Index: DZ6/trunk/libf/dyn3d/advtrac.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d/advtrac.F90	(revision 5267)
+++ 	(revision )
@@ -1,353 +1,0 @@
-! $Id$
-
-SUBROUTINE advtrac(pbaru, pbarv, p, masse,q,iapptrac,teta, flxw, pk)
-   !     Auteur :  F. Hourdin
-   !
-   !     Modif. P. Le Van     (20/12/97)
-   !            F. Codron     (10/99)
-   !            D. Le Croller (07/2001)
-   !            M.A Filiberti (04/2002)
-   !
-   USE infotrac,     ONLY: nqtot, tracers, isoCheck
-   USE control_mod,  ONLY: iapp_tracvl, day_step
-   USE comconst_mod, ONLY: dtvr
-   USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_DEBUGIO
-   USE strings_mod, ONLY: int2str
-   IMPLICIT NONE
-   !
-   include "dimensions.h"
-   include "paramet.h"
-   include "comdissip.h"
-   include "comgeom2.h"
-   include "description.h"
-   include "iniprint.h"
-
-   !---------------------------------------------------------------------------
-   !     Arguments
-   !---------------------------------------------------------------------------
-   INTEGER, INTENT(OUT) :: iapptrac
-   REAL, INTENT(IN) :: pbaru(ip1jmp1,llm)
-   REAL, INTENT(IN) :: pbarv(ip1jm,  llm)
-   REAL, INTENT(INOUT) ::  q(ip1jmp1,llm,nqtot)
-   REAL, INTENT(IN) :: masse(ip1jmp1,llm)
-   REAL, INTENT(IN) ::     p(ip1jmp1,llmp1 )
-   REAL, INTENT(IN) ::  teta(ip1jmp1,llm)
-   REAL, INTENT(IN) ::    pk(ip1jmp1,llm)
-   REAL, INTENT(OUT) :: flxw(ip1jmp1,llm)
-   !---------------------------------------------------------------------------
-   !     Ajout PPM
-   !---------------------------------------------------------------------------
-   REAL :: massebx(ip1jmp1,llm), masseby(ip1jm,llm)
-   !---------------------------------------------------------------------------
-   !     Variables locales
-   !---------------------------------------------------------------------------
-   INTEGER :: ij, l, iq, iadv
-!   REAL(KIND=KIND(1.d0)) :: t_initial, t_final, tps_cpu
-   REAL :: zdp(ip1jmp1), zdpmin, zdpmax
-   INTEGER, SAVE :: iadvtr=0
-   REAL, DIMENSION(ip1jmp1,llm) :: pbaruc, pbarug, massem, wg
-   REAL, DIMENSION(ip1jm,  llm) :: pbarvc, pbarvg
-   EXTERNAL  minmax
-   SAVE massem, pbaruc, pbarvc
-   !---------------------------------------------------------------------------
-   !     Rajouts pour PPM
-   !---------------------------------------------------------------------------
-   INTEGER indice, n
-   REAL :: dtbon                       ! Pas de temps adaptatif pour que CFL<1
-   REAL :: CFLmaxz, aaa, bbb           ! CFL maximum
-   REAL, DIMENSION(iim,jjp1,llm) :: unatppm, vnatppm, fluxwppm
-   REAL ::    qppm(iim*jjp1,llm,nqtot)
-   REAL ::   psppm(iim,jjp1)           ! pression  au sol
-   REAL, DIMENSION(llmp1) :: apppm, bpppm
-   LOGICAL, SAVE :: dum=.TRUE., fill=.TRUE.
-
-   INTEGER, SAVE :: countcfl=0
-   REAL, DIMENSION(ip1jmp1,llm) :: cflx, cflz
-   REAL, DIMENSION(ip1jm  ,llm) :: cfly
-   REAL, DIMENSION(llm), SAVE :: cflxmax, cflymax, cflzmax
-
-   IF(iadvtr == 0) THEN
-      pbaruc(:,:)=0
-      pbarvc(:,:)=0
-   END IF
-
-   !--- Accumulation des flux de masse horizontaux
-   DO l=1,llm
-      DO ij = 1,ip1jmp1
-         pbaruc(ij,l) = pbaruc(ij,l) + pbaru(ij,l)
-      END DO
-      DO ij = 1,ip1jm
-         pbarvc(ij,l) = pbarvc(ij,l) + pbarv(ij,l)
-      END DO
-   END DO
-
-   !--- Selection de la masse instantannee des mailles avant le transport.
-   IF(iadvtr == 0) THEN
-     CALL SCOPY(ip1jmp1*llm,masse,1,massem,1)
-   ! CALL filtreg ( massem ,jjp1, llm,-2, 2, .TRUE., 1 )
-   END IF
-
-   iadvtr   = iadvtr+1
-   iapptrac = iadvtr
-
-   !--- Test pour savoir si on advecte a ce pas de temps
-   IF(iadvtr /= iapp_tracvl) RETURN
-
-   !   ..  Modif P.Le Van  ( 20/12/97 )  ....
-   !
-   !   traitement des flux de masse avant advection.
-   !       1. calcul de w
-   !       2. groupement des mailles pres du pole.
-
-   CALL groupe(massem, pbaruc, pbarvc, pbarug, pbarvg, wg)
-
-   !--- Flux de masse diaganostiques traceurs
-   flxw = wg / REAL(iapp_tracvl)
-
-   !--- Test sur l'eventuelle creation de valeurs negatives de la masse
-   DO l=1,llm-1
-      DO ij = iip2+1,ip1jm
-         zdp(ij) = pbarug(ij-1,l)    - pbarug(ij,l) &
-                 - pbarvg(ij-iip1,l) + pbarvg(ij,l) &
-                 +     wg(ij,l+1)    -     wg(ij,l)
-      END DO
-! ym  ---> pourquoi jjm-1 et non jjm ? a cause du pole ?
-      CALL SCOPY( jjm -1 ,zdp(iip1+iip1),iip1,zdp(iip2),iip1 )
-      DO ij = iip2,ip1jm
-         zdp(ij)= zdp(ij)*dtvr/ massem(ij,l)
-      END DO
-
-      CALL minmax ( ip1jm-iip1, zdp(iip2), zdpmin,zdpmax )
-
-      IF(MAX(ABS(zdpmin),ABS(zdpmax)) > 0.5) &
-         WRITE(*,*)'WARNING DP/P l=',l,'  MIN:',zdpmin,' MAX:', zdpmax
-
-   END DO
-
-   !-------------------------------------------------------------------------
-   ! Calcul des criteres CFL en X, Y et Z
-   !-------------------------------------------------------------------------
-   IF(countcfl == 0. ) then
-      cflxmax(:)=0.
-      cflymax(:)=0.
-      cflzmax(:)=0.
-   END IF
-
-   countcfl=countcfl+iapp_tracvl
-   cflx(:,:)=0.
-   cfly(:,:)=0.
-   cflz(:,:)=0.
-   DO l=1,llm
-      DO ij=iip2,ip1jm-1
-         IF(pbarug(ij,l)>=0.) then
-            cflx(ij,l)=pbarug(ij,l)*dtvr/masse(ij,l)
-         ELSE
-            cflx(ij,l)=-pbarug(ij,l)*dtvr/masse(ij+1,l)
-         END IF
-      END DO
-   END DO
-
-   DO l=1,llm
-      DO ij=iip2,ip1jm-1,iip1
-         cflx(ij+iip1,l)=cflx(ij,l)
-      END DO
-   END DO
-
-   DO l=1,llm
-      DO ij=1,ip1jm
-         IF(pbarvg(ij,l)>=0.) then
-            cfly(ij,l)=pbarvg(ij,l)*dtvr/masse(ij,l)
-         ELSE
-            cfly(ij,l)=-pbarvg(ij,l)*dtvr/masse(ij+iip1,l)
-         END IF
-      END DO
-   END DO
-
-   DO l=2,llm
-      DO ij=1,ip1jm
-         IF(wg(ij,l) >= 0.) THEN
-            cflz(ij,l)=wg(ij,l)*dtvr/masse(ij,l)
-         ELSE
-            cflz(ij,l)=-wg(ij,l)*dtvr/masse(ij,l-1)
-         END IF
-      END DO
-   END DO
-
-   DO l=1,llm
-      cflxmax(l)=max(cflxmax(l),maxval(cflx(:,l)))
-      cflymax(l)=max(cflymax(l),maxval(cfly(:,l)))
-      cflzmax(l)=max(cflzmax(l),maxval(cflz(:,l)))
-   END DO
-
-   !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-   ! Par defaut, on sort le diagnostic des CFL tous les jours.
-   ! Si on veut le sortir a chaque pas d'advection en cas de plantage 
-   !       IF(countcfl==iapp_tracvl) then
-   !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-   IF(countcfl==day_step) then
-      DO l=1,llm
-         WRITE(lunout,*) 'L, CFL[xyz]max:', l, cflxmax(l), cflymax(l), cflzmax(l)
-      END DO
-      countcfl=0
-   END IF
-
-   !---------------------------------------------------------------------------
-   !   Advection proprement dite (Modification Le Croller (07/2001)
-   !---------------------------------------------------------------------------
-
-   !---------------------------------------------------------------------------
-   !   Calcul des moyennes basees sur la masse
-   !---------------------------------------------------------------------------
-   CALL massbar(massem,massebx,masseby)
-
-IF (CPPKEY_DEBUGIO) THEN
-   CALL WriteField_u('massem',massem)
-   CALL WriteField_u('wg',wg)
-   CALL WriteField_u('pbarug',pbarug)
-   CALL WriteField_v('pbarvg',pbarvg)
-   CALL WriteField_u('p_tmp',p)
-   CALL WriteField_u('pk_tmp',pk)
-   CALL WriteField_u('teta_tmp',teta)
-   DO iq=1,nqtot
-      CALL WriteField_u('q_adv'//trim(int2str(iq)),q(:,:,iq))
-   END DO
-END IF
-
-   IF(isoCheck) WRITE(*,*) 'advtrac 227'
-   CALL check_isotopes_seq(q,ip1jmp1,'advtrac 162')
-
-   !-------------------------------------------------------------------------
-   !       Appel des sous programmes d'advection
-   !-------------------------------------------------------------------------
-   DO iq = 1, nqtot
-!     CALL clock(t_initial)
-      IF(tracers(iq)%parent /= 'air') CYCLE
-      iadv = tracers(iq)%iadv
-      !-----------------------------------------------------------------------
-      SELECT CASE(iadv)
-      !-----------------------------------------------------------------------
-         CASE(0); CYCLE
-         !--------------------------------------------------------------------
-         CASE(10)  !--- Schema de Van Leer I MUSCL
-         !--------------------------------------------------------------------
-!           WRITE(*,*) 'advtrac 239: iq,q(1721,19,:)=',iq,q(1721,19,:)     
-            CALL vlsplt(q,2.,massem,wg,pbarug,pbarvg,dtvr,iq)
-
-         !--------------------------------------------------------------------
-         CASE(14)  !--- Schema "pseuDO amont" + test sur humidite specifique
-                   !--- pour la vapeur d'eau. F. Codron
-         !--------------------------------------------------------------------
-!           WRITE(*,*) 'advtrac 248: iq,q(1721,19,:)=',iq,q(1721,19,:)
-            CALL vlspltqs(q,2.,massem,wg,pbarug,pbarvg,dtvr,p,pk,teta,iq)
-
-         !--------------------------------------------------------------------
-         CASE(12)  !--- Schema de Frederic Hourdin
-         !--------------------------------------------------------------------
-            CALL adaptdt(iadv,dtbon,n,pbarug,massem)   ! pas de temps adaptatif
-            IF(n > 1) WRITE(*,*) 'WARNING horizontal dt=',dtbon,'dtvr=',dtvr,'n=',n
-            DO indice=1,n
-              CALL advn(q(1,1,iq),massem,wg,pbarug,pbarvg,dtbon,1)
-            END DO
-
-         !--------------------------------------------------------------------
-         CASE(13)  !--- Pas de temps adaptatif
-         !--------------------------------------------------------------------
-            CALL adaptdt(iadv,dtbon,n,pbarug,massem)
-            IF(n > 1) WRITE(*,*) 'WARNING horizontal dt=',dtbon,'dtvr=',dtvr,'n=',n
-            DO indice=1,n
-               CALL advn(q(1,1,iq),massem,wg,pbarug,pbarvg,dtbon,2)
-            END DO
-
-         !--------------------------------------------------------------------
-         CASE(20)  !--- Schema de pente SLOPES
-         !--------------------------------------------------------------------
-            CALL pentes_ini (q(1,1,iq),wg,massem,pbarug,pbarvg,0)
-
-         !--------------------------------------------------------------------
-         CASE(30)  !--- Schema de Prather
-         !--------------------------------------------------------------------
-            ! Pas de temps adaptatif
-            CALL adaptdt(iadv,dtbon,n,pbarug,massem)
-            IF(n > 1) WRITE(*,*) 'WARNING horizontal dt=',dtbon,'dtvr=',dtvr,'n=',n
-            CALL prather(q(1,1,iq),wg,massem,pbarug,pbarvg,n,dtbon)
-
-         !--------------------------------------------------------------------
-         CASE(11,16,17,18)   !--- Schemas PPM Lin et Rood
-         !--------------------------------------------------------------------
-            ! Test sur le flux horizontal
-            CALL adaptdt(iadv,dtbon,n,pbarug,massem)   ! pas de temps adaptatif
-            IF(n > 1) WRITE(*,*) 'WARNING horizontal dt=',dtbon,'dtvr=',dtvr,'n=',n
-            ! Test sur le flux vertical
-            CFLmaxz=0.
-            DO l=2,llm
-               DO ij=iip2,ip1jm
-                  aaa=wg(ij,l)*dtvr/massem(ij,l)
-                  CFLmaxz=max(CFLmaxz,aaa)
-                  bbb=-wg(ij,l)*dtvr/massem(ij,l-1)
-                  CFLmaxz=max(CFLmaxz,bbb)
-               END DO
-            END DO
-            IF(CFLmaxz.GE.1) WRITE(*,*) 'WARNING vertical','CFLmaxz=', CFLmaxz
-            !----------------------------------------------------------------
-            !     Ss-prg interface LMDZ.4->PPM3d (ss-prg de Lin)
-            !----------------------------------------------------------------
-            CALL interpre(q(1,1,iq),qppm(1,1,iq),wg,fluxwppm,massem, &
-                 apppm,bpppm,massebx,masseby,pbarug,pbarvg, &
-                 unatppm,vnatppm,psppm)
-
-            !----------------------------------------------------------------
-            DO indice=1,n     !--- VL (version PPM) horiz. et PPM vert.
-            !----------------------------------------------------------------
-               SELECT CASE(iadv)
-                  !----------------------------------------------------------
-                  CASE(11)
-                  !----------------------------------------------------------
-                     CALL ppm3d(1,qppm(1,1,iq),psppm,psppm,unatppm,vnatppm,fluxwppm,dtbon, &
-                                2,2,2,1,iim,jjp1,2,llm,apppm,bpppm,0.01,6400000,fill,dum,220.)
-                  !----------------------------------------------------------
-                  CASE(16) !--- Monotonic PPM
-                  !----------------------------------------------------------
-                     CALL ppm3d(1,qppm(1,1,iq),psppm,psppm,unatppm,vnatppm,fluxwppm,dtbon, &
-                                3,3,3,1,iim,jjp1,2,llm,apppm,bpppm,0.01,6400000,fill,dum,220.)
-                  !----------------------------------------------------------
-                  CASE(17) !--- Semi monotonic PPM
-                  !----------------------------------------------------------
-                     CALL ppm3d(1,qppm(1,1,iq),psppm,psppm,unatppm,vnatppm,fluxwppm,dtbon, &
-                                4,4,4,1,iim,jjp1,2,llm,apppm,bpppm,0.01,6400000, fill,dum,220.)
-                  !----------------------------------------------------------
-                  CASE(18) !--- Positive Definite PPM
-                  !----------------------------------------------------------
-                     CALL ppm3d(1,qppm(1,1,iq),psppm,psppm,unatppm,vnatppm,fluxwppm,dtbon, &
-                                5,5,5,1,iim,jjp1,2,llm,apppm,bpppm,0.01,6400000,fill,dum,220.)
-               END SELECT
-            !----------------------------------------------------------------
-            END DO
-            !----------------------------------------------------------------
-            !     Ss-prg interface PPM3d-LMDZ.4
-            !----------------------------------------------------------------
-            CALL interpost(q(1,1,iq),qppm(1,1,iq))
-      !----------------------------------------------------------------------
-      END SELECT
-      !----------------------------------------------------------------------
-
-      !----------------------------------------------------------------------
-      ! On impose une seule valeur du traceur au pole Sud j=jjm+1=jjp1 et Nord j=1
-      !----------------------------------------------------------------------
-      !  CALL traceurpole(q(1,1,iq),massem)
-
-      !--- Calcul du temps cpu pour un schema donne
-      !  CALL clock(t_final)
-      !ym  tps_cpu=t_final-t_initial
-      !ym  cpuadv(iq)=cpuadv(iq)+tps_cpu
-
-   END DO
-
-   IF(isoCheck) WRITE(*,*) 'advtrac 402'
-   CALL check_isotopes_seq(q,ip1jmp1,'advtrac 397')
-
-   !-------------------------------------------------------------------------
-   !   on reinitialise a zero les flux de masse cumules
-   !-------------------------------------------------------------------------
-   iadvtr=0
-
-END SUBROUTINE advtrac
Index: /LMDZ6/trunk/libf/dyn3d/advtrac.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d/advtrac.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3d/advtrac.f90	(revision 5268)
@@ -0,0 +1,353 @@
+! $Id$
+
+SUBROUTINE advtrac(pbaru, pbarv, p, masse,q,iapptrac,teta, flxw, pk)
+   !     Auteur :  F. Hourdin
+   !
+   !     Modif. P. Le Van     (20/12/97)
+   !            F. Codron     (10/99)
+   !            D. Le Croller (07/2001)
+   !            M.A Filiberti (04/2002)
+   !
+   USE infotrac,     ONLY: nqtot, tracers, isoCheck
+   USE control_mod,  ONLY: iapp_tracvl, day_step
+   USE comconst_mod, ONLY: dtvr
+   USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_DEBUGIO
+   USE strings_mod, ONLY: int2str
+   IMPLICIT NONE
+   !
+   include "dimensions.h"
+   include "paramet.h"
+   include "comdissip.h"
+   include "comgeom2.h"
+   include "description.h"
+   include "iniprint.h"
+
+   !---------------------------------------------------------------------------
+   !     Arguments
+   !---------------------------------------------------------------------------
+   INTEGER, INTENT(OUT) :: iapptrac
+   REAL, INTENT(IN) :: pbaru(ip1jmp1,llm)
+   REAL, INTENT(IN) :: pbarv(ip1jm,  llm)
+   REAL, INTENT(INOUT) ::  q(ip1jmp1,llm,nqtot)
+   REAL, INTENT(IN) :: masse(ip1jmp1,llm)
+   REAL, INTENT(IN) ::     p(ip1jmp1,llmp1 )
+   REAL, INTENT(IN) ::  teta(ip1jmp1,llm)
+   REAL, INTENT(IN) ::    pk(ip1jmp1,llm)
+   REAL, INTENT(OUT) :: flxw(ip1jmp1,llm)
+   !---------------------------------------------------------------------------
+   !     Ajout PPM
+   !---------------------------------------------------------------------------
+   REAL :: massebx(ip1jmp1,llm), masseby(ip1jm,llm)
+   !---------------------------------------------------------------------------
+   !     Variables locales
+   !---------------------------------------------------------------------------
+   INTEGER :: ij, l, iq, iadv
+!   REAL(KIND=KIND(1.d0)) :: t_initial, t_final, tps_cpu
+   REAL :: zdp(ip1jmp1), zdpmin, zdpmax
+   INTEGER, SAVE :: iadvtr=0
+   REAL, DIMENSION(ip1jmp1,llm) :: pbaruc, pbarug, massem, wg
+   REAL, DIMENSION(ip1jm,  llm) :: pbarvc, pbarvg
+   EXTERNAL  minmax
+   SAVE massem, pbaruc, pbarvc
+   !---------------------------------------------------------------------------
+   !     Rajouts pour PPM
+   !---------------------------------------------------------------------------
+   INTEGER indice, n
+   REAL :: dtbon                       ! Pas de temps adaptatif pour que CFL<1
+   REAL :: CFLmaxz, aaa, bbb           ! CFL maximum
+   REAL, DIMENSION(iim,jjp1,llm) :: unatppm, vnatppm, fluxwppm
+   REAL ::    qppm(iim*jjp1,llm,nqtot)
+   REAL ::   psppm(iim,jjp1)           ! pression  au sol
+   REAL, DIMENSION(llmp1) :: apppm, bpppm
+   LOGICAL, SAVE :: dum=.TRUE., fill=.TRUE.
+
+   INTEGER, SAVE :: countcfl=0
+   REAL, DIMENSION(ip1jmp1,llm) :: cflx, cflz
+   REAL, DIMENSION(ip1jm  ,llm) :: cfly
+   REAL, DIMENSION(llm), SAVE :: cflxmax, cflymax, cflzmax
+
+   IF(iadvtr == 0) THEN
+      pbaruc(:,:)=0
+      pbarvc(:,:)=0
+   END IF
+
+   !--- Accumulation des flux de masse horizontaux
+   DO l=1,llm
+      DO ij = 1,ip1jmp1
+         pbaruc(ij,l) = pbaruc(ij,l) + pbaru(ij,l)
+      END DO
+      DO ij = 1,ip1jm
+         pbarvc(ij,l) = pbarvc(ij,l) + pbarv(ij,l)
+      END DO
+   END DO
+
+   !--- Selection de la masse instantannee des mailles avant le transport.
+   IF(iadvtr == 0) THEN
+     CALL SCOPY(ip1jmp1*llm,masse,1,massem,1)
+   ! CALL filtreg ( massem ,jjp1, llm,-2, 2, .TRUE., 1 )
+   END IF
+
+   iadvtr   = iadvtr+1
+   iapptrac = iadvtr
+
+   !--- Test pour savoir si on advecte a ce pas de temps
+   IF(iadvtr /= iapp_tracvl) RETURN
+
+   !   ..  Modif P.Le Van  ( 20/12/97 )  ....
+   !
+   !   traitement des flux de masse avant advection.
+   !       1. calcul de w
+   !       2. groupement des mailles pres du pole.
+
+   CALL groupe(massem, pbaruc, pbarvc, pbarug, pbarvg, wg)
+
+   !--- Flux de masse diaganostiques traceurs
+   flxw = wg / REAL(iapp_tracvl)
+
+   !--- Test sur l'eventuelle creation de valeurs negatives de la masse
+   DO l=1,llm-1
+      DO ij = iip2+1,ip1jm
+         zdp(ij) = pbarug(ij-1,l)    - pbarug(ij,l) &
+                 - pbarvg(ij-iip1,l) + pbarvg(ij,l) &
+                 +     wg(ij,l+1)    -     wg(ij,l)
+      END DO
+! ym  ---> pourquoi jjm-1 et non jjm ? a cause du pole ?
+      CALL SCOPY( jjm -1 ,zdp(iip1+iip1),iip1,zdp(iip2),iip1 )
+      DO ij = iip2,ip1jm
+         zdp(ij)= zdp(ij)*dtvr/ massem(ij,l)
+      END DO
+
+      CALL minmax ( ip1jm-iip1, zdp(iip2), zdpmin,zdpmax )
+
+      IF(MAX(ABS(zdpmin),ABS(zdpmax)) > 0.5) &
+         WRITE(*,*)'WARNING DP/P l=',l,'  MIN:',zdpmin,' MAX:', zdpmax
+
+   END DO
+
+   !-------------------------------------------------------------------------
+   ! Calcul des criteres CFL en X, Y et Z
+   !-------------------------------------------------------------------------
+   IF(countcfl == 0. ) then
+      cflxmax(:)=0.
+      cflymax(:)=0.
+      cflzmax(:)=0.
+   END IF
+
+   countcfl=countcfl+iapp_tracvl
+   cflx(:,:)=0.
+   cfly(:,:)=0.
+   cflz(:,:)=0.
+   DO l=1,llm
+      DO ij=iip2,ip1jm-1
+         IF(pbarug(ij,l)>=0.) then
+            cflx(ij,l)=pbarug(ij,l)*dtvr/masse(ij,l)
+         ELSE
+            cflx(ij,l)=-pbarug(ij,l)*dtvr/masse(ij+1,l)
+         END IF
+      END DO
+   END DO
+
+   DO l=1,llm
+      DO ij=iip2,ip1jm-1,iip1
+         cflx(ij+iip1,l)=cflx(ij,l)
+      END DO
+   END DO
+
+   DO l=1,llm
+      DO ij=1,ip1jm
+         IF(pbarvg(ij,l)>=0.) then
+            cfly(ij,l)=pbarvg(ij,l)*dtvr/masse(ij,l)
+         ELSE
+            cfly(ij,l)=-pbarvg(ij,l)*dtvr/masse(ij+iip1,l)
+         END IF
+      END DO
+   END DO
+
+   DO l=2,llm
+      DO ij=1,ip1jm
+         IF(wg(ij,l) >= 0.) THEN
+            cflz(ij,l)=wg(ij,l)*dtvr/masse(ij,l)
+         ELSE
+            cflz(ij,l)=-wg(ij,l)*dtvr/masse(ij,l-1)
+         END IF
+      END DO
+   END DO
+
+   DO l=1,llm
+      cflxmax(l)=max(cflxmax(l),maxval(cflx(:,l)))
+      cflymax(l)=max(cflymax(l),maxval(cfly(:,l)))
+      cflzmax(l)=max(cflzmax(l),maxval(cflz(:,l)))
+   END DO
+
+   !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+   ! Par defaut, on sort le diagnostic des CFL tous les jours.
+   ! Si on veut le sortir a chaque pas d'advection en cas de plantage 
+   !       IF(countcfl==iapp_tracvl) then
+   !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+   IF(countcfl==day_step) then
+      DO l=1,llm
+         WRITE(lunout,*) 'L, CFL[xyz]max:', l, cflxmax(l), cflymax(l), cflzmax(l)
+      END DO
+      countcfl=0
+   END IF
+
+   !---------------------------------------------------------------------------
+   !   Advection proprement dite (Modification Le Croller (07/2001)
+   !---------------------------------------------------------------------------
+
+   !---------------------------------------------------------------------------
+   !   Calcul des moyennes basees sur la masse
+   !---------------------------------------------------------------------------
+   CALL massbar(massem,massebx,masseby)
+
+IF (CPPKEY_DEBUGIO) THEN
+   CALL WriteField_u('massem',massem)
+   CALL WriteField_u('wg',wg)
+   CALL WriteField_u('pbarug',pbarug)
+   CALL WriteField_v('pbarvg',pbarvg)
+   CALL WriteField_u('p_tmp',p)
+   CALL WriteField_u('pk_tmp',pk)
+   CALL WriteField_u('teta_tmp',teta)
+   DO iq=1,nqtot
+      CALL WriteField_u('q_adv'//trim(int2str(iq)),q(:,:,iq))
+   END DO
+END IF
+
+   IF(isoCheck) WRITE(*,*) 'advtrac 227'
+   CALL check_isotopes_seq(q,ip1jmp1,'advtrac 162')
+
+   !-------------------------------------------------------------------------
+   !       Appel des sous programmes d'advection
+   !-------------------------------------------------------------------------
+   DO iq = 1, nqtot
+!     CALL clock(t_initial)
+      IF(tracers(iq)%parent /= 'air') CYCLE
+      iadv = tracers(iq)%iadv
+      !-----------------------------------------------------------------------
+      SELECT CASE(iadv)
+      !-----------------------------------------------------------------------
+         CASE(0); CYCLE
+         !--------------------------------------------------------------------
+         CASE(10)  !--- Schema de Van Leer I MUSCL
+         !--------------------------------------------------------------------
+!           WRITE(*,*) 'advtrac 239: iq,q(1721,19,:)=',iq,q(1721,19,:)     
+            CALL vlsplt(q,2.,massem,wg,pbarug,pbarvg,dtvr,iq)
+
+         !--------------------------------------------------------------------
+         CASE(14)  !--- Schema "pseuDO amont" + test sur humidite specifique
+                   !--- pour la vapeur d'eau. F. Codron
+         !--------------------------------------------------------------------
+!           WRITE(*,*) 'advtrac 248: iq,q(1721,19,:)=',iq,q(1721,19,:)
+            CALL vlspltqs(q,2.,massem,wg,pbarug,pbarvg,dtvr,p,pk,teta,iq)
+
+         !--------------------------------------------------------------------
+         CASE(12)  !--- Schema de Frederic Hourdin
+         !--------------------------------------------------------------------
+            CALL adaptdt(iadv,dtbon,n,pbarug,massem)   ! pas de temps adaptatif
+            IF(n > 1) WRITE(*,*) 'WARNING horizontal dt=',dtbon,'dtvr=',dtvr,'n=',n
+            DO indice=1,n
+              CALL advn(q(1,1,iq),massem,wg,pbarug,pbarvg,dtbon,1)
+            END DO
+
+         !--------------------------------------------------------------------
+         CASE(13)  !--- Pas de temps adaptatif
+         !--------------------------------------------------------------------
+            CALL adaptdt(iadv,dtbon,n,pbarug,massem)
+            IF(n > 1) WRITE(*,*) 'WARNING horizontal dt=',dtbon,'dtvr=',dtvr,'n=',n
+            DO indice=1,n
+               CALL advn(q(1,1,iq),massem,wg,pbarug,pbarvg,dtbon,2)
+            END DO
+
+         !--------------------------------------------------------------------
+         CASE(20)  !--- Schema de pente SLOPES
+         !--------------------------------------------------------------------
+            CALL pentes_ini (q(1,1,iq),wg,massem,pbarug,pbarvg,0)
+
+         !--------------------------------------------------------------------
+         CASE(30)  !--- Schema de Prather
+         !--------------------------------------------------------------------
+            ! Pas de temps adaptatif
+            CALL adaptdt(iadv,dtbon,n,pbarug,massem)
+            IF(n > 1) WRITE(*,*) 'WARNING horizontal dt=',dtbon,'dtvr=',dtvr,'n=',n
+            CALL prather(q(1,1,iq),wg,massem,pbarug,pbarvg,n,dtbon)
+
+         !--------------------------------------------------------------------
+         CASE(11,16,17,18)   !--- Schemas PPM Lin et Rood
+         !--------------------------------------------------------------------
+            ! Test sur le flux horizontal
+            CALL adaptdt(iadv,dtbon,n,pbarug,massem)   ! pas de temps adaptatif
+            IF(n > 1) WRITE(*,*) 'WARNING horizontal dt=',dtbon,'dtvr=',dtvr,'n=',n
+            ! Test sur le flux vertical
+            CFLmaxz=0.
+            DO l=2,llm
+               DO ij=iip2,ip1jm
+                  aaa=wg(ij,l)*dtvr/massem(ij,l)
+                  CFLmaxz=max(CFLmaxz,aaa)
+                  bbb=-wg(ij,l)*dtvr/massem(ij,l-1)
+                  CFLmaxz=max(CFLmaxz,bbb)
+               END DO
+            END DO
+            IF(CFLmaxz.GE.1) WRITE(*,*) 'WARNING vertical','CFLmaxz=', CFLmaxz
+            !----------------------------------------------------------------
+            !     Ss-prg interface LMDZ.4->PPM3d (ss-prg de Lin)
+            !----------------------------------------------------------------
+            CALL interpre(q(1,1,iq),qppm(1,1,iq),wg,fluxwppm,massem, &
+                 apppm,bpppm,massebx,masseby,pbarug,pbarvg, &
+                 unatppm,vnatppm,psppm)
+
+            !----------------------------------------------------------------
+            DO indice=1,n     !--- VL (version PPM) horiz. et PPM vert.
+            !----------------------------------------------------------------
+               SELECT CASE(iadv)
+                  !----------------------------------------------------------
+                  CASE(11)
+                  !----------------------------------------------------------
+                     CALL ppm3d(1,qppm(1,1,iq),psppm,psppm,unatppm,vnatppm,fluxwppm,dtbon, &
+                                2,2,2,1,iim,jjp1,2,llm,apppm,bpppm,0.01,6400000,fill,dum,220.)
+                  !----------------------------------------------------------
+                  CASE(16) !--- Monotonic PPM
+                  !----------------------------------------------------------
+                     CALL ppm3d(1,qppm(1,1,iq),psppm,psppm,unatppm,vnatppm,fluxwppm,dtbon, &
+                                3,3,3,1,iim,jjp1,2,llm,apppm,bpppm,0.01,6400000,fill,dum,220.)
+                  !----------------------------------------------------------
+                  CASE(17) !--- Semi monotonic PPM
+                  !----------------------------------------------------------
+                     CALL ppm3d(1,qppm(1,1,iq),psppm,psppm,unatppm,vnatppm,fluxwppm,dtbon, &
+                                4,4,4,1,iim,jjp1,2,llm,apppm,bpppm,0.01,6400000, fill,dum,220.)
+                  !----------------------------------------------------------
+                  CASE(18) !--- Positive Definite PPM
+                  !----------------------------------------------------------
+                     CALL ppm3d(1,qppm(1,1,iq),psppm,psppm,unatppm,vnatppm,fluxwppm,dtbon, &
+                                5,5,5,1,iim,jjp1,2,llm,apppm,bpppm,0.01,6400000,fill,dum,220.)
+               END SELECT
+            !----------------------------------------------------------------
+            END DO
+            !----------------------------------------------------------------
+            !     Ss-prg interface PPM3d-LMDZ.4
+            !----------------------------------------------------------------
+            CALL interpost(q(1,1,iq),qppm(1,1,iq))
+      !----------------------------------------------------------------------
+      END SELECT
+      !----------------------------------------------------------------------
+
+      !----------------------------------------------------------------------
+      ! On impose une seule valeur du traceur au pole Sud j=jjm+1=jjp1 et Nord j=1
+      !----------------------------------------------------------------------
+      !  CALL traceurpole(q(1,1,iq),massem)
+
+      !--- Calcul du temps cpu pour un schema donne
+      !  CALL clock(t_final)
+      !ym  tps_cpu=t_final-t_initial
+      !ym  cpuadv(iq)=cpuadv(iq)+tps_cpu
+
+   END DO
+
+   IF(isoCheck) WRITE(*,*) 'advtrac 402'
+   CALL check_isotopes_seq(q,ip1jmp1,'advtrac 397')
+
+   !-------------------------------------------------------------------------
+   !   on reinitialise a zero les flux de masse cumules
+   !-------------------------------------------------------------------------
+   iadvtr=0
+
+END SUBROUTINE advtrac
Index: DZ6/trunk/libf/dyn3d/bilan_dyn.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d/bilan_dyn.F90	(revision 5267)
+++ 	(revision )
@@ -1,584 +1,0 @@
-!
-! $Id$
-!
-SUBROUTINE bilan_dyn (ntrac,dt_app,dt_cum, &
-        ps,masse,pk,flux_u,flux_v,teta,phi,ucov,vcov,trac)
-
-  !   AFAIRE
-  !   Prevoir en champ nq+1 le diagnostique de l'energie
-  !   en faisant Qzon=Cv T + L * ...
-  !             vQ..A=Cp T + L * ...
-
-  USE IOIPSL
-  USE comconst_mod, ONLY: pi, cpp
-  USE comvert_mod, ONLY: presnivs
-  USE temps_mod, ONLY: annee_ref, day_ref, itau_dyn
-
-  IMPLICIT NONE
-
-  include "dimensions.h"
-  include "paramet.h"
-  include "comgeom2.h"
-  include "iniprint.h"
-
-  !====================================================================
-  !
-  !   Sous-programme consacre � des diagnostics dynamiques de base
-  !
-  !
-  !   De facon generale, les moyennes des scalaires Q sont ponderees par
-  !   la masse.
-  !
-  !   Les flux de masse sont eux simplement moyennes.
-  !
-  !====================================================================
-
-  !   Arguments :
-  !   ===========
-
-  integer :: ntrac
-  real :: dt_app,dt_cum
-  real :: ps(iip1,jjp1)
-  real :: masse(iip1,jjp1,llm),pk(iip1,jjp1,llm)
-  real :: flux_u(iip1,jjp1,llm)
-  real :: flux_v(iip1,jjm,llm)
-  real :: teta(iip1,jjp1,llm)
-  real :: phi(iip1,jjp1,llm)
-  real :: ucov(iip1,jjp1,llm)
-  real :: vcov(iip1,jjm,llm)
-  real :: trac(iip1,jjp1,llm,ntrac)
-
-  !   Local :
-  !   =======
-
-  integer :: icum,ncum
-  logical :: first
-  real :: zz,zqy,zfactv(jjm,llm)
-
-  integer :: nQ
-  parameter (nQ=7)
-
-
-  !ym      character*6 nom(nQ)
-  !ym      character*6 unites(nQ)
-  character*6,save :: nom(nQ)
-  character*6,save :: unites(nQ)
-
-  character(len=10) :: file
-  integer :: ifile
-  parameter (ifile=4)
-
-  integer :: itemp,igeop,iecin,iang,iu,iovap,iun
-  integer :: i_sortie
-
-  save first,icum,ncum
-  save itemp,igeop,iecin,iang,iu,iovap,iun
-  save i_sortie
-
-  real :: time
-  integer :: itau
-  save time,itau
-  data time,itau/0.,0/
-
-  data first/.true./
-  data itemp,igeop,iecin,iang,iu,iovap,iun/1,2,3,4,5,6,7/
-  data i_sortie/1/
-
-  real :: ww
-
-  !   variables dynamiques interm�diaires
-  REAL :: vcont(iip1,jjm,llm),ucont(iip1,jjp1,llm)
-  REAL :: ang(iip1,jjp1,llm),unat(iip1,jjp1,llm)
-  REAL :: massebx(iip1,jjp1,llm),masseby(iip1,jjm,llm)
-  REAL :: vorpot(iip1,jjm,llm)
-  REAL :: w(iip1,jjp1,llm),ecin(iip1,jjp1,llm),convm(iip1,jjp1,llm)
-  REAL :: bern(iip1,jjp1,llm)
-
-  !   champ contenant les scalaires advect�s.
-  real :: Q(iip1,jjp1,llm,nQ)
-
-  !   champs cumul�s
-  real :: ps_cum(iip1,jjp1)
-  real :: masse_cum(iip1,jjp1,llm)
-  real :: flux_u_cum(iip1,jjp1,llm)
-  real :: flux_v_cum(iip1,jjm,llm)
-  real :: Q_cum(iip1,jjp1,llm,nQ)
-  real :: flux_uQ_cum(iip1,jjp1,llm,nQ)
-  real :: flux_vQ_cum(iip1,jjm,llm,nQ)
-  real :: flux_wQ_cum(iip1,jjp1,llm,nQ)
-  real :: dQ(iip1,jjp1,llm,nQ)
-
-  save ps_cum,masse_cum,flux_u_cum,flux_v_cum
-  save Q_cum,flux_uQ_cum,flux_vQ_cum
-
-  !   champs de tansport en moyenne zonale
-  integer :: ntr,itr
-  parameter (ntr=5)
-
-  !ym      character*10 znom(ntr,nQ)
-  !ym      character*20 znoml(ntr,nQ)
-  !ym      character*10 zunites(ntr,nQ)
-  character*10,save :: znom(ntr,nQ)
-  character*20,save :: znoml(ntr,nQ)
-  character*10,save :: zunites(ntr,nQ)
-
-  integer :: iave,itot,immc,itrs,istn
-  data iave,itot,immc,itrs,istn/1,2,3,4,5/
-  character(len=3) :: ctrs(ntr)
-  data ctrs/'  ','TOT','MMC','TRS','STN'/
-
-  real :: zvQ(jjm,llm,ntr,nQ),zvQtmp(jjm,llm)
-  real :: zavQ(jjm,ntr,nQ),psiQ(jjm,llm+1,nQ)
-  real :: zmasse(jjm,llm),zamasse(jjm)
-
-  real :: zv(jjm,llm),psi(jjm,llm+1)
-
-  integer :: i,j,l,iQ
-
-
-  !   Initialisation du fichier contenant les moyennes zonales.
-  !   ---------------------------------------------------------
-
-  character(len=10) :: infile
-
-  integer :: fileid
-  integer :: thoriid, zvertiid
-  save fileid
-
-  integer :: ndex3d(jjm*llm)
-
-  !   Variables locales
-  !
-  integer :: tau0
-  real :: zjulian
-  character(len=3) :: str
-  character(len=10) :: ctrac
-  integer :: ii,jj
-  integer :: zan, dayref
-  !
-  real :: rlong(jjm),rlatg(jjm)
-
-
-
-  !=====================================================================
-  !   Initialisation
-  !=====================================================================
-
-  time=time+dt_app
-  itau=itau+1
-  !IM
-  ndex3d=0
-
-  if (first) then
-
-
-    icum=0
-    ! initialisation des fichiers
-    first=.false.
-  !   ncum est la frequence de stokage en pas de temps
-    ncum=dt_cum/dt_app
-    if (abs(ncum*dt_app-dt_cum).gt.1.e-5*dt_app) then
-       WRITE(lunout,*) &
-             'Pb : le pas de cumule doit etre multiple du pas'
-       WRITE(lunout,*)'dt_app=',dt_app
-       WRITE(lunout,*)'dt_cum=',dt_cum
-       call abort_gcm('bilan_dyn','stopped',1)
-    endif
-
-    if (i_sortie.eq.1) then
-     file='dynzon'
-     call inigrads(ifile,1 &
-           ,0.,180./pi,0.,0.,jjm,rlatv,-90.,90.,180./pi &
-           ,llm,presnivs,1. &
-           ,dt_cum,file,'dyn_zon ')
-    endif
-
-    nom(itemp)='T'
-    nom(igeop)='gz'
-    nom(iecin)='K'
-    nom(iang)='ang'
-    nom(iu)='u'
-    nom(iovap)='ovap'
-    nom(iun)='un'
-
-    unites(itemp)='K'
-    unites(igeop)='m2/s2'
-    unites(iecin)='m2/s2'
-    unites(iang)='ang'
-    unites(iu)='m/s'
-    unites(iovap)='kg/kg'
-    unites(iun)='un'
-
-
-  !   Initialisation du fichier contenant les moyennes zonales.
-  !   ---------------------------------------------------------
-
-  infile='dynzon'
-
-  zan = annee_ref
-  dayref = day_ref
-  CALL ymds2ju(zan, 1, dayref, 0.0, zjulian)
-  tau0 = itau_dyn
-
-  rlong=0.
-  rlatg=rlatv*180./pi
-
-  call histbeg(infile, 1, rlong, jjm, rlatg, &
-        1, 1, 1, jjm, &
-        tau0, zjulian, dt_cum, thoriid, fileid)
-
-  !
-  !  Appel a histvert pour la grille verticale
-  !
-  call histvert(fileid, 'presnivs', 'Niveaux sigma','mb', &
-        llm, presnivs, zvertiid)
-  !
-  !  Appels a histdef pour la definition des variables a sauvegarder
-  do iQ=1,nQ
-     do itr=1,ntr
-        if(itr.eq.1) then
-           znom(itr,iQ)=nom(iQ)
-           znoml(itr,iQ)=nom(iQ)
-           zunites(itr,iQ)=unites(iQ)
-        else
-           znom(itr,iQ)=ctrs(itr)//'v'//nom(iQ)
-           znoml(itr,iQ)='transport : v * '//nom(iQ)//' '//ctrs(itr)
-           zunites(itr,iQ)='m/s * '//unites(iQ)
-        endif
-     enddo
-  enddo
-
-  !   Declarations des champs avec dimension verticale
-   ! print*,'1HISTDEF'
-  do iQ=1,nQ
-     do itr=1,ntr
-  IF (prt_level > 5) &
-        WRITE(lunout,*)'var ',itr,iQ &
-        ,znom(itr,iQ),znoml(itr,iQ),zunites(itr,iQ)
-        call histdef(fileid,znom(itr,iQ),znoml(itr,iQ), &
-              zunites(itr,iQ),1,jjm,thoriid,llm,1,llm,zvertiid, &
-              32,'ave(X)',dt_cum,dt_cum)
-     enddo
-  !   Declarations pour les fonctions de courant
-   ! print*,'2HISTDEF'
-      call histdef(fileid,'psi'//nom(iQ) &
-            ,'stream fn. '//znoml(itot,iQ), &
-            zunites(itot,iQ),1,jjm,thoriid,llm,1,llm,zvertiid, &
-            32,'ave(X)',dt_cum,dt_cum)
-  enddo
-
-
-  !   Declarations pour les champs de transport d'air
-   ! print*,'3HISTDEF'
-  call histdef(fileid, 'masse', 'masse', &
-        'kg', 1, jjm, thoriid, llm, 1, llm, zvertiid, &
-        32, 'ave(X)', dt_cum, dt_cum)
-  call histdef(fileid, 'v', 'v', &
-        'm/s', 1, jjm, thoriid, llm, 1, llm, zvertiid, &
-        32, 'ave(X)', dt_cum, dt_cum)
-  !   Declarations pour les fonctions de courant
-   ! print*,'4HISTDEF'
-      call histdef(fileid,'psi','stream fn. MMC ','mega t/s', &
-            1,jjm,thoriid,llm,1,llm,zvertiid, &
-            32,'ave(X)',dt_cum,dt_cum)
-
-
-  !   Declaration des champs 1D de transport en latitude
-   ! print*,'5HISTDEF'
-  do iQ=1,nQ
-     do itr=2,ntr
-        call histdef(fileid,'a'//znom(itr,iQ),znoml(itr,iQ), &
-              zunites(itr,iQ),1,jjm,thoriid,1,1,1,-99, &
-              32,'ave(X)',dt_cum,dt_cum)
-     enddo
-  enddo
-
-
-   ! print*,'8HISTDEF'
-           CALL histend(fileid)
-
-
-  endif
-
-
-  !=====================================================================
-  !   Calcul des champs dynamiques
-  !   ----------------------------
-
-  !   �nergie cin�tique
-  ucont(:,:,:)=0
-  CALL covcont(llm,ucov,vcov,ucont,vcont)
-  CALL enercin(vcov,ucov,vcont,ucont,ecin)
-
-  !   moment cin�tique
-  do l=1,llm
-     ang(:,:,l)=ucov(:,:,l)+constang(:,:)
-     unat(:,:,l)=ucont(:,:,l)*cu(:,:)
-  enddo
-
-  Q(:,:,:,itemp)=teta(:,:,:)*pk(:,:,:)/cpp
-  Q(:,:,:,igeop)=phi(:,:,:)
-  Q(:,:,:,iecin)=ecin(:,:,:)
-  Q(:,:,:,iang)=ang(:,:,:)
-  Q(:,:,:,iu)=unat(:,:,:)
-  Q(:,:,:,iovap)=trac(:,:,:,1)
-  Q(:,:,:,iun)=1.
-
-
-  !=====================================================================
-  !   Cumul
-  !=====================================================================
-  !
-  if(icum.EQ.0) then
-     ps_cum=0.
-     masse_cum=0.
-     flux_u_cum=0.
-     flux_v_cum=0.
-     Q_cum=0.
-     flux_vQ_cum=0.
-     flux_uQ_cum=0.
-  endif
-
-  IF (prt_level > 5) &
-        WRITE(lunout,*)'dans bilan_dyn ',icum,'->',icum+1
-  icum=icum+1
-
-  !   accumulation des flux de masse horizontaux
-  ps_cum=ps_cum+ps
-  masse_cum=masse_cum+masse
-  flux_u_cum=flux_u_cum+flux_u
-  flux_v_cum=flux_v_cum+flux_v
-  do iQ=1,nQ
-  Q_cum(:,:,:,iQ)=Q_cum(:,:,:,iQ)+Q(:,:,:,iQ)*masse(:,:,:)
-  enddo
-
-  !=====================================================================
-  !  FLUX ET TENDANCES
-  !=====================================================================
-
-  !   Flux longitudinal
-  !   -----------------
-  do iQ=1,nQ
-     do l=1,llm
-        do j=1,jjp1
-           do i=1,iim
-              flux_uQ_cum(i,j,l,iQ)=flux_uQ_cum(i,j,l,iQ) &
-                    +flux_u(i,j,l)*0.5*(Q(i,j,l,iQ)+Q(i+1,j,l,iQ))
-           enddo
-           flux_uQ_cum(iip1,j,l,iQ)=flux_uQ_cum(1,j,l,iQ)
-        enddo
-     enddo
-  enddo
-
-  !    flux m�ridien
-  !    -------------
-  do iQ=1,nQ
-     do l=1,llm
-        do j=1,jjm
-           do i=1,iip1
-              flux_vQ_cum(i,j,l,iQ)=flux_vQ_cum(i,j,l,iQ) &
-                    +flux_v(i,j,l)*0.5*(Q(i,j,l,iQ)+Q(i,j+1,l,iQ))
-           enddo
-        enddo
-     enddo
-  enddo
-
-
-  !    tendances
-  !    ---------
-
-  !   convergence horizontale
-  call  convflu(flux_uQ_cum,flux_vQ_cum,llm*nQ,dQ)
-
-  !   calcul de la vitesse verticale
-  call convmas(flux_u_cum,flux_v_cum,convm)
-  CALL vitvert(convm,w)
-
-  do iQ=1,nQ
-     do l=1,llm-1
-        do j=1,jjp1
-           do i=1,iip1
-              ww=-0.5*w(i,j,l+1)*(Q(i,j,l,iQ)+Q(i,j,l+1,iQ))
-              dQ(i,j,l  ,iQ)=dQ(i,j,l  ,iQ)-ww
-              dQ(i,j,l+1,iQ)=dQ(i,j,l+1,iQ)+ww
-           enddo
-        enddo
-     enddo
-  enddo
-  IF (prt_level > 5) &
-        WRITE(lunout,*)'Apres les calculs fait a chaque pas'
-  !=====================================================================
-  !   PAS DE TEMPS D'ECRITURE
-  !=====================================================================
-  if (icum.eq.ncum) then
-  !=====================================================================
-
-  IF (prt_level > 5) &
-        WRITE(lunout,*)'Pas d ecriture'
-
-  !   Normalisation
-  do iQ=1,nQ
-     Q_cum(:,:,:,iQ)=Q_cum(:,:,:,iQ)/masse_cum(:,:,:)
-  enddo
-  zz=1./REAL(ncum)
-  ps_cum=ps_cum*zz
-  masse_cum=masse_cum*zz
-  flux_u_cum=flux_u_cum*zz
-  flux_v_cum=flux_v_cum*zz
-  flux_uQ_cum=flux_uQ_cum*zz
-  flux_vQ_cum=flux_vQ_cum*zz
-  dQ=dQ*zz
-
-
-  !   A retravailler eventuellement
-  !   division de dQ par la masse pour revenir aux bonnes grandeurs
-  do iQ=1,nQ
-     dQ(:,:,:,iQ)=dQ(:,:,:,iQ)/masse_cum(:,:,:)
-  enddo
-
-  !=====================================================================
-  !   Transport m�ridien
-  !=====================================================================
-
-  !   cumul zonal des masses des mailles
-  !   ----------------------------------
-  zv=0.
-  zmasse=0.
-  call massbar(masse_cum,massebx,masseby)
-  do l=1,llm
-     do j=1,jjm
-        do i=1,iim
-           zmasse(j,l)=zmasse(j,l)+masseby(i,j,l)
-           zv(j,l)=zv(j,l)+flux_v_cum(i,j,l)
-        enddo
-        zfactv(j,l)=cv(1,j)/zmasse(j,l)
-     enddo
-  enddo
-
-  ! print*,'3OK'
-  !   --------------------------------------------------------------
-  !   calcul de la moyenne zonale du transport :
-  !   ------------------------------------------
-  !
-  !                                 --
-  ! TOT : la circulation totale       [ vq ]
-  !
-  !                                  -     -
-  ! MMC : mean meridional circulation [ v ] [ q ]
-  !
-  !                                 ----      --       - -
-  ! TRS : transitoires                [ v'q'] = [ vq ] - [ v q ]
-  !
-  !                                 - * - *       - -       -     -
-  ! STT : stationaires                [ v   q   ] = [ v q ] - [ v ] [ q ]
-  !
-  !                                          - -
-  !    on utilise aussi l'intermediaire TMP :  [ v q ]
-  !
-  !    la variable zfactv transforme un transport meridien cumule
-  !    en kg/s * unte-du-champ-transporte en m/s * unite-du-champ-transporte
-  !
-  !   --------------------------------------------------------------
-
-
-  !   ----------------------------------------
-  !   Transport dans le plan latitude-altitude
-  !   ----------------------------------------
-
-  zvQ=0.
-  psiQ=0.
-  do iQ=1,nQ
-     zvQtmp=0.
-     do l=1,llm
-        do j=1,jjm
-           ! print*,'j,l,iQ=',j,l,iQ
-  !   Calcul des moyennes zonales du transort total et de zvQtmp
-           do i=1,iim
-              zvQ(j,l,itot,iQ)=zvQ(j,l,itot,iQ) &
-                    +flux_vQ_cum(i,j,l,iQ)
-              zqy=      0.5*(Q_cum(i,j,l,iQ)*masse_cum(i,j,l)+ &
-                    Q_cum(i,j+1,l,iQ)*masse_cum(i,j+1,l))
-              zvQtmp(j,l)=zvQtmp(j,l)+flux_v_cum(i,j,l)*zqy &
-                    /(0.5*(masse_cum(i,j,l)+masse_cum(i,j+1,l)))
-              zvQ(j,l,iave,iQ)=zvQ(j,l,iave,iQ)+zqy
-           enddo
-           ! print*,'aOK'
-  !   Decomposition
-           zvQ(j,l,iave,iQ)=zvQ(j,l,iave,iQ)/zmasse(j,l)
-           zvQ(j,l,itot,iQ)=zvQ(j,l,itot,iQ)*zfactv(j,l)
-           zvQtmp(j,l)=zvQtmp(j,l)*zfactv(j,l)
-           zvQ(j,l,immc,iQ)=zv(j,l)*zvQ(j,l,iave,iQ)*zfactv(j,l)
-           zvQ(j,l,itrs,iQ)=zvQ(j,l,itot,iQ)-zvQtmp(j,l)
-           zvQ(j,l,istn,iQ)=zvQtmp(j,l)-zvQ(j,l,immc,iQ)
-        enddo
-     enddo
-  !   fonction de courant meridienne pour la quantite Q
-     do l=llm,1,-1
-        do j=1,jjm
-           psiQ(j,l,iQ)=psiQ(j,l+1,iQ)+zvQ(j,l,itot,iQ)
-        enddo
-     enddo
-  enddo
-
-  !   fonction de courant pour la circulation meridienne moyenne
-  psi=0.
-  do l=llm,1,-1
-     do j=1,jjm
-        psi(j,l)=psi(j,l+1)+zv(j,l)
-        zv(j,l)=zv(j,l)*zfactv(j,l)
-     enddo
-  enddo
-
-  ! print*,'4OK'
-  !   sorties proprement dites
-  if (i_sortie.eq.1) then
-  do iQ=1,nQ
-     do itr=1,ntr
-        call histwrite(fileid,znom(itr,iQ),itau,zvQ(:,:,itr,iQ) &
-              ,jjm*llm,ndex3d)
-     enddo
-     call histwrite(fileid,'psi'//nom(iQ),itau,psiQ(:,1:llm,iQ) &
-           ,jjm*llm,ndex3d)
-  enddo
-
-  call histwrite(fileid,'masse',itau,zmasse &
-        ,jjm*llm,ndex3d)
-  call histwrite(fileid,'v',itau,zv &
-        ,jjm*llm,ndex3d)
-  psi=psi*1.e-9
-  call histwrite(fileid,'psi',itau,psi(:,1:llm),jjm*llm,ndex3d)
-
-  endif
-
-
-  !   -----------------
-  !   Moyenne verticale
-  !   -----------------
-
-  zamasse=0.
-  do l=1,llm
-     zamasse(:)=zamasse(:)+zmasse(:,l)
-  enddo
-  zavQ=0.
-  do iQ=1,nQ
-     do itr=2,ntr
-        do l=1,llm
-           zavQ(:,itr,iQ)=zavQ(:,itr,iQ)+zvQ(:,l,itr,iQ)*zmasse(:,l)
-        enddo
-        zavQ(:,itr,iQ)=zavQ(:,itr,iQ)/zamasse(:)
-        call histwrite(fileid,'a'//znom(itr,iQ),itau,zavQ(:,itr,iQ) &
-              ,jjm*llm,ndex3d)
-     enddo
-  enddo
-
-  ! on doit pouvoir tracer systematiquement la fonction de courant.
-
-  !=====================================================================
-  !/////////////////////////////////////////////////////////////////////
-  icum=0                  !///////////////////////////////////////
-  endif ! icum.eq.ncum    !///////////////////////////////////////
-  !/////////////////////////////////////////////////////////////////////
-  !=====================================================================
-
-  return
-end subroutine bilan_dyn
Index: /LMDZ6/trunk/libf/dyn3d/bilan_dyn.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d/bilan_dyn.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3d/bilan_dyn.f90	(revision 5268)
@@ -0,0 +1,584 @@
+!
+! $Id$
+!
+SUBROUTINE bilan_dyn (ntrac,dt_app,dt_cum, &
+        ps,masse,pk,flux_u,flux_v,teta,phi,ucov,vcov,trac)
+
+  !   AFAIRE
+  !   Prevoir en champ nq+1 le diagnostique de l'energie
+  !   en faisant Qzon=Cv T + L * ...
+  !             vQ..A=Cp T + L * ...
+
+  USE IOIPSL
+  USE comconst_mod, ONLY: pi, cpp
+  USE comvert_mod, ONLY: presnivs
+  USE temps_mod, ONLY: annee_ref, day_ref, itau_dyn
+
+  IMPLICIT NONE
+
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom2.h"
+  include "iniprint.h"
+
+  !====================================================================
+  !
+  !   Sous-programme consacre � des diagnostics dynamiques de base
+  !
+  !
+  !   De facon generale, les moyennes des scalaires Q sont ponderees par
+  !   la masse.
+  !
+  !   Les flux de masse sont eux simplement moyennes.
+  !
+  !====================================================================
+
+  !   Arguments :
+  !   ===========
+
+  integer :: ntrac
+  real :: dt_app,dt_cum
+  real :: ps(iip1,jjp1)
+  real :: masse(iip1,jjp1,llm),pk(iip1,jjp1,llm)
+  real :: flux_u(iip1,jjp1,llm)
+  real :: flux_v(iip1,jjm,llm)
+  real :: teta(iip1,jjp1,llm)
+  real :: phi(iip1,jjp1,llm)
+  real :: ucov(iip1,jjp1,llm)
+  real :: vcov(iip1,jjm,llm)
+  real :: trac(iip1,jjp1,llm,ntrac)
+
+  !   Local :
+  !   =======
+
+  integer :: icum,ncum
+  logical :: first
+  real :: zz,zqy,zfactv(jjm,llm)
+
+  integer :: nQ
+  parameter (nQ=7)
+
+
+  !ym      character*6 nom(nQ)
+  !ym      character*6 unites(nQ)
+  character*6,save :: nom(nQ)
+  character*6,save :: unites(nQ)
+
+  character(len=10) :: file
+  integer :: ifile
+  parameter (ifile=4)
+
+  integer :: itemp,igeop,iecin,iang,iu,iovap,iun
+  integer :: i_sortie
+
+  save first,icum,ncum
+  save itemp,igeop,iecin,iang,iu,iovap,iun
+  save i_sortie
+
+  real :: time
+  integer :: itau
+  save time,itau
+  data time,itau/0.,0/
+
+  data first/.true./
+  data itemp,igeop,iecin,iang,iu,iovap,iun/1,2,3,4,5,6,7/
+  data i_sortie/1/
+
+  real :: ww
+
+  !   variables dynamiques interm�diaires
+  REAL :: vcont(iip1,jjm,llm),ucont(iip1,jjp1,llm)
+  REAL :: ang(iip1,jjp1,llm),unat(iip1,jjp1,llm)
+  REAL :: massebx(iip1,jjp1,llm),masseby(iip1,jjm,llm)
+  REAL :: vorpot(iip1,jjm,llm)
+  REAL :: w(iip1,jjp1,llm),ecin(iip1,jjp1,llm),convm(iip1,jjp1,llm)
+  REAL :: bern(iip1,jjp1,llm)
+
+  !   champ contenant les scalaires advect�s.
+  real :: Q(iip1,jjp1,llm,nQ)
+
+  !   champs cumul�s
+  real :: ps_cum(iip1,jjp1)
+  real :: masse_cum(iip1,jjp1,llm)
+  real :: flux_u_cum(iip1,jjp1,llm)
+  real :: flux_v_cum(iip1,jjm,llm)
+  real :: Q_cum(iip1,jjp1,llm,nQ)
+  real :: flux_uQ_cum(iip1,jjp1,llm,nQ)
+  real :: flux_vQ_cum(iip1,jjm,llm,nQ)
+  real :: flux_wQ_cum(iip1,jjp1,llm,nQ)
+  real :: dQ(iip1,jjp1,llm,nQ)
+
+  save ps_cum,masse_cum,flux_u_cum,flux_v_cum
+  save Q_cum,flux_uQ_cum,flux_vQ_cum
+
+  !   champs de tansport en moyenne zonale
+  integer :: ntr,itr
+  parameter (ntr=5)
+
+  !ym      character*10 znom(ntr,nQ)
+  !ym      character*20 znoml(ntr,nQ)
+  !ym      character*10 zunites(ntr,nQ)
+  character*10,save :: znom(ntr,nQ)
+  character*20,save :: znoml(ntr,nQ)
+  character*10,save :: zunites(ntr,nQ)
+
+  integer :: iave,itot,immc,itrs,istn
+  data iave,itot,immc,itrs,istn/1,2,3,4,5/
+  character(len=3) :: ctrs(ntr)
+  data ctrs/'  ','TOT','MMC','TRS','STN'/
+
+  real :: zvQ(jjm,llm,ntr,nQ),zvQtmp(jjm,llm)
+  real :: zavQ(jjm,ntr,nQ),psiQ(jjm,llm+1,nQ)
+  real :: zmasse(jjm,llm),zamasse(jjm)
+
+  real :: zv(jjm,llm),psi(jjm,llm+1)
+
+  integer :: i,j,l,iQ
+
+
+  !   Initialisation du fichier contenant les moyennes zonales.
+  !   ---------------------------------------------------------
+
+  character(len=10) :: infile
+
+  integer :: fileid
+  integer :: thoriid, zvertiid
+  save fileid
+
+  integer :: ndex3d(jjm*llm)
+
+  !   Variables locales
+  !
+  integer :: tau0
+  real :: zjulian
+  character(len=3) :: str
+  character(len=10) :: ctrac
+  integer :: ii,jj
+  integer :: zan, dayref
+  !
+  real :: rlong(jjm),rlatg(jjm)
+
+
+
+  !=====================================================================
+  !   Initialisation
+  !=====================================================================
+
+  time=time+dt_app
+  itau=itau+1
+  !IM
+  ndex3d=0
+
+  if (first) then
+
+
+    icum=0
+    ! initialisation des fichiers
+    first=.false.
+  !   ncum est la frequence de stokage en pas de temps
+    ncum=dt_cum/dt_app
+    if (abs(ncum*dt_app-dt_cum).gt.1.e-5*dt_app) then
+       WRITE(lunout,*) &
+             'Pb : le pas de cumule doit etre multiple du pas'
+       WRITE(lunout,*)'dt_app=',dt_app
+       WRITE(lunout,*)'dt_cum=',dt_cum
+       call abort_gcm('bilan_dyn','stopped',1)
+    endif
+
+    if (i_sortie.eq.1) then
+     file='dynzon'
+     call inigrads(ifile,1 &
+           ,0.,180./pi,0.,0.,jjm,rlatv,-90.,90.,180./pi &
+           ,llm,presnivs,1. &
+           ,dt_cum,file,'dyn_zon ')
+    endif
+
+    nom(itemp)='T'
+    nom(igeop)='gz'
+    nom(iecin)='K'
+    nom(iang)='ang'
+    nom(iu)='u'
+    nom(iovap)='ovap'
+    nom(iun)='un'
+
+    unites(itemp)='K'
+    unites(igeop)='m2/s2'
+    unites(iecin)='m2/s2'
+    unites(iang)='ang'
+    unites(iu)='m/s'
+    unites(iovap)='kg/kg'
+    unites(iun)='un'
+
+
+  !   Initialisation du fichier contenant les moyennes zonales.
+  !   ---------------------------------------------------------
+
+  infile='dynzon'
+
+  zan = annee_ref
+  dayref = day_ref
+  CALL ymds2ju(zan, 1, dayref, 0.0, zjulian)
+  tau0 = itau_dyn
+
+  rlong=0.
+  rlatg=rlatv*180./pi
+
+  call histbeg(infile, 1, rlong, jjm, rlatg, &
+        1, 1, 1, jjm, &
+        tau0, zjulian, dt_cum, thoriid, fileid)
+
+  !
+  !  Appel a histvert pour la grille verticale
+  !
+  call histvert(fileid, 'presnivs', 'Niveaux sigma','mb', &
+        llm, presnivs, zvertiid)
+  !
+  !  Appels a histdef pour la definition des variables a sauvegarder
+  do iQ=1,nQ
+     do itr=1,ntr
+        if(itr.eq.1) then
+           znom(itr,iQ)=nom(iQ)
+           znoml(itr,iQ)=nom(iQ)
+           zunites(itr,iQ)=unites(iQ)
+        else
+           znom(itr,iQ)=ctrs(itr)//'v'//nom(iQ)
+           znoml(itr,iQ)='transport : v * '//nom(iQ)//' '//ctrs(itr)
+           zunites(itr,iQ)='m/s * '//unites(iQ)
+        endif
+     enddo
+  enddo
+
+  !   Declarations des champs avec dimension verticale
+   ! print*,'1HISTDEF'
+  do iQ=1,nQ
+     do itr=1,ntr
+  IF (prt_level > 5) &
+        WRITE(lunout,*)'var ',itr,iQ &
+        ,znom(itr,iQ),znoml(itr,iQ),zunites(itr,iQ)
+        call histdef(fileid,znom(itr,iQ),znoml(itr,iQ), &
+              zunites(itr,iQ),1,jjm,thoriid,llm,1,llm,zvertiid, &
+              32,'ave(X)',dt_cum,dt_cum)
+     enddo
+  !   Declarations pour les fonctions de courant
+   ! print*,'2HISTDEF'
+      call histdef(fileid,'psi'//nom(iQ) &
+            ,'stream fn. '//znoml(itot,iQ), &
+            zunites(itot,iQ),1,jjm,thoriid,llm,1,llm,zvertiid, &
+            32,'ave(X)',dt_cum,dt_cum)
+  enddo
+
+
+  !   Declarations pour les champs de transport d'air
+   ! print*,'3HISTDEF'
+  call histdef(fileid, 'masse', 'masse', &
+        'kg', 1, jjm, thoriid, llm, 1, llm, zvertiid, &
+        32, 'ave(X)', dt_cum, dt_cum)
+  call histdef(fileid, 'v', 'v', &
+        'm/s', 1, jjm, thoriid, llm, 1, llm, zvertiid, &
+        32, 'ave(X)', dt_cum, dt_cum)
+  !   Declarations pour les fonctions de courant
+   ! print*,'4HISTDEF'
+      call histdef(fileid,'psi','stream fn. MMC ','mega t/s', &
+            1,jjm,thoriid,llm,1,llm,zvertiid, &
+            32,'ave(X)',dt_cum,dt_cum)
+
+
+  !   Declaration des champs 1D de transport en latitude
+   ! print*,'5HISTDEF'
+  do iQ=1,nQ
+     do itr=2,ntr
+        call histdef(fileid,'a'//znom(itr,iQ),znoml(itr,iQ), &
+              zunites(itr,iQ),1,jjm,thoriid,1,1,1,-99, &
+              32,'ave(X)',dt_cum,dt_cum)
+     enddo
+  enddo
+
+
+   ! print*,'8HISTDEF'
+           CALL histend(fileid)
+
+
+  endif
+
+
+  !=====================================================================
+  !   Calcul des champs dynamiques
+  !   ----------------------------
+
+  !   �nergie cin�tique
+  ucont(:,:,:)=0
+  CALL covcont(llm,ucov,vcov,ucont,vcont)
+  CALL enercin(vcov,ucov,vcont,ucont,ecin)
+
+  !   moment cin�tique
+  do l=1,llm
+     ang(:,:,l)=ucov(:,:,l)+constang(:,:)
+     unat(:,:,l)=ucont(:,:,l)*cu(:,:)
+  enddo
+
+  Q(:,:,:,itemp)=teta(:,:,:)*pk(:,:,:)/cpp
+  Q(:,:,:,igeop)=phi(:,:,:)
+  Q(:,:,:,iecin)=ecin(:,:,:)
+  Q(:,:,:,iang)=ang(:,:,:)
+  Q(:,:,:,iu)=unat(:,:,:)
+  Q(:,:,:,iovap)=trac(:,:,:,1)
+  Q(:,:,:,iun)=1.
+
+
+  !=====================================================================
+  !   Cumul
+  !=====================================================================
+  !
+  if(icum.EQ.0) then
+     ps_cum=0.
+     masse_cum=0.
+     flux_u_cum=0.
+     flux_v_cum=0.
+     Q_cum=0.
+     flux_vQ_cum=0.
+     flux_uQ_cum=0.
+  endif
+
+  IF (prt_level > 5) &
+        WRITE(lunout,*)'dans bilan_dyn ',icum,'->',icum+1
+  icum=icum+1
+
+  !   accumulation des flux de masse horizontaux
+  ps_cum=ps_cum+ps
+  masse_cum=masse_cum+masse
+  flux_u_cum=flux_u_cum+flux_u
+  flux_v_cum=flux_v_cum+flux_v
+  do iQ=1,nQ
+  Q_cum(:,:,:,iQ)=Q_cum(:,:,:,iQ)+Q(:,:,:,iQ)*masse(:,:,:)
+  enddo
+
+  !=====================================================================
+  !  FLUX ET TENDANCES
+  !=====================================================================
+
+  !   Flux longitudinal
+  !   -----------------
+  do iQ=1,nQ
+     do l=1,llm
+        do j=1,jjp1
+           do i=1,iim
+              flux_uQ_cum(i,j,l,iQ)=flux_uQ_cum(i,j,l,iQ) &
+                    +flux_u(i,j,l)*0.5*(Q(i,j,l,iQ)+Q(i+1,j,l,iQ))
+           enddo
+           flux_uQ_cum(iip1,j,l,iQ)=flux_uQ_cum(1,j,l,iQ)
+        enddo
+     enddo
+  enddo
+
+  !    flux m�ridien
+  !    -------------
+  do iQ=1,nQ
+     do l=1,llm
+        do j=1,jjm
+           do i=1,iip1
+              flux_vQ_cum(i,j,l,iQ)=flux_vQ_cum(i,j,l,iQ) &
+                    +flux_v(i,j,l)*0.5*(Q(i,j,l,iQ)+Q(i,j+1,l,iQ))
+           enddo
+        enddo
+     enddo
+  enddo
+
+
+  !    tendances
+  !    ---------
+
+  !   convergence horizontale
+  call  convflu(flux_uQ_cum,flux_vQ_cum,llm*nQ,dQ)
+
+  !   calcul de la vitesse verticale
+  call convmas(flux_u_cum,flux_v_cum,convm)
+  CALL vitvert(convm,w)
+
+  do iQ=1,nQ
+     do l=1,llm-1
+        do j=1,jjp1
+           do i=1,iip1
+              ww=-0.5*w(i,j,l+1)*(Q(i,j,l,iQ)+Q(i,j,l+1,iQ))
+              dQ(i,j,l  ,iQ)=dQ(i,j,l  ,iQ)-ww
+              dQ(i,j,l+1,iQ)=dQ(i,j,l+1,iQ)+ww
+           enddo
+        enddo
+     enddo
+  enddo
+  IF (prt_level > 5) &
+        WRITE(lunout,*)'Apres les calculs fait a chaque pas'
+  !=====================================================================
+  !   PAS DE TEMPS D'ECRITURE
+  !=====================================================================
+  if (icum.eq.ncum) then
+  !=====================================================================
+
+  IF (prt_level > 5) &
+        WRITE(lunout,*)'Pas d ecriture'
+
+  !   Normalisation
+  do iQ=1,nQ
+     Q_cum(:,:,:,iQ)=Q_cum(:,:,:,iQ)/masse_cum(:,:,:)
+  enddo
+  zz=1./REAL(ncum)
+  ps_cum=ps_cum*zz
+  masse_cum=masse_cum*zz
+  flux_u_cum=flux_u_cum*zz
+  flux_v_cum=flux_v_cum*zz
+  flux_uQ_cum=flux_uQ_cum*zz
+  flux_vQ_cum=flux_vQ_cum*zz
+  dQ=dQ*zz
+
+
+  !   A retravailler eventuellement
+  !   division de dQ par la masse pour revenir aux bonnes grandeurs
+  do iQ=1,nQ
+     dQ(:,:,:,iQ)=dQ(:,:,:,iQ)/masse_cum(:,:,:)
+  enddo
+
+  !=====================================================================
+  !   Transport m�ridien
+  !=====================================================================
+
+  !   cumul zonal des masses des mailles
+  !   ----------------------------------
+  zv=0.
+  zmasse=0.
+  call massbar(masse_cum,massebx,masseby)
+  do l=1,llm
+     do j=1,jjm
+        do i=1,iim
+           zmasse(j,l)=zmasse(j,l)+masseby(i,j,l)
+           zv(j,l)=zv(j,l)+flux_v_cum(i,j,l)
+        enddo
+        zfactv(j,l)=cv(1,j)/zmasse(j,l)
+     enddo
+  enddo
+
+  ! print*,'3OK'
+  !   --------------------------------------------------------------
+  !   calcul de la moyenne zonale du transport :
+  !   ------------------------------------------
+  !
+  !                                 --
+  ! TOT : la circulation totale       [ vq ]
+  !
+  !                                  -     -
+  ! MMC : mean meridional circulation [ v ] [ q ]
+  !
+  !                                 ----      --       - -
+  ! TRS : transitoires                [ v'q'] = [ vq ] - [ v q ]
+  !
+  !                                 - * - *       - -       -     -
+  ! STT : stationaires                [ v   q   ] = [ v q ] - [ v ] [ q ]
+  !
+  !                                          - -
+  !    on utilise aussi l'intermediaire TMP :  [ v q ]
+  !
+  !    la variable zfactv transforme un transport meridien cumule
+  !    en kg/s * unte-du-champ-transporte en m/s * unite-du-champ-transporte
+  !
+  !   --------------------------------------------------------------
+
+
+  !   ----------------------------------------
+  !   Transport dans le plan latitude-altitude
+  !   ----------------------------------------
+
+  zvQ=0.
+  psiQ=0.
+  do iQ=1,nQ
+     zvQtmp=0.
+     do l=1,llm
+        do j=1,jjm
+           ! print*,'j,l,iQ=',j,l,iQ
+  !   Calcul des moyennes zonales du transort total et de zvQtmp
+           do i=1,iim
+              zvQ(j,l,itot,iQ)=zvQ(j,l,itot,iQ) &
+                    +flux_vQ_cum(i,j,l,iQ)
+              zqy=      0.5*(Q_cum(i,j,l,iQ)*masse_cum(i,j,l)+ &
+                    Q_cum(i,j+1,l,iQ)*masse_cum(i,j+1,l))
+              zvQtmp(j,l)=zvQtmp(j,l)+flux_v_cum(i,j,l)*zqy &
+                    /(0.5*(masse_cum(i,j,l)+masse_cum(i,j+1,l)))
+              zvQ(j,l,iave,iQ)=zvQ(j,l,iave,iQ)+zqy
+           enddo
+           ! print*,'aOK'
+  !   Decomposition
+           zvQ(j,l,iave,iQ)=zvQ(j,l,iave,iQ)/zmasse(j,l)
+           zvQ(j,l,itot,iQ)=zvQ(j,l,itot,iQ)*zfactv(j,l)
+           zvQtmp(j,l)=zvQtmp(j,l)*zfactv(j,l)
+           zvQ(j,l,immc,iQ)=zv(j,l)*zvQ(j,l,iave,iQ)*zfactv(j,l)
+           zvQ(j,l,itrs,iQ)=zvQ(j,l,itot,iQ)-zvQtmp(j,l)
+           zvQ(j,l,istn,iQ)=zvQtmp(j,l)-zvQ(j,l,immc,iQ)
+        enddo
+     enddo
+  !   fonction de courant meridienne pour la quantite Q
+     do l=llm,1,-1
+        do j=1,jjm
+           psiQ(j,l,iQ)=psiQ(j,l+1,iQ)+zvQ(j,l,itot,iQ)
+        enddo
+     enddo
+  enddo
+
+  !   fonction de courant pour la circulation meridienne moyenne
+  psi=0.
+  do l=llm,1,-1
+     do j=1,jjm
+        psi(j,l)=psi(j,l+1)+zv(j,l)
+        zv(j,l)=zv(j,l)*zfactv(j,l)
+     enddo
+  enddo
+
+  ! print*,'4OK'
+  !   sorties proprement dites
+  if (i_sortie.eq.1) then
+  do iQ=1,nQ
+     do itr=1,ntr
+        call histwrite(fileid,znom(itr,iQ),itau,zvQ(:,:,itr,iQ) &
+              ,jjm*llm,ndex3d)
+     enddo
+     call histwrite(fileid,'psi'//nom(iQ),itau,psiQ(:,1:llm,iQ) &
+           ,jjm*llm,ndex3d)
+  enddo
+
+  call histwrite(fileid,'masse',itau,zmasse &
+        ,jjm*llm,ndex3d)
+  call histwrite(fileid,'v',itau,zv &
+        ,jjm*llm,ndex3d)
+  psi=psi*1.e-9
+  call histwrite(fileid,'psi',itau,psi(:,1:llm),jjm*llm,ndex3d)
+
+  endif
+
+
+  !   -----------------
+  !   Moyenne verticale
+  !   -----------------
+
+  zamasse=0.
+  do l=1,llm
+     zamasse(:)=zamasse(:)+zmasse(:,l)
+  enddo
+  zavQ=0.
+  do iQ=1,nQ
+     do itr=2,ntr
+        do l=1,llm
+           zavQ(:,itr,iQ)=zavQ(:,itr,iQ)+zvQ(:,l,itr,iQ)*zmasse(:,l)
+        enddo
+        zavQ(:,itr,iQ)=zavQ(:,itr,iQ)/zamasse(:)
+        call histwrite(fileid,'a'//znom(itr,iQ),itau,zavQ(:,itr,iQ) &
+              ,jjm*llm,ndex3d)
+     enddo
+  enddo
+
+  ! on doit pouvoir tracer systematiquement la fonction de courant.
+
+  !=====================================================================
+  !/////////////////////////////////////////////////////////////////////
+  icum=0                  !///////////////////////////////////////
+  endif ! icum.eq.ncum    !///////////////////////////////////////
+  !/////////////////////////////////////////////////////////////////////
+  !=====================================================================
+
+  return
+end subroutine bilan_dyn
Index: DZ6/trunk/libf/dyn3d/check_isotopes.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d/check_isotopes.F90	(revision 5267)
+++ 	(revision )
@@ -1,178 +1,0 @@
-SUBROUTINE check_isotopes_seq(q, ip1jmp1, err_msg)
-   USE strings_mod, ONLY: maxlen, msg, strIdx, strStack, int2str, real2str
-   USE infotrac,    ONLY: nqtot, niso, nphas, isotope, isoCheck, iqIsoPha, isoSelect, &
-                          ntiso, iH2O, nzone, tracers, isoName,  itZonIso
-   USE iso_params_mod,  ONLY: tnat_H216O, tnat_H217O, tnat_H218O, tnat_HDO, tnat_HTO
-   USE ioipsl,          ONLY: getin
-   IMPLICIT NONE
-   include "dimensions.h"
-   REAL,             INTENT(INOUT) :: q(ip1jmp1,llm,nqtot)
-   INTEGER,          INTENT(IN)    :: ip1jmp1
-   CHARACTER(LEN=*), INTENT(IN)    :: err_msg    !--- Error message to display
-   CHARACTER(LEN=maxlen) :: modname, msg1, nm(2)
-   INTEGER :: ixt, ipha, k, i, iq, iiso, izon, ieau, iqeau, iqpar
-   INTEGER, ALLOCATABLE       ::   ix(:)
-   REAL,    ALLOCATABLE, SAVE :: tnat(:)
-   REAL :: xtractot, xiiso, deltaD, q1, q2
-   REAL, PARAMETER :: borne     = 1e19,  &
-                      errmax    = 1e-8,  &       !--- Max. absolute error
-                      errmaxrel = 1e-3,  &       !--- Max. relative error
-                      qmin      = 1e-11, &
-                      deltaDmax =1000.0, &
-                      deltaDmin =-999.0, &
-                      ridicule  = 1e-12
-   INTEGER, SAVE :: iso_eau, iso_O17, iso_O18, iso_HDO, iso_HTO
-   LOGICAL       :: ltnat1
-   LOGICAL, SAVE :: first=.TRUE.
-
-   modname='check_isotopes'
-   IF(.NOT.isoCheck)    RETURN                   !--- No need to check => finished
-   IF(isoSelect('H2O')) RETURN                   !--- No H2O isotopes group found
-   IF(niso == 0)        RETURN                   !--- No isotopes => finished
-   IF(first) THEN
-      ltnat1 = .TRUE.; CALL getin('tnateq1', ltnat1)
-      ALLOCATE(tnat(niso))
-      iso_eau = strIdx(isoName,'H216O'); IF(iso_eau /= 0) tnat(iso_eau) = tnat_H216O
-      iso_O17 = strIdx(isoName,'H217O'); IF(iso_O17 /= 0) tnat(iso_O17) = tnat_H217O
-      iso_O18 = strIdx(isoName,'H218O'); IF(iso_O18 /= 0) tnat(iso_O18) = tnat_H218O
-      iso_HDO = strIdx(isoName,'HDO');   IF(iso_HDO /= 0) tnat(iso_HDO) = tnat_HDO
-      iso_HTO = strIdx(isoName,'HTO');   IF(iso_HTO /= 0) tnat(iso_HTO) = tnat_HTO
-      IF(ltnat1) tnat(:) = 1.
-      first = .FALSE.
-   END IF
-   CALL msg('31: err_msg='//TRIM(err_msg), modname)
-
-   !--- CHECK FOR NaNs (FOR ALL THE ISOTOPES, INCLUDING GEOGRAPHIC TAGGING TRACERS)
-   modname = 'check_isotopes:iso_verif_noNaN'
-   DO ixt = 1, ntiso
-      DO ipha = 1, nphas
-         iq = iqIsoPha(ixt,ipha)
-         DO k = 1, llm
-            DO i = 1, ip1jmp1
-               IF(ABS(q(i,k,iq)) < borne) CYCLE
-               WRITE(msg1,'(s,"(",i0,",",i0,",",i0,") = ",ES12.4)')TRIM(isoName(ixt)),i,k,iq,q(i,k,iq)
-               CALL msg(msg1, modname)
-               CALL abort_gcm(modname, 'Error with isotopes: '//TRIM(err_msg), 1)
-            END DO
-         END DO
-      END DO
-   END DO
-
-   !--- CHECK CONSERVATION (MAIN ISOTOPE AND PARENT CONCENTRATIONS MUST BE EQUAL)
-   modname = 'check_isotopes:iso_verif_egalite'
-   ixt = iso_eau
-   IF(ixt /= 0) THEN
-      DO ipha = 1, nphas
-         iq = iqIsoPha(ixt,ipha)
-         iqpar = tracers(iq)%iqParent
-         DO k = 1, llm
-            DO i = 1, ip1jmp1
-               q1 = q(i,k,iqpar)
-               q2 = q(i,k,iq)
-!--- IMPROVEMENT in case at least one isotope is not negligible compared to the main isotopic form.
-!    This would be probably required to sum from smallest to highest concentrations ; the corresponding
-!    indices vector can be computed once only (in the initializations stage), using mean concentrations.
-!              q2 = SUM(q(i,k,tracers(iqPar)%iqDesc), DIM=3)
-               IF(ABS(q1-q2) <= errmax .OR. ABS(q1-q2)/MAX(MAX(ABS(q1),ABS(q2)),1e-18) <= errmaxrel) THEN
-                  q(i,k,iq) = q1                 !--- Bidouille pour convergence
-!                 q(i,k,tracers(iqPar)%iqDesc) = q(i,k,tracers(iqPar)%iqDesc) * q1 / q2
-                  CYCLE
-               END IF
-               CALL msg('ixt, iq = '//TRIM(strStack(int2str([ixt,iq]))), modname)
-               msg1 = '('//TRIM(strStack(int2str([i,k])))//')'
-               CALL msg(TRIM(tracers(iqpar)%name)//TRIM(msg1)//' = '//TRIM(real2str(q1)), modname)
-               CALL msg(TRIM(tracers(iq   )%name)//TRIM(msg1)//' = '//TRIM(real2str(q2)), modname)
-               CALL abort_gcm(modname, 'Error with isotopes: '//TRIM(err_msg), 1)
-            END DO
-         END DO
-      END DO
-   END IF
-
-   !--- CHECK DELTA ANOMALIES
-   modname = 'check_isotopes:iso_verif_aberrant'
-   ix = [ iso_HDO  ,   iso_O18 ]
-   nm = ['deltaD  ', 'deltaO18']
-   DO iiso = 1, SIZE(ix)
-      ixt = ix(iiso)
-      IF(ixt  == 0) CYCLE
-      DO ipha = 1, nphas
-         iq = iqIsoPha(ixt,ipha)
-         iqpar = tracers(iq)%iqParent
-         DO k = 1, llm
-            DO i = 1, ip1jmp1
-               q1 = q(i,k,iqpar)
-               q2 = q(i,k,iq)
-!--- IMPROVEMENT in case at least one isotope is not negligible compared to the main isotopic form.
-!    This would be probably required to sum from smallest to highest concentrations ; the corresponding
-!    indices vector can be computed once only (in the initializations stage), using mean concentrations.
-!              q2 = SUM(q(i,k,tracers(iqPar)%iqDesc), DIM=3)
-               IF(q2 <= qmin) CYCLE
-               deltaD = (q2/q1/tnat(ixt)-1.)*1000.
-               IF(deltaD <= deltaDmax .AND. deltaD >= deltaDmin) CYCLE
-               CALL msg('ixt, iq = '//TRIM(strStack(int2str([ixt,iq]))), modname)
-               msg1 = '('//TRIM(strStack(int2str([i,k])))//')'
-               CALL msg(TRIM(tracers(iqpar)%name)//TRIM(msg1)//' = '//TRIM(real2str(q1)), modname)
-               CALL msg(TRIM(tracers(iq   )%name)//TRIM(msg1)//' = '//TRIM(real2str(q2)), modname)
-               CALL msg(TRIM(nm(iiso))//TRIM(real2str(deltaD)), modname)
-               CALL abort_gcm(modname, 'Error with isotopes: '//TRIM(err_msg), 1)
-            END DO
-         END DO
-      END DO
-   END DO
-
-   IF(nzone == 0) RETURN
-
-   !--- CHECK FOR TAGGING TRACERS DELTAD ANOMALIES
-   modname = 'check_isotopes:iso_verif_aberrant'
-   IF(iso_eau /= 0 .AND. iso_HDO /= 0) THEN
-      DO izon = 1, nzone
-         ixt  = itZonIso(izon, iso_HDO)
-         ieau = itZonIso(izon, iso_eau)
-         DO ipha = 1, nphas
-            iq    = iqIsoPha(ixt,  ipha)
-            iqeau = iqIsoPha(ieau, ipha)
-            DO k = 1, llm
-               DO i = 1, ip1jmp1
-                  q1 = q(i,k,iqeau)
-                  q2 = q(i,k,iq)
-                  IF(q2<=qmin) CYCLE
-                  deltaD = (q2/q1/tnat(iso_HDO)-1.)*1000.
-                  IF(deltaD <= deltaDmax .AND. deltaD >= deltaDmin) CYCLE
-                  CALL msg('izon, ipha = '//TRIM(strStack(int2str([izon, ipha]))), modname)
-                  CALL msg( 'ixt, ieau = '//TRIM(strStack(int2str([ ixt, ieau]))), modname)
-                  msg1 = '('//TRIM(strStack(int2str([i,k])))//')'
-                  CALL msg(TRIM(tracers(iqeau)%name)//TRIM(msg1)//' = '//TRIM(real2str(q1)), modname)
-                  CALL msg(TRIM(tracers(iq   )%name)//TRIM(msg1)//' = '//TRIM(real2str(q2)), modname)
-                  CALL msg('deltaD = '//TRIM(real2str(deltaD)), modname)
-                  CALL abort_gcm(modname, 'Error with isotopes: '//TRIM(err_msg), 1)
-               END DO
-            END DO
-         END DO
-      END DO
-   END IF
-
-   !--- CHECK FOR TAGGING TRACERS CONSERVATION (PARENT AND TAGGING TRACERS SUM OVER ALL REGIONS MUST BE EQUAL)
-   DO iiso = 1, niso
-      DO ipha = 1, nphas
-         iq = iqIsoPha(iiso, ipha)
-         DO k = 1, llm
-            DO i = 1, ip1jmp1
-               xiiso = q(i,k,iq)
-               xtractot = SUM(q(i, k, iqIsoPha(itZonIso(1:nzone,iiso), ipha)))
-               IF(ABS(xtractot-xiiso) > errmax .AND. ABS(xtractot-xiiso)/MAX(MAX(ABS(xtractot),ABS(xiiso)),1e-18) > errmaxrel) THEN
-                  CALL msg('Error in iso_verif_aberrant trac: '//TRIM(err_msg))
-                  CALL msg('iiso, ipha = '//TRIM(strStack(int2str([iiso, ipha]))), modname)
-                  CALL msg('q('//TRIM(strStack(int2str([i,k])))//',:) = '//TRIM(strStack(real2str(q(i,k,:)))), modname)
-                  CALL abort_gcm(modname, 'Error with isotopes: '//TRIM(err_msg), 1)
-               END IF
-               IF(ABS(xtractot) <= ridicule) CYCLE
-               DO izon = 1, nzone
-                  q(i,k,iq) = q(i,k,iq) / xtractot * xiiso !--- Bidouille pour convergence
-               END DO
-            END DO
-         END DO
-      END DO
-   END DO
-
-END SUBROUTINE check_isotopes_seq
-
Index: /LMDZ6/trunk/libf/dyn3d/check_isotopes.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d/check_isotopes.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3d/check_isotopes.f90	(revision 5268)
@@ -0,0 +1,178 @@
+SUBROUTINE check_isotopes_seq(q, ip1jmp1, err_msg)
+   USE strings_mod, ONLY: maxlen, msg, strIdx, strStack, int2str, real2str
+   USE infotrac,    ONLY: nqtot, niso, nphas, isotope, isoCheck, iqIsoPha, isoSelect, &
+                          ntiso, iH2O, nzone, tracers, isoName,  itZonIso
+   USE iso_params_mod,  ONLY: tnat_H216O, tnat_H217O, tnat_H218O, tnat_HDO, tnat_HTO
+   USE ioipsl,          ONLY: getin
+   IMPLICIT NONE
+   include "dimensions.h"
+   REAL,             INTENT(INOUT) :: q(ip1jmp1,llm,nqtot)
+   INTEGER,          INTENT(IN)    :: ip1jmp1
+   CHARACTER(LEN=*), INTENT(IN)    :: err_msg    !--- Error message to display
+   CHARACTER(LEN=maxlen) :: modname, msg1, nm(2)
+   INTEGER :: ixt, ipha, k, i, iq, iiso, izon, ieau, iqeau, iqpar
+   INTEGER, ALLOCATABLE       ::   ix(:)
+   REAL,    ALLOCATABLE, SAVE :: tnat(:)
+   REAL :: xtractot, xiiso, deltaD, q1, q2
+   REAL, PARAMETER :: borne     = 1e19,  &
+                      errmax    = 1e-8,  &       !--- Max. absolute error
+                      errmaxrel = 1e-3,  &       !--- Max. relative error
+                      qmin      = 1e-11, &
+                      deltaDmax =1000.0, &
+                      deltaDmin =-999.0, &
+                      ridicule  = 1e-12
+   INTEGER, SAVE :: iso_eau, iso_O17, iso_O18, iso_HDO, iso_HTO
+   LOGICAL       :: ltnat1
+   LOGICAL, SAVE :: first=.TRUE.
+
+   modname='check_isotopes'
+   IF(.NOT.isoCheck)    RETURN                   !--- No need to check => finished
+   IF(isoSelect('H2O')) RETURN                   !--- No H2O isotopes group found
+   IF(niso == 0)        RETURN                   !--- No isotopes => finished
+   IF(first) THEN
+      ltnat1 = .TRUE.; CALL getin('tnateq1', ltnat1)
+      ALLOCATE(tnat(niso))
+      iso_eau = strIdx(isoName,'H216O'); IF(iso_eau /= 0) tnat(iso_eau) = tnat_H216O
+      iso_O17 = strIdx(isoName,'H217O'); IF(iso_O17 /= 0) tnat(iso_O17) = tnat_H217O
+      iso_O18 = strIdx(isoName,'H218O'); IF(iso_O18 /= 0) tnat(iso_O18) = tnat_H218O
+      iso_HDO = strIdx(isoName,'HDO');   IF(iso_HDO /= 0) tnat(iso_HDO) = tnat_HDO
+      iso_HTO = strIdx(isoName,'HTO');   IF(iso_HTO /= 0) tnat(iso_HTO) = tnat_HTO
+      IF(ltnat1) tnat(:) = 1.
+      first = .FALSE.
+   END IF
+   CALL msg('31: err_msg='//TRIM(err_msg), modname)
+
+   !--- CHECK FOR NaNs (FOR ALL THE ISOTOPES, INCLUDING GEOGRAPHIC TAGGING TRACERS)
+   modname = 'check_isotopes:iso_verif_noNaN'
+   DO ixt = 1, ntiso
+      DO ipha = 1, nphas
+         iq = iqIsoPha(ixt,ipha)
+         DO k = 1, llm
+            DO i = 1, ip1jmp1
+               IF(ABS(q(i,k,iq)) < borne) CYCLE
+               WRITE(msg1,'(s,"(",i0,",",i0,",",i0,") = ",ES12.4)')TRIM(isoName(ixt)),i,k,iq,q(i,k,iq)
+               CALL msg(msg1, modname)
+               CALL abort_gcm(modname, 'Error with isotopes: '//TRIM(err_msg), 1)
+            END DO
+         END DO
+      END DO
+   END DO
+
+   !--- CHECK CONSERVATION (MAIN ISOTOPE AND PARENT CONCENTRATIONS MUST BE EQUAL)
+   modname = 'check_isotopes:iso_verif_egalite'
+   ixt = iso_eau
+   IF(ixt /= 0) THEN
+      DO ipha = 1, nphas
+         iq = iqIsoPha(ixt,ipha)
+         iqpar = tracers(iq)%iqParent
+         DO k = 1, llm
+            DO i = 1, ip1jmp1
+               q1 = q(i,k,iqpar)
+               q2 = q(i,k,iq)
+!--- IMPROVEMENT in case at least one isotope is not negligible compared to the main isotopic form.
+!    This would be probably required to sum from smallest to highest concentrations ; the corresponding
+!    indices vector can be computed once only (in the initializations stage), using mean concentrations.
+!              q2 = SUM(q(i,k,tracers(iqPar)%iqDesc), DIM=3)
+               IF(ABS(q1-q2) <= errmax .OR. ABS(q1-q2)/MAX(MAX(ABS(q1),ABS(q2)),1e-18) <= errmaxrel) THEN
+                  q(i,k,iq) = q1                 !--- Bidouille pour convergence
+!                 q(i,k,tracers(iqPar)%iqDesc) = q(i,k,tracers(iqPar)%iqDesc) * q1 / q2
+                  CYCLE
+               END IF
+               CALL msg('ixt, iq = '//TRIM(strStack(int2str([ixt,iq]))), modname)
+               msg1 = '('//TRIM(strStack(int2str([i,k])))//')'
+               CALL msg(TRIM(tracers(iqpar)%name)//TRIM(msg1)//' = '//TRIM(real2str(q1)), modname)
+               CALL msg(TRIM(tracers(iq   )%name)//TRIM(msg1)//' = '//TRIM(real2str(q2)), modname)
+               CALL abort_gcm(modname, 'Error with isotopes: '//TRIM(err_msg), 1)
+            END DO
+         END DO
+      END DO
+   END IF
+
+   !--- CHECK DELTA ANOMALIES
+   modname = 'check_isotopes:iso_verif_aberrant'
+   ix = [ iso_HDO  ,   iso_O18 ]
+   nm = ['deltaD  ', 'deltaO18']
+   DO iiso = 1, SIZE(ix)
+      ixt = ix(iiso)
+      IF(ixt  == 0) CYCLE
+      DO ipha = 1, nphas
+         iq = iqIsoPha(ixt,ipha)
+         iqpar = tracers(iq)%iqParent
+         DO k = 1, llm
+            DO i = 1, ip1jmp1
+               q1 = q(i,k,iqpar)
+               q2 = q(i,k,iq)
+!--- IMPROVEMENT in case at least one isotope is not negligible compared to the main isotopic form.
+!    This would be probably required to sum from smallest to highest concentrations ; the corresponding
+!    indices vector can be computed once only (in the initializations stage), using mean concentrations.
+!              q2 = SUM(q(i,k,tracers(iqPar)%iqDesc), DIM=3)
+               IF(q2 <= qmin) CYCLE
+               deltaD = (q2/q1/tnat(ixt)-1.)*1000.
+               IF(deltaD <= deltaDmax .AND. deltaD >= deltaDmin) CYCLE
+               CALL msg('ixt, iq = '//TRIM(strStack(int2str([ixt,iq]))), modname)
+               msg1 = '('//TRIM(strStack(int2str([i,k])))//')'
+               CALL msg(TRIM(tracers(iqpar)%name)//TRIM(msg1)//' = '//TRIM(real2str(q1)), modname)
+               CALL msg(TRIM(tracers(iq   )%name)//TRIM(msg1)//' = '//TRIM(real2str(q2)), modname)
+               CALL msg(TRIM(nm(iiso))//TRIM(real2str(deltaD)), modname)
+               CALL abort_gcm(modname, 'Error with isotopes: '//TRIM(err_msg), 1)
+            END DO
+         END DO
+      END DO
+   END DO
+
+   IF(nzone == 0) RETURN
+
+   !--- CHECK FOR TAGGING TRACERS DELTAD ANOMALIES
+   modname = 'check_isotopes:iso_verif_aberrant'
+   IF(iso_eau /= 0 .AND. iso_HDO /= 0) THEN
+      DO izon = 1, nzone
+         ixt  = itZonIso(izon, iso_HDO)
+         ieau = itZonIso(izon, iso_eau)
+         DO ipha = 1, nphas
+            iq    = iqIsoPha(ixt,  ipha)
+            iqeau = iqIsoPha(ieau, ipha)
+            DO k = 1, llm
+               DO i = 1, ip1jmp1
+                  q1 = q(i,k,iqeau)
+                  q2 = q(i,k,iq)
+                  IF(q2<=qmin) CYCLE
+                  deltaD = (q2/q1/tnat(iso_HDO)-1.)*1000.
+                  IF(deltaD <= deltaDmax .AND. deltaD >= deltaDmin) CYCLE
+                  CALL msg('izon, ipha = '//TRIM(strStack(int2str([izon, ipha]))), modname)
+                  CALL msg( 'ixt, ieau = '//TRIM(strStack(int2str([ ixt, ieau]))), modname)
+                  msg1 = '('//TRIM(strStack(int2str([i,k])))//')'
+                  CALL msg(TRIM(tracers(iqeau)%name)//TRIM(msg1)//' = '//TRIM(real2str(q1)), modname)
+                  CALL msg(TRIM(tracers(iq   )%name)//TRIM(msg1)//' = '//TRIM(real2str(q2)), modname)
+                  CALL msg('deltaD = '//TRIM(real2str(deltaD)), modname)
+                  CALL abort_gcm(modname, 'Error with isotopes: '//TRIM(err_msg), 1)
+               END DO
+            END DO
+         END DO
+      END DO
+   END IF
+
+   !--- CHECK FOR TAGGING TRACERS CONSERVATION (PARENT AND TAGGING TRACERS SUM OVER ALL REGIONS MUST BE EQUAL)
+   DO iiso = 1, niso
+      DO ipha = 1, nphas
+         iq = iqIsoPha(iiso, ipha)
+         DO k = 1, llm
+            DO i = 1, ip1jmp1
+               xiiso = q(i,k,iq)
+               xtractot = SUM(q(i, k, iqIsoPha(itZonIso(1:nzone,iiso), ipha)))
+               IF(ABS(xtractot-xiiso) > errmax .AND. ABS(xtractot-xiiso)/MAX(MAX(ABS(xtractot),ABS(xiiso)),1e-18) > errmaxrel) THEN
+                  CALL msg('Error in iso_verif_aberrant trac: '//TRIM(err_msg))
+                  CALL msg('iiso, ipha = '//TRIM(strStack(int2str([iiso, ipha]))), modname)
+                  CALL msg('q('//TRIM(strStack(int2str([i,k])))//',:) = '//TRIM(strStack(real2str(q(i,k,:)))), modname)
+                  CALL abort_gcm(modname, 'Error with isotopes: '//TRIM(err_msg), 1)
+               END IF
+               IF(ABS(xtractot) <= ridicule) CYCLE
+               DO izon = 1, nzone
+                  q(i,k,iq) = q(i,k,iq) / xtractot * xiiso !--- Bidouille pour convergence
+               END DO
+            END DO
+         END DO
+      END DO
+   END DO
+
+END SUBROUTINE check_isotopes_seq
+
Index: DZ6/trunk/libf/dyn3d/conf_gcm.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d/conf_gcm.F90	(revision 5267)
+++ 	(revision )
@@ -1,916 +1,0 @@
-
-! $Id$
-
-SUBROUTINE conf_gcm( tapedef, etatinit )
-
-  USE control_mod
-  use IOIPSL
-  USE infotrac, ONLY : type_trac
-  use assert_m, only: assert
-  USE comconst_mod, ONLY: dissip_deltaz, dissip_factz, dissip_zref, &
-                          iflag_top_bound, mode_top_bound, tau_top_bound, &
-                          ngroup, maxlatfilter
-  USE logic_mod, ONLY: fxyhypb, iflag_phys, ok_etat0, ok_gradsfile, &
-                       ok_guide, ok_limit, ok_strato, purmats, read_start, &
-                       ysinus, read_orop, adv_qsat_liq
-  USE serre_mod, ONLY: clon,clat,grossismx,grossismy,dzoomx,dzoomy, &
-                       alphax,alphay,taux,tauy
-  USE temps_mod, ONLY: calend, year_len
-
-  IMPLICIT NONE
-  !-----------------------------------------------------------------------
-  !     Auteurs :   L. Fairhead , P. Le Van  .
-
-  !     Arguments :
-
-  !     tapedef   :
-  !     etatinit  :     = TRUE   , on ne  compare pas les valeurs des para- 
-  !     -metres  du zoom  avec  celles lues sur le fichier start .
-
-  LOGICAL,INTENT(IN) :: etatinit
-  INTEGER,INTENT(IN) :: tapedef
-
-  !   Declarations :
-  !   --------------
-  include "dimensions.h"
-  include "paramet.h"
-  include "comdissnew.h"
-  include "iniprint.h"
-
-  !   local:
-  !   ------
-
-  REAL clonn,clatt,grossismxx,grossismyy
-  REAL dzoomxx,dzoomyy, tauxx,tauyy
-  LOGICAL  fxyhypbb, ysinuss
-
-  !  -------------------------------------------------------------------
-
-  !       .........     Version  du 29/04/97       ..........
-
-  !   Nouveaux parametres nitergdiv,nitergrot,niterh,tetagdiv,tetagrot,
-  !      tetatemp   ajoutes  pour la dissipation   .
-
-  !   Autre parametre ajoute en fin de liste de tapedef : ** fxyhypb ** 
-
-  !  Si fxyhypb = .TRUE. , choix de la fonction a derivee tangente hyperb.
-  !    Sinon , choix de fxynew  , a derivee sinusoidale  ..
-
-  !   ......  etatinit = . TRUE. si defrun  est appele dans ETAT0_LMD  ou
-  !         LIMIT_LMD  pour l'initialisation de start.dat (dic) et
-  !                de limit.dat ( dic)                        ...........
-  !           Sinon  etatinit = . FALSE .
-
-  !   Donc etatinit = .F.  si on veut comparer les valeurs de  grossismx ,
-  !    grossismy,clon,clat, fxyhypb  lues sur  le fichier  start  avec
-  !   celles passees  par run.def ,  au debut du gcm, apres l'appel a 
-  !    lectba .  
-  !   Ces parmetres definissant entre autres la grille et doivent etre
-  !   pareils et coherents , sinon il y aura  divergence du gcm .
-
-  !-----------------------------------------------------------------------
-  !   initialisations:
-  !   ----------------
-
-  !Config  Key  = lunout
-  !Config  Desc = unite de fichier pour les impressions
-  !Config  Def  = 6
-  !Config  Help = unite de fichier pour les impressions 
-  !Config         (defaut sortie standard = 6)
-  lunout=6
-  CALL getin('lunout', lunout)
-  IF (lunout /= 5 .and. lunout /= 6) THEN
-     OPEN(UNIT=lunout,FILE='lmdz.out',ACTION='write',                      &
-          STATUS='unknown',FORM='formatted')
-  ENDIF
-
-  !Config  Key  = prt_level
-  !Config  Desc = niveau d'impressions de d\'ebogage
-  !Config  Def  = 0
-  !Config  Help = Niveau d'impression pour le d\'ebogage
-  !Config         (0 = minimum d'impression)
-  prt_level = 0
-  CALL getin('prt_level',prt_level)
-
-  !-----------------------------------------------------------------------
-  !  Parametres de controle du run:
-  !-----------------------------------------------------------------------
-  !Config  Key  = planet_type
-  !Config  Desc = planet type ("earth", "mars", "venus", ...)
-  !Config  Def  = earth
-  !Config  Help = this flag sets the type of atymosphere that is considered
-  planet_type="earth"
-  CALL getin('planet_type',planet_type)
-
-  !Config  Key  = calend
-  !Config  Desc = type de calendrier utilise
-  !Config  Def  = earth_360d
-  !Config  Help = valeur possible: earth_360d, earth_365d, earth_366d
-  !Config         
-  calend = 'earth_360d'
-  CALL getin('calend', calend)
-! initialize year_len for aquaplanets and 1D
-  IF (calend == 'earth_360d') THEN
-     year_len=360
-  ELSE IF (calend == 'earth_365d') THEN
-     year_len=365
-  ELSE IF (calend == 'earth_366d') THEN
-     year_len=366
-  ELSE 
-     year_len=1
-  ENDIF
-
-  !Config  Key  = dayref
-  !Config  Desc = Jour de l'etat initial
-  !Config  Def  = 1
-  !Config  Help = Jour de l'etat initial ( = 350  si 20 Decembre ,
-  !Config         par expl. ,comme ici ) ... A completer
-  dayref=1
-  CALL getin('dayref', dayref)
-
-  !Config  Key  = anneeref
-  !Config  Desc = Annee de l'etat initial
-  !Config  Def  = 1998
-  !Config  Help = Annee de l'etat  initial 
-  !Config         (   avec  4  chiffres   ) ... A completer
-  anneeref = 1998
-  CALL getin('anneeref',anneeref)
-
-  !Config  Key  = raz_date
-  !Config  Desc = Remise a zero de la date initiale
-  !Config  Def  = 0 (pas de remise a zero)
-  !Config  Help = Remise a zero de la date initiale 
-  !Config         0 pas de remise a zero, on garde la date du fichier restart
-  !Config         1 prise en compte de la date de gcm.def avec remise a zero
-  !Config         des compteurs de pas de temps
-  raz_date = 0
-  CALL getin('raz_date', raz_date)
-
-  !Config  Key  = resetvarc
-  !Config  Desc = Reinit des variables de controle
-  !Config  Def  = n
-  !Config  Help = Reinit des variables de controle
-  resetvarc = .false.
-  CALL getin('resetvarc',resetvarc)
-
-  !Config  Key  = nday
-  !Config  Desc = Nombre de jours d'integration
-  !Config  Def  = 10
-  !Config  Help = Nombre de jours d'integration
-  !Config         ... On pourait aussi permettre des mois ou des annees !
-  nday = 10
-  CALL getin('nday',nday)
-
-  !Config  Key  = starttime
-  !Config  Desc = Heure de depart de la simulation
-  !Config  Def  = 0
-  !Config  Help = Heure de depart de la simulation
-  !Config         en jour
-  starttime = 0
-  CALL getin('starttime',starttime)
-
-  !Config  Key  = day_step
-  !Config  Desc = nombre de pas par jour
-  !Config  Def  = 240 
-  !Config  Help = nombre de pas par jour (multiple de iperiod) (
-  !Config          ici pour  dt = 1 min ) 
-  day_step = 240 
-  CALL getin('day_step',day_step)
-
-  !Config  Key  = nsplit_phys
-  nsplit_phys = 1 
-  CALL getin('nsplit_phys',nsplit_phys)
-
-  !Config  Key  = iperiod
-  !Config  Desc = periode pour le pas Matsuno
-  !Config  Def  = 5
-  !Config  Help = periode pour le pas Matsuno (en pas de temps)
-  iperiod = 5
-  CALL getin('iperiod',iperiod)
-
-  !Config  Key  = iapp_tracvl
-  !Config  Desc = frequence du groupement des flux 
-  !Config  Def  = iperiod
-  !Config  Help = frequence du groupement des flux (en pas de temps) 
-  iapp_tracvl = iperiod
-  CALL getin('iapp_tracvl',iapp_tracvl)
-
-  !Config  Key  = iconser
-  !Config  Desc = periode de sortie des variables de controle
-  !Config  Def  = 240  
-  !Config  Help = periode de sortie des variables de controle
-  !Config         (En pas de temps)
-  iconser = 240  
-  CALL getin('iconser', iconser)
-
-  !Config  Key  = iecri
-  !Config  Desc = periode d'ecriture du fichier histoire
-  !Config  Def  = 1
-  !Config  Help = periode d'ecriture du fichier histoire (en jour) 
-  iecri = 1
-  CALL getin('iecri',iecri)
-
-  !Config  Key  = periodav
-  !Config  Desc = periode de stockage fichier histmoy
-  !Config  Def  = 1
-  !Config  Help = periode de stockage fichier histmoy (en jour) 
-  periodav = 1.
-  CALL getin('periodav',periodav)
-
-  !Config  Key  = output_grads_dyn
-  !Config  Desc = output dynamics diagnostics in 'dyn.dat' file
-  !Config  Def  = n
-  !Config  Help = output dynamics diagnostics in Grads-readable 'dyn.dat' file
-  output_grads_dyn=.false.
-  CALL getin('output_grads_dyn',output_grads_dyn)
-
-  !Config  Key  = dissip_period
-  !Config  Desc = periode de la dissipation 
-  !Config  Def  = 0
-  !Config  Help = periode de la dissipation 
-  !Config  dissip_period=0 => la valeur sera calcule dans inidissip       
-  !Config  dissip_period>0 => on prend cette valeur
-  dissip_period = 0
-  CALL getin('dissip_period',dissip_period)
-
-  !cc  ....   P. Le Van , modif le 29/04/97 .pour la dissipation  ...
-  !cc
-
-  !Config  Key  = lstardis
-  !Config  Desc = choix de l'operateur de dissipation
-  !Config  Def  = y
-  !Config  Help = choix de l'operateur de dissipation
-  !Config         'y' si on veut star et 'n' si on veut non-start !
-  !Config         Moi y en a pas comprendre ! 
-  lstardis = .TRUE.
-  CALL getin('lstardis',lstardis)
-
-  !Config  Key  = nitergdiv
-  !Config  Desc = Nombre d'iteration de gradiv
-  !Config  Def  = 1
-  !Config  Help = nombre d'iterations de l'operateur de dissipation 
-  !Config         gradiv
-  nitergdiv = 1
-  CALL getin('nitergdiv',nitergdiv)
-
-  !Config  Key  = nitergrot
-  !Config  Desc = nombre d'iterations de nxgradrot
-  !Config  Def  = 2
-  !Config  Help = nombre d'iterations de l'operateur de dissipation  
-  !Config         nxgradrot
-  nitergrot = 2
-  CALL getin('nitergrot',nitergrot)
-
-  !Config  Key  = niterh
-  !Config  Desc = nombre d'iterations de divgrad
-  !Config  Def  = 2
-  !Config  Help = nombre d'iterations de l'operateur de dissipation
-  !Config         divgrad
-  niterh = 2
-  CALL getin('niterh',niterh)
-
-  !Config  Key  = tetagdiv
-  !Config  Desc = temps de dissipation pour div
-  !Config  Def  = 7200
-  !Config  Help = temps de dissipation des plus petites longeur 
-  !Config         d'ondes pour u,v (gradiv)
-  tetagdiv = 7200.
-  CALL getin('tetagdiv',tetagdiv)
-
-  !Config  Key  = tetagrot
-  !Config  Desc = temps de dissipation pour grad
-  !Config  Def  = 7200
-  !Config  Help = temps de dissipation des plus petites longeur 
-  !Config         d'ondes pour u,v (nxgradrot)
-  tetagrot = 7200.
-  CALL getin('tetagrot',tetagrot)
-
-  !Config  Key  = tetatemp 
-  !Config  Desc = temps de dissipation pour h
-  !Config  Def  = 7200
-  !Config  Help =  temps de dissipation des plus petites longeur 
-  !Config         d'ondes pour h (divgrad)   
-  tetatemp  = 7200.
-  CALL getin('tetatemp',tetatemp )
-
-  ! Parametres controlant la variation sur la verticale des constantes de
-  ! dissipation.
-  ! Pour le moment actifs uniquement dans la version a 39 niveaux
-  ! avec ok_strato=y
-
-  dissip_factz=4.
-  dissip_deltaz=10.
-  dissip_zref=30.
-  CALL getin('dissip_factz',dissip_factz )
-  CALL getin('dissip_deltaz',dissip_deltaz )
-  CALL getin('dissip_zref',dissip_zref )
-
-  ! maxlatfilter
-  maxlatfilter=-1.0
-  CALL getin('maxlatfilter',maxlatfilter)
-  if (maxlatfilter > 90) &
-       call abort_gcm("conf_gcm", 'maxlatfilter should be <=90', 1)
-
-
-  ! ngroup
-  ngroup=3
-  CALL getin('ngroup',ngroup)
-
-  ! top_bound sponge: only active if ok_strato=.true. and iflag_top_bound!=0
-  !                   iflag_top_bound=0 for no sponge
-  !                   iflag_top_bound=1 for sponge over 4 topmost layers
-  !                   iflag_top_bound=2 for sponge from top to ~1% of top layer pressure
-  iflag_top_bound=1
-  CALL getin('iflag_top_bound',iflag_top_bound)
-  IF (iflag_top_bound < 0 .or. iflag_top_bound > 2) &
-       call abort_gcm("conf_gcm", 'iflag_top_bound must be 0, 1 or 2', 1)
-
-  ! mode_top_bound : fields towards which sponge relaxation will be done:
-  !                  mode_top_bound=0: no relaxation
-  !                  mode_top_bound=1: u and v relax towards 0
-  !                  mode_top_bound=2: u and v relax towards their zonal mean
-  !                  mode_top_bound=3: u,v and pot. temp. relax towards their zonal mean
-  mode_top_bound=3
-  CALL getin('mode_top_bound',mode_top_bound)
-
-  ! top_bound sponge : inverse of charactericstic relaxation time scale for sponge
-  tau_top_bound=1.e-5
-  CALL getin('tau_top_bound',tau_top_bound)
-
-  !Config  Key  = coefdis
-  !Config  Desc = coefficient pour gamdissip
-  !Config  Def  = 0
-  !Config  Help = coefficient pour gamdissip  
-  coefdis = 0.
-  CALL getin('coefdis',coefdis)
-
-  !Config  Key  = purmats
-  !Config  Desc = Schema d'integration
-  !Config  Def  = n
-  !Config  Help = Choix du schema d'integration temporel.
-  !Config         y = pure Matsuno sinon c'est du Matsuno-leapfrog
-  purmats = .FALSE.
-  CALL getin('purmats',purmats)
-
-  !Config  Key  = ok_guide
-  !Config  Desc = Guidage
-  !Config  Def  = n
-  !Config  Help = Guidage
-  ok_guide = .FALSE.
-  CALL getin('ok_guide',ok_guide)
-
-  !Config  Key  =  read_start
-  !Config  Desc = Initialize model using a 'start.nc' file
-  !Config  Def  = y
-  !Config  Help = y: intialize dynamical fields using a 'start.nc' file
-  !               n: fields are initialized by 'iniacademic' routine
-  read_start= .true.
-  CALL getin('read_start',read_start)
-
-  !Config  Key  = iflag_phys
-  !Config  Desc = Avec ls physique 
-  !Config  Def  = 1
-  !Config  Help = Permet de faire tourner le modele sans 
-  !Config         physique.
-  iflag_phys = 1
-  CALL getin('iflag_phys',iflag_phys)
-
-  !Config  Key  =  iphysiq
-  !Config  Desc = Periode de la physique
-  !Config  Def  = 5
-  !Config  Help = Periode de la physique en pas de temps de la dynamique.
-  iphysiq = 5
-  CALL getin('iphysiq', iphysiq)
-
-  !Config  Key  = ip_ebil_dyn
-  !Config  Desc = PRINT level for energy conserv. diag.
-  !Config  Def  = 0
-  !Config  Help = PRINT level for energy conservation diag. ;
-  !               les options suivantes existent :
-  !Config         0 pas de print
-  !Config         1 pas de print
-  !Config         2 print,
-  ip_ebil_dyn = 0
-  CALL getin('ip_ebil_dyn',ip_ebil_dyn)
-
-  !cc  ....   P. Le Van , ajout  le 7/03/95 .pour le zoom ...
-  !     .........   (  modif  le 17/04/96 )   .........
-
-  test_etatinit: IF (.not. etatinit) THEN
-     !Config  Key  = clon
-     !Config  Desc = centre du zoom, longitude
-     !Config  Def  = 0
-     !Config  Help = longitude en degres du centre 
-     !Config         du zoom
-     clonn = 0.
-     CALL getin('clon',clonn)
-
-     !Config  Key  = clat
-     !Config  Desc = centre du zoom, latitude
-     !Config  Def  = 0
-     !Config  Help = latitude en degres du centre du zoom
-     !Config         
-     clatt = 0.
-     CALL getin('clat',clatt)
-
-     IF( ABS(clat - clatt).GE. 0.001 )  THEN
-        write(lunout,*)'conf_gcm: La valeur de clat passee par run.def', &
-             ' est differente de celle lue sur le fichier  start '
-        CALL abort_gcm("conf_gcm","stopped",1)
-     ENDIF
-
-     !Config  Key  = grossismx 
-     !Config  Desc = zoom en longitude
-     !Config  Def  = 1.0
-     !Config  Help = facteur de grossissement du zoom,
-     !Config         selon la longitude
-     grossismxx = 1.0
-     CALL getin('grossismx',grossismxx)
-
-     IF( ABS(grossismx - grossismxx).GE. 0.001 )  THEN
-        write(lunout,*)'conf_gcm: La valeur de grossismx passee par ', &
-             'run.def est differente de celle lue sur le fichier  start '
-        CALL abort_gcm("conf_gcm","stopped",1)
-     ENDIF
-
-     !Config  Key  = grossismy
-     !Config  Desc = zoom en latitude
-     !Config  Def  = 1.0
-     !Config  Help = facteur de grossissement du zoom,
-     !Config         selon la latitude
-     grossismyy = 1.0
-     CALL getin('grossismy',grossismyy)
-
-     IF( ABS(grossismy - grossismyy).GE. 0.001 )  THEN
-        write(lunout,*)'conf_gcm: La valeur de grossismy passee par ', &
-             'run.def est differente de celle lue sur le fichier  start '
-        CALL abort_gcm("conf_gcm","stopped",1)
-     ENDIF
-
-     IF( grossismx.LT.1. )  THEN
-        write(lunout,*) &
-             'conf_gcm: ***  ATTENTION !! grossismx < 1 .   *** '
-        CALL abort_gcm("conf_gcm","stopped",1)
-     ELSE
-        alphax = 1. - 1./ grossismx
-     ENDIF
-
-     IF( grossismy.LT.1. )  THEN
-        write(lunout,*) &
-             'conf_gcm: ***  ATTENTION !! grossismy < 1 .   *** '
-        CALL abort_gcm("conf_gcm","stopped",1)
-     ELSE
-        alphay = 1. - 1./ grossismy
-     ENDIF
-
-     write(lunout,*)'conf_gcm: alphax alphay',alphax,alphay
-
-     !    alphax et alphay sont les anciennes formulat. des grossissements
-
-     !Config  Key  = fxyhypb
-     !Config  Desc = Fonction  hyperbolique
-     !Config  Def  = y
-     !Config  Help = Fonction  f(y)  hyperbolique  si = .true.  
-     !Config         sinon  sinusoidale
-     fxyhypbb = .TRUE.
-     CALL getin('fxyhypb',fxyhypbb)
-
-     IF( .NOT.fxyhypb )  THEN
-        IF( fxyhypbb )     THEN
-           write(lunout,*)' ********  PBS DANS  CONF_GCM  ******** '
-           write(lunout,*)' *** fxyhypb lu sur le fichier start est ', &
-                'F alors  qu il est  T  sur  run.def  ***'
-           CALL abort_gcm("conf_gcm","stopped",1)
-        ENDIF
-     ELSE
-        IF( .NOT.fxyhypbb )   THEN
-           write(lunout,*)' ********  PBS DANS  CONF_GCM  ******** '
-           write(lunout,*)' ***  fxyhypb lu sur le fichier start est ', &
-                'T alors  qu il est  F  sur  run.def  ****  '
-           CALL abort_gcm("conf_gcm","stopped",1)
-        ENDIF
-     ENDIF
-
-     !Config  Key  = dzoomx
-     !Config  Desc = extension en longitude
-     !Config  Def  = 0
-     !Config  Help = extension en longitude  de la zone du zoom  
-     !Config         ( fraction de la zone totale)
-     dzoomxx = 0.0
-     CALL getin('dzoomx',dzoomxx)
-
-     IF( fxyhypb )  THEN
-        IF( ABS(dzoomx - dzoomxx).GE. 0.001 )  THEN
-           write(lunout,*)'conf_gcm: La valeur de dzoomx passee par ', &
-                'run.def est differente de celle lue sur le fichier  start '
-           CALL abort_gcm("conf_gcm","stopped",1)
-        ENDIF
-     ENDIF
-
-     !Config  Key  = dzoomy
-     !Config  Desc = extension en latitude
-     !Config  Def  = 0
-     !Config  Help = extension en latitude de la zone  du zoom  
-     !Config         ( fraction de la zone totale)
-     dzoomyy = 0.0
-     CALL getin('dzoomy',dzoomyy)
-
-     IF( fxyhypb )  THEN
-        IF( ABS(dzoomy - dzoomyy).GE. 0.001 )  THEN
-           write(lunout,*)'conf_gcm: La valeur de dzoomy passee par ', &
-                'run.def est differente de celle lue sur le fichier  start '
-           CALL abort_gcm("conf_gcm","stopped",1)
-        ENDIF
-     ENDIF
-
-     !Config  Key  = taux
-     !Config  Desc = raideur du zoom en  X
-     !Config  Def  = 3
-     !Config  Help = raideur du zoom en  X
-     tauxx = 3.0
-     CALL getin('taux',tauxx)
-
-     IF( fxyhypb )  THEN
-        IF( ABS(taux - tauxx).GE. 0.001 )  THEN
-           write(lunout,*)'conf_gcm: La valeur de taux passee par ', &
-                'run.def est differente de celle lue sur le fichier  start '
-           CALL abort_gcm("conf_gcm","stopped",1)
-        ENDIF
-     ENDIF
-
-     !Config  Key  = tauyy
-     !Config  Desc = raideur du zoom en  Y
-     !Config  Def  = 3
-     !Config  Help = raideur du zoom en  Y
-     tauyy = 3.0
-     CALL getin('tauy',tauyy)
-
-     IF( fxyhypb )  THEN
-        IF( ABS(tauy - tauyy).GE. 0.001 )  THEN
-           write(lunout,*)'conf_gcm: La valeur de tauy passee par ', &
-                'run.def est differente de celle lue sur le fichier  start '
-           CALL abort_gcm("conf_gcm","stopped",1)
-        ENDIF
-     ENDIF
-
-     !c
-     IF( .NOT.fxyhypb  )  THEN
-
-        !Config  Key  = ysinus
-        !Config  IF   = !fxyhypb
-        !Config  Desc = Fonction en Sinus
-        !Config  Def  = y
-        !Config  Help = Fonction  f(y) avec y = Sin(latit.) si = .true. 
-        !Config         sinon y = latit.
-        ysinuss = .TRUE.
-        CALL getin('ysinus',ysinuss)
-
-        IF( .NOT.ysinus )  THEN
-           IF( ysinuss )     THEN
-              write(lunout,*)' ********  PBS DANS  CONF_GCM  ******** '
-              write(lunout,*)' *** ysinus lu sur le fichier start est F', &
-                   ' alors  qu il est  T  sur  run.def  ***'
-              CALL abort_gcm("conf_gcm","stopped",1)
-           ENDIF
-        ELSE
-           IF( .NOT.ysinuss )   THEN
-              write(lunout,*)' ********  PBS DANS  CONF_GCM  ******** '
-              write(lunout,*)' *** ysinus lu sur le fichier start est T', &
-                   ' alors  qu il est  F  sur  run.def  ****  '
-              CALL abort_gcm("conf_gcm","stopped",1)
-           ENDIF
-        ENDIF
-     ENDIF ! of IF( .NOT.fxyhypb  )
-
-     !Config  Key  = offline
-     !Config  Desc = Nouvelle eau liquide
-     !Config  Def  = n
-     !Config  Help = Permet de mettre en route la
-     !Config         nouvelle parametrisation de l'eau liquide !
-     offline = .FALSE.
-     CALL getin('offline',offline)
-
-     !Config  Key  = type_trac
-     !Config  Desc = Choix de couplage avec model de chimie INCA ou REPROBUS
-     !Config  Def  = lmdz
-     !Config  Help = 
-     !Config         'lmdz' = pas de couplage, pur LMDZ
-     !Config         'inca' = model de chime INCA 
-     !Config         'repr' = model de chime REPROBUS
-     !Config         'inco' = INCA + CO2i (temporaire)
-     type_trac = 'lmdz'
-     CALL getin('type_trac',type_trac)
-
-
-     !Config  Key  = adv_qsat_liq
-     !Config  Desc = option for qsat calculation in the dynamics
-     !Config  Def  = n 
-     !Config  Help = controls which phase is considered for qsat calculation 
-     !Config          
-     adv_qsat_liq = .FALSE.
-     CALL getin('adv_qsat_liq',adv_qsat_liq)
-
-     !Config  Key  = ok_dynzon 
-     !Config  Desc = calcul et sortie des transports 
-     !Config  Def  = n 
-     !Config  Help = Permet de mettre en route le calcul des transports 
-     !Config          
-     ok_dynzon = .FALSE. 
-     CALL getin('ok_dynzon',ok_dynzon) 
-
-     !Config  Key  = ok_dyn_ins
-     !Config  Desc = sorties instantanees dans la dynamique
-     !Config  Def  = n 
-     !Config  Help = 
-     !Config          
-     ok_dyn_ins = .FALSE. 
-     CALL getin('ok_dyn_ins',ok_dyn_ins) 
-
-     !Config  Key  = ok_dyn_ave
-     !Config  Desc = sorties moyennes dans la dynamique
-     !Config  Def  = n 
-     !Config  Help = 
-     !Config          
-     ok_dyn_ave = .FALSE. 
-     CALL getin('ok_dyn_ave',ok_dyn_ave) 
-
-     write(lunout,*)' #########################################'
-     write(lunout,*)' Configuration des parametres du gcm: '
-     write(lunout,*)' planet_type = ', planet_type
-     write(lunout,*)' calend = ', calend
-     write(lunout,*)' dayref = ', dayref
-     write(lunout,*)' anneeref = ', anneeref
-     write(lunout,*)' nday = ', nday
-     write(lunout,*)' day_step = ', day_step
-     write(lunout,*)' iperiod = ', iperiod
-     write(lunout,*)' nsplit_phys = ', nsplit_phys
-     write(lunout,*)' iconser = ', iconser
-     write(lunout,*)' iecri = ', iecri
-     write(lunout,*)' periodav = ', periodav 
-     write(lunout,*)' output_grads_dyn = ', output_grads_dyn
-     write(lunout,*)' dissip_period = ', dissip_period
-     write(lunout,*)' lstardis = ', lstardis
-     write(lunout,*)' nitergdiv = ', nitergdiv
-     write(lunout,*)' nitergrot = ', nitergrot
-     write(lunout,*)' niterh = ', niterh
-     write(lunout,*)' tetagdiv = ', tetagdiv
-     write(lunout,*)' tetagrot = ', tetagrot
-     write(lunout,*)' tetatemp = ', tetatemp
-     write(lunout,*)' coefdis = ', coefdis
-     write(lunout,*)' purmats = ', purmats
-     write(lunout,*)' read_start = ', read_start
-     write(lunout,*)' iflag_phys = ', iflag_phys
-     write(lunout,*)' iphysiq = ', iphysiq
-     write(lunout,*)' clonn = ', clonn 
-     write(lunout,*)' clatt = ', clatt
-     write(lunout,*)' grossismx = ', grossismx
-     write(lunout,*)' grossismy = ', grossismy
-     write(lunout,*)' fxyhypbb = ', fxyhypbb
-     write(lunout,*)' dzoomxx = ', dzoomxx
-     write(lunout,*)' dzoomy = ', dzoomyy
-     write(lunout,*)' tauxx = ', tauxx
-     write(lunout,*)' tauyy = ', tauyy
-     write(lunout,*)' offline = ', offline
-     write(lunout,*)' type_trac = ', type_trac
-     write(lunout,*)' ok_dynzon = ', ok_dynzon 
-     write(lunout,*)' ok_dyn_ins = ', ok_dyn_ins 
-     write(lunout,*)' ok_dyn_ave = ', ok_dyn_ave 
-     write(lunout,*)' adv_qsat_liq = ', adv_qsat_liq
-  ELSE
-     !Config  Key  = clon
-     !Config  Desc = centre du zoom, longitude
-     !Config  Def  = 0
-     !Config  Help = longitude en degres du centre 
-     !Config         du zoom
-     clon = 0.
-     CALL getin('clon',clon)
-
-     !Config  Key  = clat
-     !Config  Desc = centre du zoom, latitude
-     !Config  Def  = 0
-     !Config  Help = latitude en degres du centre du zoom
-     !Config         
-     clat = 0.
-     CALL getin('clat',clat)
-
-     !Config  Key  = grossismx 
-     !Config  Desc = zoom en longitude
-     !Config  Def  = 1.0
-     !Config  Help = facteur de grossissement du zoom,
-     !Config         selon la longitude
-     grossismx = 1.0
-     CALL getin('grossismx',grossismx)
-
-     !Config  Key  = grossismy
-     !Config  Desc = zoom en latitude
-     !Config  Def  = 1.0
-     !Config  Help = facteur de grossissement du zoom,
-     !Config         selon la latitude
-     grossismy = 1.0
-     CALL getin('grossismy',grossismy)
-
-     IF( grossismx.LT.1. )  THEN
-        write(lunout,*) &
-             'conf_gcm: ***  ATTENTION !! grossismx < 1 .   *** '
-        CALL abort_gcm("conf_gcm","stopped",1)
-     ELSE
-        alphax = 1. - 1./ grossismx
-     ENDIF
-
-     IF( grossismy.LT.1. )  THEN
-        write(lunout,*) 'conf_gcm: ***ATTENTION !! grossismy < 1 . *** '
-        CALL abort_gcm("conf_gcm","stopped",1)
-     ELSE
-        alphay = 1. - 1./ grossismy
-     ENDIF
-
-     write(lunout,*)'conf_gcm: alphax alphay ',alphax,alphay
-
-     !    alphax et alphay sont les anciennes formulat. des grossissements
-
-     !Config  Key  = fxyhypb
-     !Config  Desc = Fonction  hyperbolique
-     !Config  Def  = y
-     !Config  Help = Fonction  f(y)  hyperbolique  si = .true.  
-     !Config         sinon  sinusoidale
-     fxyhypb = .TRUE.
-     CALL getin('fxyhypb',fxyhypb)
-
-     !Config  Key  = dzoomx
-     !Config  Desc = extension en longitude
-     !Config  Def  = 0
-     !Config  Help = extension en longitude  de la zone du zoom  
-     !Config         ( fraction de la zone totale)
-     dzoomx = 0.2
-     CALL getin('dzoomx',dzoomx)
-     call assert(dzoomx < 1, "conf_gcm: dzoomx must be < 1")
-
-     !Config  Key  = dzoomy
-     !Config  Desc = extension en latitude
-     !Config  Def  = 0
-     !Config  Help = extension en latitude de la zone  du zoom  
-     !Config         ( fraction de la zone totale)
-     dzoomy = 0.2
-     CALL getin('dzoomy',dzoomy)
-     call assert(dzoomy < 1, "conf_gcm: dzoomy must be < 1")
-
-     !Config  Key  = taux
-     !Config  Desc = raideur du zoom en  X
-     !Config  Def  = 3
-     !Config  Help = raideur du zoom en  X
-     taux = 3.0
-     CALL getin('taux',taux)
-
-     !Config  Key  = tauy
-     !Config  Desc = raideur du zoom en  Y
-     !Config  Def  = 3
-     !Config  Help = raideur du zoom en  Y
-     tauy = 3.0
-     CALL getin('tauy',tauy)
-
-     !Config  Key  = ysinus
-     !Config  IF   = !fxyhypb
-     !Config  Desc = Fonction en Sinus
-     !Config  Def  = y
-     !Config  Help = Fonction  f(y) avec y = Sin(latit.) si = .true. 
-     !Config         sinon y = latit.
-     ysinus = .TRUE.
-     CALL getin('ysinus',ysinus)
-
-     !Config  Key  = offline
-     !Config  Desc = Nouvelle eau liquide
-     !Config  Def  = n
-     !Config  Help = Permet de mettre en route la
-     !Config         nouvelle parametrisation de l'eau liquide !
-     offline = .FALSE.
-     CALL getin('offline',offline)
-
-     !Config  Key  = type_trac
-     !Config  Desc = Choix de couplage avec model de chimie INCA ou REPROBUS
-     !Config  Def  = lmdz
-     !Config  Help = 
-     !Config         'lmdz' = pas de couplage, pur LMDZ
-     !Config         'inca' = model de chime INCA 
-     !Config         'repr' = model de chime REPROBUS
-     !Config         'inco' = INCA + CO2i (temporaire)
-     type_trac = 'lmdz'
-     CALL getin('type_trac',type_trac)
-
-     !Config  Key  = ok_dynzon 
-     !Config  Desc = sortie des transports zonaux dans la dynamique
-     !Config  Def  = n 
-     !Config  Help = Permet de mettre en route le calcul des transports 
-     !Config          
-     ok_dynzon = .FALSE. 
-     CALL getin('ok_dynzon',ok_dynzon) 
-
-     !Config  Key  = ok_dyn_ins
-     !Config  Desc = sorties instantanees dans la dynamique
-     !Config  Def  = n 
-     !Config  Help = 
-     !Config          
-     ok_dyn_ins = .FALSE. 
-     CALL getin('ok_dyn_ins',ok_dyn_ins) 
-
-     !Config  Key  = ok_dyn_ave
-     !Config  Desc = sorties moyennes dans la dynamique
-     !Config  Def  = n 
-     !Config  Help = 
-     !Config          
-     ok_dyn_ave = .FALSE. 
-     CALL getin('ok_dyn_ave',ok_dyn_ave) 
-
-     !Config key = ok_strato
-     !Config  Desc = activation de la version strato
-     !Config  Def  = .FALSE.
-     !Config  Help = active la version stratosph\'erique de LMDZ de F. Lott
-
-     ok_strato=.FALSE.
-     CALL getin('ok_strato',ok_strato)
-
-     vert_prof_dissip = merge(1, 0, ok_strato .and. llm==39)
-     CALL getin('vert_prof_dissip', vert_prof_dissip)
-     call assert(vert_prof_dissip == 0 .or. vert_prof_dissip ==  1, &
-          "bad value for vert_prof_dissip")
-
-     !Config  Key  = ok_gradsfile
-     !Config  Desc = activation des sorties grads du guidage
-     !Config  Def  = n
-     !Config  Help = active les sorties grads du guidage
-
-     ok_gradsfile = .FALSE.
-     CALL getin('ok_gradsfile',ok_gradsfile)
-
-     !Config  Key  = ok_limit
-     !Config  Desc = creation des fichiers limit dans create_etat0_limit
-     !Config  Def  = y
-     !Config  Help = production du fichier limit.nc requise
-
-     ok_limit = .TRUE.
-     CALL getin('ok_limit',ok_limit)
-
-     !Config  Key  = ok_etat0
-     !Config  Desc = creation des fichiers etat0 dans create_etat0_limit
-     !Config  Def  = y
-     !Config  Help = production des fichiers start.nc, startphy.nc requise
-
-     ok_etat0 = .TRUE.
-     CALL getin('ok_etat0',ok_etat0)
-
-     !Config  Key  = read_orop
-     !Config  Desc = lecture du fichier de params orographiques sous maille
-     !Config  Def  = f
-     !Config  Help = lecture fichier plutot que grid_noro
-
-     read_orop = .FALSE.
-     CALL getin('read_orop',read_orop)
-
-     write(lunout,*)' #########################################'
-     write(lunout,*)' Configuration des parametres de cel0_limit: '
-     write(lunout,*)' planet_type = ', planet_type
-     write(lunout,*)' calend = ', calend
-     write(lunout,*)' dayref = ', dayref
-     write(lunout,*)' anneeref = ', anneeref
-     write(lunout,*)' nday = ', nday
-     write(lunout,*)' day_step = ', day_step
-     write(lunout,*)' iperiod = ', iperiod
-     write(lunout,*)' iconser = ', iconser
-     write(lunout,*)' iecri = ', iecri
-     write(lunout,*)' periodav = ', periodav 
-     write(lunout,*)' output_grads_dyn = ', output_grads_dyn
-     write(lunout,*)' dissip_period = ', dissip_period
-     write(lunout,*)' lstardis = ', lstardis
-     write(lunout,*)' nitergdiv = ', nitergdiv
-     write(lunout,*)' nitergrot = ', nitergrot
-     write(lunout,*)' niterh = ', niterh
-     write(lunout,*)' tetagdiv = ', tetagdiv
-     write(lunout,*)' tetagrot = ', tetagrot
-     write(lunout,*)' tetatemp = ', tetatemp
-     write(lunout,*)' coefdis = ', coefdis
-     write(lunout,*)' purmats = ', purmats
-     write(lunout,*)' read_start = ', read_start
-     write(lunout,*)' iflag_phys = ', iflag_phys
-     write(lunout,*)' iphysiq = ', iphysiq
-     write(lunout,*)' clon = ', clon
-     write(lunout,*)' clat = ', clat
-     write(lunout,*)' grossismx = ', grossismx
-     write(lunout,*)' grossismy = ', grossismy
-     write(lunout,*)' fxyhypb = ', fxyhypb
-     write(lunout,*)' dzoomx = ', dzoomx
-     write(lunout,*)' dzoomy = ', dzoomy
-     write(lunout,*)' taux = ', taux
-     write(lunout,*)' tauy = ', tauy
-     write(lunout,*)' offline = ', offline
-     write(lunout,*)' type_trac = ', type_trac
-     write(lunout,*)' ok_dynzon = ', ok_dynzon
-     write(lunout,*)' ok_dyn_ins = ', ok_dyn_ins 
-     write(lunout,*)' ok_dyn_ave = ', ok_dyn_ave 
-     write(lunout,*)' ok_strato = ', ok_strato
-     write(lunout,*)' ok_gradsfile = ', ok_gradsfile
-     write(lunout,*)' ok_limit = ', ok_limit
-     write(lunout,*)' ok_etat0 = ', ok_etat0
-     write(lunout,*)' ok_guide = ', ok_guide
-     write(lunout,*)' read_orop = ', read_orop
-  ENDIF test_etatinit
-
-END SUBROUTINE conf_gcm
Index: /LMDZ6/trunk/libf/dyn3d/conf_gcm.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d/conf_gcm.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3d/conf_gcm.f90	(revision 5268)
@@ -0,0 +1,916 @@
+
+! $Id$
+
+SUBROUTINE conf_gcm( tapedef, etatinit )
+
+  USE control_mod
+  use IOIPSL
+  USE infotrac, ONLY : type_trac
+  use assert_m, only: assert
+  USE comconst_mod, ONLY: dissip_deltaz, dissip_factz, dissip_zref, &
+                          iflag_top_bound, mode_top_bound, tau_top_bound, &
+                          ngroup, maxlatfilter
+  USE logic_mod, ONLY: fxyhypb, iflag_phys, ok_etat0, ok_gradsfile, &
+                       ok_guide, ok_limit, ok_strato, purmats, read_start, &
+                       ysinus, read_orop, adv_qsat_liq
+  USE serre_mod, ONLY: clon,clat,grossismx,grossismy,dzoomx,dzoomy, &
+                       alphax,alphay,taux,tauy
+  USE temps_mod, ONLY: calend, year_len
+
+  IMPLICIT NONE
+  !-----------------------------------------------------------------------
+  !     Auteurs :   L. Fairhead , P. Le Van  .
+
+  !     Arguments :
+
+  !     tapedef   :
+  !     etatinit  :     = TRUE   , on ne  compare pas les valeurs des para- 
+  !     -metres  du zoom  avec  celles lues sur le fichier start .
+
+  LOGICAL,INTENT(IN) :: etatinit
+  INTEGER,INTENT(IN) :: tapedef
+
+  !   Declarations :
+  !   --------------
+  include "dimensions.h"
+  include "paramet.h"
+  include "comdissnew.h"
+  include "iniprint.h"
+
+  !   local:
+  !   ------
+
+  REAL clonn,clatt,grossismxx,grossismyy
+  REAL dzoomxx,dzoomyy, tauxx,tauyy
+  LOGICAL  fxyhypbb, ysinuss
+
+  !  -------------------------------------------------------------------
+
+  !       .........     Version  du 29/04/97       ..........
+
+  !   Nouveaux parametres nitergdiv,nitergrot,niterh,tetagdiv,tetagrot,
+  !      tetatemp   ajoutes  pour la dissipation   .
+
+  !   Autre parametre ajoute en fin de liste de tapedef : ** fxyhypb ** 
+
+  !  Si fxyhypb = .TRUE. , choix de la fonction a derivee tangente hyperb.
+  !    Sinon , choix de fxynew  , a derivee sinusoidale  ..
+
+  !   ......  etatinit = . TRUE. si defrun  est appele dans ETAT0_LMD  ou
+  !         LIMIT_LMD  pour l'initialisation de start.dat (dic) et
+  !                de limit.dat ( dic)                        ...........
+  !           Sinon  etatinit = . FALSE .
+
+  !   Donc etatinit = .F.  si on veut comparer les valeurs de  grossismx ,
+  !    grossismy,clon,clat, fxyhypb  lues sur  le fichier  start  avec
+  !   celles passees  par run.def ,  au debut du gcm, apres l'appel a 
+  !    lectba .  
+  !   Ces parmetres definissant entre autres la grille et doivent etre
+  !   pareils et coherents , sinon il y aura  divergence du gcm .
+
+  !-----------------------------------------------------------------------
+  !   initialisations:
+  !   ----------------
+
+  !Config  Key  = lunout
+  !Config  Desc = unite de fichier pour les impressions
+  !Config  Def  = 6
+  !Config  Help = unite de fichier pour les impressions 
+  !Config         (defaut sortie standard = 6)
+  lunout=6
+  CALL getin('lunout', lunout)
+  IF (lunout /= 5 .and. lunout /= 6) THEN
+     OPEN(UNIT=lunout,FILE='lmdz.out',ACTION='write',                      &
+          STATUS='unknown',FORM='formatted')
+  ENDIF
+
+  !Config  Key  = prt_level
+  !Config  Desc = niveau d'impressions de d\'ebogage
+  !Config  Def  = 0
+  !Config  Help = Niveau d'impression pour le d\'ebogage
+  !Config         (0 = minimum d'impression)
+  prt_level = 0
+  CALL getin('prt_level',prt_level)
+
+  !-----------------------------------------------------------------------
+  !  Parametres de controle du run:
+  !-----------------------------------------------------------------------
+  !Config  Key  = planet_type
+  !Config  Desc = planet type ("earth", "mars", "venus", ...)
+  !Config  Def  = earth
+  !Config  Help = this flag sets the type of atymosphere that is considered
+  planet_type="earth"
+  CALL getin('planet_type',planet_type)
+
+  !Config  Key  = calend
+  !Config  Desc = type de calendrier utilise
+  !Config  Def  = earth_360d
+  !Config  Help = valeur possible: earth_360d, earth_365d, earth_366d
+  !Config         
+  calend = 'earth_360d'
+  CALL getin('calend', calend)
+! initialize year_len for aquaplanets and 1D
+  IF (calend == 'earth_360d') THEN
+     year_len=360
+  ELSE IF (calend == 'earth_365d') THEN
+     year_len=365
+  ELSE IF (calend == 'earth_366d') THEN
+     year_len=366
+  ELSE 
+     year_len=1
+  ENDIF
+
+  !Config  Key  = dayref
+  !Config  Desc = Jour de l'etat initial
+  !Config  Def  = 1
+  !Config  Help = Jour de l'etat initial ( = 350  si 20 Decembre ,
+  !Config         par expl. ,comme ici ) ... A completer
+  dayref=1
+  CALL getin('dayref', dayref)
+
+  !Config  Key  = anneeref
+  !Config  Desc = Annee de l'etat initial
+  !Config  Def  = 1998
+  !Config  Help = Annee de l'etat  initial 
+  !Config         (   avec  4  chiffres   ) ... A completer
+  anneeref = 1998
+  CALL getin('anneeref',anneeref)
+
+  !Config  Key  = raz_date
+  !Config  Desc = Remise a zero de la date initiale
+  !Config  Def  = 0 (pas de remise a zero)
+  !Config  Help = Remise a zero de la date initiale 
+  !Config         0 pas de remise a zero, on garde la date du fichier restart
+  !Config         1 prise en compte de la date de gcm.def avec remise a zero
+  !Config         des compteurs de pas de temps
+  raz_date = 0
+  CALL getin('raz_date', raz_date)
+
+  !Config  Key  = resetvarc
+  !Config  Desc = Reinit des variables de controle
+  !Config  Def  = n
+  !Config  Help = Reinit des variables de controle
+  resetvarc = .false.
+  CALL getin('resetvarc',resetvarc)
+
+  !Config  Key  = nday
+  !Config  Desc = Nombre de jours d'integration
+  !Config  Def  = 10
+  !Config  Help = Nombre de jours d'integration
+  !Config         ... On pourait aussi permettre des mois ou des annees !
+  nday = 10
+  CALL getin('nday',nday)
+
+  !Config  Key  = starttime
+  !Config  Desc = Heure de depart de la simulation
+  !Config  Def  = 0
+  !Config  Help = Heure de depart de la simulation
+  !Config         en jour
+  starttime = 0
+  CALL getin('starttime',starttime)
+
+  !Config  Key  = day_step
+  !Config  Desc = nombre de pas par jour
+  !Config  Def  = 240 
+  !Config  Help = nombre de pas par jour (multiple de iperiod) (
+  !Config          ici pour  dt = 1 min ) 
+  day_step = 240 
+  CALL getin('day_step',day_step)
+
+  !Config  Key  = nsplit_phys
+  nsplit_phys = 1 
+  CALL getin('nsplit_phys',nsplit_phys)
+
+  !Config  Key  = iperiod
+  !Config  Desc = periode pour le pas Matsuno
+  !Config  Def  = 5
+  !Config  Help = periode pour le pas Matsuno (en pas de temps)
+  iperiod = 5
+  CALL getin('iperiod',iperiod)
+
+  !Config  Key  = iapp_tracvl
+  !Config  Desc = frequence du groupement des flux 
+  !Config  Def  = iperiod
+  !Config  Help = frequence du groupement des flux (en pas de temps) 
+  iapp_tracvl = iperiod
+  CALL getin('iapp_tracvl',iapp_tracvl)
+
+  !Config  Key  = iconser
+  !Config  Desc = periode de sortie des variables de controle
+  !Config  Def  = 240  
+  !Config  Help = periode de sortie des variables de controle
+  !Config         (En pas de temps)
+  iconser = 240  
+  CALL getin('iconser', iconser)
+
+  !Config  Key  = iecri
+  !Config  Desc = periode d'ecriture du fichier histoire
+  !Config  Def  = 1
+  !Config  Help = periode d'ecriture du fichier histoire (en jour) 
+  iecri = 1
+  CALL getin('iecri',iecri)
+
+  !Config  Key  = periodav
+  !Config  Desc = periode de stockage fichier histmoy
+  !Config  Def  = 1
+  !Config  Help = periode de stockage fichier histmoy (en jour) 
+  periodav = 1.
+  CALL getin('periodav',periodav)
+
+  !Config  Key  = output_grads_dyn
+  !Config  Desc = output dynamics diagnostics in 'dyn.dat' file
+  !Config  Def  = n
+  !Config  Help = output dynamics diagnostics in Grads-readable 'dyn.dat' file
+  output_grads_dyn=.false.
+  CALL getin('output_grads_dyn',output_grads_dyn)
+
+  !Config  Key  = dissip_period
+  !Config  Desc = periode de la dissipation 
+  !Config  Def  = 0
+  !Config  Help = periode de la dissipation 
+  !Config  dissip_period=0 => la valeur sera calcule dans inidissip       
+  !Config  dissip_period>0 => on prend cette valeur
+  dissip_period = 0
+  CALL getin('dissip_period',dissip_period)
+
+  !cc  ....   P. Le Van , modif le 29/04/97 .pour la dissipation  ...
+  !cc
+
+  !Config  Key  = lstardis
+  !Config  Desc = choix de l'operateur de dissipation
+  !Config  Def  = y
+  !Config  Help = choix de l'operateur de dissipation
+  !Config         'y' si on veut star et 'n' si on veut non-start !
+  !Config         Moi y en a pas comprendre ! 
+  lstardis = .TRUE.
+  CALL getin('lstardis',lstardis)
+
+  !Config  Key  = nitergdiv
+  !Config  Desc = Nombre d'iteration de gradiv
+  !Config  Def  = 1
+  !Config  Help = nombre d'iterations de l'operateur de dissipation 
+  !Config         gradiv
+  nitergdiv = 1
+  CALL getin('nitergdiv',nitergdiv)
+
+  !Config  Key  = nitergrot
+  !Config  Desc = nombre d'iterations de nxgradrot
+  !Config  Def  = 2
+  !Config  Help = nombre d'iterations de l'operateur de dissipation  
+  !Config         nxgradrot
+  nitergrot = 2
+  CALL getin('nitergrot',nitergrot)
+
+  !Config  Key  = niterh
+  !Config  Desc = nombre d'iterations de divgrad
+  !Config  Def  = 2
+  !Config  Help = nombre d'iterations de l'operateur de dissipation
+  !Config         divgrad
+  niterh = 2
+  CALL getin('niterh',niterh)
+
+  !Config  Key  = tetagdiv
+  !Config  Desc = temps de dissipation pour div
+  !Config  Def  = 7200
+  !Config  Help = temps de dissipation des plus petites longeur 
+  !Config         d'ondes pour u,v (gradiv)
+  tetagdiv = 7200.
+  CALL getin('tetagdiv',tetagdiv)
+
+  !Config  Key  = tetagrot
+  !Config  Desc = temps de dissipation pour grad
+  !Config  Def  = 7200
+  !Config  Help = temps de dissipation des plus petites longeur 
+  !Config         d'ondes pour u,v (nxgradrot)
+  tetagrot = 7200.
+  CALL getin('tetagrot',tetagrot)
+
+  !Config  Key  = tetatemp 
+  !Config  Desc = temps de dissipation pour h
+  !Config  Def  = 7200
+  !Config  Help =  temps de dissipation des plus petites longeur 
+  !Config         d'ondes pour h (divgrad)   
+  tetatemp  = 7200.
+  CALL getin('tetatemp',tetatemp )
+
+  ! Parametres controlant la variation sur la verticale des constantes de
+  ! dissipation.
+  ! Pour le moment actifs uniquement dans la version a 39 niveaux
+  ! avec ok_strato=y
+
+  dissip_factz=4.
+  dissip_deltaz=10.
+  dissip_zref=30.
+  CALL getin('dissip_factz',dissip_factz )
+  CALL getin('dissip_deltaz',dissip_deltaz )
+  CALL getin('dissip_zref',dissip_zref )
+
+  ! maxlatfilter
+  maxlatfilter=-1.0
+  CALL getin('maxlatfilter',maxlatfilter)
+  if (maxlatfilter > 90) &
+       call abort_gcm("conf_gcm", 'maxlatfilter should be <=90', 1)
+
+
+  ! ngroup
+  ngroup=3
+  CALL getin('ngroup',ngroup)
+
+  ! top_bound sponge: only active if ok_strato=.true. and iflag_top_bound!=0
+  !                   iflag_top_bound=0 for no sponge
+  !                   iflag_top_bound=1 for sponge over 4 topmost layers
+  !                   iflag_top_bound=2 for sponge from top to ~1% of top layer pressure
+  iflag_top_bound=1
+  CALL getin('iflag_top_bound',iflag_top_bound)
+  IF (iflag_top_bound < 0 .or. iflag_top_bound > 2) &
+       call abort_gcm("conf_gcm", 'iflag_top_bound must be 0, 1 or 2', 1)
+
+  ! mode_top_bound : fields towards which sponge relaxation will be done:
+  !                  mode_top_bound=0: no relaxation
+  !                  mode_top_bound=1: u and v relax towards 0
+  !                  mode_top_bound=2: u and v relax towards their zonal mean
+  !                  mode_top_bound=3: u,v and pot. temp. relax towards their zonal mean
+  mode_top_bound=3
+  CALL getin('mode_top_bound',mode_top_bound)
+
+  ! top_bound sponge : inverse of charactericstic relaxation time scale for sponge
+  tau_top_bound=1.e-5
+  CALL getin('tau_top_bound',tau_top_bound)
+
+  !Config  Key  = coefdis
+  !Config  Desc = coefficient pour gamdissip
+  !Config  Def  = 0
+  !Config  Help = coefficient pour gamdissip  
+  coefdis = 0.
+  CALL getin('coefdis',coefdis)
+
+  !Config  Key  = purmats
+  !Config  Desc = Schema d'integration
+  !Config  Def  = n
+  !Config  Help = Choix du schema d'integration temporel.
+  !Config         y = pure Matsuno sinon c'est du Matsuno-leapfrog
+  purmats = .FALSE.
+  CALL getin('purmats',purmats)
+
+  !Config  Key  = ok_guide
+  !Config  Desc = Guidage
+  !Config  Def  = n
+  !Config  Help = Guidage
+  ok_guide = .FALSE.
+  CALL getin('ok_guide',ok_guide)
+
+  !Config  Key  =  read_start
+  !Config  Desc = Initialize model using a 'start.nc' file
+  !Config  Def  = y
+  !Config  Help = y: intialize dynamical fields using a 'start.nc' file
+  !               n: fields are initialized by 'iniacademic' routine
+  read_start= .true.
+  CALL getin('read_start',read_start)
+
+  !Config  Key  = iflag_phys
+  !Config  Desc = Avec ls physique 
+  !Config  Def  = 1
+  !Config  Help = Permet de faire tourner le modele sans 
+  !Config         physique.
+  iflag_phys = 1
+  CALL getin('iflag_phys',iflag_phys)
+
+  !Config  Key  =  iphysiq
+  !Config  Desc = Periode de la physique
+  !Config  Def  = 5
+  !Config  Help = Periode de la physique en pas de temps de la dynamique.
+  iphysiq = 5
+  CALL getin('iphysiq', iphysiq)
+
+  !Config  Key  = ip_ebil_dyn
+  !Config  Desc = PRINT level for energy conserv. diag.
+  !Config  Def  = 0
+  !Config  Help = PRINT level for energy conservation diag. ;
+  !               les options suivantes existent :
+  !Config         0 pas de print
+  !Config         1 pas de print
+  !Config         2 print,
+  ip_ebil_dyn = 0
+  CALL getin('ip_ebil_dyn',ip_ebil_dyn)
+
+  !cc  ....   P. Le Van , ajout  le 7/03/95 .pour le zoom ...
+  !     .........   (  modif  le 17/04/96 )   .........
+
+  test_etatinit: IF (.not. etatinit) THEN
+     !Config  Key  = clon
+     !Config  Desc = centre du zoom, longitude
+     !Config  Def  = 0
+     !Config  Help = longitude en degres du centre 
+     !Config         du zoom
+     clonn = 0.
+     CALL getin('clon',clonn)
+
+     !Config  Key  = clat
+     !Config  Desc = centre du zoom, latitude
+     !Config  Def  = 0
+     !Config  Help = latitude en degres du centre du zoom
+     !Config         
+     clatt = 0.
+     CALL getin('clat',clatt)
+
+     IF( ABS(clat - clatt).GE. 0.001 )  THEN
+        write(lunout,*)'conf_gcm: La valeur de clat passee par run.def', &
+             ' est differente de celle lue sur le fichier  start '
+        CALL abort_gcm("conf_gcm","stopped",1)
+     ENDIF
+
+     !Config  Key  = grossismx 
+     !Config  Desc = zoom en longitude
+     !Config  Def  = 1.0
+     !Config  Help = facteur de grossissement du zoom,
+     !Config         selon la longitude
+     grossismxx = 1.0
+     CALL getin('grossismx',grossismxx)
+
+     IF( ABS(grossismx - grossismxx).GE. 0.001 )  THEN
+        write(lunout,*)'conf_gcm: La valeur de grossismx passee par ', &
+             'run.def est differente de celle lue sur le fichier  start '
+        CALL abort_gcm("conf_gcm","stopped",1)
+     ENDIF
+
+     !Config  Key  = grossismy
+     !Config  Desc = zoom en latitude
+     !Config  Def  = 1.0
+     !Config  Help = facteur de grossissement du zoom,
+     !Config         selon la latitude
+     grossismyy = 1.0
+     CALL getin('grossismy',grossismyy)
+
+     IF( ABS(grossismy - grossismyy).GE. 0.001 )  THEN
+        write(lunout,*)'conf_gcm: La valeur de grossismy passee par ', &
+             'run.def est differente de celle lue sur le fichier  start '
+        CALL abort_gcm("conf_gcm","stopped",1)
+     ENDIF
+
+     IF( grossismx.LT.1. )  THEN
+        write(lunout,*) &
+             'conf_gcm: ***  ATTENTION !! grossismx < 1 .   *** '
+        CALL abort_gcm("conf_gcm","stopped",1)
+     ELSE
+        alphax = 1. - 1./ grossismx
+     ENDIF
+
+     IF( grossismy.LT.1. )  THEN
+        write(lunout,*) &
+             'conf_gcm: ***  ATTENTION !! grossismy < 1 .   *** '
+        CALL abort_gcm("conf_gcm","stopped",1)
+     ELSE
+        alphay = 1. - 1./ grossismy
+     ENDIF
+
+     write(lunout,*)'conf_gcm: alphax alphay',alphax,alphay
+
+     !    alphax et alphay sont les anciennes formulat. des grossissements
+
+     !Config  Key  = fxyhypb
+     !Config  Desc = Fonction  hyperbolique
+     !Config  Def  = y
+     !Config  Help = Fonction  f(y)  hyperbolique  si = .true.  
+     !Config         sinon  sinusoidale
+     fxyhypbb = .TRUE.
+     CALL getin('fxyhypb',fxyhypbb)
+
+     IF( .NOT.fxyhypb )  THEN
+        IF( fxyhypbb )     THEN
+           write(lunout,*)' ********  PBS DANS  CONF_GCM  ******** '
+           write(lunout,*)' *** fxyhypb lu sur le fichier start est ', &
+                'F alors  qu il est  T  sur  run.def  ***'
+           CALL abort_gcm("conf_gcm","stopped",1)
+        ENDIF
+     ELSE
+        IF( .NOT.fxyhypbb )   THEN
+           write(lunout,*)' ********  PBS DANS  CONF_GCM  ******** '
+           write(lunout,*)' ***  fxyhypb lu sur le fichier start est ', &
+                'T alors  qu il est  F  sur  run.def  ****  '
+           CALL abort_gcm("conf_gcm","stopped",1)
+        ENDIF
+     ENDIF
+
+     !Config  Key  = dzoomx
+     !Config  Desc = extension en longitude
+     !Config  Def  = 0
+     !Config  Help = extension en longitude  de la zone du zoom  
+     !Config         ( fraction de la zone totale)
+     dzoomxx = 0.0
+     CALL getin('dzoomx',dzoomxx)
+
+     IF( fxyhypb )  THEN
+        IF( ABS(dzoomx - dzoomxx).GE. 0.001 )  THEN
+           write(lunout,*)'conf_gcm: La valeur de dzoomx passee par ', &
+                'run.def est differente de celle lue sur le fichier  start '
+           CALL abort_gcm("conf_gcm","stopped",1)
+        ENDIF
+     ENDIF
+
+     !Config  Key  = dzoomy
+     !Config  Desc = extension en latitude
+     !Config  Def  = 0
+     !Config  Help = extension en latitude de la zone  du zoom  
+     !Config         ( fraction de la zone totale)
+     dzoomyy = 0.0
+     CALL getin('dzoomy',dzoomyy)
+
+     IF( fxyhypb )  THEN
+        IF( ABS(dzoomy - dzoomyy).GE. 0.001 )  THEN
+           write(lunout,*)'conf_gcm: La valeur de dzoomy passee par ', &
+                'run.def est differente de celle lue sur le fichier  start '
+           CALL abort_gcm("conf_gcm","stopped",1)
+        ENDIF
+     ENDIF
+
+     !Config  Key  = taux
+     !Config  Desc = raideur du zoom en  X
+     !Config  Def  = 3
+     !Config  Help = raideur du zoom en  X
+     tauxx = 3.0
+     CALL getin('taux',tauxx)
+
+     IF( fxyhypb )  THEN
+        IF( ABS(taux - tauxx).GE. 0.001 )  THEN
+           write(lunout,*)'conf_gcm: La valeur de taux passee par ', &
+                'run.def est differente de celle lue sur le fichier  start '
+           CALL abort_gcm("conf_gcm","stopped",1)
+        ENDIF
+     ENDIF
+
+     !Config  Key  = tauyy
+     !Config  Desc = raideur du zoom en  Y
+     !Config  Def  = 3
+     !Config  Help = raideur du zoom en  Y
+     tauyy = 3.0
+     CALL getin('tauy',tauyy)
+
+     IF( fxyhypb )  THEN
+        IF( ABS(tauy - tauyy).GE. 0.001 )  THEN
+           write(lunout,*)'conf_gcm: La valeur de tauy passee par ', &
+                'run.def est differente de celle lue sur le fichier  start '
+           CALL abort_gcm("conf_gcm","stopped",1)
+        ENDIF
+     ENDIF
+
+     !c
+     IF( .NOT.fxyhypb  )  THEN
+
+        !Config  Key  = ysinus
+        !Config  IF   = !fxyhypb
+        !Config  Desc = Fonction en Sinus
+        !Config  Def  = y
+        !Config  Help = Fonction  f(y) avec y = Sin(latit.) si = .true. 
+        !Config         sinon y = latit.
+        ysinuss = .TRUE.
+        CALL getin('ysinus',ysinuss)
+
+        IF( .NOT.ysinus )  THEN
+           IF( ysinuss )     THEN
+              write(lunout,*)' ********  PBS DANS  CONF_GCM  ******** '
+              write(lunout,*)' *** ysinus lu sur le fichier start est F', &
+                   ' alors  qu il est  T  sur  run.def  ***'
+              CALL abort_gcm("conf_gcm","stopped",1)
+           ENDIF
+        ELSE
+           IF( .NOT.ysinuss )   THEN
+              write(lunout,*)' ********  PBS DANS  CONF_GCM  ******** '
+              write(lunout,*)' *** ysinus lu sur le fichier start est T', &
+                   ' alors  qu il est  F  sur  run.def  ****  '
+              CALL abort_gcm("conf_gcm","stopped",1)
+           ENDIF
+        ENDIF
+     ENDIF ! of IF( .NOT.fxyhypb  )
+
+     !Config  Key  = offline
+     !Config  Desc = Nouvelle eau liquide
+     !Config  Def  = n
+     !Config  Help = Permet de mettre en route la
+     !Config         nouvelle parametrisation de l'eau liquide !
+     offline = .FALSE.
+     CALL getin('offline',offline)
+
+     !Config  Key  = type_trac
+     !Config  Desc = Choix de couplage avec model de chimie INCA ou REPROBUS
+     !Config  Def  = lmdz
+     !Config  Help = 
+     !Config         'lmdz' = pas de couplage, pur LMDZ
+     !Config         'inca' = model de chime INCA 
+     !Config         'repr' = model de chime REPROBUS
+     !Config         'inco' = INCA + CO2i (temporaire)
+     type_trac = 'lmdz'
+     CALL getin('type_trac',type_trac)
+
+
+     !Config  Key  = adv_qsat_liq
+     !Config  Desc = option for qsat calculation in the dynamics
+     !Config  Def  = n 
+     !Config  Help = controls which phase is considered for qsat calculation 
+     !Config          
+     adv_qsat_liq = .FALSE.
+     CALL getin('adv_qsat_liq',adv_qsat_liq)
+
+     !Config  Key  = ok_dynzon 
+     !Config  Desc = calcul et sortie des transports 
+     !Config  Def  = n 
+     !Config  Help = Permet de mettre en route le calcul des transports 
+     !Config          
+     ok_dynzon = .FALSE. 
+     CALL getin('ok_dynzon',ok_dynzon) 
+
+     !Config  Key  = ok_dyn_ins
+     !Config  Desc = sorties instantanees dans la dynamique
+     !Config  Def  = n 
+     !Config  Help = 
+     !Config          
+     ok_dyn_ins = .FALSE. 
+     CALL getin('ok_dyn_ins',ok_dyn_ins) 
+
+     !Config  Key  = ok_dyn_ave
+     !Config  Desc = sorties moyennes dans la dynamique
+     !Config  Def  = n 
+     !Config  Help = 
+     !Config          
+     ok_dyn_ave = .FALSE. 
+     CALL getin('ok_dyn_ave',ok_dyn_ave) 
+
+     write(lunout,*)' #########################################'
+     write(lunout,*)' Configuration des parametres du gcm: '
+     write(lunout,*)' planet_type = ', planet_type
+     write(lunout,*)' calend = ', calend
+     write(lunout,*)' dayref = ', dayref
+     write(lunout,*)' anneeref = ', anneeref
+     write(lunout,*)' nday = ', nday
+     write(lunout,*)' day_step = ', day_step
+     write(lunout,*)' iperiod = ', iperiod
+     write(lunout,*)' nsplit_phys = ', nsplit_phys
+     write(lunout,*)' iconser = ', iconser
+     write(lunout,*)' iecri = ', iecri
+     write(lunout,*)' periodav = ', periodav 
+     write(lunout,*)' output_grads_dyn = ', output_grads_dyn
+     write(lunout,*)' dissip_period = ', dissip_period
+     write(lunout,*)' lstardis = ', lstardis
+     write(lunout,*)' nitergdiv = ', nitergdiv
+     write(lunout,*)' nitergrot = ', nitergrot
+     write(lunout,*)' niterh = ', niterh
+     write(lunout,*)' tetagdiv = ', tetagdiv
+     write(lunout,*)' tetagrot = ', tetagrot
+     write(lunout,*)' tetatemp = ', tetatemp
+     write(lunout,*)' coefdis = ', coefdis
+     write(lunout,*)' purmats = ', purmats
+     write(lunout,*)' read_start = ', read_start
+     write(lunout,*)' iflag_phys = ', iflag_phys
+     write(lunout,*)' iphysiq = ', iphysiq
+     write(lunout,*)' clonn = ', clonn 
+     write(lunout,*)' clatt = ', clatt
+     write(lunout,*)' grossismx = ', grossismx
+     write(lunout,*)' grossismy = ', grossismy
+     write(lunout,*)' fxyhypbb = ', fxyhypbb
+     write(lunout,*)' dzoomxx = ', dzoomxx
+     write(lunout,*)' dzoomy = ', dzoomyy
+     write(lunout,*)' tauxx = ', tauxx
+     write(lunout,*)' tauyy = ', tauyy
+     write(lunout,*)' offline = ', offline
+     write(lunout,*)' type_trac = ', type_trac
+     write(lunout,*)' ok_dynzon = ', ok_dynzon 
+     write(lunout,*)' ok_dyn_ins = ', ok_dyn_ins 
+     write(lunout,*)' ok_dyn_ave = ', ok_dyn_ave 
+     write(lunout,*)' adv_qsat_liq = ', adv_qsat_liq
+  ELSE
+     !Config  Key  = clon
+     !Config  Desc = centre du zoom, longitude
+     !Config  Def  = 0
+     !Config  Help = longitude en degres du centre 
+     !Config         du zoom
+     clon = 0.
+     CALL getin('clon',clon)
+
+     !Config  Key  = clat
+     !Config  Desc = centre du zoom, latitude
+     !Config  Def  = 0
+     !Config  Help = latitude en degres du centre du zoom
+     !Config         
+     clat = 0.
+     CALL getin('clat',clat)
+
+     !Config  Key  = grossismx 
+     !Config  Desc = zoom en longitude
+     !Config  Def  = 1.0
+     !Config  Help = facteur de grossissement du zoom,
+     !Config         selon la longitude
+     grossismx = 1.0
+     CALL getin('grossismx',grossismx)
+
+     !Config  Key  = grossismy
+     !Config  Desc = zoom en latitude
+     !Config  Def  = 1.0
+     !Config  Help = facteur de grossissement du zoom,
+     !Config         selon la latitude
+     grossismy = 1.0
+     CALL getin('grossismy',grossismy)
+
+     IF( grossismx.LT.1. )  THEN
+        write(lunout,*) &
+             'conf_gcm: ***  ATTENTION !! grossismx < 1 .   *** '
+        CALL abort_gcm("conf_gcm","stopped",1)
+     ELSE
+        alphax = 1. - 1./ grossismx
+     ENDIF
+
+     IF( grossismy.LT.1. )  THEN
+        write(lunout,*) 'conf_gcm: ***ATTENTION !! grossismy < 1 . *** '
+        CALL abort_gcm("conf_gcm","stopped",1)
+     ELSE
+        alphay = 1. - 1./ grossismy
+     ENDIF
+
+     write(lunout,*)'conf_gcm: alphax alphay ',alphax,alphay
+
+     !    alphax et alphay sont les anciennes formulat. des grossissements
+
+     !Config  Key  = fxyhypb
+     !Config  Desc = Fonction  hyperbolique
+     !Config  Def  = y
+     !Config  Help = Fonction  f(y)  hyperbolique  si = .true.  
+     !Config         sinon  sinusoidale
+     fxyhypb = .TRUE.
+     CALL getin('fxyhypb',fxyhypb)
+
+     !Config  Key  = dzoomx
+     !Config  Desc = extension en longitude
+     !Config  Def  = 0
+     !Config  Help = extension en longitude  de la zone du zoom  
+     !Config         ( fraction de la zone totale)
+     dzoomx = 0.2
+     CALL getin('dzoomx',dzoomx)
+     call assert(dzoomx < 1, "conf_gcm: dzoomx must be < 1")
+
+     !Config  Key  = dzoomy
+     !Config  Desc = extension en latitude
+     !Config  Def  = 0
+     !Config  Help = extension en latitude de la zone  du zoom  
+     !Config         ( fraction de la zone totale)
+     dzoomy = 0.2
+     CALL getin('dzoomy',dzoomy)
+     call assert(dzoomy < 1, "conf_gcm: dzoomy must be < 1")
+
+     !Config  Key  = taux
+     !Config  Desc = raideur du zoom en  X
+     !Config  Def  = 3
+     !Config  Help = raideur du zoom en  X
+     taux = 3.0
+     CALL getin('taux',taux)
+
+     !Config  Key  = tauy
+     !Config  Desc = raideur du zoom en  Y
+     !Config  Def  = 3
+     !Config  Help = raideur du zoom en  Y
+     tauy = 3.0
+     CALL getin('tauy',tauy)
+
+     !Config  Key  = ysinus
+     !Config  IF   = !fxyhypb
+     !Config  Desc = Fonction en Sinus
+     !Config  Def  = y
+     !Config  Help = Fonction  f(y) avec y = Sin(latit.) si = .true. 
+     !Config         sinon y = latit.
+     ysinus = .TRUE.
+     CALL getin('ysinus',ysinus)
+
+     !Config  Key  = offline
+     !Config  Desc = Nouvelle eau liquide
+     !Config  Def  = n
+     !Config  Help = Permet de mettre en route la
+     !Config         nouvelle parametrisation de l'eau liquide !
+     offline = .FALSE.
+     CALL getin('offline',offline)
+
+     !Config  Key  = type_trac
+     !Config  Desc = Choix de couplage avec model de chimie INCA ou REPROBUS
+     !Config  Def  = lmdz
+     !Config  Help = 
+     !Config         'lmdz' = pas de couplage, pur LMDZ
+     !Config         'inca' = model de chime INCA 
+     !Config         'repr' = model de chime REPROBUS
+     !Config         'inco' = INCA + CO2i (temporaire)
+     type_trac = 'lmdz'
+     CALL getin('type_trac',type_trac)
+
+     !Config  Key  = ok_dynzon 
+     !Config  Desc = sortie des transports zonaux dans la dynamique
+     !Config  Def  = n 
+     !Config  Help = Permet de mettre en route le calcul des transports 
+     !Config          
+     ok_dynzon = .FALSE. 
+     CALL getin('ok_dynzon',ok_dynzon) 
+
+     !Config  Key  = ok_dyn_ins
+     !Config  Desc = sorties instantanees dans la dynamique
+     !Config  Def  = n 
+     !Config  Help = 
+     !Config          
+     ok_dyn_ins = .FALSE. 
+     CALL getin('ok_dyn_ins',ok_dyn_ins) 
+
+     !Config  Key  = ok_dyn_ave
+     !Config  Desc = sorties moyennes dans la dynamique
+     !Config  Def  = n 
+     !Config  Help = 
+     !Config          
+     ok_dyn_ave = .FALSE. 
+     CALL getin('ok_dyn_ave',ok_dyn_ave) 
+
+     !Config key = ok_strato
+     !Config  Desc = activation de la version strato
+     !Config  Def  = .FALSE.
+     !Config  Help = active la version stratosph\'erique de LMDZ de F. Lott
+
+     ok_strato=.FALSE.
+     CALL getin('ok_strato',ok_strato)
+
+     vert_prof_dissip = merge(1, 0, ok_strato .and. llm==39)
+     CALL getin('vert_prof_dissip', vert_prof_dissip)
+     call assert(vert_prof_dissip == 0 .or. vert_prof_dissip ==  1, &
+          "bad value for vert_prof_dissip")
+
+     !Config  Key  = ok_gradsfile
+     !Config  Desc = activation des sorties grads du guidage
+     !Config  Def  = n
+     !Config  Help = active les sorties grads du guidage
+
+     ok_gradsfile = .FALSE.
+     CALL getin('ok_gradsfile',ok_gradsfile)
+
+     !Config  Key  = ok_limit
+     !Config  Desc = creation des fichiers limit dans create_etat0_limit
+     !Config  Def  = y
+     !Config  Help = production du fichier limit.nc requise
+
+     ok_limit = .TRUE.
+     CALL getin('ok_limit',ok_limit)
+
+     !Config  Key  = ok_etat0
+     !Config  Desc = creation des fichiers etat0 dans create_etat0_limit
+     !Config  Def  = y
+     !Config  Help = production des fichiers start.nc, startphy.nc requise
+
+     ok_etat0 = .TRUE.
+     CALL getin('ok_etat0',ok_etat0)
+
+     !Config  Key  = read_orop
+     !Config  Desc = lecture du fichier de params orographiques sous maille
+     !Config  Def  = f
+     !Config  Help = lecture fichier plutot que grid_noro
+
+     read_orop = .FALSE.
+     CALL getin('read_orop',read_orop)
+
+     write(lunout,*)' #########################################'
+     write(lunout,*)' Configuration des parametres de cel0_limit: '
+     write(lunout,*)' planet_type = ', planet_type
+     write(lunout,*)' calend = ', calend
+     write(lunout,*)' dayref = ', dayref
+     write(lunout,*)' anneeref = ', anneeref
+     write(lunout,*)' nday = ', nday
+     write(lunout,*)' day_step = ', day_step
+     write(lunout,*)' iperiod = ', iperiod
+     write(lunout,*)' iconser = ', iconser
+     write(lunout,*)' iecri = ', iecri
+     write(lunout,*)' periodav = ', periodav 
+     write(lunout,*)' output_grads_dyn = ', output_grads_dyn
+     write(lunout,*)' dissip_period = ', dissip_period
+     write(lunout,*)' lstardis = ', lstardis
+     write(lunout,*)' nitergdiv = ', nitergdiv
+     write(lunout,*)' nitergrot = ', nitergrot
+     write(lunout,*)' niterh = ', niterh
+     write(lunout,*)' tetagdiv = ', tetagdiv
+     write(lunout,*)' tetagrot = ', tetagrot
+     write(lunout,*)' tetatemp = ', tetatemp
+     write(lunout,*)' coefdis = ', coefdis
+     write(lunout,*)' purmats = ', purmats
+     write(lunout,*)' read_start = ', read_start
+     write(lunout,*)' iflag_phys = ', iflag_phys
+     write(lunout,*)' iphysiq = ', iphysiq
+     write(lunout,*)' clon = ', clon
+     write(lunout,*)' clat = ', clat
+     write(lunout,*)' grossismx = ', grossismx
+     write(lunout,*)' grossismy = ', grossismy
+     write(lunout,*)' fxyhypb = ', fxyhypb
+     write(lunout,*)' dzoomx = ', dzoomx
+     write(lunout,*)' dzoomy = ', dzoomy
+     write(lunout,*)' taux = ', taux
+     write(lunout,*)' tauy = ', tauy
+     write(lunout,*)' offline = ', offline
+     write(lunout,*)' type_trac = ', type_trac
+     write(lunout,*)' ok_dynzon = ', ok_dynzon
+     write(lunout,*)' ok_dyn_ins = ', ok_dyn_ins 
+     write(lunout,*)' ok_dyn_ave = ', ok_dyn_ave 
+     write(lunout,*)' ok_strato = ', ok_strato
+     write(lunout,*)' ok_gradsfile = ', ok_gradsfile
+     write(lunout,*)' ok_limit = ', ok_limit
+     write(lunout,*)' ok_etat0 = ', ok_etat0
+     write(lunout,*)' ok_guide = ', ok_guide
+     write(lunout,*)' read_orop = ', read_orop
+  ENDIF test_etatinit
+
+END SUBROUTINE conf_gcm
Index: DZ6/trunk/libf/dyn3d/dynetat0.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d/dynetat0.F90	(revision 5267)
+++ 	(revision )
@@ -1,254 +1,0 @@
-SUBROUTINE dynetat0(fichnom,vcov,ucov,teta,q,masse,ps,phis,time)
-!
-!-------------------------------------------------------------------------------
-! Authors: P. Le Van , L.Fairhead
-!-------------------------------------------------------------------------------
-! Purpose: Initial state reading.
-!-------------------------------------------------------------------------------
-  USE infotrac,    ONLY: nqtot, tracers, niso, iqIsoPha, iH2O, isoName, &
-                         new2oldH2O, newHNO3, oldHNO3
-  USE strings_mod, ONLY: maxlen, msg, strStack, real2str, int2str
-  USE netcdf,      ONLY: NF90_OPEN,  NF90_NOWRITE, NF90_INQ_VARID, &
-                         NF90_CLOSE, NF90_GET_VAR, NF90_NoErr
-  USE control_mod, ONLY: planet_type
-  USE assert_eq_m, ONLY: assert_eq
-  USE comvert_mod, ONLY: pa,preff
-  USE comconst_mod, ONLY: cpp, daysec, dtvr, g, im, jm, kappa, lllm, omeg, rad
-  USE logic_mod, ONLY: fxyhypb, ysinus
-  USE serre_mod, ONLY: clon, clat, grossismx, grossismy
-  USE temps_mod, ONLY: annee_ref, day_ini, day_ref, itau_dyn, start_time
-  USE ener_mod, ONLY: etot0,ptot0,ztot0,stot0,ang0
-  USE IOIPSL,   ONLY: getin
-  USE iso_params_mod   ! tnat_* and alpha_ideal_*
-  USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_INCA, CPPKEY_REPROBUS
-  USE strings_mod, ONLY: strIdx
-
-  IMPLICIT NONE
-  include "dimensions.h"
-  include "paramet.h"
-  include "comgeom2.h"
-  include "description.h"
-  include "iniprint.h"
-!===============================================================================
-! Arguments:
-  CHARACTER(LEN=*), INTENT(IN) :: fichnom          !--- FILE NAME
-  REAL, INTENT(OUT) ::  vcov(iip1,jjm, llm)        !--- V COVARIANT WIND
-  REAL, INTENT(OUT) ::  ucov(iip1,jjp1,llm)        !--- U COVARIANT WIND
-  REAL, INTENT(OUT) ::  teta(iip1,jjp1,llm)        !--- POTENTIAL TEMP.
-  REAL, INTENT(OUT) ::     q(iip1,jjp1,llm,nqtot)  !--- TRACERS
-  REAL, INTENT(OUT) :: masse(iip1,jjp1,llm)        !--- MASS PER CELL
-  REAL, INTENT(OUT) ::    ps(iip1,jjp1)            !--- GROUND PRESSURE
-  REAL, INTENT(OUT) ::  phis(iip1,jjp1)            !--- GEOPOTENTIAL
-!===============================================================================
-! Local variables:
-  CHARACTER(LEN=maxlen) :: mesg, var, modname, oldVar
-  INTEGER, PARAMETER :: length=100
-  INTEGER :: iq, fID, vID, idecal, iqParent, iName, iZone, iPhase, ix
-  REAL    :: time, tnat, alpha_ideal, tab_cntrl(length)    !--- RUN PARAMS TABLE
-  LOGICAL :: lSkip, ll, ltnat1
-!-------------------------------------------------------------------------------
-  modname="dynetat0"
-
-!--- Initial state file opening
-  var=fichnom
-  CALL err(NF90_OPEN(var,NF90_NOWRITE,fID),"open",var)
-  CALL get_var1("controle",tab_cntrl)
-
-!!! AS: idecal is a hack to be able to read planeto starts...
-!!!     .... while keeping everything OK for LMDZ EARTH
-  IF(planet_type=="generic") THEN
-    CALL msg('NOTE NOTE NOTE : Planeto-like start files', modname)
-    idecal = 4
-    annee_ref  = 2000
-  ELSE
-    CALL msg('NOTE NOTE NOTE : Earth-like start files', modname)
-    idecal = 5
-    annee_ref  = tab_cntrl(5)
-  END IF
-  im         = tab_cntrl(1)
-  jm         = tab_cntrl(2)
-  lllm       = tab_cntrl(3)
-  day_ref    = tab_cntrl(4)
-  rad        = tab_cntrl(idecal+1)
-  omeg       = tab_cntrl(idecal+2)
-  g          = tab_cntrl(idecal+3)
-  cpp        = tab_cntrl(idecal+4)
-  kappa      = tab_cntrl(idecal+5)
-  daysec     = tab_cntrl(idecal+6)
-  dtvr       = tab_cntrl(idecal+7)
-  etot0      = tab_cntrl(idecal+8)
-  ptot0      = tab_cntrl(idecal+9)
-  ztot0      = tab_cntrl(idecal+10)
-  stot0      = tab_cntrl(idecal+11)
-  ang0       = tab_cntrl(idecal+12)
-  pa         = tab_cntrl(idecal+13)
-  preff      = tab_cntrl(idecal+14)
-!
-  clon       = tab_cntrl(idecal+15)
-  clat       = tab_cntrl(idecal+16)
-  grossismx  = tab_cntrl(idecal+17)
-  grossismy  = tab_cntrl(idecal+18)
-!
-  IF ( tab_cntrl(idecal+19)==1. )  THEN
-    fxyhypb  = .TRUE.
-!   dzoomx   = tab_cntrl(25)
-!   dzoomy   = tab_cntrl(26)
-!   taux     = tab_cntrl(28)
-!   tauy     = tab_cntrl(29)
-  ELSE
-    fxyhypb = .FALSE.
-    ysinus  = tab_cntrl(idecal+22)==1.
-  END IF
-
-  day_ini    = tab_cntrl(30)
-  itau_dyn   = tab_cntrl(31)
-  start_time = tab_cntrl(32)
-
-!-------------------------------------------------------------------------------
-  CALL msg('rad, omeg, g, cpp, kappa = '//TRIM(strStack(real2str([rad,omeg,g,cpp,kappa]))), modname)
-  CALL check_dim(im,iim,'im','im')
-  CALL check_dim(jm,jjm,'jm','jm')
-  CALL check_dim(lllm,llm,'lm','lllm')
-  CALL get_var1("rlonu",rlonu)
-  CALL get_var1("rlatu",rlatu)
-  CALL get_var1("rlonv",rlonv)
-  CALL get_var1("rlatv",rlatv)
-  CALL get_var2("cu"   ,cu)
-  CALL get_var2("cv"   ,cv)
-  CALL get_var2("aire" ,aire)
-  var="temps"
-  IF(NF90_INQ_VARID(fID,var,vID)/=NF90_NoErr) THEN
-    CALL msg('Missing field <temps> ; trying with <Time>', modname)
-    var="Time"
-    CALL err(NF90_INQ_VARID(fID,var,vID),"inq",var)
-  END IF
-  CALL err(NF90_GET_VAR(fID,vID,time),"get",var)
-  CALL get_var2("phisinit",phis)
-  CALL get_var3("ucov",ucov)
-  CALL get_var3("vcov",vcov)
-  CALL get_var3("teta",teta)
-  CALL get_var3("masse",masse)
-  CALL get_var2("ps",ps)
-
-!--- Tracers
-  ll=.FALSE.
-IF (CPPKEY_REPROBUS) THEN
-  ll = NF90_INQ_VARID(fID, 'HNO3tot', vID) /= NF90_NoErr                                 !--- DETECT OLD REPRO start.nc FILE
-END IF
-  ltnat1 = .TRUE.; CALL getin('tnateq1', ltnat1)
-  DO iq=1,nqtot
-    var = tracers(iq)%name
-    oldVar = new2oldH2O(var)
-    lSkip = ll .AND. var == 'HNO3'                                                       !--- FORCE "HNO3_g" READING FOR "HNO3"
-IF (CPPKEY_REPROBUS) THEN
-    ix = strIdx(newHNO3, var); IF(ix /= 0) oldVar = oldHNO3(ix)                          !--- REPROBUS HNO3 exceptions
-END IF
-IF (CPPKEY_INCA) THEN
-    IF(var == 'O3') oldVar = 'OX'                                                        !--- DEAL WITH INCA OZONE EXCEPTION
-END IF
-    !--------------------------------------------------------------------------------------------------------------------------
-    IF(NF90_INQ_VARID(fID, var, vID) == NF90_NoErr .AND. .NOT.lSkip) THEN                !=== REGULAR CASE: AVAILABLE VARIABLE
-      CALL err(NF90_GET_VAR(fID,vID,q(:,:,:,iq)),"get",var)
-    !--------------------------------------------------------------------------------------------------------------------------
-    ELSE IF(NF90_INQ_VARID(fID, oldVar, vID) == NF90_NoErr) THEN                         !=== TRY WITH ALTERNATE NAME
-      CALL msg('Missing tracer <'//TRIM(var)//'> => initialized to <'//TRIM(oldVar)//'>', modname)
-      CALL err(NF90_GET_VAR(fID,vID,q(:,:,:,iq)),"get",oldVar)
-    !--------------------------------------------------------------------------------------------------------------------------
-    ELSE IF(tracers(iq)%iso_iGroup == iH2O .AND. niso > 0) THEN                          !=== WATER ISOTOPES
-      iName    = tracers(iq)%iso_iName
-      iPhase   = tracers(iq)%iso_iPhase
-      iqParent = tracers(iq)%iqParent
-      IF(tracers(iq)%iso_iZone == 0) THEN
-         IF(ltnat1) THEN
-            tnat = 1.0
-            alpha_ideal = 1.0
-            CALL msg(' !!!  Beware: alpha_ideal put to 1  !!!', modname)
-         ELSE
-            SELECT CASE(isoName(iName))
-              CASE('H216O'); tnat = tnat_H216O; alpha_ideal = alpha_ideal_H216O
-              CASE('H217O'); tnat = tnat_H217O; alpha_ideal = alpha_ideal_H217O
-              CASE('H218O'); tnat = tnat_H218O; alpha_ideal = alpha_ideal_H218O
-              CASE('HDO');   tnat = tnat_HDO;   alpha_ideal = alpha_ideal_HDO
-              CASE('HTO');   tnat = tnat_HTO;   alpha_ideal = alpha_ideal_HTO
-              CASE DEFAULT; CALL abort_gcm(TRIM(modname),'unknown isotope "'//TRIM(isoName(iName))//'" ; check tracer.def file',1)
-            END SELECT
-         END IF
-         CALL msg('Missing tracer <'//TRIM(var)//'> => initialized with a simplified Rayleigh distillation law.', modname)
-         q(:,:,:,iq) = q(:,:,:,iqParent)*tnat*(q(:,:,:,iqParent)/30.e-3)**(alpha_ideal-1.)
-      ELSE
-         CALL msg('Missing tracer <'//TRIM(var)//'> => initialized to its parent isotope concentration.', modname)
-         ! Camille 9 mars 2023: attention!! seuls les tags qui correspondent à
-         ! izone=izone_init (définie dans isotrac_mod) sont initialisés comme
-         ! les parents. Sinon, c'est nul.
-         ! j'ai fait ça en attendant, mais il faudrait initialiser proprement en
-         ! remplacant 1 par izone_init dans la ligne qui suit.
-         IF(tracers(iq)%iso_iZone == 1) THEN
-           q(:,:,:,iq) = q(:,:,:,iqIsoPha(iName,iPhase))
-         ELSE
-           q(:,:,:,iq) = 0.
-         END IF
-      END IF
-    !--------------------------------------------------------------------------------------------------------------------------
-    ELSE                                                                                 !=== MISSING: SET TO 0
-      CALL msg('Missing tracer <'//TRIM(var)//'> => initialized to zero', modname)
-      q(:,:,:,iq)=0.
-    !--------------------------------------------------------------------------------------------------------------------------
-    END IF
-  END DO
-
-  CALL err(NF90_CLOSE(fID),"close",fichnom)
-  day_ini=day_ini+INT(time)
-  time=time-INT(time)
-
-
-  CONTAINS
-
-
-SUBROUTINE check_dim(n1,n2,str1,str2)
-  INTEGER,          INTENT(IN) :: n1, n2
-  CHARACTER(LEN=*), INTENT(IN) :: str1, str2
-  CHARACTER(LEN=maxlen) :: s1, s2
-  IF(n1/=n2) CALL abort_gcm(TRIM(modname), 'value of "'//TRIM(str1)//'" = '//TRIM(int2str(n1))// &
-   ' read in starting file differs from gcm value of "'//TRIM(str2)//'" = '//TRIM(int2str(n2)), 1)
-END SUBROUTINE check_dim
-
-
-SUBROUTINE get_var1(var,v)
-  CHARACTER(LEN=*), INTENT(IN)  :: var
-  REAL,             INTENT(OUT) :: v(:)
-  CALL err(NF90_INQ_VARID(fID,var,vID),"inq",var)
-  CALL err(NF90_GET_VAR(fID,vID,v),"get",var)
-END SUBROUTINE get_var1
-
-
-SUBROUTINE get_var2(var,v)
-  CHARACTER(LEN=*), INTENT(IN)  :: var
-  REAL,             INTENT(OUT) :: v(:,:)
-  CALL err(NF90_INQ_VARID(fID,var,vID),"inq",var)
-  CALL err(NF90_GET_VAR(fID,vID,v),"get",var)
-END SUBROUTINE get_var2
-
-
-SUBROUTINE get_var3(var,v)
-  CHARACTER(LEN=*), INTENT(IN)  :: var
-  REAL,             INTENT(OUT) :: v(:,:,:)
-  CALL err(NF90_INQ_VARID(fID,var,vID),"inq",var)
-  CALL err(NF90_GET_VAR(fID,vID,v),"get",var)
-END SUBROUTINE get_var3
-
-
-SUBROUTINE err(ierr,typ,nam)
-  INTEGER,          INTENT(IN) :: ierr   !--- NetCDF ERROR CODE
-  CHARACTER(LEN=*), INTENT(IN) :: typ    !--- TYPE OF OPERATION
-  CHARACTER(LEN=*), INTENT(IN) :: nam    !--- FIELD/FILE NAME
-  IF(ierr==NF90_NoERR) RETURN
-  SELECT CASE(typ)
-    CASE('inq');   mesg="Field <"//TRIM(nam)//"> is missing"
-    CASE('get');   mesg="Reading failed for <"//TRIM(nam)//">"
-    CASE('open');  mesg="File opening failed for <"//TRIM(nam)//">"
-    CASE('close'); mesg="File closing failed for <"//TRIM(nam)//">"
-  END SELECT
-  CALL ABORT_gcm(TRIM(modname),TRIM(mesg),ierr)
-END SUBROUTINE err
-
-END SUBROUTINE dynetat0
Index: /LMDZ6/trunk/libf/dyn3d/dynetat0.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d/dynetat0.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3d/dynetat0.f90	(revision 5268)
@@ -0,0 +1,254 @@
+SUBROUTINE dynetat0(fichnom,vcov,ucov,teta,q,masse,ps,phis,time)
+!
+!-------------------------------------------------------------------------------
+! Authors: P. Le Van , L.Fairhead
+!-------------------------------------------------------------------------------
+! Purpose: Initial state reading.
+!-------------------------------------------------------------------------------
+  USE infotrac,    ONLY: nqtot, tracers, niso, iqIsoPha, iH2O, isoName, &
+                         new2oldH2O, newHNO3, oldHNO3
+  USE strings_mod, ONLY: maxlen, msg, strStack, real2str, int2str
+  USE netcdf,      ONLY: NF90_OPEN,  NF90_NOWRITE, NF90_INQ_VARID, &
+                         NF90_CLOSE, NF90_GET_VAR, NF90_NoErr
+  USE control_mod, ONLY: planet_type
+  USE assert_eq_m, ONLY: assert_eq
+  USE comvert_mod, ONLY: pa,preff
+  USE comconst_mod, ONLY: cpp, daysec, dtvr, g, im, jm, kappa, lllm, omeg, rad
+  USE logic_mod, ONLY: fxyhypb, ysinus
+  USE serre_mod, ONLY: clon, clat, grossismx, grossismy
+  USE temps_mod, ONLY: annee_ref, day_ini, day_ref, itau_dyn, start_time
+  USE ener_mod, ONLY: etot0,ptot0,ztot0,stot0,ang0
+  USE IOIPSL,   ONLY: getin
+  USE iso_params_mod   ! tnat_* and alpha_ideal_*
+  USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_INCA, CPPKEY_REPROBUS
+  USE strings_mod, ONLY: strIdx
+
+  IMPLICIT NONE
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom2.h"
+  include "description.h"
+  include "iniprint.h"
+!===============================================================================
+! Arguments:
+  CHARACTER(LEN=*), INTENT(IN) :: fichnom          !--- FILE NAME
+  REAL, INTENT(OUT) ::  vcov(iip1,jjm, llm)        !--- V COVARIANT WIND
+  REAL, INTENT(OUT) ::  ucov(iip1,jjp1,llm)        !--- U COVARIANT WIND
+  REAL, INTENT(OUT) ::  teta(iip1,jjp1,llm)        !--- POTENTIAL TEMP.
+  REAL, INTENT(OUT) ::     q(iip1,jjp1,llm,nqtot)  !--- TRACERS
+  REAL, INTENT(OUT) :: masse(iip1,jjp1,llm)        !--- MASS PER CELL
+  REAL, INTENT(OUT) ::    ps(iip1,jjp1)            !--- GROUND PRESSURE
+  REAL, INTENT(OUT) ::  phis(iip1,jjp1)            !--- GEOPOTENTIAL
+!===============================================================================
+! Local variables:
+  CHARACTER(LEN=maxlen) :: mesg, var, modname, oldVar
+  INTEGER, PARAMETER :: length=100
+  INTEGER :: iq, fID, vID, idecal, iqParent, iName, iZone, iPhase, ix
+  REAL    :: time, tnat, alpha_ideal, tab_cntrl(length)    !--- RUN PARAMS TABLE
+  LOGICAL :: lSkip, ll, ltnat1
+!-------------------------------------------------------------------------------
+  modname="dynetat0"
+
+!--- Initial state file opening
+  var=fichnom
+  CALL err(NF90_OPEN(var,NF90_NOWRITE,fID),"open",var)
+  CALL get_var1("controle",tab_cntrl)
+
+!!! AS: idecal is a hack to be able to read planeto starts...
+!!!     .... while keeping everything OK for LMDZ EARTH
+  IF(planet_type=="generic") THEN
+    CALL msg('NOTE NOTE NOTE : Planeto-like start files', modname)
+    idecal = 4
+    annee_ref  = 2000
+  ELSE
+    CALL msg('NOTE NOTE NOTE : Earth-like start files', modname)
+    idecal = 5
+    annee_ref  = tab_cntrl(5)
+  END IF
+  im         = tab_cntrl(1)
+  jm         = tab_cntrl(2)
+  lllm       = tab_cntrl(3)
+  day_ref    = tab_cntrl(4)
+  rad        = tab_cntrl(idecal+1)
+  omeg       = tab_cntrl(idecal+2)
+  g          = tab_cntrl(idecal+3)
+  cpp        = tab_cntrl(idecal+4)
+  kappa      = tab_cntrl(idecal+5)
+  daysec     = tab_cntrl(idecal+6)
+  dtvr       = tab_cntrl(idecal+7)
+  etot0      = tab_cntrl(idecal+8)
+  ptot0      = tab_cntrl(idecal+9)
+  ztot0      = tab_cntrl(idecal+10)
+  stot0      = tab_cntrl(idecal+11)
+  ang0       = tab_cntrl(idecal+12)
+  pa         = tab_cntrl(idecal+13)
+  preff      = tab_cntrl(idecal+14)
+!
+  clon       = tab_cntrl(idecal+15)
+  clat       = tab_cntrl(idecal+16)
+  grossismx  = tab_cntrl(idecal+17)
+  grossismy  = tab_cntrl(idecal+18)
+!
+  IF ( tab_cntrl(idecal+19)==1. )  THEN
+    fxyhypb  = .TRUE.
+!   dzoomx   = tab_cntrl(25)
+!   dzoomy   = tab_cntrl(26)
+!   taux     = tab_cntrl(28)
+!   tauy     = tab_cntrl(29)
+  ELSE
+    fxyhypb = .FALSE.
+    ysinus  = tab_cntrl(idecal+22)==1.
+  END IF
+
+  day_ini    = tab_cntrl(30)
+  itau_dyn   = tab_cntrl(31)
+  start_time = tab_cntrl(32)
+
+!-------------------------------------------------------------------------------
+  CALL msg('rad, omeg, g, cpp, kappa = '//TRIM(strStack(real2str([rad,omeg,g,cpp,kappa]))), modname)
+  CALL check_dim(im,iim,'im','im')
+  CALL check_dim(jm,jjm,'jm','jm')
+  CALL check_dim(lllm,llm,'lm','lllm')
+  CALL get_var1("rlonu",rlonu)
+  CALL get_var1("rlatu",rlatu)
+  CALL get_var1("rlonv",rlonv)
+  CALL get_var1("rlatv",rlatv)
+  CALL get_var2("cu"   ,cu)
+  CALL get_var2("cv"   ,cv)
+  CALL get_var2("aire" ,aire)
+  var="temps"
+  IF(NF90_INQ_VARID(fID,var,vID)/=NF90_NoErr) THEN
+    CALL msg('Missing field <temps> ; trying with <Time>', modname)
+    var="Time"
+    CALL err(NF90_INQ_VARID(fID,var,vID),"inq",var)
+  END IF
+  CALL err(NF90_GET_VAR(fID,vID,time),"get",var)
+  CALL get_var2("phisinit",phis)
+  CALL get_var3("ucov",ucov)
+  CALL get_var3("vcov",vcov)
+  CALL get_var3("teta",teta)
+  CALL get_var3("masse",masse)
+  CALL get_var2("ps",ps)
+
+!--- Tracers
+  ll=.FALSE.
+IF (CPPKEY_REPROBUS) THEN
+  ll = NF90_INQ_VARID(fID, 'HNO3tot', vID) /= NF90_NoErr                                 !--- DETECT OLD REPRO start.nc FILE
+END IF
+  ltnat1 = .TRUE.; CALL getin('tnateq1', ltnat1)
+  DO iq=1,nqtot
+    var = tracers(iq)%name
+    oldVar = new2oldH2O(var)
+    lSkip = ll .AND. var == 'HNO3'                                                       !--- FORCE "HNO3_g" READING FOR "HNO3"
+IF (CPPKEY_REPROBUS) THEN
+    ix = strIdx(newHNO3, var); IF(ix /= 0) oldVar = oldHNO3(ix)                          !--- REPROBUS HNO3 exceptions
+END IF
+IF (CPPKEY_INCA) THEN
+    IF(var == 'O3') oldVar = 'OX'                                                        !--- DEAL WITH INCA OZONE EXCEPTION
+END IF
+    !--------------------------------------------------------------------------------------------------------------------------
+    IF(NF90_INQ_VARID(fID, var, vID) == NF90_NoErr .AND. .NOT.lSkip) THEN                !=== REGULAR CASE: AVAILABLE VARIABLE
+      CALL err(NF90_GET_VAR(fID,vID,q(:,:,:,iq)),"get",var)
+    !--------------------------------------------------------------------------------------------------------------------------
+    ELSE IF(NF90_INQ_VARID(fID, oldVar, vID) == NF90_NoErr) THEN                         !=== TRY WITH ALTERNATE NAME
+      CALL msg('Missing tracer <'//TRIM(var)//'> => initialized to <'//TRIM(oldVar)//'>', modname)
+      CALL err(NF90_GET_VAR(fID,vID,q(:,:,:,iq)),"get",oldVar)
+    !--------------------------------------------------------------------------------------------------------------------------
+    ELSE IF(tracers(iq)%iso_iGroup == iH2O .AND. niso > 0) THEN                          !=== WATER ISOTOPES
+      iName    = tracers(iq)%iso_iName
+      iPhase   = tracers(iq)%iso_iPhase
+      iqParent = tracers(iq)%iqParent
+      IF(tracers(iq)%iso_iZone == 0) THEN
+         IF(ltnat1) THEN
+            tnat = 1.0
+            alpha_ideal = 1.0
+            CALL msg(' !!!  Beware: alpha_ideal put to 1  !!!', modname)
+         ELSE
+            SELECT CASE(isoName(iName))
+              CASE('H216O'); tnat = tnat_H216O; alpha_ideal = alpha_ideal_H216O
+              CASE('H217O'); tnat = tnat_H217O; alpha_ideal = alpha_ideal_H217O
+              CASE('H218O'); tnat = tnat_H218O; alpha_ideal = alpha_ideal_H218O
+              CASE('HDO');   tnat = tnat_HDO;   alpha_ideal = alpha_ideal_HDO
+              CASE('HTO');   tnat = tnat_HTO;   alpha_ideal = alpha_ideal_HTO
+              CASE DEFAULT; CALL abort_gcm(TRIM(modname),'unknown isotope "'//TRIM(isoName(iName))//'" ; check tracer.def file',1)
+            END SELECT
+         END IF
+         CALL msg('Missing tracer <'//TRIM(var)//'> => initialized with a simplified Rayleigh distillation law.', modname)
+         q(:,:,:,iq) = q(:,:,:,iqParent)*tnat*(q(:,:,:,iqParent)/30.e-3)**(alpha_ideal-1.)
+      ELSE
+         CALL msg('Missing tracer <'//TRIM(var)//'> => initialized to its parent isotope concentration.', modname)
+         ! Camille 9 mars 2023: attention!! seuls les tags qui correspondent à
+         ! izone=izone_init (définie dans isotrac_mod) sont initialisés comme
+         ! les parents. Sinon, c'est nul.
+         ! j'ai fait ça en attendant, mais il faudrait initialiser proprement en
+         ! remplacant 1 par izone_init dans la ligne qui suit.
+         IF(tracers(iq)%iso_iZone == 1) THEN
+           q(:,:,:,iq) = q(:,:,:,iqIsoPha(iName,iPhase))
+         ELSE
+           q(:,:,:,iq) = 0.
+         END IF
+      END IF
+    !--------------------------------------------------------------------------------------------------------------------------
+    ELSE                                                                                 !=== MISSING: SET TO 0
+      CALL msg('Missing tracer <'//TRIM(var)//'> => initialized to zero', modname)
+      q(:,:,:,iq)=0.
+    !--------------------------------------------------------------------------------------------------------------------------
+    END IF
+  END DO
+
+  CALL err(NF90_CLOSE(fID),"close",fichnom)
+  day_ini=day_ini+INT(time)
+  time=time-INT(time)
+
+
+  CONTAINS
+
+
+SUBROUTINE check_dim(n1,n2,str1,str2)
+  INTEGER,          INTENT(IN) :: n1, n2
+  CHARACTER(LEN=*), INTENT(IN) :: str1, str2
+  CHARACTER(LEN=maxlen) :: s1, s2
+  IF(n1/=n2) CALL abort_gcm(TRIM(modname), 'value of "'//TRIM(str1)//'" = '//TRIM(int2str(n1))// &
+   ' read in starting file differs from gcm value of "'//TRIM(str2)//'" = '//TRIM(int2str(n2)), 1)
+END SUBROUTINE check_dim
+
+
+SUBROUTINE get_var1(var,v)
+  CHARACTER(LEN=*), INTENT(IN)  :: var
+  REAL,             INTENT(OUT) :: v(:)
+  CALL err(NF90_INQ_VARID(fID,var,vID),"inq",var)
+  CALL err(NF90_GET_VAR(fID,vID,v),"get",var)
+END SUBROUTINE get_var1
+
+
+SUBROUTINE get_var2(var,v)
+  CHARACTER(LEN=*), INTENT(IN)  :: var
+  REAL,             INTENT(OUT) :: v(:,:)
+  CALL err(NF90_INQ_VARID(fID,var,vID),"inq",var)
+  CALL err(NF90_GET_VAR(fID,vID,v),"get",var)
+END SUBROUTINE get_var2
+
+
+SUBROUTINE get_var3(var,v)
+  CHARACTER(LEN=*), INTENT(IN)  :: var
+  REAL,             INTENT(OUT) :: v(:,:,:)
+  CALL err(NF90_INQ_VARID(fID,var,vID),"inq",var)
+  CALL err(NF90_GET_VAR(fID,vID,v),"get",var)
+END SUBROUTINE get_var3
+
+
+SUBROUTINE err(ierr,typ,nam)
+  INTEGER,          INTENT(IN) :: ierr   !--- NetCDF ERROR CODE
+  CHARACTER(LEN=*), INTENT(IN) :: typ    !--- TYPE OF OPERATION
+  CHARACTER(LEN=*), INTENT(IN) :: nam    !--- FIELD/FILE NAME
+  IF(ierr==NF90_NoERR) RETURN
+  SELECT CASE(typ)
+    CASE('inq');   mesg="Field <"//TRIM(nam)//"> is missing"
+    CASE('get');   mesg="Reading failed for <"//TRIM(nam)//">"
+    CASE('open');  mesg="File opening failed for <"//TRIM(nam)//">"
+    CASE('close'); mesg="File closing failed for <"//TRIM(nam)//">"
+  END SELECT
+  CALL ABORT_gcm(TRIM(modname),TRIM(mesg),ierr)
+END SUBROUTINE err
+
+END SUBROUTINE dynetat0
Index: DZ6/trunk/libf/dyn3d/dynredem.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d/dynredem.F90	(revision 5267)
+++ 	(revision )
@@ -1,244 +1,0 @@
-SUBROUTINE dynredem0(fichnom,iday_end,phis)
-!
-!-------------------------------------------------------------------------------
-! Write the NetCDF restart file (initialization).
-!-------------------------------------------------------------------------------
-  USE IOIPSL
-  USE strings_mod, ONLY: maxlen
-  USE infotrac, ONLY: nqtot, tracers
-  USE netcdf, ONLY: NF90_CREATE, NF90_DEF_DIM, NF90_INQ_VARID, NF90_GLOBAL,    &
-                    NF90_CLOSE,  NF90_PUT_ATT, NF90_UNLIMITED, NF90_CLOBBER,   &
-                    NF90_64BIT_OFFSET
-  USE dynredem_mod, ONLY: cre_var, put_var1, put_var2, err, modname, fil
-  USE comvert_mod,  ONLY: ap, bp, presnivs, pa, preff, nivsig, nivsigs
-  USE comconst_mod, ONLY: cpp, daysec, dtvr, g, kappa, omeg, rad
-  USE logic_mod, ONLY: fxyhypb, ysinus
-  USE serre_mod, ONLY: clon,clat,grossismx,grossismy,dzoomx,dzoomy, &
-                              taux,tauy
-  USE temps_mod, ONLY: annee_ref, day_ref, itau_dyn, itaufin, start_time
-  USE ener_mod, ONLY: etot0,ptot0,ztot0,stot0,ang0
-  
-  IMPLICIT NONE
-  include "dimensions.h"
-  include "paramet.h"
-  include "comgeom2.h"
-  include "description.h"
-  include "iniprint.h"
-!===============================================================================
-! Arguments:
-  CHARACTER(LEN=*), INTENT(IN) :: fichnom          !--- FILE NAME
-  INTEGER,          INTENT(IN) :: iday_end         !--- 
-  REAL,             INTENT(IN) :: phis(iip1, jjp1) !--- GROUND GEOPOTENTIAL
-!===============================================================================
-! Local variables:
-  INTEGER :: iq
-  INTEGER, PARAMETER :: length=100
-  REAL    :: tab_cntrl(length)                     !--- RUN PARAMETERS TABLE
-!   For NetCDF:
-  CHARACTER(LEN=maxlen) :: unites
-  INTEGER :: indexID
-  INTEGER :: rlonuID, rlonvID, rlatuID, rlatvID
-  INTEGER :: sID, sigID, nID, timID
-  INTEGER :: yyears0, jjour0, mmois0
-  REAL    :: zjulian, hours
-!===============================================================================
-  modname='dynredem0'; fil=fichnom
-  CALL ymds2ju(annee_ref, 1, iday_end, 0.0, zjulian)
-  CALL ju2ymds(zjulian, yyears0, mmois0, jjour0, hours)
-
-
-  tab_cntrl(:)  = 0.
-  tab_cntrl(1)  = REAL(iim)
-  tab_cntrl(2)  = REAL(jjm)
-  tab_cntrl(3)  = REAL(llm)
-  tab_cntrl(4)  = REAL(day_ref)
-  tab_cntrl(5)  = REAL(annee_ref)
-  tab_cntrl(6)  = rad
-  tab_cntrl(7)  = omeg
-  tab_cntrl(8)  = g
-  tab_cntrl(9)  = cpp
-  tab_cntrl(10) = kappa
-  tab_cntrl(11) = daysec
-  tab_cntrl(12) = dtvr
-  tab_cntrl(13) = etot0
-  tab_cntrl(14) = ptot0
-  tab_cntrl(15) = ztot0
-  tab_cntrl(16) = stot0
-  tab_cntrl(17) = ang0
-  tab_cntrl(18) = pa
-  tab_cntrl(19) = preff
-
-!    .....    parameters for zoom    ......   
-  tab_cntrl(20) = clon
-  tab_cntrl(21) = clat
-  tab_cntrl(22) = grossismx
-  tab_cntrl(23) = grossismy
-!
-  IF ( fxyhypb )   THEN
-    tab_cntrl(24) = 1.
-    tab_cntrl(25) = dzoomx
-    tab_cntrl(26) = dzoomy
-    tab_cntrl(27) = 0.
-    tab_cntrl(28) = taux
-    tab_cntrl(29) = tauy
-  ELSE
-    tab_cntrl(24) = 0.
-    tab_cntrl(25) = dzoomx
-    tab_cntrl(26) = dzoomy
-    tab_cntrl(27) = 0.
-    tab_cntrl(28) = 0.
-    tab_cntrl(29) = 0.
-    IF( ysinus )  tab_cntrl(27) = 1.
-  END IF
-  tab_cntrl(30) = REAL(iday_end)
-  tab_cntrl(31) = REAL(itau_dyn + itaufin)
-! start_time: start_time of simulation (not necessarily 0.)
-  tab_cntrl(32) = start_time
-
-!--- File creation
-  CALL err(NF90_CREATE(fichnom,IOR(NF90_CLOBBER,NF90_64BIT_OFFSET),nid))
-
-!--- Some global attributes
-  CALL err(NF90_PUT_ATT(nid,NF90_GLOBAL,"title","Fichier demarrage dynamique"))
-
-!--- Dimensions
-  CALL err(NF90_DEF_DIM(nid,"index", length, indexID))
-  CALL err(NF90_DEF_DIM(nid,"rlonu", iip1,   rlonuID))
-  CALL err(NF90_DEF_DIM(nid,"rlatu", jjp1,   rlatuID))
-  CALL err(NF90_DEF_DIM(nid,"rlonv", iip1,   rlonvID))
-  CALL err(NF90_DEF_DIM(nid,"rlatv", jjm,    rlatvID))
-  CALL err(NF90_DEF_DIM(nid,"sigs",  llm,        sID))
-  CALL err(NF90_DEF_DIM(nid,"sig",   llmp1,    sigID))
-  CALL err(NF90_DEF_DIM(nid,"temps", NF90_UNLIMITED, timID))
-
-!--- Define and save invariant fields
-  CALL put_var1(nid,"controle","Parametres de controle" ,[indexID],tab_cntrl)
-  CALL put_var1(nid,"rlonu"   ,"Longitudes des points U",[rlonuID],rlonu)
-  CALL put_var1(nid,"rlatu"   ,"Latitudes des points U" ,[rlatuID],rlatu)
-  CALL put_var1(nid,"rlonv"   ,"Longitudes des points V",[rlonvID],rlonv)
-  CALL put_var1(nid,"rlatv"   ,"Latitudes des points V" ,[rlatvID],rlatv)
-  CALL put_var1(nid,"nivsigs" ,"Numero naturel des couches s"    ,[sID]  ,nivsigs)
-  CALL put_var1(nid,"nivsig"  ,"Numero naturel des couches sigma",[sigID],nivsig)
-  CALL put_var1(nid,"ap"      ,"Coefficient A pour hybride"      ,[sigID],ap)
-  CALL put_var1(nid,"bp"      ,"Coefficient B pour hybride"      ,[sigID],bp)
-  CALL put_var1(nid,"presnivs",""                                ,[sID]  ,presnivs)
-! covariant <-> contravariant <-> natural conversion coefficients
-  CALL put_var2(nid,"cu","Coefficient de passage pour U",[rlonuID,rlatuID],cu)
-  CALL put_var2(nid,"cv","Coefficient de passage pour V",[rlonvID,rlatvID],cv)
-  CALL put_var2(nid,"aire","Aires de chaque maille"     ,[rlonvID,rlatuID],aire)
-  CALL put_var2(nid,"phisinit","Geopotentiel au sol"    ,[rlonvID,rlatuID],phis)
-
-!--- Define fields saved later
-  WRITE(unites,"('days since ',i4,'-',i2.2,'-',i2.2,' 00:00:00')") &
-               yyears0,mmois0,jjour0
-  CALL cre_var(nid,"temps","Temps de simulation",[timID],unites)
-  CALL cre_var(nid,"ucov" ,"Vitesse U"  ,[rlonuID,rlatuID,sID,timID])
-  CALL cre_var(nid,"vcov" ,"Vitesse V"  ,[rlonvID,rlatvID,sID,timID])
-  CALL cre_var(nid,"teta" ,"Temperature",[rlonvID,rlatuID,sID,timID])
-  DO iq=1,nqtot
-    CALL cre_var(nid,tracers(iq)%name,tracers(iq)%longName,[rlonvID,rlatuID,sID,timID])
-  END DO
-  CALL cre_var(nid,"masse","Masse d air"    ,[rlonvID,rlatuID,sID,timID])
-  CALL cre_var(nid,"ps"   ,"Pression au sol",[rlonvID,rlatuID    ,timID])
-  CALL err(NF90_CLOSE (nid))
-
-  WRITE(lunout,*)TRIM(modname)//': iim,jjm,llm,iday_end',iim,jjm,llm,iday_end
-  WRITE(lunout,*)TRIM(modname)//': rad,omeg,g,cpp,kappa',rad,omeg,g,cpp,kappa
-
-END SUBROUTINE dynredem0
-!
-!-------------------------------------------------------------------------------
-
-
-!-------------------------------------------------------------------------------
-!
-SUBROUTINE dynredem1(fichnom,time,vcov,ucov,teta,q,masse,ps)
-!
-!-------------------------------------------------------------------------------
-! Purpose: Write the NetCDF restart file (append).
-!-------------------------------------------------------------------------------
-  USE strings_mod, ONLY: maxlen
-  USE infotrac, ONLY: nqtot, tracers, type_trac
-  USE control_mod
-  USE netcdf,   ONLY: NF90_OPEN,  NF90_NOWRITE, NF90_GET_VAR, NF90_INQ_VARID,  &
-                      NF90_CLOSE, NF90_WRITE,   NF90_PUT_VAR, NF90_NoErr
-  USE dynredem_mod, ONLY: dynredem_write_u, dynredem_write_v, dynredem_read_u, &
-                          err, modname, fil, msg
-  USE temps_mod, ONLY: itau_dyn, itaufin
-  
-  IMPLICIT NONE
-  include "dimensions.h"
-  include "paramet.h"
-  include "description.h"
-  include "comgeom.h"
-  include "iniprint.h"
-!===============================================================================
-! Arguments:
-  CHARACTER(LEN=*), INTENT(IN) :: fichnom              !-- FILE NAME
-  REAL, INTENT(IN)    ::  time                         !-- TIME
-  REAL, INTENT(IN)    ::  vcov(iip1,jjm, llm)          !-- V COVARIANT WIND
-  REAL, INTENT(IN)    ::  ucov(iip1,jjp1,llm)          !-- U COVARIANT WIND
-  REAL, INTENT(IN)    ::  teta(iip1,jjp1,llm)          !-- POTENTIAL TEMPERATURE
-  REAL, INTENT(INOUT) ::     q(iip1,jjp1,llm,nqtot)    !-- TRACERS
-  REAL, INTENT(IN)    :: masse(iip1,jjp1,llm)          !-- MASS PER CELL
-  REAL, INTENT(IN)    ::    ps(iip1,jjp1)              !-- GROUND PRESSURE
-!===============================================================================
-! Local variables:
-  INTEGER :: iq, nid, vID, ierr, nid_trac, vID_trac
-  INTEGER, SAVE :: nb=0
-  INTEGER, PARAMETER :: length=100
-  REAL               :: tab_cntrl(length) ! tableau des parametres du run
-  CHARACTER(LEN=maxlen) :: var, dum
-  LOGICAL            :: lread_inca
-!===============================================================================
-
-  modname='dynredem1'; fil=fichnom
-  CALL err(NF90_OPEN(fil,NF90_WRITE,nid),"open",fil)
-
-!--- Write/extend time coordinate
-  nb = nb + 1
-  var="temps"
-  CALL err(NF90_INQ_VARID(nid,var,vID),"inq",var)
-  CALL err(NF90_PUT_VAR(nid,vID,[time]),"put",var)
-  WRITE(lunout,*)TRIM(modname)//": Saving for ", nb, time
-
-!--- Rewrite control table (itaufin undefined in dynredem0)
-  var="controle"
-  CALL err(NF90_INQ_VARID(nid,var,vID),"inq",var)
-  CALL err(NF90_GET_VAR(nid,vID,tab_cntrl),"get",var)
-  tab_cntrl(31)=DBLE(itau_dyn + itaufin)
-  CALL err(NF90_INQ_VARID(nid,var,vID),"inq",var)
-  CALL err(NF90_PUT_VAR(nid,vID,tab_cntrl),"put",var)
-
-!--- Save fields
-  CALL dynredem_write_u(nid,"ucov" ,ucov ,llm)
-  CALL dynredem_write_v(nid,"vcov" ,vcov ,llm)
-  CALL dynredem_write_u(nid,"teta" ,teta ,llm)
-  CALL dynredem_write_u(nid,"masse",masse,llm)
-  CALL dynredem_write_u(nid,"ps"   ,ps   ,1)
-
-!--- Tracers in file "start_trac.nc" (added by Anne)
-  lread_inca=.FALSE.; fil="start_trac.nc"
-  IF(ANY(type_trac == ['inca','inco'])) INQUIRE(FILE=fil,EXIST=lread_inca)
-  IF(lread_inca) CALL err(NF90_OPEN(fil,NF90_NOWRITE,nid_trac),"open")
-
-!--- Save tracers
-  DO iq=1,nqtot; var=TRIM(tracers(iq)%name); ierr=-1
-    IF(lread_inca) THEN                  !--- Possibly read from "start_trac.nc"
-      fil="start_trac.nc"
-      ierr=NF90_INQ_VARID(nid_trac,var,vID_trac)
-      dum='inq'; IF(ierr==NF90_NoErr) dum='fnd'
-      WRITE(lunout,*)msg(dum,var)
-
-
-      IF(ierr==NF90_NoErr) CALL dynredem_read_u(nid_trac,var,q(:,:,:,iq),llm)
-    END IF
-    fil=fichnom
-    CALL dynredem_write_u(nid,var,q(:,:,:,iq),llm)
-  END DO
-  CALL err(NF90_CLOSE(nid),"close")
-  fil="start_trac.nc"
-  IF(lread_inca) CALL err(NF90_CLOSE(nid_trac),"close")
-
-END SUBROUTINE dynredem1
-
Index: /LMDZ6/trunk/libf/dyn3d/dynredem.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d/dynredem.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3d/dynredem.f90	(revision 5268)
@@ -0,0 +1,244 @@
+SUBROUTINE dynredem0(fichnom,iday_end,phis)
+!
+!-------------------------------------------------------------------------------
+! Write the NetCDF restart file (initialization).
+!-------------------------------------------------------------------------------
+  USE IOIPSL
+  USE strings_mod, ONLY: maxlen
+  USE infotrac, ONLY: nqtot, tracers
+  USE netcdf, ONLY: NF90_CREATE, NF90_DEF_DIM, NF90_INQ_VARID, NF90_GLOBAL,    &
+                    NF90_CLOSE,  NF90_PUT_ATT, NF90_UNLIMITED, NF90_CLOBBER,   &
+                    NF90_64BIT_OFFSET
+  USE dynredem_mod, ONLY: cre_var, put_var1, put_var2, err, modname, fil
+  USE comvert_mod,  ONLY: ap, bp, presnivs, pa, preff, nivsig, nivsigs
+  USE comconst_mod, ONLY: cpp, daysec, dtvr, g, kappa, omeg, rad
+  USE logic_mod, ONLY: fxyhypb, ysinus
+  USE serre_mod, ONLY: clon,clat,grossismx,grossismy,dzoomx,dzoomy, &
+                              taux,tauy
+  USE temps_mod, ONLY: annee_ref, day_ref, itau_dyn, itaufin, start_time
+  USE ener_mod, ONLY: etot0,ptot0,ztot0,stot0,ang0
+  
+  IMPLICIT NONE
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom2.h"
+  include "description.h"
+  include "iniprint.h"
+!===============================================================================
+! Arguments:
+  CHARACTER(LEN=*), INTENT(IN) :: fichnom          !--- FILE NAME
+  INTEGER,          INTENT(IN) :: iday_end         !--- 
+  REAL,             INTENT(IN) :: phis(iip1, jjp1) !--- GROUND GEOPOTENTIAL
+!===============================================================================
+! Local variables:
+  INTEGER :: iq
+  INTEGER, PARAMETER :: length=100
+  REAL    :: tab_cntrl(length)                     !--- RUN PARAMETERS TABLE
+!   For NetCDF:
+  CHARACTER(LEN=maxlen) :: unites
+  INTEGER :: indexID
+  INTEGER :: rlonuID, rlonvID, rlatuID, rlatvID
+  INTEGER :: sID, sigID, nID, timID
+  INTEGER :: yyears0, jjour0, mmois0
+  REAL    :: zjulian, hours
+!===============================================================================
+  modname='dynredem0'; fil=fichnom
+  CALL ymds2ju(annee_ref, 1, iday_end, 0.0, zjulian)
+  CALL ju2ymds(zjulian, yyears0, mmois0, jjour0, hours)
+
+
+  tab_cntrl(:)  = 0.
+  tab_cntrl(1)  = REAL(iim)
+  tab_cntrl(2)  = REAL(jjm)
+  tab_cntrl(3)  = REAL(llm)
+  tab_cntrl(4)  = REAL(day_ref)
+  tab_cntrl(5)  = REAL(annee_ref)
+  tab_cntrl(6)  = rad
+  tab_cntrl(7)  = omeg
+  tab_cntrl(8)  = g
+  tab_cntrl(9)  = cpp
+  tab_cntrl(10) = kappa
+  tab_cntrl(11) = daysec
+  tab_cntrl(12) = dtvr
+  tab_cntrl(13) = etot0
+  tab_cntrl(14) = ptot0
+  tab_cntrl(15) = ztot0
+  tab_cntrl(16) = stot0
+  tab_cntrl(17) = ang0
+  tab_cntrl(18) = pa
+  tab_cntrl(19) = preff
+
+!    .....    parameters for zoom    ......   
+  tab_cntrl(20) = clon
+  tab_cntrl(21) = clat
+  tab_cntrl(22) = grossismx
+  tab_cntrl(23) = grossismy
+!
+  IF ( fxyhypb )   THEN
+    tab_cntrl(24) = 1.
+    tab_cntrl(25) = dzoomx
+    tab_cntrl(26) = dzoomy
+    tab_cntrl(27) = 0.
+    tab_cntrl(28) = taux
+    tab_cntrl(29) = tauy
+  ELSE
+    tab_cntrl(24) = 0.
+    tab_cntrl(25) = dzoomx
+    tab_cntrl(26) = dzoomy
+    tab_cntrl(27) = 0.
+    tab_cntrl(28) = 0.
+    tab_cntrl(29) = 0.
+    IF( ysinus )  tab_cntrl(27) = 1.
+  END IF
+  tab_cntrl(30) = REAL(iday_end)
+  tab_cntrl(31) = REAL(itau_dyn + itaufin)
+! start_time: start_time of simulation (not necessarily 0.)
+  tab_cntrl(32) = start_time
+
+!--- File creation
+  CALL err(NF90_CREATE(fichnom,IOR(NF90_CLOBBER,NF90_64BIT_OFFSET),nid))
+
+!--- Some global attributes
+  CALL err(NF90_PUT_ATT(nid,NF90_GLOBAL,"title","Fichier demarrage dynamique"))
+
+!--- Dimensions
+  CALL err(NF90_DEF_DIM(nid,"index", length, indexID))
+  CALL err(NF90_DEF_DIM(nid,"rlonu", iip1,   rlonuID))
+  CALL err(NF90_DEF_DIM(nid,"rlatu", jjp1,   rlatuID))
+  CALL err(NF90_DEF_DIM(nid,"rlonv", iip1,   rlonvID))
+  CALL err(NF90_DEF_DIM(nid,"rlatv", jjm,    rlatvID))
+  CALL err(NF90_DEF_DIM(nid,"sigs",  llm,        sID))
+  CALL err(NF90_DEF_DIM(nid,"sig",   llmp1,    sigID))
+  CALL err(NF90_DEF_DIM(nid,"temps", NF90_UNLIMITED, timID))
+
+!--- Define and save invariant fields
+  CALL put_var1(nid,"controle","Parametres de controle" ,[indexID],tab_cntrl)
+  CALL put_var1(nid,"rlonu"   ,"Longitudes des points U",[rlonuID],rlonu)
+  CALL put_var1(nid,"rlatu"   ,"Latitudes des points U" ,[rlatuID],rlatu)
+  CALL put_var1(nid,"rlonv"   ,"Longitudes des points V",[rlonvID],rlonv)
+  CALL put_var1(nid,"rlatv"   ,"Latitudes des points V" ,[rlatvID],rlatv)
+  CALL put_var1(nid,"nivsigs" ,"Numero naturel des couches s"    ,[sID]  ,nivsigs)
+  CALL put_var1(nid,"nivsig"  ,"Numero naturel des couches sigma",[sigID],nivsig)
+  CALL put_var1(nid,"ap"      ,"Coefficient A pour hybride"      ,[sigID],ap)
+  CALL put_var1(nid,"bp"      ,"Coefficient B pour hybride"      ,[sigID],bp)
+  CALL put_var1(nid,"presnivs",""                                ,[sID]  ,presnivs)
+! covariant <-> contravariant <-> natural conversion coefficients
+  CALL put_var2(nid,"cu","Coefficient de passage pour U",[rlonuID,rlatuID],cu)
+  CALL put_var2(nid,"cv","Coefficient de passage pour V",[rlonvID,rlatvID],cv)
+  CALL put_var2(nid,"aire","Aires de chaque maille"     ,[rlonvID,rlatuID],aire)
+  CALL put_var2(nid,"phisinit","Geopotentiel au sol"    ,[rlonvID,rlatuID],phis)
+
+!--- Define fields saved later
+  WRITE(unites,"('days since ',i4,'-',i2.2,'-',i2.2,' 00:00:00')") &
+               yyears0,mmois0,jjour0
+  CALL cre_var(nid,"temps","Temps de simulation",[timID],unites)
+  CALL cre_var(nid,"ucov" ,"Vitesse U"  ,[rlonuID,rlatuID,sID,timID])
+  CALL cre_var(nid,"vcov" ,"Vitesse V"  ,[rlonvID,rlatvID,sID,timID])
+  CALL cre_var(nid,"teta" ,"Temperature",[rlonvID,rlatuID,sID,timID])
+  DO iq=1,nqtot
+    CALL cre_var(nid,tracers(iq)%name,tracers(iq)%longName,[rlonvID,rlatuID,sID,timID])
+  END DO
+  CALL cre_var(nid,"masse","Masse d air"    ,[rlonvID,rlatuID,sID,timID])
+  CALL cre_var(nid,"ps"   ,"Pression au sol",[rlonvID,rlatuID    ,timID])
+  CALL err(NF90_CLOSE (nid))
+
+  WRITE(lunout,*)TRIM(modname)//': iim,jjm,llm,iday_end',iim,jjm,llm,iday_end
+  WRITE(lunout,*)TRIM(modname)//': rad,omeg,g,cpp,kappa',rad,omeg,g,cpp,kappa
+
+END SUBROUTINE dynredem0
+!
+!-------------------------------------------------------------------------------
+
+
+!-------------------------------------------------------------------------------
+!
+SUBROUTINE dynredem1(fichnom,time,vcov,ucov,teta,q,masse,ps)
+!
+!-------------------------------------------------------------------------------
+! Purpose: Write the NetCDF restart file (append).
+!-------------------------------------------------------------------------------
+  USE strings_mod, ONLY: maxlen
+  USE infotrac, ONLY: nqtot, tracers, type_trac
+  USE control_mod
+  USE netcdf,   ONLY: NF90_OPEN,  NF90_NOWRITE, NF90_GET_VAR, NF90_INQ_VARID,  &
+                      NF90_CLOSE, NF90_WRITE,   NF90_PUT_VAR, NF90_NoErr
+  USE dynredem_mod, ONLY: dynredem_write_u, dynredem_write_v, dynredem_read_u, &
+                          err, modname, fil, msg
+  USE temps_mod, ONLY: itau_dyn, itaufin
+  
+  IMPLICIT NONE
+  include "dimensions.h"
+  include "paramet.h"
+  include "description.h"
+  include "comgeom.h"
+  include "iniprint.h"
+!===============================================================================
+! Arguments:
+  CHARACTER(LEN=*), INTENT(IN) :: fichnom              !-- FILE NAME
+  REAL, INTENT(IN)    ::  time                         !-- TIME
+  REAL, INTENT(IN)    ::  vcov(iip1,jjm, llm)          !-- V COVARIANT WIND
+  REAL, INTENT(IN)    ::  ucov(iip1,jjp1,llm)          !-- U COVARIANT WIND
+  REAL, INTENT(IN)    ::  teta(iip1,jjp1,llm)          !-- POTENTIAL TEMPERATURE
+  REAL, INTENT(INOUT) ::     q(iip1,jjp1,llm,nqtot)    !-- TRACERS
+  REAL, INTENT(IN)    :: masse(iip1,jjp1,llm)          !-- MASS PER CELL
+  REAL, INTENT(IN)    ::    ps(iip1,jjp1)              !-- GROUND PRESSURE
+!===============================================================================
+! Local variables:
+  INTEGER :: iq, nid, vID, ierr, nid_trac, vID_trac
+  INTEGER, SAVE :: nb=0
+  INTEGER, PARAMETER :: length=100
+  REAL               :: tab_cntrl(length) ! tableau des parametres du run
+  CHARACTER(LEN=maxlen) :: var, dum
+  LOGICAL            :: lread_inca
+!===============================================================================
+
+  modname='dynredem1'; fil=fichnom
+  CALL err(NF90_OPEN(fil,NF90_WRITE,nid),"open",fil)
+
+!--- Write/extend time coordinate
+  nb = nb + 1
+  var="temps"
+  CALL err(NF90_INQ_VARID(nid,var,vID),"inq",var)
+  CALL err(NF90_PUT_VAR(nid,vID,[time]),"put",var)
+  WRITE(lunout,*)TRIM(modname)//": Saving for ", nb, time
+
+!--- Rewrite control table (itaufin undefined in dynredem0)
+  var="controle"
+  CALL err(NF90_INQ_VARID(nid,var,vID),"inq",var)
+  CALL err(NF90_GET_VAR(nid,vID,tab_cntrl),"get",var)
+  tab_cntrl(31)=DBLE(itau_dyn + itaufin)
+  CALL err(NF90_INQ_VARID(nid,var,vID),"inq",var)
+  CALL err(NF90_PUT_VAR(nid,vID,tab_cntrl),"put",var)
+
+!--- Save fields
+  CALL dynredem_write_u(nid,"ucov" ,ucov ,llm)
+  CALL dynredem_write_v(nid,"vcov" ,vcov ,llm)
+  CALL dynredem_write_u(nid,"teta" ,teta ,llm)
+  CALL dynredem_write_u(nid,"masse",masse,llm)
+  CALL dynredem_write_u(nid,"ps"   ,ps   ,1)
+
+!--- Tracers in file "start_trac.nc" (added by Anne)
+  lread_inca=.FALSE.; fil="start_trac.nc"
+  IF(ANY(type_trac == ['inca','inco'])) INQUIRE(FILE=fil,EXIST=lread_inca)
+  IF(lread_inca) CALL err(NF90_OPEN(fil,NF90_NOWRITE,nid_trac),"open")
+
+!--- Save tracers
+  DO iq=1,nqtot; var=TRIM(tracers(iq)%name); ierr=-1
+    IF(lread_inca) THEN                  !--- Possibly read from "start_trac.nc"
+      fil="start_trac.nc"
+      ierr=NF90_INQ_VARID(nid_trac,var,vID_trac)
+      dum='inq'; IF(ierr==NF90_NoErr) dum='fnd'
+      WRITE(lunout,*)msg(dum,var)
+
+
+      IF(ierr==NF90_NoErr) CALL dynredem_read_u(nid_trac,var,q(:,:,:,iq),llm)
+    END IF
+    fil=fichnom
+    CALL dynredem_write_u(nid,var,q(:,:,:,iq),llm)
+  END DO
+  CALL err(NF90_CLOSE(nid),"close")
+  fil="start_trac.nc"
+  IF(lread_inca) CALL err(NF90_CLOSE(nid_trac),"close")
+
+END SUBROUTINE dynredem1
+
Index: DZ6/trunk/libf/dyn3d/dynredem_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d/dynredem_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,212 +1,0 @@
-MODULE dynredem_mod
-
-  USE netcdf
-  PRIVATE
-  PUBLIC :: dynredem_write_u, dynredem_write_v, dynredem_read_u, err
-  PUBLIC :: cre_var, put_var1, put_var2, fil, modname, msg
-  include "dimensions.h"
-  include "paramet.h"
-  CHARACTER(LEN=256), SAVE :: fil, modname
-  INTEGER,            SAVE :: nvarid
-
-
-CONTAINS
-
-
-!===============================================================================
-!
-SUBROUTINE dynredem_write_u(ncid,id,var,ll)
-!
-!===============================================================================
-  IMPLICIT NONE
-!===============================================================================
-! Arguments:
-  INTEGER,          INTENT(IN) :: ncid
-  CHARACTER(LEN=*), INTENT(IN) :: id
-  REAL,             INTENT(IN) :: var(iip1,jjp1,ll)
-  INTEGER,          INTENT(IN) :: ll
-!===============================================================================
-! Local variables:
-  INTEGER :: start(4), count(4)
-!===============================================================================
-  start(:)=[1,1,1,1]; count(:)=[iip1,jjp1,ll,1]
-  CALL err(NF90_INQ_VARID(ncid,id,nvarid),"inq",id)
-  CALL err(NF90_PUT_VAR(ncid,nvarid,var,start,count),"put",id)
-  
-END SUBROUTINE dynredem_write_u
-!
-!===============================================================================
-
-
-!===============================================================================
-!
-SUBROUTINE dynredem_write_v(ncid,id,var,ll)
-!
-!===============================================================================
-  IMPLICIT NONE
-!===============================================================================
-! Arguments:
-  INTEGER,          INTENT(IN) :: ncid
-  CHARACTER(LEN=*), INTENT(IN) :: id
-  REAL,             INTENT(IN) :: var(iip1,jjm,ll)
-  INTEGER,          INTENT(IN) :: ll
-!===============================================================================
-! Local variables:
-  INTEGER :: start(4), count(4)
-!===============================================================================
-  start(:)=[1,1,1,1]; count(:)=[iip1,jjm,ll,1]
-  CALL err(NF90_INQ_VARID(ncid,id,nvarid),"inq",id)
-  CALL err(NF90_PUT_VAR(ncid,nvarid,var,start,count),"put",id)
-  
-END SUBROUTINE dynredem_write_v
-!
-!===============================================================================
-
-
-!===============================================================================
-!
-SUBROUTINE dynredem_read_u(ncid,id,var,ll)
-!
-!===============================================================================
-  IMPLICIT NONE
-!===============================================================================
-! Arguments:
-  INTEGER,          INTENT(IN)  :: ncid
-  CHARACTER(LEN=*), INTENT(IN)  :: id
-  REAL,             INTENT(OUT) :: var(iip1,jjp1,ll)
-  INTEGER,          INTENT(IN)  :: ll
-!===============================================================================
-! Local variables:
-  INTEGER :: start(4), count(4)
-!===============================================================================
-  start(:)=[1,1,1,1]; count(:)=[iip1,jjp1,ll,1]
-  CALL err(NF90_INQ_VARID(ncid,id,nvarid),"inq",id)
-  CALL err(NF90_GET_VAR(ncid,nvarid,var,start,count),"get",id)
-  
-END SUBROUTINE dynredem_read_u    
-!
-!===============================================================================
-
-
-!===============================================================================
-!
-SUBROUTINE cre_var(ncid,var,title,did,units)
-  USE lmdz_cppkeys_wrapper, ONLY: nf90_format
-  IMPLICIT NONE
-
-  INTEGER,                    INTENT(IN) :: ncid
-  CHARACTER(LEN=*),           INTENT(IN) :: var, title
-  INTEGER,                    INTENT(IN) :: did(:)
-  CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: units
-
-  CALL err(NF90_DEF_VAR(ncid,var,nf90_format,did,nvarid),"inq",var)
-  IF(title/="")      CALL err(NF90_PUT_ATT(ncid,nvarid,"title",title),var)
-  IF(PRESENT(units)) CALL err(NF90_PUT_ATT(ncid,nvarid,"units",units),var)
-END SUBROUTINE cre_var
-!
-!===============================================================================
-
-
-!===============================================================================
-!
-SUBROUTINE put_var1(ncid,var,title,did,v,units)
-!
-!===============================================================================
-  IMPLICIT NONE
-!===============================================================================
-! Arguments:
-  INTEGER,                    INTENT(IN) :: ncid
-  CHARACTER(LEN=*),           INTENT(IN) :: var, title
-  INTEGER,                    INTENT(IN) :: did(1)
-  REAL,                       INTENT(IN) :: v(:)
-  CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: units
-!===============================================================================
-  IF(     PRESENT(units)) CALL cre_var(ncid,var,title,did,units)
-  IF(.NOT.PRESENT(units)) CALL cre_var(ncid,var,title,did)
-  CALL err(NF90_ENDDEF(ncid))
-  CALL err(NF90_PUT_VAR(ncid,nvarid,v),"put",var)
-  CALL err(NF90_REDEF(ncid))
-
-END SUBROUTINE put_var1
-!
-!===============================================================================
-
-
-!===============================================================================
-!
-SUBROUTINE put_var2(ncid,var,title,did,v,units)
-!
-!===============================================================================
-  IMPLICIT NONE
-!===============================================================================
-! Arguments:
-  INTEGER,                    INTENT(IN) :: ncid
-  CHARACTER(LEN=*),           INTENT(IN) :: var, title
-  INTEGER,                    INTENT(IN) :: did(2)
-  REAL,                       INTENT(IN) :: v(:,:)
-  CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: units
-!===============================================================================
-  IF(     PRESENT(units)) CALL cre_var(ncid,var,title,did,units)
-  IF(.NOT.PRESENT(units)) CALL cre_var(ncid,var,title,did)
-  CALL err(NF90_ENDDEF(ncid))
-  CALL err(NF90_PUT_VAR(ncid,nvarid,v),"put",var)
-  CALL err(NF90_REDEF(ncid))
-
-END SUBROUTINE put_var2
-!
-!===============================================================================
-
-
-!===============================================================================
-!
-FUNCTION msg(typ,nam)
-!
-!===============================================================================
-  IMPLICIT NONE
-!===============================================================================
-! Arguments:
-  CHARACTER(LEN=256)                     :: msg    !--- STANDARDIZED MESSAGE
-  CHARACTER(LEN=*),           INTENT(IN) :: typ    !--- TYPE OF OPERATION
-  CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: nam    !--- FIELD NAME
-!===============================================================================
-  SELECT CASE(typ)
-    CASE('open');  msg="Opening failed for <"//TRIM(fil)//">"
-    CASE('close'); msg="Closing failed for <"//TRIM(fil)//">"
-    CASE('get');   msg="Reading failed for <"//TRIM(nam)//">"
-    CASE('put');   msg="Writting failed for <"//TRIM(nam)//">"
-    CASE('inq');   msg="Missing field <"//TRIM(nam)//">"
-    CASE('fnd');   msg="Found field <"//TRIM(nam)//">"
-  END SELECT
-  msg=TRIM(msg)//" in file <"//TRIM(fil)//">"
-
-END FUNCTION msg
-!
-!===============================================================================
-
-
-!===============================================================================
-!
-SUBROUTINE err(ierr,typ,nam)
-!
-!===============================================================================
-  IMPLICIT NONE
-!===============================================================================
-! Arguments:
-  INTEGER,                    INTENT(IN) :: ierr   !--- NetCDF ERROR CODE
-  CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: typ    !--- TYPE OF OPERATION
-  CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: nam    !--- FIELD NAME
-!===============================================================================
-  IF(ierr==NF90_NoERR) RETURN
-  IF(.NOT.PRESENT(typ)) THEN
-    CALL ABORT_gcm(modname,NF90_STRERROR(ierr),ierr)
-  ELSE
-    CALL ABORT_gcm(modname,msg(typ,nam),ierr)
-  END IF
-
-END SUBROUTINE err
-!
-!===============================================================================
-
-END MODULE dynredem_mod   
-    
-    
Index: /LMDZ6/trunk/libf/dyn3d/dynredem_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d/dynredem_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3d/dynredem_mod.f90	(revision 5268)
@@ -0,0 +1,212 @@
+MODULE dynredem_mod
+
+  USE netcdf
+  PRIVATE
+  PUBLIC :: dynredem_write_u, dynredem_write_v, dynredem_read_u, err
+  PUBLIC :: cre_var, put_var1, put_var2, fil, modname, msg
+  include "dimensions.h"
+  include "paramet.h"
+  CHARACTER(LEN=256), SAVE :: fil, modname
+  INTEGER,            SAVE :: nvarid
+
+
+CONTAINS
+
+
+!===============================================================================
+!
+SUBROUTINE dynredem_write_u(ncid,id,var,ll)
+!
+!===============================================================================
+  IMPLICIT NONE
+!===============================================================================
+! Arguments:
+  INTEGER,          INTENT(IN) :: ncid
+  CHARACTER(LEN=*), INTENT(IN) :: id
+  REAL,             INTENT(IN) :: var(iip1,jjp1,ll)
+  INTEGER,          INTENT(IN) :: ll
+!===============================================================================
+! Local variables:
+  INTEGER :: start(4), count(4)
+!===============================================================================
+  start(:)=[1,1,1,1]; count(:)=[iip1,jjp1,ll,1]
+  CALL err(NF90_INQ_VARID(ncid,id,nvarid),"inq",id)
+  CALL err(NF90_PUT_VAR(ncid,nvarid,var,start,count),"put",id)
+  
+END SUBROUTINE dynredem_write_u
+!
+!===============================================================================
+
+
+!===============================================================================
+!
+SUBROUTINE dynredem_write_v(ncid,id,var,ll)
+!
+!===============================================================================
+  IMPLICIT NONE
+!===============================================================================
+! Arguments:
+  INTEGER,          INTENT(IN) :: ncid
+  CHARACTER(LEN=*), INTENT(IN) :: id
+  REAL,             INTENT(IN) :: var(iip1,jjm,ll)
+  INTEGER,          INTENT(IN) :: ll
+!===============================================================================
+! Local variables:
+  INTEGER :: start(4), count(4)
+!===============================================================================
+  start(:)=[1,1,1,1]; count(:)=[iip1,jjm,ll,1]
+  CALL err(NF90_INQ_VARID(ncid,id,nvarid),"inq",id)
+  CALL err(NF90_PUT_VAR(ncid,nvarid,var,start,count),"put",id)
+  
+END SUBROUTINE dynredem_write_v
+!
+!===============================================================================
+
+
+!===============================================================================
+!
+SUBROUTINE dynredem_read_u(ncid,id,var,ll)
+!
+!===============================================================================
+  IMPLICIT NONE
+!===============================================================================
+! Arguments:
+  INTEGER,          INTENT(IN)  :: ncid
+  CHARACTER(LEN=*), INTENT(IN)  :: id
+  REAL,             INTENT(OUT) :: var(iip1,jjp1,ll)
+  INTEGER,          INTENT(IN)  :: ll
+!===============================================================================
+! Local variables:
+  INTEGER :: start(4), count(4)
+!===============================================================================
+  start(:)=[1,1,1,1]; count(:)=[iip1,jjp1,ll,1]
+  CALL err(NF90_INQ_VARID(ncid,id,nvarid),"inq",id)
+  CALL err(NF90_GET_VAR(ncid,nvarid,var,start,count),"get",id)
+  
+END SUBROUTINE dynredem_read_u    
+!
+!===============================================================================
+
+
+!===============================================================================
+!
+SUBROUTINE cre_var(ncid,var,title,did,units)
+  USE lmdz_cppkeys_wrapper, ONLY: nf90_format
+  IMPLICIT NONE
+
+  INTEGER,                    INTENT(IN) :: ncid
+  CHARACTER(LEN=*),           INTENT(IN) :: var, title
+  INTEGER,                    INTENT(IN) :: did(:)
+  CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: units
+
+  CALL err(NF90_DEF_VAR(ncid,var,nf90_format,did,nvarid),"inq",var)
+  IF(title/="")      CALL err(NF90_PUT_ATT(ncid,nvarid,"title",title),var)
+  IF(PRESENT(units)) CALL err(NF90_PUT_ATT(ncid,nvarid,"units",units),var)
+END SUBROUTINE cre_var
+!
+!===============================================================================
+
+
+!===============================================================================
+!
+SUBROUTINE put_var1(ncid,var,title,did,v,units)
+!
+!===============================================================================
+  IMPLICIT NONE
+!===============================================================================
+! Arguments:
+  INTEGER,                    INTENT(IN) :: ncid
+  CHARACTER(LEN=*),           INTENT(IN) :: var, title
+  INTEGER,                    INTENT(IN) :: did(1)
+  REAL,                       INTENT(IN) :: v(:)
+  CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: units
+!===============================================================================
+  IF(     PRESENT(units)) CALL cre_var(ncid,var,title,did,units)
+  IF(.NOT.PRESENT(units)) CALL cre_var(ncid,var,title,did)
+  CALL err(NF90_ENDDEF(ncid))
+  CALL err(NF90_PUT_VAR(ncid,nvarid,v),"put",var)
+  CALL err(NF90_REDEF(ncid))
+
+END SUBROUTINE put_var1
+!
+!===============================================================================
+
+
+!===============================================================================
+!
+SUBROUTINE put_var2(ncid,var,title,did,v,units)
+!
+!===============================================================================
+  IMPLICIT NONE
+!===============================================================================
+! Arguments:
+  INTEGER,                    INTENT(IN) :: ncid
+  CHARACTER(LEN=*),           INTENT(IN) :: var, title
+  INTEGER,                    INTENT(IN) :: did(2)
+  REAL,                       INTENT(IN) :: v(:,:)
+  CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: units
+!===============================================================================
+  IF(     PRESENT(units)) CALL cre_var(ncid,var,title,did,units)
+  IF(.NOT.PRESENT(units)) CALL cre_var(ncid,var,title,did)
+  CALL err(NF90_ENDDEF(ncid))
+  CALL err(NF90_PUT_VAR(ncid,nvarid,v),"put",var)
+  CALL err(NF90_REDEF(ncid))
+
+END SUBROUTINE put_var2
+!
+!===============================================================================
+
+
+!===============================================================================
+!
+FUNCTION msg(typ,nam)
+!
+!===============================================================================
+  IMPLICIT NONE
+!===============================================================================
+! Arguments:
+  CHARACTER(LEN=256)                     :: msg    !--- STANDARDIZED MESSAGE
+  CHARACTER(LEN=*),           INTENT(IN) :: typ    !--- TYPE OF OPERATION
+  CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: nam    !--- FIELD NAME
+!===============================================================================
+  SELECT CASE(typ)
+    CASE('open');  msg="Opening failed for <"//TRIM(fil)//">"
+    CASE('close'); msg="Closing failed for <"//TRIM(fil)//">"
+    CASE('get');   msg="Reading failed for <"//TRIM(nam)//">"
+    CASE('put');   msg="Writting failed for <"//TRIM(nam)//">"
+    CASE('inq');   msg="Missing field <"//TRIM(nam)//">"
+    CASE('fnd');   msg="Found field <"//TRIM(nam)//">"
+  END SELECT
+  msg=TRIM(msg)//" in file <"//TRIM(fil)//">"
+
+END FUNCTION msg
+!
+!===============================================================================
+
+
+!===============================================================================
+!
+SUBROUTINE err(ierr,typ,nam)
+!
+!===============================================================================
+  IMPLICIT NONE
+!===============================================================================
+! Arguments:
+  INTEGER,                    INTENT(IN) :: ierr   !--- NetCDF ERROR CODE
+  CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: typ    !--- TYPE OF OPERATION
+  CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: nam    !--- FIELD NAME
+!===============================================================================
+  IF(ierr==NF90_NoERR) RETURN
+  IF(.NOT.PRESENT(typ)) THEN
+    CALL ABORT_gcm(modname,NF90_STRERROR(ierr),ierr)
+  ELSE
+    CALL ABORT_gcm(modname,msg(typ,nam),ierr)
+  END IF
+
+END SUBROUTINE err
+!
+!===============================================================================
+
+END MODULE dynredem_mod   
+    
+    
Index: DZ6/trunk/libf/dyn3d/fluxstokenc.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d/fluxstokenc.F90	(revision 5267)
+++ 	(revision )
@@ -1,166 +1,0 @@
-!
-! $Id$
-!
-SUBROUTINE fluxstokenc(pbaru,pbarv,masse,teta,phi,phis, &
-        time_step,itau )
-  ! This routine is designed to work with ioipsl
-
-   USE IOIPSL
-  !
-  ! Auteur :  F. Hourdin
-  !
-  !
-  !cc   ..   Modif. P. Le Van  ( 20/12/97 )  ...
-  !
-  IMPLICIT NONE
-  !
-  include "dimensions.h"
-  include "paramet.h"
-  include "comgeom.h"
-  include "tracstoke.h"
-  include "iniprint.h"
-
-  REAL :: time_step,t_wrt, t_ops
-  REAL :: pbaru(ip1jmp1,llm),pbarv(ip1jm,llm)
-  REAL :: masse(ip1jmp1,llm),teta(ip1jmp1,llm),phi(ip1jmp1,llm)
-  REAL :: phis(ip1jmp1)
-
-  REAL :: pbaruc(ip1jmp1,llm),pbarvc(ip1jm,llm)
-  REAL :: massem(ip1jmp1,llm),tetac(ip1jmp1,llm),phic(ip1jmp1,llm)
-
-  REAL :: pbarug(ip1jmp1,llm),pbarvg(iip1,jjm,llm),wg(ip1jmp1,llm)
-
-  REAL :: pbarvst(iip1,jjp1,llm),zistdyn
-    real :: dtcum
-
-  INTEGER :: iadvtr,ndex(1)
-  integer :: nscal
-  real :: tst(1),ist(1),istp(1)
-  INTEGER :: ij,l,irec,i,j,itau
-  INTEGER, SAVE :: fluxid, fluxvid,fluxdid
-
-  SAVE iadvtr, massem,pbaruc,pbarvc,irec
-  SAVE phic,tetac
-  logical :: first
-  save first
-  data first/.true./
-  DATA iadvtr/0/
-
-
-  ! AC initialisations
-  pbarug(:,:)   = 0.
-  pbarvg(:,:,:) = 0.
-  wg(:,:)       = 0.
-
-
-  if(first) then
-
-    CALL initfluxsto( 'fluxstoke', &
-          time_step,istdyn* time_step,istdyn* time_step, &
-          fluxid,fluxvid,fluxdid)
-
-    ndex(1) = 0
-    call histwrite(fluxid, 'phis', 1, phis, iip1*jjp1, ndex)
-    call histwrite(fluxid, 'aire', 1, aire, iip1*jjp1, ndex)
-
-    ndex(1) = 0
-    nscal = 1
-    tst(1) = time_step
-    call histwrite(fluxdid, 'dtvr', 1, tst, nscal, ndex)
-    ist(1)=istdyn
-    call histwrite(fluxdid, 'istdyn', 1, ist, nscal, ndex)
-    istp(1)= istphy
-    call histwrite(fluxdid, 'istphy', 1, istp, nscal, ndex)
-
-    first = .false.
-
-  endif
-
-
-  IF(iadvtr.EQ.0) THEN
-     phic(:,:)=0
-     tetac(:,:)=0
-     pbaruc(:,:)=0
-     pbarvc(:,:)=0
-  ENDIF
-
-  !   accumulation des flux de masse horizontaux
-  DO l=1,llm
-     DO ij = 1,ip1jmp1
-        pbaruc(ij,l) = pbaruc(ij,l) + pbaru(ij,l)
-        tetac(ij,l) = tetac(ij,l) + teta(ij,l)
-        phic(ij,l) = phic(ij,l) + phi(ij,l)
-     ENDDO
-     DO ij = 1,ip1jm
-        pbarvc(ij,l) = pbarvc(ij,l) + pbarv(ij,l)
-     ENDDO
-  ENDDO
-
-  !   selection de la masse instantannee des mailles avant le transport.
-  IF(iadvtr.EQ.0) THEN
-     CALL SCOPY(ip1jmp1*llm,masse,1,massem,1)
-  ENDIF
-
-  iadvtr   = iadvtr+1
-
-
-  !   Test pour savoir si on advecte a ce pas de temps
-  IF ( iadvtr.EQ.istdyn ) THEN
-  !    normalisation
-  DO l=1,llm
-     DO ij = 1,ip1jmp1
-        pbaruc(ij,l) = pbaruc(ij,l)/REAL(istdyn)
-        tetac(ij,l) = tetac(ij,l)/REAL(istdyn)
-        phic(ij,l) = phic(ij,l)/REAL(istdyn)
-     ENDDO
-     DO ij = 1,ip1jm
-        pbarvc(ij,l) = pbarvc(ij,l)/REAL(istdyn)
-     ENDDO
-  ENDDO
-
-  !   traitement des flux de masse avant advection.
-  ! 1. calcul de w
-  ! 2. groupement des mailles pres du pole.
-
-    CALL groupe( massem, pbaruc,pbarvc, pbarug,pbarvg,wg )
-
-    do l=1,llm
-       do j=1,jjm
-          do i=1,iip1
-             pbarvst(i,j,l)=pbarvg(i,j,l)
-          enddo
-       enddo
-       do i=1,iip1
-          pbarvst(i,jjp1,l)=0.
-       enddo
-    enddo
-
-     iadvtr=0
-    write(lunout,*)'ITAU auquel on stoke les fluxmasses',itau
-
-    call histwrite(fluxid, 'masse', itau, massem, &
-          iip1*jjp1*llm, ndex)
-
-    call histwrite(fluxid, 'pbaru', itau, pbarug, &
-          iip1*jjp1*llm, ndex)
-
-    call histwrite(fluxvid, 'pbarv', itau, pbarvg, &
-          iip1*jjm*llm, ndex)
-
-    call histwrite(fluxid, 'w' ,itau, wg, &
-          iip1*jjp1*llm, ndex)
-
-    call histwrite(fluxid, 'teta' ,itau, tetac, &
-          iip1*jjp1*llm, ndex)
-
-    call histwrite(fluxid, 'phi' ,itau, phic, &
-          iip1*jjp1*llm, ndex)
-
-  !
-
-  ENDIF ! if iadvtr.EQ.istdyn
-
-
-
-  RETURN
-END SUBROUTINE fluxstokenc
Index: /LMDZ6/trunk/libf/dyn3d/fluxstokenc.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d/fluxstokenc.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3d/fluxstokenc.f90	(revision 5268)
@@ -0,0 +1,166 @@
+!
+! $Id$
+!
+SUBROUTINE fluxstokenc(pbaru,pbarv,masse,teta,phi,phis, &
+        time_step,itau )
+  ! This routine is designed to work with ioipsl
+
+   USE IOIPSL
+  !
+  ! Auteur :  F. Hourdin
+  !
+  !
+  !cc   ..   Modif. P. Le Van  ( 20/12/97 )  ...
+  !
+  IMPLICIT NONE
+  !
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom.h"
+  include "tracstoke.h"
+  include "iniprint.h"
+
+  REAL :: time_step,t_wrt, t_ops
+  REAL :: pbaru(ip1jmp1,llm),pbarv(ip1jm,llm)
+  REAL :: masse(ip1jmp1,llm),teta(ip1jmp1,llm),phi(ip1jmp1,llm)
+  REAL :: phis(ip1jmp1)
+
+  REAL :: pbaruc(ip1jmp1,llm),pbarvc(ip1jm,llm)
+  REAL :: massem(ip1jmp1,llm),tetac(ip1jmp1,llm),phic(ip1jmp1,llm)
+
+  REAL :: pbarug(ip1jmp1,llm),pbarvg(iip1,jjm,llm),wg(ip1jmp1,llm)
+
+  REAL :: pbarvst(iip1,jjp1,llm),zistdyn
+    real :: dtcum
+
+  INTEGER :: iadvtr,ndex(1)
+  integer :: nscal
+  real :: tst(1),ist(1),istp(1)
+  INTEGER :: ij,l,irec,i,j,itau
+  INTEGER, SAVE :: fluxid, fluxvid,fluxdid
+
+  SAVE iadvtr, massem,pbaruc,pbarvc,irec
+  SAVE phic,tetac
+  logical :: first
+  save first
+  data first/.true./
+  DATA iadvtr/0/
+
+
+  ! AC initialisations
+  pbarug(:,:)   = 0.
+  pbarvg(:,:,:) = 0.
+  wg(:,:)       = 0.
+
+
+  if(first) then
+
+    CALL initfluxsto( 'fluxstoke', &
+          time_step,istdyn* time_step,istdyn* time_step, &
+          fluxid,fluxvid,fluxdid)
+
+    ndex(1) = 0
+    call histwrite(fluxid, 'phis', 1, phis, iip1*jjp1, ndex)
+    call histwrite(fluxid, 'aire', 1, aire, iip1*jjp1, ndex)
+
+    ndex(1) = 0
+    nscal = 1
+    tst(1) = time_step
+    call histwrite(fluxdid, 'dtvr', 1, tst, nscal, ndex)
+    ist(1)=istdyn
+    call histwrite(fluxdid, 'istdyn', 1, ist, nscal, ndex)
+    istp(1)= istphy
+    call histwrite(fluxdid, 'istphy', 1, istp, nscal, ndex)
+
+    first = .false.
+
+  endif
+
+
+  IF(iadvtr.EQ.0) THEN
+     phic(:,:)=0
+     tetac(:,:)=0
+     pbaruc(:,:)=0
+     pbarvc(:,:)=0
+  ENDIF
+
+  !   accumulation des flux de masse horizontaux
+  DO l=1,llm
+     DO ij = 1,ip1jmp1
+        pbaruc(ij,l) = pbaruc(ij,l) + pbaru(ij,l)
+        tetac(ij,l) = tetac(ij,l) + teta(ij,l)
+        phic(ij,l) = phic(ij,l) + phi(ij,l)
+     ENDDO
+     DO ij = 1,ip1jm
+        pbarvc(ij,l) = pbarvc(ij,l) + pbarv(ij,l)
+     ENDDO
+  ENDDO
+
+  !   selection de la masse instantannee des mailles avant le transport.
+  IF(iadvtr.EQ.0) THEN
+     CALL SCOPY(ip1jmp1*llm,masse,1,massem,1)
+  ENDIF
+
+  iadvtr   = iadvtr+1
+
+
+  !   Test pour savoir si on advecte a ce pas de temps
+  IF ( iadvtr.EQ.istdyn ) THEN
+  !    normalisation
+  DO l=1,llm
+     DO ij = 1,ip1jmp1
+        pbaruc(ij,l) = pbaruc(ij,l)/REAL(istdyn)
+        tetac(ij,l) = tetac(ij,l)/REAL(istdyn)
+        phic(ij,l) = phic(ij,l)/REAL(istdyn)
+     ENDDO
+     DO ij = 1,ip1jm
+        pbarvc(ij,l) = pbarvc(ij,l)/REAL(istdyn)
+     ENDDO
+  ENDDO
+
+  !   traitement des flux de masse avant advection.
+  ! 1. calcul de w
+  ! 2. groupement des mailles pres du pole.
+
+    CALL groupe( massem, pbaruc,pbarvc, pbarug,pbarvg,wg )
+
+    do l=1,llm
+       do j=1,jjm
+          do i=1,iip1
+             pbarvst(i,j,l)=pbarvg(i,j,l)
+          enddo
+       enddo
+       do i=1,iip1
+          pbarvst(i,jjp1,l)=0.
+       enddo
+    enddo
+
+     iadvtr=0
+    write(lunout,*)'ITAU auquel on stoke les fluxmasses',itau
+
+    call histwrite(fluxid, 'masse', itau, massem, &
+          iip1*jjp1*llm, ndex)
+
+    call histwrite(fluxid, 'pbaru', itau, pbarug, &
+          iip1*jjp1*llm, ndex)
+
+    call histwrite(fluxvid, 'pbarv', itau, pbarvg, &
+          iip1*jjm*llm, ndex)
+
+    call histwrite(fluxid, 'w' ,itau, wg, &
+          iip1*jjp1*llm, ndex)
+
+    call histwrite(fluxid, 'teta' ,itau, tetac, &
+          iip1*jjp1*llm, ndex)
+
+    call histwrite(fluxid, 'phi' ,itau, phic, &
+          iip1*jjp1*llm, ndex)
+
+  !
+
+  ENDIF ! if iadvtr.EQ.istdyn
+
+
+
+  RETURN
+END SUBROUTINE fluxstokenc
Index: DZ6/trunk/libf/dyn3d/friction.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d/friction.F90	(revision 5267)
+++ 	(revision )
@@ -1,131 +1,0 @@
-!
-! $Id$
-!
-!=======================================================================
-SUBROUTINE friction(ucov,vcov,pdt)
-
-  USE control_mod
-  USE IOIPSL
-
-  USE comconst_mod, ONLY: pi
-  IMPLICIT NONE
-
-  !=======================================================================
-  !
-  !   Friction for the Newtonian case:
-  !   --------------------------------
-  !    2 possibilities (depending on flag 'friction_type'
-  ! friction_type=0 : A friction that is only applied to the lowermost
-  !                   atmospheric layer
-  ! friction_type=1 : Friction applied on all atmospheric layer (but
-  !   (default)       with stronger magnitude near the surface; see
-  !                   iniacademic.F)
-  !=======================================================================
-
-  include "dimensions.h"
-  include "paramet.h"
-  include "comgeom2.h"
-  include "iniprint.h"
-  include "academic.h"
-
-  ! arguments:
-  REAL,INTENT(out) :: ucov( iip1,jjp1,llm )
-  REAL,INTENT(out) :: vcov( iip1,jjm,llm )
-  REAL,INTENT(in) :: pdt ! time step
-
-  ! local variables:
-
-  REAL :: modv(iip1,jjp1),zco,zsi
-  REAL :: vpn,vps,upoln,upols,vpols,vpoln
-  REAL :: u2(iip1,jjp1),v2(iip1,jjm)
-  INTEGER :: i,j,l
-  REAL,PARAMETER :: cfric=1.e-5
-  LOGICAL,SAVE :: firstcall=.true.
-  INTEGER,SAVE :: friction_type=1
-  CHARACTER(len=20) :: modname="friction"
-  CHARACTER(len=80) :: abort_message
-
-  IF (firstcall) THEN
-    ! ! set friction type
-    call getin("friction_type",friction_type)
-    if ((friction_type.lt.0).or.(friction_type.gt.1)) then
-      abort_message="wrong friction type"
-      write(lunout,*)'Friction: wrong friction type',friction_type
-      call abort_gcm(modname,abort_message,42)
-    endif
-    firstcall=.false.
-  ENDIF
-
-  if (friction_type.eq.0) then
-  !   calcul des composantes au carre du vent naturel
-  do j=1,jjp1
-     do i=1,iip1
-        u2(i,j)=ucov(i,j,1)*ucov(i,j,1)*unscu2(i,j)
-     enddo
-  enddo
-  do j=1,jjm
-     do i=1,iip1
-        v2(i,j)=vcov(i,j,1)*vcov(i,j,1)*unscv2(i,j)
-     enddo
-  enddo
-
-  !   calcul du module de V en dehors des poles
-  do j=2,jjm
-     do i=2,iip1
-        modv(i,j)=sqrt(0.5*(u2(i-1,j)+u2(i,j)+v2(i,j-1)+v2(i,j)))
-     enddo
-     modv(1,j)=modv(iip1,j)
-  enddo
-
-  !   les deux composantes du vent au pole sont obtenues comme
-  !   premiers modes de fourier de v pres du pole
-  upoln=0.
-  vpoln=0.
-  upols=0.
-  vpols=0.
-  do i=2,iip1
-     zco=cos(rlonv(i))*(rlonu(i)-rlonu(i-1))
-     zsi=sin(rlonv(i))*(rlonu(i)-rlonu(i-1))
-     vpn=vcov(i,1,1)/cv(i,1)
-     vps=vcov(i,jjm,1)/cv(i,jjm)
-     upoln=upoln+zco*vpn
-     vpoln=vpoln+zsi*vpn
-     upols=upols+zco*vps
-     vpols=vpols+zsi*vps
-  enddo
-  vpn=sqrt(upoln*upoln+vpoln*vpoln)/pi
-  vps=sqrt(upols*upols+vpols*vpols)/pi
-  do i=1,iip1
-     ! modv(i,1)=vpn
-     ! modv(i,jjp1)=vps
-     modv(i,1)=modv(i,2)
-     modv(i,jjp1)=modv(i,jjm)
-  enddo
-
-  !   calcul du frottement au sol.
-  do j=2,jjm
-     do i=1,iim
-        ucov(i,j,1)=ucov(i,j,1) &
-              -cfric*pdt*0.5*(modv(i+1,j)+modv(i,j))*ucov(i,j,1)
-     enddo
-     ucov(iip1,j,1)=ucov(1,j,1)
-  enddo
-  do j=1,jjm
-     do i=1,iip1
-        vcov(i,j,1)=vcov(i,j,1) &
-              -cfric*pdt*0.5*(modv(i,j+1)+modv(i,j))*vcov(i,j,1)
-     enddo
-     vcov(iip1,j,1)=vcov(1,j,1)
-  enddo
-  endif ! of if (friction_type.eq.0)
-
-  if (friction_type.eq.1) then
-    do l=1,llm
-      ucov(:,:,l)=ucov(:,:,l)*(1.-pdt*kfrict(l))
-      vcov(:,:,l)=vcov(:,:,l)*(1.-pdt*kfrict(l))
-    enddo
-  endif
-
-  RETURN
-END SUBROUTINE friction
-
Index: /LMDZ6/trunk/libf/dyn3d/friction.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d/friction.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3d/friction.f90	(revision 5268)
@@ -0,0 +1,131 @@
+!
+! $Id$
+!
+!=======================================================================
+SUBROUTINE friction(ucov,vcov,pdt)
+
+  USE control_mod
+  USE IOIPSL
+
+  USE comconst_mod, ONLY: pi
+  IMPLICIT NONE
+
+  !=======================================================================
+  !
+  !   Friction for the Newtonian case:
+  !   --------------------------------
+  !    2 possibilities (depending on flag 'friction_type'
+  ! friction_type=0 : A friction that is only applied to the lowermost
+  !                   atmospheric layer
+  ! friction_type=1 : Friction applied on all atmospheric layer (but
+  !   (default)       with stronger magnitude near the surface; see
+  !                   iniacademic.F)
+  !=======================================================================
+
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom2.h"
+  include "iniprint.h"
+  include "academic.h"
+
+  ! arguments:
+  REAL,INTENT(out) :: ucov( iip1,jjp1,llm )
+  REAL,INTENT(out) :: vcov( iip1,jjm,llm )
+  REAL,INTENT(in) :: pdt ! time step
+
+  ! local variables:
+
+  REAL :: modv(iip1,jjp1),zco,zsi
+  REAL :: vpn,vps,upoln,upols,vpols,vpoln
+  REAL :: u2(iip1,jjp1),v2(iip1,jjm)
+  INTEGER :: i,j,l
+  REAL,PARAMETER :: cfric=1.e-5
+  LOGICAL,SAVE :: firstcall=.true.
+  INTEGER,SAVE :: friction_type=1
+  CHARACTER(len=20) :: modname="friction"
+  CHARACTER(len=80) :: abort_message
+
+  IF (firstcall) THEN
+    ! ! set friction type
+    call getin("friction_type",friction_type)
+    if ((friction_type.lt.0).or.(friction_type.gt.1)) then
+      abort_message="wrong friction type"
+      write(lunout,*)'Friction: wrong friction type',friction_type
+      call abort_gcm(modname,abort_message,42)
+    endif
+    firstcall=.false.
+  ENDIF
+
+  if (friction_type.eq.0) then
+  !   calcul des composantes au carre du vent naturel
+  do j=1,jjp1
+     do i=1,iip1
+        u2(i,j)=ucov(i,j,1)*ucov(i,j,1)*unscu2(i,j)
+     enddo
+  enddo
+  do j=1,jjm
+     do i=1,iip1
+        v2(i,j)=vcov(i,j,1)*vcov(i,j,1)*unscv2(i,j)
+     enddo
+  enddo
+
+  !   calcul du module de V en dehors des poles
+  do j=2,jjm
+     do i=2,iip1
+        modv(i,j)=sqrt(0.5*(u2(i-1,j)+u2(i,j)+v2(i,j-1)+v2(i,j)))
+     enddo
+     modv(1,j)=modv(iip1,j)
+  enddo
+
+  !   les deux composantes du vent au pole sont obtenues comme
+  !   premiers modes de fourier de v pres du pole
+  upoln=0.
+  vpoln=0.
+  upols=0.
+  vpols=0.
+  do i=2,iip1
+     zco=cos(rlonv(i))*(rlonu(i)-rlonu(i-1))
+     zsi=sin(rlonv(i))*(rlonu(i)-rlonu(i-1))
+     vpn=vcov(i,1,1)/cv(i,1)
+     vps=vcov(i,jjm,1)/cv(i,jjm)
+     upoln=upoln+zco*vpn
+     vpoln=vpoln+zsi*vpn
+     upols=upols+zco*vps
+     vpols=vpols+zsi*vps
+  enddo
+  vpn=sqrt(upoln*upoln+vpoln*vpoln)/pi
+  vps=sqrt(upols*upols+vpols*vpols)/pi
+  do i=1,iip1
+     ! modv(i,1)=vpn
+     ! modv(i,jjp1)=vps
+     modv(i,1)=modv(i,2)
+     modv(i,jjp1)=modv(i,jjm)
+  enddo
+
+  !   calcul du frottement au sol.
+  do j=2,jjm
+     do i=1,iim
+        ucov(i,j,1)=ucov(i,j,1) &
+              -cfric*pdt*0.5*(modv(i+1,j)+modv(i,j))*ucov(i,j,1)
+     enddo
+     ucov(iip1,j,1)=ucov(1,j,1)
+  enddo
+  do j=1,jjm
+     do i=1,iip1
+        vcov(i,j,1)=vcov(i,j,1) &
+              -cfric*pdt*0.5*(modv(i,j+1)+modv(i,j))*vcov(i,j,1)
+     enddo
+     vcov(iip1,j,1)=vcov(1,j,1)
+  enddo
+  endif ! of if (friction_type.eq.0)
+
+  if (friction_type.eq.1) then
+    do l=1,llm
+      ucov(:,:,l)=ucov(:,:,l)*(1.-pdt*kfrict(l))
+      vcov(:,:,l)=vcov(:,:,l)*(1.-pdt*kfrict(l))
+    enddo
+  endif
+
+  RETURN
+END SUBROUTINE friction
+
Index: DZ6/trunk/libf/dyn3d/gcm.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d/gcm.F90	(revision 5267)
+++ 	(revision )
@@ -1,453 +1,0 @@
-!
-! $Id$
-!
-!
-!
-PROGRAM gcm
-
-  USE IOIPSL
-
-
-
-! ug Pour les sorties XIOS
-  USE wxios
-
-  USE filtreg_mod
-  USE infotrac, ONLY: nqtot, init_infotrac
-  USE control_mod
-  USE mod_const_mpi, ONLY: COMM_LMDZ
-  USE temps_mod, ONLY: calend,start_time,annee_ref,day_ref, &
-                     itau_dyn,itau_phy,day_ini,jD_ref,jH_ref,day_end
-  USE comconst_mod, ONLY: cpp, daysec, dtphys, dtvr, g, r, rad
-  USE logic_mod, ONLY: ecripar, iflag_phys, read_start
-  USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_PHYS
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-  ! FH 2008/05/09 On elimine toutes les clefs physiques dans la dynamique
-  ! A nettoyer. On ne veut qu'une ou deux routines d'interface 
-  ! dynamique -> physique pour l'initialisation
-  USE iniphysiq_mod, ONLY: iniphysiq
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-  IMPLICIT NONE
-
-  !      ......   Version  du 10/01/98    ..........
-
-  !             avec  coordonnees  verticales hybrides 
-  !   avec nouveaux operat. dissipation * ( gradiv2,divgrad2,nxgraro2 )
-
-  !=======================================================================
-  !
-  !   Auteur:  P. Le Van /L. Fairhead/F.Hourdin
-  !   -------
-  !
-  !   Objet:
-  !   ------
-  !
-  !   GCM LMD nouvelle grille
-  !
-  !=======================================================================
-  !
-  !  ... Dans inigeom , nouveaux calculs pour les elongations  cu , cv
-  !      et possibilite d'appeler une fonction f(y)  a derivee tangente
-  !      hyperbolique a la  place de la fonction a derivee sinusoidale.
-  !  ... Possibilite de choisir le schema pour l'advection de
-  !        q  , en modifiant iadv dans traceur.def  (MAF,10/02) .
-  !
-  !      Pour Van-Leer + Vapeur d'eau saturee, iadv(1)=4. (F.Codron,10/99)
-  !      Pour Van-Leer iadv=10
-  !
-  !-----------------------------------------------------------------------
-  !   Declarations:
-  !   -------------
-
-  include "dimensions.h"
-  include "paramet.h"
-  include "comdissnew.h"
-  include "comgeom.h"
-  include "description.h"
-  include "iniprint.h"
-  include "tracstoke.h"
-
-  REAL zdtvr
-
-  !   variables dynamiques
-  REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm) ! vents covariants
-  REAL teta(ip1jmp1,llm)                 ! temperature potentielle 
-  REAL, ALLOCATABLE, DIMENSION(:,:,:):: q! champs advectes
-  REAL ps(ip1jmp1)                       ! pression  au sol
-!  REAL p (ip1jmp1,llmp1  )               ! pression aux interfac.des couches
-  REAL masse(ip1jmp1,llm)                ! masse d'air
-  REAL phis(ip1jmp1)                     ! geopotentiel au sol
-!  REAL phi(ip1jmp1,llm)                  ! geopotentiel
-!  REAL w(ip1jmp1,llm)                    ! vitesse verticale
-
-  ! variables dynamiques intermediaire pour le transport
-
-  !   variables pour le fichier histoire
-  REAL dtav      ! intervalle de temps elementaire
-
-  REAL time_0
-
-  LOGICAL lafin
-
-
-  real time_step, t_wrt, t_ops
-
-  !      LOGICAL call_iniphys
-  !      data call_iniphys/.true./
-
-  !+jld variables test conservation energie
-  !      REAL ecin(ip1jmp1,llm),ecin0(ip1jmp1,llm)
-  !     Tendance de la temp. potentiel d (theta)/ d t due a la 
-  !     tansformation d'energie cinetique en energie thermique
-  !     cree par la dissipation
-!  REAL dhecdt(ip1jmp1,llm)
-  !      REAL vcont(ip1jm,llm),ucont(ip1jmp1,llm)
-  !      REAL      d_h_vcol, d_qt, d_qw, d_ql, d_ec
-!  CHARACTER (len=15) :: ztit
-  !-jld 
-
-
-  character (len=80) :: dynhist_file, dynhistave_file
-  character (len=20) :: modname
-  character (len=80) :: abort_message
-  ! locales pour gestion du temps
-  INTEGER :: an, mois, jour
-  REAL :: heure
-  logical use_filtre_fft
-
-  !-----------------------------------------------------------------------
-  !   Initialisations:
-  !   ----------------
-
-  abort_message = 'last timestep reached'
-  modname = 'gcm'
-  descript = 'Run GCM LMDZ'
-  lafin    = .FALSE.
-  dynhist_file = 'dyn_hist.nc'
-  dynhistave_file = 'dyn_hist_ave.nc'
-
-
-
-  !----------------------------------------------------------------------
-  !  lecture des fichiers gcm.def ou run.def
-  !  ---------------------------------------
-  !
-  CALL conf_gcm( 99, .TRUE.)
-
-  if (mod(iphysiq, iperiod) /= 0) call abort_gcm("conf_gcm", &
-       "iphysiq must be a multiple of iperiod", 1)
-
-  use_filtre_fft=.FALSE.
-  CALL getin('use_filtre_fft',use_filtre_fft)
-  IF (use_filtre_fft) call abort_gcm("gcm", 'FFT filter is not available in ' &
-          // 'the sequential version of the dynamics.', 1)
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-  ! Initialisation de XIOS
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-  IF (using_xios) THEN
-    CALL wxios_init("LMDZ")
-  ENDIF
-
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-  ! FH 2008/05/02
-  ! A nettoyer. On ne veut qu'une ou deux routines d'interface 
-  ! dynamique -> physique pour l'initialisation
-!#ifdef CPP_PHYS
-!  CALL Init_Phys_lmdz(iim,jjp1,llm,1,(/(jjm-1)*iim+2/))
-!  !      call InitComgeomphy ! now done in iniphysiq
-!#endif
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-  !-----------------------------------------------------------------------
-  !   Choix du calendrier
-  !   -------------------
-
-  !      calend = 'earth_365d'
-
-  if (calend == 'earth_360d') then
-     call ioconf_calendar('360_day')
-     write(lunout,*)'CALENDRIER CHOISI: Terrestre a 360 jours/an'
-  else if (calend == 'earth_365d') then
-     call ioconf_calendar('noleap')
-     write(lunout,*)'CALENDRIER CHOISI: Terrestre a 365 jours/an'
-  else if (calend == 'gregorian') then
-     call ioconf_calendar('gregorian')
-     write(lunout,*)'CALENDRIER CHOISI: Terrestre bissextile'
-  else
-     abort_message = 'Mauvais choix de calendrier'
-     call abort_gcm(modname,abort_message,1)
-  endif
-
-  !-----------------------------------------------------------------------
-  !
-  !
-  !------------------------------------
-  !   Initialisation partie parallele
-  !------------------------------------
-
-  !
-  !
-  !-----------------------------------------------------------------------
-  !   Initialisation des traceurs
-  !   ---------------------------
-  !  Choix du nombre de traceurs et du schema pour l'advection
-  !  dans fichier traceur.def, par default ou via INCA
-  call init_infotrac
-
-  ! Allocation de la tableau q : champs advectes   
-  allocate(q(ip1jmp1,llm,nqtot))
-
-  !-----------------------------------------------------------------------
-  !   Lecture de l'etat initial :
-  !   ---------------------------
-
-  !  lecture du fichier start.nc
-  if (read_start) then
-     ! we still need to run iniacademic to initialize some
-     ! constants & fields, if we run the 'newtonian' or 'SW' cases:
-     if (iflag_phys.ne.1) then
-        CALL iniacademic(vcov,ucov,teta,q,masse,ps,phis,time_0)
-     endif
-
-     !        if (planet_type.eq."earth") then
-     ! Load an Earth-format start file
-     CALL dynetat0("start.nc",vcov,ucov, &
-          teta,q,masse,ps,phis, time_0)
-     !        endif ! of if (planet_type.eq."earth")
-
-     !       write(73,*) 'ucov',ucov
-     !       write(74,*) 'vcov',vcov
-     !       write(75,*) 'teta',teta
-     !       write(76,*) 'ps',ps
-     !       write(77,*) 'q',q
-
-  endif ! of if (read_start)
-
-
-  ! le cas echeant, creation d un etat initial
-  IF (prt_level > 9) WRITE(lunout,*) &
-       'GCM: AVANT iniacademic AVANT AVANT AVANT AVANT'
-  if (.not.read_start) then
-     start_time=0.
-     annee_ref=anneeref
-     CALL iniacademic(vcov,ucov,teta,q,masse,ps,phis,time_0)
-  endif
-
-
-  !-----------------------------------------------------------------------
-  !   Lecture des parametres de controle pour la simulation :
-  !   -------------------------------------------------------
-  !  on recalcule eventuellement le pas de temps
-
-  IF(MOD(day_step,iperiod).NE.0) THEN
-     abort_message =  &
-          'Il faut choisir un nb de pas par jour multiple de iperiod'
-     call abort_gcm(modname,abort_message,1)
-  ENDIF
-
-  IF(MOD(day_step,iphysiq).NE.0) THEN
-     abort_message =  &
-          'Il faut choisir un nb de pas par jour multiple de iphysiq'
-     call abort_gcm(modname,abort_message,1)
-  ENDIF
-
-  zdtvr    = daysec/REAL(day_step)
-  IF(dtvr.NE.zdtvr) THEN
-     WRITE(lunout,*) &
-          'WARNING!!! changement de pas de temps',dtvr,'>',zdtvr
-  ENDIF
-
-  !
-  ! on remet le calendrier \`a zero si demande
-  !
-  IF (start_time /= starttime) then
-     WRITE(lunout,*)' GCM: Attention l''heure de depart lue dans le' &
-          ,' fichier restart ne correspond pas a celle lue dans le run.def'
-     IF (raz_date == 1) then
-        WRITE(lunout,*)'Je prends l''heure lue dans run.def'
-        start_time = starttime
-     ELSE
-        call abort_gcm("gcm", "'Je m''arrete'", 1)
-     ENDIF
-  ENDIF
-  IF (raz_date == 1) THEN
-     annee_ref = anneeref
-     day_ref = dayref
-     day_ini = dayref
-     itau_dyn = 0
-     itau_phy = 0
-     time_0 = 0.
-     write(lunout,*) &
-          'GCM: On reinitialise a la date lue dans gcm.def'
-  ELSE IF (annee_ref .ne. anneeref .or. day_ref .ne. dayref) THEN
-     write(lunout,*) &
-          'GCM: Attention les dates initiales lues dans le fichier'
-     write(lunout,*) &
-          ' restart ne correspondent pas a celles lues dans '
-     write(lunout,*)' gcm.def'
-     write(lunout,*)' annee_ref=',annee_ref," anneeref=",anneeref
-     write(lunout,*)' day_ref=',day_ref," dayref=",dayref
-     write(lunout,*)' Pas de remise a zero'
-  ENDIF
-
-  !      if (annee_ref .ne. anneeref .or. day_ref .ne. dayref) then
-  !        write(lunout,*)
-  !     .  'GCM: Attention les dates initiales lues dans le fichier'
-  !        write(lunout,*)
-  !     .  ' restart ne correspondent pas a celles lues dans '
-  !        write(lunout,*)' gcm.def'
-  !        write(lunout,*)' annee_ref=',annee_ref," anneeref=",anneeref
-  !        write(lunout,*)' day_ref=',day_ref," dayref=",dayref
-  !        if (raz_date .ne. 1) then
-  !          write(lunout,*)
-  !     .    'GCM: On garde les dates du fichier restart'
-  !        else
-  !          annee_ref = anneeref
-  !          day_ref = dayref
-  !          day_ini = dayref
-  !          itau_dyn = 0
-  !          itau_phy = 0
-  !          time_0 = 0.
-  !          write(lunout,*)
-  !     .   'GCM: On reinitialise a la date lue dans gcm.def'
-  !        endif
-  !      ELSE
-  !        raz_date = 0
-  !      endif
-
-  mois = 1
-  heure = 0.
-  call ymds2ju(annee_ref, mois, day_ref, heure, jD_ref)
-  jH_ref = jD_ref - int(jD_ref)
-  jD_ref = int(jD_ref)
-
-  call ioconf_startdate(INT(jD_ref), jH_ref)
-
-  write(lunout,*)'DEBUG'
-  write(lunout,*)'annee_ref, mois, day_ref, heure, jD_ref'
-  write(lunout,*)annee_ref, mois, day_ref, heure, jD_ref
-  call ju2ymds(jD_ref+jH_ref,an, mois, jour, heure)
-  write(lunout,*)'jD_ref+jH_ref,an, mois, jour, heure'
-  write(lunout,*)jD_ref+jH_ref,an, mois, jour, heure
-
-
-
-  if (iflag_phys.eq.1) then
-     ! these initialisations have already been done (via iniacademic)
-     ! if running in SW or Newtonian mode
-     !-----------------------------------------------------------------------
-     !   Initialisation des constantes dynamiques :
-     !   ------------------------------------------
-     dtvr = zdtvr
-     CALL iniconst
-
-     !-----------------------------------------------------------------------
-     !   Initialisation de la geometrie :
-     !   --------------------------------
-     CALL inigeom
-
-     !-----------------------------------------------------------------------
-     !   Initialisation du filtre :
-     !   --------------------------
-     CALL inifilr
-  endif ! of if (iflag_phys.eq.1)
-  !
-  !-----------------------------------------------------------------------
-  !   Initialisation de la dissipation :
-  !   ----------------------------------
-
-  CALL inidissip( lstardis, nitergdiv, nitergrot, niterh   , &
-       tetagdiv, tetagrot , tetatemp, vert_prof_dissip)
-
-  !  numero de stockage pour les fichiers de redemarrage:
-
-  !-----------------------------------------------------------------------
-  !   Initialisation des I/O :
-  !   ------------------------
-
-
-  if (nday>=0) then
-     day_end = day_ini + nday
-  else
-     day_end = day_ini - nday/day_step
-  endif
-  WRITE(lunout,300)day_ini,day_end
-300 FORMAT('1'/,15x,'run du jour',i7,2x,'au jour',i7//)
-
-  call ju2ymds(jD_ref + day_ini - day_ref, an, mois, jour, heure)
-  write (lunout,301)jour, mois, an
-  call ju2ymds(jD_ref + day_end - day_ref, an, mois, jour, heure)
-  write (lunout,302)jour, mois, an
-301 FORMAT('1'/,15x,'run du ', i2,'/',i2,'/',i4)
-302 FORMAT('1'/,15x,'    au ', i2,'/',i2,'/',i4)
-
-
-  !-----------------------------------------------------------------------
-  !   Initialisation de la physique :
-  !   -------------------------------
-
-  IF ((iflag_phys==1).or.(iflag_phys>=100)) THEN
-    ! Physics:
-    IF (CPPKEY_PHYS) THEN
-      CALL iniphysiq(iim, jjm, llm, &
-              (jjm - 1) * iim + 2, comm_lmdz, &
-              daysec, day_ini, dtphys / nsplit_phys, &
-              rlatu, rlatv, rlonu, rlonv, aire, cu, cv, rad, g, r, cpp, &
-              iflag_phys)
-    END IF
-  ENDIF ! of IF ((iflag_phys==1).or.(iflag_phys>=100))
-
-  !      if (planet_type.eq."earth") then
-  ! Write an Earth-format restart file
-
-  CALL dynredem0("restart.nc", day_end, phis)
-  !      endif
-
-  ecripar = .TRUE.
-
-  time_step = zdtvr
-  if (ok_dyn_ins) then
-     ! initialize output file for instantaneous outputs
-     ! t_ops = iecri * daysec ! do operations every t_ops
-     t_ops =((1.0*iecri)/day_step) * daysec
-     t_wrt = daysec ! iecri * daysec ! write output every t_wrt
-     CALL inithist(day_ref,annee_ref,time_step, &
-          t_ops,t_wrt)
-  endif
-
-  IF (ok_dyn_ave) THEN
-     ! initialize output file for averaged outputs
-     t_ops = iperiod * time_step ! do operations every t_ops
-     t_wrt = periodav * daysec   ! write output every t_wrt
-     CALL initdynav(day_ref,annee_ref,time_step, &
-          t_ops,t_wrt)
-  END IF
-  dtav = iperiod*dtvr/daysec
-
-
-  !  Choix des frequences de stokage pour le offline
-  !      istdyn=day_step/4     ! stockage toutes les 6h=1jour/4
-  !      istdyn=day_step/12     ! stockage toutes les 2h=1jour/12
-  istdyn=day_step/4     ! stockage toutes les 6h=1jour/12
-  istphy=istdyn/iphysiq     
-
-
-  !
-  !-----------------------------------------------------------------------
-  !   Integration temporelle du modele :
-  !   ----------------------------------
-
-  !       write(78,*) 'ucov',ucov
-  !       write(78,*) 'vcov',vcov
-  !       write(78,*) 'teta',teta
-  !       write(78,*) 'ps',ps
-  !       write(78,*) 'q',q
-
-
-  CALL leapfrog(ucov,vcov,teta,ps,masse,phis,q,time_0)
-
-END PROGRAM gcm
Index: /LMDZ6/trunk/libf/dyn3d/gcm.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d/gcm.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3d/gcm.f90	(revision 5268)
@@ -0,0 +1,453 @@
+!
+! $Id$
+!
+!
+!
+PROGRAM gcm
+
+  USE IOIPSL
+
+
+
+! ug Pour les sorties XIOS
+  USE wxios
+
+  USE filtreg_mod
+  USE infotrac, ONLY: nqtot, init_infotrac
+  USE control_mod
+  USE mod_const_mpi, ONLY: COMM_LMDZ
+  USE temps_mod, ONLY: calend,start_time,annee_ref,day_ref, &
+                     itau_dyn,itau_phy,day_ini,jD_ref,jH_ref,day_end
+  USE comconst_mod, ONLY: cpp, daysec, dtphys, dtvr, g, r, rad
+  USE logic_mod, ONLY: ecripar, iflag_phys, read_start
+  USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_PHYS
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+  ! FH 2008/05/09 On elimine toutes les clefs physiques dans la dynamique
+  ! A nettoyer. On ne veut qu'une ou deux routines d'interface 
+  ! dynamique -> physique pour l'initialisation
+  USE iniphysiq_mod, ONLY: iniphysiq
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+  IMPLICIT NONE
+
+  !      ......   Version  du 10/01/98    ..........
+
+  !             avec  coordonnees  verticales hybrides 
+  !   avec nouveaux operat. dissipation * ( gradiv2,divgrad2,nxgraro2 )
+
+  !=======================================================================
+  !
+  !   Auteur:  P. Le Van /L. Fairhead/F.Hourdin
+  !   -------
+  !
+  !   Objet:
+  !   ------
+  !
+  !   GCM LMD nouvelle grille
+  !
+  !=======================================================================
+  !
+  !  ... Dans inigeom , nouveaux calculs pour les elongations  cu , cv
+  !      et possibilite d'appeler une fonction f(y)  a derivee tangente
+  !      hyperbolique a la  place de la fonction a derivee sinusoidale.
+  !  ... Possibilite de choisir le schema pour l'advection de
+  !        q  , en modifiant iadv dans traceur.def  (MAF,10/02) .
+  !
+  !      Pour Van-Leer + Vapeur d'eau saturee, iadv(1)=4. (F.Codron,10/99)
+  !      Pour Van-Leer iadv=10
+  !
+  !-----------------------------------------------------------------------
+  !   Declarations:
+  !   -------------
+
+  include "dimensions.h"
+  include "paramet.h"
+  include "comdissnew.h"
+  include "comgeom.h"
+  include "description.h"
+  include "iniprint.h"
+  include "tracstoke.h"
+
+  REAL zdtvr
+
+  !   variables dynamiques
+  REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm) ! vents covariants
+  REAL teta(ip1jmp1,llm)                 ! temperature potentielle 
+  REAL, ALLOCATABLE, DIMENSION(:,:,:):: q! champs advectes
+  REAL ps(ip1jmp1)                       ! pression  au sol
+!  REAL p (ip1jmp1,llmp1  )               ! pression aux interfac.des couches
+  REAL masse(ip1jmp1,llm)                ! masse d'air
+  REAL phis(ip1jmp1)                     ! geopotentiel au sol
+!  REAL phi(ip1jmp1,llm)                  ! geopotentiel
+!  REAL w(ip1jmp1,llm)                    ! vitesse verticale
+
+  ! variables dynamiques intermediaire pour le transport
+
+  !   variables pour le fichier histoire
+  REAL dtav      ! intervalle de temps elementaire
+
+  REAL time_0
+
+  LOGICAL lafin
+
+
+  real time_step, t_wrt, t_ops
+
+  !      LOGICAL call_iniphys
+  !      data call_iniphys/.true./
+
+  !+jld variables test conservation energie
+  !      REAL ecin(ip1jmp1,llm),ecin0(ip1jmp1,llm)
+  !     Tendance de la temp. potentiel d (theta)/ d t due a la 
+  !     tansformation d'energie cinetique en energie thermique
+  !     cree par la dissipation
+!  REAL dhecdt(ip1jmp1,llm)
+  !      REAL vcont(ip1jm,llm),ucont(ip1jmp1,llm)
+  !      REAL      d_h_vcol, d_qt, d_qw, d_ql, d_ec
+!  CHARACTER (len=15) :: ztit
+  !-jld 
+
+
+  character (len=80) :: dynhist_file, dynhistave_file
+  character (len=20) :: modname
+  character (len=80) :: abort_message
+  ! locales pour gestion du temps
+  INTEGER :: an, mois, jour
+  REAL :: heure
+  logical use_filtre_fft
+
+  !-----------------------------------------------------------------------
+  !   Initialisations:
+  !   ----------------
+
+  abort_message = 'last timestep reached'
+  modname = 'gcm'
+  descript = 'Run GCM LMDZ'
+  lafin    = .FALSE.
+  dynhist_file = 'dyn_hist.nc'
+  dynhistave_file = 'dyn_hist_ave.nc'
+
+
+
+  !----------------------------------------------------------------------
+  !  lecture des fichiers gcm.def ou run.def
+  !  ---------------------------------------
+  !
+  CALL conf_gcm( 99, .TRUE.)
+
+  if (mod(iphysiq, iperiod) /= 0) call abort_gcm("conf_gcm", &
+       "iphysiq must be a multiple of iperiod", 1)
+
+  use_filtre_fft=.FALSE.
+  CALL getin('use_filtre_fft',use_filtre_fft)
+  IF (use_filtre_fft) call abort_gcm("gcm", 'FFT filter is not available in ' &
+          // 'the sequential version of the dynamics.', 1)
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+  ! Initialisation de XIOS
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+  IF (using_xios) THEN
+    CALL wxios_init("LMDZ")
+  ENDIF
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+  ! FH 2008/05/02
+  ! A nettoyer. On ne veut qu'une ou deux routines d'interface 
+  ! dynamique -> physique pour l'initialisation
+!#ifdef CPP_PHYS
+!  CALL Init_Phys_lmdz(iim,jjp1,llm,1,(/(jjm-1)*iim+2/))
+!  !      call InitComgeomphy ! now done in iniphysiq
+!#endif
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+  !-----------------------------------------------------------------------
+  !   Choix du calendrier
+  !   -------------------
+
+  !      calend = 'earth_365d'
+
+  if (calend == 'earth_360d') then
+     call ioconf_calendar('360_day')
+     write(lunout,*)'CALENDRIER CHOISI: Terrestre a 360 jours/an'
+  else if (calend == 'earth_365d') then
+     call ioconf_calendar('noleap')
+     write(lunout,*)'CALENDRIER CHOISI: Terrestre a 365 jours/an'
+  else if (calend == 'gregorian') then
+     call ioconf_calendar('gregorian')
+     write(lunout,*)'CALENDRIER CHOISI: Terrestre bissextile'
+  else
+     abort_message = 'Mauvais choix de calendrier'
+     call abort_gcm(modname,abort_message,1)
+  endif
+
+  !-----------------------------------------------------------------------
+  !
+  !
+  !------------------------------------
+  !   Initialisation partie parallele
+  !------------------------------------
+
+  !
+  !
+  !-----------------------------------------------------------------------
+  !   Initialisation des traceurs
+  !   ---------------------------
+  !  Choix du nombre de traceurs et du schema pour l'advection
+  !  dans fichier traceur.def, par default ou via INCA
+  call init_infotrac
+
+  ! Allocation de la tableau q : champs advectes   
+  allocate(q(ip1jmp1,llm,nqtot))
+
+  !-----------------------------------------------------------------------
+  !   Lecture de l'etat initial :
+  !   ---------------------------
+
+  !  lecture du fichier start.nc
+  if (read_start) then
+     ! we still need to run iniacademic to initialize some
+     ! constants & fields, if we run the 'newtonian' or 'SW' cases:
+     if (iflag_phys.ne.1) then
+        CALL iniacademic(vcov,ucov,teta,q,masse,ps,phis,time_0)
+     endif
+
+     !        if (planet_type.eq."earth") then
+     ! Load an Earth-format start file
+     CALL dynetat0("start.nc",vcov,ucov, &
+          teta,q,masse,ps,phis, time_0)
+     !        endif ! of if (planet_type.eq."earth")
+
+     !       write(73,*) 'ucov',ucov
+     !       write(74,*) 'vcov',vcov
+     !       write(75,*) 'teta',teta
+     !       write(76,*) 'ps',ps
+     !       write(77,*) 'q',q
+
+  endif ! of if (read_start)
+
+
+  ! le cas echeant, creation d un etat initial
+  IF (prt_level > 9) WRITE(lunout,*) &
+       'GCM: AVANT iniacademic AVANT AVANT AVANT AVANT'
+  if (.not.read_start) then
+     start_time=0.
+     annee_ref=anneeref
+     CALL iniacademic(vcov,ucov,teta,q,masse,ps,phis,time_0)
+  endif
+
+
+  !-----------------------------------------------------------------------
+  !   Lecture des parametres de controle pour la simulation :
+  !   -------------------------------------------------------
+  !  on recalcule eventuellement le pas de temps
+
+  IF(MOD(day_step,iperiod).NE.0) THEN
+     abort_message =  &
+          'Il faut choisir un nb de pas par jour multiple de iperiod'
+     call abort_gcm(modname,abort_message,1)
+  ENDIF
+
+  IF(MOD(day_step,iphysiq).NE.0) THEN
+     abort_message =  &
+          'Il faut choisir un nb de pas par jour multiple de iphysiq'
+     call abort_gcm(modname,abort_message,1)
+  ENDIF
+
+  zdtvr    = daysec/REAL(day_step)
+  IF(dtvr.NE.zdtvr) THEN
+     WRITE(lunout,*) &
+          'WARNING!!! changement de pas de temps',dtvr,'>',zdtvr
+  ENDIF
+
+  !
+  ! on remet le calendrier \`a zero si demande
+  !
+  IF (start_time /= starttime) then
+     WRITE(lunout,*)' GCM: Attention l''heure de depart lue dans le' &
+          ,' fichier restart ne correspond pas a celle lue dans le run.def'
+     IF (raz_date == 1) then
+        WRITE(lunout,*)'Je prends l''heure lue dans run.def'
+        start_time = starttime
+     ELSE
+        call abort_gcm("gcm", "'Je m''arrete'", 1)
+     ENDIF
+  ENDIF
+  IF (raz_date == 1) THEN
+     annee_ref = anneeref
+     day_ref = dayref
+     day_ini = dayref
+     itau_dyn = 0
+     itau_phy = 0
+     time_0 = 0.
+     write(lunout,*) &
+          'GCM: On reinitialise a la date lue dans gcm.def'
+  ELSE IF (annee_ref .ne. anneeref .or. day_ref .ne. dayref) THEN
+     write(lunout,*) &
+          'GCM: Attention les dates initiales lues dans le fichier'
+     write(lunout,*) &
+          ' restart ne correspondent pas a celles lues dans '
+     write(lunout,*)' gcm.def'
+     write(lunout,*)' annee_ref=',annee_ref," anneeref=",anneeref
+     write(lunout,*)' day_ref=',day_ref," dayref=",dayref
+     write(lunout,*)' Pas de remise a zero'
+  ENDIF
+
+  !      if (annee_ref .ne. anneeref .or. day_ref .ne. dayref) then
+  !        write(lunout,*)
+  !     .  'GCM: Attention les dates initiales lues dans le fichier'
+  !        write(lunout,*)
+  !     .  ' restart ne correspondent pas a celles lues dans '
+  !        write(lunout,*)' gcm.def'
+  !        write(lunout,*)' annee_ref=',annee_ref," anneeref=",anneeref
+  !        write(lunout,*)' day_ref=',day_ref," dayref=",dayref
+  !        if (raz_date .ne. 1) then
+  !          write(lunout,*)
+  !     .    'GCM: On garde les dates du fichier restart'
+  !        else
+  !          annee_ref = anneeref
+  !          day_ref = dayref
+  !          day_ini = dayref
+  !          itau_dyn = 0
+  !          itau_phy = 0
+  !          time_0 = 0.
+  !          write(lunout,*)
+  !     .   'GCM: On reinitialise a la date lue dans gcm.def'
+  !        endif
+  !      ELSE
+  !        raz_date = 0
+  !      endif
+
+  mois = 1
+  heure = 0.
+  call ymds2ju(annee_ref, mois, day_ref, heure, jD_ref)
+  jH_ref = jD_ref - int(jD_ref)
+  jD_ref = int(jD_ref)
+
+  call ioconf_startdate(INT(jD_ref), jH_ref)
+
+  write(lunout,*)'DEBUG'
+  write(lunout,*)'annee_ref, mois, day_ref, heure, jD_ref'
+  write(lunout,*)annee_ref, mois, day_ref, heure, jD_ref
+  call ju2ymds(jD_ref+jH_ref,an, mois, jour, heure)
+  write(lunout,*)'jD_ref+jH_ref,an, mois, jour, heure'
+  write(lunout,*)jD_ref+jH_ref,an, mois, jour, heure
+
+
+
+  if (iflag_phys.eq.1) then
+     ! these initialisations have already been done (via iniacademic)
+     ! if running in SW or Newtonian mode
+     !-----------------------------------------------------------------------
+     !   Initialisation des constantes dynamiques :
+     !   ------------------------------------------
+     dtvr = zdtvr
+     CALL iniconst
+
+     !-----------------------------------------------------------------------
+     !   Initialisation de la geometrie :
+     !   --------------------------------
+     CALL inigeom
+
+     !-----------------------------------------------------------------------
+     !   Initialisation du filtre :
+     !   --------------------------
+     CALL inifilr
+  endif ! of if (iflag_phys.eq.1)
+  !
+  !-----------------------------------------------------------------------
+  !   Initialisation de la dissipation :
+  !   ----------------------------------
+
+  CALL inidissip( lstardis, nitergdiv, nitergrot, niterh   , &
+       tetagdiv, tetagrot , tetatemp, vert_prof_dissip)
+
+  !  numero de stockage pour les fichiers de redemarrage:
+
+  !-----------------------------------------------------------------------
+  !   Initialisation des I/O :
+  !   ------------------------
+
+
+  if (nday>=0) then
+     day_end = day_ini + nday
+  else
+     day_end = day_ini - nday/day_step
+  endif
+  WRITE(lunout,300)day_ini,day_end
+300 FORMAT('1'/,15x,'run du jour',i7,2x,'au jour',i7//)
+
+  call ju2ymds(jD_ref + day_ini - day_ref, an, mois, jour, heure)
+  write (lunout,301)jour, mois, an
+  call ju2ymds(jD_ref + day_end - day_ref, an, mois, jour, heure)
+  write (lunout,302)jour, mois, an
+301 FORMAT('1'/,15x,'run du ', i2,'/',i2,'/',i4)
+302 FORMAT('1'/,15x,'    au ', i2,'/',i2,'/',i4)
+
+
+  !-----------------------------------------------------------------------
+  !   Initialisation de la physique :
+  !   -------------------------------
+
+  IF ((iflag_phys==1).or.(iflag_phys>=100)) THEN
+    ! Physics:
+    IF (CPPKEY_PHYS) THEN
+      CALL iniphysiq(iim, jjm, llm, &
+              (jjm - 1) * iim + 2, comm_lmdz, &
+              daysec, day_ini, dtphys / nsplit_phys, &
+              rlatu, rlatv, rlonu, rlonv, aire, cu, cv, rad, g, r, cpp, &
+              iflag_phys)
+    END IF
+  ENDIF ! of IF ((iflag_phys==1).or.(iflag_phys>=100))
+
+  !      if (planet_type.eq."earth") then
+  ! Write an Earth-format restart file
+
+  CALL dynredem0("restart.nc", day_end, phis)
+  !      endif
+
+  ecripar = .TRUE.
+
+  time_step = zdtvr
+  if (ok_dyn_ins) then
+     ! initialize output file for instantaneous outputs
+     ! t_ops = iecri * daysec ! do operations every t_ops
+     t_ops =((1.0*iecri)/day_step) * daysec
+     t_wrt = daysec ! iecri * daysec ! write output every t_wrt
+     CALL inithist(day_ref,annee_ref,time_step, &
+          t_ops,t_wrt)
+  endif
+
+  IF (ok_dyn_ave) THEN
+     ! initialize output file for averaged outputs
+     t_ops = iperiod * time_step ! do operations every t_ops
+     t_wrt = periodav * daysec   ! write output every t_wrt
+     CALL initdynav(day_ref,annee_ref,time_step, &
+          t_ops,t_wrt)
+  END IF
+  dtav = iperiod*dtvr/daysec
+
+
+  !  Choix des frequences de stokage pour le offline
+  !      istdyn=day_step/4     ! stockage toutes les 6h=1jour/4
+  !      istdyn=day_step/12     ! stockage toutes les 2h=1jour/12
+  istdyn=day_step/4     ! stockage toutes les 6h=1jour/12
+  istphy=istdyn/iphysiq     
+
+
+  !
+  !-----------------------------------------------------------------------
+  !   Integration temporelle du modele :
+  !   ----------------------------------
+
+  !       write(78,*) 'ucov',ucov
+  !       write(78,*) 'vcov',vcov
+  !       write(78,*) 'teta',teta
+  !       write(78,*) 'ps',ps
+  !       write(78,*) 'q',q
+
+
+  CALL leapfrog(ucov,vcov,teta,ps,masse,phis,q,time_0)
+
+END PROGRAM gcm
Index: DZ6/trunk/libf/dyn3d/getparam.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d/getparam.F90	(revision 5267)
+++ 	(revision )
@@ -1,103 +1,0 @@
-!
-! $Id$
-!
-MODULE getparam
-   USE IOIPSL
-
-
-   INTERFACE getpar
-     MODULE PROCEDURE getparamr,getparami,getparaml
-   END INTERFACE
-   private getparamr,getparami,getparaml
-
-   INTEGER, PARAMETER :: out_eff=99
-
-CONTAINS
-  SUBROUTINE ini_getparam(fichier)
-    !
-    IMPLICIT NONE
-    !
-    CHARACTER*(*) :: fichier
-    open(out_eff,file=fichier,status='unknown',form='formatted') 
-  END SUBROUTINE ini_getparam
-
-  SUBROUTINE fin_getparam
-    !
-    IMPLICIT NONE
-    !
-    close(out_eff)
-
-  END SUBROUTINE fin_getparam
-
-  SUBROUTINE getparamr(TARGET,def_val,ret_val,comment)
-    !
-    IMPLICIT NONE
-    !
-    !   Get a real scalar. We first check if we find it
-    !   in the database and if not we get it from the run.def
-    !
-    !   getinr1d and getinr2d are written on the same pattern
-    !
-    CHARACTER*(*) :: TARGET
-    REAL :: def_val
-    REAL :: ret_val
-    CHARACTER*(*) :: comment
-
-    ret_val=def_val
-    call getin(TARGET,ret_val)
-
-    write(out_eff,*) '######################################'
-    write(out_eff,*) '#### ',comment,' #####'
-    write(out_eff,*) TARGET,'=',ret_val
-
-  END SUBROUTINE getparamr
-
-  SUBROUTINE getparami(TARGET,def_val,ret_val,comment)
-    !
-    IMPLICIT NONE
-    !
-    !   Get a real scalar. We first check if we find it
-    !   in the database and if not we get it from the run.def
-    !
-    !   getinr1d and getinr2d are written on the same pattern
-    !
-    CHARACTER*(*) :: TARGET
-    INTEGER :: def_val
-    INTEGER :: ret_val
-    CHARACTER*(*) :: comment
-
-    ret_val=def_val
-    call getin(TARGET,ret_val)
-
-    write(out_eff,*) '######################################'
-    write(out_eff,*) '#### ',comment,' #####'
-    write(out_eff,*) comment
-    write(out_eff,*) TARGET,'=',ret_val
-
-  END SUBROUTINE getparami
-
-  SUBROUTINE getparaml(TARGET,def_val,ret_val,comment)
-    !
-    IMPLICIT NONE
-    !
-    !   Get a real scalar. We first check if we find it
-    !   in the database and if not we get it from the run.def
-    !
-    !   getinr1d and getinr2d are written on the same pattern
-    !
-    CHARACTER*(*) :: TARGET
-    LOGICAL :: def_val
-    LOGICAL :: ret_val
-    CHARACTER*(*) :: comment
-
-    ret_val=def_val
-    call getin(TARGET,ret_val)
-
-    write(out_eff,*) '######################################'
-    write(out_eff,*) '#### ',comment,' #####'
-    write(out_eff,*) TARGET,'=',ret_val
-
-  END SUBROUTINE getparaml
-
-
-END MODULE getparam
Index: /LMDZ6/trunk/libf/dyn3d/getparam.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d/getparam.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3d/getparam.f90	(revision 5268)
@@ -0,0 +1,103 @@
+!
+! $Id$
+!
+MODULE getparam
+   USE IOIPSL
+
+
+   INTERFACE getpar
+     MODULE PROCEDURE getparamr,getparami,getparaml
+   END INTERFACE
+   private getparamr,getparami,getparaml
+
+   INTEGER, PARAMETER :: out_eff=99
+
+CONTAINS
+  SUBROUTINE ini_getparam(fichier)
+    !
+    IMPLICIT NONE
+    !
+    CHARACTER*(*) :: fichier
+    open(out_eff,file=fichier,status='unknown',form='formatted') 
+  END SUBROUTINE ini_getparam
+
+  SUBROUTINE fin_getparam
+    !
+    IMPLICIT NONE
+    !
+    close(out_eff)
+
+  END SUBROUTINE fin_getparam
+
+  SUBROUTINE getparamr(TARGET,def_val,ret_val,comment)
+    !
+    IMPLICIT NONE
+    !
+    !   Get a real scalar. We first check if we find it
+    !   in the database and if not we get it from the run.def
+    !
+    !   getinr1d and getinr2d are written on the same pattern
+    !
+    CHARACTER*(*) :: TARGET
+    REAL :: def_val
+    REAL :: ret_val
+    CHARACTER*(*) :: comment
+
+    ret_val=def_val
+    call getin(TARGET,ret_val)
+
+    write(out_eff,*) '######################################'
+    write(out_eff,*) '#### ',comment,' #####'
+    write(out_eff,*) TARGET,'=',ret_val
+
+  END SUBROUTINE getparamr
+
+  SUBROUTINE getparami(TARGET,def_val,ret_val,comment)
+    !
+    IMPLICIT NONE
+    !
+    !   Get a real scalar. We first check if we find it
+    !   in the database and if not we get it from the run.def
+    !
+    !   getinr1d and getinr2d are written on the same pattern
+    !
+    CHARACTER*(*) :: TARGET
+    INTEGER :: def_val
+    INTEGER :: ret_val
+    CHARACTER*(*) :: comment
+
+    ret_val=def_val
+    call getin(TARGET,ret_val)
+
+    write(out_eff,*) '######################################'
+    write(out_eff,*) '#### ',comment,' #####'
+    write(out_eff,*) comment
+    write(out_eff,*) TARGET,'=',ret_val
+
+  END SUBROUTINE getparami
+
+  SUBROUTINE getparaml(TARGET,def_val,ret_val,comment)
+    !
+    IMPLICIT NONE
+    !
+    !   Get a real scalar. We first check if we find it
+    !   in the database and if not we get it from the run.def
+    !
+    !   getinr1d and getinr2d are written on the same pattern
+    !
+    CHARACTER*(*) :: TARGET
+    LOGICAL :: def_val
+    LOGICAL :: ret_val
+    CHARACTER*(*) :: comment
+
+    ret_val=def_val
+    call getin(TARGET,ret_val)
+
+    write(out_eff,*) '######################################'
+    write(out_eff,*) '#### ',comment,' #####'
+    write(out_eff,*) TARGET,'=',ret_val
+
+  END SUBROUTINE getparaml
+
+
+END MODULE getparam
Index: DZ6/trunk/libf/dyn3d/guide_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d/guide_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,1827 +1,0 @@
-!
-! $Id$
-!
-MODULE guide_mod
-
-!=======================================================================
-!   Auteur:  F.Hourdin
-!            F. Codron 01/09
-!=======================================================================
-
-  USE getparam, only: ini_getparam, fin_getparam, getpar
-  USE Write_Field
-  use netcdf, only: nf90_nowrite, nf90_open, nf90_inq_varid, nf90_close, &
-                    nf90_inq_dimid, nf90_inquire_dimension
-  use pres2lev_mod, only: pres2lev
-
-  IMPLICIT NONE
-
-! ---------------------------------------------
-! Declarations des cles logiques et parametres 
-! ---------------------------------------------
-  INTEGER, PRIVATE, SAVE  :: iguide_read,iguide_int,iguide_sav
-  INTEGER, PRIVATE, SAVE  :: nlevnc, guide_plevs
-  LOGICAL, PRIVATE, SAVE  :: guide_u,guide_v,guide_T,guide_Q,guide_P
-  LOGICAL, PRIVATE, SAVE  :: guide_hr,guide_teta  
-  LOGICAL, PRIVATE, SAVE  :: guide_BL,guide_reg,guide_add,gamma4,guide_zon 
-  LOGICAL, PRIVATE, SAVE  :: invert_p,invert_y,ini_anal
-  LOGICAL, PRIVATE, SAVE  :: guide_2D,guide_sav,guide_modele
-!FC
-  LOGICAL, PRIVATE, SAVE  :: convert_Pa
-  
-  REAL, PRIVATE, SAVE     :: tau_min_u,tau_max_u
-  REAL, PRIVATE, SAVE     :: tau_min_v,tau_max_v
-  REAL, PRIVATE, SAVE     :: tau_min_T,tau_max_T
-  REAL, PRIVATE, SAVE     :: tau_min_Q,tau_max_Q
-  REAL, PRIVATE, SAVE     :: tau_min_P,tau_max_P
-
-  REAL, PRIVATE, SAVE     :: lat_min_g,lat_max_g
-  REAL, PRIVATE, SAVE     :: lon_min_g,lon_max_g
-  REAL, PRIVATE, SAVE     :: tau_lon,tau_lat
-
-  REAL, PRIVATE, SAVE     :: plim_guide_BL
-
-  REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE     :: alpha_u,alpha_v 
-  REAL, ALLOCATABLE, DIMENSION(:, :), PRIVATE, SAVE     :: alpha_T,alpha_Q 
-  REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE     :: alpha_P,alpha_pcor
-  
-! ---------------------------------------------
-! Variables de guidage
-! ---------------------------------------------
-! Variables des fichiers de guidage
-  REAL, ALLOCATABLE, DIMENSION(:,:,:), PRIVATE, SAVE   :: unat1,unat2
-  REAL, ALLOCATABLE, DIMENSION(:,:,:), PRIVATE, SAVE   :: vnat1,vnat2
-  REAL, ALLOCATABLE, DIMENSION(:,:,:), PRIVATE, SAVE   :: tnat1,tnat2
-  REAL, ALLOCATABLE, DIMENSION(:,:,:), PRIVATE, SAVE   :: qnat1,qnat2
-  REAL, ALLOCATABLE, DIMENSION(:,:,:), PRIVATE, SAVE   :: pnat1,pnat2
-  REAL, ALLOCATABLE, DIMENSION(:,:),   PRIVATE, SAVE   :: psnat1,psnat2
-  REAL, ALLOCATABLE, DIMENSION(:),     PRIVATE, SAVE   :: apnc,bpnc
-! Variables aux dimensions du modele
-  REAL, ALLOCATABLE, DIMENSION(:,:),   PRIVATE, SAVE   :: ugui1,ugui2
-  REAL, ALLOCATABLE, DIMENSION(:,:),   PRIVATE, SAVE   :: vgui1,vgui2
-  REAL, ALLOCATABLE, DIMENSION(:,:),   PRIVATE, SAVE   :: tgui1,tgui2
-  REAL, ALLOCATABLE, DIMENSION(:,:),   PRIVATE, SAVE   :: qgui1,qgui2
-  REAL, ALLOCATABLE, DIMENSION(:),   PRIVATE, SAVE   :: psgui1,psgui2
-
-CONTAINS
-!=======================================================================
-
-  SUBROUTINE guide_init
-
-    use netcdf, only: nf90_noerr
-    USE control_mod, ONLY: day_step
-    USE serre_mod, ONLY: grossismx
-
-    IMPLICIT NONE
-  
-    INCLUDE "dimensions.h"
-    INCLUDE "paramet.h"
-    INCLUDE "netcdf.inc"
-
-    INTEGER                :: error,ncidpl,rid,rcod
-    CHARACTER (len = 80)   :: abort_message
-    CHARACTER (len = 20)   :: modname = 'guide_init'
-    CHARACTER (len = 20)   :: namedim
-
-! ---------------------------------------------
-! Lecture des parametres:  
-! ---------------------------------------------
-    call ini_getparam("nudging_parameters_out.txt")
-! Variables guidees
-    CALL getpar('guide_u',.true.,guide_u,'guidage de u')
-    CALL getpar('guide_v',.true.,guide_v,'guidage de v')
-    CALL getpar('guide_T',.true.,guide_T,'guidage de T')
-    CALL getpar('guide_P',.true.,guide_P,'guidage de P')
-    CALL getpar('guide_Q',.true.,guide_Q,'guidage de Q')
-    CALL getpar('guide_hr',.true.,guide_hr,'guidage de Q par H.R')
-    CALL getpar('guide_teta',.false.,guide_teta,'guidage de T par Teta')
-
-    CALL getpar('guide_add',.false.,guide_add,'for�age constant?')
-    CALL getpar('guide_zon',.false.,guide_zon,'guidage moy zonale')
-    if (guide_zon .and. abs(grossismx - 1.) > 0.01) &
-         call abort_gcm("guide_init", &
-         "zonal nudging requires grid regular in longitude", 1)
-
-!   Constantes de rappel. Unite : fraction de jour
-    CALL getpar('tau_min_u',0.02,tau_min_u,'Cste de rappel min, u')
-    CALL getpar('tau_max_u', 10.,tau_max_u,'Cste de rappel max, u')
-    CALL getpar('tau_min_v',0.02,tau_min_v,'Cste de rappel min, v')
-    CALL getpar('tau_max_v', 10.,tau_max_v,'Cste de rappel max, v')
-    CALL getpar('tau_min_T',0.02,tau_min_T,'Cste de rappel min, T')
-    CALL getpar('tau_max_T', 10.,tau_max_T,'Cste de rappel max, T')
-    CALL getpar('tau_min_Q',0.02,tau_min_Q,'Cste de rappel min, Q')
-    CALL getpar('tau_max_Q', 10.,tau_max_Q,'Cste de rappel max, Q')
-    CALL getpar('tau_min_P',0.02,tau_min_P,'Cste de rappel min, P')
-    CALL getpar('tau_max_P', 10.,tau_max_P,'Cste de rappel max, P')
-    CALL getpar('gamma4',.false.,gamma4,'Zone sans rappel elargie')
-    CALL getpar('guide_BL',.true.,guide_BL,'guidage dans C.Lim')
-    CALL getpar('plim_guide_BL',85000.,plim_guide_BL,'BL top presnivs value')
-
-
-! Sauvegarde du for�age
-    CALL getpar('guide_sav',.false.,guide_sav,'sauvegarde guidage')
-    CALL getpar('iguide_sav',4,iguide_sav,'freq. sauvegarde guidage')
-    ! frequences f>0: fx/jour; f<0: tous les f jours; f=0: 1 seule fois.
-    IF (iguide_sav.GT.0) THEN
-       iguide_sav=day_step/iguide_sav
-    ELSE if (iguide_sav == 0) then
-       iguide_sav = huge(0)
-    ELSE
-       iguide_sav=day_step*iguide_sav
-    ENDIF
-
-! Guidage regional seulement (sinon constant ou suivant le zoom)
-    CALL getpar('guide_reg',.false.,guide_reg,'guidage regional')
-    CALL getpar('lat_min_g',-90.,lat_min_g,'Latitude mini guidage ')
-    CALL getpar('lat_max_g', 90.,lat_max_g,'Latitude maxi guidage ')
-    CALL getpar('lon_min_g',-180.,lon_min_g,'longitude mini guidage ')
-    CALL getpar('lon_max_g', 180.,lon_max_g,'longitude maxi guidage ')
-    CALL getpar('tau_lat', 5.,tau_lat,'raideur lat guide regional ')
-    CALL getpar('tau_lon', 5.,tau_lon,'raideur lon guide regional ')
-
-! Parametres pour lecture des fichiers
-    CALL getpar('iguide_read',4,iguide_read,'freq. lecture guidage')
-    CALL getpar('iguide_int',4,iguide_int,'freq. interpolation vert')
-    IF (iguide_int.EQ.0) THEN
-        iguide_int=1
-    ELSEIF (iguide_int.GT.0) THEN
-        iguide_int=day_step/iguide_int
-    ELSE
-        iguide_int=day_step*iguide_int
-    ENDIF
-    CALL getpar('guide_plevs',0,guide_plevs,'niveaux pression fichiers guidage')
-    ! Pour compatibilite avec ancienne version avec guide_modele
-    CALL getpar('guide_modele',.false.,guide_modele,'niveaux pression ap+bp*psol')
-    IF (guide_modele) THEN
-        guide_plevs=1
-    ENDIF
-!FC
-    CALL getpar('convert_Pa',.true.,convert_Pa,'Convert Pressure levels in Pa')
-    ! Fin raccord
-    CALL getpar('ini_anal',.false.,ini_anal,'Etat initial = analyse')
-    CALL getpar('guide_invertp',.true.,invert_p,'niveaux p inverses')
-    CALL getpar('guide_inverty',.true.,invert_y,'inversion N-S')
-    CALL getpar('guide_2D',.false.,guide_2D,'fichier guidage lat-P')
-
-    call fin_getparam
-    
-! ---------------------------------------------
-! Determination du nombre de niveaux verticaux
-! des fichiers guidage
-! ---------------------------------------------
-    ncidpl=-99
-    if (guide_plevs.EQ.1) then
-       if (ncidpl.eq.-99) then
-          rcod=nf90_open('apbp.nc',Nf90_NOWRITe, ncidpl)
-          if (rcod.NE.NF90_NOERR) THEN
-             abort_message=' Nudging error -> no file apbp.nc'
-             CALL abort_gcm(modname,abort_message,1)
-          endif
-       endif
-    elseif (guide_plevs.EQ.2) then
-       if (ncidpl.EQ.-99) then
-          rcod=nf90_open('P.nc',Nf90_NOWRITe,ncidpl)
-          if (rcod.NE.NF90_NOERR) THEN
-             abort_message=' Nudging error -> no file P.nc'
-             CALL abort_gcm(modname,abort_message,1)
-          endif
-       endif
-
-    elseif (guide_u) then
-           if (ncidpl.eq.-99) then
-               rcod=nf90_open('u.nc',Nf90_NOWRITe,ncidpl)
-               if (rcod.NE.NF90_NOERR) THEN
-                  CALL abort_gcm(modname, &
-                       ' Nudging error -> no file u.nc',1)
-               endif
-           endif
-
-    elseif (guide_v) then
-           if (ncidpl.eq.-99) then
-               rcod=nf90_open('v.nc',nf90_nowrite,ncidpl)
-               if (rcod.NE.NF90_NOERR) THEN
-                  CALL abort_gcm(modname, &
-                       ' Nudging error -> no file v.nc',1)
-               endif
-           endif
-    elseif (guide_T) then
-           if (ncidpl.eq.-99) then
-               rcod=nf90_open('T.nc',nf90_nowrite,ncidpl)
-               if (rcod.NE.NF90_NOERR) THEN
-                  CALL abort_gcm(modname, &
-                       ' Nudging error -> no file T.nc',1)
-               endif
-           endif
-    elseif (guide_Q) then
-           if (ncidpl.eq.-99) then
-               rcod=nf90_open('hur.nc',nf90_nowrite, ncidpl)
-               if (rcod.NE.NF90_NOERR) THEN
-                  CALL abort_gcm(modname, &
-                       ' Nudging error -> no file hur.nc',1)
-               endif
-           endif
-
-
-    endif 
-    error=NF_INQ_DIMID(ncidpl,'LEVEL',rid)
-    IF (error.NE.NF90_NOERR) error=NF_INQ_DIMID(ncidpl,'PRESSURE',rid)
-    IF (error.NE.NF90_NOERR) THEN
-        CALL abort_gcm(modname,'Nudging: error reading pressure levels',1)
-    ENDIF
-    error=NF_INQ_DIMLEN(ncidpl,rid,nlevnc)
-    write(*,*)trim(modname)//' : number of vertical levels nlevnc', nlevnc 
-    rcod = nf90_close(ncidpl)
-
-! ---------------------------------------------
-! Allocation des variables
-! ---------------------------------------------
-    abort_message='nudging allocation error'
-
-    ALLOCATE(apnc(nlevnc), stat = error)
-    IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
-    ALLOCATE(bpnc(nlevnc), stat = error)
-    IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
-    apnc=0.;bpnc=0.
-
-    ALLOCATE(alpha_pcor(llm), stat = error)
-    IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
-    ALLOCATE(alpha_u(ip1jmp1), stat = error)
-    IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
-    ALLOCATE(alpha_v(ip1jm), stat = error)
-    IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
-    ALLOCATE(alpha_T(iip1, jjp1), stat = error)
-    IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
-    ALLOCATE(alpha_Q(iip1, jjp1), stat = error)
-    IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
-    ALLOCATE(alpha_P(ip1jmp1), stat = error)
-    IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
-    alpha_u=0.;alpha_v=0;alpha_T=0;alpha_Q=0;alpha_P=0
-    
-    IF (guide_u) THEN
-        ALLOCATE(unat1(iip1,jjp1,nlevnc), stat = error)
-        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
-        ALLOCATE(ugui1(ip1jmp1,llm), stat = error)
-        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
-        ALLOCATE(unat2(iip1,jjp1,nlevnc), stat = error)
-        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
-        ALLOCATE(ugui2(ip1jmp1,llm), stat = error)
-        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
-        unat1=0.;unat2=0.;ugui1=0.;ugui2=0.
-    ENDIF
-
-    IF (guide_T) THEN
-        ALLOCATE(tnat1(iip1,jjp1,nlevnc), stat = error)
-        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
-        ALLOCATE(tgui1(ip1jmp1,llm), stat = error)
-        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
-        ALLOCATE(tnat2(iip1,jjp1,nlevnc), stat = error)
-        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
-        ALLOCATE(tgui2(ip1jmp1,llm), stat = error)
-        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
-        tnat1=0.;tnat2=0.;tgui1=0.;tgui2=0.
-    ENDIF
-     
-    IF (guide_Q) THEN
-        ALLOCATE(qnat1(iip1,jjp1,nlevnc), stat = error)
-        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
-        ALLOCATE(qgui1(ip1jmp1,llm), stat = error)
-        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
-        ALLOCATE(qnat2(iip1,jjp1,nlevnc), stat = error)
-        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
-        ALLOCATE(qgui2(ip1jmp1,llm), stat = error)
-        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
-        qnat1=0.;qnat2=0.;qgui1=0.;qgui2=0.
-    ENDIF
-
-    IF (guide_v) THEN
-        ALLOCATE(vnat1(iip1,jjm,nlevnc), stat = error)
-        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
-        ALLOCATE(vgui1(ip1jm,llm), stat = error)
-        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
-        ALLOCATE(vnat2(iip1,jjm,nlevnc), stat = error)
-        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
-        ALLOCATE(vgui2(ip1jm,llm), stat = error)
-        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
-        vnat1=0.;vnat2=0.;vgui1=0.;vgui2=0.
-    ENDIF
-
-    IF (guide_plevs.EQ.2) THEN
-        ALLOCATE(pnat1(iip1,jjp1,nlevnc), stat = error)
-        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
-        ALLOCATE(pnat2(iip1,jjp1,nlevnc), stat = error)
-        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
-        pnat1=0.;pnat2=0.;
-    ENDIF
-
-    IF (guide_P.OR.guide_plevs.EQ.1) THEN
-        ALLOCATE(psnat1(iip1,jjp1), stat = error)
-        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
-        ALLOCATE(psnat2(iip1,jjp1), stat = error)
-        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
-        psnat1=0.;psnat2=0.;
-    ENDIF
-    IF (guide_P) THEN
-        ALLOCATE(psgui2(ip1jmp1), stat = error)
-        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
-        ALLOCATE(psgui1(ip1jmp1), stat = error)
-        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
-        psgui1=0.;psgui2=0.
-    ENDIF
-
-! ---------------------------------------------
-!   Lecture du premier etat de guidage.
-! ---------------------------------------------
-    IF (guide_2D) THEN
-        CALL guide_read2D(1)
-    ELSE
-        CALL guide_read(1)
-    ENDIF
-    IF (guide_v) vnat1=vnat2
-    IF (guide_u) unat1=unat2
-    IF (guide_T) tnat1=tnat2
-    IF (guide_Q) qnat1=qnat2
-    IF (guide_plevs.EQ.2) pnat1=pnat2
-    IF (guide_P.OR.guide_plevs.EQ.1) psnat1=psnat2
-
-  END SUBROUTINE guide_init
-
-!=======================================================================
-  SUBROUTINE guide_main(itau,ucov,vcov,teta,q,masse,ps)
-
-    USE exner_hyb_m, ONLY: exner_hyb
-    USE exner_milieu_m, ONLY: exner_milieu
-    USE control_mod, ONLY: day_step, iperiod
-    USE comconst_mod, ONLY: cpp, dtvr, daysec,kappa
-    USE comvert_mod, ONLY: ap, bp, preff, presnivs, pressure_exner
- 
-    IMPLICIT NONE
-  
-    INCLUDE "dimensions.h"
-    INCLUDE "paramet.h"
-    INCLUDE "iniprint.h"
-
-
-    ! Variables entree
-    INTEGER,                       INTENT(IN)    :: itau !pas de temps
-    REAL, DIMENSION (ip1jmp1,llm), INTENT(INOUT) :: ucov,teta,q,masse
-    REAL, DIMENSION (ip1jm,llm),   INTENT(INOUT) :: vcov
-    REAL, DIMENSION (ip1jmp1),     INTENT(INOUT) :: ps
-
-    ! Variables locales
-    LOGICAL, SAVE :: first=.TRUE.
-    LOGICAL       :: f_out ! sortie guidage
-    REAL, DIMENSION (ip1jmp1,llm) :: f_add ! var aux: champ de guidage
-    REAL :: pk(ip1jmp1,llm) ! Exner at mid-layers
-    REAL :: pks(ip1jmp1) ! Exner at the surface
-    REAL :: unskap ! 1./kappa
-    REAL, DIMENSION (ip1jmp1,llmp1) :: p ! Pressure at inter-layers
-    ! Compteurs temps:
-    INTEGER, SAVE :: step_rea,count_no_rea,itau_test ! lecture guidage
-    REAL          :: ditau, dday_step
-    REAL          :: tau,reste ! position entre 2 etats de guidage
-    REAL, SAVE    :: factt ! pas de temps en fraction de jour
-    
-    INTEGER       :: l
-    CHARACTER(LEN=20) :: modname="guide_main"
-    CHARACTER (len = 80)   :: abort_message
-
-
-!-----------------------------------------------------------------------
-! Initialisations au premier passage
-!-----------------------------------------------------------------------
-    IF (first) THEN
-        first=.FALSE.
-        CALL guide_init 
-        itau_test=1001
-        step_rea=1
-        count_no_rea=0
-! Calcul des constantes de rappel
-        factt=dtvr*iperiod/daysec 
-        call tau2alpha(3,iip1,jjm ,factt,tau_min_v,tau_max_v,alpha_v)
-        call tau2alpha(2,iip1,jjp1,factt,tau_min_u,tau_max_u,alpha_u)
-        call tau2alpha(1,iip1,jjp1,factt,tau_min_T,tau_max_T,alpha_T)
-        call tau2alpha(1,iip1,jjp1,factt,tau_min_P,tau_max_P,alpha_P)
-        call tau2alpha(1,iip1,jjp1,factt,tau_min_Q,tau_max_Q,alpha_Q)
-! correction de rappel dans couche limite
-        if (guide_BL) then
-             alpha_pcor(:)=1.
-        else
-            do l=1,llm
-               alpha_pcor(l)=(1.+tanh(((plim_guide_BL-presnivs(l))/preff)/0.05))/2.
-            enddo
-        endif
-! ini_anal: etat initial egal au guidage        
-        IF (ini_anal) THEN
-            CALL guide_interp(ps,teta)
-            IF (guide_u) ucov=ugui2
-            IF (guide_v) vcov=ugui2
-            IF (guide_T) teta=tgui2
-            IF (guide_Q) q=qgui2
-            IF (guide_P) THEN
-                ps=psgui2
-                CALL pression(ip1jmp1,ap,bp,ps,p)
-                CALL massdair(p,masse)
-            ENDIF
-            RETURN
-        ENDIF
-! Verification structure guidage
-!        IF (guide_u) THEN
-!            CALL writefield('unat',unat1)
-!            CALL writefield('ucov',RESHAPE(ucov,(/iip1,jjp1,llm/)))
-!        ENDIF
-!        IF (guide_T) THEN
-!            CALL writefield('tnat',tnat1)
-!            CALL writefield('teta',RESHAPE(teta,(/iip1,jjp1,llm/)))
-!        ENDIF
-
-    ENDIF !first
-
-!-----------------------------------------------------------------------
-! Lecture des fichiers de guidage ?
-!-----------------------------------------------------------------------
-    IF (iguide_read.NE.0) THEN
-      ditau=real(itau)
-      dday_step=real(day_step)
-      IF (iguide_read.LT.0) THEN
-          tau=ditau/dday_step/REAL(iguide_read)
-      ELSE
-          tau=REAL(iguide_read)*ditau/dday_step
-      ENDIF
-      reste=tau-AINT(tau)
-      IF (reste.EQ.0.) THEN
-          IF (itau_test.EQ.itau) THEN
-            write(lunout,*)trim(modname)//' second pass in advreel at itau=',&
-            itau
-              abort_message='stopped'
-              CALL abort_gcm(modname,abort_message,1) 
-          ELSE
-              IF (guide_v) vnat1=vnat2
-              IF (guide_u) unat1=unat2
-              IF (guide_T) tnat1=tnat2
-              IF (guide_Q) qnat1=qnat2
-              IF (guide_plevs.EQ.2) pnat1=pnat2
-              IF (guide_P.OR.guide_plevs.EQ.1) psnat1=psnat2
-              step_rea=step_rea+1
-              itau_test=itau
-              write(*,*)trim(modname)//' Reading nudging files, step ',&
-                     step_rea,'after ',count_no_rea,' skips'
-              IF (guide_2D) THEN
-                  CALL guide_read2D(step_rea)
-              ELSE
-                  CALL guide_read(step_rea)
-              ENDIF
-              count_no_rea=0
-          ENDIF
-      ELSE
-        count_no_rea=count_no_rea+1
-
-      ENDIF
-    ENDIF !iguide_read=0
-
-!-----------------------------------------------------------------------
-! Interpolation et conversion des champs de guidage
-!-----------------------------------------------------------------------
-    IF (MOD(itau,iguide_int).EQ.0) THEN
-        CALL guide_interp(ps,teta)
-    ENDIF
-! Repartition entre 2 etats de guidage
-    IF (iguide_read.NE.0) THEN
-        tau=reste
-    ELSE
-        tau=1.
-    ENDIF
-
-!-----------------------------------------------------------------------
-!   Ajout des champs de guidage 
-!-----------------------------------------------------------------------
-! Sauvegarde du guidage?
-    f_out=((MOD(itau,iguide_sav).EQ.0).AND.guide_sav)  
-    IF (f_out) THEN
-      ! compute pressures at layer interfaces
-      CALL pression(ip1jmp1,ap,bp,ps,p)
-      if (pressure_exner) then
-        call exner_hyb(ip1jmp1,ps,p,pks,pk)
-      else
-        call exner_milieu(ip1jmp1,ps,p,pks,pk)
-      endif
-      unskap=1./kappa
-      ! Now compute pressures at mid-layer
-      do l=1,llm
-        p(:,l)=preff*(pk(:,l)/cpp)**unskap
-      enddo
-      CALL guide_out("SP",jjp1,llm,p(:,1:llm))
-    ENDIF
-    
-    if (guide_u) then
-        if (guide_add) then
-           f_add=(1.-tau)*ugui1+tau*ugui2
-        else
-           f_add=(1.-tau)*ugui1+tau*ugui2-ucov
-        endif 
-        if (guide_zon) CALL guide_zonave(1,jjp1,llm,f_add)
-        CALL guide_addfield(ip1jmp1,llm,f_add,alpha_u)
-        IF (f_out) CALL guide_out("ua",jjp1,llm,(1.-tau)*ugui1+tau*ugui2)
-        IF (f_out) CALL guide_out("u",jjp1,llm,ucov)
-        IF (f_out) CALL guide_out("ucov",jjp1,llm,f_add/factt)
-        ucov=ucov+f_add
-    endif
-
-    if (guide_T) then
-        if (guide_add) then
-           f_add=(1.-tau)*tgui1+tau*tgui2
-        else
-           f_add=(1.-tau)*tgui1+tau*tgui2-teta
-        endif 
-        if (guide_zon) CALL guide_zonave(2,jjp1,llm,f_add)
-        CALL guide_addfield(ip1jmp1,llm,f_add,alpha_T)
-        IF (f_out) CALL guide_out("teta",jjp1,llm,f_add/factt)
-        teta=teta+f_add
-    endif
-
-    if (guide_P) then
-        if (guide_add) then
-           f_add(1:ip1jmp1,1)=(1.-tau)*psgui1+tau*psgui2
-        else
-           f_add(1:ip1jmp1,1)=(1.-tau)*psgui1+tau*psgui2-ps
-        endif 
-        if (guide_zon) CALL guide_zonave(2,jjp1,1,f_add(1:ip1jmp1,1))
-        CALL guide_addfield(ip1jmp1,1,f_add(1:ip1jmp1,1),alpha_P)
-!        IF (f_out) CALL guide_out("ps",jjp1,1,f_add(1:ip1jmp1,1)/factt)
-        ps=ps+f_add(1:ip1jmp1,1)
-        CALL pression(ip1jmp1,ap,bp,ps,p)
-        CALL massdair(p,masse)
-    endif
-
-    if (guide_Q) then
-        if (guide_add) then
-           f_add=(1.-tau)*qgui1+tau*qgui2
-        else
-           f_add=(1.-tau)*qgui1+tau*qgui2-q
-        endif 
-        if (guide_zon) CALL guide_zonave(2,jjp1,llm,f_add)
-        CALL guide_addfield(ip1jmp1,llm,f_add,alpha_Q)
-        IF (f_out) CALL guide_out("q",jjp1,llm,f_add/factt)
-        q=q+f_add
-    endif
-
-    if (guide_v) then
-        if (guide_add) then
-           f_add(1:ip1jm,:)=(1.-tau)*vgui1+tau*vgui2
-        else
-           f_add(1:ip1jm,:)=(1.-tau)*vgui1+tau*vgui2-vcov
-        endif 
-        if (guide_zon) CALL guide_zonave(2,jjm,llm,f_add(1:ip1jm,:))
-        CALL guide_addfield(ip1jm,llm,f_add(1:ip1jm,:),alpha_v)
-        IF (f_out) CALL guide_out("v",jjm,llm,vcov)
-        IF (f_out) CALL guide_out("va",jjm,llm,(1.-tau)*vgui1+tau*vgui2)
-        IF (f_out) CALL guide_out("vcov",jjm,llm,f_add(1:ip1jm,:)/factt)
-        vcov=vcov+f_add(1:ip1jm,:)
-    endif
-  END SUBROUTINE guide_main
-
-!=======================================================================
-  SUBROUTINE guide_addfield(hsize,vsize,field,alpha)
-! field1=a*field1+alpha*field2
-
-    IMPLICIT NONE
-
-    ! input variables
-    INTEGER,                      INTENT(IN)    :: hsize
-    INTEGER,                      INTENT(IN)    :: vsize
-    REAL, DIMENSION(hsize),       INTENT(IN)    :: alpha 
-    REAL, DIMENSION(hsize,vsize), INTENT(INOUT) :: field
-
-    ! Local variables
-    INTEGER :: l
-
-    do l=1,vsize
-        field(:,l)=alpha*field(:,l)*alpha_pcor(l)
-    enddo
-
-  END SUBROUTINE guide_addfield
-
-!=======================================================================
-  SUBROUTINE guide_zonave(typ,hsize,vsize,field)
-
-    USE comconst_mod, ONLY: pi
-    
-    IMPLICIT NONE
-
-    INCLUDE "dimensions.h"
-    INCLUDE "paramet.h"
-    INCLUDE "comgeom.h"
-    
-    ! input/output variables
-    INTEGER,                           INTENT(IN)    :: typ
-    INTEGER,                           INTENT(IN)    :: vsize
-    INTEGER,                           INTENT(IN)    :: hsize
-    REAL, DIMENSION(hsize*iip1,vsize), INTENT(INOUT) :: field
-
-    ! Local variables
-    LOGICAL, SAVE                :: first=.TRUE.
-    INTEGER, DIMENSION (2), SAVE :: imin, imax ! averaging domain
-    INTEGER                      :: i,j,l,ij
-    REAL, DIMENSION (iip1)       :: lond       ! longitude in Deg.
-    REAL, DIMENSION (hsize,vsize):: fieldm     ! zon-averaged field
-
-    IF (first) THEN
-        first=.FALSE.
-!Compute domain for averaging
-        lond=rlonu*180./pi
-        imin(1)=1;imax(1)=iip1;
-        imin(2)=1;imax(2)=iip1;
-        IF (guide_reg) THEN
-            DO i=1,iim
-                IF (lond(i).LT.lon_min_g) imin(1)=i
-                IF (lond(i).LE.lon_max_g) imax(1)=i
-            ENDDO
-            lond=rlonv*180./pi
-            DO i=1,iim
-                IF (lond(i).LT.lon_min_g) imin(2)=i
-                IF (lond(i).LE.lon_max_g) imax(2)=i
-            ENDDO
-        ENDIF
-    ENDIF
-
-    fieldm=0.
-    DO l=1,vsize
-    ! Compute zonal average
-        DO j=1,hsize
-            DO i=imin(typ),imax(typ)
-                ij=(j-1)*iip1+i
-                fieldm(j,l)=fieldm(j,l)+field(ij,l)
-            ENDDO
-        ENDDO 
-        fieldm(:,l)=fieldm(:,l)/REAL(imax(typ)-imin(typ)+1)
-    ! Compute forcing
-        DO j=1,hsize
-            DO i=1,iip1
-                ij=(j-1)*iip1+i
-                field(ij,l)=fieldm(j,l)
-            ENDDO
-        ENDDO
-    ENDDO
-
-  END SUBROUTINE guide_zonave
-
-!=======================================================================
-  SUBROUTINE guide_interp(psi,teta)
-  
-  use exner_hyb_m, only: exner_hyb
-  use exner_milieu_m, only: exner_milieu
-  use comconst_mod, only: kappa, cpp
-  use comvert_mod, only: preff, pressure_exner, bp, ap
-  IMPLICIT NONE
-
-  include "dimensions.h"
-  include "paramet.h"
-  include "comgeom2.h"
-
-  REAL, DIMENSION (iip1,jjp1),     INTENT(IN) :: psi ! Psol gcm
-  REAL, DIMENSION (iip1,jjp1,llm), INTENT(IN) :: teta ! Temp. Pot. gcm
-
-  LOGICAL, SAVE                      :: first=.TRUE.
-  ! Variables pour niveaux pression:
-  REAL, DIMENSION (iip1,jjp1,nlevnc) :: plnc1,plnc2 !niveaux pression guidage
-  REAL, DIMENSION (iip1,jjp1,llm)    :: plunc,plsnc !niveaux pression modele
-  REAL, DIMENSION (iip1,jjm,llm)     :: plvnc       !niveaux pression modele
-  REAL, DIMENSION (iip1,jjp1,llmp1)  :: p           ! pression intercouches 
-  REAL, DIMENSION (iip1,jjp1,llm)    :: pls, pext   ! var intermediaire
-  REAL, DIMENSION (iip1,jjp1,llm)    :: pbarx 
-  REAL, DIMENSION (iip1,jjm,llm)     :: pbary 
-  ! Variables pour fonction Exner (P milieu couche)
-  REAL, DIMENSION (iip1,jjp1,llm)    :: pk
-  REAL, DIMENSION (iip1,jjp1)        :: pks    
-  REAL                               :: prefkap,unskap
-  ! Pression de vapeur saturante
-  REAL, DIMENSION (ip1jmp1,llm)      :: qsat
-  !Variables intermediaires interpolation
-  REAL, DIMENSION (iip1,jjp1,llm)    :: zu1,zu2 
-  REAL, DIMENSION (iip1,jjm,llm)     :: zv1,zv2
-  
-  INTEGER                            :: i,j,l,ij
-  CHARACTER(LEN=20),PARAMETER :: modname="guide_interp"
-  
-    write(*,*)trim(modname)//': interpolate nudging variables'
-! -----------------------------------------------------------------
-! Calcul des niveaux de pression champs guidage
-! -----------------------------------------------------------------
-if (guide_modele) then
-    do i=1,iip1
-        do j=1,jjp1
-            do l=1,nlevnc
-                plnc2(i,j,l)=apnc(l)+bpnc(l)*psnat2(i,j)
-                plnc1(i,j,l)=apnc(l)+bpnc(l)*psnat1(i,j)
-            enddo
-        enddo
-    enddo
-else
-    do i=1,iip1
-        do j=1,jjp1
-            do l=1,nlevnc
-                plnc2(i,j,l)=apnc(l)
-                plnc1(i,j,l)=apnc(l)
-           enddo
-        enddo
-    enddo
-
-endif
-    if (first) then
-        first=.FALSE.
-        write(*,*)trim(modname)//' : check vertical level order'
-        write(*,*)trim(modname)//' LMDZ :'
-        do l=1,llm
-          write(*,*)trim(modname)//' PL(',l,')=',(ap(l)+ap(l+1))/2. &
-                  +psi(1,jjp1)*(bp(l)+bp(l+1))/2.
-        enddo
-        write(*,*)trim(modname)//' nudging file :'
-        do l=1,nlevnc
-          write(*,*)trim(modname)//' PL(',l,')=',plnc2(1,1,l)
-        enddo
-        write(*,*)trim(modname)//' invert ordering: invert_p=',invert_p
-        if (guide_u) then
-            do l=1,nlevnc
-              write(*,*)trim(modname)//' U(',l,')=',unat2(1,1,l)
-            enddo
-        endif
-        if (guide_T) then
-            do l=1,nlevnc
-              write(*,*)trim(modname)//' T(',l,')=',tnat2(1,1,l)
-            enddo
-        endif
-    endif
-    
-! -----------------------------------------------------------------
-! Calcul niveaux pression modele 
-! -----------------------------------------------------------------
-    CALL pression( ip1jmp1, ap, bp, psi, p )
-    if (pressure_exner) then
-      CALL exner_hyb(ip1jmp1,psi,p,pks,pk)
-    else
-      CALL exner_milieu(ip1jmp1,psi,p,pks,pk)
-    endif
-!    ....  Calcul de pls , pression au milieu des couches ,en Pascals
-    unskap=1./kappa
-    prefkap =  preff  ** kappa
-    DO l = 1, llm
-        DO j=1,jjp1
-            DO i =1, iip1
-                pls(i,j,l) = preff * ( pk(i,j,l)/cpp) ** unskap
-            ENDDO
-        ENDDO
-    ENDDO
-
-!   calcul des pressions pour les grilles u et v
-    do l=1,llm
-        do j=1,jjp1
-            do i=1,iip1
-                pext(i,j,l)=pls(i,j,l)*aire(i,j)
-            enddo
-        enddo
-    enddo
-    call massbar(pext, pbarx, pbary )
-    do l=1,llm
-        do j=1,jjp1
-            do i=1,iip1
-                plunc(i,j,l)=pbarx(i,j,l)/aireu(i,j)
-                plsnc(i,j,l)=pls(i,j,l)
-            enddo
-        enddo
-    enddo
-    do l=1,llm
-        do j=1,jjm
-            do i=1,iip1
-                plvnc(i,j,l)=pbary(i,j,l)/airev(i,j)
-            enddo
-        enddo
-    enddo
-
-! -----------------------------------------------------------------
-! Interpolation champs guidage sur niveaux modele (+inversion N/S)
-! Conversion en variables gcm (ucov, vcov...)
-! -----------------------------------------------------------------
-    if (guide_P) then
-        do j=1,jjp1
-            do i=1,iim
-                ij=(j-1)*iip1+i
-                psgui1(ij)=psnat1(i,j)
-                psgui2(ij)=psnat2(i,j)
-            enddo
-            psgui1(iip1*j)=psnat1(1,j)
-            psgui2(iip1*j)=psnat2(1,j)
-        enddo
-    endif
-
-    IF (guide_u) THEN
-        CALL pres2lev(unat1,zu1,nlevnc,llm,plnc1,plunc,iip1,jjp1,invert_p)
-        CALL pres2lev(unat2,zu2,nlevnc,llm,plnc2,plunc,iip1,jjp1,invert_p)
-        do l=1,llm
-            do j=1,jjp1
-                do i=1,iim
-                    ij=(j-1)*iip1+i
-                    ugui1(ij,l)=zu1(i,j,l)*cu(i,j)
-                    ugui2(ij,l)=zu2(i,j,l)*cu(i,j)
-                enddo
-                ugui1(j*iip1,l)=ugui1((j-1)*iip1+1,l)    
-                ugui2(j*iip1,l)=ugui2((j-1)*iip1+1,l)    
-            enddo
-            do i=1,iip1
-                ugui1(i,l)=0.
-                ugui1(ip1jm+i,l)=0.
-                ugui2(i,l)=0.
-                ugui2(ip1jm+i,l)=0.
-            enddo
-        enddo
-    ENDIF
-    
-    IF (guide_T) THEN
-        CALL pres2lev(tnat1,zu1,nlevnc,llm,plnc1,plsnc,iip1,jjp1,invert_p)
-        CALL pres2lev(tnat2,zu2,nlevnc,llm,plnc2,plsnc,iip1,jjp1,invert_p)
-        do l=1,llm
-            do j=1,jjp1
-                IF (guide_teta) THEN
-                    do i=1,iim
-                        ij=(j-1)*iip1+i
-                        tgui1(ij,l)=zu1(i,j,l)
-                        tgui2(ij,l)=zu2(i,j,l)
-                    enddo
-                ELSE
-                    do i=1,iim
-                        ij=(j-1)*iip1+i
-                        tgui1(ij,l)=zu1(i,j,l)*cpp/pk(i,j,l)
-                        tgui2(ij,l)=zu2(i,j,l)*cpp/pk(i,j,l)
-                    enddo
-                ENDIF
-                tgui1(j*iip1,l)=tgui1((j-1)*iip1+1,l)    
-                tgui2(j*iip1,l)=tgui2((j-1)*iip1+1,l)    
-            enddo
-            do i=1,iip1
-                tgui1(i,l)=tgui1(1,l)
-                tgui1(ip1jm+i,l)=tgui1(ip1jm+1,l) 
-                tgui2(i,l)=tgui2(1,l)
-                tgui2(ip1jm+i,l)=tgui2(ip1jm+1,l) 
-            enddo
-        enddo
-    ENDIF
-
-    IF (guide_v) THEN
-
-        CALL pres2lev(vnat1,zv1,nlevnc,llm,plnc1(:,:jjm,:),plvnc,iip1,jjm,invert_p)
-        CALL pres2lev(vnat2,zv2,nlevnc,llm,plnc2(:,:jjm,:),plvnc,iip1,jjm,invert_p)
-
-        do l=1,llm
-            do j=1,jjm
-                do i=1,iim
-                    ij=(j-1)*iip1+i
-                    vgui1(ij,l)=zv1(i,j,l)*cv(i,j)
-                    vgui2(ij,l)=zv2(i,j,l)*cv(i,j)
-                enddo
-                vgui1(j*iip1,l)=vgui1((j-1)*iip1+1,l)    
-                vgui2(j*iip1,l)=vgui2((j-1)*iip1+1,l)    
-            enddo
-        enddo
-    ENDIF
-    
-    IF (guide_Q) THEN
-        ! On suppose qu'on a la bonne variable dans le fichier de guidage:
-        ! Hum.Rel si guide_hr, Hum.Spec. sinon.
-        CALL pres2lev(qnat1,zu1,nlevnc,llm,plnc1,plsnc,iip1,jjp1,invert_p)
-        CALL pres2lev(qnat2,zu2,nlevnc,llm,plnc2,plsnc,iip1,jjp1,invert_p)
-        do l=1,llm
-            do j=1,jjp1
-                do i=1,iim
-                    ij=(j-1)*iip1+i
-                    qgui1(ij,l)=zu1(i,j,l)
-                    qgui2(ij,l)=zu2(i,j,l)
-                enddo
-                qgui1(j*iip1,l)=qgui1((j-1)*iip1+1,l)    
-                qgui2(j*iip1,l)=qgui2((j-1)*iip1+1,l)    
-            enddo
-            do i=1,iip1
-                qgui1(i,l)=qgui1(1,l)
-                qgui1(ip1jm+i,l)=qgui1(ip1jm+1,l) 
-                qgui2(i,l)=qgui2(1,l)
-                qgui2(ip1jm+i,l)=qgui2(ip1jm+1,l) 
-            enddo
-        enddo
-        IF (guide_hr) THEN
-            CALL q_sat(iip1*jjp1*llm,teta*pk/cpp,plsnc,qsat)
-            qgui1=qgui1*qsat*0.01 !hum. rel. en %
-            qgui2=qgui2*qsat*0.01 
-        ENDIF
-    ENDIF
-
-  END SUBROUTINE guide_interp
-
-!=======================================================================
-  SUBROUTINE tau2alpha(typ,pim,pjm,factt,taumin,taumax,alpha)
-
-! Calcul des constantes de rappel alpha (=1/tau)
-
-    use comconst_mod, only: pi
-    use serre_mod, only: clon, clat, grossismx, grossismy
-    
-    implicit none
-
-    include "dimensions.h"
-    include "paramet.h"
-    include "comgeom2.h"
-
-! input arguments :
-    INTEGER, INTENT(IN) :: typ    ! u(2),v(3), ou scalaire(1)
-    INTEGER, INTENT(IN) :: pim,pjm ! dimensions en lat, lon
-    REAL, INTENT(IN)    :: factt   ! pas de temps en fraction de jour
-    REAL, INTENT(IN)    :: taumin,taumax
-! output arguments:
-    REAL, DIMENSION(pim,pjm), INTENT(OUT) :: alpha 
-  
-!  local variables:
-    LOGICAL, SAVE               :: first=.TRUE.
-    REAL, SAVE                  :: gamma,dxdy_min,dxdy_max
-    REAL, DIMENSION (iip1,jjp1) :: zdx,zdy
-    REAL, DIMENSION (iip1,jjp1) :: dxdys,dxdyu
-    REAL, DIMENSION (iip1,jjm)  :: dxdyv
-    real dxdy_
-    real zlat,zlon
-    real alphamin,alphamax,xi
-    integer i,j,ilon,ilat
-    character(len=20),parameter :: modname="tau2alpha"
-    CHARACTER (len = 80)   :: abort_message
-
-
-    alphamin=factt/taumax
-    alphamax=factt/taumin
-    IF (guide_reg.OR.guide_add) THEN
-        alpha=alphamax
-!-----------------------------------------------------------------------
-! guide_reg: alpha=alpha_min dans region, 0. sinon.
-!-----------------------------------------------------------------------
-        IF (guide_reg) THEN
-            do j=1,pjm
-                do i=1,pim
-                    if (typ.eq.2) then
-                       zlat=rlatu(j)*180./pi
-                       zlon=rlonu(i)*180./pi
-                    elseif (typ.eq.1) then
-                       zlat=rlatu(j)*180./pi
-                       zlon=rlonv(i)*180./pi
-                    elseif (typ.eq.3) then
-                       zlat=rlatv(j)*180./pi
-                       zlon=rlonv(i)*180./pi
-                    endif
-                    alpha(i,j)=alphamax/16.* &
-                              (1.+tanh((zlat-lat_min_g)/tau_lat))* &
-                              (1.+tanh((lat_max_g-zlat)/tau_lat))* &
-                              (1.+tanh((zlon-lon_min_g)/tau_lon))* &
-                              (1.+tanh((lon_max_g-zlon)/tau_lon))
-                enddo
-            enddo
-        ENDIF
-    ELSE
-!-----------------------------------------------------------------------
-! Sinon, alpha varie entre alpha_min et alpha_max suivant le zoom.
-!-----------------------------------------------------------------------
-!Calcul de l'aire des mailles
-        do j=2,jjm
-            do i=2,iip1
-               zdx(i,j)=0.5*(cu(i-1,j)+cu(i,j))/cos(rlatu(j))
-            enddo
-            zdx(1,j)=zdx(iip1,j)
-        enddo
-        do j=2,jjm
-            do i=1,iip1
-               zdy(i,j)=0.5*(cv(i,j-1)+cv(i,j))
-            enddo
-        enddo
-        do i=1,iip1
-            zdx(i,1)=zdx(i,2)
-            zdx(i,jjp1)=zdx(i,jjm)
-            zdy(i,1)=zdy(i,2)
-            zdy(i,jjp1)=zdy(i,jjm)
-        enddo
-        do j=1,jjp1
-            do i=1,iip1
-               dxdys(i,j)=sqrt(zdx(i,j)*zdx(i,j)+zdy(i,j)*zdy(i,j))
-            enddo
-        enddo
-        IF (typ.EQ.2) THEN
-            do j=1,jjp1
-                do i=1,iim
-                   dxdyu(i,j)=0.5*(dxdys(i,j)+dxdys(i+1,j))
-                enddo
-                dxdyu(iip1,j)=dxdyu(1,j)
-            enddo
-        ENDIF
-        IF (typ.EQ.3) THEN
-            do j=1,jjm
-                do i=1,iip1
-                   dxdyv(i,j)=0.5*(dxdys(i,j)+dxdys(i,j+1))
-                enddo
-            enddo
-        ENDIF
-! Premier appel: calcul des aires min et max et de gamma.
-        IF (first) THEN 
-            first=.FALSE.
-            ! coordonnees du centre du zoom
-            CALL coordij(clon,clat,ilon,ilat) 
-            ! aire de la maille au centre du zoom
-            dxdy_min=dxdys(ilon,ilat)
-            ! dxdy maximale de la maille
-            dxdy_max=0.
-            do j=1,jjp1
-                do i=1,iip1
-                     dxdy_max=max(dxdy_max,dxdys(i,j))
-                enddo
-            enddo
-            ! Calcul de gamma
-            if (abs(grossismx-1.).lt.0.1.or.abs(grossismy-1.).lt.0.1) then
-              write(*,*)trim(modname)//' ATTENTION modele peu zoome'
-              write(*,*)trim(modname)//' ATTENTION on prend une constante de guidage cste'
-              gamma=0.
-            else
-              gamma=(dxdy_max-2.*dxdy_min)/(dxdy_max-dxdy_min)
-              write(*,*)trim(modname)//' gamma=',gamma
-              if (gamma.lt.1.e-5) then
-                write(*,*)trim(modname)//' gamma =',gamma,'<1e-5'
-                abort_message='stopped'
-                CALL abort_gcm(modname,abort_message,1)
-              endif
-              gamma=log(0.5)/log(gamma)
-              if (gamma4) then 
-                gamma=min(gamma,4.)
-              endif
-              write(*,*)trim(modname)//' gamma=',gamma
-            endif
-        ENDIF !first
-
-        do j=1,pjm
-            do i=1,pim
-                if (typ.eq.1) then
-                   dxdy_=dxdys(i,j)
-                   zlat=rlatu(j)*180./pi
-                elseif (typ.eq.2) then
-                   dxdy_=dxdyu(i,j)
-                   zlat=rlatu(j)*180./pi
-                elseif (typ.eq.3) then
-                   dxdy_=dxdyv(i,j)
-                   zlat=rlatv(j)*180./pi
-                endif
-                if (abs(grossismx-1.).lt.0.1.or.abs(grossismy-1.).lt.0.1) then
-                ! pour une grille reguliere, xi=xxx**0=1 -> alpha=alphamin
-                    alpha(i,j)=alphamin
-                else
-                    xi=((dxdy_max-dxdy_)/(dxdy_max-dxdy_min))**gamma
-                    xi=min(xi,1.)
-                    if(lat_min_g.le.zlat .and. zlat.le.lat_max_g) then
-                        alpha(i,j)=xi*alphamin+(1.-xi)*alphamax
-                    else
-                        alpha(i,j)=0.
-                    endif
-                endif
-            enddo
-        enddo
-    ENDIF ! guide_reg
-
-    if (.not. guide_add) alpha = 1. - exp(- alpha)
-
-  END SUBROUTINE tau2alpha
-
-!=======================================================================
-  SUBROUTINE guide_read(timestep)
-
-    use netcdf, only: NF90_GET_VAR, nf90_noerr
-
-    IMPLICIT NONE
-
-    include "dimensions.h"
-    include "paramet.h"
-
-    INTEGER, INTENT(IN)   :: timestep
-
-    LOGICAL, SAVE         :: first=.TRUE.
-! Identification fichiers et variables NetCDF:
-    INTEGER, SAVE         :: ncidu,varidu,ncidv,varidv,ncidp,varidp
-    INTEGER, SAVE         :: ncidQ,varidQ,ncidt,varidt,ncidps,varidps
-    INTEGER               :: ncidpl,varidpl,varidap,varidbp,dimid,lendim
-! Variables auxiliaires NetCDF:
-    INTEGER, DIMENSION(4) :: start,count
-    INTEGER               :: status,rcode
-    CHARACTER (len = 80)   :: abort_message
-    CHARACTER (len = 20)   :: modname = 'guide_read'
-    CHARACTER (len = 20)   :: namedim
-
-! -----------------------------------------------------------------
-! Premier appel: initialisation de la lecture des fichiers
-! -----------------------------------------------------------------
-    if (first) then
-         ncidpl=-99
-         write(*,*) trim(modname)//': opening nudging files '
-! Niveaux de pression si non constants
-         if (guide_plevs.EQ.1) then
-             write(*,*) trim(modname)//' Reading nudging on model levels'
-             rcode = nf90_open('apbp.nc', nf90_nowrite, ncidpl)
-             IF (rcode.NE.NF90_NOERR) THEN
-              abort_message='Nudging: error -> no file apbp.nc'
-              CALL abort_gcm(modname,abort_message,1)
-             ENDIF
-             rcode = nf90_inq_varid(ncidpl, 'AP', varidap)
-             IF (rcode.NE.NF90_NOERR) THEN
-              abort_message='Nudging: error -> no AP variable in file apbp.nc'
-              CALL abort_gcm(modname,abort_message,1)
-             ENDIF
-             rcode = nf90_inq_varid(ncidpl, 'BP', varidbp)
-             IF (rcode.NE.NF90_NOERR) THEN
-              abort_message='Nudging: error -> no BP variable in file apbp.nc'
-              CALL abort_gcm(modname,abort_message,1)
-             ENDIF
-             write(*,*) trim(modname)//' ncidpl,varidap',ncidpl,varidap
-         endif
-
-! Pression si guidage sur niveaux P variables
-         if (guide_plevs.EQ.2) then
-             rcode = nf90_open('P.nc', nf90_nowrite, ncidp)
-             IF (rcode.NE.NF90_NOERR) THEN
-              abort_message='Nudging: error -> no file P.nc'
-              CALL abort_gcm(modname,abort_message,1)
-             ENDIF
-             rcode = nf90_inq_varid(ncidp, 'PRES', varidp)
-             IF (rcode.NE.NF90_NOERR) THEN 
-              abort_message='Nudging: error -> no PRES variable in file P.nc'
-              CALL abort_gcm(modname,abort_message,1)
-             ENDIF
-             write(*,*) trim(modname)//' ncidp,varidp',ncidp,varidp
-             if (ncidpl.eq.-99) ncidpl=ncidp
-         endif
-
-! Vent zonal
-         if (guide_u) then
-             rcode = nf90_open('u.nc', nf90_nowrite, ncidu)
-             IF (rcode.NE.NF90_NOERR) THEN
-              abort_message='Nudging: error -> no file u.nc'
-              CALL abort_gcm(modname,abort_message,1)
-             ENDIF
-             rcode = nf90_inq_varid(ncidu, 'UWND', varidu)
-             IF (rcode.NE.NF90_NOERR) THEN
-              abort_message='Nudging: error -> no UWND variable in file u.nc'
-              CALL abort_gcm(modname,abort_message,1)
-             ENDIF
-             write(*,*) trim(modname)//' ncidu,varidu',ncidu,varidu
-             if (ncidpl.eq.-99) ncidpl=ncidu
-
-             status=NF90_INQ_DIMID(ncidu, "LONU", dimid)
-             status=NF90_INQUIRE_DIMENSION(ncidu,dimid,namedim,lendim)
-             IF (lendim .NE. iip1) THEN
-                abort_message='dimension LONU different from iip1 in u.nc'
-                CALL abort_gcm(modname,abort_message,1)
-             ENDIF
-
-             status=NF90_INQ_DIMID(ncidu, "LATU", dimid)
-             status=NF90_INQUIRE_DIMENSION(ncidu,dimid,namedim,lendim)
-             IF (lendim .NE. jjp1) THEN
-                abort_message='dimension LATU different from jjp1 in u.nc'
-                CALL abort_gcm(modname,abort_message,1)
-             ENDIF
-
-         endif
-
-! Vent meridien
-         if (guide_v) then
-             rcode = nf90_open('v.nc', nf90_nowrite, ncidv)
-             IF (rcode.NE.NF90_NOERR) THEN
-              abort_message='Nudging: error -> no file v.nc'
-              CALL abort_gcm(modname,abort_message,1)
-             ENDIF
-             rcode = nf90_inq_varid(ncidv, 'VWND', varidv)
-             IF (rcode.NE.NF90_NOERR) THEN
-              abort_message='Nudging: error -> no VWND variable in file v.nc'
-              CALL abort_gcm(modname,abort_message,1)
-             ENDIF
-             write(*,*) trim(modname)//' ncidv,varidv',ncidv,varidv
-             if (ncidpl.eq.-99) ncidpl=ncidv
-             
-             status=NF90_INQ_DIMID(ncidv, "LONV", dimid)
-             status=NF90_INQUIRE_DIMENSION(ncidv,dimid,namedim,lendim)
-             
-                IF (lendim .NE. iip1) THEN
-                abort_message='dimension LONV different from iip1 in v.nc'
-                CALL abort_gcm(modname,abort_message,1)
-             ENDIF
-
-
-             status=NF90_INQ_DIMID(ncidv, "LATV", dimid)
-             status=NF90_INQUIRE_DIMENSION(ncidv,dimid,namedim,lendim)
-             IF (lendim .NE. jjm) THEN
-                abort_message='dimension LATV different from jjm in v.nc'
-                CALL abort_gcm(modname,abort_message,1)
-             ENDIF
-        
-         endif
-
-! Temperature
-         if (guide_T) then
-             rcode = nf90_open('T.nc', nf90_nowrite, ncidt)
-             IF (rcode.NE.NF90_NOERR) THEN
-              abort_message='Nudging: error -> no file T.nc'
-              CALL abort_gcm(modname,abort_message,1)
-             ENDIF
-             rcode = nf90_inq_varid(ncidt, 'AIR', varidt)
-             IF (rcode.NE.NF90_NOERR) THEN
-              abort_message='Nudging: error -> no AIR variable in file T.nc'
-              CALL abort_gcm(modname,abort_message,1)
-             ENDIF
-             write(*,*) trim(modname)//' ncidT,varidT',ncidt,varidt
-             if (ncidpl.eq.-99) ncidpl=ncidt
-
-             status=NF90_INQ_DIMID(ncidt, "LONV", dimid)
-             status=NF90_INQUIRE_DIMENSION(ncidt,dimid,namedim,lendim)
-             IF (lendim .NE. iip1) THEN
-                abort_message='dimension LONV different from iip1 in T.nc'
-                CALL abort_gcm(modname,abort_message,1)
-             ENDIF
-
-             status=NF90_INQ_DIMID(ncidt, "LATU", dimid)
-             status=NF90_INQUIRE_DIMENSION(ncidt,dimid,namedim,lendim)
-             IF (lendim .NE. jjp1) THEN
-                abort_message='dimension LATU different from jjp1 in T.nc'
-                CALL abort_gcm(modname,abort_message,1)
-             ENDIF
-
-         endif
-
-! Humidite
-         if (guide_Q) then
-             rcode = nf90_open('hur.nc', nf90_nowrite, ncidQ)
-             IF (rcode.NE.NF90_NOERR) THEN
-              abort_message='Nudging: error -> no file hur.nc'
-              CALL abort_gcm(modname,abort_message,1)
-             ENDIF
-             rcode = nf90_inq_varid(ncidQ, 'RH', varidQ)
-             IF (rcode.NE.NF90_NOERR) THEN
-              abort_message='Nudging: error -> no RH variable in file hur.nc'
-              CALL abort_gcm(modname,abort_message,1)
-             ENDIF
-             write(*,*) trim(modname)//' ncidQ,varidQ',ncidQ,varidQ
-             if (ncidpl.eq.-99) ncidpl=ncidQ
-
-             status=NF90_INQ_DIMID(ncidQ, "LONV", dimid)
-             status=NF90_INQUIRE_DIMENSION(ncidQ,dimid,namedim,lendim)
-             IF (lendim .NE. iip1) THEN
-                abort_message='dimension LONV different from iip1 in hur.nc'
-                CALL abort_gcm(modname,abort_message,1)
-             ENDIF
-
-             status=NF90_INQ_DIMID(ncidQ, "LATU", dimid)
-             status=NF90_INQUIRE_DIMENSION(ncidQ,dimid,namedim,lendim)
-             IF (lendim .NE. jjp1) THEN
-                abort_message='dimension LATU different from jjp1 in hur.nc'
-                CALL abort_gcm(modname,abort_message,1)
-             ENDIF
-
-         endif
-
-! Pression de surface
-         if ((guide_P).OR.(guide_modele)) then
-             rcode = nf90_open('ps.nc', nf90_nowrite, ncidps)
-             IF (rcode.NE.NF90_NOERR) THEN
-              abort_message='Nudging: error -> no file ps.nc'
-              CALL abort_gcm(modname,abort_message,1)
-             ENDIF
-             rcode = nf90_inq_varid(ncidps, 'SP', varidps)
-             IF (rcode.NE.NF90_NOERR) THEN
-              abort_message='Nudging: error -> no SP variable in file ps.nc'
-              CALL abort_gcm(modname,abort_message,1)
-             ENDIF
-             write(*,*) trim(modname)//' ncidps,varidps',ncidps,varidps
-         endif
-! Coordonnee verticale
-         if (guide_plevs.EQ.0) then
-              rcode = nf90_inq_varid(ncidpl, 'LEVEL', varidpl)
-              IF (rcode.NE.0) rcode = nf90_inq_varid(ncidpl, 'PRESSURE', varidpl)
-              write(*,*) trim(modname)//' ncidpl,varidpl',ncidpl,varidpl
-         endif
-! Coefs ap, bp pour calcul de la pression aux differents niveaux
-         if (guide_plevs.EQ.1) then
-             status=NF90_GET_VAR(ncidpl,varidap,apnc,[1],[nlevnc])
-             status=NF90_GET_VAR(ncidpl,varidbp,bpnc,[1],[nlevnc])
-         ELSEIF (guide_plevs.EQ.0) THEN
-             status=NF90_GET_VAR(ncidpl,varidpl,apnc,[1],[nlevnc])
-!FC Pour les corrections la pression est deja en Pascals on commente la ligne ci-dessous
-             IF(convert_Pa) apnc=apnc*100.! conversion en Pascals
-             bpnc(:)=0.
-         endif
-         first=.FALSE.
-     endif ! (first)
-
-! -----------------------------------------------------------------
-!   lecture des champs u, v, T, Q, ps
-! -----------------------------------------------------------------
-
-!  dimensions pour les champs scalaires et le vent zonal
-     start(1)=1
-     start(2)=1
-     start(3)=1
-     start(4)=timestep
-
-     count(1)=iip1
-     count(2)=jjp1
-     count(3)=nlevnc
-     count(4)=1
-
-! Pression 
-     if (guide_plevs.EQ.2) then
-         status=NF90_GET_VAR(ncidp,varidp,pnat2,start,count)
-         IF (invert_y) THEN
-!           PRINT*,"Invertion impossible actuellement"
-!           CALL abort_gcm(modname,abort_message,1)
-           CALL invert_lat(iip1,jjp1,nlevnc,pnat2)
-         ENDIF
-     endif
-
-!  Vent zonal
-     if (guide_u) then
-         status=NF90_GET_VAR(ncidu,varidu,unat2,start,count)
-         IF (invert_y) THEN
-           CALL invert_lat(iip1,jjp1,nlevnc,unat2)
-         ENDIF
-     endif
-
-!  Temperature
-     if (guide_T) then
-         status=NF90_GET_VAR(ncidt,varidt,tnat2,start,count)
-         IF (invert_y) THEN
-           CALL invert_lat(iip1,jjp1,nlevnc,tnat2)
-         ENDIF
-     endif
-
-!  Humidite
-     if (guide_Q) then
-         status=NF90_GET_VAR(ncidQ,varidQ,qnat2,start,count)
-         IF (invert_y) THEN
-           CALL invert_lat(iip1,jjp1,nlevnc,qnat2)
-         ENDIF
-         
-     endif
-
-!  Vent meridien
-     if (guide_v) then
-         count(2)=jjm
-         status=NF90_GET_VAR(ncidv,varidv,vnat2,start,count)
-         IF (invert_y) THEN
-           CALL invert_lat(iip1,jjm,nlevnc,vnat2)
-         ENDIF
-     endif
-
-!  Pression de surface
-     if ((guide_P).OR.(guide_modele))  then
-         start(3)=timestep
-         start(4)=0
-         count(2)=jjp1
-         count(3)=1
-         count(4)=0
-         status=NF90_GET_VAR(ncidps,varidps,psnat2,start,count)
-         IF (invert_y) THEN
-           CALL invert_lat(iip1,jjp1,1,psnat2)
-         ENDIF
-     endif
-
-  END SUBROUTINE guide_read
-
-!=======================================================================
-  SUBROUTINE guide_read2D(timestep)
-
-    use netcdf, only: nf90_get_var, nf90_noerr
-
-    IMPLICIT NONE
-
-    include "dimensions.h"
-    include "paramet.h"
-
-    INTEGER, INTENT(IN)   :: timestep
-
-    LOGICAL, SAVE         :: first=.TRUE.
-! Identification fichiers et variables NetCDF:
-    INTEGER, SAVE         :: ncidu,varidu,ncidv,varidv,ncidp,varidp
-    INTEGER, SAVE         :: ncidQ,varidQ,ncidt,varidt,ncidps,varidps
-    INTEGER               :: ncidpl,varidpl,varidap,varidbp
-! Variables auxiliaires NetCDF:
-    INTEGER, DIMENSION(4) :: start,count
-    INTEGER               :: status,rcode
-! Variables for 3D extension:
-    REAL, DIMENSION (jjp1,llm) :: zu
-    REAL, DIMENSION (jjm,llm)  :: zv
-    INTEGER               :: i
-
-    CHARACTER (len = 80)   :: abort_message
-    CHARACTER (len = 20)   :: modname = 'guide_read2D'
-! -----------------------------------------------------------------
-! Premier appel: initialisation de la lecture des fichiers
-! -----------------------------------------------------------------
-    if (first) then
-         ncidpl=-99
-         write(*,*)trim(modname)//' : opening nudging files '
-! Ap et Bp si niveaux de pression hybrides
-         if (guide_plevs.EQ.1) then
-           write(*,*)trim(modname)//' Reading nudging on model levels'
-           rcode = nf90_open('apbp.nc', nf90_nowrite, ncidpl)
-           IF (rcode.NE.NF90_NOERR) THEN
-             abort_message='Nudging: error -> no file apbp.nc'
-           CALL abort_gcm(modname,abort_message,1)
-           ENDIF
-           rcode = nf90_inq_varid(ncidpl, 'AP', varidap)
-           IF (rcode.NE.NF90_NOERR) THEN
-             abort_message='Nudging: error -> no AP variable in file apbp.nc'
-           CALL abort_gcm(modname,abort_message,1)
-           ENDIF
-           rcode = nf90_inq_varid(ncidpl, 'BP', varidbp)
-           IF (rcode.NE.NF90_NOERR) THEN
-             abort_message='Nudging: error -> no BP variable in file apbp.nc'
-             CALL abort_gcm(modname,abort_message,1)
-           ENDIF
-           write(*,*)trim(modname)//'ncidpl,varidap',ncidpl,varidap
-         endif
-! Pression
-         if (guide_plevs.EQ.2) then
-           rcode = nf90_open('P.nc', nf90_nowrite, ncidp)
-           IF (rcode.NE.NF90_NOERR) THEN
-             abort_message='Nudging: error -> no file P.nc'
-             CALL abort_gcm(modname,abort_message,1)
-           ENDIF
-           rcode = nf90_inq_varid(ncidp, 'PRES', varidp)
-           IF (rcode.NE.NF90_NOERR) THEN
-             abort_message='Nudging: error -> no PRES variable in file P.nc'
-             CALL abort_gcm(modname,abort_message,1)
-           ENDIF
-           write(*,*)trim(modname)//' ncidp,varidp',ncidp,varidp
-           if (ncidpl.eq.-99) ncidpl=ncidp
-         endif
-! Vent zonal
-         if (guide_u) then
-           rcode = nf90_open('u.nc', nf90_nowrite, ncidu)
-           IF (rcode.NE.NF90_NOERR) THEN
-             abort_message='Nudging: error -> no file u.nc'
-             CALL abort_gcm(modname,abort_message,1)
-           ENDIF
-           rcode = nf90_inq_varid(ncidu, 'UWND', varidu)
-           IF (rcode.NE.NF90_NOERR) THEN
-             abort_message='Nudging: error -> no UWND variable in file u.nc'
-             CALL abort_gcm(modname,abort_message,1)
-           ENDIF
-           write(*,*)trim(modname)//' ncidu,varidu',ncidu,varidu
-           if (ncidpl.eq.-99) ncidpl=ncidu
-         endif
-! Vent meridien
-         if (guide_v) then
-           rcode = nf90_open('v.nc', nf90_nowrite, ncidv)
-           IF (rcode.NE.NF90_NOERR) THEN
-             abort_message='Nudging: error -> no file v.nc'
-             CALL abort_gcm(modname,abort_message,1)
-           ENDIF
-           rcode = nf90_inq_varid(ncidv, 'VWND', varidv)
-           IF (rcode.NE.NF90_NOERR) THEN
-             abort_message='Nudging: error -> no VWND variable in file v.nc'
-             CALL abort_gcm(modname,abort_message,1)
-           ENDIF
-           write(*,*)trim(modname)//' ncidv,varidv',ncidv,varidv
-           if (ncidpl.eq.-99) ncidpl=ncidv
-         endif
-! Temperature
-         if (guide_T) then
-           rcode = nf90_open('T.nc', nf90_nowrite, ncidt)
-           IF (rcode.NE.NF90_NOERR) THEN
-             abort_message='Nudging: error -> no file T.nc'
-             CALL abort_gcm(modname,abort_message,1)
-           ENDIF
-           rcode = nf90_inq_varid(ncidt, 'AIR', varidt)
-           IF (rcode.NE.NF90_NOERR) THEN
-             abort_message='Nudging: error -> no AIR variable in file T.nc'
-             CALL abort_gcm(modname,abort_message,1)
-           ENDIF
-           write(*,*)trim(modname)//' ncidT,varidT',ncidt,varidt
-           if (ncidpl.eq.-99) ncidpl=ncidt
-         endif
-! Humidite
-         if (guide_Q) then
-           rcode = nf90_open('hur.nc', nf90_nowrite, ncidQ)
-           IF (rcode.NE.NF90_NOERR) THEN
-             abort_message='Nudging: error -> no file hur.nc'
-             CALL abort_gcm(modname,abort_message,1)
-           ENDIF
-           rcode = nf90_inq_varid(ncidQ, 'RH', varidQ)
-           IF (rcode.NE.NF90_NOERR) THEN
-             abort_message='Nudging: error -> no RH,variable in file hur.nc'
-             CALL abort_gcm(modname,abort_message,1)
-           ENDIF
-           write(*,*)trim(modname)//' ncidQ,varidQ',ncidQ,varidQ
-           if (ncidpl.eq.-99) ncidpl=ncidQ
-         endif
-! Pression de surface
-         if ((guide_P).OR.(guide_modele)) then
-           rcode = nf90_open('ps.nc', nf90_nowrite, ncidps)
-           IF (rcode.NE.NF90_NOERR) THEN
-             abort_message='Nudging: error -> no file ps.nc'
-             CALL abort_gcm(modname,abort_message,1)
-           ENDIF
-           rcode = nf90_inq_varid(ncidps, 'SP', varidps)
-           IF (rcode.NE.NF90_NOERR) THEN
-             abort_message='Nudging: error -> no SP variable in file ps.nc'
-             CALL abort_gcm(modname,abort_message,1)
-           ENDIF
-           write(*,*)trim(modname)//' ncidps,varidps',ncidps,varidps
-         endif
-! Coordonnee verticale
-         if (guide_plevs.EQ.0) then
-           rcode = nf90_inq_varid(ncidpl, 'LEVEL', varidpl)
-           IF (rcode.NE.0) rcode = nf90_inq_varid(ncidpl, 'PRESSURE', varidpl)
-           write(*,*)trim(modname)//' ncidpl,varidpl',ncidpl,varidpl
-         endif
-! Coefs ap, bp pour calcul de la pression aux differents niveaux
-         if (guide_plevs.EQ.1) then
-             status=NF90_GET_VAR(ncidpl,varidap,apnc,[1],[nlevnc])
-             status=NF90_GET_VAR(ncidpl,varidbp,bpnc,[1],[nlevnc])
-         elseif (guide_plevs.EQ.0) THEN
-             status=NF90_GET_VAR(ncidpl,varidpl,apnc,[1],[nlevnc])
-             apnc=apnc*100.! conversion en Pascals
-             bpnc(:)=0.
-         endif
-         first=.FALSE.
-     endif ! (first)
-
-! -----------------------------------------------------------------
-!   lecture des champs u, v, T, Q, ps
-! -----------------------------------------------------------------
-
-!  dimensions pour les champs scalaires et le vent zonal
-     start(1)=1
-     start(2)=1
-     start(3)=1
-     start(4)=timestep
-
-     count(1)=1
-     count(2)=jjp1
-     count(3)=nlevnc
-     count(4)=1
-
-!  Pression
-     if (guide_plevs.EQ.2) then
-         status=NF90_GET_VAR(ncidp,varidp,zu,start,count)
-         DO i=1,iip1
-             pnat2(i,:,:)=zu(:,:)
-         ENDDO
-
-         IF (invert_y) THEN
-!           PRINT*,"Invertion impossible actuellement"
-!           CALL abort_gcm(modname,abort_message,1)
-           CALL invert_lat(iip1,jjp1,nlevnc,pnat2)
-         ENDIF
-     endif
-!  Vent zonal
-     if (guide_u) then
-         status=NF90_GET_VAR(ncidu,varidu,zu,start,count)
-         DO i=1,iip1
-             unat2(i,:,:)=zu(:,:)
-         ENDDO
-
-         IF (invert_y) THEN
-           CALL invert_lat(iip1,jjp1,nlevnc,unat2)
-         ENDIF
-
-     endif
-
-!  Temperature
-     if (guide_T) then
-         status=NF90_GET_VAR(ncidt,varidt,zu,start,count)
-         DO i=1,iip1
-             tnat2(i,:,:)=zu(:,:)
-         ENDDO
-
-         IF (invert_y) THEN
-           CALL invert_lat(iip1,jjp1,nlevnc,tnat2)
-         ENDIF
-
-     endif
-
-!  Humidite
-     if (guide_Q) then
-         status=NF90_GET_VAR(ncidQ,varidQ,zu,start,count)
-         DO i=1,iip1
-             qnat2(i,:,:)=zu(:,:)
-         ENDDO
-
-         IF (invert_y) THEN
-           CALL invert_lat(iip1,jjp1,nlevnc,qnat2)
-         ENDIF
-
-     endif
-
-!  Vent meridien
-     if (guide_v) then
-         count(2)=jjm
-         status=NF90_GET_VAR(ncidv,varidv,zv,start,count)
-         DO i=1,iip1
-             vnat2(i,:,:)=zv(:,:)
-         ENDDO
-
-         IF (invert_y) THEN
-           CALL invert_lat(iip1,jjm,nlevnc,vnat2)
-         ENDIF
-
-     endif
-
-!  Pression de surface
-     if ((guide_P).OR.(guide_plevs.EQ.1))  then
-         start(3)=timestep
-         start(4)=0
-         count(2)=jjp1
-         count(3)=1
-         count(4)=0
-         status=NF90_GET_VAR(ncidps,varidps,zu(:,1),start,count)
-         DO i=1,iip1
-             psnat2(i,:)=zu(:,1)
-         ENDDO
-
-         IF (invert_y) THEN
-           CALL invert_lat(iip1,jjp1,1,psnat2)
-         ENDIF
-
-     endif
-
-  END SUBROUTINE guide_read2D
-  
-!=======================================================================
-  SUBROUTINE guide_out(varname,hsize,vsize,field)
-
-    USE comconst_mod, ONLY: pi
-    USE comvert_mod, ONLY: presnivs
-    use netcdf95, only: nf95_def_var, nf95_put_var
-    use netcdf, only: nf90_float, nf90_def_var, nf90_put_var
-    
-    IMPLICIT NONE
-
-    INCLUDE "dimensions.h"
-    INCLUDE "paramet.h"
-    INCLUDE "netcdf.inc"
-    INCLUDE "comgeom2.h"
-    
-    ! Variables entree
-    CHARACTER*(*), INTENT(IN)                          :: varname
-    INTEGER,   INTENT (IN)                         :: hsize,vsize
-    REAL, DIMENSION (iip1,hsize,vsize), INTENT(IN) :: field
-
-    ! Variables locales
-    INTEGER, SAVE :: timestep=0
-    ! Identites fichier netcdf
-    INTEGER       :: nid, id_lonu, id_lonv, id_latu, id_latv, id_tim, id_lev
-    INTEGER       :: vid_lonu,vid_lonv,vid_latu,vid_latv,vid_cu,vid_cv,vid_lev
-    INTEGER       :: vid_au,vid_av, varid_alpha_t, varid_alpha_q
-    INTEGER, DIMENSION (3) :: dim3
-    INTEGER, DIMENSION (4) :: dim4,count,start
-    INTEGER                :: ierr, varid,l
-    REAL, DIMENSION (iip1,hsize,vsize) :: field2
-    CHARACTER(LEN=20),PARAMETER :: modname="guide_out"
-
-    write(*,*)trim(modname)//': output timestep',timestep,'var ',varname
-    IF (timestep.EQ.0) THEN 
-! ----------------------------------------------
-! initialisation fichier de sortie
-! ----------------------------------------------
-! Ouverture du fichier
-        ierr=NF_CREATE("guide_ins.nc",IOR(NF_CLOBBER,NF_64BIT_OFFSET),nid)
-! Definition des dimensions
-        ierr=NF_DEF_DIM(nid,"LONU",iip1,id_lonu) 
-        ierr=NF_DEF_DIM(nid,"LONV",iip1,id_lonv) 
-        ierr=NF_DEF_DIM(nid,"LATU",jjp1,id_latu) 
-        ierr=NF_DEF_DIM(nid,"LATV",jjm,id_latv) 
-        ierr=NF_DEF_DIM(nid,"LEVEL",llm,id_lev)
-        ierr=NF_DEF_DIM(nid,"TIME",NF_UNLIMITED,id_tim)
-
-! Creation des variables dimensions
-        ierr=NF90_DEF_VAR(nid,"LONU",NF90_FLOAT,id_lonu,vid_lonu)
-        ierr=NF90_DEF_VAR(nid,"LONV",NF90_FLOAT,id_lonv,vid_lonv)
-        ierr=NF90_DEF_VAR(nid,"LATU",NF90_FLOAT,id_latu,vid_latu)
-        ierr=NF90_DEF_VAR(nid,"LATV",NF90_FLOAT,id_latv,vid_latv)
-        ierr=NF90_DEF_VAR(nid,"LEVEL",NF90_FLOAT,id_lev,vid_lev)
-        ierr=NF90_DEF_VAR(nid,"cu",NF90_FLOAT,(/id_lonu,id_latu/),vid_cu)
-        ierr=NF90_DEF_VAR(nid,"cv",NF90_FLOAT,(/id_lonv,id_latv/),vid_cv)
-        ierr=NF90_DEF_VAR(nid,"au",NF90_FLOAT,(/id_lonu,id_latu/),vid_au)
-        ierr=NF90_DEF_VAR(nid,"av",NF90_FLOAT,(/id_lonv,id_latv/),vid_av)
-        call nf95_def_var(nid, "alpha_T", nf90_float, (/id_lonv, id_latu/), &
-             varid_alpha_t)
-        call nf95_def_var(nid, "alpha_q", nf90_float, (/id_lonv, id_latu/), &
-             varid_alpha_q)
-        
-        ierr=NF_ENDDEF(nid)
-
-! Enregistrement des variables dimensions
-
-         ierr = nf90_put_var(nid, vid_lonu, rlonu * 180. / pi)
-         ierr = nf90_put_var(nid, vid_lonv, rlonv * 180. / pi)
-         ierr = nf90_put_var(nid, vid_latu, rlatu * 180. / pi)
-         ierr = nf90_put_var(nid, vid_latv, rlatv * 180. / pi)
-         ierr = nf90_put_var(nid, vid_lev, presnivs)
-         ierr = nf90_put_var(nid, vid_cu, cu)
-         ierr = nf90_put_var(nid, vid_cv, cv)
-         ierr = nf90_put_var(nid, vid_au, alpha_u)
-         ierr = nf90_put_var(nid, vid_av, alpha_v)
-
-
-        call nf95_put_var(nid, varid_alpha_t, alpha_t)
-        call nf95_put_var(nid, varid_alpha_q, alpha_q)
-! --------------------------------------------------------------------
-! Cr�ation des variables sauvegard�es
-! --------------------------------------------------------------------
-        ierr = NF_REDEF(nid)
-! Pressure (GCM)
-        dim4=(/id_lonv,id_latu,id_lev,id_tim/)
-        ierr = NF90_DEF_VAR(nid,"SP",NF90_FLOAT,dim4,varid)
-! Surface pressure (guidage)
-        IF (guide_P) THEN
-            dim3=(/id_lonv,id_latu,id_tim/)
-            ierr = NF90_DEF_VAR(nid,"ps",NF90_FLOAT,dim3,varid)
-        ENDIF
-! Zonal wind
-        IF (guide_u) THEN
-            dim4=(/id_lonu,id_latu,id_lev,id_tim/)
-            ierr = NF90_DEF_VAR(nid,"u",NF90_FLOAT,dim4,varid)
-            ierr = NF90_DEF_VAR(nid,"ua",NF90_FLOAT,dim4,varid)
-            ierr = NF90_DEF_VAR(nid,"ucov",NF90_FLOAT,dim4,varid)
-        ENDIF
-! Merid. wind
-        IF (guide_v) THEN
-            dim4=(/id_lonv,id_latv,id_lev,id_tim/)
-            ierr = NF90_DEF_VAR(nid,"v",NF90_FLOAT,dim4,varid)
-            ierr = NF90_DEF_VAR(nid,"va",NF90_FLOAT,dim4,varid)
-            ierr = NF90_DEF_VAR(nid,"vcov",NF90_FLOAT,dim4,varid)
-        ENDIF
-! Pot. Temperature
-        IF (guide_T) THEN
-            dim4=(/id_lonv,id_latu,id_lev,id_tim/)
-            ierr = NF90_DEF_VAR(nid,"teta",NF90_FLOAT,dim4,varid)
-        ENDIF
-! Specific Humidity
-        IF (guide_Q) THEN
-            dim4=(/id_lonv,id_latu,id_lev,id_tim/)
-            ierr = NF90_DEF_VAR(nid,"q",NF90_FLOAT,dim4,varid)
-        ENDIF
-        
-        ierr = NF_ENDDEF(nid)
-        ierr = NF_CLOSE(nid)
-    ENDIF ! timestep=0
-
-! --------------------------------------------------------------------
-! Enregistrement du champ
-! --------------------------------------------------------------------
-    ierr=NF_OPEN("guide_ins.nc",NF_WRITE,nid)
-
-    IF (varname=="SP") timestep=timestep+1
-
-    ierr = NF_INQ_VARID(nid,varname,varid)
-    SELECT CASE (varname)
-    CASE ("SP","ps")
-        start=(/1,1,1,timestep/)
-        count=(/iip1,jjp1,llm,1/)
-    CASE ("v","va","vcov")
-        start=(/1,1,1,timestep/)
-        count=(/iip1,jjm,llm,1/)
-    CASE DEFAULT
-        start=(/1,1,1,timestep/)
-        count=(/iip1,jjp1,llm,1/)
-    END SELECT
-
-    SELECT CASE (varname)
-    CASE("u","ua")
-        DO l=1,llm ; field2(:,2:jjm,l)=field(:,2:jjm,l)/cu(:,2:jjm) ; ENDDO
-        field2(:,1,:)=0. ; field2(:,jjp1,:)=0.
-    CASE("v","va")
-        DO l=1,llm ; field2(:,:,l)=field(:,:,l)/cv(:,:) ; ENDDO
-    CASE DEFAULT
-        field2=field
-    END SELECT
-
-
-    ierr = nf90_put_var(nid, varid, field2, start, count)
-    ierr = NF_CLOSE(nid)
-
-  END SUBROUTINE guide_out
-    
-  
-!===========================================================================
-  subroutine correctbid(iim,nl,x)
-    integer iim,nl
-    real x(iim+1,nl)
-    integer i,l
-    real zz
-
-    do l=1,nl
-        do i=2,iim-1
-            if(abs(x(i,l)).gt.1.e10) then
-               zz=0.5*(x(i-1,l)+x(i+1,l))
-              print*,'correction ',i,l,x(i,l),zz
-               x(i,l)=zz
-            endif
-         enddo
-     enddo
-     return
-  end subroutine correctbid
-
-!===========================================================================
-END MODULE guide_mod
Index: /LMDZ6/trunk/libf/dyn3d/guide_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d/guide_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3d/guide_mod.f90	(revision 5268)
@@ -0,0 +1,1827 @@
+!
+! $Id$
+!
+MODULE guide_mod
+
+!=======================================================================
+!   Auteur:  F.Hourdin
+!            F. Codron 01/09
+!=======================================================================
+
+  USE getparam, only: ini_getparam, fin_getparam, getpar
+  USE Write_Field
+  use netcdf, only: nf90_nowrite, nf90_open, nf90_inq_varid, nf90_close, &
+                    nf90_inq_dimid, nf90_inquire_dimension
+  use pres2lev_mod, only: pres2lev
+
+  IMPLICIT NONE
+
+! ---------------------------------------------
+! Declarations des cles logiques et parametres 
+! ---------------------------------------------
+  INTEGER, PRIVATE, SAVE  :: iguide_read,iguide_int,iguide_sav
+  INTEGER, PRIVATE, SAVE  :: nlevnc, guide_plevs
+  LOGICAL, PRIVATE, SAVE  :: guide_u,guide_v,guide_T,guide_Q,guide_P
+  LOGICAL, PRIVATE, SAVE  :: guide_hr,guide_teta  
+  LOGICAL, PRIVATE, SAVE  :: guide_BL,guide_reg,guide_add,gamma4,guide_zon 
+  LOGICAL, PRIVATE, SAVE  :: invert_p,invert_y,ini_anal
+  LOGICAL, PRIVATE, SAVE  :: guide_2D,guide_sav,guide_modele
+!FC
+  LOGICAL, PRIVATE, SAVE  :: convert_Pa
+  
+  REAL, PRIVATE, SAVE     :: tau_min_u,tau_max_u
+  REAL, PRIVATE, SAVE     :: tau_min_v,tau_max_v
+  REAL, PRIVATE, SAVE     :: tau_min_T,tau_max_T
+  REAL, PRIVATE, SAVE     :: tau_min_Q,tau_max_Q
+  REAL, PRIVATE, SAVE     :: tau_min_P,tau_max_P
+
+  REAL, PRIVATE, SAVE     :: lat_min_g,lat_max_g
+  REAL, PRIVATE, SAVE     :: lon_min_g,lon_max_g
+  REAL, PRIVATE, SAVE     :: tau_lon,tau_lat
+
+  REAL, PRIVATE, SAVE     :: plim_guide_BL
+
+  REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE     :: alpha_u,alpha_v 
+  REAL, ALLOCATABLE, DIMENSION(:, :), PRIVATE, SAVE     :: alpha_T,alpha_Q 
+  REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE     :: alpha_P,alpha_pcor
+  
+! ---------------------------------------------
+! Variables de guidage
+! ---------------------------------------------
+! Variables des fichiers de guidage
+  REAL, ALLOCATABLE, DIMENSION(:,:,:), PRIVATE, SAVE   :: unat1,unat2
+  REAL, ALLOCATABLE, DIMENSION(:,:,:), PRIVATE, SAVE   :: vnat1,vnat2
+  REAL, ALLOCATABLE, DIMENSION(:,:,:), PRIVATE, SAVE   :: tnat1,tnat2
+  REAL, ALLOCATABLE, DIMENSION(:,:,:), PRIVATE, SAVE   :: qnat1,qnat2
+  REAL, ALLOCATABLE, DIMENSION(:,:,:), PRIVATE, SAVE   :: pnat1,pnat2
+  REAL, ALLOCATABLE, DIMENSION(:,:),   PRIVATE, SAVE   :: psnat1,psnat2
+  REAL, ALLOCATABLE, DIMENSION(:),     PRIVATE, SAVE   :: apnc,bpnc
+! Variables aux dimensions du modele
+  REAL, ALLOCATABLE, DIMENSION(:,:),   PRIVATE, SAVE   :: ugui1,ugui2
+  REAL, ALLOCATABLE, DIMENSION(:,:),   PRIVATE, SAVE   :: vgui1,vgui2
+  REAL, ALLOCATABLE, DIMENSION(:,:),   PRIVATE, SAVE   :: tgui1,tgui2
+  REAL, ALLOCATABLE, DIMENSION(:,:),   PRIVATE, SAVE   :: qgui1,qgui2
+  REAL, ALLOCATABLE, DIMENSION(:),   PRIVATE, SAVE   :: psgui1,psgui2
+
+CONTAINS
+!=======================================================================
+
+  SUBROUTINE guide_init
+
+    use netcdf, only: nf90_noerr
+    USE control_mod, ONLY: day_step
+    USE serre_mod, ONLY: grossismx
+
+    IMPLICIT NONE
+  
+    INCLUDE "dimensions.h"
+    INCLUDE "paramet.h"
+    INCLUDE "netcdf.inc"
+
+    INTEGER                :: error,ncidpl,rid,rcod
+    CHARACTER (len = 80)   :: abort_message
+    CHARACTER (len = 20)   :: modname = 'guide_init'
+    CHARACTER (len = 20)   :: namedim
+
+! ---------------------------------------------
+! Lecture des parametres:  
+! ---------------------------------------------
+    call ini_getparam("nudging_parameters_out.txt")
+! Variables guidees
+    CALL getpar('guide_u',.true.,guide_u,'guidage de u')
+    CALL getpar('guide_v',.true.,guide_v,'guidage de v')
+    CALL getpar('guide_T',.true.,guide_T,'guidage de T')
+    CALL getpar('guide_P',.true.,guide_P,'guidage de P')
+    CALL getpar('guide_Q',.true.,guide_Q,'guidage de Q')
+    CALL getpar('guide_hr',.true.,guide_hr,'guidage de Q par H.R')
+    CALL getpar('guide_teta',.false.,guide_teta,'guidage de T par Teta')
+
+    CALL getpar('guide_add',.false.,guide_add,'for�age constant?')
+    CALL getpar('guide_zon',.false.,guide_zon,'guidage moy zonale')
+    if (guide_zon .and. abs(grossismx - 1.) > 0.01) &
+         call abort_gcm("guide_init", &
+         "zonal nudging requires grid regular in longitude", 1)
+
+!   Constantes de rappel. Unite : fraction de jour
+    CALL getpar('tau_min_u',0.02,tau_min_u,'Cste de rappel min, u')
+    CALL getpar('tau_max_u', 10.,tau_max_u,'Cste de rappel max, u')
+    CALL getpar('tau_min_v',0.02,tau_min_v,'Cste de rappel min, v')
+    CALL getpar('tau_max_v', 10.,tau_max_v,'Cste de rappel max, v')
+    CALL getpar('tau_min_T',0.02,tau_min_T,'Cste de rappel min, T')
+    CALL getpar('tau_max_T', 10.,tau_max_T,'Cste de rappel max, T')
+    CALL getpar('tau_min_Q',0.02,tau_min_Q,'Cste de rappel min, Q')
+    CALL getpar('tau_max_Q', 10.,tau_max_Q,'Cste de rappel max, Q')
+    CALL getpar('tau_min_P',0.02,tau_min_P,'Cste de rappel min, P')
+    CALL getpar('tau_max_P', 10.,tau_max_P,'Cste de rappel max, P')
+    CALL getpar('gamma4',.false.,gamma4,'Zone sans rappel elargie')
+    CALL getpar('guide_BL',.true.,guide_BL,'guidage dans C.Lim')
+    CALL getpar('plim_guide_BL',85000.,plim_guide_BL,'BL top presnivs value')
+
+
+! Sauvegarde du for�age
+    CALL getpar('guide_sav',.false.,guide_sav,'sauvegarde guidage')
+    CALL getpar('iguide_sav',4,iguide_sav,'freq. sauvegarde guidage')
+    ! frequences f>0: fx/jour; f<0: tous les f jours; f=0: 1 seule fois.
+    IF (iguide_sav.GT.0) THEN
+       iguide_sav=day_step/iguide_sav
+    ELSE if (iguide_sav == 0) then
+       iguide_sav = huge(0)
+    ELSE
+       iguide_sav=day_step*iguide_sav
+    ENDIF
+
+! Guidage regional seulement (sinon constant ou suivant le zoom)
+    CALL getpar('guide_reg',.false.,guide_reg,'guidage regional')
+    CALL getpar('lat_min_g',-90.,lat_min_g,'Latitude mini guidage ')
+    CALL getpar('lat_max_g', 90.,lat_max_g,'Latitude maxi guidage ')
+    CALL getpar('lon_min_g',-180.,lon_min_g,'longitude mini guidage ')
+    CALL getpar('lon_max_g', 180.,lon_max_g,'longitude maxi guidage ')
+    CALL getpar('tau_lat', 5.,tau_lat,'raideur lat guide regional ')
+    CALL getpar('tau_lon', 5.,tau_lon,'raideur lon guide regional ')
+
+! Parametres pour lecture des fichiers
+    CALL getpar('iguide_read',4,iguide_read,'freq. lecture guidage')
+    CALL getpar('iguide_int',4,iguide_int,'freq. interpolation vert')
+    IF (iguide_int.EQ.0) THEN
+        iguide_int=1
+    ELSEIF (iguide_int.GT.0) THEN
+        iguide_int=day_step/iguide_int
+    ELSE
+        iguide_int=day_step*iguide_int
+    ENDIF
+    CALL getpar('guide_plevs',0,guide_plevs,'niveaux pression fichiers guidage')
+    ! Pour compatibilite avec ancienne version avec guide_modele
+    CALL getpar('guide_modele',.false.,guide_modele,'niveaux pression ap+bp*psol')
+    IF (guide_modele) THEN
+        guide_plevs=1
+    ENDIF
+!FC
+    CALL getpar('convert_Pa',.true.,convert_Pa,'Convert Pressure levels in Pa')
+    ! Fin raccord
+    CALL getpar('ini_anal',.false.,ini_anal,'Etat initial = analyse')
+    CALL getpar('guide_invertp',.true.,invert_p,'niveaux p inverses')
+    CALL getpar('guide_inverty',.true.,invert_y,'inversion N-S')
+    CALL getpar('guide_2D',.false.,guide_2D,'fichier guidage lat-P')
+
+    call fin_getparam
+    
+! ---------------------------------------------
+! Determination du nombre de niveaux verticaux
+! des fichiers guidage
+! ---------------------------------------------
+    ncidpl=-99
+    if (guide_plevs.EQ.1) then
+       if (ncidpl.eq.-99) then
+          rcod=nf90_open('apbp.nc',Nf90_NOWRITe, ncidpl)
+          if (rcod.NE.NF90_NOERR) THEN
+             abort_message=' Nudging error -> no file apbp.nc'
+             CALL abort_gcm(modname,abort_message,1)
+          endif
+       endif
+    elseif (guide_plevs.EQ.2) then
+       if (ncidpl.EQ.-99) then
+          rcod=nf90_open('P.nc',Nf90_NOWRITe,ncidpl)
+          if (rcod.NE.NF90_NOERR) THEN
+             abort_message=' Nudging error -> no file P.nc'
+             CALL abort_gcm(modname,abort_message,1)
+          endif
+       endif
+
+    elseif (guide_u) then
+           if (ncidpl.eq.-99) then
+               rcod=nf90_open('u.nc',Nf90_NOWRITe,ncidpl)
+               if (rcod.NE.NF90_NOERR) THEN
+                  CALL abort_gcm(modname, &
+                       ' Nudging error -> no file u.nc',1)
+               endif
+           endif
+
+    elseif (guide_v) then
+           if (ncidpl.eq.-99) then
+               rcod=nf90_open('v.nc',nf90_nowrite,ncidpl)
+               if (rcod.NE.NF90_NOERR) THEN
+                  CALL abort_gcm(modname, &
+                       ' Nudging error -> no file v.nc',1)
+               endif
+           endif
+    elseif (guide_T) then
+           if (ncidpl.eq.-99) then
+               rcod=nf90_open('T.nc',nf90_nowrite,ncidpl)
+               if (rcod.NE.NF90_NOERR) THEN
+                  CALL abort_gcm(modname, &
+                       ' Nudging error -> no file T.nc',1)
+               endif
+           endif
+    elseif (guide_Q) then
+           if (ncidpl.eq.-99) then
+               rcod=nf90_open('hur.nc',nf90_nowrite, ncidpl)
+               if (rcod.NE.NF90_NOERR) THEN
+                  CALL abort_gcm(modname, &
+                       ' Nudging error -> no file hur.nc',1)
+               endif
+           endif
+
+
+    endif 
+    error=NF_INQ_DIMID(ncidpl,'LEVEL',rid)
+    IF (error.NE.NF90_NOERR) error=NF_INQ_DIMID(ncidpl,'PRESSURE',rid)
+    IF (error.NE.NF90_NOERR) THEN
+        CALL abort_gcm(modname,'Nudging: error reading pressure levels',1)
+    ENDIF
+    error=NF_INQ_DIMLEN(ncidpl,rid,nlevnc)
+    write(*,*)trim(modname)//' : number of vertical levels nlevnc', nlevnc 
+    rcod = nf90_close(ncidpl)
+
+! ---------------------------------------------
+! Allocation des variables
+! ---------------------------------------------
+    abort_message='nudging allocation error'
+
+    ALLOCATE(apnc(nlevnc), stat = error)
+    IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+    ALLOCATE(bpnc(nlevnc), stat = error)
+    IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+    apnc=0.;bpnc=0.
+
+    ALLOCATE(alpha_pcor(llm), stat = error)
+    IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+    ALLOCATE(alpha_u(ip1jmp1), stat = error)
+    IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+    ALLOCATE(alpha_v(ip1jm), stat = error)
+    IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+    ALLOCATE(alpha_T(iip1, jjp1), stat = error)
+    IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+    ALLOCATE(alpha_Q(iip1, jjp1), stat = error)
+    IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+    ALLOCATE(alpha_P(ip1jmp1), stat = error)
+    IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+    alpha_u=0.;alpha_v=0;alpha_T=0;alpha_Q=0;alpha_P=0
+    
+    IF (guide_u) THEN
+        ALLOCATE(unat1(iip1,jjp1,nlevnc), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(ugui1(ip1jmp1,llm), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(unat2(iip1,jjp1,nlevnc), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(ugui2(ip1jmp1,llm), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        unat1=0.;unat2=0.;ugui1=0.;ugui2=0.
+    ENDIF
+
+    IF (guide_T) THEN
+        ALLOCATE(tnat1(iip1,jjp1,nlevnc), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(tgui1(ip1jmp1,llm), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(tnat2(iip1,jjp1,nlevnc), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(tgui2(ip1jmp1,llm), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        tnat1=0.;tnat2=0.;tgui1=0.;tgui2=0.
+    ENDIF
+     
+    IF (guide_Q) THEN
+        ALLOCATE(qnat1(iip1,jjp1,nlevnc), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(qgui1(ip1jmp1,llm), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(qnat2(iip1,jjp1,nlevnc), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(qgui2(ip1jmp1,llm), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        qnat1=0.;qnat2=0.;qgui1=0.;qgui2=0.
+    ENDIF
+
+    IF (guide_v) THEN
+        ALLOCATE(vnat1(iip1,jjm,nlevnc), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(vgui1(ip1jm,llm), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(vnat2(iip1,jjm,nlevnc), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(vgui2(ip1jm,llm), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        vnat1=0.;vnat2=0.;vgui1=0.;vgui2=0.
+    ENDIF
+
+    IF (guide_plevs.EQ.2) THEN
+        ALLOCATE(pnat1(iip1,jjp1,nlevnc), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(pnat2(iip1,jjp1,nlevnc), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        pnat1=0.;pnat2=0.;
+    ENDIF
+
+    IF (guide_P.OR.guide_plevs.EQ.1) THEN
+        ALLOCATE(psnat1(iip1,jjp1), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(psnat2(iip1,jjp1), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        psnat1=0.;psnat2=0.;
+    ENDIF
+    IF (guide_P) THEN
+        ALLOCATE(psgui2(ip1jmp1), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(psgui1(ip1jmp1), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        psgui1=0.;psgui2=0.
+    ENDIF
+
+! ---------------------------------------------
+!   Lecture du premier etat de guidage.
+! ---------------------------------------------
+    IF (guide_2D) THEN
+        CALL guide_read2D(1)
+    ELSE
+        CALL guide_read(1)
+    ENDIF
+    IF (guide_v) vnat1=vnat2
+    IF (guide_u) unat1=unat2
+    IF (guide_T) tnat1=tnat2
+    IF (guide_Q) qnat1=qnat2
+    IF (guide_plevs.EQ.2) pnat1=pnat2
+    IF (guide_P.OR.guide_plevs.EQ.1) psnat1=psnat2
+
+  END SUBROUTINE guide_init
+
+!=======================================================================
+  SUBROUTINE guide_main(itau,ucov,vcov,teta,q,masse,ps)
+
+    USE exner_hyb_m, ONLY: exner_hyb
+    USE exner_milieu_m, ONLY: exner_milieu
+    USE control_mod, ONLY: day_step, iperiod
+    USE comconst_mod, ONLY: cpp, dtvr, daysec,kappa
+    USE comvert_mod, ONLY: ap, bp, preff, presnivs, pressure_exner
+ 
+    IMPLICIT NONE
+  
+    INCLUDE "dimensions.h"
+    INCLUDE "paramet.h"
+    INCLUDE "iniprint.h"
+
+
+    ! Variables entree
+    INTEGER,                       INTENT(IN)    :: itau !pas de temps
+    REAL, DIMENSION (ip1jmp1,llm), INTENT(INOUT) :: ucov,teta,q,masse
+    REAL, DIMENSION (ip1jm,llm),   INTENT(INOUT) :: vcov
+    REAL, DIMENSION (ip1jmp1),     INTENT(INOUT) :: ps
+
+    ! Variables locales
+    LOGICAL, SAVE :: first=.TRUE.
+    LOGICAL       :: f_out ! sortie guidage
+    REAL, DIMENSION (ip1jmp1,llm) :: f_add ! var aux: champ de guidage
+    REAL :: pk(ip1jmp1,llm) ! Exner at mid-layers
+    REAL :: pks(ip1jmp1) ! Exner at the surface
+    REAL :: unskap ! 1./kappa
+    REAL, DIMENSION (ip1jmp1,llmp1) :: p ! Pressure at inter-layers
+    ! Compteurs temps:
+    INTEGER, SAVE :: step_rea,count_no_rea,itau_test ! lecture guidage
+    REAL          :: ditau, dday_step
+    REAL          :: tau,reste ! position entre 2 etats de guidage
+    REAL, SAVE    :: factt ! pas de temps en fraction de jour
+    
+    INTEGER       :: l
+    CHARACTER(LEN=20) :: modname="guide_main"
+    CHARACTER (len = 80)   :: abort_message
+
+
+!-----------------------------------------------------------------------
+! Initialisations au premier passage
+!-----------------------------------------------------------------------
+    IF (first) THEN
+        first=.FALSE.
+        CALL guide_init 
+        itau_test=1001
+        step_rea=1
+        count_no_rea=0
+! Calcul des constantes de rappel
+        factt=dtvr*iperiod/daysec 
+        call tau2alpha(3,iip1,jjm ,factt,tau_min_v,tau_max_v,alpha_v)
+        call tau2alpha(2,iip1,jjp1,factt,tau_min_u,tau_max_u,alpha_u)
+        call tau2alpha(1,iip1,jjp1,factt,tau_min_T,tau_max_T,alpha_T)
+        call tau2alpha(1,iip1,jjp1,factt,tau_min_P,tau_max_P,alpha_P)
+        call tau2alpha(1,iip1,jjp1,factt,tau_min_Q,tau_max_Q,alpha_Q)
+! correction de rappel dans couche limite
+        if (guide_BL) then
+             alpha_pcor(:)=1.
+        else
+            do l=1,llm
+               alpha_pcor(l)=(1.+tanh(((plim_guide_BL-presnivs(l))/preff)/0.05))/2.
+            enddo
+        endif
+! ini_anal: etat initial egal au guidage        
+        IF (ini_anal) THEN
+            CALL guide_interp(ps,teta)
+            IF (guide_u) ucov=ugui2
+            IF (guide_v) vcov=ugui2
+            IF (guide_T) teta=tgui2
+            IF (guide_Q) q=qgui2
+            IF (guide_P) THEN
+                ps=psgui2
+                CALL pression(ip1jmp1,ap,bp,ps,p)
+                CALL massdair(p,masse)
+            ENDIF
+            RETURN
+        ENDIF
+! Verification structure guidage
+!        IF (guide_u) THEN
+!            CALL writefield('unat',unat1)
+!            CALL writefield('ucov',RESHAPE(ucov,(/iip1,jjp1,llm/)))
+!        ENDIF
+!        IF (guide_T) THEN
+!            CALL writefield('tnat',tnat1)
+!            CALL writefield('teta',RESHAPE(teta,(/iip1,jjp1,llm/)))
+!        ENDIF
+
+    ENDIF !first
+
+!-----------------------------------------------------------------------
+! Lecture des fichiers de guidage ?
+!-----------------------------------------------------------------------
+    IF (iguide_read.NE.0) THEN
+      ditau=real(itau)
+      dday_step=real(day_step)
+      IF (iguide_read.LT.0) THEN
+          tau=ditau/dday_step/REAL(iguide_read)
+      ELSE
+          tau=REAL(iguide_read)*ditau/dday_step
+      ENDIF
+      reste=tau-AINT(tau)
+      IF (reste.EQ.0.) THEN
+          IF (itau_test.EQ.itau) THEN
+            write(lunout,*)trim(modname)//' second pass in advreel at itau=',&
+            itau
+              abort_message='stopped'
+              CALL abort_gcm(modname,abort_message,1) 
+          ELSE
+              IF (guide_v) vnat1=vnat2
+              IF (guide_u) unat1=unat2
+              IF (guide_T) tnat1=tnat2
+              IF (guide_Q) qnat1=qnat2
+              IF (guide_plevs.EQ.2) pnat1=pnat2
+              IF (guide_P.OR.guide_plevs.EQ.1) psnat1=psnat2
+              step_rea=step_rea+1
+              itau_test=itau
+              write(*,*)trim(modname)//' Reading nudging files, step ',&
+                     step_rea,'after ',count_no_rea,' skips'
+              IF (guide_2D) THEN
+                  CALL guide_read2D(step_rea)
+              ELSE
+                  CALL guide_read(step_rea)
+              ENDIF
+              count_no_rea=0
+          ENDIF
+      ELSE
+        count_no_rea=count_no_rea+1
+
+      ENDIF
+    ENDIF !iguide_read=0
+
+!-----------------------------------------------------------------------
+! Interpolation et conversion des champs de guidage
+!-----------------------------------------------------------------------
+    IF (MOD(itau,iguide_int).EQ.0) THEN
+        CALL guide_interp(ps,teta)
+    ENDIF
+! Repartition entre 2 etats de guidage
+    IF (iguide_read.NE.0) THEN
+        tau=reste
+    ELSE
+        tau=1.
+    ENDIF
+
+!-----------------------------------------------------------------------
+!   Ajout des champs de guidage 
+!-----------------------------------------------------------------------
+! Sauvegarde du guidage?
+    f_out=((MOD(itau,iguide_sav).EQ.0).AND.guide_sav)  
+    IF (f_out) THEN
+      ! compute pressures at layer interfaces
+      CALL pression(ip1jmp1,ap,bp,ps,p)
+      if (pressure_exner) then
+        call exner_hyb(ip1jmp1,ps,p,pks,pk)
+      else
+        call exner_milieu(ip1jmp1,ps,p,pks,pk)
+      endif
+      unskap=1./kappa
+      ! Now compute pressures at mid-layer
+      do l=1,llm
+        p(:,l)=preff*(pk(:,l)/cpp)**unskap
+      enddo
+      CALL guide_out("SP",jjp1,llm,p(:,1:llm))
+    ENDIF
+    
+    if (guide_u) then
+        if (guide_add) then
+           f_add=(1.-tau)*ugui1+tau*ugui2
+        else
+           f_add=(1.-tau)*ugui1+tau*ugui2-ucov
+        endif 
+        if (guide_zon) CALL guide_zonave(1,jjp1,llm,f_add)
+        CALL guide_addfield(ip1jmp1,llm,f_add,alpha_u)
+        IF (f_out) CALL guide_out("ua",jjp1,llm,(1.-tau)*ugui1+tau*ugui2)
+        IF (f_out) CALL guide_out("u",jjp1,llm,ucov)
+        IF (f_out) CALL guide_out("ucov",jjp1,llm,f_add/factt)
+        ucov=ucov+f_add
+    endif
+
+    if (guide_T) then
+        if (guide_add) then
+           f_add=(1.-tau)*tgui1+tau*tgui2
+        else
+           f_add=(1.-tau)*tgui1+tau*tgui2-teta
+        endif 
+        if (guide_zon) CALL guide_zonave(2,jjp1,llm,f_add)
+        CALL guide_addfield(ip1jmp1,llm,f_add,alpha_T)
+        IF (f_out) CALL guide_out("teta",jjp1,llm,f_add/factt)
+        teta=teta+f_add
+    endif
+
+    if (guide_P) then
+        if (guide_add) then
+           f_add(1:ip1jmp1,1)=(1.-tau)*psgui1+tau*psgui2
+        else
+           f_add(1:ip1jmp1,1)=(1.-tau)*psgui1+tau*psgui2-ps
+        endif 
+        if (guide_zon) CALL guide_zonave(2,jjp1,1,f_add(1:ip1jmp1,1))
+        CALL guide_addfield(ip1jmp1,1,f_add(1:ip1jmp1,1),alpha_P)
+!        IF (f_out) CALL guide_out("ps",jjp1,1,f_add(1:ip1jmp1,1)/factt)
+        ps=ps+f_add(1:ip1jmp1,1)
+        CALL pression(ip1jmp1,ap,bp,ps,p)
+        CALL massdair(p,masse)
+    endif
+
+    if (guide_Q) then
+        if (guide_add) then
+           f_add=(1.-tau)*qgui1+tau*qgui2
+        else
+           f_add=(1.-tau)*qgui1+tau*qgui2-q
+        endif 
+        if (guide_zon) CALL guide_zonave(2,jjp1,llm,f_add)
+        CALL guide_addfield(ip1jmp1,llm,f_add,alpha_Q)
+        IF (f_out) CALL guide_out("q",jjp1,llm,f_add/factt)
+        q=q+f_add
+    endif
+
+    if (guide_v) then
+        if (guide_add) then
+           f_add(1:ip1jm,:)=(1.-tau)*vgui1+tau*vgui2
+        else
+           f_add(1:ip1jm,:)=(1.-tau)*vgui1+tau*vgui2-vcov
+        endif 
+        if (guide_zon) CALL guide_zonave(2,jjm,llm,f_add(1:ip1jm,:))
+        CALL guide_addfield(ip1jm,llm,f_add(1:ip1jm,:),alpha_v)
+        IF (f_out) CALL guide_out("v",jjm,llm,vcov)
+        IF (f_out) CALL guide_out("va",jjm,llm,(1.-tau)*vgui1+tau*vgui2)
+        IF (f_out) CALL guide_out("vcov",jjm,llm,f_add(1:ip1jm,:)/factt)
+        vcov=vcov+f_add(1:ip1jm,:)
+    endif
+  END SUBROUTINE guide_main
+
+!=======================================================================
+  SUBROUTINE guide_addfield(hsize,vsize,field,alpha)
+! field1=a*field1+alpha*field2
+
+    IMPLICIT NONE
+
+    ! input variables
+    INTEGER,                      INTENT(IN)    :: hsize
+    INTEGER,                      INTENT(IN)    :: vsize
+    REAL, DIMENSION(hsize),       INTENT(IN)    :: alpha 
+    REAL, DIMENSION(hsize,vsize), INTENT(INOUT) :: field
+
+    ! Local variables
+    INTEGER :: l
+
+    do l=1,vsize
+        field(:,l)=alpha*field(:,l)*alpha_pcor(l)
+    enddo
+
+  END SUBROUTINE guide_addfield
+
+!=======================================================================
+  SUBROUTINE guide_zonave(typ,hsize,vsize,field)
+
+    USE comconst_mod, ONLY: pi
+    
+    IMPLICIT NONE
+
+    INCLUDE "dimensions.h"
+    INCLUDE "paramet.h"
+    INCLUDE "comgeom.h"
+    
+    ! input/output variables
+    INTEGER,                           INTENT(IN)    :: typ
+    INTEGER,                           INTENT(IN)    :: vsize
+    INTEGER,                           INTENT(IN)    :: hsize
+    REAL, DIMENSION(hsize*iip1,vsize), INTENT(INOUT) :: field
+
+    ! Local variables
+    LOGICAL, SAVE                :: first=.TRUE.
+    INTEGER, DIMENSION (2), SAVE :: imin, imax ! averaging domain
+    INTEGER                      :: i,j,l,ij
+    REAL, DIMENSION (iip1)       :: lond       ! longitude in Deg.
+    REAL, DIMENSION (hsize,vsize):: fieldm     ! zon-averaged field
+
+    IF (first) THEN
+        first=.FALSE.
+!Compute domain for averaging
+        lond=rlonu*180./pi
+        imin(1)=1;imax(1)=iip1;
+        imin(2)=1;imax(2)=iip1;
+        IF (guide_reg) THEN
+            DO i=1,iim
+                IF (lond(i).LT.lon_min_g) imin(1)=i
+                IF (lond(i).LE.lon_max_g) imax(1)=i
+            ENDDO
+            lond=rlonv*180./pi
+            DO i=1,iim
+                IF (lond(i).LT.lon_min_g) imin(2)=i
+                IF (lond(i).LE.lon_max_g) imax(2)=i
+            ENDDO
+        ENDIF
+    ENDIF
+
+    fieldm=0.
+    DO l=1,vsize
+    ! Compute zonal average
+        DO j=1,hsize
+            DO i=imin(typ),imax(typ)
+                ij=(j-1)*iip1+i
+                fieldm(j,l)=fieldm(j,l)+field(ij,l)
+            ENDDO
+        ENDDO 
+        fieldm(:,l)=fieldm(:,l)/REAL(imax(typ)-imin(typ)+1)
+    ! Compute forcing
+        DO j=1,hsize
+            DO i=1,iip1
+                ij=(j-1)*iip1+i
+                field(ij,l)=fieldm(j,l)
+            ENDDO
+        ENDDO
+    ENDDO
+
+  END SUBROUTINE guide_zonave
+
+!=======================================================================
+  SUBROUTINE guide_interp(psi,teta)
+  
+  use exner_hyb_m, only: exner_hyb
+  use exner_milieu_m, only: exner_milieu
+  use comconst_mod, only: kappa, cpp
+  use comvert_mod, only: preff, pressure_exner, bp, ap
+  IMPLICIT NONE
+
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom2.h"
+
+  REAL, DIMENSION (iip1,jjp1),     INTENT(IN) :: psi ! Psol gcm
+  REAL, DIMENSION (iip1,jjp1,llm), INTENT(IN) :: teta ! Temp. Pot. gcm
+
+  LOGICAL, SAVE                      :: first=.TRUE.
+  ! Variables pour niveaux pression:
+  REAL, DIMENSION (iip1,jjp1,nlevnc) :: plnc1,plnc2 !niveaux pression guidage
+  REAL, DIMENSION (iip1,jjp1,llm)    :: plunc,plsnc !niveaux pression modele
+  REAL, DIMENSION (iip1,jjm,llm)     :: plvnc       !niveaux pression modele
+  REAL, DIMENSION (iip1,jjp1,llmp1)  :: p           ! pression intercouches 
+  REAL, DIMENSION (iip1,jjp1,llm)    :: pls, pext   ! var intermediaire
+  REAL, DIMENSION (iip1,jjp1,llm)    :: pbarx 
+  REAL, DIMENSION (iip1,jjm,llm)     :: pbary 
+  ! Variables pour fonction Exner (P milieu couche)
+  REAL, DIMENSION (iip1,jjp1,llm)    :: pk
+  REAL, DIMENSION (iip1,jjp1)        :: pks    
+  REAL                               :: prefkap,unskap
+  ! Pression de vapeur saturante
+  REAL, DIMENSION (ip1jmp1,llm)      :: qsat
+  !Variables intermediaires interpolation
+  REAL, DIMENSION (iip1,jjp1,llm)    :: zu1,zu2 
+  REAL, DIMENSION (iip1,jjm,llm)     :: zv1,zv2
+  
+  INTEGER                            :: i,j,l,ij
+  CHARACTER(LEN=20),PARAMETER :: modname="guide_interp"
+  
+    write(*,*)trim(modname)//': interpolate nudging variables'
+! -----------------------------------------------------------------
+! Calcul des niveaux de pression champs guidage
+! -----------------------------------------------------------------
+if (guide_modele) then
+    do i=1,iip1
+        do j=1,jjp1
+            do l=1,nlevnc
+                plnc2(i,j,l)=apnc(l)+bpnc(l)*psnat2(i,j)
+                plnc1(i,j,l)=apnc(l)+bpnc(l)*psnat1(i,j)
+            enddo
+        enddo
+    enddo
+else
+    do i=1,iip1
+        do j=1,jjp1
+            do l=1,nlevnc
+                plnc2(i,j,l)=apnc(l)
+                plnc1(i,j,l)=apnc(l)
+           enddo
+        enddo
+    enddo
+
+endif
+    if (first) then
+        first=.FALSE.
+        write(*,*)trim(modname)//' : check vertical level order'
+        write(*,*)trim(modname)//' LMDZ :'
+        do l=1,llm
+          write(*,*)trim(modname)//' PL(',l,')=',(ap(l)+ap(l+1))/2. &
+                  +psi(1,jjp1)*(bp(l)+bp(l+1))/2.
+        enddo
+        write(*,*)trim(modname)//' nudging file :'
+        do l=1,nlevnc
+          write(*,*)trim(modname)//' PL(',l,')=',plnc2(1,1,l)
+        enddo
+        write(*,*)trim(modname)//' invert ordering: invert_p=',invert_p
+        if (guide_u) then
+            do l=1,nlevnc
+              write(*,*)trim(modname)//' U(',l,')=',unat2(1,1,l)
+            enddo
+        endif
+        if (guide_T) then
+            do l=1,nlevnc
+              write(*,*)trim(modname)//' T(',l,')=',tnat2(1,1,l)
+            enddo
+        endif
+    endif
+    
+! -----------------------------------------------------------------
+! Calcul niveaux pression modele 
+! -----------------------------------------------------------------
+    CALL pression( ip1jmp1, ap, bp, psi, p )
+    if (pressure_exner) then
+      CALL exner_hyb(ip1jmp1,psi,p,pks,pk)
+    else
+      CALL exner_milieu(ip1jmp1,psi,p,pks,pk)
+    endif
+!    ....  Calcul de pls , pression au milieu des couches ,en Pascals
+    unskap=1./kappa
+    prefkap =  preff  ** kappa
+    DO l = 1, llm
+        DO j=1,jjp1
+            DO i =1, iip1
+                pls(i,j,l) = preff * ( pk(i,j,l)/cpp) ** unskap
+            ENDDO
+        ENDDO
+    ENDDO
+
+!   calcul des pressions pour les grilles u et v
+    do l=1,llm
+        do j=1,jjp1
+            do i=1,iip1
+                pext(i,j,l)=pls(i,j,l)*aire(i,j)
+            enddo
+        enddo
+    enddo
+    call massbar(pext, pbarx, pbary )
+    do l=1,llm
+        do j=1,jjp1
+            do i=1,iip1
+                plunc(i,j,l)=pbarx(i,j,l)/aireu(i,j)
+                plsnc(i,j,l)=pls(i,j,l)
+            enddo
+        enddo
+    enddo
+    do l=1,llm
+        do j=1,jjm
+            do i=1,iip1
+                plvnc(i,j,l)=pbary(i,j,l)/airev(i,j)
+            enddo
+        enddo
+    enddo
+
+! -----------------------------------------------------------------
+! Interpolation champs guidage sur niveaux modele (+inversion N/S)
+! Conversion en variables gcm (ucov, vcov...)
+! -----------------------------------------------------------------
+    if (guide_P) then
+        do j=1,jjp1
+            do i=1,iim
+                ij=(j-1)*iip1+i
+                psgui1(ij)=psnat1(i,j)
+                psgui2(ij)=psnat2(i,j)
+            enddo
+            psgui1(iip1*j)=psnat1(1,j)
+            psgui2(iip1*j)=psnat2(1,j)
+        enddo
+    endif
+
+    IF (guide_u) THEN
+        CALL pres2lev(unat1,zu1,nlevnc,llm,plnc1,plunc,iip1,jjp1,invert_p)
+        CALL pres2lev(unat2,zu2,nlevnc,llm,plnc2,plunc,iip1,jjp1,invert_p)
+        do l=1,llm
+            do j=1,jjp1
+                do i=1,iim
+                    ij=(j-1)*iip1+i
+                    ugui1(ij,l)=zu1(i,j,l)*cu(i,j)
+                    ugui2(ij,l)=zu2(i,j,l)*cu(i,j)
+                enddo
+                ugui1(j*iip1,l)=ugui1((j-1)*iip1+1,l)    
+                ugui2(j*iip1,l)=ugui2((j-1)*iip1+1,l)    
+            enddo
+            do i=1,iip1
+                ugui1(i,l)=0.
+                ugui1(ip1jm+i,l)=0.
+                ugui2(i,l)=0.
+                ugui2(ip1jm+i,l)=0.
+            enddo
+        enddo
+    ENDIF
+    
+    IF (guide_T) THEN
+        CALL pres2lev(tnat1,zu1,nlevnc,llm,plnc1,plsnc,iip1,jjp1,invert_p)
+        CALL pres2lev(tnat2,zu2,nlevnc,llm,plnc2,plsnc,iip1,jjp1,invert_p)
+        do l=1,llm
+            do j=1,jjp1
+                IF (guide_teta) THEN
+                    do i=1,iim
+                        ij=(j-1)*iip1+i
+                        tgui1(ij,l)=zu1(i,j,l)
+                        tgui2(ij,l)=zu2(i,j,l)
+                    enddo
+                ELSE
+                    do i=1,iim
+                        ij=(j-1)*iip1+i
+                        tgui1(ij,l)=zu1(i,j,l)*cpp/pk(i,j,l)
+                        tgui2(ij,l)=zu2(i,j,l)*cpp/pk(i,j,l)
+                    enddo
+                ENDIF
+                tgui1(j*iip1,l)=tgui1((j-1)*iip1+1,l)    
+                tgui2(j*iip1,l)=tgui2((j-1)*iip1+1,l)    
+            enddo
+            do i=1,iip1
+                tgui1(i,l)=tgui1(1,l)
+                tgui1(ip1jm+i,l)=tgui1(ip1jm+1,l) 
+                tgui2(i,l)=tgui2(1,l)
+                tgui2(ip1jm+i,l)=tgui2(ip1jm+1,l) 
+            enddo
+        enddo
+    ENDIF
+
+    IF (guide_v) THEN
+
+        CALL pres2lev(vnat1,zv1,nlevnc,llm,plnc1(:,:jjm,:),plvnc,iip1,jjm,invert_p)
+        CALL pres2lev(vnat2,zv2,nlevnc,llm,plnc2(:,:jjm,:),plvnc,iip1,jjm,invert_p)
+
+        do l=1,llm
+            do j=1,jjm
+                do i=1,iim
+                    ij=(j-1)*iip1+i
+                    vgui1(ij,l)=zv1(i,j,l)*cv(i,j)
+                    vgui2(ij,l)=zv2(i,j,l)*cv(i,j)
+                enddo
+                vgui1(j*iip1,l)=vgui1((j-1)*iip1+1,l)    
+                vgui2(j*iip1,l)=vgui2((j-1)*iip1+1,l)    
+            enddo
+        enddo
+    ENDIF
+    
+    IF (guide_Q) THEN
+        ! On suppose qu'on a la bonne variable dans le fichier de guidage:
+        ! Hum.Rel si guide_hr, Hum.Spec. sinon.
+        CALL pres2lev(qnat1,zu1,nlevnc,llm,plnc1,plsnc,iip1,jjp1,invert_p)
+        CALL pres2lev(qnat2,zu2,nlevnc,llm,plnc2,plsnc,iip1,jjp1,invert_p)
+        do l=1,llm
+            do j=1,jjp1
+                do i=1,iim
+                    ij=(j-1)*iip1+i
+                    qgui1(ij,l)=zu1(i,j,l)
+                    qgui2(ij,l)=zu2(i,j,l)
+                enddo
+                qgui1(j*iip1,l)=qgui1((j-1)*iip1+1,l)    
+                qgui2(j*iip1,l)=qgui2((j-1)*iip1+1,l)    
+            enddo
+            do i=1,iip1
+                qgui1(i,l)=qgui1(1,l)
+                qgui1(ip1jm+i,l)=qgui1(ip1jm+1,l) 
+                qgui2(i,l)=qgui2(1,l)
+                qgui2(ip1jm+i,l)=qgui2(ip1jm+1,l) 
+            enddo
+        enddo
+        IF (guide_hr) THEN
+            CALL q_sat(iip1*jjp1*llm,teta*pk/cpp,plsnc,qsat)
+            qgui1=qgui1*qsat*0.01 !hum. rel. en %
+            qgui2=qgui2*qsat*0.01 
+        ENDIF
+    ENDIF
+
+  END SUBROUTINE guide_interp
+
+!=======================================================================
+  SUBROUTINE tau2alpha(typ,pim,pjm,factt,taumin,taumax,alpha)
+
+! Calcul des constantes de rappel alpha (=1/tau)
+
+    use comconst_mod, only: pi
+    use serre_mod, only: clon, clat, grossismx, grossismy
+    
+    implicit none
+
+    include "dimensions.h"
+    include "paramet.h"
+    include "comgeom2.h"
+
+! input arguments :
+    INTEGER, INTENT(IN) :: typ    ! u(2),v(3), ou scalaire(1)
+    INTEGER, INTENT(IN) :: pim,pjm ! dimensions en lat, lon
+    REAL, INTENT(IN)    :: factt   ! pas de temps en fraction de jour
+    REAL, INTENT(IN)    :: taumin,taumax
+! output arguments:
+    REAL, DIMENSION(pim,pjm), INTENT(OUT) :: alpha 
+  
+!  local variables:
+    LOGICAL, SAVE               :: first=.TRUE.
+    REAL, SAVE                  :: gamma,dxdy_min,dxdy_max
+    REAL, DIMENSION (iip1,jjp1) :: zdx,zdy
+    REAL, DIMENSION (iip1,jjp1) :: dxdys,dxdyu
+    REAL, DIMENSION (iip1,jjm)  :: dxdyv
+    real dxdy_
+    real zlat,zlon
+    real alphamin,alphamax,xi
+    integer i,j,ilon,ilat
+    character(len=20),parameter :: modname="tau2alpha"
+    CHARACTER (len = 80)   :: abort_message
+
+
+    alphamin=factt/taumax
+    alphamax=factt/taumin
+    IF (guide_reg.OR.guide_add) THEN
+        alpha=alphamax
+!-----------------------------------------------------------------------
+! guide_reg: alpha=alpha_min dans region, 0. sinon.
+!-----------------------------------------------------------------------
+        IF (guide_reg) THEN
+            do j=1,pjm
+                do i=1,pim
+                    if (typ.eq.2) then
+                       zlat=rlatu(j)*180./pi
+                       zlon=rlonu(i)*180./pi
+                    elseif (typ.eq.1) then
+                       zlat=rlatu(j)*180./pi
+                       zlon=rlonv(i)*180./pi
+                    elseif (typ.eq.3) then
+                       zlat=rlatv(j)*180./pi
+                       zlon=rlonv(i)*180./pi
+                    endif
+                    alpha(i,j)=alphamax/16.* &
+                              (1.+tanh((zlat-lat_min_g)/tau_lat))* &
+                              (1.+tanh((lat_max_g-zlat)/tau_lat))* &
+                              (1.+tanh((zlon-lon_min_g)/tau_lon))* &
+                              (1.+tanh((lon_max_g-zlon)/tau_lon))
+                enddo
+            enddo
+        ENDIF
+    ELSE
+!-----------------------------------------------------------------------
+! Sinon, alpha varie entre alpha_min et alpha_max suivant le zoom.
+!-----------------------------------------------------------------------
+!Calcul de l'aire des mailles
+        do j=2,jjm
+            do i=2,iip1
+               zdx(i,j)=0.5*(cu(i-1,j)+cu(i,j))/cos(rlatu(j))
+            enddo
+            zdx(1,j)=zdx(iip1,j)
+        enddo
+        do j=2,jjm
+            do i=1,iip1
+               zdy(i,j)=0.5*(cv(i,j-1)+cv(i,j))
+            enddo
+        enddo
+        do i=1,iip1
+            zdx(i,1)=zdx(i,2)
+            zdx(i,jjp1)=zdx(i,jjm)
+            zdy(i,1)=zdy(i,2)
+            zdy(i,jjp1)=zdy(i,jjm)
+        enddo
+        do j=1,jjp1
+            do i=1,iip1
+               dxdys(i,j)=sqrt(zdx(i,j)*zdx(i,j)+zdy(i,j)*zdy(i,j))
+            enddo
+        enddo
+        IF (typ.EQ.2) THEN
+            do j=1,jjp1
+                do i=1,iim
+                   dxdyu(i,j)=0.5*(dxdys(i,j)+dxdys(i+1,j))
+                enddo
+                dxdyu(iip1,j)=dxdyu(1,j)
+            enddo
+        ENDIF
+        IF (typ.EQ.3) THEN
+            do j=1,jjm
+                do i=1,iip1
+                   dxdyv(i,j)=0.5*(dxdys(i,j)+dxdys(i,j+1))
+                enddo
+            enddo
+        ENDIF
+! Premier appel: calcul des aires min et max et de gamma.
+        IF (first) THEN 
+            first=.FALSE.
+            ! coordonnees du centre du zoom
+            CALL coordij(clon,clat,ilon,ilat) 
+            ! aire de la maille au centre du zoom
+            dxdy_min=dxdys(ilon,ilat)
+            ! dxdy maximale de la maille
+            dxdy_max=0.
+            do j=1,jjp1
+                do i=1,iip1
+                     dxdy_max=max(dxdy_max,dxdys(i,j))
+                enddo
+            enddo
+            ! Calcul de gamma
+            if (abs(grossismx-1.).lt.0.1.or.abs(grossismy-1.).lt.0.1) then
+              write(*,*)trim(modname)//' ATTENTION modele peu zoome'
+              write(*,*)trim(modname)//' ATTENTION on prend une constante de guidage cste'
+              gamma=0.
+            else
+              gamma=(dxdy_max-2.*dxdy_min)/(dxdy_max-dxdy_min)
+              write(*,*)trim(modname)//' gamma=',gamma
+              if (gamma.lt.1.e-5) then
+                write(*,*)trim(modname)//' gamma =',gamma,'<1e-5'
+                abort_message='stopped'
+                CALL abort_gcm(modname,abort_message,1)
+              endif
+              gamma=log(0.5)/log(gamma)
+              if (gamma4) then 
+                gamma=min(gamma,4.)
+              endif
+              write(*,*)trim(modname)//' gamma=',gamma
+            endif
+        ENDIF !first
+
+        do j=1,pjm
+            do i=1,pim
+                if (typ.eq.1) then
+                   dxdy_=dxdys(i,j)
+                   zlat=rlatu(j)*180./pi
+                elseif (typ.eq.2) then
+                   dxdy_=dxdyu(i,j)
+                   zlat=rlatu(j)*180./pi
+                elseif (typ.eq.3) then
+                   dxdy_=dxdyv(i,j)
+                   zlat=rlatv(j)*180./pi
+                endif
+                if (abs(grossismx-1.).lt.0.1.or.abs(grossismy-1.).lt.0.1) then
+                ! pour une grille reguliere, xi=xxx**0=1 -> alpha=alphamin
+                    alpha(i,j)=alphamin
+                else
+                    xi=((dxdy_max-dxdy_)/(dxdy_max-dxdy_min))**gamma
+                    xi=min(xi,1.)
+                    if(lat_min_g.le.zlat .and. zlat.le.lat_max_g) then
+                        alpha(i,j)=xi*alphamin+(1.-xi)*alphamax
+                    else
+                        alpha(i,j)=0.
+                    endif
+                endif
+            enddo
+        enddo
+    ENDIF ! guide_reg
+
+    if (.not. guide_add) alpha = 1. - exp(- alpha)
+
+  END SUBROUTINE tau2alpha
+
+!=======================================================================
+  SUBROUTINE guide_read(timestep)
+
+    use netcdf, only: NF90_GET_VAR, nf90_noerr
+
+    IMPLICIT NONE
+
+    include "dimensions.h"
+    include "paramet.h"
+
+    INTEGER, INTENT(IN)   :: timestep
+
+    LOGICAL, SAVE         :: first=.TRUE.
+! Identification fichiers et variables NetCDF:
+    INTEGER, SAVE         :: ncidu,varidu,ncidv,varidv,ncidp,varidp
+    INTEGER, SAVE         :: ncidQ,varidQ,ncidt,varidt,ncidps,varidps
+    INTEGER               :: ncidpl,varidpl,varidap,varidbp,dimid,lendim
+! Variables auxiliaires NetCDF:
+    INTEGER, DIMENSION(4) :: start,count
+    INTEGER               :: status,rcode
+    CHARACTER (len = 80)   :: abort_message
+    CHARACTER (len = 20)   :: modname = 'guide_read'
+    CHARACTER (len = 20)   :: namedim
+
+! -----------------------------------------------------------------
+! Premier appel: initialisation de la lecture des fichiers
+! -----------------------------------------------------------------
+    if (first) then
+         ncidpl=-99
+         write(*,*) trim(modname)//': opening nudging files '
+! Niveaux de pression si non constants
+         if (guide_plevs.EQ.1) then
+             write(*,*) trim(modname)//' Reading nudging on model levels'
+             rcode = nf90_open('apbp.nc', nf90_nowrite, ncidpl)
+             IF (rcode.NE.NF90_NOERR) THEN
+              abort_message='Nudging: error -> no file apbp.nc'
+              CALL abort_gcm(modname,abort_message,1)
+             ENDIF
+             rcode = nf90_inq_varid(ncidpl, 'AP', varidap)
+             IF (rcode.NE.NF90_NOERR) THEN
+              abort_message='Nudging: error -> no AP variable in file apbp.nc'
+              CALL abort_gcm(modname,abort_message,1)
+             ENDIF
+             rcode = nf90_inq_varid(ncidpl, 'BP', varidbp)
+             IF (rcode.NE.NF90_NOERR) THEN
+              abort_message='Nudging: error -> no BP variable in file apbp.nc'
+              CALL abort_gcm(modname,abort_message,1)
+             ENDIF
+             write(*,*) trim(modname)//' ncidpl,varidap',ncidpl,varidap
+         endif
+
+! Pression si guidage sur niveaux P variables
+         if (guide_plevs.EQ.2) then
+             rcode = nf90_open('P.nc', nf90_nowrite, ncidp)
+             IF (rcode.NE.NF90_NOERR) THEN
+              abort_message='Nudging: error -> no file P.nc'
+              CALL abort_gcm(modname,abort_message,1)
+             ENDIF
+             rcode = nf90_inq_varid(ncidp, 'PRES', varidp)
+             IF (rcode.NE.NF90_NOERR) THEN 
+              abort_message='Nudging: error -> no PRES variable in file P.nc'
+              CALL abort_gcm(modname,abort_message,1)
+             ENDIF
+             write(*,*) trim(modname)//' ncidp,varidp',ncidp,varidp
+             if (ncidpl.eq.-99) ncidpl=ncidp
+         endif
+
+! Vent zonal
+         if (guide_u) then
+             rcode = nf90_open('u.nc', nf90_nowrite, ncidu)
+             IF (rcode.NE.NF90_NOERR) THEN
+              abort_message='Nudging: error -> no file u.nc'
+              CALL abort_gcm(modname,abort_message,1)
+             ENDIF
+             rcode = nf90_inq_varid(ncidu, 'UWND', varidu)
+             IF (rcode.NE.NF90_NOERR) THEN
+              abort_message='Nudging: error -> no UWND variable in file u.nc'
+              CALL abort_gcm(modname,abort_message,1)
+             ENDIF
+             write(*,*) trim(modname)//' ncidu,varidu',ncidu,varidu
+             if (ncidpl.eq.-99) ncidpl=ncidu
+
+             status=NF90_INQ_DIMID(ncidu, "LONU", dimid)
+             status=NF90_INQUIRE_DIMENSION(ncidu,dimid,namedim,lendim)
+             IF (lendim .NE. iip1) THEN
+                abort_message='dimension LONU different from iip1 in u.nc'
+                CALL abort_gcm(modname,abort_message,1)
+             ENDIF
+
+             status=NF90_INQ_DIMID(ncidu, "LATU", dimid)
+             status=NF90_INQUIRE_DIMENSION(ncidu,dimid,namedim,lendim)
+             IF (lendim .NE. jjp1) THEN
+                abort_message='dimension LATU different from jjp1 in u.nc'
+                CALL abort_gcm(modname,abort_message,1)
+             ENDIF
+
+         endif
+
+! Vent meridien
+         if (guide_v) then
+             rcode = nf90_open('v.nc', nf90_nowrite, ncidv)
+             IF (rcode.NE.NF90_NOERR) THEN
+              abort_message='Nudging: error -> no file v.nc'
+              CALL abort_gcm(modname,abort_message,1)
+             ENDIF
+             rcode = nf90_inq_varid(ncidv, 'VWND', varidv)
+             IF (rcode.NE.NF90_NOERR) THEN
+              abort_message='Nudging: error -> no VWND variable in file v.nc'
+              CALL abort_gcm(modname,abort_message,1)
+             ENDIF
+             write(*,*) trim(modname)//' ncidv,varidv',ncidv,varidv
+             if (ncidpl.eq.-99) ncidpl=ncidv
+             
+             status=NF90_INQ_DIMID(ncidv, "LONV", dimid)
+             status=NF90_INQUIRE_DIMENSION(ncidv,dimid,namedim,lendim)
+             
+                IF (lendim .NE. iip1) THEN
+                abort_message='dimension LONV different from iip1 in v.nc'
+                CALL abort_gcm(modname,abort_message,1)
+             ENDIF
+
+
+             status=NF90_INQ_DIMID(ncidv, "LATV", dimid)
+             status=NF90_INQUIRE_DIMENSION(ncidv,dimid,namedim,lendim)
+             IF (lendim .NE. jjm) THEN
+                abort_message='dimension LATV different from jjm in v.nc'
+                CALL abort_gcm(modname,abort_message,1)
+             ENDIF
+        
+         endif
+
+! Temperature
+         if (guide_T) then
+             rcode = nf90_open('T.nc', nf90_nowrite, ncidt)
+             IF (rcode.NE.NF90_NOERR) THEN
+              abort_message='Nudging: error -> no file T.nc'
+              CALL abort_gcm(modname,abort_message,1)
+             ENDIF
+             rcode = nf90_inq_varid(ncidt, 'AIR', varidt)
+             IF (rcode.NE.NF90_NOERR) THEN
+              abort_message='Nudging: error -> no AIR variable in file T.nc'
+              CALL abort_gcm(modname,abort_message,1)
+             ENDIF
+             write(*,*) trim(modname)//' ncidT,varidT',ncidt,varidt
+             if (ncidpl.eq.-99) ncidpl=ncidt
+
+             status=NF90_INQ_DIMID(ncidt, "LONV", dimid)
+             status=NF90_INQUIRE_DIMENSION(ncidt,dimid,namedim,lendim)
+             IF (lendim .NE. iip1) THEN
+                abort_message='dimension LONV different from iip1 in T.nc'
+                CALL abort_gcm(modname,abort_message,1)
+             ENDIF
+
+             status=NF90_INQ_DIMID(ncidt, "LATU", dimid)
+             status=NF90_INQUIRE_DIMENSION(ncidt,dimid,namedim,lendim)
+             IF (lendim .NE. jjp1) THEN
+                abort_message='dimension LATU different from jjp1 in T.nc'
+                CALL abort_gcm(modname,abort_message,1)
+             ENDIF
+
+         endif
+
+! Humidite
+         if (guide_Q) then
+             rcode = nf90_open('hur.nc', nf90_nowrite, ncidQ)
+             IF (rcode.NE.NF90_NOERR) THEN
+              abort_message='Nudging: error -> no file hur.nc'
+              CALL abort_gcm(modname,abort_message,1)
+             ENDIF
+             rcode = nf90_inq_varid(ncidQ, 'RH', varidQ)
+             IF (rcode.NE.NF90_NOERR) THEN
+              abort_message='Nudging: error -> no RH variable in file hur.nc'
+              CALL abort_gcm(modname,abort_message,1)
+             ENDIF
+             write(*,*) trim(modname)//' ncidQ,varidQ',ncidQ,varidQ
+             if (ncidpl.eq.-99) ncidpl=ncidQ
+
+             status=NF90_INQ_DIMID(ncidQ, "LONV", dimid)
+             status=NF90_INQUIRE_DIMENSION(ncidQ,dimid,namedim,lendim)
+             IF (lendim .NE. iip1) THEN
+                abort_message='dimension LONV different from iip1 in hur.nc'
+                CALL abort_gcm(modname,abort_message,1)
+             ENDIF
+
+             status=NF90_INQ_DIMID(ncidQ, "LATU", dimid)
+             status=NF90_INQUIRE_DIMENSION(ncidQ,dimid,namedim,lendim)
+             IF (lendim .NE. jjp1) THEN
+                abort_message='dimension LATU different from jjp1 in hur.nc'
+                CALL abort_gcm(modname,abort_message,1)
+             ENDIF
+
+         endif
+
+! Pression de surface
+         if ((guide_P).OR.(guide_modele)) then
+             rcode = nf90_open('ps.nc', nf90_nowrite, ncidps)
+             IF (rcode.NE.NF90_NOERR) THEN
+              abort_message='Nudging: error -> no file ps.nc'
+              CALL abort_gcm(modname,abort_message,1)
+             ENDIF
+             rcode = nf90_inq_varid(ncidps, 'SP', varidps)
+             IF (rcode.NE.NF90_NOERR) THEN
+              abort_message='Nudging: error -> no SP variable in file ps.nc'
+              CALL abort_gcm(modname,abort_message,1)
+             ENDIF
+             write(*,*) trim(modname)//' ncidps,varidps',ncidps,varidps
+         endif
+! Coordonnee verticale
+         if (guide_plevs.EQ.0) then
+              rcode = nf90_inq_varid(ncidpl, 'LEVEL', varidpl)
+              IF (rcode.NE.0) rcode = nf90_inq_varid(ncidpl, 'PRESSURE', varidpl)
+              write(*,*) trim(modname)//' ncidpl,varidpl',ncidpl,varidpl
+         endif
+! Coefs ap, bp pour calcul de la pression aux differents niveaux
+         if (guide_plevs.EQ.1) then
+             status=NF90_GET_VAR(ncidpl,varidap,apnc,[1],[nlevnc])
+             status=NF90_GET_VAR(ncidpl,varidbp,bpnc,[1],[nlevnc])
+         ELSEIF (guide_plevs.EQ.0) THEN
+             status=NF90_GET_VAR(ncidpl,varidpl,apnc,[1],[nlevnc])
+!FC Pour les corrections la pression est deja en Pascals on commente la ligne ci-dessous
+             IF(convert_Pa) apnc=apnc*100.! conversion en Pascals
+             bpnc(:)=0.
+         endif
+         first=.FALSE.
+     endif ! (first)
+
+! -----------------------------------------------------------------
+!   lecture des champs u, v, T, Q, ps
+! -----------------------------------------------------------------
+
+!  dimensions pour les champs scalaires et le vent zonal
+     start(1)=1
+     start(2)=1
+     start(3)=1
+     start(4)=timestep
+
+     count(1)=iip1
+     count(2)=jjp1
+     count(3)=nlevnc
+     count(4)=1
+
+! Pression 
+     if (guide_plevs.EQ.2) then
+         status=NF90_GET_VAR(ncidp,varidp,pnat2,start,count)
+         IF (invert_y) THEN
+!           PRINT*,"Invertion impossible actuellement"
+!           CALL abort_gcm(modname,abort_message,1)
+           CALL invert_lat(iip1,jjp1,nlevnc,pnat2)
+         ENDIF
+     endif
+
+!  Vent zonal
+     if (guide_u) then
+         status=NF90_GET_VAR(ncidu,varidu,unat2,start,count)
+         IF (invert_y) THEN
+           CALL invert_lat(iip1,jjp1,nlevnc,unat2)
+         ENDIF
+     endif
+
+!  Temperature
+     if (guide_T) then
+         status=NF90_GET_VAR(ncidt,varidt,tnat2,start,count)
+         IF (invert_y) THEN
+           CALL invert_lat(iip1,jjp1,nlevnc,tnat2)
+         ENDIF
+     endif
+
+!  Humidite
+     if (guide_Q) then
+         status=NF90_GET_VAR(ncidQ,varidQ,qnat2,start,count)
+         IF (invert_y) THEN
+           CALL invert_lat(iip1,jjp1,nlevnc,qnat2)
+         ENDIF
+         
+     endif
+
+!  Vent meridien
+     if (guide_v) then
+         count(2)=jjm
+         status=NF90_GET_VAR(ncidv,varidv,vnat2,start,count)
+         IF (invert_y) THEN
+           CALL invert_lat(iip1,jjm,nlevnc,vnat2)
+         ENDIF
+     endif
+
+!  Pression de surface
+     if ((guide_P).OR.(guide_modele))  then
+         start(3)=timestep
+         start(4)=0
+         count(2)=jjp1
+         count(3)=1
+         count(4)=0
+         status=NF90_GET_VAR(ncidps,varidps,psnat2,start,count)
+         IF (invert_y) THEN
+           CALL invert_lat(iip1,jjp1,1,psnat2)
+         ENDIF
+     endif
+
+  END SUBROUTINE guide_read
+
+!=======================================================================
+  SUBROUTINE guide_read2D(timestep)
+
+    use netcdf, only: nf90_get_var, nf90_noerr
+
+    IMPLICIT NONE
+
+    include "dimensions.h"
+    include "paramet.h"
+
+    INTEGER, INTENT(IN)   :: timestep
+
+    LOGICAL, SAVE         :: first=.TRUE.
+! Identification fichiers et variables NetCDF:
+    INTEGER, SAVE         :: ncidu,varidu,ncidv,varidv,ncidp,varidp
+    INTEGER, SAVE         :: ncidQ,varidQ,ncidt,varidt,ncidps,varidps
+    INTEGER               :: ncidpl,varidpl,varidap,varidbp
+! Variables auxiliaires NetCDF:
+    INTEGER, DIMENSION(4) :: start,count
+    INTEGER               :: status,rcode
+! Variables for 3D extension:
+    REAL, DIMENSION (jjp1,llm) :: zu
+    REAL, DIMENSION (jjm,llm)  :: zv
+    INTEGER               :: i
+
+    CHARACTER (len = 80)   :: abort_message
+    CHARACTER (len = 20)   :: modname = 'guide_read2D'
+! -----------------------------------------------------------------
+! Premier appel: initialisation de la lecture des fichiers
+! -----------------------------------------------------------------
+    if (first) then
+         ncidpl=-99
+         write(*,*)trim(modname)//' : opening nudging files '
+! Ap et Bp si niveaux de pression hybrides
+         if (guide_plevs.EQ.1) then
+           write(*,*)trim(modname)//' Reading nudging on model levels'
+           rcode = nf90_open('apbp.nc', nf90_nowrite, ncidpl)
+           IF (rcode.NE.NF90_NOERR) THEN
+             abort_message='Nudging: error -> no file apbp.nc'
+           CALL abort_gcm(modname,abort_message,1)
+           ENDIF
+           rcode = nf90_inq_varid(ncidpl, 'AP', varidap)
+           IF (rcode.NE.NF90_NOERR) THEN
+             abort_message='Nudging: error -> no AP variable in file apbp.nc'
+           CALL abort_gcm(modname,abort_message,1)
+           ENDIF
+           rcode = nf90_inq_varid(ncidpl, 'BP', varidbp)
+           IF (rcode.NE.NF90_NOERR) THEN
+             abort_message='Nudging: error -> no BP variable in file apbp.nc'
+             CALL abort_gcm(modname,abort_message,1)
+           ENDIF
+           write(*,*)trim(modname)//'ncidpl,varidap',ncidpl,varidap
+         endif
+! Pression
+         if (guide_plevs.EQ.2) then
+           rcode = nf90_open('P.nc', nf90_nowrite, ncidp)
+           IF (rcode.NE.NF90_NOERR) THEN
+             abort_message='Nudging: error -> no file P.nc'
+             CALL abort_gcm(modname,abort_message,1)
+           ENDIF
+           rcode = nf90_inq_varid(ncidp, 'PRES', varidp)
+           IF (rcode.NE.NF90_NOERR) THEN
+             abort_message='Nudging: error -> no PRES variable in file P.nc'
+             CALL abort_gcm(modname,abort_message,1)
+           ENDIF
+           write(*,*)trim(modname)//' ncidp,varidp',ncidp,varidp
+           if (ncidpl.eq.-99) ncidpl=ncidp
+         endif
+! Vent zonal
+         if (guide_u) then
+           rcode = nf90_open('u.nc', nf90_nowrite, ncidu)
+           IF (rcode.NE.NF90_NOERR) THEN
+             abort_message='Nudging: error -> no file u.nc'
+             CALL abort_gcm(modname,abort_message,1)
+           ENDIF
+           rcode = nf90_inq_varid(ncidu, 'UWND', varidu)
+           IF (rcode.NE.NF90_NOERR) THEN
+             abort_message='Nudging: error -> no UWND variable in file u.nc'
+             CALL abort_gcm(modname,abort_message,1)
+           ENDIF
+           write(*,*)trim(modname)//' ncidu,varidu',ncidu,varidu
+           if (ncidpl.eq.-99) ncidpl=ncidu
+         endif
+! Vent meridien
+         if (guide_v) then
+           rcode = nf90_open('v.nc', nf90_nowrite, ncidv)
+           IF (rcode.NE.NF90_NOERR) THEN
+             abort_message='Nudging: error -> no file v.nc'
+             CALL abort_gcm(modname,abort_message,1)
+           ENDIF
+           rcode = nf90_inq_varid(ncidv, 'VWND', varidv)
+           IF (rcode.NE.NF90_NOERR) THEN
+             abort_message='Nudging: error -> no VWND variable in file v.nc'
+             CALL abort_gcm(modname,abort_message,1)
+           ENDIF
+           write(*,*)trim(modname)//' ncidv,varidv',ncidv,varidv
+           if (ncidpl.eq.-99) ncidpl=ncidv
+         endif
+! Temperature
+         if (guide_T) then
+           rcode = nf90_open('T.nc', nf90_nowrite, ncidt)
+           IF (rcode.NE.NF90_NOERR) THEN
+             abort_message='Nudging: error -> no file T.nc'
+             CALL abort_gcm(modname,abort_message,1)
+           ENDIF
+           rcode = nf90_inq_varid(ncidt, 'AIR', varidt)
+           IF (rcode.NE.NF90_NOERR) THEN
+             abort_message='Nudging: error -> no AIR variable in file T.nc'
+             CALL abort_gcm(modname,abort_message,1)
+           ENDIF
+           write(*,*)trim(modname)//' ncidT,varidT',ncidt,varidt
+           if (ncidpl.eq.-99) ncidpl=ncidt
+         endif
+! Humidite
+         if (guide_Q) then
+           rcode = nf90_open('hur.nc', nf90_nowrite, ncidQ)
+           IF (rcode.NE.NF90_NOERR) THEN
+             abort_message='Nudging: error -> no file hur.nc'
+             CALL abort_gcm(modname,abort_message,1)
+           ENDIF
+           rcode = nf90_inq_varid(ncidQ, 'RH', varidQ)
+           IF (rcode.NE.NF90_NOERR) THEN
+             abort_message='Nudging: error -> no RH,variable in file hur.nc'
+             CALL abort_gcm(modname,abort_message,1)
+           ENDIF
+           write(*,*)trim(modname)//' ncidQ,varidQ',ncidQ,varidQ
+           if (ncidpl.eq.-99) ncidpl=ncidQ
+         endif
+! Pression de surface
+         if ((guide_P).OR.(guide_modele)) then
+           rcode = nf90_open('ps.nc', nf90_nowrite, ncidps)
+           IF (rcode.NE.NF90_NOERR) THEN
+             abort_message='Nudging: error -> no file ps.nc'
+             CALL abort_gcm(modname,abort_message,1)
+           ENDIF
+           rcode = nf90_inq_varid(ncidps, 'SP', varidps)
+           IF (rcode.NE.NF90_NOERR) THEN
+             abort_message='Nudging: error -> no SP variable in file ps.nc'
+             CALL abort_gcm(modname,abort_message,1)
+           ENDIF
+           write(*,*)trim(modname)//' ncidps,varidps',ncidps,varidps
+         endif
+! Coordonnee verticale
+         if (guide_plevs.EQ.0) then
+           rcode = nf90_inq_varid(ncidpl, 'LEVEL', varidpl)
+           IF (rcode.NE.0) rcode = nf90_inq_varid(ncidpl, 'PRESSURE', varidpl)
+           write(*,*)trim(modname)//' ncidpl,varidpl',ncidpl,varidpl
+         endif
+! Coefs ap, bp pour calcul de la pression aux differents niveaux
+         if (guide_plevs.EQ.1) then
+             status=NF90_GET_VAR(ncidpl,varidap,apnc,[1],[nlevnc])
+             status=NF90_GET_VAR(ncidpl,varidbp,bpnc,[1],[nlevnc])
+         elseif (guide_plevs.EQ.0) THEN
+             status=NF90_GET_VAR(ncidpl,varidpl,apnc,[1],[nlevnc])
+             apnc=apnc*100.! conversion en Pascals
+             bpnc(:)=0.
+         endif
+         first=.FALSE.
+     endif ! (first)
+
+! -----------------------------------------------------------------
+!   lecture des champs u, v, T, Q, ps
+! -----------------------------------------------------------------
+
+!  dimensions pour les champs scalaires et le vent zonal
+     start(1)=1
+     start(2)=1
+     start(3)=1
+     start(4)=timestep
+
+     count(1)=1
+     count(2)=jjp1
+     count(3)=nlevnc
+     count(4)=1
+
+!  Pression
+     if (guide_plevs.EQ.2) then
+         status=NF90_GET_VAR(ncidp,varidp,zu,start,count)
+         DO i=1,iip1
+             pnat2(i,:,:)=zu(:,:)
+         ENDDO
+
+         IF (invert_y) THEN
+!           PRINT*,"Invertion impossible actuellement"
+!           CALL abort_gcm(modname,abort_message,1)
+           CALL invert_lat(iip1,jjp1,nlevnc,pnat2)
+         ENDIF
+     endif
+!  Vent zonal
+     if (guide_u) then
+         status=NF90_GET_VAR(ncidu,varidu,zu,start,count)
+         DO i=1,iip1
+             unat2(i,:,:)=zu(:,:)
+         ENDDO
+
+         IF (invert_y) THEN
+           CALL invert_lat(iip1,jjp1,nlevnc,unat2)
+         ENDIF
+
+     endif
+
+!  Temperature
+     if (guide_T) then
+         status=NF90_GET_VAR(ncidt,varidt,zu,start,count)
+         DO i=1,iip1
+             tnat2(i,:,:)=zu(:,:)
+         ENDDO
+
+         IF (invert_y) THEN
+           CALL invert_lat(iip1,jjp1,nlevnc,tnat2)
+         ENDIF
+
+     endif
+
+!  Humidite
+     if (guide_Q) then
+         status=NF90_GET_VAR(ncidQ,varidQ,zu,start,count)
+         DO i=1,iip1
+             qnat2(i,:,:)=zu(:,:)
+         ENDDO
+
+         IF (invert_y) THEN
+           CALL invert_lat(iip1,jjp1,nlevnc,qnat2)
+         ENDIF
+
+     endif
+
+!  Vent meridien
+     if (guide_v) then
+         count(2)=jjm
+         status=NF90_GET_VAR(ncidv,varidv,zv,start,count)
+         DO i=1,iip1
+             vnat2(i,:,:)=zv(:,:)
+         ENDDO
+
+         IF (invert_y) THEN
+           CALL invert_lat(iip1,jjm,nlevnc,vnat2)
+         ENDIF
+
+     endif
+
+!  Pression de surface
+     if ((guide_P).OR.(guide_plevs.EQ.1))  then
+         start(3)=timestep
+         start(4)=0
+         count(2)=jjp1
+         count(3)=1
+         count(4)=0
+         status=NF90_GET_VAR(ncidps,varidps,zu(:,1),start,count)
+         DO i=1,iip1
+             psnat2(i,:)=zu(:,1)
+         ENDDO
+
+         IF (invert_y) THEN
+           CALL invert_lat(iip1,jjp1,1,psnat2)
+         ENDIF
+
+     endif
+
+  END SUBROUTINE guide_read2D
+  
+!=======================================================================
+  SUBROUTINE guide_out(varname,hsize,vsize,field)
+
+    USE comconst_mod, ONLY: pi
+    USE comvert_mod, ONLY: presnivs
+    use netcdf95, only: nf95_def_var, nf95_put_var
+    use netcdf, only: nf90_float, nf90_def_var, nf90_put_var
+    
+    IMPLICIT NONE
+
+    INCLUDE "dimensions.h"
+    INCLUDE "paramet.h"
+    INCLUDE "netcdf.inc"
+    INCLUDE "comgeom2.h"
+    
+    ! Variables entree
+    CHARACTER*(*), INTENT(IN)                          :: varname
+    INTEGER,   INTENT (IN)                         :: hsize,vsize
+    REAL, DIMENSION (iip1,hsize,vsize), INTENT(IN) :: field
+
+    ! Variables locales
+    INTEGER, SAVE :: timestep=0
+    ! Identites fichier netcdf
+    INTEGER       :: nid, id_lonu, id_lonv, id_latu, id_latv, id_tim, id_lev
+    INTEGER       :: vid_lonu,vid_lonv,vid_latu,vid_latv,vid_cu,vid_cv,vid_lev
+    INTEGER       :: vid_au,vid_av, varid_alpha_t, varid_alpha_q
+    INTEGER, DIMENSION (3) :: dim3
+    INTEGER, DIMENSION (4) :: dim4,count,start
+    INTEGER                :: ierr, varid,l
+    REAL, DIMENSION (iip1,hsize,vsize) :: field2
+    CHARACTER(LEN=20),PARAMETER :: modname="guide_out"
+
+    write(*,*)trim(modname)//': output timestep',timestep,'var ',varname
+    IF (timestep.EQ.0) THEN 
+! ----------------------------------------------
+! initialisation fichier de sortie
+! ----------------------------------------------
+! Ouverture du fichier
+        ierr=NF_CREATE("guide_ins.nc",IOR(NF_CLOBBER,NF_64BIT_OFFSET),nid)
+! Definition des dimensions
+        ierr=NF_DEF_DIM(nid,"LONU",iip1,id_lonu) 
+        ierr=NF_DEF_DIM(nid,"LONV",iip1,id_lonv) 
+        ierr=NF_DEF_DIM(nid,"LATU",jjp1,id_latu) 
+        ierr=NF_DEF_DIM(nid,"LATV",jjm,id_latv) 
+        ierr=NF_DEF_DIM(nid,"LEVEL",llm,id_lev)
+        ierr=NF_DEF_DIM(nid,"TIME",NF_UNLIMITED,id_tim)
+
+! Creation des variables dimensions
+        ierr=NF90_DEF_VAR(nid,"LONU",NF90_FLOAT,id_lonu,vid_lonu)
+        ierr=NF90_DEF_VAR(nid,"LONV",NF90_FLOAT,id_lonv,vid_lonv)
+        ierr=NF90_DEF_VAR(nid,"LATU",NF90_FLOAT,id_latu,vid_latu)
+        ierr=NF90_DEF_VAR(nid,"LATV",NF90_FLOAT,id_latv,vid_latv)
+        ierr=NF90_DEF_VAR(nid,"LEVEL",NF90_FLOAT,id_lev,vid_lev)
+        ierr=NF90_DEF_VAR(nid,"cu",NF90_FLOAT,(/id_lonu,id_latu/),vid_cu)
+        ierr=NF90_DEF_VAR(nid,"cv",NF90_FLOAT,(/id_lonv,id_latv/),vid_cv)
+        ierr=NF90_DEF_VAR(nid,"au",NF90_FLOAT,(/id_lonu,id_latu/),vid_au)
+        ierr=NF90_DEF_VAR(nid,"av",NF90_FLOAT,(/id_lonv,id_latv/),vid_av)
+        call nf95_def_var(nid, "alpha_T", nf90_float, (/id_lonv, id_latu/), &
+             varid_alpha_t)
+        call nf95_def_var(nid, "alpha_q", nf90_float, (/id_lonv, id_latu/), &
+             varid_alpha_q)
+        
+        ierr=NF_ENDDEF(nid)
+
+! Enregistrement des variables dimensions
+
+         ierr = nf90_put_var(nid, vid_lonu, rlonu * 180. / pi)
+         ierr = nf90_put_var(nid, vid_lonv, rlonv * 180. / pi)
+         ierr = nf90_put_var(nid, vid_latu, rlatu * 180. / pi)
+         ierr = nf90_put_var(nid, vid_latv, rlatv * 180. / pi)
+         ierr = nf90_put_var(nid, vid_lev, presnivs)
+         ierr = nf90_put_var(nid, vid_cu, cu)
+         ierr = nf90_put_var(nid, vid_cv, cv)
+         ierr = nf90_put_var(nid, vid_au, alpha_u)
+         ierr = nf90_put_var(nid, vid_av, alpha_v)
+
+
+        call nf95_put_var(nid, varid_alpha_t, alpha_t)
+        call nf95_put_var(nid, varid_alpha_q, alpha_q)
+! --------------------------------------------------------------------
+! Cr�ation des variables sauvegard�es
+! --------------------------------------------------------------------
+        ierr = NF_REDEF(nid)
+! Pressure (GCM)
+        dim4=(/id_lonv,id_latu,id_lev,id_tim/)
+        ierr = NF90_DEF_VAR(nid,"SP",NF90_FLOAT,dim4,varid)
+! Surface pressure (guidage)
+        IF (guide_P) THEN
+            dim3=(/id_lonv,id_latu,id_tim/)
+            ierr = NF90_DEF_VAR(nid,"ps",NF90_FLOAT,dim3,varid)
+        ENDIF
+! Zonal wind
+        IF (guide_u) THEN
+            dim4=(/id_lonu,id_latu,id_lev,id_tim/)
+            ierr = NF90_DEF_VAR(nid,"u",NF90_FLOAT,dim4,varid)
+            ierr = NF90_DEF_VAR(nid,"ua",NF90_FLOAT,dim4,varid)
+            ierr = NF90_DEF_VAR(nid,"ucov",NF90_FLOAT,dim4,varid)
+        ENDIF
+! Merid. wind
+        IF (guide_v) THEN
+            dim4=(/id_lonv,id_latv,id_lev,id_tim/)
+            ierr = NF90_DEF_VAR(nid,"v",NF90_FLOAT,dim4,varid)
+            ierr = NF90_DEF_VAR(nid,"va",NF90_FLOAT,dim4,varid)
+            ierr = NF90_DEF_VAR(nid,"vcov",NF90_FLOAT,dim4,varid)
+        ENDIF
+! Pot. Temperature
+        IF (guide_T) THEN
+            dim4=(/id_lonv,id_latu,id_lev,id_tim/)
+            ierr = NF90_DEF_VAR(nid,"teta",NF90_FLOAT,dim4,varid)
+        ENDIF
+! Specific Humidity
+        IF (guide_Q) THEN
+            dim4=(/id_lonv,id_latu,id_lev,id_tim/)
+            ierr = NF90_DEF_VAR(nid,"q",NF90_FLOAT,dim4,varid)
+        ENDIF
+        
+        ierr = NF_ENDDEF(nid)
+        ierr = NF_CLOSE(nid)
+    ENDIF ! timestep=0
+
+! --------------------------------------------------------------------
+! Enregistrement du champ
+! --------------------------------------------------------------------
+    ierr=NF_OPEN("guide_ins.nc",NF_WRITE,nid)
+
+    IF (varname=="SP") timestep=timestep+1
+
+    ierr = NF_INQ_VARID(nid,varname,varid)
+    SELECT CASE (varname)
+    CASE ("SP","ps")
+        start=(/1,1,1,timestep/)
+        count=(/iip1,jjp1,llm,1/)
+    CASE ("v","va","vcov")
+        start=(/1,1,1,timestep/)
+        count=(/iip1,jjm,llm,1/)
+    CASE DEFAULT
+        start=(/1,1,1,timestep/)
+        count=(/iip1,jjp1,llm,1/)
+    END SELECT
+
+    SELECT CASE (varname)
+    CASE("u","ua")
+        DO l=1,llm ; field2(:,2:jjm,l)=field(:,2:jjm,l)/cu(:,2:jjm) ; ENDDO
+        field2(:,1,:)=0. ; field2(:,jjp1,:)=0.
+    CASE("v","va")
+        DO l=1,llm ; field2(:,:,l)=field(:,:,l)/cv(:,:) ; ENDDO
+    CASE DEFAULT
+        field2=field
+    END SELECT
+
+
+    ierr = nf90_put_var(nid, varid, field2, start, count)
+    ierr = NF_CLOSE(nid)
+
+  END SUBROUTINE guide_out
+    
+  
+!===========================================================================
+  subroutine correctbid(iim,nl,x)
+    integer iim,nl
+    real x(iim+1,nl)
+    integer i,l
+    real zz
+
+    do l=1,nl
+        do i=2,iim-1
+            if(abs(x(i,l)).gt.1.e10) then
+               zz=0.5*(x(i-1,l)+x(i+1,l))
+              print*,'correction ',i,l,x(i,l),zz
+               x(i,l)=zz
+            endif
+         enddo
+     enddo
+     return
+  end subroutine correctbid
+
+!===========================================================================
+END MODULE guide_mod
Index: DZ6/trunk/libf/dyn3d/iniacademic.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d/iniacademic.F90	(revision 5267)
+++ 	(revision )
@@ -1,373 +1,0 @@
-!
-! $Id$
-!
-SUBROUTINE iniacademic(vcov,ucov,teta,q,masse,ps,phis,time_0)
-
-  USE filtreg_mod, ONLY: inifilr
-  USE infotrac,    ONLY: nqtot, niso, iqIsoPha, tracers, isoName, addPhase
-  USE control_mod, ONLY: day_step,planet_type
-  use exner_hyb_m, only: exner_hyb
-  use exner_milieu_m, only: exner_milieu
-  USE IOIPSL, ONLY: getin
-
-  USE Write_Field
-  USE comconst_mod, ONLY: cpp, kappa, g, daysec, dtvr, pi, im, jm
-  USE logic_mod, ONLY: iflag_phys, read_start
-  USE comvert_mod, ONLY: ap, bp, preff, pa, presnivs, pressure_exner
-  USE temps_mod, ONLY: annee_ref, day_ini, day_ref
-  USE ener_mod, ONLY: etot0,ptot0,ztot0,stot0,ang0
-  use netcdf, only : NF90_NOWRITE,NF90_OPEN,NF90_NOERR,NF90_INQ_VARID
-  use netcdf, only : NF90_CLOSE, NF90_GET_VAR
-  USE iso_params_mod   ! tnat_* and alpha_ideal_*
-
-
-  !   Author:    Frederic Hourdin      original: 15/01/93
-  ! The forcing defined here is from Held and Suarez, 1994, Bulletin
-  ! of the American Meteorological Society, 75, 1825.
-
-  IMPLICIT NONE
-
-  !   Declararations:
-  !   ---------------
-
-  include "dimensions.h"
-  include "paramet.h"
-  include "comgeom.h"
-  include "academic.h"
-  include "iniprint.h"
-
-  !   Arguments:
-  !   ----------
-
-  REAL,INTENT(OUT) :: time_0
-
-  !   fields
-  REAL,INTENT(OUT) :: vcov(ip1jm,llm) ! meridional covariant wind
-  REAL,INTENT(OUT) :: ucov(ip1jmp1,llm) ! zonal covariant wind
-  REAL,INTENT(OUT) :: teta(ip1jmp1,llm) ! potential temperature (K)
-  REAL,INTENT(OUT) :: q(ip1jmp1,llm,nqtot) ! advected tracers (.../kg_of_air)
-  REAL,INTENT(OUT) :: ps(ip1jmp1) ! surface pressure (Pa)
-  REAL,INTENT(OUT) :: masse(ip1jmp1,llm) ! air mass in grid cell (kg)
-  REAL,INTENT(OUT) :: phis(ip1jmp1) ! surface geopotential
-
-  !   Local:
-  !   ------
-
-  REAL p (ip1jmp1,llmp1  )               ! pression aux interfac.des couches
-  REAL pks(ip1jmp1)                      ! exner au  sol
-  REAL pk(ip1jmp1,llm)                   ! exner au milieu des couches
-  REAL phi(ip1jmp1,llm)                  ! geopotentiel
-  REAL ddsin,zsig,tetapv,w_pv  ! variables auxiliaires
-  real tetastrat ! potential temperature in the stratosphere, in K
-  real tetajl(jjp1,llm)
-  INTEGER i,j,l,lsup,ij, iq, iName, iPhase, iqParent
-
-  integer :: nid_relief,varid,ierr
-  real, dimension(iip1,jjp1) :: relief
-
-  REAL teta0,ttp,delt_y,delt_z,eps ! Constantes pour profil de T
-  REAL k_f,k_c_a,k_c_s         ! Constantes de rappel
-  LOGICAL ok_geost             ! Initialisation vent geost. ou nul
-  LOGICAL ok_pv                ! Polar Vortex
-  REAL phi_pv,dphi_pv,gam_pv,tetanoise   ! Constantes pour polar vortex 
-
-  real zz,ran1
-  integer idum
-
-  REAL zdtvr, tnat, alpha_ideal
-  LOGICAL :: ltnat1
-  
-  character(len=*),parameter :: modname="iniacademic"
-  character(len=80) :: abort_message
-
-  ! Sanity check: verify that options selected by user are not incompatible
-  if ((iflag_phys==1).and. .not. read_start) then
-    write(lunout,*) trim(modname)," error: if read_start is set to ", &
-    " false then iflag_phys should not be 1"
-    write(lunout,*) "You most likely want an aquaplanet initialisation", &
-    " (iflag_phys >= 100)"
-    call abort_gcm(modname,"incompatible iflag_phys==1 and read_start==.false.",1)
-  endif
-  
-  !-----------------------------------------------------------------------
-  ! 1. Initializations for Earth-like case
-  ! --------------------------------------
-  !
-  ! initialize planet radius, rotation rate,...
-  call conf_planete
-
-  time_0=0.
-  day_ref=1
-  annee_ref=0
-
-  im         = iim
-  jm         = jjm
-  day_ini    = 1
-  dtvr    = daysec/REAL(day_step)
-  zdtvr=dtvr
-  etot0      = 0.
-  ptot0      = 0.
-  ztot0      = 0.
-  stot0      = 0.
-  ang0       = 0.
-
-  if (llm == 1) then
-     ! specific initializations for the shallow water case
-     kappa=1
-  endif
-
-  CALL iniconst
-  CALL inigeom
-  CALL inifilr
-
-
-  !------------------------------------------------------------------
-  ! Initialize pressure and mass field if read_start=.false.
-  !------------------------------------------------------------------
-
-  IF (.NOT. read_start) THEN
-
-     !------------------------------------------------------------------
-     ! Lecture eventuelle d'un fichier de relief interpollee sur la grille
-     ! du modele.
-     ! On suppose que le fichier relief_in.nc est stoké sur une grille
-     ! iim*jjp1
-     ! Facile a créer à partir de la commande
-     ! cdo remapcon,fichier_output_phys.nc Relief.nc relief_in.nc
-     !------------------------------------------------------------------
-
-     relief=0.
-     ierr = NF90_OPEN ('relief_in.nc', NF90_NOWRITE,nid_relief)
-     if (ierr.EQ.NF90_NOERR) THEN
-         ierr=NF90_INQ_VARID(nid_relief,'RELIEF',varid)
-         if (ierr==NF90_NOERR) THEN
-              ierr=NF90_GET_VAR(nid_relief,varid,relief(1:iim,1:jjp1))
-              relief(iip1,:)=relief(1,:)
-         else
-              CALL abort_gcm ('iniacademic','variable RELIEF pas la',1)
-         endif
-     endif
-     ierr = NF90_CLOSE (nid_relief)
-
-     !------------------------------------------------------------------
-     ! Initialisation du geopotentiel au sol et de la pression
-     !------------------------------------------------------------------
-
-     print*,'relief=',minval(relief),maxval(relief),'g=',g
-     do j=1,jjp1
-        do i=1,iip1
-           phis((j-1)*iip1+i)=g*relief(i,j)
-        enddo
-     enddo
-     print*,'phis=',minval(phis),maxval(phis),'g=',g
-
-     ! ground geopotential
-     !phis(:)=0.
-     ps(:)=preff
-     CALL pression ( ip1jmp1, ap, bp, ps, p       )
-
-     if (pressure_exner) then
-       CALL exner_hyb( ip1jmp1, ps, p, pks, pk)
-     else
-       call exner_milieu(ip1jmp1,ps,p,pks,pk)
-     endif
-     CALL massdair(p,masse)
-  ENDIF
-
-  if (llm == 1) then
-     ! initialize fields for the shallow water case, if required
-     if (.not.read_start) then
-        phis(:)=0.
-        q(:,:,:)=0
-        CALL sw_case_williamson91_6(vcov,ucov,teta,masse,ps)
-     endif
-  endif
-
-  academic_case: if (iflag_phys >= 2) then
-     ! initializations
-
-     ! 1. local parameters
-     ! by convention, winter is in the southern hemisphere
-     ! Geostrophic wind or no wind?
-     ok_geost=.TRUE.
-     CALL getin('ok_geost',ok_geost)
-     ! Constants for Newtonian relaxation and friction
-     k_f=1.                !friction 
-     CALL getin('k_j',k_f)
-     k_f=1./(daysec*k_f)
-     k_c_s=4.  !cooling surface
-     CALL getin('k_c_s',k_c_s)
-     k_c_s=1./(daysec*k_c_s)
-     k_c_a=40. !cooling free atm
-     CALL getin('k_c_a',k_c_a)
-     k_c_a=1./(daysec*k_c_a)
-     ! Constants for Teta equilibrium profile
-     teta0=315.     ! mean Teta (S.H. 315K)
-     CALL getin('teta0',teta0)
-     ttp=200.       ! Tropopause temperature (S.H. 200K)
-     CALL getin('ttp',ttp)
-     eps=0.         ! Deviation to N-S symmetry(~0-20K)
-     CALL getin('eps',eps)
-     delt_y=60.     ! Merid Temp. Gradient (S.H. 60K)
-     CALL getin('delt_y',delt_y)
-     delt_z=10.     ! Vertical Gradient (S.H. 10K)
-     CALL getin('delt_z',delt_z)
-     ! Polar vortex
-     ok_pv=.false.
-     CALL getin('ok_pv',ok_pv)
-     phi_pv=-50.            ! Latitude of edge of vortex
-     CALL getin('phi_pv',phi_pv)
-     phi_pv=phi_pv*pi/180.
-     dphi_pv=5.             ! Width of the edge
-     CALL getin('dphi_pv',dphi_pv)
-     dphi_pv=dphi_pv*pi/180.
-     gam_pv=4.              ! -dT/dz vortex (in K/km)
-     CALL getin('gam_pv',gam_pv)
-     tetanoise=0.005
-     CALL getin('tetanoise',tetanoise)
-
-     ! 2. Initialize fields towards which to relax
-     ! Friction
-     knewt_g=k_c_a
-     DO l=1,llm
-        zsig=presnivs(l)/preff
-        knewt_t(l)=(k_c_s-k_c_a)*MAX(0.,(zsig-0.7)/0.3)
-        kfrict(l)=k_f*MAX(0.,(zsig-0.7)/0.3)
-     ENDDO
-     DO j=1,jjp1
-        clat4((j-1)*iip1+1:j*iip1)=cos(rlatu(j))**4
-     ENDDO
-
-     ! Potential temperature 
-     DO l=1,llm
-        zsig=presnivs(l)/preff
-        tetastrat=ttp*zsig**(-kappa)
-        tetapv=tetastrat
-        IF ((ok_pv).AND.(zsig.LT.0.1)) THEN
-           tetapv=tetastrat*(zsig*10.)**(kappa*cpp*gam_pv/1000./g)
-        ENDIF
-        DO j=1,jjp1
-           ! Troposphere
-           ddsin=sin(rlatu(j))
-           tetajl(j,l)=teta0-delt_y*ddsin*ddsin+eps*ddsin &
-                -delt_z*(1.-ddsin*ddsin)*log(zsig)
-           if (planet_type=="giant") then
-             tetajl(j,l)=teta0+(delt_y*                   &
-                ((sin(rlatu(j)*3.14159*eps+0.0001))**2)   &
-                / ((rlatu(j)*3.14159*eps+0.0001)**2))     &
-                -delt_z*log(zsig)
-           endif
-           ! Profil stratospherique isotherme (+vortex)
-           w_pv=(1.-tanh((rlatu(j)-phi_pv)/dphi_pv))/2.
-           tetastrat=tetastrat*(1.-w_pv)+tetapv*w_pv             
-           tetajl(j,l)=MAX(tetajl(j,l),tetastrat)  
-        ENDDO
-     ENDDO
-
-     !          CALL writefield('theta_eq',tetajl)
-
-     do l=1,llm
-        do j=1,jjp1
-           do i=1,iip1
-              ij=(j-1)*iip1+i
-              tetarappel(ij,l)=tetajl(j,l)
-           enddo
-        enddo
-     enddo
-
-     ! 3. Initialize fields (if necessary)
-     IF (.NOT. read_start) THEN
-        ! bulk initialization of temperature
-        IF (iflag_phys>10000) THEN
-        ! Particular case to impose a constant temperature T0=0.01*iflag_physx
-           teta(:,:)= 0.01*iflag_phys/(pk(:,:)/cpp)
-        ELSE
-           teta(:,:)=tetarappel(:,:)
-        ENDIF
-        ! geopotential
-        CALL geopot(ip1jmp1,teta,pk,pks,phis,phi)
-
-        DO l=1,llm
-          print*,'presnivs,play,l',presnivs(l),(pk(1,l)/cpp)**(1./kappa)*preff
-         !pks(ij) = (cpp/preff) * ps(ij)
-         !pk(ij,1) = .5*pks(ij)
-         ! pk = cpp * (p/preff)^kappa
-        ENDDO
-
-        ! winds
-        if (ok_geost) then
-           call ugeostr(phi,ucov)
-        else
-           ucov(:,:)=0.
-        endif
-        vcov(:,:)=0.
-
-        ! bulk initialization of tracers
-        if (planet_type=="earth") then
-           ltnat1 = .TRUE.; CALL getin('tnateq1', ltnat1)
-           ! Earth: first two tracers will be water
-           do iq=1,nqtot
-              q(:,:,iq)=0.
-              IF(tracers(iq)%name == addPhase('H2O', 'g')) q(:,:,iq)=1.e-10
-              IF(tracers(iq)%name == addPhase('H2O', 'l')) q(:,:,iq)=1.e-15
-
-              ! CRisi: init des isotopes
-              ! distill de Rayleigh très simplifiée
-              iName    = tracers(iq)%iso_iName
-              if (niso <= 0 .OR. iName <= 0) CYCLE
-              iPhase   = tracers(iq)%iso_iPhase
-              iqParent = tracers(iq)%iqParent
-              IF(tracers(iq)%iso_iZone == 0) THEN
-                 IF(ltnat1) THEN
-                    tnat = 1.0
-                    alpha_ideal = 1.0
-                    WRITE(lunout, *)'In '//TRIM(modname)//': !!!  Beware: alpha_ideal put to 1  !!!'
-                 ELSE
-                    SELECT CASE(isoName(iName))
-                      CASE('H216O'); tnat = tnat_H216O; alpha_ideal = alpha_ideal_H216O
-                      CASE('H217O'); tnat = tnat_H217O; alpha_ideal = alpha_ideal_H217O
-                      CASE('H218O'); tnat = tnat_H218O; alpha_ideal = alpha_ideal_H218O
-                      CASE('HDO');   tnat = tnat_HDO;   alpha_ideal = alpha_ideal_HDO
-                      CASE('HTO');   tnat = tnat_HTO;   alpha_ideal = alpha_ideal_HTO
-                      CASE DEFAULT
-                         CALL abort_gcm(TRIM(modname),'unknown isotope "'//TRIM(isoName(iName))//'" ; check tracer.def file',1)
-                    END SELECT
-                 END IF
-                 q(:,:,iq) = q(:,:,iqParent)*tnat*(q(:,:,iqParent)/30.e-3)**(alpha_ideal-1.)
-              ELSE !IF(tracers(iq)%iso_iZone == 0) THEN
-                 IF(tracers(iq)%iso_iZone == 1) THEN
-                    ! correction le 14 mai 2024 pour que tous les traceurs soient de la couleur 1.
-                    ! Sinon, on va avoir des porblèmes de conservation de masse de traceurs.
-                    q(:,:,iq) = q(:,:,iqIsoPha(iName,iPhase))
-                 else !IF(tracers(iq)%iso_iZone == 1) THEN
-                    q(:,:,iq) = 0.
-                 endif !IF(tracers(iq)%iso_iZone == 1) THEN
-              END IF !IF(tracers(iq)%iso_iZone == 0) THEN
-           enddo
-        else
-           q(:,:,:)=0
-        endif ! of if (planet_type=="earth")
-
-        call check_isotopes_seq(q,1,ip1jmp1,'iniacademic_loc')
-
-        ! add random perturbation to temperature
-        idum  = -1
-        zz = ran1(idum)
-        idum  = 0
-        do l=1,llm
-           do ij=iip2,ip1jm
-              teta(ij,l)=teta(ij,l)*(1.+tetanoise*ran1(idum))
-           enddo
-        enddo
-
-        ! maintain periodicity in longitude
-        do l=1,llm
-           do ij=1,ip1jmp1,iip1
-              teta(ij+iim,l)=teta(ij,l)
-           enddo
-        enddo
-
-     ENDIF ! of IF (.NOT. read_start)
-  endif academic_case
-
-END SUBROUTINE iniacademic
Index: /LMDZ6/trunk/libf/dyn3d/iniacademic.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d/iniacademic.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3d/iniacademic.f90	(revision 5268)
@@ -0,0 +1,373 @@
+!
+! $Id$
+!
+SUBROUTINE iniacademic(vcov,ucov,teta,q,masse,ps,phis,time_0)
+
+  USE filtreg_mod, ONLY: inifilr
+  USE infotrac,    ONLY: nqtot, niso, iqIsoPha, tracers, isoName, addPhase
+  USE control_mod, ONLY: day_step,planet_type
+  use exner_hyb_m, only: exner_hyb
+  use exner_milieu_m, only: exner_milieu
+  USE IOIPSL, ONLY: getin
+
+  USE Write_Field
+  USE comconst_mod, ONLY: cpp, kappa, g, daysec, dtvr, pi, im, jm
+  USE logic_mod, ONLY: iflag_phys, read_start
+  USE comvert_mod, ONLY: ap, bp, preff, pa, presnivs, pressure_exner
+  USE temps_mod, ONLY: annee_ref, day_ini, day_ref
+  USE ener_mod, ONLY: etot0,ptot0,ztot0,stot0,ang0
+  use netcdf, only : NF90_NOWRITE,NF90_OPEN,NF90_NOERR,NF90_INQ_VARID
+  use netcdf, only : NF90_CLOSE, NF90_GET_VAR
+  USE iso_params_mod   ! tnat_* and alpha_ideal_*
+
+
+  !   Author:    Frederic Hourdin      original: 15/01/93
+  ! The forcing defined here is from Held and Suarez, 1994, Bulletin
+  ! of the American Meteorological Society, 75, 1825.
+
+  IMPLICIT NONE
+
+  !   Declararations:
+  !   ---------------
+
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom.h"
+  include "academic.h"
+  include "iniprint.h"
+
+  !   Arguments:
+  !   ----------
+
+  REAL,INTENT(OUT) :: time_0
+
+  !   fields
+  REAL,INTENT(OUT) :: vcov(ip1jm,llm) ! meridional covariant wind
+  REAL,INTENT(OUT) :: ucov(ip1jmp1,llm) ! zonal covariant wind
+  REAL,INTENT(OUT) :: teta(ip1jmp1,llm) ! potential temperature (K)
+  REAL,INTENT(OUT) :: q(ip1jmp1,llm,nqtot) ! advected tracers (.../kg_of_air)
+  REAL,INTENT(OUT) :: ps(ip1jmp1) ! surface pressure (Pa)
+  REAL,INTENT(OUT) :: masse(ip1jmp1,llm) ! air mass in grid cell (kg)
+  REAL,INTENT(OUT) :: phis(ip1jmp1) ! surface geopotential
+
+  !   Local:
+  !   ------
+
+  REAL p (ip1jmp1,llmp1  )               ! pression aux interfac.des couches
+  REAL pks(ip1jmp1)                      ! exner au  sol
+  REAL pk(ip1jmp1,llm)                   ! exner au milieu des couches
+  REAL phi(ip1jmp1,llm)                  ! geopotentiel
+  REAL ddsin,zsig,tetapv,w_pv  ! variables auxiliaires
+  real tetastrat ! potential temperature in the stratosphere, in K
+  real tetajl(jjp1,llm)
+  INTEGER i,j,l,lsup,ij, iq, iName, iPhase, iqParent
+
+  integer :: nid_relief,varid,ierr
+  real, dimension(iip1,jjp1) :: relief
+
+  REAL teta0,ttp,delt_y,delt_z,eps ! Constantes pour profil de T
+  REAL k_f,k_c_a,k_c_s         ! Constantes de rappel
+  LOGICAL ok_geost             ! Initialisation vent geost. ou nul
+  LOGICAL ok_pv                ! Polar Vortex
+  REAL phi_pv,dphi_pv,gam_pv,tetanoise   ! Constantes pour polar vortex 
+
+  real zz,ran1
+  integer idum
+
+  REAL zdtvr, tnat, alpha_ideal
+  LOGICAL :: ltnat1
+  
+  character(len=*),parameter :: modname="iniacademic"
+  character(len=80) :: abort_message
+
+  ! Sanity check: verify that options selected by user are not incompatible
+  if ((iflag_phys==1).and. .not. read_start) then
+    write(lunout,*) trim(modname)," error: if read_start is set to ", &
+    " false then iflag_phys should not be 1"
+    write(lunout,*) "You most likely want an aquaplanet initialisation", &
+    " (iflag_phys >= 100)"
+    call abort_gcm(modname,"incompatible iflag_phys==1 and read_start==.false.",1)
+  endif
+  
+  !-----------------------------------------------------------------------
+  ! 1. Initializations for Earth-like case
+  ! --------------------------------------
+  !
+  ! initialize planet radius, rotation rate,...
+  call conf_planete
+
+  time_0=0.
+  day_ref=1
+  annee_ref=0
+
+  im         = iim
+  jm         = jjm
+  day_ini    = 1
+  dtvr    = daysec/REAL(day_step)
+  zdtvr=dtvr
+  etot0      = 0.
+  ptot0      = 0.
+  ztot0      = 0.
+  stot0      = 0.
+  ang0       = 0.
+
+  if (llm == 1) then
+     ! specific initializations for the shallow water case
+     kappa=1
+  endif
+
+  CALL iniconst
+  CALL inigeom
+  CALL inifilr
+
+
+  !------------------------------------------------------------------
+  ! Initialize pressure and mass field if read_start=.false.
+  !------------------------------------------------------------------
+
+  IF (.NOT. read_start) THEN
+
+     !------------------------------------------------------------------
+     ! Lecture eventuelle d'un fichier de relief interpollee sur la grille
+     ! du modele.
+     ! On suppose que le fichier relief_in.nc est stoké sur une grille
+     ! iim*jjp1
+     ! Facile a créer à partir de la commande
+     ! cdo remapcon,fichier_output_phys.nc Relief.nc relief_in.nc
+     !------------------------------------------------------------------
+
+     relief=0.
+     ierr = NF90_OPEN ('relief_in.nc', NF90_NOWRITE,nid_relief)
+     if (ierr.EQ.NF90_NOERR) THEN
+         ierr=NF90_INQ_VARID(nid_relief,'RELIEF',varid)
+         if (ierr==NF90_NOERR) THEN
+              ierr=NF90_GET_VAR(nid_relief,varid,relief(1:iim,1:jjp1))
+              relief(iip1,:)=relief(1,:)
+         else
+              CALL abort_gcm ('iniacademic','variable RELIEF pas la',1)
+         endif
+     endif
+     ierr = NF90_CLOSE (nid_relief)
+
+     !------------------------------------------------------------------
+     ! Initialisation du geopotentiel au sol et de la pression
+     !------------------------------------------------------------------
+
+     print*,'relief=',minval(relief),maxval(relief),'g=',g
+     do j=1,jjp1
+        do i=1,iip1
+           phis((j-1)*iip1+i)=g*relief(i,j)
+        enddo
+     enddo
+     print*,'phis=',minval(phis),maxval(phis),'g=',g
+
+     ! ground geopotential
+     !phis(:)=0.
+     ps(:)=preff
+     CALL pression ( ip1jmp1, ap, bp, ps, p       )
+
+     if (pressure_exner) then
+       CALL exner_hyb( ip1jmp1, ps, p, pks, pk)
+     else
+       call exner_milieu(ip1jmp1,ps,p,pks,pk)
+     endif
+     CALL massdair(p,masse)
+  ENDIF
+
+  if (llm == 1) then
+     ! initialize fields for the shallow water case, if required
+     if (.not.read_start) then
+        phis(:)=0.
+        q(:,:,:)=0
+        CALL sw_case_williamson91_6(vcov,ucov,teta,masse,ps)
+     endif
+  endif
+
+  academic_case: if (iflag_phys >= 2) then
+     ! initializations
+
+     ! 1. local parameters
+     ! by convention, winter is in the southern hemisphere
+     ! Geostrophic wind or no wind?
+     ok_geost=.TRUE.
+     CALL getin('ok_geost',ok_geost)
+     ! Constants for Newtonian relaxation and friction
+     k_f=1.                !friction 
+     CALL getin('k_j',k_f)
+     k_f=1./(daysec*k_f)
+     k_c_s=4.  !cooling surface
+     CALL getin('k_c_s',k_c_s)
+     k_c_s=1./(daysec*k_c_s)
+     k_c_a=40. !cooling free atm
+     CALL getin('k_c_a',k_c_a)
+     k_c_a=1./(daysec*k_c_a)
+     ! Constants for Teta equilibrium profile
+     teta0=315.     ! mean Teta (S.H. 315K)
+     CALL getin('teta0',teta0)
+     ttp=200.       ! Tropopause temperature (S.H. 200K)
+     CALL getin('ttp',ttp)
+     eps=0.         ! Deviation to N-S symmetry(~0-20K)
+     CALL getin('eps',eps)
+     delt_y=60.     ! Merid Temp. Gradient (S.H. 60K)
+     CALL getin('delt_y',delt_y)
+     delt_z=10.     ! Vertical Gradient (S.H. 10K)
+     CALL getin('delt_z',delt_z)
+     ! Polar vortex
+     ok_pv=.false.
+     CALL getin('ok_pv',ok_pv)
+     phi_pv=-50.            ! Latitude of edge of vortex
+     CALL getin('phi_pv',phi_pv)
+     phi_pv=phi_pv*pi/180.
+     dphi_pv=5.             ! Width of the edge
+     CALL getin('dphi_pv',dphi_pv)
+     dphi_pv=dphi_pv*pi/180.
+     gam_pv=4.              ! -dT/dz vortex (in K/km)
+     CALL getin('gam_pv',gam_pv)
+     tetanoise=0.005
+     CALL getin('tetanoise',tetanoise)
+
+     ! 2. Initialize fields towards which to relax
+     ! Friction
+     knewt_g=k_c_a
+     DO l=1,llm
+        zsig=presnivs(l)/preff
+        knewt_t(l)=(k_c_s-k_c_a)*MAX(0.,(zsig-0.7)/0.3)
+        kfrict(l)=k_f*MAX(0.,(zsig-0.7)/0.3)
+     ENDDO
+     DO j=1,jjp1
+        clat4((j-1)*iip1+1:j*iip1)=cos(rlatu(j))**4
+     ENDDO
+
+     ! Potential temperature 
+     DO l=1,llm
+        zsig=presnivs(l)/preff
+        tetastrat=ttp*zsig**(-kappa)
+        tetapv=tetastrat
+        IF ((ok_pv).AND.(zsig.LT.0.1)) THEN
+           tetapv=tetastrat*(zsig*10.)**(kappa*cpp*gam_pv/1000./g)
+        ENDIF
+        DO j=1,jjp1
+           ! Troposphere
+           ddsin=sin(rlatu(j))
+           tetajl(j,l)=teta0-delt_y*ddsin*ddsin+eps*ddsin &
+                -delt_z*(1.-ddsin*ddsin)*log(zsig)
+           if (planet_type=="giant") then
+             tetajl(j,l)=teta0+(delt_y*                   &
+                ((sin(rlatu(j)*3.14159*eps+0.0001))**2)   &
+                / ((rlatu(j)*3.14159*eps+0.0001)**2))     &
+                -delt_z*log(zsig)
+           endif
+           ! Profil stratospherique isotherme (+vortex)
+           w_pv=(1.-tanh((rlatu(j)-phi_pv)/dphi_pv))/2.
+           tetastrat=tetastrat*(1.-w_pv)+tetapv*w_pv             
+           tetajl(j,l)=MAX(tetajl(j,l),tetastrat)  
+        ENDDO
+     ENDDO
+
+     !          CALL writefield('theta_eq',tetajl)
+
+     do l=1,llm
+        do j=1,jjp1
+           do i=1,iip1
+              ij=(j-1)*iip1+i
+              tetarappel(ij,l)=tetajl(j,l)
+           enddo
+        enddo
+     enddo
+
+     ! 3. Initialize fields (if necessary)
+     IF (.NOT. read_start) THEN
+        ! bulk initialization of temperature
+        IF (iflag_phys>10000) THEN
+        ! Particular case to impose a constant temperature T0=0.01*iflag_physx
+           teta(:,:)= 0.01*iflag_phys/(pk(:,:)/cpp)
+        ELSE
+           teta(:,:)=tetarappel(:,:)
+        ENDIF
+        ! geopotential
+        CALL geopot(ip1jmp1,teta,pk,pks,phis,phi)
+
+        DO l=1,llm
+          print*,'presnivs,play,l',presnivs(l),(pk(1,l)/cpp)**(1./kappa)*preff
+         !pks(ij) = (cpp/preff) * ps(ij)
+         !pk(ij,1) = .5*pks(ij)
+         ! pk = cpp * (p/preff)^kappa
+        ENDDO
+
+        ! winds
+        if (ok_geost) then
+           call ugeostr(phi,ucov)
+        else
+           ucov(:,:)=0.
+        endif
+        vcov(:,:)=0.
+
+        ! bulk initialization of tracers
+        if (planet_type=="earth") then
+           ltnat1 = .TRUE.; CALL getin('tnateq1', ltnat1)
+           ! Earth: first two tracers will be water
+           do iq=1,nqtot
+              q(:,:,iq)=0.
+              IF(tracers(iq)%name == addPhase('H2O', 'g')) q(:,:,iq)=1.e-10
+              IF(tracers(iq)%name == addPhase('H2O', 'l')) q(:,:,iq)=1.e-15
+
+              ! CRisi: init des isotopes
+              ! distill de Rayleigh très simplifiée
+              iName    = tracers(iq)%iso_iName
+              if (niso <= 0 .OR. iName <= 0) CYCLE
+              iPhase   = tracers(iq)%iso_iPhase
+              iqParent = tracers(iq)%iqParent
+              IF(tracers(iq)%iso_iZone == 0) THEN
+                 IF(ltnat1) THEN
+                    tnat = 1.0
+                    alpha_ideal = 1.0
+                    WRITE(lunout, *)'In '//TRIM(modname)//': !!!  Beware: alpha_ideal put to 1  !!!'
+                 ELSE
+                    SELECT CASE(isoName(iName))
+                      CASE('H216O'); tnat = tnat_H216O; alpha_ideal = alpha_ideal_H216O
+                      CASE('H217O'); tnat = tnat_H217O; alpha_ideal = alpha_ideal_H217O
+                      CASE('H218O'); tnat = tnat_H218O; alpha_ideal = alpha_ideal_H218O
+                      CASE('HDO');   tnat = tnat_HDO;   alpha_ideal = alpha_ideal_HDO
+                      CASE('HTO');   tnat = tnat_HTO;   alpha_ideal = alpha_ideal_HTO
+                      CASE DEFAULT
+                         CALL abort_gcm(TRIM(modname),'unknown isotope "'//TRIM(isoName(iName))//'" ; check tracer.def file',1)
+                    END SELECT
+                 END IF
+                 q(:,:,iq) = q(:,:,iqParent)*tnat*(q(:,:,iqParent)/30.e-3)**(alpha_ideal-1.)
+              ELSE !IF(tracers(iq)%iso_iZone == 0) THEN
+                 IF(tracers(iq)%iso_iZone == 1) THEN
+                    ! correction le 14 mai 2024 pour que tous les traceurs soient de la couleur 1.
+                    ! Sinon, on va avoir des porblèmes de conservation de masse de traceurs.
+                    q(:,:,iq) = q(:,:,iqIsoPha(iName,iPhase))
+                 else !IF(tracers(iq)%iso_iZone == 1) THEN
+                    q(:,:,iq) = 0.
+                 endif !IF(tracers(iq)%iso_iZone == 1) THEN
+              END IF !IF(tracers(iq)%iso_iZone == 0) THEN
+           enddo
+        else
+           q(:,:,:)=0
+        endif ! of if (planet_type=="earth")
+
+        call check_isotopes_seq(q,1,ip1jmp1,'iniacademic_loc')
+
+        ! add random perturbation to temperature
+        idum  = -1
+        zz = ran1(idum)
+        idum  = 0
+        do l=1,llm
+           do ij=iip2,ip1jm
+              teta(ij,l)=teta(ij,l)*(1.+tetanoise*ran1(idum))
+           enddo
+        enddo
+
+        ! maintain periodicity in longitude
+        do l=1,llm
+           do ij=1,ip1jmp1,iip1
+              teta(ij+iim,l)=teta(ij,l)
+           enddo
+        enddo
+
+     ENDIF ! of IF (.NOT. read_start)
+  endif academic_case
+
+END SUBROUTINE iniacademic
Index: DZ6/trunk/libf/dyn3d/logic_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d/logic_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,38 +1,0 @@
-!
-! $Id$
-!
-MODULE logic_mod
-
-IMPLICIT NONE
-
-  LOGICAL purmats ! true if time stepping is purely Matsuno scheme
-                  ! false implies Matsuno-Leapfrog time stepping scheme
-  LOGICAL forward ! true if during forward phase of Matsuno step
-  LOGICAL leapf ! true if during a leapfrog time stepping step
-  LOGICAL apphys ! true if during a time step when physics will be called
-  LOGICAL statcl
-  LOGICAL conser
-  LOGICAL apdiss ! true if during a time step when dissipation will be called
-  LOGICAL apdelq
-  LOGICAL saison
-  LOGICAL ecripar
-  LOGICAL fxyhypb ! true if using hyperbolic function discretization
-                  ! for latitudinal grid 
-  LOGICAL ysinus ! true if using sine function discretiation
-                 ! for latitudinal grid
-  LOGICAL read_start ! true if reading a start.nc file to initialize fields
-  LOGICAL ok_guide ! true if nudging
-  LOGICAL ok_strato
-  LOGICAL ok_gradsfile
-  LOGICAL ok_limit  ! true for boundary conditions file creation (limit.nc)
-  LOGICAL ok_etat0  ! true for initial states creation (start.nc, startphy.nc)
-  LOGICAL read_orop ! true for sub-cell scales orographic params read in file
-  LOGICAL hybrid ! vertical coordinate is hybrid if true (sigma otherwise)
-                 ! (only used if disvert_type==2)
-  LOGICAL adv_qsat_liq ! true if qsat is calculated alwats wrt liquid for
-                       ! adapted Van Leer advection scheme
-  INTEGER iflag_phys ! type of physics to call: 0 none, 1: phy*** package,
-                     ! 2: Held & Suarez, 101-200: aquaplanets & terraplanets
-  INTEGER iflag_trac
-
-END MODULE logic_mod
Index: /LMDZ6/trunk/libf/dyn3d/logic_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d/logic_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3d/logic_mod.f90	(revision 5268)
@@ -0,0 +1,38 @@
+!
+! $Id$
+!
+MODULE logic_mod
+
+IMPLICIT NONE
+
+  LOGICAL purmats ! true if time stepping is purely Matsuno scheme
+                  ! false implies Matsuno-Leapfrog time stepping scheme
+  LOGICAL forward ! true if during forward phase of Matsuno step
+  LOGICAL leapf ! true if during a leapfrog time stepping step
+  LOGICAL apphys ! true if during a time step when physics will be called
+  LOGICAL statcl
+  LOGICAL conser
+  LOGICAL apdiss ! true if during a time step when dissipation will be called
+  LOGICAL apdelq
+  LOGICAL saison
+  LOGICAL ecripar
+  LOGICAL fxyhypb ! true if using hyperbolic function discretization
+                  ! for latitudinal grid 
+  LOGICAL ysinus ! true if using sine function discretiation
+                 ! for latitudinal grid
+  LOGICAL read_start ! true if reading a start.nc file to initialize fields
+  LOGICAL ok_guide ! true if nudging
+  LOGICAL ok_strato
+  LOGICAL ok_gradsfile
+  LOGICAL ok_limit  ! true for boundary conditions file creation (limit.nc)
+  LOGICAL ok_etat0  ! true for initial states creation (start.nc, startphy.nc)
+  LOGICAL read_orop ! true for sub-cell scales orographic params read in file
+  LOGICAL hybrid ! vertical coordinate is hybrid if true (sigma otherwise)
+                 ! (only used if disvert_type==2)
+  LOGICAL adv_qsat_liq ! true if qsat is calculated alwats wrt liquid for
+                       ! adapted Van Leer advection scheme
+  INTEGER iflag_phys ! type of physics to call: 0 none, 1: phy*** package,
+                     ! 2: Held & Suarez, 101-200: aquaplanets & terraplanets
+  INTEGER iflag_trac
+
+END MODULE logic_mod
Index: DZ6/trunk/libf/dyn3d/mod_const_mpi.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d/mod_const_mpi.F90	(revision 5267)
+++ 	(revision )
@@ -1,16 +1,0 @@
-MODULE mod_const_mpi
-
-  INTEGER :: COMM_LMDZ
-  INTEGER :: MPI_REAL_LMDZ
- 
-
-CONTAINS 
-
-  SUBROUTINE Init_const_mpi
-  IMPLICIT NONE
-  
-    COMM_LMDZ=0
-    MPI_REAL_LMDZ=0
-  END SUBROUTINE Init_const_mpi
-
-END MODULE mod_const_mpi
Index: /LMDZ6/trunk/libf/dyn3d/mod_const_mpi.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d/mod_const_mpi.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3d/mod_const_mpi.f90	(revision 5268)
@@ -0,0 +1,16 @@
+MODULE mod_const_mpi
+
+  INTEGER :: COMM_LMDZ
+  INTEGER :: MPI_REAL_LMDZ
+ 
+
+CONTAINS 
+
+  SUBROUTINE Init_const_mpi
+  IMPLICIT NONE
+  
+    COMM_LMDZ=0
+    MPI_REAL_LMDZ=0
+  END SUBROUTINE Init_const_mpi
+
+END MODULE mod_const_mpi
Index: DZ6/trunk/libf/dyn3d/replay3d.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d/replay3d.F90	(revision 5267)
+++ 	(revision )
@@ -1,193 +1,0 @@
-!
-! $Id: gcm.F90 3579 2019-10-09 13:11:07Z fairhead $
-!
-!
-!
-PROGRAM replay3d
-
-
-
-USE comvert_mod, only :  preff, pa
-USE inigeomphy_mod, ONLY: inigeomphy
-
-
-  USE control_mod
-  USE temps_mod, ONLY: calend,start_time,annee_ref,day_ref, &
-                     itau_dyn,itau_phy,day_ini,jD_ref,jH_ref,day_end
-  USE comconst_mod, ONLY: cpp, daysec, dtphys, dtvr, g, r, rad
-  USE logic_mod, ONLY: ecripar, iflag_phys, read_start
-
-  USE serre_mod, ONLY : clon,clat,transx,transy,alphax,alphay,pxo,pyo,              &
-        grossismx, grossismy, dzoomx, dzoomy,taux,tauy
-  USE mod_const_mpi, ONLY: comm_lmdz
-
-
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-  ! FH 2008/05/09 On elimine toutes les clefs physiques dans la dynamique
-  ! A nettoyer. On ne veut qu'une ou deux routines d'interface 
-  ! dynamique -> physique pour l'initialisation
-  USE iniphysiq_mod, ONLY: iniphysiq
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-  IMPLICIT NONE
-
-  !      ......   Version  du 10/01/98    ..........
-
-  !             avec  coordonnees  verticales hybrides 
-  !   avec nouveaux operat. dissipation * ( gradiv2,divgrad2,nxgraro2 )
-
-  !=======================================================================
-  !
-  !   Auteur:  P. Le Van /L. Fairhead/F.Hourdin
-  !   -------
-  !
-  !   Objet:
-  !   ------
-  !
-  !   GCM LMD nouvelle grille
-  !
-  !=======================================================================
-  !
-  !  ... Dans inigeom , nouveaux calculs pour les elongations  cu , cv
-  !      et possibilite d'appeler une fonction f(y)  a derivee tangente
-  !      hyperbolique a la  place de la fonction a derivee sinusoidale.
-  !  ... Possibilite de choisir le schema pour l'advection de
-  !        q  , en modifiant iadv dans traceur.def  (MAF,10/02) .
-  !
-  !      Pour Van-Leer + Vapeur d'eau saturee, iadv(1)=4. (F.Codron,10/99)
-  !      Pour Van-Leer iadv=10
-  !
-  !-----------------------------------------------------------------------
-  !   Declarations:
-  !   -------------
-
-  include "dimensions.h"
-  include "paramet.h"
-  include "comdissnew.h"
-  include "comgeom2.h"
-
-  REAL zdtvr
-
-
-  ! variables dynamiques intermediaire pour le transport
-
-  !   variables pour le fichier histoire
-  REAL dtav      ! intervalle de temps elementaire
-
-  REAL time_0
-
-  LOGICAL lafin
-
-  integer :: ntime=10000,it,klon,klev
-
-
-  ! locales pour gestion du temps
-  INTEGER :: an, mois, jour
-  REAL :: heure
-
-  !   Initialisations:
-  !   ----------------
-
-
-  !----------------------------------------------------------------------
-  !  lecture des fichiers gcm.def ou run.def
-  !  ---------------------------------------
-  !
-preff=101325.
- pa=50000.
- clon=0.
- clat=0.
- taux=3.
- tauy=3.
- dzoomx=0.1
- dzoomy=0.1
- grossismx=1.
- grossismx=1.
- transx=0.
- transy=0.
-
-  CALL conf_gcm( 99, .TRUE.)
-
-  if (mod(iphysiq, iperiod) /= 0) call abort_gcm("conf_gcm", &
-       "iphysiq must be a multiple of iperiod", 1)
-
- rad=6400000
-g=9.81
-
-
-
-  !-----------------------------------------------------------------------
-  !   Choix du calendrier
-  !   -------------------
-
-  !      calend = 'earth_365d'
-
-
-  !-----------------------------------------------------------------------
-  !   Lecture de l'etat initial :
-  !   ---------------------------
-
-  !-----------------------------------------------------------------------
-  !   Lecture des parametres de controle pour la simulation :
-  !   -------------------------------------------------------
-  !  on recalcule eventuellement le pas de temps
-
-
-  zdtvr    = daysec/REAL(day_step)
-
-  !
-  ! on remet le calendrier \`a zero si demande
-  !
-     annee_ref = anneeref
-     day_ref = dayref
-     day_ini = dayref
-     itau_dyn = 0
-     itau_phy = 0
-     time_0 = 0.
-
-  mois = 1
-  heure = 0.
-! call ymds2ju(annee_ref, mois, day_ref, heure, jD_ref)
-  jH_ref = jD_ref - int(jD_ref)
-  jD_ref = int(jD_ref)
-
-
-
-     dtvr = zdtvr
-     CALL iniconst
-     print*,'APRES inisconst'
-     CALL inigeom
-
-
-  CALL inigeomphy(iim,jjm,llm, &
-               1, comm_lmdz, &
-               rlatu,rlatv, &
-               rlonu,rlonv, &
-               aire,cu,cv)
-
-CALL suphel
-!open(82,file='dump_param.bin',form='unformatted',status='old')
-
-
-
-     CALL iophys_ini(900.)
-print*,'Rlatu=',rlatu
-klon=2+iim*(jjm-1)
-klev=llm
-
-!---------------------------------------------------------------------
-! Initialisation de la parametrisation
-!---------------------------------------------------------------------
-      call call_ini_replay
-
-!---------------------------------------------------------------------
-! Boucle en temps sur l'appel à la parametrisation
-!---------------------------------------------------------------------
-      DO it=1,ntime
-         print*,'Pas de temps ',it,klon,klev
-         call call_param_replay(klon,klev)
-      ENDDO
-
-
-END PROGRAM replay3d
Index: /LMDZ6/trunk/libf/dyn3d/replay3d.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d/replay3d.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3d/replay3d.f90	(revision 5268)
@@ -0,0 +1,193 @@
+!
+! $Id: gcm.F90 3579 2019-10-09 13:11:07Z fairhead $
+!
+!
+!
+PROGRAM replay3d
+
+
+
+USE comvert_mod, only :  preff, pa
+USE inigeomphy_mod, ONLY: inigeomphy
+
+
+  USE control_mod
+  USE temps_mod, ONLY: calend,start_time,annee_ref,day_ref, &
+                     itau_dyn,itau_phy,day_ini,jD_ref,jH_ref,day_end
+  USE comconst_mod, ONLY: cpp, daysec, dtphys, dtvr, g, r, rad
+  USE logic_mod, ONLY: ecripar, iflag_phys, read_start
+
+  USE serre_mod, ONLY : clon,clat,transx,transy,alphax,alphay,pxo,pyo,              &
+        grossismx, grossismy, dzoomx, dzoomy,taux,tauy
+  USE mod_const_mpi, ONLY: comm_lmdz
+
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+  ! FH 2008/05/09 On elimine toutes les clefs physiques dans la dynamique
+  ! A nettoyer. On ne veut qu'une ou deux routines d'interface 
+  ! dynamique -> physique pour l'initialisation
+  USE iniphysiq_mod, ONLY: iniphysiq
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+  IMPLICIT NONE
+
+  !      ......   Version  du 10/01/98    ..........
+
+  !             avec  coordonnees  verticales hybrides 
+  !   avec nouveaux operat. dissipation * ( gradiv2,divgrad2,nxgraro2 )
+
+  !=======================================================================
+  !
+  !   Auteur:  P. Le Van /L. Fairhead/F.Hourdin
+  !   -------
+  !
+  !   Objet:
+  !   ------
+  !
+  !   GCM LMD nouvelle grille
+  !
+  !=======================================================================
+  !
+  !  ... Dans inigeom , nouveaux calculs pour les elongations  cu , cv
+  !      et possibilite d'appeler une fonction f(y)  a derivee tangente
+  !      hyperbolique a la  place de la fonction a derivee sinusoidale.
+  !  ... Possibilite de choisir le schema pour l'advection de
+  !        q  , en modifiant iadv dans traceur.def  (MAF,10/02) .
+  !
+  !      Pour Van-Leer + Vapeur d'eau saturee, iadv(1)=4. (F.Codron,10/99)
+  !      Pour Van-Leer iadv=10
+  !
+  !-----------------------------------------------------------------------
+  !   Declarations:
+  !   -------------
+
+  include "dimensions.h"
+  include "paramet.h"
+  include "comdissnew.h"
+  include "comgeom2.h"
+
+  REAL zdtvr
+
+
+  ! variables dynamiques intermediaire pour le transport
+
+  !   variables pour le fichier histoire
+  REAL dtav      ! intervalle de temps elementaire
+
+  REAL time_0
+
+  LOGICAL lafin
+
+  integer :: ntime=10000,it,klon,klev
+
+
+  ! locales pour gestion du temps
+  INTEGER :: an, mois, jour
+  REAL :: heure
+
+  !   Initialisations:
+  !   ----------------
+
+
+  !----------------------------------------------------------------------
+  !  lecture des fichiers gcm.def ou run.def
+  !  ---------------------------------------
+  !
+preff=101325.
+ pa=50000.
+ clon=0.
+ clat=0.
+ taux=3.
+ tauy=3.
+ dzoomx=0.1
+ dzoomy=0.1
+ grossismx=1.
+ grossismx=1.
+ transx=0.
+ transy=0.
+
+  CALL conf_gcm( 99, .TRUE.)
+
+  if (mod(iphysiq, iperiod) /= 0) call abort_gcm("conf_gcm", &
+       "iphysiq must be a multiple of iperiod", 1)
+
+ rad=6400000
+g=9.81
+
+
+
+  !-----------------------------------------------------------------------
+  !   Choix du calendrier
+  !   -------------------
+
+  !      calend = 'earth_365d'
+
+
+  !-----------------------------------------------------------------------
+  !   Lecture de l'etat initial :
+  !   ---------------------------
+
+  !-----------------------------------------------------------------------
+  !   Lecture des parametres de controle pour la simulation :
+  !   -------------------------------------------------------
+  !  on recalcule eventuellement le pas de temps
+
+
+  zdtvr    = daysec/REAL(day_step)
+
+  !
+  ! on remet le calendrier \`a zero si demande
+  !
+     annee_ref = anneeref
+     day_ref = dayref
+     day_ini = dayref
+     itau_dyn = 0
+     itau_phy = 0
+     time_0 = 0.
+
+  mois = 1
+  heure = 0.
+! call ymds2ju(annee_ref, mois, day_ref, heure, jD_ref)
+  jH_ref = jD_ref - int(jD_ref)
+  jD_ref = int(jD_ref)
+
+
+
+     dtvr = zdtvr
+     CALL iniconst
+     print*,'APRES inisconst'
+     CALL inigeom
+
+
+  CALL inigeomphy(iim,jjm,llm, &
+               1, comm_lmdz, &
+               rlatu,rlatv, &
+               rlonu,rlonv, &
+               aire,cu,cv)
+
+CALL suphel
+!open(82,file='dump_param.bin',form='unformatted',status='old')
+
+
+
+     CALL iophys_ini(900.)
+print*,'Rlatu=',rlatu
+klon=2+iim*(jjm-1)
+klev=llm
+
+!---------------------------------------------------------------------
+! Initialisation de la parametrisation
+!---------------------------------------------------------------------
+      call call_ini_replay
+
+!---------------------------------------------------------------------
+! Boucle en temps sur l'appel à la parametrisation
+!---------------------------------------------------------------------
+      DO it=1,ntime
+         print*,'Pas de temps ',it,klon,klev
+         call call_param_replay(klon,klev)
+      ENDDO
+
+
+END PROGRAM replay3d
Index: DZ6/trunk/libf/dyn3d/temps_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d/temps_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,25 +1,0 @@
-!
-! $Id$
-!
-MODULE temps_mod
-
-IMPLICIT NONE  
-
-  INTEGER   itaufin ! total number of dynamical steps for the run
-  INTEGER   itau_dyn
-  INTEGER   itau_phy
-  INTEGER   day_ini ! initial day # of simulation sequence
-  INTEGER   day_end ! final day # ; i.e. day # when this simulation ends
-  INTEGER   annee_ref
-  INTEGER   day_ref
-  INTEGER   year_len
-  REAL      dt ! (dynamics) time step (changes if doing Matsuno or LF step)
-  REAL      jD_ref ! reference julian day date (beginning of experiment)
-  REAL      jH_ref ! reference julian "hour" of reference julian date
-  REAL      start_time
-  CHARACTER (len=10) :: calend ! calendar type
-
-  ! Additionnal Mars stuff:
-  REAL hour_ini ! initial fraction of day of simulation sequence (0=<hour_ini<1)
-
-END MODULE temps_mod
Index: /LMDZ6/trunk/libf/dyn3d/temps_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d/temps_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3d/temps_mod.f90	(revision 5268)
@@ -0,0 +1,25 @@
+!
+! $Id$
+!
+MODULE temps_mod
+
+IMPLICIT NONE  
+
+  INTEGER   itaufin ! total number of dynamical steps for the run
+  INTEGER   itau_dyn
+  INTEGER   itau_phy
+  INTEGER   day_ini ! initial day # of simulation sequence
+  INTEGER   day_end ! final day # ; i.e. day # when this simulation ends
+  INTEGER   annee_ref
+  INTEGER   day_ref
+  INTEGER   year_len
+  REAL      dt ! (dynamics) time step (changes if doing Matsuno or LF step)
+  REAL      jD_ref ! reference julian day date (beginning of experiment)
+  REAL      jH_ref ! reference julian "hour" of reference julian date
+  REAL      start_time
+  CHARACTER (len=10) :: calend ! calendar type
+
+  ! Additionnal Mars stuff:
+  REAL hour_ini ! initial fraction of day of simulation sequence (0=<hour_ini<1)
+
+END MODULE temps_mod
Index: DZ6/trunk/libf/dyn3d_common/caldyn0.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d_common/caldyn0.F90	(revision 5267)
+++ 	(revision )
@@ -1,55 +1,0 @@
-SUBROUTINE caldyn0(itau,ucov,vcov,teta,ps,masse,pk,phis,phi,w,pbaru,pbarv,time)
-!
-!-------------------------------------------------------------------------------
-! Author: P. Le Van ; modif. 04/93: F.Forget.
-!-------------------------------------------------------------------------------
-! Purpose: Compute dynamic tendencies.
-!-------------------------------------------------------------------------------
-  USE control_mod, ONLY: resetvarc 
-  USE comvert_mod, ONLY: ap, bp
-  IMPLICIT NONE
-  include "dimensions.h"
-  include "paramet.h"
-  include "comgeom.h"
-!===============================================================================
-! Arguments:
-  INTEGER, INTENT(IN)  :: itau                      !--- TIME STEP INDEX
-  REAL,    INTENT(IN)  :: vcov (ip1jm    ,llm)      !--- V COVARIANT WIND
-  REAL,    INTENT(IN)  :: ucov (ip1jmp1  ,llm)      !--- U COVARIANT WIND
-  REAL,    INTENT(IN)  :: teta (ip1jmp1  ,llm)      !--- POTENTIAL TEMPERATURE
-  REAL,    INTENT(IN)  :: ps   (ip1jmp1)            !--- GROUND PRESSURE
-  REAL,    INTENT(OUT) :: masse(ip1jmp1  ,llm)      !--- MASS IN EACH CELL
-  REAL,    INTENT(IN)  :: pk   (iip1,jjp1,llm)      !--- PRESSURE
-  REAL,    INTENT(IN)  :: phis (ip1jmp1)            !--- GROUND GEOPOTENTIAL
-  REAL,    INTENT(IN)  :: phi  (ip1jmp1  ,llm)      !--- 3D GEOPOTENTIAL
-  REAL,    INTENT(OUT) :: w    (ip1jmp1  ,llm)      !--- VERTICAL WIND
-  REAL,    INTENT(OUT) :: pbaru(ip1jmp1  ,llm)      !--- U MASS FLUX
-  REAL,    INTENT(OUT) :: pbarv(ip1jm    ,llm)      !--- V MASS FLUX
-  REAL,    INTENT(IN)  :: time                      !--- TIME
-!===============================================================================
-! Local variables:
-  REAL, DIMENSION(ip1jmp1,llmp1) :: p
-  REAL, DIMENSION(ip1jmp1,llm)   :: ucont, massebx, ang, ecin, convm, bern
-  REAL, DIMENSION(ip1jmp1)       :: dp
-  REAL, DIMENSION(ip1jm  ,llm)   :: vcont, masseby, massebxy, vorpot
-  REAL, DIMENSION(ip1jm)         :: psexbarxy
-  INTEGER                        :: ij, l
-!===============================================================================
-  CALL covcont  ( llm    , ucov    , vcov , ucont, vcont        )
-  CALL pression ( ip1jmp1, ap      , bp   ,  ps  , p            )
-  CALL psextbar (   ps   , psexbarxy                            )
-  CALL massdair (    p   , masse                                )
-  CALL massbar  (   masse, massebx , masseby                    )
-  CALL massbarxy(   masse, massebxy                             )
-  CALL flumass  ( massebx, masseby , vcont, ucont ,pbaru, pbarv )
-  CALL convmas  (   pbaru, pbarv   , convm                      )
-  CALL vitvert  ( convm  , w                                    )
-  CALL tourpot  ( vcov   , ucov    , massebxy  , vorpot         )
-  CALL enercin  ( vcov   , ucov    , vcont     , ucont  , ecin  )
-  CALL bernoui  ( ip1jmp1, llm     , phi       , ecin   , bern  )
-  DO l=1,llm; ang(:,l) = ucov(:,l) + constang(:); END DO
-  resetvarc=.true. ! force a recomputation of initial values in sortvarc
-  dp(:)=convm(:,1)/airesurg(:)
-  CALL sortvarc( itau,ucov,teta,ps,masse,pk,phis,vorpot,phi,bern,dp,time,vcov )
-
-END SUBROUTINE caldyn0
Index: /LMDZ6/trunk/libf/dyn3d_common/caldyn0.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d_common/caldyn0.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3d_common/caldyn0.f90	(revision 5268)
@@ -0,0 +1,55 @@
+SUBROUTINE caldyn0(itau,ucov,vcov,teta,ps,masse,pk,phis,phi,w,pbaru,pbarv,time)
+!
+!-------------------------------------------------------------------------------
+! Author: P. Le Van ; modif. 04/93: F.Forget.
+!-------------------------------------------------------------------------------
+! Purpose: Compute dynamic tendencies.
+!-------------------------------------------------------------------------------
+  USE control_mod, ONLY: resetvarc 
+  USE comvert_mod, ONLY: ap, bp
+  IMPLICIT NONE
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom.h"
+!===============================================================================
+! Arguments:
+  INTEGER, INTENT(IN)  :: itau                      !--- TIME STEP INDEX
+  REAL,    INTENT(IN)  :: vcov (ip1jm    ,llm)      !--- V COVARIANT WIND
+  REAL,    INTENT(IN)  :: ucov (ip1jmp1  ,llm)      !--- U COVARIANT WIND
+  REAL,    INTENT(IN)  :: teta (ip1jmp1  ,llm)      !--- POTENTIAL TEMPERATURE
+  REAL,    INTENT(IN)  :: ps   (ip1jmp1)            !--- GROUND PRESSURE
+  REAL,    INTENT(OUT) :: masse(ip1jmp1  ,llm)      !--- MASS IN EACH CELL
+  REAL,    INTENT(IN)  :: pk   (iip1,jjp1,llm)      !--- PRESSURE
+  REAL,    INTENT(IN)  :: phis (ip1jmp1)            !--- GROUND GEOPOTENTIAL
+  REAL,    INTENT(IN)  :: phi  (ip1jmp1  ,llm)      !--- 3D GEOPOTENTIAL
+  REAL,    INTENT(OUT) :: w    (ip1jmp1  ,llm)      !--- VERTICAL WIND
+  REAL,    INTENT(OUT) :: pbaru(ip1jmp1  ,llm)      !--- U MASS FLUX
+  REAL,    INTENT(OUT) :: pbarv(ip1jm    ,llm)      !--- V MASS FLUX
+  REAL,    INTENT(IN)  :: time                      !--- TIME
+!===============================================================================
+! Local variables:
+  REAL, DIMENSION(ip1jmp1,llmp1) :: p
+  REAL, DIMENSION(ip1jmp1,llm)   :: ucont, massebx, ang, ecin, convm, bern
+  REAL, DIMENSION(ip1jmp1)       :: dp
+  REAL, DIMENSION(ip1jm  ,llm)   :: vcont, masseby, massebxy, vorpot
+  REAL, DIMENSION(ip1jm)         :: psexbarxy
+  INTEGER                        :: ij, l
+!===============================================================================
+  CALL covcont  ( llm    , ucov    , vcov , ucont, vcont        )
+  CALL pression ( ip1jmp1, ap      , bp   ,  ps  , p            )
+  CALL psextbar (   ps   , psexbarxy                            )
+  CALL massdair (    p   , masse                                )
+  CALL massbar  (   masse, massebx , masseby                    )
+  CALL massbarxy(   masse, massebxy                             )
+  CALL flumass  ( massebx, masseby , vcont, ucont ,pbaru, pbarv )
+  CALL convmas  (   pbaru, pbarv   , convm                      )
+  CALL vitvert  ( convm  , w                                    )
+  CALL tourpot  ( vcov   , ucov    , massebxy  , vorpot         )
+  CALL enercin  ( vcov   , ucov    , vcont     , ucont  , ecin  )
+  CALL bernoui  ( ip1jmp1, llm     , phi       , ecin   , bern  )
+  DO l=1,llm; ang(:,l) = ucov(:,l) + constang(:); END DO
+  resetvarc=.true. ! force a recomputation of initial values in sortvarc
+  dp(:)=convm(:,1)/airesurg(:)
+  CALL sortvarc( itau,ucov,teta,ps,masse,pk,phis,vorpot,phi,bern,dp,time,vcov )
+
+END SUBROUTINE caldyn0
Index: DZ6/trunk/libf/dyn3d_common/com_io_dyn_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d_common/com_io_dyn_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,31 +1,0 @@
-!
-! $Id $
-!
-module com_io_dyn_mod
-
-  implicit none 
-
-! Names of various files for outputs (in the dynamics)
-  ! to store instantaneous values:
-  character(len=18),parameter :: dynhist_file="dyn_hist.nc" ! on scalar grid
-  character(len=18),parameter :: dynhistv_file="dyn_histv.nc" ! on v grid
-  character(len=18),parameter :: dynhistu_file="dyn_histu.nc" ! on u grid
-
-  ! to store averaged values:
-  character(len=18),parameter :: dynhistave_file="dyn_hist_ave.nc"
-  character(len=18),parameter :: dynhistvave_file="dyn_histv_ave.nc"
-  character(len=18),parameter :: dynhistuave_file="dyn_histu_ave.nc"
-  
-! Ids of various files for outputs (in the dynamics)
-
-  ! instantaneous (these are set by inithist.F)
-  integer :: histid
-  integer :: histvid
-  integer :: histuid
-  
-  ! averages (these are set by initdynav.F)
-  integer :: histaveid
-  integer :: histvaveid
-  integer :: histuaveid
-  
-end module com_io_dyn_mod
Index: /LMDZ6/trunk/libf/dyn3d_common/com_io_dyn_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d_common/com_io_dyn_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3d_common/com_io_dyn_mod.f90	(revision 5268)
@@ -0,0 +1,31 @@
+!
+! $Id $
+!
+module com_io_dyn_mod
+
+  implicit none 
+
+! Names of various files for outputs (in the dynamics)
+  ! to store instantaneous values:
+  character(len=18),parameter :: dynhist_file="dyn_hist.nc" ! on scalar grid
+  character(len=18),parameter :: dynhistv_file="dyn_histv.nc" ! on v grid
+  character(len=18),parameter :: dynhistu_file="dyn_histu.nc" ! on u grid
+
+  ! to store averaged values:
+  character(len=18),parameter :: dynhistave_file="dyn_hist_ave.nc"
+  character(len=18),parameter :: dynhistvave_file="dyn_histv_ave.nc"
+  character(len=18),parameter :: dynhistuave_file="dyn_histu_ave.nc"
+  
+! Ids of various files for outputs (in the dynamics)
+
+  ! instantaneous (these are set by inithist.F)
+  integer :: histid
+  integer :: histvid
+  integer :: histuid
+  
+  ! averages (these are set by initdynav.F)
+  integer :: histaveid
+  integer :: histvaveid
+  integer :: histuaveid
+  
+end module com_io_dyn_mod
Index: DZ6/trunk/libf/dyn3d_common/comconst_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d_common/comconst_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,38 +1,0 @@
-!
-! $Id$
-!
-
-MODULE comconst_mod
-
-IMPLICIT NONE  
-
-      INTEGER im,jm,lllm,imp1,jmp1,lllmm1,lllmp1,lcl
-      REAL dtvr ! dynamical time step (in s)
-      REAL daysec !length (in s) of a standard day
-      REAL pi    ! something like 3.14159....
-      REAL dtphys ! (s) time step for the physics
-      REAL dtdiss ! (s) time step for the dissipation
-      REAL rad ! (m) radius of the planet
-      REAL r ! Reduced Gas constant r=R/mu
-             ! with R=8.31.. J.K-1.mol-1, mu: mol mass of atmosphere (kg/mol)
-      REAL cpp   ! Specific heat Cp (J.kg-1.K-1)
-      REAL kappa ! kappa=R/Cp 
-      REAL cotot
-      REAL unsim ! = 1./iim
-      REAL g ! (m/s2) gravity
-      REAL omeg ! (rad/s) rotation rate of the planet
-      REAL dissip_factz,dissip_deltaz,dissip_zref
-! top_bound sponge:
-      INTEGER iflag_top_bound ! sponge type
-      INTEGER ngroup ! parameter to group points (along longitude) near poles
-      REAL maxlatfilter ! maximum latitude (in degrees) above which filter is active
-      INTEGER mode_top_bound  ! sponge mode
-      REAL tau_top_bound ! inverse of sponge characteristic time scale (Hz)
-      REAL daylen ! length of solar day, in 'standard' day length
-      REAL year_day ! Number of standard days in a year
-      REAL molmass ! (g/mol) molar mass of the atmosphere
-
-      REAL ihf ! (W/m2) Intrinsic heat flux (for giant planets)
-
-
-END MODULE comconst_mod
Index: /LMDZ6/trunk/libf/dyn3d_common/comconst_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d_common/comconst_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3d_common/comconst_mod.f90	(revision 5268)
@@ -0,0 +1,38 @@
+!
+! $Id$
+!
+
+MODULE comconst_mod
+
+IMPLICIT NONE  
+
+      INTEGER im,jm,lllm,imp1,jmp1,lllmm1,lllmp1,lcl
+      REAL dtvr ! dynamical time step (in s)
+      REAL daysec !length (in s) of a standard day
+      REAL pi    ! something like 3.14159....
+      REAL dtphys ! (s) time step for the physics
+      REAL dtdiss ! (s) time step for the dissipation
+      REAL rad ! (m) radius of the planet
+      REAL r ! Reduced Gas constant r=R/mu
+             ! with R=8.31.. J.K-1.mol-1, mu: mol mass of atmosphere (kg/mol)
+      REAL cpp   ! Specific heat Cp (J.kg-1.K-1)
+      REAL kappa ! kappa=R/Cp 
+      REAL cotot
+      REAL unsim ! = 1./iim
+      REAL g ! (m/s2) gravity
+      REAL omeg ! (rad/s) rotation rate of the planet
+      REAL dissip_factz,dissip_deltaz,dissip_zref
+! top_bound sponge:
+      INTEGER iflag_top_bound ! sponge type
+      INTEGER ngroup ! parameter to group points (along longitude) near poles
+      REAL maxlatfilter ! maximum latitude (in degrees) above which filter is active
+      INTEGER mode_top_bound  ! sponge mode
+      REAL tau_top_bound ! inverse of sponge characteristic time scale (Hz)
+      REAL daylen ! length of solar day, in 'standard' day length
+      REAL year_day ! Number of standard days in a year
+      REAL molmass ! (g/mol) molar mass of the atmosphere
+
+      REAL ihf ! (W/m2) Intrinsic heat flux (for giant planets)
+
+
+END MODULE comconst_mod
Index: DZ6/trunk/libf/dyn3d_common/comvert_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d_common/comvert_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,43 +1,0 @@
-!
-! $Id$
-!
-MODULE comvert_mod
-
-IMPLICIT NONE  
-
-PRIVATE
-INCLUDE "dimensions.h"
-
-PUBLIC :: ap,bp,presnivs,dpres,sig,ds,pa,preff,nivsigs,nivsig, &
-          aps,bps,scaleheight,pseudoalt,disvert_type, pressure_exner, &
-          presinter
-
-REAL ap(llm+1) ! hybrid pressure contribution at interlayers
-REAL bp (llm+1) ! hybrid sigma contribution at interlayer
-REAL presnivs(llm) ! (reference) pressure at mid-layers
-REAL presinter(llm+1) ! (reference) pressure at interlayers
-REAL dpres(llm)
-REAL sig(llm+1)
-REAL ds(llm)
-REAL pa ! reference pressure (Pa) at which hybrid coordinates
-        ! become purely pressure (more or less)
-REAL preff  ! reference surface pressure (Pa)
-REAL nivsigs(llm)
-REAL nivsig(llm+1)
-REAL aps(llm) ! hybrid pressure contribution at mid-layers
-REAL bps(llm) ! hybrid sigma contribution at mid-layers
-REAL scaleheight ! atmospheric (reference) scale height (km)
-REAL pseudoalt(llm) ! pseudo-altitude of model levels (km), based on presnivs(),
-                     ! preff and scaleheight
-
-INTEGER disvert_type ! type of vertical discretization:
-                     ! 1: Earth (default for planet_type==earth),
-                     !     automatic generation
-                     ! 2: Planets (default for planet_type!=earth),
-                     !     using 'z2sig.def' (or 'esasig.def) file
-
-LOGICAL pressure_exner
-!     compute pressure inside layers using Exner function, else use mean
-!     of pressure values at interfaces
-
-END MODULE comvert_mod
Index: /LMDZ6/trunk/libf/dyn3d_common/comvert_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d_common/comvert_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3d_common/comvert_mod.f90	(revision 5268)
@@ -0,0 +1,43 @@
+!
+! $Id$
+!
+MODULE comvert_mod
+
+IMPLICIT NONE  
+
+PRIVATE
+INCLUDE "dimensions.h"
+
+PUBLIC :: ap,bp,presnivs,dpres,sig,ds,pa,preff,nivsigs,nivsig, &
+          aps,bps,scaleheight,pseudoalt,disvert_type, pressure_exner, &
+          presinter
+
+REAL ap(llm+1) ! hybrid pressure contribution at interlayers
+REAL bp (llm+1) ! hybrid sigma contribution at interlayer
+REAL presnivs(llm) ! (reference) pressure at mid-layers
+REAL presinter(llm+1) ! (reference) pressure at interlayers
+REAL dpres(llm)
+REAL sig(llm+1)
+REAL ds(llm)
+REAL pa ! reference pressure (Pa) at which hybrid coordinates
+        ! become purely pressure (more or less)
+REAL preff  ! reference surface pressure (Pa)
+REAL nivsigs(llm)
+REAL nivsig(llm+1)
+REAL aps(llm) ! hybrid pressure contribution at mid-layers
+REAL bps(llm) ! hybrid sigma contribution at mid-layers
+REAL scaleheight ! atmospheric (reference) scale height (km)
+REAL pseudoalt(llm) ! pseudo-altitude of model levels (km), based on presnivs(),
+                     ! preff and scaleheight
+
+INTEGER disvert_type ! type of vertical discretization:
+                     ! 1: Earth (default for planet_type==earth),
+                     !     automatic generation
+                     ! 2: Planets (default for planet_type!=earth),
+                     !     using 'z2sig.def' (or 'esasig.def) file
+
+LOGICAL pressure_exner
+!     compute pressure inside layers using Exner function, else use mean
+!     of pressure values at interfaces
+
+END MODULE comvert_mod
Index: DZ6/trunk/libf/dyn3d_common/conf_dat_m.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d_common/conf_dat_m.F90	(revision 5267)
+++ 	(revision )
@@ -1,235 +1,0 @@
-MODULE conf_dat_m
-!
-!*******************************************************************************
-
-  PRIVATE
-  PUBLIC :: conf_dat2d, conf_dat3d
-
-
-CONTAINS
-
-
-!-------------------------------------------------------------------------------
-!
-SUBROUTINE conf_dat2d(title, xd, yd, xf, yf, champd, interbar)
-!
-!-------------------------------------------------------------------------------
-! Author: P. Le Van
-!-------------------------------------------------------------------------------
-! Purpose: Configure the 2D data field "champd" so that:
-!     - Longitudes are in [ -pi     pi   ]
-!     - Latitudes  are in [  pi/2. -pi/2 ]
-!  * xd / yd are initial lon / lats.
-!  * xf / yf are output  lon / lats, possibly modified to satisfy configuration.
-!  * interbar is TRUE for barycentric interpolation.
-!-------------------------------------------------------------------------------
-  USE assert_eq_m, ONLY: assert_eq
-  IMPLICIT NONE
-!-------------------------------------------------------------------------------
-! Arguments:
-  CHARACTER(LEN=*), INTENT(IN)    :: title
-  REAL,             INTENT(IN)    :: xd(:), yd(:)  ! dim (lons) (lats)
-  REAL,             INTENT(INOUT) :: xf(:), yf(:)  ! dim (lons) (lats)
-  REAL,             INTENT(INOUT) :: champd(:,:)   ! dim (lons,lats)
-  LOGICAL,          INTENT(IN)    :: interbar
-!-------------------------------------------------------------------------------
-! Local variables:
-  CHARACTER(LEN=256) :: modname="conf_dat2d"
-  INTEGER :: i, j, ip180, ind, lons, lats
-  LOGICAL :: radlon, invlon ,radlat, invlat
-  REAL    :: pi, pis2, depi, rlatmin, rlatmax, oldxd1
-  REAL, ALLOCATABLE :: xtemp(:) , ytemp(:), champf(:,:)
-!-------------------------------------------------------------------------------
-  lons=assert_eq(SIZE(xd),SIZE(xf),SIZE(champd,1),TRIM(modname)//" lons")
-  lats=assert_eq(SIZE(yd),SIZE(yf),SIZE(champd,2),TRIM(modname)//" lats")
-  ALLOCATE(xtemp(lons),ytemp(lats)); xtemp(:)=xd(:); ytemp(:)=yd(:)
-  ALLOCATE(champf(lons,lats))
-  pi = 2. * ASIN(1.) 
-  pis2 = pi/2.
-  depi = 2. * pi
-  radlon=.FALSE.; invlon=.FALSE.
-  IF     (xtemp(1)>=-pi-0.5.AND.xtemp(lons)<=  pi+0.5) THEN
-    radlon = .TRUE.;  invlon = .FALSE.
-  ELSE IF(xtemp(1)>=   -0.5.AND.xtemp(lons)<=depi+0.5) THEN
-    radlon = .TRUE.;  invlon = .TRUE.
-  ELSE IF(xtemp(1)>= -180.5.AND.xtemp(lons)<=   180.5) THEN
-    radlon = .FALSE.; invlon = .FALSE.
-  ELSE IF(xtemp(1)>=   -0.5.AND.xtemp(lons)<=   360.5) THEN
-    radlon = .FALSE.; invlon = .TRUE.
-  ELSE; WRITE(6,*) 'Problems with data longitudes for file '//TRIM(title)
-  END IF
-  invlat = ytemp(1)<ytemp(lats)
-  rlatmin = MIN( ytemp(1), ytemp(lats) )
-  rlatmax = MAX( ytemp(1), ytemp(lats) )
-      
-  IF     (rlatmin>=-pis2-0.5.AND.rlatmax<=pis2+0.5) THEN; radlat = .TRUE.
-  ELSE IF(rlatmin>= -90.-0.5.AND.rlatmax<= 90.+0.5) THEN; radlat = .FALSE.
-  ELSE; WRITE(6,*) 'Problems with data latitudes for file '//TRIM(title)
-  END IF
-
-  IF(.NOT.radlon) xtemp(:)=xtemp(:)*pi/180.
-  IF(.NOT.radlat) ytemp(:)=ytemp(:)*pi/180.
-
-!--- FLIPPED LONGITUDES
-  IF(invlon) THEN
-    champf(:,:)=champd(:,:); xf(:)=xtemp(:)
-
-  !--- Longitudes rotated to get them in [ -pi pi] interval.
-    DO i=1,lons;      IF(xf(i)>pi) EXIT;                   END DO; ip180 = i
-    DO i=1,lons;      IF(xf(i)>pi) xf(i)=xf(i)-depi;       END DO
-    DO i= ip180,lons; ind=i-ip180+1; xtemp(ind)=xf(i);     END DO
-    DO i= ind+1,lons;                xtemp(i  )=xf(i-ind); END DO
-
-  !--- Longitudes rotated in champf
-    DO j=1,lats
-      DO i=ip180,lons; ind=i-ip180+1; champd(ind,j)=champf(i    ,j); END DO
-      DO i=ind+1,lons;                champd(i  ,j)=champf(i-ind,j); END DO
-    END DO
-  END IF
-
-!--- FLIPPED LATITUDES
-  IF(invlat) THEN
-    yf(:)=ytemp(:)
-    champf(:,:)=champd(:,:)
-    ytemp(lats:1:-1)=yf(:)
-    DO j=1,lats; champd(:,lats-j+1)=champf(:,j); END DO
-  END IF
-
-!--- FOR BARYCENTRIC INTERPOLATION
-  IF(interbar) THEN
-    oldxd1 = xtemp(1)
-    xtemp(1:lons-1)=0.5*(xtemp(1:lons-1)+xtemp(2:lons))
-    xtemp(  lons  )=0.5*(xtemp(  lons  )+oldxd1+depi)
-    ytemp(1:lats-1)=0.5*(ytemp(1:lats-1)+ytemp(2:lats))
-  END IF
-  DEALLOCATE(champf)
-  xf(:)=xtemp(:); DEALLOCATE(xtemp)
-  yf(:)=ytemp(:); DEALLOCATE(ytemp)
-
-END SUBROUTINE conf_dat2d
-!
-!-------------------------------------------------------------------------------
-
-
-!-------------------------------------------------------------------------------
-!
-SUBROUTINE conf_dat3d(title, xd, yd, zd, xf, yf, zf, champd, interbar)
-!
-!-------------------------------------------------------------------------------
-! Author: P. Le Van
-!-------------------------------------------------------------------------------
-! Purpose: Configure the 3D data field "champd" so that:
-!     - Longitudes are in [ -pi     pi   ]
-!     - Latitudes  are in [  pi/2. -pi/2 ]
-!     - Vertical levels from ground to model top (in Pascals)
-!  * xd / yd are initial lon / lats.
-!  * xf / yf are output  lon / lats, possibly modified to satisfy configuration.
-!  * zf      are output pressures
-!  * interbar is TRUE for barycentric interpolation.
-!-------------------------------------------------------------------------------
-  USE assert_eq_m, ONLY: assert_eq
-  IMPLICIT NONE
-!-------------------------------------------------------------------------------
-! Arguments:
-  CHARACTER(LEN=*), INTENT(IN)    :: title
-  REAL,             INTENT(IN)    :: xd(:), yd(:), zd(:) ! (lons) (lats) (levs)
-  REAL,             INTENT(INOUT) :: xf(:), yf(:), zf(:) ! (lons) (lats) (levs)
-  REAL,             INTENT(INOUT) :: champd(:,:,:)       ! (lons,lats,levs)
-  LOGICAL,          INTENT(IN)    :: interbar
-!-------------------------------------------------------------------------------
-! Local variables:
-  CHARACTER(LEN=256) :: modname="conf_dat3d"
-  INTEGER :: i, j, l, ip180, ind, lons, lats, levs
-  LOGICAL :: radlon, invlon ,radlat, invlat, invlev
-  REAL    :: pi, pis2, depi, presmax, rlatmin, rlatmax, oldxd1
-  REAL, ALLOCATABLE :: xtemp(:) , ytemp(:), ztemp(:), champf(:,:,:)
-!-------------------------------------------------------------------------------
-  lons=assert_eq(SIZE(xd),SIZE(xf),SIZE(champd,1),TRIM(modname)//" lons")
-  lats=assert_eq(SIZE(yd),SIZE(yf),SIZE(champd,2),TRIM(modname)//" lats")
-  levs=assert_eq(SIZE(zd),SIZE(zf),SIZE(champd,3),TRIM(modname)//" levs")
-  ALLOCATE(xtemp(lons),ytemp(lats),ztemp(levs),champf(lons,lats,levs))
-  xtemp(:)=xd(:); ytemp(:)=yd(:); ztemp(:)=zd(:)
-  pi = 2. * ASIN(1.) 
-  pis2 = pi/2.
-  depi = 2. * pi
-  radlon=.FALSE.; invlon=.FALSE.
-  IF     (xtemp(1)>=-pi-0.5.AND.xtemp(lons)<=  pi+0.5) THEN
-    radlon = .TRUE.;  invlon = .FALSE.
-  ELSE IF(xtemp(1)>=   -0.5.AND.xtemp(lons)<=depi+0.5) THEN
-    radlon = .TRUE.;  invlon = .TRUE.
-  ELSE IF(xtemp(1)>= -180.5.AND.xtemp(lons)<=   180.5) THEN
-    radlon = .FALSE.; invlon = .FALSE.
-  ELSE IF(xtemp(1)>=   -0.5.AND.xtemp(lons)<=   360.5) THEN
-    radlon = .FALSE.; invlon = .TRUE.
-  ELSE; WRITE(6,*) 'Problems with data longitudes for file '//TRIM(title)
-  END IF
-  invlat = ytemp(1)<ytemp(lats)
-  rlatmin = MIN( ytemp(1), ytemp(lats) )
-  rlatmax = MAX( ytemp(1), ytemp(lats) )
-      
-  IF     (rlatmin>=-pis2-0.5.AND.rlatmax<=pis2+0.5) THEN; radlat = .TRUE.
-  ELSE IF(rlatmin>= -90.-0.5.AND.rlatmax<= 90.+0.5) THEN; radlat = .FALSE.
-  ELSE; WRITE(6,*) 'Problems with data latitudes for file '//TRIM(title)
-  END IF
-
-  IF(.NOT.radlon) xtemp(:)=xtemp(:)*pi/180.
-  IF(.NOT.radlat) ytemp(:)=ytemp(:)*pi/180.
-
-!--- FLIPPED LONGITUDES
-  IF(invlon) THEN
-    champf(:,:,:)=champd(:,:,:); xf(:)=xtemp(:)
-
-  !--- Longitudes rotated to get them in [ -pi pi] interval.
-    DO i=1,lons;      IF(xf(i)>pi) EXIT;                   END DO; ip180 = i
-    DO i=1,lons;      IF(xf(i)>pi) xf(i)=xf(i)-depi;       END DO
-    DO i= ip180,lons; ind=i-ip180+1; xtemp(ind)=xf(i);     END DO
-    DO i= ind+1,lons;                xtemp(i  )=xf(i-ind); END DO
-
-  !--- Longitudes rotated in champf
-    DO l=1,levs
-    DO j=1,lats
-      DO i=ip180,lons; ind=i-ip180+1; champd(ind,j,l)=champf(i    ,j,l); END DO
-      DO i=ind+1,lons;                champd(i  ,j,l)=champf(i-ind,j,l); END DO
-    END DO
-    END DO
-  END IF
-
-!--- FLIPPED LATITUDES
-  IF(invlat) THEN
-    yf(:)=ytemp(:)
-    champf(:,:,:)=champd(:,:,:)
-    ytemp(lats:1:-1)=yf(:)
-    DO l=1,levs
-      DO j=1,lats; champd(:,lats-j+1,l)=champf(:,j,l); END DO
-    END DO
-  END IF
-
-!--- FOR BARYCENTRIC INTERPOLATION
-  IF(interbar) THEN
-    oldxd1 = xtemp(1)
-    xtemp(1:lons-1)=0.5*(xtemp(1:lons-1)+xtemp(2:lons))
-    xtemp(  lons  )=0.5*(xtemp(  lons  )+oldxd1+depi)
-    ytemp(1:lats-1)=0.5*(ytemp(1:lats-1)+ytemp(2:lats))
-  END IF
-
-!--- FLIPPED LEVELS
-  invlev=ztemp(1)<ztemp(levs)
-  IF(MAX(ztemp(1),ztemp(levs))<1200.) ztemp(:)=ztemp(:)*100.
-  IF(invlev) THEN
-    zf(:)=ztemp(:)
-    champf(:,:,:)=champd(:,:,:)
-    ztemp(levs:1:-1)=zf(:)
-    DO l=1,levs; champd(:,:,levs+1-l)=champf(:,:,l); END DO
-  END IF
-
-  DEALLOCATE(champf)
-  xf(:)=xtemp(:); DEALLOCATE(xtemp)
-  yf(:)=ytemp(:); DEALLOCATE(ytemp)
-  zf(:)=ztemp(:); DEALLOCATE(ztemp)
-
-END SUBROUTINE conf_dat3d
-!
-!-------------------------------------------------------------------------------
-
-END MODULE conf_dat_m
-
Index: /LMDZ6/trunk/libf/dyn3d_common/conf_dat_m.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d_common/conf_dat_m.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3d_common/conf_dat_m.f90	(revision 5268)
@@ -0,0 +1,235 @@
+MODULE conf_dat_m
+!
+!*******************************************************************************
+
+  PRIVATE
+  PUBLIC :: conf_dat2d, conf_dat3d
+
+
+CONTAINS
+
+
+!-------------------------------------------------------------------------------
+!
+SUBROUTINE conf_dat2d(title, xd, yd, xf, yf, champd, interbar)
+!
+!-------------------------------------------------------------------------------
+! Author: P. Le Van
+!-------------------------------------------------------------------------------
+! Purpose: Configure the 2D data field "champd" so that:
+!     - Longitudes are in [ -pi     pi   ]
+!     - Latitudes  are in [  pi/2. -pi/2 ]
+!  * xd / yd are initial lon / lats.
+!  * xf / yf are output  lon / lats, possibly modified to satisfy configuration.
+!  * interbar is TRUE for barycentric interpolation.
+!-------------------------------------------------------------------------------
+  USE assert_eq_m, ONLY: assert_eq
+  IMPLICIT NONE
+!-------------------------------------------------------------------------------
+! Arguments:
+  CHARACTER(LEN=*), INTENT(IN)    :: title
+  REAL,             INTENT(IN)    :: xd(:), yd(:)  ! dim (lons) (lats)
+  REAL,             INTENT(INOUT) :: xf(:), yf(:)  ! dim (lons) (lats)
+  REAL,             INTENT(INOUT) :: champd(:,:)   ! dim (lons,lats)
+  LOGICAL,          INTENT(IN)    :: interbar
+!-------------------------------------------------------------------------------
+! Local variables:
+  CHARACTER(LEN=256) :: modname="conf_dat2d"
+  INTEGER :: i, j, ip180, ind, lons, lats
+  LOGICAL :: radlon, invlon ,radlat, invlat
+  REAL    :: pi, pis2, depi, rlatmin, rlatmax, oldxd1
+  REAL, ALLOCATABLE :: xtemp(:) , ytemp(:), champf(:,:)
+!-------------------------------------------------------------------------------
+  lons=assert_eq(SIZE(xd),SIZE(xf),SIZE(champd,1),TRIM(modname)//" lons")
+  lats=assert_eq(SIZE(yd),SIZE(yf),SIZE(champd,2),TRIM(modname)//" lats")
+  ALLOCATE(xtemp(lons),ytemp(lats)); xtemp(:)=xd(:); ytemp(:)=yd(:)
+  ALLOCATE(champf(lons,lats))
+  pi = 2. * ASIN(1.) 
+  pis2 = pi/2.
+  depi = 2. * pi
+  radlon=.FALSE.; invlon=.FALSE.
+  IF     (xtemp(1)>=-pi-0.5.AND.xtemp(lons)<=  pi+0.5) THEN
+    radlon = .TRUE.;  invlon = .FALSE.
+  ELSE IF(xtemp(1)>=   -0.5.AND.xtemp(lons)<=depi+0.5) THEN
+    radlon = .TRUE.;  invlon = .TRUE.
+  ELSE IF(xtemp(1)>= -180.5.AND.xtemp(lons)<=   180.5) THEN
+    radlon = .FALSE.; invlon = .FALSE.
+  ELSE IF(xtemp(1)>=   -0.5.AND.xtemp(lons)<=   360.5) THEN
+    radlon = .FALSE.; invlon = .TRUE.
+  ELSE; WRITE(6,*) 'Problems with data longitudes for file '//TRIM(title)
+  END IF
+  invlat = ytemp(1)<ytemp(lats)
+  rlatmin = MIN( ytemp(1), ytemp(lats) )
+  rlatmax = MAX( ytemp(1), ytemp(lats) )
+      
+  IF     (rlatmin>=-pis2-0.5.AND.rlatmax<=pis2+0.5) THEN; radlat = .TRUE.
+  ELSE IF(rlatmin>= -90.-0.5.AND.rlatmax<= 90.+0.5) THEN; radlat = .FALSE.
+  ELSE; WRITE(6,*) 'Problems with data latitudes for file '//TRIM(title)
+  END IF
+
+  IF(.NOT.radlon) xtemp(:)=xtemp(:)*pi/180.
+  IF(.NOT.radlat) ytemp(:)=ytemp(:)*pi/180.
+
+!--- FLIPPED LONGITUDES
+  IF(invlon) THEN
+    champf(:,:)=champd(:,:); xf(:)=xtemp(:)
+
+  !--- Longitudes rotated to get them in [ -pi pi] interval.
+    DO i=1,lons;      IF(xf(i)>pi) EXIT;                   END DO; ip180 = i
+    DO i=1,lons;      IF(xf(i)>pi) xf(i)=xf(i)-depi;       END DO
+    DO i= ip180,lons; ind=i-ip180+1; xtemp(ind)=xf(i);     END DO
+    DO i= ind+1,lons;                xtemp(i  )=xf(i-ind); END DO
+
+  !--- Longitudes rotated in champf
+    DO j=1,lats
+      DO i=ip180,lons; ind=i-ip180+1; champd(ind,j)=champf(i    ,j); END DO
+      DO i=ind+1,lons;                champd(i  ,j)=champf(i-ind,j); END DO
+    END DO
+  END IF
+
+!--- FLIPPED LATITUDES
+  IF(invlat) THEN
+    yf(:)=ytemp(:)
+    champf(:,:)=champd(:,:)
+    ytemp(lats:1:-1)=yf(:)
+    DO j=1,lats; champd(:,lats-j+1)=champf(:,j); END DO
+  END IF
+
+!--- FOR BARYCENTRIC INTERPOLATION
+  IF(interbar) THEN
+    oldxd1 = xtemp(1)
+    xtemp(1:lons-1)=0.5*(xtemp(1:lons-1)+xtemp(2:lons))
+    xtemp(  lons  )=0.5*(xtemp(  lons  )+oldxd1+depi)
+    ytemp(1:lats-1)=0.5*(ytemp(1:lats-1)+ytemp(2:lats))
+  END IF
+  DEALLOCATE(champf)
+  xf(:)=xtemp(:); DEALLOCATE(xtemp)
+  yf(:)=ytemp(:); DEALLOCATE(ytemp)
+
+END SUBROUTINE conf_dat2d
+!
+!-------------------------------------------------------------------------------
+
+
+!-------------------------------------------------------------------------------
+!
+SUBROUTINE conf_dat3d(title, xd, yd, zd, xf, yf, zf, champd, interbar)
+!
+!-------------------------------------------------------------------------------
+! Author: P. Le Van
+!-------------------------------------------------------------------------------
+! Purpose: Configure the 3D data field "champd" so that:
+!     - Longitudes are in [ -pi     pi   ]
+!     - Latitudes  are in [  pi/2. -pi/2 ]
+!     - Vertical levels from ground to model top (in Pascals)
+!  * xd / yd are initial lon / lats.
+!  * xf / yf are output  lon / lats, possibly modified to satisfy configuration.
+!  * zf      are output pressures
+!  * interbar is TRUE for barycentric interpolation.
+!-------------------------------------------------------------------------------
+  USE assert_eq_m, ONLY: assert_eq
+  IMPLICIT NONE
+!-------------------------------------------------------------------------------
+! Arguments:
+  CHARACTER(LEN=*), INTENT(IN)    :: title
+  REAL,             INTENT(IN)    :: xd(:), yd(:), zd(:) ! (lons) (lats) (levs)
+  REAL,             INTENT(INOUT) :: xf(:), yf(:), zf(:) ! (lons) (lats) (levs)
+  REAL,             INTENT(INOUT) :: champd(:,:,:)       ! (lons,lats,levs)
+  LOGICAL,          INTENT(IN)    :: interbar
+!-------------------------------------------------------------------------------
+! Local variables:
+  CHARACTER(LEN=256) :: modname="conf_dat3d"
+  INTEGER :: i, j, l, ip180, ind, lons, lats, levs
+  LOGICAL :: radlon, invlon ,radlat, invlat, invlev
+  REAL    :: pi, pis2, depi, presmax, rlatmin, rlatmax, oldxd1
+  REAL, ALLOCATABLE :: xtemp(:) , ytemp(:), ztemp(:), champf(:,:,:)
+!-------------------------------------------------------------------------------
+  lons=assert_eq(SIZE(xd),SIZE(xf),SIZE(champd,1),TRIM(modname)//" lons")
+  lats=assert_eq(SIZE(yd),SIZE(yf),SIZE(champd,2),TRIM(modname)//" lats")
+  levs=assert_eq(SIZE(zd),SIZE(zf),SIZE(champd,3),TRIM(modname)//" levs")
+  ALLOCATE(xtemp(lons),ytemp(lats),ztemp(levs),champf(lons,lats,levs))
+  xtemp(:)=xd(:); ytemp(:)=yd(:); ztemp(:)=zd(:)
+  pi = 2. * ASIN(1.) 
+  pis2 = pi/2.
+  depi = 2. * pi
+  radlon=.FALSE.; invlon=.FALSE.
+  IF     (xtemp(1)>=-pi-0.5.AND.xtemp(lons)<=  pi+0.5) THEN
+    radlon = .TRUE.;  invlon = .FALSE.
+  ELSE IF(xtemp(1)>=   -0.5.AND.xtemp(lons)<=depi+0.5) THEN
+    radlon = .TRUE.;  invlon = .TRUE.
+  ELSE IF(xtemp(1)>= -180.5.AND.xtemp(lons)<=   180.5) THEN
+    radlon = .FALSE.; invlon = .FALSE.
+  ELSE IF(xtemp(1)>=   -0.5.AND.xtemp(lons)<=   360.5) THEN
+    radlon = .FALSE.; invlon = .TRUE.
+  ELSE; WRITE(6,*) 'Problems with data longitudes for file '//TRIM(title)
+  END IF
+  invlat = ytemp(1)<ytemp(lats)
+  rlatmin = MIN( ytemp(1), ytemp(lats) )
+  rlatmax = MAX( ytemp(1), ytemp(lats) )
+      
+  IF     (rlatmin>=-pis2-0.5.AND.rlatmax<=pis2+0.5) THEN; radlat = .TRUE.
+  ELSE IF(rlatmin>= -90.-0.5.AND.rlatmax<= 90.+0.5) THEN; radlat = .FALSE.
+  ELSE; WRITE(6,*) 'Problems with data latitudes for file '//TRIM(title)
+  END IF
+
+  IF(.NOT.radlon) xtemp(:)=xtemp(:)*pi/180.
+  IF(.NOT.radlat) ytemp(:)=ytemp(:)*pi/180.
+
+!--- FLIPPED LONGITUDES
+  IF(invlon) THEN
+    champf(:,:,:)=champd(:,:,:); xf(:)=xtemp(:)
+
+  !--- Longitudes rotated to get them in [ -pi pi] interval.
+    DO i=1,lons;      IF(xf(i)>pi) EXIT;                   END DO; ip180 = i
+    DO i=1,lons;      IF(xf(i)>pi) xf(i)=xf(i)-depi;       END DO
+    DO i= ip180,lons; ind=i-ip180+1; xtemp(ind)=xf(i);     END DO
+    DO i= ind+1,lons;                xtemp(i  )=xf(i-ind); END DO
+
+  !--- Longitudes rotated in champf
+    DO l=1,levs
+    DO j=1,lats
+      DO i=ip180,lons; ind=i-ip180+1; champd(ind,j,l)=champf(i    ,j,l); END DO
+      DO i=ind+1,lons;                champd(i  ,j,l)=champf(i-ind,j,l); END DO
+    END DO
+    END DO
+  END IF
+
+!--- FLIPPED LATITUDES
+  IF(invlat) THEN
+    yf(:)=ytemp(:)
+    champf(:,:,:)=champd(:,:,:)
+    ytemp(lats:1:-1)=yf(:)
+    DO l=1,levs
+      DO j=1,lats; champd(:,lats-j+1,l)=champf(:,j,l); END DO
+    END DO
+  END IF
+
+!--- FOR BARYCENTRIC INTERPOLATION
+  IF(interbar) THEN
+    oldxd1 = xtemp(1)
+    xtemp(1:lons-1)=0.5*(xtemp(1:lons-1)+xtemp(2:lons))
+    xtemp(  lons  )=0.5*(xtemp(  lons  )+oldxd1+depi)
+    ytemp(1:lats-1)=0.5*(ytemp(1:lats-1)+ytemp(2:lats))
+  END IF
+
+!--- FLIPPED LEVELS
+  invlev=ztemp(1)<ztemp(levs)
+  IF(MAX(ztemp(1),ztemp(levs))<1200.) ztemp(:)=ztemp(:)*100.
+  IF(invlev) THEN
+    zf(:)=ztemp(:)
+    champf(:,:,:)=champd(:,:,:)
+    ztemp(levs:1:-1)=zf(:)
+    DO l=1,levs; champd(:,:,levs+1-l)=champf(:,:,l); END DO
+  END IF
+
+  DEALLOCATE(champf)
+  xf(:)=xtemp(:); DEALLOCATE(xtemp)
+  yf(:)=ytemp(:); DEALLOCATE(ytemp)
+  zf(:)=ztemp(:); DEALLOCATE(ztemp)
+
+END SUBROUTINE conf_dat3d
+!
+!-------------------------------------------------------------------------------
+
+END MODULE conf_dat_m
+
Index: DZ6/trunk/libf/dyn3d_common/conf_planete.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d_common/conf_planete.F90	(revision 5267)
+++ 	(revision )
@@ -1,81 +1,0 @@
-!
-! $Id$
-!
-SUBROUTINE conf_planete
-!
-USE IOIPSL
-USE comconst_mod, ONLY: pi, g, molmass, kappa, cpp, omeg, rad, &
-                        year_day, daylen, daysec, ihf
-USE comvert_mod, ONLY: preff, pa
-IMPLICIT NONE
-!
-!
-!   Declarations :
-!   --------------
-
-!
-!   local:
-!   ------
-
-! ---------------------------------------------
-! Initialisations de constantes de la dynamique
-! ---------------------------------------------
-! Pi
-pi=2.*asin(1.)
-
-!Reference surface pressure (Pa)
-! 101080 : specific value for CMIP5 aqua/terra planets
-! "Specify the initial dry mass to be equivalent to
-!  a global mean surface pressure (101325 minus 245) Pa."
-preff=101080.
-CALL getin('preff', preff)
-
-! Reference pressure at which hybrid coord. become purely pressure
-! pa=50000.
-pa=preff/2.
-CALL getin('pa', pa)
-
-! Gravity
-g=9.80665
-
-CALL getin('g',g)
-! Molar mass of the atmosphere
-
-molmass = 28.9644
-CALL getin('molmass',molmass)
-! kappa=R/Cp et Cp      
-
-kappa = 2./7.
-CALL getin('kappa',kappa)
-
-cpp=8.3145/molmass/kappa*1000.
-CALL getin('cpp',cpp)
-! Radius of the planet
-
-rad = 6371229. 
-CALL getin('radius',rad)
-
-! Length of a standard day (s)
-daysec=86400.
-CALL getin('daysec',daysec)
-
-! Rotation rate of the planet:
-! Length of a solar day, in standard days
-daylen = 1.
-
-CALL getin('daylen',daylen)
-! Number of days (standard) per year:
-
-year_day = 365.25
-CALL getin('year_day',year_day)
-! Omega
-! omeg=2.*pi/86400.
-
-omeg=2.*pi/daysec*(1./daylen+1./year_day)
-CALL getin('omeg',omeg)
-
-! Intrinsic heat flux (default: none) (only used if planet_type="giant")
-ihf = 0.
-call getin('ihf',ihf)
-
-END SUBROUTINE conf_planete
Index: /LMDZ6/trunk/libf/dyn3d_common/conf_planete.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d_common/conf_planete.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3d_common/conf_planete.f90	(revision 5268)
@@ -0,0 +1,81 @@
+!
+! $Id$
+!
+SUBROUTINE conf_planete
+!
+USE IOIPSL
+USE comconst_mod, ONLY: pi, g, molmass, kappa, cpp, omeg, rad, &
+                        year_day, daylen, daysec, ihf
+USE comvert_mod, ONLY: preff, pa
+IMPLICIT NONE
+!
+!
+!   Declarations :
+!   --------------
+
+!
+!   local:
+!   ------
+
+! ---------------------------------------------
+! Initialisations de constantes de la dynamique
+! ---------------------------------------------
+! Pi
+pi=2.*asin(1.)
+
+!Reference surface pressure (Pa)
+! 101080 : specific value for CMIP5 aqua/terra planets
+! "Specify the initial dry mass to be equivalent to
+!  a global mean surface pressure (101325 minus 245) Pa."
+preff=101080.
+CALL getin('preff', preff)
+
+! Reference pressure at which hybrid coord. become purely pressure
+! pa=50000.
+pa=preff/2.
+CALL getin('pa', pa)
+
+! Gravity
+g=9.80665
+
+CALL getin('g',g)
+! Molar mass of the atmosphere
+
+molmass = 28.9644
+CALL getin('molmass',molmass)
+! kappa=R/Cp et Cp      
+
+kappa = 2./7.
+CALL getin('kappa',kappa)
+
+cpp=8.3145/molmass/kappa*1000.
+CALL getin('cpp',cpp)
+! Radius of the planet
+
+rad = 6371229. 
+CALL getin('radius',rad)
+
+! Length of a standard day (s)
+daysec=86400.
+CALL getin('daysec',daysec)
+
+! Rotation rate of the planet:
+! Length of a solar day, in standard days
+daylen = 1.
+
+CALL getin('daylen',daylen)
+! Number of days (standard) per year:
+
+year_day = 365.25
+CALL getin('year_day',year_day)
+! Omega
+! omeg=2.*pi/86400.
+
+omeg=2.*pi/daysec*(1./daylen+1./year_day)
+CALL getin('omeg',omeg)
+
+! Intrinsic heat flux (default: none) (only used if planet_type="giant")
+ihf = 0.
+call getin('ihf',ihf)
+
+END SUBROUTINE conf_planete
Index: DZ6/trunk/libf/dyn3d_common/control_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d_common/control_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,42 +1,0 @@
-!
-! $Id $
-!
-
-MODULE control_mod
-
-! LF 01/2010
-! Remplacement du fichier et common control
-
-  IMPLICIT NONE
-
-  REAL,SAVE :: periodav
-  REAL,SAVE :: starttime
-  INTEGER,SAVE :: nday ! # of days to run
-  INTEGER,SAVE :: day_step ! # of dynamical time steps per day
-  INTEGER,SAVE :: iperiod ! make a Matsuno step before avery iperiod-1 LF steps
-  INTEGER,SAVE :: iapp_tracvl ! apply (cumulated) traceur advection every
-                              ! iapp_tracvl dynamical steps
-  INTEGER,SAVE :: nsplit_phys ! number of sub-cycle steps in call to physics
-  INTEGER,SAVE :: iconser
-  INTEGER,SAVE :: iecri
-  INTEGER,SAVE :: dissip_period ! apply dissipation every dissip_period
-                                ! dynamical step
-  INTEGER,SAVE :: iphysiq ! call physics every iphysiq dynamical steps
-  INTEGER,SAVE :: iecrimoy
-  INTEGER,SAVE :: dayref
-  INTEGER,SAVE :: anneeref ! reference year #
-  INTEGER,SAVE :: raz_date
-  INTEGER,SAVE :: ip_ebil_dyn
-  LOGICAL,SAVE :: offline
-  CHARACTER(len=10),SAVE :: planet_type ! planet type ('earth','mars',...)
-  LOGICAL,SAVE :: output_grads_dyn ! output dynamics diagnostics in
-                                   ! binary grads file 'dyn.dat' (y/n)
-  LOGICAL,SAVE :: ok_dynzon  ! output zonal transports in dynzon.nc file
-  LOGICAL,SAVE ::  ok_dyn_ins ! output instantaneous values of fields
-                              ! in the dynamics in NetCDF files dyn_hist*nc
-  LOGICAL,SAVE :: ok_dyn_ave ! output averaged values of fields in the dynamics
-                             ! in NetCDF files dyn_hist*ave.nc
-  LOGICAL,SAVE :: ok_dyn_xios ! xios outputs in dynamics
-  LOGICAL,SAVE :: resetvarc  ! allows to reset the variables in sortvarc
-
-END MODULE
Index: /LMDZ6/trunk/libf/dyn3d_common/control_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d_common/control_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3d_common/control_mod.f90	(revision 5268)
@@ -0,0 +1,42 @@
+!
+! $Id $
+!
+
+MODULE control_mod
+
+! LF 01/2010
+! Remplacement du fichier et common control
+
+  IMPLICIT NONE
+
+  REAL,SAVE :: periodav
+  REAL,SAVE :: starttime
+  INTEGER,SAVE :: nday ! # of days to run
+  INTEGER,SAVE :: day_step ! # of dynamical time steps per day
+  INTEGER,SAVE :: iperiod ! make a Matsuno step before avery iperiod-1 LF steps
+  INTEGER,SAVE :: iapp_tracvl ! apply (cumulated) traceur advection every
+                              ! iapp_tracvl dynamical steps
+  INTEGER,SAVE :: nsplit_phys ! number of sub-cycle steps in call to physics
+  INTEGER,SAVE :: iconser
+  INTEGER,SAVE :: iecri
+  INTEGER,SAVE :: dissip_period ! apply dissipation every dissip_period
+                                ! dynamical step
+  INTEGER,SAVE :: iphysiq ! call physics every iphysiq dynamical steps
+  INTEGER,SAVE :: iecrimoy
+  INTEGER,SAVE :: dayref
+  INTEGER,SAVE :: anneeref ! reference year #
+  INTEGER,SAVE :: raz_date
+  INTEGER,SAVE :: ip_ebil_dyn
+  LOGICAL,SAVE :: offline
+  CHARACTER(len=10),SAVE :: planet_type ! planet type ('earth','mars',...)
+  LOGICAL,SAVE :: output_grads_dyn ! output dynamics diagnostics in
+                                   ! binary grads file 'dyn.dat' (y/n)
+  LOGICAL,SAVE :: ok_dynzon  ! output zonal transports in dynzon.nc file
+  LOGICAL,SAVE ::  ok_dyn_ins ! output instantaneous values of fields
+                              ! in the dynamics in NetCDF files dyn_hist*nc
+  LOGICAL,SAVE :: ok_dyn_ave ! output averaged values of fields in the dynamics
+                             ! in NetCDF files dyn_hist*ave.nc
+  LOGICAL,SAVE :: ok_dyn_xios ! xios outputs in dynamics
+  LOGICAL,SAVE :: resetvarc  ! allows to reset the variables in sortvarc
+
+END MODULE
Index: DZ6/trunk/libf/dyn3d_common/convmas.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d_common/convmas.F90	(revision 5267)
+++ 	(revision )
@@ -1,35 +1,0 @@
-SUBROUTINE convmas (pbaru, pbarv, convm)
-!
-!-------------------------------------------------------------------------------
-! Authors: P. Le Van , Fr. Hourdin.
-!-------------------------------------------------------------------------------
-! Purpose: Compute mass flux convergence at p levels.
-  IMPLICIT NONE
-  include "dimensions.h"
-  include "paramet.h"
-  include "comgeom.h"
-!===============================================================================
-! Arguments:
-  REAL, INTENT(IN)  :: pbaru(ip1jmp1,llm)
-  REAL, INTENT(IN)  :: pbarv(ip1jm  ,llm)
-  REAL, INTENT(OUT) :: convm(ip1jmp1,llm)
-!===============================================================================
-! Method used:   Computation from top to bottom.
-!   Mass convergence at level llm is equal to zero and is not stored in convm.
-!===============================================================================
-! Local variables:
-  INTEGER :: l
-!===============================================================================
-
-!--- Computation of - (d(pbaru)/dx + d(pbarv)/dy )
-  CALL convflu( pbaru, pbarv, llm, convm )
-
-!--- Filter
-  CALL filtreg( convm, jjp1, llm, 2, 2, .TRUE., 1 )
-
-!--- Mass convergence is integrated from top to bottom
-  DO l=llmm1,1,-1
-    convm(:,l) = convm(:,l) + convm(:,l+1)
-  END DO
-
-END SUBROUTINE convmas
Index: /LMDZ6/trunk/libf/dyn3d_common/convmas.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d_common/convmas.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3d_common/convmas.f90	(revision 5268)
@@ -0,0 +1,35 @@
+SUBROUTINE convmas (pbaru, pbarv, convm)
+!
+!-------------------------------------------------------------------------------
+! Authors: P. Le Van , Fr. Hourdin.
+!-------------------------------------------------------------------------------
+! Purpose: Compute mass flux convergence at p levels.
+  IMPLICIT NONE
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom.h"
+!===============================================================================
+! Arguments:
+  REAL, INTENT(IN)  :: pbaru(ip1jmp1,llm)
+  REAL, INTENT(IN)  :: pbarv(ip1jm  ,llm)
+  REAL, INTENT(OUT) :: convm(ip1jmp1,llm)
+!===============================================================================
+! Method used:   Computation from top to bottom.
+!   Mass convergence at level llm is equal to zero and is not stored in convm.
+!===============================================================================
+! Local variables:
+  INTEGER :: l
+!===============================================================================
+
+!--- Computation of - (d(pbaru)/dx + d(pbarv)/dy )
+  CALL convflu( pbaru, pbarv, llm, convm )
+
+!--- Filter
+  CALL filtreg( convm, jjp1, llm, 2, 2, .TRUE., 1 )
+
+!--- Mass convergence is integrated from top to bottom
+  DO l=llmm1,1,-1
+    convm(:,l) = convm(:,l) + convm(:,l+1)
+  END DO
+
+END SUBROUTINE convmas
Index: DZ6/trunk/libf/dyn3d_common/covcont.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d_common/covcont.F90	(revision 5267)
+++ 	(revision )
@@ -1,29 +1,0 @@
-SUBROUTINE covcont (klevel,ucov, vcov, ucont, vcont )
-!
-!-------------------------------------------------------------------------------
-! Author: P. Le Van
-!-------------------------------------------------------------------------------
-! Purpose: Compute contravariant components from covariant components.
-!-------------------------------------------------------------------------------
-  IMPLICIT NONE
-  include "dimensions.h"
-  include "paramet.h"
-  include "comgeom.h"
-!===============================================================================
-! Arguments:
-  INTEGER, INTENT(IN)  :: klevel                    !--- VERTICAL LEVELS NUMBER
-  REAL,    INTENT(IN)  :: ucov ( ip1jmp1,klevel )   !--- U COVARIANT WIND
-  REAL,    INTENT(IN)  :: vcov ( ip1jm  ,klevel )   !--- V COVARIANT WIND
-  REAL,    INTENT(OUT) :: ucont( ip1jmp1,klevel )   !--- U CONTRAVAR WIND
-  REAL,    INTENT(OUT) :: vcont( ip1jm  ,klevel )   !--- V CONTRAVAR WIND
-!===============================================================================
-!   Local variables:
-  INTEGER :: l
-!===============================================================================
-  DO l=1,klevel
-    ucont(iip2:ip1jm,l)=ucov(iip2:ip1jm,l) * unscu2(iip2:ip1jm)
-    vcont(   1:ip1jm,l)=vcov(   1:ip1jm,l) * unscv2(   1:ip1jm)
-  END DO
-
-END SUBROUTINE covcont
-
Index: /LMDZ6/trunk/libf/dyn3d_common/covcont.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d_common/covcont.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3d_common/covcont.f90	(revision 5268)
@@ -0,0 +1,29 @@
+SUBROUTINE covcont (klevel,ucov, vcov, ucont, vcont )
+!
+!-------------------------------------------------------------------------------
+! Author: P. Le Van
+!-------------------------------------------------------------------------------
+! Purpose: Compute contravariant components from covariant components.
+!-------------------------------------------------------------------------------
+  IMPLICIT NONE
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom.h"
+!===============================================================================
+! Arguments:
+  INTEGER, INTENT(IN)  :: klevel                    !--- VERTICAL LEVELS NUMBER
+  REAL,    INTENT(IN)  :: ucov ( ip1jmp1,klevel )   !--- U COVARIANT WIND
+  REAL,    INTENT(IN)  :: vcov ( ip1jm  ,klevel )   !--- V COVARIANT WIND
+  REAL,    INTENT(OUT) :: ucont( ip1jmp1,klevel )   !--- U CONTRAVAR WIND
+  REAL,    INTENT(OUT) :: vcont( ip1jm  ,klevel )   !--- V CONTRAVAR WIND
+!===============================================================================
+!   Local variables:
+  INTEGER :: l
+!===============================================================================
+  DO l=1,klevel
+    ucont(iip2:ip1jm,l)=ucov(iip2:ip1jm,l) * unscu2(iip2:ip1jm)
+    vcont(   1:ip1jm,l)=vcov(   1:ip1jm,l) * unscv2(   1:ip1jm)
+  END DO
+
+END SUBROUTINE covcont
+
Index: DZ6/trunk/libf/dyn3d_common/disvert.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d_common/disvert.F90	(revision 5267)
+++ 	(revision )
@@ -1,459 +1,0 @@
-! $Id$
-
-SUBROUTINE disvert()
-
-  use ioipsl, only: getin
-  use new_unit_m, only: new_unit
-  use assert_m, only: assert
-  USE comvert_mod, ONLY: ap, bp, aps, bps, nivsigs, nivsig, dpres, presnivs, &
-                         pseudoalt, pa, preff, scaleheight, presinter
-  USE logic_mod, ONLY: ok_strato
-
-  IMPLICIT NONE
-
-  include "dimensions.h"
-  include "paramet.h"
-  include "iniprint.h"
-
-!-------------------------------------------------------------------------------
-! Purpose: Vertical distribution functions for LMDZ.
-!          Triggered by the levels number llm.
-!-------------------------------------------------------------------------------
-! Read    in "comvert_mod":
-
-! pa !--- vertical coordinate is close to a PRESSURE COORDINATE FOR P
-! < 0.3 * pa (relative variation of p on a model level is < 0.1 %)
-
-! preff                      !--- REFERENCE PRESSURE                 (101325 Pa)
-! Written in "comvert_mod":
-! ap(llm+1), bp(llm+1)       !--- Ap, Bp HYBRID COEFFICIENTS AT INTERFACES
-! aps(llm),  bps(llm)        !--- Ap, Bp HYBRID COEFFICIENTS AT MID-LAYERS
-! dpres(llm)                 !--- PRESSURE DIFFERENCE FOR EACH LAYER
-! presnivs(llm)              !--- PRESSURE AT EACH MID-LAYER
-! presinter(llm+1)           !--- PRESSURE AT EACH INTERFACE
-! scaleheight                !--- VERTICAL SCALE HEIGHT            (Earth: 8kms)
-! nivsig(llm+1)              !--- SIGMA INDEX OF EACH LAYER INTERFACE
-! nivsigs(llm)               !--- SIGMA INDEX OF EACH MID-LAYER
-!-------------------------------------------------------------------------------
-! Local variables:
-  REAL sig(llm+1), dsig(llm)
-  REAL sig0(llm+1), zz(llm+1)
-  REAL zk, zkm1, dzk1, dzk2, z, k0, k1
-
-  INTEGER l, unit
-  REAL dsigmin
-  REAL vert_scale,vert_dzmin,vert_dzlow,vert_z0low,vert_dzmid,vert_z0mid,vert_h_mid,vert_dzhig,vert_z0hig,vert_h_hig
-
-  REAL alpha, beta, deltaz
-  REAL x
-  character(len=*),parameter :: modname="disvert"
-
-  character(len=24):: vert_sampling
-  ! (allowed values are "param", "tropo", "strato" and "read")
-
-  !-----------------------------------------------------------------------
-
-  WRITE(lunout,*) TRIM(modname)//" starts"
-
-  ! default scaleheight is 8km for earth
-  scaleheight=8.
-
-  vert_sampling = merge("strato", "tropo ", ok_strato) ! default value
-  call getin('vert_sampling', vert_sampling)
-  WRITE(lunout,*) TRIM(modname)//' vert_sampling = ' // vert_sampling
-  if (llm==39 .and. vert_sampling=="strato") then
-     dsigmin=0.3 ! Vieille option par défaut pour CMIP5
-  else
-     dsigmin=1.
-  endif
-  call getin('dsigmin', dsigmin)
-  WRITE(LUNOUT,*) trim(modname), 'Discretisation verticale DSIGMIN=',dsigmin
-
-
-  select case (vert_sampling)
-  case ("param")
-     ! On lit les options dans sigma.def:
-     OPEN(99, file='sigma.def', status='old', form='formatted')
-     READ(99, *) scaleheight ! hauteur d'echelle 8.
-     READ(99, *) deltaz ! epaiseur de la premiere couche 0.04
-     READ(99, *) beta ! facteur d'acroissement en haut 1.3
-     READ(99, *) k0 ! nombre de couches dans la transition surf
-     READ(99, *) k1 ! nombre de couches dans la transition haute
-     CLOSE(99)
-     alpha=deltaz/(llm*scaleheight)
-     write(lunout, *)trim(modname),':scaleheight, alpha, k0, k1, beta', &
-                               scaleheight, alpha, k0, k1, beta
-
-     alpha=deltaz/tanh(1./k0)*2.
-     zkm1=0.
-     sig(1)=1.
-     do l=1, llm
-        sig(l+1)=(cosh(l/k0))**(-alpha*k0/scaleheight) &
-             *exp(-alpha/scaleheight*tanh((llm-k1)/k0) &
-                  *beta**(l-(llm-k1))/log(beta))
-        zk=-scaleheight*log(sig(l+1))
-
-        dzk1=alpha*tanh(l/k0)
-        dzk2=alpha*tanh((llm-k1)/k0)*beta**(l-(llm-k1))/log(beta)
-        write(lunout, *)l, sig(l+1), zk, zk-zkm1, dzk1, dzk2
-        zkm1=zk
-     enddo
-
-     sig(llm+1)=0.
-
-     bp(: llm) = EXP(1. - 1. / sig(: llm)**2)
-     bp(llmp1) = 0.
-
-     ap = pa * (sig - bp)
-  case("sigma")
-     DO l = 1, llm
-        x = 2*asin(1.) * (l - 0.5) / (llm + 1)
-        dsig(l) = dsigmin + 7.0 * SIN(x)**2
-     ENDDO
-     dsig = dsig / sum(dsig)
-     sig(llm+1) = 0.
-     DO l = llm, 1, -1
-        sig(l) = sig(l+1) + dsig(l)
-     ENDDO
-
-     bp(1)=1.
-     bp(2: llm) = sig(2:llm)
-     bp(llmp1) = 0.
-     ap(:)=0.
-  case("tropo")
-     DO l = 1, llm
-        x = 2*asin(1.) * (l - 0.5) / (llm + 1)
-        dsig(l) = dsigmin + 7.0 * SIN(x)**2
-     ENDDO
-     dsig = dsig / sum(dsig)
-     sig(llm+1) = 0.
-     DO l = llm, 1, -1
-        sig(l) = sig(l+1) + dsig(l)
-     ENDDO
-
-     bp(1)=1.
-     bp(2: llm) = EXP(1. - 1. / sig(2: llm)**2)
-     bp(llmp1) = 0.
-
-     ap(1)=0.
-     ap(2: llm + 1) = pa * (sig(2: llm + 1) - bp(2: llm + 1))
-  case("strato")
-     DO l = 1, llm
-        x = 2*asin(1.) * (l - 0.5) / (llm + 1)
-        dsig(l) =(dsigmin + 7. * SIN(x)**2) &
-             *(0.5*(1.-tanh(1.*(x-asin(1.))/asin(1.))))**2
-     ENDDO
-     dsig = dsig / sum(dsig)
-     sig(llm+1) = 0.
-     DO l = llm, 1, -1
-        sig(l) = sig(l+1) + dsig(l)
-     ENDDO
-
-     bp(1)=1.
-     bp(2: llm) = EXP(1. - 1. / sig(2: llm)**2)
-     bp(llmp1) = 0.
-
-     ap(1)=0.
-     ap(2: llm + 1) = pa * (sig(2: llm + 1) - bp(2: llm + 1))
-  case("strato_correct")
-!==================================================================
-! Fredho 2014/05/18, Saint-Louis du Senegal
-! Cette version de la discretisation strato est corrige au niveau
-! du passage des sig aux ap, bp
-! la version precedente donne un coude dans l'epaisseur des couches
-! vers la tropopause
-!==================================================================
-
-
-     DO l = 1, llm
-        x = 2*asin(1.) * (l - 0.5) / (llm + 1)
-        dsig(l) =(dsigmin + 7. * SIN(x)**2) &
-             *(0.5*(1.-tanh(1.*(x-asin(1.))/asin(1.))))**2
-     ENDDO
-     dsig = dsig / sum(dsig)
-     sig0(llm+1) = 0.
-     DO l = llm, 1, -1
-        sig0(l) = sig0(l+1) + dsig(l)
-     ENDDO
-     sig=racinesig(sig0)
-
-     bp(1)=1.
-     bp(2:llm)=EXP(1.-1./sig(2: llm)**2)
-     bp(llmp1)=0.
-
-     ap(1)=0.
-     ap(2:llm)=pa*(sig(2:llm)-bp(2:llm))
-     ap(llm+1)=0.
-
-  CASE("strato_custom0") 
-!=======================================================
-! Version Transitoire
-    ! custumize strato distribution with specific alpha & beta values and function
-    ! depending on llm (experimental and temporary)!
-    SELECT CASE (llm)
-      CASE(55)
-        alpha=0.45
-        beta=4.0
-      CASE(63)
-        alpha=0.45
-        beta=5.0
-      CASE(71)
-        alpha=3.05
-        beta=65.
-      CASE(79)
-        alpha=3.20
-        ! alpha=2.05 ! FLOTT 79 (PLANTE)
-        beta=70.
-    END SELECT
-    ! Or used values provided by user in def file:
-    CALL getin("strato_alpha",alpha)
-    CALL getin("strato_beta",beta)
-    
-    ! Build geometrical distribution
-    scaleheight=7.
-    zz(1)=0.
-    IF (llm==55.OR.llm==63) THEN
-      DO l=1,llm
-        z=zz(l)/scaleheight
-        zz(l+1)=zz(l)+0.03+z*1.5*(1.-TANH(z-0.5))+alpha*(1.+TANH(z-1.5))     &
-                            +5.0*EXP((l-llm)/beta)
-      ENDDO
-    ELSEIF (llm==71) THEN !.OR.llm==79) THEN      ! FLOTT 79 (PLANTE)
-      DO l=1,llm
-        z=zz(l)
-        zz(l+1)=zz(l)+0.02+0.88*TANH(z/2.5)+alpha*(1.+TANH((z-beta)/15.))
-      ENDDO
-    ELSEIF (llm==79) THEN
-      DO l=1,llm
-        z=zz(l)
-        zz(l+1)=zz(l)+0.02+0.80*TANH(z/3.8)+alpha*(1+TANH((z-beta)/17.))     &
-                            +0.03*TANH(z/.25)
-      ENDDO
-    ENDIF ! of IF (llm==55.OR.llm==63) ...
-    
-
-    ! Build sigma distribution
-    sig0=EXP(-zz(:)/scaleheight)
-    sig0(llm+1)=0.
-!    sig=ridders(sig0)
-    sig=racinesig(sig0)
-    
-    ! Compute ap() and bp()
-    bp(1)=1.
-    bp(2:llm)=EXP(1.-1./sig(2:llm)**2)
-    bp(llm+1)=0.
-    ap=pa*(sig-bp)
-
-  CASE("strato_custom") 
-!===================================================================
-! David Cugnet, François Lott, Lionel Guez, Ehouoarn Millour, Fredho
-! 2014/05
-! custumize strato distribution
-! Al the parameter are given in km assuming a given scalehigh
-    vert_scale=7.     ! scale hight
-    vert_dzmin=0.02   ! width of first layer
-    vert_dzlow=1.     ! dz in the low atmosphere
-    vert_z0low=8.     ! height at which resolution recches dzlow
-    vert_dzmid=3.     ! dz in the mid atmsophere
-    vert_z0mid=70.    ! height at which resolution recches dzmid
-    vert_h_mid=20.    ! width of the transition
-    vert_dzhig=11.    ! dz in the high atmsophere
-    vert_z0hig=80.    ! height at which resolution recches dz
-    vert_h_hig=20.    ! width of the transition
-!===================================================================
-
-    call getin('vert_scale',vert_scale)
-    call getin('vert_dzmin',vert_dzmin)
-    call getin('vert_dzlow',vert_dzlow)
-    call getin('vert_z0low',vert_z0low)
-    CALL getin('vert_dzmid',vert_dzmid)
-    CALL getin('vert_z0mid',vert_z0mid)
-    call getin('vert_h_mid',vert_h_mid)
-    call getin('vert_dzhig',vert_dzhig)
-    call getin('vert_z0hig',vert_z0hig)
-    call getin('vert_h_hig',vert_h_hig)
-
-    scaleheight=vert_scale ! for consistency with further computations
-    ! Build geometrical distribution
-    zz(1)=0.
-    DO l=1,llm
-       z=zz(l)
-       zz(l+1)=zz(l)+vert_dzmin+vert_dzlow*TANH(z/vert_z0low)+                &
-&      (vert_dzmid-vert_dzlow)* &
-&           (TANH((z-vert_z0mid)/vert_h_mid)-TANH((-vert_z0mid)/vert_h_mid)) &
-&     +(vert_dzhig-vert_dzmid-vert_dzlow)*                                  &
-&           (TANH((z-vert_z0hig)/vert_h_hig)-TANH((-vert_z0hig)/vert_h_hig))
-    ENDDO
-
-
-!===================================================================
-! Comment added Fredho 2014/05/18, Saint-Louis, Senegal
-! From approximate z to ap, bp, so that p=ap+bp*p0 and p/p0=exp(-z/H)
-! sig0 is p/p0
-! sig is an intermediate distribution introduce to estimate bp
-! 1.   sig0=exp(-z/H)
-! 2.   inversion of sig0=(1-pa/p0)*sig+(1-pa/p0)*exp(1-1/sig**2)
-! 3.   bp=exp(1-1/sig**2)
-! 4.   ap deduced from  the combination of 2 and 3 so that sig0=ap/p0+bp
-!===================================================================
-
-    sig0=EXP(-zz(:)/vert_scale)
-    sig0(llm+1)=0.
-    sig=racinesig(sig0)
-    bp(1)=1.
-    bp(2:llm)=EXP(1.-1./sig(2:llm)**2)
-    bp(llm+1)=0.
-    ap=pa*(sig-bp)
-
-  case("read")
-     ! Read "ap" and "bp". First line is skipped (title line). "ap"
-     ! should be in Pa. First couple of values should correspond to
-     ! the surface, that is : "bp" should be in descending order.
-     call new_unit(unit)
-     open(unit, file="hybrid.txt", status="old", action="read", &
-          position="rewind")
-     read(unit, fmt=*) ! skip title line
-     do l = 1, llm + 1
-        read(unit, fmt=*) ap(l), bp(l)
-     end do
-     close(unit)
-     call assert(ap(1) == 0., ap(llm + 1) == 0., bp(1) == 1., &
-          bp(llm + 1) == 0., "disvert: bad ap or bp values")
-  case default
-     call abort_gcm("disvert", 'Wrong value for "vert_sampling"', 1)
-  END select
-
-  DO l=1, llm
-     nivsigs(l) = REAL(l)
-  ENDDO
-
-  DO l=1, llmp1
-     nivsig(l)= REAL(l)
-  ENDDO
-
-  write(lunout, *)  trim(modname),': BP '
-  write(lunout, *) bp
-  write(lunout, *)  trim(modname),': AP '
-  write(lunout, *) ap
-
-  write(lunout, *) 'Niveaux de pressions approximatifs aux centres des'
-  write(lunout, *)'couches calcules pour une pression de surface =', preff
-  write(lunout, *) 'et altitudes equivalentes pour une hauteur d echelle de '
-  write(lunout, *) scaleheight,' km'
-  DO l = 1, llm
-     dpres(l) = bp(l) - bp(l+1)
-     aps(l) =  0.5 *( ap(l) +ap(l+1))
-     bps(l) =  0.5 *( bp(l) +bp(l+1))
-     presnivs(l) = 0.5 *( ap(l)+bp(l)*preff + ap(l+1)+bp(l+1)*preff )
-     pseudoalt(l) = log(preff/presnivs(l))*scaleheight
-     write(lunout, *)'PRESNIVS(', l, ')=', presnivs(l), ' Z ~ ', &
-          pseudoalt(l) &
-          , ' DZ ~ ', scaleheight*log((ap(l)+bp(l)*preff)/ &
-          max(ap(l+1)+bp(l+1)*preff, 1.e-10))
-  ENDDO
-  DO l=1, llmp1
-     presinter(l)= ( ap(l)+bp(l)*preff)
-     write(lunout, *)'PRESINTER(', l, ')=', presinter(l)
-  ENDDO
-
-  write(lunout, *) trim(modname),': PRESNIVS '
-  write(lunout, *) presnivs
-
-CONTAINS
-
-!-------------------------------------------------------------------------------
-!
-FUNCTION ridders(sig) RESULT(sg)
-!
-!-------------------------------------------------------------------------------
-  IMPLICIT NONE
-!-------------------------------------------------------------------------------
-! Purpose: Search for s solving (Pa/Preff)*s+(1-Pa/Preff)*EXP(1-1./s**2)=sg
-! Notes:   Uses Ridders' method, quite robust. Initial bracketing: 0<=sg<=1.
-! Reference: Ridders, C. F. J. "A New Algorithm for Computing a Single Root of a
-!       Real Continuous Function" IEEE Trans. Circuits Systems 26, 979-980, 1979
-!-------------------------------------------------------------------------------
-! Arguments:
-  REAL, INTENT(IN)  :: sig(:)
-  REAL              :: sg(SIZE(sig))
-!-------------------------------------------------------------------------------
-! Local variables:
-  INTEGER :: it, ns, maxit
-  REAL :: c1, c2, x1, x2, x3, x4, f1, f2, f3, f4, s, xx, distrib
-!-------------------------------------------------------------------------------
-  ns=SIZE(sig); maxit=9999
-  c1=Pa/Preff; c2=1.-c1
-  DO l=1,ns
-    xx=HUGE(1.)
-    x1=0.0; f1=distrib(x1,c1,c2,sig(l))
-    x2=1.0; f2=distrib(x2,c1,c2,sig(l))
-    DO it=1,maxit
-      x3=0.5*(x1+x2); f3=distrib(x3,c1,c2,sig(l))
-      s=SQRT(f3**2-f1*f2);                 IF(s==0.) EXIT
-      x4=x3+(x3-x1)*(SIGN(1.,f1-f2)*f3/s); IF(ABS(10.*LOG(x4-xx))<=1E-5) EXIT
-      xx=x4; f4=distrib(x4,c1,c2,sig(l));  IF(f4==0.) EXIT
-      IF(SIGN(f3,f4)/=f3) THEN;      x1=x3; f1=f3; x2=xx; f2=f4
-      ELSE IF(SIGN(f1,f4)/=f1) THEN; x2=xx; f2=f4
-      ELSE IF(SIGN(f2,f4)/=f2) THEN; x1=xx; f1=f4
-      ELSE; CALL abort_gcm("ridders",'Algorithm failed (which is odd...', 1)
-      END IF
-      IF(ABS(10.*LOG(ABS(x2-x1)))<=1E-5) EXIT       !--- ERROR ON SIG <= 0.01m            
-    END DO
-    IF(it==maxit+1) WRITE(lunout,'(a,i3)')'WARNING in ridder: failed to converg&
-     &e for level ',l
-    sg(l)=xx
-  END DO
-  sg(1)=1.; sg(ns)=0.
-
-END FUNCTION ridders
-
-FUNCTION racinesig(sig) RESULT(sg)
-!
-!-------------------------------------------------------------------------------
-  IMPLICIT NONE
-!-------------------------------------------------------------------------------
-! Fredho 2014/05/18
-! Purpose: Search for s solving (Pa/Preff)*sg+(1-Pa/Preff)*EXP(1-1./sg**2)=s
-! Notes:   Uses Newton Raphson search
-!-------------------------------------------------------------------------------
-! Arguments:
-  REAL, INTENT(IN)  :: sig(:)
-  REAL              :: sg(SIZE(sig))
-!-------------------------------------------------------------------------------
-! Local variables:
-  INTEGER :: it, ns, maxit
-  REAL :: c1, c2, x1, x2, x3, x4, f1, f2, f3, f4, s, xx, distrib
-!-------------------------------------------------------------------------------
-  ns=SIZE(sig); maxit=100
-  c1=Pa/Preff; c2=1.-c1
-  DO l=2,ns-1
-    sg(l)=sig(l)
-    DO it=1,maxit
-       f1=exp(1-1./sg(l)**2)*(1.-c1)
-       sg(l)=sg(l)-(c1*sg(l)+f1-sig(l))/(c1+2*f1*sg(l)**(-3))
-    ENDDO
-!   print*,'SSSSIG ',sig(l),sg(l),c1*sg(l)+exp(1-1./sg(l)**2)*(1.-c1)
-  ENDDO
-  sg(1)=1.; sg(ns)=0.
-
-END FUNCTION racinesig
-
-
-
-
-END SUBROUTINE disvert
-
-!-------------------------------------------------------------------------------
-
-FUNCTION distrib(x,c1,c2,x0) RESULT(res)
-!
-!-------------------------------------------------------------------------------
-! Arguments:
-  REAL, INTENT(IN) :: x, c1, c2, x0
-  REAL             :: res
-!-------------------------------------------------------------------------------
-  res=c1*x+c2*EXP(1-1/(x**2))-x0
-
-END FUNCTION distrib
-
-
Index: /LMDZ6/trunk/libf/dyn3d_common/disvert.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d_common/disvert.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3d_common/disvert.f90	(revision 5268)
@@ -0,0 +1,459 @@
+! $Id$
+
+SUBROUTINE disvert()
+
+  use ioipsl, only: getin
+  use new_unit_m, only: new_unit
+  use assert_m, only: assert
+  USE comvert_mod, ONLY: ap, bp, aps, bps, nivsigs, nivsig, dpres, presnivs, &
+                         pseudoalt, pa, preff, scaleheight, presinter
+  USE logic_mod, ONLY: ok_strato
+
+  IMPLICIT NONE
+
+  include "dimensions.h"
+  include "paramet.h"
+  include "iniprint.h"
+
+!-------------------------------------------------------------------------------
+! Purpose: Vertical distribution functions for LMDZ.
+!          Triggered by the levels number llm.
+!-------------------------------------------------------------------------------
+! Read    in "comvert_mod":
+
+! pa !--- vertical coordinate is close to a PRESSURE COORDINATE FOR P
+! < 0.3 * pa (relative variation of p on a model level is < 0.1 %)
+
+! preff                      !--- REFERENCE PRESSURE                 (101325 Pa)
+! Written in "comvert_mod":
+! ap(llm+1), bp(llm+1)       !--- Ap, Bp HYBRID COEFFICIENTS AT INTERFACES
+! aps(llm),  bps(llm)        !--- Ap, Bp HYBRID COEFFICIENTS AT MID-LAYERS
+! dpres(llm)                 !--- PRESSURE DIFFERENCE FOR EACH LAYER
+! presnivs(llm)              !--- PRESSURE AT EACH MID-LAYER
+! presinter(llm+1)           !--- PRESSURE AT EACH INTERFACE
+! scaleheight                !--- VERTICAL SCALE HEIGHT            (Earth: 8kms)
+! nivsig(llm+1)              !--- SIGMA INDEX OF EACH LAYER INTERFACE
+! nivsigs(llm)               !--- SIGMA INDEX OF EACH MID-LAYER
+!-------------------------------------------------------------------------------
+! Local variables:
+  REAL sig(llm+1), dsig(llm)
+  REAL sig0(llm+1), zz(llm+1)
+  REAL zk, zkm1, dzk1, dzk2, z, k0, k1
+
+  INTEGER l, unit
+  REAL dsigmin
+  REAL vert_scale,vert_dzmin,vert_dzlow,vert_z0low,vert_dzmid,vert_z0mid,vert_h_mid,vert_dzhig,vert_z0hig,vert_h_hig
+
+  REAL alpha, beta, deltaz
+  REAL x
+  character(len=*),parameter :: modname="disvert"
+
+  character(len=24):: vert_sampling
+  ! (allowed values are "param", "tropo", "strato" and "read")
+
+  !-----------------------------------------------------------------------
+
+  WRITE(lunout,*) TRIM(modname)//" starts"
+
+  ! default scaleheight is 8km for earth
+  scaleheight=8.
+
+  vert_sampling = merge("strato", "tropo ", ok_strato) ! default value
+  call getin('vert_sampling', vert_sampling)
+  WRITE(lunout,*) TRIM(modname)//' vert_sampling = ' // vert_sampling
+  if (llm==39 .and. vert_sampling=="strato") then
+     dsigmin=0.3 ! Vieille option par défaut pour CMIP5
+  else
+     dsigmin=1.
+  endif
+  call getin('dsigmin', dsigmin)
+  WRITE(LUNOUT,*) trim(modname), 'Discretisation verticale DSIGMIN=',dsigmin
+
+
+  select case (vert_sampling)
+  case ("param")
+     ! On lit les options dans sigma.def:
+     OPEN(99, file='sigma.def', status='old', form='formatted')
+     READ(99, *) scaleheight ! hauteur d'echelle 8.
+     READ(99, *) deltaz ! epaiseur de la premiere couche 0.04
+     READ(99, *) beta ! facteur d'acroissement en haut 1.3
+     READ(99, *) k0 ! nombre de couches dans la transition surf
+     READ(99, *) k1 ! nombre de couches dans la transition haute
+     CLOSE(99)
+     alpha=deltaz/(llm*scaleheight)
+     write(lunout, *)trim(modname),':scaleheight, alpha, k0, k1, beta', &
+                               scaleheight, alpha, k0, k1, beta
+
+     alpha=deltaz/tanh(1./k0)*2.
+     zkm1=0.
+     sig(1)=1.
+     do l=1, llm
+        sig(l+1)=(cosh(l/k0))**(-alpha*k0/scaleheight) &
+             *exp(-alpha/scaleheight*tanh((llm-k1)/k0) &
+                  *beta**(l-(llm-k1))/log(beta))
+        zk=-scaleheight*log(sig(l+1))
+
+        dzk1=alpha*tanh(l/k0)
+        dzk2=alpha*tanh((llm-k1)/k0)*beta**(l-(llm-k1))/log(beta)
+        write(lunout, *)l, sig(l+1), zk, zk-zkm1, dzk1, dzk2
+        zkm1=zk
+     enddo
+
+     sig(llm+1)=0.
+
+     bp(: llm) = EXP(1. - 1. / sig(: llm)**2)
+     bp(llmp1) = 0.
+
+     ap = pa * (sig - bp)
+  case("sigma")
+     DO l = 1, llm
+        x = 2*asin(1.) * (l - 0.5) / (llm + 1)
+        dsig(l) = dsigmin + 7.0 * SIN(x)**2
+     ENDDO
+     dsig = dsig / sum(dsig)
+     sig(llm+1) = 0.
+     DO l = llm, 1, -1
+        sig(l) = sig(l+1) + dsig(l)
+     ENDDO
+
+     bp(1)=1.
+     bp(2: llm) = sig(2:llm)
+     bp(llmp1) = 0.
+     ap(:)=0.
+  case("tropo")
+     DO l = 1, llm
+        x = 2*asin(1.) * (l - 0.5) / (llm + 1)
+        dsig(l) = dsigmin + 7.0 * SIN(x)**2
+     ENDDO
+     dsig = dsig / sum(dsig)
+     sig(llm+1) = 0.
+     DO l = llm, 1, -1
+        sig(l) = sig(l+1) + dsig(l)
+     ENDDO
+
+     bp(1)=1.
+     bp(2: llm) = EXP(1. - 1. / sig(2: llm)**2)
+     bp(llmp1) = 0.
+
+     ap(1)=0.
+     ap(2: llm + 1) = pa * (sig(2: llm + 1) - bp(2: llm + 1))
+  case("strato")
+     DO l = 1, llm
+        x = 2*asin(1.) * (l - 0.5) / (llm + 1)
+        dsig(l) =(dsigmin + 7. * SIN(x)**2) &
+             *(0.5*(1.-tanh(1.*(x-asin(1.))/asin(1.))))**2
+     ENDDO
+     dsig = dsig / sum(dsig)
+     sig(llm+1) = 0.
+     DO l = llm, 1, -1
+        sig(l) = sig(l+1) + dsig(l)
+     ENDDO
+
+     bp(1)=1.
+     bp(2: llm) = EXP(1. - 1. / sig(2: llm)**2)
+     bp(llmp1) = 0.
+
+     ap(1)=0.
+     ap(2: llm + 1) = pa * (sig(2: llm + 1) - bp(2: llm + 1))
+  case("strato_correct")
+!==================================================================
+! Fredho 2014/05/18, Saint-Louis du Senegal
+! Cette version de la discretisation strato est corrige au niveau
+! du passage des sig aux ap, bp
+! la version precedente donne un coude dans l'epaisseur des couches
+! vers la tropopause
+!==================================================================
+
+
+     DO l = 1, llm
+        x = 2*asin(1.) * (l - 0.5) / (llm + 1)
+        dsig(l) =(dsigmin + 7. * SIN(x)**2) &
+             *(0.5*(1.-tanh(1.*(x-asin(1.))/asin(1.))))**2
+     ENDDO
+     dsig = dsig / sum(dsig)
+     sig0(llm+1) = 0.
+     DO l = llm, 1, -1
+        sig0(l) = sig0(l+1) + dsig(l)
+     ENDDO
+     sig=racinesig(sig0)
+
+     bp(1)=1.
+     bp(2:llm)=EXP(1.-1./sig(2: llm)**2)
+     bp(llmp1)=0.
+
+     ap(1)=0.
+     ap(2:llm)=pa*(sig(2:llm)-bp(2:llm))
+     ap(llm+1)=0.
+
+  CASE("strato_custom0") 
+!=======================================================
+! Version Transitoire
+    ! custumize strato distribution with specific alpha & beta values and function
+    ! depending on llm (experimental and temporary)!
+    SELECT CASE (llm)
+      CASE(55)
+        alpha=0.45
+        beta=4.0
+      CASE(63)
+        alpha=0.45
+        beta=5.0
+      CASE(71)
+        alpha=3.05
+        beta=65.
+      CASE(79)
+        alpha=3.20
+        ! alpha=2.05 ! FLOTT 79 (PLANTE)
+        beta=70.
+    END SELECT
+    ! Or used values provided by user in def file:
+    CALL getin("strato_alpha",alpha)
+    CALL getin("strato_beta",beta)
+    
+    ! Build geometrical distribution
+    scaleheight=7.
+    zz(1)=0.
+    IF (llm==55.OR.llm==63) THEN
+      DO l=1,llm
+        z=zz(l)/scaleheight
+        zz(l+1)=zz(l)+0.03+z*1.5*(1.-TANH(z-0.5))+alpha*(1.+TANH(z-1.5))     &
+                            +5.0*EXP((l-llm)/beta)
+      ENDDO
+    ELSEIF (llm==71) THEN !.OR.llm==79) THEN      ! FLOTT 79 (PLANTE)
+      DO l=1,llm
+        z=zz(l)
+        zz(l+1)=zz(l)+0.02+0.88*TANH(z/2.5)+alpha*(1.+TANH((z-beta)/15.))
+      ENDDO
+    ELSEIF (llm==79) THEN
+      DO l=1,llm
+        z=zz(l)
+        zz(l+1)=zz(l)+0.02+0.80*TANH(z/3.8)+alpha*(1+TANH((z-beta)/17.))     &
+                            +0.03*TANH(z/.25)
+      ENDDO
+    ENDIF ! of IF (llm==55.OR.llm==63) ...
+    
+
+    ! Build sigma distribution
+    sig0=EXP(-zz(:)/scaleheight)
+    sig0(llm+1)=0.
+!    sig=ridders(sig0)
+    sig=racinesig(sig0)
+    
+    ! Compute ap() and bp()
+    bp(1)=1.
+    bp(2:llm)=EXP(1.-1./sig(2:llm)**2)
+    bp(llm+1)=0.
+    ap=pa*(sig-bp)
+
+  CASE("strato_custom") 
+!===================================================================
+! David Cugnet, François Lott, Lionel Guez, Ehouoarn Millour, Fredho
+! 2014/05
+! custumize strato distribution
+! Al the parameter are given in km assuming a given scalehigh
+    vert_scale=7.     ! scale hight
+    vert_dzmin=0.02   ! width of first layer
+    vert_dzlow=1.     ! dz in the low atmosphere
+    vert_z0low=8.     ! height at which resolution recches dzlow
+    vert_dzmid=3.     ! dz in the mid atmsophere
+    vert_z0mid=70.    ! height at which resolution recches dzmid
+    vert_h_mid=20.    ! width of the transition
+    vert_dzhig=11.    ! dz in the high atmsophere
+    vert_z0hig=80.    ! height at which resolution recches dz
+    vert_h_hig=20.    ! width of the transition
+!===================================================================
+
+    call getin('vert_scale',vert_scale)
+    call getin('vert_dzmin',vert_dzmin)
+    call getin('vert_dzlow',vert_dzlow)
+    call getin('vert_z0low',vert_z0low)
+    CALL getin('vert_dzmid',vert_dzmid)
+    CALL getin('vert_z0mid',vert_z0mid)
+    call getin('vert_h_mid',vert_h_mid)
+    call getin('vert_dzhig',vert_dzhig)
+    call getin('vert_z0hig',vert_z0hig)
+    call getin('vert_h_hig',vert_h_hig)
+
+    scaleheight=vert_scale ! for consistency with further computations
+    ! Build geometrical distribution
+    zz(1)=0.
+    DO l=1,llm
+       z=zz(l)
+       zz(l+1)=zz(l)+vert_dzmin+vert_dzlow*TANH(z/vert_z0low)+                &
+&      (vert_dzmid-vert_dzlow)* &
+&           (TANH((z-vert_z0mid)/vert_h_mid)-TANH((-vert_z0mid)/vert_h_mid)) &
+&     +(vert_dzhig-vert_dzmid-vert_dzlow)*                                  &
+&           (TANH((z-vert_z0hig)/vert_h_hig)-TANH((-vert_z0hig)/vert_h_hig))
+    ENDDO
+
+
+!===================================================================
+! Comment added Fredho 2014/05/18, Saint-Louis, Senegal
+! From approximate z to ap, bp, so that p=ap+bp*p0 and p/p0=exp(-z/H)
+! sig0 is p/p0
+! sig is an intermediate distribution introduce to estimate bp
+! 1.   sig0=exp(-z/H)
+! 2.   inversion of sig0=(1-pa/p0)*sig+(1-pa/p0)*exp(1-1/sig**2)
+! 3.   bp=exp(1-1/sig**2)
+! 4.   ap deduced from  the combination of 2 and 3 so that sig0=ap/p0+bp
+!===================================================================
+
+    sig0=EXP(-zz(:)/vert_scale)
+    sig0(llm+1)=0.
+    sig=racinesig(sig0)
+    bp(1)=1.
+    bp(2:llm)=EXP(1.-1./sig(2:llm)**2)
+    bp(llm+1)=0.
+    ap=pa*(sig-bp)
+
+  case("read")
+     ! Read "ap" and "bp". First line is skipped (title line). "ap"
+     ! should be in Pa. First couple of values should correspond to
+     ! the surface, that is : "bp" should be in descending order.
+     call new_unit(unit)
+     open(unit, file="hybrid.txt", status="old", action="read", &
+          position="rewind")
+     read(unit, fmt=*) ! skip title line
+     do l = 1, llm + 1
+        read(unit, fmt=*) ap(l), bp(l)
+     end do
+     close(unit)
+     call assert(ap(1) == 0., ap(llm + 1) == 0., bp(1) == 1., &
+          bp(llm + 1) == 0., "disvert: bad ap or bp values")
+  case default
+     call abort_gcm("disvert", 'Wrong value for "vert_sampling"', 1)
+  END select
+
+  DO l=1, llm
+     nivsigs(l) = REAL(l)
+  ENDDO
+
+  DO l=1, llmp1
+     nivsig(l)= REAL(l)
+  ENDDO
+
+  write(lunout, *)  trim(modname),': BP '
+  write(lunout, *) bp
+  write(lunout, *)  trim(modname),': AP '
+  write(lunout, *) ap
+
+  write(lunout, *) 'Niveaux de pressions approximatifs aux centres des'
+  write(lunout, *)'couches calcules pour une pression de surface =', preff
+  write(lunout, *) 'et altitudes equivalentes pour une hauteur d echelle de '
+  write(lunout, *) scaleheight,' km'
+  DO l = 1, llm
+     dpres(l) = bp(l) - bp(l+1)
+     aps(l) =  0.5 *( ap(l) +ap(l+1))
+     bps(l) =  0.5 *( bp(l) +bp(l+1))
+     presnivs(l) = 0.5 *( ap(l)+bp(l)*preff + ap(l+1)+bp(l+1)*preff )
+     pseudoalt(l) = log(preff/presnivs(l))*scaleheight
+     write(lunout, *)'PRESNIVS(', l, ')=', presnivs(l), ' Z ~ ', &
+          pseudoalt(l) &
+          , ' DZ ~ ', scaleheight*log((ap(l)+bp(l)*preff)/ &
+          max(ap(l+1)+bp(l+1)*preff, 1.e-10))
+  ENDDO
+  DO l=1, llmp1
+     presinter(l)= ( ap(l)+bp(l)*preff)
+     write(lunout, *)'PRESINTER(', l, ')=', presinter(l)
+  ENDDO
+
+  write(lunout, *) trim(modname),': PRESNIVS '
+  write(lunout, *) presnivs
+
+CONTAINS
+
+!-------------------------------------------------------------------------------
+!
+FUNCTION ridders(sig) RESULT(sg)
+!
+!-------------------------------------------------------------------------------
+  IMPLICIT NONE
+!-------------------------------------------------------------------------------
+! Purpose: Search for s solving (Pa/Preff)*s+(1-Pa/Preff)*EXP(1-1./s**2)=sg
+! Notes:   Uses Ridders' method, quite robust. Initial bracketing: 0<=sg<=1.
+! Reference: Ridders, C. F. J. "A New Algorithm for Computing a Single Root of a
+!       Real Continuous Function" IEEE Trans. Circuits Systems 26, 979-980, 1979
+!-------------------------------------------------------------------------------
+! Arguments:
+  REAL, INTENT(IN)  :: sig(:)
+  REAL              :: sg(SIZE(sig))
+!-------------------------------------------------------------------------------
+! Local variables:
+  INTEGER :: it, ns, maxit
+  REAL :: c1, c2, x1, x2, x3, x4, f1, f2, f3, f4, s, xx, distrib
+!-------------------------------------------------------------------------------
+  ns=SIZE(sig); maxit=9999
+  c1=Pa/Preff; c2=1.-c1
+  DO l=1,ns
+    xx=HUGE(1.)
+    x1=0.0; f1=distrib(x1,c1,c2,sig(l))
+    x2=1.0; f2=distrib(x2,c1,c2,sig(l))
+    DO it=1,maxit
+      x3=0.5*(x1+x2); f3=distrib(x3,c1,c2,sig(l))
+      s=SQRT(f3**2-f1*f2);                 IF(s==0.) EXIT
+      x4=x3+(x3-x1)*(SIGN(1.,f1-f2)*f3/s); IF(ABS(10.*LOG(x4-xx))<=1E-5) EXIT
+      xx=x4; f4=distrib(x4,c1,c2,sig(l));  IF(f4==0.) EXIT
+      IF(SIGN(f3,f4)/=f3) THEN;      x1=x3; f1=f3; x2=xx; f2=f4
+      ELSE IF(SIGN(f1,f4)/=f1) THEN; x2=xx; f2=f4
+      ELSE IF(SIGN(f2,f4)/=f2) THEN; x1=xx; f1=f4
+      ELSE; CALL abort_gcm("ridders",'Algorithm failed (which is odd...', 1)
+      END IF
+      IF(ABS(10.*LOG(ABS(x2-x1)))<=1E-5) EXIT       !--- ERROR ON SIG <= 0.01m            
+    END DO
+    IF(it==maxit+1) WRITE(lunout,'(a,i3)')'WARNING in ridder: failed to converg&
+     &e for level ',l
+    sg(l)=xx
+  END DO
+  sg(1)=1.; sg(ns)=0.
+
+END FUNCTION ridders
+
+FUNCTION racinesig(sig) RESULT(sg)
+!
+!-------------------------------------------------------------------------------
+  IMPLICIT NONE
+!-------------------------------------------------------------------------------
+! Fredho 2014/05/18
+! Purpose: Search for s solving (Pa/Preff)*sg+(1-Pa/Preff)*EXP(1-1./sg**2)=s
+! Notes:   Uses Newton Raphson search
+!-------------------------------------------------------------------------------
+! Arguments:
+  REAL, INTENT(IN)  :: sig(:)
+  REAL              :: sg(SIZE(sig))
+!-------------------------------------------------------------------------------
+! Local variables:
+  INTEGER :: it, ns, maxit
+  REAL :: c1, c2, x1, x2, x3, x4, f1, f2, f3, f4, s, xx, distrib
+!-------------------------------------------------------------------------------
+  ns=SIZE(sig); maxit=100
+  c1=Pa/Preff; c2=1.-c1
+  DO l=2,ns-1
+    sg(l)=sig(l)
+    DO it=1,maxit
+       f1=exp(1-1./sg(l)**2)*(1.-c1)
+       sg(l)=sg(l)-(c1*sg(l)+f1-sig(l))/(c1+2*f1*sg(l)**(-3))
+    ENDDO
+!   print*,'SSSSIG ',sig(l),sg(l),c1*sg(l)+exp(1-1./sg(l)**2)*(1.-c1)
+  ENDDO
+  sg(1)=1.; sg(ns)=0.
+
+END FUNCTION racinesig
+
+
+
+
+END SUBROUTINE disvert
+
+!-------------------------------------------------------------------------------
+
+FUNCTION distrib(x,c1,c2,x0) RESULT(res)
+!
+!-------------------------------------------------------------------------------
+! Arguments:
+  REAL, INTENT(IN) :: x, c1, c2, x0
+  REAL             :: res
+!-------------------------------------------------------------------------------
+  res=c1*x+c2*EXP(1-1/(x**2))-x0
+
+END FUNCTION distrib
+
+
Index: DZ6/trunk/libf/dyn3d_common/disvert_noterre.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d_common/disvert_noterre.F90	(revision 5267)
+++ 	(revision )
@@ -1,327 +1,0 @@
-! $Id: $
-SUBROUTINE disvert_noterre
-
-  !    Auteur :  F. Forget Y. Wanherdrick, P. Levan
-  !    Nouvelle version 100% Mars !!
-  !    On l'utilise aussi pour Venus et Titan, legerment modifiee.
-
-  use IOIPSL
-
-  USE comvert_mod, ONLY: ap,bp,aps,bps,presnivs,pseudoalt, &
-        nivsig,nivsigs,pa,preff,scaleheight
-  USE comconst_mod, ONLY: kappa
-  USE logic_mod, ONLY: hybrid
-
-  IMPLICIT NONE
-
-  include "dimensions.h"
-  include "paramet.h"
-  include "iniprint.h"
-  !
-  !=======================================================================
-  !    Discretisation verticale en coordonn�e hybride (ou sigma)
-  !
-  !=======================================================================
-  !
-  !   declarations:
-  !   -------------
-  !
-  !
-  INTEGER :: l,ll
-  REAL :: snorm
-  REAL :: alpha,beta,gama,delta,deltaz
-  real :: quoi,quand
-  REAL :: zsig(llm),sig(llm+1)
-  INTEGER :: np,ierr
-  integer :: ierr1,ierr2,ierr3,ierr4
-  REAL :: x
-
-  REAL :: SSUM
-  EXTERNAL SSUM
-  real :: newsig
-  REAL :: dz0,dz1,nhaut,sig1,esig,csig,zz
-  real :: tt,rr,gg, prevz
-  real :: s(llm),dsig(llm)
-
-  integer :: iz
-  real :: z, ps,p
-  character(len=*),parameter :: modname="disvert_noterre"
-
-  !
-  !-----------------------------------------------------------------------
-  !
-  ! Initializations:
-  !  pi=2.*ASIN(1.) ! already done in iniconst
-
-  hybrid=.true. ! default value for hybrid (ie: use hybrid coordinates)
-  CALL getin('hybrid',hybrid)
-  write(lunout,*) trim(modname),': hybrid=',hybrid
-
-  ! Ouverture possible de fichiers typiquement E.T.
-
-     open(99,file="esasig.def",status='old',form='formatted', &
-           iostat=ierr2)
-     if(ierr2.ne.0) then
-          close(99)
-          open(99,file="z2sig.def",status='old',form='formatted', &
-                iostat=ierr4)
-     endif
-
-  !-----------------------------------------------------------------------
-  !   cas 1 on lit les options dans esasig.def:
-  !   ----------------------------------------
-
-  IF(ierr2.eq.0) then
-
-     ! Lecture de esasig.def :
-     ! Systeme peu souple, mais qui respecte en theorie
-     ! La conservation de l'energie (conversion Energie potentielle
-     ! <-> energie cinetique, d'apres la note de Frederic Hourdin...
-
-     write(lunout,*)'*****************************'
-     write(lunout,*)'WARNING reading esasig.def'
-     write(lunout,*)'*****************************'
-     READ(99,*) scaleheight
-     READ(99,*) dz0
-     READ(99,*) dz1
-     READ(99,*) nhaut
-     CLOSE(99)
-
-     dz0=dz0/scaleheight
-     dz1=dz1/scaleheight
-
-     sig1=(1.-dz1)/tanh(.5*(llm-1)/nhaut)
-
-     esig=1.
-
-     do l=1,20
-        esig=-log((1./sig1-1.)*exp(-dz0)/esig)/(llm-1.)
-     enddo
-     csig=(1./sig1-1.)/(exp(esig)-1.)
-
-     DO L = 2, llm
-        zz=csig*(exp(esig*(l-1.))-1.)
-        sig(l) =1./(1.+zz) &
-              * tanh(.5*(llm+1-l)/nhaut)
-     ENDDO
-     sig(1)=1.
-     sig(llm+1)=0.
-     quoi      = 1. + 2.* kappa
-     s( llm )  = 1.
-     s(llm-1) = quoi
-     IF( llm.gt.2 )  THEN
-        DO  ll = 2, llm-1
-           l         = llm+1 - ll
-           quand     = sig(l+1)/ sig(l)
-           s(l-1)    = quoi * (1.-quand) * s(l)  + quand * s(l+1)
-        ENDDO
-     END IF
-  !
-     snorm=(1.-.5*sig(2)+kappa*(1.-sig(2)))*s(1)+.5*sig(2)*s(2)
-     DO l = 1, llm
-        s(l)    = s(l)/ snorm
-     ENDDO
-
-  !-----------------------------------------------------------------------
-  !   cas 2 on lit les options dans z2sig.def:
-  !   ----------------------------------------
-
-  ELSE IF(ierr4.eq.0) then
-     write(lunout,*)'****************************'
-     write(lunout,*)'Reading z2sig.def'
-     write(lunout,*)'****************************'
-
-     READ(99,*) scaleheight
-     do l=1,llm
-        read(99,*) zsig(l)
-     end do
-     CLOSE(99)
-
-     sig(1) =1
-     do l=2,llm
-       sig(l) = 0.5 * ( exp(-zsig(l)/scaleheight) + &
-             exp(-zsig(l-1)/scaleheight) )
-     end do
-     sig(llm+1) =0
-
-  !-----------------------------------------------------------------------
-  ELSE
-     write(lunout,*) 'didn t you forget something ??? '
-     write(lunout,*) 'We need file  z2sig.def ! (OR esasig.def)'
-     stop
-  ENDIF
-  !-----------------------------------------------------------------------
-
-  DO l=1,llm
-    nivsigs(l) = REAL(l)
-  ENDDO
-
-  DO l=1,llmp1
-    nivsig(l)= REAL(l)
-  ENDDO
-
-
-  !-----------------------------------------------------------------------
-  !    ....  Calculs  de ap(l) et de bp(l)  ....
-  !    .........................................
-  !
-  !   .....  pa et preff sont lus  sur les fichiers start par dynetat0 .....
-  !-----------------------------------------------------------------------
-  !
-
-  if (hybrid) then  ! use hybrid coordinates
-     write(lunout,*) "*********************************"
-     write(lunout,*) "Using hybrid vertical coordinates"
-     write(lunout,*)
-     ! Coordonnees hybrides avec mod
-     DO l = 1, llm
-
-     call sig_hybrid(sig(l),pa,preff,newsig)
-        bp(l) = EXP( 1. - 1./(newsig**2)  )
-        ap(l) = pa * (newsig - bp(l) )
-     enddo
-     bp(llmp1) = 0.
-     ap(llmp1) = 0.
-  else ! use sigma coordinates
-     write(lunout,*) "********************************"
-     write(lunout,*) "Using sigma vertical coordinates"
-     write(lunout,*)
-     ! Pour ne pas passer en coordonnees hybrides
-     DO l = 1, llm
-        ap(l) = 0.
-        bp(l) = sig(l)
-     ENDDO
-     ap(llmp1) = 0.
-  endif
-
-  bp(llmp1) =   0.
-
-  write(lunout,*) trim(modname),': BP '
-  write(lunout,*)  bp
-  write(lunout,*) trim(modname),': AP '
-  write(lunout,*)  ap
-
-  ! Calcul au milieu des couches :
-  ! WARNING : le choix de placer le milieu des couches au niveau de
-  ! pression interm�diaire est arbitraire et pourrait etre modifi�.
-  ! Le calcul du niveau pour la derniere couche
-  ! (on met la meme distance (en log pression)  entre P(llm)
-  ! et P(llm -1) qu'entre P(llm-1) et P(llm-2) ) est
-  ! Specifique.  Ce choix est sp�cifi� ici ET dans exner_milieu.F
-
-  DO l = 1, llm-1
-   aps(l) =  0.5 *( ap(l) +ap(l+1))
-   bps(l) =  0.5 *( bp(l) +bp(l+1))
-  ENDDO
-
-  if (hybrid) then
-     aps(llm) = aps(llm-1)**2 / aps(llm-2)
-     bps(llm) = 0.5*(bp(llm) + bp(llm+1))
-  else
-     bps(llm) = bps(llm-1)**2 / bps(llm-2)
-     aps(llm) = 0.
-  end if
-
-  write(lunout,*) trim(modname),': BPs '
-  write(lunout,*)  bps
-  write(lunout,*) trim(modname),': APs'
-  write(lunout,*)  aps
-
-  DO l = 1, llm
-   presnivs(l) = aps(l)+bps(l)*preff
-   pseudoalt(l) = -scaleheight*log(presnivs(l)/preff)
-  ENDDO
-
-  write(lunout,*)trim(modname),' : PRESNIVS'
-  write(lunout,*)presnivs
-  write(lunout,*)'Pseudo altitude of Presnivs : (for a scale ', &
-        'height of ',scaleheight,' km)'
-  write(lunout,*)pseudoalt
-
-  ! --------------------------------------------------
-  ! This can be used to plot the vertical discretization
-  ! (> xmgrace -nxy testhybrid.tab )
-  ! --------------------------------------------------
-  ! open (53,file='testhybrid.tab')
-  ! scaleheight=15.5
-  ! do iz=0,34
-  !   z = -5 + min(iz,34-iz)
-  ! approximation of scale height for Venus
-  !   scaleheight = 15.5 - z/55.*10.
-  !   ps = preff*exp(-z/scaleheight)
-  !   zsig(1)= -scaleheight*log((aps(1) + bps(1)*ps)/preff)
-  !   do l=2,llm
-  ! approximation of scale height for Venus
-  !      if (zsig(l-1).le.55.) then
-  !         scaleheight = 15.5 - zsig(l-1)/55.*10.
-  !      else
-  !         scaleheight = 5.5 - (zsig(l-1)-55.)/35.*2.
-  !      endif
-  !      zsig(l)= zsig(l-1)-scaleheight*
-  !    .    log((aps(l) + bps(l)*ps)/(aps(l-1) + bps(l-1)*ps))
-  !   end do
-  !   write(53,'(I3,50F10.5)') iz, zsig
-  !  end do
-  !  close(53)
-  ! --------------------------------------------------
-
-
-  RETURN
-END SUBROUTINE disvert_noterre
-
-! ************************************************************
-subroutine sig_hybrid(sig,pa,preff,newsig)
-  ! ----------------------------------------------
-  ! Subroutine utilisee pour calculer des valeurs de sigma modifie
-  ! pour conserver les coordonnees verticales decrites dans
-  ! esasig.def/z2sig.def lors du passage en coordonnees hybrides
-  ! F. Forget 2002
-  ! Connaissant sig (niveaux "sigma" ou on veut mettre les couches)
-  ! L'objectif est de calculer newsig telle que
-  !   (1 -pa/preff)*exp(1-1./newsig**2)+(pa/preff)*newsig = sig
-  ! Cela ne se r�soud pas analytiquement:
-  ! => on r�soud par iterration bourrine
-  ! ----------------------------------------------
-  ! Information  : where exp(1-1./x**2) become << x
-  !       x      exp(1-1./x**2) /x
-  !       1           1
-  !       0.68       0.5
-  !       0.5        1.E-1
-  !       0.391      1.E-2
-  !       0.333      1.E-3
-  !       0.295      1.E-4
-  !       0.269      1.E-5
-  !       0.248      1.E-6
-  !    => on peut utiliser newsig = sig*preff/pa si sig*preff/pa < 0.25
-
-
-  implicit none
-  real :: x1, x2, sig,pa,preff, newsig, F
-  integer :: j
-
-  newsig = sig
-  x1=0
-  x2=1
-  if (sig.ge.1) then
-        newsig= sig
-  else if (sig*preff/pa.ge.0.25) then
-    DO J=1,9999  ! nombre d''iteration max
-      F=((1 -pa/preff)*exp(1-1./newsig**2)+(pa/preff)*newsig)/sig
-      ! write(0,*) J, ' newsig =', newsig, ' F= ', F
-      if (F.gt.1) then
-          X2 = newsig
-          newsig=(X1+newsig)*0.5
-      else
-          X1 = newsig
-          newsig=(X2+newsig)*0.5
-      end if
-      ! Test : on arete lorsque on approxime sig � moins de 0.01 m pr�s
-      ! (en pseudo altitude) :
-      IF(abs(10.*log(F)).LT.1.E-5) goto 999
-    END DO
-   else   !    if (sig*preff/pa.le.0.25) then
-         newsig= sig*preff/pa
-   end if
- 999   continue
-   Return
-END SUBROUTINE sig_hybrid
Index: /LMDZ6/trunk/libf/dyn3d_common/disvert_noterre.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d_common/disvert_noterre.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3d_common/disvert_noterre.f90	(revision 5268)
@@ -0,0 +1,327 @@
+! $Id: $
+SUBROUTINE disvert_noterre
+
+  !    Auteur :  F. Forget Y. Wanherdrick, P. Levan
+  !    Nouvelle version 100% Mars !!
+  !    On l'utilise aussi pour Venus et Titan, legerment modifiee.
+
+  use IOIPSL
+
+  USE comvert_mod, ONLY: ap,bp,aps,bps,presnivs,pseudoalt, &
+        nivsig,nivsigs,pa,preff,scaleheight
+  USE comconst_mod, ONLY: kappa
+  USE logic_mod, ONLY: hybrid
+
+  IMPLICIT NONE
+
+  include "dimensions.h"
+  include "paramet.h"
+  include "iniprint.h"
+  !
+  !=======================================================================
+  !    Discretisation verticale en coordonn�e hybride (ou sigma)
+  !
+  !=======================================================================
+  !
+  !   declarations:
+  !   -------------
+  !
+  !
+  INTEGER :: l,ll
+  REAL :: snorm
+  REAL :: alpha,beta,gama,delta,deltaz
+  real :: quoi,quand
+  REAL :: zsig(llm),sig(llm+1)
+  INTEGER :: np,ierr
+  integer :: ierr1,ierr2,ierr3,ierr4
+  REAL :: x
+
+  REAL :: SSUM
+  EXTERNAL SSUM
+  real :: newsig
+  REAL :: dz0,dz1,nhaut,sig1,esig,csig,zz
+  real :: tt,rr,gg, prevz
+  real :: s(llm),dsig(llm)
+
+  integer :: iz
+  real :: z, ps,p
+  character(len=*),parameter :: modname="disvert_noterre"
+
+  !
+  !-----------------------------------------------------------------------
+  !
+  ! Initializations:
+  !  pi=2.*ASIN(1.) ! already done in iniconst
+
+  hybrid=.true. ! default value for hybrid (ie: use hybrid coordinates)
+  CALL getin('hybrid',hybrid)
+  write(lunout,*) trim(modname),': hybrid=',hybrid
+
+  ! Ouverture possible de fichiers typiquement E.T.
+
+     open(99,file="esasig.def",status='old',form='formatted', &
+           iostat=ierr2)
+     if(ierr2.ne.0) then
+          close(99)
+          open(99,file="z2sig.def",status='old',form='formatted', &
+                iostat=ierr4)
+     endif
+
+  !-----------------------------------------------------------------------
+  !   cas 1 on lit les options dans esasig.def:
+  !   ----------------------------------------
+
+  IF(ierr2.eq.0) then
+
+     ! Lecture de esasig.def :
+     ! Systeme peu souple, mais qui respecte en theorie
+     ! La conservation de l'energie (conversion Energie potentielle
+     ! <-> energie cinetique, d'apres la note de Frederic Hourdin...
+
+     write(lunout,*)'*****************************'
+     write(lunout,*)'WARNING reading esasig.def'
+     write(lunout,*)'*****************************'
+     READ(99,*) scaleheight
+     READ(99,*) dz0
+     READ(99,*) dz1
+     READ(99,*) nhaut
+     CLOSE(99)
+
+     dz0=dz0/scaleheight
+     dz1=dz1/scaleheight
+
+     sig1=(1.-dz1)/tanh(.5*(llm-1)/nhaut)
+
+     esig=1.
+
+     do l=1,20
+        esig=-log((1./sig1-1.)*exp(-dz0)/esig)/(llm-1.)
+     enddo
+     csig=(1./sig1-1.)/(exp(esig)-1.)
+
+     DO L = 2, llm
+        zz=csig*(exp(esig*(l-1.))-1.)
+        sig(l) =1./(1.+zz) &
+              * tanh(.5*(llm+1-l)/nhaut)
+     ENDDO
+     sig(1)=1.
+     sig(llm+1)=0.
+     quoi      = 1. + 2.* kappa
+     s( llm )  = 1.
+     s(llm-1) = quoi
+     IF( llm.gt.2 )  THEN
+        DO  ll = 2, llm-1
+           l         = llm+1 - ll
+           quand     = sig(l+1)/ sig(l)
+           s(l-1)    = quoi * (1.-quand) * s(l)  + quand * s(l+1)
+        ENDDO
+     END IF
+  !
+     snorm=(1.-.5*sig(2)+kappa*(1.-sig(2)))*s(1)+.5*sig(2)*s(2)
+     DO l = 1, llm
+        s(l)    = s(l)/ snorm
+     ENDDO
+
+  !-----------------------------------------------------------------------
+  !   cas 2 on lit les options dans z2sig.def:
+  !   ----------------------------------------
+
+  ELSE IF(ierr4.eq.0) then
+     write(lunout,*)'****************************'
+     write(lunout,*)'Reading z2sig.def'
+     write(lunout,*)'****************************'
+
+     READ(99,*) scaleheight
+     do l=1,llm
+        read(99,*) zsig(l)
+     end do
+     CLOSE(99)
+
+     sig(1) =1
+     do l=2,llm
+       sig(l) = 0.5 * ( exp(-zsig(l)/scaleheight) + &
+             exp(-zsig(l-1)/scaleheight) )
+     end do
+     sig(llm+1) =0
+
+  !-----------------------------------------------------------------------
+  ELSE
+     write(lunout,*) 'didn t you forget something ??? '
+     write(lunout,*) 'We need file  z2sig.def ! (OR esasig.def)'
+     stop
+  ENDIF
+  !-----------------------------------------------------------------------
+
+  DO l=1,llm
+    nivsigs(l) = REAL(l)
+  ENDDO
+
+  DO l=1,llmp1
+    nivsig(l)= REAL(l)
+  ENDDO
+
+
+  !-----------------------------------------------------------------------
+  !    ....  Calculs  de ap(l) et de bp(l)  ....
+  !    .........................................
+  !
+  !   .....  pa et preff sont lus  sur les fichiers start par dynetat0 .....
+  !-----------------------------------------------------------------------
+  !
+
+  if (hybrid) then  ! use hybrid coordinates
+     write(lunout,*) "*********************************"
+     write(lunout,*) "Using hybrid vertical coordinates"
+     write(lunout,*)
+     ! Coordonnees hybrides avec mod
+     DO l = 1, llm
+
+     call sig_hybrid(sig(l),pa,preff,newsig)
+        bp(l) = EXP( 1. - 1./(newsig**2)  )
+        ap(l) = pa * (newsig - bp(l) )
+     enddo
+     bp(llmp1) = 0.
+     ap(llmp1) = 0.
+  else ! use sigma coordinates
+     write(lunout,*) "********************************"
+     write(lunout,*) "Using sigma vertical coordinates"
+     write(lunout,*)
+     ! Pour ne pas passer en coordonnees hybrides
+     DO l = 1, llm
+        ap(l) = 0.
+        bp(l) = sig(l)
+     ENDDO
+     ap(llmp1) = 0.
+  endif
+
+  bp(llmp1) =   0.
+
+  write(lunout,*) trim(modname),': BP '
+  write(lunout,*)  bp
+  write(lunout,*) trim(modname),': AP '
+  write(lunout,*)  ap
+
+  ! Calcul au milieu des couches :
+  ! WARNING : le choix de placer le milieu des couches au niveau de
+  ! pression interm�diaire est arbitraire et pourrait etre modifi�.
+  ! Le calcul du niveau pour la derniere couche
+  ! (on met la meme distance (en log pression)  entre P(llm)
+  ! et P(llm -1) qu'entre P(llm-1) et P(llm-2) ) est
+  ! Specifique.  Ce choix est sp�cifi� ici ET dans exner_milieu.F
+
+  DO l = 1, llm-1
+   aps(l) =  0.5 *( ap(l) +ap(l+1))
+   bps(l) =  0.5 *( bp(l) +bp(l+1))
+  ENDDO
+
+  if (hybrid) then
+     aps(llm) = aps(llm-1)**2 / aps(llm-2)
+     bps(llm) = 0.5*(bp(llm) + bp(llm+1))
+  else
+     bps(llm) = bps(llm-1)**2 / bps(llm-2)
+     aps(llm) = 0.
+  end if
+
+  write(lunout,*) trim(modname),': BPs '
+  write(lunout,*)  bps
+  write(lunout,*) trim(modname),': APs'
+  write(lunout,*)  aps
+
+  DO l = 1, llm
+   presnivs(l) = aps(l)+bps(l)*preff
+   pseudoalt(l) = -scaleheight*log(presnivs(l)/preff)
+  ENDDO
+
+  write(lunout,*)trim(modname),' : PRESNIVS'
+  write(lunout,*)presnivs
+  write(lunout,*)'Pseudo altitude of Presnivs : (for a scale ', &
+        'height of ',scaleheight,' km)'
+  write(lunout,*)pseudoalt
+
+  ! --------------------------------------------------
+  ! This can be used to plot the vertical discretization
+  ! (> xmgrace -nxy testhybrid.tab )
+  ! --------------------------------------------------
+  ! open (53,file='testhybrid.tab')
+  ! scaleheight=15.5
+  ! do iz=0,34
+  !   z = -5 + min(iz,34-iz)
+  ! approximation of scale height for Venus
+  !   scaleheight = 15.5 - z/55.*10.
+  !   ps = preff*exp(-z/scaleheight)
+  !   zsig(1)= -scaleheight*log((aps(1) + bps(1)*ps)/preff)
+  !   do l=2,llm
+  ! approximation of scale height for Venus
+  !      if (zsig(l-1).le.55.) then
+  !         scaleheight = 15.5 - zsig(l-1)/55.*10.
+  !      else
+  !         scaleheight = 5.5 - (zsig(l-1)-55.)/35.*2.
+  !      endif
+  !      zsig(l)= zsig(l-1)-scaleheight*
+  !    .    log((aps(l) + bps(l)*ps)/(aps(l-1) + bps(l-1)*ps))
+  !   end do
+  !   write(53,'(I3,50F10.5)') iz, zsig
+  !  end do
+  !  close(53)
+  ! --------------------------------------------------
+
+
+  RETURN
+END SUBROUTINE disvert_noterre
+
+! ************************************************************
+subroutine sig_hybrid(sig,pa,preff,newsig)
+  ! ----------------------------------------------
+  ! Subroutine utilisee pour calculer des valeurs de sigma modifie
+  ! pour conserver les coordonnees verticales decrites dans
+  ! esasig.def/z2sig.def lors du passage en coordonnees hybrides
+  ! F. Forget 2002
+  ! Connaissant sig (niveaux "sigma" ou on veut mettre les couches)
+  ! L'objectif est de calculer newsig telle que
+  !   (1 -pa/preff)*exp(1-1./newsig**2)+(pa/preff)*newsig = sig
+  ! Cela ne se r�soud pas analytiquement:
+  ! => on r�soud par iterration bourrine
+  ! ----------------------------------------------
+  ! Information  : where exp(1-1./x**2) become << x
+  !       x      exp(1-1./x**2) /x
+  !       1           1
+  !       0.68       0.5
+  !       0.5        1.E-1
+  !       0.391      1.E-2
+  !       0.333      1.E-3
+  !       0.295      1.E-4
+  !       0.269      1.E-5
+  !       0.248      1.E-6
+  !    => on peut utiliser newsig = sig*preff/pa si sig*preff/pa < 0.25
+
+
+  implicit none
+  real :: x1, x2, sig,pa,preff, newsig, F
+  integer :: j
+
+  newsig = sig
+  x1=0
+  x2=1
+  if (sig.ge.1) then
+        newsig= sig
+  else if (sig*preff/pa.ge.0.25) then
+    DO J=1,9999  ! nombre d''iteration max
+      F=((1 -pa/preff)*exp(1-1./newsig**2)+(pa/preff)*newsig)/sig
+      ! write(0,*) J, ' newsig =', newsig, ' F= ', F
+      if (F.gt.1) then
+          X2 = newsig
+          newsig=(X1+newsig)*0.5
+      else
+          X1 = newsig
+          newsig=(X2+newsig)*0.5
+      end if
+      ! Test : on arete lorsque on approxime sig � moins de 0.01 m pr�s
+      ! (en pseudo altitude) :
+      IF(abs(10.*log(F)).LT.1.E-5) goto 999
+    END DO
+   else   !    if (sig*preff/pa.le.0.25) then
+         newsig= sig*preff/pa
+   end if
+ 999   continue
+   Return
+END SUBROUTINE sig_hybrid
Index: DZ6/trunk/libf/dyn3d_common/ener_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d_common/ener_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,15 +1,0 @@
-!
-! $Id$
-!
-MODULE ener_mod
-
-IMPLICIT NONE  
-
-include "dimensions.h"
-include "paramet.h"
-
-      REAL ang0,etot0,ptot0,ztot0,stot0,			&
-		ang,etot,ptot,ztot,stot,rmsdpdt,rmsv,gtot(llmm1)
-
-
-END MODULE ener_mod
Index: /LMDZ6/trunk/libf/dyn3d_common/ener_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d_common/ener_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3d_common/ener_mod.f90	(revision 5268)
@@ -0,0 +1,15 @@
+!
+! $Id$
+!
+MODULE ener_mod
+
+IMPLICIT NONE  
+
+include "dimensions.h"
+include "paramet.h"
+
+      REAL ang0,etot0,ptot0,ztot0,stot0,			&
+		ang,etot,ptot,ztot,stot,rmsdpdt,rmsv,gtot(llmm1)
+
+
+END MODULE ener_mod
Index: DZ6/trunk/libf/dyn3d_common/enercin.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d_common/enercin.F90	(revision 5267)
+++ 	(revision )
@@ -1,71 +1,0 @@
-SUBROUTINE enercin ( vcov, ucov, vcont, ucont, ecin )
-!
-!-------------------------------------------------------------------------------
-! Authors: P. Le Van.
-!-------------------------------------------------------------------------------
-! Purpose: Compute kinetic energy at sigma levels.
-  IMPLICIT NONE
-  include "dimensions.h"
-  include "paramet.h"
-  include "comgeom.h"
-!===============================================================================
-! Arguments:
-  REAL, INTENT(IN)  :: vcov    (ip1jm,  llm)
-  REAL, INTENT(IN)  :: ucov    (ip1jmp1,llm)
-  REAL, INTENT(IN)  :: vcont   (ip1jm,  llm)
-  REAL, INTENT(IN)  :: ucont   (ip1jmp1,llm)
-  REAL, INTENT(OUT) :: ecin    (ip1jmp1,llm)
-!===============================================================================
-! Notes:
-!                 . V
-!                i,j-1
-!
-!      alpha4 .       . alpha1
-!
-!
-!        U .      . P     . U
-!       i-1,j    i,j      i,j
-!
-!      alpha3 .       . alpha2
-!
-!
-!                 . V
-!                i,j
-!
-! Kinetic energy at scalar point P(i,j) (excluding poles) is:
-!       Ecin = 0.5 * U(i-1,j)**2 *( alpha3 + alpha4 )  +
-!              0.5 * U(i  ,j)**2 *( alpha1 + alpha2 )  +
-!              0.5 * V(i,j-1)**2 *( alpha1 + alpha4 )  +
-!              0.5 * V(i,  j)**2 *( alpha2 + alpha3 )
-!===============================================================================
-! Local variables:
-  INTEGER :: l, ij, i
-  REAL    :: ecinni(iip1), ecinsi(iip1), ecinpn, ecinps
-!===============================================================================
-  DO l=1,llm
-    DO ij = iip2, ip1jm -1
-      ecin(ij+1,l)=0.5*(ucov(ij    ,l)*ucont(ij    ,l)*alpha3p4(ij +1)          &
-                      + ucov(ij+1  ,l)*ucont(ij+1  ,l)*alpha1p2(ij +1)          &
-                      + vcov(ij-iim,l)*vcont(ij-iim,l)*alpha1p4(ij +1)          &
-                      + vcov(ij+1  ,l)*vcont(ij+1  ,l)*alpha2p3(ij +1) )
-    END DO
-    !--- Correction: ecin(1,j,l)= ecin(iip1,j,l)
-    DO ij=iip2,ip1jm,iip1; ecin(ij,l) = ecin(ij+iim,l); END DO
-
-    !--- North pole
-    DO i=1,iim
-      ecinni(i) = vcov(i,l)*vcont(i,l)*aire(i)
-    END DO
-    ecinpn = 0.5*SUM(ecinni(1:iim))/apoln
-    DO ij=1,iip1; ecin(ij,l)=ecinpn; END DO
-
-    !--- South pole
-    DO i=1,iim
-      ecinsi(i) = vcov(i+ip1jmi1,l)*vcont(i+ip1jmi1,l)*aire(i+ip1jm)
-    END DO
-    ecinps = 0.5*SUM(ecinsi(1:iim))/apols
-    DO ij=1,iip1; ecin(ij+ip1jm,l)=ecinps; END DO
-  END DO
-
-END SUBROUTINE enercin
-
Index: /LMDZ6/trunk/libf/dyn3d_common/enercin.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d_common/enercin.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3d_common/enercin.f90	(revision 5268)
@@ -0,0 +1,71 @@
+SUBROUTINE enercin ( vcov, ucov, vcont, ucont, ecin )
+!
+!-------------------------------------------------------------------------------
+! Authors: P. Le Van.
+!-------------------------------------------------------------------------------
+! Purpose: Compute kinetic energy at sigma levels.
+  IMPLICIT NONE
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom.h"
+!===============================================================================
+! Arguments:
+  REAL, INTENT(IN)  :: vcov    (ip1jm,  llm)
+  REAL, INTENT(IN)  :: ucov    (ip1jmp1,llm)
+  REAL, INTENT(IN)  :: vcont   (ip1jm,  llm)
+  REAL, INTENT(IN)  :: ucont   (ip1jmp1,llm)
+  REAL, INTENT(OUT) :: ecin    (ip1jmp1,llm)
+!===============================================================================
+! Notes:
+!                 . V
+!                i,j-1
+!
+!      alpha4 .       . alpha1
+!
+!
+!        U .      . P     . U
+!       i-1,j    i,j      i,j
+!
+!      alpha3 .       . alpha2
+!
+!
+!                 . V
+!                i,j
+!
+! Kinetic energy at scalar point P(i,j) (excluding poles) is:
+!       Ecin = 0.5 * U(i-1,j)**2 *( alpha3 + alpha4 )  +
+!              0.5 * U(i  ,j)**2 *( alpha1 + alpha2 )  +
+!              0.5 * V(i,j-1)**2 *( alpha1 + alpha4 )  +
+!              0.5 * V(i,  j)**2 *( alpha2 + alpha3 )
+!===============================================================================
+! Local variables:
+  INTEGER :: l, ij, i
+  REAL    :: ecinni(iip1), ecinsi(iip1), ecinpn, ecinps
+!===============================================================================
+  DO l=1,llm
+    DO ij = iip2, ip1jm -1
+      ecin(ij+1,l)=0.5*(ucov(ij    ,l)*ucont(ij    ,l)*alpha3p4(ij +1)          &
+                      + ucov(ij+1  ,l)*ucont(ij+1  ,l)*alpha1p2(ij +1)          &
+                      + vcov(ij-iim,l)*vcont(ij-iim,l)*alpha1p4(ij +1)          &
+                      + vcov(ij+1  ,l)*vcont(ij+1  ,l)*alpha2p3(ij +1) )
+    END DO
+    !--- Correction: ecin(1,j,l)= ecin(iip1,j,l)
+    DO ij=iip2,ip1jm,iip1; ecin(ij,l) = ecin(ij+iim,l); END DO
+
+    !--- North pole
+    DO i=1,iim
+      ecinni(i) = vcov(i,l)*vcont(i,l)*aire(i)
+    END DO
+    ecinpn = 0.5*SUM(ecinni(1:iim))/apoln
+    DO ij=1,iip1; ecin(ij,l)=ecinpn; END DO
+
+    !--- South pole
+    DO i=1,iim
+      ecinsi(i) = vcov(i+ip1jmi1,l)*vcont(i+ip1jmi1,l)*aire(i+ip1jm)
+    END DO
+    ecinps = 0.5*SUM(ecinsi(1:iim))/apols
+    DO ij=1,iip1; ecin(ij+ip1jm,l)=ecinps; END DO
+  END DO
+
+END SUBROUTINE enercin
+
Index: DZ6/trunk/libf/dyn3d_common/exner_hyb_m.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d_common/exner_hyb_m.F90	(revision 5267)
+++ 	(revision )
@@ -1,147 +1,0 @@
-module exner_hyb_m
-
-  IMPLICIT NONE
-
-contains
-
-  SUBROUTINE  exner_hyb ( ngrid, ps, p, pks, pk, pkf )
-
-    !     Auteurs :  P.Le Van  , Fr. Hourdin  .
-    !    ..........
-    !
-    !    ....  ngrid, ps,p             sont des argum.d'entree  au sous-prog ...
-    !    ....  pks,pk,pkf   sont des argum.de sortie au sous-prog ...
-    !
-    !   ************************************************************************
-    !    Calcule la fonction d'Exner pk = Cp * (p/preff) ** kappa , aux milieux des 
-    !    couches .   Pk(l) sera calcule aux milieux  des couches l ,entre les
-    !    pressions p(l) et p(l+1) ,definis aux interfaces des llm couches .
-    !   ************************************************************************
-    !  .. N.B : Au sommet de l'atmosphere,  p(llm+1) = 0. , et ps et pks sont
-    !    la pression et la fonction d'Exner  au  sol  .
-    !
-    !                                 -------- z
-    !    A partir des relations  ( 1 ) p*dz(pk) = kappa *pk*dz(p)      et
-    !                            ( 2 ) pk(l) = alpha(l)+ beta(l)*pk(l-1)
-    !    ( voir note de Fr.Hourdin )  ,
-    !
-    !    on determine successivement , du haut vers le bas des couches, les 
-    !    coef. alpha(llm),beta(llm) .,.,alpha(l),beta(l),,,alpha(2),beta(2), 
-    !    puis pk(ij,1). Ensuite ,on calcule,du bas vers le haut des couches,  
-    !     pk(ij,l)  donne  par la relation (2),  pour l = 2 a l = llm .
-    !
-    !
-    !
-    USE comconst_mod, ONLY: jmp1, cpp, kappa, r
-    USE comvert_mod, ONLY: preff
-    
-    IMPLICIT NONE
-    
-    include "dimensions.h"
-    include "paramet.h"
-    include "comgeom.h"
-
-    INTEGER  ngrid
-    REAL p(ngrid,llmp1),pk(ngrid,llm)
-    real, optional:: pkf(ngrid,llm)
-    REAL ps(ngrid),pks(ngrid), alpha(ngrid,llm),beta(ngrid,llm)
-
-    !    .... variables locales   ...
-
-    INTEGER l, ij
-    REAL unpl2k,dellta
-
-    logical,save :: firstcall=.true.
-    character(len=*),parameter :: modname="exner_hyb"
-
-    ! Sanity check
-    if (firstcall) then
-       ! sanity checks for Shallow Water case (1 vertical layer)
-       if (llm.eq.1) then
-          if (kappa.ne.1) then
-             call abort_gcm(modname, &
-                  "kappa!=1 , but running in Shallow Water mode!!",42)
-          endif
-          if (cpp.ne.r) then
-             call abort_gcm(modname, &
-                  "cpp!=r , but running in Shallow Water mode!!",42)
-          endif
-       endif ! of if (llm.eq.1)
-
-       firstcall=.false.
-    endif ! of if (firstcall)
-
-    ! Specific behaviour for Shallow Water (1 vertical layer) case:
-    if (llm.eq.1) then
-
-       ! Compute pks(:),pk(:),pkf(:)
-
-       DO   ij  = 1, ngrid
-          pks(ij) = (cpp/preff) * ps(ij)
-          pk(ij,1) = .5*pks(ij)
-       ENDDO
-
-       if (present(pkf)) then
-          pkf = pk
-          CALL filtreg ( pkf, jmp1, llm, 2, 1, .TRUE., 1 ) 
-       end if
-
-       ! our work is done, exit routine
-       return
-    endif ! of if (llm.eq.1)
-
-    ! General case:
-
-    unpl2k    = 1.+ 2.* kappa
-
-    !     -------------
-    !     Calcul de pks
-    !     -------------
-
-    DO   ij  = 1, ngrid
-       pks(ij) = cpp * ( ps(ij)/preff ) ** kappa
-    ENDDO
-
-    !    .... Calcul des coeff. alpha et beta  pour la couche l = llm ..
-    !
-    DO     ij      = 1, ngrid
-       alpha(ij,llm) = 0.
-       beta (ij,llm) = 1./ unpl2k
-    ENDDO
-    !
-    !     ... Calcul des coeff. alpha et beta  pour l = llm-1  a l = 2 ...
-    !
-    DO l = llm -1 , 2 , -1
-       !
-       DO ij = 1, ngrid
-          dellta = p(ij,l)* unpl2k + p(ij,l+1)* ( beta(ij,l+1)-unpl2k )
-          alpha(ij,l)  = - p(ij,l+1) / dellta * alpha(ij,l+1)
-          beta (ij,l)  =   p(ij,l  ) / dellta   
-       ENDDO
-    ENDDO
-
-    !  ***********************************************************************
-    !     .....  Calcul de pk pour la couche 1 , pres du sol  ....
-    !
-    DO   ij   = 1, ngrid
-       pk(ij,1) = ( p(ij,1)*pks(ij) - 0.5*alpha(ij,2)*p(ij,2) )  / &
-            (  p(ij,1)* (1.+kappa) + 0.5*( beta(ij,2)-unpl2k )* p(ij,2) )
-    ENDDO
-    !
-    !    ..... Calcul de pk(ij,l) , pour l = 2 a l = llm  ........
-    !
-    DO l = 2, llm
-       DO   ij   = 1, ngrid
-          pk(ij,l) = alpha(ij,l) + beta(ij,l) * pk(ij,l-1)
-       ENDDO
-    ENDDO
-
-    if (present(pkf)) then
-       !    calcul de pkf
-       pkf = pk
-       CALL filtreg ( pkf, jmp1, llm, 2, 1, .TRUE., 1 )
-    end if
-
-  END SUBROUTINE exner_hyb
-
-end module exner_hyb_m
Index: /LMDZ6/trunk/libf/dyn3d_common/exner_hyb_m.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d_common/exner_hyb_m.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3d_common/exner_hyb_m.f90	(revision 5268)
@@ -0,0 +1,147 @@
+module exner_hyb_m
+
+  IMPLICIT NONE
+
+contains
+
+  SUBROUTINE  exner_hyb ( ngrid, ps, p, pks, pk, pkf )
+
+    !     Auteurs :  P.Le Van  , Fr. Hourdin  .
+    !    ..........
+    !
+    !    ....  ngrid, ps,p             sont des argum.d'entree  au sous-prog ...
+    !    ....  pks,pk,pkf   sont des argum.de sortie au sous-prog ...
+    !
+    !   ************************************************************************
+    !    Calcule la fonction d'Exner pk = Cp * (p/preff) ** kappa , aux milieux des 
+    !    couches .   Pk(l) sera calcule aux milieux  des couches l ,entre les
+    !    pressions p(l) et p(l+1) ,definis aux interfaces des llm couches .
+    !   ************************************************************************
+    !  .. N.B : Au sommet de l'atmosphere,  p(llm+1) = 0. , et ps et pks sont
+    !    la pression et la fonction d'Exner  au  sol  .
+    !
+    !                                 -------- z
+    !    A partir des relations  ( 1 ) p*dz(pk) = kappa *pk*dz(p)      et
+    !                            ( 2 ) pk(l) = alpha(l)+ beta(l)*pk(l-1)
+    !    ( voir note de Fr.Hourdin )  ,
+    !
+    !    on determine successivement , du haut vers le bas des couches, les 
+    !    coef. alpha(llm),beta(llm) .,.,alpha(l),beta(l),,,alpha(2),beta(2), 
+    !    puis pk(ij,1). Ensuite ,on calcule,du bas vers le haut des couches,  
+    !     pk(ij,l)  donne  par la relation (2),  pour l = 2 a l = llm .
+    !
+    !
+    !
+    USE comconst_mod, ONLY: jmp1, cpp, kappa, r
+    USE comvert_mod, ONLY: preff
+    
+    IMPLICIT NONE
+    
+    include "dimensions.h"
+    include "paramet.h"
+    include "comgeom.h"
+
+    INTEGER  ngrid
+    REAL p(ngrid,llmp1),pk(ngrid,llm)
+    real, optional:: pkf(ngrid,llm)
+    REAL ps(ngrid),pks(ngrid), alpha(ngrid,llm),beta(ngrid,llm)
+
+    !    .... variables locales   ...
+
+    INTEGER l, ij
+    REAL unpl2k,dellta
+
+    logical,save :: firstcall=.true.
+    character(len=*),parameter :: modname="exner_hyb"
+
+    ! Sanity check
+    if (firstcall) then
+       ! sanity checks for Shallow Water case (1 vertical layer)
+       if (llm.eq.1) then
+          if (kappa.ne.1) then
+             call abort_gcm(modname, &
+                  "kappa!=1 , but running in Shallow Water mode!!",42)
+          endif
+          if (cpp.ne.r) then
+             call abort_gcm(modname, &
+                  "cpp!=r , but running in Shallow Water mode!!",42)
+          endif
+       endif ! of if (llm.eq.1)
+
+       firstcall=.false.
+    endif ! of if (firstcall)
+
+    ! Specific behaviour for Shallow Water (1 vertical layer) case:
+    if (llm.eq.1) then
+
+       ! Compute pks(:),pk(:),pkf(:)
+
+       DO   ij  = 1, ngrid
+          pks(ij) = (cpp/preff) * ps(ij)
+          pk(ij,1) = .5*pks(ij)
+       ENDDO
+
+       if (present(pkf)) then
+          pkf = pk
+          CALL filtreg ( pkf, jmp1, llm, 2, 1, .TRUE., 1 ) 
+       end if
+
+       ! our work is done, exit routine
+       return
+    endif ! of if (llm.eq.1)
+
+    ! General case:
+
+    unpl2k    = 1.+ 2.* kappa
+
+    !     -------------
+    !     Calcul de pks
+    !     -------------
+
+    DO   ij  = 1, ngrid
+       pks(ij) = cpp * ( ps(ij)/preff ) ** kappa
+    ENDDO
+
+    !    .... Calcul des coeff. alpha et beta  pour la couche l = llm ..
+    !
+    DO     ij      = 1, ngrid
+       alpha(ij,llm) = 0.
+       beta (ij,llm) = 1./ unpl2k
+    ENDDO
+    !
+    !     ... Calcul des coeff. alpha et beta  pour l = llm-1  a l = 2 ...
+    !
+    DO l = llm -1 , 2 , -1
+       !
+       DO ij = 1, ngrid
+          dellta = p(ij,l)* unpl2k + p(ij,l+1)* ( beta(ij,l+1)-unpl2k )
+          alpha(ij,l)  = - p(ij,l+1) / dellta * alpha(ij,l+1)
+          beta (ij,l)  =   p(ij,l  ) / dellta   
+       ENDDO
+    ENDDO
+
+    !  ***********************************************************************
+    !     .....  Calcul de pk pour la couche 1 , pres du sol  ....
+    !
+    DO   ij   = 1, ngrid
+       pk(ij,1) = ( p(ij,1)*pks(ij) - 0.5*alpha(ij,2)*p(ij,2) )  / &
+            (  p(ij,1)* (1.+kappa) + 0.5*( beta(ij,2)-unpl2k )* p(ij,2) )
+    ENDDO
+    !
+    !    ..... Calcul de pk(ij,l) , pour l = 2 a l = llm  ........
+    !
+    DO l = 2, llm
+       DO   ij   = 1, ngrid
+          pk(ij,l) = alpha(ij,l) + beta(ij,l) * pk(ij,l-1)
+       ENDDO
+    ENDDO
+
+    if (present(pkf)) then
+       !    calcul de pkf
+       pkf = pk
+       CALL filtreg ( pkf, jmp1, llm, 2, 1, .TRUE., 1 )
+    end if
+
+  END SUBROUTINE exner_hyb
+
+end module exner_hyb_m
Index: DZ6/trunk/libf/dyn3d_common/exner_milieu_m.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d_common/exner_milieu_m.F90	(revision 5267)
+++ 	(revision )
@@ -1,126 +1,0 @@
-module exner_milieu_m
-
-  IMPLICIT NONE
-
-contains
-
-  SUBROUTINE  exner_milieu ( ngrid, ps, p, pks, pk, pkf )
-    !
-    !     Auteurs :  F. Forget , Y. Wanherdrick
-    ! P.Le Van  , Fr. Hourdin  .
-    !    ..........
-    !
-    !    ....  ngrid, ps,p             sont des argum.d'entree  au sous-prog ...
-    !    ....  pks,pk,pkf   sont des argum.de sortie au sous-prog ...
-    !
-    !   ************************************************************************
-    !    Calcule la fonction d'Exner pk = Cp * (p/preff) ** kappa , aux milieux des 
-    !    couches .   Pk(l) sera calcule aux milieux  des couches l ,entre les
-    !    pressions p(l) et p(l+1) ,definis aux interfaces des llm couches .
-    !   ************************************************************************
-    !  .. N.B : Au sommet de l'atmosphere,  p(llm+1) = 0. , et ps et pks sont
-    !    la pression et la fonction d'Exner  au  sol  .
-    !
-    !     WARNING : CECI est une version speciale de exner_hyb originale
-    !               Utilise dans la version martienne pour pouvoir 
-    !               tourner avec des coordonnees verticales complexe
-    !              => Il ne verifie PAS la condition la proportionalite en 
-    !              energie totale/ interne / potentielle (F.Forget 2001)
-    !    ( voir note de Fr.Hourdin )  ,
-    !
-    !
-    USE comconst_mod, ONLY: jmp1, cpp, kappa, r
-    USE comvert_mod, ONLY: preff
-    
-    IMPLICIT NONE
-    
-    include "dimensions.h"
-    include "paramet.h"
-    include "comgeom.h"
-
-    INTEGER  ngrid
-    REAL p(ngrid,llmp1),pk(ngrid,llm)
-    real, optional:: pkf(ngrid,llm)
-    REAL ps(ngrid),pks(ngrid)
-
-    !    .... variables locales   ...
-
-    INTEGER l, ij
-    REAL dum1
-
-    logical,save :: firstcall=.true.
-    character(len=*),parameter :: modname="exner_milieu"
-
-    ! Sanity check
-    if (firstcall) then
-       ! sanity checks for Shallow Water case (1 vertical layer)
-       if (llm.eq.1) then
-          if (kappa.ne.1) then
-             call abort_gcm(modname, &
-                  "kappa!=1 , but running in Shallow Water mode!!",42)
-          endif
-          if (cpp.ne.r) then
-             call abort_gcm(modname, &
-                  "cpp!=r , but running in Shallow Water mode!!",42)
-          endif
-       endif ! of if (llm.eq.1)
-
-       firstcall=.false.
-    endif ! of if (firstcall)
-
-    ! Specific behaviour for Shallow Water (1 vertical layer) case:
-    if (llm.eq.1) then
-
-       ! Compute pks(:),pk(:),pkf(:)
-
-       DO   ij  = 1, ngrid
-          pks(ij) = (cpp/preff) * ps(ij)
-          pk(ij,1) = .5*pks(ij)
-       ENDDO
-
-       if (present(pkf)) then
-          pkf = pk
-          CALL filtreg ( pkf, jmp1, llm, 2, 1, .TRUE., 1 ) 
-       end if
-
-       ! our work is done, exit routine
-       return
-    endif ! of if (llm.eq.1)
-
-    ! General case:
-
-    !     -------------
-    !     Calcul de pks
-    !     -------------
-
-    DO   ij  = 1, ngrid
-       pks(ij) = cpp * ( ps(ij)/preff ) ** kappa
-    ENDDO
-
-    !    .... Calcul de pk  pour la couche l 
-    !    --------------------------------------------
-    !
-    dum1 = cpp * (2*preff)**(-kappa) 
-    DO l = 1, llm-1
-       DO   ij   = 1, ngrid
-          pk(ij,l) = dum1 * (p(ij,l) + p(ij,l+1))**kappa
-       ENDDO
-    ENDDO
-
-    !    .... Calcul de pk  pour la couche l = llm ..
-    !    (on met la meme distance (en log pression)  entre Pk(llm)
-    !    et Pk(llm -1) qu'entre Pk(llm-1) et Pk(llm-2)
-
-    DO   ij   = 1, ngrid
-       pk(ij,llm) = pk(ij,llm-1)**2 / pk(ij,llm-2)
-    ENDDO
-
-    if (present(pkf)) then
-       !    calcul de pkf
-       pkf = pk
-       CALL filtreg ( pkf, jmp1, llm, 2, 1, .TRUE., 1 )
-    end if
-
-  END SUBROUTINE exner_milieu
-
-end module exner_milieu_m
Index: /LMDZ6/trunk/libf/dyn3d_common/exner_milieu_m.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d_common/exner_milieu_m.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3d_common/exner_milieu_m.f90	(revision 5268)
@@ -0,0 +1,126 @@
+module exner_milieu_m
+
+  IMPLICIT NONE
+
+contains
+
+  SUBROUTINE  exner_milieu ( ngrid, ps, p, pks, pk, pkf )
+    !
+    !     Auteurs :  F. Forget , Y. Wanherdrick
+    ! P.Le Van  , Fr. Hourdin  .
+    !    ..........
+    !
+    !    ....  ngrid, ps,p             sont des argum.d'entree  au sous-prog ...
+    !    ....  pks,pk,pkf   sont des argum.de sortie au sous-prog ...
+    !
+    !   ************************************************************************
+    !    Calcule la fonction d'Exner pk = Cp * (p/preff) ** kappa , aux milieux des 
+    !    couches .   Pk(l) sera calcule aux milieux  des couches l ,entre les
+    !    pressions p(l) et p(l+1) ,definis aux interfaces des llm couches .
+    !   ************************************************************************
+    !  .. N.B : Au sommet de l'atmosphere,  p(llm+1) = 0. , et ps et pks sont
+    !    la pression et la fonction d'Exner  au  sol  .
+    !
+    !     WARNING : CECI est une version speciale de exner_hyb originale
+    !               Utilise dans la version martienne pour pouvoir 
+    !               tourner avec des coordonnees verticales complexe
+    !              => Il ne verifie PAS la condition la proportionalite en 
+    !              energie totale/ interne / potentielle (F.Forget 2001)
+    !    ( voir note de Fr.Hourdin )  ,
+    !
+    !
+    USE comconst_mod, ONLY: jmp1, cpp, kappa, r
+    USE comvert_mod, ONLY: preff
+    
+    IMPLICIT NONE
+    
+    include "dimensions.h"
+    include "paramet.h"
+    include "comgeom.h"
+
+    INTEGER  ngrid
+    REAL p(ngrid,llmp1),pk(ngrid,llm)
+    real, optional:: pkf(ngrid,llm)
+    REAL ps(ngrid),pks(ngrid)
+
+    !    .... variables locales   ...
+
+    INTEGER l, ij
+    REAL dum1
+
+    logical,save :: firstcall=.true.
+    character(len=*),parameter :: modname="exner_milieu"
+
+    ! Sanity check
+    if (firstcall) then
+       ! sanity checks for Shallow Water case (1 vertical layer)
+       if (llm.eq.1) then
+          if (kappa.ne.1) then
+             call abort_gcm(modname, &
+                  "kappa!=1 , but running in Shallow Water mode!!",42)
+          endif
+          if (cpp.ne.r) then
+             call abort_gcm(modname, &
+                  "cpp!=r , but running in Shallow Water mode!!",42)
+          endif
+       endif ! of if (llm.eq.1)
+
+       firstcall=.false.
+    endif ! of if (firstcall)
+
+    ! Specific behaviour for Shallow Water (1 vertical layer) case:
+    if (llm.eq.1) then
+
+       ! Compute pks(:),pk(:),pkf(:)
+
+       DO   ij  = 1, ngrid
+          pks(ij) = (cpp/preff) * ps(ij)
+          pk(ij,1) = .5*pks(ij)
+       ENDDO
+
+       if (present(pkf)) then
+          pkf = pk
+          CALL filtreg ( pkf, jmp1, llm, 2, 1, .TRUE., 1 ) 
+       end if
+
+       ! our work is done, exit routine
+       return
+    endif ! of if (llm.eq.1)
+
+    ! General case:
+
+    !     -------------
+    !     Calcul de pks
+    !     -------------
+
+    DO   ij  = 1, ngrid
+       pks(ij) = cpp * ( ps(ij)/preff ) ** kappa
+    ENDDO
+
+    !    .... Calcul de pk  pour la couche l 
+    !    --------------------------------------------
+    !
+    dum1 = cpp * (2*preff)**(-kappa) 
+    DO l = 1, llm-1
+       DO   ij   = 1, ngrid
+          pk(ij,l) = dum1 * (p(ij,l) + p(ij,l+1))**kappa
+       ENDDO
+    ENDDO
+
+    !    .... Calcul de pk  pour la couche l = llm ..
+    !    (on met la meme distance (en log pression)  entre Pk(llm)
+    !    et Pk(llm -1) qu'entre Pk(llm-1) et Pk(llm-2)
+
+    DO   ij   = 1, ngrid
+       pk(ij,llm) = pk(ij,llm-1)**2 / pk(ij,llm-2)
+    ENDDO
+
+    if (present(pkf)) then
+       !    calcul de pkf
+       pkf = pk
+       CALL filtreg ( pkf, jmp1, llm, 2, 1, .TRUE., 1 )
+    end if
+
+  END SUBROUTINE exner_milieu
+
+end module exner_milieu_m
Index: DZ6/trunk/libf/dyn3d_common/flumass.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d_common/flumass.F90	(revision 5267)
+++ 	(revision )
@@ -1,76 +1,0 @@
-SUBROUTINE flumass (massebx,masseby, vcont, ucont, pbaru, pbarv )
-!
-!-------------------------------------------------------------------------------
-! Authors: P. Le Van , Fr. Hourdin.
-!-------------------------------------------------------------------------------
-! Purpose: Compute mass flux at s levels.
-  IMPLICIT NONE
-  include "dimensions.h"
-  include "paramet.h"
-  include "comgeom.h"
-!===============================================================================
-! Arguments:
-  REAL, INTENT(IN)  :: massebx(ip1jmp1,llm)
-  REAL, INTENT(IN)  :: masseby(ip1jm  ,llm)
-  REAL, INTENT(IN)  :: vcont  (ip1jm  ,llm)
-  REAL, INTENT(IN)  :: ucont  (ip1jmp1,llm)
-  REAL, INTENT(OUT) :: pbaru  (ip1jmp1,llm)
-  REAL, INTENT(OUT) :: pbarv  (ip1jm  ,llm)
-!===============================================================================
-! Method used:   A 2 equations system is solved.
-!   * 1st one describes divergence computation at pole point nr. i (i=1 to im):
-!     (0.5*(pbaru(i)-pbaru(i-1))-pbarv(i))/aire(i) = - SUM(pbarv(n))/aire pole
-!   * 2nd one specifies that mean mass flux at pole is equal to 0:
-!     SUM(pbaru(n)*local_area(n))=0
-! This way, we determine additive constant common to pbary elements representing
-!   pbaru(0,j,l) in divergence computation equation for point i=1. (i=1 to im)
-!===============================================================================
-! Local variables:
-  REAL    :: sairen, saireun, ctn, ctn0, apbarun(iip1)
-  REAL    :: saires, saireus, cts, cts0, apbarus(iip1)
-  INTEGER :: l, i
-!===============================================================================
-  DO l=1,llm
-    pbaru(iip2:ip1jm,l)=massebx(iip2:ip1jm,l)*ucont(iip2:ip1jm,l)
-    pbarv(   1:ip1jm,l)=masseby(   1:ip1jm,l)*vcont(   1:ip1jm,l)
-  END DO
-
-  !--- NORTH POLE
-  sairen =SUM(aire (1:iim))
-  saireun=SUM(aireu(1:iim))
-  DO l = 1,llm
-    ctn=SUM(pbarv(1:iim,l))/sairen
-    pbaru(1,l)= pbarv(1,l)-ctn*aire(1)
-    DO i=2,iim
-      pbaru(i,l)=pbaru(i-1,l)+pbarv(i,l)-ctn*aire(i)
-    END DO
-    DO i=1,iim
-      apbarun(i)=aireu(i)*pbaru(i,l)
-    END DO
-    ctn0 = -SUM(apbarun(1:iim))/saireun
-    DO i = 1,iim
-      pbaru(i,l)=2.*(pbaru(i,l)+ctn0)
-    END DO
-    pbaru(iip1,l)=pbaru(1,l)
-  END DO
-
-  !--- SOUTH POLE
-  saires =SUM(aire (ip1jm+1:ip1jmp1-1))
-  saireus=SUM(aireu(ip1jm+1:ip1jmp1-1))
-  DO l = 1,llm
-    cts=SUM(pbarv(ip1jmi1+1:ip1jm-1,l))/saires
-    pbaru(1+ip1jm,l)=-pbarv(1+ip1jmi1,l)+cts*aire(1+ip1jm)
-    DO i=2,iim
-      pbaru(i+ip1jm,l)=pbaru(i-1+ip1jm,l)-pbarv(i+ip1jmi1,l)+cts*aire(i+ip1jm)
-    END DO
-    DO i=1,iim
-      apbarus(i)=aireu(i+ip1jm)*pbaru(i+ip1jm,l)
-    END DO
-    cts0 = -SUM(apbarus(1:iim))/saireus
-    DO i = 1,iim
-      pbaru(i+ip1jm,l)=2.*(pbaru(i+ip1jm,l)+cts0)
-    END DO
-    pbaru(ip1jmp1,l)=pbaru(1+ip1jm,l)
-  END DO
-
-END SUBROUTINE flumass
Index: /LMDZ6/trunk/libf/dyn3d_common/flumass.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d_common/flumass.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3d_common/flumass.f90	(revision 5268)
@@ -0,0 +1,76 @@
+SUBROUTINE flumass (massebx,masseby, vcont, ucont, pbaru, pbarv )
+!
+!-------------------------------------------------------------------------------
+! Authors: P. Le Van , Fr. Hourdin.
+!-------------------------------------------------------------------------------
+! Purpose: Compute mass flux at s levels.
+  IMPLICIT NONE
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom.h"
+!===============================================================================
+! Arguments:
+  REAL, INTENT(IN)  :: massebx(ip1jmp1,llm)
+  REAL, INTENT(IN)  :: masseby(ip1jm  ,llm)
+  REAL, INTENT(IN)  :: vcont  (ip1jm  ,llm)
+  REAL, INTENT(IN)  :: ucont  (ip1jmp1,llm)
+  REAL, INTENT(OUT) :: pbaru  (ip1jmp1,llm)
+  REAL, INTENT(OUT) :: pbarv  (ip1jm  ,llm)
+!===============================================================================
+! Method used:   A 2 equations system is solved.
+!   * 1st one describes divergence computation at pole point nr. i (i=1 to im):
+!     (0.5*(pbaru(i)-pbaru(i-1))-pbarv(i))/aire(i) = - SUM(pbarv(n))/aire pole
+!   * 2nd one specifies that mean mass flux at pole is equal to 0:
+!     SUM(pbaru(n)*local_area(n))=0
+! This way, we determine additive constant common to pbary elements representing
+!   pbaru(0,j,l) in divergence computation equation for point i=1. (i=1 to im)
+!===============================================================================
+! Local variables:
+  REAL    :: sairen, saireun, ctn, ctn0, apbarun(iip1)
+  REAL    :: saires, saireus, cts, cts0, apbarus(iip1)
+  INTEGER :: l, i
+!===============================================================================
+  DO l=1,llm
+    pbaru(iip2:ip1jm,l)=massebx(iip2:ip1jm,l)*ucont(iip2:ip1jm,l)
+    pbarv(   1:ip1jm,l)=masseby(   1:ip1jm,l)*vcont(   1:ip1jm,l)
+  END DO
+
+  !--- NORTH POLE
+  sairen =SUM(aire (1:iim))
+  saireun=SUM(aireu(1:iim))
+  DO l = 1,llm
+    ctn=SUM(pbarv(1:iim,l))/sairen
+    pbaru(1,l)= pbarv(1,l)-ctn*aire(1)
+    DO i=2,iim
+      pbaru(i,l)=pbaru(i-1,l)+pbarv(i,l)-ctn*aire(i)
+    END DO
+    DO i=1,iim
+      apbarun(i)=aireu(i)*pbaru(i,l)
+    END DO
+    ctn0 = -SUM(apbarun(1:iim))/saireun
+    DO i = 1,iim
+      pbaru(i,l)=2.*(pbaru(i,l)+ctn0)
+    END DO
+    pbaru(iip1,l)=pbaru(1,l)
+  END DO
+
+  !--- SOUTH POLE
+  saires =SUM(aire (ip1jm+1:ip1jmp1-1))
+  saireus=SUM(aireu(ip1jm+1:ip1jmp1-1))
+  DO l = 1,llm
+    cts=SUM(pbarv(ip1jmi1+1:ip1jm-1,l))/saires
+    pbaru(1+ip1jm,l)=-pbarv(1+ip1jmi1,l)+cts*aire(1+ip1jm)
+    DO i=2,iim
+      pbaru(i+ip1jm,l)=pbaru(i-1+ip1jm,l)-pbarv(i+ip1jmi1,l)+cts*aire(i+ip1jm)
+    END DO
+    DO i=1,iim
+      apbarus(i)=aireu(i+ip1jm)*pbaru(i+ip1jm,l)
+    END DO
+    cts0 = -SUM(apbarus(1:iim))/saireus
+    DO i = 1,iim
+      pbaru(i+ip1jm,l)=2.*(pbaru(i+ip1jm,l)+cts0)
+    END DO
+    pbaru(ip1jmp1,l)=pbaru(1+ip1jm,l)
+  END DO
+
+END SUBROUTINE flumass
Index: DZ6/trunk/libf/dyn3d_common/fxhyp_m.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d_common/fxhyp_m.F90	(revision 5267)
+++ 	(revision )
@@ -1,248 +1,0 @@
-module fxhyp_m
-
-  IMPLICIT NONE
-
-contains
-
-  SUBROUTINE fxhyp(xprimm025, rlonv, xprimv, rlonu, xprimu, xprimp025)
-
-    ! From LMDZ4/libf/dyn3d/fxhyp.F, version 1.2, 2005/06/03 09:11:32
-    ! Author: P. Le Van, from formulas by R. Sadourny
-
-    ! Calcule les longitudes et dérivées dans la grille du GCM pour
-    ! une fonction f(x) à dérivée tangente hyperbolique.
-
-    ! Il vaut mieux avoir : grossismx \times dzoom < pi
-
-    ! Le premier point scalaire pour une grille regulière (grossismx =
-    ! 1., taux=0., clon=0.) est à - 180 degrés.
-
-    use arth_m, only: arth
-    use invert_zoom_x_m, only: invert_zoom_x, nmax
-    use nrtype, only: pi, pi_d, twopi, twopi_d, k8
-    use principal_cshift_m, only: principal_cshift
-    use serre_mod, only: clon, grossismx, dzoomx, taux
-
-    include "dimensions.h"
-    ! for iim
-
-    REAL, intent(out):: xprimm025(:), rlonv(:), xprimv(:) ! (iim + 1)
-    real, intent(out):: rlonu(:), xprimu(:), xprimp025(:) ! (iim + 1)
-
-    ! Local:
-    real rlonm025(iim + 1), rlonp025(iim + 1)
-    REAL dzoom, step
-    real d_rlonv(iim)
-    REAL(K8) xtild(0:2 * nmax)
-    REAL(K8) fhyp(nmax:2 * nmax), ffdx, beta, Xprimt(0:2 * nmax)
-    REAL(K8) Xf(0:2 * nmax), xxpr(2 * nmax)
-    REAL(K8) fa, fb
-    INTEGER i, is2
-    REAL(K8) xmoy, fxm
-
-    !----------------------------------------------------------------------
-
-    print *, "Call sequence information: fxhyp"
-
-    test_iim: if (iim==1) then
-       rlonv(1)=0.
-       rlonu(1)=pi
-       rlonv(2)=rlonv(1)+twopi
-       rlonu(2)=rlonu(1)+twopi
-
-       xprimm025(:)=1.
-       xprimv(:)=1.
-       xprimu(:)=1.
-       xprimp025(:)=1.
-    else test_iim
-       test_grossismx: if (grossismx == 1.) then
-          step = twopi / iim
-
-          xprimm025(:iim) = step
-          xprimp025(:iim) = step
-          xprimv(:iim) = step
-          xprimu(:iim) = step
-
-          rlonv(:iim) = arth(- pi + clon / 180. * pi, step, iim)
-          rlonm025(:iim) = rlonv(:iim) - 0.25 * step
-          rlonp025(:iim) = rlonv(:iim) + 0.25 * step
-          rlonu(:iim) = rlonv(:iim) + 0.5 * step
-       else test_grossismx
-          dzoom = dzoomx * twopi_d
-          xtild = arth(- pi_d, pi_d / nmax, 2 * nmax + 1)
-
-          ! Compute fhyp:
-          DO i = nmax, 2 * nmax
-             fa = taux * (dzoom / 2. - xtild(i))
-             fb = xtild(i) * (pi_d - xtild(i))
-
-             IF (200. * fb < - fa) THEN
-                fhyp(i) = - 1.
-             ELSE IF (200. * fb < fa) THEN
-                fhyp(i) = 1.
-             ELSE
-                IF (ABS(fa) < 1e-13 .AND. ABS(fb) < 1e-13) THEN
-                   IF (200. * fb + fa < 1e-10) THEN
-                      fhyp(i) = - 1.
-                   ELSE IF (200. * fb - fa < 1e-10) THEN
-                      fhyp(i) = 1.
-                   END IF
-                ELSE
-                   fhyp(i) = TANH(fa / fb)
-                END IF
-             END IF
-
-             IF (xtild(i) == 0.) fhyp(i) = 1.
-             IF (xtild(i) == pi_d) fhyp(i) = -1.
-          END DO
-
-          ! Calcul de beta 
-
-          ffdx = 0.
-
-          DO i = nmax + 1, 2 * nmax
-             xmoy = 0.5 * (xtild(i-1) + xtild(i))
-             fa = taux * (dzoom / 2. - xmoy)
-             fb = xmoy * (pi_d - xmoy)
-
-             IF (200. * fb < - fa) THEN
-                fxm = - 1.
-             ELSE IF (200. * fb < fa) THEN
-                fxm = 1.
-             ELSE
-                IF (ABS(fa) < 1e-13 .AND. ABS(fb) < 1e-13) THEN
-                   IF (200. * fb + fa < 1e-10) THEN
-                      fxm = - 1.
-                   ELSE IF (200. * fb - fa < 1e-10) THEN
-                      fxm = 1.
-                   END IF
-                ELSE
-                   fxm = TANH(fa / fb)
-                END IF
-             END IF
-
-             IF (xmoy == 0.) fxm = 1.
-             IF (xmoy == pi_d) fxm = -1.
-
-             ffdx = ffdx + fxm * (xtild(i) - xtild(i-1))
-          END DO
-
-          print *, "ffdx = ", ffdx
-          beta = (grossismx * ffdx - pi_d) / (ffdx - pi_d)
-          print *, "beta = ", beta
-
-          IF (2. * beta - grossismx <= 0.) THEN
-             print *, 'Bad choice of grossismx, taux, dzoomx.'
-             print *, 'Decrease dzoomx or grossismx.'
-             STOP 1
-          END IF
-
-          ! calcul de Xprimt 
-          Xprimt(nmax:2 * nmax) = beta + (grossismx - beta) * fhyp
-          xprimt(:nmax - 1) = xprimt(2 * nmax:nmax + 1:- 1)
-
-          ! Calcul de Xf
-
-          DO i = nmax + 1, 2 * nmax
-             xmoy = 0.5 * (xtild(i-1) + xtild(i))
-             fa = taux * (dzoom / 2. - xmoy)
-             fb = xmoy * (pi_d - xmoy)
-
-             IF (200. * fb < - fa) THEN
-                fxm = - 1.
-             ELSE IF (200. * fb < fa) THEN
-                fxm = 1.
-             ELSE
-                fxm = TANH(fa / fb)
-             END IF
-
-             IF (xmoy == 0.) fxm = 1.
-             IF (xmoy == pi_d) fxm = -1.
-             xxpr(i) = beta + (grossismx - beta) * fxm
-          END DO
-
-          xxpr(:nmax) = xxpr(2 * nmax:nmax + 1:- 1)
-
-          Xf(0) = - pi_d
-
-          DO i=1, 2 * nmax - 1
-             Xf(i) = Xf(i-1) + xxpr(i) * (xtild(i) - xtild(i-1))
-          END DO
-
-          Xf(2 * nmax) = pi_d
-
-          call invert_zoom_x(xf, xtild, Xprimt, rlonm025(:iim), &
-               xprimm025(:iim), xuv = - 0.25_k8)
-          call invert_zoom_x(xf, xtild, Xprimt, rlonv(:iim), xprimv(:iim), &
-               xuv = 0._k8)
-          call invert_zoom_x(xf, xtild, Xprimt, rlonu(:iim), xprimu(:iim), &
-               xuv = 0.5_k8)
-          call invert_zoom_x(xf, xtild, Xprimt, rlonp025(:iim), &
-               xprimp025(:iim), xuv = 0.25_k8)
-       end if test_grossismx
-
-       is2 = 0
-
-       IF (MINval(rlonm025(:iim)) < - pi - 0.1 &
-            .or. MAXval(rlonm025(:iim)) > pi + 0.1) THEN
-          IF (clon <= 0.) THEN
-             is2 = 1
-
-             do while (rlonm025(is2) < - pi .and. is2 < iim)
-                is2 = is2 + 1
-             end do
-
-             if (rlonm025(is2) < - pi) then
-                print *, 'Rlonm025 plus petit que - pi !'
-                STOP 1
-             end if
-          ELSE
-             is2 = iim
-
-             do while (rlonm025(is2) > pi .and. is2 > 1)
-                is2 = is2 - 1
-             end do
-
-             if (rlonm025(is2) > pi) then
-                print *, 'Rlonm025 plus grand que pi !'
-                STOP 1
-             end if
-          END IF
-       END IF
-
-       call principal_cshift(is2, rlonm025, xprimm025)
-       call principal_cshift(is2, rlonv, xprimv)
-       call principal_cshift(is2, rlonu, xprimu)
-       call principal_cshift(is2, rlonp025, xprimp025)
-
-       forall (i = 1: iim) d_rlonv(i) = rlonv(i + 1) - rlonv(i)
-       print *, "Minimum longitude step:", MINval(d_rlonv) * 180. / pi, &
-            "degrees"
-       print *, "Maximum longitude step:", MAXval(d_rlonv) * 180. / pi, &
-            "degrees"
-
-       ! Check that rlonm025 <= rlonv <= rlonp025 <= rlonu:
-       DO i = 1, iim + 1
-          IF (rlonp025(i) < rlonv(i)) THEN
-             print *, 'rlonp025(', i, ') = ', rlonp025(i)
-             print *, "< rlonv(", i, ") = ", rlonv(i)
-             STOP 1
-          END IF
-
-          IF (rlonv(i) < rlonm025(i)) THEN 
-             print *, 'rlonv(', i, ') = ', rlonv(i)
-             print *, "< rlonm025(", i, ") = ", rlonm025(i)
-             STOP 1
-          END IF
-
-          IF (rlonp025(i) > rlonu(i)) THEN
-             print *, 'rlonp025(', i, ') = ', rlonp025(i)
-             print *, "> rlonu(", i, ") = ", rlonu(i)
-             STOP 1
-          END IF
-       END DO
-    end if test_iim
-
-  END SUBROUTINE fxhyp
-
-end module fxhyp_m
Index: /LMDZ6/trunk/libf/dyn3d_common/fxhyp_m.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d_common/fxhyp_m.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3d_common/fxhyp_m.f90	(revision 5268)
@@ -0,0 +1,248 @@
+module fxhyp_m
+
+  IMPLICIT NONE
+
+contains
+
+  SUBROUTINE fxhyp(xprimm025, rlonv, xprimv, rlonu, xprimu, xprimp025)
+
+    ! From LMDZ4/libf/dyn3d/fxhyp.F, version 1.2, 2005/06/03 09:11:32
+    ! Author: P. Le Van, from formulas by R. Sadourny
+
+    ! Calcule les longitudes et dérivées dans la grille du GCM pour
+    ! une fonction f(x) à dérivée tangente hyperbolique.
+
+    ! Il vaut mieux avoir : grossismx \times dzoom < pi
+
+    ! Le premier point scalaire pour une grille regulière (grossismx =
+    ! 1., taux=0., clon=0.) est à - 180 degrés.
+
+    use arth_m, only: arth
+    use invert_zoom_x_m, only: invert_zoom_x, nmax
+    use nrtype, only: pi, pi_d, twopi, twopi_d, k8
+    use principal_cshift_m, only: principal_cshift
+    use serre_mod, only: clon, grossismx, dzoomx, taux
+
+    include "dimensions.h"
+    ! for iim
+
+    REAL, intent(out):: xprimm025(:), rlonv(:), xprimv(:) ! (iim + 1)
+    real, intent(out):: rlonu(:), xprimu(:), xprimp025(:) ! (iim + 1)
+
+    ! Local:
+    real rlonm025(iim + 1), rlonp025(iim + 1)
+    REAL dzoom, step
+    real d_rlonv(iim)
+    REAL(K8) xtild(0:2 * nmax)
+    REAL(K8) fhyp(nmax:2 * nmax), ffdx, beta, Xprimt(0:2 * nmax)
+    REAL(K8) Xf(0:2 * nmax), xxpr(2 * nmax)
+    REAL(K8) fa, fb
+    INTEGER i, is2
+    REAL(K8) xmoy, fxm
+
+    !----------------------------------------------------------------------
+
+    print *, "Call sequence information: fxhyp"
+
+    test_iim: if (iim==1) then
+       rlonv(1)=0.
+       rlonu(1)=pi
+       rlonv(2)=rlonv(1)+twopi
+       rlonu(2)=rlonu(1)+twopi
+
+       xprimm025(:)=1.
+       xprimv(:)=1.
+       xprimu(:)=1.
+       xprimp025(:)=1.
+    else test_iim
+       test_grossismx: if (grossismx == 1.) then
+          step = twopi / iim
+
+          xprimm025(:iim) = step
+          xprimp025(:iim) = step
+          xprimv(:iim) = step
+          xprimu(:iim) = step
+
+          rlonv(:iim) = arth(- pi + clon / 180. * pi, step, iim)
+          rlonm025(:iim) = rlonv(:iim) - 0.25 * step
+          rlonp025(:iim) = rlonv(:iim) + 0.25 * step
+          rlonu(:iim) = rlonv(:iim) + 0.5 * step
+       else test_grossismx
+          dzoom = dzoomx * twopi_d
+          xtild = arth(- pi_d, pi_d / nmax, 2 * nmax + 1)
+
+          ! Compute fhyp:
+          DO i = nmax, 2 * nmax
+             fa = taux * (dzoom / 2. - xtild(i))
+             fb = xtild(i) * (pi_d - xtild(i))
+
+             IF (200. * fb < - fa) THEN
+                fhyp(i) = - 1.
+             ELSE IF (200. * fb < fa) THEN
+                fhyp(i) = 1.
+             ELSE
+                IF (ABS(fa) < 1e-13 .AND. ABS(fb) < 1e-13) THEN
+                   IF (200. * fb + fa < 1e-10) THEN
+                      fhyp(i) = - 1.
+                   ELSE IF (200. * fb - fa < 1e-10) THEN
+                      fhyp(i) = 1.
+                   END IF
+                ELSE
+                   fhyp(i) = TANH(fa / fb)
+                END IF
+             END IF
+
+             IF (xtild(i) == 0.) fhyp(i) = 1.
+             IF (xtild(i) == pi_d) fhyp(i) = -1.
+          END DO
+
+          ! Calcul de beta 
+
+          ffdx = 0.
+
+          DO i = nmax + 1, 2 * nmax
+             xmoy = 0.5 * (xtild(i-1) + xtild(i))
+             fa = taux * (dzoom / 2. - xmoy)
+             fb = xmoy * (pi_d - xmoy)
+
+             IF (200. * fb < - fa) THEN
+                fxm = - 1.
+             ELSE IF (200. * fb < fa) THEN
+                fxm = 1.
+             ELSE
+                IF (ABS(fa) < 1e-13 .AND. ABS(fb) < 1e-13) THEN
+                   IF (200. * fb + fa < 1e-10) THEN
+                      fxm = - 1.
+                   ELSE IF (200. * fb - fa < 1e-10) THEN
+                      fxm = 1.
+                   END IF
+                ELSE
+                   fxm = TANH(fa / fb)
+                END IF
+             END IF
+
+             IF (xmoy == 0.) fxm = 1.
+             IF (xmoy == pi_d) fxm = -1.
+
+             ffdx = ffdx + fxm * (xtild(i) - xtild(i-1))
+          END DO
+
+          print *, "ffdx = ", ffdx
+          beta = (grossismx * ffdx - pi_d) / (ffdx - pi_d)
+          print *, "beta = ", beta
+
+          IF (2. * beta - grossismx <= 0.) THEN
+             print *, 'Bad choice of grossismx, taux, dzoomx.'
+             print *, 'Decrease dzoomx or grossismx.'
+             STOP 1
+          END IF
+
+          ! calcul de Xprimt 
+          Xprimt(nmax:2 * nmax) = beta + (grossismx - beta) * fhyp
+          xprimt(:nmax - 1) = xprimt(2 * nmax:nmax + 1:- 1)
+
+          ! Calcul de Xf
+
+          DO i = nmax + 1, 2 * nmax
+             xmoy = 0.5 * (xtild(i-1) + xtild(i))
+             fa = taux * (dzoom / 2. - xmoy)
+             fb = xmoy * (pi_d - xmoy)
+
+             IF (200. * fb < - fa) THEN
+                fxm = - 1.
+             ELSE IF (200. * fb < fa) THEN
+                fxm = 1.
+             ELSE
+                fxm = TANH(fa / fb)
+             END IF
+
+             IF (xmoy == 0.) fxm = 1.
+             IF (xmoy == pi_d) fxm = -1.
+             xxpr(i) = beta + (grossismx - beta) * fxm
+          END DO
+
+          xxpr(:nmax) = xxpr(2 * nmax:nmax + 1:- 1)
+
+          Xf(0) = - pi_d
+
+          DO i=1, 2 * nmax - 1
+             Xf(i) = Xf(i-1) + xxpr(i) * (xtild(i) - xtild(i-1))
+          END DO
+
+          Xf(2 * nmax) = pi_d
+
+          call invert_zoom_x(xf, xtild, Xprimt, rlonm025(:iim), &
+               xprimm025(:iim), xuv = - 0.25_k8)
+          call invert_zoom_x(xf, xtild, Xprimt, rlonv(:iim), xprimv(:iim), &
+               xuv = 0._k8)
+          call invert_zoom_x(xf, xtild, Xprimt, rlonu(:iim), xprimu(:iim), &
+               xuv = 0.5_k8)
+          call invert_zoom_x(xf, xtild, Xprimt, rlonp025(:iim), &
+               xprimp025(:iim), xuv = 0.25_k8)
+       end if test_grossismx
+
+       is2 = 0
+
+       IF (MINval(rlonm025(:iim)) < - pi - 0.1 &
+            .or. MAXval(rlonm025(:iim)) > pi + 0.1) THEN
+          IF (clon <= 0.) THEN
+             is2 = 1
+
+             do while (rlonm025(is2) < - pi .and. is2 < iim)
+                is2 = is2 + 1
+             end do
+
+             if (rlonm025(is2) < - pi) then
+                print *, 'Rlonm025 plus petit que - pi !'
+                STOP 1
+             end if
+          ELSE
+             is2 = iim
+
+             do while (rlonm025(is2) > pi .and. is2 > 1)
+                is2 = is2 - 1
+             end do
+
+             if (rlonm025(is2) > pi) then
+                print *, 'Rlonm025 plus grand que pi !'
+                STOP 1
+             end if
+          END IF
+       END IF
+
+       call principal_cshift(is2, rlonm025, xprimm025)
+       call principal_cshift(is2, rlonv, xprimv)
+       call principal_cshift(is2, rlonu, xprimu)
+       call principal_cshift(is2, rlonp025, xprimp025)
+
+       forall (i = 1: iim) d_rlonv(i) = rlonv(i + 1) - rlonv(i)
+       print *, "Minimum longitude step:", MINval(d_rlonv) * 180. / pi, &
+            "degrees"
+       print *, "Maximum longitude step:", MAXval(d_rlonv) * 180. / pi, &
+            "degrees"
+
+       ! Check that rlonm025 <= rlonv <= rlonp025 <= rlonu:
+       DO i = 1, iim + 1
+          IF (rlonp025(i) < rlonv(i)) THEN
+             print *, 'rlonp025(', i, ') = ', rlonp025(i)
+             print *, "< rlonv(", i, ") = ", rlonv(i)
+             STOP 1
+          END IF
+
+          IF (rlonv(i) < rlonm025(i)) THEN 
+             print *, 'rlonv(', i, ') = ', rlonv(i)
+             print *, "< rlonm025(", i, ") = ", rlonm025(i)
+             STOP 1
+          END IF
+
+          IF (rlonp025(i) > rlonu(i)) THEN
+             print *, 'rlonp025(', i, ') = ', rlonp025(i)
+             print *, "> rlonu(", i, ") = ", rlonu(i)
+             STOP 1
+          END IF
+       END DO
+    end if test_iim
+
+  END SUBROUTINE fxhyp
+
+end module fxhyp_m
Index: DZ6/trunk/libf/dyn3d_common/fyhyp_m.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d_common/fyhyp_m.F90	(revision 5267)
+++ 	(revision )
@@ -1,340 +1,0 @@
-module fyhyp_m
-
-  IMPLICIT NONE
-
-contains
-
-  SUBROUTINE fyhyp(rlatu, yyprimu, rlatv, rlatu2, yprimu2, rlatu1, yprimu1)
-
-    ! From LMDZ4/libf/dyn3d/fyhyp.F, version 1.2, 2005/06/03 09:11:32
-
-    ! Author: P. Le Van, from analysis by R. Sadourny 
-
-    ! Calcule les latitudes et dérivées dans la grille du GCM pour une
-    ! fonction f(y) à dérivée tangente hyperbolique.
-
-    ! Il vaut mieux avoir : grossismy * dzoom < pi / 2
-
-    use coefpoly_m, only: coefpoly
-    use nrtype, only: k8
-    use serre_mod, only: clat, grossismy, dzoomy, tauy
-
-    include "dimensions.h"
-    ! for jjm
-
-    REAL, intent(out):: rlatu(jjm + 1), yyprimu(jjm + 1)
-    REAL, intent(out):: rlatv(jjm)
-    real, intent(out):: rlatu2(jjm), yprimu2(jjm), rlatu1(jjm), yprimu1(jjm)
-
-    ! Local: 
-
-    REAL(K8) champmin, champmax
-    INTEGER, PARAMETER:: nmax=30000, nmax2=2*nmax
-    REAL dzoom ! distance totale de la zone du zoom (en radians)
-    REAL(K8) ylat(jjm + 1), yprim(jjm + 1)
-    REAL(K8) yuv
-    REAL(K8), save:: yt(0:nmax2)
-    REAL(K8) fhyp(0:nmax2), beta
-    REAL(K8), save:: ytprim(0:nmax2)
-    REAL(K8) fxm(0:nmax2)
-    REAL(K8), save:: yf(0:nmax2)
-    REAL(K8) yypr(0:nmax2)
-    REAL(K8) yvrai(jjm + 1), yprimm(jjm + 1), ylatt(jjm + 1)
-    REAL(K8) pi, pis2, epsilon, y0, pisjm
-    REAL(K8) yo1, yi, ylon2, ymoy, yprimin
-    REAL(K8) yfi, yf1, ffdy
-    REAL(K8) ypn, deply, y00
-    SAVE y00, deply
-
-    INTEGER i, j, it, ik, iter, jlat
-    INTEGER jpn, jjpn
-    SAVE jpn
-    REAL(K8) a0, a1, a2, a3, yi2, heavyy0, heavyy0m
-    REAL(K8) fa(0:nmax2), fb(0:nmax2)
-    REAL y0min, y0max
-
-    REAL(K8) heavyside
-
-    !-------------------------------------------------------------------
-
-    print *, "Call sequence information: fyhyp"
-
-    pi = 2.*asin(1.)
-    pis2 = pi/2.
-    pisjm = pi/real(jjm)
-    epsilon = 1e-3
-    y0 = clat*pi/180.
-    dzoom = dzoomy*pi
-    print *, 'yzoom(rad), grossismy, tauy, dzoom (rad):'
-    print *, y0, grossismy, tauy, dzoom
-
-    DO i = 0, nmax2
-       yt(i) = -pis2 + real(i)*pi/nmax2
-    END DO
-
-    heavyy0m = heavyside(-y0)
-    heavyy0 = heavyside(y0)
-    y0min = 2.*y0*heavyy0m - pis2
-    y0max = 2.*y0*heavyy0 + pis2
-
-    fa = 999.999
-    fb = 999.999
-
-    DO i = 0, nmax2
-       IF (yt(i)<y0) THEN
-          fa(i) = tauy*(yt(i)-y0 + dzoom/2.)
-          fb(i) = (yt(i)-2.*y0*heavyy0m + pis2)*(y0-yt(i))
-       ELSE IF (yt(i)>y0) THEN
-          fa(i) = tauy*(y0-yt(i) + dzoom/2.)
-          fb(i) = (2.*y0*heavyy0-yt(i) + pis2)*(yt(i)-y0)
-       END IF
-
-       IF (200.*fb(i)<-fa(i)) THEN
-          fhyp(i) = -1.
-       ELSE IF (200.*fb(i)<fa(i)) THEN
-          fhyp(i) = 1.
-       ELSE
-          fhyp(i) = tanh(fa(i)/fb(i))
-       END IF
-
-       IF (yt(i)==y0) fhyp(i) = 1.
-       IF (yt(i)==y0min .OR. yt(i)==y0max) fhyp(i) = -1.
-    END DO
-
-    ! Calcul de beta 
-
-    ffdy = 0.
-
-    DO i = 1, nmax2
-       ymoy = 0.5*(yt(i-1) + yt(i))
-       IF (ymoy<y0) THEN
-          fa(i) = tauy*(ymoy-y0 + dzoom/2.)
-          fb(i) = (ymoy-2.*y0*heavyy0m + pis2)*(y0-ymoy)
-       ELSE IF (ymoy>y0) THEN
-          fa(i) = tauy*(y0-ymoy + dzoom/2.)
-          fb(i) = (2.*y0*heavyy0-ymoy + pis2)*(ymoy-y0)
-       END IF
-
-       IF (200.*fb(i)<-fa(i)) THEN
-          fxm(i) = -1.
-       ELSE IF (200.*fb(i)<fa(i)) THEN
-          fxm(i) = 1.
-       ELSE
-          fxm(i) = tanh(fa(i)/fb(i))
-       END IF
-       IF (ymoy==y0) fxm(i) = 1.
-       IF (ymoy==y0min .OR. yt(i)==y0max) fxm(i) = -1.
-       ffdy = ffdy + fxm(i)*(yt(i)-yt(i-1))
-    END DO
-
-    beta = (grossismy*ffdy-pi)/(ffdy-pi)
-
-    IF (2. * beta - grossismy <= 0.) THEN
-       print *, 'Attention ! La valeur beta calculee dans la routine fyhyp ' &
-            // 'est mauvaise. Modifier les valeurs de grossismy, tauy ou ' &
-            // 'dzoomy et relancer.'
-       STOP 1
-    END IF
-
-    ! calcul de Ytprim 
-
-    DO i = 0, nmax2
-       ytprim(i) = beta + (grossismy-beta)*fhyp(i)
-    END DO
-
-    ! Calcul de Yf 
-
-    yf(0) = -pis2
-    DO i = 1, nmax2
-       yypr(i) = beta + (grossismy-beta)*fxm(i)
-    END DO
-
-    DO i = 1, nmax2
-       yf(i) = yf(i-1) + yypr(i)*(yt(i)-yt(i-1))
-    END DO
-
-    ! yuv = 0. si calcul des latitudes aux pts. U 
-    ! yuv = 0.5 si calcul des latitudes aux pts. V 
-
-    loop_ik: DO ik = 1, 4
-       IF (ik==1) THEN
-          yuv = 0.
-          jlat = jjm + 1
-       ELSE IF (ik==2) THEN
-          yuv = 0.5
-          jlat = jjm
-       ELSE IF (ik==3) THEN
-          yuv = 0.25
-          jlat = jjm
-       ELSE IF (ik==4) THEN
-          yuv = 0.75
-          jlat = jjm
-       END IF
-
-       yo1 = 0.
-       DO j = 1, jlat
-          yo1 = 0.
-          ylon2 = -pis2 + pisjm*(real(j) + yuv-1.)
-          yfi = ylon2
-
-          it = nmax2
-          DO while (it >= 1 .and. yfi < yf(it))
-             it = it - 1
-          END DO
-
-          yi = yt(it)
-          IF (it==nmax2) THEN
-             it = nmax2 - 1
-             yf(it + 1) = pis2
-          END IF
-
-          ! Interpolation entre yi(it) et yi(it + 1) pour avoir Y(yi)
-          ! et Y'(yi) 
-
-          CALL coefpoly(yf(it), yf(it + 1), ytprim(it), ytprim(it + 1), &
-               yt(it), yt(it + 1), a0, a1, a2, a3)
-
-          yf1 = yf(it)
-          yprimin = a1 + 2.*a2*yi + 3.*a3*yi*yi
-
-          iter = 1
-          DO
-             yi = yi - (yf1-yfi)/yprimin
-             IF (abs(yi-yo1)<=epsilon .or. iter == 300) exit
-             yo1 = yi
-             yi2 = yi*yi
-             yf1 = a0 + a1*yi + a2*yi2 + a3*yi2*yi
-             yprimin = a1 + 2.*a2*yi + 3.*a3*yi2
-          END DO
-          if (abs(yi-yo1) > epsilon) then
-             print *, 'Pas de solution.', j, ylon2
-             STOP 1
-          end if
-
-          yprimin = a1 + 2.*a2*yi + 3.*a3*yi*yi
-          yprim(j) = pi/(jjm*yprimin)
-          yvrai(j) = yi
-       END DO
-
-       DO j = 1, jlat - 1
-          IF (yvrai(j + 1)<yvrai(j)) THEN
-             print *, 'Problème avec rlat(', j + 1, ') plus petit que rlat(', &
-                  j, ')'
-             STOP 1
-          END IF
-       END DO
-
-       print *, 'Reorganisation des latitudes pour avoir entre - pi/2 et pi/2'
-
-       IF (ik==1) THEN
-          ypn = pis2
-          DO j = jjm + 1, 1, -1
-             IF (yvrai(j)<=ypn) exit
-          END DO
-
-          jpn = j
-          y00 = yvrai(jpn)
-          deply = pis2 - y00
-       END IF
-
-       DO j = 1, jjm + 1 - jpn
-          ylatt(j) = -pis2 - y00 + yvrai(jpn + j-1)
-          yprimm(j) = yprim(jpn + j-1)
-       END DO
-
-       jjpn = jpn
-       IF (jlat==jjm) jjpn = jpn - 1
-
-       DO j = 1, jjpn
-          ylatt(j + jjm + 1-jpn) = yvrai(j) + deply
-          yprimm(j + jjm + 1-jpn) = yprim(j)
-       END DO
-
-       ! Fin de la reorganisation
-
-       DO j = 1, jlat
-          ylat(j) = ylatt(jlat + 1-j)
-          yprim(j) = yprimm(jlat + 1-j)
-       END DO
-
-       DO j = 1, jlat
-          yvrai(j) = ylat(j)*180./pi
-       END DO
-
-       IF (ik==1) THEN
-          DO j = 1, jjm + 1
-             rlatu(j) = ylat(j)
-             yyprimu(j) = yprim(j)
-          END DO
-       ELSE IF (ik==2) THEN
-          DO j = 1, jjm
-             rlatv(j) = ylat(j)
-          END DO
-       ELSE IF (ik==3) THEN
-          DO j = 1, jjm
-             rlatu2(j) = ylat(j)
-             yprimu2(j) = yprim(j)
-          END DO
-       ELSE IF (ik==4) THEN
-          DO j = 1, jjm
-             rlatu1(j) = ylat(j)
-             yprimu1(j) = yprim(j)
-          END DO
-       END IF
-    END DO loop_ik
-
-    DO j = 1, jjm
-       ylat(j) = rlatu(j) - rlatu(j + 1)
-    END DO
-    champmin = 1e12
-    champmax = -1e12
-    DO j = 1, jjm
-       champmin = min(champmin, ylat(j))
-       champmax = max(champmax, ylat(j))
-    END DO
-    champmin = champmin*180./pi
-    champmax = champmax*180./pi
-
-    DO j = 1, jjm
-       IF (rlatu1(j) <= rlatu2(j)) THEN
-          print *, 'Attention ! rlatu1 < rlatu2 ', rlatu1(j), rlatu2(j), j
-          STOP 13
-       ENDIF
-
-       IF (rlatu2(j) <= rlatu(j+1)) THEN
-          print *, 'Attention ! rlatu2 < rlatup1 ', rlatu2(j), rlatu(j+1), j
-          STOP 14
-       ENDIF
-
-       IF (rlatu(j) <= rlatu1(j)) THEN
-          print *, ' Attention ! rlatu < rlatu1 ', rlatu(j), rlatu1(j), j
-          STOP 15
-       ENDIF
-
-       IF (rlatv(j) <= rlatu2(j)) THEN
-          print *, ' Attention ! rlatv < rlatu2 ', rlatv(j), rlatu2(j), j
-          STOP 16
-       ENDIF
-
-       IF (rlatv(j) >= rlatu1(j)) THEN
-          print *, ' Attention ! rlatv > rlatu1 ', rlatv(j), rlatu1(j), j
-          STOP 17
-       ENDIF
-
-       IF (rlatv(j) >= rlatu(j)) THEN
-          print *, ' Attention ! rlatv > rlatu ', rlatv(j), rlatu(j), j
-          STOP 18
-       ENDIF
-    ENDDO
-
-    print *, 'Latitudes'
-    print 3, champmin, champmax
-
-3   Format(1x, ' Au centre du zoom, la longueur de la maille est', &
-         ' d environ ', f0.2, ' degres ', /, &
-         ' alors que la maille en dehors de la zone du zoom est ', &
-         "d'environ ", f0.2, ' degres ')
-
-  END SUBROUTINE fyhyp
-
-end module fyhyp_m
Index: /LMDZ6/trunk/libf/dyn3d_common/fyhyp_m.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d_common/fyhyp_m.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3d_common/fyhyp_m.f90	(revision 5268)
@@ -0,0 +1,340 @@
+module fyhyp_m
+
+  IMPLICIT NONE
+
+contains
+
+  SUBROUTINE fyhyp(rlatu, yyprimu, rlatv, rlatu2, yprimu2, rlatu1, yprimu1)
+
+    ! From LMDZ4/libf/dyn3d/fyhyp.F, version 1.2, 2005/06/03 09:11:32
+
+    ! Author: P. Le Van, from analysis by R. Sadourny 
+
+    ! Calcule les latitudes et dérivées dans la grille du GCM pour une
+    ! fonction f(y) à dérivée tangente hyperbolique.
+
+    ! Il vaut mieux avoir : grossismy * dzoom < pi / 2
+
+    use coefpoly_m, only: coefpoly
+    use nrtype, only: k8
+    use serre_mod, only: clat, grossismy, dzoomy, tauy
+
+    include "dimensions.h"
+    ! for jjm
+
+    REAL, intent(out):: rlatu(jjm + 1), yyprimu(jjm + 1)
+    REAL, intent(out):: rlatv(jjm)
+    real, intent(out):: rlatu2(jjm), yprimu2(jjm), rlatu1(jjm), yprimu1(jjm)
+
+    ! Local: 
+
+    REAL(K8) champmin, champmax
+    INTEGER, PARAMETER:: nmax=30000, nmax2=2*nmax
+    REAL dzoom ! distance totale de la zone du zoom (en radians)
+    REAL(K8) ylat(jjm + 1), yprim(jjm + 1)
+    REAL(K8) yuv
+    REAL(K8), save:: yt(0:nmax2)
+    REAL(K8) fhyp(0:nmax2), beta
+    REAL(K8), save:: ytprim(0:nmax2)
+    REAL(K8) fxm(0:nmax2)
+    REAL(K8), save:: yf(0:nmax2)
+    REAL(K8) yypr(0:nmax2)
+    REAL(K8) yvrai(jjm + 1), yprimm(jjm + 1), ylatt(jjm + 1)
+    REAL(K8) pi, pis2, epsilon, y0, pisjm
+    REAL(K8) yo1, yi, ylon2, ymoy, yprimin
+    REAL(K8) yfi, yf1, ffdy
+    REAL(K8) ypn, deply, y00
+    SAVE y00, deply
+
+    INTEGER i, j, it, ik, iter, jlat
+    INTEGER jpn, jjpn
+    SAVE jpn
+    REAL(K8) a0, a1, a2, a3, yi2, heavyy0, heavyy0m
+    REAL(K8) fa(0:nmax2), fb(0:nmax2)
+    REAL y0min, y0max
+
+    REAL(K8) heavyside
+
+    !-------------------------------------------------------------------
+
+    print *, "Call sequence information: fyhyp"
+
+    pi = 2.*asin(1.)
+    pis2 = pi/2.
+    pisjm = pi/real(jjm)
+    epsilon = 1e-3
+    y0 = clat*pi/180.
+    dzoom = dzoomy*pi
+    print *, 'yzoom(rad), grossismy, tauy, dzoom (rad):'
+    print *, y0, grossismy, tauy, dzoom
+
+    DO i = 0, nmax2
+       yt(i) = -pis2 + real(i)*pi/nmax2
+    END DO
+
+    heavyy0m = heavyside(-y0)
+    heavyy0 = heavyside(y0)
+    y0min = 2.*y0*heavyy0m - pis2
+    y0max = 2.*y0*heavyy0 + pis2
+
+    fa = 999.999
+    fb = 999.999
+
+    DO i = 0, nmax2
+       IF (yt(i)<y0) THEN
+          fa(i) = tauy*(yt(i)-y0 + dzoom/2.)
+          fb(i) = (yt(i)-2.*y0*heavyy0m + pis2)*(y0-yt(i))
+       ELSE IF (yt(i)>y0) THEN
+          fa(i) = tauy*(y0-yt(i) + dzoom/2.)
+          fb(i) = (2.*y0*heavyy0-yt(i) + pis2)*(yt(i)-y0)
+       END IF
+
+       IF (200.*fb(i)<-fa(i)) THEN
+          fhyp(i) = -1.
+       ELSE IF (200.*fb(i)<fa(i)) THEN
+          fhyp(i) = 1.
+       ELSE
+          fhyp(i) = tanh(fa(i)/fb(i))
+       END IF
+
+       IF (yt(i)==y0) fhyp(i) = 1.
+       IF (yt(i)==y0min .OR. yt(i)==y0max) fhyp(i) = -1.
+    END DO
+
+    ! Calcul de beta 
+
+    ffdy = 0.
+
+    DO i = 1, nmax2
+       ymoy = 0.5*(yt(i-1) + yt(i))
+       IF (ymoy<y0) THEN
+          fa(i) = tauy*(ymoy-y0 + dzoom/2.)
+          fb(i) = (ymoy-2.*y0*heavyy0m + pis2)*(y0-ymoy)
+       ELSE IF (ymoy>y0) THEN
+          fa(i) = tauy*(y0-ymoy + dzoom/2.)
+          fb(i) = (2.*y0*heavyy0-ymoy + pis2)*(ymoy-y0)
+       END IF
+
+       IF (200.*fb(i)<-fa(i)) THEN
+          fxm(i) = -1.
+       ELSE IF (200.*fb(i)<fa(i)) THEN
+          fxm(i) = 1.
+       ELSE
+          fxm(i) = tanh(fa(i)/fb(i))
+       END IF
+       IF (ymoy==y0) fxm(i) = 1.
+       IF (ymoy==y0min .OR. yt(i)==y0max) fxm(i) = -1.
+       ffdy = ffdy + fxm(i)*(yt(i)-yt(i-1))
+    END DO
+
+    beta = (grossismy*ffdy-pi)/(ffdy-pi)
+
+    IF (2. * beta - grossismy <= 0.) THEN
+       print *, 'Attention ! La valeur beta calculee dans la routine fyhyp ' &
+            // 'est mauvaise. Modifier les valeurs de grossismy, tauy ou ' &
+            // 'dzoomy et relancer.'
+       STOP 1
+    END IF
+
+    ! calcul de Ytprim 
+
+    DO i = 0, nmax2
+       ytprim(i) = beta + (grossismy-beta)*fhyp(i)
+    END DO
+
+    ! Calcul de Yf 
+
+    yf(0) = -pis2
+    DO i = 1, nmax2
+       yypr(i) = beta + (grossismy-beta)*fxm(i)
+    END DO
+
+    DO i = 1, nmax2
+       yf(i) = yf(i-1) + yypr(i)*(yt(i)-yt(i-1))
+    END DO
+
+    ! yuv = 0. si calcul des latitudes aux pts. U 
+    ! yuv = 0.5 si calcul des latitudes aux pts. V 
+
+    loop_ik: DO ik = 1, 4
+       IF (ik==1) THEN
+          yuv = 0.
+          jlat = jjm + 1
+       ELSE IF (ik==2) THEN
+          yuv = 0.5
+          jlat = jjm
+       ELSE IF (ik==3) THEN
+          yuv = 0.25
+          jlat = jjm
+       ELSE IF (ik==4) THEN
+          yuv = 0.75
+          jlat = jjm
+       END IF
+
+       yo1 = 0.
+       DO j = 1, jlat
+          yo1 = 0.
+          ylon2 = -pis2 + pisjm*(real(j) + yuv-1.)
+          yfi = ylon2
+
+          it = nmax2
+          DO while (it >= 1 .and. yfi < yf(it))
+             it = it - 1
+          END DO
+
+          yi = yt(it)
+          IF (it==nmax2) THEN
+             it = nmax2 - 1
+             yf(it + 1) = pis2
+          END IF
+
+          ! Interpolation entre yi(it) et yi(it + 1) pour avoir Y(yi)
+          ! et Y'(yi) 
+
+          CALL coefpoly(yf(it), yf(it + 1), ytprim(it), ytprim(it + 1), &
+               yt(it), yt(it + 1), a0, a1, a2, a3)
+
+          yf1 = yf(it)
+          yprimin = a1 + 2.*a2*yi + 3.*a3*yi*yi
+
+          iter = 1
+          DO
+             yi = yi - (yf1-yfi)/yprimin
+             IF (abs(yi-yo1)<=epsilon .or. iter == 300) exit
+             yo1 = yi
+             yi2 = yi*yi
+             yf1 = a0 + a1*yi + a2*yi2 + a3*yi2*yi
+             yprimin = a1 + 2.*a2*yi + 3.*a3*yi2
+          END DO
+          if (abs(yi-yo1) > epsilon) then
+             print *, 'Pas de solution.', j, ylon2
+             STOP 1
+          end if
+
+          yprimin = a1 + 2.*a2*yi + 3.*a3*yi*yi
+          yprim(j) = pi/(jjm*yprimin)
+          yvrai(j) = yi
+       END DO
+
+       DO j = 1, jlat - 1
+          IF (yvrai(j + 1)<yvrai(j)) THEN
+             print *, 'Problème avec rlat(', j + 1, ') plus petit que rlat(', &
+                  j, ')'
+             STOP 1
+          END IF
+       END DO
+
+       print *, 'Reorganisation des latitudes pour avoir entre - pi/2 et pi/2'
+
+       IF (ik==1) THEN
+          ypn = pis2
+          DO j = jjm + 1, 1, -1
+             IF (yvrai(j)<=ypn) exit
+          END DO
+
+          jpn = j
+          y00 = yvrai(jpn)
+          deply = pis2 - y00
+       END IF
+
+       DO j = 1, jjm + 1 - jpn
+          ylatt(j) = -pis2 - y00 + yvrai(jpn + j-1)
+          yprimm(j) = yprim(jpn + j-1)
+       END DO
+
+       jjpn = jpn
+       IF (jlat==jjm) jjpn = jpn - 1
+
+       DO j = 1, jjpn
+          ylatt(j + jjm + 1-jpn) = yvrai(j) + deply
+          yprimm(j + jjm + 1-jpn) = yprim(j)
+       END DO
+
+       ! Fin de la reorganisation
+
+       DO j = 1, jlat
+          ylat(j) = ylatt(jlat + 1-j)
+          yprim(j) = yprimm(jlat + 1-j)
+       END DO
+
+       DO j = 1, jlat
+          yvrai(j) = ylat(j)*180./pi
+       END DO
+
+       IF (ik==1) THEN
+          DO j = 1, jjm + 1
+             rlatu(j) = ylat(j)
+             yyprimu(j) = yprim(j)
+          END DO
+       ELSE IF (ik==2) THEN
+          DO j = 1, jjm
+             rlatv(j) = ylat(j)
+          END DO
+       ELSE IF (ik==3) THEN
+          DO j = 1, jjm
+             rlatu2(j) = ylat(j)
+             yprimu2(j) = yprim(j)
+          END DO
+       ELSE IF (ik==4) THEN
+          DO j = 1, jjm
+             rlatu1(j) = ylat(j)
+             yprimu1(j) = yprim(j)
+          END DO
+       END IF
+    END DO loop_ik
+
+    DO j = 1, jjm
+       ylat(j) = rlatu(j) - rlatu(j + 1)
+    END DO
+    champmin = 1e12
+    champmax = -1e12
+    DO j = 1, jjm
+       champmin = min(champmin, ylat(j))
+       champmax = max(champmax, ylat(j))
+    END DO
+    champmin = champmin*180./pi
+    champmax = champmax*180./pi
+
+    DO j = 1, jjm
+       IF (rlatu1(j) <= rlatu2(j)) THEN
+          print *, 'Attention ! rlatu1 < rlatu2 ', rlatu1(j), rlatu2(j), j
+          STOP 13
+       ENDIF
+
+       IF (rlatu2(j) <= rlatu(j+1)) THEN
+          print *, 'Attention ! rlatu2 < rlatup1 ', rlatu2(j), rlatu(j+1), j
+          STOP 14
+       ENDIF
+
+       IF (rlatu(j) <= rlatu1(j)) THEN
+          print *, ' Attention ! rlatu < rlatu1 ', rlatu(j), rlatu1(j), j
+          STOP 15
+       ENDIF
+
+       IF (rlatv(j) <= rlatu2(j)) THEN
+          print *, ' Attention ! rlatv < rlatu2 ', rlatv(j), rlatu2(j), j
+          STOP 16
+       ENDIF
+
+       IF (rlatv(j) >= rlatu1(j)) THEN
+          print *, ' Attention ! rlatv > rlatu1 ', rlatv(j), rlatu1(j), j
+          STOP 17
+       ENDIF
+
+       IF (rlatv(j) >= rlatu(j)) THEN
+          print *, ' Attention ! rlatv > rlatu ', rlatv(j), rlatu(j), j
+          STOP 18
+       ENDIF
+    ENDDO
+
+    print *, 'Latitudes'
+    print 3, champmin, champmax
+
+3   Format(1x, ' Au centre du zoom, la longueur de la maille est', &
+         ' d environ ', f0.2, ' degres ', /, &
+         ' alors que la maille en dehors de la zone du zoom est ', &
+         "d'environ ", f0.2, ' degres ')
+
+  END SUBROUTINE fyhyp
+
+end module fyhyp_m
Index: DZ6/trunk/libf/dyn3d_common/grilles_gcm_netcdf_sub.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d_common/grilles_gcm_netcdf_sub.F90	(revision 5267)
+++ 	(revision )
@@ -1,242 +1,0 @@
-!
-! $Id: $
-!
-! This subroutine creates the grilles_gcm.nc file, containing:
-! -> longitudes and latitudes in degrees for dynamical grids u, v and scalaire,
-! and the following variables added for INCA (informative anyway)
-! -> vertical levels "presnivs"
-! -> mask (land/sea), area (grid), phis=surface geopotential height = phis/g
-!
-! The subroutine is called in dynphy_lonlat/phylmd/ce0l.F90.
-
-SUBROUTINE grilles_gcm_netcdf_sub(masque,phis)
-
-  USE comconst_mod, ONLY: cpp, kappa, g, omeg, daysec, rad, pi
-  USE comvert_mod, ONLY: presnivs, preff, pa
-  use netcdf, only: nf90_def_var, nf90_int, nf90_float, nf90_put_var
-  
-  IMPLICIT NONE
-
-  INCLUDE "dimensions.h"
-  INCLUDE "paramet.h"
-  INCLUDE "comgeom.h"
-  INCLUDE "netcdf.inc"
-
-!======================== 
-  REAL,DIMENSION(iip1,jjp1),INTENT(IN)  :: masque ! masque terre/mer
-  REAL,DIMENSION(iip1,jjp1),INTENT(IN)  :: phis   ! geopotentiel au sol
-
-  INTEGER status,i,j
-  
-  ! Attributs netcdf output
-  INTEGER ncid_out,rcode_out
-  
-  INTEGER out_lonuid,out_lonvid,out_latuid,out_latvid
-  INTEGER out_uid,out_vid,out_tempid
-  INTEGER out_lonudim,out_lonvdim
-  INTEGER out_latudim,out_latvdim,out_dim(2)
-  INTEGER out_levdim
-  !
-  INTEGER :: presnivs_id
-  INTEGER :: mask_id,area_id,phis_id
-  !
-  INTEGER start(2),COUNT(2)
-
-  ! Variables
-  REAL rlatudeg(jjp1),rlatvdeg(jjm),rlev(llm)
-  REAL rlonudeg(iip1),rlonvdeg(iip1)
-  REAL uwnd(iip1,jjp1),vwnd(iip1,jjm),temp(iip1,jjp1) 
-  !
-  INTEGER masque_int(iip1,jjp1)
-  REAL :: phis_loc(iip1,jjp1)
-  
-  !======================== 
-  ! CALCULATION of latu, latv, lonu, lonv in deg.
-  ! ---------------------------------------------------
-  rad = 6400000
-  omeg = 7.272205e-05
-  g = 9.8
-  kappa = 0.285716
-  daysec = 86400
-  cpp = 1004.70885
-
-  preff = 101325.
-  pa= 50000.
-
-  CALL conf_gcm( 99, .TRUE. )
-  CALL iniconst
-  CALL inigeom
-
-  DO j=1,jjp1
-     rlatudeg(j)=rlatu(j)*180./pi
-  ENDDO
-  
-  DO j=1,jjm
-     rlatvdeg(j)=rlatv(j)*180./pi
-  ENDDO
-
-  DO i=1,iip1
-     rlonudeg(i)=rlonu(i)*180./pi + 360.
-     rlonvdeg(i)=rlonv(i)*180./pi + 360.
-  ENDDO
- 
-  ! CALCULATION of "false" variables on u, v, s grids
-  ! --------------------------------------------------- 
-   DO i=1,iip1
-     DO j=1,jjp1
-        uwnd(i,j)=MOD(i,2)+MOD(j,2)
-        temp(i,j)=MOD(i,2)+MOD(j,2)
-     ENDDO
-     DO j=1,jjm
-        vwnd(i,j)=MOD(i,2)+MOD(j,2)
-     END DO
-  ENDDO  
-
-  ! CALCULATION of local vars for presnivs, mask, sfc. geopot. height
-  ! --------------------------------------------------- 
-  rlev(:) = presnivs(:)
-  phis_loc(:,:) = phis(:,:)/g
-  masque_int(:,:) = nINT(masque(:,:))
-
-
-  ! OPEN output netcdf file
-  !-------------------------
-  status=NF_CREATE('grilles_gcm.nc',IOR(NF_CLOBBER,NF_64BIT_OFFSET),ncid_out)
-  CALL handle_err(status)
-  
-  ! DEFINE output dimensions
-  !-------------------------
-  status=NF_DEF_DIM(ncid_out,'lonu',iim+1,out_lonudim)
-  CALL handle_err(status)
-  status=NF_DEF_DIM(ncid_out,'lonv',iim+1,out_lonvdim)
-  CALL handle_err(status)
-  status=NF_DEF_DIM(ncid_out,'latu',jjm+1,out_latudim)
-  CALL handle_err(status)
-  status=NF_DEF_DIM(ncid_out,'latv',jjm,out_latvdim)
-  CALL handle_err(status)
-  !
-  status=NF_DEF_DIM(ncid_out,'lev',llm,out_levdim)
-  CALL handle_err(status)
-  
-  ! DEFINE output variables
-  !-------------------------
-  !   Longitudes on "u" dynamical grid
-  status=NF90_DEF_VAR(ncid_out,'lonu',NF90_FLOAT,out_lonudim, out_lonuid)
-  CALL handle_err(status)
-  status=NF_PUT_ATT_TEXT(ncid_out,out_lonuid,'units', 12,'degrees_east')
-  status=NF_PUT_ATT_TEXT(ncid_out,out_lonuid,'long_name',19,'Longitude on u grid')
-  !   Longitudes on "v" dynamical grid
-  status=NF90_DEF_VAR(ncid_out,'lonv',NF90_FLOAT,out_lonvdim, out_lonvid)
-  CALL handle_err(status)
-  status=NF_PUT_ATT_TEXT(ncid_out,out_lonvid,'units', 12,'degrees_east')
-  status=NF_PUT_ATT_TEXT(ncid_out,out_lonvid,'long_name', 19,'Longitude on v grid')
-  !   Latitudes on "u" dynamical grid
-  status=NF90_DEF_VAR(ncid_out,'latu',NF90_FLOAT,out_latudim, out_latuid)
-  CALL handle_err(status)
-  status=NF_PUT_ATT_TEXT(ncid_out,out_latuid,'units', 13,'degrees_north')
-  status=NF_PUT_ATT_TEXT(ncid_out,out_latuid,'long_name', 18,'Latitude on u grid')
-  !  Latitudes on "v" dynamical grid
-  status=NF90_DEF_VAR(ncid_out,'latv',NF90_FLOAT,out_latvdim, out_latvid)
-  CALL handle_err(status)
-  status=NF_PUT_ATT_TEXT(ncid_out,out_latvid,'units', 13,'degrees_north')
-  status=NF_PUT_ATT_TEXT(ncid_out,out_latvid,'long_name', 18,'Latitude on v grid')
-  !  "u" lat/lon dynamical grid
-  out_dim(1)=out_lonudim
-  out_dim(2)=out_latudim
-  status=NF90_DEF_VAR(ncid_out,'grille_u',NF90_FLOAT,out_dim, out_uid)
-  CALL handle_err(status)
-  status=NF_PUT_ATT_TEXT(ncid_out,out_uid,'units', 3,'m/s')
-  status=NF_PUT_ATT_TEXT(ncid_out,out_uid,'long_name', 21,'u-wind dynamical grid')
-  !  "v" lat/lon dynamical grid
-  out_dim(1)=out_lonvdim
-  out_dim(2)=out_latvdim
-  status=NF90_DEF_VAR(ncid_out,'grille_v',NF90_FLOAT,out_dim, out_vid)
-  CALL handle_err(status)
-  status=NF_PUT_ATT_TEXT(ncid_out,out_vid,'units', 3,'m/s')
-  status=NF_PUT_ATT_TEXT(ncid_out,out_vid,'long_name', 21,'v-wind dynamical grid')
-  !  "s" (scalar) lat/lon dynamical grid
-  out_dim(1)=out_lonvdim
-  out_dim(2)=out_latudim
-  status=NF90_DEF_VAR(ncid_out,'grille_s',NF90_FLOAT,out_dim, out_tempid)
-  CALL handle_err(status)
-  status=NF_PUT_ATT_TEXT(ncid_out,out_tempid,'units', 6,'Kelvin')
-  status=NF_PUT_ATT_TEXT(ncid_out,out_tempid,'long_name',21,'scalar dynamical grid')
-  !
-  ! for INCA :
-  ! vertical levels "presnivs"
-  status=NF90_DEF_VAR(ncid_out,'presnivs',NF90_FLOAT,out_levdim, presnivs_id)
-  CALL handle_err(status)
-  status=NF_PUT_ATT_TEXT(ncid_out,presnivs_id,'units', 2,'Pa')
-  status=NF_PUT_ATT_TEXT(ncid_out,presnivs_id,'long_name',15,'Vertical levels')
-  ! surface geopotential height: named "phis" as the sfc geopotential, is actually phis/g
-  out_dim(1)=out_lonvdim
-  out_dim(2)=out_latudim
-  status = nf90_def_var(ncid_out,'phis',NF90_FLOAT,out_dim,phis_id)
-  CALL handle_err(status)
-  status=NF_PUT_ATT_TEXT(ncid_out,phis_id,'units', 1,'m')
-  status=NF_PUT_ATT_TEXT(ncid_out,phis_id,'long_name',27,'surface geopotential height')
-  ! gridcell area
-  status = nf90_def_var(ncid_out,'aire',NF90_FLOAT,out_dim,area_id)
-  CALL handle_err(status)
-  status=NF_PUT_ATT_TEXT(ncid_out,area_id,'units', 2,'m2')
-  status=NF_PUT_ATT_TEXT(ncid_out,area_id,'long_name',13,'gridcell area')
-  ! land-sea mask (nearest integer approx)
-  status = nf90_def_var(ncid_out,'mask',NF90_INT,out_dim,mask_id)
-  CALL handle_err(status)
-  status=NF_PUT_ATT_TEXT(ncid_out,mask_id,'long_name',27,'land-sea mask (nINT approx)')
-  
-  ! END the 'define' mode in netCDF file
-  status=NF_ENDDEF(ncid_out)  
-  CALL handle_err(status)
-  
-  ! WRITE the variables
-  !-------------------------
-  ! 1D : lonu, lonv,latu,latv ; INCA : presnivs
-  status=NF90_PUT_VAR(ncid_out,out_lonuid,rlonudeg,[1],[iip1])
-  CALL handle_err(status)
-  status=NF90_PUT_VAR(ncid_out,out_lonvid,rlonvdeg,[1],[iip1])
-  CALL handle_err(status)
-  status=NF90_PUT_VAR(ncid_out,out_latuid,rlatudeg,[1],[jjp1])
-  CALL handle_err(status)
-  status=NF90_PUT_VAR(ncid_out,out_latvid,rlatvdeg,[1],[jjm])
-  CALL handle_err(status)
-  status=NF90_PUT_VAR(ncid_out,presnivs_id,rlev,[1],[llm])
-  CALL handle_err(status)
-
-  ! 2D : grille_u,grille_v,grille_s ; INCA: phis,aire,mask
-  start(:)=1 
-  COUNT(1)=iip1
-  
-  COUNT(2)=jjp1  ! for "u" and "s" grids
-  status=NF90_PUT_VAR(ncid_out,out_uid,uwnd,start, count)
-  CALL handle_err(status)
-  COUNT(2)=jjm  ! for "v" grid
-  status=NF90_PUT_VAR(ncid_out,out_vid,vwnd,start, count)
-  CALL handle_err(status) 
-  COUNT(2)=jjp1  ! as "s" grid, for all the following vars
-  status=NF90_PUT_VAR(ncid_out,out_tempid,temp,start, count)
-  CALL handle_err(status)
-  status = nf90_put_var(ncid_out, phis_id, phis_loc,start,count)
-  CALL handle_err(status) 
-  status = nf90_put_var(ncid_out, area_id, aire,start,count)
-  CALL handle_err(status) 
-  status = nf90_put_var(ncid_out, mask_id,masque_int,start,count)
-  CALL handle_err(status)
-  
-  ! CLOSE netcdf file
-  CALL ncclos(ncid_out,rcode_out)
-  write(*,*) "END grilles_gcm_netcdf_sub OK"
-
-END SUBROUTINE grilles_gcm_netcdf_sub
-
-
-SUBROUTINE handle_err(status)
-  INCLUDE "netcdf.inc"
-
-  INTEGER status
-  IF (status.NE.nf_noerr) THEN
-     PRINT *,NF_STRERROR(status)
-     CALL abort_gcm('grilles_gcm_netcdf','netcdf error',1)
-  ENDIF
-END SUBROUTINE handle_err
-
Index: /LMDZ6/trunk/libf/dyn3d_common/grilles_gcm_netcdf_sub.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d_common/grilles_gcm_netcdf_sub.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3d_common/grilles_gcm_netcdf_sub.f90	(revision 5268)
@@ -0,0 +1,242 @@
+!
+! $Id: $
+!
+! This subroutine creates the grilles_gcm.nc file, containing:
+! -> longitudes and latitudes in degrees for dynamical grids u, v and scalaire,
+! and the following variables added for INCA (informative anyway)
+! -> vertical levels "presnivs"
+! -> mask (land/sea), area (grid), phis=surface geopotential height = phis/g
+!
+! The subroutine is called in dynphy_lonlat/phylmd/ce0l.F90.
+
+SUBROUTINE grilles_gcm_netcdf_sub(masque,phis)
+
+  USE comconst_mod, ONLY: cpp, kappa, g, omeg, daysec, rad, pi
+  USE comvert_mod, ONLY: presnivs, preff, pa
+  use netcdf, only: nf90_def_var, nf90_int, nf90_float, nf90_put_var
+  
+  IMPLICIT NONE
+
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  INCLUDE "comgeom.h"
+  INCLUDE "netcdf.inc"
+
+!======================== 
+  REAL,DIMENSION(iip1,jjp1),INTENT(IN)  :: masque ! masque terre/mer
+  REAL,DIMENSION(iip1,jjp1),INTENT(IN)  :: phis   ! geopotentiel au sol
+
+  INTEGER status,i,j
+  
+  ! Attributs netcdf output
+  INTEGER ncid_out,rcode_out
+  
+  INTEGER out_lonuid,out_lonvid,out_latuid,out_latvid
+  INTEGER out_uid,out_vid,out_tempid
+  INTEGER out_lonudim,out_lonvdim
+  INTEGER out_latudim,out_latvdim,out_dim(2)
+  INTEGER out_levdim
+  !
+  INTEGER :: presnivs_id
+  INTEGER :: mask_id,area_id,phis_id
+  !
+  INTEGER start(2),COUNT(2)
+
+  ! Variables
+  REAL rlatudeg(jjp1),rlatvdeg(jjm),rlev(llm)
+  REAL rlonudeg(iip1),rlonvdeg(iip1)
+  REAL uwnd(iip1,jjp1),vwnd(iip1,jjm),temp(iip1,jjp1) 
+  !
+  INTEGER masque_int(iip1,jjp1)
+  REAL :: phis_loc(iip1,jjp1)
+  
+  !======================== 
+  ! CALCULATION of latu, latv, lonu, lonv in deg.
+  ! ---------------------------------------------------
+  rad = 6400000
+  omeg = 7.272205e-05
+  g = 9.8
+  kappa = 0.285716
+  daysec = 86400
+  cpp = 1004.70885
+
+  preff = 101325.
+  pa= 50000.
+
+  CALL conf_gcm( 99, .TRUE. )
+  CALL iniconst
+  CALL inigeom
+
+  DO j=1,jjp1
+     rlatudeg(j)=rlatu(j)*180./pi
+  ENDDO
+  
+  DO j=1,jjm
+     rlatvdeg(j)=rlatv(j)*180./pi
+  ENDDO
+
+  DO i=1,iip1
+     rlonudeg(i)=rlonu(i)*180./pi + 360.
+     rlonvdeg(i)=rlonv(i)*180./pi + 360.
+  ENDDO
+ 
+  ! CALCULATION of "false" variables on u, v, s grids
+  ! --------------------------------------------------- 
+   DO i=1,iip1
+     DO j=1,jjp1
+        uwnd(i,j)=MOD(i,2)+MOD(j,2)
+        temp(i,j)=MOD(i,2)+MOD(j,2)
+     ENDDO
+     DO j=1,jjm
+        vwnd(i,j)=MOD(i,2)+MOD(j,2)
+     END DO
+  ENDDO  
+
+  ! CALCULATION of local vars for presnivs, mask, sfc. geopot. height
+  ! --------------------------------------------------- 
+  rlev(:) = presnivs(:)
+  phis_loc(:,:) = phis(:,:)/g
+  masque_int(:,:) = nINT(masque(:,:))
+
+
+  ! OPEN output netcdf file
+  !-------------------------
+  status=NF_CREATE('grilles_gcm.nc',IOR(NF_CLOBBER,NF_64BIT_OFFSET),ncid_out)
+  CALL handle_err(status)
+  
+  ! DEFINE output dimensions
+  !-------------------------
+  status=NF_DEF_DIM(ncid_out,'lonu',iim+1,out_lonudim)
+  CALL handle_err(status)
+  status=NF_DEF_DIM(ncid_out,'lonv',iim+1,out_lonvdim)
+  CALL handle_err(status)
+  status=NF_DEF_DIM(ncid_out,'latu',jjm+1,out_latudim)
+  CALL handle_err(status)
+  status=NF_DEF_DIM(ncid_out,'latv',jjm,out_latvdim)
+  CALL handle_err(status)
+  !
+  status=NF_DEF_DIM(ncid_out,'lev',llm,out_levdim)
+  CALL handle_err(status)
+  
+  ! DEFINE output variables
+  !-------------------------
+  !   Longitudes on "u" dynamical grid
+  status=NF90_DEF_VAR(ncid_out,'lonu',NF90_FLOAT,out_lonudim, out_lonuid)
+  CALL handle_err(status)
+  status=NF_PUT_ATT_TEXT(ncid_out,out_lonuid,'units', 12,'degrees_east')
+  status=NF_PUT_ATT_TEXT(ncid_out,out_lonuid,'long_name',19,'Longitude on u grid')
+  !   Longitudes on "v" dynamical grid
+  status=NF90_DEF_VAR(ncid_out,'lonv',NF90_FLOAT,out_lonvdim, out_lonvid)
+  CALL handle_err(status)
+  status=NF_PUT_ATT_TEXT(ncid_out,out_lonvid,'units', 12,'degrees_east')
+  status=NF_PUT_ATT_TEXT(ncid_out,out_lonvid,'long_name', 19,'Longitude on v grid')
+  !   Latitudes on "u" dynamical grid
+  status=NF90_DEF_VAR(ncid_out,'latu',NF90_FLOAT,out_latudim, out_latuid)
+  CALL handle_err(status)
+  status=NF_PUT_ATT_TEXT(ncid_out,out_latuid,'units', 13,'degrees_north')
+  status=NF_PUT_ATT_TEXT(ncid_out,out_latuid,'long_name', 18,'Latitude on u grid')
+  !  Latitudes on "v" dynamical grid
+  status=NF90_DEF_VAR(ncid_out,'latv',NF90_FLOAT,out_latvdim, out_latvid)
+  CALL handle_err(status)
+  status=NF_PUT_ATT_TEXT(ncid_out,out_latvid,'units', 13,'degrees_north')
+  status=NF_PUT_ATT_TEXT(ncid_out,out_latvid,'long_name', 18,'Latitude on v grid')
+  !  "u" lat/lon dynamical grid
+  out_dim(1)=out_lonudim
+  out_dim(2)=out_latudim
+  status=NF90_DEF_VAR(ncid_out,'grille_u',NF90_FLOAT,out_dim, out_uid)
+  CALL handle_err(status)
+  status=NF_PUT_ATT_TEXT(ncid_out,out_uid,'units', 3,'m/s')
+  status=NF_PUT_ATT_TEXT(ncid_out,out_uid,'long_name', 21,'u-wind dynamical grid')
+  !  "v" lat/lon dynamical grid
+  out_dim(1)=out_lonvdim
+  out_dim(2)=out_latvdim
+  status=NF90_DEF_VAR(ncid_out,'grille_v',NF90_FLOAT,out_dim, out_vid)
+  CALL handle_err(status)
+  status=NF_PUT_ATT_TEXT(ncid_out,out_vid,'units', 3,'m/s')
+  status=NF_PUT_ATT_TEXT(ncid_out,out_vid,'long_name', 21,'v-wind dynamical grid')
+  !  "s" (scalar) lat/lon dynamical grid
+  out_dim(1)=out_lonvdim
+  out_dim(2)=out_latudim
+  status=NF90_DEF_VAR(ncid_out,'grille_s',NF90_FLOAT,out_dim, out_tempid)
+  CALL handle_err(status)
+  status=NF_PUT_ATT_TEXT(ncid_out,out_tempid,'units', 6,'Kelvin')
+  status=NF_PUT_ATT_TEXT(ncid_out,out_tempid,'long_name',21,'scalar dynamical grid')
+  !
+  ! for INCA :
+  ! vertical levels "presnivs"
+  status=NF90_DEF_VAR(ncid_out,'presnivs',NF90_FLOAT,out_levdim, presnivs_id)
+  CALL handle_err(status)
+  status=NF_PUT_ATT_TEXT(ncid_out,presnivs_id,'units', 2,'Pa')
+  status=NF_PUT_ATT_TEXT(ncid_out,presnivs_id,'long_name',15,'Vertical levels')
+  ! surface geopotential height: named "phis" as the sfc geopotential, is actually phis/g
+  out_dim(1)=out_lonvdim
+  out_dim(2)=out_latudim
+  status = nf90_def_var(ncid_out,'phis',NF90_FLOAT,out_dim,phis_id)
+  CALL handle_err(status)
+  status=NF_PUT_ATT_TEXT(ncid_out,phis_id,'units', 1,'m')
+  status=NF_PUT_ATT_TEXT(ncid_out,phis_id,'long_name',27,'surface geopotential height')
+  ! gridcell area
+  status = nf90_def_var(ncid_out,'aire',NF90_FLOAT,out_dim,area_id)
+  CALL handle_err(status)
+  status=NF_PUT_ATT_TEXT(ncid_out,area_id,'units', 2,'m2')
+  status=NF_PUT_ATT_TEXT(ncid_out,area_id,'long_name',13,'gridcell area')
+  ! land-sea mask (nearest integer approx)
+  status = nf90_def_var(ncid_out,'mask',NF90_INT,out_dim,mask_id)
+  CALL handle_err(status)
+  status=NF_PUT_ATT_TEXT(ncid_out,mask_id,'long_name',27,'land-sea mask (nINT approx)')
+  
+  ! END the 'define' mode in netCDF file
+  status=NF_ENDDEF(ncid_out)  
+  CALL handle_err(status)
+  
+  ! WRITE the variables
+  !-------------------------
+  ! 1D : lonu, lonv,latu,latv ; INCA : presnivs
+  status=NF90_PUT_VAR(ncid_out,out_lonuid,rlonudeg,[1],[iip1])
+  CALL handle_err(status)
+  status=NF90_PUT_VAR(ncid_out,out_lonvid,rlonvdeg,[1],[iip1])
+  CALL handle_err(status)
+  status=NF90_PUT_VAR(ncid_out,out_latuid,rlatudeg,[1],[jjp1])
+  CALL handle_err(status)
+  status=NF90_PUT_VAR(ncid_out,out_latvid,rlatvdeg,[1],[jjm])
+  CALL handle_err(status)
+  status=NF90_PUT_VAR(ncid_out,presnivs_id,rlev,[1],[llm])
+  CALL handle_err(status)
+
+  ! 2D : grille_u,grille_v,grille_s ; INCA: phis,aire,mask
+  start(:)=1 
+  COUNT(1)=iip1
+  
+  COUNT(2)=jjp1  ! for "u" and "s" grids
+  status=NF90_PUT_VAR(ncid_out,out_uid,uwnd,start, count)
+  CALL handle_err(status)
+  COUNT(2)=jjm  ! for "v" grid
+  status=NF90_PUT_VAR(ncid_out,out_vid,vwnd,start, count)
+  CALL handle_err(status) 
+  COUNT(2)=jjp1  ! as "s" grid, for all the following vars
+  status=NF90_PUT_VAR(ncid_out,out_tempid,temp,start, count)
+  CALL handle_err(status)
+  status = nf90_put_var(ncid_out, phis_id, phis_loc,start,count)
+  CALL handle_err(status) 
+  status = nf90_put_var(ncid_out, area_id, aire,start,count)
+  CALL handle_err(status) 
+  status = nf90_put_var(ncid_out, mask_id,masque_int,start,count)
+  CALL handle_err(status)
+  
+  ! CLOSE netcdf file
+  CALL ncclos(ncid_out,rcode_out)
+  write(*,*) "END grilles_gcm_netcdf_sub OK"
+
+END SUBROUTINE grilles_gcm_netcdf_sub
+
+
+SUBROUTINE handle_err(status)
+  INCLUDE "netcdf.inc"
+
+  INTEGER status
+  IF (status.NE.nf_noerr) THEN
+     PRINT *,NF_STRERROR(status)
+     CALL abort_gcm('grilles_gcm_netcdf','netcdf error',1)
+  ENDIF
+END SUBROUTINE handle_err
+
Index: DZ6/trunk/libf/dyn3d_common/infotrac.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d_common/infotrac.F90	(revision 5267)
+++ 	(revision )
@@ -1,425 +1,0 @@
-!$Id$
-!
-MODULE infotrac
-
-   USE       strings_mod, ONLY: msg, fmsg, maxlen, cat, dispTable, int2str, bool2str, strStack, strParse
-   USE readTracFiles_mod, ONLY: trac_type, readTracersFiles, tracers, setGeneration, itZonIso, nzone, tran0, isoZone, &
-        delPhase, niso, getKey, isot_type, processIsotopes,  isotope, maxTableWidth, iqIsoPha, nphas, ixIso, isoPhas, &
-        addPhase, iH2O, addKey, isoSelect, testTracersFiles, isoKeys, indexUpdate,  iqWIsoPha, nbIso, ntiso, isoName, isoCheck
-   USE readTracFiles_mod, ONLY: new2oldH2O, newHNO3, oldHNO3
-   IMPLICIT NONE
-
-   PRIVATE
-
-   !=== FOR TRACERS:
-   PUBLIC :: init_infotrac                                 !--- Initialization of the tracers
-   PUBLIC :: tracers, type_trac                            !--- Full tracers database, tracers type keyword
-   PUBLIC :: nqtot,   nbtr,   nqo,   nqCO2,   nqtottr      !--- Main dimensions
-   PUBLIC :: conv_flg, pbl_flg                             !--- Convection & boundary layer activation keys
-   PUBLIC :: new2oldH2O, newHNO3, oldHNO3                  !--- For backwards compatibility in dynetat0
-   PUBLIC :: addPhase, delPhase                            !--- Add/remove the phase from the name of a tracer
-
-   !=== FOR ISOTOPES: General
-   PUBLIC :: isot_type, nbIso                              !--- Derived type, full isotopes families database + nb of families
-   PUBLIC :: isoSelect, ixIso                              !--- Isotopes family selection tool + selected family index
-   !=== FOR ISOTOPES: Specific to water
-   PUBLIC :: iH2O                                          !--- Value of "ixIso" for "H2O" isotopes class
-   PUBLIC :: min_qParent, min_qMass, min_ratio             !--- Min. values for various isotopic quantities
-   !=== FOR ISOTOPES: Depending on the selected isotopes family
-   PUBLIC :: isotope                                       !--- Selected isotopes database (argument of getKey)
-   PUBLIC :: isoKeys, isoName, isoZone, isoPhas            !--- Isotopes keys & names, tagging zones names, phases
-   PUBLIC ::    niso,   ntiso,   nzone,   nphas            !--- Number of   "   "
-   PUBLIC :: itZonIso                                      !--- index "it" in "isoName(1:niso)" = f(tagging idx, isotope idx)
-   PUBLIC :: iqIsoPha                                      !--- index "iq" in "qx"              = f(isotope idx,   phase idx)
-   PUBLIC :: isoCheck                                      !--- Run isotopes checking routines
-   !=== FOR BOTH TRACERS AND ISOTOPES
-   PUBLIC :: getKey                                        !--- Get a key from "tracers" or "isotope"
-
-!=== CONVENTIONS FOR TRACERS NUMBERS:
-!  |--------------------+-----------------------+-----------------+---------------+----------------------------|
-!  | water in different |    water tagging      |  water isotopes | other tracers | additional tracers moments |
-!  | phases: H2O_[glsrb]|      isotopes         |                 |               |  for higher order schemes  |
-!  |--------------------+-----------------------+-----------------+---------------+----------------------------|
-!  |                    |                       |                 |               |                            |
-!  |<--     nqo      -->|<-- nqo*niso* nzone -->|<-- nqo*niso  -->|<--  nbtr   -->|<--        (nmom)        -->|         
-!  |                    |                                         |                                            |
-!  |                    |<-- nqo*niso*(nzone+1)  =   nqo*ntiso -->|<--    nqtottr = nbtr + nmom             -->|
-!  |                                                                              = nqtot - nqo*(ntiso+1)      |
-!  |                                                                                                           |
-!  |<--                        nqtrue  =  nbtr + nqo*(ntiso+1)                 -->|                            |
-!  |                                                                                                           |
-!  |<--                        nqtot   =  nqtrue + nmom                                                     -->|
-!  |                                                                                                           |
-!  |-----------------------------------------------------------------------------------------------------------|
-!  NOTES FOR THIS TABLE:
-!  * Used "niso", "nzone" and "ntiso" are components of "isotopes(ip)" for water (isotopes(ip)%parent == 'H2O'),
-!    since water is so far the sole tracers family, except passive CO2, removed from the main tracers table.
-!  * For water, "nqo" is equal to the more general field "isotopes(ip)%nphas".
-!  * "niso", "nzone", "ntiso", "nphas" are defined for other isotopic tracers families, if any.
-!
-!=== DERIVED TYPE EMBEDDING MOST OF THE TRACERS-RELATED QUANTITIES (LENGTH: nqtot)
-!    Each entry is accessible using "%" sign.
-!  |-------------+------------------------------------------------------+-------------+------------------------+
-!  |  entry      | Meaning                                              | Former name | Possible values        |
-!  |-------------+------------------------------------------------------+-------------+------------------------+
-!  | name        | Name (short)                                         | tname       |                        |
-!  | keys        | key/val pairs accessible with "getKey" routine       | /           |                        |
-!  | gen0Name    | Name of the 1st generation ancestor                  | /           |                        |
-!  | parent      | Name of the parent                                   | /           |                        |
-!  | longName    | Long name (with adv. scheme suffix) for outputs      | ttext       |                        |
-!  | type        | Type (so far: tracer or tag)                         | /           | tracer,tag             |
-!  | phase       | Phases list ("g"as / "l"iquid / "s"olid              |             | [g|l|s|r|b]            |
-!  |             |              "r"(cloud) / "b"lowing)                 | /           |                        |
-!  | component   | Name(s) of the merged/cumulated section(s)           | /           | coma-separated names   |
-!  | iGeneration | Generation (>=1)                                     | /           |                        |
-!  | iqParent    | Index of the parent tracer                           | iqpere      | 1:nqtot                |
-!  | iqDescen    | Indexes of the childs       (all generations)        | iqfils      | 1:nqtot                |
-!  | nqDescen    | Number of the descendants   (all generations)        | nqdesc      | 1:nqtot                |
-!  | nqChildren  | Number of childs            (1st generation only)    | nqfils      | 1:nqtot                |
-!  | iadv        | Advection scheme number                              | iadv        | 1,2,10-20(exc.15,19),30|
-!  | isAdvected  | Advected tracers flag (.TRUE. if iadv >= 0)          | /           | nqtrue  .TRUE. values  |
-!  | isInPhysics | Tracers not extracted from the main table in physics | /           | nqtottr .TRUE. values  |
-!  | iso_iGroup  | Isotopes group index in isotopes(:)                  | /           | 1:nbIso                |
-!  | iso_iName   | Isotope  name  index in isotopes(iso_iGroup)%trac(:) | iso_indnum  | 1:niso                 |
-!  | iso_iZone   | Isotope  zone  index in isotopes(iso_iGroup)%zone(:) | zone_num    | 1:nzone                |
-!  | iso_iPhas   | Isotope  phase index in isotopes(iso_iGroup)%phas(:) | phase_num   | 1:nphas                |
-!  +-------------+------------------------------------------------------+-------------+------------------------+
-!
-!=== DERIVED TYPE EMBEDDING MOST OF THE ISOTOPES-RELATED QUANTITIES (LENGTH: nbIso, NUMBER OF ISOTOPES FAMILIES)
-!    Each entry is accessible using "%" sign.
-!  |-----------------+--------------------------------------------------+--------------------+-----------------+
-!  |  entry | length | Meaning                                          |    Former name     | Possible values |
-!  |-----------------+--------------------------------------------------+--------------------+-----------------+
-!  | parent          | Parent tracer (isotopes family name)             |                    |                 |
-!  | keys   | niso   | Isotopes keys/values pairs list + number         |                    |                 |
-!  | trac   | ntiso  | Isotopes + tagging tracers list + number         | / | ntraciso       |                 |
-!  | zone   | nzone  | Geographic tagging zones   list + number         | / | ntraceurs_zone |                 |
-!  | phase  | nphas  | Phases                     list + number         |                    | [g|l|s|r|b] 1:5 |
-!  | iqIsoPha        | Index in "qx"           = f(name(1:ntiso)),phas) | iqiso              | 1:nqtot         |
-!  | itZonIso        | Index in "trac(1:ntiso)"= f(zone, name(1:niso))  | index_trac         | 1:ntiso         |
-!  +-----------------+--------------------------------------------------+--------------------+-----------------+
-
-   REAL, PARAMETER :: min_qParent = 1.e-30, min_qMass = 1.e-18, min_ratio = 1.e-16 ! MVals et CRisi
-
-   !=== DIMENSIONS OF THE TRACERS TABLES AND OTHER SCALAR VARIABLES
-   INTEGER,               SAVE :: nqtot,   &                    !--- Tracers nb in dynamics (incl. higher moments + H2O)
-                                  nbtr,    &                    !--- Tracers nb in physics  (excl. higher moments + H2O)
-                                  nqo,     &                    !--- Number of water phases
-                                  nqtottr, &                    !--- Number of tracers passed to phytrac (TO BE DELETED ?)
-                                  nqCO2                         !--- Number of tracers of CO2  (ThL)
-   CHARACTER(LEN=maxlen), SAVE :: type_trac                     !--- Keyword for tracers type(s)
-
-   !=== VARIABLES FOR INCA
-   INTEGER, DIMENSION(:), SAVE, ALLOCATABLE :: &
-                    conv_flg, pbl_flg                           !--- Convection / boundary layer activation (nbtr)
-
-CONTAINS
-
-SUBROUTINE init_infotrac
-   USE control_mod, ONLY: planet_type
-   USE lmdz_reprobus_wrappers, ONLY: Init_chem_rep_trac
-   USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_INCA, CPPKEY_REPROBUS, CPPKEY_STRATAER
-   IMPLICIT NONE
-!==============================================================================================================================
-!
-!   Auteur:  P. Le Van /L. Fairhead/F.Hourdin
-!   -------
-!
-!   Modifications:
-!   --------------
-!   05/94: F.Forget      Modif special traceur
-!   02/02: M-A Filiberti Lecture de traceur.def
-!   01/22: D. Cugnet     Nouveaux tracer.def et tracer_*.def + encapsulation (types trac_type et isot_type)
-!
-!   Objet:
-!   ------
-!   GCM LMD nouvelle grille
-!
-!==============================================================================================================================
-!   ... modification de l'integration de q ( 26/04/94 ) ....
-!------------------------------------------------------------------------------------------------------------------------------
-! Declarations:
-   INCLUDE "dimensions.h"
-   INCLUDE "iniprint.h"
-
-!------------------------------------------------------------------------------------------------------------------------------
-! Local variables
-   INTEGER, ALLOCATABLE :: hadv(:), vadv(:)                          !--- Horizontal/vertical transport scheme number
-   INTEGER, ALLOCATABLE :: had (:), hadv_inca(:), conv_flg_inca(:), &!--- Variables specific to INCA
-                           vad (:), vadv_inca(:),  pbl_flg_inca(:)
-   CHARACTER(LEN=8), ALLOCATABLE :: solsym_inca(:)                   !--- Tracers names for INCA
-   INTEGER :: nqINCA
-   CHARACTER(LEN=2)      ::   suff(9)                                !--- Suffixes for schemes of order 3 or 4 (Prather)
-   CHARACTER(LEN=3)      :: descrq(30)                               !--- Advection scheme description tags
-   CHARACTER(LEN=maxlen) :: msg1, texp, ttp                          !--- Strings for messages and expanded tracers type
-   INTEGER :: fType                                                  !--- Tracers description file type ; 0: none
-                                                                     !--- 1/2/3: "traceur.def"/"tracer.def"/"tracer_*.def"
-   INTEGER :: nqtrue                                                 !--- Tracers nb from tracer.def (no higher order moments)
-   INTEGER :: iad                                                    !--- Advection scheme number
-   INTEGER :: iq, jq, nt, im, nm                                     !--- Indexes and temporary variables
-   LOGICAL :: lerr, ll
-   TYPE(trac_type), ALLOCATABLE, TARGET :: ttr(:)
-   TYPE(trac_type), POINTER             :: t1, t(:)
-   CHARACTER(LEN=maxlen),   ALLOCATABLE :: types_trac(:)             !--- Keywords for tracers type(s), parsed version
-   CHARACTER(LEN=*), PARAMETER :: modname="init_infotrac"
-!------------------------------------------------------------------------------------------------------------------------------
-! Initialization :
-!------------------------------------------------------------------------------------------------------------------------------
-   suff          = ['x ','y ','z ','xx','xy','xz','yy','yz','zz']
-   descrq( 1:30) =  '   '
-   descrq( 1: 2) = ['LMV','BAK']
-   descrq(10:20) = ['VL1','VLP','FH1','FH2','VLH','   ','PPM','PPS','PPP','   ','SLP']
-   descrq(30)    =  'PRA'
-
-   lerr=strParse(type_trac, '|', types_trac, n=nt)
-   IF (nt .GT. 1) THEN
-      IF (nt .GT. 2) CALL abort_gcm(modname, 'you need to modify type_trac, this version is not supported by lmdz', 1)
-      IF (nt .EQ. 2) type_trac=types_trac(2)
-   ENDIF
-
-   CALL msg('type_trac = "'//TRIM(type_trac)//'"', modname)
-
-   
-   !--- MESSAGE ABOUT THE CHOSEN CONFIGURATION
-   msg1 = 'For type_trac = "'//TRIM(type_trac)//'":'
-   SELECT CASE(type_trac)
-      CASE('inca'); CALL msg(TRIM(msg1)//' coupling with INCA chemistry model',        modname)
-      CASE('inco'); CALL msg(TRIM(msg1)//' coupling jointly with INCA and CO2 cycle',  modname)
-      CASE('repr'); CALL msg(TRIM(msg1)//' coupling with REPROBUS chemistry model',    modname)
-      CASE('co2i'); CALL msg(TRIM(msg1)//' you have chosen to run with CO2 cycle',     modname)
-      CASE('coag'); CALL msg(TRIM(msg1)//' tracers are treated for COAGULATION tests', modname)
-      CASE('lmdz'); CALL msg(TRIM(msg1)//' tracers are treated in LMDZ only',          modname)
-      CASE DEFAULT; CALL abort_gcm(modname,'type_trac='//TRIM(type_trac)//' not possible yet.',1)
-   END SELECT
-
-   !--- COHERENCE TEST BETWEEN "type_trac" AND PREPROCESSING KEYS
-   SELECT CASE(type_trac)
-      CASE('inca', 'inco')
-IF (.NOT. CPPKEY_INCA) THEN
-         CALL abort_gcm(modname, 'You must add cpp key INCA and compile with INCA code', 1)
-END IF
-      CASE('repr')
-IF (.NOT. CPPKEY_REPROBUS) THEN
-         CALL abort_gcm(modname, 'You must add cpp key REPROBUS and compile with REPROBUS code', 1)
-END IF
-      CASE('coag')
-IF (.NOT. CPPKEY_STRATAER) THEN
-         CALL abort_gcm(modname, 'You must add cpp key StratAer and compile with StratAer code', 1)
-END IF
-   END SELECT
-
-   nqCO2 = COUNT( [type_trac == 'inco', type_trac == 'co2i'] )
-
-!==============================================================================================================================
-! 0) DETERMINE THE TYPE OF THE INPUT TRACERS DESCRIPTION FILE AND READ IT
-!==============================================================================================================================
-   texp = type_trac                                                            !=== EXPANDED (WITH "|" SEPARATOR) "type_trac"
-   IF(texp == 'inco') texp = 'co2i|inca'
-   IF(texp /= 'lmdz') texp = 'lmdz|'//TRIM(texp)
-   IF(testTracersFiles(modname, texp, fType, .TRUE.)) CALL abort_gcm(modname, 'problem with tracers file(s)',1)
-   ttp = type_trac; IF(fType /= 1) ttp = texp
-   IF(readTracersFiles(ttp, lRepr=type_trac=='repr')) CALL abort_gcm(modname, 'problem with tracers file(s)',1)
-
-!==============================================================================================================================
-! 1) Get various numbers: "nqtrue" (first order only tracers), "nqo" (water phases), 'nbtr' (tracers passed to physics), etc.
-!==============================================================================================================================
-   !---------------------------------------------------------------------------------------------------------------------------
-   IF(fType == 0) CALL abort_gcm(modname, 'Missing "traceur.def", "tracer.def" or "tracer_<keyword>.def tracers file.',1)
-   !---------------------------------------------------------------------------------------------------------------------------
-   IF(fType == 1 .AND. ANY(['inca', 'inco'] == type_trac)) THEN      !=== FOUND OLD STYLE INCA "traceur.def"
-   !---------------------------------------------------------------------------------------------------------------------------
-IF (CPPKEY_INCA) THEN
-      nqo = SIZE(tracers) - nqCO2
-      CALL Init_chem_inca_trac(nqINCA)                               !--- Get nqINCA from INCA
-      nbtr = nqINCA + nqCO2                                          !--- Number of tracers passed to phytrac
-      nqtrue = nbtr + nqo                                            !--- Total number of "true" tracers
-      IF(ALL([2,3] /= nqo)) CALL abort_gcm(modname, 'Only 2 or 3 water phases allowed ; found nqo='//TRIM(int2str(nqo)), 1)
-      ALLOCATE(hadv(nqtrue), hadv_inca(nqINCA), conv_flg_inca(nqINCA), solsym_inca(nqINCA))
-      ALLOCATE(vadv(nqtrue), vadv_inca(nqINCA),  pbl_flg_inca(nqINCA))
-      CALL init_transport(solsym_inca, conv_flg_inca, pbl_flg_inca, hadv_inca, vadv_inca)
-      ALLOCATE(ttr(nqtrue))
-      ttr(1:nqo+nqCO2)                  = tracers
-      ttr(1    :      nqo   )%component = 'lmdz'
-      ttr(1+nqo:nqCO2+nqo   )%component = 'co2i'
-      ttr(1+nqo+nqCO2:nqtrue)%component = 'inca'
-      ttr(1+nqo      :nqtrue)%name      = [('CO2     ', iq=1, nqCO2), solsym_inca]
-      ttr(1+nqo+nqCO2:nqtrue)%parent    = tran0
-      ttr(1+nqo+nqCO2:nqtrue)%phase     = 'g'
-      lerr = getKey('hadv', had, ky=tracers(:)%keys)
-      lerr = getKey('vadv', vad, ky=tracers(:)%keys)
-      hadv(1:nqo+nqCO2) = had(:); hadv(1+nqo+nqCO2:nqtrue) = hadv_inca
-      vadv(1:nqo+nqCO2) = vad(:); vadv(1+nqo+nqCO2:nqtrue) = vadv_inca
-      CALL MOVE_ALLOC(FROM=ttr, TO=tracers)
-      DO iq = 1, nqtrue
-         t1 => tracers(iq)
-         CALL addKey('name',      t1%name,      t1%keys)
-         CALL addKey('component', t1%component, t1%keys)
-         CALL addKey('parent',    t1%parent,    t1%keys)
-         CALL addKey('phase',     t1%phase,     t1%keys)
-      END DO
-      IF(setGeneration(tracers)) CALL abort_gcm(modname,'See above',1) !- SET FIELDS %iGeneration, %gen0Name
-      DEALLOCATE(had, hadv_inca, vad, vadv_inca, conv_flg_inca, pbl_flg_inca, solsym_inca)
-END IF
-   !---------------------------------------------------------------------------------------------------------------------------
-   ELSE                                                              !=== OTHER CASES (OLD OR NEW FORMAT, NO INCA MODULE)
-   !---------------------------------------------------------------------------------------------------------------------------
-   nqtrue = SIZE(tracers)                                                                               !--- "true" tracers
-   nqo    =      COUNT(tracers(:)%component == 'lmdz' .AND. delPhase(tracers(:)%name)     == 'H2O')     !--- Water phases
-   nbtr = nqtrue-COUNT(tracers(:)%component == 'lmdz' .AND. delPhase(tracers(:)%gen0Name) == 'H2O')     !--- Passed to phytrac
-   nqCO2  =      COUNT( [type_trac == 'inco', type_trac == 'co2i'] )
-IF (CPPKEY_INCA) THEN
-   nqINCA =      COUNT(tracers(:)%component == 'inca')
-END IF
-   IF(getKey('hadv', hadv, ky=tracers(:)%keys)) CALL abort_gcm(modname, 'missing key "hadv"', 1)
-   IF(getKey('vadv', vadv, ky=tracers(:)%keys)) CALL abort_gcm(modname, 'missing key "vadv"', 1)
-   !---------------------------------------------------------------------------------------------------------------------------
-   END IF
-   !---------------------------------------------------------------------------------------------------------------------------
-
-IF (CPPKEY_REPROBUS) THEN
-   CALL Init_chem_rep_trac(nbtr, nqo, tracers(:)%name)
-END IF
-
-!==============================================================================================================================
-! 2) Calculate nqtot, number of tracers needed (greater if advection schemes 20 or 30 have been chosen).
-!==============================================================================================================================
-   DO iq = 1, nqtrue
-      IF( hadv(iq)<20 .OR. (ANY(hadv(iq)==[20,30]) .AND. hadv(iq)==vadv(iq)) ) CYCLE
-      WRITE(msg1,'("The choice hadv=",i0,", vadv=",i0,a)')hadv(iq),vadv(iq),' for "'//TRIM(tracers(iq)%name)//'" is not available'
-      CALL abort_gcm(modname, TRIM(msg1), 1)
-   END DO
-   nqtot =    COUNT( hadv< 20 .AND. vadv< 20 ) &                     !--- No additional tracer
-         +  4*COUNT( hadv==20 .AND. vadv==20 ) &                     !--- 3  additional tracers
-         + 10*COUNT( hadv==30 .AND. vadv==30 )                       !--- 9  additional tracers
-
-   !--- More tracers due to the choice of advection scheme => assign total number of tracers
-   IF( nqtot /= nqtrue ) THEN
-      CALL msg('The choice of advection scheme for one or more tracers makes it necessary to add tracers')
-      CALL msg('The number of true tracers is '//TRIM(int2str(nqtrue)))
-      CALL msg('The total number of tracers needed is '//TRIM(int2str(nqtot)))
-   END IF
-
-!==============================================================================================================================
-! 3) Determine the advection scheme choice for water and tracers "iadv" and the fields long name, isAdvected.
-!     iadv = 1    "LMDZ-specific humidity transport" (for H2O vapour)          LMV
-!     iadv = 2    backward                           (for H2O liquid)          BAK
-!     iadv = 14   Van-Leer + specific humidity, modified by Francis Codron     VLH
-!     iadv = 10   Van-Leer (chosen for vapour and liquid water)                VL1
-!     iadv = 11   Van-Leer for hadv and PPM version (Monotonic) for vadv       VLP
-!     iadv = 12   Frederic Hourdin I                                           FH1
-!     iadv = 13   Frederic Hourdin II                                          FH2
-!     iadv = 16   Monotonic         PPM (Collela & Woodward 1984)              PPM
-!     iadv = 17   Semi-monotonic    PPM (overshoots allowed)                   PPS
-!     iadv = 18   Definite positive PPM (overshoots and undershoots allowed)   PPP
-!     iadv = 20   Slopes                                                       SLP
-!     iadv = 30   Prather                                                      PRA
-!
-!        In array q(ij,l,iq) : iq = 1/2[/3]    for vapour/liquid[/ice] water
-!        And optionaly:        iq = 3[4],nqtot for other tracers
-!==============================================================================================================================
-   ALLOCATE(ttr(nqtot))
-   jq = nqtrue+1; tracers(:)%iadv = -1
-   DO iq = 1, nqtrue
-      t1 => tracers(iq)
-
-      !--- VERIFY THE CHOICE OF ADVECTION SCHEME
-      iad = -1
-      IF(hadv(iq)     ==    vadv(iq)    ) iad = hadv(iq)
-      IF(hadv(iq)==10 .AND. vadv(iq)==16) iad = 11
-      WRITE(msg1,'("Bad choice of advection scheme for ",a,": hadv = ",i0,", vadv = ",i0)')TRIM(t1%name), hadv(iq), vadv(iq)
-      IF(iad == -1) CALL abort_gcm(modname, msg1, 1)
-
-      !--- SET FIELDS longName, iadv, isAdvected, isInPhysics
-      t1%longName   = t1%name; IF(iad > 0) t1%longName=TRIM(t1%name)//descrq(iad)
-      t1%iadv       = iad
-      t1%isAdvected = iad >= 0
-      t1%isInPhysics= delPhase(t1%gen0Name) /= 'H2O' .OR. t1%component /= 'lmdz' !=== MORE EXCEPTIONS ? CO2i, SURSAT CLOUD H2O
-      ttr(iq)       = t1
-
-      !--- DEFINE THE HIGHER ORDER TRACERS, IF ANY
-      nm = 0
-      IF(iad == 20) nm = 3                                           !--- 2nd order scheme
-      IF(iad == 30) nm = 9                                           !--- 3rd order scheme
-      IF(nm == 0) CYCLE                                              !--- No higher moments
-      ttr(jq+1:jq+nm)             = t1
-      ttr(jq+1:jq+nm)%name        = [ (TRIM(t1%name)    //'-'//TRIM(suff(im)), im=1, nm) ]
-      ttr(jq+1:jq+nm)%gen0Name    = [ (TRIM(t1%name)    //'-'//TRIM(suff(im)), im=1, nm) ]
-      ttr(jq+1:jq+nm)%parent      = [ (TRIM(t1%parent)  //'-'//TRIM(suff(im)), im=1, nm) ]
-      ttr(jq+1:jq+nm)%longName    = [ (TRIM(t1%longName)//'-'//TRIM(suff(im)), im=1, nm) ]
-      ttr(jq+1:jq+nm)%iadv        = [ (-iad,    im=1, nm) ]
-      ttr(jq+1:jq+nm)%isAdvected  = [ (.FALSE., im=1, nm) ]
-      jq = jq + nm
-   END DO
-   DEALLOCATE(hadv, vadv)
-   CALL MOVE_ALLOC(FROM=ttr, TO=tracers)
-
-   !--- SET FIELDS iqParent, iqDescen, nqDescen, nqChildren
-   IF(indexUpdate(tracers)) CALL abort_gcm(modname, 'problem with tracers indices update', 1)
-
-   !=== TEST ADVECTION SCHEME
-   DO iq = 1, nqtot ; t1 => tracers(iq); iad = t1%iadv
-
-      !--- ONLY TESTED VALUES FOR TRACERS FOR NOW:               iadv = 14, 10 (and 0 for non-transported tracers)
-      IF(ALL([10,14,0] /= iad)) &
-         CALL abort_gcm(modname, 'Not tested for iadv='//TRIM(int2str(iad))//' ; 10 or 14 only are allowed !', 1)
-
-      !--- ONLY TESTED VALUES FOR PARENTS HAVING CHILDS FOR NOW: iadv = 14, 10 (PARENTS: TRACERS OF GENERATION 1)
-      IF(ALL([10,14] /= iad) .AND. t1%iGeneration == 1 .AND. ANY(tracers(:)%iGeneration > 1)) &
-         CALL abort_gcm(modname, 'iadv='//TRIM(int2str(iad))//' not implemented for parents ; 10 or 14 only are allowed !', 1)
-
-      !--- ONLY TESTED VALUES FOR CHILDS FOR NOW:                iadv = 10     (CHILDS:  TRACERS OF GENERATION GREATER THAN 1)
-      IF(fmsg('WARNING ! iadv='//TRIM(int2str(iad))//' not implemented for childs. Setting iadv=10 for "'//TRIM(t1%name)//'"',&
-         modname, iad /= 10 .AND. t1%iGeneration > 1)) t1%iadv = 10
-
-      !--- ONLY VALID SCHEME NUMBER FOR WATER VAPOUR:            iadv = 14
-      ll = t1%name /= addPhase('H2O','g')
-      IF(fmsg('WARNING ! iadv=14 is valid for water vapour only. Setting iadv=10 for "'//TRIM(t1%name)//'".', &
-         modname, iad == 14 .AND. ll))                 t1%iadv = 10
-   END DO
-
-   !=== READ PHYSICAL PARAMETERS FOR ISOTOPES ; DONE HERE BECAUSE dynetat0 AND iniacademic NEED "tnat" AND "alpha_ideal"
-   niso = 0; nzone = 0; nphas = nqo; ntiso = 0; isoCheck = .FALSE.
-   IF(processIsotopes()) CALL abort_gcm(modname, 'problem when processing isotopes parameters', 1)
-
-   !--- Convection / boundary layer activation for all tracers
-   ALLOCATE(conv_flg(nbtr)); conv_flg(1:nbtr) = 1
-   ALLOCATE( pbl_flg(nbtr));  pbl_flg(1:nbtr) = 1
-
-   !--- Note: nqtottr can differ from nbtr when nmom/=0
-   nqtottr = nqtot - COUNT(delPhase(tracers%gen0Name) == 'H2O' .AND. tracers%component == 'lmdz')
-   IF(COUNT(tracers%iso_iName == 0) - COUNT(delPhase(tracers%name) == 'H2O' .AND. tracers%component == 'lmdz') /= nqtottr) &
-      CALL abort_gcm(modname, 'problem with the computation of nqtottr', 1)
-
-   !=== DISPLAY THE RESULTS
-   CALL msg('nqo    = '//TRIM(int2str(nqo)),    modname)
-   CALL msg('nbtr   = '//TRIM(int2str(nbtr)),   modname)
-   CALL msg('nqtrue = '//TRIM(int2str(nqtrue)), modname)
-   CALL msg('nqtot  = '//TRIM(int2str(nqtot)),  modname)
-   CALL msg('niso   = '//TRIM(int2str(niso)),   modname)
-   CALL msg('ntiso  = '//TRIM(int2str(ntiso)),  modname)
-IF (CPPKEY_INCA) THEN
-   CALL msg('nqCO2  = '//TRIM(int2str(nqCO2)),  modname)
-   CALL msg('nqINCA = '//TRIM(int2str(nqINCA)), modname)
-END IF
-   t => tracers
-   CALL msg('Information stored in '//TRIM(modname)//': ', modname)
-   IF(dispTable('isssssssiiiiiiiii', ['iq  ', 'name', 'lNam', 'g0Nm', 'prnt', 'type', 'phas', 'comp',      &
-                              'iAdv', 'iGen', 'iqPr', 'nqDe', 'nqCh', 'iGrp', 'iNam', 'iZon', 'iPha'],     &
-      cat(t%name, t%longName, t%gen0Name, t%parent, t%type, t%phase, t%component),                         &
-      cat([(iq, iq=1, nqtot)], t%iadv, t%iGeneration, t%iqParent, t%nqDescen, t%nqChildren, t%iso_iGroup,  &
-                  t%iso_iName, t%iso_iZone, t%iso_iPhase), nColMax=maxTableWidth, nHead=2, sub=modname))   &
-      CALL abort_gcm(modname, "problem with the tracers table content", 1)
-   IF(niso > 0) THEN
-      CALL msg('Where, for isotopes family "'//TRIM(isotope%parent)//'":', modname)
-      CALL msg('  isoKeys%name = '//strStack(isoKeys%name), modname)
-      CALL msg('  isoName = '//strStack(isoName),      modname)
-      CALL msg('  isoZone = '//strStack(isoZone),      modname)
-      CALL msg('  isoPhas = '//TRIM(isoPhas),          modname)
-   ELSE
-      CALL msg('No isotopes identified.', modname)
-   END IF
-   CALL msg('end', modname)
-
-END SUBROUTINE init_infotrac
-
-END MODULE infotrac
Index: /LMDZ6/trunk/libf/dyn3d_common/infotrac.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d_common/infotrac.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3d_common/infotrac.f90	(revision 5268)
@@ -0,0 +1,425 @@
+!$Id$
+!
+MODULE infotrac
+
+   USE       strings_mod, ONLY: msg, fmsg, maxlen, cat, dispTable, int2str, bool2str, strStack, strParse
+   USE readTracFiles_mod, ONLY: trac_type, readTracersFiles, tracers, setGeneration, itZonIso, nzone, tran0, isoZone, &
+        delPhase, niso, getKey, isot_type, processIsotopes,  isotope, maxTableWidth, iqIsoPha, nphas, ixIso, isoPhas, &
+        addPhase, iH2O, addKey, isoSelect, testTracersFiles, isoKeys, indexUpdate,  iqWIsoPha, nbIso, ntiso, isoName, isoCheck
+   USE readTracFiles_mod, ONLY: new2oldH2O, newHNO3, oldHNO3
+   IMPLICIT NONE
+
+   PRIVATE
+
+   !=== FOR TRACERS:
+   PUBLIC :: init_infotrac                                 !--- Initialization of the tracers
+   PUBLIC :: tracers, type_trac                            !--- Full tracers database, tracers type keyword
+   PUBLIC :: nqtot,   nbtr,   nqo,   nqCO2,   nqtottr      !--- Main dimensions
+   PUBLIC :: conv_flg, pbl_flg                             !--- Convection & boundary layer activation keys
+   PUBLIC :: new2oldH2O, newHNO3, oldHNO3                  !--- For backwards compatibility in dynetat0
+   PUBLIC :: addPhase, delPhase                            !--- Add/remove the phase from the name of a tracer
+
+   !=== FOR ISOTOPES: General
+   PUBLIC :: isot_type, nbIso                              !--- Derived type, full isotopes families database + nb of families
+   PUBLIC :: isoSelect, ixIso                              !--- Isotopes family selection tool + selected family index
+   !=== FOR ISOTOPES: Specific to water
+   PUBLIC :: iH2O                                          !--- Value of "ixIso" for "H2O" isotopes class
+   PUBLIC :: min_qParent, min_qMass, min_ratio             !--- Min. values for various isotopic quantities
+   !=== FOR ISOTOPES: Depending on the selected isotopes family
+   PUBLIC :: isotope                                       !--- Selected isotopes database (argument of getKey)
+   PUBLIC :: isoKeys, isoName, isoZone, isoPhas            !--- Isotopes keys & names, tagging zones names, phases
+   PUBLIC ::    niso,   ntiso,   nzone,   nphas            !--- Number of   "   "
+   PUBLIC :: itZonIso                                      !--- index "it" in "isoName(1:niso)" = f(tagging idx, isotope idx)
+   PUBLIC :: iqIsoPha                                      !--- index "iq" in "qx"              = f(isotope idx,   phase idx)
+   PUBLIC :: isoCheck                                      !--- Run isotopes checking routines
+   !=== FOR BOTH TRACERS AND ISOTOPES
+   PUBLIC :: getKey                                        !--- Get a key from "tracers" or "isotope"
+
+!=== CONVENTIONS FOR TRACERS NUMBERS:
+!  |--------------------+-----------------------+-----------------+---------------+----------------------------|
+!  | water in different |    water tagging      |  water isotopes | other tracers | additional tracers moments |
+!  | phases: H2O_[glsrb]|      isotopes         |                 |               |  for higher order schemes  |
+!  |--------------------+-----------------------+-----------------+---------------+----------------------------|
+!  |                    |                       |                 |               |                            |
+!  |<--     nqo      -->|<-- nqo*niso* nzone -->|<-- nqo*niso  -->|<--  nbtr   -->|<--        (nmom)        -->|         
+!  |                    |                                         |                                            |
+!  |                    |<-- nqo*niso*(nzone+1)  =   nqo*ntiso -->|<--    nqtottr = nbtr + nmom             -->|
+!  |                                                                              = nqtot - nqo*(ntiso+1)      |
+!  |                                                                                                           |
+!  |<--                        nqtrue  =  nbtr + nqo*(ntiso+1)                 -->|                            |
+!  |                                                                                                           |
+!  |<--                        nqtot   =  nqtrue + nmom                                                     -->|
+!  |                                                                                                           |
+!  |-----------------------------------------------------------------------------------------------------------|
+!  NOTES FOR THIS TABLE:
+!  * Used "niso", "nzone" and "ntiso" are components of "isotopes(ip)" for water (isotopes(ip)%parent == 'H2O'),
+!    since water is so far the sole tracers family, except passive CO2, removed from the main tracers table.
+!  * For water, "nqo" is equal to the more general field "isotopes(ip)%nphas".
+!  * "niso", "nzone", "ntiso", "nphas" are defined for other isotopic tracers families, if any.
+!
+!=== DERIVED TYPE EMBEDDING MOST OF THE TRACERS-RELATED QUANTITIES (LENGTH: nqtot)
+!    Each entry is accessible using "%" sign.
+!  |-------------+------------------------------------------------------+-------------+------------------------+
+!  |  entry      | Meaning                                              | Former name | Possible values        |
+!  |-------------+------------------------------------------------------+-------------+------------------------+
+!  | name        | Name (short)                                         | tname       |                        |
+!  | keys        | key/val pairs accessible with "getKey" routine       | /           |                        |
+!  | gen0Name    | Name of the 1st generation ancestor                  | /           |                        |
+!  | parent      | Name of the parent                                   | /           |                        |
+!  | longName    | Long name (with adv. scheme suffix) for outputs      | ttext       |                        |
+!  | type        | Type (so far: tracer or tag)                         | /           | tracer,tag             |
+!  | phase       | Phases list ("g"as / "l"iquid / "s"olid              |             | [g|l|s|r|b]            |
+!  |             |              "r"(cloud) / "b"lowing)                 | /           |                        |
+!  | component   | Name(s) of the merged/cumulated section(s)           | /           | coma-separated names   |
+!  | iGeneration | Generation (>=1)                                     | /           |                        |
+!  | iqParent    | Index of the parent tracer                           | iqpere      | 1:nqtot                |
+!  | iqDescen    | Indexes of the childs       (all generations)        | iqfils      | 1:nqtot                |
+!  | nqDescen    | Number of the descendants   (all generations)        | nqdesc      | 1:nqtot                |
+!  | nqChildren  | Number of childs            (1st generation only)    | nqfils      | 1:nqtot                |
+!  | iadv        | Advection scheme number                              | iadv        | 1,2,10-20(exc.15,19),30|
+!  | isAdvected  | Advected tracers flag (.TRUE. if iadv >= 0)          | /           | nqtrue  .TRUE. values  |
+!  | isInPhysics | Tracers not extracted from the main table in physics | /           | nqtottr .TRUE. values  |
+!  | iso_iGroup  | Isotopes group index in isotopes(:)                  | /           | 1:nbIso                |
+!  | iso_iName   | Isotope  name  index in isotopes(iso_iGroup)%trac(:) | iso_indnum  | 1:niso                 |
+!  | iso_iZone   | Isotope  zone  index in isotopes(iso_iGroup)%zone(:) | zone_num    | 1:nzone                |
+!  | iso_iPhas   | Isotope  phase index in isotopes(iso_iGroup)%phas(:) | phase_num   | 1:nphas                |
+!  +-------------+------------------------------------------------------+-------------+------------------------+
+!
+!=== DERIVED TYPE EMBEDDING MOST OF THE ISOTOPES-RELATED QUANTITIES (LENGTH: nbIso, NUMBER OF ISOTOPES FAMILIES)
+!    Each entry is accessible using "%" sign.
+!  |-----------------+--------------------------------------------------+--------------------+-----------------+
+!  |  entry | length | Meaning                                          |    Former name     | Possible values |
+!  |-----------------+--------------------------------------------------+--------------------+-----------------+
+!  | parent          | Parent tracer (isotopes family name)             |                    |                 |
+!  | keys   | niso   | Isotopes keys/values pairs list + number         |                    |                 |
+!  | trac   | ntiso  | Isotopes + tagging tracers list + number         | / | ntraciso       |                 |
+!  | zone   | nzone  | Geographic tagging zones   list + number         | / | ntraceurs_zone |                 |
+!  | phase  | nphas  | Phases                     list + number         |                    | [g|l|s|r|b] 1:5 |
+!  | iqIsoPha        | Index in "qx"           = f(name(1:ntiso)),phas) | iqiso              | 1:nqtot         |
+!  | itZonIso        | Index in "trac(1:ntiso)"= f(zone, name(1:niso))  | index_trac         | 1:ntiso         |
+!  +-----------------+--------------------------------------------------+--------------------+-----------------+
+
+   REAL, PARAMETER :: min_qParent = 1.e-30, min_qMass = 1.e-18, min_ratio = 1.e-16 ! MVals et CRisi
+
+   !=== DIMENSIONS OF THE TRACERS TABLES AND OTHER SCALAR VARIABLES
+   INTEGER,               SAVE :: nqtot,   &                    !--- Tracers nb in dynamics (incl. higher moments + H2O)
+                                  nbtr,    &                    !--- Tracers nb in physics  (excl. higher moments + H2O)
+                                  nqo,     &                    !--- Number of water phases
+                                  nqtottr, &                    !--- Number of tracers passed to phytrac (TO BE DELETED ?)
+                                  nqCO2                         !--- Number of tracers of CO2  (ThL)
+   CHARACTER(LEN=maxlen), SAVE :: type_trac                     !--- Keyword for tracers type(s)
+
+   !=== VARIABLES FOR INCA
+   INTEGER, DIMENSION(:), SAVE, ALLOCATABLE :: &
+                    conv_flg, pbl_flg                           !--- Convection / boundary layer activation (nbtr)
+
+CONTAINS
+
+SUBROUTINE init_infotrac
+   USE control_mod, ONLY: planet_type
+   USE lmdz_reprobus_wrappers, ONLY: Init_chem_rep_trac
+   USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_INCA, CPPKEY_REPROBUS, CPPKEY_STRATAER
+   IMPLICIT NONE
+!==============================================================================================================================
+!
+!   Auteur:  P. Le Van /L. Fairhead/F.Hourdin
+!   -------
+!
+!   Modifications:
+!   --------------
+!   05/94: F.Forget      Modif special traceur
+!   02/02: M-A Filiberti Lecture de traceur.def
+!   01/22: D. Cugnet     Nouveaux tracer.def et tracer_*.def + encapsulation (types trac_type et isot_type)
+!
+!   Objet:
+!   ------
+!   GCM LMD nouvelle grille
+!
+!==============================================================================================================================
+!   ... modification de l'integration de q ( 26/04/94 ) ....
+!------------------------------------------------------------------------------------------------------------------------------
+! Declarations:
+   INCLUDE "dimensions.h"
+   INCLUDE "iniprint.h"
+
+!------------------------------------------------------------------------------------------------------------------------------
+! Local variables
+   INTEGER, ALLOCATABLE :: hadv(:), vadv(:)                          !--- Horizontal/vertical transport scheme number
+   INTEGER, ALLOCATABLE :: had (:), hadv_inca(:), conv_flg_inca(:), &!--- Variables specific to INCA
+                           vad (:), vadv_inca(:),  pbl_flg_inca(:)
+   CHARACTER(LEN=8), ALLOCATABLE :: solsym_inca(:)                   !--- Tracers names for INCA
+   INTEGER :: nqINCA
+   CHARACTER(LEN=2)      ::   suff(9)                                !--- Suffixes for schemes of order 3 or 4 (Prather)
+   CHARACTER(LEN=3)      :: descrq(30)                               !--- Advection scheme description tags
+   CHARACTER(LEN=maxlen) :: msg1, texp, ttp                          !--- Strings for messages and expanded tracers type
+   INTEGER :: fType                                                  !--- Tracers description file type ; 0: none
+                                                                     !--- 1/2/3: "traceur.def"/"tracer.def"/"tracer_*.def"
+   INTEGER :: nqtrue                                                 !--- Tracers nb from tracer.def (no higher order moments)
+   INTEGER :: iad                                                    !--- Advection scheme number
+   INTEGER :: iq, jq, nt, im, nm                                     !--- Indexes and temporary variables
+   LOGICAL :: lerr, ll
+   TYPE(trac_type), ALLOCATABLE, TARGET :: ttr(:)
+   TYPE(trac_type), POINTER             :: t1, t(:)
+   CHARACTER(LEN=maxlen),   ALLOCATABLE :: types_trac(:)             !--- Keywords for tracers type(s), parsed version
+   CHARACTER(LEN=*), PARAMETER :: modname="init_infotrac"
+!------------------------------------------------------------------------------------------------------------------------------
+! Initialization :
+!------------------------------------------------------------------------------------------------------------------------------
+   suff          = ['x ','y ','z ','xx','xy','xz','yy','yz','zz']
+   descrq( 1:30) =  '   '
+   descrq( 1: 2) = ['LMV','BAK']
+   descrq(10:20) = ['VL1','VLP','FH1','FH2','VLH','   ','PPM','PPS','PPP','   ','SLP']
+   descrq(30)    =  'PRA'
+
+   lerr=strParse(type_trac, '|', types_trac, n=nt)
+   IF (nt .GT. 1) THEN
+      IF (nt .GT. 2) CALL abort_gcm(modname, 'you need to modify type_trac, this version is not supported by lmdz', 1)
+      IF (nt .EQ. 2) type_trac=types_trac(2)
+   ENDIF
+
+   CALL msg('type_trac = "'//TRIM(type_trac)//'"', modname)
+
+   
+   !--- MESSAGE ABOUT THE CHOSEN CONFIGURATION
+   msg1 = 'For type_trac = "'//TRIM(type_trac)//'":'
+   SELECT CASE(type_trac)
+      CASE('inca'); CALL msg(TRIM(msg1)//' coupling with INCA chemistry model',        modname)
+      CASE('inco'); CALL msg(TRIM(msg1)//' coupling jointly with INCA and CO2 cycle',  modname)
+      CASE('repr'); CALL msg(TRIM(msg1)//' coupling with REPROBUS chemistry model',    modname)
+      CASE('co2i'); CALL msg(TRIM(msg1)//' you have chosen to run with CO2 cycle',     modname)
+      CASE('coag'); CALL msg(TRIM(msg1)//' tracers are treated for COAGULATION tests', modname)
+      CASE('lmdz'); CALL msg(TRIM(msg1)//' tracers are treated in LMDZ only',          modname)
+      CASE DEFAULT; CALL abort_gcm(modname,'type_trac='//TRIM(type_trac)//' not possible yet.',1)
+   END SELECT
+
+   !--- COHERENCE TEST BETWEEN "type_trac" AND PREPROCESSING KEYS
+   SELECT CASE(type_trac)
+      CASE('inca', 'inco')
+IF (.NOT. CPPKEY_INCA) THEN
+         CALL abort_gcm(modname, 'You must add cpp key INCA and compile with INCA code', 1)
+END IF
+      CASE('repr')
+IF (.NOT. CPPKEY_REPROBUS) THEN
+         CALL abort_gcm(modname, 'You must add cpp key REPROBUS and compile with REPROBUS code', 1)
+END IF
+      CASE('coag')
+IF (.NOT. CPPKEY_STRATAER) THEN
+         CALL abort_gcm(modname, 'You must add cpp key StratAer and compile with StratAer code', 1)
+END IF
+   END SELECT
+
+   nqCO2 = COUNT( [type_trac == 'inco', type_trac == 'co2i'] )
+
+!==============================================================================================================================
+! 0) DETERMINE THE TYPE OF THE INPUT TRACERS DESCRIPTION FILE AND READ IT
+!==============================================================================================================================
+   texp = type_trac                                                            !=== EXPANDED (WITH "|" SEPARATOR) "type_trac"
+   IF(texp == 'inco') texp = 'co2i|inca'
+   IF(texp /= 'lmdz') texp = 'lmdz|'//TRIM(texp)
+   IF(testTracersFiles(modname, texp, fType, .TRUE.)) CALL abort_gcm(modname, 'problem with tracers file(s)',1)
+   ttp = type_trac; IF(fType /= 1) ttp = texp
+   IF(readTracersFiles(ttp, lRepr=type_trac=='repr')) CALL abort_gcm(modname, 'problem with tracers file(s)',1)
+
+!==============================================================================================================================
+! 1) Get various numbers: "nqtrue" (first order only tracers), "nqo" (water phases), 'nbtr' (tracers passed to physics), etc.
+!==============================================================================================================================
+   !---------------------------------------------------------------------------------------------------------------------------
+   IF(fType == 0) CALL abort_gcm(modname, 'Missing "traceur.def", "tracer.def" or "tracer_<keyword>.def tracers file.',1)
+   !---------------------------------------------------------------------------------------------------------------------------
+   IF(fType == 1 .AND. ANY(['inca', 'inco'] == type_trac)) THEN      !=== FOUND OLD STYLE INCA "traceur.def"
+   !---------------------------------------------------------------------------------------------------------------------------
+IF (CPPKEY_INCA) THEN
+      nqo = SIZE(tracers) - nqCO2
+      CALL Init_chem_inca_trac(nqINCA)                               !--- Get nqINCA from INCA
+      nbtr = nqINCA + nqCO2                                          !--- Number of tracers passed to phytrac
+      nqtrue = nbtr + nqo                                            !--- Total number of "true" tracers
+      IF(ALL([2,3] /= nqo)) CALL abort_gcm(modname, 'Only 2 or 3 water phases allowed ; found nqo='//TRIM(int2str(nqo)), 1)
+      ALLOCATE(hadv(nqtrue), hadv_inca(nqINCA), conv_flg_inca(nqINCA), solsym_inca(nqINCA))
+      ALLOCATE(vadv(nqtrue), vadv_inca(nqINCA),  pbl_flg_inca(nqINCA))
+      CALL init_transport(solsym_inca, conv_flg_inca, pbl_flg_inca, hadv_inca, vadv_inca)
+      ALLOCATE(ttr(nqtrue))
+      ttr(1:nqo+nqCO2)                  = tracers
+      ttr(1    :      nqo   )%component = 'lmdz'
+      ttr(1+nqo:nqCO2+nqo   )%component = 'co2i'
+      ttr(1+nqo+nqCO2:nqtrue)%component = 'inca'
+      ttr(1+nqo      :nqtrue)%name      = [('CO2     ', iq=1, nqCO2), solsym_inca]
+      ttr(1+nqo+nqCO2:nqtrue)%parent    = tran0
+      ttr(1+nqo+nqCO2:nqtrue)%phase     = 'g'
+      lerr = getKey('hadv', had, ky=tracers(:)%keys)
+      lerr = getKey('vadv', vad, ky=tracers(:)%keys)
+      hadv(1:nqo+nqCO2) = had(:); hadv(1+nqo+nqCO2:nqtrue) = hadv_inca
+      vadv(1:nqo+nqCO2) = vad(:); vadv(1+nqo+nqCO2:nqtrue) = vadv_inca
+      CALL MOVE_ALLOC(FROM=ttr, TO=tracers)
+      DO iq = 1, nqtrue
+         t1 => tracers(iq)
+         CALL addKey('name',      t1%name,      t1%keys)
+         CALL addKey('component', t1%component, t1%keys)
+         CALL addKey('parent',    t1%parent,    t1%keys)
+         CALL addKey('phase',     t1%phase,     t1%keys)
+      END DO
+      IF(setGeneration(tracers)) CALL abort_gcm(modname,'See above',1) !- SET FIELDS %iGeneration, %gen0Name
+      DEALLOCATE(had, hadv_inca, vad, vadv_inca, conv_flg_inca, pbl_flg_inca, solsym_inca)
+END IF
+   !---------------------------------------------------------------------------------------------------------------------------
+   ELSE                                                              !=== OTHER CASES (OLD OR NEW FORMAT, NO INCA MODULE)
+   !---------------------------------------------------------------------------------------------------------------------------
+   nqtrue = SIZE(tracers)                                                                               !--- "true" tracers
+   nqo    =      COUNT(tracers(:)%component == 'lmdz' .AND. delPhase(tracers(:)%name)     == 'H2O')     !--- Water phases
+   nbtr = nqtrue-COUNT(tracers(:)%component == 'lmdz' .AND. delPhase(tracers(:)%gen0Name) == 'H2O')     !--- Passed to phytrac
+   nqCO2  =      COUNT( [type_trac == 'inco', type_trac == 'co2i'] )
+IF (CPPKEY_INCA) THEN
+   nqINCA =      COUNT(tracers(:)%component == 'inca')
+END IF
+   IF(getKey('hadv', hadv, ky=tracers(:)%keys)) CALL abort_gcm(modname, 'missing key "hadv"', 1)
+   IF(getKey('vadv', vadv, ky=tracers(:)%keys)) CALL abort_gcm(modname, 'missing key "vadv"', 1)
+   !---------------------------------------------------------------------------------------------------------------------------
+   END IF
+   !---------------------------------------------------------------------------------------------------------------------------
+
+IF (CPPKEY_REPROBUS) THEN
+   CALL Init_chem_rep_trac(nbtr, nqo, tracers(:)%name)
+END IF
+
+!==============================================================================================================================
+! 2) Calculate nqtot, number of tracers needed (greater if advection schemes 20 or 30 have been chosen).
+!==============================================================================================================================
+   DO iq = 1, nqtrue
+      IF( hadv(iq)<20 .OR. (ANY(hadv(iq)==[20,30]) .AND. hadv(iq)==vadv(iq)) ) CYCLE
+      WRITE(msg1,'("The choice hadv=",i0,", vadv=",i0,a)')hadv(iq),vadv(iq),' for "'//TRIM(tracers(iq)%name)//'" is not available'
+      CALL abort_gcm(modname, TRIM(msg1), 1)
+   END DO
+   nqtot =    COUNT( hadv< 20 .AND. vadv< 20 ) &                     !--- No additional tracer
+         +  4*COUNT( hadv==20 .AND. vadv==20 ) &                     !--- 3  additional tracers
+         + 10*COUNT( hadv==30 .AND. vadv==30 )                       !--- 9  additional tracers
+
+   !--- More tracers due to the choice of advection scheme => assign total number of tracers
+   IF( nqtot /= nqtrue ) THEN
+      CALL msg('The choice of advection scheme for one or more tracers makes it necessary to add tracers')
+      CALL msg('The number of true tracers is '//TRIM(int2str(nqtrue)))
+      CALL msg('The total number of tracers needed is '//TRIM(int2str(nqtot)))
+   END IF
+
+!==============================================================================================================================
+! 3) Determine the advection scheme choice for water and tracers "iadv" and the fields long name, isAdvected.
+!     iadv = 1    "LMDZ-specific humidity transport" (for H2O vapour)          LMV
+!     iadv = 2    backward                           (for H2O liquid)          BAK
+!     iadv = 14   Van-Leer + specific humidity, modified by Francis Codron     VLH
+!     iadv = 10   Van-Leer (chosen for vapour and liquid water)                VL1
+!     iadv = 11   Van-Leer for hadv and PPM version (Monotonic) for vadv       VLP
+!     iadv = 12   Frederic Hourdin I                                           FH1
+!     iadv = 13   Frederic Hourdin II                                          FH2
+!     iadv = 16   Monotonic         PPM (Collela & Woodward 1984)              PPM
+!     iadv = 17   Semi-monotonic    PPM (overshoots allowed)                   PPS
+!     iadv = 18   Definite positive PPM (overshoots and undershoots allowed)   PPP
+!     iadv = 20   Slopes                                                       SLP
+!     iadv = 30   Prather                                                      PRA
+!
+!        In array q(ij,l,iq) : iq = 1/2[/3]    for vapour/liquid[/ice] water
+!        And optionaly:        iq = 3[4],nqtot for other tracers
+!==============================================================================================================================
+   ALLOCATE(ttr(nqtot))
+   jq = nqtrue+1; tracers(:)%iadv = -1
+   DO iq = 1, nqtrue
+      t1 => tracers(iq)
+
+      !--- VERIFY THE CHOICE OF ADVECTION SCHEME
+      iad = -1
+      IF(hadv(iq)     ==    vadv(iq)    ) iad = hadv(iq)
+      IF(hadv(iq)==10 .AND. vadv(iq)==16) iad = 11
+      WRITE(msg1,'("Bad choice of advection scheme for ",a,": hadv = ",i0,", vadv = ",i0)')TRIM(t1%name), hadv(iq), vadv(iq)
+      IF(iad == -1) CALL abort_gcm(modname, msg1, 1)
+
+      !--- SET FIELDS longName, iadv, isAdvected, isInPhysics
+      t1%longName   = t1%name; IF(iad > 0) t1%longName=TRIM(t1%name)//descrq(iad)
+      t1%iadv       = iad
+      t1%isAdvected = iad >= 0
+      t1%isInPhysics= delPhase(t1%gen0Name) /= 'H2O' .OR. t1%component /= 'lmdz' !=== MORE EXCEPTIONS ? CO2i, SURSAT CLOUD H2O
+      ttr(iq)       = t1
+
+      !--- DEFINE THE HIGHER ORDER TRACERS, IF ANY
+      nm = 0
+      IF(iad == 20) nm = 3                                           !--- 2nd order scheme
+      IF(iad == 30) nm = 9                                           !--- 3rd order scheme
+      IF(nm == 0) CYCLE                                              !--- No higher moments
+      ttr(jq+1:jq+nm)             = t1
+      ttr(jq+1:jq+nm)%name        = [ (TRIM(t1%name)    //'-'//TRIM(suff(im)), im=1, nm) ]
+      ttr(jq+1:jq+nm)%gen0Name    = [ (TRIM(t1%name)    //'-'//TRIM(suff(im)), im=1, nm) ]
+      ttr(jq+1:jq+nm)%parent      = [ (TRIM(t1%parent)  //'-'//TRIM(suff(im)), im=1, nm) ]
+      ttr(jq+1:jq+nm)%longName    = [ (TRIM(t1%longName)//'-'//TRIM(suff(im)), im=1, nm) ]
+      ttr(jq+1:jq+nm)%iadv        = [ (-iad,    im=1, nm) ]
+      ttr(jq+1:jq+nm)%isAdvected  = [ (.FALSE., im=1, nm) ]
+      jq = jq + nm
+   END DO
+   DEALLOCATE(hadv, vadv)
+   CALL MOVE_ALLOC(FROM=ttr, TO=tracers)
+
+   !--- SET FIELDS iqParent, iqDescen, nqDescen, nqChildren
+   IF(indexUpdate(tracers)) CALL abort_gcm(modname, 'problem with tracers indices update', 1)
+
+   !=== TEST ADVECTION SCHEME
+   DO iq = 1, nqtot ; t1 => tracers(iq); iad = t1%iadv
+
+      !--- ONLY TESTED VALUES FOR TRACERS FOR NOW:               iadv = 14, 10 (and 0 for non-transported tracers)
+      IF(ALL([10,14,0] /= iad)) &
+         CALL abort_gcm(modname, 'Not tested for iadv='//TRIM(int2str(iad))//' ; 10 or 14 only are allowed !', 1)
+
+      !--- ONLY TESTED VALUES FOR PARENTS HAVING CHILDS FOR NOW: iadv = 14, 10 (PARENTS: TRACERS OF GENERATION 1)
+      IF(ALL([10,14] /= iad) .AND. t1%iGeneration == 1 .AND. ANY(tracers(:)%iGeneration > 1)) &
+         CALL abort_gcm(modname, 'iadv='//TRIM(int2str(iad))//' not implemented for parents ; 10 or 14 only are allowed !', 1)
+
+      !--- ONLY TESTED VALUES FOR CHILDS FOR NOW:                iadv = 10     (CHILDS:  TRACERS OF GENERATION GREATER THAN 1)
+      IF(fmsg('WARNING ! iadv='//TRIM(int2str(iad))//' not implemented for childs. Setting iadv=10 for "'//TRIM(t1%name)//'"',&
+         modname, iad /= 10 .AND. t1%iGeneration > 1)) t1%iadv = 10
+
+      !--- ONLY VALID SCHEME NUMBER FOR WATER VAPOUR:            iadv = 14
+      ll = t1%name /= addPhase('H2O','g')
+      IF(fmsg('WARNING ! iadv=14 is valid for water vapour only. Setting iadv=10 for "'//TRIM(t1%name)//'".', &
+         modname, iad == 14 .AND. ll))                 t1%iadv = 10
+   END DO
+
+   !=== READ PHYSICAL PARAMETERS FOR ISOTOPES ; DONE HERE BECAUSE dynetat0 AND iniacademic NEED "tnat" AND "alpha_ideal"
+   niso = 0; nzone = 0; nphas = nqo; ntiso = 0; isoCheck = .FALSE.
+   IF(processIsotopes()) CALL abort_gcm(modname, 'problem when processing isotopes parameters', 1)
+
+   !--- Convection / boundary layer activation for all tracers
+   ALLOCATE(conv_flg(nbtr)); conv_flg(1:nbtr) = 1
+   ALLOCATE( pbl_flg(nbtr));  pbl_flg(1:nbtr) = 1
+
+   !--- Note: nqtottr can differ from nbtr when nmom/=0
+   nqtottr = nqtot - COUNT(delPhase(tracers%gen0Name) == 'H2O' .AND. tracers%component == 'lmdz')
+   IF(COUNT(tracers%iso_iName == 0) - COUNT(delPhase(tracers%name) == 'H2O' .AND. tracers%component == 'lmdz') /= nqtottr) &
+      CALL abort_gcm(modname, 'problem with the computation of nqtottr', 1)
+
+   !=== DISPLAY THE RESULTS
+   CALL msg('nqo    = '//TRIM(int2str(nqo)),    modname)
+   CALL msg('nbtr   = '//TRIM(int2str(nbtr)),   modname)
+   CALL msg('nqtrue = '//TRIM(int2str(nqtrue)), modname)
+   CALL msg('nqtot  = '//TRIM(int2str(nqtot)),  modname)
+   CALL msg('niso   = '//TRIM(int2str(niso)),   modname)
+   CALL msg('ntiso  = '//TRIM(int2str(ntiso)),  modname)
+IF (CPPKEY_INCA) THEN
+   CALL msg('nqCO2  = '//TRIM(int2str(nqCO2)),  modname)
+   CALL msg('nqINCA = '//TRIM(int2str(nqINCA)), modname)
+END IF
+   t => tracers
+   CALL msg('Information stored in '//TRIM(modname)//': ', modname)
+   IF(dispTable('isssssssiiiiiiiii', ['iq  ', 'name', 'lNam', 'g0Nm', 'prnt', 'type', 'phas', 'comp',      &
+                              'iAdv', 'iGen', 'iqPr', 'nqDe', 'nqCh', 'iGrp', 'iNam', 'iZon', 'iPha'],     &
+      cat(t%name, t%longName, t%gen0Name, t%parent, t%type, t%phase, t%component),                         &
+      cat([(iq, iq=1, nqtot)], t%iadv, t%iGeneration, t%iqParent, t%nqDescen, t%nqChildren, t%iso_iGroup,  &
+                  t%iso_iName, t%iso_iZone, t%iso_iPhase), nColMax=maxTableWidth, nHead=2, sub=modname))   &
+      CALL abort_gcm(modname, "problem with the tracers table content", 1)
+   IF(niso > 0) THEN
+      CALL msg('Where, for isotopes family "'//TRIM(isotope%parent)//'":', modname)
+      CALL msg('  isoKeys%name = '//strStack(isoKeys%name), modname)
+      CALL msg('  isoName = '//strStack(isoName),      modname)
+      CALL msg('  isoZone = '//strStack(isoZone),      modname)
+      CALL msg('  isoPhas = '//TRIM(isoPhas),          modname)
+   ELSE
+      CALL msg('No isotopes identified.', modname)
+   END IF
+   CALL msg('end', modname)
+
+END SUBROUTINE init_infotrac
+
+END MODULE infotrac
Index: DZ6/trunk/libf/dyn3d_common/iniconst.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d_common/iniconst.F90	(revision 5267)
+++ 	(revision )
@@ -1,80 +1,0 @@
-!
-! $Id$
-!
-SUBROUTINE iniconst
-
-  USE control_mod
-  use IOIPSL
-
-  USE comconst_mod, ONLY: im, imp1, jm, jmp1, lllm, lllmm1, lllmp1, &
-                          unsim, pi, r, kappa, cpp, dtvr, dtphys
-  USE comvert_mod, ONLY: disvert_type, pressure_exner
-  
-  IMPLICIT NONE
-  !
-  !      P. Le Van
-  !
-  !   Declarations:
-  !   -------------
-  !
-  include "dimensions.h"
-  include "paramet.h"
-  include "iniprint.h"
-
-  character(len=*),parameter :: modname="iniconst"
-  character(len=80) :: abort_message
-  !
-  !
-  !
-  !-----------------------------------------------------------------------
-  !   dimension des boucles:
-  !   ----------------------
-
-  im      = iim
-  jm      = jjm
-  lllm    = llm
-  imp1    = iim 
-  jmp1    = jjm + 1
-  lllmm1  = llm - 1
-  lllmp1  = llm + 1
-
-  !-----------------------------------------------------------------------
-
-  dtphys  = iphysiq * dtvr
-  unsim   = 1./iim
-  pi      = 2.*ASIN( 1. )
-
-  !-----------------------------------------------------------------------
-  !
-
-  r       = cpp * kappa
-
-  write(lunout,*) trim(modname),': R  CP  Kappa ',r,cpp,kappa
-  !
-  !-----------------------------------------------------------------------
-
-  ! vertical discretization: default behavior depends on planet_type flag
-  if (planet_type=="earth") then
-     disvert_type=1
-  else
-     disvert_type=2
-  endif
-  ! but user can also specify using one or the other in run.def:
-  call getin('disvert_type',disvert_type)
-  write(lunout,*) trim(modname),': disvert_type=',disvert_type
-
-  pressure_exner = disvert_type == 1 ! default value
-  call getin('pressure_exner', pressure_exner)
-
-  if (disvert_type==1) then
-     ! standard case for Earth (automatic generation of levels)
-     call disvert()
-  else if (disvert_type==2) then
-     ! standard case for planets (levels generated using z2sig.def file)
-     call disvert_noterre
-  else
-     write(abort_message,*) "Wrong value for disvert_type: ", disvert_type
-     call abort_gcm(modname,abort_message,0)
-  endif
-
-END SUBROUTINE iniconst
Index: /LMDZ6/trunk/libf/dyn3d_common/iniconst.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d_common/iniconst.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3d_common/iniconst.f90	(revision 5268)
@@ -0,0 +1,80 @@
+!
+! $Id$
+!
+SUBROUTINE iniconst
+
+  USE control_mod
+  use IOIPSL
+
+  USE comconst_mod, ONLY: im, imp1, jm, jmp1, lllm, lllmm1, lllmp1, &
+                          unsim, pi, r, kappa, cpp, dtvr, dtphys
+  USE comvert_mod, ONLY: disvert_type, pressure_exner
+  
+  IMPLICIT NONE
+  !
+  !      P. Le Van
+  !
+  !   Declarations:
+  !   -------------
+  !
+  include "dimensions.h"
+  include "paramet.h"
+  include "iniprint.h"
+
+  character(len=*),parameter :: modname="iniconst"
+  character(len=80) :: abort_message
+  !
+  !
+  !
+  !-----------------------------------------------------------------------
+  !   dimension des boucles:
+  !   ----------------------
+
+  im      = iim
+  jm      = jjm
+  lllm    = llm
+  imp1    = iim 
+  jmp1    = jjm + 1
+  lllmm1  = llm - 1
+  lllmp1  = llm + 1
+
+  !-----------------------------------------------------------------------
+
+  dtphys  = iphysiq * dtvr
+  unsim   = 1./iim
+  pi      = 2.*ASIN( 1. )
+
+  !-----------------------------------------------------------------------
+  !
+
+  r       = cpp * kappa
+
+  write(lunout,*) trim(modname),': R  CP  Kappa ',r,cpp,kappa
+  !
+  !-----------------------------------------------------------------------
+
+  ! vertical discretization: default behavior depends on planet_type flag
+  if (planet_type=="earth") then
+     disvert_type=1
+  else
+     disvert_type=2
+  endif
+  ! but user can also specify using one or the other in run.def:
+  call getin('disvert_type',disvert_type)
+  write(lunout,*) trim(modname),': disvert_type=',disvert_type
+
+  pressure_exner = disvert_type == 1 ! default value
+  call getin('pressure_exner', pressure_exner)
+
+  if (disvert_type==1) then
+     ! standard case for Earth (automatic generation of levels)
+     call disvert()
+  else if (disvert_type==2) then
+     ! standard case for planets (levels generated using z2sig.def file)
+     call disvert_noterre
+  else
+     write(abort_message,*) "Wrong value for disvert_type: ", disvert_type
+     call abort_gcm(modname,abort_message,0)
+  endif
+
+END SUBROUTINE iniconst
Index: DZ6/trunk/libf/dyn3d_common/inidissip.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d_common/inidissip.F90	(revision 5267)
+++ 	(revision )
@@ -1,223 +1,0 @@
-!
-! $Id$
-!
-SUBROUTINE inidissip ( lstardis,nitergdiv,nitergrot,niterh  , &
-     tetagdiv,tetagrot,tetatemp, vert_prof_dissip)
-  !=======================================================================
-  !   initialisation de la dissipation horizontale
-  !=======================================================================
-  !-----------------------------------------------------------------------
-  !   declarations:
-  !   -------------
-
-  USE control_mod, only : dissip_period,iperiod
-  USE comconst_mod, ONLY: dissip_deltaz, dissip_factz, dissip_zref, &
-                          dtdiss, dtvr, rad
-  USE comvert_mod, ONLY: preff, presnivs
-
-  IMPLICIT NONE
-  include "dimensions.h"
-  include "paramet.h"
-  include "comdissipn.h"
-  include "iniprint.h"
-
-  LOGICAL,INTENT(in) :: lstardis
-  INTEGER,INTENT(in) :: nitergdiv,nitergrot,niterh
-  REAL,INTENT(in) :: tetagdiv,tetagrot,tetatemp
-
-  integer, INTENT(in):: vert_prof_dissip
-  ! Vertical profile of horizontal dissipation
-  ! Allowed values:
-  ! 0: rational fraction, function of pressure
-  ! 1: tanh of altitude
-
-! Local variables:
-  REAL fact,zvert(llm),zz
-  REAL zh(ip1jmp1),zu(ip1jmp1), gx(ip1jmp1), divgra(ip1jmp1)
-  real zv(ip1jm), gy(ip1jm), deltap(ip1jmp1,llm)
-  REAL ullm,vllm,umin,vmin,zhmin,zhmax
-  REAL zllm
-
-  INTEGER l,ij,idum,ii
-  REAL tetamin
-  REAL pseudoz
-  character (len=80) :: abort_message
-
-  REAL ran1
-
-
-  !-----------------------------------------------------------------------
-  !
-  !   calcul des valeurs propres des operateurs par methode iterrative:
-  !   -----------------------------------------------------------------
-
-  crot     = -1.
-  cdivu    = -1.
-  cdivh    = -1.
-
-  !   calcul de la valeur propre de divgrad:
-  !   --------------------------------------
-  idum = 0
-  DO l = 1, llm
-     DO ij = 1, ip1jmp1
-        deltap(ij,l) = 1.
-     ENDDO
-  ENDDO
-
-  idum  = -1
-  zh(1) = RAN1(idum)-.5
-  idum  = 0
-  DO ij = 2, ip1jmp1
-     zh(ij) = RAN1(idum) -.5
-  ENDDO
-
-  CALL filtreg (zh,jjp1,1,2,1,.TRUE.,1)
-
-  CALL minmax(iip1*jjp1,zh,zhmin,zhmax )
-
-  IF ( zhmin .GE. zhmax  )     THEN
-     write(lunout,*)'  Inidissip  zh min max  ',zhmin,zhmax
-     abort_message='probleme generateur alleatoire dans inidissip'
-     call abort_gcm('inidissip',abort_message,1)
-  ENDIF
-
-  zllm = ABS( zhmax )
-  DO l = 1,50
-     IF(lstardis) THEN
-        CALL divgrad2(1,zh,deltap,niterh,divgra)
-     ELSE
-        CALL divgrad (1,zh,niterh,divgra)
-     ENDIF
-
-     zllm  = ABS(maxval(divgra))
-     zh = divgra / zllm
-  ENDDO
-
-  IF(lstardis) THEN
-     cdivh = 1./ zllm
-  ELSE
-     cdivh = zllm ** ( -1./niterh )
-  ENDIF
-
-  !   calcul des valeurs propres de gradiv (ii =1) et  nxgrarot(ii=2)
-  !   -----------------------------------------------------------------
-  write(lunout,*)'inidissip: calcul des valeurs propres'
-
-  DO    ii = 1, 2
-     !
-     DO ij = 1, ip1jmp1
-        zu(ij)  = RAN1(idum) -.5
-     ENDDO
-     CALL filtreg (zu,jjp1,1,2,1,.TRUE.,1)
-     DO ij = 1, ip1jm
-        zv(ij) = RAN1(idum) -.5
-     ENDDO
-     CALL filtreg (zv,jjm,1,2,1,.FALSE.,1)
-
-     CALL minmax(iip1*jjp1,zu,umin,ullm )
-     CALL minmax(iip1*jjm, zv,vmin,vllm )
-
-     ullm = ABS ( ullm )
-     vllm = ABS ( vllm )
-
-     DO    l = 1, 50
-        IF(ii.EQ.1) THEN
-           !cccc             CALL covcont( 1,zu,zv,zu,zv )
-           IF(lstardis) THEN
-              CALL gradiv2( 1,zu,zv,nitergdiv,gx,gy )
-           ELSE
-              CALL gradiv ( 1,zu,zv,nitergdiv,gx,gy )
-           ENDIF
-        ELSE
-           IF(lstardis) THEN
-              CALL nxgraro2( 1,zu,zv,nitergrot,gx,gy )
-           ELSE
-              CALL nxgrarot( 1,zu,zv,nitergrot,gx,gy )
-           ENDIF
-        ENDIF
-
-        zllm = max(abs(maxval(gx)), abs(maxval(gy)))
-        zu = gx / zllm
-        zv = gy / zllm
-     end DO
-
-     IF ( ii.EQ.1 ) THEN
-        IF(lstardis) THEN
-           cdivu  = 1./zllm
-        ELSE
-           cdivu  = zllm **( -1./nitergdiv )
-        ENDIF
-     ELSE
-        IF(lstardis) THEN
-           crot   = 1./ zllm
-        ELSE
-           crot   = zllm **( -1./nitergrot )
-        ENDIF
-     ENDIF
-
-  end DO
-
-  !   petit test pour les operateurs non star:
-  !   ----------------------------------------
-
-  !     IF(.NOT.lstardis) THEN
-  fact    = rad*24./REAL(jjm)
-  fact    = fact*fact
-  write(lunout,*)'inidissip: coef u ', fact/cdivu, 1./cdivu
-  write(lunout,*)'inidissip: coef r ', fact/crot , 1./crot
-  write(lunout,*)'inidissip: coef h ', fact/cdivh, 1./cdivh
-  !     ENDIF
-
-  !-----------------------------------------------------------------------
-  !   variation verticale du coefficient de dissipation:
-  !   --------------------------------------------------
-
-  if (vert_prof_dissip == 1) then
-     do l=1,llm
-        pseudoz=8.*log(preff/presnivs(l))
-        zvert(l)=1+ &
-             (tanh((pseudoz-dissip_zref)/dissip_deltaz)+1.)/2. &
-             *(dissip_factz-1.)
-     enddo
-  else
-     DO l=1,llm
-        zvert(l)=1.
-     ENDDO
-     fact=2.
-     DO l = 1, llm
-        zz      = 1. - preff/presnivs(l)
-        zvert(l)= fact -( fact-1.)/( 1.+zz*zz )
-     ENDDO
-  endif
-
-
-  write(lunout,*)'inidissip: Constantes de temps de la diffusion horizontale'
-
-  tetamin =  1.e+6
-
-  DO l=1,llm
-     tetaudiv(l)   = zvert(l)/tetagdiv
-     tetaurot(l)   = zvert(l)/tetagrot
-     tetah(l)      = zvert(l)/tetatemp
-
-     IF( tetamin.GT. (1./tetaudiv(l)) ) tetamin = 1./ tetaudiv(l)
-     IF( tetamin.GT. (1./tetaurot(l)) ) tetamin = 1./ tetaurot(l)
-     IF( tetamin.GT. (1./   tetah(l)) ) tetamin = 1./    tetah(l)
-  ENDDO
-
-  ! If dissip_period=0 calculate value for dissipation period, else keep value read from gcm.def
-  IF (dissip_period == 0) THEN
-     dissip_period = INT( tetamin/( 2.*dtvr*iperiod) ) * iperiod
-     write(lunout,*)'inidissip: tetamin dtvr iperiod dissip_period(intermed) ',tetamin,dtvr,iperiod,dissip_period
-     dissip_period = MAX(iperiod,dissip_period)
-  END IF
-
-  dtdiss  = dissip_period * dtvr
-  write(lunout,*)'inidissip: dissip_period=',dissip_period,' dtdiss=',dtdiss,' dtvr=',dtvr
-
-  DO l = 1,llm
-     write(lunout,*)zvert(l),dtdiss*tetaudiv(l),dtdiss*tetaurot(l), &
-          dtdiss*tetah(l)
-  ENDDO
-
-END SUBROUTINE inidissip
Index: /LMDZ6/trunk/libf/dyn3d_common/inidissip.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d_common/inidissip.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3d_common/inidissip.f90	(revision 5268)
@@ -0,0 +1,223 @@
+!
+! $Id$
+!
+SUBROUTINE inidissip ( lstardis,nitergdiv,nitergrot,niterh  , &
+     tetagdiv,tetagrot,tetatemp, vert_prof_dissip)
+  !=======================================================================
+  !   initialisation de la dissipation horizontale
+  !=======================================================================
+  !-----------------------------------------------------------------------
+  !   declarations:
+  !   -------------
+
+  USE control_mod, only : dissip_period,iperiod
+  USE comconst_mod, ONLY: dissip_deltaz, dissip_factz, dissip_zref, &
+                          dtdiss, dtvr, rad
+  USE comvert_mod, ONLY: preff, presnivs
+
+  IMPLICIT NONE
+  include "dimensions.h"
+  include "paramet.h"
+  include "comdissipn.h"
+  include "iniprint.h"
+
+  LOGICAL,INTENT(in) :: lstardis
+  INTEGER,INTENT(in) :: nitergdiv,nitergrot,niterh
+  REAL,INTENT(in) :: tetagdiv,tetagrot,tetatemp
+
+  integer, INTENT(in):: vert_prof_dissip
+  ! Vertical profile of horizontal dissipation
+  ! Allowed values:
+  ! 0: rational fraction, function of pressure
+  ! 1: tanh of altitude
+
+! Local variables:
+  REAL fact,zvert(llm),zz
+  REAL zh(ip1jmp1),zu(ip1jmp1), gx(ip1jmp1), divgra(ip1jmp1)
+  real zv(ip1jm), gy(ip1jm), deltap(ip1jmp1,llm)
+  REAL ullm,vllm,umin,vmin,zhmin,zhmax
+  REAL zllm
+
+  INTEGER l,ij,idum,ii
+  REAL tetamin
+  REAL pseudoz
+  character (len=80) :: abort_message
+
+  REAL ran1
+
+
+  !-----------------------------------------------------------------------
+  !
+  !   calcul des valeurs propres des operateurs par methode iterrative:
+  !   -----------------------------------------------------------------
+
+  crot     = -1.
+  cdivu    = -1.
+  cdivh    = -1.
+
+  !   calcul de la valeur propre de divgrad:
+  !   --------------------------------------
+  idum = 0
+  DO l = 1, llm
+     DO ij = 1, ip1jmp1
+        deltap(ij,l) = 1.
+     ENDDO
+  ENDDO
+
+  idum  = -1
+  zh(1) = RAN1(idum)-.5
+  idum  = 0
+  DO ij = 2, ip1jmp1
+     zh(ij) = RAN1(idum) -.5
+  ENDDO
+
+  CALL filtreg (zh,jjp1,1,2,1,.TRUE.,1)
+
+  CALL minmax(iip1*jjp1,zh,zhmin,zhmax )
+
+  IF ( zhmin .GE. zhmax  )     THEN
+     write(lunout,*)'  Inidissip  zh min max  ',zhmin,zhmax
+     abort_message='probleme generateur alleatoire dans inidissip'
+     call abort_gcm('inidissip',abort_message,1)
+  ENDIF
+
+  zllm = ABS( zhmax )
+  DO l = 1,50
+     IF(lstardis) THEN
+        CALL divgrad2(1,zh,deltap,niterh,divgra)
+     ELSE
+        CALL divgrad (1,zh,niterh,divgra)
+     ENDIF
+
+     zllm  = ABS(maxval(divgra))
+     zh = divgra / zllm
+  ENDDO
+
+  IF(lstardis) THEN
+     cdivh = 1./ zllm
+  ELSE
+     cdivh = zllm ** ( -1./niterh )
+  ENDIF
+
+  !   calcul des valeurs propres de gradiv (ii =1) et  nxgrarot(ii=2)
+  !   -----------------------------------------------------------------
+  write(lunout,*)'inidissip: calcul des valeurs propres'
+
+  DO    ii = 1, 2
+     !
+     DO ij = 1, ip1jmp1
+        zu(ij)  = RAN1(idum) -.5
+     ENDDO
+     CALL filtreg (zu,jjp1,1,2,1,.TRUE.,1)
+     DO ij = 1, ip1jm
+        zv(ij) = RAN1(idum) -.5
+     ENDDO
+     CALL filtreg (zv,jjm,1,2,1,.FALSE.,1)
+
+     CALL minmax(iip1*jjp1,zu,umin,ullm )
+     CALL minmax(iip1*jjm, zv,vmin,vllm )
+
+     ullm = ABS ( ullm )
+     vllm = ABS ( vllm )
+
+     DO    l = 1, 50
+        IF(ii.EQ.1) THEN
+           !cccc             CALL covcont( 1,zu,zv,zu,zv )
+           IF(lstardis) THEN
+              CALL gradiv2( 1,zu,zv,nitergdiv,gx,gy )
+           ELSE
+              CALL gradiv ( 1,zu,zv,nitergdiv,gx,gy )
+           ENDIF
+        ELSE
+           IF(lstardis) THEN
+              CALL nxgraro2( 1,zu,zv,nitergrot,gx,gy )
+           ELSE
+              CALL nxgrarot( 1,zu,zv,nitergrot,gx,gy )
+           ENDIF
+        ENDIF
+
+        zllm = max(abs(maxval(gx)), abs(maxval(gy)))
+        zu = gx / zllm
+        zv = gy / zllm
+     end DO
+
+     IF ( ii.EQ.1 ) THEN
+        IF(lstardis) THEN
+           cdivu  = 1./zllm
+        ELSE
+           cdivu  = zllm **( -1./nitergdiv )
+        ENDIF
+     ELSE
+        IF(lstardis) THEN
+           crot   = 1./ zllm
+        ELSE
+           crot   = zllm **( -1./nitergrot )
+        ENDIF
+     ENDIF
+
+  end DO
+
+  !   petit test pour les operateurs non star:
+  !   ----------------------------------------
+
+  !     IF(.NOT.lstardis) THEN
+  fact    = rad*24./REAL(jjm)
+  fact    = fact*fact
+  write(lunout,*)'inidissip: coef u ', fact/cdivu, 1./cdivu
+  write(lunout,*)'inidissip: coef r ', fact/crot , 1./crot
+  write(lunout,*)'inidissip: coef h ', fact/cdivh, 1./cdivh
+  !     ENDIF
+
+  !-----------------------------------------------------------------------
+  !   variation verticale du coefficient de dissipation:
+  !   --------------------------------------------------
+
+  if (vert_prof_dissip == 1) then
+     do l=1,llm
+        pseudoz=8.*log(preff/presnivs(l))
+        zvert(l)=1+ &
+             (tanh((pseudoz-dissip_zref)/dissip_deltaz)+1.)/2. &
+             *(dissip_factz-1.)
+     enddo
+  else
+     DO l=1,llm
+        zvert(l)=1.
+     ENDDO
+     fact=2.
+     DO l = 1, llm
+        zz      = 1. - preff/presnivs(l)
+        zvert(l)= fact -( fact-1.)/( 1.+zz*zz )
+     ENDDO
+  endif
+
+
+  write(lunout,*)'inidissip: Constantes de temps de la diffusion horizontale'
+
+  tetamin =  1.e+6
+
+  DO l=1,llm
+     tetaudiv(l)   = zvert(l)/tetagdiv
+     tetaurot(l)   = zvert(l)/tetagrot
+     tetah(l)      = zvert(l)/tetatemp
+
+     IF( tetamin.GT. (1./tetaudiv(l)) ) tetamin = 1./ tetaudiv(l)
+     IF( tetamin.GT. (1./tetaurot(l)) ) tetamin = 1./ tetaurot(l)
+     IF( tetamin.GT. (1./   tetah(l)) ) tetamin = 1./    tetah(l)
+  ENDDO
+
+  ! If dissip_period=0 calculate value for dissipation period, else keep value read from gcm.def
+  IF (dissip_period == 0) THEN
+     dissip_period = INT( tetamin/( 2.*dtvr*iperiod) ) * iperiod
+     write(lunout,*)'inidissip: tetamin dtvr iperiod dissip_period(intermed) ',tetamin,dtvr,iperiod,dissip_period
+     dissip_period = MAX(iperiod,dissip_period)
+  END IF
+
+  dtdiss  = dissip_period * dtvr
+  write(lunout,*)'inidissip: dissip_period=',dissip_period,' dtdiss=',dtdiss,' dtvr=',dtvr
+
+  DO l = 1,llm
+     write(lunout,*)zvert(l),dtdiss*tetaudiv(l),dtdiss*tetaurot(l), &
+          dtdiss*tetah(l)
+  ENDDO
+
+END SUBROUTINE inidissip
Index: DZ6/trunk/libf/dyn3d_common/initdynav.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d_common/initdynav.F90	(revision 5267)
+++ 	(revision )
@@ -1,187 +1,0 @@
-! $Id$
-
-subroutine initdynav(day0,anne0,tstep,t_ops,t_wrt)
-
-  USE IOIPSL
-  USE infotrac, ONLY : nqtot
-  use com_io_dyn_mod, only : histaveid,histvaveid,histuaveid, &
-       dynhistave_file,dynhistvave_file,dynhistuave_file
-  USE comconst_mod, ONLY: pi
-  USE comvert_mod, ONLY: presnivs
-  USE temps_mod, ONLY: itau_dyn
-  
-  implicit none
-
-
-  !   Routine d'initialisation des ecritures des fichiers histoires LMDZ
-  !   au format IOIPSL. Initialisation du fichier histoire moyenne.
-
-  !   Appels succesifs des routines: histbeg
-  !                                  histhori
-  !                                  histver
-  !                                  histdef
-  !                                  histend
-
-  !   Entree:
-
-  !      infile: nom du fichier histoire a creer
-  !      day0,anne0: date de reference
-  !      tstep : frequence d'ecriture
-  !      t_ops: frequence de l'operation pour IOIPSL
-  !      t_wrt: frequence d'ecriture sur le fichier
-
-
-  !   L. Fairhead, LMD, 03/99
-
-  include "dimensions.h"
-  include "paramet.h"
-  include "comgeom.h"
-  include "description.h"
-  include "iniprint.h"
-
-  !   Arguments
-
-  integer day0, anne0
-  real tstep, t_ops, t_wrt
-
-  ! This routine needs IOIPSL to work
-  !   Variables locales
-
-  integer tau0
-  real zjulian
-  integer iq
-  real rlong(iip1,jjp1), rlat(iip1,jjp1)
-  integer uhoriid, vhoriid, thoriid, zvertiid
-  integer ii,jj
-  integer zan, dayref
-
-  !--------------------------------------------------------------------
-
-  !  Initialisations
-
-  pi = 4. * atan (1.)
-
-  !  Appel a histbeg: creation du fichier netcdf et initialisations diverses
-
-
-  zan = anne0
-  dayref = day0
-  CALL ymds2ju(zan, 1, dayref, 0.0, zjulian)
-  tau0 = itau_dyn
-
-  do jj = 1, jjp1
-     do ii = 1, iip1
-        rlong(ii,jj) = rlonv(ii) * 180. / pi
-        rlat(ii,jj)  = rlatu(jj) * 180. / pi
-     enddo
-  enddo
-
-  ! Creation de 3 fichiers pour les differentes grilles horizontales
-  ! Restriction de IOIPSL: seulement 2 coordonnees dans le meme fichier
-  ! Grille Scalaire
-  call histbeg(dynhistave_file, iip1, rlong(:,1), jjp1, rlat(1,:), &
-       1, iip1, 1, jjp1, &
-       tau0, zjulian, tstep, thoriid,histaveid)
-
-  ! Creation du fichier histoire pour les grilles en V et U (oblige
-  ! pour l'instant, IOIPSL ne permet pas de grilles avec des nombres
-  ! de point differents dans  un meme fichier)
-  ! Grille V
-  do jj = 1, jjm
-     do ii = 1, iip1
-        rlong(ii,jj) = rlonv(ii) * 180. / pi
-        rlat(ii,jj) = rlatv(jj) * 180. / pi
-     enddo
-  enddo
-
-  call histbeg(dynhistvave_file, iip1, rlong(:,1), jjm, rlat(1,:), &
-       1, iip1, 1, jjm, &
-       tau0, zjulian, tstep, vhoriid,histvaveid)
-  ! Grille U
-  do jj = 1, jjp1
-     do ii = 1, iip1
-        rlong(ii,jj) = rlonu(ii) * 180. / pi
-        rlat(ii,jj) = rlatu(jj) * 180. / pi
-     enddo
-  enddo
-
-  call histbeg(dynhistuave_file, iip1, rlong(:,1),jjp1, rlat(1,:), &
-       1, iip1, 1, jjp1, &
-       tau0, zjulian, tstep, uhoriid,histuaveid)
-
-  !  Appel a histvert pour la grille verticale
-
-  call histvert(histaveid,'presnivs','Niveaux Pression approximatifs','mb', &
-       llm, presnivs/100., zvertiid,'down')
-  call histvert(histuaveid,'presnivs','Niveaux Pression approximatifs','mb', &
-       llm, presnivs/100., zvertiid,'down')
-  call histvert(histvaveid,'presnivs','Niveaux Pression approximatifs','mb', &
-       llm, presnivs/100., zvertiid,'down')
-
-  !  Appels a histdef pour la definition des variables a sauvegarder
-
-  !  Vents U
-
-  call histdef(histuaveid, 'u', 'vent u moyen ', &
-       'm/s', iip1, jjp1, uhoriid, llm, 1, llm, zvertiid, &
-       32, 'ave(X)', t_ops, t_wrt)
-
-  !  Vents V
-
-  call histdef(histvaveid, 'v', 'vent v moyen', &
-       'm/s', iip1, jjm, vhoriid, llm, 1, llm, zvertiid, &
-       32, 'ave(X)', t_ops, t_wrt)
-
-
-  !  Temperature
-
-  call histdef(histaveid, 'temp', 'temperature moyenne', 'K', &
-       iip1, jjp1, thoriid, llm, 1, llm, zvertiid, &
-       32, 'ave(X)', t_ops, t_wrt)
-
-  !  Temperature potentielle
-
-  call histdef(histaveid, 'theta', 'temperature potentielle', 'K', &
-       iip1, jjp1, thoriid, llm, 1, llm, zvertiid, &
-       32, 'ave(X)', t_ops, t_wrt)
-
-  !  Geopotentiel
-
-  call histdef(histaveid, 'phi', 'geopotentiel moyen', '-', &
-       iip1, jjp1, thoriid, llm, 1, llm, zvertiid, &
-       32, 'ave(X)', t_ops, t_wrt)
-
-  !  Traceurs
-
-  !        DO iq=1,nqtot
-  !          call histdef(histaveid, tracers(iq)%name, &
-  !                                  tracers(iq)%longName, '-',  &
-  !                  iip1, jjp1, thoriid, llm, 1, llm, zvertiid, &
-  !                  32, 'ave(X)', t_ops, t_wrt)
-  !        enddo
-
-  !  Masse
-
-  call histdef(histaveid, 'masse', 'masse', 'kg', &
-       iip1, jjp1, thoriid, llm, 1, llm, zvertiid, &
-       32, 'ave(X)', t_ops, t_wrt)
-
-  !  Pression au sol
-
-  call histdef(histaveid, 'ps', 'pression naturelle au sol', 'Pa', &
-       iip1, jjp1, thoriid, 1, 1, 1, -99, &
-       32, 'ave(X)', t_ops, t_wrt)
-
-  !  Geopotentiel au sol
-
-  !      call histdef(histaveid, 'phis', 'geopotentiel au sol', '-', &
-  !                  iip1, jjp1, thoriid, 1, 1, 1, -99, &
-  !                  32, 'ave(X)', t_ops, t_wrt)
-
-  call histend(histaveid)
-  call histend(histuaveid)
-  call histend(histvaveid)
-
-
-
-end subroutine initdynav
Index: /LMDZ6/trunk/libf/dyn3d_common/initdynav.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d_common/initdynav.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3d_common/initdynav.f90	(revision 5268)
@@ -0,0 +1,187 @@
+! $Id$
+
+subroutine initdynav(day0,anne0,tstep,t_ops,t_wrt)
+
+  USE IOIPSL
+  USE infotrac, ONLY : nqtot
+  use com_io_dyn_mod, only : histaveid,histvaveid,histuaveid, &
+       dynhistave_file,dynhistvave_file,dynhistuave_file
+  USE comconst_mod, ONLY: pi
+  USE comvert_mod, ONLY: presnivs
+  USE temps_mod, ONLY: itau_dyn
+  
+  implicit none
+
+
+  !   Routine d'initialisation des ecritures des fichiers histoires LMDZ
+  !   au format IOIPSL. Initialisation du fichier histoire moyenne.
+
+  !   Appels succesifs des routines: histbeg
+  !                                  histhori
+  !                                  histver
+  !                                  histdef
+  !                                  histend
+
+  !   Entree:
+
+  !      infile: nom du fichier histoire a creer
+  !      day0,anne0: date de reference
+  !      tstep : frequence d'ecriture
+  !      t_ops: frequence de l'operation pour IOIPSL
+  !      t_wrt: frequence d'ecriture sur le fichier
+
+
+  !   L. Fairhead, LMD, 03/99
+
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom.h"
+  include "description.h"
+  include "iniprint.h"
+
+  !   Arguments
+
+  integer day0, anne0
+  real tstep, t_ops, t_wrt
+
+  ! This routine needs IOIPSL to work
+  !   Variables locales
+
+  integer tau0
+  real zjulian
+  integer iq
+  real rlong(iip1,jjp1), rlat(iip1,jjp1)
+  integer uhoriid, vhoriid, thoriid, zvertiid
+  integer ii,jj
+  integer zan, dayref
+
+  !--------------------------------------------------------------------
+
+  !  Initialisations
+
+  pi = 4. * atan (1.)
+
+  !  Appel a histbeg: creation du fichier netcdf et initialisations diverses
+
+
+  zan = anne0
+  dayref = day0
+  CALL ymds2ju(zan, 1, dayref, 0.0, zjulian)
+  tau0 = itau_dyn
+
+  do jj = 1, jjp1
+     do ii = 1, iip1
+        rlong(ii,jj) = rlonv(ii) * 180. / pi
+        rlat(ii,jj)  = rlatu(jj) * 180. / pi
+     enddo
+  enddo
+
+  ! Creation de 3 fichiers pour les differentes grilles horizontales
+  ! Restriction de IOIPSL: seulement 2 coordonnees dans le meme fichier
+  ! Grille Scalaire
+  call histbeg(dynhistave_file, iip1, rlong(:,1), jjp1, rlat(1,:), &
+       1, iip1, 1, jjp1, &
+       tau0, zjulian, tstep, thoriid,histaveid)
+
+  ! Creation du fichier histoire pour les grilles en V et U (oblige
+  ! pour l'instant, IOIPSL ne permet pas de grilles avec des nombres
+  ! de point differents dans  un meme fichier)
+  ! Grille V
+  do jj = 1, jjm
+     do ii = 1, iip1
+        rlong(ii,jj) = rlonv(ii) * 180. / pi
+        rlat(ii,jj) = rlatv(jj) * 180. / pi
+     enddo
+  enddo
+
+  call histbeg(dynhistvave_file, iip1, rlong(:,1), jjm, rlat(1,:), &
+       1, iip1, 1, jjm, &
+       tau0, zjulian, tstep, vhoriid,histvaveid)
+  ! Grille U
+  do jj = 1, jjp1
+     do ii = 1, iip1
+        rlong(ii,jj) = rlonu(ii) * 180. / pi
+        rlat(ii,jj) = rlatu(jj) * 180. / pi
+     enddo
+  enddo
+
+  call histbeg(dynhistuave_file, iip1, rlong(:,1),jjp1, rlat(1,:), &
+       1, iip1, 1, jjp1, &
+       tau0, zjulian, tstep, uhoriid,histuaveid)
+
+  !  Appel a histvert pour la grille verticale
+
+  call histvert(histaveid,'presnivs','Niveaux Pression approximatifs','mb', &
+       llm, presnivs/100., zvertiid,'down')
+  call histvert(histuaveid,'presnivs','Niveaux Pression approximatifs','mb', &
+       llm, presnivs/100., zvertiid,'down')
+  call histvert(histvaveid,'presnivs','Niveaux Pression approximatifs','mb', &
+       llm, presnivs/100., zvertiid,'down')
+
+  !  Appels a histdef pour la definition des variables a sauvegarder
+
+  !  Vents U
+
+  call histdef(histuaveid, 'u', 'vent u moyen ', &
+       'm/s', iip1, jjp1, uhoriid, llm, 1, llm, zvertiid, &
+       32, 'ave(X)', t_ops, t_wrt)
+
+  !  Vents V
+
+  call histdef(histvaveid, 'v', 'vent v moyen', &
+       'm/s', iip1, jjm, vhoriid, llm, 1, llm, zvertiid, &
+       32, 'ave(X)', t_ops, t_wrt)
+
+
+  !  Temperature
+
+  call histdef(histaveid, 'temp', 'temperature moyenne', 'K', &
+       iip1, jjp1, thoriid, llm, 1, llm, zvertiid, &
+       32, 'ave(X)', t_ops, t_wrt)
+
+  !  Temperature potentielle
+
+  call histdef(histaveid, 'theta', 'temperature potentielle', 'K', &
+       iip1, jjp1, thoriid, llm, 1, llm, zvertiid, &
+       32, 'ave(X)', t_ops, t_wrt)
+
+  !  Geopotentiel
+
+  call histdef(histaveid, 'phi', 'geopotentiel moyen', '-', &
+       iip1, jjp1, thoriid, llm, 1, llm, zvertiid, &
+       32, 'ave(X)', t_ops, t_wrt)
+
+  !  Traceurs
+
+  !        DO iq=1,nqtot
+  !          call histdef(histaveid, tracers(iq)%name, &
+  !                                  tracers(iq)%longName, '-',  &
+  !                  iip1, jjp1, thoriid, llm, 1, llm, zvertiid, &
+  !                  32, 'ave(X)', t_ops, t_wrt)
+  !        enddo
+
+  !  Masse
+
+  call histdef(histaveid, 'masse', 'masse', 'kg', &
+       iip1, jjp1, thoriid, llm, 1, llm, zvertiid, &
+       32, 'ave(X)', t_ops, t_wrt)
+
+  !  Pression au sol
+
+  call histdef(histaveid, 'ps', 'pression naturelle au sol', 'Pa', &
+       iip1, jjp1, thoriid, 1, 1, 1, -99, &
+       32, 'ave(X)', t_ops, t_wrt)
+
+  !  Geopotentiel au sol
+
+  !      call histdef(histaveid, 'phis', 'geopotentiel au sol', '-', &
+  !                  iip1, jjp1, thoriid, 1, 1, 1, -99, &
+  !                  32, 'ave(X)', t_ops, t_wrt)
+
+  call histend(histaveid)
+  call histend(histuaveid)
+  call histend(histvaveid)
+
+
+
+end subroutine initdynav
Index: DZ6/trunk/libf/dyn3d_common/initfluxsto.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d_common/initfluxsto.F90	(revision 5267)
+++ 	(revision )
@@ -1,224 +1,0 @@
-!
-! $Id$
-!
-subroutine initfluxsto &
-        (infile,tstep,t_ops,t_wrt, &
-        fileid,filevid,filedid)
-
-   USE IOIPSL
-  USE comconst_mod, ONLY: pi
-  USE comvert_mod, ONLY: nivsigs
-  USE temps_mod, ONLY: annee_ref, day_ref, itau_dyn
-
-  implicit none
-
-  !
-  !   Routine d'initialisation des ecritures des fichiers histoires LMDZ
-  !   au format IOIPSL
-  !
-  !   Appels succesifs des routines: histbeg
-  !                              histhori
-  !                              histver
-  !                              histdef
-  !                              histend
-  !
-  !   Entree:
-  !
-  !  infile: nom du fichier histoire a creer
-  !  day0,anne0: date de reference
-  !  tstep: duree du pas de temps en seconde
-  !  t_ops: frequence de l'operation pour IOIPSL
-  !  t_wrt: frequence d'ecriture sur le fichier
-  !
-  !   Sortie:
-  !  fileid: ID du fichier netcdf cree
-  !  filevid:ID du fichier netcdf pour la grille v
-  !
-  !   L. Fairhead, LMD, 03/99
-  !
-  ! =====================================================================
-  !
-  !   Declarations
-  include "dimensions.h"
-  include "paramet.h"
-  include "comgeom.h"
-  include "description.h"
-  include "iniprint.h"
-
-  !   Arguments
-  !
-  character(len=*) :: infile
-  real :: tstep, t_ops, t_wrt
-  integer :: fileid, filevid,filedid
-
-  ! This routine needs IOIPSL to work
-  !   Variables locales
-  !
-  real :: nivd(1)
-  integer :: tau0
-  real :: zjulian
-  character(len=3) :: str
-  character(len=10) :: ctrac
-  integer :: iq
-  real :: rlong(iip1,jjp1), rlat(iip1,jjp1),rl(1,1)
-  integer :: uhoriid, vhoriid, thoriid, zvertiid,dhoriid,dvertiid
-  integer :: ii,jj
-  integer :: zan, idayref
-  logical :: ok_sync
-  !
-  !  Initialisations
-  !
-  pi = 4. * atan (1.)
-  str='q  '
-  ctrac = 'traceur   '
-  ok_sync = .true.
-  !
-  !  Appel a histbeg: creation du fichier netcdf et initialisations diverses
-  !
-
-  zan = annee_ref
-  idayref = day_ref
-  CALL ymds2ju(zan, 1, idayref, 0.0, zjulian)
-  tau0 = itau_dyn
-
-    do jj = 1, jjp1
-    do ii = 1, iip1
-      rlong(ii,jj) = rlonu(ii) * 180. / pi
-      rlat(ii,jj) = rlatu(jj) * 180. / pi
-    enddo
-  enddo
-
-  call histbeg(infile, iip1, rlong(:,1), jjp1, rlat(1,:), &
-        1, iip1, 1, jjp1, &
-        tau0, zjulian, tstep, uhoriid, fileid)
-  !
-  !  Creation du fichier histoire pour la grille en V (oblige pour l'instant,
-  !  IOIPSL ne permet pas de grilles avec des nombres de point differents dans
-  !  un meme fichier)
-
-
-  do jj = 1, jjm
-    do ii = 1, iip1
-      rlong(ii,jj) = rlonv(ii) * 180. / pi
-      rlat(ii,jj) = rlatv(jj) * 180. / pi
-    enddo
-  enddo
-
-  call histbeg('fluxstokev.nc', iip1, rlong(:,1), jjm, rlat(1,:), &
-        1, iip1, 1, jjm, &
-        tau0, zjulian, tstep, vhoriid, filevid)
-
-    rl(1,1) = 1.
-  call histbeg('defstoke.nc', 1, rl, 1, rl, &
-        1, 1, 1, 1, &
-        tau0, zjulian, tstep, dhoriid, filedid)
-
-  !
-  !  Appel a histhori pour rajouter les autres grilles horizontales
-  !
-  do jj = 1, jjp1
-    do ii = 1, iip1
-      rlong(ii,jj) = rlonv(ii) * 180. / pi
-      rlat(ii,jj) = rlatu(jj) * 180. / pi
-    enddo
-  enddo
-
-  call histhori(fileid, iip1, rlong, jjp1, rlat, 'scalar', &
-        'Grille points scalaires', thoriid)
-
-  !
-  !  Appel a histvert pour la grille verticale
-  !
-  call histvert(fileid, 'sig_s', 'Niveaux sigma', &
-        'sigma_level', &
-        llm, nivsigs, zvertiid)
-  ! Pour le fichier V
-  call histvert(filevid, 'sig_s', 'Niveaux sigma', &
-        'sigma_level', &
-        llm, nivsigs, zvertiid)
-  ! pour le fichier def
-  nivd(1) = 1
-  call histvert(filedid, 'sig_s', 'Niveaux sigma', &
-        'sigma_level', &
-        1, nivd, dvertiid)
-
-  !
-  !  Appels a histdef pour la definition des variables a sauvegarder
-
-    CALL histdef(fileid, "phis", "Surface geop. height", "-", &
-          iip1,jjp1,thoriid, 1,1,1, -99, 32, &
-          "once", t_ops, t_wrt)
-
-     CALL histdef(fileid, "aire", "Grid area", "-", &
-           iip1,jjp1,thoriid, 1,1,1, -99, 32, &
-           "once", t_ops, t_wrt)
-
-    CALL histdef(filedid, "dtvr", "tps dyn", "s", &
-          1,1,dhoriid, 1,1,1, -99, 32, &
-          "once", t_ops, t_wrt)
-
-     CALL histdef(filedid, "istdyn", "tps stock", "s", &
-           1,1,dhoriid, 1,1,1, -99, 32, &
-           "once", t_ops, t_wrt)
-
-     CALL histdef(filedid, "istphy", "tps stock phy", "s", &
-           1,1,dhoriid, 1,1,1, -99, 32, &
-           "once", t_ops, t_wrt)
-
-
-  !
-  ! Masse
-  !
-  call histdef(fileid, 'masse', 'Masse', 'kg', &
-        iip1, jjp1, thoriid, llm, 1, llm, zvertiid, &
-        32, 'inst(X)', t_ops, t_wrt)
-  !
-  !  Pbaru
-  !
-  call histdef(fileid, 'pbaru', 'flx de masse zonal', 'kg m/s', &
-        iip1, jjp1, uhoriid, llm, 1, llm, zvertiid, &
-        32, 'inst(X)', t_ops, t_wrt)
-
-  !
-  !  Pbarv
-  !
-  call histdef(filevid, 'pbarv', 'flx de masse mer', 'kg m/s', &
-        iip1, jjm, vhoriid, llm, 1, llm, zvertiid, &
-        32, 'inst(X)', t_ops, t_wrt)
-  !
-  !  w
-  !
-  call histdef(fileid, 'w', 'flx de masse vert', 'kg m/s', &
-        iip1, jjp1, thoriid, llm, 1, llm, zvertiid, &
-        32, 'inst(X)', t_ops, t_wrt)
-
-  !
-  !  Temperature potentielle
-  !
-  call histdef(fileid, 'teta', 'temperature potentielle', '-', &
-        iip1, jjp1, thoriid, llm, 1, llm, zvertiid, &
-        32, 'inst(X)', t_ops, t_wrt)
-  !
-
-  !
-  ! Geopotentiel
-  !
-  call histdef(fileid, 'phi', 'geopotentiel instantane', '-', &
-        iip1, jjp1, thoriid, llm, 1, llm, zvertiid, &
-        32, 'inst(X)', t_ops, t_wrt)
-  !
-  !  Fin
-  !
-  call histend(fileid)
-  call histend(filevid)
-  call histend(filedid)
-  if (ok_sync) then
-    call histsync(fileid)
-    call histsync(filevid)
-    call histsync(filedid)
-  endif
-
-
-
-  return
-end subroutine initfluxsto
Index: /LMDZ6/trunk/libf/dyn3d_common/initfluxsto.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d_common/initfluxsto.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3d_common/initfluxsto.f90	(revision 5268)
@@ -0,0 +1,224 @@
+!
+! $Id$
+!
+subroutine initfluxsto &
+        (infile,tstep,t_ops,t_wrt, &
+        fileid,filevid,filedid)
+
+   USE IOIPSL
+  USE comconst_mod, ONLY: pi
+  USE comvert_mod, ONLY: nivsigs
+  USE temps_mod, ONLY: annee_ref, day_ref, itau_dyn
+
+  implicit none
+
+  !
+  !   Routine d'initialisation des ecritures des fichiers histoires LMDZ
+  !   au format IOIPSL
+  !
+  !   Appels succesifs des routines: histbeg
+  !                              histhori
+  !                              histver
+  !                              histdef
+  !                              histend
+  !
+  !   Entree:
+  !
+  !  infile: nom du fichier histoire a creer
+  !  day0,anne0: date de reference
+  !  tstep: duree du pas de temps en seconde
+  !  t_ops: frequence de l'operation pour IOIPSL
+  !  t_wrt: frequence d'ecriture sur le fichier
+  !
+  !   Sortie:
+  !  fileid: ID du fichier netcdf cree
+  !  filevid:ID du fichier netcdf pour la grille v
+  !
+  !   L. Fairhead, LMD, 03/99
+  !
+  ! =====================================================================
+  !
+  !   Declarations
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom.h"
+  include "description.h"
+  include "iniprint.h"
+
+  !   Arguments
+  !
+  character(len=*) :: infile
+  real :: tstep, t_ops, t_wrt
+  integer :: fileid, filevid,filedid
+
+  ! This routine needs IOIPSL to work
+  !   Variables locales
+  !
+  real :: nivd(1)
+  integer :: tau0
+  real :: zjulian
+  character(len=3) :: str
+  character(len=10) :: ctrac
+  integer :: iq
+  real :: rlong(iip1,jjp1), rlat(iip1,jjp1),rl(1,1)
+  integer :: uhoriid, vhoriid, thoriid, zvertiid,dhoriid,dvertiid
+  integer :: ii,jj
+  integer :: zan, idayref
+  logical :: ok_sync
+  !
+  !  Initialisations
+  !
+  pi = 4. * atan (1.)
+  str='q  '
+  ctrac = 'traceur   '
+  ok_sync = .true.
+  !
+  !  Appel a histbeg: creation du fichier netcdf et initialisations diverses
+  !
+
+  zan = annee_ref
+  idayref = day_ref
+  CALL ymds2ju(zan, 1, idayref, 0.0, zjulian)
+  tau0 = itau_dyn
+
+    do jj = 1, jjp1
+    do ii = 1, iip1
+      rlong(ii,jj) = rlonu(ii) * 180. / pi
+      rlat(ii,jj) = rlatu(jj) * 180. / pi
+    enddo
+  enddo
+
+  call histbeg(infile, iip1, rlong(:,1), jjp1, rlat(1,:), &
+        1, iip1, 1, jjp1, &
+        tau0, zjulian, tstep, uhoriid, fileid)
+  !
+  !  Creation du fichier histoire pour la grille en V (oblige pour l'instant,
+  !  IOIPSL ne permet pas de grilles avec des nombres de point differents dans
+  !  un meme fichier)
+
+
+  do jj = 1, jjm
+    do ii = 1, iip1
+      rlong(ii,jj) = rlonv(ii) * 180. / pi
+      rlat(ii,jj) = rlatv(jj) * 180. / pi
+    enddo
+  enddo
+
+  call histbeg('fluxstokev.nc', iip1, rlong(:,1), jjm, rlat(1,:), &
+        1, iip1, 1, jjm, &
+        tau0, zjulian, tstep, vhoriid, filevid)
+
+    rl(1,1) = 1.
+  call histbeg('defstoke.nc', 1, rl, 1, rl, &
+        1, 1, 1, 1, &
+        tau0, zjulian, tstep, dhoriid, filedid)
+
+  !
+  !  Appel a histhori pour rajouter les autres grilles horizontales
+  !
+  do jj = 1, jjp1
+    do ii = 1, iip1
+      rlong(ii,jj) = rlonv(ii) * 180. / pi
+      rlat(ii,jj) = rlatu(jj) * 180. / pi
+    enddo
+  enddo
+
+  call histhori(fileid, iip1, rlong, jjp1, rlat, 'scalar', &
+        'Grille points scalaires', thoriid)
+
+  !
+  !  Appel a histvert pour la grille verticale
+  !
+  call histvert(fileid, 'sig_s', 'Niveaux sigma', &
+        'sigma_level', &
+        llm, nivsigs, zvertiid)
+  ! Pour le fichier V
+  call histvert(filevid, 'sig_s', 'Niveaux sigma', &
+        'sigma_level', &
+        llm, nivsigs, zvertiid)
+  ! pour le fichier def
+  nivd(1) = 1
+  call histvert(filedid, 'sig_s', 'Niveaux sigma', &
+        'sigma_level', &
+        1, nivd, dvertiid)
+
+  !
+  !  Appels a histdef pour la definition des variables a sauvegarder
+
+    CALL histdef(fileid, "phis", "Surface geop. height", "-", &
+          iip1,jjp1,thoriid, 1,1,1, -99, 32, &
+          "once", t_ops, t_wrt)
+
+     CALL histdef(fileid, "aire", "Grid area", "-", &
+           iip1,jjp1,thoriid, 1,1,1, -99, 32, &
+           "once", t_ops, t_wrt)
+
+    CALL histdef(filedid, "dtvr", "tps dyn", "s", &
+          1,1,dhoriid, 1,1,1, -99, 32, &
+          "once", t_ops, t_wrt)
+
+     CALL histdef(filedid, "istdyn", "tps stock", "s", &
+           1,1,dhoriid, 1,1,1, -99, 32, &
+           "once", t_ops, t_wrt)
+
+     CALL histdef(filedid, "istphy", "tps stock phy", "s", &
+           1,1,dhoriid, 1,1,1, -99, 32, &
+           "once", t_ops, t_wrt)
+
+
+  !
+  ! Masse
+  !
+  call histdef(fileid, 'masse', 'Masse', 'kg', &
+        iip1, jjp1, thoriid, llm, 1, llm, zvertiid, &
+        32, 'inst(X)', t_ops, t_wrt)
+  !
+  !  Pbaru
+  !
+  call histdef(fileid, 'pbaru', 'flx de masse zonal', 'kg m/s', &
+        iip1, jjp1, uhoriid, llm, 1, llm, zvertiid, &
+        32, 'inst(X)', t_ops, t_wrt)
+
+  !
+  !  Pbarv
+  !
+  call histdef(filevid, 'pbarv', 'flx de masse mer', 'kg m/s', &
+        iip1, jjm, vhoriid, llm, 1, llm, zvertiid, &
+        32, 'inst(X)', t_ops, t_wrt)
+  !
+  !  w
+  !
+  call histdef(fileid, 'w', 'flx de masse vert', 'kg m/s', &
+        iip1, jjp1, thoriid, llm, 1, llm, zvertiid, &
+        32, 'inst(X)', t_ops, t_wrt)
+
+  !
+  !  Temperature potentielle
+  !
+  call histdef(fileid, 'teta', 'temperature potentielle', '-', &
+        iip1, jjp1, thoriid, llm, 1, llm, zvertiid, &
+        32, 'inst(X)', t_ops, t_wrt)
+  !
+
+  !
+  ! Geopotentiel
+  !
+  call histdef(fileid, 'phi', 'geopotentiel instantane', '-', &
+        iip1, jjp1, thoriid, llm, 1, llm, zvertiid, &
+        32, 'inst(X)', t_ops, t_wrt)
+  !
+  !  Fin
+  !
+  call histend(fileid)
+  call histend(filevid)
+  call histend(filedid)
+  if (ok_sync) then
+    call histsync(fileid)
+    call histsync(filevid)
+    call histsync(filedid)
+  endif
+
+
+
+  return
+end subroutine initfluxsto
Index: DZ6/trunk/libf/dyn3d_common/inithist.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d_common/inithist.F90	(revision 5267)
+++ 	(revision )
@@ -1,188 +1,0 @@
-!
-! $Id$
-!
-subroutine inithist(day0,anne0,tstep,t_ops,t_wrt)
-
-   USE IOIPSL
-   USE infotrac, ONLY : nqtot
-   use com_io_dyn_mod, only : histid,histvid,histuid,               &
-         dynhist_file,dynhistv_file,dynhistu_file
-   USE comconst_mod, ONLY: pi
-   USE comvert_mod, ONLY: presnivs
-   USE temps_mod, ONLY: itau_dyn
-
-  implicit none
-
-  !
-  !   Routine d'initialisation des ecritures des fichiers histoires LMDZ
-  !   au format IOIPSL
-  !
-  !   Appels succesifs des routines: histbeg
-  !                              histhori
-  !                              histver
-  !                              histdef
-  !                              histend
-  !
-  !   Entree:
-  !
-  !  infile: nom du fichier histoire a creer
-  !  day0,anne0: date de reference
-  !  tstep: duree du pas de temps en seconde
-  !  t_ops: frequence de l'operation pour IOIPSL
-  !  t_wrt: frequence d'ecriture sur le fichier
-  !  nq: nombre de traceurs
-  !
-  !
-  !   L. Fairhead, LMD, 03/99
-  !
-  ! =====================================================================
-  !
-  !   Declarations
-  include "dimensions.h"
-  include "paramet.h"
-  include "comgeom.h"
-  include "description.h"
-  include "iniprint.h"
-
-  !   Arguments
-  !
-  integer :: day0, anne0
-  real :: tstep, t_ops, t_wrt
-
-  ! This routine needs IOIPSL to work
-  !   Variables locales
-  !
-  integer :: tau0
-  real :: zjulian
-  integer :: iq
-  real :: rlong(iip1,jjp1), rlat(iip1,jjp1)
-  integer :: uhoriid, vhoriid, thoriid, zvertiid
-  integer :: ii,jj
-  integer :: zan, dayref
-  !
-  !  Initialisations
-  !
-  pi = 4. * atan (1.)
-  !
-  !  Appel a histbeg: creation du fichier netcdf et initialisations diverses
-  !
-
-  zan = anne0
-  dayref = day0
-  CALL ymds2ju(zan, 1, dayref, 0.0, zjulian)
-  tau0 = itau_dyn
-
-  ! -------------------------------------------------------------
-  ! Creation des 3 fichiers pour les grilles horizontales U,V,Scal
-  ! -------------------------------------------------------------
-  !Grille U
-  do jj = 1, jjp1
-    do ii = 1, iip1
-      rlong(ii,jj) = rlonu(ii) * 180. / pi
-      rlat(ii,jj) = rlatu(jj) * 180. / pi
-    enddo
-  enddo
-
-  call histbeg(dynhistu_file, iip1, rlong(:,1), jjp1, rlat(1,:), &
-        1, iip1, 1, jjp1, &
-        tau0, zjulian, tstep, uhoriid, histuid)
-
-  ! Grille V
-  do jj = 1, jjm
-    do ii = 1, iip1
-      rlong(ii,jj) = rlonv(ii) * 180. / pi
-      rlat(ii,jj) = rlatv(jj) * 180. / pi
-    enddo
-  enddo
-
-  call histbeg(dynhistv_file, iip1, rlong(:,1), jjm, rlat(1,:), &
-        1, iip1, 1, jjm, &
-        tau0, zjulian, tstep, vhoriid, histvid)
-
-  !Grille Scalaire
-  do jj = 1, jjp1
-    do ii = 1, iip1
-      rlong(ii,jj) = rlonv(ii) * 180. / pi
-      rlat(ii,jj) = rlatu(jj) * 180. / pi
-    enddo
-  enddo
-
-  call histbeg(dynhist_file, iip1, rlong(:,1), jjp1, rlat(1,:), &
-        1, iip1, 1, jjp1, &
-        tau0, zjulian, tstep, thoriid, histid)
-  ! -------------------------------------------------------------
-  !  Appel a histvert pour la grille verticale
-  ! -------------------------------------------------------------
-  call histvert(histid, 'presnivs', 'Niveaux pression','mb', &
-        llm, presnivs/100., zvertiid,'down')
-  call histvert(histvid, 'presnivs', 'Niveaux pression','mb', &
-        llm, presnivs/100., zvertiid,'down')
-  call histvert(histuid, 'presnivs', 'Niveaux pression','mb', &
-        llm, presnivs/100., zvertiid,'down')
-  !
-  ! -------------------------------------------------------------
-  !  Appels a histdef pour la definition des variables a sauvegarder
-  ! -------------------------------------------------------------
-  !
-  !  Vents U
-  !
-  call histdef(histuid, 'u', 'vent u', 'm/s', &
-        iip1, jjp1, uhoriid, llm, 1, llm, zvertiid, &
-        32, 'inst(X)', t_ops, t_wrt)
-  !
-  !  Vents V
-  !
-  call histdef(histvid, 'v', 'vent v', 'm/s', &
-        iip1, jjm, vhoriid, llm, 1, llm, zvertiid, &
-        32, 'inst(X)', t_ops, t_wrt)
-
-  !
-  !  Temperature potentielle
-  !
-  call histdef(histid, 'teta', 'temperature potentielle', '-', &
-        iip1, jjp1, thoriid, llm, 1, llm, zvertiid, &
-        32, 'inst(X)', t_ops, t_wrt)
-  !
-  !  Geopotentiel
-  !
-  call histdef(histid, 'phi', 'geopotentiel', '-', &
-        iip1, jjp1, thoriid, llm, 1, llm, zvertiid, &
-        32, 'inst(X)', t_ops, t_wrt)
-  !
-  !  Traceurs
-  !
-  !
-  !    DO iq=1,nqtot
-  !      call histdef(histid, tracers(iq)%name,
-  !                           tracers(iq)%longName, '-',
-  ! .             iip1, jjp1, thoriid, llm, 1, llm, zvertiid,
-  ! .             32, 'inst(X)', t_ops, t_wrt)
-  !    enddo
-  !C
-  !  Masse
-  !
-  call histdef(histid, 'masse', 'masse', 'kg', &
-        iip1, jjp1, thoriid, llm, 1, llm, zvertiid, &
-        32, 'inst(X)', t_ops, t_wrt)
-  !
-  !  Pression au sol
-  !
-  call histdef(histid, 'ps', 'pression naturelle au sol', 'Pa', &
-        iip1, jjp1, thoriid, 1, 1, 1, -99, &
-        32, 'inst(X)', t_ops, t_wrt)
-  !
-  !  Geopotentiel au sol
-  !C
-  !  call histdef(histid, 'phis', 'geopotentiel au sol', '-',
-  ! .             iip1, jjp1, thoriid, 1, 1, 1, -99,
-  ! .             32, 'inst(X)', t_ops, t_wrt)
-  !C
-  !  Fin
-  !
-  call histend(histid)
-  call histend(histuid)
-  call histend(histvid)
-
-
-  return
-end subroutine inithist
Index: /LMDZ6/trunk/libf/dyn3d_common/inithist.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d_common/inithist.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3d_common/inithist.f90	(revision 5268)
@@ -0,0 +1,188 @@
+!
+! $Id$
+!
+subroutine inithist(day0,anne0,tstep,t_ops,t_wrt)
+
+   USE IOIPSL
+   USE infotrac, ONLY : nqtot
+   use com_io_dyn_mod, only : histid,histvid,histuid,               &
+         dynhist_file,dynhistv_file,dynhistu_file
+   USE comconst_mod, ONLY: pi
+   USE comvert_mod, ONLY: presnivs
+   USE temps_mod, ONLY: itau_dyn
+
+  implicit none
+
+  !
+  !   Routine d'initialisation des ecritures des fichiers histoires LMDZ
+  !   au format IOIPSL
+  !
+  !   Appels succesifs des routines: histbeg
+  !                              histhori
+  !                              histver
+  !                              histdef
+  !                              histend
+  !
+  !   Entree:
+  !
+  !  infile: nom du fichier histoire a creer
+  !  day0,anne0: date de reference
+  !  tstep: duree du pas de temps en seconde
+  !  t_ops: frequence de l'operation pour IOIPSL
+  !  t_wrt: frequence d'ecriture sur le fichier
+  !  nq: nombre de traceurs
+  !
+  !
+  !   L. Fairhead, LMD, 03/99
+  !
+  ! =====================================================================
+  !
+  !   Declarations
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom.h"
+  include "description.h"
+  include "iniprint.h"
+
+  !   Arguments
+  !
+  integer :: day0, anne0
+  real :: tstep, t_ops, t_wrt
+
+  ! This routine needs IOIPSL to work
+  !   Variables locales
+  !
+  integer :: tau0
+  real :: zjulian
+  integer :: iq
+  real :: rlong(iip1,jjp1), rlat(iip1,jjp1)
+  integer :: uhoriid, vhoriid, thoriid, zvertiid
+  integer :: ii,jj
+  integer :: zan, dayref
+  !
+  !  Initialisations
+  !
+  pi = 4. * atan (1.)
+  !
+  !  Appel a histbeg: creation du fichier netcdf et initialisations diverses
+  !
+
+  zan = anne0
+  dayref = day0
+  CALL ymds2ju(zan, 1, dayref, 0.0, zjulian)
+  tau0 = itau_dyn
+
+  ! -------------------------------------------------------------
+  ! Creation des 3 fichiers pour les grilles horizontales U,V,Scal
+  ! -------------------------------------------------------------
+  !Grille U
+  do jj = 1, jjp1
+    do ii = 1, iip1
+      rlong(ii,jj) = rlonu(ii) * 180. / pi
+      rlat(ii,jj) = rlatu(jj) * 180. / pi
+    enddo
+  enddo
+
+  call histbeg(dynhistu_file, iip1, rlong(:,1), jjp1, rlat(1,:), &
+        1, iip1, 1, jjp1, &
+        tau0, zjulian, tstep, uhoriid, histuid)
+
+  ! Grille V
+  do jj = 1, jjm
+    do ii = 1, iip1
+      rlong(ii,jj) = rlonv(ii) * 180. / pi
+      rlat(ii,jj) = rlatv(jj) * 180. / pi
+    enddo
+  enddo
+
+  call histbeg(dynhistv_file, iip1, rlong(:,1), jjm, rlat(1,:), &
+        1, iip1, 1, jjm, &
+        tau0, zjulian, tstep, vhoriid, histvid)
+
+  !Grille Scalaire
+  do jj = 1, jjp1
+    do ii = 1, iip1
+      rlong(ii,jj) = rlonv(ii) * 180. / pi
+      rlat(ii,jj) = rlatu(jj) * 180. / pi
+    enddo
+  enddo
+
+  call histbeg(dynhist_file, iip1, rlong(:,1), jjp1, rlat(1,:), &
+        1, iip1, 1, jjp1, &
+        tau0, zjulian, tstep, thoriid, histid)
+  ! -------------------------------------------------------------
+  !  Appel a histvert pour la grille verticale
+  ! -------------------------------------------------------------
+  call histvert(histid, 'presnivs', 'Niveaux pression','mb', &
+        llm, presnivs/100., zvertiid,'down')
+  call histvert(histvid, 'presnivs', 'Niveaux pression','mb', &
+        llm, presnivs/100., zvertiid,'down')
+  call histvert(histuid, 'presnivs', 'Niveaux pression','mb', &
+        llm, presnivs/100., zvertiid,'down')
+  !
+  ! -------------------------------------------------------------
+  !  Appels a histdef pour la definition des variables a sauvegarder
+  ! -------------------------------------------------------------
+  !
+  !  Vents U
+  !
+  call histdef(histuid, 'u', 'vent u', 'm/s', &
+        iip1, jjp1, uhoriid, llm, 1, llm, zvertiid, &
+        32, 'inst(X)', t_ops, t_wrt)
+  !
+  !  Vents V
+  !
+  call histdef(histvid, 'v', 'vent v', 'm/s', &
+        iip1, jjm, vhoriid, llm, 1, llm, zvertiid, &
+        32, 'inst(X)', t_ops, t_wrt)
+
+  !
+  !  Temperature potentielle
+  !
+  call histdef(histid, 'teta', 'temperature potentielle', '-', &
+        iip1, jjp1, thoriid, llm, 1, llm, zvertiid, &
+        32, 'inst(X)', t_ops, t_wrt)
+  !
+  !  Geopotentiel
+  !
+  call histdef(histid, 'phi', 'geopotentiel', '-', &
+        iip1, jjp1, thoriid, llm, 1, llm, zvertiid, &
+        32, 'inst(X)', t_ops, t_wrt)
+  !
+  !  Traceurs
+  !
+  !
+  !    DO iq=1,nqtot
+  !      call histdef(histid, tracers(iq)%name,
+  !                           tracers(iq)%longName, '-',
+  ! .             iip1, jjp1, thoriid, llm, 1, llm, zvertiid,
+  ! .             32, 'inst(X)', t_ops, t_wrt)
+  !    enddo
+  !C
+  !  Masse
+  !
+  call histdef(histid, 'masse', 'masse', 'kg', &
+        iip1, jjp1, thoriid, llm, 1, llm, zvertiid, &
+        32, 'inst(X)', t_ops, t_wrt)
+  !
+  !  Pression au sol
+  !
+  call histdef(histid, 'ps', 'pression naturelle au sol', 'Pa', &
+        iip1, jjp1, thoriid, 1, 1, 1, -99, &
+        32, 'inst(X)', t_ops, t_wrt)
+  !
+  !  Geopotentiel au sol
+  !C
+  !  call histdef(histid, 'phis', 'geopotentiel au sol', '-',
+  ! .             iip1, jjp1, thoriid, 1, 1, 1, -99,
+  ! .             32, 'inst(X)', t_ops, t_wrt)
+  !C
+  !  Fin
+  !
+  call histend(histid)
+  call histend(histuid)
+  call histend(histvid)
+
+
+  return
+end subroutine inithist
Index: DZ6/trunk/libf/dyn3d_common/inter_barxy_m.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d_common/inter_barxy_m.F90	(revision 5267)
+++ 	(revision )
@@ -1,450 +1,0 @@
-!
-! $Id$
-!
-module inter_barxy_m
-
-  ! Authors: Robert SADOURNY, Phu LE VAN, Lionel GUEZ
-
-  implicit none
-
-  private
-  public inter_barxy
-
-contains
-
-  SUBROUTINE inter_barxy(dlonid, dlatid, champ, rlonimod, rlatimod, champint)
-
-    use assert_eq_m, only: assert_eq
-    use assert_m, only: assert
-
-    include "dimensions.h"
-    ! (for "iim", "jjm")
-
-    include "paramet.h"
-    ! (for other included files)
-
-    include "comgeom2.h"
-    ! (for "aire", "apoln", "apols")
-
-    REAL, intent(in):: dlonid(:)
-    ! (longitude from input file, in rad, from -pi to pi)
-
-    REAL, intent(in):: dlatid(:), champ(:, :), rlonimod(:)
-
-    REAL, intent(in):: rlatimod(:)
-    ! (latitude angle, in degrees or rad, in strictly decreasing order)
-
-    real, intent(out):: champint(:, :)
-    ! Si taille de la seconde dim = jjm + 1, on veut interpoler sur les
-    ! jjm+1 latitudes rlatu du modele (latitudes des scalaires et de U)
-    ! Si taille de la seconde dim = jjm, on veut interpoler sur les
-    ! jjm latitudes rlatv du modele (latitudes de V) 
-
-    ! Variables local to the procedure:
-
-    REAL champy(iim, size(champ, 2))
-    integer j, i, jnterfd, jmods
-
-    REAL yjmod(size(champint, 2))
-    ! (angle, in degrees, in strictly increasing order)
-
-    REAL   yjdat(size(dlatid) + 1) ! angle, in degrees, in increasing order
-    LOGICAL decrois ! "dlatid" is in decreasing order
-
-    !-----------------------------------
-
-    jnterfd = assert_eq(size(champ, 2) - 1, size(dlatid), &
-         "inter_barxy jnterfd")
-    jmods = size(champint, 2)
-    call assert(size(champ, 1) == size(dlonid), "inter_barxy size(champ, 1)")
-    call assert((/size(rlonimod), size(champint, 1)/) == iim, &
-         "inter_barxy iim")
-    call assert(any(jmods == (/jjm, jjm + 1/)), 'inter_barxy jmods')
-    call assert(size(rlatimod) == jjm, "inter_barxy size(rlatimod)")
-
-    ! Check decreasing order for "rlatimod":
-    DO i = 2, jjm
-       IF (rlatimod(i) >= rlatimod(i-1)) stop &
-            '"inter_barxy": "rlatimod" should be strictly decreasing'
-    ENDDO
-
-    yjmod(:jjm) = ord_coordm(rlatimod)
-    IF (jmods == jjm + 1) THEN
-       IF (90. - yjmod(jjm) < 0.01) stop &
-            '"inter_barxy": with jmods = jjm + 1, yjmod(jjm) should be < 90.'
-    ELSE
-       ! jmods = jjm
-       IF (ABS(yjmod(jjm) - 90.) > 0.01) stop &
-            '"inter_barxy": with jmods = jjm, yjmod(jjm) should be 90.'
-    ENDIF
-
-    if (jmods == jjm + 1) yjmod(jjm + 1) = 90.
-
-    DO j = 1, jnterfd + 1
-       champy(:, j) = inter_barx(dlonid, champ(:, j), rlonimod)
-    ENDDO
-
-    CALL ord_coord(dlatid, yjdat, decrois) 
-    IF (decrois) champy(:, :) = champy(:, jnterfd + 1:1:-1)
-    DO i = 1, iim
-       champint(i, :) = inter_bary(yjdat, champy(i, :), yjmod)
-    ENDDO
-    champint(:, :) = champint(:, jmods:1:-1)
-
-    IF (jmods == jjm + 1) THEN
-       ! Valeurs uniques aux poles
-       champint(:, 1) = SUM(aire(:iim,  1) * champint(:, 1)) / apoln
-       champint(:, jjm + 1) = SUM(aire(:iim, jjm + 1) &
-            * champint(:, jjm + 1)) / apols
-    ENDIF
-
-  END SUBROUTINE inter_barxy
-
-  !******************************
-
-  function inter_barx(dlonid, fdat, rlonimod) 
-
-    !        INTERPOLATION BARYCENTRIQUE BASEE SUR LES AIRES
-    !            VERSION UNIDIMENSIONNELLE  ,   EN  LONGITUDE .
-
-    !     idat : indice du champ de donnees, de 1 a idatmax
-    !     imod : indice du champ du modele,  de 1 a  imodmax
-    !     fdat(idat) : champ de donnees (entrees)
-    !     inter_barx(imod) : champ du modele (sorties)
-    !     dlonid(idat): abscisses des interfaces des mailles donnees
-    !     rlonimod(imod): abscisses des interfaces des mailles modele
-    !      ( L'indice 1 correspond a l'interface mailLE 1 / maille 2)
-    !      ( Les abscisses sont exprimees en degres)
-
-    use assert_eq_m, only: assert_eq
-
-    IMPLICIT NONE
-
-    REAL, intent(in):: dlonid(:)
-    real, intent(in):: fdat(:)
-    real, intent(in):: rlonimod(:)
-
-    real inter_barx(size(rlonimod))
-
-    !    ...  Variables locales ... 
-
-    INTEGER idatmax, imodmax
-    REAL xxid(size(dlonid)+1), xxd(size(dlonid)+1), fdd(size(dlonid)+1)
-    REAL  fxd(size(dlonid)+1), xchan(size(dlonid)+1), fdchan(size(dlonid)+1) 
-    REAL  xxim(size(rlonimod))
-
-    REAL x0, xim0, dx, dxm
-    REAL chmin, chmax, pi
-
-    INTEGER imod, idat, i, ichang, id0, id1, nid, idatmax1
-
-    !-----------------------------------------------------
-
-    idatmax = assert_eq(size(dlonid), size(fdat), "inter_barx idatmax")
-    imodmax = size(rlonimod)
-
-    pi = 2. * ASIN(1.)
-
-    !   REDEFINITION DE L'ORIGINE DES ABSCISSES
-    !    A L'INTERFACE OUEST DE LA PREMIERE MAILLE DU MODELE  
-    DO imod = 1, imodmax
-       xxim(imod) = rlonimod(imod)
-    ENDDO
-
-    CALL minmax( imodmax, xxim, chmin, chmax)
-    IF( chmax.LT.6.50 )   THEN
-       DO imod = 1, imodmax
-          xxim(imod) = xxim(imod) * 180./pi
-       ENDDO
-    ENDIF
-
-    xim0 = xxim(imodmax) - 360.
-
-    DO imod = 1, imodmax
-       xxim(imod) = xxim(imod) - xim0
-    ENDDO
-
-    idatmax1 = idatmax +1
-
-    DO idat = 1, idatmax
-       xxd(idat) = dlonid(idat)
-    ENDDO
-
-    CALL minmax( idatmax, xxd, chmin, chmax)
-    IF( chmax.LT.6.50 )  THEN
-       DO idat = 1, idatmax
-          xxd(idat) = xxd(idat) * 180./pi
-       ENDDO
-    ENDIF
-
-    DO idat = 1, idatmax
-       xxd(idat) = MOD( xxd(idat) - xim0, 360. )
-       fdd(idat) = fdat (idat)
-    ENDDO
-
-    i = 2
-    DO while (xxd(i) >= xxd(i-1) .and. i < idatmax)
-       i = i + 1
-    ENDDO
-    IF (xxd(i) < xxd(i-1)) THEN
-       ichang = i
-       !  ***  reorganisation  des longitudes entre 0. et 360. degres ****
-       nid = idatmax - ichang +1
-       DO i = 1, nid
-          xchan (i) = xxd(i+ichang -1 )
-          fdchan(i) = fdd(i+ichang -1 )
-       ENDDO
-       DO i=1, ichang -1
-          xchan (i+ nid) = xxd(i)
-          fdchan(i+nid) = fdd(i) 
-       ENDDO
-       DO i =1, idatmax
-          xxd(i) = xchan(i)
-          fdd(i) = fdchan(i)
-       ENDDO
-    end IF
-
-    !    translation des champs de donnees par rapport
-    !    a la nouvelle origine, avec redondance de la
-    !       maille a cheval sur les bords
-
-    id0 = 0
-    id1 = 0
-
-    DO idat = 1, idatmax
-       IF ( xxd( idatmax1- idat ).LT.360.) exit
-       id1 = id1 + 1
-    ENDDO
-
-    DO idat = 1, idatmax
-       IF (xxd(idat).GT.0.) exit
-       id0 = id0 + 1
-    END DO
-
-    IF( id1 /= 0 ) then
-       DO idat = 1, id1
-          xxid(idat) = xxd(idatmax - id1 + idat) - 360.
-          fxd (idat) = fdd(idatmax - id1 + idat)     
-       END DO
-       DO idat = 1, idatmax - id1
-          xxid(idat + id1) = xxd(idat)
-          fxd (idat + id1) = fdd(idat)
-       END DO
-    end IF
-
-    IF(id0 /= 0) then
-       DO idat = 1, idatmax - id0
-          xxid(idat) = xxd(idat + id0)
-          fxd (idat) = fdd(idat + id0)
-       END DO
-
-       DO idat = 1, id0
-          xxid (idatmax - id0 + idat) =  xxd(idat) + 360.
-          fxd  (idatmax - id0 + idat) =  fdd(idat)   
-       END DO
-    else 
-       DO idat = 1, idatmax
-          xxid(idat)  = xxd(idat)
-          fxd (idat)  = fdd(idat)
-       ENDDO
-    end IF
-    xxid(idatmax1) = xxid(1) + 360.
-    fxd (idatmax1) = fxd(1)
-
-    !   initialisation du champ du modele
-
-    inter_barx(:) = 0.
-
-    ! iteration
-
-    x0   = xim0
-    dxm  = 0.
-    imod = 1
-    idat = 1
-
-    do while (imod <= imodmax)
-       do while (xxim(imod).GT.xxid(idat))
-          dx   = xxid(idat) - x0
-          dxm  = dxm + dx
-          inter_barx(imod) = inter_barx(imod) + dx * fxd(idat)
-          x0   = xxid(idat)
-          idat = idat + 1
-       end do
-       IF (xxim(imod).LT.xxid(idat)) THEN
-          dx   = xxim(imod) - x0
-          dxm  = dxm + dx
-          inter_barx(imod) = (inter_barx(imod) + dx * fxd(idat)) / dxm
-          x0   = xxim(imod)
-          dxm  = 0.
-          imod = imod + 1
-       ELSE
-          dx   = xxim(imod) - x0
-          dxm  = dxm + dx
-          inter_barx(imod) = (inter_barx(imod) + dx * fxd(idat)) / dxm
-          x0   = xxim(imod)
-          dxm  = 0.
-          imod = imod + 1
-          idat = idat + 1
-       END IF
-    end do
-
-  END function inter_barx
-
-  !******************************
-
-  function inter_bary(yjdat, fdat, yjmod)
-
-    ! Interpolation barycentrique basée sur les aires.
-    ! Version unidimensionnelle, en latitude.
-    ! L'indice 1 correspond à l'interface maille 1 -- maille 2.
-
-    use assert_m, only: assert
-
-    IMPLICIT NONE
-
-    REAL, intent(in):: yjdat(:)
-    ! (angles, ordonnées des interfaces des mailles des données, in
-    ! degrees, in increasing order)
-
-    REAL, intent(in):: fdat(:) ! champ de données
-
-    REAL, intent(in):: yjmod(:)
-    ! (ordonnées des interfaces des mailles du modèle)
-    ! (in degrees, in strictly increasing order)
-
-    REAL inter_bary(size(yjmod)) ! champ du modèle
-
-    ! Variables local to the procedure:
-
-    REAL y0, dy, dym 
-    INTEGER jdat ! indice du champ de données
-    integer jmod ! indice du champ du modèle
-
-    !------------------------------------
-
-    call assert(size(yjdat) == size(fdat), "inter_bary")
-
-    ! Initialisation des variables
-    inter_bary(:) = 0.
-    y0    = -90.
-    dym   = 0.
-    jmod  = 1
-    jdat  = 1
-
-    do while (jmod <= size(yjmod))
-       do while (yjmod(jmod) > yjdat(jdat))
-          dy         = yjdat(jdat) - y0
-          dym        = dym + dy
-          inter_bary(jmod) = inter_bary(jmod) + dy * fdat(jdat)
-          y0         = yjdat(jdat)
-          jdat       = jdat + 1
-       end do
-       IF (yjmod(jmod) < yjdat(jdat)) THEN
-          dy         = yjmod(jmod) - y0
-          dym        = dym + dy
-          inter_bary(jmod) = (inter_bary(jmod) + dy * fdat(jdat)) / dym
-          y0         = yjmod(jmod)
-          dym        = 0.
-          jmod       = jmod + 1
-       ELSE
-          ! {yjmod(jmod) == yjdat(jdat)}
-          dy         = yjmod(jmod) - y0
-          dym        = dym + dy
-          inter_bary(jmod) = (inter_bary(jmod) + dy * fdat(jdat)) / dym
-          y0         = yjmod(jmod)
-          dym        = 0.
-          jmod       = jmod + 1
-          jdat       = jdat + 1
-       END IF
-    end do
-    ! Le test de fin suppose que l'interface 0 est commune aux deux
-    ! grilles "yjdat" et "yjmod".
-
-  END function inter_bary
-
-  !******************************
-
-  SUBROUTINE ord_coord(xi, xo, decrois)
-
-    ! This procedure receives an array of latitudes.
-    ! It converts them to degrees if they are in radians.
-    ! If the input latitudes are in decreasing order, the procedure
-    ! reverses their order.
-    ! Finally, the procedure adds 90° as the last value of the array.
-
-    use assert_eq_m, only: assert_eq
-    use comconst_mod, only: pi
-
-    IMPLICIT NONE
-
-    REAL, intent(in):: xi(:)
-    ! (latitude, in degrees or radians, in increasing or decreasing order)
-    ! ("xi" should contain latitudes from pole to pole.
-    ! "xi" should contain the latitudes of the boundaries of grid
-    ! cells, not the centers of grid cells.
-    ! So the extreme values should not be 90° and -90°.)
-
-    REAL, intent(out):: xo(:) ! angles in degrees
-    LOGICAL, intent(out):: decrois
-
-    ! Variables  local to the procedure:
-    INTEGER nmax, i
-
-    !--------------------
-
-    nmax = assert_eq(size(xi), size(xo) - 1, "ord_coord")
-
-    ! Check monotonicity:
-    decrois = xi(2) < xi(1)
-    DO i = 3, nmax
-       IF (decrois .neqv. xi(i) < xi(i-1)) stop &
-            '"ord_coord":  latitudes are not monotonic'
-    ENDDO
-
-    IF (abs(xi(1)) < pi) then
-       ! "xi" contains latitudes in radians
-       xo(:nmax) = xi(:) * 180. / pi
-    else
-       ! "xi" contains latitudes in degrees
-       xo(:nmax) = xi(:)
-    end IF
-
-    IF (ABS(abs(xo(1)) - 90) < 0.001 .or. ABS(abs(xo(nmax)) - 90) < 0.001) THEN
-       print *, "ord_coord"
-       PRINT *, '"xi" should contain the latitudes of the boundaries of ' &
-            // 'grid cells, not the centers of grid cells.'
-       STOP
-    ENDIF
-
-    IF (decrois) xo(:nmax) = xo(nmax:1:- 1)
-    xo(nmax + 1) = 90.
-
-  END SUBROUTINE ord_coord
-
-  !***********************************
-
-  function ord_coordm(xi)
-
-    ! This procedure converts to degrees, if necessary, and inverts the
-    ! order.
-
-    use comconst_mod, only: pi
-
-    IMPLICIT NONE
-
-    REAL, intent(in):: xi(:) ! angle, in rad or degrees
-    REAL ord_coordm(size(xi)) ! angle, in degrees
-
-    !-----------------------------
-
-    IF (xi(1) < 6.5) THEN
-       ! "xi" is in rad
-       ord_coordm(:) = xi(size(xi):1:-1) * 180. / pi
-    else
-       ! "xi" is in degrees
-       ord_coordm(:) = xi(size(xi):1:-1)
-    ENDIF
-
-  END function ord_coordm
-
-end module inter_barxy_m
Index: /LMDZ6/trunk/libf/dyn3d_common/inter_barxy_m.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d_common/inter_barxy_m.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3d_common/inter_barxy_m.f90	(revision 5268)
@@ -0,0 +1,450 @@
+!
+! $Id$
+!
+module inter_barxy_m
+
+  ! Authors: Robert SADOURNY, Phu LE VAN, Lionel GUEZ
+
+  implicit none
+
+  private
+  public inter_barxy
+
+contains
+
+  SUBROUTINE inter_barxy(dlonid, dlatid, champ, rlonimod, rlatimod, champint)
+
+    use assert_eq_m, only: assert_eq
+    use assert_m, only: assert
+
+    include "dimensions.h"
+    ! (for "iim", "jjm")
+
+    include "paramet.h"
+    ! (for other included files)
+
+    include "comgeom2.h"
+    ! (for "aire", "apoln", "apols")
+
+    REAL, intent(in):: dlonid(:)
+    ! (longitude from input file, in rad, from -pi to pi)
+
+    REAL, intent(in):: dlatid(:), champ(:, :), rlonimod(:)
+
+    REAL, intent(in):: rlatimod(:)
+    ! (latitude angle, in degrees or rad, in strictly decreasing order)
+
+    real, intent(out):: champint(:, :)
+    ! Si taille de la seconde dim = jjm + 1, on veut interpoler sur les
+    ! jjm+1 latitudes rlatu du modele (latitudes des scalaires et de U)
+    ! Si taille de la seconde dim = jjm, on veut interpoler sur les
+    ! jjm latitudes rlatv du modele (latitudes de V) 
+
+    ! Variables local to the procedure:
+
+    REAL champy(iim, size(champ, 2))
+    integer j, i, jnterfd, jmods
+
+    REAL yjmod(size(champint, 2))
+    ! (angle, in degrees, in strictly increasing order)
+
+    REAL   yjdat(size(dlatid) + 1) ! angle, in degrees, in increasing order
+    LOGICAL decrois ! "dlatid" is in decreasing order
+
+    !-----------------------------------
+
+    jnterfd = assert_eq(size(champ, 2) - 1, size(dlatid), &
+         "inter_barxy jnterfd")
+    jmods = size(champint, 2)
+    call assert(size(champ, 1) == size(dlonid), "inter_barxy size(champ, 1)")
+    call assert((/size(rlonimod), size(champint, 1)/) == iim, &
+         "inter_barxy iim")
+    call assert(any(jmods == (/jjm, jjm + 1/)), 'inter_barxy jmods')
+    call assert(size(rlatimod) == jjm, "inter_barxy size(rlatimod)")
+
+    ! Check decreasing order for "rlatimod":
+    DO i = 2, jjm
+       IF (rlatimod(i) >= rlatimod(i-1)) stop &
+            '"inter_barxy": "rlatimod" should be strictly decreasing'
+    ENDDO
+
+    yjmod(:jjm) = ord_coordm(rlatimod)
+    IF (jmods == jjm + 1) THEN
+       IF (90. - yjmod(jjm) < 0.01) stop &
+            '"inter_barxy": with jmods = jjm + 1, yjmod(jjm) should be < 90.'
+    ELSE
+       ! jmods = jjm
+       IF (ABS(yjmod(jjm) - 90.) > 0.01) stop &
+            '"inter_barxy": with jmods = jjm, yjmod(jjm) should be 90.'
+    ENDIF
+
+    if (jmods == jjm + 1) yjmod(jjm + 1) = 90.
+
+    DO j = 1, jnterfd + 1
+       champy(:, j) = inter_barx(dlonid, champ(:, j), rlonimod)
+    ENDDO
+
+    CALL ord_coord(dlatid, yjdat, decrois) 
+    IF (decrois) champy(:, :) = champy(:, jnterfd + 1:1:-1)
+    DO i = 1, iim
+       champint(i, :) = inter_bary(yjdat, champy(i, :), yjmod)
+    ENDDO
+    champint(:, :) = champint(:, jmods:1:-1)
+
+    IF (jmods == jjm + 1) THEN
+       ! Valeurs uniques aux poles
+       champint(:, 1) = SUM(aire(:iim,  1) * champint(:, 1)) / apoln
+       champint(:, jjm + 1) = SUM(aire(:iim, jjm + 1) &
+            * champint(:, jjm + 1)) / apols
+    ENDIF
+
+  END SUBROUTINE inter_barxy
+
+  !******************************
+
+  function inter_barx(dlonid, fdat, rlonimod) 
+
+    !        INTERPOLATION BARYCENTRIQUE BASEE SUR LES AIRES
+    !            VERSION UNIDIMENSIONNELLE  ,   EN  LONGITUDE .
+
+    !     idat : indice du champ de donnees, de 1 a idatmax
+    !     imod : indice du champ du modele,  de 1 a  imodmax
+    !     fdat(idat) : champ de donnees (entrees)
+    !     inter_barx(imod) : champ du modele (sorties)
+    !     dlonid(idat): abscisses des interfaces des mailles donnees
+    !     rlonimod(imod): abscisses des interfaces des mailles modele
+    !      ( L'indice 1 correspond a l'interface mailLE 1 / maille 2)
+    !      ( Les abscisses sont exprimees en degres)
+
+    use assert_eq_m, only: assert_eq
+
+    IMPLICIT NONE
+
+    REAL, intent(in):: dlonid(:)
+    real, intent(in):: fdat(:)
+    real, intent(in):: rlonimod(:)
+
+    real inter_barx(size(rlonimod))
+
+    !    ...  Variables locales ... 
+
+    INTEGER idatmax, imodmax
+    REAL xxid(size(dlonid)+1), xxd(size(dlonid)+1), fdd(size(dlonid)+1)
+    REAL  fxd(size(dlonid)+1), xchan(size(dlonid)+1), fdchan(size(dlonid)+1) 
+    REAL  xxim(size(rlonimod))
+
+    REAL x0, xim0, dx, dxm
+    REAL chmin, chmax, pi
+
+    INTEGER imod, idat, i, ichang, id0, id1, nid, idatmax1
+
+    !-----------------------------------------------------
+
+    idatmax = assert_eq(size(dlonid), size(fdat), "inter_barx idatmax")
+    imodmax = size(rlonimod)
+
+    pi = 2. * ASIN(1.)
+
+    !   REDEFINITION DE L'ORIGINE DES ABSCISSES
+    !    A L'INTERFACE OUEST DE LA PREMIERE MAILLE DU MODELE  
+    DO imod = 1, imodmax
+       xxim(imod) = rlonimod(imod)
+    ENDDO
+
+    CALL minmax( imodmax, xxim, chmin, chmax)
+    IF( chmax.LT.6.50 )   THEN
+       DO imod = 1, imodmax
+          xxim(imod) = xxim(imod) * 180./pi
+       ENDDO
+    ENDIF
+
+    xim0 = xxim(imodmax) - 360.
+
+    DO imod = 1, imodmax
+       xxim(imod) = xxim(imod) - xim0
+    ENDDO
+
+    idatmax1 = idatmax +1
+
+    DO idat = 1, idatmax
+       xxd(idat) = dlonid(idat)
+    ENDDO
+
+    CALL minmax( idatmax, xxd, chmin, chmax)
+    IF( chmax.LT.6.50 )  THEN
+       DO idat = 1, idatmax
+          xxd(idat) = xxd(idat) * 180./pi
+       ENDDO
+    ENDIF
+
+    DO idat = 1, idatmax
+       xxd(idat) = MOD( xxd(idat) - xim0, 360. )
+       fdd(idat) = fdat (idat)
+    ENDDO
+
+    i = 2
+    DO while (xxd(i) >= xxd(i-1) .and. i < idatmax)
+       i = i + 1
+    ENDDO
+    IF (xxd(i) < xxd(i-1)) THEN
+       ichang = i
+       !  ***  reorganisation  des longitudes entre 0. et 360. degres ****
+       nid = idatmax - ichang +1
+       DO i = 1, nid
+          xchan (i) = xxd(i+ichang -1 )
+          fdchan(i) = fdd(i+ichang -1 )
+       ENDDO
+       DO i=1, ichang -1
+          xchan (i+ nid) = xxd(i)
+          fdchan(i+nid) = fdd(i) 
+       ENDDO
+       DO i =1, idatmax
+          xxd(i) = xchan(i)
+          fdd(i) = fdchan(i)
+       ENDDO
+    end IF
+
+    !    translation des champs de donnees par rapport
+    !    a la nouvelle origine, avec redondance de la
+    !       maille a cheval sur les bords
+
+    id0 = 0
+    id1 = 0
+
+    DO idat = 1, idatmax
+       IF ( xxd( idatmax1- idat ).LT.360.) exit
+       id1 = id1 + 1
+    ENDDO
+
+    DO idat = 1, idatmax
+       IF (xxd(idat).GT.0.) exit
+       id0 = id0 + 1
+    END DO
+
+    IF( id1 /= 0 ) then
+       DO idat = 1, id1
+          xxid(idat) = xxd(idatmax - id1 + idat) - 360.
+          fxd (idat) = fdd(idatmax - id1 + idat)     
+       END DO
+       DO idat = 1, idatmax - id1
+          xxid(idat + id1) = xxd(idat)
+          fxd (idat + id1) = fdd(idat)
+       END DO
+    end IF
+
+    IF(id0 /= 0) then
+       DO idat = 1, idatmax - id0
+          xxid(idat) = xxd(idat + id0)
+          fxd (idat) = fdd(idat + id0)
+       END DO
+
+       DO idat = 1, id0
+          xxid (idatmax - id0 + idat) =  xxd(idat) + 360.
+          fxd  (idatmax - id0 + idat) =  fdd(idat)   
+       END DO
+    else 
+       DO idat = 1, idatmax
+          xxid(idat)  = xxd(idat)
+          fxd (idat)  = fdd(idat)
+       ENDDO
+    end IF
+    xxid(idatmax1) = xxid(1) + 360.
+    fxd (idatmax1) = fxd(1)
+
+    !   initialisation du champ du modele
+
+    inter_barx(:) = 0.
+
+    ! iteration
+
+    x0   = xim0
+    dxm  = 0.
+    imod = 1
+    idat = 1
+
+    do while (imod <= imodmax)
+       do while (xxim(imod).GT.xxid(idat))
+          dx   = xxid(idat) - x0
+          dxm  = dxm + dx
+          inter_barx(imod) = inter_barx(imod) + dx * fxd(idat)
+          x0   = xxid(idat)
+          idat = idat + 1
+       end do
+       IF (xxim(imod).LT.xxid(idat)) THEN
+          dx   = xxim(imod) - x0
+          dxm  = dxm + dx
+          inter_barx(imod) = (inter_barx(imod) + dx * fxd(idat)) / dxm
+          x0   = xxim(imod)
+          dxm  = 0.
+          imod = imod + 1
+       ELSE
+          dx   = xxim(imod) - x0
+          dxm  = dxm + dx
+          inter_barx(imod) = (inter_barx(imod) + dx * fxd(idat)) / dxm
+          x0   = xxim(imod)
+          dxm  = 0.
+          imod = imod + 1
+          idat = idat + 1
+       END IF
+    end do
+
+  END function inter_barx
+
+  !******************************
+
+  function inter_bary(yjdat, fdat, yjmod)
+
+    ! Interpolation barycentrique basée sur les aires.
+    ! Version unidimensionnelle, en latitude.
+    ! L'indice 1 correspond à l'interface maille 1 -- maille 2.
+
+    use assert_m, only: assert
+
+    IMPLICIT NONE
+
+    REAL, intent(in):: yjdat(:)
+    ! (angles, ordonnées des interfaces des mailles des données, in
+    ! degrees, in increasing order)
+
+    REAL, intent(in):: fdat(:) ! champ de données
+
+    REAL, intent(in):: yjmod(:)
+    ! (ordonnées des interfaces des mailles du modèle)
+    ! (in degrees, in strictly increasing order)
+
+    REAL inter_bary(size(yjmod)) ! champ du modèle
+
+    ! Variables local to the procedure:
+
+    REAL y0, dy, dym 
+    INTEGER jdat ! indice du champ de données
+    integer jmod ! indice du champ du modèle
+
+    !------------------------------------
+
+    call assert(size(yjdat) == size(fdat), "inter_bary")
+
+    ! Initialisation des variables
+    inter_bary(:) = 0.
+    y0    = -90.
+    dym   = 0.
+    jmod  = 1
+    jdat  = 1
+
+    do while (jmod <= size(yjmod))
+       do while (yjmod(jmod) > yjdat(jdat))
+          dy         = yjdat(jdat) - y0
+          dym        = dym + dy
+          inter_bary(jmod) = inter_bary(jmod) + dy * fdat(jdat)
+          y0         = yjdat(jdat)
+          jdat       = jdat + 1
+       end do
+       IF (yjmod(jmod) < yjdat(jdat)) THEN
+          dy         = yjmod(jmod) - y0
+          dym        = dym + dy
+          inter_bary(jmod) = (inter_bary(jmod) + dy * fdat(jdat)) / dym
+          y0         = yjmod(jmod)
+          dym        = 0.
+          jmod       = jmod + 1
+       ELSE
+          ! {yjmod(jmod) == yjdat(jdat)}
+          dy         = yjmod(jmod) - y0
+          dym        = dym + dy
+          inter_bary(jmod) = (inter_bary(jmod) + dy * fdat(jdat)) / dym
+          y0         = yjmod(jmod)
+          dym        = 0.
+          jmod       = jmod + 1
+          jdat       = jdat + 1
+       END IF
+    end do
+    ! Le test de fin suppose que l'interface 0 est commune aux deux
+    ! grilles "yjdat" et "yjmod".
+
+  END function inter_bary
+
+  !******************************
+
+  SUBROUTINE ord_coord(xi, xo, decrois)
+
+    ! This procedure receives an array of latitudes.
+    ! It converts them to degrees if they are in radians.
+    ! If the input latitudes are in decreasing order, the procedure
+    ! reverses their order.
+    ! Finally, the procedure adds 90° as the last value of the array.
+
+    use assert_eq_m, only: assert_eq
+    use comconst_mod, only: pi
+
+    IMPLICIT NONE
+
+    REAL, intent(in):: xi(:)
+    ! (latitude, in degrees or radians, in increasing or decreasing order)
+    ! ("xi" should contain latitudes from pole to pole.
+    ! "xi" should contain the latitudes of the boundaries of grid
+    ! cells, not the centers of grid cells.
+    ! So the extreme values should not be 90° and -90°.)
+
+    REAL, intent(out):: xo(:) ! angles in degrees
+    LOGICAL, intent(out):: decrois
+
+    ! Variables  local to the procedure:
+    INTEGER nmax, i
+
+    !--------------------
+
+    nmax = assert_eq(size(xi), size(xo) - 1, "ord_coord")
+
+    ! Check monotonicity:
+    decrois = xi(2) < xi(1)
+    DO i = 3, nmax
+       IF (decrois .neqv. xi(i) < xi(i-1)) stop &
+            '"ord_coord":  latitudes are not monotonic'
+    ENDDO
+
+    IF (abs(xi(1)) < pi) then
+       ! "xi" contains latitudes in radians
+       xo(:nmax) = xi(:) * 180. / pi
+    else
+       ! "xi" contains latitudes in degrees
+       xo(:nmax) = xi(:)
+    end IF
+
+    IF (ABS(abs(xo(1)) - 90) < 0.001 .or. ABS(abs(xo(nmax)) - 90) < 0.001) THEN
+       print *, "ord_coord"
+       PRINT *, '"xi" should contain the latitudes of the boundaries of ' &
+            // 'grid cells, not the centers of grid cells.'
+       STOP
+    ENDIF
+
+    IF (decrois) xo(:nmax) = xo(nmax:1:- 1)
+    xo(nmax + 1) = 90.
+
+  END SUBROUTINE ord_coord
+
+  !***********************************
+
+  function ord_coordm(xi)
+
+    ! This procedure converts to degrees, if necessary, and inverts the
+    ! order.
+
+    use comconst_mod, only: pi
+
+    IMPLICIT NONE
+
+    REAL, intent(in):: xi(:) ! angle, in rad or degrees
+    REAL ord_coordm(size(xi)) ! angle, in degrees
+
+    !-----------------------------
+
+    IF (xi(1) < 6.5) THEN
+       ! "xi" is in rad
+       ord_coordm(:) = xi(size(xi):1:-1) * 180. / pi
+    else
+       ! "xi" is in degrees
+       ord_coordm(:) = xi(size(xi):1:-1)
+    ENDIF
+
+  END function ord_coordm
+
+end module inter_barxy_m
Index: DZ6/trunk/libf/dyn3d_common/invert_lat.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d_common/invert_lat.F90	(revision 5267)
+++ 	(revision )
@@ -1,21 +1,0 @@
-
-SUBROUTINE invert_lat(xsize,ysize,vsize,field)
-
-    IMPLICIT NONE
- 
-! Input variables
-    INTEGER, INTENT(IN) :: xsize,ysize,vsize
-    REAL, DIMENSION (xsize,ysize,vsize), INTENT(INOUT) :: field
-! Local variables
-    REAL, DIMENSION (xsize,ysize,vsize)                :: f_aux
-    INTEGER :: l,j
- 
-    DO l=1,vsize
-        DO j=1,ysize
-            f_aux(:,j,l)=field(:,ysize+1-j,l)
-	END DO
-    END DO
-    
-    field=f_aux
-
-    END SUBROUTINE invert_lat
Index: /LMDZ6/trunk/libf/dyn3d_common/invert_lat.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d_common/invert_lat.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3d_common/invert_lat.f90	(revision 5268)
@@ -0,0 +1,21 @@
+
+SUBROUTINE invert_lat(xsize,ysize,vsize,field)
+
+    IMPLICIT NONE
+ 
+! Input variables
+    INTEGER, INTENT(IN) :: xsize,ysize,vsize
+    REAL, DIMENSION (xsize,ysize,vsize), INTENT(INOUT) :: field
+! Local variables
+    REAL, DIMENSION (xsize,ysize,vsize)                :: f_aux
+    INTEGER :: l,j
+ 
+    DO l=1,vsize
+        DO j=1,ysize
+            f_aux(:,j,l)=field(:,ysize+1-j,l)
+	END DO
+    END DO
+    
+    field=f_aux
+
+    END SUBROUTINE invert_lat
Index: DZ6/trunk/libf/dyn3d_common/invert_zoom_x_m.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d_common/invert_zoom_x_m.F90	(revision 5267)
+++ 	(revision )
@@ -1,88 +1,0 @@
-module invert_zoom_x_m
-
-  implicit none
-
-  INTEGER, PARAMETER:: nmax = 30000
-
-contains
-
-  subroutine invert_zoom_x(xf, xtild, Xprimt, xlon, xprimm, xuv)
-
-    use coefpoly_m, only: coefpoly
-    use nrtype, only: pi, pi_d, twopi_d, k8
-    use serre_mod, only: clon
-
-    include "dimensions.h"
-    ! for iim
-
-    REAL(K8), intent(in):: Xf(0:), xtild(0:), Xprimt(0:) ! (0:2 * nmax)
-    real, intent(out):: xlon(:), xprimm(:) ! (iim)
-
-    REAL(K8), intent(in):: xuv
-    ! 0. si calcul aux points scalaires 
-    ! 0.5 si calcul aux points U 
-
-    ! Local:
-    REAL(K8) xo1, Xfi, a0, a1, a2, a3, Xf1, Xprimin
-    integer i, it, iter
-    REAL(K8), parameter:: my_eps = 1e-6_k8
-
-    REAL(K8) xxprim(iim), xvrai(iim) 
-    ! intermediary variables because xlon and xprimm are simple precision
-
-    !------------------------------------------------------------------
-
-    DO i = 1, iim
-       Xfi = - pi_d + (i + xuv - 0.75_k8) * twopi_d / iim
-
-       it = 2 * nmax
-       do while (xfi < xf(it) .and. it >= 1)
-          it = it - 1
-       end do
-
-       ! Calcul de Xf(xvrai(i)) 
-
-       xvrai(i) = xtild(it)
-
-       IF (it == 2 * nmax) THEN
-          it = 2 * nmax -1
-       END IF
-
-       CALL coefpoly(Xf(it), Xf(it + 1), Xprimt(it), Xprimt(it + 1), &
-            xtild(it), xtild(it + 1), a0, a1, a2, a3)
-       Xf1 = Xf(it)
-       Xprimin = a1 + xvrai(i) * (2._k8 * a2 + xvrai(i) * 3._k8 * a3)
-       xo1 = xvrai(i)
-       iter = 1
-
-       do
-          xvrai(i) = xvrai(i) - (Xf1 - Xfi) / Xprimin
-          IF (ABS(xvrai(i) - xo1) <= my_eps .or. iter == 300) exit
-          xo1 = xvrai(i)
-          Xf1 = a0 + xvrai(i) * (a1 + xvrai(i) * (a2 + xvrai(i) * a3))
-          Xprimin = a1 + xvrai(i) * (2._k8 * a2 + xvrai(i) * 3._k8 * a3)
-       end DO
-
-       if (ABS(xvrai(i) - xo1) > my_eps) then
-          ! iter == 300
-          print *, 'Pas de solution.'
-          print *, i, xfi
-          STOP 1
-       end if
-
-       xxprim(i) = twopi_d / (iim * Xprimin)
-    end DO
-
-    DO i = 1, iim -1
-       IF (xvrai(i + 1) < xvrai(i)) THEN
-          print *, 'xvrai(', i + 1, ') < xvrai(', i, ')'
-          STOP 1
-       END IF
-    END DO
-
-    xlon = xvrai + clon / 180. * pi
-    xprimm = xxprim
-
-  end subroutine invert_zoom_x
-
-end module invert_zoom_x_m
Index: /LMDZ6/trunk/libf/dyn3d_common/invert_zoom_x_m.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d_common/invert_zoom_x_m.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3d_common/invert_zoom_x_m.f90	(revision 5268)
@@ -0,0 +1,88 @@
+module invert_zoom_x_m
+
+  implicit none
+
+  INTEGER, PARAMETER:: nmax = 30000
+
+contains
+
+  subroutine invert_zoom_x(xf, xtild, Xprimt, xlon, xprimm, xuv)
+
+    use coefpoly_m, only: coefpoly
+    use nrtype, only: pi, pi_d, twopi_d, k8
+    use serre_mod, only: clon
+
+    include "dimensions.h"
+    ! for iim
+
+    REAL(K8), intent(in):: Xf(0:), xtild(0:), Xprimt(0:) ! (0:2 * nmax)
+    real, intent(out):: xlon(:), xprimm(:) ! (iim)
+
+    REAL(K8), intent(in):: xuv
+    ! 0. si calcul aux points scalaires 
+    ! 0.5 si calcul aux points U 
+
+    ! Local:
+    REAL(K8) xo1, Xfi, a0, a1, a2, a3, Xf1, Xprimin
+    integer i, it, iter
+    REAL(K8), parameter:: my_eps = 1e-6_k8
+
+    REAL(K8) xxprim(iim), xvrai(iim) 
+    ! intermediary variables because xlon and xprimm are simple precision
+
+    !------------------------------------------------------------------
+
+    DO i = 1, iim
+       Xfi = - pi_d + (i + xuv - 0.75_k8) * twopi_d / iim
+
+       it = 2 * nmax
+       do while (xfi < xf(it) .and. it >= 1)
+          it = it - 1
+       end do
+
+       ! Calcul de Xf(xvrai(i)) 
+
+       xvrai(i) = xtild(it)
+
+       IF (it == 2 * nmax) THEN
+          it = 2 * nmax -1
+       END IF
+
+       CALL coefpoly(Xf(it), Xf(it + 1), Xprimt(it), Xprimt(it + 1), &
+            xtild(it), xtild(it + 1), a0, a1, a2, a3)
+       Xf1 = Xf(it)
+       Xprimin = a1 + xvrai(i) * (2._k8 * a2 + xvrai(i) * 3._k8 * a3)
+       xo1 = xvrai(i)
+       iter = 1
+
+       do
+          xvrai(i) = xvrai(i) - (Xf1 - Xfi) / Xprimin
+          IF (ABS(xvrai(i) - xo1) <= my_eps .or. iter == 300) exit
+          xo1 = xvrai(i)
+          Xf1 = a0 + xvrai(i) * (a1 + xvrai(i) * (a2 + xvrai(i) * a3))
+          Xprimin = a1 + xvrai(i) * (2._k8 * a2 + xvrai(i) * 3._k8 * a3)
+       end DO
+
+       if (ABS(xvrai(i) - xo1) > my_eps) then
+          ! iter == 300
+          print *, 'Pas de solution.'
+          print *, i, xfi
+          STOP 1
+       end if
+
+       xxprim(i) = twopi_d / (iim * Xprimin)
+    end DO
+
+    DO i = 1, iim -1
+       IF (xvrai(i + 1) < xvrai(i)) THEN
+          print *, 'xvrai(', i + 1, ') < xvrai(', i, ')'
+          STOP 1
+       END IF
+    END DO
+
+    xlon = xvrai + clon / 180. * pi
+    xprimm = xxprim
+
+  end subroutine invert_zoom_x
+
+end module invert_zoom_x_m
Index: DZ6/trunk/libf/dyn3d_common/iso_verif_dyn.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d_common/iso_verif_dyn.F90	(revision 5267)
+++ 	(revision )
@@ -1,65 +1,0 @@
-LOGICAL FUNCTION iso_verif_noNaN_nostop(x, err_msg) RESULT(lerr)
-   IMPLICIT NONE
-! If "x" is NaN, print an error message .
-   REAL,             INTENT(IN) :: x
-   CHARACTER(LEN=*), INTENT(IN) :: err_msg
-   REAL, PARAMETER :: borne = 1e19
-   lerr = x > -borne .AND. x < borne
-   IF(.NOT.lerr) RETURN
-   WRITE(*,*) 'erreur detectee par iso_verif_nonNaN:'
-   WRITE(*,*) err_msg
-   WRITE(*,*) 'x=',x
-END FUNCTION iso_verif_noNaN_nostop
-
-
-LOGICAL FUNCTION iso_verif_egalite_nostop(a, b, err_msg) RESULT(lerr)
-   IMPLICIT NONE
-!   Compare "a" and "b". If a/=b, print an error message.
-!   Both absolute and relative errors are checked for equality.
-   REAL,             INTENT(IN) :: a, b
-   CHARACTER(LEN=*), INTENT(IN) :: err_msg
-   REAL, PARAMETER :: errmax = 1e-8, &           ! max absolute error
-                   errmaxrel = 1e-3              ! max relative error
-   lerr = ABS(a-b) > errmax
-   IF(.NOT.lerr) RETURN
-   lerr = ABS( (a-b) / MAX(MAX(ABS(b), ABS(a)),1e-18) ) > errmaxrel
-   IF(.NOT.lerr) RETURN
-   WRITE(*,*) 'erreur detectee par iso_verif_egalite:'
-   WRITE(*,*) err_msg
-   WRITE(*,*) 'a=',a
-   WRITE(*,*) 'b=',b
-END FUNCTION iso_verif_egalite_nostop
-
-
-LOGICAL FUNCTION iso_verif_aberrant_nostop(x, iso, q, err_msg) RESULT(lerr)
-   USE IOIPSL, ONLY: getin
-   USE iso_params_mod, ONLY: tnat_HDO
-   IMPLICIT NONE
-   REAL,             INTENT(IN) :: x, q
-   INTEGER,          INTENT(IN) :: iso ! 2=HDO, 1=O18
-   CHARACTER(LEN=*), INTENT(IN) :: err_msg
-
-   REAL, PARAMETER :: qmin = 1e-11, &
-                 deltaDmax = 200.0, &
-                 deltaDmin =-999.9
-   LOGICAL       :: ltnat1
-   LOGICAL, SAVE :: lFirst=.TRUE.
-   REAL,    SAVE :: tnat
-   REAL          :: deltaD
-   IF(lFirst) THEN
-      ltnat1 = .TRUE.; CALL getin('tnateq1', ltnat1)
-      tnat = tnat_HDO; IF(ltnat1) tnat = 1.0
-      lFirst = .FALSE.
-   END IF
-   lerr = q > qmin
-   IF(.NOT.lerr) RETURN
-   deltaD = (x / q /tnat - 1.) * 1000.
-   lerr = deltaD > deltaDmax .OR. deltaD < deltaDmin
-   IF(.NOT.lerr) RETURN
-   WRITE(*,*) 'erreur detectee par iso_verif_aberrant:'
-   WRITE(*,*) err_msg
-   WRITE(*,*) 'q=',q
-   WRITE(*,*) 'deltaD=',deltaD
-   WRITE(*,*) 'iso=',iso
-END FUNCTION iso_verif_aberrant_nostop
-
Index: /LMDZ6/trunk/libf/dyn3d_common/iso_verif_dyn.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d_common/iso_verif_dyn.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3d_common/iso_verif_dyn.f90	(revision 5268)
@@ -0,0 +1,65 @@
+LOGICAL FUNCTION iso_verif_noNaN_nostop(x, err_msg) RESULT(lerr)
+   IMPLICIT NONE
+! If "x" is NaN, print an error message .
+   REAL,             INTENT(IN) :: x
+   CHARACTER(LEN=*), INTENT(IN) :: err_msg
+   REAL, PARAMETER :: borne = 1e19
+   lerr = x > -borne .AND. x < borne
+   IF(.NOT.lerr) RETURN
+   WRITE(*,*) 'erreur detectee par iso_verif_nonNaN:'
+   WRITE(*,*) err_msg
+   WRITE(*,*) 'x=',x
+END FUNCTION iso_verif_noNaN_nostop
+
+
+LOGICAL FUNCTION iso_verif_egalite_nostop(a, b, err_msg) RESULT(lerr)
+   IMPLICIT NONE
+!   Compare "a" and "b". If a/=b, print an error message.
+!   Both absolute and relative errors are checked for equality.
+   REAL,             INTENT(IN) :: a, b
+   CHARACTER(LEN=*), INTENT(IN) :: err_msg
+   REAL, PARAMETER :: errmax = 1e-8, &           ! max absolute error
+                   errmaxrel = 1e-3              ! max relative error
+   lerr = ABS(a-b) > errmax
+   IF(.NOT.lerr) RETURN
+   lerr = ABS( (a-b) / MAX(MAX(ABS(b), ABS(a)),1e-18) ) > errmaxrel
+   IF(.NOT.lerr) RETURN
+   WRITE(*,*) 'erreur detectee par iso_verif_egalite:'
+   WRITE(*,*) err_msg
+   WRITE(*,*) 'a=',a
+   WRITE(*,*) 'b=',b
+END FUNCTION iso_verif_egalite_nostop
+
+
+LOGICAL FUNCTION iso_verif_aberrant_nostop(x, iso, q, err_msg) RESULT(lerr)
+   USE IOIPSL, ONLY: getin
+   USE iso_params_mod, ONLY: tnat_HDO
+   IMPLICIT NONE
+   REAL,             INTENT(IN) :: x, q
+   INTEGER,          INTENT(IN) :: iso ! 2=HDO, 1=O18
+   CHARACTER(LEN=*), INTENT(IN) :: err_msg
+
+   REAL, PARAMETER :: qmin = 1e-11, &
+                 deltaDmax = 200.0, &
+                 deltaDmin =-999.9
+   LOGICAL       :: ltnat1
+   LOGICAL, SAVE :: lFirst=.TRUE.
+   REAL,    SAVE :: tnat
+   REAL          :: deltaD
+   IF(lFirst) THEN
+      ltnat1 = .TRUE.; CALL getin('tnateq1', ltnat1)
+      tnat = tnat_HDO; IF(ltnat1) tnat = 1.0
+      lFirst = .FALSE.
+   END IF
+   lerr = q > qmin
+   IF(.NOT.lerr) RETURN
+   deltaD = (x / q /tnat - 1.) * 1000.
+   lerr = deltaD > deltaDmax .OR. deltaD < deltaDmin
+   IF(.NOT.lerr) RETURN
+   WRITE(*,*) 'erreur detectee par iso_verif_aberrant:'
+   WRITE(*,*) err_msg
+   WRITE(*,*) 'q=',q
+   WRITE(*,*) 'deltaD=',deltaD
+   WRITE(*,*) 'iso=',iso
+END FUNCTION iso_verif_aberrant_nostop
+
Index: DZ6/trunk/libf/dyn3d_common/massbar.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d_common/massbar.F90	(revision 5267)
+++ 	(revision )
@@ -1,66 +1,0 @@
-SUBROUTINE massbar(masse,massebx,masseby)
-!
-!-------------------------------------------------------------------------------
-! Authors: P. Le Van , Fr. Hourdin.
-!-------------------------------------------------------------------------------
-! Purpose: Compute air mass mean along X and Y in each cell.
-! See iniconst for more details.
-  IMPLICIT NONE
-  include "dimensions.h"
-  include "paramet.h"
-  include "comgeom.h"
-!===============================================================================
-! Arguments:
-  REAL, INTENT(IN)  :: masse  (ip1jmp1,llm)
-  REAL, INTENT(OUT) :: massebx(ip1jmp1,llm)
-  REAL, INTENT(OUT) :: masseby(ip1jm  ,llm)
-!-------------------------------------------------------------------------------
-! Method used. Each scalar point is associated to 4 area coefficients:
-!    * alpha1(i,j) at point ( i+1/4,j-1/4 )
-!    * alpha2(i,j) at point ( i+1/4,j+1/4 )
-!    * alpha3(i,j) at point ( i-1/4,j+1/4 )
-!    * alpha4(i,j) at point ( i-1/4,j-1/4 )
-! where alpha1(i,j) = aire(i+1/4,j-1/4)/ aire(i,j)
-!
-!   alpha4 .         . alpha1    . alpha4
-!    (i,j)             (i,j)       (i+1,j)
-!
-!             P .        U .          . P
-!           (i,j)       (i,j)         (i+1,j)
-!
-!   alpha3 .         . alpha2    .alpha3 
-!    (i,j)              (i,j)     (i+1,j)
-!
-!             V .        Z .          . V
-!           (i,j)
-!
-!   alpha4 .         . alpha1    .alpha4
-!   (i,j+1)            (i,j+1)   (i+1,j+1) 
-!
-!             P .        U .          . P
-!          (i,j+1)                    (i+1,j+1)
-!
-!
-!    massebx(i,j) = masse(i  ,j) * ( alpha1(i  ,j) + alpha2(i,j))   +
-!                   masse(i+1,j) * ( alpha3(i+1,j) + alpha4(i+1,j) )
-!     localized at point  ... U (i,j) ...
-!
-!    masseby(i,j) = masse(i,j  ) * ( alpha2(i,j  ) + alpha3(i,j  )  +
-!                   masse(i,j+1) * ( alpha1(i,j+1) + alpha4(i,j+1)  
-!     localized at point  ... V (i,j) ...
-!===============================================================================
-! Local variables:
-  INTEGER :: ij, l
-!===============================================================================
-  DO l=1,llm
-    DO ij=1,ip1jmp1-1
-      massebx(ij,l)=masse(ij,l)*alpha1p2(ij)+masse(ij+1   ,l)*alpha3p4(ij+1)
-    END DO
-    DO ij=iip1,ip1jmp1,iip1; massebx(ij,l)=massebx(ij-iim,l); END DO
-    DO ij=1,ip1jm
-      masseby(ij,l)=masse(ij,l)*alpha2p3(ij)+masse(ij+iip1,l)*alpha1p4(ij+iip1)
-    END DO
-  END DO
-
-END SUBROUTINE massbar
-
Index: /LMDZ6/trunk/libf/dyn3d_common/massbar.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d_common/massbar.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3d_common/massbar.f90	(revision 5268)
@@ -0,0 +1,66 @@
+SUBROUTINE massbar(masse,massebx,masseby)
+!
+!-------------------------------------------------------------------------------
+! Authors: P. Le Van , Fr. Hourdin.
+!-------------------------------------------------------------------------------
+! Purpose: Compute air mass mean along X and Y in each cell.
+! See iniconst for more details.
+  IMPLICIT NONE
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom.h"
+!===============================================================================
+! Arguments:
+  REAL, INTENT(IN)  :: masse  (ip1jmp1,llm)
+  REAL, INTENT(OUT) :: massebx(ip1jmp1,llm)
+  REAL, INTENT(OUT) :: masseby(ip1jm  ,llm)
+!-------------------------------------------------------------------------------
+! Method used. Each scalar point is associated to 4 area coefficients:
+!    * alpha1(i,j) at point ( i+1/4,j-1/4 )
+!    * alpha2(i,j) at point ( i+1/4,j+1/4 )
+!    * alpha3(i,j) at point ( i-1/4,j+1/4 )
+!    * alpha4(i,j) at point ( i-1/4,j-1/4 )
+! where alpha1(i,j) = aire(i+1/4,j-1/4)/ aire(i,j)
+!
+!   alpha4 .         . alpha1    . alpha4
+!    (i,j)             (i,j)       (i+1,j)
+!
+!             P .        U .          . P
+!           (i,j)       (i,j)         (i+1,j)
+!
+!   alpha3 .         . alpha2    .alpha3 
+!    (i,j)              (i,j)     (i+1,j)
+!
+!             V .        Z .          . V
+!           (i,j)
+!
+!   alpha4 .         . alpha1    .alpha4
+!   (i,j+1)            (i,j+1)   (i+1,j+1) 
+!
+!             P .        U .          . P
+!          (i,j+1)                    (i+1,j+1)
+!
+!
+!    massebx(i,j) = masse(i  ,j) * ( alpha1(i  ,j) + alpha2(i,j))   +
+!                   masse(i+1,j) * ( alpha3(i+1,j) + alpha4(i+1,j) )
+!     localized at point  ... U (i,j) ...
+!
+!    masseby(i,j) = masse(i,j  ) * ( alpha2(i,j  ) + alpha3(i,j  )  +
+!                   masse(i,j+1) * ( alpha1(i,j+1) + alpha4(i,j+1)  
+!     localized at point  ... V (i,j) ...
+!===============================================================================
+! Local variables:
+  INTEGER :: ij, l
+!===============================================================================
+  DO l=1,llm
+    DO ij=1,ip1jmp1-1
+      massebx(ij,l)=masse(ij,l)*alpha1p2(ij)+masse(ij+1   ,l)*alpha3p4(ij+1)
+    END DO
+    DO ij=iip1,ip1jmp1,iip1; massebx(ij,l)=massebx(ij-iim,l); END DO
+    DO ij=1,ip1jm
+      masseby(ij,l)=masse(ij,l)*alpha2p3(ij)+masse(ij+iip1,l)*alpha1p4(ij+iip1)
+    END DO
+  END DO
+
+END SUBROUTINE massbar
+
Index: DZ6/trunk/libf/dyn3d_common/massbarxy.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d_common/massbarxy.F90	(revision 5267)
+++ 	(revision )
@@ -1,30 +1,0 @@
-SUBROUTINE massbarxy(masse,massebxy)
-!
-!-------------------------------------------------------------------------------
-! Authors: P. Le Van , Fr. Hourdin.
-!-------------------------------------------------------------------------------
-! Purpose: Compute air mass mean along X and Y in each cell.
-! See iniconst for more details.
-  IMPLICIT NONE
-  include "dimensions.h"
-  include "paramet.h"
-  include "comgeom.h"
-!===============================================================================
-! Arguments:
-  REAL, INTENT(IN)  :: masse   (ip1jmp1,llm)
-  REAL, INTENT(OUT) :: massebxy(ip1jm  ,llm)
-!===============================================================================
-! Local variables:
-  INTEGER :: ij, l
-!===============================================================================
-  DO l=1,llm
-    DO ij=1,ip1jm-1
-      massebxy(ij,l)=masse(ij     ,l)*alpha2(ij     ) + &
-     +               masse(ij+1   ,l)*alpha3(ij+1   ) + &
-     +               masse(ij+iip1,l)*alpha1(ij+iip1) + &
-     +               masse(ij+iip2,l)*alpha4(ij+iip2)
-    END DO
-    DO ij=iip1,ip1jm,iip1; massebxy(ij,l)=massebxy(ij-iim,l); END DO
-  END DO
-
-END SUBROUTINE massbarxy
Index: /LMDZ6/trunk/libf/dyn3d_common/massbarxy.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d_common/massbarxy.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3d_common/massbarxy.f90	(revision 5268)
@@ -0,0 +1,30 @@
+SUBROUTINE massbarxy(masse,massebxy)
+!
+!-------------------------------------------------------------------------------
+! Authors: P. Le Van , Fr. Hourdin.
+!-------------------------------------------------------------------------------
+! Purpose: Compute air mass mean along X and Y in each cell.
+! See iniconst for more details.
+  IMPLICIT NONE
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom.h"
+!===============================================================================
+! Arguments:
+  REAL, INTENT(IN)  :: masse   (ip1jmp1,llm)
+  REAL, INTENT(OUT) :: massebxy(ip1jm  ,llm)
+!===============================================================================
+! Local variables:
+  INTEGER :: ij, l
+!===============================================================================
+  DO l=1,llm
+    DO ij=1,ip1jm-1
+      massebxy(ij,l)=masse(ij     ,l)*alpha2(ij     ) + &
+     +               masse(ij+1   ,l)*alpha3(ij+1   ) + &
+     +               masse(ij+iip1,l)*alpha1(ij+iip1) + &
+     +               masse(ij+iip2,l)*alpha4(ij+iip2)
+    END DO
+    DO ij=iip1,ip1jm,iip1; massebxy(ij,l)=massebxy(ij-iim,l); END DO
+  END DO
+
+END SUBROUTINE massbarxy
Index: DZ6/trunk/libf/dyn3d_common/misc_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d_common/misc_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,6 +1,0 @@
-module misc_mod
-  integer,save :: itaumax
-  logical,save :: adjust
-  integer,save :: ItCount
-  logical,save :: debug
-end module misc_mod 
Index: /LMDZ6/trunk/libf/dyn3d_common/misc_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d_common/misc_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3d_common/misc_mod.f90	(revision 5268)
@@ -0,0 +1,6 @@
+module misc_mod
+  integer,save :: itaumax
+  logical,save :: adjust
+  integer,save :: ItCount
+  logical,save :: debug
+end module misc_mod 
Index: DZ6/trunk/libf/dyn3d_common/pression.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d_common/pression.F90	(revision 5267)
+++ 	(revision )
@@ -1,27 +1,0 @@
-SUBROUTINE pression( ngrid, ap, bp, ps, p )
-!
-!-------------------------------------------------------------------------------
-! Authors: P. Le Van , Fr.Hourdin 
-!-------------------------------------------------------------------------------
-! Purpose: Compute pressure p(l) at different levels from l = 1 (ground level)
-!          to l = llm +1. Those levels correspond to the llm layers interfaces,
-!          with p(ij,llm+1) = 0. and  p(ij,1) = ps(ij)  .   
-!-------------------------------------------------------------------------------
-  IMPLICIT NONE
-  include "dimensions.h"
-  include "paramet.h"
-!===============================================================================
-! Arguments:
-  INTEGER, INTENT(IN)  :: ngrid                 !--- NUMBER OF GRID POINTS
-  REAL,    INTENT(IN)  :: ap(llmp1), bp(llmp1)  !--- HYBRID COEFFICIENTS
-  REAL,    INTENT(IN)  :: ps(ngrid)             !--- SURFACE PRESSURE
-  REAL,    INTENT(OUT) :: p(ngrid,llmp1)        !--- 3D PRESSURE FIELD 
-!===============================================================================
-! Local variables:
-  INTEGER :: l
-!===============================================================================
-  DO l=1,llmp1;  p(:,l) = ap(l) + bp(l) * ps(:);  END DO
-
-END SUBROUTINE pression
-
-
Index: /LMDZ6/trunk/libf/dyn3d_common/pression.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d_common/pression.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3d_common/pression.f90	(revision 5268)
@@ -0,0 +1,27 @@
+SUBROUTINE pression( ngrid, ap, bp, ps, p )
+!
+!-------------------------------------------------------------------------------
+! Authors: P. Le Van , Fr.Hourdin 
+!-------------------------------------------------------------------------------
+! Purpose: Compute pressure p(l) at different levels from l = 1 (ground level)
+!          to l = llm +1. Those levels correspond to the llm layers interfaces,
+!          with p(ij,llm+1) = 0. and  p(ij,1) = ps(ij)  .   
+!-------------------------------------------------------------------------------
+  IMPLICIT NONE
+  include "dimensions.h"
+  include "paramet.h"
+!===============================================================================
+! Arguments:
+  INTEGER, INTENT(IN)  :: ngrid                 !--- NUMBER OF GRID POINTS
+  REAL,    INTENT(IN)  :: ap(llmp1), bp(llmp1)  !--- HYBRID COEFFICIENTS
+  REAL,    INTENT(IN)  :: ps(ngrid)             !--- SURFACE PRESSURE
+  REAL,    INTENT(OUT) :: p(ngrid,llmp1)        !--- 3D PRESSURE FIELD 
+!===============================================================================
+! Local variables:
+  INTEGER :: l
+!===============================================================================
+  DO l=1,llmp1;  p(:,l) = ap(l) + bp(l) * ps(:);  END DO
+
+END SUBROUTINE pression
+
+
Index: DZ6/trunk/libf/dyn3d_common/principal_cshift_m.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d_common/principal_cshift_m.F90	(revision 5267)
+++ 	(revision )
@@ -1,43 +1,0 @@
-module principal_cshift_m
-
-  implicit none
-
-contains
-
-  subroutine principal_cshift(is2, xlon, xprimm)
-
-    ! Add or subtract 2 pi so that xlon is near [-pi, pi], then cshift
-    ! so that xlon is in ascending order. Make the same cshift on
-    ! xprimm.
-
-    use nrtype, only: twopi
-    use serre_mod, only: clon
-
-    include "dimensions.h"
-    ! for iim
-
-    integer, intent(in):: is2
-    real, intent(inout):: xlon(:), xprimm(:) ! (iim + 1)
-
-    !-----------------------------------------------------
-
-    if (is2 /= 0) then
-       IF (clon <= 0.) THEN
-          IF (is2 /= 1) THEN
-             xlon(:is2 - 1) = xlon(:is2 - 1) + twopi
-             xlon(:iim) = cshift(xlon(:iim), shift = is2 - 1)
-             xprimm(:iim) = cshift(xprimm(:iim), shift = is2 - 1)
-          END IF
-       else
-          xlon(is2 + 1:iim) = xlon(is2 + 1:iim) - twopi
-          xlon(:iim) = cshift(xlon(:iim), shift = is2)
-          xprimm(:iim) = cshift(xprimm(:iim), shift = is2)
-       end IF
-    end if
-
-    xlon(iim + 1) = xlon(1) + twopi
-    xprimm(iim + 1) = xprimm(1)
-
-  end subroutine principal_cshift
-
-end module principal_cshift_m
Index: /LMDZ6/trunk/libf/dyn3d_common/principal_cshift_m.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d_common/principal_cshift_m.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3d_common/principal_cshift_m.f90	(revision 5268)
@@ -0,0 +1,43 @@
+module principal_cshift_m
+
+  implicit none
+
+contains
+
+  subroutine principal_cshift(is2, xlon, xprimm)
+
+    ! Add or subtract 2 pi so that xlon is near [-pi, pi], then cshift
+    ! so that xlon is in ascending order. Make the same cshift on
+    ! xprimm.
+
+    use nrtype, only: twopi
+    use serre_mod, only: clon
+
+    include "dimensions.h"
+    ! for iim
+
+    integer, intent(in):: is2
+    real, intent(inout):: xlon(:), xprimm(:) ! (iim + 1)
+
+    !-----------------------------------------------------
+
+    if (is2 /= 0) then
+       IF (clon <= 0.) THEN
+          IF (is2 /= 1) THEN
+             xlon(:is2 - 1) = xlon(:is2 - 1) + twopi
+             xlon(:iim) = cshift(xlon(:iim), shift = is2 - 1)
+             xprimm(:iim) = cshift(xprimm(:iim), shift = is2 - 1)
+          END IF
+       else
+          xlon(is2 + 1:iim) = xlon(is2 + 1:iim) - twopi
+          xlon(:iim) = cshift(xlon(:iim), shift = is2)
+          xprimm(:iim) = cshift(xprimm(:iim), shift = is2)
+       end IF
+    end if
+
+    xlon(iim + 1) = xlon(1) + twopi
+    xprimm(iim + 1) = xprimm(1)
+
+  end subroutine principal_cshift
+
+end module principal_cshift_m
Index: DZ6/trunk/libf/dyn3d_common/serre_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d_common/serre_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,11 +1,0 @@
-!
-! $Id$
-!
-MODULE serre_mod
-
-IMPLICIT NONE  
-
-      REAL clon,clat,transx,transy,alphax,alphay,pxo,pyo,              &
-        grossismx, grossismy, dzoomx, dzoomy,taux,tauy
-
-END MODULE serre_mod
Index: /LMDZ6/trunk/libf/dyn3d_common/serre_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d_common/serre_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3d_common/serre_mod.f90	(revision 5268)
@@ -0,0 +1,11 @@
+!
+! $Id$
+!
+MODULE serre_mod
+
+IMPLICIT NONE  
+
+      REAL clon,clat,transx,transy,alphax,alphay,pxo,pyo,              &
+        grossismx, grossismy, dzoomx, dzoomy,taux,tauy
+
+END MODULE serre_mod
Index: DZ6/trunk/libf/dyn3d_common/tourpot.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d_common/tourpot.F90	(revision 5267)
+++ 	(revision )
@@ -1,45 +1,0 @@
-SUBROUTINE tourpot ( vcov, ucov, massebxy, vorpot )
-!
-!-------------------------------------------------------------------------------
-! Authors: P. Le Van.
-!-------------------------------------------------------------------------------
-! Purpose: Compute potential vorticity.
-  IMPLICIT NONE
-  include "dimensions.h"
-  include "paramet.h"
-  include "comgeom.h"
-!===============================================================================
-! Arguments:
-  REAL, INTENT(IN)  :: vcov    (ip1jm,  llm)
-  REAL, INTENT(IN)  :: ucov    (ip1jmp1,llm)
-  REAL, INTENT(IN)  :: massebxy(ip1jm,  llm)
-  REAL, INTENT(OUT) :: vorpot  (ip1jm,  llm)
-!===============================================================================
-! Method used:
-!   vorpot = ( Filtre( d(vcov)/dx - d(ucov)/dy ) + fext ) /psbarxy
-!===============================================================================
-! Local variables:
-  INTEGER :: l, ij
-  REAL    :: rot(ip1jm,llm)
-!===============================================================================
-
-!--- Wind vorticity ; correction: rot(iip1,j,l) = rot(1,j,l)
-  DO l=1,llm
-    DO ij=1,ip1jm-1
-      rot(ij,l)=vcov(ij+1,l)-vcov(ij,l)+ucov(ij+iip1,l)-ucov(ij,l)
-    END DO
-    DO ij=iip1,ip1jm,iip1; rot(ij,l)=rot(ij-iim,l); END DO
-  END DO
-
-!--- Filter
-  CALL  filtreg(rot,jjm,llm,2,1,.FALSE.,1)
-
-!--- Potential vorticity ; correction: rot(iip1,j,l) = rot(1,j,l)
-  DO l=1,llm
-    DO ij=1,ip1jm-1
-      vorpot(ij,l)=(rot(ij,l)+fext(ij))/massebxy(ij,l)
-    END DO
-    DO ij=iip1,ip1jm,iip1; vorpot(ij,l)=vorpot(ij-iim,l); END DO
-  END DO
-
-END SUBROUTINE tourpot
Index: /LMDZ6/trunk/libf/dyn3d_common/tourpot.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d_common/tourpot.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3d_common/tourpot.f90	(revision 5268)
@@ -0,0 +1,45 @@
+SUBROUTINE tourpot ( vcov, ucov, massebxy, vorpot )
+!
+!-------------------------------------------------------------------------------
+! Authors: P. Le Van.
+!-------------------------------------------------------------------------------
+! Purpose: Compute potential vorticity.
+  IMPLICIT NONE
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom.h"
+!===============================================================================
+! Arguments:
+  REAL, INTENT(IN)  :: vcov    (ip1jm,  llm)
+  REAL, INTENT(IN)  :: ucov    (ip1jmp1,llm)
+  REAL, INTENT(IN)  :: massebxy(ip1jm,  llm)
+  REAL, INTENT(OUT) :: vorpot  (ip1jm,  llm)
+!===============================================================================
+! Method used:
+!   vorpot = ( Filtre( d(vcov)/dx - d(ucov)/dy ) + fext ) /psbarxy
+!===============================================================================
+! Local variables:
+  INTEGER :: l, ij
+  REAL    :: rot(ip1jm,llm)
+!===============================================================================
+
+!--- Wind vorticity ; correction: rot(iip1,j,l) = rot(1,j,l)
+  DO l=1,llm
+    DO ij=1,ip1jm-1
+      rot(ij,l)=vcov(ij+1,l)-vcov(ij,l)+ucov(ij+iip1,l)-ucov(ij,l)
+    END DO
+    DO ij=iip1,ip1jm,iip1; rot(ij,l)=rot(ij-iim,l); END DO
+  END DO
+
+!--- Filter
+  CALL  filtreg(rot,jjm,llm,2,1,.FALSE.,1)
+
+!--- Potential vorticity ; correction: rot(iip1,j,l) = rot(1,j,l)
+  DO l=1,llm
+    DO ij=1,ip1jm-1
+      vorpot(ij,l)=(rot(ij,l)+fext(ij))/massebxy(ij,l)
+    END DO
+    DO ij=iip1,ip1jm,iip1; vorpot(ij,l)=vorpot(ij-iim,l); END DO
+  END DO
+
+END SUBROUTINE tourpot
Index: DZ6/trunk/libf/dyn3d_common/ugeostr.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d_common/ugeostr.F90	(revision 5267)
+++ 	(revision )
@@ -1,69 +1,0 @@
-!
-! $Id$
-!
-subroutine ugeostr(phi,ucov)
-
-  ! Calcul du vent covariant geostrophique a partir du champ de
-  ! geopotentiel.
-  ! We actually compute: (1 - cos^8 \phi) u_g
-  ! to have a wind going smoothly to 0 at the equator.
-  ! We assume that the surface pressure is uniform so that model
-  ! levels are pressure levels.
-
-  use comconst_mod, only: omeg, rad
-  
-  implicit none
-
-  include "dimensions.h"
-  include "paramet.h"
-  include "comgeom2.h"
-
-  real ucov(iip1,jjp1,llm),phi(iip1,jjp1,llm)
-  real um(jjm,llm),fact,u(iip1,jjm,llm)
-  integer i,j,l
-
-  real zlat
-
-  um(:,:)=0 ! initialize um()
-
-  DO j=1,jjm
-
-     if (abs(sin(rlatv(j))).lt.1.e-4) then
-        zlat=1.e-4
-     else
-        zlat=rlatv(j)
-     endif
-     fact=cos(zlat)
-     fact=fact*fact
-     fact=fact*fact
-     fact=fact*fact
-     fact=(1.-fact)/ &
-          (2.*omeg*sin(zlat)*(rlatu(j+1)-rlatu(j)))
-     fact=-fact/rad
-     DO l=1,llm
-        DO i=1,iim
-           u(i,j,l)=fact*(phi(i,j+1,l)-phi(i,j,l))
-           um(j,l)=um(j,l)+u(i,j,l)/REAL(iim)
-        ENDDO
-     ENDDO
-  ENDDO
-  call dump2d(jjm,llm,um,'Vent-u geostrophique')
-
-  !   calcul des champ de vent:
-
-  DO l=1,llm
-     DO i=1,iip1
-        ucov(i,1,l)=0.
-        ucov(i,jjp1,l)=0.
-     end DO
-     DO  j=2,jjm
-        DO  i=1,iim
-           ucov(i,j,l) = 0.5*(u(i,j,l)+u(i,j-1,l))*cu(i,j)
-        end DO
-        ucov(iip1,j,l)=ucov(1,j,l)
-     end DO
-  end DO
-
-  print *, 301
-
-end subroutine ugeostr
Index: /LMDZ6/trunk/libf/dyn3d_common/ugeostr.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d_common/ugeostr.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3d_common/ugeostr.f90	(revision 5268)
@@ -0,0 +1,69 @@
+!
+! $Id$
+!
+subroutine ugeostr(phi,ucov)
+
+  ! Calcul du vent covariant geostrophique a partir du champ de
+  ! geopotentiel.
+  ! We actually compute: (1 - cos^8 \phi) u_g
+  ! to have a wind going smoothly to 0 at the equator.
+  ! We assume that the surface pressure is uniform so that model
+  ! levels are pressure levels.
+
+  use comconst_mod, only: omeg, rad
+  
+  implicit none
+
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom2.h"
+
+  real ucov(iip1,jjp1,llm),phi(iip1,jjp1,llm)
+  real um(jjm,llm),fact,u(iip1,jjm,llm)
+  integer i,j,l
+
+  real zlat
+
+  um(:,:)=0 ! initialize um()
+
+  DO j=1,jjm
+
+     if (abs(sin(rlatv(j))).lt.1.e-4) then
+        zlat=1.e-4
+     else
+        zlat=rlatv(j)
+     endif
+     fact=cos(zlat)
+     fact=fact*fact
+     fact=fact*fact
+     fact=fact*fact
+     fact=(1.-fact)/ &
+          (2.*omeg*sin(zlat)*(rlatu(j+1)-rlatu(j)))
+     fact=-fact/rad
+     DO l=1,llm
+        DO i=1,iim
+           u(i,j,l)=fact*(phi(i,j+1,l)-phi(i,j,l))
+           um(j,l)=um(j,l)+u(i,j,l)/REAL(iim)
+        ENDDO
+     ENDDO
+  ENDDO
+  call dump2d(jjm,llm,um,'Vent-u geostrophique')
+
+  !   calcul des champ de vent:
+
+  DO l=1,llm
+     DO i=1,iip1
+        ucov(i,1,l)=0.
+        ucov(i,jjp1,l)=0.
+     end DO
+     DO  j=2,jjm
+        DO  i=1,iim
+           ucov(i,j,l) = 0.5*(u(i,j,l)+u(i,j-1,l))*cu(i,j)
+        end DO
+        ucov(iip1,j,l)=ucov(1,j,l)
+     end DO
+  end DO
+
+  print *, 301
+
+end subroutine ugeostr
Index: DZ6/trunk/libf/dyn3d_common/vitvert.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d_common/vitvert.F90	(revision 5267)
+++ 	(revision )
@@ -1,27 +1,0 @@
-SUBROUTINE vitvert (convm, w)
-!
-!-------------------------------------------------------------------------------
-! Authors: P. Le Van , Fr. Hourdin.
-!-------------------------------------------------------------------------------
-! Purpose: Compute vertical speed at sigma levels.
-  USE comvert_mod, ONLY: bp
-  IMPLICIT NONE
-  include "dimensions.h"
-  include "paramet.h"
-!===============================================================================
-! Arguments:
-  REAL, INTENT(IN)  :: convm(ip1jmp1,llm)
-  REAL, INTENT(OUT) :: w    (ip1jmp1,llm)
-!===============================================================================
-! Notes: Vertical speed is oriented from bottom to top.
-!   * At ground - level sigma(1):     w(i,j,1) = 0.
-!   * At top    - level sigma(llm+1): w(i,j,l) = 0. (not stored in w)
-!===============================================================================
-! Local variables:
-  INTEGER :: l
-!===============================================================================
-  DO l=1,llmm1; w(:,l+1)=convm(:,l+1)-bp(l+1)*convm(:,1); END DO
-  w(:,1)=0.
-
-END SUBROUTINE vitvert
-
Index: /LMDZ6/trunk/libf/dyn3d_common/vitvert.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d_common/vitvert.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3d_common/vitvert.f90	(revision 5268)
@@ -0,0 +1,27 @@
+SUBROUTINE vitvert (convm, w)
+!
+!-------------------------------------------------------------------------------
+! Authors: P. Le Van , Fr. Hourdin.
+!-------------------------------------------------------------------------------
+! Purpose: Compute vertical speed at sigma levels.
+  USE comvert_mod, ONLY: bp
+  IMPLICIT NONE
+  include "dimensions.h"
+  include "paramet.h"
+!===============================================================================
+! Arguments:
+  REAL, INTENT(IN)  :: convm(ip1jmp1,llm)
+  REAL, INTENT(OUT) :: w    (ip1jmp1,llm)
+!===============================================================================
+! Notes: Vertical speed is oriented from bottom to top.
+!   * At ground - level sigma(1):     w(i,j,1) = 0.
+!   * At top    - level sigma(llm+1): w(i,j,l) = 0. (not stored in w)
+!===============================================================================
+! Local variables:
+  INTEGER :: l
+!===============================================================================
+  DO l=1,llmm1; w(:,l+1)=convm(:,l+1)-bp(l+1)*convm(:,1); END DO
+  w(:,1)=0.
+
+END SUBROUTINE vitvert
+
Index: DZ6/trunk/libf/dyn3d_common/writedynav.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d_common/writedynav.F90	(revision 5267)
+++ 	(revision )
@@ -1,131 +1,0 @@
-! $Id$
-
-subroutine writedynav(time, vcov, ucov, teta, ppk, phi, q, masse, ps, phis)
-
-  USE ioipsl
-  USE infotrac, ONLY : nqtot
-  use com_io_dyn_mod, only : histaveid, histvaveid, histuaveid
-  USE comconst_mod, ONLY: cpp
-  USE temps_mod, ONLY: itau_dyn
-
-  implicit none
-
-  !   Ecriture du fichier histoire au format IOIPSL
-
-  !   Appels succesifs des routines: histwrite
-
-  !   Entree:
-  !      time: temps de l'ecriture
-  !      vcov: vents v covariants
-  !      ucov: vents u covariants
-  !      teta: temperature potentielle
-  !      phi : geopotentiel instantane
-  !      q   : traceurs
-  !      masse: masse
-  !      ps   :pression au sol
-  !      phis : geopotentiel au sol
-
-  !   L. Fairhead, LMD, 03/99
-
-  !   Declarations
-  include "dimensions.h"
-  include "paramet.h"
-  include "comgeom.h"
-  include "description.h"
-  include "iniprint.h"
-
-  !   Arguments
-
-  REAL vcov(ip1jm, llm), ucov(ip1jmp1, llm) 
-  REAL teta(ip1jmp1*llm), phi(ip1jmp1, llm), ppk(ip1jmp1*llm)     
-  REAL ps(ip1jmp1), masse(ip1jmp1, llm)                   
-  REAL phis(ip1jmp1)                  
-  REAL q(ip1jmp1, llm, nqtot)
-  integer time
-
-  ! This routine needs IOIPSL to work
-  !   Variables locales
-
-  integer ndex2d(ip1jmp1), ndexu(ip1jmp1*llm), ndexv(ip1jm*llm)
-  INTEGER iq, ii, ll
-  real tm(ip1jmp1*llm)
-  REAL vnat(ip1jm, llm), unat(ip1jmp1, llm)
-  logical ok_sync
-  integer itau_w
-
-  !-----------------------------------------------------------------
-
-  !  Initialisations
-
-  ndexu = 0
-  ndexv = 0
-  ndex2d = 0
-  ok_sync = .TRUE.
-  tm = 999.999
-  vnat = 999.999
-  unat = 999.999
-  itau_w = itau_dyn + time
-
-  ! Passage aux composantes naturelles du vent
-  call covnat(llm, ucov, vcov, unat, vnat)
-
-  !  Appels a histwrite pour l'ecriture des variables a sauvegarder
-
-  !  Vents U
-
-  call histwrite(histuaveid, 'u', itau_w, unat,  &
-       iip1*jjp1*llm, ndexu)
-
-  !  Vents V
-
-  call histwrite(histvaveid, 'v', itau_w, vnat,  &
-       iip1*jjm*llm, ndexv)
-
-  !  Temperature potentielle moyennee
-
-  call histwrite(histaveid, 'theta', itau_w, teta,  &
-       iip1*jjp1*llm, ndexu)
-
-  !  Temperature moyennee
-
-  do ii = 1, ijp1llm
-     tm(ii) = teta(ii) * ppk(ii)/cpp
-  enddo
-  call histwrite(histaveid, 'temp', itau_w, tm,  &
-       iip1*jjp1*llm, ndexu)
-
-  !  Geopotentiel
-
-  call histwrite(histaveid, 'phi', itau_w, phi,  &
-       iip1*jjp1*llm, ndexu)
-
-  !  Traceurs
-
-  !  DO iq=1, nqtot
-  !       call histwrite(histaveid, tracers(iq)%longName, itau_w, &
-  !                   q(:, :, iq), iip1*jjp1*llm, ndexu)
-  ! enddo
-
-  !  Masse
-
-  call histwrite(histaveid, 'masse', itau_w, masse,  &
-       iip1*jjp1*llm, ndexu)
-
-  !  Pression au sol
-
-  call histwrite(histaveid, 'ps', itau_w, ps, iip1*jjp1, ndex2d)
-
-  ! Geopotentiel au sol
-
-  ! call histwrite(histaveid, 'phis', itau_w, phis, iip1*jjp1, ndex2d)
-
-  if (ok_sync) then
-     call histsync(histaveid)
-     call histsync(histvaveid)
-     call histsync(histuaveid)
-  ENDIF
-
-
-
-
-end subroutine writedynav
Index: /LMDZ6/trunk/libf/dyn3d_common/writedynav.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d_common/writedynav.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3d_common/writedynav.f90	(revision 5268)
@@ -0,0 +1,131 @@
+! $Id$
+
+subroutine writedynav(time, vcov, ucov, teta, ppk, phi, q, masse, ps, phis)
+
+  USE ioipsl
+  USE infotrac, ONLY : nqtot
+  use com_io_dyn_mod, only : histaveid, histvaveid, histuaveid
+  USE comconst_mod, ONLY: cpp
+  USE temps_mod, ONLY: itau_dyn
+
+  implicit none
+
+  !   Ecriture du fichier histoire au format IOIPSL
+
+  !   Appels succesifs des routines: histwrite
+
+  !   Entree:
+  !      time: temps de l'ecriture
+  !      vcov: vents v covariants
+  !      ucov: vents u covariants
+  !      teta: temperature potentielle
+  !      phi : geopotentiel instantane
+  !      q   : traceurs
+  !      masse: masse
+  !      ps   :pression au sol
+  !      phis : geopotentiel au sol
+
+  !   L. Fairhead, LMD, 03/99
+
+  !   Declarations
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom.h"
+  include "description.h"
+  include "iniprint.h"
+
+  !   Arguments
+
+  REAL vcov(ip1jm, llm), ucov(ip1jmp1, llm) 
+  REAL teta(ip1jmp1*llm), phi(ip1jmp1, llm), ppk(ip1jmp1*llm)     
+  REAL ps(ip1jmp1), masse(ip1jmp1, llm)                   
+  REAL phis(ip1jmp1)                  
+  REAL q(ip1jmp1, llm, nqtot)
+  integer time
+
+  ! This routine needs IOIPSL to work
+  !   Variables locales
+
+  integer ndex2d(ip1jmp1), ndexu(ip1jmp1*llm), ndexv(ip1jm*llm)
+  INTEGER iq, ii, ll
+  real tm(ip1jmp1*llm)
+  REAL vnat(ip1jm, llm), unat(ip1jmp1, llm)
+  logical ok_sync
+  integer itau_w
+
+  !-----------------------------------------------------------------
+
+  !  Initialisations
+
+  ndexu = 0
+  ndexv = 0
+  ndex2d = 0
+  ok_sync = .TRUE.
+  tm = 999.999
+  vnat = 999.999
+  unat = 999.999
+  itau_w = itau_dyn + time
+
+  ! Passage aux composantes naturelles du vent
+  call covnat(llm, ucov, vcov, unat, vnat)
+
+  !  Appels a histwrite pour l'ecriture des variables a sauvegarder
+
+  !  Vents U
+
+  call histwrite(histuaveid, 'u', itau_w, unat,  &
+       iip1*jjp1*llm, ndexu)
+
+  !  Vents V
+
+  call histwrite(histvaveid, 'v', itau_w, vnat,  &
+       iip1*jjm*llm, ndexv)
+
+  !  Temperature potentielle moyennee
+
+  call histwrite(histaveid, 'theta', itau_w, teta,  &
+       iip1*jjp1*llm, ndexu)
+
+  !  Temperature moyennee
+
+  do ii = 1, ijp1llm
+     tm(ii) = teta(ii) * ppk(ii)/cpp
+  enddo
+  call histwrite(histaveid, 'temp', itau_w, tm,  &
+       iip1*jjp1*llm, ndexu)
+
+  !  Geopotentiel
+
+  call histwrite(histaveid, 'phi', itau_w, phi,  &
+       iip1*jjp1*llm, ndexu)
+
+  !  Traceurs
+
+  !  DO iq=1, nqtot
+  !       call histwrite(histaveid, tracers(iq)%longName, itau_w, &
+  !                   q(:, :, iq), iip1*jjp1*llm, ndexu)
+  ! enddo
+
+  !  Masse
+
+  call histwrite(histaveid, 'masse', itau_w, masse,  &
+       iip1*jjp1*llm, ndexu)
+
+  !  Pression au sol
+
+  call histwrite(histaveid, 'ps', itau_w, ps, iip1*jjp1, ndex2d)
+
+  ! Geopotentiel au sol
+
+  ! call histwrite(histaveid, 'phis', itau_w, phis, iip1*jjp1, ndex2d)
+
+  if (ok_sync) then
+     call histsync(histaveid)
+     call histsync(histvaveid)
+     call histsync(histuaveid)
+  ENDIF
+
+
+
+
+end subroutine writedynav
Index: DZ6/trunk/libf/dyn3d_common/writehist.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d_common/writehist.F90	(revision 5267)
+++ 	(revision )
@@ -1,125 +1,0 @@
-!
-! $Id$
-!
-subroutine writehist(time,vcov,ucov,teta,phi,q,masse,ps,phis)
-
-  USE ioipsl
-  USE infotrac, ONLY : nqtot
-  use com_io_dyn_mod, only : histid,histvid,histuid
-  USE temps_mod, ONLY: itau_dyn
-
-  implicit none
-
-  !
-  !   Ecriture du fichier histoire au format IOIPSL
-  !
-  !   Appels succesifs des routines: histwrite
-  !
-  !   Entree:
-  !  time: temps de l'ecriture
-  !  vcov: vents v covariants
-  !  ucov: vents u covariants
-  !  teta: temperature potentielle
-  !  phi : geopotentiel instantane
-  !  q   : traceurs
-  !  masse: masse
-  !  ps   :pression au sol
-  !  phis : geopotentiel au sol
-  !
-  !
-  !   L. Fairhead, LMD, 03/99
-  !
-  ! =====================================================================
-  !
-  !   Declarations
-  include "dimensions.h"
-  include "paramet.h"
-  include "comgeom.h"
-  include "description.h"
-  include "iniprint.h"
-
-  !
-  !   Arguments
-  !
-
-  REAL :: vcov(ip1jm,llm),ucov(ip1jmp1,llm)
-  REAL :: teta(ip1jmp1,llm),phi(ip1jmp1,llm)
-  REAL :: ps(ip1jmp1),masse(ip1jmp1,llm)
-  REAL :: phis(ip1jmp1)
-  REAL :: q(ip1jmp1,llm,nqtot)
-  integer :: time
-
-
-  ! This routine needs IOIPSL to work
-  !   Variables locales
-  !
-  integer :: iq, ii, ll
-  integer :: ndexu(ip1jmp1*llm),ndexv(ip1jm*llm),ndex2d(ip1jmp1)
-  logical :: ok_sync
-  integer :: itau_w
-  REAL :: vnat(ip1jm,llm),unat(ip1jmp1,llm)
-
-  !
-  !  Initialisations
-  !
-  ndexu = 0
-  ndexv = 0
-  ndex2d = 0
-  ok_sync =.TRUE.
-  itau_w = itau_dyn + time
-  !  Passage aux composantes naturelles du vent
-  call covnat(llm, ucov, vcov, unat, vnat)
-  !
-  !  Appels a histwrite pour l'ecriture des variables a sauvegarder
-  !
-  !  Vents U
-  !
-  call histwrite(histuid, 'u', itau_w, unat, &
-        iip1*jjp1*llm, ndexu)
-  !
-  !  Vents V
-  !
-  call histwrite(histvid, 'v', itau_w, vnat, &
-        iip1*jjm*llm, ndexv)
-
-  !
-  !  Temperature potentielle
-  !
-  call histwrite(histid, 'teta', itau_w, teta, &
-        iip1*jjp1*llm, ndexu)
-  !
-  !  Geopotentiel
-  !
-  call histwrite(histid, 'phi', itau_w, phi, &
-        iip1*jjp1*llm, ndexu)
-  !
-  !  Traceurs
-  !
-  !    DO iq=1,nqtot
-  !      call histwrite(histid, tracers(iq)%longName, itau_w,
-  ! .                   q(:,:,iq), iip1*jjp1*llm, ndexu)
-  !    enddo
-  !C
-  !  Masse
-  !
-  call histwrite(histid,'masse',itau_w, masse,iip1*jjp1*llm,ndexu)
-  !
-  !  Pression au sol
-  !
-  call histwrite(histid, 'ps', itau_w, ps, iip1*jjp1, ndex2d)
-  !
-  !  Geopotentiel au sol
-  !
-  !  call histwrite(histid, 'phis', itau_w, phis, iip1*jjp1, ndex2d)
-  !
-  !  Fin
-  !
-  if (ok_sync) then
-    call histsync(histid)
-    call histsync(histvid)
-    call histsync(histuid)
-  endif
-
-
-  return
-end subroutine writehist
Index: /LMDZ6/trunk/libf/dyn3d_common/writehist.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3d_common/writehist.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3d_common/writehist.f90	(revision 5268)
@@ -0,0 +1,125 @@
+!
+! $Id$
+!
+subroutine writehist(time,vcov,ucov,teta,phi,q,masse,ps,phis)
+
+  USE ioipsl
+  USE infotrac, ONLY : nqtot
+  use com_io_dyn_mod, only : histid,histvid,histuid
+  USE temps_mod, ONLY: itau_dyn
+
+  implicit none
+
+  !
+  !   Ecriture du fichier histoire au format IOIPSL
+  !
+  !   Appels succesifs des routines: histwrite
+  !
+  !   Entree:
+  !  time: temps de l'ecriture
+  !  vcov: vents v covariants
+  !  ucov: vents u covariants
+  !  teta: temperature potentielle
+  !  phi : geopotentiel instantane
+  !  q   : traceurs
+  !  masse: masse
+  !  ps   :pression au sol
+  !  phis : geopotentiel au sol
+  !
+  !
+  !   L. Fairhead, LMD, 03/99
+  !
+  ! =====================================================================
+  !
+  !   Declarations
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom.h"
+  include "description.h"
+  include "iniprint.h"
+
+  !
+  !   Arguments
+  !
+
+  REAL :: vcov(ip1jm,llm),ucov(ip1jmp1,llm)
+  REAL :: teta(ip1jmp1,llm),phi(ip1jmp1,llm)
+  REAL :: ps(ip1jmp1),masse(ip1jmp1,llm)
+  REAL :: phis(ip1jmp1)
+  REAL :: q(ip1jmp1,llm,nqtot)
+  integer :: time
+
+
+  ! This routine needs IOIPSL to work
+  !   Variables locales
+  !
+  integer :: iq, ii, ll
+  integer :: ndexu(ip1jmp1*llm),ndexv(ip1jm*llm),ndex2d(ip1jmp1)
+  logical :: ok_sync
+  integer :: itau_w
+  REAL :: vnat(ip1jm,llm),unat(ip1jmp1,llm)
+
+  !
+  !  Initialisations
+  !
+  ndexu = 0
+  ndexv = 0
+  ndex2d = 0
+  ok_sync =.TRUE.
+  itau_w = itau_dyn + time
+  !  Passage aux composantes naturelles du vent
+  call covnat(llm, ucov, vcov, unat, vnat)
+  !
+  !  Appels a histwrite pour l'ecriture des variables a sauvegarder
+  !
+  !  Vents U
+  !
+  call histwrite(histuid, 'u', itau_w, unat, &
+        iip1*jjp1*llm, ndexu)
+  !
+  !  Vents V
+  !
+  call histwrite(histvid, 'v', itau_w, vnat, &
+        iip1*jjm*llm, ndexv)
+
+  !
+  !  Temperature potentielle
+  !
+  call histwrite(histid, 'teta', itau_w, teta, &
+        iip1*jjp1*llm, ndexu)
+  !
+  !  Geopotentiel
+  !
+  call histwrite(histid, 'phi', itau_w, phi, &
+        iip1*jjp1*llm, ndexu)
+  !
+  !  Traceurs
+  !
+  !    DO iq=1,nqtot
+  !      call histwrite(histid, tracers(iq)%longName, itau_w,
+  ! .                   q(:,:,iq), iip1*jjp1*llm, ndexu)
+  !    enddo
+  !C
+  !  Masse
+  !
+  call histwrite(histid,'masse',itau_w, masse,iip1*jjp1*llm,ndexu)
+  !
+  !  Pression au sol
+  !
+  call histwrite(histid, 'ps', itau_w, ps, iip1*jjp1, ndex2d)
+  !
+  !  Geopotentiel au sol
+  !
+  !  call histwrite(histid, 'phis', itau_w, phis, iip1*jjp1, ndex2d)
+  !
+  !  Fin
+  !
+  if (ok_sync) then
+    call histsync(histid)
+    call histsync(histvid)
+    call histsync(histuid)
+  endif
+
+
+  return
+end subroutine writehist
Index: DZ6/trunk/libf/dyn3dmem/abort_gcm.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/abort_gcm.F90	(revision 5267)
+++ 	(revision )
@@ -1,53 +1,0 @@
-!
-! $Id: abort_gcm.F 1747 2013-04-23 14:06:30Z lguez $
-!
-!
-!
-SUBROUTINE abort_gcm(modname, message, ierr)
-
-  USE IOIPSL
-
-  USE parallel_lmdz
-  INCLUDE "iniprint.h"
-
-  !
-  ! Stops the simulation cleanly, closing files and printing various
-  ! comments
-  !
-  !  Input: modname = name of calling program
-  !     message = stuff to print
-  !     ierr    = severity of situation ( = 0 normal )
-
-  character(len=*), intent(in):: modname
-  integer :: ierr, ierror_mpi
-  character(len=*), intent(in):: message
-
-  write(lunout,*) 'in abort_gcm'
-!$OMP MASTER
-  call histclo
-  call restclo
-  if (MPI_rank .eq. 0) then
-     call getin_dump
-  endif
-!$OMP END MASTER
-  ! call histclo(2)
-  ! call histclo(3)
-  ! call histclo(4)
-  ! call histclo(5)
-  write(lunout,*) 'Stopping in ', modname
-  write(lunout,*) 'Reason = ',message
-  if (ierr .eq. 0) then
-    write(lunout,*) 'Everything is cool'
-  else
-    write(lunout,*) 'Houston, we have a problem, ierr = ', ierr
-
-    if (using_mpi) THEN
-!$OMP CRITICAL (MPI_ABORT_GCM)
-      call MPI_ABORT(COMM_LMDZ, 1, ierror_mpi)
-!$OMP END CRITICAL (MPI_ABORT_GCM)
-    else
-     stop 1
-    endif
-
-  endif
-END SUBROUTINE abort_gcm
Index: /LMDZ6/trunk/libf/dyn3dmem/abort_gcm.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/abort_gcm.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3dmem/abort_gcm.f90	(revision 5268)
@@ -0,0 +1,53 @@
+!
+! $Id: abort_gcm.F 1747 2013-04-23 14:06:30Z lguez $
+!
+!
+!
+SUBROUTINE abort_gcm(modname, message, ierr)
+
+  USE IOIPSL
+
+  USE parallel_lmdz
+  INCLUDE "iniprint.h"
+
+  !
+  ! Stops the simulation cleanly, closing files and printing various
+  ! comments
+  !
+  !  Input: modname = name of calling program
+  !     message = stuff to print
+  !     ierr    = severity of situation ( = 0 normal )
+
+  character(len=*), intent(in):: modname
+  integer :: ierr, ierror_mpi
+  character(len=*), intent(in):: message
+
+  write(lunout,*) 'in abort_gcm'
+!$OMP MASTER
+  call histclo
+  call restclo
+  if (MPI_rank .eq. 0) then
+     call getin_dump
+  endif
+!$OMP END MASTER
+  ! call histclo(2)
+  ! call histclo(3)
+  ! call histclo(4)
+  ! call histclo(5)
+  write(lunout,*) 'Stopping in ', modname
+  write(lunout,*) 'Reason = ',message
+  if (ierr .eq. 0) then
+    write(lunout,*) 'Everything is cool'
+  else
+    write(lunout,*) 'Houston, we have a problem, ierr = ', ierr
+
+    if (using_mpi) THEN
+!$OMP CRITICAL (MPI_ABORT_GCM)
+      call MPI_ABORT(COMM_LMDZ, 1, ierror_mpi)
+!$OMP END CRITICAL (MPI_ABORT_GCM)
+    else
+     stop 1
+    endif
+
+  endif
+END SUBROUTINE abort_gcm
Index: DZ6/trunk/libf/dyn3dmem/advect_new_loc.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/advect_new_loc.F90	(revision 5267)
+++ 	(revision )
@@ -1,294 +1,0 @@
-!
-! $Header$
-!
-SUBROUTINE advect_new_loc(ucov,vcov,teta,w,massebx,masseby, &
-        du,dv,dteta)
-  USE parallel_lmdz
-  USE write_field_loc
-  USE advect_new_mod
-  USE comconst_mod, ONLY: daysec
-  USE logic_mod, ONLY: conser
-  USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_DEBUGIO
-  IMPLICIT NONE
-  !=======================================================================
-  !
-  !   Auteurs:  P. Le Van , Fr. Hourdin  .
-  !   -------
-  !
-  !   Objet:
-  !   ------
-  !
-  !   *************************************************************
-  !   .... calcul des termes d'advection vertic.pour u,v,teta,q ...
-  !   *************************************************************
-  !    ces termes sont ajoutes a du,dv,dteta et dq .
-  !  Modif F.Forget 03/94 : on retire q de advect
-  !
-  !=======================================================================
-  !-----------------------------------------------------------------------
-  !   Declarations:
-  !   -------------
-
-  include "dimensions.h"
-  include "paramet.h"
-  include "comgeom.h"
-
-  !   Arguments:
-  !   ----------
-
-  REAL :: vcov(ijb_v:ije_v,llm),ucov(ijb_u:ije_u,llm)
-  REAL :: teta(ijb_u:ije_u,llm)
-  REAL :: massebx(ijb_u:ije_u,llm),masseby(ijb_v:ije_v,llm)
-  REAL :: w(ijb_u:ije_u,llm)
-  REAL :: dv(ijb_v:ije_v,llm),du(ijb_u:ije_u,llm)
-  REAL :: dteta(ijb_u:ije_u,llm)
-  !   Local:
-  !   ------
-
-  REAL :: wsur2(ijb_u:ije_u)
-  REAL :: unsaire2(ijb_u:ije_u), ge(ijb_u:ije_u)
-  REAL :: deuxjour, ww, gt, uu, vv
-
-  INTEGER :: ij,l,ijb,ije
-  EXTERNAL  SSUM
-  REAL :: SSUM
-
-
-
-  !-----------------------------------------------------------------------
-  !   2. Calculs preliminaires:
-  !   -------------------------
-
-  IF (conser.AND.1==0)  THEN
-     deuxjour = 2. * daysec
-
-     DO  ij   = 1, ip1jmp1
-     unsaire2(ij) = unsaire(ij) * unsaire(ij)
-     END DO
-  END IF
-
-
-  !------------------  -yy ----------------------------------------------
-  !   .  Calcul de     u
-
-!$OMP MASTER
-  ijb=ij_begin
-  ije=ij_end
-  if (pole_nord) ijb=ijb+iip1
-  if (pole_sud)  ije=ije-iip1
-
-  DO ij=ijb,ije
-    du2(ij,1)=0.
-    du1(ij,llm)=0.
-  ENDDO
-
-  ijb=ij_begin
-  ije=ij_end
-  if (pole_sud)  ije=ij_end-iip1
-
-  DO ij=ijb,ije
-    dv2(ij,1)=0.
-    dv1(ij,llm)=0.
-  ENDDO
-
-  ijb=ij_begin
-  ije=ij_end
-
-  DO ij=ijb,ije
-    dteta2(ij,1)=0.
-    dteta1(ij,llm)=0.
-  ENDDO
-!$OMP END MASTER
-!$OMP BARRIER
-
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-  DO  l=1,llm
-
-     ijb=ij_begin
-     ije=ij_end
-     if (pole_nord) ijb=ijb+iip1
-     if (pole_sud)  ije=ije-iip1
-
-      ! DO    ij     = iip2, ip1jmp1
-      !    uav(ij,l) = 0.25 * ( ucov(ij,l) + ucov(ij-iip1,l) )
-      ! ENDDO
-
-      ! DO    ij     = iip2, ip1jm
-      !    uav(ij,l) = uav(ij,l) + uav(ij+iip1,l)
-      ! ENDDO
-
-     DO    ij     = ijb, ije
-
-       uav(ij,l)=0.25*(ucov(ij,l)+ucov(ij-iip1,l)) &
-             +0.25*(ucov(ij+iip1,l)+ucov(ij,l))
-     ENDDO
-
-     if (pole_nord) then
-       DO      ij         = 1, iip1
-          uav(ij      ,l) = 0.
-       ENDDO
-     endif
-
-     if (pole_sud) then
-       DO      ij         = 1, iip1
-          uav(ip1jm+ij,l) = 0.
-       ENDDO
-     endif
-
-  ENDDO
-!$OMP END DO
-   ! call write_field3d_p('uav',reshape(uav,(/iip1,jjp1,llm/)))
-
-  !------------------  -xx ----------------------------------------------
-  !   .  Calcul de     v
-
-  ijb=ij_begin
-  ije=ij_end
-  if (pole_sud)  ije=ij_end-iip1
-
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-  DO  l=1,llm
-
-     DO    ij   = ijb+1, ije
-       vav(ij,l) = 0.25 * ( vcov(ij,l) + vcov(ij-1,l) )
-     ENDDO
-
-     DO    ij   = ijb,ije,iip1
-      vav(ij,l) = vav(ij+iim,l)
-     ENDDO
-
-
-     DO    ij   = ijb, ije-1
-      vav(ij,l) = vav(ij,l) + vav(ij+1,l)
-     ENDDO
-
-     DO    ij       = ijb, ije, iip1
-      vav(ij+iim,l) = vav(ij,l)
-     ENDDO
-
-  ENDDO
-!$OMP END DO
-    ! call write_field3d_p('vav',reshape(vav,(/iip1,jjm,llm/)))
-
-  !-----------------------------------------------------------------------
-!$OMP BARRIER
-
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-  DO l = 1, llmm1
-
-
-    ! ......   calcul de  - w/2.    au niveau  l+1   .......
-  ijb=ij_begin
-  ije=ij_end+iip1
-  if (pole_sud)  ije=ij_end
-
-  DO   ij   = ijb, ije
-  wsur2( ij ) = - 0.5 * w( ij,l+1 )
-  END DO
-
-
-  ! .....................     calcul pour  du     ..................
-
-  ijb=ij_begin
-  ije=ij_end
-  if (pole_nord) ijb=ijb+iip1
-  if (pole_sud)  ije=ije-iip1
-
-  DO ij = ijb ,ije-1
-  ww        = wsur2 (  ij  )     + wsur2( ij+1 )
-  uu        = 0.5 * ( ucov(ij,l) + ucov(ij,l+1) )
-  du1(ij,l)  =  ww * ( uu - uav(ij, l ) )/massebx(ij, l )
-  du2(ij,l+1)=  ww * ( uu - uav(ij,l+1) )/massebx(ij,l+1)
-  END DO
-
-  ! .................    calcul pour   dv      .....................
-  ijb=ij_begin
-  ije=ij_end
-  if (pole_sud)  ije=ij_end-iip1
-
-  DO ij = ijb, ije
-  ww        = wsur2( ij+iip1 )   + wsur2( ij )
-  vv        = 0.5 * ( vcov(ij,l) + vcov(ij,l+1) )
-  dv1(ij,l)  =  ww * (vv - vav(ij, l ) )/masseby(ij, l )
-  dv2(ij,l+1)=  ww * (vv - vav(ij,l+1) )/masseby(ij,l+1)
-  END DO
-
-  !
-
-  ! ............................................................
-  ! ...............    calcul pour   dh      ...................
-  ! ............................................................
-
-  !                   ---z
-  !   calcul de  - d( teta  * w )      qu'on ajoute a   dh
-  !               ...............
-    ijb=ij_begin
-    ije=ij_end
-
-    DO ij = ijb, ije
-     ww            = wsur2(ij) * (teta(ij,l) + teta(ij,l+1) )
-     dteta1(ij, l ) =   ww
-     dteta2(ij,l+1) =   ww
-    END DO
-
-  ! ym ---> conser a voir plus tard
-
-   ! IF( conser)  THEN
-  !
-  !    DO 17 ij = 1,ip1jmp1
-  !    ge(ij)   = wsur2(ij) * wsur2(ij) * unsaire2(ij)
-  !  17    CONTINUE
-  !    gt       = SSUM( ip1jmp1,ge,1 )
-  !    gtot(l)  = deuxjour * SQRT( gt/ip1jmp1 )
-  !  END IF
-
-  END DO
-!$OMP END DO
-
-  ijb=ij_begin
-  ije=ij_end
-  if (pole_nord) ijb=ijb+iip1
-  if (pole_sud)  ije=ije-iip1
-IF (CPPKEY_DEBUGIO) THEN
-   CALL WriteField_u('du_bis',du)
-END IF
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-  DO l=1,llm
-    DO ij=ijb,ije-1
-      du(ij,l)=du(ij,l)+du2(ij,l)-du1(ij,l)
-    ENDDO
-
-    DO   ij   = ijb+iip1-1, ije, iip1
-     du( ij, l  ) = du( ij -iim, l  )
-    ENDDO
-  ENDDO
-!$OMP END DO NOWAIT
-IF (CPPKEY_DEBUGIO) THEN
-  CALL WriteField_u('du1',du1)
-  CALL WriteField_u('du2',du2)
-  CALL WriteField_u('du_bis',du)
-END IF
-  ijb=ij_begin
-  ije=ij_end
-  if (pole_sud)  ije=ij_end-iip1
-
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-  DO l=1,llm
-    DO ij=ijb,ije
-      dv(ij,l)=dv(ij,l)+dv2(ij,l)-dv1(ij,l)
-    ENDDO
-  ENDDO
-!$OMP END DO NOWAIT
-  ijb=ij_begin
-  ije=ij_end
-
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-  DO l=1,llm
-    DO ij=ijb,ije
-      dteta(ij,l)=dteta(ij,l)+dteta2(ij,l)-dteta1(ij,l)
-    ENDDO
-  ENDDO
-!$OMP END DO NOWAIT
-
-  RETURN
-END SUBROUTINE advect_new_loc
Index: /LMDZ6/trunk/libf/dyn3dmem/advect_new_loc.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/advect_new_loc.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3dmem/advect_new_loc.f90	(revision 5268)
@@ -0,0 +1,294 @@
+!
+! $Header$
+!
+SUBROUTINE advect_new_loc(ucov,vcov,teta,w,massebx,masseby, &
+        du,dv,dteta)
+  USE parallel_lmdz
+  USE write_field_loc
+  USE advect_new_mod
+  USE comconst_mod, ONLY: daysec
+  USE logic_mod, ONLY: conser
+  USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_DEBUGIO
+  IMPLICIT NONE
+  !=======================================================================
+  !
+  !   Auteurs:  P. Le Van , Fr. Hourdin  .
+  !   -------
+  !
+  !   Objet:
+  !   ------
+  !
+  !   *************************************************************
+  !   .... calcul des termes d'advection vertic.pour u,v,teta,q ...
+  !   *************************************************************
+  !    ces termes sont ajoutes a du,dv,dteta et dq .
+  !  Modif F.Forget 03/94 : on retire q de advect
+  !
+  !=======================================================================
+  !-----------------------------------------------------------------------
+  !   Declarations:
+  !   -------------
+
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom.h"
+
+  !   Arguments:
+  !   ----------
+
+  REAL :: vcov(ijb_v:ije_v,llm),ucov(ijb_u:ije_u,llm)
+  REAL :: teta(ijb_u:ije_u,llm)
+  REAL :: massebx(ijb_u:ije_u,llm),masseby(ijb_v:ije_v,llm)
+  REAL :: w(ijb_u:ije_u,llm)
+  REAL :: dv(ijb_v:ije_v,llm),du(ijb_u:ije_u,llm)
+  REAL :: dteta(ijb_u:ije_u,llm)
+  !   Local:
+  !   ------
+
+  REAL :: wsur2(ijb_u:ije_u)
+  REAL :: unsaire2(ijb_u:ije_u), ge(ijb_u:ije_u)
+  REAL :: deuxjour, ww, gt, uu, vv
+
+  INTEGER :: ij,l,ijb,ije
+  EXTERNAL  SSUM
+  REAL :: SSUM
+
+
+
+  !-----------------------------------------------------------------------
+  !   2. Calculs preliminaires:
+  !   -------------------------
+
+  IF (conser.AND.1==0)  THEN
+     deuxjour = 2. * daysec
+
+     DO  ij   = 1, ip1jmp1
+     unsaire2(ij) = unsaire(ij) * unsaire(ij)
+     END DO
+  END IF
+
+
+  !------------------  -yy ----------------------------------------------
+  !   .  Calcul de     u
+
+!$OMP MASTER
+  ijb=ij_begin
+  ije=ij_end
+  if (pole_nord) ijb=ijb+iip1
+  if (pole_sud)  ije=ije-iip1
+
+  DO ij=ijb,ije
+    du2(ij,1)=0.
+    du1(ij,llm)=0.
+  ENDDO
+
+  ijb=ij_begin
+  ije=ij_end
+  if (pole_sud)  ije=ij_end-iip1
+
+  DO ij=ijb,ije
+    dv2(ij,1)=0.
+    dv1(ij,llm)=0.
+  ENDDO
+
+  ijb=ij_begin
+  ije=ij_end
+
+  DO ij=ijb,ije
+    dteta2(ij,1)=0.
+    dteta1(ij,llm)=0.
+  ENDDO
+!$OMP END MASTER
+!$OMP BARRIER
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO  l=1,llm
+
+     ijb=ij_begin
+     ije=ij_end
+     if (pole_nord) ijb=ijb+iip1
+     if (pole_sud)  ije=ije-iip1
+
+      ! DO    ij     = iip2, ip1jmp1
+      !    uav(ij,l) = 0.25 * ( ucov(ij,l) + ucov(ij-iip1,l) )
+      ! ENDDO
+
+      ! DO    ij     = iip2, ip1jm
+      !    uav(ij,l) = uav(ij,l) + uav(ij+iip1,l)
+      ! ENDDO
+
+     DO    ij     = ijb, ije
+
+       uav(ij,l)=0.25*(ucov(ij,l)+ucov(ij-iip1,l)) &
+             +0.25*(ucov(ij+iip1,l)+ucov(ij,l))
+     ENDDO
+
+     if (pole_nord) then
+       DO      ij         = 1, iip1
+          uav(ij      ,l) = 0.
+       ENDDO
+     endif
+
+     if (pole_sud) then
+       DO      ij         = 1, iip1
+          uav(ip1jm+ij,l) = 0.
+       ENDDO
+     endif
+
+  ENDDO
+!$OMP END DO
+   ! call write_field3d_p('uav',reshape(uav,(/iip1,jjp1,llm/)))
+
+  !------------------  -xx ----------------------------------------------
+  !   .  Calcul de     v
+
+  ijb=ij_begin
+  ije=ij_end
+  if (pole_sud)  ije=ij_end-iip1
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO  l=1,llm
+
+     DO    ij   = ijb+1, ije
+       vav(ij,l) = 0.25 * ( vcov(ij,l) + vcov(ij-1,l) )
+     ENDDO
+
+     DO    ij   = ijb,ije,iip1
+      vav(ij,l) = vav(ij+iim,l)
+     ENDDO
+
+
+     DO    ij   = ijb, ije-1
+      vav(ij,l) = vav(ij,l) + vav(ij+1,l)
+     ENDDO
+
+     DO    ij       = ijb, ije, iip1
+      vav(ij+iim,l) = vav(ij,l)
+     ENDDO
+
+  ENDDO
+!$OMP END DO
+    ! call write_field3d_p('vav',reshape(vav,(/iip1,jjm,llm/)))
+
+  !-----------------------------------------------------------------------
+!$OMP BARRIER
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l = 1, llmm1
+
+
+    ! ......   calcul de  - w/2.    au niveau  l+1   .......
+  ijb=ij_begin
+  ije=ij_end+iip1
+  if (pole_sud)  ije=ij_end
+
+  DO   ij   = ijb, ije
+  wsur2( ij ) = - 0.5 * w( ij,l+1 )
+  END DO
+
+
+  ! .....................     calcul pour  du     ..................
+
+  ijb=ij_begin
+  ije=ij_end
+  if (pole_nord) ijb=ijb+iip1
+  if (pole_sud)  ije=ije-iip1
+
+  DO ij = ijb ,ije-1
+  ww        = wsur2 (  ij  )     + wsur2( ij+1 )
+  uu        = 0.5 * ( ucov(ij,l) + ucov(ij,l+1) )
+  du1(ij,l)  =  ww * ( uu - uav(ij, l ) )/massebx(ij, l )
+  du2(ij,l+1)=  ww * ( uu - uav(ij,l+1) )/massebx(ij,l+1)
+  END DO
+
+  ! .................    calcul pour   dv      .....................
+  ijb=ij_begin
+  ije=ij_end
+  if (pole_sud)  ije=ij_end-iip1
+
+  DO ij = ijb, ije
+  ww        = wsur2( ij+iip1 )   + wsur2( ij )
+  vv        = 0.5 * ( vcov(ij,l) + vcov(ij,l+1) )
+  dv1(ij,l)  =  ww * (vv - vav(ij, l ) )/masseby(ij, l )
+  dv2(ij,l+1)=  ww * (vv - vav(ij,l+1) )/masseby(ij,l+1)
+  END DO
+
+  !
+
+  ! ............................................................
+  ! ...............    calcul pour   dh      ...................
+  ! ............................................................
+
+  !                   ---z
+  !   calcul de  - d( teta  * w )      qu'on ajoute a   dh
+  !               ...............
+    ijb=ij_begin
+    ije=ij_end
+
+    DO ij = ijb, ije
+     ww            = wsur2(ij) * (teta(ij,l) + teta(ij,l+1) )
+     dteta1(ij, l ) =   ww
+     dteta2(ij,l+1) =   ww
+    END DO
+
+  ! ym ---> conser a voir plus tard
+
+   ! IF( conser)  THEN
+  !
+  !    DO 17 ij = 1,ip1jmp1
+  !    ge(ij)   = wsur2(ij) * wsur2(ij) * unsaire2(ij)
+  !  17    CONTINUE
+  !    gt       = SSUM( ip1jmp1,ge,1 )
+  !    gtot(l)  = deuxjour * SQRT( gt/ip1jmp1 )
+  !  END IF
+
+  END DO
+!$OMP END DO
+
+  ijb=ij_begin
+  ije=ij_end
+  if (pole_nord) ijb=ijb+iip1
+  if (pole_sud)  ije=ije-iip1
+IF (CPPKEY_DEBUGIO) THEN
+   CALL WriteField_u('du_bis',du)
+END IF
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,llm
+    DO ij=ijb,ije-1
+      du(ij,l)=du(ij,l)+du2(ij,l)-du1(ij,l)
+    ENDDO
+
+    DO   ij   = ijb+iip1-1, ije, iip1
+     du( ij, l  ) = du( ij -iim, l  )
+    ENDDO
+  ENDDO
+!$OMP END DO NOWAIT
+IF (CPPKEY_DEBUGIO) THEN
+  CALL WriteField_u('du1',du1)
+  CALL WriteField_u('du2',du2)
+  CALL WriteField_u('du_bis',du)
+END IF
+  ijb=ij_begin
+  ije=ij_end
+  if (pole_sud)  ije=ij_end-iip1
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,llm
+    DO ij=ijb,ije
+      dv(ij,l)=dv(ij,l)+dv2(ij,l)-dv1(ij,l)
+    ENDDO
+  ENDDO
+!$OMP END DO NOWAIT
+  ijb=ij_begin
+  ije=ij_end
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,llm
+    DO ij=ijb,ije
+      dteta(ij,l)=dteta(ij,l)+dteta2(ij,l)-dteta1(ij,l)
+    ENDDO
+  ENDDO
+!$OMP END DO NOWAIT
+
+  RETURN
+END SUBROUTINE advect_new_loc
Index: DZ6/trunk/libf/dyn3dmem/advect_new_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/advect_new_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,55 +1,0 @@
-MODULE advect_new_mod
-
-  REAL,POINTER,SAVE :: dv1(:,:)
-  REAL,POINTER,SAVE :: du1(:,:)
-  REAL,POINTER,SAVE :: dteta1(:,:)
-  REAL,POINTER,SAVE :: dv2(:,:)
-  REAL,POINTER,SAVE :: du2(:,:)
-  REAL,POINTER,SAVE :: dteta2(:,:)
-  REAL,POINTER,SAVE :: uav(:,:)
-  REAL,POINTER,SAVE :: vav(:,:)
-
-  
-CONTAINS
-
-  SUBROUTINE advect_new_allocate
-  USE bands
-  USE allocate_field_mod
-  USE parallel_lmdz
-  USE dimensions_mod
-  IMPLICIT NONE
-  TYPE(distrib),POINTER :: d
-
-
-    d=>distrib_caldyn
-    CALL allocate_v(dv1,llm,d)
-    CALL allocate_u(du1,llm,d)
-    CALL allocate_u(dteta1,llm,d)
-    CALL allocate_v(dv2,llm,d)
-    CALL allocate_u(du2,llm,d)
-    CALL allocate_u(dteta2,llm,d)
-    CALL allocate_u(uav,llm,d)
-    CALL allocate_v(vav,llm,d)
- 
-    
-  END SUBROUTINE advect_new_allocate
-  
-  SUBROUTINE advect_new_switch_caldyn(dist)
-  USE allocate_field_mod
-  USE bands
-  USE parallel_lmdz
-  IMPLICIT NONE
-    TYPE(distrib),INTENT(IN) :: dist
-
-    CALL switch_v(dv1,distrib_caldyn,dist)
-    CALL switch_u(du1,distrib_caldyn,dist)
-    CALL switch_u(dteta1,distrib_caldyn,dist)
-    CALL switch_v(dv2,distrib_caldyn,dist)
-    CALL switch_u(du2,distrib_caldyn,dist)
-    CALL switch_u(dteta2,distrib_caldyn,dist)
-    CALL switch_u(uav,distrib_caldyn,dist)
-    CALL switch_v(vav,distrib_caldyn,dist)
-
-  END SUBROUTINE advect_new_switch_caldyn
-  
-END MODULE advect_new_mod  
Index: /LMDZ6/trunk/libf/dyn3dmem/advect_new_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/advect_new_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3dmem/advect_new_mod.f90	(revision 5268)
@@ -0,0 +1,55 @@
+MODULE advect_new_mod
+
+  REAL,POINTER,SAVE :: dv1(:,:)
+  REAL,POINTER,SAVE :: du1(:,:)
+  REAL,POINTER,SAVE :: dteta1(:,:)
+  REAL,POINTER,SAVE :: dv2(:,:)
+  REAL,POINTER,SAVE :: du2(:,:)
+  REAL,POINTER,SAVE :: dteta2(:,:)
+  REAL,POINTER,SAVE :: uav(:,:)
+  REAL,POINTER,SAVE :: vav(:,:)
+
+  
+CONTAINS
+
+  SUBROUTINE advect_new_allocate
+  USE bands
+  USE allocate_field_mod
+  USE parallel_lmdz
+  USE dimensions_mod
+  IMPLICIT NONE
+  TYPE(distrib),POINTER :: d
+
+
+    d=>distrib_caldyn
+    CALL allocate_v(dv1,llm,d)
+    CALL allocate_u(du1,llm,d)
+    CALL allocate_u(dteta1,llm,d)
+    CALL allocate_v(dv2,llm,d)
+    CALL allocate_u(du2,llm,d)
+    CALL allocate_u(dteta2,llm,d)
+    CALL allocate_u(uav,llm,d)
+    CALL allocate_v(vav,llm,d)
+ 
+    
+  END SUBROUTINE advect_new_allocate
+  
+  SUBROUTINE advect_new_switch_caldyn(dist)
+  USE allocate_field_mod
+  USE bands
+  USE parallel_lmdz
+  IMPLICIT NONE
+    TYPE(distrib),INTENT(IN) :: dist
+
+    CALL switch_v(dv1,distrib_caldyn,dist)
+    CALL switch_u(du1,distrib_caldyn,dist)
+    CALL switch_u(dteta1,distrib_caldyn,dist)
+    CALL switch_v(dv2,distrib_caldyn,dist)
+    CALL switch_u(du2,distrib_caldyn,dist)
+    CALL switch_u(dteta2,distrib_caldyn,dist)
+    CALL switch_u(uav,distrib_caldyn,dist)
+    CALL switch_v(vav,distrib_caldyn,dist)
+
+  END SUBROUTINE advect_new_switch_caldyn
+  
+END MODULE advect_new_mod  
Index: DZ6/trunk/libf/dyn3dmem/advtrac_loc.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/advtrac_loc.F90	(revision 5267)
+++ 	(revision )
@@ -1,290 +1,0 @@
-
-SUBROUTINE advtrac_loc(pbarug, pbarvg, wg, p, massem, q, teta, pk)
-   !     Auteur :  F. Hourdin
-   !
-   !     Modif. P. Le Van     (20/12/97)
-   !            F. Codron     (10/99)
-   !            D. Le Croller (07/2001)
-   !            M.A Filiberti (04/2002)
-   !
-   USE infotrac,     ONLY: nqtot, tracers
-   USE control_mod,  ONLY: iapp_tracvl, day_step, planet_type
-   USE comconst_mod, ONLY: dtvr
-   USE parallel_lmdz
-   USE Write_Field_loc
-   USE Write_Field
-   USE Bands
-   USE mod_hallo
-   USE Vampir
-   USE times
-   USE advtrac_mod, ONLY: finmasse
-   USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_DEBUGIO
-   USE strings_mod, ONLY: int2str
-   IMPLICIT NONE
-   !
-   include "dimensions.h"
-   include "paramet.h"
-   include "comdissip.h"
-   include "comgeom2.h"
-   include "description.h"
-!   include "iniprint.h"
-
-   !---------------------------------------------------------------------------
-   !     Arguments
-   !---------------------------------------------------------------------------
-   REAL, INTENT(IN) ::  pbarug(ijb_u:ije_u,llm)
-   REAL, INTENT(IN) ::  pbarvg(ijb_v:ije_v,llm)
-   REAL, INTENT(IN) ::      wg(ijb_u:ije_u,llm)
-   REAL, INTENT(IN) ::       p(ijb_u:ije_u,llmp1)
-   REAL, INTENT(IN) ::  massem(ijb_u:ije_u,llm)
-   REAL, INTENT(INOUT) ::    q(ijb_u:ije_u,llm,nqtot)
-   REAL, INTENT(IN) ::    teta(ijb_u:ije_u,llm)
-   REAL, INTENT(IN) ::      pk(ijb_u:ije_u,llm)
-   !---------------------------------------------------------------------------
-   !     Ajout PPM
-   !---------------------------------------------------------------------------
-   REAL :: massebx(ijb_u:ije_u,llm), masseby(ijb_v:ije_v,llm)
-   !---------------------------------------------------------------------------
-   !     Variables locales
-   !---------------------------------------------------------------------------
-   INTEGER :: ij, l, iq, iadv
-   REAL(KIND=KIND(1.d0)) :: t_initial, t_final, tps_cpu
-   REAL :: zdp(ijb_u:ije_u), zdpmin, zdpmax
-   INTEGER, SAVE :: iadvtr=0
-!$OMP THREADPRIVATE(iadvtr)
-   EXTERNAL  minmax
-
-   !---------------------------------------------------------------------------
-   !     Rajouts pour PPM
-   !---------------------------------------------------------------------------
-   INTEGER :: indice, n
-   REAL :: dtbon                       ! Pas de temps adaptatif pour que CFL<1
-   REAL :: CFLmaxz, aaa, bbb           ! CFL maximum
-   REAL, DIMENSION(iim,jjb_u:jje_u,llm) :: unatppm, vnatppm, fluxwppm
-   REAL ::    qppm(iim*jjnb_u,llm,nqtot)
-   REAL ::   psppm(iim,jjb_u:jje_u)    ! pression  au sol
-   REAL, DIMENSION(llmp1) :: apppm, bpppm
-   LOGICAL, SAVE :: dum=.TRUE., fill=.TRUE.
-   INTEGER :: ijb, ije, ijbu, ijbv, ijeu, ijev, j
-   TYPE(Request),SAVE :: testRequest
-!$OMP THREADPRIVATE(testRequest)
-
-! Test sur l'eventuelle creation de valeurs negatives de la masse
-   ijb = ij_begin; IF(pole_nord) ijb = ij_begin+iip1
-   ije = ij_end;   IF(pole_sud)  ije = ij_end-iip1
-
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-   DO l=1,llm-1
-      DO ij = ijb+1,ije
-         zdp(ij) = pbarug(ij-1,l)    - pbarug(ij,l) &
-                 - pbarvg(ij-iip1,l) + pbarvg(ij,l) &
-                 +     wg(ij,l+1)    -     wg(ij,l)
-      END DO
-! ym  ---> pourquoi jjm-1 et non jjm ? a cause du pole ?
-!     CALL SCOPY( jjm -1 ,zdp(iip1+iip1),iip1,zdp(iip2),iip1 )
-      DO ij = ijb,ije-iip1+1,iip1
-         zdp(ij)=zdp(ij+iip1-1)
-      END DO
-      DO ij = ijb,ije
-         zdp(ij)= zdp(ij)*dtvr/ massem(ij,l) 
-      END DO 
-!     CALL minmax ( ip1jm-iip1, zdp(iip2), zdpmin,zdpmax )
-! ym ---> eventuellement a revoir
-      CALL minmax( ije-ijb+1, zdp(ijb), zdpmin,zdpmax )
-      IF(MAX(ABS(zdpmin),ABS(zdpmax)) >0.5) &
-         WRITE(*,*)'WARNING DP/P l=',l,'  MIN:',zdpmin,'   MAX:', zdpmax
-   END DO
-!$OMP END DO NOWAIT
-
-   !---------------------------------------------------------------------------
-   !   Advection proprement dite (Modification Le Croller (07/2001)
-   !---------------------------------------------------------------------------
-
-   !---------------------------------------------------------------------------
-   !   Calcul des moyennes basees sur la masse
-   !---------------------------------------------------------------------------
-!ym   CALL massbar_p(massem,massebx,masseby)
-!ym   ----> Normalement, inutile pour les schemas classiques
-!ym   ----> Reverifier lors de la parallelisation des autres schemas
-
-IF (CPPKEY_DEBUGIO) THEN
-   CALL WriteField_u('massem',massem)
-   CALL WriteField_u('wg',wg)
-   CALL WriteField_u('pbarug',pbarug)
-   CALL WriteField_v('pbarvg',pbarvg)
-   CALL WriteField_u('p_tmp',p)
-   CALL WriteField_u('pk_tmp',pk)
-   CALL WriteField_u('teta_tmp',teta)
-   DO iq=1,nqtot
-      CALL WriteField_u('q_adv'//trim(int2str(iq)),q(:,:,iq))
-   END DO
-END IF
-
-!          
-!  CALL Register_Hallo_v(pbarvg,llm,1,1,1,1,TestRequest)
-!  CALL SendRequest(TestRequest)
-!!$OMP BARRIER
-!  CALL WaitRequest(TestRequest)
-!$OMP BARRIER
-
-!  WRITE(*,*) 'advtrac 157: appel de vlspltgen_loc'
-   CALL vlspltgen_loc(q, 2., massem, wg, pbarug, pbarvg, dtvr, p, pk, teta )
-
-IF (CPPKEY_DEBUGIO) THEN
-   DO iq = 1, nqtot
-      CALL WriteField_u('q_adv'//trim(int2str(iq)),q(:,:,iq))
-   END DO
-END IF
-         
-   GOTO 1234     
-   !-------------------------------------------------------------------------
-   !       Appel des sous programmes d'advection
-   !-------------------------------------------------------------------------
-   DO iq = 1, nqtot
-!     CALL clock(t_initial)
-      IF(tracers(iq)%parent /= 'air') CYCLE
-      iadv = tracers(iq)%iadv
-      !-----------------------------------------------------------------------
-      SELECT CASE(iadv)
-      !-----------------------------------------------------------------------
-         CASE(0); CYCLE
-         !--------------------------------------------------------------------
-         CASE(10)  !--- Schema de Van Leer I MUSCL
-         !--------------------------------------------------------------------
-!           WRITE(*,*) 'advtrac 239: iq,q(1721,19,:)=',iq,q(1721,19,:)     
-!LF         CALL vlsplt_p(q(1,1,iq),2.,massem,wg,pbarug,pbarvg,dtvr)
-
-         !--------------------------------------------------------------------
-         CASE(14)  !--- Schema "pseuDO amont" + test sur humidite specifique
-                   !--- pour la vapeur d'eau. F. Codron
-         !--------------------------------------------------------------------
-!           WRITE(*,*) 'advtrac 248: iq,q(1721,19,:)=',iq,q(1721,19,:)
-            CALL abort_gcm("advtrac","appel a vlspltqs :schema non parallelise",1)
-!LF         CALL vlspltqs_p(q(1,1,1),2.,massem,wg,pbarug,pbarvg,dtvr,p,pk,teta )
-
-         !--------------------------------------------------------------------
-         CASE(12)  !--- Schema de Frederic Hourdin
-         !--------------------------------------------------------------------
-            CALL abort_gcm("advtrac","appel a vlspltqs :schema non parallelise",1)
-            CALL adaptdt(iadv,dtbon,n,pbarug,massem)   ! pas de temps adaptatif
-            IF(n > 1) WRITE(*,*) 'WARNING horizontal dt=',dtbon,'dtvr=',dtvr,'n=',n
-            DO indice=1,n
-              CALL advn(q(1,1,iq),massem,wg,pbarug,pbarvg,dtbon,1)
-            END DO
-
-         !--------------------------------------------------------------------
-         CASE(13)  !--- Pas de temps adaptatif
-         !--------------------------------------------------------------------
-            CALL abort_gcm("advtrac","schema non parallelise",1)
-            CALL adaptdt(iadv,dtbon,n,pbarug,massem)
-            IF(n > 1) WRITE(*,*) 'WARNING horizontal dt=',dtbon,'dtvr=',dtvr,'n=',n
-            DO indice=1,n
-               CALL advn(q(1,1,iq),massem,wg,pbarug,pbarvg,dtbon,2)
-            END DO
-
-         !--------------------------------------------------------------------
-         CASE(20)  !--- Schema de pente SLOPES
-         !--------------------------------------------------------------------
-            CALL abort_gcm("advtrac","schema SLOPES non parallelise",1)
-            CALL pentes_ini (q(1,1,iq),wg,massem,pbarug,pbarvg,0)
-
-         !--------------------------------------------------------------------
-         CASE(30)  !--- Schema de Prather
-         !--------------------------------------------------------------------
-            CALL abort_gcm("advtrac","schema prather non parallelise",1)
-            ! Pas de temps adaptatif
-            CALL adaptdt(iadv,dtbon,n,pbarug,massem)
-            IF(n > 1) WRITE(*,*) 'WARNING horizontal dt=',dtbon,'dtvr=',dtvr,'n=',n
-            CALL prather(q(1,1,iq),wg,massem,pbarug,pbarvg,n,dtbon)
-
-         !--------------------------------------------------------------------
-         CASE(11,16,17,18)   !--- Schemas PPM Lin et Rood
-         !--------------------------------------------------------------------
-            CALL abort_gcm("advtrac","schema PPM non parallelise",1)
-            ! Test sur le flux horizontal
-            CALL adaptdt(iadv,dtbon,n,pbarug,massem)   ! pas de temps adaptatif
-            IF(n > 1) WRITE(*,*) 'WARNING horizontal dt=',dtbon,'dtvr=',dtvr,'n=',n
-            ! Test sur le flux vertical
-            CFLmaxz=0.
-            DO l=2,llm
-               DO ij=iip2,ip1jm
-                  aaa=wg(ij,l)*dtvr/massem(ij,l)
-                  CFLmaxz=max(CFLmaxz,aaa)
-                  bbb=-wg(ij,l)*dtvr/massem(ij,l-1)
-                  CFLmaxz=max(CFLmaxz,bbb)
-               END DO
-            END DO
-            IF(CFLmaxz.GE.1) WRITE(*,*) 'WARNING vertical','CFLmaxz=', CFLmaxz
-            !----------------------------------------------------------------
-            !     Ss-prg interface LMDZ.4->PPM3d (ss-prg de Lin)
-            !----------------------------------------------------------------
-            CALL interpre(q(1,1,iq),qppm(1,1,iq),wg,fluxwppm,massem, &
-                 apppm,bpppm,massebx,masseby,pbarug,pbarvg, &
-                 unatppm,vnatppm,psppm)
-
-            !----------------------------------------------------------------
-            DO indice=1,n     !--- VL (version PPM) horiz. et PPM vert.
-            !----------------------------------------------------------------
-               SELECT CASE(iadv)
-                  !----------------------------------------------------------
-                  CASE(11)
-                  !----------------------------------------------------------
-                     CALL ppm3d(1,qppm(1,1,iq),psppm,psppm,unatppm,vnatppm,fluxwppm,dtbon, &
-                                2,2,2,1,iim,jjp1,2,llm,apppm,bpppm,0.01,6400000,fill,dum,220.)
-                  !----------------------------------------------------------
-                  CASE(16) !--- Monotonic PPM
-                  !----------------------------------------------------------
-                     CALL ppm3d(1,qppm(1,1,iq),psppm,psppm,unatppm,vnatppm,fluxwppm,dtbon, &
-                                3,3,3,1,iim,jjp1,2,llm,apppm,bpppm,0.01,6400000,fill,dum,220.)
-                  !----------------------------------------------------------
-                  CASE(17) !--- Semi monotonic PPM
-                  !----------------------------------------------------------
-                     CALL ppm3d(1,qppm(1,1,iq),psppm,psppm,unatppm,vnatppm,fluxwppm,dtbon, &
-                                4,4,4,1,iim,jjp1,2,llm,apppm,bpppm,0.01,6400000, fill,dum,220.)
-                  !----------------------------------------------------------
-                  CASE(18) !--- Positive Definite PPM
-                  !----------------------------------------------------------
-                     CALL ppm3d(1,qppm(1,1,iq),psppm,psppm,unatppm,vnatppm,fluxwppm,dtbon, &
-                                5,5,5,1,iim,jjp1,2,llm,apppm,bpppm,0.01,6400000,fill,dum,220.)
-               END SELECT
-            !----------------------------------------------------------------
-            END DO
-            !----------------------------------------------------------------
-            !     Ss-prg interface PPM3d-LMDZ.4
-            !----------------------------------------------------------------
-            CALL interpost(q(1,1,iq),qppm(1,1,iq))
-      !----------------------------------------------------------------------
-      END SELECT
-      !----------------------------------------------------------------------
-
-      !----------------------------------------------------------------------
-      ! On impose une seule valeur du traceur au pole Sud j=jjm+1=jjp1 et Nord j=1
-      !----------------------------------------------------------------------
-      !  CALL traceurpole(q(1,1,iq),massem)
-
-      !--- Calcul du temps cpu pour un schema donne
-      !  CALL clock(t_final)
-      !ym  tps_cpu=t_final-t_initial
-      !ym  cpuadv(iq)=cpuadv(iq)+tps_cpu
-
-   END DO
-
-1234 CONTINUE
-!$OMP BARRIER
-   IF(planet_type=="earth") THEN
-      ijb=ij_begin
-      ije=ij_end
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
-      DO l = 1, llm
-         DO ij = ijb, ije
-            finmasse(ij,l) =  p(ij,l) - p(ij,l+1) 
-         END DO
-      END DO
-!$OMP END DO
-
-      CALL qminimum_loc( q, nqtot, finmasse )
-
-   END IF ! of if (planet_type=="earth")
-
-END SUBROUTINE advtrac_loc
-
Index: /LMDZ6/trunk/libf/dyn3dmem/advtrac_loc.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/advtrac_loc.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3dmem/advtrac_loc.f90	(revision 5268)
@@ -0,0 +1,290 @@
+
+SUBROUTINE advtrac_loc(pbarug, pbarvg, wg, p, massem, q, teta, pk)
+   !     Auteur :  F. Hourdin
+   !
+   !     Modif. P. Le Van     (20/12/97)
+   !            F. Codron     (10/99)
+   !            D. Le Croller (07/2001)
+   !            M.A Filiberti (04/2002)
+   !
+   USE infotrac,     ONLY: nqtot, tracers
+   USE control_mod,  ONLY: iapp_tracvl, day_step, planet_type
+   USE comconst_mod, ONLY: dtvr
+   USE parallel_lmdz
+   USE Write_Field_loc
+   USE Write_Field
+   USE Bands
+   USE mod_hallo
+   USE Vampir
+   USE times
+   USE advtrac_mod, ONLY: finmasse
+   USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_DEBUGIO
+   USE strings_mod, ONLY: int2str
+   IMPLICIT NONE
+   !
+   include "dimensions.h"
+   include "paramet.h"
+   include "comdissip.h"
+   include "comgeom2.h"
+   include "description.h"
+!   include "iniprint.h"
+
+   !---------------------------------------------------------------------------
+   !     Arguments
+   !---------------------------------------------------------------------------
+   REAL, INTENT(IN) ::  pbarug(ijb_u:ije_u,llm)
+   REAL, INTENT(IN) ::  pbarvg(ijb_v:ije_v,llm)
+   REAL, INTENT(IN) ::      wg(ijb_u:ije_u,llm)
+   REAL, INTENT(IN) ::       p(ijb_u:ije_u,llmp1)
+   REAL, INTENT(IN) ::  massem(ijb_u:ije_u,llm)
+   REAL, INTENT(INOUT) ::    q(ijb_u:ije_u,llm,nqtot)
+   REAL, INTENT(IN) ::    teta(ijb_u:ije_u,llm)
+   REAL, INTENT(IN) ::      pk(ijb_u:ije_u,llm)
+   !---------------------------------------------------------------------------
+   !     Ajout PPM
+   !---------------------------------------------------------------------------
+   REAL :: massebx(ijb_u:ije_u,llm), masseby(ijb_v:ije_v,llm)
+   !---------------------------------------------------------------------------
+   !     Variables locales
+   !---------------------------------------------------------------------------
+   INTEGER :: ij, l, iq, iadv
+   REAL(KIND=KIND(1.d0)) :: t_initial, t_final, tps_cpu
+   REAL :: zdp(ijb_u:ije_u), zdpmin, zdpmax
+   INTEGER, SAVE :: iadvtr=0
+!$OMP THREADPRIVATE(iadvtr)
+   EXTERNAL  minmax
+
+   !---------------------------------------------------------------------------
+   !     Rajouts pour PPM
+   !---------------------------------------------------------------------------
+   INTEGER :: indice, n
+   REAL :: dtbon                       ! Pas de temps adaptatif pour que CFL<1
+   REAL :: CFLmaxz, aaa, bbb           ! CFL maximum
+   REAL, DIMENSION(iim,jjb_u:jje_u,llm) :: unatppm, vnatppm, fluxwppm
+   REAL ::    qppm(iim*jjnb_u,llm,nqtot)
+   REAL ::   psppm(iim,jjb_u:jje_u)    ! pression  au sol
+   REAL, DIMENSION(llmp1) :: apppm, bpppm
+   LOGICAL, SAVE :: dum=.TRUE., fill=.TRUE.
+   INTEGER :: ijb, ije, ijbu, ijbv, ijeu, ijev, j
+   TYPE(Request),SAVE :: testRequest
+!$OMP THREADPRIVATE(testRequest)
+
+! Test sur l'eventuelle creation de valeurs negatives de la masse
+   ijb = ij_begin; IF(pole_nord) ijb = ij_begin+iip1
+   ije = ij_end;   IF(pole_sud)  ije = ij_end-iip1
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+   DO l=1,llm-1
+      DO ij = ijb+1,ije
+         zdp(ij) = pbarug(ij-1,l)    - pbarug(ij,l) &
+                 - pbarvg(ij-iip1,l) + pbarvg(ij,l) &
+                 +     wg(ij,l+1)    -     wg(ij,l)
+      END DO
+! ym  ---> pourquoi jjm-1 et non jjm ? a cause du pole ?
+!     CALL SCOPY( jjm -1 ,zdp(iip1+iip1),iip1,zdp(iip2),iip1 )
+      DO ij = ijb,ije-iip1+1,iip1
+         zdp(ij)=zdp(ij+iip1-1)
+      END DO
+      DO ij = ijb,ije
+         zdp(ij)= zdp(ij)*dtvr/ massem(ij,l) 
+      END DO 
+!     CALL minmax ( ip1jm-iip1, zdp(iip2), zdpmin,zdpmax )
+! ym ---> eventuellement a revoir
+      CALL minmax( ije-ijb+1, zdp(ijb), zdpmin,zdpmax )
+      IF(MAX(ABS(zdpmin),ABS(zdpmax)) >0.5) &
+         WRITE(*,*)'WARNING DP/P l=',l,'  MIN:',zdpmin,'   MAX:', zdpmax
+   END DO
+!$OMP END DO NOWAIT
+
+   !---------------------------------------------------------------------------
+   !   Advection proprement dite (Modification Le Croller (07/2001)
+   !---------------------------------------------------------------------------
+
+   !---------------------------------------------------------------------------
+   !   Calcul des moyennes basees sur la masse
+   !---------------------------------------------------------------------------
+!ym   CALL massbar_p(massem,massebx,masseby)
+!ym   ----> Normalement, inutile pour les schemas classiques
+!ym   ----> Reverifier lors de la parallelisation des autres schemas
+
+IF (CPPKEY_DEBUGIO) THEN
+   CALL WriteField_u('massem',massem)
+   CALL WriteField_u('wg',wg)
+   CALL WriteField_u('pbarug',pbarug)
+   CALL WriteField_v('pbarvg',pbarvg)
+   CALL WriteField_u('p_tmp',p)
+   CALL WriteField_u('pk_tmp',pk)
+   CALL WriteField_u('teta_tmp',teta)
+   DO iq=1,nqtot
+      CALL WriteField_u('q_adv'//trim(int2str(iq)),q(:,:,iq))
+   END DO
+END IF
+
+!          
+!  CALL Register_Hallo_v(pbarvg,llm,1,1,1,1,TestRequest)
+!  CALL SendRequest(TestRequest)
+!!$OMP BARRIER
+!  CALL WaitRequest(TestRequest)
+!$OMP BARRIER
+
+!  WRITE(*,*) 'advtrac 157: appel de vlspltgen_loc'
+   CALL vlspltgen_loc(q, 2., massem, wg, pbarug, pbarvg, dtvr, p, pk, teta )
+
+IF (CPPKEY_DEBUGIO) THEN
+   DO iq = 1, nqtot
+      CALL WriteField_u('q_adv'//trim(int2str(iq)),q(:,:,iq))
+   END DO
+END IF
+         
+   GOTO 1234     
+   !-------------------------------------------------------------------------
+   !       Appel des sous programmes d'advection
+   !-------------------------------------------------------------------------
+   DO iq = 1, nqtot
+!     CALL clock(t_initial)
+      IF(tracers(iq)%parent /= 'air') CYCLE
+      iadv = tracers(iq)%iadv
+      !-----------------------------------------------------------------------
+      SELECT CASE(iadv)
+      !-----------------------------------------------------------------------
+         CASE(0); CYCLE
+         !--------------------------------------------------------------------
+         CASE(10)  !--- Schema de Van Leer I MUSCL
+         !--------------------------------------------------------------------
+!           WRITE(*,*) 'advtrac 239: iq,q(1721,19,:)=',iq,q(1721,19,:)     
+!LF         CALL vlsplt_p(q(1,1,iq),2.,massem,wg,pbarug,pbarvg,dtvr)
+
+         !--------------------------------------------------------------------
+         CASE(14)  !--- Schema "pseuDO amont" + test sur humidite specifique
+                   !--- pour la vapeur d'eau. F. Codron
+         !--------------------------------------------------------------------
+!           WRITE(*,*) 'advtrac 248: iq,q(1721,19,:)=',iq,q(1721,19,:)
+            CALL abort_gcm("advtrac","appel a vlspltqs :schema non parallelise",1)
+!LF         CALL vlspltqs_p(q(1,1,1),2.,massem,wg,pbarug,pbarvg,dtvr,p,pk,teta )
+
+         !--------------------------------------------------------------------
+         CASE(12)  !--- Schema de Frederic Hourdin
+         !--------------------------------------------------------------------
+            CALL abort_gcm("advtrac","appel a vlspltqs :schema non parallelise",1)
+            CALL adaptdt(iadv,dtbon,n,pbarug,massem)   ! pas de temps adaptatif
+            IF(n > 1) WRITE(*,*) 'WARNING horizontal dt=',dtbon,'dtvr=',dtvr,'n=',n
+            DO indice=1,n
+              CALL advn(q(1,1,iq),massem,wg,pbarug,pbarvg,dtbon,1)
+            END DO
+
+         !--------------------------------------------------------------------
+         CASE(13)  !--- Pas de temps adaptatif
+         !--------------------------------------------------------------------
+            CALL abort_gcm("advtrac","schema non parallelise",1)
+            CALL adaptdt(iadv,dtbon,n,pbarug,massem)
+            IF(n > 1) WRITE(*,*) 'WARNING horizontal dt=',dtbon,'dtvr=',dtvr,'n=',n
+            DO indice=1,n
+               CALL advn(q(1,1,iq),massem,wg,pbarug,pbarvg,dtbon,2)
+            END DO
+
+         !--------------------------------------------------------------------
+         CASE(20)  !--- Schema de pente SLOPES
+         !--------------------------------------------------------------------
+            CALL abort_gcm("advtrac","schema SLOPES non parallelise",1)
+            CALL pentes_ini (q(1,1,iq),wg,massem,pbarug,pbarvg,0)
+
+         !--------------------------------------------------------------------
+         CASE(30)  !--- Schema de Prather
+         !--------------------------------------------------------------------
+            CALL abort_gcm("advtrac","schema prather non parallelise",1)
+            ! Pas de temps adaptatif
+            CALL adaptdt(iadv,dtbon,n,pbarug,massem)
+            IF(n > 1) WRITE(*,*) 'WARNING horizontal dt=',dtbon,'dtvr=',dtvr,'n=',n
+            CALL prather(q(1,1,iq),wg,massem,pbarug,pbarvg,n,dtbon)
+
+         !--------------------------------------------------------------------
+         CASE(11,16,17,18)   !--- Schemas PPM Lin et Rood
+         !--------------------------------------------------------------------
+            CALL abort_gcm("advtrac","schema PPM non parallelise",1)
+            ! Test sur le flux horizontal
+            CALL adaptdt(iadv,dtbon,n,pbarug,massem)   ! pas de temps adaptatif
+            IF(n > 1) WRITE(*,*) 'WARNING horizontal dt=',dtbon,'dtvr=',dtvr,'n=',n
+            ! Test sur le flux vertical
+            CFLmaxz=0.
+            DO l=2,llm
+               DO ij=iip2,ip1jm
+                  aaa=wg(ij,l)*dtvr/massem(ij,l)
+                  CFLmaxz=max(CFLmaxz,aaa)
+                  bbb=-wg(ij,l)*dtvr/massem(ij,l-1)
+                  CFLmaxz=max(CFLmaxz,bbb)
+               END DO
+            END DO
+            IF(CFLmaxz.GE.1) WRITE(*,*) 'WARNING vertical','CFLmaxz=', CFLmaxz
+            !----------------------------------------------------------------
+            !     Ss-prg interface LMDZ.4->PPM3d (ss-prg de Lin)
+            !----------------------------------------------------------------
+            CALL interpre(q(1,1,iq),qppm(1,1,iq),wg,fluxwppm,massem, &
+                 apppm,bpppm,massebx,masseby,pbarug,pbarvg, &
+                 unatppm,vnatppm,psppm)
+
+            !----------------------------------------------------------------
+            DO indice=1,n     !--- VL (version PPM) horiz. et PPM vert.
+            !----------------------------------------------------------------
+               SELECT CASE(iadv)
+                  !----------------------------------------------------------
+                  CASE(11)
+                  !----------------------------------------------------------
+                     CALL ppm3d(1,qppm(1,1,iq),psppm,psppm,unatppm,vnatppm,fluxwppm,dtbon, &
+                                2,2,2,1,iim,jjp1,2,llm,apppm,bpppm,0.01,6400000,fill,dum,220.)
+                  !----------------------------------------------------------
+                  CASE(16) !--- Monotonic PPM
+                  !----------------------------------------------------------
+                     CALL ppm3d(1,qppm(1,1,iq),psppm,psppm,unatppm,vnatppm,fluxwppm,dtbon, &
+                                3,3,3,1,iim,jjp1,2,llm,apppm,bpppm,0.01,6400000,fill,dum,220.)
+                  !----------------------------------------------------------
+                  CASE(17) !--- Semi monotonic PPM
+                  !----------------------------------------------------------
+                     CALL ppm3d(1,qppm(1,1,iq),psppm,psppm,unatppm,vnatppm,fluxwppm,dtbon, &
+                                4,4,4,1,iim,jjp1,2,llm,apppm,bpppm,0.01,6400000, fill,dum,220.)
+                  !----------------------------------------------------------
+                  CASE(18) !--- Positive Definite PPM
+                  !----------------------------------------------------------
+                     CALL ppm3d(1,qppm(1,1,iq),psppm,psppm,unatppm,vnatppm,fluxwppm,dtbon, &
+                                5,5,5,1,iim,jjp1,2,llm,apppm,bpppm,0.01,6400000,fill,dum,220.)
+               END SELECT
+            !----------------------------------------------------------------
+            END DO
+            !----------------------------------------------------------------
+            !     Ss-prg interface PPM3d-LMDZ.4
+            !----------------------------------------------------------------
+            CALL interpost(q(1,1,iq),qppm(1,1,iq))
+      !----------------------------------------------------------------------
+      END SELECT
+      !----------------------------------------------------------------------
+
+      !----------------------------------------------------------------------
+      ! On impose une seule valeur du traceur au pole Sud j=jjm+1=jjp1 et Nord j=1
+      !----------------------------------------------------------------------
+      !  CALL traceurpole(q(1,1,iq),massem)
+
+      !--- Calcul du temps cpu pour un schema donne
+      !  CALL clock(t_final)
+      !ym  tps_cpu=t_final-t_initial
+      !ym  cpuadv(iq)=cpuadv(iq)+tps_cpu
+
+   END DO
+
+1234 CONTINUE
+!$OMP BARRIER
+   IF(planet_type=="earth") THEN
+      ijb=ij_begin
+      ije=ij_end
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
+      DO l = 1, llm
+         DO ij = ijb, ije
+            finmasse(ij,l) =  p(ij,l) - p(ij,l+1) 
+         END DO
+      END DO
+!$OMP END DO
+
+      CALL qminimum_loc( q, nqtot, finmasse )
+
+   END IF ! of if (planet_type=="earth")
+
+END SUBROUTINE advtrac_loc
+
Index: DZ6/trunk/libf/dyn3dmem/advtrac_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/advtrac_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,36 +1,0 @@
-MODULE advtrac_mod
-
-  REAL,POINTER,SAVE :: finmasse(:,:)
-  
-CONTAINS
-
-  SUBROUTINE advtrac_allocate
-  USE bands
-  USE allocate_field_mod
-  USE parallel_lmdz
-  USE vlspltgen_mod
-  IMPLICIT NONE
-  INCLUDE "dimensions.h"
-  INCLUDE "paramet.h"
-  TYPE(distrib),POINTER :: d
-    
-    d=>distrib_vanleer
-    CALL allocate_u(finmasse,llm,d)
-    CALL vlspltgen_allocate
-  END SUBROUTINE advtrac_allocate
-  
-  SUBROUTINE advtrac_switch_vanleer(dist)
-  USE allocate_field_mod
-  USE bands
-  USE parallel_lmdz
-  USE vlspltgen_mod
-  IMPLICIT NONE
-    TYPE(distrib),INTENT(IN) :: dist
-  
-    CALL switch_u(finmasse,distrib_vanleer,dist)
-
-    CALL vlspltgen_switch_vanleer(dist)
-
-  END SUBROUTINE advtrac_switch_vanleer  
-  
-END MODULE advtrac_mod  
Index: /LMDZ6/trunk/libf/dyn3dmem/advtrac_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/advtrac_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3dmem/advtrac_mod.f90	(revision 5268)
@@ -0,0 +1,36 @@
+MODULE advtrac_mod
+
+  REAL,POINTER,SAVE :: finmasse(:,:)
+  
+CONTAINS
+
+  SUBROUTINE advtrac_allocate
+  USE bands
+  USE allocate_field_mod
+  USE parallel_lmdz
+  USE vlspltgen_mod
+  IMPLICIT NONE
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  TYPE(distrib),POINTER :: d
+    
+    d=>distrib_vanleer
+    CALL allocate_u(finmasse,llm,d)
+    CALL vlspltgen_allocate
+  END SUBROUTINE advtrac_allocate
+  
+  SUBROUTINE advtrac_switch_vanleer(dist)
+  USE allocate_field_mod
+  USE bands
+  USE parallel_lmdz
+  USE vlspltgen_mod
+  IMPLICIT NONE
+    TYPE(distrib),INTENT(IN) :: dist
+  
+    CALL switch_u(finmasse,distrib_vanleer,dist)
+
+    CALL vlspltgen_switch_vanleer(dist)
+
+  END SUBROUTINE advtrac_switch_vanleer  
+  
+END MODULE advtrac_mod  
Index: DZ6/trunk/libf/dyn3dmem/allocate_field_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/allocate_field_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,739 +1,0 @@
-MODULE allocate_field_mod
-
-  INTERFACE allocate_u
-    MODULE PROCEDURE allocate1d_u1d,allocate2d_u1d,allocate3d_u1d
-  END INTERFACE allocate_u
-
-  INTERFACE switch_u
-    MODULE PROCEDURE switch1d_u1d,switch2d_u1d,switch3d_u1d
-  END INTERFACE switch_u
-
-  INTERFACE switch_v
-    MODULE PROCEDURE switch1d_v1d,switch2d_v1d,switch3d_v1d
-  END INTERFACE switch_v
-
-  INTERFACE allocate_v
-    MODULE PROCEDURE allocate1d_v1d,allocate2d_v1d,allocate3d_v1d
-  END INTERFACE allocate_v
-
-  INTERFACE allocate2d_u
-    MODULE PROCEDURE allocate1d_u2d,allocate2d_u2d,allocate3d_u2d
-  END INTERFACE allocate2d_u
-
-  INTERFACE allocate2d_v
-    MODULE PROCEDURE allocate1d_v2d,allocate2d_v2d,allocate3d_v2d
-  END INTERFACE allocate2d_v
-
-  INTERFACE switch2d_u
-    MODULE PROCEDURE switch1d_u2d,switch2d_u2d,switch3d_u2d
-  END INTERFACE switch2d_u
-
-  INTERFACE switch2d_v
-    MODULE PROCEDURE switch1d_v2d,switch2d_v2d,switch3d_v2d
-  END INTERFACE switch2D_v
-
-  REAL :: nan
-
-CONTAINS
-
-  SUBROUTINE Init_nan
-  IMPLICIT NONE
-    REAL*8 :: rnan
-    INTEGER :: inan(2)
-    EQUIVALENCE(rnan,inan)
-    
-    inan(1)=2147483647
-    inan(2)=2147483647
-    
-    nan=rnan
-  
-  END SUBROUTINE Init_nan
-
-  SUBROUTINE allocate1d_u1d(field,d)
-  USE parallel_lmdz
-  IMPLICIT NONE
-  REAL,POINTER :: field(:)
-  TYPE(distrib),INTENT(IN) :: d
-
-!$OMP BARRIER
-!$OMP MASTER    
-    IF (ASSOCIATED(field)) DEALLOCATE(field)
-    ALLOCATE(field(d%ijb_u:d%ije_u))
-!$OMP END MASTER
-!$OMP BARRIER
-
-  END SUBROUTINE allocate1d_u1d
-
-
-  SUBROUTINE allocate2d_u1d(field,dim1,d)
-  USE parallel_lmdz
-  IMPLICIT NONE
-  REAL,POINTER :: field(:,:)
-  INTEGER      :: dim1
-  TYPE(distrib),INTENT(IN) :: d
-
-!$OMP BARRIER
-!$OMP MASTER    
-    IF (ASSOCIATED(field)) DEALLOCATE(field)
-    ALLOCATE(field(d%ijb_u:d%ije_u,dim1))
-!$OMP END MASTER
-!$OMP BARRIER
-
-  END SUBROUTINE allocate2d_u1d 
-
-  SUBROUTINE allocate3d_u1d(field,dim1,dim2,d)
-  USE parallel_lmdz
-  IMPLICIT NONE
-  REAL,POINTER :: field(:,:,:)
-  INTEGER      :: dim1,dim2
-  TYPE(distrib),INTENT(IN) :: d
-
-!$OMP BARRIER
-!$OMP MASTER    
-    IF (ASSOCIATED(field)) DEALLOCATE(field)
-    ALLOCATE(field(d%ijb_u:d%ije_u,dim1,dim2))
-!$OMP END MASTER
-!$OMP BARRIER
-
-  END SUBROUTINE allocate3d_u1d   
-
-
-
-  SUBROUTINE allocate1d_v1d(field,d)
-  USE parallel_lmdz
-  IMPLICIT NONE
-  REAL,POINTER :: field(:)
-  TYPE(distrib),INTENT(IN) :: d
-
-!$OMP BARRIER
-!$OMP MASTER    
-    IF (ASSOCIATED(field)) DEALLOCATE(field)
-    ALLOCATE(field(d%ijb_v:d%ije_v))
-!$OMP END MASTER
-!$OMP BARRIER
-
-  END SUBROUTINE allocate1d_v1d
-
-
-  SUBROUTINE allocate2d_v1d(field,dim1,d)
-  USE parallel_lmdz
-  IMPLICIT NONE
-  REAL,POINTER :: field(:,:)
-  INTEGER      :: dim1
-  TYPE(distrib),INTENT(IN) :: d
-
-!$OMP BARRIER
-!$OMP MASTER    
-    IF (ASSOCIATED(field)) DEALLOCATE(field)
-    ALLOCATE(field(d%ijb_v:d%ije_v,dim1))
-!$OMP END MASTER
-!$OMP BARRIER
-
-  END SUBROUTINE allocate2d_v1d 
-
-  SUBROUTINE allocate3d_v1d(field,dim1,dim2,d)
-  USE parallel_lmdz
-  IMPLICIT NONE
-  REAL,POINTER :: field(:,:,:)
-  INTEGER      :: dim1,dim2
-  TYPE(distrib),INTENT(IN) :: d
-
-!$OMP BARRIER
-!$OMP MASTER    
-    IF (ASSOCIATED(field)) DEALLOCATE(field)
-    ALLOCATE(field(d%ijb_v:d%ije_v,dim1,dim2))
-!$OMP END MASTER
-!$OMP BARRIER
-
-  END SUBROUTINE allocate3d_v1d   
-
-
-
-
-
-
-
-
-
-  SUBROUTINE allocate1d_u2d(field,d)
-  USE parallel_lmdz
-  USE dimensions_mod
-  IMPLICIT NONE
-  REAL,POINTER :: field(:,:)
-  TYPE(distrib),INTENT(IN) :: d
-
-!$OMP BARRIER
-!$OMP MASTER    
-    IF (ASSOCIATED(field)) DEALLOCATE(field)
-    ALLOCATE(field(iip1,d%jjb_u:d%jje_u))
-!$OMP END MASTER
-!$OMP BARRIER
-
-  END SUBROUTINE allocate1d_u2d
-
-
-  SUBROUTINE allocate2d_u2d(field,dim1,d)
-  USE parallel_lmdz
-  USE dimensions_mod
-  IMPLICIT NONE
-  REAL,POINTER :: field(:,:,:)
-  INTEGER      :: dim1
-  TYPE(distrib),INTENT(IN) :: d
-
-!$OMP BARRIER
-!$OMP MASTER    
-    IF (ASSOCIATED(field)) DEALLOCATE(field)
-    ALLOCATE(field(iip1,d%jjb_u:d%jje_u,dim1))
-!$OMP END MASTER
-!$OMP BARRIER
-
-  END SUBROUTINE allocate2d_u2d
-
-  SUBROUTINE allocate3d_u2d(field,dim1,dim2,d)
-  USE parallel_lmdz
-  USE dimensions_mod
-  IMPLICIT NONE
-  REAL,POINTER :: field(:,:,:,:)
-  INTEGER      :: dim1,dim2
-  TYPE(distrib),INTENT(IN) :: d
-
-!$OMP BARRIER
-!$OMP MASTER    
-    IF (ASSOCIATED(field)) DEALLOCATE(field)
-    ALLOCATE(field(iip1,d%jjb_u:d%jje_u,dim1,dim2))
-!$OMP END MASTER
-!$OMP BARRIER
-
-  END SUBROUTINE allocate3d_u2d   
-
-
-
-  SUBROUTINE allocate1d_v2d(field,d)
-  USE parallel_lmdz
-  USE dimensions_mod
-  IMPLICIT NONE
-  REAL,POINTER :: field(:,:)
-  TYPE(distrib),INTENT(IN) :: d
-
-!$OMP BARRIER
-!$OMP MASTER    
-    IF (ASSOCIATED(field)) DEALLOCATE(field)
-    ALLOCATE(field(iip1,d%jjb_v:d%jje_v))
-!$OMP END MASTER
-!$OMP BARRIER
-
-  END SUBROUTINE allocate1d_v2d
-
-
-  SUBROUTINE allocate2d_v2d(field,dim1,d)
-  USE parallel_lmdz
-  USE dimensions_mod
-  IMPLICIT NONE
-  REAL,POINTER :: field(:,:,:)
-  INTEGER      :: dim1
-  TYPE(distrib),INTENT(IN) :: d
-
-!$OMP BARRIER
-!$OMP MASTER    
-    IF (ASSOCIATED(field)) DEALLOCATE(field)
-    ALLOCATE(field(iip1,d%jjb_v:d%jje_v,dim1))
-!$OMP END MASTER
-!$OMP BARRIER
-
-  END SUBROUTINE allocate2d_v2d
-
-  SUBROUTINE allocate3d_v2d(field,dim1,dim2,d)
-  USE parallel_lmdz
-  USE dimensions_mod
-  IMPLICIT NONE
-  REAL,POINTER :: field(:,:,:,:)
-  INTEGER      :: dim1,dim2
-  TYPE(distrib),INTENT(IN) :: d
-
-!$OMP BARRIER
-!$OMP MASTER    
-    IF (ASSOCIATED(field)) DEALLOCATE(field)
-    ALLOCATE(field(iip1,d%jjb_v:d%jje_v,dim1,dim2))
-!$OMP END MASTER
-!$OMP BARRIER
-
-  END SUBROUTINE allocate3d_v2d   
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-  SUBROUTINE switch1d_u1d(field,old_dist,new_dist,up,down)
-  USE parallel_lmdz
-  USE mod_hallo
-  IMPLICIT NONE
-  REAL,POINTER :: field(:)
-  TYPE(distrib),INTENT(IN) :: old_dist
-  TYPE(distrib),INTENT(IN) :: new_dist
-  INTEGER, OPTIONAL,INTENT(IN) :: up
-  INTEGER, OPTIONAL,INTENT(IN) :: down
-  
-  REAL,POINTER,SAVE :: new_field(:)
-  TYPE(request) :: req
-  
-  !$OMP BARRIER
-  !$OMP MASTER    
-    ALLOCATE(new_field(new_dist%ijb_u:new_dist%ije_u))
-    new_field=nan
-  !$OMP END MASTER
-  !$OMP BARRIER
-    CALL Register_SwapField_u(field,new_field,new_dist,req,old_dist=old_dist,up=up,down=down)
-  
-    CALL SendRequest(req)
-
-  !$OMP BARRIER
-    CALL WaitRequest(req)     
-  !$OMP BARRIER
-    
-  !$OMP MASTER
-    DEALLOCATE(field)
-    field=>new_field
-  !$OMP END MASTER
-  !$OMP BARRIER
-   
-    CALL barrier
-  END SUBROUTINE switch1d_u1d  
-  
-  SUBROUTINE switch2d_u1d(field,old_dist,new_dist,up,down)
-  USE parallel_lmdz
-  USE mod_hallo
-  IMPLICIT NONE
-  REAL,POINTER :: field(:,:)
-  TYPE(distrib),INTENT(IN) :: old_dist
-  TYPE(distrib),INTENT(IN) :: new_dist
-  INTEGER, OPTIONAL,INTENT(IN) :: up
-  INTEGER, OPTIONAL,INTENT(IN) :: down
-
-  REAL,POINTER,SAVE :: new_field(:,:)
-  TYPE(request) :: req
-  
-  !$OMP BARRIER
-  !$OMP MASTER    
-    ALLOCATE(new_field(new_dist%ijb_u:new_dist%ije_u,size(field,2)))
-    new_field=nan
-  !$OMP END MASTER
-  !$OMP BARRIER
-    CALL Register_SwapField_u(field,new_field,new_dist,req,old_dist=old_dist,up=up,down=down)
-  
-    CALL SendRequest(req)
-
-  !$OMP BARRIER
-    CALL WaitRequest(req)     
-  !$OMP BARRIER
-    
-  !$OMP MASTER
-    DEALLOCATE(field)
-    field=>new_field
-  !$OMP END MASTER
-  !$OMP BARRIER
-    CALL barrier
-
-  END SUBROUTINE switch2d_u1d  
-
-  SUBROUTINE switch3d_u1d(field,old_dist,new_dist,up,down)
-  USE parallel_lmdz
-  USE mod_hallo
-  IMPLICIT NONE
-  REAL,POINTER :: field(:,:,:)
-  TYPE(distrib),INTENT(IN) :: old_dist
-  TYPE(distrib),INTENT(IN) :: new_dist
-  INTEGER, OPTIONAL,INTENT(IN) :: up
-  INTEGER, OPTIONAL,INTENT(IN) :: down
-
-  REAL,POINTER,SAVE :: new_field(:,:,:)
-  TYPE(request) :: req
-  
-  !$OMP BARRIER
-  !$OMP MASTER    
-    ALLOCATE(new_field(new_dist%ijb_u:new_dist%ije_u,size(field,2),size(field,3)))
-    new_field=nan
-  !$OMP END MASTER
-  !$OMP BARRIER
-    CALL Register_SwapField_u(field,new_field,new_dist,req,old_dist=old_dist,up=up,down=down)
-  
-    CALL SendRequest(req)
-
-  !$OMP BARRIER
-    CALL WaitRequest(req)     
-  !$OMP BARRIER
-    
-  !$OMP MASTER
-    DEALLOCATE(field)
-    field=>new_field
-  !$OMP END MASTER
-  !$OMP BARRIER
-    CALL barrier
-
-  END SUBROUTINE switch3d_u1d  
-
-
-
-
-  SUBROUTINE switch1d_v1d(field,old_dist,new_dist,up,down)
-  USE parallel_lmdz
-  USE mod_hallo
-  IMPLICIT NONE
-  REAL,POINTER :: field(:)
-  TYPE(distrib),INTENT(IN) :: old_dist
-  TYPE(distrib),INTENT(IN) :: new_dist
-  INTEGER, OPTIONAL,INTENT(IN) :: up
-  INTEGER, OPTIONAL,INTENT(IN) :: down
-
-  REAL,POINTER,SAVE :: new_field(:)
-  TYPE(request) :: req
-  
-  !$OMP BARRIER
-  !$OMP MASTER    
-    ALLOCATE(new_field(new_dist%ijb_v:new_dist%ije_v))
-    new_field=nan
-  !$OMP END MASTER
-  !$OMP BARRIER
-    CALL Register_SwapField_v(field,new_field,new_dist,req,old_dist=old_dist,up=up,down=down)
-  
-    CALL SendRequest(req)
-
-  !$OMP BARRIER
-    CALL WaitRequest(req)     
-  !$OMP BARRIER
-    
-  !$OMP MASTER
-    DEALLOCATE(field)
-    field=>new_field
-  !$OMP END MASTER
-  !$OMP BARRIER
-
-    CALL barrier
-  END SUBROUTINE switch1d_v1d  
-  
-  SUBROUTINE switch2d_v1d(field,old_dist,new_dist,up,down)
-  USE parallel_lmdz
-  USE mod_hallo
-  IMPLICIT NONE
-  REAL,POINTER :: field(:,:)
-  TYPE(distrib),INTENT(IN) :: old_dist
-  TYPE(distrib),INTENT(IN) :: new_dist
-  INTEGER, OPTIONAL,INTENT(IN) :: up
-  INTEGER, OPTIONAL,INTENT(IN) :: down
-
-  REAL,POINTER,SAVE :: new_field(:,:)
-  TYPE(request) :: req
-  
-  !$OMP BARRIER
-  !$OMP MASTER    
-    ALLOCATE(new_field(new_dist%ijb_v:new_dist%ije_v,size(field,2)))
-    new_field=nan
-  !$OMP END MASTER
-  !$OMP BARRIER
-    CALL Register_SwapField_v(field,new_field,new_dist,req,old_dist=old_dist,up=up,down=down)
-  
-    CALL SendRequest(req)
-
-  !$OMP BARRIER
-    CALL WaitRequest(req)     
-  !$OMP BARRIER
-    
-  !$OMP MASTER
-    DEALLOCATE(field)
-    field=>new_field
-  !$OMP END MASTER
-  !$OMP BARRIER
-    CALL barrier
-
-  END SUBROUTINE switch2d_v1d  
-
-  SUBROUTINE switch3d_v1d(field,old_dist,new_dist,up,down)
-  USE parallel_lmdz
-  USE mod_hallo
-  IMPLICIT NONE
-  REAL,POINTER :: field(:,:,:)
-  TYPE(distrib),INTENT(IN) :: old_dist
-  TYPE(distrib),INTENT(IN) :: new_dist
-  INTEGER, OPTIONAL,INTENT(IN) :: up
-  INTEGER, OPTIONAL,INTENT(IN) :: down
-
-  REAL,POINTER,SAVE :: new_field(:,:,:)
-  TYPE(request) :: req
-  
-  !$OMP BARRIER
-  !$OMP MASTER    
-    ALLOCATE(new_field(new_dist%ijb_v:new_dist%ije_v,size(field,2),size(field,3)))
-    new_field=nan
-  !$OMP END MASTER
-  !$OMP BARRIER
-    CALL Register_SwapField_v(field,new_field,new_dist,req,old_dist=old_dist,up=up,down=down)
-  
-    CALL SendRequest(req)
-
-  !$OMP BARRIER
-    CALL WaitRequest(req)     
-  !$OMP BARRIER
-    
-  !$OMP MASTER
-    DEALLOCATE(field)
-    field=>new_field
-  !$OMP END MASTER
-  !$OMP BARRIER
-    CALL barrier
-
-  END SUBROUTINE switch3d_v1d  
-
-
-
-
-
-
-
-
-
-
-
-
-  SUBROUTINE switch1d_u2d(field,old_dist,new_dist,up,down)
-  USE parallel_lmdz
-  USE mod_hallo
-  USE dimensions_mod
-  IMPLICIT NONE
-  REAL,POINTER :: field(:,:)
-  TYPE(distrib),INTENT(IN) :: old_dist
-  TYPE(distrib),INTENT(IN) :: new_dist
-  INTEGER, OPTIONAL,INTENT(IN) :: up
-  INTEGER, OPTIONAL,INTENT(IN) :: down
-
-  REAL,POINTER,SAVE :: new_field(:,:)
-  TYPE(request) :: req
-  
-  !$OMP BARRIER
-  !$OMP MASTER    
-    ALLOCATE(new_field(iip1,new_dist%jjb_u:new_dist%jje_u))
-    new_field=nan
-  !$OMP END MASTER
-  !$OMP BARRIER
-    CALL Register_SwapField2d_u(field,new_field,new_dist,req,old_dist=old_dist,up=up,down=down)
-  
-    CALL SendRequest(req)
-
-  !$OMP BARRIER
-    CALL WaitRequest(req)     
-  !$OMP BARRIER
-    
-  !$OMP MASTER
-    DEALLOCATE(field)
-    field=>new_field
-  !$OMP END MASTER
-  !$OMP BARRIER
-    CALL barrier
-
-  END SUBROUTINE switch1d_u2d  
-  
-  SUBROUTINE switch2d_u2d(field,old_dist,new_dist,up,down)
-  USE parallel_lmdz
-  USE mod_hallo
-  USE dimensions_mod
-  IMPLICIT NONE
-  REAL,POINTER :: field(:,:,:)
-  TYPE(distrib),INTENT(IN) :: old_dist
-  TYPE(distrib),INTENT(IN) :: new_dist
-  INTEGER, OPTIONAL,INTENT(IN) :: up
-  INTEGER, OPTIONAL,INTENT(IN) :: down
-
-  REAL,POINTER,SAVE :: new_field(:,:,:)
-  TYPE(request) :: req
-  
-  !$OMP BARRIER
-  !$OMP MASTER    
-    ALLOCATE(new_field(iip1,new_dist%jjb_u:new_dist%jje_u,size(field,3)))
-    new_field=nan
-  !$OMP END MASTER
-  !$OMP BARRIER
-    CALL Register_SwapField2d_u(field,new_field,new_dist,req,old_dist=old_dist,up=up,down=down)
-  
-    CALL SendRequest(req)
-
-  !$OMP BARRIER
-    CALL WaitRequest(req)     
-  !$OMP BARRIER
-    
-  !$OMP MASTER
-    DEALLOCATE(field)
-    field=>new_field
-  !$OMP END MASTER
-  !$OMP BARRIER
-    CALL barrier
-
-  END SUBROUTINE switch2d_u2d  
-
-  SUBROUTINE switch3d_u2d(field,old_dist,new_dist,up,down)
-  USE parallel_lmdz
-  USE mod_hallo
-  USE dimensions_mod
-  IMPLICIT NONE
-  REAL,POINTER :: field(:,:,:,:)
-  TYPE(distrib),INTENT(IN) :: old_dist
-  TYPE(distrib),INTENT(IN) :: new_dist
-  INTEGER, OPTIONAL,INTENT(IN) :: up
-  INTEGER, OPTIONAL,INTENT(IN) :: down
-
-  REAL,POINTER,SAVE :: new_field(:,:,:,:)
-  TYPE(request) :: req
-  
-  !$OMP BARRIER
-  !$OMP MASTER    
-    ALLOCATE(new_field(iip1,new_dist%jjb_u:new_dist%jje_u,size(field,3),size(field,4)))
-    new_field=nan
-  !$OMP END MASTER
-  !$OMP BARRIER
-    CALL Register_SwapField2d_u(field,new_field,new_dist,req,old_dist=old_dist,up=up,down=down)
-  
-    CALL SendRequest(req)
-
-  !$OMP BARRIER
-    CALL WaitRequest(req)     
-  !$OMP BARRIER
-    
-  !$OMP MASTER
-    DEALLOCATE(field)
-    field=>new_field
-  !$OMP END MASTER
-  !$OMP BARRIER
-    CALL barrier
-
-  END SUBROUTINE switch3d_u2d  
-
-
-
-
-  SUBROUTINE switch1d_v2d(field,old_dist,new_dist,up,down)
-  USE parallel_lmdz
-  USE mod_hallo
-  USE dimensions_mod
-  IMPLICIT NONE
-  REAL,POINTER :: field(:,:)
-  TYPE(distrib),INTENT(IN) :: old_dist
-  TYPE(distrib),INTENT(IN) :: new_dist
-  INTEGER, OPTIONAL,INTENT(IN) :: up
-  INTEGER, OPTIONAL,INTENT(IN) :: down
-
-  REAL,POINTER,SAVE :: new_field(:,:)
-  TYPE(request) :: req
-  
-  !$OMP BARRIER
-  !$OMP MASTER    
-    ALLOCATE(new_field(iip1,new_dist%jjb_v:new_dist%jje_v))
-    new_field=nan
-  !$OMP END MASTER
-  !$OMP BARRIER
-    CALL Register_SwapField2d_v(field,new_field,new_dist,req,old_dist=old_dist,up=up,down=down)
-  
-    CALL SendRequest(req)
-
-  !$OMP BARRIER
-    CALL WaitRequest(req)     
-  !$OMP BARRIER
-    
-  !$OMP MASTER
-    DEALLOCATE(field)
-    field=>new_field
-  !$OMP END MASTER
-  !$OMP BARRIER
-    CALL barrier
-
-  END SUBROUTINE switch1d_v2d  
-  
-  SUBROUTINE switch2d_v2d(field,old_dist,new_dist,up,down)
-  USE parallel_lmdz
-  USE mod_hallo
-  USE dimensions_mod
-  IMPLICIT NONE
-  REAL,POINTER :: field(:,:,:)
-  TYPE(distrib),INTENT(IN) :: old_dist
-  TYPE(distrib),INTENT(IN) :: new_dist
-  INTEGER, OPTIONAL,INTENT(IN) :: up
-  INTEGER, OPTIONAL,INTENT(IN) :: down
-
-  REAL,POINTER,SAVE :: new_field(:,:,:)
-  TYPE(request) :: req
-  
-  !$OMP BARRIER
-  !$OMP MASTER    
-    ALLOCATE(new_field(iip1,new_dist%jjb_v:new_dist%jje_v,size(field,3)))
-    new_field=nan
-  !$OMP END MASTER
-  !$OMP BARRIER
-    CALL Register_SwapField2d_v(field,new_field,new_dist,req,old_dist=old_dist,up=up,down=down)
-  
-    CALL SendRequest(req)
-
-  !$OMP BARRIER
-    CALL WaitRequest(req)     
-  !$OMP BARRIER
-    
-  !$OMP MASTER
-    DEALLOCATE(field)
-    field=>new_field
-  !$OMP END MASTER
-  !$OMP BARRIER
-
-    CALL barrier
-  END SUBROUTINE switch2d_v2d  
-
-  SUBROUTINE switch3d_v2d(field,old_dist,new_dist,up,down)
-  USE parallel_lmdz
-  USE mod_hallo
-  USE dimensions_mod
-  IMPLICIT NONE
-  REAL,POINTER :: field(:,:,:,:)
-  TYPE(distrib),INTENT(IN) :: old_dist
-  TYPE(distrib),INTENT(IN) :: new_dist
-  INTEGER, OPTIONAL,INTENT(IN) :: up
-  INTEGER, OPTIONAL,INTENT(IN) :: down
-
-  REAL,POINTER,SAVE :: new_field(:,:,:,:)
-  TYPE(request) :: req
-  
-  !$OMP BARRIER
-  !$OMP MASTER    
-    ALLOCATE(new_field(iip1,new_dist%jjb_v:new_dist%jje_v,size(field,3),size(field,4)))
-    new_field=nan
-  !$OMP END MASTER
-  !$OMP BARRIER
-    CALL Register_SwapField2d_v(field,new_field,new_dist,req,old_dist=old_dist,up=up,down=down)
-  
-    CALL SendRequest(req)
-
-  !$OMP BARRIER
-    CALL WaitRequest(req)     
-  !$OMP BARRIER
-    
-  !$OMP MASTER
-    DEALLOCATE(field)
-    field=>new_field
-  !$OMP END MASTER
-  !$OMP BARRIER
-
-    CALL barrier
-  END SUBROUTINE switch3d_v2d 
-
-END MODULE allocate_field_mod
-  
-  
-  
-  
Index: /LMDZ6/trunk/libf/dyn3dmem/allocate_field_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/allocate_field_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3dmem/allocate_field_mod.f90	(revision 5268)
@@ -0,0 +1,739 @@
+MODULE allocate_field_mod
+
+  INTERFACE allocate_u
+    MODULE PROCEDURE allocate1d_u1d,allocate2d_u1d,allocate3d_u1d
+  END INTERFACE allocate_u
+
+  INTERFACE switch_u
+    MODULE PROCEDURE switch1d_u1d,switch2d_u1d,switch3d_u1d
+  END INTERFACE switch_u
+
+  INTERFACE switch_v
+    MODULE PROCEDURE switch1d_v1d,switch2d_v1d,switch3d_v1d
+  END INTERFACE switch_v
+
+  INTERFACE allocate_v
+    MODULE PROCEDURE allocate1d_v1d,allocate2d_v1d,allocate3d_v1d
+  END INTERFACE allocate_v
+
+  INTERFACE allocate2d_u
+    MODULE PROCEDURE allocate1d_u2d,allocate2d_u2d,allocate3d_u2d
+  END INTERFACE allocate2d_u
+
+  INTERFACE allocate2d_v
+    MODULE PROCEDURE allocate1d_v2d,allocate2d_v2d,allocate3d_v2d
+  END INTERFACE allocate2d_v
+
+  INTERFACE switch2d_u
+    MODULE PROCEDURE switch1d_u2d,switch2d_u2d,switch3d_u2d
+  END INTERFACE switch2d_u
+
+  INTERFACE switch2d_v
+    MODULE PROCEDURE switch1d_v2d,switch2d_v2d,switch3d_v2d
+  END INTERFACE switch2D_v
+
+  REAL :: nan
+
+CONTAINS
+
+  SUBROUTINE Init_nan
+  IMPLICIT NONE
+    REAL*8 :: rnan
+    INTEGER :: inan(2)
+    EQUIVALENCE(rnan,inan)
+    
+    inan(1)=2147483647
+    inan(2)=2147483647
+    
+    nan=rnan
+  
+  END SUBROUTINE Init_nan
+
+  SUBROUTINE allocate1d_u1d(field,d)
+  USE parallel_lmdz
+  IMPLICIT NONE
+  REAL,POINTER :: field(:)
+  TYPE(distrib),INTENT(IN) :: d
+
+!$OMP BARRIER
+!$OMP MASTER    
+    IF (ASSOCIATED(field)) DEALLOCATE(field)
+    ALLOCATE(field(d%ijb_u:d%ije_u))
+!$OMP END MASTER
+!$OMP BARRIER
+
+  END SUBROUTINE allocate1d_u1d
+
+
+  SUBROUTINE allocate2d_u1d(field,dim1,d)
+  USE parallel_lmdz
+  IMPLICIT NONE
+  REAL,POINTER :: field(:,:)
+  INTEGER      :: dim1
+  TYPE(distrib),INTENT(IN) :: d
+
+!$OMP BARRIER
+!$OMP MASTER    
+    IF (ASSOCIATED(field)) DEALLOCATE(field)
+    ALLOCATE(field(d%ijb_u:d%ije_u,dim1))
+!$OMP END MASTER
+!$OMP BARRIER
+
+  END SUBROUTINE allocate2d_u1d 
+
+  SUBROUTINE allocate3d_u1d(field,dim1,dim2,d)
+  USE parallel_lmdz
+  IMPLICIT NONE
+  REAL,POINTER :: field(:,:,:)
+  INTEGER      :: dim1,dim2
+  TYPE(distrib),INTENT(IN) :: d
+
+!$OMP BARRIER
+!$OMP MASTER    
+    IF (ASSOCIATED(field)) DEALLOCATE(field)
+    ALLOCATE(field(d%ijb_u:d%ije_u,dim1,dim2))
+!$OMP END MASTER
+!$OMP BARRIER
+
+  END SUBROUTINE allocate3d_u1d   
+
+
+
+  SUBROUTINE allocate1d_v1d(field,d)
+  USE parallel_lmdz
+  IMPLICIT NONE
+  REAL,POINTER :: field(:)
+  TYPE(distrib),INTENT(IN) :: d
+
+!$OMP BARRIER
+!$OMP MASTER    
+    IF (ASSOCIATED(field)) DEALLOCATE(field)
+    ALLOCATE(field(d%ijb_v:d%ije_v))
+!$OMP END MASTER
+!$OMP BARRIER
+
+  END SUBROUTINE allocate1d_v1d
+
+
+  SUBROUTINE allocate2d_v1d(field,dim1,d)
+  USE parallel_lmdz
+  IMPLICIT NONE
+  REAL,POINTER :: field(:,:)
+  INTEGER      :: dim1
+  TYPE(distrib),INTENT(IN) :: d
+
+!$OMP BARRIER
+!$OMP MASTER    
+    IF (ASSOCIATED(field)) DEALLOCATE(field)
+    ALLOCATE(field(d%ijb_v:d%ije_v,dim1))
+!$OMP END MASTER
+!$OMP BARRIER
+
+  END SUBROUTINE allocate2d_v1d 
+
+  SUBROUTINE allocate3d_v1d(field,dim1,dim2,d)
+  USE parallel_lmdz
+  IMPLICIT NONE
+  REAL,POINTER :: field(:,:,:)
+  INTEGER      :: dim1,dim2
+  TYPE(distrib),INTENT(IN) :: d
+
+!$OMP BARRIER
+!$OMP MASTER    
+    IF (ASSOCIATED(field)) DEALLOCATE(field)
+    ALLOCATE(field(d%ijb_v:d%ije_v,dim1,dim2))
+!$OMP END MASTER
+!$OMP BARRIER
+
+  END SUBROUTINE allocate3d_v1d   
+
+
+
+
+
+
+
+
+
+  SUBROUTINE allocate1d_u2d(field,d)
+  USE parallel_lmdz
+  USE dimensions_mod
+  IMPLICIT NONE
+  REAL,POINTER :: field(:,:)
+  TYPE(distrib),INTENT(IN) :: d
+
+!$OMP BARRIER
+!$OMP MASTER    
+    IF (ASSOCIATED(field)) DEALLOCATE(field)
+    ALLOCATE(field(iip1,d%jjb_u:d%jje_u))
+!$OMP END MASTER
+!$OMP BARRIER
+
+  END SUBROUTINE allocate1d_u2d
+
+
+  SUBROUTINE allocate2d_u2d(field,dim1,d)
+  USE parallel_lmdz
+  USE dimensions_mod
+  IMPLICIT NONE
+  REAL,POINTER :: field(:,:,:)
+  INTEGER      :: dim1
+  TYPE(distrib),INTENT(IN) :: d
+
+!$OMP BARRIER
+!$OMP MASTER    
+    IF (ASSOCIATED(field)) DEALLOCATE(field)
+    ALLOCATE(field(iip1,d%jjb_u:d%jje_u,dim1))
+!$OMP END MASTER
+!$OMP BARRIER
+
+  END SUBROUTINE allocate2d_u2d
+
+  SUBROUTINE allocate3d_u2d(field,dim1,dim2,d)
+  USE parallel_lmdz
+  USE dimensions_mod
+  IMPLICIT NONE
+  REAL,POINTER :: field(:,:,:,:)
+  INTEGER      :: dim1,dim2
+  TYPE(distrib),INTENT(IN) :: d
+
+!$OMP BARRIER
+!$OMP MASTER    
+    IF (ASSOCIATED(field)) DEALLOCATE(field)
+    ALLOCATE(field(iip1,d%jjb_u:d%jje_u,dim1,dim2))
+!$OMP END MASTER
+!$OMP BARRIER
+
+  END SUBROUTINE allocate3d_u2d   
+
+
+
+  SUBROUTINE allocate1d_v2d(field,d)
+  USE parallel_lmdz
+  USE dimensions_mod
+  IMPLICIT NONE
+  REAL,POINTER :: field(:,:)
+  TYPE(distrib),INTENT(IN) :: d
+
+!$OMP BARRIER
+!$OMP MASTER    
+    IF (ASSOCIATED(field)) DEALLOCATE(field)
+    ALLOCATE(field(iip1,d%jjb_v:d%jje_v))
+!$OMP END MASTER
+!$OMP BARRIER
+
+  END SUBROUTINE allocate1d_v2d
+
+
+  SUBROUTINE allocate2d_v2d(field,dim1,d)
+  USE parallel_lmdz
+  USE dimensions_mod
+  IMPLICIT NONE
+  REAL,POINTER :: field(:,:,:)
+  INTEGER      :: dim1
+  TYPE(distrib),INTENT(IN) :: d
+
+!$OMP BARRIER
+!$OMP MASTER    
+    IF (ASSOCIATED(field)) DEALLOCATE(field)
+    ALLOCATE(field(iip1,d%jjb_v:d%jje_v,dim1))
+!$OMP END MASTER
+!$OMP BARRIER
+
+  END SUBROUTINE allocate2d_v2d
+
+  SUBROUTINE allocate3d_v2d(field,dim1,dim2,d)
+  USE parallel_lmdz
+  USE dimensions_mod
+  IMPLICIT NONE
+  REAL,POINTER :: field(:,:,:,:)
+  INTEGER      :: dim1,dim2
+  TYPE(distrib),INTENT(IN) :: d
+
+!$OMP BARRIER
+!$OMP MASTER    
+    IF (ASSOCIATED(field)) DEALLOCATE(field)
+    ALLOCATE(field(iip1,d%jjb_v:d%jje_v,dim1,dim2))
+!$OMP END MASTER
+!$OMP BARRIER
+
+  END SUBROUTINE allocate3d_v2d   
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+  SUBROUTINE switch1d_u1d(field,old_dist,new_dist,up,down)
+  USE parallel_lmdz
+  USE mod_hallo
+  IMPLICIT NONE
+  REAL,POINTER :: field(:)
+  TYPE(distrib),INTENT(IN) :: old_dist
+  TYPE(distrib),INTENT(IN) :: new_dist
+  INTEGER, OPTIONAL,INTENT(IN) :: up
+  INTEGER, OPTIONAL,INTENT(IN) :: down
+  
+  REAL,POINTER,SAVE :: new_field(:)
+  TYPE(request) :: req
+  
+  !$OMP BARRIER
+  !$OMP MASTER    
+    ALLOCATE(new_field(new_dist%ijb_u:new_dist%ije_u))
+    new_field=nan
+  !$OMP END MASTER
+  !$OMP BARRIER
+    CALL Register_SwapField_u(field,new_field,new_dist,req,old_dist=old_dist,up=up,down=down)
+  
+    CALL SendRequest(req)
+
+  !$OMP BARRIER
+    CALL WaitRequest(req)     
+  !$OMP BARRIER
+    
+  !$OMP MASTER
+    DEALLOCATE(field)
+    field=>new_field
+  !$OMP END MASTER
+  !$OMP BARRIER
+   
+    CALL barrier
+  END SUBROUTINE switch1d_u1d  
+  
+  SUBROUTINE switch2d_u1d(field,old_dist,new_dist,up,down)
+  USE parallel_lmdz
+  USE mod_hallo
+  IMPLICIT NONE
+  REAL,POINTER :: field(:,:)
+  TYPE(distrib),INTENT(IN) :: old_dist
+  TYPE(distrib),INTENT(IN) :: new_dist
+  INTEGER, OPTIONAL,INTENT(IN) :: up
+  INTEGER, OPTIONAL,INTENT(IN) :: down
+
+  REAL,POINTER,SAVE :: new_field(:,:)
+  TYPE(request) :: req
+  
+  !$OMP BARRIER
+  !$OMP MASTER    
+    ALLOCATE(new_field(new_dist%ijb_u:new_dist%ije_u,size(field,2)))
+    new_field=nan
+  !$OMP END MASTER
+  !$OMP BARRIER
+    CALL Register_SwapField_u(field,new_field,new_dist,req,old_dist=old_dist,up=up,down=down)
+  
+    CALL SendRequest(req)
+
+  !$OMP BARRIER
+    CALL WaitRequest(req)     
+  !$OMP BARRIER
+    
+  !$OMP MASTER
+    DEALLOCATE(field)
+    field=>new_field
+  !$OMP END MASTER
+  !$OMP BARRIER
+    CALL barrier
+
+  END SUBROUTINE switch2d_u1d  
+
+  SUBROUTINE switch3d_u1d(field,old_dist,new_dist,up,down)
+  USE parallel_lmdz
+  USE mod_hallo
+  IMPLICIT NONE
+  REAL,POINTER :: field(:,:,:)
+  TYPE(distrib),INTENT(IN) :: old_dist
+  TYPE(distrib),INTENT(IN) :: new_dist
+  INTEGER, OPTIONAL,INTENT(IN) :: up
+  INTEGER, OPTIONAL,INTENT(IN) :: down
+
+  REAL,POINTER,SAVE :: new_field(:,:,:)
+  TYPE(request) :: req
+  
+  !$OMP BARRIER
+  !$OMP MASTER    
+    ALLOCATE(new_field(new_dist%ijb_u:new_dist%ije_u,size(field,2),size(field,3)))
+    new_field=nan
+  !$OMP END MASTER
+  !$OMP BARRIER
+    CALL Register_SwapField_u(field,new_field,new_dist,req,old_dist=old_dist,up=up,down=down)
+  
+    CALL SendRequest(req)
+
+  !$OMP BARRIER
+    CALL WaitRequest(req)     
+  !$OMP BARRIER
+    
+  !$OMP MASTER
+    DEALLOCATE(field)
+    field=>new_field
+  !$OMP END MASTER
+  !$OMP BARRIER
+    CALL barrier
+
+  END SUBROUTINE switch3d_u1d  
+
+
+
+
+  SUBROUTINE switch1d_v1d(field,old_dist,new_dist,up,down)
+  USE parallel_lmdz
+  USE mod_hallo
+  IMPLICIT NONE
+  REAL,POINTER :: field(:)
+  TYPE(distrib),INTENT(IN) :: old_dist
+  TYPE(distrib),INTENT(IN) :: new_dist
+  INTEGER, OPTIONAL,INTENT(IN) :: up
+  INTEGER, OPTIONAL,INTENT(IN) :: down
+
+  REAL,POINTER,SAVE :: new_field(:)
+  TYPE(request) :: req
+  
+  !$OMP BARRIER
+  !$OMP MASTER    
+    ALLOCATE(new_field(new_dist%ijb_v:new_dist%ije_v))
+    new_field=nan
+  !$OMP END MASTER
+  !$OMP BARRIER
+    CALL Register_SwapField_v(field,new_field,new_dist,req,old_dist=old_dist,up=up,down=down)
+  
+    CALL SendRequest(req)
+
+  !$OMP BARRIER
+    CALL WaitRequest(req)     
+  !$OMP BARRIER
+    
+  !$OMP MASTER
+    DEALLOCATE(field)
+    field=>new_field
+  !$OMP END MASTER
+  !$OMP BARRIER
+
+    CALL barrier
+  END SUBROUTINE switch1d_v1d  
+  
+  SUBROUTINE switch2d_v1d(field,old_dist,new_dist,up,down)
+  USE parallel_lmdz
+  USE mod_hallo
+  IMPLICIT NONE
+  REAL,POINTER :: field(:,:)
+  TYPE(distrib),INTENT(IN) :: old_dist
+  TYPE(distrib),INTENT(IN) :: new_dist
+  INTEGER, OPTIONAL,INTENT(IN) :: up
+  INTEGER, OPTIONAL,INTENT(IN) :: down
+
+  REAL,POINTER,SAVE :: new_field(:,:)
+  TYPE(request) :: req
+  
+  !$OMP BARRIER
+  !$OMP MASTER    
+    ALLOCATE(new_field(new_dist%ijb_v:new_dist%ije_v,size(field,2)))
+    new_field=nan
+  !$OMP END MASTER
+  !$OMP BARRIER
+    CALL Register_SwapField_v(field,new_field,new_dist,req,old_dist=old_dist,up=up,down=down)
+  
+    CALL SendRequest(req)
+
+  !$OMP BARRIER
+    CALL WaitRequest(req)     
+  !$OMP BARRIER
+    
+  !$OMP MASTER
+    DEALLOCATE(field)
+    field=>new_field
+  !$OMP END MASTER
+  !$OMP BARRIER
+    CALL barrier
+
+  END SUBROUTINE switch2d_v1d  
+
+  SUBROUTINE switch3d_v1d(field,old_dist,new_dist,up,down)
+  USE parallel_lmdz
+  USE mod_hallo
+  IMPLICIT NONE
+  REAL,POINTER :: field(:,:,:)
+  TYPE(distrib),INTENT(IN) :: old_dist
+  TYPE(distrib),INTENT(IN) :: new_dist
+  INTEGER, OPTIONAL,INTENT(IN) :: up
+  INTEGER, OPTIONAL,INTENT(IN) :: down
+
+  REAL,POINTER,SAVE :: new_field(:,:,:)
+  TYPE(request) :: req
+  
+  !$OMP BARRIER
+  !$OMP MASTER    
+    ALLOCATE(new_field(new_dist%ijb_v:new_dist%ije_v,size(field,2),size(field,3)))
+    new_field=nan
+  !$OMP END MASTER
+  !$OMP BARRIER
+    CALL Register_SwapField_v(field,new_field,new_dist,req,old_dist=old_dist,up=up,down=down)
+  
+    CALL SendRequest(req)
+
+  !$OMP BARRIER
+    CALL WaitRequest(req)     
+  !$OMP BARRIER
+    
+  !$OMP MASTER
+    DEALLOCATE(field)
+    field=>new_field
+  !$OMP END MASTER
+  !$OMP BARRIER
+    CALL barrier
+
+  END SUBROUTINE switch3d_v1d  
+
+
+
+
+
+
+
+
+
+
+
+
+  SUBROUTINE switch1d_u2d(field,old_dist,new_dist,up,down)
+  USE parallel_lmdz
+  USE mod_hallo
+  USE dimensions_mod
+  IMPLICIT NONE
+  REAL,POINTER :: field(:,:)
+  TYPE(distrib),INTENT(IN) :: old_dist
+  TYPE(distrib),INTENT(IN) :: new_dist
+  INTEGER, OPTIONAL,INTENT(IN) :: up
+  INTEGER, OPTIONAL,INTENT(IN) :: down
+
+  REAL,POINTER,SAVE :: new_field(:,:)
+  TYPE(request) :: req
+  
+  !$OMP BARRIER
+  !$OMP MASTER    
+    ALLOCATE(new_field(iip1,new_dist%jjb_u:new_dist%jje_u))
+    new_field=nan
+  !$OMP END MASTER
+  !$OMP BARRIER
+    CALL Register_SwapField2d_u(field,new_field,new_dist,req,old_dist=old_dist,up=up,down=down)
+  
+    CALL SendRequest(req)
+
+  !$OMP BARRIER
+    CALL WaitRequest(req)     
+  !$OMP BARRIER
+    
+  !$OMP MASTER
+    DEALLOCATE(field)
+    field=>new_field
+  !$OMP END MASTER
+  !$OMP BARRIER
+    CALL barrier
+
+  END SUBROUTINE switch1d_u2d  
+  
+  SUBROUTINE switch2d_u2d(field,old_dist,new_dist,up,down)
+  USE parallel_lmdz
+  USE mod_hallo
+  USE dimensions_mod
+  IMPLICIT NONE
+  REAL,POINTER :: field(:,:,:)
+  TYPE(distrib),INTENT(IN) :: old_dist
+  TYPE(distrib),INTENT(IN) :: new_dist
+  INTEGER, OPTIONAL,INTENT(IN) :: up
+  INTEGER, OPTIONAL,INTENT(IN) :: down
+
+  REAL,POINTER,SAVE :: new_field(:,:,:)
+  TYPE(request) :: req
+  
+  !$OMP BARRIER
+  !$OMP MASTER    
+    ALLOCATE(new_field(iip1,new_dist%jjb_u:new_dist%jje_u,size(field,3)))
+    new_field=nan
+  !$OMP END MASTER
+  !$OMP BARRIER
+    CALL Register_SwapField2d_u(field,new_field,new_dist,req,old_dist=old_dist,up=up,down=down)
+  
+    CALL SendRequest(req)
+
+  !$OMP BARRIER
+    CALL WaitRequest(req)     
+  !$OMP BARRIER
+    
+  !$OMP MASTER
+    DEALLOCATE(field)
+    field=>new_field
+  !$OMP END MASTER
+  !$OMP BARRIER
+    CALL barrier
+
+  END SUBROUTINE switch2d_u2d  
+
+  SUBROUTINE switch3d_u2d(field,old_dist,new_dist,up,down)
+  USE parallel_lmdz
+  USE mod_hallo
+  USE dimensions_mod
+  IMPLICIT NONE
+  REAL,POINTER :: field(:,:,:,:)
+  TYPE(distrib),INTENT(IN) :: old_dist
+  TYPE(distrib),INTENT(IN) :: new_dist
+  INTEGER, OPTIONAL,INTENT(IN) :: up
+  INTEGER, OPTIONAL,INTENT(IN) :: down
+
+  REAL,POINTER,SAVE :: new_field(:,:,:,:)
+  TYPE(request) :: req
+  
+  !$OMP BARRIER
+  !$OMP MASTER    
+    ALLOCATE(new_field(iip1,new_dist%jjb_u:new_dist%jje_u,size(field,3),size(field,4)))
+    new_field=nan
+  !$OMP END MASTER
+  !$OMP BARRIER
+    CALL Register_SwapField2d_u(field,new_field,new_dist,req,old_dist=old_dist,up=up,down=down)
+  
+    CALL SendRequest(req)
+
+  !$OMP BARRIER
+    CALL WaitRequest(req)     
+  !$OMP BARRIER
+    
+  !$OMP MASTER
+    DEALLOCATE(field)
+    field=>new_field
+  !$OMP END MASTER
+  !$OMP BARRIER
+    CALL barrier
+
+  END SUBROUTINE switch3d_u2d  
+
+
+
+
+  SUBROUTINE switch1d_v2d(field,old_dist,new_dist,up,down)
+  USE parallel_lmdz
+  USE mod_hallo
+  USE dimensions_mod
+  IMPLICIT NONE
+  REAL,POINTER :: field(:,:)
+  TYPE(distrib),INTENT(IN) :: old_dist
+  TYPE(distrib),INTENT(IN) :: new_dist
+  INTEGER, OPTIONAL,INTENT(IN) :: up
+  INTEGER, OPTIONAL,INTENT(IN) :: down
+
+  REAL,POINTER,SAVE :: new_field(:,:)
+  TYPE(request) :: req
+  
+  !$OMP BARRIER
+  !$OMP MASTER    
+    ALLOCATE(new_field(iip1,new_dist%jjb_v:new_dist%jje_v))
+    new_field=nan
+  !$OMP END MASTER
+  !$OMP BARRIER
+    CALL Register_SwapField2d_v(field,new_field,new_dist,req,old_dist=old_dist,up=up,down=down)
+  
+    CALL SendRequest(req)
+
+  !$OMP BARRIER
+    CALL WaitRequest(req)     
+  !$OMP BARRIER
+    
+  !$OMP MASTER
+    DEALLOCATE(field)
+    field=>new_field
+  !$OMP END MASTER
+  !$OMP BARRIER
+    CALL barrier
+
+  END SUBROUTINE switch1d_v2d  
+  
+  SUBROUTINE switch2d_v2d(field,old_dist,new_dist,up,down)
+  USE parallel_lmdz
+  USE mod_hallo
+  USE dimensions_mod
+  IMPLICIT NONE
+  REAL,POINTER :: field(:,:,:)
+  TYPE(distrib),INTENT(IN) :: old_dist
+  TYPE(distrib),INTENT(IN) :: new_dist
+  INTEGER, OPTIONAL,INTENT(IN) :: up
+  INTEGER, OPTIONAL,INTENT(IN) :: down
+
+  REAL,POINTER,SAVE :: new_field(:,:,:)
+  TYPE(request) :: req
+  
+  !$OMP BARRIER
+  !$OMP MASTER    
+    ALLOCATE(new_field(iip1,new_dist%jjb_v:new_dist%jje_v,size(field,3)))
+    new_field=nan
+  !$OMP END MASTER
+  !$OMP BARRIER
+    CALL Register_SwapField2d_v(field,new_field,new_dist,req,old_dist=old_dist,up=up,down=down)
+  
+    CALL SendRequest(req)
+
+  !$OMP BARRIER
+    CALL WaitRequest(req)     
+  !$OMP BARRIER
+    
+  !$OMP MASTER
+    DEALLOCATE(field)
+    field=>new_field
+  !$OMP END MASTER
+  !$OMP BARRIER
+
+    CALL barrier
+  END SUBROUTINE switch2d_v2d  
+
+  SUBROUTINE switch3d_v2d(field,old_dist,new_dist,up,down)
+  USE parallel_lmdz
+  USE mod_hallo
+  USE dimensions_mod
+  IMPLICIT NONE
+  REAL,POINTER :: field(:,:,:,:)
+  TYPE(distrib),INTENT(IN) :: old_dist
+  TYPE(distrib),INTENT(IN) :: new_dist
+  INTEGER, OPTIONAL,INTENT(IN) :: up
+  INTEGER, OPTIONAL,INTENT(IN) :: down
+
+  REAL,POINTER,SAVE :: new_field(:,:,:,:)
+  TYPE(request) :: req
+  
+  !$OMP BARRIER
+  !$OMP MASTER    
+    ALLOCATE(new_field(iip1,new_dist%jjb_v:new_dist%jje_v,size(field,3),size(field,4)))
+    new_field=nan
+  !$OMP END MASTER
+  !$OMP BARRIER
+    CALL Register_SwapField2d_v(field,new_field,new_dist,req,old_dist=old_dist,up=up,down=down)
+  
+    CALL SendRequest(req)
+
+  !$OMP BARRIER
+    CALL WaitRequest(req)     
+  !$OMP BARRIER
+    
+  !$OMP MASTER
+    DEALLOCATE(field)
+    field=>new_field
+  !$OMP END MASTER
+  !$OMP BARRIER
+
+    CALL barrier
+  END SUBROUTINE switch3d_v2d 
+
+END MODULE allocate_field_mod
+  
+  
+  
+  
Index: DZ6/trunk/libf/dyn3dmem/bands.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/bands.F90	(revision 5267)
+++ 	(revision )
@@ -1,490 +1,0 @@
-!
-! $Id$
-!
-  module Bands
-  USE parallel_lmdz
-    integer, parameter :: bands_caldyn=1
-    integer, parameter :: bands_vanleer=2
-    integer, parameter :: bands_dissip=3
-    
-    INTEGER,dimension(:),allocatable :: jj_Nb_Caldyn
-    INTEGER,dimension(:),allocatable :: jj_Nb_vanleer
-    INTEGER,dimension(:),allocatable :: jj_Nb_vanleer2
-    INTEGER,dimension(:),allocatable :: jj_Nb_dissip
-    INTEGER,dimension(:),allocatable :: jj_Nb_physic
-    INTEGER,dimension(:),allocatable :: jj_Nb_physic_bis
-   
-    TYPE(distrib),SAVE,TARGET :: distrib_Caldyn
-    TYPE(distrib),SAVE,TARGET :: distrib_vanleer
-    TYPE(distrib),SAVE,TARGET :: distrib_vanleer2
-    TYPE(distrib),SAVE,TARGET :: distrib_dissip
-    TYPE(distrib),SAVE,TARGET :: distrib_physic
-    TYPE(distrib),SAVE,TARGET :: distrib_physic_bis
-
-    INTEGER,dimension(:),allocatable :: distrib_phys
-  
-  contains
-  
-  subroutine AllocateBands
-    USE parallel_lmdz
-    implicit none
-    
-    allocate(jj_Nb_Caldyn(0:MPI_Size-1))
-    allocate(jj_Nb_vanleer(0:MPI_Size-1))
-    allocate(jj_Nb_vanleer2(0:MPI_Size-1))
-    allocate(jj_Nb_dissip(0:MPI_Size-1))
-    allocate(jj_Nb_physic(0:MPI_Size-1))
-    allocate(jj_Nb_physic_bis(0:MPI_Size-1))
-    allocate(distrib_phys(0:MPI_Size-1))
-  
-  end subroutine AllocateBands
-  
-  subroutine Read_distrib
-    USE parallel_lmdz
-    implicit none
-
-    include "dimensions.h"
-      integer :: i,j
-      character (len=4) :: siim,sjjm,sllm,sproc
-      character (len=255) :: filename
-      integer :: unit_number=10
-      integer :: ierr
-    
-      call AllocateBands
-      write(siim,'(i3)') iim
-      write(sjjm,'(i3)') jjm
-      write(sllm,'(i3)') llm
-      write(sproc,'(i3)') mpi_size
-      filename='Bands_'//TRIM(ADJUSTL(siim))//'x'//TRIM(ADJUSTL(sjjm))//'x'//TRIM(ADJUSTL(sllm))//'_'  &
-                        //TRIM(ADJUSTL(sproc))//'prc.dat'    
-       
-      OPEN(UNIT=unit_number,FILE=trim(filename),STATUS='old',FORM='formatted',IOSTAT=ierr)
-      
-      if (ierr==0) then
-      
-         do i=0,mpi_size-1
-          read (unit_number,*) j,jj_nb_caldyn(i)
-        enddo
-      
-        do i=0,mpi_size-1
-          read (unit_number,*) j,jj_nb_vanleer(i)
-        enddo
-      
-        do i=0,mpi_size-1
-          read (unit_number,*) j,jj_nb_dissip(i)
-        enddo
-      
-        do i=0,mpi_size-1
-          read (unit_number,*) j,distrib_phys(i)
-        enddo
-	
-	CLOSE(unit_number)  
-  
-      else
-        do i=0,mpi_size-1
-          jj_nb_caldyn(i)=(jjm+1)/mpi_size
-	  if (i<MOD(jjm+1,mpi_size)) jj_nb_caldyn(i)=jj_nb_caldyn(i)+1
-        enddo
-      
-        jj_nb_vanleer(:)=jj_nb_caldyn(:)
-        jj_nb_dissip(:)=jj_nb_caldyn(:)
-        
-	do i=0,mpi_size-1
-	  distrib_phys(i)=(iim*(jjm-1)+2)/mpi_size
-	  IF (i<MOD(iim*(jjm-1)+2,mpi_size)) distrib_phys(i)=distrib_phys(i)+1
-	enddo
-      endif
-      
-!      distrib_phys(:)=jj_nb_caldyn(:)*iim
-!      distrib_phys(0) = distrib_phys(0) - (iim-1)
-!      distrib_phys(mpi_size-1) = distrib_phys(mpi_size-1) - (iim-1)
-      
-   end subroutine Read_distrib
-   
-   
-   SUBROUTINE  Set_Bands 
-     USE parallel_lmdz
-     IMPLICIT NONE
-     INCLUDE 'dimensions.h'    
-     INTEGER :: i, ij
-     INTEGER :: jj_para_begin(0:mpi_size-1)
-     INTEGER :: jj_para_end(0:mpi_size-1)
-        
-      do i=0,mpi_size-1
-         jj_nb_vanleer2(i)=(jjm+1)/mpi_size
-	 if (i<MOD(jjm+1,mpi_size)) jj_nb_vanleer2(i)=jj_nb_vanleer2(i)+1
-      enddo
-          
-      jj_para_begin(0)=1
-      ij=distrib_phys(0)+iim-1
-      jj_para_end(0)=((ij-1)/iim)+1
-      
-      DO i=1,mpi_Size-1
-        ij=ij+1
-        jj_para_begin(i)=((ij-1)/iim)+1
-        ij=ij+distrib_phys(i)-1
-        jj_para_end(i)=((ij-1)/iim)+1
-      ENDDO
- 
-       do i=0,MPI_Size-1
-        jj_Nb_physic(i)=jj_para_end(i)-jj_para_begin(i)+1
-        if (i/=0) then
-          if (jj_para_begin(i)==jj_para_end(i-1)) then
-            jj_Nb_physic(i-1)=jj_Nb_physic(i-1)-1
-          endif
-        endif
-      enddo
-      
-      do i=0,MPI_Size-1
-        jj_Nb_physic_bis(i)=jj_para_end(i)-jj_para_begin(i)+1
-        if (i/=0) then
-          if (jj_para_begin(i)==jj_para_end(i-1)) then
-            jj_Nb_physic_bis(i)=jj_Nb_physic_bis(i)-1
-          else
-	    jj_Nb_physic_bis(i-1)=jj_Nb_physic_bis(i-1)+1
-	    jj_Nb_physic_bis(i)=jj_Nb_physic_bis(i)-1
-	  endif
-        endif
-      enddo
-
-      CALL create_distrib(jj_Nb_Caldyn,distrib_caldyn)
-      CALL create_distrib(jj_Nb_vanleer,distrib_vanleer)
-      CALL create_distrib(jj_Nb_vanleer2,distrib_vanleer2)
-      CALL create_distrib(jj_Nb_dissip,distrib_dissip)
-      CALL create_distrib(jj_Nb_physic,distrib_physic)
-      CALL create_distrib(jj_Nb_physic_bis,distrib_physic_bis)
-      
-      distrib_physic_bis%jjb_u=distrib_physic%jjb_u
-      distrib_physic_bis%jje_u=distrib_physic%jje_u
-      distrib_physic_bis%jjnb_u=distrib_physic%jjnb_u
-
-      distrib_physic_bis%ijb_u=distrib_physic%ijb_u
-      distrib_physic_bis%ije_u=distrib_physic%ije_u
-      distrib_physic_bis%ijnb_u=distrib_physic%ijnb_u
-
-      distrib_physic_bis%jjb_v=distrib_physic%jjb_v
-      distrib_physic_bis%jje_v=distrib_physic%jje_v
-      distrib_physic_bis%jjnb_v=distrib_physic%jjnb_v
-
-      distrib_physic_bis%ijb_v=distrib_physic%ijb_v
-      distrib_physic_bis%ije_v=distrib_physic%ije_v
-      distrib_physic_bis%ijnb_v=distrib_physic%ijnb_v
-     
-    end subroutine Set_Bands
-
-
-    subroutine AdjustBands_caldyn(new_dist)
-      use times
-      USE parallel_lmdz
-      implicit none
-      TYPE(distrib),INTENT(INOUT) :: new_dist
-
-      real :: minvalue,maxvalue
-      integer :: min_proc,max_proc
-      integer :: i,j
-      real,allocatable,dimension(:) :: value
-      integer,allocatable,dimension(:) :: index
-      real :: tmpvalue
-      integer :: tmpindex
-      
-      allocate(value(0:mpi_size-1))
-      allocate(index(0:mpi_size-1))
-        
-  
-      call allgather_timer_average
-
-      do i=0,mpi_size-1
-        value(i)=timer_average(jj_nb_caldyn(i),timer_caldyn,i)
-	index(i)=i
-      enddo
-      
-      do i=0,mpi_size-2
-        do j=i+1,mpi_size-1
-	  if (value(i)>value(j)) then
-	    tmpvalue=value(i)
-	    value(i)=value(j)
-	    value(j)=tmpvalue
-	    
-	    tmpindex=index(i)
-	    index(i)=index(j)
-	    index(j)=tmpindex
-	   endif
-	 enddo
-      enddo
-      
-      maxvalue=value(mpi_size-1)
-      max_proc=index(mpi_size-1)           
-           
-      do i=0,mpi_size-2
-        minvalue=value(i)
-        min_proc=index(i)
-        if (jj_nb_caldyn(max_proc)>2) then
-          if (timer_iteration(jj_nb_caldyn(min_proc)+1,timer_caldyn,min_proc)<=1 ) then
-             jj_nb_caldyn(min_proc)=jj_nb_caldyn(min_proc)+1
-             jj_nb_caldyn(max_proc)=jj_nb_caldyn(max_proc)-1
-	     exit
-           else
-             if (timer_average(jj_nb_caldyn(min_proc)+1,timer_caldyn,min_proc)                 &
-	        -timer_delta(jj_nb_caldyn(min_proc)+1,timer_caldyn,min_proc) < maxvalue) then
-               jj_nb_caldyn(min_proc)=jj_nb_caldyn(min_proc)+1
-               jj_nb_caldyn(max_proc)=jj_nb_caldyn(max_proc)-1
-               exit
-	     endif
-           endif
-         endif
-      enddo
-      
-      deallocate(value)
-      deallocate(index)
-      CALL create_distrib(jj_nb_caldyn,new_dist)
-        
-    end subroutine AdjustBands_caldyn
-    
-    subroutine AdjustBands_vanleer(new_dist)
-      use times
-      USE parallel_lmdz
-      implicit none
-      TYPE(distrib),INTENT(INOUT) :: new_dist
-
-      real :: minvalue,maxvalue
-      integer :: min_proc,max_proc
-      integer :: i,j
-      real,allocatable,dimension(:) :: value
-      integer,allocatable,dimension(:) :: index
-      real :: tmpvalue
-      integer :: tmpindex
-      
-      allocate(value(0:mpi_size-1))
-      allocate(index(0:mpi_size-1))
-        
-  
-      call allgather_timer_average
-
-      do i=0,mpi_size-1
-        value(i)=timer_average(jj_nb_vanleer(i),timer_vanleer,i)
-	index(i)=i
-      enddo
-      
-      do i=0,mpi_size-2
-        do j=i+1,mpi_size-1
-	  if (value(i)>value(j)) then
-	    tmpvalue=value(i)
-	    value(i)=value(j)
-	    value(j)=tmpvalue
-	    
-	    tmpindex=index(i)
-	    index(i)=index(j)
-	    index(j)=tmpindex
-	   endif
-	 enddo
-      enddo
-      
-      maxvalue=value(mpi_size-1)
-      max_proc=index(mpi_size-1)           
-           
-      do i=0,mpi_size-2
-        minvalue=value(i)
-        min_proc=index(i)
-
-        if (jj_nb_vanleer(max_proc)>2) then
-          if (timer_average(jj_nb_vanleer(min_proc)+1,timer_vanleer,min_proc)==0. .or. &
-             timer_average(jj_nb_vanleer(max_proc)-1,timer_vanleer,max_proc)==0.) then
-             jj_nb_vanleer(min_proc)=jj_nb_vanleer(min_proc)+1
-             jj_nb_vanleer(max_proc)=jj_nb_vanleer(max_proc)-1
-	     exit
-           else
-             if (timer_average(jj_nb_vanleer(min_proc)+1,timer_vanleer,min_proc) < maxvalue) then
-               jj_nb_vanleer(min_proc)=jj_nb_vanleer(min_proc)+1
-               jj_nb_vanleer(max_proc)=jj_nb_vanleer(max_proc)-1
-               exit
-	     endif
-           endif
-         endif
-      enddo
-      
-      deallocate(value)
-      deallocate(index)
- 
-      CALL create_distrib(jj_nb_vanleer,new_dist)
-         
-    end subroutine AdjustBands_vanleer
-
-    subroutine AdjustBands_dissip(new_dist)
-      use times
-      USE parallel_lmdz
-      implicit none
-      TYPE(distrib),INTENT(INOUT) :: new_dist
-      
-      real :: minvalue,maxvalue
-      integer :: min_proc,max_proc
-      integer :: i,j
-      real,allocatable,dimension(:) :: value
-      integer,allocatable,dimension(:) :: index
-      real :: tmpvalue
-      integer :: tmpindex
-      
-      allocate(value(0:mpi_size-1))
-      allocate(index(0:mpi_size-1))
-        
-  
-      call allgather_timer_average
-
-      do i=0,mpi_size-1
-        value(i)=timer_average(jj_nb_dissip(i),timer_dissip,i)
-	index(i)=i
-      enddo
-      
-      do i=0,mpi_size-2
-        do j=i+1,mpi_size-1
-	  if (value(i)>value(j)) then
-	    tmpvalue=value(i)
-	    value(i)=value(j)
-	    value(j)=tmpvalue
-	    
-	    tmpindex=index(i)
-	    index(i)=index(j)
-	    index(j)=tmpindex
-	   endif
-	 enddo
-      enddo
-      
-      maxvalue=value(mpi_size-1)
-      max_proc=index(mpi_size-1)           
-           
-      do i=0,mpi_size-2
-        minvalue=value(i)
-        min_proc=index(i)
-
-        if (jj_nb_dissip(max_proc)>3) then
-          if (timer_iteration(jj_nb_dissip(min_proc)+1,timer_dissip,min_proc)<=1) then
-             jj_nb_dissip(min_proc)=jj_nb_dissip(min_proc)+1
-             jj_nb_dissip(max_proc)=jj_nb_dissip(max_proc)-1
-	     exit
-           else
-             if (timer_average(jj_nb_dissip(min_proc)+1,timer_dissip,min_proc)         &
-	        - timer_delta(jj_nb_dissip(min_proc)+1,timer_dissip,min_proc) < maxvalue) then
-               jj_nb_dissip(min_proc)=jj_nb_dissip(min_proc)+1
-               jj_nb_dissip(max_proc)=jj_nb_dissip(max_proc)-1
-               exit
-	     endif
-           endif
-         endif
-      enddo
-      
-      deallocate(value)
-      deallocate(index)
-  
-      CALL create_distrib(jj_nb_dissip,new_dist)
-         
-    end subroutine AdjustBands_dissip
-
-    subroutine AdjustBands_physic
-      use times
-! Ehouarn: what follows is only related to // physics
-      USE mod_phys_lmdz_para, only : klon_mpi_para_nb
-
-      USE parallel_lmdz
-      USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_PHYS
-
-      implicit none
-
-      integer :: i,Index
-      real,allocatable,dimension(:) :: value
-      integer,allocatable,dimension(:) :: Inc
-      real :: medium
-      integer :: NbTot,sgn
-      
-      allocate(value(0:mpi_size-1))
-      allocate(Inc(0:mpi_size-1))
-        
-  
-      call allgather_timer_average
-      
-      medium=0
-      do i=0,mpi_size-1
-        value(i)=timer_average(jj_nb_physic(i),timer_physic,i)
-	medium=medium+value(i)
-      enddo    
-      
-      medium=medium/mpi_size      
-      NbTot=0
-IF (CPPKEY_PHYS) THEN
-      do i=0,mpi_size-1
-        Inc(i)=nint(klon_mpi_para_nb(i)*(medium-value(i))/value(i))
-        NbTot=NbTot+Inc(i)
-      enddo
-
-      if (NbTot>=0) then
-        Sgn=1
-      else
-        Sgn=-1
-	NbTot=-NbTot
-      endif
-
-      Index=0
-      do i=1,NbTot
-        Inc(Index)=Inc(Index)-Sgn
-	Index=Index+1
-	if (Index>mpi_size-1) Index=0
-      enddo
-
-      do i=0,mpi_size-1
-        distrib_phys(i)=klon_mpi_para_nb(i)+inc(i)
-      enddo
-END IF
-         
-    end subroutine AdjustBands_physic
-
-    subroutine WriteBands
-    USE parallel_lmdz
-    implicit none
-    include "dimensions.h"
-
-      integer :: i,j
-      character (len=4) :: siim,sjjm,sllm,sproc
-      character (len=255) :: filename
-      integer :: unit_number=10
-      integer :: ierr
-  
-      write(siim,'(i3)') iim
-      write(sjjm,'(i3)') jjm
-      write(sllm,'(i3)') llm
-      write(sproc,'(i3)') mpi_size
-
-      filename='Bands_'//TRIM(ADJUSTL(siim))//'x'//TRIM(ADJUSTL(sjjm))//'x'//TRIM(ADJUSTL(sllm))//'_'  &
-                        //TRIM(ADJUSTL(sproc))//'prc.dat'    
-      
-      OPEN(UNIT=unit_number,FILE=trim(filename),STATUS='replace',FORM='formatted',IOSTAT=ierr)
-      
-      if (ierr==0) then
-        
-!	write (unit_number,*) '*** Bandes caldyn ***'
-	do i=0,mpi_size-1
-          write (unit_number,*) i,jj_nb_caldyn(i)
-        enddo
-        
-!	write (unit_number,*) '*** Bandes vanleer ***' 
-        do i=0,mpi_size-1
-          write (unit_number,*) i,jj_nb_vanleer(i)
-        enddo
-       
-!        write (unit_number,*) '*** Bandes dissip ***'
-        do i=0,mpi_size-1
-          write (unit_number,*) i,jj_nb_dissip(i)
-        enddo
-        
-	do i=0,mpi_size-1
-          write (unit_number,*) i,distrib_phys(i)
-        enddo
-	
-        CLOSE(unit_number)   
-      else 
-        print *,'probleme lors de l ecriture des bandes'
-      endif
-       
-    end subroutine WriteBands
-  
-  end module Bands
-  
-  
-
Index: /LMDZ6/trunk/libf/dyn3dmem/bands.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/bands.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3dmem/bands.f90	(revision 5268)
@@ -0,0 +1,490 @@
+!
+! $Id$
+!
+  module Bands
+  USE parallel_lmdz
+    integer, parameter :: bands_caldyn=1
+    integer, parameter :: bands_vanleer=2
+    integer, parameter :: bands_dissip=3
+    
+    INTEGER,dimension(:),allocatable :: jj_Nb_Caldyn
+    INTEGER,dimension(:),allocatable :: jj_Nb_vanleer
+    INTEGER,dimension(:),allocatable :: jj_Nb_vanleer2
+    INTEGER,dimension(:),allocatable :: jj_Nb_dissip
+    INTEGER,dimension(:),allocatable :: jj_Nb_physic
+    INTEGER,dimension(:),allocatable :: jj_Nb_physic_bis
+   
+    TYPE(distrib),SAVE,TARGET :: distrib_Caldyn
+    TYPE(distrib),SAVE,TARGET :: distrib_vanleer
+    TYPE(distrib),SAVE,TARGET :: distrib_vanleer2
+    TYPE(distrib),SAVE,TARGET :: distrib_dissip
+    TYPE(distrib),SAVE,TARGET :: distrib_physic
+    TYPE(distrib),SAVE,TARGET :: distrib_physic_bis
+
+    INTEGER,dimension(:),allocatable :: distrib_phys
+  
+  contains
+  
+  subroutine AllocateBands
+    USE parallel_lmdz
+    implicit none
+    
+    allocate(jj_Nb_Caldyn(0:MPI_Size-1))
+    allocate(jj_Nb_vanleer(0:MPI_Size-1))
+    allocate(jj_Nb_vanleer2(0:MPI_Size-1))
+    allocate(jj_Nb_dissip(0:MPI_Size-1))
+    allocate(jj_Nb_physic(0:MPI_Size-1))
+    allocate(jj_Nb_physic_bis(0:MPI_Size-1))
+    allocate(distrib_phys(0:MPI_Size-1))
+  
+  end subroutine AllocateBands
+  
+  subroutine Read_distrib
+    USE parallel_lmdz
+    implicit none
+
+    include "dimensions.h"
+      integer :: i,j
+      character (len=4) :: siim,sjjm,sllm,sproc
+      character (len=255) :: filename
+      integer :: unit_number=10
+      integer :: ierr
+    
+      call AllocateBands
+      write(siim,'(i3)') iim
+      write(sjjm,'(i3)') jjm
+      write(sllm,'(i3)') llm
+      write(sproc,'(i3)') mpi_size
+      filename='Bands_'//TRIM(ADJUSTL(siim))//'x'//TRIM(ADJUSTL(sjjm))//'x'//TRIM(ADJUSTL(sllm))//'_'  &
+                        //TRIM(ADJUSTL(sproc))//'prc.dat'    
+       
+      OPEN(UNIT=unit_number,FILE=trim(filename),STATUS='old',FORM='formatted',IOSTAT=ierr)
+      
+      if (ierr==0) then
+      
+         do i=0,mpi_size-1
+          read (unit_number,*) j,jj_nb_caldyn(i)
+        enddo
+      
+        do i=0,mpi_size-1
+          read (unit_number,*) j,jj_nb_vanleer(i)
+        enddo
+      
+        do i=0,mpi_size-1
+          read (unit_number,*) j,jj_nb_dissip(i)
+        enddo
+      
+        do i=0,mpi_size-1
+          read (unit_number,*) j,distrib_phys(i)
+        enddo
+	
+	CLOSE(unit_number)  
+  
+      else
+        do i=0,mpi_size-1
+          jj_nb_caldyn(i)=(jjm+1)/mpi_size
+	  if (i<MOD(jjm+1,mpi_size)) jj_nb_caldyn(i)=jj_nb_caldyn(i)+1
+        enddo
+      
+        jj_nb_vanleer(:)=jj_nb_caldyn(:)
+        jj_nb_dissip(:)=jj_nb_caldyn(:)
+        
+	do i=0,mpi_size-1
+	  distrib_phys(i)=(iim*(jjm-1)+2)/mpi_size
+	  IF (i<MOD(iim*(jjm-1)+2,mpi_size)) distrib_phys(i)=distrib_phys(i)+1
+	enddo
+      endif
+      
+!      distrib_phys(:)=jj_nb_caldyn(:)*iim
+!      distrib_phys(0) = distrib_phys(0) - (iim-1)
+!      distrib_phys(mpi_size-1) = distrib_phys(mpi_size-1) - (iim-1)
+      
+   end subroutine Read_distrib
+   
+   
+   SUBROUTINE  Set_Bands 
+     USE parallel_lmdz
+     IMPLICIT NONE
+     INCLUDE 'dimensions.h'    
+     INTEGER :: i, ij
+     INTEGER :: jj_para_begin(0:mpi_size-1)
+     INTEGER :: jj_para_end(0:mpi_size-1)
+        
+      do i=0,mpi_size-1
+         jj_nb_vanleer2(i)=(jjm+1)/mpi_size
+	 if (i<MOD(jjm+1,mpi_size)) jj_nb_vanleer2(i)=jj_nb_vanleer2(i)+1
+      enddo
+          
+      jj_para_begin(0)=1
+      ij=distrib_phys(0)+iim-1
+      jj_para_end(0)=((ij-1)/iim)+1
+      
+      DO i=1,mpi_Size-1
+        ij=ij+1
+        jj_para_begin(i)=((ij-1)/iim)+1
+        ij=ij+distrib_phys(i)-1
+        jj_para_end(i)=((ij-1)/iim)+1
+      ENDDO
+ 
+       do i=0,MPI_Size-1
+        jj_Nb_physic(i)=jj_para_end(i)-jj_para_begin(i)+1
+        if (i/=0) then
+          if (jj_para_begin(i)==jj_para_end(i-1)) then
+            jj_Nb_physic(i-1)=jj_Nb_physic(i-1)-1
+          endif
+        endif
+      enddo
+      
+      do i=0,MPI_Size-1
+        jj_Nb_physic_bis(i)=jj_para_end(i)-jj_para_begin(i)+1
+        if (i/=0) then
+          if (jj_para_begin(i)==jj_para_end(i-1)) then
+            jj_Nb_physic_bis(i)=jj_Nb_physic_bis(i)-1
+          else
+	    jj_Nb_physic_bis(i-1)=jj_Nb_physic_bis(i-1)+1
+	    jj_Nb_physic_bis(i)=jj_Nb_physic_bis(i)-1
+	  endif
+        endif
+      enddo
+
+      CALL create_distrib(jj_Nb_Caldyn,distrib_caldyn)
+      CALL create_distrib(jj_Nb_vanleer,distrib_vanleer)
+      CALL create_distrib(jj_Nb_vanleer2,distrib_vanleer2)
+      CALL create_distrib(jj_Nb_dissip,distrib_dissip)
+      CALL create_distrib(jj_Nb_physic,distrib_physic)
+      CALL create_distrib(jj_Nb_physic_bis,distrib_physic_bis)
+      
+      distrib_physic_bis%jjb_u=distrib_physic%jjb_u
+      distrib_physic_bis%jje_u=distrib_physic%jje_u
+      distrib_physic_bis%jjnb_u=distrib_physic%jjnb_u
+
+      distrib_physic_bis%ijb_u=distrib_physic%ijb_u
+      distrib_physic_bis%ije_u=distrib_physic%ije_u
+      distrib_physic_bis%ijnb_u=distrib_physic%ijnb_u
+
+      distrib_physic_bis%jjb_v=distrib_physic%jjb_v
+      distrib_physic_bis%jje_v=distrib_physic%jje_v
+      distrib_physic_bis%jjnb_v=distrib_physic%jjnb_v
+
+      distrib_physic_bis%ijb_v=distrib_physic%ijb_v
+      distrib_physic_bis%ije_v=distrib_physic%ije_v
+      distrib_physic_bis%ijnb_v=distrib_physic%ijnb_v
+     
+    end subroutine Set_Bands
+
+
+    subroutine AdjustBands_caldyn(new_dist)
+      use times
+      USE parallel_lmdz
+      implicit none
+      TYPE(distrib),INTENT(INOUT) :: new_dist
+
+      real :: minvalue,maxvalue
+      integer :: min_proc,max_proc
+      integer :: i,j
+      real,allocatable,dimension(:) :: value
+      integer,allocatable,dimension(:) :: index
+      real :: tmpvalue
+      integer :: tmpindex
+      
+      allocate(value(0:mpi_size-1))
+      allocate(index(0:mpi_size-1))
+        
+  
+      call allgather_timer_average
+
+      do i=0,mpi_size-1
+        value(i)=timer_average(jj_nb_caldyn(i),timer_caldyn,i)
+	index(i)=i
+      enddo
+      
+      do i=0,mpi_size-2
+        do j=i+1,mpi_size-1
+	  if (value(i)>value(j)) then
+	    tmpvalue=value(i)
+	    value(i)=value(j)
+	    value(j)=tmpvalue
+	    
+	    tmpindex=index(i)
+	    index(i)=index(j)
+	    index(j)=tmpindex
+	   endif
+	 enddo
+      enddo
+      
+      maxvalue=value(mpi_size-1)
+      max_proc=index(mpi_size-1)           
+           
+      do i=0,mpi_size-2
+        minvalue=value(i)
+        min_proc=index(i)
+        if (jj_nb_caldyn(max_proc)>2) then
+          if (timer_iteration(jj_nb_caldyn(min_proc)+1,timer_caldyn,min_proc)<=1 ) then
+             jj_nb_caldyn(min_proc)=jj_nb_caldyn(min_proc)+1
+             jj_nb_caldyn(max_proc)=jj_nb_caldyn(max_proc)-1
+	     exit
+           else
+             if (timer_average(jj_nb_caldyn(min_proc)+1,timer_caldyn,min_proc)                 &
+	        -timer_delta(jj_nb_caldyn(min_proc)+1,timer_caldyn,min_proc) < maxvalue) then
+               jj_nb_caldyn(min_proc)=jj_nb_caldyn(min_proc)+1
+               jj_nb_caldyn(max_proc)=jj_nb_caldyn(max_proc)-1
+               exit
+	     endif
+           endif
+         endif
+      enddo
+      
+      deallocate(value)
+      deallocate(index)
+      CALL create_distrib(jj_nb_caldyn,new_dist)
+        
+    end subroutine AdjustBands_caldyn
+    
+    subroutine AdjustBands_vanleer(new_dist)
+      use times
+      USE parallel_lmdz
+      implicit none
+      TYPE(distrib),INTENT(INOUT) :: new_dist
+
+      real :: minvalue,maxvalue
+      integer :: min_proc,max_proc
+      integer :: i,j
+      real,allocatable,dimension(:) :: value
+      integer,allocatable,dimension(:) :: index
+      real :: tmpvalue
+      integer :: tmpindex
+      
+      allocate(value(0:mpi_size-1))
+      allocate(index(0:mpi_size-1))
+        
+  
+      call allgather_timer_average
+
+      do i=0,mpi_size-1
+        value(i)=timer_average(jj_nb_vanleer(i),timer_vanleer,i)
+	index(i)=i
+      enddo
+      
+      do i=0,mpi_size-2
+        do j=i+1,mpi_size-1
+	  if (value(i)>value(j)) then
+	    tmpvalue=value(i)
+	    value(i)=value(j)
+	    value(j)=tmpvalue
+	    
+	    tmpindex=index(i)
+	    index(i)=index(j)
+	    index(j)=tmpindex
+	   endif
+	 enddo
+      enddo
+      
+      maxvalue=value(mpi_size-1)
+      max_proc=index(mpi_size-1)           
+           
+      do i=0,mpi_size-2
+        minvalue=value(i)
+        min_proc=index(i)
+
+        if (jj_nb_vanleer(max_proc)>2) then
+          if (timer_average(jj_nb_vanleer(min_proc)+1,timer_vanleer,min_proc)==0. .or. &
+             timer_average(jj_nb_vanleer(max_proc)-1,timer_vanleer,max_proc)==0.) then
+             jj_nb_vanleer(min_proc)=jj_nb_vanleer(min_proc)+1
+             jj_nb_vanleer(max_proc)=jj_nb_vanleer(max_proc)-1
+	     exit
+           else
+             if (timer_average(jj_nb_vanleer(min_proc)+1,timer_vanleer,min_proc) < maxvalue) then
+               jj_nb_vanleer(min_proc)=jj_nb_vanleer(min_proc)+1
+               jj_nb_vanleer(max_proc)=jj_nb_vanleer(max_proc)-1
+               exit
+	     endif
+           endif
+         endif
+      enddo
+      
+      deallocate(value)
+      deallocate(index)
+ 
+      CALL create_distrib(jj_nb_vanleer,new_dist)
+         
+    end subroutine AdjustBands_vanleer
+
+    subroutine AdjustBands_dissip(new_dist)
+      use times
+      USE parallel_lmdz
+      implicit none
+      TYPE(distrib),INTENT(INOUT) :: new_dist
+      
+      real :: minvalue,maxvalue
+      integer :: min_proc,max_proc
+      integer :: i,j
+      real,allocatable,dimension(:) :: value
+      integer,allocatable,dimension(:) :: index
+      real :: tmpvalue
+      integer :: tmpindex
+      
+      allocate(value(0:mpi_size-1))
+      allocate(index(0:mpi_size-1))
+        
+  
+      call allgather_timer_average
+
+      do i=0,mpi_size-1
+        value(i)=timer_average(jj_nb_dissip(i),timer_dissip,i)
+	index(i)=i
+      enddo
+      
+      do i=0,mpi_size-2
+        do j=i+1,mpi_size-1
+	  if (value(i)>value(j)) then
+	    tmpvalue=value(i)
+	    value(i)=value(j)
+	    value(j)=tmpvalue
+	    
+	    tmpindex=index(i)
+	    index(i)=index(j)
+	    index(j)=tmpindex
+	   endif
+	 enddo
+      enddo
+      
+      maxvalue=value(mpi_size-1)
+      max_proc=index(mpi_size-1)           
+           
+      do i=0,mpi_size-2
+        minvalue=value(i)
+        min_proc=index(i)
+
+        if (jj_nb_dissip(max_proc)>3) then
+          if (timer_iteration(jj_nb_dissip(min_proc)+1,timer_dissip,min_proc)<=1) then
+             jj_nb_dissip(min_proc)=jj_nb_dissip(min_proc)+1
+             jj_nb_dissip(max_proc)=jj_nb_dissip(max_proc)-1
+	     exit
+           else
+             if (timer_average(jj_nb_dissip(min_proc)+1,timer_dissip,min_proc)         &
+	        - timer_delta(jj_nb_dissip(min_proc)+1,timer_dissip,min_proc) < maxvalue) then
+               jj_nb_dissip(min_proc)=jj_nb_dissip(min_proc)+1
+               jj_nb_dissip(max_proc)=jj_nb_dissip(max_proc)-1
+               exit
+	     endif
+           endif
+         endif
+      enddo
+      
+      deallocate(value)
+      deallocate(index)
+  
+      CALL create_distrib(jj_nb_dissip,new_dist)
+         
+    end subroutine AdjustBands_dissip
+
+    subroutine AdjustBands_physic
+      use times
+! Ehouarn: what follows is only related to // physics
+      USE mod_phys_lmdz_para, only : klon_mpi_para_nb
+
+      USE parallel_lmdz
+      USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_PHYS
+
+      implicit none
+
+      integer :: i,Index
+      real,allocatable,dimension(:) :: value
+      integer,allocatable,dimension(:) :: Inc
+      real :: medium
+      integer :: NbTot,sgn
+      
+      allocate(value(0:mpi_size-1))
+      allocate(Inc(0:mpi_size-1))
+        
+  
+      call allgather_timer_average
+      
+      medium=0
+      do i=0,mpi_size-1
+        value(i)=timer_average(jj_nb_physic(i),timer_physic,i)
+	medium=medium+value(i)
+      enddo    
+      
+      medium=medium/mpi_size      
+      NbTot=0
+IF (CPPKEY_PHYS) THEN
+      do i=0,mpi_size-1
+        Inc(i)=nint(klon_mpi_para_nb(i)*(medium-value(i))/value(i))
+        NbTot=NbTot+Inc(i)
+      enddo
+
+      if (NbTot>=0) then
+        Sgn=1
+      else
+        Sgn=-1
+	NbTot=-NbTot
+      endif
+
+      Index=0
+      do i=1,NbTot
+        Inc(Index)=Inc(Index)-Sgn
+	Index=Index+1
+	if (Index>mpi_size-1) Index=0
+      enddo
+
+      do i=0,mpi_size-1
+        distrib_phys(i)=klon_mpi_para_nb(i)+inc(i)
+      enddo
+END IF
+         
+    end subroutine AdjustBands_physic
+
+    subroutine WriteBands
+    USE parallel_lmdz
+    implicit none
+    include "dimensions.h"
+
+      integer :: i,j
+      character (len=4) :: siim,sjjm,sllm,sproc
+      character (len=255) :: filename
+      integer :: unit_number=10
+      integer :: ierr
+  
+      write(siim,'(i3)') iim
+      write(sjjm,'(i3)') jjm
+      write(sllm,'(i3)') llm
+      write(sproc,'(i3)') mpi_size
+
+      filename='Bands_'//TRIM(ADJUSTL(siim))//'x'//TRIM(ADJUSTL(sjjm))//'x'//TRIM(ADJUSTL(sllm))//'_'  &
+                        //TRIM(ADJUSTL(sproc))//'prc.dat'    
+      
+      OPEN(UNIT=unit_number,FILE=trim(filename),STATUS='replace',FORM='formatted',IOSTAT=ierr)
+      
+      if (ierr==0) then
+        
+!	write (unit_number,*) '*** Bandes caldyn ***'
+	do i=0,mpi_size-1
+          write (unit_number,*) i,jj_nb_caldyn(i)
+        enddo
+        
+!	write (unit_number,*) '*** Bandes vanleer ***' 
+        do i=0,mpi_size-1
+          write (unit_number,*) i,jj_nb_vanleer(i)
+        enddo
+       
+!        write (unit_number,*) '*** Bandes dissip ***'
+        do i=0,mpi_size-1
+          write (unit_number,*) i,jj_nb_dissip(i)
+        enddo
+        
+	do i=0,mpi_size-1
+          write (unit_number,*) i,distrib_phys(i)
+        enddo
+	
+        CLOSE(unit_number)   
+      else 
+        print *,'probleme lors de l ecriture des bandes'
+      endif
+       
+    end subroutine WriteBands
+  
+  end module Bands
+  
+  
+
Index: DZ6/trunk/libf/dyn3dmem/bilan_dyn_loc.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/bilan_dyn_loc.F90	(revision 5267)
+++ 	(revision )
@@ -1,843 +1,0 @@
-!
-! $Id: bilan_dyn_p.F 1299 2010-01-20 14:27:21Z fairhead $
-!
-SUBROUTINE bilan_dyn_loc (ntrac,dt_app,dt_cum, &
-        ps,masse,pk,flux_u,flux_v,teta,phi,ucov,vcov,trac)
-
-  !   AFAIRE
-  !   Prevoir en champ nq+1 le diagnostique de l'energie
-  !   en faisant Qzon=Cv T + L * ...
-  !             vQ..A=Cp T + L * ...
-
-  USE IOIPSL
-  USE parallel_lmdz
-  USE mod_hallo
-  use misc_mod
-  USE write_field_loc
-  USE comconst_mod, ONLY: cpp, pi
-  USE comvert_mod, ONLY: presnivs
-  USE temps_mod, ONLY: annee_ref, day_ref, itau_dyn
-
-  IMPLICIT NONE
-
-  include "dimensions.h"
-  include "paramet.h"
-  include "comgeom2.h"
-  include "iniprint.h"
-
-  !====================================================================
-  !
-  !   Sous-programme consacre � des diagnostics dynamiques de base
-  !
-  !
-  !   De facon generale, les moyennes des scalaires Q sont ponderees par
-  !   la masse.
-  !
-  !   Les flux de masse sont eux simplement moyennes.
-  !
-  !====================================================================
-
-  !   Arguments :
-  !   ===========
-
-  integer :: ntrac
-  real :: dt_app,dt_cum
-  real :: ps(iip1,jjb_u:jje_u)
-  real :: masse(iip1,jjb_u:jje_u,llm),pk(iip1,jjb_u:jje_u,llm)
-  real :: flux_u(iip1,jjb_u:jje_u,llm)
-  real :: flux_v(iip1,jjb_v:jje_v,llm)
-  real :: teta(iip1,jjb_u:jje_u,llm)
-  real :: phi(iip1,jjb_u:jje_u,llm)
-  real :: ucov(iip1,jjb_u:jje_u,llm)
-  real :: vcov(iip1,jjb_v:jje_v,llm)
-  real :: trac(iip1,jjb_u:jje_u,llm,ntrac)
-
-  !   Local :
-  !   =======
-
-  integer,SAVE :: icum,ncum
-!$OMP THREADPRIVATE(icum,ncum)
-  LOGICAL,SAVE :: first=.TRUE.
-!$OMP THREADPRIVATE(first)
-
-  real :: zz,zqy
-  REAl,SAVE,ALLOCATABLE :: zfactv(:,:)
-
-  INTEGER,PARAMETER :: nQ=7
-
-
-  !ym      character*6 nom(nQ)
-  !ym      character*6 unites(nQ)
-  character(len=6),save :: nom(nQ)
-  character(len=6),save :: unites(nQ)
-
-  character(len=10) file
-  integer :: ifile
-  parameter (ifile=4)
-
-  integer,PARAMETER :: itemp=1,igeop=2,iecin=3,iang=4,iu=5
-  INTEGER,PARAMETER :: iovap=6,iun=7
-  integer,PARAMETER :: i_sortie=1
-
-  real,SAVE :: time=0.
-  integer,SAVE :: itau=0.
-!$OMP THREADPRIVATE(time,itau)
-
-  real :: ww
-
-  !   variables dynamiques interm�diaires
-  REAL,SAVE,ALLOCATABLE :: vcont(:,:,:),ucont(:,:,:)
-  REAL,SAVE,ALLOCATABLE :: ang(:,:,:),unat(:,:,:)
-  REAL,SAVE,ALLOCATABLE :: massebx(:,:,:),masseby(:,:,:)
-  REAL,SAVE,ALLOCATABLE :: vorpot(:,:,:)
-  REAL,SAVE,ALLOCATABLE :: w(:,:,:),ecin(:,:,:),convm(:,:,:)
-  REAL,SAVE,ALLOCATABLE :: bern(:,:,:)
-
-  !   champ contenant les scalaires advect�s.
-  real,SAVE,ALLOCATABLE :: Q(:,:,:,:)
-
-  !   champs cumul�s
-  real,SAVE,ALLOCATABLE ::  ps_cum(:,:)
-  real,SAVE,ALLOCATABLE ::  masse_cum(:,:,:)
-  real,SAVE,ALLOCATABLE ::  flux_u_cum(:,:,:)
-  real,SAVE,ALLOCATABLE ::  flux_v_cum(:,:,:)
-  real,SAVE,ALLOCATABLE ::  Q_cum(:,:,:,:)
-  real,SAVE,ALLOCATABLE ::  flux_uQ_cum(:,:,:,:)
-  real,SAVE,ALLOCATABLE ::  flux_vQ_cum(:,:,:,:)
-  real,SAVE,ALLOCATABLE ::  flux_wQ_cum(:,:,:,:)
-  real,SAVE,ALLOCATABLE ::  dQ(:,:,:,:)
-
-
-  !   champs de tansport en moyenne zonale
-  integer :: ntr,itr
-  parameter (ntr=5)
-
-  !ym      character*10 znom(ntr,nQ)
-  !ym      character*20 znoml(ntr,nQ)
-  !ym      character*10 zunites(ntr,nQ)
-  character*10,save :: znom(ntr,nQ)
-  character*20,save :: znoml(ntr,nQ)
-  character*10,save :: zunites(ntr,nQ)
-
-  INTEGER,PARAMETER :: iave=1,itot=2,immc=3,itrs=4,istn=5
-
-  character(len=3) :: ctrs(ntr)
-  data ctrs/'  ','TOT','MMC','TRS','STN'/
-
-  real,SAVE,ALLOCATABLE ::  zvQ(:,:,:,:),zvQtmp(:,:)
-  real,SAVE,ALLOCATABLE ::  zavQ(:,:,:),psiQ(:,:,:)
-  real,SAVE,ALLOCATABLE ::  zmasse(:,:),zamasse(:)
-
-  real,SAVE,ALLOCATABLE ::  zv(:,:),psi(:,:)
-
-  integer :: i,j,l,iQ
-
-
-  !   Initialisation du fichier contenant les moyennes zonales.
-  !   ---------------------------------------------------------
-
-  character(len=10) :: infile
-
-  integer, save :: fileid
-  integer :: thoriid, zvertiid
-
-  INTEGER,SAVE,ALLOCATABLE :: ndex3d(:)
-
-  !   Variables locales
-  !
-  integer :: tau0
-  real :: zjulian
-  character(len=3) :: str
-  character(len=10) :: ctrac
-  integer :: ii,jj
-  integer :: zan, dayref
-  !
-  real,SAVE,ALLOCATABLE :: rlong(:),rlatg(:)
-  integer :: jjb,jje,jjn,ijb,ije
-  type(Request),SAVE :: Req
-!$OMP THREADPRIVATE(Req)
-
-  ! definition du domaine d'ecriture pour le rebuild
-
-  INTEGER,DIMENSION(1) :: ddid
-  INTEGER,DIMENSION(1) :: dsg
-  INTEGER,DIMENSION(1) :: dsl
-  INTEGER,DIMENSION(1) :: dpf
-  INTEGER,DIMENSION(1) :: dpl
-  INTEGER,DIMENSION(1) :: dhs
-  INTEGER,DIMENSION(1) :: dhe
-
-  INTEGER :: bilan_dyn_domain_id
-
-  !=====================================================================
-  !   Initialisation
-  !=====================================================================
-  if (adjust) return
-
-  time=time+dt_app
-  itau=itau+1
-
-  if (first) then
-!$OMP BARRIER
-!$OMP MASTER
-  ALLOCATE(zfactv(jjb_v:jje_v,llm))
-  ALLOCATE(vcont(iip1,jjb_v:jje_v,llm))
-  ALLOCATE(ucont(iip1,jjb_u:jje_u,llm))
-  ALLOCATE(ang(iip1,jjb_u:jje_u,llm))
-  ALLOCATE(unat(iip1,jjb_u:jje_u,llm))
-  ALLOCATE(massebx(iip1,jjb_u:jje_u,llm))
-  ALLOCATE(masseby(iip1,jjb_v:jje_v,llm))
-  ALLOCATE(vorpot(iip1,jjb_v:jje_v,llm))
-  ALLOCATE(w(iip1,jjb_u:jje_u,llm))
-  ALLOCATE(ecin(iip1,jjb_u:jje_u,llm))
-  ALLOCATE(convm(iip1,jjb_u:jje_u,llm))
-  ALLOCATE(bern(iip1,jjb_u:jje_u,llm))
-  ALLOCATE(Q(iip1,jjb_u:jje_u,llm,nQ))
-  ALLOCATE(ps_cum(iip1,jjb_u:jje_u))
-  ALLOCATE(masse_cum(iip1,jjb_u:jje_u,llm))
-  ALLOCATE(flux_u_cum(iip1,jjb_u:jje_u,llm))
-  ALLOCATE(flux_v_cum(iip1,jjb_v:jje_v,llm))
-  ALLOCATE(Q_cum(iip1,jjb_u:jje_u,llm,nQ))
-  ALLOCATE(flux_uQ_cum(iip1,jjb_u:jje_u,llm,nQ))
-  ALLOCATE(flux_vQ_cum(iip1,jjb_v:jje_v,llm,nQ))
-  ALLOCATE(flux_wQ_cum(iip1,jjb_u:jje_u,llm,nQ))
-  ALLOCATE(dQ(iip1,jjb_u:jje_u,llm,nQ))
-  ALLOCATE(zvQ(jjb_v:jje_v,llm,ntr,nQ))
-  ALLOCATE(zvQtmp(jjb_v:jje_v,llm))
-  ALLOCATE(zavQ(jjb_v:jje_v,ntr,nQ))
-  ALLOCATE(psiQ(jjb_v:jje_v,llm+1,nQ))
-  ALLOCATE(zmasse(jjb_v:jje_v,llm))
-  ALLOCATE(zamasse(jjb_v:jje_v))
-  ALLOCATE(zv(jjb_v:jje_v,llm))
-  ALLOCATE(psi(jjb_v:jje_v,llm+1))
-  ALLOCATE(ndex3d(jjb_v:jje_v*llm))
-  ndex3d=0
-  ALLOCATE(rlong(1))
-  ALLOCATE(rlatg(jjm))
-
-!$OMP END MASTER
-!$OMP BARRIER
-    icum=0
-    ! initialisation des fichiers
-    first=.false.
-  !   ncum est la frequence de stokage en pas de temps
-    ncum=dt_cum/dt_app
-    if (abs(ncum*dt_app-dt_cum).gt.1.e-5*dt_app) then
-       WRITE(lunout,*) &
-             'Pb : le pas de cumule doit etre multiple du pas'
-       WRITE(lunout,*)'dt_app=',dt_app
-       WRITE(lunout,*)'dt_cum=',dt_cum
-       CALL abort_gcm("conf_gcmbilan_dyn_loc","stopped",1)
-    endif
-
-!$OMP MASTER
-    nom(itemp)='T'
-    nom(igeop)='gz'
-    nom(iecin)='K'
-    nom(iang)='ang'
-    nom(iu)='u'
-    nom(iovap)='ovap'
-    nom(iun)='un'
-
-    unites(itemp)='K'
-    unites(igeop)='m2/s2'
-    unites(iecin)='m2/s2'
-    unites(iang)='ang'
-    unites(iu)='m/s'
-    unites(iovap)='kg/kg'
-    unites(iun)='un'
-
-
-  !   Initialisation du fichier contenant les moyennes zonales.
-  !   ---------------------------------------------------------
-
-  infile='dynzon'
-
-  zan = annee_ref
-  dayref = day_ref
-  CALL ymds2ju(zan, 1, dayref, 0.0, zjulian)
-  tau0 = itau_dyn
-
-  rlong=0.
-  rlatg=rlatv*180./pi
-
-  jjb=jj_begin
-  jje=jj_end
-  jjn=jj_nb
-  IF (pole_sud) THEN
-    jjn=jj_nb-1
-    jje=jj_end-1
-  ENDIF
-
-  ddid=(/ 2 /)
-  dsg=(/ jjm /)
-  dsl=(/ jjn /)
-  dpf=(/ jjb /)
-  dpl=(/ jje /)
-  dhs=(/ 0 /)
-  dhe=(/ 0 /)
-
-  call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, &
-        'box',bilan_dyn_domain_id)
-
-  call histbeg(trim(infile), &
-        1, rlong, jjn, rlatg(jjb:jje), &
-        1, 1, 1, jjn, &
-        tau0, zjulian, dt_cum, thoriid, fileid, &
-        bilan_dyn_domain_id)
-
-  !
-  !  Appel a histvert pour la grille verticale
-  !
-  call histvert(fileid, 'presnivs', 'Niveaux sigma','mb', &
-        llm, presnivs, zvertiid)
-  !
-  !  Appels a histdef pour la definition des variables a sauvegarder
-  do iQ=1,nQ
-     do itr=1,ntr
-        if(itr.eq.1) then
-           znom(itr,iQ)=nom(iQ)
-           znoml(itr,iQ)=nom(iQ)
-           zunites(itr,iQ)=unites(iQ)
-        else
-           znom(itr,iQ)=ctrs(itr)//'v'//nom(iQ)
-           znoml(itr,iQ)='transport : v * '//nom(iQ)//' '//ctrs(itr)
-           zunites(itr,iQ)='m/s * '//unites(iQ)
-        endif
-     enddo
-  enddo
-
-  !   Declarations des champs avec dimension verticale
-   ! print*,'1HISTDEF'
-  do iQ=1,nQ
-     do itr=1,ntr
-  IF (prt_level > 5) &
-        WRITE(lunout,*)'var ',itr,iQ &
-        ,znom(itr,iQ),znoml(itr,iQ),zunites(itr,iQ)
-        call histdef(fileid,znom(itr,iQ),znoml(itr,iQ), &
-              zunites(itr,iQ),1,jjn,thoriid,llm,1,llm,zvertiid, &
-              32,'ave(X)',dt_cum,dt_cum)
-     enddo
-  !   Declarations pour les fonctions de courant
-   ! print*,'2HISTDEF'
-      call histdef(fileid,'psi'//nom(iQ) &
-            ,'stream fn. '//znoml(itot,iQ), &
-            zunites(itot,iQ),1,jjn,thoriid,llm,1,llm,zvertiid, &
-            32,'ave(X)',dt_cum,dt_cum)
-  enddo
-
-
-  !   Declarations pour les champs de transport d'air
-   ! print*,'3HISTDEF'
-  call histdef(fileid, 'masse', 'masse', &
-        'kg', 1, jjn, thoriid, llm, 1, llm, zvertiid, &
-        32, 'ave(X)', dt_cum, dt_cum)
-  call histdef(fileid, 'v', 'v', &
-        'm/s', 1, jjn, thoriid, llm, 1, llm, zvertiid, &
-        32, 'ave(X)', dt_cum, dt_cum)
-  !   Declarations pour les fonctions de courant
-   ! print*,'4HISTDEF'
-      call histdef(fileid,'psi','stream fn. MMC ','mega t/s', &
-            1,jjn,thoriid,llm,1,llm,zvertiid, &
-            32,'ave(X)',dt_cum,dt_cum)
-
-
-  !   Declaration des champs 1D de transport en latitude
-   ! print*,'5HISTDEF'
-  do iQ=1,nQ
-     do itr=2,ntr
-        call histdef(fileid,'a'//znom(itr,iQ),znoml(itr,iQ), &
-              zunites(itr,iQ),1,jjn,thoriid,1,1,1,-99, &
-              32,'ave(X)',dt_cum,dt_cum)
-     enddo
-  enddo
-
-
-   ! print*,'8HISTDEF'
-           CALL histend(fileid)
-
-!$OMP END MASTER
-  endif
-
-
-  !=====================================================================
-  !   Calcul des champs dynamiques
-  !   ----------------------------
-
-  jjb=jj_begin
-  jje=jj_end
-
-  !   �nergie cin�tique
-   ! ucont(:,jjb:jje,:)=0
-
-  call Register_Hallo_u(ucov,llm,1,1,1,1,Req)
-  call Register_Hallo_v(vcov,llm,1,1,1,1,Req)
-  call SendRequest(Req)
-!$OMP BARRIER
-  call WaitRequest(Req)
-
-  CALL covcont_loc(llm,ucov,vcov,ucont,vcont)
-  CALL enercin_loc(vcov,ucov,vcont,ucont,ecin)
-
-  !   moment cin�tique
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-  do l=1,llm
-     ang(:,jjb:jje,l)=ucov(:,jjb:jje,l)+constang(:,jjb:jje)
-     unat(:,jjb:jje,l)=ucont(:,jjb:jje,l)*cu(:,jjb:jje)
-  enddo
-!$OMP END DO NOWAIT
-
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-  DO l=1,llm
-    Q(:,jjb:jje,l,itemp)=teta(:,jjb:jje,l)*pk(:,jjb:jje,l)/cpp
-    Q(:,jjb:jje,l,igeop)=phi(:,jjb:jje,l)
-    Q(:,jjb:jje,l,iecin)=ecin(:,jjb:jje,l)
-    Q(:,jjb:jje,l,iang)=ang(:,jjb:jje,l)
-    Q(:,jjb:jje,l,iu)=unat(:,jjb:jje,l)
-    Q(:,jjb:jje,l,iovap)=trac(:,jjb:jje,l,1)
-    Q(:,jjb:jje,l,iun)=1.
-  ENDDO
-!$OMP END DO NOWAIT
-
-  !=====================================================================
-  !   Cumul
-  !=====================================================================
-  !
-  if(icum.EQ.0) then
-     jjb=jj_begin
-     jje=jj_end
-
-!$OMP MASTER
-     ps_cum(:,jjb:jje)=0.
-!$OMP END MASTER
-
-
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-    DO l=1,llm
-      masse_cum(:,jjb:jje,l)=0.
-      flux_u_cum(:,jjb:jje,l)=0.
-      Q_cum(:,jjb:jje,l,:)=0.
-      flux_uQ_cum(:,jjb:jje,l,:)=0.
-      if (pole_sud) jje=jj_end-1
-      flux_v_cum(:,jjb:jje,l)=0.
-      flux_vQ_cum(:,jjb:jje,l,:)=0.
-    ENDDO
-!$OMP END DO NOWAIT
-  endif
-
-  IF (prt_level > 5) &
-        WRITE(lunout,*)'dans bilan_dyn ',icum,'->',icum+1
-  icum=icum+1
-
-  !   accumulation des flux de masse horizontaux
-  jjb=jj_begin
-  jje=jj_end
-
-!$OMP MASTER
-  ps_cum(:,jjb:jje)=ps_cum(:,jjb:jje)+ps(:,jjb:jje)
-!$OMP END MASTER
-
-
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-  DO l=1,llm
-    masse_cum(:,jjb:jje,l)=masse_cum(:,jjb:jje,l)+masse(:,jjb:jje,l)
-    flux_u_cum(:,jjb:jje,l)=flux_u_cum(:,jjb:jje,l) &
-          +flux_u(:,jjb:jje,l)
-  ENDDO
-!$OMP END DO NOWAIT
-
-  if (pole_sud) jje=jj_end-1
-
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-  DO l=1,llm
-   flux_v_cum(:,jjb:jje,l)=flux_v_cum(:,jjb:jje,l) &
-         +flux_v(:,jjb:jje,l)
-  ENDDO
-!$OMP END DO NOWAIT
-
-  jjb=jj_begin
-  jje=jj_end
-
-  do iQ=1,nQ
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-    DO l=1,llm
-      Q_cum(:,jjb:jje,l,iQ)=Q_cum(:,jjb:jje,l,iQ) &
-            +Q(:,jjb:jje,l,iQ)*masse(:,jjb:jje,l)
-    ENDDO
-!$OMP END DO NOWAIT
-  enddo
-
-  !=====================================================================
-  !  FLUX ET TENDANCES
-  !=====================================================================
-
-  !   Flux longitudinal
-  !   -----------------
-  do iQ=1,nQ
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-     do l=1,llm
-        do j=jjb,jje
-           do i=1,iim
-              flux_uQ_cum(i,j,l,iQ)=flux_uQ_cum(i,j,l,iQ) &
-                    +flux_u(i,j,l)*0.5*(Q(i,j,l,iQ)+Q(i+1,j,l,iQ))
-           enddo
-           flux_uQ_cum(iip1,j,l,iQ)=flux_uQ_cum(1,j,l,iQ)
-        enddo
-     enddo
-!$OMP END DO NOWAIT
-  enddo
-
-  !    flux m�ridien
-  !    -------------
-  do iQ=1,nQ
-    call Register_Hallo_u(Q(1,jjb_u,1,iQ),llm,0,1,1,0,Req)
-  enddo
-  call SendRequest(Req)
-!$OMP BARRIER
-  call WaitRequest(Req)
-
-  jjb=jj_begin
-  jje=jj_end
-  if (pole_sud) jje=jj_end-1
-
-  do iQ=1,nQ
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-     do l=1,llm
-        do j=jjb,jje
-           do i=1,iip1
-              flux_vQ_cum(i,j,l,iQ)=flux_vQ_cum(i,j,l,iQ) &
-                    +flux_v(i,j,l)*0.5*(Q(i,j,l,iQ)+Q(i,j+1,l,iQ))
-           enddo
-        enddo
-     enddo
-!$OMP ENDDO NOWAIT
-!$OMP BARRIER
-  enddo
-
-  !    tendances
-  !    ---------
-
-  !   convergence horizontale
-  call Register_Hallo_u(flux_uQ_cum,llm,2,2,2,2,Req)
-  call Register_Hallo_v(flux_vQ_cum,llm,2,2,2,2,Req)
-  call SendRequest(Req)
-!$OMP BARRIER
-  call WaitRequest(Req)
-
-  call  convflu_loc(flux_uQ_cum,flux_vQ_cum,llm*nQ,dQ)
-
-  !   calcul de la vitesse verticale
-  call Register_Hallo_u(flux_u_cum,llm,2,2,2,2,Req)
-  call Register_Hallo_v(flux_v_cum,llm,2,2,2,2,Req)
-  call SendRequest(Req)
-!$OMP BARRIER
-  call WaitRequest(Req)
-
-  call convmas_loc(flux_u_cum,flux_v_cum,convm)
-  CALL vitvert_loc(convm,w)
-!$OMP BARRIER
-
-
-  jjb=jj_begin
-  jje=jj_end
-
-   ! do iQ=1,nQ
-   !    do l=1,llm-1
-   !       do j=jjb,jje
-   !          do i=1,iip1
-   !             ww=-0.5*w(i,j,l+1)*(Q(i,j,l,iQ)+Q(i,j,l+1,iQ))
-   !             dQ(i,j,l  ,iQ)=dQ(i,j,l  ,iQ)-ww
-   !             dQ(i,j,l+1,iQ)=dQ(i,j,l+1,iQ)+ww
-   !          enddo
-   !       enddo
-   !     enddo
-   !  enddo
-
-  do iQ=1,nQ
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-     do l=1,llm
-        IF (l<llm) THEN
-          do j=jjb,jje
-             do i=1,iip1
-                ww=-0.5*w(i,j,l+1)*(Q(i,j,l,iQ)+Q(i,j,l+1,iQ))
-                dQ(i,j,l  ,iQ)=dQ(i,j,l  ,iQ)-ww
-                dQ(i,j,l+1,iQ)=dQ(i,j,l+1,iQ)+ww
-             enddo
-          enddo
-        ENDIF
-        IF (l>2) THEN
-          do j=jjb,jje
-            do i=1,iip1
-              ww=-0.5*w(i,j,l)*(Q(i,j,l-1,iQ)+Q(i,j,l,iQ))
-              dQ(i,j,l,iQ)=dQ(i,j,l,iQ)+ww
-            enddo
-          enddo
-        ENDIF
-     enddo
-!$OMP ENDDO NOWAIT
-  enddo
-  IF (prt_level > 5) &
-        WRITE(lunout,*)'Apres les calculs fait a chaque pas'
-  !=====================================================================
-  !   PAS DE TEMPS D'ECRITURE
-  !=====================================================================
-  if (icum.eq.ncum) then
-  !=====================================================================
-
-  IF (prt_level > 5) &
-        WRITE(lunout,*)'Pas d ecriture'
-
-  jjb=jj_begin
-  jje=jj_end
-
-  !   Normalisation
-  do iQ=1,nQ
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-    do l=1,llm
-      Q_cum(:,jjb:jje,l,iQ)=Q_cum(:,jjb:jje,l,iQ) &
-            /masse_cum(:,jjb:jje,l)
-    enddo
-!$OMP ENDDO NOWAIT
-  enddo
-
-  zz=1./REAL(ncum)
-
-!$OMP MASTER
-    ps_cum(:,jjb:jje)=ps_cum(:,jjb:jje)*zz
-!$OMP END MASTER
-
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-  DO l=1,llm
-    masse_cum(:,jjb:jje,l)=masse_cum(:,jjb:jje,l)*zz
-    flux_u_cum(:,jjb:jje,l)=flux_u_cum(:,jjb:jje,l)*zz
-    flux_uQ_cum(:,jjb:jje,l,:)=flux_uQ_cum(:,jjb:jje,l,:)*zz
-    dQ(:,jjb:jje,l,:)=dQ(:,jjb:jje,l,:)*zz
-  ENDDO
-!$OMP ENDDO NOWAIT
-
-  IF (pole_sud) jje=jj_end-1
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-  DO l=1,llm
-    flux_v_cum(:,jjb:jje,l)=flux_v_cum(:,jjb:jje,l)*zz
-    flux_vQ_cum(:,jjb:jje,l,:)=flux_vQ_cum(:,jjb:jje,l,:)*zz
-  ENDDO
-!$OMP ENDDO NOWAIT
-!$OMP BARRIER
-
-  jjb=jj_begin
-  jje=jj_end
-
-
-  !   A retravailler eventuellement
-  !   division de dQ par la masse pour revenir aux bonnes grandeurs
-  do iQ=1,nQ
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-    DO l=1,llm
-       dQ(:,jjb:jje,l,iQ)=dQ(:,jjb:jje,l,iQ)/masse_cum(:,jjb:jje,l)
-    ENDDO
-!$OMP ENDDO NOWAIT
-  enddo
-
-  !=====================================================================
-  !   Transport m�ridien
-  !=====================================================================
-
-  !   cumul zonal des masses des mailles
-  !   ----------------------------------
-  jjb=jj_begin
-  jje=jj_end
-  if (pole_sud) jje=jj_end-1
-
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-    DO l=1,llm
-      zv(jjb:jje,l)=0.
-      zmasse(jjb:jje,l)=0.
-    ENDDO
-!$OMP ENDDO NOWAIT
-!$OMP BARRIER
-
-  call Register_Hallo_u(masse_cum,llm,1,1,1,1,Req)
-  do iQ=1,nQ
-    call Register_Hallo_u(Q_cum(1,jjb_u,1,iQ),llm,0,1,1,0,Req)
-  enddo
-
-  call SendRequest(Req)
-!$OMP BARRIER
-  call WaitRequest(Req)
-
-  call massbar_loc(masse_cum,massebx,masseby)
-
-  jjb=jj_begin
-  jje=jj_end
-  if (pole_sud) jje=jj_end-1
-
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-  do l=1,llm
-     do j=jjb,jje
-        do i=1,iim
-           zmasse(j,l)=zmasse(j,l)+masseby(i,j,l)
-           zv(j,l)=zv(j,l)+flux_v_cum(i,j,l)
-        enddo
-        zfactv(j,l)=cv(1,j)/zmasse(j,l)
-     enddo
-  enddo
-!$OMP ENDDO NOWAIT
-!$OMP BARRIER
-
-  ! print*,'3OK'
-  !   --------------------------------------------------------------
-  !   calcul de la moyenne zonale du transport :
-  !   ------------------------------------------
-  !
-  !                                 --
-  ! TOT : la circulation totale       [ vq ]
-  !
-  !                                  -     -
-  ! MMC : mean meridional circulation [ v ] [ q ]
-  !
-  !                                 ----      --       - -
-  ! TRS : transitoires                [ v'q'] = [ vq ] - [ v q ]
-  !
-  !                                 - * - *       - -       -     -
-  ! STT : stationaires                [ v   q   ] = [ v q ] - [ v ] [ q ]
-  !
-  !                                          - -
-  !    on utilise aussi l'intermediaire TMP :  [ v q ]
-  !
-  !    la variable zfactv transforme un transport meridien cumule
-  !    en kg/s * unte-du-champ-transporte en m/s * unite-du-champ-transporte
-  !
-  !   --------------------------------------------------------------
-
-
-  !   ----------------------------------------
-  !   Transport dans le plan latitude-altitude
-  !   ----------------------------------------
-
-  jjb=jj_begin
-  jje=jj_end
-  if (pole_sud) jje=jj_end-1
-
-  zvQ=0.
-  psiQ=0.
-  do iQ=1,nQ
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-     do l=1,llm
-        zvQtmp(:,l)=0.
-        do j=jjb,jje
-           ! print*,'j,l,iQ=',j,l,iQ
-  !   Calcul des moyennes zonales du transort total et de zvQtmp
-           do i=1,iim
-              zvQ(j,l,itot,iQ)=zvQ(j,l,itot,iQ) &
-                    +flux_vQ_cum(i,j,l,iQ)
-              zqy=      0.5*(Q_cum(i,j,l,iQ)*masse_cum(i,j,l)+ &
-                    Q_cum(i,j+1,l,iQ)*masse_cum(i,j+1,l))
-              zvQtmp(j,l)=zvQtmp(j,l)+flux_v_cum(i,j,l)*zqy &
-                    /(0.5*(masse_cum(i,j,l)+masse_cum(i,j+1,l)))
-              zvQ(j,l,iave,iQ)=zvQ(j,l,iave,iQ)+zqy
-           enddo
-           ! print*,'aOK'
-  !   Decomposition
-           zvQ(j,l,iave,iQ)=zvQ(j,l,iave,iQ)/zmasse(j,l)
-           zvQ(j,l,itot,iQ)=zvQ(j,l,itot,iQ)*zfactv(j,l)
-           zvQtmp(j,l)=zvQtmp(j,l)*zfactv(j,l)
-           zvQ(j,l,immc,iQ)=zv(j,l)*zvQ(j,l,iave,iQ)*zfactv(j,l)
-           zvQ(j,l,itrs,iQ)=zvQ(j,l,itot,iQ)-zvQtmp(j,l)
-           zvQ(j,l,istn,iQ)=zvQtmp(j,l)-zvQ(j,l,immc,iQ)
-        enddo
-     enddo
-!$OMP ENDDO NOWAIT
-  !   fonction de courant meridienne pour la quantite Q
-!$OMP BARRIER
-!$OMP MASTER
-     do l=llm,1,-1
-        do j=jjb,jje
-           psiQ(j,l,iQ)=psiQ(j,l+1,iQ)+zvQ(j,l,itot,iQ)
-        enddo
-     enddo
-!$OMP END MASTER
-!$OMP BARRIER
-  enddo
-
-  !   fonction de courant pour la circulation meridienne moyenne
-!$OMP BARRIER
-!$OMP MASTER
-  psi(jjb:jje,:)=0.
-  do l=llm,1,-1
-     do j=jjb,jje
-        psi(j,l)=psi(j,l+1)+zv(j,l)
-        zv(j,l)=zv(j,l)*zfactv(j,l)
-     enddo
-  enddo
-!$OMP END MASTER
-!$OMP BARRIER
-
-  ! print*,'4OK'
-  !   sorties proprement dites
-!$OMP MASTER
-  if (i_sortie.eq.1) then
-  jjb=jj_begin
-  jje=jj_end
-  jjn=jj_nb
-  if (pole_sud) jje=jj_end-1
-  if (pole_sud) jjn=jj_nb-1
-  do iQ=1,nQ
-     do itr=1,ntr
-        call histwrite(fileid,znom(itr,iQ),itau, &
-              zvQ(jjb:jje,:,itr,iQ) &
-              ,jjn*llm,ndex3d)
-     enddo
-     call histwrite(fileid,'psi'//nom(iQ), &
-           itau,psiQ(jjb:jje,1:llm,iQ) &
-           ,jjn*llm,ndex3d)
-  enddo
-
-  call histwrite(fileid,'masse',itau,zmasse(jjb:jje,1:llm) &
-        ,jjn*llm,ndex3d)
-  call histwrite(fileid,'v',itau,zv(jjb:jje,1:llm) &
-        ,jjn*llm,ndex3d)
-  psi(jjb:jje,:)=psi(jjb:jje,:)*1.e-9
-  call histwrite(fileid,'psi',itau,psi(jjb:jje,1:llm), &
-        jjn*llm,ndex3d)
-
-  endif
-
-
-  !   -----------------
-  !   Moyenne verticale
-  !   -----------------
-
-  zamasse(jjb:jje)=0.
-  do l=1,llm
-     zamasse(jjb:jje)=zamasse(jjb:jje)+zmasse(jjb:jje,l)
-  enddo
-
-  zavQ(jjb:jje,:,:)=0.
-  do iQ=1,nQ
-     do itr=2,ntr
-        do l=1,llm
-           zavQ(jjb:jje,itr,iQ)=zavQ(jjb:jje,itr,iQ) &
-                 +zvQ(jjb:jje,l,itr,iQ) &
-                 *zmasse(jjb:jje,l)
-        enddo
-        zavQ(jjb:jje,itr,iQ)=zavQ(jjb:jje,itr,iQ)/zamasse(jjb:jje)
-        call histwrite(fileid,'a'//znom(itr,iQ),itau, &
-              zavQ(jjb:jje,itr,iQ),jjn*llm,ndex3d)
-     enddo
-  enddo
-!$OMP END MASTER
-  ! on doit pouvoir tracer systematiquement la fonction de courant.
-
-  !=====================================================================
-  !/////////////////////////////////////////////////////////////////////
-  icum=0                  !///////////////////////////////////////
-  endif ! icum.eq.ncum    !///////////////////////////////////////
-  !/////////////////////////////////////////////////////////////////////
-  !=====================================================================
-!$OMP MASTER
-  call histsync(fileid)
-!$OMP END MASTER
-
-
-  return
-end subroutine bilan_dyn_loc
Index: /LMDZ6/trunk/libf/dyn3dmem/bilan_dyn_loc.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/bilan_dyn_loc.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3dmem/bilan_dyn_loc.f90	(revision 5268)
@@ -0,0 +1,843 @@
+!
+! $Id: bilan_dyn_p.F 1299 2010-01-20 14:27:21Z fairhead $
+!
+SUBROUTINE bilan_dyn_loc (ntrac,dt_app,dt_cum, &
+        ps,masse,pk,flux_u,flux_v,teta,phi,ucov,vcov,trac)
+
+  !   AFAIRE
+  !   Prevoir en champ nq+1 le diagnostique de l'energie
+  !   en faisant Qzon=Cv T + L * ...
+  !             vQ..A=Cp T + L * ...
+
+  USE IOIPSL
+  USE parallel_lmdz
+  USE mod_hallo
+  use misc_mod
+  USE write_field_loc
+  USE comconst_mod, ONLY: cpp, pi
+  USE comvert_mod, ONLY: presnivs
+  USE temps_mod, ONLY: annee_ref, day_ref, itau_dyn
+
+  IMPLICIT NONE
+
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom2.h"
+  include "iniprint.h"
+
+  !====================================================================
+  !
+  !   Sous-programme consacre � des diagnostics dynamiques de base
+  !
+  !
+  !   De facon generale, les moyennes des scalaires Q sont ponderees par
+  !   la masse.
+  !
+  !   Les flux de masse sont eux simplement moyennes.
+  !
+  !====================================================================
+
+  !   Arguments :
+  !   ===========
+
+  integer :: ntrac
+  real :: dt_app,dt_cum
+  real :: ps(iip1,jjb_u:jje_u)
+  real :: masse(iip1,jjb_u:jje_u,llm),pk(iip1,jjb_u:jje_u,llm)
+  real :: flux_u(iip1,jjb_u:jje_u,llm)
+  real :: flux_v(iip1,jjb_v:jje_v,llm)
+  real :: teta(iip1,jjb_u:jje_u,llm)
+  real :: phi(iip1,jjb_u:jje_u,llm)
+  real :: ucov(iip1,jjb_u:jje_u,llm)
+  real :: vcov(iip1,jjb_v:jje_v,llm)
+  real :: trac(iip1,jjb_u:jje_u,llm,ntrac)
+
+  !   Local :
+  !   =======
+
+  integer,SAVE :: icum,ncum
+!$OMP THREADPRIVATE(icum,ncum)
+  LOGICAL,SAVE :: first=.TRUE.
+!$OMP THREADPRIVATE(first)
+
+  real :: zz,zqy
+  REAl,SAVE,ALLOCATABLE :: zfactv(:,:)
+
+  INTEGER,PARAMETER :: nQ=7
+
+
+  !ym      character*6 nom(nQ)
+  !ym      character*6 unites(nQ)
+  character(len=6),save :: nom(nQ)
+  character(len=6),save :: unites(nQ)
+
+  character(len=10) file
+  integer :: ifile
+  parameter (ifile=4)
+
+  integer,PARAMETER :: itemp=1,igeop=2,iecin=3,iang=4,iu=5
+  INTEGER,PARAMETER :: iovap=6,iun=7
+  integer,PARAMETER :: i_sortie=1
+
+  real,SAVE :: time=0.
+  integer,SAVE :: itau=0.
+!$OMP THREADPRIVATE(time,itau)
+
+  real :: ww
+
+  !   variables dynamiques interm�diaires
+  REAL,SAVE,ALLOCATABLE :: vcont(:,:,:),ucont(:,:,:)
+  REAL,SAVE,ALLOCATABLE :: ang(:,:,:),unat(:,:,:)
+  REAL,SAVE,ALLOCATABLE :: massebx(:,:,:),masseby(:,:,:)
+  REAL,SAVE,ALLOCATABLE :: vorpot(:,:,:)
+  REAL,SAVE,ALLOCATABLE :: w(:,:,:),ecin(:,:,:),convm(:,:,:)
+  REAL,SAVE,ALLOCATABLE :: bern(:,:,:)
+
+  !   champ contenant les scalaires advect�s.
+  real,SAVE,ALLOCATABLE :: Q(:,:,:,:)
+
+  !   champs cumul�s
+  real,SAVE,ALLOCATABLE ::  ps_cum(:,:)
+  real,SAVE,ALLOCATABLE ::  masse_cum(:,:,:)
+  real,SAVE,ALLOCATABLE ::  flux_u_cum(:,:,:)
+  real,SAVE,ALLOCATABLE ::  flux_v_cum(:,:,:)
+  real,SAVE,ALLOCATABLE ::  Q_cum(:,:,:,:)
+  real,SAVE,ALLOCATABLE ::  flux_uQ_cum(:,:,:,:)
+  real,SAVE,ALLOCATABLE ::  flux_vQ_cum(:,:,:,:)
+  real,SAVE,ALLOCATABLE ::  flux_wQ_cum(:,:,:,:)
+  real,SAVE,ALLOCATABLE ::  dQ(:,:,:,:)
+
+
+  !   champs de tansport en moyenne zonale
+  integer :: ntr,itr
+  parameter (ntr=5)
+
+  !ym      character*10 znom(ntr,nQ)
+  !ym      character*20 znoml(ntr,nQ)
+  !ym      character*10 zunites(ntr,nQ)
+  character*10,save :: znom(ntr,nQ)
+  character*20,save :: znoml(ntr,nQ)
+  character*10,save :: zunites(ntr,nQ)
+
+  INTEGER,PARAMETER :: iave=1,itot=2,immc=3,itrs=4,istn=5
+
+  character(len=3) :: ctrs(ntr)
+  data ctrs/'  ','TOT','MMC','TRS','STN'/
+
+  real,SAVE,ALLOCATABLE ::  zvQ(:,:,:,:),zvQtmp(:,:)
+  real,SAVE,ALLOCATABLE ::  zavQ(:,:,:),psiQ(:,:,:)
+  real,SAVE,ALLOCATABLE ::  zmasse(:,:),zamasse(:)
+
+  real,SAVE,ALLOCATABLE ::  zv(:,:),psi(:,:)
+
+  integer :: i,j,l,iQ
+
+
+  !   Initialisation du fichier contenant les moyennes zonales.
+  !   ---------------------------------------------------------
+
+  character(len=10) :: infile
+
+  integer, save :: fileid
+  integer :: thoriid, zvertiid
+
+  INTEGER,SAVE,ALLOCATABLE :: ndex3d(:)
+
+  !   Variables locales
+  !
+  integer :: tau0
+  real :: zjulian
+  character(len=3) :: str
+  character(len=10) :: ctrac
+  integer :: ii,jj
+  integer :: zan, dayref
+  !
+  real,SAVE,ALLOCATABLE :: rlong(:),rlatg(:)
+  integer :: jjb,jje,jjn,ijb,ije
+  type(Request),SAVE :: Req
+!$OMP THREADPRIVATE(Req)
+
+  ! definition du domaine d'ecriture pour le rebuild
+
+  INTEGER,DIMENSION(1) :: ddid
+  INTEGER,DIMENSION(1) :: dsg
+  INTEGER,DIMENSION(1) :: dsl
+  INTEGER,DIMENSION(1) :: dpf
+  INTEGER,DIMENSION(1) :: dpl
+  INTEGER,DIMENSION(1) :: dhs
+  INTEGER,DIMENSION(1) :: dhe
+
+  INTEGER :: bilan_dyn_domain_id
+
+  !=====================================================================
+  !   Initialisation
+  !=====================================================================
+  if (adjust) return
+
+  time=time+dt_app
+  itau=itau+1
+
+  if (first) then
+!$OMP BARRIER
+!$OMP MASTER
+  ALLOCATE(zfactv(jjb_v:jje_v,llm))
+  ALLOCATE(vcont(iip1,jjb_v:jje_v,llm))
+  ALLOCATE(ucont(iip1,jjb_u:jje_u,llm))
+  ALLOCATE(ang(iip1,jjb_u:jje_u,llm))
+  ALLOCATE(unat(iip1,jjb_u:jje_u,llm))
+  ALLOCATE(massebx(iip1,jjb_u:jje_u,llm))
+  ALLOCATE(masseby(iip1,jjb_v:jje_v,llm))
+  ALLOCATE(vorpot(iip1,jjb_v:jje_v,llm))
+  ALLOCATE(w(iip1,jjb_u:jje_u,llm))
+  ALLOCATE(ecin(iip1,jjb_u:jje_u,llm))
+  ALLOCATE(convm(iip1,jjb_u:jje_u,llm))
+  ALLOCATE(bern(iip1,jjb_u:jje_u,llm))
+  ALLOCATE(Q(iip1,jjb_u:jje_u,llm,nQ))
+  ALLOCATE(ps_cum(iip1,jjb_u:jje_u))
+  ALLOCATE(masse_cum(iip1,jjb_u:jje_u,llm))
+  ALLOCATE(flux_u_cum(iip1,jjb_u:jje_u,llm))
+  ALLOCATE(flux_v_cum(iip1,jjb_v:jje_v,llm))
+  ALLOCATE(Q_cum(iip1,jjb_u:jje_u,llm,nQ))
+  ALLOCATE(flux_uQ_cum(iip1,jjb_u:jje_u,llm,nQ))
+  ALLOCATE(flux_vQ_cum(iip1,jjb_v:jje_v,llm,nQ))
+  ALLOCATE(flux_wQ_cum(iip1,jjb_u:jje_u,llm,nQ))
+  ALLOCATE(dQ(iip1,jjb_u:jje_u,llm,nQ))
+  ALLOCATE(zvQ(jjb_v:jje_v,llm,ntr,nQ))
+  ALLOCATE(zvQtmp(jjb_v:jje_v,llm))
+  ALLOCATE(zavQ(jjb_v:jje_v,ntr,nQ))
+  ALLOCATE(psiQ(jjb_v:jje_v,llm+1,nQ))
+  ALLOCATE(zmasse(jjb_v:jje_v,llm))
+  ALLOCATE(zamasse(jjb_v:jje_v))
+  ALLOCATE(zv(jjb_v:jje_v,llm))
+  ALLOCATE(psi(jjb_v:jje_v,llm+1))
+  ALLOCATE(ndex3d(jjb_v:jje_v*llm))
+  ndex3d=0
+  ALLOCATE(rlong(1))
+  ALLOCATE(rlatg(jjm))
+
+!$OMP END MASTER
+!$OMP BARRIER
+    icum=0
+    ! initialisation des fichiers
+    first=.false.
+  !   ncum est la frequence de stokage en pas de temps
+    ncum=dt_cum/dt_app
+    if (abs(ncum*dt_app-dt_cum).gt.1.e-5*dt_app) then
+       WRITE(lunout,*) &
+             'Pb : le pas de cumule doit etre multiple du pas'
+       WRITE(lunout,*)'dt_app=',dt_app
+       WRITE(lunout,*)'dt_cum=',dt_cum
+       CALL abort_gcm("conf_gcmbilan_dyn_loc","stopped",1)
+    endif
+
+!$OMP MASTER
+    nom(itemp)='T'
+    nom(igeop)='gz'
+    nom(iecin)='K'
+    nom(iang)='ang'
+    nom(iu)='u'
+    nom(iovap)='ovap'
+    nom(iun)='un'
+
+    unites(itemp)='K'
+    unites(igeop)='m2/s2'
+    unites(iecin)='m2/s2'
+    unites(iang)='ang'
+    unites(iu)='m/s'
+    unites(iovap)='kg/kg'
+    unites(iun)='un'
+
+
+  !   Initialisation du fichier contenant les moyennes zonales.
+  !   ---------------------------------------------------------
+
+  infile='dynzon'
+
+  zan = annee_ref
+  dayref = day_ref
+  CALL ymds2ju(zan, 1, dayref, 0.0, zjulian)
+  tau0 = itau_dyn
+
+  rlong=0.
+  rlatg=rlatv*180./pi
+
+  jjb=jj_begin
+  jje=jj_end
+  jjn=jj_nb
+  IF (pole_sud) THEN
+    jjn=jj_nb-1
+    jje=jj_end-1
+  ENDIF
+
+  ddid=(/ 2 /)
+  dsg=(/ jjm /)
+  dsl=(/ jjn /)
+  dpf=(/ jjb /)
+  dpl=(/ jje /)
+  dhs=(/ 0 /)
+  dhe=(/ 0 /)
+
+  call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, &
+        'box',bilan_dyn_domain_id)
+
+  call histbeg(trim(infile), &
+        1, rlong, jjn, rlatg(jjb:jje), &
+        1, 1, 1, jjn, &
+        tau0, zjulian, dt_cum, thoriid, fileid, &
+        bilan_dyn_domain_id)
+
+  !
+  !  Appel a histvert pour la grille verticale
+  !
+  call histvert(fileid, 'presnivs', 'Niveaux sigma','mb', &
+        llm, presnivs, zvertiid)
+  !
+  !  Appels a histdef pour la definition des variables a sauvegarder
+  do iQ=1,nQ
+     do itr=1,ntr
+        if(itr.eq.1) then
+           znom(itr,iQ)=nom(iQ)
+           znoml(itr,iQ)=nom(iQ)
+           zunites(itr,iQ)=unites(iQ)
+        else
+           znom(itr,iQ)=ctrs(itr)//'v'//nom(iQ)
+           znoml(itr,iQ)='transport : v * '//nom(iQ)//' '//ctrs(itr)
+           zunites(itr,iQ)='m/s * '//unites(iQ)
+        endif
+     enddo
+  enddo
+
+  !   Declarations des champs avec dimension verticale
+   ! print*,'1HISTDEF'
+  do iQ=1,nQ
+     do itr=1,ntr
+  IF (prt_level > 5) &
+        WRITE(lunout,*)'var ',itr,iQ &
+        ,znom(itr,iQ),znoml(itr,iQ),zunites(itr,iQ)
+        call histdef(fileid,znom(itr,iQ),znoml(itr,iQ), &
+              zunites(itr,iQ),1,jjn,thoriid,llm,1,llm,zvertiid, &
+              32,'ave(X)',dt_cum,dt_cum)
+     enddo
+  !   Declarations pour les fonctions de courant
+   ! print*,'2HISTDEF'
+      call histdef(fileid,'psi'//nom(iQ) &
+            ,'stream fn. '//znoml(itot,iQ), &
+            zunites(itot,iQ),1,jjn,thoriid,llm,1,llm,zvertiid, &
+            32,'ave(X)',dt_cum,dt_cum)
+  enddo
+
+
+  !   Declarations pour les champs de transport d'air
+   ! print*,'3HISTDEF'
+  call histdef(fileid, 'masse', 'masse', &
+        'kg', 1, jjn, thoriid, llm, 1, llm, zvertiid, &
+        32, 'ave(X)', dt_cum, dt_cum)
+  call histdef(fileid, 'v', 'v', &
+        'm/s', 1, jjn, thoriid, llm, 1, llm, zvertiid, &
+        32, 'ave(X)', dt_cum, dt_cum)
+  !   Declarations pour les fonctions de courant
+   ! print*,'4HISTDEF'
+      call histdef(fileid,'psi','stream fn. MMC ','mega t/s', &
+            1,jjn,thoriid,llm,1,llm,zvertiid, &
+            32,'ave(X)',dt_cum,dt_cum)
+
+
+  !   Declaration des champs 1D de transport en latitude
+   ! print*,'5HISTDEF'
+  do iQ=1,nQ
+     do itr=2,ntr
+        call histdef(fileid,'a'//znom(itr,iQ),znoml(itr,iQ), &
+              zunites(itr,iQ),1,jjn,thoriid,1,1,1,-99, &
+              32,'ave(X)',dt_cum,dt_cum)
+     enddo
+  enddo
+
+
+   ! print*,'8HISTDEF'
+           CALL histend(fileid)
+
+!$OMP END MASTER
+  endif
+
+
+  !=====================================================================
+  !   Calcul des champs dynamiques
+  !   ----------------------------
+
+  jjb=jj_begin
+  jje=jj_end
+
+  !   �nergie cin�tique
+   ! ucont(:,jjb:jje,:)=0
+
+  call Register_Hallo_u(ucov,llm,1,1,1,1,Req)
+  call Register_Hallo_v(vcov,llm,1,1,1,1,Req)
+  call SendRequest(Req)
+!$OMP BARRIER
+  call WaitRequest(Req)
+
+  CALL covcont_loc(llm,ucov,vcov,ucont,vcont)
+  CALL enercin_loc(vcov,ucov,vcont,ucont,ecin)
+
+  !   moment cin�tique
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  do l=1,llm
+     ang(:,jjb:jje,l)=ucov(:,jjb:jje,l)+constang(:,jjb:jje)
+     unat(:,jjb:jje,l)=ucont(:,jjb:jje,l)*cu(:,jjb:jje)
+  enddo
+!$OMP END DO NOWAIT
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,llm
+    Q(:,jjb:jje,l,itemp)=teta(:,jjb:jje,l)*pk(:,jjb:jje,l)/cpp
+    Q(:,jjb:jje,l,igeop)=phi(:,jjb:jje,l)
+    Q(:,jjb:jje,l,iecin)=ecin(:,jjb:jje,l)
+    Q(:,jjb:jje,l,iang)=ang(:,jjb:jje,l)
+    Q(:,jjb:jje,l,iu)=unat(:,jjb:jje,l)
+    Q(:,jjb:jje,l,iovap)=trac(:,jjb:jje,l,1)
+    Q(:,jjb:jje,l,iun)=1.
+  ENDDO
+!$OMP END DO NOWAIT
+
+  !=====================================================================
+  !   Cumul
+  !=====================================================================
+  !
+  if(icum.EQ.0) then
+     jjb=jj_begin
+     jje=jj_end
+
+!$OMP MASTER
+     ps_cum(:,jjb:jje)=0.
+!$OMP END MASTER
+
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO l=1,llm
+      masse_cum(:,jjb:jje,l)=0.
+      flux_u_cum(:,jjb:jje,l)=0.
+      Q_cum(:,jjb:jje,l,:)=0.
+      flux_uQ_cum(:,jjb:jje,l,:)=0.
+      if (pole_sud) jje=jj_end-1
+      flux_v_cum(:,jjb:jje,l)=0.
+      flux_vQ_cum(:,jjb:jje,l,:)=0.
+    ENDDO
+!$OMP END DO NOWAIT
+  endif
+
+  IF (prt_level > 5) &
+        WRITE(lunout,*)'dans bilan_dyn ',icum,'->',icum+1
+  icum=icum+1
+
+  !   accumulation des flux de masse horizontaux
+  jjb=jj_begin
+  jje=jj_end
+
+!$OMP MASTER
+  ps_cum(:,jjb:jje)=ps_cum(:,jjb:jje)+ps(:,jjb:jje)
+!$OMP END MASTER
+
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,llm
+    masse_cum(:,jjb:jje,l)=masse_cum(:,jjb:jje,l)+masse(:,jjb:jje,l)
+    flux_u_cum(:,jjb:jje,l)=flux_u_cum(:,jjb:jje,l) &
+          +flux_u(:,jjb:jje,l)
+  ENDDO
+!$OMP END DO NOWAIT
+
+  if (pole_sud) jje=jj_end-1
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,llm
+   flux_v_cum(:,jjb:jje,l)=flux_v_cum(:,jjb:jje,l) &
+         +flux_v(:,jjb:jje,l)
+  ENDDO
+!$OMP END DO NOWAIT
+
+  jjb=jj_begin
+  jje=jj_end
+
+  do iQ=1,nQ
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO l=1,llm
+      Q_cum(:,jjb:jje,l,iQ)=Q_cum(:,jjb:jje,l,iQ) &
+            +Q(:,jjb:jje,l,iQ)*masse(:,jjb:jje,l)
+    ENDDO
+!$OMP END DO NOWAIT
+  enddo
+
+  !=====================================================================
+  !  FLUX ET TENDANCES
+  !=====================================================================
+
+  !   Flux longitudinal
+  !   -----------------
+  do iQ=1,nQ
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+     do l=1,llm
+        do j=jjb,jje
+           do i=1,iim
+              flux_uQ_cum(i,j,l,iQ)=flux_uQ_cum(i,j,l,iQ) &
+                    +flux_u(i,j,l)*0.5*(Q(i,j,l,iQ)+Q(i+1,j,l,iQ))
+           enddo
+           flux_uQ_cum(iip1,j,l,iQ)=flux_uQ_cum(1,j,l,iQ)
+        enddo
+     enddo
+!$OMP END DO NOWAIT
+  enddo
+
+  !    flux m�ridien
+  !    -------------
+  do iQ=1,nQ
+    call Register_Hallo_u(Q(1,jjb_u,1,iQ),llm,0,1,1,0,Req)
+  enddo
+  call SendRequest(Req)
+!$OMP BARRIER
+  call WaitRequest(Req)
+
+  jjb=jj_begin
+  jje=jj_end
+  if (pole_sud) jje=jj_end-1
+
+  do iQ=1,nQ
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+     do l=1,llm
+        do j=jjb,jje
+           do i=1,iip1
+              flux_vQ_cum(i,j,l,iQ)=flux_vQ_cum(i,j,l,iQ) &
+                    +flux_v(i,j,l)*0.5*(Q(i,j,l,iQ)+Q(i,j+1,l,iQ))
+           enddo
+        enddo
+     enddo
+!$OMP ENDDO NOWAIT
+!$OMP BARRIER
+  enddo
+
+  !    tendances
+  !    ---------
+
+  !   convergence horizontale
+  call Register_Hallo_u(flux_uQ_cum,llm,2,2,2,2,Req)
+  call Register_Hallo_v(flux_vQ_cum,llm,2,2,2,2,Req)
+  call SendRequest(Req)
+!$OMP BARRIER
+  call WaitRequest(Req)
+
+  call  convflu_loc(flux_uQ_cum,flux_vQ_cum,llm*nQ,dQ)
+
+  !   calcul de la vitesse verticale
+  call Register_Hallo_u(flux_u_cum,llm,2,2,2,2,Req)
+  call Register_Hallo_v(flux_v_cum,llm,2,2,2,2,Req)
+  call SendRequest(Req)
+!$OMP BARRIER
+  call WaitRequest(Req)
+
+  call convmas_loc(flux_u_cum,flux_v_cum,convm)
+  CALL vitvert_loc(convm,w)
+!$OMP BARRIER
+
+
+  jjb=jj_begin
+  jje=jj_end
+
+   ! do iQ=1,nQ
+   !    do l=1,llm-1
+   !       do j=jjb,jje
+   !          do i=1,iip1
+   !             ww=-0.5*w(i,j,l+1)*(Q(i,j,l,iQ)+Q(i,j,l+1,iQ))
+   !             dQ(i,j,l  ,iQ)=dQ(i,j,l  ,iQ)-ww
+   !             dQ(i,j,l+1,iQ)=dQ(i,j,l+1,iQ)+ww
+   !          enddo
+   !       enddo
+   !     enddo
+   !  enddo
+
+  do iQ=1,nQ
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+     do l=1,llm
+        IF (l<llm) THEN
+          do j=jjb,jje
+             do i=1,iip1
+                ww=-0.5*w(i,j,l+1)*(Q(i,j,l,iQ)+Q(i,j,l+1,iQ))
+                dQ(i,j,l  ,iQ)=dQ(i,j,l  ,iQ)-ww
+                dQ(i,j,l+1,iQ)=dQ(i,j,l+1,iQ)+ww
+             enddo
+          enddo
+        ENDIF
+        IF (l>2) THEN
+          do j=jjb,jje
+            do i=1,iip1
+              ww=-0.5*w(i,j,l)*(Q(i,j,l-1,iQ)+Q(i,j,l,iQ))
+              dQ(i,j,l,iQ)=dQ(i,j,l,iQ)+ww
+            enddo
+          enddo
+        ENDIF
+     enddo
+!$OMP ENDDO NOWAIT
+  enddo
+  IF (prt_level > 5) &
+        WRITE(lunout,*)'Apres les calculs fait a chaque pas'
+  !=====================================================================
+  !   PAS DE TEMPS D'ECRITURE
+  !=====================================================================
+  if (icum.eq.ncum) then
+  !=====================================================================
+
+  IF (prt_level > 5) &
+        WRITE(lunout,*)'Pas d ecriture'
+
+  jjb=jj_begin
+  jje=jj_end
+
+  !   Normalisation
+  do iQ=1,nQ
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    do l=1,llm
+      Q_cum(:,jjb:jje,l,iQ)=Q_cum(:,jjb:jje,l,iQ) &
+            /masse_cum(:,jjb:jje,l)
+    enddo
+!$OMP ENDDO NOWAIT
+  enddo
+
+  zz=1./REAL(ncum)
+
+!$OMP MASTER
+    ps_cum(:,jjb:jje)=ps_cum(:,jjb:jje)*zz
+!$OMP END MASTER
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,llm
+    masse_cum(:,jjb:jje,l)=masse_cum(:,jjb:jje,l)*zz
+    flux_u_cum(:,jjb:jje,l)=flux_u_cum(:,jjb:jje,l)*zz
+    flux_uQ_cum(:,jjb:jje,l,:)=flux_uQ_cum(:,jjb:jje,l,:)*zz
+    dQ(:,jjb:jje,l,:)=dQ(:,jjb:jje,l,:)*zz
+  ENDDO
+!$OMP ENDDO NOWAIT
+
+  IF (pole_sud) jje=jj_end-1
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,llm
+    flux_v_cum(:,jjb:jje,l)=flux_v_cum(:,jjb:jje,l)*zz
+    flux_vQ_cum(:,jjb:jje,l,:)=flux_vQ_cum(:,jjb:jje,l,:)*zz
+  ENDDO
+!$OMP ENDDO NOWAIT
+!$OMP BARRIER
+
+  jjb=jj_begin
+  jje=jj_end
+
+
+  !   A retravailler eventuellement
+  !   division de dQ par la masse pour revenir aux bonnes grandeurs
+  do iQ=1,nQ
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO l=1,llm
+       dQ(:,jjb:jje,l,iQ)=dQ(:,jjb:jje,l,iQ)/masse_cum(:,jjb:jje,l)
+    ENDDO
+!$OMP ENDDO NOWAIT
+  enddo
+
+  !=====================================================================
+  !   Transport m�ridien
+  !=====================================================================
+
+  !   cumul zonal des masses des mailles
+  !   ----------------------------------
+  jjb=jj_begin
+  jje=jj_end
+  if (pole_sud) jje=jj_end-1
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO l=1,llm
+      zv(jjb:jje,l)=0.
+      zmasse(jjb:jje,l)=0.
+    ENDDO
+!$OMP ENDDO NOWAIT
+!$OMP BARRIER
+
+  call Register_Hallo_u(masse_cum,llm,1,1,1,1,Req)
+  do iQ=1,nQ
+    call Register_Hallo_u(Q_cum(1,jjb_u,1,iQ),llm,0,1,1,0,Req)
+  enddo
+
+  call SendRequest(Req)
+!$OMP BARRIER
+  call WaitRequest(Req)
+
+  call massbar_loc(masse_cum,massebx,masseby)
+
+  jjb=jj_begin
+  jje=jj_end
+  if (pole_sud) jje=jj_end-1
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  do l=1,llm
+     do j=jjb,jje
+        do i=1,iim
+           zmasse(j,l)=zmasse(j,l)+masseby(i,j,l)
+           zv(j,l)=zv(j,l)+flux_v_cum(i,j,l)
+        enddo
+        zfactv(j,l)=cv(1,j)/zmasse(j,l)
+     enddo
+  enddo
+!$OMP ENDDO NOWAIT
+!$OMP BARRIER
+
+  ! print*,'3OK'
+  !   --------------------------------------------------------------
+  !   calcul de la moyenne zonale du transport :
+  !   ------------------------------------------
+  !
+  !                                 --
+  ! TOT : la circulation totale       [ vq ]
+  !
+  !                                  -     -
+  ! MMC : mean meridional circulation [ v ] [ q ]
+  !
+  !                                 ----      --       - -
+  ! TRS : transitoires                [ v'q'] = [ vq ] - [ v q ]
+  !
+  !                                 - * - *       - -       -     -
+  ! STT : stationaires                [ v   q   ] = [ v q ] - [ v ] [ q ]
+  !
+  !                                          - -
+  !    on utilise aussi l'intermediaire TMP :  [ v q ]
+  !
+  !    la variable zfactv transforme un transport meridien cumule
+  !    en kg/s * unte-du-champ-transporte en m/s * unite-du-champ-transporte
+  !
+  !   --------------------------------------------------------------
+
+
+  !   ----------------------------------------
+  !   Transport dans le plan latitude-altitude
+  !   ----------------------------------------
+
+  jjb=jj_begin
+  jje=jj_end
+  if (pole_sud) jje=jj_end-1
+
+  zvQ=0.
+  psiQ=0.
+  do iQ=1,nQ
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+     do l=1,llm
+        zvQtmp(:,l)=0.
+        do j=jjb,jje
+           ! print*,'j,l,iQ=',j,l,iQ
+  !   Calcul des moyennes zonales du transort total et de zvQtmp
+           do i=1,iim
+              zvQ(j,l,itot,iQ)=zvQ(j,l,itot,iQ) &
+                    +flux_vQ_cum(i,j,l,iQ)
+              zqy=      0.5*(Q_cum(i,j,l,iQ)*masse_cum(i,j,l)+ &
+                    Q_cum(i,j+1,l,iQ)*masse_cum(i,j+1,l))
+              zvQtmp(j,l)=zvQtmp(j,l)+flux_v_cum(i,j,l)*zqy &
+                    /(0.5*(masse_cum(i,j,l)+masse_cum(i,j+1,l)))
+              zvQ(j,l,iave,iQ)=zvQ(j,l,iave,iQ)+zqy
+           enddo
+           ! print*,'aOK'
+  !   Decomposition
+           zvQ(j,l,iave,iQ)=zvQ(j,l,iave,iQ)/zmasse(j,l)
+           zvQ(j,l,itot,iQ)=zvQ(j,l,itot,iQ)*zfactv(j,l)
+           zvQtmp(j,l)=zvQtmp(j,l)*zfactv(j,l)
+           zvQ(j,l,immc,iQ)=zv(j,l)*zvQ(j,l,iave,iQ)*zfactv(j,l)
+           zvQ(j,l,itrs,iQ)=zvQ(j,l,itot,iQ)-zvQtmp(j,l)
+           zvQ(j,l,istn,iQ)=zvQtmp(j,l)-zvQ(j,l,immc,iQ)
+        enddo
+     enddo
+!$OMP ENDDO NOWAIT
+  !   fonction de courant meridienne pour la quantite Q
+!$OMP BARRIER
+!$OMP MASTER
+     do l=llm,1,-1
+        do j=jjb,jje
+           psiQ(j,l,iQ)=psiQ(j,l+1,iQ)+zvQ(j,l,itot,iQ)
+        enddo
+     enddo
+!$OMP END MASTER
+!$OMP BARRIER
+  enddo
+
+  !   fonction de courant pour la circulation meridienne moyenne
+!$OMP BARRIER
+!$OMP MASTER
+  psi(jjb:jje,:)=0.
+  do l=llm,1,-1
+     do j=jjb,jje
+        psi(j,l)=psi(j,l+1)+zv(j,l)
+        zv(j,l)=zv(j,l)*zfactv(j,l)
+     enddo
+  enddo
+!$OMP END MASTER
+!$OMP BARRIER
+
+  ! print*,'4OK'
+  !   sorties proprement dites
+!$OMP MASTER
+  if (i_sortie.eq.1) then
+  jjb=jj_begin
+  jje=jj_end
+  jjn=jj_nb
+  if (pole_sud) jje=jj_end-1
+  if (pole_sud) jjn=jj_nb-1
+  do iQ=1,nQ
+     do itr=1,ntr
+        call histwrite(fileid,znom(itr,iQ),itau, &
+              zvQ(jjb:jje,:,itr,iQ) &
+              ,jjn*llm,ndex3d)
+     enddo
+     call histwrite(fileid,'psi'//nom(iQ), &
+           itau,psiQ(jjb:jje,1:llm,iQ) &
+           ,jjn*llm,ndex3d)
+  enddo
+
+  call histwrite(fileid,'masse',itau,zmasse(jjb:jje,1:llm) &
+        ,jjn*llm,ndex3d)
+  call histwrite(fileid,'v',itau,zv(jjb:jje,1:llm) &
+        ,jjn*llm,ndex3d)
+  psi(jjb:jje,:)=psi(jjb:jje,:)*1.e-9
+  call histwrite(fileid,'psi',itau,psi(jjb:jje,1:llm), &
+        jjn*llm,ndex3d)
+
+  endif
+
+
+  !   -----------------
+  !   Moyenne verticale
+  !   -----------------
+
+  zamasse(jjb:jje)=0.
+  do l=1,llm
+     zamasse(jjb:jje)=zamasse(jjb:jje)+zmasse(jjb:jje,l)
+  enddo
+
+  zavQ(jjb:jje,:,:)=0.
+  do iQ=1,nQ
+     do itr=2,ntr
+        do l=1,llm
+           zavQ(jjb:jje,itr,iQ)=zavQ(jjb:jje,itr,iQ) &
+                 +zvQ(jjb:jje,l,itr,iQ) &
+                 *zmasse(jjb:jje,l)
+        enddo
+        zavQ(jjb:jje,itr,iQ)=zavQ(jjb:jje,itr,iQ)/zamasse(jjb:jje)
+        call histwrite(fileid,'a'//znom(itr,iQ),itau, &
+              zavQ(jjb:jje,itr,iQ),jjn*llm,ndex3d)
+     enddo
+  enddo
+!$OMP END MASTER
+  ! on doit pouvoir tracer systematiquement la fonction de courant.
+
+  !=====================================================================
+  !/////////////////////////////////////////////////////////////////////
+  icum=0                  !///////////////////////////////////////
+  endif ! icum.eq.ncum    !///////////////////////////////////////
+  !/////////////////////////////////////////////////////////////////////
+  !=====================================================================
+!$OMP MASTER
+  call histsync(fileid)
+!$OMP END MASTER
+
+
+  return
+end subroutine bilan_dyn_loc
Index: DZ6/trunk/libf/dyn3dmem/caladvtrac_loc.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/caladvtrac_loc.F90	(revision 5267)
+++ 	(revision )
@@ -1,217 +1,0 @@
-!
-! $Id: caladvtrac_p.F 1299 2010-01-20 14:27:21Z fairhead $
-!
-!
-!
-      SUBROUTINE caladvtrac_loc(q,pbaru,pbarv , &
-              p ,masse, dq ,  teta, &
-              flxw, pk, iapptrac)
-  USE parallel_lmdz
-  USE infotrac, ONLY : nqtot
-  USE control_mod, ONLY : iapp_tracvl,planet_type
-  USE caladvtrac_mod
-  USE mod_hallo
-  USE bands
-  USE times
-  USE Vampir
-  USE write_field_loc
-  USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_DEBUGIO
-  IMPLICIT NONE
-  !
-  ! Auteurs:   F.Hourdin , P.Le Van, F.Forget, F.Codron
-  !
-  ! F.Codron (10/99) : ajout humidite specifique pour eau vapeur
-  !=======================================================================
-  !
-  !   Shema de  Van Leer
-  !
-  !=======================================================================
-
-
-  include "dimensions.h"
-  include "paramet.h"
-
-  !   Arguments:
-  !   ----------
-  REAL :: pbaru( ijb_u:ije_u,llm ),pbarv( ijb_v:ije_v,llm)
-  REAL :: masse(ijb_u:ije_u,llm)
-  REAL :: p( ijb_u:ije_u,llmp1)
-  REAL :: q( ijb_u:ije_u,llm,nqtot),dq( ijb_u:ije_u,llm, nqtot )
-  REAL :: teta( ijb_u:ije_u,llm),pk( ijb_u:ije_u,llm)
-  REAL :: flxw(ijb_u:ije_u,llm)
-  INTEGER :: iapptrac
-  !   Local:
-  !   ------
-   ! REAL :: pbarug(ijb_u:ije_u,llm)
-   ! REAL :: pbarvg(ijb_v:ije_v,llm)
-  !      REAL :: wg(ijb_u:ije_u,llm)
-
-  REAL :: flxw_adv(distrib_vanleer%ijb_u:distrib_vanleer%ije_u,llm)
-  INTEGER,SAVE :: iadvtr=0
-!$OMP THREADPRIVATE(iadvtr)
-  INTEGER ::  ijb,ije,ijbu,ijbv,ijeu,ijev,j
-  INTEGER :: ij,l
-  TYPE(Request),SAVE :: Request_vanleer
-!$OMP THREADPRIVATE(Request_vanleer)
-
-  ! !write(*,*) 'caladvtrac 58: entree'
-  ijbu=ij_begin
-  ijeu=ij_end
-
-  ijbv=ij_begin-iip1
-  ijev=ij_end
-  if (pole_nord) ijbv=ij_begin
-  if (pole_sud)  ijev=ij_end-iip1
-
-  IF(iadvtr.EQ.0) THEN
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-    DO l=1,llm
-      pbaruc(ijbu:ijeu,l)=0.
-      pbarvc(ijbv:ijev,l)=0.
-    ENDDO
-!$OMP END DO NOWAIT
-  ENDIF
-
-  !   accumulation des flux de masse horizontaux
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-  DO l=1,llm
-     DO ij = ijbu,ijeu
-        pbaruc(ij,l) = pbaruc(ij,l) + pbaru(ij,l)
-     ENDDO
-     DO ij = ijbv,ijev
-        pbarvc(ij,l) = pbarvc(ij,l) + pbarv(ij,l)
-     ENDDO
-  ENDDO
-!$OMP END DO NOWAIT
-
-  !   selection de la masse instantannee des mailles avant le transport.
-  IF(iadvtr.EQ.0) THEN
-
-      ijb=ij_begin
-      ije=ij_end
-
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-   DO l=1,llm
-      massem(ijb:ije,l)=masse(ijb:ije,l)
-   ENDDO
-!$OMP END DO NOWAIT
-
-  ENDIF
-
-  iadvtr   = iadvtr+1
-
-!$OMP MASTER
-  iapptrac = iadvtr
-!$OMP END MASTER
-
-  !   Test pour savoir si on advecte a ce pas de temps
-
-  IF ( iadvtr.EQ.iapp_tracvl ) THEN
-  ! !write(*,*) 'caladvtrac 133'
-!$OMP MASTER
-    call suspend_timer(timer_caldyn)
-!$OMP END MASTER
-
-  ijb=ij_begin
-  ije=ij_end
-
-  !c   ..  Modif P.Le Van  ( 20/12/97 )  ....
-  !c
-
-  !   traitement des flux de masse avant advection.
-  ! 1. calcul de w
-  ! 2. groupement des mailles pres du pole.
-
-    CALL groupe_loc( massem, pbaruc,pbarvc, pbarug,pbarvg,wg )
-
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-  DO l=1,llm
-    flxw(ijb:ije,l)=wg(ijb:ije,l)/REAL(iapp_tracvl)
-  ENDDO
-!$OMP ENDDO NOWAIT
-
-IF (CPPKEY_DEBUGIO) THEN
-     CALL WriteField_u('pbarug1',pbarug)
-     CALL WriteField_v('pbarvg1',pbarvg)
-     CALL WriteField_u('wg1',wg)
-END IF
-
-!$OMP BARRIER
-
-
-!$OMP MASTER
-  call VTb(VTHallo)
-!$OMP END MASTER
-
-  call Register_SwapField_u(pbarug,pbarug_adv, distrib_vanleer, &
-        Request_vanleer)
-  call Register_SwapField_v(pbarvg,pbarvg_adv, distrib_vanleer, &
-        Request_vanleer,up=1)
-  call Register_SwapField_u(massem,massem_adv, distrib_vanleer, &
-        Request_vanleer)
-  call Register_SwapField_u(wg,wg_adv,distrib_vanleer, &
-        Request_vanleer)
-  call Register_SwapField_u(teta,teta_adv, distrib_vanleer, &
-        Request_vanleer,up=1,down=1)
-  call Register_SwapField_u(p,p_adv, distrib_vanleer, &
-        Request_vanleer,up=1,down=1)
-  call Register_SwapField_u(pk,pk_adv, distrib_vanleer, &
-        Request_vanleer,up=1,down=1)
-  call Register_SwapField_u(q,q_adv, distrib_vanleer, &
-        Request_vanleer)
-
-  call SendRequest(Request_vanleer)
-!$OMP BARRIER
-  call WaitRequest(Request_vanleer)
-
-
-!$OMP BARRIER
-!$OMP MASTER
-  call Set_Distrib(distrib_vanleer)
-  call VTe(VTHallo)
-  call VTb(VTadvection)
-  call start_timer(timer_vanleer)
-!$OMP END MASTER
-!$OMP BARRIER
-   ! CALL WriteField_u('pbarug_adv',pbarug_adv)
-   ! CALL WriteField_u('',)
-
-
-IF (CPPKEY_DEBUGIO) THEN
-     CALL WriteField_u('pbarug1',pbarug_adv)
-     CALL WriteField_v('pbarvg1',pbarvg_adv)
-     CALL WriteField_u('wg1',wg_adv)
-END IF
-  ! !write(*,*) 'caladvtrac 185'
-  CALL advtrac_loc( pbarug_adv,pbarvg_adv,wg_adv, &
-        p_adv,  massem_adv,q_adv, teta_adv, &
-        pk_adv)
-  ! !write(*,*) 'caladvtrac 189'
-
-
-!$OMP MASTER
-    call VTe(VTadvection)
-    call stop_timer(timer_vanleer)
-    call VTb(VThallo)
-!$OMP END MASTER
-
-    call Register_SwapField_u(q_adv,q,distrib_caldyn, &
-          Request_vanleer)
-
-    call SendRequest(Request_vanleer)
-!$OMP BARRIER
-    call WaitRequest(Request_vanleer)
-
-!$OMP BARRIER
-!$OMP MASTER
-    call Set_Distrib(distrib_caldyn)
-    call VTe(VThallo)
-    call resume_timer(timer_caldyn)
-!$OMP END MASTER
-!$OMP BARRIER
-      iadvtr=0
-   ENDIF ! if iadvtr.EQ.iapp_tracvl
-
-END SUBROUTINE caladvtrac_loc
-
-
Index: /LMDZ6/trunk/libf/dyn3dmem/caladvtrac_loc.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/caladvtrac_loc.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3dmem/caladvtrac_loc.f90	(revision 5268)
@@ -0,0 +1,217 @@
+!
+! $Id: caladvtrac_p.F 1299 2010-01-20 14:27:21Z fairhead $
+!
+!
+!
+      SUBROUTINE caladvtrac_loc(q,pbaru,pbarv , &
+              p ,masse, dq ,  teta, &
+              flxw, pk, iapptrac)
+  USE parallel_lmdz
+  USE infotrac, ONLY : nqtot
+  USE control_mod, ONLY : iapp_tracvl,planet_type
+  USE caladvtrac_mod
+  USE mod_hallo
+  USE bands
+  USE times
+  USE Vampir
+  USE write_field_loc
+  USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_DEBUGIO
+  IMPLICIT NONE
+  !
+  ! Auteurs:   F.Hourdin , P.Le Van, F.Forget, F.Codron
+  !
+  ! F.Codron (10/99) : ajout humidite specifique pour eau vapeur
+  !=======================================================================
+  !
+  !   Shema de  Van Leer
+  !
+  !=======================================================================
+
+
+  include "dimensions.h"
+  include "paramet.h"
+
+  !   Arguments:
+  !   ----------
+  REAL :: pbaru( ijb_u:ije_u,llm ),pbarv( ijb_v:ije_v,llm)
+  REAL :: masse(ijb_u:ije_u,llm)
+  REAL :: p( ijb_u:ije_u,llmp1)
+  REAL :: q( ijb_u:ije_u,llm,nqtot),dq( ijb_u:ije_u,llm, nqtot )
+  REAL :: teta( ijb_u:ije_u,llm),pk( ijb_u:ije_u,llm)
+  REAL :: flxw(ijb_u:ije_u,llm)
+  INTEGER :: iapptrac
+  !   Local:
+  !   ------
+   ! REAL :: pbarug(ijb_u:ije_u,llm)
+   ! REAL :: pbarvg(ijb_v:ije_v,llm)
+  !      REAL :: wg(ijb_u:ije_u,llm)
+
+  REAL :: flxw_adv(distrib_vanleer%ijb_u:distrib_vanleer%ije_u,llm)
+  INTEGER,SAVE :: iadvtr=0
+!$OMP THREADPRIVATE(iadvtr)
+  INTEGER ::  ijb,ije,ijbu,ijbv,ijeu,ijev,j
+  INTEGER :: ij,l
+  TYPE(Request),SAVE :: Request_vanleer
+!$OMP THREADPRIVATE(Request_vanleer)
+
+  ! !write(*,*) 'caladvtrac 58: entree'
+  ijbu=ij_begin
+  ijeu=ij_end
+
+  ijbv=ij_begin-iip1
+  ijev=ij_end
+  if (pole_nord) ijbv=ij_begin
+  if (pole_sud)  ijev=ij_end-iip1
+
+  IF(iadvtr.EQ.0) THEN
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO l=1,llm
+      pbaruc(ijbu:ijeu,l)=0.
+      pbarvc(ijbv:ijev,l)=0.
+    ENDDO
+!$OMP END DO NOWAIT
+  ENDIF
+
+  !   accumulation des flux de masse horizontaux
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,llm
+     DO ij = ijbu,ijeu
+        pbaruc(ij,l) = pbaruc(ij,l) + pbaru(ij,l)
+     ENDDO
+     DO ij = ijbv,ijev
+        pbarvc(ij,l) = pbarvc(ij,l) + pbarv(ij,l)
+     ENDDO
+  ENDDO
+!$OMP END DO NOWAIT
+
+  !   selection de la masse instantannee des mailles avant le transport.
+  IF(iadvtr.EQ.0) THEN
+
+      ijb=ij_begin
+      ije=ij_end
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+   DO l=1,llm
+      massem(ijb:ije,l)=masse(ijb:ije,l)
+   ENDDO
+!$OMP END DO NOWAIT
+
+  ENDIF
+
+  iadvtr   = iadvtr+1
+
+!$OMP MASTER
+  iapptrac = iadvtr
+!$OMP END MASTER
+
+  !   Test pour savoir si on advecte a ce pas de temps
+
+  IF ( iadvtr.EQ.iapp_tracvl ) THEN
+  ! !write(*,*) 'caladvtrac 133'
+!$OMP MASTER
+    call suspend_timer(timer_caldyn)
+!$OMP END MASTER
+
+  ijb=ij_begin
+  ije=ij_end
+
+  !c   ..  Modif P.Le Van  ( 20/12/97 )  ....
+  !c
+
+  !   traitement des flux de masse avant advection.
+  ! 1. calcul de w
+  ! 2. groupement des mailles pres du pole.
+
+    CALL groupe_loc( massem, pbaruc,pbarvc, pbarug,pbarvg,wg )
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,llm
+    flxw(ijb:ije,l)=wg(ijb:ije,l)/REAL(iapp_tracvl)
+  ENDDO
+!$OMP ENDDO NOWAIT
+
+IF (CPPKEY_DEBUGIO) THEN
+     CALL WriteField_u('pbarug1',pbarug)
+     CALL WriteField_v('pbarvg1',pbarvg)
+     CALL WriteField_u('wg1',wg)
+END IF
+
+!$OMP BARRIER
+
+
+!$OMP MASTER
+  call VTb(VTHallo)
+!$OMP END MASTER
+
+  call Register_SwapField_u(pbarug,pbarug_adv, distrib_vanleer, &
+        Request_vanleer)
+  call Register_SwapField_v(pbarvg,pbarvg_adv, distrib_vanleer, &
+        Request_vanleer,up=1)
+  call Register_SwapField_u(massem,massem_adv, distrib_vanleer, &
+        Request_vanleer)
+  call Register_SwapField_u(wg,wg_adv,distrib_vanleer, &
+        Request_vanleer)
+  call Register_SwapField_u(teta,teta_adv, distrib_vanleer, &
+        Request_vanleer,up=1,down=1)
+  call Register_SwapField_u(p,p_adv, distrib_vanleer, &
+        Request_vanleer,up=1,down=1)
+  call Register_SwapField_u(pk,pk_adv, distrib_vanleer, &
+        Request_vanleer,up=1,down=1)
+  call Register_SwapField_u(q,q_adv, distrib_vanleer, &
+        Request_vanleer)
+
+  call SendRequest(Request_vanleer)
+!$OMP BARRIER
+  call WaitRequest(Request_vanleer)
+
+
+!$OMP BARRIER
+!$OMP MASTER
+  call Set_Distrib(distrib_vanleer)
+  call VTe(VTHallo)
+  call VTb(VTadvection)
+  call start_timer(timer_vanleer)
+!$OMP END MASTER
+!$OMP BARRIER
+   ! CALL WriteField_u('pbarug_adv',pbarug_adv)
+   ! CALL WriteField_u('',)
+
+
+IF (CPPKEY_DEBUGIO) THEN
+     CALL WriteField_u('pbarug1',pbarug_adv)
+     CALL WriteField_v('pbarvg1',pbarvg_adv)
+     CALL WriteField_u('wg1',wg_adv)
+END IF
+  ! !write(*,*) 'caladvtrac 185'
+  CALL advtrac_loc( pbarug_adv,pbarvg_adv,wg_adv, &
+        p_adv,  massem_adv,q_adv, teta_adv, &
+        pk_adv)
+  ! !write(*,*) 'caladvtrac 189'
+
+
+!$OMP MASTER
+    call VTe(VTadvection)
+    call stop_timer(timer_vanleer)
+    call VTb(VThallo)
+!$OMP END MASTER
+
+    call Register_SwapField_u(q_adv,q,distrib_caldyn, &
+          Request_vanleer)
+
+    call SendRequest(Request_vanleer)
+!$OMP BARRIER
+    call WaitRequest(Request_vanleer)
+
+!$OMP BARRIER
+!$OMP MASTER
+    call Set_Distrib(distrib_caldyn)
+    call VTe(VThallo)
+    call resume_timer(timer_caldyn)
+!$OMP END MASTER
+!$OMP BARRIER
+      iadvtr=0
+   ENDIF ! if iadvtr.EQ.iapp_tracvl
+
+END SUBROUTINE caladvtrac_loc
+
+
Index: DZ6/trunk/libf/dyn3dmem/caladvtrac_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/caladvtrac_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,115 +1,0 @@
-MODULE caladvtrac_mod
-
-  REAL,POINTER,SAVE :: q_adv(:,:,:)
-  REAL,POINTER,SAVE :: massem_adv(:,:)
-  REAL,POINTER,SAVE :: wg_adv(:,:)
-  REAL,POINTER,SAVE :: teta_adv(:,:)
-  REAL,POINTER,SAVE :: p_adv(:,:)
-  REAL,POINTER,SAVE :: pk_adv(:,:)
-  REAL,POINTER,SAVE :: pbarug_adv(:,:)
-  REAL,POINTER,SAVE :: pbarvg_adv(:,:)
-  REAL,POINTER,SAVE :: pbaruc(:,:)
-  REAL,POINTER,SAVE :: pbarvc(:,:)
-  REAL,POINTER,SAVE :: pbarug(:,:)
-  REAL,POINTER,SAVE :: pbarvg(:,:)
-  REAL,POINTER,SAVE :: wg(:,:)
-
-  REAL,POINTER,SAVE :: massem(:,:)
-  !Offline
-  REAL,POINTER,SAVE :: tetac(:,:)
-  REAL,POINTER,SAVE :: massec(:,:)
-  REAL,POINTER,SAVE :: phic(:,:)
-  REAL,POINTER,SAVE :: pbarucc(:,:)
-  REAL,POINTER,SAVE :: pbarvcc(:,:)
-  REAL,POINTER,SAVE :: pbarugg(:,:)
-  REAL,POINTER,SAVE :: pbarvgg(:,:)
-  REAL,POINTER,SAVE :: wgg(:,:)
-CONTAINS
-
-  SUBROUTINE caladvtrac_allocate
-  USE bands
-  USE allocate_field_mod
-  USE parallel_lmdz
-  USE infotrac, ONLY: nqtot
-  USE advtrac_mod, ONLY : advtrac_allocate
-  USE groupe_mod 
-  IMPLICIT NONE
-  INCLUDE "dimensions.h"
-  INCLUDE "paramet.h"
-  TYPE(distrib),POINTER :: d
-
-    d=>distrib_vanleer
-    CALL allocate_u(q_adv,llm,nqtot,d)
-    CALL allocate_u(massem_adv,llm,d)
-    CALL allocate_u(wg_adv,llm,d)
-    CALL allocate_u(teta_adv,llm,d)
-    CALL allocate_u(p_adv,llmp1,d)
-    CALL allocate_u(pk_adv,llm,d)
-    CALL allocate_u(pbarug_adv,llm,d)
-    CALL allocate_v(pbarvg_adv,llm,d)
-
-    d=>distrib_caldyn
-    CALL allocate_u(massem,llm,d)
-    CALL allocate_u(pbaruc,llm,d)
-    pbaruc(:,:)=0
-    CALL allocate_v(pbarvc,llm,d)
-    pbarvc(:,:)=0
-    CALL allocate_u(pbarug,llm,d)
-    CALL allocate_v(pbarvg,llm,d)
-    CALL allocate_u(wg,llm,d)
-    ! Offline
-    CALL allocate_u(tetac,llm,d)
-    CALL allocate_u(phic,llm,d)
-    CALL allocate_u(pbarucc,llm,d)
-    CALL allocate_v(pbarvcc,llm,d)
-    CALL allocate_u(massec,llm,d)
-    CALL allocate_u(pbarugg,llm,d)
-    CALL allocate_v(pbarvgg,llm,d)
-    CALL allocate_u(wgg,llm,d)
-
-    CALL groupe_allocate
-    CALL advtrac_allocate
-    
-  END SUBROUTINE caladvtrac_allocate
-  
-  SUBROUTINE caladvtrac_switch_caldyn(dist)
-  USE allocate_field_mod
-  USE bands
-  USE parallel_lmdz
-  USE groupe_mod
-  IMPLICIT NONE
-    TYPE(distrib),INTENT(IN) :: dist
-
-    CALL switch_u(massem,distrib_caldyn,dist)
-    CALL switch_u(pbaruc,distrib_caldyn,dist)
-    CALL switch_v(pbarvc,distrib_caldyn,dist,up=1)
-    CALL switch_u(pbarug,distrib_caldyn,dist)
-    CALL switch_v(pbarvg,distrib_caldyn,dist)
-    CALL switch_u(wg,distrib_caldyn,dist)
-    
-    CALL groupe_switch_caldyn(dist)
-
-  END SUBROUTINE caladvtrac_switch_caldyn
-  
-  SUBROUTINE caladvtrac_switch_vanleer(dist)
-  USE allocate_field_mod
-  USE bands
-  USE parallel_lmdz
-  USE advtrac_mod, ONLY : advtrac_switch_vanleer 
-  IMPLICIT NONE
-    TYPE(distrib),INTENT(IN) :: dist
-  
-    CALL switch_u(q_adv,distrib_vanleer,dist)
-    CALL switch_u(massem_adv,distrib_vanleer,dist)
-    CALL switch_u(wg_adv,distrib_vanleer,dist)
-    CALL switch_u(teta_adv,distrib_vanleer,dist)
-    CALL switch_u(p_adv,distrib_vanleer,dist)
-    CALL switch_u(pk_adv,distrib_vanleer,dist)
-    CALL switch_u(pbarug_adv,distrib_vanleer,dist)
-    CALL switch_v(pbarvg_adv,distrib_vanleer,dist)
-
-    CALL advtrac_switch_vanleer(dist)
-    
-  END SUBROUTINE caladvtrac_switch_vanleer  
-  
-END MODULE caladvtrac_mod  
Index: /LMDZ6/trunk/libf/dyn3dmem/caladvtrac_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/caladvtrac_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3dmem/caladvtrac_mod.f90	(revision 5268)
@@ -0,0 +1,115 @@
+MODULE caladvtrac_mod
+
+  REAL,POINTER,SAVE :: q_adv(:,:,:)
+  REAL,POINTER,SAVE :: massem_adv(:,:)
+  REAL,POINTER,SAVE :: wg_adv(:,:)
+  REAL,POINTER,SAVE :: teta_adv(:,:)
+  REAL,POINTER,SAVE :: p_adv(:,:)
+  REAL,POINTER,SAVE :: pk_adv(:,:)
+  REAL,POINTER,SAVE :: pbarug_adv(:,:)
+  REAL,POINTER,SAVE :: pbarvg_adv(:,:)
+  REAL,POINTER,SAVE :: pbaruc(:,:)
+  REAL,POINTER,SAVE :: pbarvc(:,:)
+  REAL,POINTER,SAVE :: pbarug(:,:)
+  REAL,POINTER,SAVE :: pbarvg(:,:)
+  REAL,POINTER,SAVE :: wg(:,:)
+
+  REAL,POINTER,SAVE :: massem(:,:)
+  !Offline
+  REAL,POINTER,SAVE :: tetac(:,:)
+  REAL,POINTER,SAVE :: massec(:,:)
+  REAL,POINTER,SAVE :: phic(:,:)
+  REAL,POINTER,SAVE :: pbarucc(:,:)
+  REAL,POINTER,SAVE :: pbarvcc(:,:)
+  REAL,POINTER,SAVE :: pbarugg(:,:)
+  REAL,POINTER,SAVE :: pbarvgg(:,:)
+  REAL,POINTER,SAVE :: wgg(:,:)
+CONTAINS
+
+  SUBROUTINE caladvtrac_allocate
+  USE bands
+  USE allocate_field_mod
+  USE parallel_lmdz
+  USE infotrac, ONLY: nqtot
+  USE advtrac_mod, ONLY : advtrac_allocate
+  USE groupe_mod 
+  IMPLICIT NONE
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  TYPE(distrib),POINTER :: d
+
+    d=>distrib_vanleer
+    CALL allocate_u(q_adv,llm,nqtot,d)
+    CALL allocate_u(massem_adv,llm,d)
+    CALL allocate_u(wg_adv,llm,d)
+    CALL allocate_u(teta_adv,llm,d)
+    CALL allocate_u(p_adv,llmp1,d)
+    CALL allocate_u(pk_adv,llm,d)
+    CALL allocate_u(pbarug_adv,llm,d)
+    CALL allocate_v(pbarvg_adv,llm,d)
+
+    d=>distrib_caldyn
+    CALL allocate_u(massem,llm,d)
+    CALL allocate_u(pbaruc,llm,d)
+    pbaruc(:,:)=0
+    CALL allocate_v(pbarvc,llm,d)
+    pbarvc(:,:)=0
+    CALL allocate_u(pbarug,llm,d)
+    CALL allocate_v(pbarvg,llm,d)
+    CALL allocate_u(wg,llm,d)
+    ! Offline
+    CALL allocate_u(tetac,llm,d)
+    CALL allocate_u(phic,llm,d)
+    CALL allocate_u(pbarucc,llm,d)
+    CALL allocate_v(pbarvcc,llm,d)
+    CALL allocate_u(massec,llm,d)
+    CALL allocate_u(pbarugg,llm,d)
+    CALL allocate_v(pbarvgg,llm,d)
+    CALL allocate_u(wgg,llm,d)
+
+    CALL groupe_allocate
+    CALL advtrac_allocate
+    
+  END SUBROUTINE caladvtrac_allocate
+  
+  SUBROUTINE caladvtrac_switch_caldyn(dist)
+  USE allocate_field_mod
+  USE bands
+  USE parallel_lmdz
+  USE groupe_mod
+  IMPLICIT NONE
+    TYPE(distrib),INTENT(IN) :: dist
+
+    CALL switch_u(massem,distrib_caldyn,dist)
+    CALL switch_u(pbaruc,distrib_caldyn,dist)
+    CALL switch_v(pbarvc,distrib_caldyn,dist,up=1)
+    CALL switch_u(pbarug,distrib_caldyn,dist)
+    CALL switch_v(pbarvg,distrib_caldyn,dist)
+    CALL switch_u(wg,distrib_caldyn,dist)
+    
+    CALL groupe_switch_caldyn(dist)
+
+  END SUBROUTINE caladvtrac_switch_caldyn
+  
+  SUBROUTINE caladvtrac_switch_vanleer(dist)
+  USE allocate_field_mod
+  USE bands
+  USE parallel_lmdz
+  USE advtrac_mod, ONLY : advtrac_switch_vanleer 
+  IMPLICIT NONE
+    TYPE(distrib),INTENT(IN) :: dist
+  
+    CALL switch_u(q_adv,distrib_vanleer,dist)
+    CALL switch_u(massem_adv,distrib_vanleer,dist)
+    CALL switch_u(wg_adv,distrib_vanleer,dist)
+    CALL switch_u(teta_adv,distrib_vanleer,dist)
+    CALL switch_u(p_adv,distrib_vanleer,dist)
+    CALL switch_u(pk_adv,distrib_vanleer,dist)
+    CALL switch_u(pbarug_adv,distrib_vanleer,dist)
+    CALL switch_v(pbarvg_adv,distrib_vanleer,dist)
+
+    CALL advtrac_switch_vanleer(dist)
+    
+  END SUBROUTINE caladvtrac_switch_vanleer  
+  
+END MODULE caladvtrac_mod  
Index: DZ6/trunk/libf/dyn3dmem/caldyn_loc.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/caldyn_loc.F90	(revision 5267)
+++ 	(revision )
@@ -1,179 +1,0 @@
-SUBROUTINE caldyn_loc &
-        (itau,ucov,vcov,teta,ps,masse,pk,pkf,phis , &
-        phi,conser,du,dv,dteta,dp,w,pbaru,pbarv,time )
-  USE parallel_lmdz
-  USE Write_Field_loc
-  USE caldyn_mod, ONLY: vcont, ucont, ang, p, massebx, masseby, &
-        vorpot, ecin, bern, massebxy, convm
-  USE comvert_mod, ONLY: ap, bp
-  USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_DEBUGIO
-  IMPLICIT NONE
-
-  !=======================================================================
-  !
-  !  Auteur :  P. Le Van
-  !
-  !   Objet:
-  !   ------
-  !
-  !   Calcul des tendances dynamiques.
-  !
-  ! Modif 04/93 F.Forget
-  !=======================================================================
-
-  !-----------------------------------------------------------------------
-  !   0. Declarations:
-  !   ----------------
-
-  include "dimensions.h"
-  include "paramet.h"
-  include "comgeom.h"
-
-  !   Arguments:
-  !   ----------
-
-  LOGICAL,INTENT(IN) :: conser ! triggers printing some diagnostics ! not used
-  INTEGER,INTENT(IN) :: itau ! time step index ! not used
-  REAL,INTENT(IN) :: vcov(ijb_v:ije_v,llm) ! covariant meridional wind
-  REAL,INTENT(IN) :: ucov(ijb_u:ije_u,llm) ! covariant zonal wind
-  REAL,INTENT(IN) :: teta(ijb_u:ije_u,llm) ! potential temperature
-  REAL,INTENT(IN) :: ps(ijb_u:ije_u) ! surface pressure
-  REAL,INTENT(IN) :: phis(ijb_u:ije_u) ! geopotential at the surface
-  REAL,INTENT(IN) :: pk(iip1,jjb_u:jje_u,llm) ! Exner at mid-layer
-  REAL,INTENT(IN) :: pkf(ijb_u:ije_u,llm) ! filtered Exner
-  REAL,INTENT(IN) :: phi(ijb_u:ije_u,llm) ! geopotential
-  REAL,INTENT(OUT) :: masse(ijb_u:ije_u,llm) ! air mass
-  REAL,INTENT(OUT) :: dv(ijb_v:ije_v,llm) ! tendency on vcov
-  REAL,INTENT(OUT) :: du(ijb_u:ije_u,llm) ! tendency on ucov
-  REAL,INTENT(OUT) :: dteta(ijb_u:ije_u,llm) ! tenddency on teta
-  REAL,INTENT(OUT) :: dp(ijb_u:ije_u) ! tendency on ps
-  REAL,INTENT(OUT) :: w(ijb_u:ije_u,llm) ! vertical velocity
-  REAL,INTENT(OUT) :: pbaru(ijb_u:ije_u,llm) ! mass flux in the zonal direction
-  REAL,INTENT(OUT) :: pbarv(ijb_v:ije_v,llm) ! mass flux in the meridional direction
-  REAL,INTENT(IN) :: time ! current time
-
-  !   Local:
-  !   ------
-
-  INTEGER :: ij,l,ijb,ije,ierr
-
-
-  !-----------------------------------------------------------------------
-  !   Compute dynamical tendencies:
-  !--------------------------------
-
-  ! ! compute contravariant winds ucont() and vcont
-  CALL covcont_loc  ( llm    , ucov    , vcov , ucont, vcont     )
-  ! ! compute pressure p()
-  CALL pression_loc ( ip1jmp1, ap      , bp   ,  ps  , p         )
-  !ym      CALL psextbar (   ps   , psexbarxy                          )
-!$OMP BARRIER
-  ! ! compute mass in each atmospheric mesh: masse()
-  CALL massdair_loc (    p   , masse                             )
-  ! ! compute X and Y-averages of mass, massebx() and masseby()
-  CALL massbar_loc  (   masse, massebx , masseby                 )
-  ! ! compute XY-average of mass, massebxy()
-  call massbarxy_loc(   masse, massebxy                          )
-  ! ! compute mass fluxes pbaru() and pbarv()
-  CALL flumass_loc  ( massebx, masseby,vcont,ucont,pbaru,pbarv   )
-  ! ! compute dteta() , horizontal converging flux of theta
-  CALL dteta1_loc   (   teta , pbaru   , pbarv, dteta            )
-  ! ! compute convm(), horizontal converging flux of mass
-  CALL convmas1_loc  (   pbaru, pbarv   , convm                  )
-!$OMP BARRIER
-  CALL convmas2_loc  (   convm                      )
-!$OMP BARRIER
-IF (CPPKEY_DEBUGIO) THEN
-  call WriteField_u('ucont',ucont)
-  call WriteField_v('vcont',vcont)
-  call WriteField_u('p',p)
-  call WriteField_u('masse',masse)
-  call WriteField_u('massebx',massebx)
-  call WriteField_v('masseby',masseby)
-  call WriteField_v('massebxy',massebxy)
-  call WriteField_u('pbaru',pbaru)
-  call WriteField_v('pbarv',pbarv)
-  call WriteField_u('dteta',dteta)
-  call WriteField_u('convm',convm)
-END IF
-
-!$OMP BARRIER
-!$OMP MASTER
-  ijb=ij_begin
-  ije=ij_end
-  ! ! compute pressure variation due to mass convergence
-  DO ij =ijb, ije
-     dp( ij ) = convm( ij,1 ) / airesurg( ij )
-  ENDDO
-!$OMP END MASTER
-!$OMP BARRIER
-
-  ! ! compute vertical velocity w()
-  CALL vitvert_loc ( convm  , w                                )
-  ! ! compute potential vorticity vorpot()
-  CALL tourpot_loc ( vcov   , ucov  , massebxy  , vorpot       )
-  ! ! compute rotation induced du() and dv()
-  CALL dudv1_loc   ( vorpot , pbaru , pbarv     , du     , dv  )
-
-IF (CPPKEY_DEBUGIO) THEN
-  call WriteField_u('w',w)
-  call WriteField_v('vorpot',vorpot)
-  call WriteField_u('du',du)
-  call WriteField_v('dv',dv)
-END IF
-
-  ! ! compute kinetic energy ecin()
-  CALL enercin_loc ( vcov   , ucov  , vcont   , ucont  , ecin  )
-  ! ! compute Bernouilli function bern()
-  CALL bernoui_loc ( ip1jmp1, llm   , phi       , ecin   , bern)
-  ! ! compute and add du() and dv() contributions from Bernouilli and pressure
-  CALL dudv2_loc   ( teta   , pkf   , bern      , du     , dv  )
-
-IF (CPPKEY_DEBUGIO) THEN
-  call WriteField_u('ecin',ecin)
-  call WriteField_u('bern',bern)
-  call WriteField_u('du',du)
-  call WriteField_v('dv',dv)
-  call WriteField_u('pkf',pkf)
-END IF
-
-  ijb=ij_begin-iip1
-  ije=ij_end+iip1
-
-  if (pole_nord) ijb=ij_begin
-  if (pole_sud) ije=ij_end
-
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-  DO l=1,llm
-     DO ij=ijb,ije
-        ang(ij,l) = ucov(ij,l) + constang(ij)
-    ENDDO
-  ENDDO
-!$OMP END DO
-
-  ! ! compute vertical advection contributions to du(), dv() and dteta()
-  CALL advect_new_loc(ang,vcov,teta,w,massebx,masseby,du,dv,dteta)
-
-  !  WARNING probleme de peridocite de dv sur les PC/linux. Pb d'arrondi
-       ! probablement. Observe sur le code compile avec pgf90 3.0-1
-  ijb=ij_begin
-  ije=ij_end
-  if (pole_sud) ije=ij_end-iip1
-
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-  DO l = 1, llm
-     DO ij = ijb, ije, iip1
-       IF( dv(ij,l).NE.dv(ij+iim,l) )  THEN
-      ! PRINT *,'!!!ATTENTION!!! probleme de periodicite sur vcov',
-  !    ,   ' dans caldyn'
-      ! PRINT *,' l,  ij = ', l, ij, ij+iim,dv(ij+iim,l),dv(ij,l)
-      dv(ij+iim,l) = dv(ij,l)
-      endif
-     enddo
-  enddo
-!$OMP END DO NOWAIT
-
-  ! Ehouarn: NB: output of control variables not implemented...
-
-  RETURN
-END SUBROUTINE caldyn_loc
Index: /LMDZ6/trunk/libf/dyn3dmem/caldyn_loc.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/caldyn_loc.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3dmem/caldyn_loc.f90	(revision 5268)
@@ -0,0 +1,179 @@
+SUBROUTINE caldyn_loc &
+        (itau,ucov,vcov,teta,ps,masse,pk,pkf,phis , &
+        phi,conser,du,dv,dteta,dp,w,pbaru,pbarv,time )
+  USE parallel_lmdz
+  USE Write_Field_loc
+  USE caldyn_mod, ONLY: vcont, ucont, ang, p, massebx, masseby, &
+        vorpot, ecin, bern, massebxy, convm
+  USE comvert_mod, ONLY: ap, bp
+  USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_DEBUGIO
+  IMPLICIT NONE
+
+  !=======================================================================
+  !
+  !  Auteur :  P. Le Van
+  !
+  !   Objet:
+  !   ------
+  !
+  !   Calcul des tendances dynamiques.
+  !
+  ! Modif 04/93 F.Forget
+  !=======================================================================
+
+  !-----------------------------------------------------------------------
+  !   0. Declarations:
+  !   ----------------
+
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom.h"
+
+  !   Arguments:
+  !   ----------
+
+  LOGICAL,INTENT(IN) :: conser ! triggers printing some diagnostics ! not used
+  INTEGER,INTENT(IN) :: itau ! time step index ! not used
+  REAL,INTENT(IN) :: vcov(ijb_v:ije_v,llm) ! covariant meridional wind
+  REAL,INTENT(IN) :: ucov(ijb_u:ije_u,llm) ! covariant zonal wind
+  REAL,INTENT(IN) :: teta(ijb_u:ije_u,llm) ! potential temperature
+  REAL,INTENT(IN) :: ps(ijb_u:ije_u) ! surface pressure
+  REAL,INTENT(IN) :: phis(ijb_u:ije_u) ! geopotential at the surface
+  REAL,INTENT(IN) :: pk(iip1,jjb_u:jje_u,llm) ! Exner at mid-layer
+  REAL,INTENT(IN) :: pkf(ijb_u:ije_u,llm) ! filtered Exner
+  REAL,INTENT(IN) :: phi(ijb_u:ije_u,llm) ! geopotential
+  REAL,INTENT(OUT) :: masse(ijb_u:ije_u,llm) ! air mass
+  REAL,INTENT(OUT) :: dv(ijb_v:ije_v,llm) ! tendency on vcov
+  REAL,INTENT(OUT) :: du(ijb_u:ije_u,llm) ! tendency on ucov
+  REAL,INTENT(OUT) :: dteta(ijb_u:ije_u,llm) ! tenddency on teta
+  REAL,INTENT(OUT) :: dp(ijb_u:ije_u) ! tendency on ps
+  REAL,INTENT(OUT) :: w(ijb_u:ije_u,llm) ! vertical velocity
+  REAL,INTENT(OUT) :: pbaru(ijb_u:ije_u,llm) ! mass flux in the zonal direction
+  REAL,INTENT(OUT) :: pbarv(ijb_v:ije_v,llm) ! mass flux in the meridional direction
+  REAL,INTENT(IN) :: time ! current time
+
+  !   Local:
+  !   ------
+
+  INTEGER :: ij,l,ijb,ije,ierr
+
+
+  !-----------------------------------------------------------------------
+  !   Compute dynamical tendencies:
+  !--------------------------------
+
+  ! ! compute contravariant winds ucont() and vcont
+  CALL covcont_loc  ( llm    , ucov    , vcov , ucont, vcont     )
+  ! ! compute pressure p()
+  CALL pression_loc ( ip1jmp1, ap      , bp   ,  ps  , p         )
+  !ym      CALL psextbar (   ps   , psexbarxy                          )
+!$OMP BARRIER
+  ! ! compute mass in each atmospheric mesh: masse()
+  CALL massdair_loc (    p   , masse                             )
+  ! ! compute X and Y-averages of mass, massebx() and masseby()
+  CALL massbar_loc  (   masse, massebx , masseby                 )
+  ! ! compute XY-average of mass, massebxy()
+  call massbarxy_loc(   masse, massebxy                          )
+  ! ! compute mass fluxes pbaru() and pbarv()
+  CALL flumass_loc  ( massebx, masseby,vcont,ucont,pbaru,pbarv   )
+  ! ! compute dteta() , horizontal converging flux of theta
+  CALL dteta1_loc   (   teta , pbaru   , pbarv, dteta            )
+  ! ! compute convm(), horizontal converging flux of mass
+  CALL convmas1_loc  (   pbaru, pbarv   , convm                  )
+!$OMP BARRIER
+  CALL convmas2_loc  (   convm                      )
+!$OMP BARRIER
+IF (CPPKEY_DEBUGIO) THEN
+  call WriteField_u('ucont',ucont)
+  call WriteField_v('vcont',vcont)
+  call WriteField_u('p',p)
+  call WriteField_u('masse',masse)
+  call WriteField_u('massebx',massebx)
+  call WriteField_v('masseby',masseby)
+  call WriteField_v('massebxy',massebxy)
+  call WriteField_u('pbaru',pbaru)
+  call WriteField_v('pbarv',pbarv)
+  call WriteField_u('dteta',dteta)
+  call WriteField_u('convm',convm)
+END IF
+
+!$OMP BARRIER
+!$OMP MASTER
+  ijb=ij_begin
+  ije=ij_end
+  ! ! compute pressure variation due to mass convergence
+  DO ij =ijb, ije
+     dp( ij ) = convm( ij,1 ) / airesurg( ij )
+  ENDDO
+!$OMP END MASTER
+!$OMP BARRIER
+
+  ! ! compute vertical velocity w()
+  CALL vitvert_loc ( convm  , w                                )
+  ! ! compute potential vorticity vorpot()
+  CALL tourpot_loc ( vcov   , ucov  , massebxy  , vorpot       )
+  ! ! compute rotation induced du() and dv()
+  CALL dudv1_loc   ( vorpot , pbaru , pbarv     , du     , dv  )
+
+IF (CPPKEY_DEBUGIO) THEN
+  call WriteField_u('w',w)
+  call WriteField_v('vorpot',vorpot)
+  call WriteField_u('du',du)
+  call WriteField_v('dv',dv)
+END IF
+
+  ! ! compute kinetic energy ecin()
+  CALL enercin_loc ( vcov   , ucov  , vcont   , ucont  , ecin  )
+  ! ! compute Bernouilli function bern()
+  CALL bernoui_loc ( ip1jmp1, llm   , phi       , ecin   , bern)
+  ! ! compute and add du() and dv() contributions from Bernouilli and pressure
+  CALL dudv2_loc   ( teta   , pkf   , bern      , du     , dv  )
+
+IF (CPPKEY_DEBUGIO) THEN
+  call WriteField_u('ecin',ecin)
+  call WriteField_u('bern',bern)
+  call WriteField_u('du',du)
+  call WriteField_v('dv',dv)
+  call WriteField_u('pkf',pkf)
+END IF
+
+  ijb=ij_begin-iip1
+  ije=ij_end+iip1
+
+  if (pole_nord) ijb=ij_begin
+  if (pole_sud) ije=ij_end
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,llm
+     DO ij=ijb,ije
+        ang(ij,l) = ucov(ij,l) + constang(ij)
+    ENDDO
+  ENDDO
+!$OMP END DO
+
+  ! ! compute vertical advection contributions to du(), dv() and dteta()
+  CALL advect_new_loc(ang,vcov,teta,w,massebx,masseby,du,dv,dteta)
+
+  !  WARNING probleme de peridocite de dv sur les PC/linux. Pb d'arrondi
+       ! probablement. Observe sur le code compile avec pgf90 3.0-1
+  ijb=ij_begin
+  ije=ij_end
+  if (pole_sud) ije=ij_end-iip1
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l = 1, llm
+     DO ij = ijb, ije, iip1
+       IF( dv(ij,l).NE.dv(ij+iim,l) )  THEN
+      ! PRINT *,'!!!ATTENTION!!! probleme de periodicite sur vcov',
+  !    ,   ' dans caldyn'
+      ! PRINT *,' l,  ij = ', l, ij, ij+iim,dv(ij+iim,l),dv(ij,l)
+      dv(ij+iim,l) = dv(ij,l)
+      endif
+     enddo
+  enddo
+!$OMP END DO NOWAIT
+
+  ! Ehouarn: NB: output of control variables not implemented...
+
+  RETURN
+END SUBROUTINE caldyn_loc
Index: DZ6/trunk/libf/dyn3dmem/caldyn_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/caldyn_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,75 +1,0 @@
-MODULE caldyn_mod
-
-  REAL,POINTER,SAVE :: vcont(:,:)
-  REAL,POINTER,SAVE :: ucont(:,:)
-  REAL,POINTER,SAVE :: ang(:,:)
-  REAL,POINTER,SAVE :: p(:,:)
-  REAL,POINTER,SAVE :: massebx(:,:)
-  REAL,POINTER,SAVE :: masseby(:,:)
-  REAL,POINTER,SAVE :: psexbarxy(:,:)
-  REAL,POINTER,SAVE :: vorpot(:,:)
-  REAL,POINTER,SAVE :: ecin(:,:)
-  REAL,POINTER,SAVE :: bern(:,:)
-  REAL,POINTER,SAVE :: massebxy(:,:)
-  REAL,POINTER,SAVE :: convm(:,:)
-
-
-  
-CONTAINS
-
-  SUBROUTINE caldyn_allocate
-  USE bands
-  USE allocate_field_mod
-  USE parallel_lmdz
-  USE dimensions_mod
-  USE advect_new_mod,ONLY : advect_new_allocate
-  IMPLICIT NONE
-  TYPE(distrib),POINTER :: d
-
-
-    d=>distrib_caldyn
-    CALL allocate_v(vcont,llm,d)
-    CALL allocate_u(ucont,llm,d)
-    CALL allocate_u(ang,llm,d)
-    CALL allocate_u(p,llmp1,d)
-    CALL allocate_u(massebx,llm,d)
-    CALL allocate_v(masseby,llm,d)
-    CALL allocate_v(psexbarxy,llm,d)
-    CALL allocate_v(vorpot,llm,d)
-    CALL allocate_u(ecin,llm,d)
-    CALL allocate_u(bern,llm,d)
-    CALL allocate_v(massebxy,llm,d)
-    CALL allocate_u(convm,llm,d)
-    
-    CALL advect_new_allocate
-    
-  END SUBROUTINE caldyn_allocate
-  
-  SUBROUTINE caldyn_switch_caldyn(dist)
-  USE allocate_field_mod
-  USE bands
-  USE parallel_lmdz
-  USE advect_new_mod,ONLY : advect_new_switch_caldyn
-  IMPLICIT NONE
-    TYPE(distrib),INTENT(IN) :: dist
-
-    CALL switch_v(vcont,distrib_caldyn,dist)
-    CALL switch_u(ucont,distrib_caldyn,dist)
-    CALL switch_u(ang,distrib_caldyn,dist)
-    CALL switch_u(p,distrib_caldyn,dist)
-    CALL switch_u(massebx,distrib_caldyn,dist)
-    CALL switch_v(masseby,distrib_caldyn,dist)
-    CALL switch_v(psexbarxy,distrib_caldyn,dist)
-    CALL switch_v(vorpot,distrib_caldyn,dist)
-    CALL switch_u(ecin,distrib_caldyn,dist)
-    CALL switch_u(bern,distrib_caldyn,dist)
-    CALL switch_v(massebxy,distrib_caldyn,dist)
-    CALL switch_u(convm,distrib_caldyn,dist)
-    
-    CALL advect_new_switch_caldyn(dist)
-    
-  END SUBROUTINE caldyn_switch_caldyn
-  
-
-  
-END MODULE caldyn_mod  
Index: /LMDZ6/trunk/libf/dyn3dmem/caldyn_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/caldyn_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3dmem/caldyn_mod.f90	(revision 5268)
@@ -0,0 +1,75 @@
+MODULE caldyn_mod
+
+  REAL,POINTER,SAVE :: vcont(:,:)
+  REAL,POINTER,SAVE :: ucont(:,:)
+  REAL,POINTER,SAVE :: ang(:,:)
+  REAL,POINTER,SAVE :: p(:,:)
+  REAL,POINTER,SAVE :: massebx(:,:)
+  REAL,POINTER,SAVE :: masseby(:,:)
+  REAL,POINTER,SAVE :: psexbarxy(:,:)
+  REAL,POINTER,SAVE :: vorpot(:,:)
+  REAL,POINTER,SAVE :: ecin(:,:)
+  REAL,POINTER,SAVE :: bern(:,:)
+  REAL,POINTER,SAVE :: massebxy(:,:)
+  REAL,POINTER,SAVE :: convm(:,:)
+
+
+  
+CONTAINS
+
+  SUBROUTINE caldyn_allocate
+  USE bands
+  USE allocate_field_mod
+  USE parallel_lmdz
+  USE dimensions_mod
+  USE advect_new_mod,ONLY : advect_new_allocate
+  IMPLICIT NONE
+  TYPE(distrib),POINTER :: d
+
+
+    d=>distrib_caldyn
+    CALL allocate_v(vcont,llm,d)
+    CALL allocate_u(ucont,llm,d)
+    CALL allocate_u(ang,llm,d)
+    CALL allocate_u(p,llmp1,d)
+    CALL allocate_u(massebx,llm,d)
+    CALL allocate_v(masseby,llm,d)
+    CALL allocate_v(psexbarxy,llm,d)
+    CALL allocate_v(vorpot,llm,d)
+    CALL allocate_u(ecin,llm,d)
+    CALL allocate_u(bern,llm,d)
+    CALL allocate_v(massebxy,llm,d)
+    CALL allocate_u(convm,llm,d)
+    
+    CALL advect_new_allocate
+    
+  END SUBROUTINE caldyn_allocate
+  
+  SUBROUTINE caldyn_switch_caldyn(dist)
+  USE allocate_field_mod
+  USE bands
+  USE parallel_lmdz
+  USE advect_new_mod,ONLY : advect_new_switch_caldyn
+  IMPLICIT NONE
+    TYPE(distrib),INTENT(IN) :: dist
+
+    CALL switch_v(vcont,distrib_caldyn,dist)
+    CALL switch_u(ucont,distrib_caldyn,dist)
+    CALL switch_u(ang,distrib_caldyn,dist)
+    CALL switch_u(p,distrib_caldyn,dist)
+    CALL switch_u(massebx,distrib_caldyn,dist)
+    CALL switch_v(masseby,distrib_caldyn,dist)
+    CALL switch_v(psexbarxy,distrib_caldyn,dist)
+    CALL switch_v(vorpot,distrib_caldyn,dist)
+    CALL switch_u(ecin,distrib_caldyn,dist)
+    CALL switch_u(bern,distrib_caldyn,dist)
+    CALL switch_v(massebxy,distrib_caldyn,dist)
+    CALL switch_u(convm,distrib_caldyn,dist)
+    
+    CALL advect_new_switch_caldyn(dist)
+    
+  END SUBROUTINE caldyn_switch_caldyn
+  
+
+  
+END MODULE caldyn_mod  
Index: DZ6/trunk/libf/dyn3dmem/call_calfis_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/call_calfis_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,418 +1,0 @@
-!#define DEBUG_IO
-MODULE call_calfis_mod
-
-    REAL,POINTER,SAVE :: ucov(:,:)
-    REAL,POINTER,SAVE :: vcov(:,:) 
-    REAL,POINTER,SAVE :: teta(:,:) 
-    REAL,POINTER,SAVE :: masse(:,:) 
-    REAL,POINTER,SAVE :: ps(:) 
-    REAL,POINTER,SAVE :: phis(:) 
-    REAL,POINTER,SAVE :: q(:,:,:) 
-    REAL,POINTER,SAVE :: flxw(:,:) 
-
-    REAL,POINTER,SAVE :: p(:,:) 
-    REAL,POINTER,SAVE :: pks(:) 
-    REAL,POINTER,SAVE :: pk(:,:) 
-    REAL,POINTER,SAVE :: pkf(:,:) 
-    REAL,POINTER,SAVE :: phi(:,:) 
-    REAL,POINTER,SAVE :: du(:,:) 
-    REAL,POINTER,SAVE :: dv(:,:) 
-    REAL,POINTER,SAVE :: dteta(:,:) 
-    REAL,POINTER,SAVE :: dq(:,:,:) 
-    REAL,POINTER,SAVE :: dufi(:,:) 
-    REAL,POINTER,SAVE :: dvfi(:,:) 
-    REAL,POINTER,SAVE :: dtetafi(:,:) 
-    REAL,POINTER,SAVE :: dqfi(:,:,:) 
-    REAL,POINTER,SAVE :: dpfi(:) 
-   
-    
-    
-    
-    
-CONTAINS
-
-  SUBROUTINE call_calfis_allocate
-  USE bands
-  USE allocate_field_mod
-  USE parallel_lmdz
-  USE dimensions_mod
-  USE infotrac, ONLY: nqtot
-  IMPLICIT NONE
-    TYPE(distrib),POINTER :: d
-    d=>distrib_physic
-
-    CALL allocate_u(ucov,llm,d)
-    CALL allocate_v(vcov,llm,d)
-    CALL allocate_u(teta,llm,d)
-    CALL allocate_u(masse,llm,d)
-    CALL allocate_u(ps,d)
-    CALL allocate_u(phis,d)
-    CALL allocate_u(q,llm,nqtot,d)
-    CALL allocate_u(flxw,llm,d)
-    CALL allocate_u(p,llmp1,d)
-    CALL allocate_u(pks,d)
-    pks(:)=0
-    CALL allocate_u(pk,llm,d)
-    pk(:,:)=0
-    CALL allocate_u(pkf,llm,d)
-    CALL allocate_u(phi,llm,d)
-    CALL allocate_u(du,llm,d)
-    CALL allocate_v(dv,llm,d)
-    CALL allocate_u(dteta,llm,d)
-    CALL allocate_u(dq,llm,nqtot,d)
-    CALL allocate_u(dufi,llm,d)
-    CALL allocate_v(dvfi,llm,d)
-    CALL allocate_u(dtetafi,llm,d)
-    CALL allocate_u(dqfi,llm,nqtot,d)
-    CALL allocate_u(dpfi,d)
-  
-  END SUBROUTINE call_calfis_allocate
-  
-  
-  SUBROUTINE call_calfis(itau,lafin,ucov_dyn,vcov_dyn,teta_dyn,masse_dyn,ps_dyn, &
-                         phis_dyn,q_dyn,flxw_dyn)
-  USE dimensions_mod
-  use exner_hyb_loc_m, only: exner_hyb_loc
-  use exner_milieu_loc_m, only: exner_milieu_loc
-  USE parallel_lmdz
-  USE times
-  USE mod_hallo
-  USE Bands
-  USE vampir
-  USE infotrac, ONLY: nqtot
-  USE control_mod
-  USE write_field_loc
-  USE write_field
-  USE comconst_mod, ONLY: dtphys
-  USE logic_mod, ONLY: leapf, forward, ok_strato
-  USE comvert_mod, ONLY: ap, bp, pressure_exner
-  USE temps_mod, ONLY: day_ini, day_ref, jd_ref, jh_ref, start_time
-  USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_PHYS, CPPKEY_DEBUGIO
-  USE strings_mod, ONLY: int2str
-  
-  IMPLICIT NONE
-    INCLUDE "iniprint.h"
-
-    INTEGER,INTENT(IN) :: itau ! (time) iteration step number
-    LOGICAL,INTENT(IN) :: lafin ! .true. if final time step
-    REAL,INTENT(INOUT) :: ucov_dyn(ijb_u:ije_u,llm) ! covariant zonal wind
-    REAL,INTENT(INOUT) :: vcov_dyn(ijb_v:ije_v,llm) ! covariant meridional wind
-    REAL,INTENT(INOUT) :: teta_dyn(ijb_u:ije_u,llm) ! potential temperature
-    REAL,INTENT(INOUT) :: masse_dyn(ijb_u:ije_u,llm) ! air mass
-    REAL,INTENT(INOUT) :: ps_dyn(ijb_u:ije_u) ! surface pressure
-    REAL,INTENT(INOUT) :: phis_dyn(ijb_u:ije_u) ! surface geopotential
-    REAL,INTENT(INOUT) :: q_dyn(ijb_u:ije_u,llm,nqtot) ! advected tracers
-    REAL,INTENT(INOUT) :: flxw_dyn(ijb_u:ije_u,llm) ! vertical mass flux
-
-    REAL :: dufi_tmp(iip1,llm)    
-    REAL :: dvfi_tmp(iip1,llm)  
-    REAL :: dtetafi_tmp(iip1,llm)
-    REAL :: dpfi_tmp(iip1)
-    REAL :: dqfi_tmp(iip1,llm,nqtot)
-
-    REAL :: jD_cur, jH_cur
-    CHARACTER(LEN=15) :: ztit
-    TYPE(Request),SAVE :: Request_physic
-!$OMP THREADPRIVATE(Request_physic )
-    INTEGER :: ijb,ije,l,iq
-    
-    
-IF (CPPKEY_DEBUGIO) THEN
-    CALL WriteField_u('ucovfi',ucov)
-    CALL WriteField_v('vcovfi',vcov)
-    CALL WriteField_u('tetafi',teta)
-    CALL WriteField_u('pfi',p)
-    CALL WriteField_u('pkfi',pk)
-    DO iq=1,nqtot
-      CALL WriteField_u('qfi'//trim(int2str(iq)),q(:,:,iq))
-    ENDDO
-END IF
-
-!
-!     .......   Ajout   P.Le Van ( 17/04/96 )   ...........
-!
-
-
-  !$OMP MASTER
-    CALL suspend_timer(timer_caldyn)
-    IF (prt_level >= 10) THEN
-      WRITE(lunout,*) 'leapfrog_p: Entree dans la physique : Iteration No ',itau
-    ENDIF
-  !$OMP END MASTER
-   
-           jD_cur = jD_ref + day_ini - day_ref                           &
-     &        + (itau+1)/day_step
-
-           IF (planet_type .eq."generic") THEN
-              ! AS: we make jD_cur to be pday
-              jD_cur = int(day_ini + itau/day_step)
-           ENDIF
-
-           jH_cur = jH_ref + start_time +                                &
-     &              mod(itau+1,day_step)/float(day_step) 
-    if (jH_cur > 1.0 ) then
-      jD_cur = jD_cur +1.
-      jH_cur = jH_cur -1.
-    endif
-
-!   Inbterface avec les routines de phylmd (phymars ... )
-!   -----------------------------------------------------
-
-!+jld
-
-!  Diagnostique de conservation de l'energie : initialisation
- 
-!-jld
-  !$OMP BARRIER
-  !$OMP MASTER
-    CALL VTb(VThallo)
-  !$OMP END MASTER
-
-IF (CPPKEY_DEBUGIO) THEN
-    CALL WriteField_u('ucovfi',ucov)
-    CALL WriteField_v('vcovfi',vcov)
-    CALL WriteField_u('tetafi',teta)
-    CALL WriteField_u('pfi',p)
-    CALL WriteField_u('pkfi',pk)
-END IF
-    
-    CALL SetTag(Request_physic,800)
-    CALL Register_SwapField_u(ucov_dyn,ucov,distrib_physic,Request_physic,up=2,down=2)
-    CALL Register_SwapField_v(vcov_dyn,vcov,distrib_physic,Request_physic,up=2,down=2)
-    CALL Register_SwapField_u(teta_dyn,teta,distrib_physic,Request_physic,up=2,down=2)
-    CALL Register_SwapField_u(masse_dyn,masse,distrib_physic,Request_physic,up=1,down=2)
-    CALL Register_SwapField_u(ps_dyn,ps,distrib_physic,Request_physic,up=2,down=2)
-    CALL Register_SwapField_u(phis_dyn,phis,distrib_physic,Request_physic,up=2,down=2)
-    CALL Register_SwapField_u(q_dyn,q,distrib_physic,Request_physic,up=2,down=2)
-    CALL Register_SwapField_u(flxw_dyn,flxw,distrib_physic,Request_physic,up=2,down=2)
- 
-    CALL SendRequest(Request_Physic)
-  !$OMP BARRIER
-    CALL WaitRequest(Request_Physic)       
-
-  !$OMP BARRIER
-  !$OMP MASTER
-    CALL Set_Distrib(distrib_Physic)
-    CALL VTe(VThallo)
-        
-    CALL VTb(VTphysiq)
-  !$OMP END MASTER
-  !$OMP BARRIER
-
-    CALL pression_loc (  ip1jmp1, ap, bp, ps,  p      )
-
-  !$OMP BARRIER
-    CALL exner_hyb_loc(  ip1jmp1, ps, p, pks, pk, pkf )
-  !$OMP BARRIER
-    CALL geopot_loc  ( ip1jmp1, teta  , pk , pks,  phis  , phi   )
-
-
-    CALL Register_Hallo_u(p,llmp1,2,2,2,2,Request_physic)
-    CALL Register_Hallo_u(pk,llm,2,2,2,2,Request_physic)
-    CALL Register_Hallo_u(phi,llm,2,2,2,2,Request_physic)
-        
-    CALL SendRequest(Request_Physic)
-  !$OMP BARRIER
-    CALL WaitRequest(Request_Physic)
-             
-  !$OMP BARRIER
-  
-  
-IF (CPPKEY_DEBUGIO) THEN
-    CALL WriteField_u('ucovfi',ucov)
-    CALL WriteField_v('vcovfi',vcov)
-    CALL WriteField_u('tetafi',teta)
-    CALL WriteField_u('pfi',p)
-    CALL WriteField_u('pkfi',pk)
-    DO iq=1,nqtot
-      CALL WriteField_u('qfi'//trim(int2str(iq)),q(:,:,iq))
-    ENDDO
-END IF
-
-  !$OMP BARRIER
-
-IF (CPPKEY_PHYS) THEN
-    CALL calfis_loc(lafin ,jD_cur, jH_cur,                       &
-                     ucov,vcov,teta,q,masse,ps,p,pk,phis,phi ,   &
-                     du,dv,dteta,dq,                             &
-                     flxw, dufi,dvfi,dtetafi,dqfi,dpfi  )
-END IF
-    ijb=ij_begin
-    ije=ij_end  
-    IF ( .not. pole_nord) THEN
-  
-    !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-      DO l=1,llm
-        dufi_tmp(1:iip1,l)   = dufi(ijb:ijb+iim,l) 
-        dvfi_tmp(1:iip1,l)   = dvfi(ijb:ijb+iim,l)  
-        dtetafi_tmp(1:iip1,l)= dtetafi(ijb:ijb+iim,l)  
-        dqfi_tmp(1:iip1,l,:) = dqfi(ijb:ijb+iim,l,:)  
-      ENDDO
-    !$OMP END DO NOWAIT
-
-    !$OMP MASTER
-      dpfi_tmp(1:iip1)     = dpfi(ijb:ijb+iim)  
-    !$OMP END MASTER
-    
-    ENDIF ! of if ( .not. pole_nord)
-
-  !$OMP BARRIER
-  !$OMP MASTER
-    CALL Set_Distrib(distrib_Physic_bis)
-    CALL VTb(VThallo)
-  !$OMP END MASTER
-  !$OMP BARRIER
- 
-    CALL Register_Hallo_u(dufi,llm,1,0,0,1,Request_physic)
-    CALL Register_Hallo_v(dvfi,llm,1,0,0,1,Request_physic)
-    CALL Register_Hallo_u(dtetafi,llm,1,0,0,1,Request_physic)
-    CALL Register_Hallo_u(dpfi,1,1,0,0,1,Request_physic)
-
-    DO iq=1,nqtot
-      CALL Register_Hallo_u(dqfi(:,:,iq),llm,1,0,0,1,Request_physic)
-    ENDDO
-        
-    CALL SendRequest(Request_Physic)
-  !$OMP BARRIER
-    CALL WaitRequest(Request_Physic)
-             
-  !$OMP BARRIER
-  !$OMP MASTER
-    CALL VTe(VThallo)
-    CALL Set_Distrib(distrib_Physic)
-  !$OMP END MASTER
-  !$OMP BARRIER        
-    ijb=ij_begin
-    IF (.not. pole_nord) THEN
-        
-    !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-      DO l=1,llm
-        dufi(ijb:ijb+iim,l) = dufi(ijb:ijb+iim,l)+dufi_tmp(1:iip1,l)
-        dvfi(ijb:ijb+iim,l) = dvfi(ijb:ijb+iim,l)+dvfi_tmp(1:iip1,l) 
-        dtetafi(ijb:ijb+iim,l) = dtetafi(ijb:ijb+iim,l)+dtetafi_tmp(1:iip1,l)
-        dqfi(ijb:ijb+iim,l,:) = dqfi(ijb:ijb+iim,l,:) + dqfi_tmp(1:iip1,l,:)
-      ENDDO
-    !$OMP END DO NOWAIT
-
-    !$OMP MASTER
-      dpfi(ijb:ijb+iim)   = dpfi(ijb:ijb+iim)+ dpfi_tmp(1:iip1)
-    !$OMP END MASTER
-          
-    endif ! of if (.not. pole_nord)
-        
-        
-IF (CPPKEY_DEBUGIO) THEN
-    CALL WriteField_u('dufi',dufi)
-    CALL WriteField_v('dvfi',dvfi)
-    CALL WriteField_u('dtetafi',dtetafi)
-    CALL WriteField_u('dpfi',dpfi)
-    DO iq=1,nqtot
-      CALL WriteField_u('dqfi'//trim(int2str(iq)),dqfi(:,:,iq))
-    ENDDO
-END IF
-
-  !$OMP BARRIER
-
-!      ajout des tendances physiques:
-!      ------------------------------
-IF (CPPKEY_DEBUGIO) THEN
-    CALL WriteField_u('ucovfi',ucov)
-    CALL WriteField_v('vcovfi',vcov)
-    CALL WriteField_u('tetafi',teta)
-    CALL WriteField_u('psfi',ps)
-    DO iq=1,nqtot
-      CALL WriteField_u('qfi'//trim(int2str(iq)),q(:,:,iq))
-    ENDDO
-END IF
-
-IF (CPPKEY_DEBUGIO) THEN
-    CALL WriteField_u('ucovfi',ucov)
-    CALL WriteField_v('vcovfi',vcov)
-    CALL WriteField_u('tetafi',teta)
-    CALL WriteField_u('psfi',ps)
-    DO iq=1,nqtot
-      CALL WriteField_u('qfi'//trim(int2str(iq)),q(:,:,iq))
-    ENDDO
-END IF
-
-    CALL addfi_loc( dtphys, leapf, forward   ,              &
-                    ucov, vcov, teta , q   ,ps ,            &
-                    dufi, dvfi, dtetafi , dqfi ,dpfi  )
-    ! since addfi updates ps(), also update p(), masse() and pk()
-    CALL pression_loc(ip1jmp1,ap,bp,ps,p)
-!$OMP BARRIER
-    CALL massdair_loc(p,masse)
-!$OMP BARRIER
-    if (pressure_exner) then
-      CALL exner_hyb_loc(ijnb_u,ps,p,pks,pk,pkf)
-    else 
-      CALL exner_milieu_loc(ijnb_u,ps,p,pks,pk,pkf)
-    endif
-!$OMP BARRIER
-
-IF (CPPKEY_DEBUGIO) THEN
-    CALL WriteField_u('ucovfi',ucov)
-    CALL WriteField_v('vcovfi',vcov)
-    CALL WriteField_u('tetafi',teta)
-    CALL WriteField_u('psfi',ps)
-    DO iq=1,nqtot
-      CALL WriteField_u('qfi'//trim(int2str(iq)),q(:,:,iq))
-    ENDDO
-END IF
-
-    IF (ok_strato) THEN
-!      CALL top_bound_loc( vcov,ucov,teta,masse,dufi,dvfi,dtetafi)
-      CALL top_bound_loc(vcov,ucov,teta,masse,dtphys)
-    ENDIF
-
-  !$OMP BARRIER
-  !$OMP MASTER
-    CALL VTe(VTphysiq)
-    CALL VTb(VThallo)
-  !$OMP END MASTER
-
-    CALL SetTag(Request_physic,800)
-    CALL Register_SwapField_u(ucov,ucov_dyn,distrib_caldyn,Request_physic)
-    CALL Register_SwapField_v(vcov,vcov_dyn,distrib_caldyn,Request_physic)
-    CALL Register_SwapField_u(teta,teta_dyn,distrib_caldyn,Request_physic)
-    CALL Register_SwapField_u(masse,masse_dyn,distrib_caldyn,Request_physic)
-    CALL Register_SwapField_u(ps,ps_dyn,distrib_caldyn,Request_physic)
-    CALL Register_SwapField_u(q,q_dyn,distrib_caldyn,Request_physic)
-    CALL SendRequest(Request_Physic)
-  !$OMP BARRIER
-    CALL WaitRequest(Request_Physic)     
-
-  !$OMP BARRIER
-  !$OMP MASTER
-    CALL VTe(VThallo)
-    CALL set_distrib(distrib_caldyn)
-  !$OMP END MASTER
-  !$OMP BARRIER
-
-!
-!  Diagnostique de conservation de l'energie : difference
-    IF (ip_ebil_dyn.ge.1 ) THEN 
-      ztit='bil phys'
-!      CALL diagedyn(ztit,2,1,1,dtphys,ucov, vcov , ps, p ,pk , teta , q(:,:,1), q(:,:,2))
-      write(lunout,*)"call_calfis: diagedyn disabled in dyn3dmem !!"
-    ENDIF 
-
-IF (CPPKEY_DEBUGIO) THEN
-    CALL WriteField_u('ucovfi',ucov_dyn)
-    CALL WriteField_v('vcovfi',vcov_dyn)
-    CALL WriteField_u('tetafi',teta_dyn)
-    CALL WriteField_u('psfi',ps_dyn)
-    DO iq=1,nqtot
-      CALL WriteField_u('qfi'//trim(int2str(iq)),q_dyn(:,:,iq))
-    ENDDO
-END IF
-
-
-!-jld
-    !$OMP MASTER
-      CALL resume_timer(timer_caldyn)
-    !$OMP END MASTER
-
-  END SUBROUTINE call_calfis
-  
-END MODULE call_calfis_mod
Index: /LMDZ6/trunk/libf/dyn3dmem/call_calfis_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/call_calfis_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3dmem/call_calfis_mod.f90	(revision 5268)
@@ -0,0 +1,418 @@
+!#define DEBUG_IO
+MODULE call_calfis_mod
+
+    REAL,POINTER,SAVE :: ucov(:,:)
+    REAL,POINTER,SAVE :: vcov(:,:) 
+    REAL,POINTER,SAVE :: teta(:,:) 
+    REAL,POINTER,SAVE :: masse(:,:) 
+    REAL,POINTER,SAVE :: ps(:) 
+    REAL,POINTER,SAVE :: phis(:) 
+    REAL,POINTER,SAVE :: q(:,:,:) 
+    REAL,POINTER,SAVE :: flxw(:,:) 
+
+    REAL,POINTER,SAVE :: p(:,:) 
+    REAL,POINTER,SAVE :: pks(:) 
+    REAL,POINTER,SAVE :: pk(:,:) 
+    REAL,POINTER,SAVE :: pkf(:,:) 
+    REAL,POINTER,SAVE :: phi(:,:) 
+    REAL,POINTER,SAVE :: du(:,:) 
+    REAL,POINTER,SAVE :: dv(:,:) 
+    REAL,POINTER,SAVE :: dteta(:,:) 
+    REAL,POINTER,SAVE :: dq(:,:,:) 
+    REAL,POINTER,SAVE :: dufi(:,:) 
+    REAL,POINTER,SAVE :: dvfi(:,:) 
+    REAL,POINTER,SAVE :: dtetafi(:,:) 
+    REAL,POINTER,SAVE :: dqfi(:,:,:) 
+    REAL,POINTER,SAVE :: dpfi(:) 
+   
+    
+    
+    
+    
+CONTAINS
+
+  SUBROUTINE call_calfis_allocate
+  USE bands
+  USE allocate_field_mod
+  USE parallel_lmdz
+  USE dimensions_mod
+  USE infotrac, ONLY: nqtot
+  IMPLICIT NONE
+    TYPE(distrib),POINTER :: d
+    d=>distrib_physic
+
+    CALL allocate_u(ucov,llm,d)
+    CALL allocate_v(vcov,llm,d)
+    CALL allocate_u(teta,llm,d)
+    CALL allocate_u(masse,llm,d)
+    CALL allocate_u(ps,d)
+    CALL allocate_u(phis,d)
+    CALL allocate_u(q,llm,nqtot,d)
+    CALL allocate_u(flxw,llm,d)
+    CALL allocate_u(p,llmp1,d)
+    CALL allocate_u(pks,d)
+    pks(:)=0
+    CALL allocate_u(pk,llm,d)
+    pk(:,:)=0
+    CALL allocate_u(pkf,llm,d)
+    CALL allocate_u(phi,llm,d)
+    CALL allocate_u(du,llm,d)
+    CALL allocate_v(dv,llm,d)
+    CALL allocate_u(dteta,llm,d)
+    CALL allocate_u(dq,llm,nqtot,d)
+    CALL allocate_u(dufi,llm,d)
+    CALL allocate_v(dvfi,llm,d)
+    CALL allocate_u(dtetafi,llm,d)
+    CALL allocate_u(dqfi,llm,nqtot,d)
+    CALL allocate_u(dpfi,d)
+  
+  END SUBROUTINE call_calfis_allocate
+  
+  
+  SUBROUTINE call_calfis(itau,lafin,ucov_dyn,vcov_dyn,teta_dyn,masse_dyn,ps_dyn, &
+                         phis_dyn,q_dyn,flxw_dyn)
+  USE dimensions_mod
+  use exner_hyb_loc_m, only: exner_hyb_loc
+  use exner_milieu_loc_m, only: exner_milieu_loc
+  USE parallel_lmdz
+  USE times
+  USE mod_hallo
+  USE Bands
+  USE vampir
+  USE infotrac, ONLY: nqtot
+  USE control_mod
+  USE write_field_loc
+  USE write_field
+  USE comconst_mod, ONLY: dtphys
+  USE logic_mod, ONLY: leapf, forward, ok_strato
+  USE comvert_mod, ONLY: ap, bp, pressure_exner
+  USE temps_mod, ONLY: day_ini, day_ref, jd_ref, jh_ref, start_time
+  USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_PHYS, CPPKEY_DEBUGIO
+  USE strings_mod, ONLY: int2str
+  
+  IMPLICIT NONE
+    INCLUDE "iniprint.h"
+
+    INTEGER,INTENT(IN) :: itau ! (time) iteration step number
+    LOGICAL,INTENT(IN) :: lafin ! .true. if final time step
+    REAL,INTENT(INOUT) :: ucov_dyn(ijb_u:ije_u,llm) ! covariant zonal wind
+    REAL,INTENT(INOUT) :: vcov_dyn(ijb_v:ije_v,llm) ! covariant meridional wind
+    REAL,INTENT(INOUT) :: teta_dyn(ijb_u:ije_u,llm) ! potential temperature
+    REAL,INTENT(INOUT) :: masse_dyn(ijb_u:ije_u,llm) ! air mass
+    REAL,INTENT(INOUT) :: ps_dyn(ijb_u:ije_u) ! surface pressure
+    REAL,INTENT(INOUT) :: phis_dyn(ijb_u:ije_u) ! surface geopotential
+    REAL,INTENT(INOUT) :: q_dyn(ijb_u:ije_u,llm,nqtot) ! advected tracers
+    REAL,INTENT(INOUT) :: flxw_dyn(ijb_u:ije_u,llm) ! vertical mass flux
+
+    REAL :: dufi_tmp(iip1,llm)    
+    REAL :: dvfi_tmp(iip1,llm)  
+    REAL :: dtetafi_tmp(iip1,llm)
+    REAL :: dpfi_tmp(iip1)
+    REAL :: dqfi_tmp(iip1,llm,nqtot)
+
+    REAL :: jD_cur, jH_cur
+    CHARACTER(LEN=15) :: ztit
+    TYPE(Request),SAVE :: Request_physic
+!$OMP THREADPRIVATE(Request_physic )
+    INTEGER :: ijb,ije,l,iq
+    
+    
+IF (CPPKEY_DEBUGIO) THEN
+    CALL WriteField_u('ucovfi',ucov)
+    CALL WriteField_v('vcovfi',vcov)
+    CALL WriteField_u('tetafi',teta)
+    CALL WriteField_u('pfi',p)
+    CALL WriteField_u('pkfi',pk)
+    DO iq=1,nqtot
+      CALL WriteField_u('qfi'//trim(int2str(iq)),q(:,:,iq))
+    ENDDO
+END IF
+
+!
+!     .......   Ajout   P.Le Van ( 17/04/96 )   ...........
+!
+
+
+  !$OMP MASTER
+    CALL suspend_timer(timer_caldyn)
+    IF (prt_level >= 10) THEN
+      WRITE(lunout,*) 'leapfrog_p: Entree dans la physique : Iteration No ',itau
+    ENDIF
+  !$OMP END MASTER
+   
+           jD_cur = jD_ref + day_ini - day_ref                           &
+     &        + (itau+1)/day_step
+
+           IF (planet_type .eq."generic") THEN
+              ! AS: we make jD_cur to be pday
+              jD_cur = int(day_ini + itau/day_step)
+           ENDIF
+
+           jH_cur = jH_ref + start_time +                                &
+     &              mod(itau+1,day_step)/float(day_step) 
+    if (jH_cur > 1.0 ) then
+      jD_cur = jD_cur +1.
+      jH_cur = jH_cur -1.
+    endif
+
+!   Inbterface avec les routines de phylmd (phymars ... )
+!   -----------------------------------------------------
+
+!+jld
+
+!  Diagnostique de conservation de l'energie : initialisation
+ 
+!-jld
+  !$OMP BARRIER
+  !$OMP MASTER
+    CALL VTb(VThallo)
+  !$OMP END MASTER
+
+IF (CPPKEY_DEBUGIO) THEN
+    CALL WriteField_u('ucovfi',ucov)
+    CALL WriteField_v('vcovfi',vcov)
+    CALL WriteField_u('tetafi',teta)
+    CALL WriteField_u('pfi',p)
+    CALL WriteField_u('pkfi',pk)
+END IF
+    
+    CALL SetTag(Request_physic,800)
+    CALL Register_SwapField_u(ucov_dyn,ucov,distrib_physic,Request_physic,up=2,down=2)
+    CALL Register_SwapField_v(vcov_dyn,vcov,distrib_physic,Request_physic,up=2,down=2)
+    CALL Register_SwapField_u(teta_dyn,teta,distrib_physic,Request_physic,up=2,down=2)
+    CALL Register_SwapField_u(masse_dyn,masse,distrib_physic,Request_physic,up=1,down=2)
+    CALL Register_SwapField_u(ps_dyn,ps,distrib_physic,Request_physic,up=2,down=2)
+    CALL Register_SwapField_u(phis_dyn,phis,distrib_physic,Request_physic,up=2,down=2)
+    CALL Register_SwapField_u(q_dyn,q,distrib_physic,Request_physic,up=2,down=2)
+    CALL Register_SwapField_u(flxw_dyn,flxw,distrib_physic,Request_physic,up=2,down=2)
+ 
+    CALL SendRequest(Request_Physic)
+  !$OMP BARRIER
+    CALL WaitRequest(Request_Physic)       
+
+  !$OMP BARRIER
+  !$OMP MASTER
+    CALL Set_Distrib(distrib_Physic)
+    CALL VTe(VThallo)
+        
+    CALL VTb(VTphysiq)
+  !$OMP END MASTER
+  !$OMP BARRIER
+
+    CALL pression_loc (  ip1jmp1, ap, bp, ps,  p      )
+
+  !$OMP BARRIER
+    CALL exner_hyb_loc(  ip1jmp1, ps, p, pks, pk, pkf )
+  !$OMP BARRIER
+    CALL geopot_loc  ( ip1jmp1, teta  , pk , pks,  phis  , phi   )
+
+
+    CALL Register_Hallo_u(p,llmp1,2,2,2,2,Request_physic)
+    CALL Register_Hallo_u(pk,llm,2,2,2,2,Request_physic)
+    CALL Register_Hallo_u(phi,llm,2,2,2,2,Request_physic)
+        
+    CALL SendRequest(Request_Physic)
+  !$OMP BARRIER
+    CALL WaitRequest(Request_Physic)
+             
+  !$OMP BARRIER
+  
+  
+IF (CPPKEY_DEBUGIO) THEN
+    CALL WriteField_u('ucovfi',ucov)
+    CALL WriteField_v('vcovfi',vcov)
+    CALL WriteField_u('tetafi',teta)
+    CALL WriteField_u('pfi',p)
+    CALL WriteField_u('pkfi',pk)
+    DO iq=1,nqtot
+      CALL WriteField_u('qfi'//trim(int2str(iq)),q(:,:,iq))
+    ENDDO
+END IF
+
+  !$OMP BARRIER
+
+IF (CPPKEY_PHYS) THEN
+    CALL calfis_loc(lafin ,jD_cur, jH_cur,                       &
+                     ucov,vcov,teta,q,masse,ps,p,pk,phis,phi ,   &
+                     du,dv,dteta,dq,                             &
+                     flxw, dufi,dvfi,dtetafi,dqfi,dpfi  )
+END IF
+    ijb=ij_begin
+    ije=ij_end  
+    IF ( .not. pole_nord) THEN
+  
+    !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,llm
+        dufi_tmp(1:iip1,l)   = dufi(ijb:ijb+iim,l) 
+        dvfi_tmp(1:iip1,l)   = dvfi(ijb:ijb+iim,l)  
+        dtetafi_tmp(1:iip1,l)= dtetafi(ijb:ijb+iim,l)  
+        dqfi_tmp(1:iip1,l,:) = dqfi(ijb:ijb+iim,l,:)  
+      ENDDO
+    !$OMP END DO NOWAIT
+
+    !$OMP MASTER
+      dpfi_tmp(1:iip1)     = dpfi(ijb:ijb+iim)  
+    !$OMP END MASTER
+    
+    ENDIF ! of if ( .not. pole_nord)
+
+  !$OMP BARRIER
+  !$OMP MASTER
+    CALL Set_Distrib(distrib_Physic_bis)
+    CALL VTb(VThallo)
+  !$OMP END MASTER
+  !$OMP BARRIER
+ 
+    CALL Register_Hallo_u(dufi,llm,1,0,0,1,Request_physic)
+    CALL Register_Hallo_v(dvfi,llm,1,0,0,1,Request_physic)
+    CALL Register_Hallo_u(dtetafi,llm,1,0,0,1,Request_physic)
+    CALL Register_Hallo_u(dpfi,1,1,0,0,1,Request_physic)
+
+    DO iq=1,nqtot
+      CALL Register_Hallo_u(dqfi(:,:,iq),llm,1,0,0,1,Request_physic)
+    ENDDO
+        
+    CALL SendRequest(Request_Physic)
+  !$OMP BARRIER
+    CALL WaitRequest(Request_Physic)
+             
+  !$OMP BARRIER
+  !$OMP MASTER
+    CALL VTe(VThallo)
+    CALL Set_Distrib(distrib_Physic)
+  !$OMP END MASTER
+  !$OMP BARRIER        
+    ijb=ij_begin
+    IF (.not. pole_nord) THEN
+        
+    !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,llm
+        dufi(ijb:ijb+iim,l) = dufi(ijb:ijb+iim,l)+dufi_tmp(1:iip1,l)
+        dvfi(ijb:ijb+iim,l) = dvfi(ijb:ijb+iim,l)+dvfi_tmp(1:iip1,l) 
+        dtetafi(ijb:ijb+iim,l) = dtetafi(ijb:ijb+iim,l)+dtetafi_tmp(1:iip1,l)
+        dqfi(ijb:ijb+iim,l,:) = dqfi(ijb:ijb+iim,l,:) + dqfi_tmp(1:iip1,l,:)
+      ENDDO
+    !$OMP END DO NOWAIT
+
+    !$OMP MASTER
+      dpfi(ijb:ijb+iim)   = dpfi(ijb:ijb+iim)+ dpfi_tmp(1:iip1)
+    !$OMP END MASTER
+          
+    endif ! of if (.not. pole_nord)
+        
+        
+IF (CPPKEY_DEBUGIO) THEN
+    CALL WriteField_u('dufi',dufi)
+    CALL WriteField_v('dvfi',dvfi)
+    CALL WriteField_u('dtetafi',dtetafi)
+    CALL WriteField_u('dpfi',dpfi)
+    DO iq=1,nqtot
+      CALL WriteField_u('dqfi'//trim(int2str(iq)),dqfi(:,:,iq))
+    ENDDO
+END IF
+
+  !$OMP BARRIER
+
+!      ajout des tendances physiques:
+!      ------------------------------
+IF (CPPKEY_DEBUGIO) THEN
+    CALL WriteField_u('ucovfi',ucov)
+    CALL WriteField_v('vcovfi',vcov)
+    CALL WriteField_u('tetafi',teta)
+    CALL WriteField_u('psfi',ps)
+    DO iq=1,nqtot
+      CALL WriteField_u('qfi'//trim(int2str(iq)),q(:,:,iq))
+    ENDDO
+END IF
+
+IF (CPPKEY_DEBUGIO) THEN
+    CALL WriteField_u('ucovfi',ucov)
+    CALL WriteField_v('vcovfi',vcov)
+    CALL WriteField_u('tetafi',teta)
+    CALL WriteField_u('psfi',ps)
+    DO iq=1,nqtot
+      CALL WriteField_u('qfi'//trim(int2str(iq)),q(:,:,iq))
+    ENDDO
+END IF
+
+    CALL addfi_loc( dtphys, leapf, forward   ,              &
+                    ucov, vcov, teta , q   ,ps ,            &
+                    dufi, dvfi, dtetafi , dqfi ,dpfi  )
+    ! since addfi updates ps(), also update p(), masse() and pk()
+    CALL pression_loc(ip1jmp1,ap,bp,ps,p)
+!$OMP BARRIER
+    CALL massdair_loc(p,masse)
+!$OMP BARRIER
+    if (pressure_exner) then
+      CALL exner_hyb_loc(ijnb_u,ps,p,pks,pk,pkf)
+    else 
+      CALL exner_milieu_loc(ijnb_u,ps,p,pks,pk,pkf)
+    endif
+!$OMP BARRIER
+
+IF (CPPKEY_DEBUGIO) THEN
+    CALL WriteField_u('ucovfi',ucov)
+    CALL WriteField_v('vcovfi',vcov)
+    CALL WriteField_u('tetafi',teta)
+    CALL WriteField_u('psfi',ps)
+    DO iq=1,nqtot
+      CALL WriteField_u('qfi'//trim(int2str(iq)),q(:,:,iq))
+    ENDDO
+END IF
+
+    IF (ok_strato) THEN
+!      CALL top_bound_loc( vcov,ucov,teta,masse,dufi,dvfi,dtetafi)
+      CALL top_bound_loc(vcov,ucov,teta,masse,dtphys)
+    ENDIF
+
+  !$OMP BARRIER
+  !$OMP MASTER
+    CALL VTe(VTphysiq)
+    CALL VTb(VThallo)
+  !$OMP END MASTER
+
+    CALL SetTag(Request_physic,800)
+    CALL Register_SwapField_u(ucov,ucov_dyn,distrib_caldyn,Request_physic)
+    CALL Register_SwapField_v(vcov,vcov_dyn,distrib_caldyn,Request_physic)
+    CALL Register_SwapField_u(teta,teta_dyn,distrib_caldyn,Request_physic)
+    CALL Register_SwapField_u(masse,masse_dyn,distrib_caldyn,Request_physic)
+    CALL Register_SwapField_u(ps,ps_dyn,distrib_caldyn,Request_physic)
+    CALL Register_SwapField_u(q,q_dyn,distrib_caldyn,Request_physic)
+    CALL SendRequest(Request_Physic)
+  !$OMP BARRIER
+    CALL WaitRequest(Request_Physic)     
+
+  !$OMP BARRIER
+  !$OMP MASTER
+    CALL VTe(VThallo)
+    CALL set_distrib(distrib_caldyn)
+  !$OMP END MASTER
+  !$OMP BARRIER
+
+!
+!  Diagnostique de conservation de l'energie : difference
+    IF (ip_ebil_dyn.ge.1 ) THEN 
+      ztit='bil phys'
+!      CALL diagedyn(ztit,2,1,1,dtphys,ucov, vcov , ps, p ,pk , teta , q(:,:,1), q(:,:,2))
+      write(lunout,*)"call_calfis: diagedyn disabled in dyn3dmem !!"
+    ENDIF 
+
+IF (CPPKEY_DEBUGIO) THEN
+    CALL WriteField_u('ucovfi',ucov_dyn)
+    CALL WriteField_v('vcovfi',vcov_dyn)
+    CALL WriteField_u('tetafi',teta_dyn)
+    CALL WriteField_u('psfi',ps_dyn)
+    DO iq=1,nqtot
+      CALL WriteField_u('qfi'//trim(int2str(iq)),q_dyn(:,:,iq))
+    ENDDO
+END IF
+
+
+!-jld
+    !$OMP MASTER
+      CALL resume_timer(timer_caldyn)
+    !$OMP END MASTER
+
+  END SUBROUTINE call_calfis
+  
+END MODULE call_calfis_mod
Index: DZ6/trunk/libf/dyn3dmem/call_dissip_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/call_dissip_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,326 +1,0 @@
-MODULE call_dissip_mod
-
-    REAL,POINTER,SAVE :: ucov(:,:)
-    REAL,POINTER,SAVE :: vcov(:,:)
-    REAL,POINTER,SAVE :: teta(:,:)
-    REAL,POINTER,SAVE :: p(:,: )
-    REAL,POINTER,SAVE :: pk(:,:)
-
-    REAL,POINTER,SAVE :: ucont(:,:)
-    REAL,POINTER,SAVE :: vcont(:,:)
-    REAL,POINTER,SAVE :: ecin(:,:)
-    REAL,POINTER,SAVE :: ecin0(:,:)
-    REAL,POINTER,SAVE :: dudis(:,:)
-    REAL,POINTER,SAVE :: dvdis(:,:)
-    REAL,POINTER,SAVE :: dtetadis(:,:)
-    REAL,POINTER,SAVE :: dtetaecdt(:,:)
-
-
-
-CONTAINS
-  
-  SUBROUTINE call_dissip_allocate
-  USE bands
-  USE allocate_field_mod
-  USE parallel_lmdz
-  USE dimensions_mod
-  USE dissip_mod, ONLY : dissip_allocate
-  IMPLICIT NONE
-    TYPE(distrib),POINTER :: d
-    d=>distrib_dissip
-
-    CALL allocate_u(ucov,llm,d)
-    ucov(:,:)=0
-    CALL allocate_v(vcov,llm,d)
-    vcov(:,:)=0
-    CALL allocate_u(teta,llm,d)
-    CALL allocate_u(p,llmp1,d)
-    CALL allocate_u(pk,llm,d)
-    CALL allocate_u(ucont,llm,d)
-    CALL allocate_v(vcont,llm,d)
-    CALL allocate_u(ecin,llm,d)
-    CALL allocate_u(ecin0,llm,d)
-    CALL allocate_u(dudis,llm,d)
-    CALL allocate_v(dvdis,llm,d)
-    CALL allocate_u(dtetadis,llm,d)
-    CALL allocate_u(dtetaecdt,llm,d)
-    
-    
-    CALL dissip_allocate
-    
-  END SUBROUTINE call_dissip_allocate
-  
-  SUBROUTINE call_dissip_switch_dissip(dist)
-  USE allocate_field_mod
-  USE bands
-  USE parallel_lmdz
-  USE dissip_mod, ONLY : dissip_switch_dissip
-  IMPLICIT NONE
-    TYPE(distrib),INTENT(IN) :: dist
-
-    CALL switch_u(ucov,distrib_dissip,dist)
-    CALL switch_v(vcov,distrib_dissip,dist)
-    CALL switch_u(teta,distrib_dissip,dist)
-    CALL switch_u(p,distrib_dissip,dist)
-    CALL switch_u(pk,distrib_dissip,dist)
-    CALL switch_u(ucont,distrib_dissip,dist)
-    CALL switch_v(vcont,distrib_dissip,dist)
-    CALL switch_u(ecin,distrib_dissip,dist)
-    CALL switch_u(ecin0,distrib_dissip,dist)
-    CALL switch_u(dudis,distrib_dissip,dist)
-    CALL switch_v(dvdis,distrib_dissip,dist)
-    CALL switch_u(dtetadis,distrib_dissip,dist)
-    CALL switch_u(dtetaecdt,distrib_dissip,dist)
-
-    CALL dissip_switch_dissip(dist)
-    
-  END SUBROUTINE call_dissip_switch_dissip  
-  
-
-  
-  SUBROUTINE call_dissip(ucov_dyn,vcov_dyn,teta_dyn,p_dyn,pk_dyn,ps_dyn)
-  USE dimensions_mod
-  USE parallel_lmdz
-  USE times
-  USE mod_hallo
-  USE Bands
-  USE vampir
-  USE write_field_loc
-  USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_DEBUGIO
-  IMPLICIT NONE
-    INCLUDE 'comgeom.h'
-    REAL,INTENT(INOUT) :: ucov_dyn(ijb_u:ije_u,llm) ! covariant zonal wind
-    REAL,INTENT(INOUT) :: vcov_dyn(ijb_v:ije_v,llm) ! covariant meridional wind
-    REAL,INTENT(INOUT) :: teta_dyn(ijb_u:ije_u,llm) ! covariant meridional wind
-    REAL,INTENT(INOUT) :: p_dyn(ijb_u:ije_u,llmp1 ) ! pressure at interlayer
-    REAL,INTENT(INOUT) :: pk_dyn(ijb_u:ije_u,llm) ! Exner at midlayer
-    REAL,INTENT(INOUT) :: ps_dyn(ijb_u:ije_u) ! surface pressure
-    REAL :: tppn(iim),tpps(iim)
-    REAL :: tpn,tps
-
-    REAL  SSUM
-    LOGICAL,PARAMETER :: dissip_conservative=.TRUE.
-    TYPE(Request),SAVE :: Request_dissip 
-!$OMP THREADPRIVATE(Request_dissip )    
-    INTEGER :: ij,l,ijb,ije 
-  
-    
-  !$OMP MASTER
-    CALL suspend_timer(timer_caldyn)
-        
-!       print*,'Entree dans la dissipation : Iteration No ',true_itau
-!   calcul de l'energie cinetique avant dissipation
-!       print *,'Passage dans la dissipation'
-
-    CALL VTb(VThallo)
-  !$OMP END MASTER
-
-  !$OMP BARRIER
-
-    CALL Register_SwapField_u(ucov_dyn,ucov,distrib_dissip, Request_dissip,up=1,down=1)
-    CALL Register_SwapField_v(vcov_dyn,vcov,distrib_dissip, Request_dissip,up=1,down=1)
-    CALL Register_SwapField_u(teta_dyn,teta,distrib_dissip, Request_dissip)
-    CALL Register_SwapField_u(p_dyn,p,distrib_dissip,Request_dissip)
-    CALL Register_SwapField_u(pk_dyn,pk,distrib_dissip,Request_dissip)
-
-    CALL SendRequest(Request_dissip)       
-  !$OMP BARRIER
-    CALL WaitRequest(Request_dissip)       
-
-  !$OMP BARRIER
-  !$OMP MASTER
-    CALL set_distrib(distrib_dissip)
-    CALL VTe(VThallo)
-    CALL VTb(VTdissipation)
-    CALL start_timer(timer_dissip)
-  !$OMP END MASTER
-  !$OMP BARRIER
-
-    CALL covcont_loc(llm,ucov,vcov,ucont,vcont)
-    CALL enercin_loc(vcov,ucov,vcont,ucont,ecin0)
-
-!   dissipation
-
-!        CALL FTRACE_REGION_BEGIN("dissip")
-    CALL dissip_loc(vcov,ucov,teta,p,dvdis,dudis,dtetadis)
-
-IF (CPPKEY_DEBUGIO) THEN
-    CALL WriteField_u('dudis',dudis)
-    CALL WriteField_v('dvdis',dvdis)
-    CALL WriteField_u('dtetadis',dtetadis)
-END IF
- 
-!      CALL FTRACE_REGION_END("dissip")
-         
-    ijb=ij_begin
-    ije=ij_end
-  !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)        
-    DO l=1,llm
-      ucov(ijb:ije,l)=ucov(ijb:ije,l)+dudis(ijb:ije,l)
-    ENDDO
-  !$OMP END DO NOWAIT        
-
-    IF (pole_sud) ije=ije-iip1
-   
-  !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)        
-    DO l=1,llm
-      vcov(ijb:ije,l)=vcov(ijb:ije,l)+dvdis(ijb:ije,l)
-    ENDDO
-  !$OMP END DO NOWAIT        
-
-!       teta=teta+dtetadis
-
-
-!------------------------------------------------------------------------
-    IF (dissip_conservative) THEN
-!       On rajoute la tendance due a la transform. Ec -> E therm. cree
-!       lors de la dissipation
-    !$OMP BARRIER
-    !$OMP MASTER
-      CALL suspend_timer(timer_dissip)
-      CALL VTb(VThallo)
-    !$OMP END MASTER
-      CALL Register_Hallo_u(ucov,llm,1,1,1,1,Request_Dissip)
-      CALL Register_Hallo_v(vcov,llm,1,1,1,1,Request_Dissip)
-      CALL SendRequest(Request_Dissip)
-    !$OMP BARRIER
-      CALL WaitRequest(Request_Dissip)
-    !$OMP MASTER
-      CALL VTe(VThallo)
-      CALL resume_timer(timer_dissip)
-    !$OMP END MASTER
-    !$OMP BARRIER            
-      CALL covcont_loc(llm,ucov,vcov,ucont,vcont)
-      CALL enercin_loc(vcov,ucov,vcont,ucont,ecin)
-            
-      ijb=ij_begin
-      ije=ij_end
-    !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)            
-      DO l=1,llm
-        DO ij=ijb,ije
-           dtetaecdt(ij,l)= (ecin0(ij,l)-ecin(ij,l))/ pk(ij,l)
-           dtetadis(ij,l)=dtetadis(ij,l)+dtetaecdt(ij,l)
-        ENDDO
-      ENDDO
-    !$OMP END DO NOWAIT            
-
-    ENDIF
-
-    ijb=ij_begin
-    ije=ij_end
-
-  !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)            
-    DO l=1,llm
-      DO ij=ijb,ije
-         teta(ij,l)=teta(ij,l)+dtetadis(ij,l)
-      ENDDO
-    ENDDO
-  !$OMP END DO NOWAIT         
-
-!------------------------------------------------------------------------
-
-
-!    .......        P. Le Van (  ajout  le 17/04/96  )   ...........
-!   ...      Calcul de la valeur moyenne, unique de h aux poles  .....
-!
-
-    ijb=ij_begin
-    ije=ij_end
-         
-    IF (pole_nord) THEN
-  
-   !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-      DO l  =  1, llm
-        DO ij =  1,iim
-          tppn(ij)  = aire(  ij    ) * teta(  ij    ,l)
-        ENDDO
-        tpn  = SSUM(iim,tppn,1)/apoln
-
-        DO ij = 1, iip1
-          teta(  ij    ,l) = tpn
-        ENDDO
-      ENDDO
-    !$OMP END DO NOWAIT
-
-         if (1 == 0) then
-!!! Ehouarn: lines here 1) kill 1+1=2 in the dynamics
-!!!                     2) should probably not be here anyway
-!!! but are kept for those who would want to revert to previous behaviour
-    !$OMP MASTER               
-      DO ij =  1,iim
-        tppn(ij)  = aire(  ij    ) * ps_dyn (  ij    )
-      ENDDO
-      tpn  = SSUM(iim,tppn,1)/apoln
-  
-      DO ij = 1, iip1
-        ps_dyn(  ij    ) = tpn
-      ENDDO
-    !$OMP END MASTER
-    
-    ENDIF ! of if (1 == 0)
-    endif ! of of (pole_nord)
-        
-    IF (pole_sud) THEN
-
-    !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-      DO l  =  1, llm
-        DO ij =  1,iim
-          tpps(ij)  = aire(ij+ip1jm) * teta(ij+ip1jm,l)
-        ENDDO
-        
-        tps  = SSUM(iim,tpps,1)/apols
-
-        DO ij = 1, iip1
-          teta(ij+ip1jm,l) = tps
-        ENDDO
-      ENDDO
-    !$OMP END DO NOWAIT
-
-    if (1 == 0) then
-!!! Ehouarn: lines here 1) kill 1+1=2 in the dynamics
-!!!                     2) should probably not be here anyway
-!!! but are kept for those who would want to revert to previous behaviour
-    !$OMP MASTER               
-      DO ij =  1,iim
-        tpps(ij)  = aire(ij+ip1jm) * ps_dyn (ij+ip1jm)
-      ENDDO
-      tps  = SSUM(iim,tpps,1)/apols
-  
-      DO ij = 1, iip1
-        ps_dyn(ij+ip1jm) = tps
-      ENDDO
-    !$OMP END MASTER
-    ENDIF ! of if (1 == 0)
-    endif ! of if (pole_sud)
-
-
-  !$OMP BARRIER
-  !$OMP MASTER
-    CALL VTe(VTdissipation)
-    CALL stop_timer(timer_dissip)
-    CALL VTb(VThallo)
-  !$OMP END MASTER
- 
-    CALL Register_SwapField_u(ucov,ucov_dyn,distrib_caldyn,Request_dissip)
-    CALL Register_SwapField_v(vcov,vcov_dyn,distrib_caldyn,Request_dissip)
-    CALL Register_SwapField_u(teta,teta_dyn,distrib_caldyn,Request_dissip)
-    CALL Register_SwapField_u(p,p_dyn,distrib_caldyn,Request_dissip)
-    CALL Register_SwapField_u(pk,pk_dyn,distrib_caldyn,Request_dissip)
-
-    CALL SendRequest(Request_dissip)       
-
-  !$OMP BARRIER
-    CALL WaitRequest(Request_dissip)       
-  !$OMP BARRIER
-  !$OMP MASTER
-    CALL set_distrib(distrib_caldyn)
-    CALL VTe(VThallo)
-    CALL resume_timer(timer_caldyn)
-!        print *,'fin dissipation'
-  !$OMP END MASTER
-  !$OMP BARRIER
-  
-  
-  END SUBROUTINE call_dissip
-
-END MODULE call_dissip_mod
Index: /LMDZ6/trunk/libf/dyn3dmem/call_dissip_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/call_dissip_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3dmem/call_dissip_mod.f90	(revision 5268)
@@ -0,0 +1,326 @@
+MODULE call_dissip_mod
+
+    REAL,POINTER,SAVE :: ucov(:,:)
+    REAL,POINTER,SAVE :: vcov(:,:)
+    REAL,POINTER,SAVE :: teta(:,:)
+    REAL,POINTER,SAVE :: p(:,: )
+    REAL,POINTER,SAVE :: pk(:,:)
+
+    REAL,POINTER,SAVE :: ucont(:,:)
+    REAL,POINTER,SAVE :: vcont(:,:)
+    REAL,POINTER,SAVE :: ecin(:,:)
+    REAL,POINTER,SAVE :: ecin0(:,:)
+    REAL,POINTER,SAVE :: dudis(:,:)
+    REAL,POINTER,SAVE :: dvdis(:,:)
+    REAL,POINTER,SAVE :: dtetadis(:,:)
+    REAL,POINTER,SAVE :: dtetaecdt(:,:)
+
+
+
+CONTAINS
+  
+  SUBROUTINE call_dissip_allocate
+  USE bands
+  USE allocate_field_mod
+  USE parallel_lmdz
+  USE dimensions_mod
+  USE dissip_mod, ONLY : dissip_allocate
+  IMPLICIT NONE
+    TYPE(distrib),POINTER :: d
+    d=>distrib_dissip
+
+    CALL allocate_u(ucov,llm,d)
+    ucov(:,:)=0
+    CALL allocate_v(vcov,llm,d)
+    vcov(:,:)=0
+    CALL allocate_u(teta,llm,d)
+    CALL allocate_u(p,llmp1,d)
+    CALL allocate_u(pk,llm,d)
+    CALL allocate_u(ucont,llm,d)
+    CALL allocate_v(vcont,llm,d)
+    CALL allocate_u(ecin,llm,d)
+    CALL allocate_u(ecin0,llm,d)
+    CALL allocate_u(dudis,llm,d)
+    CALL allocate_v(dvdis,llm,d)
+    CALL allocate_u(dtetadis,llm,d)
+    CALL allocate_u(dtetaecdt,llm,d)
+    
+    
+    CALL dissip_allocate
+    
+  END SUBROUTINE call_dissip_allocate
+  
+  SUBROUTINE call_dissip_switch_dissip(dist)
+  USE allocate_field_mod
+  USE bands
+  USE parallel_lmdz
+  USE dissip_mod, ONLY : dissip_switch_dissip
+  IMPLICIT NONE
+    TYPE(distrib),INTENT(IN) :: dist
+
+    CALL switch_u(ucov,distrib_dissip,dist)
+    CALL switch_v(vcov,distrib_dissip,dist)
+    CALL switch_u(teta,distrib_dissip,dist)
+    CALL switch_u(p,distrib_dissip,dist)
+    CALL switch_u(pk,distrib_dissip,dist)
+    CALL switch_u(ucont,distrib_dissip,dist)
+    CALL switch_v(vcont,distrib_dissip,dist)
+    CALL switch_u(ecin,distrib_dissip,dist)
+    CALL switch_u(ecin0,distrib_dissip,dist)
+    CALL switch_u(dudis,distrib_dissip,dist)
+    CALL switch_v(dvdis,distrib_dissip,dist)
+    CALL switch_u(dtetadis,distrib_dissip,dist)
+    CALL switch_u(dtetaecdt,distrib_dissip,dist)
+
+    CALL dissip_switch_dissip(dist)
+    
+  END SUBROUTINE call_dissip_switch_dissip  
+  
+
+  
+  SUBROUTINE call_dissip(ucov_dyn,vcov_dyn,teta_dyn,p_dyn,pk_dyn,ps_dyn)
+  USE dimensions_mod
+  USE parallel_lmdz
+  USE times
+  USE mod_hallo
+  USE Bands
+  USE vampir
+  USE write_field_loc
+  USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_DEBUGIO
+  IMPLICIT NONE
+    INCLUDE 'comgeom.h'
+    REAL,INTENT(INOUT) :: ucov_dyn(ijb_u:ije_u,llm) ! covariant zonal wind
+    REAL,INTENT(INOUT) :: vcov_dyn(ijb_v:ije_v,llm) ! covariant meridional wind
+    REAL,INTENT(INOUT) :: teta_dyn(ijb_u:ije_u,llm) ! covariant meridional wind
+    REAL,INTENT(INOUT) :: p_dyn(ijb_u:ije_u,llmp1 ) ! pressure at interlayer
+    REAL,INTENT(INOUT) :: pk_dyn(ijb_u:ije_u,llm) ! Exner at midlayer
+    REAL,INTENT(INOUT) :: ps_dyn(ijb_u:ije_u) ! surface pressure
+    REAL :: tppn(iim),tpps(iim)
+    REAL :: tpn,tps
+
+    REAL  SSUM
+    LOGICAL,PARAMETER :: dissip_conservative=.TRUE.
+    TYPE(Request),SAVE :: Request_dissip 
+!$OMP THREADPRIVATE(Request_dissip )    
+    INTEGER :: ij,l,ijb,ije 
+  
+    
+  !$OMP MASTER
+    CALL suspend_timer(timer_caldyn)
+        
+!       print*,'Entree dans la dissipation : Iteration No ',true_itau
+!   calcul de l'energie cinetique avant dissipation
+!       print *,'Passage dans la dissipation'
+
+    CALL VTb(VThallo)
+  !$OMP END MASTER
+
+  !$OMP BARRIER
+
+    CALL Register_SwapField_u(ucov_dyn,ucov,distrib_dissip, Request_dissip,up=1,down=1)
+    CALL Register_SwapField_v(vcov_dyn,vcov,distrib_dissip, Request_dissip,up=1,down=1)
+    CALL Register_SwapField_u(teta_dyn,teta,distrib_dissip, Request_dissip)
+    CALL Register_SwapField_u(p_dyn,p,distrib_dissip,Request_dissip)
+    CALL Register_SwapField_u(pk_dyn,pk,distrib_dissip,Request_dissip)
+
+    CALL SendRequest(Request_dissip)       
+  !$OMP BARRIER
+    CALL WaitRequest(Request_dissip)       
+
+  !$OMP BARRIER
+  !$OMP MASTER
+    CALL set_distrib(distrib_dissip)
+    CALL VTe(VThallo)
+    CALL VTb(VTdissipation)
+    CALL start_timer(timer_dissip)
+  !$OMP END MASTER
+  !$OMP BARRIER
+
+    CALL covcont_loc(llm,ucov,vcov,ucont,vcont)
+    CALL enercin_loc(vcov,ucov,vcont,ucont,ecin0)
+
+!   dissipation
+
+!        CALL FTRACE_REGION_BEGIN("dissip")
+    CALL dissip_loc(vcov,ucov,teta,p,dvdis,dudis,dtetadis)
+
+IF (CPPKEY_DEBUGIO) THEN
+    CALL WriteField_u('dudis',dudis)
+    CALL WriteField_v('dvdis',dvdis)
+    CALL WriteField_u('dtetadis',dtetadis)
+END IF
+ 
+!      CALL FTRACE_REGION_END("dissip")
+         
+    ijb=ij_begin
+    ije=ij_end
+  !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)        
+    DO l=1,llm
+      ucov(ijb:ije,l)=ucov(ijb:ije,l)+dudis(ijb:ije,l)
+    ENDDO
+  !$OMP END DO NOWAIT        
+
+    IF (pole_sud) ije=ije-iip1
+   
+  !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)        
+    DO l=1,llm
+      vcov(ijb:ije,l)=vcov(ijb:ije,l)+dvdis(ijb:ije,l)
+    ENDDO
+  !$OMP END DO NOWAIT        
+
+!       teta=teta+dtetadis
+
+
+!------------------------------------------------------------------------
+    IF (dissip_conservative) THEN
+!       On rajoute la tendance due a la transform. Ec -> E therm. cree
+!       lors de la dissipation
+    !$OMP BARRIER
+    !$OMP MASTER
+      CALL suspend_timer(timer_dissip)
+      CALL VTb(VThallo)
+    !$OMP END MASTER
+      CALL Register_Hallo_u(ucov,llm,1,1,1,1,Request_Dissip)
+      CALL Register_Hallo_v(vcov,llm,1,1,1,1,Request_Dissip)
+      CALL SendRequest(Request_Dissip)
+    !$OMP BARRIER
+      CALL WaitRequest(Request_Dissip)
+    !$OMP MASTER
+      CALL VTe(VThallo)
+      CALL resume_timer(timer_dissip)
+    !$OMP END MASTER
+    !$OMP BARRIER            
+      CALL covcont_loc(llm,ucov,vcov,ucont,vcont)
+      CALL enercin_loc(vcov,ucov,vcont,ucont,ecin)
+            
+      ijb=ij_begin
+      ije=ij_end
+    !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)            
+      DO l=1,llm
+        DO ij=ijb,ije
+           dtetaecdt(ij,l)= (ecin0(ij,l)-ecin(ij,l))/ pk(ij,l)
+           dtetadis(ij,l)=dtetadis(ij,l)+dtetaecdt(ij,l)
+        ENDDO
+      ENDDO
+    !$OMP END DO NOWAIT            
+
+    ENDIF
+
+    ijb=ij_begin
+    ije=ij_end
+
+  !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)            
+    DO l=1,llm
+      DO ij=ijb,ije
+         teta(ij,l)=teta(ij,l)+dtetadis(ij,l)
+      ENDDO
+    ENDDO
+  !$OMP END DO NOWAIT         
+
+!------------------------------------------------------------------------
+
+
+!    .......        P. Le Van (  ajout  le 17/04/96  )   ...........
+!   ...      Calcul de la valeur moyenne, unique de h aux poles  .....
+!
+
+    ijb=ij_begin
+    ije=ij_end
+         
+    IF (pole_nord) THEN
+  
+   !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l  =  1, llm
+        DO ij =  1,iim
+          tppn(ij)  = aire(  ij    ) * teta(  ij    ,l)
+        ENDDO
+        tpn  = SSUM(iim,tppn,1)/apoln
+
+        DO ij = 1, iip1
+          teta(  ij    ,l) = tpn
+        ENDDO
+      ENDDO
+    !$OMP END DO NOWAIT
+
+         if (1 == 0) then
+!!! Ehouarn: lines here 1) kill 1+1=2 in the dynamics
+!!!                     2) should probably not be here anyway
+!!! but are kept for those who would want to revert to previous behaviour
+    !$OMP MASTER               
+      DO ij =  1,iim
+        tppn(ij)  = aire(  ij    ) * ps_dyn (  ij    )
+      ENDDO
+      tpn  = SSUM(iim,tppn,1)/apoln
+  
+      DO ij = 1, iip1
+        ps_dyn(  ij    ) = tpn
+      ENDDO
+    !$OMP END MASTER
+    
+    ENDIF ! of if (1 == 0)
+    endif ! of of (pole_nord)
+        
+    IF (pole_sud) THEN
+
+    !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l  =  1, llm
+        DO ij =  1,iim
+          tpps(ij)  = aire(ij+ip1jm) * teta(ij+ip1jm,l)
+        ENDDO
+        
+        tps  = SSUM(iim,tpps,1)/apols
+
+        DO ij = 1, iip1
+          teta(ij+ip1jm,l) = tps
+        ENDDO
+      ENDDO
+    !$OMP END DO NOWAIT
+
+    if (1 == 0) then
+!!! Ehouarn: lines here 1) kill 1+1=2 in the dynamics
+!!!                     2) should probably not be here anyway
+!!! but are kept for those who would want to revert to previous behaviour
+    !$OMP MASTER               
+      DO ij =  1,iim
+        tpps(ij)  = aire(ij+ip1jm) * ps_dyn (ij+ip1jm)
+      ENDDO
+      tps  = SSUM(iim,tpps,1)/apols
+  
+      DO ij = 1, iip1
+        ps_dyn(ij+ip1jm) = tps
+      ENDDO
+    !$OMP END MASTER
+    ENDIF ! of if (1 == 0)
+    endif ! of if (pole_sud)
+
+
+  !$OMP BARRIER
+  !$OMP MASTER
+    CALL VTe(VTdissipation)
+    CALL stop_timer(timer_dissip)
+    CALL VTb(VThallo)
+  !$OMP END MASTER
+ 
+    CALL Register_SwapField_u(ucov,ucov_dyn,distrib_caldyn,Request_dissip)
+    CALL Register_SwapField_v(vcov,vcov_dyn,distrib_caldyn,Request_dissip)
+    CALL Register_SwapField_u(teta,teta_dyn,distrib_caldyn,Request_dissip)
+    CALL Register_SwapField_u(p,p_dyn,distrib_caldyn,Request_dissip)
+    CALL Register_SwapField_u(pk,pk_dyn,distrib_caldyn,Request_dissip)
+
+    CALL SendRequest(Request_dissip)       
+
+  !$OMP BARRIER
+    CALL WaitRequest(Request_dissip)       
+  !$OMP BARRIER
+  !$OMP MASTER
+    CALL set_distrib(distrib_caldyn)
+    CALL VTe(VThallo)
+    CALL resume_timer(timer_caldyn)
+!        print *,'fin dissipation'
+  !$OMP END MASTER
+  !$OMP BARRIER
+  
+  
+  END SUBROUTINE call_dissip
+
+END MODULE call_dissip_mod
Index: DZ6/trunk/libf/dyn3dmem/check_isotopes_loc.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/check_isotopes_loc.F90	(revision 5267)
+++ 	(revision )
@@ -1,194 +1,0 @@
-SUBROUTINE check_isotopes(q, ijb, ije, err_msg)
-   USE parallel_lmdz
-   USE strings_mod, ONLY: maxlen, msg, strIdx, strStack, int2str, real2str
-   USE infotrac,    ONLY: nqtot, niso, nphas, isotope, isoCheck, iqIsoPha, isoSelect, &
-                          ntiso, iH2O, nzone, tracers, isoName,  itZonIso
-   USE iso_params_mod, ONLY: tnat_H216O, tnat_H217O, tnat_H218O, tnat_HDO, tnat_HTO
-   USE ioipsl,          ONLY: getin
-   IMPLICIT NONE
-   include "dimensions.h"
-   REAL,             INTENT(INOUT) :: q(ijb_u:ije_u,llm,nqtot)
-   INTEGER,          INTENT(IN)    :: ijb, ije   !--- Can be local and different from ijb_u,ije_u, for example in qminimum
-   CHARACTER(LEN=*), INTENT(IN)    :: err_msg    !--- Error message to display
-   CHARACTER(LEN=maxlen) :: modname, msg1, nm(2)
-   INTEGER :: ixt, ipha, k, i, iq, iiso, izon, ieau, iqeau, iqpar
-   INTEGER, ALLOCATABLE       ::   ix(:)
-   REAL,    ALLOCATABLE, SAVE :: tnat(:)         !--- OpenMP shared variable
-   REAL :: xtractot, xiiso, deltaD, q1, q2
-   REAL, PARAMETER :: borne     = 1e19,  &
-                      errmax    = 1e-8,  &       !--- Max. absolute error
-                      errmaxrel = 1e-3,  &       !--- Max. relative error
-                      qmin      = 1e-11, &
-                      deltaDmax =1000.0, &
-                      deltaDmin =-999.0, &
-                      ridicule  = 1e-12
-   INTEGER, SAVE :: iso_eau, iso_HDO, iso_O18, iso_O17, iso_HTO
-!$OMP THREADPRIVATE(iso_eau, iso_HDO, iso_O18, iso_O17, iso_HTO)
-   LOGICAL       :: ltnat1
-   LOGICAL, SAVE :: first=.TRUE.
-!$OMP THREADPRIVATE(first)
-
-   modname='check_isotopes'
-   IF(.NOT.isoCheck)    RETURN                   !--- No need to check => finished
-   IF(isoSelect('H2O')) RETURN                   !--- No H2O isotopes group found
-   IF(niso == 0)        RETURN                   !--- No isotopes => finished
-   IF(first) THEN
-!$OMP MASTER
-      ltnat1 = .TRUE.; CALL getin('tnateq1', ltnat1)
-      ALLOCATE(tnat(niso))
-      iso_eau = strIdx(isoName,'H216O'); IF(iso_eau /= 0) tnat(iso_eau) = tnat_H216O
-      iso_O17 = strIdx(isoName,'H217O'); IF(iso_O17 /= 0) tnat(iso_O17) = tnat_H217O
-      iso_O18 = strIdx(isoName,'H218O'); IF(iso_O18 /= 0) tnat(iso_O18) = tnat_H218O
-      iso_HDO = strIdx(isoName,'HDO');   IF(iso_HDO /= 0) tnat(iso_HDO) = tnat_HDO
-      iso_HTO = strIdx(isoName,'HTO');   IF(iso_HTO /= 0) tnat(iso_HTO) = tnat_HTO
-      IF(ltnat1) tnat(:) = 1.0
-!$OMP END MASTER
-!$OMP BARRIER
-      first = .FALSE.
-   END IF
-   CALL msg('31: err_msg='//TRIM(err_msg), modname)
-
-   !--- CHECK FOR NaNs (FOR ALL THE ISOTOPES, INCLUDING GEOGRAPHIC TAGGING TRACERS)
-   modname = 'check_isotopes:iso_verif_noNaN'
-   DO ixt = 1, ntiso
-      DO ipha = 1, nphas
-         iq = iqIsoPha(ixt,ipha)
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-         DO k = 1, llm
-            DO i = ijb, ije
-               IF(ABS(q(i,k,iq)) < borne) CYCLE
-               WRITE(msg1,'(s,"(",i0,",",i0,",",i0,") = ",ES12.4)')TRIM(isoName(ixt)),i,k,iq,q(i,k,iq)
-               CALL msg(msg1, modname)
-               CALL abort_gcm(modname, 'Error with isotopes: '//TRIM(err_msg), 1)
-            END DO
-         END DO
-!$OMP END DO NOWAIT
-      END DO
-   END DO
-
-   !--- CHECK CONSERVATION (MAIN ISOTOPE AND PARENT CONCENTRATIONS MUST BE EQUAL)
-   modname = 'check_isotopes:iso_verif_egalite'
-   ixt = iso_eau
-   IF(ixt /= 0) THEN
-      DO ipha = 1, nphas
-         iq = iqIsoPha(ixt,ipha)
-         iqpar = tracers(iq)%iqParent
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-         DO k = 1, llm
-            DO i = ijb, ije
-               q1 = q(i,k,iqpar)
-               q2 = q(i,k,iq)
-!--- IMPROVEMENT in case at least one isotope is not negligible compared to the main isotopic form.
-!    This would be probably required to sum from smallest to highest concentrations ; the corresponding
-!    indices vector can be computed once only (in the initializations stage), using mean concentrations.
-!              q2 = SUM(q(i,k,tracers(iqPar)%iqDesc), DIM=3)
-               IF(ABS(q1-q2) <= errmax .OR. ABS(q1-q2)/MAX(MAX(ABS(q1),ABS(q2)),1e-18) <= errmaxrel) THEN
-                  q(i,k,iq) = q1                 !--- Bidouille pour convergence
-!                 q(i,k,tracers(iqPar)%iqDesc) = q(i,k,tracers(iqPar)%iqDesc) * q1 / q2
-                  CYCLE
-               END IF
-               CALL msg('ixt, iq = '//TRIM(strStack(int2str([ixt,iq]))), modname)
-               msg1 = '('//TRIM(strStack(int2str([i,k])))//')'
-               CALL msg(TRIM(tracers(iqpar)%name)//TRIM(msg1)//' = '//TRIM(real2str(q1)), modname)
-               CALL msg(TRIM(tracers(iq   )%name)//TRIM(msg1)//' = '//TRIM(real2str(q2)), modname)
-               CALL abort_gcm(modname, 'Error with isotopes: '//TRIM(err_msg), 1)
-            END DO
-         END DO
-!$OMP END DO NOWAIT
-      END DO
-   END IF
-
-   !--- CHECK DELTA ANOMALIES
-   modname = 'check_isotopes:iso_verif_aberrant'
-   ix = [ iso_HDO  ,   iso_O18 ]
-   nm = ['deltaD  ', 'deltaO18']
-   DO iiso = 1, SIZE(ix)
-      ixt = ix(iiso)
-      IF(ixt  == 0) CYCLE
-      DO ipha = 1, nphas
-         iq = iqIsoPha(ixt,ipha)
-         iqpar = tracers(iq)%iqParent
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-         DO k = 1, llm
-            DO i = ijb, ije
-               q1 = q(i,k,iqpar)
-               q2 = q(i,k,iq)
-!--- IMPROVEMENT in case at least one isotope is not negligible compared to the main isotopic form.
-!    This would be probably required to sum from smallest to highest concentrations ; the corresponding
-!    indices vector can be computed once only (in the initializations stage), using mean concentrations.
-!              q2 = SUM(q(i,k,tracers(iqPar)%iqDesc), DIM=3)
-               IF(q2 <= qmin) CYCLE
-               deltaD = (q2/q1/tnat(ixt)-1.)*1000.
-               IF(deltaD <= deltaDmax .AND. deltaD >= deltaDmin) CYCLE
-               CALL msg('ixt, iq = '//TRIM(strStack(int2str([ixt,iq]))), modname)
-               msg1 = '('//TRIM(strStack(int2str([i,k])))//')'
-               CALL msg(TRIM(tracers(iqpar)%name)//TRIM(msg1)//' = '//TRIM(real2str(q1)), modname)
-               CALL msg(TRIM(tracers(iq   )%name)//TRIM(msg1)//' = '//TRIM(real2str(q2)), modname)
-               CALL msg(TRIM(nm(iiso))//TRIM(real2str(deltaD)), modname)
-               CALL abort_gcm(modname, 'Error with isotopes: '//TRIM(err_msg), 1)
-            END DO
-         END DO
-!$OMP END DO NOWAIT
-      END DO
-   END DO
-
-   IF(nzone == 0) RETURN
-
-   !--- CHECK FOR TAGGING TRACERS DELTAD ANOMALIES
-   modname = 'check_isotopes:iso_verif_aberrant'
-   IF(iso_eau /= 0 .AND. iso_HDO /= 0) THEN
-      DO izon = 1, nzone
-         ixt  = itZonIso(izon, iso_HDO)
-         ieau = itZonIso(izon, iso_eau)
-         DO ipha = 1, nphas
-            iq    = iqIsoPha(ixt,  ipha)
-            iqeau = iqIsoPha(ieau, ipha)
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-            DO k = 1, llm
-               DO i = ijb, ije
-                  q1 = q(i,k,iqeau)
-                  q2 = q(i,k,iq)
-                  IF(q2<=qmin) CYCLE
-                  deltaD = (q2/q1/tnat(iso_HDO)-1.)*1000.
-                  IF(deltaD <= deltaDmax .AND. deltaD >= deltaDmin) CYCLE
-                  CALL msg('izon, ipha = '//TRIM(strStack(int2str([izon, ipha]))), modname)
-                  CALL msg( 'ixt, ieau = '//TRIM(strStack(int2str([ ixt, ieau]))), modname)
-                  msg1 = '('//TRIM(strStack(int2str([i,k])))//')'
-                  CALL msg(TRIM(tracers(iqeau)%name)//TRIM(msg1)//' = '//TRIM(real2str(q1)), modname)
-                  CALL msg(TRIM(tracers(iq   )%name)//TRIM(msg1)//' = '//TRIM(real2str(q2)), modname)
-                  CALL msg('deltaD = '//TRIM(real2str(deltaD)), modname)
-                  CALL abort_gcm(modname, 'Error with isotopes: '//TRIM(err_msg), 1)
-               END DO
-            END DO
-!$OMP END DO NOWAIT
-         END DO
-      END DO
-   END IF
-
-   !--- CHECK FOR TAGGING TRACERS CONSERVATION (PARENT AND TAGGING TRACERS SUM OVER ALL REGIONS MUST BE EQUAL)
-   DO iiso = 1, niso
-      DO ipha = 1, nphas
-         iq = iqIsoPha(iiso, ipha)
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-         DO k = 1, llm
-            DO i = ijb, ije
-               xiiso = q(i,k,iq)
-               xtractot = SUM(q(i, k, iqIsoPha(itZonIso(1:nzone,iiso), ipha)))
-               IF(ABS(xtractot-xiiso) > errmax .AND. ABS(xtractot-xiiso)/MAX(MAX(ABS(xtractot),ABS(xiiso)),1e-18) > errmaxrel) THEN
-                  CALL msg('Error in iso_verif_aberrant trac: '//TRIM(err_msg))
-                  CALL msg('iiso, ipha = '//TRIM(strStack(int2str([iiso, ipha]))), modname)
-                  CALL msg('q('//TRIM(strStack(int2str([i,k])))//',:) = '//TRIM(strStack(real2str(q(i,k,:)))), modname)
-                  CALL abort_gcm(modname, 'Error with isotopes: '//TRIM(err_msg), 1)
-               END IF
-               IF(ABS(xtractot) <= ridicule) CYCLE
-               DO izon = 1, nzone
-                  q(i,k,iq) = q(i,k,iq) / xtractot * xiiso !--- Bidouille pour convergence
-               END DO
-            END DO
-         END DO
-!$OMP END DO NOWAIT
-      END DO
-   END DO
-
-END SUBROUTINE check_isotopes
-
Index: /LMDZ6/trunk/libf/dyn3dmem/check_isotopes_loc.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/check_isotopes_loc.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3dmem/check_isotopes_loc.f90	(revision 5268)
@@ -0,0 +1,194 @@
+SUBROUTINE check_isotopes(q, ijb, ije, err_msg)
+   USE parallel_lmdz
+   USE strings_mod, ONLY: maxlen, msg, strIdx, strStack, int2str, real2str
+   USE infotrac,    ONLY: nqtot, niso, nphas, isotope, isoCheck, iqIsoPha, isoSelect, &
+                          ntiso, iH2O, nzone, tracers, isoName,  itZonIso
+   USE iso_params_mod, ONLY: tnat_H216O, tnat_H217O, tnat_H218O, tnat_HDO, tnat_HTO
+   USE ioipsl,          ONLY: getin
+   IMPLICIT NONE
+   include "dimensions.h"
+   REAL,             INTENT(INOUT) :: q(ijb_u:ije_u,llm,nqtot)
+   INTEGER,          INTENT(IN)    :: ijb, ije   !--- Can be local and different from ijb_u,ije_u, for example in qminimum
+   CHARACTER(LEN=*), INTENT(IN)    :: err_msg    !--- Error message to display
+   CHARACTER(LEN=maxlen) :: modname, msg1, nm(2)
+   INTEGER :: ixt, ipha, k, i, iq, iiso, izon, ieau, iqeau, iqpar
+   INTEGER, ALLOCATABLE       ::   ix(:)
+   REAL,    ALLOCATABLE, SAVE :: tnat(:)         !--- OpenMP shared variable
+   REAL :: xtractot, xiiso, deltaD, q1, q2
+   REAL, PARAMETER :: borne     = 1e19,  &
+                      errmax    = 1e-8,  &       !--- Max. absolute error
+                      errmaxrel = 1e-3,  &       !--- Max. relative error
+                      qmin      = 1e-11, &
+                      deltaDmax =1000.0, &
+                      deltaDmin =-999.0, &
+                      ridicule  = 1e-12
+   INTEGER, SAVE :: iso_eau, iso_HDO, iso_O18, iso_O17, iso_HTO
+!$OMP THREADPRIVATE(iso_eau, iso_HDO, iso_O18, iso_O17, iso_HTO)
+   LOGICAL       :: ltnat1
+   LOGICAL, SAVE :: first=.TRUE.
+!$OMP THREADPRIVATE(first)
+
+   modname='check_isotopes'
+   IF(.NOT.isoCheck)    RETURN                   !--- No need to check => finished
+   IF(isoSelect('H2O')) RETURN                   !--- No H2O isotopes group found
+   IF(niso == 0)        RETURN                   !--- No isotopes => finished
+   IF(first) THEN
+!$OMP MASTER
+      ltnat1 = .TRUE.; CALL getin('tnateq1', ltnat1)
+      ALLOCATE(tnat(niso))
+      iso_eau = strIdx(isoName,'H216O'); IF(iso_eau /= 0) tnat(iso_eau) = tnat_H216O
+      iso_O17 = strIdx(isoName,'H217O'); IF(iso_O17 /= 0) tnat(iso_O17) = tnat_H217O
+      iso_O18 = strIdx(isoName,'H218O'); IF(iso_O18 /= 0) tnat(iso_O18) = tnat_H218O
+      iso_HDO = strIdx(isoName,'HDO');   IF(iso_HDO /= 0) tnat(iso_HDO) = tnat_HDO
+      iso_HTO = strIdx(isoName,'HTO');   IF(iso_HTO /= 0) tnat(iso_HTO) = tnat_HTO
+      IF(ltnat1) tnat(:) = 1.0
+!$OMP END MASTER
+!$OMP BARRIER
+      first = .FALSE.
+   END IF
+   CALL msg('31: err_msg='//TRIM(err_msg), modname)
+
+   !--- CHECK FOR NaNs (FOR ALL THE ISOTOPES, INCLUDING GEOGRAPHIC TAGGING TRACERS)
+   modname = 'check_isotopes:iso_verif_noNaN'
+   DO ixt = 1, ntiso
+      DO ipha = 1, nphas
+         iq = iqIsoPha(ixt,ipha)
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+         DO k = 1, llm
+            DO i = ijb, ije
+               IF(ABS(q(i,k,iq)) < borne) CYCLE
+               WRITE(msg1,'(s,"(",i0,",",i0,",",i0,") = ",ES12.4)')TRIM(isoName(ixt)),i,k,iq,q(i,k,iq)
+               CALL msg(msg1, modname)
+               CALL abort_gcm(modname, 'Error with isotopes: '//TRIM(err_msg), 1)
+            END DO
+         END DO
+!$OMP END DO NOWAIT
+      END DO
+   END DO
+
+   !--- CHECK CONSERVATION (MAIN ISOTOPE AND PARENT CONCENTRATIONS MUST BE EQUAL)
+   modname = 'check_isotopes:iso_verif_egalite'
+   ixt = iso_eau
+   IF(ixt /= 0) THEN
+      DO ipha = 1, nphas
+         iq = iqIsoPha(ixt,ipha)
+         iqpar = tracers(iq)%iqParent
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+         DO k = 1, llm
+            DO i = ijb, ije
+               q1 = q(i,k,iqpar)
+               q2 = q(i,k,iq)
+!--- IMPROVEMENT in case at least one isotope is not negligible compared to the main isotopic form.
+!    This would be probably required to sum from smallest to highest concentrations ; the corresponding
+!    indices vector can be computed once only (in the initializations stage), using mean concentrations.
+!              q2 = SUM(q(i,k,tracers(iqPar)%iqDesc), DIM=3)
+               IF(ABS(q1-q2) <= errmax .OR. ABS(q1-q2)/MAX(MAX(ABS(q1),ABS(q2)),1e-18) <= errmaxrel) THEN
+                  q(i,k,iq) = q1                 !--- Bidouille pour convergence
+!                 q(i,k,tracers(iqPar)%iqDesc) = q(i,k,tracers(iqPar)%iqDesc) * q1 / q2
+                  CYCLE
+               END IF
+               CALL msg('ixt, iq = '//TRIM(strStack(int2str([ixt,iq]))), modname)
+               msg1 = '('//TRIM(strStack(int2str([i,k])))//')'
+               CALL msg(TRIM(tracers(iqpar)%name)//TRIM(msg1)//' = '//TRIM(real2str(q1)), modname)
+               CALL msg(TRIM(tracers(iq   )%name)//TRIM(msg1)//' = '//TRIM(real2str(q2)), modname)
+               CALL abort_gcm(modname, 'Error with isotopes: '//TRIM(err_msg), 1)
+            END DO
+         END DO
+!$OMP END DO NOWAIT
+      END DO
+   END IF
+
+   !--- CHECK DELTA ANOMALIES
+   modname = 'check_isotopes:iso_verif_aberrant'
+   ix = [ iso_HDO  ,   iso_O18 ]
+   nm = ['deltaD  ', 'deltaO18']
+   DO iiso = 1, SIZE(ix)
+      ixt = ix(iiso)
+      IF(ixt  == 0) CYCLE
+      DO ipha = 1, nphas
+         iq = iqIsoPha(ixt,ipha)
+         iqpar = tracers(iq)%iqParent
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+         DO k = 1, llm
+            DO i = ijb, ije
+               q1 = q(i,k,iqpar)
+               q2 = q(i,k,iq)
+!--- IMPROVEMENT in case at least one isotope is not negligible compared to the main isotopic form.
+!    This would be probably required to sum from smallest to highest concentrations ; the corresponding
+!    indices vector can be computed once only (in the initializations stage), using mean concentrations.
+!              q2 = SUM(q(i,k,tracers(iqPar)%iqDesc), DIM=3)
+               IF(q2 <= qmin) CYCLE
+               deltaD = (q2/q1/tnat(ixt)-1.)*1000.
+               IF(deltaD <= deltaDmax .AND. deltaD >= deltaDmin) CYCLE
+               CALL msg('ixt, iq = '//TRIM(strStack(int2str([ixt,iq]))), modname)
+               msg1 = '('//TRIM(strStack(int2str([i,k])))//')'
+               CALL msg(TRIM(tracers(iqpar)%name)//TRIM(msg1)//' = '//TRIM(real2str(q1)), modname)
+               CALL msg(TRIM(tracers(iq   )%name)//TRIM(msg1)//' = '//TRIM(real2str(q2)), modname)
+               CALL msg(TRIM(nm(iiso))//TRIM(real2str(deltaD)), modname)
+               CALL abort_gcm(modname, 'Error with isotopes: '//TRIM(err_msg), 1)
+            END DO
+         END DO
+!$OMP END DO NOWAIT
+      END DO
+   END DO
+
+   IF(nzone == 0) RETURN
+
+   !--- CHECK FOR TAGGING TRACERS DELTAD ANOMALIES
+   modname = 'check_isotopes:iso_verif_aberrant'
+   IF(iso_eau /= 0 .AND. iso_HDO /= 0) THEN
+      DO izon = 1, nzone
+         ixt  = itZonIso(izon, iso_HDO)
+         ieau = itZonIso(izon, iso_eau)
+         DO ipha = 1, nphas
+            iq    = iqIsoPha(ixt,  ipha)
+            iqeau = iqIsoPha(ieau, ipha)
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+            DO k = 1, llm
+               DO i = ijb, ije
+                  q1 = q(i,k,iqeau)
+                  q2 = q(i,k,iq)
+                  IF(q2<=qmin) CYCLE
+                  deltaD = (q2/q1/tnat(iso_HDO)-1.)*1000.
+                  IF(deltaD <= deltaDmax .AND. deltaD >= deltaDmin) CYCLE
+                  CALL msg('izon, ipha = '//TRIM(strStack(int2str([izon, ipha]))), modname)
+                  CALL msg( 'ixt, ieau = '//TRIM(strStack(int2str([ ixt, ieau]))), modname)
+                  msg1 = '('//TRIM(strStack(int2str([i,k])))//')'
+                  CALL msg(TRIM(tracers(iqeau)%name)//TRIM(msg1)//' = '//TRIM(real2str(q1)), modname)
+                  CALL msg(TRIM(tracers(iq   )%name)//TRIM(msg1)//' = '//TRIM(real2str(q2)), modname)
+                  CALL msg('deltaD = '//TRIM(real2str(deltaD)), modname)
+                  CALL abort_gcm(modname, 'Error with isotopes: '//TRIM(err_msg), 1)
+               END DO
+            END DO
+!$OMP END DO NOWAIT
+         END DO
+      END DO
+   END IF
+
+   !--- CHECK FOR TAGGING TRACERS CONSERVATION (PARENT AND TAGGING TRACERS SUM OVER ALL REGIONS MUST BE EQUAL)
+   DO iiso = 1, niso
+      DO ipha = 1, nphas
+         iq = iqIsoPha(iiso, ipha)
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+         DO k = 1, llm
+            DO i = ijb, ije
+               xiiso = q(i,k,iq)
+               xtractot = SUM(q(i, k, iqIsoPha(itZonIso(1:nzone,iiso), ipha)))
+               IF(ABS(xtractot-xiiso) > errmax .AND. ABS(xtractot-xiiso)/MAX(MAX(ABS(xtractot),ABS(xiiso)),1e-18) > errmaxrel) THEN
+                  CALL msg('Error in iso_verif_aberrant trac: '//TRIM(err_msg))
+                  CALL msg('iiso, ipha = '//TRIM(strStack(int2str([iiso, ipha]))), modname)
+                  CALL msg('q('//TRIM(strStack(int2str([i,k])))//',:) = '//TRIM(strStack(real2str(q(i,k,:)))), modname)
+                  CALL abort_gcm(modname, 'Error with isotopes: '//TRIM(err_msg), 1)
+               END IF
+               IF(ABS(xtractot) <= ridicule) CYCLE
+               DO izon = 1, nzone
+                  q(i,k,iq) = q(i,k,iq) / xtractot * xiiso !--- Bidouille pour convergence
+               END DO
+            END DO
+         END DO
+!$OMP END DO NOWAIT
+      END DO
+   END DO
+
+END SUBROUTINE check_isotopes
+
Index: DZ6/trunk/libf/dyn3dmem/convmas1_loc.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/convmas1_loc.F90	(revision 5267)
+++ 	(revision )
@@ -1,37 +1,0 @@
-SUBROUTINE convmas1_loc (pbaru, pbarv, convm)
-!
-!-------------------------------------------------------------------------------
-! Authors: P. Le Van , Fr. Hourdin.
-!-------------------------------------------------------------------------------
-! Purpose: Compute mass flux convergence at p levels.
-!          Equivalent to convmas_loc if convmas2_loc is called after.
-  USE parallel_lmdz
-  USE mod_filtreg_p
-  IMPLICIT NONE
-  include "dimensions.h"
-  include "paramet.h"
-  include "comgeom.h"
-!===============================================================================
-! Arguments:
-  REAL, INTENT(IN)  :: pbaru(ijb_u:ije_u,llm)
-  REAL, INTENT(IN)  :: pbarv(ijb_v:ije_v,llm)
-  REAL, TARGET, INTENT(OUT) :: convm(ijb_u:ije_u,llm)
-!===============================================================================
-! Method used:   Computation from top to bottom.
-!   Mass convergence at level llm is equal to zero and is not stored in convm.
-!===============================================================================
-! Local variables:
-  INTEGER :: l, jjb, jje
-!===============================================================================
-
-!--- Computation of - (d(pbaru)/dx + d(pbarv)/dy )
-  CALL convflu_loc( pbaru, pbarv, llm, convm )
-
-!--- Filter
-  jjb=jj_begin
-  jje=jj_end+1
-  IF(pole_sud) jje=jj_end
-  CALL filtreg_p(convm,jjb_u,jje_u,jjb,jje,jjp1,llm,2,2,.TRUE.,1)
-
-END SUBROUTINE convmas1_loc
-
Index: /LMDZ6/trunk/libf/dyn3dmem/convmas1_loc.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/convmas1_loc.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3dmem/convmas1_loc.f90	(revision 5268)
@@ -0,0 +1,37 @@
+SUBROUTINE convmas1_loc (pbaru, pbarv, convm)
+!
+!-------------------------------------------------------------------------------
+! Authors: P. Le Van , Fr. Hourdin.
+!-------------------------------------------------------------------------------
+! Purpose: Compute mass flux convergence at p levels.
+!          Equivalent to convmas_loc if convmas2_loc is called after.
+  USE parallel_lmdz
+  USE mod_filtreg_p
+  IMPLICIT NONE
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom.h"
+!===============================================================================
+! Arguments:
+  REAL, INTENT(IN)  :: pbaru(ijb_u:ije_u,llm)
+  REAL, INTENT(IN)  :: pbarv(ijb_v:ije_v,llm)
+  REAL, TARGET, INTENT(OUT) :: convm(ijb_u:ije_u,llm)
+!===============================================================================
+! Method used:   Computation from top to bottom.
+!   Mass convergence at level llm is equal to zero and is not stored in convm.
+!===============================================================================
+! Local variables:
+  INTEGER :: l, jjb, jje
+!===============================================================================
+
+!--- Computation of - (d(pbaru)/dx + d(pbarv)/dy )
+  CALL convflu_loc( pbaru, pbarv, llm, convm )
+
+!--- Filter
+  jjb=jj_begin
+  jje=jj_end+1
+  IF(pole_sud) jje=jj_end
+  CALL filtreg_p(convm,jjb_u,jje_u,jjb,jje,jjp1,llm,2,2,.TRUE.,1)
+
+END SUBROUTINE convmas1_loc
+
Index: DZ6/trunk/libf/dyn3dmem/convmas2_loc.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/convmas2_loc.F90	(revision 5267)
+++ 	(revision )
@@ -1,35 +1,0 @@
-SUBROUTINE convmas2_loc (convm)
-!
-!-------------------------------------------------------------------------------
-! Authors: P. Le Van , Fr. Hourdin.
-!-------------------------------------------------------------------------------
-! Purpose: Compute mass flux convergence at p levels.
-!          Equivalent to convmas_loc if convmas1_loc is called before.
-  USE parallel_lmdz
-  IMPLICIT NONE
-  include "dimensions.h"
-  include "paramet.h"
-  include "comgeom.h"
-!===============================================================================
-! Arguments:
-  REAL, INTENT(INOUT) :: convm(ijb_u:ije_u,llm)
-!===============================================================================
-! Method used:   Computation from top to bottom.
-!   Mass convergence at level llm is equal to zero and is not stored in convm.
-!===============================================================================
-! Local variables:
-  INTEGER :: l, ijb, ije
-!===============================================================================
-
-!$OMP MASTER
-!--- Mass convergence is integrated from top to bottom
-  ijb=ij_begin
-  ije=ij_end+iip1
-  IF(pole_sud) ije=ij_end
-  DO l=llmm1,1,-1
-    convm(ijb:ije,l) = convm(ijb:ije,l) + convm(ijb:ije,l+1)
-  END DO
-!$OMP END MASTER
-
-END SUBROUTINE convmas2_loc
-
Index: /LMDZ6/trunk/libf/dyn3dmem/convmas2_loc.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/convmas2_loc.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3dmem/convmas2_loc.f90	(revision 5268)
@@ -0,0 +1,35 @@
+SUBROUTINE convmas2_loc (convm)
+!
+!-------------------------------------------------------------------------------
+! Authors: P. Le Van , Fr. Hourdin.
+!-------------------------------------------------------------------------------
+! Purpose: Compute mass flux convergence at p levels.
+!          Equivalent to convmas_loc if convmas1_loc is called before.
+  USE parallel_lmdz
+  IMPLICIT NONE
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom.h"
+!===============================================================================
+! Arguments:
+  REAL, INTENT(INOUT) :: convm(ijb_u:ije_u,llm)
+!===============================================================================
+! Method used:   Computation from top to bottom.
+!   Mass convergence at level llm is equal to zero and is not stored in convm.
+!===============================================================================
+! Local variables:
+  INTEGER :: l, ijb, ije
+!===============================================================================
+
+!$OMP MASTER
+!--- Mass convergence is integrated from top to bottom
+  ijb=ij_begin
+  ije=ij_end+iip1
+  IF(pole_sud) ije=ij_end
+  DO l=llmm1,1,-1
+    convm(ijb:ije,l) = convm(ijb:ije,l) + convm(ijb:ije,l+1)
+  END DO
+!$OMP END MASTER
+
+END SUBROUTINE convmas2_loc
+
Index: DZ6/trunk/libf/dyn3dmem/convmas_loc.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/convmas_loc.F90	(revision 5267)
+++ 	(revision )
@@ -1,48 +1,0 @@
-SUBROUTINE convmas_loc (pbaru, pbarv, convm)
-!
-!-------------------------------------------------------------------------------
-! Authors: P. Le Van , Fr. Hourdin.
-!-------------------------------------------------------------------------------
-! Purpose: Compute mass flux convergence at p levels.
-  USE parallel_lmdz
-  USE mod_filtreg_p
-  IMPLICIT NONE
-  include "dimensions.h"
-  include "paramet.h"
-  include "comgeom.h"
-!===============================================================================
-! Arguments:
-  REAL, INTENT(IN)  :: pbaru(ijb_u:ije_u,llm)
-  REAL, INTENT(IN)  :: pbarv(ijb_v:ije_v,llm)
-  REAL, INTENT(OUT) :: convm(ijb_u:ije_u,llm)
-!===============================================================================
-! Method used:   Computation from top to bottom.
-!   Mass convergence at level llm is equal to zero and is not stored in convm.
-!===============================================================================
-! Local variables:
-  INTEGER :: l, ijb, ije, jjb, jje
-!===============================================================================
-
-!--- Computation of - (d(pbaru)/dx + d(pbarv)/dy )
-  CALL convflu_loc( pbaru, pbarv, llm, convm )
-
-!--- Filter
-  jjb=jj_begin
-  jje=jj_end+1
-  IF(pole_sud) jje=jj_end
-  CALL filtreg_p(convm,jjb_u,jje_u,jjb,jje,jjp1,llm,2,2,.TRUE.,1)
-
-!--- Mass convergence is integrated from top to bottom
-!$OMP BARRIER
-!$OMP MASTER
-  ijb=ij_begin
-  ije=ij_end+iip1
-  IF(pole_sud) ije=ij_end
-  DO l=llmm1,1,-1
-    convm(ijb:ije,l) = convm(ijb:ije,l) + convm(ijb:ije,l+1)
-  END DO
-!$OMP END MASTER
-!$OMP BARRIER
-
-END SUBROUTINE convmas_loc
-
Index: /LMDZ6/trunk/libf/dyn3dmem/convmas_loc.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/convmas_loc.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3dmem/convmas_loc.f90	(revision 5268)
@@ -0,0 +1,48 @@
+SUBROUTINE convmas_loc (pbaru, pbarv, convm)
+!
+!-------------------------------------------------------------------------------
+! Authors: P. Le Van , Fr. Hourdin.
+!-------------------------------------------------------------------------------
+! Purpose: Compute mass flux convergence at p levels.
+  USE parallel_lmdz
+  USE mod_filtreg_p
+  IMPLICIT NONE
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom.h"
+!===============================================================================
+! Arguments:
+  REAL, INTENT(IN)  :: pbaru(ijb_u:ije_u,llm)
+  REAL, INTENT(IN)  :: pbarv(ijb_v:ije_v,llm)
+  REAL, INTENT(OUT) :: convm(ijb_u:ije_u,llm)
+!===============================================================================
+! Method used:   Computation from top to bottom.
+!   Mass convergence at level llm is equal to zero and is not stored in convm.
+!===============================================================================
+! Local variables:
+  INTEGER :: l, ijb, ije, jjb, jje
+!===============================================================================
+
+!--- Computation of - (d(pbaru)/dx + d(pbarv)/dy )
+  CALL convflu_loc( pbaru, pbarv, llm, convm )
+
+!--- Filter
+  jjb=jj_begin
+  jje=jj_end+1
+  IF(pole_sud) jje=jj_end
+  CALL filtreg_p(convm,jjb_u,jje_u,jjb,jje,jjp1,llm,2,2,.TRUE.,1)
+
+!--- Mass convergence is integrated from top to bottom
+!$OMP BARRIER
+!$OMP MASTER
+  ijb=ij_begin
+  ije=ij_end+iip1
+  IF(pole_sud) ije=ij_end
+  DO l=llmm1,1,-1
+    convm(ijb:ije,l) = convm(ijb:ije,l) + convm(ijb:ije,l+1)
+  END DO
+!$OMP END MASTER
+!$OMP BARRIER
+
+END SUBROUTINE convmas_loc
+
Index: DZ6/trunk/libf/dyn3dmem/dimensions_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/dimensions_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,4 +1,0 @@
-MODULE dimensions_mod
-  INCLUDE 'dimensions.h'
-  INCLUDE 'paramet.h'
-END MODULE dimensions_mod
Index: /LMDZ6/trunk/libf/dyn3dmem/dimensions_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/dimensions_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3dmem/dimensions_mod.f90	(revision 5268)
@@ -0,0 +1,4 @@
+MODULE dimensions_mod
+  INCLUDE 'dimensions.h'
+  INCLUDE 'paramet.h'
+END MODULE dimensions_mod
Index: DZ6/trunk/libf/dyn3dmem/dissip_loc.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/dissip_loc.F90	(revision 5267)
+++ 	(revision )
@@ -1,235 +1,0 @@
-!
-! $Id: $
-!
-SUBROUTINE dissip_loc( vcov,ucov,teta,p, dv,du,dh )
-  !
-  USE parallel_lmdz
-  USE write_field_loc
-  USE dissip_mod, ONLY: dissip_allocate
-  USE comconst_mod, ONLY: dtdiss
-  USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_DEBUGIO
-  IMPLICIT NONE
-
-
-  ! ..  Avec nouveaux operateurs star :  gradiv2 , divgrad2, nxgraro2  ...
-                              ! (  10/01/98  )
-
-  !=======================================================================
-  !
-  !   Auteur:  P. Le Van
-  !   -------
-  !
-  !   Objet:
-  !   ------
-  !
-  !   Dissipation horizontale
-  !
-  !=======================================================================
-  !-----------------------------------------------------------------------
-  !   Declarations:
-  !   -------------
-
-  include "dimensions.h"
-  include "paramet.h"
-  include "comgeom.h"
-  include "comdissnew.h"
-  include "comdissipn.h"
-
-  !   Arguments:
-  !   ----------
-
-  REAL,INTENT(IN) :: vcov(ijb_v:ije_v,llm) ! covariant meridional wind
-  REAL,INTENT(IN) :: ucov(ijb_u:ije_u,llm) ! covariant zonal wind
-  REAL,INTENT(IN) :: teta(ijb_u:ije_u,llm) ! potential temperature
-  REAL,INTENT(IN) :: p(ijb_u:ije_u,llmp1) ! interlayer pressure
-  ! ! tendencies (.../s) on covariant winds and potential temperature
-  REAL,INTENT(OUT) :: dv(ijb_v:ije_v,llm)
-  REAL,INTENT(OUT) :: du(ijb_u:ije_u,llm)
-  REAL,INTENT(OUT) :: dh(ijb_u:ije_u,llm)
-
-  !   Local:
-  !   ------
-
-  REAL :: gdx(ijb_u:ije_u,llm),gdy(ijb_v:ije_v,llm)
-  REAL :: grx(ijb_u:ije_u,llm),gry(ijb_v:ije_v,llm)
-  REAL :: te1dt(llm),te2dt(llm),te3dt(llm)
-  REAL :: deltapres(ijb_u:ije_u,llm)
-
-  INTEGER :: l,ij
-
-  REAL :: SSUM
-  integer :: ijb,ije
-
-  LOGICAl,SAVE :: first=.TRUE.
-!$OMP THREADPRIVATE(first)
-
-  IF (first) THEN
-    CALL dissip_allocate
-    first=.FALSE.
-  ENDIF
-  !-----------------------------------------------------------------------
-  !   initialisations:
-  !   ----------------
-
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-  DO l=1,llm
-     te1dt(l) = tetaudiv(l) * dtdiss
-     te2dt(l) = tetaurot(l) * dtdiss
-     te3dt(l) = tetah(l)    * dtdiss
-  ENDDO
-!$OMP END DO NOWAIT
-   ! CALL initial0( ijp1llm, du )
-   ! CALL initial0( ijmllm , dv )
-   ! CALL initial0( ijp1llm, dh )
-
-  ijb=ij_begin
-  ije=ij_end
-
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-  DO l=1,llm
-    du(ijb:ije,l)=0
-    dh(ijb:ije,l)=0
-  ENDDO
-!$OMP END DO NOWAIT
-
-  if (pole_sud) ije=ij_end-iip1
-
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-  DO l=1,llm
-    dv(ijb:ije,l)=0
-  ENDDO
-!$OMP END DO NOWAIT
-
-  !-----------------------------------------------------------------------
-  !   Calcul de la dissipation:
-  !   -------------------------
-
-  !   Calcul de la partie   grad  ( div ) :
-  !   -------------------------------------
-
-
-
-  IF(lstardis) THEN
-   ! IF (.FALSE.) THEN
-     CALL gradiv2_loc( llm,ucov,vcov,nitergdiv,gdx,gdy )
-  ELSE
-      ! CALL gradiv_p ( llm,ucov,vcov,nitergdiv,gdx,gdy )
-  ENDIF
-
-IF (CPPKEY_DEBUGIO) THEN
-  call WriteField_u('gdx',gdx)
-  call WriteField_v('gdy',gdy)
-END IF
-
-  ijb=ij_begin
-  ije=ij_end
-  if (pole_sud) ije=ij_end-iip1
-
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-  DO l=1,llm
-     if (pole_nord) then
-       DO ij = 1, iip1
-          gdx(     ij ,l) = 0.
-       ENDDO
-     endif
-
-     if (pole_sud) then
-       DO ij = 1, iip1
-          gdx(ij+ip1jm,l) = 0.
-       ENDDO
-     endif
-
-     if (pole_nord) ijb=ij_begin+iip1
-     DO ij = ijb,ije
-        du(ij,l) = du(ij,l) - te1dt(l) *gdx(ij,l)
-     ENDDO
-
-     if (pole_nord) ijb=ij_begin
-     DO ij = ijb,ije
-        dv(ij,l) = dv(ij,l) - te1dt(l) *gdy(ij,l)
-     ENDDO
-
-   ENDDO
-!$OMP END DO NOWAIT
-  !   calcul de la partie   n X grad ( rot ):
-  !   ---------------------------------------
-
-  IF(lstardis) THEN
-   ! IF (.FALSE.) THEN
-     CALL nxgraro2_loc( llm,ucov, vcov, nitergrot,grx,gry )
-  ELSE
-      ! CALL nxgrarot_p( llm,ucov, vcov, nitergrot,grx,gry )
-  ENDIF
-
-IF (CPPKEY_DEBUGIO) THEN
-  call WriteField_u('grx',grx)
-  call WriteField_v('gry',gry)
-END IF
-
-
-  ijb=ij_begin
-  ije=ij_end
-  if (pole_sud) ije=ij_end-iip1
-
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-  DO l=1,llm
-
-     if (pole_nord) then
-       DO ij = 1, iip1
-          grx(ij,l) = 0.
-       ENDDO
-     endif
-
-     if (pole_nord) ijb=ij_begin+iip1
-     DO ij = ijb,ije
-        du(ij,l) = du(ij,l) - te2dt(l) * grx(ij,l)
-     ENDDO
-
-     if (pole_nord) ijb=ij_begin
-     DO ij =  ijb, ije
-        dv(ij,l) = dv(ij,l) - te2dt(l) * gry(ij,l)
-     ENDDO
-
-  ENDDO
-!$OMP END DO NOWAIT
-
-  !   calcul de la partie   div ( grad ):
-  !   -----------------------------------
-
-
-  IF(lstardis) THEN
-   ! IF (.FALSE.) THEN
-
-  ijb=ij_begin
-  ije=ij_end
-
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-   DO l = 1, llm
-      DO ij = ijb, ije
-        deltapres(ij,l) = AMAX1( 0.,  p(ij,l) - p(ij,l+1) )
-      ENDDO
-   ENDDO
-!$OMP END DO NOWAIT
-     CALL divgrad2_loc( llm,teta, deltapres  ,niterh, gdx )
-  ELSE
-      ! CALL divgrad_p ( llm,teta, niterh, gdx        )
-  ENDIF
-
-IF (CPPKEY_DEBUGIO) THEN
-  call WriteField_u('gdx',gdx)
-END IF
-
-
-  ijb=ij_begin
-  ije=ij_end
-
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-  DO l = 1,llm
-     DO ij = ijb,ije
-        dh( ij,l ) = dh( ij,l ) - te3dt(l) * gdx( ij,l )
-     ENDDO
-  ENDDO
-!$OMP END DO NOWAIT
-
-  RETURN
-END SUBROUTINE dissip_loc
Index: /LMDZ6/trunk/libf/dyn3dmem/dissip_loc.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/dissip_loc.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3dmem/dissip_loc.f90	(revision 5268)
@@ -0,0 +1,235 @@
+!
+! $Id: $
+!
+SUBROUTINE dissip_loc( vcov,ucov,teta,p, dv,du,dh )
+  !
+  USE parallel_lmdz
+  USE write_field_loc
+  USE dissip_mod, ONLY: dissip_allocate
+  USE comconst_mod, ONLY: dtdiss
+  USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_DEBUGIO
+  IMPLICIT NONE
+
+
+  ! ..  Avec nouveaux operateurs star :  gradiv2 , divgrad2, nxgraro2  ...
+                              ! (  10/01/98  )
+
+  !=======================================================================
+  !
+  !   Auteur:  P. Le Van
+  !   -------
+  !
+  !   Objet:
+  !   ------
+  !
+  !   Dissipation horizontale
+  !
+  !=======================================================================
+  !-----------------------------------------------------------------------
+  !   Declarations:
+  !   -------------
+
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom.h"
+  include "comdissnew.h"
+  include "comdissipn.h"
+
+  !   Arguments:
+  !   ----------
+
+  REAL,INTENT(IN) :: vcov(ijb_v:ije_v,llm) ! covariant meridional wind
+  REAL,INTENT(IN) :: ucov(ijb_u:ije_u,llm) ! covariant zonal wind
+  REAL,INTENT(IN) :: teta(ijb_u:ije_u,llm) ! potential temperature
+  REAL,INTENT(IN) :: p(ijb_u:ije_u,llmp1) ! interlayer pressure
+  ! ! tendencies (.../s) on covariant winds and potential temperature
+  REAL,INTENT(OUT) :: dv(ijb_v:ije_v,llm)
+  REAL,INTENT(OUT) :: du(ijb_u:ije_u,llm)
+  REAL,INTENT(OUT) :: dh(ijb_u:ije_u,llm)
+
+  !   Local:
+  !   ------
+
+  REAL :: gdx(ijb_u:ije_u,llm),gdy(ijb_v:ije_v,llm)
+  REAL :: grx(ijb_u:ije_u,llm),gry(ijb_v:ije_v,llm)
+  REAL :: te1dt(llm),te2dt(llm),te3dt(llm)
+  REAL :: deltapres(ijb_u:ije_u,llm)
+
+  INTEGER :: l,ij
+
+  REAL :: SSUM
+  integer :: ijb,ije
+
+  LOGICAl,SAVE :: first=.TRUE.
+!$OMP THREADPRIVATE(first)
+
+  IF (first) THEN
+    CALL dissip_allocate
+    first=.FALSE.
+  ENDIF
+  !-----------------------------------------------------------------------
+  !   initialisations:
+  !   ----------------
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,llm
+     te1dt(l) = tetaudiv(l) * dtdiss
+     te2dt(l) = tetaurot(l) * dtdiss
+     te3dt(l) = tetah(l)    * dtdiss
+  ENDDO
+!$OMP END DO NOWAIT
+   ! CALL initial0( ijp1llm, du )
+   ! CALL initial0( ijmllm , dv )
+   ! CALL initial0( ijp1llm, dh )
+
+  ijb=ij_begin
+  ije=ij_end
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,llm
+    du(ijb:ije,l)=0
+    dh(ijb:ije,l)=0
+  ENDDO
+!$OMP END DO NOWAIT
+
+  if (pole_sud) ije=ij_end-iip1
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,llm
+    dv(ijb:ije,l)=0
+  ENDDO
+!$OMP END DO NOWAIT
+
+  !-----------------------------------------------------------------------
+  !   Calcul de la dissipation:
+  !   -------------------------
+
+  !   Calcul de la partie   grad  ( div ) :
+  !   -------------------------------------
+
+
+
+  IF(lstardis) THEN
+   ! IF (.FALSE.) THEN
+     CALL gradiv2_loc( llm,ucov,vcov,nitergdiv,gdx,gdy )
+  ELSE
+      ! CALL gradiv_p ( llm,ucov,vcov,nitergdiv,gdx,gdy )
+  ENDIF
+
+IF (CPPKEY_DEBUGIO) THEN
+  call WriteField_u('gdx',gdx)
+  call WriteField_v('gdy',gdy)
+END IF
+
+  ijb=ij_begin
+  ije=ij_end
+  if (pole_sud) ije=ij_end-iip1
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,llm
+     if (pole_nord) then
+       DO ij = 1, iip1
+          gdx(     ij ,l) = 0.
+       ENDDO
+     endif
+
+     if (pole_sud) then
+       DO ij = 1, iip1
+          gdx(ij+ip1jm,l) = 0.
+       ENDDO
+     endif
+
+     if (pole_nord) ijb=ij_begin+iip1
+     DO ij = ijb,ije
+        du(ij,l) = du(ij,l) - te1dt(l) *gdx(ij,l)
+     ENDDO
+
+     if (pole_nord) ijb=ij_begin
+     DO ij = ijb,ije
+        dv(ij,l) = dv(ij,l) - te1dt(l) *gdy(ij,l)
+     ENDDO
+
+   ENDDO
+!$OMP END DO NOWAIT
+  !   calcul de la partie   n X grad ( rot ):
+  !   ---------------------------------------
+
+  IF(lstardis) THEN
+   ! IF (.FALSE.) THEN
+     CALL nxgraro2_loc( llm,ucov, vcov, nitergrot,grx,gry )
+  ELSE
+      ! CALL nxgrarot_p( llm,ucov, vcov, nitergrot,grx,gry )
+  ENDIF
+
+IF (CPPKEY_DEBUGIO) THEN
+  call WriteField_u('grx',grx)
+  call WriteField_v('gry',gry)
+END IF
+
+
+  ijb=ij_begin
+  ije=ij_end
+  if (pole_sud) ije=ij_end-iip1
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,llm
+
+     if (pole_nord) then
+       DO ij = 1, iip1
+          grx(ij,l) = 0.
+       ENDDO
+     endif
+
+     if (pole_nord) ijb=ij_begin+iip1
+     DO ij = ijb,ije
+        du(ij,l) = du(ij,l) - te2dt(l) * grx(ij,l)
+     ENDDO
+
+     if (pole_nord) ijb=ij_begin
+     DO ij =  ijb, ije
+        dv(ij,l) = dv(ij,l) - te2dt(l) * gry(ij,l)
+     ENDDO
+
+  ENDDO
+!$OMP END DO NOWAIT
+
+  !   calcul de la partie   div ( grad ):
+  !   -----------------------------------
+
+
+  IF(lstardis) THEN
+   ! IF (.FALSE.) THEN
+
+  ijb=ij_begin
+  ije=ij_end
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+   DO l = 1, llm
+      DO ij = ijb, ije
+        deltapres(ij,l) = AMAX1( 0.,  p(ij,l) - p(ij,l+1) )
+      ENDDO
+   ENDDO
+!$OMP END DO NOWAIT
+     CALL divgrad2_loc( llm,teta, deltapres  ,niterh, gdx )
+  ELSE
+      ! CALL divgrad_p ( llm,teta, niterh, gdx        )
+  ENDIF
+
+IF (CPPKEY_DEBUGIO) THEN
+  call WriteField_u('gdx',gdx)
+END IF
+
+
+  ijb=ij_begin
+  ije=ij_end
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l = 1,llm
+     DO ij = ijb,ije
+        dh( ij,l ) = dh( ij,l ) - te3dt(l) * gdx( ij,l )
+     ENDDO
+  ENDDO
+!$OMP END DO NOWAIT
+
+  RETURN
+END SUBROUTINE dissip_loc
Index: DZ6/trunk/libf/dyn3dmem/dissip_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/dissip_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,40 +1,0 @@
-MODULE dissip_mod
-
-
-  
-CONTAINS
-
-  SUBROUTINE dissip_allocate
-  USE bands
-  USE allocate_field_mod
-  USE parallel_lmdz
-  USE dimensions_mod
-  USE gradiv2_mod, ONLY : gradiv2_allocate
-  USE nxgraro2_mod, ONLY : nxgraro2_allocate
-  USE divgrad2_mod, ONLY : divgrad2_allocate
-  IMPLICIT NONE
-
-    CALL gradiv2_allocate
-    CALL nxgraro2_allocate
-    CALL divgrad2_allocate
-
-    
-  END SUBROUTINE dissip_allocate
-  
-  SUBROUTINE dissip_switch_dissip(dist)
-  USE allocate_field_mod
-  USE bands
-  USE parallel_lmdz
-  USE gradiv2_mod,ONLY : gradiv2_switch_dissip
-  USE nxgraro2_mod,ONLY : nxgraro2_switch_dissip
-  USE divgrad2_mod,ONLY : divgrad2_switch_dissip
-  IMPLICIT NONE
-    TYPE(distrib),INTENT(IN) :: dist
-
-    CALL gradiv2_switch_dissip(dist)
-    CALL nxgraro2_switch_dissip(dist)
-    CALL divgrad2_switch_dissip(dist)
-    
-  END SUBROUTINE dissip_switch_dissip
-  
-END MODULE dissip_mod  
Index: /LMDZ6/trunk/libf/dyn3dmem/dissip_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/dissip_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3dmem/dissip_mod.f90	(revision 5268)
@@ -0,0 +1,40 @@
+MODULE dissip_mod
+
+
+  
+CONTAINS
+
+  SUBROUTINE dissip_allocate
+  USE bands
+  USE allocate_field_mod
+  USE parallel_lmdz
+  USE dimensions_mod
+  USE gradiv2_mod, ONLY : gradiv2_allocate
+  USE nxgraro2_mod, ONLY : nxgraro2_allocate
+  USE divgrad2_mod, ONLY : divgrad2_allocate
+  IMPLICIT NONE
+
+    CALL gradiv2_allocate
+    CALL nxgraro2_allocate
+    CALL divgrad2_allocate
+
+    
+  END SUBROUTINE dissip_allocate
+  
+  SUBROUTINE dissip_switch_dissip(dist)
+  USE allocate_field_mod
+  USE bands
+  USE parallel_lmdz
+  USE gradiv2_mod,ONLY : gradiv2_switch_dissip
+  USE nxgraro2_mod,ONLY : nxgraro2_switch_dissip
+  USE divgrad2_mod,ONLY : divgrad2_switch_dissip
+  IMPLICIT NONE
+    TYPE(distrib),INTENT(IN) :: dist
+
+    CALL gradiv2_switch_dissip(dist)
+    CALL nxgraro2_switch_dissip(dist)
+    CALL divgrad2_switch_dissip(dist)
+    
+  END SUBROUTINE dissip_switch_dissip
+  
+END MODULE dissip_mod  
Index: DZ6/trunk/libf/dyn3dmem/divgrad2_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/divgrad2_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,33 +1,0 @@
-MODULE divgrad2_mod
-
-  REAL,POINTER,SAVE ::  divgra( :,: )
-  
-CONTAINS
-
-  SUBROUTINE divgrad2_allocate
-  USE bands
-  USE allocate_field_mod
-  USE parallel_lmdz
-  USE dimensions_mod
-  IMPLICIT NONE
-    TYPE(distrib),POINTER :: d
-    d=>distrib_dissip
-
-    CALL allocate_u(divgra,llm,d)
-
-    
-  END SUBROUTINE divgrad2_allocate
-  
-  SUBROUTINE divgrad2_switch_dissip(dist)
-  USE allocate_field_mod
-  USE bands
-  USE parallel_lmdz
-  IMPLICIT NONE
-    TYPE(distrib),INTENT(IN) :: dist
-
-    CALL switch_u(divgra,distrib_dissip,dist)
-
-
-  END SUBROUTINE divgrad2_switch_dissip
-  
-END MODULE divgrad2_mod  
Index: /LMDZ6/trunk/libf/dyn3dmem/divgrad2_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/divgrad2_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3dmem/divgrad2_mod.f90	(revision 5268)
@@ -0,0 +1,33 @@
+MODULE divgrad2_mod
+
+  REAL,POINTER,SAVE ::  divgra( :,: )
+  
+CONTAINS
+
+  SUBROUTINE divgrad2_allocate
+  USE bands
+  USE allocate_field_mod
+  USE parallel_lmdz
+  USE dimensions_mod
+  IMPLICIT NONE
+    TYPE(distrib),POINTER :: d
+    d=>distrib_dissip
+
+    CALL allocate_u(divgra,llm,d)
+
+    
+  END SUBROUTINE divgrad2_allocate
+  
+  SUBROUTINE divgrad2_switch_dissip(dist)
+  USE allocate_field_mod
+  USE bands
+  USE parallel_lmdz
+  IMPLICIT NONE
+    TYPE(distrib),INTENT(IN) :: dist
+
+    CALL switch_u(divgra,distrib_dissip,dist)
+
+
+  END SUBROUTINE divgrad2_switch_dissip
+  
+END MODULE divgrad2_mod  
Index: DZ6/trunk/libf/dyn3dmem/dynetat0_loc.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/dynetat0_loc.F90	(revision 5267)
+++ 	(revision )
@@ -1,308 +1,0 @@
-SUBROUTINE dynetat0_loc(fichnom,vcov,ucov,teta,q,masse,ps,phis,time)
-!
-!-------------------------------------------------------------------------------
-! Authors: P. Le Van , L.Fairhead
-!-------------------------------------------------------------------------------
-! Purpose: Initial state reading.
-!-------------------------------------------------------------------------------
-  USE parallel_lmdz
-  USE infotrac,    ONLY: nqtot, tracers, niso, iqIsoPha, iH2O, isoName, &
-                         new2oldH2O, newHNO3, oldHNO3
-  USE strings_mod, ONLY: maxlen, msg, strStack, real2str, int2str, strIdx
-  USE netcdf,      ONLY: NF90_OPEN,  NF90_NOWRITE, NF90_INQUIRE_DIMENSION, NF90_INQ_VARID, &
-                         NF90_CLOSE, NF90_GET_VAR, NF90_INQUIRE_VARIABLE,  NF90_NoErr
-  USE control_mod, ONLY: planet_type
-  USE assert_eq_m, ONLY: assert_eq
-  USE comvert_mod, ONLY: pa,preff
-  USE comconst_mod, ONLY: cpp, daysec, dtvr, g, im, jm, kappa, lllm, omeg, rad
-  USE logic_mod, ONLY: fxyhypb, ysinus
-  USE serre_mod, ONLY: clon, clat, grossismx, grossismy
-  USE temps_mod, ONLY: annee_ref, day_ini, day_ref, itau_dyn, start_time
-  USE ener_mod, ONLY: etot0,ptot0,ztot0,stot0,ang0
-  USE IOIPSL,   ONLY: getin
-  USE iso_params_mod   ! tnat_* and alpha_ideal_*
-  USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_INCA, CPPKEY_REPROBUS
-
-  IMPLICIT NONE
-  include "dimensions.h"
-  include "paramet.h"
-  include "comgeom.h"
-  include "description.h"
-  include "iniprint.h"
-!===============================================================================
-! Arguments:
-  CHARACTER(LEN=*), INTENT(IN) :: fichnom          !--- FILE NAME
-  REAL, INTENT(OUT) ::  vcov(ijb_v:ije_v,llm)      !--- V COVARIANT WIND
-  REAL, INTENT(OUT) ::  ucov(ijb_u:ije_u,llm)      !--- U COVARIANT WIND
-  REAL, INTENT(OUT) ::  teta(ijb_u:ije_u,llm)      !--- POTENTIAL TEMP.
-  REAL, INTENT(OUT) ::     q(ijb_u:ije_u,llm,nqtot)!--- TRACERS
-  REAL, INTENT(OUT) :: masse(ijb_u:ije_u,llm)      !--- MASS PER CELL
-  REAL, INTENT(OUT) ::    ps(ijb_u:ije_u)          !--- GROUND PRESSURE
-  REAL, INTENT(OUT) ::  phis(ijb_u:ije_u)          !--- GEOPOTENTIAL
-!===============================================================================
-! Local variables:
-  CHARACTER(LEN=maxlen) :: mesg, var, modname, oldVar
-  INTEGER, PARAMETER :: length=100
-  INTEGER :: iq, fID, vID, idecal, ierr, iqParent, iName, iZone, iPhase, ix
-  REAL    :: time,tab_cntrl(length)    !--- RUN PARAMS TABLE
-  REAL    :: tnat, alpha_ideal
-  REAL,             ALLOCATABLE :: vcov_glo(:,:),masse_glo(:,:),   ps_glo(:)
-  REAL,             ALLOCATABLE :: ucov_glo(:,:),    q_glo(:,:), phis_glo(:)
-  REAL,             ALLOCATABLE :: teta_glo(:,:)
-  LOGICAL :: lSkip, ll, ltnat1
-!-------------------------------------------------------------------------------
-  modname="dynetat0_loc"
-
-!--- Initial state file opening
-  var=fichnom
-  CALL err(NF90_OPEN(var,NF90_NOWRITE,fID),"open",var)
-  CALL get_var1("controle",tab_cntrl)
-
-!!! AS: idecal is a hack to be able to read planeto starts...
-!!!     .... while keeping everything OK for LMDZ EARTH
-  IF(planet_type=="generic") THEN
-    CALL msg('NOTE NOTE NOTE : Planeto-like start files', modname)
-    idecal = 4
-    annee_ref  = 2000
-  ELSE
-    CALL msg('NOTE NOTE NOTE : Earth-like start files', modname)
-    idecal = 5
-    annee_ref  = tab_cntrl(5)
-  END IF
-  im         = tab_cntrl(1)
-  jm         = tab_cntrl(2)
-  lllm       = tab_cntrl(3)
-  day_ref    = tab_cntrl(4)
-  rad        = tab_cntrl(idecal+1)
-  omeg       = tab_cntrl(idecal+2)
-  g          = tab_cntrl(idecal+3)
-  cpp        = tab_cntrl(idecal+4)
-  kappa      = tab_cntrl(idecal+5)
-  daysec     = tab_cntrl(idecal+6)
-  dtvr       = tab_cntrl(idecal+7)
-  etot0      = tab_cntrl(idecal+8)
-  ptot0      = tab_cntrl(idecal+9)
-  ztot0      = tab_cntrl(idecal+10)
-  stot0      = tab_cntrl(idecal+11)
-  ang0       = tab_cntrl(idecal+12)
-  pa         = tab_cntrl(idecal+13)
-  preff      = tab_cntrl(idecal+14)
-!
-  clon       = tab_cntrl(idecal+15)
-  clat       = tab_cntrl(idecal+16)
-  grossismx  = tab_cntrl(idecal+17)
-  grossismy  = tab_cntrl(idecal+18)
-!
-  IF ( tab_cntrl(idecal+19)==1. )  THEN
-    fxyhypb  = .TRUE.
-!   dzoomx   = tab_cntrl(25)
-!   dzoomy   = tab_cntrl(26)
-!   taux     = tab_cntrl(28)
-!   tauy     = tab_cntrl(29)
-  ELSE
-    fxyhypb = .FALSE.
-    ysinus  = tab_cntrl(idecal+22)==1.
-  END IF
-
-  day_ini    = tab_cntrl(30)
-  itau_dyn   = tab_cntrl(31)
-  start_time = tab_cntrl(32)
-
-!-------------------------------------------------------------------------------
-  CALL msg('rad, omeg, g, cpp, kappa = '//TRIM(strStack(real2str([rad,omeg,g,cpp,kappa]))), modname)
-  CALL check_dim(im,iim,'im','im')
-  CALL check_dim(jm,jjm,'jm','jm')
-  CALL check_dim(lllm,llm,'lm','lllm')
-  CALL get_var1("rlonu",rlonu)
-  CALL get_var1("rlatu",rlatu)
-  CALL get_var1("rlonv",rlonv)
-  CALL get_var1("rlatv",rlatv)
-  CALL get_var1("cu"  ,cu)
-  CALL get_var1("cv"  ,cv)
-  CALL get_var1("aire",aire)
-
-  var="temps"
-  IF(NF90_INQ_VARID(fID,var,vID)/=NF90_NoErr) THEN
-    CALL msg('missing field <temps> ; trying with <Time>', modname)
-    var="Time"
-    CALL err(NF90_INQ_VARID(fID,var,vID),"inq",var)
-  END IF
-  CALL err(NF90_GET_VAR(fID,vID,time),"get",var)
-
-  ALLOCATE(phis_glo(ip1jmp1))
-  CALL get_var1("phisinit",phis_glo)
-  phis (ijb_u:ije_u)  =phis_glo(ijb_u:ije_u);    DEALLOCATE(phis_glo)
-
-  ALLOCATE(ucov_glo(ip1jmp1,llm))
-  CALL get_var2("ucov",ucov_glo)
-  ucov (ijb_u:ije_u,:)=ucov_glo(ijb_u:ije_u,:);  DEALLOCATE(ucov_glo)
-
-  ALLOCATE(vcov_glo(ip1jm,llm))
-  CALL get_var2("vcov",vcov_glo)
-  vcov (ijb_v:ije_v,:)=vcov_glo(ijb_v:ije_v,:);  DEALLOCATE(vcov_glo)
-
-  ALLOCATE(teta_glo(ip1jmp1,llm))
-  CALL get_var2("teta",teta_glo)
-  teta (ijb_u:ije_u,:)=teta_glo(ijb_u:ije_u,:);  DEALLOCATE(teta_glo)
-
-  ALLOCATE(masse_glo(ip1jmp1,llm))
-  CALL get_var2("masse",masse_glo)
-  masse(ijb_u:ije_u,:)=masse_glo(ijb_u:ije_u,:); DEALLOCATE(masse_glo)
-  
-  ALLOCATE(ps_glo(ip1jmp1))
-  CALL get_var1("ps",ps_glo)
-  ps   (ijb_u:ije_u)  =   ps_glo(ijb_u:ije_u);   DEALLOCATE(ps_glo)
-
-!--- Tracers
-  ALLOCATE(q_glo(ip1jmp1,llm))
-  ll = .FALSE.
-IF (CPPKEY_REPROBUS) THEN
-  ll = NF90_INQ_VARID(fID, 'HNO3tot', vID) /= NF90_NoErr                                 !--- DETECT OLD REPRO start.nc FILE
-END IF
-  ltnat1 = .TRUE.; CALL getin('tnateq1', ltnat1)
-  DO iq=1,nqtot
-    var = tracers(iq)%name
-    oldVar = new2oldH2O(var)
-    lSkip = ll .AND. var == 'HNO3'                                                       !--- FORCE "HNO3_g" READING FOR "HNO3"
-IF (CPPKEY_REPROBUS) THEN
-    ix = strIdx(newHNO3, var); IF(ix /= 0) oldVar = oldHNO3(ix)                          !--- REPROBUS HNO3 exceptions
-END IF
-IF (CPPKEY_INCA) THEN
-    IF(var == 'O3') oldVar = 'OX'                                                        !--- DEAL WITH INCA OZONE EXCEPTION
-END IF
-    !--------------------------------------------------------------------------------------------------------------------------
-    IF(NF90_INQ_VARID(fID, var, vID) == NF90_NoErr .AND. .NOT.lSkip) THEN                !=== REGULAR CASE: AVAILABLE VARIABLE
-      CALL get_var2(var,q_glo); q(ijb_u:ije_u,:,iq)=q_glo(ijb_u:ije_u,:)
-    !--------------------------------------------------------------------------------------------------------------------------
-    ELSE IF(NF90_INQ_VARID(fID, oldVar, vID) == NF90_NoErr) THEN                         !=== TRY WITH ALTERNATE NAME
-      CALL msg('Missing tracer <'//TRIM(var)//'> => initialized to <'//TRIM(oldVar)//'>', modname)
-      CALL get_var2(oldVar, q_glo); q(ijb_u:ije_u,:,iq)=q_glo(ijb_u:ije_u,:)
-    !--------------------------------------------------------------------------------------------------------------------------
-    ELSE IF(tracers(iq)%iso_iGroup == iH2O .AND. niso > 0) THEN                          !=== WATER ISOTOPES
-      iName    = tracers(iq)%iso_iName
-      iPhase   = tracers(iq)%iso_iPhase
-      iqParent = tracers(iq)%iqParent
-      IF(tracers(iq)%iso_iZone == 0) THEN
-         IF(ltnat1) THEN
-            tnat = 1.0
-            alpha_ideal = 1.0
-            CALL msg(' !!!  Beware: alpha_ideal put to 1  !!!', modname)
-         ELSE
-            SELECT CASE(isoName(iName))
-              CASE('H216O'); tnat = tnat_H216O; alpha_ideal = alpha_ideal_H216O
-              CASE('H217O'); tnat = tnat_H217O; alpha_ideal = alpha_ideal_H217O
-              CASE('H218O'); tnat = tnat_H218O; alpha_ideal = alpha_ideal_H218O
-              CASE('HDO');   tnat = tnat_HDO;   alpha_ideal = alpha_ideal_HDO
-              CASE('HTO');   tnat = tnat_HTO;   alpha_ideal = alpha_ideal_HTO
-              CASE DEFAULT; CALL abort_gcm(TRIM(modname),'unknown isotope "'//TRIM(isoName(iName))//'" ; check tracer.def file',1)
-            END SELECT
-         END IF
-         CALL msg('Missing tracer <'//TRIM(var)//'> => initialized with a simplified Rayleigh distillation law.', modname)
-         q(ijb_u:ije_u,:,iq) = q(ijb_u:ije_u,:,iqParent)*tnat*(q(ijb_u:ije_u,:,iqParent)/30.e-3)**(alpha_ideal-1.)
-         ! Camille 9 mars 2023: point de vigilence: initialisation incohérente
-         ! avec celle de xt_ancien dans la physiq.
-      ELSE
-         CALL msg('Missing tracer <'//TRIM(var)//'> => initialized to its parent isotope concentration.', modname)
-         ! Camille 9 mars 2023: attention!! seuls les tags qui correspondent à
-         ! izone=izone_init (définie dans isotrac_mod) sont initialisés comme
-         ! les parents. Sinon, c'est nul.
-         ! j'ai fait ça en attendant, mais il faudrait initialiser proprement en
-         ! remplacant 1 par izone_init dans la ligne qui suit.
-         IF(tracers(iq)%iso_iZone == 1) THEN
-           q(ijb_u:ije_u,:,iq) = q(ijb_u:ije_u,:,iqIsoPha(iName,iPhase))
-         ELSE
-           q(ijb_u:ije_u,:,iq) =  0.
-         ENDIF
-      END IF
-    !--------------------------------------------------------------------------------------------------------------------------
-    ELSE                                                                                 !=== MISSING: SET TO 0
-      CALL msg('missing tracer <'//TRIM(var)//'> => initialized to zero', modname)
-      q(ijb_u:ije_u,:,iq)=0.
-    !--------------------------------------------------------------------------------------------------------------------------
-    END IF
-  END DO
-  DEALLOCATE(q_glo)
-  CALL err(NF90_CLOSE(fID),"close",fichnom)
-  day_ini=day_ini+INT(time)
-  time=time-INT(time)
-
-
-  CONTAINS
-
-
-SUBROUTINE check_dim(n1,n2,str1,str2)
-  INTEGER,          INTENT(IN) :: n1, n2
-  CHARACTER(LEN=*), INTENT(IN) :: str1, str2
-  CHARACTER(LEN=maxlen) :: s1, s2
-  IF(n1/=n2) CALL abort_gcm(TRIM(modname), 'value of "'//TRIM(str1)//'" = '//TRIM(int2str(n1))// &
-   ' read in starting file differs from gcm value of "'//TRIM(str2)//'" = '//TRIM(int2str(n2)), 1)
-END SUBROUTINE check_dim
-
-
-SUBROUTINE get_var1(var,v)
-  CHARACTER(LEN=*), INTENT(IN)  :: var
-  REAL,             INTENT(OUT) :: v(:)
-  REAL,             ALLOCATABLE :: w2(:,:), w3(:,:,:)
-  INTEGER :: nn(3), dids(3), k, nd, ntot
-
-  CALL err(NF90_INQ_VARID(fID,var,vID),"inq",var)
-  ierr=NF90_INQUIRE_VARIABLE(fID,vID,ndims=nd)
-  IF(nd==1) THEN
-    CALL err(NF90_GET_VAR(fID,vID,v),"get",var); RETURN
-  END IF
-  ierr=NF90_INQUIRE_VARIABLE(fID,vID,dimids=dids)
-  DO k=1,nd; ierr=NF90_INQUIRE_DIMENSION(fID,dids(k),len=nn(k)); END DO
-  ntot=PRODUCT(nn(1:nd))
-  SELECT CASE(nd)
-    CASE(2); ALLOCATE(w2(nn(1),nn(2)))
-      CALL err(NF90_GET_VAR(fID,vID,w2),"get",var)
-      v=RESHAPE(w2,[ntot]); DEALLOCATE(w2)
-    CASE(3); ALLOCATE(w3(nn(1),nn(2),nn(3)))
-      CALL err(NF90_GET_VAR(fID,vID,w3),"get",var)
-      v=RESHAPE(w3,[ntot]); DEALLOCATE(w3)
-  END SELECT
-END SUBROUTINE get_var1
-
-SUBROUTINE get_var2(var,v)
-  CHARACTER(LEN=*), INTENT(IN)  :: var
-  REAL,             INTENT(OUT) :: v(:,:)
-  REAL,             ALLOCATABLE :: w4(:,:,:,:), w3(:,:,:)
-  INTEGER :: nn(4), dids(4), k, nd
-
-
-  CALL err(NF90_INQ_VARID(fID,var,vID),"inq",var)
-  ierr=NF90_INQUIRE_VARIABLE(fID,vID,ndims=nd)
-
-  IF(nd==1) THEN
-    CALL err(NF90_GET_VAR(fID,vID,v),"get",var); RETURN
-  END IF
-  ierr=NF90_INQUIRE_VARIABLE(fID,vID,dimids=dids)
-
-  DO k=1,nd; ierr=NF90_INQUIRE_DIMENSION(fID,dids(k),len=nn(k)); END DO
-
-  SELECT CASE(nd)
-  CASE(3); ALLOCATE(w3(nn(1),nn(2),nn(3)))
-     CALL err(NF90_GET_VAR(fID,vID,w3),"get",var)
-     v=RESHAPE(w3,[nn(1)*nn(2),nn(3)]); DEALLOCATE(w3)
-  CASE(4);  ALLOCATE(w4(nn(1),nn(2),nn(3),nn(4)))
-     CALL err(NF90_GET_VAR(fID,vID,w4),"get",var)
-     v=RESHAPE(w4,[nn(1)*nn(2),nn(3)]); DEALLOCATE(w4)
-  END SELECT
-END SUBROUTINE get_var2
-
-
-SUBROUTINE err(ierr,typ,nam)
-  INTEGER,          INTENT(IN) :: ierr   !--- NetCDF ERROR CODE
-  CHARACTER(LEN=*), INTENT(IN) :: typ    !--- TYPE OF OPERATION
-  CHARACTER(LEN=*), INTENT(IN) :: nam    !--- FIELD/FILE NAME
-  IF(ierr==NF90_NoERR) RETURN
-  SELECT CASE(typ)
-    CASE('inq');   mesg="Field <"//TRIM(nam)//"> is missing"
-    CASE('get');   mesg="Reading failed for <"//TRIM(nam)//">"
-    CASE('open');  mesg="File opening failed for <"//TRIM(nam)//">"
-    CASE('close'); mesg="File closing failed for <"//TRIM(nam)//">"
-  END SELECT
-  CALL ABORT_gcm(TRIM(modname),TRIM(mesg),ierr)
-END SUBROUTINE err
-
-END SUBROUTINE dynetat0_loc
Index: /LMDZ6/trunk/libf/dyn3dmem/dynetat0_loc.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/dynetat0_loc.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3dmem/dynetat0_loc.f90	(revision 5268)
@@ -0,0 +1,308 @@
+SUBROUTINE dynetat0_loc(fichnom,vcov,ucov,teta,q,masse,ps,phis,time)
+!
+!-------------------------------------------------------------------------------
+! Authors: P. Le Van , L.Fairhead
+!-------------------------------------------------------------------------------
+! Purpose: Initial state reading.
+!-------------------------------------------------------------------------------
+  USE parallel_lmdz
+  USE infotrac,    ONLY: nqtot, tracers, niso, iqIsoPha, iH2O, isoName, &
+                         new2oldH2O, newHNO3, oldHNO3
+  USE strings_mod, ONLY: maxlen, msg, strStack, real2str, int2str, strIdx
+  USE netcdf,      ONLY: NF90_OPEN,  NF90_NOWRITE, NF90_INQUIRE_DIMENSION, NF90_INQ_VARID, &
+                         NF90_CLOSE, NF90_GET_VAR, NF90_INQUIRE_VARIABLE,  NF90_NoErr
+  USE control_mod, ONLY: planet_type
+  USE assert_eq_m, ONLY: assert_eq
+  USE comvert_mod, ONLY: pa,preff
+  USE comconst_mod, ONLY: cpp, daysec, dtvr, g, im, jm, kappa, lllm, omeg, rad
+  USE logic_mod, ONLY: fxyhypb, ysinus
+  USE serre_mod, ONLY: clon, clat, grossismx, grossismy
+  USE temps_mod, ONLY: annee_ref, day_ini, day_ref, itau_dyn, start_time
+  USE ener_mod, ONLY: etot0,ptot0,ztot0,stot0,ang0
+  USE IOIPSL,   ONLY: getin
+  USE iso_params_mod   ! tnat_* and alpha_ideal_*
+  USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_INCA, CPPKEY_REPROBUS
+
+  IMPLICIT NONE
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom.h"
+  include "description.h"
+  include "iniprint.h"
+!===============================================================================
+! Arguments:
+  CHARACTER(LEN=*), INTENT(IN) :: fichnom          !--- FILE NAME
+  REAL, INTENT(OUT) ::  vcov(ijb_v:ije_v,llm)      !--- V COVARIANT WIND
+  REAL, INTENT(OUT) ::  ucov(ijb_u:ije_u,llm)      !--- U COVARIANT WIND
+  REAL, INTENT(OUT) ::  teta(ijb_u:ije_u,llm)      !--- POTENTIAL TEMP.
+  REAL, INTENT(OUT) ::     q(ijb_u:ije_u,llm,nqtot)!--- TRACERS
+  REAL, INTENT(OUT) :: masse(ijb_u:ije_u,llm)      !--- MASS PER CELL
+  REAL, INTENT(OUT) ::    ps(ijb_u:ije_u)          !--- GROUND PRESSURE
+  REAL, INTENT(OUT) ::  phis(ijb_u:ije_u)          !--- GEOPOTENTIAL
+!===============================================================================
+! Local variables:
+  CHARACTER(LEN=maxlen) :: mesg, var, modname, oldVar
+  INTEGER, PARAMETER :: length=100
+  INTEGER :: iq, fID, vID, idecal, ierr, iqParent, iName, iZone, iPhase, ix
+  REAL    :: time,tab_cntrl(length)    !--- RUN PARAMS TABLE
+  REAL    :: tnat, alpha_ideal
+  REAL,             ALLOCATABLE :: vcov_glo(:,:),masse_glo(:,:),   ps_glo(:)
+  REAL,             ALLOCATABLE :: ucov_glo(:,:),    q_glo(:,:), phis_glo(:)
+  REAL,             ALLOCATABLE :: teta_glo(:,:)
+  LOGICAL :: lSkip, ll, ltnat1
+!-------------------------------------------------------------------------------
+  modname="dynetat0_loc"
+
+!--- Initial state file opening
+  var=fichnom
+  CALL err(NF90_OPEN(var,NF90_NOWRITE,fID),"open",var)
+  CALL get_var1("controle",tab_cntrl)
+
+!!! AS: idecal is a hack to be able to read planeto starts...
+!!!     .... while keeping everything OK for LMDZ EARTH
+  IF(planet_type=="generic") THEN
+    CALL msg('NOTE NOTE NOTE : Planeto-like start files', modname)
+    idecal = 4
+    annee_ref  = 2000
+  ELSE
+    CALL msg('NOTE NOTE NOTE : Earth-like start files', modname)
+    idecal = 5
+    annee_ref  = tab_cntrl(5)
+  END IF
+  im         = tab_cntrl(1)
+  jm         = tab_cntrl(2)
+  lllm       = tab_cntrl(3)
+  day_ref    = tab_cntrl(4)
+  rad        = tab_cntrl(idecal+1)
+  omeg       = tab_cntrl(idecal+2)
+  g          = tab_cntrl(idecal+3)
+  cpp        = tab_cntrl(idecal+4)
+  kappa      = tab_cntrl(idecal+5)
+  daysec     = tab_cntrl(idecal+6)
+  dtvr       = tab_cntrl(idecal+7)
+  etot0      = tab_cntrl(idecal+8)
+  ptot0      = tab_cntrl(idecal+9)
+  ztot0      = tab_cntrl(idecal+10)
+  stot0      = tab_cntrl(idecal+11)
+  ang0       = tab_cntrl(idecal+12)
+  pa         = tab_cntrl(idecal+13)
+  preff      = tab_cntrl(idecal+14)
+!
+  clon       = tab_cntrl(idecal+15)
+  clat       = tab_cntrl(idecal+16)
+  grossismx  = tab_cntrl(idecal+17)
+  grossismy  = tab_cntrl(idecal+18)
+!
+  IF ( tab_cntrl(idecal+19)==1. )  THEN
+    fxyhypb  = .TRUE.
+!   dzoomx   = tab_cntrl(25)
+!   dzoomy   = tab_cntrl(26)
+!   taux     = tab_cntrl(28)
+!   tauy     = tab_cntrl(29)
+  ELSE
+    fxyhypb = .FALSE.
+    ysinus  = tab_cntrl(idecal+22)==1.
+  END IF
+
+  day_ini    = tab_cntrl(30)
+  itau_dyn   = tab_cntrl(31)
+  start_time = tab_cntrl(32)
+
+!-------------------------------------------------------------------------------
+  CALL msg('rad, omeg, g, cpp, kappa = '//TRIM(strStack(real2str([rad,omeg,g,cpp,kappa]))), modname)
+  CALL check_dim(im,iim,'im','im')
+  CALL check_dim(jm,jjm,'jm','jm')
+  CALL check_dim(lllm,llm,'lm','lllm')
+  CALL get_var1("rlonu",rlonu)
+  CALL get_var1("rlatu",rlatu)
+  CALL get_var1("rlonv",rlonv)
+  CALL get_var1("rlatv",rlatv)
+  CALL get_var1("cu"  ,cu)
+  CALL get_var1("cv"  ,cv)
+  CALL get_var1("aire",aire)
+
+  var="temps"
+  IF(NF90_INQ_VARID(fID,var,vID)/=NF90_NoErr) THEN
+    CALL msg('missing field <temps> ; trying with <Time>', modname)
+    var="Time"
+    CALL err(NF90_INQ_VARID(fID,var,vID),"inq",var)
+  END IF
+  CALL err(NF90_GET_VAR(fID,vID,time),"get",var)
+
+  ALLOCATE(phis_glo(ip1jmp1))
+  CALL get_var1("phisinit",phis_glo)
+  phis (ijb_u:ije_u)  =phis_glo(ijb_u:ije_u);    DEALLOCATE(phis_glo)
+
+  ALLOCATE(ucov_glo(ip1jmp1,llm))
+  CALL get_var2("ucov",ucov_glo)
+  ucov (ijb_u:ije_u,:)=ucov_glo(ijb_u:ije_u,:);  DEALLOCATE(ucov_glo)
+
+  ALLOCATE(vcov_glo(ip1jm,llm))
+  CALL get_var2("vcov",vcov_glo)
+  vcov (ijb_v:ije_v,:)=vcov_glo(ijb_v:ije_v,:);  DEALLOCATE(vcov_glo)
+
+  ALLOCATE(teta_glo(ip1jmp1,llm))
+  CALL get_var2("teta",teta_glo)
+  teta (ijb_u:ije_u,:)=teta_glo(ijb_u:ije_u,:);  DEALLOCATE(teta_glo)
+
+  ALLOCATE(masse_glo(ip1jmp1,llm))
+  CALL get_var2("masse",masse_glo)
+  masse(ijb_u:ije_u,:)=masse_glo(ijb_u:ije_u,:); DEALLOCATE(masse_glo)
+  
+  ALLOCATE(ps_glo(ip1jmp1))
+  CALL get_var1("ps",ps_glo)
+  ps   (ijb_u:ije_u)  =   ps_glo(ijb_u:ije_u);   DEALLOCATE(ps_glo)
+
+!--- Tracers
+  ALLOCATE(q_glo(ip1jmp1,llm))
+  ll = .FALSE.
+IF (CPPKEY_REPROBUS) THEN
+  ll = NF90_INQ_VARID(fID, 'HNO3tot', vID) /= NF90_NoErr                                 !--- DETECT OLD REPRO start.nc FILE
+END IF
+  ltnat1 = .TRUE.; CALL getin('tnateq1', ltnat1)
+  DO iq=1,nqtot
+    var = tracers(iq)%name
+    oldVar = new2oldH2O(var)
+    lSkip = ll .AND. var == 'HNO3'                                                       !--- FORCE "HNO3_g" READING FOR "HNO3"
+IF (CPPKEY_REPROBUS) THEN
+    ix = strIdx(newHNO3, var); IF(ix /= 0) oldVar = oldHNO3(ix)                          !--- REPROBUS HNO3 exceptions
+END IF
+IF (CPPKEY_INCA) THEN
+    IF(var == 'O3') oldVar = 'OX'                                                        !--- DEAL WITH INCA OZONE EXCEPTION
+END IF
+    !--------------------------------------------------------------------------------------------------------------------------
+    IF(NF90_INQ_VARID(fID, var, vID) == NF90_NoErr .AND. .NOT.lSkip) THEN                !=== REGULAR CASE: AVAILABLE VARIABLE
+      CALL get_var2(var,q_glo); q(ijb_u:ije_u,:,iq)=q_glo(ijb_u:ije_u,:)
+    !--------------------------------------------------------------------------------------------------------------------------
+    ELSE IF(NF90_INQ_VARID(fID, oldVar, vID) == NF90_NoErr) THEN                         !=== TRY WITH ALTERNATE NAME
+      CALL msg('Missing tracer <'//TRIM(var)//'> => initialized to <'//TRIM(oldVar)//'>', modname)
+      CALL get_var2(oldVar, q_glo); q(ijb_u:ije_u,:,iq)=q_glo(ijb_u:ije_u,:)
+    !--------------------------------------------------------------------------------------------------------------------------
+    ELSE IF(tracers(iq)%iso_iGroup == iH2O .AND. niso > 0) THEN                          !=== WATER ISOTOPES
+      iName    = tracers(iq)%iso_iName
+      iPhase   = tracers(iq)%iso_iPhase
+      iqParent = tracers(iq)%iqParent
+      IF(tracers(iq)%iso_iZone == 0) THEN
+         IF(ltnat1) THEN
+            tnat = 1.0
+            alpha_ideal = 1.0
+            CALL msg(' !!!  Beware: alpha_ideal put to 1  !!!', modname)
+         ELSE
+            SELECT CASE(isoName(iName))
+              CASE('H216O'); tnat = tnat_H216O; alpha_ideal = alpha_ideal_H216O
+              CASE('H217O'); tnat = tnat_H217O; alpha_ideal = alpha_ideal_H217O
+              CASE('H218O'); tnat = tnat_H218O; alpha_ideal = alpha_ideal_H218O
+              CASE('HDO');   tnat = tnat_HDO;   alpha_ideal = alpha_ideal_HDO
+              CASE('HTO');   tnat = tnat_HTO;   alpha_ideal = alpha_ideal_HTO
+              CASE DEFAULT; CALL abort_gcm(TRIM(modname),'unknown isotope "'//TRIM(isoName(iName))//'" ; check tracer.def file',1)
+            END SELECT
+         END IF
+         CALL msg('Missing tracer <'//TRIM(var)//'> => initialized with a simplified Rayleigh distillation law.', modname)
+         q(ijb_u:ije_u,:,iq) = q(ijb_u:ije_u,:,iqParent)*tnat*(q(ijb_u:ije_u,:,iqParent)/30.e-3)**(alpha_ideal-1.)
+         ! Camille 9 mars 2023: point de vigilence: initialisation incohérente
+         ! avec celle de xt_ancien dans la physiq.
+      ELSE
+         CALL msg('Missing tracer <'//TRIM(var)//'> => initialized to its parent isotope concentration.', modname)
+         ! Camille 9 mars 2023: attention!! seuls les tags qui correspondent à
+         ! izone=izone_init (définie dans isotrac_mod) sont initialisés comme
+         ! les parents. Sinon, c'est nul.
+         ! j'ai fait ça en attendant, mais il faudrait initialiser proprement en
+         ! remplacant 1 par izone_init dans la ligne qui suit.
+         IF(tracers(iq)%iso_iZone == 1) THEN
+           q(ijb_u:ije_u,:,iq) = q(ijb_u:ije_u,:,iqIsoPha(iName,iPhase))
+         ELSE
+           q(ijb_u:ije_u,:,iq) =  0.
+         ENDIF
+      END IF
+    !--------------------------------------------------------------------------------------------------------------------------
+    ELSE                                                                                 !=== MISSING: SET TO 0
+      CALL msg('missing tracer <'//TRIM(var)//'> => initialized to zero', modname)
+      q(ijb_u:ije_u,:,iq)=0.
+    !--------------------------------------------------------------------------------------------------------------------------
+    END IF
+  END DO
+  DEALLOCATE(q_glo)
+  CALL err(NF90_CLOSE(fID),"close",fichnom)
+  day_ini=day_ini+INT(time)
+  time=time-INT(time)
+
+
+  CONTAINS
+
+
+SUBROUTINE check_dim(n1,n2,str1,str2)
+  INTEGER,          INTENT(IN) :: n1, n2
+  CHARACTER(LEN=*), INTENT(IN) :: str1, str2
+  CHARACTER(LEN=maxlen) :: s1, s2
+  IF(n1/=n2) CALL abort_gcm(TRIM(modname), 'value of "'//TRIM(str1)//'" = '//TRIM(int2str(n1))// &
+   ' read in starting file differs from gcm value of "'//TRIM(str2)//'" = '//TRIM(int2str(n2)), 1)
+END SUBROUTINE check_dim
+
+
+SUBROUTINE get_var1(var,v)
+  CHARACTER(LEN=*), INTENT(IN)  :: var
+  REAL,             INTENT(OUT) :: v(:)
+  REAL,             ALLOCATABLE :: w2(:,:), w3(:,:,:)
+  INTEGER :: nn(3), dids(3), k, nd, ntot
+
+  CALL err(NF90_INQ_VARID(fID,var,vID),"inq",var)
+  ierr=NF90_INQUIRE_VARIABLE(fID,vID,ndims=nd)
+  IF(nd==1) THEN
+    CALL err(NF90_GET_VAR(fID,vID,v),"get",var); RETURN
+  END IF
+  ierr=NF90_INQUIRE_VARIABLE(fID,vID,dimids=dids)
+  DO k=1,nd; ierr=NF90_INQUIRE_DIMENSION(fID,dids(k),len=nn(k)); END DO
+  ntot=PRODUCT(nn(1:nd))
+  SELECT CASE(nd)
+    CASE(2); ALLOCATE(w2(nn(1),nn(2)))
+      CALL err(NF90_GET_VAR(fID,vID,w2),"get",var)
+      v=RESHAPE(w2,[ntot]); DEALLOCATE(w2)
+    CASE(3); ALLOCATE(w3(nn(1),nn(2),nn(3)))
+      CALL err(NF90_GET_VAR(fID,vID,w3),"get",var)
+      v=RESHAPE(w3,[ntot]); DEALLOCATE(w3)
+  END SELECT
+END SUBROUTINE get_var1
+
+SUBROUTINE get_var2(var,v)
+  CHARACTER(LEN=*), INTENT(IN)  :: var
+  REAL,             INTENT(OUT) :: v(:,:)
+  REAL,             ALLOCATABLE :: w4(:,:,:,:), w3(:,:,:)
+  INTEGER :: nn(4), dids(4), k, nd
+
+
+  CALL err(NF90_INQ_VARID(fID,var,vID),"inq",var)
+  ierr=NF90_INQUIRE_VARIABLE(fID,vID,ndims=nd)
+
+  IF(nd==1) THEN
+    CALL err(NF90_GET_VAR(fID,vID,v),"get",var); RETURN
+  END IF
+  ierr=NF90_INQUIRE_VARIABLE(fID,vID,dimids=dids)
+
+  DO k=1,nd; ierr=NF90_INQUIRE_DIMENSION(fID,dids(k),len=nn(k)); END DO
+
+  SELECT CASE(nd)
+  CASE(3); ALLOCATE(w3(nn(1),nn(2),nn(3)))
+     CALL err(NF90_GET_VAR(fID,vID,w3),"get",var)
+     v=RESHAPE(w3,[nn(1)*nn(2),nn(3)]); DEALLOCATE(w3)
+  CASE(4);  ALLOCATE(w4(nn(1),nn(2),nn(3),nn(4)))
+     CALL err(NF90_GET_VAR(fID,vID,w4),"get",var)
+     v=RESHAPE(w4,[nn(1)*nn(2),nn(3)]); DEALLOCATE(w4)
+  END SELECT
+END SUBROUTINE get_var2
+
+
+SUBROUTINE err(ierr,typ,nam)
+  INTEGER,          INTENT(IN) :: ierr   !--- NetCDF ERROR CODE
+  CHARACTER(LEN=*), INTENT(IN) :: typ    !--- TYPE OF OPERATION
+  CHARACTER(LEN=*), INTENT(IN) :: nam    !--- FIELD/FILE NAME
+  IF(ierr==NF90_NoERR) RETURN
+  SELECT CASE(typ)
+    CASE('inq');   mesg="Field <"//TRIM(nam)//"> is missing"
+    CASE('get');   mesg="Reading failed for <"//TRIM(nam)//">"
+    CASE('open');  mesg="File opening failed for <"//TRIM(nam)//">"
+    CASE('close'); mesg="File closing failed for <"//TRIM(nam)//">"
+  END SELECT
+  CALL ABORT_gcm(TRIM(modname),TRIM(mesg),ierr)
+END SUBROUTINE err
+
+END SUBROUTINE dynetat0_loc
Index: DZ6/trunk/libf/dyn3dmem/dynredem_loc.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/dynredem_loc.F90	(revision 5267)
+++ 	(revision )
@@ -1,267 +1,0 @@
-SUBROUTINE dynredem0_loc(fichnom,iday_end,phis)
-!
-!-------------------------------------------------------------------------------
-! Write the NetCDF restart file (initialization).
-!-------------------------------------------------------------------------------
-  USE IOIPSL
-  USE parallel_lmdz
-  USE mod_hallo
-  USE strings_mod, ONLY: maxlen
-  USE infotrac, ONLY: nqtot, tracers
-  USE netcdf, ONLY: NF90_CREATE, NF90_DEF_DIM, NF90_INQ_VARID, NF90_GLOBAL,    &
-                    NF90_CLOSE,  NF90_PUT_ATT, NF90_UNLIMITED, NF90_CLOBBER,   &
-                    NF90_64BIT_OFFSET
-  USE dynredem_mod, ONLY: cre_var, put_var, err, modname, fil
-  USE comvert_mod,  ONLY: ap, bp, presnivs, pa, preff, nivsig, nivsigs,&
-                          aps,bps,pseudoalt
-  USE comconst_mod, ONLY: cpp, daysec, dtvr, g, kappa, omeg, rad
-  USE logic_mod, ONLY: fxyhypb, ysinus
-  USE serre_mod, ONLY: clon,clat,grossismx,grossismy,dzoomx,dzoomy, &
-                       taux,tauy
-  USE temps_mod, ONLY: annee_ref, day_ref, itau_dyn, itaufin, start_time
-  USE ener_mod, ONLY: etot0,ptot0,ztot0,stot0,ang0
-
-  IMPLICIT NONE
-  include "dimensions.h"
-  include "paramet.h"
-  include "comgeom.h"
-  include "description.h"
-  include "iniprint.h"
-!===============================================================================
-! Arguments:
-  CHARACTER(LEN=*), INTENT(IN) :: fichnom          !--- FILE NAME
-  INTEGER,          INTENT(IN) :: iday_end         !--- 
-  REAL,             INTENT(IN) :: phis(ijb_u:ije_u)!--- GROUND GEOPOTENTIAL
-!===============================================================================
-! Local variables:
-  INTEGER :: iq
-  INTEGER, PARAMETER :: length=100
-  REAL    :: tab_cntrl(length)                     !--- RUN PARAMETERS TABLE
-  REAL    :: phis_glo(ip1jmp1)
-!   For NetCDF:
-  CHARACTER(LEN=maxlen) :: unites
-  INTEGER :: indexID
-  INTEGER :: rlonuID, rlonvID, rlatuID, rlatvID
-  INTEGER :: sID, sigID, nID, timID
-  INTEGER :: yyears0, jjour0, mmois0
-  REAL    :: zjulian, hours
-!===============================================================================
-  modname='dynredem0'; fil=fichnom
-  CALL Gather_field_u(phis,phis_glo,1)
-  IF(mpi_rank/=0) RETURN
-
-  CALL ymds2ju(annee_ref, 1, iday_end, 0.0, zjulian)
-  CALL ju2ymds(zjulian, yyears0, mmois0, jjour0, hours)
-
-
-  tab_cntrl(:)  = 0.
-  tab_cntrl(1)  = REAL(iim)
-  tab_cntrl(2)  = REAL(jjm)
-  tab_cntrl(3)  = REAL(llm)
-  tab_cntrl(4)  = REAL(day_ref)
-  tab_cntrl(5)  = REAL(annee_ref)
-  tab_cntrl(6)  = rad
-  tab_cntrl(7)  = omeg
-  tab_cntrl(8)  = g
-  tab_cntrl(9)  = cpp
-  tab_cntrl(10) = kappa
-  tab_cntrl(11) = daysec
-  tab_cntrl(12) = dtvr
-  tab_cntrl(13) = etot0
-  tab_cntrl(14) = ptot0
-  tab_cntrl(15) = ztot0
-  tab_cntrl(16) = stot0
-  tab_cntrl(17) = ang0
-  tab_cntrl(18) = pa
-  tab_cntrl(19) = preff
-
-!    .....    parameters for zoom    ......   
-  tab_cntrl(20) = clon
-  tab_cntrl(21) = clat
-  tab_cntrl(22) = grossismx
-  tab_cntrl(23) = grossismy
-!
-  IF ( fxyhypb )   THEN
-    tab_cntrl(24) = 1.
-    tab_cntrl(25) = dzoomx
-    tab_cntrl(26) = dzoomy
-    tab_cntrl(27) = 0.
-    tab_cntrl(28) = taux
-    tab_cntrl(29) = tauy
-  ELSE
-    tab_cntrl(24) = 0.
-    tab_cntrl(25) = dzoomx
-    tab_cntrl(26) = dzoomy
-    tab_cntrl(27) = 0.
-    tab_cntrl(28) = 0.
-    tab_cntrl(29) = 0.
-    IF( ysinus )  tab_cntrl(27) = 1.
-  END IF
-  tab_cntrl(30) = REAL(iday_end)
-  tab_cntrl(31) = REAL(itau_dyn + itaufin)
-! start_time: start_time of simulation (not necessarily 0.)
-  tab_cntrl(32) = start_time
-
-!--- File creation
-  CALL err(NF90_CREATE(fichnom,IOR(NF90_CLOBBER,NF90_64BIT_OFFSET),nid))
-
-!--- Some global attributes
-  CALL err(NF90_PUT_ATT(nid,NF90_GLOBAL,"title","Fichier demarrage dynamique"))
-
-!--- Dimensions
-  CALL err(NF90_DEF_DIM(nid,"index", length, indexID))
-  CALL err(NF90_DEF_DIM(nid,"rlonu", iip1,   rlonuID))
-  CALL err(NF90_DEF_DIM(nid,"rlatu", jjp1,   rlatuID))
-  CALL err(NF90_DEF_DIM(nid,"rlonv", iip1,   rlonvID))
-  CALL err(NF90_DEF_DIM(nid,"rlatv", jjm,    rlatvID))
-  CALL err(NF90_DEF_DIM(nid,"sigs",  llm,        sID))
-  CALL err(NF90_DEF_DIM(nid,"sig",   llmp1,    sigID))
-  CALL err(NF90_DEF_DIM(nid,"temps", NF90_UNLIMITED, timID))
-
-!--- Define and save invariant fields
-  CALL put_var(nid,"controle","Parametres de controle" ,[indexID],tab_cntrl)
-  CALL put_var(nid,"rlonu"   ,"Longitudes des points U",[rlonuID],rlonu)
-  CALL put_var(nid,"rlatu"   ,"Latitudes des points U" ,[rlatuID],rlatu)
-  CALL put_var(nid,"rlonv"   ,"Longitudes des points V",[rlonvID],rlonv)
-  CALL put_var(nid,"rlatv"   ,"Latitudes des points V" ,[rlatvID],rlatv)
-  CALL put_var(nid,"nivsigs" ,"Numero naturel des couches s"    ,[sID]  ,nivsigs)
-  CALL put_var(nid,"nivsig"  ,"Numero naturel des couches sigma",[sigID],nivsig)
-  CALL put_var(nid,"ap"      ,"Coefficient A pour hybride"      ,[sigID],ap)
-  CALL put_var(nid,"bp"      ,"Coefficient B pour hybride"      ,[sigID],bp)
-  CALL put_var(nid,"presnivs",""                                ,[sID]  ,presnivs)
-! covariant <-> contravariant <-> natural conversion coefficients
-  CALL put_var(nid,"cu","Coefficient de passage pour U",[rlonuID,rlatuID],cu)
-  CALL put_var(nid,"cv","Coefficient de passage pour V",[rlonvID,rlatvID],cv)
-  CALL put_var(nid,"aire","Aires de chaque maille"     ,[rlonvID,rlatuID],aire)
-  CALL put_var(nid,"phisinit","Geopotentiel au sol"    ,[rlonvID,rlatuID],phis_glo)
-
-!--- Define fields saved later
-  WRITE(unites,"('days since ',i4,'-',i2.2,'-',i2.2,' 00:00:00')") &
-               yyears0,mmois0,jjour0
-  CALL cre_var(nid,"temps","Temps de simulation",[timID],unites)
-  CALL cre_var(nid,"ucov" ,"Vitesse U"  ,[rlonuID,rlatuID,sID,timID])
-  CALL cre_var(nid,"vcov" ,"Vitesse V"  ,[rlonvID,rlatvID,sID,timID])
-  CALL cre_var(nid,"teta" ,"Temperature",[rlonvID,rlatuID,sID,timID])
-  DO iq=1,nqtot
-    CALL cre_var(nid,tracers(iq)%name,tracers(iq)%longName,[rlonvID,rlatuID,sID,timID])
-  END DO
-  CALL cre_var(nid,"masse","Masse d air"    ,[rlonvID,rlatuID,sID,timID])
-  CALL cre_var(nid,"ps"   ,"Pression au sol",[rlonvID,rlatuID    ,timID])
-  CALL err(NF90_CLOSE (nid))
-
-  WRITE(lunout,*)TRIM(modname)//': iim,jjm,llm,iday_end',iim,jjm,llm,iday_end
-  WRITE(lunout,*)TRIM(modname)//': rad,omeg,g,cpp,kappa',rad,omeg,g,cpp,kappa
-
-END SUBROUTINE dynredem0_loc
-!
-!-------------------------------------------------------------------------------
-
-
-!-------------------------------------------------------------------------------
-!
-SUBROUTINE dynredem1_loc(fichnom,time,vcov,ucov,teta,q,masse,ps)
-!
-!-------------------------------------------------------------------------------
-! Purpose: Write the NetCDF restart file (append).
-!-------------------------------------------------------------------------------
-  USE parallel_lmdz
-  USE mod_hallo
-  USE strings_mod, ONLY: maxlen
-  USE infotrac, ONLY: nqtot, tracers, type_trac
-  USE control_mod
-  USE netcdf,   ONLY: NF90_OPEN,  NF90_NOWRITE, NF90_GET_VAR, NF90_INQ_VARID,  &
-                      NF90_CLOSE, NF90_WRITE,   NF90_PUT_VAR, NF90_NoErr
-  USE dynredem_mod, ONLY: dynredem_write_u, dynredem_write_v, dynredem_read_u, &
-                          err, modname, fil, msg
-  USE temps_mod, ONLY: itau_dyn, itaufin
-  
-  IMPLICIT NONE
-  include "dimensions.h"
-  include "paramet.h"
-  include "description.h"
-  include "comgeom.h"
-  include "iniprint.h"
-!===============================================================================
-! Arguments:
-  CHARACTER(LEN=*), INTENT(IN) :: fichnom              !-- FILE NAME
-  REAL, INTENT(IN)    ::  time                         !-- TIME
-  REAL, INTENT(IN)    ::  vcov(ijb_v:ije_v,llm)        !-- V COVARIANT WIND
-  REAL, INTENT(IN)    ::  ucov(ijb_u:ije_u,llm)        !-- U COVARIANT WIND
-  REAL, INTENT(IN)    ::  teta(ijb_u:ije_u,llm)        !-- POTENTIAL TEMPERATURE
-  REAL, INTENT(INOUT) ::     q(ijb_u:ije_u,llm,nqtot)  !-- TRACERS
-  REAL, INTENT(IN)    :: masse(ijb_u:ije_u,llm)        !-- MASS PER CELL
-  REAL, INTENT(IN)    ::    ps(ijb_u:ije_u)            !-- GROUND PRESSURE
-!===============================================================================
-! Local variables:
-  INTEGER :: iq, nid, vID, ierr, nid_trac, vID_trac
-  INTEGER, SAVE :: nb=0
-  INTEGER, PARAMETER :: length=100
-  REAL               :: tab_cntrl(length) ! tableau des parametres du run
-  CHARACTER(LEN=maxlen) :: var, dum
-  LOGICAL            :: lread_inca
-!===============================================================================
-
-!$OMP MASTER
-  IF(mpi_rank==0) THEN !++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-  modname='dynredem1_loc'; fil=fichnom
-  CALL err(NF90_OPEN(fil,NF90_WRITE,nid),"open",fil)
-
-!--- Write/extend time coordinate
-  nb = nb + 1
-  var="temps"
-  CALL err(NF90_INQ_VARID(nid,var,vID),"inq",var)
-  CALL err(NF90_PUT_VAR(nid,vID,[time]),"put",var)
-  WRITE(lunout,*)TRIM(modname)//": Saving for ", nb, time
-
-!--- Rewrite control table (itaufin undefined in dynredem0)
-  var="controle"
-  CALL err(NF90_INQ_VARID(nid,var,vID),"inq",var)
-  CALL err(NF90_GET_VAR(nid,vID,tab_cntrl),"get",var)
-  tab_cntrl(31)=DBLE(itau_dyn + itaufin)
-  CALL err(NF90_INQ_VARID(nid,var,vID),"inq",var)
-  CALL err(NF90_PUT_VAR(nid,vID,tab_cntrl),"put",var)
-  END IF               !++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-!$OMP END MASTER
-
-!--- Save fields
-  CALL dynredem_write_u(nid,"ucov" ,ucov ,llm)
-  CALL dynredem_write_v(nid,"vcov" ,vcov ,llm)
-  CALL dynredem_write_u(nid,"teta" ,teta ,llm)
-  CALL dynredem_write_u(nid,"masse",masse,llm)
-  CALL dynredem_write_u(nid,"ps"   ,ps   ,1)
-
-!--- Tracers in file "start_trac.nc" (added by Anne)
-  lread_inca=.FALSE.
-!$OMP MASTER
-  fil="start_trac.nc"
-  IF(ANY(type_trac == ['inca','inco'])) INQUIRE(FILE=fil,EXIST=lread_inca)
-  IF(lread_inca) CALL err(NF90_OPEN(fil,NF90_NOWRITE,nid_trac),"open")
-!$OMP END MASTER
-!$OMP BARRIER
-
-!--- Save tracers
-  DO iq=1,nqtot; var=TRIM(tracers(iq)%name); ierr=-1
-    IF(lread_inca) THEN                  !--- Possibly read from "start_trac.nc"
-!$OMP MASTER      
-      fil="start_trac.nc"
-      ierr=NF90_INQ_VARID(nid_trac,var,vID_trac)
-      dum='inq'; IF(ierr==NF90_NoErr) dum='fnd'
-      WRITE(lunout,*)msg(dum,var)
-!$OMP END MASTER
-!$OMP BARRIER
-      IF(ierr==NF90_NoErr) CALL dynredem_read_u(nid_trac,var,q(:,:,iq),llm)
-    END IF
-    fil=fichnom
-    CALL dynredem_write_u(nid,var,q(:,:,iq),llm)
-  END DO
-
-!$OMP MASTER
-  IF(mpi_rank==0) THEN !++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-  CALL err(NF90_CLOSE(nid),"close")
-  fil="start_trac.nc"
-  IF(lread_inca) CALL err(NF90_CLOSE(nid_trac),"close")
-  END IF               !++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-!$OMP END MASTER
-
-END SUBROUTINE dynredem1_loc
-
Index: /LMDZ6/trunk/libf/dyn3dmem/dynredem_loc.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/dynredem_loc.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3dmem/dynredem_loc.f90	(revision 5268)
@@ -0,0 +1,267 @@
+SUBROUTINE dynredem0_loc(fichnom,iday_end,phis)
+!
+!-------------------------------------------------------------------------------
+! Write the NetCDF restart file (initialization).
+!-------------------------------------------------------------------------------
+  USE IOIPSL
+  USE parallel_lmdz
+  USE mod_hallo
+  USE strings_mod, ONLY: maxlen
+  USE infotrac, ONLY: nqtot, tracers
+  USE netcdf, ONLY: NF90_CREATE, NF90_DEF_DIM, NF90_INQ_VARID, NF90_GLOBAL,    &
+                    NF90_CLOSE,  NF90_PUT_ATT, NF90_UNLIMITED, NF90_CLOBBER,   &
+                    NF90_64BIT_OFFSET
+  USE dynredem_mod, ONLY: cre_var, put_var, err, modname, fil
+  USE comvert_mod,  ONLY: ap, bp, presnivs, pa, preff, nivsig, nivsigs,&
+                          aps,bps,pseudoalt
+  USE comconst_mod, ONLY: cpp, daysec, dtvr, g, kappa, omeg, rad
+  USE logic_mod, ONLY: fxyhypb, ysinus
+  USE serre_mod, ONLY: clon,clat,grossismx,grossismy,dzoomx,dzoomy, &
+                       taux,tauy
+  USE temps_mod, ONLY: annee_ref, day_ref, itau_dyn, itaufin, start_time
+  USE ener_mod, ONLY: etot0,ptot0,ztot0,stot0,ang0
+
+  IMPLICIT NONE
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom.h"
+  include "description.h"
+  include "iniprint.h"
+!===============================================================================
+! Arguments:
+  CHARACTER(LEN=*), INTENT(IN) :: fichnom          !--- FILE NAME
+  INTEGER,          INTENT(IN) :: iday_end         !--- 
+  REAL,             INTENT(IN) :: phis(ijb_u:ije_u)!--- GROUND GEOPOTENTIAL
+!===============================================================================
+! Local variables:
+  INTEGER :: iq
+  INTEGER, PARAMETER :: length=100
+  REAL    :: tab_cntrl(length)                     !--- RUN PARAMETERS TABLE
+  REAL    :: phis_glo(ip1jmp1)
+!   For NetCDF:
+  CHARACTER(LEN=maxlen) :: unites
+  INTEGER :: indexID
+  INTEGER :: rlonuID, rlonvID, rlatuID, rlatvID
+  INTEGER :: sID, sigID, nID, timID
+  INTEGER :: yyears0, jjour0, mmois0
+  REAL    :: zjulian, hours
+!===============================================================================
+  modname='dynredem0'; fil=fichnom
+  CALL Gather_field_u(phis,phis_glo,1)
+  IF(mpi_rank/=0) RETURN
+
+  CALL ymds2ju(annee_ref, 1, iday_end, 0.0, zjulian)
+  CALL ju2ymds(zjulian, yyears0, mmois0, jjour0, hours)
+
+
+  tab_cntrl(:)  = 0.
+  tab_cntrl(1)  = REAL(iim)
+  tab_cntrl(2)  = REAL(jjm)
+  tab_cntrl(3)  = REAL(llm)
+  tab_cntrl(4)  = REAL(day_ref)
+  tab_cntrl(5)  = REAL(annee_ref)
+  tab_cntrl(6)  = rad
+  tab_cntrl(7)  = omeg
+  tab_cntrl(8)  = g
+  tab_cntrl(9)  = cpp
+  tab_cntrl(10) = kappa
+  tab_cntrl(11) = daysec
+  tab_cntrl(12) = dtvr
+  tab_cntrl(13) = etot0
+  tab_cntrl(14) = ptot0
+  tab_cntrl(15) = ztot0
+  tab_cntrl(16) = stot0
+  tab_cntrl(17) = ang0
+  tab_cntrl(18) = pa
+  tab_cntrl(19) = preff
+
+!    .....    parameters for zoom    ......   
+  tab_cntrl(20) = clon
+  tab_cntrl(21) = clat
+  tab_cntrl(22) = grossismx
+  tab_cntrl(23) = grossismy
+!
+  IF ( fxyhypb )   THEN
+    tab_cntrl(24) = 1.
+    tab_cntrl(25) = dzoomx
+    tab_cntrl(26) = dzoomy
+    tab_cntrl(27) = 0.
+    tab_cntrl(28) = taux
+    tab_cntrl(29) = tauy
+  ELSE
+    tab_cntrl(24) = 0.
+    tab_cntrl(25) = dzoomx
+    tab_cntrl(26) = dzoomy
+    tab_cntrl(27) = 0.
+    tab_cntrl(28) = 0.
+    tab_cntrl(29) = 0.
+    IF( ysinus )  tab_cntrl(27) = 1.
+  END IF
+  tab_cntrl(30) = REAL(iday_end)
+  tab_cntrl(31) = REAL(itau_dyn + itaufin)
+! start_time: start_time of simulation (not necessarily 0.)
+  tab_cntrl(32) = start_time
+
+!--- File creation
+  CALL err(NF90_CREATE(fichnom,IOR(NF90_CLOBBER,NF90_64BIT_OFFSET),nid))
+
+!--- Some global attributes
+  CALL err(NF90_PUT_ATT(nid,NF90_GLOBAL,"title","Fichier demarrage dynamique"))
+
+!--- Dimensions
+  CALL err(NF90_DEF_DIM(nid,"index", length, indexID))
+  CALL err(NF90_DEF_DIM(nid,"rlonu", iip1,   rlonuID))
+  CALL err(NF90_DEF_DIM(nid,"rlatu", jjp1,   rlatuID))
+  CALL err(NF90_DEF_DIM(nid,"rlonv", iip1,   rlonvID))
+  CALL err(NF90_DEF_DIM(nid,"rlatv", jjm,    rlatvID))
+  CALL err(NF90_DEF_DIM(nid,"sigs",  llm,        sID))
+  CALL err(NF90_DEF_DIM(nid,"sig",   llmp1,    sigID))
+  CALL err(NF90_DEF_DIM(nid,"temps", NF90_UNLIMITED, timID))
+
+!--- Define and save invariant fields
+  CALL put_var(nid,"controle","Parametres de controle" ,[indexID],tab_cntrl)
+  CALL put_var(nid,"rlonu"   ,"Longitudes des points U",[rlonuID],rlonu)
+  CALL put_var(nid,"rlatu"   ,"Latitudes des points U" ,[rlatuID],rlatu)
+  CALL put_var(nid,"rlonv"   ,"Longitudes des points V",[rlonvID],rlonv)
+  CALL put_var(nid,"rlatv"   ,"Latitudes des points V" ,[rlatvID],rlatv)
+  CALL put_var(nid,"nivsigs" ,"Numero naturel des couches s"    ,[sID]  ,nivsigs)
+  CALL put_var(nid,"nivsig"  ,"Numero naturel des couches sigma",[sigID],nivsig)
+  CALL put_var(nid,"ap"      ,"Coefficient A pour hybride"      ,[sigID],ap)
+  CALL put_var(nid,"bp"      ,"Coefficient B pour hybride"      ,[sigID],bp)
+  CALL put_var(nid,"presnivs",""                                ,[sID]  ,presnivs)
+! covariant <-> contravariant <-> natural conversion coefficients
+  CALL put_var(nid,"cu","Coefficient de passage pour U",[rlonuID,rlatuID],cu)
+  CALL put_var(nid,"cv","Coefficient de passage pour V",[rlonvID,rlatvID],cv)
+  CALL put_var(nid,"aire","Aires de chaque maille"     ,[rlonvID,rlatuID],aire)
+  CALL put_var(nid,"phisinit","Geopotentiel au sol"    ,[rlonvID,rlatuID],phis_glo)
+
+!--- Define fields saved later
+  WRITE(unites,"('days since ',i4,'-',i2.2,'-',i2.2,' 00:00:00')") &
+               yyears0,mmois0,jjour0
+  CALL cre_var(nid,"temps","Temps de simulation",[timID],unites)
+  CALL cre_var(nid,"ucov" ,"Vitesse U"  ,[rlonuID,rlatuID,sID,timID])
+  CALL cre_var(nid,"vcov" ,"Vitesse V"  ,[rlonvID,rlatvID,sID,timID])
+  CALL cre_var(nid,"teta" ,"Temperature",[rlonvID,rlatuID,sID,timID])
+  DO iq=1,nqtot
+    CALL cre_var(nid,tracers(iq)%name,tracers(iq)%longName,[rlonvID,rlatuID,sID,timID])
+  END DO
+  CALL cre_var(nid,"masse","Masse d air"    ,[rlonvID,rlatuID,sID,timID])
+  CALL cre_var(nid,"ps"   ,"Pression au sol",[rlonvID,rlatuID    ,timID])
+  CALL err(NF90_CLOSE (nid))
+
+  WRITE(lunout,*)TRIM(modname)//': iim,jjm,llm,iday_end',iim,jjm,llm,iday_end
+  WRITE(lunout,*)TRIM(modname)//': rad,omeg,g,cpp,kappa',rad,omeg,g,cpp,kappa
+
+END SUBROUTINE dynredem0_loc
+!
+!-------------------------------------------------------------------------------
+
+
+!-------------------------------------------------------------------------------
+!
+SUBROUTINE dynredem1_loc(fichnom,time,vcov,ucov,teta,q,masse,ps)
+!
+!-------------------------------------------------------------------------------
+! Purpose: Write the NetCDF restart file (append).
+!-------------------------------------------------------------------------------
+  USE parallel_lmdz
+  USE mod_hallo
+  USE strings_mod, ONLY: maxlen
+  USE infotrac, ONLY: nqtot, tracers, type_trac
+  USE control_mod
+  USE netcdf,   ONLY: NF90_OPEN,  NF90_NOWRITE, NF90_GET_VAR, NF90_INQ_VARID,  &
+                      NF90_CLOSE, NF90_WRITE,   NF90_PUT_VAR, NF90_NoErr
+  USE dynredem_mod, ONLY: dynredem_write_u, dynredem_write_v, dynredem_read_u, &
+                          err, modname, fil, msg
+  USE temps_mod, ONLY: itau_dyn, itaufin
+  
+  IMPLICIT NONE
+  include "dimensions.h"
+  include "paramet.h"
+  include "description.h"
+  include "comgeom.h"
+  include "iniprint.h"
+!===============================================================================
+! Arguments:
+  CHARACTER(LEN=*), INTENT(IN) :: fichnom              !-- FILE NAME
+  REAL, INTENT(IN)    ::  time                         !-- TIME
+  REAL, INTENT(IN)    ::  vcov(ijb_v:ije_v,llm)        !-- V COVARIANT WIND
+  REAL, INTENT(IN)    ::  ucov(ijb_u:ije_u,llm)        !-- U COVARIANT WIND
+  REAL, INTENT(IN)    ::  teta(ijb_u:ije_u,llm)        !-- POTENTIAL TEMPERATURE
+  REAL, INTENT(INOUT) ::     q(ijb_u:ije_u,llm,nqtot)  !-- TRACERS
+  REAL, INTENT(IN)    :: masse(ijb_u:ije_u,llm)        !-- MASS PER CELL
+  REAL, INTENT(IN)    ::    ps(ijb_u:ije_u)            !-- GROUND PRESSURE
+!===============================================================================
+! Local variables:
+  INTEGER :: iq, nid, vID, ierr, nid_trac, vID_trac
+  INTEGER, SAVE :: nb=0
+  INTEGER, PARAMETER :: length=100
+  REAL               :: tab_cntrl(length) ! tableau des parametres du run
+  CHARACTER(LEN=maxlen) :: var, dum
+  LOGICAL            :: lread_inca
+!===============================================================================
+
+!$OMP MASTER
+  IF(mpi_rank==0) THEN !++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+  modname='dynredem1_loc'; fil=fichnom
+  CALL err(NF90_OPEN(fil,NF90_WRITE,nid),"open",fil)
+
+!--- Write/extend time coordinate
+  nb = nb + 1
+  var="temps"
+  CALL err(NF90_INQ_VARID(nid,var,vID),"inq",var)
+  CALL err(NF90_PUT_VAR(nid,vID,[time]),"put",var)
+  WRITE(lunout,*)TRIM(modname)//": Saving for ", nb, time
+
+!--- Rewrite control table (itaufin undefined in dynredem0)
+  var="controle"
+  CALL err(NF90_INQ_VARID(nid,var,vID),"inq",var)
+  CALL err(NF90_GET_VAR(nid,vID,tab_cntrl),"get",var)
+  tab_cntrl(31)=DBLE(itau_dyn + itaufin)
+  CALL err(NF90_INQ_VARID(nid,var,vID),"inq",var)
+  CALL err(NF90_PUT_VAR(nid,vID,tab_cntrl),"put",var)
+  END IF               !++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+!$OMP END MASTER
+
+!--- Save fields
+  CALL dynredem_write_u(nid,"ucov" ,ucov ,llm)
+  CALL dynredem_write_v(nid,"vcov" ,vcov ,llm)
+  CALL dynredem_write_u(nid,"teta" ,teta ,llm)
+  CALL dynredem_write_u(nid,"masse",masse,llm)
+  CALL dynredem_write_u(nid,"ps"   ,ps   ,1)
+
+!--- Tracers in file "start_trac.nc" (added by Anne)
+  lread_inca=.FALSE.
+!$OMP MASTER
+  fil="start_trac.nc"
+  IF(ANY(type_trac == ['inca','inco'])) INQUIRE(FILE=fil,EXIST=lread_inca)
+  IF(lread_inca) CALL err(NF90_OPEN(fil,NF90_NOWRITE,nid_trac),"open")
+!$OMP END MASTER
+!$OMP BARRIER
+
+!--- Save tracers
+  DO iq=1,nqtot; var=TRIM(tracers(iq)%name); ierr=-1
+    IF(lread_inca) THEN                  !--- Possibly read from "start_trac.nc"
+!$OMP MASTER      
+      fil="start_trac.nc"
+      ierr=NF90_INQ_VARID(nid_trac,var,vID_trac)
+      dum='inq'; IF(ierr==NF90_NoErr) dum='fnd'
+      WRITE(lunout,*)msg(dum,var)
+!$OMP END MASTER
+!$OMP BARRIER
+      IF(ierr==NF90_NoErr) CALL dynredem_read_u(nid_trac,var,q(:,:,iq),llm)
+    END IF
+    fil=fichnom
+    CALL dynredem_write_u(nid,var,q(:,:,iq),llm)
+  END DO
+
+!$OMP MASTER
+  IF(mpi_rank==0) THEN !++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+  CALL err(NF90_CLOSE(nid),"close")
+  fil="start_trac.nc"
+  IF(lread_inca) CALL err(NF90_CLOSE(nid_trac),"close")
+  END IF               !++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+!$OMP END MASTER
+
+END SUBROUTINE dynredem1_loc
+
Index: DZ6/trunk/libf/dyn3dmem/dynredem_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/dynredem_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,271 +1,0 @@
-MODULE dynredem_mod
-
-  USE dimensions_mod
-  USE parallel_lmdz
-  USE mod_hallo
-  USE netcdf
-  PRIVATE
-  PUBLIC :: dynredem_write_u, dynredem_write_v, dynredem_read_u, err
-  PUBLIC :: cre_var, put_var, fil, modname, msg
-  CHARACTER(LEN=256), SAVE :: fil, modname
-  INTEGER,            SAVE :: nvarid
-
-
-CONTAINS
-
-
-!===============================================================================
-!
-SUBROUTINE dynredem_write_u(ncid,id,var,ll)
-!
-!===============================================================================
-  IMPLICIT NONE
-!===============================================================================
-! Arguments:
-  INTEGER,          INTENT(IN) :: ncid
-  CHARACTER(LEN=*), INTENT(IN) :: id
-  REAL,             INTENT(IN) :: var(ijb_u:ije_u,ll)
-  INTEGER,          INTENT(IN) :: ll
-!===============================================================================
-! Local variables:
-  REAL, ALLOCATABLE, SAVE :: var_tmp(:,:), var_glo(:)
-  INTEGER :: start(4), count(4), l, ierr
-!===============================================================================
-  start(:)=[1,1,1,1]; count(:)=[iip1,jjp1,1,1]
-
-!$OMP MASTER
-  IF(mpi_rank==0) CALL err(NF90_INQ_VARID(ncid,id,nvarid),"inq",id)
-!$OMP END MASTER
-
-!$OMP MASTER
-  ALLOCATE(var_tmp(ijb_u:ije_u,ll),var_glo(ip1jmp1))
-!$OMP END MASTER
-!$OMP BARRIER
-
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-  DO l=1,ll; var_tmp(:,l)=var(:,l); END DO
-  DO l=1,ll
-    CALL gather_field_u(var_tmp(:,l),var_glo,1)
-    IF(mpi_rank==0) THEN
-    !$OMP MASTER
-      start(3)=l
-      CALL err(NF90_PUT_VAR(ncid,nvarid,var_glo,start,count),"put",id)
-    !$OMP END MASTER
-    END IF
-  END DO
-!$OMP BARRIER
-!$OMP MASTER
-  DEALLOCATE(var_glo,var_tmp)
-!$OMP END MASTER
-!$OMP BARRIER
-  
-END SUBROUTINE dynredem_write_u
-!
-!===============================================================================
-
-
-!===============================================================================
-!
-SUBROUTINE dynredem_write_v(ncid,id,var,ll)
-!
-!===============================================================================
-  IMPLICIT NONE
-!===============================================================================
-! Arguments:
-  INTEGER,          INTENT(IN) :: ncid
-  CHARACTER(LEN=*), INTENT(IN) :: id
-  REAL,             INTENT(IN) :: var(ijb_v:ije_v,ll)
-  INTEGER,          INTENT(IN) :: ll
-!===============================================================================
-! Local variables:
-  REAL, ALLOCATABLE, SAVE :: var_tmp(:,:), var_glo(:)
-  INTEGER :: start(4), count(4), l, ierr
-!===============================================================================
-  start(:)=[1,1,1,1]; count(:)=[iip1,jjm,1,1]
-
-!$OMP MASTER
-  IF(mpi_rank==0) CALL err(NF90_INQ_VARID(ncid,id,nvarid),"inq",id)
-!$OMP END MASTER
-
-!$OMP MASTER
-  ALLOCATE(var_tmp(ijb_v:ije_v,ll),var_glo(ip1jm))
-!$OMP END MASTER
-!$OMP BARRIER
-
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-  DO l=1,ll; var_tmp(:,l)=var(:,l); END DO
-  DO l=1,ll
-    CALL gather_field_v(var_tmp(:,l),var_glo,1)
-    IF(mpi_rank==0) THEN
-    !$OMP MASTER
-      start(3)=l
-      CALL err(NF90_PUT_VAR(ncid,nvarid,var_glo,start,count),"put",id)
-    !$OMP END MASTER
-    END IF
-  END DO
-!$OMP BARRIER
-!$OMP MASTER
-  DEALLOCATE(var_glo,var_tmp)
-!$OMP END MASTER
-!$OMP BARRIER
-  
-END SUBROUTINE dynredem_write_v
-!
-!===============================================================================
-
-
-!===============================================================================
-!
-SUBROUTINE dynredem_read_u(ncid,id,var,ll)
-!
-!===============================================================================
-  IMPLICIT NONE
-!===============================================================================
-! Arguments:
-  INTEGER,          INTENT(IN)  :: ncid
-  CHARACTER(LEN=*), INTENT(IN)  :: id
-  REAL,             INTENT(OUT) :: var(ijb_u:ije_u,ll)
-  INTEGER,          INTENT(IN)  :: ll
-!===============================================================================
-! Local variables:
-  REAL, ALLOCATABLE, SAVE :: var_tmp(:,:), var_glo(:)
-  INTEGER :: start(4), count(4), l, ierr
-!===============================================================================
-  start(:)=[1,1,1,1]; count(:)=[iip1,jjp1,1,1]
-
-!$OMP MASTER
-  IF(mpi_rank==0) CALL err(NF90_INQ_VARID(ncid,id,nvarid),'inq',id)
-!$OMP END MASTER
-
-!$OMP MASTER
-  ALLOCATE(var_tmp(ijb_u:ije_u,ll),var_glo(ip1jmp1))
-!$OMP END MASTER
-!$OMP BARRIER
-
-  DO l=1,ll
-    IF(mpi_rank==0) THEN
-    !$OMP MASTER
-      start(3)=l
-      CALL err(NF90_GET_VAR(ncid,nvarid,var_glo,start,count),"get",id)
-    !$OMP END MASTER
-    END IF
-    CALL scatter_field_u(var_glo,var_tmp(:,l),1)
-  END DO
-
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-  DO l=1,ll; var(:,l)=var_tmp(:,l); END DO
-    
-!$OMP BARRIER
-!$OMP MASTER
-  DEALLOCATE(var_glo,var_tmp)
-!$OMP END MASTER
-!$OMP BARRIER
-  
-END SUBROUTINE dynredem_read_u    
-!
-!===============================================================================
-
-
-!===============================================================================
-!
-SUBROUTINE cre_var(ncid,var,title,did,units)
-  USE lmdz_cppkeys_wrapper, ONLY: nf90_format
-  IMPLICIT NONE
-!===============================================================================
-! Arguments:
-  INTEGER,                    INTENT(IN) :: ncid
-  CHARACTER(LEN=*),           INTENT(IN) :: var, title
-  INTEGER,                    INTENT(IN) :: did(:)
-  CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: units
-!===============================================================================
-  CALL err(NF90_DEF_VAR(ncid,var,nf90_format ,did,nvarid),"inq",var)
-  IF(title/="")      CALL err(NF90_PUT_ATT(ncid,nvarid,"title",title),var)
-  IF(PRESENT(units)) CALL err(NF90_PUT_ATT(ncid,nvarid,"units",units),var)
-
-END SUBROUTINE cre_var
-!
-!===============================================================================
-
-
-!===============================================================================
-!
-SUBROUTINE put_var(ncid,var,title,did,v,units)
-!
-!===============================================================================
-  IMPLICIT NONE
-!===============================================================================
-! Arguments:
-  INTEGER,                    INTENT(IN) :: ncid
-  CHARACTER(LEN=*),           INTENT(IN) :: var, title
-  INTEGER,                    INTENT(IN) :: did(:)
-  REAL,                       INTENT(IN) :: v(:)
-  CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: units
-!===============================================================================
-  INTEGER :: nd, k, nn(2)
-  IF(     PRESENT(units)) CALL cre_var(ncid,var,title,did,units)
-  IF(.NOT.PRESENT(units)) CALL cre_var(ncid,var,title,did)
-  CALL err(NF90_ENDDEF(ncid))
-  nd=SIZE(did)
-  DO k=1,nd; CALL err(NF90_INQUIRE_DIMENSION(ncid,did(k),len=nn(k))); END DO
-  IF(nd==1) CALL err(NF90_PUT_VAR(ncid,nvarid,RESHAPE(v,nn(1:1))),var)
-  IF(nd==2) CALL err(NF90_PUT_VAR(ncid,nvarid,RESHAPE(v,nn(1:2))),var)
-  CALL err(NF90_REDEF(ncid))
-END SUBROUTINE put_var
-!
-!===============================================================================
-
-
-!===============================================================================
-!
-FUNCTION msg(typ,nam)
-!
-!===============================================================================
-  IMPLICIT NONE
-!===============================================================================
-! Arguments:
-  CHARACTER(LEN=256)                     :: msg    !--- STANDARDIZED MESSAGE
-  CHARACTER(LEN=*),           INTENT(IN) :: typ    !--- TYPE OF OPERATION
-  CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: nam    !--- FIELD NAME
-!===============================================================================
-  SELECT CASE(typ)
-    CASE('open');  msg="Opening failed for <"//TRIM(fil)//">"
-    CASE('close'); msg="Closing failed for <"//TRIM(fil)//">"
-    CASE('get');   msg="Reading failed for <"//TRIM(nam)//">"
-    CASE('put');   msg="Writting failed for <"//TRIM(nam)//">"
-    CASE('inq');   msg="Missing field <"//TRIM(nam)//">"
-    CASE('fnd');   msg="Found field <"//TRIM(nam)//">"
-  END SELECT
-  msg=TRIM(msg)//" in file <"//TRIM(fil)//">"
-
-END FUNCTION msg
-!
-!===============================================================================
-
-
-!===============================================================================
-!
-SUBROUTINE err(ierr,typ,nam)
-!
-!===============================================================================
-  IMPLICIT NONE
-!===============================================================================
-! Arguments:
-  INTEGER,                    INTENT(IN) :: ierr   !--- NetCDF ERROR CODE
-  CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: typ    !--- TYPE OF OPERATION
-  CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: nam    !--- FIELD NAME
-!===============================================================================
-  IF(ierr==NF90_NoERR) RETURN
-  IF(.NOT.PRESENT(typ)) THEN
-    CALL ABORT_gcm(modname,NF90_STRERROR(ierr),ierr)
-  ELSE
-    CALL ABORT_gcm(modname,msg(typ,nam),ierr)
-  END IF
-
-END SUBROUTINE err
-!
-!===============================================================================
-
-END MODULE dynredem_mod   
-
-    
-    
Index: /LMDZ6/trunk/libf/dyn3dmem/dynredem_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/dynredem_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3dmem/dynredem_mod.f90	(revision 5268)
@@ -0,0 +1,271 @@
+MODULE dynredem_mod
+
+  USE dimensions_mod
+  USE parallel_lmdz
+  USE mod_hallo
+  USE netcdf
+  PRIVATE
+  PUBLIC :: dynredem_write_u, dynredem_write_v, dynredem_read_u, err
+  PUBLIC :: cre_var, put_var, fil, modname, msg
+  CHARACTER(LEN=256), SAVE :: fil, modname
+  INTEGER,            SAVE :: nvarid
+
+
+CONTAINS
+
+
+!===============================================================================
+!
+SUBROUTINE dynredem_write_u(ncid,id,var,ll)
+!
+!===============================================================================
+  IMPLICIT NONE
+!===============================================================================
+! Arguments:
+  INTEGER,          INTENT(IN) :: ncid
+  CHARACTER(LEN=*), INTENT(IN) :: id
+  REAL,             INTENT(IN) :: var(ijb_u:ije_u,ll)
+  INTEGER,          INTENT(IN) :: ll
+!===============================================================================
+! Local variables:
+  REAL, ALLOCATABLE, SAVE :: var_tmp(:,:), var_glo(:)
+  INTEGER :: start(4), count(4), l, ierr
+!===============================================================================
+  start(:)=[1,1,1,1]; count(:)=[iip1,jjp1,1,1]
+
+!$OMP MASTER
+  IF(mpi_rank==0) CALL err(NF90_INQ_VARID(ncid,id,nvarid),"inq",id)
+!$OMP END MASTER
+
+!$OMP MASTER
+  ALLOCATE(var_tmp(ijb_u:ije_u,ll),var_glo(ip1jmp1))
+!$OMP END MASTER
+!$OMP BARRIER
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,ll; var_tmp(:,l)=var(:,l); END DO
+  DO l=1,ll
+    CALL gather_field_u(var_tmp(:,l),var_glo,1)
+    IF(mpi_rank==0) THEN
+    !$OMP MASTER
+      start(3)=l
+      CALL err(NF90_PUT_VAR(ncid,nvarid,var_glo,start,count),"put",id)
+    !$OMP END MASTER
+    END IF
+  END DO
+!$OMP BARRIER
+!$OMP MASTER
+  DEALLOCATE(var_glo,var_tmp)
+!$OMP END MASTER
+!$OMP BARRIER
+  
+END SUBROUTINE dynredem_write_u
+!
+!===============================================================================
+
+
+!===============================================================================
+!
+SUBROUTINE dynredem_write_v(ncid,id,var,ll)
+!
+!===============================================================================
+  IMPLICIT NONE
+!===============================================================================
+! Arguments:
+  INTEGER,          INTENT(IN) :: ncid
+  CHARACTER(LEN=*), INTENT(IN) :: id
+  REAL,             INTENT(IN) :: var(ijb_v:ije_v,ll)
+  INTEGER,          INTENT(IN) :: ll
+!===============================================================================
+! Local variables:
+  REAL, ALLOCATABLE, SAVE :: var_tmp(:,:), var_glo(:)
+  INTEGER :: start(4), count(4), l, ierr
+!===============================================================================
+  start(:)=[1,1,1,1]; count(:)=[iip1,jjm,1,1]
+
+!$OMP MASTER
+  IF(mpi_rank==0) CALL err(NF90_INQ_VARID(ncid,id,nvarid),"inq",id)
+!$OMP END MASTER
+
+!$OMP MASTER
+  ALLOCATE(var_tmp(ijb_v:ije_v,ll),var_glo(ip1jm))
+!$OMP END MASTER
+!$OMP BARRIER
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,ll; var_tmp(:,l)=var(:,l); END DO
+  DO l=1,ll
+    CALL gather_field_v(var_tmp(:,l),var_glo,1)
+    IF(mpi_rank==0) THEN
+    !$OMP MASTER
+      start(3)=l
+      CALL err(NF90_PUT_VAR(ncid,nvarid,var_glo,start,count),"put",id)
+    !$OMP END MASTER
+    END IF
+  END DO
+!$OMP BARRIER
+!$OMP MASTER
+  DEALLOCATE(var_glo,var_tmp)
+!$OMP END MASTER
+!$OMP BARRIER
+  
+END SUBROUTINE dynredem_write_v
+!
+!===============================================================================
+
+
+!===============================================================================
+!
+SUBROUTINE dynredem_read_u(ncid,id,var,ll)
+!
+!===============================================================================
+  IMPLICIT NONE
+!===============================================================================
+! Arguments:
+  INTEGER,          INTENT(IN)  :: ncid
+  CHARACTER(LEN=*), INTENT(IN)  :: id
+  REAL,             INTENT(OUT) :: var(ijb_u:ije_u,ll)
+  INTEGER,          INTENT(IN)  :: ll
+!===============================================================================
+! Local variables:
+  REAL, ALLOCATABLE, SAVE :: var_tmp(:,:), var_glo(:)
+  INTEGER :: start(4), count(4), l, ierr
+!===============================================================================
+  start(:)=[1,1,1,1]; count(:)=[iip1,jjp1,1,1]
+
+!$OMP MASTER
+  IF(mpi_rank==0) CALL err(NF90_INQ_VARID(ncid,id,nvarid),'inq',id)
+!$OMP END MASTER
+
+!$OMP MASTER
+  ALLOCATE(var_tmp(ijb_u:ije_u,ll),var_glo(ip1jmp1))
+!$OMP END MASTER
+!$OMP BARRIER
+
+  DO l=1,ll
+    IF(mpi_rank==0) THEN
+    !$OMP MASTER
+      start(3)=l
+      CALL err(NF90_GET_VAR(ncid,nvarid,var_glo,start,count),"get",id)
+    !$OMP END MASTER
+    END IF
+    CALL scatter_field_u(var_glo,var_tmp(:,l),1)
+  END DO
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,ll; var(:,l)=var_tmp(:,l); END DO
+    
+!$OMP BARRIER
+!$OMP MASTER
+  DEALLOCATE(var_glo,var_tmp)
+!$OMP END MASTER
+!$OMP BARRIER
+  
+END SUBROUTINE dynredem_read_u    
+!
+!===============================================================================
+
+
+!===============================================================================
+!
+SUBROUTINE cre_var(ncid,var,title,did,units)
+  USE lmdz_cppkeys_wrapper, ONLY: nf90_format
+  IMPLICIT NONE
+!===============================================================================
+! Arguments:
+  INTEGER,                    INTENT(IN) :: ncid
+  CHARACTER(LEN=*),           INTENT(IN) :: var, title
+  INTEGER,                    INTENT(IN) :: did(:)
+  CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: units
+!===============================================================================
+  CALL err(NF90_DEF_VAR(ncid,var,nf90_format ,did,nvarid),"inq",var)
+  IF(title/="")      CALL err(NF90_PUT_ATT(ncid,nvarid,"title",title),var)
+  IF(PRESENT(units)) CALL err(NF90_PUT_ATT(ncid,nvarid,"units",units),var)
+
+END SUBROUTINE cre_var
+!
+!===============================================================================
+
+
+!===============================================================================
+!
+SUBROUTINE put_var(ncid,var,title,did,v,units)
+!
+!===============================================================================
+  IMPLICIT NONE
+!===============================================================================
+! Arguments:
+  INTEGER,                    INTENT(IN) :: ncid
+  CHARACTER(LEN=*),           INTENT(IN) :: var, title
+  INTEGER,                    INTENT(IN) :: did(:)
+  REAL,                       INTENT(IN) :: v(:)
+  CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: units
+!===============================================================================
+  INTEGER :: nd, k, nn(2)
+  IF(     PRESENT(units)) CALL cre_var(ncid,var,title,did,units)
+  IF(.NOT.PRESENT(units)) CALL cre_var(ncid,var,title,did)
+  CALL err(NF90_ENDDEF(ncid))
+  nd=SIZE(did)
+  DO k=1,nd; CALL err(NF90_INQUIRE_DIMENSION(ncid,did(k),len=nn(k))); END DO
+  IF(nd==1) CALL err(NF90_PUT_VAR(ncid,nvarid,RESHAPE(v,nn(1:1))),var)
+  IF(nd==2) CALL err(NF90_PUT_VAR(ncid,nvarid,RESHAPE(v,nn(1:2))),var)
+  CALL err(NF90_REDEF(ncid))
+END SUBROUTINE put_var
+!
+!===============================================================================
+
+
+!===============================================================================
+!
+FUNCTION msg(typ,nam)
+!
+!===============================================================================
+  IMPLICIT NONE
+!===============================================================================
+! Arguments:
+  CHARACTER(LEN=256)                     :: msg    !--- STANDARDIZED MESSAGE
+  CHARACTER(LEN=*),           INTENT(IN) :: typ    !--- TYPE OF OPERATION
+  CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: nam    !--- FIELD NAME
+!===============================================================================
+  SELECT CASE(typ)
+    CASE('open');  msg="Opening failed for <"//TRIM(fil)//">"
+    CASE('close'); msg="Closing failed for <"//TRIM(fil)//">"
+    CASE('get');   msg="Reading failed for <"//TRIM(nam)//">"
+    CASE('put');   msg="Writting failed for <"//TRIM(nam)//">"
+    CASE('inq');   msg="Missing field <"//TRIM(nam)//">"
+    CASE('fnd');   msg="Found field <"//TRIM(nam)//">"
+  END SELECT
+  msg=TRIM(msg)//" in file <"//TRIM(fil)//">"
+
+END FUNCTION msg
+!
+!===============================================================================
+
+
+!===============================================================================
+!
+SUBROUTINE err(ierr,typ,nam)
+!
+!===============================================================================
+  IMPLICIT NONE
+!===============================================================================
+! Arguments:
+  INTEGER,                    INTENT(IN) :: ierr   !--- NetCDF ERROR CODE
+  CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: typ    !--- TYPE OF OPERATION
+  CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: nam    !--- FIELD NAME
+!===============================================================================
+  IF(ierr==NF90_NoERR) RETURN
+  IF(.NOT.PRESENT(typ)) THEN
+    CALL ABORT_gcm(modname,NF90_STRERROR(ierr),ierr)
+  ELSE
+    CALL ABORT_gcm(modname,msg(typ,nam),ierr)
+  END IF
+
+END SUBROUTINE err
+!
+!===============================================================================
+
+END MODULE dynredem_mod   
+
+    
+    
Index: DZ6/trunk/libf/dyn3dmem/enercin_loc.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/enercin_loc.F90	(revision 5267)
+++ 	(revision )
@@ -1,84 +1,0 @@
-SUBROUTINE enercin_loc ( vcov, ucov, vcont, ucont, ecin )
-!
-!-------------------------------------------------------------------------------
-! Authors: P. Le Van.
-!-------------------------------------------------------------------------------
-! Purpose: Compute kinetic energy at sigma levels.
-  USE parallel_lmdz
-  IMPLICIT NONE
-  include "dimensions.h"
-  include "paramet.h"
-  include "comgeom.h"
-!===============================================================================
-! Arguments:
-  REAL, INTENT(IN)  :: vcov    (ijb_v:ije_v,llm)
-  REAL, INTENT(IN)  :: ucov    (ijb_u:ije_u,llm)
-  REAL, INTENT(IN)  :: vcont   (ijb_v:ije_v,llm)
-  REAL, INTENT(IN)  :: ucont   (ijb_u:ije_u,llm)
-  REAL, INTENT(OUT) :: ecin    (ijb_u:ije_u,llm)
-!===============================================================================
-! Notes:
-!                 . V
-!                i,j-1
-!
-!      alpha4 .       . alpha1
-!
-!
-!        U .      . P     . U
-!       i-1,j    i,j      i,j
-!
-!      alpha3 .       . alpha2
-!
-!
-!                 . V
-!                i,j
-!
-! Kinetic energy at scalar point P(i,j) (excluding poles) is:
-!       Ecin = 0.5 * U(i-1,j)**2 *( alpha3 + alpha4 )  +
-!              0.5 * U(i  ,j)**2 *( alpha1 + alpha2 )  +
-!              0.5 * V(i,j-1)**2 *( alpha1 + alpha4 )  +
-!              0.5 * V(i,  j)**2 *( alpha2 + alpha3 )
-!===============================================================================
-! Local variables:
-  INTEGER :: l, ij, i, ijb, ije
-  REAL    :: ecinni(iim), ecinsi(iim), ecinpn, ecinps
-!===============================================================================
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-  DO l=1,llm
-
-    ijb=ij_begin
-    ije=ij_end+iip1
-
-    IF(pole_nord) ijb=ij_begin+iip1
-    IF(pole_sud)  ije=ij_end-iip1
-
-    DO ij = ijb,ije-1
-      ecin(ij+1,l)=0.5*(ucov(ij    ,l)*ucont(ij    ,l)*alpha3p4(ij +1)          &
-                      + ucov(ij+1  ,l)*ucont(ij+1  ,l)*alpha1p2(ij +1)          &
-                      + vcov(ij-iim,l)*vcont(ij-iim,l)*alpha1p4(ij +1)          &
-                      + vcov(ij+1  ,l)*vcont(ij+1  ,l)*alpha2p3(ij +1) )
-    END DO
-
-    !--- Correction: ecin(1,j,l)= ecin(iip1,j,l)
-    DO ij=ijb,ije,iip1; ecin(ij,l) = ecin(ij+iim,l); END DO
-
-    !--- North pole
-    IF(pole_nord) THEN
-      ecinni(:) = vcov(1:iim,l)*vcont(1:iim,l)*aire(1:iim)
-      ecinpn = 0.5*SUM(ecinni)/apoln
-      ecin(1:iip1,l)=ecinpn
-    END IF
-
-    !--- South pole
-    IF(pole_sud) THEN
-      DO i=1,iim
-        ecinsi(i) = vcov(i+ip1jmi1,l)*vcont(i+ip1jmi1,l)*aire(i+ip1jm)
-      END DO
-      ecinps = 0.5*SUM(ecinsi)/apols
-      ecin(1+ip1jm:ip1jmp1,l)=ecinps
-    END IF
-  END DO
-!$OMP END DO NOWAIT
-
-END SUBROUTINE enercin_loc
-
Index: /LMDZ6/trunk/libf/dyn3dmem/enercin_loc.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/enercin_loc.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3dmem/enercin_loc.f90	(revision 5268)
@@ -0,0 +1,84 @@
+SUBROUTINE enercin_loc ( vcov, ucov, vcont, ucont, ecin )
+!
+!-------------------------------------------------------------------------------
+! Authors: P. Le Van.
+!-------------------------------------------------------------------------------
+! Purpose: Compute kinetic energy at sigma levels.
+  USE parallel_lmdz
+  IMPLICIT NONE
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom.h"
+!===============================================================================
+! Arguments:
+  REAL, INTENT(IN)  :: vcov    (ijb_v:ije_v,llm)
+  REAL, INTENT(IN)  :: ucov    (ijb_u:ije_u,llm)
+  REAL, INTENT(IN)  :: vcont   (ijb_v:ije_v,llm)
+  REAL, INTENT(IN)  :: ucont   (ijb_u:ije_u,llm)
+  REAL, INTENT(OUT) :: ecin    (ijb_u:ije_u,llm)
+!===============================================================================
+! Notes:
+!                 . V
+!                i,j-1
+!
+!      alpha4 .       . alpha1
+!
+!
+!        U .      . P     . U
+!       i-1,j    i,j      i,j
+!
+!      alpha3 .       . alpha2
+!
+!
+!                 . V
+!                i,j
+!
+! Kinetic energy at scalar point P(i,j) (excluding poles) is:
+!       Ecin = 0.5 * U(i-1,j)**2 *( alpha3 + alpha4 )  +
+!              0.5 * U(i  ,j)**2 *( alpha1 + alpha2 )  +
+!              0.5 * V(i,j-1)**2 *( alpha1 + alpha4 )  +
+!              0.5 * V(i,  j)**2 *( alpha2 + alpha3 )
+!===============================================================================
+! Local variables:
+  INTEGER :: l, ij, i, ijb, ije
+  REAL    :: ecinni(iim), ecinsi(iim), ecinpn, ecinps
+!===============================================================================
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,llm
+
+    ijb=ij_begin
+    ije=ij_end+iip1
+
+    IF(pole_nord) ijb=ij_begin+iip1
+    IF(pole_sud)  ije=ij_end-iip1
+
+    DO ij = ijb,ije-1
+      ecin(ij+1,l)=0.5*(ucov(ij    ,l)*ucont(ij    ,l)*alpha3p4(ij +1)          &
+                      + ucov(ij+1  ,l)*ucont(ij+1  ,l)*alpha1p2(ij +1)          &
+                      + vcov(ij-iim,l)*vcont(ij-iim,l)*alpha1p4(ij +1)          &
+                      + vcov(ij+1  ,l)*vcont(ij+1  ,l)*alpha2p3(ij +1) )
+    END DO
+
+    !--- Correction: ecin(1,j,l)= ecin(iip1,j,l)
+    DO ij=ijb,ije,iip1; ecin(ij,l) = ecin(ij+iim,l); END DO
+
+    !--- North pole
+    IF(pole_nord) THEN
+      ecinni(:) = vcov(1:iim,l)*vcont(1:iim,l)*aire(1:iim)
+      ecinpn = 0.5*SUM(ecinni)/apoln
+      ecin(1:iip1,l)=ecinpn
+    END IF
+
+    !--- South pole
+    IF(pole_sud) THEN
+      DO i=1,iim
+        ecinsi(i) = vcov(i+ip1jmi1,l)*vcont(i+ip1jmi1,l)*aire(i+ip1jm)
+      END DO
+      ecinps = 0.5*SUM(ecinsi)/apols
+      ecin(1+ip1jm:ip1jmp1,l)=ecinps
+    END IF
+  END DO
+!$OMP END DO NOWAIT
+
+END SUBROUTINE enercin_loc
+
Index: DZ6/trunk/libf/dyn3dmem/exner_hyb_loc_m.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/exner_hyb_loc_m.F90	(revision 5267)
+++ 	(revision )
@@ -1,199 +1,0 @@
-module exner_hyb_loc_m
-
-  IMPLICIT NONE
-
-contains
-
-  SUBROUTINE  exner_hyb_loc(ngrid, ps, p, pks,pk,pkf)
-
-    !     Auteurs :  P.Le Van  , Fr. Hourdin  .
-    !    ..........
-    !
-    !    ....  ngrid, ps,p             sont des argum.d'entree  au sous-prog ...
-    !    ....  pks,pk,pkf   sont des argum.de sortie au sous-prog ...
-    !
-    !   ************************************************************************
-    !    Calcule la fonction d'Exner pk = Cp * (p/preff) ** kappa , aux milieux des 
-    !    couches .   Pk(l) sera calcule aux milieux  des couches l ,entre les
-    !    pressions p(l) et p(l+1) ,definis aux interfaces des llm couches .
-    !   ************************************************************************
-    !  .. N.B : Au sommet de l'atmosphere,  p(llm+1) = 0. , et ps et pks sont
-    !    la pression et la fonction d'Exner  au  sol  .
-    !
-    !                                 -------- z
-    !    A partir des relations  ( 1 ) p*dz(pk) = kappa *pk*dz(p)      et
-    !                            ( 2 ) pk(l) = alpha(l)+ beta(l)*pk(l-1)
-    !    ( voir note de Fr.Hourdin )  ,
-    !
-    !    on determine successivement , du haut vers le bas des couches, les 
-    !    coef. alpha(llm),beta(llm) .,.,alpha(l),beta(l),,,alpha(2),beta(2), 
-    !    puis pk(ij,1). Ensuite ,on calcule,du bas vers le haut des couches,  
-    !     pk(ij,l)  donne  par la relation (2),  pour l = 2 a l = llm .
-    !
-    !
-    USE parallel_lmdz
-    USE mod_filtreg_p
-    USE write_field_loc
-    USE comconst_mod, ONLY: cpp, kappa, r, jmp1
-    USE comvert_mod, ONLY: preff
-    USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_DEBUGIO
-    IMPLICIT NONE
-    !
-    include "dimensions.h"
-    include "paramet.h"
-    include "comgeom.h"
-
-    INTEGER  ngrid
-    REAL p(ijb_u:ije_u,llmp1),pk(ijb_u:ije_u,llm)
-    REAL, optional:: pkf(ijb_u:ije_u,llm)
-    REAL ps(ijb_u:ije_u),pks(ijb_u:ije_u)
-    REAL alpha(ijb_u:ije_u,llm),beta(ijb_u:ije_u,llm)
-
-    !    .... variables locales   ...
-
-    INTEGER l, ij
-    REAL unpl2k,dellta
-
-    INTEGER ije,ijb,jje,jjb
-    logical,save :: firstcall=.true.
-    !$OMP THREADPRIVATE(firstcall) 
-    character(len=*),parameter :: modname="exner_hyb_loc"
-    !
-    !$OMP BARRIER           
-
-    ! Sanity check
-    if (firstcall) then
-       ! sanity checks for Shallow Water case (1 vertical layer)
-       if (llm.eq.1) then
-          if (kappa.ne.1) then
-             call abort_gcm(modname, &
-                  "kappa!=1 , but running in Shallow Water mode!!",42)
-          endif
-          if (cpp.ne.r) then
-             call abort_gcm(modname, &
-                  "cpp!=r , but running in Shallow Water mode!!",42)
-          endif
-       endif ! of if (llm.eq.1)
-
-       firstcall=.false.
-    endif ! of if (firstcall)
-
-    !$OMP BARRIER
-
-    ! Specific behaviour for Shallow Water (1 vertical layer) case:
-    if (llm.eq.1) then
-
-       ! Compute pks(:),pk(:),pkf(:)
-       ijb=ij_begin
-       ije=ij_end
-       !$OMP DO SCHEDULE(STATIC)
-       DO ij=ijb, ije
-          pks(ij) = (cpp/preff) * ps(ij)
-          pk(ij,1) = .5*pks(ij)
-          if (present(pkf)) pkf(ij,1)=pk(ij,1)
-       ENDDO
-       !$OMP ENDDO
-
-       !$OMP BARRIER
-       if (present(pkf)) then
-          jjb=jj_begin
-          jje=jj_end
-          CALL filtreg_p ( pkf,jjb_u,jje_u,jjb,jje, jmp1, llm, &
-               2, 1, .TRUE., 1 )
-       end if
-
-       ! our work is done, exit routine
-       return
-    endif ! of if (llm.eq.1)
-
-    ! General case:
-
-    unpl2k    = 1.+ 2.* kappa
-
-    !     -------------
-    !     Calcul de pks
-    !     -------------
-
-    ijb=ij_begin
-    ije=ij_end
-
-    !$OMP DO SCHEDULE(STATIC)
-    DO   ij  = ijb, ije
-       pks(ij) = cpp * ( ps(ij)/preff ) ** kappa
-    ENDDO
-    !$OMP ENDDO
-    ! Synchro OPENMP ici
-
-    !$OMP BARRIER
-    !
-    !
-    !    .... Calcul des coeff. alpha et beta  pour la couche l = llm ..
-    !
-    !$OMP DO SCHEDULE(STATIC)
-    DO     ij      = ijb,ije
-       alpha(ij,llm) = 0.
-       beta (ij,llm) = 1./ unpl2k
-    ENDDO
-    !$OMP ENDDO NOWAIT
-    !
-    !     ... Calcul des coeff. alpha et beta  pour l = llm-1  a l = 2 ...
-    !
-    DO l = llm -1 , 2 , -1
-       !
-       !$OMP DO SCHEDULE(STATIC)
-       DO ij = ijb, ije
-          dellta = p(ij,l)* unpl2k + p(ij,l+1)* ( beta(ij,l+1)-unpl2k )
-          alpha(ij,l)  = - p(ij,l+1) / dellta * alpha(ij,l+1)
-          beta (ij,l)  =   p(ij,l  ) / dellta   
-       ENDDO
-       !$OMP ENDDO NOWAIT
-    ENDDO
-
-    !  ***********************************************************************
-    !     .....  Calcul de pk pour la couche 1 , pres du sol  ....
-    !
-    !$OMP DO SCHEDULE(STATIC)
-    DO   ij   = ijb, ije
-       pk(ij,1) = ( p(ij,1)*pks(ij) - 0.5*alpha(ij,2)*p(ij,2) )  / &
-            (  p(ij,1)* (1.+kappa) + 0.5*( beta(ij,2)-unpl2k )* p(ij,2) )
-    ENDDO
-    !$OMP ENDDO NOWAIT
-    !
-    !    ..... Calcul de pk(ij,l) , pour l = 2 a l = llm  ........
-    !
-    DO l = 2, llm
-       !$OMP DO SCHEDULE(STATIC)
-       DO   ij   = ijb, ije
-          pk(ij,l) = alpha(ij,l) + beta(ij,l) * pk(ij,l-1)
-       ENDDO
-       !$OMP ENDDO NOWAIT        
-    ENDDO
-
-    if (present(pkf)) then
-       !    calcul de pkf
-
-       DO l = 1, llm
-          !$OMP DO SCHEDULE(STATIC)
-          DO   ij   = ijb, ije
-             pkf(ij,l)=pk(ij,l)
-          ENDDO
-          !$OMP ENDDO NOWAIT             
-       ENDDO
-
-       !$OMP BARRIER
-
-       jjb=jj_begin
-       jje=jj_end
-IF (CPPKEY_DEBUGIO) THEN
-       call WriteField_u('pkf',pkf)
-END IF
-       CALL filtreg_p ( pkf,jjb_u,jje_u,jjb,jje, jmp1, llm, &
-            2, 1, .TRUE., 1 )
-IF (CPPKEY_DEBUGIO) THEN
-       call WriteField_u('pkf',pkf)
-END IF
-    end if
-
-  END SUBROUTINE exner_hyb_loc
-
-end module exner_hyb_loc_m
Index: /LMDZ6/trunk/libf/dyn3dmem/exner_hyb_loc_m.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/exner_hyb_loc_m.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3dmem/exner_hyb_loc_m.f90	(revision 5268)
@@ -0,0 +1,199 @@
+module exner_hyb_loc_m
+
+  IMPLICIT NONE
+
+contains
+
+  SUBROUTINE  exner_hyb_loc(ngrid, ps, p, pks,pk,pkf)
+
+    !     Auteurs :  P.Le Van  , Fr. Hourdin  .
+    !    ..........
+    !
+    !    ....  ngrid, ps,p             sont des argum.d'entree  au sous-prog ...
+    !    ....  pks,pk,pkf   sont des argum.de sortie au sous-prog ...
+    !
+    !   ************************************************************************
+    !    Calcule la fonction d'Exner pk = Cp * (p/preff) ** kappa , aux milieux des 
+    !    couches .   Pk(l) sera calcule aux milieux  des couches l ,entre les
+    !    pressions p(l) et p(l+1) ,definis aux interfaces des llm couches .
+    !   ************************************************************************
+    !  .. N.B : Au sommet de l'atmosphere,  p(llm+1) = 0. , et ps et pks sont
+    !    la pression et la fonction d'Exner  au  sol  .
+    !
+    !                                 -------- z
+    !    A partir des relations  ( 1 ) p*dz(pk) = kappa *pk*dz(p)      et
+    !                            ( 2 ) pk(l) = alpha(l)+ beta(l)*pk(l-1)
+    !    ( voir note de Fr.Hourdin )  ,
+    !
+    !    on determine successivement , du haut vers le bas des couches, les 
+    !    coef. alpha(llm),beta(llm) .,.,alpha(l),beta(l),,,alpha(2),beta(2), 
+    !    puis pk(ij,1). Ensuite ,on calcule,du bas vers le haut des couches,  
+    !     pk(ij,l)  donne  par la relation (2),  pour l = 2 a l = llm .
+    !
+    !
+    USE parallel_lmdz
+    USE mod_filtreg_p
+    USE write_field_loc
+    USE comconst_mod, ONLY: cpp, kappa, r, jmp1
+    USE comvert_mod, ONLY: preff
+    USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_DEBUGIO
+    IMPLICIT NONE
+    !
+    include "dimensions.h"
+    include "paramet.h"
+    include "comgeom.h"
+
+    INTEGER  ngrid
+    REAL p(ijb_u:ije_u,llmp1),pk(ijb_u:ije_u,llm)
+    REAL, optional:: pkf(ijb_u:ije_u,llm)
+    REAL ps(ijb_u:ije_u),pks(ijb_u:ije_u)
+    REAL alpha(ijb_u:ije_u,llm),beta(ijb_u:ije_u,llm)
+
+    !    .... variables locales   ...
+
+    INTEGER l, ij
+    REAL unpl2k,dellta
+
+    INTEGER ije,ijb,jje,jjb
+    logical,save :: firstcall=.true.
+    !$OMP THREADPRIVATE(firstcall) 
+    character(len=*),parameter :: modname="exner_hyb_loc"
+    !
+    !$OMP BARRIER           
+
+    ! Sanity check
+    if (firstcall) then
+       ! sanity checks for Shallow Water case (1 vertical layer)
+       if (llm.eq.1) then
+          if (kappa.ne.1) then
+             call abort_gcm(modname, &
+                  "kappa!=1 , but running in Shallow Water mode!!",42)
+          endif
+          if (cpp.ne.r) then
+             call abort_gcm(modname, &
+                  "cpp!=r , but running in Shallow Water mode!!",42)
+          endif
+       endif ! of if (llm.eq.1)
+
+       firstcall=.false.
+    endif ! of if (firstcall)
+
+    !$OMP BARRIER
+
+    ! Specific behaviour for Shallow Water (1 vertical layer) case:
+    if (llm.eq.1) then
+
+       ! Compute pks(:),pk(:),pkf(:)
+       ijb=ij_begin
+       ije=ij_end
+       !$OMP DO SCHEDULE(STATIC)
+       DO ij=ijb, ije
+          pks(ij) = (cpp/preff) * ps(ij)
+          pk(ij,1) = .5*pks(ij)
+          if (present(pkf)) pkf(ij,1)=pk(ij,1)
+       ENDDO
+       !$OMP ENDDO
+
+       !$OMP BARRIER
+       if (present(pkf)) then
+          jjb=jj_begin
+          jje=jj_end
+          CALL filtreg_p ( pkf,jjb_u,jje_u,jjb,jje, jmp1, llm, &
+               2, 1, .TRUE., 1 )
+       end if
+
+       ! our work is done, exit routine
+       return
+    endif ! of if (llm.eq.1)
+
+    ! General case:
+
+    unpl2k    = 1.+ 2.* kappa
+
+    !     -------------
+    !     Calcul de pks
+    !     -------------
+
+    ijb=ij_begin
+    ije=ij_end
+
+    !$OMP DO SCHEDULE(STATIC)
+    DO   ij  = ijb, ije
+       pks(ij) = cpp * ( ps(ij)/preff ) ** kappa
+    ENDDO
+    !$OMP ENDDO
+    ! Synchro OPENMP ici
+
+    !$OMP BARRIER
+    !
+    !
+    !    .... Calcul des coeff. alpha et beta  pour la couche l = llm ..
+    !
+    !$OMP DO SCHEDULE(STATIC)
+    DO     ij      = ijb,ije
+       alpha(ij,llm) = 0.
+       beta (ij,llm) = 1./ unpl2k
+    ENDDO
+    !$OMP ENDDO NOWAIT
+    !
+    !     ... Calcul des coeff. alpha et beta  pour l = llm-1  a l = 2 ...
+    !
+    DO l = llm -1 , 2 , -1
+       !
+       !$OMP DO SCHEDULE(STATIC)
+       DO ij = ijb, ije
+          dellta = p(ij,l)* unpl2k + p(ij,l+1)* ( beta(ij,l+1)-unpl2k )
+          alpha(ij,l)  = - p(ij,l+1) / dellta * alpha(ij,l+1)
+          beta (ij,l)  =   p(ij,l  ) / dellta   
+       ENDDO
+       !$OMP ENDDO NOWAIT
+    ENDDO
+
+    !  ***********************************************************************
+    !     .....  Calcul de pk pour la couche 1 , pres du sol  ....
+    !
+    !$OMP DO SCHEDULE(STATIC)
+    DO   ij   = ijb, ije
+       pk(ij,1) = ( p(ij,1)*pks(ij) - 0.5*alpha(ij,2)*p(ij,2) )  / &
+            (  p(ij,1)* (1.+kappa) + 0.5*( beta(ij,2)-unpl2k )* p(ij,2) )
+    ENDDO
+    !$OMP ENDDO NOWAIT
+    !
+    !    ..... Calcul de pk(ij,l) , pour l = 2 a l = llm  ........
+    !
+    DO l = 2, llm
+       !$OMP DO SCHEDULE(STATIC)
+       DO   ij   = ijb, ije
+          pk(ij,l) = alpha(ij,l) + beta(ij,l) * pk(ij,l-1)
+       ENDDO
+       !$OMP ENDDO NOWAIT        
+    ENDDO
+
+    if (present(pkf)) then
+       !    calcul de pkf
+
+       DO l = 1, llm
+          !$OMP DO SCHEDULE(STATIC)
+          DO   ij   = ijb, ije
+             pkf(ij,l)=pk(ij,l)
+          ENDDO
+          !$OMP ENDDO NOWAIT             
+       ENDDO
+
+       !$OMP BARRIER
+
+       jjb=jj_begin
+       jje=jj_end
+IF (CPPKEY_DEBUGIO) THEN
+       call WriteField_u('pkf',pkf)
+END IF
+       CALL filtreg_p ( pkf,jjb_u,jje_u,jjb,jje, jmp1, llm, &
+            2, 1, .TRUE., 1 )
+IF (CPPKEY_DEBUGIO) THEN
+       call WriteField_u('pkf',pkf)
+END IF
+    end if
+
+  END SUBROUTINE exner_hyb_loc
+
+end module exner_hyb_loc_m
Index: DZ6/trunk/libf/dyn3dmem/exner_milieu_loc_m.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/exner_milieu_loc_m.F90	(revision 5267)
+++ 	(revision )
@@ -1,164 +1,0 @@
-module exner_milieu_loc_m
-
-  IMPLICIT NONE
-
-contains
-
-  SUBROUTINE  exner_milieu_loc ( ngrid, ps, p, pks, pk, pkf )
-    !
-    !     Auteurs :  F. Forget , Y. Wanherdrick
-    ! P.Le Van  , Fr. Hourdin  .
-    !    ..........
-    !
-    !    ....  ngrid, ps,p             sont des argum.d'entree  au sous-prog ...
-    !    ....  pks,pk,pkf   sont des argum.de sortie au sous-prog ...
-    !
-    !   ************************************************************************
-    !    Calcule la fonction d'Exner pk = Cp * (p/preff) ** kappa , aux milieux des 
-    !    couches .   Pk(l) sera calcule aux milieux  des couches l ,entre les
-    !    pressions p(l) et p(l+1) ,definis aux interfaces des llm couches .
-    !   ************************************************************************
-    !  .. N.B : Au sommet de l'atmosphere,  p(llm+1) = 0. , et ps et pks sont
-    !    la pression et la fonction d'Exner  au  sol  .
-    !
-    !     WARNING : CECI est une version speciale de exner_hyb originale
-    !               Utilise dans la version martienne pour pouvoir 
-    !               tourner avec des coordonnees verticales complexe
-    !              => Il ne verifie PAS la condition la proportionalite en 
-    !              energie totale/ interne / potentielle (F.Forget 2001)
-    !    ( voir note de Fr.Hourdin )  ,
-    !
-    USE parallel_lmdz
-    USE mod_filtreg_p
-    USE comconst_mod, ONLY: cpp, kappa, r, jmp1
-    USE comvert_mod, ONLY: preff
-    
-    IMPLICIT NONE
-    !
-    include "dimensions.h"
-    include "paramet.h"
-    include "comgeom.h"
-
-    INTEGER  ngrid
-    REAL p(ijb_u:ije_u,llmp1),pk(ijb_u:ije_u,llm)
-    REAL, optional:: pkf(ijb_u:ije_u,llm)
-    REAL ps(ijb_u:ije_u),pks(ijb_u:ije_u)
-
-    !    .... variables locales   ...
-
-    INTEGER l, ij
-    REAL dum1
-
-    INTEGER ije,ijb,jje,jjb
-    logical,save :: firstcall=.true.
-    !$OMP THREADPRIVATE(firstcall) 
-    character(len=*),parameter :: modname="exner_milieu_loc"
-
-    ! Sanity check
-    if (firstcall) then
-       ! sanity checks for Shallow Water case (1 vertical layer)
-       if (llm.eq.1) then
-          if (kappa.ne.1) then
-             call abort_gcm(modname, &
-                  "kappa!=1 , but running in Shallow Water mode!!",42)
-          endif
-          if (cpp.ne.r) then
-             call abort_gcm(modname, &
-                  "cpp!=r , but running in Shallow Water mode!!",42)
-          endif
-       endif ! of if (llm.eq.1)
-
-       firstcall=.false.
-    endif ! of if (firstcall)
-
-    !$OMP BARRIER
-
-    ! Specific behaviour for Shallow Water (1 vertical layer) case:
-    if (llm.eq.1) then
-
-       ! Compute pks(:),pk(:),pkf(:)
-       ijb=ij_begin
-       ije=ij_end
-       !$OMP DO SCHEDULE(STATIC)
-       DO ij=ijb, ije
-          pks(ij) = (cpp/preff) * ps(ij)
-          pk(ij,1) = .5*pks(ij)
-          if (present(pkf)) pkf(ij,1)=pk(ij,1)
-       ENDDO
-       !$OMP ENDDO
-
-       !$OMP BARRIER
-       if (present(pkf)) then
-          jjb=jj_begin
-          jje=jj_end
-          CALL filtreg_p ( pkf,jjb_u,jje_u,jjb,jje, jmp1, llm, &
-               2, 1, .TRUE., 1 )
-       end if
-
-       ! our work is done, exit routine
-       return
-    endif ! of if (llm.eq.1)
-
-    ! General case:
-
-    !     -------------
-    !     Calcul de pks
-    !     -------------
-
-    ijb=ij_begin
-    ije=ij_end
-
-    !$OMP DO SCHEDULE(STATIC)
-    DO   ij  = ijb, ije
-       pks(ij) = cpp * ( ps(ij)/preff ) ** kappa
-    ENDDO
-    !$OMP ENDDO
-    ! Synchro OPENMP ici
-
-    !$OMP BARRIER
-    !
-    !
-    !    .... Calcul de pk  pour la couche l 
-    !    --------------------------------------------
-    !
-    dum1 = cpp * (2*preff)**(-kappa) 
-    DO l = 1, llm-1
-       !$OMP DO SCHEDULE(STATIC)
-       DO   ij   = ijb, ije
-          pk(ij,l) = dum1 * (p(ij,l) + p(ij,l+1))**kappa
-       ENDDO
-       !$OMP ENDDO NOWAIT
-    ENDDO
-
-    !    .... Calcul de pk  pour la couche l = llm ..
-    !    (on met la meme distance (en log pression)  entre Pk(llm)
-    !    et Pk(llm -1) qu'entre Pk(llm-1) et Pk(llm-2)
-
-    !$OMP DO SCHEDULE(STATIC)
-    DO   ij   = ijb, ije
-       pk(ij,llm) = pk(ij,llm-1)**2 / pk(ij,llm-2)
-    ENDDO
-    !$OMP ENDDO NOWAIT        
-
-    if (present(pkf)) then
-       !    calcul de pkf
-
-       DO l = 1, llm
-          !$OMP DO SCHEDULE(STATIC)
-          DO   ij   = ijb, ije
-             pkf(ij,l)=pk(ij,l)
-          ENDDO
-          !$OMP ENDDO NOWAIT
-       ENDDO
-
-       !$OMP BARRIER
-
-       jjb=jj_begin
-       jje=jj_end
-       CALL filtreg_p ( pkf,jjb_u,jje_u,jjb,jje, jmp1, llm, &
-            2, 1, .TRUE., 1 )
-    end if
-
-  END SUBROUTINE exner_milieu_loc
-
-end module exner_milieu_loc_m
Index: /LMDZ6/trunk/libf/dyn3dmem/exner_milieu_loc_m.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/exner_milieu_loc_m.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3dmem/exner_milieu_loc_m.f90	(revision 5268)
@@ -0,0 +1,164 @@
+module exner_milieu_loc_m
+
+  IMPLICIT NONE
+
+contains
+
+  SUBROUTINE  exner_milieu_loc ( ngrid, ps, p, pks, pk, pkf )
+    !
+    !     Auteurs :  F. Forget , Y. Wanherdrick
+    ! P.Le Van  , Fr. Hourdin  .
+    !    ..........
+    !
+    !    ....  ngrid, ps,p             sont des argum.d'entree  au sous-prog ...
+    !    ....  pks,pk,pkf   sont des argum.de sortie au sous-prog ...
+    !
+    !   ************************************************************************
+    !    Calcule la fonction d'Exner pk = Cp * (p/preff) ** kappa , aux milieux des 
+    !    couches .   Pk(l) sera calcule aux milieux  des couches l ,entre les
+    !    pressions p(l) et p(l+1) ,definis aux interfaces des llm couches .
+    !   ************************************************************************
+    !  .. N.B : Au sommet de l'atmosphere,  p(llm+1) = 0. , et ps et pks sont
+    !    la pression et la fonction d'Exner  au  sol  .
+    !
+    !     WARNING : CECI est une version speciale de exner_hyb originale
+    !               Utilise dans la version martienne pour pouvoir 
+    !               tourner avec des coordonnees verticales complexe
+    !              => Il ne verifie PAS la condition la proportionalite en 
+    !              energie totale/ interne / potentielle (F.Forget 2001)
+    !    ( voir note de Fr.Hourdin )  ,
+    !
+    USE parallel_lmdz
+    USE mod_filtreg_p
+    USE comconst_mod, ONLY: cpp, kappa, r, jmp1
+    USE comvert_mod, ONLY: preff
+    
+    IMPLICIT NONE
+    !
+    include "dimensions.h"
+    include "paramet.h"
+    include "comgeom.h"
+
+    INTEGER  ngrid
+    REAL p(ijb_u:ije_u,llmp1),pk(ijb_u:ije_u,llm)
+    REAL, optional:: pkf(ijb_u:ije_u,llm)
+    REAL ps(ijb_u:ije_u),pks(ijb_u:ije_u)
+
+    !    .... variables locales   ...
+
+    INTEGER l, ij
+    REAL dum1
+
+    INTEGER ije,ijb,jje,jjb
+    logical,save :: firstcall=.true.
+    !$OMP THREADPRIVATE(firstcall) 
+    character(len=*),parameter :: modname="exner_milieu_loc"
+
+    ! Sanity check
+    if (firstcall) then
+       ! sanity checks for Shallow Water case (1 vertical layer)
+       if (llm.eq.1) then
+          if (kappa.ne.1) then
+             call abort_gcm(modname, &
+                  "kappa!=1 , but running in Shallow Water mode!!",42)
+          endif
+          if (cpp.ne.r) then
+             call abort_gcm(modname, &
+                  "cpp!=r , but running in Shallow Water mode!!",42)
+          endif
+       endif ! of if (llm.eq.1)
+
+       firstcall=.false.
+    endif ! of if (firstcall)
+
+    !$OMP BARRIER
+
+    ! Specific behaviour for Shallow Water (1 vertical layer) case:
+    if (llm.eq.1) then
+
+       ! Compute pks(:),pk(:),pkf(:)
+       ijb=ij_begin
+       ije=ij_end
+       !$OMP DO SCHEDULE(STATIC)
+       DO ij=ijb, ije
+          pks(ij) = (cpp/preff) * ps(ij)
+          pk(ij,1) = .5*pks(ij)
+          if (present(pkf)) pkf(ij,1)=pk(ij,1)
+       ENDDO
+       !$OMP ENDDO
+
+       !$OMP BARRIER
+       if (present(pkf)) then
+          jjb=jj_begin
+          jje=jj_end
+          CALL filtreg_p ( pkf,jjb_u,jje_u,jjb,jje, jmp1, llm, &
+               2, 1, .TRUE., 1 )
+       end if
+
+       ! our work is done, exit routine
+       return
+    endif ! of if (llm.eq.1)
+
+    ! General case:
+
+    !     -------------
+    !     Calcul de pks
+    !     -------------
+
+    ijb=ij_begin
+    ije=ij_end
+
+    !$OMP DO SCHEDULE(STATIC)
+    DO   ij  = ijb, ije
+       pks(ij) = cpp * ( ps(ij)/preff ) ** kappa
+    ENDDO
+    !$OMP ENDDO
+    ! Synchro OPENMP ici
+
+    !$OMP BARRIER
+    !
+    !
+    !    .... Calcul de pk  pour la couche l 
+    !    --------------------------------------------
+    !
+    dum1 = cpp * (2*preff)**(-kappa) 
+    DO l = 1, llm-1
+       !$OMP DO SCHEDULE(STATIC)
+       DO   ij   = ijb, ije
+          pk(ij,l) = dum1 * (p(ij,l) + p(ij,l+1))**kappa
+       ENDDO
+       !$OMP ENDDO NOWAIT
+    ENDDO
+
+    !    .... Calcul de pk  pour la couche l = llm ..
+    !    (on met la meme distance (en log pression)  entre Pk(llm)
+    !    et Pk(llm -1) qu'entre Pk(llm-1) et Pk(llm-2)
+
+    !$OMP DO SCHEDULE(STATIC)
+    DO   ij   = ijb, ije
+       pk(ij,llm) = pk(ij,llm-1)**2 / pk(ij,llm-2)
+    ENDDO
+    !$OMP ENDDO NOWAIT        
+
+    if (present(pkf)) then
+       !    calcul de pkf
+
+       DO l = 1, llm
+          !$OMP DO SCHEDULE(STATIC)
+          DO   ij   = ijb, ije
+             pkf(ij,l)=pk(ij,l)
+          ENDDO
+          !$OMP ENDDO NOWAIT
+       ENDDO
+
+       !$OMP BARRIER
+
+       jjb=jj_begin
+       jje=jj_end
+       CALL filtreg_p ( pkf,jjb_u,jje_u,jjb,jje, jmp1, llm, &
+            2, 1, .TRUE., 1 )
+    end if
+
+  END SUBROUTINE exner_milieu_loc
+
+end module exner_milieu_loc_m
Index: DZ6/trunk/libf/dyn3dmem/flumass_loc.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/flumass_loc.F90	(revision 5267)
+++ 	(revision )
@@ -1,91 +1,0 @@
-SUBROUTINE flumass_loc(massebx,masseby, vcont, ucont, pbaru, pbarv )
-!
-!-------------------------------------------------------------------------------
-! Authors: P. Le Van , Fr. Hourdin.
-!-------------------------------------------------------------------------------
-! Purpose: Compute mass flux at s levels.
-  USE parallel_lmdz
-  IMPLICIT NONE
-  include "dimensions.h"
-  include "paramet.h"
-  include "comgeom.h"
-!===============================================================================
-! Arguments:
-  REAL, INTENT(IN)  :: massebx(ijb_u:ije_u,llm)
-  REAL, INTENT(IN)  :: masseby(ijb_v:ije_v,llm)
-  REAL, INTENT(IN)  :: vcont  (ijb_v:ije_v,llm)
-  REAL, INTENT(IN)  :: ucont  (ijb_u:ije_u,llm)
-  REAL, INTENT(OUT) :: pbaru  (ijb_u:ije_u,llm)
-  REAL, INTENT(OUT) :: pbarv  (ijb_v:ije_v,llm)
-!===============================================================================
-! Method used:   A 2 equations system is solved.
-!   * 1st one describes divergence computation at pole point nr. i (i=1 to im):
-!     (0.5*(pbaru(i)-pbaru(i-1))-pbarv(i))/aire(i) = - SUM(pbarv(n))/aire pole
-!   * 2nd one specifies that mean mass flux at pole is equal to 0:
-!     SUM(pbaru(n)*local_area(n))=0
-! This way, we determine additive constant common to pbary elements representing
-!   pbaru(0,j,l) in divergence computation equation for point i=1. (i=1 to im)
-!===============================================================================
-! Local variables:
-  REAL    :: sairen, saireun, ctn, ctn0, apbarun(iim)
-  REAL    :: saires, saireus, cts, cts0, apbarus(iim)
-  INTEGER :: l, i, ij, ijb, ije
-!===============================================================================
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)    
-  DO l=1,llm
-
-    ijb=ij_begin
-    ije=ij_end+iip1
-    IF(pole_nord) ijb=ij_begin+iip1
-    IF(pole_sud)  ije=ij_end-iip1
-    pbaru(ijb:ije,l)=massebx(ijb:ije,l)*ucont(ijb:ije,l)
-
-    ijb=ij_begin-iip1
-    ije=ij_end+iip1
-    IF(pole_nord) ijb=ij_begin
-    IF(pole_sud)  ije=ij_end-iip1
-    pbarv(ijb:ije,l)=masseby(ijb:ije,l)*vcont(ijb:ije,l)
-
-  END DO
-!$OMP END DO NOWAIT
-
-  !--- North pole
-  IF(pole_nord) THEN
-    sairen =SUM(aire (1:iim))
-    saireun=SUM(aireu(1:iim))
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)    
-    DO l=1,llm
-      ctn=SUM(pbarv(1:iim,l))/sairen
-      pbaru(1,l)= pbarv(1,l)-ctn*aire(1)
-      DO i=2,iim
-        pbaru(i,l)=pbaru(i-1,l)+pbarv(i,l)-ctn*aire(i)
-      END DO
-      apbarun(:)=aireu(1:iim)*pbaru(1:iim,l)
-      ctn0 = -SUM(apbarun)/saireun
-      pbaru(1:iim,l)=2.*(pbaru(1:iim,l)+ctn0)
-      pbaru(iip1,l)=pbaru(1,l)
-    END DO
-!$OMP END DO NOWAIT              
-  END IF
-
-  !--- South pole
-  IF(pole_sud) THEN
-    saires =SUM(aire (ip1jm+1:ip1jmp1-1))
-    saireus=SUM(aireu(ip1jm+1:ip1jmp1-1))
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)    
-    DO l=1,llm
-      cts=SUM(pbarv(1+ip1jmi1:ip1jm-1,l))/saires
-      pbaru(1+ip1jm,l)=-pbarv(1+ip1jmi1,l)+cts*aire(1+ip1jm)
-      DO i=2,iim
-        pbaru(i+ip1jm,l)=pbaru(i-1+ip1jm,l)-pbarv(i+ip1jmi1,l)+cts*aire(i+ip1jm)
-      END DO
-      apbarus(:)=aireu(1+ip1jm:ip1jmp1-1)*pbaru(1+ip1jm:ip1jmp1-1,l)
-      cts0 = -SUM(apbarus)/saireus
-      pbaru(1+ip1jm:ip1jmp1-1,l)=2.*(pbaru(1+ip1jm:ip1jmp1-1,l)+cts0)
-      pbaru(ip1jmp1,l)=pbaru(1+ip1jm,l)
-    END DO
-!$OMP END DO NOWAIT         
-  END IF
-
-END SUBROUTINE flumass_loc
-
Index: /LMDZ6/trunk/libf/dyn3dmem/flumass_loc.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/flumass_loc.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3dmem/flumass_loc.f90	(revision 5268)
@@ -0,0 +1,91 @@
+SUBROUTINE flumass_loc(massebx,masseby, vcont, ucont, pbaru, pbarv )
+!
+!-------------------------------------------------------------------------------
+! Authors: P. Le Van , Fr. Hourdin.
+!-------------------------------------------------------------------------------
+! Purpose: Compute mass flux at s levels.
+  USE parallel_lmdz
+  IMPLICIT NONE
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom.h"
+!===============================================================================
+! Arguments:
+  REAL, INTENT(IN)  :: massebx(ijb_u:ije_u,llm)
+  REAL, INTENT(IN)  :: masseby(ijb_v:ije_v,llm)
+  REAL, INTENT(IN)  :: vcont  (ijb_v:ije_v,llm)
+  REAL, INTENT(IN)  :: ucont  (ijb_u:ije_u,llm)
+  REAL, INTENT(OUT) :: pbaru  (ijb_u:ije_u,llm)
+  REAL, INTENT(OUT) :: pbarv  (ijb_v:ije_v,llm)
+!===============================================================================
+! Method used:   A 2 equations system is solved.
+!   * 1st one describes divergence computation at pole point nr. i (i=1 to im):
+!     (0.5*(pbaru(i)-pbaru(i-1))-pbarv(i))/aire(i) = - SUM(pbarv(n))/aire pole
+!   * 2nd one specifies that mean mass flux at pole is equal to 0:
+!     SUM(pbaru(n)*local_area(n))=0
+! This way, we determine additive constant common to pbary elements representing
+!   pbaru(0,j,l) in divergence computation equation for point i=1. (i=1 to im)
+!===============================================================================
+! Local variables:
+  REAL    :: sairen, saireun, ctn, ctn0, apbarun(iim)
+  REAL    :: saires, saireus, cts, cts0, apbarus(iim)
+  INTEGER :: l, i, ij, ijb, ije
+!===============================================================================
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)    
+  DO l=1,llm
+
+    ijb=ij_begin
+    ije=ij_end+iip1
+    IF(pole_nord) ijb=ij_begin+iip1
+    IF(pole_sud)  ije=ij_end-iip1
+    pbaru(ijb:ije,l)=massebx(ijb:ije,l)*ucont(ijb:ije,l)
+
+    ijb=ij_begin-iip1
+    ije=ij_end+iip1
+    IF(pole_nord) ijb=ij_begin
+    IF(pole_sud)  ije=ij_end-iip1
+    pbarv(ijb:ije,l)=masseby(ijb:ije,l)*vcont(ijb:ije,l)
+
+  END DO
+!$OMP END DO NOWAIT
+
+  !--- North pole
+  IF(pole_nord) THEN
+    sairen =SUM(aire (1:iim))
+    saireun=SUM(aireu(1:iim))
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)    
+    DO l=1,llm
+      ctn=SUM(pbarv(1:iim,l))/sairen
+      pbaru(1,l)= pbarv(1,l)-ctn*aire(1)
+      DO i=2,iim
+        pbaru(i,l)=pbaru(i-1,l)+pbarv(i,l)-ctn*aire(i)
+      END DO
+      apbarun(:)=aireu(1:iim)*pbaru(1:iim,l)
+      ctn0 = -SUM(apbarun)/saireun
+      pbaru(1:iim,l)=2.*(pbaru(1:iim,l)+ctn0)
+      pbaru(iip1,l)=pbaru(1,l)
+    END DO
+!$OMP END DO NOWAIT              
+  END IF
+
+  !--- South pole
+  IF(pole_sud) THEN
+    saires =SUM(aire (ip1jm+1:ip1jmp1-1))
+    saireus=SUM(aireu(ip1jm+1:ip1jmp1-1))
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)    
+    DO l=1,llm
+      cts=SUM(pbarv(1+ip1jmi1:ip1jm-1,l))/saires
+      pbaru(1+ip1jm,l)=-pbarv(1+ip1jmi1,l)+cts*aire(1+ip1jm)
+      DO i=2,iim
+        pbaru(i+ip1jm,l)=pbaru(i-1+ip1jm,l)-pbarv(i+ip1jmi1,l)+cts*aire(i+ip1jm)
+      END DO
+      apbarus(:)=aireu(1+ip1jm:ip1jmp1-1)*pbaru(1+ip1jm:ip1jmp1-1,l)
+      cts0 = -SUM(apbarus)/saireus
+      pbaru(1+ip1jm:ip1jmp1-1,l)=2.*(pbaru(1+ip1jm:ip1jmp1-1,l)+cts0)
+      pbaru(ip1jmp1,l)=pbaru(1+ip1jm,l)
+    END DO
+!$OMP END DO NOWAIT         
+  END IF
+
+END SUBROUTINE flumass_loc
+
Index: DZ6/trunk/libf/dyn3dmem/friction_loc.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/friction_loc.F90	(revision 5267)
+++ 	(revision )
@@ -1,199 +1,0 @@
-!
-! $Id: friction_p.F 1299 2010-01-20 14:27:21Z fairhead $
-!
-!=======================================================================
-SUBROUTINE friction_loc(ucov,vcov,pdt)
-  USE parallel_lmdz
-  USE control_mod
-  USE IOIPSL
-
-  USE comconst_mod, ONLY: pi
-  IMPLICIT NONE
-
-  !=======================================================================
-  !
-  !   Friction for the Newtonian case:
-  !   --------------------------------
-  !    2 possibilities (depending on flag 'friction_type'
-  ! friction_type=0 : A friction that is only applied to the lowermost
-  !                   atmospheric layer
-  ! friction_type=1 : Friction applied on all atmospheric layer (but
-  !   (default)       with stronger magnitude near the surface; see
-  !                   iniacademic.F)
-  !=======================================================================
-
-  include "dimensions.h"
-  include "paramet.h"
-  include "comgeom2.h"
-  include "iniprint.h"
-  include "academic.h"
-
-  ! arguments:
-  REAL,INTENT(inout) :: ucov( iip1,jjb_u:jje_u,llm )
-  REAL,INTENT(inout) :: vcov( iip1,jjb_v:jje_v,llm )
-  REAL,INTENT(in) :: pdt ! time step
-
-  ! local variables:
-
-  REAL :: modv(iip1,jjb_u:jje_u),zco,zsi
-  REAL :: vpn,vps,upoln,upols,vpols,vpoln
-  REAL :: u2(iip1,jjb_u:jje_u),v2(iip1,jjb_v:jje_v)
-  INTEGER :: i,j,l
-  REAL,PARAMETER :: cfric=1.e-5
-  LOGICAL,SAVE :: firstcall=.true.
-  INTEGER,SAVE :: friction_type=1
-  CHARACTER(len=20) :: modname="friction_p"
-  CHARACTER(len=80) :: abort_message
-!$OMP THREADPRIVATE(firstcall,friction_type)
-  integer :: jjb,jje
-
-!$OMP SINGLE
-  IF (firstcall) THEN
-    ! ! set friction type
-    call getin("friction_type",friction_type)
-    if ((friction_type.lt.0).or.(friction_type.gt.1)) then
-      abort_message="wrong friction type"
-      write(lunout,*)'Friction: wrong friction type',friction_type
-      call abort_gcm(modname,abort_message,42)
-    endif
-    firstcall=.false.
-  ENDIF
-!$OMP END SINGLE COPYPRIVATE(friction_type,firstcall)
-
-  if (friction_type.eq.0) then ! friction on first layer only
-!$OMP SINGLE
-  !   calcul des composantes au carre du vent naturel
-  jjb=jj_begin
-  jje=jj_end+1
-  if (pole_sud) jje=jj_end
-
-  do j=jjb,jje
-     do i=1,iip1
-        u2(i,j)=ucov(i,j,1)*ucov(i,j,1)*unscu2(i,j)
-     enddo
-  enddo
-
-  jjb=jj_begin-1
-  jje=jj_end+1
-  if (pole_nord) jjb=jj_begin
-  if (pole_sud) jje=jj_end-1
-
-  do j=jjb,jje
-     do i=1,iip1
-        v2(i,j)=vcov(i,j,1)*vcov(i,j,1)*unscv2(i,j)
-     enddo
-  enddo
-
-  !   calcul du module de V en dehors des poles
-  jjb=jj_begin
-  jje=jj_end+1
-  if (pole_nord) jjb=jj_begin+1
-  if (pole_sud) jje=jj_end-1
-
-  do j=jjb,jje
-     do i=2,iip1
-        modv(i,j)=sqrt(0.5*(u2(i-1,j)+u2(i,j)+v2(i,j-1)+v2(i,j)))
-     enddo
-     modv(1,j)=modv(iip1,j)
-  enddo
-
-  !   les deux composantes du vent au pole sont obtenues comme
-  !   premiers modes de fourier de v pres du pole
-  if (pole_nord) then
-
-    upoln=0.
-    vpoln=0.
-
-    do i=2,iip1
-       zco=cos(rlonv(i))*(rlonu(i)-rlonu(i-1))
-       zsi=sin(rlonv(i))*(rlonu(i)-rlonu(i-1))
-       vpn=vcov(i,1,1)/cv(i,1)
-       upoln=upoln+zco*vpn
-       vpoln=vpoln+zsi*vpn
-    enddo
-    vpn=sqrt(upoln*upoln+vpoln*vpoln)/pi
-    do i=1,iip1
-       ! modv(i,1)=vpn
-       modv(i,1)=modv(i,2)
-    enddo
-
-  endif
-
-  if (pole_sud) then
-
-    upols=0.
-    vpols=0.
-    do i=2,iip1
-       zco=cos(rlonv(i))*(rlonu(i)-rlonu(i-1))
-       zsi=sin(rlonv(i))*(rlonu(i)-rlonu(i-1))
-       vps=vcov(i,jjm,1)/cv(i,jjm)
-       upols=upols+zco*vps
-       vpols=vpols+zsi*vps
-    enddo
-    vps=sqrt(upols*upols+vpols*vpols)/pi
-    do i=1,iip1
-     ! modv(i,jjp1)=vps
-     modv(i,jjp1)=modv(i,jjm)
-    enddo
-
-  endif
-
-  !   calcul du frottement au sol.
-
-  jjb=jj_begin
-  jje=jj_end
-  if (pole_nord) jjb=jj_begin+1
-  if (pole_sud) jje=jj_end-1
-
-  do j=jjb,jje
-     do i=1,iim
-        ucov(i,j,1)=ucov(i,j,1) &
-              -cfric*pdt*0.5*(modv(i+1,j)+modv(i,j))*ucov(i,j,1)
-     enddo
-     ucov(iip1,j,1)=ucov(1,j,1)
-  enddo
-
-  jjb=jj_begin
-  jje=jj_end
-  if (pole_sud) jje=jj_end-1
-
-  do j=jjb,jje
-     do i=1,iip1
-        vcov(i,j,1)=vcov(i,j,1) &
-              -cfric*pdt*0.5*(modv(i,j+1)+modv(i,j))*vcov(i,j,1)
-     enddo
-     vcov(iip1,j,1)=vcov(1,j,1)
-  enddo
-!$OMP END SINGLE
-  endif ! of if (friction_type.eq.0)
-
-  if (friction_type.eq.1) then
-   ! ! for ucov()
-    jjb=jj_begin
-    jje=jj_end
-    if (pole_nord) jjb=jj_begin+1
-    if (pole_sud) jje=jj_end-1
-
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-    do l=1,llm
-      ucov(1:iip1,jjb:jje,l)=ucov(1:iip1,jjb:jje,l)* &
-            (1.-pdt*kfrict(l))
-    enddo
-!$OMP END DO NOWAIT
-
-   ! ! for vcoc()
-    jjb=jj_begin
-    jje=jj_end
-    if (pole_sud) jje=jj_end-1
-
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-    do l=1,llm
-      vcov(1:iip1,jjb:jje,l)=vcov(1:iip1,jjb:jje,l)* &
-            (1.-pdt*kfrict(l))
-    enddo
-!$OMP END DO
-  endif ! of if (friction_type.eq.1)
-
-  RETURN
-END SUBROUTINE friction_loc
-
Index: /LMDZ6/trunk/libf/dyn3dmem/friction_loc.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/friction_loc.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3dmem/friction_loc.f90	(revision 5268)
@@ -0,0 +1,199 @@
+!
+! $Id: friction_p.F 1299 2010-01-20 14:27:21Z fairhead $
+!
+!=======================================================================
+SUBROUTINE friction_loc(ucov,vcov,pdt)
+  USE parallel_lmdz
+  USE control_mod
+  USE IOIPSL
+
+  USE comconst_mod, ONLY: pi
+  IMPLICIT NONE
+
+  !=======================================================================
+  !
+  !   Friction for the Newtonian case:
+  !   --------------------------------
+  !    2 possibilities (depending on flag 'friction_type'
+  ! friction_type=0 : A friction that is only applied to the lowermost
+  !                   atmospheric layer
+  ! friction_type=1 : Friction applied on all atmospheric layer (but
+  !   (default)       with stronger magnitude near the surface; see
+  !                   iniacademic.F)
+  !=======================================================================
+
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom2.h"
+  include "iniprint.h"
+  include "academic.h"
+
+  ! arguments:
+  REAL,INTENT(inout) :: ucov( iip1,jjb_u:jje_u,llm )
+  REAL,INTENT(inout) :: vcov( iip1,jjb_v:jje_v,llm )
+  REAL,INTENT(in) :: pdt ! time step
+
+  ! local variables:
+
+  REAL :: modv(iip1,jjb_u:jje_u),zco,zsi
+  REAL :: vpn,vps,upoln,upols,vpols,vpoln
+  REAL :: u2(iip1,jjb_u:jje_u),v2(iip1,jjb_v:jje_v)
+  INTEGER :: i,j,l
+  REAL,PARAMETER :: cfric=1.e-5
+  LOGICAL,SAVE :: firstcall=.true.
+  INTEGER,SAVE :: friction_type=1
+  CHARACTER(len=20) :: modname="friction_p"
+  CHARACTER(len=80) :: abort_message
+!$OMP THREADPRIVATE(firstcall,friction_type)
+  integer :: jjb,jje
+
+!$OMP SINGLE
+  IF (firstcall) THEN
+    ! ! set friction type
+    call getin("friction_type",friction_type)
+    if ((friction_type.lt.0).or.(friction_type.gt.1)) then
+      abort_message="wrong friction type"
+      write(lunout,*)'Friction: wrong friction type',friction_type
+      call abort_gcm(modname,abort_message,42)
+    endif
+    firstcall=.false.
+  ENDIF
+!$OMP END SINGLE COPYPRIVATE(friction_type,firstcall)
+
+  if (friction_type.eq.0) then ! friction on first layer only
+!$OMP SINGLE
+  !   calcul des composantes au carre du vent naturel
+  jjb=jj_begin
+  jje=jj_end+1
+  if (pole_sud) jje=jj_end
+
+  do j=jjb,jje
+     do i=1,iip1
+        u2(i,j)=ucov(i,j,1)*ucov(i,j,1)*unscu2(i,j)
+     enddo
+  enddo
+
+  jjb=jj_begin-1
+  jje=jj_end+1
+  if (pole_nord) jjb=jj_begin
+  if (pole_sud) jje=jj_end-1
+
+  do j=jjb,jje
+     do i=1,iip1
+        v2(i,j)=vcov(i,j,1)*vcov(i,j,1)*unscv2(i,j)
+     enddo
+  enddo
+
+  !   calcul du module de V en dehors des poles
+  jjb=jj_begin
+  jje=jj_end+1
+  if (pole_nord) jjb=jj_begin+1
+  if (pole_sud) jje=jj_end-1
+
+  do j=jjb,jje
+     do i=2,iip1
+        modv(i,j)=sqrt(0.5*(u2(i-1,j)+u2(i,j)+v2(i,j-1)+v2(i,j)))
+     enddo
+     modv(1,j)=modv(iip1,j)
+  enddo
+
+  !   les deux composantes du vent au pole sont obtenues comme
+  !   premiers modes de fourier de v pres du pole
+  if (pole_nord) then
+
+    upoln=0.
+    vpoln=0.
+
+    do i=2,iip1
+       zco=cos(rlonv(i))*(rlonu(i)-rlonu(i-1))
+       zsi=sin(rlonv(i))*(rlonu(i)-rlonu(i-1))
+       vpn=vcov(i,1,1)/cv(i,1)
+       upoln=upoln+zco*vpn
+       vpoln=vpoln+zsi*vpn
+    enddo
+    vpn=sqrt(upoln*upoln+vpoln*vpoln)/pi
+    do i=1,iip1
+       ! modv(i,1)=vpn
+       modv(i,1)=modv(i,2)
+    enddo
+
+  endif
+
+  if (pole_sud) then
+
+    upols=0.
+    vpols=0.
+    do i=2,iip1
+       zco=cos(rlonv(i))*(rlonu(i)-rlonu(i-1))
+       zsi=sin(rlonv(i))*(rlonu(i)-rlonu(i-1))
+       vps=vcov(i,jjm,1)/cv(i,jjm)
+       upols=upols+zco*vps
+       vpols=vpols+zsi*vps
+    enddo
+    vps=sqrt(upols*upols+vpols*vpols)/pi
+    do i=1,iip1
+     ! modv(i,jjp1)=vps
+     modv(i,jjp1)=modv(i,jjm)
+    enddo
+
+  endif
+
+  !   calcul du frottement au sol.
+
+  jjb=jj_begin
+  jje=jj_end
+  if (pole_nord) jjb=jj_begin+1
+  if (pole_sud) jje=jj_end-1
+
+  do j=jjb,jje
+     do i=1,iim
+        ucov(i,j,1)=ucov(i,j,1) &
+              -cfric*pdt*0.5*(modv(i+1,j)+modv(i,j))*ucov(i,j,1)
+     enddo
+     ucov(iip1,j,1)=ucov(1,j,1)
+  enddo
+
+  jjb=jj_begin
+  jje=jj_end
+  if (pole_sud) jje=jj_end-1
+
+  do j=jjb,jje
+     do i=1,iip1
+        vcov(i,j,1)=vcov(i,j,1) &
+              -cfric*pdt*0.5*(modv(i,j+1)+modv(i,j))*vcov(i,j,1)
+     enddo
+     vcov(iip1,j,1)=vcov(1,j,1)
+  enddo
+!$OMP END SINGLE
+  endif ! of if (friction_type.eq.0)
+
+  if (friction_type.eq.1) then
+   ! ! for ucov()
+    jjb=jj_begin
+    jje=jj_end
+    if (pole_nord) jjb=jj_begin+1
+    if (pole_sud) jje=jj_end-1
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    do l=1,llm
+      ucov(1:iip1,jjb:jje,l)=ucov(1:iip1,jjb:jje,l)* &
+            (1.-pdt*kfrict(l))
+    enddo
+!$OMP END DO NOWAIT
+
+   ! ! for vcoc()
+    jjb=jj_begin
+    jje=jj_end
+    if (pole_sud) jje=jj_end-1
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    do l=1,llm
+      vcov(1:iip1,jjb:jje,l)=vcov(1:iip1,jjb:jje,l)* &
+            (1.-pdt*kfrict(l))
+    enddo
+!$OMP END DO
+  endif ! of if (friction_type.eq.1)
+
+  RETURN
+END SUBROUTINE friction_loc
+
Index: DZ6/trunk/libf/dyn3dmem/getparam.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/getparam.F90	(revision 5267)
+++ 	(revision )
@@ -1,115 +1,0 @@
-!
-! $Id: getparam.F90 1279 2009-12-10 09:02:56Z fairhead $
-!
-MODULE getparam
-   USE IOIPSL
-
-
-   INTERFACE getpar
-     MODULE PROCEDURE getparamr,getparami,getparaml
-   END INTERFACE
-   private getparamr,getparami,getparaml
-
-   INTEGER, PARAMETER :: out_eff=99
-
-CONTAINS
-  SUBROUTINE ini_getparam(fichier)
-  USE parallel_lmdz
-    !
-    IMPLICIT NONE
-    !
-    CHARACTER*(*) :: fichier
-    IF (mpi_rank==0) OPEN(out_eff,file=fichier,status='unknown',form='formatted')
-    
-  END SUBROUTINE ini_getparam
-
-  SUBROUTINE fin_getparam
-  USE parallel_lmdz
-    !
-    IMPLICIT NONE
-    !
-      IF (mpi_rank==0) CLOSE(out_eff)
-
-  END SUBROUTINE fin_getparam
-
-  SUBROUTINE getparamr(TARGET,def_val,ret_val,comment)
-  USE parallel_lmdz
-    !
-    IMPLICIT NONE
-    !
-    !   Get a real scalar. We first check if we find it
-    !   in the database and if not we get it from the run.def
-    !
-    !   getinr1d and getinr2d are written on the same pattern
-    !
-    CHARACTER*(*) :: TARGET
-    REAL :: def_val
-    REAL :: ret_val
-    CHARACTER*(*) :: comment
-
-    ret_val=def_val
-    call getin(TARGET,ret_val)
-
-    IF (mpi_rank==0) THEN
-      write(out_eff,*) '######################################'
-      write(out_eff,*) '#### ',comment,' #####'
-      write(out_eff,*) TARGET,'=',ret_val
-    ENDIF
-    
-  END SUBROUTINE getparamr
-
-  SUBROUTINE getparami(TARGET,def_val,ret_val,comment)
-  USE parallel_lmdz
-    !
-    IMPLICIT NONE
-    !
-    !   Get a real scalar. We first check if we find it
-    !   in the database and if not we get it from the run.def
-    !
-    !   getinr1d and getinr2d are written on the same pattern
-    !
-    CHARACTER*(*) :: TARGET
-    INTEGER :: def_val
-    INTEGER :: ret_val
-    CHARACTER*(*) :: comment
-
-    ret_val=def_val
-    call getin(TARGET,ret_val)
-
-    IF (mpi_rank==0) THEN
-      write(out_eff,*) '######################################'
-      write(out_eff,*) '#### ',comment,' #####'
-      write(out_eff,*) comment
-      write(out_eff,*) TARGET,'=',ret_val
-    ENDIF
-    
-  END SUBROUTINE getparami
-
-  SUBROUTINE getparaml(TARGET,def_val,ret_val,comment)
-  USE parallel_lmdz
-    !
-    IMPLICIT NONE
-    !
-    !   Get a real scalar. We first check if we find it
-    !   in the database and if not we get it from the run.def
-    !
-    !   getinr1d and getinr2d are written on the same pattern
-    !
-    CHARACTER*(*) :: TARGET
-    LOGICAL :: def_val
-    LOGICAL :: ret_val
-    CHARACTER*(*) :: comment
-
-    ret_val=def_val
-    call getin(TARGET,ret_val)
-
-    IF (mpi_rank==0) THEN
-      write(out_eff,*) '######################################'
-      write(out_eff,*) '#### ',comment,' #####'
-      write(out_eff,*) TARGET,'=',ret_val
-    ENDIF
-       
-  END SUBROUTINE getparaml
-
-
-END MODULE getparam
Index: /LMDZ6/trunk/libf/dyn3dmem/getparam.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/getparam.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3dmem/getparam.f90	(revision 5268)
@@ -0,0 +1,115 @@
+!
+! $Id: getparam.F90 1279 2009-12-10 09:02:56Z fairhead $
+!
+MODULE getparam
+   USE IOIPSL
+
+
+   INTERFACE getpar
+     MODULE PROCEDURE getparamr,getparami,getparaml
+   END INTERFACE
+   private getparamr,getparami,getparaml
+
+   INTEGER, PARAMETER :: out_eff=99
+
+CONTAINS
+  SUBROUTINE ini_getparam(fichier)
+  USE parallel_lmdz
+    !
+    IMPLICIT NONE
+    !
+    CHARACTER*(*) :: fichier
+    IF (mpi_rank==0) OPEN(out_eff,file=fichier,status='unknown',form='formatted')
+    
+  END SUBROUTINE ini_getparam
+
+  SUBROUTINE fin_getparam
+  USE parallel_lmdz
+    !
+    IMPLICIT NONE
+    !
+      IF (mpi_rank==0) CLOSE(out_eff)
+
+  END SUBROUTINE fin_getparam
+
+  SUBROUTINE getparamr(TARGET,def_val,ret_val,comment)
+  USE parallel_lmdz
+    !
+    IMPLICIT NONE
+    !
+    !   Get a real scalar. We first check if we find it
+    !   in the database and if not we get it from the run.def
+    !
+    !   getinr1d and getinr2d are written on the same pattern
+    !
+    CHARACTER*(*) :: TARGET
+    REAL :: def_val
+    REAL :: ret_val
+    CHARACTER*(*) :: comment
+
+    ret_val=def_val
+    call getin(TARGET,ret_val)
+
+    IF (mpi_rank==0) THEN
+      write(out_eff,*) '######################################'
+      write(out_eff,*) '#### ',comment,' #####'
+      write(out_eff,*) TARGET,'=',ret_val
+    ENDIF
+    
+  END SUBROUTINE getparamr
+
+  SUBROUTINE getparami(TARGET,def_val,ret_val,comment)
+  USE parallel_lmdz
+    !
+    IMPLICIT NONE
+    !
+    !   Get a real scalar. We first check if we find it
+    !   in the database and if not we get it from the run.def
+    !
+    !   getinr1d and getinr2d are written on the same pattern
+    !
+    CHARACTER*(*) :: TARGET
+    INTEGER :: def_val
+    INTEGER :: ret_val
+    CHARACTER*(*) :: comment
+
+    ret_val=def_val
+    call getin(TARGET,ret_val)
+
+    IF (mpi_rank==0) THEN
+      write(out_eff,*) '######################################'
+      write(out_eff,*) '#### ',comment,' #####'
+      write(out_eff,*) comment
+      write(out_eff,*) TARGET,'=',ret_val
+    ENDIF
+    
+  END SUBROUTINE getparami
+
+  SUBROUTINE getparaml(TARGET,def_val,ret_val,comment)
+  USE parallel_lmdz
+    !
+    IMPLICIT NONE
+    !
+    !   Get a real scalar. We first check if we find it
+    !   in the database and if not we get it from the run.def
+    !
+    !   getinr1d and getinr2d are written on the same pattern
+    !
+    CHARACTER*(*) :: TARGET
+    LOGICAL :: def_val
+    LOGICAL :: ret_val
+    CHARACTER*(*) :: comment
+
+    ret_val=def_val
+    call getin(TARGET,ret_val)
+
+    IF (mpi_rank==0) THEN
+      write(out_eff,*) '######################################'
+      write(out_eff,*) '#### ',comment,' #####'
+      write(out_eff,*) TARGET,'=',ret_val
+    ENDIF
+       
+  END SUBROUTINE getparaml
+
+
+END MODULE getparam
Index: DZ6/trunk/libf/dyn3dmem/gradiv2_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/gradiv2_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,39 +1,0 @@
-MODULE gradiv2_mod
-
-  REAL,POINTER,SAVE ::  gdx( :,: )
-  REAL,POINTER,SAVE ::  gdy( :,: )
-  REAL,POINTER,SAVE ::  div( :,: )
-  
-CONTAINS
-
-  SUBROUTINE gradiv2_allocate
-  USE bands
-  USE allocate_field_mod
-  USE parallel_lmdz
-  USE dimensions_mod
-  IMPLICIT NONE
-    TYPE(distrib),POINTER :: d
-    d=>distrib_dissip
-
-    CALL allocate_u(gdx,llm,d)
-    CALL allocate_v(gdy,llm,d)
-    CALL allocate_u(div,llm,d)
-
-    
-  END SUBROUTINE gradiv2_allocate
-  
-  SUBROUTINE gradiv2_switch_dissip(dist)
-  USE allocate_field_mod
-  USE bands
-  USE parallel_lmdz
-  IMPLICIT NONE
-    TYPE(distrib),INTENT(IN) :: dist
-
-    CALL switch_u(gdx,distrib_dissip,dist)
-    CALL switch_v(gdy,distrib_dissip,dist)
-    CALL switch_u(div,distrib_dissip,dist)
-
-
-  END SUBROUTINE gradiv2_switch_dissip
-  
-END MODULE gradiv2_mod  
Index: /LMDZ6/trunk/libf/dyn3dmem/gradiv2_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/gradiv2_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3dmem/gradiv2_mod.f90	(revision 5268)
@@ -0,0 +1,39 @@
+MODULE gradiv2_mod
+
+  REAL,POINTER,SAVE ::  gdx( :,: )
+  REAL,POINTER,SAVE ::  gdy( :,: )
+  REAL,POINTER,SAVE ::  div( :,: )
+  
+CONTAINS
+
+  SUBROUTINE gradiv2_allocate
+  USE bands
+  USE allocate_field_mod
+  USE parallel_lmdz
+  USE dimensions_mod
+  IMPLICIT NONE
+    TYPE(distrib),POINTER :: d
+    d=>distrib_dissip
+
+    CALL allocate_u(gdx,llm,d)
+    CALL allocate_v(gdy,llm,d)
+    CALL allocate_u(div,llm,d)
+
+    
+  END SUBROUTINE gradiv2_allocate
+  
+  SUBROUTINE gradiv2_switch_dissip(dist)
+  USE allocate_field_mod
+  USE bands
+  USE parallel_lmdz
+  IMPLICIT NONE
+    TYPE(distrib),INTENT(IN) :: dist
+
+    CALL switch_u(gdx,distrib_dissip,dist)
+    CALL switch_v(gdy,distrib_dissip,dist)
+    CALL switch_u(div,distrib_dissip,dist)
+
+
+  END SUBROUTINE gradiv2_switch_dissip
+  
+END MODULE gradiv2_mod  
Index: DZ6/trunk/libf/dyn3dmem/groupe_loc.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/groupe_loc.F90	(revision 5267)
+++ 	(revision )
@@ -1,129 +1,0 @@
-subroutine groupe_loc(pext,pbaru,pbarv,pbarum,pbarvm,wm)
-  USE parallel_lmdz
-  USE Write_field_loc
-  USE groupe_mod
-  USE comconst_mod, ONLY: ngroup
-  USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_DEBUGIO
-  implicit none
-
-  !   sous-programme servant a fitlrer les champs de flux de masse aux
-  !   poles en "regroupant" les mailles 2 par 2 puis 4 par 4 etc. au fur
-  !   et a mesure qu'on se rapproche du pole.
-  !
-  !   en entree: pext, pbaru et pbarv
-  !
-  !   en sortie:  pbarum,pbarvm et wm.
-  !
-  !   remarque, le wm est recalcule a partir des pbaru pbarv et on n'a donc
-  !   pas besoin de w en entree.
-
-  include "dimensions.h"
-  include "paramet.h"
-  include "comgeom2.h"
-
-  ! integer ngroup
-  ! parameter (ngroup=3)
-
-
-  real :: pbaru(iip1,jjb_u:jje_u,llm),pbarv(iip1,jjb_v:jje_v,llm)
-  real :: pext(iip1,jjb_u:jje_u,llm)
-
-  real :: pbarum(iip1,jjb_u:jje_u,llm),pbarvm(iip1,jjb_v:jje_v,llm)
-  real :: wm(iip1,jjb_u:jje_u,llm)
-
-
-  real :: uu
-
-  integer :: i,j,l
-
-  logical :: firstcall
-  save firstcall
-!$OMP THREADPRIVATE(firstcall)
-
-  integer :: ijb,ije,jjb,jje
-
-  !   Champs 1D
-
-  call convflu_loc(pbaru,pbarv,llm,zconvm)
-
-  !
-  !  call scopy(ijp1llm,zconvm,1,zconvmm,1)
-  !  call scopy(ijmllm,pbarv,1,pbarvm,1)
-
-  jjb=jj_begin
-  jje=jj_end
-
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-  do l=1,llm
-    zconvmm(:,jjb:jje,l)=zconvm(:,jjb:jje,l)
-  enddo
-!$OMP END DO NOWAIT
-
-  call groupeun_loc(jjp1,llm,jjb_u,jje_u,jjb,jje,zconvmm)
-
-  jjb=jj_begin-1
-  jje=jj_end
-  if (pole_nord) jjb=jj_begin
-  if (pole_sud)  jje=jj_end-1
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-  do l=1,llm
-    pbarvm(:,jjb:jje,l)=pbarv(:,jjb:jje,l)
-  enddo
-!$OMP END DO NOWAIT
-
-IF (CPPKEY_DEBUGIO) THEN
-  CALL WriteField_v('pbarvm',reshape(pbarvm,(/ip1jm,llm/)))
-END IF
-  call groupeun_loc(jjm,llm,jjb_v,jje_v,jjb,jje,pbarvm)
-IF (CPPKEY_DEBUGIO) THEN
-  CALL WriteField_v('pbarvm',reshape(pbarvm,(/ip1jm,llm/)))
-END IF
-  !   Champs 3D
-
-  jjb=jj_begin
-  jje=jj_end
-  if (pole_nord) jjb=jj_begin+1
-  if (pole_sud)  jje=jj_end-1
-
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-  do l=1,llm
-     do j=jjb,jje
-        uu=pbaru(iim,j,l)
-        do i=1,iim
-           uu=uu+pbarvm(i,j,l)-pbarvm(i,j-1,l)-zconvmm(i,j,l)
-           pbarum(i,j,l)=uu
-  ! zconvm(i,j,l ) =  xflu(i-1,j,l)-xflu(i,j,l)+
-  !    *                      yflu(i,j,l)-yflu(i,j-1,l)
-        enddo
-        pbarum(iip1,j,l)=pbarum(1,j,l)
-     enddo
-  enddo
-!$OMP END DO NOWAIT
-  !    integration de la convergence de masse de haut  en bas ......
-
-  jjb=jj_begin
-  jje=jj_end
-
-!$OMP BARRIER
-!$OMP MASTER
-  do  l = llm-1,1,-1
-      do j=jjb,jje
-         do i=1,iip1
-            zconvmm(i,j,l)=zconvmm(i,j,l)+zconvmm(i,j,l+1)
-         enddo
-      enddo
-  enddo
-
-  if (.not. pole_sud) then
-    zconvmm(:,jj_end+1,:)=0
-  !ym	wm(:,jj_end+1,:)=0
-  endif
-
-!$OMP END MASTER
-!$OMP BARRIER
-
-  CALL vitvert_loc(zconvmm,wm)
-
-  return
-end subroutine groupe_loc
-
Index: /LMDZ6/trunk/libf/dyn3dmem/groupe_loc.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/groupe_loc.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3dmem/groupe_loc.f90	(revision 5268)
@@ -0,0 +1,129 @@
+subroutine groupe_loc(pext,pbaru,pbarv,pbarum,pbarvm,wm)
+  USE parallel_lmdz
+  USE Write_field_loc
+  USE groupe_mod
+  USE comconst_mod, ONLY: ngroup
+  USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_DEBUGIO
+  implicit none
+
+  !   sous-programme servant a fitlrer les champs de flux de masse aux
+  !   poles en "regroupant" les mailles 2 par 2 puis 4 par 4 etc. au fur
+  !   et a mesure qu'on se rapproche du pole.
+  !
+  !   en entree: pext, pbaru et pbarv
+  !
+  !   en sortie:  pbarum,pbarvm et wm.
+  !
+  !   remarque, le wm est recalcule a partir des pbaru pbarv et on n'a donc
+  !   pas besoin de w en entree.
+
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom2.h"
+
+  ! integer ngroup
+  ! parameter (ngroup=3)
+
+
+  real :: pbaru(iip1,jjb_u:jje_u,llm),pbarv(iip1,jjb_v:jje_v,llm)
+  real :: pext(iip1,jjb_u:jje_u,llm)
+
+  real :: pbarum(iip1,jjb_u:jje_u,llm),pbarvm(iip1,jjb_v:jje_v,llm)
+  real :: wm(iip1,jjb_u:jje_u,llm)
+
+
+  real :: uu
+
+  integer :: i,j,l
+
+  logical :: firstcall
+  save firstcall
+!$OMP THREADPRIVATE(firstcall)
+
+  integer :: ijb,ije,jjb,jje
+
+  !   Champs 1D
+
+  call convflu_loc(pbaru,pbarv,llm,zconvm)
+
+  !
+  !  call scopy(ijp1llm,zconvm,1,zconvmm,1)
+  !  call scopy(ijmllm,pbarv,1,pbarvm,1)
+
+  jjb=jj_begin
+  jje=jj_end
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  do l=1,llm
+    zconvmm(:,jjb:jje,l)=zconvm(:,jjb:jje,l)
+  enddo
+!$OMP END DO NOWAIT
+
+  call groupeun_loc(jjp1,llm,jjb_u,jje_u,jjb,jje,zconvmm)
+
+  jjb=jj_begin-1
+  jje=jj_end
+  if (pole_nord) jjb=jj_begin
+  if (pole_sud)  jje=jj_end-1
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  do l=1,llm
+    pbarvm(:,jjb:jje,l)=pbarv(:,jjb:jje,l)
+  enddo
+!$OMP END DO NOWAIT
+
+IF (CPPKEY_DEBUGIO) THEN
+  CALL WriteField_v('pbarvm',reshape(pbarvm,(/ip1jm,llm/)))
+END IF
+  call groupeun_loc(jjm,llm,jjb_v,jje_v,jjb,jje,pbarvm)
+IF (CPPKEY_DEBUGIO) THEN
+  CALL WriteField_v('pbarvm',reshape(pbarvm,(/ip1jm,llm/)))
+END IF
+  !   Champs 3D
+
+  jjb=jj_begin
+  jje=jj_end
+  if (pole_nord) jjb=jj_begin+1
+  if (pole_sud)  jje=jj_end-1
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  do l=1,llm
+     do j=jjb,jje
+        uu=pbaru(iim,j,l)
+        do i=1,iim
+           uu=uu+pbarvm(i,j,l)-pbarvm(i,j-1,l)-zconvmm(i,j,l)
+           pbarum(i,j,l)=uu
+  ! zconvm(i,j,l ) =  xflu(i-1,j,l)-xflu(i,j,l)+
+  !    *                      yflu(i,j,l)-yflu(i,j-1,l)
+        enddo
+        pbarum(iip1,j,l)=pbarum(1,j,l)
+     enddo
+  enddo
+!$OMP END DO NOWAIT
+  !    integration de la convergence de masse de haut  en bas ......
+
+  jjb=jj_begin
+  jje=jj_end
+
+!$OMP BARRIER
+!$OMP MASTER
+  do  l = llm-1,1,-1
+      do j=jjb,jje
+         do i=1,iip1
+            zconvmm(i,j,l)=zconvmm(i,j,l)+zconvmm(i,j,l+1)
+         enddo
+      enddo
+  enddo
+
+  if (.not. pole_sud) then
+    zconvmm(:,jj_end+1,:)=0
+  !ym	wm(:,jj_end+1,:)=0
+  endif
+
+!$OMP END MASTER
+!$OMP BARRIER
+
+  CALL vitvert_loc(zconvmm,wm)
+
+  return
+end subroutine groupe_loc
+
Index: DZ6/trunk/libf/dyn3dmem/groupe_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/groupe_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,40 +1,0 @@
-MODULE groupe_mod
-
-  REAL,POINTER,SAVE :: zconvm(:,:,:)
-  REAL,POINTER,SAVE :: zconvmm(:,:,:)
-  
-CONTAINS
-
-  SUBROUTINE groupe_allocate
-  USE bands
-  USE allocate_field_mod
-  USE parallel_lmdz
-!  USE infotrac
-  USE advtrac_mod, ONLY : advtrac_allocate 
-  IMPLICIT NONE
-  INCLUDE "dimensions.h"
-  INCLUDE "paramet.h"
-  TYPE(distrib),POINTER :: d
-
-    d=>distrib_caldyn
-    CALL allocate2d_u(zconvm,llm,d)
-    CALL allocate2d_u(zconvmm,llm,d)
-
-
-  END SUBROUTINE groupe_allocate
-  
-  SUBROUTINE groupe_switch_caldyn(dist)
-  USE allocate_field_mod
-  USE bands
-  USE parallel_lmdz
-  IMPLICIT NONE
-    TYPE(distrib),INTENT(IN) :: dist
-
-    CALL switch2d_u(zconvm,distrib_caldyn,dist)
-    CALL switch2d_u(zconvmm,distrib_caldyn,dist)
-
-  END SUBROUTINE groupe_switch_caldyn
-  
-
-  
-END MODULE groupe_mod  
Index: /LMDZ6/trunk/libf/dyn3dmem/groupe_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/groupe_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3dmem/groupe_mod.f90	(revision 5268)
@@ -0,0 +1,40 @@
+MODULE groupe_mod
+
+  REAL,POINTER,SAVE :: zconvm(:,:,:)
+  REAL,POINTER,SAVE :: zconvmm(:,:,:)
+  
+CONTAINS
+
+  SUBROUTINE groupe_allocate
+  USE bands
+  USE allocate_field_mod
+  USE parallel_lmdz
+!  USE infotrac
+  USE advtrac_mod, ONLY : advtrac_allocate 
+  IMPLICIT NONE
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  TYPE(distrib),POINTER :: d
+
+    d=>distrib_caldyn
+    CALL allocate2d_u(zconvm,llm,d)
+    CALL allocate2d_u(zconvmm,llm,d)
+
+
+  END SUBROUTINE groupe_allocate
+  
+  SUBROUTINE groupe_switch_caldyn(dist)
+  USE allocate_field_mod
+  USE bands
+  USE parallel_lmdz
+  IMPLICIT NONE
+    TYPE(distrib),INTENT(IN) :: dist
+
+    CALL switch2d_u(zconvm,distrib_caldyn,dist)
+    CALL switch2d_u(zconvmm,distrib_caldyn,dist)
+
+  END SUBROUTINE groupe_switch_caldyn
+  
+
+  
+END MODULE groupe_mod  
Index: DZ6/trunk/libf/dyn3dmem/guide_loc_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/guide_loc_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,2440 +1,0 @@
-!
-! $Id$
-!
-MODULE guide_loc_mod
-
-!=======================================================================
-!   Auteur:  F.Hourdin
-!            F. Codron 01/09
-!=======================================================================
-
-  USE getparam, only: ini_getparam, fin_getparam, getpar
-  USE Write_Field_loc
-  use netcdf, only: nf90_nowrite, nf90_open, nf90_inq_varid, nf90_close, &
-                    nf90_inq_dimid, nf90_inquire_dimension
-  USE parallel_lmdz
-  USE pres2lev_mod, only: pres2lev
-
-  IMPLICIT NONE
-
-! ---------------------------------------------
-! Declarations des cles logiques et parametres
-! ---------------------------------------------
-  INTEGER, PRIVATE, SAVE  :: iguide_read,iguide_int,iguide_sav
-  INTEGER, PRIVATE, SAVE  :: nlevnc, guide_plevs
-  LOGICAL, PRIVATE, SAVE  :: guide_u,guide_v,guide_T,guide_Q,guide_P
-  LOGICAL, PRIVATE, SAVE  :: guide_hr,guide_teta
-  LOGICAL, PRIVATE, SAVE  :: guide_BL,guide_reg,guide_add,gamma4,guide_zon
-  LOGICAL, PRIVATE, SAVE  :: invert_p,invert_y,ini_anal
-  LOGICAL, PRIVATE, SAVE  :: guide_2D,guide_sav,guide_modele
-!FC
-  LOGICAL, PRIVATE, SAVE  :: convert_Pa
-
-  REAL, PRIVATE, SAVE     :: tau_min_u,tau_max_u
-  REAL, PRIVATE, SAVE     :: tau_min_v,tau_max_v
-  REAL, PRIVATE, SAVE     :: tau_min_T,tau_max_T
-  REAL, PRIVATE, SAVE     :: tau_min_Q,tau_max_Q
-  REAL, PRIVATE, SAVE     :: tau_min_P,tau_max_P
-
-  REAL, PRIVATE, SAVE     :: lat_min_g,lat_max_g
-  REAL, PRIVATE, SAVE     :: lon_min_g,lon_max_g
-  REAL, PRIVATE, SAVE     :: tau_lon,tau_lat
-
-  REAL, PRIVATE, SAVE     :: plim_guide_BL
-
-  REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE     :: alpha_u,alpha_v
-  REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE     :: alpha_T,alpha_Q
-  REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE     :: alpha_P,alpha_pcor
-
-! ---------------------------------------------
-! Variables de guidage
-! ---------------------------------------------
-! Variables des fichiers de guidage
-  REAL, ALLOCATABLE, DIMENSION(:,:,:), PRIVATE, SAVE   :: unat1,unat2
-  REAL, ALLOCATABLE, DIMENSION(:,:,:), PRIVATE, SAVE   :: vnat1,vnat2
-  REAL, ALLOCATABLE, DIMENSION(:,:,:), PRIVATE, SAVE   :: tnat1,tnat2
-  REAL, ALLOCATABLE, DIMENSION(:,:,:), PRIVATE, SAVE   :: qnat1,qnat2
-  REAL, ALLOCATABLE, DIMENSION(:,:,:), PRIVATE, SAVE   :: pnat1,pnat2
-  REAL, ALLOCATABLE, DIMENSION(:,:),   PRIVATE, SAVE   :: psnat1,psnat2
-  REAL, ALLOCATABLE, DIMENSION(:),     PRIVATE, SAVE   :: apnc,bpnc
-! Variables aux dimensions du modele
-  REAL, ALLOCATABLE, DIMENSION(:,:),   PRIVATE, SAVE   :: ugui1,ugui2
-  REAL, ALLOCATABLE, DIMENSION(:,:),   PRIVATE, SAVE   :: vgui1,vgui2
-  REAL, ALLOCATABLE, DIMENSION(:,:),   PRIVATE, SAVE   :: tgui1,tgui2
-  REAL, ALLOCATABLE, DIMENSION(:,:),   PRIVATE, SAVE   :: qgui1,qgui2
-  REAL, ALLOCATABLE, DIMENSION(:),   PRIVATE, SAVE   :: psgui1,psgui2
-
-  INTEGER,SAVE,PRIVATE :: ijbu,ijbv,ijeu,ijev !,ijnu,ijnv
-  INTEGER,SAVE,PRIVATE :: jjbu,jjbv,jjeu,jjev,jjnu,jjnv
-
-
-CONTAINS
-!=======================================================================
-
-  SUBROUTINE guide_init
-
-    USE control_mod, ONLY: day_step
-    USE serre_mod, ONLY: grossismx
-
-    IMPLICIT NONE
-
-    INCLUDE "dimensions.h"
-    INCLUDE "paramet.h"
-    INCLUDE "netcdf.inc"
-
-    INTEGER                :: error,ncidpl,rid,rcod
-    CHARACTER (len = 80)   :: abort_message
-    CHARACTER (len = 20)   :: modname = 'guide_init'
-    CHARACTER (len = 20)   :: namedim
-
-! ---------------------------------------------
-! Lecture des parametres:
-! ---------------------------------------------
-    call ini_getparam("nudging_parameters_out.txt")
-! Variables guidees
-    CALL getpar('guide_u',.true.,guide_u,'guidage de u')
-    CALL getpar('guide_v',.true.,guide_v,'guidage de v')
-    CALL getpar('guide_T',.true.,guide_T,'guidage de T')
-    CALL getpar('guide_P',.true.,guide_P,'guidage de P')
-    CALL getpar('guide_Q',.true.,guide_Q,'guidage de Q')
-    CALL getpar('guide_hr',.true.,guide_hr,'guidage de Q par H.R')
-    CALL getpar('guide_teta',.false.,guide_teta,'guidage de T par Teta')
-
-    CALL getpar('guide_add',.false.,guide_add,'for�age constant?')
-    CALL getpar('guide_zon',.false.,guide_zon,'guidage moy zonale')
-    if (guide_zon .and. abs(grossismx - 1.) > 0.01) &
-         call abort_gcm("guide_init", &
-         "zonal nudging requires grid regular in longitude", 1)
-
-!   Constantes de rappel. Unite : fraction de jour
-    CALL getpar('tau_min_u',0.02,tau_min_u,'Cste de rappel min, u')
-    CALL getpar('tau_max_u', 10.,tau_max_u,'Cste de rappel max, u')
-    CALL getpar('tau_min_v',0.02,tau_min_v,'Cste de rappel min, v')
-    CALL getpar('tau_max_v', 10.,tau_max_v,'Cste de rappel max, v')
-    CALL getpar('tau_min_T',0.02,tau_min_T,'Cste de rappel min, T')
-    CALL getpar('tau_max_T', 10.,tau_max_T,'Cste de rappel max, T')
-    CALL getpar('tau_min_Q',0.02,tau_min_Q,'Cste de rappel min, Q')
-    CALL getpar('tau_max_Q', 10.,tau_max_Q,'Cste de rappel max, Q')
-    CALL getpar('tau_min_P',0.02,tau_min_P,'Cste de rappel min, P')
-    CALL getpar('tau_max_P', 10.,tau_max_P,'Cste de rappel max, P')
-    CALL getpar('gamma4',.false.,gamma4,'Zone sans rappel elargie')
-    CALL getpar('guide_BL',.true.,guide_BL,'guidage dans C.Lim')
-    CALL getpar('plim_guide_BL',85000.,plim_guide_BL,'BL top presnivs value')
-
-! Sauvegarde du for�age
-    CALL getpar('guide_sav',.false.,guide_sav,'sauvegarde guidage')
-    CALL getpar('iguide_sav',4,iguide_sav,'freq. sauvegarde guidage')
-    ! frequences f>0: fx/jour; f<0: tous les f jours; f=0: 1 seule fois.
-    IF (iguide_sav.GT.0) THEN
-       iguide_sav=day_step/iguide_sav
-    ELSE if (iguide_sav == 0) then
-       iguide_sav = huge(0)
-    ELSE
-       iguide_sav=day_step*iguide_sav
-    ENDIF
-
-! Guidage regional seulement (sinon constant ou suivant le zoom)
-    CALL getpar('guide_reg',.false.,guide_reg,'guidage regional')
-    CALL getpar('lat_min_g',-90.,lat_min_g,'Latitude mini guidage ')
-    CALL getpar('lat_max_g', 90.,lat_max_g,'Latitude maxi guidage ')
-    CALL getpar('lon_min_g',-180.,lon_min_g,'longitude mini guidage ')
-    CALL getpar('lon_max_g', 180.,lon_max_g,'longitude maxi guidage ')
-    CALL getpar('tau_lat', 5.,tau_lat,'raideur lat guide regional ')
-    CALL getpar('tau_lon', 5.,tau_lon,'raideur lon guide regional ')
-
-! Parametres pour lecture des fichiers
-    CALL getpar('iguide_read',4,iguide_read,'freq. lecture guidage')
-    CALL getpar('iguide_int',4,iguide_int,'freq. interpolation vert')
-    IF (iguide_int.EQ.0) THEN
-        iguide_int=1
-    ELSEIF (iguide_int.GT.0) THEN
-        iguide_int=day_step/iguide_int
-    ELSE
-        iguide_int=day_step*iguide_int
-    ENDIF
-    CALL getpar('guide_plevs',0,guide_plevs,'niveaux pression fichiers guidage')
-    ! Pour compatibilite avec ancienne version avec guide_modele
-    CALL getpar('guide_modele',.false.,guide_modele,'niveaux pression ap+bp*psol')
-    IF (guide_modele) THEN
-        guide_plevs=1
-    ENDIF
-!FC
-    CALL getpar('convert_Pa',.true.,convert_Pa,'Convert Pressure levels in Pa')
-    ! Fin raccord
-    CALL getpar('ini_anal',.false.,ini_anal,'Etat initial = analyse')
-    CALL getpar('guide_invertp',.true.,invert_p,'niveaux p inverses')
-    CALL getpar('guide_inverty',.true.,invert_y,'inversion N-S')
-    CALL getpar('guide_2D',.false.,guide_2D,'fichier guidage lat-P')
-
-    call fin_getparam
-
-! ---------------------------------------------
-! Determination du nombre de niveaux verticaux
-! des fichiers guidage
-! ---------------------------------------------
-    ncidpl=-99
-    if (guide_plevs.EQ.1) then
-       if (ncidpl.eq.-99) then
-          rcod=nf90_open('apbp.nc',Nf90_NOWRITe, ncidpl)
-          if (rcod.NE.NF_NOERR) THEN
-             abort_message=' Nudging error -> no file apbp.nc'
-             CALL abort_gcm(modname,abort_message,1)
-          endif
-       endif
-    elseif (guide_plevs.EQ.2) then
-       if (ncidpl.EQ.-99) then
-          rcod=nf90_open('P.nc',Nf90_NOWRITe,ncidpl)
-          if (rcod.NE.NF_NOERR) THEN
-             abort_message=' Nudging error -> no file P.nc'
-             CALL abort_gcm(modname,abort_message,1)
-          endif
-       endif
-
-    elseif (guide_u) then
-       if (ncidpl.eq.-99) then
-          rcod=nf90_open('u.nc',Nf90_NOWRITe,ncidpl)
-          if (rcod.NE.NF_NOERR) THEN
-             abort_message=' Nudging error -> no file u.nc'
-             CALL abort_gcm(modname,abort_message,1)
-          endif
-
-       endif
-
-
-    elseif (guide_v) then
-       if (ncidpl.eq.-99) then
-          rcod=nf90_open('v.nc',nf90_nowrite,ncidpl)
-          if (rcod.NE.NF_NOERR) THEN
-             abort_message=' Nudging error -> no file v.nc'
-             CALL abort_gcm(modname,abort_message,1)
-          endif
-       endif
-
-
-    elseif (guide_T) then
-       if (ncidpl.eq.-99) then
-          rcod=nf90_open('T.nc',nf90_nowrite,ncidpl)
-          if (rcod.NE.NF_NOERR) THEN
-             abort_message=' Nudging error -> no file T.nc'
-             CALL abort_gcm(modname,abort_message,1)
-          endif
-       endif
-
-
-
-    elseif (guide_Q) then
-       if (ncidpl.eq.-99) then
-          rcod=nf90_open('hur.nc',nf90_nowrite, ncidpl)
-          if (rcod.NE.NF_NOERR) THEN
-             abort_message=' Nudging error -> no file hur.nc'
-             CALL abort_gcm(modname,abort_message,1)
-          endif
-       endif
-
-
-    endif
-    error=NF_INQ_DIMID(ncidpl,'LEVEL',rid)
-    IF (error.NE.NF_NOERR) error=NF_INQ_DIMID(ncidpl,'PRESSURE',rid)
-    IF (error.NE.NF_NOERR) THEN
-        abort_message='Nudging: error reading pressure levels'
-        CALL abort_gcm(modname,abort_message,1)
-    ENDIF
-    error=NF_INQ_DIMLEN(ncidpl,rid,nlevnc)
-    write(*,*)trim(modname)//' : number of vertical levels nlevnc', nlevnc
-    rcod = nf90_close(ncidpl)
-
-! ---------------------------------------------
-! Allocation des variables
-! ---------------------------------------------
-    abort_message='nudging allocation error'
-
-    ALLOCATE(apnc(nlevnc), stat = error)
-    IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
-    ALLOCATE(bpnc(nlevnc), stat = error)
-    IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
-    apnc=0.;bpnc=0.
-
-    ALLOCATE(alpha_pcor(llm), stat = error)
-    IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
-    ALLOCATE(alpha_u(ijb_u:ije_u), stat = error)
-    IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
-    ALLOCATE(alpha_v(ijb_v:ije_v), stat = error)
-    IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
-    ALLOCATE(alpha_T(ijb_u:ije_u), stat = error)
-    IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
-    ALLOCATE(alpha_Q(ijb_u:ije_u), stat = error)
-    IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
-    ALLOCATE(alpha_P(ijb_u:ije_u), stat = error)
-    IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
-    alpha_u=0.;alpha_v=0;alpha_T=0;alpha_Q=0;alpha_P=0
-
-    IF (guide_u) THEN
-        ALLOCATE(unat1(iip1,jjb_u:jje_u,nlevnc), stat = error)
-        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
-        ALLOCATE(ugui1(ijb_u:ije_u,llm), stat = error)
-        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
-        ALLOCATE(unat2(iip1,jjb_u:jje_u,nlevnc), stat = error)
-        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
-        ALLOCATE(ugui2(ijb_u:ije_u,llm), stat = error)
-        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
-        unat1=0.;unat2=0.;ugui1=0.;ugui2=0.
-    ENDIF
-
-    IF (guide_T) THEN
-        ALLOCATE(tnat1(iip1,jjb_u:jje_u,nlevnc), stat = error)
-        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
-        ALLOCATE(tgui1(ijb_u:ije_u,llm), stat = error)
-        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
-        ALLOCATE(tnat2(iip1,jjb_u:jje_u,nlevnc), stat = error)
-        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
-        ALLOCATE(tgui2(ijb_u:ije_u,llm), stat = error)
-        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
-        tnat1=0.;tnat2=0.;tgui1=0.;tgui2=0.
-    ENDIF
-
-    IF (guide_Q) THEN
-        ALLOCATE(qnat1(iip1,jjb_u:jje_u,nlevnc), stat = error)
-        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
-        ALLOCATE(qgui1(ijb_u:ije_u,llm), stat = error)
-        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
-        ALLOCATE(qnat2(iip1,jjb_u:jje_u,nlevnc), stat = error)
-        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
-        ALLOCATE(qgui2(ijb_u:ije_u,llm), stat = error)
-        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
-        qnat1=0.;qnat2=0.;qgui1=0.;qgui2=0.
-    ENDIF
-
-    IF (guide_v) THEN
-        ALLOCATE(vnat1(iip1,jjb_v:jje_v,nlevnc), stat = error)
-        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
-        ALLOCATE(vgui1(ijb_v:ije_v,llm), stat = error)
-        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
-        ALLOCATE(vnat2(iip1,jjb_v:jje_v,nlevnc), stat = error)
-        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
-        ALLOCATE(vgui2(ijb_v:ije_v,llm), stat = error)
-        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
-        vnat1=0.;vnat2=0.;vgui1=0.;vgui2=0.
-    ENDIF
-
-    IF (guide_plevs.EQ.2) THEN
-        ALLOCATE(pnat1(iip1,jjb_u:jje_u,nlevnc), stat = error)
-        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
-        ALLOCATE(pnat2(iip1,jjb_u:jje_u,nlevnc), stat = error)
-        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
-        pnat1=0.;pnat2=0.;
-    ENDIF
-
-    IF (guide_P.OR.guide_plevs.EQ.1) THEN
-        ALLOCATE(psnat1(iip1,jjb_u:jje_u), stat = error)
-        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
-        ALLOCATE(psnat2(iip1,jjb_u:jje_u), stat = error)
-        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
-        psnat1=0.;psnat2=0.;
-    ENDIF
-    IF (guide_P) THEN
-        ALLOCATE(psgui2(ijb_u:ije_u), stat = error)
-        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
-        ALLOCATE(psgui1(ijb_u:ije_u), stat = error)
-        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
-        psgui1=0.;psgui2=0.
-    ENDIF
-
-! ---------------------------------------------
-!   Lecture du premier etat de guidage.
-! ---------------------------------------------
-    IF (guide_2D) THEN
-        CALL guide_read2D(1)
-    ELSE
-        CALL guide_read(1)
-    ENDIF
-    IF (guide_v) vnat1=vnat2
-    IF (guide_u) unat1=unat2
-    IF (guide_T) tnat1=tnat2
-    IF (guide_Q) qnat1=qnat2
-    IF (guide_plevs.EQ.2) pnat1=pnat2
-    IF (guide_P.OR.guide_plevs.EQ.1) psnat1=psnat2
-
-  END SUBROUTINE guide_init
-
-!=======================================================================
-  SUBROUTINE guide_main(itau,ucov,vcov,teta,q,masse,ps)
-    use exner_hyb_loc_m, only: exner_hyb_loc
-    use exner_milieu_loc_m, only: exner_milieu_loc
-    USE parallel_lmdz
-    USE control_mod
-    USE write_field_loc
-    USE comconst_mod, ONLY: cpp, daysec, dtvr, kappa
-    USE comvert_mod, ONLY: ap, bp, preff, presnivs, pressure_exner
-
-    IMPLICIT NONE
-
-    INCLUDE "dimensions.h"
-    INCLUDE "paramet.h"
-
-    ! Variables entree
-    INTEGER,                           INTENT(IN)    :: itau !pas de temps
-    REAL, DIMENSION (ijb_u:ije_u,llm), INTENT(INOUT) :: ucov,teta,q,masse
-    REAL, DIMENSION (ijb_v:ije_v,llm), INTENT(INOUT) :: vcov
-    REAL, DIMENSION (ijb_u:ije_u),     INTENT(INOUT) :: ps
-
-    ! Variables locales
-    LOGICAL, SAVE :: first=.TRUE.
-!$OMP THREADPRIVATE(first)
-    LOGICAL       :: f_out ! sortie guidage
-    REAL, ALLOCATABLE, SAVE, DIMENSION (:,:) :: f_addu ! var aux: champ de guidage
-    REAL, ALLOCATABLE, SAVE, DIMENSION (:,:) :: f_addv ! var aux: champ de guidage
-    ! Variables pour fonction Exner (P milieu couche)
-    REAL, ALLOCATABLE, SAVE, DIMENSION (:,:,:)    :: pk
-    REAL, ALLOCATABLE, SAVE, DIMENSION (:,:)        :: pks
-    REAL                               :: unskap
-    REAL, ALLOCATABLE, SAVE, DIMENSION (:,:)    :: p ! besoin si guide_P
-    ! Compteurs temps:
-    INTEGER, SAVE :: step_rea,count_no_rea,itau_test ! lecture guidage
-!$OMP THREADPRIVATE(step_rea,count_no_rea,itau_test)
-    REAL          :: ditau, dday_step
-    REAL          :: tau,reste ! position entre 2 etats de guidage
-    REAL, SAVE    :: factt ! pas de temps en fraction de jour
-!$OMP THREADPRIVATE(factt)
-
-    INTEGER       :: i,j,l
-    CHARACTER(LEN=20) :: modname="guide_main"
-
-!$OMP MASTER
-    ijbu=ij_begin ; ijeu=ij_end
-    jjbu=jj_begin ; jjeu=jj_end ; jjnu=jjeu-jjbu+1
-    ijbv=ij_begin ; ijev=ij_end
-    jjbv=jj_begin ; jjev=jj_end ; jjnv=jjev-jjbv+1
-    IF (pole_sud) THEN
-      ijeu=ij_end-iip1
-      ijev=ij_end-iip1
-      jjev=jj_end-1
-      jjnv=jjev-jjbv+1
-    ENDIF
-    IF (pole_nord) THEN
-      ijbu=ij_begin+iip1
-      ijbv=ij_begin
-    ENDIF
-!$OMP END MASTER
-!$OMP BARRIER
-
-!    PRINT *,'---> on rentre dans guide_main'
-!    CALL AllGather_Field(ucov,ip1jmp1,llm)
-!    CALL AllGather_Field(vcov,ip1jm,llm)
-!    CALL AllGather_Field(teta,ip1jmp1,llm)
-!    CALL AllGather_Field(ps,ip1jmp1,1)
-!    CALL AllGather_Field(q,ip1jmp1,llm)
-
-!-----------------------------------------------------------------------
-! Initialisations au premier passage
-!-----------------------------------------------------------------------
-
-    IF (first) THEN
-        first=.FALSE.
-!$OMP MASTER
-        ALLOCATE(f_addu(ijb_u:ije_u,llm) )
-        ALLOCATE(f_addv(ijb_v:ije_v,llm) )
-        ALLOCATE(pk(iip1,jjb_u:jje_u,llm)  )
-        ALLOCATE(pks(iip1,jjb_u:jje_u)  )
-        ALLOCATE(p(ijb_u:ije_u,llmp1) )
-        CALL guide_init
-!$OMP END MASTER
-!$OMP BARRIER
-        itau_test=1001
-        step_rea=1
-        count_no_rea=0
-! Calcul des constantes de rappel
-        factt=dtvr*iperiod/daysec
-!$OMP MASTER
-        call tau2alpha(3, iip1, jjb_v, jje_v, factt, tau_min_v, tau_max_v, alpha_v)
-        call tau2alpha(2, iip1, jjb_u, jje_u, factt, tau_min_u, tau_max_u, alpha_u)
-        call tau2alpha(1, iip1, jjb_u, jje_u, factt, tau_min_T, tau_max_T, alpha_T)
-        call tau2alpha(1, iip1, jjb_u, jje_u, factt, tau_min_P, tau_max_P, alpha_P)
-        call tau2alpha(1, iip1, jjb_u, jje_u, factt, tau_min_Q, tau_max_Q, alpha_Q)
-! correction de rappel dans couche limite
-        if (guide_BL) then
-             alpha_pcor(:)=1.
-        else
-            do l=1,llm
-                alpha_pcor(l)=(1.+tanh(((plim_guide_BL-presnivs(l))/preff)/0.05))/2.
-            enddo
-        endif
-!$OMP END MASTER
-!$OMP BARRIER
-! ini_anal: etat initial egal au guidage
-        IF (ini_anal) THEN
-            CALL guide_interp(ps,teta)
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-            DO l=1,llm
-              IF (guide_u) ucov(ijbu:ijeu,l)=ugui2(ijbu:ijeu,l)
-              IF (guide_v) vcov(ijbv:ijev,l)=ugui2(ijbv:ijev,l)
-              IF (guide_T) teta(ijbu:ijeu,l)=tgui2(ijbu:ijeu,l)
-              IF (guide_Q) q(ijbu:ijeu,l)=qgui2(ijbu:ijeu,l)
-            ENDDO
-
-            IF (guide_P) THEN
-!$OMP MASTER
-                ps(ijbu:ijeu)=psgui2(ijbu:ijeu)
-!$OMP END MASTER
-!$OMP BARRIER
-                CALL pression_loc(ijnb_u,ap,bp,ps,p)
-                CALL massdair_loc(p,masse)
-!$OMP BARRIER
-            ENDIF
-            RETURN
-        ENDIF
-
-    ENDIF !first
-
-!-----------------------------------------------------------------------
-! Lecture des fichiers de guidage ?
-!-----------------------------------------------------------------------
-    IF (iguide_read.NE.0) THEN
-      ditau=real(itau)
-      dday_step=real(day_step)
-      IF (iguide_read.LT.0) THEN
-          tau=ditau/dday_step/REAL(iguide_read)
-      ELSE
-          tau=REAL(iguide_read)*ditau/dday_step
-      ENDIF
-      reste=tau-AINT(tau)
-      IF (reste.EQ.0.) THEN
-          IF (itau_test.EQ.itau) THEN
-            write(*,*)trim(modname)//' second pass in advreel at itau=',&
-            itau
-            CALL abort_gcm("guide_loc_lod","stopped",1)
-          ELSE
-!$OMP MASTER
-              IF (guide_v) vnat1(:,jjbv:jjev,:)=vnat2(:,jjbv:jjev,:)
-              IF (guide_u) unat1(:,jjbu:jjeu,:)=unat2(:,jjbu:jjeu,:)
-              IF (guide_T) tnat1(:,jjbu:jjeu,:)=tnat2(:,jjbu:jjeu,:)
-              IF (guide_Q) qnat1(:,jjbu:jjeu,:)=qnat2(:,jjbu:jjeu,:)
-              IF (guide_plevs.EQ.2) pnat1(:,jjbu:jjeu,:)=pnat2(:,jjbu:jjeu,:)
-              IF (guide_P.OR.guide_plevs.EQ.1) psnat1(:,jjbu:jjeu)=psnat2(:,jjbu:jjeu)
-!$OMP END MASTER
-!$OMP BARRIER
-              step_rea=step_rea+1
-              itau_test=itau
-              if (is_master) then
-                write(*,*)trim(modname)//' Reading nudging files, step ',&
-                    step_rea,'after ',count_no_rea,' skips'
-              endif
-              IF (guide_2D) THEN
-!$OMP MASTER
-                  CALL guide_read2D(step_rea)
-!$OMP END MASTER
-!$OMP BARRIER
-              ELSE
-!$OMP MASTER
-                  CALL guide_read(step_rea)
-!$OMP END MASTER
-!$OMP BARRIER
-              ENDIF
-              count_no_rea=0
-          ENDIF
-      ELSE
-        count_no_rea=count_no_rea+1
-
-      ENDIF
-    ENDIF !iguide_read=0
-
-!-----------------------------------------------------------------------
-! Interpolation et conversion des champs de guidage
-!-----------------------------------------------------------------------
-    IF (MOD(itau,iguide_int).EQ.0) THEN
-        CALL guide_interp(ps,teta)
-    ENDIF
-! Repartition entre 2 etats de guidage
-    IF (iguide_read.NE.0) THEN
-        tau=reste
-    ELSE
-        tau=1.
-    ENDIF
-
-!    CALL WriteField_u('ucov_guide',ucov)
-!    CALL WriteField_v('vcov_guide',vcov)
-!    CALL WriteField_u('teta_guide',teta)
-!    CALL WriteField_u('masse_guide',masse)
-
-
-!-----------------------------------------------------------------------
-!   Ajout des champs de guidage
-!-----------------------------------------------------------------------
-! Sauvegarde du guidage?
-    f_out=((MOD(itau,iguide_sav).EQ.0).AND.guide_sav)
-    IF (f_out) THEN
-
-!$OMP BARRIER
-      CALL pression_loc(ijnb_u,ap,bp,ps,p)
-
-!$OMP BARRIER
-      if (pressure_exner) then
-      CALL exner_hyb_loc( ijnb_u, ps, p, pks, pk)
-      else
-        CALL exner_milieu_loc( ijnb_u, ps, p, pks, pk )
-      endif
-
-!$OMP BARRIER
-
-        unskap=1./kappa
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-        DO l = 1, llm
-            DO j=jjbu,jjeu
-                DO i =1, iip1
-                    p(i+(j-1)*iip1,l) = preff * ( pk(i,j,l)/cpp) ** unskap
-                ENDDO
-            ENDDO
-        ENDDO
-
-        CALL guide_out("SP",jjp1,llm,p(ijb_u:ije_u,1:llm),1.)
-    ENDIF
-
-    if (guide_u) then
-        if (guide_add) then
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-          DO l=1,llm
-           f_addu(ijbu:ijeu,l)=(1.-tau)*ugui1(ijbu:ijeu,l)+tau*ugui2(ijbu:ijeu,l)
-          ENDDO
-        else
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-          DO l=1,llm
-           f_addu(ijbu:ijeu,l)=(1.-tau)*ugui1(ijbu:ijeu,l)+tau*ugui2(ijbu:ijeu,l)-ucov(ijbu:ijeu,l)
-          ENDDO
-        endif
-
-!        CALL WriteField_u('f_addu',f_addu)
-
-        if (guide_zon) CALL guide_zonave_u(1,llm,f_addu)
-        CALL guide_addfield_u(llm,f_addu,alpha_u)
-        IF (f_out) CALL guide_out("ua",jjp1,llm,(1.-tau)*ugui1(ijb_u:ije_u,:)+tau*ugui2(ijb_u:ije_u,:),factt)
-        IF (f_out) CALL guide_out("u",jjp1,llm,ucov(ijb_u:ije_u,:),factt)
-        IF (f_out) THEN
-         ! Ehouarn: fill the gaps adequately...
-         IF (ijbu>ijb_u) f_addu(ijb_u:ijbu-1,:)=0
-         IF (ijeu<ije_u) f_addu(ijeu+1:ije_u,:)=0
-         CALL guide_out("ucov",jjp1,llm,f_addu(ijb_u:ije_u,:)/factt,factt)
-        ENDIF
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-        DO l=1,llm
-          ucov(ijbu:ijeu,l)=ucov(ijbu:ijeu,l)+f_addu(ijbu:ijeu,l)
-        ENDDO
-
-    endif
-
-    if (guide_T) then
-        if (guide_add) then
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-          DO l=1,llm
-            f_addu(ijbu:ijeu,l)=(1.-tau)*tgui1(ijbu:ijeu,l)+tau*tgui2(ijbu:ijeu,l)
-          ENDDO
-        else
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-          DO l=1,llm
-           f_addu(ijbu:ijeu,l)=(1.-tau)*tgui1(ijbu:ijeu,l)+tau*tgui2(ijbu:ijeu,l)-teta(ijbu:ijeu,l)
-          ENDDO
-        endif
-        if (guide_zon) CALL guide_zonave_u(2,llm,f_addu)
-        CALL guide_addfield_u(llm,f_addu,alpha_T)
-        IF (f_out) CALL guide_out("teta",jjp1,llm,f_addu(:,:)/factt,factt)
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-        DO l=1,llm
-          teta(ijbu:ijeu,l)=teta(ijbu:ijeu,l)+f_addu(ijbu:ijeu,l)
-        ENDDO
-    endif
-
-    if (guide_P) then
-        if (guide_add) then
-!$OMP MASTER
-            f_addu(ijbu:ijeu,1)=(1.-tau)*psgui1(ijbu:ijeu)+tau*psgui2(ijbu:ijeu)
-!$OMP END MASTER
-!$OMP BARRIER
-        else
-!$OMP MASTER
-            f_addu(ijbu:ijeu,1)=(1.-tau)*psgui1(ijbu:ijeu)+tau*psgui2(ijbu:ijeu)-ps(ijbu:ijeu)
-!$OMP END MASTER
-!$OMP BARRIER
-        endif
-        if (guide_zon) CALL guide_zonave_u(2,1,f_addu(ijb_u:ije_u,1))
-        CALL guide_addfield_u(1,f_addu(ijb_u:ije_u,1),alpha_P)
-!       IF (f_out) CALL guide_out("ps",jjp1,1,f_addu(ijb_u:ije_u,1)/factt,factt)
-!$OMP MASTER
-        ps(ijbu:ijeu)=ps(ijbu:ijeu)+f_addu(ijbu:ijeu,1)
-!$OMP END MASTER
-!$OMP BARRIER
-        CALL pression_loc(ijnb_u,ap,bp,ps,p)
-        CALL massdair_loc(p,masse)
-!$OMP BARRIER
-    endif
-
-    if (guide_Q) then
-        if (guide_add) then
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-          DO l=1,llm
-            f_addu(ijbu:ijeu,l)=(1.-tau)*qgui1(ijbu:ijeu,l)+tau*qgui2(ijbu:ijeu,l)
-          ENDDO
-        else
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-          DO l=1,llm
-            f_addu(ijbu:ijeu,l)=(1.-tau)*qgui1(ijbu:ijeu,l)+tau*qgui2(ijbu:ijeu,l)-q(ijbu:ijeu,l)
-          ENDDO
-        endif
-        if (guide_zon) CALL guide_zonave_u(2,llm,f_addu)
-        CALL guide_addfield_u(llm,f_addu,alpha_Q)
-        IF (f_out) CALL guide_out("q",jjp1,llm,f_addu(:,:)/factt,factt)
-
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-        DO l=1,llm
-          q(ijbu:ijeu,l)=q(ijbu:ijeu,l)+f_addu(ijbu:ijeu,l)
-        ENDDO
-    endif
-
-    if (guide_v) then
-        if (guide_add) then
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-          DO l=1,llm
-             f_addv(ijbv:ijev,l)=(1.-tau)*vgui1(ijbv:ijev,l)+tau*vgui2(ijbv:ijev,l)
-          ENDDO
-
-        else
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-          DO l=1,llm
-            f_addv(ijbv:ijev,l)=(1.-tau)*vgui1(ijbv:ijev,l)+tau*vgui2(ijbv:ijev,l)-vcov(ijbv:ijev,l)
-          ENDDO
-
-        endif
-
-        if (guide_zon) CALL guide_zonave_v(2,jjm,llm,f_addv(ijb_v:ije_v,:))
-
-        CALL guide_addfield_v(llm,f_addv(ijb_v:ije_v,:),alpha_v)
-        IF (f_out) CALL guide_out("v",jjm,llm,vcov(ijb_v:ije_v,:),factt)
-        IF (f_out) CALL guide_out("va",jjm,llm,(1.-tau)*vgui1(ijb_v:ije_v,:)+tau*vgui2(ijb_v:ije_v,:),factt)
-        IF (f_out) THEN
-          ! Ehouarn: Fill in the gaps adequately
-          IF (ijbv>ijb_v) f_addv(ijb_v:ijbv-1,:)=0
-          IF (ijev<ije_v) f_addv(ijev+1:ije_v,:)=0
-          CALL guide_out("vcov",jjm,llm,f_addv(ijb_v:ije_v,:)/factt,factt)
-        ENDIF
-
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-        DO l=1,llm
-          vcov(ijbv:ijev,l)=vcov(ijbv:ijev,l)+f_addv(ijbv:ijev,l)
-        ENDDO
-    endif
-
-  END SUBROUTINE guide_main
-
-
-  SUBROUTINE guide_addfield_u(vsize,field,alpha)
-! field1=a*field1+alpha*field2
-
-    IMPLICIT NONE
-    INCLUDE "dimensions.h"
-    INCLUDE "paramet.h"
-
-    ! input variables
-    INTEGER,                      INTENT(IN)    :: vsize
-    REAL, DIMENSION(ijb_u:ije_u),       INTENT(IN)    :: alpha
-    REAL, DIMENSION(ijb_u:ije_u,vsize), INTENT(INOUT) :: field
-
-    ! Local variables
-    INTEGER :: l
-
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-    DO l=1,vsize
-      field(ijbu:ijeu,l)=alpha(ijbu:ijeu)*field(ijbu:ijeu,l)*alpha_pcor(l)
-    ENDDO
-
-  END SUBROUTINE guide_addfield_u
-
-
-  SUBROUTINE guide_addfield_v(vsize,field,alpha)
-! field1=a*field1+alpha*field2
-
-    IMPLICIT NONE
-    INCLUDE "dimensions.h"
-    INCLUDE "paramet.h"
-
-    ! input variables
-    INTEGER,                      INTENT(IN)    :: vsize
-    REAL, DIMENSION(ijb_v:ije_v),       INTENT(IN)    :: alpha
-    REAL, DIMENSION(ijb_v:ije_v,vsize), INTENT(INOUT) :: field
-
-    ! Local variables
-    INTEGER :: l
-
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-    DO l=1,vsize
-      field(ijbv:ijev,l)=alpha(ijbv:ijev)*field(ijbv:ijev,l)*alpha_pcor(l)
-    ENDDO
-
-  END SUBROUTINE guide_addfield_v
-
-!=======================================================================
-
-  SUBROUTINE guide_zonave_u(typ,vsize,field)
-
-    USE comconst_mod, ONLY: pi
-
-    IMPLICIT NONE
-
-    INCLUDE "dimensions.h"
-    INCLUDE "paramet.h"
-    INCLUDE "comgeom.h"
-
-    ! input/output variables
-    INTEGER,                           INTENT(IN)    :: typ
-    INTEGER,                           INTENT(IN)    :: vsize
-    REAL, DIMENSION(ijb_u:ije_u,vsize), INTENT(INOUT) :: field
-
-    ! Local variables
-    LOGICAL, SAVE                :: first=.TRUE.
-!$OMP THREADPRIVATE(first)
-
-    INTEGER, DIMENSION (2), SAVE :: imin, imax ! averaging domain
-!$OMP THREADPRIVATE(imin,imax)
-    INTEGER                      :: i,j,l,ij
-    REAL, DIMENSION (iip1)       :: lond       ! longitude in Deg.
-    REAL, DIMENSION (jjb_u:jje_u,vsize):: fieldm     ! zon-averaged field
-
-    IF (first) THEN
-        first=.FALSE.
-!Compute domain for averaging
-        lond=rlonu*180./pi
-        imin(1)=1;imax(1)=iip1;
-        imin(2)=1;imax(2)=iip1;
-        IF (guide_reg) THEN
-            DO i=1,iim
-                IF (lond(i).LT.lon_min_g) imin(1)=i
-                IF (lond(i).LE.lon_max_g) imax(1)=i
-            ENDDO
-            lond=rlonv*180./pi
-            DO i=1,iim
-                IF (lond(i).LT.lon_min_g) imin(2)=i
-                IF (lond(i).LE.lon_max_g) imax(2)=i
-            ENDDO
-        ENDIF
-    ENDIF
-
-
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-      DO l=1,vsize
-        fieldm(:,l)=0.
-      ! Compute zonal average
-
-!correction bug ici
-! ---> a verifier
-! ym         DO j=jjbv,jjev
-         DO j=jjbu,jjeu
-              DO i=imin(typ),imax(typ)
-                  ij=(j-1)*iip1+i
-                  fieldm(j,l)=fieldm(j,l)+field(ij,l)
-              ENDDO
-          ENDDO
-          fieldm(:,l)=fieldm(:,l)/REAL(imax(typ)-imin(typ)+1)
-    ! Compute forcing
-          DO j=jjbu,jjeu
-              DO i=1,iip1
-                  ij=(j-1)*iip1+i
-                  field(ij,l)=fieldm(j,l)
-              ENDDO
-          ENDDO
-      ENDDO
-
-  END SUBROUTINE guide_zonave_u
-
-
-  SUBROUTINE guide_zonave_v(typ,hsize,vsize,field)
-
-    USE comconst_mod, ONLY: pi
-
-    IMPLICIT NONE
-
-    INCLUDE "dimensions.h"
-    INCLUDE "paramet.h"
-    INCLUDE "comgeom.h"
-
-    ! input/output variables
-    INTEGER,                           INTENT(IN)    :: typ
-    INTEGER,                           INTENT(IN)    :: vsize
-    INTEGER,                           INTENT(IN)    :: hsize
-    REAL, DIMENSION(ijb_v:ije_v,vsize), INTENT(INOUT) :: field
-
-    ! Local variables
-    LOGICAL, SAVE                :: first=.TRUE.
-!$OMP THREADPRIVATE(first)
-    INTEGER, DIMENSION (2), SAVE :: imin, imax ! averaging domain
-!$OMP THREADPRIVATE(imin, imax)
-    INTEGER                      :: i,j,l,ij
-    REAL, DIMENSION (iip1)       :: lond       ! longitude in Deg.
-    REAL, DIMENSION (jjb_v:jjev,vsize):: fieldm     ! zon-averaged field
-
-    IF (first) THEN
-        first=.FALSE.
-!Compute domain for averaging
-        lond=rlonu*180./pi
-        imin(1)=1;imax(1)=iip1;
-        imin(2)=1;imax(2)=iip1;
-        IF (guide_reg) THEN
-            DO i=1,iim
-                IF (lond(i).LT.lon_min_g) imin(1)=i
-                IF (lond(i).LE.lon_max_g) imax(1)=i
-            ENDDO
-            lond=rlonv*180./pi
-            DO i=1,iim
-                IF (lond(i).LT.lon_min_g) imin(2)=i
-                IF (lond(i).LE.lon_max_g) imax(2)=i
-            ENDDO
-        ENDIF
-    ENDIF
-
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-      DO l=1,vsize
-      ! Compute zonal average
-          fieldm(:,l)=0.
-          DO j=jjbv,jjev
-              DO i=imin(typ),imax(typ)
-                  ij=(j-1)*iip1+i
-                  fieldm(j,l)=fieldm(j,l)+field(ij,l)
-              ENDDO
-          ENDDO
-          fieldm(:,l)=fieldm(:,l)/REAL(imax(typ)-imin(typ)+1)
-    ! Compute forcing
-          DO j=jjbv,jjev
-              DO i=1,iip1
-                  ij=(j-1)*iip1+i
-                  field(ij,l)=fieldm(j,l)
-              ENDDO
-          ENDDO
-      ENDDO
-
-
-  END SUBROUTINE guide_zonave_v
-
-!=======================================================================
-  SUBROUTINE guide_interp(psi,teta)
-    use exner_hyb_loc_m, only: exner_hyb_loc
-    use exner_milieu_loc_m, only: exner_milieu_loc
-  USE parallel_lmdz
-  USE mod_hallo
-  USE Bands
-  USE comconst_mod, ONLY: cpp, kappa
-  USE comvert_mod, ONLY: preff, pressure_exner, bp, ap, disvert_type
-  IMPLICIT NONE
-
-  include "dimensions.h"
-  include "paramet.h"
-  include "comgeom2.h"
-
-  REAL, DIMENSION (iip1,jjb_u:jje_u),     INTENT(IN) :: psi ! Psol gcm
-  REAL, DIMENSION (iip1,jjb_u:jje_u,llm), INTENT(IN) :: teta ! Temp. Pot. gcm
-
-  LOGICAL, SAVE                      :: first=.TRUE.
-!$OMP THREADPRIVATE(first)
-  ! Variables pour niveaux pression:
-  REAL, ALLOCATABLE, SAVE, DIMENSION (:,:,:) :: plnc1,plnc2 !niveaux pression guidage
-  REAL, ALLOCATABLE, SAVE,DIMENSION (:,:,:)    :: plunc,plsnc !niveaux pression modele
-  REAL, ALLOCATABLE, SAVE,DIMENSION (:,:,:)     :: plvnc       !niveaux pression modele
-  REAL, ALLOCATABLE, SAVE,DIMENSION (:,:,:)  :: p           ! pression intercouches
-  REAL, ALLOCATABLE, SAVE,DIMENSION (:,:,:)    :: pls, pext   ! var intermediaire
-  REAL, ALLOCATABLE, SAVE,DIMENSION (:,:,:)    :: pbarx
-  REAL, ALLOCATABLE, SAVE,DIMENSION (:,:,:)     :: pbary
-  ! Variables pour fonction Exner (P milieu couche)
-  REAL, ALLOCATABLE, SAVE,DIMENSION (:,:,:)    :: pk
-  REAL ,ALLOCATABLE, SAVE, DIMENSION (:,:)        :: pks
-  REAL                               :: unskap
-  ! Pression de vapeur saturante
-  REAL, ALLOCATABLE, SAVE,DIMENSION (:,:)      :: qsat
-  !Variables intermediaires interpolation
-  REAL, ALLOCATABLE, SAVE,DIMENSION (:,:,:)    :: zu1,zu2
-  REAL, ALLOCATABLE, SAVE,DIMENSION (:,:,:)     :: zv1,zv2
-
-  INTEGER                            :: i,j,l,ij
-  CHARACTER(LEN=20),PARAMETER :: modname="guide_interp"
-  TYPE(Request),SAVE :: Req
-!$OMP THREADPRIVATE(Req)
-
-    if (is_master) write(*,*)trim(modname)//': interpolate nudging variables'
-! -----------------------------------------------------------------
-! Calcul des niveaux de pression champs guidage (pour T et Q)
-! -----------------------------------------------------------------
-    IF (first) THEN
-!$OMP MASTER
-      ALLOCATE(plnc1(iip1,jjb_u:jje_u,nlevnc) )
-      ALLOCATE(plnc2(iip1,jjb_u:jje_u,nlevnc) )
-      ALLOCATE(plunc(iip1,jjb_u:jje_u,llm) )
-      ALLOCATE(plsnc(iip1,jjb_u:jje_u,llm) )
-      ALLOCATE(plvnc(iip1,jjb_v:jje_v,llm) )
-      ALLOCATE(p(iip1,jjb_u:jje_u,llmp1) )
-      ALLOCATE(pls(iip1,jjb_u:jje_u,llm) )
-      ALLOCATE(pext(iip1,jjb_u:jje_u,llm) )
-      ALLOCATE(pbarx(iip1,jjb_u:jje_u,llm) )
-      ALLOCATE(pbary(iip1,jjb_v:jje_v,llm) )
-      ALLOCATE(pk(iip1,jjb_u:jje_u,llm) )
-      ALLOCATE(pks (iip1,jjb_u:jje_u) )
-      ALLOCATE(qsat(ijb_u:ije_u,llm) )
-      ALLOCATE(zu1(iip1,jjb_u:jje_u,llm) )
-      ALLOCATE(zu2(iip1,jjb_u:jje_u,llm) )
-      ALLOCATE(zv1(iip1,jjb_v:jje_v,llm) )
-      ALLOCATE(zv2(iip1,jjb_v:jje_v,llm) )
-!$OMP END MASTER
-!$OMP BARRIER
-    ENDIF
-
-
-
-
-    IF (guide_plevs.EQ.0) THEN
-!$OMP DO
-        DO l=1,nlevnc
-            DO j=jjbu,jjeu
-                DO i=1,iip1
-                    plnc2(i,j,l)=apnc(l)
-                    plnc1(i,j,l)=apnc(l)
-               ENDDO
-            ENDDO
-        ENDDO
-    ENDIF
-
-    if (first) then
-        first=.FALSE.
-!$OMP MASTER
-        write(*,*)trim(modname)//' : check vertical level order'
-        write(*,*)trim(modname)//' LMDZ :'
-        do l=1,llm
-          write(*,*)trim(modname)//' PL(',l,')=',(ap(l)+ap(l+1))/2. &
-                  +psi(1,jjeu)*(bp(l)+bp(l+1))/2.
-        enddo
-        write(*,*)trim(modname)//' nudging file :'
-        SELECT CASE (guide_plevs)
-        CASE (0)
-            do l=1,nlevnc
-              write(*,*)trim(modname)//' PL(',l,')=',plnc2(1,jjbu,l)
-            enddo
-        CASE (1)
-            DO l=1,nlevnc
-              write(*,*)trim(modname)//' PL(',l,')=',&
-                        apnc(l)+bpnc(l)*psnat2(1,jjbu)
-            ENDDO
-        CASE (2)
-            do l=1,nlevnc
-              write(*,*)trim(modname)//' PL(',l,')=',pnat2(1,jjbu,l)
-            enddo
-        END SELECT
-        write(*,*)trim(modname)//' invert ordering: invert_p=',invert_p
-        if (guide_u) then
-            do l=1,nlevnc
-              write(*,*)trim(modname)//' U(',l,')=',unat2(1,jjbu,l)
-            enddo
-        endif
-        if (guide_T) then
-            do l=1,nlevnc
-              write(*,*)trim(modname)//' T(',l,')=',tnat2(1,jjbu,l)
-            enddo
-        endif
-!$OMP END MASTER
-    endif ! of if (first)
-
-    if (guide_plevs /= 1 .or. guide_t .and. .not. guide_teta &
-         .or. guide_q .and. guide_hr) then
-       CALL pression_loc( ijnb_u, ap, bp, psi, p )
-       if (disvert_type==1) then
-          CALL exner_hyb_loc(ijnb_u,psi,p,pks,pk)
-       else ! we assume that we are in the disvert_type==2 case
-          CALL exner_milieu_loc(ijnb_u,psi,p,pks,pk)
-       endif
-    end if
-
-! -----------------------------------------------------------------
-! Calcul niveaux pression modele
-! -----------------------------------------------------------------
-
-!    ....  Calcul de pls , pression au milieu des couches ,en Pascals
-    IF (guide_plevs.EQ.1) THEN
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-        DO l=1,llm
-            DO j=jjbu,jjeu
-                DO i =1, iip1
-                    pls(i,j,l)=(ap(l)+ap(l+1))/2.+psi(i,j)*(bp(l)+bp(l+1))/2.
-                ENDDO
-            ENDDO
-        ENDDO
-    ELSE
-        unskap=1./kappa
-!$OMP BARRIER
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-   DO l = 1, llm
-       DO j=jjbu,jjeu
-           DO i =1, iip1
-               pls(i,j,l) = preff * ( pk(i,j,l)/cpp) ** unskap
-           ENDDO
-       ENDDO
-   ENDDO
-    ENDIF
-
-!   calcul des pressions pour les grilles u et v
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-    do l=1,llm
-        do j=jjbu,jjeu
-            do i=1,iip1
-                pext(i,j,l)=pls(i,j,l)*aire(i,j)
-            enddo
-        enddo
-    enddo
-
-     CALL Register_Hallo_u(pext,llm,1,2,2,1,Req)
-     CALL SendRequest(Req)
-!$OMP BARRIER
-     CALL WaitRequest(Req)
-!$OMP BARRIER
-
-    call massbar_loc(pext, pbarx, pbary )
-!$OMP BARRIER
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-    do l=1,llm
-        do j=jjbu,jjeu
-            do i=1,iip1
-                plunc(i,j,l)=pbarx(i,j,l)/aireu(i,j)
-                plsnc(i,j,l)=pls(i,j,l)
-            enddo
-        enddo
-    enddo
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-    do l=1,llm
-        do j=jjbv,jjev
-            do i=1,iip1
-                plvnc(i,j,l)=pbary(i,j,l)/airev(i,j)
-            enddo
-        enddo
-    enddo
-
-! -----------------------------------------------------------------
-! Interpolation verticale champs guidage sur niveaux modele
-! Conversion en variables gcm (ucov, vcov...)
-! -----------------------------------------------------------------
-    if (guide_P) then
-!$OMP MASTER
-        do j=jjbu,jjeu
-            do i=1,iim
-                ij=(j-1)*iip1+i
-                psgui1(ij)=psnat1(i,j)
-                psgui2(ij)=psnat2(i,j)
-            enddo
-            psgui1(iip1*j)=psnat1(1,j)
-            psgui2(iip1*j)=psnat2(1,j)
-        enddo
-!$OMP END MASTER
-!$OMP BARRIER
-    endif
-
-    IF (guide_T) THEN
-        ! Calcul des nouvelles valeurs des niveaux de pression du guidage
-        IF (guide_plevs.EQ.1) THEN
-!$OMP DO
-            DO l=1,nlevnc
-                DO j=jjbu,jjeu
-                    DO i=1,iip1
-                        plnc2(i,j,l)=apnc(l)+bpnc(l)*psnat2(i,j)
-                        plnc1(i,j,l)=apnc(l)+bpnc(l)*psnat1(i,j)
-                    ENDDO
-                ENDDO
-            ENDDO
-        ELSE IF (guide_plevs.EQ.2) THEN
-!$OMP DO
-            DO l=1,nlevnc
-                DO j=jjbu,jjeu
-                    DO i=1,iip1
-                        plnc2(i,j,l)=pnat2(i,j,l)
-                        plnc1(i,j,l)=pnat1(i,j,l)
-                    ENDDO
-                ENDDO
-            ENDDO
-        ENDIF
-
-        ! Interpolation verticale
-!$OMP MASTER
-        CALL pres2lev(tnat1(:,jjbu:jjeu,:),zu1(:,jjbu:jjeu,:),nlevnc,llm,           &
-                    plnc1(:,jjbu:jjeu,:),plsnc(:,jjbu:jjeu,:),iip1,jjnu,invert_p)
-        CALL pres2lev(tnat2(:,jjbu:jjeu,:),zu2(:,jjbu:jjeu,:),nlevnc,llm,           &
-                    plnc2(:,jjbu:jjeu,:),plsnc(:,jjbu:jjeu,:),iip1,jjnu,invert_p)
-!$OMP END MASTER
-!$OMP BARRIER
-        ! Conversion en variables GCM
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-        do l=1,llm
-            do j=jjbu,jjeu
-                IF (guide_teta) THEN
-                    do i=1,iim
-                        ij=(j-1)*iip1+i
-                        tgui1(ij,l)=zu1(i,j,l)
-                        tgui2(ij,l)=zu2(i,j,l)
-                    enddo
-                ELSE
-                    do i=1,iim
-                        ij=(j-1)*iip1+i
-                        tgui1(ij,l)=zu1(i,j,l)*cpp/pk(i,j,l)
-                        tgui2(ij,l)=zu2(i,j,l)*cpp/pk(i,j,l)
-                    enddo
-                ENDIF
-                tgui1(j*iip1,l)=tgui1((j-1)*iip1+1,l)
-                tgui2(j*iip1,l)=tgui2((j-1)*iip1+1,l)
-            enddo
-            if (pole_nord) then
-              do i=1,iip1
-                tgui1(i,l)=tgui1(1,l)
-                tgui2(i,l)=tgui2(1,l)
-              enddo
-            endif
-            if (pole_sud) then
-              do i=1,iip1
-                tgui1(ip1jm+i,l)=tgui1(ip1jm+1,l)
-                tgui2(ip1jm+i,l)=tgui2(ip1jm+1,l)
-              enddo
-           endif
-        enddo
-    ENDIF
-
-    IF (guide_Q) THEN
-        ! Calcul des nouvelles valeurs des niveaux de pression du guidage
-        IF (guide_plevs.EQ.1) THEN
-!$OMP DO
-            DO l=1,nlevnc
-                DO j=jjbu,jjeu
-                    DO i=1,iip1
-                        plnc2(i,j,l)=apnc(l)+bpnc(l)*psnat2(i,j)
-                        plnc1(i,j,l)=apnc(l)+bpnc(l)*psnat1(i,j)
-                    ENDDO
-                ENDDO
-            ENDDO
-        ELSE IF (guide_plevs.EQ.2) THEN
-!$OMP DO
-            DO l=1,nlevnc
-                DO j=jjbu,jjeu
-                    DO i=1,iip1
-                        plnc2(i,j,l)=pnat2(i,j,l)
-                        plnc1(i,j,l)=pnat1(i,j,l)
-                    ENDDO
-                ENDDO
-            ENDDO
-        ENDIF
-
-        ! Interpolation verticale
-!$OMP MASTER
-        CALL pres2lev(qnat1(:,jjbu:jjeu,:),zu1(:,jjbu:jjeu,:),nlevnc,llm,             &
-                      plnc1(:,jjbu:jjeu,:),plsnc(:,jjbu:jjeu,:),iip1,jjnu,invert_p)
-        CALL pres2lev(qnat2(:,jjbu:jjeu,:),zu2(:,jjbu:jjeu,:),nlevnc,llm,             &
-                      plnc2(:,jjbu:jjeu,:),plsnc(:,jjbu:jjeu,:),iip1,jjnu,invert_p)
-!$OMP END MASTER
-!$OMP BARRIER
-
-        ! Conversion en variables GCM
-        ! On suppose qu'on a la bonne variable dans le fichier de guidage:
-        ! Hum.Rel si guide_hr, Hum.Spec. sinon.
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-        do l=1,llm
-            do j=jjbu,jjeu
-                do i=1,iim
-                    ij=(j-1)*iip1+i
-                    qgui1(ij,l)=zu1(i,j,l)
-                    qgui2(ij,l)=zu2(i,j,l)
-                enddo
-                qgui1(j*iip1,l)=qgui1((j-1)*iip1+1,l)
-                qgui2(j*iip1,l)=qgui2((j-1)*iip1+1,l)
-            enddo
-            if (pole_nord) then
-              do i=1,iip1
-                qgui1(i,l)=qgui1(1,l)
-                qgui2(i,l)=qgui2(1,l)
-              enddo
-            endif
-            if (pole_sud) then
-              do i=1,iip1
-                qgui1(ip1jm+i,l)=qgui1(ip1jm+1,l)
-                qgui2(ip1jm+i,l)=qgui2(ip1jm+1,l)
-              enddo
-            endif
-        enddo
-        IF (guide_hr) THEN
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-          do l=1,llm
-            CALL q_sat(iip1*jjnu,teta(:,jjbu:jjeu,l)*pk(:,jjbu:jjeu,l)/cpp,       &
-                       plsnc(:,jjbu:jjeu,l),qsat(ijbu:ijeu,l))
-            qgui1(ijbu:ijeu,l)=qgui1(ijbu:ijeu,l)*qsat(ijbu:ijeu,l)*0.01 !hum. rel. en %
-            qgui2(ijbu:ijeu,l)=qgui2(ijbu:ijeu,l)*qsat(ijbu:ijeu,l)*0.01
-          enddo
-
-        ENDIF
-    ENDIF
-
-    IF (guide_u) THEN
-        ! Calcul des nouvelles valeurs des niveaux de pression du guidage
-        IF (guide_plevs.EQ.1) THEN
-!$OMP DO
-            DO l=1,nlevnc
-                DO j=jjbu,jjeu
-                    DO i=1,iim
-                        plnc2(i,j,l)=apnc(l)+bpnc(l)*(psnat2(i,j)*aire(i,j)*alpha1p2(i,j) &
-                       &           +psnat2(i+1,j)*aire(i+1,j)*alpha3p4(i+1,j))/aireu(i,j)
-                        plnc1(i,j,l)=apnc(l)+bpnc(l)*(psnat1(i,j)*aire(i,j)*alpha1p2(i,j) &
-                       &           +psnat1(i+1,j)*aire(i+1,j)*alpha3p4(i+1,j))/aireu(i,j)
-                    ENDDO
-                    plnc2(iip1,j,l)=plnc2(1,j,l)
-                    plnc1(iip1,j,l)=plnc1(1,j,l)
-                ENDDO
-            ENDDO
-        ELSE IF (guide_plevs.EQ.2) THEN
-!$OMP DO
-            DO l=1,nlevnc
-                DO j=jjbu,jjeu
-                    DO i=1,iim
-                        plnc2(i,j,l)=(pnat2(i,j,l)*aire(i,j)*alpha1p2(i,j) &
-                       & +pnat2(i+1,j,l)*aire(i,j)*alpha3p4(i+1,j))/aireu(i,j)
-                        plnc1(i,j,l)=(pnat1(i,j,l)*aire(i,j)*alpha1p2(i,j) &
-                       & +pnat1(i+1,j,l)*aire(i,j)*alpha3p4(i+1,j))/aireu(i,j)
-                    ENDDO
-                    plnc2(iip1,j,l)=plnc2(1,j,l)
-                    plnc1(iip1,j,l)=plnc1(1,j,l)
-                ENDDO
-            ENDDO
-        ENDIF
-
-        ! Interpolation verticale
-!$OMP MASTER
-        CALL pres2lev(unat1(:,jjbu:jjeu,:),zu1(:,jjbu:jjeu,:),nlevnc,llm,            &
-                      plnc1(:,jjbu:jjeu,:),plunc(:,jjbu:jjeu,:),iip1,jjnu,invert_p)
-        CALL pres2lev(unat2(:,jjbu:jjeu,:),zu2(:,jjbu:jjeu,:),nlevnc,llm,            &
-                      plnc2(:,jjbu:jjeu,:),plunc(:,jjbu:jjeu,:),iip1,jjnu,invert_p)
-!$OMP END MASTER
-!$OMP BARRIER
-
-        ! Conversion en variables GCM
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-        do l=1,llm
-            do j=jjbu,jjeu
-                do i=1,iim
-                    ij=(j-1)*iip1+i
-                    ugui1(ij,l)=zu1(i,j,l)*cu(i,j)
-                    ugui2(ij,l)=zu2(i,j,l)*cu(i,j)
-                enddo
-                ugui1(j*iip1,l)=ugui1((j-1)*iip1+1,l)
-                ugui2(j*iip1,l)=ugui2((j-1)*iip1+1,l)
-            enddo
-            if (pole_nord) then
-              do i=1,iip1
-                ugui1(i,l)=0.
-                ugui2(i,l)=0.
-              enddo
-            endif
-            if (pole_sud) then
-              do i=1,iip1
-                ugui1(ip1jm+i,l)=0.
-                ugui2(ip1jm+i,l)=0.
-              enddo
-            endif
-        enddo
-    ENDIF
-
-    IF (guide_v) THEN
-        ! Calcul des nouvelles valeurs des niveaux de pression du guidage
-        IF (guide_plevs.EQ.1) THEN
-         CALL Register_Hallo_u(psnat1,1,1,2,2,1,Req)
-         CALL Register_Hallo_u(psnat2,1,1,2,2,1,Req)
-         CALL SendRequest(Req)
-!$OMP BARRIER
-         CALL WaitRequest(Req)
-!$OMP BARRIER
-!$OMP DO
-            DO l=1,nlevnc
-                DO j=jjbv,jjev
-                    DO i=1,iip1
-                        plnc2(i,j,l)=apnc(l)+bpnc(l)*(psnat2(i,j)*aire(i,j)*alpha2p3(i,j) &
-                       &           +psnat2(i,j+1)*aire(i,j+1)*alpha1p4(i,j+1))/airev(i,j)
-                        plnc1(i,j,l)=apnc(l)+bpnc(l)*(psnat1(i,j)*aire(i,j)*alpha2p3(i,j) &
-                       &           +psnat1(i,j+1)*aire(i,j+1)*alpha1p4(i,j+1))/airev(i,j)
-                    ENDDO
-                ENDDO
-            ENDDO
-        ELSE IF (guide_plevs.EQ.2) THEN
-         CALL Register_Hallo_u(pnat1,llm,1,2,2,1,Req)
-         CALL Register_Hallo_u(pnat2,llm,1,2,2,1,Req)
-         CALL SendRequest(Req)
-!$OMP BARRIER
-         CALL WaitRequest(Req)
-!$OMP BARRIER
-!$OMP DO
-            DO l=1,nlevnc
-                DO j=jjbv,jjev
-                    DO i=1,iip1
-                        plnc2(i,j,l)=(pnat2(i,j,l)*aire(i,j)*alpha2p3(i,j) &
-                       & +pnat2(i,j+1,l)*aire(i,j)*alpha1p4(i,j+1))/airev(i,j)
-                        plnc1(i,j,l)=(pnat1(i,j,l)*aire(i,j)*alpha2p3(i,j) &
-                       & +pnat1(i,j+1,l)*aire(i,j)*alpha1p4(i,j+1))/airev(i,j)
-                    ENDDO
-                ENDDO
-            ENDDO
-        ENDIF
-        ! Interpolation verticale
-
-!$OMP MASTER
-        CALL pres2lev(vnat1(:,jjbv:jjev,:),zv1(:,jjbv:jjev,:),nlevnc,llm,             &
-                      plnc1(:,jjbv:jjev,:),plvnc(:,jjbv:jjev,:),iip1,jjnv,invert_p)
-        CALL pres2lev(vnat2(:,jjbv:jjev,:),zv2(:,jjbv:jjev,:),nlevnc,llm,             &
-                      plnc2(:,jjbv:jjev,:),plvnc(:,jjbv:jjev,:),iip1,jjnv,invert_p)
-!$OMP END MASTER
-!$OMP BARRIER
-        ! Conversion en variables GCM
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-        do l=1,llm
-            do j=jjbv,jjev
-                do i=1,iim
-                    ij=(j-1)*iip1+i
-                    vgui1(ij,l)=zv1(i,j,l)*cv(i,j)
-                    vgui2(ij,l)=zv2(i,j,l)*cv(i,j)
-                enddo
-                vgui1(j*iip1,l)=vgui1((j-1)*iip1+1,l)
-                vgui2(j*iip1,l)=vgui2((j-1)*iip1+1,l)
-            enddo
-        enddo
-    ENDIF
-
-
-  END SUBROUTINE guide_interp
-
-!=======================================================================
-  SUBROUTINE tau2alpha(typ,pim,jjb,jje,factt,taumin,taumax,alpha)
-
-! Calcul des constantes de rappel alpha (=1/tau)
-
-    use comconst_mod, only: pi
-    use serre_mod, only: clat, clon, grossismx, grossismy
-
-    implicit none
-
-    include "dimensions.h"
-    include "paramet.h"
-    include "comgeom2.h"
-
-! input arguments :
-    INTEGER, INTENT(IN) :: typ    ! u(2),v(3), ou scalaire(1)
-    INTEGER, INTENT(IN) :: pim ! dimensions en lon
-    INTEGER, INTENT(IN) :: jjb,jje ! dimensions en lat
-    REAL, INTENT(IN)    :: factt   ! pas de temps en fraction de jour
-    REAL, INTENT(IN)    :: taumin,taumax
-! output arguments:
-    REAL, DIMENSION(pim,jjb:jje), INTENT(OUT) :: alpha
-
-!  local variables:
-    LOGICAL, SAVE               :: first=.TRUE.
-    REAL, SAVE                  :: gamma,dxdy_min,dxdy_max
-    REAL, DIMENSION (iip1,jjp1) :: zdx,zdy
-    REAL, DIMENSION (iip1,jjp1) :: dxdys,dxdyu
-    REAL, DIMENSION (iip1,jjm)  :: dxdyv
-    real dxdy_
-    real zlat,zlon
-    real alphamin,alphamax,xi
-    integer i,j,ilon,ilat
-    character(len=20),parameter :: modname="tau2alpha"
-
-
-    alphamin=factt/taumax
-    alphamax=factt/taumin
-    IF (guide_reg.OR.guide_add) THEN
-        alpha=alphamax
-!-----------------------------------------------------------------------
-! guide_reg: alpha=alpha_min dans region, 0. sinon.
-!-----------------------------------------------------------------------
-        IF (guide_reg) THEN
-            do j=jjb,jje
-                do i=1,pim
-                    if (typ.eq.2) then
-                       zlat=rlatu(j)*180./pi
-                       zlon=rlonu(i)*180./pi
-                    elseif (typ.eq.1) then
-                       zlat=rlatu(j)*180./pi
-                       zlon=rlonv(i)*180./pi
-                    elseif (typ.eq.3) then
-                       zlat=rlatv(j)*180./pi
-                       zlon=rlonv(i)*180./pi
-                    endif
-                    alpha(i,j)=alphamax/16.* &
-                              (1.+tanh((zlat-lat_min_g)/tau_lat))* &
-                              (1.+tanh((lat_max_g-zlat)/tau_lat))* &
-                              (1.+tanh((zlon-lon_min_g)/tau_lon))* &
-                              (1.+tanh((lon_max_g-zlon)/tau_lon))
-                enddo
-            enddo
-        ENDIF
-    ELSE
-!-----------------------------------------------------------------------
-! Sinon, alpha varie entre alpha_min et alpha_max suivant le zoom.
-!-----------------------------------------------------------------------
-!Calcul de l'aire des mailles
-        do j=2,jjm
-            do i=2,iip1
-               zdx(i,j)=0.5*(cu(i-1,j)+cu(i,j))/cos(rlatu(j))
-            enddo
-            zdx(1,j)=zdx(iip1,j)
-        enddo
-        do j=2,jjm
-            do i=1,iip1
-               zdy(i,j)=0.5*(cv(i,j-1)+cv(i,j))
-            enddo
-        enddo
-        do i=1,iip1
-            zdx(i,1)=zdx(i,2)
-            zdx(i,jjp1)=zdx(i,jjm)
-            zdy(i,1)=zdy(i,2)
-            zdy(i,jjp1)=zdy(i,jjm)
-        enddo
-        do j=1,jjp1
-            do i=1,iip1
-               dxdys(i,j)=sqrt(zdx(i,j)*zdx(i,j)+zdy(i,j)*zdy(i,j))
-            enddo
-        enddo
-        IF (typ.EQ.2) THEN
-            do j=1,jjp1
-                do i=1,iim
-                   dxdyu(i,j)=0.5*(dxdys(i,j)+dxdys(i+1,j))
-                enddo
-                dxdyu(iip1,j)=dxdyu(1,j)
-            enddo
-        ENDIF
-        IF (typ.EQ.3) THEN
-            do j=1,jjm
-                do i=1,iip1
-                   dxdyv(i,j)=0.5*(dxdys(i,j)+dxdys(i,j+1))
-                enddo
-            enddo
-        ENDIF
-! Premier appel: calcul des aires min et max et de gamma.
-        IF (first) THEN
-            first=.FALSE.
-            ! coordonnees du centre du zoom
-            CALL coordij(clon,clat,ilon,ilat)
-            ! aire de la maille au centre du zoom
-            dxdy_min=dxdys(ilon,ilat)
-            ! dxdy maximale de la maille
-            dxdy_max=0.
-            do j=1,jjp1
-                do i=1,iip1
-                     dxdy_max=max(dxdy_max,dxdys(i,j))
-                enddo
-            enddo
-            ! Calcul de gamma
-            if (abs(grossismx-1.).lt.0.1.or.abs(grossismy-1.).lt.0.1) then
-              write(*,*)trim(modname)//' ATTENTION modele peu zoome'
-              write(*,*)trim(modname)//' ATTENTION on prend une constante de guidage cste'
-              gamma=0.
-            else
-              gamma=(dxdy_max-2.*dxdy_min)/(dxdy_max-dxdy_min)
-              write(*,*)trim(modname)//' gamma=',gamma
-              if (gamma.lt.1.e-5) then
-                write(*,*)trim(modname)//' gamma =',gamma,'<1e-5'
-                CALL abort_gcm("guide_loc_mod","stopped",1)
-              endif
-              gamma=log(0.5)/log(gamma)
-              if (gamma4) then
-                gamma=min(gamma,4.)
-              endif
-              write(*,*)trim(modname)//' gamma=',gamma
-            endif
-        ENDIF !first
-
-        do j=jjb,jje
-            do i=1,pim
-                if (typ.eq.1) then
-                   dxdy_=dxdys(i,j)
-                   zlat=rlatu(j)*180./pi
-                elseif (typ.eq.2) then
-                   dxdy_=dxdyu(i,j)
-                   zlat=rlatu(j)*180./pi
-                elseif (typ.eq.3) then
-                   dxdy_=dxdyv(i,j)
-                   zlat=rlatv(j)*180./pi
-                endif
-                if (abs(grossismx-1.).lt.0.1.or.abs(grossismy-1.).lt.0.1) then
-                ! pour une grille reguliere, xi=xxx**0=1 -> alpha=alphamin
-                    alpha(i,j)=alphamin
-                else
-                    xi=((dxdy_max-dxdy_)/(dxdy_max-dxdy_min))**gamma
-                    xi=min(xi,1.)
-                    if(lat_min_g.le.zlat .and. zlat.le.lat_max_g) then
-                        alpha(i,j)=xi*alphamin+(1.-xi)*alphamax
-                    else
-                        alpha(i,j)=0.
-                    endif
-                endif
-            enddo
-        enddo
-    ENDIF ! guide_reg
-
-    if (.not. guide_add) alpha = 1. - exp(- alpha)
-
-  END SUBROUTINE tau2alpha
-
-!=======================================================================
-  SUBROUTINE guide_read(timestep)
-    USE netcdf, ONLY: nf90_put_var
-    IMPLICIT NONE
-
-    include "netcdf.inc"
-    include "dimensions.h"
-    include "paramet.h"
-
-    INTEGER, INTENT(IN)   :: timestep
-
-    LOGICAL, SAVE         :: first=.TRUE.
-! Identification fichiers et variables NetCDF:
-    INTEGER, SAVE         :: ncidu,varidu,ncidv,varidv,ncidp,varidp
-    INTEGER, SAVE         :: ncidQ,varidQ,ncidt,varidt,ncidps,varidps
-    INTEGER               :: ncidpl,varidpl,varidap,varidbp,dimid,lendim
-! Variables auxiliaires NetCDF:
-    INTEGER, DIMENSION(4) :: start,count
-    INTEGER               :: status,rcode
-    CHARACTER (len = 80)   :: abort_message
-    CHARACTER (len = 20)   :: modname = 'guide_read'
-    CHARACTER (len = 20)   :: namedim
-    abort_message='pb in guide_read'
-
-! -----------------------------------------------------------------
-! Premier appel: initialisation de la lecture des fichiers
-! -----------------------------------------------------------------
-    if (first) then
-         ncidpl=-99
-         write(*,*),trim(modname)//': opening nudging files '
-! Ap et Bp si Niveaux de pression hybrides
-         if (guide_plevs.EQ.1) then
-             write(*,*),trim(modname)//' Reading nudging on model levels'
-             rcode = nf90_open('apbp.nc', nf90_nowrite, ncidpl)
-             IF (rcode.NE.NF_NOERR) THEN
-              abort_message='Nudging: error -> no file apbp.nc'
-              CALL abort_gcm(modname,abort_message,1)
-             ENDIF
-             rcode = nf90_inq_varid(ncidpl, 'AP', varidap)
-             IF (rcode.NE.NF_NOERR) THEN
-              abort_message='Nudging: error -> no AP variable in file apbp.nc'
-              CALL abort_gcm(modname,abort_message,1)
-             ENDIF
-             rcode = nf90_inq_varid(ncidpl, 'BP', varidbp)
-             IF (rcode.NE.NF_NOERR) THEN
-              abort_message='Nudging: error -> no BP variable in file apbp.nc'
-              CALL abort_gcm(modname,abort_message,1)
-             ENDIF
-             write(*,*),trim(modname)//' ncidpl,varidap',ncidpl,varidap
-         endif
-
-! Pression si guidage sur niveaux P variables
-         if (guide_plevs.EQ.2) then
-             rcode = nf90_open('P.nc', nf90_nowrite, ncidp)
-             IF (rcode.NE.NF_NOERR) THEN
-              abort_message='Nudging: error -> no file P.nc'
-              CALL abort_gcm(modname,abort_message,1)
-             ENDIF
-             rcode = nf90_inq_varid(ncidp, 'PRES', varidp)
-             IF (rcode.NE.NF_NOERR) THEN
-              abort_message='Nudging: error -> no PRES variable in file P.nc'
-              CALL abort_gcm(modname,abort_message,1)
-             ENDIF
-             write(*,*),trim(modname)//' ncidp,varidp',ncidp,varidp
-             if (ncidpl.eq.-99) ncidpl=ncidp
-         endif
-
-! Vent zonal
-         if (guide_u) then
-             rcode = nf90_open('u.nc', nf90_nowrite, ncidu)
-             IF (rcode.NE.NF_NOERR) THEN
-              abort_message='Nudging: error -> no file u.nc'
-              CALL abort_gcm(modname,abort_message,1)
-             ENDIF
-             rcode = nf90_inq_varid(ncidu, 'UWND', varidu)
-             IF (rcode.NE.NF_NOERR) THEN
-              abort_message='Nudging: error -> no UWND variable in file u.nc'
-              CALL abort_gcm(modname,abort_message,1)
-             ENDIF
-             write(*,*),trim(modname)//' ncidu,varidu',ncidu,varidu
-             if (ncidpl.eq.-99) ncidpl=ncidu
-
-
-             status=NF90_INQ_DIMID(ncidu, "LONU", dimid)
-             status=NF90_INQUIRE_DIMENSION(ncidu,dimid,namedim,lendim)
-             IF (lendim .NE. iip1) THEN
-                abort_message='dimension LONU different from iip1 in u.nc'
-                CALL abort_gcm(modname,abort_message,1)
-             ENDIF
-
-             status=NF90_INQ_DIMID(ncidu, "LATU", dimid)
-             status=NF90_INQUIRE_DIMENSION(ncidu,dimid,namedim,lendim)
-             IF (lendim .NE. jjp1) THEN
-                abort_message='dimension LATU different from jjp1 in u.nc'
-                CALL abort_gcm(modname,abort_message,1)
-             ENDIF
-
-         endif
-
-! Vent meridien
-         if (guide_v) then
-             rcode = nf90_open('v.nc', nf90_nowrite, ncidv)
-             IF (rcode.NE.NF_NOERR) THEN
-              abort_message='Nudging: error -> no file v.nc'
-              CALL abort_gcm(modname,abort_message,1)
-             ENDIF
-             rcode = nf90_inq_varid(ncidv, 'VWND', varidv)
-             IF (rcode.NE.NF_NOERR) THEN
-              abort_message='Nudging: error -> no VWND variable in file v.nc'
-              CALL abort_gcm(modname,abort_message,1)
-             ENDIF
-             write(*,*),trim(modname)//' ncidv,varidv',ncidv,varidv
-             if (ncidpl.eq.-99) ncidpl=ncidv
-
-             status=NF90_INQ_DIMID(ncidv, "LONV", dimid)
-             status=NF90_INQUIRE_DIMENSION(ncidv,dimid,namedim,lendim)
-
-                IF (lendim .NE. iip1) THEN
-                abort_message='dimension LONV different from iip1 in v.nc'
-                CALL abort_gcm(modname,abort_message,1)
-             ENDIF
-
-
-             status=NF90_INQ_DIMID(ncidv, "LATV", dimid)
-             status=NF90_INQUIRE_DIMENSION(ncidv,dimid,namedim,lendim)
-             IF (lendim .NE. jjm) THEN
-                abort_message='dimension LATV different from jjm in v.nc'
-                CALL abort_gcm(modname,abort_message,1)
-             ENDIF
-
-        endif
-
-! Temperature
-         if (guide_T) then
-             rcode = nf90_open('T.nc', nf90_nowrite, ncidt)
-             IF (rcode.NE.NF_NOERR) THEN
-              abort_message='Nudging: error -> no file T.nc'
-              CALL abort_gcm(modname,abort_message,1)
-             ENDIF
-             rcode = nf90_inq_varid(ncidt, 'AIR', varidt)
-             IF (rcode.NE.NF_NOERR) THEN
-              abort_message='Nudging: error -> no AIR variable in file T.nc'
-              CALL abort_gcm(modname,abort_message,1)
-             ENDIF
-             write(*,*),trim(modname)//' ncidT,varidT',ncidt,varidt
-             if (ncidpl.eq.-99) ncidpl=ncidt
-
-             status=NF90_INQ_DIMID(ncidt, "LONV", dimid)
-             status=NF90_INQUIRE_DIMENSION(ncidt,dimid,namedim,lendim)
-             IF (lendim .NE. iip1) THEN
-                abort_message='dimension LONV different from iip1 in T.nc'
-                CALL abort_gcm(modname,abort_message,1)
-             ENDIF
-
-             status=NF90_INQ_DIMID(ncidt, "LATU", dimid)
-             status=NF90_INQUIRE_DIMENSION(ncidt,dimid,namedim,lendim)
-             IF (lendim .NE. jjp1) THEN
-                abort_message='dimension LATU different from jjp1 in T.nc'
-                CALL abort_gcm(modname,abort_message,1)
-             ENDIF
-
-         endif
-
-! Humidite
-         if (guide_Q) then
-             rcode = nf90_open('hur.nc', nf90_nowrite, ncidQ)
-             IF (rcode.NE.NF_NOERR) THEN
-              abort_message='Nudging: error -> no file hur.nc'
-              CALL abort_gcm(modname,abort_message,1)
-             ENDIF
-             rcode = nf90_inq_varid(ncidQ, 'RH', varidQ)
-             IF (rcode.NE.NF_NOERR) THEN
-              abort_message='Nudging: error -> no RH variable in file hur.nc'
-              CALL abort_gcm(modname,abort_message,1)
-             ENDIF
-             write(*,*),trim(modname)//' ncidQ,varidQ',ncidQ,varidQ
-             if (ncidpl.eq.-99) ncidpl=ncidQ
-
-
-             status=NF90_INQ_DIMID(ncidQ, "LONV", dimid)
-             status=NF90_INQUIRE_DIMENSION(ncidQ,dimid,namedim,lendim)
-             IF (lendim .NE. iip1) THEN
-                abort_message='dimension LONV different from iip1 in hur.nc'
-                CALL abort_gcm(modname,abort_message,1)
-             ENDIF
-
-             status=NF90_INQ_DIMID(ncidQ, "LATU", dimid)
-             status=NF90_INQUIRE_DIMENSION(ncidQ,dimid,namedim,lendim)
-             IF (lendim .NE. jjp1) THEN
-                abort_message='dimension LATU different from jjp1 in hur.nc'
-                CALL abort_gcm(modname,abort_message,1)
-             ENDIF
-
-
-         endif
-! Pression de surface
-         if ((guide_P).OR.(guide_plevs.EQ.1)) then
-             rcode = nf90_open('ps.nc', nf90_nowrite, ncidps)
-             IF (rcode.NE.NF_NOERR) THEN
-              abort_message='Nudging: error -> no file ps.nc'
-              CALL abort_gcm(modname,abort_message,1)
-             ENDIF
-             rcode = nf90_inq_varid(ncidps, 'SP', varidps)
-             IF (rcode.NE.NF_NOERR) THEN
-              abort_message='Nudging: error -> no SP variable in file ps.nc'
-              CALL abort_gcm(modname,abort_message,1)
-             ENDIF
-             write(*,*),trim(modname)//' ncidps,varidps',ncidps,varidps
-         endif
-! Coordonnee verticale
-         if (guide_plevs.EQ.0) then
-              rcode = nf90_inq_varid(ncidpl, 'LEVEL', varidpl)
-              IF (rcode.NE.0) rcode = nf90_inq_varid(ncidpl, 'PRESSURE', varidpl)
-              write(*,*),trim(modname)//' ncidpl,varidpl',ncidpl,varidpl
-         endif
-! Coefs ap, bp pour calcul de la pression aux differents niveaux
-         IF (guide_plevs.EQ.1) THEN
-             status = nf90_put_var(ncidpl, varidap, apnc, [1], [nlevnc])
-             status = nf90_put_var(ncidpl, varidbp, bpnc, [1], [nlevnc])
-         ELSEIF (guide_plevs.EQ.0) THEN
-             status = nf90_put_var(ncidpl, varidpl, apnc, [1], [nlevnc])
-!FC Pour les corrections la pression est deja en Pascals on commente la ligne ci-dessous
-             IF(convert_Pa) apnc=apnc*100.! conversion en Pascals
-             bpnc(:)=0.
-         ENDIF
-         first=.FALSE.
-     ENDIF ! (first)
-
-! -----------------------------------------------------------------
-!   lecture des champs u, v, T, Q, ps
-! -----------------------------------------------------------------
-
-!  dimensions pour les champs scalaires et le vent zonal
-     start(1)=1
-     start(2)=jjb_u
-     start(3)=1
-     start(4)=timestep
-
-     count(1)=iip1
-     count(2)=jjnb_u
-     count(3)=nlevnc
-     count(4)=1
-
-     IF (invert_y) start(2)=jjp1-jje_u+1
-! Pression
-     if (guide_plevs.EQ.2) then
-         status = nf90_put_var(ncidp, varidp, pnat2, start, count)
-         IF (invert_y) THEN
-!           PRINT*,"Invertion impossible actuellement"
-!           CALL abort_gcm(modname,abort_message,1)
-           CALL invert_lat(iip1,jjnb_u,nlevnc,pnat2)
-         ENDIF
-     endif
-
-!  Vent zonal
-     if (guide_u) then
-         status = nf90_put_var(ncidu, varidu, unat2, start, count)
-         IF (invert_y) THEN
-!           PRINT*,"Invertion impossible actuellement"
-!           CALL abort_gcm(modname,abort_message,1)
-           CALL invert_lat(iip1,jjnb_u,nlevnc,unat2)
-         ENDIF
-
-     endif
-
-
-!  Temperature
-     if (guide_T) then
-         status = nf90_put_var(ncidt, varidt, tnat2, start, count)
-         IF (invert_y) THEN
-!           PRINT*,"Invertion impossible actuellement"
-!           CALL abort_gcm(modname,abort_message,1)
-           CALL invert_lat(iip1,jjnb_u,nlevnc,tnat2)
-         ENDIF
-     endif
-
-!  Humidite
-     if (guide_Q) then
-         status = nf90_put_var(ncidQ, varidQ, qnat2, start, count)
-         IF (invert_y) THEN
-!           PRINT*,"Invertion impossible actuellement"
-!           CALL abort_gcm(modname,abort_message,1)
-           CALL invert_lat(iip1,jjnb_u,nlevnc,qnat2)
-         ENDIF
-
-     endif
-
-!  Vent meridien
-     if (guide_v) then
-         start(2)=jjb_v
-         count(2)=jjnb_v
-         IF (invert_y) start(2)=jjm-jje_v+1
-         status = nf90_put_var(ncidv, varidv, vnat2, start, count)
-         IF (invert_y) THEN
-!           PRINT*,"Invertion impossible actuellement"
-!           CALL abort_gcm(modname,abort_message,1)
-           CALL invert_lat(iip1,jjnb_v,nlevnc,vnat2)
-         ENDIF
-     endif
-
-!  Pression de surface
-     if ((guide_P).OR.(guide_plevs.EQ.1))  then
-         start(2)=jjb_u
-         start(3)=timestep
-         start(4)=0
-         count(2)=jjnb_u
-         count(3)=1
-         count(4)=0
-         IF (invert_y) start(2)=jjp1-jje_u+1
-         status = nf90_put_var(ncidps, varidps, psnat2, start, count)
-         IF (invert_y) THEN
-!           PRINT*,"Invertion impossible actuellement"
-!           CALL abort_gcm(modname,abort_message,1)
-           CALL invert_lat(iip1,jjnb_u,1,psnat2)
-         ENDIF
-     endif
-
-  END SUBROUTINE guide_read
-
-!=======================================================================
-  SUBROUTINE guide_read2D(timestep)
-    USE netcdf, ONLY: nf90_put_var
-    IMPLICIT NONE
-
-    include "netcdf.inc"
-    include "dimensions.h"
-    include "paramet.h"
-
-    INTEGER, INTENT(IN)   :: timestep
-
-    LOGICAL, SAVE         :: first=.TRUE.
-! Identification fichiers et variables NetCDF:
-    INTEGER, SAVE         :: ncidu,varidu,ncidv,varidv,ncidp,varidp
-    INTEGER, SAVE         :: ncidQ,varidQ,ncidt,varidt,ncidps,varidps
-    INTEGER               :: ncidpl,varidpl,varidap,varidbp
-! Variables auxiliaires NetCDF:
-    INTEGER, DIMENSION(4) :: start,count
-    INTEGER               :: status,rcode
-! Variables for 3D extension:
-    REAL, DIMENSION (jjb_u:jje_u,llm)  :: zu
-    REAL, DIMENSION (jjb_v:jje_v,llm)  :: zv
-    INTEGER               :: i
-    CHARACTER (len = 80)   :: abort_message
-    CHARACTER (len = 20)   :: modname = 'guide_read2D'
-    abort_message='pb in guide_read2D'
-
-! -----------------------------------------------------------------
-! Premier appel: initialisation de la lecture des fichiers
-! -----------------------------------------------------------------
-    if (first) then
-         ncidpl=-99
-         write(*,*)trim(modname)//' : opening nudging files '
-! Ap et Bp si niveaux de pression hybrides
-         if (guide_plevs.EQ.1) then
-           write(*,*)trim(modname)//' Reading nudging on model levels'
-           rcode = nf90_open('apbp.nc', nf90_nowrite, ncidpl)
-           IF (rcode.NE.NF_NOERR) THEN
-             abort_message='Nudging: error -> no file apbp.nc'
-           CALL abort_gcm(modname,abort_message,1)
-           ENDIF
-           rcode = nf90_inq_varid(ncidpl, 'AP', varidap)
-           IF (rcode.NE.NF_NOERR) THEN
-             abort_message='Nudging: error -> no AP variable in file apbp.nc'
-           CALL abort_gcm(modname,abort_message,1)
-           ENDIF
-           rcode = nf90_inq_varid(ncidpl, 'BP', varidbp)
-           IF (rcode.NE.NF_NOERR) THEN
-             abort_message='Nudging: error -> no BP variable in file apbp.nc'
-             CALL abort_gcm(modname,abort_message,1)
-           ENDIF
-           write(*,*)trim(modname)//'ncidpl,varidap',ncidpl,varidap
-         endif
-! Pression
-         if (guide_plevs.EQ.2) then
-           rcode = nf90_open('P.nc', nf90_nowrite, ncidp)
-           IF (rcode.NE.NF_NOERR) THEN
-             abort_message='Nudging: error -> no file P.nc'
-             CALL abort_gcm(modname,abort_message,1)
-           ENDIF
-           rcode = nf90_inq_varid(ncidp, 'PRES', varidp)
-           IF (rcode.NE.NF_NOERR) THEN
-             abort_message='Nudging: error -> no PRES variable in file P.nc'
-             CALL abort_gcm(modname,abort_message,1)
-           ENDIF
-           write(*,*)trim(modname)//' ncidp,varidp',ncidp,varidp
-           if (ncidpl.eq.-99) ncidpl=ncidp
-         endif
-! Vent zonal
-         if (guide_u) then
-           rcode = nf90_open('u.nc', nf90_nowrite, ncidu)
-           IF (rcode.NE.NF_NOERR) THEN
-             abort_message='Nudging: error -> no file u.nc'
-             CALL abort_gcm(modname,abort_message,1)
-           ENDIF
-           rcode = nf90_inq_varid(ncidu, 'UWND', varidu)
-           IF (rcode.NE.NF_NOERR) THEN
-             abort_message='Nudging: error -> no UWND variable in file u.nc'
-             CALL abort_gcm(modname,abort_message,1)
-           ENDIF
-           write(*,*)trim(modname)//' ncidu,varidu',ncidu,varidu
-           if (ncidpl.eq.-99) ncidpl=ncidu
-         endif
-
-! Vent meridien
-         if (guide_v) then
-           rcode = nf90_open('v.nc', nf90_nowrite, ncidv)
-           IF (rcode.NE.NF_NOERR) THEN
-             abort_message='Nudging: error -> no file v.nc'
-             CALL abort_gcm(modname,abort_message,1)
-           ENDIF
-           rcode = nf90_inq_varid(ncidv, 'VWND', varidv)
-           IF (rcode.NE.NF_NOERR) THEN
-             abort_message='Nudging: error -> no VWND variable in file v.nc'
-             CALL abort_gcm(modname,abort_message,1)
-           ENDIF
-           write(*,*)trim(modname)//' ncidv,varidv',ncidv,varidv
-           if (ncidpl.eq.-99) ncidpl=ncidv
-        endif
-! Temperature
-         if (guide_T) then
-           rcode = nf90_open('T.nc', nf90_nowrite, ncidt)
-           IF (rcode.NE.NF_NOERR) THEN
-             abort_message='Nudging: error -> no file T.nc'
-             CALL abort_gcm(modname,abort_message,1)
-           ENDIF
-           rcode = nf90_inq_varid(ncidt, 'AIR', varidt)
-           IF (rcode.NE.NF_NOERR) THEN
-             abort_message='Nudging: error -> no AIR variable in file T.nc'
-             CALL abort_gcm(modname,abort_message,1)
-           ENDIF
-           write(*,*)trim(modname)//' ncidT,varidT',ncidt,varidt
-           if (ncidpl.eq.-99) ncidpl=ncidt
-         endif
-! Humidite
-         if (guide_Q) then
-           rcode = nf90_open('hur.nc', nf90_nowrite, ncidQ)
-           IF (rcode.NE.NF_NOERR) THEN
-             abort_message='Nudging: error -> no file hur.nc'
-             CALL abort_gcm(modname,abort_message,1)
-           ENDIF
-           rcode = nf90_inq_varid(ncidQ, 'RH', varidQ)
-           IF (rcode.NE.NF_NOERR) THEN
-             abort_message='Nudging: error -> no RH,variable in file hur.nc'
-             CALL abort_gcm(modname,abort_message,1)
-           ENDIF
-           write(*,*)trim(modname)//' ncidQ,varidQ',ncidQ,varidQ
-           if (ncidpl.eq.-99) ncidpl=ncidQ
-         endif
-! Pression de surface
-         if ((guide_P).OR.(guide_plevs.EQ.1)) then
-           rcode = nf90_open('ps.nc', nf90_nowrite, ncidps)
-           IF (rcode.NE.NF_NOERR) THEN
-             abort_message='Nudging: error -> no file ps.nc'
-             CALL abort_gcm(modname,abort_message,1)
-           ENDIF
-           rcode = nf90_inq_varid(ncidps, 'SP', varidps)
-           IF (rcode.NE.NF_NOERR) THEN
-             abort_message='Nudging: error -> no SP variable in file ps.nc'
-             CALL abort_gcm(modname,abort_message,1)
-           ENDIF
-           write(*,*)trim(modname)//' ncidps,varidps',ncidps,varidps
-         endif
-! Coordonnee verticale
-         if (guide_plevs.EQ.0) then
-           rcode = nf90_inq_varid(ncidpl, 'LEVEL', varidpl)
-           IF (rcode.NE.0) rcode = nf90_inq_varid(ncidpl, 'PRESSURE', varidpl)
-           write(*,*)trim(modname)//' ncidpl,varidpl',ncidpl,varidpl
-         endif
-! Coefs ap, bp pour calcul de la pression aux differents niveaux
-         if (guide_plevs.EQ.1) then
-             status = nf90_put_var(ncidpl, varidap, apnc, [1], [nlevnc])
-             status = nf90_put_var(ncidpl, varidbp, bpnc, [1], [nlevnc])
-         elseif (guide_plevs.EQ.0) THEN
-             status = nf90_put_var(ncidpl, varidpl, apnc, [1], [nlevnc])
-             apnc=apnc*100.! conversion en Pascals
-             bpnc(:)=0.
-         endif
-         first=.FALSE.
-     endif ! (first)
-
-! -----------------------------------------------------------------
-!   lecture des champs u, v, T, Q, ps
-! -----------------------------------------------------------------
-
-!  dimensions pour les champs scalaires et le vent zonal
-     start(1)=1
-     start(2)=jjb_u
-     start(3)=1
-     start(4)=timestep
-
-     count(1)=1
-     count(2)=jjnb_u
-     count(3)=nlevnc
-     count(4)=1
-
-     IF (invert_y) start(2)=jjp1-jje_u+1
-!  Pression
-     if (guide_plevs.EQ.2) then
-         status = nf90_put_var(ncidp, varidp, zu, start, count)
-         DO i=1,iip1
-             pnat2(i,:,:)=zu(:,:)
-         ENDDO
-
-         IF (invert_y) THEN
-!           PRINT*,"Invertion impossible actuellement"
-!           CALL abort_gcm(modname,abort_message,1)
-           CALL invert_lat(iip1,jjnb_u,nlevnc,pnat2)
-         ENDIF
-     endif
-!  Vent zonal
-     if (guide_u) then
-         status = nf90_put_var(ncidu, varidu, zu, start, count)
-         DO i=1,iip1
-             unat2(i,:,:)=zu(:,:)
-         ENDDO
-
-         IF (invert_y) THEN
-!           PRINT*,"Invertion impossible actuellement"
-!           CALL abort_gcm(modname,abort_message,1)
-           CALL invert_lat(iip1,jjnb_u,nlevnc,unat2)
-         ENDIF
-     endif
-
-
-!  Temperature
-     if (guide_T) then
-         status = nf90_put_var(ncidt, varidt, zu, start, count)
-         DO i=1,iip1
-             tnat2(i,:,:)=zu(:,:)
-         ENDDO
-
-         IF (invert_y) THEN
-!           PRINT*,"Invertion impossible actuellement"
-!           CALL abort_gcm(modname,abort_message,1)
-           CALL invert_lat(iip1,jjnb_u,nlevnc,tnat2)
-         ENDIF
-     endif
-
-!  Humidite
-     if (guide_Q) then
-         status = nf90_put_var(ncidQ, varidQ, zu, start, count)
-         DO i=1,iip1
-             qnat2(i,:,:)=zu(:,:)
-         ENDDO
-
-         IF (invert_y) THEN
-!           PRINT*,"Invertion impossible actuellement"
-!           CALL abort_gcm(modname,abort_message,1)
-           CALL invert_lat(iip1,jjnb_u,nlevnc,qnat2)
-         ENDIF
-     endif
-
-!  Vent meridien
-     if (guide_v) then
-         start(2)=jjb_v
-         count(2)=jjnb_v
-         IF (invert_y) start(2)=jjm-jje_v+1
-         status = nf90_put_var(ncidv, varidv, zv, start, count)
-         DO i=1,iip1
-             vnat2(i,:,:)=zv(:,:)
-         ENDDO
-
-         IF (invert_y) THEN
-
-!           PRINT*,"Invertion impossible actuellement"
-!           CALL abort_gcm(modname,abort_message,1)
-           CALL invert_lat(iip1,jjnb_v,nlevnc,vnat2)
-         ENDIF
-     endif
-
-!  Pression de surface
-     if ((guide_P).OR.(guide_plevs.EQ.1))  then
-         start(2)=jjb_u
-         start(3)=timestep
-         start(4)=0
-         count(2)=jjnb_u
-         count(3)=1
-         count(4)=0
-         IF (invert_y) start(2)=jjp1-jje_u+1
-         status = nf90_put_var(ncidps, varidps, zu(:, 1), start, count)
-         DO i=1,iip1
-             psnat2(i,:)=zu(:,1)
-         ENDDO
-
-         IF (invert_y) THEN
-!           PRINT*,"Invertion impossible actuellement"
-!           CALL abort_gcm(modname,abort_message,1)
-           CALL invert_lat(iip1,jjnb_u,1,psnat2)
-         ENDIF
-     endif
-
-  END SUBROUTINE guide_read2D
-
-!=======================================================================
-  SUBROUTINE guide_out(varname,hsize,vsize,field_loc,factt)
-    USE parallel_lmdz
-    USE mod_hallo, ONLY : gather_field_u, gather_field_v
-    USE comconst_mod, ONLY: pi
-    USE comvert_mod, ONLY: presnivs
-    use netcdf95, only: nf95_def_var, nf95_put_var
-    use netcdf, only: nf90_float, nf90_put_var
-
-    IMPLICIT NONE
-
-    INCLUDE "dimensions.h"
-    INCLUDE "paramet.h"
-    INCLUDE "netcdf.inc"
-    INCLUDE "comgeom2.h"
-
-    ! Variables entree
-    CHARACTER*(*), INTENT(IN)                      :: varname
-    INTEGER,   INTENT (IN)                         :: hsize,vsize
-!   REAL, DIMENSION (iip1,hsize,vsize), INTENT(IN) :: field_loc
-    REAL, DIMENSION (:,:), INTENT(IN) :: field_loc
-    REAL factt
-
-    ! Variables locales
-    INTEGER, SAVE :: timestep=0
-    ! Identites fichier netcdf
-    INTEGER       :: nid, id_lonu, id_lonv, id_latu, id_latv, id_tim, id_lev
-    INTEGER       :: vid_lonu,vid_lonv,vid_latu,vid_latv,vid_cu,vid_cv,vid_lev
-    INTEGER       :: vid_au,vid_av, varid_alpha_t, varid_alpha_q
-    INTEGER, DIMENSION (3) :: dim3
-    INTEGER, DIMENSION (4) :: dim4,count,start
-    INTEGER                :: ierr, varid,l
-    REAL zu(ip1jmp1),zv(ip1jm), zt(iip1, jjp1), zq(iip1, jjp1)
-    REAL, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: field_glo
-    CHARACTER(LEN=20),PARAMETER :: modname="guide_out"
-
-!$OMP MASTER
-    ALLOCATE(field_glo(iip1,hsize,vsize))
-!$OMP END MASTER
-!$OMP BARRIER
-
-!    write(*,*)trim(modname)//' after allocation ',hsize,vsize
-
-    IF (hsize==jjp1) THEN
-        CALL gather_field_u(field_loc,field_glo,vsize)
-    ELSE IF (hsize==jjm) THEN
-       CALL gather_field_v(field_loc,field_glo, vsize)
-    ENDIF
-
-!    write(*,*)trim(modname)//' after gather '
-    CALL Gather_field_u(alpha_u,zu,1)
-    CALL Gather_field_u(alpha_t,zt,1)
-    CALL Gather_field_u(alpha_q,zq,1)
-    CALL Gather_field_v(alpha_v,zv,1)
-
-    IF (mpi_rank >  0) THEN
-!$OMP MASTER
-       DEALLOCATE(field_glo)
-!$OMP END MASTER
-!$OMP BARRIER
-
-       RETURN
-    ENDIF
-
-!$OMP MASTER
-    IF (timestep.EQ.0) THEN
-! ----------------------------------------------
-! initialisation fichier de sortie
-! ----------------------------------------------
-! Ouverture du fichier
-        ierr=NF_CREATE("guide_ins.nc",IOR(NF_CLOBBER,NF_64BIT_OFFSET),nid)
-! Definition des dimensions
-        ierr=NF_DEF_DIM(nid,"LONU",iip1,id_lonu)
-        ierr=NF_DEF_DIM(nid,"LONV",iip1,id_lonv)
-        ierr=NF_DEF_DIM(nid,"LATU",jjp1,id_latu)
-        ierr=NF_DEF_DIM(nid,"LATV",jjm,id_latv)
-        ierr=NF_DEF_DIM(nid,"LEVEL",llm,id_lev)
-        ierr=NF_DEF_DIM(nid,"TIME",NF_UNLIMITED,id_tim)
-
-! Creation des variables dimensions
-        ierr=NF_DEF_VAR(nid,"LONU",NF_FLOAT,1,id_lonu,vid_lonu)
-        ierr=NF_DEF_VAR(nid,"LONV",NF_FLOAT,1,id_lonv,vid_lonv)
-        ierr=NF_DEF_VAR(nid,"LATU",NF_FLOAT,1,id_latu,vid_latu)
-        ierr=NF_DEF_VAR(nid,"LATV",NF_FLOAT,1,id_latv,vid_latv)
-        ierr=NF_DEF_VAR(nid,"LEVEL",NF_FLOAT,1,id_lev,vid_lev)
-        ierr=NF_DEF_VAR(nid,"cu",NF_FLOAT,2,(/id_lonu,id_latu/),vid_cu)
-        ierr=NF_DEF_VAR(nid,"cv",NF_FLOAT,2,(/id_lonv,id_latv/),vid_cv)
-        ierr=NF_DEF_VAR(nid,"au",NF_FLOAT,2,(/id_lonu,id_latu/),vid_au)
-        ierr=NF_DEF_VAR(nid,"av",NF_FLOAT,2,(/id_lonv,id_latv/),vid_av)
-        call nf95_def_var(nid, "alpha_T", nf90_float, (/id_lonv, id_latu/), &
-             varid_alpha_t)
-        call nf95_def_var(nid, "alpha_q", nf90_float, (/id_lonv, id_latu/), &
-             varid_alpha_q)
-
-        ierr=NF_ENDDEF(nid)
-
-! Enregistrement des variables dimensions
-        ierr = nf90_put_var(nid, vid_lonu, rlonu * 180. / pi)
-        ierr = nf90_put_var(nid, vid_lonv, rlonv * 180. / pi)
-        ierr = nf90_put_var(nid, vid_latu, rlatu * 180. / pi)
-        ierr = nf90_put_var(nid, vid_latv, rlatv * 180. / pi)
-        ierr = nf90_put_var(nid, vid_lev, presnivs)
-        ierr = nf90_put_var(nid, vid_cu, cu)
-        ierr = nf90_put_var(nid, vid_cv, cv)
-        ierr = nf90_put_var(nid, vid_au, zu)
-        ierr = nf90_put_var(nid, vid_av, zv)
-        call nf95_put_var(nid, varid_alpha_t, zt)
-        call nf95_put_var(nid, varid_alpha_q, zq)
-! --------------------------------------------------------------------
-! Cr�ation des variables sauvegard�es
-! --------------------------------------------------------------------
-        ierr = NF_REDEF(nid)
-! Pressure (GCM)
-        dim4=(/id_lonv,id_latu,id_lev,id_tim/)
-        ierr = NF_DEF_VAR(nid,"SP",NF_FLOAT,4,dim4,varid)
-! Surface pressure (guidage)
-        IF (guide_P) THEN
-            dim3=(/id_lonv,id_latu,id_tim/)
-            ierr = NF_DEF_VAR(nid,"ps",NF_FLOAT,3,dim3,varid)
-        ENDIF
-! Zonal wind
-        IF (guide_u) THEN
-            dim4=(/id_lonu,id_latu,id_lev,id_tim/)
-            ierr = NF_DEF_VAR(nid,"u",NF_FLOAT,4,dim4,varid)
-            ierr = NF_DEF_VAR(nid,"ua",NF_FLOAT,4,dim4,varid)
-            ierr = NF_DEF_VAR(nid,"ucov",NF_FLOAT,4,dim4,varid)
-        ENDIF
-! Merid. wind
-        IF (guide_v) THEN
-            dim4=(/id_lonv,id_latv,id_lev,id_tim/)
-            ierr = NF_DEF_VAR(nid,"v",NF_FLOAT,4,dim4,varid)
-            ierr = NF_DEF_VAR(nid,"va",NF_FLOAT,4,dim4,varid)
-            ierr = NF_DEF_VAR(nid,"vcov",NF_FLOAT,4,dim4,varid)
-        ENDIF
-! Pot. Temperature
-        IF (guide_T) THEN
-            dim4=(/id_lonv,id_latu,id_lev,id_tim/)
-            ierr = NF_DEF_VAR(nid,"teta",NF_FLOAT,4,dim4,varid)
-        ENDIF
-! Specific Humidity
-        IF (guide_Q) THEN
-            dim4=(/id_lonv,id_latu,id_lev,id_tim/)
-            ierr = NF_DEF_VAR(nid,"q",NF_FLOAT,4,dim4,varid)
-        ENDIF
-
-        ierr = NF_ENDDEF(nid)
-        ierr = NF_CLOSE(nid)
-    ENDIF ! timestep=0
-
-! --------------------------------------------------------------------
-! Enregistrement du champ
-! --------------------------------------------------------------------
-
-    ierr=NF_OPEN("guide_ins.nc",NF_WRITE,nid)
-
-    IF (varname=="SP") timestep=timestep+1
-
-    ierr = NF_INQ_VARID(nid,varname,varid)
-    SELECT CASE (varname)
-    CASE ("SP","ps")
-        start=(/1,1,1,timestep/)
-        count=(/iip1,jjp1,llm,1/)
-    CASE ("v","va","vcov")
-        start=(/1,1,1,timestep/)
-        count=(/iip1,jjm,llm,1/)
-    CASE DEFAULT
-        start=(/1,1,1,timestep/)
-        count=(/iip1,jjp1,llm,1/)
-    END SELECT
-
-!$OMP END MASTER
-!$OMP BARRIER
-
-    SELECT CASE (varname)
-
-    CASE("u","ua")
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-        DO l=1,llm
-            field_glo(:,2:jjm,l)=field_glo(:,2:jjm,l)/cu(:,2:jjm)
-            field_glo(:,1,l)=0. ; field_glo(:,jjp1,l)=0.
-        ENDDO
-    CASE("v","va")
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-        DO l=1,llm
-           field_glo(:,:,l)=field_glo(:,:,l)/cv(:,:)
-        ENDDO
-    END SELECT
-
-!    if (varname=="ua") then
-!    call dump2d(iip1,jjp1,field_glo,'ua gui1 1ere couche ')
-!    call dump2d(iip1,jjp1,field_glo(:,:,llm),'ua gui1 llm ')
-!    endif
-
-!$OMP MASTER
-
-    ierr = nf90_put_var(nid, varid, field_glo, start, count)
-    ierr = NF_CLOSE(nid)
-
-       DEALLOCATE(field_glo)
-!$OMP END MASTER
-!$OMP BARRIER
-
-  END SUBROUTINE guide_out
-
-
-!===========================================================================
-  subroutine correctbid(iim,nl,x)
-    integer iim,nl
-    real x(iim+1,nl)
-    integer i,l
-    real zz
-
-    do l=1,nl
-        do i=2,iim-1
-            if(abs(x(i,l)).gt.1.e10) then
-               zz=0.5*(x(i-1,l)+x(i+1,l))
-              print*,'correction ',i,l,x(i,l),zz
-               x(i,l)=zz
-            endif
-         enddo
-     enddo
-     return
-  end subroutine correctbid
-
-
-!====================================================================
-! Ascii debug output. Could be reactivated
-!====================================================================
-
-subroutine dump2du(var,varname)
-use parallel_lmdz
-use mod_hallo
-implicit none
-include 'dimensions.h'
-include 'paramet.h'
-
-      CHARACTER (len=*) :: varname
-
-
-real, dimension(ijb_u:ije_u) :: var
-
-real, dimension(ip1jmp1) :: var_glob
-
-    RETURN
-
-    call barrier
-    CALL Gather_field_u(var,var_glob,1)
-    call barrier
-
-    if (mpi_rank==0) then
-       call dump2d(iip1,jjp1,var_glob,varname)
-    endif
-
-    call barrier
-
-    return
-    end subroutine dump2du
-
-!====================================================================
-! Ascii debug output. Could be reactivated
-!====================================================================
-subroutine dumpall
-     implicit none
-     include "dimensions.h"
-     include "paramet.h"
-     include "comgeom.h"
-     call barrier
-     call dump2du(alpha_u(ijb_u:ije_u),'  alpha_u couche 1')
-     call dump2du(unat2(:,jjbu:jjeu,nlevnc),'  unat2 couche nlevnc')
-     call dump2du(ugui1(ijb_u:ije_u,1)*sqrt(unscu2(ijb_u:ije_u)),'  ugui1 couche 1')
-     return
-end subroutine dumpall
-
-!===========================================================================
-END MODULE guide_loc_mod
Index: /LMDZ6/trunk/libf/dyn3dmem/guide_loc_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/guide_loc_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3dmem/guide_loc_mod.f90	(revision 5268)
@@ -0,0 +1,2440 @@
+!
+! $Id$
+!
+MODULE guide_loc_mod
+
+!=======================================================================
+!   Auteur:  F.Hourdin
+!            F. Codron 01/09
+!=======================================================================
+
+  USE getparam, only: ini_getparam, fin_getparam, getpar
+  USE Write_Field_loc
+  use netcdf, only: nf90_nowrite, nf90_open, nf90_inq_varid, nf90_close, &
+                    nf90_inq_dimid, nf90_inquire_dimension
+  USE parallel_lmdz
+  USE pres2lev_mod, only: pres2lev
+
+  IMPLICIT NONE
+
+! ---------------------------------------------
+! Declarations des cles logiques et parametres
+! ---------------------------------------------
+  INTEGER, PRIVATE, SAVE  :: iguide_read,iguide_int,iguide_sav
+  INTEGER, PRIVATE, SAVE  :: nlevnc, guide_plevs
+  LOGICAL, PRIVATE, SAVE  :: guide_u,guide_v,guide_T,guide_Q,guide_P
+  LOGICAL, PRIVATE, SAVE  :: guide_hr,guide_teta
+  LOGICAL, PRIVATE, SAVE  :: guide_BL,guide_reg,guide_add,gamma4,guide_zon
+  LOGICAL, PRIVATE, SAVE  :: invert_p,invert_y,ini_anal
+  LOGICAL, PRIVATE, SAVE  :: guide_2D,guide_sav,guide_modele
+!FC
+  LOGICAL, PRIVATE, SAVE  :: convert_Pa
+
+  REAL, PRIVATE, SAVE     :: tau_min_u,tau_max_u
+  REAL, PRIVATE, SAVE     :: tau_min_v,tau_max_v
+  REAL, PRIVATE, SAVE     :: tau_min_T,tau_max_T
+  REAL, PRIVATE, SAVE     :: tau_min_Q,tau_max_Q
+  REAL, PRIVATE, SAVE     :: tau_min_P,tau_max_P
+
+  REAL, PRIVATE, SAVE     :: lat_min_g,lat_max_g
+  REAL, PRIVATE, SAVE     :: lon_min_g,lon_max_g
+  REAL, PRIVATE, SAVE     :: tau_lon,tau_lat
+
+  REAL, PRIVATE, SAVE     :: plim_guide_BL
+
+  REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE     :: alpha_u,alpha_v
+  REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE     :: alpha_T,alpha_Q
+  REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE     :: alpha_P,alpha_pcor
+
+! ---------------------------------------------
+! Variables de guidage
+! ---------------------------------------------
+! Variables des fichiers de guidage
+  REAL, ALLOCATABLE, DIMENSION(:,:,:), PRIVATE, SAVE   :: unat1,unat2
+  REAL, ALLOCATABLE, DIMENSION(:,:,:), PRIVATE, SAVE   :: vnat1,vnat2
+  REAL, ALLOCATABLE, DIMENSION(:,:,:), PRIVATE, SAVE   :: tnat1,tnat2
+  REAL, ALLOCATABLE, DIMENSION(:,:,:), PRIVATE, SAVE   :: qnat1,qnat2
+  REAL, ALLOCATABLE, DIMENSION(:,:,:), PRIVATE, SAVE   :: pnat1,pnat2
+  REAL, ALLOCATABLE, DIMENSION(:,:),   PRIVATE, SAVE   :: psnat1,psnat2
+  REAL, ALLOCATABLE, DIMENSION(:),     PRIVATE, SAVE   :: apnc,bpnc
+! Variables aux dimensions du modele
+  REAL, ALLOCATABLE, DIMENSION(:,:),   PRIVATE, SAVE   :: ugui1,ugui2
+  REAL, ALLOCATABLE, DIMENSION(:,:),   PRIVATE, SAVE   :: vgui1,vgui2
+  REAL, ALLOCATABLE, DIMENSION(:,:),   PRIVATE, SAVE   :: tgui1,tgui2
+  REAL, ALLOCATABLE, DIMENSION(:,:),   PRIVATE, SAVE   :: qgui1,qgui2
+  REAL, ALLOCATABLE, DIMENSION(:),   PRIVATE, SAVE   :: psgui1,psgui2
+
+  INTEGER,SAVE,PRIVATE :: ijbu,ijbv,ijeu,ijev !,ijnu,ijnv
+  INTEGER,SAVE,PRIVATE :: jjbu,jjbv,jjeu,jjev,jjnu,jjnv
+
+
+CONTAINS
+!=======================================================================
+
+  SUBROUTINE guide_init
+
+    USE control_mod, ONLY: day_step
+    USE serre_mod, ONLY: grossismx
+
+    IMPLICIT NONE
+
+    INCLUDE "dimensions.h"
+    INCLUDE "paramet.h"
+    INCLUDE "netcdf.inc"
+
+    INTEGER                :: error,ncidpl,rid,rcod
+    CHARACTER (len = 80)   :: abort_message
+    CHARACTER (len = 20)   :: modname = 'guide_init'
+    CHARACTER (len = 20)   :: namedim
+
+! ---------------------------------------------
+! Lecture des parametres:
+! ---------------------------------------------
+    call ini_getparam("nudging_parameters_out.txt")
+! Variables guidees
+    CALL getpar('guide_u',.true.,guide_u,'guidage de u')
+    CALL getpar('guide_v',.true.,guide_v,'guidage de v')
+    CALL getpar('guide_T',.true.,guide_T,'guidage de T')
+    CALL getpar('guide_P',.true.,guide_P,'guidage de P')
+    CALL getpar('guide_Q',.true.,guide_Q,'guidage de Q')
+    CALL getpar('guide_hr',.true.,guide_hr,'guidage de Q par H.R')
+    CALL getpar('guide_teta',.false.,guide_teta,'guidage de T par Teta')
+
+    CALL getpar('guide_add',.false.,guide_add,'for�age constant?')
+    CALL getpar('guide_zon',.false.,guide_zon,'guidage moy zonale')
+    if (guide_zon .and. abs(grossismx - 1.) > 0.01) &
+         call abort_gcm("guide_init", &
+         "zonal nudging requires grid regular in longitude", 1)
+
+!   Constantes de rappel. Unite : fraction de jour
+    CALL getpar('tau_min_u',0.02,tau_min_u,'Cste de rappel min, u')
+    CALL getpar('tau_max_u', 10.,tau_max_u,'Cste de rappel max, u')
+    CALL getpar('tau_min_v',0.02,tau_min_v,'Cste de rappel min, v')
+    CALL getpar('tau_max_v', 10.,tau_max_v,'Cste de rappel max, v')
+    CALL getpar('tau_min_T',0.02,tau_min_T,'Cste de rappel min, T')
+    CALL getpar('tau_max_T', 10.,tau_max_T,'Cste de rappel max, T')
+    CALL getpar('tau_min_Q',0.02,tau_min_Q,'Cste de rappel min, Q')
+    CALL getpar('tau_max_Q', 10.,tau_max_Q,'Cste de rappel max, Q')
+    CALL getpar('tau_min_P',0.02,tau_min_P,'Cste de rappel min, P')
+    CALL getpar('tau_max_P', 10.,tau_max_P,'Cste de rappel max, P')
+    CALL getpar('gamma4',.false.,gamma4,'Zone sans rappel elargie')
+    CALL getpar('guide_BL',.true.,guide_BL,'guidage dans C.Lim')
+    CALL getpar('plim_guide_BL',85000.,plim_guide_BL,'BL top presnivs value')
+
+! Sauvegarde du for�age
+    CALL getpar('guide_sav',.false.,guide_sav,'sauvegarde guidage')
+    CALL getpar('iguide_sav',4,iguide_sav,'freq. sauvegarde guidage')
+    ! frequences f>0: fx/jour; f<0: tous les f jours; f=0: 1 seule fois.
+    IF (iguide_sav.GT.0) THEN
+       iguide_sav=day_step/iguide_sav
+    ELSE if (iguide_sav == 0) then
+       iguide_sav = huge(0)
+    ELSE
+       iguide_sav=day_step*iguide_sav
+    ENDIF
+
+! Guidage regional seulement (sinon constant ou suivant le zoom)
+    CALL getpar('guide_reg',.false.,guide_reg,'guidage regional')
+    CALL getpar('lat_min_g',-90.,lat_min_g,'Latitude mini guidage ')
+    CALL getpar('lat_max_g', 90.,lat_max_g,'Latitude maxi guidage ')
+    CALL getpar('lon_min_g',-180.,lon_min_g,'longitude mini guidage ')
+    CALL getpar('lon_max_g', 180.,lon_max_g,'longitude maxi guidage ')
+    CALL getpar('tau_lat', 5.,tau_lat,'raideur lat guide regional ')
+    CALL getpar('tau_lon', 5.,tau_lon,'raideur lon guide regional ')
+
+! Parametres pour lecture des fichiers
+    CALL getpar('iguide_read',4,iguide_read,'freq. lecture guidage')
+    CALL getpar('iguide_int',4,iguide_int,'freq. interpolation vert')
+    IF (iguide_int.EQ.0) THEN
+        iguide_int=1
+    ELSEIF (iguide_int.GT.0) THEN
+        iguide_int=day_step/iguide_int
+    ELSE
+        iguide_int=day_step*iguide_int
+    ENDIF
+    CALL getpar('guide_plevs',0,guide_plevs,'niveaux pression fichiers guidage')
+    ! Pour compatibilite avec ancienne version avec guide_modele
+    CALL getpar('guide_modele',.false.,guide_modele,'niveaux pression ap+bp*psol')
+    IF (guide_modele) THEN
+        guide_plevs=1
+    ENDIF
+!FC
+    CALL getpar('convert_Pa',.true.,convert_Pa,'Convert Pressure levels in Pa')
+    ! Fin raccord
+    CALL getpar('ini_anal',.false.,ini_anal,'Etat initial = analyse')
+    CALL getpar('guide_invertp',.true.,invert_p,'niveaux p inverses')
+    CALL getpar('guide_inverty',.true.,invert_y,'inversion N-S')
+    CALL getpar('guide_2D',.false.,guide_2D,'fichier guidage lat-P')
+
+    call fin_getparam
+
+! ---------------------------------------------
+! Determination du nombre de niveaux verticaux
+! des fichiers guidage
+! ---------------------------------------------
+    ncidpl=-99
+    if (guide_plevs.EQ.1) then
+       if (ncidpl.eq.-99) then
+          rcod=nf90_open('apbp.nc',Nf90_NOWRITe, ncidpl)
+          if (rcod.NE.NF_NOERR) THEN
+             abort_message=' Nudging error -> no file apbp.nc'
+             CALL abort_gcm(modname,abort_message,1)
+          endif
+       endif
+    elseif (guide_plevs.EQ.2) then
+       if (ncidpl.EQ.-99) then
+          rcod=nf90_open('P.nc',Nf90_NOWRITe,ncidpl)
+          if (rcod.NE.NF_NOERR) THEN
+             abort_message=' Nudging error -> no file P.nc'
+             CALL abort_gcm(modname,abort_message,1)
+          endif
+       endif
+
+    elseif (guide_u) then
+       if (ncidpl.eq.-99) then
+          rcod=nf90_open('u.nc',Nf90_NOWRITe,ncidpl)
+          if (rcod.NE.NF_NOERR) THEN
+             abort_message=' Nudging error -> no file u.nc'
+             CALL abort_gcm(modname,abort_message,1)
+          endif
+
+       endif
+
+
+    elseif (guide_v) then
+       if (ncidpl.eq.-99) then
+          rcod=nf90_open('v.nc',nf90_nowrite,ncidpl)
+          if (rcod.NE.NF_NOERR) THEN
+             abort_message=' Nudging error -> no file v.nc'
+             CALL abort_gcm(modname,abort_message,1)
+          endif
+       endif
+
+
+    elseif (guide_T) then
+       if (ncidpl.eq.-99) then
+          rcod=nf90_open('T.nc',nf90_nowrite,ncidpl)
+          if (rcod.NE.NF_NOERR) THEN
+             abort_message=' Nudging error -> no file T.nc'
+             CALL abort_gcm(modname,abort_message,1)
+          endif
+       endif
+
+
+
+    elseif (guide_Q) then
+       if (ncidpl.eq.-99) then
+          rcod=nf90_open('hur.nc',nf90_nowrite, ncidpl)
+          if (rcod.NE.NF_NOERR) THEN
+             abort_message=' Nudging error -> no file hur.nc'
+             CALL abort_gcm(modname,abort_message,1)
+          endif
+       endif
+
+
+    endif
+    error=NF_INQ_DIMID(ncidpl,'LEVEL',rid)
+    IF (error.NE.NF_NOERR) error=NF_INQ_DIMID(ncidpl,'PRESSURE',rid)
+    IF (error.NE.NF_NOERR) THEN
+        abort_message='Nudging: error reading pressure levels'
+        CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+    error=NF_INQ_DIMLEN(ncidpl,rid,nlevnc)
+    write(*,*)trim(modname)//' : number of vertical levels nlevnc', nlevnc
+    rcod = nf90_close(ncidpl)
+
+! ---------------------------------------------
+! Allocation des variables
+! ---------------------------------------------
+    abort_message='nudging allocation error'
+
+    ALLOCATE(apnc(nlevnc), stat = error)
+    IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+    ALLOCATE(bpnc(nlevnc), stat = error)
+    IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+    apnc=0.;bpnc=0.
+
+    ALLOCATE(alpha_pcor(llm), stat = error)
+    IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+    ALLOCATE(alpha_u(ijb_u:ije_u), stat = error)
+    IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+    ALLOCATE(alpha_v(ijb_v:ije_v), stat = error)
+    IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+    ALLOCATE(alpha_T(ijb_u:ije_u), stat = error)
+    IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+    ALLOCATE(alpha_Q(ijb_u:ije_u), stat = error)
+    IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+    ALLOCATE(alpha_P(ijb_u:ije_u), stat = error)
+    IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+    alpha_u=0.;alpha_v=0;alpha_T=0;alpha_Q=0;alpha_P=0
+
+    IF (guide_u) THEN
+        ALLOCATE(unat1(iip1,jjb_u:jje_u,nlevnc), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(ugui1(ijb_u:ije_u,llm), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(unat2(iip1,jjb_u:jje_u,nlevnc), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(ugui2(ijb_u:ije_u,llm), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        unat1=0.;unat2=0.;ugui1=0.;ugui2=0.
+    ENDIF
+
+    IF (guide_T) THEN
+        ALLOCATE(tnat1(iip1,jjb_u:jje_u,nlevnc), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(tgui1(ijb_u:ije_u,llm), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(tnat2(iip1,jjb_u:jje_u,nlevnc), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(tgui2(ijb_u:ije_u,llm), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        tnat1=0.;tnat2=0.;tgui1=0.;tgui2=0.
+    ENDIF
+
+    IF (guide_Q) THEN
+        ALLOCATE(qnat1(iip1,jjb_u:jje_u,nlevnc), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(qgui1(ijb_u:ije_u,llm), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(qnat2(iip1,jjb_u:jje_u,nlevnc), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(qgui2(ijb_u:ije_u,llm), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        qnat1=0.;qnat2=0.;qgui1=0.;qgui2=0.
+    ENDIF
+
+    IF (guide_v) THEN
+        ALLOCATE(vnat1(iip1,jjb_v:jje_v,nlevnc), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(vgui1(ijb_v:ije_v,llm), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(vnat2(iip1,jjb_v:jje_v,nlevnc), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(vgui2(ijb_v:ije_v,llm), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        vnat1=0.;vnat2=0.;vgui1=0.;vgui2=0.
+    ENDIF
+
+    IF (guide_plevs.EQ.2) THEN
+        ALLOCATE(pnat1(iip1,jjb_u:jje_u,nlevnc), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(pnat2(iip1,jjb_u:jje_u,nlevnc), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        pnat1=0.;pnat2=0.;
+    ENDIF
+
+    IF (guide_P.OR.guide_plevs.EQ.1) THEN
+        ALLOCATE(psnat1(iip1,jjb_u:jje_u), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(psnat2(iip1,jjb_u:jje_u), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        psnat1=0.;psnat2=0.;
+    ENDIF
+    IF (guide_P) THEN
+        ALLOCATE(psgui2(ijb_u:ije_u), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        ALLOCATE(psgui1(ijb_u:ije_u), stat = error)
+        IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
+        psgui1=0.;psgui2=0.
+    ENDIF
+
+! ---------------------------------------------
+!   Lecture du premier etat de guidage.
+! ---------------------------------------------
+    IF (guide_2D) THEN
+        CALL guide_read2D(1)
+    ELSE
+        CALL guide_read(1)
+    ENDIF
+    IF (guide_v) vnat1=vnat2
+    IF (guide_u) unat1=unat2
+    IF (guide_T) tnat1=tnat2
+    IF (guide_Q) qnat1=qnat2
+    IF (guide_plevs.EQ.2) pnat1=pnat2
+    IF (guide_P.OR.guide_plevs.EQ.1) psnat1=psnat2
+
+  END SUBROUTINE guide_init
+
+!=======================================================================
+  SUBROUTINE guide_main(itau,ucov,vcov,teta,q,masse,ps)
+    use exner_hyb_loc_m, only: exner_hyb_loc
+    use exner_milieu_loc_m, only: exner_milieu_loc
+    USE parallel_lmdz
+    USE control_mod
+    USE write_field_loc
+    USE comconst_mod, ONLY: cpp, daysec, dtvr, kappa
+    USE comvert_mod, ONLY: ap, bp, preff, presnivs, pressure_exner
+
+    IMPLICIT NONE
+
+    INCLUDE "dimensions.h"
+    INCLUDE "paramet.h"
+
+    ! Variables entree
+    INTEGER,                           INTENT(IN)    :: itau !pas de temps
+    REAL, DIMENSION (ijb_u:ije_u,llm), INTENT(INOUT) :: ucov,teta,q,masse
+    REAL, DIMENSION (ijb_v:ije_v,llm), INTENT(INOUT) :: vcov
+    REAL, DIMENSION (ijb_u:ije_u),     INTENT(INOUT) :: ps
+
+    ! Variables locales
+    LOGICAL, SAVE :: first=.TRUE.
+!$OMP THREADPRIVATE(first)
+    LOGICAL       :: f_out ! sortie guidage
+    REAL, ALLOCATABLE, SAVE, DIMENSION (:,:) :: f_addu ! var aux: champ de guidage
+    REAL, ALLOCATABLE, SAVE, DIMENSION (:,:) :: f_addv ! var aux: champ de guidage
+    ! Variables pour fonction Exner (P milieu couche)
+    REAL, ALLOCATABLE, SAVE, DIMENSION (:,:,:)    :: pk
+    REAL, ALLOCATABLE, SAVE, DIMENSION (:,:)        :: pks
+    REAL                               :: unskap
+    REAL, ALLOCATABLE, SAVE, DIMENSION (:,:)    :: p ! besoin si guide_P
+    ! Compteurs temps:
+    INTEGER, SAVE :: step_rea,count_no_rea,itau_test ! lecture guidage
+!$OMP THREADPRIVATE(step_rea,count_no_rea,itau_test)
+    REAL          :: ditau, dday_step
+    REAL          :: tau,reste ! position entre 2 etats de guidage
+    REAL, SAVE    :: factt ! pas de temps en fraction de jour
+!$OMP THREADPRIVATE(factt)
+
+    INTEGER       :: i,j,l
+    CHARACTER(LEN=20) :: modname="guide_main"
+
+!$OMP MASTER
+    ijbu=ij_begin ; ijeu=ij_end
+    jjbu=jj_begin ; jjeu=jj_end ; jjnu=jjeu-jjbu+1
+    ijbv=ij_begin ; ijev=ij_end
+    jjbv=jj_begin ; jjev=jj_end ; jjnv=jjev-jjbv+1
+    IF (pole_sud) THEN
+      ijeu=ij_end-iip1
+      ijev=ij_end-iip1
+      jjev=jj_end-1
+      jjnv=jjev-jjbv+1
+    ENDIF
+    IF (pole_nord) THEN
+      ijbu=ij_begin+iip1
+      ijbv=ij_begin
+    ENDIF
+!$OMP END MASTER
+!$OMP BARRIER
+
+!    PRINT *,'---> on rentre dans guide_main'
+!    CALL AllGather_Field(ucov,ip1jmp1,llm)
+!    CALL AllGather_Field(vcov,ip1jm,llm)
+!    CALL AllGather_Field(teta,ip1jmp1,llm)
+!    CALL AllGather_Field(ps,ip1jmp1,1)
+!    CALL AllGather_Field(q,ip1jmp1,llm)
+
+!-----------------------------------------------------------------------
+! Initialisations au premier passage
+!-----------------------------------------------------------------------
+
+    IF (first) THEN
+        first=.FALSE.
+!$OMP MASTER
+        ALLOCATE(f_addu(ijb_u:ije_u,llm) )
+        ALLOCATE(f_addv(ijb_v:ije_v,llm) )
+        ALLOCATE(pk(iip1,jjb_u:jje_u,llm)  )
+        ALLOCATE(pks(iip1,jjb_u:jje_u)  )
+        ALLOCATE(p(ijb_u:ije_u,llmp1) )
+        CALL guide_init
+!$OMP END MASTER
+!$OMP BARRIER
+        itau_test=1001
+        step_rea=1
+        count_no_rea=0
+! Calcul des constantes de rappel
+        factt=dtvr*iperiod/daysec
+!$OMP MASTER
+        call tau2alpha(3, iip1, jjb_v, jje_v, factt, tau_min_v, tau_max_v, alpha_v)
+        call tau2alpha(2, iip1, jjb_u, jje_u, factt, tau_min_u, tau_max_u, alpha_u)
+        call tau2alpha(1, iip1, jjb_u, jje_u, factt, tau_min_T, tau_max_T, alpha_T)
+        call tau2alpha(1, iip1, jjb_u, jje_u, factt, tau_min_P, tau_max_P, alpha_P)
+        call tau2alpha(1, iip1, jjb_u, jje_u, factt, tau_min_Q, tau_max_Q, alpha_Q)
+! correction de rappel dans couche limite
+        if (guide_BL) then
+             alpha_pcor(:)=1.
+        else
+            do l=1,llm
+                alpha_pcor(l)=(1.+tanh(((plim_guide_BL-presnivs(l))/preff)/0.05))/2.
+            enddo
+        endif
+!$OMP END MASTER
+!$OMP BARRIER
+! ini_anal: etat initial egal au guidage
+        IF (ini_anal) THEN
+            CALL guide_interp(ps,teta)
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+            DO l=1,llm
+              IF (guide_u) ucov(ijbu:ijeu,l)=ugui2(ijbu:ijeu,l)
+              IF (guide_v) vcov(ijbv:ijev,l)=ugui2(ijbv:ijev,l)
+              IF (guide_T) teta(ijbu:ijeu,l)=tgui2(ijbu:ijeu,l)
+              IF (guide_Q) q(ijbu:ijeu,l)=qgui2(ijbu:ijeu,l)
+            ENDDO
+
+            IF (guide_P) THEN
+!$OMP MASTER
+                ps(ijbu:ijeu)=psgui2(ijbu:ijeu)
+!$OMP END MASTER
+!$OMP BARRIER
+                CALL pression_loc(ijnb_u,ap,bp,ps,p)
+                CALL massdair_loc(p,masse)
+!$OMP BARRIER
+            ENDIF
+            RETURN
+        ENDIF
+
+    ENDIF !first
+
+!-----------------------------------------------------------------------
+! Lecture des fichiers de guidage ?
+!-----------------------------------------------------------------------
+    IF (iguide_read.NE.0) THEN
+      ditau=real(itau)
+      dday_step=real(day_step)
+      IF (iguide_read.LT.0) THEN
+          tau=ditau/dday_step/REAL(iguide_read)
+      ELSE
+          tau=REAL(iguide_read)*ditau/dday_step
+      ENDIF
+      reste=tau-AINT(tau)
+      IF (reste.EQ.0.) THEN
+          IF (itau_test.EQ.itau) THEN
+            write(*,*)trim(modname)//' second pass in advreel at itau=',&
+            itau
+            CALL abort_gcm("guide_loc_lod","stopped",1)
+          ELSE
+!$OMP MASTER
+              IF (guide_v) vnat1(:,jjbv:jjev,:)=vnat2(:,jjbv:jjev,:)
+              IF (guide_u) unat1(:,jjbu:jjeu,:)=unat2(:,jjbu:jjeu,:)
+              IF (guide_T) tnat1(:,jjbu:jjeu,:)=tnat2(:,jjbu:jjeu,:)
+              IF (guide_Q) qnat1(:,jjbu:jjeu,:)=qnat2(:,jjbu:jjeu,:)
+              IF (guide_plevs.EQ.2) pnat1(:,jjbu:jjeu,:)=pnat2(:,jjbu:jjeu,:)
+              IF (guide_P.OR.guide_plevs.EQ.1) psnat1(:,jjbu:jjeu)=psnat2(:,jjbu:jjeu)
+!$OMP END MASTER
+!$OMP BARRIER
+              step_rea=step_rea+1
+              itau_test=itau
+              if (is_master) then
+                write(*,*)trim(modname)//' Reading nudging files, step ',&
+                    step_rea,'after ',count_no_rea,' skips'
+              endif
+              IF (guide_2D) THEN
+!$OMP MASTER
+                  CALL guide_read2D(step_rea)
+!$OMP END MASTER
+!$OMP BARRIER
+              ELSE
+!$OMP MASTER
+                  CALL guide_read(step_rea)
+!$OMP END MASTER
+!$OMP BARRIER
+              ENDIF
+              count_no_rea=0
+          ENDIF
+      ELSE
+        count_no_rea=count_no_rea+1
+
+      ENDIF
+    ENDIF !iguide_read=0
+
+!-----------------------------------------------------------------------
+! Interpolation et conversion des champs de guidage
+!-----------------------------------------------------------------------
+    IF (MOD(itau,iguide_int).EQ.0) THEN
+        CALL guide_interp(ps,teta)
+    ENDIF
+! Repartition entre 2 etats de guidage
+    IF (iguide_read.NE.0) THEN
+        tau=reste
+    ELSE
+        tau=1.
+    ENDIF
+
+!    CALL WriteField_u('ucov_guide',ucov)
+!    CALL WriteField_v('vcov_guide',vcov)
+!    CALL WriteField_u('teta_guide',teta)
+!    CALL WriteField_u('masse_guide',masse)
+
+
+!-----------------------------------------------------------------------
+!   Ajout des champs de guidage
+!-----------------------------------------------------------------------
+! Sauvegarde du guidage?
+    f_out=((MOD(itau,iguide_sav).EQ.0).AND.guide_sav)
+    IF (f_out) THEN
+
+!$OMP BARRIER
+      CALL pression_loc(ijnb_u,ap,bp,ps,p)
+
+!$OMP BARRIER
+      if (pressure_exner) then
+      CALL exner_hyb_loc( ijnb_u, ps, p, pks, pk)
+      else
+        CALL exner_milieu_loc( ijnb_u, ps, p, pks, pk )
+      endif
+
+!$OMP BARRIER
+
+        unskap=1./kappa
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+        DO l = 1, llm
+            DO j=jjbu,jjeu
+                DO i =1, iip1
+                    p(i+(j-1)*iip1,l) = preff * ( pk(i,j,l)/cpp) ** unskap
+                ENDDO
+            ENDDO
+        ENDDO
+
+        CALL guide_out("SP",jjp1,llm,p(ijb_u:ije_u,1:llm),1.)
+    ENDIF
+
+    if (guide_u) then
+        if (guide_add) then
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+          DO l=1,llm
+           f_addu(ijbu:ijeu,l)=(1.-tau)*ugui1(ijbu:ijeu,l)+tau*ugui2(ijbu:ijeu,l)
+          ENDDO
+        else
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+          DO l=1,llm
+           f_addu(ijbu:ijeu,l)=(1.-tau)*ugui1(ijbu:ijeu,l)+tau*ugui2(ijbu:ijeu,l)-ucov(ijbu:ijeu,l)
+          ENDDO
+        endif
+
+!        CALL WriteField_u('f_addu',f_addu)
+
+        if (guide_zon) CALL guide_zonave_u(1,llm,f_addu)
+        CALL guide_addfield_u(llm,f_addu,alpha_u)
+        IF (f_out) CALL guide_out("ua",jjp1,llm,(1.-tau)*ugui1(ijb_u:ije_u,:)+tau*ugui2(ijb_u:ije_u,:),factt)
+        IF (f_out) CALL guide_out("u",jjp1,llm,ucov(ijb_u:ije_u,:),factt)
+        IF (f_out) THEN
+         ! Ehouarn: fill the gaps adequately...
+         IF (ijbu>ijb_u) f_addu(ijb_u:ijbu-1,:)=0
+         IF (ijeu<ije_u) f_addu(ijeu+1:ije_u,:)=0
+         CALL guide_out("ucov",jjp1,llm,f_addu(ijb_u:ije_u,:)/factt,factt)
+        ENDIF
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+        DO l=1,llm
+          ucov(ijbu:ijeu,l)=ucov(ijbu:ijeu,l)+f_addu(ijbu:ijeu,l)
+        ENDDO
+
+    endif
+
+    if (guide_T) then
+        if (guide_add) then
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+          DO l=1,llm
+            f_addu(ijbu:ijeu,l)=(1.-tau)*tgui1(ijbu:ijeu,l)+tau*tgui2(ijbu:ijeu,l)
+          ENDDO
+        else
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+          DO l=1,llm
+           f_addu(ijbu:ijeu,l)=(1.-tau)*tgui1(ijbu:ijeu,l)+tau*tgui2(ijbu:ijeu,l)-teta(ijbu:ijeu,l)
+          ENDDO
+        endif
+        if (guide_zon) CALL guide_zonave_u(2,llm,f_addu)
+        CALL guide_addfield_u(llm,f_addu,alpha_T)
+        IF (f_out) CALL guide_out("teta",jjp1,llm,f_addu(:,:)/factt,factt)
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+        DO l=1,llm
+          teta(ijbu:ijeu,l)=teta(ijbu:ijeu,l)+f_addu(ijbu:ijeu,l)
+        ENDDO
+    endif
+
+    if (guide_P) then
+        if (guide_add) then
+!$OMP MASTER
+            f_addu(ijbu:ijeu,1)=(1.-tau)*psgui1(ijbu:ijeu)+tau*psgui2(ijbu:ijeu)
+!$OMP END MASTER
+!$OMP BARRIER
+        else
+!$OMP MASTER
+            f_addu(ijbu:ijeu,1)=(1.-tau)*psgui1(ijbu:ijeu)+tau*psgui2(ijbu:ijeu)-ps(ijbu:ijeu)
+!$OMP END MASTER
+!$OMP BARRIER
+        endif
+        if (guide_zon) CALL guide_zonave_u(2,1,f_addu(ijb_u:ije_u,1))
+        CALL guide_addfield_u(1,f_addu(ijb_u:ije_u,1),alpha_P)
+!       IF (f_out) CALL guide_out("ps",jjp1,1,f_addu(ijb_u:ije_u,1)/factt,factt)
+!$OMP MASTER
+        ps(ijbu:ijeu)=ps(ijbu:ijeu)+f_addu(ijbu:ijeu,1)
+!$OMP END MASTER
+!$OMP BARRIER
+        CALL pression_loc(ijnb_u,ap,bp,ps,p)
+        CALL massdair_loc(p,masse)
+!$OMP BARRIER
+    endif
+
+    if (guide_Q) then
+        if (guide_add) then
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+          DO l=1,llm
+            f_addu(ijbu:ijeu,l)=(1.-tau)*qgui1(ijbu:ijeu,l)+tau*qgui2(ijbu:ijeu,l)
+          ENDDO
+        else
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+          DO l=1,llm
+            f_addu(ijbu:ijeu,l)=(1.-tau)*qgui1(ijbu:ijeu,l)+tau*qgui2(ijbu:ijeu,l)-q(ijbu:ijeu,l)
+          ENDDO
+        endif
+        if (guide_zon) CALL guide_zonave_u(2,llm,f_addu)
+        CALL guide_addfield_u(llm,f_addu,alpha_Q)
+        IF (f_out) CALL guide_out("q",jjp1,llm,f_addu(:,:)/factt,factt)
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+        DO l=1,llm
+          q(ijbu:ijeu,l)=q(ijbu:ijeu,l)+f_addu(ijbu:ijeu,l)
+        ENDDO
+    endif
+
+    if (guide_v) then
+        if (guide_add) then
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+          DO l=1,llm
+             f_addv(ijbv:ijev,l)=(1.-tau)*vgui1(ijbv:ijev,l)+tau*vgui2(ijbv:ijev,l)
+          ENDDO
+
+        else
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+          DO l=1,llm
+            f_addv(ijbv:ijev,l)=(1.-tau)*vgui1(ijbv:ijev,l)+tau*vgui2(ijbv:ijev,l)-vcov(ijbv:ijev,l)
+          ENDDO
+
+        endif
+
+        if (guide_zon) CALL guide_zonave_v(2,jjm,llm,f_addv(ijb_v:ije_v,:))
+
+        CALL guide_addfield_v(llm,f_addv(ijb_v:ije_v,:),alpha_v)
+        IF (f_out) CALL guide_out("v",jjm,llm,vcov(ijb_v:ije_v,:),factt)
+        IF (f_out) CALL guide_out("va",jjm,llm,(1.-tau)*vgui1(ijb_v:ije_v,:)+tau*vgui2(ijb_v:ije_v,:),factt)
+        IF (f_out) THEN
+          ! Ehouarn: Fill in the gaps adequately
+          IF (ijbv>ijb_v) f_addv(ijb_v:ijbv-1,:)=0
+          IF (ijev<ije_v) f_addv(ijev+1:ije_v,:)=0
+          CALL guide_out("vcov",jjm,llm,f_addv(ijb_v:ije_v,:)/factt,factt)
+        ENDIF
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+        DO l=1,llm
+          vcov(ijbv:ijev,l)=vcov(ijbv:ijev,l)+f_addv(ijbv:ijev,l)
+        ENDDO
+    endif
+
+  END SUBROUTINE guide_main
+
+
+  SUBROUTINE guide_addfield_u(vsize,field,alpha)
+! field1=a*field1+alpha*field2
+
+    IMPLICIT NONE
+    INCLUDE "dimensions.h"
+    INCLUDE "paramet.h"
+
+    ! input variables
+    INTEGER,                      INTENT(IN)    :: vsize
+    REAL, DIMENSION(ijb_u:ije_u),       INTENT(IN)    :: alpha
+    REAL, DIMENSION(ijb_u:ije_u,vsize), INTENT(INOUT) :: field
+
+    ! Local variables
+    INTEGER :: l
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO l=1,vsize
+      field(ijbu:ijeu,l)=alpha(ijbu:ijeu)*field(ijbu:ijeu,l)*alpha_pcor(l)
+    ENDDO
+
+  END SUBROUTINE guide_addfield_u
+
+
+  SUBROUTINE guide_addfield_v(vsize,field,alpha)
+! field1=a*field1+alpha*field2
+
+    IMPLICIT NONE
+    INCLUDE "dimensions.h"
+    INCLUDE "paramet.h"
+
+    ! input variables
+    INTEGER,                      INTENT(IN)    :: vsize
+    REAL, DIMENSION(ijb_v:ije_v),       INTENT(IN)    :: alpha
+    REAL, DIMENSION(ijb_v:ije_v,vsize), INTENT(INOUT) :: field
+
+    ! Local variables
+    INTEGER :: l
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO l=1,vsize
+      field(ijbv:ijev,l)=alpha(ijbv:ijev)*field(ijbv:ijev,l)*alpha_pcor(l)
+    ENDDO
+
+  END SUBROUTINE guide_addfield_v
+
+!=======================================================================
+
+  SUBROUTINE guide_zonave_u(typ,vsize,field)
+
+    USE comconst_mod, ONLY: pi
+
+    IMPLICIT NONE
+
+    INCLUDE "dimensions.h"
+    INCLUDE "paramet.h"
+    INCLUDE "comgeom.h"
+
+    ! input/output variables
+    INTEGER,                           INTENT(IN)    :: typ
+    INTEGER,                           INTENT(IN)    :: vsize
+    REAL, DIMENSION(ijb_u:ije_u,vsize), INTENT(INOUT) :: field
+
+    ! Local variables
+    LOGICAL, SAVE                :: first=.TRUE.
+!$OMP THREADPRIVATE(first)
+
+    INTEGER, DIMENSION (2), SAVE :: imin, imax ! averaging domain
+!$OMP THREADPRIVATE(imin,imax)
+    INTEGER                      :: i,j,l,ij
+    REAL, DIMENSION (iip1)       :: lond       ! longitude in Deg.
+    REAL, DIMENSION (jjb_u:jje_u,vsize):: fieldm     ! zon-averaged field
+
+    IF (first) THEN
+        first=.FALSE.
+!Compute domain for averaging
+        lond=rlonu*180./pi
+        imin(1)=1;imax(1)=iip1;
+        imin(2)=1;imax(2)=iip1;
+        IF (guide_reg) THEN
+            DO i=1,iim
+                IF (lond(i).LT.lon_min_g) imin(1)=i
+                IF (lond(i).LE.lon_max_g) imax(1)=i
+            ENDDO
+            lond=rlonv*180./pi
+            DO i=1,iim
+                IF (lond(i).LT.lon_min_g) imin(2)=i
+                IF (lond(i).LE.lon_max_g) imax(2)=i
+            ENDDO
+        ENDIF
+    ENDIF
+
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,vsize
+        fieldm(:,l)=0.
+      ! Compute zonal average
+
+!correction bug ici
+! ---> a verifier
+! ym         DO j=jjbv,jjev
+         DO j=jjbu,jjeu
+              DO i=imin(typ),imax(typ)
+                  ij=(j-1)*iip1+i
+                  fieldm(j,l)=fieldm(j,l)+field(ij,l)
+              ENDDO
+          ENDDO
+          fieldm(:,l)=fieldm(:,l)/REAL(imax(typ)-imin(typ)+1)
+    ! Compute forcing
+          DO j=jjbu,jjeu
+              DO i=1,iip1
+                  ij=(j-1)*iip1+i
+                  field(ij,l)=fieldm(j,l)
+              ENDDO
+          ENDDO
+      ENDDO
+
+  END SUBROUTINE guide_zonave_u
+
+
+  SUBROUTINE guide_zonave_v(typ,hsize,vsize,field)
+
+    USE comconst_mod, ONLY: pi
+
+    IMPLICIT NONE
+
+    INCLUDE "dimensions.h"
+    INCLUDE "paramet.h"
+    INCLUDE "comgeom.h"
+
+    ! input/output variables
+    INTEGER,                           INTENT(IN)    :: typ
+    INTEGER,                           INTENT(IN)    :: vsize
+    INTEGER,                           INTENT(IN)    :: hsize
+    REAL, DIMENSION(ijb_v:ije_v,vsize), INTENT(INOUT) :: field
+
+    ! Local variables
+    LOGICAL, SAVE                :: first=.TRUE.
+!$OMP THREADPRIVATE(first)
+    INTEGER, DIMENSION (2), SAVE :: imin, imax ! averaging domain
+!$OMP THREADPRIVATE(imin, imax)
+    INTEGER                      :: i,j,l,ij
+    REAL, DIMENSION (iip1)       :: lond       ! longitude in Deg.
+    REAL, DIMENSION (jjb_v:jjev,vsize):: fieldm     ! zon-averaged field
+
+    IF (first) THEN
+        first=.FALSE.
+!Compute domain for averaging
+        lond=rlonu*180./pi
+        imin(1)=1;imax(1)=iip1;
+        imin(2)=1;imax(2)=iip1;
+        IF (guide_reg) THEN
+            DO i=1,iim
+                IF (lond(i).LT.lon_min_g) imin(1)=i
+                IF (lond(i).LE.lon_max_g) imax(1)=i
+            ENDDO
+            lond=rlonv*180./pi
+            DO i=1,iim
+                IF (lond(i).LT.lon_min_g) imin(2)=i
+                IF (lond(i).LE.lon_max_g) imax(2)=i
+            ENDDO
+        ENDIF
+    ENDIF
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      DO l=1,vsize
+      ! Compute zonal average
+          fieldm(:,l)=0.
+          DO j=jjbv,jjev
+              DO i=imin(typ),imax(typ)
+                  ij=(j-1)*iip1+i
+                  fieldm(j,l)=fieldm(j,l)+field(ij,l)
+              ENDDO
+          ENDDO
+          fieldm(:,l)=fieldm(:,l)/REAL(imax(typ)-imin(typ)+1)
+    ! Compute forcing
+          DO j=jjbv,jjev
+              DO i=1,iip1
+                  ij=(j-1)*iip1+i
+                  field(ij,l)=fieldm(j,l)
+              ENDDO
+          ENDDO
+      ENDDO
+
+
+  END SUBROUTINE guide_zonave_v
+
+!=======================================================================
+  SUBROUTINE guide_interp(psi,teta)
+    use exner_hyb_loc_m, only: exner_hyb_loc
+    use exner_milieu_loc_m, only: exner_milieu_loc
+  USE parallel_lmdz
+  USE mod_hallo
+  USE Bands
+  USE comconst_mod, ONLY: cpp, kappa
+  USE comvert_mod, ONLY: preff, pressure_exner, bp, ap, disvert_type
+  IMPLICIT NONE
+
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom2.h"
+
+  REAL, DIMENSION (iip1,jjb_u:jje_u),     INTENT(IN) :: psi ! Psol gcm
+  REAL, DIMENSION (iip1,jjb_u:jje_u,llm), INTENT(IN) :: teta ! Temp. Pot. gcm
+
+  LOGICAL, SAVE                      :: first=.TRUE.
+!$OMP THREADPRIVATE(first)
+  ! Variables pour niveaux pression:
+  REAL, ALLOCATABLE, SAVE, DIMENSION (:,:,:) :: plnc1,plnc2 !niveaux pression guidage
+  REAL, ALLOCATABLE, SAVE,DIMENSION (:,:,:)    :: plunc,plsnc !niveaux pression modele
+  REAL, ALLOCATABLE, SAVE,DIMENSION (:,:,:)     :: plvnc       !niveaux pression modele
+  REAL, ALLOCATABLE, SAVE,DIMENSION (:,:,:)  :: p           ! pression intercouches
+  REAL, ALLOCATABLE, SAVE,DIMENSION (:,:,:)    :: pls, pext   ! var intermediaire
+  REAL, ALLOCATABLE, SAVE,DIMENSION (:,:,:)    :: pbarx
+  REAL, ALLOCATABLE, SAVE,DIMENSION (:,:,:)     :: pbary
+  ! Variables pour fonction Exner (P milieu couche)
+  REAL, ALLOCATABLE, SAVE,DIMENSION (:,:,:)    :: pk
+  REAL ,ALLOCATABLE, SAVE, DIMENSION (:,:)        :: pks
+  REAL                               :: unskap
+  ! Pression de vapeur saturante
+  REAL, ALLOCATABLE, SAVE,DIMENSION (:,:)      :: qsat
+  !Variables intermediaires interpolation
+  REAL, ALLOCATABLE, SAVE,DIMENSION (:,:,:)    :: zu1,zu2
+  REAL, ALLOCATABLE, SAVE,DIMENSION (:,:,:)     :: zv1,zv2
+
+  INTEGER                            :: i,j,l,ij
+  CHARACTER(LEN=20),PARAMETER :: modname="guide_interp"
+  TYPE(Request),SAVE :: Req
+!$OMP THREADPRIVATE(Req)
+
+    if (is_master) write(*,*)trim(modname)//': interpolate nudging variables'
+! -----------------------------------------------------------------
+! Calcul des niveaux de pression champs guidage (pour T et Q)
+! -----------------------------------------------------------------
+    IF (first) THEN
+!$OMP MASTER
+      ALLOCATE(plnc1(iip1,jjb_u:jje_u,nlevnc) )
+      ALLOCATE(plnc2(iip1,jjb_u:jje_u,nlevnc) )
+      ALLOCATE(plunc(iip1,jjb_u:jje_u,llm) )
+      ALLOCATE(plsnc(iip1,jjb_u:jje_u,llm) )
+      ALLOCATE(plvnc(iip1,jjb_v:jje_v,llm) )
+      ALLOCATE(p(iip1,jjb_u:jje_u,llmp1) )
+      ALLOCATE(pls(iip1,jjb_u:jje_u,llm) )
+      ALLOCATE(pext(iip1,jjb_u:jje_u,llm) )
+      ALLOCATE(pbarx(iip1,jjb_u:jje_u,llm) )
+      ALLOCATE(pbary(iip1,jjb_v:jje_v,llm) )
+      ALLOCATE(pk(iip1,jjb_u:jje_u,llm) )
+      ALLOCATE(pks (iip1,jjb_u:jje_u) )
+      ALLOCATE(qsat(ijb_u:ije_u,llm) )
+      ALLOCATE(zu1(iip1,jjb_u:jje_u,llm) )
+      ALLOCATE(zu2(iip1,jjb_u:jje_u,llm) )
+      ALLOCATE(zv1(iip1,jjb_v:jje_v,llm) )
+      ALLOCATE(zv2(iip1,jjb_v:jje_v,llm) )
+!$OMP END MASTER
+!$OMP BARRIER
+    ENDIF
+
+
+
+
+    IF (guide_plevs.EQ.0) THEN
+!$OMP DO
+        DO l=1,nlevnc
+            DO j=jjbu,jjeu
+                DO i=1,iip1
+                    plnc2(i,j,l)=apnc(l)
+                    plnc1(i,j,l)=apnc(l)
+               ENDDO
+            ENDDO
+        ENDDO
+    ENDIF
+
+    if (first) then
+        first=.FALSE.
+!$OMP MASTER
+        write(*,*)trim(modname)//' : check vertical level order'
+        write(*,*)trim(modname)//' LMDZ :'
+        do l=1,llm
+          write(*,*)trim(modname)//' PL(',l,')=',(ap(l)+ap(l+1))/2. &
+                  +psi(1,jjeu)*(bp(l)+bp(l+1))/2.
+        enddo
+        write(*,*)trim(modname)//' nudging file :'
+        SELECT CASE (guide_plevs)
+        CASE (0)
+            do l=1,nlevnc
+              write(*,*)trim(modname)//' PL(',l,')=',plnc2(1,jjbu,l)
+            enddo
+        CASE (1)
+            DO l=1,nlevnc
+              write(*,*)trim(modname)//' PL(',l,')=',&
+                        apnc(l)+bpnc(l)*psnat2(1,jjbu)
+            ENDDO
+        CASE (2)
+            do l=1,nlevnc
+              write(*,*)trim(modname)//' PL(',l,')=',pnat2(1,jjbu,l)
+            enddo
+        END SELECT
+        write(*,*)trim(modname)//' invert ordering: invert_p=',invert_p
+        if (guide_u) then
+            do l=1,nlevnc
+              write(*,*)trim(modname)//' U(',l,')=',unat2(1,jjbu,l)
+            enddo
+        endif
+        if (guide_T) then
+            do l=1,nlevnc
+              write(*,*)trim(modname)//' T(',l,')=',tnat2(1,jjbu,l)
+            enddo
+        endif
+!$OMP END MASTER
+    endif ! of if (first)
+
+    if (guide_plevs /= 1 .or. guide_t .and. .not. guide_teta &
+         .or. guide_q .and. guide_hr) then
+       CALL pression_loc( ijnb_u, ap, bp, psi, p )
+       if (disvert_type==1) then
+          CALL exner_hyb_loc(ijnb_u,psi,p,pks,pk)
+       else ! we assume that we are in the disvert_type==2 case
+          CALL exner_milieu_loc(ijnb_u,psi,p,pks,pk)
+       endif
+    end if
+
+! -----------------------------------------------------------------
+! Calcul niveaux pression modele
+! -----------------------------------------------------------------
+
+!    ....  Calcul de pls , pression au milieu des couches ,en Pascals
+    IF (guide_plevs.EQ.1) THEN
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+        DO l=1,llm
+            DO j=jjbu,jjeu
+                DO i =1, iip1
+                    pls(i,j,l)=(ap(l)+ap(l+1))/2.+psi(i,j)*(bp(l)+bp(l+1))/2.
+                ENDDO
+            ENDDO
+        ENDDO
+    ELSE
+        unskap=1./kappa
+!$OMP BARRIER
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+   DO l = 1, llm
+       DO j=jjbu,jjeu
+           DO i =1, iip1
+               pls(i,j,l) = preff * ( pk(i,j,l)/cpp) ** unskap
+           ENDDO
+       ENDDO
+   ENDDO
+    ENDIF
+
+!   calcul des pressions pour les grilles u et v
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    do l=1,llm
+        do j=jjbu,jjeu
+            do i=1,iip1
+                pext(i,j,l)=pls(i,j,l)*aire(i,j)
+            enddo
+        enddo
+    enddo
+
+     CALL Register_Hallo_u(pext,llm,1,2,2,1,Req)
+     CALL SendRequest(Req)
+!$OMP BARRIER
+     CALL WaitRequest(Req)
+!$OMP BARRIER
+
+    call massbar_loc(pext, pbarx, pbary )
+!$OMP BARRIER
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    do l=1,llm
+        do j=jjbu,jjeu
+            do i=1,iip1
+                plunc(i,j,l)=pbarx(i,j,l)/aireu(i,j)
+                plsnc(i,j,l)=pls(i,j,l)
+            enddo
+        enddo
+    enddo
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    do l=1,llm
+        do j=jjbv,jjev
+            do i=1,iip1
+                plvnc(i,j,l)=pbary(i,j,l)/airev(i,j)
+            enddo
+        enddo
+    enddo
+
+! -----------------------------------------------------------------
+! Interpolation verticale champs guidage sur niveaux modele
+! Conversion en variables gcm (ucov, vcov...)
+! -----------------------------------------------------------------
+    if (guide_P) then
+!$OMP MASTER
+        do j=jjbu,jjeu
+            do i=1,iim
+                ij=(j-1)*iip1+i
+                psgui1(ij)=psnat1(i,j)
+                psgui2(ij)=psnat2(i,j)
+            enddo
+            psgui1(iip1*j)=psnat1(1,j)
+            psgui2(iip1*j)=psnat2(1,j)
+        enddo
+!$OMP END MASTER
+!$OMP BARRIER
+    endif
+
+    IF (guide_T) THEN
+        ! Calcul des nouvelles valeurs des niveaux de pression du guidage
+        IF (guide_plevs.EQ.1) THEN
+!$OMP DO
+            DO l=1,nlevnc
+                DO j=jjbu,jjeu
+                    DO i=1,iip1
+                        plnc2(i,j,l)=apnc(l)+bpnc(l)*psnat2(i,j)
+                        plnc1(i,j,l)=apnc(l)+bpnc(l)*psnat1(i,j)
+                    ENDDO
+                ENDDO
+            ENDDO
+        ELSE IF (guide_plevs.EQ.2) THEN
+!$OMP DO
+            DO l=1,nlevnc
+                DO j=jjbu,jjeu
+                    DO i=1,iip1
+                        plnc2(i,j,l)=pnat2(i,j,l)
+                        plnc1(i,j,l)=pnat1(i,j,l)
+                    ENDDO
+                ENDDO
+            ENDDO
+        ENDIF
+
+        ! Interpolation verticale
+!$OMP MASTER
+        CALL pres2lev(tnat1(:,jjbu:jjeu,:),zu1(:,jjbu:jjeu,:),nlevnc,llm,           &
+                    plnc1(:,jjbu:jjeu,:),plsnc(:,jjbu:jjeu,:),iip1,jjnu,invert_p)
+        CALL pres2lev(tnat2(:,jjbu:jjeu,:),zu2(:,jjbu:jjeu,:),nlevnc,llm,           &
+                    plnc2(:,jjbu:jjeu,:),plsnc(:,jjbu:jjeu,:),iip1,jjnu,invert_p)
+!$OMP END MASTER
+!$OMP BARRIER
+        ! Conversion en variables GCM
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+        do l=1,llm
+            do j=jjbu,jjeu
+                IF (guide_teta) THEN
+                    do i=1,iim
+                        ij=(j-1)*iip1+i
+                        tgui1(ij,l)=zu1(i,j,l)
+                        tgui2(ij,l)=zu2(i,j,l)
+                    enddo
+                ELSE
+                    do i=1,iim
+                        ij=(j-1)*iip1+i
+                        tgui1(ij,l)=zu1(i,j,l)*cpp/pk(i,j,l)
+                        tgui2(ij,l)=zu2(i,j,l)*cpp/pk(i,j,l)
+                    enddo
+                ENDIF
+                tgui1(j*iip1,l)=tgui1((j-1)*iip1+1,l)
+                tgui2(j*iip1,l)=tgui2((j-1)*iip1+1,l)
+            enddo
+            if (pole_nord) then
+              do i=1,iip1
+                tgui1(i,l)=tgui1(1,l)
+                tgui2(i,l)=tgui2(1,l)
+              enddo
+            endif
+            if (pole_sud) then
+              do i=1,iip1
+                tgui1(ip1jm+i,l)=tgui1(ip1jm+1,l)
+                tgui2(ip1jm+i,l)=tgui2(ip1jm+1,l)
+              enddo
+           endif
+        enddo
+    ENDIF
+
+    IF (guide_Q) THEN
+        ! Calcul des nouvelles valeurs des niveaux de pression du guidage
+        IF (guide_plevs.EQ.1) THEN
+!$OMP DO
+            DO l=1,nlevnc
+                DO j=jjbu,jjeu
+                    DO i=1,iip1
+                        plnc2(i,j,l)=apnc(l)+bpnc(l)*psnat2(i,j)
+                        plnc1(i,j,l)=apnc(l)+bpnc(l)*psnat1(i,j)
+                    ENDDO
+                ENDDO
+            ENDDO
+        ELSE IF (guide_plevs.EQ.2) THEN
+!$OMP DO
+            DO l=1,nlevnc
+                DO j=jjbu,jjeu
+                    DO i=1,iip1
+                        plnc2(i,j,l)=pnat2(i,j,l)
+                        plnc1(i,j,l)=pnat1(i,j,l)
+                    ENDDO
+                ENDDO
+            ENDDO
+        ENDIF
+
+        ! Interpolation verticale
+!$OMP MASTER
+        CALL pres2lev(qnat1(:,jjbu:jjeu,:),zu1(:,jjbu:jjeu,:),nlevnc,llm,             &
+                      plnc1(:,jjbu:jjeu,:),plsnc(:,jjbu:jjeu,:),iip1,jjnu,invert_p)
+        CALL pres2lev(qnat2(:,jjbu:jjeu,:),zu2(:,jjbu:jjeu,:),nlevnc,llm,             &
+                      plnc2(:,jjbu:jjeu,:),plsnc(:,jjbu:jjeu,:),iip1,jjnu,invert_p)
+!$OMP END MASTER
+!$OMP BARRIER
+
+        ! Conversion en variables GCM
+        ! On suppose qu'on a la bonne variable dans le fichier de guidage:
+        ! Hum.Rel si guide_hr, Hum.Spec. sinon.
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+        do l=1,llm
+            do j=jjbu,jjeu
+                do i=1,iim
+                    ij=(j-1)*iip1+i
+                    qgui1(ij,l)=zu1(i,j,l)
+                    qgui2(ij,l)=zu2(i,j,l)
+                enddo
+                qgui1(j*iip1,l)=qgui1((j-1)*iip1+1,l)
+                qgui2(j*iip1,l)=qgui2((j-1)*iip1+1,l)
+            enddo
+            if (pole_nord) then
+              do i=1,iip1
+                qgui1(i,l)=qgui1(1,l)
+                qgui2(i,l)=qgui2(1,l)
+              enddo
+            endif
+            if (pole_sud) then
+              do i=1,iip1
+                qgui1(ip1jm+i,l)=qgui1(ip1jm+1,l)
+                qgui2(ip1jm+i,l)=qgui2(ip1jm+1,l)
+              enddo
+            endif
+        enddo
+        IF (guide_hr) THEN
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+          do l=1,llm
+            CALL q_sat(iip1*jjnu,teta(:,jjbu:jjeu,l)*pk(:,jjbu:jjeu,l)/cpp,       &
+                       plsnc(:,jjbu:jjeu,l),qsat(ijbu:ijeu,l))
+            qgui1(ijbu:ijeu,l)=qgui1(ijbu:ijeu,l)*qsat(ijbu:ijeu,l)*0.01 !hum. rel. en %
+            qgui2(ijbu:ijeu,l)=qgui2(ijbu:ijeu,l)*qsat(ijbu:ijeu,l)*0.01
+          enddo
+
+        ENDIF
+    ENDIF
+
+    IF (guide_u) THEN
+        ! Calcul des nouvelles valeurs des niveaux de pression du guidage
+        IF (guide_plevs.EQ.1) THEN
+!$OMP DO
+            DO l=1,nlevnc
+                DO j=jjbu,jjeu
+                    DO i=1,iim
+                        plnc2(i,j,l)=apnc(l)+bpnc(l)*(psnat2(i,j)*aire(i,j)*alpha1p2(i,j) &
+                       &           +psnat2(i+1,j)*aire(i+1,j)*alpha3p4(i+1,j))/aireu(i,j)
+                        plnc1(i,j,l)=apnc(l)+bpnc(l)*(psnat1(i,j)*aire(i,j)*alpha1p2(i,j) &
+                       &           +psnat1(i+1,j)*aire(i+1,j)*alpha3p4(i+1,j))/aireu(i,j)
+                    ENDDO
+                    plnc2(iip1,j,l)=plnc2(1,j,l)
+                    plnc1(iip1,j,l)=plnc1(1,j,l)
+                ENDDO
+            ENDDO
+        ELSE IF (guide_plevs.EQ.2) THEN
+!$OMP DO
+            DO l=1,nlevnc
+                DO j=jjbu,jjeu
+                    DO i=1,iim
+                        plnc2(i,j,l)=(pnat2(i,j,l)*aire(i,j)*alpha1p2(i,j) &
+                       & +pnat2(i+1,j,l)*aire(i,j)*alpha3p4(i+1,j))/aireu(i,j)
+                        plnc1(i,j,l)=(pnat1(i,j,l)*aire(i,j)*alpha1p2(i,j) &
+                       & +pnat1(i+1,j,l)*aire(i,j)*alpha3p4(i+1,j))/aireu(i,j)
+                    ENDDO
+                    plnc2(iip1,j,l)=plnc2(1,j,l)
+                    plnc1(iip1,j,l)=plnc1(1,j,l)
+                ENDDO
+            ENDDO
+        ENDIF
+
+        ! Interpolation verticale
+!$OMP MASTER
+        CALL pres2lev(unat1(:,jjbu:jjeu,:),zu1(:,jjbu:jjeu,:),nlevnc,llm,            &
+                      plnc1(:,jjbu:jjeu,:),plunc(:,jjbu:jjeu,:),iip1,jjnu,invert_p)
+        CALL pres2lev(unat2(:,jjbu:jjeu,:),zu2(:,jjbu:jjeu,:),nlevnc,llm,            &
+                      plnc2(:,jjbu:jjeu,:),plunc(:,jjbu:jjeu,:),iip1,jjnu,invert_p)
+!$OMP END MASTER
+!$OMP BARRIER
+
+        ! Conversion en variables GCM
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+        do l=1,llm
+            do j=jjbu,jjeu
+                do i=1,iim
+                    ij=(j-1)*iip1+i
+                    ugui1(ij,l)=zu1(i,j,l)*cu(i,j)
+                    ugui2(ij,l)=zu2(i,j,l)*cu(i,j)
+                enddo
+                ugui1(j*iip1,l)=ugui1((j-1)*iip1+1,l)
+                ugui2(j*iip1,l)=ugui2((j-1)*iip1+1,l)
+            enddo
+            if (pole_nord) then
+              do i=1,iip1
+                ugui1(i,l)=0.
+                ugui2(i,l)=0.
+              enddo
+            endif
+            if (pole_sud) then
+              do i=1,iip1
+                ugui1(ip1jm+i,l)=0.
+                ugui2(ip1jm+i,l)=0.
+              enddo
+            endif
+        enddo
+    ENDIF
+
+    IF (guide_v) THEN
+        ! Calcul des nouvelles valeurs des niveaux de pression du guidage
+        IF (guide_plevs.EQ.1) THEN
+         CALL Register_Hallo_u(psnat1,1,1,2,2,1,Req)
+         CALL Register_Hallo_u(psnat2,1,1,2,2,1,Req)
+         CALL SendRequest(Req)
+!$OMP BARRIER
+         CALL WaitRequest(Req)
+!$OMP BARRIER
+!$OMP DO
+            DO l=1,nlevnc
+                DO j=jjbv,jjev
+                    DO i=1,iip1
+                        plnc2(i,j,l)=apnc(l)+bpnc(l)*(psnat2(i,j)*aire(i,j)*alpha2p3(i,j) &
+                       &           +psnat2(i,j+1)*aire(i,j+1)*alpha1p4(i,j+1))/airev(i,j)
+                        plnc1(i,j,l)=apnc(l)+bpnc(l)*(psnat1(i,j)*aire(i,j)*alpha2p3(i,j) &
+                       &           +psnat1(i,j+1)*aire(i,j+1)*alpha1p4(i,j+1))/airev(i,j)
+                    ENDDO
+                ENDDO
+            ENDDO
+        ELSE IF (guide_plevs.EQ.2) THEN
+         CALL Register_Hallo_u(pnat1,llm,1,2,2,1,Req)
+         CALL Register_Hallo_u(pnat2,llm,1,2,2,1,Req)
+         CALL SendRequest(Req)
+!$OMP BARRIER
+         CALL WaitRequest(Req)
+!$OMP BARRIER
+!$OMP DO
+            DO l=1,nlevnc
+                DO j=jjbv,jjev
+                    DO i=1,iip1
+                        plnc2(i,j,l)=(pnat2(i,j,l)*aire(i,j)*alpha2p3(i,j) &
+                       & +pnat2(i,j+1,l)*aire(i,j)*alpha1p4(i,j+1))/airev(i,j)
+                        plnc1(i,j,l)=(pnat1(i,j,l)*aire(i,j)*alpha2p3(i,j) &
+                       & +pnat1(i,j+1,l)*aire(i,j)*alpha1p4(i,j+1))/airev(i,j)
+                    ENDDO
+                ENDDO
+            ENDDO
+        ENDIF
+        ! Interpolation verticale
+
+!$OMP MASTER
+        CALL pres2lev(vnat1(:,jjbv:jjev,:),zv1(:,jjbv:jjev,:),nlevnc,llm,             &
+                      plnc1(:,jjbv:jjev,:),plvnc(:,jjbv:jjev,:),iip1,jjnv,invert_p)
+        CALL pres2lev(vnat2(:,jjbv:jjev,:),zv2(:,jjbv:jjev,:),nlevnc,llm,             &
+                      plnc2(:,jjbv:jjev,:),plvnc(:,jjbv:jjev,:),iip1,jjnv,invert_p)
+!$OMP END MASTER
+!$OMP BARRIER
+        ! Conversion en variables GCM
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+        do l=1,llm
+            do j=jjbv,jjev
+                do i=1,iim
+                    ij=(j-1)*iip1+i
+                    vgui1(ij,l)=zv1(i,j,l)*cv(i,j)
+                    vgui2(ij,l)=zv2(i,j,l)*cv(i,j)
+                enddo
+                vgui1(j*iip1,l)=vgui1((j-1)*iip1+1,l)
+                vgui2(j*iip1,l)=vgui2((j-1)*iip1+1,l)
+            enddo
+        enddo
+    ENDIF
+
+
+  END SUBROUTINE guide_interp
+
+!=======================================================================
+  SUBROUTINE tau2alpha(typ,pim,jjb,jje,factt,taumin,taumax,alpha)
+
+! Calcul des constantes de rappel alpha (=1/tau)
+
+    use comconst_mod, only: pi
+    use serre_mod, only: clat, clon, grossismx, grossismy
+
+    implicit none
+
+    include "dimensions.h"
+    include "paramet.h"
+    include "comgeom2.h"
+
+! input arguments :
+    INTEGER, INTENT(IN) :: typ    ! u(2),v(3), ou scalaire(1)
+    INTEGER, INTENT(IN) :: pim ! dimensions en lon
+    INTEGER, INTENT(IN) :: jjb,jje ! dimensions en lat
+    REAL, INTENT(IN)    :: factt   ! pas de temps en fraction de jour
+    REAL, INTENT(IN)    :: taumin,taumax
+! output arguments:
+    REAL, DIMENSION(pim,jjb:jje), INTENT(OUT) :: alpha
+
+!  local variables:
+    LOGICAL, SAVE               :: first=.TRUE.
+    REAL, SAVE                  :: gamma,dxdy_min,dxdy_max
+    REAL, DIMENSION (iip1,jjp1) :: zdx,zdy
+    REAL, DIMENSION (iip1,jjp1) :: dxdys,dxdyu
+    REAL, DIMENSION (iip1,jjm)  :: dxdyv
+    real dxdy_
+    real zlat,zlon
+    real alphamin,alphamax,xi
+    integer i,j,ilon,ilat
+    character(len=20),parameter :: modname="tau2alpha"
+
+
+    alphamin=factt/taumax
+    alphamax=factt/taumin
+    IF (guide_reg.OR.guide_add) THEN
+        alpha=alphamax
+!-----------------------------------------------------------------------
+! guide_reg: alpha=alpha_min dans region, 0. sinon.
+!-----------------------------------------------------------------------
+        IF (guide_reg) THEN
+            do j=jjb,jje
+                do i=1,pim
+                    if (typ.eq.2) then
+                       zlat=rlatu(j)*180./pi
+                       zlon=rlonu(i)*180./pi
+                    elseif (typ.eq.1) then
+                       zlat=rlatu(j)*180./pi
+                       zlon=rlonv(i)*180./pi
+                    elseif (typ.eq.3) then
+                       zlat=rlatv(j)*180./pi
+                       zlon=rlonv(i)*180./pi
+                    endif
+                    alpha(i,j)=alphamax/16.* &
+                              (1.+tanh((zlat-lat_min_g)/tau_lat))* &
+                              (1.+tanh((lat_max_g-zlat)/tau_lat))* &
+                              (1.+tanh((zlon-lon_min_g)/tau_lon))* &
+                              (1.+tanh((lon_max_g-zlon)/tau_lon))
+                enddo
+            enddo
+        ENDIF
+    ELSE
+!-----------------------------------------------------------------------
+! Sinon, alpha varie entre alpha_min et alpha_max suivant le zoom.
+!-----------------------------------------------------------------------
+!Calcul de l'aire des mailles
+        do j=2,jjm
+            do i=2,iip1
+               zdx(i,j)=0.5*(cu(i-1,j)+cu(i,j))/cos(rlatu(j))
+            enddo
+            zdx(1,j)=zdx(iip1,j)
+        enddo
+        do j=2,jjm
+            do i=1,iip1
+               zdy(i,j)=0.5*(cv(i,j-1)+cv(i,j))
+            enddo
+        enddo
+        do i=1,iip1
+            zdx(i,1)=zdx(i,2)
+            zdx(i,jjp1)=zdx(i,jjm)
+            zdy(i,1)=zdy(i,2)
+            zdy(i,jjp1)=zdy(i,jjm)
+        enddo
+        do j=1,jjp1
+            do i=1,iip1
+               dxdys(i,j)=sqrt(zdx(i,j)*zdx(i,j)+zdy(i,j)*zdy(i,j))
+            enddo
+        enddo
+        IF (typ.EQ.2) THEN
+            do j=1,jjp1
+                do i=1,iim
+                   dxdyu(i,j)=0.5*(dxdys(i,j)+dxdys(i+1,j))
+                enddo
+                dxdyu(iip1,j)=dxdyu(1,j)
+            enddo
+        ENDIF
+        IF (typ.EQ.3) THEN
+            do j=1,jjm
+                do i=1,iip1
+                   dxdyv(i,j)=0.5*(dxdys(i,j)+dxdys(i,j+1))
+                enddo
+            enddo
+        ENDIF
+! Premier appel: calcul des aires min et max et de gamma.
+        IF (first) THEN
+            first=.FALSE.
+            ! coordonnees du centre du zoom
+            CALL coordij(clon,clat,ilon,ilat)
+            ! aire de la maille au centre du zoom
+            dxdy_min=dxdys(ilon,ilat)
+            ! dxdy maximale de la maille
+            dxdy_max=0.
+            do j=1,jjp1
+                do i=1,iip1
+                     dxdy_max=max(dxdy_max,dxdys(i,j))
+                enddo
+            enddo
+            ! Calcul de gamma
+            if (abs(grossismx-1.).lt.0.1.or.abs(grossismy-1.).lt.0.1) then
+              write(*,*)trim(modname)//' ATTENTION modele peu zoome'
+              write(*,*)trim(modname)//' ATTENTION on prend une constante de guidage cste'
+              gamma=0.
+            else
+              gamma=(dxdy_max-2.*dxdy_min)/(dxdy_max-dxdy_min)
+              write(*,*)trim(modname)//' gamma=',gamma
+              if (gamma.lt.1.e-5) then
+                write(*,*)trim(modname)//' gamma =',gamma,'<1e-5'
+                CALL abort_gcm("guide_loc_mod","stopped",1)
+              endif
+              gamma=log(0.5)/log(gamma)
+              if (gamma4) then
+                gamma=min(gamma,4.)
+              endif
+              write(*,*)trim(modname)//' gamma=',gamma
+            endif
+        ENDIF !first
+
+        do j=jjb,jje
+            do i=1,pim
+                if (typ.eq.1) then
+                   dxdy_=dxdys(i,j)
+                   zlat=rlatu(j)*180./pi
+                elseif (typ.eq.2) then
+                   dxdy_=dxdyu(i,j)
+                   zlat=rlatu(j)*180./pi
+                elseif (typ.eq.3) then
+                   dxdy_=dxdyv(i,j)
+                   zlat=rlatv(j)*180./pi
+                endif
+                if (abs(grossismx-1.).lt.0.1.or.abs(grossismy-1.).lt.0.1) then
+                ! pour une grille reguliere, xi=xxx**0=1 -> alpha=alphamin
+                    alpha(i,j)=alphamin
+                else
+                    xi=((dxdy_max-dxdy_)/(dxdy_max-dxdy_min))**gamma
+                    xi=min(xi,1.)
+                    if(lat_min_g.le.zlat .and. zlat.le.lat_max_g) then
+                        alpha(i,j)=xi*alphamin+(1.-xi)*alphamax
+                    else
+                        alpha(i,j)=0.
+                    endif
+                endif
+            enddo
+        enddo
+    ENDIF ! guide_reg
+
+    if (.not. guide_add) alpha = 1. - exp(- alpha)
+
+  END SUBROUTINE tau2alpha
+
+!=======================================================================
+  SUBROUTINE guide_read(timestep)
+    USE netcdf, ONLY: nf90_put_var
+    IMPLICIT NONE
+
+    include "netcdf.inc"
+    include "dimensions.h"
+    include "paramet.h"
+
+    INTEGER, INTENT(IN)   :: timestep
+
+    LOGICAL, SAVE         :: first=.TRUE.
+! Identification fichiers et variables NetCDF:
+    INTEGER, SAVE         :: ncidu,varidu,ncidv,varidv,ncidp,varidp
+    INTEGER, SAVE         :: ncidQ,varidQ,ncidt,varidt,ncidps,varidps
+    INTEGER               :: ncidpl,varidpl,varidap,varidbp,dimid,lendim
+! Variables auxiliaires NetCDF:
+    INTEGER, DIMENSION(4) :: start,count
+    INTEGER               :: status,rcode
+    CHARACTER (len = 80)   :: abort_message
+    CHARACTER (len = 20)   :: modname = 'guide_read'
+    CHARACTER (len = 20)   :: namedim
+    abort_message='pb in guide_read'
+
+! -----------------------------------------------------------------
+! Premier appel: initialisation de la lecture des fichiers
+! -----------------------------------------------------------------
+    if (first) then
+         ncidpl=-99
+         write(*,*),trim(modname)//': opening nudging files '
+! Ap et Bp si Niveaux de pression hybrides
+         if (guide_plevs.EQ.1) then
+             write(*,*),trim(modname)//' Reading nudging on model levels'
+             rcode = nf90_open('apbp.nc', nf90_nowrite, ncidpl)
+             IF (rcode.NE.NF_NOERR) THEN
+              abort_message='Nudging: error -> no file apbp.nc'
+              CALL abort_gcm(modname,abort_message,1)
+             ENDIF
+             rcode = nf90_inq_varid(ncidpl, 'AP', varidap)
+             IF (rcode.NE.NF_NOERR) THEN
+              abort_message='Nudging: error -> no AP variable in file apbp.nc'
+              CALL abort_gcm(modname,abort_message,1)
+             ENDIF
+             rcode = nf90_inq_varid(ncidpl, 'BP', varidbp)
+             IF (rcode.NE.NF_NOERR) THEN
+              abort_message='Nudging: error -> no BP variable in file apbp.nc'
+              CALL abort_gcm(modname,abort_message,1)
+             ENDIF
+             write(*,*),trim(modname)//' ncidpl,varidap',ncidpl,varidap
+         endif
+
+! Pression si guidage sur niveaux P variables
+         if (guide_plevs.EQ.2) then
+             rcode = nf90_open('P.nc', nf90_nowrite, ncidp)
+             IF (rcode.NE.NF_NOERR) THEN
+              abort_message='Nudging: error -> no file P.nc'
+              CALL abort_gcm(modname,abort_message,1)
+             ENDIF
+             rcode = nf90_inq_varid(ncidp, 'PRES', varidp)
+             IF (rcode.NE.NF_NOERR) THEN
+              abort_message='Nudging: error -> no PRES variable in file P.nc'
+              CALL abort_gcm(modname,abort_message,1)
+             ENDIF
+             write(*,*),trim(modname)//' ncidp,varidp',ncidp,varidp
+             if (ncidpl.eq.-99) ncidpl=ncidp
+         endif
+
+! Vent zonal
+         if (guide_u) then
+             rcode = nf90_open('u.nc', nf90_nowrite, ncidu)
+             IF (rcode.NE.NF_NOERR) THEN
+              abort_message='Nudging: error -> no file u.nc'
+              CALL abort_gcm(modname,abort_message,1)
+             ENDIF
+             rcode = nf90_inq_varid(ncidu, 'UWND', varidu)
+             IF (rcode.NE.NF_NOERR) THEN
+              abort_message='Nudging: error -> no UWND variable in file u.nc'
+              CALL abort_gcm(modname,abort_message,1)
+             ENDIF
+             write(*,*),trim(modname)//' ncidu,varidu',ncidu,varidu
+             if (ncidpl.eq.-99) ncidpl=ncidu
+
+
+             status=NF90_INQ_DIMID(ncidu, "LONU", dimid)
+             status=NF90_INQUIRE_DIMENSION(ncidu,dimid,namedim,lendim)
+             IF (lendim .NE. iip1) THEN
+                abort_message='dimension LONU different from iip1 in u.nc'
+                CALL abort_gcm(modname,abort_message,1)
+             ENDIF
+
+             status=NF90_INQ_DIMID(ncidu, "LATU", dimid)
+             status=NF90_INQUIRE_DIMENSION(ncidu,dimid,namedim,lendim)
+             IF (lendim .NE. jjp1) THEN
+                abort_message='dimension LATU different from jjp1 in u.nc'
+                CALL abort_gcm(modname,abort_message,1)
+             ENDIF
+
+         endif
+
+! Vent meridien
+         if (guide_v) then
+             rcode = nf90_open('v.nc', nf90_nowrite, ncidv)
+             IF (rcode.NE.NF_NOERR) THEN
+              abort_message='Nudging: error -> no file v.nc'
+              CALL abort_gcm(modname,abort_message,1)
+             ENDIF
+             rcode = nf90_inq_varid(ncidv, 'VWND', varidv)
+             IF (rcode.NE.NF_NOERR) THEN
+              abort_message='Nudging: error -> no VWND variable in file v.nc'
+              CALL abort_gcm(modname,abort_message,1)
+             ENDIF
+             write(*,*),trim(modname)//' ncidv,varidv',ncidv,varidv
+             if (ncidpl.eq.-99) ncidpl=ncidv
+
+             status=NF90_INQ_DIMID(ncidv, "LONV", dimid)
+             status=NF90_INQUIRE_DIMENSION(ncidv,dimid,namedim,lendim)
+
+                IF (lendim .NE. iip1) THEN
+                abort_message='dimension LONV different from iip1 in v.nc'
+                CALL abort_gcm(modname,abort_message,1)
+             ENDIF
+
+
+             status=NF90_INQ_DIMID(ncidv, "LATV", dimid)
+             status=NF90_INQUIRE_DIMENSION(ncidv,dimid,namedim,lendim)
+             IF (lendim .NE. jjm) THEN
+                abort_message='dimension LATV different from jjm in v.nc'
+                CALL abort_gcm(modname,abort_message,1)
+             ENDIF
+
+        endif
+
+! Temperature
+         if (guide_T) then
+             rcode = nf90_open('T.nc', nf90_nowrite, ncidt)
+             IF (rcode.NE.NF_NOERR) THEN
+              abort_message='Nudging: error -> no file T.nc'
+              CALL abort_gcm(modname,abort_message,1)
+             ENDIF
+             rcode = nf90_inq_varid(ncidt, 'AIR', varidt)
+             IF (rcode.NE.NF_NOERR) THEN
+              abort_message='Nudging: error -> no AIR variable in file T.nc'
+              CALL abort_gcm(modname,abort_message,1)
+             ENDIF
+             write(*,*),trim(modname)//' ncidT,varidT',ncidt,varidt
+             if (ncidpl.eq.-99) ncidpl=ncidt
+
+             status=NF90_INQ_DIMID(ncidt, "LONV", dimid)
+             status=NF90_INQUIRE_DIMENSION(ncidt,dimid,namedim,lendim)
+             IF (lendim .NE. iip1) THEN
+                abort_message='dimension LONV different from iip1 in T.nc'
+                CALL abort_gcm(modname,abort_message,1)
+             ENDIF
+
+             status=NF90_INQ_DIMID(ncidt, "LATU", dimid)
+             status=NF90_INQUIRE_DIMENSION(ncidt,dimid,namedim,lendim)
+             IF (lendim .NE. jjp1) THEN
+                abort_message='dimension LATU different from jjp1 in T.nc'
+                CALL abort_gcm(modname,abort_message,1)
+             ENDIF
+
+         endif
+
+! Humidite
+         if (guide_Q) then
+             rcode = nf90_open('hur.nc', nf90_nowrite, ncidQ)
+             IF (rcode.NE.NF_NOERR) THEN
+              abort_message='Nudging: error -> no file hur.nc'
+              CALL abort_gcm(modname,abort_message,1)
+             ENDIF
+             rcode = nf90_inq_varid(ncidQ, 'RH', varidQ)
+             IF (rcode.NE.NF_NOERR) THEN
+              abort_message='Nudging: error -> no RH variable in file hur.nc'
+              CALL abort_gcm(modname,abort_message,1)
+             ENDIF
+             write(*,*),trim(modname)//' ncidQ,varidQ',ncidQ,varidQ
+             if (ncidpl.eq.-99) ncidpl=ncidQ
+
+
+             status=NF90_INQ_DIMID(ncidQ, "LONV", dimid)
+             status=NF90_INQUIRE_DIMENSION(ncidQ,dimid,namedim,lendim)
+             IF (lendim .NE. iip1) THEN
+                abort_message='dimension LONV different from iip1 in hur.nc'
+                CALL abort_gcm(modname,abort_message,1)
+             ENDIF
+
+             status=NF90_INQ_DIMID(ncidQ, "LATU", dimid)
+             status=NF90_INQUIRE_DIMENSION(ncidQ,dimid,namedim,lendim)
+             IF (lendim .NE. jjp1) THEN
+                abort_message='dimension LATU different from jjp1 in hur.nc'
+                CALL abort_gcm(modname,abort_message,1)
+             ENDIF
+
+
+         endif
+! Pression de surface
+         if ((guide_P).OR.(guide_plevs.EQ.1)) then
+             rcode = nf90_open('ps.nc', nf90_nowrite, ncidps)
+             IF (rcode.NE.NF_NOERR) THEN
+              abort_message='Nudging: error -> no file ps.nc'
+              CALL abort_gcm(modname,abort_message,1)
+             ENDIF
+             rcode = nf90_inq_varid(ncidps, 'SP', varidps)
+             IF (rcode.NE.NF_NOERR) THEN
+              abort_message='Nudging: error -> no SP variable in file ps.nc'
+              CALL abort_gcm(modname,abort_message,1)
+             ENDIF
+             write(*,*),trim(modname)//' ncidps,varidps',ncidps,varidps
+         endif
+! Coordonnee verticale
+         if (guide_plevs.EQ.0) then
+              rcode = nf90_inq_varid(ncidpl, 'LEVEL', varidpl)
+              IF (rcode.NE.0) rcode = nf90_inq_varid(ncidpl, 'PRESSURE', varidpl)
+              write(*,*),trim(modname)//' ncidpl,varidpl',ncidpl,varidpl
+         endif
+! Coefs ap, bp pour calcul de la pression aux differents niveaux
+         IF (guide_plevs.EQ.1) THEN
+             status = nf90_put_var(ncidpl, varidap, apnc, [1], [nlevnc])
+             status = nf90_put_var(ncidpl, varidbp, bpnc, [1], [nlevnc])
+         ELSEIF (guide_plevs.EQ.0) THEN
+             status = nf90_put_var(ncidpl, varidpl, apnc, [1], [nlevnc])
+!FC Pour les corrections la pression est deja en Pascals on commente la ligne ci-dessous
+             IF(convert_Pa) apnc=apnc*100.! conversion en Pascals
+             bpnc(:)=0.
+         ENDIF
+         first=.FALSE.
+     ENDIF ! (first)
+
+! -----------------------------------------------------------------
+!   lecture des champs u, v, T, Q, ps
+! -----------------------------------------------------------------
+
+!  dimensions pour les champs scalaires et le vent zonal
+     start(1)=1
+     start(2)=jjb_u
+     start(3)=1
+     start(4)=timestep
+
+     count(1)=iip1
+     count(2)=jjnb_u
+     count(3)=nlevnc
+     count(4)=1
+
+     IF (invert_y) start(2)=jjp1-jje_u+1
+! Pression
+     if (guide_plevs.EQ.2) then
+         status = nf90_put_var(ncidp, varidp, pnat2, start, count)
+         IF (invert_y) THEN
+!           PRINT*,"Invertion impossible actuellement"
+!           CALL abort_gcm(modname,abort_message,1)
+           CALL invert_lat(iip1,jjnb_u,nlevnc,pnat2)
+         ENDIF
+     endif
+
+!  Vent zonal
+     if (guide_u) then
+         status = nf90_put_var(ncidu, varidu, unat2, start, count)
+         IF (invert_y) THEN
+!           PRINT*,"Invertion impossible actuellement"
+!           CALL abort_gcm(modname,abort_message,1)
+           CALL invert_lat(iip1,jjnb_u,nlevnc,unat2)
+         ENDIF
+
+     endif
+
+
+!  Temperature
+     if (guide_T) then
+         status = nf90_put_var(ncidt, varidt, tnat2, start, count)
+         IF (invert_y) THEN
+!           PRINT*,"Invertion impossible actuellement"
+!           CALL abort_gcm(modname,abort_message,1)
+           CALL invert_lat(iip1,jjnb_u,nlevnc,tnat2)
+         ENDIF
+     endif
+
+!  Humidite
+     if (guide_Q) then
+         status = nf90_put_var(ncidQ, varidQ, qnat2, start, count)
+         IF (invert_y) THEN
+!           PRINT*,"Invertion impossible actuellement"
+!           CALL abort_gcm(modname,abort_message,1)
+           CALL invert_lat(iip1,jjnb_u,nlevnc,qnat2)
+         ENDIF
+
+     endif
+
+!  Vent meridien
+     if (guide_v) then
+         start(2)=jjb_v
+         count(2)=jjnb_v
+         IF (invert_y) start(2)=jjm-jje_v+1
+         status = nf90_put_var(ncidv, varidv, vnat2, start, count)
+         IF (invert_y) THEN
+!           PRINT*,"Invertion impossible actuellement"
+!           CALL abort_gcm(modname,abort_message,1)
+           CALL invert_lat(iip1,jjnb_v,nlevnc,vnat2)
+         ENDIF
+     endif
+
+!  Pression de surface
+     if ((guide_P).OR.(guide_plevs.EQ.1))  then
+         start(2)=jjb_u
+         start(3)=timestep
+         start(4)=0
+         count(2)=jjnb_u
+         count(3)=1
+         count(4)=0
+         IF (invert_y) start(2)=jjp1-jje_u+1
+         status = nf90_put_var(ncidps, varidps, psnat2, start, count)
+         IF (invert_y) THEN
+!           PRINT*,"Invertion impossible actuellement"
+!           CALL abort_gcm(modname,abort_message,1)
+           CALL invert_lat(iip1,jjnb_u,1,psnat2)
+         ENDIF
+     endif
+
+  END SUBROUTINE guide_read
+
+!=======================================================================
+  SUBROUTINE guide_read2D(timestep)
+    USE netcdf, ONLY: nf90_put_var
+    IMPLICIT NONE
+
+    include "netcdf.inc"
+    include "dimensions.h"
+    include "paramet.h"
+
+    INTEGER, INTENT(IN)   :: timestep
+
+    LOGICAL, SAVE         :: first=.TRUE.
+! Identification fichiers et variables NetCDF:
+    INTEGER, SAVE         :: ncidu,varidu,ncidv,varidv,ncidp,varidp
+    INTEGER, SAVE         :: ncidQ,varidQ,ncidt,varidt,ncidps,varidps
+    INTEGER               :: ncidpl,varidpl,varidap,varidbp
+! Variables auxiliaires NetCDF:
+    INTEGER, DIMENSION(4) :: start,count
+    INTEGER               :: status,rcode
+! Variables for 3D extension:
+    REAL, DIMENSION (jjb_u:jje_u,llm)  :: zu
+    REAL, DIMENSION (jjb_v:jje_v,llm)  :: zv
+    INTEGER               :: i
+    CHARACTER (len = 80)   :: abort_message
+    CHARACTER (len = 20)   :: modname = 'guide_read2D'
+    abort_message='pb in guide_read2D'
+
+! -----------------------------------------------------------------
+! Premier appel: initialisation de la lecture des fichiers
+! -----------------------------------------------------------------
+    if (first) then
+         ncidpl=-99
+         write(*,*)trim(modname)//' : opening nudging files '
+! Ap et Bp si niveaux de pression hybrides
+         if (guide_plevs.EQ.1) then
+           write(*,*)trim(modname)//' Reading nudging on model levels'
+           rcode = nf90_open('apbp.nc', nf90_nowrite, ncidpl)
+           IF (rcode.NE.NF_NOERR) THEN
+             abort_message='Nudging: error -> no file apbp.nc'
+           CALL abort_gcm(modname,abort_message,1)
+           ENDIF
+           rcode = nf90_inq_varid(ncidpl, 'AP', varidap)
+           IF (rcode.NE.NF_NOERR) THEN
+             abort_message='Nudging: error -> no AP variable in file apbp.nc'
+           CALL abort_gcm(modname,abort_message,1)
+           ENDIF
+           rcode = nf90_inq_varid(ncidpl, 'BP', varidbp)
+           IF (rcode.NE.NF_NOERR) THEN
+             abort_message='Nudging: error -> no BP variable in file apbp.nc'
+             CALL abort_gcm(modname,abort_message,1)
+           ENDIF
+           write(*,*)trim(modname)//'ncidpl,varidap',ncidpl,varidap
+         endif
+! Pression
+         if (guide_plevs.EQ.2) then
+           rcode = nf90_open('P.nc', nf90_nowrite, ncidp)
+           IF (rcode.NE.NF_NOERR) THEN
+             abort_message='Nudging: error -> no file P.nc'
+             CALL abort_gcm(modname,abort_message,1)
+           ENDIF
+           rcode = nf90_inq_varid(ncidp, 'PRES', varidp)
+           IF (rcode.NE.NF_NOERR) THEN
+             abort_message='Nudging: error -> no PRES variable in file P.nc'
+             CALL abort_gcm(modname,abort_message,1)
+           ENDIF
+           write(*,*)trim(modname)//' ncidp,varidp',ncidp,varidp
+           if (ncidpl.eq.-99) ncidpl=ncidp
+         endif
+! Vent zonal
+         if (guide_u) then
+           rcode = nf90_open('u.nc', nf90_nowrite, ncidu)
+           IF (rcode.NE.NF_NOERR) THEN
+             abort_message='Nudging: error -> no file u.nc'
+             CALL abort_gcm(modname,abort_message,1)
+           ENDIF
+           rcode = nf90_inq_varid(ncidu, 'UWND', varidu)
+           IF (rcode.NE.NF_NOERR) THEN
+             abort_message='Nudging: error -> no UWND variable in file u.nc'
+             CALL abort_gcm(modname,abort_message,1)
+           ENDIF
+           write(*,*)trim(modname)//' ncidu,varidu',ncidu,varidu
+           if (ncidpl.eq.-99) ncidpl=ncidu
+         endif
+
+! Vent meridien
+         if (guide_v) then
+           rcode = nf90_open('v.nc', nf90_nowrite, ncidv)
+           IF (rcode.NE.NF_NOERR) THEN
+             abort_message='Nudging: error -> no file v.nc'
+             CALL abort_gcm(modname,abort_message,1)
+           ENDIF
+           rcode = nf90_inq_varid(ncidv, 'VWND', varidv)
+           IF (rcode.NE.NF_NOERR) THEN
+             abort_message='Nudging: error -> no VWND variable in file v.nc'
+             CALL abort_gcm(modname,abort_message,1)
+           ENDIF
+           write(*,*)trim(modname)//' ncidv,varidv',ncidv,varidv
+           if (ncidpl.eq.-99) ncidpl=ncidv
+        endif
+! Temperature
+         if (guide_T) then
+           rcode = nf90_open('T.nc', nf90_nowrite, ncidt)
+           IF (rcode.NE.NF_NOERR) THEN
+             abort_message='Nudging: error -> no file T.nc'
+             CALL abort_gcm(modname,abort_message,1)
+           ENDIF
+           rcode = nf90_inq_varid(ncidt, 'AIR', varidt)
+           IF (rcode.NE.NF_NOERR) THEN
+             abort_message='Nudging: error -> no AIR variable in file T.nc'
+             CALL abort_gcm(modname,abort_message,1)
+           ENDIF
+           write(*,*)trim(modname)//' ncidT,varidT',ncidt,varidt
+           if (ncidpl.eq.-99) ncidpl=ncidt
+         endif
+! Humidite
+         if (guide_Q) then
+           rcode = nf90_open('hur.nc', nf90_nowrite, ncidQ)
+           IF (rcode.NE.NF_NOERR) THEN
+             abort_message='Nudging: error -> no file hur.nc'
+             CALL abort_gcm(modname,abort_message,1)
+           ENDIF
+           rcode = nf90_inq_varid(ncidQ, 'RH', varidQ)
+           IF (rcode.NE.NF_NOERR) THEN
+             abort_message='Nudging: error -> no RH,variable in file hur.nc'
+             CALL abort_gcm(modname,abort_message,1)
+           ENDIF
+           write(*,*)trim(modname)//' ncidQ,varidQ',ncidQ,varidQ
+           if (ncidpl.eq.-99) ncidpl=ncidQ
+         endif
+! Pression de surface
+         if ((guide_P).OR.(guide_plevs.EQ.1)) then
+           rcode = nf90_open('ps.nc', nf90_nowrite, ncidps)
+           IF (rcode.NE.NF_NOERR) THEN
+             abort_message='Nudging: error -> no file ps.nc'
+             CALL abort_gcm(modname,abort_message,1)
+           ENDIF
+           rcode = nf90_inq_varid(ncidps, 'SP', varidps)
+           IF (rcode.NE.NF_NOERR) THEN
+             abort_message='Nudging: error -> no SP variable in file ps.nc'
+             CALL abort_gcm(modname,abort_message,1)
+           ENDIF
+           write(*,*)trim(modname)//' ncidps,varidps',ncidps,varidps
+         endif
+! Coordonnee verticale
+         if (guide_plevs.EQ.0) then
+           rcode = nf90_inq_varid(ncidpl, 'LEVEL', varidpl)
+           IF (rcode.NE.0) rcode = nf90_inq_varid(ncidpl, 'PRESSURE', varidpl)
+           write(*,*)trim(modname)//' ncidpl,varidpl',ncidpl,varidpl
+         endif
+! Coefs ap, bp pour calcul de la pression aux differents niveaux
+         if (guide_plevs.EQ.1) then
+             status = nf90_put_var(ncidpl, varidap, apnc, [1], [nlevnc])
+             status = nf90_put_var(ncidpl, varidbp, bpnc, [1], [nlevnc])
+         elseif (guide_plevs.EQ.0) THEN
+             status = nf90_put_var(ncidpl, varidpl, apnc, [1], [nlevnc])
+             apnc=apnc*100.! conversion en Pascals
+             bpnc(:)=0.
+         endif
+         first=.FALSE.
+     endif ! (first)
+
+! -----------------------------------------------------------------
+!   lecture des champs u, v, T, Q, ps
+! -----------------------------------------------------------------
+
+!  dimensions pour les champs scalaires et le vent zonal
+     start(1)=1
+     start(2)=jjb_u
+     start(3)=1
+     start(4)=timestep
+
+     count(1)=1
+     count(2)=jjnb_u
+     count(3)=nlevnc
+     count(4)=1
+
+     IF (invert_y) start(2)=jjp1-jje_u+1
+!  Pression
+     if (guide_plevs.EQ.2) then
+         status = nf90_put_var(ncidp, varidp, zu, start, count)
+         DO i=1,iip1
+             pnat2(i,:,:)=zu(:,:)
+         ENDDO
+
+         IF (invert_y) THEN
+!           PRINT*,"Invertion impossible actuellement"
+!           CALL abort_gcm(modname,abort_message,1)
+           CALL invert_lat(iip1,jjnb_u,nlevnc,pnat2)
+         ENDIF
+     endif
+!  Vent zonal
+     if (guide_u) then
+         status = nf90_put_var(ncidu, varidu, zu, start, count)
+         DO i=1,iip1
+             unat2(i,:,:)=zu(:,:)
+         ENDDO
+
+         IF (invert_y) THEN
+!           PRINT*,"Invertion impossible actuellement"
+!           CALL abort_gcm(modname,abort_message,1)
+           CALL invert_lat(iip1,jjnb_u,nlevnc,unat2)
+         ENDIF
+     endif
+
+
+!  Temperature
+     if (guide_T) then
+         status = nf90_put_var(ncidt, varidt, zu, start, count)
+         DO i=1,iip1
+             tnat2(i,:,:)=zu(:,:)
+         ENDDO
+
+         IF (invert_y) THEN
+!           PRINT*,"Invertion impossible actuellement"
+!           CALL abort_gcm(modname,abort_message,1)
+           CALL invert_lat(iip1,jjnb_u,nlevnc,tnat2)
+         ENDIF
+     endif
+
+!  Humidite
+     if (guide_Q) then
+         status = nf90_put_var(ncidQ, varidQ, zu, start, count)
+         DO i=1,iip1
+             qnat2(i,:,:)=zu(:,:)
+         ENDDO
+
+         IF (invert_y) THEN
+!           PRINT*,"Invertion impossible actuellement"
+!           CALL abort_gcm(modname,abort_message,1)
+           CALL invert_lat(iip1,jjnb_u,nlevnc,qnat2)
+         ENDIF
+     endif
+
+!  Vent meridien
+     if (guide_v) then
+         start(2)=jjb_v
+         count(2)=jjnb_v
+         IF (invert_y) start(2)=jjm-jje_v+1
+         status = nf90_put_var(ncidv, varidv, zv, start, count)
+         DO i=1,iip1
+             vnat2(i,:,:)=zv(:,:)
+         ENDDO
+
+         IF (invert_y) THEN
+
+!           PRINT*,"Invertion impossible actuellement"
+!           CALL abort_gcm(modname,abort_message,1)
+           CALL invert_lat(iip1,jjnb_v,nlevnc,vnat2)
+         ENDIF
+     endif
+
+!  Pression de surface
+     if ((guide_P).OR.(guide_plevs.EQ.1))  then
+         start(2)=jjb_u
+         start(3)=timestep
+         start(4)=0
+         count(2)=jjnb_u
+         count(3)=1
+         count(4)=0
+         IF (invert_y) start(2)=jjp1-jje_u+1
+         status = nf90_put_var(ncidps, varidps, zu(:, 1), start, count)
+         DO i=1,iip1
+             psnat2(i,:)=zu(:,1)
+         ENDDO
+
+         IF (invert_y) THEN
+!           PRINT*,"Invertion impossible actuellement"
+!           CALL abort_gcm(modname,abort_message,1)
+           CALL invert_lat(iip1,jjnb_u,1,psnat2)
+         ENDIF
+     endif
+
+  END SUBROUTINE guide_read2D
+
+!=======================================================================
+  SUBROUTINE guide_out(varname,hsize,vsize,field_loc,factt)
+    USE parallel_lmdz
+    USE mod_hallo, ONLY : gather_field_u, gather_field_v
+    USE comconst_mod, ONLY: pi
+    USE comvert_mod, ONLY: presnivs
+    use netcdf95, only: nf95_def_var, nf95_put_var
+    use netcdf, only: nf90_float, nf90_put_var
+
+    IMPLICIT NONE
+
+    INCLUDE "dimensions.h"
+    INCLUDE "paramet.h"
+    INCLUDE "netcdf.inc"
+    INCLUDE "comgeom2.h"
+
+    ! Variables entree
+    CHARACTER*(*), INTENT(IN)                      :: varname
+    INTEGER,   INTENT (IN)                         :: hsize,vsize
+!   REAL, DIMENSION (iip1,hsize,vsize), INTENT(IN) :: field_loc
+    REAL, DIMENSION (:,:), INTENT(IN) :: field_loc
+    REAL factt
+
+    ! Variables locales
+    INTEGER, SAVE :: timestep=0
+    ! Identites fichier netcdf
+    INTEGER       :: nid, id_lonu, id_lonv, id_latu, id_latv, id_tim, id_lev
+    INTEGER       :: vid_lonu,vid_lonv,vid_latu,vid_latv,vid_cu,vid_cv,vid_lev
+    INTEGER       :: vid_au,vid_av, varid_alpha_t, varid_alpha_q
+    INTEGER, DIMENSION (3) :: dim3
+    INTEGER, DIMENSION (4) :: dim4,count,start
+    INTEGER                :: ierr, varid,l
+    REAL zu(ip1jmp1),zv(ip1jm), zt(iip1, jjp1), zq(iip1, jjp1)
+    REAL, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: field_glo
+    CHARACTER(LEN=20),PARAMETER :: modname="guide_out"
+
+!$OMP MASTER
+    ALLOCATE(field_glo(iip1,hsize,vsize))
+!$OMP END MASTER
+!$OMP BARRIER
+
+!    write(*,*)trim(modname)//' after allocation ',hsize,vsize
+
+    IF (hsize==jjp1) THEN
+        CALL gather_field_u(field_loc,field_glo,vsize)
+    ELSE IF (hsize==jjm) THEN
+       CALL gather_field_v(field_loc,field_glo, vsize)
+    ENDIF
+
+!    write(*,*)trim(modname)//' after gather '
+    CALL Gather_field_u(alpha_u,zu,1)
+    CALL Gather_field_u(alpha_t,zt,1)
+    CALL Gather_field_u(alpha_q,zq,1)
+    CALL Gather_field_v(alpha_v,zv,1)
+
+    IF (mpi_rank >  0) THEN
+!$OMP MASTER
+       DEALLOCATE(field_glo)
+!$OMP END MASTER
+!$OMP BARRIER
+
+       RETURN
+    ENDIF
+
+!$OMP MASTER
+    IF (timestep.EQ.0) THEN
+! ----------------------------------------------
+! initialisation fichier de sortie
+! ----------------------------------------------
+! Ouverture du fichier
+        ierr=NF_CREATE("guide_ins.nc",IOR(NF_CLOBBER,NF_64BIT_OFFSET),nid)
+! Definition des dimensions
+        ierr=NF_DEF_DIM(nid,"LONU",iip1,id_lonu)
+        ierr=NF_DEF_DIM(nid,"LONV",iip1,id_lonv)
+        ierr=NF_DEF_DIM(nid,"LATU",jjp1,id_latu)
+        ierr=NF_DEF_DIM(nid,"LATV",jjm,id_latv)
+        ierr=NF_DEF_DIM(nid,"LEVEL",llm,id_lev)
+        ierr=NF_DEF_DIM(nid,"TIME",NF_UNLIMITED,id_tim)
+
+! Creation des variables dimensions
+        ierr=NF_DEF_VAR(nid,"LONU",NF_FLOAT,1,id_lonu,vid_lonu)
+        ierr=NF_DEF_VAR(nid,"LONV",NF_FLOAT,1,id_lonv,vid_lonv)
+        ierr=NF_DEF_VAR(nid,"LATU",NF_FLOAT,1,id_latu,vid_latu)
+        ierr=NF_DEF_VAR(nid,"LATV",NF_FLOAT,1,id_latv,vid_latv)
+        ierr=NF_DEF_VAR(nid,"LEVEL",NF_FLOAT,1,id_lev,vid_lev)
+        ierr=NF_DEF_VAR(nid,"cu",NF_FLOAT,2,(/id_lonu,id_latu/),vid_cu)
+        ierr=NF_DEF_VAR(nid,"cv",NF_FLOAT,2,(/id_lonv,id_latv/),vid_cv)
+        ierr=NF_DEF_VAR(nid,"au",NF_FLOAT,2,(/id_lonu,id_latu/),vid_au)
+        ierr=NF_DEF_VAR(nid,"av",NF_FLOAT,2,(/id_lonv,id_latv/),vid_av)
+        call nf95_def_var(nid, "alpha_T", nf90_float, (/id_lonv, id_latu/), &
+             varid_alpha_t)
+        call nf95_def_var(nid, "alpha_q", nf90_float, (/id_lonv, id_latu/), &
+             varid_alpha_q)
+
+        ierr=NF_ENDDEF(nid)
+
+! Enregistrement des variables dimensions
+        ierr = nf90_put_var(nid, vid_lonu, rlonu * 180. / pi)
+        ierr = nf90_put_var(nid, vid_lonv, rlonv * 180. / pi)
+        ierr = nf90_put_var(nid, vid_latu, rlatu * 180. / pi)
+        ierr = nf90_put_var(nid, vid_latv, rlatv * 180. / pi)
+        ierr = nf90_put_var(nid, vid_lev, presnivs)
+        ierr = nf90_put_var(nid, vid_cu, cu)
+        ierr = nf90_put_var(nid, vid_cv, cv)
+        ierr = nf90_put_var(nid, vid_au, zu)
+        ierr = nf90_put_var(nid, vid_av, zv)
+        call nf95_put_var(nid, varid_alpha_t, zt)
+        call nf95_put_var(nid, varid_alpha_q, zq)
+! --------------------------------------------------------------------
+! Cr�ation des variables sauvegard�es
+! --------------------------------------------------------------------
+        ierr = NF_REDEF(nid)
+! Pressure (GCM)
+        dim4=(/id_lonv,id_latu,id_lev,id_tim/)
+        ierr = NF_DEF_VAR(nid,"SP",NF_FLOAT,4,dim4,varid)
+! Surface pressure (guidage)
+        IF (guide_P) THEN
+            dim3=(/id_lonv,id_latu,id_tim/)
+            ierr = NF_DEF_VAR(nid,"ps",NF_FLOAT,3,dim3,varid)
+        ENDIF
+! Zonal wind
+        IF (guide_u) THEN
+            dim4=(/id_lonu,id_latu,id_lev,id_tim/)
+            ierr = NF_DEF_VAR(nid,"u",NF_FLOAT,4,dim4,varid)
+            ierr = NF_DEF_VAR(nid,"ua",NF_FLOAT,4,dim4,varid)
+            ierr = NF_DEF_VAR(nid,"ucov",NF_FLOAT,4,dim4,varid)
+        ENDIF
+! Merid. wind
+        IF (guide_v) THEN
+            dim4=(/id_lonv,id_latv,id_lev,id_tim/)
+            ierr = NF_DEF_VAR(nid,"v",NF_FLOAT,4,dim4,varid)
+            ierr = NF_DEF_VAR(nid,"va",NF_FLOAT,4,dim4,varid)
+            ierr = NF_DEF_VAR(nid,"vcov",NF_FLOAT,4,dim4,varid)
+        ENDIF
+! Pot. Temperature
+        IF (guide_T) THEN
+            dim4=(/id_lonv,id_latu,id_lev,id_tim/)
+            ierr = NF_DEF_VAR(nid,"teta",NF_FLOAT,4,dim4,varid)
+        ENDIF
+! Specific Humidity
+        IF (guide_Q) THEN
+            dim4=(/id_lonv,id_latu,id_lev,id_tim/)
+            ierr = NF_DEF_VAR(nid,"q",NF_FLOAT,4,dim4,varid)
+        ENDIF
+
+        ierr = NF_ENDDEF(nid)
+        ierr = NF_CLOSE(nid)
+    ENDIF ! timestep=0
+
+! --------------------------------------------------------------------
+! Enregistrement du champ
+! --------------------------------------------------------------------
+
+    ierr=NF_OPEN("guide_ins.nc",NF_WRITE,nid)
+
+    IF (varname=="SP") timestep=timestep+1
+
+    ierr = NF_INQ_VARID(nid,varname,varid)
+    SELECT CASE (varname)
+    CASE ("SP","ps")
+        start=(/1,1,1,timestep/)
+        count=(/iip1,jjp1,llm,1/)
+    CASE ("v","va","vcov")
+        start=(/1,1,1,timestep/)
+        count=(/iip1,jjm,llm,1/)
+    CASE DEFAULT
+        start=(/1,1,1,timestep/)
+        count=(/iip1,jjp1,llm,1/)
+    END SELECT
+
+!$OMP END MASTER
+!$OMP BARRIER
+
+    SELECT CASE (varname)
+
+    CASE("u","ua")
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+        DO l=1,llm
+            field_glo(:,2:jjm,l)=field_glo(:,2:jjm,l)/cu(:,2:jjm)
+            field_glo(:,1,l)=0. ; field_glo(:,jjp1,l)=0.
+        ENDDO
+    CASE("v","va")
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+        DO l=1,llm
+           field_glo(:,:,l)=field_glo(:,:,l)/cv(:,:)
+        ENDDO
+    END SELECT
+
+!    if (varname=="ua") then
+!    call dump2d(iip1,jjp1,field_glo,'ua gui1 1ere couche ')
+!    call dump2d(iip1,jjp1,field_glo(:,:,llm),'ua gui1 llm ')
+!    endif
+
+!$OMP MASTER
+
+    ierr = nf90_put_var(nid, varid, field_glo, start, count)
+    ierr = NF_CLOSE(nid)
+
+       DEALLOCATE(field_glo)
+!$OMP END MASTER
+!$OMP BARRIER
+
+  END SUBROUTINE guide_out
+
+
+!===========================================================================
+  subroutine correctbid(iim,nl,x)
+    integer iim,nl
+    real x(iim+1,nl)
+    integer i,l
+    real zz
+
+    do l=1,nl
+        do i=2,iim-1
+            if(abs(x(i,l)).gt.1.e10) then
+               zz=0.5*(x(i-1,l)+x(i+1,l))
+              print*,'correction ',i,l,x(i,l),zz
+               x(i,l)=zz
+            endif
+         enddo
+     enddo
+     return
+  end subroutine correctbid
+
+
+!====================================================================
+! Ascii debug output. Could be reactivated
+!====================================================================
+
+subroutine dump2du(var,varname)
+use parallel_lmdz
+use mod_hallo
+implicit none
+include 'dimensions.h'
+include 'paramet.h'
+
+      CHARACTER (len=*) :: varname
+
+
+real, dimension(ijb_u:ije_u) :: var
+
+real, dimension(ip1jmp1) :: var_glob
+
+    RETURN
+
+    call barrier
+    CALL Gather_field_u(var,var_glob,1)
+    call barrier
+
+    if (mpi_rank==0) then
+       call dump2d(iip1,jjp1,var_glob,varname)
+    endif
+
+    call barrier
+
+    return
+    end subroutine dump2du
+
+!====================================================================
+! Ascii debug output. Could be reactivated
+!====================================================================
+subroutine dumpall
+     implicit none
+     include "dimensions.h"
+     include "paramet.h"
+     include "comgeom.h"
+     call barrier
+     call dump2du(alpha_u(ijb_u:ije_u),'  alpha_u couche 1')
+     call dump2du(unat2(:,jjbu:jjeu,nlevnc),'  unat2 couche nlevnc')
+     call dump2du(ugui1(ijb_u:ije_u,1)*sqrt(unscu2(ijb_u:ije_u)),'  ugui1 couche 1')
+     return
+end subroutine dumpall
+
+!===========================================================================
+END MODULE guide_loc_mod
Index: DZ6/trunk/libf/dyn3dmem/iniacademic_loc.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/iniacademic_loc.F90	(revision 5267)
+++ 	(revision )
@@ -1,389 +1,0 @@
-!
-! $Id: iniacademic.F90 1625 2012-05-09 13:14:48Z lguez $
-!
-SUBROUTINE iniacademic_loc(vcov,ucov,teta,q,masse,ps,phis,time_0)
-
-  USE filtreg_mod, ONLY: inifilr
-  USE infotrac,    ONLY: nqtot, niso, iqIsoPha, tracers, isoName, addPhase
-  USE control_mod, ONLY: day_step,planet_type
-  use exner_hyb_m, only: exner_hyb
-  use exner_milieu_m, only: exner_milieu
-  USE parallel_lmdz, ONLY: ijb_u, ije_u, ijb_v, ije_v
-  USE IOIPSL, ONLY: getin
-
-  USE Write_Field
-  USE comconst_mod, ONLY: cpp, kappa, g, daysec, dtvr, pi, im, jm
-  USE logic_mod, ONLY: iflag_phys, read_start
-  USE comvert_mod, ONLY: ap, bp, preff, pa, presnivs, pressure_exner
-  USE temps_mod, ONLY: annee_ref, day_ini, day_ref
-  USE ener_mod, ONLY: etot0,ptot0,ztot0,stot0,ang0
-  use netcdf, only : NF90_NOWRITE,NF90_OPEN,NF90_NOERR,NF90_INQ_VARID
-  use netcdf, only : NF90_CLOSE, NF90_GET_VAR
-  USE iso_params_mod   ! tnat_* and alpha_ideal_*
-
-
-  !   Author:    Frederic Hourdin      original: 15/01/93
-  ! The forcing defined here is from Held and Suarez, 1994, Bulletin
-  ! of the American Meteorological Society, 75, 1825.
-
-  IMPLICIT NONE
-
-  !   Declararations:
-  !   ---------------
-
-  include "dimensions.h"
-  include "paramet.h"
-  include "comgeom.h"
-  include "academic.h"
-  include "iniprint.h"
-
-  !   Arguments:
-  !   ----------
-
-  REAL,INTENT(OUT) :: time_0
-
-  !   fields
-  REAL,INTENT(OUT) :: vcov(ijb_v:ije_v,llm) ! meridional covariant wind
-  REAL,INTENT(OUT) :: ucov(ijb_u:ije_u,llm) ! zonal covariant wind
-  REAL,INTENT(OUT) :: teta(ijb_u:ije_u,llm) ! potential temperature (K)
-  REAL,INTENT(OUT) :: q(ijb_u:ije_u,llm,nqtot) ! advected tracers (.../kg_of_air)
-  REAL,INTENT(OUT) :: ps(ijb_u:ije_u) ! surface pressure (Pa)
-  REAL,INTENT(OUT) :: masse(ijb_u:ije_u,llm) ! air mass in grid cell (kg)
-  REAL,INTENT(OUT) :: phis(ijb_u:ije_u) ! surface geopotential
-
-  !   Local:
-  !   ------
-
-  REAL,ALLOCATABLE :: vcov_glo(:,:),ucov_glo(:,:),teta_glo(:,:)
-  REAL,ALLOCATABLE :: q_glo(:,:),masse_glo(:,:),ps_glo(:)
-  REAL,ALLOCATABLE :: phis_glo(:)
-  REAL p (ip1jmp1,llmp1  )               ! pression aux interfac.des couches
-  REAL pks(ip1jmp1)                      ! exner au  sol
-  REAL pk(ip1jmp1,llm)                   ! exner au milieu des couches
-  REAL phi(ip1jmp1,llm)                  ! geopotentiel
-  REAL ddsin,zsig,tetapv,w_pv  ! variables auxiliaires
-  real tetastrat ! potential temperature in the stratosphere, in K
-  real tetajl(jjp1,llm)
-  INTEGER i,j,l,lsup,ij, iq, iName, iPhase, iqParent
-
-  integer :: nid_relief,varid,ierr
-  real, dimension(iip1,jjp1) :: relief
-
-
-  REAL teta0,ttp,delt_y,delt_z,eps ! Constantes pour profil de T
-  REAL k_f,k_c_a,k_c_s         ! Constantes de rappel
-  LOGICAL ok_geost             ! Initialisation vent geost. ou nul
-  LOGICAL ok_pv                ! Polar Vortex
-  REAL phi_pv,dphi_pv,gam_pv,tetanoise   ! Constantes pour polar vortex 
-
-  real zz,ran1
-  integer idum
-
-  REAL zdtvr, tnat, alpha_ideal
-  LOGICAL :: ltnat1
-  
-  character(len=*),parameter :: modname="iniacademic"
-  character(len=80) :: abort_message
-
-  ! Sanity check: verify that options selected by user are not incompatible
-  if ((iflag_phys==1).and. .not. read_start) then
-    write(lunout,*) trim(modname)," error: if read_start is set to ", &
-    " false then iflag_phys should not be 1"
-    write(lunout,*) "You most likely want an aquaplanet initialisation", &
-    " (iflag_phys >= 100)"
-    call abort_gcm(modname,"incompatible iflag_phys==1 and read_start==.false.",1)
-  endif
-  
-  !-----------------------------------------------------------------------
-  ! 1. Initializations for Earth-like case
-  ! --------------------------------------
-  !
-  ! initialize planet radius, rotation rate,...
-  call conf_planete
-
-  time_0=0.
-  day_ref=1
-  ! annee_ref=0
-
-  im         = iim
-  jm         = jjm
-  day_ini    = 1
-  dtvr    = daysec/REAL(day_step)
-  zdtvr=dtvr
-  etot0      = 0.
-  ptot0      = 0.
-  ztot0      = 0.
-  stot0      = 0.
-  ang0       = 0.
-
-  if (llm == 1) then
-     ! specific initializations for the shallow water case
-     kappa=1
-  endif
-
-  CALL iniconst
-  CALL inigeom
-  CALL inifilr
-
-  ! Initialize pressure and mass field if read_start=.false.
-  IF (.NOT. read_start) THEN
-    ! allocate global fields:
-!    allocate(vcov_glo(ip1jm,llm))
-
-    allocate(ucov_glo(ip1jmp1,llm))
-    allocate(teta_glo(ip1jmp1,llm))
-    allocate(ps_glo(ip1jmp1))
-    allocate(masse_glo(ip1jmp1,llm))
-    allocate(phis_glo(ip1jmp1))
-
-     ! surface pressure
-     ps_glo(:)=preff
-
-     !------------------------------------------------------------------
-     ! Lecture eventuelle d'un fichier de relief interpollee sur la grille
-     ! du modele.
-     ! On suppose que le fichier relief_in.nc est stoké sur une grille
-     ! iim*jjp1
-     ! Facile a créer à partir de la commande
-     ! cdo remapcon,fichier_output_phys.nc Relief.nc relief_in.nc
-     !------------------------------------------------------------------
-
-     relief=0.
-     ierr = NF90_OPEN ('relief_in.nc', NF90_NOWRITE,nid_relief)
-     if (ierr.EQ.NF90_NOERR) THEN
-         ierr=NF90_INQ_VARID(nid_relief,'RELIEF',varid)
-         if (ierr==NF90_NOERR) THEN
-              ierr=NF90_GET_VAR(nid_relief,varid,relief(1:iim,1:jjp1))
-              relief(iip1,:)=relief(1,:)
-         else
-              CALL abort_gcm ('iniacademic','variable RELIEF pas la',1)
-         endif
-     endif
-     ierr = NF90_CLOSE (nid_relief)
-
-
-     !------------------------------------------------------------------
-     ! Initialisation du geopotentiel au sol et de la pression
-     !------------------------------------------------------------------
-
-     print*,'relief=',minval(relief),maxval(relief),'g=',g
-     do j=1,jjp1
-        do i=1,iip1
-           phis_glo((j-1)*iip1+i)=g*relief(i,j)
-        enddo
-     enddo
-     print*,'phis=',minval(phis),maxval(phis),'g=',g
-
-     CALL pression ( ip1jmp1, ap, bp, ps_glo, p       )
-     if (pressure_exner) then
-       CALL exner_hyb( ip1jmp1, ps_glo, p, pks, pk )
-     else
-       call exner_milieu(ip1jmp1,ps_glo,p,pks,pk)
-     endif
-     CALL massdair(p,masse_glo)
-  ENDIF
-
-  if (llm == 1) then
-     ! initialize fields for the shallow water case, if required
-     if (.not.read_start) then
-        phis(ijb_u:ije_u)=0.
-        q(ijb_u:ije_u,1:llm,1:nqtot)=0
-        CALL sw_case_williamson91_6_loc(vcov,ucov,teta,masse,ps)
-     endif
-  endif
-
-  academic_case: if (iflag_phys >= 2) then
-     ! initializations
-
-     ! 1. local parameters
-     ! by convention, winter is in the southern hemisphere
-     ! Geostrophic wind or no wind?
-     ok_geost=.TRUE.
-     CALL getin('ok_geost',ok_geost)
-     ! Constants for Newtonian relaxation and friction
-     k_f=1.                !friction 
-     CALL getin('k_j',k_f)
-     k_f=1./(daysec*k_f)
-     k_c_s=4.  !cooling surface
-     CALL getin('k_c_s',k_c_s)
-     k_c_s=1./(daysec*k_c_s)
-     k_c_a=40. !cooling free atm
-     CALL getin('k_c_a',k_c_a)
-     k_c_a=1./(daysec*k_c_a)
-     ! Constants for Teta equilibrium profile
-     teta0=315.     ! mean Teta (S.H. 315K)
-     CALL getin('teta0',teta0)
-     ttp=200.       ! Tropopause temperature (S.H. 200K)
-     CALL getin('ttp',ttp)
-     eps=0.         ! Deviation to N-S symmetry(~0-20K)
-     CALL getin('eps',eps)
-     delt_y=60.     ! Merid Temp. Gradient (S.H. 60K)
-     CALL getin('delt_y',delt_y)
-     delt_z=10.     ! Vertical Gradient (S.H. 10K)
-     CALL getin('delt_z',delt_z)
-     ! Polar vortex
-     ok_pv=.false.
-     CALL getin('ok_pv',ok_pv)
-     phi_pv=-50.            ! Latitude of edge of vortex
-     CALL getin('phi_pv',phi_pv)
-     phi_pv=phi_pv*pi/180.
-     dphi_pv=5.             ! Width of the edge
-     CALL getin('dphi_pv',dphi_pv)
-     dphi_pv=dphi_pv*pi/180.
-     gam_pv=4.              ! -dT/dz vortex (in K/km)
-     CALL getin('gam_pv',gam_pv)
-     tetanoise=0.005
-     CALL getin('tetanoise',tetanoise)
-
-     ! 2. Initialize fields towards which to relax
-     ! Friction
-     knewt_g=k_c_a
-     DO l=1,llm
-        zsig=presnivs(l)/preff
-        knewt_t(l)=(k_c_s-k_c_a)*MAX(0.,(zsig-0.7)/0.3)
-        kfrict(l)=k_f*MAX(0.,(zsig-0.7)/0.3)
-     ENDDO
-     DO j=1,jjp1
-        clat4((j-1)*iip1+1:j*iip1)=cos(rlatu(j))**4
-     ENDDO
-
-     ! Potential temperature 
-     DO l=1,llm
-        zsig=presnivs(l)/preff
-        tetastrat=ttp*zsig**(-kappa)
-        tetapv=tetastrat
-        IF ((ok_pv).AND.(zsig.LT.0.1)) THEN
-           tetapv=tetastrat*(zsig*10.)**(kappa*cpp*gam_pv/1000./g)
-        ENDIF
-        DO j=1,jjp1
-           ! Troposphere
-           ddsin=sin(rlatu(j))
-           tetajl(j,l)=teta0-delt_y*ddsin*ddsin+eps*ddsin &
-                -delt_z*(1.-ddsin*ddsin)*log(zsig)
-           if (planet_type=="giant") then
-             tetajl(j,l)=teta0+(delt_y*                   &
-                ((sin(rlatu(j)*3.14159*eps+0.0001))**2)   &
-                / ((rlatu(j)*3.14159*eps+0.0001)**2))     &
-                -delt_z*log(zsig)
-           endif
-           ! Profil stratospherique isotherme (+vortex)
-           w_pv=(1.-tanh((rlatu(j)-phi_pv)/dphi_pv))/2.
-           tetastrat=tetastrat*(1.-w_pv)+tetapv*w_pv             
-           tetajl(j,l)=MAX(tetajl(j,l),tetastrat)  
-        ENDDO
-     ENDDO
-
-     !          CALL writefield('theta_eq',tetajl)
-
-     do l=1,llm
-        do j=1,jjp1
-           do i=1,iip1
-              ij=(j-1)*iip1+i
-              tetarappel(ij,l)=tetajl(j,l)
-           enddo
-        enddo
-     enddo
-
-     ! 3. Initialize fields (if necessary)
-     IF (.NOT. read_start) THEN
-        ! bulk initialization of temperature
-        IF (iflag_phys>10000) THEN
-        ! Particular case to impose a constant temperature T0=0.01*iflag_phys
-           teta_glo(:,:)= 0.01*iflag_phys/(pk(:,:)/cpp)
-        ELSE
-           teta_glo(:,:)=tetarappel(:,:)
-        ENDIF
-        ! geopotential
-        CALL geopot(ip1jmp1,teta_glo,pk,pks,phis_glo,phi)
-
-        ! winds
-        if (ok_geost) then
-           call ugeostr(phi,ucov_glo)
-        else
-           ucov_glo(:,:)=0.
-        endif
-        vcov(ijb_v:ije_v,1:llm)=0.
-
-        ! bulk initialization of tracers
-        if (planet_type=="earth") then
-           ltnat1 = .TRUE.; CALL getin('tnateq1', ltnat1)
-           ! Earth: first two tracers will be water
-           do iq=1,nqtot
-              q(ijb_u:ije_u,:,iq)=0.
-              IF(tracers(iq)%name == addPhase('H2O', 'g')) q(ijb_u:ije_u,:,iq)=1.e-10
-              IF(tracers(iq)%name == addPhase('H2O', 'l')) q(ijb_u:ije_u,:,iq)=1.e-15
-
-              ! CRisi: init des isotopes
-              ! distill de Rayleigh très simplifiée
-              iName    = tracers(iq)%iso_iName
-              if (niso <= 0 .OR. iName <= 0) CYCLE
-              iPhase   = tracers(iq)%iso_iPhase
-              iqParent = tracers(iq)%iqParent
-              IF(tracers(iq)%iso_iZone == 0) THEN
-                 IF(ltnat1) THEN
-                    tnat = 1.0
-                    alpha_ideal = 1.0
-                    WRITE(lunout, *) 'In '//TRIM(modname)//': !!!  Beware: alpha_ideal put to 1  !!!'
-                 ELSE
-                    SELECT CASE(isoName(iName))
-                      CASE('H216O'); tnat = tnat_H216O; alpha_ideal = alpha_ideal_H216O
-                      CASE('H217O'); tnat = tnat_H217O; alpha_ideal = alpha_ideal_H217O
-                      CASE('H218O'); tnat = tnat_H218O; alpha_ideal = alpha_ideal_H218O
-                      CASE('HDO');   tnat = tnat_HDO;   alpha_ideal = alpha_ideal_HDO
-                      CASE('HTO');   tnat = tnat_HTO;   alpha_ideal = alpha_ideal_HTO
-                      CASE DEFAULT
-                         CALL abort_gcm(TRIM(modname),'unknown isotope "'//TRIM(isoName(iName))//'" ; check tracer.def file',1)
-                    END SELECT
-                 END IF
-                 q(ijb_u:ije_u,:,iq) = q(ijb_u:ije_u,:,iqParent)*tnat*(q(ijb_u:ije_u,:,iqParent)/30.e-3)**(alpha_ideal-1.)
-              ELSE !IF(tracers(iq)%iso_iZone == 0) THEN
-                 IF(tracers(iq)%iso_iZone == 1) THEN ! a verifier.
-                    ! correction le 14 mai 2024 pour que tous les traceurs soient de la couleur 1.
-                    ! Sinon, on va avoir des porblèmes de conservation de masse de traceurs.
-                    q(ijb_u:ije_u,:,iq) = q(ijb_u:ije_u,:,iqIsoPha(iName,iPhase))
-                 else !IF(tracers(iq)%iso_iZone == 1) THEN
-                    q(ijb_u:ije_u,:,iq) = 0.0
-                 endif !IF(tracers(iq)%iso_iZone == 1) THEN
-              END IF !IF(tracers(iq)%iso_iZone == 0) THEN
-           enddo
-        else
-           q(ijb_u:ije_u,:,:)=0
-        endif ! of if (planet_type=="earth")
-
-        call check_isotopes(q,ijb_u,ije_u,'iniacademic_loc')
-
-        ! add random perturbation to temperature
-        idum  = -1
-        zz = ran1(idum)
-        idum  = 0
-        do l=1,llm
-           do ij=iip2,ip1jm
-              teta_glo(ij,l)=teta_glo(ij,l)*(1.+tetanoise*ran1(idum))
-           enddo
-        enddo
-
-        ! maintain periodicity in longitude
-        do l=1,llm
-           do ij=1,ip1jmp1,iip1
-              teta_glo(ij+iim,l)=teta_glo(ij,l)
-           enddo
-        enddo
-
-        ! copy data from global array to local array:
-        teta(ijb_u:ije_u,:)=teta_glo(ijb_u:ije_u,:)
-        ucov(ijb_u:ije_u,:)=ucov_glo(ijb_u:ije_u,:)
-!        vcov(ijb_v:ije_v,:)=vcov_glo(ijb_v:ije_v,:)
-        masse(ijb_u:ije_u,:)=masse_glo(ijb_u:ije_u,:)
-        ps(ijb_u:ije_u)=ps_glo(ijb_u:ije_u)
-        phis(ijb_u:ije_u)=phis_glo(ijb_u:ije_u)
-
-        deallocate(teta_glo)
-        deallocate(ucov_glo)
-!        deallocate(vcov_glo)
-        deallocate(masse_glo)
-        deallocate(ps_glo)
-        deallocate(phis_glo)
-     ENDIF ! of IF (.NOT. read_start)
-  endif academic_case
-
-END SUBROUTINE iniacademic_loc
Index: /LMDZ6/trunk/libf/dyn3dmem/iniacademic_loc.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/iniacademic_loc.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3dmem/iniacademic_loc.f90	(revision 5268)
@@ -0,0 +1,389 @@
+!
+! $Id: iniacademic.F90 1625 2012-05-09 13:14:48Z lguez $
+!
+SUBROUTINE iniacademic_loc(vcov,ucov,teta,q,masse,ps,phis,time_0)
+
+  USE filtreg_mod, ONLY: inifilr
+  USE infotrac,    ONLY: nqtot, niso, iqIsoPha, tracers, isoName, addPhase
+  USE control_mod, ONLY: day_step,planet_type
+  use exner_hyb_m, only: exner_hyb
+  use exner_milieu_m, only: exner_milieu
+  USE parallel_lmdz, ONLY: ijb_u, ije_u, ijb_v, ije_v
+  USE IOIPSL, ONLY: getin
+
+  USE Write_Field
+  USE comconst_mod, ONLY: cpp, kappa, g, daysec, dtvr, pi, im, jm
+  USE logic_mod, ONLY: iflag_phys, read_start
+  USE comvert_mod, ONLY: ap, bp, preff, pa, presnivs, pressure_exner
+  USE temps_mod, ONLY: annee_ref, day_ini, day_ref
+  USE ener_mod, ONLY: etot0,ptot0,ztot0,stot0,ang0
+  use netcdf, only : NF90_NOWRITE,NF90_OPEN,NF90_NOERR,NF90_INQ_VARID
+  use netcdf, only : NF90_CLOSE, NF90_GET_VAR
+  USE iso_params_mod   ! tnat_* and alpha_ideal_*
+
+
+  !   Author:    Frederic Hourdin      original: 15/01/93
+  ! The forcing defined here is from Held and Suarez, 1994, Bulletin
+  ! of the American Meteorological Society, 75, 1825.
+
+  IMPLICIT NONE
+
+  !   Declararations:
+  !   ---------------
+
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom.h"
+  include "academic.h"
+  include "iniprint.h"
+
+  !   Arguments:
+  !   ----------
+
+  REAL,INTENT(OUT) :: time_0
+
+  !   fields
+  REAL,INTENT(OUT) :: vcov(ijb_v:ije_v,llm) ! meridional covariant wind
+  REAL,INTENT(OUT) :: ucov(ijb_u:ije_u,llm) ! zonal covariant wind
+  REAL,INTENT(OUT) :: teta(ijb_u:ije_u,llm) ! potential temperature (K)
+  REAL,INTENT(OUT) :: q(ijb_u:ije_u,llm,nqtot) ! advected tracers (.../kg_of_air)
+  REAL,INTENT(OUT) :: ps(ijb_u:ije_u) ! surface pressure (Pa)
+  REAL,INTENT(OUT) :: masse(ijb_u:ije_u,llm) ! air mass in grid cell (kg)
+  REAL,INTENT(OUT) :: phis(ijb_u:ije_u) ! surface geopotential
+
+  !   Local:
+  !   ------
+
+  REAL,ALLOCATABLE :: vcov_glo(:,:),ucov_glo(:,:),teta_glo(:,:)
+  REAL,ALLOCATABLE :: q_glo(:,:),masse_glo(:,:),ps_glo(:)
+  REAL,ALLOCATABLE :: phis_glo(:)
+  REAL p (ip1jmp1,llmp1  )               ! pression aux interfac.des couches
+  REAL pks(ip1jmp1)                      ! exner au  sol
+  REAL pk(ip1jmp1,llm)                   ! exner au milieu des couches
+  REAL phi(ip1jmp1,llm)                  ! geopotentiel
+  REAL ddsin,zsig,tetapv,w_pv  ! variables auxiliaires
+  real tetastrat ! potential temperature in the stratosphere, in K
+  real tetajl(jjp1,llm)
+  INTEGER i,j,l,lsup,ij, iq, iName, iPhase, iqParent
+
+  integer :: nid_relief,varid,ierr
+  real, dimension(iip1,jjp1) :: relief
+
+
+  REAL teta0,ttp,delt_y,delt_z,eps ! Constantes pour profil de T
+  REAL k_f,k_c_a,k_c_s         ! Constantes de rappel
+  LOGICAL ok_geost             ! Initialisation vent geost. ou nul
+  LOGICAL ok_pv                ! Polar Vortex
+  REAL phi_pv,dphi_pv,gam_pv,tetanoise   ! Constantes pour polar vortex 
+
+  real zz,ran1
+  integer idum
+
+  REAL zdtvr, tnat, alpha_ideal
+  LOGICAL :: ltnat1
+  
+  character(len=*),parameter :: modname="iniacademic"
+  character(len=80) :: abort_message
+
+  ! Sanity check: verify that options selected by user are not incompatible
+  if ((iflag_phys==1).and. .not. read_start) then
+    write(lunout,*) trim(modname)," error: if read_start is set to ", &
+    " false then iflag_phys should not be 1"
+    write(lunout,*) "You most likely want an aquaplanet initialisation", &
+    " (iflag_phys >= 100)"
+    call abort_gcm(modname,"incompatible iflag_phys==1 and read_start==.false.",1)
+  endif
+  
+  !-----------------------------------------------------------------------
+  ! 1. Initializations for Earth-like case
+  ! --------------------------------------
+  !
+  ! initialize planet radius, rotation rate,...
+  call conf_planete
+
+  time_0=0.
+  day_ref=1
+  ! annee_ref=0
+
+  im         = iim
+  jm         = jjm
+  day_ini    = 1
+  dtvr    = daysec/REAL(day_step)
+  zdtvr=dtvr
+  etot0      = 0.
+  ptot0      = 0.
+  ztot0      = 0.
+  stot0      = 0.
+  ang0       = 0.
+
+  if (llm == 1) then
+     ! specific initializations for the shallow water case
+     kappa=1
+  endif
+
+  CALL iniconst
+  CALL inigeom
+  CALL inifilr
+
+  ! Initialize pressure and mass field if read_start=.false.
+  IF (.NOT. read_start) THEN
+    ! allocate global fields:
+!    allocate(vcov_glo(ip1jm,llm))
+
+    allocate(ucov_glo(ip1jmp1,llm))
+    allocate(teta_glo(ip1jmp1,llm))
+    allocate(ps_glo(ip1jmp1))
+    allocate(masse_glo(ip1jmp1,llm))
+    allocate(phis_glo(ip1jmp1))
+
+     ! surface pressure
+     ps_glo(:)=preff
+
+     !------------------------------------------------------------------
+     ! Lecture eventuelle d'un fichier de relief interpollee sur la grille
+     ! du modele.
+     ! On suppose que le fichier relief_in.nc est stoké sur une grille
+     ! iim*jjp1
+     ! Facile a créer à partir de la commande
+     ! cdo remapcon,fichier_output_phys.nc Relief.nc relief_in.nc
+     !------------------------------------------------------------------
+
+     relief=0.
+     ierr = NF90_OPEN ('relief_in.nc', NF90_NOWRITE,nid_relief)
+     if (ierr.EQ.NF90_NOERR) THEN
+         ierr=NF90_INQ_VARID(nid_relief,'RELIEF',varid)
+         if (ierr==NF90_NOERR) THEN
+              ierr=NF90_GET_VAR(nid_relief,varid,relief(1:iim,1:jjp1))
+              relief(iip1,:)=relief(1,:)
+         else
+              CALL abort_gcm ('iniacademic','variable RELIEF pas la',1)
+         endif
+     endif
+     ierr = NF90_CLOSE (nid_relief)
+
+
+     !------------------------------------------------------------------
+     ! Initialisation du geopotentiel au sol et de la pression
+     !------------------------------------------------------------------
+
+     print*,'relief=',minval(relief),maxval(relief),'g=',g
+     do j=1,jjp1
+        do i=1,iip1
+           phis_glo((j-1)*iip1+i)=g*relief(i,j)
+        enddo
+     enddo
+     print*,'phis=',minval(phis),maxval(phis),'g=',g
+
+     CALL pression ( ip1jmp1, ap, bp, ps_glo, p       )
+     if (pressure_exner) then
+       CALL exner_hyb( ip1jmp1, ps_glo, p, pks, pk )
+     else
+       call exner_milieu(ip1jmp1,ps_glo,p,pks,pk)
+     endif
+     CALL massdair(p,masse_glo)
+  ENDIF
+
+  if (llm == 1) then
+     ! initialize fields for the shallow water case, if required
+     if (.not.read_start) then
+        phis(ijb_u:ije_u)=0.
+        q(ijb_u:ije_u,1:llm,1:nqtot)=0
+        CALL sw_case_williamson91_6_loc(vcov,ucov,teta,masse,ps)
+     endif
+  endif
+
+  academic_case: if (iflag_phys >= 2) then
+     ! initializations
+
+     ! 1. local parameters
+     ! by convention, winter is in the southern hemisphere
+     ! Geostrophic wind or no wind?
+     ok_geost=.TRUE.
+     CALL getin('ok_geost',ok_geost)
+     ! Constants for Newtonian relaxation and friction
+     k_f=1.                !friction 
+     CALL getin('k_j',k_f)
+     k_f=1./(daysec*k_f)
+     k_c_s=4.  !cooling surface
+     CALL getin('k_c_s',k_c_s)
+     k_c_s=1./(daysec*k_c_s)
+     k_c_a=40. !cooling free atm
+     CALL getin('k_c_a',k_c_a)
+     k_c_a=1./(daysec*k_c_a)
+     ! Constants for Teta equilibrium profile
+     teta0=315.     ! mean Teta (S.H. 315K)
+     CALL getin('teta0',teta0)
+     ttp=200.       ! Tropopause temperature (S.H. 200K)
+     CALL getin('ttp',ttp)
+     eps=0.         ! Deviation to N-S symmetry(~0-20K)
+     CALL getin('eps',eps)
+     delt_y=60.     ! Merid Temp. Gradient (S.H. 60K)
+     CALL getin('delt_y',delt_y)
+     delt_z=10.     ! Vertical Gradient (S.H. 10K)
+     CALL getin('delt_z',delt_z)
+     ! Polar vortex
+     ok_pv=.false.
+     CALL getin('ok_pv',ok_pv)
+     phi_pv=-50.            ! Latitude of edge of vortex
+     CALL getin('phi_pv',phi_pv)
+     phi_pv=phi_pv*pi/180.
+     dphi_pv=5.             ! Width of the edge
+     CALL getin('dphi_pv',dphi_pv)
+     dphi_pv=dphi_pv*pi/180.
+     gam_pv=4.              ! -dT/dz vortex (in K/km)
+     CALL getin('gam_pv',gam_pv)
+     tetanoise=0.005
+     CALL getin('tetanoise',tetanoise)
+
+     ! 2. Initialize fields towards which to relax
+     ! Friction
+     knewt_g=k_c_a
+     DO l=1,llm
+        zsig=presnivs(l)/preff
+        knewt_t(l)=(k_c_s-k_c_a)*MAX(0.,(zsig-0.7)/0.3)
+        kfrict(l)=k_f*MAX(0.,(zsig-0.7)/0.3)
+     ENDDO
+     DO j=1,jjp1
+        clat4((j-1)*iip1+1:j*iip1)=cos(rlatu(j))**4
+     ENDDO
+
+     ! Potential temperature 
+     DO l=1,llm
+        zsig=presnivs(l)/preff
+        tetastrat=ttp*zsig**(-kappa)
+        tetapv=tetastrat
+        IF ((ok_pv).AND.(zsig.LT.0.1)) THEN
+           tetapv=tetastrat*(zsig*10.)**(kappa*cpp*gam_pv/1000./g)
+        ENDIF
+        DO j=1,jjp1
+           ! Troposphere
+           ddsin=sin(rlatu(j))
+           tetajl(j,l)=teta0-delt_y*ddsin*ddsin+eps*ddsin &
+                -delt_z*(1.-ddsin*ddsin)*log(zsig)
+           if (planet_type=="giant") then
+             tetajl(j,l)=teta0+(delt_y*                   &
+                ((sin(rlatu(j)*3.14159*eps+0.0001))**2)   &
+                / ((rlatu(j)*3.14159*eps+0.0001)**2))     &
+                -delt_z*log(zsig)
+           endif
+           ! Profil stratospherique isotherme (+vortex)
+           w_pv=(1.-tanh((rlatu(j)-phi_pv)/dphi_pv))/2.
+           tetastrat=tetastrat*(1.-w_pv)+tetapv*w_pv             
+           tetajl(j,l)=MAX(tetajl(j,l),tetastrat)  
+        ENDDO
+     ENDDO
+
+     !          CALL writefield('theta_eq',tetajl)
+
+     do l=1,llm
+        do j=1,jjp1
+           do i=1,iip1
+              ij=(j-1)*iip1+i
+              tetarappel(ij,l)=tetajl(j,l)
+           enddo
+        enddo
+     enddo
+
+     ! 3. Initialize fields (if necessary)
+     IF (.NOT. read_start) THEN
+        ! bulk initialization of temperature
+        IF (iflag_phys>10000) THEN
+        ! Particular case to impose a constant temperature T0=0.01*iflag_phys
+           teta_glo(:,:)= 0.01*iflag_phys/(pk(:,:)/cpp)
+        ELSE
+           teta_glo(:,:)=tetarappel(:,:)
+        ENDIF
+        ! geopotential
+        CALL geopot(ip1jmp1,teta_glo,pk,pks,phis_glo,phi)
+
+        ! winds
+        if (ok_geost) then
+           call ugeostr(phi,ucov_glo)
+        else
+           ucov_glo(:,:)=0.
+        endif
+        vcov(ijb_v:ije_v,1:llm)=0.
+
+        ! bulk initialization of tracers
+        if (planet_type=="earth") then
+           ltnat1 = .TRUE.; CALL getin('tnateq1', ltnat1)
+           ! Earth: first two tracers will be water
+           do iq=1,nqtot
+              q(ijb_u:ije_u,:,iq)=0.
+              IF(tracers(iq)%name == addPhase('H2O', 'g')) q(ijb_u:ije_u,:,iq)=1.e-10
+              IF(tracers(iq)%name == addPhase('H2O', 'l')) q(ijb_u:ije_u,:,iq)=1.e-15
+
+              ! CRisi: init des isotopes
+              ! distill de Rayleigh très simplifiée
+              iName    = tracers(iq)%iso_iName
+              if (niso <= 0 .OR. iName <= 0) CYCLE
+              iPhase   = tracers(iq)%iso_iPhase
+              iqParent = tracers(iq)%iqParent
+              IF(tracers(iq)%iso_iZone == 0) THEN
+                 IF(ltnat1) THEN
+                    tnat = 1.0
+                    alpha_ideal = 1.0
+                    WRITE(lunout, *) 'In '//TRIM(modname)//': !!!  Beware: alpha_ideal put to 1  !!!'
+                 ELSE
+                    SELECT CASE(isoName(iName))
+                      CASE('H216O'); tnat = tnat_H216O; alpha_ideal = alpha_ideal_H216O
+                      CASE('H217O'); tnat = tnat_H217O; alpha_ideal = alpha_ideal_H217O
+                      CASE('H218O'); tnat = tnat_H218O; alpha_ideal = alpha_ideal_H218O
+                      CASE('HDO');   tnat = tnat_HDO;   alpha_ideal = alpha_ideal_HDO
+                      CASE('HTO');   tnat = tnat_HTO;   alpha_ideal = alpha_ideal_HTO
+                      CASE DEFAULT
+                         CALL abort_gcm(TRIM(modname),'unknown isotope "'//TRIM(isoName(iName))//'" ; check tracer.def file',1)
+                    END SELECT
+                 END IF
+                 q(ijb_u:ije_u,:,iq) = q(ijb_u:ije_u,:,iqParent)*tnat*(q(ijb_u:ije_u,:,iqParent)/30.e-3)**(alpha_ideal-1.)
+              ELSE !IF(tracers(iq)%iso_iZone == 0) THEN
+                 IF(tracers(iq)%iso_iZone == 1) THEN ! a verifier.
+                    ! correction le 14 mai 2024 pour que tous les traceurs soient de la couleur 1.
+                    ! Sinon, on va avoir des porblèmes de conservation de masse de traceurs.
+                    q(ijb_u:ije_u,:,iq) = q(ijb_u:ije_u,:,iqIsoPha(iName,iPhase))
+                 else !IF(tracers(iq)%iso_iZone == 1) THEN
+                    q(ijb_u:ije_u,:,iq) = 0.0
+                 endif !IF(tracers(iq)%iso_iZone == 1) THEN
+              END IF !IF(tracers(iq)%iso_iZone == 0) THEN
+           enddo
+        else
+           q(ijb_u:ije_u,:,:)=0
+        endif ! of if (planet_type=="earth")
+
+        call check_isotopes(q,ijb_u,ije_u,'iniacademic_loc')
+
+        ! add random perturbation to temperature
+        idum  = -1
+        zz = ran1(idum)
+        idum  = 0
+        do l=1,llm
+           do ij=iip2,ip1jm
+              teta_glo(ij,l)=teta_glo(ij,l)*(1.+tetanoise*ran1(idum))
+           enddo
+        enddo
+
+        ! maintain periodicity in longitude
+        do l=1,llm
+           do ij=1,ip1jmp1,iip1
+              teta_glo(ij+iim,l)=teta_glo(ij,l)
+           enddo
+        enddo
+
+        ! copy data from global array to local array:
+        teta(ijb_u:ije_u,:)=teta_glo(ijb_u:ije_u,:)
+        ucov(ijb_u:ije_u,:)=ucov_glo(ijb_u:ije_u,:)
+!        vcov(ijb_v:ije_v,:)=vcov_glo(ijb_v:ije_v,:)
+        masse(ijb_u:ije_u,:)=masse_glo(ijb_u:ije_u,:)
+        ps(ijb_u:ije_u)=ps_glo(ijb_u:ije_u)
+        phis(ijb_u:ije_u)=phis_glo(ijb_u:ije_u)
+
+        deallocate(teta_glo)
+        deallocate(ucov_glo)
+!        deallocate(vcov_glo)
+        deallocate(masse_glo)
+        deallocate(ps_glo)
+        deallocate(phis_glo)
+     ENDIF ! of IF (.NOT. read_start)
+  endif academic_case
+
+END SUBROUTINE iniacademic_loc
Index: DZ6/trunk/libf/dyn3dmem/initdynav_loc.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/initdynav_loc.F90	(revision 5267)
+++ 	(revision )
@@ -1,282 +1,0 @@
-!
-! $Id: initdynav_p.F 1279 2009-12-10 09:02:56Z fairhead $
-!
-subroutine initdynav_loc(day0,anne0,tstep,t_ops,t_wrt)
-
-  ! This routine needs IOIPSL
-   USE IOIPSL
-
-   USE parallel_lmdz
-   use Write_field
-   use misc_mod
-    ! USE infotrac
-   use com_io_dyn_mod, only : histaveid,histvaveid,histuaveid,       &
-         dynhistave_file,dynhistvave_file,dynhistuave_file
-   USE comconst_mod, ONLY: pi
-   USE comvert_mod, ONLY: presnivs
-   USE temps_mod, ONLY: itau_dyn
-
-   implicit none
-
-  !
-  !   Routine d'initialisation des ecritures des fichiers histoires LMDZ
-  !   au format IOIPSL. Initialisation du fichier histoire moyenne.
-  !
-  !   Appels succesifs des routines: histbeg
-  !                              histhori
-  !                              histver
-  !                              histdef
-  !                              histend
-  !
-  !   Entree:
-  !
-  !  day0,anne0: date de reference
-  !  tstep : frequence d'ecriture
-  !  t_ops: frequence de l'operation pour IOIPSL
-  !  t_wrt: frequence d'ecriture sur le fichier
-  !
-  !   Sortie:
-  !  fileid: ID du fichier netcdf cree
-  !
-  !   L. Fairhead, LMD, 03/99
-  !
-  ! =====================================================================
-  !
-  !   Declarations
-  include "dimensions.h"
-  include "paramet.h"
-  include "comgeom.h"
-  include "description.h"
-  include "iniprint.h"
-
-  !   Arguments
-  !
-  integer(kind=4) :: day0, anne0
-  real :: tstep, t_ops, t_wrt
-
-  ! This routine needs IOIPSL
-  !   Variables locales
-  !
-  integer :: tau0
-  real :: zjulian
-  integer :: iq
-  real :: rlong(iip1,jjp1), rlat(iip1,jjp1)
-  integer :: uhoriid, vhoriid, thoriid
-  integer :: zvertiid,zvertiidv,zvertiidu
-  integer :: ii,jj
-  integer :: zan, dayref
-  integer :: jjb,jje,jjn
-
-  ! definition du domaine d'ecriture pour le rebuild
-
-  INTEGER,DIMENSION(2) :: ddid
-  INTEGER,DIMENSION(2) :: dsg
-  INTEGER,DIMENSION(2) :: dsl
-  INTEGER,DIMENSION(2) :: dpf
-  INTEGER,DIMENSION(2) :: dpl
-  INTEGER,DIMENSION(2) :: dhs
-  INTEGER,DIMENSION(2) :: dhe
-
-  INTEGER :: dynhistave_domain_id
-  INTEGER :: dynhistvave_domain_id
-  INTEGER :: dynhistuave_domain_id
-
-  if (adjust) return
-
-  !
-  !  Initialisations
-  !
-  pi = 4. * atan (1.)
-  !
-  !  Appel a histbeg: creation du fichier netcdf et initialisations diverses
-  !
-
-  zan = anne0
-  dayref = day0
-  CALL ymds2ju(zan, 1, dayref, 0.0, zjulian)
-  tau0 = itau_dyn
-
-  do jj = 1, jjp1
-    do ii = 1, iip1
-      rlong(ii,jj) = rlonv(ii) * 180. / pi
-      rlat(ii,jj)  = rlatu(jj) * 180. / pi
-    enddo
-  enddo
-
-
-  ! Creation de 3 fichiers pour les differentes grilles horizontales
-  ! Restriction de IOIPSL: seulement 2 coordonnees dans le meme fichier
-  ! Grille Scalaire
-
-  jjb=jj_begin
-  jje=jj_end
-  jjn=jj_nb
-
-  ddid=(/ 1,2 /)
-  dsg=(/ iip1,jjp1 /)
-  dsl=(/ iip1,jjn /)
-  dpf=(/ 1,jjb /)
-  dpl=(/ iip1,jje /)
-  dhs=(/ 0,0 /)
-  dhe=(/ 0,0 /)
-
-
-  call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, &
-        'box',dynhistave_domain_id)
-
-  call histbeg(dynhistave_file,iip1, rlong(:,1), jjn, &
-        rlat(1,jjb:jje), 1, iip1, 1, jjn,tau0, &
-        zjulian, tstep, thoriid, &
-        histaveid,dynhistave_domain_id)
-
-
-  !  Creation du fichier histoire pour les grilles en V et U (oblige pour l'instant,
-  !  IOIPSL ne permet pas de grilles avec des nombres de point differents dans
-  !  un meme fichier)
-  ! Grille V
-
-  jjb=jj_begin
-  jje=jj_end
-  jjn=jj_nb
-  IF (pole_sud) jjn=jjn-1
-  IF (pole_sud) jje=jje-1
-
-  do jj = jjb, jje
-    do ii = 1, iip1
-      rlong(ii,jj) = rlonv(ii) * 180. / pi
-      rlat(ii,jj) = rlatv(jj) * 180. / pi
-    enddo
-  enddo
-
-  ddid=(/ 1,2 /)
-  dsg=(/ iip1,jjm /)
-  dsl=(/ iip1,jjn /)
-  dpf=(/ 1,jjb /)
-  dpl=(/ iip1,jje /)
-  dhs=(/ 0,0 /)
-  dhe=(/ 0,0 /)
-
-
-  call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, &
-        'box',dynhistvave_domain_id)
-
-  call histbeg(dynhistvave_file,iip1, rlong(:,1), jjn, &
-        rlat(1,jjb:jje), 1, iip1, 1, jjn,tau0, &
-        zjulian, tstep, vhoriid, &
-        histvaveid,dynhistvave_domain_id)
-
-  ! Grille U
-
-  do jj = 1, jjp1
-    do ii = 1, iip1
-      rlong(ii,jj) = rlonu(ii) * 180. / pi
-      rlat(ii,jj) = rlatu(jj) * 180. / pi
-    enddo
-  enddo
-
-  jjb=jj_begin
-  jje=jj_end
-  jjn=jj_nb
-
-  ddid=(/ 1,2 /)
-  dsg=(/ iip1,jjp1 /)
-  dsl=(/ iip1,jjn /)
-  dpf=(/ 1,jjb /)
-  dpl=(/ iip1,jje /)
-  dhs=(/ 0,0 /)
-  dhe=(/ 0,0 /)
-
-
-  call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, &
-        'box',dynhistuave_domain_id)
-
-  call histbeg(dynhistuave_file,iip1, rlong(:,1), jjn, &
-        rlat(1,jjb:jje), 1, iip1, 1, jjn,tau0, &
-        zjulian, tstep, uhoriid, &
-        histuaveid,dynhistuave_domain_id)
-
-
-  !
-  !  Appel a histvert pour la grille verticale
-  !
-  call histvert(histaveid,'presnivs','Niveaux Pression&
-        &     approximatifs','mb',llm, presnivs/100., zvertiid,'down')
-  call histvert(histuaveid,'presnivs','Niveaux Pression&
-        &     approximatifs','mb',llm, presnivs/100., zvertiidv,'down')
-  call histvert(histvaveid,'presnivs','Niveaux Pression&
-        &     approximatifs','mb',llm, presnivs/100., zvertiidu,'down')
-
-  !
-  !  Appels a histdef pour la definition des variables a sauvegarder
-  !
-  !  Vents U
-  !
-  jjn=jj_nb
-  call histdef(histuaveid, 'u', 'vent u moyen ', &
-        'm/s', iip1, jjn, uhoriid, llm, 1, llm, zvertiidu, &
-        32, 'ave(X)', t_ops, t_wrt)
-
-  !
-  !  Vents V
-  !
-  if (pole_sud) jjn=jj_nb-1
-  call histdef(histvaveid, 'v', 'vent v moyen', &
-        'm/s', iip1, jjn, vhoriid, llm, 1, llm, zvertiidv, &
-        32, 'ave(X)', t_ops, t_wrt)
-
-  !
-  !  Temperature
-  !
-  jjn=jj_nb
-  call histdef(histaveid, 'temp', 'temperature moyenne', 'K', &
-        iip1, jjn, thoriid, llm, 1, llm, zvertiid, &
-        32, 'ave(X)', t_ops, t_wrt)
-  !
-  !  Temperature potentielle
-  !
-  call histdef(histaveid, 'theta', 'temperature potentielle', 'K', &
-        iip1, jjn, thoriid, llm, 1, llm, zvertiid, &
-        32, 'ave(X)', t_ops, t_wrt)
-
-
-  !
-  !  Geopotentiel
-  !
-  call histdef(histaveid, 'phi', 'geopotentiel moyen', '-', &
-        iip1, jjn, thoriid, llm, 1, llm, zvertiid, &
-        32, 'ave(X)', t_ops, t_wrt)
-  !
-  !  Traceurs
-  !
-  !    DO iq=1,nqtot
-  !      call histdef(histaveid, tracers(iq)%name,
-  ! .                            tracers(iq)%longName, '-',
-  ! .             iip1, jjn, thoriid, llm, 1, llm, zvertiid,
-  ! .             32, 'ave(X)', t_ops, t_wrt)
-  !    enddo
-  !
-  !  Masse
-  !
-  call histdef(histaveid, 'masse', 'masse moyenne', 'kg', &
-        iip1, jjn, thoriid, llm, 1, llm, zvertiid, &
-        32, 'ave(X)', t_ops, t_wrt)
-  !
-  !  Pression au sol
-  !
-  call histdef(histaveid, 'ps', 'pression naturelle au sol', 'Pa', &
-        iip1, jjn, thoriid, 1, 1, 1, -99, &
-        32, 'ave(X)', t_ops, t_wrt)
-  !
-  !  Geopotentiel au sol
-  !
-  !  call histdef(histaveid, 'phis', 'geopotentiel au sol', '-',
-  ! .             iip1, jjn, thoriid, 1, 1, 1, -99,
-  ! .             32, 'ave(X)', t_ops, t_wrt)
-  !
-  !  Fin
-  !
-  call histend(histaveid)
-  call histend(histuaveid)
-  call histend(histvaveid)
-
-end subroutine initdynav_loc
Index: /LMDZ6/trunk/libf/dyn3dmem/initdynav_loc.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/initdynav_loc.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3dmem/initdynav_loc.f90	(revision 5268)
@@ -0,0 +1,282 @@
+!
+! $Id: initdynav_p.F 1279 2009-12-10 09:02:56Z fairhead $
+!
+subroutine initdynav_loc(day0,anne0,tstep,t_ops,t_wrt)
+
+  ! This routine needs IOIPSL
+   USE IOIPSL
+
+   USE parallel_lmdz
+   use Write_field
+   use misc_mod
+    ! USE infotrac
+   use com_io_dyn_mod, only : histaveid,histvaveid,histuaveid,       &
+         dynhistave_file,dynhistvave_file,dynhistuave_file
+   USE comconst_mod, ONLY: pi
+   USE comvert_mod, ONLY: presnivs
+   USE temps_mod, ONLY: itau_dyn
+
+   implicit none
+
+  !
+  !   Routine d'initialisation des ecritures des fichiers histoires LMDZ
+  !   au format IOIPSL. Initialisation du fichier histoire moyenne.
+  !
+  !   Appels succesifs des routines: histbeg
+  !                              histhori
+  !                              histver
+  !                              histdef
+  !                              histend
+  !
+  !   Entree:
+  !
+  !  day0,anne0: date de reference
+  !  tstep : frequence d'ecriture
+  !  t_ops: frequence de l'operation pour IOIPSL
+  !  t_wrt: frequence d'ecriture sur le fichier
+  !
+  !   Sortie:
+  !  fileid: ID du fichier netcdf cree
+  !
+  !   L. Fairhead, LMD, 03/99
+  !
+  ! =====================================================================
+  !
+  !   Declarations
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom.h"
+  include "description.h"
+  include "iniprint.h"
+
+  !   Arguments
+  !
+  integer(kind=4) :: day0, anne0
+  real :: tstep, t_ops, t_wrt
+
+  ! This routine needs IOIPSL
+  !   Variables locales
+  !
+  integer :: tau0
+  real :: zjulian
+  integer :: iq
+  real :: rlong(iip1,jjp1), rlat(iip1,jjp1)
+  integer :: uhoriid, vhoriid, thoriid
+  integer :: zvertiid,zvertiidv,zvertiidu
+  integer :: ii,jj
+  integer :: zan, dayref
+  integer :: jjb,jje,jjn
+
+  ! definition du domaine d'ecriture pour le rebuild
+
+  INTEGER,DIMENSION(2) :: ddid
+  INTEGER,DIMENSION(2) :: dsg
+  INTEGER,DIMENSION(2) :: dsl
+  INTEGER,DIMENSION(2) :: dpf
+  INTEGER,DIMENSION(2) :: dpl
+  INTEGER,DIMENSION(2) :: dhs
+  INTEGER,DIMENSION(2) :: dhe
+
+  INTEGER :: dynhistave_domain_id
+  INTEGER :: dynhistvave_domain_id
+  INTEGER :: dynhistuave_domain_id
+
+  if (adjust) return
+
+  !
+  !  Initialisations
+  !
+  pi = 4. * atan (1.)
+  !
+  !  Appel a histbeg: creation du fichier netcdf et initialisations diverses
+  !
+
+  zan = anne0
+  dayref = day0
+  CALL ymds2ju(zan, 1, dayref, 0.0, zjulian)
+  tau0 = itau_dyn
+
+  do jj = 1, jjp1
+    do ii = 1, iip1
+      rlong(ii,jj) = rlonv(ii) * 180. / pi
+      rlat(ii,jj)  = rlatu(jj) * 180. / pi
+    enddo
+  enddo
+
+
+  ! Creation de 3 fichiers pour les differentes grilles horizontales
+  ! Restriction de IOIPSL: seulement 2 coordonnees dans le meme fichier
+  ! Grille Scalaire
+
+  jjb=jj_begin
+  jje=jj_end
+  jjn=jj_nb
+
+  ddid=(/ 1,2 /)
+  dsg=(/ iip1,jjp1 /)
+  dsl=(/ iip1,jjn /)
+  dpf=(/ 1,jjb /)
+  dpl=(/ iip1,jje /)
+  dhs=(/ 0,0 /)
+  dhe=(/ 0,0 /)
+
+
+  call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, &
+        'box',dynhistave_domain_id)
+
+  call histbeg(dynhistave_file,iip1, rlong(:,1), jjn, &
+        rlat(1,jjb:jje), 1, iip1, 1, jjn,tau0, &
+        zjulian, tstep, thoriid, &
+        histaveid,dynhistave_domain_id)
+
+
+  !  Creation du fichier histoire pour les grilles en V et U (oblige pour l'instant,
+  !  IOIPSL ne permet pas de grilles avec des nombres de point differents dans
+  !  un meme fichier)
+  ! Grille V
+
+  jjb=jj_begin
+  jje=jj_end
+  jjn=jj_nb
+  IF (pole_sud) jjn=jjn-1
+  IF (pole_sud) jje=jje-1
+
+  do jj = jjb, jje
+    do ii = 1, iip1
+      rlong(ii,jj) = rlonv(ii) * 180. / pi
+      rlat(ii,jj) = rlatv(jj) * 180. / pi
+    enddo
+  enddo
+
+  ddid=(/ 1,2 /)
+  dsg=(/ iip1,jjm /)
+  dsl=(/ iip1,jjn /)
+  dpf=(/ 1,jjb /)
+  dpl=(/ iip1,jje /)
+  dhs=(/ 0,0 /)
+  dhe=(/ 0,0 /)
+
+
+  call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, &
+        'box',dynhistvave_domain_id)
+
+  call histbeg(dynhistvave_file,iip1, rlong(:,1), jjn, &
+        rlat(1,jjb:jje), 1, iip1, 1, jjn,tau0, &
+        zjulian, tstep, vhoriid, &
+        histvaveid,dynhistvave_domain_id)
+
+  ! Grille U
+
+  do jj = 1, jjp1
+    do ii = 1, iip1
+      rlong(ii,jj) = rlonu(ii) * 180. / pi
+      rlat(ii,jj) = rlatu(jj) * 180. / pi
+    enddo
+  enddo
+
+  jjb=jj_begin
+  jje=jj_end
+  jjn=jj_nb
+
+  ddid=(/ 1,2 /)
+  dsg=(/ iip1,jjp1 /)
+  dsl=(/ iip1,jjn /)
+  dpf=(/ 1,jjb /)
+  dpl=(/ iip1,jje /)
+  dhs=(/ 0,0 /)
+  dhe=(/ 0,0 /)
+
+
+  call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, &
+        'box',dynhistuave_domain_id)
+
+  call histbeg(dynhistuave_file,iip1, rlong(:,1), jjn, &
+        rlat(1,jjb:jje), 1, iip1, 1, jjn,tau0, &
+        zjulian, tstep, uhoriid, &
+        histuaveid,dynhistuave_domain_id)
+
+
+  !
+  !  Appel a histvert pour la grille verticale
+  !
+  call histvert(histaveid,'presnivs','Niveaux Pression&
+        &     approximatifs','mb',llm, presnivs/100., zvertiid,'down')
+  call histvert(histuaveid,'presnivs','Niveaux Pression&
+        &     approximatifs','mb',llm, presnivs/100., zvertiidv,'down')
+  call histvert(histvaveid,'presnivs','Niveaux Pression&
+        &     approximatifs','mb',llm, presnivs/100., zvertiidu,'down')
+
+  !
+  !  Appels a histdef pour la definition des variables a sauvegarder
+  !
+  !  Vents U
+  !
+  jjn=jj_nb
+  call histdef(histuaveid, 'u', 'vent u moyen ', &
+        'm/s', iip1, jjn, uhoriid, llm, 1, llm, zvertiidu, &
+        32, 'ave(X)', t_ops, t_wrt)
+
+  !
+  !  Vents V
+  !
+  if (pole_sud) jjn=jj_nb-1
+  call histdef(histvaveid, 'v', 'vent v moyen', &
+        'm/s', iip1, jjn, vhoriid, llm, 1, llm, zvertiidv, &
+        32, 'ave(X)', t_ops, t_wrt)
+
+  !
+  !  Temperature
+  !
+  jjn=jj_nb
+  call histdef(histaveid, 'temp', 'temperature moyenne', 'K', &
+        iip1, jjn, thoriid, llm, 1, llm, zvertiid, &
+        32, 'ave(X)', t_ops, t_wrt)
+  !
+  !  Temperature potentielle
+  !
+  call histdef(histaveid, 'theta', 'temperature potentielle', 'K', &
+        iip1, jjn, thoriid, llm, 1, llm, zvertiid, &
+        32, 'ave(X)', t_ops, t_wrt)
+
+
+  !
+  !  Geopotentiel
+  !
+  call histdef(histaveid, 'phi', 'geopotentiel moyen', '-', &
+        iip1, jjn, thoriid, llm, 1, llm, zvertiid, &
+        32, 'ave(X)', t_ops, t_wrt)
+  !
+  !  Traceurs
+  !
+  !    DO iq=1,nqtot
+  !      call histdef(histaveid, tracers(iq)%name,
+  ! .                            tracers(iq)%longName, '-',
+  ! .             iip1, jjn, thoriid, llm, 1, llm, zvertiid,
+  ! .             32, 'ave(X)', t_ops, t_wrt)
+  !    enddo
+  !
+  !  Masse
+  !
+  call histdef(histaveid, 'masse', 'masse moyenne', 'kg', &
+        iip1, jjn, thoriid, llm, 1, llm, zvertiid, &
+        32, 'ave(X)', t_ops, t_wrt)
+  !
+  !  Pression au sol
+  !
+  call histdef(histaveid, 'ps', 'pression naturelle au sol', 'Pa', &
+        iip1, jjn, thoriid, 1, 1, 1, -99, &
+        32, 'ave(X)', t_ops, t_wrt)
+  !
+  !  Geopotentiel au sol
+  !
+  !  call histdef(histaveid, 'phis', 'geopotentiel au sol', '-',
+  ! .             iip1, jjn, thoriid, 1, 1, 1, -99,
+  ! .             32, 'ave(X)', t_ops, t_wrt)
+  !
+  !  Fin
+  !
+  call histend(histaveid)
+  call histend(histuaveid)
+  call histend(histvaveid)
+
+end subroutine initdynav_loc
Index: DZ6/trunk/libf/dyn3dmem/initfluxsto_p.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/initfluxsto_p.F90	(revision 5267)
+++ 	(revision )
@@ -1,289 +1,0 @@
-!
-! $Id$
-!
-subroutine initfluxsto_p &
-        (infile,tstep,t_ops,t_wrt, &
-        fileid,filevid,filedid)
-
-  ! This routine needs IOIPSL
-   USE IOIPSL
-
-   USE parallel_lmdz
-   use Write_field
-   use misc_mod
-   USE comconst_mod, ONLY: pi
-   USE comvert_mod, ONLY: nivsigs
-   USE temps_mod, ONLY: annee_ref, day_ref, itau_dyn
-
-  implicit none
-
-  !
-  !   Routine d'initialisation des ecritures des fichiers histoires LMDZ
-  !   au format IOIPSL
-  !
-  !   Appels succesifs des routines: histbeg
-  !                              histhori
-  !                              histver
-  !                              histdef
-  !                              histend
-  !
-  !   Entree:
-  !
-  !  infile: nom du fichier histoire a creer
-  !  day0,anne0: date de reference
-  !  tstep: duree du pas de temps en seconde
-  !  t_ops: frequence de l'operation pour IOIPSL
-  !  t_wrt: frequence d'ecriture sur le fichier
-  !
-  !   Sortie:
-  !  fileid: ID du fichier netcdf cree
-  !  filevid:ID du fichier netcdf pour la grille v
-  !
-  !   L. Fairhead, LMD, 03/99
-  !
-  ! =====================================================================
-  !
-  !   Declarations
-  include "dimensions.h"
-  include "paramet.h"
-  include "comgeom.h"
-  include "description.h"
-  include "iniprint.h"
-
-  !   Arguments
-  !
-  character(len=*) :: infile
-  real :: tstep, t_ops, t_wrt
-  integer :: fileid, filevid,filedid
-
-  ! This routine needs IOIPSL
-  !   Variables locales
-  !
-  real :: nivd(1)
-  integer :: tau0
-  real :: zjulian
-  character(len=3) :: str
-  character(len=10) :: ctrac
-  integer :: iq
-  real :: rlong(iip1,jjp1), rlat(iip1,jjp1),rl(1,1)
-  integer :: uhoriid, vhoriid, thoriid, zvertiid,dhoriid,dvertiid
-  integer :: ii,jj
-  integer :: zan, idayref
-  logical :: ok_sync
-  integer :: jjb,jje,jjn
-
-  ! definition du domaine d'ecriture pour le rebuild
-
-  INTEGER,DIMENSION(2) :: ddid
-  INTEGER,DIMENSION(2) :: dsg
-  INTEGER,DIMENSION(2) :: dsl
-  INTEGER,DIMENSION(2) :: dpf
-  INTEGER,DIMENSION(2) :: dpl
-  INTEGER,DIMENSION(2) :: dhs
-  INTEGER,DIMENSION(2) :: dhe
-
-  INTEGER :: dynu_domain_id
-  INTEGER :: dynv_domain_id
-
-  !
-  !  Initialisations
-  !
-  pi = 4. * atan (1.)
-  str='q  '
-  ctrac = 'traceur   '
-  ok_sync = .true.
-  !
-  !  Appel a histbeg: creation du fichier netcdf et initialisations diverses
-  !
-
-  zan = annee_ref
-  idayref = day_ref
-  CALL ymds2ju(zan, 1, idayref, 0.0, zjulian)
-  tau0 = itau_dyn
-
-    do jj = 1, jjp1
-    do ii = 1, iip1
-      rlong(ii,jj) = rlonu(ii) * 180. / pi
-      rlat(ii,jj) = rlatu(jj) * 180. / pi
-    enddo
-  enddo
-
-  jjb=jj_begin
-  jje=jj_end
-  jjn=jj_nb
-
-  ddid=(/ 1,2 /)
-  dsg=(/ iip1,jjp1 /)
-  dsl=(/ iip1,jjn /)
-  dpf=(/ 1,jjb /)
-  dpl=(/ iip1,jje /)
-  dhs=(/ 0,0 /)
-  dhe=(/ 0,0 /)
-
-  call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, &
-        'box',dynu_domain_id)
-
-  call histbeg(trim(infile),iip1, rlong(:,1), jjn, rlat(1,jjb:jje), &
-        1, iip1, 1, jjn, tau0, zjulian, tstep, uhoriid, &
-        fileid,dynu_domain_id)
-  !
-  !  Creation du fichier histoire pour la grille en V (oblige pour l'instant,
-  !  IOIPSL ne permet pas de grilles avec des nombres de point differents dans
-  !  un meme fichier)
-
-
-  do jj = 1, jjm
-    do ii = 1, iip1
-      rlong(ii,jj) = rlonv(ii) * 180. / pi
-      rlat(ii,jj) = rlatv(jj) * 180. / pi
-    enddo
-  enddo
-
-  jjb=jj_begin
-  jje=jj_end
-  jjn=jj_nb
-  if (pole_sud) jje=jj_end-1
-  if (pole_sud) jjn=jj_nb-1
-
-  ddid=(/ 1,2 /)
-  dsg=(/ iip1,jjm /)
-  dsl=(/ iip1,jjn /)
-  dpf=(/ 1,jjb /)
-  dpl=(/ iip1,jje /)
-  dhs=(/ 0,0 /)
-  dhe=(/ 0,0 /)
-
-  call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, &
-        'box',dynv_domain_id)
-
-  call histbeg('fluxstokev',iip1, rlong(:,1), jjn, rlat(1,jjb:jje), &
-        1, iip1, 1, jjn,tau0, zjulian, tstep, vhoriid, &
-        filevid,dynv_domain_id)
-
-  rl(1,1) = 1.
-
-  if (mpi_rank==0) then
-
-    call histbeg('defstoke.nc', 1, rl, 1, rl, &
-          1, 1, 1, 1, &
-          tau0, zjulian, tstep, dhoriid, filedid)
-
-  endif
-  !
-  !  Appel a histhori pour rajouter les autres grilles horizontales
-  !
-  do jj = 1, jjp1
-    do ii = 1, iip1
-      rlong(ii,jj) = rlonv(ii) * 180. / pi
-      rlat(ii,jj) = rlatu(jj) * 180. / pi
-    enddo
-  enddo
-
-  jjb=jj_begin
-  jje=jj_end
-  jjn=jj_nb
-
-  call histhori(fileid, iip1, rlong(:,jjb:jje),jjn,rlat(:,jjb:jje), &
-        'scalar','Grille points scalaires', thoriid)
-
-  !
-  !  Appel a histvert pour la grille verticale
-  !
-  call histvert(fileid, 'sig_s', 'Niveaux sigma', &
-        'sigma_level', &
-        llm, nivsigs, zvertiid)
-  ! Pour le fichier V
-  call histvert(filevid, 'sig_s', 'Niveaux sigma', &
-        'sigma_level', &
-        llm, nivsigs, zvertiid)
-  ! pour le fichier def
-  if (mpi_rank==0) then
-     nivd(1) = 1
-     call histvert(filedid, 'sig_s', 'Niveaux sigma', &
-           'sigma_level', &
-           1, nivd, dvertiid)
-  endif
-  !
-  !  Appels a histdef pour la definition des variables a sauvegarder
-
-    CALL histdef(fileid, "phis", "Surface geop. height", "-", &
-          iip1,jjn,thoriid, 1,1,1, -99, 32, &
-          "once", t_ops, t_wrt)
-
-     CALL histdef(fileid, "aire", "Grid area", "-", &
-           iip1,jjn,thoriid, 1,1,1, -99, 32, &
-           "once", t_ops, t_wrt)
-
-    if (mpi_rank==0) then
-
-    CALL histdef(filedid, "dtvr", "tps dyn", "s", &
-          1,1,dhoriid, 1,1,1, -99, 32, &
-          "once", t_ops, t_wrt)
-
-     CALL histdef(filedid, "istdyn", "tps stock", "s", &
-           1,1,dhoriid, 1,1,1, -99, 32, &
-           "once", t_ops, t_wrt)
-
-     CALL histdef(filedid, "istphy", "tps stock phy", "s", &
-           1,1,dhoriid, 1,1,1, -99, 32, &
-           "once", t_ops, t_wrt)
-
-    endif
-  !
-  ! Masse
-  !
-  call histdef(fileid, 'masse', 'Masse', 'kg', &
-        iip1, jjn, thoriid, llm, 1, llm, zvertiid, &
-        32, 'inst(X)', t_ops, t_wrt)
-  !
-  !  Pbaru
-  !
-  call histdef(fileid, 'pbaru', 'flx de masse zonal', 'kg m/s', &
-        iip1, jjn, uhoriid, llm, 1, llm, zvertiid, &
-        32, 'inst(X)', t_ops, t_wrt)
-
-  !
-  !  Pbarv
-  !
-  if (pole_sud) jjn=jj_nb-1
-
-  call histdef(filevid, 'pbarv', 'flx de masse mer', 'kg m/s', &
-        iip1, jjn, vhoriid, llm, 1, llm, zvertiid, &
-        32, 'inst(X)', t_ops, t_wrt)
-  !
-  !  w
-  !
-  if (pole_sud) jjn=jj_nb
-  call histdef(fileid, 'w', 'flx de masse vert', 'kg m/s', &
-        iip1, jjn, thoriid, llm, 1, llm, zvertiid, &
-        32, 'inst(X)', t_ops, t_wrt)
-
-  !
-  !  Temperature potentielle
-  !
-  call histdef(fileid, 'teta', 'temperature potentielle', '-', &
-        iip1, jjn, thoriid, llm, 1, llm, zvertiid, &
-        32, 'inst(X)', t_ops, t_wrt)
-  !
-
-  !
-  ! Geopotentiel
-  !
-  call histdef(fileid, 'phi', 'geopotentiel instantane', '-', &
-        iip1, jjn, thoriid, llm, 1, llm, zvertiid, &
-        32, 'inst(X)', t_ops, t_wrt)
-  !
-  !  Fin
-  !
-  call histend(fileid)
-  call histend(filevid)
-  if (mpi_rank==0) call histend(filedid)
-  if (ok_sync) then
-    call histsync(fileid)
-    call histsync(filevid)
-    if (mpi_rank==0) call histsync(filedid)
-  endif
-
-
-  return
-end subroutine initfluxsto_p
Index: /LMDZ6/trunk/libf/dyn3dmem/initfluxsto_p.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/initfluxsto_p.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3dmem/initfluxsto_p.f90	(revision 5268)
@@ -0,0 +1,289 @@
+!
+! $Id$
+!
+subroutine initfluxsto_p &
+        (infile,tstep,t_ops,t_wrt, &
+        fileid,filevid,filedid)
+
+  ! This routine needs IOIPSL
+   USE IOIPSL
+
+   USE parallel_lmdz
+   use Write_field
+   use misc_mod
+   USE comconst_mod, ONLY: pi
+   USE comvert_mod, ONLY: nivsigs
+   USE temps_mod, ONLY: annee_ref, day_ref, itau_dyn
+
+  implicit none
+
+  !
+  !   Routine d'initialisation des ecritures des fichiers histoires LMDZ
+  !   au format IOIPSL
+  !
+  !   Appels succesifs des routines: histbeg
+  !                              histhori
+  !                              histver
+  !                              histdef
+  !                              histend
+  !
+  !   Entree:
+  !
+  !  infile: nom du fichier histoire a creer
+  !  day0,anne0: date de reference
+  !  tstep: duree du pas de temps en seconde
+  !  t_ops: frequence de l'operation pour IOIPSL
+  !  t_wrt: frequence d'ecriture sur le fichier
+  !
+  !   Sortie:
+  !  fileid: ID du fichier netcdf cree
+  !  filevid:ID du fichier netcdf pour la grille v
+  !
+  !   L. Fairhead, LMD, 03/99
+  !
+  ! =====================================================================
+  !
+  !   Declarations
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom.h"
+  include "description.h"
+  include "iniprint.h"
+
+  !   Arguments
+  !
+  character(len=*) :: infile
+  real :: tstep, t_ops, t_wrt
+  integer :: fileid, filevid,filedid
+
+  ! This routine needs IOIPSL
+  !   Variables locales
+  !
+  real :: nivd(1)
+  integer :: tau0
+  real :: zjulian
+  character(len=3) :: str
+  character(len=10) :: ctrac
+  integer :: iq
+  real :: rlong(iip1,jjp1), rlat(iip1,jjp1),rl(1,1)
+  integer :: uhoriid, vhoriid, thoriid, zvertiid,dhoriid,dvertiid
+  integer :: ii,jj
+  integer :: zan, idayref
+  logical :: ok_sync
+  integer :: jjb,jje,jjn
+
+  ! definition du domaine d'ecriture pour le rebuild
+
+  INTEGER,DIMENSION(2) :: ddid
+  INTEGER,DIMENSION(2) :: dsg
+  INTEGER,DIMENSION(2) :: dsl
+  INTEGER,DIMENSION(2) :: dpf
+  INTEGER,DIMENSION(2) :: dpl
+  INTEGER,DIMENSION(2) :: dhs
+  INTEGER,DIMENSION(2) :: dhe
+
+  INTEGER :: dynu_domain_id
+  INTEGER :: dynv_domain_id
+
+  !
+  !  Initialisations
+  !
+  pi = 4. * atan (1.)
+  str='q  '
+  ctrac = 'traceur   '
+  ok_sync = .true.
+  !
+  !  Appel a histbeg: creation du fichier netcdf et initialisations diverses
+  !
+
+  zan = annee_ref
+  idayref = day_ref
+  CALL ymds2ju(zan, 1, idayref, 0.0, zjulian)
+  tau0 = itau_dyn
+
+    do jj = 1, jjp1
+    do ii = 1, iip1
+      rlong(ii,jj) = rlonu(ii) * 180. / pi
+      rlat(ii,jj) = rlatu(jj) * 180. / pi
+    enddo
+  enddo
+
+  jjb=jj_begin
+  jje=jj_end
+  jjn=jj_nb
+
+  ddid=(/ 1,2 /)
+  dsg=(/ iip1,jjp1 /)
+  dsl=(/ iip1,jjn /)
+  dpf=(/ 1,jjb /)
+  dpl=(/ iip1,jje /)
+  dhs=(/ 0,0 /)
+  dhe=(/ 0,0 /)
+
+  call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, &
+        'box',dynu_domain_id)
+
+  call histbeg(trim(infile),iip1, rlong(:,1), jjn, rlat(1,jjb:jje), &
+        1, iip1, 1, jjn, tau0, zjulian, tstep, uhoriid, &
+        fileid,dynu_domain_id)
+  !
+  !  Creation du fichier histoire pour la grille en V (oblige pour l'instant,
+  !  IOIPSL ne permet pas de grilles avec des nombres de point differents dans
+  !  un meme fichier)
+
+
+  do jj = 1, jjm
+    do ii = 1, iip1
+      rlong(ii,jj) = rlonv(ii) * 180. / pi
+      rlat(ii,jj) = rlatv(jj) * 180. / pi
+    enddo
+  enddo
+
+  jjb=jj_begin
+  jje=jj_end
+  jjn=jj_nb
+  if (pole_sud) jje=jj_end-1
+  if (pole_sud) jjn=jj_nb-1
+
+  ddid=(/ 1,2 /)
+  dsg=(/ iip1,jjm /)
+  dsl=(/ iip1,jjn /)
+  dpf=(/ 1,jjb /)
+  dpl=(/ iip1,jje /)
+  dhs=(/ 0,0 /)
+  dhe=(/ 0,0 /)
+
+  call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, &
+        'box',dynv_domain_id)
+
+  call histbeg('fluxstokev',iip1, rlong(:,1), jjn, rlat(1,jjb:jje), &
+        1, iip1, 1, jjn,tau0, zjulian, tstep, vhoriid, &
+        filevid,dynv_domain_id)
+
+  rl(1,1) = 1.
+
+  if (mpi_rank==0) then
+
+    call histbeg('defstoke.nc', 1, rl, 1, rl, &
+          1, 1, 1, 1, &
+          tau0, zjulian, tstep, dhoriid, filedid)
+
+  endif
+  !
+  !  Appel a histhori pour rajouter les autres grilles horizontales
+  !
+  do jj = 1, jjp1
+    do ii = 1, iip1
+      rlong(ii,jj) = rlonv(ii) * 180. / pi
+      rlat(ii,jj) = rlatu(jj) * 180. / pi
+    enddo
+  enddo
+
+  jjb=jj_begin
+  jje=jj_end
+  jjn=jj_nb
+
+  call histhori(fileid, iip1, rlong(:,jjb:jje),jjn,rlat(:,jjb:jje), &
+        'scalar','Grille points scalaires', thoriid)
+
+  !
+  !  Appel a histvert pour la grille verticale
+  !
+  call histvert(fileid, 'sig_s', 'Niveaux sigma', &
+        'sigma_level', &
+        llm, nivsigs, zvertiid)
+  ! Pour le fichier V
+  call histvert(filevid, 'sig_s', 'Niveaux sigma', &
+        'sigma_level', &
+        llm, nivsigs, zvertiid)
+  ! pour le fichier def
+  if (mpi_rank==0) then
+     nivd(1) = 1
+     call histvert(filedid, 'sig_s', 'Niveaux sigma', &
+           'sigma_level', &
+           1, nivd, dvertiid)
+  endif
+  !
+  !  Appels a histdef pour la definition des variables a sauvegarder
+
+    CALL histdef(fileid, "phis", "Surface geop. height", "-", &
+          iip1,jjn,thoriid, 1,1,1, -99, 32, &
+          "once", t_ops, t_wrt)
+
+     CALL histdef(fileid, "aire", "Grid area", "-", &
+           iip1,jjn,thoriid, 1,1,1, -99, 32, &
+           "once", t_ops, t_wrt)
+
+    if (mpi_rank==0) then
+
+    CALL histdef(filedid, "dtvr", "tps dyn", "s", &
+          1,1,dhoriid, 1,1,1, -99, 32, &
+          "once", t_ops, t_wrt)
+
+     CALL histdef(filedid, "istdyn", "tps stock", "s", &
+           1,1,dhoriid, 1,1,1, -99, 32, &
+           "once", t_ops, t_wrt)
+
+     CALL histdef(filedid, "istphy", "tps stock phy", "s", &
+           1,1,dhoriid, 1,1,1, -99, 32, &
+           "once", t_ops, t_wrt)
+
+    endif
+  !
+  ! Masse
+  !
+  call histdef(fileid, 'masse', 'Masse', 'kg', &
+        iip1, jjn, thoriid, llm, 1, llm, zvertiid, &
+        32, 'inst(X)', t_ops, t_wrt)
+  !
+  !  Pbaru
+  !
+  call histdef(fileid, 'pbaru', 'flx de masse zonal', 'kg m/s', &
+        iip1, jjn, uhoriid, llm, 1, llm, zvertiid, &
+        32, 'inst(X)', t_ops, t_wrt)
+
+  !
+  !  Pbarv
+  !
+  if (pole_sud) jjn=jj_nb-1
+
+  call histdef(filevid, 'pbarv', 'flx de masse mer', 'kg m/s', &
+        iip1, jjn, vhoriid, llm, 1, llm, zvertiid, &
+        32, 'inst(X)', t_ops, t_wrt)
+  !
+  !  w
+  !
+  if (pole_sud) jjn=jj_nb
+  call histdef(fileid, 'w', 'flx de masse vert', 'kg m/s', &
+        iip1, jjn, thoriid, llm, 1, llm, zvertiid, &
+        32, 'inst(X)', t_ops, t_wrt)
+
+  !
+  !  Temperature potentielle
+  !
+  call histdef(fileid, 'teta', 'temperature potentielle', '-', &
+        iip1, jjn, thoriid, llm, 1, llm, zvertiid, &
+        32, 'inst(X)', t_ops, t_wrt)
+  !
+
+  !
+  ! Geopotentiel
+  !
+  call histdef(fileid, 'phi', 'geopotentiel instantane', '-', &
+        iip1, jjn, thoriid, llm, 1, llm, zvertiid, &
+        32, 'inst(X)', t_ops, t_wrt)
+  !
+  !  Fin
+  !
+  call histend(fileid)
+  call histend(filevid)
+  if (mpi_rank==0) call histend(filedid)
+  if (ok_sync) then
+    call histsync(fileid)
+    call histsync(filevid)
+    if (mpi_rank==0) call histsync(filedid)
+  endif
+
+
+  return
+end subroutine initfluxsto_p
Index: DZ6/trunk/libf/dyn3dmem/inithist_loc.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/inithist_loc.F90	(revision 5267)
+++ 	(revision )
@@ -1,282 +1,0 @@
-!
-! $Id: initdynav_p.F 1279 2009-12-10 09:02:56Z fairhead $
-!
-subroutine inithist_loc(day0,anne0,tstep,t_ops,t_wrt)
-
-  ! This routine needs IOIPSL
-   USE IOIPSL
-
-   USE parallel_lmdz
-   use Write_field
-   use misc_mod
-   use com_io_dyn_mod, only : histid,histvid,histuid,               &
-         dynhist_file,dynhistv_file,dynhistu_file
-   USE comconst_mod, ONLY: pi
-   USE comvert_mod, ONLY: presnivs
-   USE temps_mod, ONLY: itau_dyn
-
-   implicit none
-
-  !
-  !   Routine d'initialisation des ecritures des fichiers histoires LMDZ
-  !   au format IOIPSL
-  !
-  !   Appels succesifs des routines: histbeg
-  !                              histhori
-  !                              histver
-  !                              histdef
-  !                              histend
-  !
-  !   Entree:
-  !
-  !  day0,anne0: date de reference
-  !  tstep: duree du pas de temps en seconde
-  !  t_ops: frequence de l'operation pour IOIPSL
-  !  t_wrt: frequence d'ecriture sur le fichier
-  !  nq: nombre de traceurs
-  !
-  !
-  !   L. Fairhead, LMD, 03/99
-  !
-  ! =====================================================================
-  !
-  !   Declarations
-  include "dimensions.h"
-  include "paramet.h"
-  include "comgeom.h"
-  include "description.h"
-  include "iniprint.h"
-
-  !   Arguments
-  !
-  integer :: day0, anne0
-  real :: tstep, t_ops, t_wrt
-
-  ! This routine needs IOIPSL
-  !   Variables locales
-  !
-  integer :: tau0
-  real :: zjulian
-  integer :: iq
-  real :: rlong(iip1,jjp1), rlat(iip1,jjp1)
-  integer :: uhoriid, vhoriid, thoriid
-  integer :: zvertiid,zvertiidv,zvertiidu
-  integer :: ii,jj
-  integer :: zan, dayref
-  integer :: jjb,jje,jjn
-
-  ! definition du domaine d'ecriture pour le rebuild
-
-  INTEGER,DIMENSION(2) :: ddid
-  INTEGER,DIMENSION(2) :: dsg
-  INTEGER,DIMENSION(2) :: dsl
-  INTEGER,DIMENSION(2) :: dpf
-  INTEGER,DIMENSION(2) :: dpl
-  INTEGER,DIMENSION(2) :: dhs
-  INTEGER,DIMENSION(2) :: dhe
-
-  INTEGER :: dynhist_domain_id
-  INTEGER :: dynhistv_domain_id
-  INTEGER :: dynhistu_domain_id
-
-  if (adjust) return
-
-  !
-  !  Initialisations
-  !
-  pi = 4. * atan (1.)
-  !
-  !  Appel a histbeg: creation du fichier netcdf et initialisations diverses
-  !
-
-  zan = anne0
-  dayref = day0
-  CALL ymds2ju(zan, 1, dayref, 0.0, zjulian)
-  tau0 = itau_dyn
-
-  do jj = 1, jjp1
-    do ii = 1, iip1
-      rlong(ii,jj) = rlonv(ii) * 180. / pi
-      rlat(ii,jj)  = rlatu(jj) * 180. / pi
-    enddo
-  enddo
-
-
-  ! Creation de 3 fichiers pour les differentes grilles horizontales
-  ! Restriction de IOIPSL: seulement 2 coordonnees dans le meme fichier
-  ! Grille Scalaire
-
-  jjb=jj_begin
-  jje=jj_end
-  jjn=jj_nb
-
-  ddid=(/ 1,2 /)
-  dsg=(/ iip1,jjp1 /)
-  dsl=(/ iip1,jjn /)
-  dpf=(/ 1,jjb /)
-  dpl=(/ iip1,jje /)
-  dhs=(/ 0,0 /)
-  dhe=(/ 0,0 /)
-
-
-  call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, &
-        'box',dynhist_domain_id)
-
-  call histbeg(dynhist_file,iip1, rlong(:,1), jjn, &
-        rlat(1,jjb:jje), 1, iip1, 1, jjn,tau0, &
-        zjulian, tstep, thoriid, &
-        histid,dynhist_domain_id)
-
-
-  !  Creation du fichier histoire pour les grilles en V et U (oblige pour l'instant,
-  !  IOIPSL ne permet pas de grilles avec des nombres de point differents dans
-  !  un meme fichier)
-  ! Grille V
-
-  jjb=jj_begin
-  jje=jj_end
-  jjn=jj_nb
-  IF (pole_sud) jjn=jjn-1
-  IF (pole_sud) jje=jje-1
-
-  do jj = jjb, jje
-    do ii = 1, iip1
-      rlong(ii,jj) = rlonv(ii) * 180. / pi
-      rlat(ii,jj) = rlatv(jj) * 180. / pi
-    enddo
-  enddo
-
-  ddid=(/ 1,2 /)
-  dsg=(/ iip1,jjm /)
-  dsl=(/ iip1,jjn /)
-  dpf=(/ 1,jjb /)
-  dpl=(/ iip1,jje /)
-  dhs=(/ 0,0 /)
-  dhe=(/ 0,0 /)
-
-
-  call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, &
-        'box',dynhistv_domain_id)
-
-  call histbeg(dynhistv_file,iip1, rlong(:,1), jjn, &
-        rlat(1,jjb:jje), 1, iip1, 1, jjn,tau0, &
-        zjulian, tstep, vhoriid, &
-        histvid,dynhistv_domain_id)
-
-  ! Grille U
-
-  do jj = 1, jjp1
-    do ii = 1, iip1
-      rlong(ii,jj) = rlonu(ii) * 180. / pi
-      rlat(ii,jj) = rlatu(jj) * 180. / pi
-    enddo
-  enddo
-
-  jjb=jj_begin
-  jje=jj_end
-  jjn=jj_nb
-
-  ddid=(/ 1,2 /)
-  dsg=(/ iip1,jjp1 /)
-  dsl=(/ iip1,jjn /)
-  dpf=(/ 1,jjb /)
-  dpl=(/ iip1,jje /)
-  dhs=(/ 0,0 /)
-  dhe=(/ 0,0 /)
-
-
-  call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, &
-        'box',dynhistu_domain_id)
-
-  call histbeg(dynhistu_file,iip1, rlong(:,1), jjn, &
-        rlat(1,jjb:jje), 1, iip1, 1, jjn,tau0, &
-        zjulian, tstep, uhoriid, &
-        histuid,dynhistu_domain_id)
-
-
-  ! -------------------------------------------------------------
-  !  Appel a histvert pour la grille verticale
-  ! -------------------------------------------------------------
-  call histvert(histid, 'presnivs', 'Niveaux pression','mb', &
-        llm, presnivs/100., zvertiid,'down')
-  call histvert(histvid, 'presnivs', 'Niveaux pression','mb', &
-        llm, presnivs/100., zvertiidv,'down')
-  call histvert(histuid, 'presnivs', 'Niveaux pression','mb', &
-        llm, presnivs/100., zvertiidu,'down')
-
-  !
-  ! -------------------------------------------------------------
-  !  Appels a histdef pour la definition des variables a sauvegarder
-  ! -------------------------------------------------------------
-  !
-  !  Vents U
-  !
-  jjn=jj_nb
-  call histdef(histuid, 'u', 'vent u', &
-        'm/s', iip1, jjn, uhoriid, llm, 1, llm, zvertiidu, &
-        32, 'inst(X)', t_ops, t_wrt)
-
-  !
-  !  Vents V
-  !
-  if (pole_sud) jjn=jj_nb-1
-  call histdef(histvid, 'v', 'vent v', &
-        'm/s', iip1, jjn, vhoriid, llm, 1, llm, zvertiidv, &
-        32, 'inst(X)', t_ops, t_wrt)
-
-  !
-  !  Temperature
-  !
-  jjn=jj_nb
-  call histdef(histid, 'temp', 'temperature', 'K', &
-        iip1, jjn, thoriid, llm, 1, llm, zvertiid, &
-        32, 'inst(X)', t_ops, t_wrt)
-  !
-  !  Temperature potentielle
-  !
-  call histdef(histid, 'theta', 'temperature potentielle', 'K', &
-        iip1, jjn, thoriid, llm, 1, llm, zvertiid, &
-        32, 'inst(X)', t_ops, t_wrt)
-
-
-  !
-  !  Geopotentiel
-  !
-  call histdef(histid, 'phi', 'geopotentiel', '-', &
-        iip1, jjn, thoriid, llm, 1, llm, zvertiid, &
-        32, 'inst(X)', t_ops, t_wrt)
-  !
-  !  Traceurs
-  !
-  !    DO iq=1,nqtot
-  !      call histdef(histid, tracers(iq)%name,
-  ! .             tracers(iq)%longName, '-',
-  ! .             iip1, jjn, thoriid, llm, 1, llm, zvertiid,
-  ! .             32, 'inst(X)', t_ops, t_wrt)
-  !    enddo
-  !
-  !  Masse
-  !
-  call histdef(histid, 'masse', 'masse', 'kg', &
-        iip1, jjn, thoriid, llm, 1, llm, zvertiid, &
-        32, 'inst(X)', t_ops, t_wrt)
-  !
-  !  Pression au sol
-  !
-  call histdef(histid, 'ps', 'pression naturelle au sol', 'Pa', &
-        iip1, jjn, thoriid, 1, 1, 1, -99, &
-        32, 'inst(X)', t_ops, t_wrt)
-  !
-  !  Geopotentiel au sol
-  !
-  !  call histdef(histid, 'phis', 'geopotentiel au sol', '-',
-  ! .             iip1, jjn, thoriid, 1, 1, 1, -99,
-  ! .             32, 'inst(X)', t_ops, t_wrt)
-  !
-  !  Fin
-  !
-  call histend(histid)
-  call histend(histuid)
-  call histend(histvid)
-
-end subroutine inithist_loc
Index: /LMDZ6/trunk/libf/dyn3dmem/inithist_loc.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/inithist_loc.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3dmem/inithist_loc.f90	(revision 5268)
@@ -0,0 +1,282 @@
+!
+! $Id: initdynav_p.F 1279 2009-12-10 09:02:56Z fairhead $
+!
+subroutine inithist_loc(day0,anne0,tstep,t_ops,t_wrt)
+
+  ! This routine needs IOIPSL
+   USE IOIPSL
+
+   USE parallel_lmdz
+   use Write_field
+   use misc_mod
+   use com_io_dyn_mod, only : histid,histvid,histuid,               &
+         dynhist_file,dynhistv_file,dynhistu_file
+   USE comconst_mod, ONLY: pi
+   USE comvert_mod, ONLY: presnivs
+   USE temps_mod, ONLY: itau_dyn
+
+   implicit none
+
+  !
+  !   Routine d'initialisation des ecritures des fichiers histoires LMDZ
+  !   au format IOIPSL
+  !
+  !   Appels succesifs des routines: histbeg
+  !                              histhori
+  !                              histver
+  !                              histdef
+  !                              histend
+  !
+  !   Entree:
+  !
+  !  day0,anne0: date de reference
+  !  tstep: duree du pas de temps en seconde
+  !  t_ops: frequence de l'operation pour IOIPSL
+  !  t_wrt: frequence d'ecriture sur le fichier
+  !  nq: nombre de traceurs
+  !
+  !
+  !   L. Fairhead, LMD, 03/99
+  !
+  ! =====================================================================
+  !
+  !   Declarations
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom.h"
+  include "description.h"
+  include "iniprint.h"
+
+  !   Arguments
+  !
+  integer :: day0, anne0
+  real :: tstep, t_ops, t_wrt
+
+  ! This routine needs IOIPSL
+  !   Variables locales
+  !
+  integer :: tau0
+  real :: zjulian
+  integer :: iq
+  real :: rlong(iip1,jjp1), rlat(iip1,jjp1)
+  integer :: uhoriid, vhoriid, thoriid
+  integer :: zvertiid,zvertiidv,zvertiidu
+  integer :: ii,jj
+  integer :: zan, dayref
+  integer :: jjb,jje,jjn
+
+  ! definition du domaine d'ecriture pour le rebuild
+
+  INTEGER,DIMENSION(2) :: ddid
+  INTEGER,DIMENSION(2) :: dsg
+  INTEGER,DIMENSION(2) :: dsl
+  INTEGER,DIMENSION(2) :: dpf
+  INTEGER,DIMENSION(2) :: dpl
+  INTEGER,DIMENSION(2) :: dhs
+  INTEGER,DIMENSION(2) :: dhe
+
+  INTEGER :: dynhist_domain_id
+  INTEGER :: dynhistv_domain_id
+  INTEGER :: dynhistu_domain_id
+
+  if (adjust) return
+
+  !
+  !  Initialisations
+  !
+  pi = 4. * atan (1.)
+  !
+  !  Appel a histbeg: creation du fichier netcdf et initialisations diverses
+  !
+
+  zan = anne0
+  dayref = day0
+  CALL ymds2ju(zan, 1, dayref, 0.0, zjulian)
+  tau0 = itau_dyn
+
+  do jj = 1, jjp1
+    do ii = 1, iip1
+      rlong(ii,jj) = rlonv(ii) * 180. / pi
+      rlat(ii,jj)  = rlatu(jj) * 180. / pi
+    enddo
+  enddo
+
+
+  ! Creation de 3 fichiers pour les differentes grilles horizontales
+  ! Restriction de IOIPSL: seulement 2 coordonnees dans le meme fichier
+  ! Grille Scalaire
+
+  jjb=jj_begin
+  jje=jj_end
+  jjn=jj_nb
+
+  ddid=(/ 1,2 /)
+  dsg=(/ iip1,jjp1 /)
+  dsl=(/ iip1,jjn /)
+  dpf=(/ 1,jjb /)
+  dpl=(/ iip1,jje /)
+  dhs=(/ 0,0 /)
+  dhe=(/ 0,0 /)
+
+
+  call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, &
+        'box',dynhist_domain_id)
+
+  call histbeg(dynhist_file,iip1, rlong(:,1), jjn, &
+        rlat(1,jjb:jje), 1, iip1, 1, jjn,tau0, &
+        zjulian, tstep, thoriid, &
+        histid,dynhist_domain_id)
+
+
+  !  Creation du fichier histoire pour les grilles en V et U (oblige pour l'instant,
+  !  IOIPSL ne permet pas de grilles avec des nombres de point differents dans
+  !  un meme fichier)
+  ! Grille V
+
+  jjb=jj_begin
+  jje=jj_end
+  jjn=jj_nb
+  IF (pole_sud) jjn=jjn-1
+  IF (pole_sud) jje=jje-1
+
+  do jj = jjb, jje
+    do ii = 1, iip1
+      rlong(ii,jj) = rlonv(ii) * 180. / pi
+      rlat(ii,jj) = rlatv(jj) * 180. / pi
+    enddo
+  enddo
+
+  ddid=(/ 1,2 /)
+  dsg=(/ iip1,jjm /)
+  dsl=(/ iip1,jjn /)
+  dpf=(/ 1,jjb /)
+  dpl=(/ iip1,jje /)
+  dhs=(/ 0,0 /)
+  dhe=(/ 0,0 /)
+
+
+  call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, &
+        'box',dynhistv_domain_id)
+
+  call histbeg(dynhistv_file,iip1, rlong(:,1), jjn, &
+        rlat(1,jjb:jje), 1, iip1, 1, jjn,tau0, &
+        zjulian, tstep, vhoriid, &
+        histvid,dynhistv_domain_id)
+
+  ! Grille U
+
+  do jj = 1, jjp1
+    do ii = 1, iip1
+      rlong(ii,jj) = rlonu(ii) * 180. / pi
+      rlat(ii,jj) = rlatu(jj) * 180. / pi
+    enddo
+  enddo
+
+  jjb=jj_begin
+  jje=jj_end
+  jjn=jj_nb
+
+  ddid=(/ 1,2 /)
+  dsg=(/ iip1,jjp1 /)
+  dsl=(/ iip1,jjn /)
+  dpf=(/ 1,jjb /)
+  dpl=(/ iip1,jje /)
+  dhs=(/ 0,0 /)
+  dhe=(/ 0,0 /)
+
+
+  call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, &
+        'box',dynhistu_domain_id)
+
+  call histbeg(dynhistu_file,iip1, rlong(:,1), jjn, &
+        rlat(1,jjb:jje), 1, iip1, 1, jjn,tau0, &
+        zjulian, tstep, uhoriid, &
+        histuid,dynhistu_domain_id)
+
+
+  ! -------------------------------------------------------------
+  !  Appel a histvert pour la grille verticale
+  ! -------------------------------------------------------------
+  call histvert(histid, 'presnivs', 'Niveaux pression','mb', &
+        llm, presnivs/100., zvertiid,'down')
+  call histvert(histvid, 'presnivs', 'Niveaux pression','mb', &
+        llm, presnivs/100., zvertiidv,'down')
+  call histvert(histuid, 'presnivs', 'Niveaux pression','mb', &
+        llm, presnivs/100., zvertiidu,'down')
+
+  !
+  ! -------------------------------------------------------------
+  !  Appels a histdef pour la definition des variables a sauvegarder
+  ! -------------------------------------------------------------
+  !
+  !  Vents U
+  !
+  jjn=jj_nb
+  call histdef(histuid, 'u', 'vent u', &
+        'm/s', iip1, jjn, uhoriid, llm, 1, llm, zvertiidu, &
+        32, 'inst(X)', t_ops, t_wrt)
+
+  !
+  !  Vents V
+  !
+  if (pole_sud) jjn=jj_nb-1
+  call histdef(histvid, 'v', 'vent v', &
+        'm/s', iip1, jjn, vhoriid, llm, 1, llm, zvertiidv, &
+        32, 'inst(X)', t_ops, t_wrt)
+
+  !
+  !  Temperature
+  !
+  jjn=jj_nb
+  call histdef(histid, 'temp', 'temperature', 'K', &
+        iip1, jjn, thoriid, llm, 1, llm, zvertiid, &
+        32, 'inst(X)', t_ops, t_wrt)
+  !
+  !  Temperature potentielle
+  !
+  call histdef(histid, 'theta', 'temperature potentielle', 'K', &
+        iip1, jjn, thoriid, llm, 1, llm, zvertiid, &
+        32, 'inst(X)', t_ops, t_wrt)
+
+
+  !
+  !  Geopotentiel
+  !
+  call histdef(histid, 'phi', 'geopotentiel', '-', &
+        iip1, jjn, thoriid, llm, 1, llm, zvertiid, &
+        32, 'inst(X)', t_ops, t_wrt)
+  !
+  !  Traceurs
+  !
+  !    DO iq=1,nqtot
+  !      call histdef(histid, tracers(iq)%name,
+  ! .             tracers(iq)%longName, '-',
+  ! .             iip1, jjn, thoriid, llm, 1, llm, zvertiid,
+  ! .             32, 'inst(X)', t_ops, t_wrt)
+  !    enddo
+  !
+  !  Masse
+  !
+  call histdef(histid, 'masse', 'masse', 'kg', &
+        iip1, jjn, thoriid, llm, 1, llm, zvertiid, &
+        32, 'inst(X)', t_ops, t_wrt)
+  !
+  !  Pression au sol
+  !
+  call histdef(histid, 'ps', 'pression naturelle au sol', 'Pa', &
+        iip1, jjn, thoriid, 1, 1, 1, -99, &
+        32, 'inst(X)', t_ops, t_wrt)
+  !
+  !  Geopotentiel au sol
+  !
+  !  call histdef(histid, 'phis', 'geopotentiel au sol', '-',
+  ! .             iip1, jjn, thoriid, 1, 1, 1, -99,
+  ! .             32, 'inst(X)', t_ops, t_wrt)
+  !
+  !  Fin
+  !
+  call histend(histid)
+  call histend(histuid)
+  call histend(histvid)
+
+end subroutine inithist_loc
Index: DZ6/trunk/libf/dyn3dmem/integrd_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/integrd_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,47 +1,0 @@
-MODULE integrd_mod
-
-  REAL,POINTER,SAVE :: p(:,:)
-  REAL,POINTER,SAVE :: deltap(:,:)
-  REAL,POINTER,SAVE :: ps(:)
-
-
-  
-CONTAINS
-
-  SUBROUTINE integrd_allocate
-  USE bands
-  USE allocate_field_mod
-  USE parallel_lmdz
-  USE dimensions_mod
-  USE advect_new_mod,ONLY : advect_new_allocate
-  IMPLICIT NONE
-  TYPE(distrib),POINTER :: d
-
-
-    d=>distrib_caldyn
-    CALL allocate_u(p,llmp1,d)
-    CALL allocate_u(deltap,llm,d)
-    CALL allocate_u(ps,d)
-    ps(:)=0
-
-    
-  END SUBROUTINE integrd_allocate
-  
-  SUBROUTINE integrd_switch_caldyn(dist)
-  USE allocate_field_mod
-  USE bands
-  USE parallel_lmdz
-  IMPLICIT NONE
-    TYPE(distrib),INTENT(IN) :: dist
-
-    CALL switch_u(p,distrib_caldyn,dist)
-    CALL switch_u(deltap,distrib_caldyn,dist)
-    CALL switch_u(ps,distrib_caldyn,dist)
-
-    
-    
-  END SUBROUTINE integrd_switch_caldyn
-  
-
-  
-END MODULE integrd_mod  
Index: /LMDZ6/trunk/libf/dyn3dmem/integrd_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/integrd_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3dmem/integrd_mod.f90	(revision 5268)
@@ -0,0 +1,47 @@
+MODULE integrd_mod
+
+  REAL,POINTER,SAVE :: p(:,:)
+  REAL,POINTER,SAVE :: deltap(:,:)
+  REAL,POINTER,SAVE :: ps(:)
+
+
+  
+CONTAINS
+
+  SUBROUTINE integrd_allocate
+  USE bands
+  USE allocate_field_mod
+  USE parallel_lmdz
+  USE dimensions_mod
+  USE advect_new_mod,ONLY : advect_new_allocate
+  IMPLICIT NONE
+  TYPE(distrib),POINTER :: d
+
+
+    d=>distrib_caldyn
+    CALL allocate_u(p,llmp1,d)
+    CALL allocate_u(deltap,llm,d)
+    CALL allocate_u(ps,d)
+    ps(:)=0
+
+    
+  END SUBROUTINE integrd_allocate
+  
+  SUBROUTINE integrd_switch_caldyn(dist)
+  USE allocate_field_mod
+  USE bands
+  USE parallel_lmdz
+  IMPLICIT NONE
+    TYPE(distrib),INTENT(IN) :: dist
+
+    CALL switch_u(p,distrib_caldyn,dist)
+    CALL switch_u(deltap,distrib_caldyn,dist)
+    CALL switch_u(ps,distrib_caldyn,dist)
+
+    
+    
+  END SUBROUTINE integrd_switch_caldyn
+  
+
+  
+END MODULE integrd_mod  
Index: DZ6/trunk/libf/dyn3dmem/leapfrog_loc.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/leapfrog_loc.F90	(revision 5267)
+++ 	(revision )
@@ -1,1875 +1,0 @@
-SUBROUTINE leapfrog_loc(ucov0,vcov0,teta0,ps0, &
-        masse0,phis0,q0,time_0)
-
-   USE misc_mod
-   USE parallel_lmdz
-   USE times
-   USE mod_hallo
-   USE Bands
-   USE Write_Field
-   USE Write_Field_p
-   USE vampir
-   USE timer_filtre, ONLY : print_filtre_timer
-   USE infotrac
-   USE guide_loc_mod, ONLY : guide_main
-   USE getparam
-   USE control_mod
-   USE mod_filtreg_p
-   USE write_field_loc
-   USE allocate_field_mod
-   USE call_dissip_mod, ONLY : call_dissip
-   USE call_calfis_mod, ONLY : call_calfis
-   USE leapfrog_mod, ONLY : ucov,vcov,teta,ps,masse,phis,q,dq &
-         ,ucovm1,vcovm1,tetam1,massem1,psm1,p,pks,pk,pkf,flxw &
-         ,pbaru,pbarv,du,dv,dteta,phi,dp,w &
-         ,leapfrog_allocate,leapfrog_switch_caldyn,leapfrog_switch_dissip
-
-   use exner_hyb_loc_m, only: exner_hyb_loc
-   use exner_milieu_loc_m, only: exner_milieu_loc
-   USE comconst_mod, ONLY: cpp, dtvr, ihf
-   USE comvert_mod, ONLY: ap, bp, pressure_exner
-   USE logic_mod, ONLY: iflag_phys,ok_guide,forward,leapf,apphys, &
-         statcl,conser,apdiss,purmats,ok_strato
-   USE temps_mod, ONLY: itaufin,jD_ref,jH_ref,day_ini, &
-         day_ref,start_time,dt
-   USE mod_xios_dyn3dmem, ONLY : dyn3d_ctx_handle
-   USE lmdz_xios, ONLY: xios_update_calendar, &
-         xios_set_current_context, &
-         using_xios
-   USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_INCA, CPPKEY_REPROBUS, CPPKEY_DEBUGIO
-   USE strings_mod, ONLY: int2str
-
-  IMPLICIT NONE
-
-   ! ......   Version  du 10/01/98    ..........
-
-   !        avec  coordonnees  verticales hybrides
-  !   avec nouveaux operat. dissipation * ( gradiv2,divgrad2,nxgraro2 )
-
-  !=======================================================================
-  !
-  !   Auteur:  P. Le Van /L. Fairhead/F.Hourdin
-  !   -------
-  !
-  !   Objet:
-  !   ------
-  !
-  !   GCM LMD nouvelle grille
-  !
-  !=======================================================================
-  !
-  !  ... Dans inigeom , nouveaux calculs pour les elongations  cu , cv
-  !  et possibilite d'appeler une fonction f(y)  a derivee tangente
-  !  hyperbolique a la  place de la fonction a derivee sinusoidale.
-
-  !  ... Possibilite de choisir le shema pour l'advection de
-  !    q  , en modifiant iadv dans traceur.def  (10/02) .
-  !
-  !  Pour Van-Leer + Vapeur d'eau saturee, iadv(1)=4. (F.Codron,10/99)
-  !  Pour Van-Leer iadv=10
-  !
-  !-----------------------------------------------------------------------
-  !   Declarations:
-  !   -------------
-
-  include "dimensions.h"
-  include "paramet.h"
-  include "comdissnew.h"
-  include "comgeom.h"
-  include "description.h"
-  include "iniprint.h"
-  include "academic.h"
-
-  REAL,INTENT(IN) :: time_0 ! not used
-
-  !   dynamical variables:
-  REAL,INTENT(IN) :: ucov0(ijb_u:ije_u,llm)    ! zonal covariant wind
-  REAL,INTENT(IN) :: vcov0(ijb_v:ije_v,llm)    ! meridional covariant wind
-  REAL,INTENT(IN) :: teta0(ijb_u:ije_u,llm)    ! potential temperature
-  REAL,INTENT(IN) :: q0(ijb_u:ije_u,llm,nqtot) ! advected tracers
-  REAL,INTENT(IN) :: ps0(ijb_u:ije_u)          ! surface pressure (Pa)
-  REAL,INTENT(IN) :: masse0(ijb_u:ije_u,llm)   ! air mass
-  REAL,INTENT(IN) :: phis0(ijb_u:ije_u)        ! geopotentiat at the surface
-
-  real :: zqmin,zqmax
-
-   ! REAL,SAVE,ALLOCATABLE :: p (:,:  )               ! pression aux interfac.des couches
-   ! REAL,SAVE,ALLOCATABLE :: pks(:)                      ! exner au  sol
-   ! REAL,SAVE,ALLOCATABLE :: pk(:,:)                   ! exner au milieu des couches
-   ! REAL,SAVE,ALLOCATABLE :: pkf(:,:)                  ! exner filt.au milieu des couches
-   ! REAL,SAVE,ALLOCATABLE :: phi(:,:)                  ! geopotentiel
-   ! REAL,SAVE,ALLOCATABLE :: w(:,:)                    ! vitesse verticale
-
-  ! variables dynamiques intermediaire pour le transport
-   ! REAL,SAVE,ALLOCATABLE :: pbaru(:,:),pbarv(:,:) !flux de masse
-
-  !   variables dynamiques au pas -1
-   ! REAL,SAVE,ALLOCATABLE :: vcovm1(:,:),ucovm1(:,:)
-  !      REAL,SAVE,ALLOCATABLE :: tetam1(:,:),psm1(:)
-   ! REAL,SAVE,ALLOCATABLE :: massem1(:,:)
-
-  !   tendances dynamiques
-   ! REAL,SAVE,ALLOCATABLE :: dv(:,:),du(:,:)
-   ! REAL,SAVE,ALLOCATABLE :: dteta(:,:),dp(:)
-   ! REAL,DIMENSION(:,:,:), ALLOCATABLE, SAVE :: dq
-
-  !   tendances de la dissipation
-   ! REAL,SAVE,ALLOCATABLE :: dvdis(:,:),dudis(:,:)
-   ! REAL,SAVE,ALLOCATABLE :: dtetadis(:,:)
-
-  !   tendances physiques
-  REAL,SAVE,ALLOCATABLE :: dvfi(:,:),dufi(:,:)
-  REAL,SAVE,ALLOCATABLE :: dtetafi(:,:)
-  REAL,SAVE,ALLOCATABLE :: dpfi(:)
-  REAL,DIMENSION(:,:,:),ALLOCATABLE,SAVE :: dqfi
-
-  !   variables pour le fichier histoire
-  REAL :: dtav      ! intervalle de temps elementaire
-
-  REAL :: tppn(iim),tpps(iim),tpn,tps
-  !
-  INTEGER :: itau,itaufinp1,iav
-   ! INTEGER  iday ! jour julien
-  REAL :: time
-
-  REAL :: SSUM
-   ! REAL,SAVE,ALLOCATABLE :: finvmaold(:,:)
-
-  !ym      LOGICAL  lafin
-  LOGICAL :: lafin
-  INTEGER :: ij,iq,l
-  INTEGER :: ik
-
-  real :: time_step, t_wrt, t_ops
-
-  ! jD_cur: jour julien courant
-  ! jH_cur: heure julienne courante
-  REAL :: jD_cur, jH_cur
-  INTEGER :: an, mois, jour
-  REAL :: secondes
-
-  logical :: physic
-  LOGICAL :: first,callinigrads
-
-  data callinigrads/.true./
-  character(len=10) :: string10
-
-   ! REAL,SAVE,ALLOCATABLE :: flxw(:,:) ! flux de masse verticale
-
-  !+jld variables test conservation energie
-   ! REAL,SAVE,ALLOCATABLE :: ecin(:,:),ecin0(:,:)
-  ! Tendance de la temp. potentiel d (theta)/ d t due a la
-  ! tansformation d'energie cinetique en energie thermique
-  ! cree par la dissipation
-  !  REAL,SAVE,ALLOCATABLE :: dtetaecdt(:,:)
-  !  REAL,SAVE,ALLOCATABLE :: vcont(:,:),ucont(:,:)
-  !  REAL,SAVE,ALLOCATABLE :: vnat(:,:),unat(:,:)
-  REAL :: d_h_vcol, d_qt, d_qw, d_ql, d_ec
-  CHARACTER(len=15) :: ztit
-  !!      INTEGER   ip_ebil_dyn  ! PRINT level for energy conserv. diag.
-   ! SAVE      ip_ebil_dyn
-   ! DATA      ip_ebil_dyn/0/
-  !-jld
-
-  character(len=80) :: dynhist_file, dynhistave_file
-  character(len=*),parameter :: modname="leapfrog_loc"
-  character(len=80) :: abort_message
-
-
-  logical,PARAMETER :: dissip_conservative=.TRUE.
-
-  INTEGER :: testita
-  PARAMETER (testita = 9)
-
-  logical , parameter :: flag_verif = .false.
-
-  ! declaration liees au parallelisme
-  INTEGER :: ierr
-  LOGICAL :: FirstCaldyn
-  LOGICAL :: FirstPhysic
-  INTEGER :: ijb,ije,j,i
-  type(Request) :: TestRequest
-  type(Request) :: Request_Dissip
-  type(Request) :: Request_physic
-
-  INTEGER :: true_itau
-  INTEGER :: iapptrac
-  INTEGER :: AdjustCount
-   ! INTEGER :: var_time
-  LOGICAL :: ok_start_timer=.FALSE.
-  LOGICAL, SAVE :: firstcall=.TRUE.
-  TYPE(distrib),SAVE :: new_dist
-
-  call check_isotopes(q0,ijb_u,ije_u,'leapfrog204: debut')
-
-!$OMP MASTER
-  ItCount=0
-!$OMP END MASTER
-  true_itau=0
-  FirstCaldyn=.TRUE.
-  FirstPhysic=.TRUE.
-  iapptrac=0
-  AdjustCount = 0
-  lafin=.false.
-
-  if (nday>=0) then
-     itaufin   = nday*day_step
-  else
-     itaufin   = -nday
-  endif
-
-  itaufinp1 = itaufin +1
-
-  call check_isotopes(q0,ijb_u,ije_u,'leapfrog 226')
-
-  itau = 0
-  physic=.true.
-  if (iflag_phys==0.or.iflag_phys==2) physic=.false.
-  CALL init_nan
-  CALL leapfrog_allocate
-  ucov=ucov0
-  vcov=vcov0
-  teta=teta0
-  ps=ps0
-  masse=masse0
-  phis=phis0
-  q=q0
-
-  call check_isotopes(q,ijb_u,ije_u,'leapfrog 239')
-
-   ! iday = day_ini+itau/day_step
-   ! time = REAL(itau-(iday-day_ini)*day_step)/day_step+time_0
-   !    IF(time.GT.1.) THEN
-   !     time = time-1.
-   !     iday = iday+1
-   !    ENDIF
-
-  ! Allocate variables depending on dynamic variable nqtot
-!$OMP MASTER
-  if (firstcall) then
-  !
-  !  ALLOCATE(p(ijb_u:ije_u,llmp1))
-  !      ALLOCATE(pks(ijb_u:ije_u))
-  !  ALLOCATE(pk(ijb_u:ije_u,llm))
-  !  ALLOCATE(pkf(ijb_u:ije_u,llm))
-  !  ALLOCATE(phi(ijb_u:ije_u,llm))
-  !  ALLOCATE(w(ijb_u:ije_u,llm))
-  !  ALLOCATE(pbaru(ip1jmp1,llm),pbarv(ip1jm,llm))
-  !  ALLOCATE(vcovm1(ijb_v:ije_v,llm),ucovm1(ijb_u:ije_u,llm))
-  !  ALLOCATE(tetam1(ijb_u:ije_u,llm),psm1(ijb_u:ije_u))
-  !  ALLOCATE(massem1(ijb_u:ije_u,llm))
-  !  ALLOCATE(dv(ijb_v:ije_v,llm),du(ijb_u:ije_u,llm))
-  !  ALLOCATE(dteta(ijb_u:ije_u,llm),dp(ijb_u:ije_u))
-  !  ALLOCATE(dvdis(ijb_v:ije_v,llm),dudis(ijb_u:ije_u,llm))
-  !  ALLOCATE(dtetadis(ijb_u:ije_u,llm))
-  ALLOCATE(dvfi(ijb_v:ije_v,llm),dufi(ijb_u:ije_u,llm))
-  ALLOCATE(dtetafi(ijb_u:ije_u,llm))
-  ALLOCATE(dpfi(ijb_u:ije_u))
-   ! ALLOCATE(dq(ijb_u:ije_u,llm,nqtot))
-  ALLOCATE(dqfi(ijb_u:ije_u,llm,nqtot))
-   ! ALLOCATE(dqfi_tmp(iip1,llm,nqtot))
-   ! ALLOCATE(finvmaold(ijb_u:ije_u,llm))
-   ! ALLOCATE(flxw(ijb_u:ije_u,llm))
-   ! ALLOCATE(ecin(ijb_u:ije_u,llm),ecin0(ijb_u:ije_u,llm))
-   ! ALLOCATE(dtetaecdt(ijb_u:ije_u,llm))
-   ! ALLOCATE(vcont(ijb_v:ije_v,llm),ucont(ijb_u:ije_u,llm))
-   ! ALLOCATE(vnat(ijb_v:ije_v,llm),unat(ijb_u:ije_u,llm))
-  endif
-!$OMP END MASTER
-!$OMP BARRIER
-
-             ! CALL dynredem1_loc("restart.nc",0.0,
-  ! &                           vcov,ucov,teta,q,masse,ps)
-
-
-  !-----------------------------------------------------------------------
-  !   On initialise la pression et la fonction d'Exner :
-  !   --------------------------------------------------
-
-!$OMP MASTER
-  dq(:,:,:)=0.
-  CALL pression ( ijnb_u, ap, bp, ps, p       )
-!$OMP END MASTER
-  if (pressure_exner) then
-  CALL exner_hyb_loc( ijnb_u, ps, p, pks, pk, pkf)
-  else
-    CALL exner_milieu_loc( ijnb_u, ps, p, pks, pk, pkf )
-  endif
-  !-----------------------------------------------------------------------
-  !   Debut de l'integration temporelle:
-  !   ----------------------------------
-  ! et du parallelisme !!
-
-   1   CONTINUE ! Matsuno Forward step begins here
-
-  !   date: (NB: date remains unchanged for Backward step)
-  !   -----
-
-  jD_cur = jD_ref + day_ini - day_ref +                             &
-        (itau+1)/day_step
-  jH_cur = jH_ref + start_time +                                    &
-        mod(itau+1,day_step)/float(day_step)
-  if (jH_cur > 1.0 ) then
-    jD_cur = jD_cur +1.
-    jH_cur = jH_cur -1.
-  endif
-
-  call check_isotopes(q,ijb_u,ije_u,'leapfrog 321')
-
-  if (ok_guide) then
-    call guide_main(itau,ucov,vcov,teta,q,masse,ps)
-!$OMP BARRIER
-  endif
-
-
-
-  !
-  ! IF( MOD( itau, 10* day_step ).EQ.0 )  THEN
-  !   CALL  test_period ( ucov,vcov,teta,q,p,phis )
-  !   PRINT *,' ----   Test_period apres continue   OK ! -----', itau
-  ! ENDIF
-  !
-  !ym      CALL SCOPY( ijmllm ,vcov , 1, vcovm1 , 1 )
-  !ym      CALL SCOPY( ijp1llm,ucov , 1, ucovm1 , 1 )
-  !ym      CALL SCOPY( ijp1llm,teta , 1, tetam1 , 1 )
-  !ym      CALL SCOPY( ijp1llm,masse, 1, massem1, 1 )
-  !ym      CALL SCOPY( ip1jmp1, ps  , 1,   psm1 , 1 )
-
-   if (FirstCaldyn) then
-!$OMP MASTER
-     ucovm1=ucov
-     vcovm1=vcov
-     tetam1= teta
-     massem1= masse
-     psm1= ps
-
-  ! Ehouarn: finvmaold is actually not used
-      ! finvmaold = masse
-!$OMP END MASTER
-!$OMP BARRIER
-      ! CALL filtreg_p ( finvmaold ,jjb_u,jje_u,jjb_u,jje_u,jjp1, llm,
-  ! &                    -2,2, .TRUE., 1 )
-   else
-  ! Save fields obtained at previous time step as '...m1'
-     ijb=ij_begin
-     ije=ij_end
-
-!$OMP MASTER
-     psm1     (ijb:ije) = ps    (ijb:ije)
-!$OMP END MASTER
-
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-     DO l=1,llm
-       ije=ij_end
-       ucovm1   (ijb:ije,l) = ucov  (ijb:ije,l)
-       tetam1   (ijb:ije,l) = teta  (ijb:ije,l)
-       massem1  (ijb:ije,l) = masse (ijb:ije,l)
-        ! finvmaold(ijb:ije,l)=masse(ijb:ije,l)
-
-       if (pole_sud) ije=ij_end-iip1
-       vcovm1(ijb:ije,l) = vcov  (ijb:ije,l)
-
-
-     ENDDO
-!$OMP ENDDO
-
-
-  ! Ehouarn: finvmaold not used
-       ! CALL filtreg_p(finvmaold ,jjb_u,jje_u,jj_begin,jj_end,jjp1,
-  ! .                    llm, -2,2, .TRUE., 1 )
-
-   endif ! of if (FirstCaldyn)
-
-  forward = .TRUE.
-  leapf   = .FALSE.
-  dt      =  dtvr
-
-  !   ...    P.Le Van .26/04/94  ....
-
-  !ym      CALL SCOPY   ( ijp1llm,   masse, 1, finvmaold,     1 )
-  !ym      CALL filtreg ( finvmaold ,jjp1, llm, -2,2, .TRUE., 1 )
-
-  !ym  ne sert a rien
-  !ym      call minmax(ijp1llm,q(:,:,3),zqmin,zqmax)
-
-
-     call check_isotopes(q,ijb_u,ije_u,'leapfrog 400')
-
-   2   CONTINUE ! Matsuno backward or leapfrog step begins here
-
-
-  call check_isotopes(q,ijb_u,ije_u,'leapfrog 402')
-
-!$OMP MASTER
-  ItCount=ItCount+1
-  if (MOD(ItCount,1)==1) then
-    debug=.true.
-  else
-    debug=.false.
-  endif
-!$OMP END MASTER
-  !-----------------------------------------------------------------------
-
-  !   date: (NB: only leapfrog step requires recomputing date)
-  !   -----
-
-  IF (leapf) THEN
-    jD_cur = jD_ref + day_ini - day_ref + &
-          (itau+1)/day_step
-    jH_cur = jH_ref + start_time + &
-          mod(itau+1,day_step)/float(day_step)
-    if (jH_cur > 1.0 ) then
-      jD_cur = jD_cur +1.
-      jH_cur = jH_cur -1.
-    endif
-  ENDIF
-
-  !   gestion des appels de la physique et des dissipations:
-  !   ------------------------------------------------------
-  !
-  !   ...    P.Le Van  ( 6/02/95 )  ....
-
-  apphys = .FALSE.
-  statcl = .FALSE.
-  conser = .FALSE.
-  apdiss = .FALSE.
-
-  IF( purmats ) THEN
-  ! ! Purely Matsuno time stepping
-     IF( MOD(itau,iconser) .EQ.0.AND.  forward    ) conser = .TRUE.
-     IF( MOD(itau,dissip_period ).EQ.0.AND..NOT.forward ) &
-           apdiss = .TRUE.
-     IF( MOD(itau,iphysiq ).EQ.0.AND..NOT.forward &
-           .and. physic                        ) apphys = .TRUE.
-  ELSE
-  ! ! Leapfrog/Matsuno time stepping
-     IF( MOD(itau   ,iconser) .EQ. 0              ) conser = .TRUE.
-     IF( MOD(itau+1,dissip_period).EQ.0 .AND. .NOT. forward ) &
-           apdiss = .TRUE.
-     IF( MOD(itau+1,iphysiq).EQ.0.AND.physic) apphys=.TRUE.
-  END IF
-
-  ! Ehouarn: for Shallow Water case (ie: 1 vertical layer),
-       ! supress dissipation step
-  if (llm.eq.1) then
-    apdiss=.false.
-  endif
-
-  !ym    ---> Pour le moment
-  !ym      apphys = .FALSE.
-  statcl = .FALSE.
-  ! conser = .FALSE. ! ie: no output of control variables to stdout in //
-
-  if (firstCaldyn) then
-!$OMP MASTER
-      call Set_Distrib(distrib_caldyn)
-!$OMP END MASTER
-!$OMP BARRIER
-      firstCaldyn=.FALSE.
-  !ym          call InitTime
-!$OMP MASTER
-      call Init_timer
-!$OMP END MASTER
-  endif
-
-!$OMP MASTER
-  IF (ok_start_timer) THEN
-    CALL InitTime
-    ok_start_timer=.FALSE.
-  ENDIF
-!$OMP END MASTER
-
-
-  call check_isotopes(q,ijb_u,ije_u,'leapfrog 471')
-
-  !ym  PAS D'AJUSTEMENT POUR LE MOMENT
-  if (Adjust) then
-    AdjustCount=AdjustCount+1
-     ! if (iapptrac==iapp_tracvl .and. (forward.OR. leapf)
-  ! &         .and. itau/iphysiq>2 .and. Adjustcount>30) then
-    if (Adjustcount>1) then
-       AdjustCount=0
-!$OMP MASTER
-       call allgather_timer_average
-
-    if (prt_level > 9) then
-
-    print *,'*********************************'
-    print *,'******    TIMER CALDYN     ******'
-    do i=0,mpi_size-1
-      print *,'proc',i,' :   Nb Bandes  :',jj_nb_caldyn(i), &
-            '  : temps moyen :', &
-            timer_average(jj_nb_caldyn(i),timer_caldyn,i), &
-            '+-',timer_delta(jj_nb_caldyn(i),timer_caldyn,i)
-    enddo
-
-    print *,'*********************************'
-    print *,'******    TIMER VANLEER    ******'
-    do i=0,mpi_size-1
-      print *,'proc',i,' :   Nb Bandes  :',jj_nb_vanleer(i), &
-            '  : temps moyen :', &
-            timer_average(jj_nb_vanleer(i),timer_vanleer,i), &
-            '+-',timer_delta(jj_nb_vanleer(i),timer_vanleer,i)
-    enddo
-
-    print *,'*********************************'
-    print *,'******    TIMER DISSIP    ******'
-    do i=0,mpi_size-1
-      print *,'proc',i,' :   Nb Bandes  :',jj_nb_dissip(i), &
-            '  : temps moyen :', &
-            timer_average(jj_nb_dissip(i),timer_dissip,i), &
-            '+-',timer_delta(jj_nb_dissip(i),timer_dissip,i)
-    enddo
-
-     ! if (mpi_rank==0) call WriteBands
-
-   endif
-
-     call AdjustBands_caldyn(new_dist)
-!$OMP END MASTER
-!$OMP BARRIER
-     CALL leapfrog_switch_caldyn(new_dist)
-!$OMP BARRIER
-
-
-!$OMP MASTER
-     distrib_caldyn=new_dist
-     CALL set_distrib(distrib_caldyn)
-!$OMP END MASTER
-!$OMP BARRIER
-      ! call Register_SwapFieldHallo(ucov,ucov,ip1jmp1,llm,
-  ! &                                jj_Nb_caldyn,0,0,TestRequest)
-  !     call Register_SwapFieldHallo(ucovm1,ucovm1,ip1jmp1,llm,
-  ! &                                jj_Nb_caldyn,0,0,TestRequest)
-  !     call Register_SwapFieldHallo(vcov,vcov,ip1jm,llm,
-  ! &                                jj_Nb_caldyn,0,0,TestRequest)
-  !     call Register_SwapFieldHallo(vcovm1,vcovm1,ip1jm,llm,
-  ! &                                jj_Nb_caldyn,0,0,TestRequest)
-  !     call Register_SwapFieldHallo(teta,teta,ip1jmp1,llm,
-  ! &                                jj_Nb_caldyn,0,0,TestRequest)
-  !     call Register_SwapFieldHallo(tetam1,tetam1,ip1jmp1,llm,
-  ! &                                jj_Nb_caldyn,0,0,TestRequest)
-  !     call Register_SwapFieldHallo(masse,masse,ip1jmp1,llm,
-  ! &                                jj_Nb_caldyn,0,0,TestRequest)
-  !     call Register_SwapFieldHallo(massem1,massem1,ip1jmp1,llm,
-  ! &                                jj_Nb_caldyn,0,0,TestRequest)
-  !     call Register_SwapFieldHallo(ps,ps,ip1jmp1,1,
-  ! &                                jj_Nb_caldyn,0,0,TestRequest)
-  !     call Register_SwapFieldHallo(psm1,psm1,ip1jmp1,1,
-  ! &                                jj_Nb_caldyn,0,0,TestRequest)
-  !     call Register_SwapFieldHallo(pkf,pkf,ip1jmp1,llm,
-  ! &                                jj_Nb_caldyn,0,0,TestRequest)
-  !     call Register_SwapFieldHallo(pk,pk,ip1jmp1,llm,
-  ! &                                jj_Nb_caldyn,0,0,TestRequest)
-  !     call Register_SwapFieldHallo(pks,pks,ip1jmp1,1,
-  ! &                                jj_Nb_caldyn,0,0,TestRequest)
-  !     call Register_SwapFieldHallo(phis,phis,ip1jmp1,1,
-  ! &                                jj_Nb_caldyn,0,0,TestRequest)
-  !     call Register_SwapFieldHallo(phi,phi,ip1jmp1,llm,
-  ! &                                jj_Nb_caldyn,0,0,TestRequest)
-  !     call Register_SwapFieldHallo(finvmaold,finvmaold,ip1jmp1,llm,
-  ! &                                jj_Nb_caldyn,0,0,TestRequest)
-  !
-  !    do j=1,nqtot
-  !     call Register_SwapFieldHallo(q(:,:,j),q(:,:,j),ip1jmp1,llm,
-  ! &                                jj_nb_caldyn,0,0,TestRequest)
-  !    enddo
-  !
-  !     call Set_Distrib(distrib_caldyn)
-  !     call SendRequest(TestRequest)
-  !     call WaitRequest(TestRequest)
-
-!$OMP MASTER
-    call AdjustBands_dissip(new_dist)
-!$OMP END MASTER
-!$OMP BARRIER
-    CALL leapfrog_switch_dissip(new_dist)
-!$OMP BARRIER
-!$OMP MASTER
-    distrib_dissip=new_dist
-!$OMP END MASTER
-!$OMP BARRIER
-     ! call AdjustBands_physic
-
-!$OMP MASTER
-    if (mpi_rank==0) call WriteBands
-!$OMP END MASTER
-
-
-  endif
-  endif
-
-
-  call check_isotopes(q,ijb_u,ije_u,'leapfrog 589')
-
-  !-----------------------------------------------------------------------
-  !   calcul des tendances dynamiques:
-  !   --------------------------------
-!$OMP BARRIER
-!$OMP MASTER
-   call VTb(VThallo)
-!$OMP END MASTER
-
-   call Register_Hallo_u(ucov,llm,1,1,1,1,TestRequest)
-   call Register_Hallo_v(vcov,llm,1,1,1,1,TestRequest)
-   call Register_Hallo_u(teta,llm,1,1,1,1,TestRequest)
-   call Register_Hallo_u(ps,1,1,2,2,1,TestRequest)
-   call Register_Hallo_u(pkf,llm,1,1,1,1,TestRequest)
-   call Register_Hallo_u(pk,llm,1,1,1,1,TestRequest)
-   call Register_Hallo_u(pks,1,1,1,1,1,TestRequest)
-   call Register_Hallo_u(p,llmp1,1,1,1,1,TestRequest)
-
-    ! do j=1,nqtot
-    !   call Register_Hallo(q(1,1,j),ip1jmp1,llm,1,1,1,1,
-  ! *                       TestRequest)
-  !    enddo
-
-   call SendRequest(TestRequest)
-!$OMP BARRIER
-   call WaitRequest(TestRequest)
-
-!$OMP MASTER
-   call VTe(VThallo)
-!$OMP END MASTER
-!$OMP BARRIER
-
-  if (debug) then
-    call WriteField_u('ucov',ucov)
-    call WriteField_v('vcov',vcov)
-    call WriteField_u('teta',teta)
-    call WriteField_u('ps',ps)
-    call WriteField_u('masse',masse)
-    call WriteField_u('pk',pk)
-    call WriteField_u('pks',pks)
-    call WriteField_u('pkf',pkf)
-    call WriteField_u('phis',phis)
-    do iq=1,nqtot
-      call WriteField_u('q'//trim(int2str(iq)), &
-            q(:,:,iq))
-    enddo
-  endif
-
-
-  True_itau=True_itau+1
-
-!$OMP MASTER
-  IF (prt_level>9) THEN
-    WRITE(lunout,*)"leapfrog_p: Iteration No",True_itau
-  ENDIF
-
-
-  call start_timer(timer_caldyn)
-
-  ! ! compute geopotential phi()
-  CALL geopot_loc  ( ip1jmp1, teta  , pk , pks,  phis  , phi   )
-
-  call check_isotopes(q,ijb_u,ije_u,'leapfrog 651')
-
-  call VTb(VTcaldyn)
-!$OMP END MASTER
-   ! var_time=time+iday-day_ini
-
-!$OMP BARRIER
-   ! CALL FTRACE_REGION_BEGIN("caldyn")
-  time = jD_cur + jH_cur
-
-  CALL caldyn_loc &
-        ( itau,ucov,vcov,teta,ps,masse,pk,pkf,phis , &
-        phi,conser,du,dv,dteta,dp,w, pbaru,pbarv, time )
-
-   ! CALL FTRACE_REGION_END("caldyn")
-
-!$OMP MASTER
-  if (mpi_rank==0.AND.conser) THEN
-     WRITE(lunout,*) 'leapfrog_loc, Time step: ',itau,' Day:',time
-  ENDIF
-  call VTe(VTcaldyn)
-!$OMP END MASTER
-
-IF (CPPKEY_DEBUGIO) THEN
-  call WriteField_u('du',du)
-  call WriteField_v('dv',dv)
-  call WriteField_u('dteta',dteta)
-  call WriteField_u('dp',dp)
-  call WriteField_u('w',w)
-  call WriteField_u('pbaru',pbaru)
-  call WriteField_v('pbarv',pbarv)
-  call WriteField_u('p',p)
-  call WriteField_u('masse',masse)
-  call WriteField_u('pk',pk)
-END IF
-  !-----------------------------------------------------------------------
-  !   calcul des tendances advection des traceurs (dont l'humidite)
-  !   -------------------------------------------------------------
-
-  call check_isotopes(q,ijb_u,ije_u, &
-        'leapfrog 686: avant caladvtrac')
-
-  IF( forward.OR. leapf )  THEN
-  ! Ehouarn: NB: fields sent to advtrac are those at the beginning of the time step
-    ! !write(*,*) 'leapfrog 679: avant CALL caladvtrac_loc'
-     CALL caladvtrac_loc(q,pbaru,pbarv, &
-           p, masse, dq,  teta, &
-           flxw,pk, iapptrac)
-
-  ! call creation of mass flux
-     IF (offline .AND. .NOT. adjust) THEN
-        CALL fluxstokenc_p(pbaru,pbarv,masse,teta,phi)
-     ENDIF
-
-     ! !write(*,*) 'leapfrog 719'
-     call check_isotopes(q,ijb_u,ije_u, &
-           'leapfrog 698: apres caladvtrac')
-
-   ! do j=1,nqtot
-   !   call WriteField_u('qadv'//trim(int2str(j)),q(:,:,j))
-   ! enddo
-
-  ! Ehouarn: Storage of mass flux for off-line tracers... not implemented...
-
-  ENDIF ! of IF( forward.OR. leapf )
-
-
-  !-----------------------------------------------------------------------
-  !   integrations dynamique et traceurs:
-  !   ----------------------------------
-
-!$OMP MASTER
-   call VTb(VTintegre)
-!$OMP END MASTER
-IF (CPPKEY_DEBUGIO) THEN
-  if (true_itau>20) then
-  call WriteField_u('ucovm1',ucovm1)
-  call WriteField_v('vcovm1',vcovm1)
-  call WriteField_u('tetam1',tetam1)
-  call WriteField_u('psm1',psm1)
-  call WriteField_u('ucov_int',ucov)
-  call WriteField_v('vcov_int',vcov)
-  call WriteField_u('teta_int',teta)
-  call WriteField_u('ps_int',ps)
-  endif
-END IF
-!$OMP BARRIER
-    ! CALL FTRACE_REGION_BEGIN("integrd")
-
-   ! !write(*,*) 'leapfrog 720'
-   call check_isotopes(q,ijb_u,ije_u,'leapfrog 756')
-
-   ! ! CRisi: pourquoi aller jusqu'à 2 et non pas jusqu'à nqtot??
-   CALL integrd_loc ( nqtot,vcovm1,ucovm1,tetam1,psm1,massem1 , &
-         dv,du,dteta,dq,dp,vcov,ucov,teta,q,ps,masse,phis)
-  ! $              finvmaold                                    )
-
-  !  !write(*,*) 'leapfrog 724'
-   call check_isotopes(q,ijb_u,ije_u,'leapfrog 762')
-
-    ! CALL FTRACE_REGION_END("integrd")
-!$OMP BARRIER
-IF (CPPKEY_DEBUGIO) THEN
-  call WriteField_u('ucovm1',ucovm1)
-  call WriteField_v('vcovm1',vcovm1)
-  call WriteField_u('tetam1',tetam1)
-  call WriteField_u('psm1',psm1)
-  call WriteField_u('ucov_int',ucov)
-  call WriteField_v('vcov_int',vcov)
-  call WriteField_u('teta_int',teta)
-  call WriteField_u('ps_int',ps)
-END IF
-
-  call check_isotopes(q,ijb_u,ije_u,'leapfrog 775')
-
-   ! do j=1,nqtot
-   !   call WriteField_p('q'//trim(int2str(j)),
-  ! .                reshape(q(:,:,j),(/iip1,jmp1,llm/)))
-  !    call WriteField_p('dq'//trim(int2str(j)),
-  ! .                reshape(dq(:,:,j),(/iip1,jmp1,llm/)))
-  !  enddo
-
-
-!$OMP MASTER
-   call VTe(VTintegre)
-!$OMP END MASTER
-  ! .P.Le Van (26/04/94  ajout de  finvpold dans l'appel d'integrd)
-  !
-  !-----------------------------------------------------------------------
-  !   calcul des tendances physiques:
-  !   -------------------------------
-  !    ########   P.Le Van ( Modif le  6/02/95 )   ###########
-  !
-   IF( purmats )  THEN
-      IF( itau.EQ.itaufin.AND..NOT.forward ) lafin = .TRUE.
-   ELSE
-      IF( itau+1.EQ. itaufin )              lafin = .TRUE.
-   ENDIF
-
-  !c$OMP END PARALLEL
-
-  !
-  !
-   IF( apphys )  THEN
-
-     CALL call_calfis(itau,lafin,ucov,vcov,teta,masse,ps, &
-           phis,q,flxw)
-  ! #ifdef DEBUG_IO
-      ! call WriteField_u('ucovfi',ucov)
-      ! call WriteField_v('vcovfi',vcov)
-      ! call WriteField_u('tetafi',teta)
-      ! call WriteField_u('pfi',p)
-      ! call WriteField_u('pkfi',pk)
-      ! do j=1,nqtot
-      !   call WriteField_u('qfi'//trim(int2str(j)),q(:,:,j))
-      ! enddo
-  ! #endif
-  ! c
-  ! c     .......   Ajout   P.Le Van ( 17/04/96 )   ...........
-  ! c
-  ! cc$OMP PARALLEL DEFAULT(SHARED)
-  ! cc$OMP+         PRIVATE(rdaym_ini,rdayvrai,ijb,ije)
-
-  ! c$OMP MASTER
-      !  call suspend_timer(timer_caldyn)
-
-      !  write(lunout,*)
-   ! &   'leapfrog_p: Entree dans la physique : Iteration No ',true_itau
-  ! c$OMP END MASTER
-
-   !     CALL pression_loc (  ip1jmp1, ap, bp, ps,  p      )
-
-  ! c$OMP BARRIER
-   !     CALL exner_hyb_loc(  ip1jmp1, ps, p,pks, pk, pkf )
-  ! c$OMP BARRIER
-   !       jD_cur = jD_ref + day_ini - day_ref
-   ! $        + int (itau * dtvr / daysec)
-   !       jH_cur = jH_ref +                                            &
-   ! &              (itau * dtvr / daysec - int(itau * dtvr / daysec))
-  ! !         call ju2ymds(jD_cur+jH_cur, an, mois, jour, secondes)
-
-  ! c rajout debug
-  ! c       lafin = .true.
-
-
-  ! c   Inbterface avec les routines de phylmd (phymars ... )
-  ! c   -----------------------------------------------------
-
-  ! c+jld
-
-  ! c  Diagnostique de conservation de l'energie : initialisation
-  !
-  ! c-jld
-  ! c$OMP BARRIER
-  ! c$OMP MASTER
-  !     call VTb(VThallo)
-  ! c$OMP END MASTER
-
-  ! #ifdef DEBUG_IO
-  !     call WriteField_u('ucovfi',ucov)
-  !     call WriteField_v('vcovfi',vcov)
-  !     call WriteField_u('tetafi',teta)
-  !     call WriteField_u('pfi',p)
-  !     call WriteField_u('pkfi',pk)
-  ! #endif
-  !     call SetTag(Request_physic,800)
-  !
-  !     call Register_SwapField_u(ucov,ucov,distrib_physic,
-  !  *                            Request_physic,up=2,down=2)
-  !
-  !     call Register_SwapField_v(vcov,vcov,distrib_physic,
-  !  *                            Request_physic,up=2,down=2)
-
-  !     call Register_SwapField_u(teta,teta,distrib_physic,
-  !  *                            Request_physic,up=2,down=2)
-  !
-  !     call Register_SwapField_u(masse,masse,distrib_physic,
-  !  *                            Request_physic,up=1,down=2)
-
-  !     call Register_SwapField_u(p,p,distrib_physic,
-  !  *                            Request_physic,up=2,down=2)
-  !
-  !     call Register_SwapField_u(pk,pk,distrib_physic,
-  !  *                            Request_physic,up=2,down=2)
-  !
-  !     call Register_SwapField_u(phis,phis,distrib_physic,
-  !  *                            Request_physic,up=2,down=2)
-  !
-  !     call Register_SwapField_u(phi,phi,distrib_physic,
-  !  *                            Request_physic,up=2,down=2)
-  !
-  !     call Register_SwapField_u(w,w,distrib_physic,
-  !  *                            Request_physic,up=2,down=2)
-  !
-  !     call Register_SwapField_u(q,q,distrib_physic,
-  !  *                            Request_physic,up=2,down=2)
-
-  !     call Register_SwapField_u(flxw,flxw,distrib_physic,
-  !  *                            Request_physic,up=2,down=2)
-  !
-  !     call SendRequest(Request_Physic)
-  ! c$OMP BARRIER
-  !     call WaitRequest(Request_Physic)
-
-  ! c$OMP BARRIER
-  ! c$OMP MASTER
-  !     call Set_Distrib(distrib_Physic)
-  !     call VTe(VThallo)
-  !
-  !     call VTb(VTphysiq)
-  ! c$OMP END MASTER
-  ! c$OMP BARRIER
-
-  ! #ifdef DEBUG_IO
-  !   call WriteField_u('ucovfi',ucov)
-  !   call WriteField_v('vcovfi',vcov)
-  !   call WriteField_u('tetafi',teta)
-  !   call WriteField_u('pfi',p)
-  !   call WriteField_u('pkfi',pk)
-  !   do j=1,nqtot
-  !     call WriteField_u('qfi'//trim(int2str(j)),q(:,:,j))
-  !   enddo
-  ! #endif
-  !    STOP
-  ! c$OMP BARRIER
-  ! !        CALL FTRACE_REGION_BEGIN("calfis")
-  !     CALL calfis_loc(lafin ,jD_cur, jH_cur,
-  !  $               ucov,vcov,teta,q,masse,ps,p,pk,phis,phi ,
-  !  $               du,dv,dteta,dq,
-  !  $               flxw,
-  !  $               dufi,dvfi,dtetafi,dqfi,dpfi  )
-  ! !        CALL FTRACE_REGION_END("calfis")
-  ! !        ijb=ij_begin
-  ! !        ije=ij_end
-  ! !        if ( .not. pole_nord) then
-  ! !c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-  ! !          DO l=1,llm
-  ! !          dufi_tmp(1:iip1,l)   = dufi(ijb:ijb+iim,l)
-  ! !          dvfi_tmp(1:iip1,l)   = dvfi(ijb:ijb+iim,l)
-  ! !          dtetafi_tmp(1:iip1,l)= dtetafi(ijb:ijb+iim,l)
-  ! !          dqfi_tmp(1:iip1,l,:) = dqfi(ijb:ijb+iim,l,:)
-  ! !          ENDDO
-  ! !c$OMP END DO NOWAIT
-  ! !
-  ! !c$OMP MASTER
-  ! !          dpfi_tmp(1:iip1)     = dpfi(ijb:ijb+iim)
-  ! !c$OMP END MASTER
-  ! !        endif ! of if ( .not. pole_nord)
-
-  ! !c$OMP BARRIER
-  ! !c$OMP MASTER
-  ! !        call Set_Distrib(distrib_physic_bis)
-
-  ! !        call VTb(VThallo)
-  ! !c$OMP END MASTER
-  ! !c$OMP BARRIER
-  ! !
-  ! !        call Register_Hallo_u(dufi,llm,
-  ! !     *                      1,0,0,1,Request_physic)
-  ! !
-  ! !        call Register_Hallo_v(dvfi,llm,
-  ! !     *                      1,0,0,1,Request_physic)
-  ! !
-  ! !        call Register_Hallo_u(dtetafi,llm,
-  ! !     *                      1,0,0,1,Request_physic)
-  ! !
-  ! !        call Register_Hallo_u(dpfi,1,
-  ! !     *                      1,0,0,1,Request_physic)
-  ! !
-  ! !        do j=1,nqtot
-  ! !          call Register_Hallo_u(dqfi(ijb_u,1,j),llm,
-  ! !     *                        1,0,0,1,Request_physic)
-  ! !        enddo
-  ! !
-  ! !        call SendRequest(Request_Physic)
-  ! !c$OMP BARRIER
-  ! !        call WaitRequest(Request_Physic)
-  ! !
-  ! !c$OMP BARRIER
-  ! !c$OMP MASTER
-  ! !        call VTe(VThallo)
-  ! !
-  ! !        call set_Distrib(distrib_Physic)
-  ! !c$OMP END MASTER
-  ! !c$OMP BARRIER
-  ! !                ijb=ij_begin
-  ! !        if (.not. pole_nord) then
-  ! !
-  ! !c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-  ! !          DO l=1,llm
-  ! !            dufi(ijb:ijb+iim,l) = dufi(ijb:ijb+iim,l)+dufi_tmp(1:iip1,l)
-  ! !            dvfi(ijb:ijb+iim,l) = dvfi(ijb:ijb+iim,l)+dvfi_tmp(1:iip1,l)
-  ! !            dtetafi(ijb:ijb+iim,l) = dtetafi(ijb:ijb+iim,l)
-  ! !     &                              +dtetafi_tmp(1:iip1,l)
-  ! !            dqfi(ijb:ijb+iim,l,:) = dqfi(ijb:ijb+iim,l,:)
-  ! !     &                              + dqfi_tmp(1:iip1,l,:)
-  ! !          ENDDO
-  ! !c$OMP END DO NOWAIT
-  ! !
-  ! !c$OMP MASTER
-  ! !          dpfi(ijb:ijb+iim)   = dpfi(ijb:ijb+iim)+ dpfi_tmp(1:iip1)
-  ! !c$OMP END MASTER
-  ! !
-  ! !        endif ! of if (.not. pole_nord)
-
-  ! #ifdef DEBUG_IO
-  !     call WriteField_u('dufi',dufi)
-  !     call WriteField_v('dvfi',dvfi)
-  !     call WriteField_u('dtetafi',dtetafi)
-  !     call WriteField_u('dpfi',dpfi)
-  !     do j=1,nqtot
-  !       call WriteField_u('dqfi'//trim(int2str(j)),dqfi(:,:,j))
-  !    enddo
-  ! #endif
-
-  ! c$OMP BARRIER
-
-  ! c      ajout des tendances physiques:
-  ! c      ------------------------------
-  ! #ifdef DEBUG_IO
-  !     call WriteField_u('ucovfi',ucov)
-  !     call WriteField_v('vcovfi',vcov)
-  !     call WriteField_u('tetafi',teta)
-  !         call WriteField_u('psfi',ps)
-  !     do j=1,nqtot
-  !       call WriteField_u('qfi'//trim(int2str(j)),q(:,:,j))
-  !    enddo
-  ! #endif
-
-  !      IF (ok_strato) THEN
-  !        CALL top_bound_loc( vcov,ucov,teta,masse,dufi,dvfi,dtetafi)
-  !      ENDIF
-
-  ! #ifdef DEBUG_IO
-  !     call WriteField_u('ucovfi',ucov)
-  !     call WriteField_v('vcovfi',vcov)
-  !     call WriteField_u('tetafi',teta)
-  !         call WriteField_u('psfi',ps)
-  !     do j=1,nqtot
-  !       call WriteField_u('qfi'//trim(int2str(j)),q(:,:,j))
-  !    enddo
-  ! #endif
-
-  !       CALL addfi_loc( dtphys, leapf, forward   ,
-  !  $                  ucov, vcov, teta , q   ,ps ,
-  !  $                 dufi, dvfi, dtetafi , dqfi ,dpfi  )
-
-  ! #ifdef DEBUG_IO
-  !     call WriteField_u('ucovfi',ucov)
-  !     call WriteField_v('vcovfi',vcov)
-  !     call WriteField_u('tetafi',teta)
-  !         call WriteField_u('psfi',ps)
-  !     do j=1,nqtot
-  !       call WriteField_u('qfi'//trim(int2str(j)),q(:,:,j))
-  !    enddo
-  ! #endif
-
-  ! c$OMP BARRIER
-  ! c$OMP MASTER
-  !     call VTe(VTphysiq)
-
-  !     call VTb(VThallo)
-  ! c$OMP END MASTER
-
-  !     call SetTag(Request_physic,800)
-  !     call Register_SwapField_u(ucov,ucov,
-  !  *                               distrib_caldyn,Request_physic)
-  !
-  !     call Register_SwapField_v(vcov,vcov,
-  !  *                               distrib_caldyn,Request_physic)
-  !
-  !     call Register_SwapField_u(teta,teta,
-  !  *                               distrib_caldyn,Request_physic)
-  !
-  !     call Register_SwapField_u(masse,masse,
-  !  *                               distrib_caldyn,Request_physic)
-
-  !     call Register_SwapField_u(p,p,
-  !  *                               distrib_caldyn,Request_physic)
-  !
-  !     call Register_SwapField_u(pk,pk,
-  !  *                               distrib_caldyn,Request_physic)
-  !
-  !     call Register_SwapField_u(phis,phis,
-  !  *                               distrib_caldyn,Request_physic)
-  !
-  !     call Register_SwapField_u(phi,phi,
-  !  *                               distrib_caldyn,Request_physic)
-  !
-  !     call Register_SwapField_u(w,w,
-  !  *                               distrib_caldyn,Request_physic)
-
-  !     call Register_SwapField_u(q,q,
-  !  *                               distrib_caldyn,Request_physic)
-  !
-  !     call SendRequest(Request_Physic)
-  ! c$OMP BARRIER
-  !     call WaitRequest(Request_Physic)
-
-  ! c$OMP BARRIER
-  ! c$OMP MASTER
-  !    call VTe(VThallo)
-  !    call set_distrib(distrib_caldyn)
-  ! c$OMP END MASTER
-  ! c$OMP BARRIER
-  ! c
-  ! c  Diagnostique de conservation de l'energie : difference
-  !   IF (ip_ebil_dyn.ge.1 ) THEN
-  !       ztit='bil phys'
-  !       CALL diagedyn(ztit,2,1,1,dtphys
-  !  e  , ucov    , vcov , ps, p ,pk , teta , q(:,:,1), q(:,:,2))
-  !   ENDIF
-
-  ! #ifdef DEBUG_IO
-  !     call WriteField_u('ucovfi',ucov)
-  !     call WriteField_v('vcovfi',vcov)
-  !     call WriteField_u('tetafi',teta)
-  !         call WriteField_u('psfi',ps)
-  !     do j=1,nqtot
-  !       call WriteField_u('qfi'//trim(int2str(j)),q(:,:,j))
-  !    enddo
-  ! #endif
-
-
-  ! c-jld
-!$OMP MASTER
-     if (FirstPhysic) then
-       ok_start_timer=.TRUE.
-       FirstPhysic=.false.
-     endif
-!$OMP END MASTER
-   ENDIF ! of IF( apphys )
-
-   call check_isotopes(q,ijb_u,ije_u,'leapfrog 1132')
-    ! !write(*,*) 'leapfrog 1134: iflag_phys=',iflag_phys
-
-  IF(iflag_phys.EQ.2) THEN ! "Newtonian" case
-!$OMP MASTER
-     if (FirstPhysic) then
-       ok_start_timer=.TRUE.
-       FirstPhysic=.false.
-     endif
-!$OMP END MASTER
-
-
-  !   Calcul academique de la physique = Rappel Newtonien + fritcion
-  !   --------------------------------------------------------------
-  !ym       teta(:,:)=teta(:,:)
-  !ym     s  -iphysiq*dtvr*(teta(:,:)-tetarappel(:,:))/taurappel
-   ijb=ij_begin
-   ije=ij_end
-  !LF       teta(ijb:ije,:)=teta(ijb:ije,:)
-  !LF     s  -iphysiq*dtvr*(teta(ijb:ije,:)-tetarappel(ijb:ije,:))/taurappel
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-   do l=1,llm
-   teta(ijb:ije,l)=teta(ijb:ije,l) -dtvr* &
-         (teta(ijb:ije,l)-tetarappel(ijb:ije,l))* &
-         (knewt_g+knewt_t(l)*clat4(ijb:ije))
-   enddo
-!$OMP END DO
-
-!$OMP MASTER
-   if (planet_type.eq."giant") then
-     ! ! add an intrinsic heat flux at the base of the atmosphere
-     teta(ijb:ije,1) = teta(ijb:ije,1) &
-           + dtvr * aire(ijb:ije) * ihf / cpp / masse(ijb:ije,1)
-   endif
-!$OMP END MASTER
-!$OMP BARRIER
-
-
-   call Register_Hallo_u(ucov,llm,0,1,1,0,Request_Physic)
-   call Register_Hallo_v(vcov,llm,1,1,1,1,Request_Physic)
-   call SendRequest(Request_Physic)
-!$OMP BARRIER
-   call WaitRequest(Request_Physic)
-!$OMP BARRIER
-   call friction_loc(ucov,vcov,dtvr)
-!$OMP BARRIER
-
-    ! ! Sponge layer (if any)
-    IF (ok_strato) THEN
-      CALL top_bound_loc(vcov,ucov,teta,masse,dtvr)
-!$OMP BARRIER
-    ENDIF ! of IF (ok_strato)
-  ENDIF ! of IF(iflag_phys.EQ.2)
-
-
-    CALL pression_loc ( ip1jmp1, ap, bp, ps, p                  )
-!$OMP BARRIER
-    if (pressure_exner) then
-    CALL exner_hyb_loc( ijnb_u, ps, p, pks, pk, pkf )
-    else
-      CALL exner_milieu_loc( ijnb_u, ps, p, pks, pk, pkf )
-    endif
-!$OMP BARRIER
-    CALL massdair_loc(p,masse)
-!$OMP BARRIER
-
-  !c$OMP END PARALLEL
-    call check_isotopes(q,ijb_u,ije_u,'leapfrog 1196')
-
-  !-----------------------------------------------------------------------
-  !   dissipation horizontale et verticale  des petites echelles:
-  !   ----------------------------------------------------------
-  ! !write(*,*) 'leapfrog 1163: apdiss=',apdiss
-  IF(apdiss) THEN
-
-    CALL call_dissip(ucov,vcov,teta,p,pk,ps)
-  !cc$OMP  PARALLEL DEFAULT(SHARED)
-  !cc$OMP+          PRIVATE(ijb,ije,tppn,tpn,tpps,tps)
-  !c$OMP MASTER
-     ! call suspend_timer(timer_caldyn)
-  !
-  !c       print*,'Entree dans la dissipation : Iteration No ',true_itau
-  !c   calcul de l'energie cinetique avant dissipation
-  !c       print *,'Passage dans la dissipation'
-
-  !    call VTb(VThallo)
-  !c$OMP END MASTER
-
-  !c$OMP BARRIER
-
-  !    call Register_SwapField_u(ucov,ucov,distrib_dissip,
-  ! *                            Request_dissip,up=1,down=1)
-
-  !    call Register_SwapField_v(vcov,vcov,distrib_dissip,
-  ! *                            Request_dissip,up=1,down=1)
-
-  !    call Register_SwapField_u(teta,teta,distrib_dissip,
-  ! *                            Request_dissip)
-
-  !    call Register_SwapField_u(p,p,distrib_dissip,
-  ! *                            Request_dissip)
-
-  !    call Register_SwapField_u(pk,pk,distrib_dissip,
-  ! *                            Request_dissip)
-
-  !    call SendRequest(Request_dissip)
-  !c$OMP BARRIER
-  !    call WaitRequest(Request_dissip)
-
-  !c$OMP BARRIER
-  !c$OMP MASTER
-  !    call set_distrib(distrib_dissip)
-  !    call VTe(VThallo)
-  !    call VTb(VTdissipation)
-  !    call start_timer(timer_dissip)
-  !c$OMP END MASTER
-  !c$OMP BARRIER
-
-  !    call covcont_loc(llm,ucov,vcov,ucont,vcont)
-  !    call enercin_loc(vcov,ucov,vcont,ucont,ecin0)
-
-  !c   dissipation
-
-  !!        CALL FTRACE_REGION_BEGIN("dissip")
-  !    CALL dissip_loc(vcov,ucov,teta,p,dvdis,dudis,dtetadis)
-
-  !#ifdef DEBUG_IO
-  !    call WriteField_u('dudis',dudis)
-  !    call WriteField_v('dvdis',dvdis)
-  !    call WriteField_u('dtetadis',dtetadis)
-  !#endif
-  !
-  !!      CALL FTRACE_REGION_END("dissip")
-  !
-  !    ijb=ij_begin
-  !    ije=ij_end
-  !c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-  !    DO l=1,llm
-  !      ucov(ijb:ije,l)=ucov(ijb:ije,l)+dudis(ijb:ije,l)
-  !    ENDDO
-  !c$OMP END DO NOWAIT
-  !    if (pole_sud) ije=ije-iip1
-  !c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-  !    DO l=1,llm
-  !      vcov(ijb:ije,l)=vcov(ijb:ije,l)+dvdis(ijb:ije,l)
-  !    ENDDO
-  !c$OMP END DO NOWAIT
-
-  !c       teta=teta+dtetadis
-
-
-  !c------------------------------------------------------------------------
-  !    if (dissip_conservative) then
-  !C       On rajoute la tendance due a la transform. Ec -> E therm. cree
-  !C       lors de la dissipation
-  !c$OMP BARRIER
-  !c$OMP MASTER
-  !        call suspend_timer(timer_dissip)
-  !        call VTb(VThallo)
-  !c$OMP END MASTER
-  !        call Register_Hallo_u(ucov,llm,1,1,1,1,Request_Dissip)
-  !        call Register_Hallo_v(vcov,llm,1,1,1,1,Request_Dissip)
-  !        call SendRequest(Request_Dissip)
-  !c$OMP BARRIER
-  !        call WaitRequest(Request_Dissip)
-  !c$OMP MASTER
-  !        call VTe(VThallo)
-  !        call resume_timer(timer_dissip)
-  !c$OMP END MASTER
-  !c$OMP BARRIER
-  !        call covcont_loc(llm,ucov,vcov,ucont,vcont)
-  !        call enercin_loc(vcov,ucov,vcont,ucont,ecin)
-  !
-  !        ijb=ij_begin
-  !        ije=ij_end
-  !c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-  !        do l=1,llm
-  !          do ij=ijb,ije
-  !            dtetaecdt(ij,l)= (ecin0(ij,l)-ecin(ij,l))/ pk(ij,l)
-  !            dtetadis(ij,l)=dtetadis(ij,l)+dtetaecdt(ij,l)
-  !          enddo
-  !        enddo
-  !c$OMP END DO NOWAIT
-  !   endif
-
-  !   ijb=ij_begin
-  !   ije=ij_end
-  !c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-  !     do l=1,llm
-  !       do ij=ijb,ije
-  !          teta(ij,l)=teta(ij,l)+dtetadis(ij,l)
-  !       enddo
-  !     enddo
-  !c$OMP END DO NOWAIT
-  !c------------------------------------------------------------------------
-
-
-  !c    .......        P. Le Van (  ajout  le 17/04/96  )   ...........
-  !c   ...      Calcul de la valeur moyenne, unique de h aux poles  .....
-  !c
-
-  !    ijb=ij_begin
-  !    ije=ij_end
-  !
-  !    if (pole_nord) then
-  !c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-  !      DO l  =  1, llm
-  !        DO ij =  1,iim
-  !         tppn(ij)  = aire(  ij    ) * teta(  ij    ,l)
-  !        ENDDO
-  !         tpn  = SSUM(iim,tppn,1)/apoln
-
-  !        DO ij = 1, iip1
-  !         teta(  ij    ,l) = tpn
-  !        ENDDO
-  !      ENDDO
-  !c$OMP END DO NOWAIT
-
-  !c$OMP MASTER
-  !      DO ij =  1,iim
-  !        tppn(ij)  = aire(  ij    ) * ps (  ij    )
-  !      ENDDO
-  !        tpn  = SSUM(iim,tppn,1)/apoln
-  !
-  !      DO ij = 1, iip1
-  !        ps(  ij    ) = tpn
-  !      ENDDO
-  !c$OMP END MASTER
-  !    endif
-  !
-  !    if (pole_sud) then
-  !c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-  !      DO l  =  1, llm
-  !        DO ij =  1,iim
-  !         tpps(ij)  = aire(ij+ip1jm) * teta(ij+ip1jm,l)
-  !        ENDDO
-  !         tps  = SSUM(iim,tpps,1)/apols
-
-  !        DO ij = 1, iip1
-  !         teta(ij+ip1jm,l) = tps
-  !        ENDDO
-  !      ENDDO
-  !c$OMP END DO NOWAIT
-
-  !c$OMP MASTER
-  !      DO ij =  1,iim
-  !        tpps(ij)  = aire(ij+ip1jm) * ps (ij+ip1jm)
-  !      ENDDO
-  !        tps  = SSUM(iim,tpps,1)/apols
-  !
-  !      DO ij = 1, iip1
-  !        ps(ij+ip1jm) = tps
-  !      ENDDO
-  !c$OMP END MASTER
-  !    endif
-
-
-  !c$OMP BARRIER
-  !c$OMP MASTER
-  !    call VTe(VTdissipation)
-
-  !    call stop_timer(timer_dissip)
-  !
-  !    call VTb(VThallo)
-  !c$OMP END MASTER
-  !    call Register_SwapField_u(ucov,ucov,distrib_caldyn,
-  ! *                            Request_dissip)
-
-  !    call Register_SwapField_v(vcov,vcov,distrib_caldyn,
-  ! *                            Request_dissip)
-
-  !    call Register_SwapField_u(teta,teta,distrib_caldyn,
-  ! *                            Request_dissip)
-
-  !    call Register_SwapField_u(p,p,distrib_caldyn,
-  ! *                            Request_dissip)
-
-  !    call Register_SwapField_u(pk,pk,distrib_caldyn,
-  ! *                            Request_dissip)
-
-  !    call SendRequest(Request_dissip)
-  !c$OMP BARRIER
-  !    call WaitRequest(Request_dissip)
-
-  !c$OMP BARRIER
-  !c$OMP MASTER
-  !    call set_distrib(distrib_caldyn)
-  !    call VTe(VThallo)
-  !    call resume_timer(timer_caldyn)
-  !c        print *,'fin dissipation'
-  !c$OMP END MASTER
-  !c$OMP BARRIER
-   END IF ! of IF(apdiss)
-
-  !c$OMP END PARALLEL
-
-  ! ajout debug
-           ! IF( lafin ) then
-           !   abort_message = 'Simulation finished'
-           !   call abort_gcm(modname,abort_message,0)
-           ! ENDIF
-
-   call check_isotopes(q,ijb_u,ije_u,'leapfrog 1430')
-
-  !   ********************************************************************
-  !   ********************************************************************
-  !   .... fin de l'integration dynamique  et physique pour le pas itau ..
-  !   ********************************************************************
-  !   ********************************************************************
-
-  !   preparation du pas d'integration suivant  ......
-  !ym      call WriteField('ucov',reshape(ucov,(/iip1,jmp1,llm/)))
-  !ym      call WriteField('vcov',reshape(vcov,(/iip1,jjm,llm/)))
-!$OMP MASTER
-  call stop_timer(timer_caldyn)
-!$OMP END MASTER
-  IF (itau==itaumax) then
-!$OMP MASTER
-     call allgather_timer_average
-     call barrier
-     if (mpi_rank==0) then
-
-        print *,'*********************************'
-        print *,'******    TIMER CALDYN     ******'
-        do i=0,mpi_size-1
-           print *,'proc',i,' :   Nb Bandes  :',jj_nb_caldyn(i), &
-                 '  : temps moyen :', &
-                 timer_average(jj_nb_caldyn(i),timer_caldyn,i)
-        enddo
-
-        print *,'*********************************'
-        print *,'******    TIMER VANLEER    ******'
-        do i=0,mpi_size-1
-           print *,'proc',i,' :   Nb Bandes  :',jj_nb_vanleer(i), &
-                 '  : temps moyen :', &
-                 timer_average(jj_nb_vanleer(i),timer_vanleer,i)
-        enddo
-
-        print *,'*********************************'
-        print *,'******    TIMER DISSIP    ******'
-        do i=0,mpi_size-1
-           print *,'proc',i,' :   Nb Bandes  :',jj_nb_dissip(i), &
-                 '  : temps moyen :', &
-                 timer_average(jj_nb_dissip(i),timer_dissip,i)
-        enddo
-
-        print *,'*********************************'
-        print *,'******    TIMER PHYSIC    ******'
-        do i=0,mpi_size-1
-           print *,'proc',i,' :   Nb Bandes  :',jj_nb_physic(i), &
-                 '  : temps moyen :', &
-                 timer_average(jj_nb_physic(i),timer_physic,i)
-        enddo
-
-     endif
-     CALL barrier
-     print *,'Taille du Buffer MPI (REAL*8)',MaxBufferSize
-  print *,'Taille du Buffer MPI utilise (REAL*8)',MaxBufferSize_Used
-   print *, 'Temps total ecoule sur la parallelisation :',DiffTime()
-  print *, 'Temps CPU ecoule sur la parallelisation :',DiffCpuTime()
-     CALL print_filtre_timer
-!$OMP END MASTER
-     CALL dynredem1_loc("restart.nc",0.0, &
-           vcov,ucov,teta,q,masse,ps)
-!$OMP MASTER
-     call fin_getparam
-!$OMP END MASTER
-
-     if (ok_guide) then
-       ! ! set ok_guide to false to avoid extra output
-       ! ! in following forward step
-       ok_guide=.false.
-     endif
-
-IF (CPPKEY_INCA) THEN
-     IF (ANY(type_trac == ['inca','inco'])) THEN
-        CALL finalize_inca
-  ! switching back to LMDZDYN context
-!$OMP MASTER
-        IF (ok_dyn_xios) THEN
-           CALL xios_set_current_context(dyn3d_ctx_handle)
-        ENDIF
-!$OMP END MASTER
-     ENDIF
-END IF
-IF (CPPKEY_REPROBUS) THEN
-     if (type_trac == 'repr') CALL finalize_reprobus
-END IF
-
-!$OMP MASTER
-     call finalize_parallel
-!$OMP END MASTER
-!$OMP BARRIER
-     RETURN
-  ENDIF
-
-  call check_isotopes(q,ijb_u,ije_u,'leapfrog 1509')
-
-  IF ( .NOT.purmats ) THEN
-    ! ........................................................
-    ! ..............  schema matsuno + leapfrog  ..............
-    ! ........................................................
-
-        IF(forward.OR. leapf) THEN
-          itau= itau + 1
-           ! iday= day_ini+itau/day_step
-           ! time= REAL(itau-(iday-day_ini)*day_step)/day_step+time_0
-           !   IF(time.GT.1.) THEN
-           !     time = time-1.
-           !     iday = iday+1
-           !   ENDIF
-        ENDIF
-
-
-        IF( itau.EQ. itaufinp1 ) then
-
-          if (flag_verif) then
-            write(79,*) 'ucov',ucov
-            write(80,*) 'vcov',vcov
-            write(81,*) 'teta',teta
-            write(82,*) 'ps',ps
-            write(83,*) 'q',q
-            WRITE(85,*) 'q1 = ',q(:,:,1)
-            WRITE(86,*) 'q3 = ',q(:,:,3)
-          endif
-
-
-!$OMP MASTER
-          call fin_getparam
-!$OMP END MASTER
-
-IF (CPPKEY_INCA) THEN
-          IF (ANY(type_trac == ['inca','inco'])) THEN
-             CALL finalize_inca
-  ! switching back to LMDZDYN context
-!$OMP MASTER
-             IF (ok_dyn_xios) THEN
-                CALL xios_set_current_context(dyn3d_ctx_handle)
-             ENDIF
-!$OMP END MASTER
-          ENDIF
-END IF
-IF (CPPKEY_REPROBUS) THEN
-          if (type_trac == 'repr') CALL finalize_reprobus
-END IF
-
-!$OMP MASTER
-          call finalize_parallel
-!$OMP END MASTER
-          abort_message = 'Simulation finished'
-          call abort_gcm(modname,abort_message,0)
-          RETURN
-        ENDIF
-  !-----------------------------------------------------------------------
-  !   ecriture du fichier histoire moyenne:
-  !   -------------------------------------
-
-        IF(MOD(itau,iperiod).EQ.0 .OR. itau.EQ.itaufin) THEN
-!$OMP BARRIER
-           IF(itau.EQ.itaufin) THEN
-              iav=1
-           ELSE
-              iav=0
-           ENDIF
-
-          ! ! Ehouarn: re-compute geopotential for outputs
-!$OMP BARRIER
-!$OMP MASTER
-          CALL geopot_loc(ip1jmp1,teta,pk,pks,phis,phi)
-!$OMP END MASTER
-!$OMP BARRIER
-
-         IF (ok_dynzon) THEN
-
-          CALL bilan_dyn_loc(2,dtvr*iperiod,dtvr*day_step*periodav, &
-                ps,masse,pk,pbaru,pbarv,teta,phi,ucov,vcov,q)
-
-          ENDIF !ok_dynzon
-
-          IF (ok_dyn_ave) THEN
-             CALL writedynav_loc(itau,vcov, &
-                   ucov,teta,pk,phi,q,masse,ps,phis)
-          ENDIF
-
-
-
-        ENDIF
-
-        call check_isotopes(q,ijb_u,ije_u,'leapfrog 1584')
-
-  !-----------------------------------------------------------------------
-  !   ecriture de la bande histoire:
-  !   ------------------------------
-
-        IF( MOD(itau,iecri).EQ.0) THEN
-         ! ! Ehouarn: output only during LF or Backward Matsuno
-         if (leapf.or.(.not.leapf.and.(.not.forward))) then
-
-!$OMP BARRIER
-!$OMP MASTER
-          CALL geopot_loc(ip1jmp1,teta,pk,pks,phis,phi)
-!$OMP END MASTER
-!$OMP BARRIER
-
-         if (ok_dyn_ins) then
-             CALL writehist_loc(itau,vcov,ucov,teta,pk,phi,q, &
-                   masse,ps,phis)
-         endif
-
-
-          IF (ok_dyn_xios) THEN
-!$OMP MASTER
-             CALL xios_update_calendar(itau)
-!$OMP END MASTER
-!$OMP BARRIER
-             CALL writedyn_xios(vcov, &
-                   ucov,teta,pk,phi,q,masse,ps,phis)
-          ENDIF
-
-      endif                 ! of if (leapf.or.(.not.leapf.and.(.not.forward)))
-
-
-       ENDIF ! of IF(MOD(itau,iecri).EQ.0)
-
-        IF(itau.EQ.itaufin) THEN
-
-!$OMP BARRIER
-
-           ! if (planet_type.eq."earth") then
-  ! Write an Earth-format restart file
-            CALL dynredem1_loc("restart.nc",0.0, &
-                  vcov,ucov,teta,q,masse,ps)
-           ! endif ! of if (planet_type.eq."earth")
-            if (ok_guide) then
-              ! ! set ok_guide to false to avoid extra output
-              ! ! in following forward step
-              ok_guide=.false.
-            endif
-
-           ! CLOSE(99)
-        ENDIF ! of IF (itau.EQ.itaufin)
-
-        call check_isotopes(q,ijb_u,ije_u,'leapfrog 1624')
-
-  !-----------------------------------------------------------------------
-  !   gestion de l'integration temporelle:
-  !   ------------------------------------
-
-        IF( MOD(itau,iperiod).EQ.0 )    THEN
-                GO TO 1
-        ELSE IF ( MOD(itau-1,iperiod).EQ. 0 ) THEN
-
-               IF( forward )  THEN
-   ! fin du pas forward et debut du pas backward
-
-                  forward = .FALSE.
-                    leapf = .FALSE.
-                       GO TO 2
-
-               ELSE
-   ! fin du pas backward et debut du premier pas leapfrog
-
-                    leapf =  .TRUE.
-                    dt  =  2.*dtvr
-                    GO TO 2
-               END IF
-        ELSE
-
-   ! ......   pas leapfrog  .....
-
-             leapf = .TRUE.
-             dt  = 2.*dtvr
-             GO TO 2
-        END IF ! of IF (MOD(itau,iperiod).EQ.0)
-               ! !    ELSEIF (MOD(itau-1,iperiod).EQ.0)
-
-
-  ELSE ! of IF (.not.purmats)
-
-
-    call check_isotopes(q,ijb_u,ije_u,'leapfrog 1664')
-
-    ! ........................................................
-    ! ..............       schema  matsuno        ...............
-    ! ........................................................
-        IF( forward )  THEN
-
-         itau =  itau + 1
-          ! iday = day_ini+itau/day_step
-          ! time = REAL(itau-(iday-day_ini)*day_step)/day_step+time_0
-  !
-  !              IF(time.GT.1.) THEN
-  !               time = time-1.
-  !               iday = iday+1
-  !              ENDIF
-
-           forward =  .FALSE.
-           IF( itau.EQ. itaufinp1 ) then
-!$OMP MASTER
-             call fin_getparam
-!$OMP END MASTER
-
-IF (CPPKEY_INCA) THEN
-             IF (ANY(type_trac == ['inca','inco'])) THEN
-                CALL finalize_inca
-  ! switching back to LMDZDYN context
-!$OMP MASTER
-                IF (ok_dyn_xios) THEN
-                   CALL xios_set_current_context(dyn3d_ctx_handle)
-                ENDIF
-!$OMP END MASTER
-             ENDIF
-
-END IF
-IF (CPPKEY_REPROBUS) THEN
-             if (type_trac == 'repr') CALL finalize_reprobus
-END IF
-
-!$OMP MASTER
-             call finalize_parallel
-!$OMP END MASTER
-             abort_message = 'Simulation finished'
-             call abort_gcm(modname,abort_message,0)
-             RETURN
-           ENDIF
-           GO TO 2
-
-        ELSE ! of IF(forward) i.e. backward step
-
-
-          call check_isotopes(q,ijb_u,ije_u,'leapfrog 1698')
-
-          IF(MOD(itau,iperiod).EQ.0 .OR. itau.EQ.itaufin) THEN
-           IF(itau.EQ.itaufin) THEN
-              iav=1
-           ELSE
-              iav=0
-           ENDIF
-
-          ! ! Ehouarn: re-compute geopotential for outputs
-!$OMP BARRIER
-!$OMP MASTER
-          CALL geopot_loc(ip1jmp1,teta,pk,pks,phis,phi)
-!$OMP END MASTER
-!$OMP BARRIER
-
-           IF (ok_dynzon) THEN
-           CALL bilan_dyn_loc(2,dtvr*iperiod,dtvr*day_step*periodav, &
-                 ps,masse,pk,pbaru,pbarv,teta,phi,ucov,vcov,q)
-           ENDIF
-
-           IF (ok_dyn_ave) THEN
-             CALL writedynav_loc(itau,vcov, &
-                   ucov,teta,pk,phi,q,masse,ps,phis)
-           ENDIF
-
-
-
-          ENDIF ! of IF(MOD(itau,iperiod).EQ.0 .OR. itau.EQ.itaufin)
-
-
-           IF(MOD(itau,iecri         ).EQ.0) THEN
-
-!$OMP BARRIER
-!$OMP MASTER
-          CALL geopot_loc(ip1jmp1,teta,pk,pks,phis,phi)
-!$OMP END MASTER
-!$OMP BARRIER
-
-
-          if (ok_dyn_ins) then
-             CALL writehist_loc(itau,vcov,ucov,teta,pk,phi,q, &
-                   masse,ps,phis)
-          endif ! of if (ok_dyn_ins)
-
-
-          IF (ok_dyn_xios) THEN
-!$OMP MASTER
-             CALL xios_update_calendar(itau)
-!$OMP END MASTER
-!$OMP BARRIER
-             CALL writedyn_xios(vcov, &
-                   ucov,teta,pk,phi,q,masse,ps,phis)
-          ENDIF
-
-       ENDIF                ! of IF(MOD(itau,iecri).EQ.0)
-
-
-          IF(itau.EQ.itaufin) THEN
-             ! if (planet_type.eq."earth") then
-               CALL dynredem1_loc("restart.nc",0.0, &
-                     vcov,ucov,teta,q,masse,ps)
-            ! endif ! of if (planet_type.eq."earth")
-            if (ok_guide) then
-              ! ! set ok_guide to false to avoid extra output
-              ! ! in following forward step
-              ok_guide=.false.
-            endif
-
-          ENDIF ! of IF(itau.EQ.itaufin)
-
-          forward = .TRUE.
-          GO TO  1
-
-        ENDIF ! of IF (forward)
-
-
-        call check_isotopes(q,ijb_u,ije_u,'leapfrog 1750')
-
-  END IF ! of IF(.not.purmats)
-!$OMP MASTER
-  call fin_getparam
-!$OMP END MASTER
-
-IF (CPPKEY_INCA) THEN
-  IF (ANY(type_trac == ['inca','inco'])) THEN
-     CALL finalize_inca
-  ! switching back to LMDZDYN context
-!$OMP MASTER
-     IF (ok_dyn_xios) THEN
-        CALL xios_set_current_context(dyn3d_ctx_handle)
-     ENDIF
-!$OMP END MASTER
-  ENDIF
-
-END IF
-IF (CPPKEY_REPROBUS) THEN
-  if (type_trac == 'repr') CALL finalize_reprobus
-END IF
-
-!$OMP MASTER
-  call finalize_parallel
-!$OMP END MASTER
-  abort_message = 'Simulation finished'
-  call abort_gcm(modname,abort_message,0)
-  RETURN
-END SUBROUTINE leapfrog_loc
Index: /LMDZ6/trunk/libf/dyn3dmem/leapfrog_loc.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/leapfrog_loc.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3dmem/leapfrog_loc.f90	(revision 5268)
@@ -0,0 +1,1875 @@
+SUBROUTINE leapfrog_loc(ucov0,vcov0,teta0,ps0, &
+        masse0,phis0,q0,time_0)
+
+   USE misc_mod
+   USE parallel_lmdz
+   USE times
+   USE mod_hallo
+   USE Bands
+   USE Write_Field
+   USE Write_Field_p
+   USE vampir
+   USE timer_filtre, ONLY : print_filtre_timer
+   USE infotrac
+   USE guide_loc_mod, ONLY : guide_main
+   USE getparam
+   USE control_mod
+   USE mod_filtreg_p
+   USE write_field_loc
+   USE allocate_field_mod
+   USE call_dissip_mod, ONLY : call_dissip
+   USE call_calfis_mod, ONLY : call_calfis
+   USE leapfrog_mod, ONLY : ucov,vcov,teta,ps,masse,phis,q,dq &
+         ,ucovm1,vcovm1,tetam1,massem1,psm1,p,pks,pk,pkf,flxw &
+         ,pbaru,pbarv,du,dv,dteta,phi,dp,w &
+         ,leapfrog_allocate,leapfrog_switch_caldyn,leapfrog_switch_dissip
+
+   use exner_hyb_loc_m, only: exner_hyb_loc
+   use exner_milieu_loc_m, only: exner_milieu_loc
+   USE comconst_mod, ONLY: cpp, dtvr, ihf
+   USE comvert_mod, ONLY: ap, bp, pressure_exner
+   USE logic_mod, ONLY: iflag_phys,ok_guide,forward,leapf,apphys, &
+         statcl,conser,apdiss,purmats,ok_strato
+   USE temps_mod, ONLY: itaufin,jD_ref,jH_ref,day_ini, &
+         day_ref,start_time,dt
+   USE mod_xios_dyn3dmem, ONLY : dyn3d_ctx_handle
+   USE lmdz_xios, ONLY: xios_update_calendar, &
+         xios_set_current_context, &
+         using_xios
+   USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_INCA, CPPKEY_REPROBUS, CPPKEY_DEBUGIO
+   USE strings_mod, ONLY: int2str
+
+  IMPLICIT NONE
+
+   ! ......   Version  du 10/01/98    ..........
+
+   !        avec  coordonnees  verticales hybrides
+  !   avec nouveaux operat. dissipation * ( gradiv2,divgrad2,nxgraro2 )
+
+  !=======================================================================
+  !
+  !   Auteur:  P. Le Van /L. Fairhead/F.Hourdin
+  !   -------
+  !
+  !   Objet:
+  !   ------
+  !
+  !   GCM LMD nouvelle grille
+  !
+  !=======================================================================
+  !
+  !  ... Dans inigeom , nouveaux calculs pour les elongations  cu , cv
+  !  et possibilite d'appeler une fonction f(y)  a derivee tangente
+  !  hyperbolique a la  place de la fonction a derivee sinusoidale.
+
+  !  ... Possibilite de choisir le shema pour l'advection de
+  !    q  , en modifiant iadv dans traceur.def  (10/02) .
+  !
+  !  Pour Van-Leer + Vapeur d'eau saturee, iadv(1)=4. (F.Codron,10/99)
+  !  Pour Van-Leer iadv=10
+  !
+  !-----------------------------------------------------------------------
+  !   Declarations:
+  !   -------------
+
+  include "dimensions.h"
+  include "paramet.h"
+  include "comdissnew.h"
+  include "comgeom.h"
+  include "description.h"
+  include "iniprint.h"
+  include "academic.h"
+
+  REAL,INTENT(IN) :: time_0 ! not used
+
+  !   dynamical variables:
+  REAL,INTENT(IN) :: ucov0(ijb_u:ije_u,llm)    ! zonal covariant wind
+  REAL,INTENT(IN) :: vcov0(ijb_v:ije_v,llm)    ! meridional covariant wind
+  REAL,INTENT(IN) :: teta0(ijb_u:ije_u,llm)    ! potential temperature
+  REAL,INTENT(IN) :: q0(ijb_u:ije_u,llm,nqtot) ! advected tracers
+  REAL,INTENT(IN) :: ps0(ijb_u:ije_u)          ! surface pressure (Pa)
+  REAL,INTENT(IN) :: masse0(ijb_u:ije_u,llm)   ! air mass
+  REAL,INTENT(IN) :: phis0(ijb_u:ije_u)        ! geopotentiat at the surface
+
+  real :: zqmin,zqmax
+
+   ! REAL,SAVE,ALLOCATABLE :: p (:,:  )               ! pression aux interfac.des couches
+   ! REAL,SAVE,ALLOCATABLE :: pks(:)                      ! exner au  sol
+   ! REAL,SAVE,ALLOCATABLE :: pk(:,:)                   ! exner au milieu des couches
+   ! REAL,SAVE,ALLOCATABLE :: pkf(:,:)                  ! exner filt.au milieu des couches
+   ! REAL,SAVE,ALLOCATABLE :: phi(:,:)                  ! geopotentiel
+   ! REAL,SAVE,ALLOCATABLE :: w(:,:)                    ! vitesse verticale
+
+  ! variables dynamiques intermediaire pour le transport
+   ! REAL,SAVE,ALLOCATABLE :: pbaru(:,:),pbarv(:,:) !flux de masse
+
+  !   variables dynamiques au pas -1
+   ! REAL,SAVE,ALLOCATABLE :: vcovm1(:,:),ucovm1(:,:)
+  !      REAL,SAVE,ALLOCATABLE :: tetam1(:,:),psm1(:)
+   ! REAL,SAVE,ALLOCATABLE :: massem1(:,:)
+
+  !   tendances dynamiques
+   ! REAL,SAVE,ALLOCATABLE :: dv(:,:),du(:,:)
+   ! REAL,SAVE,ALLOCATABLE :: dteta(:,:),dp(:)
+   ! REAL,DIMENSION(:,:,:), ALLOCATABLE, SAVE :: dq
+
+  !   tendances de la dissipation
+   ! REAL,SAVE,ALLOCATABLE :: dvdis(:,:),dudis(:,:)
+   ! REAL,SAVE,ALLOCATABLE :: dtetadis(:,:)
+
+  !   tendances physiques
+  REAL,SAVE,ALLOCATABLE :: dvfi(:,:),dufi(:,:)
+  REAL,SAVE,ALLOCATABLE :: dtetafi(:,:)
+  REAL,SAVE,ALLOCATABLE :: dpfi(:)
+  REAL,DIMENSION(:,:,:),ALLOCATABLE,SAVE :: dqfi
+
+  !   variables pour le fichier histoire
+  REAL :: dtav      ! intervalle de temps elementaire
+
+  REAL :: tppn(iim),tpps(iim),tpn,tps
+  !
+  INTEGER :: itau,itaufinp1,iav
+   ! INTEGER  iday ! jour julien
+  REAL :: time
+
+  REAL :: SSUM
+   ! REAL,SAVE,ALLOCATABLE :: finvmaold(:,:)
+
+  !ym      LOGICAL  lafin
+  LOGICAL :: lafin
+  INTEGER :: ij,iq,l
+  INTEGER :: ik
+
+  real :: time_step, t_wrt, t_ops
+
+  ! jD_cur: jour julien courant
+  ! jH_cur: heure julienne courante
+  REAL :: jD_cur, jH_cur
+  INTEGER :: an, mois, jour
+  REAL :: secondes
+
+  logical :: physic
+  LOGICAL :: first,callinigrads
+
+  data callinigrads/.true./
+  character(len=10) :: string10
+
+   ! REAL,SAVE,ALLOCATABLE :: flxw(:,:) ! flux de masse verticale
+
+  !+jld variables test conservation energie
+   ! REAL,SAVE,ALLOCATABLE :: ecin(:,:),ecin0(:,:)
+  ! Tendance de la temp. potentiel d (theta)/ d t due a la
+  ! tansformation d'energie cinetique en energie thermique
+  ! cree par la dissipation
+  !  REAL,SAVE,ALLOCATABLE :: dtetaecdt(:,:)
+  !  REAL,SAVE,ALLOCATABLE :: vcont(:,:),ucont(:,:)
+  !  REAL,SAVE,ALLOCATABLE :: vnat(:,:),unat(:,:)
+  REAL :: d_h_vcol, d_qt, d_qw, d_ql, d_ec
+  CHARACTER(len=15) :: ztit
+  !!      INTEGER   ip_ebil_dyn  ! PRINT level for energy conserv. diag.
+   ! SAVE      ip_ebil_dyn
+   ! DATA      ip_ebil_dyn/0/
+  !-jld
+
+  character(len=80) :: dynhist_file, dynhistave_file
+  character(len=*),parameter :: modname="leapfrog_loc"
+  character(len=80) :: abort_message
+
+
+  logical,PARAMETER :: dissip_conservative=.TRUE.
+
+  INTEGER :: testita
+  PARAMETER (testita = 9)
+
+  logical , parameter :: flag_verif = .false.
+
+  ! declaration liees au parallelisme
+  INTEGER :: ierr
+  LOGICAL :: FirstCaldyn
+  LOGICAL :: FirstPhysic
+  INTEGER :: ijb,ije,j,i
+  type(Request) :: TestRequest
+  type(Request) :: Request_Dissip
+  type(Request) :: Request_physic
+
+  INTEGER :: true_itau
+  INTEGER :: iapptrac
+  INTEGER :: AdjustCount
+   ! INTEGER :: var_time
+  LOGICAL :: ok_start_timer=.FALSE.
+  LOGICAL, SAVE :: firstcall=.TRUE.
+  TYPE(distrib),SAVE :: new_dist
+
+  call check_isotopes(q0,ijb_u,ije_u,'leapfrog204: debut')
+
+!$OMP MASTER
+  ItCount=0
+!$OMP END MASTER
+  true_itau=0
+  FirstCaldyn=.TRUE.
+  FirstPhysic=.TRUE.
+  iapptrac=0
+  AdjustCount = 0
+  lafin=.false.
+
+  if (nday>=0) then
+     itaufin   = nday*day_step
+  else
+     itaufin   = -nday
+  endif
+
+  itaufinp1 = itaufin +1
+
+  call check_isotopes(q0,ijb_u,ije_u,'leapfrog 226')
+
+  itau = 0
+  physic=.true.
+  if (iflag_phys==0.or.iflag_phys==2) physic=.false.
+  CALL init_nan
+  CALL leapfrog_allocate
+  ucov=ucov0
+  vcov=vcov0
+  teta=teta0
+  ps=ps0
+  masse=masse0
+  phis=phis0
+  q=q0
+
+  call check_isotopes(q,ijb_u,ije_u,'leapfrog 239')
+
+   ! iday = day_ini+itau/day_step
+   ! time = REAL(itau-(iday-day_ini)*day_step)/day_step+time_0
+   !    IF(time.GT.1.) THEN
+   !     time = time-1.
+   !     iday = iday+1
+   !    ENDIF
+
+  ! Allocate variables depending on dynamic variable nqtot
+!$OMP MASTER
+  if (firstcall) then
+  !
+  !  ALLOCATE(p(ijb_u:ije_u,llmp1))
+  !      ALLOCATE(pks(ijb_u:ije_u))
+  !  ALLOCATE(pk(ijb_u:ije_u,llm))
+  !  ALLOCATE(pkf(ijb_u:ije_u,llm))
+  !  ALLOCATE(phi(ijb_u:ije_u,llm))
+  !  ALLOCATE(w(ijb_u:ije_u,llm))
+  !  ALLOCATE(pbaru(ip1jmp1,llm),pbarv(ip1jm,llm))
+  !  ALLOCATE(vcovm1(ijb_v:ije_v,llm),ucovm1(ijb_u:ije_u,llm))
+  !  ALLOCATE(tetam1(ijb_u:ije_u,llm),psm1(ijb_u:ije_u))
+  !  ALLOCATE(massem1(ijb_u:ije_u,llm))
+  !  ALLOCATE(dv(ijb_v:ije_v,llm),du(ijb_u:ije_u,llm))
+  !  ALLOCATE(dteta(ijb_u:ije_u,llm),dp(ijb_u:ije_u))
+  !  ALLOCATE(dvdis(ijb_v:ije_v,llm),dudis(ijb_u:ije_u,llm))
+  !  ALLOCATE(dtetadis(ijb_u:ije_u,llm))
+  ALLOCATE(dvfi(ijb_v:ije_v,llm),dufi(ijb_u:ije_u,llm))
+  ALLOCATE(dtetafi(ijb_u:ije_u,llm))
+  ALLOCATE(dpfi(ijb_u:ije_u))
+   ! ALLOCATE(dq(ijb_u:ije_u,llm,nqtot))
+  ALLOCATE(dqfi(ijb_u:ije_u,llm,nqtot))
+   ! ALLOCATE(dqfi_tmp(iip1,llm,nqtot))
+   ! ALLOCATE(finvmaold(ijb_u:ije_u,llm))
+   ! ALLOCATE(flxw(ijb_u:ije_u,llm))
+   ! ALLOCATE(ecin(ijb_u:ije_u,llm),ecin0(ijb_u:ije_u,llm))
+   ! ALLOCATE(dtetaecdt(ijb_u:ije_u,llm))
+   ! ALLOCATE(vcont(ijb_v:ije_v,llm),ucont(ijb_u:ije_u,llm))
+   ! ALLOCATE(vnat(ijb_v:ije_v,llm),unat(ijb_u:ije_u,llm))
+  endif
+!$OMP END MASTER
+!$OMP BARRIER
+
+             ! CALL dynredem1_loc("restart.nc",0.0,
+  ! &                           vcov,ucov,teta,q,masse,ps)
+
+
+  !-----------------------------------------------------------------------
+  !   On initialise la pression et la fonction d'Exner :
+  !   --------------------------------------------------
+
+!$OMP MASTER
+  dq(:,:,:)=0.
+  CALL pression ( ijnb_u, ap, bp, ps, p       )
+!$OMP END MASTER
+  if (pressure_exner) then
+  CALL exner_hyb_loc( ijnb_u, ps, p, pks, pk, pkf)
+  else
+    CALL exner_milieu_loc( ijnb_u, ps, p, pks, pk, pkf )
+  endif
+  !-----------------------------------------------------------------------
+  !   Debut de l'integration temporelle:
+  !   ----------------------------------
+  ! et du parallelisme !!
+
+   1   CONTINUE ! Matsuno Forward step begins here
+
+  !   date: (NB: date remains unchanged for Backward step)
+  !   -----
+
+  jD_cur = jD_ref + day_ini - day_ref +                             &
+        (itau+1)/day_step
+  jH_cur = jH_ref + start_time +                                    &
+        mod(itau+1,day_step)/float(day_step)
+  if (jH_cur > 1.0 ) then
+    jD_cur = jD_cur +1.
+    jH_cur = jH_cur -1.
+  endif
+
+  call check_isotopes(q,ijb_u,ije_u,'leapfrog 321')
+
+  if (ok_guide) then
+    call guide_main(itau,ucov,vcov,teta,q,masse,ps)
+!$OMP BARRIER
+  endif
+
+
+
+  !
+  ! IF( MOD( itau, 10* day_step ).EQ.0 )  THEN
+  !   CALL  test_period ( ucov,vcov,teta,q,p,phis )
+  !   PRINT *,' ----   Test_period apres continue   OK ! -----', itau
+  ! ENDIF
+  !
+  !ym      CALL SCOPY( ijmllm ,vcov , 1, vcovm1 , 1 )
+  !ym      CALL SCOPY( ijp1llm,ucov , 1, ucovm1 , 1 )
+  !ym      CALL SCOPY( ijp1llm,teta , 1, tetam1 , 1 )
+  !ym      CALL SCOPY( ijp1llm,masse, 1, massem1, 1 )
+  !ym      CALL SCOPY( ip1jmp1, ps  , 1,   psm1 , 1 )
+
+   if (FirstCaldyn) then
+!$OMP MASTER
+     ucovm1=ucov
+     vcovm1=vcov
+     tetam1= teta
+     massem1= masse
+     psm1= ps
+
+  ! Ehouarn: finvmaold is actually not used
+      ! finvmaold = masse
+!$OMP END MASTER
+!$OMP BARRIER
+      ! CALL filtreg_p ( finvmaold ,jjb_u,jje_u,jjb_u,jje_u,jjp1, llm,
+  ! &                    -2,2, .TRUE., 1 )
+   else
+  ! Save fields obtained at previous time step as '...m1'
+     ijb=ij_begin
+     ije=ij_end
+
+!$OMP MASTER
+     psm1     (ijb:ije) = ps    (ijb:ije)
+!$OMP END MASTER
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+     DO l=1,llm
+       ije=ij_end
+       ucovm1   (ijb:ije,l) = ucov  (ijb:ije,l)
+       tetam1   (ijb:ije,l) = teta  (ijb:ije,l)
+       massem1  (ijb:ije,l) = masse (ijb:ije,l)
+        ! finvmaold(ijb:ije,l)=masse(ijb:ije,l)
+
+       if (pole_sud) ije=ij_end-iip1
+       vcovm1(ijb:ije,l) = vcov  (ijb:ije,l)
+
+
+     ENDDO
+!$OMP ENDDO
+
+
+  ! Ehouarn: finvmaold not used
+       ! CALL filtreg_p(finvmaold ,jjb_u,jje_u,jj_begin,jj_end,jjp1,
+  ! .                    llm, -2,2, .TRUE., 1 )
+
+   endif ! of if (FirstCaldyn)
+
+  forward = .TRUE.
+  leapf   = .FALSE.
+  dt      =  dtvr
+
+  !   ...    P.Le Van .26/04/94  ....
+
+  !ym      CALL SCOPY   ( ijp1llm,   masse, 1, finvmaold,     1 )
+  !ym      CALL filtreg ( finvmaold ,jjp1, llm, -2,2, .TRUE., 1 )
+
+  !ym  ne sert a rien
+  !ym      call minmax(ijp1llm,q(:,:,3),zqmin,zqmax)
+
+
+     call check_isotopes(q,ijb_u,ije_u,'leapfrog 400')
+
+   2   CONTINUE ! Matsuno backward or leapfrog step begins here
+
+
+  call check_isotopes(q,ijb_u,ije_u,'leapfrog 402')
+
+!$OMP MASTER
+  ItCount=ItCount+1
+  if (MOD(ItCount,1)==1) then
+    debug=.true.
+  else
+    debug=.false.
+  endif
+!$OMP END MASTER
+  !-----------------------------------------------------------------------
+
+  !   date: (NB: only leapfrog step requires recomputing date)
+  !   -----
+
+  IF (leapf) THEN
+    jD_cur = jD_ref + day_ini - day_ref + &
+          (itau+1)/day_step
+    jH_cur = jH_ref + start_time + &
+          mod(itau+1,day_step)/float(day_step)
+    if (jH_cur > 1.0 ) then
+      jD_cur = jD_cur +1.
+      jH_cur = jH_cur -1.
+    endif
+  ENDIF
+
+  !   gestion des appels de la physique et des dissipations:
+  !   ------------------------------------------------------
+  !
+  !   ...    P.Le Van  ( 6/02/95 )  ....
+
+  apphys = .FALSE.
+  statcl = .FALSE.
+  conser = .FALSE.
+  apdiss = .FALSE.
+
+  IF( purmats ) THEN
+  ! ! Purely Matsuno time stepping
+     IF( MOD(itau,iconser) .EQ.0.AND.  forward    ) conser = .TRUE.
+     IF( MOD(itau,dissip_period ).EQ.0.AND..NOT.forward ) &
+           apdiss = .TRUE.
+     IF( MOD(itau,iphysiq ).EQ.0.AND..NOT.forward &
+           .and. physic                        ) apphys = .TRUE.
+  ELSE
+  ! ! Leapfrog/Matsuno time stepping
+     IF( MOD(itau   ,iconser) .EQ. 0              ) conser = .TRUE.
+     IF( MOD(itau+1,dissip_period).EQ.0 .AND. .NOT. forward ) &
+           apdiss = .TRUE.
+     IF( MOD(itau+1,iphysiq).EQ.0.AND.physic) apphys=.TRUE.
+  END IF
+
+  ! Ehouarn: for Shallow Water case (ie: 1 vertical layer),
+       ! supress dissipation step
+  if (llm.eq.1) then
+    apdiss=.false.
+  endif
+
+  !ym    ---> Pour le moment
+  !ym      apphys = .FALSE.
+  statcl = .FALSE.
+  ! conser = .FALSE. ! ie: no output of control variables to stdout in //
+
+  if (firstCaldyn) then
+!$OMP MASTER
+      call Set_Distrib(distrib_caldyn)
+!$OMP END MASTER
+!$OMP BARRIER
+      firstCaldyn=.FALSE.
+  !ym          call InitTime
+!$OMP MASTER
+      call Init_timer
+!$OMP END MASTER
+  endif
+
+!$OMP MASTER
+  IF (ok_start_timer) THEN
+    CALL InitTime
+    ok_start_timer=.FALSE.
+  ENDIF
+!$OMP END MASTER
+
+
+  call check_isotopes(q,ijb_u,ije_u,'leapfrog 471')
+
+  !ym  PAS D'AJUSTEMENT POUR LE MOMENT
+  if (Adjust) then
+    AdjustCount=AdjustCount+1
+     ! if (iapptrac==iapp_tracvl .and. (forward.OR. leapf)
+  ! &         .and. itau/iphysiq>2 .and. Adjustcount>30) then
+    if (Adjustcount>1) then
+       AdjustCount=0
+!$OMP MASTER
+       call allgather_timer_average
+
+    if (prt_level > 9) then
+
+    print *,'*********************************'
+    print *,'******    TIMER CALDYN     ******'
+    do i=0,mpi_size-1
+      print *,'proc',i,' :   Nb Bandes  :',jj_nb_caldyn(i), &
+            '  : temps moyen :', &
+            timer_average(jj_nb_caldyn(i),timer_caldyn,i), &
+            '+-',timer_delta(jj_nb_caldyn(i),timer_caldyn,i)
+    enddo
+
+    print *,'*********************************'
+    print *,'******    TIMER VANLEER    ******'
+    do i=0,mpi_size-1
+      print *,'proc',i,' :   Nb Bandes  :',jj_nb_vanleer(i), &
+            '  : temps moyen :', &
+            timer_average(jj_nb_vanleer(i),timer_vanleer,i), &
+            '+-',timer_delta(jj_nb_vanleer(i),timer_vanleer,i)
+    enddo
+
+    print *,'*********************************'
+    print *,'******    TIMER DISSIP    ******'
+    do i=0,mpi_size-1
+      print *,'proc',i,' :   Nb Bandes  :',jj_nb_dissip(i), &
+            '  : temps moyen :', &
+            timer_average(jj_nb_dissip(i),timer_dissip,i), &
+            '+-',timer_delta(jj_nb_dissip(i),timer_dissip,i)
+    enddo
+
+     ! if (mpi_rank==0) call WriteBands
+
+   endif
+
+     call AdjustBands_caldyn(new_dist)
+!$OMP END MASTER
+!$OMP BARRIER
+     CALL leapfrog_switch_caldyn(new_dist)
+!$OMP BARRIER
+
+
+!$OMP MASTER
+     distrib_caldyn=new_dist
+     CALL set_distrib(distrib_caldyn)
+!$OMP END MASTER
+!$OMP BARRIER
+      ! call Register_SwapFieldHallo(ucov,ucov,ip1jmp1,llm,
+  ! &                                jj_Nb_caldyn,0,0,TestRequest)
+  !     call Register_SwapFieldHallo(ucovm1,ucovm1,ip1jmp1,llm,
+  ! &                                jj_Nb_caldyn,0,0,TestRequest)
+  !     call Register_SwapFieldHallo(vcov,vcov,ip1jm,llm,
+  ! &                                jj_Nb_caldyn,0,0,TestRequest)
+  !     call Register_SwapFieldHallo(vcovm1,vcovm1,ip1jm,llm,
+  ! &                                jj_Nb_caldyn,0,0,TestRequest)
+  !     call Register_SwapFieldHallo(teta,teta,ip1jmp1,llm,
+  ! &                                jj_Nb_caldyn,0,0,TestRequest)
+  !     call Register_SwapFieldHallo(tetam1,tetam1,ip1jmp1,llm,
+  ! &                                jj_Nb_caldyn,0,0,TestRequest)
+  !     call Register_SwapFieldHallo(masse,masse,ip1jmp1,llm,
+  ! &                                jj_Nb_caldyn,0,0,TestRequest)
+  !     call Register_SwapFieldHallo(massem1,massem1,ip1jmp1,llm,
+  ! &                                jj_Nb_caldyn,0,0,TestRequest)
+  !     call Register_SwapFieldHallo(ps,ps,ip1jmp1,1,
+  ! &                                jj_Nb_caldyn,0,0,TestRequest)
+  !     call Register_SwapFieldHallo(psm1,psm1,ip1jmp1,1,
+  ! &                                jj_Nb_caldyn,0,0,TestRequest)
+  !     call Register_SwapFieldHallo(pkf,pkf,ip1jmp1,llm,
+  ! &                                jj_Nb_caldyn,0,0,TestRequest)
+  !     call Register_SwapFieldHallo(pk,pk,ip1jmp1,llm,
+  ! &                                jj_Nb_caldyn,0,0,TestRequest)
+  !     call Register_SwapFieldHallo(pks,pks,ip1jmp1,1,
+  ! &                                jj_Nb_caldyn,0,0,TestRequest)
+  !     call Register_SwapFieldHallo(phis,phis,ip1jmp1,1,
+  ! &                                jj_Nb_caldyn,0,0,TestRequest)
+  !     call Register_SwapFieldHallo(phi,phi,ip1jmp1,llm,
+  ! &                                jj_Nb_caldyn,0,0,TestRequest)
+  !     call Register_SwapFieldHallo(finvmaold,finvmaold,ip1jmp1,llm,
+  ! &                                jj_Nb_caldyn,0,0,TestRequest)
+  !
+  !    do j=1,nqtot
+  !     call Register_SwapFieldHallo(q(:,:,j),q(:,:,j),ip1jmp1,llm,
+  ! &                                jj_nb_caldyn,0,0,TestRequest)
+  !    enddo
+  !
+  !     call Set_Distrib(distrib_caldyn)
+  !     call SendRequest(TestRequest)
+  !     call WaitRequest(TestRequest)
+
+!$OMP MASTER
+    call AdjustBands_dissip(new_dist)
+!$OMP END MASTER
+!$OMP BARRIER
+    CALL leapfrog_switch_dissip(new_dist)
+!$OMP BARRIER
+!$OMP MASTER
+    distrib_dissip=new_dist
+!$OMP END MASTER
+!$OMP BARRIER
+     ! call AdjustBands_physic
+
+!$OMP MASTER
+    if (mpi_rank==0) call WriteBands
+!$OMP END MASTER
+
+
+  endif
+  endif
+
+
+  call check_isotopes(q,ijb_u,ije_u,'leapfrog 589')
+
+  !-----------------------------------------------------------------------
+  !   calcul des tendances dynamiques:
+  !   --------------------------------
+!$OMP BARRIER
+!$OMP MASTER
+   call VTb(VThallo)
+!$OMP END MASTER
+
+   call Register_Hallo_u(ucov,llm,1,1,1,1,TestRequest)
+   call Register_Hallo_v(vcov,llm,1,1,1,1,TestRequest)
+   call Register_Hallo_u(teta,llm,1,1,1,1,TestRequest)
+   call Register_Hallo_u(ps,1,1,2,2,1,TestRequest)
+   call Register_Hallo_u(pkf,llm,1,1,1,1,TestRequest)
+   call Register_Hallo_u(pk,llm,1,1,1,1,TestRequest)
+   call Register_Hallo_u(pks,1,1,1,1,1,TestRequest)
+   call Register_Hallo_u(p,llmp1,1,1,1,1,TestRequest)
+
+    ! do j=1,nqtot
+    !   call Register_Hallo(q(1,1,j),ip1jmp1,llm,1,1,1,1,
+  ! *                       TestRequest)
+  !    enddo
+
+   call SendRequest(TestRequest)
+!$OMP BARRIER
+   call WaitRequest(TestRequest)
+
+!$OMP MASTER
+   call VTe(VThallo)
+!$OMP END MASTER
+!$OMP BARRIER
+
+  if (debug) then
+    call WriteField_u('ucov',ucov)
+    call WriteField_v('vcov',vcov)
+    call WriteField_u('teta',teta)
+    call WriteField_u('ps',ps)
+    call WriteField_u('masse',masse)
+    call WriteField_u('pk',pk)
+    call WriteField_u('pks',pks)
+    call WriteField_u('pkf',pkf)
+    call WriteField_u('phis',phis)
+    do iq=1,nqtot
+      call WriteField_u('q'//trim(int2str(iq)), &
+            q(:,:,iq))
+    enddo
+  endif
+
+
+  True_itau=True_itau+1
+
+!$OMP MASTER
+  IF (prt_level>9) THEN
+    WRITE(lunout,*)"leapfrog_p: Iteration No",True_itau
+  ENDIF
+
+
+  call start_timer(timer_caldyn)
+
+  ! ! compute geopotential phi()
+  CALL geopot_loc  ( ip1jmp1, teta  , pk , pks,  phis  , phi   )
+
+  call check_isotopes(q,ijb_u,ije_u,'leapfrog 651')
+
+  call VTb(VTcaldyn)
+!$OMP END MASTER
+   ! var_time=time+iday-day_ini
+
+!$OMP BARRIER
+   ! CALL FTRACE_REGION_BEGIN("caldyn")
+  time = jD_cur + jH_cur
+
+  CALL caldyn_loc &
+        ( itau,ucov,vcov,teta,ps,masse,pk,pkf,phis , &
+        phi,conser,du,dv,dteta,dp,w, pbaru,pbarv, time )
+
+   ! CALL FTRACE_REGION_END("caldyn")
+
+!$OMP MASTER
+  if (mpi_rank==0.AND.conser) THEN
+     WRITE(lunout,*) 'leapfrog_loc, Time step: ',itau,' Day:',time
+  ENDIF
+  call VTe(VTcaldyn)
+!$OMP END MASTER
+
+IF (CPPKEY_DEBUGIO) THEN
+  call WriteField_u('du',du)
+  call WriteField_v('dv',dv)
+  call WriteField_u('dteta',dteta)
+  call WriteField_u('dp',dp)
+  call WriteField_u('w',w)
+  call WriteField_u('pbaru',pbaru)
+  call WriteField_v('pbarv',pbarv)
+  call WriteField_u('p',p)
+  call WriteField_u('masse',masse)
+  call WriteField_u('pk',pk)
+END IF
+  !-----------------------------------------------------------------------
+  !   calcul des tendances advection des traceurs (dont l'humidite)
+  !   -------------------------------------------------------------
+
+  call check_isotopes(q,ijb_u,ije_u, &
+        'leapfrog 686: avant caladvtrac')
+
+  IF( forward.OR. leapf )  THEN
+  ! Ehouarn: NB: fields sent to advtrac are those at the beginning of the time step
+    ! !write(*,*) 'leapfrog 679: avant CALL caladvtrac_loc'
+     CALL caladvtrac_loc(q,pbaru,pbarv, &
+           p, masse, dq,  teta, &
+           flxw,pk, iapptrac)
+
+  ! call creation of mass flux
+     IF (offline .AND. .NOT. adjust) THEN
+        CALL fluxstokenc_p(pbaru,pbarv,masse,teta,phi)
+     ENDIF
+
+     ! !write(*,*) 'leapfrog 719'
+     call check_isotopes(q,ijb_u,ije_u, &
+           'leapfrog 698: apres caladvtrac')
+
+   ! do j=1,nqtot
+   !   call WriteField_u('qadv'//trim(int2str(j)),q(:,:,j))
+   ! enddo
+
+  ! Ehouarn: Storage of mass flux for off-line tracers... not implemented...
+
+  ENDIF ! of IF( forward.OR. leapf )
+
+
+  !-----------------------------------------------------------------------
+  !   integrations dynamique et traceurs:
+  !   ----------------------------------
+
+!$OMP MASTER
+   call VTb(VTintegre)
+!$OMP END MASTER
+IF (CPPKEY_DEBUGIO) THEN
+  if (true_itau>20) then
+  call WriteField_u('ucovm1',ucovm1)
+  call WriteField_v('vcovm1',vcovm1)
+  call WriteField_u('tetam1',tetam1)
+  call WriteField_u('psm1',psm1)
+  call WriteField_u('ucov_int',ucov)
+  call WriteField_v('vcov_int',vcov)
+  call WriteField_u('teta_int',teta)
+  call WriteField_u('ps_int',ps)
+  endif
+END IF
+!$OMP BARRIER
+    ! CALL FTRACE_REGION_BEGIN("integrd")
+
+   ! !write(*,*) 'leapfrog 720'
+   call check_isotopes(q,ijb_u,ije_u,'leapfrog 756')
+
+   ! ! CRisi: pourquoi aller jusqu'à 2 et non pas jusqu'à nqtot??
+   CALL integrd_loc ( nqtot,vcovm1,ucovm1,tetam1,psm1,massem1 , &
+         dv,du,dteta,dq,dp,vcov,ucov,teta,q,ps,masse,phis)
+  ! $              finvmaold                                    )
+
+  !  !write(*,*) 'leapfrog 724'
+   call check_isotopes(q,ijb_u,ije_u,'leapfrog 762')
+
+    ! CALL FTRACE_REGION_END("integrd")
+!$OMP BARRIER
+IF (CPPKEY_DEBUGIO) THEN
+  call WriteField_u('ucovm1',ucovm1)
+  call WriteField_v('vcovm1',vcovm1)
+  call WriteField_u('tetam1',tetam1)
+  call WriteField_u('psm1',psm1)
+  call WriteField_u('ucov_int',ucov)
+  call WriteField_v('vcov_int',vcov)
+  call WriteField_u('teta_int',teta)
+  call WriteField_u('ps_int',ps)
+END IF
+
+  call check_isotopes(q,ijb_u,ije_u,'leapfrog 775')
+
+   ! do j=1,nqtot
+   !   call WriteField_p('q'//trim(int2str(j)),
+  ! .                reshape(q(:,:,j),(/iip1,jmp1,llm/)))
+  !    call WriteField_p('dq'//trim(int2str(j)),
+  ! .                reshape(dq(:,:,j),(/iip1,jmp1,llm/)))
+  !  enddo
+
+
+!$OMP MASTER
+   call VTe(VTintegre)
+!$OMP END MASTER
+  ! .P.Le Van (26/04/94  ajout de  finvpold dans l'appel d'integrd)
+  !
+  !-----------------------------------------------------------------------
+  !   calcul des tendances physiques:
+  !   -------------------------------
+  !    ########   P.Le Van ( Modif le  6/02/95 )   ###########
+  !
+   IF( purmats )  THEN
+      IF( itau.EQ.itaufin.AND..NOT.forward ) lafin = .TRUE.
+   ELSE
+      IF( itau+1.EQ. itaufin )              lafin = .TRUE.
+   ENDIF
+
+  !c$OMP END PARALLEL
+
+  !
+  !
+   IF( apphys )  THEN
+
+     CALL call_calfis(itau,lafin,ucov,vcov,teta,masse,ps, &
+           phis,q,flxw)
+  ! #ifdef DEBUG_IO
+      ! call WriteField_u('ucovfi',ucov)
+      ! call WriteField_v('vcovfi',vcov)
+      ! call WriteField_u('tetafi',teta)
+      ! call WriteField_u('pfi',p)
+      ! call WriteField_u('pkfi',pk)
+      ! do j=1,nqtot
+      !   call WriteField_u('qfi'//trim(int2str(j)),q(:,:,j))
+      ! enddo
+  ! #endif
+  ! c
+  ! c     .......   Ajout   P.Le Van ( 17/04/96 )   ...........
+  ! c
+  ! cc$OMP PARALLEL DEFAULT(SHARED)
+  ! cc$OMP+         PRIVATE(rdaym_ini,rdayvrai,ijb,ije)
+
+  ! c$OMP MASTER
+      !  call suspend_timer(timer_caldyn)
+
+      !  write(lunout,*)
+   ! &   'leapfrog_p: Entree dans la physique : Iteration No ',true_itau
+  ! c$OMP END MASTER
+
+   !     CALL pression_loc (  ip1jmp1, ap, bp, ps,  p      )
+
+  ! c$OMP BARRIER
+   !     CALL exner_hyb_loc(  ip1jmp1, ps, p,pks, pk, pkf )
+  ! c$OMP BARRIER
+   !       jD_cur = jD_ref + day_ini - day_ref
+   ! $        + int (itau * dtvr / daysec)
+   !       jH_cur = jH_ref +                                            &
+   ! &              (itau * dtvr / daysec - int(itau * dtvr / daysec))
+  ! !         call ju2ymds(jD_cur+jH_cur, an, mois, jour, secondes)
+
+  ! c rajout debug
+  ! c       lafin = .true.
+
+
+  ! c   Inbterface avec les routines de phylmd (phymars ... )
+  ! c   -----------------------------------------------------
+
+  ! c+jld
+
+  ! c  Diagnostique de conservation de l'energie : initialisation
+  !
+  ! c-jld
+  ! c$OMP BARRIER
+  ! c$OMP MASTER
+  !     call VTb(VThallo)
+  ! c$OMP END MASTER
+
+  ! #ifdef DEBUG_IO
+  !     call WriteField_u('ucovfi',ucov)
+  !     call WriteField_v('vcovfi',vcov)
+  !     call WriteField_u('tetafi',teta)
+  !     call WriteField_u('pfi',p)
+  !     call WriteField_u('pkfi',pk)
+  ! #endif
+  !     call SetTag(Request_physic,800)
+  !
+  !     call Register_SwapField_u(ucov,ucov,distrib_physic,
+  !  *                            Request_physic,up=2,down=2)
+  !
+  !     call Register_SwapField_v(vcov,vcov,distrib_physic,
+  !  *                            Request_physic,up=2,down=2)
+
+  !     call Register_SwapField_u(teta,teta,distrib_physic,
+  !  *                            Request_physic,up=2,down=2)
+  !
+  !     call Register_SwapField_u(masse,masse,distrib_physic,
+  !  *                            Request_physic,up=1,down=2)
+
+  !     call Register_SwapField_u(p,p,distrib_physic,
+  !  *                            Request_physic,up=2,down=2)
+  !
+  !     call Register_SwapField_u(pk,pk,distrib_physic,
+  !  *                            Request_physic,up=2,down=2)
+  !
+  !     call Register_SwapField_u(phis,phis,distrib_physic,
+  !  *                            Request_physic,up=2,down=2)
+  !
+  !     call Register_SwapField_u(phi,phi,distrib_physic,
+  !  *                            Request_physic,up=2,down=2)
+  !
+  !     call Register_SwapField_u(w,w,distrib_physic,
+  !  *                            Request_physic,up=2,down=2)
+  !
+  !     call Register_SwapField_u(q,q,distrib_physic,
+  !  *                            Request_physic,up=2,down=2)
+
+  !     call Register_SwapField_u(flxw,flxw,distrib_physic,
+  !  *                            Request_physic,up=2,down=2)
+  !
+  !     call SendRequest(Request_Physic)
+  ! c$OMP BARRIER
+  !     call WaitRequest(Request_Physic)
+
+  ! c$OMP BARRIER
+  ! c$OMP MASTER
+  !     call Set_Distrib(distrib_Physic)
+  !     call VTe(VThallo)
+  !
+  !     call VTb(VTphysiq)
+  ! c$OMP END MASTER
+  ! c$OMP BARRIER
+
+  ! #ifdef DEBUG_IO
+  !   call WriteField_u('ucovfi',ucov)
+  !   call WriteField_v('vcovfi',vcov)
+  !   call WriteField_u('tetafi',teta)
+  !   call WriteField_u('pfi',p)
+  !   call WriteField_u('pkfi',pk)
+  !   do j=1,nqtot
+  !     call WriteField_u('qfi'//trim(int2str(j)),q(:,:,j))
+  !   enddo
+  ! #endif
+  !    STOP
+  ! c$OMP BARRIER
+  ! !        CALL FTRACE_REGION_BEGIN("calfis")
+  !     CALL calfis_loc(lafin ,jD_cur, jH_cur,
+  !  $               ucov,vcov,teta,q,masse,ps,p,pk,phis,phi ,
+  !  $               du,dv,dteta,dq,
+  !  $               flxw,
+  !  $               dufi,dvfi,dtetafi,dqfi,dpfi  )
+  ! !        CALL FTRACE_REGION_END("calfis")
+  ! !        ijb=ij_begin
+  ! !        ije=ij_end
+  ! !        if ( .not. pole_nord) then
+  ! !c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  ! !          DO l=1,llm
+  ! !          dufi_tmp(1:iip1,l)   = dufi(ijb:ijb+iim,l)
+  ! !          dvfi_tmp(1:iip1,l)   = dvfi(ijb:ijb+iim,l)
+  ! !          dtetafi_tmp(1:iip1,l)= dtetafi(ijb:ijb+iim,l)
+  ! !          dqfi_tmp(1:iip1,l,:) = dqfi(ijb:ijb+iim,l,:)
+  ! !          ENDDO
+  ! !c$OMP END DO NOWAIT
+  ! !
+  ! !c$OMP MASTER
+  ! !          dpfi_tmp(1:iip1)     = dpfi(ijb:ijb+iim)
+  ! !c$OMP END MASTER
+  ! !        endif ! of if ( .not. pole_nord)
+
+  ! !c$OMP BARRIER
+  ! !c$OMP MASTER
+  ! !        call Set_Distrib(distrib_physic_bis)
+
+  ! !        call VTb(VThallo)
+  ! !c$OMP END MASTER
+  ! !c$OMP BARRIER
+  ! !
+  ! !        call Register_Hallo_u(dufi,llm,
+  ! !     *                      1,0,0,1,Request_physic)
+  ! !
+  ! !        call Register_Hallo_v(dvfi,llm,
+  ! !     *                      1,0,0,1,Request_physic)
+  ! !
+  ! !        call Register_Hallo_u(dtetafi,llm,
+  ! !     *                      1,0,0,1,Request_physic)
+  ! !
+  ! !        call Register_Hallo_u(dpfi,1,
+  ! !     *                      1,0,0,1,Request_physic)
+  ! !
+  ! !        do j=1,nqtot
+  ! !          call Register_Hallo_u(dqfi(ijb_u,1,j),llm,
+  ! !     *                        1,0,0,1,Request_physic)
+  ! !        enddo
+  ! !
+  ! !        call SendRequest(Request_Physic)
+  ! !c$OMP BARRIER
+  ! !        call WaitRequest(Request_Physic)
+  ! !
+  ! !c$OMP BARRIER
+  ! !c$OMP MASTER
+  ! !        call VTe(VThallo)
+  ! !
+  ! !        call set_Distrib(distrib_Physic)
+  ! !c$OMP END MASTER
+  ! !c$OMP BARRIER
+  ! !                ijb=ij_begin
+  ! !        if (.not. pole_nord) then
+  ! !
+  ! !c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  ! !          DO l=1,llm
+  ! !            dufi(ijb:ijb+iim,l) = dufi(ijb:ijb+iim,l)+dufi_tmp(1:iip1,l)
+  ! !            dvfi(ijb:ijb+iim,l) = dvfi(ijb:ijb+iim,l)+dvfi_tmp(1:iip1,l)
+  ! !            dtetafi(ijb:ijb+iim,l) = dtetafi(ijb:ijb+iim,l)
+  ! !     &                              +dtetafi_tmp(1:iip1,l)
+  ! !            dqfi(ijb:ijb+iim,l,:) = dqfi(ijb:ijb+iim,l,:)
+  ! !     &                              + dqfi_tmp(1:iip1,l,:)
+  ! !          ENDDO
+  ! !c$OMP END DO NOWAIT
+  ! !
+  ! !c$OMP MASTER
+  ! !          dpfi(ijb:ijb+iim)   = dpfi(ijb:ijb+iim)+ dpfi_tmp(1:iip1)
+  ! !c$OMP END MASTER
+  ! !
+  ! !        endif ! of if (.not. pole_nord)
+
+  ! #ifdef DEBUG_IO
+  !     call WriteField_u('dufi',dufi)
+  !     call WriteField_v('dvfi',dvfi)
+  !     call WriteField_u('dtetafi',dtetafi)
+  !     call WriteField_u('dpfi',dpfi)
+  !     do j=1,nqtot
+  !       call WriteField_u('dqfi'//trim(int2str(j)),dqfi(:,:,j))
+  !    enddo
+  ! #endif
+
+  ! c$OMP BARRIER
+
+  ! c      ajout des tendances physiques:
+  ! c      ------------------------------
+  ! #ifdef DEBUG_IO
+  !     call WriteField_u('ucovfi',ucov)
+  !     call WriteField_v('vcovfi',vcov)
+  !     call WriteField_u('tetafi',teta)
+  !         call WriteField_u('psfi',ps)
+  !     do j=1,nqtot
+  !       call WriteField_u('qfi'//trim(int2str(j)),q(:,:,j))
+  !    enddo
+  ! #endif
+
+  !      IF (ok_strato) THEN
+  !        CALL top_bound_loc( vcov,ucov,teta,masse,dufi,dvfi,dtetafi)
+  !      ENDIF
+
+  ! #ifdef DEBUG_IO
+  !     call WriteField_u('ucovfi',ucov)
+  !     call WriteField_v('vcovfi',vcov)
+  !     call WriteField_u('tetafi',teta)
+  !         call WriteField_u('psfi',ps)
+  !     do j=1,nqtot
+  !       call WriteField_u('qfi'//trim(int2str(j)),q(:,:,j))
+  !    enddo
+  ! #endif
+
+  !       CALL addfi_loc( dtphys, leapf, forward   ,
+  !  $                  ucov, vcov, teta , q   ,ps ,
+  !  $                 dufi, dvfi, dtetafi , dqfi ,dpfi  )
+
+  ! #ifdef DEBUG_IO
+  !     call WriteField_u('ucovfi',ucov)
+  !     call WriteField_v('vcovfi',vcov)
+  !     call WriteField_u('tetafi',teta)
+  !         call WriteField_u('psfi',ps)
+  !     do j=1,nqtot
+  !       call WriteField_u('qfi'//trim(int2str(j)),q(:,:,j))
+  !    enddo
+  ! #endif
+
+  ! c$OMP BARRIER
+  ! c$OMP MASTER
+  !     call VTe(VTphysiq)
+
+  !     call VTb(VThallo)
+  ! c$OMP END MASTER
+
+  !     call SetTag(Request_physic,800)
+  !     call Register_SwapField_u(ucov,ucov,
+  !  *                               distrib_caldyn,Request_physic)
+  !
+  !     call Register_SwapField_v(vcov,vcov,
+  !  *                               distrib_caldyn,Request_physic)
+  !
+  !     call Register_SwapField_u(teta,teta,
+  !  *                               distrib_caldyn,Request_physic)
+  !
+  !     call Register_SwapField_u(masse,masse,
+  !  *                               distrib_caldyn,Request_physic)
+
+  !     call Register_SwapField_u(p,p,
+  !  *                               distrib_caldyn,Request_physic)
+  !
+  !     call Register_SwapField_u(pk,pk,
+  !  *                               distrib_caldyn,Request_physic)
+  !
+  !     call Register_SwapField_u(phis,phis,
+  !  *                               distrib_caldyn,Request_physic)
+  !
+  !     call Register_SwapField_u(phi,phi,
+  !  *                               distrib_caldyn,Request_physic)
+  !
+  !     call Register_SwapField_u(w,w,
+  !  *                               distrib_caldyn,Request_physic)
+
+  !     call Register_SwapField_u(q,q,
+  !  *                               distrib_caldyn,Request_physic)
+  !
+  !     call SendRequest(Request_Physic)
+  ! c$OMP BARRIER
+  !     call WaitRequest(Request_Physic)
+
+  ! c$OMP BARRIER
+  ! c$OMP MASTER
+  !    call VTe(VThallo)
+  !    call set_distrib(distrib_caldyn)
+  ! c$OMP END MASTER
+  ! c$OMP BARRIER
+  ! c
+  ! c  Diagnostique de conservation de l'energie : difference
+  !   IF (ip_ebil_dyn.ge.1 ) THEN
+  !       ztit='bil phys'
+  !       CALL diagedyn(ztit,2,1,1,dtphys
+  !  e  , ucov    , vcov , ps, p ,pk , teta , q(:,:,1), q(:,:,2))
+  !   ENDIF
+
+  ! #ifdef DEBUG_IO
+  !     call WriteField_u('ucovfi',ucov)
+  !     call WriteField_v('vcovfi',vcov)
+  !     call WriteField_u('tetafi',teta)
+  !         call WriteField_u('psfi',ps)
+  !     do j=1,nqtot
+  !       call WriteField_u('qfi'//trim(int2str(j)),q(:,:,j))
+  !    enddo
+  ! #endif
+
+
+  ! c-jld
+!$OMP MASTER
+     if (FirstPhysic) then
+       ok_start_timer=.TRUE.
+       FirstPhysic=.false.
+     endif
+!$OMP END MASTER
+   ENDIF ! of IF( apphys )
+
+   call check_isotopes(q,ijb_u,ije_u,'leapfrog 1132')
+    ! !write(*,*) 'leapfrog 1134: iflag_phys=',iflag_phys
+
+  IF(iflag_phys.EQ.2) THEN ! "Newtonian" case
+!$OMP MASTER
+     if (FirstPhysic) then
+       ok_start_timer=.TRUE.
+       FirstPhysic=.false.
+     endif
+!$OMP END MASTER
+
+
+  !   Calcul academique de la physique = Rappel Newtonien + fritcion
+  !   --------------------------------------------------------------
+  !ym       teta(:,:)=teta(:,:)
+  !ym     s  -iphysiq*dtvr*(teta(:,:)-tetarappel(:,:))/taurappel
+   ijb=ij_begin
+   ije=ij_end
+  !LF       teta(ijb:ije,:)=teta(ijb:ije,:)
+  !LF     s  -iphysiq*dtvr*(teta(ijb:ije,:)-tetarappel(ijb:ije,:))/taurappel
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+   do l=1,llm
+   teta(ijb:ije,l)=teta(ijb:ije,l) -dtvr* &
+         (teta(ijb:ije,l)-tetarappel(ijb:ije,l))* &
+         (knewt_g+knewt_t(l)*clat4(ijb:ije))
+   enddo
+!$OMP END DO
+
+!$OMP MASTER
+   if (planet_type.eq."giant") then
+     ! ! add an intrinsic heat flux at the base of the atmosphere
+     teta(ijb:ije,1) = teta(ijb:ije,1) &
+           + dtvr * aire(ijb:ije) * ihf / cpp / masse(ijb:ije,1)
+   endif
+!$OMP END MASTER
+!$OMP BARRIER
+
+
+   call Register_Hallo_u(ucov,llm,0,1,1,0,Request_Physic)
+   call Register_Hallo_v(vcov,llm,1,1,1,1,Request_Physic)
+   call SendRequest(Request_Physic)
+!$OMP BARRIER
+   call WaitRequest(Request_Physic)
+!$OMP BARRIER
+   call friction_loc(ucov,vcov,dtvr)
+!$OMP BARRIER
+
+    ! ! Sponge layer (if any)
+    IF (ok_strato) THEN
+      CALL top_bound_loc(vcov,ucov,teta,masse,dtvr)
+!$OMP BARRIER
+    ENDIF ! of IF (ok_strato)
+  ENDIF ! of IF(iflag_phys.EQ.2)
+
+
+    CALL pression_loc ( ip1jmp1, ap, bp, ps, p                  )
+!$OMP BARRIER
+    if (pressure_exner) then
+    CALL exner_hyb_loc( ijnb_u, ps, p, pks, pk, pkf )
+    else
+      CALL exner_milieu_loc( ijnb_u, ps, p, pks, pk, pkf )
+    endif
+!$OMP BARRIER
+    CALL massdair_loc(p,masse)
+!$OMP BARRIER
+
+  !c$OMP END PARALLEL
+    call check_isotopes(q,ijb_u,ije_u,'leapfrog 1196')
+
+  !-----------------------------------------------------------------------
+  !   dissipation horizontale et verticale  des petites echelles:
+  !   ----------------------------------------------------------
+  ! !write(*,*) 'leapfrog 1163: apdiss=',apdiss
+  IF(apdiss) THEN
+
+    CALL call_dissip(ucov,vcov,teta,p,pk,ps)
+  !cc$OMP  PARALLEL DEFAULT(SHARED)
+  !cc$OMP+          PRIVATE(ijb,ije,tppn,tpn,tpps,tps)
+  !c$OMP MASTER
+     ! call suspend_timer(timer_caldyn)
+  !
+  !c       print*,'Entree dans la dissipation : Iteration No ',true_itau
+  !c   calcul de l'energie cinetique avant dissipation
+  !c       print *,'Passage dans la dissipation'
+
+  !    call VTb(VThallo)
+  !c$OMP END MASTER
+
+  !c$OMP BARRIER
+
+  !    call Register_SwapField_u(ucov,ucov,distrib_dissip,
+  ! *                            Request_dissip,up=1,down=1)
+
+  !    call Register_SwapField_v(vcov,vcov,distrib_dissip,
+  ! *                            Request_dissip,up=1,down=1)
+
+  !    call Register_SwapField_u(teta,teta,distrib_dissip,
+  ! *                            Request_dissip)
+
+  !    call Register_SwapField_u(p,p,distrib_dissip,
+  ! *                            Request_dissip)
+
+  !    call Register_SwapField_u(pk,pk,distrib_dissip,
+  ! *                            Request_dissip)
+
+  !    call SendRequest(Request_dissip)
+  !c$OMP BARRIER
+  !    call WaitRequest(Request_dissip)
+
+  !c$OMP BARRIER
+  !c$OMP MASTER
+  !    call set_distrib(distrib_dissip)
+  !    call VTe(VThallo)
+  !    call VTb(VTdissipation)
+  !    call start_timer(timer_dissip)
+  !c$OMP END MASTER
+  !c$OMP BARRIER
+
+  !    call covcont_loc(llm,ucov,vcov,ucont,vcont)
+  !    call enercin_loc(vcov,ucov,vcont,ucont,ecin0)
+
+  !c   dissipation
+
+  !!        CALL FTRACE_REGION_BEGIN("dissip")
+  !    CALL dissip_loc(vcov,ucov,teta,p,dvdis,dudis,dtetadis)
+
+  !#ifdef DEBUG_IO
+  !    call WriteField_u('dudis',dudis)
+  !    call WriteField_v('dvdis',dvdis)
+  !    call WriteField_u('dtetadis',dtetadis)
+  !#endif
+  !
+  !!      CALL FTRACE_REGION_END("dissip")
+  !
+  !    ijb=ij_begin
+  !    ije=ij_end
+  !c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  !    DO l=1,llm
+  !      ucov(ijb:ije,l)=ucov(ijb:ije,l)+dudis(ijb:ije,l)
+  !    ENDDO
+  !c$OMP END DO NOWAIT
+  !    if (pole_sud) ije=ije-iip1
+  !c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  !    DO l=1,llm
+  !      vcov(ijb:ije,l)=vcov(ijb:ije,l)+dvdis(ijb:ije,l)
+  !    ENDDO
+  !c$OMP END DO NOWAIT
+
+  !c       teta=teta+dtetadis
+
+
+  !c------------------------------------------------------------------------
+  !    if (dissip_conservative) then
+  !C       On rajoute la tendance due a la transform. Ec -> E therm. cree
+  !C       lors de la dissipation
+  !c$OMP BARRIER
+  !c$OMP MASTER
+  !        call suspend_timer(timer_dissip)
+  !        call VTb(VThallo)
+  !c$OMP END MASTER
+  !        call Register_Hallo_u(ucov,llm,1,1,1,1,Request_Dissip)
+  !        call Register_Hallo_v(vcov,llm,1,1,1,1,Request_Dissip)
+  !        call SendRequest(Request_Dissip)
+  !c$OMP BARRIER
+  !        call WaitRequest(Request_Dissip)
+  !c$OMP MASTER
+  !        call VTe(VThallo)
+  !        call resume_timer(timer_dissip)
+  !c$OMP END MASTER
+  !c$OMP BARRIER
+  !        call covcont_loc(llm,ucov,vcov,ucont,vcont)
+  !        call enercin_loc(vcov,ucov,vcont,ucont,ecin)
+  !
+  !        ijb=ij_begin
+  !        ije=ij_end
+  !c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  !        do l=1,llm
+  !          do ij=ijb,ije
+  !            dtetaecdt(ij,l)= (ecin0(ij,l)-ecin(ij,l))/ pk(ij,l)
+  !            dtetadis(ij,l)=dtetadis(ij,l)+dtetaecdt(ij,l)
+  !          enddo
+  !        enddo
+  !c$OMP END DO NOWAIT
+  !   endif
+
+  !   ijb=ij_begin
+  !   ije=ij_end
+  !c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  !     do l=1,llm
+  !       do ij=ijb,ije
+  !          teta(ij,l)=teta(ij,l)+dtetadis(ij,l)
+  !       enddo
+  !     enddo
+  !c$OMP END DO NOWAIT
+  !c------------------------------------------------------------------------
+
+
+  !c    .......        P. Le Van (  ajout  le 17/04/96  )   ...........
+  !c   ...      Calcul de la valeur moyenne, unique de h aux poles  .....
+  !c
+
+  !    ijb=ij_begin
+  !    ije=ij_end
+  !
+  !    if (pole_nord) then
+  !c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  !      DO l  =  1, llm
+  !        DO ij =  1,iim
+  !         tppn(ij)  = aire(  ij    ) * teta(  ij    ,l)
+  !        ENDDO
+  !         tpn  = SSUM(iim,tppn,1)/apoln
+
+  !        DO ij = 1, iip1
+  !         teta(  ij    ,l) = tpn
+  !        ENDDO
+  !      ENDDO
+  !c$OMP END DO NOWAIT
+
+  !c$OMP MASTER
+  !      DO ij =  1,iim
+  !        tppn(ij)  = aire(  ij    ) * ps (  ij    )
+  !      ENDDO
+  !        tpn  = SSUM(iim,tppn,1)/apoln
+  !
+  !      DO ij = 1, iip1
+  !        ps(  ij    ) = tpn
+  !      ENDDO
+  !c$OMP END MASTER
+  !    endif
+  !
+  !    if (pole_sud) then
+  !c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  !      DO l  =  1, llm
+  !        DO ij =  1,iim
+  !         tpps(ij)  = aire(ij+ip1jm) * teta(ij+ip1jm,l)
+  !        ENDDO
+  !         tps  = SSUM(iim,tpps,1)/apols
+
+  !        DO ij = 1, iip1
+  !         teta(ij+ip1jm,l) = tps
+  !        ENDDO
+  !      ENDDO
+  !c$OMP END DO NOWAIT
+
+  !c$OMP MASTER
+  !      DO ij =  1,iim
+  !        tpps(ij)  = aire(ij+ip1jm) * ps (ij+ip1jm)
+  !      ENDDO
+  !        tps  = SSUM(iim,tpps,1)/apols
+  !
+  !      DO ij = 1, iip1
+  !        ps(ij+ip1jm) = tps
+  !      ENDDO
+  !c$OMP END MASTER
+  !    endif
+
+
+  !c$OMP BARRIER
+  !c$OMP MASTER
+  !    call VTe(VTdissipation)
+
+  !    call stop_timer(timer_dissip)
+  !
+  !    call VTb(VThallo)
+  !c$OMP END MASTER
+  !    call Register_SwapField_u(ucov,ucov,distrib_caldyn,
+  ! *                            Request_dissip)
+
+  !    call Register_SwapField_v(vcov,vcov,distrib_caldyn,
+  ! *                            Request_dissip)
+
+  !    call Register_SwapField_u(teta,teta,distrib_caldyn,
+  ! *                            Request_dissip)
+
+  !    call Register_SwapField_u(p,p,distrib_caldyn,
+  ! *                            Request_dissip)
+
+  !    call Register_SwapField_u(pk,pk,distrib_caldyn,
+  ! *                            Request_dissip)
+
+  !    call SendRequest(Request_dissip)
+  !c$OMP BARRIER
+  !    call WaitRequest(Request_dissip)
+
+  !c$OMP BARRIER
+  !c$OMP MASTER
+  !    call set_distrib(distrib_caldyn)
+  !    call VTe(VThallo)
+  !    call resume_timer(timer_caldyn)
+  !c        print *,'fin dissipation'
+  !c$OMP END MASTER
+  !c$OMP BARRIER
+   END IF ! of IF(apdiss)
+
+  !c$OMP END PARALLEL
+
+  ! ajout debug
+           ! IF( lafin ) then
+           !   abort_message = 'Simulation finished'
+           !   call abort_gcm(modname,abort_message,0)
+           ! ENDIF
+
+   call check_isotopes(q,ijb_u,ije_u,'leapfrog 1430')
+
+  !   ********************************************************************
+  !   ********************************************************************
+  !   .... fin de l'integration dynamique  et physique pour le pas itau ..
+  !   ********************************************************************
+  !   ********************************************************************
+
+  !   preparation du pas d'integration suivant  ......
+  !ym      call WriteField('ucov',reshape(ucov,(/iip1,jmp1,llm/)))
+  !ym      call WriteField('vcov',reshape(vcov,(/iip1,jjm,llm/)))
+!$OMP MASTER
+  call stop_timer(timer_caldyn)
+!$OMP END MASTER
+  IF (itau==itaumax) then
+!$OMP MASTER
+     call allgather_timer_average
+     call barrier
+     if (mpi_rank==0) then
+
+        print *,'*********************************'
+        print *,'******    TIMER CALDYN     ******'
+        do i=0,mpi_size-1
+           print *,'proc',i,' :   Nb Bandes  :',jj_nb_caldyn(i), &
+                 '  : temps moyen :', &
+                 timer_average(jj_nb_caldyn(i),timer_caldyn,i)
+        enddo
+
+        print *,'*********************************'
+        print *,'******    TIMER VANLEER    ******'
+        do i=0,mpi_size-1
+           print *,'proc',i,' :   Nb Bandes  :',jj_nb_vanleer(i), &
+                 '  : temps moyen :', &
+                 timer_average(jj_nb_vanleer(i),timer_vanleer,i)
+        enddo
+
+        print *,'*********************************'
+        print *,'******    TIMER DISSIP    ******'
+        do i=0,mpi_size-1
+           print *,'proc',i,' :   Nb Bandes  :',jj_nb_dissip(i), &
+                 '  : temps moyen :', &
+                 timer_average(jj_nb_dissip(i),timer_dissip,i)
+        enddo
+
+        print *,'*********************************'
+        print *,'******    TIMER PHYSIC    ******'
+        do i=0,mpi_size-1
+           print *,'proc',i,' :   Nb Bandes  :',jj_nb_physic(i), &
+                 '  : temps moyen :', &
+                 timer_average(jj_nb_physic(i),timer_physic,i)
+        enddo
+
+     endif
+     CALL barrier
+     print *,'Taille du Buffer MPI (REAL*8)',MaxBufferSize
+  print *,'Taille du Buffer MPI utilise (REAL*8)',MaxBufferSize_Used
+   print *, 'Temps total ecoule sur la parallelisation :',DiffTime()
+  print *, 'Temps CPU ecoule sur la parallelisation :',DiffCpuTime()
+     CALL print_filtre_timer
+!$OMP END MASTER
+     CALL dynredem1_loc("restart.nc",0.0, &
+           vcov,ucov,teta,q,masse,ps)
+!$OMP MASTER
+     call fin_getparam
+!$OMP END MASTER
+
+     if (ok_guide) then
+       ! ! set ok_guide to false to avoid extra output
+       ! ! in following forward step
+       ok_guide=.false.
+     endif
+
+IF (CPPKEY_INCA) THEN
+     IF (ANY(type_trac == ['inca','inco'])) THEN
+        CALL finalize_inca
+  ! switching back to LMDZDYN context
+!$OMP MASTER
+        IF (ok_dyn_xios) THEN
+           CALL xios_set_current_context(dyn3d_ctx_handle)
+        ENDIF
+!$OMP END MASTER
+     ENDIF
+END IF
+IF (CPPKEY_REPROBUS) THEN
+     if (type_trac == 'repr') CALL finalize_reprobus
+END IF
+
+!$OMP MASTER
+     call finalize_parallel
+!$OMP END MASTER
+!$OMP BARRIER
+     RETURN
+  ENDIF
+
+  call check_isotopes(q,ijb_u,ije_u,'leapfrog 1509')
+
+  IF ( .NOT.purmats ) THEN
+    ! ........................................................
+    ! ..............  schema matsuno + leapfrog  ..............
+    ! ........................................................
+
+        IF(forward.OR. leapf) THEN
+          itau= itau + 1
+           ! iday= day_ini+itau/day_step
+           ! time= REAL(itau-(iday-day_ini)*day_step)/day_step+time_0
+           !   IF(time.GT.1.) THEN
+           !     time = time-1.
+           !     iday = iday+1
+           !   ENDIF
+        ENDIF
+
+
+        IF( itau.EQ. itaufinp1 ) then
+
+          if (flag_verif) then
+            write(79,*) 'ucov',ucov
+            write(80,*) 'vcov',vcov
+            write(81,*) 'teta',teta
+            write(82,*) 'ps',ps
+            write(83,*) 'q',q
+            WRITE(85,*) 'q1 = ',q(:,:,1)
+            WRITE(86,*) 'q3 = ',q(:,:,3)
+          endif
+
+
+!$OMP MASTER
+          call fin_getparam
+!$OMP END MASTER
+
+IF (CPPKEY_INCA) THEN
+          IF (ANY(type_trac == ['inca','inco'])) THEN
+             CALL finalize_inca
+  ! switching back to LMDZDYN context
+!$OMP MASTER
+             IF (ok_dyn_xios) THEN
+                CALL xios_set_current_context(dyn3d_ctx_handle)
+             ENDIF
+!$OMP END MASTER
+          ENDIF
+END IF
+IF (CPPKEY_REPROBUS) THEN
+          if (type_trac == 'repr') CALL finalize_reprobus
+END IF
+
+!$OMP MASTER
+          call finalize_parallel
+!$OMP END MASTER
+          abort_message = 'Simulation finished'
+          call abort_gcm(modname,abort_message,0)
+          RETURN
+        ENDIF
+  !-----------------------------------------------------------------------
+  !   ecriture du fichier histoire moyenne:
+  !   -------------------------------------
+
+        IF(MOD(itau,iperiod).EQ.0 .OR. itau.EQ.itaufin) THEN
+!$OMP BARRIER
+           IF(itau.EQ.itaufin) THEN
+              iav=1
+           ELSE
+              iav=0
+           ENDIF
+
+          ! ! Ehouarn: re-compute geopotential for outputs
+!$OMP BARRIER
+!$OMP MASTER
+          CALL geopot_loc(ip1jmp1,teta,pk,pks,phis,phi)
+!$OMP END MASTER
+!$OMP BARRIER
+
+         IF (ok_dynzon) THEN
+
+          CALL bilan_dyn_loc(2,dtvr*iperiod,dtvr*day_step*periodav, &
+                ps,masse,pk,pbaru,pbarv,teta,phi,ucov,vcov,q)
+
+          ENDIF !ok_dynzon
+
+          IF (ok_dyn_ave) THEN
+             CALL writedynav_loc(itau,vcov, &
+                   ucov,teta,pk,phi,q,masse,ps,phis)
+          ENDIF
+
+
+
+        ENDIF
+
+        call check_isotopes(q,ijb_u,ije_u,'leapfrog 1584')
+
+  !-----------------------------------------------------------------------
+  !   ecriture de la bande histoire:
+  !   ------------------------------
+
+        IF( MOD(itau,iecri).EQ.0) THEN
+         ! ! Ehouarn: output only during LF or Backward Matsuno
+         if (leapf.or.(.not.leapf.and.(.not.forward))) then
+
+!$OMP BARRIER
+!$OMP MASTER
+          CALL geopot_loc(ip1jmp1,teta,pk,pks,phis,phi)
+!$OMP END MASTER
+!$OMP BARRIER
+
+         if (ok_dyn_ins) then
+             CALL writehist_loc(itau,vcov,ucov,teta,pk,phi,q, &
+                   masse,ps,phis)
+         endif
+
+
+          IF (ok_dyn_xios) THEN
+!$OMP MASTER
+             CALL xios_update_calendar(itau)
+!$OMP END MASTER
+!$OMP BARRIER
+             CALL writedyn_xios(vcov, &
+                   ucov,teta,pk,phi,q,masse,ps,phis)
+          ENDIF
+
+      endif                 ! of if (leapf.or.(.not.leapf.and.(.not.forward)))
+
+
+       ENDIF ! of IF(MOD(itau,iecri).EQ.0)
+
+        IF(itau.EQ.itaufin) THEN
+
+!$OMP BARRIER
+
+           ! if (planet_type.eq."earth") then
+  ! Write an Earth-format restart file
+            CALL dynredem1_loc("restart.nc",0.0, &
+                  vcov,ucov,teta,q,masse,ps)
+           ! endif ! of if (planet_type.eq."earth")
+            if (ok_guide) then
+              ! ! set ok_guide to false to avoid extra output
+              ! ! in following forward step
+              ok_guide=.false.
+            endif
+
+           ! CLOSE(99)
+        ENDIF ! of IF (itau.EQ.itaufin)
+
+        call check_isotopes(q,ijb_u,ije_u,'leapfrog 1624')
+
+  !-----------------------------------------------------------------------
+  !   gestion de l'integration temporelle:
+  !   ------------------------------------
+
+        IF( MOD(itau,iperiod).EQ.0 )    THEN
+                GO TO 1
+        ELSE IF ( MOD(itau-1,iperiod).EQ. 0 ) THEN
+
+               IF( forward )  THEN
+   ! fin du pas forward et debut du pas backward
+
+                  forward = .FALSE.
+                    leapf = .FALSE.
+                       GO TO 2
+
+               ELSE
+   ! fin du pas backward et debut du premier pas leapfrog
+
+                    leapf =  .TRUE.
+                    dt  =  2.*dtvr
+                    GO TO 2
+               END IF
+        ELSE
+
+   ! ......   pas leapfrog  .....
+
+             leapf = .TRUE.
+             dt  = 2.*dtvr
+             GO TO 2
+        END IF ! of IF (MOD(itau,iperiod).EQ.0)
+               ! !    ELSEIF (MOD(itau-1,iperiod).EQ.0)
+
+
+  ELSE ! of IF (.not.purmats)
+
+
+    call check_isotopes(q,ijb_u,ije_u,'leapfrog 1664')
+
+    ! ........................................................
+    ! ..............       schema  matsuno        ...............
+    ! ........................................................
+        IF( forward )  THEN
+
+         itau =  itau + 1
+          ! iday = day_ini+itau/day_step
+          ! time = REAL(itau-(iday-day_ini)*day_step)/day_step+time_0
+  !
+  !              IF(time.GT.1.) THEN
+  !               time = time-1.
+  !               iday = iday+1
+  !              ENDIF
+
+           forward =  .FALSE.
+           IF( itau.EQ. itaufinp1 ) then
+!$OMP MASTER
+             call fin_getparam
+!$OMP END MASTER
+
+IF (CPPKEY_INCA) THEN
+             IF (ANY(type_trac == ['inca','inco'])) THEN
+                CALL finalize_inca
+  ! switching back to LMDZDYN context
+!$OMP MASTER
+                IF (ok_dyn_xios) THEN
+                   CALL xios_set_current_context(dyn3d_ctx_handle)
+                ENDIF
+!$OMP END MASTER
+             ENDIF
+
+END IF
+IF (CPPKEY_REPROBUS) THEN
+             if (type_trac == 'repr') CALL finalize_reprobus
+END IF
+
+!$OMP MASTER
+             call finalize_parallel
+!$OMP END MASTER
+             abort_message = 'Simulation finished'
+             call abort_gcm(modname,abort_message,0)
+             RETURN
+           ENDIF
+           GO TO 2
+
+        ELSE ! of IF(forward) i.e. backward step
+
+
+          call check_isotopes(q,ijb_u,ije_u,'leapfrog 1698')
+
+          IF(MOD(itau,iperiod).EQ.0 .OR. itau.EQ.itaufin) THEN
+           IF(itau.EQ.itaufin) THEN
+              iav=1
+           ELSE
+              iav=0
+           ENDIF
+
+          ! ! Ehouarn: re-compute geopotential for outputs
+!$OMP BARRIER
+!$OMP MASTER
+          CALL geopot_loc(ip1jmp1,teta,pk,pks,phis,phi)
+!$OMP END MASTER
+!$OMP BARRIER
+
+           IF (ok_dynzon) THEN
+           CALL bilan_dyn_loc(2,dtvr*iperiod,dtvr*day_step*periodav, &
+                 ps,masse,pk,pbaru,pbarv,teta,phi,ucov,vcov,q)
+           ENDIF
+
+           IF (ok_dyn_ave) THEN
+             CALL writedynav_loc(itau,vcov, &
+                   ucov,teta,pk,phi,q,masse,ps,phis)
+           ENDIF
+
+
+
+          ENDIF ! of IF(MOD(itau,iperiod).EQ.0 .OR. itau.EQ.itaufin)
+
+
+           IF(MOD(itau,iecri         ).EQ.0) THEN
+
+!$OMP BARRIER
+!$OMP MASTER
+          CALL geopot_loc(ip1jmp1,teta,pk,pks,phis,phi)
+!$OMP END MASTER
+!$OMP BARRIER
+
+
+          if (ok_dyn_ins) then
+             CALL writehist_loc(itau,vcov,ucov,teta,pk,phi,q, &
+                   masse,ps,phis)
+          endif ! of if (ok_dyn_ins)
+
+
+          IF (ok_dyn_xios) THEN
+!$OMP MASTER
+             CALL xios_update_calendar(itau)
+!$OMP END MASTER
+!$OMP BARRIER
+             CALL writedyn_xios(vcov, &
+                   ucov,teta,pk,phi,q,masse,ps,phis)
+          ENDIF
+
+       ENDIF                ! of IF(MOD(itau,iecri).EQ.0)
+
+
+          IF(itau.EQ.itaufin) THEN
+             ! if (planet_type.eq."earth") then
+               CALL dynredem1_loc("restart.nc",0.0, &
+                     vcov,ucov,teta,q,masse,ps)
+            ! endif ! of if (planet_type.eq."earth")
+            if (ok_guide) then
+              ! ! set ok_guide to false to avoid extra output
+              ! ! in following forward step
+              ok_guide=.false.
+            endif
+
+          ENDIF ! of IF(itau.EQ.itaufin)
+
+          forward = .TRUE.
+          GO TO  1
+
+        ENDIF ! of IF (forward)
+
+
+        call check_isotopes(q,ijb_u,ije_u,'leapfrog 1750')
+
+  END IF ! of IF(.not.purmats)
+!$OMP MASTER
+  call fin_getparam
+!$OMP END MASTER
+
+IF (CPPKEY_INCA) THEN
+  IF (ANY(type_trac == ['inca','inco'])) THEN
+     CALL finalize_inca
+  ! switching back to LMDZDYN context
+!$OMP MASTER
+     IF (ok_dyn_xios) THEN
+        CALL xios_set_current_context(dyn3d_ctx_handle)
+     ENDIF
+!$OMP END MASTER
+  ENDIF
+
+END IF
+IF (CPPKEY_REPROBUS) THEN
+  if (type_trac == 'repr') CALL finalize_reprobus
+END IF
+
+!$OMP MASTER
+  call finalize_parallel
+!$OMP END MASTER
+  abort_message = 'Simulation finished'
+  call abort_gcm(modname,abort_message,0)
+  RETURN
+END SUBROUTINE leapfrog_loc
Index: DZ6/trunk/libf/dyn3dmem/leapfrog_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/leapfrog_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,157 +1,0 @@
-MODULE leapfrog_mod
-
-  REAL,POINTER,SAVE :: ucov(:,:) ! zonal covariant wind
-  REAL,POINTER,SAVE :: vcov(:,:) ! meridional covariant wind
-  REAL,POINTER,SAVE :: teta(:,:) ! potential temperature
-  REAL,POINTER,SAVE :: ps(:) ! surface pressure
-  REAL,POINTER,SAVE :: masse(:,:) ! air mass
-  REAL,POINTER,SAVE :: phis(:) ! geopotential at the surface
-  REAL,POINTER,SAVE :: q(:,:,:) ! advected tracers
-  REAL,POINTER,SAVE :: p(:,:) ! interlayer pressure
-  REAL,POINTER,SAVE :: pks(:) ! Exner at the surface
-  REAL,POINTER,SAVE :: pk(:,:) ! Exner at mid-layer
-  REAL,POINTER,SAVE :: pkf(:,:) ! filtered Exner
-  REAL,POINTER,SAVE :: phi(:,:) ! geopotential
-  REAL,POINTER,SAVE :: w(:,:) ! vertical velocity
-  REAL,POINTER,SAVE :: pbaru(:,:)
-  REAL,POINTER,SAVE :: pbarv(:,:)
-  REAL,POINTER,SAVE :: vcovm1(:,:)
-  REAL,POINTER,SAVE :: ucovm1(:,:)
-  REAL,POINTER,SAVE :: tetam1(:,:)
-  REAL,POINTER,SAVE :: psm1(:)
-  REAL,POINTER,SAVE :: massem1(:,:)
-  REAL,POINTER,SAVE :: dv(:,:)
-  REAL,POINTER,SAVE :: du(:,:)
-  REAL,POINTER,SAVE :: dteta(:,:)
-  REAL,POINTER,SAVE :: dp(:)
-  REAL,POINTER,SAVE :: dq(:,:,:)
-  REAL,POINTER,SAVE :: finvmaold(:,:)
-  REAL,POINTER,SAVE :: flxw(:,:)
-  REAL,POINTER,SAVE :: unat(:,:)
-  REAL,POINTER,SAVE :: vnat(:,:)
- 
-
-  
-CONTAINS
-
-  SUBROUTINE leapfrog_allocate
-  USE bands
-  USE allocate_field_mod
-  USE parallel_lmdz
-  USE dimensions_mod
-  USE infotrac
-  USE caldyn_mod,ONLY : caldyn_allocate
-  USE integrd_mod,ONLY : integrd_allocate
-  USE caladvtrac_mod,ONLY : caladvtrac_allocate
-  USE call_calfis_mod,ONLY : call_calfis_allocate
-  USE call_dissip_mod, ONLY : call_dissip_allocate
-  IMPLICIT NONE
-  TYPE(distrib),POINTER :: d
-
-
-    d=>distrib_caldyn
-    CALL allocate_u(ucov,llm,d)
-    CALL allocate_v(vcov,llm,d)
-    CALL allocate_u(teta,llm,d)
-    CALL allocate_u(ps,d)
-    CALL allocate_u(masse,llm,d)
-    CALL allocate_u(phis,d)
-    CALL allocate_u(q,llm,nqtot,d)
-    CALL allocate_u(p,llmp1,d)
-    CALL allocate_u(pks,d)
-    CALL allocate_u(pk,llm,d)
-    CALL allocate_u(pkf,llm,d)
-    CALL allocate_u(phi,llm,d)
-    CALL allocate_u(w,llm,d)
-    CALL allocate_u(pbaru,llm,d)
-    CALL allocate_v(pbarv,llm,d)
-    CALL allocate_v(vcovm1,llm,d)
-    CALL allocate_u(ucovm1,llm,d)
-    CALL allocate_u(tetam1,llm,d)
-    CALL allocate_u(psm1,d)
-    CALL allocate_u(massem1,llm,d)
-    CALL allocate_v(dv,llm,d)
-    CALL allocate_u(du,llm,d)
-    CALL allocate_u(dteta,llm,d)
-    CALL allocate_u(dp,d)
-    CALL allocate_u(dq,llm,nqtot,d)
-    CALL allocate_u(finvmaold,llm,d)
-    CALL allocate_u(flxw,llm,d)
-    CALL allocate_u(unat,llm,d)
-    CALL allocate_v(vnat,llm,d)
-    
-    CALL caldyn_allocate
-    CALL integrd_allocate
-    CALL caladvtrac_allocate
-    CALL call_calfis_allocate
-    CALL call_dissip_allocate
-        
-  END SUBROUTINE leapfrog_allocate
-  
-  SUBROUTINE leapfrog_switch_caldyn(dist)
-  USE allocate_field_mod
-  USE bands
-  USE parallel_lmdz
-  USE caldyn_mod,ONLY : caldyn_switch_caldyn
-  USE integrd_mod,ONLY : integrd_switch_caldyn
-  USE caladvtrac_mod,ONLY : caladvtrac_switch_caldyn
-  IMPLICIT NONE
-    TYPE(distrib),INTENT(IN) :: dist
-
-    CALL switch_u(ucov,distrib_caldyn,dist)
-    CALL switch_v(vcov,distrib_caldyn,dist)
-    CALL switch_u(teta,distrib_caldyn,dist)
-    CALL switch_u(ps,distrib_caldyn,dist)
-    CALL switch_u(masse,distrib_caldyn,dist)
-    CALL switch_u(phis,distrib_caldyn,dist,up=halo_max,down=halo_max)
-    CALL switch_u(q,distrib_caldyn,dist)
-    CALL switch_u(p,distrib_caldyn,dist)
-    CALL switch_u(pks,distrib_caldyn,dist)
-    CALL switch_u(pk,distrib_caldyn,dist)
-    CALL switch_u(pkf,distrib_caldyn,dist)
-    CALL switch_u(phi,distrib_caldyn,dist)
-    CALL switch_u(w,distrib_caldyn,dist)
-    CALL switch_u(pbaru,distrib_caldyn,dist)
-    CALL switch_v(pbarv,distrib_caldyn,dist)
-    CALL switch_v(vcovm1,distrib_caldyn,dist)
-    CALL switch_u(ucovm1,distrib_caldyn,dist)
-    CALL switch_u(tetam1,distrib_caldyn,dist)
-    CALL switch_u(psm1,distrib_caldyn,dist)
-    CALL switch_u(massem1,distrib_caldyn,dist)
-    CALL switch_v(dv,distrib_caldyn,dist)
-    CALL switch_u(du,distrib_caldyn,dist)
-    CALL switch_u(dteta,distrib_caldyn,dist)
-    CALL switch_u(dp,distrib_caldyn,dist)
-    CALL switch_u(dq,distrib_caldyn,dist)
-    CALL switch_u(finvmaold,distrib_caldyn,dist)
-    CALL switch_u(flxw,distrib_caldyn,dist)
-    CALL switch_u(unat,distrib_caldyn,dist)
-    CALL switch_v(vnat,distrib_caldyn,dist)
-
-    
-    CALL caldyn_switch_caldyn(dist)
-    CALL integrd_switch_caldyn(dist)
-    CALL caladvtrac_switch_caldyn(dist)
-    
-  END SUBROUTINE leapfrog_switch_caldyn
-  
-  SUBROUTINE leapfrog_switch_dissip(dist)
-  USE allocate_field_mod
-  USE bands
-  USE parallel_lmdz
-  USE call_dissip_mod,ONLY : call_dissip_switch_dissip
-  IMPLICIT NONE
-    TYPE(distrib),INTENT(IN) :: dist
-
-    CALL call_dissip_switch_dissip(dist)
-    
-  END SUBROUTINE leapfrog_switch_dissip
-  
-END MODULE leapfrog_mod  
-
-
-
-
-
-
-
Index: /LMDZ6/trunk/libf/dyn3dmem/leapfrog_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/leapfrog_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3dmem/leapfrog_mod.f90	(revision 5268)
@@ -0,0 +1,157 @@
+MODULE leapfrog_mod
+
+  REAL,POINTER,SAVE :: ucov(:,:) ! zonal covariant wind
+  REAL,POINTER,SAVE :: vcov(:,:) ! meridional covariant wind
+  REAL,POINTER,SAVE :: teta(:,:) ! potential temperature
+  REAL,POINTER,SAVE :: ps(:) ! surface pressure
+  REAL,POINTER,SAVE :: masse(:,:) ! air mass
+  REAL,POINTER,SAVE :: phis(:) ! geopotential at the surface
+  REAL,POINTER,SAVE :: q(:,:,:) ! advected tracers
+  REAL,POINTER,SAVE :: p(:,:) ! interlayer pressure
+  REAL,POINTER,SAVE :: pks(:) ! Exner at the surface
+  REAL,POINTER,SAVE :: pk(:,:) ! Exner at mid-layer
+  REAL,POINTER,SAVE :: pkf(:,:) ! filtered Exner
+  REAL,POINTER,SAVE :: phi(:,:) ! geopotential
+  REAL,POINTER,SAVE :: w(:,:) ! vertical velocity
+  REAL,POINTER,SAVE :: pbaru(:,:)
+  REAL,POINTER,SAVE :: pbarv(:,:)
+  REAL,POINTER,SAVE :: vcovm1(:,:)
+  REAL,POINTER,SAVE :: ucovm1(:,:)
+  REAL,POINTER,SAVE :: tetam1(:,:)
+  REAL,POINTER,SAVE :: psm1(:)
+  REAL,POINTER,SAVE :: massem1(:,:)
+  REAL,POINTER,SAVE :: dv(:,:)
+  REAL,POINTER,SAVE :: du(:,:)
+  REAL,POINTER,SAVE :: dteta(:,:)
+  REAL,POINTER,SAVE :: dp(:)
+  REAL,POINTER,SAVE :: dq(:,:,:)
+  REAL,POINTER,SAVE :: finvmaold(:,:)
+  REAL,POINTER,SAVE :: flxw(:,:)
+  REAL,POINTER,SAVE :: unat(:,:)
+  REAL,POINTER,SAVE :: vnat(:,:)
+ 
+
+  
+CONTAINS
+
+  SUBROUTINE leapfrog_allocate
+  USE bands
+  USE allocate_field_mod
+  USE parallel_lmdz
+  USE dimensions_mod
+  USE infotrac
+  USE caldyn_mod,ONLY : caldyn_allocate
+  USE integrd_mod,ONLY : integrd_allocate
+  USE caladvtrac_mod,ONLY : caladvtrac_allocate
+  USE call_calfis_mod,ONLY : call_calfis_allocate
+  USE call_dissip_mod, ONLY : call_dissip_allocate
+  IMPLICIT NONE
+  TYPE(distrib),POINTER :: d
+
+
+    d=>distrib_caldyn
+    CALL allocate_u(ucov,llm,d)
+    CALL allocate_v(vcov,llm,d)
+    CALL allocate_u(teta,llm,d)
+    CALL allocate_u(ps,d)
+    CALL allocate_u(masse,llm,d)
+    CALL allocate_u(phis,d)
+    CALL allocate_u(q,llm,nqtot,d)
+    CALL allocate_u(p,llmp1,d)
+    CALL allocate_u(pks,d)
+    CALL allocate_u(pk,llm,d)
+    CALL allocate_u(pkf,llm,d)
+    CALL allocate_u(phi,llm,d)
+    CALL allocate_u(w,llm,d)
+    CALL allocate_u(pbaru,llm,d)
+    CALL allocate_v(pbarv,llm,d)
+    CALL allocate_v(vcovm1,llm,d)
+    CALL allocate_u(ucovm1,llm,d)
+    CALL allocate_u(tetam1,llm,d)
+    CALL allocate_u(psm1,d)
+    CALL allocate_u(massem1,llm,d)
+    CALL allocate_v(dv,llm,d)
+    CALL allocate_u(du,llm,d)
+    CALL allocate_u(dteta,llm,d)
+    CALL allocate_u(dp,d)
+    CALL allocate_u(dq,llm,nqtot,d)
+    CALL allocate_u(finvmaold,llm,d)
+    CALL allocate_u(flxw,llm,d)
+    CALL allocate_u(unat,llm,d)
+    CALL allocate_v(vnat,llm,d)
+    
+    CALL caldyn_allocate
+    CALL integrd_allocate
+    CALL caladvtrac_allocate
+    CALL call_calfis_allocate
+    CALL call_dissip_allocate
+        
+  END SUBROUTINE leapfrog_allocate
+  
+  SUBROUTINE leapfrog_switch_caldyn(dist)
+  USE allocate_field_mod
+  USE bands
+  USE parallel_lmdz
+  USE caldyn_mod,ONLY : caldyn_switch_caldyn
+  USE integrd_mod,ONLY : integrd_switch_caldyn
+  USE caladvtrac_mod,ONLY : caladvtrac_switch_caldyn
+  IMPLICIT NONE
+    TYPE(distrib),INTENT(IN) :: dist
+
+    CALL switch_u(ucov,distrib_caldyn,dist)
+    CALL switch_v(vcov,distrib_caldyn,dist)
+    CALL switch_u(teta,distrib_caldyn,dist)
+    CALL switch_u(ps,distrib_caldyn,dist)
+    CALL switch_u(masse,distrib_caldyn,dist)
+    CALL switch_u(phis,distrib_caldyn,dist,up=halo_max,down=halo_max)
+    CALL switch_u(q,distrib_caldyn,dist)
+    CALL switch_u(p,distrib_caldyn,dist)
+    CALL switch_u(pks,distrib_caldyn,dist)
+    CALL switch_u(pk,distrib_caldyn,dist)
+    CALL switch_u(pkf,distrib_caldyn,dist)
+    CALL switch_u(phi,distrib_caldyn,dist)
+    CALL switch_u(w,distrib_caldyn,dist)
+    CALL switch_u(pbaru,distrib_caldyn,dist)
+    CALL switch_v(pbarv,distrib_caldyn,dist)
+    CALL switch_v(vcovm1,distrib_caldyn,dist)
+    CALL switch_u(ucovm1,distrib_caldyn,dist)
+    CALL switch_u(tetam1,distrib_caldyn,dist)
+    CALL switch_u(psm1,distrib_caldyn,dist)
+    CALL switch_u(massem1,distrib_caldyn,dist)
+    CALL switch_v(dv,distrib_caldyn,dist)
+    CALL switch_u(du,distrib_caldyn,dist)
+    CALL switch_u(dteta,distrib_caldyn,dist)
+    CALL switch_u(dp,distrib_caldyn,dist)
+    CALL switch_u(dq,distrib_caldyn,dist)
+    CALL switch_u(finvmaold,distrib_caldyn,dist)
+    CALL switch_u(flxw,distrib_caldyn,dist)
+    CALL switch_u(unat,distrib_caldyn,dist)
+    CALL switch_v(vnat,distrib_caldyn,dist)
+
+    
+    CALL caldyn_switch_caldyn(dist)
+    CALL integrd_switch_caldyn(dist)
+    CALL caladvtrac_switch_caldyn(dist)
+    
+  END SUBROUTINE leapfrog_switch_caldyn
+  
+  SUBROUTINE leapfrog_switch_dissip(dist)
+  USE allocate_field_mod
+  USE bands
+  USE parallel_lmdz
+  USE call_dissip_mod,ONLY : call_dissip_switch_dissip
+  IMPLICIT NONE
+    TYPE(distrib),INTENT(IN) :: dist
+
+    CALL call_dissip_switch_dissip(dist)
+    
+  END SUBROUTINE leapfrog_switch_dissip
+  
+END MODULE leapfrog_mod  
+
+
+
+
+
+
+
Index: DZ6/trunk/libf/dyn3dmem/logic_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/logic_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,48 +1,0 @@
-!
-! $Id: $
-!
-MODULE logic_mod
-
-IMPLICIT NONE
-
-  LOGICAL purmats ! true if time stepping is purely Matsuno scheme
-                  ! false implies Matsuno-Leapfrog time stepping scheme
-  LOGICAL forward ! true if during forward phase of Matsuno step
-  LOGICAL leapf ! true if during a leapfrog time stepping step
-  LOGICAL apphys ! true if during a time step when physics will be called
-  LOGICAL statcl
-  LOGICAL conser
-  LOGICAL apdiss ! true if during a time step when dissipation will be called
-  LOGICAL apdelq
-  LOGICAL saison
-  LOGICAL ecripar
-  LOGICAL fxyhypb ! true if using hyperbolic function discretization
-                  ! for latitudinal grid 
-  LOGICAL ysinus ! true if using sine function discretiation
-                 ! for latitudinal grid
-  LOGICAL read_start ! true if reading a start.nc file to initialize fields
-  LOGICAL ok_guide ! true if nudging
-  LOGICAL ok_strato
-  LOGICAL ok_gradsfile
-  LOGICAL ok_limit  ! true for boundary conditions file creation (limit.nc)
-  LOGICAL ok_etat0  ! true for initial states creation (start.nc, startphy.nc)
-  LOGICAL read_orop ! true for sub-cell scales orographic params read in file
-  LOGICAL hybrid ! vertical coordinate is hybrid if true (sigma otherwise)
-                 ! (only used if disvert_type==2)
-  LOGICAL adv_qsat_liq ! true if qsat is calculated alwats wrt liquid for
-                       ! adapted Van Leer advection scheme
-  INTEGER iflag_phys ! type of physics to call: 0 none, 1: phy*** package,
-                     ! 2: Held & Suarez, 101-200: aquaplanets & terraplanets
-  INTEGER iflag_trac
-
-!$OMP THREADPRIVATE(purmats,forward,leapf,apphys,statcl,conser, &
-!$OMP     apdiss,apdelq,saison,ecripar,fxyhypb,ysinus, &
-!$OMP     read_start,ok_guide,ok_strato,ok_gradsfile, &
-!$OMP     ok_limit,ok_etat0,hybrid, adv_qsat_liq)
-!$OMP THREADPRIVATE(iflag_phys,iflag_trac)
-
-!WARNING: when adding a threadprivate variable in this module
-!        do not forget to add it to the copyin clause when opening an OpenMP
-!        parallel section. e.g. in gcm before call leapfrog_loc 
-
-END MODULE logic_mod
Index: /LMDZ6/trunk/libf/dyn3dmem/logic_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/logic_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3dmem/logic_mod.f90	(revision 5268)
@@ -0,0 +1,48 @@
+!
+! $Id: $
+!
+MODULE logic_mod
+
+IMPLICIT NONE
+
+  LOGICAL purmats ! true if time stepping is purely Matsuno scheme
+                  ! false implies Matsuno-Leapfrog time stepping scheme
+  LOGICAL forward ! true if during forward phase of Matsuno step
+  LOGICAL leapf ! true if during a leapfrog time stepping step
+  LOGICAL apphys ! true if during a time step when physics will be called
+  LOGICAL statcl
+  LOGICAL conser
+  LOGICAL apdiss ! true if during a time step when dissipation will be called
+  LOGICAL apdelq
+  LOGICAL saison
+  LOGICAL ecripar
+  LOGICAL fxyhypb ! true if using hyperbolic function discretization
+                  ! for latitudinal grid 
+  LOGICAL ysinus ! true if using sine function discretiation
+                 ! for latitudinal grid
+  LOGICAL read_start ! true if reading a start.nc file to initialize fields
+  LOGICAL ok_guide ! true if nudging
+  LOGICAL ok_strato
+  LOGICAL ok_gradsfile
+  LOGICAL ok_limit  ! true for boundary conditions file creation (limit.nc)
+  LOGICAL ok_etat0  ! true for initial states creation (start.nc, startphy.nc)
+  LOGICAL read_orop ! true for sub-cell scales orographic params read in file
+  LOGICAL hybrid ! vertical coordinate is hybrid if true (sigma otherwise)
+                 ! (only used if disvert_type==2)
+  LOGICAL adv_qsat_liq ! true if qsat is calculated alwats wrt liquid for
+                       ! adapted Van Leer advection scheme
+  INTEGER iflag_phys ! type of physics to call: 0 none, 1: phy*** package,
+                     ! 2: Held & Suarez, 101-200: aquaplanets & terraplanets
+  INTEGER iflag_trac
+
+!$OMP THREADPRIVATE(purmats,forward,leapf,apphys,statcl,conser, &
+!$OMP     apdiss,apdelq,saison,ecripar,fxyhypb,ysinus, &
+!$OMP     read_start,ok_guide,ok_strato,ok_gradsfile, &
+!$OMP     ok_limit,ok_etat0,hybrid, adv_qsat_liq)
+!$OMP THREADPRIVATE(iflag_phys,iflag_trac)
+
+!WARNING: when adding a threadprivate variable in this module
+!        do not forget to add it to the copyin clause when opening an OpenMP
+!        parallel section. e.g. in gcm before call leapfrog_loc 
+
+END MODULE logic_mod
Index: DZ6/trunk/libf/dyn3dmem/massbar_loc.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/massbar_loc.F90	(revision 5267)
+++ 	(revision )
@@ -1,76 +1,0 @@
-SUBROUTINE massbar_loc(masse,massebx,masseby)
-!
-!-------------------------------------------------------------------------------
-! Authors: P. Le Van , Fr. Hourdin.
-!-------------------------------------------------------------------------------
-! Purpose: Compute air mass mean along X and Y in each cell.
-! See iniconst for more details.
-  USE parallel_lmdz
-  IMPLICIT NONE
-  include "dimensions.h"
-  include "paramet.h"
-  include "comgeom.h"
-!===============================================================================
-! Arguments:
-  REAL, INTENT(IN)  :: masse  (ijb_u:ije_u,llm)
-  REAL, INTENT(OUT) :: massebx(ijb_u:ije_u,llm)
-  REAL, INTENT(OUT) :: masseby(ijb_v:ije_v,llm)
-!-------------------------------------------------------------------------------
-! Method used. Each scalar point is associated to 4 area coefficients:
-!    * alpha1(i,j) at point ( i+1/4,j-1/4 )
-!    * alpha2(i,j) at point ( i+1/4,j+1/4 )
-!    * alpha3(i,j) at point ( i-1/4,j+1/4 )
-!    * alpha4(i,j) at point ( i-1/4,j-1/4 )
-! where alpha1(i,j) = aire(i+1/4,j-1/4)/ aire(i,j)
-!
-!   alpha4 .         . alpha1    . alpha4
-!    (i,j)             (i,j)       (i+1,j)
-!
-!             P .        U .          . P
-!           (i,j)       (i,j)         (i+1,j)
-!
-!   alpha3 .         . alpha2    .alpha3 
-!    (i,j)              (i,j)     (i+1,j)
-!
-!             V .        Z .          . V
-!           (i,j)
-!
-!   alpha4 .         . alpha1    .alpha4
-!   (i,j+1)            (i,j+1)   (i+1,j+1) 
-!
-!             P .        U .          . P
-!          (i,j+1)                    (i+1,j+1)
-!
-!
-!    massebx(i,j) = masse(i  ,j) * ( alpha1(i  ,j) + alpha2(i,j))   +
-!                   masse(i+1,j) * ( alpha3(i+1,j) + alpha4(i+1,j) )
-!     localized at point  ... U (i,j) ...
-!
-!    masseby(i,j) = masse(i,j  ) * ( alpha2(i,j  ) + alpha3(i,j  )  +
-!                   masse(i,j+1) * ( alpha1(i,j+1) + alpha4(i,j+1)  
-!     localized at point  ... V (i,j) ...
-!===============================================================================
-! Local variables:
-  INTEGER :: ij, l, ijb, ije
-!===============================================================================
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)  
-  DO l=1,llm
-    ijb=ij_begin
-    ije=ij_end+iip1
-    IF(pole_sud) ije=ije-iip1
-    DO ij=ijb,ije-1
-      massebx(ij,l)=masse(ij,l)*alpha1p2(ij)+masse(ij+1   ,l)*alpha3p4(ij+1)
-    END DO
-    DO ij=ijb+iim,ije+iim,iip1; massebx(ij,l)=massebx(ij-iim,l); END DO
-    ijb=ij_begin-iip1
-    ije=ij_end+iip1
-    IF(pole_nord) ijb=ij_begin
-    IF(pole_sud) ije=ij_end-iip1
-    DO ij=ijb,ije
-      masseby(ij,l)=masse(ij,l)*alpha2p3(ij)+masse(ij+iip1,l)*alpha1p4(ij+iip1)
-    END DO
-  END DO
-!$OMP END DO NOWAIT
-
-END SUBROUTINE massbar_loc
-
Index: /LMDZ6/trunk/libf/dyn3dmem/massbar_loc.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/massbar_loc.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3dmem/massbar_loc.f90	(revision 5268)
@@ -0,0 +1,76 @@
+SUBROUTINE massbar_loc(masse,massebx,masseby)
+!
+!-------------------------------------------------------------------------------
+! Authors: P. Le Van , Fr. Hourdin.
+!-------------------------------------------------------------------------------
+! Purpose: Compute air mass mean along X and Y in each cell.
+! See iniconst for more details.
+  USE parallel_lmdz
+  IMPLICIT NONE
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom.h"
+!===============================================================================
+! Arguments:
+  REAL, INTENT(IN)  :: masse  (ijb_u:ije_u,llm)
+  REAL, INTENT(OUT) :: massebx(ijb_u:ije_u,llm)
+  REAL, INTENT(OUT) :: masseby(ijb_v:ije_v,llm)
+!-------------------------------------------------------------------------------
+! Method used. Each scalar point is associated to 4 area coefficients:
+!    * alpha1(i,j) at point ( i+1/4,j-1/4 )
+!    * alpha2(i,j) at point ( i+1/4,j+1/4 )
+!    * alpha3(i,j) at point ( i-1/4,j+1/4 )
+!    * alpha4(i,j) at point ( i-1/4,j-1/4 )
+! where alpha1(i,j) = aire(i+1/4,j-1/4)/ aire(i,j)
+!
+!   alpha4 .         . alpha1    . alpha4
+!    (i,j)             (i,j)       (i+1,j)
+!
+!             P .        U .          . P
+!           (i,j)       (i,j)         (i+1,j)
+!
+!   alpha3 .         . alpha2    .alpha3 
+!    (i,j)              (i,j)     (i+1,j)
+!
+!             V .        Z .          . V
+!           (i,j)
+!
+!   alpha4 .         . alpha1    .alpha4
+!   (i,j+1)            (i,j+1)   (i+1,j+1) 
+!
+!             P .        U .          . P
+!          (i,j+1)                    (i+1,j+1)
+!
+!
+!    massebx(i,j) = masse(i  ,j) * ( alpha1(i  ,j) + alpha2(i,j))   +
+!                   masse(i+1,j) * ( alpha3(i+1,j) + alpha4(i+1,j) )
+!     localized at point  ... U (i,j) ...
+!
+!    masseby(i,j) = masse(i,j  ) * ( alpha2(i,j  ) + alpha3(i,j  )  +
+!                   masse(i,j+1) * ( alpha1(i,j+1) + alpha4(i,j+1)  
+!     localized at point  ... V (i,j) ...
+!===============================================================================
+! Local variables:
+  INTEGER :: ij, l, ijb, ije
+!===============================================================================
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)  
+  DO l=1,llm
+    ijb=ij_begin
+    ije=ij_end+iip1
+    IF(pole_sud) ije=ije-iip1
+    DO ij=ijb,ije-1
+      massebx(ij,l)=masse(ij,l)*alpha1p2(ij)+masse(ij+1   ,l)*alpha3p4(ij+1)
+    END DO
+    DO ij=ijb+iim,ije+iim,iip1; massebx(ij,l)=massebx(ij-iim,l); END DO
+    ijb=ij_begin-iip1
+    ije=ij_end+iip1
+    IF(pole_nord) ijb=ij_begin
+    IF(pole_sud) ije=ij_end-iip1
+    DO ij=ijb,ije
+      masseby(ij,l)=masse(ij,l)*alpha2p3(ij)+masse(ij+iip1,l)*alpha1p4(ij+iip1)
+    END DO
+  END DO
+!$OMP END DO NOWAIT
+
+END SUBROUTINE massbar_loc
+
Index: DZ6/trunk/libf/dyn3dmem/massbarxy_loc.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/massbarxy_loc.F90	(revision 5267)
+++ 	(revision )
@@ -1,38 +1,0 @@
-SUBROUTINE massbarxy_loc(masse,massebxy)
-!
-!-------------------------------------------------------------------------------
-! Authors: P. Le Van , Fr. Hourdin.
-!-------------------------------------------------------------------------------
-! Purpose: Compute air mass mean along X and Y in each cell.
-! See iniconst for more details.
-  USE parallel_lmdz
-  IMPLICIT NONE
-  include "dimensions.h"
-  include "paramet.h"
-  include "comgeom.h"
-!===============================================================================
-! Arguments:
-  REAL, INTENT(IN)  :: masse   (ijb_u:ije_u,llm)
-  REAL, INTENT(OUT) :: massebxy(ijb_v:ije_v,llm)
-!===============================================================================
-! Local variables:
-  INTEGER :: ij, l, ijb, ije
-!===============================================================================
-  ijb=ij_begin-iip1
-  ije=ij_end
-  IF(pole_nord) ijb=ijb+iip1
-  IF(pole_sud)  ije=ije-iip1
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)    
-  DO l=1,llm
-    DO ij=ijb,ije-1
-      massebxy(ij,l)=masse(ij     ,l)*alpha2(ij     ) + &
-     +               masse(ij+1   ,l)*alpha3(ij+1   ) + &
-     +               masse(ij+iip1,l)*alpha1(ij+iip1) + &
-     +               masse(ij+iip2,l)*alpha4(ij+iip2)
-    END DO
-    DO ij=ijb+iip1-1,ije+iip1-1,iip1; massebxy(ij,l)=massebxy(ij-iim,l); END DO
-  END DO
-!$OMP END DO NOWAIT
-
-END SUBROUTINE massbarxy_loc
-
Index: /LMDZ6/trunk/libf/dyn3dmem/massbarxy_loc.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/massbarxy_loc.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3dmem/massbarxy_loc.f90	(revision 5268)
@@ -0,0 +1,38 @@
+SUBROUTINE massbarxy_loc(masse,massebxy)
+!
+!-------------------------------------------------------------------------------
+! Authors: P. Le Van , Fr. Hourdin.
+!-------------------------------------------------------------------------------
+! Purpose: Compute air mass mean along X and Y in each cell.
+! See iniconst for more details.
+  USE parallel_lmdz
+  IMPLICIT NONE
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom.h"
+!===============================================================================
+! Arguments:
+  REAL, INTENT(IN)  :: masse   (ijb_u:ije_u,llm)
+  REAL, INTENT(OUT) :: massebxy(ijb_v:ije_v,llm)
+!===============================================================================
+! Local variables:
+  INTEGER :: ij, l, ijb, ije
+!===============================================================================
+  ijb=ij_begin-iip1
+  ije=ij_end
+  IF(pole_nord) ijb=ijb+iip1
+  IF(pole_sud)  ije=ije-iip1
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)    
+  DO l=1,llm
+    DO ij=ijb,ije-1
+      massebxy(ij,l)=masse(ij     ,l)*alpha2(ij     ) + &
+     +               masse(ij+1   ,l)*alpha3(ij+1   ) + &
+     +               masse(ij+iip1,l)*alpha1(ij+iip1) + &
+     +               masse(ij+iip2,l)*alpha4(ij+iip2)
+    END DO
+    DO ij=ijb+iip1-1,ije+iip1-1,iip1; massebxy(ij,l)=massebxy(ij-iim,l); END DO
+  END DO
+!$OMP END DO NOWAIT
+
+END SUBROUTINE massbarxy_loc
+
Index: DZ6/trunk/libf/dyn3dmem/mod_hallo.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/mod_hallo.F90	(revision 5267)
+++ 	(revision )
@@ -1,1863 +1,0 @@
-module mod_Hallo
-USE parallel_lmdz
-implicit none
-  logical,save :: use_mpi_alloc
-  integer, parameter :: MaxProc=512
-  integer, parameter :: DefaultMaxBufferSize=1024*1024*100
-  integer, SAVE :: MaxBufferSize=0
-  integer, parameter :: ListSize=1000
-  
-  integer,save       :: MaxBufferSize_Used
-!$OMP THREADPRIVATE( MaxBufferSize_Used)
-
-   real,save,pointer,dimension(:) :: Buffer
-!$OMP THREADPRIVATE(Buffer)
-
-   integer,save,dimension(Listsize) :: Buffer_Pos
-   integer,save :: Index_Pos
-!$OMP THREADPRIVATE(Buffer_Pos,Index_pos)
-   
-  type Hallo
-    real, dimension(:,:),pointer :: Field
-    integer :: offset
-    integer :: size
-    integer :: NbLevel
-    integer :: Stride
-  end type Hallo
-  
-  type request_SR
-    integer :: NbRequest=0
-    integer :: NbRequestMax=0
-    integer :: BufferSize
-    integer :: Pos
-    integer :: Index 
-    type(Hallo), POINTER :: Hallo(:)
-    integer :: MSG_Request
-  end type request_SR
-
-  type request
-    type(request_SR),dimension(0:MaxProc-1) :: RequestSend
-    type(request_SR),dimension(0:MaxProc-1) :: RequestRecv
-    integer :: tag=1
-  end type request
-  
-   TYPE(distrib),SAVE :: distrib_gather
-
-
-  INTERFACE Register_SwapField_u
-    MODULE PROCEDURE Register_SwapField1d_u,Register_SwapField2d_u1d,Register_SwapField3d_u, &
-                     Register_SwapField1d_u_bis,Register_SwapField2d_u1d_bis,Register_SwapField3d_u_bis
-  END INTERFACE Register_SwapField_u
-
-  INTERFACE Register_SwapField_v
-    MODULE PROCEDURE Register_SwapField1d_v,Register_SwapField2d_v1d,Register_SwapField3d_v,&
-                     Register_SwapField1d_v_bis,Register_SwapField2d_v1d_bis,Register_SwapField3d_v_bis
-  END INTERFACE Register_SwapField_v
-
-  INTERFACE Register_SwapField2d_u
-    MODULE PROCEDURE Register_SwapField1d_u2d,Register_SwapField2d_u2d,Register_SwapField3d_u2d, &
-                     Register_SwapField1d_u2d_bis,Register_SwapField2d_u2d_bis,Register_SwapField3d_u2d_bis
-  END INTERFACE Register_SwapField2d_u
-
-  INTERFACE Register_SwapField2d_v
-    MODULE PROCEDURE Register_SwapField1d_v2d,Register_SwapField2d_v2d,Register_SwapField3d_v2d, &
-                     Register_SwapField1d_v2d_bis,Register_SwapField2d_v2d_bis,Register_SwapField3d_v2d_bis
-  END INTERFACE Register_SwapField2d_v
-
-  contains
-
-  subroutine Init_mod_hallo
-  USE dimensions_mod
-  USE IOIPSL
-    implicit none
-    integer :: jj_nb_gather(0:mpi_size-1)
-    
-    Index_Pos=1
-    Buffer_Pos(Index_Pos)=1
-    MaxBufferSize_Used=0
-!$OMP MASTER     
-    MaxBufferSize=DefaultMaxBufferSize
-    CALL getin("mpi_buffer_size",MaxBufferSize)
-!$OMP END MASTER
-!$OMP BARRIER
-    
-    IF (use_mpi_alloc .AND. using_mpi) THEN
-      CALL create_global_mpi_buffer
-    ELSE 
-      CALL create_standard_mpi_buffer
-    ENDIF
-     
-!$OMP MASTER     
-     jj_nb_gather(:)=0
-     jj_nb_gather(0)=jjp1
-     
-     CALL create_distrib(jj_nb_gather,distrib_gather) 
-!$OMP END MASTER
-!$OMP BARRIER
-
-  end subroutine init_mod_hallo
-
-  SUBROUTINE create_standard_mpi_buffer
-  IMPLICIT NONE
-    
-    ALLOCATE(Buffer(MaxBufferSize))
-    
-  END SUBROUTINE create_standard_mpi_buffer
-  
-  SUBROUTINE create_global_mpi_buffer
-  USE lmdz_mpi
-  IMPLICIT NONE
-    POINTER (Pbuffer,MPI_Buffer(MaxBufferSize))
-    REAL :: MPI_Buffer
-    INTEGER(KIND=MPI_ADDRESS_KIND) :: BS 
-    INTEGER :: i,ierr
-
-!  Allocation du buffer MPI
-      Bs=8*MaxBufferSize
-!$OMP CRITICAL (MPI)
-      CALL MPI_ALLOC_MEM(BS,MPI_INFO_NULL,Pbuffer,ierr)
-!$OMP END CRITICAL (MPI)
-      DO i=1,MaxBufferSize
-	MPI_Buffer(i)=i
-      ENDDO
-     
-      CALL  Associate_buffer(MPI_Buffer)
-      
-  CONTAINS
-     
-     SUBROUTINE Associate_buffer(MPI_Buffer)
-     IMPLICIT NONE
-       REAL,DIMENSION(:),target :: MPI_Buffer  
-
-         Buffer=>MPI_Buffer
- 
-      END SUBROUTINE  Associate_buffer
-                                      
-  END SUBROUTINE create_global_mpi_buffer
- 
-      
-  subroutine allocate_buffer(Size,Index,Pos)
-  implicit none
-    integer :: Size
-    integer :: Index
-    integer :: Pos
-
-    if (Buffer_pos(Index_pos)+Size>MaxBufferSize_Used) MaxBufferSize_Used=Buffer_pos(Index_pos)+Size  
-    if (Buffer_pos(Index_pos)+Size>MaxBufferSize) then
-      print *,'STOP :: La taille de MaxBufferSize dans mod_hallo.F90 est trop petite !!!!'
-      CALL abort_gcm("mod_hallo","stopped",1)
-    endif
-    
-    if (Index_pos>=ListSize) then
-      print *,'STOP :: La taille de ListSize dans mod_hallo.F90 est trop petite !!!!'
-      CALL abort_gcm("mod_hallo","stopped",1)
-    endif
-     
-    Pos=Buffer_Pos(Index_Pos)
-    Buffer_Pos(Index_pos+1)=Buffer_Pos(Index_Pos)+Size
-    Index_Pos=Index_Pos+1
-    Index=Index_Pos
-    
-  end subroutine allocate_buffer
-     
-  subroutine deallocate_buffer(Index)
-  implicit none
-    integer :: Index
-    
-    Buffer_Pos(Index)=-1
-    
-    do while (Buffer_Pos(Index_Pos)==-1 .and. Index_Pos>1)
-      Index_Pos=Index_Pos-1
-    end do
-
-  end subroutine deallocate_buffer  
-  
-  subroutine SetTag(a_request,tag)
-  implicit none
-    type(request):: a_request
-    integer :: tag
-    
-    a_request%tag=tag
-  end subroutine SetTag
-  
-  
-  subroutine New_Hallo(Field,Stride,NbLevel,offset,size,Ptr_request)
-    integer :: Stride
-    integer :: NbLevel
-    integer :: size
-    integer :: offset
-    real, dimension(Stride,NbLevel),target :: Field
-    type(request_SR),pointer :: Ptr_request
-    type(Hallo),POINTER :: NewHallos(:),HalloSwitch(:), NewHallo
-    
-    Ptr_Request%NbRequest=Ptr_Request%NbRequest+1
-    IF(Ptr_Request%NbRequestMax==0) THEN
-       Ptr_Request%NbRequestMax=10
-       ALLOCATE(Ptr_Request%Hallo(Ptr_Request%NbRequestMax))
-    ELSE IF ( Ptr_Request%NbRequest > Ptr_Request%NbRequestMax) THEN
-      Ptr_Request%NbRequestMax=INT(Ptr_Request%NbRequestMax*1.2)
-      ALLOCATE(NewHallos(Ptr_Request%NbRequestMax))
-      NewHallos(1:Ptr_Request%NbRequest-1)=Ptr_Request%hallo(1:Ptr_Request%NbRequest-1)
-      HalloSwitch=>Ptr_Request%hallo
-      Ptr_Request%hallo=>NewHallos
-      DEALLOCATE(HalloSwitch)
-    ENDIF
-    
-    NewHallo=>Ptr_Request%hallo(Ptr_Request%NbRequest)
-          
-    NewHallo%Field=>Field
-    NewHallo%Stride=Stride
-    NewHallo%NbLevel=NbLevel
-    NewHallo%size=size
-    NewHallo%offset=offset
-    
-  end subroutine New_Hallo
-  
-  subroutine Register_SendField(Field,ij,ll,offset,size,target,a_request)
-  USE dimensions_mod
-  implicit none
-
-    
-      INTEGER :: ij,ll,offset,size,target
-      REAL, dimension(ij,ll) :: Field
-      type(request),target :: a_request
-      type(request_SR),pointer :: Ptr_request
-
-      Ptr_Request=>a_request%RequestSend(target)
-
-      call New_Hallo(Field,ij,ll,offset,size,Ptr_request)
-      
-   end subroutine Register_SendField      
-      
-  subroutine Register_RecvField(Field,ij,ll,offset,size,target,a_request)
-  USE dimensions_mod
-  implicit none
-
-   
-      INTEGER :: ij,ll,offset,size,target
-      REAL, dimension(ij,ll) :: Field
-      type(request),target :: a_request
-      type(request_SR),pointer :: Ptr_request
-
-      Ptr_Request=>a_request%RequestRecv(target)
-            
-      call New_Hallo(Field,ij,ll,offset,size,Ptr_request)
-
-      
-   end subroutine Register_RecvField      
-  
-  subroutine Register_SwapField(FieldS,FieldR,ij,ll,jj_Nb_New,a_request)
-  USE dimensions_mod
-      implicit none
-
-    
-    INTEGER :: ij,ll
-    REAL, dimension(ij,ll) :: FieldS
-    REAL, dimension(ij,ll) :: FieldR
-    type(request) :: a_request
-    integer,dimension(0:MPI_Size-1) :: jj_Nb_New   
-    integer,dimension(0:MPI_Size-1) :: jj_Begin_New,jj_End_New
-    
-    integer ::i,jje,jjb
-    
-    jj_begin_New(0)=1
-    jj_End_New(0)=jj_Nb_New(0)
-    do i=1,MPI_Size-1
-      jj_begin_New(i)=jj_end_New(i-1)+1
-      jj_end_New(i)=jj_begin_new(i)+jj_Nb_New(i)-1
-    enddo
-    
-    do i=0,MPI_Size-1
-      if (i /= MPI_Rank) then
-        jjb=max(jj_begin_new(i),jj_begin)
-        jje=min(jj_end_new(i),jj_end)
-        
-        if (ij==ip1jm .and. jje==jjp1) jje=jjm
-        
-        if (jje >= jjb) then
-          call Register_SendField(FieldS,ij,ll,jjb,jje-jjb+1,i,a_request) 
-        endif
-        
-        jjb=max(jj_begin_new(MPI_Rank),jj_begin_Para(i))
-        jje=min(jj_end_new(MPI_Rank),jj_end_Para(i))
-        
-        if (ij==ip1jm .and. jje==jjp1) jje=jjm
-        
-        if (jje >= jjb) then
-          call Register_RecvField(FieldR,ij,ll,jjb,jje-jjb+1,i,a_request) 
-        endif
-        
-      endif
-    enddo
-    
-  end subroutine Register_SwapField    
-  
-
-  
-  subroutine Register_SwapFieldHallo(FieldS,FieldR,ij,ll,jj_Nb_New,Up,Down,a_request)
-  USE dimensions_mod
-  
-      implicit none
-    
-    INTEGER :: ij,ll,Up,Down
-    REAL, dimension(ij,ll) :: FieldS
-    REAL, dimension(ij,ll) :: FieldR
-    type(request) :: a_request
-    integer,dimension(0:MPI_Size-1) :: jj_Nb_New   
-    integer,dimension(0:MPI_Size-1) :: jj_Begin_New,jj_End_New
-    
-    integer ::i,jje,jjb
-    
-    jj_begin_New(0)=1
-    jj_End_New(0)=jj_Nb_New(0)
-    do i=1,MPI_Size-1
-      jj_begin_New(i)=jj_end_New(i-1)+1
-      jj_end_New(i)=jj_begin_new(i)+jj_Nb_New(i)-1
-    enddo
-    
-    do i=0,MPI_Size-1
-      jj_begin_New(i)=max(1,jj_begin_New(i)-Up)
-      jj_end_New(i)=min(jjp1,jj_end_new(i)+Down)
-    enddo
-   
-    do i=0,MPI_Size-1
-      if (i /= MPI_Rank) then
-        jjb=max(jj_begin_new(i),jj_begin)
-        jje=min(jj_end_new(i),jj_end)
-        
-        if (ij==ip1jm .and. jje==jjp1) jje=jjm
-        
-        if (jje >= jjb) then
-          call Register_SendField(FieldS,ij,ll,jjb,jje-jjb+1,i,a_request) 
-        endif
-        
-        jjb=max(jj_begin_new(MPI_Rank),jj_begin_Para(i))
-        jje=min(jj_end_new(MPI_Rank),jj_end_Para(i))
-        
-        if (ij==ip1jm .and. jje==jjp1) jje=jjm
-        
-        if (jje >= jjb) then
-          call Register_RecvField(FieldR,ij,ll,jjb,jje-jjb+1,i,a_request) 
-        endif
-        
-      endif
-    enddo
-    
-  end subroutine Register_SwapFieldHallo
-
-
-
-  SUBROUTINE Register_SwapField1d_u(FieldS,FieldR,new_dist,a_request,up,down)
-  USE parallel_lmdz
-  USE dimensions_mod
-      IMPLICIT NONE
-    
-    TYPE(distrib),INTENT(IN)          :: new_dist
-    REAL, DIMENSION(current_dist%ijb_u:),INTENT(IN)     :: FieldS
-    REAL, DIMENSION(new_dist%ijb_u:),INTENT(OUT)    :: FieldR
-    INTEGER,OPTIONAL,INTENT(IN)       :: up
-    INTEGER,OPTIONAL,INTENT(IN)       :: down      
-    TYPE(request),INTENT(INOUT)         :: a_request
-
-    INTEGER                           :: halo_up
-    INTEGER                           :: halo_down
-    
-    
-    halo_up=0
-    halo_down=0
-    IF (PRESENT(up))   halo_up=up
-    IF (PRESENT(down)) halo_down=down
-
-    CALL  Register_SwapField_gen_u(FieldS,FieldR,1,current_dist,new_dist,halo_up,halo_down,a_request)
-        
-  END SUBROUTINE  Register_SwapField1d_u 
-
-  SUBROUTINE Register_SwapField1d_u_bis(FieldS,FieldR,new_dist,a_request,old_dist,up,down)
-  USE parallel_lmdz
-  USE dimensions_mod
-      IMPLICIT NONE
-    
-    TYPE(distrib),INTENT(IN)          :: new_dist
-    TYPE(distrib),INTENT(IN)          :: old_dist
-    REAL, DIMENSION(old_dist%ijb_u:),INTENT(IN)     :: FieldS
-    REAL, DIMENSION(new_dist%ijb_u:),INTENT(OUT)    :: FieldR
-    INTEGER,OPTIONAL,INTENT(IN)       :: up
-    INTEGER,OPTIONAL,INTENT(IN)       :: down      
-    TYPE(request),INTENT(INOUT)         :: a_request
-
-    INTEGER                           :: halo_up
-    INTEGER                           :: halo_down
-    
-    
-    halo_up=0
-    halo_down=0
-    IF (PRESENT(up))   halo_up=up
-    IF (PRESENT(down)) halo_down=down
-
-    CALL  Register_SwapField_gen_u(FieldS,FieldR,1,old_dist,new_dist,halo_up,halo_down,a_request)
-        
-  END SUBROUTINE  Register_SwapField1d_u_bis 
-
-
-  SUBROUTINE Register_SwapField2d_u1d(FieldS,FieldR,new_dist,a_request,up,down)
-  USE parallel_lmdz
-  USE dimensions_mod
-    IMPLICIT NONE
-    
-    TYPE(distrib),INTENT(IN)          :: new_dist
-    REAL, DIMENSION(current_dist%ijb_u:,:),INTENT(IN)     :: FieldS
-    REAL, DIMENSION(new_dist%ijb_u:,:),INTENT(OUT)    :: FieldR
-    INTEGER,OPTIONAL,INTENT(IN)       :: up
-    INTEGER,OPTIONAL,INTENT(IN)       :: down      
-    TYPE(request),INTENT(INOUT)         :: a_request
-
-    INTEGER                           :: halo_up
-    INTEGER                           :: halo_down
-    INTEGER                           :: ll
-        
-    
-    halo_up=0
-    halo_down=0
-    IF (PRESENT(up))   halo_up=up
-    IF (PRESENT(down)) halo_down=down
-    
-    ll=size(FieldS,2)
-    
-    CALL  Register_SwapField_gen_u(FieldS,FieldR,ll,current_dist,new_dist,halo_up,halo_down,a_request)
-    
-  END SUBROUTINE  Register_SwapField2d_u1d
-
-  SUBROUTINE Register_SwapField2d_u1d_bis(FieldS,FieldR,new_dist,a_request,old_dist,up,down)
-  USE parallel_lmdz
-  USE dimensions_mod
-    IMPLICIT NONE
-    
-    TYPE(distrib),INTENT(IN)          :: new_dist
-    TYPE(distrib),INTENT(IN) :: old_dist
-    REAL, DIMENSION(old_dist%ijb_u:,:),INTENT(IN)     :: FieldS
-    REAL, DIMENSION(new_dist%ijb_u:,:),INTENT(OUT)    :: FieldR
-    INTEGER,OPTIONAL,INTENT(IN)       :: up
-    INTEGER,OPTIONAL,INTENT(IN)       :: down      
-    TYPE(request),INTENT(INOUT)         :: a_request
-
-    INTEGER                           :: halo_up
-    INTEGER                           :: halo_down
-    INTEGER                           :: ll
-        
-    
-    halo_up=0
-    halo_down=0
-    IF (PRESENT(up))   halo_up=up
-    IF (PRESENT(down)) halo_down=down
-    
-    ll=size(FieldS,2)
-    
-    CALL  Register_SwapField_gen_u(FieldS,FieldR,ll,old_dist,new_dist,halo_up,halo_down,a_request)
-    
-  END SUBROUTINE  Register_SwapField2d_u1d_bis
-   
-
-  SUBROUTINE Register_SwapField3d_u(FieldS,FieldR,new_dist,a_request,up,down)
-  USE parallel_lmdz
-  USE dimensions_mod
-      IMPLICIT NONE
-    
-    TYPE(distrib),INTENT(IN)          :: new_dist
-    REAL, DIMENSION(current_dist%ijb_u:,:,:),INTENT(IN)     :: FieldS
-    REAL, DIMENSION(new_dist%ijb_u:,:,:),INTENT(OUT)    :: FieldR
-    INTEGER,OPTIONAL,INTENT(IN)       :: up
-    INTEGER,OPTIONAL,INTENT(IN)       :: down      
-    TYPE(request),INTENT(INOUT)         :: a_request
-
-    INTEGER                           :: halo_up
-    INTEGER                           :: halo_down
-    INTEGER                           :: ll
-        
-    
-    halo_up=0
-    halo_down=0
-    IF (PRESENT(up))   halo_up=up
-    IF (PRESENT(down)) halo_down=down
-    
-    ll=size(FieldS,2)*size(FieldS,3)
-    
-    CALL  Register_SwapField_gen_u(FieldS,FieldR,ll,current_dist,new_dist,halo_up,halo_down,a_request)
-    
-  END SUBROUTINE  Register_SwapField3d_u 
-
-  SUBROUTINE Register_SwapField3d_u_bis(FieldS,FieldR,new_dist,a_request,old_dist,up,down)
-  USE parallel_lmdz
-  USE dimensions_mod
-      IMPLICIT NONE
-    
-    TYPE(distrib),INTENT(IN)          :: new_dist
-    TYPE(distrib),INTENT(IN) :: old_dist
-    REAL, DIMENSION(old_dist%ijb_u:,:,:),INTENT(IN)     :: FieldS
-    REAL, DIMENSION(new_dist%ijb_u:,:,:),INTENT(OUT)    :: FieldR
-    INTEGER,OPTIONAL,INTENT(IN)       :: up
-    INTEGER,OPTIONAL,INTENT(IN)       :: down      
-    TYPE(request),INTENT(INOUT)         :: a_request
-
-    INTEGER                           :: halo_up
-    INTEGER                           :: halo_down
-    INTEGER                           :: ll
-        
-    
-    halo_up=0
-    halo_down=0
-    IF (PRESENT(up))   halo_up=up
-    IF (PRESENT(down)) halo_down=down
-    
-    ll=size(FieldS,2)*size(FieldS,3)
-    
-    CALL  Register_SwapField_gen_u(FieldS,FieldR,ll,old_dist,new_dist,halo_up,halo_down,a_request)
-    
-  END SUBROUTINE  Register_SwapField3d_u_bis 
-  
-
-
- SUBROUTINE Register_SwapField1d_u2d(FieldS,FieldR,new_dist,a_request,up,down)
-  USE parallel_lmdz
-  USE dimensions_mod
-
-      IMPLICIT NONE
-
-    TYPE(distrib),INTENT(IN)          :: new_dist !LF
-    REAL, DIMENSION(current_dist%jjb_u:,:),INTENT(IN)     :: FieldS
-    REAL, DIMENSION(new_dist%jjb_u:,:),INTENT(OUT)    :: FieldR
-    INTEGER,OPTIONAL,INTENT(IN)       :: up
-    INTEGER,OPTIONAL,INTENT(IN)       :: down      
-    TYPE(request),INTENT(INOUT)         :: a_request
-
-    INTEGER                           :: halo_up
-    INTEGER                           :: halo_down
-    
-    
-    halo_up=0
-    halo_down=0
-    IF (PRESENT(up))   halo_up=up
-    IF (PRESENT(down)) halo_down=down
-
-    CALL  Register_SwapField_gen_u(FieldS,FieldR,1,current_dist,new_dist,halo_up,halo_down,a_request)
-        
-  END SUBROUTINE  Register_SwapField1d_u2d 
-
- SUBROUTINE Register_SwapField1d_u2d_bis(FieldS,FieldR,new_dist,a_request,old_dist,up,down)
-  USE parallel_lmdz
-  USE dimensions_mod
-
-      IMPLICIT NONE
-
-    TYPE(distrib),INTENT(IN)          :: new_dist !LF
-    TYPE(distrib),INTENT(IN)          :: old_dist
-    REAL, DIMENSION(old_dist%jjb_u:,:),INTENT(IN)     :: FieldS
-    REAL, DIMENSION(new_dist%jjb_u:,:),INTENT(OUT)    :: FieldR
-    INTEGER,OPTIONAL,INTENT(IN)       :: up
-    INTEGER,OPTIONAL,INTENT(IN)       :: down      
-    TYPE(request),INTENT(INOUT)         :: a_request
-
-    INTEGER                           :: halo_up
-    INTEGER                           :: halo_down
-    
-    
-    halo_up=0
-    halo_down=0
-    IF (PRESENT(up))   halo_up=up
-    IF (PRESENT(down)) halo_down=down
-
-    CALL  Register_SwapField_gen_u(FieldS,FieldR,1,old_dist,new_dist,halo_up,halo_down,a_request)
-        
-  END SUBROUTINE  Register_SwapField1d_u2d_bis 
-
-
-  SUBROUTINE Register_SwapField2d_u2d(FieldS,FieldR,new_dist,a_request,up,down)
-  USE parallel_lmdz
-  USE dimensions_mod
-
-      IMPLICIT NONE
-    
-    TYPE(distrib),INTENT(IN)          :: new_dist
-    REAL, DIMENSION(current_dist%jjb_u:,:,:),INTENT(IN)     :: FieldS
-    REAL, DIMENSION(new_dist%jjb_u:,:,:),INTENT(OUT)    :: FieldR
-    INTEGER,OPTIONAL,INTENT(IN)       :: up
-    INTEGER,OPTIONAL,INTENT(IN)       :: down      
-    TYPE(request),INTENT(INOUT)         :: a_request
-
-    INTEGER                           :: halo_up
-    INTEGER                           :: halo_down
-    INTEGER                           :: ll
-        
-    
-    halo_up=0
-    halo_down=0
-    IF (PRESENT(up))   halo_up=up
-    IF (PRESENT(down)) halo_down=down
-    
-    ll=size(FieldS,3)
-    
-    CALL  Register_SwapField_gen_u(FieldS,FieldR,ll,current_dist,new_dist,halo_up,halo_down,a_request)
-    
-  END SUBROUTINE  Register_SwapField2d_u2d
-
-  SUBROUTINE Register_SwapField2d_u2d_bis(FieldS,FieldR,new_dist,a_request,old_dist,up,down)
-  USE parallel_lmdz
-  USE dimensions_mod
-
-      IMPLICIT NONE
-    
-    TYPE(distrib),INTENT(IN)          :: new_dist
-    TYPE(distrib),INTENT(IN) :: old_dist
-    REAL, DIMENSION(old_dist%jjb_u:,:,:),INTENT(IN)     :: FieldS
-    REAL, DIMENSION(new_dist%jjb_u:,:,:),INTENT(OUT)    :: FieldR
-    INTEGER,OPTIONAL,INTENT(IN)       :: up
-    INTEGER,OPTIONAL,INTENT(IN)       :: down      
-    TYPE(request),INTENT(INOUT)         :: a_request
-
-    INTEGER                           :: halo_up
-    INTEGER                           :: halo_down
-    INTEGER                           :: ll
-        
-    
-    halo_up=0
-    halo_down=0
-    IF (PRESENT(up))   halo_up=up
-    IF (PRESENT(down)) halo_down=down
-    
-    ll=size(FieldS,3)
-    
-    CALL  Register_SwapField_gen_u(FieldS,FieldR,ll,old_dist,new_dist,halo_up,halo_down,a_request)
-    
-  END SUBROUTINE  Register_SwapField2d_u2d_bis
-   
-
-  SUBROUTINE Register_SwapField3d_u2d(FieldS,FieldR,new_dist,a_request,up,down)
-  USE parallel_lmdz
-  USE dimensions_mod
-      IMPLICIT NONE
-    
-    TYPE(distrib),INTENT(IN)          :: new_dist
-    REAL, DIMENSION(current_dist%jjb_u:,:,:,:),INTENT(IN)     :: FieldS
-    REAL, DIMENSION(new_dist%jjb_u:,:,:,:),INTENT(OUT)    :: FieldR
-    INTEGER,OPTIONAL,INTENT(IN)       :: up
-    INTEGER,OPTIONAL,INTENT(IN)       :: down      
-    TYPE(request),INTENT(INOUT)         :: a_request
-
-    INTEGER                           :: halo_up
-    INTEGER                           :: halo_down
-    INTEGER                           :: ll
-        
-    
-    halo_up=0
-    halo_down=0
-    IF (PRESENT(up))   halo_up=up
-    IF (PRESENT(down)) halo_down=down
-    
-    ll=size(FieldS,3)*size(FieldS,4)
-    
-    CALL  Register_SwapField_gen_u(FieldS,FieldR,ll,current_dist,new_dist,halo_up,halo_down,a_request)
-    
-  END SUBROUTINE  Register_SwapField3d_u2d 
-
-  SUBROUTINE Register_SwapField3d_u2d_bis(FieldS,FieldR,new_dist,a_request,old_dist,up,down)
-  USE parallel_lmdz
-  USE dimensions_mod
-      IMPLICIT NONE
-    
-    TYPE(distrib),INTENT(IN)          :: new_dist
-    TYPE(distrib),INTENT(IN) :: old_dist
-    REAL, DIMENSION(old_dist%jjb_u:,:,:,:),INTENT(IN)     :: FieldS
-    REAL, DIMENSION(new_dist%jjb_u:,:,:,:),INTENT(OUT)    :: FieldR
-    INTEGER,OPTIONAL,INTENT(IN)       :: up
-    INTEGER,OPTIONAL,INTENT(IN)       :: down      
-    TYPE(request),INTENT(INOUT)         :: a_request
-
-    INTEGER                           :: halo_up
-    INTEGER                           :: halo_down
-    INTEGER                           :: ll
-        
-    
-    halo_up=0
-    halo_down=0
-    IF (PRESENT(up))   halo_up=up
-    IF (PRESENT(down)) halo_down=down
-    
-    ll=size(FieldS,3)*size(FieldS,4)
-    
-    CALL  Register_SwapField_gen_u(FieldS,FieldR,ll,old_dist,new_dist,halo_up,halo_down,a_request)
-    
-  END SUBROUTINE  Register_SwapField3d_u2d_bis 
-
-
-
-
-
-
-
-  SUBROUTINE Register_SwapField1d_v(FieldS,FieldR,new_dist,a_request,up,down)
-  USE parallel_lmdz
-  USE dimensions_mod
-      IMPLICIT NONE
-    
-    TYPE(distrib),INTENT(IN)          :: new_dist
-    REAL, DIMENSION(current_dist%ijb_v:),INTENT(IN)     :: FieldS
-    REAL, DIMENSION(new_dist%ijb_v:),INTENT(OUT)    :: FieldR
-    INTEGER,OPTIONAL,INTENT(IN)       :: up
-    INTEGER,OPTIONAL,INTENT(IN)       :: down      
-    TYPE(request),INTENT(INOUT)         :: a_request
-
-    INTEGER                           :: halo_up
-    INTEGER                           :: halo_down
-    
-    
-    halo_up=0
-    halo_down=0
-    IF (PRESENT(up))   halo_up=up
-    IF (PRESENT(down)) halo_down=down
-
-    CALL  Register_SwapField_gen_v(FieldS,FieldR,1,current_dist,new_dist,halo_up,halo_down,a_request)
-        
-  END SUBROUTINE  Register_SwapField1d_v 
-
-  SUBROUTINE Register_SwapField1d_v_bis(FieldS,FieldR,new_dist,a_request,old_dist,up,down)
-  USE parallel_lmdz
-  USE dimensions_mod
-      IMPLICIT NONE
-    
-    TYPE(distrib),INTENT(IN)          :: new_dist
-    TYPE(distrib),INTENT(IN) :: old_dist
-    REAL, DIMENSION(old_dist%ijb_v:),INTENT(IN)     :: FieldS
-    REAL, DIMENSION(new_dist%ijb_v:),INTENT(OUT)    :: FieldR
-    INTEGER,OPTIONAL,INTENT(IN)       :: up
-    INTEGER,OPTIONAL,INTENT(IN)       :: down      
-    TYPE(request),INTENT(INOUT)         :: a_request
-
-    INTEGER                           :: halo_up
-    INTEGER                           :: halo_down
-    
-    
-    halo_up=0
-    halo_down=0
-    IF (PRESENT(up))   halo_up=up
-    IF (PRESENT(down)) halo_down=down
-
-    CALL  Register_SwapField_gen_v(FieldS,FieldR,1,old_dist,new_dist,halo_up,halo_down,a_request)
-        
-  END SUBROUTINE  Register_SwapField1d_v_bis 
-
-
-  SUBROUTINE Register_SwapField2d_v1d(FieldS,FieldR,new_dist,a_request,up,down)
-  USE parallel_lmdz
-  USE dimensions_mod
-      IMPLICIT NONE
-   
-    TYPE(distrib),INTENT(IN)          :: new_dist
-    REAL, DIMENSION(current_dist%ijb_v:,:),INTENT(IN)     :: FieldS
-    REAL, DIMENSION(new_dist%ijb_v:,:),INTENT(OUT)    :: FieldR
-    INTEGER,OPTIONAL,INTENT(IN)       :: up
-    INTEGER,OPTIONAL,INTENT(IN)       :: down      
-    TYPE(request),INTENT(INOUT)         :: a_request
-
-    INTEGER                           :: halo_up
-    INTEGER                           :: halo_down
-    INTEGER                           :: ll
-        
-    
-    halo_up=0
-    halo_down=0
-    IF (PRESENT(up))   halo_up=up
-    IF (PRESENT(down)) halo_down=down
-    
-    ll=size(FieldS,2)
-    
-    CALL  Register_SwapField_gen_v(FieldS,FieldR,ll,current_dist,new_dist,halo_up,halo_down,a_request)
-    
-  END SUBROUTINE  Register_SwapField2d_v1d
-  
-  SUBROUTINE Register_SwapField2d_v1d_bis(FieldS,FieldR,new_dist,a_request,old_dist,up,down)
-  USE parallel_lmdz
-  USE dimensions_mod
-      IMPLICIT NONE
-   
-    TYPE(distrib),INTENT(IN)          :: new_dist
-    TYPE(distrib),INTENT(IN)          :: old_dist
-    REAL, DIMENSION(old_dist%ijb_v:,:),INTENT(IN)     :: FieldS
-    REAL, DIMENSION(new_dist%ijb_v:,:),INTENT(OUT)    :: FieldR
-    INTEGER,OPTIONAL,INTENT(IN)       :: up
-    INTEGER,OPTIONAL,INTENT(IN)       :: down      
-    TYPE(request),INTENT(INOUT)         :: a_request
-
-    INTEGER                           :: halo_up
-    INTEGER                           :: halo_down
-    INTEGER                           :: ll
-        
-    
-    halo_up=0
-    halo_down=0
-    IF (PRESENT(up))   halo_up=up
-    IF (PRESENT(down)) halo_down=down
-    
-    ll=size(FieldS,2)
-    
-    CALL  Register_SwapField_gen_v(FieldS,FieldR,ll,old_dist,new_dist,halo_up,halo_down,a_request)
-    
-  END SUBROUTINE  Register_SwapField2d_v1d_bis
-  
-   
-
-  SUBROUTINE Register_SwapField3d_v(FieldS,FieldR,new_dist,a_request,up,down)
-  USE parallel_lmdz
-  USE dimensions_mod
-      IMPLICIT NONE
-    
-    TYPE(distrib),INTENT(IN)          :: new_dist
-    REAL, DIMENSION(current_dist%ijb_v:,:,:),INTENT(IN)     :: FieldS
-    REAL, DIMENSION(new_dist%ijb_v:,:,:),INTENT(OUT)    :: FieldR
-    INTEGER,OPTIONAL,INTENT(IN)       :: up
-    INTEGER,OPTIONAL,INTENT(IN)       :: down      
-    TYPE(request),INTENT(INOUT)         :: a_request
-
-    INTEGER                           :: halo_up
-    INTEGER                           :: halo_down
-    INTEGER                           :: ll
-        
-    
-    halo_up=0
-    halo_down=0
-    IF (PRESENT(up))   halo_up=up
-    IF (PRESENT(down)) halo_down=down
-    
-    ll=size(FieldS,2)*size(FieldS,3)
-    
-    CALL  Register_SwapField_gen_v(FieldS,FieldR,ll,current_dist,new_dist,halo_up,halo_down,a_request)
-    
-  END SUBROUTINE  Register_SwapField3d_v 
-
-  SUBROUTINE Register_SwapField3d_v_bis(FieldS,FieldR,new_dist,a_request,old_dist,up,down)
-  USE parallel_lmdz
-  USE dimensions_mod
-      IMPLICIT NONE
-    
-    TYPE(distrib),INTENT(IN)          :: new_dist
-    TYPE(distrib),INTENT(IN) :: old_dist
-    REAL, DIMENSION(old_dist%ijb_v:,:,:),INTENT(IN)     :: FieldS
-    REAL, DIMENSION(new_dist%ijb_v:,:,:),INTENT(OUT)    :: FieldR
-    INTEGER,OPTIONAL,INTENT(IN)       :: up
-    INTEGER,OPTIONAL,INTENT(IN)       :: down      
-    TYPE(request),INTENT(INOUT)         :: a_request
-
-    INTEGER                           :: halo_up
-    INTEGER                           :: halo_down
-    INTEGER                           :: ll
-        
-    
-    halo_up=0
-    halo_down=0
-    IF (PRESENT(up))   halo_up=up
-    IF (PRESENT(down)) halo_down=down
-    
-    ll=size(FieldS,2)*size(FieldS,3)
-    
-    CALL  Register_SwapField_gen_v(FieldS,FieldR,ll,old_dist,new_dist,halo_up,halo_down,a_request)
-    
-  END SUBROUTINE  Register_SwapField3d_v_bis 
-
-
-
-
-  SUBROUTINE Register_SwapField1d_v2d(FieldS,FieldR,new_dist,a_request,up,down)
-  USE parallel_lmdz
-  USE dimensions_mod
-      IMPLICIT NONE
-    
-    TYPE(distrib),INTENT(IN)          :: new_dist !LF
-    REAL, DIMENSION(current_dist%jjb_v:,:),INTENT(IN)     :: FieldS
-    REAL, DIMENSION(new_dist%jjb_v:,:),INTENT(OUT)    :: FieldR
-    INTEGER,OPTIONAL,INTENT(IN)       :: up
-    INTEGER,OPTIONAL,INTENT(IN)       :: down      
-    TYPE(request),INTENT(INOUT)         :: a_request
-
-    INTEGER                           :: halo_up
-    INTEGER                           :: halo_down
-    
-    
-    halo_up=0
-    halo_down=0
-    IF (PRESENT(up))   halo_up=up
-    IF (PRESENT(down)) halo_down=down
-
-    CALL  Register_SwapField_gen_v(FieldS,FieldR,1,current_dist,new_dist,halo_up,halo_down,a_request)
-        
-  END SUBROUTINE  Register_SwapField1d_v2d
-
-  SUBROUTINE Register_SwapField1d_v2d_bis(FieldS,FieldR,new_dist,a_request,old_dist,up,down)
-  USE parallel_lmdz
-  USE dimensions_mod
-      IMPLICIT NONE
-    
-    TYPE(distrib),INTENT(IN)          :: new_dist !LF
-    TYPE(distrib),INTENT(IN) :: old_dist
-    REAL, DIMENSION(old_dist%jjb_v:,:),INTENT(IN)     :: FieldS
-    REAL, DIMENSION(new_dist%jjb_v:,:),INTENT(OUT)    :: FieldR
-    INTEGER,OPTIONAL,INTENT(IN)       :: up
-    INTEGER,OPTIONAL,INTENT(IN)       :: down      
-    TYPE(request),INTENT(INOUT)         :: a_request
-
-    INTEGER                           :: halo_up
-    INTEGER                           :: halo_down
-    
-    
-    halo_up=0
-    halo_down=0
-    IF (PRESENT(up))   halo_up=up
-    IF (PRESENT(down)) halo_down=down
-
-    CALL  Register_SwapField_gen_v(FieldS,FieldR,1,old_dist,new_dist,halo_up,halo_down,a_request)
-        
-  END SUBROUTINE  Register_SwapField1d_v2d_bis
-
-
-  SUBROUTINE Register_SwapField2d_v2d(FieldS,FieldR,new_dist,a_request,up,down)
-  USE parallel_lmdz
-  USE dimensions_mod
-      IMPLICIT NONE
-    
-    TYPE(distrib),INTENT(IN)          :: new_dist
-    REAL, DIMENSION(current_dist%jjb_v:,:,:),INTENT(IN)     :: FieldS
-    REAL, DIMENSION(new_dist%jjb_v:,:,:),INTENT(OUT)    :: FieldR
-    INTEGER,OPTIONAL,INTENT(IN)       :: up
-    INTEGER,OPTIONAL,INTENT(IN)       :: down      
-    TYPE(request),INTENT(INOUT)         :: a_request
-
-    INTEGER                           :: halo_up
-    INTEGER                           :: halo_down
-    INTEGER                           :: ll
-        
-    
-    halo_up=0
-    halo_down=0
-    IF (PRESENT(up))   halo_up=up
-    IF (PRESENT(down)) halo_down=down
-    
-    ll=size(FieldS,3)
-    
-    CALL  Register_SwapField_gen_v(FieldS,FieldR,ll,current_dist,new_dist,halo_up,halo_down,a_request)
-    
-  END SUBROUTINE  Register_SwapField2d_v2d
-   
-  SUBROUTINE Register_SwapField2d_v2d_bis(FieldS,FieldR,new_dist,a_request,old_dist,up,down)
-  USE parallel_lmdz
-  USE dimensions_mod
-      IMPLICIT NONE
-    
-    TYPE(distrib),INTENT(IN)          :: new_dist
-    TYPE(distrib),INTENT(IN) :: old_dist
-    REAL, DIMENSION(old_dist%jjb_v:,:,:),INTENT(IN)     :: FieldS
-    REAL, DIMENSION(new_dist%jjb_v:,:,:),INTENT(OUT)    :: FieldR
-    INTEGER,OPTIONAL,INTENT(IN)       :: up
-    INTEGER,OPTIONAL,INTENT(IN)       :: down      
-    TYPE(request),INTENT(INOUT)         :: a_request
-
-    INTEGER                           :: halo_up
-    INTEGER                           :: halo_down
-    INTEGER                           :: ll
-        
-    
-    halo_up=0
-    halo_down=0
-    IF (PRESENT(up))   halo_up=up
-    IF (PRESENT(down)) halo_down=down
-    
-    ll=size(FieldS,3)
-    
-    CALL  Register_SwapField_gen_v(FieldS,FieldR,ll,old_dist,new_dist,halo_up,halo_down,a_request)
-    
-  END SUBROUTINE  Register_SwapField2d_v2d_bis
-   
-
-  SUBROUTINE Register_SwapField3d_v2d(FieldS,FieldR,new_dist,a_request,up,down)
-  USE parallel_lmdz
-  USE dimensions_mod
-      IMPLICIT NONE
-    
-    TYPE(distrib),INTENT(IN)          :: new_dist
-    REAL, DIMENSION(current_dist%jjb_v:,:,:,:),INTENT(IN)     :: FieldS
-    REAL, DIMENSION(new_dist%jjb_v:,:,:,:),INTENT(OUT)    :: FieldR
-    INTEGER,OPTIONAL,INTENT(IN)       :: up
-    INTEGER,OPTIONAL,INTENT(IN)       :: down      
-    TYPE(request),INTENT(INOUT)         :: a_request
-
-    INTEGER                           :: halo_up
-    INTEGER                           :: halo_down
-    INTEGER                           :: ll
-        
-    
-    halo_up=0
-    halo_down=0
-    IF (PRESENT(up))   halo_up=up
-    IF (PRESENT(down)) halo_down=down
-    
-    ll=size(FieldS,3)*size(FieldS,4)
-    
-    CALL  Register_SwapField_gen_v(FieldS,FieldR,ll,current_dist,new_dist,halo_up,halo_down,a_request)
-    
-  END SUBROUTINE  Register_SwapField3d_v2d 
-  
-  SUBROUTINE Register_SwapField3d_v2d_bis(FieldS,FieldR,new_dist,a_request,old_dist,up,down)
-  USE parallel_lmdz
-  USE dimensions_mod
-      IMPLICIT NONE
-    
-    TYPE(distrib),INTENT(IN)          :: new_dist
-    TYPE(distrib),INTENT(IN) :: old_dist
-    REAL, DIMENSION(old_dist%jjb_v:,:,:,:),INTENT(IN)     :: FieldS
-    REAL, DIMENSION(new_dist%jjb_v:,:,:,:),INTENT(OUT)    :: FieldR
-    INTEGER,OPTIONAL,INTENT(IN)       :: up
-    INTEGER,OPTIONAL,INTENT(IN)       :: down      
-    TYPE(request),INTENT(INOUT)         :: a_request
-
-    INTEGER                           :: halo_up
-    INTEGER                           :: halo_down
-    INTEGER                           :: ll
-        
-    
-    halo_up=0
-    halo_down=0
-    IF (PRESENT(up))   halo_up=up
-    IF (PRESENT(down)) halo_down=down
-    
-    ll=size(FieldS,3)*size(FieldS,4)
-    
-    CALL  Register_SwapField_gen_v(FieldS,FieldR,ll,old_dist,new_dist,halo_up,halo_down,a_request)
-    
-  END SUBROUTINE  Register_SwapField3d_v2d_bis 
-  
-  
-
-  SUBROUTINE Register_SwapField_gen_u(FieldS,FieldR,ll,old_dist,new_dist,Up,Down,a_request)
-  USE parallel_lmdz
-  USE dimensions_mod
-      IMPLICIT NONE
-   
-    INTEGER :: ll,Up,Down
-    TYPE(distrib)  :: old_dist
-    TYPE(distrib)  :: new_dist
-    REAL, DIMENSION(old_dist%ijb_u:old_dist%ije_u,ll) :: FieldS
-    REAL, DIMENSION(new_dist%ijb_u:new_dist%ije_u,ll) :: FieldR
-    TYPE(request) :: a_request
-    INTEGER,DIMENSION(0:MPI_Size-1) :: jj_Nb_New   
-    INTEGER,DIMENSION(0:MPI_Size-1) :: jj_Begin_New,jj_End_New
-    
-    INTEGER ::i,l,jje,jjb,ijb,ije
-    
-    DO i=0,MPI_Size-1
-      jj_begin_New(i)=max(1,new_dist%jj_begin_para(i)-Up)
-      jj_end_New(i)=min(jjp1,new_dist%jj_end_para(i)+Down)
-    ENDDO
-   
-    DO i=0,MPI_Size-1
-      IF (i /= MPI_Rank) THEN
-        jjb=max(jj_begin_new(i),old_dist%jj_begin)
-        jje=min(jj_end_new(i),old_dist%jj_end)
-        
-        IF (jje >= jjb) THEN
-          CALL Register_SendField(FieldS,old_dist%ijnb_u,ll,jjb-old_dist%jjb_u+1,jje-jjb+1,i,a_request) 
-        ENDIF
-        
-        jjb=max(jj_begin_new(MPI_Rank),old_dist%jj_begin_Para(i))
-        jje=min(jj_end_new(MPI_Rank),old_dist%jj_end_Para(i))
-        
-        IF (jje >= jjb) THEN
-          CALL Register_RecvField(FieldR,new_dist%ijnb_u,ll,jjb-new_dist%jjb_u+1,jje-jjb+1,i,a_request) 
-        ENDIF
-      ELSE
-        jjb=max(jj_begin_new(i),old_dist%jj_begin)
-        jje=min(jj_end_new(i),old_dist%jj_end)
-        ijb=(jjb-1)*iip1+1
-        ije=jje*iip1
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)           
-        DO l=1,ll
-          FieldR(ijb:ije,l)=FieldS(ijb:ije,l)              
-        ENDDO
-!$OMP END DO NOWAIT
-      ENDIF
-    ENDDO
-    
-  END SUBROUTINE Register_SwapField_gen_u
-
-
-
-  SUBROUTINE Register_SwapField_gen_v(FieldS,FieldR,ll,old_dist,new_dist,Up,Down,a_request)
-  USE parallel_lmdz
-  USE dimensions_mod
-    IMPLICIT NONE
-    
-    INTEGER :: ll,Up,Down
-    TYPE(distrib)  :: old_dist
-    TYPE(distrib)  :: new_dist
-    REAL, DIMENSION(old_dist%ijb_v:old_dist%ije_v,ll) :: FieldS
-    REAL, DIMENSION(new_dist%ijb_v:new_dist%ije_v,ll) :: FieldR
-    TYPE(request) :: a_request
-    INTEGER,DIMENSION(0:MPI_Size-1) :: jj_Nb_New   
-    INTEGER,DIMENSION(0:MPI_Size-1) :: jj_Begin_New,jj_End_New
-    
-    INTEGER ::i,l,jje,jjb,ijb,ije
-    
-    DO i=0,MPI_Size-1
-      jj_begin_New(i)=max(1,new_dist%jj_begin_para(i)-Up)
-      jj_end_New(i)=min(jjp1,new_dist%jj_end_para(i)+Down)
-    ENDDO
-   
-    DO i=0,MPI_Size-1
-      IF (i /= MPI_Rank) THEN
-        jjb=max(jj_begin_new(i),old_dist%jj_begin)
-        jje=min(jj_end_new(i),old_dist%jj_end)
-
-        IF (jje==jjp1) jje=jjm        
-
-        IF (jje >= jjb) THEN
-          CALL Register_SendField(FieldS,old_dist%ijnb_v,ll,jjb-old_dist%jjb_v+1,jje-jjb+1,i,a_request) 
-        ENDIF
-        
-        jjb=max(jj_begin_new(MPI_Rank),old_dist%jj_begin_Para(i))
-        jje=min(jj_end_new(MPI_Rank),old_dist%jj_end_Para(i))
-
-        IF (jje==jjp1) jje=jjm
-        
-        IF (jje >= jjb) THEN
-          CALL Register_RecvField(FieldR,new_dist%ijnb_v,ll,jjb-new_dist%jjb_v+1,jje-jjb+1,i,a_request) 
-        ENDIF
-      ELSE
-        jjb=max(jj_begin_new(i),old_dist%jj_begin)
-        jje=min(jj_end_new(i),old_dist%jj_end)
-        IF (jje==jjp1) jje=jjm
-        ijb=(jjb-1)*iip1+1
-        ije=jje*iip1
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)           
-        DO l=1,ll
-          FieldR(ijb:ije,l)=FieldS(ijb:ije,l)
-        ENDDO              
-!$OMP END DO NOWAIT
-      ENDIF
-    ENDDO
-    
-  END SUBROUTINE Register_SwapField_gen_v
-
-
- 
-
-  
-  subroutine Register_Hallo(Field,ij,ll,RUp,Rdown,SUp,SDown,a_request)
-  USE dimensions_mod
-  USE lmdz_mpi
-      implicit none
-
-      INTEGER :: ij,ll
-      REAL, dimension(ij,ll) :: Field
-      INTEGER :: Sup,Sdown,rup,rdown
-      type(request) :: a_request
-      type(Hallo),pointer :: PtrHallo
-      LOGICAL :: SendUp,SendDown
-      LOGICAL :: RecvUp,RecvDown
-   
- 
-      SendUp=.TRUE.
-      SendDown=.TRUE.
-      RecvUp=.TRUE.
-      RecvDown=.TRUE.
-        
-      IF (pole_nord) THEN
-        SendUp=.FALSE.
-        RecvUp=.FALSE.
-      ENDIF
-  
-      IF (pole_sud) THEN
-        SendDown=.FALSE.
-        RecvDown=.FALSE.
-      ENDIF
-      
-      if (Sup.eq.0) then
-        SendUp=.FALSE.
-       endif
-      
-      if (Sdown.eq.0) then
-        SendDown=.FALSE.
-      endif
-
-      if (Rup.eq.0) then
-        RecvUp=.FALSE.
-      endif
-      
-      if (Rdown.eq.0) then
-        RecvDown=.FALSE.
-      endif
-      
-      IF (SendUp) THEN
-        call Register_SendField(Field,ij,ll,jj_begin,SUp,MPI_Rank-1,a_request)
-      ENDIF
-  
-      IF (SendDown) THEN
-        call Register_SendField(Field,ij,ll,jj_end-SDown+1,SDown,MPI_Rank+1,a_request)
-      ENDIF
-    
-  
-      IF (RecvUp) THEN
-        call Register_RecvField(Field,ij,ll,jj_begin-Rup,RUp,MPI_Rank-1,a_request)
-      ENDIF
-  
-      IF (RecvDown) THEN
-        call Register_RecvField(Field,ij,ll,jj_end+1,RDown,MPI_Rank+1,a_request)
-      ENDIF
-  
-    end subroutine Register_Hallo
-
-
-  subroutine Register_Hallo_u(Field,ll,RUp,Rdown,SUp,SDown,a_request)
-  USE dimensions_mod
-  USE lmdz_mpi
-      implicit none
-      INTEGER :: ll
-      REAL, dimension(ijb_u:ije_u,ll) :: Field
-      INTEGER :: Sup,Sdown,rup,rdown
-      type(request) :: a_request
-      type(Hallo),pointer :: PtrHallo
-      LOGICAL :: SendUp,SendDown
-      LOGICAL :: RecvUp,RecvDown
-   
- 
-      SendUp=.TRUE.
-      SendDown=.TRUE.
-      RecvUp=.TRUE.
-      RecvDown=.TRUE.
-        
-      IF (pole_nord) THEN
-        SendUp=.FALSE.
-        RecvUp=.FALSE.
-      ENDIF
-  
-      IF (pole_sud) THEN
-        SendDown=.FALSE.
-        RecvDown=.FALSE.
-      ENDIF
-      
-      if (Sup.eq.0) then
-        SendUp=.FALSE.
-       endif
-      
-      if (Sdown.eq.0) then
-        SendDown=.FALSE.
-      endif
-
-      if (Rup.eq.0) then
-        RecvUp=.FALSE.
-      endif
-      
-      if (Rdown.eq.0) then
-        RecvDown=.FALSE.
-      endif
-      
-      IF (SendUp) THEN
-        call Register_SendField(Field,ijnb_u,ll,jj_begin-jjb_u+1,SUp,MPI_Rank-1,a_request)
-      ENDIF
-  
-      IF (SendDown) THEN
-        call Register_SendField(Field,ijnb_u,ll,jj_end-SDown+1-jjb_u+1,SDown,MPI_Rank+1,a_request)
-      ENDIF
-    
-  
-      IF (RecvUp) THEN
-        call Register_RecvField(Field,ijnb_u,ll,jj_begin-Rup-jjb_u+1,RUp,MPI_Rank-1,a_request)
-      ENDIF
-  
-      IF (RecvDown) THEN
-        call Register_RecvField(Field,ijnb_u,ll,jj_end+1-jjb_u+1,RDown,MPI_Rank+1,a_request)
-      ENDIF
-  
-    end subroutine Register_Hallo_u
-
-  subroutine Register_Hallo_v(Field,ll,RUp,Rdown,SUp,SDown,a_request)
-  USE dimensions_mod
-  USE lmdz_mpi
-      implicit none
-      INTEGER :: ll
-      REAL, dimension(ijb_v:ije_v,ll) :: Field
-      INTEGER :: Sup,Sdown,rup,rdown
-      type(request) :: a_request
-      type(Hallo),pointer :: PtrHallo
-      LOGICAL :: SendUp,SendDown
-      LOGICAL :: RecvUp,RecvDown
-   
- 
-      SendUp=.TRUE.
-      SendDown=.TRUE.
-      RecvUp=.TRUE.
-      RecvDown=.TRUE.
-        
-      IF (pole_nord) THEN
-        SendUp=.FALSE.
-        RecvUp=.FALSE.
-      ENDIF
-  
-      IF (pole_sud) THEN
-        SendDown=.FALSE.
-        RecvDown=.FALSE.
-      ENDIF
-      
-      if (Sup.eq.0) then
-        SendUp=.FALSE.
-       endif
-      
-      if (Sdown.eq.0) then
-        SendDown=.FALSE.
-      endif
-
-      if (Rup.eq.0) then
-        RecvUp=.FALSE.
-      endif
-      
-      if (Rdown.eq.0) then
-        RecvDown=.FALSE.
-      endif
-      
-      IF (SendUp) THEN
-        call Register_SendField(Field,ijnb_v,ll,jj_begin-jjb_v+1,SUp,MPI_Rank-1,a_request)
-      ENDIF
-  
-      IF (SendDown) THEN
-        call Register_SendField(Field,ijnb_v,ll,jj_end-SDown+1-jjb_v+1,SDown,MPI_Rank+1,a_request)
-      ENDIF
-    
-  
-      IF (RecvUp) THEN
-        call Register_RecvField(Field,ijnb_v,ll,jj_begin-Rup-jjb_v+1,RUp,MPI_Rank-1,a_request)
-      ENDIF
-  
-      IF (RecvDown) THEN
-        call Register_RecvField(Field,ijnb_v,ll,jj_end+1-jjb_v+1,RDown,MPI_Rank+1,a_request)
-      ENDIF
-  
-    end subroutine Register_Hallo_v
-    
-    subroutine SendRequest(a_Request)
-    USE dimensions_mod
-    USE lmdz_mpi
-      implicit none
-
-      type(request),target :: a_request
-      type(request_SR),pointer :: Req
-      type(Hallo),pointer :: PtrHallo
-      integer :: SizeBuffer
-      integer :: i,rank,l,ij,Pos,ierr
-      integer :: offset
-      real,dimension(:,:),pointer :: Field
-      integer :: Nb
-       
-      do rank=0,MPI_SIZE-1
-      
-        Req=>a_Request%RequestSend(rank)
-        
-        SizeBuffer=0
-        do i=1,Req%NbRequest
-          PtrHallo=>Req%Hallo(i)
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 
-          DO l=1,PtrHallo%NbLevel
-            SizeBuffer=SizeBuffer+PtrHallo%size*iip1
-          ENDDO
-!$OMP ENDDO NOWAIT          
-        enddo
-      
-         Req%BufferSize=SizeBuffer
-         if (Req%NbRequest>0) then
-       
-          call allocate_buffer(SizeBuffer,Req%Index,Req%pos)
-
-          Pos=Req%Pos
-          do i=1,Req%NbRequest
-            PtrHallo=>Req%Hallo(i)
-            offset=(PtrHallo%offset-1)*iip1+1
-            Nb=iip1*PtrHallo%size-1
-            Field=>PtrHallo%Field
-
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)           
-            do l=1,PtrHallo%NbLevel
-!cdir NODEP
-              do ij=0,Nb
-	        Buffer(Pos+ij)=Field(Offset+ij,l)
-	      enddo
-              
-              Pos=Pos+Nb+1
-            enddo
-!$OMP END DO NOWAIT            
-          enddo
-    
-         if (SizeBuffer>0) then
-!$OMP CRITICAL (MPI)
-         
-         call MPI_ISEND(Buffer(req%Pos),SizeBuffer,MPI_REAL_LMDZ,rank,a_request%tag+1000*omp_rank,     &
-                         COMM_LMDZ,Req%MSG_Request,ierr)
-         IF (.NOT.using_mpi) THEN
-           PRINT *,'Erreur, echange MPI en mode sequentiel !!!'
-           CALL abort_gcm("mod_hallo","stopped",1)
-         ENDIF
-!         PRINT *,"-------------------------------------------------------------------"
-!         PRINT *,"Process de rang",mpi_rank,"Task : ",omp_rank,"--->"
-!         PRINT *,"Requete envoye au proc :",rank,"tag :",a_request%tag+1000*omp_rank
-!         PRINT *,"Taille du message :",SizeBuffer,"requete no :",Req%MSG_Request
-!         PRINT *,"-------------------------------------------------------------------"
-!$OMP END CRITICAL (MPI)
-        endif
-       endif
-    enddo
-   
-           
-      do rank=0,MPI_SIZE-1
-         
-          Req=>a_Request%RequestRecv(rank)
-          SizeBuffer=0
-          
-	  do i=1,Req%NbRequest
-            PtrHallo=>Req%Hallo(i)
-
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 
-            DO l=1,PtrHallo%NbLevel
-              SizeBuffer=SizeBuffer+PtrHallo%size*iip1
-            ENDDO
-!$OMP ENDDO NOWAIT          
-          enddo
-          
-          Req%BufferSize=SizeBuffer
-          
-          if (Req%NbRequest>0) then
-          call allocate_buffer(SizeBuffer,Req%Index,Req%Pos)
-   
-          if (SizeBuffer>0) then
-
-!$OMP CRITICAL (MPI)
-
-             call MPI_IRECV(Buffer(Req%Pos),SizeBuffer,MPI_REAL_LMDZ,rank,a_request%tag+1000*omp_rank,     &
-                           COMM_LMDZ,Req%MSG_Request,ierr)
-
-             IF (.NOT.using_mpi) THEN
-               PRINT *,'Erreur, echange MPI en mode sequentiel !!!'
-               CALL abort_gcm("mod_hallo","stopped",1)
-             ENDIF
-
-!         PRINT *,"-------------------------------------------------------------------"
-!         PRINT *,"Process de rang",mpi_rank,"Task : ",omp_rank,"--->"
-!         PRINT *,"Requete en attente du proc :",rank,"tag :",a_request%tag+1000*omp_rank
-!         PRINT *,"Taille du message :",SizeBuffer,"requete no :",Req%MSG_Request
-!         PRINT *,"-------------------------------------------------------------------"
-
-!$OMP END CRITICAL (MPI)
-          endif
-        endif
-      
-      enddo
-                        
-   end subroutine SendRequest 
-   
-   subroutine WaitRequest(a_Request)
-   USE dimensions_mod
-   USE lmdz_mpi
-   implicit none
-      
-      type(request),target :: a_request
-      type(request_SR),pointer :: Req
-      type(Hallo),pointer :: PtrHallo
-      integer, dimension(2*mpi_size) :: TabRequest
-      integer, dimension(MPI_STATUS_SIZE,2*mpi_size) :: TabStatus
-      integer :: NbRequest
-      integer :: i,rank,pos,ij,l,ierr
-      integer :: offset
-      integer :: Nb
-      
-      
-      NbRequest=0
-      do rank=0,MPI_SIZE-1
-        Req=>a_request%RequestSend(rank)
-        if (Req%NbRequest>0 .AND. Req%BufferSize > 0) then
-          NbRequest=NbRequest+1
-          TabRequest(NbRequest)=Req%MSG_Request
-        endif
-      enddo
-      
-      do rank=0,MPI_SIZE-1
-        Req=>a_request%RequestRecv(rank)
-        if (Req%NbRequest>0 .AND. Req%BufferSize > 0 ) then
-          NbRequest=NbRequest+1
-          TabRequest(NbRequest)=Req%MSG_Request
-        endif
-      enddo
-     
-      if (NbRequest>0) then
-!$OMP CRITICAL (MPI)
-!        PRINT *,"-------------------------------------------------------------------"
-!        PRINT *,"Process de rang",mpi_rank,"Task : ",omp_rank,"--->",NbRequest,"en attente"
-!        PRINT *,"No des requetes :",TabRequest(1:NbRequest)
-        call MPI_WAITALL(NbRequest,TabRequest,TabStatus,ierr)
-!        PRINT *,"Process de rang",mpi_rank,"Task : ",omp_rank,"--->",NbRequest,"complete"
-!        PRINT *,"-------------------------------------------------------------------"
-!$OMP END CRITICAL (MPI)
-      endif
-      do rank=0,MPI_Size-1
-        Req=>a_request%RequestRecv(rank)
-        if (Req%NbRequest>0) then
-          Pos=Req%Pos
-          do i=1,Req%NbRequest
-            PtrHallo=>Req%Hallo(i)
-            offset=(PtrHallo%offset-1)*iip1+1
-	    Nb=iip1*PtrHallo%size-1
-
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)            
-	    do l=1,PtrHallo%NbLevel
-!cdir NODEP
-              do ij=0,Nb
-	        PtrHallo%Field(offset+ij,l)=Buffer(Pos+ij)
-	      enddo
-
-              Pos=Pos+Nb+1
-	    enddo
-!$OMP ENDDO NOWAIT	    
-          enddo
-        endif
-      enddo
-      
-      do rank=0,MPI_SIZE-1
-        Req=>a_request%RequestSend(rank)
-        if (Req%NbRequest>0) then
-          call deallocate_buffer(Req%Index)
-          Req%NbRequest=0 
-        endif
-      enddo
-              
-      do rank=0,MPI_SIZE-1
-        Req=>a_request%RequestRecv(rank)
-        if (Req%NbRequest>0) then
-          call deallocate_buffer(Req%Index)
-          Req%NbRequest=0 
-        endif
-      enddo
-     
-      a_request%tag=1
-    end subroutine WaitRequest
-     
-   subroutine WaitSendRequest(a_Request)
-   USE lmdz_mpi
-   USE dimensions_mod
-   implicit none
-   
-      type(request),target :: a_request
-      type(request_SR),pointer :: Req
-      type(Hallo),pointer :: PtrHallo
-      integer, dimension(mpi_size) :: TabRequest
-      integer, dimension(MPI_STATUS_SIZE,mpi_size) :: TabStatus
-      integer :: NbRequest
-      integer :: i,rank,pos,ij,l,ierr
-      integer :: offset
-      
-      
-      NbRequest=0
-      do rank=0,MPI_SIZE-1
-        Req=>a_request%RequestSend(rank)
-        if (Req%NbRequest>0) then
-          NbRequest=NbRequest+1
-          TabRequest(NbRequest)=Req%MSG_Request
-        endif
-      enddo
-      
-
-      if (NbRequest>0 .AND. Req%BufferSize > 0 ) THEN 
-!$OMP CRITICAL (MPI)     
-!        PRINT *,"-------------------------------------------------------------------"
-!        PRINT *,"Process de rang",mpi_rank,"Task : ",omp_rank,"--->",NbRequest,"en attente"
-!        PRINT *,"No des requetes :",TabRequest(1:NbRequest)
-         call MPI_WAITALL(NbRequest,TabRequest,TabStatus,ierr)
-!        PRINT *,"Process de rang",mpi_rank,"Task : ",omp_rank,"--->",NbRequest,"complete"
-!        PRINT *,"-------------------------------------------------------------------"
-
-!$OMP END CRITICAL (MPI)
-      endif      
-      
-      do rank=0,MPI_SIZE-1
-        Req=>a_request%RequestSend(rank)
-        if (Req%NbRequest>0) then
-          call deallocate_buffer(Req%Index)
-          Req%NbRequest=0 
-        endif
-      enddo
-              
-      a_request%tag=1
-    end subroutine WaitSendRequest
-    
-   subroutine WaitRecvRequest(a_Request)
-   USE dimensions_mod
-   USE lmdz_mpi
-   implicit none
-      type(request),target :: a_request
-      type(request_SR),pointer :: Req
-      type(Hallo),pointer :: PtrHallo
-      integer, dimension(mpi_size) :: TabRequest
-      integer, dimension(MPI_STATUS_SIZE,mpi_size) :: TabStatus
-      integer :: NbRequest
-      integer :: i,rank,pos,ij,l,ierr
-      integer :: offset,Nb
-      
-      
-      NbRequest=0
-      
-      do rank=0,MPI_SIZE-1
-        Req=>a_request%RequestRecv(rank)
-        if (Req%NbRequest>0 .AND. Req%BufferSize > 0 ) then
-          NbRequest=NbRequest+1
-          TabRequest(NbRequest)=Req%MSG_Request
-        endif
-      enddo
-     
-      
-      if (NbRequest>0) then
-!$OMP CRITICAL (MPI)     
-!        PRINT *,"-------------------------------------------------------------------"
-!        PRINT *,"Process de rang",mpi_rank,"Task : ",omp_rank,"--->",NbRequest,"en attente"
-!        PRINT *,"No des requetes :",TabRequest(1:NbRequest)
-         call MPI_WAITALL(NbRequest,TabRequest,TabStatus,ierr)
-!        PRINT *,"Process de rang",mpi_rank,"Task : ",omp_rank,"--->",NbRequest,"complete"
-!        PRINT *,"-------------------------------------------------------------------"
-!$OMP END CRITICAL (MPI)     
-      endif
-      
-      do rank=0,MPI_Size-1
-        Req=>a_request%RequestRecv(rank)
-        if (Req%NbRequest>0) then
-          Pos=Req%Pos
-          do i=1,Req%NbRequest
-            PtrHallo=>Req%Hallo(i)
-            offset=(PtrHallo%offset-1)*iip1+1
-	    Nb=iip1*PtrHallo%size-1
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)            
-	    do l=1,PtrHallo%NbLevel
-!cdir NODEP
-              do ij=0,Nb
-	        PtrHallo%Field(offset+ij,l)=Buffer(Pos+ij)
-	      enddo
-                 Pos=Pos+Nb+1
-            enddo
-!$OMP END DO NOWAIT
-          enddo
-        endif
-      enddo
-      
-           
-      do rank=0,MPI_SIZE-1
-        Req=>a_request%RequestRecv(rank)
-        if (Req%NbRequest>0) then
-          call deallocate_buffer(Req%Index)
-          Req%NbRequest=0 
-        endif
-      enddo
-     
-      a_request%tag=1
-    end subroutine WaitRecvRequest
-    
-    
-    
-    subroutine CopyField(FieldS,FieldR,ij,ll,jj_Nb_New)
-    USE dimensions_mod
-  
-      implicit none
-    
-    INTEGER :: ij,ll,l
-    REAL, dimension(ij,ll) :: FieldS
-    REAL, dimension(ij,ll) :: FieldR
-    integer,dimension(0:MPI_Size-1) :: jj_Nb_New   
-    integer,dimension(0:MPI_Size-1) :: jj_Begin_New,jj_End_New
-    
-    integer ::i,jje,jjb,ijb,ije
-    
-    jj_begin_New(0)=1
-    jj_End_New(0)=jj_Nb_New(0)
-    do i=1,MPI_Size-1
-      jj_begin_New(i)=jj_end_New(i-1)+1
-      jj_end_New(i)=jj_begin_new(i)+jj_Nb_New(i)-1
-    enddo
-    
-    jjb=max(jj_begin,jj_begin_new(MPI_Rank))
-    jje=min(jj_end,jj_end_new(MPI_Rank))
-    if (ij==ip1jm) jje=min(jje,jjm)
-
-    if (jje >= jjb) then
-      ijb=(jjb-1)*iip1+1
-      ije=jje*iip1
-
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-      do l=1,ll
-        FieldR(ijb:ije,l)=FieldS(ijb:ije,l)
-      enddo
-!$OMP ENDDO NOWAIT
-    endif
-
-
-  end subroutine CopyField    
-
-  subroutine CopyFieldHallo(FieldS,FieldR,ij,ll,jj_Nb_New,Up,Down)
-  USE dimensions_mod
-  
-      implicit none
-    
-    INTEGER :: ij,ll,Up,Down
-    REAL, dimension(ij,ll) :: FieldS
-    REAL, dimension(ij,ll) :: FieldR
-    integer,dimension(0:MPI_Size-1) :: jj_Nb_New   
-    integer,dimension(0:MPI_Size-1) :: jj_Begin_New,jj_End_New
-
-    integer ::i,jje,jjb,ijb,ije,l
-
-     
-    jj_begin_New(0)=1
-    jj_End_New(0)=jj_Nb_New(0)
-    do i=1,MPI_Size-1
-      jj_begin_New(i)=jj_end_New(i-1)+1
-      jj_end_New(i)=jj_begin_new(i)+jj_Nb_New(i)-1
-    enddo
-
-        
-    jjb=max(jj_begin,jj_begin_new(MPI_Rank)-Up)
-    jje=min(jj_end,jj_end_new(MPI_Rank)+Down)
-    if (ij==ip1jm) jje=min(jje,jjm)
-    
-    
-    if (jje >= jjb) then
-      ijb=(jjb-1)*iip1+1
-      ije=jje*iip1
-
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-      do l=1,ll
-        FieldR(ijb:ije,l)=FieldS(ijb:ije,l)
-      enddo
-!$OMP ENDDO NOWAIT
-
-    endif
-   end subroutine CopyFieldHallo        
-
-   subroutine Gather_field_u(field_loc,field_glo,ll)
-   USE dimensions_mod
-   implicit none
-     integer :: ll
-     real :: field_loc(ijb_u:ije_u,ll)
-     real :: field_glo(ip1jmp1,ll)
-     type(request) :: request_gather
-     integer       :: l
-
-
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-     DO l=1,ll
-       field_glo(ij_begin:ij_end,l)=field_loc(ij_begin:ij_end,l)
-     ENDDO
-     
-     call register_SwapField(field_glo,field_glo,ip1jmp1,ll,distrib_gather%jj_nb_para,request_gather)
-     call SendRequest(request_gather)
-!$OMP BARRIER
-     call WaitRequest(request_gather)       
-!$OMP BARRIER
-
-    end subroutine Gather_field_u
-        
-   subroutine Gather_field_v(field_loc,field_glo,ll)
-   USE dimensions_mod
-   implicit none
-     integer :: ll
-     real :: field_loc(ijb_v:ije_v,ll)
-     real :: field_glo(ip1jm,ll)
-     type(request) :: request_gather
-     integer :: ijb,ije
-     integer       :: l
-     
-   
-     ijb=ij_begin
-     ije=ij_end
-     if (pole_sud) ije=ij_end-iip1
-        
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-     DO l=1,ll
-       field_glo(ijb:ije,l)=field_loc(ijb:ije,l)
-     ENDDO
-     
-     call register_SwapField(field_glo,field_glo,ip1jm,ll,distrib_gather%jj_nb_para,request_gather)
-     call SendRequest(request_gather)
-!$OMP BARRIER
-     call WaitRequest(request_gather)       
-!$OMP BARRIER
-
-    end subroutine Gather_field_v
-     
-   subroutine Scatter_field_u(field_glo,field_loc,ll)
-   USE dimensions_mod
-   implicit none
-     integer :: ll
-     real :: field_glo(ip1jmp1,ll)
-     real :: field_loc(ijb_u:ije_u,ll)
-     type(request) :: request_gather
-     TYPE(distrib) :: distrib_swap
-     integer       :: l
-     
-!$OMP BARRIER
-!$OMP MASTER     
-     call get_current_distrib(distrib_swap)
-     call set_Distrib(distrib_gather)
-!$OMP END MASTER
-!$OMP BARRIER
- 
-     call register_SwapField(field_glo,field_glo,ip1jmp1,ll,distrib_swap%jj_nb_para,request_gather)
-     call SendRequest(request_gather)
-!$OMP BARRIER
-     call WaitRequest(request_gather)       
-!$OMP BARRIER
-!$OMP MASTER     
-     call set_Distrib(distrib_swap)
-!$OMP END MASTER
-!$OMP BARRIER
-
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-       DO l=1,ll
-         field_loc(ij_begin:ij_end,l)=field_glo(ij_begin:ij_end,l)
-       ENDDO
-
-    end subroutine Scatter_field_u
-
-   subroutine Scatter_field_v(field_glo,field_loc,ll)
-   USE dimensions_mod
-   implicit none
-     integer :: ll
-     real :: field_glo(ip1jmp1,ll)
-     real :: field_loc(ijb_v:ije_v,ll)
-     type(request) :: request_gather
-     TYPE(distrib) :: distrib_swap
-     integer       :: ijb,ije,l
-     
-
-!$OMP BARRIER
-!$OMP MASTER     
-     call get_current_distrib(distrib_swap)
-     call set_Distrib(distrib_gather)
-!$OMP END MASTER
-!$OMP BARRIER
-     call register_SwapField(field_glo,field_glo,ip1jm,ll,distrib_swap%jj_nb_para,request_gather)
-     call SendRequest(request_gather)
-!$OMP BARRIER
-     call WaitRequest(request_gather)       
-!$OMP BARRIER
-!$OMP MASTER
-     call set_Distrib(distrib_swap)
-!$OMP END MASTER
-!$OMP BARRIER
-     ijb=ij_begin
-     ije=ij_end
-     if (pole_sud) ije=ij_end-iip1
-     
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-       DO l=1,ll
-         field_loc(ijb:ije,l)=field_glo(ijb:ije,l)
-       ENDDO
-
-    end subroutine Scatter_field_v
-              
-end module mod_Hallo 
-   
Index: /LMDZ6/trunk/libf/dyn3dmem/mod_hallo.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/mod_hallo.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3dmem/mod_hallo.f90	(revision 5268)
@@ -0,0 +1,1863 @@
+module mod_Hallo
+USE parallel_lmdz
+implicit none
+  logical,save :: use_mpi_alloc
+  integer, parameter :: MaxProc=512
+  integer, parameter :: DefaultMaxBufferSize=1024*1024*100
+  integer, SAVE :: MaxBufferSize=0
+  integer, parameter :: ListSize=1000
+  
+  integer,save       :: MaxBufferSize_Used
+!$OMP THREADPRIVATE( MaxBufferSize_Used)
+
+   real,save,pointer,dimension(:) :: Buffer
+!$OMP THREADPRIVATE(Buffer)
+
+   integer,save,dimension(Listsize) :: Buffer_Pos
+   integer,save :: Index_Pos
+!$OMP THREADPRIVATE(Buffer_Pos,Index_pos)
+   
+  type Hallo
+    real, dimension(:,:),pointer :: Field
+    integer :: offset
+    integer :: size
+    integer :: NbLevel
+    integer :: Stride
+  end type Hallo
+  
+  type request_SR
+    integer :: NbRequest=0
+    integer :: NbRequestMax=0
+    integer :: BufferSize
+    integer :: Pos
+    integer :: Index 
+    type(Hallo), POINTER :: Hallo(:)
+    integer :: MSG_Request
+  end type request_SR
+
+  type request
+    type(request_SR),dimension(0:MaxProc-1) :: RequestSend
+    type(request_SR),dimension(0:MaxProc-1) :: RequestRecv
+    integer :: tag=1
+  end type request
+  
+   TYPE(distrib),SAVE :: distrib_gather
+
+
+  INTERFACE Register_SwapField_u
+    MODULE PROCEDURE Register_SwapField1d_u,Register_SwapField2d_u1d,Register_SwapField3d_u, &
+                     Register_SwapField1d_u_bis,Register_SwapField2d_u1d_bis,Register_SwapField3d_u_bis
+  END INTERFACE Register_SwapField_u
+
+  INTERFACE Register_SwapField_v
+    MODULE PROCEDURE Register_SwapField1d_v,Register_SwapField2d_v1d,Register_SwapField3d_v,&
+                     Register_SwapField1d_v_bis,Register_SwapField2d_v1d_bis,Register_SwapField3d_v_bis
+  END INTERFACE Register_SwapField_v
+
+  INTERFACE Register_SwapField2d_u
+    MODULE PROCEDURE Register_SwapField1d_u2d,Register_SwapField2d_u2d,Register_SwapField3d_u2d, &
+                     Register_SwapField1d_u2d_bis,Register_SwapField2d_u2d_bis,Register_SwapField3d_u2d_bis
+  END INTERFACE Register_SwapField2d_u
+
+  INTERFACE Register_SwapField2d_v
+    MODULE PROCEDURE Register_SwapField1d_v2d,Register_SwapField2d_v2d,Register_SwapField3d_v2d, &
+                     Register_SwapField1d_v2d_bis,Register_SwapField2d_v2d_bis,Register_SwapField3d_v2d_bis
+  END INTERFACE Register_SwapField2d_v
+
+  contains
+
+  subroutine Init_mod_hallo
+  USE dimensions_mod
+  USE IOIPSL
+    implicit none
+    integer :: jj_nb_gather(0:mpi_size-1)
+    
+    Index_Pos=1
+    Buffer_Pos(Index_Pos)=1
+    MaxBufferSize_Used=0
+!$OMP MASTER     
+    MaxBufferSize=DefaultMaxBufferSize
+    CALL getin("mpi_buffer_size",MaxBufferSize)
+!$OMP END MASTER
+!$OMP BARRIER
+    
+    IF (use_mpi_alloc .AND. using_mpi) THEN
+      CALL create_global_mpi_buffer
+    ELSE 
+      CALL create_standard_mpi_buffer
+    ENDIF
+     
+!$OMP MASTER     
+     jj_nb_gather(:)=0
+     jj_nb_gather(0)=jjp1
+     
+     CALL create_distrib(jj_nb_gather,distrib_gather) 
+!$OMP END MASTER
+!$OMP BARRIER
+
+  end subroutine init_mod_hallo
+
+  SUBROUTINE create_standard_mpi_buffer
+  IMPLICIT NONE
+    
+    ALLOCATE(Buffer(MaxBufferSize))
+    
+  END SUBROUTINE create_standard_mpi_buffer
+  
+  SUBROUTINE create_global_mpi_buffer
+  USE lmdz_mpi
+  IMPLICIT NONE
+    POINTER (Pbuffer,MPI_Buffer(MaxBufferSize))
+    REAL :: MPI_Buffer
+    INTEGER(KIND=MPI_ADDRESS_KIND) :: BS 
+    INTEGER :: i,ierr
+
+!  Allocation du buffer MPI
+      Bs=8*MaxBufferSize
+!$OMP CRITICAL (MPI)
+      CALL MPI_ALLOC_MEM(BS,MPI_INFO_NULL,Pbuffer,ierr)
+!$OMP END CRITICAL (MPI)
+      DO i=1,MaxBufferSize
+	MPI_Buffer(i)=i
+      ENDDO
+     
+      CALL  Associate_buffer(MPI_Buffer)
+      
+  CONTAINS
+     
+     SUBROUTINE Associate_buffer(MPI_Buffer)
+     IMPLICIT NONE
+       REAL,DIMENSION(:),target :: MPI_Buffer  
+
+         Buffer=>MPI_Buffer
+ 
+      END SUBROUTINE  Associate_buffer
+                                      
+  END SUBROUTINE create_global_mpi_buffer
+ 
+      
+  subroutine allocate_buffer(Size,Index,Pos)
+  implicit none
+    integer :: Size
+    integer :: Index
+    integer :: Pos
+
+    if (Buffer_pos(Index_pos)+Size>MaxBufferSize_Used) MaxBufferSize_Used=Buffer_pos(Index_pos)+Size  
+    if (Buffer_pos(Index_pos)+Size>MaxBufferSize) then
+      print *,'STOP :: La taille de MaxBufferSize dans mod_hallo.F90 est trop petite !!!!'
+      CALL abort_gcm("mod_hallo","stopped",1)
+    endif
+    
+    if (Index_pos>=ListSize) then
+      print *,'STOP :: La taille de ListSize dans mod_hallo.F90 est trop petite !!!!'
+      CALL abort_gcm("mod_hallo","stopped",1)
+    endif
+     
+    Pos=Buffer_Pos(Index_Pos)
+    Buffer_Pos(Index_pos+1)=Buffer_Pos(Index_Pos)+Size
+    Index_Pos=Index_Pos+1
+    Index=Index_Pos
+    
+  end subroutine allocate_buffer
+     
+  subroutine deallocate_buffer(Index)
+  implicit none
+    integer :: Index
+    
+    Buffer_Pos(Index)=-1
+    
+    do while (Buffer_Pos(Index_Pos)==-1 .and. Index_Pos>1)
+      Index_Pos=Index_Pos-1
+    end do
+
+  end subroutine deallocate_buffer  
+  
+  subroutine SetTag(a_request,tag)
+  implicit none
+    type(request):: a_request
+    integer :: tag
+    
+    a_request%tag=tag
+  end subroutine SetTag
+  
+  
+  subroutine New_Hallo(Field,Stride,NbLevel,offset,size,Ptr_request)
+    integer :: Stride
+    integer :: NbLevel
+    integer :: size
+    integer :: offset
+    real, dimension(Stride,NbLevel),target :: Field
+    type(request_SR),pointer :: Ptr_request
+    type(Hallo),POINTER :: NewHallos(:),HalloSwitch(:), NewHallo
+    
+    Ptr_Request%NbRequest=Ptr_Request%NbRequest+1
+    IF(Ptr_Request%NbRequestMax==0) THEN
+       Ptr_Request%NbRequestMax=10
+       ALLOCATE(Ptr_Request%Hallo(Ptr_Request%NbRequestMax))
+    ELSE IF ( Ptr_Request%NbRequest > Ptr_Request%NbRequestMax) THEN
+      Ptr_Request%NbRequestMax=INT(Ptr_Request%NbRequestMax*1.2)
+      ALLOCATE(NewHallos(Ptr_Request%NbRequestMax))
+      NewHallos(1:Ptr_Request%NbRequest-1)=Ptr_Request%hallo(1:Ptr_Request%NbRequest-1)
+      HalloSwitch=>Ptr_Request%hallo
+      Ptr_Request%hallo=>NewHallos
+      DEALLOCATE(HalloSwitch)
+    ENDIF
+    
+    NewHallo=>Ptr_Request%hallo(Ptr_Request%NbRequest)
+          
+    NewHallo%Field=>Field
+    NewHallo%Stride=Stride
+    NewHallo%NbLevel=NbLevel
+    NewHallo%size=size
+    NewHallo%offset=offset
+    
+  end subroutine New_Hallo
+  
+  subroutine Register_SendField(Field,ij,ll,offset,size,target,a_request)
+  USE dimensions_mod
+  implicit none
+
+    
+      INTEGER :: ij,ll,offset,size,target
+      REAL, dimension(ij,ll) :: Field
+      type(request),target :: a_request
+      type(request_SR),pointer :: Ptr_request
+
+      Ptr_Request=>a_request%RequestSend(target)
+
+      call New_Hallo(Field,ij,ll,offset,size,Ptr_request)
+      
+   end subroutine Register_SendField      
+      
+  subroutine Register_RecvField(Field,ij,ll,offset,size,target,a_request)
+  USE dimensions_mod
+  implicit none
+
+   
+      INTEGER :: ij,ll,offset,size,target
+      REAL, dimension(ij,ll) :: Field
+      type(request),target :: a_request
+      type(request_SR),pointer :: Ptr_request
+
+      Ptr_Request=>a_request%RequestRecv(target)
+            
+      call New_Hallo(Field,ij,ll,offset,size,Ptr_request)
+
+      
+   end subroutine Register_RecvField      
+  
+  subroutine Register_SwapField(FieldS,FieldR,ij,ll,jj_Nb_New,a_request)
+  USE dimensions_mod
+      implicit none
+
+    
+    INTEGER :: ij,ll
+    REAL, dimension(ij,ll) :: FieldS
+    REAL, dimension(ij,ll) :: FieldR
+    type(request) :: a_request
+    integer,dimension(0:MPI_Size-1) :: jj_Nb_New   
+    integer,dimension(0:MPI_Size-1) :: jj_Begin_New,jj_End_New
+    
+    integer ::i,jje,jjb
+    
+    jj_begin_New(0)=1
+    jj_End_New(0)=jj_Nb_New(0)
+    do i=1,MPI_Size-1
+      jj_begin_New(i)=jj_end_New(i-1)+1
+      jj_end_New(i)=jj_begin_new(i)+jj_Nb_New(i)-1
+    enddo
+    
+    do i=0,MPI_Size-1
+      if (i /= MPI_Rank) then
+        jjb=max(jj_begin_new(i),jj_begin)
+        jje=min(jj_end_new(i),jj_end)
+        
+        if (ij==ip1jm .and. jje==jjp1) jje=jjm
+        
+        if (jje >= jjb) then
+          call Register_SendField(FieldS,ij,ll,jjb,jje-jjb+1,i,a_request) 
+        endif
+        
+        jjb=max(jj_begin_new(MPI_Rank),jj_begin_Para(i))
+        jje=min(jj_end_new(MPI_Rank),jj_end_Para(i))
+        
+        if (ij==ip1jm .and. jje==jjp1) jje=jjm
+        
+        if (jje >= jjb) then
+          call Register_RecvField(FieldR,ij,ll,jjb,jje-jjb+1,i,a_request) 
+        endif
+        
+      endif
+    enddo
+    
+  end subroutine Register_SwapField    
+  
+
+  
+  subroutine Register_SwapFieldHallo(FieldS,FieldR,ij,ll,jj_Nb_New,Up,Down,a_request)
+  USE dimensions_mod
+  
+      implicit none
+    
+    INTEGER :: ij,ll,Up,Down
+    REAL, dimension(ij,ll) :: FieldS
+    REAL, dimension(ij,ll) :: FieldR
+    type(request) :: a_request
+    integer,dimension(0:MPI_Size-1) :: jj_Nb_New   
+    integer,dimension(0:MPI_Size-1) :: jj_Begin_New,jj_End_New
+    
+    integer ::i,jje,jjb
+    
+    jj_begin_New(0)=1
+    jj_End_New(0)=jj_Nb_New(0)
+    do i=1,MPI_Size-1
+      jj_begin_New(i)=jj_end_New(i-1)+1
+      jj_end_New(i)=jj_begin_new(i)+jj_Nb_New(i)-1
+    enddo
+    
+    do i=0,MPI_Size-1
+      jj_begin_New(i)=max(1,jj_begin_New(i)-Up)
+      jj_end_New(i)=min(jjp1,jj_end_new(i)+Down)
+    enddo
+   
+    do i=0,MPI_Size-1
+      if (i /= MPI_Rank) then
+        jjb=max(jj_begin_new(i),jj_begin)
+        jje=min(jj_end_new(i),jj_end)
+        
+        if (ij==ip1jm .and. jje==jjp1) jje=jjm
+        
+        if (jje >= jjb) then
+          call Register_SendField(FieldS,ij,ll,jjb,jje-jjb+1,i,a_request) 
+        endif
+        
+        jjb=max(jj_begin_new(MPI_Rank),jj_begin_Para(i))
+        jje=min(jj_end_new(MPI_Rank),jj_end_Para(i))
+        
+        if (ij==ip1jm .and. jje==jjp1) jje=jjm
+        
+        if (jje >= jjb) then
+          call Register_RecvField(FieldR,ij,ll,jjb,jje-jjb+1,i,a_request) 
+        endif
+        
+      endif
+    enddo
+    
+  end subroutine Register_SwapFieldHallo
+
+
+
+  SUBROUTINE Register_SwapField1d_u(FieldS,FieldR,new_dist,a_request,up,down)
+  USE parallel_lmdz
+  USE dimensions_mod
+      IMPLICIT NONE
+    
+    TYPE(distrib),INTENT(IN)          :: new_dist
+    REAL, DIMENSION(current_dist%ijb_u:),INTENT(IN)     :: FieldS
+    REAL, DIMENSION(new_dist%ijb_u:),INTENT(OUT)    :: FieldR
+    INTEGER,OPTIONAL,INTENT(IN)       :: up
+    INTEGER,OPTIONAL,INTENT(IN)       :: down      
+    TYPE(request),INTENT(INOUT)         :: a_request
+
+    INTEGER                           :: halo_up
+    INTEGER                           :: halo_down
+    
+    
+    halo_up=0
+    halo_down=0
+    IF (PRESENT(up))   halo_up=up
+    IF (PRESENT(down)) halo_down=down
+
+    CALL  Register_SwapField_gen_u(FieldS,FieldR,1,current_dist,new_dist,halo_up,halo_down,a_request)
+        
+  END SUBROUTINE  Register_SwapField1d_u 
+
+  SUBROUTINE Register_SwapField1d_u_bis(FieldS,FieldR,new_dist,a_request,old_dist,up,down)
+  USE parallel_lmdz
+  USE dimensions_mod
+      IMPLICIT NONE
+    
+    TYPE(distrib),INTENT(IN)          :: new_dist
+    TYPE(distrib),INTENT(IN)          :: old_dist
+    REAL, DIMENSION(old_dist%ijb_u:),INTENT(IN)     :: FieldS
+    REAL, DIMENSION(new_dist%ijb_u:),INTENT(OUT)    :: FieldR
+    INTEGER,OPTIONAL,INTENT(IN)       :: up
+    INTEGER,OPTIONAL,INTENT(IN)       :: down      
+    TYPE(request),INTENT(INOUT)         :: a_request
+
+    INTEGER                           :: halo_up
+    INTEGER                           :: halo_down
+    
+    
+    halo_up=0
+    halo_down=0
+    IF (PRESENT(up))   halo_up=up
+    IF (PRESENT(down)) halo_down=down
+
+    CALL  Register_SwapField_gen_u(FieldS,FieldR,1,old_dist,new_dist,halo_up,halo_down,a_request)
+        
+  END SUBROUTINE  Register_SwapField1d_u_bis 
+
+
+  SUBROUTINE Register_SwapField2d_u1d(FieldS,FieldR,new_dist,a_request,up,down)
+  USE parallel_lmdz
+  USE dimensions_mod
+    IMPLICIT NONE
+    
+    TYPE(distrib),INTENT(IN)          :: new_dist
+    REAL, DIMENSION(current_dist%ijb_u:,:),INTENT(IN)     :: FieldS
+    REAL, DIMENSION(new_dist%ijb_u:,:),INTENT(OUT)    :: FieldR
+    INTEGER,OPTIONAL,INTENT(IN)       :: up
+    INTEGER,OPTIONAL,INTENT(IN)       :: down      
+    TYPE(request),INTENT(INOUT)         :: a_request
+
+    INTEGER                           :: halo_up
+    INTEGER                           :: halo_down
+    INTEGER                           :: ll
+        
+    
+    halo_up=0
+    halo_down=0
+    IF (PRESENT(up))   halo_up=up
+    IF (PRESENT(down)) halo_down=down
+    
+    ll=size(FieldS,2)
+    
+    CALL  Register_SwapField_gen_u(FieldS,FieldR,ll,current_dist,new_dist,halo_up,halo_down,a_request)
+    
+  END SUBROUTINE  Register_SwapField2d_u1d
+
+  SUBROUTINE Register_SwapField2d_u1d_bis(FieldS,FieldR,new_dist,a_request,old_dist,up,down)
+  USE parallel_lmdz
+  USE dimensions_mod
+    IMPLICIT NONE
+    
+    TYPE(distrib),INTENT(IN)          :: new_dist
+    TYPE(distrib),INTENT(IN) :: old_dist
+    REAL, DIMENSION(old_dist%ijb_u:,:),INTENT(IN)     :: FieldS
+    REAL, DIMENSION(new_dist%ijb_u:,:),INTENT(OUT)    :: FieldR
+    INTEGER,OPTIONAL,INTENT(IN)       :: up
+    INTEGER,OPTIONAL,INTENT(IN)       :: down      
+    TYPE(request),INTENT(INOUT)         :: a_request
+
+    INTEGER                           :: halo_up
+    INTEGER                           :: halo_down
+    INTEGER                           :: ll
+        
+    
+    halo_up=0
+    halo_down=0
+    IF (PRESENT(up))   halo_up=up
+    IF (PRESENT(down)) halo_down=down
+    
+    ll=size(FieldS,2)
+    
+    CALL  Register_SwapField_gen_u(FieldS,FieldR,ll,old_dist,new_dist,halo_up,halo_down,a_request)
+    
+  END SUBROUTINE  Register_SwapField2d_u1d_bis
+   
+
+  SUBROUTINE Register_SwapField3d_u(FieldS,FieldR,new_dist,a_request,up,down)
+  USE parallel_lmdz
+  USE dimensions_mod
+      IMPLICIT NONE
+    
+    TYPE(distrib),INTENT(IN)          :: new_dist
+    REAL, DIMENSION(current_dist%ijb_u:,:,:),INTENT(IN)     :: FieldS
+    REAL, DIMENSION(new_dist%ijb_u:,:,:),INTENT(OUT)    :: FieldR
+    INTEGER,OPTIONAL,INTENT(IN)       :: up
+    INTEGER,OPTIONAL,INTENT(IN)       :: down      
+    TYPE(request),INTENT(INOUT)         :: a_request
+
+    INTEGER                           :: halo_up
+    INTEGER                           :: halo_down
+    INTEGER                           :: ll
+        
+    
+    halo_up=0
+    halo_down=0
+    IF (PRESENT(up))   halo_up=up
+    IF (PRESENT(down)) halo_down=down
+    
+    ll=size(FieldS,2)*size(FieldS,3)
+    
+    CALL  Register_SwapField_gen_u(FieldS,FieldR,ll,current_dist,new_dist,halo_up,halo_down,a_request)
+    
+  END SUBROUTINE  Register_SwapField3d_u 
+
+  SUBROUTINE Register_SwapField3d_u_bis(FieldS,FieldR,new_dist,a_request,old_dist,up,down)
+  USE parallel_lmdz
+  USE dimensions_mod
+      IMPLICIT NONE
+    
+    TYPE(distrib),INTENT(IN)          :: new_dist
+    TYPE(distrib),INTENT(IN) :: old_dist
+    REAL, DIMENSION(old_dist%ijb_u:,:,:),INTENT(IN)     :: FieldS
+    REAL, DIMENSION(new_dist%ijb_u:,:,:),INTENT(OUT)    :: FieldR
+    INTEGER,OPTIONAL,INTENT(IN)       :: up
+    INTEGER,OPTIONAL,INTENT(IN)       :: down      
+    TYPE(request),INTENT(INOUT)         :: a_request
+
+    INTEGER                           :: halo_up
+    INTEGER                           :: halo_down
+    INTEGER                           :: ll
+        
+    
+    halo_up=0
+    halo_down=0
+    IF (PRESENT(up))   halo_up=up
+    IF (PRESENT(down)) halo_down=down
+    
+    ll=size(FieldS,2)*size(FieldS,3)
+    
+    CALL  Register_SwapField_gen_u(FieldS,FieldR,ll,old_dist,new_dist,halo_up,halo_down,a_request)
+    
+  END SUBROUTINE  Register_SwapField3d_u_bis 
+  
+
+
+ SUBROUTINE Register_SwapField1d_u2d(FieldS,FieldR,new_dist,a_request,up,down)
+  USE parallel_lmdz
+  USE dimensions_mod
+
+      IMPLICIT NONE
+
+    TYPE(distrib),INTENT(IN)          :: new_dist !LF
+    REAL, DIMENSION(current_dist%jjb_u:,:),INTENT(IN)     :: FieldS
+    REAL, DIMENSION(new_dist%jjb_u:,:),INTENT(OUT)    :: FieldR
+    INTEGER,OPTIONAL,INTENT(IN)       :: up
+    INTEGER,OPTIONAL,INTENT(IN)       :: down      
+    TYPE(request),INTENT(INOUT)         :: a_request
+
+    INTEGER                           :: halo_up
+    INTEGER                           :: halo_down
+    
+    
+    halo_up=0
+    halo_down=0
+    IF (PRESENT(up))   halo_up=up
+    IF (PRESENT(down)) halo_down=down
+
+    CALL  Register_SwapField_gen_u(FieldS,FieldR,1,current_dist,new_dist,halo_up,halo_down,a_request)
+        
+  END SUBROUTINE  Register_SwapField1d_u2d 
+
+ SUBROUTINE Register_SwapField1d_u2d_bis(FieldS,FieldR,new_dist,a_request,old_dist,up,down)
+  USE parallel_lmdz
+  USE dimensions_mod
+
+      IMPLICIT NONE
+
+    TYPE(distrib),INTENT(IN)          :: new_dist !LF
+    TYPE(distrib),INTENT(IN)          :: old_dist
+    REAL, DIMENSION(old_dist%jjb_u:,:),INTENT(IN)     :: FieldS
+    REAL, DIMENSION(new_dist%jjb_u:,:),INTENT(OUT)    :: FieldR
+    INTEGER,OPTIONAL,INTENT(IN)       :: up
+    INTEGER,OPTIONAL,INTENT(IN)       :: down      
+    TYPE(request),INTENT(INOUT)         :: a_request
+
+    INTEGER                           :: halo_up
+    INTEGER                           :: halo_down
+    
+    
+    halo_up=0
+    halo_down=0
+    IF (PRESENT(up))   halo_up=up
+    IF (PRESENT(down)) halo_down=down
+
+    CALL  Register_SwapField_gen_u(FieldS,FieldR,1,old_dist,new_dist,halo_up,halo_down,a_request)
+        
+  END SUBROUTINE  Register_SwapField1d_u2d_bis 
+
+
+  SUBROUTINE Register_SwapField2d_u2d(FieldS,FieldR,new_dist,a_request,up,down)
+  USE parallel_lmdz
+  USE dimensions_mod
+
+      IMPLICIT NONE
+    
+    TYPE(distrib),INTENT(IN)          :: new_dist
+    REAL, DIMENSION(current_dist%jjb_u:,:,:),INTENT(IN)     :: FieldS
+    REAL, DIMENSION(new_dist%jjb_u:,:,:),INTENT(OUT)    :: FieldR
+    INTEGER,OPTIONAL,INTENT(IN)       :: up
+    INTEGER,OPTIONAL,INTENT(IN)       :: down      
+    TYPE(request),INTENT(INOUT)         :: a_request
+
+    INTEGER                           :: halo_up
+    INTEGER                           :: halo_down
+    INTEGER                           :: ll
+        
+    
+    halo_up=0
+    halo_down=0
+    IF (PRESENT(up))   halo_up=up
+    IF (PRESENT(down)) halo_down=down
+    
+    ll=size(FieldS,3)
+    
+    CALL  Register_SwapField_gen_u(FieldS,FieldR,ll,current_dist,new_dist,halo_up,halo_down,a_request)
+    
+  END SUBROUTINE  Register_SwapField2d_u2d
+
+  SUBROUTINE Register_SwapField2d_u2d_bis(FieldS,FieldR,new_dist,a_request,old_dist,up,down)
+  USE parallel_lmdz
+  USE dimensions_mod
+
+      IMPLICIT NONE
+    
+    TYPE(distrib),INTENT(IN)          :: new_dist
+    TYPE(distrib),INTENT(IN) :: old_dist
+    REAL, DIMENSION(old_dist%jjb_u:,:,:),INTENT(IN)     :: FieldS
+    REAL, DIMENSION(new_dist%jjb_u:,:,:),INTENT(OUT)    :: FieldR
+    INTEGER,OPTIONAL,INTENT(IN)       :: up
+    INTEGER,OPTIONAL,INTENT(IN)       :: down      
+    TYPE(request),INTENT(INOUT)         :: a_request
+
+    INTEGER                           :: halo_up
+    INTEGER                           :: halo_down
+    INTEGER                           :: ll
+        
+    
+    halo_up=0
+    halo_down=0
+    IF (PRESENT(up))   halo_up=up
+    IF (PRESENT(down)) halo_down=down
+    
+    ll=size(FieldS,3)
+    
+    CALL  Register_SwapField_gen_u(FieldS,FieldR,ll,old_dist,new_dist,halo_up,halo_down,a_request)
+    
+  END SUBROUTINE  Register_SwapField2d_u2d_bis
+   
+
+  SUBROUTINE Register_SwapField3d_u2d(FieldS,FieldR,new_dist,a_request,up,down)
+  USE parallel_lmdz
+  USE dimensions_mod
+      IMPLICIT NONE
+    
+    TYPE(distrib),INTENT(IN)          :: new_dist
+    REAL, DIMENSION(current_dist%jjb_u:,:,:,:),INTENT(IN)     :: FieldS
+    REAL, DIMENSION(new_dist%jjb_u:,:,:,:),INTENT(OUT)    :: FieldR
+    INTEGER,OPTIONAL,INTENT(IN)       :: up
+    INTEGER,OPTIONAL,INTENT(IN)       :: down      
+    TYPE(request),INTENT(INOUT)         :: a_request
+
+    INTEGER                           :: halo_up
+    INTEGER                           :: halo_down
+    INTEGER                           :: ll
+        
+    
+    halo_up=0
+    halo_down=0
+    IF (PRESENT(up))   halo_up=up
+    IF (PRESENT(down)) halo_down=down
+    
+    ll=size(FieldS,3)*size(FieldS,4)
+    
+    CALL  Register_SwapField_gen_u(FieldS,FieldR,ll,current_dist,new_dist,halo_up,halo_down,a_request)
+    
+  END SUBROUTINE  Register_SwapField3d_u2d 
+
+  SUBROUTINE Register_SwapField3d_u2d_bis(FieldS,FieldR,new_dist,a_request,old_dist,up,down)
+  USE parallel_lmdz
+  USE dimensions_mod
+      IMPLICIT NONE
+    
+    TYPE(distrib),INTENT(IN)          :: new_dist
+    TYPE(distrib),INTENT(IN) :: old_dist
+    REAL, DIMENSION(old_dist%jjb_u:,:,:,:),INTENT(IN)     :: FieldS
+    REAL, DIMENSION(new_dist%jjb_u:,:,:,:),INTENT(OUT)    :: FieldR
+    INTEGER,OPTIONAL,INTENT(IN)       :: up
+    INTEGER,OPTIONAL,INTENT(IN)       :: down      
+    TYPE(request),INTENT(INOUT)         :: a_request
+
+    INTEGER                           :: halo_up
+    INTEGER                           :: halo_down
+    INTEGER                           :: ll
+        
+    
+    halo_up=0
+    halo_down=0
+    IF (PRESENT(up))   halo_up=up
+    IF (PRESENT(down)) halo_down=down
+    
+    ll=size(FieldS,3)*size(FieldS,4)
+    
+    CALL  Register_SwapField_gen_u(FieldS,FieldR,ll,old_dist,new_dist,halo_up,halo_down,a_request)
+    
+  END SUBROUTINE  Register_SwapField3d_u2d_bis 
+
+
+
+
+
+
+
+  SUBROUTINE Register_SwapField1d_v(FieldS,FieldR,new_dist,a_request,up,down)
+  USE parallel_lmdz
+  USE dimensions_mod
+      IMPLICIT NONE
+    
+    TYPE(distrib),INTENT(IN)          :: new_dist
+    REAL, DIMENSION(current_dist%ijb_v:),INTENT(IN)     :: FieldS
+    REAL, DIMENSION(new_dist%ijb_v:),INTENT(OUT)    :: FieldR
+    INTEGER,OPTIONAL,INTENT(IN)       :: up
+    INTEGER,OPTIONAL,INTENT(IN)       :: down      
+    TYPE(request),INTENT(INOUT)         :: a_request
+
+    INTEGER                           :: halo_up
+    INTEGER                           :: halo_down
+    
+    
+    halo_up=0
+    halo_down=0
+    IF (PRESENT(up))   halo_up=up
+    IF (PRESENT(down)) halo_down=down
+
+    CALL  Register_SwapField_gen_v(FieldS,FieldR,1,current_dist,new_dist,halo_up,halo_down,a_request)
+        
+  END SUBROUTINE  Register_SwapField1d_v 
+
+  SUBROUTINE Register_SwapField1d_v_bis(FieldS,FieldR,new_dist,a_request,old_dist,up,down)
+  USE parallel_lmdz
+  USE dimensions_mod
+      IMPLICIT NONE
+    
+    TYPE(distrib),INTENT(IN)          :: new_dist
+    TYPE(distrib),INTENT(IN) :: old_dist
+    REAL, DIMENSION(old_dist%ijb_v:),INTENT(IN)     :: FieldS
+    REAL, DIMENSION(new_dist%ijb_v:),INTENT(OUT)    :: FieldR
+    INTEGER,OPTIONAL,INTENT(IN)       :: up
+    INTEGER,OPTIONAL,INTENT(IN)       :: down      
+    TYPE(request),INTENT(INOUT)         :: a_request
+
+    INTEGER                           :: halo_up
+    INTEGER                           :: halo_down
+    
+    
+    halo_up=0
+    halo_down=0
+    IF (PRESENT(up))   halo_up=up
+    IF (PRESENT(down)) halo_down=down
+
+    CALL  Register_SwapField_gen_v(FieldS,FieldR,1,old_dist,new_dist,halo_up,halo_down,a_request)
+        
+  END SUBROUTINE  Register_SwapField1d_v_bis 
+
+
+  SUBROUTINE Register_SwapField2d_v1d(FieldS,FieldR,new_dist,a_request,up,down)
+  USE parallel_lmdz
+  USE dimensions_mod
+      IMPLICIT NONE
+   
+    TYPE(distrib),INTENT(IN)          :: new_dist
+    REAL, DIMENSION(current_dist%ijb_v:,:),INTENT(IN)     :: FieldS
+    REAL, DIMENSION(new_dist%ijb_v:,:),INTENT(OUT)    :: FieldR
+    INTEGER,OPTIONAL,INTENT(IN)       :: up
+    INTEGER,OPTIONAL,INTENT(IN)       :: down      
+    TYPE(request),INTENT(INOUT)         :: a_request
+
+    INTEGER                           :: halo_up
+    INTEGER                           :: halo_down
+    INTEGER                           :: ll
+        
+    
+    halo_up=0
+    halo_down=0
+    IF (PRESENT(up))   halo_up=up
+    IF (PRESENT(down)) halo_down=down
+    
+    ll=size(FieldS,2)
+    
+    CALL  Register_SwapField_gen_v(FieldS,FieldR,ll,current_dist,new_dist,halo_up,halo_down,a_request)
+    
+  END SUBROUTINE  Register_SwapField2d_v1d
+  
+  SUBROUTINE Register_SwapField2d_v1d_bis(FieldS,FieldR,new_dist,a_request,old_dist,up,down)
+  USE parallel_lmdz
+  USE dimensions_mod
+      IMPLICIT NONE
+   
+    TYPE(distrib),INTENT(IN)          :: new_dist
+    TYPE(distrib),INTENT(IN)          :: old_dist
+    REAL, DIMENSION(old_dist%ijb_v:,:),INTENT(IN)     :: FieldS
+    REAL, DIMENSION(new_dist%ijb_v:,:),INTENT(OUT)    :: FieldR
+    INTEGER,OPTIONAL,INTENT(IN)       :: up
+    INTEGER,OPTIONAL,INTENT(IN)       :: down      
+    TYPE(request),INTENT(INOUT)         :: a_request
+
+    INTEGER                           :: halo_up
+    INTEGER                           :: halo_down
+    INTEGER                           :: ll
+        
+    
+    halo_up=0
+    halo_down=0
+    IF (PRESENT(up))   halo_up=up
+    IF (PRESENT(down)) halo_down=down
+    
+    ll=size(FieldS,2)
+    
+    CALL  Register_SwapField_gen_v(FieldS,FieldR,ll,old_dist,new_dist,halo_up,halo_down,a_request)
+    
+  END SUBROUTINE  Register_SwapField2d_v1d_bis
+  
+   
+
+  SUBROUTINE Register_SwapField3d_v(FieldS,FieldR,new_dist,a_request,up,down)
+  USE parallel_lmdz
+  USE dimensions_mod
+      IMPLICIT NONE
+    
+    TYPE(distrib),INTENT(IN)          :: new_dist
+    REAL, DIMENSION(current_dist%ijb_v:,:,:),INTENT(IN)     :: FieldS
+    REAL, DIMENSION(new_dist%ijb_v:,:,:),INTENT(OUT)    :: FieldR
+    INTEGER,OPTIONAL,INTENT(IN)       :: up
+    INTEGER,OPTIONAL,INTENT(IN)       :: down      
+    TYPE(request),INTENT(INOUT)         :: a_request
+
+    INTEGER                           :: halo_up
+    INTEGER                           :: halo_down
+    INTEGER                           :: ll
+        
+    
+    halo_up=0
+    halo_down=0
+    IF (PRESENT(up))   halo_up=up
+    IF (PRESENT(down)) halo_down=down
+    
+    ll=size(FieldS,2)*size(FieldS,3)
+    
+    CALL  Register_SwapField_gen_v(FieldS,FieldR,ll,current_dist,new_dist,halo_up,halo_down,a_request)
+    
+  END SUBROUTINE  Register_SwapField3d_v 
+
+  SUBROUTINE Register_SwapField3d_v_bis(FieldS,FieldR,new_dist,a_request,old_dist,up,down)
+  USE parallel_lmdz
+  USE dimensions_mod
+      IMPLICIT NONE
+    
+    TYPE(distrib),INTENT(IN)          :: new_dist
+    TYPE(distrib),INTENT(IN) :: old_dist
+    REAL, DIMENSION(old_dist%ijb_v:,:,:),INTENT(IN)     :: FieldS
+    REAL, DIMENSION(new_dist%ijb_v:,:,:),INTENT(OUT)    :: FieldR
+    INTEGER,OPTIONAL,INTENT(IN)       :: up
+    INTEGER,OPTIONAL,INTENT(IN)       :: down      
+    TYPE(request),INTENT(INOUT)         :: a_request
+
+    INTEGER                           :: halo_up
+    INTEGER                           :: halo_down
+    INTEGER                           :: ll
+        
+    
+    halo_up=0
+    halo_down=0
+    IF (PRESENT(up))   halo_up=up
+    IF (PRESENT(down)) halo_down=down
+    
+    ll=size(FieldS,2)*size(FieldS,3)
+    
+    CALL  Register_SwapField_gen_v(FieldS,FieldR,ll,old_dist,new_dist,halo_up,halo_down,a_request)
+    
+  END SUBROUTINE  Register_SwapField3d_v_bis 
+
+
+
+
+  SUBROUTINE Register_SwapField1d_v2d(FieldS,FieldR,new_dist,a_request,up,down)
+  USE parallel_lmdz
+  USE dimensions_mod
+      IMPLICIT NONE
+    
+    TYPE(distrib),INTENT(IN)          :: new_dist !LF
+    REAL, DIMENSION(current_dist%jjb_v:,:),INTENT(IN)     :: FieldS
+    REAL, DIMENSION(new_dist%jjb_v:,:),INTENT(OUT)    :: FieldR
+    INTEGER,OPTIONAL,INTENT(IN)       :: up
+    INTEGER,OPTIONAL,INTENT(IN)       :: down      
+    TYPE(request),INTENT(INOUT)         :: a_request
+
+    INTEGER                           :: halo_up
+    INTEGER                           :: halo_down
+    
+    
+    halo_up=0
+    halo_down=0
+    IF (PRESENT(up))   halo_up=up
+    IF (PRESENT(down)) halo_down=down
+
+    CALL  Register_SwapField_gen_v(FieldS,FieldR,1,current_dist,new_dist,halo_up,halo_down,a_request)
+        
+  END SUBROUTINE  Register_SwapField1d_v2d
+
+  SUBROUTINE Register_SwapField1d_v2d_bis(FieldS,FieldR,new_dist,a_request,old_dist,up,down)
+  USE parallel_lmdz
+  USE dimensions_mod
+      IMPLICIT NONE
+    
+    TYPE(distrib),INTENT(IN)          :: new_dist !LF
+    TYPE(distrib),INTENT(IN) :: old_dist
+    REAL, DIMENSION(old_dist%jjb_v:,:),INTENT(IN)     :: FieldS
+    REAL, DIMENSION(new_dist%jjb_v:,:),INTENT(OUT)    :: FieldR
+    INTEGER,OPTIONAL,INTENT(IN)       :: up
+    INTEGER,OPTIONAL,INTENT(IN)       :: down      
+    TYPE(request),INTENT(INOUT)         :: a_request
+
+    INTEGER                           :: halo_up
+    INTEGER                           :: halo_down
+    
+    
+    halo_up=0
+    halo_down=0
+    IF (PRESENT(up))   halo_up=up
+    IF (PRESENT(down)) halo_down=down
+
+    CALL  Register_SwapField_gen_v(FieldS,FieldR,1,old_dist,new_dist,halo_up,halo_down,a_request)
+        
+  END SUBROUTINE  Register_SwapField1d_v2d_bis
+
+
+  SUBROUTINE Register_SwapField2d_v2d(FieldS,FieldR,new_dist,a_request,up,down)
+  USE parallel_lmdz
+  USE dimensions_mod
+      IMPLICIT NONE
+    
+    TYPE(distrib),INTENT(IN)          :: new_dist
+    REAL, DIMENSION(current_dist%jjb_v:,:,:),INTENT(IN)     :: FieldS
+    REAL, DIMENSION(new_dist%jjb_v:,:,:),INTENT(OUT)    :: FieldR
+    INTEGER,OPTIONAL,INTENT(IN)       :: up
+    INTEGER,OPTIONAL,INTENT(IN)       :: down      
+    TYPE(request),INTENT(INOUT)         :: a_request
+
+    INTEGER                           :: halo_up
+    INTEGER                           :: halo_down
+    INTEGER                           :: ll
+        
+    
+    halo_up=0
+    halo_down=0
+    IF (PRESENT(up))   halo_up=up
+    IF (PRESENT(down)) halo_down=down
+    
+    ll=size(FieldS,3)
+    
+    CALL  Register_SwapField_gen_v(FieldS,FieldR,ll,current_dist,new_dist,halo_up,halo_down,a_request)
+    
+  END SUBROUTINE  Register_SwapField2d_v2d
+   
+  SUBROUTINE Register_SwapField2d_v2d_bis(FieldS,FieldR,new_dist,a_request,old_dist,up,down)
+  USE parallel_lmdz
+  USE dimensions_mod
+      IMPLICIT NONE
+    
+    TYPE(distrib),INTENT(IN)          :: new_dist
+    TYPE(distrib),INTENT(IN) :: old_dist
+    REAL, DIMENSION(old_dist%jjb_v:,:,:),INTENT(IN)     :: FieldS
+    REAL, DIMENSION(new_dist%jjb_v:,:,:),INTENT(OUT)    :: FieldR
+    INTEGER,OPTIONAL,INTENT(IN)       :: up
+    INTEGER,OPTIONAL,INTENT(IN)       :: down      
+    TYPE(request),INTENT(INOUT)         :: a_request
+
+    INTEGER                           :: halo_up
+    INTEGER                           :: halo_down
+    INTEGER                           :: ll
+        
+    
+    halo_up=0
+    halo_down=0
+    IF (PRESENT(up))   halo_up=up
+    IF (PRESENT(down)) halo_down=down
+    
+    ll=size(FieldS,3)
+    
+    CALL  Register_SwapField_gen_v(FieldS,FieldR,ll,old_dist,new_dist,halo_up,halo_down,a_request)
+    
+  END SUBROUTINE  Register_SwapField2d_v2d_bis
+   
+
+  SUBROUTINE Register_SwapField3d_v2d(FieldS,FieldR,new_dist,a_request,up,down)
+  USE parallel_lmdz
+  USE dimensions_mod
+      IMPLICIT NONE
+    
+    TYPE(distrib),INTENT(IN)          :: new_dist
+    REAL, DIMENSION(current_dist%jjb_v:,:,:,:),INTENT(IN)     :: FieldS
+    REAL, DIMENSION(new_dist%jjb_v:,:,:,:),INTENT(OUT)    :: FieldR
+    INTEGER,OPTIONAL,INTENT(IN)       :: up
+    INTEGER,OPTIONAL,INTENT(IN)       :: down      
+    TYPE(request),INTENT(INOUT)         :: a_request
+
+    INTEGER                           :: halo_up
+    INTEGER                           :: halo_down
+    INTEGER                           :: ll
+        
+    
+    halo_up=0
+    halo_down=0
+    IF (PRESENT(up))   halo_up=up
+    IF (PRESENT(down)) halo_down=down
+    
+    ll=size(FieldS,3)*size(FieldS,4)
+    
+    CALL  Register_SwapField_gen_v(FieldS,FieldR,ll,current_dist,new_dist,halo_up,halo_down,a_request)
+    
+  END SUBROUTINE  Register_SwapField3d_v2d 
+  
+  SUBROUTINE Register_SwapField3d_v2d_bis(FieldS,FieldR,new_dist,a_request,old_dist,up,down)
+  USE parallel_lmdz
+  USE dimensions_mod
+      IMPLICIT NONE
+    
+    TYPE(distrib),INTENT(IN)          :: new_dist
+    TYPE(distrib),INTENT(IN) :: old_dist
+    REAL, DIMENSION(old_dist%jjb_v:,:,:,:),INTENT(IN)     :: FieldS
+    REAL, DIMENSION(new_dist%jjb_v:,:,:,:),INTENT(OUT)    :: FieldR
+    INTEGER,OPTIONAL,INTENT(IN)       :: up
+    INTEGER,OPTIONAL,INTENT(IN)       :: down      
+    TYPE(request),INTENT(INOUT)         :: a_request
+
+    INTEGER                           :: halo_up
+    INTEGER                           :: halo_down
+    INTEGER                           :: ll
+        
+    
+    halo_up=0
+    halo_down=0
+    IF (PRESENT(up))   halo_up=up
+    IF (PRESENT(down)) halo_down=down
+    
+    ll=size(FieldS,3)*size(FieldS,4)
+    
+    CALL  Register_SwapField_gen_v(FieldS,FieldR,ll,old_dist,new_dist,halo_up,halo_down,a_request)
+    
+  END SUBROUTINE  Register_SwapField3d_v2d_bis 
+  
+  
+
+  SUBROUTINE Register_SwapField_gen_u(FieldS,FieldR,ll,old_dist,new_dist,Up,Down,a_request)
+  USE parallel_lmdz
+  USE dimensions_mod
+      IMPLICIT NONE
+   
+    INTEGER :: ll,Up,Down
+    TYPE(distrib)  :: old_dist
+    TYPE(distrib)  :: new_dist
+    REAL, DIMENSION(old_dist%ijb_u:old_dist%ije_u,ll) :: FieldS
+    REAL, DIMENSION(new_dist%ijb_u:new_dist%ije_u,ll) :: FieldR
+    TYPE(request) :: a_request
+    INTEGER,DIMENSION(0:MPI_Size-1) :: jj_Nb_New   
+    INTEGER,DIMENSION(0:MPI_Size-1) :: jj_Begin_New,jj_End_New
+    
+    INTEGER ::i,l,jje,jjb,ijb,ije
+    
+    DO i=0,MPI_Size-1
+      jj_begin_New(i)=max(1,new_dist%jj_begin_para(i)-Up)
+      jj_end_New(i)=min(jjp1,new_dist%jj_end_para(i)+Down)
+    ENDDO
+   
+    DO i=0,MPI_Size-1
+      IF (i /= MPI_Rank) THEN
+        jjb=max(jj_begin_new(i),old_dist%jj_begin)
+        jje=min(jj_end_new(i),old_dist%jj_end)
+        
+        IF (jje >= jjb) THEN
+          CALL Register_SendField(FieldS,old_dist%ijnb_u,ll,jjb-old_dist%jjb_u+1,jje-jjb+1,i,a_request) 
+        ENDIF
+        
+        jjb=max(jj_begin_new(MPI_Rank),old_dist%jj_begin_Para(i))
+        jje=min(jj_end_new(MPI_Rank),old_dist%jj_end_Para(i))
+        
+        IF (jje >= jjb) THEN
+          CALL Register_RecvField(FieldR,new_dist%ijnb_u,ll,jjb-new_dist%jjb_u+1,jje-jjb+1,i,a_request) 
+        ENDIF
+      ELSE
+        jjb=max(jj_begin_new(i),old_dist%jj_begin)
+        jje=min(jj_end_new(i),old_dist%jj_end)
+        ijb=(jjb-1)*iip1+1
+        ije=jje*iip1
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)           
+        DO l=1,ll
+          FieldR(ijb:ije,l)=FieldS(ijb:ije,l)              
+        ENDDO
+!$OMP END DO NOWAIT
+      ENDIF
+    ENDDO
+    
+  END SUBROUTINE Register_SwapField_gen_u
+
+
+
+  SUBROUTINE Register_SwapField_gen_v(FieldS,FieldR,ll,old_dist,new_dist,Up,Down,a_request)
+  USE parallel_lmdz
+  USE dimensions_mod
+    IMPLICIT NONE
+    
+    INTEGER :: ll,Up,Down
+    TYPE(distrib)  :: old_dist
+    TYPE(distrib)  :: new_dist
+    REAL, DIMENSION(old_dist%ijb_v:old_dist%ije_v,ll) :: FieldS
+    REAL, DIMENSION(new_dist%ijb_v:new_dist%ije_v,ll) :: FieldR
+    TYPE(request) :: a_request
+    INTEGER,DIMENSION(0:MPI_Size-1) :: jj_Nb_New   
+    INTEGER,DIMENSION(0:MPI_Size-1) :: jj_Begin_New,jj_End_New
+    
+    INTEGER ::i,l,jje,jjb,ijb,ije
+    
+    DO i=0,MPI_Size-1
+      jj_begin_New(i)=max(1,new_dist%jj_begin_para(i)-Up)
+      jj_end_New(i)=min(jjp1,new_dist%jj_end_para(i)+Down)
+    ENDDO
+   
+    DO i=0,MPI_Size-1
+      IF (i /= MPI_Rank) THEN
+        jjb=max(jj_begin_new(i),old_dist%jj_begin)
+        jje=min(jj_end_new(i),old_dist%jj_end)
+
+        IF (jje==jjp1) jje=jjm        
+
+        IF (jje >= jjb) THEN
+          CALL Register_SendField(FieldS,old_dist%ijnb_v,ll,jjb-old_dist%jjb_v+1,jje-jjb+1,i,a_request) 
+        ENDIF
+        
+        jjb=max(jj_begin_new(MPI_Rank),old_dist%jj_begin_Para(i))
+        jje=min(jj_end_new(MPI_Rank),old_dist%jj_end_Para(i))
+
+        IF (jje==jjp1) jje=jjm
+        
+        IF (jje >= jjb) THEN
+          CALL Register_RecvField(FieldR,new_dist%ijnb_v,ll,jjb-new_dist%jjb_v+1,jje-jjb+1,i,a_request) 
+        ENDIF
+      ELSE
+        jjb=max(jj_begin_new(i),old_dist%jj_begin)
+        jje=min(jj_end_new(i),old_dist%jj_end)
+        IF (jje==jjp1) jje=jjm
+        ijb=(jjb-1)*iip1+1
+        ije=jje*iip1
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)           
+        DO l=1,ll
+          FieldR(ijb:ije,l)=FieldS(ijb:ije,l)
+        ENDDO              
+!$OMP END DO NOWAIT
+      ENDIF
+    ENDDO
+    
+  END SUBROUTINE Register_SwapField_gen_v
+
+
+ 
+
+  
+  subroutine Register_Hallo(Field,ij,ll,RUp,Rdown,SUp,SDown,a_request)
+  USE dimensions_mod
+  USE lmdz_mpi
+      implicit none
+
+      INTEGER :: ij,ll
+      REAL, dimension(ij,ll) :: Field
+      INTEGER :: Sup,Sdown,rup,rdown
+      type(request) :: a_request
+      type(Hallo),pointer :: PtrHallo
+      LOGICAL :: SendUp,SendDown
+      LOGICAL :: RecvUp,RecvDown
+   
+ 
+      SendUp=.TRUE.
+      SendDown=.TRUE.
+      RecvUp=.TRUE.
+      RecvDown=.TRUE.
+        
+      IF (pole_nord) THEN
+        SendUp=.FALSE.
+        RecvUp=.FALSE.
+      ENDIF
+  
+      IF (pole_sud) THEN
+        SendDown=.FALSE.
+        RecvDown=.FALSE.
+      ENDIF
+      
+      if (Sup.eq.0) then
+        SendUp=.FALSE.
+       endif
+      
+      if (Sdown.eq.0) then
+        SendDown=.FALSE.
+      endif
+
+      if (Rup.eq.0) then
+        RecvUp=.FALSE.
+      endif
+      
+      if (Rdown.eq.0) then
+        RecvDown=.FALSE.
+      endif
+      
+      IF (SendUp) THEN
+        call Register_SendField(Field,ij,ll,jj_begin,SUp,MPI_Rank-1,a_request)
+      ENDIF
+  
+      IF (SendDown) THEN
+        call Register_SendField(Field,ij,ll,jj_end-SDown+1,SDown,MPI_Rank+1,a_request)
+      ENDIF
+    
+  
+      IF (RecvUp) THEN
+        call Register_RecvField(Field,ij,ll,jj_begin-Rup,RUp,MPI_Rank-1,a_request)
+      ENDIF
+  
+      IF (RecvDown) THEN
+        call Register_RecvField(Field,ij,ll,jj_end+1,RDown,MPI_Rank+1,a_request)
+      ENDIF
+  
+    end subroutine Register_Hallo
+
+
+  subroutine Register_Hallo_u(Field,ll,RUp,Rdown,SUp,SDown,a_request)
+  USE dimensions_mod
+  USE lmdz_mpi
+      implicit none
+      INTEGER :: ll
+      REAL, dimension(ijb_u:ije_u,ll) :: Field
+      INTEGER :: Sup,Sdown,rup,rdown
+      type(request) :: a_request
+      type(Hallo),pointer :: PtrHallo
+      LOGICAL :: SendUp,SendDown
+      LOGICAL :: RecvUp,RecvDown
+   
+ 
+      SendUp=.TRUE.
+      SendDown=.TRUE.
+      RecvUp=.TRUE.
+      RecvDown=.TRUE.
+        
+      IF (pole_nord) THEN
+        SendUp=.FALSE.
+        RecvUp=.FALSE.
+      ENDIF
+  
+      IF (pole_sud) THEN
+        SendDown=.FALSE.
+        RecvDown=.FALSE.
+      ENDIF
+      
+      if (Sup.eq.0) then
+        SendUp=.FALSE.
+       endif
+      
+      if (Sdown.eq.0) then
+        SendDown=.FALSE.
+      endif
+
+      if (Rup.eq.0) then
+        RecvUp=.FALSE.
+      endif
+      
+      if (Rdown.eq.0) then
+        RecvDown=.FALSE.
+      endif
+      
+      IF (SendUp) THEN
+        call Register_SendField(Field,ijnb_u,ll,jj_begin-jjb_u+1,SUp,MPI_Rank-1,a_request)
+      ENDIF
+  
+      IF (SendDown) THEN
+        call Register_SendField(Field,ijnb_u,ll,jj_end-SDown+1-jjb_u+1,SDown,MPI_Rank+1,a_request)
+      ENDIF
+    
+  
+      IF (RecvUp) THEN
+        call Register_RecvField(Field,ijnb_u,ll,jj_begin-Rup-jjb_u+1,RUp,MPI_Rank-1,a_request)
+      ENDIF
+  
+      IF (RecvDown) THEN
+        call Register_RecvField(Field,ijnb_u,ll,jj_end+1-jjb_u+1,RDown,MPI_Rank+1,a_request)
+      ENDIF
+  
+    end subroutine Register_Hallo_u
+
+  subroutine Register_Hallo_v(Field,ll,RUp,Rdown,SUp,SDown,a_request)
+  USE dimensions_mod
+  USE lmdz_mpi
+      implicit none
+      INTEGER :: ll
+      REAL, dimension(ijb_v:ije_v,ll) :: Field
+      INTEGER :: Sup,Sdown,rup,rdown
+      type(request) :: a_request
+      type(Hallo),pointer :: PtrHallo
+      LOGICAL :: SendUp,SendDown
+      LOGICAL :: RecvUp,RecvDown
+   
+ 
+      SendUp=.TRUE.
+      SendDown=.TRUE.
+      RecvUp=.TRUE.
+      RecvDown=.TRUE.
+        
+      IF (pole_nord) THEN
+        SendUp=.FALSE.
+        RecvUp=.FALSE.
+      ENDIF
+  
+      IF (pole_sud) THEN
+        SendDown=.FALSE.
+        RecvDown=.FALSE.
+      ENDIF
+      
+      if (Sup.eq.0) then
+        SendUp=.FALSE.
+       endif
+      
+      if (Sdown.eq.0) then
+        SendDown=.FALSE.
+      endif
+
+      if (Rup.eq.0) then
+        RecvUp=.FALSE.
+      endif
+      
+      if (Rdown.eq.0) then
+        RecvDown=.FALSE.
+      endif
+      
+      IF (SendUp) THEN
+        call Register_SendField(Field,ijnb_v,ll,jj_begin-jjb_v+1,SUp,MPI_Rank-1,a_request)
+      ENDIF
+  
+      IF (SendDown) THEN
+        call Register_SendField(Field,ijnb_v,ll,jj_end-SDown+1-jjb_v+1,SDown,MPI_Rank+1,a_request)
+      ENDIF
+    
+  
+      IF (RecvUp) THEN
+        call Register_RecvField(Field,ijnb_v,ll,jj_begin-Rup-jjb_v+1,RUp,MPI_Rank-1,a_request)
+      ENDIF
+  
+      IF (RecvDown) THEN
+        call Register_RecvField(Field,ijnb_v,ll,jj_end+1-jjb_v+1,RDown,MPI_Rank+1,a_request)
+      ENDIF
+  
+    end subroutine Register_Hallo_v
+    
+    subroutine SendRequest(a_Request)
+    USE dimensions_mod
+    USE lmdz_mpi
+      implicit none
+
+      type(request),target :: a_request
+      type(request_SR),pointer :: Req
+      type(Hallo),pointer :: PtrHallo
+      integer :: SizeBuffer
+      integer :: i,rank,l,ij,Pos,ierr
+      integer :: offset
+      real,dimension(:,:),pointer :: Field
+      integer :: Nb
+       
+      do rank=0,MPI_SIZE-1
+      
+        Req=>a_Request%RequestSend(rank)
+        
+        SizeBuffer=0
+        do i=1,Req%NbRequest
+          PtrHallo=>Req%Hallo(i)
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 
+          DO l=1,PtrHallo%NbLevel
+            SizeBuffer=SizeBuffer+PtrHallo%size*iip1
+          ENDDO
+!$OMP ENDDO NOWAIT          
+        enddo
+      
+         Req%BufferSize=SizeBuffer
+         if (Req%NbRequest>0) then
+       
+          call allocate_buffer(SizeBuffer,Req%Index,Req%pos)
+
+          Pos=Req%Pos
+          do i=1,Req%NbRequest
+            PtrHallo=>Req%Hallo(i)
+            offset=(PtrHallo%offset-1)*iip1+1
+            Nb=iip1*PtrHallo%size-1
+            Field=>PtrHallo%Field
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)           
+            do l=1,PtrHallo%NbLevel
+!cdir NODEP
+              do ij=0,Nb
+	        Buffer(Pos+ij)=Field(Offset+ij,l)
+	      enddo
+              
+              Pos=Pos+Nb+1
+            enddo
+!$OMP END DO NOWAIT            
+          enddo
+    
+         if (SizeBuffer>0) then
+!$OMP CRITICAL (MPI)
+         
+         call MPI_ISEND(Buffer(req%Pos),SizeBuffer,MPI_REAL_LMDZ,rank,a_request%tag+1000*omp_rank,     &
+                         COMM_LMDZ,Req%MSG_Request,ierr)
+         IF (.NOT.using_mpi) THEN
+           PRINT *,'Erreur, echange MPI en mode sequentiel !!!'
+           CALL abort_gcm("mod_hallo","stopped",1)
+         ENDIF
+!         PRINT *,"-------------------------------------------------------------------"
+!         PRINT *,"Process de rang",mpi_rank,"Task : ",omp_rank,"--->"
+!         PRINT *,"Requete envoye au proc :",rank,"tag :",a_request%tag+1000*omp_rank
+!         PRINT *,"Taille du message :",SizeBuffer,"requete no :",Req%MSG_Request
+!         PRINT *,"-------------------------------------------------------------------"
+!$OMP END CRITICAL (MPI)
+        endif
+       endif
+    enddo
+   
+           
+      do rank=0,MPI_SIZE-1
+         
+          Req=>a_Request%RequestRecv(rank)
+          SizeBuffer=0
+          
+	  do i=1,Req%NbRequest
+            PtrHallo=>Req%Hallo(i)
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 
+            DO l=1,PtrHallo%NbLevel
+              SizeBuffer=SizeBuffer+PtrHallo%size*iip1
+            ENDDO
+!$OMP ENDDO NOWAIT          
+          enddo
+          
+          Req%BufferSize=SizeBuffer
+          
+          if (Req%NbRequest>0) then
+          call allocate_buffer(SizeBuffer,Req%Index,Req%Pos)
+   
+          if (SizeBuffer>0) then
+
+!$OMP CRITICAL (MPI)
+
+             call MPI_IRECV(Buffer(Req%Pos),SizeBuffer,MPI_REAL_LMDZ,rank,a_request%tag+1000*omp_rank,     &
+                           COMM_LMDZ,Req%MSG_Request,ierr)
+
+             IF (.NOT.using_mpi) THEN
+               PRINT *,'Erreur, echange MPI en mode sequentiel !!!'
+               CALL abort_gcm("mod_hallo","stopped",1)
+             ENDIF
+
+!         PRINT *,"-------------------------------------------------------------------"
+!         PRINT *,"Process de rang",mpi_rank,"Task : ",omp_rank,"--->"
+!         PRINT *,"Requete en attente du proc :",rank,"tag :",a_request%tag+1000*omp_rank
+!         PRINT *,"Taille du message :",SizeBuffer,"requete no :",Req%MSG_Request
+!         PRINT *,"-------------------------------------------------------------------"
+
+!$OMP END CRITICAL (MPI)
+          endif
+        endif
+      
+      enddo
+                        
+   end subroutine SendRequest 
+   
+   subroutine WaitRequest(a_Request)
+   USE dimensions_mod
+   USE lmdz_mpi
+   implicit none
+      
+      type(request),target :: a_request
+      type(request_SR),pointer :: Req
+      type(Hallo),pointer :: PtrHallo
+      integer, dimension(2*mpi_size) :: TabRequest
+      integer, dimension(MPI_STATUS_SIZE,2*mpi_size) :: TabStatus
+      integer :: NbRequest
+      integer :: i,rank,pos,ij,l,ierr
+      integer :: offset
+      integer :: Nb
+      
+      
+      NbRequest=0
+      do rank=0,MPI_SIZE-1
+        Req=>a_request%RequestSend(rank)
+        if (Req%NbRequest>0 .AND. Req%BufferSize > 0) then
+          NbRequest=NbRequest+1
+          TabRequest(NbRequest)=Req%MSG_Request
+        endif
+      enddo
+      
+      do rank=0,MPI_SIZE-1
+        Req=>a_request%RequestRecv(rank)
+        if (Req%NbRequest>0 .AND. Req%BufferSize > 0 ) then
+          NbRequest=NbRequest+1
+          TabRequest(NbRequest)=Req%MSG_Request
+        endif
+      enddo
+     
+      if (NbRequest>0) then
+!$OMP CRITICAL (MPI)
+!        PRINT *,"-------------------------------------------------------------------"
+!        PRINT *,"Process de rang",mpi_rank,"Task : ",omp_rank,"--->",NbRequest,"en attente"
+!        PRINT *,"No des requetes :",TabRequest(1:NbRequest)
+        call MPI_WAITALL(NbRequest,TabRequest,TabStatus,ierr)
+!        PRINT *,"Process de rang",mpi_rank,"Task : ",omp_rank,"--->",NbRequest,"complete"
+!        PRINT *,"-------------------------------------------------------------------"
+!$OMP END CRITICAL (MPI)
+      endif
+      do rank=0,MPI_Size-1
+        Req=>a_request%RequestRecv(rank)
+        if (Req%NbRequest>0) then
+          Pos=Req%Pos
+          do i=1,Req%NbRequest
+            PtrHallo=>Req%Hallo(i)
+            offset=(PtrHallo%offset-1)*iip1+1
+	    Nb=iip1*PtrHallo%size-1
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)            
+	    do l=1,PtrHallo%NbLevel
+!cdir NODEP
+              do ij=0,Nb
+	        PtrHallo%Field(offset+ij,l)=Buffer(Pos+ij)
+	      enddo
+
+              Pos=Pos+Nb+1
+	    enddo
+!$OMP ENDDO NOWAIT	    
+          enddo
+        endif
+      enddo
+      
+      do rank=0,MPI_SIZE-1
+        Req=>a_request%RequestSend(rank)
+        if (Req%NbRequest>0) then
+          call deallocate_buffer(Req%Index)
+          Req%NbRequest=0 
+        endif
+      enddo
+              
+      do rank=0,MPI_SIZE-1
+        Req=>a_request%RequestRecv(rank)
+        if (Req%NbRequest>0) then
+          call deallocate_buffer(Req%Index)
+          Req%NbRequest=0 
+        endif
+      enddo
+     
+      a_request%tag=1
+    end subroutine WaitRequest
+     
+   subroutine WaitSendRequest(a_Request)
+   USE lmdz_mpi
+   USE dimensions_mod
+   implicit none
+   
+      type(request),target :: a_request
+      type(request_SR),pointer :: Req
+      type(Hallo),pointer :: PtrHallo
+      integer, dimension(mpi_size) :: TabRequest
+      integer, dimension(MPI_STATUS_SIZE,mpi_size) :: TabStatus
+      integer :: NbRequest
+      integer :: i,rank,pos,ij,l,ierr
+      integer :: offset
+      
+      
+      NbRequest=0
+      do rank=0,MPI_SIZE-1
+        Req=>a_request%RequestSend(rank)
+        if (Req%NbRequest>0) then
+          NbRequest=NbRequest+1
+          TabRequest(NbRequest)=Req%MSG_Request
+        endif
+      enddo
+      
+
+      if (NbRequest>0 .AND. Req%BufferSize > 0 ) THEN 
+!$OMP CRITICAL (MPI)     
+!        PRINT *,"-------------------------------------------------------------------"
+!        PRINT *,"Process de rang",mpi_rank,"Task : ",omp_rank,"--->",NbRequest,"en attente"
+!        PRINT *,"No des requetes :",TabRequest(1:NbRequest)
+         call MPI_WAITALL(NbRequest,TabRequest,TabStatus,ierr)
+!        PRINT *,"Process de rang",mpi_rank,"Task : ",omp_rank,"--->",NbRequest,"complete"
+!        PRINT *,"-------------------------------------------------------------------"
+
+!$OMP END CRITICAL (MPI)
+      endif      
+      
+      do rank=0,MPI_SIZE-1
+        Req=>a_request%RequestSend(rank)
+        if (Req%NbRequest>0) then
+          call deallocate_buffer(Req%Index)
+          Req%NbRequest=0 
+        endif
+      enddo
+              
+      a_request%tag=1
+    end subroutine WaitSendRequest
+    
+   subroutine WaitRecvRequest(a_Request)
+   USE dimensions_mod
+   USE lmdz_mpi
+   implicit none
+      type(request),target :: a_request
+      type(request_SR),pointer :: Req
+      type(Hallo),pointer :: PtrHallo
+      integer, dimension(mpi_size) :: TabRequest
+      integer, dimension(MPI_STATUS_SIZE,mpi_size) :: TabStatus
+      integer :: NbRequest
+      integer :: i,rank,pos,ij,l,ierr
+      integer :: offset,Nb
+      
+      
+      NbRequest=0
+      
+      do rank=0,MPI_SIZE-1
+        Req=>a_request%RequestRecv(rank)
+        if (Req%NbRequest>0 .AND. Req%BufferSize > 0 ) then
+          NbRequest=NbRequest+1
+          TabRequest(NbRequest)=Req%MSG_Request
+        endif
+      enddo
+     
+      
+      if (NbRequest>0) then
+!$OMP CRITICAL (MPI)     
+!        PRINT *,"-------------------------------------------------------------------"
+!        PRINT *,"Process de rang",mpi_rank,"Task : ",omp_rank,"--->",NbRequest,"en attente"
+!        PRINT *,"No des requetes :",TabRequest(1:NbRequest)
+         call MPI_WAITALL(NbRequest,TabRequest,TabStatus,ierr)
+!        PRINT *,"Process de rang",mpi_rank,"Task : ",omp_rank,"--->",NbRequest,"complete"
+!        PRINT *,"-------------------------------------------------------------------"
+!$OMP END CRITICAL (MPI)     
+      endif
+      
+      do rank=0,MPI_Size-1
+        Req=>a_request%RequestRecv(rank)
+        if (Req%NbRequest>0) then
+          Pos=Req%Pos
+          do i=1,Req%NbRequest
+            PtrHallo=>Req%Hallo(i)
+            offset=(PtrHallo%offset-1)*iip1+1
+	    Nb=iip1*PtrHallo%size-1
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)            
+	    do l=1,PtrHallo%NbLevel
+!cdir NODEP
+              do ij=0,Nb
+	        PtrHallo%Field(offset+ij,l)=Buffer(Pos+ij)
+	      enddo
+                 Pos=Pos+Nb+1
+            enddo
+!$OMP END DO NOWAIT
+          enddo
+        endif
+      enddo
+      
+           
+      do rank=0,MPI_SIZE-1
+        Req=>a_request%RequestRecv(rank)
+        if (Req%NbRequest>0) then
+          call deallocate_buffer(Req%Index)
+          Req%NbRequest=0 
+        endif
+      enddo
+     
+      a_request%tag=1
+    end subroutine WaitRecvRequest
+    
+    
+    
+    subroutine CopyField(FieldS,FieldR,ij,ll,jj_Nb_New)
+    USE dimensions_mod
+  
+      implicit none
+    
+    INTEGER :: ij,ll,l
+    REAL, dimension(ij,ll) :: FieldS
+    REAL, dimension(ij,ll) :: FieldR
+    integer,dimension(0:MPI_Size-1) :: jj_Nb_New   
+    integer,dimension(0:MPI_Size-1) :: jj_Begin_New,jj_End_New
+    
+    integer ::i,jje,jjb,ijb,ije
+    
+    jj_begin_New(0)=1
+    jj_End_New(0)=jj_Nb_New(0)
+    do i=1,MPI_Size-1
+      jj_begin_New(i)=jj_end_New(i-1)+1
+      jj_end_New(i)=jj_begin_new(i)+jj_Nb_New(i)-1
+    enddo
+    
+    jjb=max(jj_begin,jj_begin_new(MPI_Rank))
+    jje=min(jj_end,jj_end_new(MPI_Rank))
+    if (ij==ip1jm) jje=min(jje,jjm)
+
+    if (jje >= jjb) then
+      ijb=(jjb-1)*iip1+1
+      ije=jje*iip1
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      do l=1,ll
+        FieldR(ijb:ije,l)=FieldS(ijb:ije,l)
+      enddo
+!$OMP ENDDO NOWAIT
+    endif
+
+
+  end subroutine CopyField    
+
+  subroutine CopyFieldHallo(FieldS,FieldR,ij,ll,jj_Nb_New,Up,Down)
+  USE dimensions_mod
+  
+      implicit none
+    
+    INTEGER :: ij,ll,Up,Down
+    REAL, dimension(ij,ll) :: FieldS
+    REAL, dimension(ij,ll) :: FieldR
+    integer,dimension(0:MPI_Size-1) :: jj_Nb_New   
+    integer,dimension(0:MPI_Size-1) :: jj_Begin_New,jj_End_New
+
+    integer ::i,jje,jjb,ijb,ije,l
+
+     
+    jj_begin_New(0)=1
+    jj_End_New(0)=jj_Nb_New(0)
+    do i=1,MPI_Size-1
+      jj_begin_New(i)=jj_end_New(i-1)+1
+      jj_end_New(i)=jj_begin_new(i)+jj_Nb_New(i)-1
+    enddo
+
+        
+    jjb=max(jj_begin,jj_begin_new(MPI_Rank)-Up)
+    jje=min(jj_end,jj_end_new(MPI_Rank)+Down)
+    if (ij==ip1jm) jje=min(jje,jjm)
+    
+    
+    if (jje >= jjb) then
+      ijb=(jjb-1)*iip1+1
+      ije=jje*iip1
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+      do l=1,ll
+        FieldR(ijb:ije,l)=FieldS(ijb:ije,l)
+      enddo
+!$OMP ENDDO NOWAIT
+
+    endif
+   end subroutine CopyFieldHallo        
+
+   subroutine Gather_field_u(field_loc,field_glo,ll)
+   USE dimensions_mod
+   implicit none
+     integer :: ll
+     real :: field_loc(ijb_u:ije_u,ll)
+     real :: field_glo(ip1jmp1,ll)
+     type(request) :: request_gather
+     integer       :: l
+
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+     DO l=1,ll
+       field_glo(ij_begin:ij_end,l)=field_loc(ij_begin:ij_end,l)
+     ENDDO
+     
+     call register_SwapField(field_glo,field_glo,ip1jmp1,ll,distrib_gather%jj_nb_para,request_gather)
+     call SendRequest(request_gather)
+!$OMP BARRIER
+     call WaitRequest(request_gather)       
+!$OMP BARRIER
+
+    end subroutine Gather_field_u
+        
+   subroutine Gather_field_v(field_loc,field_glo,ll)
+   USE dimensions_mod
+   implicit none
+     integer :: ll
+     real :: field_loc(ijb_v:ije_v,ll)
+     real :: field_glo(ip1jm,ll)
+     type(request) :: request_gather
+     integer :: ijb,ije
+     integer       :: l
+     
+   
+     ijb=ij_begin
+     ije=ij_end
+     if (pole_sud) ije=ij_end-iip1
+        
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+     DO l=1,ll
+       field_glo(ijb:ije,l)=field_loc(ijb:ije,l)
+     ENDDO
+     
+     call register_SwapField(field_glo,field_glo,ip1jm,ll,distrib_gather%jj_nb_para,request_gather)
+     call SendRequest(request_gather)
+!$OMP BARRIER
+     call WaitRequest(request_gather)       
+!$OMP BARRIER
+
+    end subroutine Gather_field_v
+     
+   subroutine Scatter_field_u(field_glo,field_loc,ll)
+   USE dimensions_mod
+   implicit none
+     integer :: ll
+     real :: field_glo(ip1jmp1,ll)
+     real :: field_loc(ijb_u:ije_u,ll)
+     type(request) :: request_gather
+     TYPE(distrib) :: distrib_swap
+     integer       :: l
+     
+!$OMP BARRIER
+!$OMP MASTER     
+     call get_current_distrib(distrib_swap)
+     call set_Distrib(distrib_gather)
+!$OMP END MASTER
+!$OMP BARRIER
+ 
+     call register_SwapField(field_glo,field_glo,ip1jmp1,ll,distrib_swap%jj_nb_para,request_gather)
+     call SendRequest(request_gather)
+!$OMP BARRIER
+     call WaitRequest(request_gather)       
+!$OMP BARRIER
+!$OMP MASTER     
+     call set_Distrib(distrib_swap)
+!$OMP END MASTER
+!$OMP BARRIER
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+       DO l=1,ll
+         field_loc(ij_begin:ij_end,l)=field_glo(ij_begin:ij_end,l)
+       ENDDO
+
+    end subroutine Scatter_field_u
+
+   subroutine Scatter_field_v(field_glo,field_loc,ll)
+   USE dimensions_mod
+   implicit none
+     integer :: ll
+     real :: field_glo(ip1jmp1,ll)
+     real :: field_loc(ijb_v:ije_v,ll)
+     type(request) :: request_gather
+     TYPE(distrib) :: distrib_swap
+     integer       :: ijb,ije,l
+     
+
+!$OMP BARRIER
+!$OMP MASTER     
+     call get_current_distrib(distrib_swap)
+     call set_Distrib(distrib_gather)
+!$OMP END MASTER
+!$OMP BARRIER
+     call register_SwapField(field_glo,field_glo,ip1jm,ll,distrib_swap%jj_nb_para,request_gather)
+     call SendRequest(request_gather)
+!$OMP BARRIER
+     call WaitRequest(request_gather)       
+!$OMP BARRIER
+!$OMP MASTER
+     call set_Distrib(distrib_swap)
+!$OMP END MASTER
+!$OMP BARRIER
+     ijb=ij_begin
+     ije=ij_end
+     if (pole_sud) ije=ij_end-iip1
+     
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+       DO l=1,ll
+         field_loc(ijb:ije,l)=field_glo(ijb:ije,l)
+       ENDDO
+
+    end subroutine Scatter_field_v
+              
+end module mod_Hallo 
+   
Index: DZ6/trunk/libf/dyn3dmem/mod_xios_dyn3dmem.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/mod_xios_dyn3dmem.F90	(revision 5267)
+++ 	(revision )
@@ -1,260 +1,0 @@
-!
-! $Id$
-!
-! This module contains the interface between the LMDZ dynamics dyn3dmem module and XIOS.
-! 
-! Lists of subroutines
-!      xios_dyn3dmem_init : context / calendar / domain / axis initialisations
-!
-! Initialisation of communicator between LMDZ and XIOS is done elsewhere: wxios_init called by init_const_mpi 
-!                                                                         (one of the first calls in gcm.F90)
-! L. Fairhead 11/2017
-!
-!
-
-MODULE mod_xios_dyn3dmem
-
-     USE lmdz_xios
-     USE wxios, ONLY : g_comm
-     CHARACTER(len=100), SAVE :: dyn3d_ctx_name = "LMDZDYN"
-     TYPE(xios_context), SAVE :: dyn3d_ctx_handle
-!$OMP THREADPRIVATE(dyn3d_ctx_name, dyn3d_ctx_handle)
- 
-  INTERFACE writefield_dyn_u
-     MODULE PROCEDURE writefield_dyn1d_u, writefield_dyn2d_u
-  END INTERFACE writefield_dyn_u
-
-  INTERFACE writefield_dyn_v
-     MODULE PROCEDURE writefield_dyn1d_v, writefield_dyn2d_v
-  END INTERFACE writefield_dyn_v
-
-     REAL, ALLOCATABLE, SAVE :: NewField_U(:,:,:), NewField_V(:,:,:)
-  
-
-   CONTAINS
-
-   SUBROUTINE xios_dyn3dmem_init(xios_cal_type, anref, moisref, jourref,heureref, an, mois, jour, heure, zdtvr)
-
-
-     USE comvert_mod, ONLY: presnivs
-     USE parallel_lmdz
-
-     IMPLICIT NONE
-
-     INCLUDE 'dimensions.h'
-     INCLUDE "paramet.h"
-     INCLUDE 'comgeom.h'
-
-     TYPE(xios_duration) :: tstep_xios
-     TYPE(xios_date)                :: start_date
-     TYPE(xios_date)                :: time_origin
-     INTEGER :: an, mois, jour
-     REAL :: heure
-     CHARACTER (len=10) :: xios_cal_type
-     INTEGER :: anref, moisref, jourref
-     REAL :: heureref
-     REAL :: zdtvr
-     TYPE(xios_domain) :: dom_grid_U, dom_grid_V, dom_grid_T
-     REAL :: rlong(iip1), rlat(jjp1)
-     REAL :: pi
-     INTEGER :: ii, jj, jjb, jje, jjn
-
-!      WRITE(*,*)'Entree mod_xios_dyn3dmem'
-
-! 0 Initialisations
-     pi = 4. * ATAN (1.)
-! allocation of fields passed to xios
-!$OMP BARRIER
-!$OMP MASTER
-     allocate(NewField_U(iip1, jj_begin:jj_end, llm))
-     allocate(NewField_V(iip1, jj_begin:jj_end, llm))     
-!$OMP END MASTER
-!$OMP BARRIER
-
-! 1 Context initialisation
-!$OMP MASTER
-     CALL xios_context_initialize(dyn3d_ctx_name, g_comm)
-     CALL xios_get_handle(dyn3d_ctx_name, dyn3d_ctx_handle)
-     CALL xios_set_current_context(dyn3d_ctx_handle)  
-
-!     WRITE(*,*)'apres context initialisation mod_xios_dyn3dmem'
-
-! 2 calendar stuff
-
-     tstep_xios%second=zdtvr
-     CALL xios_define_calendar(type=xios_cal_type, start_date=xios_date(an, mois, jour,INT(heure),0,0), &
-            time_origin=xios_date(anref,moisref,jourref,INT(heureref),0,0), timestep=tstep_xios)
-
-!     WRITE(*,*)'apres  calendrier mod_xios_dyn3dmem'
-
-! 3 domain / grids / axis
-! Domains:
-      rlong(:) = rlonu(:) * 180. / pi
-      rlat(:) = rlatu(:) * 180. / pi
-
-      CALL xios_set_domain_attr("domain_U", ni_glo=iip1, nj_glo=jjp1,          &
-          type="rectilinear",ibegin=0, ni=iip1, jbegin=jj_begin-1, nj=jj_nb,   &
-          data_dim = 2, lonvalue_1d=rlong(1:iip1), latvalue_1d=rlat(jj_begin:jj_end))
-
-      jjb=jj_begin
-      jje=jj_end
-      jjn=jj_nb
-      IF (pole_sud) jjn=jjn-1
-      IF (pole_sud) jje=jje-1
-
-
-      rlong(:) = rlonv(:) * 180. / pi
-      do jj = jjb, jje
-        rlat(jj) = rlatv(jj) * 180. / pi
-      enddo
-      
-      CALL xios_set_domain_attr("domain_V", ni_glo=iip1, nj_glo=jjm,            &
-          type="rectilinear",ibegin=0, ni=iip1, jbegin=jj_begin-1, nj=jjn,   &
-          data_dim = 2, lonvalue_1d=rlong(1:iip1), latvalue_1d=rlat(jjb:jje))
-
-
-      rlong(:) = rlonv(:) * 180. / pi
-      rlat(:) = rlatu(:) * 180. / pi 
-      CALL xios_set_domain_attr("domain_T", ni_glo=iip1, nj_glo=jjp1,          &
-          type="rectilinear",ibegin=0, ni=iip1, jbegin=jj_begin-1, nj=jj_nb,   &
-          data_dim = 2, lonvalue_1d=rlong(1:iip1), latvalue_1d=rlat(jj_begin:jj_end))
-      
-!     WRITE(*,*)'apres  domaine mod_xios_dyn3dmem'
-! Vertical axis
-       CALL xios_set_axis_attr("presnivs",n_glo=llm,value=presnivs)
-!     WRITE(*,*)'apres  vertical axis mod_xios_dyn3dmem'
-! 4 end of context definition
-       CALL xios_close_context_definition()
-!     WRITE(*,*)'apres close context init. axis mod_xios_dyn3dmem'
-!$OMP END MASTER
-   END SUBROUTINE xios_dyn3dmem_init
-
-   SUBROUTINE  writefield_dyn1d_u(name,Field)
-
-     USE parallel_lmdz
-     IMPLICIT NONE
-     include 'dimensions.h'
-     include 'paramet.h'
-     CHARACTER(LEN=*)   :: name
-     REAL, DIMENSION(ij_begin:ij_end) :: Field
-     REAL, DIMENSION(iip1,  jj_begin:jj_end) :: NewField
-      LOGICAL,SAVE :: debuglf=.true.
-!$OMP THREADPRIVATE(debuglf)
-     
-     NewField(:,jj_begin:jj_end)=reshape(Field(ij_begin:ij_end),(/iip1,jj_nb/))
-
-!$OMP BARRIER       
-!$OMP MASTER
-     CALL xios_send_field(name, NewField)
-!$OMP END MASTER   
-  
-   END SUBROUTINE  writefield_dyn1d_u
-
-   SUBROUTINE  writefield_dyn2d_u(name,Field)
-
-     USE parallel_lmdz
-     IMPLICIT NONE
-     include 'dimensions.h'
-     include 'paramet.h'
-     CHARACTER(LEN=*)   :: name
-     REAL, DIMENSION(ij_begin:ij_end,llm) :: Field
-!     REAL, ALLOCATABLE, SAVE :: NewField(:,:,:)
-     INTEGER :: i,j,l, count
-
-!!!!!$OMP BARRIER
-!!!!!$OMP MASTER
-!!!!     allocate(NewField(iip1, jj_begin:jj_end, llm))
-!!!!!$OMP END MASTER
-!!!!!$OMP BARRIER
-
-
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 
-     DO l = 1, llm
-       NewField_U(:,jj_begin:jj_end,l)=reshape(Field(ij_begin:ij_end,l),(/iip1,jj_nb/))
-     ENDDO
-!$OMP ENDDO
-!$OMP BARRIER 
-
-!$OMP MASTER
-     CALL xios_send_field(name, NewField_U)
-!!!!     DEALLOCATE(NewField)
-!$OMP END MASTER   
-!$OMP BARRIER
-  
-   END SUBROUTINE  writefield_dyn2d_u
-
-   SUBROUTINE  writefield_dyn1d_v(name,Field)
-
-     USE parallel_lmdz
-     IMPLICIT NONE
-     include 'dimensions.h'
-     include 'paramet.h'
-     CHARACTER(LEN=*)   :: name
-     REAL, DIMENSION(ij_begin:ij_end) :: Field
-     REAL, DIMENSION(iip1,  jj_begin:jj_end) :: NewField
-     INTEGER ::  jje, ije, jjn
-
-     IF (pole_sud) THEN
-       jje=jj_end-1
-       ije=ij_end-iip1
-       jjn=jj_nb-1
-     ELSE
-       jje=jj_end
-       ije=ij_end
-       jjn=jj_nb
-     ENDIF
-
-     NewField(:,jj_begin:jje)=reshape(Field(ij_begin:ije),(/iip1,jjn/))
-
-!$OMP BARRIER       
-!$OMP MASTER
-     CALL xios_send_field(name, NewField(:,jj_begin:jje))
-!$OMP END MASTER   
-  
-   END SUBROUTINE  writefield_dyn1d_v
-
-   SUBROUTINE  writefield_dyn2d_v(name,Field)
-
-     USE parallel_lmdz
-     IMPLICIT NONE
-     include 'dimensions.h'
-     include 'paramet.h'
-     CHARACTER(LEN=*)   :: name
-     REAL, DIMENSION(ij_begin:ij_end,llm) :: Field
-!!!!     REAL, ALLOCATABLE, SAVE :: NewField(:,:,:)
-     INTEGER :: l, jje, ije, jjn
-
-!!!!!$OMP BARRIER
-!!!!!$OMP MASTER
-!!!!     allocate(NewField(iip1,  jj_begin:jj_end,llm))
-!!!!!$OMP END MASTER
-!!!!!$OMP BARRIER
-
-     IF (pole_sud) THEN
-       jje=jj_end-1
-       ije=ij_end-iip1
-       jjn=jj_nb-1
-     ELSE
-       jje=jj_end
-       ije=ij_end
-       jjn=jj_nb
-     ENDIF
-
-
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-     DO l = 1, llm
-        NewField_V(:,jj_begin:jje,l)=reshape(Field(ij_begin:ije,l),(/iip1,jjn/))
-     ENDDO
-!$OMP ENDDO
-!$OMP BARRIER       
-
-!$OMP MASTER
-     CALL xios_send_field(name, NewField_V(:,jj_begin:jje,:))
-!!!!     DEALLOCATE(NewField)
-!$OMP END MASTER   
-!$OMP BARRIER 
-  
-   END SUBROUTINE  writefield_dyn2d_v
-   
-END MODULE mod_xios_dyn3dmem 
-
Index: /LMDZ6/trunk/libf/dyn3dmem/mod_xios_dyn3dmem.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/mod_xios_dyn3dmem.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3dmem/mod_xios_dyn3dmem.f90	(revision 5268)
@@ -0,0 +1,260 @@
+!
+! $Id$
+!
+! This module contains the interface between the LMDZ dynamics dyn3dmem module and XIOS.
+! 
+! Lists of subroutines
+!      xios_dyn3dmem_init : context / calendar / domain / axis initialisations
+!
+! Initialisation of communicator between LMDZ and XIOS is done elsewhere: wxios_init called by init_const_mpi 
+!                                                                         (one of the first calls in gcm.F90)
+! L. Fairhead 11/2017
+!
+!
+
+MODULE mod_xios_dyn3dmem
+
+     USE lmdz_xios
+     USE wxios, ONLY : g_comm
+     CHARACTER(len=100), SAVE :: dyn3d_ctx_name = "LMDZDYN"
+     TYPE(xios_context), SAVE :: dyn3d_ctx_handle
+!$OMP THREADPRIVATE(dyn3d_ctx_name, dyn3d_ctx_handle)
+ 
+  INTERFACE writefield_dyn_u
+     MODULE PROCEDURE writefield_dyn1d_u, writefield_dyn2d_u
+  END INTERFACE writefield_dyn_u
+
+  INTERFACE writefield_dyn_v
+     MODULE PROCEDURE writefield_dyn1d_v, writefield_dyn2d_v
+  END INTERFACE writefield_dyn_v
+
+     REAL, ALLOCATABLE, SAVE :: NewField_U(:,:,:), NewField_V(:,:,:)
+  
+
+   CONTAINS
+
+   SUBROUTINE xios_dyn3dmem_init(xios_cal_type, anref, moisref, jourref,heureref, an, mois, jour, heure, zdtvr)
+
+
+     USE comvert_mod, ONLY: presnivs
+     USE parallel_lmdz
+
+     IMPLICIT NONE
+
+     INCLUDE 'dimensions.h'
+     INCLUDE "paramet.h"
+     INCLUDE 'comgeom.h'
+
+     TYPE(xios_duration) :: tstep_xios
+     TYPE(xios_date)                :: start_date
+     TYPE(xios_date)                :: time_origin
+     INTEGER :: an, mois, jour
+     REAL :: heure
+     CHARACTER (len=10) :: xios_cal_type
+     INTEGER :: anref, moisref, jourref
+     REAL :: heureref
+     REAL :: zdtvr
+     TYPE(xios_domain) :: dom_grid_U, dom_grid_V, dom_grid_T
+     REAL :: rlong(iip1), rlat(jjp1)
+     REAL :: pi
+     INTEGER :: ii, jj, jjb, jje, jjn
+
+!      WRITE(*,*)'Entree mod_xios_dyn3dmem'
+
+! 0 Initialisations
+     pi = 4. * ATAN (1.)
+! allocation of fields passed to xios
+!$OMP BARRIER
+!$OMP MASTER
+     allocate(NewField_U(iip1, jj_begin:jj_end, llm))
+     allocate(NewField_V(iip1, jj_begin:jj_end, llm))     
+!$OMP END MASTER
+!$OMP BARRIER
+
+! 1 Context initialisation
+!$OMP MASTER
+     CALL xios_context_initialize(dyn3d_ctx_name, g_comm)
+     CALL xios_get_handle(dyn3d_ctx_name, dyn3d_ctx_handle)
+     CALL xios_set_current_context(dyn3d_ctx_handle)  
+
+!     WRITE(*,*)'apres context initialisation mod_xios_dyn3dmem'
+
+! 2 calendar stuff
+
+     tstep_xios%second=zdtvr
+     CALL xios_define_calendar(type=xios_cal_type, start_date=xios_date(an, mois, jour,INT(heure),0,0), &
+            time_origin=xios_date(anref,moisref,jourref,INT(heureref),0,0), timestep=tstep_xios)
+
+!     WRITE(*,*)'apres  calendrier mod_xios_dyn3dmem'
+
+! 3 domain / grids / axis
+! Domains:
+      rlong(:) = rlonu(:) * 180. / pi
+      rlat(:) = rlatu(:) * 180. / pi
+
+      CALL xios_set_domain_attr("domain_U", ni_glo=iip1, nj_glo=jjp1,          &
+          type="rectilinear",ibegin=0, ni=iip1, jbegin=jj_begin-1, nj=jj_nb,   &
+          data_dim = 2, lonvalue_1d=rlong(1:iip1), latvalue_1d=rlat(jj_begin:jj_end))
+
+      jjb=jj_begin
+      jje=jj_end
+      jjn=jj_nb
+      IF (pole_sud) jjn=jjn-1
+      IF (pole_sud) jje=jje-1
+
+
+      rlong(:) = rlonv(:) * 180. / pi
+      do jj = jjb, jje
+        rlat(jj) = rlatv(jj) * 180. / pi
+      enddo
+      
+      CALL xios_set_domain_attr("domain_V", ni_glo=iip1, nj_glo=jjm,            &
+          type="rectilinear",ibegin=0, ni=iip1, jbegin=jj_begin-1, nj=jjn,   &
+          data_dim = 2, lonvalue_1d=rlong(1:iip1), latvalue_1d=rlat(jjb:jje))
+
+
+      rlong(:) = rlonv(:) * 180. / pi
+      rlat(:) = rlatu(:) * 180. / pi 
+      CALL xios_set_domain_attr("domain_T", ni_glo=iip1, nj_glo=jjp1,          &
+          type="rectilinear",ibegin=0, ni=iip1, jbegin=jj_begin-1, nj=jj_nb,   &
+          data_dim = 2, lonvalue_1d=rlong(1:iip1), latvalue_1d=rlat(jj_begin:jj_end))
+      
+!     WRITE(*,*)'apres  domaine mod_xios_dyn3dmem'
+! Vertical axis
+       CALL xios_set_axis_attr("presnivs",n_glo=llm,value=presnivs)
+!     WRITE(*,*)'apres  vertical axis mod_xios_dyn3dmem'
+! 4 end of context definition
+       CALL xios_close_context_definition()
+!     WRITE(*,*)'apres close context init. axis mod_xios_dyn3dmem'
+!$OMP END MASTER
+   END SUBROUTINE xios_dyn3dmem_init
+
+   SUBROUTINE  writefield_dyn1d_u(name,Field)
+
+     USE parallel_lmdz
+     IMPLICIT NONE
+     include 'dimensions.h'
+     include 'paramet.h'
+     CHARACTER(LEN=*)   :: name
+     REAL, DIMENSION(ij_begin:ij_end) :: Field
+     REAL, DIMENSION(iip1,  jj_begin:jj_end) :: NewField
+      LOGICAL,SAVE :: debuglf=.true.
+!$OMP THREADPRIVATE(debuglf)
+     
+     NewField(:,jj_begin:jj_end)=reshape(Field(ij_begin:ij_end),(/iip1,jj_nb/))
+
+!$OMP BARRIER       
+!$OMP MASTER
+     CALL xios_send_field(name, NewField)
+!$OMP END MASTER   
+  
+   END SUBROUTINE  writefield_dyn1d_u
+
+   SUBROUTINE  writefield_dyn2d_u(name,Field)
+
+     USE parallel_lmdz
+     IMPLICIT NONE
+     include 'dimensions.h'
+     include 'paramet.h'
+     CHARACTER(LEN=*)   :: name
+     REAL, DIMENSION(ij_begin:ij_end,llm) :: Field
+!     REAL, ALLOCATABLE, SAVE :: NewField(:,:,:)
+     INTEGER :: i,j,l, count
+
+!!!!!$OMP BARRIER
+!!!!!$OMP MASTER
+!!!!     allocate(NewField(iip1, jj_begin:jj_end, llm))
+!!!!!$OMP END MASTER
+!!!!!$OMP BARRIER
+
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) 
+     DO l = 1, llm
+       NewField_U(:,jj_begin:jj_end,l)=reshape(Field(ij_begin:ij_end,l),(/iip1,jj_nb/))
+     ENDDO
+!$OMP ENDDO
+!$OMP BARRIER 
+
+!$OMP MASTER
+     CALL xios_send_field(name, NewField_U)
+!!!!     DEALLOCATE(NewField)
+!$OMP END MASTER   
+!$OMP BARRIER
+  
+   END SUBROUTINE  writefield_dyn2d_u
+
+   SUBROUTINE  writefield_dyn1d_v(name,Field)
+
+     USE parallel_lmdz
+     IMPLICIT NONE
+     include 'dimensions.h'
+     include 'paramet.h'
+     CHARACTER(LEN=*)   :: name
+     REAL, DIMENSION(ij_begin:ij_end) :: Field
+     REAL, DIMENSION(iip1,  jj_begin:jj_end) :: NewField
+     INTEGER ::  jje, ije, jjn
+
+     IF (pole_sud) THEN
+       jje=jj_end-1
+       ije=ij_end-iip1
+       jjn=jj_nb-1
+     ELSE
+       jje=jj_end
+       ije=ij_end
+       jjn=jj_nb
+     ENDIF
+
+     NewField(:,jj_begin:jje)=reshape(Field(ij_begin:ije),(/iip1,jjn/))
+
+!$OMP BARRIER       
+!$OMP MASTER
+     CALL xios_send_field(name, NewField(:,jj_begin:jje))
+!$OMP END MASTER   
+  
+   END SUBROUTINE  writefield_dyn1d_v
+
+   SUBROUTINE  writefield_dyn2d_v(name,Field)
+
+     USE parallel_lmdz
+     IMPLICIT NONE
+     include 'dimensions.h'
+     include 'paramet.h'
+     CHARACTER(LEN=*)   :: name
+     REAL, DIMENSION(ij_begin:ij_end,llm) :: Field
+!!!!     REAL, ALLOCATABLE, SAVE :: NewField(:,:,:)
+     INTEGER :: l, jje, ije, jjn
+
+!!!!!$OMP BARRIER
+!!!!!$OMP MASTER
+!!!!     allocate(NewField(iip1,  jj_begin:jj_end,llm))
+!!!!!$OMP END MASTER
+!!!!!$OMP BARRIER
+
+     IF (pole_sud) THEN
+       jje=jj_end-1
+       ije=ij_end-iip1
+       jjn=jj_nb-1
+     ELSE
+       jje=jj_end
+       ije=ij_end
+       jjn=jj_nb
+     ENDIF
+
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+     DO l = 1, llm
+        NewField_V(:,jj_begin:jje,l)=reshape(Field(ij_begin:ije,l),(/iip1,jjn/))
+     ENDDO
+!$OMP ENDDO
+!$OMP BARRIER       
+
+!$OMP MASTER
+     CALL xios_send_field(name, NewField_V(:,jj_begin:jje,:))
+!!!!     DEALLOCATE(NewField)
+!$OMP END MASTER   
+!$OMP BARRIER 
+  
+   END SUBROUTINE  writefield_dyn2d_v
+   
+END MODULE mod_xios_dyn3dmem 
+
Index: DZ6/trunk/libf/dyn3dmem/nxgraro2_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/nxgraro2_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,39 +1,0 @@
-MODULE nxgraro2_mod
-
-  REAL,POINTER,SAVE ::  grx( :,: )
-  REAL,POINTER,SAVE ::  gry( :,: )
-  REAL,POINTER,SAVE ::  rot( :,: )
-  
-CONTAINS
-
-  SUBROUTINE nxgraro2_allocate
-  USE bands
-  USE allocate_field_mod
-  USE parallel_lmdz
-  USE dimensions_mod
-  IMPLICIT NONE
-    TYPE(distrib),POINTER :: d
-    d=>distrib_dissip
-
-    CALL allocate_u(grx,llm,d)
-    CALL allocate_v(gry,llm,d)
-    CALL allocate_v(rot,llm,d)
-
-    
-  END SUBROUTINE nxgraro2_allocate
-  
-  SUBROUTINE nxgraro2_switch_dissip(dist)
-  USE allocate_field_mod
-  USE bands
-  USE parallel_lmdz
-  IMPLICIT NONE
-    TYPE(distrib),INTENT(IN) :: dist
-
-    CALL switch_u(grx,distrib_dissip,dist)
-    CALL switch_v(gry,distrib_dissip,dist)
-    CALL switch_v(rot,distrib_dissip,dist)
-
-
-  END SUBROUTINE nxgraro2_switch_dissip
-  
-END MODULE nxgraro2_mod  
Index: /LMDZ6/trunk/libf/dyn3dmem/nxgraro2_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/nxgraro2_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3dmem/nxgraro2_mod.f90	(revision 5268)
@@ -0,0 +1,39 @@
+MODULE nxgraro2_mod
+
+  REAL,POINTER,SAVE ::  grx( :,: )
+  REAL,POINTER,SAVE ::  gry( :,: )
+  REAL,POINTER,SAVE ::  rot( :,: )
+  
+CONTAINS
+
+  SUBROUTINE nxgraro2_allocate
+  USE bands
+  USE allocate_field_mod
+  USE parallel_lmdz
+  USE dimensions_mod
+  IMPLICIT NONE
+    TYPE(distrib),POINTER :: d
+    d=>distrib_dissip
+
+    CALL allocate_u(grx,llm,d)
+    CALL allocate_v(gry,llm,d)
+    CALL allocate_v(rot,llm,d)
+
+    
+  END SUBROUTINE nxgraro2_allocate
+  
+  SUBROUTINE nxgraro2_switch_dissip(dist)
+  USE allocate_field_mod
+  USE bands
+  USE parallel_lmdz
+  IMPLICIT NONE
+    TYPE(distrib),INTENT(IN) :: dist
+
+    CALL switch_u(grx,distrib_dissip,dist)
+    CALL switch_v(gry,distrib_dissip,dist)
+    CALL switch_v(rot,distrib_dissip,dist)
+
+
+  END SUBROUTINE nxgraro2_switch_dissip
+  
+END MODULE nxgraro2_mod  
Index: DZ6/trunk/libf/dyn3dmem/temps_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/temps_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,35 +1,0 @@
-!
-! $Id: temps_mod.F90 -1   $
-!
-MODULE temps_mod
-
-IMPLICIT NONE  
-
-  INTEGER   itaufin ! total number of dynamical steps for the run
-  INTEGER   itau_dyn
-  INTEGER   itau_phy
-  INTEGER   day_ini ! initial day # of simulation sequence
-  INTEGER   day_end ! final day # ; i.e. day # when this simulation ends
-  INTEGER   annee_ref
-  INTEGER   day_ref
-  INTEGER   year_len
-  REAL      dt ! (dynamics) time step (changes if doing Matsuno or LF step)
-  REAL      jD_ref ! reference julian day date (beginning of experiment)
-  REAL      jH_ref ! reference julian "hour" of reference julian date
-  REAL      start_time
-  CHARACTER (len=10) :: calend ! calendar type
-  INTEGER   offline_time ! offline frequency storage
-
-  ! Additionnal Mars stuff:
-  REAL hour_ini ! initial fraction of day of simulation sequence (0=<hour_ini<1)
-
-!$OMP THREADPRIVATE(dt,jD_ref,jH_ref,start_time,hour_ini,                        &
-!$OMP                day_ini,day_end,annee_ref,day_ref,itau_dyn,itau_phy,itaufin,&
-!$OMP                calend)        
-
-!WARNING: when adding a threadprivate variable in this module
-!        do not forget to add it to the copyin clause when opening an OpenMP
-!        parallel section. e.g. in gcm before call leapfrog_loc and/or
-!        possibly in iniphysiq
-
-END MODULE temps_mod
Index: /LMDZ6/trunk/libf/dyn3dmem/temps_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/temps_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3dmem/temps_mod.f90	(revision 5268)
@@ -0,0 +1,35 @@
+!
+! $Id: temps_mod.F90 -1   $
+!
+MODULE temps_mod
+
+IMPLICIT NONE  
+
+  INTEGER   itaufin ! total number of dynamical steps for the run
+  INTEGER   itau_dyn
+  INTEGER   itau_phy
+  INTEGER   day_ini ! initial day # of simulation sequence
+  INTEGER   day_end ! final day # ; i.e. day # when this simulation ends
+  INTEGER   annee_ref
+  INTEGER   day_ref
+  INTEGER   year_len
+  REAL      dt ! (dynamics) time step (changes if doing Matsuno or LF step)
+  REAL      jD_ref ! reference julian day date (beginning of experiment)
+  REAL      jH_ref ! reference julian "hour" of reference julian date
+  REAL      start_time
+  CHARACTER (len=10) :: calend ! calendar type
+  INTEGER   offline_time ! offline frequency storage
+
+  ! Additionnal Mars stuff:
+  REAL hour_ini ! initial fraction of day of simulation sequence (0=<hour_ini<1)
+
+!$OMP THREADPRIVATE(dt,jD_ref,jH_ref,start_time,hour_ini,                        &
+!$OMP                day_ini,day_end,annee_ref,day_ref,itau_dyn,itau_phy,itaufin,&
+!$OMP                calend)        
+
+!WARNING: when adding a threadprivate variable in this module
+!        do not forget to add it to the copyin clause when opening an OpenMP
+!        parallel section. e.g. in gcm before call leapfrog_loc and/or
+!        possibly in iniphysiq
+
+END MODULE temps_mod
Index: DZ6/trunk/libf/dyn3dmem/times.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/times.F90	(revision 5267)
+++ 	(revision )
@@ -1,235 +1,0 @@
-module times
-  integer,private,save :: Last_Count=0
-  real, private,save :: Last_cpuCount=0
-  logical, private,save :: AllTimer_IsActive=.false.
-  
-  integer, parameter :: nb_timer = 4
-  integer, parameter :: timer_caldyn  = 1
-  integer, parameter :: timer_vanleer = 2
-  integer, parameter :: timer_dissip = 3
-  integer, parameter :: timer_physic = 4
-  integer, parameter :: stopped = 1
-  integer, parameter :: running = 2
-  integer, parameter :: suspended = 3 
-  
-  integer :: max_size
-  real,    allocatable, dimension(:,:,:) :: timer_table
-  real,    allocatable, dimension(:,:,:) :: timer_table_sqr 
-  integer, allocatable, dimension(:,:,:) :: timer_iteration
-  real,    allocatable, dimension(:,:,:) :: timer_average
-  real,    allocatable, dimension(:,:,:) :: timer_delta
-  real,    allocatable,dimension(:) :: timer_running, last_time
-  integer, allocatable,dimension(:) :: timer_state
-  
-  contains
-  
-  subroutine init_timer
-    USE parallel_lmdz
-    implicit none
-    INCLUDE "dimensions.h"
-    INCLUDE "paramet.h"
-    
-    max_size=jjm+1
-    allocate(timer_table(max_size,nb_timer,0:mpi_size-1))
-    allocate(timer_table_sqr(max_size,nb_timer,0:mpi_size-1))
-    allocate(timer_iteration(max_size,nb_timer,0:mpi_size-1))
-    allocate(timer_average(max_size,nb_timer,0:mpi_size-1))
-    allocate(timer_delta(max_size,nb_timer,0:mpi_size-1))
-    allocate(timer_running(nb_timer))
-    allocate(timer_state(nb_timer))
-    allocate(last_time(nb_timer))
-    
-    timer_table(:,:,:)=0
-    timer_table_sqr(:,:,:)=0
-    timer_iteration(:,:,:)=0
-    timer_average(:,:,:)=0
-    timer_delta(:,:,:)=0
-    timer_state(:)=stopped      
-  end subroutine init_timer
-  
-  subroutine start_timer(no_timer)
-    implicit none
-    integer :: no_timer
-    
-    if (AllTimer_IsActive) then
-    
-      if (timer_state(no_timer)/=stopped) then
-        CALL abort_gcm("times","start_timer :: timer is already running or suspended",1)
-      else
-        timer_state(no_timer)=running
-      endif
-      
-      timer_running(no_timer)=0
-      call cpu_time(last_time(no_timer))
-    
-    endif
-    
-  end subroutine start_timer
-  
-  subroutine suspend_timer(no_timer)
-    implicit none
-    integer :: no_timer
-     
-    if (AllTimer_IsActive) then   
-      if (timer_state(no_timer)/=running) then
-         CALL abort_gcm("times","suspend_timer :: timer is not running",1)
-      else
-        timer_state(no_timer)=suspended
-      endif
-    
-      timer_running(no_timer)=timer_running(no_timer)-last_time(no_timer)
-      call cpu_time(last_time(no_timer))
-      timer_running(no_timer)=timer_running(no_timer)+last_time(no_timer)
-    endif
-  end subroutine suspend_timer
-  
-  subroutine resume_timer(no_timer)
-    implicit none
-    integer :: no_timer
-     
-    if (AllTimer_IsActive) then   
-      if (timer_state(no_timer)/=suspended) then
-        CALL abort_gcm("times","resume_timer :: timer is not suspended",1)
-      else
-        timer_state(no_timer)=running
-      endif
-      
-      call cpu_time(last_time(no_timer))
-    endif
-    
-  end subroutine resume_timer
-
-  subroutine stop_timer(no_timer)
-    USE parallel_lmdz
-    implicit none
-    integer :: no_timer
-    integer :: N
-    real :: V,V2
-    
-    if (AllTimer_IsActive) then
-       
-      if (timer_state(no_timer)/=running) then
-        CALL abort_gcm("times","stop_timer :: timer is not running",1)
-      else
-        timer_state(no_timer)=stopped
-      endif
-    
-      timer_running(no_timer)=timer_running(no_timer)-last_time(no_timer)
-      call cpu_time(last_time(no_timer))
-      timer_running(no_timer)=timer_running(no_timer)+last_time(no_timer)
-    
-      timer_table(jj_nb,no_timer,mpi_rank)=timer_table(jj_nb,no_timer,mpi_rank)+timer_running(no_timer)
-      timer_table_sqr(jj_nb,no_timer,mpi_rank)=timer_table_sqr(jj_nb,no_timer,mpi_rank)+timer_running(no_timer)**2
-      timer_iteration(jj_nb,no_timer,mpi_rank)=timer_iteration(jj_nb,no_timer,mpi_rank)+1
-      timer_average(jj_nb,no_timer,mpi_rank)=timer_table(jj_nb,no_timer,mpi_rank)/timer_iteration(jj_nb,no_timer,mpi_rank)
-      if (timer_iteration(jj_nb,no_timer,mpi_rank)>=2) then
-        N=timer_iteration(jj_nb,no_timer,mpi_rank)
-	V2=timer_table_sqr(jj_nb,no_timer,mpi_rank)
-	V=timer_table(jj_nb,no_timer,mpi_rank)
-	timer_delta(jj_nb,no_timer,mpi_rank)=sqrt(ABS(V2-V*V/N)/(N-1)) 
-      else
-        timer_delta(jj_nb,no_timer,mpi_rank)=0
-      endif
-    endif
-    
-  end subroutine stop_timer
-   
-  subroutine allgather_timer
-    USE parallel_lmdz
-    USE lmdz_mpi
-    implicit none
-
-    integer :: ierr
-    integer :: data_size
-    real, allocatable,dimension(:,:) :: tmp_table
-
-    IF (using_mpi) THEN    
-   
-      if (AllTimer_IsActive) then
-    
-    
-      allocate(tmp_table(max_size,nb_timer))
-    
-      data_size=max_size*nb_timer
-    
-      tmp_table(:,:)=timer_table(:,:,mpi_rank)
-      call mpi_allgather(tmp_table(1,1),data_size,MPI_REAL_LMDZ,timer_table(1,1,0),data_size,MPI_REAL_LMDZ,COMM_LMDZ,ierr)
-      tmp_table(:,:)=timer_table_sqr(:,:,mpi_rank)
-      call mpi_allgather(tmp_table(1,1),data_size,MPI_REAL_LMDZ,timer_table_sqr(1,1,0),data_size,MPI_REAL_LMDZ,COMM_LMDZ,ierr)
-      deallocate(tmp_table)
-    
-      endif
-      
-    ENDIF ! using_mpi
-    
-  end subroutine allgather_timer
-  
-  subroutine allgather_timer_average
-    USE parallel_lmdz
-    USE lmdz_mpi
-    implicit none
-    integer :: ierr
-    integer :: data_size
-    real, allocatable,dimension(:,:),target :: tmp_table
-    integer, allocatable,dimension(:,:),target :: tmp_iter
-    integer :: istats
-
-    IF (using_mpi) THEN
-        
-      if (AllTimer_IsActive) then
-    
-      allocate(tmp_table(max_size,nb_timer))
-      allocate(tmp_iter(max_size,nb_timer))
-   
-      data_size=max_size*nb_timer
-
-      tmp_table(:,:)=timer_average(:,:,mpi_rank)
-      call mpi_allgather(tmp_table(1,1),data_size,MPI_REAL_LMDZ,timer_average(1,1,0),data_size,MPI_REAL_LMDZ,COMM_LMDZ,ierr)
-      tmp_table(:,:)=timer_delta(:,:,mpi_rank)
-      call mpi_allgather(tmp_table(1,1),data_size,MPI_REAL_LMDZ,timer_delta(1,1,0),data_size,MPI_REAL_LMDZ,COMM_LMDZ,ierr)
-      tmp_iter(:,:)=timer_iteration(:,:,mpi_rank)
-      call mpi_allgather(tmp_iter(1,1),data_size,MPI_INTEGER,timer_iteration(1,1,0),data_size,MPI_INTEGER,COMM_LMDZ,ierr)
-      deallocate(tmp_table)
-    
-      endif
-      
-    ENDIF  ! using_mp�
-  end subroutine allgather_timer_average
-  
-  subroutine InitTime
-  implicit none
-    integer :: count,count_rate,count_max
-    
-    AllTimer_IsActive=.TRUE.
-    if (AllTimer_IsActive) then
-      call system_clock(count,count_rate,count_max)
-      call cpu_time(Last_cpuCount)
-      Last_Count=count
-    endif
-  end subroutine InitTime
-  
-  function DiffTime()
-  implicit none
-    double precision :: DiffTime
-    integer :: count,count_rate,count_max
-  
-    call system_clock(count,count_rate,count_max)
-    if (Count>=Last_Count) then
-      DiffTime=(1.*(Count-last_Count))/count_rate
-    else
-      DiffTime=(1.*(Count-last_Count+Count_max))/count_rate
-    endif
-    Last_Count=Count 
-  end function DiffTime
-  
-  function DiffCpuTime()
-  implicit none
-    real :: DiffCpuTime
-    real :: Count
-    
-    call cpu_time(Count)
-    DiffCpuTime=Count-Last_cpuCount
-    Last_cpuCount=Count 
-  end function DiffCpuTime
-
-end module times
Index: /LMDZ6/trunk/libf/dyn3dmem/times.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/times.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3dmem/times.f90	(revision 5268)
@@ -0,0 +1,235 @@
+module times
+  integer,private,save :: Last_Count=0
+  real, private,save :: Last_cpuCount=0
+  logical, private,save :: AllTimer_IsActive=.false.
+  
+  integer, parameter :: nb_timer = 4
+  integer, parameter :: timer_caldyn  = 1
+  integer, parameter :: timer_vanleer = 2
+  integer, parameter :: timer_dissip = 3
+  integer, parameter :: timer_physic = 4
+  integer, parameter :: stopped = 1
+  integer, parameter :: running = 2
+  integer, parameter :: suspended = 3 
+  
+  integer :: max_size
+  real,    allocatable, dimension(:,:,:) :: timer_table
+  real,    allocatable, dimension(:,:,:) :: timer_table_sqr 
+  integer, allocatable, dimension(:,:,:) :: timer_iteration
+  real,    allocatable, dimension(:,:,:) :: timer_average
+  real,    allocatable, dimension(:,:,:) :: timer_delta
+  real,    allocatable,dimension(:) :: timer_running, last_time
+  integer, allocatable,dimension(:) :: timer_state
+  
+  contains
+  
+  subroutine init_timer
+    USE parallel_lmdz
+    implicit none
+    INCLUDE "dimensions.h"
+    INCLUDE "paramet.h"
+    
+    max_size=jjm+1
+    allocate(timer_table(max_size,nb_timer,0:mpi_size-1))
+    allocate(timer_table_sqr(max_size,nb_timer,0:mpi_size-1))
+    allocate(timer_iteration(max_size,nb_timer,0:mpi_size-1))
+    allocate(timer_average(max_size,nb_timer,0:mpi_size-1))
+    allocate(timer_delta(max_size,nb_timer,0:mpi_size-1))
+    allocate(timer_running(nb_timer))
+    allocate(timer_state(nb_timer))
+    allocate(last_time(nb_timer))
+    
+    timer_table(:,:,:)=0
+    timer_table_sqr(:,:,:)=0
+    timer_iteration(:,:,:)=0
+    timer_average(:,:,:)=0
+    timer_delta(:,:,:)=0
+    timer_state(:)=stopped      
+  end subroutine init_timer
+  
+  subroutine start_timer(no_timer)
+    implicit none
+    integer :: no_timer
+    
+    if (AllTimer_IsActive) then
+    
+      if (timer_state(no_timer)/=stopped) then
+        CALL abort_gcm("times","start_timer :: timer is already running or suspended",1)
+      else
+        timer_state(no_timer)=running
+      endif
+      
+      timer_running(no_timer)=0
+      call cpu_time(last_time(no_timer))
+    
+    endif
+    
+  end subroutine start_timer
+  
+  subroutine suspend_timer(no_timer)
+    implicit none
+    integer :: no_timer
+     
+    if (AllTimer_IsActive) then   
+      if (timer_state(no_timer)/=running) then
+         CALL abort_gcm("times","suspend_timer :: timer is not running",1)
+      else
+        timer_state(no_timer)=suspended
+      endif
+    
+      timer_running(no_timer)=timer_running(no_timer)-last_time(no_timer)
+      call cpu_time(last_time(no_timer))
+      timer_running(no_timer)=timer_running(no_timer)+last_time(no_timer)
+    endif
+  end subroutine suspend_timer
+  
+  subroutine resume_timer(no_timer)
+    implicit none
+    integer :: no_timer
+     
+    if (AllTimer_IsActive) then   
+      if (timer_state(no_timer)/=suspended) then
+        CALL abort_gcm("times","resume_timer :: timer is not suspended",1)
+      else
+        timer_state(no_timer)=running
+      endif
+      
+      call cpu_time(last_time(no_timer))
+    endif
+    
+  end subroutine resume_timer
+
+  subroutine stop_timer(no_timer)
+    USE parallel_lmdz
+    implicit none
+    integer :: no_timer
+    integer :: N
+    real :: V,V2
+    
+    if (AllTimer_IsActive) then
+       
+      if (timer_state(no_timer)/=running) then
+        CALL abort_gcm("times","stop_timer :: timer is not running",1)
+      else
+        timer_state(no_timer)=stopped
+      endif
+    
+      timer_running(no_timer)=timer_running(no_timer)-last_time(no_timer)
+      call cpu_time(last_time(no_timer))
+      timer_running(no_timer)=timer_running(no_timer)+last_time(no_timer)
+    
+      timer_table(jj_nb,no_timer,mpi_rank)=timer_table(jj_nb,no_timer,mpi_rank)+timer_running(no_timer)
+      timer_table_sqr(jj_nb,no_timer,mpi_rank)=timer_table_sqr(jj_nb,no_timer,mpi_rank)+timer_running(no_timer)**2
+      timer_iteration(jj_nb,no_timer,mpi_rank)=timer_iteration(jj_nb,no_timer,mpi_rank)+1
+      timer_average(jj_nb,no_timer,mpi_rank)=timer_table(jj_nb,no_timer,mpi_rank)/timer_iteration(jj_nb,no_timer,mpi_rank)
+      if (timer_iteration(jj_nb,no_timer,mpi_rank)>=2) then
+        N=timer_iteration(jj_nb,no_timer,mpi_rank)
+	V2=timer_table_sqr(jj_nb,no_timer,mpi_rank)
+	V=timer_table(jj_nb,no_timer,mpi_rank)
+	timer_delta(jj_nb,no_timer,mpi_rank)=sqrt(ABS(V2-V*V/N)/(N-1)) 
+      else
+        timer_delta(jj_nb,no_timer,mpi_rank)=0
+      endif
+    endif
+    
+  end subroutine stop_timer
+   
+  subroutine allgather_timer
+    USE parallel_lmdz
+    USE lmdz_mpi
+    implicit none
+
+    integer :: ierr
+    integer :: data_size
+    real, allocatable,dimension(:,:) :: tmp_table
+
+    IF (using_mpi) THEN    
+   
+      if (AllTimer_IsActive) then
+    
+    
+      allocate(tmp_table(max_size,nb_timer))
+    
+      data_size=max_size*nb_timer
+    
+      tmp_table(:,:)=timer_table(:,:,mpi_rank)
+      call mpi_allgather(tmp_table(1,1),data_size,MPI_REAL_LMDZ,timer_table(1,1,0),data_size,MPI_REAL_LMDZ,COMM_LMDZ,ierr)
+      tmp_table(:,:)=timer_table_sqr(:,:,mpi_rank)
+      call mpi_allgather(tmp_table(1,1),data_size,MPI_REAL_LMDZ,timer_table_sqr(1,1,0),data_size,MPI_REAL_LMDZ,COMM_LMDZ,ierr)
+      deallocate(tmp_table)
+    
+      endif
+      
+    ENDIF ! using_mpi
+    
+  end subroutine allgather_timer
+  
+  subroutine allgather_timer_average
+    USE parallel_lmdz
+    USE lmdz_mpi
+    implicit none
+    integer :: ierr
+    integer :: data_size
+    real, allocatable,dimension(:,:),target :: tmp_table
+    integer, allocatable,dimension(:,:),target :: tmp_iter
+    integer :: istats
+
+    IF (using_mpi) THEN
+        
+      if (AllTimer_IsActive) then
+    
+      allocate(tmp_table(max_size,nb_timer))
+      allocate(tmp_iter(max_size,nb_timer))
+   
+      data_size=max_size*nb_timer
+
+      tmp_table(:,:)=timer_average(:,:,mpi_rank)
+      call mpi_allgather(tmp_table(1,1),data_size,MPI_REAL_LMDZ,timer_average(1,1,0),data_size,MPI_REAL_LMDZ,COMM_LMDZ,ierr)
+      tmp_table(:,:)=timer_delta(:,:,mpi_rank)
+      call mpi_allgather(tmp_table(1,1),data_size,MPI_REAL_LMDZ,timer_delta(1,1,0),data_size,MPI_REAL_LMDZ,COMM_LMDZ,ierr)
+      tmp_iter(:,:)=timer_iteration(:,:,mpi_rank)
+      call mpi_allgather(tmp_iter(1,1),data_size,MPI_INTEGER,timer_iteration(1,1,0),data_size,MPI_INTEGER,COMM_LMDZ,ierr)
+      deallocate(tmp_table)
+    
+      endif
+      
+    ENDIF  ! using_mp�
+  end subroutine allgather_timer_average
+  
+  subroutine InitTime
+  implicit none
+    integer :: count,count_rate,count_max
+    
+    AllTimer_IsActive=.TRUE.
+    if (AllTimer_IsActive) then
+      call system_clock(count,count_rate,count_max)
+      call cpu_time(Last_cpuCount)
+      Last_Count=count
+    endif
+  end subroutine InitTime
+  
+  function DiffTime()
+  implicit none
+    double precision :: DiffTime
+    integer :: count,count_rate,count_max
+  
+    call system_clock(count,count_rate,count_max)
+    if (Count>=Last_Count) then
+      DiffTime=(1.*(Count-last_Count))/count_rate
+    else
+      DiffTime=(1.*(Count-last_Count+Count_max))/count_rate
+    endif
+    Last_Count=Count 
+  end function DiffTime
+  
+  function DiffCpuTime()
+  implicit none
+    real :: DiffCpuTime
+    real :: Count
+    
+    call cpu_time(Count)
+    DiffCpuTime=Count-Last_cpuCount
+    Last_cpuCount=Count 
+  end function DiffCpuTime
+
+end module times
Index: DZ6/trunk/libf/dyn3dmem/tourpot_loc.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/tourpot_loc.F90	(revision 5267)
+++ 	(revision )
@@ -1,64 +1,0 @@
-SUBROUTINE tourpot_loc ( vcov, ucov, massebxy, vorpot )
-!
-!-------------------------------------------------------------------------------
-! Authors: P. Le Van.
-!-------------------------------------------------------------------------------
-! Purpose: Compute potential vorticity.
-  USE parallel_lmdz
-  USE mod_filtreg_p
-  IMPLICIT NONE
-  include "dimensions.h"
-  include "paramet.h"
-  include "comgeom.h"
-!===============================================================================
-! Arguments:
-  REAL, INTENT(IN)  :: vcov    (ijb_v:ije_v,llm)
-  REAL, INTENT(IN)  :: ucov    (ijb_u:ije_u,llm)
-  REAL, INTENT(IN)  :: massebxy(ijb_v:ije_v,llm)
-  REAL, INTENT(OUT) :: vorpot  (ijb_v:ije_v,llm)
-!===============================================================================
-! Method used:
-!   vorpot = ( Filtre( d(vcov)/dx - d(ucov)/dy ) + fext ) /psbarxy
-!===============================================================================
-! Local variables:
-  INTEGER :: l, ij, ije, ijb, jje, jjb
-  REAL    :: rot(ijb_v:ije_v,llm)
-!===============================================================================
-
-  ijb=ij_begin-iip1
-  ije=ij_end
-  IF(pole_nord) ijb=ij_begin
-
-!--- Wind vorticity ; correction: rot(iip1,j,l) = rot(1,j,l)
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-  DO l=1,llm
-    IF(pole_sud) ije=ij_end-iip1-1
-    DO ij=ijb,ije
-      rot(ij,l)=vcov(ij+1,l)-vcov(ij,l)+ucov(ij+iip1,l)-ucov(ij,l)
-    END DO
-    IF(pole_sud) ije=ij_end-iip1
-    DO ij=ijb+iip1-1,ije,iip1; rot(ij,l)=rot(ij-iim,l); END DO
-  END DO
-!$OMP END DO NOWAIT
-
-!--- Filter
-  jjb=jj_begin-1
-  jje=jj_end
-  IF(pole_nord) jjb=jjb+1
-  IF(pole_sud)  jje=jje-1
-  CALL filtreg_p(rot,jjb_v,jje_v,jjb,jje,jjm,llm,2,1,.FALSE.,1)
-
-!--- Potential vorticity ; correction: rot(iip1,j,l) = rot(1,j,l)
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-  DO l=1,llm
-    IF(pole_sud) ije=ij_end-iip1-1
-    DO ij=ijb,ije
-      vorpot(ij,l)=(rot(ij,l)+fext(ij))/massebxy(ij,l)
-    END DO
-    IF(pole_sud) ije=ij_end-iip1
-    DO ij=ijb+iip1-1,ije,iip1; vorpot(ij,l)=vorpot(ij-iim,l); END DO
-  END DO
-!$OMP END DO NOWAIT
-
-END SUBROUTINE tourpot_loc
-
Index: /LMDZ6/trunk/libf/dyn3dmem/tourpot_loc.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/tourpot_loc.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3dmem/tourpot_loc.f90	(revision 5268)
@@ -0,0 +1,64 @@
+SUBROUTINE tourpot_loc ( vcov, ucov, massebxy, vorpot )
+!
+!-------------------------------------------------------------------------------
+! Authors: P. Le Van.
+!-------------------------------------------------------------------------------
+! Purpose: Compute potential vorticity.
+  USE parallel_lmdz
+  USE mod_filtreg_p
+  IMPLICIT NONE
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom.h"
+!===============================================================================
+! Arguments:
+  REAL, INTENT(IN)  :: vcov    (ijb_v:ije_v,llm)
+  REAL, INTENT(IN)  :: ucov    (ijb_u:ije_u,llm)
+  REAL, INTENT(IN)  :: massebxy(ijb_v:ije_v,llm)
+  REAL, INTENT(OUT) :: vorpot  (ijb_v:ije_v,llm)
+!===============================================================================
+! Method used:
+!   vorpot = ( Filtre( d(vcov)/dx - d(ucov)/dy ) + fext ) /psbarxy
+!===============================================================================
+! Local variables:
+  INTEGER :: l, ij, ije, ijb, jje, jjb
+  REAL    :: rot(ijb_v:ije_v,llm)
+!===============================================================================
+
+  ijb=ij_begin-iip1
+  ije=ij_end
+  IF(pole_nord) ijb=ij_begin
+
+!--- Wind vorticity ; correction: rot(iip1,j,l) = rot(1,j,l)
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,llm
+    IF(pole_sud) ije=ij_end-iip1-1
+    DO ij=ijb,ije
+      rot(ij,l)=vcov(ij+1,l)-vcov(ij,l)+ucov(ij+iip1,l)-ucov(ij,l)
+    END DO
+    IF(pole_sud) ije=ij_end-iip1
+    DO ij=ijb+iip1-1,ije,iip1; rot(ij,l)=rot(ij-iim,l); END DO
+  END DO
+!$OMP END DO NOWAIT
+
+!--- Filter
+  jjb=jj_begin-1
+  jje=jj_end
+  IF(pole_nord) jjb=jjb+1
+  IF(pole_sud)  jje=jje-1
+  CALL filtreg_p(rot,jjb_v,jje_v,jjb,jje,jjm,llm,2,1,.FALSE.,1)
+
+!--- Potential vorticity ; correction: rot(iip1,j,l) = rot(1,j,l)
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  DO l=1,llm
+    IF(pole_sud) ije=ij_end-iip1-1
+    DO ij=ijb,ije
+      vorpot(ij,l)=(rot(ij,l)+fext(ij))/massebxy(ij,l)
+    END DO
+    IF(pole_sud) ije=ij_end-iip1
+    DO ij=ijb+iip1-1,ije,iip1; vorpot(ij,l)=vorpot(ij-iim,l); END DO
+  END DO
+!$OMP END DO NOWAIT
+
+END SUBROUTINE tourpot_loc
+
Index: DZ6/trunk/libf/dyn3dmem/vitvert_loc.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/vitvert_loc.F90	(revision 5267)
+++ 	(revision )
@@ -1,39 +1,0 @@
-SUBROUTINE vitvert_loc(convm, w)
-!
-!-------------------------------------------------------------------------------
-! Authors: P. Le Van , Fr. Hourdin.
-!-------------------------------------------------------------------------------
-! Purpose: Compute vertical speed at sigma levels.
-  USE parallel_lmdz
-  USE comvert_mod, ONLY: bp
-  
-  IMPLICIT NONE
-  include "dimensions.h"
-  include "paramet.h"
-!===============================================================================
-! Arguments:
-  REAL, INTENT(IN)  :: convm(ijb_u:ije_u,llm)
-  REAL, INTENT(OUT) :: w    (ijb_u:ije_u,llm)
-!===============================================================================
-! Notes: Vertical speed is oriented from bottom to top.
-!   * At ground - level sigma(1):     w(i,j,1) = 0.
-!   * At top    - level sigma(llm+1): w(i,j,l) = 0. (not stored in w)
-!===============================================================================
-! Local variables:
-  INTEGER :: l, ijb, ije
-!===============================================================================
-  ijb=ij_begin
-  ije=ij_end+iip1
-  IF(pole_sud) ije=ij_end
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
-  DO l=1,llmm1
-    w(ijb:ije,l+1)=convm(ijb:ije,l+1)-bp(l+1)*convm(ijb:ije,1)
-  END DO
-!$OMP END DO
-!$OMP MASTER
-  w(ijb:ije,1)=0.
-!$OMP END MASTER
-!$OMP BARRIER
-
-END SUBROUTINE vitvert_loc
-
Index: /LMDZ6/trunk/libf/dyn3dmem/vitvert_loc.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/vitvert_loc.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3dmem/vitvert_loc.f90	(revision 5268)
@@ -0,0 +1,39 @@
+SUBROUTINE vitvert_loc(convm, w)
+!
+!-------------------------------------------------------------------------------
+! Authors: P. Le Van , Fr. Hourdin.
+!-------------------------------------------------------------------------------
+! Purpose: Compute vertical speed at sigma levels.
+  USE parallel_lmdz
+  USE comvert_mod, ONLY: bp
+  
+  IMPLICIT NONE
+  include "dimensions.h"
+  include "paramet.h"
+!===============================================================================
+! Arguments:
+  REAL, INTENT(IN)  :: convm(ijb_u:ije_u,llm)
+  REAL, INTENT(OUT) :: w    (ijb_u:ije_u,llm)
+!===============================================================================
+! Notes: Vertical speed is oriented from bottom to top.
+!   * At ground - level sigma(1):     w(i,j,1) = 0.
+!   * At top    - level sigma(llm+1): w(i,j,l) = 0. (not stored in w)
+!===============================================================================
+! Local variables:
+  INTEGER :: l, ijb, ije
+!===============================================================================
+  ijb=ij_begin
+  ije=ij_end+iip1
+  IF(pole_sud) ije=ij_end
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)      
+  DO l=1,llmm1
+    w(ijb:ije,l+1)=convm(ijb:ije,l+1)-bp(l+1)*convm(ijb:ije,1)
+  END DO
+!$OMP END DO
+!$OMP MASTER
+  w(ijb:ije,1)=0.
+!$OMP END MASTER
+!$OMP BARRIER
+
+END SUBROUTINE vitvert_loc
+
Index: DZ6/trunk/libf/dyn3dmem/vlspltgen_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/vlspltgen_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,54 +1,0 @@
-MODULE vlspltgen_mod
-
-  REAL,POINTER,SAVE :: qsat(:,:)
-  REAL,POINTER,SAVE :: mu(:,:) ! CRisi: on ajoute une dimension
-  REAL,POINTER,SAVE :: mv(:,:)
-  REAL,POINTER,SAVE :: mw(:,:,:)
-  REAL,POINTER,SAVE :: zm(:,:,:)
-  REAL,POINTER,SAVE :: zq(:,:,:)
- 
-CONTAINS
-
-  SUBROUTINE vlspltgen_allocate
-  USE bands
-  USE allocate_field_mod
-  USE parallel_lmdz
-  USE infotrac
-  USE vlz_mod,ONLY : vlz_allocate 
-  IMPLICIT NONE
-  INCLUDE "dimensions.h"
-  INCLUDE "paramet.h"
-  TYPE(distrib),POINTER :: d
-    
-    d=>distrib_vanleer
-    CALL allocate_u(qsat,llm,d)
-    CALL allocate_u(mu,llm,d)
-    CALL allocate_v(mv,llm,d)
-    CALL allocate_u(mw,llm+1,nqtot,d)
-    CALL allocate_u(zm,llm,nqtot,d)
-    CALL allocate_u(zq,llm,nqtot,d)
-
-    CALL vlz_allocate
-
-  END SUBROUTINE vlspltgen_allocate
-  
-  SUBROUTINE vlspltgen_switch_vanleer(dist)
-  USE allocate_field_mod
-  USE bands
-  USE parallel_lmdz
-  USE vlz_mod,ONLY : vlz_switch_vanleer 
-  IMPLICIT NONE
-    TYPE(distrib),INTENT(IN) :: dist
-  
-    CALL switch_u(qsat,distrib_vanleer,dist)
-    CALL switch_u(mu,distrib_vanleer,dist)
-    CALL switch_u(mv,distrib_vanleer,dist)
-    CALL switch_u(mw,distrib_vanleer,dist)
-    CALL switch_u(zm,distrib_vanleer,dist)
-    CALL switch_u(zq,distrib_vanleer,dist)
-
-    CALL vlz_switch_vanleer(dist)
-
-  END SUBROUTINE vlspltgen_switch_vanleer  
-  
-END MODULE vlspltgen_mod  
Index: /LMDZ6/trunk/libf/dyn3dmem/vlspltgen_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/vlspltgen_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3dmem/vlspltgen_mod.f90	(revision 5268)
@@ -0,0 +1,54 @@
+MODULE vlspltgen_mod
+
+  REAL,POINTER,SAVE :: qsat(:,:)
+  REAL,POINTER,SAVE :: mu(:,:) ! CRisi: on ajoute une dimension
+  REAL,POINTER,SAVE :: mv(:,:)
+  REAL,POINTER,SAVE :: mw(:,:,:)
+  REAL,POINTER,SAVE :: zm(:,:,:)
+  REAL,POINTER,SAVE :: zq(:,:,:)
+ 
+CONTAINS
+
+  SUBROUTINE vlspltgen_allocate
+  USE bands
+  USE allocate_field_mod
+  USE parallel_lmdz
+  USE infotrac
+  USE vlz_mod,ONLY : vlz_allocate 
+  IMPLICIT NONE
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  TYPE(distrib),POINTER :: d
+    
+    d=>distrib_vanleer
+    CALL allocate_u(qsat,llm,d)
+    CALL allocate_u(mu,llm,d)
+    CALL allocate_v(mv,llm,d)
+    CALL allocate_u(mw,llm+1,nqtot,d)
+    CALL allocate_u(zm,llm,nqtot,d)
+    CALL allocate_u(zq,llm,nqtot,d)
+
+    CALL vlz_allocate
+
+  END SUBROUTINE vlspltgen_allocate
+  
+  SUBROUTINE vlspltgen_switch_vanleer(dist)
+  USE allocate_field_mod
+  USE bands
+  USE parallel_lmdz
+  USE vlz_mod,ONLY : vlz_switch_vanleer 
+  IMPLICIT NONE
+    TYPE(distrib),INTENT(IN) :: dist
+  
+    CALL switch_u(qsat,distrib_vanleer,dist)
+    CALL switch_u(mu,distrib_vanleer,dist)
+    CALL switch_u(mv,distrib_vanleer,dist)
+    CALL switch_u(mw,distrib_vanleer,dist)
+    CALL switch_u(zm,distrib_vanleer,dist)
+    CALL switch_u(zq,distrib_vanleer,dist)
+
+    CALL vlz_switch_vanleer(dist)
+
+  END SUBROUTINE vlspltgen_switch_vanleer  
+  
+END MODULE vlspltgen_mod  
Index: DZ6/trunk/libf/dyn3dmem/vlz_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/vlz_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,46 +1,0 @@
-MODULE vlz_mod
-
-  REAL,POINTER,SAVE :: wq(:,:,:)
-  REAL,POINTER,SAVE :: dzq(:,:)
-  REAL,POINTER,SAVE :: dzqw(:,:)
-  REAL,POINTER,SAVE :: adzqw(:,:)
-  ! CRisi: pour les traceurs:
-  REAL,POINTER,SAVE :: Ratio(:,:,:)
-  
-CONTAINS
-
-  SUBROUTINE vlz_allocate
-  USE bands
-  USE allocate_field_mod
-  USE parallel_lmdz
-  USE infotrac
-  USE dimensions_mod
-  IMPLICIT NONE
-  TYPE(distrib),POINTER :: d
-    
-    d=>distrib_vanleer
-    CALL allocate_u(wq,llm+1,nqtot,d)
-    CALL allocate_u(dzq,llm,d)
-    CALL allocate_u(dzqw,llm,d)
-    CALL allocate_u(adzqw,llm,d)
-    IF(ANY(tracers(:)%nqDescen > 0)) CALL allocate_u(Ratio,llm,nqtot,d)
-
-  END SUBROUTINE vlz_allocate
-  
-  SUBROUTINE vlz_switch_vanleer(dist)
-  USE allocate_field_mod
-  USE bands
-  USE parallel_lmdz
-  USE infotrac
-  IMPLICIT NONE
-    TYPE(distrib),INTENT(IN) :: dist
-  
-    CALL switch_u(wq,distrib_vanleer,dist)
-    CALL switch_u(dzq,distrib_vanleer,dist)
-    CALL switch_u(dzqw,distrib_vanleer,dist)
-    CALL switch_u(adzqw,distrib_vanleer,dist)
-    IF(ANY(tracers(:)%nqDescen > 0)) CALL switch_u(Ratio,distrib_vanleer,dist)
-
-  END SUBROUTINE vlz_switch_vanleer  
-  
-END MODULE vlz_mod  
Index: /LMDZ6/trunk/libf/dyn3dmem/vlz_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/vlz_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3dmem/vlz_mod.f90	(revision 5268)
@@ -0,0 +1,46 @@
+MODULE vlz_mod
+
+  REAL,POINTER,SAVE :: wq(:,:,:)
+  REAL,POINTER,SAVE :: dzq(:,:)
+  REAL,POINTER,SAVE :: dzqw(:,:)
+  REAL,POINTER,SAVE :: adzqw(:,:)
+  ! CRisi: pour les traceurs:
+  REAL,POINTER,SAVE :: Ratio(:,:,:)
+  
+CONTAINS
+
+  SUBROUTINE vlz_allocate
+  USE bands
+  USE allocate_field_mod
+  USE parallel_lmdz
+  USE infotrac
+  USE dimensions_mod
+  IMPLICIT NONE
+  TYPE(distrib),POINTER :: d
+    
+    d=>distrib_vanleer
+    CALL allocate_u(wq,llm+1,nqtot,d)
+    CALL allocate_u(dzq,llm,d)
+    CALL allocate_u(dzqw,llm,d)
+    CALL allocate_u(adzqw,llm,d)
+    IF(ANY(tracers(:)%nqDescen > 0)) CALL allocate_u(Ratio,llm,nqtot,d)
+
+  END SUBROUTINE vlz_allocate
+  
+  SUBROUTINE vlz_switch_vanleer(dist)
+  USE allocate_field_mod
+  USE bands
+  USE parallel_lmdz
+  USE infotrac
+  IMPLICIT NONE
+    TYPE(distrib),INTENT(IN) :: dist
+  
+    CALL switch_u(wq,distrib_vanleer,dist)
+    CALL switch_u(dzq,distrib_vanleer,dist)
+    CALL switch_u(dzqw,distrib_vanleer,dist)
+    CALL switch_u(adzqw,distrib_vanleer,dist)
+    IF(ANY(tracers(:)%nqDescen > 0)) CALL switch_u(Ratio,distrib_vanleer,dist)
+
+  END SUBROUTINE vlz_switch_vanleer  
+  
+END MODULE vlz_mod  
Index: DZ6/trunk/libf/dyn3dmem/write_field_loc.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/write_field_loc.F90	(revision 5267)
+++ 	(revision )
@@ -1,155 +1,0 @@
-module write_field_loc
-implicit none
-  
-  interface WriteField_u
-    module procedure Write_field1d_u,Write_Field2d_u
-  end interface WriteField_u
-
-  interface WriteField_v
-    module procedure Write_field1d_v,Write_Field2d_v
-  end interface WriteField_v
-  
-  contains
-  
-  subroutine write_field1D_u(name,Field)
-    character(len=*)   :: name
-    real, dimension(:) :: Field
-
-    CALL write_field_u_gen(name,Field,1)
-
-  end subroutine write_field1D_u
-
-  subroutine write_field2D_u(name,Field)
-    implicit none
-      
-    character(len=*)   :: name
-    real, dimension(:,:) :: Field
-    integer :: ll
-    
-    ll=size(field,2)    
-    CALL write_field_u_gen(name,Field,ll)
-    
-    end subroutine write_field2D_u
-
-
-   SUBROUTINE write_field_u_gen(name,Field,ll)
-    USE parallel_lmdz
-    USE write_field
-    USE mod_hallo
-    implicit none
-    include 'dimensions.h'
-    include 'paramet.h'
-      
-    character(len=*)   :: name
-    real, dimension(ijb_u:ije_u,ll) :: Field
-    real, allocatable,SAVE :: New_Field(:,:,:)
-    integer,dimension(0:mpi_size-1) :: jj_nb_master
-    type(Request),SAVE :: Request_write
-!$OMP THREADPRIVATE(Request_write)
-    integer :: ll,i
-    
-    
-    jj_nb_master(:)=0
-    jj_nb_master(0)=jjp1
-!$OMP BARRIER
-!$OMP MASTER
-    allocate(New_Field(iip1,jjp1,ll))
-!$OMP END MASTER
-!$OMP BARRIER
-
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-    DO i=1,ll    
-      New_Field(:,jj_begin:jj_end,i)=reshape(Field(ij_begin:ij_end,i),(/iip1,jj_nb/))
-    ENDDO
-!$OMP BARRIER    
-    call Register_SwapField(new_field,new_field,ip1jmp1,ll,jj_Nb_master,Request_write)
-    call SendRequest(Request_write)
-!$OMP BARRIER
-    call WaitRequest(Request_write)     
-!$OMP BARRIER
-
-!$OMP MASTER
-    if (MPI_Rank==0) call WriteField(name,New_Field)
-    DEALLOCATE(New_Field)
-!$OMP END MASTER        
-!$OMP BARRIER
-    END SUBROUTINE write_field_u_gen
-
-
-  subroutine write_field1D_v(name,Field)
-    character(len=*)   :: name
-    real, dimension(:) :: Field
-
-    CALL write_field_v_gen(name,Field,1)
-
-  end subroutine write_field1D_v
-
-  subroutine write_field2D_v(name,Field)
-    implicit none
-      
-    character(len=*)   :: name
-    real, dimension(:,:) :: Field
-    integer :: ll
-    
-    ll=size(field,2)    
-    CALL write_field_v_gen(name,Field,ll)
-    
-    end subroutine write_field2D_v
-
-
-   SUBROUTINE write_field_v_gen(name,Field,ll)
-    USE parallel_lmdz
-    USE write_field
-    USE mod_hallo
-    implicit none
-    include 'dimensions.h'
-    include 'paramet.h'
-      
-    character(len=*)   :: name
-    real, dimension(ijb_v:ije_v,ll) :: Field
-    real, allocatable,SAVE :: New_Field(:,:,:)
-    integer,dimension(0:mpi_size-1) :: jj_nb_master
-    type(Request),SAVE :: Request_write
-!$OMP THREADPRIVATE(Request_write)    
-    integer :: ll,i,jje,ije,jjn
-    
-    
-    jj_nb_master(:)=0
-    jj_nb_master(0)=jjp1
-
-!$OMP BARRIER
-!$OMP MASTER
-    allocate(New_Field(iip1,jjm,ll))
-!$OMP END MASTER
-!$OMP BARRIER
-
-   IF (pole_sud) THEN
-     jje=jj_end-1
-     ije=ij_end-iip1
-     jjn=jj_nb-1
-   ELSE
-     jje=jj_end
-     ije=ij_end
-     jjn=jj_nb
-   ENDIF
-   
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-    DO i=1,ll    
-      New_Field(:,jj_begin:jje,i)=reshape(Field(ij_begin:ije,i),(/iip1,jjn/))
-    ENDDO
-!$OMP BARRIER    
-    call Register_SwapField(new_field,new_field,ip1jm,ll,jj_Nb_master,Request_write)
-    call SendRequest(Request_write)
-!$OMP BARRIER
-    call WaitRequest(Request_write)     
-!$OMP BARRIER
-
-!$OMP MASTER
-    if (MPI_Rank==0) call WriteField(name,New_Field)
-    DEALLOCATE(New_Field)
-!$OMP END MASTER        
-!$OMP BARRIER
-    END SUBROUTINE write_field_v_gen
-    
-end module write_field_loc
-  
Index: /LMDZ6/trunk/libf/dyn3dmem/write_field_loc.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/write_field_loc.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3dmem/write_field_loc.f90	(revision 5268)
@@ -0,0 +1,155 @@
+module write_field_loc
+implicit none
+  
+  interface WriteField_u
+    module procedure Write_field1d_u,Write_Field2d_u
+  end interface WriteField_u
+
+  interface WriteField_v
+    module procedure Write_field1d_v,Write_Field2d_v
+  end interface WriteField_v
+  
+  contains
+  
+  subroutine write_field1D_u(name,Field)
+    character(len=*)   :: name
+    real, dimension(:) :: Field
+
+    CALL write_field_u_gen(name,Field,1)
+
+  end subroutine write_field1D_u
+
+  subroutine write_field2D_u(name,Field)
+    implicit none
+      
+    character(len=*)   :: name
+    real, dimension(:,:) :: Field
+    integer :: ll
+    
+    ll=size(field,2)    
+    CALL write_field_u_gen(name,Field,ll)
+    
+    end subroutine write_field2D_u
+
+
+   SUBROUTINE write_field_u_gen(name,Field,ll)
+    USE parallel_lmdz
+    USE write_field
+    USE mod_hallo
+    implicit none
+    include 'dimensions.h'
+    include 'paramet.h'
+      
+    character(len=*)   :: name
+    real, dimension(ijb_u:ije_u,ll) :: Field
+    real, allocatable,SAVE :: New_Field(:,:,:)
+    integer,dimension(0:mpi_size-1) :: jj_nb_master
+    type(Request),SAVE :: Request_write
+!$OMP THREADPRIVATE(Request_write)
+    integer :: ll,i
+    
+    
+    jj_nb_master(:)=0
+    jj_nb_master(0)=jjp1
+!$OMP BARRIER
+!$OMP MASTER
+    allocate(New_Field(iip1,jjp1,ll))
+!$OMP END MASTER
+!$OMP BARRIER
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO i=1,ll    
+      New_Field(:,jj_begin:jj_end,i)=reshape(Field(ij_begin:ij_end,i),(/iip1,jj_nb/))
+    ENDDO
+!$OMP BARRIER    
+    call Register_SwapField(new_field,new_field,ip1jmp1,ll,jj_Nb_master,Request_write)
+    call SendRequest(Request_write)
+!$OMP BARRIER
+    call WaitRequest(Request_write)     
+!$OMP BARRIER
+
+!$OMP MASTER
+    if (MPI_Rank==0) call WriteField(name,New_Field)
+    DEALLOCATE(New_Field)
+!$OMP END MASTER        
+!$OMP BARRIER
+    END SUBROUTINE write_field_u_gen
+
+
+  subroutine write_field1D_v(name,Field)
+    character(len=*)   :: name
+    real, dimension(:) :: Field
+
+    CALL write_field_v_gen(name,Field,1)
+
+  end subroutine write_field1D_v
+
+  subroutine write_field2D_v(name,Field)
+    implicit none
+      
+    character(len=*)   :: name
+    real, dimension(:,:) :: Field
+    integer :: ll
+    
+    ll=size(field,2)    
+    CALL write_field_v_gen(name,Field,ll)
+    
+    end subroutine write_field2D_v
+
+
+   SUBROUTINE write_field_v_gen(name,Field,ll)
+    USE parallel_lmdz
+    USE write_field
+    USE mod_hallo
+    implicit none
+    include 'dimensions.h'
+    include 'paramet.h'
+      
+    character(len=*)   :: name
+    real, dimension(ijb_v:ije_v,ll) :: Field
+    real, allocatable,SAVE :: New_Field(:,:,:)
+    integer,dimension(0:mpi_size-1) :: jj_nb_master
+    type(Request),SAVE :: Request_write
+!$OMP THREADPRIVATE(Request_write)    
+    integer :: ll,i,jje,ije,jjn
+    
+    
+    jj_nb_master(:)=0
+    jj_nb_master(0)=jjp1
+
+!$OMP BARRIER
+!$OMP MASTER
+    allocate(New_Field(iip1,jjm,ll))
+!$OMP END MASTER
+!$OMP BARRIER
+
+   IF (pole_sud) THEN
+     jje=jj_end-1
+     ije=ij_end-iip1
+     jjn=jj_nb-1
+   ELSE
+     jje=jj_end
+     ije=ij_end
+     jjn=jj_nb
+   ENDIF
+   
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+    DO i=1,ll    
+      New_Field(:,jj_begin:jje,i)=reshape(Field(ij_begin:ije,i),(/iip1,jjn/))
+    ENDDO
+!$OMP BARRIER    
+    call Register_SwapField(new_field,new_field,ip1jm,ll,jj_Nb_master,Request_write)
+    call SendRequest(Request_write)
+!$OMP BARRIER
+    call WaitRequest(Request_write)     
+!$OMP BARRIER
+
+!$OMP MASTER
+    if (MPI_Rank==0) call WriteField(name,New_Field)
+    DEALLOCATE(New_Field)
+!$OMP END MASTER        
+!$OMP BARRIER
+    END SUBROUTINE write_field_v_gen
+    
+end module write_field_loc
+  
Index: DZ6/trunk/libf/dyn3dmem/write_field_p.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/write_field_p.F90	(revision 5267)
+++ 	(revision )
@@ -1,73 +1,0 @@
-module write_field_p
-implicit none
-  
-  interface WriteField_p
-    module procedure Write_field3d_p,Write_Field2d_p,Write_Field1d_p
-  end interface WriteField_p
-  
-  contains
-  
-  subroutine write_field1D_p(name,Field)
-    USE parallel_lmdz
-    USE write_field
-    implicit none
-  
-    integer, parameter :: MaxDim=1
-    character(len=*)   :: name
-    real, dimension(:) :: Field
-    real, dimension(:),allocatable :: New_Field
-    integer, dimension(MaxDim) :: Dim
-    
-    
-    Dim=shape(Field)
-    allocate(New_Field(Dim(1)))
-    New_Field(:)=Field(:)
-    call Gather_Field(New_Field,dim(1),1,0)
-    
-    if (MPI_Rank==0) call WriteField(name,New_Field)
-    
-    end subroutine write_field1D_p
-
-  subroutine write_field2D_p(name,Field)
-    USE parallel_lmdz
-    USE write_field
-    implicit none
-  
-    integer, parameter :: MaxDim=2
-    character(len=*)   :: name
-    real, dimension(:,:) :: Field
-    real, dimension(:,:),allocatable :: New_Field
-    integer, dimension(MaxDim) :: Dim
-    
-    Dim=shape(Field)
-    allocate(New_Field(Dim(1),Dim(2)))
-    New_Field(:,:)=Field(:,:)
-    call Gather_Field(New_Field(1,1),dim(1)*dim(2),1,0)
-    
-    if (MPI_Rank==0) call WriteField(name,New_Field)
-    
-     
-  end subroutine write_field2D_p
-  
-  subroutine write_field3D_p(name,Field)
-    USE parallel_lmdz
-    USE write_field
-    implicit none
-  
-    integer, parameter :: MaxDim=3
-    character(len=*)   :: name
-    real, dimension(:,:,:) :: Field
-    real, dimension(:,:,:),allocatable :: New_Field
-    integer, dimension(MaxDim) :: Dim
-    
-    Dim=shape(Field)
-    allocate(New_Field(Dim(1),Dim(2),Dim(3)))
-    New_Field(:,:,:)=Field(:,:,:)
-    call Gather_Field(New_Field(1,1,1),dim(1)*dim(2),dim(3),0)
-    
-   if (MPI_Rank==0) call WriteField(name,New_Field)
-    
-  end subroutine write_field3D_p  
-
-end module write_field_p
-  
Index: /LMDZ6/trunk/libf/dyn3dmem/write_field_p.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/write_field_p.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3dmem/write_field_p.f90	(revision 5268)
@@ -0,0 +1,73 @@
+module write_field_p
+implicit none
+  
+  interface WriteField_p
+    module procedure Write_field3d_p,Write_Field2d_p,Write_Field1d_p
+  end interface WriteField_p
+  
+  contains
+  
+  subroutine write_field1D_p(name,Field)
+    USE parallel_lmdz
+    USE write_field
+    implicit none
+  
+    integer, parameter :: MaxDim=1
+    character(len=*)   :: name
+    real, dimension(:) :: Field
+    real, dimension(:),allocatable :: New_Field
+    integer, dimension(MaxDim) :: Dim
+    
+    
+    Dim=shape(Field)
+    allocate(New_Field(Dim(1)))
+    New_Field(:)=Field(:)
+    call Gather_Field(New_Field,dim(1),1,0)
+    
+    if (MPI_Rank==0) call WriteField(name,New_Field)
+    
+    end subroutine write_field1D_p
+
+  subroutine write_field2D_p(name,Field)
+    USE parallel_lmdz
+    USE write_field
+    implicit none
+  
+    integer, parameter :: MaxDim=2
+    character(len=*)   :: name
+    real, dimension(:,:) :: Field
+    real, dimension(:,:),allocatable :: New_Field
+    integer, dimension(MaxDim) :: Dim
+    
+    Dim=shape(Field)
+    allocate(New_Field(Dim(1),Dim(2)))
+    New_Field(:,:)=Field(:,:)
+    call Gather_Field(New_Field(1,1),dim(1)*dim(2),1,0)
+    
+    if (MPI_Rank==0) call WriteField(name,New_Field)
+    
+     
+  end subroutine write_field2D_p
+  
+  subroutine write_field3D_p(name,Field)
+    USE parallel_lmdz
+    USE write_field
+    implicit none
+  
+    integer, parameter :: MaxDim=3
+    character(len=*)   :: name
+    real, dimension(:,:,:) :: Field
+    real, dimension(:,:,:),allocatable :: New_Field
+    integer, dimension(MaxDim) :: Dim
+    
+    Dim=shape(Field)
+    allocate(New_Field(Dim(1),Dim(2),Dim(3)))
+    New_Field(:,:,:)=Field(:,:,:)
+    call Gather_Field(New_Field(1,1,1),dim(1)*dim(2),dim(3),0)
+    
+   if (MPI_Rank==0) call WriteField(name,New_Field)
+    
+  end subroutine write_field3D_p  
+
+end module write_field_p
+  
Index: DZ6/trunk/libf/dyn3dmem/writedyn_xios.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/writedyn_xios.F90	(revision 5267)
+++ 	(revision )
@@ -1,181 +1,0 @@
-
-! $Id$
-!
-      SUBROUTINE writedyn_xios( vcov, ucov,teta,ppk,phi,q, &
-     &                           masse,ps,phis)
-
-      USE lmdz_xios
-      USE parallel_lmdz
-      USE misc_mod
-      USE infotrac, ONLY : nqtot
-      use com_io_dyn_mod, only : histaveid,histvaveid,histuaveid
-      USE comconst_mod, ONLY: cpp
-      USE temps_mod, ONLY: itau_dyn
-      USE mod_xios_dyn3dmem, ONLY : writefield_dyn_u, writefield_dyn_v
-      
-      implicit none
-!
-!   Ecriture du fichier histoire au format xios
-!
-!
-!   Entree:
-!      vcov: vents v covariants
-!      ucov: vents u covariants
-!      teta: temperature potentielle
-!      phi : geopotentiel instantane
-!      q   : traceurs
-!      masse: masse
-!      ps   :pression au sol
-!      phis : geopotentiel au sol
-!      
-!   L. Fairhead, LMD, 03/21
-!
-! =====================================================================
-!
-!   Declarations
-      include "dimensions.h"
-      include "paramet.h"
-      include "comgeom.h"
-      include "description.h"
-      include "iniprint.h"
-
-!
-!   Arguments
-!
-
-      REAL vcov(ijb_v:ije_v,llm),ucov(ijb_u:ije_u,llm) 
-      REAL teta(ijb_u:ije_u,llm),phi(ijb_u:ije_u,llm)
-      REAL ppk(ijb_u:ije_u,llm)                  
-      REAL ps(ijb_u:ije_u),masse(ijb_u:ije_u,llm)                   
-      REAL phis(ijb_u:ije_u)                  
-      REAL q(ijb_u:ije_u,llm,nqtot)
-      integer time
-
-
-!   Variables locales
-!
-      INTEGER,SAVE,ALLOCATABLE :: ndex2d(:),ndexu(:),ndexv(:)
-      INTEGER :: iq, ii, ll
-      REAL,SAVE,ALLOCATABLE :: tm(:,:)
-      REAL,SAVE,ALLOCATABLE :: vnat(:,:),unat(:,:)
-      REAL,SAVE,ALLOCATABLE :: vbuffer(:,:)
-      logical ok_sync
-      integer itau_w
-      integer :: ijb,ije,jjn
-      LOGICAL,SAVE :: first=.TRUE.
-      LOGICAL,SAVE :: debuglf=.true.
-!$OMP THREADPRIVATE(debuglf)
-!$OMP THREADPRIVATE(first)
-
-!
-!  Initialisations
-!
-
-!      WRITE(*,*)'IN WRITEDYN_XIOS'
-      IF (first) THEN
-!$OMP BARRIER
-!$OMP MASTER
-        ALLOCATE(unat(ijb_u:ije_u,llm))
-        ALLOCATE(vnat(ijb_v:ije_v,llm))
-        IF (pole_sud) THEN
-           ALLOCATE(vbuffer(ijb_v:ije_v+iip1,llm))
-        ELSE
-           ALLOCATE(vbuffer(ijb_v:ije_v+iip1,llm))
-        ENDIF
-        ALLOCATE(tm(ijb_u:ije_u,llm))
-        ALLOCATE(ndex2d(ijnb_u*llm))
-        ALLOCATE(ndexu(ijnb_u*llm))
-        ALLOCATE(ndexv(ijnb_v*llm))
-        unat = 0.; vnat = 0.; tm = 0. ;
-        ndex2d = 0
-        ndexu = 0
-        ndexv = 0
-        vbuffer=0.
-!$OMP END MASTER
-!$OMP BARRIER
-        first=.FALSE.
-      ENDIF
-      
-      ok_sync = .TRUE.
-      itau_w = itau_dyn + time
-
-! Passage aux composantes naturelles du vent
-      call covnat_loc(llm, ucov, vcov, unat, vnat)
-
-!
-!  Appels a histwrite pour l'ecriture des variables a sauvegarder
-!
-!  Vents U
-!
-      ijb=ij_begin
-      ije=ij_end
-      jjn=jj_nb
-     
-      CALL writefield_dyn_u('U', unat(ijb:ije,:))
-
-!
-!  Vents V
-!
-      ije=ij_end
-      IF (pole_sud) THEN
-         jjn=jj_nb-1
-         ije=ij_end-iip1
-      ENDIF
-      vbuffer(ijb:ije,:)=vnat(ijb:ije,:)
-
-
-      IF (pole_sud) THEN
-         CALL writefield_dyn_v('V', vbuffer(ijb:ije+iip1,:))
-      ELSE
-         CALL writefield_dyn_v('V', vbuffer(ijb:ije,:))
-      ENDIF
-      
-
-      
-!
-!  Temperature potentielle moyennee
-!
-      ijb=ij_begin
-      ije=ij_end
-      jjn=jj_nb
-     CALL writefield_dyn_u('THETA', teta(ijb:ije,:))
-
-!
-!  Temperature moyennee
-!
-
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)       
-      do ll=1,llm
-        do ii = ijb, ije
-          tm(ii,ll) = teta(ii,ll) * ppk(ii,ll)/cpp
-        enddo
-      enddo
-!$OMP ENDDO
-      CALL writefield_dyn_u('TEMP', tm(ijb:ije,:))
-
-
-!
-!  Geopotentiel
-!
-      CALL writefield_dyn_u('PHI', phi(ijb:ije,:))
-
-
-!
-! Tracers?
-!
-!        DO iq=1,nqtot
-!        ENDDO
-
-
-!
-!  Masse
-!
-      CALL writefield_dyn_u('MASSE', masse(ijb:ije,:))
-
-
-!
-!  Pression au sol
-!
-      CALL writefield_dyn_u('PS', ps(ijb:ije))
-
-      END
Index: /LMDZ6/trunk/libf/dyn3dmem/writedyn_xios.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/writedyn_xios.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3dmem/writedyn_xios.f90	(revision 5268)
@@ -0,0 +1,181 @@
+
+! $Id$
+!
+      SUBROUTINE writedyn_xios( vcov, ucov,teta,ppk,phi,q, &
+     &                           masse,ps,phis)
+
+      USE lmdz_xios
+      USE parallel_lmdz
+      USE misc_mod
+      USE infotrac, ONLY : nqtot
+      use com_io_dyn_mod, only : histaveid,histvaveid,histuaveid
+      USE comconst_mod, ONLY: cpp
+      USE temps_mod, ONLY: itau_dyn
+      USE mod_xios_dyn3dmem, ONLY : writefield_dyn_u, writefield_dyn_v
+      
+      implicit none
+!
+!   Ecriture du fichier histoire au format xios
+!
+!
+!   Entree:
+!      vcov: vents v covariants
+!      ucov: vents u covariants
+!      teta: temperature potentielle
+!      phi : geopotentiel instantane
+!      q   : traceurs
+!      masse: masse
+!      ps   :pression au sol
+!      phis : geopotentiel au sol
+!      
+!   L. Fairhead, LMD, 03/21
+!
+! =====================================================================
+!
+!   Declarations
+      include "dimensions.h"
+      include "paramet.h"
+      include "comgeom.h"
+      include "description.h"
+      include "iniprint.h"
+
+!
+!   Arguments
+!
+
+      REAL vcov(ijb_v:ije_v,llm),ucov(ijb_u:ije_u,llm) 
+      REAL teta(ijb_u:ije_u,llm),phi(ijb_u:ije_u,llm)
+      REAL ppk(ijb_u:ije_u,llm)                  
+      REAL ps(ijb_u:ije_u),masse(ijb_u:ije_u,llm)                   
+      REAL phis(ijb_u:ije_u)                  
+      REAL q(ijb_u:ije_u,llm,nqtot)
+      integer time
+
+
+!   Variables locales
+!
+      INTEGER,SAVE,ALLOCATABLE :: ndex2d(:),ndexu(:),ndexv(:)
+      INTEGER :: iq, ii, ll
+      REAL,SAVE,ALLOCATABLE :: tm(:,:)
+      REAL,SAVE,ALLOCATABLE :: vnat(:,:),unat(:,:)
+      REAL,SAVE,ALLOCATABLE :: vbuffer(:,:)
+      logical ok_sync
+      integer itau_w
+      integer :: ijb,ije,jjn
+      LOGICAL,SAVE :: first=.TRUE.
+      LOGICAL,SAVE :: debuglf=.true.
+!$OMP THREADPRIVATE(debuglf)
+!$OMP THREADPRIVATE(first)
+
+!
+!  Initialisations
+!
+
+!      WRITE(*,*)'IN WRITEDYN_XIOS'
+      IF (first) THEN
+!$OMP BARRIER
+!$OMP MASTER
+        ALLOCATE(unat(ijb_u:ije_u,llm))
+        ALLOCATE(vnat(ijb_v:ije_v,llm))
+        IF (pole_sud) THEN
+           ALLOCATE(vbuffer(ijb_v:ije_v+iip1,llm))
+        ELSE
+           ALLOCATE(vbuffer(ijb_v:ije_v+iip1,llm))
+        ENDIF
+        ALLOCATE(tm(ijb_u:ije_u,llm))
+        ALLOCATE(ndex2d(ijnb_u*llm))
+        ALLOCATE(ndexu(ijnb_u*llm))
+        ALLOCATE(ndexv(ijnb_v*llm))
+        unat = 0.; vnat = 0.; tm = 0. ;
+        ndex2d = 0
+        ndexu = 0
+        ndexv = 0
+        vbuffer=0.
+!$OMP END MASTER
+!$OMP BARRIER
+        first=.FALSE.
+      ENDIF
+      
+      ok_sync = .TRUE.
+      itau_w = itau_dyn + time
+
+! Passage aux composantes naturelles du vent
+      call covnat_loc(llm, ucov, vcov, unat, vnat)
+
+!
+!  Appels a histwrite pour l'ecriture des variables a sauvegarder
+!
+!  Vents U
+!
+      ijb=ij_begin
+      ije=ij_end
+      jjn=jj_nb
+     
+      CALL writefield_dyn_u('U', unat(ijb:ije,:))
+
+!
+!  Vents V
+!
+      ije=ij_end
+      IF (pole_sud) THEN
+         jjn=jj_nb-1
+         ije=ij_end-iip1
+      ENDIF
+      vbuffer(ijb:ije,:)=vnat(ijb:ije,:)
+
+
+      IF (pole_sud) THEN
+         CALL writefield_dyn_v('V', vbuffer(ijb:ije+iip1,:))
+      ELSE
+         CALL writefield_dyn_v('V', vbuffer(ijb:ije,:))
+      ENDIF
+      
+
+      
+!
+!  Temperature potentielle moyennee
+!
+      ijb=ij_begin
+      ije=ij_end
+      jjn=jj_nb
+     CALL writefield_dyn_u('THETA', teta(ijb:ije,:))
+
+!
+!  Temperature moyennee
+!
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)       
+      do ll=1,llm
+        do ii = ijb, ije
+          tm(ii,ll) = teta(ii,ll) * ppk(ii,ll)/cpp
+        enddo
+      enddo
+!$OMP ENDDO
+      CALL writefield_dyn_u('TEMP', tm(ijb:ije,:))
+
+
+!
+!  Geopotentiel
+!
+      CALL writefield_dyn_u('PHI', phi(ijb:ije,:))
+
+
+!
+! Tracers?
+!
+!        DO iq=1,nqtot
+!        ENDDO
+
+
+!
+!  Masse
+!
+      CALL writefield_dyn_u('MASSE', masse(ijb:ije,:))
+
+
+!
+!  Pression au sol
+!
+      CALL writefield_dyn_u('PS', ps(ijb:ije))
+
+      END
Index: DZ6/trunk/libf/dyn3dmem/writedynav_loc.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/writedynav_loc.F90	(revision 5267)
+++ 	(revision )
@@ -1,220 +1,0 @@
-!
-! $Id: writedynav_p.F 1279 2009-12-10 09:02:56Z fairhead $
-!
-subroutine writedynav_loc( time, vcov, ucov,teta,ppk,phi,q, &
-        masse,ps,phis)
-
-  ! This routine needs IOIPSL
-  USE ioipsl
-
-  USE parallel_lmdz
-  USE misc_mod
-  USE infotrac, ONLY : nqtot
-  use com_io_dyn_mod, only : histaveid,histvaveid,histuaveid
-  USE comconst_mod, ONLY: cpp
-  USE temps_mod, ONLY: itau_dyn
-
-  implicit none
-
-  !
-  !   Ecriture du fichier histoire au format IOIPSL
-  !
-  !   Appels succesifs des routines: histwrite
-  !
-  !   Entree:
-  !  histid: ID du fichier histoire
-  !  time: temps de l'ecriture
-  !  vcov: vents v covariants
-  !  ucov: vents u covariants
-  !  teta: temperature potentielle
-  !  phi : geopotentiel instantane
-  !  q   : traceurs
-  !  masse: masse
-  !  ps   :pression au sol
-  !  phis : geopotentiel au sol
-  !
-  !
-  !   Sortie:
-  !  fileid: ID du fichier netcdf cree
-  !
-  !   L. Fairhead, LMD, 03/99
-  !
-  ! =====================================================================
-  !
-  !   Declarations
-  include "dimensions.h"
-  include "paramet.h"
-  include "comgeom.h"
-  include "description.h"
-  include "iniprint.h"
-
-  !
-  !   Arguments
-  !
-
-  REAL :: vcov(ijb_v:ije_v,llm),ucov(ijb_u:ije_u,llm)
-  REAL :: teta(ijb_u:ije_u,llm),phi(ijb_u:ije_u,llm)
-  REAL :: ppk(ijb_u:ije_u,llm)
-  REAL :: ps(ijb_u:ije_u),masse(ijb_u:ije_u,llm)
-  REAL :: phis(ijb_u:ije_u)
-  REAL :: q(ijb_u:ije_u,llm,nqtot)
-  integer :: time
-
-
-  ! This routine needs IOIPSL
-  !   Variables locales
-  !
-  INTEGER,SAVE,ALLOCATABLE :: ndex2d(:),ndexu(:),ndexv(:)
-  INTEGER :: iq, ii, ll
-  REAL,SAVE,ALLOCATABLE :: tm(:,:)
-  REAL,SAVE,ALLOCATABLE :: vnat(:,:),unat(:,:)
-  logical :: ok_sync
-  integer :: itau_w
-  integer :: ijb,ije,jjn
-  LOGICAL,SAVE :: first=.TRUE.
-!$OMP THREADPRIVATE(first)
-
-  !
-  !  Initialisations
-  !
-  if (adjust) return
-
-  IF (first) THEN
-!$OMP BARRIER
-!$OMP MASTER
-    ALLOCATE(unat(ijb_u:ije_u,llm))
-    ALLOCATE(vnat(ijb_v:ije_v,llm))
-    ALLOCATE(tm(ijb_u:ije_u,llm))
-    ALLOCATE(ndex2d(ijnb_u*llm))
-    ALLOCATE(ndexu(ijnb_u*llm))
-    ALLOCATE(ndexv(ijnb_v*llm))
-    ndex2d = 0
-    ndexu = 0
-    ndexv = 0
-!$OMP END MASTER
-!$OMP BARRIER
-    first=.FALSE.
-  ENDIF
-
-  ok_sync = .TRUE.
-  itau_w = itau_dyn + time
-
-  ! Passage aux composantes naturelles du vent
-  call covnat_loc(llm, ucov, vcov, unat, vnat)
-
-  !
-  !  Appels a histwrite pour l'ecriture des variables a sauvegarder
-  !
-  !  Vents U
-  !
-
-!$OMP BARRIER
-!$OMP MASTER
-  ijb=ij_begin
-  ije=ij_end
-  jjn=jj_nb
-
-  call histwrite(histuaveid, 'u', itau_w, unat(ijb:ije,:), &
-        iip1*jjn*llm, ndexu)
-!$OMP END MASTER
-
-  !
-  !  Vents V
-  !
-  ije=ij_end
-  if (pole_sud) jjn=jj_nb-1
-  if (pole_sud) ije=ij_end-iip1
-!$OMP BARRIER
-!$OMP MASTER
-  call histwrite(histvaveid, 'v', itau_w, vnat(ijb:ije,:), &
-        iip1*jjn*llm, ndexv)
-!$OMP END MASTER
-
-
-  !
-  !  Temperature potentielle moyennee
-  !
-  ijb=ij_begin
-  ije=ij_end
-  jjn=jj_nb
-!$OMP MASTER
-  call histwrite(histaveid, 'theta', itau_w, teta(ijb:ije,:), &
-        iip1*jjn*llm, ndexu)
-!$OMP END MASTER
-
-  !
-  !  Temperature moyennee
-  !
-
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-  do ll=1,llm
-    do ii = ijb, ije
-      tm(ii,ll) = teta(ii,ll) * ppk(ii,ll)/cpp
-    enddo
-  enddo
-!$OMP ENDDO
-
-!$OMP MASTER
-  call histwrite(histaveid, 'temp', itau_w, tm(ijb:ije,:), &
-        iip1*jjn*llm, ndexu)
-!$OMP END MASTER
-
-
-  !
-  !  Geopotentiel
-  !
-!$OMP MASTER
-  call histwrite(histaveid, 'phi', itau_w, phi(ijb:ije,:), &
-        iip1*jjn*llm, ndexu)
-!$OMP END MASTER
-
-
-  !
-  !  Traceurs
-  !
-  !!$OMP MASTER
-  !    DO iq=1,nqtot
-  !      call histwrite(histaveid, tracers(iq)%longName, itau_w, &
-  ! .                   q(ijb:ije,:,iq), iip1*jjn*llm, ndexu)
-  !    enddo
-  !!$OMP END MASTER
-
-
-  !
-  !  Masse
-  !
-!$OMP MASTER
-   call histwrite(histaveid, 'masse', itau_w, masse(ijb:ije,:), &
-         iip1*jjn*llm, ndexu)
-!$OMP END MASTER
-
-
-  !
-  !  Pression au sol
-  !
-!$OMP MASTER
-
-   call histwrite(histaveid, 'ps', itau_w, ps(ijb:ije), &
-         iip1*jjn, ndex2d)
-!$OMP END MASTER
-
-  !
-  !  Geopotentiel au sol
-  !
-!$OMP MASTER
-    ! call histwrite(histaveid, 'phis', itau_w, phis(ijb:ije),
-  ! .                 iip1*jjn, ndex2d)
-!$OMP END MASTER
-
-  !
-  !  Fin
-  !
-!$OMP MASTER
-  if (ok_sync) then
-      call histsync(histaveid)
-      call histsync(histvaveid)
-      call histsync(histuaveid)
-  ENDIF
-!$OMP END MASTER
-
-end subroutine writedynav_loc
Index: /LMDZ6/trunk/libf/dyn3dmem/writedynav_loc.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/writedynav_loc.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3dmem/writedynav_loc.f90	(revision 5268)
@@ -0,0 +1,220 @@
+!
+! $Id: writedynav_p.F 1279 2009-12-10 09:02:56Z fairhead $
+!
+subroutine writedynav_loc( time, vcov, ucov,teta,ppk,phi,q, &
+        masse,ps,phis)
+
+  ! This routine needs IOIPSL
+  USE ioipsl
+
+  USE parallel_lmdz
+  USE misc_mod
+  USE infotrac, ONLY : nqtot
+  use com_io_dyn_mod, only : histaveid,histvaveid,histuaveid
+  USE comconst_mod, ONLY: cpp
+  USE temps_mod, ONLY: itau_dyn
+
+  implicit none
+
+  !
+  !   Ecriture du fichier histoire au format IOIPSL
+  !
+  !   Appels succesifs des routines: histwrite
+  !
+  !   Entree:
+  !  histid: ID du fichier histoire
+  !  time: temps de l'ecriture
+  !  vcov: vents v covariants
+  !  ucov: vents u covariants
+  !  teta: temperature potentielle
+  !  phi : geopotentiel instantane
+  !  q   : traceurs
+  !  masse: masse
+  !  ps   :pression au sol
+  !  phis : geopotentiel au sol
+  !
+  !
+  !   Sortie:
+  !  fileid: ID du fichier netcdf cree
+  !
+  !   L. Fairhead, LMD, 03/99
+  !
+  ! =====================================================================
+  !
+  !   Declarations
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom.h"
+  include "description.h"
+  include "iniprint.h"
+
+  !
+  !   Arguments
+  !
+
+  REAL :: vcov(ijb_v:ije_v,llm),ucov(ijb_u:ije_u,llm)
+  REAL :: teta(ijb_u:ije_u,llm),phi(ijb_u:ije_u,llm)
+  REAL :: ppk(ijb_u:ije_u,llm)
+  REAL :: ps(ijb_u:ije_u),masse(ijb_u:ije_u,llm)
+  REAL :: phis(ijb_u:ije_u)
+  REAL :: q(ijb_u:ije_u,llm,nqtot)
+  integer :: time
+
+
+  ! This routine needs IOIPSL
+  !   Variables locales
+  !
+  INTEGER,SAVE,ALLOCATABLE :: ndex2d(:),ndexu(:),ndexv(:)
+  INTEGER :: iq, ii, ll
+  REAL,SAVE,ALLOCATABLE :: tm(:,:)
+  REAL,SAVE,ALLOCATABLE :: vnat(:,:),unat(:,:)
+  logical :: ok_sync
+  integer :: itau_w
+  integer :: ijb,ije,jjn
+  LOGICAL,SAVE :: first=.TRUE.
+!$OMP THREADPRIVATE(first)
+
+  !
+  !  Initialisations
+  !
+  if (adjust) return
+
+  IF (first) THEN
+!$OMP BARRIER
+!$OMP MASTER
+    ALLOCATE(unat(ijb_u:ije_u,llm))
+    ALLOCATE(vnat(ijb_v:ije_v,llm))
+    ALLOCATE(tm(ijb_u:ije_u,llm))
+    ALLOCATE(ndex2d(ijnb_u*llm))
+    ALLOCATE(ndexu(ijnb_u*llm))
+    ALLOCATE(ndexv(ijnb_v*llm))
+    ndex2d = 0
+    ndexu = 0
+    ndexv = 0
+!$OMP END MASTER
+!$OMP BARRIER
+    first=.FALSE.
+  ENDIF
+
+  ok_sync = .TRUE.
+  itau_w = itau_dyn + time
+
+  ! Passage aux composantes naturelles du vent
+  call covnat_loc(llm, ucov, vcov, unat, vnat)
+
+  !
+  !  Appels a histwrite pour l'ecriture des variables a sauvegarder
+  !
+  !  Vents U
+  !
+
+!$OMP BARRIER
+!$OMP MASTER
+  ijb=ij_begin
+  ije=ij_end
+  jjn=jj_nb
+
+  call histwrite(histuaveid, 'u', itau_w, unat(ijb:ije,:), &
+        iip1*jjn*llm, ndexu)
+!$OMP END MASTER
+
+  !
+  !  Vents V
+  !
+  ije=ij_end
+  if (pole_sud) jjn=jj_nb-1
+  if (pole_sud) ije=ij_end-iip1
+!$OMP BARRIER
+!$OMP MASTER
+  call histwrite(histvaveid, 'v', itau_w, vnat(ijb:ije,:), &
+        iip1*jjn*llm, ndexv)
+!$OMP END MASTER
+
+
+  !
+  !  Temperature potentielle moyennee
+  !
+  ijb=ij_begin
+  ije=ij_end
+  jjn=jj_nb
+!$OMP MASTER
+  call histwrite(histaveid, 'theta', itau_w, teta(ijb:ije,:), &
+        iip1*jjn*llm, ndexu)
+!$OMP END MASTER
+
+  !
+  !  Temperature moyennee
+  !
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  do ll=1,llm
+    do ii = ijb, ije
+      tm(ii,ll) = teta(ii,ll) * ppk(ii,ll)/cpp
+    enddo
+  enddo
+!$OMP ENDDO
+
+!$OMP MASTER
+  call histwrite(histaveid, 'temp', itau_w, tm(ijb:ije,:), &
+        iip1*jjn*llm, ndexu)
+!$OMP END MASTER
+
+
+  !
+  !  Geopotentiel
+  !
+!$OMP MASTER
+  call histwrite(histaveid, 'phi', itau_w, phi(ijb:ije,:), &
+        iip1*jjn*llm, ndexu)
+!$OMP END MASTER
+
+
+  !
+  !  Traceurs
+  !
+  !!$OMP MASTER
+  !    DO iq=1,nqtot
+  !      call histwrite(histaveid, tracers(iq)%longName, itau_w, &
+  ! .                   q(ijb:ije,:,iq), iip1*jjn*llm, ndexu)
+  !    enddo
+  !!$OMP END MASTER
+
+
+  !
+  !  Masse
+  !
+!$OMP MASTER
+   call histwrite(histaveid, 'masse', itau_w, masse(ijb:ije,:), &
+         iip1*jjn*llm, ndexu)
+!$OMP END MASTER
+
+
+  !
+  !  Pression au sol
+  !
+!$OMP MASTER
+
+   call histwrite(histaveid, 'ps', itau_w, ps(ijb:ije), &
+         iip1*jjn, ndex2d)
+!$OMP END MASTER
+
+  !
+  !  Geopotentiel au sol
+  !
+!$OMP MASTER
+    ! call histwrite(histaveid, 'phis', itau_w, phis(ijb:ije),
+  ! .                 iip1*jjn, ndex2d)
+!$OMP END MASTER
+
+  !
+  !  Fin
+  !
+!$OMP MASTER
+  if (ok_sync) then
+      call histsync(histaveid)
+      call histsync(histvaveid)
+      call histsync(histuaveid)
+  ENDIF
+!$OMP END MASTER
+
+end subroutine writedynav_loc
Index: DZ6/trunk/libf/dyn3dmem/writehist_loc.F90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/writehist_loc.F90	(revision 5267)
+++ 	(revision )
@@ -1,219 +1,0 @@
-!
-! $Id: writedynav_p.F 1279 2009-12-10 09:02:56Z fairhead $
-!
-subroutine writehist_loc( time, vcov, ucov,teta,ppk,phi,q, &
-        masse,ps,phis)
-
-  ! This routine needs IOIPSL
-  USE ioipsl
-
-  USE parallel_lmdz
-  USE misc_mod
-  USE infotrac, ONLY : nqtot
-  use com_io_dyn_mod, only : histid,histvid,histuid
-  USE comconst_mod, ONLY: cpp
-  USE temps_mod, ONLY: itau_dyn
-
-  implicit none
-
-  !
-  !   Ecriture du fichier histoire au format IOIPSL
-  !
-  !   Appels succesifs des routines: histwrite
-  !
-  !   Entree:
-  !  histid: ID du fichier histoire
-  !  time: temps de l'ecriture
-  !  vcov: vents v covariants
-  !  ucov: vents u covariants
-  !  teta: temperature potentielle
-  !  phi : geopotentiel instantane
-  !  q   : traceurs
-  !  masse: masse
-  !  ps   :pression au sol
-  !  phis : geopotentiel au sol
-  !
-  !
-  !   Sortie:
-  !  fileid: ID du fichier netcdf cree
-  !
-  !   L. Fairhead, LMD, 03/99
-  !
-  ! =====================================================================
-  !
-  !   Declarations
-  include "dimensions.h"
-  include "paramet.h"
-  include "comgeom.h"
-  include "description.h"
-  include "iniprint.h"
-
-  !
-  !   Arguments
-  !
-
-  REAL :: vcov(ijb_v:ije_v,llm),ucov(ijb_u:ije_u,llm)
-  REAL :: teta(ijb_u:ije_u,llm),phi(ijb_u:ije_u,llm)
-  REAL :: ppk(ijb_u:ije_u,llm)
-  REAL :: ps(ijb_u:ije_u),masse(ijb_u:ije_u,llm)
-  REAL :: phis(ijb_u:ije_u)
-  REAL :: q(ijb_u:ije_u,llm,nqtot)
-  integer :: time
-
-
-  ! This routine needs IOIPSL
-  !   Variables locales
-  !
-  INTEGER,SAVE,ALLOCATABLE :: ndex2d(:),ndexu(:),ndexv(:)
-  INTEGER :: iq, ii, ll
-  REAL,SAVE,ALLOCATABLE :: tm(:,:)
-  REAL,SAVE,ALLOCATABLE :: vnat(:,:),unat(:,:)
-  logical :: ok_sync
-  integer :: itau_w
-  integer :: ijb,ije,jjn
-  LOGICAL,SAVE :: first=.TRUE.
-!$OMP THREADPRIVATE(first)
-
-  !
-  !  Initialisations
-  !
-  if (adjust) return
-
-  IF (first) THEN
-!$OMP BARRIER
-!$OMP MASTER
-    ALLOCATE(unat(ijb_u:ije_u,llm))
-    ALLOCATE(vnat(ijb_v:ije_v,llm))
-    ALLOCATE(tm(ijb_u:ije_u,llm))
-    ALLOCATE(ndex2d(ijnb_u*llm))
-    ALLOCATE(ndexu(ijnb_u*llm))
-    ALLOCATE(ndexv(ijnb_v*llm))
-    ndex2d = 0
-    ndexu = 0
-    ndexv = 0
-!$OMP END MASTER
-!$OMP BARRIER
-    first=.FALSE.
-  ENDIF
-
-  ok_sync = .TRUE.
-  itau_w = itau_dyn + time
-
-  ! Passage aux composantes naturelles du vent
-  call covnat_loc(llm, ucov, vcov, unat, vnat)
-
-  !
-  !  Appels a histwrite pour l'ecriture des variables a sauvegarder
-  !
-  !  Vents U
-  !
-
-!$OMP BARRIER
-!$OMP MASTER
-  ijb=ij_begin
-  ije=ij_end
-  jjn=jj_nb
-
-  call histwrite(histuid, 'u', itau_w, unat(ijb:ije,:), &
-        iip1*jjn*llm, ndexu)
-!$OMP END MASTER
-
-  !
-  !  Vents V
-  !
-  ije=ij_end
-  if (pole_sud) jjn=jj_nb-1
-  if (pole_sud) ije=ij_end-iip1
-!$OMP BARRIER
-!$OMP MASTER
-  call histwrite(histvid, 'v', itau_w, vnat(ijb:ije,:), &
-        iip1*jjn*llm, ndexv)
-!$OMP END MASTER
-
-
-  !
-  !  Temperature potentielle
-  !
-  ijb=ij_begin
-  ije=ij_end
-  jjn=jj_nb
-!$OMP MASTER
-  call histwrite(histid, 'theta', itau_w, teta(ijb:ije,:), &
-        iip1*jjn*llm, ndexu)
-!$OMP END MASTER
-
-  !
-  !  Temperature
-  !
-
-!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
-  do ll=1,llm
-    do ii = ijb, ije
-      tm(ii,ll) = teta(ii,ll) * ppk(ii,ll)/cpp
-    enddo
-  enddo
-!$OMP ENDDO
-
-!$OMP MASTER
-  call histwrite(histid, 'temp', itau_w, tm(ijb:ije,:), &
-        iip1*jjn*llm, ndexu)
-!$OMP END MASTER
-
-
-  !
-  !  Geopotentiel
-  !
-!$OMP MASTER
-  call histwrite(histid, 'phi', itau_w, phi(ijb:ije,:), &
-        iip1*jjn*llm, ndexu)
-!$OMP END MASTER
-
-
-  !
-  !  Traceurs
-  !
-  !!$OMP MASTER
-  !    DO iq=1,nqtot
-  !      call histwrite(histid, tracers(iq)%longName, itau_w,
-  ! .                   q(ijb:ije,:,iq), iip1*jjn*llm, ndexu)
-  !    enddo
-  !!$OMP END MASTER
-
-
-  !
-  !  Masse
-  !
-!$OMP MASTER
-   call histwrite(histid, 'masse', itau_w, masse(ijb:ije,:), &
-         iip1*jjn*llm, ndexu)
-!$OMP END MASTER
-
-
-  !
-  !  Pression au sol
-  !
-!$OMP MASTER
-   call histwrite(histid, 'ps', itau_w, ps(ijb:ije), &
-         iip1*jjn, ndex2d)
-!$OMP END MASTER
-
-  !
-  !  Geopotentiel au sol
-  !
-!$OMP MASTER
-    ! call histwrite(histid, 'phis', itau_w, phis(ijb:ije),
-  ! .                 iip1*jjn, ndex2d)
-!$OMP END MASTER
-
-  !
-  !  Fin
-  !
-!$OMP MASTER
-  if (ok_sync) then
-    call histsync(histid)
-    call histsync(histvid)
-    call histsync(histuid)
-  endif
-!$OMP END MASTER
-
-end subroutine writehist_loc
Index: /LMDZ6/trunk/libf/dyn3dmem/writehist_loc.f90
===================================================================
--- /LMDZ6/trunk/libf/dyn3dmem/writehist_loc.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dyn3dmem/writehist_loc.f90	(revision 5268)
@@ -0,0 +1,219 @@
+!
+! $Id: writedynav_p.F 1279 2009-12-10 09:02:56Z fairhead $
+!
+subroutine writehist_loc( time, vcov, ucov,teta,ppk,phi,q, &
+        masse,ps,phis)
+
+  ! This routine needs IOIPSL
+  USE ioipsl
+
+  USE parallel_lmdz
+  USE misc_mod
+  USE infotrac, ONLY : nqtot
+  use com_io_dyn_mod, only : histid,histvid,histuid
+  USE comconst_mod, ONLY: cpp
+  USE temps_mod, ONLY: itau_dyn
+
+  implicit none
+
+  !
+  !   Ecriture du fichier histoire au format IOIPSL
+  !
+  !   Appels succesifs des routines: histwrite
+  !
+  !   Entree:
+  !  histid: ID du fichier histoire
+  !  time: temps de l'ecriture
+  !  vcov: vents v covariants
+  !  ucov: vents u covariants
+  !  teta: temperature potentielle
+  !  phi : geopotentiel instantane
+  !  q   : traceurs
+  !  masse: masse
+  !  ps   :pression au sol
+  !  phis : geopotentiel au sol
+  !
+  !
+  !   Sortie:
+  !  fileid: ID du fichier netcdf cree
+  !
+  !   L. Fairhead, LMD, 03/99
+  !
+  ! =====================================================================
+  !
+  !   Declarations
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom.h"
+  include "description.h"
+  include "iniprint.h"
+
+  !
+  !   Arguments
+  !
+
+  REAL :: vcov(ijb_v:ije_v,llm),ucov(ijb_u:ije_u,llm)
+  REAL :: teta(ijb_u:ije_u,llm),phi(ijb_u:ije_u,llm)
+  REAL :: ppk(ijb_u:ije_u,llm)
+  REAL :: ps(ijb_u:ije_u),masse(ijb_u:ije_u,llm)
+  REAL :: phis(ijb_u:ije_u)
+  REAL :: q(ijb_u:ije_u,llm,nqtot)
+  integer :: time
+
+
+  ! This routine needs IOIPSL
+  !   Variables locales
+  !
+  INTEGER,SAVE,ALLOCATABLE :: ndex2d(:),ndexu(:),ndexv(:)
+  INTEGER :: iq, ii, ll
+  REAL,SAVE,ALLOCATABLE :: tm(:,:)
+  REAL,SAVE,ALLOCATABLE :: vnat(:,:),unat(:,:)
+  logical :: ok_sync
+  integer :: itau_w
+  integer :: ijb,ije,jjn
+  LOGICAL,SAVE :: first=.TRUE.
+!$OMP THREADPRIVATE(first)
+
+  !
+  !  Initialisations
+  !
+  if (adjust) return
+
+  IF (first) THEN
+!$OMP BARRIER
+!$OMP MASTER
+    ALLOCATE(unat(ijb_u:ije_u,llm))
+    ALLOCATE(vnat(ijb_v:ije_v,llm))
+    ALLOCATE(tm(ijb_u:ije_u,llm))
+    ALLOCATE(ndex2d(ijnb_u*llm))
+    ALLOCATE(ndexu(ijnb_u*llm))
+    ALLOCATE(ndexv(ijnb_v*llm))
+    ndex2d = 0
+    ndexu = 0
+    ndexv = 0
+!$OMP END MASTER
+!$OMP BARRIER
+    first=.FALSE.
+  ENDIF
+
+  ok_sync = .TRUE.
+  itau_w = itau_dyn + time
+
+  ! Passage aux composantes naturelles du vent
+  call covnat_loc(llm, ucov, vcov, unat, vnat)
+
+  !
+  !  Appels a histwrite pour l'ecriture des variables a sauvegarder
+  !
+  !  Vents U
+  !
+
+!$OMP BARRIER
+!$OMP MASTER
+  ijb=ij_begin
+  ije=ij_end
+  jjn=jj_nb
+
+  call histwrite(histuid, 'u', itau_w, unat(ijb:ije,:), &
+        iip1*jjn*llm, ndexu)
+!$OMP END MASTER
+
+  !
+  !  Vents V
+  !
+  ije=ij_end
+  if (pole_sud) jjn=jj_nb-1
+  if (pole_sud) ije=ij_end-iip1
+!$OMP BARRIER
+!$OMP MASTER
+  call histwrite(histvid, 'v', itau_w, vnat(ijb:ije,:), &
+        iip1*jjn*llm, ndexv)
+!$OMP END MASTER
+
+
+  !
+  !  Temperature potentielle
+  !
+  ijb=ij_begin
+  ije=ij_end
+  jjn=jj_nb
+!$OMP MASTER
+  call histwrite(histid, 'theta', itau_w, teta(ijb:ije,:), &
+        iip1*jjn*llm, ndexu)
+!$OMP END MASTER
+
+  !
+  !  Temperature
+  !
+
+!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
+  do ll=1,llm
+    do ii = ijb, ije
+      tm(ii,ll) = teta(ii,ll) * ppk(ii,ll)/cpp
+    enddo
+  enddo
+!$OMP ENDDO
+
+!$OMP MASTER
+  call histwrite(histid, 'temp', itau_w, tm(ijb:ije,:), &
+        iip1*jjn*llm, ndexu)
+!$OMP END MASTER
+
+
+  !
+  !  Geopotentiel
+  !
+!$OMP MASTER
+  call histwrite(histid, 'phi', itau_w, phi(ijb:ije,:), &
+        iip1*jjn*llm, ndexu)
+!$OMP END MASTER
+
+
+  !
+  !  Traceurs
+  !
+  !!$OMP MASTER
+  !    DO iq=1,nqtot
+  !      call histwrite(histid, tracers(iq)%longName, itau_w,
+  ! .                   q(ijb:ije,:,iq), iip1*jjn*llm, ndexu)
+  !    enddo
+  !!$OMP END MASTER
+
+
+  !
+  !  Masse
+  !
+!$OMP MASTER
+   call histwrite(histid, 'masse', itau_w, masse(ijb:ije,:), &
+         iip1*jjn*llm, ndexu)
+!$OMP END MASTER
+
+
+  !
+  !  Pression au sol
+  !
+!$OMP MASTER
+   call histwrite(histid, 'ps', itau_w, ps(ijb:ije), &
+         iip1*jjn, ndex2d)
+!$OMP END MASTER
+
+  !
+  !  Geopotentiel au sol
+  !
+!$OMP MASTER
+    ! call histwrite(histid, 'phis', itau_w, phis(ijb:ije),
+  ! .                 iip1*jjn, ndex2d)
+!$OMP END MASTER
+
+  !
+  !  Fin
+  !
+!$OMP MASTER
+  if (ok_sync) then
+    call histsync(histid)
+    call histsync(histvid)
+    call histsync(histuid)
+  endif
+!$OMP END MASTER
+
+end subroutine writehist_loc
Index: DZ6/trunk/libf/dynphy_lonlat/calfis.F90
===================================================================
--- /LMDZ6/trunk/libf/dynphy_lonlat/calfis.F90	(revision 5267)
+++ 	(revision )
@@ -1,688 +1,0 @@
-!
-! $Id$
-!
-!
-!
-SUBROUTINE calfis(lafin, &
-        jD_cur, jH_cur, &
-        pucov, &
-        pvcov, &
-        pteta, &
-        pq, &
-        pmasse, &
-        pps, &
-        pp, &
-        ppk, &
-        pphis, &
-        pphi, &
-        pducov, &
-        pdvcov, &
-        pdteta, &
-        pdq, &
-        flxw, &
-        pdufi, &
-        pdvfi, &
-        pdhfi, &
-        pdqfi, &
-        pdpsfi)
-  !
-  !    Auteur :  P. Le Van, F. Hourdin
-  !   .........
-  USE infotrac, ONLY: nqtot, tracers
-  USE control_mod, ONLY: planet_type, nsplit_phys
-  USE callphysiq_mod, ONLY: call_physiq
-  USE comconst_mod, ONLY: cpp, daysec, dtphys, dtvr, kappa, pi
-  USE comvert_mod, ONLY: preff, presnivs
-  USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_PHYS
-
-  IMPLICIT NONE
-  !=======================================================================
-  !
-  !   1. rearrangement des tableaux et transformation
-  !  variables dynamiques  >  variables physiques
-  !   2. calcul des termes physiques
-  !   3. retransformation des tendances physiques en tendances dynamiques
-  !
-  !   remarques:
-  !   ----------
-  !
-  !    - les vents sont donnes dans la physique par leurs composantes
-  !  naturelles.
-  !    - la variable thermodynamique de la physique est une variable
-  !  intensive :   T
-  !  pour la dynamique on prend    T * ( preff / p(l) ) **kappa
-  !    - les deux seules variables dependant de la geometrie necessaires
-  !  pour la physique sont la latitude pour le rayonnement et
-  !  l'aire de la maille quand on veut integrer une grandeur
-  !  horizontalement.
-  !    - les points de la physique sont les points scalaires de la
-  !  la dynamique; numerotation:
-  !      1 pour le pole nord
-  !      (jjm-1)*iim pour l'interieur du domaine
-  !      ngridmx pour le pole sud
-  !  ---> ngridmx=2+(jjm-1)*iim
-  !
-  ! Input :
-  ! -------
-  !   pucov           covariant zonal velocity
-  !   pvcov           covariant meridional velocity
-  !   pteta           potential temperature
-  !   pps             surface pressure
-  !   pmasse          masse d'air dans chaque maille
-  !   pts             surface temperature  (K)
-  !   callrad         clef d'appel au rayonnement
-  !
-  !    Output :
-  !    --------
-  !    pdufi          tendency for the natural zonal velocity (ms-1)
-  !    pdvfi          tendency for the natural meridional velocity
-  !    pdhfi          tendency for the potential temperature
-  !    pdtsfi         tendency for the surface temperature
-  !
-  !    pdtrad         radiative tendencies  \  both input
-  !    pfluxrad       radiative fluxes      /  and output
-  !
-  !=======================================================================
-  !
-  !-----------------------------------------------------------------------
-  !
-  !    0.  Declarations :
-  !    ------------------
-
-  include "dimensions.h"
-  include "paramet.h"
-
-  INTEGER :: ngridmx
-  PARAMETER( ngridmx = 2+(jjm-1)*iim - 1/jjm   )
-
-  include "comgeom2.h"
-  include "iniprint.h"
-
-  !    Arguments :
-  !    -----------
-  LOGICAL,INTENT(IN) ::  lafin ! .true. for the very last call to physics
-  REAL,INTENT(IN):: jD_cur, jH_cur
-  REAL,INTENT(IN) :: pvcov(iip1,jjm,llm) ! covariant meridional velocity
-  REAL,INTENT(IN) :: pucov(iip1,jjp1,llm) ! covariant zonal velocity
-  REAL,INTENT(IN) :: pteta(iip1,jjp1,llm) ! potential temperature
-  REAL,INTENT(IN) :: pmasse(iip1,jjp1,llm) ! mass in each cell ! not used
-  REAL,INTENT(IN) :: pq(iip1,jjp1,llm,nqtot) ! tracers
-  REAL,INTENT(IN) :: pphis(iip1,jjp1) ! surface geopotential
-  REAL,INTENT(IN) :: pphi(iip1,jjp1,llm) ! geopotential
-
-  REAL,INTENT(IN) :: pdvcov(iip1,jjm,llm) ! dynamical tendency on vcov
-  REAL,INTENT(IN) :: pducov(iip1,jjp1,llm) ! dynamical tendency on ucov
-  REAL,INTENT(IN) :: pdteta(iip1,jjp1,llm) ! dynamical tendency on teta
-  ! ! NB: pdteta is used only to compute pcvgt which is in fact not used...
-  REAL,INTENT(IN) :: pdq(iip1,jjp1,llm,nqtot) ! dynamical tendency on tracers
-  ! ! NB: pdq is only used to compute pcvgq which is in fact not used...
-
-  REAL,INTENT(IN) :: pps(iip1,jjp1) ! surface pressure (Pa)
-  REAL,INTENT(IN) :: pp(iip1,jjp1,llmp1) ! pressure at mesh interfaces (Pa)
-  REAL,INTENT(IN) :: ppk(iip1,jjp1,llm) ! Exner at mid-layer
-  REAL,INTENT(IN) :: flxw(iip1,jjp1,llm) ! Vertical mass flux on lower mesh interfaces (kg/s) (on llm because flxw(:,:,llm+1)=0)
-
-  ! ! tendencies (in */s) from the physics
-  REAL,INTENT(OUT) :: pdvfi(iip1,jjm,llm) ! tendency on covariant meridional wind
-  REAL,INTENT(OUT) :: pdufi(iip1,jjp1,llm) ! tendency on covariant zonal wind
-  REAL,INTENT(OUT) :: pdhfi(iip1,jjp1,llm) ! tendency on potential temperature (K/s)
-  REAL,INTENT(OUT) :: pdqfi(iip1,jjp1,llm,nqtot) ! tendency on tracers
-  REAL,INTENT(OUT) :: pdpsfi(iip1,jjp1) ! tendency on surface pressure (Pa/s)
-
-
-  !    Local variables :
-  !    -----------------
-
-  INTEGER :: i,j,l,ig0,ig,iq,itr
-  REAL :: zpsrf(ngridmx)
-  REAL :: zplev(ngridmx,llm+1),zplay(ngridmx,llm)
-  REAL :: zphi(ngridmx,llm),zphis(ngridmx)
-  !
-  REAL :: zrot(iip1,jjm,llm) ! AdlC May 2014
-  REAL :: zufi(ngridmx,llm), zvfi(ngridmx,llm)
-  REAL :: zrfi(ngridmx,llm) ! relative wind vorticity
-  REAL :: ztfi(ngridmx,llm),zqfi(ngridmx,llm,nqtot)
-  REAL :: zpk(ngridmx,llm)
-  !
-  REAL :: pcvgu(ngridmx,llm), pcvgv(ngridmx,llm)
-  REAL :: pcvgt(ngridmx,llm), pcvgq(ngridmx,llm,2)
-  !
-  REAL :: zdufi(ngridmx,llm),zdvfi(ngridmx,llm)
-  REAL :: zdtfi(ngridmx,llm),zdqfi(ngridmx,llm,nqtot)
-  REAL :: zdpsrf(ngridmx)
-  !
-  REAL :: zdufic(ngridmx,llm),zdvfic(ngridmx,llm)
-  REAL :: zdtfic(ngridmx,llm),zdqfic(ngridmx,llm,nqtot)
-  REAL :: jH_cur_split,zdt_split
-  LOGICAL :: debut_split,lafin_split
-  INTEGER :: isplit
-
-  REAL :: zsin(iim),zcos(iim),z1(iim)
-  REAL :: zsinbis(iim),zcosbis(iim),z1bis(iim)
-  REAL :: unskap, pksurcp
-  !
-  REAL :: flxwfi(ngridmx,llm)  ! Flux de masse verticale sur la grille physiq
-  !
-
-  REAL :: SSUM
-
-  LOGICAL,SAVE :: firstcal=.true., debut=.true.
-   ! REAL rdayvrai
-
-  !
-  !-----------------------------------------------------------------------
-  !
-  !    1. Initialisations :
-  !    --------------------
-  !
-  !
-  IF ( firstcal )  THEN
-    debut = .TRUE.
-    IF (ngridmx.NE.2+(jjm-1)*iim) THEN
-     write(lunout,*) 'STOP dans calfis'
-     write(lunout,*) &
-           'La dimension ngridmx doit etre egale a 2 + (jjm-1)*iim'
-     write(lunout,*) '  ngridmx  jjm   iim   '
-     write(lunout,*) ngridmx,jjm,iim
-     call abort_gcm("calfis", "", 1)
-    ENDIF
-  ELSE
-    debut = .FALSE.
-  ENDIF ! of IF (firstcal)
-
-  !
-  !
-  !-----------------------------------------------------------------------
-  !   40. transformation des variables dynamiques en variables physiques:
-  !   ---------------------------------------------------------------
-
-  !   41. pressions au sol (en Pascals)
-  !   ----------------------------------
-
-
-  zpsrf(1) = pps(1,1)
-
-  ig0  = 2
-  DO j = 2,jjm
-     CALL SCOPY( iim,pps(1,j),1,zpsrf(ig0), 1 )
-     ig0 = ig0+iim
-  ENDDO
-
-  zpsrf(ngridmx) = pps(1,jjp1)
-
-
-  !   42. pression intercouches et fonction d'Exner:
-  !
-  !   -----------------------------------------------------------------
-  ! .... zplev  definis aux (llm +1) interfaces des couches  ....
-  ! .... zplay  definis aux (  llm )    milieux des couches  ....
-  !   -----------------------------------------------------------------
-
-  !    ...    Exner = cp * ( p(l) / preff ) ** kappa     ....
-  !
-   unskap   = 1./ kappa
-  !
-  DO l = 1, llm
-    zpk(   1,l ) = ppk(1,1,l)
-    zplev( 1,l ) = pp(1,1,l)
-    ig0 = 2
-      DO j = 2, jjm
-         DO i =1, iim
-          zpk(   ig0,l ) = ppk(i,j,l)
-          zplev( ig0,l ) = pp(i,j,l)
-          ig0 = ig0 +1
-         ENDDO
-      ENDDO
-    zpk(   ngridmx,l ) = ppk(1,jjp1,l)
-    zplev( ngridmx,l ) = pp(1,jjp1,l)
-  ENDDO
-    zplev( 1,llmp1 ) = pp(1,1,llmp1)
-    ig0 = 2
-      DO j = 2, jjm
-         DO i =1, iim
-          zplev( ig0,llmp1 ) = pp(i,j,llmp1)
-          ig0 = ig0 +1
-         ENDDO
-      ENDDO
-    zplev( ngridmx,llmp1 ) = pp(1,jjp1,llmp1)
-  !
-  !
-
-  !   43. temperature naturelle (en K) et pressions milieux couches .
-  !   ---------------------------------------------------------------
-
-  DO l=1,llm
-
-     pksurcp     =  ppk(1,1,l) / cpp
-     zplay(1,l)  =  preff * pksurcp ** unskap
-     ztfi(1,l)   =  pteta(1,1,l) *  pksurcp
-     pcvgt(1,l)  =  pdteta(1,1,l) * pksurcp / pmasse(1,1,l)
-     ig0         = 2
-
-     DO j = 2, jjm
-        DO i = 1, iim
-          pksurcp        = ppk(i,j,l) / cpp
-          zplay(ig0,l)   = preff * pksurcp ** unskap
-          ztfi(ig0,l)    = pteta(i,j,l)  * pksurcp
-          pcvgt(ig0,l)   = pdteta(i,j,l) * pksurcp / pmasse(i,j,l)
-          ig0            = ig0 + 1
-        ENDDO
-     ENDDO
-
-     pksurcp       = ppk(1,jjp1,l) / cpp
-     zplay(ig0,l)  = preff * pksurcp ** unskap
-     ztfi (ig0,l)  = pteta(1,jjp1,l)  * pksurcp
-     pcvgt(ig0,l)  = pdteta(1,jjp1,l) * pksurcp/ pmasse(1,jjp1,l)
-
-  ENDDO
-
-  !   43.bis traceurs
-  !   ---------------
-  !
-  itr=0
-  DO iq=1,nqtot
-     IF(.NOT.tracers(iq)%isAdvected) CYCLE
-     itr = itr + 1
-     DO l=1,llm
-        zqfi(1,l,itr) = pq(1,1,l,iq)
-        ig0           = 2
-        DO j=2,jjm
-           DO i = 1, iim
-              zqfi(ig0,l,itr) = pq(i,j,l,iq)
-              ig0             = ig0 + 1
-           ENDDO
-        ENDDO
-        zqfi(ig0,l,itr) = pq(1,jjp1,l,iq)
-     ENDDO
-  ENDDO
-
-  !   convergence dynamique pour les traceurs "EAU"
-  ! Earth-specific treatment of first 2 tracers (water)
-   if (planet_type=="earth") then
-    DO iq=1,2
-     DO l=1,llm
-        pcvgq(1,l,iq)= pdq(1,1,l,iq) / pmasse(1,1,l)
-        ig0          = 2
-        DO j=2,jjm
-           DO i = 1, iim
-              pcvgq(ig0,l,iq) = pdq(i,j,l,iq) / pmasse(i,j,l)
-              ig0             = ig0 + 1
-           ENDDO
-        ENDDO
-        pcvgq(ig0,l,iq)= pdq(1,jjp1,l,iq) / pmasse(1,jjp1,l)
-     ENDDO
-    ENDDO
-   endif ! of if (planet_type=="earth")
-
-
-  !   Geopotentiel calcule par rapport a la surface locale:
-  !   -----------------------------------------------------
-
-  CALL gr_dyn_fi(llm,iip1,jjp1,ngridmx,pphi,zphi)
-  CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,pphis,zphis)
-  DO l=1,llm
-     DO ig=1,ngridmx
-       zphi(ig,l)=zphi(ig,l)-zphis(ig)
-     ENDDO
-  ENDDO
-
-  !   ....  Calcul de la vitesse  verticale  ( en Pa*m*s  ou Kg/s )  ....
-  ! JG : ancien calcule de omega utilise dans physiq.F. Maintenant le flux
-  !    de masse est calclue dans advtrac.F
-   ! DO l=1,llm
-   !   pvervel(1,l)=pw(1,1,l) * g /apoln
-   !   ig0=2
-   !  DO j=2,jjm
-   !      DO i = 1, iim
-   !         pvervel(ig0,l) = pw(i,j,l) * g * unsaire(i,j)
-   !         ig0 = ig0 + 1
-   !      ENDDO
-  !       ENDDO
-   !   pvervel(ig0,l)=pw(1,jjp1,l) * g /apols
-   ! ENDDO
-
-  !
-  !   45. champ u:
-  !   ------------
-
-  DO l=1,llm
-
-     DO j=2,jjm
-        ig0 = 1+(j-2)*iim
-        zufi(ig0+1,l)= 0.5 * &
-              ( pucov(iim,j,l)/cu(iim,j) + pucov(1,j,l)/cu(1,j) )
-        pcvgu(ig0+1,l)= 0.5 * &
-              ( pducov(iim,j,l)/cu(iim,j) + pducov(1,j,l)/cu(1,j) )
-        DO i=2,iim
-           zufi(ig0+i,l)= 0.5 * &
-                 ( pucov(i-1,j,l)/cu(i-1,j) + pucov(i,j,l)/cu(i,j) )
-           pcvgu(ig0+i,l)= 0.5 * &
-                 ( pducov(i-1,j,l)/cu(i-1,j) + pducov(i,j,l)/cu(i,j) )
-        END DO
-     END DO
-
-  END DO
-
-
-  !  Alvaro de la Camara (May 2014)
-  !  46.1 Calcul de la vorticite et passage sur la grille physique
-  !  --------------------------------------------------------------
-  DO l=1,llm
-    do i=1,iim
-      do j=1,jjm
-        zrot(i,j,l) = (pvcov(i+1,j,l) - pvcov(i,j,l) &
-              + pucov(i,j+1,l) - pucov(i,j,l)) &
-              / (cu(i,j)+cu(i,j+1)) &
-              / (cv(i+1,j)+cv(i,j)) *4
-      enddo
-    enddo
-  ENDDO
-
-  !   46.champ v:
-  !   -----------
-
-  DO l=1,llm
-     DO j=2,jjm
-        ig0=1+(j-2)*iim
-        DO i=1,iim
-           zvfi(ig0+i,l)= 0.5 * &
-                 ( pvcov(i,j-1,l)/cv(i,j-1) + pvcov(i,j,l)/cv(i,j) )
-           pcvgv(ig0+i,l)= 0.5 * &
-                 ( pdvcov(i,j-1,l)/cv(i,j-1) + pdvcov(i,j,l)/cv(i,j) )
-        ENDDO
-           zrfi(ig0 + 1,l)= 0.25 *(zrot(iim,j-1,l)+zrot(iim,j,l) &
-                 +zrot(1,j-1,l)+zrot(1,j,l))
-        DO i=2,iim
-           zrfi(ig0 + i,l)= 0.25 *(zrot(i-1,j-1,l)+zrot(i-1,j,l) &
-                 +zrot(i,j-1,l)+zrot(i,j,l))   !  AdlC MAY 2014
-        ENDDO
-     ENDDO
-  ENDDO
-
-
-  !   47. champs de vents aux pole nord
-  !   ------------------------------
-     ! U = 1 / pi  *  integrale [ v * cos(long) * d long ]
-     ! V = 1 / pi  *  integrale [ v * sin(long) * d long ]
-
-  DO l=1,llm
-
-     z1(1)   =(rlonu(1)-rlonu(iim)+2.*pi)*pvcov(1,1,l)/cv(1,1)
-     z1bis(1)=(rlonu(1)-rlonu(iim)+2.*pi)*pdvcov(1,1,l)/cv(1,1)
-     DO i=2,iim
-        z1(i)   =(rlonu(i)-rlonu(i-1))*pvcov(i,1,l)/cv(i,1)
-        z1bis(i)=(rlonu(i)-rlonu(i-1))*pdvcov(i,1,l)/cv(i,1)
-     ENDDO
-
-     DO i=1,iim
-        zcos(i)   = COS(rlonv(i))*z1(i)
-        zcosbis(i)= COS(rlonv(i))*z1bis(i)
-        zsin(i)   = SIN(rlonv(i))*z1(i)
-        zsinbis(i)= SIN(rlonv(i))*z1bis(i)
-     ENDDO
-
-     zufi(1,l)  = SSUM(iim,zcos,1)/pi
-     pcvgu(1,l) = SSUM(iim,zcosbis,1)/pi
-     zvfi(1,l)  = SSUM(iim,zsin,1)/pi
-     pcvgv(1,l) = SSUM(iim,zsinbis,1)/pi
-     zrfi(1, l) = 0.
-  ENDDO
-
-
-  !   48. champs de vents aux pole sud:
-  !   ---------------------------------
-     ! U = 1 / pi  *  integrale [ v * cos(long) * d long ]
-     ! V = 1 / pi  *  integrale [ v * sin(long) * d long ]
-
-  DO l=1,llm
-
-     z1(1)   =(rlonu(1)-rlonu(iim)+2.*pi)*pvcov(1,jjm,l)/cv(1,jjm)
-     z1bis(1)=(rlonu(1)-rlonu(iim)+2.*pi)*pdvcov(1,jjm,l)/cv(1,jjm)
-     DO i=2,iim
-        z1(i)   =(rlonu(i)-rlonu(i-1))*pvcov(i,jjm,l)/cv(i,jjm)
-        z1bis(i)=(rlonu(i)-rlonu(i-1))*pdvcov(i,jjm,l)/cv(i,jjm)
-     ENDDO
-
-     DO i=1,iim
-        zcos(i)    = COS(rlonv(i))*z1(i)
-        zcosbis(i) = COS(rlonv(i))*z1bis(i)
-        zsin(i)    = SIN(rlonv(i))*z1(i)
-        zsinbis(i) = SIN(rlonv(i))*z1bis(i)
-     ENDDO
-
-     zufi(ngridmx,l)  = SSUM(iim,zcos,1)/pi
-     pcvgu(ngridmx,l) = SSUM(iim,zcosbis,1)/pi
-     zvfi(ngridmx,l)  = SSUM(iim,zsin,1)/pi
-     pcvgv(ngridmx,l) = SSUM(iim,zsinbis,1)/pi
-     zrfi(ngridmx, l) = 0.
-  ENDDO
-  !
-  ! On change de grille, dynamique vers physiq, pour le flux de masse verticale
-  CALL gr_dyn_fi(llm,iip1,jjp1,ngridmx,flxw,flxwfi)
-
-  !-----------------------------------------------------------------------
-  !   Appel de la physique:
-  !   ---------------------
-
-
-
-   ! write(lunout,*) 'PHYSIQUE AVEC NSPLIT_PHYS=',nsplit_phys
-  zdt_split=dtphys/nsplit_phys
-  zdufic(:,:)=0.
-  zdvfic(:,:)=0.
-  zdtfic(:,:)=0.
-  zdqfic(:,:,:)=0.
-
-IF (CPPKEY_PHYS) THEN
-
-   do isplit=1,nsplit_phys
-
-     jH_cur_split=jH_cur+(isplit-1) * dtvr / (daysec *nsplit_phys)
-     debut_split=debut.and.isplit==1
-     lafin_split=lafin.and.isplit==nsplit_phys
-
-   ! if (planet_type=="earth") then
-    CALL call_physiq(ngridmx,llm,nqtot,tracers(:)%name, &
-          debut_split,lafin_split, &
-          jD_cur,jH_cur_split,zdt_split, &
-          zplev,zplay, &
-          zpk,zphi,zphis, &
-          presnivs, &
-          zufi,zvfi,zrfi,ztfi,zqfi, &
-          flxwfi,pducov, &
-          zdufi,zdvfi,zdtfi,zdqfi,zdpsrf)
-  !
-  !  else if ( planet_type=="generic" ) then
-  !
-  !     CALL physiq (ngridmx,     !! ngrid
-  ! .             llm,            !! nlayer
-  ! .             nqtot,          !! nq
-  ! .             tracers(:)%name,!! tracer names from dynamical core (given in infotrac)
-  ! .             debut_split,    !! firstcall
-  ! .             lafin_split,    !! lastcall
-  ! .             jD_cur,         !! pday. see leapfrog
-  ! .             jH_cur_split,   !! ptime "fraction of day"
-  ! .             zdt_split,      !! ptimestep
-  ! .             zplev,          !! pplev
-  ! .             zplay,          !! pplay
-  ! .             zphi,           !! pphi
-  ! .             zufi,           !! pu
-  ! .             zvfi,           !! pv
-  ! .             ztfi,           !! pt
-  ! .             zqfi,           !! pq
-  ! .             flxwfi,         !! pw !! or 0. anyway this is for diagnostic. not used in physiq.
-  ! .             zdufi,          !! pdu
-  ! .             zdvfi,          !! pdv
-  ! .             zdtfi,          !! pdt
-  ! .             zdqfi,          !! pdq
-  ! .             zdpsrf,         !! pdpsrf
-  ! .             tracerdyn)      !! tracerdyn <-- utilite ???
-  !
-  !  endif ! of if (planet_type=="earth")
-
-     zufi(:,:)=zufi(:,:)+zdufi(:,:)*zdt_split
-     zvfi(:,:)=zvfi(:,:)+zdvfi(:,:)*zdt_split
-     ztfi(:,:)=ztfi(:,:)+zdtfi(:,:)*zdt_split
-     zqfi(:,:,:)=zqfi(:,:,:)+zdqfi(:,:,:)*zdt_split
-
-     zdufic(:,:)=zdufic(:,:)+zdufi(:,:)
-     zdvfic(:,:)=zdvfic(:,:)+zdvfi(:,:)
-     zdtfic(:,:)=zdtfic(:,:)+zdtfi(:,:)
-     zdqfic(:,:,:)=zdqfic(:,:,:)+zdqfi(:,:,:)
-
-   enddo ! of do isplit=1,nsplit_phys
-
-END IF
-  ! of #ifdef CPP_PHYS
-
-  zdufi(:,:)=zdufic(:,:)/nsplit_phys
-  zdvfi(:,:)=zdvfic(:,:)/nsplit_phys
-  zdtfi(:,:)=zdtfic(:,:)/nsplit_phys
-  zdqfi(:,:,:)=zdqfic(:,:,:)/nsplit_phys
-
-
-500   CONTINUE
-
-  !-----------------------------------------------------------------------
-  !   transformation des tendances physiques en tendances dynamiques:
-  !   ---------------------------------------------------------------
-
-  !  tendance sur la pression :
-  !  -----------------------------------
-
-  CALL gr_fi_dyn(1,ngridmx,iip1,jjp1,zdpsrf,pdpsfi)
-  !
-  !   62. enthalpie potentielle
-  !   ---------------------
-
-  DO l=1,llm
-
-     DO i=1,iip1
-      pdhfi(i,1,l)    = cpp *  zdtfi(1,l)      / ppk(i, 1  ,l)
-      pdhfi(i,jjp1,l) = cpp *  zdtfi(ngridmx,l)/ ppk(i,jjp1,l)
-     ENDDO
-
-     DO j=2,jjm
-        ig0=1+(j-2)*iim
-        DO i=1,iim
-           pdhfi(i,j,l) = cpp * zdtfi(ig0+i,l) / ppk(i,j,l)
-        ENDDO
-           pdhfi(iip1,j,l) =  pdhfi(1,j,l)
-     ENDDO
-
-  ENDDO
-
-
-  !   62. humidite specifique
-  !   ---------------------
-  ! Ehouarn: removed this useless bit: was overwritten at step 63 anyways
-   ! DO iq=1,nqtot
-   !    DO l=1,llm
-   !       DO i=1,iip1
-   !          pdqfi(i,1,l,iq)    = zdqfi(1,l,iq)
-   !          pdqfi(i,jjp1,l,iq) = zdqfi(ngridmx,l,iq)
-   !       ENDDO
-   !       DO j=2,jjm
-   !          ig0=1+(j-2)*iim
-   !          DO i=1,iim
-   !             pdqfi(i,j,l,iq) = zdqfi(ig0+i,l,iq)
-   !          ENDDO
-   !          pdqfi(iip1,j,l,iq) = pdqfi(1,j,l,iq)
-   !       ENDDO
-   !    ENDDO
-   ! ENDDO
-
-  !   63. traceurs
-  !   ------------
-  ! initialisation des tendances
-  pdqfi(:,:,:,:)=0.
-  !
-  itr = 0
-  DO iq=1,nqtot
-     IF(.NOT.tracers(iq)%isAdvected) CYCLE
-     itr = itr + 1
-     DO l=1,llm
-        DO i=1,iip1
-           pdqfi(i,1,l,iq)    = zdqfi(1,l,itr)
-           pdqfi(i,jjp1,l,iq) = zdqfi(ngridmx,l,itr)
-        ENDDO
-        DO j=2,jjm
-           ig0=1+(j-2)*iim
-           DO i=1,iim
-              pdqfi(i,j,l,iq) = zdqfi(ig0+i,l,itr)
-           ENDDO
-           pdqfi(iip1,j,l,iq) = pdqfi(1,j,l,itr)
-        ENDDO
-     ENDDO
-  ENDDO
-
-  !   65. champ u:
-  !   ------------
-
-  DO l=1,llm
-
-     DO i=1,iip1
-        pdufi(i,1,l)    = 0.
-        pdufi(i,jjp1,l) = 0.
-     ENDDO
-
-     DO j=2,jjm
-        ig0=1+(j-2)*iim
-        DO i=1,iim-1
-           pdufi(i,j,l)= &
-                 0.5*(zdufi(ig0+i,l)+zdufi(ig0+i+1,l))*cu(i,j)
-        ENDDO
-        pdufi(iim,j,l)= &
-              0.5*(zdufi(ig0+1,l)+zdufi(ig0+iim,l))*cu(iim,j)
-        pdufi(iip1,j,l)=pdufi(1,j,l)
-     ENDDO
-
-  ENDDO
-
-
-  !   67. champ v:
-  !   ------------
-
-  DO l=1,llm
-
-     DO j=2,jjm-1
-        ig0=1+(j-2)*iim
-        DO i=1,iim
-           pdvfi(i,j,l)= &
-                 0.5*(zdvfi(ig0+i,l)+zdvfi(ig0+i+iim,l))*cv(i,j)
-        ENDDO
-        pdvfi(iip1,j,l) = pdvfi(1,j,l)
-     ENDDO
-  ENDDO
-
-
-  !   68. champ v pres des poles:
-  !   ---------------------------
-   ! v = U * cos(long) + V * SIN(long)
-
-  DO l=1,llm
-
-     DO i=1,iim
-        pdvfi(i,1,l)= &
-              zdufi(1,l)*COS(rlonv(i))+zdvfi(1,l)*SIN(rlonv(i))
-        pdvfi(i,jjm,l)=zdufi(ngridmx,l)*COS(rlonv(i)) &
-              +zdvfi(ngridmx,l)*SIN(rlonv(i))
-        pdvfi(i,1,l)= &
-              0.5*(pdvfi(i,1,l)+zdvfi(i+1,l))*cv(i,1)
-        pdvfi(i,jjm,l)= &
-              0.5*(pdvfi(i,jjm,l)+zdvfi(ngridmx-iip1+i,l))*cv(i,jjm)
-      ENDDO
-
-     pdvfi(iip1,1,l)  = pdvfi(1,1,l)
-     pdvfi(iip1,jjm,l)= pdvfi(1,jjm,l)
-
-  ENDDO
-
-  !-----------------------------------------------------------------------
-
-700   CONTINUE
-
-  firstcal = .FALSE.
-
-  RETURN
-END SUBROUTINE calfis
Index: /LMDZ6/trunk/libf/dynphy_lonlat/calfis.f90
===================================================================
--- /LMDZ6/trunk/libf/dynphy_lonlat/calfis.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dynphy_lonlat/calfis.f90	(revision 5268)
@@ -0,0 +1,688 @@
+!
+! $Id$
+!
+!
+!
+SUBROUTINE calfis(lafin, &
+        jD_cur, jH_cur, &
+        pucov, &
+        pvcov, &
+        pteta, &
+        pq, &
+        pmasse, &
+        pps, &
+        pp, &
+        ppk, &
+        pphis, &
+        pphi, &
+        pducov, &
+        pdvcov, &
+        pdteta, &
+        pdq, &
+        flxw, &
+        pdufi, &
+        pdvfi, &
+        pdhfi, &
+        pdqfi, &
+        pdpsfi)
+  !
+  !    Auteur :  P. Le Van, F. Hourdin
+  !   .........
+  USE infotrac, ONLY: nqtot, tracers
+  USE control_mod, ONLY: planet_type, nsplit_phys
+  USE callphysiq_mod, ONLY: call_physiq
+  USE comconst_mod, ONLY: cpp, daysec, dtphys, dtvr, kappa, pi
+  USE comvert_mod, ONLY: preff, presnivs
+  USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_PHYS
+
+  IMPLICIT NONE
+  !=======================================================================
+  !
+  !   1. rearrangement des tableaux et transformation
+  !  variables dynamiques  >  variables physiques
+  !   2. calcul des termes physiques
+  !   3. retransformation des tendances physiques en tendances dynamiques
+  !
+  !   remarques:
+  !   ----------
+  !
+  !    - les vents sont donnes dans la physique par leurs composantes
+  !  naturelles.
+  !    - la variable thermodynamique de la physique est une variable
+  !  intensive :   T
+  !  pour la dynamique on prend    T * ( preff / p(l) ) **kappa
+  !    - les deux seules variables dependant de la geometrie necessaires
+  !  pour la physique sont la latitude pour le rayonnement et
+  !  l'aire de la maille quand on veut integrer une grandeur
+  !  horizontalement.
+  !    - les points de la physique sont les points scalaires de la
+  !  la dynamique; numerotation:
+  !      1 pour le pole nord
+  !      (jjm-1)*iim pour l'interieur du domaine
+  !      ngridmx pour le pole sud
+  !  ---> ngridmx=2+(jjm-1)*iim
+  !
+  ! Input :
+  ! -------
+  !   pucov           covariant zonal velocity
+  !   pvcov           covariant meridional velocity
+  !   pteta           potential temperature
+  !   pps             surface pressure
+  !   pmasse          masse d'air dans chaque maille
+  !   pts             surface temperature  (K)
+  !   callrad         clef d'appel au rayonnement
+  !
+  !    Output :
+  !    --------
+  !    pdufi          tendency for the natural zonal velocity (ms-1)
+  !    pdvfi          tendency for the natural meridional velocity
+  !    pdhfi          tendency for the potential temperature
+  !    pdtsfi         tendency for the surface temperature
+  !
+  !    pdtrad         radiative tendencies  \  both input
+  !    pfluxrad       radiative fluxes      /  and output
+  !
+  !=======================================================================
+  !
+  !-----------------------------------------------------------------------
+  !
+  !    0.  Declarations :
+  !    ------------------
+
+  include "dimensions.h"
+  include "paramet.h"
+
+  INTEGER :: ngridmx
+  PARAMETER( ngridmx = 2+(jjm-1)*iim - 1/jjm   )
+
+  include "comgeom2.h"
+  include "iniprint.h"
+
+  !    Arguments :
+  !    -----------
+  LOGICAL,INTENT(IN) ::  lafin ! .true. for the very last call to physics
+  REAL,INTENT(IN):: jD_cur, jH_cur
+  REAL,INTENT(IN) :: pvcov(iip1,jjm,llm) ! covariant meridional velocity
+  REAL,INTENT(IN) :: pucov(iip1,jjp1,llm) ! covariant zonal velocity
+  REAL,INTENT(IN) :: pteta(iip1,jjp1,llm) ! potential temperature
+  REAL,INTENT(IN) :: pmasse(iip1,jjp1,llm) ! mass in each cell ! not used
+  REAL,INTENT(IN) :: pq(iip1,jjp1,llm,nqtot) ! tracers
+  REAL,INTENT(IN) :: pphis(iip1,jjp1) ! surface geopotential
+  REAL,INTENT(IN) :: pphi(iip1,jjp1,llm) ! geopotential
+
+  REAL,INTENT(IN) :: pdvcov(iip1,jjm,llm) ! dynamical tendency on vcov
+  REAL,INTENT(IN) :: pducov(iip1,jjp1,llm) ! dynamical tendency on ucov
+  REAL,INTENT(IN) :: pdteta(iip1,jjp1,llm) ! dynamical tendency on teta
+  ! ! NB: pdteta is used only to compute pcvgt which is in fact not used...
+  REAL,INTENT(IN) :: pdq(iip1,jjp1,llm,nqtot) ! dynamical tendency on tracers
+  ! ! NB: pdq is only used to compute pcvgq which is in fact not used...
+
+  REAL,INTENT(IN) :: pps(iip1,jjp1) ! surface pressure (Pa)
+  REAL,INTENT(IN) :: pp(iip1,jjp1,llmp1) ! pressure at mesh interfaces (Pa)
+  REAL,INTENT(IN) :: ppk(iip1,jjp1,llm) ! Exner at mid-layer
+  REAL,INTENT(IN) :: flxw(iip1,jjp1,llm) ! Vertical mass flux on lower mesh interfaces (kg/s) (on llm because flxw(:,:,llm+1)=0)
+
+  ! ! tendencies (in */s) from the physics
+  REAL,INTENT(OUT) :: pdvfi(iip1,jjm,llm) ! tendency on covariant meridional wind
+  REAL,INTENT(OUT) :: pdufi(iip1,jjp1,llm) ! tendency on covariant zonal wind
+  REAL,INTENT(OUT) :: pdhfi(iip1,jjp1,llm) ! tendency on potential temperature (K/s)
+  REAL,INTENT(OUT) :: pdqfi(iip1,jjp1,llm,nqtot) ! tendency on tracers
+  REAL,INTENT(OUT) :: pdpsfi(iip1,jjp1) ! tendency on surface pressure (Pa/s)
+
+
+  !    Local variables :
+  !    -----------------
+
+  INTEGER :: i,j,l,ig0,ig,iq,itr
+  REAL :: zpsrf(ngridmx)
+  REAL :: zplev(ngridmx,llm+1),zplay(ngridmx,llm)
+  REAL :: zphi(ngridmx,llm),zphis(ngridmx)
+  !
+  REAL :: zrot(iip1,jjm,llm) ! AdlC May 2014
+  REAL :: zufi(ngridmx,llm), zvfi(ngridmx,llm)
+  REAL :: zrfi(ngridmx,llm) ! relative wind vorticity
+  REAL :: ztfi(ngridmx,llm),zqfi(ngridmx,llm,nqtot)
+  REAL :: zpk(ngridmx,llm)
+  !
+  REAL :: pcvgu(ngridmx,llm), pcvgv(ngridmx,llm)
+  REAL :: pcvgt(ngridmx,llm), pcvgq(ngridmx,llm,2)
+  !
+  REAL :: zdufi(ngridmx,llm),zdvfi(ngridmx,llm)
+  REAL :: zdtfi(ngridmx,llm),zdqfi(ngridmx,llm,nqtot)
+  REAL :: zdpsrf(ngridmx)
+  !
+  REAL :: zdufic(ngridmx,llm),zdvfic(ngridmx,llm)
+  REAL :: zdtfic(ngridmx,llm),zdqfic(ngridmx,llm,nqtot)
+  REAL :: jH_cur_split,zdt_split
+  LOGICAL :: debut_split,lafin_split
+  INTEGER :: isplit
+
+  REAL :: zsin(iim),zcos(iim),z1(iim)
+  REAL :: zsinbis(iim),zcosbis(iim),z1bis(iim)
+  REAL :: unskap, pksurcp
+  !
+  REAL :: flxwfi(ngridmx,llm)  ! Flux de masse verticale sur la grille physiq
+  !
+
+  REAL :: SSUM
+
+  LOGICAL,SAVE :: firstcal=.true., debut=.true.
+   ! REAL rdayvrai
+
+  !
+  !-----------------------------------------------------------------------
+  !
+  !    1. Initialisations :
+  !    --------------------
+  !
+  !
+  IF ( firstcal )  THEN
+    debut = .TRUE.
+    IF (ngridmx.NE.2+(jjm-1)*iim) THEN
+     write(lunout,*) 'STOP dans calfis'
+     write(lunout,*) &
+           'La dimension ngridmx doit etre egale a 2 + (jjm-1)*iim'
+     write(lunout,*) '  ngridmx  jjm   iim   '
+     write(lunout,*) ngridmx,jjm,iim
+     call abort_gcm("calfis", "", 1)
+    ENDIF
+  ELSE
+    debut = .FALSE.
+  ENDIF ! of IF (firstcal)
+
+  !
+  !
+  !-----------------------------------------------------------------------
+  !   40. transformation des variables dynamiques en variables physiques:
+  !   ---------------------------------------------------------------
+
+  !   41. pressions au sol (en Pascals)
+  !   ----------------------------------
+
+
+  zpsrf(1) = pps(1,1)
+
+  ig0  = 2
+  DO j = 2,jjm
+     CALL SCOPY( iim,pps(1,j),1,zpsrf(ig0), 1 )
+     ig0 = ig0+iim
+  ENDDO
+
+  zpsrf(ngridmx) = pps(1,jjp1)
+
+
+  !   42. pression intercouches et fonction d'Exner:
+  !
+  !   -----------------------------------------------------------------
+  ! .... zplev  definis aux (llm +1) interfaces des couches  ....
+  ! .... zplay  definis aux (  llm )    milieux des couches  ....
+  !   -----------------------------------------------------------------
+
+  !    ...    Exner = cp * ( p(l) / preff ) ** kappa     ....
+  !
+   unskap   = 1./ kappa
+  !
+  DO l = 1, llm
+    zpk(   1,l ) = ppk(1,1,l)
+    zplev( 1,l ) = pp(1,1,l)
+    ig0 = 2
+      DO j = 2, jjm
+         DO i =1, iim
+          zpk(   ig0,l ) = ppk(i,j,l)
+          zplev( ig0,l ) = pp(i,j,l)
+          ig0 = ig0 +1
+         ENDDO
+      ENDDO
+    zpk(   ngridmx,l ) = ppk(1,jjp1,l)
+    zplev( ngridmx,l ) = pp(1,jjp1,l)
+  ENDDO
+    zplev( 1,llmp1 ) = pp(1,1,llmp1)
+    ig0 = 2
+      DO j = 2, jjm
+         DO i =1, iim
+          zplev( ig0,llmp1 ) = pp(i,j,llmp1)
+          ig0 = ig0 +1
+         ENDDO
+      ENDDO
+    zplev( ngridmx,llmp1 ) = pp(1,jjp1,llmp1)
+  !
+  !
+
+  !   43. temperature naturelle (en K) et pressions milieux couches .
+  !   ---------------------------------------------------------------
+
+  DO l=1,llm
+
+     pksurcp     =  ppk(1,1,l) / cpp
+     zplay(1,l)  =  preff * pksurcp ** unskap
+     ztfi(1,l)   =  pteta(1,1,l) *  pksurcp
+     pcvgt(1,l)  =  pdteta(1,1,l) * pksurcp / pmasse(1,1,l)
+     ig0         = 2
+
+     DO j = 2, jjm
+        DO i = 1, iim
+          pksurcp        = ppk(i,j,l) / cpp
+          zplay(ig0,l)   = preff * pksurcp ** unskap
+          ztfi(ig0,l)    = pteta(i,j,l)  * pksurcp
+          pcvgt(ig0,l)   = pdteta(i,j,l) * pksurcp / pmasse(i,j,l)
+          ig0            = ig0 + 1
+        ENDDO
+     ENDDO
+
+     pksurcp       = ppk(1,jjp1,l) / cpp
+     zplay(ig0,l)  = preff * pksurcp ** unskap
+     ztfi (ig0,l)  = pteta(1,jjp1,l)  * pksurcp
+     pcvgt(ig0,l)  = pdteta(1,jjp1,l) * pksurcp/ pmasse(1,jjp1,l)
+
+  ENDDO
+
+  !   43.bis traceurs
+  !   ---------------
+  !
+  itr=0
+  DO iq=1,nqtot
+     IF(.NOT.tracers(iq)%isAdvected) CYCLE
+     itr = itr + 1
+     DO l=1,llm
+        zqfi(1,l,itr) = pq(1,1,l,iq)
+        ig0           = 2
+        DO j=2,jjm
+           DO i = 1, iim
+              zqfi(ig0,l,itr) = pq(i,j,l,iq)
+              ig0             = ig0 + 1
+           ENDDO
+        ENDDO
+        zqfi(ig0,l,itr) = pq(1,jjp1,l,iq)
+     ENDDO
+  ENDDO
+
+  !   convergence dynamique pour les traceurs "EAU"
+  ! Earth-specific treatment of first 2 tracers (water)
+   if (planet_type=="earth") then
+    DO iq=1,2
+     DO l=1,llm
+        pcvgq(1,l,iq)= pdq(1,1,l,iq) / pmasse(1,1,l)
+        ig0          = 2
+        DO j=2,jjm
+           DO i = 1, iim
+              pcvgq(ig0,l,iq) = pdq(i,j,l,iq) / pmasse(i,j,l)
+              ig0             = ig0 + 1
+           ENDDO
+        ENDDO
+        pcvgq(ig0,l,iq)= pdq(1,jjp1,l,iq) / pmasse(1,jjp1,l)
+     ENDDO
+    ENDDO
+   endif ! of if (planet_type=="earth")
+
+
+  !   Geopotentiel calcule par rapport a la surface locale:
+  !   -----------------------------------------------------
+
+  CALL gr_dyn_fi(llm,iip1,jjp1,ngridmx,pphi,zphi)
+  CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,pphis,zphis)
+  DO l=1,llm
+     DO ig=1,ngridmx
+       zphi(ig,l)=zphi(ig,l)-zphis(ig)
+     ENDDO
+  ENDDO
+
+  !   ....  Calcul de la vitesse  verticale  ( en Pa*m*s  ou Kg/s )  ....
+  ! JG : ancien calcule de omega utilise dans physiq.F. Maintenant le flux
+  !    de masse est calclue dans advtrac.F
+   ! DO l=1,llm
+   !   pvervel(1,l)=pw(1,1,l) * g /apoln
+   !   ig0=2
+   !  DO j=2,jjm
+   !      DO i = 1, iim
+   !         pvervel(ig0,l) = pw(i,j,l) * g * unsaire(i,j)
+   !         ig0 = ig0 + 1
+   !      ENDDO
+  !       ENDDO
+   !   pvervel(ig0,l)=pw(1,jjp1,l) * g /apols
+   ! ENDDO
+
+  !
+  !   45. champ u:
+  !   ------------
+
+  DO l=1,llm
+
+     DO j=2,jjm
+        ig0 = 1+(j-2)*iim
+        zufi(ig0+1,l)= 0.5 * &
+              ( pucov(iim,j,l)/cu(iim,j) + pucov(1,j,l)/cu(1,j) )
+        pcvgu(ig0+1,l)= 0.5 * &
+              ( pducov(iim,j,l)/cu(iim,j) + pducov(1,j,l)/cu(1,j) )
+        DO i=2,iim
+           zufi(ig0+i,l)= 0.5 * &
+                 ( pucov(i-1,j,l)/cu(i-1,j) + pucov(i,j,l)/cu(i,j) )
+           pcvgu(ig0+i,l)= 0.5 * &
+                 ( pducov(i-1,j,l)/cu(i-1,j) + pducov(i,j,l)/cu(i,j) )
+        END DO
+     END DO
+
+  END DO
+
+
+  !  Alvaro de la Camara (May 2014)
+  !  46.1 Calcul de la vorticite et passage sur la grille physique
+  !  --------------------------------------------------------------
+  DO l=1,llm
+    do i=1,iim
+      do j=1,jjm
+        zrot(i,j,l) = (pvcov(i+1,j,l) - pvcov(i,j,l) &
+              + pucov(i,j+1,l) - pucov(i,j,l)) &
+              / (cu(i,j)+cu(i,j+1)) &
+              / (cv(i+1,j)+cv(i,j)) *4
+      enddo
+    enddo
+  ENDDO
+
+  !   46.champ v:
+  !   -----------
+
+  DO l=1,llm
+     DO j=2,jjm
+        ig0=1+(j-2)*iim
+        DO i=1,iim
+           zvfi(ig0+i,l)= 0.5 * &
+                 ( pvcov(i,j-1,l)/cv(i,j-1) + pvcov(i,j,l)/cv(i,j) )
+           pcvgv(ig0+i,l)= 0.5 * &
+                 ( pdvcov(i,j-1,l)/cv(i,j-1) + pdvcov(i,j,l)/cv(i,j) )
+        ENDDO
+           zrfi(ig0 + 1,l)= 0.25 *(zrot(iim,j-1,l)+zrot(iim,j,l) &
+                 +zrot(1,j-1,l)+zrot(1,j,l))
+        DO i=2,iim
+           zrfi(ig0 + i,l)= 0.25 *(zrot(i-1,j-1,l)+zrot(i-1,j,l) &
+                 +zrot(i,j-1,l)+zrot(i,j,l))   !  AdlC MAY 2014
+        ENDDO
+     ENDDO
+  ENDDO
+
+
+  !   47. champs de vents aux pole nord
+  !   ------------------------------
+     ! U = 1 / pi  *  integrale [ v * cos(long) * d long ]
+     ! V = 1 / pi  *  integrale [ v * sin(long) * d long ]
+
+  DO l=1,llm
+
+     z1(1)   =(rlonu(1)-rlonu(iim)+2.*pi)*pvcov(1,1,l)/cv(1,1)
+     z1bis(1)=(rlonu(1)-rlonu(iim)+2.*pi)*pdvcov(1,1,l)/cv(1,1)
+     DO i=2,iim
+        z1(i)   =(rlonu(i)-rlonu(i-1))*pvcov(i,1,l)/cv(i,1)
+        z1bis(i)=(rlonu(i)-rlonu(i-1))*pdvcov(i,1,l)/cv(i,1)
+     ENDDO
+
+     DO i=1,iim
+        zcos(i)   = COS(rlonv(i))*z1(i)
+        zcosbis(i)= COS(rlonv(i))*z1bis(i)
+        zsin(i)   = SIN(rlonv(i))*z1(i)
+        zsinbis(i)= SIN(rlonv(i))*z1bis(i)
+     ENDDO
+
+     zufi(1,l)  = SSUM(iim,zcos,1)/pi
+     pcvgu(1,l) = SSUM(iim,zcosbis,1)/pi
+     zvfi(1,l)  = SSUM(iim,zsin,1)/pi
+     pcvgv(1,l) = SSUM(iim,zsinbis,1)/pi
+     zrfi(1, l) = 0.
+  ENDDO
+
+
+  !   48. champs de vents aux pole sud:
+  !   ---------------------------------
+     ! U = 1 / pi  *  integrale [ v * cos(long) * d long ]
+     ! V = 1 / pi  *  integrale [ v * sin(long) * d long ]
+
+  DO l=1,llm
+
+     z1(1)   =(rlonu(1)-rlonu(iim)+2.*pi)*pvcov(1,jjm,l)/cv(1,jjm)
+     z1bis(1)=(rlonu(1)-rlonu(iim)+2.*pi)*pdvcov(1,jjm,l)/cv(1,jjm)
+     DO i=2,iim
+        z1(i)   =(rlonu(i)-rlonu(i-1))*pvcov(i,jjm,l)/cv(i,jjm)
+        z1bis(i)=(rlonu(i)-rlonu(i-1))*pdvcov(i,jjm,l)/cv(i,jjm)
+     ENDDO
+
+     DO i=1,iim
+        zcos(i)    = COS(rlonv(i))*z1(i)
+        zcosbis(i) = COS(rlonv(i))*z1bis(i)
+        zsin(i)    = SIN(rlonv(i))*z1(i)
+        zsinbis(i) = SIN(rlonv(i))*z1bis(i)
+     ENDDO
+
+     zufi(ngridmx,l)  = SSUM(iim,zcos,1)/pi
+     pcvgu(ngridmx,l) = SSUM(iim,zcosbis,1)/pi
+     zvfi(ngridmx,l)  = SSUM(iim,zsin,1)/pi
+     pcvgv(ngridmx,l) = SSUM(iim,zsinbis,1)/pi
+     zrfi(ngridmx, l) = 0.
+  ENDDO
+  !
+  ! On change de grille, dynamique vers physiq, pour le flux de masse verticale
+  CALL gr_dyn_fi(llm,iip1,jjp1,ngridmx,flxw,flxwfi)
+
+  !-----------------------------------------------------------------------
+  !   Appel de la physique:
+  !   ---------------------
+
+
+
+   ! write(lunout,*) 'PHYSIQUE AVEC NSPLIT_PHYS=',nsplit_phys
+  zdt_split=dtphys/nsplit_phys
+  zdufic(:,:)=0.
+  zdvfic(:,:)=0.
+  zdtfic(:,:)=0.
+  zdqfic(:,:,:)=0.
+
+IF (CPPKEY_PHYS) THEN
+
+   do isplit=1,nsplit_phys
+
+     jH_cur_split=jH_cur+(isplit-1) * dtvr / (daysec *nsplit_phys)
+     debut_split=debut.and.isplit==1
+     lafin_split=lafin.and.isplit==nsplit_phys
+
+   ! if (planet_type=="earth") then
+    CALL call_physiq(ngridmx,llm,nqtot,tracers(:)%name, &
+          debut_split,lafin_split, &
+          jD_cur,jH_cur_split,zdt_split, &
+          zplev,zplay, &
+          zpk,zphi,zphis, &
+          presnivs, &
+          zufi,zvfi,zrfi,ztfi,zqfi, &
+          flxwfi,pducov, &
+          zdufi,zdvfi,zdtfi,zdqfi,zdpsrf)
+  !
+  !  else if ( planet_type=="generic" ) then
+  !
+  !     CALL physiq (ngridmx,     !! ngrid
+  ! .             llm,            !! nlayer
+  ! .             nqtot,          !! nq
+  ! .             tracers(:)%name,!! tracer names from dynamical core (given in infotrac)
+  ! .             debut_split,    !! firstcall
+  ! .             lafin_split,    !! lastcall
+  ! .             jD_cur,         !! pday. see leapfrog
+  ! .             jH_cur_split,   !! ptime "fraction of day"
+  ! .             zdt_split,      !! ptimestep
+  ! .             zplev,          !! pplev
+  ! .             zplay,          !! pplay
+  ! .             zphi,           !! pphi
+  ! .             zufi,           !! pu
+  ! .             zvfi,           !! pv
+  ! .             ztfi,           !! pt
+  ! .             zqfi,           !! pq
+  ! .             flxwfi,         !! pw !! or 0. anyway this is for diagnostic. not used in physiq.
+  ! .             zdufi,          !! pdu
+  ! .             zdvfi,          !! pdv
+  ! .             zdtfi,          !! pdt
+  ! .             zdqfi,          !! pdq
+  ! .             zdpsrf,         !! pdpsrf
+  ! .             tracerdyn)      !! tracerdyn <-- utilite ???
+  !
+  !  endif ! of if (planet_type=="earth")
+
+     zufi(:,:)=zufi(:,:)+zdufi(:,:)*zdt_split
+     zvfi(:,:)=zvfi(:,:)+zdvfi(:,:)*zdt_split
+     ztfi(:,:)=ztfi(:,:)+zdtfi(:,:)*zdt_split
+     zqfi(:,:,:)=zqfi(:,:,:)+zdqfi(:,:,:)*zdt_split
+
+     zdufic(:,:)=zdufic(:,:)+zdufi(:,:)
+     zdvfic(:,:)=zdvfic(:,:)+zdvfi(:,:)
+     zdtfic(:,:)=zdtfic(:,:)+zdtfi(:,:)
+     zdqfic(:,:,:)=zdqfic(:,:,:)+zdqfi(:,:,:)
+
+   enddo ! of do isplit=1,nsplit_phys
+
+END IF
+  ! of #ifdef CPP_PHYS
+
+  zdufi(:,:)=zdufic(:,:)/nsplit_phys
+  zdvfi(:,:)=zdvfic(:,:)/nsplit_phys
+  zdtfi(:,:)=zdtfic(:,:)/nsplit_phys
+  zdqfi(:,:,:)=zdqfic(:,:,:)/nsplit_phys
+
+
+500   CONTINUE
+
+  !-----------------------------------------------------------------------
+  !   transformation des tendances physiques en tendances dynamiques:
+  !   ---------------------------------------------------------------
+
+  !  tendance sur la pression :
+  !  -----------------------------------
+
+  CALL gr_fi_dyn(1,ngridmx,iip1,jjp1,zdpsrf,pdpsfi)
+  !
+  !   62. enthalpie potentielle
+  !   ---------------------
+
+  DO l=1,llm
+
+     DO i=1,iip1
+      pdhfi(i,1,l)    = cpp *  zdtfi(1,l)      / ppk(i, 1  ,l)
+      pdhfi(i,jjp1,l) = cpp *  zdtfi(ngridmx,l)/ ppk(i,jjp1,l)
+     ENDDO
+
+     DO j=2,jjm
+        ig0=1+(j-2)*iim
+        DO i=1,iim
+           pdhfi(i,j,l) = cpp * zdtfi(ig0+i,l) / ppk(i,j,l)
+        ENDDO
+           pdhfi(iip1,j,l) =  pdhfi(1,j,l)
+     ENDDO
+
+  ENDDO
+
+
+  !   62. humidite specifique
+  !   ---------------------
+  ! Ehouarn: removed this useless bit: was overwritten at step 63 anyways
+   ! DO iq=1,nqtot
+   !    DO l=1,llm
+   !       DO i=1,iip1
+   !          pdqfi(i,1,l,iq)    = zdqfi(1,l,iq)
+   !          pdqfi(i,jjp1,l,iq) = zdqfi(ngridmx,l,iq)
+   !       ENDDO
+   !       DO j=2,jjm
+   !          ig0=1+(j-2)*iim
+   !          DO i=1,iim
+   !             pdqfi(i,j,l,iq) = zdqfi(ig0+i,l,iq)
+   !          ENDDO
+   !          pdqfi(iip1,j,l,iq) = pdqfi(1,j,l,iq)
+   !       ENDDO
+   !    ENDDO
+   ! ENDDO
+
+  !   63. traceurs
+  !   ------------
+  ! initialisation des tendances
+  pdqfi(:,:,:,:)=0.
+  !
+  itr = 0
+  DO iq=1,nqtot
+     IF(.NOT.tracers(iq)%isAdvected) CYCLE
+     itr = itr + 1
+     DO l=1,llm
+        DO i=1,iip1
+           pdqfi(i,1,l,iq)    = zdqfi(1,l,itr)
+           pdqfi(i,jjp1,l,iq) = zdqfi(ngridmx,l,itr)
+        ENDDO
+        DO j=2,jjm
+           ig0=1+(j-2)*iim
+           DO i=1,iim
+              pdqfi(i,j,l,iq) = zdqfi(ig0+i,l,itr)
+           ENDDO
+           pdqfi(iip1,j,l,iq) = pdqfi(1,j,l,itr)
+        ENDDO
+     ENDDO
+  ENDDO
+
+  !   65. champ u:
+  !   ------------
+
+  DO l=1,llm
+
+     DO i=1,iip1
+        pdufi(i,1,l)    = 0.
+        pdufi(i,jjp1,l) = 0.
+     ENDDO
+
+     DO j=2,jjm
+        ig0=1+(j-2)*iim
+        DO i=1,iim-1
+           pdufi(i,j,l)= &
+                 0.5*(zdufi(ig0+i,l)+zdufi(ig0+i+1,l))*cu(i,j)
+        ENDDO
+        pdufi(iim,j,l)= &
+              0.5*(zdufi(ig0+1,l)+zdufi(ig0+iim,l))*cu(iim,j)
+        pdufi(iip1,j,l)=pdufi(1,j,l)
+     ENDDO
+
+  ENDDO
+
+
+  !   67. champ v:
+  !   ------------
+
+  DO l=1,llm
+
+     DO j=2,jjm-1
+        ig0=1+(j-2)*iim
+        DO i=1,iim
+           pdvfi(i,j,l)= &
+                 0.5*(zdvfi(ig0+i,l)+zdvfi(ig0+i+iim,l))*cv(i,j)
+        ENDDO
+        pdvfi(iip1,j,l) = pdvfi(1,j,l)
+     ENDDO
+  ENDDO
+
+
+  !   68. champ v pres des poles:
+  !   ---------------------------
+   ! v = U * cos(long) + V * SIN(long)
+
+  DO l=1,llm
+
+     DO i=1,iim
+        pdvfi(i,1,l)= &
+              zdufi(1,l)*COS(rlonv(i))+zdvfi(1,l)*SIN(rlonv(i))
+        pdvfi(i,jjm,l)=zdufi(ngridmx,l)*COS(rlonv(i)) &
+              +zdvfi(ngridmx,l)*SIN(rlonv(i))
+        pdvfi(i,1,l)= &
+              0.5*(pdvfi(i,1,l)+zdvfi(i+1,l))*cv(i,1)
+        pdvfi(i,jjm,l)= &
+              0.5*(pdvfi(i,jjm,l)+zdvfi(ngridmx-iip1+i,l))*cv(i,jjm)
+      ENDDO
+
+     pdvfi(iip1,1,l)  = pdvfi(1,1,l)
+     pdvfi(iip1,jjm,l)= pdvfi(1,jjm,l)
+
+  ENDDO
+
+  !-----------------------------------------------------------------------
+
+700   CONTINUE
+
+  firstcal = .FALSE.
+
+  RETURN
+END SUBROUTINE calfis
Index: DZ6/trunk/libf/dynphy_lonlat/inigeomphy_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/dynphy_lonlat/inigeomphy_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,243 +1,0 @@
-!
-! $Id: $
-!
-MODULE inigeomphy_mod
-
-CONTAINS
-
-SUBROUTINE inigeomphy(iim,jjm,nlayer, &
-                     nbp, communicator, &
-                     rlatu,rlatv,rlonu,rlonv,aire,cu,cv)
-  USE mod_grid_phy_lmdz, ONLY: klon_glo,  & ! number of atmospheric columns (on full grid)
-                               regular_lonlat, &  ! regular longitude-latitude grid type
-                               nbp_lon, nbp_lat, nbp_lev
-  USE mod_phys_lmdz_para, ONLY: klon_omp, & ! number of columns (on local omp grid)
-                                klon_omp_begin, & ! start index of local omp subgrid
-                                klon_omp_end, & ! end index of local omp subgrid
-                                klon_mpi_begin ! start indes of columns (on local mpi grid)
-  USE geometry_mod, ONLY : init_geometry
-  USE physics_distribution_mod, ONLY : init_physics_distribution
-  USE regular_lonlat_mod, ONLY : init_regular_lonlat, &
-                                 east, west, north, south, &
-                                 north_east, north_west, &
-                                 south_west, south_east
-  USE mod_interface_dyn_phys, ONLY :  init_interface_dyn_phys
-  USE nrtype, ONLY: pi
-  USE comvert_mod, ONLY: preff, ap, bp, aps, bps, presnivs, &
-                         scaleheight, pseudoalt, presinter
-  USE vertical_layers_mod, ONLY: init_vertical_layers
-  IMPLICIT NONE
-
-  ! =======================================================================
-  ! Initialisation of the physical constants and some positional and
-  ! geometrical arrays for the physics
-  ! =======================================================================
-
-  include "iniprint.h"
-
-  INTEGER, INTENT (IN) :: nlayer ! number of atmospheric layers
-  INTEGER, INTENT (IN) :: iim ! number of atmospheric columns along longitudes
-  INTEGER, INTENT (IN) :: jjm ! number of atompsheric columns along latitudes
-  INTEGER, INTENT(IN) :: nbp ! number of physics columns for this MPI process
-  INTEGER, INTENT(IN) :: communicator ! MPI communicator
-  REAL, INTENT (IN) :: rlatu(jjm+1) ! latitudes of the physics grid
-  REAL, INTENT (IN) :: rlatv(jjm) ! latitude boundaries of the physics grid
-  REAL, INTENT (IN) :: rlonv(iim+1) ! longitudes of the physics grid
-  REAL, INTENT (IN) :: rlonu(iim+1) ! longitude boundaries of the physics grid
-  REAL, INTENT (IN) :: aire(iim+1,jjm+1) ! area of the dynamics grid (m2)
-  REAL, INTENT (IN) :: cu((iim+1)*(jjm+1)) ! cu coeff. (u_covariant = cu * u)
-  REAL, INTENT (IN) :: cv((iim+1)*jjm) ! cv coeff. (v_covariant = cv * v)
-
-  INTEGER :: ibegin, iend, offset
-  INTEGER :: i,j,k
-  CHARACTER (LEN=20) :: modname = 'inigeomphy'
-  CHARACTER (LEN=80) :: abort_message
-  REAL :: total_area_phy, total_area_dyn
-
-  ! boundaries, on global grid
-  REAL,ALLOCATABLE :: boundslon_reg(:,:)
-  REAL,ALLOCATABLE :: boundslat_reg(:,:)
-
-  ! global array, on full physics grid:
-  REAL,ALLOCATABLE :: latfi_glo(:)
-  REAL,ALLOCATABLE :: lonfi_glo(:)
-  REAL,ALLOCATABLE :: cufi_glo(:)
-  REAL,ALLOCATABLE :: cvfi_glo(:)
-  REAL,ALLOCATABLE :: airefi_glo(:)
-  REAL,ALLOCATABLE :: boundslonfi_glo(:,:)
-  REAL,ALLOCATABLE :: boundslatfi_glo(:,:)
-
-  ! local arrays, on given MPI/OpenMP domain:
-  REAL,ALLOCATABLE,SAVE :: latfi(:)
-  REAL,ALLOCATABLE,SAVE :: lonfi(:)
-  REAL,ALLOCATABLE,SAVE :: cufi(:)
-  REAL,ALLOCATABLE,SAVE :: cvfi(:)
-  REAL,ALLOCATABLE,SAVE :: airefi(:)
-  REAL,ALLOCATABLE,SAVE :: boundslonfi(:,:)
-  REAL,ALLOCATABLE,SAVE :: boundslatfi(:,:)
-  INTEGER,ALLOCATABLE,SAVE :: ind_cell_glo_fi(:)
-!$OMP THREADPRIVATE (latfi,lonfi,cufi,cvfi,airefi,boundslonfi,boundslatfi,ind_cell_glo_fi)
-
-  ! Initialize Physics distibution and parameters and interface with dynamics
-  IF (iim*jjm>1) THEN ! general 3D case
-    CALL init_physics_distribution(regular_lonlat,4, &
-                                 nbp,iim,jjm+1,nlayer,communicator)
-  ELSE ! For 1D model
-    CALL init_physics_distribution(regular_lonlat,4, &
-                                 1,1,1,nlayer,communicator)
-  ENDIF
-  CALL init_interface_dyn_phys
-  
-  ! init regular global longitude-latitude grid points and boundaries
-  ALLOCATE(boundslon_reg(iim,2))
-  ALLOCATE(boundslat_reg(jjm+1,2))
-  
-  ! specific handling of the -180 longitude scalar grid point boundaries
-  boundslon_reg(1,east)=rlonu(1)
-  boundslon_reg(1,west)=rlonu(iim)-2*PI
-  DO i=2,iim
-   boundslon_reg(i,east)=rlonu(i) 
-   boundslon_reg(i,west)=rlonu(i-1) 
-  ENDDO
-
-  boundslat_reg(1,north)= PI/2 
-  boundslat_reg(1,south)= rlatv(1)
-  DO j=2,jjm
-   boundslat_reg(j,north)=rlatv(j-1) 
-   boundslat_reg(j,south)=rlatv(j) 
-  ENDDO
-  boundslat_reg(jjm+1,north)= rlatv(jjm) 
-  boundslat_reg(jjm+1,south)= -PI/2
-
-  ! Write values in module regular_lonlat_mod
-  CALL init_regular_lonlat(iim,jjm+1, rlonv(1:iim), rlatu, &
-                           boundslon_reg, boundslat_reg)
-
-  ! Generate global arrays on full physics grid
-  ALLOCATE(latfi_glo(klon_glo),lonfi_glo(klon_glo))
-  ALLOCATE(cufi_glo(klon_glo),cvfi_glo(klon_glo))
-  ALLOCATE(airefi_glo(klon_glo))
-  ALLOCATE(boundslonfi_glo(klon_glo,4))
-  ALLOCATE(boundslatfi_glo(klon_glo,4))
-
-  IF (klon_glo>1) THEN ! general case
-    ! North pole
-    latfi_glo(1)=rlatu(1)
-    lonfi_glo(1)=0.
-    cufi_glo(1) = cu(1)
-    cvfi_glo(1) = cv(1)
-    boundslonfi_glo(1,north_east)=PI
-    boundslatfi_glo(1,north_east)=PI/2
-    boundslonfi_glo(1,north_west)=-PI
-    boundslatfi_glo(1,north_west)=PI/2
-    boundslonfi_glo(1,south_west)=-PI
-    boundslatfi_glo(1,south_west)=rlatv(1)
-    boundslonfi_glo(1,south_east)=PI
-    boundslatfi_glo(1,south_east)=rlatv(1)
-    DO j=2,jjm
-      DO i=1,iim
-        k=(j-2)*iim+1+i
-        latfi_glo(k)= rlatu(j)
-        lonfi_glo(k)= rlonv(i)
-        cufi_glo(k) = cu((j-1)*(iim+1)+i)
-        cvfi_glo(k) = cv((j-1)*(iim+1)+i)
-        boundslonfi_glo(k,north_east)=rlonu(i)
-        boundslatfi_glo(k,north_east)=rlatv(j-1)
-        if (i.eq.1) then
-          ! special case for the first longitude's west bound
-          boundslonfi_glo(k,north_west)=rlonu(iim)-2*PI
-          boundslonfi_glo(k,south_west)=rlonu(iim)-2*PI
-        else
-          boundslonfi_glo(k,north_west)=rlonu(i-1)
-          boundslonfi_glo(k,south_west)=rlonu(i-1)
-        endif
-        boundslatfi_glo(k,north_west)=rlatv(j-1)
-        boundslatfi_glo(k,south_west)=rlatv(j)
-        boundslonfi_glo(k,south_east)=rlonu(i)
-        boundslatfi_glo(k,south_east)=rlatv(j)
-      ENDDO
-    ENDDO
-    ! South pole
-    latfi_glo(klon_glo)= rlatu(jjm+1)
-    lonfi_glo(klon_glo)= 0.
-    cufi_glo(klon_glo) = cu((iim+1)*jjm+1)
-    cvfi_glo(klon_glo) = cv((iim+1)*jjm-iim)
-    boundslonfi_glo(klon_glo,north_east)= PI
-    boundslatfi_glo(klon_glo,north_east)= rlatv(jjm)
-    boundslonfi_glo(klon_glo,north_west)= -PI
-    boundslatfi_glo(klon_glo,north_west)= rlatv(jjm)
-    boundslonfi_glo(klon_glo,south_west)= -PI
-    boundslatfi_glo(klon_glo,south_west)= -PI/2
-    boundslonfi_glo(klon_glo,south_east)= PI
-    boundslatfi_glo(klon_glo,south_east)= -Pi/2
-
-    ! build airefi(), mesh area on physics grid
-    CALL gr_dyn_fi(1,iim+1,jjm+1,klon_glo,aire,airefi_glo)
-    ! Poles are single points on physics grid
-    airefi_glo(1)=sum(aire(1:iim,1))
-    airefi_glo(klon_glo)=sum(aire(1:iim,jjm+1))
-
-    ! Sanity check: do total planet area match between physics and dynamics?
-    total_area_dyn=sum(aire(1:iim,1:jjm+1))
-    total_area_phy=sum(airefi_glo(1:klon_glo))
-    IF (total_area_dyn/=total_area_phy) THEN
-      WRITE (lunout, *) 'inigeomphy: planet total surface discrepancy !!!'
-      WRITE (lunout, *) '     in the dynamics total_area_dyn=', total_area_dyn
-      WRITE (lunout, *) '  but in the physics total_area_phy=', total_area_phy
-      IF (abs(total_area_dyn-total_area_phy)>0.00001*total_area_dyn) THEN
-        ! stop here if the relative difference is more than 0.001%
-        abort_message = 'planet total surface discrepancy'
-        CALL abort_gcm(modname, abort_message, 1)
-      ENDIF
-    ENDIF
-  ELSE ! klon_glo==1, running the 1D model
-    ! just copy over input values
-    latfi_glo(1)=rlatu(1)
-    lonfi_glo(1)=rlonv(1)
-    cufi_glo(1)=cu(1)
-    cvfi_glo(1)=cv(1)
-    airefi_glo(1)=aire(1,1)
-    boundslonfi_glo(1,north_east)=rlonu(1)
-    boundslatfi_glo(1,north_east)=PI/2
-    boundslonfi_glo(1,north_west)=rlonu(2)
-    boundslatfi_glo(1,north_west)=PI/2
-    boundslonfi_glo(1,south_west)=rlonu(2)
-    boundslatfi_glo(1,south_west)=rlatv(1)
-    boundslonfi_glo(1,south_east)=rlonu(1)
-    boundslatfi_glo(1,south_east)=rlatv(1)
-  ENDIF ! of IF (klon_glo>1)
-
-!$OMP PARALLEL 
-  ! Now generate local lon/lat/cu/cv/area/bounds arrays
-  ALLOCATE(latfi(klon_omp),lonfi(klon_omp),cufi(klon_omp),cvfi(klon_omp))
-  ALLOCATE(airefi(klon_omp))
-  ALLOCATE(boundslonfi(klon_omp,4))
-  ALLOCATE(boundslatfi(klon_omp,4))
-  ALLOCATE(ind_cell_glo_fi(klon_omp))
-
-
-  offset = klon_mpi_begin - 1
-  airefi(1:klon_omp) = airefi_glo(offset+klon_omp_begin:offset+klon_omp_end)
-  cufi(1:klon_omp) = cufi_glo(offset+klon_omp_begin:offset+klon_omp_end)
-  cvfi(1:klon_omp) = cvfi_glo(offset+klon_omp_begin:offset+klon_omp_end)
-  lonfi(1:klon_omp) = lonfi_glo(offset+klon_omp_begin:offset+klon_omp_end)
-  latfi(1:klon_omp) = latfi_glo(offset+klon_omp_begin:offset+klon_omp_end)
-  boundslonfi(1:klon_omp,:) = boundslonfi_glo(offset+klon_omp_begin:offset+klon_omp_end,:)
-  boundslatfi(1:klon_omp,:) = boundslatfi_glo(offset+klon_omp_begin:offset+klon_omp_end,:)
-  ind_cell_glo_fi(1:klon_omp)=(/ (i,i=offset+klon_omp_begin,offset+klon_omp_end) /)
-
-  ! copy over local grid longitudes and latitudes
-  CALL init_geometry(klon_omp,lonfi,latfi,boundslonfi,boundslatfi, &
-                     airefi,ind_cell_glo_fi,cufi,cvfi)
-
-  ! copy over preff , ap(), bp(), etc 
-  CALL init_vertical_layers(nlayer,preff,scaleheight, &
-                            ap,bp,aps,bps,presnivs,presinter,pseudoalt)
-
-!$OMP END PARALLEL
-
-
-END SUBROUTINE inigeomphy
-
-END MODULE inigeomphy_mod
-
Index: /LMDZ6/trunk/libf/dynphy_lonlat/inigeomphy_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/dynphy_lonlat/inigeomphy_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dynphy_lonlat/inigeomphy_mod.f90	(revision 5268)
@@ -0,0 +1,243 @@
+!
+! $Id: $
+!
+MODULE inigeomphy_mod
+
+CONTAINS
+
+SUBROUTINE inigeomphy(iim,jjm,nlayer, &
+                     nbp, communicator, &
+                     rlatu,rlatv,rlonu,rlonv,aire,cu,cv)
+  USE mod_grid_phy_lmdz, ONLY: klon_glo,  & ! number of atmospheric columns (on full grid)
+                               regular_lonlat, &  ! regular longitude-latitude grid type
+                               nbp_lon, nbp_lat, nbp_lev
+  USE mod_phys_lmdz_para, ONLY: klon_omp, & ! number of columns (on local omp grid)
+                                klon_omp_begin, & ! start index of local omp subgrid
+                                klon_omp_end, & ! end index of local omp subgrid
+                                klon_mpi_begin ! start indes of columns (on local mpi grid)
+  USE geometry_mod, ONLY : init_geometry
+  USE physics_distribution_mod, ONLY : init_physics_distribution
+  USE regular_lonlat_mod, ONLY : init_regular_lonlat, &
+                                 east, west, north, south, &
+                                 north_east, north_west, &
+                                 south_west, south_east
+  USE mod_interface_dyn_phys, ONLY :  init_interface_dyn_phys
+  USE nrtype, ONLY: pi
+  USE comvert_mod, ONLY: preff, ap, bp, aps, bps, presnivs, &
+                         scaleheight, pseudoalt, presinter
+  USE vertical_layers_mod, ONLY: init_vertical_layers
+  IMPLICIT NONE
+
+  ! =======================================================================
+  ! Initialisation of the physical constants and some positional and
+  ! geometrical arrays for the physics
+  ! =======================================================================
+
+  include "iniprint.h"
+
+  INTEGER, INTENT (IN) :: nlayer ! number of atmospheric layers
+  INTEGER, INTENT (IN) :: iim ! number of atmospheric columns along longitudes
+  INTEGER, INTENT (IN) :: jjm ! number of atompsheric columns along latitudes
+  INTEGER, INTENT(IN) :: nbp ! number of physics columns for this MPI process
+  INTEGER, INTENT(IN) :: communicator ! MPI communicator
+  REAL, INTENT (IN) :: rlatu(jjm+1) ! latitudes of the physics grid
+  REAL, INTENT (IN) :: rlatv(jjm) ! latitude boundaries of the physics grid
+  REAL, INTENT (IN) :: rlonv(iim+1) ! longitudes of the physics grid
+  REAL, INTENT (IN) :: rlonu(iim+1) ! longitude boundaries of the physics grid
+  REAL, INTENT (IN) :: aire(iim+1,jjm+1) ! area of the dynamics grid (m2)
+  REAL, INTENT (IN) :: cu((iim+1)*(jjm+1)) ! cu coeff. (u_covariant = cu * u)
+  REAL, INTENT (IN) :: cv((iim+1)*jjm) ! cv coeff. (v_covariant = cv * v)
+
+  INTEGER :: ibegin, iend, offset
+  INTEGER :: i,j,k
+  CHARACTER (LEN=20) :: modname = 'inigeomphy'
+  CHARACTER (LEN=80) :: abort_message
+  REAL :: total_area_phy, total_area_dyn
+
+  ! boundaries, on global grid
+  REAL,ALLOCATABLE :: boundslon_reg(:,:)
+  REAL,ALLOCATABLE :: boundslat_reg(:,:)
+
+  ! global array, on full physics grid:
+  REAL,ALLOCATABLE :: latfi_glo(:)
+  REAL,ALLOCATABLE :: lonfi_glo(:)
+  REAL,ALLOCATABLE :: cufi_glo(:)
+  REAL,ALLOCATABLE :: cvfi_glo(:)
+  REAL,ALLOCATABLE :: airefi_glo(:)
+  REAL,ALLOCATABLE :: boundslonfi_glo(:,:)
+  REAL,ALLOCATABLE :: boundslatfi_glo(:,:)
+
+  ! local arrays, on given MPI/OpenMP domain:
+  REAL,ALLOCATABLE,SAVE :: latfi(:)
+  REAL,ALLOCATABLE,SAVE :: lonfi(:)
+  REAL,ALLOCATABLE,SAVE :: cufi(:)
+  REAL,ALLOCATABLE,SAVE :: cvfi(:)
+  REAL,ALLOCATABLE,SAVE :: airefi(:)
+  REAL,ALLOCATABLE,SAVE :: boundslonfi(:,:)
+  REAL,ALLOCATABLE,SAVE :: boundslatfi(:,:)
+  INTEGER,ALLOCATABLE,SAVE :: ind_cell_glo_fi(:)
+!$OMP THREADPRIVATE (latfi,lonfi,cufi,cvfi,airefi,boundslonfi,boundslatfi,ind_cell_glo_fi)
+
+  ! Initialize Physics distibution and parameters and interface with dynamics
+  IF (iim*jjm>1) THEN ! general 3D case
+    CALL init_physics_distribution(regular_lonlat,4, &
+                                 nbp,iim,jjm+1,nlayer,communicator)
+  ELSE ! For 1D model
+    CALL init_physics_distribution(regular_lonlat,4, &
+                                 1,1,1,nlayer,communicator)
+  ENDIF
+  CALL init_interface_dyn_phys
+  
+  ! init regular global longitude-latitude grid points and boundaries
+  ALLOCATE(boundslon_reg(iim,2))
+  ALLOCATE(boundslat_reg(jjm+1,2))
+  
+  ! specific handling of the -180 longitude scalar grid point boundaries
+  boundslon_reg(1,east)=rlonu(1)
+  boundslon_reg(1,west)=rlonu(iim)-2*PI
+  DO i=2,iim
+   boundslon_reg(i,east)=rlonu(i) 
+   boundslon_reg(i,west)=rlonu(i-1) 
+  ENDDO
+
+  boundslat_reg(1,north)= PI/2 
+  boundslat_reg(1,south)= rlatv(1)
+  DO j=2,jjm
+   boundslat_reg(j,north)=rlatv(j-1) 
+   boundslat_reg(j,south)=rlatv(j) 
+  ENDDO
+  boundslat_reg(jjm+1,north)= rlatv(jjm) 
+  boundslat_reg(jjm+1,south)= -PI/2
+
+  ! Write values in module regular_lonlat_mod
+  CALL init_regular_lonlat(iim,jjm+1, rlonv(1:iim), rlatu, &
+                           boundslon_reg, boundslat_reg)
+
+  ! Generate global arrays on full physics grid
+  ALLOCATE(latfi_glo(klon_glo),lonfi_glo(klon_glo))
+  ALLOCATE(cufi_glo(klon_glo),cvfi_glo(klon_glo))
+  ALLOCATE(airefi_glo(klon_glo))
+  ALLOCATE(boundslonfi_glo(klon_glo,4))
+  ALLOCATE(boundslatfi_glo(klon_glo,4))
+
+  IF (klon_glo>1) THEN ! general case
+    ! North pole
+    latfi_glo(1)=rlatu(1)
+    lonfi_glo(1)=0.
+    cufi_glo(1) = cu(1)
+    cvfi_glo(1) = cv(1)
+    boundslonfi_glo(1,north_east)=PI
+    boundslatfi_glo(1,north_east)=PI/2
+    boundslonfi_glo(1,north_west)=-PI
+    boundslatfi_glo(1,north_west)=PI/2
+    boundslonfi_glo(1,south_west)=-PI
+    boundslatfi_glo(1,south_west)=rlatv(1)
+    boundslonfi_glo(1,south_east)=PI
+    boundslatfi_glo(1,south_east)=rlatv(1)
+    DO j=2,jjm
+      DO i=1,iim
+        k=(j-2)*iim+1+i
+        latfi_glo(k)= rlatu(j)
+        lonfi_glo(k)= rlonv(i)
+        cufi_glo(k) = cu((j-1)*(iim+1)+i)
+        cvfi_glo(k) = cv((j-1)*(iim+1)+i)
+        boundslonfi_glo(k,north_east)=rlonu(i)
+        boundslatfi_glo(k,north_east)=rlatv(j-1)
+        if (i.eq.1) then
+          ! special case for the first longitude's west bound
+          boundslonfi_glo(k,north_west)=rlonu(iim)-2*PI
+          boundslonfi_glo(k,south_west)=rlonu(iim)-2*PI
+        else
+          boundslonfi_glo(k,north_west)=rlonu(i-1)
+          boundslonfi_glo(k,south_west)=rlonu(i-1)
+        endif
+        boundslatfi_glo(k,north_west)=rlatv(j-1)
+        boundslatfi_glo(k,south_west)=rlatv(j)
+        boundslonfi_glo(k,south_east)=rlonu(i)
+        boundslatfi_glo(k,south_east)=rlatv(j)
+      ENDDO
+    ENDDO
+    ! South pole
+    latfi_glo(klon_glo)= rlatu(jjm+1)
+    lonfi_glo(klon_glo)= 0.
+    cufi_glo(klon_glo) = cu((iim+1)*jjm+1)
+    cvfi_glo(klon_glo) = cv((iim+1)*jjm-iim)
+    boundslonfi_glo(klon_glo,north_east)= PI
+    boundslatfi_glo(klon_glo,north_east)= rlatv(jjm)
+    boundslonfi_glo(klon_glo,north_west)= -PI
+    boundslatfi_glo(klon_glo,north_west)= rlatv(jjm)
+    boundslonfi_glo(klon_glo,south_west)= -PI
+    boundslatfi_glo(klon_glo,south_west)= -PI/2
+    boundslonfi_glo(klon_glo,south_east)= PI
+    boundslatfi_glo(klon_glo,south_east)= -Pi/2
+
+    ! build airefi(), mesh area on physics grid
+    CALL gr_dyn_fi(1,iim+1,jjm+1,klon_glo,aire,airefi_glo)
+    ! Poles are single points on physics grid
+    airefi_glo(1)=sum(aire(1:iim,1))
+    airefi_glo(klon_glo)=sum(aire(1:iim,jjm+1))
+
+    ! Sanity check: do total planet area match between physics and dynamics?
+    total_area_dyn=sum(aire(1:iim,1:jjm+1))
+    total_area_phy=sum(airefi_glo(1:klon_glo))
+    IF (total_area_dyn/=total_area_phy) THEN
+      WRITE (lunout, *) 'inigeomphy: planet total surface discrepancy !!!'
+      WRITE (lunout, *) '     in the dynamics total_area_dyn=', total_area_dyn
+      WRITE (lunout, *) '  but in the physics total_area_phy=', total_area_phy
+      IF (abs(total_area_dyn-total_area_phy)>0.00001*total_area_dyn) THEN
+        ! stop here if the relative difference is more than 0.001%
+        abort_message = 'planet total surface discrepancy'
+        CALL abort_gcm(modname, abort_message, 1)
+      ENDIF
+    ENDIF
+  ELSE ! klon_glo==1, running the 1D model
+    ! just copy over input values
+    latfi_glo(1)=rlatu(1)
+    lonfi_glo(1)=rlonv(1)
+    cufi_glo(1)=cu(1)
+    cvfi_glo(1)=cv(1)
+    airefi_glo(1)=aire(1,1)
+    boundslonfi_glo(1,north_east)=rlonu(1)
+    boundslatfi_glo(1,north_east)=PI/2
+    boundslonfi_glo(1,north_west)=rlonu(2)
+    boundslatfi_glo(1,north_west)=PI/2
+    boundslonfi_glo(1,south_west)=rlonu(2)
+    boundslatfi_glo(1,south_west)=rlatv(1)
+    boundslonfi_glo(1,south_east)=rlonu(1)
+    boundslatfi_glo(1,south_east)=rlatv(1)
+  ENDIF ! of IF (klon_glo>1)
+
+!$OMP PARALLEL 
+  ! Now generate local lon/lat/cu/cv/area/bounds arrays
+  ALLOCATE(latfi(klon_omp),lonfi(klon_omp),cufi(klon_omp),cvfi(klon_omp))
+  ALLOCATE(airefi(klon_omp))
+  ALLOCATE(boundslonfi(klon_omp,4))
+  ALLOCATE(boundslatfi(klon_omp,4))
+  ALLOCATE(ind_cell_glo_fi(klon_omp))
+
+
+  offset = klon_mpi_begin - 1
+  airefi(1:klon_omp) = airefi_glo(offset+klon_omp_begin:offset+klon_omp_end)
+  cufi(1:klon_omp) = cufi_glo(offset+klon_omp_begin:offset+klon_omp_end)
+  cvfi(1:klon_omp) = cvfi_glo(offset+klon_omp_begin:offset+klon_omp_end)
+  lonfi(1:klon_omp) = lonfi_glo(offset+klon_omp_begin:offset+klon_omp_end)
+  latfi(1:klon_omp) = latfi_glo(offset+klon_omp_begin:offset+klon_omp_end)
+  boundslonfi(1:klon_omp,:) = boundslonfi_glo(offset+klon_omp_begin:offset+klon_omp_end,:)
+  boundslatfi(1:klon_omp,:) = boundslatfi_glo(offset+klon_omp_begin:offset+klon_omp_end,:)
+  ind_cell_glo_fi(1:klon_omp)=(/ (i,i=offset+klon_omp_begin,offset+klon_omp_end) /)
+
+  ! copy over local grid longitudes and latitudes
+  CALL init_geometry(klon_omp,lonfi,latfi,boundslonfi,boundslatfi, &
+                     airefi,ind_cell_glo_fi,cufi,cvfi)
+
+  ! copy over preff , ap(), bp(), etc 
+  CALL init_vertical_layers(nlayer,preff,scaleheight, &
+                            ap,bp,aps,bps,presnivs,presinter,pseudoalt)
+
+!$OMP END PARALLEL
+
+
+END SUBROUTINE inigeomphy
+
+END MODULE inigeomphy_mod
+
Index: DZ6/trunk/libf/dynphy_lonlat/phydev/callphysiq_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/dynphy_lonlat/phydev/callphysiq_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,80 +1,0 @@
-!
-! $Id: $
-!
-MODULE callphysiq_mod
-
-IMPLICIT NONE
-
-CONTAINS
-
-SUBROUTINE call_physiq(klon,llm,nqtot,tname,                              &
-                       debut_split,lafin_split,                           &
-                       jD_cur,jH_cur_split,zdt_split,                     &
-                       zplev_omp,zplay_omp,                               &
-                       zpk_omp,zphi_omp,zphis_omp,                        &
-                       presnivs_omp,                                      &
-                       zufi_omp,zvfi_omp,zrfi_omp,ztfi_omp,zqfi_omp,      &
-                       flxwfi_omp,pducov,                                 &
-                       zdufi_omp,zdvfi_omp,zdtfi_omp,zdqfi_omp,zdpsrf_omp)
-
-
-  USE mod_grid_phy_lmdz, ONLY: nbp_lon, nbp_lat
-  USE physiq_mod, ONLY: physiq
-  IMPLICIT NONE
-
-  INTEGER,INTENT(IN) :: klon ! (local) number of atmospheric columns
-  INTEGER,INTENT(IN) :: llm  ! number of atmospheric layers
-  INTEGER,INTENT(IN) :: nqtot ! number of tracers
-  CHARACTER(len=*),INTENT(IN) :: tname(nqtot) ! tracer names
-  LOGICAL,INTENT(IN) :: debut_split ! .true. if very first call to physics
-  LOGICAL,INTENT(IN) :: lafin_split ! .true. if last call to physics
-  REAL,INTENT(IN) :: JD_cur ! Julian day
-  REAL,INTENT(IN) :: JH_cur_split ! Julian hour (fraction of day)
-  REAL,INTENT(IN) :: zdt_split ! time step over which the physics are evaluated
-  REAL,INTENT(IN) :: zplev_omp(klon,llm+1) ! interlayer pressure (Pa)
-  REAL,INTENT(IN) :: zplay_omp(klon,llm) ! mid-layer pressure (Pa)
-  REAL,INTENT(IN) :: zpk_omp(klon,llm) ! Exner function
-  REAL,INTENT(IN) :: zphi_omp(klon,llm) ! geopotential at midlayer
-  REAL,INTENT(IN) :: zphis_omp(klon) ! surface geopotential
-  REAL,INTENT(IN) :: presnivs_omp(llm) ! approximate pressure of atm. layers
-  REAL,INTENT(IN) :: zufi_omp(klon,llm) ! zonal wind (m/s)
-  REAL,INTENT(IN) :: zvfi_omp(klon,llm) ! meridional wind (m/s)
-  REAL,INTENT(IN) :: zrfi_omp(klon,llm) ! relative wind vorticity, in s-1
-  REAL,INTENT(IN) :: ztfi_omp(klon,llm) ! temperature (K)
-  REAL,INTENT(IN) :: zqfi_omp(klon,llm,nqtot) ! tracers (*/kg of air)
-  REAL,INTENT(IN) :: flxwfi_omp(klon,llm) ! Vertical mass flux on lower mesh interfaces (kg/s) 
-  REAL,INTENT(IN) :: pducov(nbp_lon+1,nbp_lat,llm) ! dynamical tendency on ucov
-  ! tendencies (in */s) from the physics:
-  REAL,INTENT(OUT) :: zdufi_omp(klon,llm) ! tendency on zonal winds
-  REAL,INTENT(OUT) :: zdvfi_omp(klon,llm) ! tendency on meridional winds
-  REAL,INTENT(OUT) :: zdtfi_omp(klon,llm) ! tendency on temperature
-  REAL,INTENT(OUT) :: zdqfi_omp(klon,llm,nqtot) ! tendency on tracers
-  REAL,INTENT(OUT) :: zdpsrf_omp(klon) ! tendency on surface pressure
-  
-
-! Call physics package with required inputs/outputs
-  CALL physiq(klon,           &
-              llm,            &
-              debut_split,    &
-              lafin_split,    &
-              zdt_split,      &
-              zplev_omp,      &
-              zplay_omp,      &
-              zphi_omp,       &
-              zphis_omp,      &
-              presnivs_omp,   &
-              zufi_omp,       &
-              zvfi_omp,       &
-              ztfi_omp,       &
-              zqfi_omp,       &
-              flxwfi_omp,     &
-              zdufi_omp,      &
-              zdvfi_omp,      &
-              zdtfi_omp,      &
-              zdqfi_omp,      &
-              zdpsrf_omp)
-
-
-END SUBROUTINE call_physiq
-
-END MODULE callphysiq_mod
Index: /LMDZ6/trunk/libf/dynphy_lonlat/phydev/callphysiq_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/dynphy_lonlat/phydev/callphysiq_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dynphy_lonlat/phydev/callphysiq_mod.f90	(revision 5268)
@@ -0,0 +1,80 @@
+!
+! $Id: $
+!
+MODULE callphysiq_mod
+
+IMPLICIT NONE
+
+CONTAINS
+
+SUBROUTINE call_physiq(klon,llm,nqtot,tname,                              &
+                       debut_split,lafin_split,                           &
+                       jD_cur,jH_cur_split,zdt_split,                     &
+                       zplev_omp,zplay_omp,                               &
+                       zpk_omp,zphi_omp,zphis_omp,                        &
+                       presnivs_omp,                                      &
+                       zufi_omp,zvfi_omp,zrfi_omp,ztfi_omp,zqfi_omp,      &
+                       flxwfi_omp,pducov,                                 &
+                       zdufi_omp,zdvfi_omp,zdtfi_omp,zdqfi_omp,zdpsrf_omp)
+
+
+  USE mod_grid_phy_lmdz, ONLY: nbp_lon, nbp_lat
+  USE physiq_mod, ONLY: physiq
+  IMPLICIT NONE
+
+  INTEGER,INTENT(IN) :: klon ! (local) number of atmospheric columns
+  INTEGER,INTENT(IN) :: llm  ! number of atmospheric layers
+  INTEGER,INTENT(IN) :: nqtot ! number of tracers
+  CHARACTER(len=*),INTENT(IN) :: tname(nqtot) ! tracer names
+  LOGICAL,INTENT(IN) :: debut_split ! .true. if very first call to physics
+  LOGICAL,INTENT(IN) :: lafin_split ! .true. if last call to physics
+  REAL,INTENT(IN) :: JD_cur ! Julian day
+  REAL,INTENT(IN) :: JH_cur_split ! Julian hour (fraction of day)
+  REAL,INTENT(IN) :: zdt_split ! time step over which the physics are evaluated
+  REAL,INTENT(IN) :: zplev_omp(klon,llm+1) ! interlayer pressure (Pa)
+  REAL,INTENT(IN) :: zplay_omp(klon,llm) ! mid-layer pressure (Pa)
+  REAL,INTENT(IN) :: zpk_omp(klon,llm) ! Exner function
+  REAL,INTENT(IN) :: zphi_omp(klon,llm) ! geopotential at midlayer
+  REAL,INTENT(IN) :: zphis_omp(klon) ! surface geopotential
+  REAL,INTENT(IN) :: presnivs_omp(llm) ! approximate pressure of atm. layers
+  REAL,INTENT(IN) :: zufi_omp(klon,llm) ! zonal wind (m/s)
+  REAL,INTENT(IN) :: zvfi_omp(klon,llm) ! meridional wind (m/s)
+  REAL,INTENT(IN) :: zrfi_omp(klon,llm) ! relative wind vorticity, in s-1
+  REAL,INTENT(IN) :: ztfi_omp(klon,llm) ! temperature (K)
+  REAL,INTENT(IN) :: zqfi_omp(klon,llm,nqtot) ! tracers (*/kg of air)
+  REAL,INTENT(IN) :: flxwfi_omp(klon,llm) ! Vertical mass flux on lower mesh interfaces (kg/s) 
+  REAL,INTENT(IN) :: pducov(nbp_lon+1,nbp_lat,llm) ! dynamical tendency on ucov
+  ! tendencies (in */s) from the physics:
+  REAL,INTENT(OUT) :: zdufi_omp(klon,llm) ! tendency on zonal winds
+  REAL,INTENT(OUT) :: zdvfi_omp(klon,llm) ! tendency on meridional winds
+  REAL,INTENT(OUT) :: zdtfi_omp(klon,llm) ! tendency on temperature
+  REAL,INTENT(OUT) :: zdqfi_omp(klon,llm,nqtot) ! tendency on tracers
+  REAL,INTENT(OUT) :: zdpsrf_omp(klon) ! tendency on surface pressure
+  
+
+! Call physics package with required inputs/outputs
+  CALL physiq(klon,           &
+              llm,            &
+              debut_split,    &
+              lafin_split,    &
+              zdt_split,      &
+              zplev_omp,      &
+              zplay_omp,      &
+              zphi_omp,       &
+              zphis_omp,      &
+              presnivs_omp,   &
+              zufi_omp,       &
+              zvfi_omp,       &
+              ztfi_omp,       &
+              zqfi_omp,       &
+              flxwfi_omp,     &
+              zdufi_omp,      &
+              zdvfi_omp,      &
+              zdtfi_omp,      &
+              zdqfi_omp,      &
+              zdpsrf_omp)
+
+
+END SUBROUTINE call_physiq
+
+END MODULE callphysiq_mod
Index: DZ6/trunk/libf/dynphy_lonlat/phydev/iniphysiq_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/dynphy_lonlat/phydev/iniphysiq_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,84 +1,0 @@
-!
-! $Id: iniphysiq.F 1403 2010-07-01 09:02:53Z fairhead $
-!
-MODULE iniphysiq_mod
-
-CONTAINS
-
-SUBROUTINE iniphysiq(iim,jjm,nlayer, &
-                     nbp, communicator, &
-                     punjours, pdayref,ptimestep, &
-                     rlatu,rlatv,rlonu,rlonv,aire,cu,cv, &
-                     prad,pg,pr,pcpp,iflag_phys)
-  USE dimphy, ONLY: init_dimphy
-  USE inigeomphy_mod, ONLY: inigeomphy
-  USE mod_phys_lmdz_para, ONLY: klon_omp ! number of columns (on local omp grid)
-  USE infotrac, ONLY: nqtot, type_trac
-  USE infotrac_phy, ONLY: init_infotrac_phy
-  USE inifis_mod, ONLY: inifis
-  USE phyaqua_mod, ONLY: iniaqua
-  USE nrtype, ONLY: pi
-  IMPLICIT NONE
-  !
-  !=======================================================================
-  !   Initialisation of the physical constants and some positional and 
-  !   geometrical arrays for the physics
-  !=======================================================================
- 
- 
-  include "iniprint.h"
-
-  REAL,INTENT(IN) :: prad ! radius of the planet (m)
-  REAL,INTENT(IN) :: pg ! gravitational acceleration (m/s2)
-  REAL,INTENT(IN) :: pr ! ! reduced gas constant R/mu
-  REAL,INTENT(IN) :: pcpp ! specific heat Cp
-  REAL,INTENT(IN) :: punjours ! length (in s) of a standard day
-  INTEGER, INTENT (IN) :: nlayer ! number of atmospheric layers
-  INTEGER, INTENT (IN) :: iim ! number of atmospheric coulumns along longitudes
-  INTEGER, INTENT (IN) :: jjm  ! number of atompsheric columns along latitudes
-  INTEGER, INTENT(IN) :: nbp ! number of physics columns for this MPI process
-  INTEGER, INTENT(IN) :: communicator ! MPI communicator
-  REAL, INTENT (IN) :: rlatu(jjm+1) ! latitudes of the physics grid
-  REAL, INTENT (IN) :: rlatv(jjm) ! latitude boundaries of the physics grid
-  REAL, INTENT (IN) :: rlonv(iim+1) ! longitudes of the physics grid
-  REAL, INTENT (IN) :: rlonu(iim+1) ! longitude boundaries of the physics grid
-  REAL, INTENT (IN) :: aire(iim+1,jjm+1) ! area of the dynamics grid (m2)
-  REAL, INTENT (IN) :: cu((iim+1)*(jjm+1)) ! cu coeff. (u_covariant = cu * u)
-  REAL, INTENT (IN) :: cv((iim+1)*jjm) ! cv coeff. (v_covariant = cv * v)
-  INTEGER, INTENT (IN) :: pdayref ! reference day of for the simulation
-  REAL,INTENT(IN) :: ptimestep !physics time step (s)
-  INTEGER,INTENT(IN) :: iflag_phys ! type of physics to be called
-
-  INTEGER :: ibegin,iend,offset
-  INTEGER :: i,j,k
-  CHARACTER (LEN=20) :: modname='iniphysiq'
-  CHARACTER (LEN=80) :: abort_message
-
-
-  ! --> initialize physics distribution, global fields and geometry
-  ! (i.e. things in phy_common or dynphy_lonlat)
-  CALL inigeomphy(iim,jjm,nlayer, &
-               nbp, communicator, &
-               rlatu,rlatv, &
-               rlonu,rlonv, &
-               aire,cu,cv)
-
-  ! --> now initialize things specific to the phydev physics package
-
-!$OMP PARALLEL 
-
-  ! Initialize physical constants in physics:
-  CALL inifis(prad,pg,pr,pcpp)
-  
-  ! Initialize tracer names, numbers, etc. for physics
-  CALL init_infotrac_phy(nqtot,type_trac)
-
-  ! Additional initializations for aquaplanets 
-  IF (iflag_phys>=100) THEN
-    CALL iniaqua(klon_omp,iflag_phys)
-  ENDIF
-!$OMP END PARALLEL
-
-END SUBROUTINE iniphysiq
-
-END MODULE iniphysiq_mod
Index: /LMDZ6/trunk/libf/dynphy_lonlat/phydev/iniphysiq_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/dynphy_lonlat/phydev/iniphysiq_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dynphy_lonlat/phydev/iniphysiq_mod.f90	(revision 5268)
@@ -0,0 +1,84 @@
+!
+! $Id: iniphysiq.F 1403 2010-07-01 09:02:53Z fairhead $
+!
+MODULE iniphysiq_mod
+
+CONTAINS
+
+SUBROUTINE iniphysiq(iim,jjm,nlayer, &
+                     nbp, communicator, &
+                     punjours, pdayref,ptimestep, &
+                     rlatu,rlatv,rlonu,rlonv,aire,cu,cv, &
+                     prad,pg,pr,pcpp,iflag_phys)
+  USE dimphy, ONLY: init_dimphy
+  USE inigeomphy_mod, ONLY: inigeomphy
+  USE mod_phys_lmdz_para, ONLY: klon_omp ! number of columns (on local omp grid)
+  USE infotrac, ONLY: nqtot, type_trac
+  USE infotrac_phy, ONLY: init_infotrac_phy
+  USE inifis_mod, ONLY: inifis
+  USE phyaqua_mod, ONLY: iniaqua
+  USE nrtype, ONLY: pi
+  IMPLICIT NONE
+  !
+  !=======================================================================
+  !   Initialisation of the physical constants and some positional and 
+  !   geometrical arrays for the physics
+  !=======================================================================
+ 
+ 
+  include "iniprint.h"
+
+  REAL,INTENT(IN) :: prad ! radius of the planet (m)
+  REAL,INTENT(IN) :: pg ! gravitational acceleration (m/s2)
+  REAL,INTENT(IN) :: pr ! ! reduced gas constant R/mu
+  REAL,INTENT(IN) :: pcpp ! specific heat Cp
+  REAL,INTENT(IN) :: punjours ! length (in s) of a standard day
+  INTEGER, INTENT (IN) :: nlayer ! number of atmospheric layers
+  INTEGER, INTENT (IN) :: iim ! number of atmospheric coulumns along longitudes
+  INTEGER, INTENT (IN) :: jjm  ! number of atompsheric columns along latitudes
+  INTEGER, INTENT(IN) :: nbp ! number of physics columns for this MPI process
+  INTEGER, INTENT(IN) :: communicator ! MPI communicator
+  REAL, INTENT (IN) :: rlatu(jjm+1) ! latitudes of the physics grid
+  REAL, INTENT (IN) :: rlatv(jjm) ! latitude boundaries of the physics grid
+  REAL, INTENT (IN) :: rlonv(iim+1) ! longitudes of the physics grid
+  REAL, INTENT (IN) :: rlonu(iim+1) ! longitude boundaries of the physics grid
+  REAL, INTENT (IN) :: aire(iim+1,jjm+1) ! area of the dynamics grid (m2)
+  REAL, INTENT (IN) :: cu((iim+1)*(jjm+1)) ! cu coeff. (u_covariant = cu * u)
+  REAL, INTENT (IN) :: cv((iim+1)*jjm) ! cv coeff. (v_covariant = cv * v)
+  INTEGER, INTENT (IN) :: pdayref ! reference day of for the simulation
+  REAL,INTENT(IN) :: ptimestep !physics time step (s)
+  INTEGER,INTENT(IN) :: iflag_phys ! type of physics to be called
+
+  INTEGER :: ibegin,iend,offset
+  INTEGER :: i,j,k
+  CHARACTER (LEN=20) :: modname='iniphysiq'
+  CHARACTER (LEN=80) :: abort_message
+
+
+  ! --> initialize physics distribution, global fields and geometry
+  ! (i.e. things in phy_common or dynphy_lonlat)
+  CALL inigeomphy(iim,jjm,nlayer, &
+               nbp, communicator, &
+               rlatu,rlatv, &
+               rlonu,rlonv, &
+               aire,cu,cv)
+
+  ! --> now initialize things specific to the phydev physics package
+
+!$OMP PARALLEL 
+
+  ! Initialize physical constants in physics:
+  CALL inifis(prad,pg,pr,pcpp)
+  
+  ! Initialize tracer names, numbers, etc. for physics
+  CALL init_infotrac_phy(nqtot,type_trac)
+
+  ! Additional initializations for aquaplanets 
+  IF (iflag_phys>=100) THEN
+    CALL iniaqua(klon_omp,iflag_phys)
+  ENDIF
+!$OMP END PARALLEL
+
+END SUBROUTINE iniphysiq
+
+END MODULE iniphysiq_mod
Index: DZ6/trunk/libf/dynphy_lonlat/phylmd/callphysiq_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/dynphy_lonlat/phylmd/callphysiq_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,109 +1,0 @@
-!
-! $Id: $
-!
-MODULE callphysiq_mod
-
-IMPLICIT NONE
-
-CONTAINS
-
-SUBROUTINE call_physiq(klon,llm,nqtot,tname,                              &
-                       debut_split,lafin_split,                           &
-                       jD_cur,jH_cur_split,zdt_split,                     &
-                       zplev_omp,zplay_omp,                               &
-                       zpk_omp,zphi_omp,zphis_omp,                        &
-                       presnivs_omp,                                      &
-                       zufi_omp,zvfi_omp,zrfi_omp,ztfi_omp,zqfi_omp,      &
-                       flxwfi_omp,pducov,                                 &
-                       zdufi_omp,zdvfi_omp,zdtfi_omp,zdqfi_omp,zdpsrf_omp)
-
-
-  USE mod_grid_phy_lmdz, ONLY: nbp_lon, nbp_lat
-  USE control_mod, ONLY: planet_type, ok_dyn_xios
-  USE physiq_mod, ONLY: physiq
-  USE lmdz_xios, ONLY : xios_set_current_context, xios_get_current_context, xios_context
-  IMPLICIT NONE
-
-  INTEGER,INTENT(IN) :: klon ! (local) number of atmospheric columns
-  INTEGER,INTENT(IN) :: llm  ! number of atmospheric layers
-  INTEGER,INTENT(IN) :: nqtot ! number of tracers
-  CHARACTER(len=*),INTENT(IN) :: tname(nqtot) ! tracer names
-  LOGICAL,INTENT(IN) :: debut_split ! .true. if very first call to physics
-  LOGICAL,INTENT(IN) :: lafin_split ! .true. if last call to physics
-  REAL,INTENT(IN) :: JD_cur ! Julian day
-  REAL,INTENT(IN) :: JH_cur_split ! Julian hour (fraction of day)
-  REAL,INTENT(IN) :: zdt_split ! time step over which the physics are evaluated
-  REAL,INTENT(IN) :: zplev_omp(klon,llm+1) ! interlayer pressure (Pa)
-  REAL,INTENT(IN) :: zplay_omp(klon,llm) ! mid-layer pressure (Pa)
-  REAL,INTENT(IN) :: zpk_omp(klon,llm) ! Exner function
-  REAL,INTENT(IN) :: zphi_omp(klon,llm) ! geopotential at midlayer
-  REAL,INTENT(IN) :: zphis_omp(klon) ! surface geopotential
-  REAL,INTENT(IN) :: presnivs_omp(llm) ! approximate pressure of atm. layers
-  REAL,INTENT(IN) :: zufi_omp(klon,llm) ! zonal wind (m/s)
-  REAL,INTENT(IN) :: zvfi_omp(klon,llm) ! meridional wind (m/s)
-  REAL,INTENT(IN) :: zrfi_omp(klon,llm) ! relative wind vorticity, in s-1
-  REAL,INTENT(IN) :: ztfi_omp(klon,llm) ! temperature (K)
-  REAL,INTENT(IN) :: zqfi_omp(klon,llm,nqtot) ! tracers (*/kg of air)
-  REAL,INTENT(IN) :: flxwfi_omp(klon,llm) ! Vertical mass flux on lower mesh interfaces (kg/s) 
-  REAL,INTENT(IN) :: pducov(nbp_lon+1,nbp_lat,llm) ! dynamical tendency on ucov
-  ! tendencies (in */s) from the physics:
-  REAL,INTENT(OUT) :: zdufi_omp(klon,llm) ! tendency on zonal winds
-  REAL,INTENT(OUT) :: zdvfi_omp(klon,llm) ! tendency on meridional winds
-  REAL,INTENT(OUT) :: zdtfi_omp(klon,llm) ! tendency on temperature
-  REAL,INTENT(OUT) :: zdqfi_omp(klon,llm,nqtot) ! tendency on tracers
-  REAL,INTENT(OUT) :: zdpsrf_omp(klon) ! tendency on surface pressure
-  TYPE(xios_context) :: dyn3d_ctx_handle
-
-  ! Local variables
-  CHARACTER(len=11) :: modname="call_physiq"
-  LOGICAL,SAVE :: firstcall=.true.
-!$OMP THREADPRIVATE(firstcall)
-
-! Sanity check on physics package type
-  IF (firstcall) THEN
-    IF (planet_type.ne."earth") THEN
-      CALL abort_gcm(modname,"wrong planet_type for this physics package",1)
-    ENDIF
-    firstcall=.false.
-  ENDIF
-
-  !$OMP MASTER
-  if (ok_dyn_xios) then
-     CALL xios_get_current_context(dyn3d_ctx_handle)
-  endif
-  !$OMP END MASTER
-
-! Call physics package with required inputs/outputs
-  CALL physiq(klon,           &
-              llm,            &
-              debut_split,    &
-              lafin_split,    &
-              zdt_split,      &
-              zplev_omp,      &
-              zplay_omp,      &
-              zphi_omp,       &
-              zphis_omp,      &
-              presnivs_omp,   &
-              zufi_omp,       &
-              zvfi_omp,       &
-              zrfi_omp,       &
-              ztfi_omp,       &
-              zqfi_omp,       &
-              flxwfi_omp,     &
-              zdufi_omp,      &
-              zdvfi_omp,      &
-              zdtfi_omp,      &
-              zdqfi_omp,      &
-              zdpsrf_omp)
-
-! switching back to LMDZDYN context
-!$OMP MASTER
-  if (ok_dyn_xios) then
-     CALL xios_set_current_context(dyn3d_ctx_handle)
-  endif
-!$OMP END MASTER
-
-
-END SUBROUTINE call_physiq
-
-END MODULE callphysiq_mod
Index: /LMDZ6/trunk/libf/dynphy_lonlat/phylmd/callphysiq_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/dynphy_lonlat/phylmd/callphysiq_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dynphy_lonlat/phylmd/callphysiq_mod.f90	(revision 5268)
@@ -0,0 +1,109 @@
+!
+! $Id: $
+!
+MODULE callphysiq_mod
+
+IMPLICIT NONE
+
+CONTAINS
+
+SUBROUTINE call_physiq(klon,llm,nqtot,tname,                              &
+                       debut_split,lafin_split,                           &
+                       jD_cur,jH_cur_split,zdt_split,                     &
+                       zplev_omp,zplay_omp,                               &
+                       zpk_omp,zphi_omp,zphis_omp,                        &
+                       presnivs_omp,                                      &
+                       zufi_omp,zvfi_omp,zrfi_omp,ztfi_omp,zqfi_omp,      &
+                       flxwfi_omp,pducov,                                 &
+                       zdufi_omp,zdvfi_omp,zdtfi_omp,zdqfi_omp,zdpsrf_omp)
+
+
+  USE mod_grid_phy_lmdz, ONLY: nbp_lon, nbp_lat
+  USE control_mod, ONLY: planet_type, ok_dyn_xios
+  USE physiq_mod, ONLY: physiq
+  USE lmdz_xios, ONLY : xios_set_current_context, xios_get_current_context, xios_context
+  IMPLICIT NONE
+
+  INTEGER,INTENT(IN) :: klon ! (local) number of atmospheric columns
+  INTEGER,INTENT(IN) :: llm  ! number of atmospheric layers
+  INTEGER,INTENT(IN) :: nqtot ! number of tracers
+  CHARACTER(len=*),INTENT(IN) :: tname(nqtot) ! tracer names
+  LOGICAL,INTENT(IN) :: debut_split ! .true. if very first call to physics
+  LOGICAL,INTENT(IN) :: lafin_split ! .true. if last call to physics
+  REAL,INTENT(IN) :: JD_cur ! Julian day
+  REAL,INTENT(IN) :: JH_cur_split ! Julian hour (fraction of day)
+  REAL,INTENT(IN) :: zdt_split ! time step over which the physics are evaluated
+  REAL,INTENT(IN) :: zplev_omp(klon,llm+1) ! interlayer pressure (Pa)
+  REAL,INTENT(IN) :: zplay_omp(klon,llm) ! mid-layer pressure (Pa)
+  REAL,INTENT(IN) :: zpk_omp(klon,llm) ! Exner function
+  REAL,INTENT(IN) :: zphi_omp(klon,llm) ! geopotential at midlayer
+  REAL,INTENT(IN) :: zphis_omp(klon) ! surface geopotential
+  REAL,INTENT(IN) :: presnivs_omp(llm) ! approximate pressure of atm. layers
+  REAL,INTENT(IN) :: zufi_omp(klon,llm) ! zonal wind (m/s)
+  REAL,INTENT(IN) :: zvfi_omp(klon,llm) ! meridional wind (m/s)
+  REAL,INTENT(IN) :: zrfi_omp(klon,llm) ! relative wind vorticity, in s-1
+  REAL,INTENT(IN) :: ztfi_omp(klon,llm) ! temperature (K)
+  REAL,INTENT(IN) :: zqfi_omp(klon,llm,nqtot) ! tracers (*/kg of air)
+  REAL,INTENT(IN) :: flxwfi_omp(klon,llm) ! Vertical mass flux on lower mesh interfaces (kg/s) 
+  REAL,INTENT(IN) :: pducov(nbp_lon+1,nbp_lat,llm) ! dynamical tendency on ucov
+  ! tendencies (in */s) from the physics:
+  REAL,INTENT(OUT) :: zdufi_omp(klon,llm) ! tendency on zonal winds
+  REAL,INTENT(OUT) :: zdvfi_omp(klon,llm) ! tendency on meridional winds
+  REAL,INTENT(OUT) :: zdtfi_omp(klon,llm) ! tendency on temperature
+  REAL,INTENT(OUT) :: zdqfi_omp(klon,llm,nqtot) ! tendency on tracers
+  REAL,INTENT(OUT) :: zdpsrf_omp(klon) ! tendency on surface pressure
+  TYPE(xios_context) :: dyn3d_ctx_handle
+
+  ! Local variables
+  CHARACTER(len=11) :: modname="call_physiq"
+  LOGICAL,SAVE :: firstcall=.true.
+!$OMP THREADPRIVATE(firstcall)
+
+! Sanity check on physics package type
+  IF (firstcall) THEN
+    IF (planet_type.ne."earth") THEN
+      CALL abort_gcm(modname,"wrong planet_type for this physics package",1)
+    ENDIF
+    firstcall=.false.
+  ENDIF
+
+  !$OMP MASTER
+  if (ok_dyn_xios) then
+     CALL xios_get_current_context(dyn3d_ctx_handle)
+  endif
+  !$OMP END MASTER
+
+! Call physics package with required inputs/outputs
+  CALL physiq(klon,           &
+              llm,            &
+              debut_split,    &
+              lafin_split,    &
+              zdt_split,      &
+              zplev_omp,      &
+              zplay_omp,      &
+              zphi_omp,       &
+              zphis_omp,      &
+              presnivs_omp,   &
+              zufi_omp,       &
+              zvfi_omp,       &
+              zrfi_omp,       &
+              ztfi_omp,       &
+              zqfi_omp,       &
+              flxwfi_omp,     &
+              zdufi_omp,      &
+              zdvfi_omp,      &
+              zdtfi_omp,      &
+              zdqfi_omp,      &
+              zdpsrf_omp)
+
+! switching back to LMDZDYN context
+!$OMP MASTER
+  if (ok_dyn_xios) then
+     CALL xios_set_current_context(dyn3d_ctx_handle)
+  endif
+!$OMP END MASTER
+
+
+END SUBROUTINE call_physiq
+
+END MODULE callphysiq_mod
Index: DZ6/trunk/libf/dynphy_lonlat/phylmd/etat0phys_netcdf.F90
===================================================================
--- /LMDZ6/trunk/libf/dynphy_lonlat/phylmd/etat0phys_netcdf.F90	(revision 5267)
+++ 	(revision )
@@ -1,576 +1,0 @@
-!
-! $Id$
-!
-MODULE etat0phys
-!
-!*******************************************************************************
-! Purpose: Create physical initial state using atmospheric fields from a
-!          database of atmospheric to initialize the model.
-!-------------------------------------------------------------------------------
-! Comments:
-!
-!    *  This module is designed to work for Earth (and with ioipsl)
-!
-!    *  etat0phys_netcdf routine can access to NetCDF data through subroutines:
-!         "start_init_phys" for variables contained in file "ECPHY.nc":
-!            'ST'     : Surface temperature
-!            'CDSW'   : Soil moisture
-!         "start_init_orog" for variables contained in file "Relief.nc":
-!            'RELIEF' : High resolution orography 
-!
-!    * The land mask and corresponding weights can be:
-!      1) computed using the ocean mask from the ocean model (to ensure ocean
-!         fractions are the same for atmosphere and ocean) for coupled runs.
-!         File name: "o2a.nc"  ;  variable name: "OceMask"
-!      2) computed from topography file "Relief.nc" for forced runs.
-!
-!    * Allowed values for read_climoz flag are 0, 1 and 2:
-!      0: do not read an ozone climatology
-!      1: read a single ozone climatology that will be used day and night
-!      2: read two ozone climatologies, the average day and night climatology
-!         and the daylight climatology
-!-------------------------------------------------------------------------------
-!    * There is a big mess with the longitude size. Should it be iml or iml+1 ?
-!  I have chosen to use the iml+1 as an argument to this routine and we declare
-!  internaly smaller fields when needed. This needs to be cleared once and for
-!  all in LMDZ. A convention is required.
-!-------------------------------------------------------------------------------
-
-  USE ioipsl,             ONLY: flininfo, flinopen, flinget, flinclo
-  USE assert_eq_m,        ONLY: assert_eq
-  USE dimphy,             ONLY: klon
-  USE conf_dat_m,         ONLY: conf_dat2d
-  USE phys_state_var_mod, ONLY: zmea, zstd, zsig, zgam, zthe, zpic, zval, z0m, &
-          solsw, solswfdiff, radsol, t_ancien, wake_deltat, wake_s,  rain_fall, qsol, z0h, &
-          sollw,sollwdown, rugoro, q_ancien, wake_deltaq, wake_pe, snow_fall, ratqs,w01, &
-    sig1, ftsol, clwcon, fm_therm, wake_Cstar,  pctsrf,  entr_therm,radpas, f0,&
-    zmax0,fevap, rnebcon,falb_dir, falb_dif, wake_fip,    agesno,  detr_therm, pbl_tke,  &
-    phys_state_var_init, ql_ancien, qs_ancien, prlw_ancien, prsw_ancien, &
-    prw_ancien, u10m,v10m, treedrg, u_ancien, v_ancien, wake_delta_pbl_TKE, wake_dens, &
-    ale_bl, ale_bl_trig, alp_bl, &
-    ale_wake, ale_bl_stat, AWAKE_S, &
-    cf_ancien, rvc_ancien
-
-  USE comconst_mod, ONLY: pi, dtvr
-
-  PRIVATE
-  PUBLIC :: etat0phys_netcdf
-
-  include "iniprint.h"
-  include "dimensions.h"
-  include "paramet.h"
-  include "comgeom2.h"
-  include "dimsoil.h"
-  include "clesphys.h"
-  REAL, SAVE :: deg2rad
-  REAL, SAVE, ALLOCATABLE :: tsol(:)
-  INTEGER,            SAVE      :: iml_phys, jml_phys, llm_phys, ttm_phys, fid_phys
-  REAL, ALLOCATABLE,  SAVE      :: lon_phys(:,:), lat_phys(:,:), levphys_ini(:)
-  CHARACTER(LEN=256), PARAMETER :: oroparam="oro_params.nc"
-  CHARACTER(LEN=256), PARAMETER :: orofname="Relief.nc", orogvar="RELIEF"
-  CHARACTER(LEN=256), PARAMETER :: phyfname="ECPHY.nc",  psrfvar="SP"
-  CHARACTER(LEN=256), PARAMETER :: qsolvar="CDSW",       tsrfvar="ST"
-
-
-CONTAINS
-
-
-!-------------------------------------------------------------------------------
-!
-SUBROUTINE etat0phys_netcdf(masque, phis)
-!
-!-------------------------------------------------------------------------------
-! Purpose: Creates initial states
-!-------------------------------------------------------------------------------
-! Notes:  1) This routine is designed to work for Earth
-!         2) If masque(:,:)/=-99999., masque and phis are already known.
-!         Otherwise: compute it.
-!-------------------------------------------------------------------------------
-  USE control_mod
-  USE fonte_neige_mod
-  USE pbl_surface_mod
-  USE regr_horiz_time_climoz_m, ONLY: regr_horiz_time_climoz
-  USE indice_sol_mod
-  USE conf_phys_m, ONLY: conf_phys
-  USE init_ssrf_m, ONLY: start_init_subsurf
-  USE phys_state_var_mod, ONLY: beta_aridity, delta_tsurf, awake_dens, cv_gen, &
-       ratqs_inter_
-  !use ioipsl
-  IMPLICIT NONE
-!-------------------------------------------------------------------------------
-! Arguments:
-  REAL,    INTENT(INOUT) :: masque(:,:) !--- Land mask           dim(iip1,jjp1)
-  REAL,    INTENT(INOUT) :: phis  (:,:) !--- Ground geopotential dim(iip1,jjp1)
-!-------------------------------------------------------------------------------
-! Local variables:
-  CHARACTER(LEN=256) :: modname="etat0phys_netcdf", fmt
-  INTEGER            :: i, j, l, ji, iml, jml
-  LOGICAL            :: read_mask
-  REAL               :: phystep, dummy
-  REAL, DIMENSION(SIZE(masque,1),SIZE(masque,2)) :: masque_tmp,phiso
-  REAL, DIMENSION(klon)               :: sn, rugmer, run_off_lic_0, fder
-  REAL, DIMENSION(klon,nbsrf)         :: qsurf, snsrf
-  REAL, DIMENSION(klon,nsoilmx,nbsrf) :: tsoil
-
-!--- Arguments for conf_phys
-  LOGICAL :: ok_journe, ok_mensuel, ok_instan, ok_hf, ok_LES, callstats
-  REAL    :: solarlong0, seuil_inversion, fact_cldcon, facttemps
-  LOGICAL :: ok_newmicro
-  INTEGER :: iflag_radia, iflag_cldcon, iflag_ratqs
-  REAL    :: ratqsbas, ratqshaut, tau_ratqs
-  LOGICAL :: ok_ade, ok_aie, ok_volcan, ok_alw, ok_cdnc, aerosol_couple, chemistry_couple
-  INTEGER :: flag_aerosol
-  INTEGER :: flag_aerosol_strat
-  INTEGER :: flag_volc_surfstrat
-  LOGICAL :: flag_aer_feedback
-  LOGICAL :: flag_bc_internal_mixture
-  REAL    :: bl95_b0, bl95_b1
-  INTEGER :: read_climoz                        !--- Read ozone climatology
-  REAL    :: alp_offset
-  LOGICAL :: filtre_oro=.false.
-
-  INCLUDE "compbl.h"
-  INCLUDE "alpale.h"
-  
-  deg2rad= pi/180.0
-  iml=assert_eq(SIZE(masque,1),SIZE(phis,1),TRIM(modname)//" iml")
-  jml=assert_eq(SIZE(masque,2),SIZE(phis,2),TRIM(modname)//" jml")
-
-! Physics configuration
-!*******************************************************************************
-  CALL conf_phys(  ok_journe, ok_mensuel, ok_instan, ok_hf, ok_LES,     &
-                   callstats,                                           &
-                   solarlong0,seuil_inversion,                          &
-                   fact_cldcon, facttemps,ok_newmicro,iflag_radia,      &
-                   iflag_cldcon,                                        &
-                   ratqsbas,ratqshaut,tau_ratqs,            &
-                   ok_ade, ok_aie, ok_alw, ok_cdnc, ok_volcan, flag_volc_surfstrat,     &
-                   aerosol_couple, chemistry_couple, flag_aerosol, flag_aerosol_strat,  & 
-                   flag_aer_feedback, flag_bc_internal_mixture, bl95_b0, bl95_b1,       &
-                   read_climoz, alp_offset)
-  CALL phys_state_var_init(read_climoz)
-
-!--- Initial atmospheric CO2 conc. from .def file
-  co2_ppm0 = co2_ppm
-
-! Compute ground geopotential, sub-cells quantities and possibly the mask.
-!*******************************************************************************
-  read_mask=ANY(masque/=-99999.); masque_tmp=masque
-  CALL start_init_orog(rlonv, rlatu, phis, masque_tmp)
-
-  CALL getin('filtre_oro',filtre_oro)
-  IF (filtre_oro) CALL filtreoro(size(phis,1),size(phis,2),phis,masque_tmp,rlatu)
-
-  WRITE(fmt,"(i4,'i1)')")iml ; fmt='('//ADJUSTL(fmt)
-  IF(.NOT.read_mask) THEN                       !--- Keep mask form orography
-    masque=masque_tmp
-    IF(prt_level>=1) THEN
-      WRITE(lunout,*)'BUILT MASK :'
-      WRITE(lunout,fmt) NINT(masque)
-    END IF
-    WHERE(   masque(:,:)<EPSFRA) masque(:,:)=0.
-    WHERE(1.-masque(:,:)<EPSFRA) masque(:,:)=1.
-  END IF
-  CALL gr_dyn_fi(1,iml,jml,klon,masque,zmasq) !--- Land mask to physical grid
-
-! Compute tsol and qsol on physical grid, knowing phis on 2D grid.
-!*******************************************************************************
-  CALL start_init_phys(rlonu, rlatv, phis)
-
-! Some initializations.
-!*******************************************************************************
-  sn    (:) = 0.0                               !--- Snow
-  radsol(:) = 0.0                               !--- Net radiation at ground
-  rugmer(:) = 0.001                             !--- Ocean rugosity
-  !--- Ozone (zonal or 3D) interpolation in space and time (if 2nd arg is TRUE)
-  IF(read_climoz>=1) CALL regr_horiz_time_climoz(read_climoz,ok_daily_climoz)
-
-! Sub-surfaces initialization.
-!*******************************************************************************
-  CALL start_init_subsurf(read_mask)
-
-! Write physical initial state
-!*******************************************************************************
-  WRITE(lunout,*)'phystep ',dtvr,iphysiq,nbapp_rad
-  phystep = dtvr * FLOAT(iphysiq)
-  radpas  = NINT (86400./phystep/ FLOAT(nbapp_rad) )
-  WRITE(lunout,*)'phystep =', phystep, radpas
-
-! Init: ftsol, snsrf, qsurf, tsoil, rain_fall, snow_fall, solsw, sollw, z0
-!*******************************************************************************
-  DO i=1,nbsrf; ftsol(:,i) = tsol; END DO
-  DO i=1,nbsrf; snsrf(:,i) = sn;   END DO
-  falb_dir(:, :, is_ter) = 0.08
-  falb_dir(:, :, is_lic) = 0.6
-  falb_dir(:, :, is_oce) = 0.5
-  falb_dir(:, :, is_sic) = 0.6
-
-!ym warning missing init for falb_dif => set to 0
-  falb_dif(:,:,:)=0
-
-  u10m(:,:)=0  
-  v10m(:,:)=0  
-  treedrg(:,:,:)=0
-
-  fevap(:,:) = 0.
-  qsurf = 0.
-  DO i=1,nbsrf; DO j=1,nsoilmx; tsoil(:,j,i) = tsol; END DO; END DO
-  rain_fall  = 0.
-  snow_fall  = 0.
-  solsw      = 165.
-  solswfdiff = 1. 
-  sollw      = -53.
-!ym warning missing init for sollwdown => set to 0
-  sollwdown  = 0.
-  t_ancien   = 273.15
-  q_ancien   = 0.
-  ql_ancien = 0.
-  qs_ancien = 0.
-  prlw_ancien = 0.
-  prsw_ancien = 0.
-  prw_ancien = 0.
-  agesno     = 0.
-  
-  u_ancien = 0.
-  v_ancien = 0.
-  wake_delta_pbl_TKE(:,:,:)=0
-  wake_dens(:)=0
-  awake_dens = 0.
-  cv_gen = 0.
-  ale_bl = 0.
-  ale_bl_trig =0.
-  alp_bl=0.
-  ale_wake=0.
-  ale_bl_stat=0.
-
-  cf_ancien = 0.
-  rvc_ancien = 0.
-  
-  z0m(:,:)=0 ! ym missing 5th subsurface initialization
- 
-  z0m(:,is_oce) = rugmer(:)
-  z0m(:,is_ter) = 0.01 !MAX(1.0e-05,zstd(:)*zsig(:)/2.0)
-  z0m(:,is_lic) = 0.001 !MAX(1.0e-05,zstd(:)*zsig(:)/2.0)
-  z0m(:,is_sic) = 0.001
-  z0h(:,:)=z0m(:,:)
-
-  fder    = 0.0
-  clwcon  = 0.0
-  rnebcon = 0.0
-  ratqs   = 0.0
-  run_off_lic_0 = 0.0 
-  rugoro  = 0.0
-
-! Before phyredem calling, surface modules and values to be saved in startphy.nc
-! are initialized
-!*******************************************************************************
-  dummy            = 1.0
-  pbl_tke(:,:,:)   = 1.e-8 
-  zmax0(:)         = 40.
-  f0(:)            = 1.e-5
-  sig1(:,:)        = 0.
-  w01(:,:)         = 0.
-  wake_deltat(:,:) = 0.
-  wake_deltaq(:,:) = 0.
-  wake_s(:)        = 0.
-  wake_cstar(:)    = 0.
-  wake_fip(:)      = 0.
-  wake_pe          = 0.
-  fm_therm         = 0.
-  entr_therm       = 0.
-  detr_therm       = 0.
-  awake_s = 0.
-
-  CALL fonte_neige_init(run_off_lic_0)
-  CALL pbl_surface_init( fder, snsrf, qsurf, tsoil )
-
-  IF (iflag_pbl>1 .AND. iflag_wake>=1  .AND. iflag_pbl_split >=1) then
-     delta_tsurf = 0.
-     beta_aridity = 0.
-  end IF
-
-  ratqs_inter_ = 0.002
-  CALL phyredem( "startphy.nc" )
-
-!  WRITE(lunout,*)'CCCCCCCCCCCCCCCCCC REACTIVER SORTIE VISU DANS ETAT0'
-!  WRITE(lunout,*)'entree histclo'
-  CALL histclo()
-
-END SUBROUTINE etat0phys_netcdf
-!
-!-------------------------------------------------------------------------------
-
-
-!-------------------------------------------------------------------------------
-!
-SUBROUTINE start_init_orog(lon_in,lat_in,phis,masque)
-!
-!===============================================================================
-! Comment:
-!   This routine launch grid_noro, which computes parameters for SSO scheme as
-!   described in LOTT & MILLER (1997) and LOTT(1999).
-!   In case the file oroparam is present and the key read_orop is activated,
-!   grid_noro is bypassed and sub-cell parameters are read from the file.
-!===============================================================================
-  USE grid_noro_m, ONLY: grid_noro, read_noro
-  USE logic_mod,   ONLY: read_orop
-  IMPLICIT NONE
-!-------------------------------------------------------------------------------
-! Arguments:
-  REAL,    INTENT(IN)    :: lon_in(:), lat_in(:)   ! dim (iml) (jml)
-  REAL,    INTENT(INOUT) :: phis(:,:), masque(:,:) ! dim (iml,jml)
-!-------------------------------------------------------------------------------
-! Local variables:
-  CHARACTER(LEN=256) :: modname
-  INTEGER            :: fid, llm_tmp,ttm_tmp, iml,jml, iml_rel,jml_rel, itau(1)
-  INTEGER            :: ierr
-  REAL               :: lev(1), date, dt
-  REAL, ALLOCATABLE  :: lon_rad(:), lon_ini(:), lon_rel(:,:), relief_hi(:,:)
-  REAL, ALLOCATABLE  :: lat_rad(:), lat_ini(:), lat_rel(:,:), tmp_var  (:,:)
-  REAL, ALLOCATABLE  :: zmea0(:,:), zstd0(:,:), zsig0(:,:)
-  REAL, ALLOCATABLE  :: zgam0(:,:), zthe0(:,:), zpic0(:,:), zval0(:,:)
-!-------------------------------------------------------------------------------
-  modname="start_init_orog"
-  iml=assert_eq(SIZE(lon_in),SIZE(phis,1),SIZE(masque,1),TRIM(modname)//" iml")
-  jml=assert_eq(SIZE(lat_in),SIZE(phis,2),SIZE(masque,2),TRIM(modname)//" jml")
-
-!--- HIGH RESOLUTION OROGRAPHY
-  CALL flininfo(orofname, iml_rel, jml_rel, llm_tmp, ttm_tmp, fid)
-
-  ALLOCATE(lat_rel(iml_rel,jml_rel),lon_rel(iml_rel,jml_rel))
-  CALL flinopen(orofname, .FALSE., iml_rel, jml_rel, llm_tmp, lon_rel, lat_rel,&
-                lev, ttm_tmp, itau, date, dt, fid)
-  ALLOCATE(relief_hi(iml_rel,jml_rel))
-  CALL flinget(fid, orogvar, iml_rel, jml_rel, llm_tmp, ttm_tmp, 1,1, relief_hi)
-  CALL flinclo(fid)
-
-!--- IF ANGLES ARE IN DEGREES, THEY ARE CONVERTED INTO RADIANS
-  ALLOCATE(lon_ini(iml_rel),lat_ini(jml_rel))
-  lon_ini(:)=lon_rel(:,1); IF(MAXVAL(lon_rel)>pi) lon_ini=lon_ini*deg2rad
-  lat_ini(:)=lat_rel(1,:); IF(MAXVAL(lat_rel)>pi) lat_ini=lat_ini*deg2rad
-
-!--- FIELDS ARE PROCESSED TO BE ON STANDARD ANGULAR DOMAINS
-  ALLOCATE(lon_rad(iml_rel),lat_rad(jml_rel))
-  CALL conf_dat2d(orogvar, lon_ini, lat_ini, lon_rad, lat_rad, relief_hi,.FALSE.)
-  DEALLOCATE(lon_ini,lat_ini)
-
-!--- COMPUTING THE REQUIRED FIELDS USING ROUTINE grid_noro
-  WRITE(lunout,*)
-  WRITE(lunout,*)'*** Compute parameters needed for gravity wave drag code ***'
-
-!--- ALLOCATIONS OF SUB-CELL SCALES QUANTITIES
-  ALLOCATE(zmea0(iml,jml),zstd0(iml,jml)) !--- Mean orography and std deviation
-  ALLOCATE(zsig0(iml,jml),zgam0(iml,jml)) !--- Slope and nisotropy
-  zsig0(:,:)=0   !ym uninitialized variable
-  zgam0(:,:)=0   !ym uninitialized variable
-  ALLOCATE(zthe0(iml,jml))                !--- Highest slope orientation
-  zthe0(:,:)=0   !ym uninitialized variable
-  ALLOCATE(zpic0(iml,jml),zval0(iml,jml)) !--- Peaks and valley heights
-
-!--- READ SUB-CELL SCALES PARAMETERS FROM A FILE (AT RIGHT RESOLUTION)
-  OPEN(UNIT=66,FILE=oroparam,STATUS='OLD',IOSTAT=ierr)
-  IF(ierr==0.AND.read_orop) THEN
-    CLOSE(UNIT=66)
-    CALL read_noro(lon_in,lat_in,oroparam,                                     &
-                   phis,zmea0,zstd0,zsig0,zgam0,zthe0,zpic0,zval0,masque)
-  ELSE
-!--- CALL OROGRAPHY MODULE TO COMPUTE FIELDS
-    CALL grid_noro(lon_rad,lat_rad,relief_hi,lon_in,lat_in,                    &
-                   phis,zmea0,zstd0,zsig0,zgam0,zthe0,zpic0,zval0,masque)
-  END IF
-  phis = phis * 9.81
-  phis(iml,:) = phis(1,:)
-  DEALLOCATE(relief_hi,lon_rad,lat_rad)
-
-!--- PUT QUANTITIES TO PHYSICAL GRID
-  CALL gr_dyn_fi(1,iml,jml,klon,zmea0,zmea); DEALLOCATE(zmea0)
-  CALL gr_dyn_fi(1,iml,jml,klon,zstd0,zstd); DEALLOCATE(zstd0)
-  CALL gr_dyn_fi(1,iml,jml,klon,zsig0,zsig); DEALLOCATE(zsig0)
-  CALL gr_dyn_fi(1,iml,jml,klon,zgam0,zgam); DEALLOCATE(zgam0)
-  CALL gr_dyn_fi(1,iml,jml,klon,zthe0,zthe); DEALLOCATE(zthe0)
-  CALL gr_dyn_fi(1,iml,jml,klon,zpic0,zpic); DEALLOCATE(zpic0)
-  CALL gr_dyn_fi(1,iml,jml,klon,zval0,zval); DEALLOCATE(zval0)
-
-
-END SUBROUTINE start_init_orog
-!
-!-------------------------------------------------------------------------------
-
-
-!-------------------------------------------------------------------------------
-!
-SUBROUTINE start_init_phys(lon_in,lat_in,phis)
-!
-!===============================================================================
-! Purpose:   Compute tsol and qsol, knowing phis.
-!===============================================================================
-  IMPLICIT NONE
-!-------------------------------------------------------------------------------
-! Arguments:
-  REAL,    INTENT(IN) :: lon_in(:),  lat_in(:)       ! dim (iml) (jml2)
-  REAL,    INTENT(IN) :: phis(:,:)                   ! dim (iml,jml)
-!-------------------------------------------------------------------------------
-! Local variables:
-  CHARACTER(LEN=256) :: modname
-  REAL               :: date, dt
-  INTEGER            :: iml, jml, jml2, itau(1)
-  REAL, ALLOCATABLE  :: lon_rad(:), lon_ini(:), var_ana(:,:)
-  REAL, ALLOCATABLE  :: lat_rad(:), lat_ini(:)
-  REAL, ALLOCATABLE  :: ts(:,:), qs(:,:)
-!-------------------------------------------------------------------------------
-  modname="start_init_phys"
-  iml=assert_eq(SIZE(lon_in),SIZE(phis,1),TRIM(modname)//" iml")
-  jml=SIZE(phis,2); jml2=SIZE(lat_in)
-
-  WRITE(lunout,*)'Opening the surface analysis'
-  CALL flininfo(phyfname, iml_phys, jml_phys, llm_phys, ttm_phys, fid_phys)
-  WRITE(lunout,*) 'Values read: ',  iml_phys, jml_phys, llm_phys, ttm_phys
-
-  ALLOCATE(lat_phys(iml_phys,jml_phys),lon_phys(iml_phys,jml_phys))
-  ALLOCATE(levphys_ini(llm_phys))
-  CALL flinopen(phyfname, .FALSE., iml_phys, jml_phys, llm_phys,              &
-                lon_phys,lat_phys,levphys_ini,ttm_phys,itau,date,dt,fid_phys)
-
-!--- IF ANGLES ARE IN DEGREES, THEY ARE CONVERTED INTO RADIANS
-  ALLOCATE(lon_ini(iml_phys),lat_ini(jml_phys))
-  lon_ini(:)=lon_phys(:,1); IF(MAXVAL(lon_phys)>pi) lon_ini=lon_ini*deg2rad
-  lat_ini(:)=lat_phys(1,:); IF(MAXVAL(lat_phys)>pi) lat_ini=lat_ini*deg2rad
-
-  ALLOCATE(var_ana(iml_phys,jml_phys),lon_rad(iml_phys),lat_rad(jml_phys))
-  CALL get_var_phys(tsrfvar,ts)                   !--- SURFACE TEMPERATURE
-  CALL get_var_phys(qsolvar,qs)                   !--- SOIL MOISTURE
-  CALL flinclo(fid_phys)
-  DEALLOCATE(var_ana,lon_rad,lat_rad,lon_ini,lat_ini)
-
-!--- TSOL AND QSOL ON PHYSICAL GRID
-  ALLOCATE(tsol(klon))
-  CALL gr_dyn_fi(1,iml,jml,klon,ts,tsol)
-  CALL gr_dyn_fi(1,iml,jml,klon,qs,qsol)
-  DEALLOCATE(ts,qs)
-
-CONTAINS
-
-!-------------------------------------------------------------------------------
-!
-SUBROUTINE get_var_phys(title,field)
-!
-!-------------------------------------------------------------------------------
-  IMPLICIT NONE
-!-------------------------------------------------------------------------------
-! Arguments:
-  CHARACTER(LEN=*),  INTENT(IN)    :: title
-  REAL, ALLOCATABLE, INTENT(INOUT) :: field(:,:)
-!-------------------------------------------------------------------------------
-! Local variables:
-  INTEGER :: tllm
-!-------------------------------------------------------------------------------
-  SELECT CASE(title)
-    CASE(psrfvar);         tllm=0
-    CASE(tsrfvar,qsolvar); tllm=llm_phys
-  END SELECT
-  IF(ALLOCATED(field)) RETURN
-  ALLOCATE(field(iml,jml)); field(:,:)=0.
-  CALL flinget(fid_phys,title,iml_phys,jml_phys,tllm,ttm_phys,1,1,var_ana)
-  CALL conf_dat2d(title, lon_ini, lat_ini, lon_rad, lat_rad, var_ana, .TRUE.)
-  CALL interp_startvar(title, .TRUE., lon_rad, lat_rad, var_ana,               &
-                                      lon_in,  lat_in,  field)
-
-END SUBROUTINE get_var_phys
-!
-!-------------------------------------------------------------------------------
-!
-END SUBROUTINE start_init_phys
-!
-!-------------------------------------------------------------------------------
-
-
-!-------------------------------------------------------------------------------
-!
-SUBROUTINE interp_startvar(nam,ibeg,lon,lat,vari,lon2,lat2,varo)
-!
-!-------------------------------------------------------------------------------
-  USE inter_barxy_m, ONLY: inter_barxy
-  IMPLICIT NONE
-!-------------------------------------------------------------------------------
-! Arguments:
-  CHARACTER(LEN=*), INTENT(IN)  :: nam
-  LOGICAL,          INTENT(IN)  :: ibeg
-  REAL,             INTENT(IN)  :: lon(:), lat(:)   ! dim (ii) (jj)
-  REAL,             INTENT(IN)  :: vari(:,:)        ! dim (ii,jj)
-  REAL,             INTENT(IN)  :: lon2(:), lat2(:) ! dim (i1) (j2)
-  REAL,             INTENT(OUT) :: varo(:,:)        ! dim (i1) (j1)
-!-------------------------------------------------------------------------------
-! Local variables:
-  CHARACTER(LEN=256) :: modname
-  INTEGER            :: ii, jj, i1, j1, j2
-  REAL, ALLOCATABLE  :: vtmp(:,:)
-!-------------------------------------------------------------------------------
-  modname="interp_startvar"
-  ii=assert_eq(SIZE(lon), SIZE(vari,1),TRIM(modname)//" ii")
-  jj=assert_eq(SIZE(lat), SIZE(vari,2),TRIM(modname)//" jj")
-  i1=assert_eq(SIZE(lon2),SIZE(varo,1),TRIM(modname)//" i1")
-  j1=SIZE(varo,2); j2=SIZE(lat2)
-  ALLOCATE(vtmp(i1-1,j1))
-  IF(ibeg.AND.prt_level>1) THEN
-    WRITE(lunout,*)"--------------------------------------------------------"
-    WRITE(lunout,*)"$$$ Interpolation barycentrique pour "//TRIM(nam)//" $$$"
-    WRITE(lunout,*)"--------------------------------------------------------"
-  END IF
-  CALL inter_barxy(lon, lat(:jj-1), vari, lon2(:i1-1), lat2, vtmp)
-  CALL gr_int_dyn(vtmp, varo, i1-1, j1)
-
-END SUBROUTINE interp_startvar
-!
-!-------------------------------------------------------------------------------
-!
-!*******************************************************************************
-
-SUBROUTINE filtreoro(imp1,jmp1,phis,masque,rlatu)
-
-IMPLICIT NONE
-
-  INTEGER imp1,jmp1
-  REAL, DIMENSION(imp1,jmp1) :: phis,masque
-  REAL, DIMENSION(jmp1) :: rlatu
-  REAL, DIMENSION(imp1) :: wwf
-  REAL, DIMENSION(imp1,jmp1) :: phiso
-  INTEGER :: ifiltre,ifi,ii,i,j
-  REAL :: coslat0,ssz
-
-  coslat0=0.5
-  phiso=phis
-  do j=2,jmp1-1
-     print*,'avant if ',cos(rlatu(j)),coslat0
-     if (cos(rlatu(j))<coslat0) then
-         ! nb de pts affectes par le filtrage de part et d'autre du pt
-         ifiltre=(coslat0/cos(rlatu(j))-1.)/2.
-         wwf=0.
-         do i=1,ifiltre
-            wwf(i)=1.
-         enddo
-         wwf(ifiltre+1)=(coslat0/cos(rlatu(j))-1.)/2.-ifiltre
-         do i=1,imp1-1
-            if (masque(i,j)>0.9) then
-               ssz=phis(i,j)
-               do ifi=1,ifiltre+1
-                  ii=i+ifi
-                  if (ii>imp1-1) ii=ii-imp1+1
-                  ssz=ssz+wwf(ifi)*phis(ii,j)
-                  ii=i-ifi
-                  if (ii<1) ii=ii+imp1-1
-                  ssz=ssz+wwf(ifi)*phis(ii,j)
-               enddo
-               phis(i,j)=ssz*cos(rlatu(j))/coslat0
-            endif
-         enddo
-         print*,'j=',j,coslat0/cos(rlatu(j)), (1.+2.*sum(wwf))*cos(rlatu(j))/coslat0
-     endif
-  enddo
-  call dump2d(imp1,jmp1,phis,'phis ')
-  call dump2d(imp1,jmp1,masque,'masque ')
-  call dump2d(imp1,jmp1,phis-phiso,'dphis ')
-
-END SUBROUTINE filtreoro
-
-
-END MODULE etat0phys
Index: /LMDZ6/trunk/libf/dynphy_lonlat/phylmd/etat0phys_netcdf.f90
===================================================================
--- /LMDZ6/trunk/libf/dynphy_lonlat/phylmd/etat0phys_netcdf.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dynphy_lonlat/phylmd/etat0phys_netcdf.f90	(revision 5268)
@@ -0,0 +1,576 @@
+!
+! $Id$
+!
+MODULE etat0phys
+!
+!*******************************************************************************
+! Purpose: Create physical initial state using atmospheric fields from a
+!          database of atmospheric to initialize the model.
+!-------------------------------------------------------------------------------
+! Comments:
+!
+!    *  This module is designed to work for Earth (and with ioipsl)
+!
+!    *  etat0phys_netcdf routine can access to NetCDF data through subroutines:
+!         "start_init_phys" for variables contained in file "ECPHY.nc":
+!            'ST'     : Surface temperature
+!            'CDSW'   : Soil moisture
+!         "start_init_orog" for variables contained in file "Relief.nc":
+!            'RELIEF' : High resolution orography 
+!
+!    * The land mask and corresponding weights can be:
+!      1) computed using the ocean mask from the ocean model (to ensure ocean
+!         fractions are the same for atmosphere and ocean) for coupled runs.
+!         File name: "o2a.nc"  ;  variable name: "OceMask"
+!      2) computed from topography file "Relief.nc" for forced runs.
+!
+!    * Allowed values for read_climoz flag are 0, 1 and 2:
+!      0: do not read an ozone climatology
+!      1: read a single ozone climatology that will be used day and night
+!      2: read two ozone climatologies, the average day and night climatology
+!         and the daylight climatology
+!-------------------------------------------------------------------------------
+!    * There is a big mess with the longitude size. Should it be iml or iml+1 ?
+!  I have chosen to use the iml+1 as an argument to this routine and we declare
+!  internaly smaller fields when needed. This needs to be cleared once and for
+!  all in LMDZ. A convention is required.
+!-------------------------------------------------------------------------------
+
+  USE ioipsl,             ONLY: flininfo, flinopen, flinget, flinclo
+  USE assert_eq_m,        ONLY: assert_eq
+  USE dimphy,             ONLY: klon
+  USE conf_dat_m,         ONLY: conf_dat2d
+  USE phys_state_var_mod, ONLY: zmea, zstd, zsig, zgam, zthe, zpic, zval, z0m, &
+          solsw, solswfdiff, radsol, t_ancien, wake_deltat, wake_s,  rain_fall, qsol, z0h, &
+          sollw,sollwdown, rugoro, q_ancien, wake_deltaq, wake_pe, snow_fall, ratqs,w01, &
+    sig1, ftsol, clwcon, fm_therm, wake_Cstar,  pctsrf,  entr_therm,radpas, f0,&
+    zmax0,fevap, rnebcon,falb_dir, falb_dif, wake_fip,    agesno,  detr_therm, pbl_tke,  &
+    phys_state_var_init, ql_ancien, qs_ancien, prlw_ancien, prsw_ancien, &
+    prw_ancien, u10m,v10m, treedrg, u_ancien, v_ancien, wake_delta_pbl_TKE, wake_dens, &
+    ale_bl, ale_bl_trig, alp_bl, &
+    ale_wake, ale_bl_stat, AWAKE_S, &
+    cf_ancien, rvc_ancien
+
+  USE comconst_mod, ONLY: pi, dtvr
+
+  PRIVATE
+  PUBLIC :: etat0phys_netcdf
+
+  include "iniprint.h"
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom2.h"
+  include "dimsoil.h"
+  include "clesphys.h"
+  REAL, SAVE :: deg2rad
+  REAL, SAVE, ALLOCATABLE :: tsol(:)
+  INTEGER,            SAVE      :: iml_phys, jml_phys, llm_phys, ttm_phys, fid_phys
+  REAL, ALLOCATABLE,  SAVE      :: lon_phys(:,:), lat_phys(:,:), levphys_ini(:)
+  CHARACTER(LEN=256), PARAMETER :: oroparam="oro_params.nc"
+  CHARACTER(LEN=256), PARAMETER :: orofname="Relief.nc", orogvar="RELIEF"
+  CHARACTER(LEN=256), PARAMETER :: phyfname="ECPHY.nc",  psrfvar="SP"
+  CHARACTER(LEN=256), PARAMETER :: qsolvar="CDSW",       tsrfvar="ST"
+
+
+CONTAINS
+
+
+!-------------------------------------------------------------------------------
+!
+SUBROUTINE etat0phys_netcdf(masque, phis)
+!
+!-------------------------------------------------------------------------------
+! Purpose: Creates initial states
+!-------------------------------------------------------------------------------
+! Notes:  1) This routine is designed to work for Earth
+!         2) If masque(:,:)/=-99999., masque and phis are already known.
+!         Otherwise: compute it.
+!-------------------------------------------------------------------------------
+  USE control_mod
+  USE fonte_neige_mod
+  USE pbl_surface_mod
+  USE regr_horiz_time_climoz_m, ONLY: regr_horiz_time_climoz
+  USE indice_sol_mod
+  USE conf_phys_m, ONLY: conf_phys
+  USE init_ssrf_m, ONLY: start_init_subsurf
+  USE phys_state_var_mod, ONLY: beta_aridity, delta_tsurf, awake_dens, cv_gen, &
+       ratqs_inter_
+  !use ioipsl
+  IMPLICIT NONE
+!-------------------------------------------------------------------------------
+! Arguments:
+  REAL,    INTENT(INOUT) :: masque(:,:) !--- Land mask           dim(iip1,jjp1)
+  REAL,    INTENT(INOUT) :: phis  (:,:) !--- Ground geopotential dim(iip1,jjp1)
+!-------------------------------------------------------------------------------
+! Local variables:
+  CHARACTER(LEN=256) :: modname="etat0phys_netcdf", fmt
+  INTEGER            :: i, j, l, ji, iml, jml
+  LOGICAL            :: read_mask
+  REAL               :: phystep, dummy
+  REAL, DIMENSION(SIZE(masque,1),SIZE(masque,2)) :: masque_tmp,phiso
+  REAL, DIMENSION(klon)               :: sn, rugmer, run_off_lic_0, fder
+  REAL, DIMENSION(klon,nbsrf)         :: qsurf, snsrf
+  REAL, DIMENSION(klon,nsoilmx,nbsrf) :: tsoil
+
+!--- Arguments for conf_phys
+  LOGICAL :: ok_journe, ok_mensuel, ok_instan, ok_hf, ok_LES, callstats
+  REAL    :: solarlong0, seuil_inversion, fact_cldcon, facttemps
+  LOGICAL :: ok_newmicro
+  INTEGER :: iflag_radia, iflag_cldcon, iflag_ratqs
+  REAL    :: ratqsbas, ratqshaut, tau_ratqs
+  LOGICAL :: ok_ade, ok_aie, ok_volcan, ok_alw, ok_cdnc, aerosol_couple, chemistry_couple
+  INTEGER :: flag_aerosol
+  INTEGER :: flag_aerosol_strat
+  INTEGER :: flag_volc_surfstrat
+  LOGICAL :: flag_aer_feedback
+  LOGICAL :: flag_bc_internal_mixture
+  REAL    :: bl95_b0, bl95_b1
+  INTEGER :: read_climoz                        !--- Read ozone climatology
+  REAL    :: alp_offset
+  LOGICAL :: filtre_oro=.false.
+
+  INCLUDE "compbl.h"
+  INCLUDE "alpale.h"
+  
+  deg2rad= pi/180.0
+  iml=assert_eq(SIZE(masque,1),SIZE(phis,1),TRIM(modname)//" iml")
+  jml=assert_eq(SIZE(masque,2),SIZE(phis,2),TRIM(modname)//" jml")
+
+! Physics configuration
+!*******************************************************************************
+  CALL conf_phys(  ok_journe, ok_mensuel, ok_instan, ok_hf, ok_LES,     &
+                   callstats,                                           &
+                   solarlong0,seuil_inversion,                          &
+                   fact_cldcon, facttemps,ok_newmicro,iflag_radia,      &
+                   iflag_cldcon,                                        &
+                   ratqsbas,ratqshaut,tau_ratqs,            &
+                   ok_ade, ok_aie, ok_alw, ok_cdnc, ok_volcan, flag_volc_surfstrat,     &
+                   aerosol_couple, chemistry_couple, flag_aerosol, flag_aerosol_strat,  & 
+                   flag_aer_feedback, flag_bc_internal_mixture, bl95_b0, bl95_b1,       &
+                   read_climoz, alp_offset)
+  CALL phys_state_var_init(read_climoz)
+
+!--- Initial atmospheric CO2 conc. from .def file
+  co2_ppm0 = co2_ppm
+
+! Compute ground geopotential, sub-cells quantities and possibly the mask.
+!*******************************************************************************
+  read_mask=ANY(masque/=-99999.); masque_tmp=masque
+  CALL start_init_orog(rlonv, rlatu, phis, masque_tmp)
+
+  CALL getin('filtre_oro',filtre_oro)
+  IF (filtre_oro) CALL filtreoro(size(phis,1),size(phis,2),phis,masque_tmp,rlatu)
+
+  WRITE(fmt,"(i4,'i1)')")iml ; fmt='('//ADJUSTL(fmt)
+  IF(.NOT.read_mask) THEN                       !--- Keep mask form orography
+    masque=masque_tmp
+    IF(prt_level>=1) THEN
+      WRITE(lunout,*)'BUILT MASK :'
+      WRITE(lunout,fmt) NINT(masque)
+    END IF
+    WHERE(   masque(:,:)<EPSFRA) masque(:,:)=0.
+    WHERE(1.-masque(:,:)<EPSFRA) masque(:,:)=1.
+  END IF
+  CALL gr_dyn_fi(1,iml,jml,klon,masque,zmasq) !--- Land mask to physical grid
+
+! Compute tsol and qsol on physical grid, knowing phis on 2D grid.
+!*******************************************************************************
+  CALL start_init_phys(rlonu, rlatv, phis)
+
+! Some initializations.
+!*******************************************************************************
+  sn    (:) = 0.0                               !--- Snow
+  radsol(:) = 0.0                               !--- Net radiation at ground
+  rugmer(:) = 0.001                             !--- Ocean rugosity
+  !--- Ozone (zonal or 3D) interpolation in space and time (if 2nd arg is TRUE)
+  IF(read_climoz>=1) CALL regr_horiz_time_climoz(read_climoz,ok_daily_climoz)
+
+! Sub-surfaces initialization.
+!*******************************************************************************
+  CALL start_init_subsurf(read_mask)
+
+! Write physical initial state
+!*******************************************************************************
+  WRITE(lunout,*)'phystep ',dtvr,iphysiq,nbapp_rad
+  phystep = dtvr * FLOAT(iphysiq)
+  radpas  = NINT (86400./phystep/ FLOAT(nbapp_rad) )
+  WRITE(lunout,*)'phystep =', phystep, radpas
+
+! Init: ftsol, snsrf, qsurf, tsoil, rain_fall, snow_fall, solsw, sollw, z0
+!*******************************************************************************
+  DO i=1,nbsrf; ftsol(:,i) = tsol; END DO
+  DO i=1,nbsrf; snsrf(:,i) = sn;   END DO
+  falb_dir(:, :, is_ter) = 0.08
+  falb_dir(:, :, is_lic) = 0.6
+  falb_dir(:, :, is_oce) = 0.5
+  falb_dir(:, :, is_sic) = 0.6
+
+!ym warning missing init for falb_dif => set to 0
+  falb_dif(:,:,:)=0
+
+  u10m(:,:)=0  
+  v10m(:,:)=0  
+  treedrg(:,:,:)=0
+
+  fevap(:,:) = 0.
+  qsurf = 0.
+  DO i=1,nbsrf; DO j=1,nsoilmx; tsoil(:,j,i) = tsol; END DO; END DO
+  rain_fall  = 0.
+  snow_fall  = 0.
+  solsw      = 165.
+  solswfdiff = 1. 
+  sollw      = -53.
+!ym warning missing init for sollwdown => set to 0
+  sollwdown  = 0.
+  t_ancien   = 273.15
+  q_ancien   = 0.
+  ql_ancien = 0.
+  qs_ancien = 0.
+  prlw_ancien = 0.
+  prsw_ancien = 0.
+  prw_ancien = 0.
+  agesno     = 0.
+  
+  u_ancien = 0.
+  v_ancien = 0.
+  wake_delta_pbl_TKE(:,:,:)=0
+  wake_dens(:)=0
+  awake_dens = 0.
+  cv_gen = 0.
+  ale_bl = 0.
+  ale_bl_trig =0.
+  alp_bl=0.
+  ale_wake=0.
+  ale_bl_stat=0.
+
+  cf_ancien = 0.
+  rvc_ancien = 0.
+  
+  z0m(:,:)=0 ! ym missing 5th subsurface initialization
+ 
+  z0m(:,is_oce) = rugmer(:)
+  z0m(:,is_ter) = 0.01 !MAX(1.0e-05,zstd(:)*zsig(:)/2.0)
+  z0m(:,is_lic) = 0.001 !MAX(1.0e-05,zstd(:)*zsig(:)/2.0)
+  z0m(:,is_sic) = 0.001
+  z0h(:,:)=z0m(:,:)
+
+  fder    = 0.0
+  clwcon  = 0.0
+  rnebcon = 0.0
+  ratqs   = 0.0
+  run_off_lic_0 = 0.0 
+  rugoro  = 0.0
+
+! Before phyredem calling, surface modules and values to be saved in startphy.nc
+! are initialized
+!*******************************************************************************
+  dummy            = 1.0
+  pbl_tke(:,:,:)   = 1.e-8 
+  zmax0(:)         = 40.
+  f0(:)            = 1.e-5
+  sig1(:,:)        = 0.
+  w01(:,:)         = 0.
+  wake_deltat(:,:) = 0.
+  wake_deltaq(:,:) = 0.
+  wake_s(:)        = 0.
+  wake_cstar(:)    = 0.
+  wake_fip(:)      = 0.
+  wake_pe          = 0.
+  fm_therm         = 0.
+  entr_therm       = 0.
+  detr_therm       = 0.
+  awake_s = 0.
+
+  CALL fonte_neige_init(run_off_lic_0)
+  CALL pbl_surface_init( fder, snsrf, qsurf, tsoil )
+
+  IF (iflag_pbl>1 .AND. iflag_wake>=1  .AND. iflag_pbl_split >=1) then
+     delta_tsurf = 0.
+     beta_aridity = 0.
+  end IF
+
+  ratqs_inter_ = 0.002
+  CALL phyredem( "startphy.nc" )
+
+!  WRITE(lunout,*)'CCCCCCCCCCCCCCCCCC REACTIVER SORTIE VISU DANS ETAT0'
+!  WRITE(lunout,*)'entree histclo'
+  CALL histclo()
+
+END SUBROUTINE etat0phys_netcdf
+!
+!-------------------------------------------------------------------------------
+
+
+!-------------------------------------------------------------------------------
+!
+SUBROUTINE start_init_orog(lon_in,lat_in,phis,masque)
+!
+!===============================================================================
+! Comment:
+!   This routine launch grid_noro, which computes parameters for SSO scheme as
+!   described in LOTT & MILLER (1997) and LOTT(1999).
+!   In case the file oroparam is present and the key read_orop is activated,
+!   grid_noro is bypassed and sub-cell parameters are read from the file.
+!===============================================================================
+  USE grid_noro_m, ONLY: grid_noro, read_noro
+  USE logic_mod,   ONLY: read_orop
+  IMPLICIT NONE
+!-------------------------------------------------------------------------------
+! Arguments:
+  REAL,    INTENT(IN)    :: lon_in(:), lat_in(:)   ! dim (iml) (jml)
+  REAL,    INTENT(INOUT) :: phis(:,:), masque(:,:) ! dim (iml,jml)
+!-------------------------------------------------------------------------------
+! Local variables:
+  CHARACTER(LEN=256) :: modname
+  INTEGER            :: fid, llm_tmp,ttm_tmp, iml,jml, iml_rel,jml_rel, itau(1)
+  INTEGER            :: ierr
+  REAL               :: lev(1), date, dt
+  REAL, ALLOCATABLE  :: lon_rad(:), lon_ini(:), lon_rel(:,:), relief_hi(:,:)
+  REAL, ALLOCATABLE  :: lat_rad(:), lat_ini(:), lat_rel(:,:), tmp_var  (:,:)
+  REAL, ALLOCATABLE  :: zmea0(:,:), zstd0(:,:), zsig0(:,:)
+  REAL, ALLOCATABLE  :: zgam0(:,:), zthe0(:,:), zpic0(:,:), zval0(:,:)
+!-------------------------------------------------------------------------------
+  modname="start_init_orog"
+  iml=assert_eq(SIZE(lon_in),SIZE(phis,1),SIZE(masque,1),TRIM(modname)//" iml")
+  jml=assert_eq(SIZE(lat_in),SIZE(phis,2),SIZE(masque,2),TRIM(modname)//" jml")
+
+!--- HIGH RESOLUTION OROGRAPHY
+  CALL flininfo(orofname, iml_rel, jml_rel, llm_tmp, ttm_tmp, fid)
+
+  ALLOCATE(lat_rel(iml_rel,jml_rel),lon_rel(iml_rel,jml_rel))
+  CALL flinopen(orofname, .FALSE., iml_rel, jml_rel, llm_tmp, lon_rel, lat_rel,&
+                lev, ttm_tmp, itau, date, dt, fid)
+  ALLOCATE(relief_hi(iml_rel,jml_rel))
+  CALL flinget(fid, orogvar, iml_rel, jml_rel, llm_tmp, ttm_tmp, 1,1, relief_hi)
+  CALL flinclo(fid)
+
+!--- IF ANGLES ARE IN DEGREES, THEY ARE CONVERTED INTO RADIANS
+  ALLOCATE(lon_ini(iml_rel),lat_ini(jml_rel))
+  lon_ini(:)=lon_rel(:,1); IF(MAXVAL(lon_rel)>pi) lon_ini=lon_ini*deg2rad
+  lat_ini(:)=lat_rel(1,:); IF(MAXVAL(lat_rel)>pi) lat_ini=lat_ini*deg2rad
+
+!--- FIELDS ARE PROCESSED TO BE ON STANDARD ANGULAR DOMAINS
+  ALLOCATE(lon_rad(iml_rel),lat_rad(jml_rel))
+  CALL conf_dat2d(orogvar, lon_ini, lat_ini, lon_rad, lat_rad, relief_hi,.FALSE.)
+  DEALLOCATE(lon_ini,lat_ini)
+
+!--- COMPUTING THE REQUIRED FIELDS USING ROUTINE grid_noro
+  WRITE(lunout,*)
+  WRITE(lunout,*)'*** Compute parameters needed for gravity wave drag code ***'
+
+!--- ALLOCATIONS OF SUB-CELL SCALES QUANTITIES
+  ALLOCATE(zmea0(iml,jml),zstd0(iml,jml)) !--- Mean orography and std deviation
+  ALLOCATE(zsig0(iml,jml),zgam0(iml,jml)) !--- Slope and nisotropy
+  zsig0(:,:)=0   !ym uninitialized variable
+  zgam0(:,:)=0   !ym uninitialized variable
+  ALLOCATE(zthe0(iml,jml))                !--- Highest slope orientation
+  zthe0(:,:)=0   !ym uninitialized variable
+  ALLOCATE(zpic0(iml,jml),zval0(iml,jml)) !--- Peaks and valley heights
+
+!--- READ SUB-CELL SCALES PARAMETERS FROM A FILE (AT RIGHT RESOLUTION)
+  OPEN(UNIT=66,FILE=oroparam,STATUS='OLD',IOSTAT=ierr)
+  IF(ierr==0.AND.read_orop) THEN
+    CLOSE(UNIT=66)
+    CALL read_noro(lon_in,lat_in,oroparam,                                     &
+                   phis,zmea0,zstd0,zsig0,zgam0,zthe0,zpic0,zval0,masque)
+  ELSE
+!--- CALL OROGRAPHY MODULE TO COMPUTE FIELDS
+    CALL grid_noro(lon_rad,lat_rad,relief_hi,lon_in,lat_in,                    &
+                   phis,zmea0,zstd0,zsig0,zgam0,zthe0,zpic0,zval0,masque)
+  END IF
+  phis = phis * 9.81
+  phis(iml,:) = phis(1,:)
+  DEALLOCATE(relief_hi,lon_rad,lat_rad)
+
+!--- PUT QUANTITIES TO PHYSICAL GRID
+  CALL gr_dyn_fi(1,iml,jml,klon,zmea0,zmea); DEALLOCATE(zmea0)
+  CALL gr_dyn_fi(1,iml,jml,klon,zstd0,zstd); DEALLOCATE(zstd0)
+  CALL gr_dyn_fi(1,iml,jml,klon,zsig0,zsig); DEALLOCATE(zsig0)
+  CALL gr_dyn_fi(1,iml,jml,klon,zgam0,zgam); DEALLOCATE(zgam0)
+  CALL gr_dyn_fi(1,iml,jml,klon,zthe0,zthe); DEALLOCATE(zthe0)
+  CALL gr_dyn_fi(1,iml,jml,klon,zpic0,zpic); DEALLOCATE(zpic0)
+  CALL gr_dyn_fi(1,iml,jml,klon,zval0,zval); DEALLOCATE(zval0)
+
+
+END SUBROUTINE start_init_orog
+!
+!-------------------------------------------------------------------------------
+
+
+!-------------------------------------------------------------------------------
+!
+SUBROUTINE start_init_phys(lon_in,lat_in,phis)
+!
+!===============================================================================
+! Purpose:   Compute tsol and qsol, knowing phis.
+!===============================================================================
+  IMPLICIT NONE
+!-------------------------------------------------------------------------------
+! Arguments:
+  REAL,    INTENT(IN) :: lon_in(:),  lat_in(:)       ! dim (iml) (jml2)
+  REAL,    INTENT(IN) :: phis(:,:)                   ! dim (iml,jml)
+!-------------------------------------------------------------------------------
+! Local variables:
+  CHARACTER(LEN=256) :: modname
+  REAL               :: date, dt
+  INTEGER            :: iml, jml, jml2, itau(1)
+  REAL, ALLOCATABLE  :: lon_rad(:), lon_ini(:), var_ana(:,:)
+  REAL, ALLOCATABLE  :: lat_rad(:), lat_ini(:)
+  REAL, ALLOCATABLE  :: ts(:,:), qs(:,:)
+!-------------------------------------------------------------------------------
+  modname="start_init_phys"
+  iml=assert_eq(SIZE(lon_in),SIZE(phis,1),TRIM(modname)//" iml")
+  jml=SIZE(phis,2); jml2=SIZE(lat_in)
+
+  WRITE(lunout,*)'Opening the surface analysis'
+  CALL flininfo(phyfname, iml_phys, jml_phys, llm_phys, ttm_phys, fid_phys)
+  WRITE(lunout,*) 'Values read: ',  iml_phys, jml_phys, llm_phys, ttm_phys
+
+  ALLOCATE(lat_phys(iml_phys,jml_phys),lon_phys(iml_phys,jml_phys))
+  ALLOCATE(levphys_ini(llm_phys))
+  CALL flinopen(phyfname, .FALSE., iml_phys, jml_phys, llm_phys,              &
+                lon_phys,lat_phys,levphys_ini,ttm_phys,itau,date,dt,fid_phys)
+
+!--- IF ANGLES ARE IN DEGREES, THEY ARE CONVERTED INTO RADIANS
+  ALLOCATE(lon_ini(iml_phys),lat_ini(jml_phys))
+  lon_ini(:)=lon_phys(:,1); IF(MAXVAL(lon_phys)>pi) lon_ini=lon_ini*deg2rad
+  lat_ini(:)=lat_phys(1,:); IF(MAXVAL(lat_phys)>pi) lat_ini=lat_ini*deg2rad
+
+  ALLOCATE(var_ana(iml_phys,jml_phys),lon_rad(iml_phys),lat_rad(jml_phys))
+  CALL get_var_phys(tsrfvar,ts)                   !--- SURFACE TEMPERATURE
+  CALL get_var_phys(qsolvar,qs)                   !--- SOIL MOISTURE
+  CALL flinclo(fid_phys)
+  DEALLOCATE(var_ana,lon_rad,lat_rad,lon_ini,lat_ini)
+
+!--- TSOL AND QSOL ON PHYSICAL GRID
+  ALLOCATE(tsol(klon))
+  CALL gr_dyn_fi(1,iml,jml,klon,ts,tsol)
+  CALL gr_dyn_fi(1,iml,jml,klon,qs,qsol)
+  DEALLOCATE(ts,qs)
+
+CONTAINS
+
+!-------------------------------------------------------------------------------
+!
+SUBROUTINE get_var_phys(title,field)
+!
+!-------------------------------------------------------------------------------
+  IMPLICIT NONE
+!-------------------------------------------------------------------------------
+! Arguments:
+  CHARACTER(LEN=*),  INTENT(IN)    :: title
+  REAL, ALLOCATABLE, INTENT(INOUT) :: field(:,:)
+!-------------------------------------------------------------------------------
+! Local variables:
+  INTEGER :: tllm
+!-------------------------------------------------------------------------------
+  SELECT CASE(title)
+    CASE(psrfvar);         tllm=0
+    CASE(tsrfvar,qsolvar); tllm=llm_phys
+  END SELECT
+  IF(ALLOCATED(field)) RETURN
+  ALLOCATE(field(iml,jml)); field(:,:)=0.
+  CALL flinget(fid_phys,title,iml_phys,jml_phys,tllm,ttm_phys,1,1,var_ana)
+  CALL conf_dat2d(title, lon_ini, lat_ini, lon_rad, lat_rad, var_ana, .TRUE.)
+  CALL interp_startvar(title, .TRUE., lon_rad, lat_rad, var_ana,               &
+                                      lon_in,  lat_in,  field)
+
+END SUBROUTINE get_var_phys
+!
+!-------------------------------------------------------------------------------
+!
+END SUBROUTINE start_init_phys
+!
+!-------------------------------------------------------------------------------
+
+
+!-------------------------------------------------------------------------------
+!
+SUBROUTINE interp_startvar(nam,ibeg,lon,lat,vari,lon2,lat2,varo)
+!
+!-------------------------------------------------------------------------------
+  USE inter_barxy_m, ONLY: inter_barxy
+  IMPLICIT NONE
+!-------------------------------------------------------------------------------
+! Arguments:
+  CHARACTER(LEN=*), INTENT(IN)  :: nam
+  LOGICAL,          INTENT(IN)  :: ibeg
+  REAL,             INTENT(IN)  :: lon(:), lat(:)   ! dim (ii) (jj)
+  REAL,             INTENT(IN)  :: vari(:,:)        ! dim (ii,jj)
+  REAL,             INTENT(IN)  :: lon2(:), lat2(:) ! dim (i1) (j2)
+  REAL,             INTENT(OUT) :: varo(:,:)        ! dim (i1) (j1)
+!-------------------------------------------------------------------------------
+! Local variables:
+  CHARACTER(LEN=256) :: modname
+  INTEGER            :: ii, jj, i1, j1, j2
+  REAL, ALLOCATABLE  :: vtmp(:,:)
+!-------------------------------------------------------------------------------
+  modname="interp_startvar"
+  ii=assert_eq(SIZE(lon), SIZE(vari,1),TRIM(modname)//" ii")
+  jj=assert_eq(SIZE(lat), SIZE(vari,2),TRIM(modname)//" jj")
+  i1=assert_eq(SIZE(lon2),SIZE(varo,1),TRIM(modname)//" i1")
+  j1=SIZE(varo,2); j2=SIZE(lat2)
+  ALLOCATE(vtmp(i1-1,j1))
+  IF(ibeg.AND.prt_level>1) THEN
+    WRITE(lunout,*)"--------------------------------------------------------"
+    WRITE(lunout,*)"$$$ Interpolation barycentrique pour "//TRIM(nam)//" $$$"
+    WRITE(lunout,*)"--------------------------------------------------------"
+  END IF
+  CALL inter_barxy(lon, lat(:jj-1), vari, lon2(:i1-1), lat2, vtmp)
+  CALL gr_int_dyn(vtmp, varo, i1-1, j1)
+
+END SUBROUTINE interp_startvar
+!
+!-------------------------------------------------------------------------------
+!
+!*******************************************************************************
+
+SUBROUTINE filtreoro(imp1,jmp1,phis,masque,rlatu)
+
+IMPLICIT NONE
+
+  INTEGER imp1,jmp1
+  REAL, DIMENSION(imp1,jmp1) :: phis,masque
+  REAL, DIMENSION(jmp1) :: rlatu
+  REAL, DIMENSION(imp1) :: wwf
+  REAL, DIMENSION(imp1,jmp1) :: phiso
+  INTEGER :: ifiltre,ifi,ii,i,j
+  REAL :: coslat0,ssz
+
+  coslat0=0.5
+  phiso=phis
+  do j=2,jmp1-1
+     print*,'avant if ',cos(rlatu(j)),coslat0
+     if (cos(rlatu(j))<coslat0) then
+         ! nb de pts affectes par le filtrage de part et d'autre du pt
+         ifiltre=(coslat0/cos(rlatu(j))-1.)/2.
+         wwf=0.
+         do i=1,ifiltre
+            wwf(i)=1.
+         enddo
+         wwf(ifiltre+1)=(coslat0/cos(rlatu(j))-1.)/2.-ifiltre
+         do i=1,imp1-1
+            if (masque(i,j)>0.9) then
+               ssz=phis(i,j)
+               do ifi=1,ifiltre+1
+                  ii=i+ifi
+                  if (ii>imp1-1) ii=ii-imp1+1
+                  ssz=ssz+wwf(ifi)*phis(ii,j)
+                  ii=i-ifi
+                  if (ii<1) ii=ii+imp1-1
+                  ssz=ssz+wwf(ifi)*phis(ii,j)
+               enddo
+               phis(i,j)=ssz*cos(rlatu(j))/coslat0
+            endif
+         enddo
+         print*,'j=',j,coslat0/cos(rlatu(j)), (1.+2.*sum(wwf))*cos(rlatu(j))/coslat0
+     endif
+  enddo
+  call dump2d(imp1,jmp1,phis,'phis ')
+  call dump2d(imp1,jmp1,masque,'masque ')
+  call dump2d(imp1,jmp1,phis-phiso,'dphis ')
+
+END SUBROUTINE filtreoro
+
+
+END MODULE etat0phys
Index: DZ6/trunk/libf/dynphy_lonlat/phylmd/init_ssrf_m.F90
===================================================================
--- /LMDZ6/trunk/libf/dynphy_lonlat/phylmd/init_ssrf_m.F90	(revision 5267)
+++ 	(revision )
@@ -1,148 +1,0 @@
-MODULE init_ssrf_m
-!
-!*******************************************************************************
-
-  USE indice_sol_mod,     ONLY: is_ter, is_oce, is_oce, is_lic, epsfra
-  USE dimphy,             ONLY: klon, zmasq
-  USE phys_state_var_mod, ONLY: pctsrf
-  USE geometry_mod,       ONLY : longitude_deg, latitude_deg
-  USE grid_atob_m,        ONLY: grille_m
-  USE ioipsl,             ONLY: flininfo, flinopen, flinget, flinclo
-  USE ioipsl_getin_p_mod, ONLY: getin_p
-  USE comconst_mod,       ONLY: im, pi
-  USE surface_data,       ONLY: landice_opt
-
-  CHARACTER(LEN=256), PARAMETER :: icefname="landiceref.nc", icevar="landice"
-  PRIVATE
-  PUBLIC :: start_init_subsurf
-  include "iniprint.h"
-  include "dimensions.h"
-  include "paramet.h"
-  include "comgeom2.h"
-
-CONTAINS
-
-!-------------------------------------------------------------------------------
-!
-SUBROUTINE start_init_subsurf(known_mask)
-!
-!-------------------------------------------------------------------------------
-! Purpose: Subsurfaces initialization.
-!-------------------------------------------------------------------------------
-! Comment: Called by etat0phys_netcdf ; also called by limit_netcdf in case
-!          no starting states are required (ok_etat0==.FALSE.).
-!-------------------------------------------------------------------------------
-  IMPLICIT NONE
-!-------------------------------------------------------------------------------
-! Arguments:
-  LOGICAL, INTENT(IN) :: known_mask
-!-------------------------------------------------------------------------------
-! Local variables:
-  INTEGER           :: iml_lic, jml_lic
-  INTEGER           :: fid, llm_tmp, ttm_tmp, itaul(1), ji, j
-  REAL, ALLOCATABLE :: dlon_lic(:), lon_lic(:,:), fraclic (:,:)
-  REAL, ALLOCATABLE :: dlat_lic(:), lat_lic(:,:), flic_tmp(:,:), vtmp(:,:)
-  REAL              :: date, lev(1), dt, deg2rad
-  LOGICAL           :: no_ter_antartique   ! If true, no land points are allowed at Antartic
-!-------------------------------------------------------------------------------
-  deg2rad= pi/180.0
-
-!--- Physical grid points coordinates
-  DO j=2,jjm; latitude_deg((j-2)*iim+2:(j-1)*iim+1)=rlatu(j);    END DO
-  DO j=2,jjm; longitude_deg((j-2)*iim+2:(j-1)*iim+1)=rlonv(1:im); END DO
-  latitude_deg(1) = pi/2.; latitude_deg(klon) = - pi/2.
-  latitude_deg(:)=latitude_deg(:)/deg2rad
-  longitude_deg(1) = 0.0;   longitude_deg(klon) = 0.0;
-  longitude_deg(:)=longitude_deg(:)/deg2rad
-
-! Compute ground geopotential, sub-cells quantities and possibly the mask.
-! Sub-surfaces initialization
-!*******************************************************************************
-  IF (landice_opt .LT. 2) THEN
-     ! Continue with reading landice.nc file
-     WRITE(lunout,*)"Read landice.nc file to attribute is_lic fraction"
-
-     !--- Read and interpolate on model T-grid soil fraction and soil ice fraction.
-     CALL flininfo(icefname, iml_lic, jml_lic, llm_tmp, ttm_tmp, fid)
-     ALLOCATE(lat_lic(iml_lic,jml_lic),lon_lic(iml_lic,jml_lic))
-     ALLOCATE(fraclic(iml_lic,jml_lic))
-     CALL flinopen(icefname, .FALSE., iml_lic, jml_lic, llm_tmp,  &
-          &               lon_lic, lat_lic, lev, ttm_tmp, itaul, date, dt, fid)
-     CALL flinget(fid, icevar, iml_lic, jml_lic, llm_tmp, ttm_tmp, 1,1, fraclic)
-     CALL flinclo(fid)
-     WRITE(lunout,*)'landice dimensions: iml_lic, jml_lic : ',iml_lic,jml_lic
-     
-     ALLOCATE(dlon_lic(iml_lic),dlat_lic(jml_lic))
-     dlon_lic(:)=lon_lic(:,1); IF(MAXVAL(dlon_lic)>pi) dlon_lic=dlon_lic*pi/180.
-     dlat_lic(:)=lat_lic(1,:); IF(MAXVAL(dlat_lic)>pi) dlat_lic=dlat_lic*pi/180.
-     DEALLOCATE(lon_lic,lat_lic); ALLOCATE(flic_tmp(iip1,jjp1))
-     CALL grille_m(dlon_lic,dlat_lic,fraclic,rlonv(1:iim),rlatu,flic_tmp(1:iim,:))
-     flic_tmp(iip1,:)=flic_tmp(1,:)
-     
-     !--- To the physical grid
-     pctsrf(:,:) = 0.
-     CALL gr_dyn_fi(1, iip1, jjp1, klon, flic_tmp, pctsrf(:,is_lic))
-     DEALLOCATE(flic_tmp)
-     
-     !--- Adequation with soil/sea mask
-     WHERE(pctsrf(:,is_lic)<EPSFRA) pctsrf(:,is_lic)=0. 
-     WHERE(zmasq(:)<EPSFRA)         pctsrf(:,is_lic)=0.
-     pctsrf(:,is_ter)=zmasq(:)
-     DO ji=1,klon
-        IF(zmasq(ji)>EPSFRA) THEN 
-           IF(pctsrf(ji,is_lic)>=zmasq(ji)) THEN
-              pctsrf(ji,is_lic)=zmasq(ji)
-              pctsrf(ji,is_ter)=0.
-           ELSE
-              pctsrf(ji,is_ter)=zmasq(ji)-pctsrf(ji,is_lic)
-              IF(pctsrf(ji,is_ter)<EPSFRA) THEN
-                 pctsrf(ji,is_ter)=0.
-                 pctsrf(ji,is_lic)=zmasq(ji)
-              END IF
-           END IF
-        END IF
-     END DO
-     
-     
-     !--- Option no_ter_antartique removes all land fractions souther than 60S.
-     !--- Land ice is set instead of the land fractions on these latitudes.
-     !--- The ocean and sea-ice fractions are not changed.
-     no_ter_antartique=.FALSE.
-     CALL getin_p('no_ter_antartique',no_ter_antartique)
-     WRITE(lunout,*)"no_ter_antartique=",no_ter_antartique
-     IF (no_ter_antartique) THEN
-        ! Remove all land fractions souther than 60S and set land-ice instead
-        WRITE(lunout,*) "Remove land fractions souther than 60deg south by increasing"
-        WRITE(lunout,*) "the continental ice fractions. No land can now be found at Antartic."
-        DO ji=1, klon
-           IF (latitude_deg(ji)<-60.0) THEN
-              pctsrf(ji,is_lic) = pctsrf(ji,is_lic) + pctsrf(ji,is_ter)
-              pctsrf(ji,is_ter) = 0
-           END IF
-        END DO
-     END IF
-     
-  ELSE
-     ! landice_opt=2 and higher
-     WRITE(lunout,*) 'No landice is attributed is_lic sub-surface because landice_opt=2 or higher.'
-     WRITE(lunout,*) 'This means that the land model will handel land ice as well as all other land areas.'
-     pctsrf(:,is_ter) = zmasq(:)
-     pctsrf(:,is_lic) = 0.0
-  END IF
-
-!--- Sub-surface ocean and sea ice (sea ice set to zero for start).
-  pctsrf(:,is_oce)=(1.-zmasq(:))
-  WHERE(pctsrf(:,is_oce)<EPSFRA) pctsrf(:,is_oce)=0.
-  IF(known_mask) pctsrf(:,is_oce)=1-zmasq(:)
-
-!--- It is checked that the sub-surfaces sum is equal to 1.
-  ji=COUNT((ABS(SUM(pctsrf(:,:),dim=2))-1.0)>EPSFRA)
-  IF(ji/=0) WRITE(lunout,*) 'Sub-cell distribution problem for ',ji,' points'
-
-END SUBROUTINE start_init_subsurf
-!
-!-------------------------------------------------------------------------------
-
-END MODULE init_ssrf_m
-!
-!*******************************************************************************
Index: /LMDZ6/trunk/libf/dynphy_lonlat/phylmd/init_ssrf_m.f90
===================================================================
--- /LMDZ6/trunk/libf/dynphy_lonlat/phylmd/init_ssrf_m.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dynphy_lonlat/phylmd/init_ssrf_m.f90	(revision 5268)
@@ -0,0 +1,148 @@
+MODULE init_ssrf_m
+!
+!*******************************************************************************
+
+  USE indice_sol_mod,     ONLY: is_ter, is_oce, is_oce, is_lic, epsfra
+  USE dimphy,             ONLY: klon, zmasq
+  USE phys_state_var_mod, ONLY: pctsrf
+  USE geometry_mod,       ONLY : longitude_deg, latitude_deg
+  USE grid_atob_m,        ONLY: grille_m
+  USE ioipsl,             ONLY: flininfo, flinopen, flinget, flinclo
+  USE ioipsl_getin_p_mod, ONLY: getin_p
+  USE comconst_mod,       ONLY: im, pi
+  USE surface_data,       ONLY: landice_opt
+
+  CHARACTER(LEN=256), PARAMETER :: icefname="landiceref.nc", icevar="landice"
+  PRIVATE
+  PUBLIC :: start_init_subsurf
+  include "iniprint.h"
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom2.h"
+
+CONTAINS
+
+!-------------------------------------------------------------------------------
+!
+SUBROUTINE start_init_subsurf(known_mask)
+!
+!-------------------------------------------------------------------------------
+! Purpose: Subsurfaces initialization.
+!-------------------------------------------------------------------------------
+! Comment: Called by etat0phys_netcdf ; also called by limit_netcdf in case
+!          no starting states are required (ok_etat0==.FALSE.).
+!-------------------------------------------------------------------------------
+  IMPLICIT NONE
+!-------------------------------------------------------------------------------
+! Arguments:
+  LOGICAL, INTENT(IN) :: known_mask
+!-------------------------------------------------------------------------------
+! Local variables:
+  INTEGER           :: iml_lic, jml_lic
+  INTEGER           :: fid, llm_tmp, ttm_tmp, itaul(1), ji, j
+  REAL, ALLOCATABLE :: dlon_lic(:), lon_lic(:,:), fraclic (:,:)
+  REAL, ALLOCATABLE :: dlat_lic(:), lat_lic(:,:), flic_tmp(:,:), vtmp(:,:)
+  REAL              :: date, lev(1), dt, deg2rad
+  LOGICAL           :: no_ter_antartique   ! If true, no land points are allowed at Antartic
+!-------------------------------------------------------------------------------
+  deg2rad= pi/180.0
+
+!--- Physical grid points coordinates
+  DO j=2,jjm; latitude_deg((j-2)*iim+2:(j-1)*iim+1)=rlatu(j);    END DO
+  DO j=2,jjm; longitude_deg((j-2)*iim+2:(j-1)*iim+1)=rlonv(1:im); END DO
+  latitude_deg(1) = pi/2.; latitude_deg(klon) = - pi/2.
+  latitude_deg(:)=latitude_deg(:)/deg2rad
+  longitude_deg(1) = 0.0;   longitude_deg(klon) = 0.0;
+  longitude_deg(:)=longitude_deg(:)/deg2rad
+
+! Compute ground geopotential, sub-cells quantities and possibly the mask.
+! Sub-surfaces initialization
+!*******************************************************************************
+  IF (landice_opt .LT. 2) THEN
+     ! Continue with reading landice.nc file
+     WRITE(lunout,*)"Read landice.nc file to attribute is_lic fraction"
+
+     !--- Read and interpolate on model T-grid soil fraction and soil ice fraction.
+     CALL flininfo(icefname, iml_lic, jml_lic, llm_tmp, ttm_tmp, fid)
+     ALLOCATE(lat_lic(iml_lic,jml_lic),lon_lic(iml_lic,jml_lic))
+     ALLOCATE(fraclic(iml_lic,jml_lic))
+     CALL flinopen(icefname, .FALSE., iml_lic, jml_lic, llm_tmp,  &
+          &               lon_lic, lat_lic, lev, ttm_tmp, itaul, date, dt, fid)
+     CALL flinget(fid, icevar, iml_lic, jml_lic, llm_tmp, ttm_tmp, 1,1, fraclic)
+     CALL flinclo(fid)
+     WRITE(lunout,*)'landice dimensions: iml_lic, jml_lic : ',iml_lic,jml_lic
+     
+     ALLOCATE(dlon_lic(iml_lic),dlat_lic(jml_lic))
+     dlon_lic(:)=lon_lic(:,1); IF(MAXVAL(dlon_lic)>pi) dlon_lic=dlon_lic*pi/180.
+     dlat_lic(:)=lat_lic(1,:); IF(MAXVAL(dlat_lic)>pi) dlat_lic=dlat_lic*pi/180.
+     DEALLOCATE(lon_lic,lat_lic); ALLOCATE(flic_tmp(iip1,jjp1))
+     CALL grille_m(dlon_lic,dlat_lic,fraclic,rlonv(1:iim),rlatu,flic_tmp(1:iim,:))
+     flic_tmp(iip1,:)=flic_tmp(1,:)
+     
+     !--- To the physical grid
+     pctsrf(:,:) = 0.
+     CALL gr_dyn_fi(1, iip1, jjp1, klon, flic_tmp, pctsrf(:,is_lic))
+     DEALLOCATE(flic_tmp)
+     
+     !--- Adequation with soil/sea mask
+     WHERE(pctsrf(:,is_lic)<EPSFRA) pctsrf(:,is_lic)=0. 
+     WHERE(zmasq(:)<EPSFRA)         pctsrf(:,is_lic)=0.
+     pctsrf(:,is_ter)=zmasq(:)
+     DO ji=1,klon
+        IF(zmasq(ji)>EPSFRA) THEN 
+           IF(pctsrf(ji,is_lic)>=zmasq(ji)) THEN
+              pctsrf(ji,is_lic)=zmasq(ji)
+              pctsrf(ji,is_ter)=0.
+           ELSE
+              pctsrf(ji,is_ter)=zmasq(ji)-pctsrf(ji,is_lic)
+              IF(pctsrf(ji,is_ter)<EPSFRA) THEN
+                 pctsrf(ji,is_ter)=0.
+                 pctsrf(ji,is_lic)=zmasq(ji)
+              END IF
+           END IF
+        END IF
+     END DO
+     
+     
+     !--- Option no_ter_antartique removes all land fractions souther than 60S.
+     !--- Land ice is set instead of the land fractions on these latitudes.
+     !--- The ocean and sea-ice fractions are not changed.
+     no_ter_antartique=.FALSE.
+     CALL getin_p('no_ter_antartique',no_ter_antartique)
+     WRITE(lunout,*)"no_ter_antartique=",no_ter_antartique
+     IF (no_ter_antartique) THEN
+        ! Remove all land fractions souther than 60S and set land-ice instead
+        WRITE(lunout,*) "Remove land fractions souther than 60deg south by increasing"
+        WRITE(lunout,*) "the continental ice fractions. No land can now be found at Antartic."
+        DO ji=1, klon
+           IF (latitude_deg(ji)<-60.0) THEN
+              pctsrf(ji,is_lic) = pctsrf(ji,is_lic) + pctsrf(ji,is_ter)
+              pctsrf(ji,is_ter) = 0
+           END IF
+        END DO
+     END IF
+     
+  ELSE
+     ! landice_opt=2 and higher
+     WRITE(lunout,*) 'No landice is attributed is_lic sub-surface because landice_opt=2 or higher.'
+     WRITE(lunout,*) 'This means that the land model will handel land ice as well as all other land areas.'
+     pctsrf(:,is_ter) = zmasq(:)
+     pctsrf(:,is_lic) = 0.0
+  END IF
+
+!--- Sub-surface ocean and sea ice (sea ice set to zero for start).
+  pctsrf(:,is_oce)=(1.-zmasq(:))
+  WHERE(pctsrf(:,is_oce)<EPSFRA) pctsrf(:,is_oce)=0.
+  IF(known_mask) pctsrf(:,is_oce)=1-zmasq(:)
+
+!--- It is checked that the sub-surfaces sum is equal to 1.
+  ji=COUNT((ABS(SUM(pctsrf(:,:),dim=2))-1.0)>EPSFRA)
+  IF(ji/=0) WRITE(lunout,*) 'Sub-cell distribution problem for ',ji,' points'
+
+END SUBROUTINE start_init_subsurf
+!
+!-------------------------------------------------------------------------------
+
+END MODULE init_ssrf_m
+!
+!*******************************************************************************
Index: DZ6/trunk/libf/dynphy_lonlat/phylmd/test_disvert_m.F90
===================================================================
--- /LMDZ6/trunk/libf/dynphy_lonlat/phylmd/test_disvert_m.F90	(revision 5267)
+++ 	(revision )
@@ -1,66 +1,0 @@
-module test_disvert_m
-
-  implicit none
-
-contains
-
-  subroutine test_disvert
-
-    ! Author: Lionel GUEZ
-
-    ! This procedure tests the order of pressure values at half-levels
-    ! and full levels. We arbitrarily choose to test ngrid values of
-    ! the surface pressure, which sample possible values on Earth.
-
-    use exner_hyb_m, only: exner_hyb
-    use vertical_layers_mod, only: ap,bp,preff
-    use comconst_mod, only: kappa, cpp
-
-    ! For llm:
-    include "dimensions.h"
-
-    ! Local:
-    integer l, i
-    integer, parameter:: ngrid = 7
-    real p(ngrid, llm + 1) ! pressure at half-level, in Pa
-    real pks(ngrid) ! exner function at the surface, in J K-1 kg-1 
-    real pk(ngrid, llm) ! exner function at full level, in J K-1 kg-1 
-    real ps(ngrid) ! surface pressure, in Pa
-    real p_lay(ngrid, llm) ! pressure at full level, in Pa
-    real delta_ps ! in Pa
-
-    !---------------------
-
-    print *, "Call sequence information: test_disvert"
-
-    delta_ps = 6e4 / (ngrid - 1)
-    ps = (/(5e4 + delta_ps * i, i = 0, ngrid - 1)/)
-    forall (l = 1: llm + 1) p(:, l) = ap(l) + bp(l) * ps
-    call exner_hyb(ngrid, ps, p, pks, pk)
-    p_lay = preff * (pk / cpp)**(1. / kappa)
-
-    ! Are pressure values in the right order?
-    if (any(p(:, :llm) <= p_lay .or. p_lay <= p(:, 2:))) then
-       ! List details and stop:
-       do l = 1, llm
-          do i = 1, ngrid
-             if (p(i, l) <= p_lay(i, l)) then
-                print 1000, "ps = ", ps(i) / 100., "hPa, p(level ",  l, &
-                     ") = ", p(i, l) / 100., " hPa <= p(layer ", l, ") = ", &
-                     p_lay(i, l) / 100., " hPa"
-             end if
-             if (p_lay(i, l) <= p(i, l + 1)) then
-                print 1000, "ps = ", ps(i) / 100., "hPa, p(layer ", l, ") = ", &
-                     p_lay(i, l) / 100., " hPa <= p(level ", l + 1, ") = ", &
-                     p(i, l + 1) / 100., " hPa"
-             end if
-          end do
-       end do
-       call abort_physic("test_disvert", "bad order of pressure values", 1)
-    end if
-
-1000 format (3(a, g10.4, a, i0))
-
-  end subroutine test_disvert
-
-end module test_disvert_m
Index: /LMDZ6/trunk/libf/dynphy_lonlat/phylmd/test_disvert_m.f90
===================================================================
--- /LMDZ6/trunk/libf/dynphy_lonlat/phylmd/test_disvert_m.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/dynphy_lonlat/phylmd/test_disvert_m.f90	(revision 5268)
@@ -0,0 +1,66 @@
+module test_disvert_m
+
+  implicit none
+
+contains
+
+  subroutine test_disvert
+
+    ! Author: Lionel GUEZ
+
+    ! This procedure tests the order of pressure values at half-levels
+    ! and full levels. We arbitrarily choose to test ngrid values of
+    ! the surface pressure, which sample possible values on Earth.
+
+    use exner_hyb_m, only: exner_hyb
+    use vertical_layers_mod, only: ap,bp,preff
+    use comconst_mod, only: kappa, cpp
+
+    ! For llm:
+    include "dimensions.h"
+
+    ! Local:
+    integer l, i
+    integer, parameter:: ngrid = 7
+    real p(ngrid, llm + 1) ! pressure at half-level, in Pa
+    real pks(ngrid) ! exner function at the surface, in J K-1 kg-1 
+    real pk(ngrid, llm) ! exner function at full level, in J K-1 kg-1 
+    real ps(ngrid) ! surface pressure, in Pa
+    real p_lay(ngrid, llm) ! pressure at full level, in Pa
+    real delta_ps ! in Pa
+
+    !---------------------
+
+    print *, "Call sequence information: test_disvert"
+
+    delta_ps = 6e4 / (ngrid - 1)
+    ps = (/(5e4 + delta_ps * i, i = 0, ngrid - 1)/)
+    forall (l = 1: llm + 1) p(:, l) = ap(l) + bp(l) * ps
+    call exner_hyb(ngrid, ps, p, pks, pk)
+    p_lay = preff * (pk / cpp)**(1. / kappa)
+
+    ! Are pressure values in the right order?
+    if (any(p(:, :llm) <= p_lay .or. p_lay <= p(:, 2:))) then
+       ! List details and stop:
+       do l = 1, llm
+          do i = 1, ngrid
+             if (p(i, l) <= p_lay(i, l)) then
+                print 1000, "ps = ", ps(i) / 100., "hPa, p(level ",  l, &
+                     ") = ", p(i, l) / 100., " hPa <= p(layer ", l, ") = ", &
+                     p_lay(i, l) / 100., " hPa"
+             end if
+             if (p_lay(i, l) <= p(i, l + 1)) then
+                print 1000, "ps = ", ps(i) / 100., "hPa, p(layer ", l, ") = ", &
+                     p_lay(i, l) / 100., " hPa <= p(level ", l + 1, ") = ", &
+                     p(i, l + 1) / 100., " hPa"
+             end if
+          end do
+       end do
+       call abort_physic("test_disvert", "bad order of pressure values", 1)
+    end if
+
+1000 format (3(a, g10.4, a, i0))
+
+  end subroutine test_disvert
+
+end module test_disvert_m
Index: DZ6/trunk/libf/filtrez/jacobi.F90
===================================================================
--- /LMDZ6/trunk/libf/filtrez/jacobi.F90	(revision 5267)
+++ 	(revision )
@@ -1,106 +1,0 @@
-!
-! $Id$
-!
-      SUBROUTINE JACOBI(A,N,NP,D,V,NROT)
-      implicit none
-! Arguments:
-      integer,intent(in) :: N
-      integer,intent(in) :: NP
-      integer,intent(out) :: NROT
-      real,intent(inout) :: A(NP,NP)
-      real,intent(out) :: D(NP)
-      real,intent(out) :: V(NP,NP)
-
-! local variables:
-      integer :: IP,IQ,I,J
-      real :: SM,TRESH,G,H,T,THETA,C,S,TAU
-      real :: B(N)
-      real :: Z(N)
-      
-      DO IP=1,N
-        DO IQ=1,N
-          V(IP,IQ)=0.
-        ENDDO
-        V(IP,IP)=1.
-      ENDDO
-      DO IP=1,N
-        B(IP)=A(IP,IP)
-        D(IP)=B(IP)
-        Z(IP)=0.
-      ENDDO
-      NROT=0
-      DO I=1,50 ! 50? I suspect this should be NP
-                !     but convergence is fast enough anyway
-        SM=0.
-        DO IP=1,N-1
-          DO IQ=IP+1,N
-            SM=SM+ABS(A(IP,IQ))
-          ENDDO
-        ENDDO
-        IF(SM.EQ.0.)RETURN
-        IF(I.LT.4)THEN
-          TRESH=0.2*SM/N**2
-        ELSE
-          TRESH=0.
-        ENDIF
-        DO IP=1,N-1
-          DO IQ=IP+1,N
-            G=100.*ABS(A(IP,IQ))
-            IF((I.GT.4).AND.(ABS(D(IP))+G.EQ.ABS(D(IP))) &
-               .AND.(ABS(D(IQ))+G.EQ.ABS(D(IQ))))THEN
-              A(IP,IQ)=0.
-            ELSE IF(ABS(A(IP,IQ)).GT.TRESH)THEN
-              H=D(IQ)-D(IP)
-              IF(ABS(H)+G.EQ.ABS(H))THEN
-                T=A(IP,IQ)/H
-              ELSE
-                THETA=0.5*H/A(IP,IQ)
-                T=1./(ABS(THETA)+SQRT(1.+THETA**2))
-                IF(THETA.LT.0.)T=-T
-              ENDIF
-              C=1./SQRT(1+T**2)
-              S=T*C
-              TAU=S/(1.+C)
-              H=T*A(IP,IQ)
-              Z(IP)=Z(IP)-H
-              Z(IQ)=Z(IQ)+H
-              D(IP)=D(IP)-H
-              D(IQ)=D(IQ)+H
-              A(IP,IQ)=0.
-              DO J=1,IP-1
-                G=A(J,IP)
-                H=A(J,IQ)
-                A(J,IP)=G-S*(H+G*TAU)
-                A(J,IQ)=H+S*(G-H*TAU)
-             ENDDO
-              DO J=IP+1,IQ-1
-                G=A(IP,J)
-                H=A(J,IQ)
-                A(IP,J)=G-S*(H+G*TAU)
-                A(J,IQ)=H+S*(G-H*TAU)
-              ENDDO
-              DO J=IQ+1,N
-                G=A(IP,J)
-                H=A(IQ,J)
-                A(IP,J)=G-S*(H+G*TAU)
-                A(IQ,J)=H+S*(G-H*TAU)
-              ENDDO
-              DO J=1,N
-                G=V(J,IP)
-                H=V(J,IQ)
-                V(J,IP)=G-S*(H+G*TAU)
-                V(J,IQ)=H+S*(G-H*TAU)
-              ENDDO
-              NROT=NROT+1
-            ENDIF
-          ENDDO
-        ENDDO
-        DO IP=1,N
-          B(IP)=B(IP)+Z(IP)
-          D(IP)=B(IP)
-          Z(IP)=0.
-        ENDDO
-      ENDDO ! of DO I=1,50
-      STOP 'Jacobi: 50 iterations should never happen'
-      RETURN
-      END SUBROUTINE JACOBI
Index: /LMDZ6/trunk/libf/filtrez/jacobi.f90
===================================================================
--- /LMDZ6/trunk/libf/filtrez/jacobi.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/filtrez/jacobi.f90	(revision 5268)
@@ -0,0 +1,106 @@
+!
+! $Id$
+!
+      SUBROUTINE JACOBI(A,N,NP,D,V,NROT)
+      implicit none
+! Arguments:
+      integer,intent(in) :: N
+      integer,intent(in) :: NP
+      integer,intent(out) :: NROT
+      real,intent(inout) :: A(NP,NP)
+      real,intent(out) :: D(NP)
+      real,intent(out) :: V(NP,NP)
+
+! local variables:
+      integer :: IP,IQ,I,J
+      real :: SM,TRESH,G,H,T,THETA,C,S,TAU
+      real :: B(N)
+      real :: Z(N)
+      
+      DO IP=1,N
+        DO IQ=1,N
+          V(IP,IQ)=0.
+        ENDDO
+        V(IP,IP)=1.
+      ENDDO
+      DO IP=1,N
+        B(IP)=A(IP,IP)
+        D(IP)=B(IP)
+        Z(IP)=0.
+      ENDDO
+      NROT=0
+      DO I=1,50 ! 50? I suspect this should be NP
+                !     but convergence is fast enough anyway
+        SM=0.
+        DO IP=1,N-1
+          DO IQ=IP+1,N
+            SM=SM+ABS(A(IP,IQ))
+          ENDDO
+        ENDDO
+        IF(SM.EQ.0.)RETURN
+        IF(I.LT.4)THEN
+          TRESH=0.2*SM/N**2
+        ELSE
+          TRESH=0.
+        ENDIF
+        DO IP=1,N-1
+          DO IQ=IP+1,N
+            G=100.*ABS(A(IP,IQ))
+            IF((I.GT.4).AND.(ABS(D(IP))+G.EQ.ABS(D(IP))) &
+               .AND.(ABS(D(IQ))+G.EQ.ABS(D(IQ))))THEN
+              A(IP,IQ)=0.
+            ELSE IF(ABS(A(IP,IQ)).GT.TRESH)THEN
+              H=D(IQ)-D(IP)
+              IF(ABS(H)+G.EQ.ABS(H))THEN
+                T=A(IP,IQ)/H
+              ELSE
+                THETA=0.5*H/A(IP,IQ)
+                T=1./(ABS(THETA)+SQRT(1.+THETA**2))
+                IF(THETA.LT.0.)T=-T
+              ENDIF
+              C=1./SQRT(1+T**2)
+              S=T*C
+              TAU=S/(1.+C)
+              H=T*A(IP,IQ)
+              Z(IP)=Z(IP)-H
+              Z(IQ)=Z(IQ)+H
+              D(IP)=D(IP)-H
+              D(IQ)=D(IQ)+H
+              A(IP,IQ)=0.
+              DO J=1,IP-1
+                G=A(J,IP)
+                H=A(J,IQ)
+                A(J,IP)=G-S*(H+G*TAU)
+                A(J,IQ)=H+S*(G-H*TAU)
+             ENDDO
+              DO J=IP+1,IQ-1
+                G=A(IP,J)
+                H=A(J,IQ)
+                A(IP,J)=G-S*(H+G*TAU)
+                A(J,IQ)=H+S*(G-H*TAU)
+              ENDDO
+              DO J=IQ+1,N
+                G=A(IP,J)
+                H=A(IQ,J)
+                A(IP,J)=G-S*(H+G*TAU)
+                A(IQ,J)=H+S*(G-H*TAU)
+              ENDDO
+              DO J=1,N
+                G=V(J,IP)
+                H=V(J,IQ)
+                V(J,IP)=G-S*(H+G*TAU)
+                V(J,IQ)=H+S*(G-H*TAU)
+              ENDDO
+              NROT=NROT+1
+            ENDIF
+          ENDDO
+        ENDDO
+        DO IP=1,N
+          B(IP)=B(IP)+Z(IP)
+          D(IP)=B(IP)
+          Z(IP)=0.
+        ENDDO
+      ENDDO ! of DO I=1,50
+      STOP 'Jacobi: 50 iterations should never happen'
+      RETURN
+      END SUBROUTINE JACOBI
Index: DZ6/trunk/libf/filtrez/mod_fft_wrapper.F90
===================================================================
--- /LMDZ6/trunk/libf/filtrez/mod_fft_wrapper.F90	(revision 5267)
+++ 	(revision )
@@ -1,40 +1,0 @@
-MODULE mod_fft_wrapper
-
-  INTEGER,SAVE             :: vsize
-  INTEGER,PARAMETER        :: inc=1
-
-CONTAINS
-  
-  SUBROUTINE Init_fft(iim,nb)
-  IMPLICIT NONE
-    INTEGER :: iim
-    INTEGER :: nb
-    
-    print *, "wrapper fft : une FFT doit etre specifiee a l'aide d'une clee CPP, sinon utiliser le filtre classique"
-    stop 1
-  END SUBROUTINE Init_fft
-  
-  
-  SUBROUTINE fft_forward(vect,TF_vect,nb_vect)
-    IMPLICIT NONE
-    INTEGER,INTENT(IN)  :: nb_vect
-    REAL,INTENT(IN)     :: vect(vsize+inc,nb_vect)
-    COMPLEX,INTENT(INOUT) :: TF_vect(vsize/2+1,nb_vect)
-    
-    print *, "wrapper fft : une FFT doit etre specifiee a l'aide d'une clee CPP, sinon utiliser le filtre classique"
-    stop 1
-    
-  END SUBROUTINE fft_forward
-  
-  SUBROUTINE fft_backward(TF_vect,vect,nb_vect)
-    IMPLICIT NONE
-    INTEGER,INTENT(IN)  :: nb_vect
-    REAL,INTENT(INOUT)    :: vect(vsize+inc,nb_vect)
-    COMPLEX,INTENT(IN ) :: TF_vect(vsize/2+1,nb_vect)
-  
-    print *, "wrapper fft : une FFT doit etre specifiee a l'aide d'une clee CPP, sinon utiliser le filtre classique"
-    stop 1
-    
-  END SUBROUTINE fft_backward
-  
-END MODULE mod_fft_wrapper
Index: /LMDZ6/trunk/libf/filtrez/mod_fft_wrapper.f90
===================================================================
--- /LMDZ6/trunk/libf/filtrez/mod_fft_wrapper.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/filtrez/mod_fft_wrapper.f90	(revision 5268)
@@ -0,0 +1,40 @@
+MODULE mod_fft_wrapper
+
+  INTEGER,SAVE             :: vsize
+  INTEGER,PARAMETER        :: inc=1
+
+CONTAINS
+  
+  SUBROUTINE Init_fft(iim,nb)
+  IMPLICIT NONE
+    INTEGER :: iim
+    INTEGER :: nb
+    
+    print *, "wrapper fft : une FFT doit etre specifiee a l'aide d'une clee CPP, sinon utiliser le filtre classique"
+    stop 1
+  END SUBROUTINE Init_fft
+  
+  
+  SUBROUTINE fft_forward(vect,TF_vect,nb_vect)
+    IMPLICIT NONE
+    INTEGER,INTENT(IN)  :: nb_vect
+    REAL,INTENT(IN)     :: vect(vsize+inc,nb_vect)
+    COMPLEX,INTENT(INOUT) :: TF_vect(vsize/2+1,nb_vect)
+    
+    print *, "wrapper fft : une FFT doit etre specifiee a l'aide d'une clee CPP, sinon utiliser le filtre classique"
+    stop 1
+    
+  END SUBROUTINE fft_forward
+  
+  SUBROUTINE fft_backward(TF_vect,vect,nb_vect)
+    IMPLICIT NONE
+    INTEGER,INTENT(IN)  :: nb_vect
+    REAL,INTENT(INOUT)    :: vect(vsize+inc,nb_vect)
+    COMPLEX,INTENT(IN ) :: TF_vect(vsize/2+1,nb_vect)
+  
+    print *, "wrapper fft : une FFT doit etre specifiee a l'aide d'une clee CPP, sinon utiliser le filtre classique"
+    stop 1
+    
+  END SUBROUTINE fft_backward
+  
+END MODULE mod_fft_wrapper
Index: DZ6/trunk/libf/filtrez/timer_filtre.F90
===================================================================
--- /LMDZ6/trunk/libf/filtrez/timer_filtre.F90	(revision 5267)
+++ 	(revision )
@@ -1,33 +1,0 @@
-MODULE timer_filtre
-IMPLICIT NONE
-  PRIVATE
-  REAL :: time
-  REAL :: Last_time
-  PUBLIC :: Init_timer, start_timer, stop_timer, Print_filtre_timer
-CONTAINS
-
- SUBROUTINE Init_timer
-   time=0
-   Last_time=0
- END SUBROUTINE Init_timer
- 
- SUBROUTINE Start_timer
-  
-   CALL cpu_time(last_time)
-
- END SUBROUTINE start_timer
- 
- 
- SUBROUTINE stop_timer
-   REAL :: T 
-   
-   CALL cpu_time(t)
-   Time=Time+t-last_time
- 
-  END SUBROUTINE stop_timer
-  
-  SUBROUTINE Print_filtre_timer
-  PRINT *,"Temps CPU passe dans le filtre :",Time
-  END SUBROUTINE  Print_filtre_timer
-
-END MODULE timer_filtre
Index: /LMDZ6/trunk/libf/filtrez/timer_filtre.f90
===================================================================
--- /LMDZ6/trunk/libf/filtrez/timer_filtre.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/filtrez/timer_filtre.f90	(revision 5268)
@@ -0,0 +1,33 @@
+MODULE timer_filtre
+IMPLICIT NONE
+  PRIVATE
+  REAL :: time
+  REAL :: Last_time
+  PUBLIC :: Init_timer, start_timer, stop_timer, Print_filtre_timer
+CONTAINS
+
+ SUBROUTINE Init_timer
+   time=0
+   Last_time=0
+ END SUBROUTINE Init_timer
+ 
+ SUBROUTINE Start_timer
+  
+   CALL cpu_time(last_time)
+
+ END SUBROUTINE start_timer
+ 
+ 
+ SUBROUTINE stop_timer
+   REAL :: T 
+   
+   CALL cpu_time(t)
+   Time=Time+t-last_time
+ 
+  END SUBROUTINE stop_timer
+  
+  SUBROUTINE Print_filtre_timer
+  PRINT *,"Temps CPU passe dans le filtre :",Time
+  END SUBROUTINE  Print_filtre_timer
+
+END MODULE timer_filtre
Index: DZ6/trunk/libf/misc/arth_m.F90
===================================================================
--- /LMDZ6/trunk/libf/misc/arth_m.F90	(revision 5267)
+++ 	(revision )
@@ -1,88 +1,0 @@
-MODULE arth_m
-
-  IMPLICIT NONE
-
-  INTEGER, PARAMETER, private:: NPAR_ARTH=16, NPAR2_ARTH=8
-
-  INTERFACE arth
-     ! Returns an arithmetic progression, given a first term "first", an
-     ! increment and a number of terms "n" (including "first").
-
-     MODULE PROCEDURE arth_r, arth_i
-     ! The difference between the procedures is the kind and type of
-     ! arguments first and increment and of function result.
-  END INTERFACE
-
-  private arth_r, arth_i
-
-CONTAINS
-
-  pure FUNCTION arth_r(first,increment,n)
-
-    REAL, INTENT(IN) :: first,increment
-    INTEGER, INTENT(IN) :: n
-    REAL arth_r(n)
-
-    ! Local:
-    INTEGER :: k,k2
-    REAL :: temp
-
-    !---------------------------------------
-
-    if (n > 0) arth_r(1)=first
-    if (n <= NPAR_ARTH) then
-       do k=2,n
-          arth_r(k)=arth_r(k-1)+increment
-       end do
-    else
-       do k=2,NPAR2_ARTH
-          arth_r(k)=arth_r(k-1)+increment
-       end do
-       temp=increment*NPAR2_ARTH
-       k=NPAR2_ARTH
-       do
-          if (k >= n) exit
-          k2=k+k
-          arth_r(k+1:min(k2,n)) = temp + arth_r(1:min(k,n-k))
-          temp=temp+temp
-          k=k2
-       end do
-    end if
-
-  END FUNCTION arth_r
-
-  !*************************************
-
-  pure FUNCTION arth_i(first,increment,n)
-
-    INTEGER, INTENT(IN) :: first,increment,n
-    INTEGER arth_i(n)
-
-    ! Local:
-    INTEGER :: k,k2,temp
-
-    !---------------------------------------
-
-    if (n > 0) arth_i(1)=first
-    if (n <= NPAR_ARTH) then
-       do k=2,n
-          arth_i(k)=arth_i(k-1)+increment
-       end do
-    else
-       do k=2,NPAR2_ARTH
-          arth_i(k)=arth_i(k-1)+increment
-       end do
-       temp=increment*NPAR2_ARTH
-       k=NPAR2_ARTH
-       do
-          if (k >= n) exit
-          k2=k+k
-          arth_i(k+1:min(k2,n))=temp+arth_i(1:min(k,n-k))
-          temp=temp+temp
-          k=k2
-       end do
-    end if
-
-  END FUNCTION arth_i
-
-END MODULE arth_m
Index: /LMDZ6/trunk/libf/misc/arth_m.f90
===================================================================
--- /LMDZ6/trunk/libf/misc/arth_m.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/misc/arth_m.f90	(revision 5268)
@@ -0,0 +1,88 @@
+MODULE arth_m
+
+  IMPLICIT NONE
+
+  INTEGER, PARAMETER, private:: NPAR_ARTH=16, NPAR2_ARTH=8
+
+  INTERFACE arth
+     ! Returns an arithmetic progression, given a first term "first", an
+     ! increment and a number of terms "n" (including "first").
+
+     MODULE PROCEDURE arth_r, arth_i
+     ! The difference between the procedures is the kind and type of
+     ! arguments first and increment and of function result.
+  END INTERFACE
+
+  private arth_r, arth_i
+
+CONTAINS
+
+  pure FUNCTION arth_r(first,increment,n)
+
+    REAL, INTENT(IN) :: first,increment
+    INTEGER, INTENT(IN) :: n
+    REAL arth_r(n)
+
+    ! Local:
+    INTEGER :: k,k2
+    REAL :: temp
+
+    !---------------------------------------
+
+    if (n > 0) arth_r(1)=first
+    if (n <= NPAR_ARTH) then
+       do k=2,n
+          arth_r(k)=arth_r(k-1)+increment
+       end do
+    else
+       do k=2,NPAR2_ARTH
+          arth_r(k)=arth_r(k-1)+increment
+       end do
+       temp=increment*NPAR2_ARTH
+       k=NPAR2_ARTH
+       do
+          if (k >= n) exit
+          k2=k+k
+          arth_r(k+1:min(k2,n)) = temp + arth_r(1:min(k,n-k))
+          temp=temp+temp
+          k=k2
+       end do
+    end if
+
+  END FUNCTION arth_r
+
+  !*************************************
+
+  pure FUNCTION arth_i(first,increment,n)
+
+    INTEGER, INTENT(IN) :: first,increment,n
+    INTEGER arth_i(n)
+
+    ! Local:
+    INTEGER :: k,k2,temp
+
+    !---------------------------------------
+
+    if (n > 0) arth_i(1)=first
+    if (n <= NPAR_ARTH) then
+       do k=2,n
+          arth_i(k)=arth_i(k-1)+increment
+       end do
+    else
+       do k=2,NPAR2_ARTH
+          arth_i(k)=arth_i(k-1)+increment
+       end do
+       temp=increment*NPAR2_ARTH
+       k=NPAR2_ARTH
+       do
+          if (k >= n) exit
+          k2=k+k
+          arth_i(k+1:min(k2,n))=temp+arth_i(1:min(k,n-k))
+          temp=temp+temp
+          k=k2
+       end do
+    end if
+
+  END FUNCTION arth_i
+
+END MODULE arth_m
Index: DZ6/trunk/libf/misc/assert_eq_m.F90
===================================================================
--- /LMDZ6/trunk/libf/misc/assert_eq_m.F90	(revision 5267)
+++ 	(revision )
@@ -1,70 +1,0 @@
-! $Id$
-MODULE assert_eq_m
-
-  implicit none
-
-  INTERFACE assert_eq
-     MODULE PROCEDURE assert_eq2,assert_eq3,assert_eq4,assert_eqn
-  END INTERFACE
-
-  private assert_eq2,assert_eq3,assert_eq4,assert_eqn
-
-CONTAINS
-
-  FUNCTION assert_eq2(n1,n2,string)
-    CHARACTER(LEN=*), INTENT(IN) :: string
-    INTEGER, INTENT(IN) :: n1,n2
-    INTEGER  assert_eq2
-    if (n1 == n2) then
-       assert_eq2=n1
-    else
-       write (*,*) 'nrerror: an assert_eq failed with this tag: ', &
-            string
-       print *, 'program terminated by assert_eq2'
-       stop 1
-    end if
-  END FUNCTION assert_eq2
-  !BL
-  FUNCTION assert_eq3(n1,n2,n3,string)
-    CHARACTER(LEN=*), INTENT(IN) :: string
-    INTEGER, INTENT(IN) :: n1,n2,n3
-    INTEGER  assert_eq3
-    if (n1 == n2 .and. n2 == n3) then
-       assert_eq3=n1
-    else
-       write (*,*) 'nrerror: an assert_eq failed with this tag: ', &
-            string
-       print *, 'program terminated by assert_eq3'
-       stop 1
-    end if
-  END FUNCTION assert_eq3
-  !BL
-  FUNCTION assert_eq4(n1,n2,n3,n4,string)
-    CHARACTER(LEN=*), INTENT(IN) :: string
-    INTEGER, INTENT(IN) :: n1,n2,n3,n4
-    INTEGER  assert_eq4
-    if (n1 == n2 .and. n2 == n3 .and. n3 == n4) then
-       assert_eq4=n1
-    else
-       write (*,*) 'nrerror: an assert_eq failed with this tag: ', &
-            string,n1,n2,n3,n4
-       print *, 'program terminated by assert_eq4'
-       stop 1
-    end if
-  END FUNCTION assert_eq4
-  !BL
-  FUNCTION assert_eqn(nn,string)
-    CHARACTER(LEN=*), INTENT(IN) :: string
-    INTEGER, DIMENSION(:), INTENT(IN) :: nn
-    INTEGER  assert_eqn
-    if (all(nn(2:) == nn(1))) then
-       assert_eqn=nn(1)
-    else
-       write (*,*) 'nrerror: an assert_eq failed with this tag: ', &
-            string
-       print *, 'program terminated by assert_eqn'
-       stop 1
-    end if
-  END FUNCTION assert_eqn
-
-END MODULE assert_eq_m
Index: /LMDZ6/trunk/libf/misc/assert_eq_m.f90
===================================================================
--- /LMDZ6/trunk/libf/misc/assert_eq_m.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/misc/assert_eq_m.f90	(revision 5268)
@@ -0,0 +1,70 @@
+! $Id$
+MODULE assert_eq_m
+
+  implicit none
+
+  INTERFACE assert_eq
+     MODULE PROCEDURE assert_eq2,assert_eq3,assert_eq4,assert_eqn
+  END INTERFACE
+
+  private assert_eq2,assert_eq3,assert_eq4,assert_eqn
+
+CONTAINS
+
+  FUNCTION assert_eq2(n1,n2,string)
+    CHARACTER(LEN=*), INTENT(IN) :: string
+    INTEGER, INTENT(IN) :: n1,n2
+    INTEGER  assert_eq2
+    if (n1 == n2) then
+       assert_eq2=n1
+    else
+       write (*,*) 'nrerror: an assert_eq failed with this tag: ', &
+            string
+       print *, 'program terminated by assert_eq2'
+       stop 1
+    end if
+  END FUNCTION assert_eq2
+  !BL
+  FUNCTION assert_eq3(n1,n2,n3,string)
+    CHARACTER(LEN=*), INTENT(IN) :: string
+    INTEGER, INTENT(IN) :: n1,n2,n3
+    INTEGER  assert_eq3
+    if (n1 == n2 .and. n2 == n3) then
+       assert_eq3=n1
+    else
+       write (*,*) 'nrerror: an assert_eq failed with this tag: ', &
+            string
+       print *, 'program terminated by assert_eq3'
+       stop 1
+    end if
+  END FUNCTION assert_eq3
+  !BL
+  FUNCTION assert_eq4(n1,n2,n3,n4,string)
+    CHARACTER(LEN=*), INTENT(IN) :: string
+    INTEGER, INTENT(IN) :: n1,n2,n3,n4
+    INTEGER  assert_eq4
+    if (n1 == n2 .and. n2 == n3 .and. n3 == n4) then
+       assert_eq4=n1
+    else
+       write (*,*) 'nrerror: an assert_eq failed with this tag: ', &
+            string,n1,n2,n3,n4
+       print *, 'program terminated by assert_eq4'
+       stop 1
+    end if
+  END FUNCTION assert_eq4
+  !BL
+  FUNCTION assert_eqn(nn,string)
+    CHARACTER(LEN=*), INTENT(IN) :: string
+    INTEGER, DIMENSION(:), INTENT(IN) :: nn
+    INTEGER  assert_eqn
+    if (all(nn(2:) == nn(1))) then
+       assert_eqn=nn(1)
+    else
+       write (*,*) 'nrerror: an assert_eq failed with this tag: ', &
+            string
+       print *, 'program terminated by assert_eqn'
+       stop 1
+    end if
+  END FUNCTION assert_eqn
+
+END MODULE assert_eq_m
Index: DZ6/trunk/libf/misc/assert_m.F90
===================================================================
--- /LMDZ6/trunk/libf/misc/assert_m.F90	(revision 5267)
+++ 	(revision )
@@ -1,69 +1,0 @@
-! $Id$
-MODULE assert_m
-
-  implicit none
-
-  INTERFACE assert
-     MODULE PROCEDURE assert1,assert2,assert3,assert4,assert_v
-  END INTERFACE
-
-  private assert1,assert2,assert3,assert4,assert_v
-
-CONTAINS
-
-  SUBROUTINE assert1(n1,string)
-    CHARACTER(LEN=*), INTENT(IN) :: string
-    LOGICAL, INTENT(IN) :: n1
-    if (.not. n1) then
-       write (*,*) 'nrerror: an assertion failed with this tag:', &
-            string
-       print *, 'program terminated by assert1'
-       stop 1
-    end if
-  END SUBROUTINE assert1
-  !BL
-  SUBROUTINE assert2(n1,n2,string)
-    CHARACTER(LEN=*), INTENT(IN) :: string
-    LOGICAL, INTENT(IN) :: n1,n2
-    if (.not. (n1 .and. n2)) then
-       write (*,*) 'nrerror: an assertion failed with this tag:', &
-            string
-       print *, 'program terminated by assert2'
-       stop 1
-    end if
-  END SUBROUTINE assert2
-  !BL
-  SUBROUTINE assert3(n1,n2,n3,string)
-    CHARACTER(LEN=*), INTENT(IN) :: string
-    LOGICAL, INTENT(IN) :: n1,n2,n3
-    if (.not. (n1 .and. n2 .and. n3)) then
-       write (*,*) 'nrerror: an assertion failed with this tag:', &
-            string
-       print *, 'program terminated by assert3'
-       stop 1
-    end if
-  END SUBROUTINE assert3
-  !BL
-  SUBROUTINE assert4(n1,n2,n3,n4,string)
-    CHARACTER(LEN=*), INTENT(IN) :: string
-    LOGICAL, INTENT(IN) :: n1,n2,n3,n4
-    if (.not. (n1 .and. n2 .and. n3 .and. n4)) then
-       write (*,*) 'nrerror: an assertion failed with this tag:', &
-            string
-       print *, 'program terminated by assert4'
-       stop 1
-    end if
-  END SUBROUTINE assert4
-  !BL
-  SUBROUTINE assert_v(n,string)
-    CHARACTER(LEN=*), INTENT(IN) :: string
-    LOGICAL, DIMENSION(:), INTENT(IN) :: n
-    if (.not. all(n)) then
-       write (*,*) 'nrerror: an assertion failed with this tag:', &
-            string
-       print *, 'program terminated by assert_v'
-       stop 1
-    end if
-  END SUBROUTINE assert_v
-
-END MODULE assert_m
Index: /LMDZ6/trunk/libf/misc/assert_m.f90
===================================================================
--- /LMDZ6/trunk/libf/misc/assert_m.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/misc/assert_m.f90	(revision 5268)
@@ -0,0 +1,69 @@
+! $Id$
+MODULE assert_m
+
+  implicit none
+
+  INTERFACE assert
+     MODULE PROCEDURE assert1,assert2,assert3,assert4,assert_v
+  END INTERFACE
+
+  private assert1,assert2,assert3,assert4,assert_v
+
+CONTAINS
+
+  SUBROUTINE assert1(n1,string)
+    CHARACTER(LEN=*), INTENT(IN) :: string
+    LOGICAL, INTENT(IN) :: n1
+    if (.not. n1) then
+       write (*,*) 'nrerror: an assertion failed with this tag:', &
+            string
+       print *, 'program terminated by assert1'
+       stop 1
+    end if
+  END SUBROUTINE assert1
+  !BL
+  SUBROUTINE assert2(n1,n2,string)
+    CHARACTER(LEN=*), INTENT(IN) :: string
+    LOGICAL, INTENT(IN) :: n1,n2
+    if (.not. (n1 .and. n2)) then
+       write (*,*) 'nrerror: an assertion failed with this tag:', &
+            string
+       print *, 'program terminated by assert2'
+       stop 1
+    end if
+  END SUBROUTINE assert2
+  !BL
+  SUBROUTINE assert3(n1,n2,n3,string)
+    CHARACTER(LEN=*), INTENT(IN) :: string
+    LOGICAL, INTENT(IN) :: n1,n2,n3
+    if (.not. (n1 .and. n2 .and. n3)) then
+       write (*,*) 'nrerror: an assertion failed with this tag:', &
+            string
+       print *, 'program terminated by assert3'
+       stop 1
+    end if
+  END SUBROUTINE assert3
+  !BL
+  SUBROUTINE assert4(n1,n2,n3,n4,string)
+    CHARACTER(LEN=*), INTENT(IN) :: string
+    LOGICAL, INTENT(IN) :: n1,n2,n3,n4
+    if (.not. (n1 .and. n2 .and. n3 .and. n4)) then
+       write (*,*) 'nrerror: an assertion failed with this tag:', &
+            string
+       print *, 'program terminated by assert4'
+       stop 1
+    end if
+  END SUBROUTINE assert4
+  !BL
+  SUBROUTINE assert_v(n,string)
+    CHARACTER(LEN=*), INTENT(IN) :: string
+    LOGICAL, DIMENSION(:), INTENT(IN) :: n
+    if (.not. all(n)) then
+       write (*,*) 'nrerror: an assertion failed with this tag:', &
+            string
+       print *, 'program terminated by assert_v'
+       stop 1
+    end if
+  END SUBROUTINE assert_v
+
+END MODULE assert_m
Index: DZ6/trunk/libf/misc/coefpoly_m.F90
===================================================================
--- /LMDZ6/trunk/libf/misc/coefpoly_m.F90	(revision 5267)
+++ 	(revision )
@@ -1,52 +1,0 @@
-module coefpoly_m
-
-  IMPLICIT NONE
-
-contains
-
-  SUBROUTINE coefpoly(xf1, xf2, xprim1, xprim2, xtild1, xtild2, a0, a1, a2, a3)
-
-    ! From LMDZ4/libf/dyn3d/coefpoly.F, version 1.1.1.1 2004/05/19 12:53:05
-
-    ! Author: P. Le Van
-
-    ! Calcul des coefficients a0, a1, a2, a3 du polynôme de degré 3 qui
-    ! satisfait aux 4 équations suivantes :
-
-    ! a0 + a1 * xtild1 + a2 * xtild1**2 + a3 * xtild1**3 = Xf1
-    ! a0 + a1 * xtild2 + a2 * xtild2**2 + a3 * xtild2**3 = Xf2
-    ! a1 + 2. * a2 * xtild1 + 3. * a3 * xtild1**2 = Xprim1
-    ! a1 + 2. * a2 * xtild2 + 3. * a3 * xtild2**2 = Xprim2
-
-    ! (passe par les points (Xf(it), xtild(it)) et (Xf(it + 1),
-    ! xtild(it + 1))
-
-    ! On en revient à resoudre un système de 4 équations à 4 inconnues
-    ! a0, a1, a2, a3.
-
-    use nrtype, only: k8
-
-    REAL(K8), intent(in):: xf1, xf2, xprim1, xprim2, xtild1, xtild2
-    REAL(K8), intent(out):: a0, a1, a2, a3
-
-    ! Local:
-    REAL(K8) xtil1car, xtil2car, derr, x1x2car
-
-    !------------------------------------------------------------
-
-    xtil1car = xtild1 * xtild1
-    xtil2car = xtild2 * xtild2
-
-    derr = 2. * (xf2-xf1)/(xtild1-xtild2)
-
-    x1x2car = (xtild1-xtild2) * (xtild1-xtild2)
-
-    a3 = (derr+xprim1+xprim2)/x1x2car
-    a2 = (xprim1-xprim2+3. * a3 * (xtil2car-xtil1car))/(2. * (xtild1-xtild2))
-
-    a1 = xprim1 - 3. * a3 * xtil1car - 2. * a2 * xtild1
-    a0 = xf1 - a3 * xtild1 * xtil1car - a2 * xtil1car - a1 * xtild1
-
-  END SUBROUTINE coefpoly
-
-end module coefpoly_m
Index: /LMDZ6/trunk/libf/misc/coefpoly_m.f90
===================================================================
--- /LMDZ6/trunk/libf/misc/coefpoly_m.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/misc/coefpoly_m.f90	(revision 5268)
@@ -0,0 +1,52 @@
+module coefpoly_m
+
+  IMPLICIT NONE
+
+contains
+
+  SUBROUTINE coefpoly(xf1, xf2, xprim1, xprim2, xtild1, xtild2, a0, a1, a2, a3)
+
+    ! From LMDZ4/libf/dyn3d/coefpoly.F, version 1.1.1.1 2004/05/19 12:53:05
+
+    ! Author: P. Le Van
+
+    ! Calcul des coefficients a0, a1, a2, a3 du polynôme de degré 3 qui
+    ! satisfait aux 4 équations suivantes :
+
+    ! a0 + a1 * xtild1 + a2 * xtild1**2 + a3 * xtild1**3 = Xf1
+    ! a0 + a1 * xtild2 + a2 * xtild2**2 + a3 * xtild2**3 = Xf2
+    ! a1 + 2. * a2 * xtild1 + 3. * a3 * xtild1**2 = Xprim1
+    ! a1 + 2. * a2 * xtild2 + 3. * a3 * xtild2**2 = Xprim2
+
+    ! (passe par les points (Xf(it), xtild(it)) et (Xf(it + 1),
+    ! xtild(it + 1))
+
+    ! On en revient à resoudre un système de 4 équations à 4 inconnues
+    ! a0, a1, a2, a3.
+
+    use nrtype, only: k8
+
+    REAL(K8), intent(in):: xf1, xf2, xprim1, xprim2, xtild1, xtild2
+    REAL(K8), intent(out):: a0, a1, a2, a3
+
+    ! Local:
+    REAL(K8) xtil1car, xtil2car, derr, x1x2car
+
+    !------------------------------------------------------------
+
+    xtil1car = xtild1 * xtild1
+    xtil2car = xtild2 * xtild2
+
+    derr = 2. * (xf2-xf1)/(xtild1-xtild2)
+
+    x1x2car = (xtild1-xtild2) * (xtild1-xtild2)
+
+    a3 = (derr+xprim1+xprim2)/x1x2car
+    a2 = (xprim1-xprim2+3. * a3 * (xtil2car-xtil1car))/(2. * (xtild1-xtild2))
+
+    a1 = xprim1 - 3. * a3 * xtil1car - 2. * a2 * xtild1
+    a0 = xf1 - a3 * xtild1 * xtil1car - a2 * xtil1car - a1 * xtild1
+
+  END SUBROUTINE coefpoly
+
+end module coefpoly_m
Index: DZ6/trunk/libf/misc/interpolation.F90
===================================================================
--- /LMDZ6/trunk/libf/misc/interpolation.F90	(revision 5267)
+++ 	(revision )
@@ -1,138 +1,0 @@
-! $Id$
-module interpolation
-
-  ! From Press et al., 1996, version 2.10a
-  ! B3 Interpolation and Extrapolation
-
-  IMPLICIT NONE 
-
-contains
-
-  pure FUNCTION locate(xx,x)
-
-    REAL, DIMENSION(:), INTENT(IN) :: xx
-    REAL, INTENT(IN) :: x
-    INTEGER  locate
-
-    ! Given an array xx(1:N), and given a value x, returns a value j,
-    ! between 0 and N, such that x is between xx(j) and xx(j + 1). xx
-    ! must be monotonic, either increasing or decreasing. j = 0 or j =
-    ! N is returned to indicate that x is out of range. This
-    ! procedure should not be called with a zero-sized array argument.
-    ! See notes.
-
-    INTEGER  n,jl,jm,ju
-    LOGICAL  ascnd
-
-    !----------------------------
-
-    n=size(xx)
-    ascnd = (xx(n) >= xx(1))
-    ! (True if ascending order of table, false otherwise.)
-    ! Initialize lower and upper limits:
-    jl=0
-    ju=n+1
-    do while (ju-jl > 1)
-       jm=(ju+jl)/2 ! Compute a midpoint,
-       if (ascnd .eqv. (x >= xx(jm))) then
-          jl=jm ! and replace either the lower limit
-       else
-          ju=jm ! or the upper limit, as appropriate.
-       end if
-    end do
-    ! {ju == jl + 1}
-
-    ! {(ascnd .and. xx(jl) <= x < xx(jl+1)) 
-    !  .neqv. 
-    !  (.not. ascnd .and. xx(jl+1) <= x < xx(jl))}
-
-    ! Then set the output, being careful with the endpoints:
-    if (x == xx(1)) then
-       locate=1
-    else if (x == xx(n)) then
-       locate=n-1
-    else
-       locate=jl
-    end if
-
-  END FUNCTION locate
-
-  !***************************
-
-  pure SUBROUTINE hunt(xx,x,jlo)
-
-    ! Given an array xx(1:N ), and given a value x, returns a value
-    ! jlo such that x is between xx(jlo) and xx(jlo+1). xx must be
-    ! monotonic, either increasing or decreasing. jlo = 0 or jlo = N is
-    ! returned to indicate that x is out of range. jlo on input is taken as
-    ! the initial guess for jlo on output.
-    ! Modified so that it uses the information "jlo = 0" on input.
-
-    INTEGER, INTENT(INOUT) :: jlo
-    REAL, INTENT(IN) :: x
-    REAL, DIMENSION(:), INTENT(IN) :: xx
-    INTEGER  n,inc,jhi,jm
-    LOGICAL  ascnd, hunt_up
-
-    !-----------------------------------------------------
-
-    n=size(xx)
-    ascnd = (xx(n) >= xx(1))
-    ! (True if ascending order of table, false otherwise.)
-    if (jlo < 0 .or. jlo > n) then
-       ! Input guess not useful. Go immediately to bisection.
-       jlo=0
-       jhi=n+1
-    else
-       inc=1 ! Set the hunting increment.
-       if (jlo == 0) then
-          hunt_up = .true.
-       else
-          hunt_up = x >= xx(jlo) .eqv. ascnd
-       end if
-       if (hunt_up) then ! Hunt up:
-          do
-             jhi=jlo+inc
-             if (jhi > n) then ! Done hunting, since off end of table.
-                jhi=n+1
-                exit
-             else
-                if (x < xx(jhi) .eqv. ascnd) exit
-                jlo=jhi ! Not done hunting,
-                inc=inc+inc ! so double the increment
-             end if
-          end do ! and try again.
-       else ! Hunt down:
-          jhi=jlo
-          do
-             jlo=jhi-inc
-             if (jlo < 1) then ! Done hunting, since off end of table.
-                jlo=0
-                exit
-             else
-                if (x >= xx(jlo) .eqv. ascnd) exit
-                jhi=jlo ! Not done hunting,
-                inc=inc+inc ! so double the increment
-             end if
-          end do ! and try again.
-       end if
-    end if ! Done hunting, value bracketed.
-
-    do ! Hunt is done, so begin the final bisection phase:
-       if (jhi-jlo <= 1) then
-          if (x == xx(n)) jlo=n-1
-          if (x == xx(1)) jlo=1
-          exit
-       else
-          jm=(jhi+jlo)/2
-          if (x >= xx(jm) .eqv. ascnd) then
-             jlo=jm
-          else
-             jhi=jm
-          end if
-       end if
-    end do
-
-  END SUBROUTINE hunt
-
-end module interpolation
Index: /LMDZ6/trunk/libf/misc/interpolation.f90
===================================================================
--- /LMDZ6/trunk/libf/misc/interpolation.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/misc/interpolation.f90	(revision 5268)
@@ -0,0 +1,138 @@
+! $Id$
+module interpolation
+
+  ! From Press et al., 1996, version 2.10a
+  ! B3 Interpolation and Extrapolation
+
+  IMPLICIT NONE 
+
+contains
+
+  pure FUNCTION locate(xx,x)
+
+    REAL, DIMENSION(:), INTENT(IN) :: xx
+    REAL, INTENT(IN) :: x
+    INTEGER  locate
+
+    ! Given an array xx(1:N), and given a value x, returns a value j,
+    ! between 0 and N, such that x is between xx(j) and xx(j + 1). xx
+    ! must be monotonic, either increasing or decreasing. j = 0 or j =
+    ! N is returned to indicate that x is out of range. This
+    ! procedure should not be called with a zero-sized array argument.
+    ! See notes.
+
+    INTEGER  n,jl,jm,ju
+    LOGICAL  ascnd
+
+    !----------------------------
+
+    n=size(xx)
+    ascnd = (xx(n) >= xx(1))
+    ! (True if ascending order of table, false otherwise.)
+    ! Initialize lower and upper limits:
+    jl=0
+    ju=n+1
+    do while (ju-jl > 1)
+       jm=(ju+jl)/2 ! Compute a midpoint,
+       if (ascnd .eqv. (x >= xx(jm))) then
+          jl=jm ! and replace either the lower limit
+       else
+          ju=jm ! or the upper limit, as appropriate.
+       end if
+    end do
+    ! {ju == jl + 1}
+
+    ! {(ascnd .and. xx(jl) <= x < xx(jl+1)) 
+    !  .neqv. 
+    !  (.not. ascnd .and. xx(jl+1) <= x < xx(jl))}
+
+    ! Then set the output, being careful with the endpoints:
+    if (x == xx(1)) then
+       locate=1
+    else if (x == xx(n)) then
+       locate=n-1
+    else
+       locate=jl
+    end if
+
+  END FUNCTION locate
+
+  !***************************
+
+  pure SUBROUTINE hunt(xx,x,jlo)
+
+    ! Given an array xx(1:N ), and given a value x, returns a value
+    ! jlo such that x is between xx(jlo) and xx(jlo+1). xx must be
+    ! monotonic, either increasing or decreasing. jlo = 0 or jlo = N is
+    ! returned to indicate that x is out of range. jlo on input is taken as
+    ! the initial guess for jlo on output.
+    ! Modified so that it uses the information "jlo = 0" on input.
+
+    INTEGER, INTENT(INOUT) :: jlo
+    REAL, INTENT(IN) :: x
+    REAL, DIMENSION(:), INTENT(IN) :: xx
+    INTEGER  n,inc,jhi,jm
+    LOGICAL  ascnd, hunt_up
+
+    !-----------------------------------------------------
+
+    n=size(xx)
+    ascnd = (xx(n) >= xx(1))
+    ! (True if ascending order of table, false otherwise.)
+    if (jlo < 0 .or. jlo > n) then
+       ! Input guess not useful. Go immediately to bisection.
+       jlo=0
+       jhi=n+1
+    else
+       inc=1 ! Set the hunting increment.
+       if (jlo == 0) then
+          hunt_up = .true.
+       else
+          hunt_up = x >= xx(jlo) .eqv. ascnd
+       end if
+       if (hunt_up) then ! Hunt up:
+          do
+             jhi=jlo+inc
+             if (jhi > n) then ! Done hunting, since off end of table.
+                jhi=n+1
+                exit
+             else
+                if (x < xx(jhi) .eqv. ascnd) exit
+                jlo=jhi ! Not done hunting,
+                inc=inc+inc ! so double the increment
+             end if
+          end do ! and try again.
+       else ! Hunt down:
+          jhi=jlo
+          do
+             jlo=jhi-inc
+             if (jlo < 1) then ! Done hunting, since off end of table.
+                jlo=0
+                exit
+             else
+                if (x >= xx(jlo) .eqv. ascnd) exit
+                jhi=jlo ! Not done hunting,
+                inc=inc+inc ! so double the increment
+             end if
+          end do ! and try again.
+       end if
+    end if ! Done hunting, value bracketed.
+
+    do ! Hunt is done, so begin the final bisection phase:
+       if (jhi-jlo <= 1) then
+          if (x == xx(n)) jlo=n-1
+          if (x == xx(1)) jlo=1
+          exit
+       else
+          jm=(jhi+jlo)/2
+          if (x >= xx(jm) .eqv. ascnd) then
+             jlo=jm
+          else
+             jhi=jm
+          end if
+       end if
+    end do
+
+  END SUBROUTINE hunt
+
+end module interpolation
Index: DZ6/trunk/libf/misc/iso_params_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/misc/iso_params_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,10 +1,0 @@
-MODULE iso_params_mod
-
-   REAL, PARAMETER :: tnat_H216O = 1.0000,    alpha_ideal_H216O = 1.000, &
-                      tnat_H217O = 40.000e-6, alpha_ideal_H217O = 1.003, &
-                      tnat_H218O = 2005.2e-6, alpha_ideal_H218O = 1.006, &
-                      tnat_HDO   = 155.76e-6, alpha_ideal_HDO   = 1.010, &
-                      tnat_HTO   = 0.0000,    alpha_ideal_HTO   = 1.000
-
-END MODULE iso_params_mod
-
Index: /LMDZ6/trunk/libf/misc/iso_params_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/misc/iso_params_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/misc/iso_params_mod.f90	(revision 5268)
@@ -0,0 +1,10 @@
+MODULE iso_params_mod
+
+   REAL, PARAMETER :: tnat_H216O = 1.0000,    alpha_ideal_H216O = 1.000, &
+                      tnat_H217O = 40.000e-6, alpha_ideal_H217O = 1.003, &
+                      tnat_H218O = 2005.2e-6, alpha_ideal_H218O = 1.006, &
+                      tnat_HDO   = 155.76e-6, alpha_ideal_HDO   = 1.010, &
+                      tnat_HTO   = 0.0000,    alpha_ideal_HTO   = 1.000
+
+END MODULE iso_params_mod
+
Index: DZ6/trunk/libf/misc/new_unit_m.F90
===================================================================
--- /LMDZ6/trunk/libf/misc/new_unit_m.F90	(revision 5267)
+++ 	(revision )
@@ -1,25 +1,0 @@
-module new_unit_m
-
-  implicit none
-
-contains
-
-  subroutine new_unit(unit)
-
-    integer, intent(out):: unit
-
-    ! Variables local to the procedure:
-    logical opened, exist
-
-    !------------------------------------------------------
-
-    unit = 0
-    do
-       inquire(unit=unit, opened=opened, exist=exist)
-       if (exist .and. .not. opened) exit
-       unit = unit + 1
-    end do
-
-  end subroutine new_unit
-
-end module new_unit_m
Index: /LMDZ6/trunk/libf/misc/new_unit_m.f90
===================================================================
--- /LMDZ6/trunk/libf/misc/new_unit_m.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/misc/new_unit_m.f90	(revision 5268)
@@ -0,0 +1,25 @@
+module new_unit_m
+
+  implicit none
+
+contains
+
+  subroutine new_unit(unit)
+
+    integer, intent(out):: unit
+
+    ! Variables local to the procedure:
+    logical opened, exist
+
+    !------------------------------------------------------
+
+    unit = 0
+    do
+       inquire(unit=unit, opened=opened, exist=exist)
+       if (exist .and. .not. opened) exit
+       unit = unit + 1
+    end do
+
+  end subroutine new_unit
+
+end module new_unit_m
Index: DZ6/trunk/libf/misc/nrtype.F90
===================================================================
--- /LMDZ6/trunk/libf/misc/nrtype.F90	(revision 5267)
+++ 	(revision )
@@ -1,22 +1,0 @@
-MODULE nrtype
-
-  implicit none
-
-  integer, parameter:: k8 = selected_real_kind(13)
-
-  ! Frequently used mathematical constants (with precision to spare):
-
-  REAL, PARAMETER :: PI=3.141592653589793238462643383279502884197
-  REAL, PARAMETER :: PIO2=1.57079632679489661923132169163975144209858
-  REAL, PARAMETER :: TWOPI=6.283185307179586476925286766559005768394
-  REAL, PARAMETER :: SQRT2=1.41421356237309504880168872420969807856967
-  REAL, PARAMETER :: EULER=0.5772156649015328606065120900824024310422
-
-  REAL(K8), PARAMETER:: &
-       PI_D = 3.141592653589793238462643383279502884197_k8
-  REAL(K8), PARAMETER:: &
-       PIO2_D=1.57079632679489661923132169163975144209858_k8
-  REAL(K8), PARAMETER:: &
-       TWOPI_D=6.283185307179586476925286766559005768394_k8
-
-END MODULE nrtype
Index: /LMDZ6/trunk/libf/misc/nrtype.f90
===================================================================
--- /LMDZ6/trunk/libf/misc/nrtype.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/misc/nrtype.f90	(revision 5268)
@@ -0,0 +1,22 @@
+MODULE nrtype
+
+  implicit none
+
+  integer, parameter:: k8 = selected_real_kind(13)
+
+  ! Frequently used mathematical constants (with precision to spare):
+
+  REAL, PARAMETER :: PI=3.141592653589793238462643383279502884197
+  REAL, PARAMETER :: PIO2=1.57079632679489661923132169163975144209858
+  REAL, PARAMETER :: TWOPI=6.283185307179586476925286766559005768394
+  REAL, PARAMETER :: SQRT2=1.41421356237309504880168872420969807856967
+  REAL, PARAMETER :: EULER=0.5772156649015328606065120900824024310422
+
+  REAL(K8), PARAMETER:: &
+       PI_D = 3.141592653589793238462643383279502884197_k8
+  REAL(K8), PARAMETER:: &
+       PIO2_D=1.57079632679489661923132169163975144209858_k8
+  REAL(K8), PARAMETER:: &
+       TWOPI_D=6.283185307179586476925286766559005768394_k8
+
+END MODULE nrtype
Index: DZ6/trunk/libf/misc/pchfe_95_m.F90
===================================================================
--- /LMDZ6/trunk/libf/misc/pchfe_95_m.F90	(revision 5267)
+++ 	(revision )
@@ -1,76 +1,0 @@
-module PCHFE_95_m
-
-  implicit none
-
-contains
-
-  SUBROUTINE PCHFE_95(X, F, D, SKIP, XE, FE, IERR)
-
-    ! PURPOSE  Evaluate a piecewise cubic Hermite function at an array of
-    !            points.  May be used by itself for Hermite interpolation,
-    !            or as an evaluator for PCHIM or PCHIC.
-    ! CATEGORY  E3
-    ! KEYWORDS  CUBIC HERMITE EVALUATION, HERMITE INTERPOLATION, PCHIP,
-    !             PIECEWISE CUBIC EVALUATION
-
-    !          PCHFE:  Piecewise Cubic Hermite Function Evaluator
-    ! Evaluates the cubic Hermite function defined by  X, F, D  at
-    ! the points  XE.
-
-    use assert_eq_m, only: assert_eq
-
-    REAL, intent(in):: X(:) ! real array of independent variable values
-    ! The elements of X must be strictly increasing.
-
-    REAL, intent(in):: F(:) ! real array of function values
-    ! F(I) is the value corresponding to X(I).
-
-    REAL, intent(in):: D(:) ! real array of derivative values
-    ! D(I) is the value corresponding to X(I).
-
-    LOGICAL, intent(inout):: SKIP 
-    ! request to skip checks for validity of "x"
-    ! If "skip" is false then "pchfe" will check that size(x) >= 2 and
-    ! "x" is in strictly ascending order.
-    ! Setting "skip" to true will save time in case these checks have
-    ! already been performed (say, in "PCHIM" or "PCHIC").
-    ! "SKIP" will be set to TRUE on normal return.
-
-    real, intent(in):: XE(:) ! points at which the function is to be evaluated
-    ! NOTES:
-    ! 1. The evaluation will be most efficient if the elements of XE
-    ! are increasing relative to X.
-    ! That is,   XE(J) .GE. X(I)
-    ! implies    XE(K) .GE. X(I),  all K.GE.J
-    ! 2. If any of the XE are outside the interval [X(1),X(N)], values
-    ! are extrapolated from the nearest extreme cubic, and a warning
-    ! error is returned.
-
-    real, intent(out):: FE(:) ! values of the cubic Hermite function
-    ! defined by X, F, D at the points XE
-
-    integer, intent(out):: IERR ! error flag
-    ! Normal return:
-    ! IERR = 0  no error
-    ! Warning error:
-    ! IERR > 0  means that extrapolation was performed at IERR points
-    ! "Recoverable" errors:
-    !              IERR = -1  if N < 2
-    !              IERR = -3  if the X-array is not strictly increasing
-    !              IERR = -4  if NE < 1
-    ! NOTE: The above errors are checked in the order listed, and
-    ! following arguments have **NOT** been validated.
-
-    ! Variables local to the procedure:
-
-    INTEGER  N, NE
-
-    !---------------------------------------
-
-    n = assert_eq(size(x), size(f), size(d), "PCHFE_95 n")
-    ne = assert_eq(size(xe), size(fe), "PCHFE_95 ne")
-    call PCHFE(N, X, F, D, 1, SKIP, NE, XE, FE, IERR)
-
-  end SUBROUTINE PCHFE_95
-
-end module PCHFE_95_m
Index: /LMDZ6/trunk/libf/misc/pchfe_95_m.f90
===================================================================
--- /LMDZ6/trunk/libf/misc/pchfe_95_m.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/misc/pchfe_95_m.f90	(revision 5268)
@@ -0,0 +1,76 @@
+module PCHFE_95_m
+
+  implicit none
+
+contains
+
+  SUBROUTINE PCHFE_95(X, F, D, SKIP, XE, FE, IERR)
+
+    ! PURPOSE  Evaluate a piecewise cubic Hermite function at an array of
+    !            points.  May be used by itself for Hermite interpolation,
+    !            or as an evaluator for PCHIM or PCHIC.
+    ! CATEGORY  E3
+    ! KEYWORDS  CUBIC HERMITE EVALUATION, HERMITE INTERPOLATION, PCHIP,
+    !             PIECEWISE CUBIC EVALUATION
+
+    !          PCHFE:  Piecewise Cubic Hermite Function Evaluator
+    ! Evaluates the cubic Hermite function defined by  X, F, D  at
+    ! the points  XE.
+
+    use assert_eq_m, only: assert_eq
+
+    REAL, intent(in):: X(:) ! real array of independent variable values
+    ! The elements of X must be strictly increasing.
+
+    REAL, intent(in):: F(:) ! real array of function values
+    ! F(I) is the value corresponding to X(I).
+
+    REAL, intent(in):: D(:) ! real array of derivative values
+    ! D(I) is the value corresponding to X(I).
+
+    LOGICAL, intent(inout):: SKIP 
+    ! request to skip checks for validity of "x"
+    ! If "skip" is false then "pchfe" will check that size(x) >= 2 and
+    ! "x" is in strictly ascending order.
+    ! Setting "skip" to true will save time in case these checks have
+    ! already been performed (say, in "PCHIM" or "PCHIC").
+    ! "SKIP" will be set to TRUE on normal return.
+
+    real, intent(in):: XE(:) ! points at which the function is to be evaluated
+    ! NOTES:
+    ! 1. The evaluation will be most efficient if the elements of XE
+    ! are increasing relative to X.
+    ! That is,   XE(J) .GE. X(I)
+    ! implies    XE(K) .GE. X(I),  all K.GE.J
+    ! 2. If any of the XE are outside the interval [X(1),X(N)], values
+    ! are extrapolated from the nearest extreme cubic, and a warning
+    ! error is returned.
+
+    real, intent(out):: FE(:) ! values of the cubic Hermite function
+    ! defined by X, F, D at the points XE
+
+    integer, intent(out):: IERR ! error flag
+    ! Normal return:
+    ! IERR = 0  no error
+    ! Warning error:
+    ! IERR > 0  means that extrapolation was performed at IERR points
+    ! "Recoverable" errors:
+    !              IERR = -1  if N < 2
+    !              IERR = -3  if the X-array is not strictly increasing
+    !              IERR = -4  if NE < 1
+    ! NOTE: The above errors are checked in the order listed, and
+    ! following arguments have **NOT** been validated.
+
+    ! Variables local to the procedure:
+
+    INTEGER  N, NE
+
+    !---------------------------------------
+
+    n = assert_eq(size(x), size(f), size(d), "PCHFE_95 n")
+    ne = assert_eq(size(xe), size(fe), "PCHFE_95 ne")
+    call PCHFE(N, X, F, D, 1, SKIP, NE, XE, FE, IERR)
+
+  end SUBROUTINE PCHFE_95
+
+end module PCHFE_95_m
Index: DZ6/trunk/libf/misc/pchsp_95_m.F90
===================================================================
--- /LMDZ6/trunk/libf/misc/pchsp_95_m.F90	(revision 5267)
+++ 	(revision )
@@ -1,116 +1,0 @@
-module pchsp_95_m
-
-  implicit none
-
-contains
-
-  function pchsp_95(x, f, ibeg, iend, vc_beg, vc_end)
-
-    ! PURPOSE: Set derivatives needed to determine the Hermite
-    ! representation of the cubic spline interpolant to given data,
-    ! with specified boundary conditions.
-
-    ! Part of the "pchip" package.
-
-    ! CATEGORY: E1A
-
-    ! KEYWORDS: cubic hermite interpolation, piecewise cubic
-    ! interpolation, spline interpolation
-
-    ! DESCRIPTION: "pchsp" stands for "Piecewise Cubic Hermite Spline"
-    ! Computes the Hermite representation of the cubic spline
-    ! interpolant to the data given in X and F satisfying the boundary
-    ! conditions specified by Ibeg, iend, vc_beg and VC_end.
-
-    ! The resulting piecewise cubic Hermite function may be evaluated
-    ! by "pchfe" or "pchfd".
-
-    ! NOTE: This is a modified version of C. de Boor's cubic spline
-    ! routine "cubspl".
-
-    ! REFERENCE: Carl de Boor, A Practical Guide to Splines, Springer,
-    ! 2001, pages 43-47
-
-    use assert_eq_m, only: assert_eq
-
-    real, intent(in):: x(:)
-    ! independent variable values
-    ! The elements of X must be strictly increasing:
-    !                X(I-1) < X(I),  I = 2...N.
-    !           (Error return if not.)
-    ! (error if size(x) < 2)
-
-    real, intent(in):: f(:)
-    !     dependent variable values to be interpolated
-    !  F(I) is value corresponding to X(I).
-
-    INTEGER, intent(in):: ibeg
-    !     desired boundary condition at beginning of data
-
-    !        IBEG = 0  to set pchsp_95(1) so that the third derivative is con-
-    !              tinuous at X(2).  This is the "not a knot" condition
-    !              provided by de Boor's cubic spline routine CUBSPL.
-    !              This is the default boundary condition.
-    !        IBEG = 1  if first derivative at X(1) is given in VC_BEG.
-    !        IBEG = 2  if second derivative at X(1) is given in VC_BEG.
-    !        IBEG = 3  to use the 3-point difference formula for pchsp_95(1).
-    !              (Reverts to the default boundary condition if size(x) < 3 .)
-    !        IBEG = 4  to use the 4-point difference formula for pchsp_95(1).
-    !              (Reverts to the default boundary condition if size(x) < 4 .)
-
-    !          NOTES:
-    !           1. An error return is taken if IBEG is out of range.
-    !           2. For the "natural" boundary condition, use IBEG=2 and
-    !              VC_BEG=0.
-
-    INTEGER, intent(in):: iend
-    !           IC(2) = IEND, desired condition at end of data.
-    !  IEND may take on the same values as IBEG, but applied to
-    !  derivative at X(N). In case IEND = 1 or 2, The value is given in VC_END.
-
-    !          NOTES:
-    !           1. An error return is taken if IEND is out of range.
-    !           2. For the "natural" boundary condition, use IEND=2 and
-    !              VC_END=0.
-
-    REAL, intent(in), optional:: vc_beg
-    ! desired boundary value, as indicated above.
-    !           VC_BEG need be set only if IBEG = 1 or 2 .
-
-    REAL, intent(in), optional:: vc_end
-    ! desired boundary value, as indicated above.
-    !           VC_END need be set only if Iend = 1 or 2 .
-
-    real pchsp_95(size(x))
-    ! derivative values at the data points
-    !           These values will determine the cubic spline interpolant
-    !           with the requested boundary conditions.
-    !           The value corresponding to X(I) is stored in
-    !                PCHSP_95(I),  I=1...N.
-
-    ! LOCAL VARIABLES:
-    real wk(2, size(x)) ! real array of working storage
-    INTEGER n ! number of data points
-    integer ierr, ic(2)
-    real vc(2)
-
-    !-------------------------------------------------------------------
-
-    n = assert_eq(size(x), size(f), "pchsp_95 n")
-    if ((ibeg == 1 .or. ibeg == 2) .and. .not. present(vc_beg)) then
-       print *, "vc_beg required for IBEG = 1 or 2"
-       stop 1
-    end if
-    if ((iend == 1 .or. iend == 2) .and. .not. present(vc_end)) then
-       print *, "vc_end required for IEND = 1 or 2"
-       stop 1
-    end if
-    ic = (/ibeg, iend/)
-    if (present(vc_beg)) vc(1) = vc_beg
-    if (present(vc_end)) vc(2) = vc_end
-    call PCHSP(IC, VC, N, X, F, pchsp_95, 1, WK, size(WK), IERR)
-    if (ierr /= 0) stop 1
-
-  END function pchsp_95
-
-end module pchsp_95_m
Index: /LMDZ6/trunk/libf/misc/pchsp_95_m.f90
===================================================================
--- /LMDZ6/trunk/libf/misc/pchsp_95_m.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/misc/pchsp_95_m.f90	(revision 5268)
@@ -0,0 +1,116 @@
+module pchsp_95_m
+
+  implicit none
+
+contains
+
+  function pchsp_95(x, f, ibeg, iend, vc_beg, vc_end)
+
+    ! PURPOSE: Set derivatives needed to determine the Hermite
+    ! representation of the cubic spline interpolant to given data,
+    ! with specified boundary conditions.
+
+    ! Part of the "pchip" package.
+
+    ! CATEGORY: E1A
+
+    ! KEYWORDS: cubic hermite interpolation, piecewise cubic
+    ! interpolation, spline interpolation
+
+    ! DESCRIPTION: "pchsp" stands for "Piecewise Cubic Hermite Spline"
+    ! Computes the Hermite representation of the cubic spline
+    ! interpolant to the data given in X and F satisfying the boundary
+    ! conditions specified by Ibeg, iend, vc_beg and VC_end.
+
+    ! The resulting piecewise cubic Hermite function may be evaluated
+    ! by "pchfe" or "pchfd".
+
+    ! NOTE: This is a modified version of C. de Boor's cubic spline
+    ! routine "cubspl".
+
+    ! REFERENCE: Carl de Boor, A Practical Guide to Splines, Springer,
+    ! 2001, pages 43-47
+
+    use assert_eq_m, only: assert_eq
+
+    real, intent(in):: x(:)
+    ! independent variable values
+    ! The elements of X must be strictly increasing:
+    !                X(I-1) < X(I),  I = 2...N.
+    !           (Error return if not.)
+    ! (error if size(x) < 2)
+
+    real, intent(in):: f(:)
+    !     dependent variable values to be interpolated
+    !  F(I) is value corresponding to X(I).
+
+    INTEGER, intent(in):: ibeg
+    !     desired boundary condition at beginning of data
+
+    !        IBEG = 0  to set pchsp_95(1) so that the third derivative is con-
+    !              tinuous at X(2).  This is the "not a knot" condition
+    !              provided by de Boor's cubic spline routine CUBSPL.
+    !              This is the default boundary condition.
+    !        IBEG = 1  if first derivative at X(1) is given in VC_BEG.
+    !        IBEG = 2  if second derivative at X(1) is given in VC_BEG.
+    !        IBEG = 3  to use the 3-point difference formula for pchsp_95(1).
+    !              (Reverts to the default boundary condition if size(x) < 3 .)
+    !        IBEG = 4  to use the 4-point difference formula for pchsp_95(1).
+    !              (Reverts to the default boundary condition if size(x) < 4 .)
+
+    !          NOTES:
+    !           1. An error return is taken if IBEG is out of range.
+    !           2. For the "natural" boundary condition, use IBEG=2 and
+    !              VC_BEG=0.
+
+    INTEGER, intent(in):: iend
+    !           IC(2) = IEND, desired condition at end of data.
+    !  IEND may take on the same values as IBEG, but applied to
+    !  derivative at X(N). In case IEND = 1 or 2, The value is given in VC_END.
+
+    !          NOTES:
+    !           1. An error return is taken if IEND is out of range.
+    !           2. For the "natural" boundary condition, use IEND=2 and
+    !              VC_END=0.
+
+    REAL, intent(in), optional:: vc_beg
+    ! desired boundary value, as indicated above.
+    !           VC_BEG need be set only if IBEG = 1 or 2 .
+
+    REAL, intent(in), optional:: vc_end
+    ! desired boundary value, as indicated above.
+    !           VC_END need be set only if Iend = 1 or 2 .
+
+    real pchsp_95(size(x))
+    ! derivative values at the data points
+    !           These values will determine the cubic spline interpolant
+    !           with the requested boundary conditions.
+    !           The value corresponding to X(I) is stored in
+    !                PCHSP_95(I),  I=1...N.
+
+    ! LOCAL VARIABLES:
+    real wk(2, size(x)) ! real array of working storage
+    INTEGER n ! number of data points
+    integer ierr, ic(2)
+    real vc(2)
+
+    !-------------------------------------------------------------------
+
+    n = assert_eq(size(x), size(f), "pchsp_95 n")
+    if ((ibeg == 1 .or. ibeg == 2) .and. .not. present(vc_beg)) then
+       print *, "vc_beg required for IBEG = 1 or 2"
+       stop 1
+    end if
+    if ((iend == 1 .or. iend == 2) .and. .not. present(vc_end)) then
+       print *, "vc_end required for IEND = 1 or 2"
+       stop 1
+    end if
+    ic = (/ibeg, iend/)
+    if (present(vc_beg)) vc(1) = vc_beg
+    if (present(vc_end)) vc(2) = vc_end
+    call PCHSP(IC, VC, N, X, F, pchsp_95, 1, WK, size(WK), IERR)
+    if (ierr /= 0) stop 1
+
+  END function pchsp_95
+
+end module pchsp_95_m
Index: DZ6/trunk/libf/misc/pres2lev_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/misc/pres2lev_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,79 +1,0 @@
-! $Id: pres2lev.F 1179 2009-06-11 14:18:47Z jghattas $
-!
-MODULE pres2lev_mod
-
-CONTAINS 
-
-!******************************************************
-SUBROUTINE pres2lev(varo,varn,lmo,lmn,po,pn,ni,nj,ok_invertp)
-!
-! interpolation lineaire pour passer
-! a une nouvelle discretisation verticale pour
-! les variables de GCM
-! Francois Forget (01/1995)
-! MOdif remy roca 12/97 pour passer de pres2sig
-! Modif F.Codron 07/08 po en 3D
-!**********************************************************
-
-  IMPLICIT NONE
-
-!   Declarations:
-! ==============
-!
-!  ARGUMENTS
-!  """""""""
-  LOGICAL, INTENT(IN) :: ok_invertp
-  INTEGER, INTENT(IN) :: lmo ! dimensions ancienne couches
-  INTEGER, INTENT(IN) :: lmn ! dimensions nouvelle couches
-  
-  INTEGER, INTENT(IN) :: ni,nj ! nombre de point horizontal
-  REAL, INTENT(IN) :: po(ni*nj,lmo) ! niveau de pression ancienne grille
-  REAL, INTENT(IN) :: pn(ni*nj,lmn) ! niveau de pression nouvelle grille
-
-  REAL, INTENT(IN)  :: varo(ni*nj,lmo) ! var dans l'ancienne grille
-  REAL, INTENT(OUT) :: varn(ni*nj,lmn) ! var dans la nouvelle grille
-
-  REAL :: zvaro(ni*nj,lmo),zpo(ni*nj,lmo)
-
-! Autres variables
-! """"""""""""""""
-  INTEGER ::  ln ,lo, k
-  REAL    :: coef
-
-
-! Inversion de l'ordre des niveaux verticaux
-  IF (ok_invertp) THEN
-    DO lo=1,lmo
-      DO k=1,ni*nj
-        zpo(k,lo)=po(k,lmo+1-lo)
-        zvaro(k,lo)=varo(k,lmo+1-lo)
-      ENDDO
-    ENDDO
-  ELSE
-    DO lo=1,lmo
-      DO k=1,ni*nj
-        zpo(k,lo)=po(k,lo)
-        zvaro(k,lo)=varo(k,lo)
-      ENDDO
-    ENDDO
-  ENDIF 
-
-  DO ln=1,lmn
-    DO lo=1,lmo-1
-      DO k=1,ni*nj
-        IF (pn(k,ln) >= zpo(k,1) ) THEN
-          varn(k,ln) = zvaro(k,1)
-        ELSE IF (pn(k,ln) <= zpo(k,lmo)) THEN
-          varn(k,ln) = zvaro(k,lmo)
-        ELSE IF ( pn(k,ln) <= zpo(k,lo) .AND. pn(k,ln) > zpo(k,lo+1) ) THEN
-          coef = (pn(k,ln)-zpo(k,lo)) / (zpo(k,lo+1)-zpo(k,lo))
-          varn(k,ln) = zvaro(k,lo) + coef*(zvaro(k,lo+1)-zvaro(k,lo))
-        ENDIF
-         
-      ENDDO  
-    ENDDO
-  ENDDO                
-
-END SUBROUTINE pres2lev    
-
-END MODULE pres2lev_mod
Index: /LMDZ6/trunk/libf/misc/pres2lev_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/misc/pres2lev_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/misc/pres2lev_mod.f90	(revision 5268)
@@ -0,0 +1,79 @@
+! $Id: pres2lev.F 1179 2009-06-11 14:18:47Z jghattas $
+!
+MODULE pres2lev_mod
+
+CONTAINS 
+
+!******************************************************
+SUBROUTINE pres2lev(varo,varn,lmo,lmn,po,pn,ni,nj,ok_invertp)
+!
+! interpolation lineaire pour passer
+! a une nouvelle discretisation verticale pour
+! les variables de GCM
+! Francois Forget (01/1995)
+! MOdif remy roca 12/97 pour passer de pres2sig
+! Modif F.Codron 07/08 po en 3D
+!**********************************************************
+
+  IMPLICIT NONE
+
+!   Declarations:
+! ==============
+!
+!  ARGUMENTS
+!  """""""""
+  LOGICAL, INTENT(IN) :: ok_invertp
+  INTEGER, INTENT(IN) :: lmo ! dimensions ancienne couches
+  INTEGER, INTENT(IN) :: lmn ! dimensions nouvelle couches
+  
+  INTEGER, INTENT(IN) :: ni,nj ! nombre de point horizontal
+  REAL, INTENT(IN) :: po(ni*nj,lmo) ! niveau de pression ancienne grille
+  REAL, INTENT(IN) :: pn(ni*nj,lmn) ! niveau de pression nouvelle grille
+
+  REAL, INTENT(IN)  :: varo(ni*nj,lmo) ! var dans l'ancienne grille
+  REAL, INTENT(OUT) :: varn(ni*nj,lmn) ! var dans la nouvelle grille
+
+  REAL :: zvaro(ni*nj,lmo),zpo(ni*nj,lmo)
+
+! Autres variables
+! """"""""""""""""
+  INTEGER ::  ln ,lo, k
+  REAL    :: coef
+
+
+! Inversion de l'ordre des niveaux verticaux
+  IF (ok_invertp) THEN
+    DO lo=1,lmo
+      DO k=1,ni*nj
+        zpo(k,lo)=po(k,lmo+1-lo)
+        zvaro(k,lo)=varo(k,lmo+1-lo)
+      ENDDO
+    ENDDO
+  ELSE
+    DO lo=1,lmo
+      DO k=1,ni*nj
+        zpo(k,lo)=po(k,lo)
+        zvaro(k,lo)=varo(k,lo)
+      ENDDO
+    ENDDO
+  ENDIF 
+
+  DO ln=1,lmn
+    DO lo=1,lmo-1
+      DO k=1,ni*nj
+        IF (pn(k,ln) >= zpo(k,1) ) THEN
+          varn(k,ln) = zvaro(k,1)
+        ELSE IF (pn(k,ln) <= zpo(k,lmo)) THEN
+          varn(k,ln) = zvaro(k,lmo)
+        ELSE IF ( pn(k,ln) <= zpo(k,lo) .AND. pn(k,ln) > zpo(k,lo+1) ) THEN
+          coef = (pn(k,ln)-zpo(k,lo)) / (zpo(k,lo+1)-zpo(k,lo))
+          varn(k,ln) = zvaro(k,lo) + coef*(zvaro(k,lo+1)-zvaro(k,lo))
+        ENDIF
+         
+      ENDDO  
+    ENDDO
+  ENDDO                
+
+END SUBROUTINE pres2lev    
+
+END MODULE pres2lev_mod
Index: DZ6/trunk/libf/misc/regr1_step_av_m.F90
===================================================================
--- /LMDZ6/trunk/libf/misc/regr1_step_av_m.F90	(revision 5267)
+++ 	(revision )
@@ -1,268 +1,0 @@
-! $Id: regr1_step_av_m.F90 3065 2017-11-10 13:25:09Z fairhead $
-module regr1_step_av_m
-
-  ! Author: Lionel GUEZ
-
-  implicit none
-
-  interface regr1_step_av
-
-     ! Each procedure regrids a step function by averaging it.
-     ! The regridding operation is done on the first dimension of the
-     ! input array.
-     ! Source grid contains edges of steps.
-     ! Target grid contains positions of cell edges.
-     ! The target grid should be included in the source grid: no
-     ! extrapolation is allowed.
-     ! The difference between the procedures is the rank of the first argument.
-
-     module procedure regr11_step_av, regr12_step_av, regr13_step_av, &
-          regr14_step_av
-  end interface
-
-  private
-  public regr1_step_av
-
-contains
-
-  function regr11_step_av(vs, xs, xt) result(vt)
-
-    ! "vs" has rank 1.
-
-    use assert_eq_m, only: assert_eq
-    use assert_m, only: assert
-    use interpolation, only: locate
-
-    real, intent(in):: vs(:) ! values of steps on the source grid
-    ! (Step "is" is between "xs(is)" and "xs(is + 1)".)
-
-    real, intent(in):: xs(:)
-    ! (edges of of steps on the source grid, in strictly increasing order)
-
-    real, intent(in):: xt(:)
-    ! (edges of cells of the target grid, in strictly increasing order)
-
-    real vt(size(xt) - 1) ! average values on the target grid
-    ! (Cell "it" is between "xt(it)" and "xt(it + 1)".)
-
-    ! Variables local to the procedure:
-    integer is, it, ns, nt
-    real left_edge
-
-    !---------------------------------------------
-
-    ns = assert_eq(size(vs), size(xs) - 1, "regr11_step_av ns")
-    nt = size(xt) - 1
-    ! Quick check on sort order:
-    call assert(xs(1) < xs(2), "regr11_step_av xs bad order")
-    call assert(xt(1) < xt(2), "regr11_step_av xt bad order")
-
-    call assert(xs(1) <= xt(1) .and. xt(nt + 1) <= xs(ns + 1), &
-         "regr11_step_av extrapolation")
-
-    is = locate(xs, xt(1)) ! 1 <= is <= ns, because we forbid extrapolation
-    do it = 1, nt
-       ! 1 <= is <= ns
-       ! xs(is) <= xt(it) < xs(is + 1)
-       ! Compute "vt(it)":
-       left_edge = xt(it)
-       vt(it) = 0.
-       do while (xs(is + 1) < xt(it + 1))
-          ! 1 <= is <= ns - 1
-          vt(it) = vt(it) + (xs(is + 1) - left_edge) * vs(is)
-          is = is + 1
-          left_edge = xs(is)
-       end do
-       ! 1 <= is <= ns
-       vt(it) = (vt(it) + (xt(it + 1) - left_edge) * vs(is)) &
-            / (xt(it + 1) - xt(it))
-       if (xs(is + 1) == xt(it + 1)) is = is + 1
-       ! 1 <= is <= ns .or. it == nt
-    end do
-
-  end function regr11_step_av
-
-  !********************************************
-
-  function regr12_step_av(vs, xs, xt) result(vt)
-
-    ! "vs" has rank 2.
-
-    use assert_eq_m, only: assert_eq
-    use assert_m, only: assert
-    use interpolation, only: locate
-
-    real, intent(in):: vs(:, :) ! values of steps on the source grid
-    ! (Step "is" is between "xs(is)" and "xs(is + 1)".)
-
-    real, intent(in):: xs(:)
-    ! (edges of steps on the source grid, in strictly increasing order)
-
-    real, intent(in):: xt(:)
-    ! (edges of cells of the target grid, in strictly increasing order)
-
-    real vt(size(xt) - 1, size(vs, 2)) ! average values on the target grid
-    ! (Cell "it" is between "xt(it)" and "xt(it + 1)".)
-
-    ! Variables local to the procedure:
-    integer is, it, ns, nt
-    real left_edge
-
-    !---------------------------------------------
-
-    ns = assert_eq(size(vs, 1), size(xs) - 1, "regr12_step_av ns")
-    nt = size(xt) - 1
-
-    ! Quick check on sort order:
-    call assert(xs(1) < xs(2), "regr12_step_av xs bad order")
-    call assert(xt(1) < xt(2), "regr12_step_av xt bad order")
-
-    call assert(xs(1) <= xt(1) .and. xt(nt + 1) <= xs(ns + 1), &
-         "regr12_step_av extrapolation")
-
-    is = locate(xs, xt(1)) ! 1 <= is <= ns, because we forbid extrapolation
-    do it = 1, nt
-       ! 1 <= is <= ns
-       ! xs(is) <= xt(it) < xs(is + 1)
-       ! Compute "vt(it, :)":
-       left_edge = xt(it)
-       vt(it, :) = 0.
-       do while (xs(is + 1) < xt(it + 1))
-          ! 1 <= is <= ns - 1
-          vt(it, :) = vt(it, :) + (xs(is + 1) - left_edge) * vs(is, :)
-          is = is + 1
-          left_edge = xs(is)
-       end do
-       ! 1 <= is <= ns
-       vt(it, :) = (vt(it, :) + (xt(it + 1) - left_edge) * vs(is, :)) &
-            / (xt(it + 1) - xt(it))
-       if (xs(is + 1) == xt(it + 1)) is = is + 1
-       ! 1 <= is <= ns .or. it == nt
-    end do
-
-  end function regr12_step_av
-
-  !********************************************
-
-  function regr13_step_av(vs, xs, xt) result(vt)
-
-    ! "vs" has rank 3.
-
-    use assert_eq_m, only: assert_eq
-    use assert_m, only: assert
-    use interpolation, only: locate
-
-    real, intent(in):: vs(:, :, :) ! values of steps on the source grid
-    ! (Step "is" is between "xs(is)" and "xs(is + 1)".)
-
-    real, intent(in):: xs(:)
-    ! (edges of steps on the source grid, in strictly increasing order)
-
-    real, intent(in):: xt(:)
-    ! (edges of cells of the target grid, in strictly increasing order)
-
-    real vt(size(xt) - 1, size(vs, 2), size(vs, 3)) 
-    ! (average values on the target grid)
-    ! (Cell "it" is between "xt(it)" and "xt(it + 1)".)
-
-    ! Variables local to the procedure:
-    integer is, it, ns, nt
-    real left_edge
-
-    !---------------------------------------------
-
-    ns = assert_eq(size(vs, 1), size(xs) - 1, "regr13_step_av ns")
-    nt = size(xt) - 1
-
-    ! Quick check on sort order:
-    call assert(xs(1) < xs(2), "regr13_step_av xs bad order")
-    call assert(xt(1) < xt(2), "regr13_step_av xt bad order")
-
-    call assert(xs(1) <= xt(1) .and. xt(nt + 1) <= xs(ns + 1), &
-         "regr13_step_av extrapolation")
-
-    is = locate(xs, xt(1)) ! 1 <= is <= ns, because we forbid extrapolation
-    do it = 1, nt
-       ! 1 <= is <= ns
-       ! xs(is) <= xt(it) < xs(is + 1)
-       ! Compute "vt(it, :, :)":
-       left_edge = xt(it)
-       vt(it, :, :) = 0.
-       do while (xs(is + 1) < xt(it + 1))
-          ! 1 <= is <= ns - 1
-          vt(it, :, :) = vt(it, :, :) + (xs(is + 1) - left_edge) * vs(is, :, :)
-          is = is + 1
-          left_edge = xs(is)
-       end do
-       ! 1 <= is <= ns
-       vt(it, :, :) = (vt(it, :, :) &
-            + (xt(it + 1) - left_edge) * vs(is, :, :)) / (xt(it + 1) - xt(it))
-       if (xs(is + 1) == xt(it + 1)) is = is + 1
-       ! 1 <= is <= ns .or. it == nt
-    end do
-
-  end function regr13_step_av
-
-  !********************************************
-
-  function regr14_step_av(vs, xs, xt) result(vt)
-
-    ! "vs" has rank 4.
-
-    use assert_eq_m, only: assert_eq
-    use assert_m, only: assert
-    use interpolation, only: locate
-
-    real, intent(in):: vs(:, :, :, :) ! values of steps on the source grid
-    ! (Step "is" is between "xs(is)" and "xs(is + 1)".)
-
-    real, intent(in):: xs(:)
-    ! (edges of steps on the source grid, in strictly increasing order)
-
-    real, intent(in):: xt(:)
-    ! (edges of cells of the target grid, in strictly increasing order)
-
-    real vt(size(xt) - 1, size(vs, 2), size(vs, 3), size(vs, 4))
-    ! (average values on the target grid)
-    ! (Cell "it" is between "xt(it)" and "xt(it + 1)".)
-
-    ! Variables local to the procedure:
-    integer is, it, ns, nt
-    real left_edge
-
-    !---------------------------------------------
-
-    ns = assert_eq(size(vs, 1), size(xs) - 1, "regr14_step_av ns")
-    nt = size(xt) - 1
-
-    ! Quick check on sort order:
-    call assert(xs(1) < xs(2), "regr14_step_av xs bad order")
-    call assert(xt(1) < xt(2), "regr14_step_av xt bad order")
-
-    call assert(xs(1) <= xt(1) .and. xt(nt + 1) <= xs(ns + 1), &
-         "regr14_step_av extrapolation")
-
-    is = locate(xs, xt(1)) ! 1 <= is <= ns, because we forbid extrapolation
-    do it = 1, nt
-       ! 1 <= is <= ns
-       ! xs(is) <= xt(it) < xs(is + 1)
-       ! Compute "vt(it, :, :, :)":
-       left_edge = xt(it)
-       vt(it, :, :, :) = 0.
-       do while (xs(is + 1) < xt(it + 1))
-          ! 1 <= is <= ns - 1
-          vt(it, :, :, :) = vt(it, :, :, :) + (xs(is + 1) - left_edge) &
-               * vs(is, :, :, :)
-          is = is + 1
-          left_edge = xs(is)
-       end do
-       ! 1 <= is <= ns
-       vt(it, :, :, :) = (vt(it, :, :, :) + (xt(it + 1) - left_edge) &
-            * vs(is, :, :, :)) / (xt(it + 1) - xt(it))
-       if (xs(is + 1) == xt(it + 1)) is = is + 1
-       ! 1 <= is <= ns .or. it == nt
-    end do
-
-  end function regr14_step_av
-
-end module regr1_step_av_m
Index: /LMDZ6/trunk/libf/misc/regr1_step_av_m.f90
===================================================================
--- /LMDZ6/trunk/libf/misc/regr1_step_av_m.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/misc/regr1_step_av_m.f90	(revision 5268)
@@ -0,0 +1,268 @@
+! $Id: regr1_step_av_m.F90 3065 2017-11-10 13:25:09Z fairhead $
+module regr1_step_av_m
+
+  ! Author: Lionel GUEZ
+
+  implicit none
+
+  interface regr1_step_av
+
+     ! Each procedure regrids a step function by averaging it.
+     ! The regridding operation is done on the first dimension of the
+     ! input array.
+     ! Source grid contains edges of steps.
+     ! Target grid contains positions of cell edges.
+     ! The target grid should be included in the source grid: no
+     ! extrapolation is allowed.
+     ! The difference between the procedures is the rank of the first argument.
+
+     module procedure regr11_step_av, regr12_step_av, regr13_step_av, &
+          regr14_step_av
+  end interface
+
+  private
+  public regr1_step_av
+
+contains
+
+  function regr11_step_av(vs, xs, xt) result(vt)
+
+    ! "vs" has rank 1.
+
+    use assert_eq_m, only: assert_eq
+    use assert_m, only: assert
+    use interpolation, only: locate
+
+    real, intent(in):: vs(:) ! values of steps on the source grid
+    ! (Step "is" is between "xs(is)" and "xs(is + 1)".)
+
+    real, intent(in):: xs(:)
+    ! (edges of of steps on the source grid, in strictly increasing order)
+
+    real, intent(in):: xt(:)
+    ! (edges of cells of the target grid, in strictly increasing order)
+
+    real vt(size(xt) - 1) ! average values on the target grid
+    ! (Cell "it" is between "xt(it)" and "xt(it + 1)".)
+
+    ! Variables local to the procedure:
+    integer is, it, ns, nt
+    real left_edge
+
+    !---------------------------------------------
+
+    ns = assert_eq(size(vs), size(xs) - 1, "regr11_step_av ns")
+    nt = size(xt) - 1
+    ! Quick check on sort order:
+    call assert(xs(1) < xs(2), "regr11_step_av xs bad order")
+    call assert(xt(1) < xt(2), "regr11_step_av xt bad order")
+
+    call assert(xs(1) <= xt(1) .and. xt(nt + 1) <= xs(ns + 1), &
+         "regr11_step_av extrapolation")
+
+    is = locate(xs, xt(1)) ! 1 <= is <= ns, because we forbid extrapolation
+    do it = 1, nt
+       ! 1 <= is <= ns
+       ! xs(is) <= xt(it) < xs(is + 1)
+       ! Compute "vt(it)":
+       left_edge = xt(it)
+       vt(it) = 0.
+       do while (xs(is + 1) < xt(it + 1))
+          ! 1 <= is <= ns - 1
+          vt(it) = vt(it) + (xs(is + 1) - left_edge) * vs(is)
+          is = is + 1
+          left_edge = xs(is)
+       end do
+       ! 1 <= is <= ns
+       vt(it) = (vt(it) + (xt(it + 1) - left_edge) * vs(is)) &
+            / (xt(it + 1) - xt(it))
+       if (xs(is + 1) == xt(it + 1)) is = is + 1
+       ! 1 <= is <= ns .or. it == nt
+    end do
+
+  end function regr11_step_av
+
+  !********************************************
+
+  function regr12_step_av(vs, xs, xt) result(vt)
+
+    ! "vs" has rank 2.
+
+    use assert_eq_m, only: assert_eq
+    use assert_m, only: assert
+    use interpolation, only: locate
+
+    real, intent(in):: vs(:, :) ! values of steps on the source grid
+    ! (Step "is" is between "xs(is)" and "xs(is + 1)".)
+
+    real, intent(in):: xs(:)
+    ! (edges of steps on the source grid, in strictly increasing order)
+
+    real, intent(in):: xt(:)
+    ! (edges of cells of the target grid, in strictly increasing order)
+
+    real vt(size(xt) - 1, size(vs, 2)) ! average values on the target grid
+    ! (Cell "it" is between "xt(it)" and "xt(it + 1)".)
+
+    ! Variables local to the procedure:
+    integer is, it, ns, nt
+    real left_edge
+
+    !---------------------------------------------
+
+    ns = assert_eq(size(vs, 1), size(xs) - 1, "regr12_step_av ns")
+    nt = size(xt) - 1
+
+    ! Quick check on sort order:
+    call assert(xs(1) < xs(2), "regr12_step_av xs bad order")
+    call assert(xt(1) < xt(2), "regr12_step_av xt bad order")
+
+    call assert(xs(1) <= xt(1) .and. xt(nt + 1) <= xs(ns + 1), &
+         "regr12_step_av extrapolation")
+
+    is = locate(xs, xt(1)) ! 1 <= is <= ns, because we forbid extrapolation
+    do it = 1, nt
+       ! 1 <= is <= ns
+       ! xs(is) <= xt(it) < xs(is + 1)
+       ! Compute "vt(it, :)":
+       left_edge = xt(it)
+       vt(it, :) = 0.
+       do while (xs(is + 1) < xt(it + 1))
+          ! 1 <= is <= ns - 1
+          vt(it, :) = vt(it, :) + (xs(is + 1) - left_edge) * vs(is, :)
+          is = is + 1
+          left_edge = xs(is)
+       end do
+       ! 1 <= is <= ns
+       vt(it, :) = (vt(it, :) + (xt(it + 1) - left_edge) * vs(is, :)) &
+            / (xt(it + 1) - xt(it))
+       if (xs(is + 1) == xt(it + 1)) is = is + 1
+       ! 1 <= is <= ns .or. it == nt
+    end do
+
+  end function regr12_step_av
+
+  !********************************************
+
+  function regr13_step_av(vs, xs, xt) result(vt)
+
+    ! "vs" has rank 3.
+
+    use assert_eq_m, only: assert_eq
+    use assert_m, only: assert
+    use interpolation, only: locate
+
+    real, intent(in):: vs(:, :, :) ! values of steps on the source grid
+    ! (Step "is" is between "xs(is)" and "xs(is + 1)".)
+
+    real, intent(in):: xs(:)
+    ! (edges of steps on the source grid, in strictly increasing order)
+
+    real, intent(in):: xt(:)
+    ! (edges of cells of the target grid, in strictly increasing order)
+
+    real vt(size(xt) - 1, size(vs, 2), size(vs, 3)) 
+    ! (average values on the target grid)
+    ! (Cell "it" is between "xt(it)" and "xt(it + 1)".)
+
+    ! Variables local to the procedure:
+    integer is, it, ns, nt
+    real left_edge
+
+    !---------------------------------------------
+
+    ns = assert_eq(size(vs, 1), size(xs) - 1, "regr13_step_av ns")
+    nt = size(xt) - 1
+
+    ! Quick check on sort order:
+    call assert(xs(1) < xs(2), "regr13_step_av xs bad order")
+    call assert(xt(1) < xt(2), "regr13_step_av xt bad order")
+
+    call assert(xs(1) <= xt(1) .and. xt(nt + 1) <= xs(ns + 1), &
+         "regr13_step_av extrapolation")
+
+    is = locate(xs, xt(1)) ! 1 <= is <= ns, because we forbid extrapolation
+    do it = 1, nt
+       ! 1 <= is <= ns
+       ! xs(is) <= xt(it) < xs(is + 1)
+       ! Compute "vt(it, :, :)":
+       left_edge = xt(it)
+       vt(it, :, :) = 0.
+       do while (xs(is + 1) < xt(it + 1))
+          ! 1 <= is <= ns - 1
+          vt(it, :, :) = vt(it, :, :) + (xs(is + 1) - left_edge) * vs(is, :, :)
+          is = is + 1
+          left_edge = xs(is)
+       end do
+       ! 1 <= is <= ns
+       vt(it, :, :) = (vt(it, :, :) &
+            + (xt(it + 1) - left_edge) * vs(is, :, :)) / (xt(it + 1) - xt(it))
+       if (xs(is + 1) == xt(it + 1)) is = is + 1
+       ! 1 <= is <= ns .or. it == nt
+    end do
+
+  end function regr13_step_av
+
+  !********************************************
+
+  function regr14_step_av(vs, xs, xt) result(vt)
+
+    ! "vs" has rank 4.
+
+    use assert_eq_m, only: assert_eq
+    use assert_m, only: assert
+    use interpolation, only: locate
+
+    real, intent(in):: vs(:, :, :, :) ! values of steps on the source grid
+    ! (Step "is" is between "xs(is)" and "xs(is + 1)".)
+
+    real, intent(in):: xs(:)
+    ! (edges of steps on the source grid, in strictly increasing order)
+
+    real, intent(in):: xt(:)
+    ! (edges of cells of the target grid, in strictly increasing order)
+
+    real vt(size(xt) - 1, size(vs, 2), size(vs, 3), size(vs, 4))
+    ! (average values on the target grid)
+    ! (Cell "it" is between "xt(it)" and "xt(it + 1)".)
+
+    ! Variables local to the procedure:
+    integer is, it, ns, nt
+    real left_edge
+
+    !---------------------------------------------
+
+    ns = assert_eq(size(vs, 1), size(xs) - 1, "regr14_step_av ns")
+    nt = size(xt) - 1
+
+    ! Quick check on sort order:
+    call assert(xs(1) < xs(2), "regr14_step_av xs bad order")
+    call assert(xt(1) < xt(2), "regr14_step_av xt bad order")
+
+    call assert(xs(1) <= xt(1) .and. xt(nt + 1) <= xs(ns + 1), &
+         "regr14_step_av extrapolation")
+
+    is = locate(xs, xt(1)) ! 1 <= is <= ns, because we forbid extrapolation
+    do it = 1, nt
+       ! 1 <= is <= ns
+       ! xs(is) <= xt(it) < xs(is + 1)
+       ! Compute "vt(it, :, :, :)":
+       left_edge = xt(it)
+       vt(it, :, :, :) = 0.
+       do while (xs(is + 1) < xt(it + 1))
+          ! 1 <= is <= ns - 1
+          vt(it, :, :, :) = vt(it, :, :, :) + (xs(is + 1) - left_edge) &
+               * vs(is, :, :, :)
+          is = is + 1
+          left_edge = xs(is)
+       end do
+       ! 1 <= is <= ns
+       vt(it, :, :, :) = (vt(it, :, :, :) + (xt(it + 1) - left_edge) &
+            * vs(is, :, :, :)) / (xt(it + 1) - xt(it))
+       if (xs(is + 1) == xt(it + 1)) is = is + 1
+       ! 1 <= is <= ns .or. it == nt
+    end do
+
+  end function regr14_step_av
+
+end module regr1_step_av_m
Index: DZ6/trunk/libf/misc/regr_conserv_m.F90
===================================================================
--- /LMDZ6/trunk/libf/misc/regr_conserv_m.F90	(revision 5267)
+++ 	(revision )
@@ -1,388 +1,0 @@
-MODULE regr_conserv_m
-
-  USE assert_eq_m,   ONLY: assert_eq
-  USE assert_m,      ONLY: assert
-  USE interpolation, ONLY: locate
-
-  IMPLICIT NONE
-
-! Purpose: Each procedure regrids a piecewise linear function (not necessarily
-!          continuous) by averaging it. This is a conservative regridding.
-!          The regridding operation is done along dimension "ix" of the input
-!          field "vs". Input are positions of cell edges.
-! Remarks:
-!   * The target grid should be included in the source grid:
-!     no extrapolation is allowed.
-!   * Field on target grid "vt" has same rank, slopes and averages as "vs".
-!   * If optional argument "slope" is not given, 0 is assumed for slopes.
-!     Then the regridding is first order instead of second.
-!   * "vs" and "vt" have the same dimensions except Nr. ix (ns for vs, nt for vt)
-
-! Argument                         Type         Description
-!-------------------------------------------------------------------------------
-!  INTEGER, INTENT(IN)  :: ix      Scalar       dimension regridded <=rank(vs)
-!  REAL,    INTENT(IN)  :: vs(*)   Rank>=1      averages in source grid cells
-!  REAL,    INTENT(IN)  :: xs(:)   Vector(ns+1) edges of source grid, asc. order
-!  REAL,    INTENT(IN)  :: xt(:)   Vector(nt+1) edges of target grid, asc. order
-!  REAL,    INTENT(OUT) :: vt(*)   Rank>=1      regridded field
-! [REAL,    INTENT(IN)  :: slope]  Rank>=1      slopes in source grid cells
-
-  INTERFACE regr_conserv
-    ! The procedures differ only from the rank of the input/output fields.
-    MODULE PROCEDURE regr1_conserv, regr2_conserv, regr3_conserv, &
-                     regr4_conserv, regr5_conserv
-  END INTERFACE
-
-  PRIVATE
-  PUBLIC :: regr_conserv
-
-CONTAINS
-
-!-------------------------------------------------------------------------------
-!
-SUBROUTINE regr1_conserv(ix, vs, xs, xt, vt, slope)
-!
-!-------------------------------------------------------------------------------
-! Arguments:
-  INTEGER,        INTENT(IN)  :: ix
-  REAL,           INTENT(IN)  :: vs(:)
-  REAL,           INTENT(IN)  :: xs(:), xt(:)
-  REAL,           INTENT(OUT) :: vt(:)
-  REAL, OPTIONAL, INTENT(IN)  :: slope(:)
-!-------------------------------------------------------------------------------
-! Local variables:
-  INTEGER :: is, it, ns, nt
-  REAL    :: co, idt
-  LOGICAL :: lslope
-!-------------------------------------------------------------------------------
-  lslope=PRESENT(slope)
-  CALL check_size(ix,SHAPE(vs),SHAPE(vt),xs,xt,ns,nt)
-  is=locate(xs,xt(1))                    !--- 1<= is <= ns (no extrapolation)
-  vt(:)=0.
-  DO it=1, nt; idt=1./(xt(it+1)-xt(it))
-    IF(xt(it+1)<=xs(is+1)) THEN          !--- xs(is)<=xt(it)<=xt(it+1)<=xs(is+1)
-      CALL mean_lin(xt(it),xt(it+1))
-    ELSE
-      CALL mean_lin(xt(it),xs(is+1)); is=is+1
-      DO WHILE(xs(is+1)<xt(it+1))        !--- 1<=is<=ns-1
-      CALL mean_lin(xs(is),xs(is+1)); is=is+1
-      END DO
-      CALL mean_lin(xs(is),xt(it+1))     !--- 1<=is<=ns
-    END IF
-    IF(xs(is+1)==xt(it+1)) is=is+1       !--- 1<=is<=ns .OR. it==nt
-  END DO
-
-CONTAINS
-
-!-------------------------------------------------------------------------------
-SUBROUTINE mean_lin(a,b)  ! mean [a,b] of the linear function in [xs(is),xs(is+1)]
-!-------------------------------------------------------------------------------
-! Arguments:
-  REAL, INTENT(IN)    :: a, b
-!-------------------------------------------------------------------------------
-  IF(lslope.AND.(a/=xs(is).OR.b/=xs(is+1))) THEN; co=0.
-    IF(a==xt(it  )) co=co+xt(it  )-xs(is  )
-    IF(b==xt(it+1)) co=co+xt(it+1)-xs(is+1)
-    vt(it) = vt(it)+idt*(b-a)*(vs(is)+co*slope(is)/2.)
-  ELSE
-    vt(it) = vt(it)+idt*(b-a)* vs(is)
-  END IF
-
-END SUBROUTINE mean_lin
-!-------------------------------------------------------------------------------
-
-END SUBROUTINE regr1_conserv
-!
-!-------------------------------------------------------------------------------
-
-
-!-------------------------------------------------------------------------------
-!
-SUBROUTINE regr2_conserv(ix, vs, xs, xt, vt, slope)
-!
-!-------------------------------------------------------------------------------
-! Arguments:
-  INTEGER,        INTENT(IN)  :: ix
-  REAL,           INTENT(IN)  :: vs(:,:)
-  REAL,           INTENT(IN)  :: xs(:), xt(:)
-  REAL,           INTENT(OUT) :: vt(:,:)
-  REAL, OPTIONAL, INTENT(IN)  :: slope(:,:)
-!-------------------------------------------------------------------------------
-! Local variables:
-  INTEGER :: is, it, ns, nt
-  REAL    :: co, idt
-  LOGICAL :: lslope
-!-------------------------------------------------------------------------------
-  lslope=PRESENT(slope)
-  CALL check_size(ix,SHAPE(vs),SHAPE(vt),xs,xt,ns,nt)
-  is=locate(xs,xt(1)) ! 1 <= is <= ns, because we forbid extrapolation
-  vt(:,:)=0.
-  DO it=1, nt; idt=1./(xt(it+1)-xt(it))
-    IF(xt(it+1)<=xs(is+1)) THEN          !--- xs(is)<=xt(it)<=xt(it+1)<=xs(is+1)
-      CALL mean_lin(xt(it),xt(it+1))
-    ELSE
-      CALL mean_lin(xt(it),xs(is+1)); is=is+1
-      DO WHILE(xs(is+1)<xt(it+1))        !--- 1<=is<=ns-1
-      CALL mean_lin(xs(is),xs(is+1)); is=is+1
-      END DO
-      CALL mean_lin(xs(is),xt(it+1))     !--- 1<=is<=ns
-    END IF
-    IF(xs(is+1)==xt(it+1)) is=is+1       !--- 1<=is<=ns .OR. it==nt
-  END DO
-
-CONTAINS
-
-!-------------------------------------------------------------------------------
-SUBROUTINE mean_lin(a,b)  ! mean [a,b] of the linear function in [xs(is),xs(is+1)]
-!-------------------------------------------------------------------------------
-! Arguments:
-  REAL, INTENT(IN)    :: a, b
-!-------------------------------------------------------------------------------
-  IF(lslope.AND.(a/=xs(is).OR.b/=xs(is+1))) THEN; co=0.
-    IF(a==xt(it  )) co=co+xt(it  )-xs(is  )
-    IF(b==xt(it+1)) co=co+xt(it+1)-xs(is+1)
-    IF(ix==1) vt(it,:) = vt(it,:)+idt*(b-a)*(vs(is,:)+co*slope(is,:)/2.)
-    IF(ix==2) vt(:,it) = vt(:,it)+idt*(b-a)*(vs(:,is)+co*slope(:,is)/2.)
-  ELSE
-    IF(ix==1) vt(it,:) = vt(it,:)+idt*(b-a)* vs(is,:)
-    IF(ix==2) vt(:,it) = vt(:,it)+idt*(b-a)* vs(:,is)
-  END IF
-
-END SUBROUTINE mean_lin
-!-------------------------------------------------------------------------------
-
-END SUBROUTINE regr2_conserv
-!
-!-------------------------------------------------------------------------------
-
-
-!-------------------------------------------------------------------------------
-!
-SUBROUTINE regr3_conserv(ix, vs, xs, xt, vt, slope)
-!
-!-------------------------------------------------------------------------------
-! Arguments:
-  INTEGER,        INTENT(IN)  :: ix
-  REAL,           INTENT(IN)  :: vs(:,:,:)
-  REAL,           INTENT(IN)  :: xs(:), xt(:)
-  REAL,           INTENT(OUT) :: vt(:,:,:)
-  REAL, OPTIONAL, INTENT(IN)  :: slope(:,:,:)
-!-------------------------------------------------------------------------------
-! Local variables:
-  INTEGER :: is, it, ns, nt
-  REAL    :: co, idt
-  LOGICAL :: lslope
-!-------------------------------------------------------------------------------
-  lslope=PRESENT(slope)
-  CALL check_size(ix,SHAPE(vs),SHAPE(vt),xs,xt,ns,nt)
-  is=locate(xs,xt(1)) ! 1 <= is <= ns, because we forbid extrapolation
-  vt(:,:,:)=0.
-  DO it=1, nt; idt=1./(xt(it+1)-xt(it))
-    IF(xt(it+1)<=xs(is+1)) THEN          !--- xs(is)<=xt(it)<=xt(it+1)<=xs(is+1)
-      CALL mean_lin(xt(it),xt(it+1))
-    ELSE
-      CALL mean_lin(xt(it),xs(is+1)); is=is+1
-      DO WHILE(xs(is+1)<xt(it+1))        !--- 1<=is<=ns-1
-      CALL mean_lin(xs(is),xs(is+1)); is=is+1
-      END DO
-      CALL mean_lin(xs(is),xt(it+1))     !--- 1<=is<=ns
-    END IF
-    IF(xs(is+1)==xt(it+1)) is=is+1       !--- 1<=is<=ns .OR. it==nt
-  END DO
-
-CONTAINS
-
-!-------------------------------------------------------------------------------
-SUBROUTINE mean_lin(a,b)  ! mean [a,b] of the linear function in [xs(is),xs(is+1)]
-!-------------------------------------------------------------------------------
-! Arguments:
-  REAL, INTENT(IN)    :: a, b
-!-------------------------------------------------------------------------------
-  IF(lslope.AND.(a/=xs(is).OR.b/=xs(is+1))) THEN; co=0.
-    IF(a==xt(it  )) co=co+xt(it  )-xs(is  )
-    IF(b==xt(it+1)) co=co+xt(it+1)-xs(is+1)
-    IF(ix==1) vt(it,:,:) = vt(it,:,:)+idt*(b-a)*(vs(is,:,:)+co*slope(is,:,:)/2.)
-    IF(ix==2) vt(:,it,:) = vt(:,it,:)+idt*(b-a)*(vs(:,is,:)+co*slope(:,is,:)/2.)
-    IF(ix==3) vt(:,:,it) = vt(:,:,it)+idt*(b-a)*(vs(:,:,is)+co*slope(:,:,is)/2.)
-  ELSE
-    IF(ix==1) vt(it,:,:) = vt(it,:,:)+idt*(b-a)* vs(is,:,:)
-    IF(ix==2) vt(:,it,:) = vt(:,it,:)+idt*(b-a)* vs(:,is,:)
-    IF(ix==3) vt(:,:,it) = vt(:,:,it)+idt*(b-a)* vs(:,:,is)
-  END IF
-
-END SUBROUTINE mean_lin
-!-------------------------------------------------------------------------------
-
-END SUBROUTINE regr3_conserv
-!
-!-------------------------------------------------------------------------------
-
-
-!-------------------------------------------------------------------------------
-!
-SUBROUTINE regr4_conserv(ix, vs, xs, xt, vt, slope)
-!
-!-------------------------------------------------------------------------------
-! Arguments:
-  INTEGER,        INTENT(IN)  :: ix
-  REAL,           INTENT(IN)  :: vs(:,:,:,:)
-  REAL,           INTENT(IN)  :: xs(:), xt(:)
-  REAL,           INTENT(OUT) :: vt(:,:,:,:)
-  REAL, OPTIONAL, INTENT(IN)  :: slope(:,:,:,:)
-!-------------------------------------------------------------------------------
-! Local variables:
-  INTEGER :: is, it, ns, nt
-  REAL    :: co, idt
-  LOGICAL :: lslope
-!-------------------------------------------------------------------------------
-  lslope=PRESENT(slope)
-  CALL check_size(ix,SHAPE(vs),SHAPE(vt),xs,xt,ns,nt)
-  is=locate(xs,xt(1)) ! 1 <= is <= ns, because we forbid extrapolation
-  vt(:,:,:,:)=0.
-  DO it=1, nt; idt=1./(xt(it+1)-xt(it))
-    IF(xt(it+1)<=xs(is+1)) THEN          !--- xs(is)<=xt(it)<=xt(it+1)<=xs(is+1)
-      CALL mean_lin(xt(it),xt(it+1))
-    ELSE
-      CALL mean_lin(xt(it),xs(is+1)); is=is+1
-      DO WHILE(xs(is+1)<xt(it+1))        !--- 1<=is<=ns-1
-      CALL mean_lin(xs(is),xs(is+1)); is=is+1
-      END DO
-      CALL mean_lin(xs(is),xt(it+1))     !--- 1<=is<=ns
-    END IF
-    IF(xs(is+1)==xt(it+1)) is=is+1       !--- 1<=is<=ns .OR. it==nt
-  END DO
-
-CONTAINS
-
-!-------------------------------------------------------------------------------
-SUBROUTINE mean_lin(a,b)  ! mean [a,b] of the linear function in [xs(is),xs(is+1)]
-!-------------------------------------------------------------------------------
-! Arguments:
-  REAL, INTENT(IN) :: a, b
-!-------------------------------------------------------------------------------
-  IF(lslope.AND.(a/=xs(is).OR.b/=xs(is+1))) THEN; co=0.
-    IF(a==xt(it  )) co=co+xt(it  )-xs(is  )
-    IF(b==xt(it+1)) co=co+xt(it+1)-xs(is+1)
-    IF(ix==1) vt(it,:,:,:) = vt(it,:,:,:)+idt*(b-a)*(vs(is,:,:,:)+co*slope(is,:,:,:)/2.)
-    IF(ix==2) vt(:,it,:,:) = vt(:,it,:,:)+idt*(b-a)*(vs(:,is,:,:)+co*slope(:,is,:,:)/2.)
-    IF(ix==3) vt(:,:,it,:) = vt(:,:,it,:)+idt*(b-a)*(vs(:,:,is,:)+co*slope(:,:,is,:)/2.)
-    IF(ix==4) vt(:,:,:,it) = vt(:,:,:,it)+idt*(b-a)*(vs(:,:,:,is)+co*slope(:,:,:,is)/2.)
-  ELSE
-    IF(ix==1) vt(it,:,:,:) = vt(it,:,:,:)+idt*(b-a)* vs(is,:,:,:)
-    IF(ix==2) vt(:,it,:,:) = vt(:,it,:,:)+idt*(b-a)* vs(:,is,:,:)
-    IF(ix==3) vt(:,:,it,:) = vt(:,:,it,:)+idt*(b-a)* vs(:,:,is,:)
-    IF(ix==4) vt(:,:,:,it) = vt(:,:,:,it)+idt*(b-a)* vs(:,:,:,is)
-  END IF
-
-END SUBROUTINE mean_lin
-!-------------------------------------------------------------------------------
-
-END SUBROUTINE regr4_conserv
-!
-!-------------------------------------------------------------------------------
-
-
-!-------------------------------------------------------------------------------
-!
-SUBROUTINE regr5_conserv(ix, vs, xs, xt, vt, slope)
-!
-!-------------------------------------------------------------------------------
-! Arguments:
-  INTEGER,        INTENT(IN)  :: ix
-  REAL,           INTENT(IN)  :: vs(:,:,:,:,:)
-  REAL,           INTENT(IN)  :: xs(:), xt(:)
-  REAL,           INTENT(OUT) :: vt(:,:,:,:,:)
-  REAL, OPTIONAL, INTENT(IN)  :: slope(:,:,:,:,:)
-!-------------------------------------------------------------------------------
-! Local variables:
-  INTEGER :: is, it, ns, nt
-  REAL    :: co, idt
-  LOGICAL :: lslope
-!-------------------------------------------------------------------------------
-  lslope=PRESENT(slope)
-  CALL check_size(ix,SHAPE(vs),SHAPE(vt),xs,xt,ns,nt)
-  is=locate(xs,xt(1)) ! 1 <= is <= ns, because we forbid extrapolation
-  vt(:,:,:,:,:)=0.
-  DO it=1, nt; idt=1./(xt(it+1)-xt(it))
-    IF(xt(it+1)<=xs(is+1)) THEN          !--- xs(is)<=xt(it)<=xt(it+1)<=xs(is+1)
-      CALL mean_lin(xt(it),xt(it+1))
-    ELSE
-      CALL mean_lin(xt(it),xs(is+1)); is=is+1
-      DO WHILE(xs(is+1)<xt(it+1))        !--- 1<=is<=ns-1
-      CALL mean_lin(xs(is),xs(is+1)); is=is+1
-      END DO
-      CALL mean_lin(xs(is),xt(it+1))     !--- 1<=is<=ns
-    END IF
-    IF(xs(is+1)==xt(it+1)) is=is+1     !--- 1<=is<=ns .OR. it==nt
-  END DO
-
-CONTAINS
-
-!-------------------------------------------------------------------------------
-SUBROUTINE mean_lin(a,b)  ! mean [a,b] of the linear function in [xs(is),xs(is+1)]
-!-------------------------------------------------------------------------------
-! Arguments:
-  REAL, INTENT(IN) :: a, b
-!-------------------------------------------------------------------------------
-  IF(lslope.AND.(a/=xs(is).OR.b/=xs(is+1))) THEN; co=0.
-    IF(a==xt(it  )) co=co+xt(it  )-xs(is  )
-    IF(b==xt(it+1)) co=co+xt(it+1)-xs(is+1)
-    IF(ix==1) vt(it,:,:,:,:) = vt(it,:,:,:,:)+idt*(b-a)*(vs(is,:,:,:,:)+co*slope(is,:,:,:,:)/2.)
-    IF(ix==2) vt(:,it,:,:,:) = vt(:,it,:,:,:)+idt*(b-a)*(vs(:,is,:,:,:)+co*slope(:,is,:,:,:)/2.)
-    IF(ix==3) vt(:,:,it,:,:) = vt(:,:,it,:,:)+idt*(b-a)*(vs(:,:,is,:,:)+co*slope(:,:,is,:,:)/2.)
-    IF(ix==4) vt(:,:,:,it,:) = vt(:,:,:,it,:)+idt*(b-a)*(vs(:,:,:,is,:)+co*slope(:,:,:,is,:)/2.)
-    IF(ix==5) vt(:,:,:,:,it) = vt(:,:,:,:,it)+idt*(b-a)*(vs(:,:,:,:,is)+co*slope(:,:,:,:,is)/2.)
-  ELSE
-    IF(ix==1) vt(it,:,:,:,:) = vt(it,:,:,:,:)+idt*(b-a)* vs(is,:,:,:,:)
-    IF(ix==2) vt(:,it,:,:,:) = vt(:,it,:,:,:)+idt*(b-a)* vs(:,is,:,:,:)
-    IF(ix==3) vt(:,:,it,:,:) = vt(:,:,it,:,:)+idt*(b-a)* vs(:,:,is,:,:)
-    IF(ix==4) vt(:,:,:,it,:) = vt(:,:,:,it,:)+idt*(b-a)* vs(:,:,:,is,:)
-    IF(ix==5) vt(:,:,:,:,it) = vt(:,:,:,:,it)+idt*(b-a)* vs(:,:,:,:,is)
-  END IF
-
-END SUBROUTINE mean_lin
-!-------------------------------------------------------------------------------
-
-END SUBROUTINE regr5_conserv
-!
-!-------------------------------------------------------------------------------
-
-
-!-------------------------------------------------------------------------------
-!
-SUBROUTINE check_size(ix,svs,svt,xs,xt,ns,nt)
-!
-!-------------------------------------------------------------------------------
-! Arguments:
-  INTEGER, INTENT(IN)  :: ix, svs(:), svt(:)
-  REAL,    INTENT(IN)  :: xs(:), xt(:)
-  INTEGER, INTENT(OUT) :: ns,    nt
-!-------------------------------------------------------------------------------
-! Local variables:
-  INTEGER :: rk, is, ii, n
-  CHARACTER(LEN=80) :: sub, msg
-!-------------------------------------------------------------------------------
-  WRITE(sub,'(a,2i0,a)')"regr",SIZE(svs),ix,"_conserv"
-  rk=assert_eq(SIZE(svs),SIZE(svt),TRIM(sub)//': inconsistent ranks')
-  WRITE(msg,'(a,2(i0,a))')TRIM(sub)//": ix (",ix,") exceeds field rank (",rk,")"
-  CALL assert(ix>=1.AND.ix<=rk,msg)
-  ii=0
-  DO is=1,rk; IF(is==ix) CYCLE
-    WRITE(msg,'(a,i0)')TRIM(sub)//" n",is
-    n=assert_eq(svs(is),svt(is),msg)
-    ii=ii+1
-  END DO
-  ns=assert_eq(svs(ix),SIZE(xs)-1,TRIM(sub)//" ns")
-  nt=assert_eq(svt(ix),SIZE(xt)-1,TRIM(sub)//" nt")
-
-  !--- Quick check on sort order:
-  CALL assert(xs(1)<xs(2), TRIM(sub)//": xs bad order")
-  CALL assert(xt(1)<xt(2), TRIM(sub)//": xt bad order")
-  CALL assert(xs(1)<=xt(1).AND.xt(nt+1)<=xs(ns+1), TRIM(sub)//": extrapolation")
-
-END SUBROUTINE check_size
-!
-!-------------------------------------------------------------------------------
-
-
-END MODULE regr_conserv_m
Index: /LMDZ6/trunk/libf/misc/regr_conserv_m.f90
===================================================================
--- /LMDZ6/trunk/libf/misc/regr_conserv_m.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/misc/regr_conserv_m.f90	(revision 5268)
@@ -0,0 +1,388 @@
+MODULE regr_conserv_m
+
+  USE assert_eq_m,   ONLY: assert_eq
+  USE assert_m,      ONLY: assert
+  USE interpolation, ONLY: locate
+
+  IMPLICIT NONE
+
+! Purpose: Each procedure regrids a piecewise linear function (not necessarily
+!          continuous) by averaging it. This is a conservative regridding.
+!          The regridding operation is done along dimension "ix" of the input
+!          field "vs". Input are positions of cell edges.
+! Remarks:
+!   * The target grid should be included in the source grid:
+!     no extrapolation is allowed.
+!   * Field on target grid "vt" has same rank, slopes and averages as "vs".
+!   * If optional argument "slope" is not given, 0 is assumed for slopes.
+!     Then the regridding is first order instead of second.
+!   * "vs" and "vt" have the same dimensions except Nr. ix (ns for vs, nt for vt)
+
+! Argument                         Type         Description
+!-------------------------------------------------------------------------------
+!  INTEGER, INTENT(IN)  :: ix      Scalar       dimension regridded <=rank(vs)
+!  REAL,    INTENT(IN)  :: vs(*)   Rank>=1      averages in source grid cells
+!  REAL,    INTENT(IN)  :: xs(:)   Vector(ns+1) edges of source grid, asc. order
+!  REAL,    INTENT(IN)  :: xt(:)   Vector(nt+1) edges of target grid, asc. order
+!  REAL,    INTENT(OUT) :: vt(*)   Rank>=1      regridded field
+! [REAL,    INTENT(IN)  :: slope]  Rank>=1      slopes in source grid cells
+
+  INTERFACE regr_conserv
+    ! The procedures differ only from the rank of the input/output fields.
+    MODULE PROCEDURE regr1_conserv, regr2_conserv, regr3_conserv, &
+                     regr4_conserv, regr5_conserv
+  END INTERFACE
+
+  PRIVATE
+  PUBLIC :: regr_conserv
+
+CONTAINS
+
+!-------------------------------------------------------------------------------
+!
+SUBROUTINE regr1_conserv(ix, vs, xs, xt, vt, slope)
+!
+!-------------------------------------------------------------------------------
+! Arguments:
+  INTEGER,        INTENT(IN)  :: ix
+  REAL,           INTENT(IN)  :: vs(:)
+  REAL,           INTENT(IN)  :: xs(:), xt(:)
+  REAL,           INTENT(OUT) :: vt(:)
+  REAL, OPTIONAL, INTENT(IN)  :: slope(:)
+!-------------------------------------------------------------------------------
+! Local variables:
+  INTEGER :: is, it, ns, nt
+  REAL    :: co, idt
+  LOGICAL :: lslope
+!-------------------------------------------------------------------------------
+  lslope=PRESENT(slope)
+  CALL check_size(ix,SHAPE(vs),SHAPE(vt),xs,xt,ns,nt)
+  is=locate(xs,xt(1))                    !--- 1<= is <= ns (no extrapolation)
+  vt(:)=0.
+  DO it=1, nt; idt=1./(xt(it+1)-xt(it))
+    IF(xt(it+1)<=xs(is+1)) THEN          !--- xs(is)<=xt(it)<=xt(it+1)<=xs(is+1)
+      CALL mean_lin(xt(it),xt(it+1))
+    ELSE
+      CALL mean_lin(xt(it),xs(is+1)); is=is+1
+      DO WHILE(xs(is+1)<xt(it+1))        !--- 1<=is<=ns-1
+      CALL mean_lin(xs(is),xs(is+1)); is=is+1
+      END DO
+      CALL mean_lin(xs(is),xt(it+1))     !--- 1<=is<=ns
+    END IF
+    IF(xs(is+1)==xt(it+1)) is=is+1       !--- 1<=is<=ns .OR. it==nt
+  END DO
+
+CONTAINS
+
+!-------------------------------------------------------------------------------
+SUBROUTINE mean_lin(a,b)  ! mean [a,b] of the linear function in [xs(is),xs(is+1)]
+!-------------------------------------------------------------------------------
+! Arguments:
+  REAL, INTENT(IN)    :: a, b
+!-------------------------------------------------------------------------------
+  IF(lslope.AND.(a/=xs(is).OR.b/=xs(is+1))) THEN; co=0.
+    IF(a==xt(it  )) co=co+xt(it  )-xs(is  )
+    IF(b==xt(it+1)) co=co+xt(it+1)-xs(is+1)
+    vt(it) = vt(it)+idt*(b-a)*(vs(is)+co*slope(is)/2.)
+  ELSE
+    vt(it) = vt(it)+idt*(b-a)* vs(is)
+  END IF
+
+END SUBROUTINE mean_lin
+!-------------------------------------------------------------------------------
+
+END SUBROUTINE regr1_conserv
+!
+!-------------------------------------------------------------------------------
+
+
+!-------------------------------------------------------------------------------
+!
+SUBROUTINE regr2_conserv(ix, vs, xs, xt, vt, slope)
+!
+!-------------------------------------------------------------------------------
+! Arguments:
+  INTEGER,        INTENT(IN)  :: ix
+  REAL,           INTENT(IN)  :: vs(:,:)
+  REAL,           INTENT(IN)  :: xs(:), xt(:)
+  REAL,           INTENT(OUT) :: vt(:,:)
+  REAL, OPTIONAL, INTENT(IN)  :: slope(:,:)
+!-------------------------------------------------------------------------------
+! Local variables:
+  INTEGER :: is, it, ns, nt
+  REAL    :: co, idt
+  LOGICAL :: lslope
+!-------------------------------------------------------------------------------
+  lslope=PRESENT(slope)
+  CALL check_size(ix,SHAPE(vs),SHAPE(vt),xs,xt,ns,nt)
+  is=locate(xs,xt(1)) ! 1 <= is <= ns, because we forbid extrapolation
+  vt(:,:)=0.
+  DO it=1, nt; idt=1./(xt(it+1)-xt(it))
+    IF(xt(it+1)<=xs(is+1)) THEN          !--- xs(is)<=xt(it)<=xt(it+1)<=xs(is+1)
+      CALL mean_lin(xt(it),xt(it+1))
+    ELSE
+      CALL mean_lin(xt(it),xs(is+1)); is=is+1
+      DO WHILE(xs(is+1)<xt(it+1))        !--- 1<=is<=ns-1
+      CALL mean_lin(xs(is),xs(is+1)); is=is+1
+      END DO
+      CALL mean_lin(xs(is),xt(it+1))     !--- 1<=is<=ns
+    END IF
+    IF(xs(is+1)==xt(it+1)) is=is+1       !--- 1<=is<=ns .OR. it==nt
+  END DO
+
+CONTAINS
+
+!-------------------------------------------------------------------------------
+SUBROUTINE mean_lin(a,b)  ! mean [a,b] of the linear function in [xs(is),xs(is+1)]
+!-------------------------------------------------------------------------------
+! Arguments:
+  REAL, INTENT(IN)    :: a, b
+!-------------------------------------------------------------------------------
+  IF(lslope.AND.(a/=xs(is).OR.b/=xs(is+1))) THEN; co=0.
+    IF(a==xt(it  )) co=co+xt(it  )-xs(is  )
+    IF(b==xt(it+1)) co=co+xt(it+1)-xs(is+1)
+    IF(ix==1) vt(it,:) = vt(it,:)+idt*(b-a)*(vs(is,:)+co*slope(is,:)/2.)
+    IF(ix==2) vt(:,it) = vt(:,it)+idt*(b-a)*(vs(:,is)+co*slope(:,is)/2.)
+  ELSE
+    IF(ix==1) vt(it,:) = vt(it,:)+idt*(b-a)* vs(is,:)
+    IF(ix==2) vt(:,it) = vt(:,it)+idt*(b-a)* vs(:,is)
+  END IF
+
+END SUBROUTINE mean_lin
+!-------------------------------------------------------------------------------
+
+END SUBROUTINE regr2_conserv
+!
+!-------------------------------------------------------------------------------
+
+
+!-------------------------------------------------------------------------------
+!
+SUBROUTINE regr3_conserv(ix, vs, xs, xt, vt, slope)
+!
+!-------------------------------------------------------------------------------
+! Arguments:
+  INTEGER,        INTENT(IN)  :: ix
+  REAL,           INTENT(IN)  :: vs(:,:,:)
+  REAL,           INTENT(IN)  :: xs(:), xt(:)
+  REAL,           INTENT(OUT) :: vt(:,:,:)
+  REAL, OPTIONAL, INTENT(IN)  :: slope(:,:,:)
+!-------------------------------------------------------------------------------
+! Local variables:
+  INTEGER :: is, it, ns, nt
+  REAL    :: co, idt
+  LOGICAL :: lslope
+!-------------------------------------------------------------------------------
+  lslope=PRESENT(slope)
+  CALL check_size(ix,SHAPE(vs),SHAPE(vt),xs,xt,ns,nt)
+  is=locate(xs,xt(1)) ! 1 <= is <= ns, because we forbid extrapolation
+  vt(:,:,:)=0.
+  DO it=1, nt; idt=1./(xt(it+1)-xt(it))
+    IF(xt(it+1)<=xs(is+1)) THEN          !--- xs(is)<=xt(it)<=xt(it+1)<=xs(is+1)
+      CALL mean_lin(xt(it),xt(it+1))
+    ELSE
+      CALL mean_lin(xt(it),xs(is+1)); is=is+1
+      DO WHILE(xs(is+1)<xt(it+1))        !--- 1<=is<=ns-1
+      CALL mean_lin(xs(is),xs(is+1)); is=is+1
+      END DO
+      CALL mean_lin(xs(is),xt(it+1))     !--- 1<=is<=ns
+    END IF
+    IF(xs(is+1)==xt(it+1)) is=is+1       !--- 1<=is<=ns .OR. it==nt
+  END DO
+
+CONTAINS
+
+!-------------------------------------------------------------------------------
+SUBROUTINE mean_lin(a,b)  ! mean [a,b] of the linear function in [xs(is),xs(is+1)]
+!-------------------------------------------------------------------------------
+! Arguments:
+  REAL, INTENT(IN)    :: a, b
+!-------------------------------------------------------------------------------
+  IF(lslope.AND.(a/=xs(is).OR.b/=xs(is+1))) THEN; co=0.
+    IF(a==xt(it  )) co=co+xt(it  )-xs(is  )
+    IF(b==xt(it+1)) co=co+xt(it+1)-xs(is+1)
+    IF(ix==1) vt(it,:,:) = vt(it,:,:)+idt*(b-a)*(vs(is,:,:)+co*slope(is,:,:)/2.)
+    IF(ix==2) vt(:,it,:) = vt(:,it,:)+idt*(b-a)*(vs(:,is,:)+co*slope(:,is,:)/2.)
+    IF(ix==3) vt(:,:,it) = vt(:,:,it)+idt*(b-a)*(vs(:,:,is)+co*slope(:,:,is)/2.)
+  ELSE
+    IF(ix==1) vt(it,:,:) = vt(it,:,:)+idt*(b-a)* vs(is,:,:)
+    IF(ix==2) vt(:,it,:) = vt(:,it,:)+idt*(b-a)* vs(:,is,:)
+    IF(ix==3) vt(:,:,it) = vt(:,:,it)+idt*(b-a)* vs(:,:,is)
+  END IF
+
+END SUBROUTINE mean_lin
+!-------------------------------------------------------------------------------
+
+END SUBROUTINE regr3_conserv
+!
+!-------------------------------------------------------------------------------
+
+
+!-------------------------------------------------------------------------------
+!
+SUBROUTINE regr4_conserv(ix, vs, xs, xt, vt, slope)
+!
+!-------------------------------------------------------------------------------
+! Arguments:
+  INTEGER,        INTENT(IN)  :: ix
+  REAL,           INTENT(IN)  :: vs(:,:,:,:)
+  REAL,           INTENT(IN)  :: xs(:), xt(:)
+  REAL,           INTENT(OUT) :: vt(:,:,:,:)
+  REAL, OPTIONAL, INTENT(IN)  :: slope(:,:,:,:)
+!-------------------------------------------------------------------------------
+! Local variables:
+  INTEGER :: is, it, ns, nt
+  REAL    :: co, idt
+  LOGICAL :: lslope
+!-------------------------------------------------------------------------------
+  lslope=PRESENT(slope)
+  CALL check_size(ix,SHAPE(vs),SHAPE(vt),xs,xt,ns,nt)
+  is=locate(xs,xt(1)) ! 1 <= is <= ns, because we forbid extrapolation
+  vt(:,:,:,:)=0.
+  DO it=1, nt; idt=1./(xt(it+1)-xt(it))
+    IF(xt(it+1)<=xs(is+1)) THEN          !--- xs(is)<=xt(it)<=xt(it+1)<=xs(is+1)
+      CALL mean_lin(xt(it),xt(it+1))
+    ELSE
+      CALL mean_lin(xt(it),xs(is+1)); is=is+1
+      DO WHILE(xs(is+1)<xt(it+1))        !--- 1<=is<=ns-1
+      CALL mean_lin(xs(is),xs(is+1)); is=is+1
+      END DO
+      CALL mean_lin(xs(is),xt(it+1))     !--- 1<=is<=ns
+    END IF
+    IF(xs(is+1)==xt(it+1)) is=is+1       !--- 1<=is<=ns .OR. it==nt
+  END DO
+
+CONTAINS
+
+!-------------------------------------------------------------------------------
+SUBROUTINE mean_lin(a,b)  ! mean [a,b] of the linear function in [xs(is),xs(is+1)]
+!-------------------------------------------------------------------------------
+! Arguments:
+  REAL, INTENT(IN) :: a, b
+!-------------------------------------------------------------------------------
+  IF(lslope.AND.(a/=xs(is).OR.b/=xs(is+1))) THEN; co=0.
+    IF(a==xt(it  )) co=co+xt(it  )-xs(is  )
+    IF(b==xt(it+1)) co=co+xt(it+1)-xs(is+1)
+    IF(ix==1) vt(it,:,:,:) = vt(it,:,:,:)+idt*(b-a)*(vs(is,:,:,:)+co*slope(is,:,:,:)/2.)
+    IF(ix==2) vt(:,it,:,:) = vt(:,it,:,:)+idt*(b-a)*(vs(:,is,:,:)+co*slope(:,is,:,:)/2.)
+    IF(ix==3) vt(:,:,it,:) = vt(:,:,it,:)+idt*(b-a)*(vs(:,:,is,:)+co*slope(:,:,is,:)/2.)
+    IF(ix==4) vt(:,:,:,it) = vt(:,:,:,it)+idt*(b-a)*(vs(:,:,:,is)+co*slope(:,:,:,is)/2.)
+  ELSE
+    IF(ix==1) vt(it,:,:,:) = vt(it,:,:,:)+idt*(b-a)* vs(is,:,:,:)
+    IF(ix==2) vt(:,it,:,:) = vt(:,it,:,:)+idt*(b-a)* vs(:,is,:,:)
+    IF(ix==3) vt(:,:,it,:) = vt(:,:,it,:)+idt*(b-a)* vs(:,:,is,:)
+    IF(ix==4) vt(:,:,:,it) = vt(:,:,:,it)+idt*(b-a)* vs(:,:,:,is)
+  END IF
+
+END SUBROUTINE mean_lin
+!-------------------------------------------------------------------------------
+
+END SUBROUTINE regr4_conserv
+!
+!-------------------------------------------------------------------------------
+
+
+!-------------------------------------------------------------------------------
+!
+SUBROUTINE regr5_conserv(ix, vs, xs, xt, vt, slope)
+!
+!-------------------------------------------------------------------------------
+! Arguments:
+  INTEGER,        INTENT(IN)  :: ix
+  REAL,           INTENT(IN)  :: vs(:,:,:,:,:)
+  REAL,           INTENT(IN)  :: xs(:), xt(:)
+  REAL,           INTENT(OUT) :: vt(:,:,:,:,:)
+  REAL, OPTIONAL, INTENT(IN)  :: slope(:,:,:,:,:)
+!-------------------------------------------------------------------------------
+! Local variables:
+  INTEGER :: is, it, ns, nt
+  REAL    :: co, idt
+  LOGICAL :: lslope
+!-------------------------------------------------------------------------------
+  lslope=PRESENT(slope)
+  CALL check_size(ix,SHAPE(vs),SHAPE(vt),xs,xt,ns,nt)
+  is=locate(xs,xt(1)) ! 1 <= is <= ns, because we forbid extrapolation
+  vt(:,:,:,:,:)=0.
+  DO it=1, nt; idt=1./(xt(it+1)-xt(it))
+    IF(xt(it+1)<=xs(is+1)) THEN          !--- xs(is)<=xt(it)<=xt(it+1)<=xs(is+1)
+      CALL mean_lin(xt(it),xt(it+1))
+    ELSE
+      CALL mean_lin(xt(it),xs(is+1)); is=is+1
+      DO WHILE(xs(is+1)<xt(it+1))        !--- 1<=is<=ns-1
+      CALL mean_lin(xs(is),xs(is+1)); is=is+1
+      END DO
+      CALL mean_lin(xs(is),xt(it+1))     !--- 1<=is<=ns
+    END IF
+    IF(xs(is+1)==xt(it+1)) is=is+1     !--- 1<=is<=ns .OR. it==nt
+  END DO
+
+CONTAINS
+
+!-------------------------------------------------------------------------------
+SUBROUTINE mean_lin(a,b)  ! mean [a,b] of the linear function in [xs(is),xs(is+1)]
+!-------------------------------------------------------------------------------
+! Arguments:
+  REAL, INTENT(IN) :: a, b
+!-------------------------------------------------------------------------------
+  IF(lslope.AND.(a/=xs(is).OR.b/=xs(is+1))) THEN; co=0.
+    IF(a==xt(it  )) co=co+xt(it  )-xs(is  )
+    IF(b==xt(it+1)) co=co+xt(it+1)-xs(is+1)
+    IF(ix==1) vt(it,:,:,:,:) = vt(it,:,:,:,:)+idt*(b-a)*(vs(is,:,:,:,:)+co*slope(is,:,:,:,:)/2.)
+    IF(ix==2) vt(:,it,:,:,:) = vt(:,it,:,:,:)+idt*(b-a)*(vs(:,is,:,:,:)+co*slope(:,is,:,:,:)/2.)
+    IF(ix==3) vt(:,:,it,:,:) = vt(:,:,it,:,:)+idt*(b-a)*(vs(:,:,is,:,:)+co*slope(:,:,is,:,:)/2.)
+    IF(ix==4) vt(:,:,:,it,:) = vt(:,:,:,it,:)+idt*(b-a)*(vs(:,:,:,is,:)+co*slope(:,:,:,is,:)/2.)
+    IF(ix==5) vt(:,:,:,:,it) = vt(:,:,:,:,it)+idt*(b-a)*(vs(:,:,:,:,is)+co*slope(:,:,:,:,is)/2.)
+  ELSE
+    IF(ix==1) vt(it,:,:,:,:) = vt(it,:,:,:,:)+idt*(b-a)* vs(is,:,:,:,:)
+    IF(ix==2) vt(:,it,:,:,:) = vt(:,it,:,:,:)+idt*(b-a)* vs(:,is,:,:,:)
+    IF(ix==3) vt(:,:,it,:,:) = vt(:,:,it,:,:)+idt*(b-a)* vs(:,:,is,:,:)
+    IF(ix==4) vt(:,:,:,it,:) = vt(:,:,:,it,:)+idt*(b-a)* vs(:,:,:,is,:)
+    IF(ix==5) vt(:,:,:,:,it) = vt(:,:,:,:,it)+idt*(b-a)* vs(:,:,:,:,is)
+  END IF
+
+END SUBROUTINE mean_lin
+!-------------------------------------------------------------------------------
+
+END SUBROUTINE regr5_conserv
+!
+!-------------------------------------------------------------------------------
+
+
+!-------------------------------------------------------------------------------
+!
+SUBROUTINE check_size(ix,svs,svt,xs,xt,ns,nt)
+!
+!-------------------------------------------------------------------------------
+! Arguments:
+  INTEGER, INTENT(IN)  :: ix, svs(:), svt(:)
+  REAL,    INTENT(IN)  :: xs(:), xt(:)
+  INTEGER, INTENT(OUT) :: ns,    nt
+!-------------------------------------------------------------------------------
+! Local variables:
+  INTEGER :: rk, is, ii, n
+  CHARACTER(LEN=80) :: sub, msg
+!-------------------------------------------------------------------------------
+  WRITE(sub,'(a,2i0,a)')"regr",SIZE(svs),ix,"_conserv"
+  rk=assert_eq(SIZE(svs),SIZE(svt),TRIM(sub)//': inconsistent ranks')
+  WRITE(msg,'(a,2(i0,a))')TRIM(sub)//": ix (",ix,") exceeds field rank (",rk,")"
+  CALL assert(ix>=1.AND.ix<=rk,msg)
+  ii=0
+  DO is=1,rk; IF(is==ix) CYCLE
+    WRITE(msg,'(a,i0)')TRIM(sub)//" n",is
+    n=assert_eq(svs(is),svt(is),msg)
+    ii=ii+1
+  END DO
+  ns=assert_eq(svs(ix),SIZE(xs)-1,TRIM(sub)//" ns")
+  nt=assert_eq(svt(ix),SIZE(xt)-1,TRIM(sub)//" nt")
+
+  !--- Quick check on sort order:
+  CALL assert(xs(1)<xs(2), TRIM(sub)//": xs bad order")
+  CALL assert(xt(1)<xt(2), TRIM(sub)//": xt bad order")
+  CALL assert(xs(1)<=xt(1).AND.xt(nt+1)<=xs(ns+1), TRIM(sub)//": extrapolation")
+
+END SUBROUTINE check_size
+!
+!-------------------------------------------------------------------------------
+
+
+END MODULE regr_conserv_m
Index: DZ6/trunk/libf/misc/regr_lint_m.F90
===================================================================
--- /LMDZ6/trunk/libf/misc/regr_lint_m.F90	(revision 5267)
+++ 	(revision )
@@ -1,219 +1,0 @@
-MODULE regr_lint_m
-
-  USE assert_eq_m,   ONLY: assert_eq
-  USE assert_m,      ONLY: assert
-  USE interpolation, ONLY: hunt
-
-  IMPLICIT NONE
-
-! Purpose: Each procedure regrids by linear interpolation along dimension "ix"
-!          the input field "vs" to the output field "vt".
-! Remark:
-!   * "vs" and "vt" have the same dimensions except Nr. ix (ns for vs, nt for vt)
-
-! Argument                         Type         Description
-!-------------------------------------------------------------------------------
-!  INTEGER, INTENT(IN)  :: ix      Scalar       dimension regridded <=rank(vs)
-!  REAL,    INTENT(IN)  :: vs(*)   Rank>=1      source grid field values
-!  REAL,    INTENT(IN)  :: xs(:)   Vector(ns)   centers of source grid, asc. order
-!  REAL,    INTENT(IN)  :: xt(:)   Vector(nt)   centers of target grid, asc. order
-!  REAL,    INTENT(OUT) :: vt(*)   Rank>=1      regridded field
-
-  INTERFACE regr_lint
-    ! The procedures differ only from the rank of the input/output fields.
-    MODULE PROCEDURE regr1_lint, regr2_lint, regr3_lint, &
-                     regr4_lint, regr5_lint
-  END INTERFACE
-
-  PRIVATE
-  PUBLIC :: regr_lint
-
-CONTAINS
-
-
-!-------------------------------------------------------------------------------
-!
-SUBROUTINE regr1_lint(ix, vs, xs, xt, vt)
-!
-!-------------------------------------------------------------------------------
-! Arguments:
-  INTEGER, INTENT(IN)  :: ix
-  REAL,    INTENT(IN)  :: vs(:)
-  REAL,    INTENT(IN)  :: xs(:)
-  REAL,    INTENT(IN)  :: xt(:)
-  REAL,    INTENT(OUT) :: vt(:)
-!-------------------------------------------------------------------------------
-! Local variables:
-  INTEGER :: is, it, ns, nt, isb ! "is" bound between 1 and "ns - 1"
-  REAL    :: r
-!-------------------------------------------------------------------------------
-  CALL check_size(ix,SHAPE(vs),SHAPE(vt),SIZE(xs),SIZE(xt),ns,nt)
-  is = -1 ! go immediately to bisection on first call to "hunt"
-  DO it=1,SIZE(xt)
-    CALL hunt(xs,xt(it),is); isb=MIN(MAX(is,1),ns-1)
-    r=(xs(isb+1)-xt(it))/(xs(isb+1)-xs(isb))
-    vt(it)=r*vs(isb)+(1.-r)*vs(isb+1)
-  END DO
-
-END SUBROUTINE regr1_lint
-!
-!-------------------------------------------------------------------------------
-
-
-!-------------------------------------------------------------------------------
-!
-SUBROUTINE regr2_lint(ix, vs, xs, xt, vt)
-!
-!-------------------------------------------------------------------------------
-! Arguments:
-  INTEGER, INTENT(IN)  :: ix
-  REAL,    INTENT(IN)  :: vs(:,:)
-  REAL,    INTENT(IN)  :: xs(:)
-  REAL,    INTENT(IN)  :: xt(:)
-  REAL,    INTENT(OUT) :: vt(:,:)
-!-------------------------------------------------------------------------------
-! Local variables:
-  INTEGER :: is, it, ns, nt, isb ! "is" bound between 1 and "ns - 1"
-  REAL    :: r
-!-------------------------------------------------------------------------------
-  CALL check_size(ix,SHAPE(vs),SHAPE(vt),SIZE(xs),SIZE(xt),ns,nt)
-  is = -1 ! go immediately to bisection on first call to "hunt"
-  DO it=1,SIZE(xt)
-    CALL hunt(xs,xt(it),is); isb=MIN(MAX(is,1),ns-1)
-    r=(xs(isb+1)-xt(it))/(xs(isb+1)-xs(isb))
-    IF(ix==1) vt(it,:)=r*vs(isb,:)+(1.-r)*vs(isb+1,:)
-    IF(ix==2) vt(:,it)=r*vs(:,isb)+(1.-r)*vs(:,isb+1)
-  END DO
-
-END SUBROUTINE regr2_lint
-!
-!-------------------------------------------------------------------------------
-
-
-!-------------------------------------------------------------------------------
-!
-SUBROUTINE regr3_lint(ix, vs, xs, xt, vt)
-!
-!-------------------------------------------------------------------------------
-! Arguments:
-  INTEGER, INTENT(IN)  :: ix
-  REAL,    INTENT(IN)  :: vs(:,:,:)
-  REAL,    INTENT(IN)  :: xs(:)
-  REAL,    INTENT(IN)  :: xt(:)
-  REAL,    INTENT(OUT) :: vt(:,:,:)
-!-------------------------------------------------------------------------------
-! Local variables:
-  INTEGER :: is, it, ns, nt, isb ! "is" bound between 1 and "ns - 1"
-  REAL    :: r
-!-------------------------------------------------------------------------------
-  CALL check_size(ix,SHAPE(vs),SHAPE(vt),SIZE(xs),SIZE(xt),ns,nt)
-  is = -1 ! go immediately to bisection on first call to "hunt"
-  DO it=1,SIZE(xt)
-    CALL hunt(xs,xt(it),is); isb=MIN(MAX(is,1),ns-1)
-    r=(xs(isb+1)-xt(it))/(xs(isb+1)-xs(isb))
-    IF(ix==1) vt(it,:,:)=r*vs(isb,:,:)+(1.-r)*vs(isb+1,:,:)
-    IF(ix==2) vt(:,it,:)=r*vs(:,isb,:)+(1.-r)*vs(:,isb+1,:)
-    IF(ix==3) vt(:,:,it)=r*vs(:,:,isb)+(1.-r)*vs(:,:,isb+1)
-  END DO
-
-END SUBROUTINE regr3_lint
-!
-!-------------------------------------------------------------------------------
-
-
-!-------------------------------------------------------------------------------
-!
-SUBROUTINE regr4_lint(ix, vs, xs, xt, vt)
-!
-!-------------------------------------------------------------------------------
-! Arguments:
-  INTEGER, INTENT(IN)  :: ix
-  REAL,    INTENT(IN)  :: vs(:,:,:,:)
-  REAL,    INTENT(IN)  :: xs(:)
-  REAL,    INTENT(IN)  :: xt(:)
-  REAL,    INTENT(OUT) :: vt(:,:,:,:)
-!-------------------------------------------------------------------------------
-! Local variables:
-  INTEGER :: is, it, ns, nt, isb ! "is" bound between 1 and "ns - 1"
-  REAL    :: r
-!-------------------------------------------------------------------------------
-  CALL check_size(ix,SHAPE(vs),SHAPE(vt),SIZE(xs),SIZE(xt),ns,nt)
-  is = -1 ! go immediately to bisection on first call to "hunt"
-  DO it=1,SIZE(xt)
-    CALL hunt(xs,xt(it),is); isb=MIN(MAX(is,1),ns-1)
-    r=(xs(isb+1)-xt(it))/(xs(isb+1)-xs(isb))
-    IF(ix==1) vt(it,:,:,:)=r*vs(isb,:,:,:)+(1.-r)*vs(isb+1,:,:,:)
-    IF(ix==2) vt(:,it,:,:)=r*vs(:,isb,:,:)+(1.-r)*vs(:,isb+1,:,:)
-    IF(ix==3) vt(:,:,it,:)=r*vs(:,:,isb,:)+(1.-r)*vs(:,:,isb+1,:)
-    IF(ix==4) vt(:,:,:,it)=r*vs(:,:,:,isb)+(1.-r)*vs(:,:,:,isb+1)
-  END DO
-
-END SUBROUTINE regr4_lint
-!
-!-------------------------------------------------------------------------------
-
-
-!-------------------------------------------------------------------------------
-!
-SUBROUTINE regr5_lint(ix, vs, xs, xt, vt)
-!
-!-------------------------------------------------------------------------------
-! Arguments:
-  INTEGER, INTENT(IN)  :: ix
-  REAL,    INTENT(IN)  :: vs(:,:,:,:,:)
-  REAL,    INTENT(IN)  :: xs(:)
-  REAL,    INTENT(IN)  :: xt(:)
-  REAL,    INTENT(OUT) :: vt(:,:,:,:,:)
-!-------------------------------------------------------------------------------
-! Local variables:
-  INTEGER :: is, it, ns, nt, isb ! "is" bound between 1 and "ns - 1"
-  REAL    :: r
-!-------------------------------------------------------------------------------
-  CALL check_size(ix,SHAPE(vs),SHAPE(vt),SIZE(xs),SIZE(xt),ns,nt)
-  is = -1 ! go immediately to bisection on first call to "hunt"
-  DO it=1,SIZE(xt)
-    CALL hunt(xs,xt(it),is); isb=MIN(MAX(is,1),ns-1)
-    r=(xs(isb+1)-xt(it))/(xs(isb+1)-xs(isb))
-    IF(ix==1) vt(it,:,:,:,:)=r*vs(isb,:,:,:,:)+(1.-r)*vs(isb+1,:,:,:,:)
-    IF(ix==2) vt(:,it,:,:,:)=r*vs(:,isb,:,:,:)+(1.-r)*vs(:,isb+1,:,:,:)
-    IF(ix==3) vt(:,:,it,:,:)=r*vs(:,:,isb,:,:)+(1.-r)*vs(:,:,isb+1,:,:)
-    IF(ix==4) vt(:,:,:,it,:)=r*vs(:,:,:,isb,:)+(1.-r)*vs(:,:,:,isb+1,:)
-    IF(ix==5) vt(:,:,:,:,it)=r*vs(:,:,:,:,isb)+(1.-r)*vs(:,:,:,:,isb+1)
-  END DO
-
-END SUBROUTINE regr5_lint
-!
-!-------------------------------------------------------------------------------
-
-
-!-------------------------------------------------------------------------------
-!
-SUBROUTINE check_size(ix,svs,svt,nxs,nxt,ns,nt)
-!
-!-------------------------------------------------------------------------------
-! Arguments:
-  INTEGER, INTENT(IN)  :: ix, svs(:), svt(:), nxs, nxt
-  INTEGER, INTENT(OUT) :: ns, nt
-!-------------------------------------------------------------------------------
-! Local variables:
-  INTEGER :: rk, is
-  CHARACTER(LEN=80) :: sub, msg
-!-------------------------------------------------------------------------------
-  rk=SIZE(svs)
-  WRITE(sub,'(a,2i0,a)')"regr",rk,ix,"_lint"
-  CALL assert(ix>=1.AND.ix<=rk,TRIM(sub)//": ix exceeds fields rank")
-  DO is=1,rk; IF(is==ix) CYCLE
-    WRITE(msg,'(a,i1)')TRIM(sub)//" n",is
-    CALL assert(svs(is)==svt(is),msg)
-  END DO
-  ns=assert_eq(svs(ix),nxs,TRIM(sub)//" ns")
-  nt=assert_eq(svt(ix),nxt,TRIM(sub)//" nt")
-
-END SUBROUTINE check_size
-!
-!-------------------------------------------------------------------------------
-
-END MODULE regr_lint_m
-!
-!-------------------------------------------------------------------------------
-
Index: /LMDZ6/trunk/libf/misc/regr_lint_m.f90
===================================================================
--- /LMDZ6/trunk/libf/misc/regr_lint_m.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/misc/regr_lint_m.f90	(revision 5268)
@@ -0,0 +1,219 @@
+MODULE regr_lint_m
+
+  USE assert_eq_m,   ONLY: assert_eq
+  USE assert_m,      ONLY: assert
+  USE interpolation, ONLY: hunt
+
+  IMPLICIT NONE
+
+! Purpose: Each procedure regrids by linear interpolation along dimension "ix"
+!          the input field "vs" to the output field "vt".
+! Remark:
+!   * "vs" and "vt" have the same dimensions except Nr. ix (ns for vs, nt for vt)
+
+! Argument                         Type         Description
+!-------------------------------------------------------------------------------
+!  INTEGER, INTENT(IN)  :: ix      Scalar       dimension regridded <=rank(vs)
+!  REAL,    INTENT(IN)  :: vs(*)   Rank>=1      source grid field values
+!  REAL,    INTENT(IN)  :: xs(:)   Vector(ns)   centers of source grid, asc. order
+!  REAL,    INTENT(IN)  :: xt(:)   Vector(nt)   centers of target grid, asc. order
+!  REAL,    INTENT(OUT) :: vt(*)   Rank>=1      regridded field
+
+  INTERFACE regr_lint
+    ! The procedures differ only from the rank of the input/output fields.
+    MODULE PROCEDURE regr1_lint, regr2_lint, regr3_lint, &
+                     regr4_lint, regr5_lint
+  END INTERFACE
+
+  PRIVATE
+  PUBLIC :: regr_lint
+
+CONTAINS
+
+
+!-------------------------------------------------------------------------------
+!
+SUBROUTINE regr1_lint(ix, vs, xs, xt, vt)
+!
+!-------------------------------------------------------------------------------
+! Arguments:
+  INTEGER, INTENT(IN)  :: ix
+  REAL,    INTENT(IN)  :: vs(:)
+  REAL,    INTENT(IN)  :: xs(:)
+  REAL,    INTENT(IN)  :: xt(:)
+  REAL,    INTENT(OUT) :: vt(:)
+!-------------------------------------------------------------------------------
+! Local variables:
+  INTEGER :: is, it, ns, nt, isb ! "is" bound between 1 and "ns - 1"
+  REAL    :: r
+!-------------------------------------------------------------------------------
+  CALL check_size(ix,SHAPE(vs),SHAPE(vt),SIZE(xs),SIZE(xt),ns,nt)
+  is = -1 ! go immediately to bisection on first call to "hunt"
+  DO it=1,SIZE(xt)
+    CALL hunt(xs,xt(it),is); isb=MIN(MAX(is,1),ns-1)
+    r=(xs(isb+1)-xt(it))/(xs(isb+1)-xs(isb))
+    vt(it)=r*vs(isb)+(1.-r)*vs(isb+1)
+  END DO
+
+END SUBROUTINE regr1_lint
+!
+!-------------------------------------------------------------------------------
+
+
+!-------------------------------------------------------------------------------
+!
+SUBROUTINE regr2_lint(ix, vs, xs, xt, vt)
+!
+!-------------------------------------------------------------------------------
+! Arguments:
+  INTEGER, INTENT(IN)  :: ix
+  REAL,    INTENT(IN)  :: vs(:,:)
+  REAL,    INTENT(IN)  :: xs(:)
+  REAL,    INTENT(IN)  :: xt(:)
+  REAL,    INTENT(OUT) :: vt(:,:)
+!-------------------------------------------------------------------------------
+! Local variables:
+  INTEGER :: is, it, ns, nt, isb ! "is" bound between 1 and "ns - 1"
+  REAL    :: r
+!-------------------------------------------------------------------------------
+  CALL check_size(ix,SHAPE(vs),SHAPE(vt),SIZE(xs),SIZE(xt),ns,nt)
+  is = -1 ! go immediately to bisection on first call to "hunt"
+  DO it=1,SIZE(xt)
+    CALL hunt(xs,xt(it),is); isb=MIN(MAX(is,1),ns-1)
+    r=(xs(isb+1)-xt(it))/(xs(isb+1)-xs(isb))
+    IF(ix==1) vt(it,:)=r*vs(isb,:)+(1.-r)*vs(isb+1,:)
+    IF(ix==2) vt(:,it)=r*vs(:,isb)+(1.-r)*vs(:,isb+1)
+  END DO
+
+END SUBROUTINE regr2_lint
+!
+!-------------------------------------------------------------------------------
+
+
+!-------------------------------------------------------------------------------
+!
+SUBROUTINE regr3_lint(ix, vs, xs, xt, vt)
+!
+!-------------------------------------------------------------------------------
+! Arguments:
+  INTEGER, INTENT(IN)  :: ix
+  REAL,    INTENT(IN)  :: vs(:,:,:)
+  REAL,    INTENT(IN)  :: xs(:)
+  REAL,    INTENT(IN)  :: xt(:)
+  REAL,    INTENT(OUT) :: vt(:,:,:)
+!-------------------------------------------------------------------------------
+! Local variables:
+  INTEGER :: is, it, ns, nt, isb ! "is" bound between 1 and "ns - 1"
+  REAL    :: r
+!-------------------------------------------------------------------------------
+  CALL check_size(ix,SHAPE(vs),SHAPE(vt),SIZE(xs),SIZE(xt),ns,nt)
+  is = -1 ! go immediately to bisection on first call to "hunt"
+  DO it=1,SIZE(xt)
+    CALL hunt(xs,xt(it),is); isb=MIN(MAX(is,1),ns-1)
+    r=(xs(isb+1)-xt(it))/(xs(isb+1)-xs(isb))
+    IF(ix==1) vt(it,:,:)=r*vs(isb,:,:)+(1.-r)*vs(isb+1,:,:)
+    IF(ix==2) vt(:,it,:)=r*vs(:,isb,:)+(1.-r)*vs(:,isb+1,:)
+    IF(ix==3) vt(:,:,it)=r*vs(:,:,isb)+(1.-r)*vs(:,:,isb+1)
+  END DO
+
+END SUBROUTINE regr3_lint
+!
+!-------------------------------------------------------------------------------
+
+
+!-------------------------------------------------------------------------------
+!
+SUBROUTINE regr4_lint(ix, vs, xs, xt, vt)
+!
+!-------------------------------------------------------------------------------
+! Arguments:
+  INTEGER, INTENT(IN)  :: ix
+  REAL,    INTENT(IN)  :: vs(:,:,:,:)
+  REAL,    INTENT(IN)  :: xs(:)
+  REAL,    INTENT(IN)  :: xt(:)
+  REAL,    INTENT(OUT) :: vt(:,:,:,:)
+!-------------------------------------------------------------------------------
+! Local variables:
+  INTEGER :: is, it, ns, nt, isb ! "is" bound between 1 and "ns - 1"
+  REAL    :: r
+!-------------------------------------------------------------------------------
+  CALL check_size(ix,SHAPE(vs),SHAPE(vt),SIZE(xs),SIZE(xt),ns,nt)
+  is = -1 ! go immediately to bisection on first call to "hunt"
+  DO it=1,SIZE(xt)
+    CALL hunt(xs,xt(it),is); isb=MIN(MAX(is,1),ns-1)
+    r=(xs(isb+1)-xt(it))/(xs(isb+1)-xs(isb))
+    IF(ix==1) vt(it,:,:,:)=r*vs(isb,:,:,:)+(1.-r)*vs(isb+1,:,:,:)
+    IF(ix==2) vt(:,it,:,:)=r*vs(:,isb,:,:)+(1.-r)*vs(:,isb+1,:,:)
+    IF(ix==3) vt(:,:,it,:)=r*vs(:,:,isb,:)+(1.-r)*vs(:,:,isb+1,:)
+    IF(ix==4) vt(:,:,:,it)=r*vs(:,:,:,isb)+(1.-r)*vs(:,:,:,isb+1)
+  END DO
+
+END SUBROUTINE regr4_lint
+!
+!-------------------------------------------------------------------------------
+
+
+!-------------------------------------------------------------------------------
+!
+SUBROUTINE regr5_lint(ix, vs, xs, xt, vt)
+!
+!-------------------------------------------------------------------------------
+! Arguments:
+  INTEGER, INTENT(IN)  :: ix
+  REAL,    INTENT(IN)  :: vs(:,:,:,:,:)
+  REAL,    INTENT(IN)  :: xs(:)
+  REAL,    INTENT(IN)  :: xt(:)
+  REAL,    INTENT(OUT) :: vt(:,:,:,:,:)
+!-------------------------------------------------------------------------------
+! Local variables:
+  INTEGER :: is, it, ns, nt, isb ! "is" bound between 1 and "ns - 1"
+  REAL    :: r
+!-------------------------------------------------------------------------------
+  CALL check_size(ix,SHAPE(vs),SHAPE(vt),SIZE(xs),SIZE(xt),ns,nt)
+  is = -1 ! go immediately to bisection on first call to "hunt"
+  DO it=1,SIZE(xt)
+    CALL hunt(xs,xt(it),is); isb=MIN(MAX(is,1),ns-1)
+    r=(xs(isb+1)-xt(it))/(xs(isb+1)-xs(isb))
+    IF(ix==1) vt(it,:,:,:,:)=r*vs(isb,:,:,:,:)+(1.-r)*vs(isb+1,:,:,:,:)
+    IF(ix==2) vt(:,it,:,:,:)=r*vs(:,isb,:,:,:)+(1.-r)*vs(:,isb+1,:,:,:)
+    IF(ix==3) vt(:,:,it,:,:)=r*vs(:,:,isb,:,:)+(1.-r)*vs(:,:,isb+1,:,:)
+    IF(ix==4) vt(:,:,:,it,:)=r*vs(:,:,:,isb,:)+(1.-r)*vs(:,:,:,isb+1,:)
+    IF(ix==5) vt(:,:,:,:,it)=r*vs(:,:,:,:,isb)+(1.-r)*vs(:,:,:,:,isb+1)
+  END DO
+
+END SUBROUTINE regr5_lint
+!
+!-------------------------------------------------------------------------------
+
+
+!-------------------------------------------------------------------------------
+!
+SUBROUTINE check_size(ix,svs,svt,nxs,nxt,ns,nt)
+!
+!-------------------------------------------------------------------------------
+! Arguments:
+  INTEGER, INTENT(IN)  :: ix, svs(:), svt(:), nxs, nxt
+  INTEGER, INTENT(OUT) :: ns, nt
+!-------------------------------------------------------------------------------
+! Local variables:
+  INTEGER :: rk, is
+  CHARACTER(LEN=80) :: sub, msg
+!-------------------------------------------------------------------------------
+  rk=SIZE(svs)
+  WRITE(sub,'(a,2i0,a)')"regr",rk,ix,"_lint"
+  CALL assert(ix>=1.AND.ix<=rk,TRIM(sub)//": ix exceeds fields rank")
+  DO is=1,rk; IF(is==ix) CYCLE
+    WRITE(msg,'(a,i1)')TRIM(sub)//" n",is
+    CALL assert(svs(is)==svt(is),msg)
+  END DO
+  ns=assert_eq(svs(ix),nxs,TRIM(sub)//" ns")
+  nt=assert_eq(svt(ix),nxt,TRIM(sub)//" nt")
+
+END SUBROUTINE check_size
+!
+!-------------------------------------------------------------------------------
+
+END MODULE regr_lint_m
+!
+!-------------------------------------------------------------------------------
+
Index: DZ6/trunk/libf/misc/slopes_m.F90
===================================================================
--- /LMDZ6/trunk/libf/misc/slopes_m.F90	(revision 5267)
+++ 	(revision )
@@ -1,283 +1,0 @@
-MODULE slopes_m
-
-  ! Author: Lionel GUEZ
-  ! Extension / factorisation: David CUGNET
-
-  IMPLICIT NONE
-
-  ! Those generic function computes second order slopes with Van
-  ! Leer slope-limiting, given cell averages. Reference: Dukowicz,
-  ! 1987, SIAM Journal on Scientific and Statistical Computing, 8,
-  ! 305.
-
-  ! The only difference between the specific functions is the rank
-  ! of the first argument and the equal rank of the result.
-
-  ! slope(ix,...) acts on ix th dimension.
-
-  ! real, intent(in), rank >= 1:: f ! (n, ...) cell averages, n must be >= 1
-  ! real, intent(in):: x(:) ! (n + 1) cell edges
-  ! real slopes, same shape as f ! (n, ...)
-  INTERFACE slopes
-     MODULE procedure slopes1, slopes2, slopes3, slopes4, slopes5
-  END INTERFACE
-
-  PRIVATE
-  PUBLIC :: slopes
-
-CONTAINS
-
-!-------------------------------------------------------------------------------
-!
-PURE FUNCTION slopes1(ix, f, x)
-!
-!-------------------------------------------------------------------------------
-! Arguments:
-  INTEGER, INTENT(IN) :: ix
-  REAL,    INTENT(IN) :: f(:)
-  REAL,    INTENT(IN) :: x(:)
-  REAL :: slopes1(SIZE(f,1))
-!-------------------------------------------------------------------------------
-! Local:
-  INTEGER :: n, i, j, sta(2), sto(2)
-  REAL :: xc(SIZE(f,1))                             ! (n) cell centers
-  REAL :: h(2:SIZE(f,1)-1), delta_xc(2:SIZE(f,1)-1) ! (2:n-1)
-  REAL :: fm, ff, fp, dx
-!-------------------------------------------------------------------------------
-  n=SIZE(f,ix)
-  FORALL(i=1:n) xc(i)=(x(i)+x(i+1))/2.
-  FORALL(i=2:n-1)
-    h(i)=ABS(x(i+1)-xc(i)) ; delta_xc(i)=xc(i+1)-xc(i-1)
-  END FORALL
-  slopes1(:)=0.
-  DO i=2,n-1
-    ff=f(i); fm=f(i-1); fp=f(i+1)
-    IF(ff>=MAX(fm,fp).OR.ff<=MIN(fm,fp)) THEN
-      slopes1(i)=0.; CYCLE           !--- Local extremum
-      !--- 2nd order slope ; (fm, ff, fp) strictly monotonous
-      slopes1(i)=(fp-fm)/delta_xc(i)
-      !--- Slope limitation
-      slopes1(i) = SIGN(MIN(ABS(slopes1(i)), &
-        ABS(fp-ff)/h(i),ABS(ff-fm)/h(i)),slopes1(i) )
-     END IF
-  END DO
-
-END FUNCTION slopes1
-!
-!-------------------------------------------------------------------------------
-
-
-!-------------------------------------------------------------------------------
-!
-PURE FUNCTION slopes2(ix, f, x)
-!
-!-------------------------------------------------------------------------------
-! Arguments:
-  INTEGER, INTENT(IN) :: ix
-  REAL,    INTENT(IN) :: f(:, :)
-  REAL,    INTENT(IN) :: x(:)
-  REAL :: slopes2(SIZE(f,1),SIZE(f,2))
-!-------------------------------------------------------------------------------
-! Local:
-  INTEGER :: n, i, j, sta(2), sto(2)
-  REAL, ALLOCATABLE :: xc(:)                        ! (n) cell centers
-  REAL, ALLOCATABLE :: h(:), delta_xc(:)            ! (2:n-1)
-  REAL :: fm, ff, fp, dx
-!-------------------------------------------------------------------------------
-  n=SIZE(f,ix); ALLOCATE(xc(n),h(2:n-1),delta_xc(2:n-1))
-  FORALL(i=1:n) xc(i)=(x(i)+x(i+1))/2.
-  FORALL(i=2:n-1)
-    h(i)=ABS(x(i+1)-xc(i)) ; delta_xc(i)=xc(i+1)-xc(i-1)
-  END FORALL
-  slopes2(:,:)=0.
-  sta=[1,1]; sta(ix)=2
-  sto=SHAPE(f); sto(ix)=n-1
-  DO j=sta(2),sto(2); IF(ix==2) dx=delta_xc(j)
-    DO i=sta(1),sto(1); IF(ix==1) dx=delta_xc(i)
-      ff=f(i,j)
-      SELECT CASE(ix)
-        CASE(1); fm=f(i-1,j); fp=f(i+1,j)
-        CASE(2); fm=f(i,j-1); fp=f(i,j+1)
-      END SELECT
-      IF(ff>=MAX(fm,fp).OR.ff<=MIN(fm,fp)) THEN
-        slopes2(i,j)=0.; CYCLE           !--- Local extremum
-        !--- 2nd order slope ; (fm, ff, fp) strictly monotonous
-        slopes2(i,j)=(fp-fm)/dx
-        !--- Slope limitation
-        slopes2(i,j) = SIGN(MIN(ABS(slopes2(i,j)), &
-          ABS(fp-ff)/h(i),ABS(ff-fm)/h(i)),slopes2(i,j) )
-       END IF
-    END DO
-  END DO
-  DEALLOCATE(xc,h,delta_xc)
-
-END FUNCTION slopes2
-!
-!-------------------------------------------------------------------------------
-
-
-!-------------------------------------------------------------------------------
-!
-PURE FUNCTION slopes3(ix, f, x)
-!
-!-------------------------------------------------------------------------------
-! Arguments:
-  INTEGER, INTENT(IN) :: ix
-  REAL,    INTENT(IN) :: f(:, :, :)
-  REAL,    INTENT(IN) :: x(:)
-  REAL :: slopes3(SIZE(f,1),SIZE(f,2),SIZE(f,3))
-!-------------------------------------------------------------------------------
-! Local:
-  INTEGER :: n, i, j, k, sta(3), sto(3)
-  REAL, ALLOCATABLE :: xc(:)                        ! (n) cell centers
-  REAL, ALLOCATABLE :: h(:), delta_xc(:)            ! (2:n-1)
-  REAL :: fm, ff, fp, dx
-!-------------------------------------------------------------------------------
-  n=SIZE(f,ix); ALLOCATE(xc(n),h(2:n-1),delta_xc(2:n-1))
-  FORALL(i=1:n) xc(i)=(x(i)+x(i+1))/2.
-  FORALL(i=2:n-1)
-    h(i)=ABS(x(i+1)-xc(i)) ; delta_xc(i)=xc(i+1)-xc(i-1)
-  END FORALL
-  slopes3(:,:,:)=0.
-  sta=[1,1,1]; sta(ix)=2
-  sto=SHAPE(f); sto(ix)=n-1
-  DO k=sta(3),sto(3); IF(ix==3) dx=delta_xc(k)
-    DO j=sta(2),sto(2); IF(ix==2) dx=delta_xc(j)
-      DO i=sta(1),sto(1); IF(ix==1) dx=delta_xc(i)
-        ff=f(i,j,k)
-        SELECT CASE(ix)
-          CASE(1); fm=f(i-1,j,k); fp=f(i+1,j,k)
-          CASE(2); fm=f(i,j-1,k); fp=f(i,j+1,k)
-          CASE(3); fm=f(i,j,k-1); fp=f(i,j,k+1)
-        END SELECT
-        IF(ff>=MAX(fm,fp).OR.ff<=MIN(fm,fp)) THEN
-          slopes3(i,j,k)=0.; CYCLE           !--- Local extremum
-          !--- 2nd order slope ; (fm, ff, fp) strictly monotonous
-          slopes3(i,j,k)=(fp-fm)/dx
-          !--- Slope limitation
-          slopes3(i,j,k) = SIGN(MIN(ABS(slopes3(i,j,k)), &
-            ABS(fp-ff)/h(i),ABS(ff-fm)/h(i)),slopes3(i,j,k) )
-         END IF
-      END DO
-    END DO
-  END DO
-  DEALLOCATE(xc,h,delta_xc)
-
-END FUNCTION slopes3
-!
-!-------------------------------------------------------------------------------
-
-
-!-------------------------------------------------------------------------------
-!
-PURE FUNCTION slopes4(ix, f, x)
-!
-!-------------------------------------------------------------------------------
-! Arguments:
-  INTEGER, INTENT(IN) :: ix
-  REAL,    INTENT(IN) :: f(:, :, :, :)
-  REAL,    INTENT(IN) :: x(:)
-  REAL :: slopes4(SIZE(f,1),SIZE(f,2),SIZE(f,3),SIZE(f,4))
-!-------------------------------------------------------------------------------
-! Local:
-  INTEGER :: n, i, j, k, l, m, sta(4), sto(4)
-  REAL, ALLOCATABLE :: xc(:)                        ! (n) cell centers
-  REAL, ALLOCATABLE :: h(:), delta_xc(:)            ! (2:n-1)
-  REAL :: fm, ff, fp, dx
-!-------------------------------------------------------------------------------
-  n=SIZE(f,ix); ALLOCATE(xc(n),h(2:n-1),delta_xc(2:n-1))
-  FORALL(i=1:n) xc(i)=(x(i)+x(i+1))/2.
-  FORALL(i=2:n-1)
-    h(i)=ABS(x(i+1)-xc(i)) ; delta_xc(i)=xc(i+1)-xc(i-1)
-  END FORALL
-  slopes4(:,:,:,:)=0.
-  sta=[1,1,1,1]; sta(ix)=2
-  sto=SHAPE(f); sto(ix)=n-1
-  DO l=sta(4),sto(4); IF(ix==4) dx=delta_xc(l)
-    DO k=sta(3),sto(3); IF(ix==3) dx=delta_xc(k)
-      DO j=sta(2),sto(2); IF(ix==2) dx=delta_xc(j)
-        DO i=sta(1),sto(1); IF(ix==1) dx=delta_xc(i)
-          ff=f(i,j,k,l)
-          SELECT CASE(ix)
-            CASE(1); fm=f(i-1,j,k,l); fp=f(i+1,j,k,l)
-            CASE(2); fm=f(i,j-1,k,l); fp=f(i,j+1,k,l)
-            CASE(3); fm=f(i,j,k-1,l); fp=f(i,j,k+1,l)
-            CASE(4); fm=f(i,j,k,l-1); fp=f(i,j,k,l+1)
-          END SELECT
-          IF(ff>=MAX(fm,fp).OR.ff<=MIN(fm,fp)) THEN
-            slopes4(i,j,k,l)=0.; CYCLE           !--- Local extremum
-            !--- 2nd order slope ; (fm, ff, fp) strictly monotonous
-            slopes4(i,j,k,l)=(fp-fm)/dx
-            !--- Slope limitation
-            slopes4(i,j,k,l) = SIGN(MIN(ABS(slopes4(i,j,k,l)), &
-              ABS(fp-ff)/h(i),ABS(ff-fm)/h(i)),slopes4(i,j,k,l) )
-           END IF
-        END DO
-      END DO
-    END DO
-  END DO
-  DEALLOCATE(xc,h,delta_xc)
-
-END FUNCTION slopes4
-!
-!-------------------------------------------------------------------------------
-
-
-!-------------------------------------------------------------------------------
-!
-PURE FUNCTION slopes5(ix, f, x)
-!
-!-------------------------------------------------------------------------------
-! Arguments:
-  INTEGER, INTENT(IN) :: ix
-  REAL,    INTENT(IN) :: f(:, :, :, :, :)
-  REAL,    INTENT(IN) :: x(:)
-  REAL :: slopes5(SIZE(f,1),SIZE(f,2),SIZE(f,3),SIZE(f,4),SIZE(f,5))
-!-------------------------------------------------------------------------------
-! Local:
-  INTEGER :: n, i, j, k, l, m, sta(5), sto(5)
-  REAL, ALLOCATABLE :: xc(:)                        ! (n) cell centers
-  REAL, ALLOCATABLE :: h(:), delta_xc(:)            ! (2:n-1)
-  REAL :: fm, ff, fp, dx
-!-------------------------------------------------------------------------------
-  n=SIZE(f,ix); ALLOCATE(xc(n),h(2:n-1),delta_xc(2:n-1))
-  FORALL(i=1:n) xc(i)=(x(i)+x(i+1))/2.
-  FORALL(i=2:n-1)
-    h(i)=ABS(x(i+1)-xc(i)) ; delta_xc(i)=xc(i+1)-xc(i-1)
-  END FORALL
-  slopes5(:,:,:,:,:)=0.
-  sta=[1,1,1,1,1]; sta(ix)=2
-  sto=SHAPE(f);    sto(ix)=n-1
-  DO m=sta(5),sto(5); IF(ix==5) dx=delta_xc(m)
-    DO l=sta(4),sto(4); IF(ix==4) dx=delta_xc(l)
-      DO k=sta(3),sto(3); IF(ix==3) dx=delta_xc(k)
-        DO j=sta(2),sto(2); IF(ix==2) dx=delta_xc(j)
-          DO i=sta(1),sto(1); IF(ix==1) dx=delta_xc(i)
-            ff=f(i,j,k,l,m)
-            SELECT CASE(ix)
-              CASE(1); fm=f(i-1,j,k,l,m); fp=f(i+1,j,k,l,m)
-              CASE(2); fm=f(i,j-1,k,l,m); fp=f(i,j+1,k,l,m)
-              CASE(3); fm=f(i,j,k-1,l,m); fp=f(i,j,k+1,l,m)
-              CASE(4); fm=f(i,j,k,l-1,m); fp=f(i,j,k,l+1,m)
-              CASE(5); fm=f(i,j,k,l,m-1); fp=f(i,j,k,l,m+1)
-            END SELECT
-            IF(ff>=MAX(fm,fp).OR.ff<=MIN(fm,fp)) THEN
-              slopes5(i,j,k,l,m)=0.; CYCLE           !--- Local extremum
-              !--- 2nd order slope ; (fm, ff, fp) strictly monotonous
-              slopes5(i,j,k,l,m)=(fp-fm)/dx
-              !--- Slope limitation
-              slopes5(i,j,k,l,m) = SIGN(MIN(ABS(slopes5(i,j,k,l,m)), &
-                ABS(fp-ff)/h(i),ABS(ff-fm)/h(i)),slopes5(i,j,k,l,m) )
-            END IF
-          END DO
-        END DO
-      END DO
-    END DO
-  END DO
-  DEALLOCATE(xc,h,delta_xc)
-
-END FUNCTION slopes5
-!
-!-------------------------------------------------------------------------------
-
-END MODULE slopes_m
Index: /LMDZ6/trunk/libf/misc/slopes_m.f90
===================================================================
--- /LMDZ6/trunk/libf/misc/slopes_m.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/misc/slopes_m.f90	(revision 5268)
@@ -0,0 +1,283 @@
+MODULE slopes_m
+
+  ! Author: Lionel GUEZ
+  ! Extension / factorisation: David CUGNET
+
+  IMPLICIT NONE
+
+  ! Those generic function computes second order slopes with Van
+  ! Leer slope-limiting, given cell averages. Reference: Dukowicz,
+  ! 1987, SIAM Journal on Scientific and Statistical Computing, 8,
+  ! 305.
+
+  ! The only difference between the specific functions is the rank
+  ! of the first argument and the equal rank of the result.
+
+  ! slope(ix,...) acts on ix th dimension.
+
+  ! real, intent(in), rank >= 1:: f ! (n, ...) cell averages, n must be >= 1
+  ! real, intent(in):: x(:) ! (n + 1) cell edges
+  ! real slopes, same shape as f ! (n, ...)
+  INTERFACE slopes
+     MODULE procedure slopes1, slopes2, slopes3, slopes4, slopes5
+  END INTERFACE
+
+  PRIVATE
+  PUBLIC :: slopes
+
+CONTAINS
+
+!-------------------------------------------------------------------------------
+!
+PURE FUNCTION slopes1(ix, f, x)
+!
+!-------------------------------------------------------------------------------
+! Arguments:
+  INTEGER, INTENT(IN) :: ix
+  REAL,    INTENT(IN) :: f(:)
+  REAL,    INTENT(IN) :: x(:)
+  REAL :: slopes1(SIZE(f,1))
+!-------------------------------------------------------------------------------
+! Local:
+  INTEGER :: n, i, j, sta(2), sto(2)
+  REAL :: xc(SIZE(f,1))                             ! (n) cell centers
+  REAL :: h(2:SIZE(f,1)-1), delta_xc(2:SIZE(f,1)-1) ! (2:n-1)
+  REAL :: fm, ff, fp, dx
+!-------------------------------------------------------------------------------
+  n=SIZE(f,ix)
+  FORALL(i=1:n) xc(i)=(x(i)+x(i+1))/2.
+  FORALL(i=2:n-1)
+    h(i)=ABS(x(i+1)-xc(i)) ; delta_xc(i)=xc(i+1)-xc(i-1)
+  END FORALL
+  slopes1(:)=0.
+  DO i=2,n-1
+    ff=f(i); fm=f(i-1); fp=f(i+1)
+    IF(ff>=MAX(fm,fp).OR.ff<=MIN(fm,fp)) THEN
+      slopes1(i)=0.; CYCLE           !--- Local extremum
+      !--- 2nd order slope ; (fm, ff, fp) strictly monotonous
+      slopes1(i)=(fp-fm)/delta_xc(i)
+      !--- Slope limitation
+      slopes1(i) = SIGN(MIN(ABS(slopes1(i)), &
+        ABS(fp-ff)/h(i),ABS(ff-fm)/h(i)),slopes1(i) )
+     END IF
+  END DO
+
+END FUNCTION slopes1
+!
+!-------------------------------------------------------------------------------
+
+
+!-------------------------------------------------------------------------------
+!
+PURE FUNCTION slopes2(ix, f, x)
+!
+!-------------------------------------------------------------------------------
+! Arguments:
+  INTEGER, INTENT(IN) :: ix
+  REAL,    INTENT(IN) :: f(:, :)
+  REAL,    INTENT(IN) :: x(:)
+  REAL :: slopes2(SIZE(f,1),SIZE(f,2))
+!-------------------------------------------------------------------------------
+! Local:
+  INTEGER :: n, i, j, sta(2), sto(2)
+  REAL, ALLOCATABLE :: xc(:)                        ! (n) cell centers
+  REAL, ALLOCATABLE :: h(:), delta_xc(:)            ! (2:n-1)
+  REAL :: fm, ff, fp, dx
+!-------------------------------------------------------------------------------
+  n=SIZE(f,ix); ALLOCATE(xc(n),h(2:n-1),delta_xc(2:n-1))
+  FORALL(i=1:n) xc(i)=(x(i)+x(i+1))/2.
+  FORALL(i=2:n-1)
+    h(i)=ABS(x(i+1)-xc(i)) ; delta_xc(i)=xc(i+1)-xc(i-1)
+  END FORALL
+  slopes2(:,:)=0.
+  sta=[1,1]; sta(ix)=2
+  sto=SHAPE(f); sto(ix)=n-1
+  DO j=sta(2),sto(2); IF(ix==2) dx=delta_xc(j)
+    DO i=sta(1),sto(1); IF(ix==1) dx=delta_xc(i)
+      ff=f(i,j)
+      SELECT CASE(ix)
+        CASE(1); fm=f(i-1,j); fp=f(i+1,j)
+        CASE(2); fm=f(i,j-1); fp=f(i,j+1)
+      END SELECT
+      IF(ff>=MAX(fm,fp).OR.ff<=MIN(fm,fp)) THEN
+        slopes2(i,j)=0.; CYCLE           !--- Local extremum
+        !--- 2nd order slope ; (fm, ff, fp) strictly monotonous
+        slopes2(i,j)=(fp-fm)/dx
+        !--- Slope limitation
+        slopes2(i,j) = SIGN(MIN(ABS(slopes2(i,j)), &
+          ABS(fp-ff)/h(i),ABS(ff-fm)/h(i)),slopes2(i,j) )
+       END IF
+    END DO
+  END DO
+  DEALLOCATE(xc,h,delta_xc)
+
+END FUNCTION slopes2
+!
+!-------------------------------------------------------------------------------
+
+
+!-------------------------------------------------------------------------------
+!
+PURE FUNCTION slopes3(ix, f, x)
+!
+!-------------------------------------------------------------------------------
+! Arguments:
+  INTEGER, INTENT(IN) :: ix
+  REAL,    INTENT(IN) :: f(:, :, :)
+  REAL,    INTENT(IN) :: x(:)
+  REAL :: slopes3(SIZE(f,1),SIZE(f,2),SIZE(f,3))
+!-------------------------------------------------------------------------------
+! Local:
+  INTEGER :: n, i, j, k, sta(3), sto(3)
+  REAL, ALLOCATABLE :: xc(:)                        ! (n) cell centers
+  REAL, ALLOCATABLE :: h(:), delta_xc(:)            ! (2:n-1)
+  REAL :: fm, ff, fp, dx
+!-------------------------------------------------------------------------------
+  n=SIZE(f,ix); ALLOCATE(xc(n),h(2:n-1),delta_xc(2:n-1))
+  FORALL(i=1:n) xc(i)=(x(i)+x(i+1))/2.
+  FORALL(i=2:n-1)
+    h(i)=ABS(x(i+1)-xc(i)) ; delta_xc(i)=xc(i+1)-xc(i-1)
+  END FORALL
+  slopes3(:,:,:)=0.
+  sta=[1,1,1]; sta(ix)=2
+  sto=SHAPE(f); sto(ix)=n-1
+  DO k=sta(3),sto(3); IF(ix==3) dx=delta_xc(k)
+    DO j=sta(2),sto(2); IF(ix==2) dx=delta_xc(j)
+      DO i=sta(1),sto(1); IF(ix==1) dx=delta_xc(i)
+        ff=f(i,j,k)
+        SELECT CASE(ix)
+          CASE(1); fm=f(i-1,j,k); fp=f(i+1,j,k)
+          CASE(2); fm=f(i,j-1,k); fp=f(i,j+1,k)
+          CASE(3); fm=f(i,j,k-1); fp=f(i,j,k+1)
+        END SELECT
+        IF(ff>=MAX(fm,fp).OR.ff<=MIN(fm,fp)) THEN
+          slopes3(i,j,k)=0.; CYCLE           !--- Local extremum
+          !--- 2nd order slope ; (fm, ff, fp) strictly monotonous
+          slopes3(i,j,k)=(fp-fm)/dx
+          !--- Slope limitation
+          slopes3(i,j,k) = SIGN(MIN(ABS(slopes3(i,j,k)), &
+            ABS(fp-ff)/h(i),ABS(ff-fm)/h(i)),slopes3(i,j,k) )
+         END IF
+      END DO
+    END DO
+  END DO
+  DEALLOCATE(xc,h,delta_xc)
+
+END FUNCTION slopes3
+!
+!-------------------------------------------------------------------------------
+
+
+!-------------------------------------------------------------------------------
+!
+PURE FUNCTION slopes4(ix, f, x)
+!
+!-------------------------------------------------------------------------------
+! Arguments:
+  INTEGER, INTENT(IN) :: ix
+  REAL,    INTENT(IN) :: f(:, :, :, :)
+  REAL,    INTENT(IN) :: x(:)
+  REAL :: slopes4(SIZE(f,1),SIZE(f,2),SIZE(f,3),SIZE(f,4))
+!-------------------------------------------------------------------------------
+! Local:
+  INTEGER :: n, i, j, k, l, m, sta(4), sto(4)
+  REAL, ALLOCATABLE :: xc(:)                        ! (n) cell centers
+  REAL, ALLOCATABLE :: h(:), delta_xc(:)            ! (2:n-1)
+  REAL :: fm, ff, fp, dx
+!-------------------------------------------------------------------------------
+  n=SIZE(f,ix); ALLOCATE(xc(n),h(2:n-1),delta_xc(2:n-1))
+  FORALL(i=1:n) xc(i)=(x(i)+x(i+1))/2.
+  FORALL(i=2:n-1)
+    h(i)=ABS(x(i+1)-xc(i)) ; delta_xc(i)=xc(i+1)-xc(i-1)
+  END FORALL
+  slopes4(:,:,:,:)=0.
+  sta=[1,1,1,1]; sta(ix)=2
+  sto=SHAPE(f); sto(ix)=n-1
+  DO l=sta(4),sto(4); IF(ix==4) dx=delta_xc(l)
+    DO k=sta(3),sto(3); IF(ix==3) dx=delta_xc(k)
+      DO j=sta(2),sto(2); IF(ix==2) dx=delta_xc(j)
+        DO i=sta(1),sto(1); IF(ix==1) dx=delta_xc(i)
+          ff=f(i,j,k,l)
+          SELECT CASE(ix)
+            CASE(1); fm=f(i-1,j,k,l); fp=f(i+1,j,k,l)
+            CASE(2); fm=f(i,j-1,k,l); fp=f(i,j+1,k,l)
+            CASE(3); fm=f(i,j,k-1,l); fp=f(i,j,k+1,l)
+            CASE(4); fm=f(i,j,k,l-1); fp=f(i,j,k,l+1)
+          END SELECT
+          IF(ff>=MAX(fm,fp).OR.ff<=MIN(fm,fp)) THEN
+            slopes4(i,j,k,l)=0.; CYCLE           !--- Local extremum
+            !--- 2nd order slope ; (fm, ff, fp) strictly monotonous
+            slopes4(i,j,k,l)=(fp-fm)/dx
+            !--- Slope limitation
+            slopes4(i,j,k,l) = SIGN(MIN(ABS(slopes4(i,j,k,l)), &
+              ABS(fp-ff)/h(i),ABS(ff-fm)/h(i)),slopes4(i,j,k,l) )
+           END IF
+        END DO
+      END DO
+    END DO
+  END DO
+  DEALLOCATE(xc,h,delta_xc)
+
+END FUNCTION slopes4
+!
+!-------------------------------------------------------------------------------
+
+
+!-------------------------------------------------------------------------------
+!
+PURE FUNCTION slopes5(ix, f, x)
+!
+!-------------------------------------------------------------------------------
+! Arguments:
+  INTEGER, INTENT(IN) :: ix
+  REAL,    INTENT(IN) :: f(:, :, :, :, :)
+  REAL,    INTENT(IN) :: x(:)
+  REAL :: slopes5(SIZE(f,1),SIZE(f,2),SIZE(f,3),SIZE(f,4),SIZE(f,5))
+!-------------------------------------------------------------------------------
+! Local:
+  INTEGER :: n, i, j, k, l, m, sta(5), sto(5)
+  REAL, ALLOCATABLE :: xc(:)                        ! (n) cell centers
+  REAL, ALLOCATABLE :: h(:), delta_xc(:)            ! (2:n-1)
+  REAL :: fm, ff, fp, dx
+!-------------------------------------------------------------------------------
+  n=SIZE(f,ix); ALLOCATE(xc(n),h(2:n-1),delta_xc(2:n-1))
+  FORALL(i=1:n) xc(i)=(x(i)+x(i+1))/2.
+  FORALL(i=2:n-1)
+    h(i)=ABS(x(i+1)-xc(i)) ; delta_xc(i)=xc(i+1)-xc(i-1)
+  END FORALL
+  slopes5(:,:,:,:,:)=0.
+  sta=[1,1,1,1,1]; sta(ix)=2
+  sto=SHAPE(f);    sto(ix)=n-1
+  DO m=sta(5),sto(5); IF(ix==5) dx=delta_xc(m)
+    DO l=sta(4),sto(4); IF(ix==4) dx=delta_xc(l)
+      DO k=sta(3),sto(3); IF(ix==3) dx=delta_xc(k)
+        DO j=sta(2),sto(2); IF(ix==2) dx=delta_xc(j)
+          DO i=sta(1),sto(1); IF(ix==1) dx=delta_xc(i)
+            ff=f(i,j,k,l,m)
+            SELECT CASE(ix)
+              CASE(1); fm=f(i-1,j,k,l,m); fp=f(i+1,j,k,l,m)
+              CASE(2); fm=f(i,j-1,k,l,m); fp=f(i,j+1,k,l,m)
+              CASE(3); fm=f(i,j,k-1,l,m); fp=f(i,j,k+1,l,m)
+              CASE(4); fm=f(i,j,k,l-1,m); fp=f(i,j,k,l+1,m)
+              CASE(5); fm=f(i,j,k,l,m-1); fp=f(i,j,k,l,m+1)
+            END SELECT
+            IF(ff>=MAX(fm,fp).OR.ff<=MIN(fm,fp)) THEN
+              slopes5(i,j,k,l,m)=0.; CYCLE           !--- Local extremum
+              !--- 2nd order slope ; (fm, ff, fp) strictly monotonous
+              slopes5(i,j,k,l,m)=(fp-fm)/dx
+              !--- Slope limitation
+              slopes5(i,j,k,l,m) = SIGN(MIN(ABS(slopes5(i,j,k,l,m)), &
+                ABS(fp-ff)/h(i),ABS(ff-fm)/h(i)),slopes5(i,j,k,l,m) )
+            END IF
+          END DO
+        END DO
+      END DO
+    END DO
+  END DO
+  DEALLOCATE(xc,h,delta_xc)
+
+END FUNCTION slopes5
+!
+!-------------------------------------------------------------------------------
+
+END MODULE slopes_m
Index: DZ6/trunk/libf/misc/strings_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/misc/strings_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,1694 +1,0 @@
-MODULE strings_mod
-
-  IMPLICIT NONE
-
-  PRIVATE
-  PUBLIC :: maxlen, init_printout, msg, fmsg, get_in, lunout, prt_level
-  PUBLIC :: strLower, strHead, strStack,  strCount, strReduce,  strClean, strIdx
-  PUBLIC :: strUpper, strTail, strStackm, strParse, strReplace, strFind, find, cat
-  PUBLIC :: dispTable, dispOutliers, dispNameList
-  PUBLIC :: is_numeric, bool2str, int2str, real2str, dble2str
-  PUBLIC :: reduceExpr, str2bool, str2int, str2real, str2dble
-  PUBLIC :: addQuotes, checkList, removeComment
-
-  INTERFACE get_in;     MODULE PROCEDURE getin_s,  getin_i,  getin_r,  getin_l;  END INTERFACE get_in
-  INTERFACE  msg;       MODULE PROCEDURE        msg_1,                    msg_m; END INTERFACE  msg
-  INTERFACE fmsg;       MODULE PROCEDURE       fmsg_1,                   fmsg_m; END INTERFACE fmsg
-  INTERFACE strHead;    MODULE PROCEDURE    strHead_1,                strHead_m; END INTERFACE strHead
-  INTERFACE strTail;    MODULE PROCEDURE    strTail_1,                strTail_m; END INTERFACE strTail
-  INTERFACE strClean;   MODULE PROCEDURE   strClean_1,               strClean_m; END INTERFACE strClean
-  INTERFACE strReduce;  MODULE PROCEDURE  strReduce_1,              strReduce_2; END INTERFACE strReduce
-  INTERFACE strIdx;     MODULE PROCEDURE     strIdx_1,                 strIdx_m; END INTERFACE strIdx
-  INTERFACE strCount;   MODULE PROCEDURE  strCount_m1, strCount_11, strCount_1m; END INTERFACE strCount
-  INTERFACE strReplace; MODULE PROCEDURE strReplace_1,             strReplace_m; END INTERFACE strReplace
-  INTERFACE cat;        MODULE PROCEDURE  horzcat_s00, horzcat_i00, horzcat_r00,  & !horzcat_d00, &
-                                          horzcat_s10, horzcat_i10, horzcat_r10,  & !horzcat_d10, &
-                                          horzcat_s11, horzcat_i11, horzcat_r11,  & !horzcat_d11, &
-                                          horzcat_s21, horzcat_i21, horzcat_r21; END INTERFACE cat !horzcat_d21
-  INTERFACE strFind;      MODULE PROCEDURE strFind_1, strFind_m;                 END INTERFACE strFind
-  INTERFACE find;         MODULE PROCEDURE strFind_1, strFind_m, intFind_1, intFind_m, booFind; END INTERFACE find
-  INTERFACE dispOutliers; MODULE PROCEDURE dispOutliers_1, dispOutliers_2; END INTERFACE dispOutliers
-  INTERFACE reduceExpr;   MODULE PROCEDURE   reduceExpr_1,   reduceExpr_m; END INTERFACE reduceExpr
-  INTERFACE addQuotes;    MODULE PROCEDURE    addQuotes_1,    addQuotes_m; END INTERFACE addQuotes
-
-  INTEGER, PARAMETER :: maxlen    = 256                    !--- Standard maximum length for strings
-  INTEGER,      SAVE :: lunout    = 6                      !--- Printing unit  (default: 6, ie. on screen)
-  INTEGER,      SAVE :: prt_level = 1                      !--- Printing level (default: 1, ie. print all)
-
-CONTAINS
-
-
-!==============================================================================================================================
-SUBROUTINE init_printout(lunout_, prt_level_)
-  IMPLICIT NONE
-  INTEGER, INTENT(IN) :: lunout_, prt_level_
-  lunout    = lunout_
-  prt_level = prt_level_
-END SUBROUTINE init_printout
-!==============================================================================================================================
-
-
-!==============================================================================================================================
-!=== Same as getin ; additional last argument: the default value.
-!==============================================================================================================================
-SUBROUTINE getin_s(nam, val, def)
-  USE ioipsl, ONLY: getin
-  IMPLICIT NONE
-  CHARACTER(LEN=*), INTENT(IN)    :: nam
-  CHARACTER(LEN=*), INTENT(INOUT) :: val
-  CHARACTER(LEN=*), INTENT(IN)    :: def
-  val = def; CALL getin(nam, val)
-  IF(val/=def) WRITE(lunout,*)TRIM(nam)//' = '//TRIM(val)
-END SUBROUTINE getin_s
-!==============================================================================================================================
-SUBROUTINE getin_i(nam, val, def)
-  USE ioipsl, ONLY: getin
-  IMPLICIT NONE
-  CHARACTER(LEN=*), INTENT(IN)    :: nam
-  INTEGER,          INTENT(INOUT) :: val
-  INTEGER,          INTENT(IN)    :: def
-  val = def; CALL getin(nam, val)
-  IF(val/=def) WRITE(lunout,*)TRIM(nam)//' = '//TRIM(int2str(val))
-END SUBROUTINE getin_i
-!==============================================================================================================================
-SUBROUTINE getin_r(nam, val, def)
-  USE ioipsl, ONLY: getin
-  IMPLICIT NONE
-  CHARACTER(LEN=*), INTENT(IN)    :: nam
-  REAL,             INTENT(INOUT) :: val
-  REAL,             INTENT(IN)    :: def
-  val = def; CALL getin(nam, val)
-  IF(val/=def) WRITE(lunout,*)TRIM(nam)//' = '//TRIM(real2str(val))
-END SUBROUTINE getin_r
-!==============================================================================================================================
-SUBROUTINE getin_l(nam, val, def)
-  USE ioipsl, ONLY: getin
-  IMPLICIT NONE
-  CHARACTER(LEN=*), INTENT(IN)    :: nam
-  LOGICAL,          INTENT(INOUT) :: val
-  LOGICAL,          INTENT(IN)    :: def
-  val = def; CALL getin(nam, val)
-  IF(val.NEQV.def) WRITE(lunout,*)TRIM(nam)//' = '//TRIM(bool2str(val))
-END SUBROUTINE getin_l
-!==============================================================================================================================
-
-
-!==============================================================================================================================
-!=== Display one or several messages, one each line, starting with the current routine name "modname".
-!==============================================================================================================================
-SUBROUTINE msg_1(str, modname, ll, unit)
-  IMPLICIT NONE
-  !--- Display a simple message "str". Optional parameters:
-  !    * "modname": module name, displayed in front of the message (with ": " separator) if present.
-  !    * "ll":      message trigger ; message is displayed only if ll==.TRUE.
-  !    * "unit":    write unit (by default: "lunout")
-  CHARACTER(LEN=*),           INTENT(IN) :: str
-  CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: modname
-  LOGICAL,          OPTIONAL, INTENT(IN) :: ll
-  INTEGER,          OPTIONAL, INTENT(IN) :: unit
-!------------------------------------------------------------------------------------------------------------------------------
-  CHARACTER(LEN=maxlen) :: subn
-  INTEGER :: unt
-  subn = '';    IF(PRESENT(modname)) subn = modname
-  IF(PRESENT(ll)) THEN; IF(.NOT.ll) RETURN; END IF
-  unt = lunout; IF(PRESENT(unit)) unt = unit
-  IF(subn == '') WRITE(unt,'(a)') str                                          !--- Simple message
-  IF(subn /= '') WRITE(unt,'(a)') TRIM(subn)//': '//str                        !--- Routine name provided
-END SUBROUTINE msg_1
-!==============================================================================================================================
-SUBROUTINE msg_m(str, modname, ll, unit, nmax)
-  IMPLICIT NONE
-  !--- Same as msg_1 with multiple strings that are stacked (separator: coma) on up to "nmax" full lines.
-  CHARACTER(LEN=*),           INTENT(IN) :: str(:)
-  CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: modname
-  LOGICAL,          OPTIONAL, INTENT(IN) :: ll
-  INTEGER,          OPTIONAL, INTENT(IN) :: unit
-  INTEGER,          OPTIONAL, INTENT(IN) :: nmax
-!------------------------------------------------------------------------------------------------------------------------------
-  CHARACTER(LEN=maxlen), ALLOCATABLE :: s(:)
-  CHARACTER(LEN=maxlen) :: subn
-  INTEGER :: unt, nmx, k
-  LOGICAL :: l
-  subn = '';    IF(PRESENT(modname)) subn = modname
-  l   = .TRUE.; IF(PRESENT(ll))     l = ll
-  unt = lunout; IF(PRESENT(unit)) unt = unit
-  nmx = 128;    IF(PRESENT(nmax)) nmx = nmax
-  s = strStackm(str, ', ', nmx)
-  DO k=1,SIZE(s); CALL msg_1(s(k), subn,  l,   unt); END DO
-END SUBROUTINE msg_m
-!==============================================================================================================================
-LOGICAL FUNCTION fmsg_1(str, modname, ll, unit) RESULT(l)
-  IMPLICIT NONE
-  CHARACTER(LEN=*),           INTENT(IN) :: str
-  CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: modname
-  LOGICAL,          OPTIONAL, INTENT(IN) :: ll
-  INTEGER,          OPTIONAL, INTENT(IN) :: unit
-!------------------------------------------------------------------------------------------------------------------------------
-  CHARACTER(LEN=maxlen) :: subn
-  INTEGER :: unt
-  subn = '';    IF(PRESENT(modname)) subn = modname
-  l   = .TRUE.; IF(PRESENT(ll))     l = ll
-  unt = lunout; IF(PRESENT(unit)) unt = unit
-  CALL msg_1(str, subn, l, unt)
-END FUNCTION fmsg_1
-!==============================================================================================================================
-LOGICAL FUNCTION fmsg_m(str, modname, ll, unit, nmax) RESULT(l)
-  IMPLICIT NONE
-  CHARACTER(LEN=*),           INTENT(IN)  :: str(:)
-  CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: modname
-  LOGICAL,          OPTIONAL, INTENT(IN) :: ll
-  INTEGER,          OPTIONAL, INTENT(IN) :: unit
-  INTEGER,          OPTIONAL, INTENT(IN)  :: nmax
-!------------------------------------------------------------------------------------------------------------------------------
-  CHARACTER(LEN=maxlen) :: subn
-  INTEGER :: unt, nmx
-  subn = '';    IF(PRESENT(modname)) subn = modname
-  l   = .TRUE.; IF(PRESENT(ll))     l = ll
-  unt = lunout; IF(PRESENT(unit)) unt = unit
-  nmx = 128;    IF(PRESENT(nmax)) nmx = nmax
-  CALL msg_m(str, subn, l, unt, nmx)
-END FUNCTION fmsg_m
-!==============================================================================================================================
-
-
-!==============================================================================================================================
-!=== Lower/upper case conversion function. ====================================================================================
-!==============================================================================================================================
-ELEMENTAL CHARACTER(LEN=maxlen) FUNCTION strLower(str) RESULT(out)
-  IMPLICIT NONE
-  CHARACTER(LEN=*), INTENT(IN) :: str
-  INTEGER :: k
-  out = str
-  DO k=1,LEN_TRIM(str)
-    IF(str(k:k)>='A' .AND. str(k:k)<='Z') out(k:k)=ACHAR(IACHAR(str(k:k))+32)
-  END DO
-END FUNCTION strLower
-!==============================================================================================================================
-ELEMENTAL CHARACTER(LEN=maxlen) FUNCTION strUpper(str) RESULT(out)
-  IMPLICIT NONE
-  CHARACTER(LEN=*), INTENT(IN) :: str
-  INTEGER :: k
-  out = str
-  DO k=1,LEN_TRIM(str)
-    IF(str(k:k)>='a' .AND. str(k:k)<='z') out(k:k)=ACHAR(IACHAR(str(k:k))-32)
-  END DO
-END FUNCTION strUpper
-!==============================================================================================================================
-
-
-!==============================================================================================================================
-!=== Extract the substring in front of the first (last if lBackward==TRUE) occurrence of "sep" in "str"        ================
-!=== Examples for str='a_b_c' and sep='_' and the bash command with the same effect:                           ================
-!===    * strHead(..,.FALSE.) = 'a'           ${str%%$sep*}                                                    ================
-!===    * strHead(..,.TRUE.)  = 'a_b'         ${str%$sep*}                                                     ================
-!==============================================================================================================================
-CHARACTER(LEN=maxlen) FUNCTION strHead_1(str, sep, lBackward) RESULT(out)
-  IMPLICIT NONE
-  CHARACTER(LEN=*),           INTENT(IN) :: str
-  CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: sep
-  LOGICAL,          OPTIONAL, INTENT(IN) :: lBackward
-!------------------------------------------------------------------------------------------------------------------------------
-  IF(PRESENT(sep)) THEN
-    IF(     PRESENT(lBackWard)) out = str(1:INDEX(str,sep,lBackWard)-1)
-    IF(.NOT.PRESENT(lBackWard)) out = str(1:INDEX(str,sep)-1)
-  ELSE
-    IF(     PRESENT(lBackWard)) out = str(1:INDEX(str,'/',lBackWard)-1)
-    IF(.NOT.PRESENT(lBackWard)) out = str(1:INDEX(str,'/')-1)
-  END IF
-  IF(out == '') out = str
-END FUNCTION strHead_1
-!==============================================================================================================================
-FUNCTION strHead_m(str, sep, lBackward) RESULT(out)
-  IMPLICIT NONE
-  CHARACTER(LEN=maxlen),     ALLOCATABLE :: out(:)
-  CHARACTER(LEN=*),           INTENT(IN) :: str(:)
-  CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: sep
-  LOGICAL,          OPTIONAL, INTENT(IN) :: lBackward
-!------------------------------------------------------------------------------------------------------------------------------
-  INTEGER :: k
-  IF(PRESENT(sep)) THEN
-    IF(     PRESENT(lBackWard)) out = [(strHead_1(str(k), sep, lBackWard), k=1, SIZE(str))]
-    IF(.NOT.PRESENT(lBackWard)) out = [(strHead_1(str(k), sep),            k=1, SIZE(str))]
-  ELSE
-    IF(     PRESENT(lBackWard)) out = [(strHead_1(str(k), '/', lBackWard), k=1, SIZE(str))]
-    IF(.NOT.PRESENT(lBackWard)) out = [(strHead_1(str(k), '/'),            k=1, SIZE(str))]
-  END IF
-END FUNCTION strHead_m
-!==============================================================================================================================
-!=== Extract the substring following the first (last if lBackward==TRUE) occurrence of "sep" in "str"          ================
-!=== Examples for str='a_b_c' and sep='_' and the bash command with the same effect:                           ================
-!===    * strTail(str, '_', .FALSE.) = 'b_c'         ${str#*$sep}                                              ================
-!===    * strTail(str, '_', .TRUE.)  = 'c'           ${str##*$sep}                                             ================
-!==============================================================================================================================
-CHARACTER(LEN=maxlen) FUNCTION strTail_1(str, sep, lBackWard) RESULT(out)
-  IMPLICIT NONE
-  CHARACTER(LEN=*),           INTENT(IN) :: str
-  CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: sep
-  LOGICAL,          OPTIONAL, INTENT(IN) :: lBackWard
-!------------------------------------------------------------------------------------------------------------------------------
-  IF(PRESENT(sep)) THEN
-    IF(     PRESENT(lBackWard)) out = str(INDEX(str,sep,lBackWard)+LEN(sep):LEN_TRIM(str))
-    IF(.NOT.PRESENT(lBackWard)) out = str(INDEX(str,sep)          +LEN(sep):LEN_TRIM(str))
-  ELSE
-    IF(     PRESENT(lBackWard)) out = str(INDEX(str,'/',lBackWard)+1:LEN_TRIM(str))
-    IF(.NOT.PRESENT(lBackWard)) out = str(INDEX(str,'/')          +1:LEN_TRIM(str))
-  END IF
-  IF(out == '') out = str
-END FUNCTION strTail_1
-!==============================================================================================================================
-FUNCTION strTail_m(str, sep, lBackWard) RESULT(out)
-  IMPLICIT NONE
-  CHARACTER(LEN=maxlen),     ALLOCATABLE :: out(:)
-  CHARACTER(LEN=*),           INTENT(IN) :: str(:)
-  CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: sep
-  LOGICAL,          OPTIONAL, INTENT(IN) :: lBackWard
-!------------------------------------------------------------------------------------------------------------------------------
-  INTEGER :: k
-  IF(PRESENT(sep)) THEN
-    IF(     PRESENT(lBackWard)) out = [(strTail_1(str(k), sep, lBackWard), k=1, SIZE(str))]
-    IF(.NOT.PRESENT(lBackWard)) out = [(strTail_1(str(k), sep),            k=1, SIZE(str))]
-  ELSE
-    IF(     PRESENT(lBackWard)) out = [(strTail_1(str(k), '/', lBackWard), k=1, SIZE(str))]
-    IF(.NOT.PRESENT(lBackWard)) out = [(strTail_1(str(k), '/'),            k=1, SIZE(str))]
-  END IF
-END FUNCTION strTail_m
-!==============================================================================================================================
-
-
-!==============================================================================================================================
-!=== Concatenates the strings "str(:)" with separator "sep" into a single string using a separator (',' by default). ==========
-!==============================================================================================================================
-FUNCTION strStack(str, sep, mask) RESULT(out)
-  IMPLICIT NONE
-  CHARACTER(LEN=:),          ALLOCATABLE :: out
-  CHARACTER(LEN=*),           INTENT(IN) :: str(:)
-  CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: sep
-  LOGICAL,          OPTIONAL, INTENT(IN) :: mask(:)
-!------------------------------------------------------------------------------------------------------------------------------
-  CHARACTER(LEN=:), ALLOCATABLE :: s
-  INTEGER :: is, i0
-  IF(SIZE(str) == 0) THEN; out = ''; RETURN; END IF
-  ALLOCATE(s, SOURCE=', '); IF(PRESENT(sep)) s=sep
-  IF(PRESENT(mask)) THEN
-    IF(ALL(.NOT.mask)) THEN; out = ''; RETURN; END IF
-    i0 = 0; DO WHILE(.NOT.mask(i0+1)); i0 = i0+1; END DO
-    out = str(i0); DO is=i0+1,SIZE(str, DIM=1); IF(.NOT.mask(is)) CYCLE; out = TRIM(out)//s//TRIM(str(is)); END DO
-  ELSE
-    out = str(1); DO is=2,SIZE(str, DIM=1); out = TRIM(out)//s//TRIM(str(is)); END DO
-  END IF
-END FUNCTION strStack
-!==============================================================================================================================
-!=== Concatenate the strings "str(:)" with separator "sep" into one or several lines of "nmax" characters max (for display) ===
-!==============================================================================================================================
-FUNCTION strStackm(str, sep, nmax) RESULT(out)
-  IMPLICIT NONE
-  CHARACTER(LEN=maxlen),     ALLOCATABLE :: out(:)
-  CHARACTER(LEN=*),           INTENT(IN) :: str(:)
-  CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: sep
-  INTEGER,          OPTIONAL, INTENT(IN) :: nmax
-!------------------------------------------------------------------------------------------------------------------------------
-  CHARACTER(LEN=maxlen), ALLOCATABLE :: t(:)
-  CHARACTER(LEN=maxlen) :: sp
-  INTEGER :: is, ns, no, mx, n
-  IF(SIZE(str) == 0) THEN; out = ['']; RETURN; END IF
-  sp =', '; IF(PRESENT(sep )) sp = sep
-  ns = 2  ; IF(PRESENT(sep )) ns = LEN(sep)
-  mx = 256; IF(PRESENT(nmax)) mx = nmax
-  no = 1; out = ['']
-  DO is = 1, SIZE(str)
-    n = LEN_TRIM(str(is)); IF(out(no)/='') n = n+ns+LEN_TRIM(out(no))          !--- Line length after "str(is)" inclusion
-    IF(out(no) == '') THEN
-      out(no) = str(is)                                                        !--- Empty new line: set to "str(is)"
-    ELSE IF(n <= mx) THEN
-      out(no) = TRIM(out(no))//sp(1:ns)//TRIM(str(is))                         !--- Append "str(is)" to the current line
-    ELSE
-      ALLOCATE(t(no+1)); t(1:no) = out; no=no+1; t(no) = str(is)               !--- Full line: "str(si)" put in next line
-      CALL MOVE_ALLOC(FROM=t, TO=out)
-    END IF
-  END DO
-END FUNCTION strStackm
-!==============================================================================================================================
-
-
-!==============================================================================================================================
-!=== String cleaning: replace tabulation by spaces, remove NULL characters and comments. ======================================
-!==============================================================================================================================
-SUBROUTINE strClean_1(str)
-  IMPLICIT NONE
-  CHARACTER(LEN=*), INTENT(INOUT) :: str
-  INTEGER :: k, n, m
-  n = LEN(str)
-  DO k = n, 1, -1
-    m = IACHAR(str(k:k))
-    IF(m==9) str(k:k) = ' '                           !--- Replace the tabulations with spaces
-    IF(m==0) str(k:n) = str(k+1:n)//' '               !--- Remove the NULL characters
-  END DO
-  m = INDEX(str,'!')-1; IF(m==-1) m = LEN_TRIM(str)   !--- Remove end of line comment
-  str = ADJUSTL(str(1:m))
-END SUBROUTINE strClean_1
-!==============================================================================================================================
-SUBROUTINE strClean_m(str)
-  IMPLICIT NONE
-  CHARACTER(LEN=*), INTENT(INOUT) :: str(:)
-  INTEGER :: k
-  DO k = 1, SIZE(str); CALL strClean_1(str(k)); END DO
-END SUBROUTINE strClean_m
-!==============================================================================================================================
-
-
-!==============================================================================================================================
-!=== strReduce_1(str1)     : Remove duplicated elements of str1.    ===========================================================
-!=== strReduce_2(str1,str2): Append str1 with new elements of str2. ===========================================================
-!==============================================================================================================================
-SUBROUTINE strReduce_1(str, nb)
-  IMPLICIT NONE
-  CHARACTER(LEN=*), ALLOCATABLE, INTENT(INOUT) :: str(:)
-  INTEGER,          OPTIONAL,    INTENT(OUT)   :: nb
-!------------------------------------------------------------------------------------------------------------------------------
-  CHARACTER(LEN=maxlen), ALLOCATABLE :: s1(:)
-  INTEGER :: k, n, n1
-  IF(PRESENT(nb)) nb = 0
-  CALL MOVE_ALLOC(FROM=str, TO=s1); CALL strClean(s1)
-  n1 = SIZE(s1, DIM=1)                                     !--- Total nb. of elements in "s1"
-  n  = COUNT( [( ALL(s1(1:k-1)/=s1(k)), k=1, n1 )] )       !--- Nb of unique elements in "s1"
-  ALLOCATE(str(n))
-  IF(n==0) RETURN
-  str(1) = s1(1)
-  n=1; DO k=2,n1; IF(ANY(s1(1:k-1)==s1(k))) CYCLE; n=n+1; str(n)=s1(k); END DO
-  IF(PRESENT(nb)) nb=n
-END SUBROUTINE strReduce_1
-!==============================================================================================================================
-SUBROUTINE strReduce_2(str1, str2)
-  IMPLICIT NONE
-  CHARACTER(LEN=*),   ALLOCATABLE, INTENT(INOUT) :: str1(:)
-  CHARACTER(LEN=*),                INTENT(IN)    :: str2(:)
-!------------------------------------------------------------------------------------------------------------------------------
-  CHARACTER(LEN=maxlen), ALLOCATABLE :: s1(:), s2(:)
-  INTEGER :: k
-  IF(SIZE(str2)==0) RETURN
-  s2 = str2; CALL strClean(s2)
-  IF(.NOT.ALLOCATED(s2)) RETURN
-  IF(SIZE(s2) == 0) THEN; DEALLOCATE(s2); RETURN; END IF
-  IF(.NOT.ALLOCATED(str1)) THEN
-    str1 = s2
-  ELSE IF(SIZE(str1)==0) THEN
-    str1 = s2
-  ELSE
-    s1 = str1; CALL strClean(s1)
-    str1 = [s1, PACK(s2, MASK= [( ALL(s1(:) /= s2(k)), k=1, SIZE(s2) )] ) ]
-  END IF
-END SUBROUTINE strReduce_2
-!==============================================================================================================================
-
-
-!==============================================================================================================================
-!=== GET THE INDEX OF THE FIRST APPEARANCE IN THE STRING VECTOR "str(:)" OF THE STRING(s) "s[(:)]" ============================
-!=== OPTIONALY: GET THE NUMBER OF FOUND ELEMENTS "n". NB: UNFOUND => INDEX=0                       ============================
-!==============================================================================================================================
-INTEGER FUNCTION strIdx_1(str, s) RESULT(out)
-  IMPLICIT NONE
-  CHARACTER(LEN=*), INTENT(IN) :: str(:), s
-  DO out = 1, SIZE(str); IF(str(out) == s) EXIT; END DO
-  IF(out == 1+SIZE(str) .OR. SIZE(str)==0) out = 0
-END FUNCTION strIdx_1
-!==============================================================================================================================
-FUNCTION strIdx_m(str, s, n) RESULT(out)
-  IMPLICIT NONE
-  CHARACTER(LEN=*),  INTENT(IN)  :: str(:), s(:)
-  INTEGER, OPTIONAL, INTENT(OUT) :: n
-  INTEGER,           ALLOCATABLE :: out(:)
-!------------------------------------------------------------------------------------------------------------------------------
-  INTEGER :: k
-  out = [(strIdx_1(str(:), s(k)), k=1, SIZE(s))]
-  IF(PRESENT(n)) n = COUNT(out(:)/=0)
-END FUNCTION strIdx_m
-!==============================================================================================================================
-
-
-!==============================================================================================================================
-!=== GET THE INDEX LIST OF THE ELEMENTS OF "str(:)" EQUAL TO "s" AND OPTIONALY, ITS LENGTH "n" ================================
-!==============================================================================================================================
-FUNCTION strFind_1(str, s, n) RESULT(out)
-  IMPLICIT NONE
-  CHARACTER(LEN=*),  INTENT(IN)  :: str(:), s
-  INTEGER, OPTIONAL, INTENT(OUT) :: n
-  INTEGER,           ALLOCATABLE :: out(:)
-!------------------------------------------------------------------------------------------------------------------------------
-  INTEGER :: k
-  out = PACK( [(k, k=1, SIZE(str(:), DIM=1))], MASK = str(:) == s )
-  IF(PRESENT(n)) n = SIZE(out(:), DIM=1)
-END FUNCTION strFind_1
-!==============================================================================================================================
-FUNCTION strFind_m(str, s, n) RESULT(out)
-  IMPLICIT NONE
-  CHARACTER(LEN=*),  INTENT(IN)  :: str(:), s(:)
-  INTEGER, OPTIONAL, INTENT(OUT) :: n
-  INTEGER,           ALLOCATABLE :: out(:)
-!------------------------------------------------------------------------------------------------------------------------------
-  INTEGER :: k
-  out = [(strFind_1(str, s(k)), k=1, SIZE(s))]
-  IF(PRESENT(n)) n = SIZE(out(:), DIM=1)
-END FUNCTION strFind_m
-!==============================================================================================================================
-FUNCTION intFind_1(i,j,n) RESULT(out)
-  IMPLICIT NONE
-  INTEGER,           INTENT(IN)  :: i(:), j
-  INTEGER, OPTIONAL, INTENT(OUT) :: n
-  INTEGER,           ALLOCATABLE :: out(:)
-!------------------------------------------------------------------------------------------------------------------------------
-  INTEGER :: k
-  out = PACK( [(k, k=1, SIZE(i(:), DIM=1))], MASK = i(:) == j )
-  IF(PRESENT(n)) n = SIZE(out(:), DIM=1)
-END FUNCTION intFind_1
-!==============================================================================================================================
-FUNCTION intFind_m(i,j,n) RESULT(out)
-  IMPLICIT NONE
-  INTEGER,           INTENT(IN)  :: i(:), j(:)
-  INTEGER, OPTIONAL, INTENT(OUT) :: n
-  INTEGER,           ALLOCATABLE :: out(:)
-!------------------------------------------------------------------------------------------------------------------------------
-  INTEGER :: k
-  out = [(intFind_1(i, j(k)), k=1, SIZE(j))]
-  IF(PRESENT(n)) n = SIZE(out(:), DIM=1)
-END FUNCTION intFind_m
-!==============================================================================================================================
-FUNCTION booFind(l,n) RESULT(out)
-   IMPLICIT NONE
- LOGICAL,           INTENT(IN)  :: l(:)
-  INTEGER, OPTIONAL, INTENT(OUT) :: n
-  INTEGER,           ALLOCATABLE :: out(:)
-!------------------------------------------------------------------------------------------------------------------------------
-  INTEGER :: k
-  out = PACK( [(k, k=1, SIZE(l(:), DIM=1))], MASK = l(:) )
-  IF(PRESENT(n)) n = SIZE(out(:), DIM=1)
-END FUNCTION booFind
-!==============================================================================================================================
-
-
-!==============================================================================================================================
-!=== GET THE INDEX IN "rawList" OF THE 1ST APPEARANCE OF ONE OF THE "del(:)" SEPARATORS (0 IF NONE OF THEM ARE PRESENT)
-!===  IF lSc == .TRUE.:  * SKIP HEAD SIGNS OR EXPONENTS SIGNS THAT SHOULD NOT BE CONFUSED WITH SEPARATORS
-!===                     * THEN TEST WHETHER THE STRING FROM START TO THE FOUND SEPARATOR IS A CORRECTLY FORMATTED NUMBER
-!==============================================================================================================================
-LOGICAL FUNCTION strIdx_prv(rawList, del, ibeg, idx, idel, lSc) RESULT(lerr)
-  IMPLICIT NONE
-  CHARACTER(LEN=*),  INTENT(IN)  :: rawList                          !--- String in which delimiters have to be identified
-  CHARACTER(LEN=*),  INTENT(IN)  :: del(:)                           !--- List of delimiters
-  INTEGER,           INTENT(IN)  :: ibeg                             !--- Start index
-  INTEGER,           INTENT(OUT) :: idx                              !--- Index of the first identified delimiter in "rawList"
-  INTEGER,           INTENT(OUT) :: idel                             !--- Index of the identified delimiter (0 if idx==0)
-  LOGICAL, OPTIONAL, INTENT(IN)  :: lSc                              !--- Care about nbs with front sign or in scient. notation
-!------------------------------------------------------------------------------------------------------------------------------
-  INTEGER :: idx0                                                    !--- Used to display an identified non-numeric string
-  lerr = .FALSE.
-  idx = strIdx1(rawList, del, ibeg, idel)                            !--- idx/=0: del(idel) is at position "idx" in "rawList" 
-  IF(.NOT.PRESENT(lSc))               RETURN                         !--- No need to check exceptions for numbers => finished
-  IF(.NOT.        lSc )               RETURN                         !--- No need to check exceptions for numbers => finished
-
-  !=== No delimiter found: the whole string must be a valid number
-  IF(idx == 0) THEN                                                  !--- No element of "del" in "rawList"
-    lerr = .NOT.is_numeric(rawList(ibeg:LEN_TRIM(rawList)))          !--- String must be a number
-    IF(lerr) idx = LEN_TRIM(rawList); RETURN                         !--- Set idx so that rawList(ibeg:idx-1) = whole string
-  END IF
-
-  lerr = idx == 1 .AND. INDEX('+-',del(idel)) /= 0; IF(lerr) RETURN  !--- The front delimiter is different from +/-: error
-  IF(    idx /= 1 .AND. is_numeric(rawList(ibeg:idx-1)))     RETURN  !--- The input string head is a valid number
-
-  !=== The string part in front of the 1st delimiter is not a valid number: search for next delimiter index "idx"
-  idx0 = idx ; idx = strIdx1(rawList, del, idx+1, idel)              !--- Keep start index because idx is recycled
-  IF(idx == 0) THEN
-    lerr = .NOT.is_numeric(rawList(ibeg:LEN_TRIM(rawList)))          !--- No other delimiter: whole string must be a valid numb
-    IF(lerr) idx = idx0; RETURN
-  END IF
-  lerr = .NOT.is_numeric(rawList(ibeg:idx-1))
-
-CONTAINS
-
-!------------------------------------------------------------------------------------------------------------------------------
-INTEGER FUNCTION strIdx1(str, del, ib, id) RESULT(i)
-!--- Get the index of the first appereance of one of the delimiters "del(:)" in "str" starting from position "ib".
-!--- "id" is the index in "del(:)" of the first delimiter found.
-  IMPLICIT NONE
-  CHARACTER(LEN=*),  INTENT(IN)  :: str, del(:)
-  INTEGER,           INTENT(IN)  :: ib
-  INTEGER,           INTENT(OUT) :: id
-!------------------------------------------------------------------------------------------------------------------------------
-  DO i = ib, LEN_TRIM(str); id = strIdx(del, str(i:i)); IF(id /= 0) EXIT; END DO
-  IF(i > LEN_TRIM(str)) THEN; i = 0; id = 0; END IF
-END FUNCTION strIdx1
-
-END FUNCTION strIdx_prv
-!==============================================================================================================================
-
-
-!==============================================================================================================================
-!=== Count the number of elements separated by "delimiter" in list "rawList". =================================================
-!==============================================================================================================================
-LOGICAL FUNCTION strCount_11(rawList, delimiter, nb, lSc) RESULT(lerr)
-  IMPLICIT NONE
-  CHARACTER(LEN=*),  INTENT(IN)  :: rawList
-  CHARACTER(LEN=*),  INTENT(IN)  :: delimiter
-  INTEGER,           INTENT(OUT) :: nb
-  LOGICAL, OPTIONAL, INTENT(IN)  :: lSc
-!------------------------------------------------------------------------------------------------------------------------------
-  LOGICAL :: ll
-  ll = .FALSE.; IF(PRESENT(lSc)) ll = lSc
-  lerr = strCount_1m(rawList, [delimiter], nb, ll)
-END FUNCTION strCount_11
-!==============================================================================================================================
-LOGICAL FUNCTION strCount_m1(rawList, delimiter, nb, lSc) RESULT(lerr)
-  IMPLICIT NONE
-  CHARACTER(LEN=*),     INTENT(IN)  :: rawList(:)
-  CHARACTER(LEN=*),     INTENT(IN)  :: delimiter
-  INTEGER, ALLOCATABLE, INTENT(OUT) :: nb(:)
-  LOGICAL,    OPTIONAL, INTENT(IN)  :: lSc
-!------------------------------------------------------------------------------------------------------------------------------
-  LOGICAL :: ll
-  INTEGER :: id
-  ll  = .FALSE.; IF(PRESENT(lSc)) ll = lSc .AND. INDEX('+-', delimiter) /= 0
-  lerr = .TRUE.
-  ALLOCATE(nb(SIZE(rawList)))
-  DO id = 1, SIZE(rawList)
-    lerr = lerr .AND. strCount_1m(rawList(id), [delimiter], nb(id), ll)
-  END DO
-END FUNCTION strCount_m1
-!==============================================================================================================================
-LOGICAL FUNCTION strCount_1m(rawList, delimiter, nb, lSc) RESULT(lerr)
-  IMPLICIT NONE
-  CHARACTER(LEN=*),  INTENT(IN)  :: rawList
-  CHARACTER(LEN=*),  INTENT(IN)  :: delimiter(:)
-  INTEGER,           INTENT(OUT) :: nb
-  LOGICAL, OPTIONAL, INTENT(IN)  :: lSc
-!------------------------------------------------------------------------------------------------------------------------------
-  INTEGER              :: ib, ie, jd, nr
-  LOGICAL              :: ll
-  CHARACTER(LEN=1024)  :: r
-  lerr = .FALSE.
-  ll   = .FALSE.; IF(PRESENT(lSc)) ll = lSc
-  r  = TRIM(ADJUSTL(rawList))
-  nr = LEN_TRIM(r); IF(nr == 0) RETURN
-  nb = 1; ib = 1
-  DO
-    lerr = strIdx_prv(r, delimiter, ib, ie, jd, ll)
-    IF(fmsg('"'//TRIM(r(ib:ie-1))//'" is not numeric', ll=lerr)) RETURN
-    IF(ie == 0 .OR. jd == 0) EXIT
-    ib = ie + LEN(delimiter(jd))
-    DO WHILE(r(ib:ib) == ' ' .AND. ib < nr); ib = ib + 1; END DO     !--- Skip spaces before next chain
-    nb = nb + 1
-  END DO
-END FUNCTION strCount_1m
-!==============================================================================================================================
-
-
-!==============================================================================================================================
-!=== Purpose: Parse "delimiter"-separated list "rawList" into the pair keys(:), vals(:).   ====================================
-!===          Corresponding "vals" remains empty if the element does not contain "=" sign. ====================================
-!==============================================================================================================================
-LOGICAL FUNCTION strParse(rawList, delimiter, keys, n, vals) RESULT(lerr)
-  IMPLICIT NONE
-  CHARACTER(LEN=*),                             INTENT(IN)  :: rawList, delimiter
-  CHARACTER(LEN=maxlen), ALLOCATABLE,           INTENT(OUT) :: keys(:)
-  INTEGER,                            OPTIONAL, INTENT(OUT) :: n
-  CHARACTER(LEN=maxlen), ALLOCATABLE, OPTIONAL, INTENT(OUT) :: vals(:)
-!------------------------------------------------------------------------------------------------------------------------------
-  CHARACTER(LEN=1024) :: r
-  INTEGER :: nr, nk
-  lerr = .FALSE.
-  r  = TRIM(ADJUSTL(rawList))
-  nr = LEN_TRIM(r); IF(nr == 0) THEN; keys = ['']; RETURN; END IF
-  nk = countK()                                                      !--- COUNT THE ELEMENTS
-  CALL parseK(keys)                                                  !--- PARSE THE KEYS
-  IF(PRESENT(vals)) CALL parseV(vals)                                !--- PARSE <key>=<val> PAIRS
-  IF(PRESENT(n)) n = nk                                              !--- RETURN THE NUMBER OF KEYS
-
-CONTAINS
-
-!------------------------------------------------------------------------------------------------------------------------------
-INTEGER FUNCTION countK() RESULT(nkeys)
-!--- Get the number of elements after parsing.
-  IMPLICIT NONE
-!------------------------------------------------------------------------------------------------------------------------------
-  INTEGER :: ib, ie, nl
-  nkeys = 1; ib = 1; nl = LEN(delimiter)
-  DO
-    ie = INDEX(rawList(ib:nr), delimiter)+ib-1                       !--- Determine the next separator start index
-    IF(ie == ib-1) EXIT
-    ib = ie + nl
-    DO WHILE(ANY([0, 9, 32] == IACHAR(r(ib:ib))) .AND. ib < nr)      !--- Skip blanks (ascii): NULL (0), TAB (9), SPACE (32)
-      ib = ib + 1
-    END DO     !--- Skip spaces before next chain
-    nkeys = nkeys+1
-  END DO
-END FUNCTION countK
-
-!------------------------------------------------------------------------------------------------------------------------------
-SUBROUTINE parseK(keys)
-!--- Parse the string separated by "delimiter" from "rawList" into "keys(:)"
-  IMPLICIT NONE
-  CHARACTER(LEN=maxlen), ALLOCATABLE, INTENT(OUT) :: keys(:)
-!------------------------------------------------------------------------------------------------------------------------------
-  INTEGER :: ib, ie, ik
-  ALLOCATE(keys(nk))
-  ib = 1
-  DO ik = 1, nk
-    ie = INDEX(rawList(ib:nr), delimiter)+ib-1                       !--- Determine the next separator start index
-    IF(ie == ib-1) EXIT
-    keys(ik) = r(ib:ie-1)                                            !--- Get the ikth key
-    ib = ie + LEN(delimiter)
-    DO WHILE(r(ib:ib) == ' ' .AND. ib < nr); ib = ib + 1; END DO     !--- Skip spaces before next chain
-  END DO
-  keys(ik) = r(ib:nr)                                                !--- Get the last key
-END SUBROUTINE parseK
-
-!------------------------------------------------------------------------------------------------------------------------------
-SUBROUTINE parseV(vals)
-!--- Parse the <key>=<val> pairs in "keys(:)" into "keys" and "vals"
-  IMPLICIT NONE
-  CHARACTER(LEN=maxlen), ALLOCATABLE, INTENT(OUT) :: vals(:)
-!------------------------------------------------------------------------------------------------------------------------------
-  CHARACTER(LEN=maxlen) :: key
-  INTEGER :: ik, ix
-  ALLOCATE(vals(nk))
-  DO ik = 1, nk; key = keys(ik)
-    vals(ik) = ''
-    ix = INDEX(key, '='); IF(ix == 0) CYCLE                          !--- First "=" index in "key"
-    vals(ik) = ADJUSTL(key(ix+1:LEN_TRIM(key)))
-    keys(ik) = ADJUSTL(key(1:ix-1))
-  END DO
-END SUBROUTINE parseV
-
-END FUNCTION strParse
-!==============================================================================================================================
-LOGICAL FUNCTION strParse_m(rawList, delimiter, keys, n, vals, lSc, id) RESULT(lerr)
-  IMPLICIT NONE
-  CHARACTER(LEN=*),                             INTENT(IN)  :: rawList, delimiter(:)
-  CHARACTER(LEN=maxlen),           ALLOCATABLE, INTENT(OUT) :: keys(:)  !--- Parsed keys vector
-  INTEGER,               OPTIONAL,              INTENT(OUT) :: n        !--- Length of the parsed vector
-  CHARACTER(LEN=maxlen), OPTIONAL, ALLOCATABLE, INTENT(OUT) :: vals(:)  !--- Values for <name>=<value> keys
-  LOGICAL,               OPTIONAL,              INTENT(IN)  :: lSc      !--- Take care about numbers in scientific notation
-  INTEGER,               OPTIONAL, ALLOCATABLE, INTENT(OUT) :: id(:)    !--- Indexes of the separators in "delimiter(:)" vector
-!------------------------------------------------------------------------------------------------------------------------------
-  CHARACTER(LEN=1024) :: r
-  INTEGER :: nr, ik, nk, ib, ie, jd
-  LOGICAL :: ll
-  ll = .FALSE.; IF(PRESENT(lSc)) ll = lSc
-  lerr = strCount_1m(rawList, delimiter, nk, ll)
-  CALL msg("Couldn't parse list: non-numerical strings were found", ll=lerr); IF(lerr) RETURN
-
-  !--- FEW ALLOCATIONS
-  ALLOCATE(keys(nk))
-  IF(PRESENT(vals)) ALLOCATE(vals(nk))
-  IF(PRESENT(id))   ALLOCATE(id(nk-1))
-  IF(PRESENT(n)) n = nk
-
-  !--- PARSING
-  r  = TRIM(ADJUSTL(rawList))
-  nr = LEN_TRIM(r); IF(nr == 0) RETURN
-  ib = 1
-  DO ik = 1, nk-1
-    lerr = strIdx_prv(r, delimiter, ib, ie, jd, ll)
-    CALL msg('Non-numeric values found', ll=lerr); IF(lerr) RETURN
-    keys(ik) = r(ib:ie-1)
-    IF(PRESENT(vals)) CALL parseKeys(keys(ik), vals(ik))             !--- Parse a <key>=<val> pair
-    IF(PRESENT(id  )) id(ik) = jd                                    !--- Index in "delimiter(:)" of the "ik"th delimiter
-    ib = ie + LEN_TRIM( delimiter(jd) )                              !--- Length of the current delimiter
-    DO WHILE(r(ib:ib) == ' ' .AND. ib < nr); ib = ib + 1; END DO     !--- Skip spaces before next chain
-  END DO
-  keys(nk) = r(ib:nr)
-  IF(PRESENT(vals)) CALL parseKeys(keys(nk), vals(nk))               !--- Parse a <key>=<val> pair
-
-CONTAINS
-
-!------------------------------------------------------------------------------------------------------------------------------
-SUBROUTINE parseKeys(key, val)
-  IMPLICIT NONE
-  CHARACTER(LEN=*), INTENT(INOUT) :: key
-  CHARACTER(LEN=*), INTENT(OUT)   :: val
-!------------------------------------------------------------------------------------------------------------------------------
-  INTEGER :: ix
-  ix = INDEX(key, '='); IF(ix == 0) RETURN                           !--- First "=" index in "key"
-  val = ADJUSTL(key(ix+1:LEN_TRIM(key)))
-  key = ADJUSTL(key(1:ix-1))
-END SUBROUTINE parseKeys
-
-END FUNCTION strParse_m    
-!==============================================================================================================================
-
-
-!==============================================================================================================================
-!=== String substitution: replace "key" by "val" each time it appears in "str".
-!==============================================================================================================================
-SUBROUTINE strReplace_1(str, key, val, lsurr)
-  IMPLICIT NONE
-  CHARACTER(LEN=*),  INTENT(INOUT) :: str        !--- Main string
-  CHARACTER(LEN=*),  INTENT(IN)    :: key, val   !--- "key" will be replaced by "val"
-  LOGICAL, OPTIONAL, INTENT(IN)    :: lsurr      !--- TRUE => key must be surrounded by special characters to be substituted
-!------------------------------------------------------------------------------------------------------------------------------
-  INTEGER :: i0, ix, nk, ns
-  LOGICAL :: lsur, lb, le
-  lsur = .FALSE.; IF(PRESENT(lsurr)) lsur = lsurr
-  nk = LEN_TRIM(key)
-  i0 = 1
-  DO
-    ns = LEN_TRIM(str)
-    ix = INDEX(str(i0:ns), TRIM(key))            !--- First appearance index of "key" in "s", starting from index "i0"
-    IF(ix == 0) EXIT
-    ix = ix + i0 -1
-    IF(lsur) THEN                                !--- Key must be surrounded by special characters
-      !--- lb=.TRUE.: key is at the very beginning of "str" or located after  a special character
-      lb = ix     ==1;  IF(.NOT.lb) lb = INDEX('+-*/()^', str(ix-1 :ix-1 ))/=0
-      !--- le=.TRUE.: key is at the very end       of "str" or located before a special character
-      le = ix+nk-1==ns; IF(.NOT.le) le = INDEX('+-*/()^', str(ix+nk:ix+nk))/=0
-      IF(.NOT.(lb.AND.le)) THEN; i0 = i0 + nk; CYCLE; END IF
-    END IF
-    str = str(1:ix-1)//TRIM(val)//str(ix+nk:ns)
-  END DO
-END SUBROUTINE strReplace_1
-!==============================================================================================================================
-SUBROUTINE strReplace_m(str, key, val, lsurr)
-  IMPLICIT NONE
-  CHARACTER(LEN=*),  INTENT(INOUT) :: str(:)     !--- Main strings vector
-  CHARACTER(LEN=*),  INTENT(IN)    :: key, val   !--- "key" will be replaced by "val"
-  LOGICAL, OPTIONAL, INTENT(IN)    :: lsurr      !--- TRUE => key must be surrounded by special characters to be substituted
-  INTEGER :: k
-  LOGICAL :: ll
-  ll=.FALSE.; IF(PRESENT(lsurr)) ll=lsurr
-  DO k=1, SIZE(str); CALL strReplace_1(str(k),key,val,ll); END DO
-END SUBROUTINE strReplace_m
-!==============================================================================================================================
-
-
-!==============================================================================================================================
-!=== Contatenate horizontally scalars/vectors of strings/integers/reals into a vector/array ===================================
-!==============================================================================================================================
-FUNCTION horzcat_s00(s0, s1, s2, s3, s4, s5, s6, s7, s8, s9) RESULT(out)
-  IMPLICIT NONE
-  CHARACTER(LEN=*),                   INTENT(IN) :: s0
-  CHARACTER(LEN=*), OPTIONAL, TARGET, INTENT(IN) :: s1, s2, s3, s4, s5, s6, s7, s8, s9
-  CHARACTER(LEN=maxlen), ALLOCATABLE :: out(:)
-  CHARACTER(LEN=maxlen), POINTER     :: s
-  INTEGER                            :: nrow, iv
-  LOGICAL                            :: pre(9)
-!------------------------------------------------------------------------------------------------------------------------------
-  pre(:) = [PRESENT(s1),PRESENT(s2),PRESENT(s3),PRESENT(s4),PRESENT(s5),PRESENT(s6),PRESENT(s7),PRESENT(s8),PRESENT(s9)]
-  nrow = 1+COUNT(pre)
-  ALLOCATE(out(nrow))
-  out(1) = s0
-  DO iv = 2, nrow; IF(.NOT.pre(iv-1)) CYCLE
-    SELECT CASE(iv-1)
-      CASE(1); s=> s1; CASE(2); s=> s2; CASE(3); s=> s3; CASE(4); s=> s4; CASE(5); s=> s5
-      CASE(6); s=> s6; CASE(7); s=> s7; CASE(8); s=> s8; CASE(9); s=> s9
-    END SELECT
-    out(iv) = s
-  END DO
-END FUNCTION horzcat_s00
-!==============================================================================================================================
-FUNCTION horzcat_s10(s0, s1, s2, s3, s4, s5, s6, s7, s8, s9) RESULT(out)
-  IMPLICIT NONE
-  CHARACTER(LEN=*),           INTENT(IN) :: s0(:), s1
-  CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: s2, s3, s4, s5, s6, s7, s8, s9
-  CHARACTER(LEN=maxlen), ALLOCATABLE :: out(:), tmp(:)
-  INTEGER :: nc
-  nc = SIZE(s0)
-  tmp = horzcat_s00(s0(nc), s1, s2, s3, s4, s5, s6, s7, s8, s9)
-  IF(nc == 1) out = tmp
-  IF(nc /= 1) out = [s0(1:nc-1), tmp]
-END FUNCTION horzcat_s10
-!==============================================================================================================================
-FUNCTION horzcat_s11(s0, s1, s2, s3, s4, s5, s6, s7, s8, s9) RESULT(out)
-  IMPLICIT NONE
-  CHARACTER(LEN=*),                   INTENT(IN) :: s0(:)
-  CHARACTER(LEN=*), OPTIONAL, TARGET, INTENT(IN) :: s1(:), s2(:), s3(:), s4(:), s5(:), s6(:), s7(:), s8(:), s9(:)
-  CHARACTER(LEN=maxlen), ALLOCATABLE :: out(:,:)
-  CHARACTER(LEN=maxlen), POINTER     :: s(:)
-  INTEGER                            :: nrow, ncol, iv, n
-  LOGICAL                            :: pre(9)
-!------------------------------------------------------------------------------------------------------------------------------
-  pre(:) = [PRESENT(s1),PRESENT(s2),PRESENT(s3),PRESENT(s4),PRESENT(s5),PRESENT(s6),PRESENT(s7),PRESENT(s8),PRESENT(s9)]
-  nrow = SIZE(s0)
-  ncol = 1+COUNT(pre)
-  ALLOCATE(out(nrow, ncol))
-  out(:,1) = s0
-  DO iv = 2, ncol; IF(.NOT.pre(iv-1)) CYCLE
-    SELECT CASE(iv-1)
-      CASE(1); s=> s1; CASE(2); s=> s2; CASE(3); s=> s3; CASE(4); s=> s4; CASE(5); s=> s5
-      CASE(6); s=> s6; CASE(7); s=> s7; CASE(8); s=> s8; CASE(9); s=> s9
-    END SELECT
-    n = SIZE(s, DIM=1)
-    IF(n /= nrow) THEN; CALL msg("Can't concatenate vectors of differing lengths"); STOP; END IF
-    out(:,iv) = s(:)
-  END DO
-END FUNCTION horzcat_s11
-!==============================================================================================================================
-FUNCTION horzcat_s21(s0, s1, s2, s3, s4, s5, s6, s7, s8, s9) RESULT(out)
-  IMPLICIT NONE
-  CHARACTER(LEN=*),           INTENT(IN) :: s0(:,:), s1(:)
-  CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: s2(:), s3(:), s4(:), s5(:), s6(:), s7(:), s8(:), s9(:)
-  CHARACTER(LEN=maxlen), ALLOCATABLE :: out(:,:), tmp(:,:)
-  INTEGER :: nc
-  nc  = SIZE(s0, 2)
-  tmp = horzcat_s11(s0(:,nc), s1, s2, s3, s4, s5, s6, s7, s8, s9)
-  IF(nc == 1) out = tmp
-  IF(nc /= 1) out = RESHAPE([PACK(s0(:,1:nc-1), .TRUE.), PACK(tmp, .TRUE.)], SHAPE=[SIZE(s0, 1), nc + SIZE(tmp, 2)-1])
-END FUNCTION horzcat_s21
-!==============================================================================================================================
-FUNCTION horzcat_i00(i0, i1, i2, i3, i4, i5, i6, i7, i8, i9) RESULT(out)
-  IMPLICIT NONE
-  INTEGER,                   INTENT(IN) :: i0
-  INTEGER, OPTIONAL, TARGET, INTENT(IN) :: i1, i2, i3, i4, i5, i6, i7, i8, i9
-  INTEGER, ALLOCATABLE :: out(:)
-  INTEGER, POINTER     :: i
-  INTEGER              :: ncol, iv
-  LOGICAL              :: pre(9)
-!------------------------------------------------------------------------------------------------------------------------------
-  pre(:) = [PRESENT(i1),PRESENT(i2),PRESENT(i3),PRESENT(i4),PRESENT(i5),PRESENT(i6),PRESENT(i7),PRESENT(i8),PRESENT(i9)]
-  ncol = SIZE(pre)
-  ALLOCATE(out(ncol))
-  out(1) = i0
-  DO iv = 2, ncol; IF(.NOT.pre(iv-1)) CYCLE
-    SELECT CASE(iv-1)
-      CASE(1); i=> i1; CASE(2); i=> i2; CASE(3); i=> i3; CASE(4); i=> i4; CASE(5); i=> i5
-      CASE(6); i=> i6; CASE(7); i=> i7; CASE(8); i=> i8; CASE(9); i=> i9
-    END SELECT
-    out(iv) = i
-  END DO
-END FUNCTION horzcat_i00
-!==============================================================================================================================
-FUNCTION horzcat_i10(i0, i1, i2, i3, i4, i5, i6, i7, i8, i9) RESULT(out)
-  IMPLICIT NONE
-  INTEGER,           INTENT(IN) :: i0(:), i1
-  INTEGER, OPTIONAL, INTENT(IN) :: i2, i3, i4, i5, i6, i7, i8, i9
-  INTEGER, ALLOCATABLE :: out(:), tmp(:)
-  INTEGER :: nc
-  nc = SIZE(i0)
-  tmp = horzcat_i00(i0(nc), i1, i2, i3, i4, i5, i6, i7, i8, i9)
-  IF(nc == 1) out = tmp
-  IF(nc /= 1) out = [i0(1:nc-1), tmp]
-END FUNCTION horzcat_i10
-!==============================================================================================================================
-FUNCTION horzcat_i11(i0, i1, i2, i3, i4, i5, i6, i7, i8, i9) RESULT(out)
-  IMPLICIT NONE
-  INTEGER,                   INTENT(IN) :: i0(:)
-  INTEGER, OPTIONAL, TARGET, INTENT(IN) :: i1(:), i2(:), i3(:), i4(:), i5(:), i6(:), i7(:), i8(:), i9(:)
-  INTEGER, ALLOCATABLE :: out(:,:)
-  INTEGER, POINTER     :: i(:)
-  INTEGER              :: nrow, ncol, iv, n
-  LOGICAL              :: pre(9)
-!------------------------------------------------------------------------------------------------------------------------------
-  pre(:) = [PRESENT(i1),PRESENT(i2),PRESENT(i3),PRESENT(i4),PRESENT(i5),PRESENT(i6),PRESENT(i7),PRESENT(i8),PRESENT(i9)]
-  nrow = SIZE(i0)
-  ncol = 1+COUNT(pre)
-  ALLOCATE(out(nrow, ncol))
-  out(:,1) = i0
-  DO iv = 2, ncol; IF(.NOT.pre(iv-1)) CYCLE
-    SELECT CASE(iv-1)
-      CASE(1); i=> i1; CASE(2); i=> i2; CASE(3); i=> i3; CASE(4); i=> i4; CASE(5); i=> i5
-      CASE(6); i=> i6; CASE(7); i=> i7; CASE(8); i=> i8; CASE(9); i=> i9
-    END SELECT
-    n = SIZE(i, DIM=1)
-    IF(n /= nrow) THEN; CALL msg("Can't concatenate vectors of differing lengths"); STOP; END IF
-    out(:,iv) = i(:)
-  END DO
-END FUNCTION horzcat_i11
-!==============================================================================================================================
-FUNCTION horzcat_i21(i0, i1, i2, i3, i4, i5, i6, i7, i8, i9) RESULT(out)
-  IMPLICIT NONE
-  INTEGER,           INTENT(IN) :: i0(:,:), i1(:)
-  INTEGER, OPTIONAL, INTENT(IN) :: i2(:), i3(:), i4(:), i5(:), i6(:), i7(:), i8(:), i9(:)
-  INTEGER, ALLOCATABLE :: out(:,:), tmp(:,:)
-  INTEGER :: nc
-  nc  = SIZE(i0, 2)
-  tmp = horzcat_i11(i0(:,nc), i1, i2, i3, i4, i5, i6, i7, i8, i9)
-  IF(nc == 1) out = tmp
-  IF(nc /= 1) out = RESHAPE([PACK(i0(:,1:nc-1), .TRUE.), PACK(tmp, .TRUE.)], SHAPE=[SIZE(i0, 1), nc + SIZE(tmp, 2)-1])
-END FUNCTION horzcat_i21
-!==============================================================================================================================
-FUNCTION horzcat_r00(r0, r1, r2, r3, r4, r5, r6, r7, r8, r9) RESULT(out)
-  IMPLICIT NONE
-  REAL,                   INTENT(IN) :: r0
-  REAL, OPTIONAL, TARGET, INTENT(IN) :: r1, r2, r3, r4, r5, r6, r7, r8, r9
-  REAL, ALLOCATABLE :: out(:)
-  REAL, POINTER     :: r
-  INTEGER           :: ncol, iv
-  LOGICAL           :: pre(9)
-!------------------------------------------------------------------------------------------------------------------------------
-  pre(:) = [PRESENT(r1),PRESENT(r2),PRESENT(r3),PRESENT(r4),PRESENT(r5),PRESENT(r6),PRESENT(r7),PRESENT(r8),PRESENT(r9)]
-  ncol = 1+COUNT(pre)
-  ALLOCATE(out(ncol))
-  out(1) = r0
-  DO iv = 2, ncol; IF(.NOT.pre(iv-1)) CYCLE
-    SELECT CASE(iv-1)
-      CASE(1); r=> r1; CASE(2); r=> r2; CASE(3); r=> r3; CASE(4); r=> r4; CASE(5); r=> r5
-      CASE(6); r=> r6; CASE(7); r=> r7; CASE(8); r=> r8; CASE(9); r=> r9
-    END SELECT
-    out(iv) = r
-  END DO
-END FUNCTION horzcat_r00
-!==============================================================================================================================
-FUNCTION horzcat_r10(r0, r1, r2, r3, r4, r5, r6, r7, r8, r9) RESULT(out)
-  IMPLICIT NONE
-  REAL,           INTENT(IN) :: r0(:), r1
-  REAL, OPTIONAL, INTENT(IN) :: r2, r3, r4, r5, r6, r7, r8, r9
-  REAL, ALLOCATABLE :: out(:), tmp(:)
-  INTEGER :: nc
-  nc  = SIZE(r0)
-  tmp = horzcat_r00(r0(nc), r1, r2, r3, r4, r5, r6, r7, r8, r9)
-  IF(nc == 1) out = tmp
-  IF(nc /= 1) out = [r0(1:nc-1), tmp]
-END FUNCTION horzcat_r10
-!==============================================================================================================================
-FUNCTION horzcat_r11(r0, r1, r2, r3, r4, r5, r6, r7, r8, r9) RESULT(out)
-  IMPLICIT NONE
-  REAL,                   INTENT(IN) :: r0(:)
-  REAL, OPTIONAL, TARGET, INTENT(IN) :: r1(:), r2(:), r3(:), r4(:), r5(:), r6(:), r7(:), r8(:), r9(:)
-  REAL, ALLOCATABLE :: out(:,:)
-  REAL, POINTER     :: r(:)
-  INTEGER           :: nrow, ncol, iv, n
-  LOGICAL           :: pre(9)
-!------------------------------------------------------------------------------------------------------------------------------
-  pre(:) = [PRESENT(r1),PRESENT(r2),PRESENT(r3),PRESENT(r4),PRESENT(r5),PRESENT(r6),PRESENT(r7),PRESENT(r8),PRESENT(r9)]
-  nrow = SIZE(r0)
-  ncol = 1+COUNT(pre)
-  ALLOCATE(out(nrow, ncol))
-  out(:,1) = r0
-  DO iv = 2, ncol; IF(.NOT.pre(iv-1)) CYCLE
-    SELECT CASE(iv-1)
-      CASE(1); r=> r1; CASE(2); r=> r2; CASE(3); r=> r3; CASE(4); r=> r4; CASE(5); r=> r5
-      CASE(6); r=> r5; CASE(7); r=> r7; CASE(8); r=> r8; CASE(9); r=> r9
-    END SELECT
-    n = SIZE(r, DIM=1)
-    IF(n /= nrow) THEN; CALL msg("Can't concatenate vectors of differing lengths"); STOP; END IF
-    out(:,iv) = r(:)
-  END DO
-END FUNCTION horzcat_r11
-!==============================================================================================================================
-FUNCTION horzcat_r21(r0, r1, r2, r3, r4, r5, r6, r7, r8, r9) RESULT(out)
-  IMPLICIT NONE
-  REAL,           INTENT(IN) :: r0(:,:), r1(:)
-  REAL, OPTIONAL, INTENT(IN) :: r2(:), r3(:), r4(:), r5(:), r6(:), r7(:), r8(:), r9(:)
-  REAL, ALLOCATABLE :: out(:,:), tmp(:,:)
-  INTEGER :: nc
-  nc  = SIZE(r0, 2)
-  tmp = horzcat_r11(r0(:,nc), r1, r2, r3, r4, r5, r6, r7, r8, r9)
-  IF(nc == 1) out = tmp
-  IF(nc /= 1) out = RESHAPE([PACK(r0(:,1:nc-1), .TRUE.), PACK(tmp, .TRUE.)], SHAPE=[SIZE(r0, 1), nc + SIZE(tmp, 2)-1])
-END FUNCTION horzcat_r21
-!==============================================================================================================================
-FUNCTION horzcat_d00(d0, d1, d2, d3, d4, d5, d6, d7, d8, d9) RESULT(out)
-  IMPLICIT NONE
-  DOUBLE PRECISION,                   INTENT(IN) :: d0
-  DOUBLE PRECISION, OPTIONAL, TARGET, INTENT(IN) :: d1, d2, d3, d4, d5, d6, d7, d8, d9
-  DOUBLE PRECISION, ALLOCATABLE :: out(:)
-  DOUBLE PRECISION, POINTER     :: d
-  INTEGER                       :: ncol, iv
-  LOGICAL                       :: pre(9)
-!------------------------------------------------------------------------------------------------------------------------------
-  pre(:) = [PRESENT(d1),PRESENT(d2),PRESENT(d3),PRESENT(d4),PRESENT(d5),PRESENT(d6),PRESENT(d7),PRESENT(d8),PRESENT(d9)]
-  ncol = 1+COUNT(pre)
-  ALLOCATE(out(ncol))
-  out(1) = d0
-  DO iv = 2, ncol; IF(.NOT.pre(iv-1)) CYCLE
-    SELECT CASE(iv-1)
-      CASE(1); d=> d1; CASE(2); d=> d2; CASE(3); d=> d3; CASE(4); d=> d4; CASE(5); d=> d5
-      CASE(6); d=> d6; CASE(7); d=> d7; CASE(8); d=> d8; CASE(9); d=> d9
-    END SELECT
-    out(iv) = d
-  END DO
-END FUNCTION horzcat_d00
-!==============================================================================================================================
-FUNCTION horzcat_d10(d0, d1, d2, d3, d4, d5, d6, d7, d8, d9) RESULT(out)
-  IMPLICIT NONE
-  DOUBLE PRECISION,           INTENT(IN) :: d0(:), d1
-  DOUBLE PRECISION, OPTIONAL, INTENT(IN) :: d2, d3, d4, d5, d6, d7, d8, d9
-  DOUBLE PRECISION, ALLOCATABLE :: out(:), tmp(:)
-  INTEGER :: nc
-  nc = SIZE(d0)
-  tmp = horzcat_d00(d0(nc), d1, d2, d3, d4, d5, d6, d7, d8, d9)
-  IF(nc == 1) out = tmp
-  IF(nc /= 1) out = [d0(1:nc-1), tmp]
-END FUNCTION horzcat_d10
-!==============================================================================================================================
-FUNCTION horzcat_d11(d0, d1, d2, d3, d4, d5, d6, d7, d8, d9) RESULT(out)
-  IMPLICIT NONE
-  DOUBLE PRECISION,                   INTENT(IN) :: d0(:)
-  DOUBLE PRECISION, OPTIONAL, TARGET, INTENT(IN) :: d1(:), d2(:), d3(:), d4(:), d5(:), d6(:), d7(:), d8(:), d9(:)
-  DOUBLE PRECISION, ALLOCATABLE :: out(:,:)
-  DOUBLE PRECISION, POINTER     :: d(:)
-  INTEGER                       :: nrow, ncol, iv, n
-  LOGICAL                       :: pre(9)
-!------------------------------------------------------------------------------------------------------------------------------
-  nrow = SIZE(d0)
-  pre(:) = [PRESENT(d1),PRESENT(d2),PRESENT(d3),PRESENT(d4),PRESENT(d5),PRESENT(d6),PRESENT(d7),PRESENT(d8),PRESENT(d9)]
-  ncol = 1+COUNT(pre)
-  ALLOCATE(out(nrow, ncol))
-  DO iv = 2, ncol; IF(.NOT.pre(iv-1)) CYCLE
-    SELECT CASE(iv-1)
-      CASE(1); d=> d1; CASE(2); d=> d2; CASE(3); d=> d3; CASE(4); d=> d4; CASE(5); d=> d5
-      CASE(6); d=> d6; CASE(7); d=> d7; CASE(8); d=> d8; CASE(9); d=> d9
-    END SELECT
-    n = SIZE(d, DIM=1)
-    IF(n /= nrow) THEN; CALL msg("Can't concatenate vectors of differing lengths"); STOP; END IF
-    out(:,iv) = d(:)
-  END DO
-END FUNCTION horzcat_d11
-!==============================================================================================================================
-FUNCTION horzcat_d21(d0, d1, d2, d3, d4, d5, d6, d7, d8, d9) RESULT(out)
-  IMPLICIT NONE
-  DOUBLE PRECISION,           INTENT(IN) :: d0(:,:), d1(:)
-  DOUBLE PRECISION, OPTIONAL, INTENT(IN) :: d2(:), d3(:), d4(:), d5(:), d6(:), d7(:), d8(:), d9(:)
-  DOUBLE PRECISION, ALLOCATABLE :: out(:,:), tmp(:,:)
-  INTEGER :: nc
-  nc  = SIZE(d0, 2)
-  tmp = horzcat_d11(d0(:,nc), d1, d2, d3, d4, d5, d6, d7, d8, d9)
-  IF(nc == 1) out = tmp
-  IF(nc /= 1) out = RESHAPE([PACK(d0(:,1:nc-1), .TRUE.), PACK(tmp, .TRUE.)], SHAPE=[SIZE(d0, 1), nc + SIZE(tmp, 2)-1])
-END FUNCTION horzcat_d21
-!==============================================================================================================================
-
-
-!==============================================================================================================================
-!--- Display a clean table composed of successive vectors of same length.
-!=== The profile "p" describe in which order to pick up the columns from "s", "i" and "r" for display.
-!===  * nRowMax lines are displayed (default: all lines)
-!===  * nColMax characters (default: as long as needed) are displayed at most on a line. If the effective total length is
-!===    higher, several partial tables are displayed ; the nHead (default: 1) first columns are included in each sub-table.
-!==============================================================================================================================
-LOGICAL FUNCTION dispTable(p, titles, s, i, r, rFmt, nRowMax, nColMax, nHead, unit, sub) RESULT(lerr)
-  IMPLICIT NONE
-  CHARACTER(LEN=*),           INTENT(IN)  :: p             !--- DISPLAY MAP: s/i/r
-  CHARACTER(LEN=*),           INTENT(IN)  :: titles(:)     !--- TITLES (ONE EACH COLUMN)
-  CHARACTER(LEN=*), OPTIONAL, INTENT(IN)  :: s(:,:)        !--- STRINGS
-  INTEGER,          OPTIONAL, INTENT(IN)  :: i(:,:)        !--- INTEGERS
-  REAL,             OPTIONAL, INTENT(IN)  :: r(:,:)        !--- REALS
-  CHARACTER(LEN=*), OPTIONAL, INTENT(IN)  :: rFmt          !--- Format for reals
-  INTEGER,          OPTIONAL, INTENT(IN)  :: nRowMax       !--- Display at most "nRowMax" rows
-  INTEGER,          OPTIONAL, INTENT(IN)  :: nColMax       !--- Display at most "nColMax" characters each line
-  INTEGER,          OPTIONAL, INTENT(IN)  :: nHead         !--- Head columns repeated for multiple tables display
-  INTEGER,          OPTIONAL, INTENT(IN)  :: unit          !--- Output unit (default: screen)
-  CHARACTER(LEN=*), OPTIONAL, INTENT(IN)  :: sub           !--- Subroutine name
-!------------------------------------------------------------------------------------------------------------------------------
-  CHARACTER(LEN=2048) :: row
-  CHARACTER(LEN=maxlen)  :: rFm, el, subn
-  CHARACTER(LEN=maxlen), ALLOCATABLE :: d(:,:)
-  CHARACTER(LEN=1) :: s1, sp
-  INTEGER :: is, ii, ir, it, k, nmx,  unt, ic, np
-  INTEGER :: ns, ni, nr, nt, l, ncol, nHd, ib, l0
-  INTEGER, ALLOCATABLE :: n(:), ncmx(:)
-  INTEGER, PARAMETER   :: nm=1                             !--- Space between values & columns
-  LOGICAL :: ls, li, lr
-  subn = '';    IF(PRESENT(sub)) subn = sub
-  rFm = '*';    IF(PRESENT(rFmt)) rFm = rFmt               !--- Specified format for reals
-  unt = lunout; IF(PRESENT(unit)) unt = unit               !--- Specified output unit
-  np = LEN_TRIM(p); ns = 0; ni = 0; nr = 0; ncol = 0
-  ls = PRESENT(s); li = PRESENT(i); lr = PRESENT(r)
-  lerr = .FALSE.; IF(.NOT.ANY([ls,li,lr])) RETURN          !--- Nothing to do
-  sp = '|'                                                 !--- Separator
-
-  !--- CHECK ARGUMENTS COHERENCE
-  lerr = np /= SIZE(titles); IF(fmsg('display map "p" length and titles list mismatch', subn, lerr)) RETURN
-  IF(ls) THEN
-    ns = SIZE(s, 1); ncol = ncol + SIZE(s, 2); lerr = COUNT([(p(ic:ic)=='s', ic=1, np)]) /= SIZE(s, 2)
-  END IF
-  IF(li) THEN
-    ni = SIZE(i, 1); ncol = ncol + SIZE(i, 2); lerr = COUNT([(p(ic:ic)=='i', ic=1, np)]) /= SIZE(i, 2)
-  END IF
-  IF(lr) THEN
-    nr = SIZE(r, 1); ncol = ncol + SIZE(r, 2); lerr = COUNT([(p(ic:ic)=='r', ic=1, np)]) /= SIZE(r, 2)
-  END IF
-  IF(fmsg('display map "p" length and arguments number mismatch', subn, lerr)) RETURN
-  lerr = ncol /= SIZE(titles); IF(fmsg('"titles" length and arguments number mismatch', subn, lerr)) RETURN
-  lerr = ls.AND.li.AND.ns/=ni; IF(fmsg('string and integer arguments lengths mismatch', subn, lerr)) RETURN
-  lerr = ls.AND.lr.AND.ns/=nr; IF(fmsg(   'string and real arguments lengths mismatch', subn, lerr)) RETURN
-  lerr = li.AND.lr.AND.ni/=nr; IF(fmsg(  'integer and real arguments lengths mismatch', subn, lerr)) RETURN
-  nmx = MAX(ns,ni,nr)+1; IF(PRESENT(nRowMax)) nmx = MIN(nmx,nRowMax+1)
-
-  !--- Allocate the assembled quantities array
-  ALLOCATE(d(nmx,ncol), n(ncol))
-
-  !--- Assemble the vectors into a strings array in the order indicated by "pattern"
-  is =  1; ii = 1; ir = 1
-  DO ic = 1, ncol
-    d(1,ic) = TRIM(titles(ic))
-    SELECT CASE(p(ic:ic))
-      CASE('s'); d(2:nmx,ic) =          s(:,is)     ; is = is + 1
-      CASE('i'); d(2:nmx,ic) =  int2str(i(:,ii)    ); ii = ii + 1
-      CASE('r'); d(2:nmx,ic) = real2str(r(:,ir),rFm); ir = ir + 1
-    END SELECT
-  END DO
-  CALL cleanZeros(d)
-  DO ic = 1, ncol
-    n(ic)=0; DO ir=1, nmx; n(ic)=MAX(n(ic), LEN_TRIM(d(ir,ic))); END DO
-  END DO
-  n(:) = n(:) + 2*nm
-
-  !--- Build the vector of max column index in case the rows are too long (table must be displayed in multiple parts)
-  nHd = 1; IF(PRESENT(nHead)) nHd = nHead
-  IF(.NOT.PRESENT(nColMax)) THEN
-    nt = 1; ncmx = [ncol]
-  ELSE
-    nt = 1; l0 = SUM(n(1:nHd)+1)+1
-    IF(PRESENT(sub)) l0=l0+LEN_TRIM(subn)+1
-    !--- Count the number of table parts
-    l = l0; DO ic = nHd+1, ncol; l = l+n(ic)+1; IF(l>=nColMax) THEN; nt = nt+1; l = l0+n(ic)+1; END IF; END DO
-    !--- Get the index of the last column for each table part
-    ALLOCATE(ncmx(nt)); k = 1
-    l = l0; DO ic = nHd+1, ncol; l = l+n(ic)+1; IF(l>=nColMax) THEN; ncmx(k) = ic-1; l = l0+n(ic)+1; k = k+1; END IF; END DO
-    ncmx(nt) = ncol
-  END IF
-      
-  !--- Display the strings array as a table
-  DO it = 1, nt
-    DO ir = 1, nmx; row = ''
-      DO ic = 1, nHd; el = d(ir,ic)
-        s1 = sp
-        row = TRIM(row)//REPEAT(' ',nm)//TRIM(el)//REPEAT(' ',n(ic)-LEN_TRIM(el)-nm)//s1
-      END DO
-      ib = nHd+1; IF(it>1) ib = ncmx(it-1)+1
-      DO ic = ib, ncmx(it); el = d(ir,ic)
-        s1 = sp
-        row = TRIM(row)//REPEAT(' ',nm)//TRIM(el)//REPEAT(' ',n(ic)-LEN_TRIM(el)-nm)//s1
-      END DO
-      nr = LEN_TRIM(row)-1                                           !--- Final separator removed
-      CALL msg(row(1:nr), subn, unit=unt)
-      IF(ir /= 1) CYCLE                                              !--- Titles only are underlined
-      row=''; DO ic=1,nHd; row=TRIM(row)//REPEAT('-',n(ic))//'+'; END DO
-      DO ic = ib,ncmx(it); row=TRIM(row)//REPEAT('-',n(ic))//'+'; END DO
-      CALL msg(row(1:LEN_TRIM(row)-1), subn, unit=unt)
-    END DO
-    CALL msg('', subn, unit=unt)
-  END DO
-
-END FUNCTION dispTable
-!==============================================================================================================================
-
-!==============================================================================================================================
-LOGICAL FUNCTION dispNamelist(unt, p, titles, s, i, r, rFmt, llast) RESULT(lerr)
-  IMPLICIT NONE
-  INTEGER,                    INTENT(IN)  :: unt           !--- Output unit
-  CHARACTER(LEN=*),           INTENT(IN)  :: p             !--- DISPLAY MAP: s/i/r
-  CHARACTER(LEN=*),           INTENT(IN)  :: titles(:)     !--- TITLES (ONE EACH COLUMN)
-  CHARACTER(LEN=*), OPTIONAL, INTENT(IN)  :: s(:,:)        !--- STRINGS
-  INTEGER,          OPTIONAL, INTENT(IN)  :: i(:,:)        !--- INTEGERS
-  REAL,             OPTIONAL, INTENT(IN)  :: r(:,:)        !--- REALS
-  CHARACTER(LEN=*), OPTIONAL, INTENT(IN)  :: rFmt          !--- Format for reals
-  LOGICAL,          OPTIONAL, INTENT(IN)  :: llast         !--- Last variable: no final ','
-!------------------------------------------------------------------------------------------------------------------------------
-  CHARACTER(LEN=maxlen)  :: rFm, el
-  CHARACTER(LEN=maxlen), ALLOCATABLE :: d(:,:)
-  CHARACTER(LEN=:),      ALLOCATABLE :: sp, row
-  INTEGER :: is, ii, ir, nrow, ic
-  INTEGER :: ns, ni, nr, ncol, np
-  INTEGER, ALLOCATABLE :: n(:)
-  LOGICAL :: ls, li, lr, la
-  rFm = '*';    IF(PRESENT(rFmt)) rFm = rFmt               !--- Specified format for reals
-  ls = PRESENT(s); li = PRESENT(i); lr = PRESENT(r)
-  lerr = .FALSE.; IF(.NOT.ANY([ls,li,lr])) RETURN          !--- Nothing to do
-  la = .FALSE.; IF(PRESENT(llast)) la = llast
-
-  !--- CHECK ARGUMENTS COHERENCE
-  ns = 0; ni = 0; nr = 0; np = LEN_TRIM(p); ncol = 0
-  IF(ls) THEN; ns = SIZE(s, DIM=1); ncol = ncol + SIZE(s, DIM=2)
-    lerr = COUNT([(p(ic:ic)=='s', ic=1, np)]) /= SIZE(s, DIM=2)
-  END IF
-  IF(li) THEN; ni = SIZE(i, DIM=1); ncol = ncol + SIZE(i, DIM=2)
-    lerr = COUNT([(p(ic:ic)=='i', ic=1, np)]) /= SIZE(i, DIM=2)
-  END IF
-  IF(lr) THEN; nr = SIZE(r, DIM=1); ncol = ncol + SIZE(r, DIM=2)
-    lerr = COUNT([(p(ic:ic)=='r', ic=1, np)]) /= SIZE(r, DIM=2)
-  END IF
-  IF(fmsg('display map "p" length and arguments number mismatch', ll=lerr)) RETURN
-  lerr = ncol /= SIZE(titles); IF(fmsg('"titles" length and arguments number mismatch', ll=lerr)) RETURN
-  lerr = ls.AND.li.AND.ns/=ni; IF(fmsg('string and integer arguments lengths mismatch', ll=lerr)) RETURN
-  lerr = ls.AND.lr.AND.ns/=nr; IF(fmsg(   'string and real arguments lengths mismatch', ll=lerr)) RETURN
-  lerr = li.AND.lr.AND.ni/=nr; IF(fmsg(  'integer and real arguments lengths mismatch', ll=lerr)) RETURN
-
-  !--- Allocate the assembled quantities array
-  nrow = MAX(ns,ni,nr)+1
-  ALLOCATE(d(nrow,ncol), n(ncol))
-
-  !--- Assemble the vectors into a strings array in the order indicated by "pattern"
-  is =  1; ii = 1; ir = 1
-  DO ic = 1, ncol
-    d(1,ic) = TRIM(titles(ic))
-    SELECT CASE(p(ic:ic))
-      CASE('s'); d(2:nrow,ic) =          s(:,is)     ; is = is + 1
-      CASE('i'); d(2:nrow,ic) =  int2str(i(:,ii)    ); ii = ii + 1
-      CASE('r'); d(2:nrow,ic) = real2str(r(:,ir),rFm); ir = ir + 1
-    END SELECT
-  END DO
-  CALL cleanZeros(d)
-  DO ic = 1, ncol
-    n(ic) = 0; DO ir=1, nrow; n(ic)=MAX(n(ic), LEN_TRIM(d(ir,ic))); END DO
-    IF(needQuotes(d(2,ic)) .AND. ic/=1) n(ic) = n(ic) + 2 !--- For quotes, using second line only
-  END DO
-
-  !--- Display the strings array as a table
-  DO ir = 1, nrow
-    row = ''; sp = '   '; IF(TRIM(d(ir,1)) /= '') sp = ' = '
-    DO ic = 1, ncol
-      el = d(ir,ic); IF(ic /= 1) el = addQuotes_1(el)
-      row = row//TRIM(el)//REPEAT(' ',n(ic)-LEN_TRIM(el))//sp
-      sp = '   '; IF(ic /= ncol-1) CYCLE
-      IF(TRIM(d(MIN(ir+1,nrow),1)) /= '' .AND. (ir /= nrow .OR. .NOT.la)) sp = ' , '
-    END DO
-    WRITE(unt,'(a)')TRIM(row)
-  END DO
-
-  !--- End of section
-  IF(la) THEN
-    WRITE(unt,'(a)')'/'
-    WRITE(unt,'(a)')
-  END IF
-
-END FUNCTION dispNameList
-!==============================================================================================================================
-
-
-!==============================================================================================================================
-LOGICAL FUNCTION dispOutliers_1(ll, a, n, err_msg, nam, subn, nRowmax, nColMax, nHead, unit) RESULT(lerr)
-  IMPLICIT NONE
-! Display outliers list in tables
-! If "nam" is supplied, it means the last index is for tracers => one table each tracer for rank > 2.
-  LOGICAL,                    INTENT(IN)  :: ll(:)                   !--- Linearized mask of outliers
-  REAL,                       INTENT(IN)  ::  a(:)                   !--- Linearized array of values
-  INTEGER,                    INTENT(IN)  ::  n(:)                   !--- Profile before linearization
-  CHARACTER(LEN=*), OPTIONAL, INTENT(IN)  :: err_msg, nam(:), subn   !--- Error message, variables and calling subroutine names
-  INTEGER,          OPTIONAL, INTENT(IN)  :: nRowMax                 !--- Maximum number of lines to display    (default: all)
-  INTEGER,          OPTIONAL, INTENT(IN)  :: nColMax                 !--- Maximum number of characters per line (default: 2048)
-  INTEGER,          OPTIONAL, INTENT(IN)  :: nHead                   !--- Number of front columns to duplicate  (default: 1)
-  INTEGER,          OPTIONAL, INTENT(IN)  :: unit                    !--- Output unit                           (def: lunout)
-!------------------------------------------------------------------------------------------------------------------------------
-  CHARACTER(LEN=maxlen),      ALLOCATABLE :: ttl(:)
-  LOGICAL,                    ALLOCATABLE :: m(:)
-  INTEGER,                    ALLOCATABLE :: ki(:), kj(:)
-  INTEGER                                 :: i, j, k, rk, rk1, ib, ie, itr, nm, unt, nRmx, nCmx, nHd, nv
-  CHARACTER(LEN=maxlen)                   :: mes, sub, fm='(f12.9)', v, s
-  CHARACTER(LEN=maxlen),      ALLOCATABLE :: vnm(:)
-
-  lerr = ANY(ll); IF(.NOT.lerr) RETURN                               !--- No outliers -> finished
-
-  mes = 'outliers found'; IF(PRESENT(err_msg)) mes = err_msg         !--- Error message
-  vnm = ['a'];            IF(PRESENT(nam ))    vnm = nam             !--- Variables names
-  sub = 'dispOutliers';   IF(PRESENT(subn))    sub = subn            !--- Calling subroutine name
-  nRmx= SIZE(a);          IF(PRESENT(nRowMax)) nRmx=MIN(nRmx,nRowMax)!-- Maximum number of lines to print
-  nCmx= 2048;             IF(PRESENT(nColMax)) nCmx=MIN(nCmx,nColMax)!-- Maximum number of characters each line
-  nHd = 1;                IF(PRESENT(nHead))   nHd = nHead           !--- Number of front columns to duplicate
-  unt = lunout;           IF(PRESENT(unit))    unt = unit            !--- Unit to print messages
-
-  rk = SIZE(n); nv = SIZE(vnm)
-  lerr = nv/=1 .AND. nv/=n(rk); CALL msg('SIZE(nam) /= 1 and /= last "n" element', sub, lerr); IF(lerr) RETURN
-  lerr = SIZE(a) /=   SIZE(ll); CALL msg('ll" and "a" sizes mismatch',             sub, lerr); IF(lerr) RETURN
-  lerr = SIZE(a) /= PRODUCT(n); CALL msg('profile "n" does not match "a" and "ll', sub, lerr); IF(lerr) RETURN
-  CALL msg(mes, sub, unit=unt)
-
-  !--- SCALAR CASE: single value to display
-  IF(rk==1.AND.n(1)==1) THEN
-    IF(ll(1)) WRITE(unt,'(a," = ",f12.9)')TRIM(nam(1)),a(1); RETURN
-  END IF
-
-  rk1 = rk; IF(nv==1) rk1 = rk-1                                    !--- Rank of each displayed table
-  SELECT CASE(rk1)                                                  !--- Indices list
-    CASE(1,2); ki = [ (i,i=1,n(1)) ]
-    CASE(3);   ki = [((i,i=1,n(1)),j=1,n(2))]; kj = [((j,i=1,n(1)),j=1,n(2))]
-    CASE DEFAULT; WRITE(unt,*)'Sorry: routine "dispOutliers" is limited to rank 3'; RETURN
-  END SELECT
-
-  !--- VECTOR CASE:  table " name | value " (known names)  /  )  /  " i | a(i) " (unknown names)
-  IF(rk==1) THEN
-    ALLOCATE(ttl(2)); ttl(2) = TRIM(vnm(1))//'(i)'; ttl(1) = 'i'
-    IF(nv == 1) lerr = dispTable('sr', ttl,               s=cat(PACK(nam,ll)), r=cat(PACK(a,ll)), &
-                                 rFmt=fm, nRowMax=nRmx, nColMax=nCmx, nHead=nHd, unit=unt, sub=sub)
-    IF(nv /= 1) lerr = dispTable('ir', ['name ','value'], i=cat(PACK(ki,m)),   r=cat(PACK(a,ll)), &
-                                 rFmt=fm, nRowMax=nRmx, nColMax=nCmx, nHead=nHd, unit=unt, sub=sub)
-    CALL msg("can't display outliers table", sub, lerr, unt)
-    RETURN
-  END IF
-
-  !--- OTHER CASES: one table for each tracer (last index)
-  ttl = [(ACHAR(k), k = 105, 104+rk)]                                !--- Titles list ('i', 'j', 'k'...)
-  s = strStack( ttl(1:rk-1) )                                        !--- Tracer name dummy indexes: (i, j, k, ...
-
-  DO itr=1,n(rk)
-    nm = PRODUCT(n(1:rk-1))                                          !--- number of elements per tracer
-    ie = itr*nm; ib = ie-nm+1; m=ll(ib:ie)                           !--- section bounds for tracer "itr" ; outlayers mask
-    IF(.NOT.ANY(m)) CYCLE                                            !--- no outlayers for tracer "itr"
-    v = TRIM(vnm(MIN(itr,SIZE(vnm))))//'('//TRIM(s)                  !--- "<name>("
-    IF(nv == 1) ttl(rk) = TRIM(v)//','//int2str(itr)//')'            !--- "<name>(i,j,itr)" (single name)
-    IF(nv /= 1) ttl(rk) = TRIM(v)//')'                               !--- "<nam(itr)>(i,j)" (one name each table/itr index)
-    IF(rk==2) lerr = dispTable('ir',  ttl, i=cat(PACK(ki,m)),            r=cat(PACK(a(ib:ie),m)), &
-                                 rFmt=fm, nRowMax=nRmx, nColMax=nCmx, nHead=nHd, unit=unt, sub=sub)
-    IF(rk==3) lerr = dispTable('iir', ttl, i=cat(PACK(ki,m),PACK(kj,m)), r=cat(PACK(a(ib:ie),m)), &
-                                 rFmt=fm, nRowMax=nRmx, nColMax=nCmx, nHead=nHd, unit=unt, sub=sub)
-    CALL msg("can't display outliers table", sub, lerr, unt)
-    IF(lerr) RETURN
-  END DO
-END FUNCTION dispOutliers_1
-!==============================================================================================================================
-LOGICAL FUNCTION dispOutliers_2(ll, a, n, err_msg, nam, subn, nRowMax, nColMax, nHead, unit) RESULT(lerr)
-  IMPLICIT NONE
-! Display outliers list in tables
-! If "nam" is supplied and, it means the last index is for tracers => one table each tracer for rank > 2.
-  LOGICAL,                    INTENT(IN)  :: ll(:)                   !--- Linearized mask of outliers
-  REAL,                       INTENT(IN)  ::  a(:,:)                 !--- Linearized arrays of values stacked along 2nd dim.
-  INTEGER,                    INTENT(IN)  ::  n(:)                   !--- Profile before linearization
-  CHARACTER(LEN=*), OPTIONAL, INTENT(IN)  :: err_msg, nam(:), subn   !--- Error message, variables and calling subroutine names
-  INTEGER,          OPTIONAL, INTENT(IN)  :: nRowMax                 !--- Maximum number of lines to display    (default: all)
-  INTEGER,          OPTIONAL, INTENT(IN)  :: nColMax                 !--- Maximum number of characters per line (default: 2048)
-  INTEGER,          OPTIONAL, INTENT(IN)  :: nHead                   !--- Number of front columns to duplicate  (default: 1)
-  INTEGER,          OPTIONAL, INTENT(IN)  :: unit                    !--- Output unit                           (def: lunout)
-!------------------------------------------------------------------------------------------------------------------------------
-  CHARACTER(LEN=maxlen)                   :: mes, sub, fm='(f12.9)', prf
-  CHARACTER(LEN=maxlen),      ALLOCATABLE :: ttl(:), vnm(:)
-  INTEGER,                    ALLOCATABLE :: ki(:), kj(:), kl(:)
-  INTEGER                                 :: i, j, k, rk, nv, unt, nRmx, nCmx, nHd
-  REAL,                       ALLOCATABLE :: val(:,:)
-
-  lerr = ANY(ll); IF(.NOT.lerr) RETURN                               !--- No outliers -> finished
-  rk = SIZE(n); nv = SIZE(a,2)
-  mes = 'outliers found';        IF(PRESENT(err_msg)) mes = err_msg  !--- Error message
-  vnm = [(ACHAR(k+96),k=1,nv)];  IF(PRESENT(nam ))    vnm = nam      !--- Variables names
-  sub = 'dispOutliers';          IF(PRESENT(subn))    sub = subn     !--- Calling subroutine name
-  nRmx= SIZE(a);          IF(PRESENT(nRowMax)) nRmx=MIN(nRmx,nRowMax)!-- Maximum number of lines to print
-  nCmx= 2048;             IF(PRESENT(nColMax)) nCmx=MIN(nCmx,nColMax)!-- Maximum number of characters each line
-  nHd = 1;                IF(PRESENT(nHead))   nHd = nHead           !--- Number of front columns to duplicate
-  unt = lunout;                  IF(PRESENT(unit))    unt = unit     !--- Unit to print messages
-  lerr= SIZE(vnm) /= nv;         IF(fmsg('SIZE(nam) /= SIZE(a,2)',                  sub, lerr, unt)) RETURN
-  lerr= SIZE(a,1) /= SIZE(ll);   IF(fmsg('"ll" and "a" sizes mismatch',             sub, lerr, unt)) RETURN
-  lerr= SIZE(a,1) /= PRODUCT(n); IF(fmsg('profile "n" does not match "a" and "ll"', sub, lerr, unt)) RETURN
-
-  SELECT CASE(rk)                                                   !--- Indices list
-    CASE(0); IF(ll(1)) THEN; WRITE(unt,'(a,", ",a," = ",2f12.9)')TRIM(vnm(1)),TRIM(vnm(2)),a(1,1),a(1,2); RETURN; END IF
-    CASE(1); ki = [  (i,i=1,n(1)) ]
-    CASE(2); ki = [ ((i,i=1,n(1)),j=1,n(2))];           kj = [ ((j,i=1,n(1)),j=1,n(2))]
-    CASE(3); ki = [(((i,i=1,n(1)),j=1,n(2)),k=1,n(3))]; kj = [(((j,i=1,n(1)),j=1,n(2)),k=1,n(3))]
-             kl = [(((k,i=1,n(1)),j=1,n(2)),k=1,n(3))]
-    CASE DEFAULT; WRITE(unt,*)'Sorry: routine "dispOutliers_2" is limited to rank 3'; RETURN
-  END SELECT
-
-  ttl = [(ACHAR(k), k = 105, 104+rk), vnm]                           !--- Titles list ('i', 'j', 'k'...'var1', 'var2', ...)
-  prf = REPEAT('i',rk)//REPEAT('r',nv)                               !--- Profile
-  ALLOCATE(val(COUNT(ll),nv)); DO k=1, nv; val(:,k) = PACK(a(:,k),ll); END DO
-  IF(rk == 1) lerr = dispTable(prf, ttl, i = cat(PACK(ki,ll)),                         r = val, &
-                                 rFmt=fm, nRowMax=nRmx, nColMax=nCmx, nHead=nHd, unit=unt, sub=sub)
-  IF(rk == 2) lerr = dispTable(prf, ttl, i = cat(PACK(ki,ll),PACK(kj,ll)),             r = val, &
-                                 rFmt=fm, nRowMax=nRmx, nColMax=nCmx, nHead=nHd, unit=unt, sub=sub)
-  IF(rk == 3) lerr = dispTable(prf, ttl, i = cat(PACK(ki,ll),PACK(kj,ll),PACK(kl,ll)), r = val, &
-                                 rFmt=fm, nRowMax=nRmx, nColMax=nCmx, nHead=nHd, unit=unt, sub=sub)
-  CALL msg("can't display outliers table", sub, lerr, unt)
-END FUNCTION dispOutliers_2
-!==============================================================================================================================
-
-
-!==============================================================================================================================
-!=== Reduce an algebrical expression (basic operations and parenthesis) to a single number (string format) ====================
-!==============================================================================================================================
-LOGICAL FUNCTION reduceExpr_1(str, val) RESULT(lerr)
-  IMPLICIT NONE
-  CHARACTER(LEN=*),      INTENT(IN)  :: str
-  CHARACTER(LEN=maxlen), INTENT(OUT) :: val
-!------------------------------------------------------------------------------------------------------------------------------
-  CHARACTER(LEN=maxlen)              :: v
-  CHARACTER(LEN=1024)                :: s, vv
-  CHARACTER(LEN=1024), ALLOCATABLE :: vl(:)
-  INTEGER,             ALLOCATABLE :: ip(:)
-  INTEGER :: nl, nn, i, j, im, ix
-  LOGICAL :: ll
-  s = str
-
-  !--- Check wether the parenthesis are correctly formed
-  ll = strCount(s,'(',nl)
-  ll = strCount(s,')',nn)
-  lerr = nl /= nn
-  IF(fmsg('Mismatching number of opening and closing parenthesis: '//TRIM(s), ll=lerr)) RETURN
-  nl = 2*nl-1
-
-  !--- Build vectors ; vl: parenthesis-separated elements ; ip: parenthesis types (1: opening, 2: closing)
-  ALLOCATE(ip(nl-1),vl(nl))
-  j = 1; im = 1
-  DO i = 1, LEN_TRIM(str)
-    ix = INDEX('()', str(i:i))
-    IF(ix == 0) CYCLE
-    ip(j) = ix
-    vl(j) = str(im:i-1)
-    j = j + 1; im = i + 1
-  END DO
-  vl(j) = str(im:LEN_TRIM(str))
-
-  !--- Search for each opening/closing parenthesis pair
-  DO WHILE(nl > 1)
-    i = 1; DO WHILE(ip(i) /= 1 .OR. ip(i+1) /= 2); i = i + 1; END DO !IF(i > SIZE(ip)+1) EXIT;END DO
-    lerr = reduceExpr_basic(vl(i+1), v); IF(lerr) RETURN
-    v = TRIM(vl(i))//TRIM(v); IF(i+2<=nl) v=TRIM(v)//TRIM(vl(i+2))
-    vv = v//REPEAT(' ',768)
-    IF(i == 1) THEN;         ip =  ip(3:nl-1);                vl = [            vv, vl(4  :nl)]
-    ELSE IF(i == nl-1) THEN; ip =  ip(1:nl-2);                vl = [vl(1:nl-3), vv            ]
-    ELSE;                    ip = [ip(1: i-1), ip(i+2:nl-1)]; vl = [vl(1: i-1), vv, vl(i+3:nl)]; END IF
-    nl = SIZE(vl)
-  END DO
-  lerr = reduceExpr_basic(vl(1), val)
-END FUNCTION reduceExpr_1
-
-
-!==============================================================================================================================
-!=== Reduce a simple algebrical expression (basic operations, no parenthesis) to a single number (string format) ==============
-!==============================================================================================================================
-LOGICAL FUNCTION reduceExpr_basic(str, val) RESULT(lerr)
-  IMPLICIT NONE
-  CHARACTER(LEN=*),      INTENT(IN)  :: str
-  CHARACTER(LEN=*),      INTENT(OUT) :: val
-  DOUBLE PRECISION,      ALLOCATABLE :: vl(:)
-  INTEGER,               ALLOCATABLE :: id(:)
-  CHARACTER(LEN=maxlen), ALLOCATABLE :: ky(:)
-  CHARACTER(LEN=1),      ALLOCATABLE :: op(:)
-!------------------------------------------------------------------------------------------------------------------------------
-  CHARACTER(LEN=1024) :: s
-  DOUBLE PRECISION :: v, vm, vp
-  INTEGER      :: i, ni, io
-  lerr = .FALSE.
-  IF(is_numeric(str)) THEN; val=TRIM(str); RETURN; END IF
-  op = ['^','/','*','+','-']                                                   !--- List of recognized operations
-  s = str
-  lerr = strParse_m(s, op, ky, lSc=.TRUE., id = id)                            !--- Parse the values
-  IF(lerr) RETURN                                                              !--- Problem with the parsing
-  vl = str2dble(ky)                                                            !--- Conversion to doubles
-  lerr = ANY(vl >= HUGE(1.d0))
-  CALL msg('Some values are non-numeric in: '//TRIM(s), ll=lerr)
-  IF(lerr) RETURN                                                              !--- Non-numerical values found
-  DO io = 1, SIZE(op)                                                          !--- Loop on known operators (order matters !)
-    DO i = SIZE(id), 1, -1                                                     !--- Loop on found operators
-      ni = SIZE(id)
-      IF(id(i) /= io) CYCLE                                                    !--- Current found operator is not op(io)
-      vm = vl(i); vp = vl(i+1)                                                 !--- Couple of values used for current operation
-      SELECT CASE(op(io))                                                      !--- Perform operation on the two values
-        CASE('^'); v = vm**vp
-        CASE('/'); v = vm/vp
-        CASE('*'); v = vm*vp
-        CASE('+'); v = vm+vp
-        CASE('-'); v = vm-vp
-      END SELECT
-      IF(i == ni) THEN; vl = [vl(1:ni-1), v]; ELSE; vl = [vl(1:i-1), v, vl(i+2:ni+1)]; END IF
-      IF(i == ni) THEN; id =  id(1:ni-1);     ELSE; id = [id(1:i-1),    id(i+1:ni  )]; END IF
-    END DO
-  END DO
-  val = dble2str(vl(1))
-
-END FUNCTION reduceExpr_basic
-!==============================================================================================================================
-
-!==============================================================================================================================
-FUNCTION reduceExpr_m(str, val) RESULT(lerr)
-  IMPLICIT NONE
-  LOGICAL,               ALLOCATABLE              :: lerr(:)
-  CHARACTER(LEN=*),                   INTENT(IN)  :: str(:)
-  CHARACTER(LEN=maxlen), ALLOCATABLE, INTENT(OUT) :: val(:)
-!------------------------------------------------------------------------------------------------------------------------------
-  INTEGER :: i
-  ALLOCATE(lerr(SIZE(str)),val(SIZE(str)))
-  lerr(:) = [(reduceExpr_1(str(i), val(i)), i=1, SIZE(str))]
-END FUNCTION reduceExpr_m
-!==============================================================================================================================
-
-
-!==============================================================================================================================
-!=== Check whether a string is a number or not ================================================================================
-!==============================================================================================================================
-ELEMENTAL LOGICAL FUNCTION is_numeric(str) RESULT(out)
-  IMPLICIT NONE
-  CHARACTER(LEN=*), INTENT(IN) :: str
-  REAL    :: x
-  INTEGER :: e
-  CHARACTER(LEN=12) :: fmt
-  IF(TRIM(str) == '') THEN; out = .FALSE.; RETURN; END IF
-  WRITE(fmt,'("(f",i0,".0)")') LEN_TRIM(str)
-  READ(str,fmt,IOSTAT=e) x
-  out = e==0 .AND. INDEX('Ee',str(LEN_TRIM(str):LEN_TRIM(str)))==0
-END FUNCTION is_numeric
-!==============================================================================================================================
-
-
-!==============================================================================================================================
-!=== Convert a string into a logical/integer integer or an integer/real into a string =========================================
-!==============================================================================================================================
-ELEMENTAL INTEGER FUNCTION str2bool(str) RESULT(out)  !--- Result: 0/1 for .FALSE./.TRUE., -1 if not a valid boolean
-  IMPLICIT NONE
-  CHARACTER(LEN=*), INTENT(IN) :: str
-  INTEGER :: ierr
-  LOGICAL :: lout
-  READ(str,*,IOSTAT=ierr) lout
-  out = -HUGE(1)
-  IF(ierr /= 0) THEN
-    IF(ANY(['.false.', 'false  ', 'no     ', 'f      ', 'n      '] == strLower(str))) out = 0
-    IF(ANY(['.true. ', 'true   ', 'yes    ', 't      ', 'y      '] == strLower(str))) out = 1
-  ELSE
-    out = 0; IF(lout) out = 1
-  END IF
-END FUNCTION str2bool
-!==============================================================================================================================
-ELEMENTAL INTEGER FUNCTION str2int(str) RESULT(out)
-  IMPLICIT NONE
-  CHARACTER(LEN=*), INTENT(IN) :: str
-  INTEGER :: ierr
-  READ(str,*,IOSTAT=ierr) out
-  IF(ierr/=0) out = -HUGE(1)
-END FUNCTION str2int
-!==============================================================================================================================
-ELEMENTAL REAL FUNCTION str2real(str) RESULT(out)
-  IMPLICIT NONE
-  CHARACTER(LEN=*), INTENT(IN) :: str
-  INTEGER :: ierr
-  READ(str,*,IOSTAT=ierr) out
-  IF(ierr/=0) out = -HUGE(1.)
-END FUNCTION str2real
-!==============================================================================================================================
-ELEMENTAL DOUBLE PRECISION FUNCTION str2dble(str) RESULT(out)
-  IMPLICIT NONE
-  CHARACTER(LEN=*), INTENT(IN) :: str
-  INTEGER :: ierr
-  READ(str,*,IOSTAT=ierr) out
-  IF(ierr/=0) out = -HUGE(1.d0)
-END FUNCTION str2dble
-!==============================================================================================================================
-ELEMENTAL CHARACTER(LEN=maxlen) FUNCTION bool2str(b) RESULT(out)
-  IMPLICIT NONE
-  LOGICAL, INTENT(IN) :: b
-  WRITE(out,*)b
-  out = ADJUSTL(out)
-END FUNCTION bool2str
-!==============================================================================================================================
-ELEMENTAL CHARACTER(LEN=maxlen) FUNCTION int2str(i, nDigits) RESULT(out)
-  IMPLICIT NONE
-  INTEGER,           INTENT(IN) :: i
-  INTEGER, OPTIONAL, INTENT(IN) :: nDigits
-!------------------------------------------------------------------------------------------------------------------------------
-  WRITE(out,*)i
-  out = ADJUSTL(out)
-  IF(.NOT.PRESENT(nDigits)) RETURN
-  IF(nDigits > LEN_TRIM(out)) out = REPEAT('0', nDigits - LEN_TRIM(out))//TRIM(out)
-END FUNCTION int2str
-!==============================================================================================================================
-ELEMENTAL CHARACTER(LEN=maxlen) FUNCTION real2str(r,fmt) RESULT(out)
-  IMPLICIT NONE
-  REAL,                       INTENT(IN) :: r
-  CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: fmt
-!------------------------------------------------------------------------------------------------------------------------------
-  IF(     PRESENT(fmt)) WRITE(out,fmt)r
-  IF(.NOT.PRESENT(fmt)) WRITE(out, * )r
-  out = ADJUSTL(out)
-END FUNCTION real2str
-!==============================================================================================================================
-ELEMENTAL CHARACTER(LEN=maxlen) FUNCTION dble2str(d,fmt) RESULT(out)
-  IMPLICIT NONE
-  DOUBLE PRECISION,           INTENT(IN) :: d
-  CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: fmt
-!------------------------------------------------------------------------------------------------------------------------------
-  IF(     PRESENT(fmt)) WRITE(out,fmt)d
-  IF(.NOT.PRESENT(fmt)) WRITE(out, * )d
-  out = ADJUSTL(out)
-END FUNCTION dble2str
-!==============================================================================================================================
-ELEMENTAL SUBROUTINE cleanZeros(s)
-  IMPLICIT NONE
-  CHARACTER(LEN=*), INTENT(INOUT) :: s
-  INTEGER :: ls, ix, i
-  IF(is_numeric(s)) THEN
-    ls = LEN_TRIM(s)
-    ix = MAX(INDEX(s,'E'),INDEX(s,'e'),INDEX(s,'D'),INDEX(s,'d'))
-    IF(ix == 0) THEN
-      DO ix = ls,1,-1; IF(s(ix:ix) /= '0') EXIT; END DO; s=s(1:ix+1)
-    ELSE IF(INDEX(s,'.')/=0) THEN
-      i = ix-1; DO WHILE(s(i:i) == '0'); i = i-1; END DO; s=s(1:i)//s(ix:ls)
-    END IF
-  END IF
-END SUBROUTINE cleanZeros
-!==============================================================================================================================
-
-
-!==============================================================================================================================
-FUNCTION addQuotes_1(s) RESULT(out)
-  IMPLICIT NONE
-  CHARACTER(LEN=*), INTENT(IN)  :: s
-  CHARACTER(LEN=:), ALLOCATABLE :: out
-  IF(needQuotes(s)) THEN; out = "'"//TRIM(s)//"'"; ELSE; out = s; END IF
-END FUNCTION addQuotes_1
-!==============================================================================================================================
-FUNCTION addQuotes_m(s) RESULT(out)
-  IMPLICIT NONE
-  CHARACTER(LEN=*), INTENT(IN)  :: s(:)
-  CHARACTER(LEN=:), ALLOCATABLE :: out(:)
-!------------------------------------------------------------------------------------------------------------------------------
-  INTEGER :: k, n
-  n = MAXVAL(LEN_TRIM(s), MASK=.TRUE.)
-  ALLOCATE(CHARACTER(LEN=n) :: out(SIZE(s)))
-  DO k=1,SIZE(s)
-    IF(needQuotes(s(k))) THEN; out(k) = "'"//TRIM(s(k))//"'"; ELSE; out(k) = s(k); END IF
-  END DO
-END FUNCTION addQuotes_m
-!==============================================================================================================================
-ELEMENTAL LOGICAL FUNCTION needQuotes(s) RESULT(out)
-  IMPLICIT NONE
-  CHARACTER(LEN=*), INTENT(IN) :: s
-  CHARACTER(LEN=1) :: b, e
-!------------------------------------------------------------------------------------------------------------------------------
-  out = .TRUE.; IF(TRIM(s) == '') RETURN
-  b = s(1:1); e = s(MAX(1,LEN_TRIM(s)):MAX(1,LEN_TRIM(s)))
-  out = .NOT.is_numeric(s) .AND. (b /= "'" .OR. e /= "'") .AND. ( b /= '"' .OR. e /= '"')
-END FUNCTION needQuotes
-!==============================================================================================================================
-
-
-!==============================================================================================================================
-!=== DISPLAY "<message>: the following <items> are <reason>" FOLLOWED BY THE LIST OF <str> FOR WHICH <lerr>==T. ===============
-!==============================================================================================================================
-LOGICAL FUNCTION checkList(str, lerr, message, items, reason, nmax) RESULT(out)
-  IMPLICIT NONE
-! Purpose: Messages in case a list contains wrong elements (indicated by lerr boolean vector).
-! Note:    Return value "out" is .TRUE. if there are errors (ie at least one element of "lerr" is TRUE).
-  CHARACTER(LEN=*),   INTENT(IN)  :: str(:)
-  LOGICAL,            INTENT(IN)  :: lerr(:)
-  CHARACTER(LEN=*),   INTENT(IN)  :: message, items, reason
-  INTEGER,  OPTIONAL, INTENT(IN)  :: nmax
-!------------------------------------------------------------------------------------------------------------------------------
-  CHARACTER(LEN=maxlen), ALLOCATABLE :: s(:)
-  INTEGER :: i, nmx
-  nmx = 256; IF(PRESENT(nmax)) nmx=nmax
-  out = ANY(lerr); IF(.NOT.out) RETURN
-  CALL msg(TRIM(message)//': the following '//TRIM(items)//' are '//TRIM(reason)//':')
-  s = strStackm(PACK(str, MASK=lerr), ', ',nmx)
-  DO i=1,SIZE(s,DIM=1); CALL msg(s(i)); END DO
-END FUNCTION checkList
-!==============================================================================================================================
-
-
-!==============================================================================================================================
-!=== Remove comment in line "str", ie all the characters from the first "#" sign found in "str". ==============================
-!==============================================================================================================================
-SUBROUTINE removeComment(str)
-  IMPLICIT NONE
-  CHARACTER(LEN=*), INTENT(INOUT) :: str
-  INTEGER :: ix
-  ix = INDEX(str,'# '); IF(ix /= 0) str = str(1:ix-1)//REPEAT(' ',LEN(str)-ix+1)
-END SUBROUTINE removeComment
-!==============================================================================================================================
-
-
-END MODULE strings_mod
Index: /LMDZ6/trunk/libf/misc/strings_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/misc/strings_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/misc/strings_mod.f90	(revision 5268)
@@ -0,0 +1,1694 @@
+MODULE strings_mod
+
+  IMPLICIT NONE
+
+  PRIVATE
+  PUBLIC :: maxlen, init_printout, msg, fmsg, get_in, lunout, prt_level
+  PUBLIC :: strLower, strHead, strStack,  strCount, strReduce,  strClean, strIdx
+  PUBLIC :: strUpper, strTail, strStackm, strParse, strReplace, strFind, find, cat
+  PUBLIC :: dispTable, dispOutliers, dispNameList
+  PUBLIC :: is_numeric, bool2str, int2str, real2str, dble2str
+  PUBLIC :: reduceExpr, str2bool, str2int, str2real, str2dble
+  PUBLIC :: addQuotes, checkList, removeComment
+
+  INTERFACE get_in;     MODULE PROCEDURE getin_s,  getin_i,  getin_r,  getin_l;  END INTERFACE get_in
+  INTERFACE  msg;       MODULE PROCEDURE        msg_1,                    msg_m; END INTERFACE  msg
+  INTERFACE fmsg;       MODULE PROCEDURE       fmsg_1,                   fmsg_m; END INTERFACE fmsg
+  INTERFACE strHead;    MODULE PROCEDURE    strHead_1,                strHead_m; END INTERFACE strHead
+  INTERFACE strTail;    MODULE PROCEDURE    strTail_1,                strTail_m; END INTERFACE strTail
+  INTERFACE strClean;   MODULE PROCEDURE   strClean_1,               strClean_m; END INTERFACE strClean
+  INTERFACE strReduce;  MODULE PROCEDURE  strReduce_1,              strReduce_2; END INTERFACE strReduce
+  INTERFACE strIdx;     MODULE PROCEDURE     strIdx_1,                 strIdx_m; END INTERFACE strIdx
+  INTERFACE strCount;   MODULE PROCEDURE  strCount_m1, strCount_11, strCount_1m; END INTERFACE strCount
+  INTERFACE strReplace; MODULE PROCEDURE strReplace_1,             strReplace_m; END INTERFACE strReplace
+  INTERFACE cat;        MODULE PROCEDURE  horzcat_s00, horzcat_i00, horzcat_r00,  & !horzcat_d00, &
+                                          horzcat_s10, horzcat_i10, horzcat_r10,  & !horzcat_d10, &
+                                          horzcat_s11, horzcat_i11, horzcat_r11,  & !horzcat_d11, &
+                                          horzcat_s21, horzcat_i21, horzcat_r21; END INTERFACE cat !horzcat_d21
+  INTERFACE strFind;      MODULE PROCEDURE strFind_1, strFind_m;                 END INTERFACE strFind
+  INTERFACE find;         MODULE PROCEDURE strFind_1, strFind_m, intFind_1, intFind_m, booFind; END INTERFACE find
+  INTERFACE dispOutliers; MODULE PROCEDURE dispOutliers_1, dispOutliers_2; END INTERFACE dispOutliers
+  INTERFACE reduceExpr;   MODULE PROCEDURE   reduceExpr_1,   reduceExpr_m; END INTERFACE reduceExpr
+  INTERFACE addQuotes;    MODULE PROCEDURE    addQuotes_1,    addQuotes_m; END INTERFACE addQuotes
+
+  INTEGER, PARAMETER :: maxlen    = 256                    !--- Standard maximum length for strings
+  INTEGER,      SAVE :: lunout    = 6                      !--- Printing unit  (default: 6, ie. on screen)
+  INTEGER,      SAVE :: prt_level = 1                      !--- Printing level (default: 1, ie. print all)
+
+CONTAINS
+
+
+!==============================================================================================================================
+SUBROUTINE init_printout(lunout_, prt_level_)
+  IMPLICIT NONE
+  INTEGER, INTENT(IN) :: lunout_, prt_level_
+  lunout    = lunout_
+  prt_level = prt_level_
+END SUBROUTINE init_printout
+!==============================================================================================================================
+
+
+!==============================================================================================================================
+!=== Same as getin ; additional last argument: the default value.
+!==============================================================================================================================
+SUBROUTINE getin_s(nam, val, def)
+  USE ioipsl, ONLY: getin
+  IMPLICIT NONE
+  CHARACTER(LEN=*), INTENT(IN)    :: nam
+  CHARACTER(LEN=*), INTENT(INOUT) :: val
+  CHARACTER(LEN=*), INTENT(IN)    :: def
+  val = def; CALL getin(nam, val)
+  IF(val/=def) WRITE(lunout,*)TRIM(nam)//' = '//TRIM(val)
+END SUBROUTINE getin_s
+!==============================================================================================================================
+SUBROUTINE getin_i(nam, val, def)
+  USE ioipsl, ONLY: getin
+  IMPLICIT NONE
+  CHARACTER(LEN=*), INTENT(IN)    :: nam
+  INTEGER,          INTENT(INOUT) :: val
+  INTEGER,          INTENT(IN)    :: def
+  val = def; CALL getin(nam, val)
+  IF(val/=def) WRITE(lunout,*)TRIM(nam)//' = '//TRIM(int2str(val))
+END SUBROUTINE getin_i
+!==============================================================================================================================
+SUBROUTINE getin_r(nam, val, def)
+  USE ioipsl, ONLY: getin
+  IMPLICIT NONE
+  CHARACTER(LEN=*), INTENT(IN)    :: nam
+  REAL,             INTENT(INOUT) :: val
+  REAL,             INTENT(IN)    :: def
+  val = def; CALL getin(nam, val)
+  IF(val/=def) WRITE(lunout,*)TRIM(nam)//' = '//TRIM(real2str(val))
+END SUBROUTINE getin_r
+!==============================================================================================================================
+SUBROUTINE getin_l(nam, val, def)
+  USE ioipsl, ONLY: getin
+  IMPLICIT NONE
+  CHARACTER(LEN=*), INTENT(IN)    :: nam
+  LOGICAL,          INTENT(INOUT) :: val
+  LOGICAL,          INTENT(IN)    :: def
+  val = def; CALL getin(nam, val)
+  IF(val.NEQV.def) WRITE(lunout,*)TRIM(nam)//' = '//TRIM(bool2str(val))
+END SUBROUTINE getin_l
+!==============================================================================================================================
+
+
+!==============================================================================================================================
+!=== Display one or several messages, one each line, starting with the current routine name "modname".
+!==============================================================================================================================
+SUBROUTINE msg_1(str, modname, ll, unit)
+  IMPLICIT NONE
+  !--- Display a simple message "str". Optional parameters:
+  !    * "modname": module name, displayed in front of the message (with ": " separator) if present.
+  !    * "ll":      message trigger ; message is displayed only if ll==.TRUE.
+  !    * "unit":    write unit (by default: "lunout")
+  CHARACTER(LEN=*),           INTENT(IN) :: str
+  CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: modname
+  LOGICAL,          OPTIONAL, INTENT(IN) :: ll
+  INTEGER,          OPTIONAL, INTENT(IN) :: unit
+!------------------------------------------------------------------------------------------------------------------------------
+  CHARACTER(LEN=maxlen) :: subn
+  INTEGER :: unt
+  subn = '';    IF(PRESENT(modname)) subn = modname
+  IF(PRESENT(ll)) THEN; IF(.NOT.ll) RETURN; END IF
+  unt = lunout; IF(PRESENT(unit)) unt = unit
+  IF(subn == '') WRITE(unt,'(a)') str                                          !--- Simple message
+  IF(subn /= '') WRITE(unt,'(a)') TRIM(subn)//': '//str                        !--- Routine name provided
+END SUBROUTINE msg_1
+!==============================================================================================================================
+SUBROUTINE msg_m(str, modname, ll, unit, nmax)
+  IMPLICIT NONE
+  !--- Same as msg_1 with multiple strings that are stacked (separator: coma) on up to "nmax" full lines.
+  CHARACTER(LEN=*),           INTENT(IN) :: str(:)
+  CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: modname
+  LOGICAL,          OPTIONAL, INTENT(IN) :: ll
+  INTEGER,          OPTIONAL, INTENT(IN) :: unit
+  INTEGER,          OPTIONAL, INTENT(IN) :: nmax
+!------------------------------------------------------------------------------------------------------------------------------
+  CHARACTER(LEN=maxlen), ALLOCATABLE :: s(:)
+  CHARACTER(LEN=maxlen) :: subn
+  INTEGER :: unt, nmx, k
+  LOGICAL :: l
+  subn = '';    IF(PRESENT(modname)) subn = modname
+  l   = .TRUE.; IF(PRESENT(ll))     l = ll
+  unt = lunout; IF(PRESENT(unit)) unt = unit
+  nmx = 128;    IF(PRESENT(nmax)) nmx = nmax
+  s = strStackm(str, ', ', nmx)
+  DO k=1,SIZE(s); CALL msg_1(s(k), subn,  l,   unt); END DO
+END SUBROUTINE msg_m
+!==============================================================================================================================
+LOGICAL FUNCTION fmsg_1(str, modname, ll, unit) RESULT(l)
+  IMPLICIT NONE
+  CHARACTER(LEN=*),           INTENT(IN) :: str
+  CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: modname
+  LOGICAL,          OPTIONAL, INTENT(IN) :: ll
+  INTEGER,          OPTIONAL, INTENT(IN) :: unit
+!------------------------------------------------------------------------------------------------------------------------------
+  CHARACTER(LEN=maxlen) :: subn
+  INTEGER :: unt
+  subn = '';    IF(PRESENT(modname)) subn = modname
+  l   = .TRUE.; IF(PRESENT(ll))     l = ll
+  unt = lunout; IF(PRESENT(unit)) unt = unit
+  CALL msg_1(str, subn, l, unt)
+END FUNCTION fmsg_1
+!==============================================================================================================================
+LOGICAL FUNCTION fmsg_m(str, modname, ll, unit, nmax) RESULT(l)
+  IMPLICIT NONE
+  CHARACTER(LEN=*),           INTENT(IN)  :: str(:)
+  CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: modname
+  LOGICAL,          OPTIONAL, INTENT(IN) :: ll
+  INTEGER,          OPTIONAL, INTENT(IN) :: unit
+  INTEGER,          OPTIONAL, INTENT(IN)  :: nmax
+!------------------------------------------------------------------------------------------------------------------------------
+  CHARACTER(LEN=maxlen) :: subn
+  INTEGER :: unt, nmx
+  subn = '';    IF(PRESENT(modname)) subn = modname
+  l   = .TRUE.; IF(PRESENT(ll))     l = ll
+  unt = lunout; IF(PRESENT(unit)) unt = unit
+  nmx = 128;    IF(PRESENT(nmax)) nmx = nmax
+  CALL msg_m(str, subn, l, unt, nmx)
+END FUNCTION fmsg_m
+!==============================================================================================================================
+
+
+!==============================================================================================================================
+!=== Lower/upper case conversion function. ====================================================================================
+!==============================================================================================================================
+ELEMENTAL CHARACTER(LEN=maxlen) FUNCTION strLower(str) RESULT(out)
+  IMPLICIT NONE
+  CHARACTER(LEN=*), INTENT(IN) :: str
+  INTEGER :: k
+  out = str
+  DO k=1,LEN_TRIM(str)
+    IF(str(k:k)>='A' .AND. str(k:k)<='Z') out(k:k)=ACHAR(IACHAR(str(k:k))+32)
+  END DO
+END FUNCTION strLower
+!==============================================================================================================================
+ELEMENTAL CHARACTER(LEN=maxlen) FUNCTION strUpper(str) RESULT(out)
+  IMPLICIT NONE
+  CHARACTER(LEN=*), INTENT(IN) :: str
+  INTEGER :: k
+  out = str
+  DO k=1,LEN_TRIM(str)
+    IF(str(k:k)>='a' .AND. str(k:k)<='z') out(k:k)=ACHAR(IACHAR(str(k:k))-32)
+  END DO
+END FUNCTION strUpper
+!==============================================================================================================================
+
+
+!==============================================================================================================================
+!=== Extract the substring in front of the first (last if lBackward==TRUE) occurrence of "sep" in "str"        ================
+!=== Examples for str='a_b_c' and sep='_' and the bash command with the same effect:                           ================
+!===    * strHead(..,.FALSE.) = 'a'           ${str%%$sep*}                                                    ================
+!===    * strHead(..,.TRUE.)  = 'a_b'         ${str%$sep*}                                                     ================
+!==============================================================================================================================
+CHARACTER(LEN=maxlen) FUNCTION strHead_1(str, sep, lBackward) RESULT(out)
+  IMPLICIT NONE
+  CHARACTER(LEN=*),           INTENT(IN) :: str
+  CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: sep
+  LOGICAL,          OPTIONAL, INTENT(IN) :: lBackward
+!------------------------------------------------------------------------------------------------------------------------------
+  IF(PRESENT(sep)) THEN
+    IF(     PRESENT(lBackWard)) out = str(1:INDEX(str,sep,lBackWard)-1)
+    IF(.NOT.PRESENT(lBackWard)) out = str(1:INDEX(str,sep)-1)
+  ELSE
+    IF(     PRESENT(lBackWard)) out = str(1:INDEX(str,'/',lBackWard)-1)
+    IF(.NOT.PRESENT(lBackWard)) out = str(1:INDEX(str,'/')-1)
+  END IF
+  IF(out == '') out = str
+END FUNCTION strHead_1
+!==============================================================================================================================
+FUNCTION strHead_m(str, sep, lBackward) RESULT(out)
+  IMPLICIT NONE
+  CHARACTER(LEN=maxlen),     ALLOCATABLE :: out(:)
+  CHARACTER(LEN=*),           INTENT(IN) :: str(:)
+  CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: sep
+  LOGICAL,          OPTIONAL, INTENT(IN) :: lBackward
+!------------------------------------------------------------------------------------------------------------------------------
+  INTEGER :: k
+  IF(PRESENT(sep)) THEN
+    IF(     PRESENT(lBackWard)) out = [(strHead_1(str(k), sep, lBackWard), k=1, SIZE(str))]
+    IF(.NOT.PRESENT(lBackWard)) out = [(strHead_1(str(k), sep),            k=1, SIZE(str))]
+  ELSE
+    IF(     PRESENT(lBackWard)) out = [(strHead_1(str(k), '/', lBackWard), k=1, SIZE(str))]
+    IF(.NOT.PRESENT(lBackWard)) out = [(strHead_1(str(k), '/'),            k=1, SIZE(str))]
+  END IF
+END FUNCTION strHead_m
+!==============================================================================================================================
+!=== Extract the substring following the first (last if lBackward==TRUE) occurrence of "sep" in "str"          ================
+!=== Examples for str='a_b_c' and sep='_' and the bash command with the same effect:                           ================
+!===    * strTail(str, '_', .FALSE.) = 'b_c'         ${str#*$sep}                                              ================
+!===    * strTail(str, '_', .TRUE.)  = 'c'           ${str##*$sep}                                             ================
+!==============================================================================================================================
+CHARACTER(LEN=maxlen) FUNCTION strTail_1(str, sep, lBackWard) RESULT(out)
+  IMPLICIT NONE
+  CHARACTER(LEN=*),           INTENT(IN) :: str
+  CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: sep
+  LOGICAL,          OPTIONAL, INTENT(IN) :: lBackWard
+!------------------------------------------------------------------------------------------------------------------------------
+  IF(PRESENT(sep)) THEN
+    IF(     PRESENT(lBackWard)) out = str(INDEX(str,sep,lBackWard)+LEN(sep):LEN_TRIM(str))
+    IF(.NOT.PRESENT(lBackWard)) out = str(INDEX(str,sep)          +LEN(sep):LEN_TRIM(str))
+  ELSE
+    IF(     PRESENT(lBackWard)) out = str(INDEX(str,'/',lBackWard)+1:LEN_TRIM(str))
+    IF(.NOT.PRESENT(lBackWard)) out = str(INDEX(str,'/')          +1:LEN_TRIM(str))
+  END IF
+  IF(out == '') out = str
+END FUNCTION strTail_1
+!==============================================================================================================================
+FUNCTION strTail_m(str, sep, lBackWard) RESULT(out)
+  IMPLICIT NONE
+  CHARACTER(LEN=maxlen),     ALLOCATABLE :: out(:)
+  CHARACTER(LEN=*),           INTENT(IN) :: str(:)
+  CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: sep
+  LOGICAL,          OPTIONAL, INTENT(IN) :: lBackWard
+!------------------------------------------------------------------------------------------------------------------------------
+  INTEGER :: k
+  IF(PRESENT(sep)) THEN
+    IF(     PRESENT(lBackWard)) out = [(strTail_1(str(k), sep, lBackWard), k=1, SIZE(str))]
+    IF(.NOT.PRESENT(lBackWard)) out = [(strTail_1(str(k), sep),            k=1, SIZE(str))]
+  ELSE
+    IF(     PRESENT(lBackWard)) out = [(strTail_1(str(k), '/', lBackWard), k=1, SIZE(str))]
+    IF(.NOT.PRESENT(lBackWard)) out = [(strTail_1(str(k), '/'),            k=1, SIZE(str))]
+  END IF
+END FUNCTION strTail_m
+!==============================================================================================================================
+
+
+!==============================================================================================================================
+!=== Concatenates the strings "str(:)" with separator "sep" into a single string using a separator (',' by default). ==========
+!==============================================================================================================================
+FUNCTION strStack(str, sep, mask) RESULT(out)
+  IMPLICIT NONE
+  CHARACTER(LEN=:),          ALLOCATABLE :: out
+  CHARACTER(LEN=*),           INTENT(IN) :: str(:)
+  CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: sep
+  LOGICAL,          OPTIONAL, INTENT(IN) :: mask(:)
+!------------------------------------------------------------------------------------------------------------------------------
+  CHARACTER(LEN=:), ALLOCATABLE :: s
+  INTEGER :: is, i0
+  IF(SIZE(str) == 0) THEN; out = ''; RETURN; END IF
+  ALLOCATE(s, SOURCE=', '); IF(PRESENT(sep)) s=sep
+  IF(PRESENT(mask)) THEN
+    IF(ALL(.NOT.mask)) THEN; out = ''; RETURN; END IF
+    i0 = 0; DO WHILE(.NOT.mask(i0+1)); i0 = i0+1; END DO
+    out = str(i0); DO is=i0+1,SIZE(str, DIM=1); IF(.NOT.mask(is)) CYCLE; out = TRIM(out)//s//TRIM(str(is)); END DO
+  ELSE
+    out = str(1); DO is=2,SIZE(str, DIM=1); out = TRIM(out)//s//TRIM(str(is)); END DO
+  END IF
+END FUNCTION strStack
+!==============================================================================================================================
+!=== Concatenate the strings "str(:)" with separator "sep" into one or several lines of "nmax" characters max (for display) ===
+!==============================================================================================================================
+FUNCTION strStackm(str, sep, nmax) RESULT(out)
+  IMPLICIT NONE
+  CHARACTER(LEN=maxlen),     ALLOCATABLE :: out(:)
+  CHARACTER(LEN=*),           INTENT(IN) :: str(:)
+  CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: sep
+  INTEGER,          OPTIONAL, INTENT(IN) :: nmax
+!------------------------------------------------------------------------------------------------------------------------------
+  CHARACTER(LEN=maxlen), ALLOCATABLE :: t(:)
+  CHARACTER(LEN=maxlen) :: sp
+  INTEGER :: is, ns, no, mx, n
+  IF(SIZE(str) == 0) THEN; out = ['']; RETURN; END IF
+  sp =', '; IF(PRESENT(sep )) sp = sep
+  ns = 2  ; IF(PRESENT(sep )) ns = LEN(sep)
+  mx = 256; IF(PRESENT(nmax)) mx = nmax
+  no = 1; out = ['']
+  DO is = 1, SIZE(str)
+    n = LEN_TRIM(str(is)); IF(out(no)/='') n = n+ns+LEN_TRIM(out(no))          !--- Line length after "str(is)" inclusion
+    IF(out(no) == '') THEN
+      out(no) = str(is)                                                        !--- Empty new line: set to "str(is)"
+    ELSE IF(n <= mx) THEN
+      out(no) = TRIM(out(no))//sp(1:ns)//TRIM(str(is))                         !--- Append "str(is)" to the current line
+    ELSE
+      ALLOCATE(t(no+1)); t(1:no) = out; no=no+1; t(no) = str(is)               !--- Full line: "str(si)" put in next line
+      CALL MOVE_ALLOC(FROM=t, TO=out)
+    END IF
+  END DO
+END FUNCTION strStackm
+!==============================================================================================================================
+
+
+!==============================================================================================================================
+!=== String cleaning: replace tabulation by spaces, remove NULL characters and comments. ======================================
+!==============================================================================================================================
+SUBROUTINE strClean_1(str)
+  IMPLICIT NONE
+  CHARACTER(LEN=*), INTENT(INOUT) :: str
+  INTEGER :: k, n, m
+  n = LEN(str)
+  DO k = n, 1, -1
+    m = IACHAR(str(k:k))
+    IF(m==9) str(k:k) = ' '                           !--- Replace the tabulations with spaces
+    IF(m==0) str(k:n) = str(k+1:n)//' '               !--- Remove the NULL characters
+  END DO
+  m = INDEX(str,'!')-1; IF(m==-1) m = LEN_TRIM(str)   !--- Remove end of line comment
+  str = ADJUSTL(str(1:m))
+END SUBROUTINE strClean_1
+!==============================================================================================================================
+SUBROUTINE strClean_m(str)
+  IMPLICIT NONE
+  CHARACTER(LEN=*), INTENT(INOUT) :: str(:)
+  INTEGER :: k
+  DO k = 1, SIZE(str); CALL strClean_1(str(k)); END DO
+END SUBROUTINE strClean_m
+!==============================================================================================================================
+
+
+!==============================================================================================================================
+!=== strReduce_1(str1)     : Remove duplicated elements of str1.    ===========================================================
+!=== strReduce_2(str1,str2): Append str1 with new elements of str2. ===========================================================
+!==============================================================================================================================
+SUBROUTINE strReduce_1(str, nb)
+  IMPLICIT NONE
+  CHARACTER(LEN=*), ALLOCATABLE, INTENT(INOUT) :: str(:)
+  INTEGER,          OPTIONAL,    INTENT(OUT)   :: nb
+!------------------------------------------------------------------------------------------------------------------------------
+  CHARACTER(LEN=maxlen), ALLOCATABLE :: s1(:)
+  INTEGER :: k, n, n1
+  IF(PRESENT(nb)) nb = 0
+  CALL MOVE_ALLOC(FROM=str, TO=s1); CALL strClean(s1)
+  n1 = SIZE(s1, DIM=1)                                     !--- Total nb. of elements in "s1"
+  n  = COUNT( [( ALL(s1(1:k-1)/=s1(k)), k=1, n1 )] )       !--- Nb of unique elements in "s1"
+  ALLOCATE(str(n))
+  IF(n==0) RETURN
+  str(1) = s1(1)
+  n=1; DO k=2,n1; IF(ANY(s1(1:k-1)==s1(k))) CYCLE; n=n+1; str(n)=s1(k); END DO
+  IF(PRESENT(nb)) nb=n
+END SUBROUTINE strReduce_1
+!==============================================================================================================================
+SUBROUTINE strReduce_2(str1, str2)
+  IMPLICIT NONE
+  CHARACTER(LEN=*),   ALLOCATABLE, INTENT(INOUT) :: str1(:)
+  CHARACTER(LEN=*),                INTENT(IN)    :: str2(:)
+!------------------------------------------------------------------------------------------------------------------------------
+  CHARACTER(LEN=maxlen), ALLOCATABLE :: s1(:), s2(:)
+  INTEGER :: k
+  IF(SIZE(str2)==0) RETURN
+  s2 = str2; CALL strClean(s2)
+  IF(.NOT.ALLOCATED(s2)) RETURN
+  IF(SIZE(s2) == 0) THEN; DEALLOCATE(s2); RETURN; END IF
+  IF(.NOT.ALLOCATED(str1)) THEN
+    str1 = s2
+  ELSE IF(SIZE(str1)==0) THEN
+    str1 = s2
+  ELSE
+    s1 = str1; CALL strClean(s1)
+    str1 = [s1, PACK(s2, MASK= [( ALL(s1(:) /= s2(k)), k=1, SIZE(s2) )] ) ]
+  END IF
+END SUBROUTINE strReduce_2
+!==============================================================================================================================
+
+
+!==============================================================================================================================
+!=== GET THE INDEX OF THE FIRST APPEARANCE IN THE STRING VECTOR "str(:)" OF THE STRING(s) "s[(:)]" ============================
+!=== OPTIONALY: GET THE NUMBER OF FOUND ELEMENTS "n". NB: UNFOUND => INDEX=0                       ============================
+!==============================================================================================================================
+INTEGER FUNCTION strIdx_1(str, s) RESULT(out)
+  IMPLICIT NONE
+  CHARACTER(LEN=*), INTENT(IN) :: str(:), s
+  DO out = 1, SIZE(str); IF(str(out) == s) EXIT; END DO
+  IF(out == 1+SIZE(str) .OR. SIZE(str)==0) out = 0
+END FUNCTION strIdx_1
+!==============================================================================================================================
+FUNCTION strIdx_m(str, s, n) RESULT(out)
+  IMPLICIT NONE
+  CHARACTER(LEN=*),  INTENT(IN)  :: str(:), s(:)
+  INTEGER, OPTIONAL, INTENT(OUT) :: n
+  INTEGER,           ALLOCATABLE :: out(:)
+!------------------------------------------------------------------------------------------------------------------------------
+  INTEGER :: k
+  out = [(strIdx_1(str(:), s(k)), k=1, SIZE(s))]
+  IF(PRESENT(n)) n = COUNT(out(:)/=0)
+END FUNCTION strIdx_m
+!==============================================================================================================================
+
+
+!==============================================================================================================================
+!=== GET THE INDEX LIST OF THE ELEMENTS OF "str(:)" EQUAL TO "s" AND OPTIONALY, ITS LENGTH "n" ================================
+!==============================================================================================================================
+FUNCTION strFind_1(str, s, n) RESULT(out)
+  IMPLICIT NONE
+  CHARACTER(LEN=*),  INTENT(IN)  :: str(:), s
+  INTEGER, OPTIONAL, INTENT(OUT) :: n
+  INTEGER,           ALLOCATABLE :: out(:)
+!------------------------------------------------------------------------------------------------------------------------------
+  INTEGER :: k
+  out = PACK( [(k, k=1, SIZE(str(:), DIM=1))], MASK = str(:) == s )
+  IF(PRESENT(n)) n = SIZE(out(:), DIM=1)
+END FUNCTION strFind_1
+!==============================================================================================================================
+FUNCTION strFind_m(str, s, n) RESULT(out)
+  IMPLICIT NONE
+  CHARACTER(LEN=*),  INTENT(IN)  :: str(:), s(:)
+  INTEGER, OPTIONAL, INTENT(OUT) :: n
+  INTEGER,           ALLOCATABLE :: out(:)
+!------------------------------------------------------------------------------------------------------------------------------
+  INTEGER :: k
+  out = [(strFind_1(str, s(k)), k=1, SIZE(s))]
+  IF(PRESENT(n)) n = SIZE(out(:), DIM=1)
+END FUNCTION strFind_m
+!==============================================================================================================================
+FUNCTION intFind_1(i,j,n) RESULT(out)
+  IMPLICIT NONE
+  INTEGER,           INTENT(IN)  :: i(:), j
+  INTEGER, OPTIONAL, INTENT(OUT) :: n
+  INTEGER,           ALLOCATABLE :: out(:)
+!------------------------------------------------------------------------------------------------------------------------------
+  INTEGER :: k
+  out = PACK( [(k, k=1, SIZE(i(:), DIM=1))], MASK = i(:) == j )
+  IF(PRESENT(n)) n = SIZE(out(:), DIM=1)
+END FUNCTION intFind_1
+!==============================================================================================================================
+FUNCTION intFind_m(i,j,n) RESULT(out)
+  IMPLICIT NONE
+  INTEGER,           INTENT(IN)  :: i(:), j(:)
+  INTEGER, OPTIONAL, INTENT(OUT) :: n
+  INTEGER,           ALLOCATABLE :: out(:)
+!------------------------------------------------------------------------------------------------------------------------------
+  INTEGER :: k
+  out = [(intFind_1(i, j(k)), k=1, SIZE(j))]
+  IF(PRESENT(n)) n = SIZE(out(:), DIM=1)
+END FUNCTION intFind_m
+!==============================================================================================================================
+FUNCTION booFind(l,n) RESULT(out)
+   IMPLICIT NONE
+ LOGICAL,           INTENT(IN)  :: l(:)
+  INTEGER, OPTIONAL, INTENT(OUT) :: n
+  INTEGER,           ALLOCATABLE :: out(:)
+!------------------------------------------------------------------------------------------------------------------------------
+  INTEGER :: k
+  out = PACK( [(k, k=1, SIZE(l(:), DIM=1))], MASK = l(:) )
+  IF(PRESENT(n)) n = SIZE(out(:), DIM=1)
+END FUNCTION booFind
+!==============================================================================================================================
+
+
+!==============================================================================================================================
+!=== GET THE INDEX IN "rawList" OF THE 1ST APPEARANCE OF ONE OF THE "del(:)" SEPARATORS (0 IF NONE OF THEM ARE PRESENT)
+!===  IF lSc == .TRUE.:  * SKIP HEAD SIGNS OR EXPONENTS SIGNS THAT SHOULD NOT BE CONFUSED WITH SEPARATORS
+!===                     * THEN TEST WHETHER THE STRING FROM START TO THE FOUND SEPARATOR IS A CORRECTLY FORMATTED NUMBER
+!==============================================================================================================================
+LOGICAL FUNCTION strIdx_prv(rawList, del, ibeg, idx, idel, lSc) RESULT(lerr)
+  IMPLICIT NONE
+  CHARACTER(LEN=*),  INTENT(IN)  :: rawList                          !--- String in which delimiters have to be identified
+  CHARACTER(LEN=*),  INTENT(IN)  :: del(:)                           !--- List of delimiters
+  INTEGER,           INTENT(IN)  :: ibeg                             !--- Start index
+  INTEGER,           INTENT(OUT) :: idx                              !--- Index of the first identified delimiter in "rawList"
+  INTEGER,           INTENT(OUT) :: idel                             !--- Index of the identified delimiter (0 if idx==0)
+  LOGICAL, OPTIONAL, INTENT(IN)  :: lSc                              !--- Care about nbs with front sign or in scient. notation
+!------------------------------------------------------------------------------------------------------------------------------
+  INTEGER :: idx0                                                    !--- Used to display an identified non-numeric string
+  lerr = .FALSE.
+  idx = strIdx1(rawList, del, ibeg, idel)                            !--- idx/=0: del(idel) is at position "idx" in "rawList" 
+  IF(.NOT.PRESENT(lSc))               RETURN                         !--- No need to check exceptions for numbers => finished
+  IF(.NOT.        lSc )               RETURN                         !--- No need to check exceptions for numbers => finished
+
+  !=== No delimiter found: the whole string must be a valid number
+  IF(idx == 0) THEN                                                  !--- No element of "del" in "rawList"
+    lerr = .NOT.is_numeric(rawList(ibeg:LEN_TRIM(rawList)))          !--- String must be a number
+    IF(lerr) idx = LEN_TRIM(rawList); RETURN                         !--- Set idx so that rawList(ibeg:idx-1) = whole string
+  END IF
+
+  lerr = idx == 1 .AND. INDEX('+-',del(idel)) /= 0; IF(lerr) RETURN  !--- The front delimiter is different from +/-: error
+  IF(    idx /= 1 .AND. is_numeric(rawList(ibeg:idx-1)))     RETURN  !--- The input string head is a valid number
+
+  !=== The string part in front of the 1st delimiter is not a valid number: search for next delimiter index "idx"
+  idx0 = idx ; idx = strIdx1(rawList, del, idx+1, idel)              !--- Keep start index because idx is recycled
+  IF(idx == 0) THEN
+    lerr = .NOT.is_numeric(rawList(ibeg:LEN_TRIM(rawList)))          !--- No other delimiter: whole string must be a valid numb
+    IF(lerr) idx = idx0; RETURN
+  END IF
+  lerr = .NOT.is_numeric(rawList(ibeg:idx-1))
+
+CONTAINS
+
+!------------------------------------------------------------------------------------------------------------------------------
+INTEGER FUNCTION strIdx1(str, del, ib, id) RESULT(i)
+!--- Get the index of the first appereance of one of the delimiters "del(:)" in "str" starting from position "ib".
+!--- "id" is the index in "del(:)" of the first delimiter found.
+  IMPLICIT NONE
+  CHARACTER(LEN=*),  INTENT(IN)  :: str, del(:)
+  INTEGER,           INTENT(IN)  :: ib
+  INTEGER,           INTENT(OUT) :: id
+!------------------------------------------------------------------------------------------------------------------------------
+  DO i = ib, LEN_TRIM(str); id = strIdx(del, str(i:i)); IF(id /= 0) EXIT; END DO
+  IF(i > LEN_TRIM(str)) THEN; i = 0; id = 0; END IF
+END FUNCTION strIdx1
+
+END FUNCTION strIdx_prv
+!==============================================================================================================================
+
+
+!==============================================================================================================================
+!=== Count the number of elements separated by "delimiter" in list "rawList". =================================================
+!==============================================================================================================================
+LOGICAL FUNCTION strCount_11(rawList, delimiter, nb, lSc) RESULT(lerr)
+  IMPLICIT NONE
+  CHARACTER(LEN=*),  INTENT(IN)  :: rawList
+  CHARACTER(LEN=*),  INTENT(IN)  :: delimiter
+  INTEGER,           INTENT(OUT) :: nb
+  LOGICAL, OPTIONAL, INTENT(IN)  :: lSc
+!------------------------------------------------------------------------------------------------------------------------------
+  LOGICAL :: ll
+  ll = .FALSE.; IF(PRESENT(lSc)) ll = lSc
+  lerr = strCount_1m(rawList, [delimiter], nb, ll)
+END FUNCTION strCount_11
+!==============================================================================================================================
+LOGICAL FUNCTION strCount_m1(rawList, delimiter, nb, lSc) RESULT(lerr)
+  IMPLICIT NONE
+  CHARACTER(LEN=*),     INTENT(IN)  :: rawList(:)
+  CHARACTER(LEN=*),     INTENT(IN)  :: delimiter
+  INTEGER, ALLOCATABLE, INTENT(OUT) :: nb(:)
+  LOGICAL,    OPTIONAL, INTENT(IN)  :: lSc
+!------------------------------------------------------------------------------------------------------------------------------
+  LOGICAL :: ll
+  INTEGER :: id
+  ll  = .FALSE.; IF(PRESENT(lSc)) ll = lSc .AND. INDEX('+-', delimiter) /= 0
+  lerr = .TRUE.
+  ALLOCATE(nb(SIZE(rawList)))
+  DO id = 1, SIZE(rawList)
+    lerr = lerr .AND. strCount_1m(rawList(id), [delimiter], nb(id), ll)
+  END DO
+END FUNCTION strCount_m1
+!==============================================================================================================================
+LOGICAL FUNCTION strCount_1m(rawList, delimiter, nb, lSc) RESULT(lerr)
+  IMPLICIT NONE
+  CHARACTER(LEN=*),  INTENT(IN)  :: rawList
+  CHARACTER(LEN=*),  INTENT(IN)  :: delimiter(:)
+  INTEGER,           INTENT(OUT) :: nb
+  LOGICAL, OPTIONAL, INTENT(IN)  :: lSc
+!------------------------------------------------------------------------------------------------------------------------------
+  INTEGER              :: ib, ie, jd, nr
+  LOGICAL              :: ll
+  CHARACTER(LEN=1024)  :: r
+  lerr = .FALSE.
+  ll   = .FALSE.; IF(PRESENT(lSc)) ll = lSc
+  r  = TRIM(ADJUSTL(rawList))
+  nr = LEN_TRIM(r); IF(nr == 0) RETURN
+  nb = 1; ib = 1
+  DO
+    lerr = strIdx_prv(r, delimiter, ib, ie, jd, ll)
+    IF(fmsg('"'//TRIM(r(ib:ie-1))//'" is not numeric', ll=lerr)) RETURN
+    IF(ie == 0 .OR. jd == 0) EXIT
+    ib = ie + LEN(delimiter(jd))
+    DO WHILE(r(ib:ib) == ' ' .AND. ib < nr); ib = ib + 1; END DO     !--- Skip spaces before next chain
+    nb = nb + 1
+  END DO
+END FUNCTION strCount_1m
+!==============================================================================================================================
+
+
+!==============================================================================================================================
+!=== Purpose: Parse "delimiter"-separated list "rawList" into the pair keys(:), vals(:).   ====================================
+!===          Corresponding "vals" remains empty if the element does not contain "=" sign. ====================================
+!==============================================================================================================================
+LOGICAL FUNCTION strParse(rawList, delimiter, keys, n, vals) RESULT(lerr)
+  IMPLICIT NONE
+  CHARACTER(LEN=*),                             INTENT(IN)  :: rawList, delimiter
+  CHARACTER(LEN=maxlen), ALLOCATABLE,           INTENT(OUT) :: keys(:)
+  INTEGER,                            OPTIONAL, INTENT(OUT) :: n
+  CHARACTER(LEN=maxlen), ALLOCATABLE, OPTIONAL, INTENT(OUT) :: vals(:)
+!------------------------------------------------------------------------------------------------------------------------------
+  CHARACTER(LEN=1024) :: r
+  INTEGER :: nr, nk
+  lerr = .FALSE.
+  r  = TRIM(ADJUSTL(rawList))
+  nr = LEN_TRIM(r); IF(nr == 0) THEN; keys = ['']; RETURN; END IF
+  nk = countK()                                                      !--- COUNT THE ELEMENTS
+  CALL parseK(keys)                                                  !--- PARSE THE KEYS
+  IF(PRESENT(vals)) CALL parseV(vals)                                !--- PARSE <key>=<val> PAIRS
+  IF(PRESENT(n)) n = nk                                              !--- RETURN THE NUMBER OF KEYS
+
+CONTAINS
+
+!------------------------------------------------------------------------------------------------------------------------------
+INTEGER FUNCTION countK() RESULT(nkeys)
+!--- Get the number of elements after parsing.
+  IMPLICIT NONE
+!------------------------------------------------------------------------------------------------------------------------------
+  INTEGER :: ib, ie, nl
+  nkeys = 1; ib = 1; nl = LEN(delimiter)
+  DO
+    ie = INDEX(rawList(ib:nr), delimiter)+ib-1                       !--- Determine the next separator start index
+    IF(ie == ib-1) EXIT
+    ib = ie + nl
+    DO WHILE(ANY([0, 9, 32] == IACHAR(r(ib:ib))) .AND. ib < nr)      !--- Skip blanks (ascii): NULL (0), TAB (9), SPACE (32)
+      ib = ib + 1
+    END DO     !--- Skip spaces before next chain
+    nkeys = nkeys+1
+  END DO
+END FUNCTION countK
+
+!------------------------------------------------------------------------------------------------------------------------------
+SUBROUTINE parseK(keys)
+!--- Parse the string separated by "delimiter" from "rawList" into "keys(:)"
+  IMPLICIT NONE
+  CHARACTER(LEN=maxlen), ALLOCATABLE, INTENT(OUT) :: keys(:)
+!------------------------------------------------------------------------------------------------------------------------------
+  INTEGER :: ib, ie, ik
+  ALLOCATE(keys(nk))
+  ib = 1
+  DO ik = 1, nk
+    ie = INDEX(rawList(ib:nr), delimiter)+ib-1                       !--- Determine the next separator start index
+    IF(ie == ib-1) EXIT
+    keys(ik) = r(ib:ie-1)                                            !--- Get the ikth key
+    ib = ie + LEN(delimiter)
+    DO WHILE(r(ib:ib) == ' ' .AND. ib < nr); ib = ib + 1; END DO     !--- Skip spaces before next chain
+  END DO
+  keys(ik) = r(ib:nr)                                                !--- Get the last key
+END SUBROUTINE parseK
+
+!------------------------------------------------------------------------------------------------------------------------------
+SUBROUTINE parseV(vals)
+!--- Parse the <key>=<val> pairs in "keys(:)" into "keys" and "vals"
+  IMPLICIT NONE
+  CHARACTER(LEN=maxlen), ALLOCATABLE, INTENT(OUT) :: vals(:)
+!------------------------------------------------------------------------------------------------------------------------------
+  CHARACTER(LEN=maxlen) :: key
+  INTEGER :: ik, ix
+  ALLOCATE(vals(nk))
+  DO ik = 1, nk; key = keys(ik)
+    vals(ik) = ''
+    ix = INDEX(key, '='); IF(ix == 0) CYCLE                          !--- First "=" index in "key"
+    vals(ik) = ADJUSTL(key(ix+1:LEN_TRIM(key)))
+    keys(ik) = ADJUSTL(key(1:ix-1))
+  END DO
+END SUBROUTINE parseV
+
+END FUNCTION strParse
+!==============================================================================================================================
+LOGICAL FUNCTION strParse_m(rawList, delimiter, keys, n, vals, lSc, id) RESULT(lerr)
+  IMPLICIT NONE
+  CHARACTER(LEN=*),                             INTENT(IN)  :: rawList, delimiter(:)
+  CHARACTER(LEN=maxlen),           ALLOCATABLE, INTENT(OUT) :: keys(:)  !--- Parsed keys vector
+  INTEGER,               OPTIONAL,              INTENT(OUT) :: n        !--- Length of the parsed vector
+  CHARACTER(LEN=maxlen), OPTIONAL, ALLOCATABLE, INTENT(OUT) :: vals(:)  !--- Values for <name>=<value> keys
+  LOGICAL,               OPTIONAL,              INTENT(IN)  :: lSc      !--- Take care about numbers in scientific notation
+  INTEGER,               OPTIONAL, ALLOCATABLE, INTENT(OUT) :: id(:)    !--- Indexes of the separators in "delimiter(:)" vector
+!------------------------------------------------------------------------------------------------------------------------------
+  CHARACTER(LEN=1024) :: r
+  INTEGER :: nr, ik, nk, ib, ie, jd
+  LOGICAL :: ll
+  ll = .FALSE.; IF(PRESENT(lSc)) ll = lSc
+  lerr = strCount_1m(rawList, delimiter, nk, ll)
+  CALL msg("Couldn't parse list: non-numerical strings were found", ll=lerr); IF(lerr) RETURN
+
+  !--- FEW ALLOCATIONS
+  ALLOCATE(keys(nk))
+  IF(PRESENT(vals)) ALLOCATE(vals(nk))
+  IF(PRESENT(id))   ALLOCATE(id(nk-1))
+  IF(PRESENT(n)) n = nk
+
+  !--- PARSING
+  r  = TRIM(ADJUSTL(rawList))
+  nr = LEN_TRIM(r); IF(nr == 0) RETURN
+  ib = 1
+  DO ik = 1, nk-1
+    lerr = strIdx_prv(r, delimiter, ib, ie, jd, ll)
+    CALL msg('Non-numeric values found', ll=lerr); IF(lerr) RETURN
+    keys(ik) = r(ib:ie-1)
+    IF(PRESENT(vals)) CALL parseKeys(keys(ik), vals(ik))             !--- Parse a <key>=<val> pair
+    IF(PRESENT(id  )) id(ik) = jd                                    !--- Index in "delimiter(:)" of the "ik"th delimiter
+    ib = ie + LEN_TRIM( delimiter(jd) )                              !--- Length of the current delimiter
+    DO WHILE(r(ib:ib) == ' ' .AND. ib < nr); ib = ib + 1; END DO     !--- Skip spaces before next chain
+  END DO
+  keys(nk) = r(ib:nr)
+  IF(PRESENT(vals)) CALL parseKeys(keys(nk), vals(nk))               !--- Parse a <key>=<val> pair
+
+CONTAINS
+
+!------------------------------------------------------------------------------------------------------------------------------
+SUBROUTINE parseKeys(key, val)
+  IMPLICIT NONE
+  CHARACTER(LEN=*), INTENT(INOUT) :: key
+  CHARACTER(LEN=*), INTENT(OUT)   :: val
+!------------------------------------------------------------------------------------------------------------------------------
+  INTEGER :: ix
+  ix = INDEX(key, '='); IF(ix == 0) RETURN                           !--- First "=" index in "key"
+  val = ADJUSTL(key(ix+1:LEN_TRIM(key)))
+  key = ADJUSTL(key(1:ix-1))
+END SUBROUTINE parseKeys
+
+END FUNCTION strParse_m    
+!==============================================================================================================================
+
+
+!==============================================================================================================================
+!=== String substitution: replace "key" by "val" each time it appears in "str".
+!==============================================================================================================================
+SUBROUTINE strReplace_1(str, key, val, lsurr)
+  IMPLICIT NONE
+  CHARACTER(LEN=*),  INTENT(INOUT) :: str        !--- Main string
+  CHARACTER(LEN=*),  INTENT(IN)    :: key, val   !--- "key" will be replaced by "val"
+  LOGICAL, OPTIONAL, INTENT(IN)    :: lsurr      !--- TRUE => key must be surrounded by special characters to be substituted
+!------------------------------------------------------------------------------------------------------------------------------
+  INTEGER :: i0, ix, nk, ns
+  LOGICAL :: lsur, lb, le
+  lsur = .FALSE.; IF(PRESENT(lsurr)) lsur = lsurr
+  nk = LEN_TRIM(key)
+  i0 = 1
+  DO
+    ns = LEN_TRIM(str)
+    ix = INDEX(str(i0:ns), TRIM(key))            !--- First appearance index of "key" in "s", starting from index "i0"
+    IF(ix == 0) EXIT
+    ix = ix + i0 -1
+    IF(lsur) THEN                                !--- Key must be surrounded by special characters
+      !--- lb=.TRUE.: key is at the very beginning of "str" or located after  a special character
+      lb = ix     ==1;  IF(.NOT.lb) lb = INDEX('+-*/()^', str(ix-1 :ix-1 ))/=0
+      !--- le=.TRUE.: key is at the very end       of "str" or located before a special character
+      le = ix+nk-1==ns; IF(.NOT.le) le = INDEX('+-*/()^', str(ix+nk:ix+nk))/=0
+      IF(.NOT.(lb.AND.le)) THEN; i0 = i0 + nk; CYCLE; END IF
+    END IF
+    str = str(1:ix-1)//TRIM(val)//str(ix+nk:ns)
+  END DO
+END SUBROUTINE strReplace_1
+!==============================================================================================================================
+SUBROUTINE strReplace_m(str, key, val, lsurr)
+  IMPLICIT NONE
+  CHARACTER(LEN=*),  INTENT(INOUT) :: str(:)     !--- Main strings vector
+  CHARACTER(LEN=*),  INTENT(IN)    :: key, val   !--- "key" will be replaced by "val"
+  LOGICAL, OPTIONAL, INTENT(IN)    :: lsurr      !--- TRUE => key must be surrounded by special characters to be substituted
+  INTEGER :: k
+  LOGICAL :: ll
+  ll=.FALSE.; IF(PRESENT(lsurr)) ll=lsurr
+  DO k=1, SIZE(str); CALL strReplace_1(str(k),key,val,ll); END DO
+END SUBROUTINE strReplace_m
+!==============================================================================================================================
+
+
+!==============================================================================================================================
+!=== Contatenate horizontally scalars/vectors of strings/integers/reals into a vector/array ===================================
+!==============================================================================================================================
+FUNCTION horzcat_s00(s0, s1, s2, s3, s4, s5, s6, s7, s8, s9) RESULT(out)
+  IMPLICIT NONE
+  CHARACTER(LEN=*),                   INTENT(IN) :: s0
+  CHARACTER(LEN=*), OPTIONAL, TARGET, INTENT(IN) :: s1, s2, s3, s4, s5, s6, s7, s8, s9
+  CHARACTER(LEN=maxlen), ALLOCATABLE :: out(:)
+  CHARACTER(LEN=maxlen), POINTER     :: s
+  INTEGER                            :: nrow, iv
+  LOGICAL                            :: pre(9)
+!------------------------------------------------------------------------------------------------------------------------------
+  pre(:) = [PRESENT(s1),PRESENT(s2),PRESENT(s3),PRESENT(s4),PRESENT(s5),PRESENT(s6),PRESENT(s7),PRESENT(s8),PRESENT(s9)]
+  nrow = 1+COUNT(pre)
+  ALLOCATE(out(nrow))
+  out(1) = s0
+  DO iv = 2, nrow; IF(.NOT.pre(iv-1)) CYCLE
+    SELECT CASE(iv-1)
+      CASE(1); s=> s1; CASE(2); s=> s2; CASE(3); s=> s3; CASE(4); s=> s4; CASE(5); s=> s5
+      CASE(6); s=> s6; CASE(7); s=> s7; CASE(8); s=> s8; CASE(9); s=> s9
+    END SELECT
+    out(iv) = s
+  END DO
+END FUNCTION horzcat_s00
+!==============================================================================================================================
+FUNCTION horzcat_s10(s0, s1, s2, s3, s4, s5, s6, s7, s8, s9) RESULT(out)
+  IMPLICIT NONE
+  CHARACTER(LEN=*),           INTENT(IN) :: s0(:), s1
+  CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: s2, s3, s4, s5, s6, s7, s8, s9
+  CHARACTER(LEN=maxlen), ALLOCATABLE :: out(:), tmp(:)
+  INTEGER :: nc
+  nc = SIZE(s0)
+  tmp = horzcat_s00(s0(nc), s1, s2, s3, s4, s5, s6, s7, s8, s9)
+  IF(nc == 1) out = tmp
+  IF(nc /= 1) out = [s0(1:nc-1), tmp]
+END FUNCTION horzcat_s10
+!==============================================================================================================================
+FUNCTION horzcat_s11(s0, s1, s2, s3, s4, s5, s6, s7, s8, s9) RESULT(out)
+  IMPLICIT NONE
+  CHARACTER(LEN=*),                   INTENT(IN) :: s0(:)
+  CHARACTER(LEN=*), OPTIONAL, TARGET, INTENT(IN) :: s1(:), s2(:), s3(:), s4(:), s5(:), s6(:), s7(:), s8(:), s9(:)
+  CHARACTER(LEN=maxlen), ALLOCATABLE :: out(:,:)
+  CHARACTER(LEN=maxlen), POINTER     :: s(:)
+  INTEGER                            :: nrow, ncol, iv, n
+  LOGICAL                            :: pre(9)
+!------------------------------------------------------------------------------------------------------------------------------
+  pre(:) = [PRESENT(s1),PRESENT(s2),PRESENT(s3),PRESENT(s4),PRESENT(s5),PRESENT(s6),PRESENT(s7),PRESENT(s8),PRESENT(s9)]
+  nrow = SIZE(s0)
+  ncol = 1+COUNT(pre)
+  ALLOCATE(out(nrow, ncol))
+  out(:,1) = s0
+  DO iv = 2, ncol; IF(.NOT.pre(iv-1)) CYCLE
+    SELECT CASE(iv-1)
+      CASE(1); s=> s1; CASE(2); s=> s2; CASE(3); s=> s3; CASE(4); s=> s4; CASE(5); s=> s5
+      CASE(6); s=> s6; CASE(7); s=> s7; CASE(8); s=> s8; CASE(9); s=> s9
+    END SELECT
+    n = SIZE(s, DIM=1)
+    IF(n /= nrow) THEN; CALL msg("Can't concatenate vectors of differing lengths"); STOP; END IF
+    out(:,iv) = s(:)
+  END DO
+END FUNCTION horzcat_s11
+!==============================================================================================================================
+FUNCTION horzcat_s21(s0, s1, s2, s3, s4, s5, s6, s7, s8, s9) RESULT(out)
+  IMPLICIT NONE
+  CHARACTER(LEN=*),           INTENT(IN) :: s0(:,:), s1(:)
+  CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: s2(:), s3(:), s4(:), s5(:), s6(:), s7(:), s8(:), s9(:)
+  CHARACTER(LEN=maxlen), ALLOCATABLE :: out(:,:), tmp(:,:)
+  INTEGER :: nc
+  nc  = SIZE(s0, 2)
+  tmp = horzcat_s11(s0(:,nc), s1, s2, s3, s4, s5, s6, s7, s8, s9)
+  IF(nc == 1) out = tmp
+  IF(nc /= 1) out = RESHAPE([PACK(s0(:,1:nc-1), .TRUE.), PACK(tmp, .TRUE.)], SHAPE=[SIZE(s0, 1), nc + SIZE(tmp, 2)-1])
+END FUNCTION horzcat_s21
+!==============================================================================================================================
+FUNCTION horzcat_i00(i0, i1, i2, i3, i4, i5, i6, i7, i8, i9) RESULT(out)
+  IMPLICIT NONE
+  INTEGER,                   INTENT(IN) :: i0
+  INTEGER, OPTIONAL, TARGET, INTENT(IN) :: i1, i2, i3, i4, i5, i6, i7, i8, i9
+  INTEGER, ALLOCATABLE :: out(:)
+  INTEGER, POINTER     :: i
+  INTEGER              :: ncol, iv
+  LOGICAL              :: pre(9)
+!------------------------------------------------------------------------------------------------------------------------------
+  pre(:) = [PRESENT(i1),PRESENT(i2),PRESENT(i3),PRESENT(i4),PRESENT(i5),PRESENT(i6),PRESENT(i7),PRESENT(i8),PRESENT(i9)]
+  ncol = SIZE(pre)
+  ALLOCATE(out(ncol))
+  out(1) = i0
+  DO iv = 2, ncol; IF(.NOT.pre(iv-1)) CYCLE
+    SELECT CASE(iv-1)
+      CASE(1); i=> i1; CASE(2); i=> i2; CASE(3); i=> i3; CASE(4); i=> i4; CASE(5); i=> i5
+      CASE(6); i=> i6; CASE(7); i=> i7; CASE(8); i=> i8; CASE(9); i=> i9
+    END SELECT
+    out(iv) = i
+  END DO
+END FUNCTION horzcat_i00
+!==============================================================================================================================
+FUNCTION horzcat_i10(i0, i1, i2, i3, i4, i5, i6, i7, i8, i9) RESULT(out)
+  IMPLICIT NONE
+  INTEGER,           INTENT(IN) :: i0(:), i1
+  INTEGER, OPTIONAL, INTENT(IN) :: i2, i3, i4, i5, i6, i7, i8, i9
+  INTEGER, ALLOCATABLE :: out(:), tmp(:)
+  INTEGER :: nc
+  nc = SIZE(i0)
+  tmp = horzcat_i00(i0(nc), i1, i2, i3, i4, i5, i6, i7, i8, i9)
+  IF(nc == 1) out = tmp
+  IF(nc /= 1) out = [i0(1:nc-1), tmp]
+END FUNCTION horzcat_i10
+!==============================================================================================================================
+FUNCTION horzcat_i11(i0, i1, i2, i3, i4, i5, i6, i7, i8, i9) RESULT(out)
+  IMPLICIT NONE
+  INTEGER,                   INTENT(IN) :: i0(:)
+  INTEGER, OPTIONAL, TARGET, INTENT(IN) :: i1(:), i2(:), i3(:), i4(:), i5(:), i6(:), i7(:), i8(:), i9(:)
+  INTEGER, ALLOCATABLE :: out(:,:)
+  INTEGER, POINTER     :: i(:)
+  INTEGER              :: nrow, ncol, iv, n
+  LOGICAL              :: pre(9)
+!------------------------------------------------------------------------------------------------------------------------------
+  pre(:) = [PRESENT(i1),PRESENT(i2),PRESENT(i3),PRESENT(i4),PRESENT(i5),PRESENT(i6),PRESENT(i7),PRESENT(i8),PRESENT(i9)]
+  nrow = SIZE(i0)
+  ncol = 1+COUNT(pre)
+  ALLOCATE(out(nrow, ncol))
+  out(:,1) = i0
+  DO iv = 2, ncol; IF(.NOT.pre(iv-1)) CYCLE
+    SELECT CASE(iv-1)
+      CASE(1); i=> i1; CASE(2); i=> i2; CASE(3); i=> i3; CASE(4); i=> i4; CASE(5); i=> i5
+      CASE(6); i=> i6; CASE(7); i=> i7; CASE(8); i=> i8; CASE(9); i=> i9
+    END SELECT
+    n = SIZE(i, DIM=1)
+    IF(n /= nrow) THEN; CALL msg("Can't concatenate vectors of differing lengths"); STOP; END IF
+    out(:,iv) = i(:)
+  END DO
+END FUNCTION horzcat_i11
+!==============================================================================================================================
+FUNCTION horzcat_i21(i0, i1, i2, i3, i4, i5, i6, i7, i8, i9) RESULT(out)
+  IMPLICIT NONE
+  INTEGER,           INTENT(IN) :: i0(:,:), i1(:)
+  INTEGER, OPTIONAL, INTENT(IN) :: i2(:), i3(:), i4(:), i5(:), i6(:), i7(:), i8(:), i9(:)
+  INTEGER, ALLOCATABLE :: out(:,:), tmp(:,:)
+  INTEGER :: nc
+  nc  = SIZE(i0, 2)
+  tmp = horzcat_i11(i0(:,nc), i1, i2, i3, i4, i5, i6, i7, i8, i9)
+  IF(nc == 1) out = tmp
+  IF(nc /= 1) out = RESHAPE([PACK(i0(:,1:nc-1), .TRUE.), PACK(tmp, .TRUE.)], SHAPE=[SIZE(i0, 1), nc + SIZE(tmp, 2)-1])
+END FUNCTION horzcat_i21
+!==============================================================================================================================
+FUNCTION horzcat_r00(r0, r1, r2, r3, r4, r5, r6, r7, r8, r9) RESULT(out)
+  IMPLICIT NONE
+  REAL,                   INTENT(IN) :: r0
+  REAL, OPTIONAL, TARGET, INTENT(IN) :: r1, r2, r3, r4, r5, r6, r7, r8, r9
+  REAL, ALLOCATABLE :: out(:)
+  REAL, POINTER     :: r
+  INTEGER           :: ncol, iv
+  LOGICAL           :: pre(9)
+!------------------------------------------------------------------------------------------------------------------------------
+  pre(:) = [PRESENT(r1),PRESENT(r2),PRESENT(r3),PRESENT(r4),PRESENT(r5),PRESENT(r6),PRESENT(r7),PRESENT(r8),PRESENT(r9)]
+  ncol = 1+COUNT(pre)
+  ALLOCATE(out(ncol))
+  out(1) = r0
+  DO iv = 2, ncol; IF(.NOT.pre(iv-1)) CYCLE
+    SELECT CASE(iv-1)
+      CASE(1); r=> r1; CASE(2); r=> r2; CASE(3); r=> r3; CASE(4); r=> r4; CASE(5); r=> r5
+      CASE(6); r=> r6; CASE(7); r=> r7; CASE(8); r=> r8; CASE(9); r=> r9
+    END SELECT
+    out(iv) = r
+  END DO
+END FUNCTION horzcat_r00
+!==============================================================================================================================
+FUNCTION horzcat_r10(r0, r1, r2, r3, r4, r5, r6, r7, r8, r9) RESULT(out)
+  IMPLICIT NONE
+  REAL,           INTENT(IN) :: r0(:), r1
+  REAL, OPTIONAL, INTENT(IN) :: r2, r3, r4, r5, r6, r7, r8, r9
+  REAL, ALLOCATABLE :: out(:), tmp(:)
+  INTEGER :: nc
+  nc  = SIZE(r0)
+  tmp = horzcat_r00(r0(nc), r1, r2, r3, r4, r5, r6, r7, r8, r9)
+  IF(nc == 1) out = tmp
+  IF(nc /= 1) out = [r0(1:nc-1), tmp]
+END FUNCTION horzcat_r10
+!==============================================================================================================================
+FUNCTION horzcat_r11(r0, r1, r2, r3, r4, r5, r6, r7, r8, r9) RESULT(out)
+  IMPLICIT NONE
+  REAL,                   INTENT(IN) :: r0(:)
+  REAL, OPTIONAL, TARGET, INTENT(IN) :: r1(:), r2(:), r3(:), r4(:), r5(:), r6(:), r7(:), r8(:), r9(:)
+  REAL, ALLOCATABLE :: out(:,:)
+  REAL, POINTER     :: r(:)
+  INTEGER           :: nrow, ncol, iv, n
+  LOGICAL           :: pre(9)
+!------------------------------------------------------------------------------------------------------------------------------
+  pre(:) = [PRESENT(r1),PRESENT(r2),PRESENT(r3),PRESENT(r4),PRESENT(r5),PRESENT(r6),PRESENT(r7),PRESENT(r8),PRESENT(r9)]
+  nrow = SIZE(r0)
+  ncol = 1+COUNT(pre)
+  ALLOCATE(out(nrow, ncol))
+  out(:,1) = r0
+  DO iv = 2, ncol; IF(.NOT.pre(iv-1)) CYCLE
+    SELECT CASE(iv-1)
+      CASE(1); r=> r1; CASE(2); r=> r2; CASE(3); r=> r3; CASE(4); r=> r4; CASE(5); r=> r5
+      CASE(6); r=> r5; CASE(7); r=> r7; CASE(8); r=> r8; CASE(9); r=> r9
+    END SELECT
+    n = SIZE(r, DIM=1)
+    IF(n /= nrow) THEN; CALL msg("Can't concatenate vectors of differing lengths"); STOP; END IF
+    out(:,iv) = r(:)
+  END DO
+END FUNCTION horzcat_r11
+!==============================================================================================================================
+FUNCTION horzcat_r21(r0, r1, r2, r3, r4, r5, r6, r7, r8, r9) RESULT(out)
+  IMPLICIT NONE
+  REAL,           INTENT(IN) :: r0(:,:), r1(:)
+  REAL, OPTIONAL, INTENT(IN) :: r2(:), r3(:), r4(:), r5(:), r6(:), r7(:), r8(:), r9(:)
+  REAL, ALLOCATABLE :: out(:,:), tmp(:,:)
+  INTEGER :: nc
+  nc  = SIZE(r0, 2)
+  tmp = horzcat_r11(r0(:,nc), r1, r2, r3, r4, r5, r6, r7, r8, r9)
+  IF(nc == 1) out = tmp
+  IF(nc /= 1) out = RESHAPE([PACK(r0(:,1:nc-1), .TRUE.), PACK(tmp, .TRUE.)], SHAPE=[SIZE(r0, 1), nc + SIZE(tmp, 2)-1])
+END FUNCTION horzcat_r21
+!==============================================================================================================================
+FUNCTION horzcat_d00(d0, d1, d2, d3, d4, d5, d6, d7, d8, d9) RESULT(out)
+  IMPLICIT NONE
+  DOUBLE PRECISION,                   INTENT(IN) :: d0
+  DOUBLE PRECISION, OPTIONAL, TARGET, INTENT(IN) :: d1, d2, d3, d4, d5, d6, d7, d8, d9
+  DOUBLE PRECISION, ALLOCATABLE :: out(:)
+  DOUBLE PRECISION, POINTER     :: d
+  INTEGER                       :: ncol, iv
+  LOGICAL                       :: pre(9)
+!------------------------------------------------------------------------------------------------------------------------------
+  pre(:) = [PRESENT(d1),PRESENT(d2),PRESENT(d3),PRESENT(d4),PRESENT(d5),PRESENT(d6),PRESENT(d7),PRESENT(d8),PRESENT(d9)]
+  ncol = 1+COUNT(pre)
+  ALLOCATE(out(ncol))
+  out(1) = d0
+  DO iv = 2, ncol; IF(.NOT.pre(iv-1)) CYCLE
+    SELECT CASE(iv-1)
+      CASE(1); d=> d1; CASE(2); d=> d2; CASE(3); d=> d3; CASE(4); d=> d4; CASE(5); d=> d5
+      CASE(6); d=> d6; CASE(7); d=> d7; CASE(8); d=> d8; CASE(9); d=> d9
+    END SELECT
+    out(iv) = d
+  END DO
+END FUNCTION horzcat_d00
+!==============================================================================================================================
+FUNCTION horzcat_d10(d0, d1, d2, d3, d4, d5, d6, d7, d8, d9) RESULT(out)
+  IMPLICIT NONE
+  DOUBLE PRECISION,           INTENT(IN) :: d0(:), d1
+  DOUBLE PRECISION, OPTIONAL, INTENT(IN) :: d2, d3, d4, d5, d6, d7, d8, d9
+  DOUBLE PRECISION, ALLOCATABLE :: out(:), tmp(:)
+  INTEGER :: nc
+  nc = SIZE(d0)
+  tmp = horzcat_d00(d0(nc), d1, d2, d3, d4, d5, d6, d7, d8, d9)
+  IF(nc == 1) out = tmp
+  IF(nc /= 1) out = [d0(1:nc-1), tmp]
+END FUNCTION horzcat_d10
+!==============================================================================================================================
+FUNCTION horzcat_d11(d0, d1, d2, d3, d4, d5, d6, d7, d8, d9) RESULT(out)
+  IMPLICIT NONE
+  DOUBLE PRECISION,                   INTENT(IN) :: d0(:)
+  DOUBLE PRECISION, OPTIONAL, TARGET, INTENT(IN) :: d1(:), d2(:), d3(:), d4(:), d5(:), d6(:), d7(:), d8(:), d9(:)
+  DOUBLE PRECISION, ALLOCATABLE :: out(:,:)
+  DOUBLE PRECISION, POINTER     :: d(:)
+  INTEGER                       :: nrow, ncol, iv, n
+  LOGICAL                       :: pre(9)
+!------------------------------------------------------------------------------------------------------------------------------
+  nrow = SIZE(d0)
+  pre(:) = [PRESENT(d1),PRESENT(d2),PRESENT(d3),PRESENT(d4),PRESENT(d5),PRESENT(d6),PRESENT(d7),PRESENT(d8),PRESENT(d9)]
+  ncol = 1+COUNT(pre)
+  ALLOCATE(out(nrow, ncol))
+  DO iv = 2, ncol; IF(.NOT.pre(iv-1)) CYCLE
+    SELECT CASE(iv-1)
+      CASE(1); d=> d1; CASE(2); d=> d2; CASE(3); d=> d3; CASE(4); d=> d4; CASE(5); d=> d5
+      CASE(6); d=> d6; CASE(7); d=> d7; CASE(8); d=> d8; CASE(9); d=> d9
+    END SELECT
+    n = SIZE(d, DIM=1)
+    IF(n /= nrow) THEN; CALL msg("Can't concatenate vectors of differing lengths"); STOP; END IF
+    out(:,iv) = d(:)
+  END DO
+END FUNCTION horzcat_d11
+!==============================================================================================================================
+FUNCTION horzcat_d21(d0, d1, d2, d3, d4, d5, d6, d7, d8, d9) RESULT(out)
+  IMPLICIT NONE
+  DOUBLE PRECISION,           INTENT(IN) :: d0(:,:), d1(:)
+  DOUBLE PRECISION, OPTIONAL, INTENT(IN) :: d2(:), d3(:), d4(:), d5(:), d6(:), d7(:), d8(:), d9(:)
+  DOUBLE PRECISION, ALLOCATABLE :: out(:,:), tmp(:,:)
+  INTEGER :: nc
+  nc  = SIZE(d0, 2)
+  tmp = horzcat_d11(d0(:,nc), d1, d2, d3, d4, d5, d6, d7, d8, d9)
+  IF(nc == 1) out = tmp
+  IF(nc /= 1) out = RESHAPE([PACK(d0(:,1:nc-1), .TRUE.), PACK(tmp, .TRUE.)], SHAPE=[SIZE(d0, 1), nc + SIZE(tmp, 2)-1])
+END FUNCTION horzcat_d21
+!==============================================================================================================================
+
+
+!==============================================================================================================================
+!--- Display a clean table composed of successive vectors of same length.
+!=== The profile "p" describe in which order to pick up the columns from "s", "i" and "r" for display.
+!===  * nRowMax lines are displayed (default: all lines)
+!===  * nColMax characters (default: as long as needed) are displayed at most on a line. If the effective total length is
+!===    higher, several partial tables are displayed ; the nHead (default: 1) first columns are included in each sub-table.
+!==============================================================================================================================
+LOGICAL FUNCTION dispTable(p, titles, s, i, r, rFmt, nRowMax, nColMax, nHead, unit, sub) RESULT(lerr)
+  IMPLICIT NONE
+  CHARACTER(LEN=*),           INTENT(IN)  :: p             !--- DISPLAY MAP: s/i/r
+  CHARACTER(LEN=*),           INTENT(IN)  :: titles(:)     !--- TITLES (ONE EACH COLUMN)
+  CHARACTER(LEN=*), OPTIONAL, INTENT(IN)  :: s(:,:)        !--- STRINGS
+  INTEGER,          OPTIONAL, INTENT(IN)  :: i(:,:)        !--- INTEGERS
+  REAL,             OPTIONAL, INTENT(IN)  :: r(:,:)        !--- REALS
+  CHARACTER(LEN=*), OPTIONAL, INTENT(IN)  :: rFmt          !--- Format for reals
+  INTEGER,          OPTIONAL, INTENT(IN)  :: nRowMax       !--- Display at most "nRowMax" rows
+  INTEGER,          OPTIONAL, INTENT(IN)  :: nColMax       !--- Display at most "nColMax" characters each line
+  INTEGER,          OPTIONAL, INTENT(IN)  :: nHead         !--- Head columns repeated for multiple tables display
+  INTEGER,          OPTIONAL, INTENT(IN)  :: unit          !--- Output unit (default: screen)
+  CHARACTER(LEN=*), OPTIONAL, INTENT(IN)  :: sub           !--- Subroutine name
+!------------------------------------------------------------------------------------------------------------------------------
+  CHARACTER(LEN=2048) :: row
+  CHARACTER(LEN=maxlen)  :: rFm, el, subn
+  CHARACTER(LEN=maxlen), ALLOCATABLE :: d(:,:)
+  CHARACTER(LEN=1) :: s1, sp
+  INTEGER :: is, ii, ir, it, k, nmx,  unt, ic, np
+  INTEGER :: ns, ni, nr, nt, l, ncol, nHd, ib, l0
+  INTEGER, ALLOCATABLE :: n(:), ncmx(:)
+  INTEGER, PARAMETER   :: nm=1                             !--- Space between values & columns
+  LOGICAL :: ls, li, lr
+  subn = '';    IF(PRESENT(sub)) subn = sub
+  rFm = '*';    IF(PRESENT(rFmt)) rFm = rFmt               !--- Specified format for reals
+  unt = lunout; IF(PRESENT(unit)) unt = unit               !--- Specified output unit
+  np = LEN_TRIM(p); ns = 0; ni = 0; nr = 0; ncol = 0
+  ls = PRESENT(s); li = PRESENT(i); lr = PRESENT(r)
+  lerr = .FALSE.; IF(.NOT.ANY([ls,li,lr])) RETURN          !--- Nothing to do
+  sp = '|'                                                 !--- Separator
+
+  !--- CHECK ARGUMENTS COHERENCE
+  lerr = np /= SIZE(titles); IF(fmsg('display map "p" length and titles list mismatch', subn, lerr)) RETURN
+  IF(ls) THEN
+    ns = SIZE(s, 1); ncol = ncol + SIZE(s, 2); lerr = COUNT([(p(ic:ic)=='s', ic=1, np)]) /= SIZE(s, 2)
+  END IF
+  IF(li) THEN
+    ni = SIZE(i, 1); ncol = ncol + SIZE(i, 2); lerr = COUNT([(p(ic:ic)=='i', ic=1, np)]) /= SIZE(i, 2)
+  END IF
+  IF(lr) THEN
+    nr = SIZE(r, 1); ncol = ncol + SIZE(r, 2); lerr = COUNT([(p(ic:ic)=='r', ic=1, np)]) /= SIZE(r, 2)
+  END IF
+  IF(fmsg('display map "p" length and arguments number mismatch', subn, lerr)) RETURN
+  lerr = ncol /= SIZE(titles); IF(fmsg('"titles" length and arguments number mismatch', subn, lerr)) RETURN
+  lerr = ls.AND.li.AND.ns/=ni; IF(fmsg('string and integer arguments lengths mismatch', subn, lerr)) RETURN
+  lerr = ls.AND.lr.AND.ns/=nr; IF(fmsg(   'string and real arguments lengths mismatch', subn, lerr)) RETURN
+  lerr = li.AND.lr.AND.ni/=nr; IF(fmsg(  'integer and real arguments lengths mismatch', subn, lerr)) RETURN
+  nmx = MAX(ns,ni,nr)+1; IF(PRESENT(nRowMax)) nmx = MIN(nmx,nRowMax+1)
+
+  !--- Allocate the assembled quantities array
+  ALLOCATE(d(nmx,ncol), n(ncol))
+
+  !--- Assemble the vectors into a strings array in the order indicated by "pattern"
+  is =  1; ii = 1; ir = 1
+  DO ic = 1, ncol
+    d(1,ic) = TRIM(titles(ic))
+    SELECT CASE(p(ic:ic))
+      CASE('s'); d(2:nmx,ic) =          s(:,is)     ; is = is + 1
+      CASE('i'); d(2:nmx,ic) =  int2str(i(:,ii)    ); ii = ii + 1
+      CASE('r'); d(2:nmx,ic) = real2str(r(:,ir),rFm); ir = ir + 1
+    END SELECT
+  END DO
+  CALL cleanZeros(d)
+  DO ic = 1, ncol
+    n(ic)=0; DO ir=1, nmx; n(ic)=MAX(n(ic), LEN_TRIM(d(ir,ic))); END DO
+  END DO
+  n(:) = n(:) + 2*nm
+
+  !--- Build the vector of max column index in case the rows are too long (table must be displayed in multiple parts)
+  nHd = 1; IF(PRESENT(nHead)) nHd = nHead
+  IF(.NOT.PRESENT(nColMax)) THEN
+    nt = 1; ncmx = [ncol]
+  ELSE
+    nt = 1; l0 = SUM(n(1:nHd)+1)+1
+    IF(PRESENT(sub)) l0=l0+LEN_TRIM(subn)+1
+    !--- Count the number of table parts
+    l = l0; DO ic = nHd+1, ncol; l = l+n(ic)+1; IF(l>=nColMax) THEN; nt = nt+1; l = l0+n(ic)+1; END IF; END DO
+    !--- Get the index of the last column for each table part
+    ALLOCATE(ncmx(nt)); k = 1
+    l = l0; DO ic = nHd+1, ncol; l = l+n(ic)+1; IF(l>=nColMax) THEN; ncmx(k) = ic-1; l = l0+n(ic)+1; k = k+1; END IF; END DO
+    ncmx(nt) = ncol
+  END IF
+      
+  !--- Display the strings array as a table
+  DO it = 1, nt
+    DO ir = 1, nmx; row = ''
+      DO ic = 1, nHd; el = d(ir,ic)
+        s1 = sp
+        row = TRIM(row)//REPEAT(' ',nm)//TRIM(el)//REPEAT(' ',n(ic)-LEN_TRIM(el)-nm)//s1
+      END DO
+      ib = nHd+1; IF(it>1) ib = ncmx(it-1)+1
+      DO ic = ib, ncmx(it); el = d(ir,ic)
+        s1 = sp
+        row = TRIM(row)//REPEAT(' ',nm)//TRIM(el)//REPEAT(' ',n(ic)-LEN_TRIM(el)-nm)//s1
+      END DO
+      nr = LEN_TRIM(row)-1                                           !--- Final separator removed
+      CALL msg(row(1:nr), subn, unit=unt)
+      IF(ir /= 1) CYCLE                                              !--- Titles only are underlined
+      row=''; DO ic=1,nHd; row=TRIM(row)//REPEAT('-',n(ic))//'+'; END DO
+      DO ic = ib,ncmx(it); row=TRIM(row)//REPEAT('-',n(ic))//'+'; END DO
+      CALL msg(row(1:LEN_TRIM(row)-1), subn, unit=unt)
+    END DO
+    CALL msg('', subn, unit=unt)
+  END DO
+
+END FUNCTION dispTable
+!==============================================================================================================================
+
+!==============================================================================================================================
+LOGICAL FUNCTION dispNamelist(unt, p, titles, s, i, r, rFmt, llast) RESULT(lerr)
+  IMPLICIT NONE
+  INTEGER,                    INTENT(IN)  :: unt           !--- Output unit
+  CHARACTER(LEN=*),           INTENT(IN)  :: p             !--- DISPLAY MAP: s/i/r
+  CHARACTER(LEN=*),           INTENT(IN)  :: titles(:)     !--- TITLES (ONE EACH COLUMN)
+  CHARACTER(LEN=*), OPTIONAL, INTENT(IN)  :: s(:,:)        !--- STRINGS
+  INTEGER,          OPTIONAL, INTENT(IN)  :: i(:,:)        !--- INTEGERS
+  REAL,             OPTIONAL, INTENT(IN)  :: r(:,:)        !--- REALS
+  CHARACTER(LEN=*), OPTIONAL, INTENT(IN)  :: rFmt          !--- Format for reals
+  LOGICAL,          OPTIONAL, INTENT(IN)  :: llast         !--- Last variable: no final ','
+!------------------------------------------------------------------------------------------------------------------------------
+  CHARACTER(LEN=maxlen)  :: rFm, el
+  CHARACTER(LEN=maxlen), ALLOCATABLE :: d(:,:)
+  CHARACTER(LEN=:),      ALLOCATABLE :: sp, row
+  INTEGER :: is, ii, ir, nrow, ic
+  INTEGER :: ns, ni, nr, ncol, np
+  INTEGER, ALLOCATABLE :: n(:)
+  LOGICAL :: ls, li, lr, la
+  rFm = '*';    IF(PRESENT(rFmt)) rFm = rFmt               !--- Specified format for reals
+  ls = PRESENT(s); li = PRESENT(i); lr = PRESENT(r)
+  lerr = .FALSE.; IF(.NOT.ANY([ls,li,lr])) RETURN          !--- Nothing to do
+  la = .FALSE.; IF(PRESENT(llast)) la = llast
+
+  !--- CHECK ARGUMENTS COHERENCE
+  ns = 0; ni = 0; nr = 0; np = LEN_TRIM(p); ncol = 0
+  IF(ls) THEN; ns = SIZE(s, DIM=1); ncol = ncol + SIZE(s, DIM=2)
+    lerr = COUNT([(p(ic:ic)=='s', ic=1, np)]) /= SIZE(s, DIM=2)
+  END IF
+  IF(li) THEN; ni = SIZE(i, DIM=1); ncol = ncol + SIZE(i, DIM=2)
+    lerr = COUNT([(p(ic:ic)=='i', ic=1, np)]) /= SIZE(i, DIM=2)
+  END IF
+  IF(lr) THEN; nr = SIZE(r, DIM=1); ncol = ncol + SIZE(r, DIM=2)
+    lerr = COUNT([(p(ic:ic)=='r', ic=1, np)]) /= SIZE(r, DIM=2)
+  END IF
+  IF(fmsg('display map "p" length and arguments number mismatch', ll=lerr)) RETURN
+  lerr = ncol /= SIZE(titles); IF(fmsg('"titles" length and arguments number mismatch', ll=lerr)) RETURN
+  lerr = ls.AND.li.AND.ns/=ni; IF(fmsg('string and integer arguments lengths mismatch', ll=lerr)) RETURN
+  lerr = ls.AND.lr.AND.ns/=nr; IF(fmsg(   'string and real arguments lengths mismatch', ll=lerr)) RETURN
+  lerr = li.AND.lr.AND.ni/=nr; IF(fmsg(  'integer and real arguments lengths mismatch', ll=lerr)) RETURN
+
+  !--- Allocate the assembled quantities array
+  nrow = MAX(ns,ni,nr)+1
+  ALLOCATE(d(nrow,ncol), n(ncol))
+
+  !--- Assemble the vectors into a strings array in the order indicated by "pattern"
+  is =  1; ii = 1; ir = 1
+  DO ic = 1, ncol
+    d(1,ic) = TRIM(titles(ic))
+    SELECT CASE(p(ic:ic))
+      CASE('s'); d(2:nrow,ic) =          s(:,is)     ; is = is + 1
+      CASE('i'); d(2:nrow,ic) =  int2str(i(:,ii)    ); ii = ii + 1
+      CASE('r'); d(2:nrow,ic) = real2str(r(:,ir),rFm); ir = ir + 1
+    END SELECT
+  END DO
+  CALL cleanZeros(d)
+  DO ic = 1, ncol
+    n(ic) = 0; DO ir=1, nrow; n(ic)=MAX(n(ic), LEN_TRIM(d(ir,ic))); END DO
+    IF(needQuotes(d(2,ic)) .AND. ic/=1) n(ic) = n(ic) + 2 !--- For quotes, using second line only
+  END DO
+
+  !--- Display the strings array as a table
+  DO ir = 1, nrow
+    row = ''; sp = '   '; IF(TRIM(d(ir,1)) /= '') sp = ' = '
+    DO ic = 1, ncol
+      el = d(ir,ic); IF(ic /= 1) el = addQuotes_1(el)
+      row = row//TRIM(el)//REPEAT(' ',n(ic)-LEN_TRIM(el))//sp
+      sp = '   '; IF(ic /= ncol-1) CYCLE
+      IF(TRIM(d(MIN(ir+1,nrow),1)) /= '' .AND. (ir /= nrow .OR. .NOT.la)) sp = ' , '
+    END DO
+    WRITE(unt,'(a)')TRIM(row)
+  END DO
+
+  !--- End of section
+  IF(la) THEN
+    WRITE(unt,'(a)')'/'
+    WRITE(unt,'(a)')
+  END IF
+
+END FUNCTION dispNameList
+!==============================================================================================================================
+
+
+!==============================================================================================================================
+LOGICAL FUNCTION dispOutliers_1(ll, a, n, err_msg, nam, subn, nRowmax, nColMax, nHead, unit) RESULT(lerr)
+  IMPLICIT NONE
+! Display outliers list in tables
+! If "nam" is supplied, it means the last index is for tracers => one table each tracer for rank > 2.
+  LOGICAL,                    INTENT(IN)  :: ll(:)                   !--- Linearized mask of outliers
+  REAL,                       INTENT(IN)  ::  a(:)                   !--- Linearized array of values
+  INTEGER,                    INTENT(IN)  ::  n(:)                   !--- Profile before linearization
+  CHARACTER(LEN=*), OPTIONAL, INTENT(IN)  :: err_msg, nam(:), subn   !--- Error message, variables and calling subroutine names
+  INTEGER,          OPTIONAL, INTENT(IN)  :: nRowMax                 !--- Maximum number of lines to display    (default: all)
+  INTEGER,          OPTIONAL, INTENT(IN)  :: nColMax                 !--- Maximum number of characters per line (default: 2048)
+  INTEGER,          OPTIONAL, INTENT(IN)  :: nHead                   !--- Number of front columns to duplicate  (default: 1)
+  INTEGER,          OPTIONAL, INTENT(IN)  :: unit                    !--- Output unit                           (def: lunout)
+!------------------------------------------------------------------------------------------------------------------------------
+  CHARACTER(LEN=maxlen),      ALLOCATABLE :: ttl(:)
+  LOGICAL,                    ALLOCATABLE :: m(:)
+  INTEGER,                    ALLOCATABLE :: ki(:), kj(:)
+  INTEGER                                 :: i, j, k, rk, rk1, ib, ie, itr, nm, unt, nRmx, nCmx, nHd, nv
+  CHARACTER(LEN=maxlen)                   :: mes, sub, fm='(f12.9)', v, s
+  CHARACTER(LEN=maxlen),      ALLOCATABLE :: vnm(:)
+
+  lerr = ANY(ll); IF(.NOT.lerr) RETURN                               !--- No outliers -> finished
+
+  mes = 'outliers found'; IF(PRESENT(err_msg)) mes = err_msg         !--- Error message
+  vnm = ['a'];            IF(PRESENT(nam ))    vnm = nam             !--- Variables names
+  sub = 'dispOutliers';   IF(PRESENT(subn))    sub = subn            !--- Calling subroutine name
+  nRmx= SIZE(a);          IF(PRESENT(nRowMax)) nRmx=MIN(nRmx,nRowMax)!-- Maximum number of lines to print
+  nCmx= 2048;             IF(PRESENT(nColMax)) nCmx=MIN(nCmx,nColMax)!-- Maximum number of characters each line
+  nHd = 1;                IF(PRESENT(nHead))   nHd = nHead           !--- Number of front columns to duplicate
+  unt = lunout;           IF(PRESENT(unit))    unt = unit            !--- Unit to print messages
+
+  rk = SIZE(n); nv = SIZE(vnm)
+  lerr = nv/=1 .AND. nv/=n(rk); CALL msg('SIZE(nam) /= 1 and /= last "n" element', sub, lerr); IF(lerr) RETURN
+  lerr = SIZE(a) /=   SIZE(ll); CALL msg('ll" and "a" sizes mismatch',             sub, lerr); IF(lerr) RETURN
+  lerr = SIZE(a) /= PRODUCT(n); CALL msg('profile "n" does not match "a" and "ll', sub, lerr); IF(lerr) RETURN
+  CALL msg(mes, sub, unit=unt)
+
+  !--- SCALAR CASE: single value to display
+  IF(rk==1.AND.n(1)==1) THEN
+    IF(ll(1)) WRITE(unt,'(a," = ",f12.9)')TRIM(nam(1)),a(1); RETURN
+  END IF
+
+  rk1 = rk; IF(nv==1) rk1 = rk-1                                    !--- Rank of each displayed table
+  SELECT CASE(rk1)                                                  !--- Indices list
+    CASE(1,2); ki = [ (i,i=1,n(1)) ]
+    CASE(3);   ki = [((i,i=1,n(1)),j=1,n(2))]; kj = [((j,i=1,n(1)),j=1,n(2))]
+    CASE DEFAULT; WRITE(unt,*)'Sorry: routine "dispOutliers" is limited to rank 3'; RETURN
+  END SELECT
+
+  !--- VECTOR CASE:  table " name | value " (known names)  /  )  /  " i | a(i) " (unknown names)
+  IF(rk==1) THEN
+    ALLOCATE(ttl(2)); ttl(2) = TRIM(vnm(1))//'(i)'; ttl(1) = 'i'
+    IF(nv == 1) lerr = dispTable('sr', ttl,               s=cat(PACK(nam,ll)), r=cat(PACK(a,ll)), &
+                                 rFmt=fm, nRowMax=nRmx, nColMax=nCmx, nHead=nHd, unit=unt, sub=sub)
+    IF(nv /= 1) lerr = dispTable('ir', ['name ','value'], i=cat(PACK(ki,m)),   r=cat(PACK(a,ll)), &
+                                 rFmt=fm, nRowMax=nRmx, nColMax=nCmx, nHead=nHd, unit=unt, sub=sub)
+    CALL msg("can't display outliers table", sub, lerr, unt)
+    RETURN
+  END IF
+
+  !--- OTHER CASES: one table for each tracer (last index)
+  ttl = [(ACHAR(k), k = 105, 104+rk)]                                !--- Titles list ('i', 'j', 'k'...)
+  s = strStack( ttl(1:rk-1) )                                        !--- Tracer name dummy indexes: (i, j, k, ...
+
+  DO itr=1,n(rk)
+    nm = PRODUCT(n(1:rk-1))                                          !--- number of elements per tracer
+    ie = itr*nm; ib = ie-nm+1; m=ll(ib:ie)                           !--- section bounds for tracer "itr" ; outlayers mask
+    IF(.NOT.ANY(m)) CYCLE                                            !--- no outlayers for tracer "itr"
+    v = TRIM(vnm(MIN(itr,SIZE(vnm))))//'('//TRIM(s)                  !--- "<name>("
+    IF(nv == 1) ttl(rk) = TRIM(v)//','//int2str(itr)//')'            !--- "<name>(i,j,itr)" (single name)
+    IF(nv /= 1) ttl(rk) = TRIM(v)//')'                               !--- "<nam(itr)>(i,j)" (one name each table/itr index)
+    IF(rk==2) lerr = dispTable('ir',  ttl, i=cat(PACK(ki,m)),            r=cat(PACK(a(ib:ie),m)), &
+                                 rFmt=fm, nRowMax=nRmx, nColMax=nCmx, nHead=nHd, unit=unt, sub=sub)
+    IF(rk==3) lerr = dispTable('iir', ttl, i=cat(PACK(ki,m),PACK(kj,m)), r=cat(PACK(a(ib:ie),m)), &
+                                 rFmt=fm, nRowMax=nRmx, nColMax=nCmx, nHead=nHd, unit=unt, sub=sub)
+    CALL msg("can't display outliers table", sub, lerr, unt)
+    IF(lerr) RETURN
+  END DO
+END FUNCTION dispOutliers_1
+!==============================================================================================================================
+LOGICAL FUNCTION dispOutliers_2(ll, a, n, err_msg, nam, subn, nRowMax, nColMax, nHead, unit) RESULT(lerr)
+  IMPLICIT NONE
+! Display outliers list in tables
+! If "nam" is supplied and, it means the last index is for tracers => one table each tracer for rank > 2.
+  LOGICAL,                    INTENT(IN)  :: ll(:)                   !--- Linearized mask of outliers
+  REAL,                       INTENT(IN)  ::  a(:,:)                 !--- Linearized arrays of values stacked along 2nd dim.
+  INTEGER,                    INTENT(IN)  ::  n(:)                   !--- Profile before linearization
+  CHARACTER(LEN=*), OPTIONAL, INTENT(IN)  :: err_msg, nam(:), subn   !--- Error message, variables and calling subroutine names
+  INTEGER,          OPTIONAL, INTENT(IN)  :: nRowMax                 !--- Maximum number of lines to display    (default: all)
+  INTEGER,          OPTIONAL, INTENT(IN)  :: nColMax                 !--- Maximum number of characters per line (default: 2048)
+  INTEGER,          OPTIONAL, INTENT(IN)  :: nHead                   !--- Number of front columns to duplicate  (default: 1)
+  INTEGER,          OPTIONAL, INTENT(IN)  :: unit                    !--- Output unit                           (def: lunout)
+!------------------------------------------------------------------------------------------------------------------------------
+  CHARACTER(LEN=maxlen)                   :: mes, sub, fm='(f12.9)', prf
+  CHARACTER(LEN=maxlen),      ALLOCATABLE :: ttl(:), vnm(:)
+  INTEGER,                    ALLOCATABLE :: ki(:), kj(:), kl(:)
+  INTEGER                                 :: i, j, k, rk, nv, unt, nRmx, nCmx, nHd
+  REAL,                       ALLOCATABLE :: val(:,:)
+
+  lerr = ANY(ll); IF(.NOT.lerr) RETURN                               !--- No outliers -> finished
+  rk = SIZE(n); nv = SIZE(a,2)
+  mes = 'outliers found';        IF(PRESENT(err_msg)) mes = err_msg  !--- Error message
+  vnm = [(ACHAR(k+96),k=1,nv)];  IF(PRESENT(nam ))    vnm = nam      !--- Variables names
+  sub = 'dispOutliers';          IF(PRESENT(subn))    sub = subn     !--- Calling subroutine name
+  nRmx= SIZE(a);          IF(PRESENT(nRowMax)) nRmx=MIN(nRmx,nRowMax)!-- Maximum number of lines to print
+  nCmx= 2048;             IF(PRESENT(nColMax)) nCmx=MIN(nCmx,nColMax)!-- Maximum number of characters each line
+  nHd = 1;                IF(PRESENT(nHead))   nHd = nHead           !--- Number of front columns to duplicate
+  unt = lunout;                  IF(PRESENT(unit))    unt = unit     !--- Unit to print messages
+  lerr= SIZE(vnm) /= nv;         IF(fmsg('SIZE(nam) /= SIZE(a,2)',                  sub, lerr, unt)) RETURN
+  lerr= SIZE(a,1) /= SIZE(ll);   IF(fmsg('"ll" and "a" sizes mismatch',             sub, lerr, unt)) RETURN
+  lerr= SIZE(a,1) /= PRODUCT(n); IF(fmsg('profile "n" does not match "a" and "ll"', sub, lerr, unt)) RETURN
+
+  SELECT CASE(rk)                                                   !--- Indices list
+    CASE(0); IF(ll(1)) THEN; WRITE(unt,'(a,", ",a," = ",2f12.9)')TRIM(vnm(1)),TRIM(vnm(2)),a(1,1),a(1,2); RETURN; END IF
+    CASE(1); ki = [  (i,i=1,n(1)) ]
+    CASE(2); ki = [ ((i,i=1,n(1)),j=1,n(2))];           kj = [ ((j,i=1,n(1)),j=1,n(2))]
+    CASE(3); ki = [(((i,i=1,n(1)),j=1,n(2)),k=1,n(3))]; kj = [(((j,i=1,n(1)),j=1,n(2)),k=1,n(3))]
+             kl = [(((k,i=1,n(1)),j=1,n(2)),k=1,n(3))]
+    CASE DEFAULT; WRITE(unt,*)'Sorry: routine "dispOutliers_2" is limited to rank 3'; RETURN
+  END SELECT
+
+  ttl = [(ACHAR(k), k = 105, 104+rk), vnm]                           !--- Titles list ('i', 'j', 'k'...'var1', 'var2', ...)
+  prf = REPEAT('i',rk)//REPEAT('r',nv)                               !--- Profile
+  ALLOCATE(val(COUNT(ll),nv)); DO k=1, nv; val(:,k) = PACK(a(:,k),ll); END DO
+  IF(rk == 1) lerr = dispTable(prf, ttl, i = cat(PACK(ki,ll)),                         r = val, &
+                                 rFmt=fm, nRowMax=nRmx, nColMax=nCmx, nHead=nHd, unit=unt, sub=sub)
+  IF(rk == 2) lerr = dispTable(prf, ttl, i = cat(PACK(ki,ll),PACK(kj,ll)),             r = val, &
+                                 rFmt=fm, nRowMax=nRmx, nColMax=nCmx, nHead=nHd, unit=unt, sub=sub)
+  IF(rk == 3) lerr = dispTable(prf, ttl, i = cat(PACK(ki,ll),PACK(kj,ll),PACK(kl,ll)), r = val, &
+                                 rFmt=fm, nRowMax=nRmx, nColMax=nCmx, nHead=nHd, unit=unt, sub=sub)
+  CALL msg("can't display outliers table", sub, lerr, unt)
+END FUNCTION dispOutliers_2
+!==============================================================================================================================
+
+
+!==============================================================================================================================
+!=== Reduce an algebrical expression (basic operations and parenthesis) to a single number (string format) ====================
+!==============================================================================================================================
+LOGICAL FUNCTION reduceExpr_1(str, val) RESULT(lerr)
+  IMPLICIT NONE
+  CHARACTER(LEN=*),      INTENT(IN)  :: str
+  CHARACTER(LEN=maxlen), INTENT(OUT) :: val
+!------------------------------------------------------------------------------------------------------------------------------
+  CHARACTER(LEN=maxlen)              :: v
+  CHARACTER(LEN=1024)                :: s, vv
+  CHARACTER(LEN=1024), ALLOCATABLE :: vl(:)
+  INTEGER,             ALLOCATABLE :: ip(:)
+  INTEGER :: nl, nn, i, j, im, ix
+  LOGICAL :: ll
+  s = str
+
+  !--- Check wether the parenthesis are correctly formed
+  ll = strCount(s,'(',nl)
+  ll = strCount(s,')',nn)
+  lerr = nl /= nn
+  IF(fmsg('Mismatching number of opening and closing parenthesis: '//TRIM(s), ll=lerr)) RETURN
+  nl = 2*nl-1
+
+  !--- Build vectors ; vl: parenthesis-separated elements ; ip: parenthesis types (1: opening, 2: closing)
+  ALLOCATE(ip(nl-1),vl(nl))
+  j = 1; im = 1
+  DO i = 1, LEN_TRIM(str)
+    ix = INDEX('()', str(i:i))
+    IF(ix == 0) CYCLE
+    ip(j) = ix
+    vl(j) = str(im:i-1)
+    j = j + 1; im = i + 1
+  END DO
+  vl(j) = str(im:LEN_TRIM(str))
+
+  !--- Search for each opening/closing parenthesis pair
+  DO WHILE(nl > 1)
+    i = 1; DO WHILE(ip(i) /= 1 .OR. ip(i+1) /= 2); i = i + 1; END DO !IF(i > SIZE(ip)+1) EXIT;END DO
+    lerr = reduceExpr_basic(vl(i+1), v); IF(lerr) RETURN
+    v = TRIM(vl(i))//TRIM(v); IF(i+2<=nl) v=TRIM(v)//TRIM(vl(i+2))
+    vv = v//REPEAT(' ',768)
+    IF(i == 1) THEN;         ip =  ip(3:nl-1);                vl = [            vv, vl(4  :nl)]
+    ELSE IF(i == nl-1) THEN; ip =  ip(1:nl-2);                vl = [vl(1:nl-3), vv            ]
+    ELSE;                    ip = [ip(1: i-1), ip(i+2:nl-1)]; vl = [vl(1: i-1), vv, vl(i+3:nl)]; END IF
+    nl = SIZE(vl)
+  END DO
+  lerr = reduceExpr_basic(vl(1), val)
+END FUNCTION reduceExpr_1
+
+
+!==============================================================================================================================
+!=== Reduce a simple algebrical expression (basic operations, no parenthesis) to a single number (string format) ==============
+!==============================================================================================================================
+LOGICAL FUNCTION reduceExpr_basic(str, val) RESULT(lerr)
+  IMPLICIT NONE
+  CHARACTER(LEN=*),      INTENT(IN)  :: str
+  CHARACTER(LEN=*),      INTENT(OUT) :: val
+  DOUBLE PRECISION,      ALLOCATABLE :: vl(:)
+  INTEGER,               ALLOCATABLE :: id(:)
+  CHARACTER(LEN=maxlen), ALLOCATABLE :: ky(:)
+  CHARACTER(LEN=1),      ALLOCATABLE :: op(:)
+!------------------------------------------------------------------------------------------------------------------------------
+  CHARACTER(LEN=1024) :: s
+  DOUBLE PRECISION :: v, vm, vp
+  INTEGER      :: i, ni, io
+  lerr = .FALSE.
+  IF(is_numeric(str)) THEN; val=TRIM(str); RETURN; END IF
+  op = ['^','/','*','+','-']                                                   !--- List of recognized operations
+  s = str
+  lerr = strParse_m(s, op, ky, lSc=.TRUE., id = id)                            !--- Parse the values
+  IF(lerr) RETURN                                                              !--- Problem with the parsing
+  vl = str2dble(ky)                                                            !--- Conversion to doubles
+  lerr = ANY(vl >= HUGE(1.d0))
+  CALL msg('Some values are non-numeric in: '//TRIM(s), ll=lerr)
+  IF(lerr) RETURN                                                              !--- Non-numerical values found
+  DO io = 1, SIZE(op)                                                          !--- Loop on known operators (order matters !)
+    DO i = SIZE(id), 1, -1                                                     !--- Loop on found operators
+      ni = SIZE(id)
+      IF(id(i) /= io) CYCLE                                                    !--- Current found operator is not op(io)
+      vm = vl(i); vp = vl(i+1)                                                 !--- Couple of values used for current operation
+      SELECT CASE(op(io))                                                      !--- Perform operation on the two values
+        CASE('^'); v = vm**vp
+        CASE('/'); v = vm/vp
+        CASE('*'); v = vm*vp
+        CASE('+'); v = vm+vp
+        CASE('-'); v = vm-vp
+      END SELECT
+      IF(i == ni) THEN; vl = [vl(1:ni-1), v]; ELSE; vl = [vl(1:i-1), v, vl(i+2:ni+1)]; END IF
+      IF(i == ni) THEN; id =  id(1:ni-1);     ELSE; id = [id(1:i-1),    id(i+1:ni  )]; END IF
+    END DO
+  END DO
+  val = dble2str(vl(1))
+
+END FUNCTION reduceExpr_basic
+!==============================================================================================================================
+
+!==============================================================================================================================
+FUNCTION reduceExpr_m(str, val) RESULT(lerr)
+  IMPLICIT NONE
+  LOGICAL,               ALLOCATABLE              :: lerr(:)
+  CHARACTER(LEN=*),                   INTENT(IN)  :: str(:)
+  CHARACTER(LEN=maxlen), ALLOCATABLE, INTENT(OUT) :: val(:)
+!------------------------------------------------------------------------------------------------------------------------------
+  INTEGER :: i
+  ALLOCATE(lerr(SIZE(str)),val(SIZE(str)))
+  lerr(:) = [(reduceExpr_1(str(i), val(i)), i=1, SIZE(str))]
+END FUNCTION reduceExpr_m
+!==============================================================================================================================
+
+
+!==============================================================================================================================
+!=== Check whether a string is a number or not ================================================================================
+!==============================================================================================================================
+ELEMENTAL LOGICAL FUNCTION is_numeric(str) RESULT(out)
+  IMPLICIT NONE
+  CHARACTER(LEN=*), INTENT(IN) :: str
+  REAL    :: x
+  INTEGER :: e
+  CHARACTER(LEN=12) :: fmt
+  IF(TRIM(str) == '') THEN; out = .FALSE.; RETURN; END IF
+  WRITE(fmt,'("(f",i0,".0)")') LEN_TRIM(str)
+  READ(str,fmt,IOSTAT=e) x
+  out = e==0 .AND. INDEX('Ee',str(LEN_TRIM(str):LEN_TRIM(str)))==0
+END FUNCTION is_numeric
+!==============================================================================================================================
+
+
+!==============================================================================================================================
+!=== Convert a string into a logical/integer integer or an integer/real into a string =========================================
+!==============================================================================================================================
+ELEMENTAL INTEGER FUNCTION str2bool(str) RESULT(out)  !--- Result: 0/1 for .FALSE./.TRUE., -1 if not a valid boolean
+  IMPLICIT NONE
+  CHARACTER(LEN=*), INTENT(IN) :: str
+  INTEGER :: ierr
+  LOGICAL :: lout
+  READ(str,*,IOSTAT=ierr) lout
+  out = -HUGE(1)
+  IF(ierr /= 0) THEN
+    IF(ANY(['.false.', 'false  ', 'no     ', 'f      ', 'n      '] == strLower(str))) out = 0
+    IF(ANY(['.true. ', 'true   ', 'yes    ', 't      ', 'y      '] == strLower(str))) out = 1
+  ELSE
+    out = 0; IF(lout) out = 1
+  END IF
+END FUNCTION str2bool
+!==============================================================================================================================
+ELEMENTAL INTEGER FUNCTION str2int(str) RESULT(out)
+  IMPLICIT NONE
+  CHARACTER(LEN=*), INTENT(IN) :: str
+  INTEGER :: ierr
+  READ(str,*,IOSTAT=ierr) out
+  IF(ierr/=0) out = -HUGE(1)
+END FUNCTION str2int
+!==============================================================================================================================
+ELEMENTAL REAL FUNCTION str2real(str) RESULT(out)
+  IMPLICIT NONE
+  CHARACTER(LEN=*), INTENT(IN) :: str
+  INTEGER :: ierr
+  READ(str,*,IOSTAT=ierr) out
+  IF(ierr/=0) out = -HUGE(1.)
+END FUNCTION str2real
+!==============================================================================================================================
+ELEMENTAL DOUBLE PRECISION FUNCTION str2dble(str) RESULT(out)
+  IMPLICIT NONE
+  CHARACTER(LEN=*), INTENT(IN) :: str
+  INTEGER :: ierr
+  READ(str,*,IOSTAT=ierr) out
+  IF(ierr/=0) out = -HUGE(1.d0)
+END FUNCTION str2dble
+!==============================================================================================================================
+ELEMENTAL CHARACTER(LEN=maxlen) FUNCTION bool2str(b) RESULT(out)
+  IMPLICIT NONE
+  LOGICAL, INTENT(IN) :: b
+  WRITE(out,*)b
+  out = ADJUSTL(out)
+END FUNCTION bool2str
+!==============================================================================================================================
+ELEMENTAL CHARACTER(LEN=maxlen) FUNCTION int2str(i, nDigits) RESULT(out)
+  IMPLICIT NONE
+  INTEGER,           INTENT(IN) :: i
+  INTEGER, OPTIONAL, INTENT(IN) :: nDigits
+!------------------------------------------------------------------------------------------------------------------------------
+  WRITE(out,*)i
+  out = ADJUSTL(out)
+  IF(.NOT.PRESENT(nDigits)) RETURN
+  IF(nDigits > LEN_TRIM(out)) out = REPEAT('0', nDigits - LEN_TRIM(out))//TRIM(out)
+END FUNCTION int2str
+!==============================================================================================================================
+ELEMENTAL CHARACTER(LEN=maxlen) FUNCTION real2str(r,fmt) RESULT(out)
+  IMPLICIT NONE
+  REAL,                       INTENT(IN) :: r
+  CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: fmt
+!------------------------------------------------------------------------------------------------------------------------------
+  IF(     PRESENT(fmt)) WRITE(out,fmt)r
+  IF(.NOT.PRESENT(fmt)) WRITE(out, * )r
+  out = ADJUSTL(out)
+END FUNCTION real2str
+!==============================================================================================================================
+ELEMENTAL CHARACTER(LEN=maxlen) FUNCTION dble2str(d,fmt) RESULT(out)
+  IMPLICIT NONE
+  DOUBLE PRECISION,           INTENT(IN) :: d
+  CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: fmt
+!------------------------------------------------------------------------------------------------------------------------------
+  IF(     PRESENT(fmt)) WRITE(out,fmt)d
+  IF(.NOT.PRESENT(fmt)) WRITE(out, * )d
+  out = ADJUSTL(out)
+END FUNCTION dble2str
+!==============================================================================================================================
+ELEMENTAL SUBROUTINE cleanZeros(s)
+  IMPLICIT NONE
+  CHARACTER(LEN=*), INTENT(INOUT) :: s
+  INTEGER :: ls, ix, i
+  IF(is_numeric(s)) THEN
+    ls = LEN_TRIM(s)
+    ix = MAX(INDEX(s,'E'),INDEX(s,'e'),INDEX(s,'D'),INDEX(s,'d'))
+    IF(ix == 0) THEN
+      DO ix = ls,1,-1; IF(s(ix:ix) /= '0') EXIT; END DO; s=s(1:ix+1)
+    ELSE IF(INDEX(s,'.')/=0) THEN
+      i = ix-1; DO WHILE(s(i:i) == '0'); i = i-1; END DO; s=s(1:i)//s(ix:ls)
+    END IF
+  END IF
+END SUBROUTINE cleanZeros
+!==============================================================================================================================
+
+
+!==============================================================================================================================
+FUNCTION addQuotes_1(s) RESULT(out)
+  IMPLICIT NONE
+  CHARACTER(LEN=*), INTENT(IN)  :: s
+  CHARACTER(LEN=:), ALLOCATABLE :: out
+  IF(needQuotes(s)) THEN; out = "'"//TRIM(s)//"'"; ELSE; out = s; END IF
+END FUNCTION addQuotes_1
+!==============================================================================================================================
+FUNCTION addQuotes_m(s) RESULT(out)
+  IMPLICIT NONE
+  CHARACTER(LEN=*), INTENT(IN)  :: s(:)
+  CHARACTER(LEN=:), ALLOCATABLE :: out(:)
+!------------------------------------------------------------------------------------------------------------------------------
+  INTEGER :: k, n
+  n = MAXVAL(LEN_TRIM(s), MASK=.TRUE.)
+  ALLOCATE(CHARACTER(LEN=n) :: out(SIZE(s)))
+  DO k=1,SIZE(s)
+    IF(needQuotes(s(k))) THEN; out(k) = "'"//TRIM(s(k))//"'"; ELSE; out(k) = s(k); END IF
+  END DO
+END FUNCTION addQuotes_m
+!==============================================================================================================================
+ELEMENTAL LOGICAL FUNCTION needQuotes(s) RESULT(out)
+  IMPLICIT NONE
+  CHARACTER(LEN=*), INTENT(IN) :: s
+  CHARACTER(LEN=1) :: b, e
+!------------------------------------------------------------------------------------------------------------------------------
+  out = .TRUE.; IF(TRIM(s) == '') RETURN
+  b = s(1:1); e = s(MAX(1,LEN_TRIM(s)):MAX(1,LEN_TRIM(s)))
+  out = .NOT.is_numeric(s) .AND. (b /= "'" .OR. e /= "'") .AND. ( b /= '"' .OR. e /= '"')
+END FUNCTION needQuotes
+!==============================================================================================================================
+
+
+!==============================================================================================================================
+!=== DISPLAY "<message>: the following <items> are <reason>" FOLLOWED BY THE LIST OF <str> FOR WHICH <lerr>==T. ===============
+!==============================================================================================================================
+LOGICAL FUNCTION checkList(str, lerr, message, items, reason, nmax) RESULT(out)
+  IMPLICIT NONE
+! Purpose: Messages in case a list contains wrong elements (indicated by lerr boolean vector).
+! Note:    Return value "out" is .TRUE. if there are errors (ie at least one element of "lerr" is TRUE).
+  CHARACTER(LEN=*),   INTENT(IN)  :: str(:)
+  LOGICAL,            INTENT(IN)  :: lerr(:)
+  CHARACTER(LEN=*),   INTENT(IN)  :: message, items, reason
+  INTEGER,  OPTIONAL, INTENT(IN)  :: nmax
+!------------------------------------------------------------------------------------------------------------------------------
+  CHARACTER(LEN=maxlen), ALLOCATABLE :: s(:)
+  INTEGER :: i, nmx
+  nmx = 256; IF(PRESENT(nmax)) nmx=nmax
+  out = ANY(lerr); IF(.NOT.out) RETURN
+  CALL msg(TRIM(message)//': the following '//TRIM(items)//' are '//TRIM(reason)//':')
+  s = strStackm(PACK(str, MASK=lerr), ', ',nmx)
+  DO i=1,SIZE(s,DIM=1); CALL msg(s(i)); END DO
+END FUNCTION checkList
+!==============================================================================================================================
+
+
+!==============================================================================================================================
+!=== Remove comment in line "str", ie all the characters from the first "#" sign found in "str". ==============================
+!==============================================================================================================================
+SUBROUTINE removeComment(str)
+  IMPLICIT NONE
+  CHARACTER(LEN=*), INTENT(INOUT) :: str
+  INTEGER :: ix
+  ix = INDEX(str,'# '); IF(ix /= 0) str = str(1:ix-1)//REPEAT(' ',LEN(str)-ix+1)
+END SUBROUTINE removeComment
+!==============================================================================================================================
+
+
+END MODULE strings_mod
Index: DZ6/trunk/libf/misc/write_field.F90
===================================================================
--- /LMDZ6/trunk/libf/misc/write_field.F90	(revision 5267)
+++ 	(revision )
@@ -1,309 +1,0 @@
-!
-! $Id$
-!
-module write_field
-  USE strings_mod, ONLY: int2str
-  IMPLICIT NONE; PRIVATE
-  PUBLIC WriteField
-
-  integer, parameter :: MaxWriteField = 100
-  integer, dimension(MaxWriteField),save :: FieldId
-  integer, dimension(MaxWriteField),save :: FieldVarId
-  integer, dimension(MaxWriteField),save :: FieldIndex
-  character(len=255), dimension(MaxWriteField) ::  FieldName 
-   
-  integer,save :: NbField = 0
-  
-  interface WriteField
-    module procedure WriteField3d,WriteField2d,WriteField1d
-  end interface WriteField
-  contains
-  
-    function GetFieldIndex(name)
-    implicit none
-      integer          :: GetFieldindex
-      character(len=*) :: name
-    
-      character(len=255) :: TrueName
-      integer            :: i
-       
-      
-      TrueName=TRIM(ADJUSTL(name))
-    
-      GetFieldIndex=-1
-      do i=1,NbField
-        if (TrueName==FieldName(i)) then
-          GetFieldIndex=i
-          exit
-        endif
-      enddo
-    end function GetFieldIndex
- 
-    subroutine WriteField3d(name,Field)
-    implicit none
-      character(len=*) :: name
-      real, dimension(:,:,:) :: Field 
-      integer, dimension(3) :: Dim
-      
-      Dim=shape(Field)
-      call WriteField_gen(name,Field,Dim(1),Dim(2),Dim(3))  
-  
-    end subroutine WriteField3d
-    
-    subroutine WriteField2d(name,Field)
-    implicit none
-      character(len=*) :: name
-      real, dimension(:,:) :: Field 
-      integer, dimension(2) :: Dim
-      
-      Dim=shape(Field)
-      call WriteField_gen(name,Field,Dim(1),Dim(2),1)  
-  
-    end subroutine WriteField2d
-    
-    subroutine WriteField1d(name,Field)
-    implicit none
-      character(len=*) :: name
-      real, dimension(:) :: Field 
-      integer, dimension(1) :: Dim
-      
-      Dim=shape(Field)
-      call WriteField_gen(name,Field,Dim(1),1,1)  
-  
-    end subroutine WriteField1d
-        
-    subroutine WriteField_gen(name,Field,dimx,dimy,dimz)
-    implicit none
-    include 'netcdf.inc'
-      character(len=*) :: name
-      integer :: dimx,dimy,dimz
-      real,dimension(dimx,dimy,dimz) :: Field
-      integer,dimension(dimx*dimy*dimz) :: ndex
-      integer :: status
-      integer :: index
-      integer :: start(4)
-      integer :: count(4)
-      
-           
-      Index=GetFieldIndex(name)
-      if (Index==-1) then
-        call CreateNewField(name,dimx,dimy,dimz)
-	Index=GetFieldIndex(name)
-      else
-        FieldIndex(Index)=FieldIndex(Index)+1.
-      endif
-      
-      start(1)=1
-      start(2)=1
-      start(3)=1
-      start(4)=FieldIndex(Index)
-
-      count(1)=dimx
-      count(2)=dimy
-      count(3)=dimz
-      count(4)=1
-
-      status = NF_PUT_VARA_DOUBLE(FieldId(Index),FieldVarId(Index),start,count,Field)
-      status = NF_SYNC(FieldId(Index))
-      
-    end subroutine WriteField_gen
-       
-    subroutine CreateNewField(name,dimx,dimy,dimz)
-    implicit none
-    include 'netcdf.inc'  
-      character(len=*) :: name
-      integer :: dimx,dimy,dimz
-      integer :: TabDim(4)
-      integer :: status
-      
-      
-      NbField=NbField+1
-      FieldName(NbField)=TRIM(ADJUSTL(name))
-      FieldIndex(NbField)=1
-      
-      
-      status = NF_CREATE(TRIM(ADJUSTL(name))//'.nc', NF_CLOBBER, FieldId(NbField))
-      status = NF_DEF_DIM(FieldId(NbField),'X',dimx,TabDim(1))
-      status = NF_DEF_DIM(FieldId(NbField),'Y',dimy,TabDim(2))
-      status = NF_DEF_DIM(FieldId(NbField),'Z',dimz,TabDim(3))
-      status = NF_DEF_DIM(FieldId(NbField),'iter',NF_UNLIMITED,TabDim(4))
-      status = NF_DEF_VAR(FieldId(NbField),FieldName(NbField),NF_DOUBLE,4,TabDim,FieldVarId(NbField))
-      status = NF_ENDDEF(FieldId(NbField))
-
-    end subroutine CreateNewField
-    
-    
-    
-  subroutine write_field1D(name,Field)
-    implicit none
-  
-    integer, parameter :: MaxDim=1
-    character(len=*)   :: name
-    real, dimension(:) :: Field
-    real, dimension(:),allocatable :: New_Field
-    character(len=20) :: str
-    integer, dimension(MaxDim) :: Dim
-    integer :: i,nb
-    integer, parameter :: id=10
-    integer, parameter :: NbCol=4
-    integer :: ColumnSize 
-    integer :: pos
-    character(len=255) :: form
-    character(len=255) :: MaxLen
-    
-    
-    open(unit=id,file=name//'.field',form='formatted',status='replace')
-    write (id,'("----- Field '//name//'",//)')
-    Dim=shape(Field)
-    MaxLen=int2str(len(trim(int2str(Dim(1)))))
-    ColumnSize=20+6+3+len(trim(int2str(Dim(1))))
-    Nb=0
-    Pos=2
-    do i=1,Dim(1)
-      nb=nb+1
-      
-      if (MOD(nb,NbCol)==0) then
-        form='(t'//trim(int2str(pos))// ',i'//trim(MaxLen) //'," ---> ",g22.16,/)'
-        Pos=2
-      else
-        form='(t'//trim(int2str(pos))// ',i'//trim(MaxLen) //'," ---> ",g22.16," | ",)'
-        Pos=Pos+ColumnSize
-      endif
-      write (id,form,advance='no') i,Field(i)
-    enddo
-     
-    close(id)
-
-  end subroutine write_field1D
-
-  subroutine write_field2D(name,Field)
-    implicit none
-  
-    integer, parameter :: MaxDim=2
-    character(len=*)   :: name
-    real, dimension(:,:) :: Field
-    real, dimension(:,:),allocatable :: New_Field
-    character(len=20) :: str
-    integer, dimension(MaxDim) :: Dim
-    integer :: i,j,nb
-    integer, parameter :: id=10
-    integer, parameter :: NbCol=4
-    integer :: ColumnSize 
-    integer :: pos,offset
-    character(len=255) :: form
-    character(len=255) :: spacing
-    
-    open(unit=id,file=name//'.field',form='formatted',status='replace')
-    write (id,'("----- Field '//name//'",//)')
-    
-    Dim=shape(Field)
-    offset=len(trim(int2str(Dim(1))))+len(trim(int2str(Dim(2))))+3
-    ColumnSize=20+6+3+offset
-
-    spacing='(t2,"'//repeat('-',ColumnSize*NbCol)//'")'
-    
-    do i=1,Dim(2)
-      nb=0
-      Pos=2
-      do j=1,Dim(1)
-        nb=nb+1
-      
-        if (MOD(nb,NbCol)==0) then
-          form='(t'//trim(int2str(pos))//            &
-               ',"('//trim(int2str(j))//','          &
-                    //trim(int2str(i))//')",t'       & 
-                    //trim(int2str(pos+offset))     &    
-                    //'," ---> ",g22.16,/)'
-          Pos=2
-        else
-          form='(t'//trim(int2str(pos))//            &
-               ',"('//trim(int2str(j))//','          &
-                    //trim(int2str(i))//')",t'       & 
-                    //trim(int2str(pos+offset))     &    
-                    //'," ---> ",g22.16," | ")'
-          Pos=Pos+ColumnSize
-        endif
-        write (id,form,advance='no') Field(j,i)
-      enddo
-      if (MOD(nb,NbCol)==0) then
-        write (id,spacing)
-      else
-        write (id,'("")')
-        write (id,spacing)
-      endif
-    enddo
-     
-  end subroutine write_field2D
-  
-  subroutine write_field3D(name,Field)
-    implicit none
-  
-    integer, parameter :: MaxDim=3
-    character(len=*)   :: name
-    real, dimension(:,:,:) :: Field
-    real, dimension(:,:,:),allocatable :: New_Field
-    integer, dimension(MaxDim) :: Dim
-    integer :: i,j,k,nb
-    integer, parameter :: id=10
-    integer, parameter :: NbCol=4
-    integer :: ColumnSize 
-    integer :: pos,offset
-    character(len=255) :: form
-    character(len=255) :: spacing
-
-    open(unit=id,file=name//'.field',form='formatted',status='replace')
-    write (id,'("----- Field '//name//'"//)')
-    
-    Dim=shape(Field)
-    offset=len(trim(int2str(Dim(1))))+len(trim(int2str(Dim(2))))+len(trim(int2str(Dim(3))))+4
-    ColumnSize=22+6+3+offset
-
-!    open(unit=id,file=name,form=formatted
-   
-    spacing='(t2,"'//repeat('-',ColumnSize*NbCol)//'")'
-    
-    do i=1,Dim(3)
-    
-      do j=1,Dim(2)
-        nb=0
-        Pos=2
-        
-        do k=1,Dim(1)
-        nb=nb+1
-      
-          if (MOD(nb,NbCol)==0) then
-            form='(t'//trim(int2str(pos))//            &
-                 ',"('//trim(int2str(k))//','          &
-                      //trim(int2str(j))//','          &
-                      //trim(int2str(i))//')",t'       & 
-                      //trim(int2str(pos+offset))      &    
-                      //'," ---> ",g22.16,/)'
-           Pos=2
-          else
-            form='(t'//trim(int2str(pos))//            &
-                 ',"('//trim(int2str(k))//','          &
-                      //trim(int2str(j))//','          &
-                      //trim(int2str(i))//')",t'       & 
-                      //trim(int2str(pos+offset))      &    
-                      //'," ---> ",g22.16," | ")'
-! d�pent de l'impl�mention, sur compaq, c'est necessaire
-!            Pos=Pos+ColumnSize
-          endif
-          write (id,form,advance='no') Field(k,j,i)
-        enddo
-        if (MOD(nb,NbCol)==0) then
-          write (id,spacing)
-        else
-          write (id,'("")')
-          write (id,spacing)
-        endif
-      enddo
-      write (id,spacing)
-    enddo
-    
-    close(id)
-  
-  end subroutine write_field3D
-
-end module write_field
-  
Index: /LMDZ6/trunk/libf/misc/write_field.f90
===================================================================
--- /LMDZ6/trunk/libf/misc/write_field.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/misc/write_field.f90	(revision 5268)
@@ -0,0 +1,309 @@
+!
+! $Id$
+!
+module write_field
+  USE strings_mod, ONLY: int2str
+  IMPLICIT NONE; PRIVATE
+  PUBLIC WriteField
+
+  integer, parameter :: MaxWriteField = 100
+  integer, dimension(MaxWriteField),save :: FieldId
+  integer, dimension(MaxWriteField),save :: FieldVarId
+  integer, dimension(MaxWriteField),save :: FieldIndex
+  character(len=255), dimension(MaxWriteField) ::  FieldName 
+   
+  integer,save :: NbField = 0
+  
+  interface WriteField
+    module procedure WriteField3d,WriteField2d,WriteField1d
+  end interface WriteField
+  contains
+  
+    function GetFieldIndex(name)
+    implicit none
+      integer          :: GetFieldindex
+      character(len=*) :: name
+    
+      character(len=255) :: TrueName
+      integer            :: i
+       
+      
+      TrueName=TRIM(ADJUSTL(name))
+    
+      GetFieldIndex=-1
+      do i=1,NbField
+        if (TrueName==FieldName(i)) then
+          GetFieldIndex=i
+          exit
+        endif
+      enddo
+    end function GetFieldIndex
+ 
+    subroutine WriteField3d(name,Field)
+    implicit none
+      character(len=*) :: name
+      real, dimension(:,:,:) :: Field 
+      integer, dimension(3) :: Dim
+      
+      Dim=shape(Field)
+      call WriteField_gen(name,Field,Dim(1),Dim(2),Dim(3))  
+  
+    end subroutine WriteField3d
+    
+    subroutine WriteField2d(name,Field)
+    implicit none
+      character(len=*) :: name
+      real, dimension(:,:) :: Field 
+      integer, dimension(2) :: Dim
+      
+      Dim=shape(Field)
+      call WriteField_gen(name,Field,Dim(1),Dim(2),1)  
+  
+    end subroutine WriteField2d
+    
+    subroutine WriteField1d(name,Field)
+    implicit none
+      character(len=*) :: name
+      real, dimension(:) :: Field 
+      integer, dimension(1) :: Dim
+      
+      Dim=shape(Field)
+      call WriteField_gen(name,Field,Dim(1),1,1)  
+  
+    end subroutine WriteField1d
+        
+    subroutine WriteField_gen(name,Field,dimx,dimy,dimz)
+    implicit none
+    include 'netcdf.inc'
+      character(len=*) :: name
+      integer :: dimx,dimy,dimz
+      real,dimension(dimx,dimy,dimz) :: Field
+      integer,dimension(dimx*dimy*dimz) :: ndex
+      integer :: status
+      integer :: index
+      integer :: start(4)
+      integer :: count(4)
+      
+           
+      Index=GetFieldIndex(name)
+      if (Index==-1) then
+        call CreateNewField(name,dimx,dimy,dimz)
+	Index=GetFieldIndex(name)
+      else
+        FieldIndex(Index)=FieldIndex(Index)+1.
+      endif
+      
+      start(1)=1
+      start(2)=1
+      start(3)=1
+      start(4)=FieldIndex(Index)
+
+      count(1)=dimx
+      count(2)=dimy
+      count(3)=dimz
+      count(4)=1
+
+      status = NF_PUT_VARA_DOUBLE(FieldId(Index),FieldVarId(Index),start,count,Field)
+      status = NF_SYNC(FieldId(Index))
+      
+    end subroutine WriteField_gen
+       
+    subroutine CreateNewField(name,dimx,dimy,dimz)
+    implicit none
+    include 'netcdf.inc'  
+      character(len=*) :: name
+      integer :: dimx,dimy,dimz
+      integer :: TabDim(4)
+      integer :: status
+      
+      
+      NbField=NbField+1
+      FieldName(NbField)=TRIM(ADJUSTL(name))
+      FieldIndex(NbField)=1
+      
+      
+      status = NF_CREATE(TRIM(ADJUSTL(name))//'.nc', NF_CLOBBER, FieldId(NbField))
+      status = NF_DEF_DIM(FieldId(NbField),'X',dimx,TabDim(1))
+      status = NF_DEF_DIM(FieldId(NbField),'Y',dimy,TabDim(2))
+      status = NF_DEF_DIM(FieldId(NbField),'Z',dimz,TabDim(3))
+      status = NF_DEF_DIM(FieldId(NbField),'iter',NF_UNLIMITED,TabDim(4))
+      status = NF_DEF_VAR(FieldId(NbField),FieldName(NbField),NF_DOUBLE,4,TabDim,FieldVarId(NbField))
+      status = NF_ENDDEF(FieldId(NbField))
+
+    end subroutine CreateNewField
+    
+    
+    
+  subroutine write_field1D(name,Field)
+    implicit none
+  
+    integer, parameter :: MaxDim=1
+    character(len=*)   :: name
+    real, dimension(:) :: Field
+    real, dimension(:),allocatable :: New_Field
+    character(len=20) :: str
+    integer, dimension(MaxDim) :: Dim
+    integer :: i,nb
+    integer, parameter :: id=10
+    integer, parameter :: NbCol=4
+    integer :: ColumnSize 
+    integer :: pos
+    character(len=255) :: form
+    character(len=255) :: MaxLen
+    
+    
+    open(unit=id,file=name//'.field',form='formatted',status='replace')
+    write (id,'("----- Field '//name//'",//)')
+    Dim=shape(Field)
+    MaxLen=int2str(len(trim(int2str(Dim(1)))))
+    ColumnSize=20+6+3+len(trim(int2str(Dim(1))))
+    Nb=0
+    Pos=2
+    do i=1,Dim(1)
+      nb=nb+1
+      
+      if (MOD(nb,NbCol)==0) then
+        form='(t'//trim(int2str(pos))// ',i'//trim(MaxLen) //'," ---> ",g22.16,/)'
+        Pos=2
+      else
+        form='(t'//trim(int2str(pos))// ',i'//trim(MaxLen) //'," ---> ",g22.16," | ",)'
+        Pos=Pos+ColumnSize
+      endif
+      write (id,form,advance='no') i,Field(i)
+    enddo
+     
+    close(id)
+
+  end subroutine write_field1D
+
+  subroutine write_field2D(name,Field)
+    implicit none
+  
+    integer, parameter :: MaxDim=2
+    character(len=*)   :: name
+    real, dimension(:,:) :: Field
+    real, dimension(:,:),allocatable :: New_Field
+    character(len=20) :: str
+    integer, dimension(MaxDim) :: Dim
+    integer :: i,j,nb
+    integer, parameter :: id=10
+    integer, parameter :: NbCol=4
+    integer :: ColumnSize 
+    integer :: pos,offset
+    character(len=255) :: form
+    character(len=255) :: spacing
+    
+    open(unit=id,file=name//'.field',form='formatted',status='replace')
+    write (id,'("----- Field '//name//'",//)')
+    
+    Dim=shape(Field)
+    offset=len(trim(int2str(Dim(1))))+len(trim(int2str(Dim(2))))+3
+    ColumnSize=20+6+3+offset
+
+    spacing='(t2,"'//repeat('-',ColumnSize*NbCol)//'")'
+    
+    do i=1,Dim(2)
+      nb=0
+      Pos=2
+      do j=1,Dim(1)
+        nb=nb+1
+      
+        if (MOD(nb,NbCol)==0) then
+          form='(t'//trim(int2str(pos))//            &
+               ',"('//trim(int2str(j))//','          &
+                    //trim(int2str(i))//')",t'       & 
+                    //trim(int2str(pos+offset))     &    
+                    //'," ---> ",g22.16,/)'
+          Pos=2
+        else
+          form='(t'//trim(int2str(pos))//            &
+               ',"('//trim(int2str(j))//','          &
+                    //trim(int2str(i))//')",t'       & 
+                    //trim(int2str(pos+offset))     &    
+                    //'," ---> ",g22.16," | ")'
+          Pos=Pos+ColumnSize
+        endif
+        write (id,form,advance='no') Field(j,i)
+      enddo
+      if (MOD(nb,NbCol)==0) then
+        write (id,spacing)
+      else
+        write (id,'("")')
+        write (id,spacing)
+      endif
+    enddo
+     
+  end subroutine write_field2D
+  
+  subroutine write_field3D(name,Field)
+    implicit none
+  
+    integer, parameter :: MaxDim=3
+    character(len=*)   :: name
+    real, dimension(:,:,:) :: Field
+    real, dimension(:,:,:),allocatable :: New_Field
+    integer, dimension(MaxDim) :: Dim
+    integer :: i,j,k,nb
+    integer, parameter :: id=10
+    integer, parameter :: NbCol=4
+    integer :: ColumnSize 
+    integer :: pos,offset
+    character(len=255) :: form
+    character(len=255) :: spacing
+
+    open(unit=id,file=name//'.field',form='formatted',status='replace')
+    write (id,'("----- Field '//name//'"//)')
+    
+    Dim=shape(Field)
+    offset=len(trim(int2str(Dim(1))))+len(trim(int2str(Dim(2))))+len(trim(int2str(Dim(3))))+4
+    ColumnSize=22+6+3+offset
+
+!    open(unit=id,file=name,form=formatted
+   
+    spacing='(t2,"'//repeat('-',ColumnSize*NbCol)//'")'
+    
+    do i=1,Dim(3)
+    
+      do j=1,Dim(2)
+        nb=0
+        Pos=2
+        
+        do k=1,Dim(1)
+        nb=nb+1
+      
+          if (MOD(nb,NbCol)==0) then
+            form='(t'//trim(int2str(pos))//            &
+                 ',"('//trim(int2str(k))//','          &
+                      //trim(int2str(j))//','          &
+                      //trim(int2str(i))//')",t'       & 
+                      //trim(int2str(pos+offset))      &    
+                      //'," ---> ",g22.16,/)'
+           Pos=2
+          else
+            form='(t'//trim(int2str(pos))//            &
+                 ',"('//trim(int2str(k))//','          &
+                      //trim(int2str(j))//','          &
+                      //trim(int2str(i))//')",t'       & 
+                      //trim(int2str(pos+offset))      &    
+                      //'," ---> ",g22.16," | ")'
+! d�pent de l'impl�mention, sur compaq, c'est necessaire
+!            Pos=Pos+ColumnSize
+          endif
+          write (id,form,advance='no') Field(k,j,i)
+        enddo
+        if (MOD(nb,NbCol)==0) then
+          write (id,spacing)
+        else
+          write (id,'("")')
+          write (id,spacing)
+        endif
+      enddo
+      write (id,spacing)
+    enddo
+    
+    close(id)
+  
+  end subroutine write_field3D
+
+end module write_field
+  
Index: DZ6/trunk/libf/phy_common/abort_physic.F90
===================================================================
--- /LMDZ6/trunk/libf/phy_common/abort_physic.F90	(revision 5267)
+++ 	(revision )
@@ -1,51 +1,0 @@
-! $Id: $
-      SUBROUTINE abort_physic(modname, message, ierr)
-     
-      USE IOIPSL
-
-      USE mod_phys_lmdz_para
-      USE print_control_mod, ONLY: lunout
-      IMPLICIT NONE
-!
-! Stops the simulation cleanly, closing files and printing various
-! comments
-!
-!  Input: modname = name of calling program
-!         message = stuff to print
-!         ierr    = severity of situation ( = 0 normal )
-
-      character(len=*), intent(in):: modname
-      integer ierr, ierror_mpi
-      character(len=*), intent(in):: message
-
-      write(lunout,*) 'in abort_physic'
-!$OMP MASTER
-      call histclo
-      call restclo
-      if (mpi_rank .eq. 0) then
-         call getin_dump
-      endif
-!$OMP END MASTER
-
-      write(lunout,*) 'Stopping in ', modname
-      write(lunout,*) 'Reason = ',message
-      if (ierr .eq. 0) then
-        write(lunout,*) 'Everything is cool'
-        if (using_mpi) then
-          !$OMP CRITICAL (MPI_ABORT_PHYSIC)
-          call MPI_ABORT(COMM_LMDZ_PHY, 0, ierror_mpi)
-          !$OMP END CRITICAL (MPI_ABORT_PHYSIC)
-        else
-          stop 0
-        endif          
-      else
-        write(lunout,*) 'Houston, we have a problem, ierr = ', ierr
-        if (using_mpi) then
-          !$OMP CRITICAL (MPI_ABORT_PHYSIC)
-          call MPI_ABORT(COMM_LMDZ_PHY, 1, ierror_mpi)
-          !$OMP END CRITICAL (MPI_ABORT_PHYSIC)
-        else
-          stop 1
-        endif          
-      endif
-      END
Index: /LMDZ6/trunk/libf/phy_common/abort_physic.f90
===================================================================
--- /LMDZ6/trunk/libf/phy_common/abort_physic.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phy_common/abort_physic.f90	(revision 5268)
@@ -0,0 +1,51 @@
+! $Id: $
+      SUBROUTINE abort_physic(modname, message, ierr)
+     
+      USE IOIPSL
+
+      USE mod_phys_lmdz_para
+      USE print_control_mod, ONLY: lunout
+      IMPLICIT NONE
+!
+! Stops the simulation cleanly, closing files and printing various
+! comments
+!
+!  Input: modname = name of calling program
+!         message = stuff to print
+!         ierr    = severity of situation ( = 0 normal )
+
+      character(len=*), intent(in):: modname
+      integer ierr, ierror_mpi
+      character(len=*), intent(in):: message
+
+      write(lunout,*) 'in abort_physic'
+!$OMP MASTER
+      call histclo
+      call restclo
+      if (mpi_rank .eq. 0) then
+         call getin_dump
+      endif
+!$OMP END MASTER
+
+      write(lunout,*) 'Stopping in ', modname
+      write(lunout,*) 'Reason = ',message
+      if (ierr .eq. 0) then
+        write(lunout,*) 'Everything is cool'
+        if (using_mpi) then
+          !$OMP CRITICAL (MPI_ABORT_PHYSIC)
+          call MPI_ABORT(COMM_LMDZ_PHY, 0, ierror_mpi)
+          !$OMP END CRITICAL (MPI_ABORT_PHYSIC)
+        else
+          stop 0
+        endif          
+      else
+        write(lunout,*) 'Houston, we have a problem, ierr = ', ierr
+        if (using_mpi) then
+          !$OMP CRITICAL (MPI_ABORT_PHYSIC)
+          call MPI_ABORT(COMM_LMDZ_PHY, 1, ierror_mpi)
+          !$OMP END CRITICAL (MPI_ABORT_PHYSIC)
+        else
+          stop 1
+        endif          
+      endif
+      END
Index: DZ6/trunk/libf/phy_common/geometry_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phy_common/geometry_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,79 +1,0 @@
-MODULE geometry_mod
-
-! Store informations concerning the local (to MPI/OpenMP core) geometry
-
-  REAL,SAVE,ALLOCATABLE :: longitude(:) ! longitude of the cell (rad)
-!$OMP THREADPRIVATE(longitude)
-
-  REAL,SAVE,ALLOCATABLE :: latitude(:)! latitude of the cell (rad)
-!$OMP THREADPRIVATE(latitude)
-
-  REAL,SAVE,ALLOCATABLE :: longitude_deg(:) ! longitude of the cell (degree)
-!$OMP THREADPRIVATE(longitude_deg)
-
-  REAL,SAVE,ALLOCATABLE :: latitude_deg(:)! latitude of the cell (degree)
-!$OMP THREADPRIVATE(latitude_deg)
-
-  REAL,SAVE,ALLOCATABLE :: boundslon(:,:)  ! boundaries of the cell (rad)
-!$OMP THREADPRIVATE(boundslon)
-
-  REAL,SAVE,ALLOCATABLE :: boundslat(:,:) ! boundaries of the cell (rad)
-!$OMP THREADPRIVATE(boundslat)
-
-  REAL,SAVE,ALLOCATABLE :: dx(:)      ! resolution of longitude cell (valid only for 2D grid)
-!$OMP THREADPRIVATE(dx)
-  
-  REAL,SAVE,ALLOCATABLE :: dy(:)      ! resolution of latitude cell (valid only for 2D grid)
-!$OMP THREADPRIVATE(dy)
-
-  REAL,SAVE,ALLOCATABLE :: cell_area(:)      ! area of the cell
-!$OMP THREADPRIVATE(cell_area)
-
-  INTEGER,SAVE,ALLOCATABLE :: ind_cell_glo(:)      ! global indice of a local cell
-!$OMP THREADPRIVATE(ind_cell_glo)
-
-CONTAINS
-
-  SUBROUTINE init_geometry(klon,longitude_,latitude_, &
-                           boundslon_,boundslat_, &
-                           cell_area_,ind_cell_glo_,dx_,dy_)
-  USE mod_grid_phy_lmdz, ONLY: nvertex
-  USE nrtype, ONLY : PI
-  IMPLICIT NONE
-    INTEGER,INTENT(IN) :: klon ! number of columns for this MPI/OpenMP domain
-    REAL,INTENT(IN) :: longitude_(klon)
-    REAL,INTENT(IN) :: latitude_(klon)
-    REAL,INTENT(IN) :: boundslon_(klon,nvertex)
-    REAL,INTENT(IN) :: boundslat_(klon,nvertex)
-    REAL,INTENT(IN) :: cell_area_(klon)
-    INTEGER,OPTIONAL,INTENT(IN) :: ind_cell_glo_(klon)
-    REAL,OPTIONAL,INTENT(IN) :: dx_(klon)
-    REAL,OPTIONAL,INTENT(IN) :: dy_(klon)
-    
-    ALLOCATE(longitude(klon))
-    ALLOCATE(latitude(klon))
-    ALLOCATE(longitude_deg(klon))
-    ALLOCATE(latitude_deg(klon))
-    ALLOCATE(boundslon(klon,nvertex))
-    ALLOCATE(boundslat(klon,nvertex))
-    ALLOCATE(cell_area(klon))
-    IF (PRESENT(ind_cell_glo_)) ALLOCATE(ind_cell_glo(klon))
-    IF (PRESENT(dx_)) ALLOCATE(dx(klon))
-    IF (PRESENT(dy_))ALLOCATE(dy(klon))
-    
-    longitude(:) = longitude_(:)
-    latitude(:) = latitude_(:)
-    longitude_deg(:) = longitude(:)*180./PI
-    latitude_deg(:) = latitude(:)*180./PI
-    boundslon(:,:) = boundslon_(:,:)
-    boundslat(:,:) = boundslat_(:,:)
-    cell_area(:) = cell_area_(:)
-    IF (PRESENT(ind_cell_glo_)) ind_cell_glo(:) = ind_cell_glo_(:)
-    IF (PRESENT(dx_)) dx(:) = dx_(:)
-    IF (PRESENT(dy_)) dy(:) = dy_(:)
-    
-  END SUBROUTINE init_geometry
-
-
-END MODULE geometry_mod
-
Index: /LMDZ6/trunk/libf/phy_common/geometry_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phy_common/geometry_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phy_common/geometry_mod.f90	(revision 5268)
@@ -0,0 +1,79 @@
+MODULE geometry_mod
+
+! Store informations concerning the local (to MPI/OpenMP core) geometry
+
+  REAL,SAVE,ALLOCATABLE :: longitude(:) ! longitude of the cell (rad)
+!$OMP THREADPRIVATE(longitude)
+
+  REAL,SAVE,ALLOCATABLE :: latitude(:)! latitude of the cell (rad)
+!$OMP THREADPRIVATE(latitude)
+
+  REAL,SAVE,ALLOCATABLE :: longitude_deg(:) ! longitude of the cell (degree)
+!$OMP THREADPRIVATE(longitude_deg)
+
+  REAL,SAVE,ALLOCATABLE :: latitude_deg(:)! latitude of the cell (degree)
+!$OMP THREADPRIVATE(latitude_deg)
+
+  REAL,SAVE,ALLOCATABLE :: boundslon(:,:)  ! boundaries of the cell (rad)
+!$OMP THREADPRIVATE(boundslon)
+
+  REAL,SAVE,ALLOCATABLE :: boundslat(:,:) ! boundaries of the cell (rad)
+!$OMP THREADPRIVATE(boundslat)
+
+  REAL,SAVE,ALLOCATABLE :: dx(:)      ! resolution of longitude cell (valid only for 2D grid)
+!$OMP THREADPRIVATE(dx)
+  
+  REAL,SAVE,ALLOCATABLE :: dy(:)      ! resolution of latitude cell (valid only for 2D grid)
+!$OMP THREADPRIVATE(dy)
+
+  REAL,SAVE,ALLOCATABLE :: cell_area(:)      ! area of the cell
+!$OMP THREADPRIVATE(cell_area)
+
+  INTEGER,SAVE,ALLOCATABLE :: ind_cell_glo(:)      ! global indice of a local cell
+!$OMP THREADPRIVATE(ind_cell_glo)
+
+CONTAINS
+
+  SUBROUTINE init_geometry(klon,longitude_,latitude_, &
+                           boundslon_,boundslat_, &
+                           cell_area_,ind_cell_glo_,dx_,dy_)
+  USE mod_grid_phy_lmdz, ONLY: nvertex
+  USE nrtype, ONLY : PI
+  IMPLICIT NONE
+    INTEGER,INTENT(IN) :: klon ! number of columns for this MPI/OpenMP domain
+    REAL,INTENT(IN) :: longitude_(klon)
+    REAL,INTENT(IN) :: latitude_(klon)
+    REAL,INTENT(IN) :: boundslon_(klon,nvertex)
+    REAL,INTENT(IN) :: boundslat_(klon,nvertex)
+    REAL,INTENT(IN) :: cell_area_(klon)
+    INTEGER,OPTIONAL,INTENT(IN) :: ind_cell_glo_(klon)
+    REAL,OPTIONAL,INTENT(IN) :: dx_(klon)
+    REAL,OPTIONAL,INTENT(IN) :: dy_(klon)
+    
+    ALLOCATE(longitude(klon))
+    ALLOCATE(latitude(klon))
+    ALLOCATE(longitude_deg(klon))
+    ALLOCATE(latitude_deg(klon))
+    ALLOCATE(boundslon(klon,nvertex))
+    ALLOCATE(boundslat(klon,nvertex))
+    ALLOCATE(cell_area(klon))
+    IF (PRESENT(ind_cell_glo_)) ALLOCATE(ind_cell_glo(klon))
+    IF (PRESENT(dx_)) ALLOCATE(dx(klon))
+    IF (PRESENT(dy_))ALLOCATE(dy(klon))
+    
+    longitude(:) = longitude_(:)
+    latitude(:) = latitude_(:)
+    longitude_deg(:) = longitude(:)*180./PI
+    latitude_deg(:) = latitude(:)*180./PI
+    boundslon(:,:) = boundslon_(:,:)
+    boundslat(:,:) = boundslat_(:,:)
+    cell_area(:) = cell_area_(:)
+    IF (PRESENT(ind_cell_glo_)) ind_cell_glo(:) = ind_cell_glo_(:)
+    IF (PRESENT(dx_)) dx(:) = dx_(:)
+    IF (PRESENT(dy_)) dy(:) = dy_(:)
+    
+  END SUBROUTINE init_geometry
+
+
+END MODULE geometry_mod
+
Index: DZ6/trunk/libf/phy_common/init_print_control_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phy_common/init_print_control_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,67 +1,0 @@
-MODULE init_print_control_mod
-
-! init_print_control to initialize print_control_mod variables
-! not included there because of circular dependecy issues
-
-CONTAINS
-
-  SUBROUTINE init_print_control
-  USE print_control_mod, ONLY : set_print_control
-  USE ioipsl_getin_p_mod, ONLY : getin_p
-  USE mod_phys_lmdz_para, ONLY: is_omp_root, is_master
-  IMPLICIT NONE
-
-    INTEGER :: lunout ! default output file identifier (6==screen)
-    INTEGER :: prt_level ! Output level
-    LOGICAL :: debug ! flag to specify if in "debug mode"
-    LOGICAL :: opened
-    INTEGER :: number
-    
-    !Config  Key  = prt_level
-    !Config  Desc = niveau d'impressions de débogage
-    !Config  Def  = 0
-    !Config  Help = Niveau d'impression pour le débogage
-    !Config         (0 = minimum d'impression)
-    prt_level = 0
-    CALL getin_p('prt_level',prt_level)
-
-    !Config  Key  = lunout
-    !Config  Desc = unite de fichier pour les impressions
-    !Config  Def  = 6
-    !Config  Help = unite de fichier pour les impressions 
-    !Config         (defaut sortie standard = 6)
-    lunout=6
-    CALL getin_p('lunout', lunout)
-
-    IF (is_omp_root) THEN
-      IF (lunout /= 5 .and. lunout /= 6) THEN
-         INQUIRE(FILE='lmdz.out_0000',OPENED=opened,NUMBER=number)
-         IF (opened) THEN
-           lunout=number
-         ELSE
-           OPEN(UNIT=lunout,FILE='lmdz.out_0000',ACTION='write',  &
-                STATUS='unknown',FORM='formatted')
-         ENDIF
-      ENDIF
-    ENDIF
-
-    !Config  Key  = debug
-    !Config  Desc = mode debogage
-    !Config  Def  = false
-    !Config  Help = positionne le mode debogage
-
-    debug = .FALSE.
-    CALL getin_p('debug',debug)
-    
-    IF (is_master) THEN
-      WRITE(lunout,*)"init_print_control: prt_level=",prt_level
-      WRITE(lunout,*)"init_print_control: lunout=",lunout
-      WRITE(lunout,*)"init_print_control: debug=",debug      
-    ENDIF
-    
-    CALL set_print_control(lunout,prt_level,debug)
-
-  END SUBROUTINE init_print_control  
-
-END MODULE init_print_control_mod
-
Index: /LMDZ6/trunk/libf/phy_common/init_print_control_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phy_common/init_print_control_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phy_common/init_print_control_mod.f90	(revision 5268)
@@ -0,0 +1,67 @@
+MODULE init_print_control_mod
+
+! init_print_control to initialize print_control_mod variables
+! not included there because of circular dependecy issues
+
+CONTAINS
+
+  SUBROUTINE init_print_control
+  USE print_control_mod, ONLY : set_print_control
+  USE ioipsl_getin_p_mod, ONLY : getin_p
+  USE mod_phys_lmdz_para, ONLY: is_omp_root, is_master
+  IMPLICIT NONE
+
+    INTEGER :: lunout ! default output file identifier (6==screen)
+    INTEGER :: prt_level ! Output level
+    LOGICAL :: debug ! flag to specify if in "debug mode"
+    LOGICAL :: opened
+    INTEGER :: number
+    
+    !Config  Key  = prt_level
+    !Config  Desc = niveau d'impressions de débogage
+    !Config  Def  = 0
+    !Config  Help = Niveau d'impression pour le débogage
+    !Config         (0 = minimum d'impression)
+    prt_level = 0
+    CALL getin_p('prt_level',prt_level)
+
+    !Config  Key  = lunout
+    !Config  Desc = unite de fichier pour les impressions
+    !Config  Def  = 6
+    !Config  Help = unite de fichier pour les impressions 
+    !Config         (defaut sortie standard = 6)
+    lunout=6
+    CALL getin_p('lunout', lunout)
+
+    IF (is_omp_root) THEN
+      IF (lunout /= 5 .and. lunout /= 6) THEN
+         INQUIRE(FILE='lmdz.out_0000',OPENED=opened,NUMBER=number)
+         IF (opened) THEN
+           lunout=number
+         ELSE
+           OPEN(UNIT=lunout,FILE='lmdz.out_0000',ACTION='write',  &
+                STATUS='unknown',FORM='formatted')
+         ENDIF
+      ENDIF
+    ENDIF
+
+    !Config  Key  = debug
+    !Config  Desc = mode debogage
+    !Config  Def  = false
+    !Config  Help = positionne le mode debogage
+
+    debug = .FALSE.
+    CALL getin_p('debug',debug)
+    
+    IF (is_master) THEN
+      WRITE(lunout,*)"init_print_control: prt_level=",prt_level
+      WRITE(lunout,*)"init_print_control: lunout=",lunout
+      WRITE(lunout,*)"init_print_control: debug=",debug      
+    ENDIF
+    
+    CALL set_print_control(lunout,prt_level,debug)
+
+  END SUBROUTINE init_print_control  
+
+END MODULE init_print_control_mod
+
Index: DZ6/trunk/libf/phy_common/ioipsl_getin_p_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phy_common/ioipsl_getin_p_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,165 +1,0 @@
-!
-! $Id$
-!
-MODULE ioipsl_getin_p_mod
-! To use getin in a parallel context
-!---------------------------------------------------------------------
-USE ioipsl, ONLY: getin
-USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
-USE mod_phys_lmdz_omp_data, ONLY :  is_omp_root
-USE mod_phys_lmdz_transfert_para, ONLY : bcast
-!-
-IMPLICIT NONE
-!-
-PRIVATE
-PUBLIC :: getin_p
-!-
-INTERFACE getin_p
-
-  MODULE PROCEDURE getinrs_p, getinr1d_p, getinr2d_p, &
- &                 getinis_p, getini1d_p, getini2d_p, &
- &                 getincs_p, 		              &
- &                 getinls_p, getinl1d_p, getinl2d_p
-END INTERFACE
-!-
-CONTAINS
-
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!!   Definition des getin -> bcast      !!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-!! -- Les chaines de caracteres -- !!
-  
-  SUBROUTINE getincs_p(VarIn,VarOut)
-    IMPLICIT NONE    
-    CHARACTER(LEN=*),INTENT(IN) :: VarIn
-    CHARACTER(LEN=*),INTENT(INOUT) :: VarOut    
-
-!$OMP BARRIER
-    IF (is_mpi_root .AND. is_omp_root) THEN
-    	CALL getin(VarIn,VarOut)
-    ENDIF
-    CALL bcast(VarOut)
-  END SUBROUTINE getincs_p
-
-!! -- Les entiers -- !!
-  
-  SUBROUTINE getinis_p(VarIn,VarOut)
-    IMPLICIT NONE    
-    CHARACTER(LEN=*),INTENT(IN) :: VarIn
-    INTEGER,INTENT(INOUT) :: VarOut    
-
-!$OMP BARRIER
-    IF (is_mpi_root .AND. is_omp_root) THEN
-    	CALL getin(VarIn,VarOut)
-    ENDIF
-    CALL bcast(VarOut)
-  END SUBROUTINE getinis_p
-
-  SUBROUTINE getini1d_p(VarIn,VarOut)
-    IMPLICIT NONE    
-    CHARACTER(LEN=*),INTENT(IN) :: VarIn
-    INTEGER,INTENT(INOUT) :: VarOut(:)
-
-!$OMP BARRIER
-    IF (is_mpi_root .AND. is_omp_root) THEN
-    	CALL getin(VarIn,VarOut)
-    ENDIF
-    CALL bcast(VarOut)
-  END SUBROUTINE getini1d_p
-
-  SUBROUTINE getini2d_p(VarIn,VarOut)
-    IMPLICIT NONE    
-    CHARACTER(LEN=*),INTENT(IN) :: VarIn
-    INTEGER,INTENT(INOUT) :: VarOut(:,:)
-
-!$OMP BARRIER
-    IF (is_mpi_root .AND. is_omp_root) THEN
-    	CALL getin(VarIn,VarOut)
-    ENDIF
-    CALL bcast(VarOut)
-  END SUBROUTINE getini2d_p
-
-!! -- Les flottants -- !!
-  
-  SUBROUTINE getinrs_p(VarIn,VarOut)
-    IMPLICIT NONE    
-    CHARACTER(LEN=*),INTENT(IN) :: VarIn
-    REAL,INTENT(INOUT) :: VarOut
-
-!$OMP BARRIER
-    IF (is_mpi_root .AND. is_omp_root) THEN
-    	CALL getin(VarIn,VarOut)
-    ENDIF
-    CALL bcast(VarOut)
-  END SUBROUTINE getinrs_p
-
-  SUBROUTINE getinr1d_p(VarIn,VarOut)
-    IMPLICIT NONE    
-    CHARACTER(LEN=*),INTENT(IN) :: VarIn
-    REAL,INTENT(INOUT) :: VarOut(:)
-
-!$OMP BARRIER
-    IF (is_mpi_root .AND. is_omp_root) THEN
-    	CALL getin(VarIn,VarOut)
-    ENDIF
-    CALL bcast(VarOut)
-  END SUBROUTINE getinr1d_p
-
-  SUBROUTINE getinr2d_p(VarIn,VarOut)
-    IMPLICIT NONE    
-    CHARACTER(LEN=*),INTENT(IN) :: VarIn
-    REAL,INTENT(INOUT) :: VarOut(:,:)
-
-!$OMP BARRIER
-    IF (is_mpi_root .AND. is_omp_root) THEN
-    	CALL getin(VarIn,VarOut)
-    ENDIF
-    CALL bcast(VarOut)
-  END SUBROUTINE getinr2d_p
-
-!! -- Les Booleens -- !!
-  
-  SUBROUTINE getinls_p(VarIn,VarOut)
-    IMPLICIT NONE    
-    CHARACTER(LEN=*),INTENT(IN) :: VarIn
-    LOGICAL,INTENT(INOUT) :: VarOut
-
-!$OMP BARRIER
-    IF (is_mpi_root .AND. is_omp_root) THEN
-    	CALL getin(VarIn,VarOut)
-    ENDIF
-    CALL bcast(VarOut)
-  END SUBROUTINE getinls_p
-
-  SUBROUTINE getinl1d_p(VarIn,VarOut)
-    IMPLICIT NONE    
-    CHARACTER(LEN=*),INTENT(IN) :: VarIn
-    LOGICAL,INTENT(INOUT) :: VarOut(:)
-
-!$OMP BARRIER
-    IF (is_mpi_root .AND. is_omp_root) THEN
-    	CALL getin(VarIn,VarOut)
-    ENDIF
-    CALL bcast(VarOut)
-  END SUBROUTINE getinl1d_p
-
-  SUBROUTINE getinl2d_p(VarIn,VarOut)
-    IMPLICIT NONE    
-    CHARACTER(LEN=*),INTENT(IN) :: VarIn
-    LOGICAL,INTENT(INOUT) :: VarOut(:,:)
-
-!$OMP BARRIER
-    IF (is_mpi_root .AND. is_omp_root) THEN
-    	CALL getin(VarIn,VarOut)
-    ENDIF
-    CALL bcast(VarOut)
-  END SUBROUTINE getinl2d_p
-!-
-!-----------------------------
-!-----------------------------
-!-----------------------------
-
-END MODULE ioipsl_getin_p_mod
-
Index: /LMDZ6/trunk/libf/phy_common/ioipsl_getin_p_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phy_common/ioipsl_getin_p_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phy_common/ioipsl_getin_p_mod.f90	(revision 5268)
@@ -0,0 +1,165 @@
+!
+! $Id$
+!
+MODULE ioipsl_getin_p_mod
+! To use getin in a parallel context
+!---------------------------------------------------------------------
+USE ioipsl, ONLY: getin
+USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+USE mod_phys_lmdz_omp_data, ONLY :  is_omp_root
+USE mod_phys_lmdz_transfert_para, ONLY : bcast
+!-
+IMPLICIT NONE
+!-
+PRIVATE
+PUBLIC :: getin_p
+!-
+INTERFACE getin_p
+
+  MODULE PROCEDURE getinrs_p, getinr1d_p, getinr2d_p, &
+ &                 getinis_p, getini1d_p, getini2d_p, &
+ &                 getincs_p, 		              &
+ &                 getinls_p, getinl1d_p, getinl2d_p
+END INTERFACE
+!-
+CONTAINS
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!   Definition des getin -> bcast      !!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+!! -- Les chaines de caracteres -- !!
+  
+  SUBROUTINE getincs_p(VarIn,VarOut)
+    IMPLICIT NONE    
+    CHARACTER(LEN=*),INTENT(IN) :: VarIn
+    CHARACTER(LEN=*),INTENT(INOUT) :: VarOut    
+
+!$OMP BARRIER
+    IF (is_mpi_root .AND. is_omp_root) THEN
+    	CALL getin(VarIn,VarOut)
+    ENDIF
+    CALL bcast(VarOut)
+  END SUBROUTINE getincs_p
+
+!! -- Les entiers -- !!
+  
+  SUBROUTINE getinis_p(VarIn,VarOut)
+    IMPLICIT NONE    
+    CHARACTER(LEN=*),INTENT(IN) :: VarIn
+    INTEGER,INTENT(INOUT) :: VarOut    
+
+!$OMP BARRIER
+    IF (is_mpi_root .AND. is_omp_root) THEN
+    	CALL getin(VarIn,VarOut)
+    ENDIF
+    CALL bcast(VarOut)
+  END SUBROUTINE getinis_p
+
+  SUBROUTINE getini1d_p(VarIn,VarOut)
+    IMPLICIT NONE    
+    CHARACTER(LEN=*),INTENT(IN) :: VarIn
+    INTEGER,INTENT(INOUT) :: VarOut(:)
+
+!$OMP BARRIER
+    IF (is_mpi_root .AND. is_omp_root) THEN
+    	CALL getin(VarIn,VarOut)
+    ENDIF
+    CALL bcast(VarOut)
+  END SUBROUTINE getini1d_p
+
+  SUBROUTINE getini2d_p(VarIn,VarOut)
+    IMPLICIT NONE    
+    CHARACTER(LEN=*),INTENT(IN) :: VarIn
+    INTEGER,INTENT(INOUT) :: VarOut(:,:)
+
+!$OMP BARRIER
+    IF (is_mpi_root .AND. is_omp_root) THEN
+    	CALL getin(VarIn,VarOut)
+    ENDIF
+    CALL bcast(VarOut)
+  END SUBROUTINE getini2d_p
+
+!! -- Les flottants -- !!
+  
+  SUBROUTINE getinrs_p(VarIn,VarOut)
+    IMPLICIT NONE    
+    CHARACTER(LEN=*),INTENT(IN) :: VarIn
+    REAL,INTENT(INOUT) :: VarOut
+
+!$OMP BARRIER
+    IF (is_mpi_root .AND. is_omp_root) THEN
+    	CALL getin(VarIn,VarOut)
+    ENDIF
+    CALL bcast(VarOut)
+  END SUBROUTINE getinrs_p
+
+  SUBROUTINE getinr1d_p(VarIn,VarOut)
+    IMPLICIT NONE    
+    CHARACTER(LEN=*),INTENT(IN) :: VarIn
+    REAL,INTENT(INOUT) :: VarOut(:)
+
+!$OMP BARRIER
+    IF (is_mpi_root .AND. is_omp_root) THEN
+    	CALL getin(VarIn,VarOut)
+    ENDIF
+    CALL bcast(VarOut)
+  END SUBROUTINE getinr1d_p
+
+  SUBROUTINE getinr2d_p(VarIn,VarOut)
+    IMPLICIT NONE    
+    CHARACTER(LEN=*),INTENT(IN) :: VarIn
+    REAL,INTENT(INOUT) :: VarOut(:,:)
+
+!$OMP BARRIER
+    IF (is_mpi_root .AND. is_omp_root) THEN
+    	CALL getin(VarIn,VarOut)
+    ENDIF
+    CALL bcast(VarOut)
+  END SUBROUTINE getinr2d_p
+
+!! -- Les Booleens -- !!
+  
+  SUBROUTINE getinls_p(VarIn,VarOut)
+    IMPLICIT NONE    
+    CHARACTER(LEN=*),INTENT(IN) :: VarIn
+    LOGICAL,INTENT(INOUT) :: VarOut
+
+!$OMP BARRIER
+    IF (is_mpi_root .AND. is_omp_root) THEN
+    	CALL getin(VarIn,VarOut)
+    ENDIF
+    CALL bcast(VarOut)
+  END SUBROUTINE getinls_p
+
+  SUBROUTINE getinl1d_p(VarIn,VarOut)
+    IMPLICIT NONE    
+    CHARACTER(LEN=*),INTENT(IN) :: VarIn
+    LOGICAL,INTENT(INOUT) :: VarOut(:)
+
+!$OMP BARRIER
+    IF (is_mpi_root .AND. is_omp_root) THEN
+    	CALL getin(VarIn,VarOut)
+    ENDIF
+    CALL bcast(VarOut)
+  END SUBROUTINE getinl1d_p
+
+  SUBROUTINE getinl2d_p(VarIn,VarOut)
+    IMPLICIT NONE    
+    CHARACTER(LEN=*),INTENT(IN) :: VarIn
+    LOGICAL,INTENT(INOUT) :: VarOut(:,:)
+
+!$OMP BARRIER
+    IF (is_mpi_root .AND. is_omp_root) THEN
+    	CALL getin(VarIn,VarOut)
+    ENDIF
+    CALL bcast(VarOut)
+  END SUBROUTINE getinl2d_p
+!-
+!-----------------------------
+!-----------------------------
+!-----------------------------
+
+END MODULE ioipsl_getin_p_mod
+
Index: DZ6/trunk/libf/phy_common/mod_grid_phy_lmdz.F90
===================================================================
--- /LMDZ6/trunk/libf/phy_common/mod_grid_phy_lmdz.F90	(revision 5267)
+++ 	(revision )
@@ -1,468 +1,0 @@
-!
-!$Id $
-!
-MODULE mod_grid_phy_lmdz
-
-  PUBLIC
-  PRIVATE :: grid1dTo2d_glo_igen, grid1dTo2d_glo_rgen, grid1dTo2d_glo_lgen, &
-             grid2dTo1d_glo_igen, grid2dTo1d_glo_rgen, grid2dTo1d_glo_lgen
-  
-  INTEGER,PARAMETER :: unstructured=0
-  INTEGER,PARAMETER :: regular_lonlat=1
-
-  INTEGER,SAVE :: grid_type
-  INTEGER,SAVE :: nvertex
-  INTEGER,SAVE :: nbp_lon  ! == iim
-  INTEGER,SAVE :: nbp_lat  ! == jjmp1 (or == 1 if running 1D model)
-  INTEGER,SAVE :: nbp_lev  ! == llm
-  INTEGER,SAVE :: klon_glo ! total number of atmospheric columns
-
-  INTERFACE grid1dTo2d_glo
-    MODULE PROCEDURE grid1dTo2d_glo_i,grid1dTo2d_glo_i1,grid1dTo2d_glo_i2,grid1dTo2d_glo_i3, &
-                     grid1dTo2d_glo_r,grid1dTo2d_glo_r1,grid1dTo2d_glo_r2,grid1dTo2d_glo_r3, &
-		     grid1dTo2d_glo_l,grid1dTo2d_glo_l1,grid1dTo2d_glo_l2,grid1dTo2d_glo_l3
-   END INTERFACE 
-
-   INTERFACE grid2dTo1d_glo
-    MODULE PROCEDURE grid2dTo1d_glo_i,grid2dTo1d_glo_i1,grid2dTo1d_glo_i2,grid2dTo1d_glo_i3, &
-                     grid2dTo1d_glo_r,grid2dTo1d_glo_r1,grid2dTo1d_glo_r2,grid2dTo1d_glo_r3, &
-		     grid2dTo1d_glo_l,grid2dTo1d_glo_l1,grid2dTo1d_glo_l2,grid2dTo1d_glo_l3
-   END INTERFACE 
- 
-CONTAINS
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!! SUBROUTINE grid1dTo2d  !!  
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-
-  SUBROUTINE init_grid_phy_lmdz(grid_type_,nvertex_,nbp_lon_,nbp_lat_,nbp_lev_)
-  IMPLICIT NONE
-  INTEGER,INTENT(IN)  :: grid_type_ 
-  INTEGER,INTENT(IN)  :: nvertex_ 
-  INTEGER, INTENT(IN) :: nbp_lon_
-  INTEGER, INTENT(IN) :: nbp_lat_
-  INTEGER, INTENT(IN) :: nbp_lev_
-  
-    grid_type = grid_type_
-    nvertex   = nvertex_
-    nbp_lon   = nbp_lon_
-    nbp_lat   = nbp_lat_
-    nbp_lev   = nbp_lev_
-    
-    IF (nbp_lon*nbp_lat==1) THEN
-      klon_glo=1
-    ELSE    
-      klon_glo=(nbp_lon*nbp_lat)-2*(nbp_lon-1)
-    ENDIF
-  
-  END SUBROUTINE init_grid_phy_lmdz
-  
-  
-  SUBROUTINE grid1dTo2d_glo_i(VarIn,VarOut)  
-  IMPLICIT NONE  
-    INTEGER,INTENT(IN),DIMENSION(:)     :: VarIn
-    INTEGER,INTENT(OUT),DIMENSION(:,:)  :: VarOut
-    
-    CALL grid1dTo2d_glo_igen(VarIn,VarOut,1)
-  
-  END SUBROUTINE grid1dTo2d_glo_i
-  
-
-  SUBROUTINE grid1dTo2d_glo_i1(VarIn,VarOut)  
-  IMPLICIT NONE  
-    INTEGER,INTENT(IN),DIMENSION(:,:)     :: VarIn
-    INTEGER,INTENT(OUT),DIMENSION(:,:,:)  :: VarOut
-    
-    CALL grid1dTo2d_glo_igen(VarIn,VarOut,size(VarIn,2))
-  
-  END SUBROUTINE grid1dTo2d_glo_i1
-
-  SUBROUTINE grid1dTo2d_glo_i2(VarIn,VarOut)  
-  IMPLICIT NONE  
-    INTEGER,INTENT(IN),DIMENSION(:,:,:)     :: VarIn
-    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:)  :: VarOut
-    
-    CALL grid1dTo2d_glo_igen(VarIn,VarOut,size(VarIn,2)*size(VarIn,3))
-  
-  END SUBROUTINE grid1dTo2d_glo_i2
-  
-  SUBROUTINE grid1dTo2d_glo_i3(VarIn,VarOut)  
-  IMPLICIT NONE  
-    INTEGER,INTENT(IN),DIMENSION(:,:,:,:)     :: VarIn
-    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:,:)  :: VarOut
-    
-    CALL grid1dTo2d_glo_igen(VarIn,VarOut,size(VarIn,2)*size(VarIn,3)*size(VarIn,4))
-  
-  END SUBROUTINE grid1dTo2d_glo_i3
-
-
-  SUBROUTINE grid1dTo2d_glo_r(VarIn,VarOut)  
-  IMPLICIT NONE  
-    REAL,INTENT(IN),DIMENSION(:)     :: VarIn
-    REAL,INTENT(OUT),DIMENSION(:,:)  :: VarOut
-    
-    CALL grid1dTo2d_glo_rgen(VarIn,VarOut,1)
-  
-  END SUBROUTINE grid1dTo2d_glo_r
-  
-
-  SUBROUTINE grid1dTo2d_glo_r1(VarIn,VarOut)  
-  IMPLICIT NONE  
-    REAL,INTENT(IN),DIMENSION(:,:)     :: VarIn
-    REAL,INTENT(OUT),DIMENSION(:,:,:)  :: VarOut
-    
-    CALL grid1dTo2d_glo_rgen(VarIn,VarOut,size(VarIn,2))
-  
-  END SUBROUTINE grid1dTo2d_glo_r1
-
-  SUBROUTINE grid1dTo2d_glo_r2(VarIn,VarOut)  
-  IMPLICIT NONE  
-    REAL,INTENT(IN),DIMENSION(:,:,:)     :: VarIn
-    REAL,INTENT(OUT),DIMENSION(:,:,:,:)  :: VarOut
-    
-    CALL grid1dTo2d_glo_rgen(VarIn,VarOut,size(VarIn,2)*size(VarIn,3))
-  
-  END SUBROUTINE grid1dTo2d_glo_r2
-  
-  SUBROUTINE grid1dTo2d_glo_r3(VarIn,VarOut)  
-  IMPLICIT NONE  
-    REAL,INTENT(IN),DIMENSION(:,:,:,:)     :: VarIn
-    REAL,INTENT(OUT),DIMENSION(:,:,:,:,:)  :: VarOut
-    
-    CALL grid1dTo2d_glo_rgen(VarIn,VarOut,size(VarIn,2)*size(VarIn,3)*size(VarIn,4))
-  
-  END SUBROUTINE grid1dTo2d_glo_r3
-  
-  
-  
-  SUBROUTINE grid1dTo2d_glo_l(VarIn,VarOut)  
-  IMPLICIT NONE  
-    LOGICAL,INTENT(IN),DIMENSION(:)     :: VarIn
-    LOGICAL,INTENT(OUT),DIMENSION(:,:)  :: VarOut
-    
-    CALL grid1dTo2d_glo_lgen(VarIn,VarOut,1)
-  
-  END SUBROUTINE grid1dTo2d_glo_l
-  
-
-  SUBROUTINE grid1dTo2d_glo_l1(VarIn,VarOut)  
-  IMPLICIT NONE  
-    LOGICAL,INTENT(IN),DIMENSION(:,:)     :: VarIn
-    LOGICAL,INTENT(OUT),DIMENSION(:,:,:)  :: VarOut
-    
-    CALL grid1dTo2d_glo_lgen(VarIn,VarOut,size(VarIn,2))
-  
-  END SUBROUTINE grid1dTo2d_glo_l1
-
-  SUBROUTINE grid1dTo2d_glo_l2(VarIn,VarOut)  
-  IMPLICIT NONE  
-    LOGICAL,INTENT(IN),DIMENSION(:,:,:)     :: VarIn
-    LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:)  :: VarOut
-    
-    CALL grid1dTo2d_glo_lgen(VarIn,VarOut,size(VarIn,2)*size(VarIn,3))
-  
-  END SUBROUTINE grid1dTo2d_glo_l2
-  
-  SUBROUTINE grid1dTo2d_glo_l3(VarIn,VarOut)  
-  IMPLICIT NONE  
-    LOGICAL,INTENT(IN),DIMENSION(:,:,:,:)     :: VarIn
-    LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:,:)  :: VarOut
-    
-    CALL grid1dTo2d_glo_lgen(VarIn,VarOut,size(VarIn,2)*size(VarIn,3)*size(VarIn,4))
-  
-  END SUBROUTINE grid1dTo2d_glo_l3  
-  
-    SUBROUTINE grid2dTo1d_glo_i(VarIn,VarOut)  
-  IMPLICIT NONE  
-    INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn
-    INTEGER,INTENT(OUT),DIMENSION(:)  :: VarOut
-    
-    CALL grid2dTo1d_glo_igen(VarIn,VarOut,1)
-  
-  END SUBROUTINE grid2dTo1d_glo_i
-  
-
-  SUBROUTINE grid2dTo1d_glo_i1(VarIn,VarOut)  
-  IMPLICIT NONE  
-    INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn
-    INTEGER,INTENT(OUT),DIMENSION(:,:)  :: VarOut
-    
-    CALL grid2dTo1d_glo_igen(VarIn,VarOut,size(VarIn,3))
-  
-  END SUBROUTINE grid2dTo1d_glo_i1
-
-  SUBROUTINE grid2dTo1d_glo_i2(VarIn,VarOut)  
-  IMPLICIT NONE  
-    INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
-    INTEGER,INTENT(OUT),DIMENSION(:,:,:)  :: VarOut
-    
-    CALL grid2dTo1d_glo_igen(VarIn,VarOut,size(VarIn,3)*size(VarIn,4))
-  
-  END SUBROUTINE grid2dTo1d_glo_i2
-  
-  SUBROUTINE grid2dTo1d_glo_i3(VarIn,VarOut)  
-  IMPLICIT NONE  
-    INTEGER,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn
-    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:)  :: VarOut
-    
-    CALL grid2dTo1d_glo_igen(VarIn,VarOut,size(VarIn,3)*size(VarIn,4)*size(VarIn,5))
-  
-  END SUBROUTINE grid2dTo1d_glo_i3
- 
-
-
-
-  SUBROUTINE grid2dTo1d_glo_r(VarIn,VarOut)  
-  IMPLICIT NONE  
-    REAL,INTENT(IN),DIMENSION(:,:) :: VarIn
-    REAL,INTENT(OUT),DIMENSION(:)  :: VarOut
-    
-    CALL grid2dTo1d_glo_rgen(VarIn,VarOut,1)
-  
-  END SUBROUTINE grid2dTo1d_glo_r
-  
-
-  SUBROUTINE grid2dTo1d_glo_r1(VarIn,VarOut)  
-  IMPLICIT NONE  
-    REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
-    REAL,INTENT(OUT),DIMENSION(:,:)  :: VarOut
-    
-    CALL grid2dTo1d_glo_rgen(VarIn,VarOut,size(VarIn,3))
-  
-  END SUBROUTINE grid2dTo1d_glo_r1
-
-  SUBROUTINE grid2dTo1d_glo_r2(VarIn,VarOut)  
-  IMPLICIT NONE  
-    REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
-    REAL,INTENT(OUT),DIMENSION(:,:,:)  :: VarOut
-    
-    CALL grid2dTo1d_glo_rgen(VarIn,VarOut,size(VarIn,3)*size(VarIn,4))
-  
-  END SUBROUTINE grid2dTo1d_glo_r2
-  
-  SUBROUTINE grid2dTo1d_glo_r3(VarIn,VarOut)  
-  IMPLICIT NONE  
-    REAL,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn
-    REAL,INTENT(OUT),DIMENSION(:,:,:,:)  :: VarOut
-    
-    CALL grid2dTo1d_glo_rgen(VarIn,VarOut,size(VarIn,3)*size(VarIn,4)*size(VarIn,5))
-  
-  END SUBROUTINE grid2dTo1d_glo_r3
-
-
-
-  SUBROUTINE grid2dTo1d_glo_l(VarIn,VarOut)  
-  IMPLICIT NONE  
-    LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn
-    LOGICAL,INTENT(OUT),DIMENSION(:)  :: VarOut
-    
-    CALL grid2dTo1d_glo_lgen(VarIn,VarOut,1)
-  
-  END SUBROUTINE grid2dTo1d_glo_l
-  
-
-  SUBROUTINE grid2dTo1d_glo_l1(VarIn,VarOut)  
-  IMPLICIT NONE  
-    LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
-    LOGICAL,INTENT(OUT),DIMENSION(:,:)  :: VarOut
-    
-    CALL grid2dTo1d_glo_lgen(VarIn,VarOut,size(VarIn,3))
-  
-  END SUBROUTINE grid2dTo1d_glo_l1
-
-  SUBROUTINE grid2dTo1d_glo_l2(VarIn,VarOut)  
-  IMPLICIT NONE  
-    LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
-    LOGICAL,INTENT(OUT),DIMENSION(:,:,:)  :: VarOut
-    
-    CALL grid2dTo1d_glo_lgen(VarIn,VarOut,size(VarIn,3)*size(VarIn,4))
-  
-  END SUBROUTINE grid2dTo1d_glo_l2
-  
-  SUBROUTINE grid2dTo1d_glo_l3(VarIn,VarOut)  
-  IMPLICIT NONE  
-    LOGICAL,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn
-    LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:)  :: VarOut
-    
-    CALL grid2dTo1d_glo_lgen(VarIn,VarOut,size(VarIn,3)*size(VarIn,4)*size(VarIn,5))
-  
-  END SUBROUTINE grid2dTo1d_glo_l3
-
-!---------------------------------------------------------------- 
-!  Generic (private) fonctions
-!---------------------------------------------------------------- 
-  
-  SUBROUTINE grid1dTo2d_glo_igen(VarIn,VarOut,dimsize)
-
-    IMPLICIT NONE
-
-    INTEGER,INTENT(IN) :: dimsize
-    INTEGER,INTENT(IN) ,DIMENSION(klon_glo,dimsize)       :: VarIn
-    INTEGER,INTENT(OUT),DIMENSION(nbp_lon*nbp_lat,dimsize)  :: VarOut
-    INTEGER :: i,ij,Offset
-
-    
-    Offset=nbp_lon
-        
-    DO i=1,dimsize
-      DO ij=1,klon_glo
-        VarOut(ij+offset-1,i)=VarIn(ij,i)
-      ENDDO
-    ENDDO
-    
-    
-    DO i=1,dimsize
-      DO ij=1,nbp_lon
-       VarOut(ij,i)=VarIn(1,i)
-      ENDDO
-    ENDDO
-    
-    
-    DO i=1,dimsize
-      DO ij=nbp_lon*(nbp_lat-1)+1,nbp_lat*nbp_lon
-       VarOut(ij,i)=VarIn(klon_glo,i)
-      ENDDO
-    ENDDO
-
-  END SUBROUTINE grid1dTo2d_glo_igen   
-
-
-  SUBROUTINE grid1dTo2d_glo_rgen(VarIn,VarOut,dimsize)
-
-    IMPLICIT NONE
-
-    INTEGER,INTENT(IN) :: dimsize
-    REAL,INTENT(IN) ,DIMENSION(klon_glo,dimsize)       :: VarIn
-    REAL,INTENT(OUT),DIMENSION(nbp_lon*nbp_lat,dimsize)  :: VarOut
-    INTEGER :: i,ij,Offset
-
-   
-    Offset=nbp_lon
-        
-    DO i=1,dimsize
-      DO ij=1,klon_glo
-        VarOut(ij+offset-1,i)=VarIn(ij,i)
-      ENDDO
-    ENDDO
-    
-    
-    DO i=1,dimsize
-      DO ij=1,nbp_lon
-       VarOut(ij,i)=VarIn(1,i)
-      ENDDO
-    ENDDO
-    
-    
-    DO i=1,dimsize
-      DO ij=nbp_lon*(nbp_lat-1)+1,nbp_lat*nbp_lon
-       VarOut(ij,i)=VarIn(klon_glo,i)
-      ENDDO
-    ENDDO
-
-  END SUBROUTINE grid1dTo2d_glo_rgen   
-
-  SUBROUTINE grid1dTo2d_glo_lgen(VarIn,VarOut,dimsize)
-
-    IMPLICIT NONE
-    
-    INTEGER,INTENT(IN) :: dimsize
-    LOGICAL,INTENT(IN) ,DIMENSION(klon_glo,dimsize)       :: VarIn
-    LOGICAL,INTENT(OUT),DIMENSION(nbp_lon*nbp_lat,dimsize)  :: VarOut
-    INTEGER :: i,ij,Offset
-
-    Offset=nbp_lon
-        
-    DO i=1,dimsize
-      DO ij=1,klon_glo
-        VarOut(ij+offset-1,i)=VarIn(ij,i)
-      ENDDO
-    ENDDO
-    
-    
-    DO i=1,dimsize
-      DO ij=1,nbp_lon
-       VarOut(ij,i)=VarIn(1,i)
-      ENDDO
-    ENDDO
-    
-    
-    DO i=1,dimsize
-      DO ij=nbp_lon*(nbp_lat-1)+1,nbp_lat*nbp_lon
-       VarOut(ij,i)=VarIn(klon_glo,i)
-      ENDDO
-    ENDDO
-
-  END SUBROUTINE grid1dTo2d_glo_lgen     
-  
-  
-  SUBROUTINE grid2dTo1d_glo_igen(VarIn,VarOut,dimsize)
-
-    IMPLICIT NONE
-
-    INTEGER,INTENT(IN) :: dimsize
-    INTEGER,INTENT(IN) ,DIMENSION(nbp_lon*nbp_lat,dimsize) :: VarIn
-    INTEGER,INTENT(OUT),DIMENSION(klon_glo,dimsize)      :: VarOut
-    INTEGER :: i,ij,offset
-
-    offset=nbp_lon
-
-    DO i=1,dimsize
-      DO ij=1,klon_glo
-        VarOut(ij,i)=VarIn(ij+offset-1,i)
-      ENDDO
-    ENDDO
-
-    DO i=1,dimsize
-      VarOut(1,i)=VarIn(1,i)
-    ENDDO
-    
-  END SUBROUTINE grid2dTo1d_glo_igen   
-  
-  SUBROUTINE grid2dTo1d_glo_rgen(VarIn,VarOut,dimsize)
-
-    IMPLICIT NONE
-
-    INTEGER,INTENT(IN) :: dimsize
-    REAL,INTENT(IN) ,DIMENSION(nbp_lon*nbp_lat,dimsize) :: VarIn
-    REAL,INTENT(OUT),DIMENSION(klon_glo,dimsize)      :: VarOut
-    INTEGER :: i,ij,offset
-
-    offset=nbp_lon
-
-    DO i=1,dimsize
-      DO ij=1,klon_glo
-        VarOut(ij,i)=VarIn(ij+offset-1,i)
-      ENDDO
-    ENDDO
-
-    DO i=1,dimsize
-      VarOut(1,i)=VarIn(1,i)
-    ENDDO
-    
-  END SUBROUTINE grid2dTo1d_glo_rgen 
-    
-  SUBROUTINE grid2dTo1d_glo_lgen(VarIn,VarOut,dimsize)
-
-    IMPLICIT NONE
-
-    INTEGER,INTENT(IN) :: dimsize
-    LOGICAL,INTENT(IN) ,DIMENSION(nbp_lon*nbp_lat,dimsize) :: VarIn
-    LOGICAL,INTENT(OUT),DIMENSION(klon_glo,dimsize)      :: VarOut
-    INTEGER :: i,ij,offset
-
-    offset=nbp_lon
-
-    DO i=1,dimsize
-      DO ij=1,klon_glo
-        VarOut(ij,i)=VarIn(ij+offset-1,i)
-      ENDDO
-    ENDDO
-
-    DO i=1,dimsize
-      VarOut(1,i)=VarIn(1,i)
-    ENDDO
-    
-  END SUBROUTINE grid2dTo1d_glo_lgen   
-
-END MODULE mod_grid_phy_lmdz
Index: /LMDZ6/trunk/libf/phy_common/mod_grid_phy_lmdz.f90
===================================================================
--- /LMDZ6/trunk/libf/phy_common/mod_grid_phy_lmdz.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phy_common/mod_grid_phy_lmdz.f90	(revision 5268)
@@ -0,0 +1,468 @@
+!
+!$Id $
+!
+MODULE mod_grid_phy_lmdz
+
+  PUBLIC
+  PRIVATE :: grid1dTo2d_glo_igen, grid1dTo2d_glo_rgen, grid1dTo2d_glo_lgen, &
+             grid2dTo1d_glo_igen, grid2dTo1d_glo_rgen, grid2dTo1d_glo_lgen
+  
+  INTEGER,PARAMETER :: unstructured=0
+  INTEGER,PARAMETER :: regular_lonlat=1
+
+  INTEGER,SAVE :: grid_type
+  INTEGER,SAVE :: nvertex
+  INTEGER,SAVE :: nbp_lon  ! == iim
+  INTEGER,SAVE :: nbp_lat  ! == jjmp1 (or == 1 if running 1D model)
+  INTEGER,SAVE :: nbp_lev  ! == llm
+  INTEGER,SAVE :: klon_glo ! total number of atmospheric columns
+
+  INTERFACE grid1dTo2d_glo
+    MODULE PROCEDURE grid1dTo2d_glo_i,grid1dTo2d_glo_i1,grid1dTo2d_glo_i2,grid1dTo2d_glo_i3, &
+                     grid1dTo2d_glo_r,grid1dTo2d_glo_r1,grid1dTo2d_glo_r2,grid1dTo2d_glo_r3, &
+		     grid1dTo2d_glo_l,grid1dTo2d_glo_l1,grid1dTo2d_glo_l2,grid1dTo2d_glo_l3
+   END INTERFACE 
+
+   INTERFACE grid2dTo1d_glo
+    MODULE PROCEDURE grid2dTo1d_glo_i,grid2dTo1d_glo_i1,grid2dTo1d_glo_i2,grid2dTo1d_glo_i3, &
+                     grid2dTo1d_glo_r,grid2dTo1d_glo_r1,grid2dTo1d_glo_r2,grid2dTo1d_glo_r3, &
+		     grid2dTo1d_glo_l,grid2dTo1d_glo_l1,grid2dTo1d_glo_l2,grid2dTo1d_glo_l3
+   END INTERFACE 
+ 
+CONTAINS
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! SUBROUTINE grid1dTo2d  !!  
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+
+  SUBROUTINE init_grid_phy_lmdz(grid_type_,nvertex_,nbp_lon_,nbp_lat_,nbp_lev_)
+  IMPLICIT NONE
+  INTEGER,INTENT(IN)  :: grid_type_ 
+  INTEGER,INTENT(IN)  :: nvertex_ 
+  INTEGER, INTENT(IN) :: nbp_lon_
+  INTEGER, INTENT(IN) :: nbp_lat_
+  INTEGER, INTENT(IN) :: nbp_lev_
+  
+    grid_type = grid_type_
+    nvertex   = nvertex_
+    nbp_lon   = nbp_lon_
+    nbp_lat   = nbp_lat_
+    nbp_lev   = nbp_lev_
+    
+    IF (nbp_lon*nbp_lat==1) THEN
+      klon_glo=1
+    ELSE    
+      klon_glo=(nbp_lon*nbp_lat)-2*(nbp_lon-1)
+    ENDIF
+  
+  END SUBROUTINE init_grid_phy_lmdz
+  
+  
+  SUBROUTINE grid1dTo2d_glo_i(VarIn,VarOut)  
+  IMPLICIT NONE  
+    INTEGER,INTENT(IN),DIMENSION(:)     :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:)  :: VarOut
+    
+    CALL grid1dTo2d_glo_igen(VarIn,VarOut,1)
+  
+  END SUBROUTINE grid1dTo2d_glo_i
+  
+
+  SUBROUTINE grid1dTo2d_glo_i1(VarIn,VarOut)  
+  IMPLICIT NONE  
+    INTEGER,INTENT(IN),DIMENSION(:,:)     :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:)  :: VarOut
+    
+    CALL grid1dTo2d_glo_igen(VarIn,VarOut,size(VarIn,2))
+  
+  END SUBROUTINE grid1dTo2d_glo_i1
+
+  SUBROUTINE grid1dTo2d_glo_i2(VarIn,VarOut)  
+  IMPLICIT NONE  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:)     :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:)  :: VarOut
+    
+    CALL grid1dTo2d_glo_igen(VarIn,VarOut,size(VarIn,2)*size(VarIn,3))
+  
+  END SUBROUTINE grid1dTo2d_glo_i2
+  
+  SUBROUTINE grid1dTo2d_glo_i3(VarIn,VarOut)  
+  IMPLICIT NONE  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:,:)     :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:,:)  :: VarOut
+    
+    CALL grid1dTo2d_glo_igen(VarIn,VarOut,size(VarIn,2)*size(VarIn,3)*size(VarIn,4))
+  
+  END SUBROUTINE grid1dTo2d_glo_i3
+
+
+  SUBROUTINE grid1dTo2d_glo_r(VarIn,VarOut)  
+  IMPLICIT NONE  
+    REAL,INTENT(IN),DIMENSION(:)     :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:)  :: VarOut
+    
+    CALL grid1dTo2d_glo_rgen(VarIn,VarOut,1)
+  
+  END SUBROUTINE grid1dTo2d_glo_r
+  
+
+  SUBROUTINE grid1dTo2d_glo_r1(VarIn,VarOut)  
+  IMPLICIT NONE  
+    REAL,INTENT(IN),DIMENSION(:,:)     :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:)  :: VarOut
+    
+    CALL grid1dTo2d_glo_rgen(VarIn,VarOut,size(VarIn,2))
+  
+  END SUBROUTINE grid1dTo2d_glo_r1
+
+  SUBROUTINE grid1dTo2d_glo_r2(VarIn,VarOut)  
+  IMPLICIT NONE  
+    REAL,INTENT(IN),DIMENSION(:,:,:)     :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:,:)  :: VarOut
+    
+    CALL grid1dTo2d_glo_rgen(VarIn,VarOut,size(VarIn,2)*size(VarIn,3))
+  
+  END SUBROUTINE grid1dTo2d_glo_r2
+  
+  SUBROUTINE grid1dTo2d_glo_r3(VarIn,VarOut)  
+  IMPLICIT NONE  
+    REAL,INTENT(IN),DIMENSION(:,:,:,:)     :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:,:,:)  :: VarOut
+    
+    CALL grid1dTo2d_glo_rgen(VarIn,VarOut,size(VarIn,2)*size(VarIn,3)*size(VarIn,4))
+  
+  END SUBROUTINE grid1dTo2d_glo_r3
+  
+  
+  
+  SUBROUTINE grid1dTo2d_glo_l(VarIn,VarOut)  
+  IMPLICIT NONE  
+    LOGICAL,INTENT(IN),DIMENSION(:)     :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:)  :: VarOut
+    
+    CALL grid1dTo2d_glo_lgen(VarIn,VarOut,1)
+  
+  END SUBROUTINE grid1dTo2d_glo_l
+  
+
+  SUBROUTINE grid1dTo2d_glo_l1(VarIn,VarOut)  
+  IMPLICIT NONE  
+    LOGICAL,INTENT(IN),DIMENSION(:,:)     :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:)  :: VarOut
+    
+    CALL grid1dTo2d_glo_lgen(VarIn,VarOut,size(VarIn,2))
+  
+  END SUBROUTINE grid1dTo2d_glo_l1
+
+  SUBROUTINE grid1dTo2d_glo_l2(VarIn,VarOut)  
+  IMPLICIT NONE  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:)     :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:)  :: VarOut
+    
+    CALL grid1dTo2d_glo_lgen(VarIn,VarOut,size(VarIn,2)*size(VarIn,3))
+  
+  END SUBROUTINE grid1dTo2d_glo_l2
+  
+  SUBROUTINE grid1dTo2d_glo_l3(VarIn,VarOut)  
+  IMPLICIT NONE  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:,:)     :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:,:)  :: VarOut
+    
+    CALL grid1dTo2d_glo_lgen(VarIn,VarOut,size(VarIn,2)*size(VarIn,3)*size(VarIn,4))
+  
+  END SUBROUTINE grid1dTo2d_glo_l3  
+  
+    SUBROUTINE grid2dTo1d_glo_i(VarIn,VarOut)  
+  IMPLICIT NONE  
+    INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:)  :: VarOut
+    
+    CALL grid2dTo1d_glo_igen(VarIn,VarOut,1)
+  
+  END SUBROUTINE grid2dTo1d_glo_i
+  
+
+  SUBROUTINE grid2dTo1d_glo_i1(VarIn,VarOut)  
+  IMPLICIT NONE  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:)  :: VarOut
+    
+    CALL grid2dTo1d_glo_igen(VarIn,VarOut,size(VarIn,3))
+  
+  END SUBROUTINE grid2dTo1d_glo_i1
+
+  SUBROUTINE grid2dTo1d_glo_i2(VarIn,VarOut)  
+  IMPLICIT NONE  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:)  :: VarOut
+    
+    CALL grid2dTo1d_glo_igen(VarIn,VarOut,size(VarIn,3)*size(VarIn,4))
+  
+  END SUBROUTINE grid2dTo1d_glo_i2
+  
+  SUBROUTINE grid2dTo1d_glo_i3(VarIn,VarOut)  
+  IMPLICIT NONE  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:)  :: VarOut
+    
+    CALL grid2dTo1d_glo_igen(VarIn,VarOut,size(VarIn,3)*size(VarIn,4)*size(VarIn,5))
+  
+  END SUBROUTINE grid2dTo1d_glo_i3
+ 
+
+
+
+  SUBROUTINE grid2dTo1d_glo_r(VarIn,VarOut)  
+  IMPLICIT NONE  
+    REAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:)  :: VarOut
+    
+    CALL grid2dTo1d_glo_rgen(VarIn,VarOut,1)
+  
+  END SUBROUTINE grid2dTo1d_glo_r
+  
+
+  SUBROUTINE grid2dTo1d_glo_r1(VarIn,VarOut)  
+  IMPLICIT NONE  
+    REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:)  :: VarOut
+    
+    CALL grid2dTo1d_glo_rgen(VarIn,VarOut,size(VarIn,3))
+  
+  END SUBROUTINE grid2dTo1d_glo_r1
+
+  SUBROUTINE grid2dTo1d_glo_r2(VarIn,VarOut)  
+  IMPLICIT NONE  
+    REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:)  :: VarOut
+    
+    CALL grid2dTo1d_glo_rgen(VarIn,VarOut,size(VarIn,3)*size(VarIn,4))
+  
+  END SUBROUTINE grid2dTo1d_glo_r2
+  
+  SUBROUTINE grid2dTo1d_glo_r3(VarIn,VarOut)  
+  IMPLICIT NONE  
+    REAL,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:,:)  :: VarOut
+    
+    CALL grid2dTo1d_glo_rgen(VarIn,VarOut,size(VarIn,3)*size(VarIn,4)*size(VarIn,5))
+  
+  END SUBROUTINE grid2dTo1d_glo_r3
+
+
+
+  SUBROUTINE grid2dTo1d_glo_l(VarIn,VarOut)  
+  IMPLICIT NONE  
+    LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:)  :: VarOut
+    
+    CALL grid2dTo1d_glo_lgen(VarIn,VarOut,1)
+  
+  END SUBROUTINE grid2dTo1d_glo_l
+  
+
+  SUBROUTINE grid2dTo1d_glo_l1(VarIn,VarOut)  
+  IMPLICIT NONE  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:)  :: VarOut
+    
+    CALL grid2dTo1d_glo_lgen(VarIn,VarOut,size(VarIn,3))
+  
+  END SUBROUTINE grid2dTo1d_glo_l1
+
+  SUBROUTINE grid2dTo1d_glo_l2(VarIn,VarOut)  
+  IMPLICIT NONE  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:)  :: VarOut
+    
+    CALL grid2dTo1d_glo_lgen(VarIn,VarOut,size(VarIn,3)*size(VarIn,4))
+  
+  END SUBROUTINE grid2dTo1d_glo_l2
+  
+  SUBROUTINE grid2dTo1d_glo_l3(VarIn,VarOut)  
+  IMPLICIT NONE  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:)  :: VarOut
+    
+    CALL grid2dTo1d_glo_lgen(VarIn,VarOut,size(VarIn,3)*size(VarIn,4)*size(VarIn,5))
+  
+  END SUBROUTINE grid2dTo1d_glo_l3
+
+!---------------------------------------------------------------- 
+!  Generic (private) fonctions
+!---------------------------------------------------------------- 
+  
+  SUBROUTINE grid1dTo2d_glo_igen(VarIn,VarOut,dimsize)
+
+    IMPLICIT NONE
+
+    INTEGER,INTENT(IN) :: dimsize
+    INTEGER,INTENT(IN) ,DIMENSION(klon_glo,dimsize)       :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(nbp_lon*nbp_lat,dimsize)  :: VarOut
+    INTEGER :: i,ij,Offset
+
+    
+    Offset=nbp_lon
+        
+    DO i=1,dimsize
+      DO ij=1,klon_glo
+        VarOut(ij+offset-1,i)=VarIn(ij,i)
+      ENDDO
+    ENDDO
+    
+    
+    DO i=1,dimsize
+      DO ij=1,nbp_lon
+       VarOut(ij,i)=VarIn(1,i)
+      ENDDO
+    ENDDO
+    
+    
+    DO i=1,dimsize
+      DO ij=nbp_lon*(nbp_lat-1)+1,nbp_lat*nbp_lon
+       VarOut(ij,i)=VarIn(klon_glo,i)
+      ENDDO
+    ENDDO
+
+  END SUBROUTINE grid1dTo2d_glo_igen   
+
+
+  SUBROUTINE grid1dTo2d_glo_rgen(VarIn,VarOut,dimsize)
+
+    IMPLICIT NONE
+
+    INTEGER,INTENT(IN) :: dimsize
+    REAL,INTENT(IN) ,DIMENSION(klon_glo,dimsize)       :: VarIn
+    REAL,INTENT(OUT),DIMENSION(nbp_lon*nbp_lat,dimsize)  :: VarOut
+    INTEGER :: i,ij,Offset
+
+   
+    Offset=nbp_lon
+        
+    DO i=1,dimsize
+      DO ij=1,klon_glo
+        VarOut(ij+offset-1,i)=VarIn(ij,i)
+      ENDDO
+    ENDDO
+    
+    
+    DO i=1,dimsize
+      DO ij=1,nbp_lon
+       VarOut(ij,i)=VarIn(1,i)
+      ENDDO
+    ENDDO
+    
+    
+    DO i=1,dimsize
+      DO ij=nbp_lon*(nbp_lat-1)+1,nbp_lat*nbp_lon
+       VarOut(ij,i)=VarIn(klon_glo,i)
+      ENDDO
+    ENDDO
+
+  END SUBROUTINE grid1dTo2d_glo_rgen   
+
+  SUBROUTINE grid1dTo2d_glo_lgen(VarIn,VarOut,dimsize)
+
+    IMPLICIT NONE
+    
+    INTEGER,INTENT(IN) :: dimsize
+    LOGICAL,INTENT(IN) ,DIMENSION(klon_glo,dimsize)       :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(nbp_lon*nbp_lat,dimsize)  :: VarOut
+    INTEGER :: i,ij,Offset
+
+    Offset=nbp_lon
+        
+    DO i=1,dimsize
+      DO ij=1,klon_glo
+        VarOut(ij+offset-1,i)=VarIn(ij,i)
+      ENDDO
+    ENDDO
+    
+    
+    DO i=1,dimsize
+      DO ij=1,nbp_lon
+       VarOut(ij,i)=VarIn(1,i)
+      ENDDO
+    ENDDO
+    
+    
+    DO i=1,dimsize
+      DO ij=nbp_lon*(nbp_lat-1)+1,nbp_lat*nbp_lon
+       VarOut(ij,i)=VarIn(klon_glo,i)
+      ENDDO
+    ENDDO
+
+  END SUBROUTINE grid1dTo2d_glo_lgen     
+  
+  
+  SUBROUTINE grid2dTo1d_glo_igen(VarIn,VarOut,dimsize)
+
+    IMPLICIT NONE
+
+    INTEGER,INTENT(IN) :: dimsize
+    INTEGER,INTENT(IN) ,DIMENSION(nbp_lon*nbp_lat,dimsize) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(klon_glo,dimsize)      :: VarOut
+    INTEGER :: i,ij,offset
+
+    offset=nbp_lon
+
+    DO i=1,dimsize
+      DO ij=1,klon_glo
+        VarOut(ij,i)=VarIn(ij+offset-1,i)
+      ENDDO
+    ENDDO
+
+    DO i=1,dimsize
+      VarOut(1,i)=VarIn(1,i)
+    ENDDO
+    
+  END SUBROUTINE grid2dTo1d_glo_igen   
+  
+  SUBROUTINE grid2dTo1d_glo_rgen(VarIn,VarOut,dimsize)
+
+    IMPLICIT NONE
+
+    INTEGER,INTENT(IN) :: dimsize
+    REAL,INTENT(IN) ,DIMENSION(nbp_lon*nbp_lat,dimsize) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(klon_glo,dimsize)      :: VarOut
+    INTEGER :: i,ij,offset
+
+    offset=nbp_lon
+
+    DO i=1,dimsize
+      DO ij=1,klon_glo
+        VarOut(ij,i)=VarIn(ij+offset-1,i)
+      ENDDO
+    ENDDO
+
+    DO i=1,dimsize
+      VarOut(1,i)=VarIn(1,i)
+    ENDDO
+    
+  END SUBROUTINE grid2dTo1d_glo_rgen 
+    
+  SUBROUTINE grid2dTo1d_glo_lgen(VarIn,VarOut,dimsize)
+
+    IMPLICIT NONE
+
+    INTEGER,INTENT(IN) :: dimsize
+    LOGICAL,INTENT(IN) ,DIMENSION(nbp_lon*nbp_lat,dimsize) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(klon_glo,dimsize)      :: VarOut
+    INTEGER :: i,ij,offset
+
+    offset=nbp_lon
+
+    DO i=1,dimsize
+      DO ij=1,klon_glo
+        VarOut(ij,i)=VarIn(ij+offset-1,i)
+      ENDDO
+    ENDDO
+
+    DO i=1,dimsize
+      VarOut(1,i)=VarIn(1,i)
+    ENDDO
+    
+  END SUBROUTINE grid2dTo1d_glo_lgen   
+
+END MODULE mod_grid_phy_lmdz
Index: DZ6/trunk/libf/phy_common/mod_phys_lmdz_mpi_data.F90
===================================================================
--- /LMDZ6/trunk/libf/phy_common/mod_phys_lmdz_mpi_data.F90	(revision 5267)
+++ 	(revision )
@@ -1,222 +1,0 @@
-!
-!$Id$
-!
-MODULE mod_phys_lmdz_mpi_data
-  USE lmdz_mpi
-  USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_INCA
-
-  INTEGER,SAVE :: ii_begin
-  INTEGER,SAVE :: ii_end
-  INTEGER,SAVE :: jj_begin
-  INTEGER,SAVE :: jj_end
-  INTEGER,SAVE :: jj_nb
-  INTEGER,SAVE :: ij_begin
-  INTEGER,SAVE :: ij_end
-  INTEGER,SAVE :: ij_nb
-  INTEGER,SAVE :: klon_mpi_begin
-  INTEGER,SAVE :: klon_mpi_end
-  INTEGER,SAVE :: klon_mpi
-  
-  INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: jj_para_nb
-  INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: jj_para_begin
-  INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: jj_para_end
-
-  INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: ii_para_begin
-  INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: ii_para_end
-
-  INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: ij_para_nb
-  INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: ij_para_begin
-  INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: ij_para_end
-
-  INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: klon_mpi_para_nb
-  INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: klon_mpi_para_begin
-  INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: klon_mpi_para_end 
-
-  
-  INTEGER,SAVE :: mpi_rank
-  INTEGER,SAVE :: mpi_size
-  INTEGER,SAVE :: mpi_master
-  LOGICAL,SAVE :: is_mpi_root
-  LOGICAL,SAVE :: is_using_mpi
-  
-  
-  LOGICAL,SAVE :: is_north_pole_dyn
-  LOGICAL,SAVE :: is_south_pole_dyn
-  INTEGER,SAVE :: COMM_LMDZ_PHY
-  INTEGER,SAVE :: MPI_REAL_LMDZ   ! MPI_REAL8
-
-CONTAINS
-  
-  SUBROUTINE init_phys_lmdz_mpi_data(nbp, nbp_lon, nbp_lat, nbp_lev, grid_type, nvertex, communicator)
-  USE lmdz_mpi
-  IMPLICIT NONE
-    INTEGER,INTENT(IN) :: nbp
-    INTEGER,INTENT(IN) :: nbp_lon
-    INTEGER,INTENT(IN) :: nbp_lat
-    INTEGER,INTENT(IN) :: nbp_lev
-    INTEGER,INTENT(IN) :: communicator
-    INTEGER,INTENT(IN) :: grid_type 
-    INTEGER,INTENT(IN) :: nvertex 
-    
-    INTEGER,ALLOCATABLE :: distrib(:)
-    INTEGER :: ierr
-    INTEGER :: klon_glo
-    INTEGER :: i
-    
-    is_using_mpi = using_mpi
-    
-    if ((nbp_lon.eq.1).and.(nbp_lat.eq.1)) then ! running 1D column model
-       klon_glo=1
-    else
-    ! The usual global physics grid: 1 point for each pole and nbp_lon points
-    ! for all other latitudes
-       klon_glo=nbp_lon*(nbp_lat-2)+2
-    endif
-    
-    COMM_LMDZ_PHY=communicator
-
-    IF (is_using_mpi) THEN    
-      MPI_REAL_LMDZ=MPI_REAL8
-      CALL MPI_COMM_SIZE(COMM_LMDZ_PHY,mpi_size,ierr)    
-      CALL MPI_COMM_RANK(COMM_LMDZ_PHY,mpi_rank,ierr)
-    ELSE
-      mpi_size=1
-      mpi_rank=0
-    ENDIF
-    
-    ALLOCATE(distrib(0:mpi_size-1))
-
-    IF (is_using_mpi) THEN    
-      CALL MPI_ALLGATHER(nbp,1,MPI_INTEGER,distrib,1,MPI_INTEGER,COMM_LMDZ_PHY,ierr)
-    ELSE
-     distrib(:)=nbp
-    ENDIF
-
-
-    IF (mpi_rank == 0) THEN
-      mpi_master = 0
-      is_mpi_root = .true.
-    ENDIF
-    
-    IF (mpi_rank == 0) THEN 
-      is_north_pole_dyn = .TRUE.
-    ELSE
-      is_north_pole_dyn = .FALSE.
-    ENDIF
-    
-    IF (mpi_rank == mpi_size-1) THEN
-      is_south_pole_dyn = .TRUE.
-    ELSE
-      is_south_pole_dyn = .FALSE.
-    ENDIF
-    
-    ALLOCATE(jj_para_nb(0:mpi_size-1))
-    ALLOCATE(jj_para_begin(0:mpi_size-1))
-    ALLOCATE(jj_para_end(0:mpi_size-1))
-    
-    ALLOCATE(ij_para_nb(0:mpi_size-1))
-    ALLOCATE(ij_para_begin(0:mpi_size-1))
-    ALLOCATE(ij_para_end(0:mpi_size-1))
-    
-    ALLOCATE(ii_para_begin(0:mpi_size-1))
-    ALLOCATE(ii_para_end(0:mpi_size-1))
-
-    ALLOCATE(klon_mpi_para_nb(0:mpi_size-1))
-    ALLOCATE(klon_mpi_para_begin(0:mpi_size-1))
-    ALLOCATE(klon_mpi_para_end(0:mpi_size-1))
-  
-      
-    klon_mpi_para_nb(0:mpi_size-1)=distrib(0:mpi_size-1)
-
-    DO i=0,mpi_size-1
-      IF (i==0) THEN 
-        klon_mpi_para_begin(i)=1
-      ELSE 
-        klon_mpi_para_begin(i)=klon_mpi_para_end(i-1)+1
-      ENDIF
-        klon_mpi_para_end(i)=klon_mpi_para_begin(i)+klon_mpi_para_nb(i)-1
-    ENDDO
-
-
-    DO i=0,mpi_size-1
-      
-      IF (i==0) THEN
-        ij_para_begin(i) = 1
-      ELSE
-        ij_para_begin(i) = klon_mpi_para_begin(i)+nbp_lon-1
-      ENDIF
-
-      jj_para_begin(i) = (ij_para_begin(i)-1)/nbp_lon + 1
-      ii_para_begin(i) = MOD(ij_para_begin(i)-1,nbp_lon) + 1
-
-      
-      ij_para_end(i) = klon_mpi_para_end(i)+nbp_lon-1
-      jj_para_end(i) = (ij_para_end(i)-1)/nbp_lon + 1
-      ii_para_end(i) = MOD(ij_para_end(i)-1,nbp_lon) + 1
-
-
-      ij_para_nb(i) = ij_para_end(i)-ij_para_begin(i)+1
-      jj_para_nb(i) = jj_para_end(i)-jj_para_begin(i)+1
-         
-    ENDDO
-  
-    ii_begin = ii_para_begin(mpi_rank)
-    ii_end   = ii_para_end(mpi_rank)
-    jj_begin = jj_para_begin(mpi_rank)
-    jj_end   = jj_para_end(mpi_rank)
-    jj_nb    = jj_para_nb(mpi_rank)
-    ij_begin = ij_para_begin(mpi_rank)
-    ij_end   = ij_para_end(mpi_rank)
-    ij_nb    = ij_para_nb(mpi_rank)
-    klon_mpi_begin = klon_mpi_para_begin(mpi_rank)
-    klon_mpi_end   = klon_mpi_para_end(mpi_rank)
-    klon_mpi       = klon_mpi_para_nb(mpi_rank)
-   
-    CALL Print_module_data
-
-IF (CPPKEY_INCA) THEN
-       CALL init_inca_para( &
-            nbp_lon,nbp_lat,nbp_lev,klon_glo,mpi_size, &
-            distrib,nvertex, grid_type,communicator)
-END IF
-    
-  END SUBROUTINE Init_phys_lmdz_mpi_data
-
-  SUBROUTINE print_module_data
-  USE print_control_mod, ONLY: lunout
-  IMPLICIT NONE
-!  INCLUDE "iniprint.h" 
-  
-    WRITE(lunout,*) 'ii_begin =', ii_begin
-    WRITE(lunout,*) 'ii_end =', ii_end
-    WRITE(lunout,*) 'jj_begin =',jj_begin
-    WRITE(lunout,*) 'jj_end =', jj_end
-    WRITE(lunout,*) 'jj_nb =', jj_nb
-    WRITE(lunout,*) 'ij_begin =', ij_begin
-    WRITE(lunout,*) 'ij_end =', ij_end
-    WRITE(lunout,*) 'ij_nb =', ij_nb
-    WRITE(lunout,*) 'klon_mpi_begin =', klon_mpi_begin
-    WRITE(lunout,*) 'klon_mpi_end =', klon_mpi_end
-    WRITE(lunout,*) 'klon_mpi =', klon_mpi
-    WRITE(lunout,*) 'jj_para_nb =', jj_para_nb
-    WRITE(lunout,*) 'jj_para_begin =', jj_para_begin
-    WRITE(lunout,*) 'jj_para_end =', jj_para_end
-    WRITE(lunout,*) 'ii_para_begin =', ii_para_begin
-    WRITE(lunout,*) 'ii_para_end =', ii_para_end
-    WRITE(lunout,*) 'ij_para_nb =', ij_para_nb
-    WRITE(lunout,*) 'ij_para_begin =', ij_para_begin
-    WRITE(lunout,*) 'ij_para_end =', ij_para_end
-    WRITE(lunout,*) 'klon_mpi_para_nb =', klon_mpi_para_nb
-    WRITE(lunout,*) 'klon_mpi_para_begin =', klon_mpi_para_begin
-    WRITE(lunout,*) 'klon_mpi_para_end  =', klon_mpi_para_end 
-    WRITE(lunout,*) 'mpi_rank =', mpi_rank
-    WRITE(lunout,*) 'mpi_size =', mpi_size
-    WRITE(lunout,*) 'mpi_master =', mpi_master
-    WRITE(lunout,*) 'is_mpi_root =', is_mpi_root
-    WRITE(lunout,*) 'is_north_pole =', is_north_pole_dyn
-    WRITE(lunout,*) 'is_south_pole =', is_south_pole_dyn
-    WRITE(lunout,*) 'COMM_LMDZ_PHY =', COMM_LMDZ_PHY
-  
-  END SUBROUTINE print_module_data
-  
-END MODULE mod_phys_lmdz_mpi_data
Index: /LMDZ6/trunk/libf/phy_common/mod_phys_lmdz_mpi_data.f90
===================================================================
--- /LMDZ6/trunk/libf/phy_common/mod_phys_lmdz_mpi_data.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phy_common/mod_phys_lmdz_mpi_data.f90	(revision 5268)
@@ -0,0 +1,222 @@
+!
+!$Id$
+!
+MODULE mod_phys_lmdz_mpi_data
+  USE lmdz_mpi
+  USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_INCA
+
+  INTEGER,SAVE :: ii_begin
+  INTEGER,SAVE :: ii_end
+  INTEGER,SAVE :: jj_begin
+  INTEGER,SAVE :: jj_end
+  INTEGER,SAVE :: jj_nb
+  INTEGER,SAVE :: ij_begin
+  INTEGER,SAVE :: ij_end
+  INTEGER,SAVE :: ij_nb
+  INTEGER,SAVE :: klon_mpi_begin
+  INTEGER,SAVE :: klon_mpi_end
+  INTEGER,SAVE :: klon_mpi
+  
+  INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: jj_para_nb
+  INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: jj_para_begin
+  INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: jj_para_end
+
+  INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: ii_para_begin
+  INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: ii_para_end
+
+  INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: ij_para_nb
+  INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: ij_para_begin
+  INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: ij_para_end
+
+  INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: klon_mpi_para_nb
+  INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: klon_mpi_para_begin
+  INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: klon_mpi_para_end 
+
+  
+  INTEGER,SAVE :: mpi_rank
+  INTEGER,SAVE :: mpi_size
+  INTEGER,SAVE :: mpi_master
+  LOGICAL,SAVE :: is_mpi_root
+  LOGICAL,SAVE :: is_using_mpi
+  
+  
+  LOGICAL,SAVE :: is_north_pole_dyn
+  LOGICAL,SAVE :: is_south_pole_dyn
+  INTEGER,SAVE :: COMM_LMDZ_PHY
+  INTEGER,SAVE :: MPI_REAL_LMDZ   ! MPI_REAL8
+
+CONTAINS
+  
+  SUBROUTINE init_phys_lmdz_mpi_data(nbp, nbp_lon, nbp_lat, nbp_lev, grid_type, nvertex, communicator)
+  USE lmdz_mpi
+  IMPLICIT NONE
+    INTEGER,INTENT(IN) :: nbp
+    INTEGER,INTENT(IN) :: nbp_lon
+    INTEGER,INTENT(IN) :: nbp_lat
+    INTEGER,INTENT(IN) :: nbp_lev
+    INTEGER,INTENT(IN) :: communicator
+    INTEGER,INTENT(IN) :: grid_type 
+    INTEGER,INTENT(IN) :: nvertex 
+    
+    INTEGER,ALLOCATABLE :: distrib(:)
+    INTEGER :: ierr
+    INTEGER :: klon_glo
+    INTEGER :: i
+    
+    is_using_mpi = using_mpi
+    
+    if ((nbp_lon.eq.1).and.(nbp_lat.eq.1)) then ! running 1D column model
+       klon_glo=1
+    else
+    ! The usual global physics grid: 1 point for each pole and nbp_lon points
+    ! for all other latitudes
+       klon_glo=nbp_lon*(nbp_lat-2)+2
+    endif
+    
+    COMM_LMDZ_PHY=communicator
+
+    IF (is_using_mpi) THEN    
+      MPI_REAL_LMDZ=MPI_REAL8
+      CALL MPI_COMM_SIZE(COMM_LMDZ_PHY,mpi_size,ierr)    
+      CALL MPI_COMM_RANK(COMM_LMDZ_PHY,mpi_rank,ierr)
+    ELSE
+      mpi_size=1
+      mpi_rank=0
+    ENDIF
+    
+    ALLOCATE(distrib(0:mpi_size-1))
+
+    IF (is_using_mpi) THEN    
+      CALL MPI_ALLGATHER(nbp,1,MPI_INTEGER,distrib,1,MPI_INTEGER,COMM_LMDZ_PHY,ierr)
+    ELSE
+     distrib(:)=nbp
+    ENDIF
+
+
+    IF (mpi_rank == 0) THEN
+      mpi_master = 0
+      is_mpi_root = .true.
+    ENDIF
+    
+    IF (mpi_rank == 0) THEN 
+      is_north_pole_dyn = .TRUE.
+    ELSE
+      is_north_pole_dyn = .FALSE.
+    ENDIF
+    
+    IF (mpi_rank == mpi_size-1) THEN
+      is_south_pole_dyn = .TRUE.
+    ELSE
+      is_south_pole_dyn = .FALSE.
+    ENDIF
+    
+    ALLOCATE(jj_para_nb(0:mpi_size-1))
+    ALLOCATE(jj_para_begin(0:mpi_size-1))
+    ALLOCATE(jj_para_end(0:mpi_size-1))
+    
+    ALLOCATE(ij_para_nb(0:mpi_size-1))
+    ALLOCATE(ij_para_begin(0:mpi_size-1))
+    ALLOCATE(ij_para_end(0:mpi_size-1))
+    
+    ALLOCATE(ii_para_begin(0:mpi_size-1))
+    ALLOCATE(ii_para_end(0:mpi_size-1))
+
+    ALLOCATE(klon_mpi_para_nb(0:mpi_size-1))
+    ALLOCATE(klon_mpi_para_begin(0:mpi_size-1))
+    ALLOCATE(klon_mpi_para_end(0:mpi_size-1))
+  
+      
+    klon_mpi_para_nb(0:mpi_size-1)=distrib(0:mpi_size-1)
+
+    DO i=0,mpi_size-1
+      IF (i==0) THEN 
+        klon_mpi_para_begin(i)=1
+      ELSE 
+        klon_mpi_para_begin(i)=klon_mpi_para_end(i-1)+1
+      ENDIF
+        klon_mpi_para_end(i)=klon_mpi_para_begin(i)+klon_mpi_para_nb(i)-1
+    ENDDO
+
+
+    DO i=0,mpi_size-1
+      
+      IF (i==0) THEN
+        ij_para_begin(i) = 1
+      ELSE
+        ij_para_begin(i) = klon_mpi_para_begin(i)+nbp_lon-1
+      ENDIF
+
+      jj_para_begin(i) = (ij_para_begin(i)-1)/nbp_lon + 1
+      ii_para_begin(i) = MOD(ij_para_begin(i)-1,nbp_lon) + 1
+
+      
+      ij_para_end(i) = klon_mpi_para_end(i)+nbp_lon-1
+      jj_para_end(i) = (ij_para_end(i)-1)/nbp_lon + 1
+      ii_para_end(i) = MOD(ij_para_end(i)-1,nbp_lon) + 1
+
+
+      ij_para_nb(i) = ij_para_end(i)-ij_para_begin(i)+1
+      jj_para_nb(i) = jj_para_end(i)-jj_para_begin(i)+1
+         
+    ENDDO
+  
+    ii_begin = ii_para_begin(mpi_rank)
+    ii_end   = ii_para_end(mpi_rank)
+    jj_begin = jj_para_begin(mpi_rank)
+    jj_end   = jj_para_end(mpi_rank)
+    jj_nb    = jj_para_nb(mpi_rank)
+    ij_begin = ij_para_begin(mpi_rank)
+    ij_end   = ij_para_end(mpi_rank)
+    ij_nb    = ij_para_nb(mpi_rank)
+    klon_mpi_begin = klon_mpi_para_begin(mpi_rank)
+    klon_mpi_end   = klon_mpi_para_end(mpi_rank)
+    klon_mpi       = klon_mpi_para_nb(mpi_rank)
+   
+    CALL Print_module_data
+
+IF (CPPKEY_INCA) THEN
+       CALL init_inca_para( &
+            nbp_lon,nbp_lat,nbp_lev,klon_glo,mpi_size, &
+            distrib,nvertex, grid_type,communicator)
+END IF
+    
+  END SUBROUTINE Init_phys_lmdz_mpi_data
+
+  SUBROUTINE print_module_data
+  USE print_control_mod, ONLY: lunout
+  IMPLICIT NONE
+!  INCLUDE "iniprint.h" 
+  
+    WRITE(lunout,*) 'ii_begin =', ii_begin
+    WRITE(lunout,*) 'ii_end =', ii_end
+    WRITE(lunout,*) 'jj_begin =',jj_begin
+    WRITE(lunout,*) 'jj_end =', jj_end
+    WRITE(lunout,*) 'jj_nb =', jj_nb
+    WRITE(lunout,*) 'ij_begin =', ij_begin
+    WRITE(lunout,*) 'ij_end =', ij_end
+    WRITE(lunout,*) 'ij_nb =', ij_nb
+    WRITE(lunout,*) 'klon_mpi_begin =', klon_mpi_begin
+    WRITE(lunout,*) 'klon_mpi_end =', klon_mpi_end
+    WRITE(lunout,*) 'klon_mpi =', klon_mpi
+    WRITE(lunout,*) 'jj_para_nb =', jj_para_nb
+    WRITE(lunout,*) 'jj_para_begin =', jj_para_begin
+    WRITE(lunout,*) 'jj_para_end =', jj_para_end
+    WRITE(lunout,*) 'ii_para_begin =', ii_para_begin
+    WRITE(lunout,*) 'ii_para_end =', ii_para_end
+    WRITE(lunout,*) 'ij_para_nb =', ij_para_nb
+    WRITE(lunout,*) 'ij_para_begin =', ij_para_begin
+    WRITE(lunout,*) 'ij_para_end =', ij_para_end
+    WRITE(lunout,*) 'klon_mpi_para_nb =', klon_mpi_para_nb
+    WRITE(lunout,*) 'klon_mpi_para_begin =', klon_mpi_para_begin
+    WRITE(lunout,*) 'klon_mpi_para_end  =', klon_mpi_para_end 
+    WRITE(lunout,*) 'mpi_rank =', mpi_rank
+    WRITE(lunout,*) 'mpi_size =', mpi_size
+    WRITE(lunout,*) 'mpi_master =', mpi_master
+    WRITE(lunout,*) 'is_mpi_root =', is_mpi_root
+    WRITE(lunout,*) 'is_north_pole =', is_north_pole_dyn
+    WRITE(lunout,*) 'is_south_pole =', is_south_pole_dyn
+    WRITE(lunout,*) 'COMM_LMDZ_PHY =', COMM_LMDZ_PHY
+  
+  END SUBROUTINE print_module_data
+  
+END MODULE mod_phys_lmdz_mpi_data
Index: DZ6/trunk/libf/phy_common/mod_phys_lmdz_mpi_transfert.F90
===================================================================
--- /LMDZ6/trunk/libf/phy_common/mod_phys_lmdz_mpi_transfert.F90	(revision 5267)
+++ 	(revision )
@@ -1,2025 +1,0 @@
-!
-!$Id$
-!
-MODULE mod_phys_lmdz_mpi_transfert
-
-
-  INTERFACE bcast_mpi
-    MODULE PROCEDURE bcast_mpi_c,                                                     &
-                     bcast_mpi_i,bcast_mpi_i1,bcast_mpi_i2,bcast_mpi_i3,bcast_mpi_i4, &
-                     bcast_mpi_r,bcast_mpi_r1,bcast_mpi_r2,bcast_mpi_r3,bcast_mpi_r4, &
-                     bcast_mpi_l,bcast_mpi_l1,bcast_mpi_l2,bcast_mpi_l3,bcast_mpi_l4
-  END INTERFACE
-
-  INTERFACE scatter_mpi
-    MODULE PROCEDURE scatter_mpi_i,scatter_mpi_i1,scatter_mpi_i2,scatter_mpi_i3, &
-                     scatter_mpi_r,scatter_mpi_r1,scatter_mpi_r2,scatter_mpi_r3, &
-                     scatter_mpi_l,scatter_mpi_l1,scatter_mpi_l2,scatter_mpi_l3
-  END INTERFACE
-
-  
-  INTERFACE gather_mpi
-    MODULE PROCEDURE gather_mpi_i,gather_mpi_i1,gather_mpi_i2,gather_mpi_i3, &
-                     gather_mpi_r,gather_mpi_r1,gather_mpi_r2,gather_mpi_r3, &
-                     gather_mpi_l,gather_mpi_l1,gather_mpi_l2,gather_mpi_l3  
-  END INTERFACE
-  
-  INTERFACE scatter2D_mpi
-    MODULE PROCEDURE scatter2D_mpi_i,scatter2D_mpi_i1,scatter2D_mpi_i2,scatter2D_mpi_i3, &
-                     scatter2D_mpi_r,scatter2D_mpi_r1,scatter2D_mpi_r2,scatter2D_mpi_r3, &
-                     scatter2D_mpi_l,scatter2D_mpi_l1,scatter2D_mpi_l2,scatter2D_mpi_l3
-  END INTERFACE
-
-  INTERFACE gather2D_mpi
-    MODULE PROCEDURE gather2D_mpi_i,gather2D_mpi_i1,gather2D_mpi_i2,gather2D_mpi_i3, &
-                     gather2D_mpi_r,gather2D_mpi_r1,gather2D_mpi_r2,gather2D_mpi_r3, &
-                     gather2D_mpi_l,gather2D_mpi_l1,gather2D_mpi_l2,gather2D_mpi_l3
-  END INTERFACE 
-  
-  INTERFACE reduce_sum_mpi
-    MODULE PROCEDURE reduce_sum_mpi_i,reduce_sum_mpi_i1,reduce_sum_mpi_i2,reduce_sum_mpi_i3,reduce_sum_mpi_i4, &
-                     reduce_sum_mpi_r,reduce_sum_mpi_r1,reduce_sum_mpi_r2,reduce_sum_mpi_r3,reduce_sum_mpi_r4
-  END INTERFACE 
-
-  INTERFACE reduce_min_mpi
-    MODULE PROCEDURE reduce_min_mpi_i,reduce_min_mpi_i1,reduce_min_mpi_i2,reduce_min_mpi_i3,reduce_min_mpi_i4, &
-                     reduce_min_mpi_r,reduce_min_mpi_r1,reduce_min_mpi_r2,reduce_min_mpi_r3,reduce_min_mpi_r4
-  END INTERFACE 
-
- INTERFACE grid1dTo2d_mpi
-    MODULE PROCEDURE grid1dTo2d_mpi_i,grid1dTo2d_mpi_i1,grid1dTo2d_mpi_i2,grid1dTo2d_mpi_i3, &
-                     grid1dTo2d_mpi_r,grid1dTo2d_mpi_r1,grid1dTo2d_mpi_r2,grid1dTo2d_mpi_r3, &
-                     grid1dTo2d_mpi_l,grid1dTo2d_mpi_l1,grid1dTo2d_mpi_l2,grid1dTo2d_mpi_l3
- END INTERFACE 
-
- INTERFACE grid2dTo1d_mpi
-    MODULE PROCEDURE grid2dTo1d_mpi_i,grid2dTo1d_mpi_i1,grid2dTo1d_mpi_i2,grid2dTo1d_mpi_i3, &
-                     grid2dTo1d_mpi_r,grid2dTo1d_mpi_r1,grid2dTo1d_mpi_r2,grid2dTo1d_mpi_r3, &
-                     grid2dTo1d_mpi_l,grid2dTo1d_mpi_l1,grid2dTo1d_mpi_l2,grid2dTo1d_mpi_l3
- END INTERFACE 
-    
-CONTAINS
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!! Definition des Broadcast --> 4D   !!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-!! -- Les chaine de charactère -- !!
-
-  SUBROUTINE bcast_mpi_c(var1)
-  IMPLICIT NONE
-    CHARACTER(LEN=*),INTENT(INOUT) :: Var1
-   
-    CALL bcast_mpi_cgen(Var1,len(Var1))
-
-  END SUBROUTINE bcast_mpi_c
-
-!! -- Les entiers -- !!
-  
-  SUBROUTINE bcast_mpi_i(var)
-  USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root
-  IMPLICIT NONE
-    INTEGER,INTENT(INOUT) :: Var
-    
-    INTEGER               :: var_tmp(1)
-    
-    IF (is_mpi_root) var_tmp(1)=var
-    CALL bcast_mpi_igen(Var_tmp,1)
-    var=var_tmp(1)
-    
-  END SUBROUTINE bcast_mpi_i
-
-  SUBROUTINE bcast_mpi_i1(var)
-  IMPLICIT NONE
-    INTEGER,INTENT(INOUT) :: Var(:)
-
-    CALL bcast_mpi_igen(Var,size(Var))
-    
-  END SUBROUTINE bcast_mpi_i1
-
-  SUBROUTINE bcast_mpi_i2(var)
-  IMPLICIT NONE
-    INTEGER,INTENT(INOUT) :: Var(:,:)
-   
-    CALL bcast_mpi_igen(Var,size(Var))
-  
-  END SUBROUTINE bcast_mpi_i2
-
-  SUBROUTINE bcast_mpi_i3(var)
-  IMPLICIT NONE
-    INTEGER,INTENT(INOUT) :: Var(:,:,:)
-   
-    CALL bcast_mpi_igen(Var,size(Var))
-
-  END SUBROUTINE bcast_mpi_i3
-
-  SUBROUTINE bcast_mpi_i4(var)
-  IMPLICIT NONE
-    INTEGER,INTENT(INOUT) :: Var(:,:,:,:)
-   
-    CALL bcast_mpi_igen(Var,size(Var))
-
-  END SUBROUTINE bcast_mpi_i4
-
-
-!! -- Les reels -- !!
-
-  SUBROUTINE bcast_mpi_r(var)
-  USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root
-  IMPLICIT NONE
-    REAL,INTENT(INOUT) :: Var
-    REAL               :: var_tmp(1)
-    
-    IF (is_mpi_root) var_tmp(1)=var
-    CALL bcast_mpi_rgen(Var_tmp,1)
-    var=var_tmp(1)   
-
-  END SUBROUTINE bcast_mpi_r
-
-  SUBROUTINE bcast_mpi_r1(var)
-  IMPLICIT NONE
-    REAL,INTENT(INOUT) :: Var(:)
-   
-    CALL bcast_mpi_rgen(Var,size(Var))
-
-  END SUBROUTINE bcast_mpi_r1
-
-  SUBROUTINE bcast_mpi_r2(var)
-  IMPLICIT NONE
-    REAL,INTENT(INOUT) :: Var(:,:)
-   
-    CALL bcast_mpi_rgen(Var,size(Var))
-
-  END SUBROUTINE bcast_mpi_r2
-
-  SUBROUTINE bcast_mpi_r3(var)
-  IMPLICIT NONE
-    REAL,INTENT(INOUT) :: Var(:,:,:)
-   
-    CALL bcast_mpi_rgen(Var,size(Var))
-
-  END SUBROUTINE bcast_mpi_r3
-
-  SUBROUTINE bcast_mpi_r4(var)
-  IMPLICIT NONE
-    REAL,INTENT(INOUT) :: Var(:,:,:,:)
-   
-    CALL bcast_mpi_rgen(Var,size(Var))
-
-  END SUBROUTINE bcast_mpi_r4
-  
-!! -- Les booleans -- !!
-
-  SUBROUTINE bcast_mpi_l(var)
-  USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root
-  IMPLICIT NONE
-    LOGICAL,INTENT(INOUT) :: Var
-    LOGICAL               :: var_tmp(1)
-    
-    IF (is_mpi_root) var_tmp(1)=var
-    CALL bcast_mpi_lgen(Var_tmp,1)
-    var=var_tmp(1)   
-
-  END SUBROUTINE bcast_mpi_l
-
-  SUBROUTINE bcast_mpi_l1(var)
-  IMPLICIT NONE
-    LOGICAL,INTENT(INOUT) :: Var(:)
-   
-    CALL bcast_mpi_lgen(Var,size(Var))
-
-  END SUBROUTINE bcast_mpi_l1
-
-  SUBROUTINE bcast_mpi_l2(var)
-  IMPLICIT NONE
-    LOGICAL,INTENT(INOUT) :: Var(:,:)
-   
-    CALL bcast_mpi_lgen(Var,size(Var))
-
-  END SUBROUTINE bcast_mpi_l2
-
-  SUBROUTINE bcast_mpi_l3(var)
-  IMPLICIT NONE
-    LOGICAL,INTENT(INOUT) :: Var(:,:,:)
-   
-    CALL bcast_mpi_lgen(Var,size(Var))
-
-  END SUBROUTINE bcast_mpi_l3
-
-  SUBROUTINE bcast_mpi_l4(var)
-  IMPLICIT NONE
-    LOGICAL,INTENT(INOUT) :: Var(:,:,:,:)
-   
-    CALL bcast_mpi_lgen(Var,size(Var))
-
-  END SUBROUTINE bcast_mpi_l4
-  
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!! Definition des Scatter   --> 4D   !!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-  SUBROUTINE scatter_mpi_i(VarIn, VarOut)
-    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
-    IMPLICIT NONE
-  
-    INTEGER,INTENT(IN),DIMENSION(:) :: VarIn
-    INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut
-
-    CALL scatter_mpi_igen(VarIn,Varout,1)
-    
-  END SUBROUTINE scatter_mpi_i
-
-  SUBROUTINE scatter_mpi_i1(VarIn, VarOut)
-    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
-    IMPLICIT NONE
-  
-    INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn
-    INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
-    
-    CALL scatter_mpi_igen(VarIn,Varout,Size(VarOut,2))
-    
-  END SUBROUTINE scatter_mpi_i1
-  
-  SUBROUTINE scatter_mpi_i2(VarIn, VarOut)
-    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
-    IMPLICIT NONE
-  
-    INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn
-    INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
-    
-    CALL scatter_mpi_igen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3))
-
-  END SUBROUTINE scatter_mpi_i2
-
-  SUBROUTINE scatter_mpi_i3(VarIn, VarOut)
-    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
-    IMPLICIT NONE
-  
-    INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
-    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
-    
-    CALL scatter_mpi_igen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3)*Size(VarOut,4))
-  
-  END SUBROUTINE scatter_mpi_i3
-
-
-  SUBROUTINE scatter_mpi_r(VarIn, VarOut)
-    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
-    IMPLICIT NONE
-  
-    REAL,INTENT(IN),DIMENSION(:) :: VarIn
-    REAL,INTENT(OUT),DIMENSION(:) :: VarOut
-    
-      CALL scatter_mpi_rgen(VarIn,Varout,1)
-  
-  END SUBROUTINE scatter_mpi_r
-
-  SUBROUTINE scatter_mpi_r1(VarIn, VarOut)
-  USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
-  IMPLICIT NONE
-  
-    REAL,INTENT(IN),DIMENSION(:,:) :: VarIn
-    REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
-    
-      CALL scatter_mpi_rgen(VarIn,Varout,Size(VarOut,2))
-  
-  END SUBROUTINE scatter_mpi_r1
-  
-  SUBROUTINE scatter_mpi_r2(VarIn, VarOut)
-    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
-    IMPLICIT NONE
-  
-    REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
-    REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
-    
-      CALL scatter_mpi_rgen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3))
-  
-  END SUBROUTINE scatter_mpi_r2
-
-  SUBROUTINE scatter_mpi_r3(VarIn, VarOut)
-    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
-    IMPLICIT NONE
-  
-    REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
-    REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
-    
-      CALL scatter_mpi_rgen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3)*Size(VarOut,4))
-  
-  END SUBROUTINE scatter_mpi_r3
-
-
-  SUBROUTINE scatter_mpi_l(VarIn, VarOut)
-    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
-    IMPLICIT NONE
-  
-    LOGICAL,INTENT(IN),DIMENSION(:) :: VarIn
-    LOGICAL,INTENT(OUT),DIMENSION(:) :: VarOut
-    
-      CALL scatter_mpi_lgen(VarIn,Varout,1)
-    
-  END SUBROUTINE scatter_mpi_l
-
-  SUBROUTINE scatter_mpi_l1(VarIn, VarOut)
-    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
-    IMPLICIT NONE
-  
-    LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn
-    LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
-    
-      CALL scatter_mpi_lgen(VarIn,Varout,Size(VarOut,2))
-  
-  END SUBROUTINE scatter_mpi_l1
-  
-  SUBROUTINE scatter_mpi_l2(VarIn, VarOut)
-    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
-    IMPLICIT NONE
-  
-    LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
-    LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
-    
-      CALL scatter_mpi_lgen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3))
-  
-  END SUBROUTINE scatter_mpi_l2
-
-  SUBROUTINE scatter_mpi_l3(VarIn, VarOut)
-    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
-    IMPLICIT NONE
-  
-    LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
-    LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
-    
-      CALL scatter_mpi_lgen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3)*Size(VarOut,4))
-  
-  END SUBROUTINE scatter_mpi_l3  
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!! Definition des Gather   --> 4D   !!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- 
-!!!!! --> Les entiers
-
-  SUBROUTINE gather_mpi_i(VarIn, VarOut)
-    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
-    IMPLICIT NONE
-  
-    INTEGER,INTENT(IN),DIMENSION(:) :: VarIn
-    INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut
-    
-      CALL gather_mpi_igen(VarIn,VarOut,1)
-  
-  END SUBROUTINE gather_mpi_i
-  
-
-!!!!!
-
-  SUBROUTINE gather_mpi_i1(VarIn, VarOut)
-    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
-    IMPLICIT NONE
-  
-    INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn
-    INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
-    
-      CALL gather_mpi_igen(VarIn,VarOut,Size(VarIn,2))
-  
-  END SUBROUTINE gather_mpi_i1
-
-!!!!!
-  
-  SUBROUTINE gather_mpi_i2(VarIn, VarOut)
-    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
-    IMPLICIT NONE
-  
-    INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn
-    INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
-    
-      CALL gather_mpi_igen(VarIn,VarOut,Size(VarIn,2)*Size(VarIn,3))
-  
-  END SUBROUTINE gather_mpi_i2
-
-!!!!!
-
-  SUBROUTINE gather_mpi_i3(VarIn, VarOut)
-    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
-    IMPLICIT NONE
-  
-    INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
-    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
-    
-      CALL gather_mpi_igen(VarIn,VarOut,Size(VarIn,2)*Size(VarIn,3)*Size(VarIn,4))
-  
-  END SUBROUTINE gather_mpi_i3
-
-!!!!! --> Les reels
-
-  SUBROUTINE gather_mpi_r(VarIn, VarOut)
-    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
-    IMPLICIT NONE
-  
-    REAL,INTENT(IN),DIMENSION(:) :: VarIn
-    REAL,INTENT(OUT),DIMENSION(:) :: VarOut
-    
-      CALL gather_mpi_rgen(VarIn,VarOut,1)
-  
-  END SUBROUTINE gather_mpi_r
-
-!!!!!
-
-  SUBROUTINE gather_mpi_r1(VarIn, VarOut)
-    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
-    IMPLICIT NONE
-  
-    REAL,INTENT(IN),DIMENSION(:,:) :: VarIn
-    REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
-    
-      CALL gather_mpi_rgen(VarIn,VarOut,Size(VarIn,2))
-  
-  END SUBROUTINE gather_mpi_r1
-
-!!!!!
-  
-  SUBROUTINE gather_mpi_r2(VarIn, VarOut)
-    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
-    IMPLICIT NONE
-  
-    REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
-    REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
-    
-      CALL gather_mpi_rgen(VarIn,VarOut,Size(VarIn,2)*Size(VarIn,3))
-  
-  END SUBROUTINE gather_mpi_r2
-
-!!!!!
-
-  SUBROUTINE gather_mpi_r3(VarIn, VarOut)
-    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
-    IMPLICIT NONE
-  
-    REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
-    REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
-    
-      CALL gather_mpi_rgen(VarIn,VarOut,Size(VarIn,2)*Size(VarIn,3)*Size(VarIn,4))
-  
-  END SUBROUTINE gather_mpi_r3
-
-!!!!! --> Les booleen
-
-  SUBROUTINE gather_mpi_l(VarIn, VarOut)
-    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
-    IMPLICIT NONE
-  
-    LOGICAL,INTENT(IN),DIMENSION(:) :: VarIn
-    LOGICAL,INTENT(OUT),DIMENSION(:) :: VarOut
-    
-      CALL gather_mpi_lgen(VarIn,VarOut,1)
-  
-  END SUBROUTINE gather_mpi_l
-
-!!!!!
-
-  SUBROUTINE gather_mpi_l1(VarIn, VarOut)
-    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
-    IMPLICIT NONE
-  
-    LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn
-    LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
-    
-      CALL gather_mpi_lgen(VarIn,VarOut,Size(VarIn,2))
-  
-  END SUBROUTINE gather_mpi_l1
-
-!!!!!
-  
-  SUBROUTINE gather_mpi_l2(VarIn, VarOut)
-    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
-    IMPLICIT NONE
-  
-    LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
-    LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
-    
-      CALL gather_mpi_lgen(VarIn,VarOut,Size(VarIn,2)*Size(VarIn,3))
-  
-  END SUBROUTINE gather_mpi_l2
-
-!!!!!
-
-  SUBROUTINE gather_mpi_l3(VarIn, VarOut)
-    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
-    IMPLICIT NONE
-  
-    LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
-    LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
-    
-    CALL gather_mpi_lgen(VarIn,VarOut,Size(VarIn,2)*Size(VarIn,3)*Size(VarIn,4))
-  
-  END SUBROUTINE gather_mpi_l3
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!! Definition des Scatter2D   --> 4D   !!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-  SUBROUTINE scatter2D_mpi_i(VarIn, VarOut)
-    USE mod_grid_phy_lmdz
-    IMPLICIT NONE
-  
-    INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn
-    INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut
-
-    INTEGER,DIMENSION(klon_glo) :: Var_tmp    
-    
-    CALL grid2dTo1d_glo(VarIn,Var_tmp)
-    CALL scatter_mpi(Var_tmp,VarOut)
-
-  END SUBROUTINE scatter2D_mpi_i
-
-  SUBROUTINE scatter2D_mpi_i1(VarIn, VarOut)
-    USE mod_grid_phy_lmdz
-    IMPLICIT NONE
-  
-    INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn
-    INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
-    INTEGER,DIMENSION(klon_glo,size(VarOut,2)) :: Var_tmp
-
-    CALL grid2dTo1d_glo(VarIn,Var_tmp)
-    CALL scatter_mpi(Var_tmp,VarOut)
-
-  END SUBROUTINE scatter2D_mpi_i1
-
-  SUBROUTINE scatter2D_mpi_i2(VarIn, VarOut)
-    USE mod_grid_phy_lmdz
-    IMPLICIT NONE
-  
-    INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
-    INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
-
-    INTEGER,DIMENSION(klon_glo,size(VarOut,2),size(VarOut,3)) :: Var_tmp
-
-    CALL grid2dTo1d_glo(VarIn,Var_tmp)
-    CALL scatter_mpi(Var_tmp,VarOut)
-
-  END SUBROUTINE scatter2D_mpi_i2
-  
-  SUBROUTINE scatter2D_mpi_i3(VarIn, VarOut)
-    USE mod_grid_phy_lmdz
-    IMPLICIT NONE
-  
-    INTEGER,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn
-    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
-    INTEGER,DIMENSION(klon_glo,size(VarOut,2),size(VarOut,3),size(VarOut,4)) :: Var_tmp
-
-    CALL grid2dTo1d_glo(VarIn,Var_tmp)
-    CALL scatter_mpi(Var_tmp,VarOut)
-    
-  END SUBROUTINE scatter2D_mpi_i3
-
-
-
-  SUBROUTINE scatter2D_mpi_r(VarIn, VarOut)
-    USE mod_grid_phy_lmdz
-    IMPLICIT NONE
-  
-    REAL,INTENT(IN),DIMENSION(:,:) :: VarIn
-    REAL,INTENT(OUT),DIMENSION(:) :: VarOut
-
-    REAL,DIMENSION(klon_glo) :: Var_tmp    
-    
-    CALL grid2dTo1d_glo(VarIn,Var_tmp)
-    CALL scatter_mpi(Var_tmp,VarOut)
-
-  END SUBROUTINE scatter2D_mpi_R
-
-
-  SUBROUTINE scatter2D_mpi_r1(VarIn, VarOut)
-    USE mod_grid_phy_lmdz
-    IMPLICIT NONE
-    REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
-    REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
-    
-    REAL,DIMENSION(klon_glo,size(VarOut,2)) :: Var_tmp
-    
-    CALL grid2dTo1d_glo(VarIn,Var_tmp)
-    CALL scatter_mpi(Var_tmp,VarOut)
-
-  END SUBROUTINE scatter2D_mpi_r1
-
-
-  SUBROUTINE scatter2D_mpi_r2(VarIn, VarOut)
-    USE mod_grid_phy_lmdz
-    IMPLICIT NONE
-  
-    REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
-    REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
-
-    REAL,DIMENSION(klon_glo,size(VarOut,2),size(VarOut,3)) :: Var_tmp
-    
-    CALL grid2dTo1d_glo(VarIn,Var_tmp)
-    CALL scatter_mpi(Var_tmp,VarOut)
-
-  END SUBROUTINE scatter2D_mpi_r2
-  
-  SUBROUTINE scatter2D_mpi_r3(VarIn, VarOut)
-    USE mod_grid_phy_lmdz
-    IMPLICIT NONE
-  
-    REAL,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn
-    REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
-    
-    REAL,DIMENSION(klon_glo,size(VarOut,2),size(VarOut,3),size(VarOut,4)) :: Var_tmp
-
-    CALL grid2dTo1d_glo(VarIn,Var_tmp)
-    CALL scatter_mpi(Var_tmp,VarOut)
- 
-  END SUBROUTINE scatter2D_mpi_r3
-  
-  
-  SUBROUTINE scatter2D_mpi_l(VarIn, VarOut)
-    USE mod_grid_phy_lmdz
-    IMPLICIT NONE
-  
-    LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn
-    LOGICAL,INTENT(OUT),DIMENSION(:) :: VarOut
-
-    LOGICAL,DIMENSION(klon_glo) :: Var_tmp    
-    
-    CALL grid2dTo1d_glo(VarIn,Var_tmp)
-    CALL scatter_mpi(Var_tmp,VarOut)
-
-  END SUBROUTINE scatter2D_mpi_l
-
-
-  SUBROUTINE scatter2D_mpi_l1(VarIn, VarOut)
-    USE mod_grid_phy_lmdz
-    IMPLICIT NONE
-  
-    LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
-    LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
-    
-    LOGICAL,DIMENSION(klon_glo,size(VarOut,2)) :: Var_tmp
-
-    CALL grid2dTo1d_glo(VarIn,Var_tmp)
-    CALL scatter_mpi(Var_tmp,VarOut)
-  
-  END SUBROUTINE scatter2D_mpi_l1
-
-
-  SUBROUTINE scatter2D_mpi_l2(VarIn, VarOut)
-    USE mod_grid_phy_lmdz
-    IMPLICIT NONE
-  
-    LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
-    LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
-    
-    LOGICAL, DIMENSION(klon_glo,size(VarOut,2),size(VarOut,3)) :: Var_tmp
-  
-    CALL grid2dTo1d_glo(VarIn,Var_tmp)
-    CALL scatter_mpi(Var_tmp,VarOut)
-
-  END SUBROUTINE scatter2D_mpi_l2
-  
-  SUBROUTINE scatter2D_mpi_l3(VarIn, VarOut)
-    USE mod_grid_phy_lmdz
-    IMPLICIT NONE
-  
-    LOGICAL,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn
-    LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
-    
-    LOGICAL,DIMENSION(klon_glo,size(VarOut,2),size(VarOut,3),size(VarOut,4)) :: Var_tmp
-
-    CALL grid2dTo1d_glo(VarIn,Var_tmp)
-    CALL scatter_mpi(Var_tmp,VarOut)
- 
-  END SUBROUTINE scatter2D_mpi_l3
-  
-  
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!! Definition des Gather2D   --> 4D   !!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-  SUBROUTINE gather2D_mpi_i(VarIn, VarOut)
-    USE mod_grid_phy_lmdz
-    IMPLICIT NONE
-  
-    INTEGER,INTENT(IN),DIMENSION(:) :: VarIn
-    INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
-    
-    INTEGER,DIMENSION(klon_glo) :: Var_tmp
-    
-    CALL gather_mpi(VarIn,Var_tmp)
-    CALL grid1dTo2d_glo(Var_tmp,VarOut)
-
-  END SUBROUTINE gather2D_mpi_i
-
-  SUBROUTINE gather2D_mpi_i1(VarIn, VarOut)
-    USE mod_grid_phy_lmdz
-    IMPLICIT NONE
-  
-    INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn
-    INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
-
-    INTEGER,DIMENSION(klon_glo,size(VarOut,3)) :: Var_tmp
-
-    CALL gather_mpi(VarIn,Var_tmp)
-    CALL grid1dTo2d_glo(Var_tmp,VarOut)
-
-  END SUBROUTINE gather2D_mpi_i1
-
-  SUBROUTINE gather2D_mpi_i2(VarIn, VarOut)
-    USE mod_grid_phy_lmdz
-    IMPLICIT NONE
-  
-    INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn
-    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
-
-    INTEGER,DIMENSION(klon_glo,size(VarOut,3),SIZE(VarOut,4)) :: Var_tmp
-    
-    CALL gather_mpi(VarIn,Var_tmp)
-    CALL grid1dTo2d_glo(Var_tmp,VarOut)
-
-  END SUBROUTINE gather2D_mpi_i2
-  
-  SUBROUTINE gather2D_mpi_i3(VarIn, VarOut)
-    USE mod_grid_phy_lmdz
-    IMPLICIT NONE
-  
-    INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
-    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:,:) :: VarOut
- 
-    INTEGER,DIMENSION(klon_glo,size(VarOut,3),SIZE(VarOut,4),SIZE(VarOut,5)) :: Var_tmp
-    
-    CALL gather_mpi(VarIn,Var_tmp)
-    CALL grid1dTo2d_glo(Var_tmp,VarOut)
-
-  END SUBROUTINE gather2D_mpi_i3
-
-
-
-  SUBROUTINE gather2D_mpi_r(VarIn, VarOut)
-    USE mod_grid_phy_lmdz
-    IMPLICIT NONE
-  
-    REAL,INTENT(IN),DIMENSION(:) :: VarIn
-    REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
-    
-    REAL,DIMENSION(klon_glo) :: Var_tmp
-    
-    CALL gather_mpi(VarIn,Var_tmp)
-    CALL grid1dTo2d_glo(Var_tmp,VarOut)
-
-  END SUBROUTINE gather2D_mpi_r
-
-  SUBROUTINE gather2D_mpi_r1(VarIn, VarOut)
-    USE mod_grid_phy_lmdz
-    IMPLICIT NONE
-  
-    REAL,INTENT(IN),DIMENSION(:,:) :: VarIn
-    REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
-    
-    REAL,DIMENSION(klon_glo,size(VarOut,3)) :: Var_tmp
-
-    CALL gather_mpi(VarIn,Var_tmp)
-    CALL grid1dTo2d_glo(Var_tmp,VarOut)
-
-  END SUBROUTINE gather2D_mpi_r1
-
-  SUBROUTINE gather2D_mpi_r2(VarIn, VarOut)
-    USE mod_grid_phy_lmdz
-    IMPLICIT NONE
-  
-    REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
-    REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
-    
-    REAL,DIMENSION(klon_glo,size(VarOut,3),SIZE(VarOut,4)) :: Var_tmp
-
-    CALL gather_mpi(VarIn,Var_tmp)
-    CALL grid1dTo2d_glo(Var_tmp,VarOut)
-
-  END SUBROUTINE gather2D_mpi_r2
-  
-  SUBROUTINE gather2D_mpi_r3(VarIn, VarOut)
-    USE mod_grid_phy_lmdz
-    IMPLICIT NONE
-  
-    REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
-    REAL,INTENT(OUT),DIMENSION(:,:,:,:,:) :: VarOut
-    
-    REAL,DIMENSION(klon_glo,size(VarOut,3),SIZE(VarOut,4),SIZE(VarOut,5)) :: Var_tmp
-    
-    CALL gather_mpi(VarIn,Var_tmp)
-    CALL grid1dTo2d_glo(Var_tmp,VarOut)
-
-  END SUBROUTINE gather2D_mpi_r3
-
-  
-  
-  SUBROUTINE gather2D_mpi_l(VarIn, VarOut)
-    USE mod_grid_phy_lmdz
-    IMPLICIT NONE
-  
-    LOGICAL,INTENT(IN),DIMENSION(:) :: VarIn
-    LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
-    
-    LOGICAL,DIMENSION(klon_glo) :: Var_tmp
-    
-    CALL gather_mpi(VarIn,Var_tmp)
-    CALL grid1dTo2d_glo(Var_tmp,VarOut)
-
-  END SUBROUTINE gather2D_mpi_l
-
-  SUBROUTINE gather2D_mpi_l1(VarIn, VarOut)
-    USE mod_grid_phy_lmdz
-    IMPLICIT NONE
-  
-    LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn
-    LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
-    
-    LOGICAL,DIMENSION(klon_glo,size(VarOut,3)) :: Var_tmp
-
-    CALL gather_mpi(VarIn,Var_tmp)
-    CALL grid1dTo2d_glo(Var_tmp,VarOut)
-
-  END SUBROUTINE gather2D_mpi_l1
-
-  SUBROUTINE gather2D_mpi_l2(VarIn, VarOut)
-    USE mod_grid_phy_lmdz
-    IMPLICIT NONE
-  
-    LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
-    LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
-    
-    LOGICAL,DIMENSION(klon_glo,size(VarOut,3),SIZE(VarOut,4)) :: Var_tmp
-
-    CALL gather_mpi(VarIn,Var_tmp)
-    CALL grid1dTo2d_glo(Var_tmp,VarOut)
-
-  END SUBROUTINE gather2D_mpi_l2
-  
-  SUBROUTINE gather2D_mpi_l3(VarIn, VarOut)
-    USE mod_grid_phy_lmdz
-    IMPLICIT NONE
-  
-    LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
-    LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:,:) :: VarOut
-    
-    LOGICAL,DIMENSION(klon_glo,size(VarOut,3),SIZE(VarOut,4),SIZE(VarOut,5)) :: Var_tmp
-    
-    CALL gather_mpi(VarIn,Var_tmp)
-    CALL grid1dTo2d_glo(Var_tmp,VarOut)
-
-  END SUBROUTINE gather2D_mpi_l3
-  
-  
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!! Definition des reduce_sum   --> 4D   !!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-  SUBROUTINE reduce_sum_mpi_i(VarIn, VarOut)
-    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
-    IMPLICIT NONE
-  
-    INTEGER,INTENT(IN)  :: VarIn
-    INTEGER,INTENT(OUT) :: VarOut
-    INTEGER             :: VarIn_tmp(1)
-    INTEGER             :: VarOut_tmp(1)
-    
-    VarIn_tmp(1)=VarIn    
-    CALL reduce_sum_mpi_igen(VarIn_tmp,Varout_tmp,1)
-    VarOut=VarOut_tmp(1)
-    
-  END SUBROUTINE reduce_sum_mpi_i
-
-  SUBROUTINE reduce_sum_mpi_i1(VarIn, VarOut)
-    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
-    IMPLICIT NONE
-  
-    INTEGER,INTENT(IN),DIMENSION(:)  :: VarIn
-    INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut
-    
-    CALL reduce_sum_mpi_igen(VarIn,Varout,SIZE(VarIn))
-  
-  END SUBROUTINE reduce_sum_mpi_i1
-
-  SUBROUTINE reduce_sum_mpi_i2(VarIn, VarOut)
-    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
-    IMPLICIT NONE
-  
-    INTEGER,INTENT(IN),DIMENSION(:,:)  :: VarIn
-    INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
-    
-    CALL reduce_sum_mpi_igen(VarIn,Varout,SIZE(VarIn))
-  
-  END SUBROUTINE reduce_sum_mpi_i2
-
-  SUBROUTINE reduce_sum_mpi_i3(VarIn, VarOut)
-    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
-    IMPLICIT NONE
-  
-    INTEGER,INTENT(IN),DIMENSION(:,:,:)  :: VarIn
-    INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
-    
-    CALL reduce_sum_mpi_igen(VarIn,Varout,SIZE(VarIn))
-  
-  END SUBROUTINE reduce_sum_mpi_i3
-
-  SUBROUTINE reduce_sum_mpi_i4(VarIn, VarOut)
-    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
-    IMPLICIT NONE
-  
-    INTEGER,INTENT(IN),DIMENSION(:,:,:,:)  :: VarIn
-    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
-    
-    CALL reduce_sum_mpi_igen(VarIn,Varout,SIZE(VarIn))
-  
-  END SUBROUTINE reduce_sum_mpi_i4                  
-  
-  
-  SUBROUTINE reduce_sum_mpi_r(VarIn, VarOut)
-    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
-    IMPLICIT NONE
-  
-    REAL,INTENT(IN)  :: VarIn
-    REAL,INTENT(OUT) :: VarOut
-    REAL             :: VarIn_tmp(1)
-    REAL             :: VarOut_tmp(1)
-    
-    VarIn_tmp(1)=VarIn    
-    CALL reduce_sum_mpi_rgen(VarIn_tmp,Varout_tmp,1)
-    VarOut=VarOut_tmp(1)
-  
-  END SUBROUTINE reduce_sum_mpi_r
-
-  SUBROUTINE reduce_sum_mpi_r1(VarIn, VarOut)
-    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
-    IMPLICIT NONE
-  
-    REAL,INTENT(IN),DIMENSION(:)  :: VarIn
-    REAL,INTENT(OUT),DIMENSION(:) :: VarOut
-    
-    CALL reduce_sum_mpi_rgen(VarIn,Varout,SIZE(VarIn))
-     
-  END SUBROUTINE reduce_sum_mpi_r1
-
-  SUBROUTINE reduce_sum_mpi_r2(VarIn, VarOut)
-    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
-    IMPLICIT NONE
-  
-    REAL,INTENT(IN),DIMENSION(:,:)  :: VarIn
-    REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
-    
-    CALL reduce_sum_mpi_rgen(VarIn,Varout,SIZE(VarIn))
-  
-  END SUBROUTINE reduce_sum_mpi_r2
-
-  SUBROUTINE reduce_sum_mpi_r3(VarIn, VarOut)
-    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
-    IMPLICIT NONE
-  
-    REAL,INTENT(IN),DIMENSION(:,:,:)  :: VarIn
-    REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
-    
-    CALL reduce_sum_mpi_rgen(VarIn,Varout,SIZE(VarIn))
-  
-  END SUBROUTINE reduce_sum_mpi_r3
-
-  SUBROUTINE reduce_sum_mpi_r4(VarIn, VarOut)
-    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
-    IMPLICIT NONE
-  
-    REAL,INTENT(IN),DIMENSION(:,:,:,:)  :: VarIn
-    REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
-    
-    CALL reduce_sum_mpi_rgen(VarIn,Varout,SIZE(VarIn))
-  
-  END SUBROUTINE reduce_sum_mpi_r4 
-  
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!! Definition des reduce_min   --> 4D   !!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-  SUBROUTINE reduce_min_mpi_i(VarIn, VarOut)
-    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
-    IMPLICIT NONE
-  
-    INTEGER,INTENT(IN)  :: VarIn
-    INTEGER,INTENT(OUT) :: VarOut
-    INTEGER             :: VarIn_tmp(1)
-    INTEGER             :: VarOut_tmp(1)
-    
-    VarIn_tmp(1)=VarIn    
-    CALL reduce_min_mpi_igen(VarIn_tmp,Varout_tmp,1)
-    VarOut=VarOut_tmp(1)
-    
-  END SUBROUTINE reduce_min_mpi_i
-
-  SUBROUTINE reduce_min_mpi_i1(VarIn, VarOut)
-    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
-    IMPLICIT NONE
-  
-    INTEGER,INTENT(IN),DIMENSION(:)  :: VarIn
-    INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut
-    
-    CALL reduce_min_mpi_igen(VarIn,Varout,SIZE(VarIn))
-  
-  END SUBROUTINE reduce_min_mpi_i1
-
-  SUBROUTINE reduce_min_mpi_i2(VarIn, VarOut)
-    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
-    IMPLICIT NONE
-  
-    INTEGER,INTENT(IN),DIMENSION(:,:)  :: VarIn
-    INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
-    
-    CALL reduce_min_mpi_igen(VarIn,Varout,SIZE(VarIn))
-  
-  END SUBROUTINE reduce_min_mpi_i2
-
-  SUBROUTINE reduce_min_mpi_i3(VarIn, VarOut)
-    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
-    IMPLICIT NONE
-  
-    INTEGER,INTENT(IN),DIMENSION(:,:,:)  :: VarIn
-    INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
-    
-    CALL reduce_min_mpi_igen(VarIn,Varout,SIZE(VarIn))
-  
-  END SUBROUTINE reduce_min_mpi_i3
-
-  SUBROUTINE reduce_min_mpi_i4(VarIn, VarOut)
-    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
-    IMPLICIT NONE
-  
-    INTEGER,INTENT(IN),DIMENSION(:,:,:,:)  :: VarIn
-    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
-    
-    CALL reduce_min_mpi_igen(VarIn,Varout,SIZE(VarIn))
-  
-  END SUBROUTINE reduce_min_mpi_i4                  
-  
-  
-  SUBROUTINE reduce_min_mpi_r(VarIn, VarOut)
-    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
-    IMPLICIT NONE
-  
-    REAL,INTENT(IN)  :: VarIn
-    REAL,INTENT(OUT) :: VarOut
-    REAL             :: VarIn_tmp(1)
-    REAL             :: VarOut_tmp(1)
-    
-    VarIn_tmp(1)=VarIn    
-    CALL reduce_min_mpi_rgen(VarIn_tmp,Varout_tmp,1)
-    VarOut=VarOut_tmp(1)
-  
-  END SUBROUTINE reduce_min_mpi_r
-
-  SUBROUTINE reduce_min_mpi_r1(VarIn, VarOut)
-    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
-    IMPLICIT NONE
-  
-    REAL,INTENT(IN),DIMENSION(:)  :: VarIn
-    REAL,INTENT(OUT),DIMENSION(:) :: VarOut
-    
-    CALL reduce_min_mpi_rgen(VarIn,Varout,SIZE(VarIn))
-     
-  END SUBROUTINE reduce_min_mpi_r1
-
-  SUBROUTINE reduce_min_mpi_r2(VarIn, VarOut)
-    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
-    IMPLICIT NONE
-  
-    REAL,INTENT(IN),DIMENSION(:,:)  :: VarIn
-    REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
-    
-    CALL reduce_min_mpi_rgen(VarIn,Varout,SIZE(VarIn))
-  
-  END SUBROUTINE reduce_min_mpi_r2
-
-  SUBROUTINE reduce_min_mpi_r3(VarIn, VarOut)
-    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
-    IMPLICIT NONE
-  
-    REAL,INTENT(IN),DIMENSION(:,:,:)  :: VarIn
-    REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
-    
-    CALL reduce_min_mpi_rgen(VarIn,Varout,SIZE(VarIn))
-  
-  END SUBROUTINE reduce_min_mpi_r3
-
-  SUBROUTINE reduce_min_mpi_r4(VarIn, VarOut)
-    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
-    IMPLICIT NONE
-  
-    REAL,INTENT(IN),DIMENSION(:,:,:,:)  :: VarIn
-    REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
-    
-    CALL reduce_min_mpi_rgen(VarIn,Varout,SIZE(VarIn))
-  
-  END SUBROUTINE reduce_min_mpi_r4 
-
-
-
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!! SUBROUTINE grid1dTo2d  !!  
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-
-  SUBROUTINE grid1dTo2d_mpi_i(VarIn,VarOut)  
-  IMPLICIT NONE  
-    INTEGER,INTENT(IN),DIMENSION(:)     :: VarIn
-    INTEGER,INTENT(OUT),DIMENSION(:,:)  :: VarOut
-    
-    CALL grid1dTo2d_mpi_igen(VarIn,VarOut,1)
-  
-  END SUBROUTINE grid1dTo2d_mpi_i
-  
-
-  SUBROUTINE grid1dTo2d_mpi_i1(VarIn,VarOut)  
-  IMPLICIT NONE  
-    INTEGER,INTENT(IN),DIMENSION(:,:)     :: VarIn
-    INTEGER,INTENT(OUT),DIMENSION(:,:,:)  :: VarOut
-    
-    CALL grid1dTo2d_mpi_igen(VarIn,VarOut,size(VarIn,2))
-  
-  END SUBROUTINE grid1dTo2d_mpi_i1
-
-  SUBROUTINE grid1dTo2d_mpi_i2(VarIn,VarOut)  
-  IMPLICIT NONE  
-    INTEGER,INTENT(IN),DIMENSION(:,:,:)     :: VarIn
-    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:)  :: VarOut
-    
-    CALL grid1dTo2d_mpi_igen(VarIn,VarOut,size(VarIn,2)*size(VarIn,3))
-  
-  END SUBROUTINE grid1dTo2d_mpi_i2
-  
-  SUBROUTINE grid1dTo2d_mpi_i3(VarIn,VarOut)  
-  IMPLICIT NONE  
-    INTEGER,INTENT(IN),DIMENSION(:,:,:,:)     :: VarIn
-    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:,:)  :: VarOut
-    
-    CALL grid1dTo2d_mpi_igen(VarIn,VarOut,size(VarIn,2)*size(VarIn,3)*size(VarIn,4))
-  
-  END SUBROUTINE grid1dTo2d_mpi_i3
-
-
-  SUBROUTINE grid1dTo2d_mpi_r(VarIn,VarOut)  
-  IMPLICIT NONE  
-    REAL,INTENT(IN),DIMENSION(:)     :: VarIn
-    REAL,INTENT(OUT),DIMENSION(:,:)  :: VarOut
-    
-    CALL grid1dTo2d_mpi_rgen(VarIn,VarOut,1)
-  
-  END SUBROUTINE grid1dTo2d_mpi_r
-  
-
-  SUBROUTINE grid1dTo2d_mpi_r1(VarIn,VarOut)  
-  IMPLICIT NONE  
-    REAL,INTENT(IN),DIMENSION(:,:)     :: VarIn
-    REAL,INTENT(OUT),DIMENSION(:,:,:)  :: VarOut
-    
-    CALL grid1dTo2d_mpi_rgen(VarIn,VarOut,size(VarIn,2))
-  
-  END SUBROUTINE grid1dTo2d_mpi_r1
-
-  SUBROUTINE grid1dTo2d_mpi_r2(VarIn,VarOut)  
-  IMPLICIT NONE  
-    REAL,INTENT(IN),DIMENSION(:,:,:)     :: VarIn
-    REAL,INTENT(OUT),DIMENSION(:,:,:,:)  :: VarOut
-    
-    CALL grid1dTo2d_mpi_rgen(VarIn,VarOut,size(VarIn,2)*size(VarIn,3))
-  
-  END SUBROUTINE grid1dTo2d_mpi_r2
-  
-  SUBROUTINE grid1dTo2d_mpi_r3(VarIn,VarOut)  
-  IMPLICIT NONE  
-    REAL,INTENT(IN),DIMENSION(:,:,:,:)     :: VarIn
-    REAL,INTENT(OUT),DIMENSION(:,:,:,:,:)  :: VarOut
-    
-    CALL grid1dTo2d_mpi_rgen(VarIn,VarOut,size(VarIn,2)*size(VarIn,3)*size(VarIn,4))
-  
-  END SUBROUTINE grid1dTo2d_mpi_r3
-  
-  
-  
-  SUBROUTINE grid1dTo2d_mpi_l(VarIn,VarOut)  
-  IMPLICIT NONE  
-    LOGICAL,INTENT(IN),DIMENSION(:)     :: VarIn
-    LOGICAL,INTENT(OUT),DIMENSION(:,:)  :: VarOut
-    
-    CALL grid1dTo2d_mpi_lgen(VarIn,VarOut,1)
-  
-  END SUBROUTINE grid1dTo2d_mpi_l
-  
-
-  SUBROUTINE grid1dTo2d_mpi_l1(VarIn,VarOut)  
-  IMPLICIT NONE  
-    LOGICAL,INTENT(IN),DIMENSION(:,:)     :: VarIn
-    LOGICAL,INTENT(OUT),DIMENSION(:,:,:)  :: VarOut
-    
-    CALL grid1dTo2d_mpi_lgen(VarIn,VarOut,size(VarIn,2))
-  
-  END SUBROUTINE grid1dTo2d_mpi_l1
-
-  SUBROUTINE grid1dTo2d_mpi_l2(VarIn,VarOut)  
-  IMPLICIT NONE  
-    LOGICAL,INTENT(IN),DIMENSION(:,:,:)     :: VarIn
-    LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:)  :: VarOut
-    
-    CALL grid1dTo2d_mpi_lgen(VarIn,VarOut,size(VarIn,2)*size(VarIn,3))
-  
-  END SUBROUTINE grid1dTo2d_mpi_l2
-  
-  SUBROUTINE grid1dTo2d_mpi_l3(VarIn,VarOut)  
-  IMPLICIT NONE  
-    LOGICAL,INTENT(IN),DIMENSION(:,:,:,:)     :: VarIn
-    LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:,:)  :: VarOut
-    
-    CALL grid1dTo2d_mpi_lgen(VarIn,VarOut,size(VarIn,2)*size(VarIn,3)*size(VarIn,4))
-  
-  END SUBROUTINE grid1dTo2d_mpi_l3
-
-
-  SUBROUTINE grid2dTo1d_mpi_i(VarIn,VarOut)  
-  IMPLICIT NONE  
-    INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn
-    INTEGER,INTENT(OUT),DIMENSION(:)  :: VarOut
-    
-    CALL grid2dTo1d_mpi_igen(VarIn,VarOut,1)
-  
-  END SUBROUTINE grid2dTo1d_mpi_i
-  
-
-  SUBROUTINE grid2dTo1d_mpi_i1(VarIn,VarOut)  
-  IMPLICIT NONE  
-    INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn
-    INTEGER,INTENT(OUT),DIMENSION(:,:)  :: VarOut
-    
-    CALL grid2dTo1d_mpi_igen(VarIn,VarOut,size(VarIn,3))
-  
-  END SUBROUTINE grid2dTo1d_mpi_i1
-
-  SUBROUTINE grid2dTo1d_mpi_i2(VarIn,VarOut)  
-  IMPLICIT NONE  
-    INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
-    INTEGER,INTENT(OUT),DIMENSION(:,:,:)  :: VarOut
-    
-    CALL grid2dTo1d_mpi_igen(VarIn,VarOut,size(VarIn,3)*size(VarIn,4))
-  
-  END SUBROUTINE grid2dTo1d_mpi_i2
-  
-  SUBROUTINE grid2dTo1d_mpi_i3(VarIn,VarOut)  
-  IMPLICIT NONE  
-    INTEGER,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn
-    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:)  :: VarOut
-    
-    CALL grid2dTo1d_mpi_igen(VarIn,VarOut,size(VarIn,3)*size(VarIn,4)*size(VarIn,5))
-  
-  END SUBROUTINE grid2dTo1d_mpi_i3
- 
-
-
-
-  SUBROUTINE grid2dTo1d_mpi_r(VarIn,VarOut)  
-  IMPLICIT NONE  
-    REAL,INTENT(IN),DIMENSION(:,:) :: VarIn
-    REAL,INTENT(OUT),DIMENSION(:)  :: VarOut
-    
-    CALL grid2dTo1d_mpi_rgen(VarIn,VarOut,1)
-  
-  END SUBROUTINE grid2dTo1d_mpi_r
-  
-
-  SUBROUTINE grid2dTo1d_mpi_r1(VarIn,VarOut)  
-  IMPLICIT NONE  
-    REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
-    REAL,INTENT(OUT),DIMENSION(:,:)  :: VarOut
-    
-    CALL grid2dTo1d_mpi_rgen(VarIn,VarOut,size(VarIn,3))
-  
-  END SUBROUTINE grid2dTo1d_mpi_r1
-
-  SUBROUTINE grid2dTo1d_mpi_r2(VarIn,VarOut)  
-  IMPLICIT NONE  
-    REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
-    REAL,INTENT(OUT),DIMENSION(:,:,:)  :: VarOut
-    
-    CALL grid2dTo1d_mpi_rgen(VarIn,VarOut,size(VarIn,3)*size(VarIn,4))
-  
-  END SUBROUTINE grid2dTo1d_mpi_r2
-  
-  SUBROUTINE grid2dTo1d_mpi_r3(VarIn,VarOut)  
-  IMPLICIT NONE  
-    REAL,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn
-    REAL,INTENT(OUT),DIMENSION(:,:,:,:)  :: VarOut
-    
-    CALL grid2dTo1d_mpi_rgen(VarIn,VarOut,size(VarIn,3)*size(VarIn,4)*size(VarIn,5))
-  
-  END SUBROUTINE grid2dTo1d_mpi_r3
-
-
-
-  SUBROUTINE grid2dTo1d_mpi_l(VarIn,VarOut)  
-  IMPLICIT NONE  
-    LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn
-    LOGICAL,INTENT(OUT),DIMENSION(:)  :: VarOut
-    
-    CALL grid2dTo1d_mpi_lgen(VarIn,VarOut,1)
-  
-  END SUBROUTINE grid2dTo1d_mpi_l
-  
-
-  SUBROUTINE grid2dTo1d_mpi_l1(VarIn,VarOut)  
-  IMPLICIT NONE  
-    LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
-    LOGICAL,INTENT(OUT),DIMENSION(:,:)  :: VarOut
-    
-    CALL grid2dTo1d_mpi_lgen(VarIn,VarOut,size(VarIn,3))
-  
-  END SUBROUTINE grid2dTo1d_mpi_l1
-
-
-
-  SUBROUTINE grid2dTo1d_mpi_l2(VarIn,VarOut)  
-  IMPLICIT NONE  
-    LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
-    LOGICAL,INTENT(OUT),DIMENSION(:,:,:)  :: VarOut
-    
-    CALL grid2dTo1d_mpi_lgen(VarIn,VarOut,size(VarIn,3)*size(VarIn,4))
-  
-  END SUBROUTINE grid2dTo1d_mpi_l2
-
-  
-  SUBROUTINE grid2dTo1d_mpi_l3(VarIn,VarOut)  
-  IMPLICIT NONE  
-    LOGICAL,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn
-    LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:)  :: VarOut
-    
-    CALL grid2dTo1d_mpi_lgen(VarIn,VarOut,size(VarIn,3)*size(VarIn,4)*size(VarIn,5))
-  
-  END SUBROUTINE grid2dTo1d_mpi_l3
-
-               
-
-
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!! DEFINITION DES FONCTIONS DE TRANSFERT GENERIQUES !
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-  SUBROUTINE bcast_mpi_cgen(var,nb)
-    USE mod_phys_lmdz_mpi_data 
-    USE lmdz_mpi
-    IMPLICIT NONE
-    
-    CHARACTER(LEN=*),INTENT(INOUT) :: Var
-    INTEGER,INTENT(IN) :: nb
-    
-    INTEGER :: ierr
-
-    IF (.not.is_using_mpi) RETURN
-    
-    CALL MPI_BCAST(Var,nb,MPI_CHARACTER,mpi_master,COMM_LMDZ_PHY,ierr)
-        
-  END SUBROUTINE bcast_mpi_cgen
-
-
-      
-  SUBROUTINE bcast_mpi_igen(var,nb)
-    USE mod_phys_lmdz_mpi_data
-    USE lmdz_mpi
-    IMPLICIT NONE
-    
-    INTEGER,INTENT(IN) :: nb
-    INTEGER,DIMENSION(nb),INTENT(INOUT) :: Var
-    
-    INTEGER :: ierr
-
-    IF (.not.is_using_mpi) RETURN
-
-    CALL MPI_BCAST(Var,nb,MPI_INTEGER,mpi_master,COMM_LMDZ_PHY,ierr)
-        
-  END SUBROUTINE bcast_mpi_igen
-
-
-
-  
-  SUBROUTINE bcast_mpi_rgen(var,nb)
-    USE mod_phys_lmdz_mpi_data
-    USE lmdz_mpi
-    IMPLICIT NONE
-    
-    INTEGER,INTENT(IN) :: nb
-    REAL,DIMENSION(nb),INTENT(INOUT) :: Var
-    
-    INTEGER :: ierr
-
-    IF (.not.is_using_mpi) RETURN
-
-    CALL MPI_BCAST(Var,nb,MPI_REAL_LMDZ,mpi_master,COMM_LMDZ_PHY,ierr)
-    
-  END SUBROUTINE bcast_mpi_rgen
-  
-
-
-
-  SUBROUTINE bcast_mpi_lgen(var,nb)
-    USE mod_phys_lmdz_mpi_data
-    USE lmdz_mpi
-    IMPLICIT NONE
-    
-    INTEGER,INTENT(IN) :: nb
-    LOGICAL,DIMENSION(nb),INTENT(INOUT) :: Var
-    
-    INTEGER :: ierr
-
-    IF (.not.is_using_mpi) RETURN
-
-    CALL MPI_BCAST(Var,nb,MPI_LOGICAL,mpi_master,COMM_LMDZ_PHY,ierr)
-
-  END SUBROUTINE bcast_mpi_lgen
-
-  
-
-  SUBROUTINE scatter_mpi_igen(VarIn, VarOut, dimsize)
-    USE mod_phys_lmdz_mpi_data 
-    USE mod_grid_phy_lmdz
-    USE lmdz_mpi
-    IMPLICIT NONE
-  
-    INTEGER,INTENT(IN) :: dimsize
-    INTEGER,INTENT(IN),DIMENSION(klon_glo,dimsize) :: VarIn
-    INTEGER,INTENT(OUT),DIMENSION(klon_mpi,dimsize) :: VarOut
-  
-    INTEGER,DIMENSION(0:mpi_size-1) :: displs
-    INTEGER,DIMENSION(0:mpi_size-1) :: counts
-    INTEGER,DIMENSION(dimsize*klon_glo) :: VarTmp
-    INTEGER :: nb,i,index,rank
-    INTEGER :: ierr
-
-
-    IF (.not.is_using_mpi) THEN
-      VarOut(:,:)=VarIn(:,:)
-      RETURN
-    ENDIF
-
-    
-    IF (is_mpi_root) THEN
-      Index=1
-      DO rank=0,mpi_size-1
-        nb=klon_mpi_para_nb(rank)
-        displs(rank)=Index-1
-        counts(rank)=nb*dimsize
-        DO i=1,dimsize
-          VarTmp(Index:Index+nb-1)=VarIn(klon_mpi_para_begin(rank):klon_mpi_para_end(rank),i)
-          Index=Index+nb
-        ENDDO
-      ENDDO
-    ENDIF
-      
-    CALL MPI_SCATTERV(VarTmp,counts,displs,MPI_INTEGER,VarOut,klon_mpi*dimsize,   &
-                      MPI_INTEGER,mpi_master, COMM_LMDZ_PHY,ierr)
-
-  END SUBROUTINE scatter_mpi_igen
-
-  SUBROUTINE scatter_mpi_rgen(VarIn, VarOut, dimsize)
-    USE mod_phys_lmdz_mpi_data 
-    USE mod_grid_phy_lmdz
-    USE lmdz_mpi
-    IMPLICIT NONE
-  
-    INTEGER,INTENT(IN) :: dimsize
-    REAL,INTENT(IN),DIMENSION(klon_glo,dimsize) :: VarIn
-    REAL,INTENT(OUT),DIMENSION(klon_mpi,dimsize) :: VarOut
-
-    INTEGER,DIMENSION(0:mpi_size-1) :: displs
-    INTEGER,DIMENSION(0:mpi_size-1) :: counts
-    REAL,DIMENSION(dimsize*klon_glo) :: VarTmp
-    INTEGER :: nb,i,index,rank
-    INTEGER :: ierr
-
-    IF (.not.is_using_mpi) THEN
-      VarOut(:,:)=VarIn(:,:)
-      RETURN
-    ENDIF
-    
-    IF (is_mpi_root) THEN
-      Index=1
-      DO rank=0,mpi_size-1
-        nb=klon_mpi_para_nb(rank)
-        displs(rank)=Index-1
-        counts(rank)=nb*dimsize
-        DO i=1,dimsize
-          VarTmp(Index:Index+nb-1)=VarIn(klon_mpi_para_begin(rank):klon_mpi_para_end(rank),i)
-          Index=Index+nb
-        ENDDO
-      ENDDO
-    ENDIF
-      
-    CALL MPI_SCATTERV(VarTmp,counts,displs,MPI_REAL_LMDZ,VarOut,klon_mpi*dimsize,   &
-                      MPI_REAL_LMDZ,mpi_master, COMM_LMDZ_PHY,ierr)
-
-  END SUBROUTINE scatter_mpi_rgen
-
-  
-  SUBROUTINE scatter_mpi_lgen(VarIn, VarOut, dimsize)
-    USE mod_phys_lmdz_mpi_data 
-    USE mod_grid_phy_lmdz
-    USE lmdz_mpi
-    IMPLICIT NONE
-  
-    INTEGER,INTENT(IN) :: dimsize
-    LOGICAL,INTENT(IN),DIMENSION(klon_glo,dimsize) :: VarIn
-    LOGICAL,INTENT(OUT),DIMENSION(klon_mpi,dimsize) :: VarOut
-  
-
-    INTEGER,DIMENSION(0:mpi_size-1) :: displs
-    INTEGER,DIMENSION(0:mpi_size-1) :: counts
-    LOGICAL,DIMENSION(dimsize*klon_glo) :: VarTmp
-    INTEGER :: nb,i,index,rank
-    INTEGER :: ierr
-
-    IF (.not.is_using_mpi) THEN
-      VarOut(:,:)=VarIn(:,:)
-      RETURN
-    ENDIF
-    
-    IF (is_mpi_root) THEN
-      Index=1
-      DO rank=0,mpi_size-1
-        nb=klon_mpi_para_nb(rank)
-        displs(rank)=Index-1
-        counts(rank)=nb*dimsize
-        DO i=1,dimsize
-          VarTmp(Index:Index+nb-1)=VarIn(klon_mpi_para_begin(rank):klon_mpi_para_end(rank),i)
-          Index=Index+nb
-        ENDDO
-      ENDDO
-    ENDIF
-      
-    CALL MPI_SCATTERV(VarTmp,counts,displs,MPI_LOGICAL,VarOut,klon_mpi*dimsize,   &
-                      MPI_LOGICAL,mpi_master, COMM_LMDZ_PHY,ierr)
-
-  END SUBROUTINE scatter_mpi_lgen  
-
-
-
-
-  SUBROUTINE gather_mpi_igen(VarIn, VarOut, dimsize)
-    USE mod_phys_lmdz_mpi_data
-    USE mod_grid_phy_lmdz
-    USE lmdz_mpi
-    IMPLICIT NONE
-  
-    INTEGER,INTENT(IN) :: dimsize
-    INTEGER,INTENT(IN),DIMENSION(klon_mpi,dimsize) :: VarIn
-    INTEGER,INTENT(OUT),DIMENSION(klon_glo,dimsize) :: VarOut
-  
-    INTEGER,DIMENSION(0:mpi_size-1) :: displs
-    INTEGER,DIMENSION(0:mpi_size-1) :: counts
-    INTEGER,DIMENSION(dimsize*klon_glo) :: VarTmp
-    INTEGER :: nb,i,index,rank
-    INTEGER :: ierr
-
-    IF (.not.is_using_mpi) THEN
-      VarOut(:,:)=VarIn(:,:)
-      RETURN
-    ENDIF
-
-    IF (is_mpi_root) THEN
-      Index=1
-      DO rank=0,mpi_size-1
-        nb=klon_mpi_para_nb(rank)
-        displs(rank)=Index-1
-        counts(rank)=nb*dimsize
-        Index=Index+nb*dimsize
-      ENDDO
-     
-    ENDIF
-    
-    CALL MPI_GATHERV(VarIn,klon_mpi*dimsize,MPI_INTEGER,VarTmp,counts,displs,   &
-                     MPI_INTEGER,mpi_master, COMM_LMDZ_PHY,ierr)
-
-                          
-    IF (is_mpi_root) THEN
-      Index=1
-      DO rank=0,mpi_size-1
-        nb=klon_mpi_para_nb(rank)
-        DO i=1,dimsize
-          VarOut(klon_mpi_para_begin(rank):klon_mpi_para_end(rank),i)=VarTmp(Index:Index+nb-1)
-          Index=Index+nb
-        ENDDO
-      ENDDO
-    ENDIF
-
-  END SUBROUTINE gather_mpi_igen  
-
-  SUBROUTINE gather_mpi_rgen(VarIn, VarOut, dimsize)
-    USE mod_phys_lmdz_mpi_data 
-    USE mod_grid_phy_lmdz
-    USE lmdz_mpi
-    IMPLICIT NONE
-  
-    INTEGER,INTENT(IN) :: dimsize
-    REAL,INTENT(IN),DIMENSION(klon_mpi,dimsize) :: VarIn
-    REAL,INTENT(OUT),DIMENSION(klon_glo,dimsize) :: VarOut
-  
-    INTEGER,DIMENSION(0:mpi_size-1) :: displs
-    INTEGER,DIMENSION(0:mpi_size-1) :: counts
-    REAL,DIMENSION(dimsize*klon_glo) :: VarTmp
-    INTEGER :: nb,i,index,rank
-    INTEGER :: ierr
-
-    IF (is_mpi_root) THEN
-      Index=1
-      DO rank=0,mpi_size-1
-        nb=klon_mpi_para_nb(rank)
-        displs(rank)=Index-1
-        counts(rank)=nb*dimsize
-        Index=Index+nb*dimsize
-      ENDDO
-    ENDIF
-    
-    IF (.not.is_using_mpi) THEN
-      VarOut(:,:)=VarIn(:,:)
-      RETURN
-    ENDIF
-
-    CALL MPI_GATHERV(VarIn,klon_mpi*dimsize,MPI_REAL_LMDZ,VarTmp,counts,displs,   &
-                      MPI_REAL_LMDZ,mpi_master, COMM_LMDZ_PHY,ierr)
-                          
-    IF (is_mpi_root) THEN
-      Index=1
-      DO rank=0,mpi_size-1
-        nb=klon_mpi_para_nb(rank)
-        DO i=1,dimsize
-          VarOut(klon_mpi_para_begin(rank):klon_mpi_para_end(rank),i)=VarTmp(Index:Index+nb-1)
-          Index=Index+nb
-        ENDDO
-      ENDDO
-    ENDIF
-
-  END SUBROUTINE gather_mpi_rgen  
-
-  SUBROUTINE gather_mpi_lgen(VarIn, VarOut, dimsize)
-    USE mod_phys_lmdz_mpi_data
-    USE mod_grid_phy_lmdz
-    USE lmdz_mpi
-    IMPLICIT NONE
-  
-    INTEGER,INTENT(IN) :: dimsize
-    LOGICAL,INTENT(IN),DIMENSION(klon_mpi,dimsize) :: VarIn
-    LOGICAL,INTENT(OUT),DIMENSION(klon_glo,dimsize) :: VarOut
-
-    INTEGER,DIMENSION(0:mpi_size-1) :: displs
-    INTEGER,DIMENSION(0:mpi_size-1) :: counts
-    LOGICAL,DIMENSION(dimsize*klon_glo) :: VarTmp
-    INTEGER :: nb,i,index,rank
-    INTEGER :: ierr
-    
-    IF (.not.is_using_mpi) THEN
-      VarOut(:,:)=VarIn(:,:)
-      RETURN
-    ENDIF
-
-    IF (is_mpi_root) THEN
-      Index=1
-      DO rank=0,mpi_size-1
-        nb=klon_mpi_para_nb(rank)
-        displs(rank)=Index-1
-        counts(rank)=nb*dimsize
-        Index=Index+nb*dimsize
-      ENDDO
-    ENDIF
-    
-
-    CALL MPI_GATHERV(VarIn,klon_mpi*dimsize,MPI_LOGICAL,VarTmp,counts,displs,   &
-                      MPI_LOGICAL,mpi_master, COMM_LMDZ_PHY,ierr)
-                          
-    IF (is_mpi_root) THEN
-      Index=1
-      DO rank=0,mpi_size-1
-        nb=klon_mpi_para_nb(rank)
-        DO i=1,dimsize
-          VarOut(klon_mpi_para_begin(rank):klon_mpi_para_end(rank),i)=VarTmp(Index:Index+nb-1)
-          Index=Index+nb
-        ENDDO
-      ENDDO
-    ENDIF
-
-  END SUBROUTINE gather_mpi_lgen
-  
-
-
-  SUBROUTINE reduce_sum_mpi_igen(VarIn,VarOut,nb)
-    USE mod_phys_lmdz_mpi_data 
-    USE mod_grid_phy_lmdz
-    USE lmdz_mpi
-    IMPLICIT NONE
-   
-    INTEGER,INTENT(IN) :: nb
-    INTEGER,DIMENSION(nb),INTENT(IN) :: VarIn
-    INTEGER,DIMENSION(nb),INTENT(OUT) :: VarOut    
-    INTEGER :: ierr
-   
-    IF (.not.is_using_mpi) THEN
-      VarOut(:)=VarIn(:)
-      RETURN
-    ENDIF
-
-
-    CALL MPI_REDUCE(VarIn,VarOut,nb,MPI_INTEGER,MPI_SUM,mpi_master,COMM_LMDZ_PHY,ierr)
-            
-  END SUBROUTINE reduce_sum_mpi_igen
-  
-  SUBROUTINE reduce_sum_mpi_rgen(VarIn,VarOut,nb)
-    USE mod_phys_lmdz_mpi_data 
-    USE mod_grid_phy_lmdz
-    USE lmdz_mpi
-    IMPLICIT NONE
-
-    INTEGER,INTENT(IN) :: nb
-    REAL,DIMENSION(nb),INTENT(IN) :: VarIn
-    REAL,DIMENSION(nb),INTENT(OUT) :: VarOut    
-    INTEGER :: ierr
- 
-    IF (.not.is_using_mpi) THEN
-      VarOut(:)=VarIn(:)
-      RETURN
-    ENDIF
-   
-    CALL MPI_REDUCE(VarIn,VarOut,nb,MPI_REAL_LMDZ,MPI_SUM,mpi_master,COMM_LMDZ_PHY,ierr)
-        
-  END SUBROUTINE reduce_sum_mpi_rgen
-
-
-
-  SUBROUTINE reduce_min_mpi_igen(VarIn,VarOut,nb)
-    USE mod_phys_lmdz_mpi_data 
-    USE mod_grid_phy_lmdz
-    USE lmdz_mpi
-    IMPLICIT NONE
-    
-    INTEGER,INTENT(IN) :: nb
-    INTEGER,DIMENSION(nb),INTENT(IN) :: VarIn
-    INTEGER,DIMENSION(nb),INTENT(OUT) :: VarOut    
-    INTEGER :: ierr
-   
-    IF (.not.is_using_mpi) THEN
-      VarOut(:)=VarIn(:)
-      RETURN
-    ENDIF
-
-
-    CALL MPI_REDUCE(VarIn,VarOut,nb,MPI_INTEGER,MPI_MIN,mpi_master,COMM_LMDZ_PHY,ierr)
-            
-  END SUBROUTINE reduce_min_mpi_igen
-  
-  SUBROUTINE reduce_min_mpi_rgen(VarIn,VarOut,nb)
-    USE mod_phys_lmdz_mpi_data 
-    USE mod_grid_phy_lmdz
-    USE lmdz_mpi
-
-    IMPLICIT NONE
-
-    INTEGER,INTENT(IN) :: nb
-    REAL,DIMENSION(nb),INTENT(IN) :: VarIn
-    REAL,DIMENSION(nb),INTENT(OUT) :: VarOut    
-    INTEGER :: ierr
- 
-    IF (.not.is_using_mpi) THEN
-      VarOut(:)=VarIn(:)
-      RETURN
-    ENDIF
-   
-    CALL MPI_REDUCE(VarIn,VarOut,nb,MPI_REAL_LMDZ,MPI_MIN,mpi_master,COMM_LMDZ_PHY,ierr)
-        
-  END SUBROUTINE reduce_min_mpi_rgen
-
-
-
-
-
-
-
-  SUBROUTINE grid1dTo2d_mpi_igen(VarIn,VarOut,dimsize)
-    USE mod_phys_lmdz_mpi_data
-    USE mod_grid_phy_lmdz
-    IMPLICIT NONE
-    
-    INTEGER,INTENT(IN) :: dimsize
-    INTEGER,INTENT(IN) ,DIMENSION(klon_mpi,dimsize)       :: VarIn
-    INTEGER,INTENT(OUT),DIMENSION(nbp_lon*jj_nb,dimsize)  :: VarOut
-    INTEGER :: i,ij,Offset
-
-    
-    VarOut(1:nbp_lon,:)=0
-    VarOut(nbp_lon*(jj_nb-1)+1:nbp_lon*jj_nb,:)=0
-    
-    offset=ii_begin
-    IF (is_north_pole_dyn) Offset=nbp_lon
-    
-    
-    DO i=1,dimsize
-      DO ij=1,klon_mpi
-        VarOut(ij+offset-1,i)=VarIn(ij,i)
-      ENDDO
-    ENDDO
-    
-    
-    IF (is_north_pole_dyn) THEN 
-      DO i=1,dimsize
-        DO ij=1,nbp_lon
-         VarOut(ij,i)=VarIn(1,i)
-        ENDDO
-      ENDDO
-    ENDIF
-    
-    IF (is_south_pole_dyn) THEN 
-      DO i=1,dimsize
-        DO ij=nbp_lon*(jj_nb-1)+1,nbp_lon*jj_nb
-         VarOut(ij,i)=VarIn(klon_mpi,i)
-        ENDDO
-      ENDDO
-    ENDIF
-
-  END SUBROUTINE grid1dTo2d_mpi_igen   
-
-
-  SUBROUTINE grid1dTo2d_mpi_rgen(VarIn,VarOut,dimsize)
-    USE mod_phys_lmdz_mpi_data
-    USE mod_grid_phy_lmdz
-    IMPLICIT NONE
-    
-    INTEGER,INTENT(IN) :: dimsize
-    REAL,INTENT(IN) ,DIMENSION(klon_mpi,dimsize)       :: VarIn
-    REAL,INTENT(OUT),DIMENSION(nbp_lon*jj_nb,dimsize)  :: VarOut
-    INTEGER :: i,ij,Offset
-
-    
-    VarOut(1:nbp_lon,:)=0
-    VarOut(nbp_lon*(jj_nb-1)+1:nbp_lon*jj_nb,:)=0
-    
-    offset=ii_begin
-    IF (is_north_pole_dyn) Offset=nbp_lon
-    
-    
-    DO i=1,dimsize
-      DO ij=1,klon_mpi
-        VarOut(ij+offset-1,i)=VarIn(ij,i)
-      ENDDO
-    ENDDO
-    
-    
-    IF (is_north_pole_dyn) THEN 
-      DO i=1,dimsize
-        DO ij=1,nbp_lon
-         VarOut(ij,i)=VarIn(1,i)
-        ENDDO
-      ENDDO
-    ENDIF
-    
-    IF (is_south_pole_dyn) THEN 
-      DO i=1,dimsize
-        DO ij=nbp_lon*(jj_nb-1)+1,nbp_lon*jj_nb
-         VarOut(ij,i)=VarIn(klon_mpi,i)
-        ENDDO
-      ENDDO
-    ENDIF
-
-   END SUBROUTINE grid1dTo2d_mpi_rgen   
-
-
-
-  SUBROUTINE grid1dTo2d_mpi_lgen(VarIn,VarOut,dimsize)
-    USE mod_phys_lmdz_mpi_data
-    USE mod_grid_phy_lmdz
-    IMPLICIT NONE
-    
-    INTEGER,INTENT(IN) :: dimsize
-    LOGICAL,INTENT(IN) ,DIMENSION(klon_mpi,dimsize)       :: VarIn
-    LOGICAL,INTENT(OUT),DIMENSION(nbp_lon*jj_nb,dimsize)  :: VarOut
-    INTEGER :: i,ij,Offset
-
-    
-    VarOut(1:nbp_lon,:)=.FALSE.
-    VarOut(nbp_lon*(jj_nb-1)+1:nbp_lon*jj_nb,:)=.FALSE.
-    
-    offset=ii_begin
-    IF (is_north_pole_dyn) Offset=nbp_lon
-    
-    
-    DO i=1,dimsize
-      DO ij=1,klon_mpi
-        VarOut(ij+offset-1,i)=VarIn(ij,i)
-      ENDDO
-    ENDDO
-    
-    
-    IF (is_north_pole_dyn) THEN 
-      DO i=1,dimsize
-        DO ij=1,nbp_lon
-         VarOut(ij,i)=VarIn(1,i)
-        ENDDO
-      ENDDO
-    ENDIF
-    
-    IF (is_south_pole_dyn) THEN 
-      DO i=1,dimsize
-        DO ij=nbp_lon*(jj_nb-1)+1,nbp_lon*jj_nb
-         VarOut(ij,i)=VarIn(klon_mpi,i)
-        ENDDO
-      ENDDO
-    ENDIF
-
-   END SUBROUTINE grid1dTo2d_mpi_lgen   
-
-  
-
-
-  SUBROUTINE grid2dTo1d_mpi_igen(VarIn,VarOut,dimsize)
-    USE mod_phys_lmdz_mpi_data
-    USE mod_grid_phy_lmdz
-    IMPLICIT NONE
-    
-    INTEGER,INTENT(IN) :: dimsize
-    INTEGER,INTENT(IN) ,DIMENSION(nbp_lon*jj_nb,dimsize) :: VarIn
-    INTEGER,INTENT(OUT),DIMENSION(klon_mpi,dimsize)      :: VarOut
-    INTEGER :: i,ij,offset
-
-    offset=ii_begin
-    IF (is_north_pole_dyn) offset=nbp_lon
-
-    DO i=1,dimsize
-      DO ij=1,klon_mpi
-        VarOut(ij,i)=VarIn(ij+offset-1,i)
-      ENDDO
-    ENDDO
-
-    IF (is_north_pole_dyn) THEN 
-      DO i=1,dimsize
-        VarOut(1,i)=VarIn(1,i)
-      ENDDO
-    ENDIF
-    
-    
-  END SUBROUTINE grid2dTo1d_mpi_igen   
-
-
-
-  SUBROUTINE grid2dTo1d_mpi_rgen(VarIn,VarOut,dimsize)
-    USE mod_phys_lmdz_mpi_data
-    USE mod_grid_phy_lmdz
-    IMPLICIT NONE
-    
-    INTEGER,INTENT(IN) :: dimsize
-    REAL,INTENT(IN) ,DIMENSION(nbp_lon*jj_nb,dimsize) :: VarIn
-    REAL,INTENT(OUT),DIMENSION(klon_mpi,dimsize)      :: VarOut
-    INTEGER :: i,ij,offset
-
-    offset=ii_begin
-    IF (is_north_pole_dyn) offset=nbp_lon
-
-    DO i=1,dimsize
-      DO ij=1,klon_mpi
-        VarOut(ij,i)=VarIn(ij+offset-1,i)
-      ENDDO
-    ENDDO
-
-    IF (is_north_pole_dyn) THEN 
-      DO i=1,dimsize
-         VarOut(1,i)=VarIn(1,i)
-      ENDDO
-    ENDIF
-    
-    
-  END SUBROUTINE grid2dTo1d_mpi_rgen   
-  
-
-  SUBROUTINE grid2dTo1d_mpi_lgen(VarIn,VarOut,dimsize)
-    USE mod_phys_lmdz_mpi_data
-    USE mod_grid_phy_lmdz
-    IMPLICIT NONE
-    
-    INTEGER,INTENT(IN) :: dimsize
-    LOGICAL,INTENT(IN) ,DIMENSION(nbp_lon*jj_nb,dimsize) :: VarIn
-    LOGICAL,INTENT(OUT),DIMENSION(klon_mpi,dimsize)      :: VarOut
-    INTEGER :: i,ij,offset
-
-    offset=ii_begin
-    IF (is_north_pole_dyn) offset=nbp_lon
-
-    DO i=1,dimsize
-      DO ij=1,klon_mpi
-        VarOut(ij,i)=VarIn(ij+offset-1,i)
-      ENDDO
-    ENDDO
-
-    IF (is_north_pole_dyn) THEN 
-      DO i=1,dimsize
-        VarOut(1,i)=VarIn(1,i)
-      ENDDO
-    ENDIF
-    
-    
-  END SUBROUTINE grid2dTo1d_mpi_lgen   
-
-END MODULE mod_phys_lmdz_mpi_transfert
-
Index: /LMDZ6/trunk/libf/phy_common/mod_phys_lmdz_mpi_transfert.f90
===================================================================
--- /LMDZ6/trunk/libf/phy_common/mod_phys_lmdz_mpi_transfert.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phy_common/mod_phys_lmdz_mpi_transfert.f90	(revision 5268)
@@ -0,0 +1,2025 @@
+!
+!$Id$
+!
+MODULE mod_phys_lmdz_mpi_transfert
+
+
+  INTERFACE bcast_mpi
+    MODULE PROCEDURE bcast_mpi_c,                                                     &
+                     bcast_mpi_i,bcast_mpi_i1,bcast_mpi_i2,bcast_mpi_i3,bcast_mpi_i4, &
+                     bcast_mpi_r,bcast_mpi_r1,bcast_mpi_r2,bcast_mpi_r3,bcast_mpi_r4, &
+                     bcast_mpi_l,bcast_mpi_l1,bcast_mpi_l2,bcast_mpi_l3,bcast_mpi_l4
+  END INTERFACE
+
+  INTERFACE scatter_mpi
+    MODULE PROCEDURE scatter_mpi_i,scatter_mpi_i1,scatter_mpi_i2,scatter_mpi_i3, &
+                     scatter_mpi_r,scatter_mpi_r1,scatter_mpi_r2,scatter_mpi_r3, &
+                     scatter_mpi_l,scatter_mpi_l1,scatter_mpi_l2,scatter_mpi_l3
+  END INTERFACE
+
+  
+  INTERFACE gather_mpi
+    MODULE PROCEDURE gather_mpi_i,gather_mpi_i1,gather_mpi_i2,gather_mpi_i3, &
+                     gather_mpi_r,gather_mpi_r1,gather_mpi_r2,gather_mpi_r3, &
+                     gather_mpi_l,gather_mpi_l1,gather_mpi_l2,gather_mpi_l3  
+  END INTERFACE
+  
+  INTERFACE scatter2D_mpi
+    MODULE PROCEDURE scatter2D_mpi_i,scatter2D_mpi_i1,scatter2D_mpi_i2,scatter2D_mpi_i3, &
+                     scatter2D_mpi_r,scatter2D_mpi_r1,scatter2D_mpi_r2,scatter2D_mpi_r3, &
+                     scatter2D_mpi_l,scatter2D_mpi_l1,scatter2D_mpi_l2,scatter2D_mpi_l3
+  END INTERFACE
+
+  INTERFACE gather2D_mpi
+    MODULE PROCEDURE gather2D_mpi_i,gather2D_mpi_i1,gather2D_mpi_i2,gather2D_mpi_i3, &
+                     gather2D_mpi_r,gather2D_mpi_r1,gather2D_mpi_r2,gather2D_mpi_r3, &
+                     gather2D_mpi_l,gather2D_mpi_l1,gather2D_mpi_l2,gather2D_mpi_l3
+  END INTERFACE 
+  
+  INTERFACE reduce_sum_mpi
+    MODULE PROCEDURE reduce_sum_mpi_i,reduce_sum_mpi_i1,reduce_sum_mpi_i2,reduce_sum_mpi_i3,reduce_sum_mpi_i4, &
+                     reduce_sum_mpi_r,reduce_sum_mpi_r1,reduce_sum_mpi_r2,reduce_sum_mpi_r3,reduce_sum_mpi_r4
+  END INTERFACE 
+
+  INTERFACE reduce_min_mpi
+    MODULE PROCEDURE reduce_min_mpi_i,reduce_min_mpi_i1,reduce_min_mpi_i2,reduce_min_mpi_i3,reduce_min_mpi_i4, &
+                     reduce_min_mpi_r,reduce_min_mpi_r1,reduce_min_mpi_r2,reduce_min_mpi_r3,reduce_min_mpi_r4
+  END INTERFACE 
+
+ INTERFACE grid1dTo2d_mpi
+    MODULE PROCEDURE grid1dTo2d_mpi_i,grid1dTo2d_mpi_i1,grid1dTo2d_mpi_i2,grid1dTo2d_mpi_i3, &
+                     grid1dTo2d_mpi_r,grid1dTo2d_mpi_r1,grid1dTo2d_mpi_r2,grid1dTo2d_mpi_r3, &
+                     grid1dTo2d_mpi_l,grid1dTo2d_mpi_l1,grid1dTo2d_mpi_l2,grid1dTo2d_mpi_l3
+ END INTERFACE 
+
+ INTERFACE grid2dTo1d_mpi
+    MODULE PROCEDURE grid2dTo1d_mpi_i,grid2dTo1d_mpi_i1,grid2dTo1d_mpi_i2,grid2dTo1d_mpi_i3, &
+                     grid2dTo1d_mpi_r,grid2dTo1d_mpi_r1,grid2dTo1d_mpi_r2,grid2dTo1d_mpi_r3, &
+                     grid2dTo1d_mpi_l,grid2dTo1d_mpi_l1,grid2dTo1d_mpi_l2,grid2dTo1d_mpi_l3
+ END INTERFACE 
+    
+CONTAINS
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! Definition des Broadcast --> 4D   !!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+!! -- Les chaine de charactère -- !!
+
+  SUBROUTINE bcast_mpi_c(var1)
+  IMPLICIT NONE
+    CHARACTER(LEN=*),INTENT(INOUT) :: Var1
+   
+    CALL bcast_mpi_cgen(Var1,len(Var1))
+
+  END SUBROUTINE bcast_mpi_c
+
+!! -- Les entiers -- !!
+  
+  SUBROUTINE bcast_mpi_i(var)
+  USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root
+  IMPLICIT NONE
+    INTEGER,INTENT(INOUT) :: Var
+    
+    INTEGER               :: var_tmp(1)
+    
+    IF (is_mpi_root) var_tmp(1)=var
+    CALL bcast_mpi_igen(Var_tmp,1)
+    var=var_tmp(1)
+    
+  END SUBROUTINE bcast_mpi_i
+
+  SUBROUTINE bcast_mpi_i1(var)
+  IMPLICIT NONE
+    INTEGER,INTENT(INOUT) :: Var(:)
+
+    CALL bcast_mpi_igen(Var,size(Var))
+    
+  END SUBROUTINE bcast_mpi_i1
+
+  SUBROUTINE bcast_mpi_i2(var)
+  IMPLICIT NONE
+    INTEGER,INTENT(INOUT) :: Var(:,:)
+   
+    CALL bcast_mpi_igen(Var,size(Var))
+  
+  END SUBROUTINE bcast_mpi_i2
+
+  SUBROUTINE bcast_mpi_i3(var)
+  IMPLICIT NONE
+    INTEGER,INTENT(INOUT) :: Var(:,:,:)
+   
+    CALL bcast_mpi_igen(Var,size(Var))
+
+  END SUBROUTINE bcast_mpi_i3
+
+  SUBROUTINE bcast_mpi_i4(var)
+  IMPLICIT NONE
+    INTEGER,INTENT(INOUT) :: Var(:,:,:,:)
+   
+    CALL bcast_mpi_igen(Var,size(Var))
+
+  END SUBROUTINE bcast_mpi_i4
+
+
+!! -- Les reels -- !!
+
+  SUBROUTINE bcast_mpi_r(var)
+  USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root
+  IMPLICIT NONE
+    REAL,INTENT(INOUT) :: Var
+    REAL               :: var_tmp(1)
+    
+    IF (is_mpi_root) var_tmp(1)=var
+    CALL bcast_mpi_rgen(Var_tmp,1)
+    var=var_tmp(1)   
+
+  END SUBROUTINE bcast_mpi_r
+
+  SUBROUTINE bcast_mpi_r1(var)
+  IMPLICIT NONE
+    REAL,INTENT(INOUT) :: Var(:)
+   
+    CALL bcast_mpi_rgen(Var,size(Var))
+
+  END SUBROUTINE bcast_mpi_r1
+
+  SUBROUTINE bcast_mpi_r2(var)
+  IMPLICIT NONE
+    REAL,INTENT(INOUT) :: Var(:,:)
+   
+    CALL bcast_mpi_rgen(Var,size(Var))
+
+  END SUBROUTINE bcast_mpi_r2
+
+  SUBROUTINE bcast_mpi_r3(var)
+  IMPLICIT NONE
+    REAL,INTENT(INOUT) :: Var(:,:,:)
+   
+    CALL bcast_mpi_rgen(Var,size(Var))
+
+  END SUBROUTINE bcast_mpi_r3
+
+  SUBROUTINE bcast_mpi_r4(var)
+  IMPLICIT NONE
+    REAL,INTENT(INOUT) :: Var(:,:,:,:)
+   
+    CALL bcast_mpi_rgen(Var,size(Var))
+
+  END SUBROUTINE bcast_mpi_r4
+  
+!! -- Les booleans -- !!
+
+  SUBROUTINE bcast_mpi_l(var)
+  USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root
+  IMPLICIT NONE
+    LOGICAL,INTENT(INOUT) :: Var
+    LOGICAL               :: var_tmp(1)
+    
+    IF (is_mpi_root) var_tmp(1)=var
+    CALL bcast_mpi_lgen(Var_tmp,1)
+    var=var_tmp(1)   
+
+  END SUBROUTINE bcast_mpi_l
+
+  SUBROUTINE bcast_mpi_l1(var)
+  IMPLICIT NONE
+    LOGICAL,INTENT(INOUT) :: Var(:)
+   
+    CALL bcast_mpi_lgen(Var,size(Var))
+
+  END SUBROUTINE bcast_mpi_l1
+
+  SUBROUTINE bcast_mpi_l2(var)
+  IMPLICIT NONE
+    LOGICAL,INTENT(INOUT) :: Var(:,:)
+   
+    CALL bcast_mpi_lgen(Var,size(Var))
+
+  END SUBROUTINE bcast_mpi_l2
+
+  SUBROUTINE bcast_mpi_l3(var)
+  IMPLICIT NONE
+    LOGICAL,INTENT(INOUT) :: Var(:,:,:)
+   
+    CALL bcast_mpi_lgen(Var,size(Var))
+
+  END SUBROUTINE bcast_mpi_l3
+
+  SUBROUTINE bcast_mpi_l4(var)
+  IMPLICIT NONE
+    LOGICAL,INTENT(INOUT) :: Var(:,:,:,:)
+   
+    CALL bcast_mpi_lgen(Var,size(Var))
+
+  END SUBROUTINE bcast_mpi_l4
+  
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! Definition des Scatter   --> 4D   !!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+  SUBROUTINE scatter_mpi_i(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut
+
+    CALL scatter_mpi_igen(VarIn,Varout,1)
+    
+  END SUBROUTINE scatter_mpi_i
+
+  SUBROUTINE scatter_mpi_i1(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+    CALL scatter_mpi_igen(VarIn,Varout,Size(VarOut,2))
+    
+  END SUBROUTINE scatter_mpi_i1
+  
+  SUBROUTINE scatter_mpi_i2(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    CALL scatter_mpi_igen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3))
+
+  END SUBROUTINE scatter_mpi_i2
+
+  SUBROUTINE scatter_mpi_i3(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+    CALL scatter_mpi_igen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3)*Size(VarOut,4))
+  
+  END SUBROUTINE scatter_mpi_i3
+
+
+  SUBROUTINE scatter_mpi_r(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:) :: VarOut
+    
+      CALL scatter_mpi_rgen(VarIn,Varout,1)
+  
+  END SUBROUTINE scatter_mpi_r
+
+  SUBROUTINE scatter_mpi_r1(VarIn, VarOut)
+  USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+  IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+      CALL scatter_mpi_rgen(VarIn,Varout,Size(VarOut,2))
+  
+  END SUBROUTINE scatter_mpi_r1
+  
+  SUBROUTINE scatter_mpi_r2(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+      CALL scatter_mpi_rgen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3))
+  
+  END SUBROUTINE scatter_mpi_r2
+
+  SUBROUTINE scatter_mpi_r3(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+      CALL scatter_mpi_rgen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3)*Size(VarOut,4))
+  
+  END SUBROUTINE scatter_mpi_r3
+
+
+  SUBROUTINE scatter_mpi_l(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:) :: VarOut
+    
+      CALL scatter_mpi_lgen(VarIn,Varout,1)
+    
+  END SUBROUTINE scatter_mpi_l
+
+  SUBROUTINE scatter_mpi_l1(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+      CALL scatter_mpi_lgen(VarIn,Varout,Size(VarOut,2))
+  
+  END SUBROUTINE scatter_mpi_l1
+  
+  SUBROUTINE scatter_mpi_l2(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+      CALL scatter_mpi_lgen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3))
+  
+  END SUBROUTINE scatter_mpi_l2
+
+  SUBROUTINE scatter_mpi_l3(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+      CALL scatter_mpi_lgen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3)*Size(VarOut,4))
+  
+  END SUBROUTINE scatter_mpi_l3  
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! Definition des Gather   --> 4D   !!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ 
+!!!!! --> Les entiers
+
+  SUBROUTINE gather_mpi_i(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut
+    
+      CALL gather_mpi_igen(VarIn,VarOut,1)
+  
+  END SUBROUTINE gather_mpi_i
+  
+
+!!!!!
+
+  SUBROUTINE gather_mpi_i1(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+      CALL gather_mpi_igen(VarIn,VarOut,Size(VarIn,2))
+  
+  END SUBROUTINE gather_mpi_i1
+
+!!!!!
+  
+  SUBROUTINE gather_mpi_i2(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+      CALL gather_mpi_igen(VarIn,VarOut,Size(VarIn,2)*Size(VarIn,3))
+  
+  END SUBROUTINE gather_mpi_i2
+
+!!!!!
+
+  SUBROUTINE gather_mpi_i3(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+      CALL gather_mpi_igen(VarIn,VarOut,Size(VarIn,2)*Size(VarIn,3)*Size(VarIn,4))
+  
+  END SUBROUTINE gather_mpi_i3
+
+!!!!! --> Les reels
+
+  SUBROUTINE gather_mpi_r(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:) :: VarOut
+    
+      CALL gather_mpi_rgen(VarIn,VarOut,1)
+  
+  END SUBROUTINE gather_mpi_r
+
+!!!!!
+
+  SUBROUTINE gather_mpi_r1(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+      CALL gather_mpi_rgen(VarIn,VarOut,Size(VarIn,2))
+  
+  END SUBROUTINE gather_mpi_r1
+
+!!!!!
+  
+  SUBROUTINE gather_mpi_r2(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+      CALL gather_mpi_rgen(VarIn,VarOut,Size(VarIn,2)*Size(VarIn,3))
+  
+  END SUBROUTINE gather_mpi_r2
+
+!!!!!
+
+  SUBROUTINE gather_mpi_r3(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+      CALL gather_mpi_rgen(VarIn,VarOut,Size(VarIn,2)*Size(VarIn,3)*Size(VarIn,4))
+  
+  END SUBROUTINE gather_mpi_r3
+
+!!!!! --> Les booleen
+
+  SUBROUTINE gather_mpi_l(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:) :: VarOut
+    
+      CALL gather_mpi_lgen(VarIn,VarOut,1)
+  
+  END SUBROUTINE gather_mpi_l
+
+!!!!!
+
+  SUBROUTINE gather_mpi_l1(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+      CALL gather_mpi_lgen(VarIn,VarOut,Size(VarIn,2))
+  
+  END SUBROUTINE gather_mpi_l1
+
+!!!!!
+  
+  SUBROUTINE gather_mpi_l2(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+      CALL gather_mpi_lgen(VarIn,VarOut,Size(VarIn,2)*Size(VarIn,3))
+  
+  END SUBROUTINE gather_mpi_l2
+
+!!!!!
+
+  SUBROUTINE gather_mpi_l3(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+    CALL gather_mpi_lgen(VarIn,VarOut,Size(VarIn,2)*Size(VarIn,3)*Size(VarIn,4))
+  
+  END SUBROUTINE gather_mpi_l3
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! Definition des Scatter2D   --> 4D   !!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+  SUBROUTINE scatter2D_mpi_i(VarIn, VarOut)
+    USE mod_grid_phy_lmdz
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut
+
+    INTEGER,DIMENSION(klon_glo) :: Var_tmp    
+    
+    CALL grid2dTo1d_glo(VarIn,Var_tmp)
+    CALL scatter_mpi(Var_tmp,VarOut)
+
+  END SUBROUTINE scatter2D_mpi_i
+
+  SUBROUTINE scatter2D_mpi_i1(VarIn, VarOut)
+    USE mod_grid_phy_lmdz
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    INTEGER,DIMENSION(klon_glo,size(VarOut,2)) :: Var_tmp
+
+    CALL grid2dTo1d_glo(VarIn,Var_tmp)
+    CALL scatter_mpi(Var_tmp,VarOut)
+
+  END SUBROUTINE scatter2D_mpi_i1
+
+  SUBROUTINE scatter2D_mpi_i2(VarIn, VarOut)
+    USE mod_grid_phy_lmdz
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+
+    INTEGER,DIMENSION(klon_glo,size(VarOut,2),size(VarOut,3)) :: Var_tmp
+
+    CALL grid2dTo1d_glo(VarIn,Var_tmp)
+    CALL scatter_mpi(Var_tmp,VarOut)
+
+  END SUBROUTINE scatter2D_mpi_i2
+  
+  SUBROUTINE scatter2D_mpi_i3(VarIn, VarOut)
+    USE mod_grid_phy_lmdz
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    INTEGER,DIMENSION(klon_glo,size(VarOut,2),size(VarOut,3),size(VarOut,4)) :: Var_tmp
+
+    CALL grid2dTo1d_glo(VarIn,Var_tmp)
+    CALL scatter_mpi(Var_tmp,VarOut)
+    
+  END SUBROUTINE scatter2D_mpi_i3
+
+
+
+  SUBROUTINE scatter2D_mpi_r(VarIn, VarOut)
+    USE mod_grid_phy_lmdz
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:) :: VarOut
+
+    REAL,DIMENSION(klon_glo) :: Var_tmp    
+    
+    CALL grid2dTo1d_glo(VarIn,Var_tmp)
+    CALL scatter_mpi(Var_tmp,VarOut)
+
+  END SUBROUTINE scatter2D_mpi_R
+
+
+  SUBROUTINE scatter2D_mpi_r1(VarIn, VarOut)
+    USE mod_grid_phy_lmdz
+    IMPLICIT NONE
+    REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+    REAL,DIMENSION(klon_glo,size(VarOut,2)) :: Var_tmp
+    
+    CALL grid2dTo1d_glo(VarIn,Var_tmp)
+    CALL scatter_mpi(Var_tmp,VarOut)
+
+  END SUBROUTINE scatter2D_mpi_r1
+
+
+  SUBROUTINE scatter2D_mpi_r2(VarIn, VarOut)
+    USE mod_grid_phy_lmdz
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+
+    REAL,DIMENSION(klon_glo,size(VarOut,2),size(VarOut,3)) :: Var_tmp
+    
+    CALL grid2dTo1d_glo(VarIn,Var_tmp)
+    CALL scatter_mpi(Var_tmp,VarOut)
+
+  END SUBROUTINE scatter2D_mpi_r2
+  
+  SUBROUTINE scatter2D_mpi_r3(VarIn, VarOut)
+    USE mod_grid_phy_lmdz
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+    REAL,DIMENSION(klon_glo,size(VarOut,2),size(VarOut,3),size(VarOut,4)) :: Var_tmp
+
+    CALL grid2dTo1d_glo(VarIn,Var_tmp)
+    CALL scatter_mpi(Var_tmp,VarOut)
+ 
+  END SUBROUTINE scatter2D_mpi_r3
+  
+  
+  SUBROUTINE scatter2D_mpi_l(VarIn, VarOut)
+    USE mod_grid_phy_lmdz
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:) :: VarOut
+
+    LOGICAL,DIMENSION(klon_glo) :: Var_tmp    
+    
+    CALL grid2dTo1d_glo(VarIn,Var_tmp)
+    CALL scatter_mpi(Var_tmp,VarOut)
+
+  END SUBROUTINE scatter2D_mpi_l
+
+
+  SUBROUTINE scatter2D_mpi_l1(VarIn, VarOut)
+    USE mod_grid_phy_lmdz
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+    LOGICAL,DIMENSION(klon_glo,size(VarOut,2)) :: Var_tmp
+
+    CALL grid2dTo1d_glo(VarIn,Var_tmp)
+    CALL scatter_mpi(Var_tmp,VarOut)
+  
+  END SUBROUTINE scatter2D_mpi_l1
+
+
+  SUBROUTINE scatter2D_mpi_l2(VarIn, VarOut)
+    USE mod_grid_phy_lmdz
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    LOGICAL, DIMENSION(klon_glo,size(VarOut,2),size(VarOut,3)) :: Var_tmp
+  
+    CALL grid2dTo1d_glo(VarIn,Var_tmp)
+    CALL scatter_mpi(Var_tmp,VarOut)
+
+  END SUBROUTINE scatter2D_mpi_l2
+  
+  SUBROUTINE scatter2D_mpi_l3(VarIn, VarOut)
+    USE mod_grid_phy_lmdz
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+    LOGICAL,DIMENSION(klon_glo,size(VarOut,2),size(VarOut,3),size(VarOut,4)) :: Var_tmp
+
+    CALL grid2dTo1d_glo(VarIn,Var_tmp)
+    CALL scatter_mpi(Var_tmp,VarOut)
+ 
+  END SUBROUTINE scatter2D_mpi_l3
+  
+  
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! Definition des Gather2D   --> 4D   !!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+  SUBROUTINE gather2D_mpi_i(VarIn, VarOut)
+    USE mod_grid_phy_lmdz
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+    INTEGER,DIMENSION(klon_glo) :: Var_tmp
+    
+    CALL gather_mpi(VarIn,Var_tmp)
+    CALL grid1dTo2d_glo(Var_tmp,VarOut)
+
+  END SUBROUTINE gather2D_mpi_i
+
+  SUBROUTINE gather2D_mpi_i1(VarIn, VarOut)
+    USE mod_grid_phy_lmdz
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+
+    INTEGER,DIMENSION(klon_glo,size(VarOut,3)) :: Var_tmp
+
+    CALL gather_mpi(VarIn,Var_tmp)
+    CALL grid1dTo2d_glo(Var_tmp,VarOut)
+
+  END SUBROUTINE gather2D_mpi_i1
+
+  SUBROUTINE gather2D_mpi_i2(VarIn, VarOut)
+    USE mod_grid_phy_lmdz
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+
+    INTEGER,DIMENSION(klon_glo,size(VarOut,3),SIZE(VarOut,4)) :: Var_tmp
+    
+    CALL gather_mpi(VarIn,Var_tmp)
+    CALL grid1dTo2d_glo(Var_tmp,VarOut)
+
+  END SUBROUTINE gather2D_mpi_i2
+  
+  SUBROUTINE gather2D_mpi_i3(VarIn, VarOut)
+    USE mod_grid_phy_lmdz
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:,:) :: VarOut
+ 
+    INTEGER,DIMENSION(klon_glo,size(VarOut,3),SIZE(VarOut,4),SIZE(VarOut,5)) :: Var_tmp
+    
+    CALL gather_mpi(VarIn,Var_tmp)
+    CALL grid1dTo2d_glo(Var_tmp,VarOut)
+
+  END SUBROUTINE gather2D_mpi_i3
+
+
+
+  SUBROUTINE gather2D_mpi_r(VarIn, VarOut)
+    USE mod_grid_phy_lmdz
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+    REAL,DIMENSION(klon_glo) :: Var_tmp
+    
+    CALL gather_mpi(VarIn,Var_tmp)
+    CALL grid1dTo2d_glo(Var_tmp,VarOut)
+
+  END SUBROUTINE gather2D_mpi_r
+
+  SUBROUTINE gather2D_mpi_r1(VarIn, VarOut)
+    USE mod_grid_phy_lmdz
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    REAL,DIMENSION(klon_glo,size(VarOut,3)) :: Var_tmp
+
+    CALL gather_mpi(VarIn,Var_tmp)
+    CALL grid1dTo2d_glo(Var_tmp,VarOut)
+
+  END SUBROUTINE gather2D_mpi_r1
+
+  SUBROUTINE gather2D_mpi_r2(VarIn, VarOut)
+    USE mod_grid_phy_lmdz
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+    REAL,DIMENSION(klon_glo,size(VarOut,3),SIZE(VarOut,4)) :: Var_tmp
+
+    CALL gather_mpi(VarIn,Var_tmp)
+    CALL grid1dTo2d_glo(Var_tmp,VarOut)
+
+  END SUBROUTINE gather2D_mpi_r2
+  
+  SUBROUTINE gather2D_mpi_r3(VarIn, VarOut)
+    USE mod_grid_phy_lmdz
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:,:,:) :: VarOut
+    
+    REAL,DIMENSION(klon_glo,size(VarOut,3),SIZE(VarOut,4),SIZE(VarOut,5)) :: Var_tmp
+    
+    CALL gather_mpi(VarIn,Var_tmp)
+    CALL grid1dTo2d_glo(Var_tmp,VarOut)
+
+  END SUBROUTINE gather2D_mpi_r3
+
+  
+  
+  SUBROUTINE gather2D_mpi_l(VarIn, VarOut)
+    USE mod_grid_phy_lmdz
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+    LOGICAL,DIMENSION(klon_glo) :: Var_tmp
+    
+    CALL gather_mpi(VarIn,Var_tmp)
+    CALL grid1dTo2d_glo(Var_tmp,VarOut)
+
+  END SUBROUTINE gather2D_mpi_l
+
+  SUBROUTINE gather2D_mpi_l1(VarIn, VarOut)
+    USE mod_grid_phy_lmdz
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    LOGICAL,DIMENSION(klon_glo,size(VarOut,3)) :: Var_tmp
+
+    CALL gather_mpi(VarIn,Var_tmp)
+    CALL grid1dTo2d_glo(Var_tmp,VarOut)
+
+  END SUBROUTINE gather2D_mpi_l1
+
+  SUBROUTINE gather2D_mpi_l2(VarIn, VarOut)
+    USE mod_grid_phy_lmdz
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+    LOGICAL,DIMENSION(klon_glo,size(VarOut,3),SIZE(VarOut,4)) :: Var_tmp
+
+    CALL gather_mpi(VarIn,Var_tmp)
+    CALL grid1dTo2d_glo(Var_tmp,VarOut)
+
+  END SUBROUTINE gather2D_mpi_l2
+  
+  SUBROUTINE gather2D_mpi_l3(VarIn, VarOut)
+    USE mod_grid_phy_lmdz
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:,:) :: VarOut
+    
+    LOGICAL,DIMENSION(klon_glo,size(VarOut,3),SIZE(VarOut,4),SIZE(VarOut,5)) :: Var_tmp
+    
+    CALL gather_mpi(VarIn,Var_tmp)
+    CALL grid1dTo2d_glo(Var_tmp,VarOut)
+
+  END SUBROUTINE gather2D_mpi_l3
+  
+  
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! Definition des reduce_sum   --> 4D   !!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+  SUBROUTINE reduce_sum_mpi_i(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN)  :: VarIn
+    INTEGER,INTENT(OUT) :: VarOut
+    INTEGER             :: VarIn_tmp(1)
+    INTEGER             :: VarOut_tmp(1)
+    
+    VarIn_tmp(1)=VarIn    
+    CALL reduce_sum_mpi_igen(VarIn_tmp,Varout_tmp,1)
+    VarOut=VarOut_tmp(1)
+    
+  END SUBROUTINE reduce_sum_mpi_i
+
+  SUBROUTINE reduce_sum_mpi_i1(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:)  :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut
+    
+    CALL reduce_sum_mpi_igen(VarIn,Varout,SIZE(VarIn))
+  
+  END SUBROUTINE reduce_sum_mpi_i1
+
+  SUBROUTINE reduce_sum_mpi_i2(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:)  :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+    CALL reduce_sum_mpi_igen(VarIn,Varout,SIZE(VarIn))
+  
+  END SUBROUTINE reduce_sum_mpi_i2
+
+  SUBROUTINE reduce_sum_mpi_i3(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:)  :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    CALL reduce_sum_mpi_igen(VarIn,Varout,SIZE(VarIn))
+  
+  END SUBROUTINE reduce_sum_mpi_i3
+
+  SUBROUTINE reduce_sum_mpi_i4(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:,:)  :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+    CALL reduce_sum_mpi_igen(VarIn,Varout,SIZE(VarIn))
+  
+  END SUBROUTINE reduce_sum_mpi_i4                  
+  
+  
+  SUBROUTINE reduce_sum_mpi_r(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN)  :: VarIn
+    REAL,INTENT(OUT) :: VarOut
+    REAL             :: VarIn_tmp(1)
+    REAL             :: VarOut_tmp(1)
+    
+    VarIn_tmp(1)=VarIn    
+    CALL reduce_sum_mpi_rgen(VarIn_tmp,Varout_tmp,1)
+    VarOut=VarOut_tmp(1)
+  
+  END SUBROUTINE reduce_sum_mpi_r
+
+  SUBROUTINE reduce_sum_mpi_r1(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:)  :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:) :: VarOut
+    
+    CALL reduce_sum_mpi_rgen(VarIn,Varout,SIZE(VarIn))
+     
+  END SUBROUTINE reduce_sum_mpi_r1
+
+  SUBROUTINE reduce_sum_mpi_r2(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:)  :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+    CALL reduce_sum_mpi_rgen(VarIn,Varout,SIZE(VarIn))
+  
+  END SUBROUTINE reduce_sum_mpi_r2
+
+  SUBROUTINE reduce_sum_mpi_r3(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:)  :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    CALL reduce_sum_mpi_rgen(VarIn,Varout,SIZE(VarIn))
+  
+  END SUBROUTINE reduce_sum_mpi_r3
+
+  SUBROUTINE reduce_sum_mpi_r4(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:,:)  :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+    CALL reduce_sum_mpi_rgen(VarIn,Varout,SIZE(VarIn))
+  
+  END SUBROUTINE reduce_sum_mpi_r4 
+  
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! Definition des reduce_min   --> 4D   !!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+  SUBROUTINE reduce_min_mpi_i(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN)  :: VarIn
+    INTEGER,INTENT(OUT) :: VarOut
+    INTEGER             :: VarIn_tmp(1)
+    INTEGER             :: VarOut_tmp(1)
+    
+    VarIn_tmp(1)=VarIn    
+    CALL reduce_min_mpi_igen(VarIn_tmp,Varout_tmp,1)
+    VarOut=VarOut_tmp(1)
+    
+  END SUBROUTINE reduce_min_mpi_i
+
+  SUBROUTINE reduce_min_mpi_i1(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:)  :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut
+    
+    CALL reduce_min_mpi_igen(VarIn,Varout,SIZE(VarIn))
+  
+  END SUBROUTINE reduce_min_mpi_i1
+
+  SUBROUTINE reduce_min_mpi_i2(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:)  :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+    CALL reduce_min_mpi_igen(VarIn,Varout,SIZE(VarIn))
+  
+  END SUBROUTINE reduce_min_mpi_i2
+
+  SUBROUTINE reduce_min_mpi_i3(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:)  :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    CALL reduce_min_mpi_igen(VarIn,Varout,SIZE(VarIn))
+  
+  END SUBROUTINE reduce_min_mpi_i3
+
+  SUBROUTINE reduce_min_mpi_i4(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:,:)  :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+    CALL reduce_min_mpi_igen(VarIn,Varout,SIZE(VarIn))
+  
+  END SUBROUTINE reduce_min_mpi_i4                  
+  
+  
+  SUBROUTINE reduce_min_mpi_r(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN)  :: VarIn
+    REAL,INTENT(OUT) :: VarOut
+    REAL             :: VarIn_tmp(1)
+    REAL             :: VarOut_tmp(1)
+    
+    VarIn_tmp(1)=VarIn    
+    CALL reduce_min_mpi_rgen(VarIn_tmp,Varout_tmp,1)
+    VarOut=VarOut_tmp(1)
+  
+  END SUBROUTINE reduce_min_mpi_r
+
+  SUBROUTINE reduce_min_mpi_r1(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:)  :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:) :: VarOut
+    
+    CALL reduce_min_mpi_rgen(VarIn,Varout,SIZE(VarIn))
+     
+  END SUBROUTINE reduce_min_mpi_r1
+
+  SUBROUTINE reduce_min_mpi_r2(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:)  :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+    CALL reduce_min_mpi_rgen(VarIn,Varout,SIZE(VarIn))
+  
+  END SUBROUTINE reduce_min_mpi_r2
+
+  SUBROUTINE reduce_min_mpi_r3(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:)  :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    CALL reduce_min_mpi_rgen(VarIn,Varout,SIZE(VarIn))
+  
+  END SUBROUTINE reduce_min_mpi_r3
+
+  SUBROUTINE reduce_min_mpi_r4(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:,:)  :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+    CALL reduce_min_mpi_rgen(VarIn,Varout,SIZE(VarIn))
+  
+  END SUBROUTINE reduce_min_mpi_r4 
+
+
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! SUBROUTINE grid1dTo2d  !!  
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+
+  SUBROUTINE grid1dTo2d_mpi_i(VarIn,VarOut)  
+  IMPLICIT NONE  
+    INTEGER,INTENT(IN),DIMENSION(:)     :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:)  :: VarOut
+    
+    CALL grid1dTo2d_mpi_igen(VarIn,VarOut,1)
+  
+  END SUBROUTINE grid1dTo2d_mpi_i
+  
+
+  SUBROUTINE grid1dTo2d_mpi_i1(VarIn,VarOut)  
+  IMPLICIT NONE  
+    INTEGER,INTENT(IN),DIMENSION(:,:)     :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:)  :: VarOut
+    
+    CALL grid1dTo2d_mpi_igen(VarIn,VarOut,size(VarIn,2))
+  
+  END SUBROUTINE grid1dTo2d_mpi_i1
+
+  SUBROUTINE grid1dTo2d_mpi_i2(VarIn,VarOut)  
+  IMPLICIT NONE  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:)     :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:)  :: VarOut
+    
+    CALL grid1dTo2d_mpi_igen(VarIn,VarOut,size(VarIn,2)*size(VarIn,3))
+  
+  END SUBROUTINE grid1dTo2d_mpi_i2
+  
+  SUBROUTINE grid1dTo2d_mpi_i3(VarIn,VarOut)  
+  IMPLICIT NONE  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:,:)     :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:,:)  :: VarOut
+    
+    CALL grid1dTo2d_mpi_igen(VarIn,VarOut,size(VarIn,2)*size(VarIn,3)*size(VarIn,4))
+  
+  END SUBROUTINE grid1dTo2d_mpi_i3
+
+
+  SUBROUTINE grid1dTo2d_mpi_r(VarIn,VarOut)  
+  IMPLICIT NONE  
+    REAL,INTENT(IN),DIMENSION(:)     :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:)  :: VarOut
+    
+    CALL grid1dTo2d_mpi_rgen(VarIn,VarOut,1)
+  
+  END SUBROUTINE grid1dTo2d_mpi_r
+  
+
+  SUBROUTINE grid1dTo2d_mpi_r1(VarIn,VarOut)  
+  IMPLICIT NONE  
+    REAL,INTENT(IN),DIMENSION(:,:)     :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:)  :: VarOut
+    
+    CALL grid1dTo2d_mpi_rgen(VarIn,VarOut,size(VarIn,2))
+  
+  END SUBROUTINE grid1dTo2d_mpi_r1
+
+  SUBROUTINE grid1dTo2d_mpi_r2(VarIn,VarOut)  
+  IMPLICIT NONE  
+    REAL,INTENT(IN),DIMENSION(:,:,:)     :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:,:)  :: VarOut
+    
+    CALL grid1dTo2d_mpi_rgen(VarIn,VarOut,size(VarIn,2)*size(VarIn,3))
+  
+  END SUBROUTINE grid1dTo2d_mpi_r2
+  
+  SUBROUTINE grid1dTo2d_mpi_r3(VarIn,VarOut)  
+  IMPLICIT NONE  
+    REAL,INTENT(IN),DIMENSION(:,:,:,:)     :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:,:,:)  :: VarOut
+    
+    CALL grid1dTo2d_mpi_rgen(VarIn,VarOut,size(VarIn,2)*size(VarIn,3)*size(VarIn,4))
+  
+  END SUBROUTINE grid1dTo2d_mpi_r3
+  
+  
+  
+  SUBROUTINE grid1dTo2d_mpi_l(VarIn,VarOut)  
+  IMPLICIT NONE  
+    LOGICAL,INTENT(IN),DIMENSION(:)     :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:)  :: VarOut
+    
+    CALL grid1dTo2d_mpi_lgen(VarIn,VarOut,1)
+  
+  END SUBROUTINE grid1dTo2d_mpi_l
+  
+
+  SUBROUTINE grid1dTo2d_mpi_l1(VarIn,VarOut)  
+  IMPLICIT NONE  
+    LOGICAL,INTENT(IN),DIMENSION(:,:)     :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:)  :: VarOut
+    
+    CALL grid1dTo2d_mpi_lgen(VarIn,VarOut,size(VarIn,2))
+  
+  END SUBROUTINE grid1dTo2d_mpi_l1
+
+  SUBROUTINE grid1dTo2d_mpi_l2(VarIn,VarOut)  
+  IMPLICIT NONE  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:)     :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:)  :: VarOut
+    
+    CALL grid1dTo2d_mpi_lgen(VarIn,VarOut,size(VarIn,2)*size(VarIn,3))
+  
+  END SUBROUTINE grid1dTo2d_mpi_l2
+  
+  SUBROUTINE grid1dTo2d_mpi_l3(VarIn,VarOut)  
+  IMPLICIT NONE  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:,:)     :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:,:)  :: VarOut
+    
+    CALL grid1dTo2d_mpi_lgen(VarIn,VarOut,size(VarIn,2)*size(VarIn,3)*size(VarIn,4))
+  
+  END SUBROUTINE grid1dTo2d_mpi_l3
+
+
+  SUBROUTINE grid2dTo1d_mpi_i(VarIn,VarOut)  
+  IMPLICIT NONE  
+    INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:)  :: VarOut
+    
+    CALL grid2dTo1d_mpi_igen(VarIn,VarOut,1)
+  
+  END SUBROUTINE grid2dTo1d_mpi_i
+  
+
+  SUBROUTINE grid2dTo1d_mpi_i1(VarIn,VarOut)  
+  IMPLICIT NONE  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:)  :: VarOut
+    
+    CALL grid2dTo1d_mpi_igen(VarIn,VarOut,size(VarIn,3))
+  
+  END SUBROUTINE grid2dTo1d_mpi_i1
+
+  SUBROUTINE grid2dTo1d_mpi_i2(VarIn,VarOut)  
+  IMPLICIT NONE  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:)  :: VarOut
+    
+    CALL grid2dTo1d_mpi_igen(VarIn,VarOut,size(VarIn,3)*size(VarIn,4))
+  
+  END SUBROUTINE grid2dTo1d_mpi_i2
+  
+  SUBROUTINE grid2dTo1d_mpi_i3(VarIn,VarOut)  
+  IMPLICIT NONE  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:)  :: VarOut
+    
+    CALL grid2dTo1d_mpi_igen(VarIn,VarOut,size(VarIn,3)*size(VarIn,4)*size(VarIn,5))
+  
+  END SUBROUTINE grid2dTo1d_mpi_i3
+ 
+
+
+
+  SUBROUTINE grid2dTo1d_mpi_r(VarIn,VarOut)  
+  IMPLICIT NONE  
+    REAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:)  :: VarOut
+    
+    CALL grid2dTo1d_mpi_rgen(VarIn,VarOut,1)
+  
+  END SUBROUTINE grid2dTo1d_mpi_r
+  
+
+  SUBROUTINE grid2dTo1d_mpi_r1(VarIn,VarOut)  
+  IMPLICIT NONE  
+    REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:)  :: VarOut
+    
+    CALL grid2dTo1d_mpi_rgen(VarIn,VarOut,size(VarIn,3))
+  
+  END SUBROUTINE grid2dTo1d_mpi_r1
+
+  SUBROUTINE grid2dTo1d_mpi_r2(VarIn,VarOut)  
+  IMPLICIT NONE  
+    REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:)  :: VarOut
+    
+    CALL grid2dTo1d_mpi_rgen(VarIn,VarOut,size(VarIn,3)*size(VarIn,4))
+  
+  END SUBROUTINE grid2dTo1d_mpi_r2
+  
+  SUBROUTINE grid2dTo1d_mpi_r3(VarIn,VarOut)  
+  IMPLICIT NONE  
+    REAL,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:,:)  :: VarOut
+    
+    CALL grid2dTo1d_mpi_rgen(VarIn,VarOut,size(VarIn,3)*size(VarIn,4)*size(VarIn,5))
+  
+  END SUBROUTINE grid2dTo1d_mpi_r3
+
+
+
+  SUBROUTINE grid2dTo1d_mpi_l(VarIn,VarOut)  
+  IMPLICIT NONE  
+    LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:)  :: VarOut
+    
+    CALL grid2dTo1d_mpi_lgen(VarIn,VarOut,1)
+  
+  END SUBROUTINE grid2dTo1d_mpi_l
+  
+
+  SUBROUTINE grid2dTo1d_mpi_l1(VarIn,VarOut)  
+  IMPLICIT NONE  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:)  :: VarOut
+    
+    CALL grid2dTo1d_mpi_lgen(VarIn,VarOut,size(VarIn,3))
+  
+  END SUBROUTINE grid2dTo1d_mpi_l1
+
+
+
+  SUBROUTINE grid2dTo1d_mpi_l2(VarIn,VarOut)  
+  IMPLICIT NONE  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:)  :: VarOut
+    
+    CALL grid2dTo1d_mpi_lgen(VarIn,VarOut,size(VarIn,3)*size(VarIn,4))
+  
+  END SUBROUTINE grid2dTo1d_mpi_l2
+
+  
+  SUBROUTINE grid2dTo1d_mpi_l3(VarIn,VarOut)  
+  IMPLICIT NONE  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:)  :: VarOut
+    
+    CALL grid2dTo1d_mpi_lgen(VarIn,VarOut,size(VarIn,3)*size(VarIn,4)*size(VarIn,5))
+  
+  END SUBROUTINE grid2dTo1d_mpi_l3
+
+               
+
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! DEFINITION DES FONCTIONS DE TRANSFERT GENERIQUES !
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+  SUBROUTINE bcast_mpi_cgen(var,nb)
+    USE mod_phys_lmdz_mpi_data 
+    USE lmdz_mpi
+    IMPLICIT NONE
+    
+    CHARACTER(LEN=*),INTENT(INOUT) :: Var
+    INTEGER,INTENT(IN) :: nb
+    
+    INTEGER :: ierr
+
+    IF (.not.is_using_mpi) RETURN
+    
+    CALL MPI_BCAST(Var,nb,MPI_CHARACTER,mpi_master,COMM_LMDZ_PHY,ierr)
+        
+  END SUBROUTINE bcast_mpi_cgen
+
+
+      
+  SUBROUTINE bcast_mpi_igen(var,nb)
+    USE mod_phys_lmdz_mpi_data
+    USE lmdz_mpi
+    IMPLICIT NONE
+    
+    INTEGER,INTENT(IN) :: nb
+    INTEGER,DIMENSION(nb),INTENT(INOUT) :: Var
+    
+    INTEGER :: ierr
+
+    IF (.not.is_using_mpi) RETURN
+
+    CALL MPI_BCAST(Var,nb,MPI_INTEGER,mpi_master,COMM_LMDZ_PHY,ierr)
+        
+  END SUBROUTINE bcast_mpi_igen
+
+
+
+  
+  SUBROUTINE bcast_mpi_rgen(var,nb)
+    USE mod_phys_lmdz_mpi_data
+    USE lmdz_mpi
+    IMPLICIT NONE
+    
+    INTEGER,INTENT(IN) :: nb
+    REAL,DIMENSION(nb),INTENT(INOUT) :: Var
+    
+    INTEGER :: ierr
+
+    IF (.not.is_using_mpi) RETURN
+
+    CALL MPI_BCAST(Var,nb,MPI_REAL_LMDZ,mpi_master,COMM_LMDZ_PHY,ierr)
+    
+  END SUBROUTINE bcast_mpi_rgen
+  
+
+
+
+  SUBROUTINE bcast_mpi_lgen(var,nb)
+    USE mod_phys_lmdz_mpi_data
+    USE lmdz_mpi
+    IMPLICIT NONE
+    
+    INTEGER,INTENT(IN) :: nb
+    LOGICAL,DIMENSION(nb),INTENT(INOUT) :: Var
+    
+    INTEGER :: ierr
+
+    IF (.not.is_using_mpi) RETURN
+
+    CALL MPI_BCAST(Var,nb,MPI_LOGICAL,mpi_master,COMM_LMDZ_PHY,ierr)
+
+  END SUBROUTINE bcast_mpi_lgen
+
+  
+
+  SUBROUTINE scatter_mpi_igen(VarIn, VarOut, dimsize)
+    USE mod_phys_lmdz_mpi_data 
+    USE mod_grid_phy_lmdz
+    USE lmdz_mpi
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN) :: dimsize
+    INTEGER,INTENT(IN),DIMENSION(klon_glo,dimsize) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(klon_mpi,dimsize) :: VarOut
+  
+    INTEGER,DIMENSION(0:mpi_size-1) :: displs
+    INTEGER,DIMENSION(0:mpi_size-1) :: counts
+    INTEGER,DIMENSION(dimsize*klon_glo) :: VarTmp
+    INTEGER :: nb,i,index,rank
+    INTEGER :: ierr
+
+
+    IF (.not.is_using_mpi) THEN
+      VarOut(:,:)=VarIn(:,:)
+      RETURN
+    ENDIF
+
+    
+    IF (is_mpi_root) THEN
+      Index=1
+      DO rank=0,mpi_size-1
+        nb=klon_mpi_para_nb(rank)
+        displs(rank)=Index-1
+        counts(rank)=nb*dimsize
+        DO i=1,dimsize
+          VarTmp(Index:Index+nb-1)=VarIn(klon_mpi_para_begin(rank):klon_mpi_para_end(rank),i)
+          Index=Index+nb
+        ENDDO
+      ENDDO
+    ENDIF
+      
+    CALL MPI_SCATTERV(VarTmp,counts,displs,MPI_INTEGER,VarOut,klon_mpi*dimsize,   &
+                      MPI_INTEGER,mpi_master, COMM_LMDZ_PHY,ierr)
+
+  END SUBROUTINE scatter_mpi_igen
+
+  SUBROUTINE scatter_mpi_rgen(VarIn, VarOut, dimsize)
+    USE mod_phys_lmdz_mpi_data 
+    USE mod_grid_phy_lmdz
+    USE lmdz_mpi
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN) :: dimsize
+    REAL,INTENT(IN),DIMENSION(klon_glo,dimsize) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(klon_mpi,dimsize) :: VarOut
+
+    INTEGER,DIMENSION(0:mpi_size-1) :: displs
+    INTEGER,DIMENSION(0:mpi_size-1) :: counts
+    REAL,DIMENSION(dimsize*klon_glo) :: VarTmp
+    INTEGER :: nb,i,index,rank
+    INTEGER :: ierr
+
+    IF (.not.is_using_mpi) THEN
+      VarOut(:,:)=VarIn(:,:)
+      RETURN
+    ENDIF
+    
+    IF (is_mpi_root) THEN
+      Index=1
+      DO rank=0,mpi_size-1
+        nb=klon_mpi_para_nb(rank)
+        displs(rank)=Index-1
+        counts(rank)=nb*dimsize
+        DO i=1,dimsize
+          VarTmp(Index:Index+nb-1)=VarIn(klon_mpi_para_begin(rank):klon_mpi_para_end(rank),i)
+          Index=Index+nb
+        ENDDO
+      ENDDO
+    ENDIF
+      
+    CALL MPI_SCATTERV(VarTmp,counts,displs,MPI_REAL_LMDZ,VarOut,klon_mpi*dimsize,   &
+                      MPI_REAL_LMDZ,mpi_master, COMM_LMDZ_PHY,ierr)
+
+  END SUBROUTINE scatter_mpi_rgen
+
+  
+  SUBROUTINE scatter_mpi_lgen(VarIn, VarOut, dimsize)
+    USE mod_phys_lmdz_mpi_data 
+    USE mod_grid_phy_lmdz
+    USE lmdz_mpi
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN) :: dimsize
+    LOGICAL,INTENT(IN),DIMENSION(klon_glo,dimsize) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(klon_mpi,dimsize) :: VarOut
+  
+
+    INTEGER,DIMENSION(0:mpi_size-1) :: displs
+    INTEGER,DIMENSION(0:mpi_size-1) :: counts
+    LOGICAL,DIMENSION(dimsize*klon_glo) :: VarTmp
+    INTEGER :: nb,i,index,rank
+    INTEGER :: ierr
+
+    IF (.not.is_using_mpi) THEN
+      VarOut(:,:)=VarIn(:,:)
+      RETURN
+    ENDIF
+    
+    IF (is_mpi_root) THEN
+      Index=1
+      DO rank=0,mpi_size-1
+        nb=klon_mpi_para_nb(rank)
+        displs(rank)=Index-1
+        counts(rank)=nb*dimsize
+        DO i=1,dimsize
+          VarTmp(Index:Index+nb-1)=VarIn(klon_mpi_para_begin(rank):klon_mpi_para_end(rank),i)
+          Index=Index+nb
+        ENDDO
+      ENDDO
+    ENDIF
+      
+    CALL MPI_SCATTERV(VarTmp,counts,displs,MPI_LOGICAL,VarOut,klon_mpi*dimsize,   &
+                      MPI_LOGICAL,mpi_master, COMM_LMDZ_PHY,ierr)
+
+  END SUBROUTINE scatter_mpi_lgen  
+
+
+
+
+  SUBROUTINE gather_mpi_igen(VarIn, VarOut, dimsize)
+    USE mod_phys_lmdz_mpi_data
+    USE mod_grid_phy_lmdz
+    USE lmdz_mpi
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN) :: dimsize
+    INTEGER,INTENT(IN),DIMENSION(klon_mpi,dimsize) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(klon_glo,dimsize) :: VarOut
+  
+    INTEGER,DIMENSION(0:mpi_size-1) :: displs
+    INTEGER,DIMENSION(0:mpi_size-1) :: counts
+    INTEGER,DIMENSION(dimsize*klon_glo) :: VarTmp
+    INTEGER :: nb,i,index,rank
+    INTEGER :: ierr
+
+    IF (.not.is_using_mpi) THEN
+      VarOut(:,:)=VarIn(:,:)
+      RETURN
+    ENDIF
+
+    IF (is_mpi_root) THEN
+      Index=1
+      DO rank=0,mpi_size-1
+        nb=klon_mpi_para_nb(rank)
+        displs(rank)=Index-1
+        counts(rank)=nb*dimsize
+        Index=Index+nb*dimsize
+      ENDDO
+     
+    ENDIF
+    
+    CALL MPI_GATHERV(VarIn,klon_mpi*dimsize,MPI_INTEGER,VarTmp,counts,displs,   &
+                     MPI_INTEGER,mpi_master, COMM_LMDZ_PHY,ierr)
+
+                          
+    IF (is_mpi_root) THEN
+      Index=1
+      DO rank=0,mpi_size-1
+        nb=klon_mpi_para_nb(rank)
+        DO i=1,dimsize
+          VarOut(klon_mpi_para_begin(rank):klon_mpi_para_end(rank),i)=VarTmp(Index:Index+nb-1)
+          Index=Index+nb
+        ENDDO
+      ENDDO
+    ENDIF
+
+  END SUBROUTINE gather_mpi_igen  
+
+  SUBROUTINE gather_mpi_rgen(VarIn, VarOut, dimsize)
+    USE mod_phys_lmdz_mpi_data 
+    USE mod_grid_phy_lmdz
+    USE lmdz_mpi
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN) :: dimsize
+    REAL,INTENT(IN),DIMENSION(klon_mpi,dimsize) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(klon_glo,dimsize) :: VarOut
+  
+    INTEGER,DIMENSION(0:mpi_size-1) :: displs
+    INTEGER,DIMENSION(0:mpi_size-1) :: counts
+    REAL,DIMENSION(dimsize*klon_glo) :: VarTmp
+    INTEGER :: nb,i,index,rank
+    INTEGER :: ierr
+
+    IF (is_mpi_root) THEN
+      Index=1
+      DO rank=0,mpi_size-1
+        nb=klon_mpi_para_nb(rank)
+        displs(rank)=Index-1
+        counts(rank)=nb*dimsize
+        Index=Index+nb*dimsize
+      ENDDO
+    ENDIF
+    
+    IF (.not.is_using_mpi) THEN
+      VarOut(:,:)=VarIn(:,:)
+      RETURN
+    ENDIF
+
+    CALL MPI_GATHERV(VarIn,klon_mpi*dimsize,MPI_REAL_LMDZ,VarTmp,counts,displs,   &
+                      MPI_REAL_LMDZ,mpi_master, COMM_LMDZ_PHY,ierr)
+                          
+    IF (is_mpi_root) THEN
+      Index=1
+      DO rank=0,mpi_size-1
+        nb=klon_mpi_para_nb(rank)
+        DO i=1,dimsize
+          VarOut(klon_mpi_para_begin(rank):klon_mpi_para_end(rank),i)=VarTmp(Index:Index+nb-1)
+          Index=Index+nb
+        ENDDO
+      ENDDO
+    ENDIF
+
+  END SUBROUTINE gather_mpi_rgen  
+
+  SUBROUTINE gather_mpi_lgen(VarIn, VarOut, dimsize)
+    USE mod_phys_lmdz_mpi_data
+    USE mod_grid_phy_lmdz
+    USE lmdz_mpi
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN) :: dimsize
+    LOGICAL,INTENT(IN),DIMENSION(klon_mpi,dimsize) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(klon_glo,dimsize) :: VarOut
+
+    INTEGER,DIMENSION(0:mpi_size-1) :: displs
+    INTEGER,DIMENSION(0:mpi_size-1) :: counts
+    LOGICAL,DIMENSION(dimsize*klon_glo) :: VarTmp
+    INTEGER :: nb,i,index,rank
+    INTEGER :: ierr
+    
+    IF (.not.is_using_mpi) THEN
+      VarOut(:,:)=VarIn(:,:)
+      RETURN
+    ENDIF
+
+    IF (is_mpi_root) THEN
+      Index=1
+      DO rank=0,mpi_size-1
+        nb=klon_mpi_para_nb(rank)
+        displs(rank)=Index-1
+        counts(rank)=nb*dimsize
+        Index=Index+nb*dimsize
+      ENDDO
+    ENDIF
+    
+
+    CALL MPI_GATHERV(VarIn,klon_mpi*dimsize,MPI_LOGICAL,VarTmp,counts,displs,   &
+                      MPI_LOGICAL,mpi_master, COMM_LMDZ_PHY,ierr)
+                          
+    IF (is_mpi_root) THEN
+      Index=1
+      DO rank=0,mpi_size-1
+        nb=klon_mpi_para_nb(rank)
+        DO i=1,dimsize
+          VarOut(klon_mpi_para_begin(rank):klon_mpi_para_end(rank),i)=VarTmp(Index:Index+nb-1)
+          Index=Index+nb
+        ENDDO
+      ENDDO
+    ENDIF
+
+  END SUBROUTINE gather_mpi_lgen
+  
+
+
+  SUBROUTINE reduce_sum_mpi_igen(VarIn,VarOut,nb)
+    USE mod_phys_lmdz_mpi_data 
+    USE mod_grid_phy_lmdz
+    USE lmdz_mpi
+    IMPLICIT NONE
+   
+    INTEGER,INTENT(IN) :: nb
+    INTEGER,DIMENSION(nb),INTENT(IN) :: VarIn
+    INTEGER,DIMENSION(nb),INTENT(OUT) :: VarOut    
+    INTEGER :: ierr
+   
+    IF (.not.is_using_mpi) THEN
+      VarOut(:)=VarIn(:)
+      RETURN
+    ENDIF
+
+
+    CALL MPI_REDUCE(VarIn,VarOut,nb,MPI_INTEGER,MPI_SUM,mpi_master,COMM_LMDZ_PHY,ierr)
+            
+  END SUBROUTINE reduce_sum_mpi_igen
+  
+  SUBROUTINE reduce_sum_mpi_rgen(VarIn,VarOut,nb)
+    USE mod_phys_lmdz_mpi_data 
+    USE mod_grid_phy_lmdz
+    USE lmdz_mpi
+    IMPLICIT NONE
+
+    INTEGER,INTENT(IN) :: nb
+    REAL,DIMENSION(nb),INTENT(IN) :: VarIn
+    REAL,DIMENSION(nb),INTENT(OUT) :: VarOut    
+    INTEGER :: ierr
+ 
+    IF (.not.is_using_mpi) THEN
+      VarOut(:)=VarIn(:)
+      RETURN
+    ENDIF
+   
+    CALL MPI_REDUCE(VarIn,VarOut,nb,MPI_REAL_LMDZ,MPI_SUM,mpi_master,COMM_LMDZ_PHY,ierr)
+        
+  END SUBROUTINE reduce_sum_mpi_rgen
+
+
+
+  SUBROUTINE reduce_min_mpi_igen(VarIn,VarOut,nb)
+    USE mod_phys_lmdz_mpi_data 
+    USE mod_grid_phy_lmdz
+    USE lmdz_mpi
+    IMPLICIT NONE
+    
+    INTEGER,INTENT(IN) :: nb
+    INTEGER,DIMENSION(nb),INTENT(IN) :: VarIn
+    INTEGER,DIMENSION(nb),INTENT(OUT) :: VarOut    
+    INTEGER :: ierr
+   
+    IF (.not.is_using_mpi) THEN
+      VarOut(:)=VarIn(:)
+      RETURN
+    ENDIF
+
+
+    CALL MPI_REDUCE(VarIn,VarOut,nb,MPI_INTEGER,MPI_MIN,mpi_master,COMM_LMDZ_PHY,ierr)
+            
+  END SUBROUTINE reduce_min_mpi_igen
+  
+  SUBROUTINE reduce_min_mpi_rgen(VarIn,VarOut,nb)
+    USE mod_phys_lmdz_mpi_data 
+    USE mod_grid_phy_lmdz
+    USE lmdz_mpi
+
+    IMPLICIT NONE
+
+    INTEGER,INTENT(IN) :: nb
+    REAL,DIMENSION(nb),INTENT(IN) :: VarIn
+    REAL,DIMENSION(nb),INTENT(OUT) :: VarOut    
+    INTEGER :: ierr
+ 
+    IF (.not.is_using_mpi) THEN
+      VarOut(:)=VarIn(:)
+      RETURN
+    ENDIF
+   
+    CALL MPI_REDUCE(VarIn,VarOut,nb,MPI_REAL_LMDZ,MPI_MIN,mpi_master,COMM_LMDZ_PHY,ierr)
+        
+  END SUBROUTINE reduce_min_mpi_rgen
+
+
+
+
+
+
+
+  SUBROUTINE grid1dTo2d_mpi_igen(VarIn,VarOut,dimsize)
+    USE mod_phys_lmdz_mpi_data
+    USE mod_grid_phy_lmdz
+    IMPLICIT NONE
+    
+    INTEGER,INTENT(IN) :: dimsize
+    INTEGER,INTENT(IN) ,DIMENSION(klon_mpi,dimsize)       :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(nbp_lon*jj_nb,dimsize)  :: VarOut
+    INTEGER :: i,ij,Offset
+
+    
+    VarOut(1:nbp_lon,:)=0
+    VarOut(nbp_lon*(jj_nb-1)+1:nbp_lon*jj_nb,:)=0
+    
+    offset=ii_begin
+    IF (is_north_pole_dyn) Offset=nbp_lon
+    
+    
+    DO i=1,dimsize
+      DO ij=1,klon_mpi
+        VarOut(ij+offset-1,i)=VarIn(ij,i)
+      ENDDO
+    ENDDO
+    
+    
+    IF (is_north_pole_dyn) THEN 
+      DO i=1,dimsize
+        DO ij=1,nbp_lon
+         VarOut(ij,i)=VarIn(1,i)
+        ENDDO
+      ENDDO
+    ENDIF
+    
+    IF (is_south_pole_dyn) THEN 
+      DO i=1,dimsize
+        DO ij=nbp_lon*(jj_nb-1)+1,nbp_lon*jj_nb
+         VarOut(ij,i)=VarIn(klon_mpi,i)
+        ENDDO
+      ENDDO
+    ENDIF
+
+  END SUBROUTINE grid1dTo2d_mpi_igen   
+
+
+  SUBROUTINE grid1dTo2d_mpi_rgen(VarIn,VarOut,dimsize)
+    USE mod_phys_lmdz_mpi_data
+    USE mod_grid_phy_lmdz
+    IMPLICIT NONE
+    
+    INTEGER,INTENT(IN) :: dimsize
+    REAL,INTENT(IN) ,DIMENSION(klon_mpi,dimsize)       :: VarIn
+    REAL,INTENT(OUT),DIMENSION(nbp_lon*jj_nb,dimsize)  :: VarOut
+    INTEGER :: i,ij,Offset
+
+    
+    VarOut(1:nbp_lon,:)=0
+    VarOut(nbp_lon*(jj_nb-1)+1:nbp_lon*jj_nb,:)=0
+    
+    offset=ii_begin
+    IF (is_north_pole_dyn) Offset=nbp_lon
+    
+    
+    DO i=1,dimsize
+      DO ij=1,klon_mpi
+        VarOut(ij+offset-1,i)=VarIn(ij,i)
+      ENDDO
+    ENDDO
+    
+    
+    IF (is_north_pole_dyn) THEN 
+      DO i=1,dimsize
+        DO ij=1,nbp_lon
+         VarOut(ij,i)=VarIn(1,i)
+        ENDDO
+      ENDDO
+    ENDIF
+    
+    IF (is_south_pole_dyn) THEN 
+      DO i=1,dimsize
+        DO ij=nbp_lon*(jj_nb-1)+1,nbp_lon*jj_nb
+         VarOut(ij,i)=VarIn(klon_mpi,i)
+        ENDDO
+      ENDDO
+    ENDIF
+
+   END SUBROUTINE grid1dTo2d_mpi_rgen   
+
+
+
+  SUBROUTINE grid1dTo2d_mpi_lgen(VarIn,VarOut,dimsize)
+    USE mod_phys_lmdz_mpi_data
+    USE mod_grid_phy_lmdz
+    IMPLICIT NONE
+    
+    INTEGER,INTENT(IN) :: dimsize
+    LOGICAL,INTENT(IN) ,DIMENSION(klon_mpi,dimsize)       :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(nbp_lon*jj_nb,dimsize)  :: VarOut
+    INTEGER :: i,ij,Offset
+
+    
+    VarOut(1:nbp_lon,:)=.FALSE.
+    VarOut(nbp_lon*(jj_nb-1)+1:nbp_lon*jj_nb,:)=.FALSE.
+    
+    offset=ii_begin
+    IF (is_north_pole_dyn) Offset=nbp_lon
+    
+    
+    DO i=1,dimsize
+      DO ij=1,klon_mpi
+        VarOut(ij+offset-1,i)=VarIn(ij,i)
+      ENDDO
+    ENDDO
+    
+    
+    IF (is_north_pole_dyn) THEN 
+      DO i=1,dimsize
+        DO ij=1,nbp_lon
+         VarOut(ij,i)=VarIn(1,i)
+        ENDDO
+      ENDDO
+    ENDIF
+    
+    IF (is_south_pole_dyn) THEN 
+      DO i=1,dimsize
+        DO ij=nbp_lon*(jj_nb-1)+1,nbp_lon*jj_nb
+         VarOut(ij,i)=VarIn(klon_mpi,i)
+        ENDDO
+      ENDDO
+    ENDIF
+
+   END SUBROUTINE grid1dTo2d_mpi_lgen   
+
+  
+
+
+  SUBROUTINE grid2dTo1d_mpi_igen(VarIn,VarOut,dimsize)
+    USE mod_phys_lmdz_mpi_data
+    USE mod_grid_phy_lmdz
+    IMPLICIT NONE
+    
+    INTEGER,INTENT(IN) :: dimsize
+    INTEGER,INTENT(IN) ,DIMENSION(nbp_lon*jj_nb,dimsize) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(klon_mpi,dimsize)      :: VarOut
+    INTEGER :: i,ij,offset
+
+    offset=ii_begin
+    IF (is_north_pole_dyn) offset=nbp_lon
+
+    DO i=1,dimsize
+      DO ij=1,klon_mpi
+        VarOut(ij,i)=VarIn(ij+offset-1,i)
+      ENDDO
+    ENDDO
+
+    IF (is_north_pole_dyn) THEN 
+      DO i=1,dimsize
+        VarOut(1,i)=VarIn(1,i)
+      ENDDO
+    ENDIF
+    
+    
+  END SUBROUTINE grid2dTo1d_mpi_igen   
+
+
+
+  SUBROUTINE grid2dTo1d_mpi_rgen(VarIn,VarOut,dimsize)
+    USE mod_phys_lmdz_mpi_data
+    USE mod_grid_phy_lmdz
+    IMPLICIT NONE
+    
+    INTEGER,INTENT(IN) :: dimsize
+    REAL,INTENT(IN) ,DIMENSION(nbp_lon*jj_nb,dimsize) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(klon_mpi,dimsize)      :: VarOut
+    INTEGER :: i,ij,offset
+
+    offset=ii_begin
+    IF (is_north_pole_dyn) offset=nbp_lon
+
+    DO i=1,dimsize
+      DO ij=1,klon_mpi
+        VarOut(ij,i)=VarIn(ij+offset-1,i)
+      ENDDO
+    ENDDO
+
+    IF (is_north_pole_dyn) THEN 
+      DO i=1,dimsize
+         VarOut(1,i)=VarIn(1,i)
+      ENDDO
+    ENDIF
+    
+    
+  END SUBROUTINE grid2dTo1d_mpi_rgen   
+  
+
+  SUBROUTINE grid2dTo1d_mpi_lgen(VarIn,VarOut,dimsize)
+    USE mod_phys_lmdz_mpi_data
+    USE mod_grid_phy_lmdz
+    IMPLICIT NONE
+    
+    INTEGER,INTENT(IN) :: dimsize
+    LOGICAL,INTENT(IN) ,DIMENSION(nbp_lon*jj_nb,dimsize) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(klon_mpi,dimsize)      :: VarOut
+    INTEGER :: i,ij,offset
+
+    offset=ii_begin
+    IF (is_north_pole_dyn) offset=nbp_lon
+
+    DO i=1,dimsize
+      DO ij=1,klon_mpi
+        VarOut(ij,i)=VarIn(ij+offset-1,i)
+      ENDDO
+    ENDDO
+
+    IF (is_north_pole_dyn) THEN 
+      DO i=1,dimsize
+        VarOut(1,i)=VarIn(1,i)
+      ENDDO
+    ENDIF
+    
+    
+  END SUBROUTINE grid2dTo1d_mpi_lgen   
+
+END MODULE mod_phys_lmdz_mpi_transfert
+
Index: DZ6/trunk/libf/phy_common/mod_phys_lmdz_omp_transfert.F90
===================================================================
--- /LMDZ6/trunk/libf/phy_common/mod_phys_lmdz_omp_transfert.F90	(revision 5267)
+++ 	(revision )
@@ -1,1256 +1,0 @@
-!
-!$Header$
-!
-MODULE mod_phys_lmdz_omp_transfert
-
-  PRIVATE
-  
-  REAL,PARAMETER :: grow_factor=1.5
-  INTEGER,PARAMETER :: size_min=1024
-  
-  CHARACTER(LEN=size_min),SAVE            :: buffer_c
-!  INTEGER,SAVE                            :: size_c=0
-  INTEGER,SAVE,ALLOCATABLE,DIMENSION(:)   :: buffer_i
-  INTEGER,SAVE                            :: size_i=0
-  REAL,SAVE,ALLOCATABLE,DIMENSION(:)      :: buffer_r
-  INTEGER,SAVE                            :: size_r=0
-  LOGICAL,SAVE,ALLOCATABLE,DIMENSION(:)   :: buffer_l
-  INTEGER,SAVE                            :: size_l=0
-
-
-  
-  
-  INTERFACE bcast_omp
-    MODULE PROCEDURE bcast_omp_c,                                                     &
-                     bcast_omp_i,bcast_omp_i1,bcast_omp_i2,bcast_omp_i3,bcast_omp_i4, &
-                     bcast_omp_r,bcast_omp_r1,bcast_omp_r2,bcast_omp_r3,bcast_omp_r4, &
-                     bcast_omp_l,bcast_omp_l1,bcast_omp_l2,bcast_omp_l3,bcast_omp_l4
-  END INTERFACE
-
-  INTERFACE scatter_omp
-    MODULE PROCEDURE scatter_omp_i,scatter_omp_i1,scatter_omp_i2,scatter_omp_i3, &
-                     scatter_omp_r,scatter_omp_r1,scatter_omp_r2,scatter_omp_r3, &
-                     scatter_omp_l,scatter_omp_l1,scatter_omp_l2,scatter_omp_l3
-  END INTERFACE
-
-  
-  INTERFACE gather_omp
-    MODULE PROCEDURE gather_omp_i,gather_omp_i1,gather_omp_i2,gather_omp_i3, &
-                     gather_omp_r,gather_omp_r1,gather_omp_r2,gather_omp_r3, &
-                     gather_omp_l,gather_omp_l1,gather_omp_l2,gather_omp_l3  
-  END INTERFACE
-  
-  
-  INTERFACE reduce_sum_omp
-    MODULE PROCEDURE reduce_sum_omp_i,reduce_sum_omp_i1,reduce_sum_omp_i2,reduce_sum_omp_i3,reduce_sum_omp_i4, &
-                     reduce_sum_omp_r,reduce_sum_omp_r1,reduce_sum_omp_r2,reduce_sum_omp_r3,reduce_sum_omp_r4
-  END INTERFACE 
-
-  INTERFACE reduce_min_omp
-    MODULE PROCEDURE reduce_min_omp_i,reduce_min_omp_i1,reduce_min_omp_i2,reduce_min_omp_i3,reduce_min_omp_i4, &
-                     reduce_min_omp_r,reduce_min_omp_r1,reduce_min_omp_r2,reduce_min_omp_r3,reduce_min_omp_r4
-  END INTERFACE 
-
-
-  PUBLIC bcast_omp,scatter_omp,gather_omp,reduce_sum_omp, reduce_min_omp, omp_barrier
-
-CONTAINS
-
-  SUBROUTINE omp_barrier
-  IMPLICIT NONE
-
-!$OMP BARRIER
-
-  END SUBROUTINE omp_barrier
-  
-  SUBROUTINE check_buffer_i(buff_size)
-  IMPLICIT NONE
-  INTEGER :: buff_size
-
-!$OMP BARRIER
-!$OMP MASTER
-    IF (buff_size>size_i) THEN
-      IF (ALLOCATED(buffer_i)) DEALLOCATE(buffer_i)
-      size_i=MAX(size_min,INT(grow_factor*buff_size))
-      ALLOCATE(buffer_i(size_i))
-    ENDIF
-!$OMP END MASTER
-!$OMP BARRIER
-  
-  END SUBROUTINE check_buffer_i
-  
-  SUBROUTINE check_buffer_r(buff_size)
-  IMPLICIT NONE
-  INTEGER :: buff_size
-
-!$OMP BARRIER
-!$OMP MASTER
-    IF (buff_size>size_r) THEN
-      IF (ALLOCATED(buffer_r)) DEALLOCATE(buffer_r)
-      size_r=MAX(size_min,INT(grow_factor*buff_size))
-      ALLOCATE(buffer_r(size_r))
-    ENDIF
-!$OMP END MASTER
-!$OMP BARRIER
-  
-  END SUBROUTINE check_buffer_r
-  
-  SUBROUTINE check_buffer_l(buff_size)
-  IMPLICIT NONE
-  INTEGER :: buff_size
-
-!$OMP BARRIER
-!$OMP MASTER
-    IF (buff_size>size_l) THEN
-      IF (ALLOCATED(buffer_l)) DEALLOCATE(buffer_l)
-      size_l=MAX(size_min,INT(grow_factor*buff_size))
-      ALLOCATE(buffer_l(size_l))
-    ENDIF
-!$OMP END MASTER
-!$OMP BARRIER
-  
-  END SUBROUTINE check_buffer_l
-    
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!! Definition des Broadcast --> 4D   !!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-!! -- Les chaine de charactère -- !!
-
-  SUBROUTINE bcast_omp_c(var)
-  IMPLICIT NONE
-    CHARACTER(LEN=*),INTENT(INOUT) :: Var
-    
-    CALL bcast_omp_cgen(Var,len(Var),buffer_c)
-    
-  END SUBROUTINE bcast_omp_c
-
-!! -- Les entiers -- !!
-  
-  SUBROUTINE bcast_omp_i(var)
-  IMPLICIT NONE
-    INTEGER,INTENT(INOUT) :: Var
-    INTEGER :: Var_tmp(1)
-    
-    Var_tmp(1)=Var
-    CALL check_buffer_i(1)
-    CALL bcast_omp_igen(Var_tmp,1,buffer_i)
-    Var=Var_tmp(1)
-
-  END SUBROUTINE bcast_omp_i
-
-
-  SUBROUTINE bcast_omp_i1(var)
-  IMPLICIT NONE
-    INTEGER,INTENT(INOUT) :: Var(:)
-   
-    CALL check_buffer_i(size(Var))
-    CALL bcast_omp_igen(Var,size(Var),buffer_i)
-
-  END SUBROUTINE bcast_omp_i1
-
-
-  SUBROUTINE bcast_omp_i2(var)
-  IMPLICIT NONE
-    INTEGER,INTENT(INOUT) :: Var(:,:)
-   
-    CALL check_buffer_i(size(Var))
-    CALL bcast_omp_igen(Var,size(Var),buffer_i)
-
-  END SUBROUTINE bcast_omp_i2
-
-
-  SUBROUTINE bcast_omp_i3(var)
-  IMPLICIT NONE
-    INTEGER,INTENT(INOUT) :: Var(:,:,:)
-
-    CALL check_buffer_i(size(Var))
-    CALL bcast_omp_igen(Var,size(Var),buffer_i)
-
-  END SUBROUTINE bcast_omp_i3
-
-
-  SUBROUTINE bcast_omp_i4(var)
-  IMPLICIT NONE
-    INTEGER,INTENT(INOUT) :: Var(:,:,:,:)
-   
-    CALL check_buffer_i(size(Var))
-    CALL bcast_omp_igen(Var,size(Var),buffer_i)
-
-  END SUBROUTINE bcast_omp_i4
-
-
-!! -- Les reels -- !!
-
-  SUBROUTINE bcast_omp_r(var)
-  IMPLICIT NONE
-    REAL,INTENT(INOUT) :: Var
-    REAL :: Var_tmp(1)
-    
-    Var_tmp(1)=Var
-    CALL check_buffer_r(1)
-    CALL bcast_omp_rgen(Var_tmp,1,buffer_r)
-    Var=Var_tmp(1)
-
-  END SUBROUTINE bcast_omp_r
-
-
-  SUBROUTINE bcast_omp_r1(var)
-  IMPLICIT NONE
-    REAL,INTENT(INOUT) :: Var(:)
-   
-    CALL check_buffer_r(size(Var))
-    CALL bcast_omp_rgen(Var,size(Var),buffer_r)
-
-  END SUBROUTINE bcast_omp_r1
-
-
-  SUBROUTINE bcast_omp_r2(var)
-  IMPLICIT NONE
-    REAL,INTENT(INOUT) :: Var(:,:)
-   
-    CALL check_buffer_r(size(Var))
-    CALL bcast_omp_rgen(Var,size(Var),buffer_r)
-
-  END SUBROUTINE bcast_omp_r2
-
-
-  SUBROUTINE bcast_omp_r3(var)
-  IMPLICIT NONE
-    REAL,INTENT(INOUT) :: Var(:,:,:)
-
-    CALL check_buffer_r(size(Var))
-    CALL bcast_omp_rgen(Var,size(Var),buffer_r)
-
-  END SUBROUTINE bcast_omp_r3
-
-
-  SUBROUTINE bcast_omp_r4(var)
-  IMPLICIT NONE
-    REAL,INTENT(INOUT) :: Var(:,:,:,:)
-   
-    CALL check_buffer_r(size(Var))
-    CALL bcast_omp_rgen(Var,size(Var),buffer_r)
-
-  END SUBROUTINE bcast_omp_r4
-
-  
-!! -- Les booleans -- !!
-
-  SUBROUTINE bcast_omp_l(var)
-  IMPLICIT NONE
-    LOGICAL,INTENT(INOUT) :: Var
-    LOGICAL :: Var_tmp(1)
-    
-    Var_tmp(1)=Var
-    CALL check_buffer_l(1)
-    CALL bcast_omp_lgen(Var_tmp,1,buffer_l)
-    Var=Var_tmp(1)
-
-  END SUBROUTINE bcast_omp_l
-
-
-  SUBROUTINE bcast_omp_l1(var)
-  IMPLICIT NONE
-    LOGICAL,INTENT(INOUT) :: Var(:)
-   
-    CALL check_buffer_l(size(Var))
-    CALL bcast_omp_lgen(Var,size(Var),buffer_l)
-
-  END SUBROUTINE bcast_omp_l1
-
-
-  SUBROUTINE bcast_omp_l2(var)
-  IMPLICIT NONE
-    LOGICAL,INTENT(INOUT) :: Var(:,:)
-   
-    CALL check_buffer_l(size(Var))
-    CALL bcast_omp_lgen(Var,size(Var),buffer_l)
-
-  END SUBROUTINE bcast_omp_l2
-
-
-  SUBROUTINE bcast_omp_l3(var)
-  IMPLICIT NONE
-    LOGICAL,INTENT(INOUT) :: Var(:,:,:)
-
-    CALL check_buffer_l(size(Var))
-    CALL bcast_omp_lgen(Var,size(Var),buffer_l)
-
-  END SUBROUTINE bcast_omp_l3
-
-
-  SUBROUTINE bcast_omp_l4(var)
-  IMPLICIT NONE
-    LOGICAL,INTENT(INOUT) :: Var(:,:,:,:)
-   
-    CALL check_buffer_l(size(Var))
-    CALL bcast_omp_lgen(Var,size(Var),buffer_l)
-
-  END SUBROUTINE bcast_omp_l4
-
-
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!! Definition des Scatter   --> 4D   !!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-  SUBROUTINE scatter_omp_i(VarIn, VarOut)
-    IMPLICIT NONE
-  
-    INTEGER,INTENT(IN),DIMENSION(:) :: VarIn
-    INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut
-
-    CALL Check_buffer_i(size(VarIn))   
-    CALL scatter_omp_igen(VarIn,Varout,1,buffer_i)
-    
-  END SUBROUTINE scatter_omp_i
-
-
-  SUBROUTINE scatter_omp_i1(VarIn, VarOut)
-    IMPLICIT NONE
-  
-    INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn
-    INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
-
-    CALL Check_buffer_i(size(VarIn))   
-    CALL scatter_omp_igen(VarIn,Varout,Size(VarOut,2),buffer_i)
-    
-  END SUBROUTINE scatter_omp_i1
-  
-  
-  SUBROUTINE scatter_omp_i2(VarIn, VarOut)
-    IMPLICIT NONE
-  
-    INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn
-    INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
-    
-    CALL Check_buffer_i(size(VarIn))   
-    CALL scatter_omp_igen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3),buffer_i)
-
-  END SUBROUTINE scatter_omp_i2
-
-
-  SUBROUTINE scatter_omp_i3(VarIn, VarOut)
-    IMPLICIT NONE
-  
-    INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
-    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
-    
-    CALL Check_buffer_i(size(VarIn))   
-    CALL scatter_omp_igen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3)*Size(VarOut,4),buffer_i)
-  
-  END SUBROUTINE scatter_omp_i3
-
-
-
-
-  SUBROUTINE scatter_omp_r(VarIn, VarOut)
-    IMPLICIT NONE
-  
-    REAL,INTENT(IN),DIMENSION(:) :: VarIn
-    REAL,INTENT(OUT),DIMENSION(:) :: VarOut
-
-    CALL Check_buffer_r(size(VarIn))   
-    CALL scatter_omp_rgen(VarIn,Varout,1,buffer_r)
-    
-  END SUBROUTINE scatter_omp_r
-
-
-  SUBROUTINE scatter_omp_r1(VarIn, VarOut)
-    IMPLICIT NONE
-  
-    REAL,INTENT(IN),DIMENSION(:,:) :: VarIn
-    REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
-    
-    CALL Check_buffer_r(size(VarIn))   
-    CALL scatter_omp_rgen(VarIn,Varout,Size(VarOut,2),buffer_r)
-        
-  END SUBROUTINE scatter_omp_r1
-  
-  
-  SUBROUTINE scatter_omp_r2(VarIn, VarOut)
-    IMPLICIT NONE
-  
-    REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
-    REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
-    
-    CALL Check_buffer_r(size(VarIn))   
-    CALL scatter_omp_rgen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3),buffer_r)
-
-  END SUBROUTINE scatter_omp_r2
-
-
-  SUBROUTINE scatter_omp_r3(VarIn, VarOut)
-    IMPLICIT NONE
-  
-    REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
-    REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
-    
-    CALL Check_buffer_r(size(VarIn))   
-    CALL scatter_omp_rgen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3)*Size(VarOut,4),buffer_r)
-  
-  END SUBROUTINE scatter_omp_r3
-  
-
-
-  SUBROUTINE scatter_omp_l(VarIn, VarOut)
-    IMPLICIT NONE
-  
-    LOGICAL,INTENT(IN),DIMENSION(:) :: VarIn
-    LOGICAL,INTENT(OUT),DIMENSION(:) :: VarOut
-
-    CALL Check_buffer_l(size(VarIn))   
-    CALL scatter_omp_lgen(VarIn,Varout,1,buffer_l)
-    
-  END SUBROUTINE scatter_omp_l
-
-
-  SUBROUTINE scatter_omp_l1(VarIn, VarOut)
-    IMPLICIT NONE
-  
-    LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn
-    LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
-    
-    CALL Check_buffer_l(size(VarIn))   
-    CALL scatter_omp_lgen(VarIn,Varout,Size(VarOut,2),buffer_l)
-    
-  END SUBROUTINE scatter_omp_l1
-  
-  
-  SUBROUTINE scatter_omp_l2(VarIn, VarOut)
-    IMPLICIT NONE
-  
-    LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
-    LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
-    
-    CALL Check_buffer_l(size(VarIn))   
-    CALL scatter_omp_lgen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3),buffer_l)
-
-  END SUBROUTINE scatter_omp_l2
-
-
-  SUBROUTINE scatter_omp_l3(VarIn, VarOut)
-    IMPLICIT NONE
-  
-    LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
-    LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
-    
-    CALL Check_buffer_l(size(VarIn))   
-    CALL scatter_omp_lgen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3)*Size(VarOut,4),buffer_l)
-  
-  END SUBROUTINE scatter_omp_l3  
-  
-
-  SUBROUTINE gather_omp_i(VarIn, VarOut)
-    IMPLICIT NONE
-  
-    INTEGER,INTENT(IN),DIMENSION(:) :: VarIn
-    INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut
-
-    CALL Check_buffer_i(size(VarOut))   
-    CALL gather_omp_igen(VarIn,Varout,1,buffer_i)
-    
-  END SUBROUTINE gather_omp_i
-
-
-  SUBROUTINE gather_omp_i1(VarIn, VarOut)
-    IMPLICIT NONE
-  
-    INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn
-    INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
-    
-    CALL Check_buffer_i(size(VarOut))   
-    CALL gather_omp_igen(VarIn,Varout,Size(VarIn,2),buffer_i)
-    
-  END SUBROUTINE gather_omp_i1
-
-
-  SUBROUTINE gather_omp_i2(VarIn, VarOut)
-    IMPLICIT NONE
-  
-    INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn
-    INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
-    
-    CALL Check_buffer_i(size(VarOut))   
-    CALL gather_omp_igen(VarIn,Varout,Size(VarIn,2)*Size(VarIn,3),buffer_i)
-          
-  END SUBROUTINE gather_omp_i2
-  
-
-  SUBROUTINE gather_omp_i3(VarIn, VarOut)
-    IMPLICIT NONE
-  
-    INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
-    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
-    
-    CALL Check_buffer_i(size(VarOut))   
-    CALL gather_omp_igen(VarIn,Varout,Size(VarIn,2)*Size(VarIn,3)*Size(VarIn,4),buffer_i)
-    
-  END SUBROUTINE gather_omp_i3
-
-
-
-  SUBROUTINE gather_omp_r(VarIn, VarOut)
-    IMPLICIT NONE
-  
-    REAL,INTENT(IN),DIMENSION(:) :: VarIn
-    REAL,INTENT(OUT),DIMENSION(:) :: VarOut
-
-    CALL gather_omp_rgen(VarIn,Varout,1)
-    
-  END SUBROUTINE gather_omp_r
-
-
-  SUBROUTINE gather_omp_r1(VarIn, VarOut)
-    IMPLICIT NONE
-  
-    REAL,INTENT(IN),DIMENSION(:,:) :: VarIn
-    REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
- 
-    CALL gather_omp_rgen(VarIn,Varout,Size(VarIn,2))
-        
-  END SUBROUTINE gather_omp_r1
-
-
-  SUBROUTINE gather_omp_r2(VarIn, VarOut)
-    IMPLICIT NONE
-  
-    REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
-    REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
- 
-    CALL gather_omp_rgen(VarIn,Varout,Size(VarIn,2)*Size(VarIn,3))
-    
-  END SUBROUTINE gather_omp_r2
-  
-
-  SUBROUTINE gather_omp_r3(VarIn, VarOut)
-    IMPLICIT NONE
-  
-    REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
-    REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
-     
-    CALL gather_omp_rgen(VarIn,Varout,Size(VarIn,2)*Size(VarIn,3)*Size(VarIn,4))
-    
-  END SUBROUTINE gather_omp_r3
-
-
-  SUBROUTINE gather_omp_l(VarIn, VarOut)
-    IMPLICIT NONE
-  
-    LOGICAL,INTENT(IN),DIMENSION(:) :: VarIn
-    LOGICAL,INTENT(OUT),DIMENSION(:) :: VarOut
-
-    CALL Check_buffer_l(size(VarOut))   
-    CALL gather_omp_lgen(VarIn,Varout,1,buffer_l)
-    
-  END SUBROUTINE gather_omp_l
-
-
-  SUBROUTINE gather_omp_l1(VarIn, VarOut)
-    IMPLICIT NONE
-  
-    LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn
-    LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
-    
-    CALL Check_buffer_l(size(VarOut))   
-    CALL gather_omp_lgen(VarIn,Varout,Size(VarIn,2),buffer_l)
-    
-  END SUBROUTINE gather_omp_l1
-
-
-  SUBROUTINE gather_omp_l2(VarIn, VarOut)
-    IMPLICIT NONE
-  
-    LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
-    LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
-    
-    CALL Check_buffer_l(size(VarOut))   
-    CALL gather_omp_lgen(VarIn,Varout,Size(VarIn,2)*Size(VarIn,3),buffer_l)
-    
-  END SUBROUTINE gather_omp_l2
-  
-
-  SUBROUTINE gather_omp_l3(VarIn, VarOut)
-    IMPLICIT NONE
-  
-    LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
-    LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
-    
-    CALL Check_buffer_l(size(VarOut))   
-    CALL gather_omp_lgen(VarIn,Varout,Size(VarIn,2)*Size(VarIn,3)*Size(VarIn,4),buffer_l)
-    
-  END SUBROUTINE gather_omp_l3
-
-
-
-
-  SUBROUTINE reduce_sum_omp_i(VarIn, VarOut)
-    IMPLICIT NONE
-  
-    INTEGER,INTENT(IN)  :: VarIn
-    INTEGER,INTENT(OUT) :: VarOut
-    INTEGER             :: VarIn_tmp(1)
-    INTEGER             :: VarOut_tmp(1)
-    
-    VarIn_tmp(1)=VarIn
-    CALL Check_buffer_i(1)   
-    CALL reduce_sum_omp_igen(VarIn_tmp,Varout_tmp,1,buffer_i)
-    VarOut=VarOut_tmp(1)
-    
-  END SUBROUTINE reduce_sum_omp_i
-
-  SUBROUTINE reduce_sum_omp_i1(VarIn, VarOut)
-    IMPLICIT NONE
-  
-    INTEGER,INTENT(IN),DIMENSION(:)  :: VarIn
-    INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut
-    
-    CALL Check_buffer_i(size(VarIn))   
-    CALL reduce_sum_omp_igen(VarIn,Varout,Size(VarIn),buffer_i)
-   
-  END SUBROUTINE reduce_sum_omp_i1
-  
-  
-  SUBROUTINE reduce_sum_omp_i2(VarIn, VarOut)
-    IMPLICIT NONE
-  
-    INTEGER,INTENT(IN),DIMENSION(:,:)  :: VarIn
-    INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
-
-    CALL Check_buffer_i(size(VarIn))   
-    CALL reduce_sum_omp_igen(VarIn,Varout,Size(VarIn),buffer_i)
-  
-  END SUBROUTINE reduce_sum_omp_i2
-
-
-  SUBROUTINE reduce_sum_omp_i3(VarIn, VarOut)
-    IMPLICIT NONE
-  
-    INTEGER,INTENT(IN),DIMENSION(:,:,:)  :: VarIn
-    INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
-    
-    CALL Check_buffer_i(size(VarIn))   
-    CALL reduce_sum_omp_igen(VarIn,Varout,Size(VarIn),buffer_i)
-  
-  END SUBROUTINE reduce_sum_omp_i3
-
-
-  SUBROUTINE reduce_sum_omp_i4(VarIn, VarOut)
-    IMPLICIT NONE
-
-    INTEGER,INTENT(IN),DIMENSION(:,:,:,:)  :: VarIn
-    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
-  
-    CALL Check_buffer_i(size(VarIn))   
-    CALL reduce_sum_omp_igen(VarIn,Varout,Size(VarIn),buffer_i)
-  
-  END SUBROUTINE reduce_sum_omp_i4
-
-
-  SUBROUTINE reduce_sum_omp_r(VarIn, VarOut)
-    IMPLICIT NONE
-  
-    REAL,INTENT(IN)  :: VarIn
-    REAL,INTENT(OUT) :: VarOut
-    REAL             :: VarIn_tmp(1)
-    REAL             :: VarOut_tmp(1)
-    
-    VarIn_tmp(1)=VarIn
-    CALL Check_buffer_r(1)   
-    CALL reduce_sum_omp_rgen(VarIn_tmp,Varout_tmp,1,buffer_r)
-    VarOut=VarOut_tmp(1)
-  
-  END SUBROUTINE reduce_sum_omp_r
-
-  SUBROUTINE reduce_sum_omp_r1(VarIn, VarOut)
-    IMPLICIT NONE
-  
-    REAL,INTENT(IN),DIMENSION(:)  :: VarIn
-    REAL,INTENT(OUT),DIMENSION(:) :: VarOut
-    
-    CALL Check_buffer_r(size(VarIn))   
-    CALL reduce_sum_omp_rgen(VarIn,Varout,Size(VarIn),buffer_r)
-   
-  END SUBROUTINE reduce_sum_omp_r1
-  
-  
-  SUBROUTINE reduce_sum_omp_r2(VarIn, VarOut)
-    IMPLICIT NONE
-  
-    REAL,INTENT(IN),DIMENSION(:,:)  :: VarIn
-    REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
-    
-    CALL Check_buffer_r(size(VarIn))   
-    CALL reduce_sum_omp_rgen(VarIn,Varout,Size(VarIn),buffer_r)
-  
-  END SUBROUTINE reduce_sum_omp_r2
-
-
-  SUBROUTINE reduce_sum_omp_r3(VarIn, VarOut)
-    IMPLICIT NONE
-  
-    REAL,INTENT(IN),DIMENSION(:,:,:)  :: VarIn
-    REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
-    
-    CALL Check_buffer_r(size(VarIn))   
-    CALL reduce_sum_omp_rgen(VarIn,Varout,Size(VarIn),buffer_r)
-  
-  END SUBROUTINE reduce_sum_omp_r3
-
-
-  SUBROUTINE reduce_sum_omp_r4(VarIn, VarOut)
-    IMPLICIT NONE
-
-    REAL,INTENT(IN),DIMENSION(:,:,:,:)  :: VarIn
-    REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
-  
-    CALL Check_buffer_r(size(VarIn))   
-    CALL reduce_sum_omp_rgen(VarIn,Varout,Size(VarIn),buffer_r)
-  
-  END SUBROUTINE reduce_sum_omp_r4
-
-
-
-  SUBROUTINE reduce_min_omp_i(VarIn, VarOut)
-    IMPLICIT NONE
-  
-    INTEGER,INTENT(IN)  :: VarIn
-    INTEGER,INTENT(OUT) :: VarOut
-    INTEGER             :: VarIn_tmp(1)
-    INTEGER             :: VarOut_tmp(1)
-    
-    VarIn_tmp(1)=VarIn
-    CALL Check_buffer_i(1)   
-    CALL reduce_min_omp_igen(VarIn_tmp,Varout_tmp,1,buffer_i)
-    VarOut=VarOut_tmp(1)
-    
-  END SUBROUTINE reduce_min_omp_i
-
-  SUBROUTINE reduce_min_omp_i1(VarIn, VarOut)
-    IMPLICIT NONE
-  
-    INTEGER,INTENT(IN),DIMENSION(:)  :: VarIn
-    INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut
-    
-    CALL Check_buffer_i(size(VarIn))   
-    CALL reduce_min_omp_igen(VarIn,Varout,Size(VarIn),buffer_i)
-   
-  END SUBROUTINE reduce_min_omp_i1
-  
-  
-  SUBROUTINE reduce_min_omp_i2(VarIn, VarOut)
-    IMPLICIT NONE
-  
-    INTEGER,INTENT(IN),DIMENSION(:,:)  :: VarIn
-    INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
-
-    CALL Check_buffer_i(size(VarIn))   
-    CALL reduce_min_omp_igen(VarIn,Varout,Size(VarIn),buffer_i)
-  
-  END SUBROUTINE reduce_min_omp_i2
-
-
-  SUBROUTINE reduce_min_omp_i3(VarIn, VarOut)
-    IMPLICIT NONE
-  
-    INTEGER,INTENT(IN),DIMENSION(:,:,:)  :: VarIn
-    INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
-    
-    CALL Check_buffer_i(size(VarIn))   
-    CALL reduce_min_omp_igen(VarIn,Varout,Size(VarIn),buffer_i)
-  
-  END SUBROUTINE reduce_min_omp_i3
-
-
-  SUBROUTINE reduce_min_omp_i4(VarIn, VarOut)
-    IMPLICIT NONE
-
-    INTEGER,INTENT(IN),DIMENSION(:,:,:,:)  :: VarIn
-    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
-  
-    CALL Check_buffer_i(size(VarIn))   
-    CALL reduce_min_omp_igen(VarIn,Varout,Size(VarIn),buffer_i)
-  
-  END SUBROUTINE reduce_min_omp_i4
-
-
-  SUBROUTINE reduce_min_omp_r(VarIn, VarOut)
-    IMPLICIT NONE
-  
-    REAL,INTENT(IN)  :: VarIn
-    REAL,INTENT(OUT) :: VarOut
-    REAL             :: VarIn_tmp(1)
-    REAL             :: VarOut_tmp(1)
-    
-    VarIn_tmp(1)=VarIn
-    CALL Check_buffer_r(1)   
-    CALL reduce_min_omp_rgen(VarIn_tmp,Varout_tmp,1,buffer_r)
-    VarOut=VarOut_tmp(1)
-  
-  END SUBROUTINE reduce_min_omp_r
-
-  SUBROUTINE reduce_min_omp_r1(VarIn, VarOut)
-    IMPLICIT NONE
-  
-    REAL,INTENT(IN),DIMENSION(:)  :: VarIn
-    REAL,INTENT(OUT),DIMENSION(:) :: VarOut
-    
-    CALL Check_buffer_r(size(VarIn))   
-    CALL reduce_min_omp_rgen(VarIn,Varout,Size(VarIn),buffer_r)
-   
-  END SUBROUTINE reduce_min_omp_r1
-  
-  
-  SUBROUTINE reduce_min_omp_r2(VarIn, VarOut)
-    IMPLICIT NONE
-  
-    REAL,INTENT(IN),DIMENSION(:,:)  :: VarIn
-    REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
-    
-    CALL Check_buffer_r(size(VarIn))   
-    CALL reduce_min_omp_rgen(VarIn,Varout,Size(VarIn),buffer_r)
-  
-  END SUBROUTINE reduce_min_omp_r2
-
-
-  SUBROUTINE reduce_min_omp_r3(VarIn, VarOut)
-    IMPLICIT NONE
-  
-    REAL,INTENT(IN),DIMENSION(:,:,:)  :: VarIn
-    REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
-    
-    CALL Check_buffer_r(size(VarIn))   
-    CALL reduce_min_omp_rgen(VarIn,Varout,Size(VarIn),buffer_r)
-  
-  END SUBROUTINE reduce_min_omp_r3
-
-
-  SUBROUTINE reduce_min_omp_r4(VarIn, VarOut)
-    IMPLICIT NONE
-
-    REAL,INTENT(IN),DIMENSION(:,:,:,:)  :: VarIn
-    REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
-  
-    CALL Check_buffer_r(size(VarIn))   
-    CALL reduce_min_omp_rgen(VarIn,Varout,Size(VarIn),buffer_r)
-  
-  END SUBROUTINE reduce_min_omp_r4
-
-
-
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!    LES ROUTINES GENERIQUES    !
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-  SUBROUTINE bcast_omp_cgen(Var,Nb,Buff)
-  IMPLICIT NONE
-    
-    CHARACTER(LEN=*),INTENT(INOUT) :: Var
-    CHARACTER(LEN=*),INTENT(INOUT) :: Buff
-    INTEGER,INTENT(IN) :: Nb
-    
-    INTEGER :: i
-  
-  !$OMP MASTER
-      Buff=Var
-  !$OMP END MASTER
-  !$OMP BARRIER
-
-    DO i=1,Nb
-      Var=Buff
-    ENDDO
-  !$OMP BARRIER      
-  
-  END SUBROUTINE bcast_omp_cgen
-
-
-      
-  SUBROUTINE bcast_omp_igen(Var,Nb,Buff)
-  IMPLICIT NONE
-    
-    INTEGER,INTENT(IN) :: Nb
-    INTEGER,DIMENSION(Nb),INTENT(INOUT) :: Var
-    INTEGER,DIMENSION(Nb),INTENT(INOUT) :: Buff
-
-    INTEGER :: i
-    
-  !$OMP MASTER
-    DO i=1,Nb
-      Buff(i)=Var(i)
-    ENDDO
-  !$OMP END MASTER
-  !$OMP BARRIER
-
-    DO i=1,Nb
-      Var(i)=Buff(i)
-    ENDDO
-  !$OMP BARRIER        
-
-  END SUBROUTINE bcast_omp_igen
-
-
-  SUBROUTINE bcast_omp_rgen(Var,Nb,Buff)
-  IMPLICIT NONE
-    
-    INTEGER,INTENT(IN) :: Nb
-    REAL,DIMENSION(Nb),INTENT(INOUT) :: Var
-    REAL,DIMENSION(Nb),INTENT(INOUT) :: Buff
-
-    INTEGER :: i
-    
-  !$OMP MASTER
-    DO i=1,Nb
-      Buff(i)=Var(i)
-    ENDDO
-  !$OMP END MASTER
-  !$OMP BARRIER
-
-    DO i=1,Nb
-      Var(i)=Buff(i)
-    ENDDO
-  !$OMP BARRIER        
-
-  END SUBROUTINE bcast_omp_rgen
-
-  SUBROUTINE bcast_omp_lgen(Var,Nb,Buff)
-  IMPLICIT NONE
-    
-    INTEGER,INTENT(IN) :: Nb
-    LOGICAL,DIMENSION(Nb),INTENT(INOUT) :: Var
-    LOGICAL,DIMENSION(Nb),INTENT(INOUT) :: Buff
-  
-    INTEGER :: i
-    
-  !$OMP MASTER
-    DO i=1,Nb
-      Buff(i)=Var(i)
-    ENDDO
-  !$OMP END MASTER
-  !$OMP BARRIER
-
-    DO i=1,Nb
-      Var(i)=Buff(i)
-    ENDDO
-  !$OMP BARRIER        
-
-  END SUBROUTINE bcast_omp_lgen
-
-
-  SUBROUTINE scatter_omp_igen(VarIn,VarOut,dimsize,Buff)
-    USE mod_phys_lmdz_omp_data
-    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi 
-    IMPLICIT NONE
-
-    INTEGER,INTENT(IN) :: dimsize
-    INTEGER,INTENT(IN),DIMENSION(klon_mpi,dimsize) :: VarIn
-    INTEGER,INTENT(OUT),DIMENSION(klon_omp,dimsize) :: VarOut
-    INTEGER,INTENT(INOUT),DIMENSION(klon_mpi,dimsize) :: Buff
-
-    INTEGER :: i,ij
-    
-  !$OMP MASTER
-    DO i=1,dimsize
-      DO ij=1,klon_mpi
-        Buff(ij,i)=VarIn(ij,i)
-      ENDDO
-    ENDDO  
-  !$OMP END MASTER
-  !$OMP BARRIER
- 
-    DO i=1,dimsize
-      DO ij=1,klon_omp
-        VarOut(ij,i)=Buff(klon_omp_begin-1+ij,i)
-      ENDDO
-    ENDDO
-  !$OMP BARRIER  
- 
-  END SUBROUTINE scatter_omp_igen
-
-
-  SUBROUTINE scatter_omp_rgen(VarIn,VarOut,dimsize,Buff)
-  USE mod_phys_lmdz_omp_data
-  USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi 
-  IMPLICIT NONE
-
-    INTEGER,INTENT(IN) :: dimsize
-    REAL,INTENT(IN),DIMENSION(klon_mpi,dimsize) :: VarIn
-    REAL,INTENT(OUT),DIMENSION(klon_omp,dimsize) :: VarOut
-    REAL,INTENT(INOUT),DIMENSION(klon_mpi,dimsize) :: Buff
-
-    INTEGER :: i,ij
-    
-  !$OMP MASTER
-    DO i=1,dimsize
-      DO ij=1,klon_mpi
-        Buff(ij,i)=VarIn(ij,i)
-      ENDDO
-    ENDDO  
-  !$OMP END MASTER
-  !$OMP BARRIER
-
-    DO i=1,dimsize
-      DO ij=1,klon_omp
-        VarOut(ij,i)=Buff(klon_omp_begin-1+ij,i)
-      ENDDO
-    ENDDO
-  !$OMP BARRIER  
-
-  END SUBROUTINE scatter_omp_rgen
-
-
-  SUBROUTINE scatter_omp_lgen(VarIn,VarOut,dimsize,Buff)
-  USE mod_phys_lmdz_omp_data
-  USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi 
-  IMPLICIT NONE
-
-    INTEGER,INTENT(IN) :: dimsize
-    LOGICAL,INTENT(IN),DIMENSION(klon_mpi,dimsize) :: VarIn
-    LOGICAL,INTENT(OUT),DIMENSION(klon_omp,dimsize) :: VarOut
-    LOGICAL,INTENT(INOUT),DIMENSION(klon_mpi,dimsize) :: Buff
-
-    INTEGER :: i,ij
-    
- !$OMP MASTER 
-    DO i=1,dimsize
-      DO ij=1,klon_mpi
-        Buff(ij,i)=VarIn(ij,i)
-      ENDDO
-    ENDDO  
-  !$OMP END MASTER
-  !$OMP BARRIER
-
-    DO i=1,dimsize
-      DO ij=1,klon_omp
-        VarOut(ij,i)=Buff(klon_omp_begin-1+ij,i)
-      ENDDO
-    ENDDO
-  !$OMP BARRIER  
-
-  END SUBROUTINE scatter_omp_lgen
-
-
-
-
-
-  SUBROUTINE gather_omp_igen(VarIn,VarOut,dimsize,Buff)
-  USE mod_phys_lmdz_omp_data
-  USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi 
-  IMPLICIT NONE
-
-    INTEGER,INTENT(IN) :: dimsize
-    INTEGER,INTENT(IN),DIMENSION(klon_omp,dimsize) :: VarIn
-    INTEGER,INTENT(OUT),DIMENSION(klon_mpi,dimsize) :: VarOut
-    INTEGER,INTENT(INOUT),DIMENSION(klon_mpi,dimsize) :: Buff
-
-    INTEGER :: i,ij
-    
-    DO i=1,dimsize
-      DO ij=1,klon_omp
-        Buff(klon_omp_begin-1+ij,i)=VarIn(ij,i)
-      ENDDO
-    ENDDO
-  !$OMP BARRIER  
-  
-  
-  !$OMP MASTER
-    DO i=1,dimsize
-      DO ij=1,klon_mpi
-        VarOut(ij,i)=Buff(ij,i)
-      ENDDO
-    ENDDO  
-  !$OMP END MASTER
-  !$OMP BARRIER
-
-  END SUBROUTINE gather_omp_igen
-
-
-  SUBROUTINE gather_omp_rgen(VarIn,VarOut,dimsize)
-  USE mod_phys_lmdz_omp_data
-  USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi 
-  IMPLICIT NONE
-
-    INTEGER,INTENT(IN) :: dimsize
-    REAL,INTENT(IN),DIMENSION(klon_omp,dimsize) :: VarIn
-    REAL,INTENT(OUT),DIMENSION(klon_mpi,dimsize),TARGET :: VarOut
-
-    REAL, POINTER, SAVE :: Varout_ptr(:,:) ! Shared between threads NOT THREADPRIVATE
-
-    INTEGER :: i,ij
-    
-    !$omp master
-    Varout_ptr => VarOut
-    !$omp end master
-    !$omp barrier
-
-    DO i=1,dimsize
-      DO ij=1,klon_omp
-        Varout_ptr(klon_omp_begin-1+ij,i)=VarIn(ij,i)
-      ENDDO
-    ENDDO
-    !$omp barrier
-  END SUBROUTINE gather_omp_rgen
-
-
-  SUBROUTINE gather_omp_lgen(VarIn,VarOut,dimsize,Buff)
-  USE mod_phys_lmdz_omp_data
-  USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi 
-  IMPLICIT NONE
-
-    INTEGER,INTENT(IN) :: dimsize
-    LOGICAL,INTENT(IN),DIMENSION(klon_omp,dimsize) :: VarIn
-    LOGICAL,INTENT(OUT),DIMENSION(klon_mpi,dimsize) :: VarOut
-    LOGICAL,INTENT(INOUT),DIMENSION(klon_mpi,dimsize) :: Buff
-
-    INTEGER :: i,ij
-    
-    DO i=1,dimsize
-      DO ij=1,klon_omp
-        Buff(klon_omp_begin-1+ij,i)=VarIn(ij,i)
-      ENDDO
-    ENDDO
-  !$OMP BARRIER  
-
-
-  !$OMP MASTER
-    DO i=1,dimsize
-      DO ij=1,klon_mpi
-        VarOut(ij,i)=Buff(ij,i)
-      ENDDO
-    ENDDO  
-  !$OMP END MASTER
-  !$OMP BARRIER
-
-  END SUBROUTINE gather_omp_lgen
-
-
-  SUBROUTINE reduce_sum_omp_igen(VarIn,VarOut,dimsize,Buff)
-  IMPLICIT NONE
-
-    INTEGER,INTENT(IN) :: dimsize
-    INTEGER,INTENT(IN),DIMENSION(dimsize) :: VarIn
-    INTEGER,INTENT(OUT),DIMENSION(dimsize) :: VarOut
-    INTEGER,INTENT(INOUT),DIMENSION(dimsize) :: Buff
-
-    INTEGER :: i
-
-  !$OMP MASTER
-    Buff(:)=0
-  !$OMP END MASTER
-  !$OMP BARRIER
-  
-  !$OMP CRITICAL     
-    DO i=1,dimsize
-      Buff(i)=Buff(i)+VarIn(i)
-    ENDDO
-  !$OMP END CRITICAL
-  !$OMP BARRIER  
-  
-  !$OMP MASTER
-    DO i=1,dimsize
-      VarOut(i)=Buff(i)
-    ENDDO
-  !$OMP END MASTER
-  !$OMP BARRIER
-  
-  END SUBROUTINE reduce_sum_omp_igen
-
-  SUBROUTINE reduce_sum_omp_rgen(VarIn,VarOut,dimsize,Buff)
-  IMPLICIT NONE
-
-    INTEGER,INTENT(IN) :: dimsize
-    REAL,INTENT(IN),DIMENSION(dimsize) :: VarIn
-    REAL,INTENT(OUT),DIMENSION(dimsize) :: VarOut
-    REAL,INTENT(INOUT),DIMENSION(dimsize) :: Buff
-
-    INTEGER :: i
-
-  !$OMP MASTER
-    Buff(:)=0
-  !$OMP END MASTER
-  !$OMP BARRIER
-  
-  !$OMP CRITICAL     
-    DO i=1,dimsize
-      Buff(i)=Buff(i)+VarIn(i)
-    ENDDO
-  !$OMP END CRITICAL
-  !$OMP BARRIER  
-  
-  !$OMP MASTER
-    DO i=1,dimsize
-      VarOut(i)=Buff(i)
-    ENDDO
-  !$OMP END MASTER
-  !$OMP BARRIER
-  
-  END SUBROUTINE reduce_sum_omp_rgen
-
-
-  SUBROUTINE reduce_min_omp_igen(VarIn,VarOut,dimsize,Buff)
-  IMPLICIT NONE
-
-    INTEGER,INTENT(IN) :: dimsize
-    INTEGER,INTENT(IN),DIMENSION(dimsize) :: VarIn
-    INTEGER,INTENT(OUT),DIMENSION(dimsize) :: VarOut
-    INTEGER,INTENT(INOUT),DIMENSION(dimsize) :: Buff
-
-    INTEGER :: i
-    INTEGER :: var
-
-  !$OMP MASTER
-    Buff(:)=HUGE(var)
-  !$OMP END MASTER
-  !$OMP BARRIER
-  
-  !$OMP CRITICAL     
-    DO i=1,dimsize
-      Buff(i)=MIN(Buff(i),VarIn(i))
-    ENDDO
-  !$OMP END CRITICAL
-  !$OMP BARRIER  
-  
-  !$OMP MASTER
-    DO i=1,dimsize
-      VarOut(i)=Buff(i)
-    ENDDO
-  !$OMP END MASTER
-  !$OMP BARRIER
-  
-  END SUBROUTINE reduce_min_omp_igen
-
-  SUBROUTINE reduce_min_omp_rgen(VarIn,VarOut,dimsize,Buff)
-  IMPLICIT NONE
-
-    INTEGER,INTENT(IN) :: dimsize
-    REAL,INTENT(IN),DIMENSION(dimsize) :: VarIn
-    REAL,INTENT(OUT),DIMENSION(dimsize) :: VarOut
-    REAL,INTENT(INOUT),DIMENSION(dimsize) :: Buff
-
-    INTEGER :: i
-    REAL :: var
-
-  !$OMP MASTER
-    Buff(:)=HUGE(var)
-  !$OMP END MASTER
-  !$OMP BARRIER
-  
-  !$OMP CRITICAL     
-    DO i=1,dimsize
-      Buff(i)=MIN(Buff(i),VarIn(i))
-    ENDDO
-  !$OMP END CRITICAL
-  !$OMP BARRIER  
-  
-  !$OMP MASTER
-    DO i=1,dimsize
-      VarOut(i)=Buff(i)
-    ENDDO
-  !$OMP END MASTER
-  !$OMP BARRIER
-  
-  END SUBROUTINE reduce_min_omp_rgen
-
-
-END MODULE mod_phys_lmdz_omp_transfert
Index: /LMDZ6/trunk/libf/phy_common/mod_phys_lmdz_omp_transfert.f90
===================================================================
--- /LMDZ6/trunk/libf/phy_common/mod_phys_lmdz_omp_transfert.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phy_common/mod_phys_lmdz_omp_transfert.f90	(revision 5268)
@@ -0,0 +1,1256 @@
+!
+!$Header$
+!
+MODULE mod_phys_lmdz_omp_transfert
+
+  PRIVATE
+  
+  REAL,PARAMETER :: grow_factor=1.5
+  INTEGER,PARAMETER :: size_min=1024
+  
+  CHARACTER(LEN=size_min),SAVE            :: buffer_c
+!  INTEGER,SAVE                            :: size_c=0
+  INTEGER,SAVE,ALLOCATABLE,DIMENSION(:)   :: buffer_i
+  INTEGER,SAVE                            :: size_i=0
+  REAL,SAVE,ALLOCATABLE,DIMENSION(:)      :: buffer_r
+  INTEGER,SAVE                            :: size_r=0
+  LOGICAL,SAVE,ALLOCATABLE,DIMENSION(:)   :: buffer_l
+  INTEGER,SAVE                            :: size_l=0
+
+
+  
+  
+  INTERFACE bcast_omp
+    MODULE PROCEDURE bcast_omp_c,                                                     &
+                     bcast_omp_i,bcast_omp_i1,bcast_omp_i2,bcast_omp_i3,bcast_omp_i4, &
+                     bcast_omp_r,bcast_omp_r1,bcast_omp_r2,bcast_omp_r3,bcast_omp_r4, &
+                     bcast_omp_l,bcast_omp_l1,bcast_omp_l2,bcast_omp_l3,bcast_omp_l4
+  END INTERFACE
+
+  INTERFACE scatter_omp
+    MODULE PROCEDURE scatter_omp_i,scatter_omp_i1,scatter_omp_i2,scatter_omp_i3, &
+                     scatter_omp_r,scatter_omp_r1,scatter_omp_r2,scatter_omp_r3, &
+                     scatter_omp_l,scatter_omp_l1,scatter_omp_l2,scatter_omp_l3
+  END INTERFACE
+
+  
+  INTERFACE gather_omp
+    MODULE PROCEDURE gather_omp_i,gather_omp_i1,gather_omp_i2,gather_omp_i3, &
+                     gather_omp_r,gather_omp_r1,gather_omp_r2,gather_omp_r3, &
+                     gather_omp_l,gather_omp_l1,gather_omp_l2,gather_omp_l3  
+  END INTERFACE
+  
+  
+  INTERFACE reduce_sum_omp
+    MODULE PROCEDURE reduce_sum_omp_i,reduce_sum_omp_i1,reduce_sum_omp_i2,reduce_sum_omp_i3,reduce_sum_omp_i4, &
+                     reduce_sum_omp_r,reduce_sum_omp_r1,reduce_sum_omp_r2,reduce_sum_omp_r3,reduce_sum_omp_r4
+  END INTERFACE 
+
+  INTERFACE reduce_min_omp
+    MODULE PROCEDURE reduce_min_omp_i,reduce_min_omp_i1,reduce_min_omp_i2,reduce_min_omp_i3,reduce_min_omp_i4, &
+                     reduce_min_omp_r,reduce_min_omp_r1,reduce_min_omp_r2,reduce_min_omp_r3,reduce_min_omp_r4
+  END INTERFACE 
+
+
+  PUBLIC bcast_omp,scatter_omp,gather_omp,reduce_sum_omp, reduce_min_omp, omp_barrier
+
+CONTAINS
+
+  SUBROUTINE omp_barrier
+  IMPLICIT NONE
+
+!$OMP BARRIER
+
+  END SUBROUTINE omp_barrier
+  
+  SUBROUTINE check_buffer_i(buff_size)
+  IMPLICIT NONE
+  INTEGER :: buff_size
+
+!$OMP BARRIER
+!$OMP MASTER
+    IF (buff_size>size_i) THEN
+      IF (ALLOCATED(buffer_i)) DEALLOCATE(buffer_i)
+      size_i=MAX(size_min,INT(grow_factor*buff_size))
+      ALLOCATE(buffer_i(size_i))
+    ENDIF
+!$OMP END MASTER
+!$OMP BARRIER
+  
+  END SUBROUTINE check_buffer_i
+  
+  SUBROUTINE check_buffer_r(buff_size)
+  IMPLICIT NONE
+  INTEGER :: buff_size
+
+!$OMP BARRIER
+!$OMP MASTER
+    IF (buff_size>size_r) THEN
+      IF (ALLOCATED(buffer_r)) DEALLOCATE(buffer_r)
+      size_r=MAX(size_min,INT(grow_factor*buff_size))
+      ALLOCATE(buffer_r(size_r))
+    ENDIF
+!$OMP END MASTER
+!$OMP BARRIER
+  
+  END SUBROUTINE check_buffer_r
+  
+  SUBROUTINE check_buffer_l(buff_size)
+  IMPLICIT NONE
+  INTEGER :: buff_size
+
+!$OMP BARRIER
+!$OMP MASTER
+    IF (buff_size>size_l) THEN
+      IF (ALLOCATED(buffer_l)) DEALLOCATE(buffer_l)
+      size_l=MAX(size_min,INT(grow_factor*buff_size))
+      ALLOCATE(buffer_l(size_l))
+    ENDIF
+!$OMP END MASTER
+!$OMP BARRIER
+  
+  END SUBROUTINE check_buffer_l
+    
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! Definition des Broadcast --> 4D   !!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+!! -- Les chaine de charactère -- !!
+
+  SUBROUTINE bcast_omp_c(var)
+  IMPLICIT NONE
+    CHARACTER(LEN=*),INTENT(INOUT) :: Var
+    
+    CALL bcast_omp_cgen(Var,len(Var),buffer_c)
+    
+  END SUBROUTINE bcast_omp_c
+
+!! -- Les entiers -- !!
+  
+  SUBROUTINE bcast_omp_i(var)
+  IMPLICIT NONE
+    INTEGER,INTENT(INOUT) :: Var
+    INTEGER :: Var_tmp(1)
+    
+    Var_tmp(1)=Var
+    CALL check_buffer_i(1)
+    CALL bcast_omp_igen(Var_tmp,1,buffer_i)
+    Var=Var_tmp(1)
+
+  END SUBROUTINE bcast_omp_i
+
+
+  SUBROUTINE bcast_omp_i1(var)
+  IMPLICIT NONE
+    INTEGER,INTENT(INOUT) :: Var(:)
+   
+    CALL check_buffer_i(size(Var))
+    CALL bcast_omp_igen(Var,size(Var),buffer_i)
+
+  END SUBROUTINE bcast_omp_i1
+
+
+  SUBROUTINE bcast_omp_i2(var)
+  IMPLICIT NONE
+    INTEGER,INTENT(INOUT) :: Var(:,:)
+   
+    CALL check_buffer_i(size(Var))
+    CALL bcast_omp_igen(Var,size(Var),buffer_i)
+
+  END SUBROUTINE bcast_omp_i2
+
+
+  SUBROUTINE bcast_omp_i3(var)
+  IMPLICIT NONE
+    INTEGER,INTENT(INOUT) :: Var(:,:,:)
+
+    CALL check_buffer_i(size(Var))
+    CALL bcast_omp_igen(Var,size(Var),buffer_i)
+
+  END SUBROUTINE bcast_omp_i3
+
+
+  SUBROUTINE bcast_omp_i4(var)
+  IMPLICIT NONE
+    INTEGER,INTENT(INOUT) :: Var(:,:,:,:)
+   
+    CALL check_buffer_i(size(Var))
+    CALL bcast_omp_igen(Var,size(Var),buffer_i)
+
+  END SUBROUTINE bcast_omp_i4
+
+
+!! -- Les reels -- !!
+
+  SUBROUTINE bcast_omp_r(var)
+  IMPLICIT NONE
+    REAL,INTENT(INOUT) :: Var
+    REAL :: Var_tmp(1)
+    
+    Var_tmp(1)=Var
+    CALL check_buffer_r(1)
+    CALL bcast_omp_rgen(Var_tmp,1,buffer_r)
+    Var=Var_tmp(1)
+
+  END SUBROUTINE bcast_omp_r
+
+
+  SUBROUTINE bcast_omp_r1(var)
+  IMPLICIT NONE
+    REAL,INTENT(INOUT) :: Var(:)
+   
+    CALL check_buffer_r(size(Var))
+    CALL bcast_omp_rgen(Var,size(Var),buffer_r)
+
+  END SUBROUTINE bcast_omp_r1
+
+
+  SUBROUTINE bcast_omp_r2(var)
+  IMPLICIT NONE
+    REAL,INTENT(INOUT) :: Var(:,:)
+   
+    CALL check_buffer_r(size(Var))
+    CALL bcast_omp_rgen(Var,size(Var),buffer_r)
+
+  END SUBROUTINE bcast_omp_r2
+
+
+  SUBROUTINE bcast_omp_r3(var)
+  IMPLICIT NONE
+    REAL,INTENT(INOUT) :: Var(:,:,:)
+
+    CALL check_buffer_r(size(Var))
+    CALL bcast_omp_rgen(Var,size(Var),buffer_r)
+
+  END SUBROUTINE bcast_omp_r3
+
+
+  SUBROUTINE bcast_omp_r4(var)
+  IMPLICIT NONE
+    REAL,INTENT(INOUT) :: Var(:,:,:,:)
+   
+    CALL check_buffer_r(size(Var))
+    CALL bcast_omp_rgen(Var,size(Var),buffer_r)
+
+  END SUBROUTINE bcast_omp_r4
+
+  
+!! -- Les booleans -- !!
+
+  SUBROUTINE bcast_omp_l(var)
+  IMPLICIT NONE
+    LOGICAL,INTENT(INOUT) :: Var
+    LOGICAL :: Var_tmp(1)
+    
+    Var_tmp(1)=Var
+    CALL check_buffer_l(1)
+    CALL bcast_omp_lgen(Var_tmp,1,buffer_l)
+    Var=Var_tmp(1)
+
+  END SUBROUTINE bcast_omp_l
+
+
+  SUBROUTINE bcast_omp_l1(var)
+  IMPLICIT NONE
+    LOGICAL,INTENT(INOUT) :: Var(:)
+   
+    CALL check_buffer_l(size(Var))
+    CALL bcast_omp_lgen(Var,size(Var),buffer_l)
+
+  END SUBROUTINE bcast_omp_l1
+
+
+  SUBROUTINE bcast_omp_l2(var)
+  IMPLICIT NONE
+    LOGICAL,INTENT(INOUT) :: Var(:,:)
+   
+    CALL check_buffer_l(size(Var))
+    CALL bcast_omp_lgen(Var,size(Var),buffer_l)
+
+  END SUBROUTINE bcast_omp_l2
+
+
+  SUBROUTINE bcast_omp_l3(var)
+  IMPLICIT NONE
+    LOGICAL,INTENT(INOUT) :: Var(:,:,:)
+
+    CALL check_buffer_l(size(Var))
+    CALL bcast_omp_lgen(Var,size(Var),buffer_l)
+
+  END SUBROUTINE bcast_omp_l3
+
+
+  SUBROUTINE bcast_omp_l4(var)
+  IMPLICIT NONE
+    LOGICAL,INTENT(INOUT) :: Var(:,:,:,:)
+   
+    CALL check_buffer_l(size(Var))
+    CALL bcast_omp_lgen(Var,size(Var),buffer_l)
+
+  END SUBROUTINE bcast_omp_l4
+
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! Definition des Scatter   --> 4D   !!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+  SUBROUTINE scatter_omp_i(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut
+
+    CALL Check_buffer_i(size(VarIn))   
+    CALL scatter_omp_igen(VarIn,Varout,1,buffer_i)
+    
+  END SUBROUTINE scatter_omp_i
+
+
+  SUBROUTINE scatter_omp_i1(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
+
+    CALL Check_buffer_i(size(VarIn))   
+    CALL scatter_omp_igen(VarIn,Varout,Size(VarOut,2),buffer_i)
+    
+  END SUBROUTINE scatter_omp_i1
+  
+  
+  SUBROUTINE scatter_omp_i2(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    CALL Check_buffer_i(size(VarIn))   
+    CALL scatter_omp_igen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3),buffer_i)
+
+  END SUBROUTINE scatter_omp_i2
+
+
+  SUBROUTINE scatter_omp_i3(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+    CALL Check_buffer_i(size(VarIn))   
+    CALL scatter_omp_igen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3)*Size(VarOut,4),buffer_i)
+  
+  END SUBROUTINE scatter_omp_i3
+
+
+
+
+  SUBROUTINE scatter_omp_r(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:) :: VarOut
+
+    CALL Check_buffer_r(size(VarIn))   
+    CALL scatter_omp_rgen(VarIn,Varout,1,buffer_r)
+    
+  END SUBROUTINE scatter_omp_r
+
+
+  SUBROUTINE scatter_omp_r1(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+    CALL Check_buffer_r(size(VarIn))   
+    CALL scatter_omp_rgen(VarIn,Varout,Size(VarOut,2),buffer_r)
+        
+  END SUBROUTINE scatter_omp_r1
+  
+  
+  SUBROUTINE scatter_omp_r2(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    CALL Check_buffer_r(size(VarIn))   
+    CALL scatter_omp_rgen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3),buffer_r)
+
+  END SUBROUTINE scatter_omp_r2
+
+
+  SUBROUTINE scatter_omp_r3(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+    CALL Check_buffer_r(size(VarIn))   
+    CALL scatter_omp_rgen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3)*Size(VarOut,4),buffer_r)
+  
+  END SUBROUTINE scatter_omp_r3
+  
+
+
+  SUBROUTINE scatter_omp_l(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:) :: VarOut
+
+    CALL Check_buffer_l(size(VarIn))   
+    CALL scatter_omp_lgen(VarIn,Varout,1,buffer_l)
+    
+  END SUBROUTINE scatter_omp_l
+
+
+  SUBROUTINE scatter_omp_l1(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+    CALL Check_buffer_l(size(VarIn))   
+    CALL scatter_omp_lgen(VarIn,Varout,Size(VarOut,2),buffer_l)
+    
+  END SUBROUTINE scatter_omp_l1
+  
+  
+  SUBROUTINE scatter_omp_l2(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    CALL Check_buffer_l(size(VarIn))   
+    CALL scatter_omp_lgen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3),buffer_l)
+
+  END SUBROUTINE scatter_omp_l2
+
+
+  SUBROUTINE scatter_omp_l3(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+    CALL Check_buffer_l(size(VarIn))   
+    CALL scatter_omp_lgen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3)*Size(VarOut,4),buffer_l)
+  
+  END SUBROUTINE scatter_omp_l3  
+  
+
+  SUBROUTINE gather_omp_i(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut
+
+    CALL Check_buffer_i(size(VarOut))   
+    CALL gather_omp_igen(VarIn,Varout,1,buffer_i)
+    
+  END SUBROUTINE gather_omp_i
+
+
+  SUBROUTINE gather_omp_i1(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+    CALL Check_buffer_i(size(VarOut))   
+    CALL gather_omp_igen(VarIn,Varout,Size(VarIn,2),buffer_i)
+    
+  END SUBROUTINE gather_omp_i1
+
+
+  SUBROUTINE gather_omp_i2(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    CALL Check_buffer_i(size(VarOut))   
+    CALL gather_omp_igen(VarIn,Varout,Size(VarIn,2)*Size(VarIn,3),buffer_i)
+          
+  END SUBROUTINE gather_omp_i2
+  
+
+  SUBROUTINE gather_omp_i3(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+    CALL Check_buffer_i(size(VarOut))   
+    CALL gather_omp_igen(VarIn,Varout,Size(VarIn,2)*Size(VarIn,3)*Size(VarIn,4),buffer_i)
+    
+  END SUBROUTINE gather_omp_i3
+
+
+
+  SUBROUTINE gather_omp_r(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:) :: VarOut
+
+    CALL gather_omp_rgen(VarIn,Varout,1)
+    
+  END SUBROUTINE gather_omp_r
+
+
+  SUBROUTINE gather_omp_r1(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+ 
+    CALL gather_omp_rgen(VarIn,Varout,Size(VarIn,2))
+        
+  END SUBROUTINE gather_omp_r1
+
+
+  SUBROUTINE gather_omp_r2(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+ 
+    CALL gather_omp_rgen(VarIn,Varout,Size(VarIn,2)*Size(VarIn,3))
+    
+  END SUBROUTINE gather_omp_r2
+  
+
+  SUBROUTINE gather_omp_r3(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+     
+    CALL gather_omp_rgen(VarIn,Varout,Size(VarIn,2)*Size(VarIn,3)*Size(VarIn,4))
+    
+  END SUBROUTINE gather_omp_r3
+
+
+  SUBROUTINE gather_omp_l(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:) :: VarOut
+
+    CALL Check_buffer_l(size(VarOut))   
+    CALL gather_omp_lgen(VarIn,Varout,1,buffer_l)
+    
+  END SUBROUTINE gather_omp_l
+
+
+  SUBROUTINE gather_omp_l1(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+    CALL Check_buffer_l(size(VarOut))   
+    CALL gather_omp_lgen(VarIn,Varout,Size(VarIn,2),buffer_l)
+    
+  END SUBROUTINE gather_omp_l1
+
+
+  SUBROUTINE gather_omp_l2(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    CALL Check_buffer_l(size(VarOut))   
+    CALL gather_omp_lgen(VarIn,Varout,Size(VarIn,2)*Size(VarIn,3),buffer_l)
+    
+  END SUBROUTINE gather_omp_l2
+  
+
+  SUBROUTINE gather_omp_l3(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+    CALL Check_buffer_l(size(VarOut))   
+    CALL gather_omp_lgen(VarIn,Varout,Size(VarIn,2)*Size(VarIn,3)*Size(VarIn,4),buffer_l)
+    
+  END SUBROUTINE gather_omp_l3
+
+
+
+
+  SUBROUTINE reduce_sum_omp_i(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN)  :: VarIn
+    INTEGER,INTENT(OUT) :: VarOut
+    INTEGER             :: VarIn_tmp(1)
+    INTEGER             :: VarOut_tmp(1)
+    
+    VarIn_tmp(1)=VarIn
+    CALL Check_buffer_i(1)   
+    CALL reduce_sum_omp_igen(VarIn_tmp,Varout_tmp,1,buffer_i)
+    VarOut=VarOut_tmp(1)
+    
+  END SUBROUTINE reduce_sum_omp_i
+
+  SUBROUTINE reduce_sum_omp_i1(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:)  :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut
+    
+    CALL Check_buffer_i(size(VarIn))   
+    CALL reduce_sum_omp_igen(VarIn,Varout,Size(VarIn),buffer_i)
+   
+  END SUBROUTINE reduce_sum_omp_i1
+  
+  
+  SUBROUTINE reduce_sum_omp_i2(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:)  :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
+
+    CALL Check_buffer_i(size(VarIn))   
+    CALL reduce_sum_omp_igen(VarIn,Varout,Size(VarIn),buffer_i)
+  
+  END SUBROUTINE reduce_sum_omp_i2
+
+
+  SUBROUTINE reduce_sum_omp_i3(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:)  :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    CALL Check_buffer_i(size(VarIn))   
+    CALL reduce_sum_omp_igen(VarIn,Varout,Size(VarIn),buffer_i)
+  
+  END SUBROUTINE reduce_sum_omp_i3
+
+
+  SUBROUTINE reduce_sum_omp_i4(VarIn, VarOut)
+    IMPLICIT NONE
+
+    INTEGER,INTENT(IN),DIMENSION(:,:,:,:)  :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+  
+    CALL Check_buffer_i(size(VarIn))   
+    CALL reduce_sum_omp_igen(VarIn,Varout,Size(VarIn),buffer_i)
+  
+  END SUBROUTINE reduce_sum_omp_i4
+
+
+  SUBROUTINE reduce_sum_omp_r(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN)  :: VarIn
+    REAL,INTENT(OUT) :: VarOut
+    REAL             :: VarIn_tmp(1)
+    REAL             :: VarOut_tmp(1)
+    
+    VarIn_tmp(1)=VarIn
+    CALL Check_buffer_r(1)   
+    CALL reduce_sum_omp_rgen(VarIn_tmp,Varout_tmp,1,buffer_r)
+    VarOut=VarOut_tmp(1)
+  
+  END SUBROUTINE reduce_sum_omp_r
+
+  SUBROUTINE reduce_sum_omp_r1(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:)  :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:) :: VarOut
+    
+    CALL Check_buffer_r(size(VarIn))   
+    CALL reduce_sum_omp_rgen(VarIn,Varout,Size(VarIn),buffer_r)
+   
+  END SUBROUTINE reduce_sum_omp_r1
+  
+  
+  SUBROUTINE reduce_sum_omp_r2(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:)  :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+    CALL Check_buffer_r(size(VarIn))   
+    CALL reduce_sum_omp_rgen(VarIn,Varout,Size(VarIn),buffer_r)
+  
+  END SUBROUTINE reduce_sum_omp_r2
+
+
+  SUBROUTINE reduce_sum_omp_r3(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:)  :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    CALL Check_buffer_r(size(VarIn))   
+    CALL reduce_sum_omp_rgen(VarIn,Varout,Size(VarIn),buffer_r)
+  
+  END SUBROUTINE reduce_sum_omp_r3
+
+
+  SUBROUTINE reduce_sum_omp_r4(VarIn, VarOut)
+    IMPLICIT NONE
+
+    REAL,INTENT(IN),DIMENSION(:,:,:,:)  :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+  
+    CALL Check_buffer_r(size(VarIn))   
+    CALL reduce_sum_omp_rgen(VarIn,Varout,Size(VarIn),buffer_r)
+  
+  END SUBROUTINE reduce_sum_omp_r4
+
+
+
+  SUBROUTINE reduce_min_omp_i(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN)  :: VarIn
+    INTEGER,INTENT(OUT) :: VarOut
+    INTEGER             :: VarIn_tmp(1)
+    INTEGER             :: VarOut_tmp(1)
+    
+    VarIn_tmp(1)=VarIn
+    CALL Check_buffer_i(1)   
+    CALL reduce_min_omp_igen(VarIn_tmp,Varout_tmp,1,buffer_i)
+    VarOut=VarOut_tmp(1)
+    
+  END SUBROUTINE reduce_min_omp_i
+
+  SUBROUTINE reduce_min_omp_i1(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:)  :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut
+    
+    CALL Check_buffer_i(size(VarIn))   
+    CALL reduce_min_omp_igen(VarIn,Varout,Size(VarIn),buffer_i)
+   
+  END SUBROUTINE reduce_min_omp_i1
+  
+  
+  SUBROUTINE reduce_min_omp_i2(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:)  :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
+
+    CALL Check_buffer_i(size(VarIn))   
+    CALL reduce_min_omp_igen(VarIn,Varout,Size(VarIn),buffer_i)
+  
+  END SUBROUTINE reduce_min_omp_i2
+
+
+  SUBROUTINE reduce_min_omp_i3(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:)  :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    CALL Check_buffer_i(size(VarIn))   
+    CALL reduce_min_omp_igen(VarIn,Varout,Size(VarIn),buffer_i)
+  
+  END SUBROUTINE reduce_min_omp_i3
+
+
+  SUBROUTINE reduce_min_omp_i4(VarIn, VarOut)
+    IMPLICIT NONE
+
+    INTEGER,INTENT(IN),DIMENSION(:,:,:,:)  :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+  
+    CALL Check_buffer_i(size(VarIn))   
+    CALL reduce_min_omp_igen(VarIn,Varout,Size(VarIn),buffer_i)
+  
+  END SUBROUTINE reduce_min_omp_i4
+
+
+  SUBROUTINE reduce_min_omp_r(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN)  :: VarIn
+    REAL,INTENT(OUT) :: VarOut
+    REAL             :: VarIn_tmp(1)
+    REAL             :: VarOut_tmp(1)
+    
+    VarIn_tmp(1)=VarIn
+    CALL Check_buffer_r(1)   
+    CALL reduce_min_omp_rgen(VarIn_tmp,Varout_tmp,1,buffer_r)
+    VarOut=VarOut_tmp(1)
+  
+  END SUBROUTINE reduce_min_omp_r
+
+  SUBROUTINE reduce_min_omp_r1(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:)  :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:) :: VarOut
+    
+    CALL Check_buffer_r(size(VarIn))   
+    CALL reduce_min_omp_rgen(VarIn,Varout,Size(VarIn),buffer_r)
+   
+  END SUBROUTINE reduce_min_omp_r1
+  
+  
+  SUBROUTINE reduce_min_omp_r2(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:)  :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+    CALL Check_buffer_r(size(VarIn))   
+    CALL reduce_min_omp_rgen(VarIn,Varout,Size(VarIn),buffer_r)
+  
+  END SUBROUTINE reduce_min_omp_r2
+
+
+  SUBROUTINE reduce_min_omp_r3(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:)  :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    CALL Check_buffer_r(size(VarIn))   
+    CALL reduce_min_omp_rgen(VarIn,Varout,Size(VarIn),buffer_r)
+  
+  END SUBROUTINE reduce_min_omp_r3
+
+
+  SUBROUTINE reduce_min_omp_r4(VarIn, VarOut)
+    IMPLICIT NONE
+
+    REAL,INTENT(IN),DIMENSION(:,:,:,:)  :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+  
+    CALL Check_buffer_r(size(VarIn))   
+    CALL reduce_min_omp_rgen(VarIn,Varout,Size(VarIn),buffer_r)
+  
+  END SUBROUTINE reduce_min_omp_r4
+
+
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!    LES ROUTINES GENERIQUES    !
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+  SUBROUTINE bcast_omp_cgen(Var,Nb,Buff)
+  IMPLICIT NONE
+    
+    CHARACTER(LEN=*),INTENT(INOUT) :: Var
+    CHARACTER(LEN=*),INTENT(INOUT) :: Buff
+    INTEGER,INTENT(IN) :: Nb
+    
+    INTEGER :: i
+  
+  !$OMP MASTER
+      Buff=Var
+  !$OMP END MASTER
+  !$OMP BARRIER
+
+    DO i=1,Nb
+      Var=Buff
+    ENDDO
+  !$OMP BARRIER      
+  
+  END SUBROUTINE bcast_omp_cgen
+
+
+      
+  SUBROUTINE bcast_omp_igen(Var,Nb,Buff)
+  IMPLICIT NONE
+    
+    INTEGER,INTENT(IN) :: Nb
+    INTEGER,DIMENSION(Nb),INTENT(INOUT) :: Var
+    INTEGER,DIMENSION(Nb),INTENT(INOUT) :: Buff
+
+    INTEGER :: i
+    
+  !$OMP MASTER
+    DO i=1,Nb
+      Buff(i)=Var(i)
+    ENDDO
+  !$OMP END MASTER
+  !$OMP BARRIER
+
+    DO i=1,Nb
+      Var(i)=Buff(i)
+    ENDDO
+  !$OMP BARRIER        
+
+  END SUBROUTINE bcast_omp_igen
+
+
+  SUBROUTINE bcast_omp_rgen(Var,Nb,Buff)
+  IMPLICIT NONE
+    
+    INTEGER,INTENT(IN) :: Nb
+    REAL,DIMENSION(Nb),INTENT(INOUT) :: Var
+    REAL,DIMENSION(Nb),INTENT(INOUT) :: Buff
+
+    INTEGER :: i
+    
+  !$OMP MASTER
+    DO i=1,Nb
+      Buff(i)=Var(i)
+    ENDDO
+  !$OMP END MASTER
+  !$OMP BARRIER
+
+    DO i=1,Nb
+      Var(i)=Buff(i)
+    ENDDO
+  !$OMP BARRIER        
+
+  END SUBROUTINE bcast_omp_rgen
+
+  SUBROUTINE bcast_omp_lgen(Var,Nb,Buff)
+  IMPLICIT NONE
+    
+    INTEGER,INTENT(IN) :: Nb
+    LOGICAL,DIMENSION(Nb),INTENT(INOUT) :: Var
+    LOGICAL,DIMENSION(Nb),INTENT(INOUT) :: Buff
+  
+    INTEGER :: i
+    
+  !$OMP MASTER
+    DO i=1,Nb
+      Buff(i)=Var(i)
+    ENDDO
+  !$OMP END MASTER
+  !$OMP BARRIER
+
+    DO i=1,Nb
+      Var(i)=Buff(i)
+    ENDDO
+  !$OMP BARRIER        
+
+  END SUBROUTINE bcast_omp_lgen
+
+
+  SUBROUTINE scatter_omp_igen(VarIn,VarOut,dimsize,Buff)
+    USE mod_phys_lmdz_omp_data
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi 
+    IMPLICIT NONE
+
+    INTEGER,INTENT(IN) :: dimsize
+    INTEGER,INTENT(IN),DIMENSION(klon_mpi,dimsize) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(klon_omp,dimsize) :: VarOut
+    INTEGER,INTENT(INOUT),DIMENSION(klon_mpi,dimsize) :: Buff
+
+    INTEGER :: i,ij
+    
+  !$OMP MASTER
+    DO i=1,dimsize
+      DO ij=1,klon_mpi
+        Buff(ij,i)=VarIn(ij,i)
+      ENDDO
+    ENDDO  
+  !$OMP END MASTER
+  !$OMP BARRIER
+ 
+    DO i=1,dimsize
+      DO ij=1,klon_omp
+        VarOut(ij,i)=Buff(klon_omp_begin-1+ij,i)
+      ENDDO
+    ENDDO
+  !$OMP BARRIER  
+ 
+  END SUBROUTINE scatter_omp_igen
+
+
+  SUBROUTINE scatter_omp_rgen(VarIn,VarOut,dimsize,Buff)
+  USE mod_phys_lmdz_omp_data
+  USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi 
+  IMPLICIT NONE
+
+    INTEGER,INTENT(IN) :: dimsize
+    REAL,INTENT(IN),DIMENSION(klon_mpi,dimsize) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(klon_omp,dimsize) :: VarOut
+    REAL,INTENT(INOUT),DIMENSION(klon_mpi,dimsize) :: Buff
+
+    INTEGER :: i,ij
+    
+  !$OMP MASTER
+    DO i=1,dimsize
+      DO ij=1,klon_mpi
+        Buff(ij,i)=VarIn(ij,i)
+      ENDDO
+    ENDDO  
+  !$OMP END MASTER
+  !$OMP BARRIER
+
+    DO i=1,dimsize
+      DO ij=1,klon_omp
+        VarOut(ij,i)=Buff(klon_omp_begin-1+ij,i)
+      ENDDO
+    ENDDO
+  !$OMP BARRIER  
+
+  END SUBROUTINE scatter_omp_rgen
+
+
+  SUBROUTINE scatter_omp_lgen(VarIn,VarOut,dimsize,Buff)
+  USE mod_phys_lmdz_omp_data
+  USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi 
+  IMPLICIT NONE
+
+    INTEGER,INTENT(IN) :: dimsize
+    LOGICAL,INTENT(IN),DIMENSION(klon_mpi,dimsize) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(klon_omp,dimsize) :: VarOut
+    LOGICAL,INTENT(INOUT),DIMENSION(klon_mpi,dimsize) :: Buff
+
+    INTEGER :: i,ij
+    
+ !$OMP MASTER 
+    DO i=1,dimsize
+      DO ij=1,klon_mpi
+        Buff(ij,i)=VarIn(ij,i)
+      ENDDO
+    ENDDO  
+  !$OMP END MASTER
+  !$OMP BARRIER
+
+    DO i=1,dimsize
+      DO ij=1,klon_omp
+        VarOut(ij,i)=Buff(klon_omp_begin-1+ij,i)
+      ENDDO
+    ENDDO
+  !$OMP BARRIER  
+
+  END SUBROUTINE scatter_omp_lgen
+
+
+
+
+
+  SUBROUTINE gather_omp_igen(VarIn,VarOut,dimsize,Buff)
+  USE mod_phys_lmdz_omp_data
+  USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi 
+  IMPLICIT NONE
+
+    INTEGER,INTENT(IN) :: dimsize
+    INTEGER,INTENT(IN),DIMENSION(klon_omp,dimsize) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(klon_mpi,dimsize) :: VarOut
+    INTEGER,INTENT(INOUT),DIMENSION(klon_mpi,dimsize) :: Buff
+
+    INTEGER :: i,ij
+    
+    DO i=1,dimsize
+      DO ij=1,klon_omp
+        Buff(klon_omp_begin-1+ij,i)=VarIn(ij,i)
+      ENDDO
+    ENDDO
+  !$OMP BARRIER  
+  
+  
+  !$OMP MASTER
+    DO i=1,dimsize
+      DO ij=1,klon_mpi
+        VarOut(ij,i)=Buff(ij,i)
+      ENDDO
+    ENDDO  
+  !$OMP END MASTER
+  !$OMP BARRIER
+
+  END SUBROUTINE gather_omp_igen
+
+
+  SUBROUTINE gather_omp_rgen(VarIn,VarOut,dimsize)
+  USE mod_phys_lmdz_omp_data
+  USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi 
+  IMPLICIT NONE
+
+    INTEGER,INTENT(IN) :: dimsize
+    REAL,INTENT(IN),DIMENSION(klon_omp,dimsize) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(klon_mpi,dimsize),TARGET :: VarOut
+
+    REAL, POINTER, SAVE :: Varout_ptr(:,:) ! Shared between threads NOT THREADPRIVATE
+
+    INTEGER :: i,ij
+    
+    !$omp master
+    Varout_ptr => VarOut
+    !$omp end master
+    !$omp barrier
+
+    DO i=1,dimsize
+      DO ij=1,klon_omp
+        Varout_ptr(klon_omp_begin-1+ij,i)=VarIn(ij,i)
+      ENDDO
+    ENDDO
+    !$omp barrier
+  END SUBROUTINE gather_omp_rgen
+
+
+  SUBROUTINE gather_omp_lgen(VarIn,VarOut,dimsize,Buff)
+  USE mod_phys_lmdz_omp_data
+  USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi 
+  IMPLICIT NONE
+
+    INTEGER,INTENT(IN) :: dimsize
+    LOGICAL,INTENT(IN),DIMENSION(klon_omp,dimsize) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(klon_mpi,dimsize) :: VarOut
+    LOGICAL,INTENT(INOUT),DIMENSION(klon_mpi,dimsize) :: Buff
+
+    INTEGER :: i,ij
+    
+    DO i=1,dimsize
+      DO ij=1,klon_omp
+        Buff(klon_omp_begin-1+ij,i)=VarIn(ij,i)
+      ENDDO
+    ENDDO
+  !$OMP BARRIER  
+
+
+  !$OMP MASTER
+    DO i=1,dimsize
+      DO ij=1,klon_mpi
+        VarOut(ij,i)=Buff(ij,i)
+      ENDDO
+    ENDDO  
+  !$OMP END MASTER
+  !$OMP BARRIER
+
+  END SUBROUTINE gather_omp_lgen
+
+
+  SUBROUTINE reduce_sum_omp_igen(VarIn,VarOut,dimsize,Buff)
+  IMPLICIT NONE
+
+    INTEGER,INTENT(IN) :: dimsize
+    INTEGER,INTENT(IN),DIMENSION(dimsize) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(dimsize) :: VarOut
+    INTEGER,INTENT(INOUT),DIMENSION(dimsize) :: Buff
+
+    INTEGER :: i
+
+  !$OMP MASTER
+    Buff(:)=0
+  !$OMP END MASTER
+  !$OMP BARRIER
+  
+  !$OMP CRITICAL     
+    DO i=1,dimsize
+      Buff(i)=Buff(i)+VarIn(i)
+    ENDDO
+  !$OMP END CRITICAL
+  !$OMP BARRIER  
+  
+  !$OMP MASTER
+    DO i=1,dimsize
+      VarOut(i)=Buff(i)
+    ENDDO
+  !$OMP END MASTER
+  !$OMP BARRIER
+  
+  END SUBROUTINE reduce_sum_omp_igen
+
+  SUBROUTINE reduce_sum_omp_rgen(VarIn,VarOut,dimsize,Buff)
+  IMPLICIT NONE
+
+    INTEGER,INTENT(IN) :: dimsize
+    REAL,INTENT(IN),DIMENSION(dimsize) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(dimsize) :: VarOut
+    REAL,INTENT(INOUT),DIMENSION(dimsize) :: Buff
+
+    INTEGER :: i
+
+  !$OMP MASTER
+    Buff(:)=0
+  !$OMP END MASTER
+  !$OMP BARRIER
+  
+  !$OMP CRITICAL     
+    DO i=1,dimsize
+      Buff(i)=Buff(i)+VarIn(i)
+    ENDDO
+  !$OMP END CRITICAL
+  !$OMP BARRIER  
+  
+  !$OMP MASTER
+    DO i=1,dimsize
+      VarOut(i)=Buff(i)
+    ENDDO
+  !$OMP END MASTER
+  !$OMP BARRIER
+  
+  END SUBROUTINE reduce_sum_omp_rgen
+
+
+  SUBROUTINE reduce_min_omp_igen(VarIn,VarOut,dimsize,Buff)
+  IMPLICIT NONE
+
+    INTEGER,INTENT(IN) :: dimsize
+    INTEGER,INTENT(IN),DIMENSION(dimsize) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(dimsize) :: VarOut
+    INTEGER,INTENT(INOUT),DIMENSION(dimsize) :: Buff
+
+    INTEGER :: i
+    INTEGER :: var
+
+  !$OMP MASTER
+    Buff(:)=HUGE(var)
+  !$OMP END MASTER
+  !$OMP BARRIER
+  
+  !$OMP CRITICAL     
+    DO i=1,dimsize
+      Buff(i)=MIN(Buff(i),VarIn(i))
+    ENDDO
+  !$OMP END CRITICAL
+  !$OMP BARRIER  
+  
+  !$OMP MASTER
+    DO i=1,dimsize
+      VarOut(i)=Buff(i)
+    ENDDO
+  !$OMP END MASTER
+  !$OMP BARRIER
+  
+  END SUBROUTINE reduce_min_omp_igen
+
+  SUBROUTINE reduce_min_omp_rgen(VarIn,VarOut,dimsize,Buff)
+  IMPLICIT NONE
+
+    INTEGER,INTENT(IN) :: dimsize
+    REAL,INTENT(IN),DIMENSION(dimsize) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(dimsize) :: VarOut
+    REAL,INTENT(INOUT),DIMENSION(dimsize) :: Buff
+
+    INTEGER :: i
+    REAL :: var
+
+  !$OMP MASTER
+    Buff(:)=HUGE(var)
+  !$OMP END MASTER
+  !$OMP BARRIER
+  
+  !$OMP CRITICAL     
+    DO i=1,dimsize
+      Buff(i)=MIN(Buff(i),VarIn(i))
+    ENDDO
+  !$OMP END CRITICAL
+  !$OMP BARRIER  
+  
+  !$OMP MASTER
+    DO i=1,dimsize
+      VarOut(i)=Buff(i)
+    ENDDO
+  !$OMP END MASTER
+  !$OMP BARRIER
+  
+  END SUBROUTINE reduce_min_omp_rgen
+
+
+END MODULE mod_phys_lmdz_omp_transfert
Index: DZ6/trunk/libf/phy_common/mod_phys_lmdz_para.F90
===================================================================
--- /LMDZ6/trunk/libf/phy_common/mod_phys_lmdz_para.F90	(revision 5267)
+++ 	(revision )
@@ -1,120 +1,0 @@
-!
-! $Id$
-!
-MODULE mod_phys_lmdz_para
-  USE mod_phys_lmdz_transfert_para
-  USE mod_phys_lmdz_mpi_data
-  USE mod_phys_lmdz_omp_data
-    
-  INTEGER,SAVE :: klon_loc
-  LOGICAL,SAVE :: is_sequential
-  LOGICAL,SAVE :: is_parallel
-  LOGICAL,SAVE :: is_master
-
-  
-!$OMP THREADPRIVATE(klon_loc,is_master)
-  
-CONTAINS
-
-  SUBROUTINE Init_phys_lmdz_para(nbp,nbp_lon,nbp_lat,nbp_lev,grid_type, nvertex,communicator)
-  IMPLICIT NONE
-    INTEGER,INTENT(in) :: nbp
-    INTEGER,INTENT(in) :: nbp_lon
-    INTEGER,INTENT(in) :: nbp_lat
-    INTEGER,INTENT(in) :: nbp_lev
-    INTEGER,INTENT(in) :: communicator
-    INTEGER,INTENT(IN) :: grid_type 
-    INTEGER,INTENT(IN) :: nvertex 
-
-    CALL Init_phys_lmdz_mpi_data(nbp,nbp_lon,nbp_lat,nbp_lev, grid_type, nvertex,communicator)
-!$OMP PARALLEL
-    CALL Init_phys_lmdz_omp_data(klon_mpi)
-    klon_loc=klon_omp
-    IF (is_mpi_root .AND. is_omp_root) THEN 
-       is_master=.TRUE.
-     ELSE
-       is_master=.FALSE.
-     ENDIF
-!ym     CALL Test_transfert
-!$OMP END PARALLEL    
-     IF (is_using_mpi .OR. is_using_omp) THEN
-       is_sequential=.FALSE.
-       is_parallel=.TRUE.
-     ELSE
-       is_sequential=.TRUE.
-       is_parallel=.FALSE.
-     ENDIF
-
-
-      
-  END SUBROUTINE Init_phys_lmdz_para
-
-  SUBROUTINE Test_transfert
-  USE mod_grid_phy_lmdz
-  USE print_control_mod, ONLY: lunout
-  IMPLICIT NONE
-!    INCLUDE "iniprint.h"
- 
-    REAL :: Test_Field1d_glo(klon_glo,nbp_lev)
-    REAL :: tmp1d_glo(klon_glo,nbp_lev)
-    REAL :: Test_Field2d_glo(nbp_lon,nbp_lat,nbp_lev)
-    REAL :: tmp2d_glo(nbp_lon,nbp_lat,nbp_lev)
-    REAL :: Test_Field1d_loc(klon_loc,nbp_lev)
-    REAL :: Test_Field2d_loc(nbp_lon,jj_nb,nbp_lev)
-    REAL :: CheckSum
-    
-    INTEGER :: i,l
-  
-    Test_Field1d_glo = 0.
-    Test_Field2d_glo = 0.
-    Test_Field1d_loc = 0.
-    Test_Field2d_loc = 0.
-  
-    IF (is_mpi_root) THEN
-!$OMP MASTER
-      DO l=1,nbp_lev
-        DO i=1,klon_glo
-!          Test_Field1d_glo(i,l)=MOD(i,10)+10*(l-1)
-           Test_Field1d_glo(i,l)=1
-        ENDDO
-      ENDDO
-!$OMP END MASTER  
-    ENDIF
-  
-    CALL Scatter(Test_Field1d_glo,Test_Field1d_loc)
-    CALL Gather(Test_Field1d_loc,tmp1d_glo)
-  
-    IF (is_mpi_root) THEN
-!$OMP MASTER  
-      Checksum=sum(Test_Field1d_glo-tmp1d_glo)
-      WRITE(lunout,*) "------> Checksum =",Checksum," MUST BE 0"
-!$OMP END MASTER
-    ENDIF
-    
-    CALL grid1dTo2d_glo(Test_Field1d_glo,Test_Field2d_glo)
-    CALL scatter2D(Test_Field2d_glo,Test_Field1d_loc)
-    CALL gather2d(Test_Field1d_loc,Test_Field2d_glo)
-    CALL grid2dTo1d_glo(Test_Field2d_glo,tmp1d_glo)
-
-    IF (is_mpi_root) THEN
-!$OMP MASTER  
-      Checksum=sum(Test_Field1d_glo-tmp1d_glo)
-      WRITE(lunout,*) "------> Checksum =",Checksum," MUST BE 0"
-!$OMP END MASTER
-    ENDIF
-
-    CALL bcast(Test_Field1d_glo)
-    CALL reduce_sum(Test_Field1d_glo,tmp1d_glo)
-
-    IF (is_mpi_root) THEN
-!$OMP MASTER  
-      Checksum=sum(Test_Field1d_glo*omp_size*mpi_size-tmp1d_glo)
-      WRITE(lunout,*) "------> Checksum =",Checksum," MUST BE 0"
-!$OMP END MASTER
-    ENDIF
-    
-     
-   END SUBROUTINE Test_transfert
-  
-END MODULE mod_phys_lmdz_para
-    
Index: /LMDZ6/trunk/libf/phy_common/mod_phys_lmdz_para.f90
===================================================================
--- /LMDZ6/trunk/libf/phy_common/mod_phys_lmdz_para.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phy_common/mod_phys_lmdz_para.f90	(revision 5268)
@@ -0,0 +1,120 @@
+!
+! $Id$
+!
+MODULE mod_phys_lmdz_para
+  USE mod_phys_lmdz_transfert_para
+  USE mod_phys_lmdz_mpi_data
+  USE mod_phys_lmdz_omp_data
+    
+  INTEGER,SAVE :: klon_loc
+  LOGICAL,SAVE :: is_sequential
+  LOGICAL,SAVE :: is_parallel
+  LOGICAL,SAVE :: is_master
+
+  
+!$OMP THREADPRIVATE(klon_loc,is_master)
+  
+CONTAINS
+
+  SUBROUTINE Init_phys_lmdz_para(nbp,nbp_lon,nbp_lat,nbp_lev,grid_type, nvertex,communicator)
+  IMPLICIT NONE
+    INTEGER,INTENT(in) :: nbp
+    INTEGER,INTENT(in) :: nbp_lon
+    INTEGER,INTENT(in) :: nbp_lat
+    INTEGER,INTENT(in) :: nbp_lev
+    INTEGER,INTENT(in) :: communicator
+    INTEGER,INTENT(IN) :: grid_type 
+    INTEGER,INTENT(IN) :: nvertex 
+
+    CALL Init_phys_lmdz_mpi_data(nbp,nbp_lon,nbp_lat,nbp_lev, grid_type, nvertex,communicator)
+!$OMP PARALLEL
+    CALL Init_phys_lmdz_omp_data(klon_mpi)
+    klon_loc=klon_omp
+    IF (is_mpi_root .AND. is_omp_root) THEN 
+       is_master=.TRUE.
+     ELSE
+       is_master=.FALSE.
+     ENDIF
+!ym     CALL Test_transfert
+!$OMP END PARALLEL    
+     IF (is_using_mpi .OR. is_using_omp) THEN
+       is_sequential=.FALSE.
+       is_parallel=.TRUE.
+     ELSE
+       is_sequential=.TRUE.
+       is_parallel=.FALSE.
+     ENDIF
+
+
+      
+  END SUBROUTINE Init_phys_lmdz_para
+
+  SUBROUTINE Test_transfert
+  USE mod_grid_phy_lmdz
+  USE print_control_mod, ONLY: lunout
+  IMPLICIT NONE
+!    INCLUDE "iniprint.h"
+ 
+    REAL :: Test_Field1d_glo(klon_glo,nbp_lev)
+    REAL :: tmp1d_glo(klon_glo,nbp_lev)
+    REAL :: Test_Field2d_glo(nbp_lon,nbp_lat,nbp_lev)
+    REAL :: tmp2d_glo(nbp_lon,nbp_lat,nbp_lev)
+    REAL :: Test_Field1d_loc(klon_loc,nbp_lev)
+    REAL :: Test_Field2d_loc(nbp_lon,jj_nb,nbp_lev)
+    REAL :: CheckSum
+    
+    INTEGER :: i,l
+  
+    Test_Field1d_glo = 0.
+    Test_Field2d_glo = 0.
+    Test_Field1d_loc = 0.
+    Test_Field2d_loc = 0.
+  
+    IF (is_mpi_root) THEN
+!$OMP MASTER
+      DO l=1,nbp_lev
+        DO i=1,klon_glo
+!          Test_Field1d_glo(i,l)=MOD(i,10)+10*(l-1)
+           Test_Field1d_glo(i,l)=1
+        ENDDO
+      ENDDO
+!$OMP END MASTER  
+    ENDIF
+  
+    CALL Scatter(Test_Field1d_glo,Test_Field1d_loc)
+    CALL Gather(Test_Field1d_loc,tmp1d_glo)
+  
+    IF (is_mpi_root) THEN
+!$OMP MASTER  
+      Checksum=sum(Test_Field1d_glo-tmp1d_glo)
+      WRITE(lunout,*) "------> Checksum =",Checksum," MUST BE 0"
+!$OMP END MASTER
+    ENDIF
+    
+    CALL grid1dTo2d_glo(Test_Field1d_glo,Test_Field2d_glo)
+    CALL scatter2D(Test_Field2d_glo,Test_Field1d_loc)
+    CALL gather2d(Test_Field1d_loc,Test_Field2d_glo)
+    CALL grid2dTo1d_glo(Test_Field2d_glo,tmp1d_glo)
+
+    IF (is_mpi_root) THEN
+!$OMP MASTER  
+      Checksum=sum(Test_Field1d_glo-tmp1d_glo)
+      WRITE(lunout,*) "------> Checksum =",Checksum," MUST BE 0"
+!$OMP END MASTER
+    ENDIF
+
+    CALL bcast(Test_Field1d_glo)
+    CALL reduce_sum(Test_Field1d_glo,tmp1d_glo)
+
+    IF (is_mpi_root) THEN
+!$OMP MASTER  
+      Checksum=sum(Test_Field1d_glo*omp_size*mpi_size-tmp1d_glo)
+      WRITE(lunout,*) "------> Checksum =",Checksum," MUST BE 0"
+!$OMP END MASTER
+    ENDIF
+    
+     
+   END SUBROUTINE Test_transfert
+  
+END MODULE mod_phys_lmdz_para
+    
Index: DZ6/trunk/libf/phy_common/mod_phys_lmdz_transfert_para.F90
===================================================================
--- /LMDZ6/trunk/libf/phy_common/mod_phys_lmdz_transfert_para.F90	(revision 5267)
+++ 	(revision )
@@ -1,1448 +1,0 @@
-!
-!$Id$
-!
-MODULE mod_phys_lmdz_transfert_para
-
-  USE mod_phys_lmdz_mpi_transfert
-  USE mod_phys_lmdz_omp_transfert 
-
-
-
-  INTERFACE bcast
-    MODULE PROCEDURE bcast_c,                                     &
-                     bcast_i,bcast_i1,bcast_i2,bcast_i3,bcast_i4, &
-                     bcast_r,bcast_r1,bcast_r2,bcast_r3,bcast_r4, &
-		     bcast_l,bcast_l1,bcast_l2,bcast_l3,bcast_l4
-  END INTERFACE
-
-  INTERFACE scatter
-    MODULE PROCEDURE scatter_i,scatter_i1,scatter_i2,scatter_i3, &
-                     scatter_r,scatter_r1,scatter_r2,scatter_r3, &
-		     scatter_l,scatter_l1,scatter_l2,scatter_l3
-  END INTERFACE
-
-  
-  INTERFACE gather
-    MODULE PROCEDURE gather_i,gather_i1,gather_i2,gather_i3, &
-                     gather_r,gather_r1,gather_r2,gather_r3, &
-		     gather_l,gather_l1,gather_l2,gather_l3  
-  END INTERFACE
-  
-  INTERFACE scatter2D
-    MODULE PROCEDURE scatter2D_i,scatter2D_i1,scatter2D_i2,scatter2D_i3, &
-                     scatter2D_r,scatter2D_r1,scatter2D_r2,scatter2D_r3, &
-		     scatter2D_l,scatter2D_l1,scatter2D_l2,scatter2D_l3
-  END INTERFACE
-
-  INTERFACE gather2D
-    MODULE PROCEDURE gather2D_i,gather2D_i1,gather2D_i2,gather2D_i3, &
-                     gather2D_r,gather2D_r1,gather2D_r2,gather2D_r3, &
-		     gather2D_l,gather2D_l1,gather2D_l2,gather2D_l3
-  END INTERFACE 
-  
-  INTERFACE reduce_sum
-    MODULE PROCEDURE reduce_sum_i,reduce_sum_i1,reduce_sum_i2,reduce_sum_i3,reduce_sum_i4, &
-                     reduce_sum_r,reduce_sum_r1,reduce_sum_r2,reduce_sum_r3,reduce_sum_r4
-  END INTERFACE 
-
-  INTERFACE reduce_min
-    MODULE PROCEDURE reduce_min_i,reduce_min_i1,reduce_min_i2,reduce_min_i3,reduce_min_i4, &
-                     reduce_min_r,reduce_min_r1,reduce_min_r2,reduce_min_r3,reduce_min_r4
-  END INTERFACE 
-   
-CONTAINS
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!! Definition des Broadcast --> 4D   !!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-!! -- Les chaine de charactère -- !!
-
-  SUBROUTINE bcast_c(var)
-  IMPLICIT NONE
-    CHARACTER(LEN=*),INTENT(INOUT) :: Var
-   
-!$OMP MASTER
-    CALL bcast_mpi(Var)
-!$OMP END MASTER
-    CALL bcast_omp(Var)
-    
-  END SUBROUTINE bcast_c
-
-!! -- Les entiers -- !!
-  
-  SUBROUTINE bcast_i(var)
-  IMPLICIT NONE
-    INTEGER,INTENT(INOUT) :: Var
-!$OMP MASTER
-    CALL bcast_mpi(Var)
-!$OMP END MASTER
-    CALL bcast_omp(Var)
-    
-  END SUBROUTINE bcast_i
-
-  SUBROUTINE bcast_i1(var)
-  IMPLICIT NONE
-    INTEGER,INTENT(INOUT) :: Var(:)
-   
-!$OMP MASTER
-    CALL bcast_mpi(Var)
-!$OMP END MASTER
-    CALL bcast_omp(Var)
-    
-  END SUBROUTINE bcast_i1
-
-
-  SUBROUTINE bcast_i2(var)
-  IMPLICIT NONE
-    INTEGER,INTENT(INOUT) :: Var(:,:)
-   
-!$OMP MASTER
-    CALL bcast_mpi(Var)
-!$OMP END MASTER
-    CALL bcast_omp(Var)
-    
-  END SUBROUTINE bcast_i2
-
-
-  SUBROUTINE bcast_i3(var)
-  IMPLICIT NONE
-    INTEGER,INTENT(INOUT) :: Var(:,:,:)
-   
-!$OMP MASTER
-    CALL bcast_mpi(Var)
-!$OMP END MASTER
-    CALL bcast_omp(Var)
-    
-  END SUBROUTINE bcast_i3
-
-
-  SUBROUTINE bcast_i4(var)
-  IMPLICIT NONE
-    INTEGER,INTENT(INOUT) :: Var(:,:,:,:)
-   
-!$OMP MASTER
-    CALL bcast_mpi(Var)
-!$OMP END MASTER
-    CALL bcast_omp(Var)
-    
-  END SUBROUTINE bcast_i4
-
- 
-!! -- Les reels -- !!
-  
-  SUBROUTINE bcast_r(var)
-  IMPLICIT NONE
-    REAL,INTENT(INOUT) :: Var
-
-!$OMP MASTER
-    CALL bcast_mpi(Var)
-!$OMP END MASTER
-    CALL bcast_omp(Var)
-    
-  END SUBROUTINE bcast_r
-
-  SUBROUTINE bcast_r1(var)
-  IMPLICIT NONE
-    REAL,INTENT(INOUT) :: Var(:)
-   
-!$OMP MASTER
-    CALL bcast_mpi(Var)
-!$OMP END MASTER
-    CALL bcast_omp(Var)
-    
-  END SUBROUTINE bcast_r1
-
-
-  SUBROUTINE bcast_r2(var)
-  IMPLICIT NONE
-    REAL,INTENT(INOUT) :: Var(:,:)
-   
-!$OMP MASTER
-    CALL bcast_mpi(Var)
-!$OMP END MASTER
-    CALL bcast_omp(Var)
-    
-  END SUBROUTINE bcast_r2
-
-
-  SUBROUTINE bcast_r3(var)
-  IMPLICIT NONE
-    REAL,INTENT(INOUT) :: Var(:,:,:)
-   
-!$OMP MASTER
-    CALL bcast_mpi(Var)
-!$OMP END MASTER
-    CALL bcast_omp(Var)
-    
-  END SUBROUTINE bcast_r3
-
-
-  SUBROUTINE bcast_r4(var)
-  IMPLICIT NONE
-    REAL,INTENT(INOUT) :: Var(:,:,:,:)
-   
-!$OMP MASTER
-    CALL bcast_mpi(Var)
-!$OMP END MASTER
-    CALL bcast_omp(Var)
-    
-  END SUBROUTINE bcast_r4 
-
-
-!! -- Les booleens -- !!
-  
-  SUBROUTINE bcast_l(var)
-  IMPLICIT NONE
-    LOGICAL,INTENT(INOUT) :: Var
-!$OMP MASTER
-    CALL bcast_mpi(Var)
-!$OMP END MASTER
-    CALL bcast_omp(Var)
-    
-  END SUBROUTINE bcast_l
-
-  SUBROUTINE bcast_l1(var)
-  IMPLICIT NONE
-    LOGICAL,INTENT(INOUT) :: Var(:)
-   
-!$OMP MASTER
-    CALL bcast_mpi(Var)
-!$OMP END MASTER
-    CALL bcast_omp(Var)
-    
-  END SUBROUTINE bcast_l1
-
-
-  SUBROUTINE bcast_l2(var)
-  IMPLICIT NONE
-    LOGICAL,INTENT(INOUT) :: Var(:,:)
-   
-!$OMP MASTER
-    CALL bcast_mpi(Var)
-!$OMP END MASTER
-    CALL bcast_omp(Var)
-    
-  END SUBROUTINE bcast_l2
-
-
-  SUBROUTINE bcast_l3(var)
-  IMPLICIT NONE
-    LOGICAL,INTENT(INOUT) :: Var(:,:,:)
-   
-!$OMP MASTER
-    CALL bcast_mpi(Var)
-!$OMP END MASTER
-    CALL bcast_omp(Var)
-    
-  END SUBROUTINE bcast_l3
-
-
-  SUBROUTINE bcast_l4(var)
-  IMPLICIT NONE
-    LOGICAL,INTENT(INOUT) :: Var(:,:,:,:)
-   
-!$OMP MASTER
-    CALL bcast_mpi(Var)
-!$OMP END MASTER
-    CALL bcast_omp(Var)
-    
-  END SUBROUTINE bcast_l4
-
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!! Definition des Scatter   --> 4D   !!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-  SUBROUTINE scatter_i(VarIn, VarOut)
-    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
-    IMPLICIT NONE
-  
-    INTEGER,INTENT(IN),DIMENSION(:) :: VarIn
-    INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut
-
-    INTEGER,DIMENSION(klon_mpi) :: Var_tmp
-    
-!$OMP MASTER
-      CALL scatter_mpi(VarIn,Var_tmp)
-!$OMP END MASTER
-
-      CALL scatter_omp(Var_tmp,Varout)
-    
-  END SUBROUTINE scatter_i
-
-
-  SUBROUTINE scatter_i1(VarIn, VarOut)
-    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
-    IMPLICIT NONE
-  
-    INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn
-    INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
-
-    INTEGER,DIMENSION(klon_mpi,SIZE(Varout,2)) :: Var_tmp
-
-!$OMP MASTER
-      CALL scatter_mpi(VarIn,Var_tmp)
-!$OMP END MASTER
-      CALL scatter_omp(Var_tmp,Varout)
-    
-  END SUBROUTINE scatter_i1
-
-
-  SUBROUTINE scatter_i2(VarIn, VarOut)
-    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
-    IMPLICIT NONE
-  
-    INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn
-    INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
-    
-    INTEGER,DIMENSION(klon_mpi,SIZE(Varout,2),SIZE(Varout,3)) :: Var_tmp
-
-!$OMP MASTER
-      CALL scatter_mpi(VarIn,Var_tmp)
-!$OMP END MASTER
-      CALL scatter_omp(Var_tmp,Varout)
-    
-  END SUBROUTINE scatter_i2
-
-
-  SUBROUTINE scatter_i3(VarIn, VarOut)
-    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
-    IMPLICIT NONE
-  
-    INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
-    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
-
-    INTEGER,DIMENSION(klon_mpi,SIZE(Varout,2),SIZE(Varout,3),SIZE(Varout,4)) :: Var_tmp
-
-!$OMP MASTER
-      CALL scatter_mpi(VarIn,Var_tmp)
-!$OMP END MASTER
-      CALL scatter_omp(Var_tmp,VarOut)
-    
-  END SUBROUTINE scatter_i3
-
-
-  SUBROUTINE scatter_r(VarIn, VarOut)
-    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
-    IMPLICIT NONE
-  
-    REAL,INTENT(IN),DIMENSION(:) :: VarIn
-    REAL,INTENT(OUT),DIMENSION(:) :: VarOut
-
-    REAL,DIMENSION(klon_mpi) :: Var_tmp
-    
-!$OMP MASTER
-      CALL scatter_mpi(VarIn,Var_tmp)
-!$OMP END MASTER
-
-      CALL scatter_omp(Var_tmp,Varout)
-    
-  END SUBROUTINE scatter_r
-
-
-  SUBROUTINE scatter_r1(VarIn, VarOut)
-    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
-    IMPLICIT NONE
-  
-    REAL,INTENT(IN),DIMENSION(:,:) :: VarIn
-    REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
-
-    REAL,DIMENSION(klon_mpi,SIZE(Varout,2)) :: Var_tmp
-
-!$OMP MASTER
-      CALL scatter_mpi(VarIn,Var_tmp)
-!$OMP END MASTER
-      CALL scatter_omp(Var_tmp,Varout)
-    
-  END SUBROUTINE scatter_r1
-
-
-  SUBROUTINE scatter_r2(VarIn, VarOut)
-    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
-    IMPLICIT NONE
-  
-    REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
-    REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
-    
-    REAL,DIMENSION(klon_mpi,SIZE(Varout,2),SIZE(Varout,3)) :: Var_tmp
-
-!$OMP MASTER
-      CALL scatter_mpi(VarIn,Var_tmp)
-!$OMP END MASTER
-      CALL scatter_omp(Var_tmp,Varout)
-    
-  END SUBROUTINE scatter_r2
-
-
-  SUBROUTINE scatter_r3(VarIn, VarOut)
-    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
-    IMPLICIT NONE
-  
-    REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
-    REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
-
-    REAL,DIMENSION(klon_mpi,SIZE(Varout,2),SIZE(Varout,3),SIZE(Varout,4)) :: Var_tmp
-
-!$OMP MASTER
-      CALL scatter_mpi(VarIn,Var_tmp)
-!$OMP END MASTER
-      CALL scatter_omp(Var_tmp,VarOut)
-    
-  END SUBROUTINE scatter_r3
-  
-  
-
-  SUBROUTINE scatter_l(VarIn, VarOut)
-    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
-    IMPLICIT NONE
-  
-    LOGICAL,INTENT(IN),DIMENSION(:) :: VarIn
-    LOGICAL,INTENT(OUT),DIMENSION(:) :: VarOut
-
-    LOGICAL,DIMENSION(klon_mpi) :: Var_tmp
-    
-!$OMP MASTER
-      CALL scatter_mpi(VarIn,Var_tmp)
-!$OMP END MASTER
-
-      CALL scatter_omp(Var_tmp,Varout)
-    
-  END SUBROUTINE scatter_l
-
-
-  SUBROUTINE scatter_l1(VarIn, VarOut)
-    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
-    IMPLICIT NONE
-  
-    LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn
-    LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
-
-    LOGICAL,DIMENSION(klon_mpi,SIZE(Varout,2)) :: Var_tmp
-
-!$OMP MASTER
-      CALL scatter_mpi(VarIn,Var_tmp)
-!$OMP END MASTER
-      CALL scatter_omp(Var_tmp,Varout)
-    
-  END SUBROUTINE scatter_l1
-
-
-  SUBROUTINE scatter_l2(VarIn, VarOut)
-    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
-    IMPLICIT NONE
-  
-    LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
-    LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
-    
-    LOGICAL,DIMENSION(klon_mpi,SIZE(Varout,2),SIZE(Varout,3)) :: Var_tmp
-
-!$OMP MASTER
-      CALL scatter_mpi(VarIn,Var_tmp)
-!$OMP END MASTER
-      CALL scatter_omp(Var_tmp,Varout)
-    
-  END SUBROUTINE scatter_l2
-
-
-  SUBROUTINE scatter_l3(VarIn, VarOut)
-    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
-    IMPLICIT NONE
-  
-    LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
-    LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
-
-    LOGICAL,DIMENSION(klon_mpi,SIZE(Varout,2),SIZE(Varout,3),SIZE(Varout,4)) :: Var_tmp
-
-!$OMP MASTER
-      CALL scatter_mpi(VarIn,Var_tmp)
-!$OMP END MASTER
-      CALL scatter_omp(Var_tmp,VarOut)
-    
-  END SUBROUTINE scatter_l3
-
-
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!! Definition des Gather   --> 4D   !!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- 
-!!!!! --> Les entiers
-
-  SUBROUTINE gather_i(VarIn, VarOut)
-    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
-    IMPLICIT NONE
-  
-    INTEGER,INTENT(IN),DIMENSION(:) :: VarIn
-    INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut
-    
-    INTEGER, DIMENSION(klon_mpi) :: Var_tmp
-    
-    CALL gather_omp(VarIn,Var_tmp)
-!$OMP MASTER
-    CALL gather_mpi(Var_tmp,Varout)
-!$OMP END MASTER
-  
-  END SUBROUTINE gather_i
-
-
-  SUBROUTINE gather_i1(VarIn, VarOut)
-    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
-    IMPLICIT NONE
-  
-    INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn
-    INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
-    
-    INTEGER, DIMENSION(klon_mpi,SIZE(VarIn,2)) :: Var_tmp
-    
-    CALL gather_omp(VarIn,Var_tmp)
-!$OMP MASTER
-    CALL gather_mpi(Var_tmp,Varout)
-!$OMP END MASTER
-  
-  END SUBROUTINE gather_i1
-
-
-  SUBROUTINE gather_i2(VarIn, VarOut)
-    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
-    IMPLICIT NONE
-  
-    INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn
-    INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
-    
-    INTEGER, DIMENSION(klon_mpi,SIZE(VarIn,2),SIZE(VarIn,3)) :: Var_tmp
-    
-    CALL gather_omp(VarIn,Var_tmp)
-!$OMP MASTER
-    CALL gather_mpi(Var_tmp,VarOut)
-!$OMP END MASTER
-  
-  END SUBROUTINE gather_i2
-
-
-  SUBROUTINE gather_i3(VarIn, VarOut)
-    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
-    IMPLICIT NONE
-  
-    INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
-    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
-    
-    INTEGER, DIMENSION(klon_mpi,SIZE(VarIn,2),SIZE(VarIn,3),SIZE(VarIn,4)) :: Var_tmp
-    
-    CALL gather_omp(VarIn,Var_tmp)
-!$OMP MASTER
-    CALL gather_mpi(Var_tmp,VarOut)
-!$OMP END MASTER
-  
-  END SUBROUTINE gather_i3
-
-
-!!!!! --> Les reels
-
-  SUBROUTINE gather_r(VarIn, VarOut)
-    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
-    IMPLICIT NONE
-  
-    REAL,INTENT(IN),DIMENSION(:) :: VarIn
-    REAL,INTENT(OUT),DIMENSION(:) :: VarOut
-    
-    REAL, DIMENSION(klon_mpi) :: Var_tmp
-    
-    CALL gather_omp(VarIn,Var_tmp)
-!$OMP MASTER
-    CALL gather_mpi(Var_tmp,VarOut)
-!$OMP END MASTER
-  
-  END SUBROUTINE gather_r
-
-
-  SUBROUTINE gather_r1(VarIn, VarOut)
-    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
-    IMPLICIT NONE
-  
-    REAL,INTENT(IN),DIMENSION(:,:) :: VarIn
-    REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
-    
-    REAL, DIMENSION(klon_mpi,SIZE(VarIn,2)) :: Var_tmp
-    
-    CALL gather_omp(VarIn,Var_tmp)
-!$OMP MASTER
-    CALL gather_mpi(Var_tmp,VarOut)
-!$OMP END MASTER
-  
-  END SUBROUTINE gather_r1
-
-
-  SUBROUTINE gather_r2(VarIn, VarOut)
-    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
-    IMPLICIT NONE
-  
-    REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
-    REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
-    
-    REAL, DIMENSION(klon_mpi,SIZE(VarIn,2),SIZE(VarIn,3)) :: Var_tmp
-    
-    CALL gather_omp(VarIn,Var_tmp)
-!$OMP MASTER
-    CALL gather_mpi(Var_tmp,VarOut)
-!$OMP END MASTER
-  
-  END SUBROUTINE gather_r2
-
-
-  SUBROUTINE gather_r3(VarIn, VarOut)
-    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
-    IMPLICIT NONE
-  
-    REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
-    REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
-    
-    REAL, DIMENSION(klon_mpi,SIZE(VarIn,2),SIZE(VarIn,3),SIZE(VarIn,4)) :: Var_tmp
-    
-    CALL gather_omp(VarIn,Var_tmp)
-!$OMP MASTER
-    CALL gather_mpi(Var_tmp,VarOut)
-!$OMP END MASTER
-  
-  END SUBROUTINE gather_r3
-
-
-!!!!! --> Les booleens
-
-  SUBROUTINE gather_l(VarIn, VarOut)
-    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
-    IMPLICIT NONE
-  
-    LOGICAL,INTENT(IN),DIMENSION(:) :: VarIn
-    LOGICAL,INTENT(OUT),DIMENSION(:) :: VarOut
-    
-    LOGICAL, DIMENSION(klon_mpi) :: Var_tmp
-    
-    CALL gather_omp(VarIn,Var_tmp)
-!$OMP MASTER
-    CALL gather_mpi(Var_tmp,VarOut)
-!$OMP END MASTER
-  
-  END SUBROUTINE gather_l
-
-
-  SUBROUTINE gather_l1(VarIn, VarOut)
-    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
-    IMPLICIT NONE
-  
-    LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn
-    LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
-    
-    LOGICAL, DIMENSION(klon_mpi,SIZE(VarIn,2)) :: Var_tmp
-    
-    CALL gather_omp(VarIn,Var_tmp)
-!$OMP MASTER
-    CALL gather_mpi(Var_tmp,VarOut)
-!$OMP END MASTER
-  
-  END SUBROUTINE gather_l1
-
-
-  SUBROUTINE gather_l2(VarIn, VarOut)
-    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
-    IMPLICIT NONE
-  
-    LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
-    LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
-    
-    LOGICAL, DIMENSION(klon_mpi,SIZE(VarIn,2),SIZE(VarIn,3)) :: Var_tmp
-    
-    CALL gather_omp(VarIn,Var_tmp)
-!$OMP MASTER
-    CALL gather_mpi(Var_tmp,VarOut)
-!$OMP END MASTER
-  
-  END SUBROUTINE gather_l2
-
-
-  SUBROUTINE gather_l3(VarIn, VarOut)
-    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
-    IMPLICIT NONE
-  
-    LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
-    LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
-    
-    LOGICAL, DIMENSION(klon_mpi,SIZE(VarIn,2),SIZE(VarIn,3),SIZE(VarIn,4)) :: Var_tmp
-    
-    CALL gather_omp(VarIn,Var_tmp)
-!$OMP MASTER
-    CALL gather_mpi(Var_tmp,VarOut)
-!$OMP END MASTER
-  
-  END SUBROUTINE gather_l3
-
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!! Definition des Scatter2D   --> 4D   !!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-
-!!!!! --> Les entiers
-
-  SUBROUTINE scatter2D_i(VarIn, VarOut)
-    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
-    IMPLICIT NONE
-  
-    INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn
-    INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut
-
-    INTEGER,DIMENSION(klon_mpi) :: Var_tmp    
-
-!$OMP MASTER    
-    CALL scatter2D_mpi(VarIn,Var_tmp)
-!$OMP END MASTER
-    CALL scatter_omp(Var_tmp,VarOut)
-
-  END SUBROUTINE scatter2D_i
-
-
-  SUBROUTINE scatter2D_i1(VarIn, VarOut)
-    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
-    IMPLICIT NONE
-  
-    INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn
-    INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
-
-    INTEGER,DIMENSION(klon_mpi,SIZE(VarOut,2)) :: Var_tmp    
-
-!$OMP MASTER    
-    CALL scatter2D_mpi(VarIn,Var_tmp)
-!$OMP END MASTER
-    CALL scatter_omp(Var_tmp,VarOut)
-
-  END SUBROUTINE scatter2D_i1
-  
-
-  SUBROUTINE scatter2D_i2(VarIn, VarOut)
-    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
-    IMPLICIT NONE
-  
-    INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
-    INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
-
-    INTEGER,DIMENSION(klon_mpi,SIZE(VarOut,2),SIZE(VarOut,3)) :: Var_tmp    
-
-!$OMP MASTER    
-    CALL scatter2D_mpi(VarIn,Var_tmp)
-!$OMP END MASTER
-    CALL scatter_omp(Var_tmp,VarOut)
-
-  END SUBROUTINE scatter2D_i2  
-
-
-  SUBROUTINE scatter2D_i3(VarIn, VarOut)
-    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
-    IMPLICIT NONE
-  
-    INTEGER,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn
-    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
-
-    INTEGER,DIMENSION(klon_mpi,SIZE(VarOut,2),SIZE(VarOut,3),SIZE(VarOut,4)) :: Var_tmp    
-
-!$OMP MASTER    
-    CALL scatter2D_mpi(VarIn,Var_tmp)
-!$OMP END MASTER
-    CALL scatter_omp(Var_tmp,VarOut)
-
-  END SUBROUTINE scatter2D_i3
-  
-
-!!!!! --> Les reels
-
-  SUBROUTINE scatter2D_r(VarIn, VarOut)
-    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
-    IMPLICIT NONE
-  
-    REAL,INTENT(IN),DIMENSION(:,:) :: VarIn
-    REAL,INTENT(OUT),DIMENSION(:) :: VarOut
-
-    REAL,DIMENSION(klon_mpi) :: Var_tmp    
-
-!$OMP MASTER    
-    CALL scatter2D_mpi(VarIn,Var_tmp)
-!$OMP END MASTER
-    CALL scatter_omp(Var_tmp,VarOut)
-
-  END SUBROUTINE scatter2D_r
-
-
-  SUBROUTINE scatter2D_r1(VarIn, VarOut)
-    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
-    IMPLICIT NONE
-  
-    REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
-    REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
-
-    REAL,DIMENSION(klon_mpi,SIZE(VarOut,2)) :: Var_tmp    
-
-!$OMP MASTER    
-    CALL scatter2D_mpi(VarIn,Var_tmp)
-!$OMP END MASTER
-    CALL scatter_omp(Var_tmp,VarOut)
-
-  END SUBROUTINE scatter2D_r1
-  
-
-  SUBROUTINE scatter2D_r2(VarIn, VarOut)
-    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
-    IMPLICIT NONE
-  
-    REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
-    REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
-
-    REAL,DIMENSION(klon_mpi,SIZE(VarOut,2),SIZE(VarOut,3)) :: Var_tmp    
-
-!$OMP MASTER    
-    CALL scatter2D_mpi(VarIn,Var_tmp)
-!$OMP END MASTER
-    CALL scatter_omp(Var_tmp,VarOut)
-
-  END SUBROUTINE scatter2D_r2  
-
-
-  SUBROUTINE scatter2D_r3(VarIn, VarOut)
-    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
-    IMPLICIT NONE
-  
-    REAL,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn
-    REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
-
-    REAL,DIMENSION(klon_mpi,SIZE(VarOut,2),SIZE(VarOut,3),SIZE(VarOut,4)) :: Var_tmp    
-
-!$OMP MASTER    
-    CALL scatter2D_mpi(VarIn,Var_tmp)
-!$OMP END MASTER
-    CALL scatter_omp(Var_tmp,VarOut)
-
-  END SUBROUTINE scatter2D_r3
-    
-    
-!!!!! --> Les booleens
-
-
-  SUBROUTINE scatter2D_l(VarIn, VarOut)
-    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
-    IMPLICIT NONE
-  
-    LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn
-    LOGICAL,INTENT(OUT),DIMENSION(:) :: VarOut
-
-    LOGICAL,DIMENSION(klon_mpi) :: Var_tmp    
-
-!$OMP MASTER    
-    CALL scatter2D_mpi(VarIn,Var_tmp)
-!$OMP END MASTER
-    CALL scatter_omp(Var_tmp,VarOut)
-
-  END SUBROUTINE scatter2D_l
-
-
-  SUBROUTINE scatter2D_l1(VarIn, VarOut)
-    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
-    IMPLICIT NONE
-  
-    LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
-    LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
-
-    LOGICAL,DIMENSION(klon_mpi,SIZE(VarOut,2)) :: Var_tmp    
-
-!$OMP MASTER    
-    CALL scatter2D_mpi(VarIn,Var_tmp)
-!$OMP END MASTER
-    CALL scatter_omp(Var_tmp,VarOut)
-
-  END SUBROUTINE scatter2D_l1
-  
-
-  SUBROUTINE scatter2D_l2(VarIn, VarOut)
-    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
-    IMPLICIT NONE
-  
-    LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
-    LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
-
-    LOGICAL,DIMENSION(klon_mpi,SIZE(VarOut,2),SIZE(VarOut,3)) :: Var_tmp    
-
-!$OMP MASTER    
-    CALL scatter2D_mpi(VarIn,Var_tmp)
-!$OMP END MASTER
-    CALL scatter_omp(Var_tmp,VarOut)
-
-  END SUBROUTINE scatter2D_l2  
-
-
-  SUBROUTINE scatter2D_l3(VarIn, VarOut)
-    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
-    IMPLICIT NONE
-  
-    LOGICAL,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn
-    LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
-
-    LOGICAL,DIMENSION(klon_mpi,SIZE(VarOut,2),SIZE(VarOut,3),SIZE(VarOut,4)) :: Var_tmp    
-
-!$OMP MASTER    
-    CALL scatter2D_mpi(VarIn,Var_tmp)
-!$OMP END MASTER
-    CALL scatter_omp(Var_tmp,VarOut)
-
-  END SUBROUTINE scatter2D_l3
-
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!! Definition des Gather2D   --> 4D   !!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-!!!!! --> Les entiers
-
-  SUBROUTINE gather2D_i(VarIn, VarOut)
-    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
-    IMPLICIT NONE
-  
-    INTEGER,INTENT(IN),DIMENSION(:) :: VarIn
-    INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
-    
-    INTEGER,DIMENSION(klon_mpi) :: Var_tmp
-
-    CALL gather_omp(VarIn,Var_tmp)
-!$OMP MASTER
-    CALL gather2D_mpi(Var_tmp,VarOut)
-!$OMP END MASTER    
-
-  END SUBROUTINE gather2D_i
-  
-
-  SUBROUTINE gather2D_i1(VarIn, VarOut)
-    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
-    IMPLICIT NONE
-  
-    INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn
-    INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
-    
-    INTEGER,DIMENSION(klon_mpi,SIZE(VarIn,2)) :: Var_tmp
-
-    CALL gather_omp(VarIn,Var_tmp)
-!$OMP MASTER
-    CALL gather2D_mpi(Var_tmp,VarOut)
-!$OMP END MASTER    
-
-  END SUBROUTINE gather2D_i1
-
-  
-  SUBROUTINE gather2D_i2(VarIn, VarOut)
-    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
-    IMPLICIT NONE
-  
-    INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn
-    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
-    
-    INTEGER,DIMENSION(klon_mpi,SIZE(VarIn,2),SIZE(VarIn,3)) :: Var_tmp
-
-    CALL gather_omp(VarIn,Var_tmp)
-!$OMP MASTER
-    CALL gather2D_mpi(Var_tmp,VarOut)
-!$OMP END MASTER    
-
-  END SUBROUTINE gather2D_i2
-
-
-  SUBROUTINE gather2D_i3(VarIn, VarOut)
-    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
-    IMPLICIT NONE
-  
-    INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
-    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:,:) :: VarOut
-    
-    INTEGER,DIMENSION(klon_mpi,SIZE(VarIn,2),SIZE(VarIn,3),SIZE(VarIn,4)) :: Var_tmp
-
-    CALL gather_omp(VarIn,Var_tmp)
-!$OMP MASTER
-    CALL gather2D_mpi(Var_tmp,VarOut)
-!$OMP END MASTER    
-
-  END SUBROUTINE gather2D_i3
-
-
-!!!!! --> Les reels
-
-  SUBROUTINE gather2D_r(VarIn, VarOut)
-    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
-    IMPLICIT NONE
-  
-    REAL,INTENT(IN),DIMENSION(:) :: VarIn
-    REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
-    
-    REAL,DIMENSION(klon_mpi) :: Var_tmp
-
-    CALL gather_omp(VarIn,Var_tmp)
-!$OMP MASTER
-    CALL gather2D_mpi(Var_tmp,VarOut)
-!$OMP END MASTER    
-
-  END SUBROUTINE gather2D_r
-  
-
-  SUBROUTINE gather2D_r1(VarIn, VarOut)
-    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
-    IMPLICIT NONE
-  
-    REAL,INTENT(IN),DIMENSION(:,:) :: VarIn
-    REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
-    
-    REAL,DIMENSION(klon_mpi,SIZE(VarIn,2)) :: Var_tmp
-
-    CALL gather_omp(VarIn,Var_tmp)
-!$OMP MASTER
-    CALL gather2D_mpi(Var_tmp,VarOut)
-!$OMP END MASTER    
-
-  END SUBROUTINE gather2D_r1
-
-  
-  SUBROUTINE gather2D_r2(VarIn, VarOut)
-    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
-    IMPLICIT NONE
-  
-    REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
-    REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
-    
-    REAL,DIMENSION(klon_mpi,SIZE(VarIn,2),SIZE(VarIn,3)) :: Var_tmp
-
-    CALL gather_omp(VarIn,Var_tmp)
-!$OMP MASTER
-    CALL gather2D_mpi(Var_tmp,VarOut)
-!$OMP END MASTER    
-
-  END SUBROUTINE gather2D_r2
-
-
-  SUBROUTINE gather2D_r3(VarIn, VarOut)
-    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
-    IMPLICIT NONE
-  
-    REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
-    REAL,INTENT(OUT),DIMENSION(:,:,:,:,:) :: VarOut
-    
-    REAL,DIMENSION(klon_mpi,SIZE(VarIn,2),SIZE(VarIn,3),SIZE(VarIn,4)) :: Var_tmp
-
-    CALL gather_omp(VarIn,Var_tmp)
-!$OMP MASTER
-    CALL gather2D_mpi(Var_tmp,VarOut)
-!$OMP END MASTER    
-
-  END SUBROUTINE gather2D_r3
-  
-
-!!!!! --> Les booleens
-
-  SUBROUTINE gather2D_l(VarIn, VarOut)
-    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
-    IMPLICIT NONE
-  
-    LOGICAL,INTENT(IN),DIMENSION(:) :: VarIn
-    LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
-    
-    LOGICAL,DIMENSION(klon_mpi) :: Var_tmp
-
-    CALL gather_omp(VarIn,Var_tmp)
-!$OMP MASTER
-    CALL gather2D_mpi(Var_tmp,VarOut)
-!$OMP END MASTER    
-
-  END SUBROUTINE gather2D_l
-  
-
-  SUBROUTINE gather2D_l1(VarIn, VarOut)
-    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
-    IMPLICIT NONE
-  
-    LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn
-    LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
-    
-    LOGICAL,DIMENSION(klon_mpi,SIZE(VarIn,2)) :: Var_tmp
-
-    CALL gather_omp(VarIn,Var_tmp)
-!$OMP MASTER
-    CALL gather2D_mpi(Var_tmp,VarOut)
-!$OMP END MASTER    
-
-  END SUBROUTINE gather2D_l1
-
-  
-  SUBROUTINE gather2D_l2(VarIn, VarOut)
-    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
-    IMPLICIT NONE
-  
-    LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
-    LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
-    
-    LOGICAL,DIMENSION(klon_mpi,SIZE(VarIn,2),SIZE(VarIn,3)) :: Var_tmp
-
-    CALL gather_omp(VarIn,Var_tmp)
-!$OMP MASTER
-    CALL gather2D_mpi(Var_tmp,VarOut)
-!$OMP END MASTER    
-
-  END SUBROUTINE gather2D_l2
-
-
-  SUBROUTINE gather2D_l3(VarIn, VarOut)
-    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
-    IMPLICIT NONE
-  
-    LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
-    LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:,:) :: VarOut
-    
-    LOGICAL,DIMENSION(klon_mpi,SIZE(VarIn,2),SIZE(VarIn,3),SIZE(VarIn,4)) :: Var_tmp
-
-    CALL gather_omp(VarIn,Var_tmp)
-!$OMP MASTER
-    CALL gather2D_mpi(Var_tmp,VarOut)
-!$OMP END MASTER    
-
-  END SUBROUTINE gather2D_l3
-  
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!! Definition des reduce_sum   --> 4D   !!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! Les entiers
-
-  SUBROUTINE reduce_sum_i(VarIn, VarOut)
-    IMPLICIT NONE
-  
-    INTEGER,INTENT(IN)  :: VarIn
-    INTEGER,INTENT(OUT) :: VarOut
-    
-    INTEGER             :: Var_tmp
-           
-    CALL reduce_sum_omp(VarIn,Var_tmp)
-!$OMP MASTER      
-    CALL reduce_sum_mpi(Var_tmp,VarOut)
-!$OMP END MASTER
-  
-  END SUBROUTINE reduce_sum_i  
-
-
-  SUBROUTINE reduce_sum_i1(VarIn, VarOut)
-    IMPLICIT NONE
-  
-    INTEGER,INTENT(IN),DIMENSION(:)  :: VarIn
-    INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut
-    
-    INTEGER,DIMENSION(SIZE(VarIn))   :: Var_tmp
-           
-    CALL reduce_sum_omp(VarIn,Var_tmp)
-!$OMP MASTER      
-    CALL reduce_sum_mpi(Var_tmp,VarOut)
-!$OMP END MASTER
-  
-  END SUBROUTINE reduce_sum_i1  
-
-
-  SUBROUTINE reduce_sum_i2(VarIn, VarOut)
-    IMPLICIT NONE
-  
-    INTEGER,INTENT(IN),DIMENSION(:,:)  :: VarIn
-    INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
-    
-    INTEGER,DIMENSION(SIZE(VarIn,1),SIZE(VarIn,2)) :: Var_tmp
-           
-    CALL reduce_sum_omp(VarIn,Var_tmp)
-!$OMP MASTER      
-    CALL reduce_sum_mpi(Var_tmp,VarOut)
-!$OMP END MASTER
-  
-  END SUBROUTINE reduce_sum_i2  
-  
-
-  SUBROUTINE reduce_sum_i3(VarIn, VarOut)
-    IMPLICIT NONE
-  
-    INTEGER,INTENT(IN),DIMENSION(:,:,:)  :: VarIn
-    INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
-    
-    INTEGER,DIMENSION(SIZE(VarIn,1),SIZE(VarIn,2),SIZE(VarIn,3))  :: Var_tmp
-           
-    CALL reduce_sum_omp(VarIn,Var_tmp)
-!$OMP MASTER      
-    CALL reduce_sum_mpi(Var_tmp,VarOut)
-!$OMP END MASTER
-  
-  END SUBROUTINE reduce_sum_i3  
-
-
-  SUBROUTINE reduce_sum_i4(VarIn, VarOut)
-    IMPLICIT NONE
-  
-    INTEGER,INTENT(IN),DIMENSION(:,:,:,:)  :: VarIn
-    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
-    
-    INTEGER,DIMENSION(SIZE(VarIn,1),SIZE(VarIn,2),SIZE(VarIn,3),SIZE(VarIn,4))  :: Var_tmp
-           
-    CALL reduce_sum_omp(VarIn,Var_tmp)
-!$OMP MASTER      
-    CALL reduce_sum_mpi(Var_tmp,VarOut)
-!$OMP END MASTER
-  
-  END SUBROUTINE reduce_sum_i4  
-
-
-! Les reels
-
-  SUBROUTINE reduce_sum_r(VarIn, VarOut)
-    IMPLICIT NONE
-  
-    REAL,INTENT(IN)  :: VarIn
-    REAL,INTENT(OUT) :: VarOut
-    
-    REAL             :: Var_tmp
-           
-    CALL reduce_sum_omp(VarIn,Var_tmp)
-!$OMP MASTER      
-    CALL reduce_sum_mpi(Var_tmp,VarOut)
-!$OMP END MASTER
-  
-  END SUBROUTINE reduce_sum_r  
-
-
-  SUBROUTINE reduce_sum_r1(VarIn, VarOut)
-    IMPLICIT NONE
-  
-    REAL,INTENT(IN),DIMENSION(:)  :: VarIn
-    REAL,INTENT(OUT),DIMENSION(:) :: VarOut
-    
-    REAL,DIMENSION(SIZE(VarIn))   :: Var_tmp
-           
-    CALL reduce_sum_omp(VarIn,Var_tmp)
-!$OMP MASTER      
-    CALL reduce_sum_mpi(Var_tmp,VarOut)
-!$OMP END MASTER
-  
-  END SUBROUTINE reduce_sum_r1  
-
-
-  SUBROUTINE reduce_sum_r2(VarIn, VarOut)
-    IMPLICIT NONE
-  
-    REAL,INTENT(IN),DIMENSION(:,:)  :: VarIn
-    REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
-    
-    REAL,DIMENSION(SIZE(VarIn,1),SIZE(VarIn,2)) :: Var_tmp
-           
-    CALL reduce_sum_omp(VarIn,Var_tmp)
-!$OMP MASTER      
-    CALL reduce_sum_mpi(Var_tmp,VarOut)
-!$OMP END MASTER
-  
-  END SUBROUTINE reduce_sum_r2  
-  
-
-  SUBROUTINE reduce_sum_r3(VarIn, VarOut)
-    IMPLICIT NONE
-  
-    REAL,INTENT(IN),DIMENSION(:,:,:)  :: VarIn
-    REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
-    
-    REAL,DIMENSION(SIZE(VarIn,1),SIZE(VarIn,2),SIZE(VarIn,3))  :: Var_tmp
-           
-    CALL reduce_sum_omp(VarIn,Var_tmp)
-!$OMP MASTER      
-    CALL reduce_sum_mpi(Var_tmp,VarOut)
-!$OMP END MASTER
-  
-  END SUBROUTINE reduce_sum_r3  
-
-
-  SUBROUTINE reduce_sum_r4(VarIn, VarOut)
-    IMPLICIT NONE
-  
-    REAL,INTENT(IN),DIMENSION(:,:,:,:)  :: VarIn
-    REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
-    
-    REAL,DIMENSION(SIZE(VarIn,1),SIZE(VarIn,2),SIZE(VarIn,3),SIZE(VarIn,4))  :: Var_tmp
-           
-    CALL reduce_sum_omp(VarIn,Var_tmp)
-!$OMP MASTER      
-    CALL reduce_sum_mpi(Var_tmp,VarOut)
-!$OMP END MASTER
-  
-  END SUBROUTINE reduce_sum_r4  
-
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!! Definition des reduce_min   --> 4D   !!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! Les entiers
-
-  SUBROUTINE reduce_min_i(VarIn, VarOut)
-    IMPLICIT NONE
-  
-    INTEGER,INTENT(IN)  :: VarIn
-    INTEGER,INTENT(OUT) :: VarOut
-    
-    INTEGER             :: Var_tmp
-           
-    CALL reduce_min_omp(VarIn,Var_tmp)
-!$OMP MASTER      
-    CALL reduce_min_mpi(Var_tmp,VarOut)
-!$OMP END MASTER
-  
-  END SUBROUTINE reduce_min_i  
-
-
-  SUBROUTINE reduce_min_i1(VarIn, VarOut)
-    IMPLICIT NONE
-  
-    INTEGER,INTENT(IN),DIMENSION(:)  :: VarIn
-    INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut
-    
-    INTEGER,DIMENSION(SIZE(VarIn))   :: Var_tmp
-           
-    CALL reduce_min_omp(VarIn,Var_tmp)
-!$OMP MASTER      
-    CALL reduce_min_mpi(Var_tmp,VarOut)
-!$OMP END MASTER
-  
-  END SUBROUTINE reduce_min_i1  
-
-
-  SUBROUTINE reduce_min_i2(VarIn, VarOut)
-    IMPLICIT NONE
-  
-    INTEGER,INTENT(IN),DIMENSION(:,:)  :: VarIn
-    INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
-    
-    INTEGER,DIMENSION(SIZE(VarIn,1),SIZE(VarIn,2)) :: Var_tmp
-           
-    CALL reduce_min_omp(VarIn,Var_tmp)
-!$OMP MASTER      
-    CALL reduce_min_mpi(Var_tmp,VarOut)
-!$OMP END MASTER
-  
-  END SUBROUTINE reduce_min_i2  
-  
-
-  SUBROUTINE reduce_min_i3(VarIn, VarOut)
-    IMPLICIT NONE
-  
-    INTEGER,INTENT(IN),DIMENSION(:,:,:)  :: VarIn
-    INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
-    
-    INTEGER,DIMENSION(SIZE(VarIn,1),SIZE(VarIn,2),SIZE(VarIn,3))  :: Var_tmp
-           
-    CALL reduce_min_omp(VarIn,Var_tmp)
-!$OMP MASTER      
-    CALL reduce_min_mpi(Var_tmp,VarOut)
-!$OMP END MASTER
-  
-  END SUBROUTINE reduce_min_i3  
-
-
-  SUBROUTINE reduce_min_i4(VarIn, VarOut)
-    IMPLICIT NONE
-  
-    INTEGER,INTENT(IN),DIMENSION(:,:,:,:)  :: VarIn
-    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
-    
-    INTEGER,DIMENSION(SIZE(VarIn,1),SIZE(VarIn,2),SIZE(VarIn,3),SIZE(VarIn,4))  :: Var_tmp
-           
-    CALL reduce_min_omp(VarIn,Var_tmp)
-!$OMP MASTER      
-    CALL reduce_min_mpi(Var_tmp,VarOut)
-!$OMP END MASTER
-  
-  END SUBROUTINE reduce_min_i4  
-
-
-! Les reels
-
-  SUBROUTINE reduce_min_r(VarIn, VarOut)
-    IMPLICIT NONE
-  
-    REAL,INTENT(IN)  :: VarIn
-    REAL,INTENT(OUT) :: VarOut
-    
-    REAL             :: Var_tmp
-           
-    CALL reduce_min_omp(VarIn,Var_tmp)
-!$OMP MASTER      
-    CALL reduce_min_mpi(Var_tmp,VarOut)
-!$OMP END MASTER
-  
-  END SUBROUTINE reduce_min_r  
-
-
-  SUBROUTINE reduce_min_r1(VarIn, VarOut)
-    IMPLICIT NONE
-  
-    REAL,INTENT(IN),DIMENSION(:)  :: VarIn
-    REAL,INTENT(OUT),DIMENSION(:) :: VarOut
-    
-    REAL,DIMENSION(SIZE(VarIn))   :: Var_tmp
-           
-    CALL reduce_min_omp(VarIn,Var_tmp)
-!$OMP MASTER      
-    CALL reduce_min_mpi(Var_tmp,VarOut)
-!$OMP END MASTER
-  
-  END SUBROUTINE reduce_min_r1  
-
-
-  SUBROUTINE reduce_min_r2(VarIn, VarOut)
-    IMPLICIT NONE
-  
-    REAL,INTENT(IN),DIMENSION(:,:)  :: VarIn
-    REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
-    
-    REAL,DIMENSION(SIZE(VarIn,1),SIZE(VarIn,2)) :: Var_tmp
-           
-    CALL reduce_min_omp(VarIn,Var_tmp)
-!$OMP MASTER      
-    CALL reduce_min_mpi(Var_tmp,VarOut)
-!$OMP END MASTER
-  
-  END SUBROUTINE reduce_min_r2  
-  
-
-  SUBROUTINE reduce_min_r3(VarIn, VarOut)
-    IMPLICIT NONE
-  
-    REAL,INTENT(IN),DIMENSION(:,:,:)  :: VarIn
-    REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
-    
-    REAL,DIMENSION(SIZE(VarIn,1),SIZE(VarIn,2),SIZE(VarIn,3))  :: Var_tmp
-           
-    CALL reduce_min_omp(VarIn,Var_tmp)
-!$OMP MASTER      
-    CALL reduce_min_mpi(Var_tmp,VarOut)
-!$OMP END MASTER
-  
-  END SUBROUTINE reduce_min_r3  
-
-
-  SUBROUTINE reduce_min_r4(VarIn, VarOut)
-    IMPLICIT NONE
-  
-    REAL,INTENT(IN),DIMENSION(:,:,:,:)  :: VarIn
-    REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
-    
-    REAL,DIMENSION(SIZE(VarIn,1),SIZE(VarIn,2),SIZE(VarIn,3),SIZE(VarIn,4))  :: Var_tmp
-           
-    CALL reduce_min_omp(VarIn,Var_tmp)
-!$OMP MASTER      
-    CALL reduce_min_mpi(Var_tmp,VarOut)
-!$OMP END MASTER
-  
-  END SUBROUTINE reduce_min_r4  
-
-
-   
-END MODULE mod_phys_lmdz_transfert_para
-
Index: /LMDZ6/trunk/libf/phy_common/mod_phys_lmdz_transfert_para.f90
===================================================================
--- /LMDZ6/trunk/libf/phy_common/mod_phys_lmdz_transfert_para.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phy_common/mod_phys_lmdz_transfert_para.f90	(revision 5268)
@@ -0,0 +1,1448 @@
+!
+!$Id$
+!
+MODULE mod_phys_lmdz_transfert_para
+
+  USE mod_phys_lmdz_mpi_transfert
+  USE mod_phys_lmdz_omp_transfert 
+
+
+
+  INTERFACE bcast
+    MODULE PROCEDURE bcast_c,                                     &
+                     bcast_i,bcast_i1,bcast_i2,bcast_i3,bcast_i4, &
+                     bcast_r,bcast_r1,bcast_r2,bcast_r3,bcast_r4, &
+		     bcast_l,bcast_l1,bcast_l2,bcast_l3,bcast_l4
+  END INTERFACE
+
+  INTERFACE scatter
+    MODULE PROCEDURE scatter_i,scatter_i1,scatter_i2,scatter_i3, &
+                     scatter_r,scatter_r1,scatter_r2,scatter_r3, &
+		     scatter_l,scatter_l1,scatter_l2,scatter_l3
+  END INTERFACE
+
+  
+  INTERFACE gather
+    MODULE PROCEDURE gather_i,gather_i1,gather_i2,gather_i3, &
+                     gather_r,gather_r1,gather_r2,gather_r3, &
+		     gather_l,gather_l1,gather_l2,gather_l3  
+  END INTERFACE
+  
+  INTERFACE scatter2D
+    MODULE PROCEDURE scatter2D_i,scatter2D_i1,scatter2D_i2,scatter2D_i3, &
+                     scatter2D_r,scatter2D_r1,scatter2D_r2,scatter2D_r3, &
+		     scatter2D_l,scatter2D_l1,scatter2D_l2,scatter2D_l3
+  END INTERFACE
+
+  INTERFACE gather2D
+    MODULE PROCEDURE gather2D_i,gather2D_i1,gather2D_i2,gather2D_i3, &
+                     gather2D_r,gather2D_r1,gather2D_r2,gather2D_r3, &
+		     gather2D_l,gather2D_l1,gather2D_l2,gather2D_l3
+  END INTERFACE 
+  
+  INTERFACE reduce_sum
+    MODULE PROCEDURE reduce_sum_i,reduce_sum_i1,reduce_sum_i2,reduce_sum_i3,reduce_sum_i4, &
+                     reduce_sum_r,reduce_sum_r1,reduce_sum_r2,reduce_sum_r3,reduce_sum_r4
+  END INTERFACE 
+
+  INTERFACE reduce_min
+    MODULE PROCEDURE reduce_min_i,reduce_min_i1,reduce_min_i2,reduce_min_i3,reduce_min_i4, &
+                     reduce_min_r,reduce_min_r1,reduce_min_r2,reduce_min_r3,reduce_min_r4
+  END INTERFACE 
+   
+CONTAINS
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! Definition des Broadcast --> 4D   !!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+!! -- Les chaine de charactère -- !!
+
+  SUBROUTINE bcast_c(var)
+  IMPLICIT NONE
+    CHARACTER(LEN=*),INTENT(INOUT) :: Var
+   
+!$OMP MASTER
+    CALL bcast_mpi(Var)
+!$OMP END MASTER
+    CALL bcast_omp(Var)
+    
+  END SUBROUTINE bcast_c
+
+!! -- Les entiers -- !!
+  
+  SUBROUTINE bcast_i(var)
+  IMPLICIT NONE
+    INTEGER,INTENT(INOUT) :: Var
+!$OMP MASTER
+    CALL bcast_mpi(Var)
+!$OMP END MASTER
+    CALL bcast_omp(Var)
+    
+  END SUBROUTINE bcast_i
+
+  SUBROUTINE bcast_i1(var)
+  IMPLICIT NONE
+    INTEGER,INTENT(INOUT) :: Var(:)
+   
+!$OMP MASTER
+    CALL bcast_mpi(Var)
+!$OMP END MASTER
+    CALL bcast_omp(Var)
+    
+  END SUBROUTINE bcast_i1
+
+
+  SUBROUTINE bcast_i2(var)
+  IMPLICIT NONE
+    INTEGER,INTENT(INOUT) :: Var(:,:)
+   
+!$OMP MASTER
+    CALL bcast_mpi(Var)
+!$OMP END MASTER
+    CALL bcast_omp(Var)
+    
+  END SUBROUTINE bcast_i2
+
+
+  SUBROUTINE bcast_i3(var)
+  IMPLICIT NONE
+    INTEGER,INTENT(INOUT) :: Var(:,:,:)
+   
+!$OMP MASTER
+    CALL bcast_mpi(Var)
+!$OMP END MASTER
+    CALL bcast_omp(Var)
+    
+  END SUBROUTINE bcast_i3
+
+
+  SUBROUTINE bcast_i4(var)
+  IMPLICIT NONE
+    INTEGER,INTENT(INOUT) :: Var(:,:,:,:)
+   
+!$OMP MASTER
+    CALL bcast_mpi(Var)
+!$OMP END MASTER
+    CALL bcast_omp(Var)
+    
+  END SUBROUTINE bcast_i4
+
+ 
+!! -- Les reels -- !!
+  
+  SUBROUTINE bcast_r(var)
+  IMPLICIT NONE
+    REAL,INTENT(INOUT) :: Var
+
+!$OMP MASTER
+    CALL bcast_mpi(Var)
+!$OMP END MASTER
+    CALL bcast_omp(Var)
+    
+  END SUBROUTINE bcast_r
+
+  SUBROUTINE bcast_r1(var)
+  IMPLICIT NONE
+    REAL,INTENT(INOUT) :: Var(:)
+   
+!$OMP MASTER
+    CALL bcast_mpi(Var)
+!$OMP END MASTER
+    CALL bcast_omp(Var)
+    
+  END SUBROUTINE bcast_r1
+
+
+  SUBROUTINE bcast_r2(var)
+  IMPLICIT NONE
+    REAL,INTENT(INOUT) :: Var(:,:)
+   
+!$OMP MASTER
+    CALL bcast_mpi(Var)
+!$OMP END MASTER
+    CALL bcast_omp(Var)
+    
+  END SUBROUTINE bcast_r2
+
+
+  SUBROUTINE bcast_r3(var)
+  IMPLICIT NONE
+    REAL,INTENT(INOUT) :: Var(:,:,:)
+   
+!$OMP MASTER
+    CALL bcast_mpi(Var)
+!$OMP END MASTER
+    CALL bcast_omp(Var)
+    
+  END SUBROUTINE bcast_r3
+
+
+  SUBROUTINE bcast_r4(var)
+  IMPLICIT NONE
+    REAL,INTENT(INOUT) :: Var(:,:,:,:)
+   
+!$OMP MASTER
+    CALL bcast_mpi(Var)
+!$OMP END MASTER
+    CALL bcast_omp(Var)
+    
+  END SUBROUTINE bcast_r4 
+
+
+!! -- Les booleens -- !!
+  
+  SUBROUTINE bcast_l(var)
+  IMPLICIT NONE
+    LOGICAL,INTENT(INOUT) :: Var
+!$OMP MASTER
+    CALL bcast_mpi(Var)
+!$OMP END MASTER
+    CALL bcast_omp(Var)
+    
+  END SUBROUTINE bcast_l
+
+  SUBROUTINE bcast_l1(var)
+  IMPLICIT NONE
+    LOGICAL,INTENT(INOUT) :: Var(:)
+   
+!$OMP MASTER
+    CALL bcast_mpi(Var)
+!$OMP END MASTER
+    CALL bcast_omp(Var)
+    
+  END SUBROUTINE bcast_l1
+
+
+  SUBROUTINE bcast_l2(var)
+  IMPLICIT NONE
+    LOGICAL,INTENT(INOUT) :: Var(:,:)
+   
+!$OMP MASTER
+    CALL bcast_mpi(Var)
+!$OMP END MASTER
+    CALL bcast_omp(Var)
+    
+  END SUBROUTINE bcast_l2
+
+
+  SUBROUTINE bcast_l3(var)
+  IMPLICIT NONE
+    LOGICAL,INTENT(INOUT) :: Var(:,:,:)
+   
+!$OMP MASTER
+    CALL bcast_mpi(Var)
+!$OMP END MASTER
+    CALL bcast_omp(Var)
+    
+  END SUBROUTINE bcast_l3
+
+
+  SUBROUTINE bcast_l4(var)
+  IMPLICIT NONE
+    LOGICAL,INTENT(INOUT) :: Var(:,:,:,:)
+   
+!$OMP MASTER
+    CALL bcast_mpi(Var)
+!$OMP END MASTER
+    CALL bcast_omp(Var)
+    
+  END SUBROUTINE bcast_l4
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! Definition des Scatter   --> 4D   !!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+  SUBROUTINE scatter_i(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut
+
+    INTEGER,DIMENSION(klon_mpi) :: Var_tmp
+    
+!$OMP MASTER
+      CALL scatter_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+
+      CALL scatter_omp(Var_tmp,Varout)
+    
+  END SUBROUTINE scatter_i
+
+
+  SUBROUTINE scatter_i1(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
+
+    INTEGER,DIMENSION(klon_mpi,SIZE(Varout,2)) :: Var_tmp
+
+!$OMP MASTER
+      CALL scatter_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+      CALL scatter_omp(Var_tmp,Varout)
+    
+  END SUBROUTINE scatter_i1
+
+
+  SUBROUTINE scatter_i2(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    INTEGER,DIMENSION(klon_mpi,SIZE(Varout,2),SIZE(Varout,3)) :: Var_tmp
+
+!$OMP MASTER
+      CALL scatter_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+      CALL scatter_omp(Var_tmp,Varout)
+    
+  END SUBROUTINE scatter_i2
+
+
+  SUBROUTINE scatter_i3(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+
+    INTEGER,DIMENSION(klon_mpi,SIZE(Varout,2),SIZE(Varout,3),SIZE(Varout,4)) :: Var_tmp
+
+!$OMP MASTER
+      CALL scatter_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+      CALL scatter_omp(Var_tmp,VarOut)
+    
+  END SUBROUTINE scatter_i3
+
+
+  SUBROUTINE scatter_r(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:) :: VarOut
+
+    REAL,DIMENSION(klon_mpi) :: Var_tmp
+    
+!$OMP MASTER
+      CALL scatter_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+
+      CALL scatter_omp(Var_tmp,Varout)
+    
+  END SUBROUTINE scatter_r
+
+
+  SUBROUTINE scatter_r1(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+
+    REAL,DIMENSION(klon_mpi,SIZE(Varout,2)) :: Var_tmp
+
+!$OMP MASTER
+      CALL scatter_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+      CALL scatter_omp(Var_tmp,Varout)
+    
+  END SUBROUTINE scatter_r1
+
+
+  SUBROUTINE scatter_r2(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    REAL,DIMENSION(klon_mpi,SIZE(Varout,2),SIZE(Varout,3)) :: Var_tmp
+
+!$OMP MASTER
+      CALL scatter_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+      CALL scatter_omp(Var_tmp,Varout)
+    
+  END SUBROUTINE scatter_r2
+
+
+  SUBROUTINE scatter_r3(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+
+    REAL,DIMENSION(klon_mpi,SIZE(Varout,2),SIZE(Varout,3),SIZE(Varout,4)) :: Var_tmp
+
+!$OMP MASTER
+      CALL scatter_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+      CALL scatter_omp(Var_tmp,VarOut)
+    
+  END SUBROUTINE scatter_r3
+  
+  
+
+  SUBROUTINE scatter_l(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:) :: VarOut
+
+    LOGICAL,DIMENSION(klon_mpi) :: Var_tmp
+    
+!$OMP MASTER
+      CALL scatter_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+
+      CALL scatter_omp(Var_tmp,Varout)
+    
+  END SUBROUTINE scatter_l
+
+
+  SUBROUTINE scatter_l1(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+
+    LOGICAL,DIMENSION(klon_mpi,SIZE(Varout,2)) :: Var_tmp
+
+!$OMP MASTER
+      CALL scatter_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+      CALL scatter_omp(Var_tmp,Varout)
+    
+  END SUBROUTINE scatter_l1
+
+
+  SUBROUTINE scatter_l2(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    LOGICAL,DIMENSION(klon_mpi,SIZE(Varout,2),SIZE(Varout,3)) :: Var_tmp
+
+!$OMP MASTER
+      CALL scatter_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+      CALL scatter_omp(Var_tmp,Varout)
+    
+  END SUBROUTINE scatter_l2
+
+
+  SUBROUTINE scatter_l3(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+
+    LOGICAL,DIMENSION(klon_mpi,SIZE(Varout,2),SIZE(Varout,3),SIZE(Varout,4)) :: Var_tmp
+
+!$OMP MASTER
+      CALL scatter_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+      CALL scatter_omp(Var_tmp,VarOut)
+    
+  END SUBROUTINE scatter_l3
+
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! Definition des Gather   --> 4D   !!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ 
+!!!!! --> Les entiers
+
+  SUBROUTINE gather_i(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut
+    
+    INTEGER, DIMENSION(klon_mpi) :: Var_tmp
+    
+    CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+    CALL gather_mpi(Var_tmp,Varout)
+!$OMP END MASTER
+  
+  END SUBROUTINE gather_i
+
+
+  SUBROUTINE gather_i1(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+    INTEGER, DIMENSION(klon_mpi,SIZE(VarIn,2)) :: Var_tmp
+    
+    CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+    CALL gather_mpi(Var_tmp,Varout)
+!$OMP END MASTER
+  
+  END SUBROUTINE gather_i1
+
+
+  SUBROUTINE gather_i2(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    INTEGER, DIMENSION(klon_mpi,SIZE(VarIn,2),SIZE(VarIn,3)) :: Var_tmp
+    
+    CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+    CALL gather_mpi(Var_tmp,VarOut)
+!$OMP END MASTER
+  
+  END SUBROUTINE gather_i2
+
+
+  SUBROUTINE gather_i3(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+    INTEGER, DIMENSION(klon_mpi,SIZE(VarIn,2),SIZE(VarIn,3),SIZE(VarIn,4)) :: Var_tmp
+    
+    CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+    CALL gather_mpi(Var_tmp,VarOut)
+!$OMP END MASTER
+  
+  END SUBROUTINE gather_i3
+
+
+!!!!! --> Les reels
+
+  SUBROUTINE gather_r(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:) :: VarOut
+    
+    REAL, DIMENSION(klon_mpi) :: Var_tmp
+    
+    CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+    CALL gather_mpi(Var_tmp,VarOut)
+!$OMP END MASTER
+  
+  END SUBROUTINE gather_r
+
+
+  SUBROUTINE gather_r1(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+    REAL, DIMENSION(klon_mpi,SIZE(VarIn,2)) :: Var_tmp
+    
+    CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+    CALL gather_mpi(Var_tmp,VarOut)
+!$OMP END MASTER
+  
+  END SUBROUTINE gather_r1
+
+
+  SUBROUTINE gather_r2(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    REAL, DIMENSION(klon_mpi,SIZE(VarIn,2),SIZE(VarIn,3)) :: Var_tmp
+    
+    CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+    CALL gather_mpi(Var_tmp,VarOut)
+!$OMP END MASTER
+  
+  END SUBROUTINE gather_r2
+
+
+  SUBROUTINE gather_r3(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+    REAL, DIMENSION(klon_mpi,SIZE(VarIn,2),SIZE(VarIn,3),SIZE(VarIn,4)) :: Var_tmp
+    
+    CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+    CALL gather_mpi(Var_tmp,VarOut)
+!$OMP END MASTER
+  
+  END SUBROUTINE gather_r3
+
+
+!!!!! --> Les booleens
+
+  SUBROUTINE gather_l(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:) :: VarOut
+    
+    LOGICAL, DIMENSION(klon_mpi) :: Var_tmp
+    
+    CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+    CALL gather_mpi(Var_tmp,VarOut)
+!$OMP END MASTER
+  
+  END SUBROUTINE gather_l
+
+
+  SUBROUTINE gather_l1(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+    LOGICAL, DIMENSION(klon_mpi,SIZE(VarIn,2)) :: Var_tmp
+    
+    CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+    CALL gather_mpi(Var_tmp,VarOut)
+!$OMP END MASTER
+  
+  END SUBROUTINE gather_l1
+
+
+  SUBROUTINE gather_l2(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    LOGICAL, DIMENSION(klon_mpi,SIZE(VarIn,2),SIZE(VarIn,3)) :: Var_tmp
+    
+    CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+    CALL gather_mpi(Var_tmp,VarOut)
+!$OMP END MASTER
+  
+  END SUBROUTINE gather_l2
+
+
+  SUBROUTINE gather_l3(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+    LOGICAL, DIMENSION(klon_mpi,SIZE(VarIn,2),SIZE(VarIn,3),SIZE(VarIn,4)) :: Var_tmp
+    
+    CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+    CALL gather_mpi(Var_tmp,VarOut)
+!$OMP END MASTER
+  
+  END SUBROUTINE gather_l3
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! Definition des Scatter2D   --> 4D   !!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+
+!!!!! --> Les entiers
+
+  SUBROUTINE scatter2D_i(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut
+
+    INTEGER,DIMENSION(klon_mpi) :: Var_tmp    
+
+!$OMP MASTER    
+    CALL scatter2D_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+    CALL scatter_omp(Var_tmp,VarOut)
+
+  END SUBROUTINE scatter2D_i
+
+
+  SUBROUTINE scatter2D_i1(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
+
+    INTEGER,DIMENSION(klon_mpi,SIZE(VarOut,2)) :: Var_tmp    
+
+!$OMP MASTER    
+    CALL scatter2D_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+    CALL scatter_omp(Var_tmp,VarOut)
+
+  END SUBROUTINE scatter2D_i1
+  
+
+  SUBROUTINE scatter2D_i2(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+
+    INTEGER,DIMENSION(klon_mpi,SIZE(VarOut,2),SIZE(VarOut,3)) :: Var_tmp    
+
+!$OMP MASTER    
+    CALL scatter2D_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+    CALL scatter_omp(Var_tmp,VarOut)
+
+  END SUBROUTINE scatter2D_i2  
+
+
+  SUBROUTINE scatter2D_i3(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+
+    INTEGER,DIMENSION(klon_mpi,SIZE(VarOut,2),SIZE(VarOut,3),SIZE(VarOut,4)) :: Var_tmp    
+
+!$OMP MASTER    
+    CALL scatter2D_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+    CALL scatter_omp(Var_tmp,VarOut)
+
+  END SUBROUTINE scatter2D_i3
+  
+
+!!!!! --> Les reels
+
+  SUBROUTINE scatter2D_r(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:) :: VarOut
+
+    REAL,DIMENSION(klon_mpi) :: Var_tmp    
+
+!$OMP MASTER    
+    CALL scatter2D_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+    CALL scatter_omp(Var_tmp,VarOut)
+
+  END SUBROUTINE scatter2D_r
+
+
+  SUBROUTINE scatter2D_r1(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+
+    REAL,DIMENSION(klon_mpi,SIZE(VarOut,2)) :: Var_tmp    
+
+!$OMP MASTER    
+    CALL scatter2D_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+    CALL scatter_omp(Var_tmp,VarOut)
+
+  END SUBROUTINE scatter2D_r1
+  
+
+  SUBROUTINE scatter2D_r2(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+
+    REAL,DIMENSION(klon_mpi,SIZE(VarOut,2),SIZE(VarOut,3)) :: Var_tmp    
+
+!$OMP MASTER    
+    CALL scatter2D_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+    CALL scatter_omp(Var_tmp,VarOut)
+
+  END SUBROUTINE scatter2D_r2  
+
+
+  SUBROUTINE scatter2D_r3(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+
+    REAL,DIMENSION(klon_mpi,SIZE(VarOut,2),SIZE(VarOut,3),SIZE(VarOut,4)) :: Var_tmp    
+
+!$OMP MASTER    
+    CALL scatter2D_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+    CALL scatter_omp(Var_tmp,VarOut)
+
+  END SUBROUTINE scatter2D_r3
+    
+    
+!!!!! --> Les booleens
+
+
+  SUBROUTINE scatter2D_l(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:) :: VarOut
+
+    LOGICAL,DIMENSION(klon_mpi) :: Var_tmp    
+
+!$OMP MASTER    
+    CALL scatter2D_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+    CALL scatter_omp(Var_tmp,VarOut)
+
+  END SUBROUTINE scatter2D_l
+
+
+  SUBROUTINE scatter2D_l1(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+
+    LOGICAL,DIMENSION(klon_mpi,SIZE(VarOut,2)) :: Var_tmp    
+
+!$OMP MASTER    
+    CALL scatter2D_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+    CALL scatter_omp(Var_tmp,VarOut)
+
+  END SUBROUTINE scatter2D_l1
+  
+
+  SUBROUTINE scatter2D_l2(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+
+    LOGICAL,DIMENSION(klon_mpi,SIZE(VarOut,2),SIZE(VarOut,3)) :: Var_tmp    
+
+!$OMP MASTER    
+    CALL scatter2D_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+    CALL scatter_omp(Var_tmp,VarOut)
+
+  END SUBROUTINE scatter2D_l2  
+
+
+  SUBROUTINE scatter2D_l3(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+
+    LOGICAL,DIMENSION(klon_mpi,SIZE(VarOut,2),SIZE(VarOut,3),SIZE(VarOut,4)) :: Var_tmp    
+
+!$OMP MASTER    
+    CALL scatter2D_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+    CALL scatter_omp(Var_tmp,VarOut)
+
+  END SUBROUTINE scatter2D_l3
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! Definition des Gather2D   --> 4D   !!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+!!!!! --> Les entiers
+
+  SUBROUTINE gather2D_i(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+    INTEGER,DIMENSION(klon_mpi) :: Var_tmp
+
+    CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+    CALL gather2D_mpi(Var_tmp,VarOut)
+!$OMP END MASTER    
+
+  END SUBROUTINE gather2D_i
+  
+
+  SUBROUTINE gather2D_i1(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    INTEGER,DIMENSION(klon_mpi,SIZE(VarIn,2)) :: Var_tmp
+
+    CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+    CALL gather2D_mpi(Var_tmp,VarOut)
+!$OMP END MASTER    
+
+  END SUBROUTINE gather2D_i1
+
+  
+  SUBROUTINE gather2D_i2(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+    INTEGER,DIMENSION(klon_mpi,SIZE(VarIn,2),SIZE(VarIn,3)) :: Var_tmp
+
+    CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+    CALL gather2D_mpi(Var_tmp,VarOut)
+!$OMP END MASTER    
+
+  END SUBROUTINE gather2D_i2
+
+
+  SUBROUTINE gather2D_i3(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:,:) :: VarOut
+    
+    INTEGER,DIMENSION(klon_mpi,SIZE(VarIn,2),SIZE(VarIn,3),SIZE(VarIn,4)) :: Var_tmp
+
+    CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+    CALL gather2D_mpi(Var_tmp,VarOut)
+!$OMP END MASTER    
+
+  END SUBROUTINE gather2D_i3
+
+
+!!!!! --> Les reels
+
+  SUBROUTINE gather2D_r(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+    REAL,DIMENSION(klon_mpi) :: Var_tmp
+
+    CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+    CALL gather2D_mpi(Var_tmp,VarOut)
+!$OMP END MASTER    
+
+  END SUBROUTINE gather2D_r
+  
+
+  SUBROUTINE gather2D_r1(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    REAL,DIMENSION(klon_mpi,SIZE(VarIn,2)) :: Var_tmp
+
+    CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+    CALL gather2D_mpi(Var_tmp,VarOut)
+!$OMP END MASTER    
+
+  END SUBROUTINE gather2D_r1
+
+  
+  SUBROUTINE gather2D_r2(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+    REAL,DIMENSION(klon_mpi,SIZE(VarIn,2),SIZE(VarIn,3)) :: Var_tmp
+
+    CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+    CALL gather2D_mpi(Var_tmp,VarOut)
+!$OMP END MASTER    
+
+  END SUBROUTINE gather2D_r2
+
+
+  SUBROUTINE gather2D_r3(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:,:,:) :: VarOut
+    
+    REAL,DIMENSION(klon_mpi,SIZE(VarIn,2),SIZE(VarIn,3),SIZE(VarIn,4)) :: Var_tmp
+
+    CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+    CALL gather2D_mpi(Var_tmp,VarOut)
+!$OMP END MASTER    
+
+  END SUBROUTINE gather2D_r3
+  
+
+!!!!! --> Les booleens
+
+  SUBROUTINE gather2D_l(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+    LOGICAL,DIMENSION(klon_mpi) :: Var_tmp
+
+    CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+    CALL gather2D_mpi(Var_tmp,VarOut)
+!$OMP END MASTER    
+
+  END SUBROUTINE gather2D_l
+  
+
+  SUBROUTINE gather2D_l1(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    LOGICAL,DIMENSION(klon_mpi,SIZE(VarIn,2)) :: Var_tmp
+
+    CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+    CALL gather2D_mpi(Var_tmp,VarOut)
+!$OMP END MASTER    
+
+  END SUBROUTINE gather2D_l1
+
+  
+  SUBROUTINE gather2D_l2(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+    LOGICAL,DIMENSION(klon_mpi,SIZE(VarIn,2),SIZE(VarIn,3)) :: Var_tmp
+
+    CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+    CALL gather2D_mpi(Var_tmp,VarOut)
+!$OMP END MASTER    
+
+  END SUBROUTINE gather2D_l2
+
+
+  SUBROUTINE gather2D_l3(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:,:) :: VarOut
+    
+    LOGICAL,DIMENSION(klon_mpi,SIZE(VarIn,2),SIZE(VarIn,3),SIZE(VarIn,4)) :: Var_tmp
+
+    CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+    CALL gather2D_mpi(Var_tmp,VarOut)
+!$OMP END MASTER    
+
+  END SUBROUTINE gather2D_l3
+  
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! Definition des reduce_sum   --> 4D   !!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! Les entiers
+
+  SUBROUTINE reduce_sum_i(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN)  :: VarIn
+    INTEGER,INTENT(OUT) :: VarOut
+    
+    INTEGER             :: Var_tmp
+           
+    CALL reduce_sum_omp(VarIn,Var_tmp)
+!$OMP MASTER      
+    CALL reduce_sum_mpi(Var_tmp,VarOut)
+!$OMP END MASTER
+  
+  END SUBROUTINE reduce_sum_i  
+
+
+  SUBROUTINE reduce_sum_i1(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:)  :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut
+    
+    INTEGER,DIMENSION(SIZE(VarIn))   :: Var_tmp
+           
+    CALL reduce_sum_omp(VarIn,Var_tmp)
+!$OMP MASTER      
+    CALL reduce_sum_mpi(Var_tmp,VarOut)
+!$OMP END MASTER
+  
+  END SUBROUTINE reduce_sum_i1  
+
+
+  SUBROUTINE reduce_sum_i2(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:)  :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+    INTEGER,DIMENSION(SIZE(VarIn,1),SIZE(VarIn,2)) :: Var_tmp
+           
+    CALL reduce_sum_omp(VarIn,Var_tmp)
+!$OMP MASTER      
+    CALL reduce_sum_mpi(Var_tmp,VarOut)
+!$OMP END MASTER
+  
+  END SUBROUTINE reduce_sum_i2  
+  
+
+  SUBROUTINE reduce_sum_i3(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:)  :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    INTEGER,DIMENSION(SIZE(VarIn,1),SIZE(VarIn,2),SIZE(VarIn,3))  :: Var_tmp
+           
+    CALL reduce_sum_omp(VarIn,Var_tmp)
+!$OMP MASTER      
+    CALL reduce_sum_mpi(Var_tmp,VarOut)
+!$OMP END MASTER
+  
+  END SUBROUTINE reduce_sum_i3  
+
+
+  SUBROUTINE reduce_sum_i4(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:,:)  :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+    INTEGER,DIMENSION(SIZE(VarIn,1),SIZE(VarIn,2),SIZE(VarIn,3),SIZE(VarIn,4))  :: Var_tmp
+           
+    CALL reduce_sum_omp(VarIn,Var_tmp)
+!$OMP MASTER      
+    CALL reduce_sum_mpi(Var_tmp,VarOut)
+!$OMP END MASTER
+  
+  END SUBROUTINE reduce_sum_i4  
+
+
+! Les reels
+
+  SUBROUTINE reduce_sum_r(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN)  :: VarIn
+    REAL,INTENT(OUT) :: VarOut
+    
+    REAL             :: Var_tmp
+           
+    CALL reduce_sum_omp(VarIn,Var_tmp)
+!$OMP MASTER      
+    CALL reduce_sum_mpi(Var_tmp,VarOut)
+!$OMP END MASTER
+  
+  END SUBROUTINE reduce_sum_r  
+
+
+  SUBROUTINE reduce_sum_r1(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:)  :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:) :: VarOut
+    
+    REAL,DIMENSION(SIZE(VarIn))   :: Var_tmp
+           
+    CALL reduce_sum_omp(VarIn,Var_tmp)
+!$OMP MASTER      
+    CALL reduce_sum_mpi(Var_tmp,VarOut)
+!$OMP END MASTER
+  
+  END SUBROUTINE reduce_sum_r1  
+
+
+  SUBROUTINE reduce_sum_r2(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:)  :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+    REAL,DIMENSION(SIZE(VarIn,1),SIZE(VarIn,2)) :: Var_tmp
+           
+    CALL reduce_sum_omp(VarIn,Var_tmp)
+!$OMP MASTER      
+    CALL reduce_sum_mpi(Var_tmp,VarOut)
+!$OMP END MASTER
+  
+  END SUBROUTINE reduce_sum_r2  
+  
+
+  SUBROUTINE reduce_sum_r3(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:)  :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    REAL,DIMENSION(SIZE(VarIn,1),SIZE(VarIn,2),SIZE(VarIn,3))  :: Var_tmp
+           
+    CALL reduce_sum_omp(VarIn,Var_tmp)
+!$OMP MASTER      
+    CALL reduce_sum_mpi(Var_tmp,VarOut)
+!$OMP END MASTER
+  
+  END SUBROUTINE reduce_sum_r3  
+
+
+  SUBROUTINE reduce_sum_r4(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:,:)  :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+    REAL,DIMENSION(SIZE(VarIn,1),SIZE(VarIn,2),SIZE(VarIn,3),SIZE(VarIn,4))  :: Var_tmp
+           
+    CALL reduce_sum_omp(VarIn,Var_tmp)
+!$OMP MASTER      
+    CALL reduce_sum_mpi(Var_tmp,VarOut)
+!$OMP END MASTER
+  
+  END SUBROUTINE reduce_sum_r4  
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! Definition des reduce_min   --> 4D   !!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! Les entiers
+
+  SUBROUTINE reduce_min_i(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN)  :: VarIn
+    INTEGER,INTENT(OUT) :: VarOut
+    
+    INTEGER             :: Var_tmp
+           
+    CALL reduce_min_omp(VarIn,Var_tmp)
+!$OMP MASTER      
+    CALL reduce_min_mpi(Var_tmp,VarOut)
+!$OMP END MASTER
+  
+  END SUBROUTINE reduce_min_i  
+
+
+  SUBROUTINE reduce_min_i1(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:)  :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut
+    
+    INTEGER,DIMENSION(SIZE(VarIn))   :: Var_tmp
+           
+    CALL reduce_min_omp(VarIn,Var_tmp)
+!$OMP MASTER      
+    CALL reduce_min_mpi(Var_tmp,VarOut)
+!$OMP END MASTER
+  
+  END SUBROUTINE reduce_min_i1  
+
+
+  SUBROUTINE reduce_min_i2(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:)  :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+    INTEGER,DIMENSION(SIZE(VarIn,1),SIZE(VarIn,2)) :: Var_tmp
+           
+    CALL reduce_min_omp(VarIn,Var_tmp)
+!$OMP MASTER      
+    CALL reduce_min_mpi(Var_tmp,VarOut)
+!$OMP END MASTER
+  
+  END SUBROUTINE reduce_min_i2  
+  
+
+  SUBROUTINE reduce_min_i3(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:)  :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    INTEGER,DIMENSION(SIZE(VarIn,1),SIZE(VarIn,2),SIZE(VarIn,3))  :: Var_tmp
+           
+    CALL reduce_min_omp(VarIn,Var_tmp)
+!$OMP MASTER      
+    CALL reduce_min_mpi(Var_tmp,VarOut)
+!$OMP END MASTER
+  
+  END SUBROUTINE reduce_min_i3  
+
+
+  SUBROUTINE reduce_min_i4(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:,:)  :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+    INTEGER,DIMENSION(SIZE(VarIn,1),SIZE(VarIn,2),SIZE(VarIn,3),SIZE(VarIn,4))  :: Var_tmp
+           
+    CALL reduce_min_omp(VarIn,Var_tmp)
+!$OMP MASTER      
+    CALL reduce_min_mpi(Var_tmp,VarOut)
+!$OMP END MASTER
+  
+  END SUBROUTINE reduce_min_i4  
+
+
+! Les reels
+
+  SUBROUTINE reduce_min_r(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN)  :: VarIn
+    REAL,INTENT(OUT) :: VarOut
+    
+    REAL             :: Var_tmp
+           
+    CALL reduce_min_omp(VarIn,Var_tmp)
+!$OMP MASTER      
+    CALL reduce_min_mpi(Var_tmp,VarOut)
+!$OMP END MASTER
+  
+  END SUBROUTINE reduce_min_r  
+
+
+  SUBROUTINE reduce_min_r1(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:)  :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:) :: VarOut
+    
+    REAL,DIMENSION(SIZE(VarIn))   :: Var_tmp
+           
+    CALL reduce_min_omp(VarIn,Var_tmp)
+!$OMP MASTER      
+    CALL reduce_min_mpi(Var_tmp,VarOut)
+!$OMP END MASTER
+  
+  END SUBROUTINE reduce_min_r1  
+
+
+  SUBROUTINE reduce_min_r2(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:)  :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+    REAL,DIMENSION(SIZE(VarIn,1),SIZE(VarIn,2)) :: Var_tmp
+           
+    CALL reduce_min_omp(VarIn,Var_tmp)
+!$OMP MASTER      
+    CALL reduce_min_mpi(Var_tmp,VarOut)
+!$OMP END MASTER
+  
+  END SUBROUTINE reduce_min_r2  
+  
+
+  SUBROUTINE reduce_min_r3(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:)  :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    REAL,DIMENSION(SIZE(VarIn,1),SIZE(VarIn,2),SIZE(VarIn,3))  :: Var_tmp
+           
+    CALL reduce_min_omp(VarIn,Var_tmp)
+!$OMP MASTER      
+    CALL reduce_min_mpi(Var_tmp,VarOut)
+!$OMP END MASTER
+  
+  END SUBROUTINE reduce_min_r3  
+
+
+  SUBROUTINE reduce_min_r4(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:,:)  :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+    REAL,DIMENSION(SIZE(VarIn,1),SIZE(VarIn,2),SIZE(VarIn,3),SIZE(VarIn,4))  :: Var_tmp
+           
+    CALL reduce_min_omp(VarIn,Var_tmp)
+!$OMP MASTER      
+    CALL reduce_min_mpi(Var_tmp,VarOut)
+!$OMP END MASTER
+  
+  END SUBROUTINE reduce_min_r4  
+
+
+   
+END MODULE mod_phys_lmdz_transfert_para
+
Index: DZ6/trunk/libf/phy_common/physics_distribution_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phy_common/physics_distribution_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,88 +1,0 @@
-!
-!$Id$
-!
-MODULE physics_distribution_mod
-
-
-CONTAINS
-
-  SUBROUTINE init_physics_distribution(grid_type, nvertex, &
-                                       nbp, nbp_lon, nbp_lat, nbp_lev, &
-                                       communicator)
-  USE mod_phys_lmdz_para, ONLY: init_phys_lmdz_para, klon_omp
-  USE mod_grid_phy_lmdz, ONLY: init_grid_phy_lmdz
-  USE dimphy, ONLY : Init_dimphy
-  USE infotrac_phy, ONLY : type_trac
-  USE lmdz_reprobus_wrappers, ONLY : Init_chem_rep_phys
-  USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_INCA, CPPKEY_REPROBUS
-
-  IMPLICIT NONE
-    INTEGER,INTENT(IN) :: grid_type 
-    INTEGER,INTENT(IN) :: nvertex 
-    INTEGER,INTENT(IN) :: nbp           
-    INTEGER,INTENT(IN) :: nbp_lon
-    INTEGER,INTENT(IN) :: nbp_lat
-    INTEGER,INTENT(IN) :: nbp_lev
-    INTEGER,INTENT(IN) :: communicator
-
-
-    CALL init_grid_phy_lmdz(grid_type,nvertex, nbp_lon,nbp_lat,nbp_lev)
-    CALL init_phys_lmdz_para(nbp,nbp_lon, nbp_lat,nbp_lev, grid_type,nvertex, communicator)
-!$OMP PARALLEL
-    CALL init_dimphy(klon_omp,nbp_lev)
-
-IF (CPPKEY_INCA) THEN
-       CALL Init_inca_dim(klon_omp,nbp_lev)
-END IF
-
-IF (CPPKEY_REPROBUS) THEN
-! Initialization of Reprobus
-    IF (type_trac == 'repr') CALL Init_chem_rep_phys(klon_omp,nbp_lev)
-END IF
-
-!$OMP END PARALLEL
-
-  END SUBROUTINE init_physics_distribution  
-
-!SUBROUTINE Init_Phys_lmdz(iim,jjp1,llm,nb_proc,distrib)
-!  USE mod_phys_lmdz_para, ONLY: Init_phys_lmdz_para!, klon_omp
-!  USE mod_grid_phy_lmdz, ONLY: Init_grid_phy_lmdz!, nbp_lev
-!  USE dimphy, ONLY : Init_dimphy
-!  USE infotrac_phy, ONLY : type_trac
-!#ifdef REPROBUS
-!  USE lmdz_reprobus_wrappers, ONLY : Init_chem_rep_phys
-!#endif
-
-!  IMPLICIT NONE
-  
-!    INTEGER,INTENT(in) :: iim
-!    INTEGER,INTENT(in) :: jjp1
-!    INTEGER,INTENT(in) :: llm
-!    INTEGER,INTENT(in) :: nb_proc
-!    INTEGER,INTENT(in) :: distrib(0:nb_proc-1)
-
-
-!    CALL Init_grid_phy_lmdz(iim,jjp1,llm)
-!    CALL Init_phys_lmdz_para(iim,jjp1,nb_proc,distrib)
-!!$OMP PARALLEL
-!    CALL Init_dimphy(klon_omp,nbp_lev)
-!
-!#ifdef REPROBUS
-!! Initialization of Reprobus
-!    IF (type_trac == 'repr') CALL Init_chem_rep_phys(klon_omp,nbp_lev)
-!    END IF
-!#endif
-!
-!!$OMP END PARALLEL
- 
-!END SUBROUTINE Init_Phys_lmdz  
-
-
-
-
-
-
-
-
-END MODULE physics_distribution_mod
-
Index: /LMDZ6/trunk/libf/phy_common/physics_distribution_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phy_common/physics_distribution_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phy_common/physics_distribution_mod.f90	(revision 5268)
@@ -0,0 +1,88 @@
+!
+!$Id$
+!
+MODULE physics_distribution_mod
+
+
+CONTAINS
+
+  SUBROUTINE init_physics_distribution(grid_type, nvertex, &
+                                       nbp, nbp_lon, nbp_lat, nbp_lev, &
+                                       communicator)
+  USE mod_phys_lmdz_para, ONLY: init_phys_lmdz_para, klon_omp
+  USE mod_grid_phy_lmdz, ONLY: init_grid_phy_lmdz
+  USE dimphy, ONLY : Init_dimphy
+  USE infotrac_phy, ONLY : type_trac
+  USE lmdz_reprobus_wrappers, ONLY : Init_chem_rep_phys
+  USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_INCA, CPPKEY_REPROBUS
+
+  IMPLICIT NONE
+    INTEGER,INTENT(IN) :: grid_type 
+    INTEGER,INTENT(IN) :: nvertex 
+    INTEGER,INTENT(IN) :: nbp           
+    INTEGER,INTENT(IN) :: nbp_lon
+    INTEGER,INTENT(IN) :: nbp_lat
+    INTEGER,INTENT(IN) :: nbp_lev
+    INTEGER,INTENT(IN) :: communicator
+
+
+    CALL init_grid_phy_lmdz(grid_type,nvertex, nbp_lon,nbp_lat,nbp_lev)
+    CALL init_phys_lmdz_para(nbp,nbp_lon, nbp_lat,nbp_lev, grid_type,nvertex, communicator)
+!$OMP PARALLEL
+    CALL init_dimphy(klon_omp,nbp_lev)
+
+IF (CPPKEY_INCA) THEN
+       CALL Init_inca_dim(klon_omp,nbp_lev)
+END IF
+
+IF (CPPKEY_REPROBUS) THEN
+! Initialization of Reprobus
+    IF (type_trac == 'repr') CALL Init_chem_rep_phys(klon_omp,nbp_lev)
+END IF
+
+!$OMP END PARALLEL
+
+  END SUBROUTINE init_physics_distribution  
+
+!SUBROUTINE Init_Phys_lmdz(iim,jjp1,llm,nb_proc,distrib)
+!  USE mod_phys_lmdz_para, ONLY: Init_phys_lmdz_para!, klon_omp
+!  USE mod_grid_phy_lmdz, ONLY: Init_grid_phy_lmdz!, nbp_lev
+!  USE dimphy, ONLY : Init_dimphy
+!  USE infotrac_phy, ONLY : type_trac
+!#ifdef REPROBUS
+!  USE lmdz_reprobus_wrappers, ONLY : Init_chem_rep_phys
+!#endif
+
+!  IMPLICIT NONE
+  
+!    INTEGER,INTENT(in) :: iim
+!    INTEGER,INTENT(in) :: jjp1
+!    INTEGER,INTENT(in) :: llm
+!    INTEGER,INTENT(in) :: nb_proc
+!    INTEGER,INTENT(in) :: distrib(0:nb_proc-1)
+
+
+!    CALL Init_grid_phy_lmdz(iim,jjp1,llm)
+!    CALL Init_phys_lmdz_para(iim,jjp1,nb_proc,distrib)
+!!$OMP PARALLEL
+!    CALL Init_dimphy(klon_omp,nbp_lev)
+!
+!#ifdef REPROBUS
+!! Initialization of Reprobus
+!    IF (type_trac == 'repr') CALL Init_chem_rep_phys(klon_omp,nbp_lev)
+!    END IF
+!#endif
+!
+!!$OMP END PARALLEL
+ 
+!END SUBROUTINE Init_Phys_lmdz  
+
+
+
+
+
+
+
+
+END MODULE physics_distribution_mod
+
Index: DZ6/trunk/libf/phy_common/print_control_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phy_common/print_control_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,62 +1,0 @@
-! $Id: $
-MODULE print_control_mod
-
-  INTEGER,SAVE :: lunout ! default output file identifier (6==screen)
-  INTEGER,SAVE :: prt_level ! debug output level
-  LOGICAL,SAVE :: debug ! flag to specify if in "debug mode"
-  LOGICAL,SAVE :: alert_first_call = .TRUE. ! for printing alerts on first call to routine only           
-  LOGICAL,SAVE :: call_alert ! (combination of is_master and alert_first_call for easier use     
-!$OMP THREADPRIVATE(lunout,prt_level,debug, alert_first_call, call_alert)
-
-  ! NB: Module variable Initializations done by set_print_control
-  !     routine from init_print_control_mod to avoid circular
-  !     module dependencies
-
-CONTAINS
-
-  SUBROUTINE set_print_control(lunout_,prt_level_,debug_)
-  IMPLICIT NONE
-    INTEGER, INTENT(IN) :: lunout_
-    INTEGER, INTENT(IN) :: prt_level_
-    LOGICAL, INTENT(IN) :: debug_
-      
-    lunout = lunout_
-    prt_level = prt_level_
-    debug = debug_
-    
-  END SUBROUTINE set_print_control
-
-  SUBROUTINE prt_alerte(message, modname, niv_alerte)
-    ! Function to print different values of alarms when first encountered
-    ! Meant for informative purposee
-    IMPLICIT NONE
-    ! Arguments:
-    ! message: message to print out
-    ! modname: module/routine name
-    ! niv_alerte: alert level (0/1/2)
-    CHARACTER(LEN=*), INTENT(IN) :: modname
-    CHARACTER(LEN=*) :: message
-    INTEGER :: niv_alerte
-    ! local variables
-    CHARACTER(LEN=7), DIMENSION(0:2) :: alarm_color = (/ 'VERTE  ','ORANGE ','ROUGE  ' /)
-    CHARACTER(LEN=7) :: alarm_couleur
-    INTEGER :: alarm_file=15 ! in case we want/need to print out the special alarms in a separate file     
-
-    IF ( alert_first_call) then
-       IF ( alarm_file .ne. lunout ) THEN
-          OPEN(unit = alarm_file, file = "ALERTES.txt")
-       ENDIF
-    ENDIF
-
-    alarm_couleur = alarm_color(niv_alerte)
-    IF (niv_alerte < 0 .OR. niv_alerte > 3) then
-       message = 'NIVEAU ALERTE INVALIDE  '//message
-       alarm_couleur='NOIRE  '
-    ENDIF
-
-    WRITE(alarm_file, *)' ALERTE ',alarm_couleur, trim(modname),  trim(message)
-    
-  END SUBROUTINE prt_alerte
-
-  
-END MODULE print_control_mod
Index: /LMDZ6/trunk/libf/phy_common/print_control_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phy_common/print_control_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phy_common/print_control_mod.f90	(revision 5268)
@@ -0,0 +1,62 @@
+! $Id: $
+MODULE print_control_mod
+
+  INTEGER,SAVE :: lunout ! default output file identifier (6==screen)
+  INTEGER,SAVE :: prt_level ! debug output level
+  LOGICAL,SAVE :: debug ! flag to specify if in "debug mode"
+  LOGICAL,SAVE :: alert_first_call = .TRUE. ! for printing alerts on first call to routine only           
+  LOGICAL,SAVE :: call_alert ! (combination of is_master and alert_first_call for easier use     
+!$OMP THREADPRIVATE(lunout,prt_level,debug, alert_first_call, call_alert)
+
+  ! NB: Module variable Initializations done by set_print_control
+  !     routine from init_print_control_mod to avoid circular
+  !     module dependencies
+
+CONTAINS
+
+  SUBROUTINE set_print_control(lunout_,prt_level_,debug_)
+  IMPLICIT NONE
+    INTEGER, INTENT(IN) :: lunout_
+    INTEGER, INTENT(IN) :: prt_level_
+    LOGICAL, INTENT(IN) :: debug_
+      
+    lunout = lunout_
+    prt_level = prt_level_
+    debug = debug_
+    
+  END SUBROUTINE set_print_control
+
+  SUBROUTINE prt_alerte(message, modname, niv_alerte)
+    ! Function to print different values of alarms when first encountered
+    ! Meant for informative purposee
+    IMPLICIT NONE
+    ! Arguments:
+    ! message: message to print out
+    ! modname: module/routine name
+    ! niv_alerte: alert level (0/1/2)
+    CHARACTER(LEN=*), INTENT(IN) :: modname
+    CHARACTER(LEN=*) :: message
+    INTEGER :: niv_alerte
+    ! local variables
+    CHARACTER(LEN=7), DIMENSION(0:2) :: alarm_color = (/ 'VERTE  ','ORANGE ','ROUGE  ' /)
+    CHARACTER(LEN=7) :: alarm_couleur
+    INTEGER :: alarm_file=15 ! in case we want/need to print out the special alarms in a separate file     
+
+    IF ( alert_first_call) then
+       IF ( alarm_file .ne. lunout ) THEN
+          OPEN(unit = alarm_file, file = "ALERTES.txt")
+       ENDIF
+    ENDIF
+
+    alarm_couleur = alarm_color(niv_alerte)
+    IF (niv_alerte < 0 .OR. niv_alerte > 3) then
+       message = 'NIVEAU ALERTE INVALIDE  '//message
+       alarm_couleur='NOIRE  '
+    ENDIF
+
+    WRITE(alarm_file, *)' ALERTE ',alarm_couleur, trim(modname),  trim(message)
+    
+  END SUBROUTINE prt_alerte
+
+  
+END MODULE print_control_mod
Index: DZ6/trunk/libf/phy_common/regular_lonlat_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phy_common/regular_lonlat_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,55 +1,0 @@
-MODULE regular_lonlat_mod
-
-  ! Store information on the global physics grid
-  ! for a regular (longitude-latitude) grid
-  
-  INTEGER, PARAMETER :: north_east=1     ! boundaries of regular lontlat
-  INTEGER, PARAMETER :: north_west=2     ! boundaries of regular lontlat
-  INTEGER, PARAMETER :: south_west=3     ! boundaries of regular lontlat
-  INTEGER, PARAMETER :: south_east=4     ! boundaries of regular lontlat
-  INTEGER, PARAMETER :: east=2           ! boundaries of regular lontlat
-  INTEGER, PARAMETER :: west=1           ! boundaries of regular lontlat
-  INTEGER, PARAMETER :: north=1          ! boundaries of regular lontlat
-  INTEGER, PARAMETER :: south=2          ! boundaries of regular lontlat
-
-! Global definition, shared by all threads
-! Do not set threadprivate directives
-
-  REAL,SAVE,ALLOCATABLE :: lon_reg(:)      ! value of longitude cell (rad)
-
-  REAL,SAVE,ALLOCATABLE :: lat_reg(:)      ! value of longitude cell (rad)
-
-  REAL,SAVE,ALLOCATABLE :: boundslon_reg(:,:)      ! value of boundaries cell (1=>west, 2=>east)(rad)
-
-  REAL,SAVE,ALLOCATABLE :: boundslat_reg(:,:)      ! value of longitude cell (1=>north, 2=>south)(rad)
-
-
-CONTAINS
-  
-  SUBROUTINE init_regular_lonlat(nbp_lon, nbp_lat, lon_reg_, lat_reg_, boundslon_reg_, boundslat_reg_)
-    IMPLICIT NONE
-    INTEGER,INTENT(IN) :: nbp_lon
-    INTEGER,INTENT(IN) :: nbp_lat
-    REAL,   INTENT(IN) :: lon_reg_(nbp_lon)  
-    REAL,   INTENT(IN) :: lat_reg_(nbp_lat) 
-    REAL,   INTENT(IN) :: boundslon_reg_(nbp_lon,2) 
-    REAL,   INTENT(IN) :: boundslat_reg_(nbp_lat,2)  
-
-    
-    ALLOCATE(lon_reg(nbp_lon))
-    lon_reg(:)=lon_reg_(:)
-
-    ALLOCATE(lat_reg(nbp_lat)) 
-    lat_reg(:)=lat_reg_(:)
-
-    ALLOCATE(boundslon_reg(nbp_lon,2)) 
-    boundslon_reg(:,:)=boundslon_reg_(:,:)
-
-    ALLOCATE(boundslat_reg(nbp_lat,2))  
-    boundslat_reg(:,:)=boundslat_reg_(:,:)
-
-  
-  END SUBROUTINE init_regular_lonlat    
-
-END MODULE regular_lonlat_mod
-
Index: /LMDZ6/trunk/libf/phy_common/regular_lonlat_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phy_common/regular_lonlat_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phy_common/regular_lonlat_mod.f90	(revision 5268)
@@ -0,0 +1,55 @@
+MODULE regular_lonlat_mod
+
+  ! Store information on the global physics grid
+  ! for a regular (longitude-latitude) grid
+  
+  INTEGER, PARAMETER :: north_east=1     ! boundaries of regular lontlat
+  INTEGER, PARAMETER :: north_west=2     ! boundaries of regular lontlat
+  INTEGER, PARAMETER :: south_west=3     ! boundaries of regular lontlat
+  INTEGER, PARAMETER :: south_east=4     ! boundaries of regular lontlat
+  INTEGER, PARAMETER :: east=2           ! boundaries of regular lontlat
+  INTEGER, PARAMETER :: west=1           ! boundaries of regular lontlat
+  INTEGER, PARAMETER :: north=1          ! boundaries of regular lontlat
+  INTEGER, PARAMETER :: south=2          ! boundaries of regular lontlat
+
+! Global definition, shared by all threads
+! Do not set threadprivate directives
+
+  REAL,SAVE,ALLOCATABLE :: lon_reg(:)      ! value of longitude cell (rad)
+
+  REAL,SAVE,ALLOCATABLE :: lat_reg(:)      ! value of longitude cell (rad)
+
+  REAL,SAVE,ALLOCATABLE :: boundslon_reg(:,:)      ! value of boundaries cell (1=>west, 2=>east)(rad)
+
+  REAL,SAVE,ALLOCATABLE :: boundslat_reg(:,:)      ! value of longitude cell (1=>north, 2=>south)(rad)
+
+
+CONTAINS
+  
+  SUBROUTINE init_regular_lonlat(nbp_lon, nbp_lat, lon_reg_, lat_reg_, boundslon_reg_, boundslat_reg_)
+    IMPLICIT NONE
+    INTEGER,INTENT(IN) :: nbp_lon
+    INTEGER,INTENT(IN) :: nbp_lat
+    REAL,   INTENT(IN) :: lon_reg_(nbp_lon)  
+    REAL,   INTENT(IN) :: lat_reg_(nbp_lat) 
+    REAL,   INTENT(IN) :: boundslon_reg_(nbp_lon,2) 
+    REAL,   INTENT(IN) :: boundslat_reg_(nbp_lat,2)  
+
+    
+    ALLOCATE(lon_reg(nbp_lon))
+    lon_reg(:)=lon_reg_(:)
+
+    ALLOCATE(lat_reg(nbp_lat)) 
+    lat_reg(:)=lat_reg_(:)
+
+    ALLOCATE(boundslon_reg(nbp_lon,2)) 
+    boundslon_reg(:,:)=boundslon_reg_(:,:)
+
+    ALLOCATE(boundslat_reg(nbp_lat,2))  
+    boundslat_reg(:,:)=boundslat_reg_(:,:)
+
+  
+  END SUBROUTINE init_regular_lonlat    
+
+END MODULE regular_lonlat_mod
+
Index: DZ6/trunk/libf/phy_common/vertical_layers_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phy_common/vertical_layers_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,61 +1,0 @@
-! $Id: $
-
-MODULE vertical_layers_mod
-
-   REAL,SAVE             :: preff  ! reference surface pressure (Pa)
-   REAL,SAVE             :: scaleheight ! atmospheric reference scale height (km)
-   REAL,SAVE,ALLOCATABLE :: ap(:) ! hybrid (pressure contribution) coordinate 
-                                  ! at layer interfaces (Pa)
-   REAL,SAVE,ALLOCATABLE :: bp(:) ! hybrid (sigma contribution) coordinate 
-                                  ! at layer interfaces (Pa)
-   REAL,SAVE,ALLOCATABLE :: aps(:) ! hybrid (pressure contribution) coordinate 
-                                   ! at mid-layer (Pa)
-   REAL,SAVE,ALLOCATABLE :: bps(:) ! hybrid (sigma contribution) coordinate 
-                                   ! at mid-layer
-   REAL,SAVE,ALLOCATABLE :: presnivs(:) ! reference pressure at mid-layer (Pa),
-                                        ! based on preff, ap and bp
-   REAL,SAVE,ALLOCATABLE :: presinter(:) ! reference pressure at interface (Pa),
-                                        ! based on preff, ap and bp
-   REAL,SAVE,ALLOCATABLE :: pseudoalt(:) ! pseudo-altitude of model layers (km),
-                                         ! based on preff and scaleheight
-   
-!$OMP THREADPRIVATE(preff,scaleheight,ap,bp,aps,bps,presnivs,presinter,pseudoalt)
-
-
-CONTAINS
-
-  SUBROUTINE init_vertical_layers(nlayer,preff_,scaleheight_,ap_,bp_,&
-                                 aps_,bps_,presnivs_, presinter_, pseudoalt_)
-    IMPLICIT NONE
-    INTEGER,INTENT(IN) :: nlayer ! number of atmospheric layers
-    REAL,INTENT(IN)    :: preff_ ! reference surface pressure (Pa)
-    REAL,INTENT(IN)    :: scaleheight_ ! atmospheric scale height (km)
-    REAL,INTENT(IN)    :: ap_(nlayer+1) ! hybrid coordinate at interfaces
-    REAL,INTENT(IN)    :: bp_(nlayer+1) ! hybrid coordinate at interfaces
-    REAL,INTENT(IN)    :: aps_(nlayer) ! hybrid coordinate at mid-layer
-    REAL,INTENT(IN)    :: bps_(nlayer) ! hybrid coordinate at mid-layer
-    REAL,INTENT(IN)    :: presnivs_(nlayer) ! Appproximative pressure of atm. layers (Pa)
-    REAL,INTENT(IN)    :: presinter_(nlayer+1) ! Appproximative pressure of atm. layers (Pa)
-    REAL,INTENT(IN)    :: pseudoalt_(nlayer) ! pseudo-altitude of atm. layers (km)
-  
-    ALLOCATE(ap(nlayer+1))
-    ALLOCATE(bp(nlayer+1))
-    ALLOCATE(aps(nlayer))
-    ALLOCATE(bps(nlayer))
-    ALLOCATE(presnivs(nlayer))
-    ALLOCATE(presinter(nlayer+1))
-    ALLOCATE(pseudoalt(nlayer))
-  
-    preff = preff_
-    scaleheight=scaleheight_
-    ap(:) = ap_(:)
-    bp(:) = bp_(:)
-    aps(:) = aps_(:)
-    bps(:) = bps_(:)
-    presnivs(:) = presnivs_(:)
-    presinter(:) = presinter_(:)
-    pseudoalt(:) = pseudoalt_(:)
-
-  END SUBROUTINE init_vertical_layers
-
-END MODULE vertical_layers_mod
Index: /LMDZ6/trunk/libf/phy_common/vertical_layers_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phy_common/vertical_layers_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phy_common/vertical_layers_mod.f90	(revision 5268)
@@ -0,0 +1,61 @@
+! $Id: $
+
+MODULE vertical_layers_mod
+
+   REAL,SAVE             :: preff  ! reference surface pressure (Pa)
+   REAL,SAVE             :: scaleheight ! atmospheric reference scale height (km)
+   REAL,SAVE,ALLOCATABLE :: ap(:) ! hybrid (pressure contribution) coordinate 
+                                  ! at layer interfaces (Pa)
+   REAL,SAVE,ALLOCATABLE :: bp(:) ! hybrid (sigma contribution) coordinate 
+                                  ! at layer interfaces (Pa)
+   REAL,SAVE,ALLOCATABLE :: aps(:) ! hybrid (pressure contribution) coordinate 
+                                   ! at mid-layer (Pa)
+   REAL,SAVE,ALLOCATABLE :: bps(:) ! hybrid (sigma contribution) coordinate 
+                                   ! at mid-layer
+   REAL,SAVE,ALLOCATABLE :: presnivs(:) ! reference pressure at mid-layer (Pa),
+                                        ! based on preff, ap and bp
+   REAL,SAVE,ALLOCATABLE :: presinter(:) ! reference pressure at interface (Pa),
+                                        ! based on preff, ap and bp
+   REAL,SAVE,ALLOCATABLE :: pseudoalt(:) ! pseudo-altitude of model layers (km),
+                                         ! based on preff and scaleheight
+   
+!$OMP THREADPRIVATE(preff,scaleheight,ap,bp,aps,bps,presnivs,presinter,pseudoalt)
+
+
+CONTAINS
+
+  SUBROUTINE init_vertical_layers(nlayer,preff_,scaleheight_,ap_,bp_,&
+                                 aps_,bps_,presnivs_, presinter_, pseudoalt_)
+    IMPLICIT NONE
+    INTEGER,INTENT(IN) :: nlayer ! number of atmospheric layers
+    REAL,INTENT(IN)    :: preff_ ! reference surface pressure (Pa)
+    REAL,INTENT(IN)    :: scaleheight_ ! atmospheric scale height (km)
+    REAL,INTENT(IN)    :: ap_(nlayer+1) ! hybrid coordinate at interfaces
+    REAL,INTENT(IN)    :: bp_(nlayer+1) ! hybrid coordinate at interfaces
+    REAL,INTENT(IN)    :: aps_(nlayer) ! hybrid coordinate at mid-layer
+    REAL,INTENT(IN)    :: bps_(nlayer) ! hybrid coordinate at mid-layer
+    REAL,INTENT(IN)    :: presnivs_(nlayer) ! Appproximative pressure of atm. layers (Pa)
+    REAL,INTENT(IN)    :: presinter_(nlayer+1) ! Appproximative pressure of atm. layers (Pa)
+    REAL,INTENT(IN)    :: pseudoalt_(nlayer) ! pseudo-altitude of atm. layers (km)
+  
+    ALLOCATE(ap(nlayer+1))
+    ALLOCATE(bp(nlayer+1))
+    ALLOCATE(aps(nlayer))
+    ALLOCATE(bps(nlayer))
+    ALLOCATE(presnivs(nlayer))
+    ALLOCATE(presinter(nlayer+1))
+    ALLOCATE(pseudoalt(nlayer))
+  
+    preff = preff_
+    scaleheight=scaleheight_
+    ap(:) = ap_(:)
+    bp(:) = bp_(:)
+    aps(:) = aps_(:)
+    bps(:) = bps_(:)
+    presnivs(:) = presnivs_(:)
+    presinter(:) = presinter_(:)
+    pseudoalt(:) = pseudoalt_(:)
+
+  END SUBROUTINE init_vertical_layers
+
+END MODULE vertical_layers_mod
Index: DZ6/trunk/libf/phy_common/write_field_phy.F90
===================================================================
--- /LMDZ6/trunk/libf/phy_common/write_field_phy.F90	(revision 5267)
+++ 	(revision )
@@ -1,37 +1,0 @@
-!
-! $Id$
-!
-MODULE write_field_phy
-
-  ! Dump a field on the global (nbp_lon by nbp_lat) physics grid
-  
-  CONTAINS 
- 
-    SUBROUTINE WriteField_phy(name,Field,ll)
-    USE mod_phys_lmdz_para, ONLY: klon_omp, is_mpi_root, &
-                                  Gather
-    USE mod_grid_phy_lmdz, ONLY: nbp_lon, nbp_lat, klon_glo, &
-                                 Grid1Dto2D_glo
-    USE Write_Field, ONLY: WriteField
-    
-    IMPLICIT NONE
-
-    CHARACTER(len=*),INTENT(IN) :: name
-    INTEGER,INTENT(IN) :: ll
-    REAL,INTENT(IN) :: Field(klon_omp,ll)
-
-    real, dimension(klon_glo,ll):: New_Field
-    real, dimension(nbp_lon,nbp_lat,ll):: Field_2d
-
-    CALL Gather(Field,New_Field)
-!$OMP MASTER
-    IF (is_mpi_root) THEN	
-      CALL Grid1Dto2D_glo(New_Field,Field_2D)
-      CALL WriteField(name,Field_2d)
-    ENDIF
-!$OMP END MASTER
-
-  
-   END SUBROUTINE WriteField_phy
- 
- END MODULE write_field_phy
Index: /LMDZ6/trunk/libf/phy_common/write_field_phy.f90
===================================================================
--- /LMDZ6/trunk/libf/phy_common/write_field_phy.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phy_common/write_field_phy.f90	(revision 5268)
@@ -0,0 +1,37 @@
+!
+! $Id$
+!
+MODULE write_field_phy
+
+  ! Dump a field on the global (nbp_lon by nbp_lat) physics grid
+  
+  CONTAINS 
+ 
+    SUBROUTINE WriteField_phy(name,Field,ll)
+    USE mod_phys_lmdz_para, ONLY: klon_omp, is_mpi_root, &
+                                  Gather
+    USE mod_grid_phy_lmdz, ONLY: nbp_lon, nbp_lat, klon_glo, &
+                                 Grid1Dto2D_glo
+    USE Write_Field, ONLY: WriteField
+    
+    IMPLICIT NONE
+
+    CHARACTER(len=*),INTENT(IN) :: name
+    INTEGER,INTENT(IN) :: ll
+    REAL,INTENT(IN) :: Field(klon_omp,ll)
+
+    real, dimension(klon_glo,ll):: New_Field
+    real, dimension(nbp_lon,nbp_lat,ll):: Field_2d
+
+    CALL Gather(Field,New_Field)
+!$OMP MASTER
+    IF (is_mpi_root) THEN	
+      CALL Grid1Dto2D_glo(New_Field,Field_2D)
+      CALL WriteField(name,Field_2d)
+    ENDIF
+!$OMP END MASTER
+
+  
+   END SUBROUTINE WriteField_phy
+ 
+ END MODULE write_field_phy
Index: DZ6/trunk/libf/phydev/comcstphy.F90
===================================================================
--- /LMDZ6/trunk/libf/phydev/comcstphy.F90	(revision 5267)
+++ 	(revision )
@@ -1,8 +1,0 @@
-module comcstphy
-  
-  real :: rradius ! planet radius (m)
-  real :: rr      ! recuced gas constant: R/molar mass of atm
-  real :: rg      ! gravity
-  real :: rcpp    ! specific heat of the atmosphere
-
-end module comcstphy
Index: /LMDZ6/trunk/libf/phydev/comcstphy.f90
===================================================================
--- /LMDZ6/trunk/libf/phydev/comcstphy.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phydev/comcstphy.f90	(revision 5268)
@@ -0,0 +1,8 @@
+module comcstphy
+  
+  real :: rradius ! planet radius (m)
+  real :: rr      ! recuced gas constant: R/molar mass of atm
+  real :: rg      ! gravity
+  real :: rcpp    ! specific heat of the atmosphere
+
+end module comcstphy
Index: DZ6/trunk/libf/phydev/gr_fi_ecrit.F90
===================================================================
--- /LMDZ6/trunk/libf/phydev/gr_fi_ecrit.F90	(revision 5267)
+++ 	(revision )
@@ -1,27 +1,0 @@
-!
-! $Id $
-!
-SUBROUTINE gr_fi_ecrit(nfield,nlon,iim,jjmp1,fi,ecrit)
-  IMPLICIT NONE
-  !
-  ! Transfer a field from the full physics grid
-  ! to a full 2D (lonxlat) grid suitable for outputs
-  !
-  INTEGER,INTENT(IN) :: nfield,nlon,iim,jjmp1
-  REAL,INTENT(IN) :: fi(nlon,nfield)
-  REAL,INTENT(out) :: ecrit(iim*jjmp1,nfield)
-
-  INTEGER :: i, n, ig, jjm
-
-  jjm = jjmp1 - 1
-  DO n = 1, nfield
-     DO i=1,iim
-        ecrit(i,n) = fi(1,n)
-        ecrit(i+jjm*iim,n) = fi(nlon,n)
-     ENDDO
-     DO ig = 1, nlon - 2
-        ecrit(iim+ig,n) = fi(1+ig,n)
-     ENDDO
-  ENDDO
-
-END SUBROUTINE gr_fi_ecrit
Index: /LMDZ6/trunk/libf/phydev/gr_fi_ecrit.f90
===================================================================
--- /LMDZ6/trunk/libf/phydev/gr_fi_ecrit.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phydev/gr_fi_ecrit.f90	(revision 5268)
@@ -0,0 +1,27 @@
+!
+! $Id $
+!
+SUBROUTINE gr_fi_ecrit(nfield,nlon,iim,jjmp1,fi,ecrit)
+  IMPLICIT NONE
+  !
+  ! Transfer a field from the full physics grid
+  ! to a full 2D (lonxlat) grid suitable for outputs
+  !
+  INTEGER,INTENT(IN) :: nfield,nlon,iim,jjmp1
+  REAL,INTENT(IN) :: fi(nlon,nfield)
+  REAL,INTENT(out) :: ecrit(iim*jjmp1,nfield)
+
+  INTEGER :: i, n, ig, jjm
+
+  jjm = jjmp1 - 1
+  DO n = 1, nfield
+     DO i=1,iim
+        ecrit(i,n) = fi(1,n)
+        ecrit(i+jjm*iim,n) = fi(nlon,n)
+     ENDDO
+     DO ig = 1, nlon - 2
+        ecrit(iim+ig,n) = fi(1+ig,n)
+     ENDDO
+  ENDDO
+
+END SUBROUTINE gr_fi_ecrit
Index: DZ6/trunk/libf/phydev/infotrac_phy.F90
===================================================================
--- /LMDZ6/trunk/libf/phydev/infotrac_phy.F90	(revision 5267)
+++ 	(revision )
@@ -1,65 +1,0 @@
-
-! $Id: $
-
-MODULE infotrac_phy
-
-   USE strings_mod, ONLY: maxlen
-!   PUBLIC :: tracers, type_trac                            !--- Full tracers database, tracers type keyword
-!   PUBLIC :: nqtot,   nbtr,   nqo,   nqCO2,   nqtottr      !--- Main dimensions
-   INTEGER,SAVE :: nqtot,   nbtr,   nqo,   nqCO2,   nqtottr      !--- Main dimensions
-   INTEGER,SAVE :: niso,ntiso
-   CHARACTER(LEN=maxlen), SAVE :: type_trac                     !--- Keyword for tracers type(s)
-
-  TYPE :: keys_type                                        !=== TYPE FOR A SET OF KEYS ASSOCIATED TO AN ELEMENT
-    CHARACTER(LEN=maxlen)              :: name             !--- Tracer name
-    CHARACTER(LEN=maxlen), ALLOCATABLE :: key(:)           !--- Keys string list
-    CHARACTER(LEN=maxlen), ALLOCATABLE :: val(:)           !--- Corresponding values string list
-  END TYPE keys_type
-
-  TYPE :: trac_type                                        !=== TYPE FOR A SINGLE TRACER NAMED "name"
-    CHARACTER(LEN=maxlen) :: name        = ''              !--- Name of the tracer
-    CHARACTER(LEN=maxlen) :: gen0Name    = ''              !--- First generation ancestor name
-    CHARACTER(LEN=maxlen) :: parent      = ''              !--- Parent name
-    CHARACTER(LEN=maxlen) :: longName    = ''              !--- Long name (with advection scheme suffix)
-    CHARACTER(LEN=maxlen) :: type        = 'tracer'        !--- Type  (so far: 'tracer' / 'tag')
-    CHARACTER(LEN=maxlen) :: phase       = 'g'             !--- Phase ('g'as / 'l'iquid / 's'olid)
-    CHARACTER(LEN=maxlen) :: component   = ''              !--- Coma-separated list of components (Ex: lmdz,inca)
-    INTEGER               :: iGeneration = -1              !--- Generation number (>=0)
-    INTEGER               :: iqParent    = 0               !--- Parent index
-    INTEGER,  ALLOCATABLE :: iqDescen(:)                   !--- Descendants index (in growing generation order)
-    INTEGER               :: nqDescen    = 0               !--- Number of descendants (all generations)
-    INTEGER               :: nqChildren  = 0               !--- Number of children  (first generation)
-    TYPE(keys_type)       :: keys                          !--- <key>=<val> pairs vector
-    INTEGER               :: iadv        = 10              !--- Advection scheme used
-    LOGICAL               :: isAdvected  = .FALSE.         !--- "true" tracers: iadv > 0.   COUNT(isAdvected )=nqtrue
-    LOGICAL               :: isInPhysics = .TRUE.          !--- "true" tracers: in tr_seri. COUNT(isInPhysics)=nqtottr
-    INTEGER               :: iso_iGroup  = 0               !--- Isotopes group index in isotopes(:)
-    INTEGER               :: iso_iName   = 0               !--- Isotope  name  index in isotopes(iso_iGroup)%trac(:)
-    INTEGER               :: iso_iZone   = 0               !--- Isotope  zone  index in isotopes(iso_iGroup)%zone(:)
-    INTEGER               :: iso_iPhase  = 0               !--- Isotope  phase index in isotopes(iso_iGroup)%phase
-  END TYPE trac_type
-
-   TYPE(trac_type), ALLOCATABLE, TARGET, SAVE ::  tracers(:)
-
-
-!$OMP THREADPRIVATE(nqtot, nbtr, nqo, nqtottr, nqCO2, type_trac)
-!$OMP THREADPRIVATE(niso,ntiso)
-!$OMP THREADPRIVATE(trac_type,tracers)
-
-
-
-
-CONTAINS
-
-SUBROUTINE init_infotrac_phy(nqtot_, type_trac_)
-   IMPLICIT NONE
-   INTEGER,          INTENT(IN) :: nqtot_
-   CHARACTER(LEN=*), INTENT(IN) :: type_trac_
-   CHARACTER(LEN=maxlen) :: modname='init_infotrac_phy'
-
-   nqtot = nqtot_
-   type_trac = type_trac_
-
-  END SUBROUTINE init_infotrac_phy
-
-END MODULE infotrac_phy
Index: /LMDZ6/trunk/libf/phydev/infotrac_phy.f90
===================================================================
--- /LMDZ6/trunk/libf/phydev/infotrac_phy.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phydev/infotrac_phy.f90	(revision 5268)
@@ -0,0 +1,65 @@
+
+! $Id: $
+
+MODULE infotrac_phy
+
+   USE strings_mod, ONLY: maxlen
+!   PUBLIC :: tracers, type_trac                            !--- Full tracers database, tracers type keyword
+!   PUBLIC :: nqtot,   nbtr,   nqo,   nqCO2,   nqtottr      !--- Main dimensions
+   INTEGER,SAVE :: nqtot,   nbtr,   nqo,   nqCO2,   nqtottr      !--- Main dimensions
+   INTEGER,SAVE :: niso,ntiso
+   CHARACTER(LEN=maxlen), SAVE :: type_trac                     !--- Keyword for tracers type(s)
+
+  TYPE :: keys_type                                        !=== TYPE FOR A SET OF KEYS ASSOCIATED TO AN ELEMENT
+    CHARACTER(LEN=maxlen)              :: name             !--- Tracer name
+    CHARACTER(LEN=maxlen), ALLOCATABLE :: key(:)           !--- Keys string list
+    CHARACTER(LEN=maxlen), ALLOCATABLE :: val(:)           !--- Corresponding values string list
+  END TYPE keys_type
+
+  TYPE :: trac_type                                        !=== TYPE FOR A SINGLE TRACER NAMED "name"
+    CHARACTER(LEN=maxlen) :: name        = ''              !--- Name of the tracer
+    CHARACTER(LEN=maxlen) :: gen0Name    = ''              !--- First generation ancestor name
+    CHARACTER(LEN=maxlen) :: parent      = ''              !--- Parent name
+    CHARACTER(LEN=maxlen) :: longName    = ''              !--- Long name (with advection scheme suffix)
+    CHARACTER(LEN=maxlen) :: type        = 'tracer'        !--- Type  (so far: 'tracer' / 'tag')
+    CHARACTER(LEN=maxlen) :: phase       = 'g'             !--- Phase ('g'as / 'l'iquid / 's'olid)
+    CHARACTER(LEN=maxlen) :: component   = ''              !--- Coma-separated list of components (Ex: lmdz,inca)
+    INTEGER               :: iGeneration = -1              !--- Generation number (>=0)
+    INTEGER               :: iqParent    = 0               !--- Parent index
+    INTEGER,  ALLOCATABLE :: iqDescen(:)                   !--- Descendants index (in growing generation order)
+    INTEGER               :: nqDescen    = 0               !--- Number of descendants (all generations)
+    INTEGER               :: nqChildren  = 0               !--- Number of children  (first generation)
+    TYPE(keys_type)       :: keys                          !--- <key>=<val> pairs vector
+    INTEGER               :: iadv        = 10              !--- Advection scheme used
+    LOGICAL               :: isAdvected  = .FALSE.         !--- "true" tracers: iadv > 0.   COUNT(isAdvected )=nqtrue
+    LOGICAL               :: isInPhysics = .TRUE.          !--- "true" tracers: in tr_seri. COUNT(isInPhysics)=nqtottr
+    INTEGER               :: iso_iGroup  = 0               !--- Isotopes group index in isotopes(:)
+    INTEGER               :: iso_iName   = 0               !--- Isotope  name  index in isotopes(iso_iGroup)%trac(:)
+    INTEGER               :: iso_iZone   = 0               !--- Isotope  zone  index in isotopes(iso_iGroup)%zone(:)
+    INTEGER               :: iso_iPhase  = 0               !--- Isotope  phase index in isotopes(iso_iGroup)%phase
+  END TYPE trac_type
+
+   TYPE(trac_type), ALLOCATABLE, TARGET, SAVE ::  tracers(:)
+
+
+!$OMP THREADPRIVATE(nqtot, nbtr, nqo, nqtottr, nqCO2, type_trac)
+!$OMP THREADPRIVATE(niso,ntiso)
+!$OMP THREADPRIVATE(trac_type,tracers)
+
+
+
+
+CONTAINS
+
+SUBROUTINE init_infotrac_phy(nqtot_, type_trac_)
+   IMPLICIT NONE
+   INTEGER,          INTENT(IN) :: nqtot_
+   CHARACTER(LEN=*), INTENT(IN) :: type_trac_
+   CHARACTER(LEN=maxlen) :: modname='init_infotrac_phy'
+
+   nqtot = nqtot_
+   type_trac = type_trac_
+
+  END SUBROUTINE init_infotrac_phy
+
+END MODULE infotrac_phy
Index: DZ6/trunk/libf/phydev/inifis_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phydev/inifis_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,28 +1,0 @@
-! $Id$
-MODULE inifis_mod
-
-CONTAINS
-
-  SUBROUTINE inifis(prad, pg, pr, pcpp)
-  ! Initialize some physical constants and settings
-  USE init_print_control_mod, ONLY: init_print_control
-  USE comcstphy, ONLY: rradius, & ! planet radius (m)
-                       rr, & ! recuced gas constant: R/molar mass of atm
-                       rg, & ! gravity
-                       rcpp  ! specific heat of the atmosphere
-  IMPLICIT NONE
-
-  REAL,INTENT(IN) :: prad, pg, pr, pcpp
-
-  ! Initialize flags lunout, prt_level, debug
-  CALL init_print_control
-
-  ! copy some fundamental parameters to physics
-  rradius=prad
-  rg=pg
-  rr=pr
-  rcpp=pcpp
-
-  END SUBROUTINE inifis
-  
-END MODULE inifis_mod
Index: /LMDZ6/trunk/libf/phydev/inifis_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phydev/inifis_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phydev/inifis_mod.f90	(revision 5268)
@@ -0,0 +1,28 @@
+! $Id$
+MODULE inifis_mod
+
+CONTAINS
+
+  SUBROUTINE inifis(prad, pg, pr, pcpp)
+  ! Initialize some physical constants and settings
+  USE init_print_control_mod, ONLY: init_print_control
+  USE comcstphy, ONLY: rradius, & ! planet radius (m)
+                       rr, & ! recuced gas constant: R/molar mass of atm
+                       rg, & ! gravity
+                       rcpp  ! specific heat of the atmosphere
+  IMPLICIT NONE
+
+  REAL,INTENT(IN) :: prad, pg, pr, pcpp
+
+  ! Initialize flags lunout, prt_level, debug
+  CALL init_print_control
+
+  ! copy some fundamental parameters to physics
+  rradius=prad
+  rg=pg
+  rr=pr
+  rcpp=pcpp
+
+  END SUBROUTINE inifis
+  
+END MODULE inifis_mod
Index: DZ6/trunk/libf/phydev/phyaqua_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phydev/phyaqua_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,35 +1,0 @@
-!
-! $Id: $
-!
-MODULE phyaqua_mod
-
-  IMPLICIT NONE
-
-CONTAINS
-
-  SUBROUTINE iniaqua(nlon, iflag_phys)
-
-  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-  !  Create an initial state (startphy.nc) for the physics
-  !  Usefull for idealised cases (e.g. aquaplanets or testcases)
-  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-  USE phys_state_var_mod, ONLY: phys_state_var_init
-  USE mod_phys_lmdz_para, ONLY: klon_omp
-  IMPLICIT NONE
-      
-  INTEGER,INTENT(IN) :: nlon,iflag_phys
-
-  CALL phys_state_var_init()
-
-
-  ! Here you could create an initial condition for the physics
-  ! ...
-  ! ... fill in the fields...
-  ! ...
-  ! ... and create a "startphy.nc" file
-      CALL phyredem ("startphy.nc")
-
-  END SUBROUTINE iniaqua
-
-END MODULE phyaqua_mod
Index: /LMDZ6/trunk/libf/phydev/phyaqua_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phydev/phyaqua_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phydev/phyaqua_mod.f90	(revision 5268)
@@ -0,0 +1,35 @@
+!
+! $Id: $
+!
+MODULE phyaqua_mod
+
+  IMPLICIT NONE
+
+CONTAINS
+
+  SUBROUTINE iniaqua(nlon, iflag_phys)
+
+  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+  !  Create an initial state (startphy.nc) for the physics
+  !  Usefull for idealised cases (e.g. aquaplanets or testcases)
+  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+  USE phys_state_var_mod, ONLY: phys_state_var_init
+  USE mod_phys_lmdz_para, ONLY: klon_omp
+  IMPLICIT NONE
+      
+  INTEGER,INTENT(IN) :: nlon,iflag_phys
+
+  CALL phys_state_var_init()
+
+
+  ! Here you could create an initial condition for the physics
+  ! ...
+  ! ... fill in the fields...
+  ! ...
+  ! ... and create a "startphy.nc" file
+      CALL phyredem ("startphy.nc")
+
+  END SUBROUTINE iniaqua
+
+END MODULE phyaqua_mod
Index: DZ6/trunk/libf/phydev/phyetat0.F90
===================================================================
--- /LMDZ6/trunk/libf/phydev/phyetat0.F90	(revision 5267)
+++ 	(revision )
@@ -1,65 +1,0 @@
-!
-! $Id $
-!
-SUBROUTINE phyetat0(fichnom)
-! Load initial state for the physics
-! and do some resulting initializations
-
-  USE dimphy, only: klon
-  USE iostart, ONLY : open_startphy,get_field,close_startphy
-  USE iophy, ONLY : init_iophy_new
-  USE geometry_mod, ONLY : longitude_deg, latitude_deg
-
-  IMPLICIT NONE
-
-  CHARACTER(len=*),INTENT(in) :: fichnom ! input file name
-
-  REAL :: lon_startphy(klon), lat_startphy(klon)
-  INTEGER :: i
-
-  ! open physics initial state file:
-  CALL open_startphy(fichnom)
-
-  ! read latitudes and make a sanity check (because already known from dyn)
-  CALL get_field("latitude",lat_startphy)
-  DO i=1,klon
-    IF (ABS(lat_startphy(i)-latitude_deg(i))>=1) THEN
-      WRITE(*,*) "phyetat0: Error! Latitude discrepancy wrt startphy file:",&
-                 " i=",i," lat_startphy(i)=",lat_startphy(i),&
-                 " latitude_deg(i)=",latitude_deg(i)
-      ! This is presumably serious enough to abort run
-      CALL abort_physic("phyetat0","discrepancy in latitudes!",1)
-    ENDIF
-    IF (ABS(lat_startphy(i)-latitude_deg(i))>=0.0001) THEN
-      WRITE(*,*) "phyetat0: Warning! Latitude discrepancy wrt startphy file:",&
-                 " i=",i," lat_startphy(i)=",lat_startphy(i),&
-                 " latitude_deg(i)=",latitude_deg(i)
-    ENDIF
-  ENDDO
-
-  ! read longitudes and make a sanity check (because already known from dyn)
-  CALL get_field("longitude",lon_startphy)
-  DO i=1,klon
-    IF (ABS(lon_startphy(i)-longitude_deg(i))>=1) THEN
-      WRITE(*,*) "phyetat0: Error! Longitude discrepancy wrt startphy file:",&
-                 " i=",i," lon_startphy(i)=",lon_startphy(i),&
-                 " longitude_deg(i)=",longitude_deg(i)
-      ! This is presumably serious enough to abort run
-      CALL abort_physic("phyetat0","discrepancy in longitudes!",1)
-    ENDIF
-    IF (ABS(lon_startphy(i)-longitude_deg(i))>=0.0001) THEN
-      WRITE(*,*) "phyetat0: Warning! Longitude discrepancy wrt startphy file:",&
-                 " i=",i," lon_startphy(i)=",lon_startphy(i),&
-                 " longitude_deg(i)=",longitude_deg(i)
-    ENDIF
-  ENDDO
-
-  ! read in other variables here ...
-
-  ! close file
-  CALL close_startphy
-
-  ! do some more initializations
-  CALL init_iophy_new(latitude_deg,longitude_deg)
-
-END SUBROUTINE phyetat0
Index: /LMDZ6/trunk/libf/phydev/phyetat0.f90
===================================================================
--- /LMDZ6/trunk/libf/phydev/phyetat0.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phydev/phyetat0.f90	(revision 5268)
@@ -0,0 +1,65 @@
+!
+! $Id $
+!
+SUBROUTINE phyetat0(fichnom)
+! Load initial state for the physics
+! and do some resulting initializations
+
+  USE dimphy, only: klon
+  USE iostart, ONLY : open_startphy,get_field,close_startphy
+  USE iophy, ONLY : init_iophy_new
+  USE geometry_mod, ONLY : longitude_deg, latitude_deg
+
+  IMPLICIT NONE
+
+  CHARACTER(len=*),INTENT(in) :: fichnom ! input file name
+
+  REAL :: lon_startphy(klon), lat_startphy(klon)
+  INTEGER :: i
+
+  ! open physics initial state file:
+  CALL open_startphy(fichnom)
+
+  ! read latitudes and make a sanity check (because already known from dyn)
+  CALL get_field("latitude",lat_startphy)
+  DO i=1,klon
+    IF (ABS(lat_startphy(i)-latitude_deg(i))>=1) THEN
+      WRITE(*,*) "phyetat0: Error! Latitude discrepancy wrt startphy file:",&
+                 " i=",i," lat_startphy(i)=",lat_startphy(i),&
+                 " latitude_deg(i)=",latitude_deg(i)
+      ! This is presumably serious enough to abort run
+      CALL abort_physic("phyetat0","discrepancy in latitudes!",1)
+    ENDIF
+    IF (ABS(lat_startphy(i)-latitude_deg(i))>=0.0001) THEN
+      WRITE(*,*) "phyetat0: Warning! Latitude discrepancy wrt startphy file:",&
+                 " i=",i," lat_startphy(i)=",lat_startphy(i),&
+                 " latitude_deg(i)=",latitude_deg(i)
+    ENDIF
+  ENDDO
+
+  ! read longitudes and make a sanity check (because already known from dyn)
+  CALL get_field("longitude",lon_startphy)
+  DO i=1,klon
+    IF (ABS(lon_startphy(i)-longitude_deg(i))>=1) THEN
+      WRITE(*,*) "phyetat0: Error! Longitude discrepancy wrt startphy file:",&
+                 " i=",i," lon_startphy(i)=",lon_startphy(i),&
+                 " longitude_deg(i)=",longitude_deg(i)
+      ! This is presumably serious enough to abort run
+      CALL abort_physic("phyetat0","discrepancy in longitudes!",1)
+    ENDIF
+    IF (ABS(lon_startphy(i)-longitude_deg(i))>=0.0001) THEN
+      WRITE(*,*) "phyetat0: Warning! Longitude discrepancy wrt startphy file:",&
+                 " i=",i," lon_startphy(i)=",lon_startphy(i),&
+                 " longitude_deg(i)=",longitude_deg(i)
+    ENDIF
+  ENDDO
+
+  ! read in other variables here ...
+
+  ! close file
+  CALL close_startphy
+
+  ! do some more initializations
+  CALL init_iophy_new(latitude_deg,longitude_deg)
+
+END SUBROUTINE phyetat0
Index: DZ6/trunk/libf/phydev/phyredem.F90
===================================================================
--- /LMDZ6/trunk/libf/phydev/phyredem.F90	(revision 5267)
+++ 	(revision )
@@ -1,45 +1,0 @@
-!
-! $Id: $
-!
-SUBROUTINE phyredem (fichnom)
-
-  USE geometry_mod, ONLY : longitude_deg, latitude_deg
-  USE iostart, ONLY: open_restartphy, close_restartphy, enddef_restartphy, put_field, put_var
-
-
-  IMPLICIT NONE
-
-  CHARACTER(LEN=*),INTENT(IN) :: fichnom
-
-  INTEGER,PARAMETER :: tab_cntrl_len=100
-  REAL :: tab_cntrl(tab_cntrl_len)
-  INTEGER :: pass
-
-  ! open file
-
-  CALL open_restartphy(fichnom)
-
-  ! tab_cntrl() contains run parameters
-
-  tab_cntrl(:)=0.0
-
-  DO pass=1,2   ! pass=1 netcdf definition ; pass=2 netcdf write
-
-    CALL put_var(pass, "controle", "Control parameters", tab_cntrl)
-
-  ! coordinates
-
-    CALL put_field(pass, "longitude", "Longitudes on physics grid", longitude_deg)
-     
-    CALL put_field(pass, "latitude", "Latitudes on physics grid", latitude_deg)
-
-    IF (pass==1) CALL enddef_restartphy
-    IF (pass==2) CALL close_restartphy
-
-  ENDDO
-  ! close file
-
-  CALL close_restartphy
-  !$OMP BARRIER
-
-END SUBROUTINE phyredem
Index: /LMDZ6/trunk/libf/phydev/phyredem.f90
===================================================================
--- /LMDZ6/trunk/libf/phydev/phyredem.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phydev/phyredem.f90	(revision 5268)
@@ -0,0 +1,45 @@
+!
+! $Id: $
+!
+SUBROUTINE phyredem (fichnom)
+
+  USE geometry_mod, ONLY : longitude_deg, latitude_deg
+  USE iostart, ONLY: open_restartphy, close_restartphy, enddef_restartphy, put_field, put_var
+
+
+  IMPLICIT NONE
+
+  CHARACTER(LEN=*),INTENT(IN) :: fichnom
+
+  INTEGER,PARAMETER :: tab_cntrl_len=100
+  REAL :: tab_cntrl(tab_cntrl_len)
+  INTEGER :: pass
+
+  ! open file
+
+  CALL open_restartphy(fichnom)
+
+  ! tab_cntrl() contains run parameters
+
+  tab_cntrl(:)=0.0
+
+  DO pass=1,2   ! pass=1 netcdf definition ; pass=2 netcdf write
+
+    CALL put_var(pass, "controle", "Control parameters", tab_cntrl)
+
+  ! coordinates
+
+    CALL put_field(pass, "longitude", "Longitudes on physics grid", longitude_deg)
+     
+    CALL put_field(pass, "latitude", "Latitudes on physics grid", latitude_deg)
+
+    IF (pass==1) CALL enddef_restartphy
+    IF (pass==2) CALL close_restartphy
+
+  ENDDO
+  ! close file
+
+  CALL close_restartphy
+  !$OMP BARRIER
+
+END SUBROUTINE phyredem
Index: DZ6/trunk/libf/phydev/phys_state_var_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phydev/phys_state_var_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,37 +1,0 @@
-!
-! $Id:  $
-!
-MODULE phys_state_var_mod
-!======================================================================
-! Variables saved in startphy.nc
-!======================================================================
-
-!USE dimphy, only : klon
- 
-
-!REAL, ALLOCATABLE, SAVE :: rlat(:), rlon(:)
-!!$OMP THREADPRIVATE(rlat,rlon)
-
-CONTAINS
-
-!======================================================================
-  SUBROUTINE phys_state_var_init()
-!  use dimphy, only : klon
-
-!  if (.not.allocated(rlat)) then
-!    ALLOCATE(rlat(klon),rlon(klon))
-!  else
-!    write(*,*) "phys_state_var_init: warning, rlat already allocated"
-!  endif
-  
-  END SUBROUTINE phys_state_var_init
-
-!======================================================================
-  SUBROUTINE phys_state_var_end
-!  use dimphy, only : klon
-
-!  deallocate(rlat,rlon)
-
-  END SUBROUTINE phys_state_var_end
-
-END MODULE phys_state_var_mod
Index: /LMDZ6/trunk/libf/phydev/phys_state_var_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phydev/phys_state_var_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phydev/phys_state_var_mod.f90	(revision 5268)
@@ -0,0 +1,37 @@
+!
+! $Id:  $
+!
+MODULE phys_state_var_mod
+!======================================================================
+! Variables saved in startphy.nc
+!======================================================================
+
+!USE dimphy, only : klon
+ 
+
+!REAL, ALLOCATABLE, SAVE :: rlat(:), rlon(:)
+!!$OMP THREADPRIVATE(rlat,rlon)
+
+CONTAINS
+
+!======================================================================
+  SUBROUTINE phys_state_var_init()
+!  use dimphy, only : klon
+
+!  if (.not.allocated(rlat)) then
+!    ALLOCATE(rlat(klon),rlon(klon))
+!  else
+!    write(*,*) "phys_state_var_init: warning, rlat already allocated"
+!  endif
+  
+  END SUBROUTINE phys_state_var_init
+
+!======================================================================
+  SUBROUTINE phys_state_var_end
+!  use dimphy, only : klon
+
+!  deallocate(rlat,rlon)
+
+  END SUBROUTINE phys_state_var_end
+
+END MODULE phys_state_var_mod
Index: DZ6/trunk/libf/phylmd/Dust/checkmass.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/Dust/checkmass.F90	(revision 5267)
+++ 	(revision )
@@ -1,59 +1,0 @@
-SUBROUTINE checkmass(zq,RNAVOG,mass,zdz,pplay,t_seri,iscm3,comment)
-  USE dimphy
-USE geometry_mod , ONLY:cell_area
-  IMPLICIT NONE
-
-  INCLUDE "YOMCST.h"
-
-! Entrees
-  REAL,DIMENSION(klon,klev), INTENT(IN)   :: zq
-  REAL,DIMENSION(klon,klev), INTENT(IN)   :: zdz
-  REAL,INTENT(IN)                         :: mass
-  REAL,INTENT(IN)                         :: RNAVOG
-  CHARACTER(LEN=*),INTENT(IN)             :: comment
-REAL,DIMENSION(klon,klev) ,INTENT(IN)  :: pplay
-REAL,DIMENSION(klon,klev) ,INTENT(IN) :: t_seri
-LOGICAL :: iscm3
-
-
-! Local  
-!  INTEGER,DIMENSION(klon)     :: jadrs
-  INTEGER                     :: i, k
-  REAL                              :: totmass
-  REAL,DIMENSION(klon)              ::  burden
-  REAL,DIMENSION(klon,klev)   :: zqv
-
-
-DO i=1, klon
-burden(i)=0.0
-  DO k=1, klev
-zqv(i,k)=zq(i,k)
-
-ENDDO
-
-ENDDO
-
-totmass=0.0
-
-
-IF (iscm3) THEN
-
-ELSE
-
-CALL kg_to_cm3(pplay,t_seri,zqv)
-
-ENDIF
-
-  DO k=1, klev
-      DO i=1, klon
-        burden(i)=burden(i)+(zqv(i,k)*1.e6*zdz(i,k)* &
-                 mass*1.e3/RNAVOG)     !--mg S/m2
-    ENDDO
-  ENDDO
-    DO i=1, klon
-        totmass=totmass+burden(i)*cell_area(i)
-ENDDO
-WRITE(*,9999) comment," totmass= ",totmass
-9999  format(a20,a10,e15.8)
-
-END SUBROUTINE checkmass
Index: /LMDZ6/trunk/libf/phylmd/Dust/checkmass.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/Dust/checkmass.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/Dust/checkmass.f90	(revision 5268)
@@ -0,0 +1,59 @@
+SUBROUTINE checkmass(zq,RNAVOG,mass,zdz,pplay,t_seri,iscm3,comment)
+  USE dimphy
+USE geometry_mod , ONLY:cell_area
+  IMPLICIT NONE
+
+  INCLUDE "YOMCST.h"
+
+! Entrees
+  REAL,DIMENSION(klon,klev), INTENT(IN)   :: zq
+  REAL,DIMENSION(klon,klev), INTENT(IN)   :: zdz
+  REAL,INTENT(IN)                         :: mass
+  REAL,INTENT(IN)                         :: RNAVOG
+  CHARACTER(LEN=*),INTENT(IN)             :: comment
+REAL,DIMENSION(klon,klev) ,INTENT(IN)  :: pplay
+REAL,DIMENSION(klon,klev) ,INTENT(IN) :: t_seri
+LOGICAL :: iscm3
+
+
+! Local  
+!  INTEGER,DIMENSION(klon)     :: jadrs
+  INTEGER                     :: i, k
+  REAL                              :: totmass
+  REAL,DIMENSION(klon)              ::  burden
+  REAL,DIMENSION(klon,klev)   :: zqv
+
+
+DO i=1, klon
+burden(i)=0.0
+  DO k=1, klev
+zqv(i,k)=zq(i,k)
+
+ENDDO
+
+ENDDO
+
+totmass=0.0
+
+
+IF (iscm3) THEN
+
+ELSE
+
+CALL kg_to_cm3(pplay,t_seri,zqv)
+
+ENDIF
+
+  DO k=1, klev
+      DO i=1, klon
+        burden(i)=burden(i)+(zqv(i,k)*1.e6*zdz(i,k)* &
+                 mass*1.e3/RNAVOG)     !--mg S/m2
+    ENDDO
+  ENDDO
+    DO i=1, klon
+        totmass=totmass+burden(i)*cell_area(i)
+ENDDO
+WRITE(*,9999) comment," totmass= ",totmass
+9999  format(a20,a10,e15.8)
+
+END SUBROUTINE checkmass
Index: DZ6/trunk/libf/phylmd/Dust/checknanqfi.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/Dust/checknanqfi.F90	(revision 5267)
+++ 	(revision )
@@ -1,32 +1,0 @@
-SUBROUTINE checknanqfi(zq,qmin,qmax,comment)
-  USE dimphy
-  IMPLICIT NONE
-
-! Entrees
-  REAL,DIMENSION(klon,klev), INTENT(IN)   :: zq
-  REAL,INTENT(IN)                         :: qmin,qmax
-  CHARACTER(LEN=*),INTENT(IN)             :: comment
-
-! Local  
-  INTEGER,DIMENSION(klon)     :: jadrs 
-  INTEGER                     :: i, jbad, k
-  
-  DO k = 1, klev
-     jbad = 0
-     DO i = 1, klon
-!        IF (zq(i,k).GT.qmax .OR. zq(i,k).LT.qmin) THEN
-        IF (isnan(zq(i,k))) THEN
-           jbad = jbad + 1
-           jadrs(jbad) = i
-        ENDIF
-     ENDDO
-     IF (jbad.GT.0) THEN
-        WRITE(*,*)comment
-        DO i = 1, jbad
-           WRITE(*,*) "i,k,q=", jadrs(i),k,zq(jadrs(i),k)
-           CALL abort_physic(comment, 'NaN founded',1)
-        ENDDO
-     ENDIF
-  ENDDO
-  
-END SUBROUTINE checknanqfi
Index: /LMDZ6/trunk/libf/phylmd/Dust/checknanqfi.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/Dust/checknanqfi.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/Dust/checknanqfi.f90	(revision 5268)
@@ -0,0 +1,32 @@
+SUBROUTINE checknanqfi(zq,qmin,qmax,comment)
+  USE dimphy
+  IMPLICIT NONE
+
+! Entrees
+  REAL,DIMENSION(klon,klev), INTENT(IN)   :: zq
+  REAL,INTENT(IN)                         :: qmin,qmax
+  CHARACTER(LEN=*),INTENT(IN)             :: comment
+
+! Local  
+  INTEGER,DIMENSION(klon)     :: jadrs 
+  INTEGER                     :: i, jbad, k
+  
+  DO k = 1, klev
+     jbad = 0
+     DO i = 1, klon
+!        IF (zq(i,k).GT.qmax .OR. zq(i,k).LT.qmin) THEN
+        IF (isnan(zq(i,k))) THEN
+           jbad = jbad + 1
+           jadrs(jbad) = i
+        ENDIF
+     ENDDO
+     IF (jbad.GT.0) THEN
+        WRITE(*,*)comment
+        DO i = 1, jbad
+           WRITE(*,*) "i,k,q=", jadrs(i),k,zq(jadrs(i),k)
+           CALL abort_physic(comment, 'NaN founded',1)
+        ENDDO
+     ENDIF
+  ENDDO
+  
+END SUBROUTINE checknanqfi
Index: DZ6/trunk/libf/phylmd/Dust/dustemission_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/Dust/dustemission_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,1543 +1,0 @@
-MODULE dustemission_mod
-
-  IMPLICIT NONE
-  !Parameters   
-!  INTEGER, PARAMETER     :: nbins=12  ! number of aerosol bins: original 
-!  INTEGER, PARAMETER     :: nbins=800  ! number of aerosol bins: for spla
-!  INTEGER, PARAMETER     :: nbins=8000  ! number of aerosol bins: for spla
-  
-  INTEGER, PARAMETER     :: flag_feff=1 ! 0: deactivate feff (drag partition scheme)
-  INTEGER, PARAMETER     :: nbins=800  ! number of aerosol bins: for spla
-  INTEGER, PARAMETER     :: nmode=3   ! number of soil-dust modes 
-  INTEGER, PARAMETER     :: ntyp=5   ! number of soil types 
-  INTEGER, PARAMETER     :: nwb=12   ! number of points for the 10m wind
-! speed weibull distribution (>=2)
-  real   ,parameter     :: z10m=1000. !10m in cm
-  REAL,PARAMETER         :: kref=3. !weibull parameter
-  INTEGER, PARAMETER    :: nats=14 !number of mineral types (14 here for sand,
-                                   ! silt, clay etc.)
-  integer, parameter :: nclass=200000
-
-
-  real   , parameter :: dmin=0.0001
-  real   , parameter :: dmax=0.2
-  integer, parameter :: nspe=nmode*3+1
-  real   ,parameter     :: vkarm=0.41
-!JE20150202 : updating scheme to chimere13b <<<
-! original values
-!  integer, parameter :: div1=3.
-!  integer, parameter :: div2=3.
-!  integer, parameter :: div3=3.
-!  real   , parameter :: e1=3.61/div1
-!  real   , parameter :: e2=3.52/div2
-!  real   , parameter :: e3=3.46/div3
-!  real   , parameter :: rop=2.65 ! particle density g/m3
-!  real   , parameter :: roa=0.001227  ! air density g/m3
-!  real   , parameter :: pi=3.14159  !!
-!  real   , parameter :: gravity=981. !! cm!!
-!  real   , parameter :: cd=1.*roa/gravity
-! new values
-!  logical, parameter :: ok_splatuning=.true.
-! Div=3 from S. Alfaro (Sow et al ACPD 2011)
-!JE 20150206
-!  integer, parameter :: div1=3.
-!  integer, parameter :: div2=3.
-!  integer, parameter :: div3=3.
-  integer, parameter :: div1=6.
-  integer, parameter :: div2=6.
-  integer, parameter :: div3=6.
-  real   , parameter :: e1=3.61/div1
-  real   , parameter :: e2=3.52/div2
-  real   , parameter :: e3=3.46/div3
-  real   , parameter :: rop=2.65 ! particle density g/m3
-  real   , parameter :: roa=0.001227  ! air density g/m3
-  real   , parameter :: pi=3.14159  !!
-  real   , parameter :: gravity=981. !! cm!!
-! C=2.61 from Marticorena and Bergametti 1995 instead of Gillete and Chen 2001
-! (recommended C=1.1  in supply-limited dust source area.. )
-   real   , parameter :: cd=2.61*roa/gravity
-!  real   , parameter :: cd=1.0*roa/gravity
-!JE20150202>>>>
-  real,parameter     :: beta=16300.
-  real, parameter, dimension(3) :: diam=(/1.5,6.7,14.2/)
-  INTEGER, PARAMETER     :: ndistb=3
-  real, parameter, dimension(3) :: sig=(/1.7,1.6,1.5/)
-
-!   INTEGER, PARAMETER     :: nbinsHR=3000 !original
-   INTEGER, PARAMETER     :: nbinsHR=30000
-!min and max dust size in um
-      REAL, PARAMETER     :: sizedustmin=0.0599 ! for spla
-      REAL, PARAMETER     :: sizedustmax=63.
-!      REAL, PARAMETER     :: sizedustmin=0.09  ! original
-!      REAL, PARAMETER     :: sizedustmax=63.
-
-
-  ! Calc variables
-  REAL,DIMENSION(:,:), ALLOCATABLE,SAVE  :: massfrac
-  REAL,DIMENSION(:),  ALLOCATABLE,SAVE :: binsHR
-  REAL,DIMENSION(:),  ALLOCATABLE,SAVE :: binsHRcm
-  REAL,DIMENSION(:),  ALLOCATABLE,SAVE :: itv
-  REAL,DIMENSION(:),  ALLOCATABLE,SAVE :: sizedust !size dust bin (in um)
-  REAL,DIMENSION(:),  ALLOCATABLE,SAVE :: szdcm !the same but (in cm)
-
-  !soil inputs from file donnees_lisa.nc . Should be in the same grid as the
-  !model (regridded with nearest neighborhood from surfnew.nc)
-  REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: sol
-  REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: P
-  REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: zos
-  REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: z01
-  REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: z02
-  REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: D
-  REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: A
-  REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: solspe
-  INTEGER,DIMENSION(:,:),ALLOCATABLE,SAVE :: masklisa
-!!!  INTEGER,DIMENSION(:),ALLOCATABLE,SAVE :: maskdust
-  REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: feff
-  REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: feffdbg
-
-  REAL,DIMENSION(:),  ALLOCATABLE,SAVE :: sizeclass 
-  REAL,DIMENSION(:),  ALLOCATABLE,SAVE :: sizeclass2 
-  REAL,DIMENSION(:),  ALLOCATABLE,SAVE :: uth
-  REAL,DIMENSION(:),  ALLOCATABLE,SAVE :: uth2
-  REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: srel
-  REAL,DIMENSION(:,:),  ALLOCATABLE,SAVE :: srel2
-
-  INTEGER :: nat ! SOL data inside the loop (use as soil type index?)
-  REAL :: ustarsalt 
-  REAL :: var3a,var3b
-  INTEGER  :: ns,nd,nsi,npi,ni ! counters
-  INTEGER :: ncl
-
-! outputs
-  REAL,DIMENSION(:),  ALLOCATABLE,SAVE :: m1dflux !fluxes for each soil mode
-  REAL,DIMENSION(:),  ALLOCATABLE,SAVE :: m2dflux
-  REAL,DIMENSION(:),  ALLOCATABLE,SAVE :: m3dflux
-
-
-
-!$OMP THREADPRIVATE(m1dflux)
-!$OMP THREADPRIVATE(m2dflux)
-!$OMP THREADPRIVATE(m3dflux)
-!$OMP THREADPRIVATE(massfrac) 
-!$OMP THREADPRIVATE(binsHR) 
-!$OMP THREADPRIVATE(binsHRcm) 
-!$OMP THREADPRIVATE(itv) 
-!$OMP THREADPRIVATE(sizedust) 
-!$OMP THREADPRIVATE(szdcm) 
-!$OMP THREADPRIVATE(sol) 
-!$OMP THREADPRIVATE(P) 
-!$OMP THREADPRIVATE(zos) 
-!$OMP THREADPRIVATE(z01) 
-!$OMP THREADPRIVATE(z02) 
-!$OMP THREADPRIVATE(D) 
-!$OMP THREADPRIVATE(A) 
-!$OMP THREADPRIVATE(solspe) 
-!$OMP THREADPRIVATE(masklisa) 
-!!!!$OMP THREADPRIVATE(maskdust) 
-!$OMP THREADPRIVATE(feff) 
-!$OMP THREADPRIVATE(feffdbg) 
-!$OMP THREADPRIVATE(sizeclass) 
-!$OMP THREADPRIVATE(sizeclass2) 
-!$OMP THREADPRIVATE(uth) 
-!$OMP THREADPRIVATE(uth2) 
-!$OMP THREADPRIVATE(srel) 
-!$OMP THREADPRIVATE(srel2) 
-
-
-
-  CONTAINS
-
-!--------------------------------------------------------------------------------------
-!======================================================================================
-!**************************************************************************************
-!======================================================================================
-!--------------------------------------------------------------------------------------
-
-  SUBROUTINE dustemis_out_init()
-
-    USE dimphy
-
-    !AS: moved here from subroutine initdust
-    ALLOCATE( m1dflux(klon) )
-    ALLOCATE( m2dflux(klon) )
-    ALLOCATE( m3dflux(klon) )
-
-  END SUBROUTINE dustemis_out_init
-
-  SUBROUTINE dustemission( debutphy, xlat, xlon, &    !Input
-                          pctsrf,zu10m,zv10m,wstar, & !Input
-                          ale_bl,ale_wake, &          !Input
-                          param_wstarBL, param_wstarWAKE, &  !Input
-                          emdustacc,emdustcoa,emdustsco,maskdust)    !Output
-  USE dimphy
-  USE infotrac
-  USE write_field_phy
-  USE mod_grid_phy_lmdz
-  USE mod_phys_lmdz_para
-  USE indice_sol_mod
-
-  IMPLICIT NONE
-  ! input :
-  ! output: flux_sparam_ddfine,flux_sparam_ddcoa,
-  ! first: 
-  ! Model grid parameters
-  REAL,DIMENSION(klon),     INTENT(IN)     :: xlat
-  REAL,DIMENSION(klon),     INTENT(IN)     :: xlon
-  REAL,DIMENSION(klon,nbsrf), INTENT(IN)     :: pctsrf
-  REAL,DIMENSION(klon),INTENT(IN)          :: zu10m   ! 10m zonal wind
-  REAL,DIMENSION(klon),INTENT(IN)          :: zv10m   ! meridional 10m wind
-  REAL,DIMENSION(klon),INTENT(IN)          :: wstar
-  REAL,DIMENSION(klon),INTENT(IN)          :: ale_bl
-  REAL,DIMENSION(klon),INTENT(IN)          :: ale_wake
-  REAL,DIMENSION(klon), INTENT(IN) :: param_wstarWAKE
-  REAL,DIMENSION(klon), INTENT(IN) :: param_wstarBL
- 
- 
-  LOGICAL  :: debutphy ! First physiqs run or not
-  ! Intermediate variable: 12 bins emissions
-  REAL,DIMENSION(:,:), ALLOCATABLE,SAVE  :: emisbinloc ! vertical emission fluxes
-
-  !OUT variables
-  REAL,DIMENSION(klon)  :: emdustacc,emdustcoa,emdustsco ! emission in spla dust bins:
-! old radio : acc=0.03-0.5 micrometers, ccoa:0.5-10 micrometers
-! new acc=0.03-0.5 micrometers, coa:0.5-3 micrometers ,sco:3-15 um
-  INTEGER,DIMENSION(klon) :: maskdust ! where the emissions were calculated
-!  INTEGER,DIMENSION(klon_glo) :: maskdust_glo ! auxiliar 
-!  REAL,DIMENSION(klon_glo) :: raux_klon_glo ! auxiliar 
-
-!$OMP THREADPRIVATE(emisbinloc)
-!!!!!!$OMP THREADPRIVATE(maskdust)
-  IF (debutphy) THEN
-     ALLOCATE( emisbinloc(klon,nbins) )
-  ENDIF
-
-  IF( debutphy ) THEN  
-     CALL initdust(xlat,xlon,pctsrf)
-  ENDIF
-
-!JE20141124  CALL  calcdustemission(debutphy,zu10m,zv10m,wstar,ale_bl,ale_wake,emisbinloc)
-  CALL  calcdustemission(debutphy,zu10m,zv10m,wstar,ale_bl,ale_wake,param_wstarBL,param_wstarWAKE, & !I
-                         emisbinloc)   !O
-
-  CALL makemask(maskdust)
-
-  IF( debutphy ) THEN  
-!       call gather(maskdust,maskdust_glo)
-!     !$OMP MASTER
-!     IF (is_mpi_root .AND. is_omp_root) THEN
-!       CALL writefield_phy("maskdust",float(maskdust_glo),1)
-       CALL writefield_phy("maskdust",float(maskdust),1)
-!     ENDIF
-!     !$OMP END MASTER
-!     !$OMP BARRIER
-  ENDIF
-
-  !CALL adaptdustemission(debutphy,emisbinloc,emdustacc,emdustcoa,emdustsco)
-  CALL adaptdustemission(debutphy,emisbinloc,emdustacc,emdustcoa,emdustsco,maskdust,pctsrf)
-  ! output in kg/m2/s
-
-
-  END SUBROUTINE dustemission
-
-!--------------------------------------------------------------------------------------
-!======================================================================================
-!**************************************************************************************
-!======================================================================================
-!--------------------------------------------------------------------------------------
-
- SUBROUTINE makemask(maskdustloc) 
-  USE dimphy
-  USE infotrac
-  IMPLICIT NONE
-  !Input
-  INTEGER,DIMENSION(klon) :: maskdustloc
-  INTEGER :: i,j,k
-  integer :: iaux
- 
-
-  do k=1,klon
-      maskdustloc(k)=0
-      do i=1,ntyp
-         if (masklisa(k,i)>0) then
-             maskdustloc(k)=1
-         endif
-      enddo
-  enddo
-
-  END SUBROUTINE makemask
-
-!--------------------------------------------------------------------------------------
-!======================================================================================
-!**************************************************************************************
-!======================================================================================
-!--------------------------------------------------------------------------------------
-
- SUBROUTINE adaptdustemission(debutphy,emisbinlocal, &
-                emdustacc,emdustcoa,emdustsco,maskdust,pctsrf)
-!                               emdustacc,emdustcoa,emdustsco)
-
-  USE dimphy
-  USE infotrac
-  USE write_field_phy
-  USE mod_grid_phy_lmdz
-  USE mod_phys_lmdz_para
-  USE indice_sol_mod
-
-  IMPLICIT NONE
-  !Input
-  REAL,DIMENSION(klon) :: emdustacc,emdustcoa,emdustsco
-  REAL, DIMENSION(klon,nbins) :: emisbinlocal
-  ! Local
-  INTEGER  :: i,j,k
-!!!  INTEGER,DIMENSION(2) :: iminacclow,iminacchigh,imincoalow,imincoahigh ! in
-!case of small nbins.... not ready
-  INTEGER,SAVE ::iminacclow,iminacchigh,imincoalow
-  INTEGER,SAVE ::imincoahigh,iminscohigh,iminscolow
-  INTEGER,DIMENSION(klon) :: maskdust ! where the emissions were calculated
-  REAL,DIMENSION(klon,nbsrf),     INTENT(IN)     :: pctsrf
-!  real,parameter :: sizeacclow=0.03
-!  real,parameter :: sizeacchigh=0.5
-!  real,parameter :: sizecoalow=0.5
-!  real,parameter :: sizecoahigh=10.  ! in micrometers
-  real,parameter :: sizeacclow=0.06
-  real,parameter :: sizeacchigh=1.0
-  real,parameter :: sizecoalow=1.0
-  real,parameter :: sizecoahigh=6.  !20 ! diameter in micrometers
-  real,parameter :: sizescolow=6.
-  real,parameter :: sizescohigh=30.  ! in micrometers
-!--------------------------------
-!  real,parameter :: tuningfactorfine=0.9  ! factor for fine bins!!! important!!
-  real,parameter :: tuningfactorfine=0.8  ! factor for fine bins!!! important!!
-!  real,parameter :: tuningfactorfine=4.5  ! factor for fine bins!!! important!!
-!  real,parameter :: tuningfactorcoa=3.6 ! factor for coarse bins!!! important!!
-  real,parameter :: tuningfactorcoa=3.25 ! factor for coarse bins!!! important!!
-!  real,parameter :: tuningfactorcoa=4.5  ! factor for coarse bins!!! important!!
-!  real,parameter :: tuningfactorsco=3.6  ! factor for supercoarse bins!!! important!!
-  real,parameter :: tuningfactorsco=3.25  ! factor for supercoarse bins!!! important!!
-!  real,parameter :: tuningfactorsco=4.5  ! factor for supercoarse bins!!! important!!
-  real,parameter :: basesumemission= 0.0  !1.e-6  ! emissions to SUM to each land pixel FOR ASSIMILATION ONLY important!!  in mg/m2/s, per bin
- !basesumemission = 1.e-6 increase the AOD in about 12%  (0.03 of AOD) , 
- !while 1e-8 increase in about 0.12%  (0.003 of AOD)
-
-  real,dimension(klon) :: basesumacc,basesumcoa,basesumsco
-!--------------------------------
-!JE20140915  real,parameter :: sizeacclow=0.06
-!JE20140915  real,parameter :: sizeacchigh=1.0
-!JE20140915  real,parameter :: sizecoalow=1.0
-!JE20140915  real,parameter :: sizecoahigh=10.  !20 ! diameter in micrometers
-!JE20140915  real,parameter :: sizescolow=10.
-!JE20140915  real,parameter :: sizescohigh=30.  ! in micrometers
-
-
-
-  logical ::  debutphy
-  real :: diff, auxr1,auxr2,auxr3,auxr4
-  real,dimension(klon,nbins) :: itvmean
-  real,dimension(klon,nbins+1) :: itv2
-!  real,dimension(klon_glo,nbins) :: itvmean_glo
-!  real,dimension(:,:) , allocatable  :: itvmean_glo
-!  real,dimension(:,:), allocatable :: itv2_glo
-  
-  integer, save :: counter,counter1 !dbg
-  REAL, DIMENSION(:,:),ALLOCATABLE,SAVE :: emisbinlocalmean,emisbinlocalmean2 !dbg
-  REAL, DIMENSION(:,:),ALLOCATABLE :: emisbinlocalmean2_glo 
-  logical :: writeaerosoldistrib
-!$OMP THREADPRIVATE(iminacclow,iminacchigh,imincoalow,imincoahigh)
-
-writeaerosoldistrib=.false.
-if (debutphy) then
-
-  if (sizedustmin>sizeacclow .or. sizedustmax<sizescohigh) then 
-   call abort_physic('adaptdustemission', 'Dust range problem',1)
-  endif
-  print *,'FINE DUST BIN: tuning EMISSION factor= ',tuningfactorfine
-  print *,'COA DUST BIN: tuning EMISSION factor= ',tuningfactorcoa
-  print *,'SCO DUST BIN: tuning EMISSION factor= ',tuningfactorsco
-  print *,'ALL DUST BIN: SUM to the emissions (mg/m2/s) = ',basesumemission
-  auxr1=9999.
-  auxr2=9999.
-  auxr3=9999.
-  auxr4=9999.
-  do i=1,nbins+1
-   if (abs(sizeacclow-itv(i))<auxr1) then
-          auxr1=abs( sizeacclow-itv(i))
-          iminacclow=i
-   endif
-   if (abs(sizeacchigh-itv(i))<auxr2) then
-          auxr2=abs( sizeacchigh-itv(i))
-          iminacchigh=i
-          imincoalow=i
-   endif
-   if (abs(sizecoahigh-itv(i))<auxr3) then
-          auxr3=abs( sizecoahigh-itv(i))
-          imincoahigh=i
-          iminscolow=i
-   endif
-   if (abs(sizescohigh-itv(i))<auxr4) then
-          auxr4=abs( sizescohigh-itv(i))
-          iminscohigh=i
-   endif
-  enddo
-if (writeaerosoldistrib) then
-!JEdbg<<
-  do j=1,klon
-  do i=1,nbins
-    itvmean(j,i)=(itv(i)+itv(i+1))/2.
-    itv2(j,i)=itv(i)
-    !print*, itv(i),itvmean(i),itv(i+1)
-    !print*, sizedust(i)
-  enddo
-  itv2(j,nbins+1)=itv(nbins+1)
-  enddo
-!  allocate(itv2_glo(klon_glo,nbins+1))
-!  allocate(itvmean_glo(klon_glo,nbins))
-!  ALLOCATE(emisbinlocalmean2_glo(klon_glo,nbins))
-!  call gather(itv2,itv2_glo)
-!  call gather(itvmean,itvmean_glo)
-!!$OMP MASTER
-!  IF (is_mpi_root .AND. is_omp_root) THEN
-!  CALL writefield_phy("itv2",itv2_glo,nbins+1)
-!  CALL writefield_phy("itvmean",itvmean_glo,nbins)
-  CALL writefield_phy("itv2",itv2,nbins+1)
-  CALL writefield_phy("itvmean",itvmean,nbins)
-!  ENDIF
-!!$OMP END MASTER
-!!$OMP BARRIER
-  ALLOCATE(emisbinlocalmean(klon,nbins))
-  ALLOCATE(emisbinlocalmean2(klon,nbins))
-  do i=1,nbins
-    do j=1,klon
-       emisbinlocalmean(j,i)=0.0
-       emisbinlocalmean2(j,i)=0.0
-    enddo
-  enddo
-  counter=1
-  counter1=0
-!JEdbg>>
-endif
-endif
-
-
-!print *,'JE'
-!print *,iminacclow,iminacchigh,imincoalow,imincoahigh
-
-! estimate and integrate bins into only accumulation and coarse
-do k=1,klon
-  basesumacc(k)=basesumemission*(pctsrf(k,is_ter))*1.e-6 ! from mg/m2/s
-  basesumcoa(k)=basesumemission*(pctsrf(k,is_ter))*1.e-6
-  basesumsco(k)=basesumemission*(pctsrf(k,is_ter))*1.e-6
-enddo
-
-
-do k=1,klon
-auxr1=0.0
-auxr2=0.0
-auxr3=0.0
-  do i=iminacclow,iminacchigh-1
-   auxr1=auxr1+emisbinlocal(k,i)
-  enddo
-  emdustacc(k)=(auxr1 + basesumacc(k))*tuningfactorfine
-  do i=imincoalow,imincoahigh-1
-    auxr2=auxr2+emisbinlocal(k,i)
-  enddo
-  emdustcoa(k)=(auxr2 + basesumcoa(k))*tuningfactorcoa
-  do i=iminscolow,iminscohigh-1
-    auxr3=auxr3+emisbinlocal(k,i)
-  enddo
-  emdustsco(k)=(auxr3 + basesumsco(k))*tuningfactorsco
-enddo
-
-
-!do k=1,klon
-!auxr1=0.0
-!auxr2=0.0
-!auxr3=0.0
-!  do i=iminacclow,iminacchigh-1
-!   auxr1=auxr1+emisbinlocal(k,i)
-!  enddo
-!  emdustacc(k)= auxr1*tuningfactor
-!  do i=imincoalow,imincoahigh-1
-!    auxr2=auxr2+emisbinlocal(k,i)
-!  enddo
-!  emdustcoa(k)=auxr2*tuningfactor
-!  do i=iminscolow,iminscohigh-1
-!    auxr3=auxr3+emisbinlocal(k,i)
-!  enddo
-!  emdustsco(k)=auxr3*tuningfactor
-!enddo
-!
-
-
-
-
-!JEdbg<<
-if (writeaerosoldistrib) then
-  do i=1,nbins
-    do j=1,klon
-        emisbinlocalmean(j,i)=emisbinlocalmean(j,i)+emisbinlocal(j,i)
-    enddo 
-  enddo
-counter1=counter1+1
-! 4 timesteps of physics=4*15min=1hour..
-! 1440 = 15 days
-! 480 = 5 days
-if (MOD(counter,1440).eq. 0) THEN
-   !if (MOD(counter,480).eq. 0) THEN
-   do k = 1,klon
-   do i=1,nbins
-     emisbinlocalmean2(k,i)=emisbinlocalmean(k,i)/float(counter1)
-   enddo
-   enddo
-   counter1=0
-!   call gather(emisbinlocalmean2,emisbinlocalmean2_glo)
-!!$OMP MASTER
-!   IF (is_mpi_root .AND. is_omp_root) THEN
-!   CALL writefield_phy("emisbinlocalmean2",emisbinlocalmean2_glo,nbins)
-   CALL writefield_phy("emisbinlocalmean2",emisbinlocalmean2,nbins)
-!   ENDIF
-!!$OMP END MASTER
-!!$OMP BARRIER
-   do i=1,nbins
-     do j=1,klon
-        emisbinlocalmean(j,i)=0.0
-     enddo
-   enddo
-endif
-counter=counter+1
-endif
-!JEdbg>>
-
-!CALL abort_gcm('calcdustemission', 'OK1',1)
- 
-END SUBROUTINE adaptdustemission
-
-
-!--------------------------------------------------------------------------------------
-!======================================================================================
-!**************************************************************************************
-!======================================================================================
-!--------------------------------------------------------------------------------------
-
-
-!--------------------------------------------------------
-  SUBROUTINE initdust(xlat,xlon,pctsrf)
-  USE dimphy
-  USE infotrac
-  USE write_field_phy
-  USE mod_grid_phy_lmdz
-  USE mod_phys_lmdz_para
-  USE indice_sol_mod
-
-  IMPLICIT NONE
-  !Inputs
-  REAL,DIMENSION(klon),     INTENT(IN)     :: xlat
-  REAL,DIMENSION(klon),     INTENT(IN)     :: xlon
-  ! JE20150605<< better to read
-  ! REAL,DIMENSION(klon),     INTENT(IN)     :: pctsrf
-  REAL,DIMENSION(klon,nbsrf),     INTENT(IN)     :: pctsrf
-  ! JE20150605>>
-
-  !Local
-  REAL,DIMENSION(klon,ntyp)                :: solini
-  REAL,DIMENSION(klon,ntyp)                :: Pini
-  REAL,DIMENSION(klon,ntyp)                :: zosini
-  REAL,DIMENSION(klon,ntyp)                :: z01ini
-  REAL,DIMENSION(klon,ntyp)                :: z02ini
-  REAL,DIMENSION(klon,ntyp)                :: Dini
-  REAL,DIMENSION(klon,ntyp)                :: Aini
-
-  REAL,DIMENSION(nclass)                   :: newstep
-
- !TEMPORAL/ MAKE MASK!!!
-  REAL, PARAMETER        :: longmin=-20.
-  REAL, PARAMETER        :: longmax=77.          !35.  
-  REAL, PARAMETER        :: latmin=10.
-  REAL, PARAMETER        :: latmax=40.
- !TEMPORAL/ MAKE MASK!!!
-  !Local
-  REAL, PARAMETER        :: eps=1.e-5
-  REAL, PARAMETER        :: aeff=0.35
-  REAL, PARAMETER        :: xeff=10.
-  REAL, PARAMETER        :: trctunt=0.310723
- 
-  INTEGER     :: i,j,k,nts
-  REAL :: dp,dstep
-! Parametres pour le calcul de la repartition de l energie feff(klon,ntyp)
-  REAL :: aa,bb,cc,dd,ee,ff
-  REAL,DIMENSION(klon,ntyp) :: tmp1
-  REAL :: p3t,var1,var2,et
-
-! Parametres pour le calcul de la surface couverte par les particule de diametre
-! dp srel(nats,nclass)
-  REAL :: stotale,su,su_loc,xk,xl,xm,xn
-  REAL,DIMENSION(nclass)                   :: subsoildist
-
-! isolog and massfrac calcs
-  INTEGER :: nbinsout,nb,miniso,nbins1,nbins2,istart,no
-  REAL :: b1,b2,stepbin,minisograd,exden,d2min,d2max,numin,numax
-  REAL                   :: delta1,delta2,ldmd
-!  REAL, PARAMETER     :: sizedustmin=0.09
-  REAL,DIMENSION(nbinsHR):: binsISOGRAD
-  REAL,DIMENSION(nbinsHR):: vdISOGRAD
-  REAL,DIMENSION(nbinsHR):: logvdISOGRAD
-  REAL                   :: curvd
-  REAL                   :: avdhr
-  REAL                   :: bvdhr
-  REAL,DIMENSION(nbins)  :: dmn1
-  REAL,DIMENSION(nbins)  :: dmn2
-  REAL,DIMENSION(nbins)  :: dmn3
-  REAL,DIMENSION(nbinsHR) :: vdHR
-  REAL,DIMENSION(nbinsHR)  :: vdout
-
-
-
-! Parametres pour le calcul de la vitesse de friction seuil uth(nclass)
-! calcul de la vitesse seuil selon la parametrisation de Shao and Lu
-! 2000(icuth=1).
-!  INTEGER                :: ich1
-  REAL                   :: an
-  REAL                   :: gam
-  REAL                   :: sigshao
-  REAL                   :: x1
-  REAL                   :: x2
-! Cas de Iversen and White 1982 (icuth=0) si necessaire.
-  REAL, PARAMETER        :: adust=1331.647
-  REAL, PARAMETER        :: bdust=0.38194
-  REAL, PARAMETER        :: xdust=1.561228
-  REAL, PARAMETER        :: ddust=0.006/(rop*gravity)
-
-  CHARACTER(LEN=10) :: varname
-  CHARACTER(LEN=80) :: fnsolspe
-  CHARACTER(LEN=200) :: line
-  
-
-! nats: number of mineral types (14 here for sand, silt, clay etc.)
-    ALLOCATE( binsHR(nbinsHR) )
-    ALLOCATE( binsHRcm(nbinsHR) )
-    ALLOCATE( itv(nbins+1) )
-    ALLOCATE( sizedust(nbins) )
-    ALLOCATE( szdcm(nbins) )
-    ALLOCATE( massfrac(ndistb,nbins) )
-    ALLOCATE( sol(klon,ntyp) )
-    ALLOCATE( P(klon,ntyp) )
-    ALLOCATE( zos(klon,ntyp) )
-    ALLOCATE( z01(klon,ntyp) )
-    ALLOCATE( z02(klon,ntyp) )
-    ALLOCATE( D(klon,ntyp) )
-    ALLOCATE( A(klon,ntyp) )
-    ALLOCATE( masklisa(klon,ntyp) )
-    ALLOCATE( solspe(nats,nspe) )
-    ALLOCATE( feff(klon,ntyp) ) 
-    ALLOCATE( feffdbg(klon,ntyp) ) 
-    ALLOCATE( sizeclass(nclass) )
-    ALLOCATE( sizeclass2(nclass) )
-    ALLOCATE( uth(nclass) )
-    ALLOCATE( uth2(nclass) )
-    ALLOCATE( srel(nats,nclass) )
-    ALLOCATE( srel2(nats,nclass) )
-
-
-
-  ! read input data from donnees_lisa.nc
-  varname='SOL'
-  CALL read_surface(varname,solini)
-  varname='P'
-  CALL read_surface(varname,Pini)
-  varname='ZOS_'
-  CALL read_surface(varname,zosini)
-  varname='ZO1_'
-  CALL read_surface(varname,z01ini)
-  varname='ZO2_'
-  CALL read_surface(varname,z02ini)
-  varname='D'
-  CALL read_surface(varname,Dini)
-  varname='A'
-  CALL read_surface(varname,Aini)
-print *,'beforewritephy',mpi_rank,omp_rank
-  CALL writefield_phy("SOLinit",solini,5)
-  CALL writefield_phy("Pinit",Pini,5)
-  CALL writefield_phy("ZOSinit",zosini,5)
-  CALL writefield_phy("ZO1init",z01ini,5)
-  CALL writefield_phy("ZO2init",z02ini,5)
-  CALL writefield_phy("Dinit",Dini,5)
-  CALL writefield_phy("Ainit",Aini,5)
-print *,'afterwritephy',mpi_rank,omp_rank
-
-  DO i=1,klon
-    DO nts=1,ntyp
-        masklisa(i,nts)=0
-        IF(Pini(i,nts)>=0.) THEN
-               masklisa(i,nts)=1
-        ENDIF 
-    ENDDO
-  ENDDO
-!print *,'JEOK1',mpi_rank,omp_rank
-  DO i=1,klon
-    !print *,Pini(i,1),Pini(i,2),Pini(i,3),Pini(i,4),Pini(i,5)
-    DO nts=1,ntyp
-      !IF(xlon(i).ge.longmin.and.xlon(i).le.longmax.and. &
-      !&      xlat(i).ge.latmin.and.xlat(i).le.latmax    &
-      !&      .and.pctsrf(i)>0.5.and.Pini(i,nts)>0.)THEN
-  ! JE20150605<< easier to read
-      IF(pctsrf(i,is_ter)>0.5.and.Pini(i,nts)>0.)THEN
-  ! JE20150605>>
-           sol(i,nts) = solini(i,nts)
-             P(i,nts) = Pini(i,nts)
-           zos(i,nts) = zosini(i,nts)
-           z01(i,nts) = z01ini(i,nts)
-           z02(i,nts) = z02ini(i,nts)
-             D(i,nts) = Dini(i,nts)
-             A(i,nts) = Aini(i,nts)
-!             masklisa(i,nts)=1
-      ELSE
-              sol(i,nts) =0.0
-               P(i,nts)  =0.0
-              zos(i,nts) =0.0
-              z01(i,nts) =0.0
-              z02(i,nts) =0.0
-               D(i,nts)  =0.0
-               A(i,nts)  =0.0
-!            masklisa(i,nts)=0
-      ENDIF
-    ENDDO
-  ENDDO
-
-! print *,'JEOK2',mpi_rank,omp_rank
-if ( 1==1 ) then
-
-! print *,'JEOK4',mpi_rank,omp_rank
-   CALL writefield_phy("SOL",sol,5)
-   CALL writefield_phy("P"  ,P  ,5)
-   CALL writefield_phy("ZOS",zos,5)
-   CALL writefield_phy("ZO1",z01,5)
-   CALL writefield_phy("ZO2",z02,5)
-   CALL writefield_phy("D"  ,D  ,5)
-   CALL writefield_phy("A"  ,A  ,5)
-   CALL writefield_phy("masklisa",float(masklisa),5)
-   CALL writefield_phy("pctsrf",pctsrf,1)
-   CALL writefield_phy("xlon",xlon,1)
-   CALL writefield_phy("xlat",xlat,1)
-!print *,'JEOK5',mpi_rank,omp_rank
-!print *,'JEOK6',mpi_rank,omp_rank
-
-endif
-
-  !CALL abort_gcm('initdustemission', 'OK1',1)
-
-! Lecture des donnees du LISA indiquant le type de sol utilise.
-       ! in lines: landuse
-! nats: number of mineral types (14 here for sand, silt, clay etc.)
-! data format in columns
-! mmd1  sigma1  p1  mmd2  sigma2  p2 mmd3 ... alpha
-!print *,'JEOK7',mpi_rank,omp_rank
-!$OMP MASTER
-IF (is_mpi_root .AND. is_omp_root) THEN
-!print *,'JEOK9',mpi_rank,omp_rank
- fnsolspe='SOILSPEC.data'
-  PRINT*,'  o Reading ',fnsolspe(1:40)
-  OPEN(10,file=fnsolspe)
-  READ(10,*)line
-  DO i=1,nats
-     READ(10,*)line
-     READ(10,*)(solspe(i,j),j=1,nspe)
-!JE     alfa(i)=solspe(i,10)
-!     PRINT*,'i,alfa(i)',i,alfa(i)
-!     WRITE(18,*)i,alfa(i)
-  END DO
-!     print*,'solspe(14,10)= ',solspe(14,10)
-  CLOSE(10)
-ENDIF
-!$OMP END MASTER
-!$OMP BARRIER
-!print *,'JEOK10',mpi_rank,omp_rank
-  call bcast(solspe)
-! Calcul de la distribution en taille des particules de Dust
-! Elle depend du nombre de classe des particules nclass.
-!c making full resolution soil diameter table
-      dstep=0.0005
-      dp=dmin
-      do i=1,nclass
-         dp=dp*exp(dstep)
-         sizeclass(i)=dp
-         if(dp.ge.dmax+eps)goto 30
-         newstep(i)=dstep
-        ! WRITE(18,*)i,sizeclass(i)
-      enddo
-30   continue
-      print*,'IK5'
-      ncl=i-1
-      print*,'   soil size classes used   ',ncl,' / ',nclass
-      print*,'   soil size min: ',sizeclass(1),' soil size max: ',sizeclass(ncl)
-      if(ncl.gt.nclass)stop
-
-! Threshold velocity:
-if (.false.) then
-!if (.true.) then
-!c 0: Iversen and White 1982
-       print *,'Using  Iversen and White 1982 Uth'
-         do i=1,ncl
-            bb=adust*(sizeclass(i)**xdust)+bdust
-            cc=sqrt(1+ddust*(sizeclass(i)**(-2.5)))
-            xk=sqrt(abs(rop*gravity*sizeclass(i)/roa))
-            if (bb.lt.10.) then
-               dd=sqrt(1.928*(bb**0.092)-1.)
-               uth(i)=0.129*xk*cc/dd
-            else
-               ee=-0.0617*(bb-10.)
-               ff=1.-0.0858*exp(ee)
-               uth(i)=0.12*xk*cc*ff
-            endif
-         enddo
-endif
-if(.true.) then
-! 1: Shao and Lu 2000
-       print *,'Using  Shao and Lu 2000 Uth'
-            an=0.0123
-            gam=0.3
-            do i=1,ncl
-               sigshao=rop/roa
-               x1=sigshao*gravity*sizeclass(i)
-               x2=gam/(roa*sizeclass(i))
-               uth(i)=sqrt(an*(x1+x2))
-            enddo
-endif
-
-
-
-!Calcul de la surface couverte par les particules de diametre dp
-!srel(nats,nclass)
-
-!  OPEN(18,file='srel.dat',form='formatted',access='sequential')
-  DO ns=1,nats
-     stotale=0.
-     DO i=1,ncl
-        su=0.
-        DO j=1,nmode
-           nd=((j-1)*3)+1
-           nsi=((j-1)*3)+2
-           npi=((j-1)*3)+3
-           IF (solspe(ns,nd).EQ.0.)THEN
-              su_loc=0.
-           ELSE
-              xk=solspe(ns,npi)/(sqrt(2.*pi)*log(solspe(ns,nsi)))
-              xl=((log(sizeclass(i))-log(solspe(ns,nd)))**2) &
-     &              /(2.*(log(solspe(ns,nsi)))**2)
-              xm=xk*exp(-xl)
-              xn=rop*(2./3.)*(sizeclass(i)/2.)
-              su_loc=xm*newstep(i)/xn
-           END IF
-           su=su+su_loc
-        END DO
-        subsoildist(i)=su
-        stotale=stotale+su
-     END DO
-     DO i=1,ncl
-        IF (subsoildist(i).gt.0..and.stotale.gt.0.)THEN
-            srel(ns,i)=subsoildist(i)/stotale
-
-        ELSE
-            srel(ns,i)=0.
-        END IF
-!        WRITE(18,*)i,srel(1,i)
-     END DO
-!     PRINT*,'ns , srel(10000) ',ns,srel(ns,10000)
-  END DO
-
-
-! Calcul de la repartition de l energie feff(klon,ntyp)
-
-  !efficient fraction for the friction velocities as a function
-  !of z0s, Zo1 et Zo2 to retrieve the apparent threshold
-  !wind friction velocity.
-      !    feff(:,:)=0.
-       do i=1,klon
-          do k=1,ntyp
-     !     print*,'IKKK ',i,klon,k,ntyp
-             if (zos(i,k).eq.0..or.z01(i,k).eq.0.) then
-     !       if (zos(i,k)<=0..or.z01(i,k)<=0.) then
-!              if (zos(i,k)<0..or.z01(i,k)<0.) then
-     !            print*,'INI DUST WARNING zos ou z01<0',zos(i,k),z01(i,k)
-!              endif
-              feff(i,k)=0.
-              feffdbg(i,k)=0.
- !         print*,'IKKK A ',i,klon,k,ntyp
-            else
-! drag partition betzeen the erodable surface and zo1
-     !     print*,'IKKK B0 ',i,klon,k,ntyp,z01(i,k),zos(i,k),xeff,aeff
-              aa=log(z01(i,k)/zos(i,k))
-              tmp1(i,k)=aa
-              bb=log(aeff*(xeff/zos(i,k))**0.8)
-              cc=1.-aa/bb
-              feffdbg(i,k)=cc
-       !   print*,'IKKK B1 ',i,klon,k,ntyp
-! drag partition between zo1 and zo2
-! feff: total efficient fraction
-              if(D(i,k).eq.0.)then
-                 feff(i,k)=cc
-   !       print*,'IKKK C ',i,klon,k,ntyp
-              else
-                 dd=log(z02(i,k)/z01(i,k))
-                 ee=log(aeff*(D(i,k)/z01(i,k))**0.8)
-                 feff(i,k)=(1.-dd/ee)*cc
-   !       print*,'IKKK D ',i,klon,k,ntyp
-              endif
-              if (feff(i,k).lt.0.)feff(i,k)=0.
-              if (feffdbg(i,k).lt.0.)feffdbg(i,k)=0.
-              if (feff(i,k).gt.1.)feff(i,k)=1.
-              if (feffdbg(i,k).gt.1.)feffdbg(i,k)=1.
-    !      print*,'IKKK E ',i,klon,k,ntyp
-            endif
-          enddo
-        enddo
-! JE20150120<<
-  if (flag_feff .eq. 0) then
-    print *,'JE_dbg FORCED deactivated feff'
-    do i=1,klon
-      do k=1,ntyp
-        feff(i,k)=1.
-      enddo
-    enddo
-  endif
-! JE20150120>>
-
-
-if (1==1) then
-!  !  CALL writefield_phy("AA",tmp1(1:klon,1:5),5)
-!
-    CALL writefield_phy("REPART5",feff(1:klon,1:5),5)
-    CALL writefield_phy("REPART5dbg",feffdbg(1:klon,1:5),5)
-endif
-
-
-!c---------------FOR def_prepag01modif(var3a,var3b)-----------------------
-        p3t=0.0001
-        var1=e3**(1./3.)
-        var2=(rop*pi)**(1./3.)
-        var3a=trctunt*var1/var2
-        et=e1+(sqrt(p3t*(e3*e3+e1*e2-e2*e3-e1*e3))/p3t)
-        var1=et**(1./3.)
-        var2=(rop*pi)**(1./3.)
-        var3b=trctunt*var1/var2
-
-! JE20140902: comment all isograd distributions and make own massfrac:
-
-
-!  if (.false.) then
-!!**************L718
-!
-!!c------------------------------------------------------------------------
-!! isolog distrib and massfrac calculations.
-!
-!      nbinsout=nbins+1
-!      b1=log(sizedustmin)
-!      b2=log(sizedustmax)
-!! restricted ISOLOG bins distributions
-!
-!!      step=(b2-b1)/(nbinsout-1)
-!!      DO ni=1,nbinsout
-!!         itv(ni)=exp(b1+(ni-1)*step)
-!!      ENDDO
-!!OPEN(18,file='vdepothrsizbin.dat',form='formatted',access='sequential')
-!! Restricted ISOGRADIENT bins distributions
-!!!!!!!Making HIGH RESOLUTION dust size distribution (in um)!!!!!!
-!  stepbin=(b2-b1)/(nbinsHR-1)
-!  DO nb=1,nbinsHR
-!     binsHR(nb)=exp(b1+(nb-1)*stepbin)
-!  END DO
-!
-!  DO nb=1,nbinsHR
-!     binsHRcm(nb)=binsHR(nb)*1.e-4
-!  END DO
-!! Making HIGH RESOLUTION dry deposition velocity
-!     CALL calcvd(vdout)
-!
-!
-! DO nb=1,nbinsHR
-!     vdHR(nb)=vdout(nb)
-!!  WRITE(18,*),binsHR(nb),vdHR(nb)
-!  END DO
-!
-!   !searching for minimum value of dry deposition velocity
-!  minisograd=1.e20
-!  DO nb=1,nbinsHR
-!     IF(vdHR(nb).le.minisograd)THEN
-!       minisograd=vdHR(nb)
-!       miniso=nb
-!     END IF
-!  END DO
-!
-!! searching for optimal number of bins in positive slope Vd part
-!
-!  nbins1=1
-!  nbins2=nbinsout-1
-!     DO k=1,1000
-!        delta1=abs(log(vdHR(1))-log(vdHR(miniso)) )/nbins1
-!        delta2=abs(log(vdHR(nbinsHR))-log(vdHR(miniso)))/(nbins2-1)
-!        IF(delta2.GE.delta1)THEN
-!        GOTO 50
-!
-!        ELSE
-!           nbins2=nbins2-1
-!           nbins1=nbins1+1
-!        END IF
-!        IF(nbins2.EQ.1)THEN
-!           PRINT*,'!! warning: lower limit was found: STOP'
-!           STOP
-!        END IF
-!     END DO
-! 50  CONTINUE
-!print*,'IK10'
-!! building the optimized distribution
-!  logvdISOGRAD(1)=log(vdHR(1))
-!  binsISOGRAD(1)=binsHR(1)
-!  DO k=2,nbins1
-!     logvdISOGRAD(k)=logvdISOGRAD(1)-(k-1)*delta1
-!  END DO
-!
-!  logvdISOGRAD(nbins1+1)=log(minisograd)
-!
-!  DO k=1,nbins2
-!     logvdISOGRAD(nbins1+1+k)=logvdISOGRAD(nbins1+1)+k*delta2
-!  END DO
-!
-!  DO k=1,nbinsout
-!     vdISOGRAD(k)=exp(logvdISOGRAD(k))
-!  END DO
-!! sequential search of the correspondig particle diameter
-!  istart=1
-!  DO k=2,nbinsout-1
-!     curvd=vdISOGRAD(k)
-!     DO nb=istart,nbinsHR
-!        avdhr=vdHR(nb)
-!        bvdhr=vdHR(nb+1)
-!        IF(nb.LT.(miniso-1).AND.curvd.LT.avdhr.AND. &
-!           curvd.GT.bvdhr)THEN
-!           binsISOGRAD(k)=binsHR(nb)
-!           istart=nb
-!           GOTO 60
-!        END IF
-!        IF(nb.eq.miniso)THEN
-!           binsISOGRAD(k)=binsHR(nb)
-!           istart=nb+1
-!           GOTO 60
-!        END IF
-!        IF(nb.GT.miniso.AND.curvd.GT.avdhr.AND. &
-!                              curvd.LT.bvdhr)THEN
-!           binsISOGRAD(k)=binsHR(nb)
-!           istart=nb
-!           GOTO 60
-!        END IF
-!     END DO
-! 60  CONTINUE
-!  END DO
-!print*,'IK11'
-!  binsISOGRAD(nbinsout)=binsHR(nbinsHR)
-!  vdISOGRAD(nbinsout)=vdHR(nbinsHR)
-!  DO nb=1,nbinsout
-!     itv(nb)=binsISOGRAD(nb)
-!  END DO
-!  end ! JE20140902 if false
-
-! Making dust size distribution (in um)
-!
-      nbinsout=nbins+1
-      b1=log(sizedustmin)
-      b2=log(sizedustmax)
-      stepbin=(b2-b1)/(nbinsout-1)
-     DO ni=1,nbinsout
-        itv(ni)=exp(b1+(ni-1)*stepbin)
-     ENDDO
-
-!  stepbin=(b2-b1)/(nbinsHR-1)
-!  DO nb=1,nbinsHR
-!     binsHR(nb)=exp(b1+(nb-1)*stepbin)
-!  END DO
-!
-!  DO nb=1,nbinsHR
-!     binsHRcm(nb)=binsHR(nb)*1.e-4
-!  END DO
-
-
-
-      DO nb=1,nbins
-         ldmd=(log(itv(nb+1))-log(itv(nb)))/2.
-         sizedust(nb)=exp(log(itv(nb))+ldmd)
-        PRINT*,nb, itv(nb),' < ',sizedust(nb),' < ',itv(nb+1)
-      ENDDO
-! Making dust size distribution (in cm) ???
-      DO nb=1,nbins
-         szdcm(nb)=sizedust(nb)*1.e-4
-      ENDDO
-!c preparation of emissions reaffectation.
-      DO k=1,ndistb
-         exden=sqrt(2.)*log(sig(k))
-         DO nb=1,nbins
-            d2min=itv(nb)
-            d2max=itv(nb+1)
-            numin=log(d2min/diam(k))
-            numax=log(d2max/diam(k))
-            massfrac(k,nb)=0.5*(erf(numax/exden)-erf(numin/exden))
-            !print *,k,nb,massfrac(k,nb)
-         ENDDO
-      ENDDO
-
-!$OMP MASTER
-IF (is_mpi_root .AND. is_omp_root) THEN
-      OPEN (unit=15001, file='massfrac')
-      DO k=1,ndistb
-        DO nb=1,nbins
-            write(15001,*),k,nb,massfrac(k,nb)
-        ENDDO
-      ENDDO
-ENDIF
-!$OMP END MASTER
-!$OMP BARRIER
-
- !CALL abort_gcm('calcdustemission', 'OK1',1)
-
-  !------------
-
-
-  END SUBROUTINE initdust
-
-!--------------------------------------------------------------------------------------
-!======================================================================================
-!**************************************************************************************
-!======================================================================================
-!--------------------------------------------------------------------------------------
-
-  SUBROUTINE calcdustemission(debutphy,zu10m,zv10m,wstar, &
-                              ale_bl,ale_wake,param_wstarBL,param_wstarWAKE, &
-                              emisbin)
-  ! emisions over 12 dust bin
-  USE dimphy
-  USE infotrac
-
-  IMPLICIT NONE
-  ! Input
-  LOGICAL, INTENT(IN)                   :: debutphy ! First physiqs run or not
-  REAL,DIMENSION(klon),INTENT(IN)          :: zu10m   ! 10m zonal wind
-  REAL,DIMENSION(klon),INTENT(IN)          :: zv10m   ! meridional 10m wind
-  REAL,DIMENSION(klon),INTENT(IN)          :: wstar   
-  REAL,DIMENSION(klon),INTENT(IN)          :: ale_bl
-  REAL,DIMENSION(klon),INTENT(IN)          :: ale_wake
-  
-  ! Local variables
-!  INTEGER, PARAMETER :: flag_wstar=150
-!  INTEGER, PARAMETER :: flag_wstar=120
-!  INTEGER, PARAMETER :: flag_wstar=125
-  REAL,DIMENSION(klon), INTENT(IN) :: param_wstarWAKE
-  REAL,DIMENSION(klon), INTENT(IN) :: param_wstarBL
-  REAL,DIMENSION(:,:), ALLOCATABLE,SAVE :: fluxdust ! horizonal emission fluxes in UNITS for the nmod soil aerosol modes
-  REAL,DIMENSION(:), ALLOCATABLE,SAVE   :: wind10ms   ! 10m wind distribution in m/s
-  REAL,DIMENSION(:), ALLOCATABLE,SAVE   :: wind10cm   ! 10m wind distribution in cm/s
-  REAL,DIMENSION(klon)                  :: zwstar   
-  REAL,DIMENSION(nwb)                :: probu
-!  REAL, DIMENSION(nmode) :: fluxN,ftN,adN,fdpN,pN,eN ! in the original code N=1,2,3
-  REAL :: flux1,flux2,flux3,ft1,ft2,ft3
-
-
-  REAL, PARAMETER        :: umin=21.
-  REAL, PARAMETER        :: woff=0.5  ! min value of 10m wind speed accepted for emissions
-  REAL :: pdfcum,U10mMOD,pdfu,weilambda
-  REAL :: z0salt,ceff,cerod,cpcent
-  REAL :: cdnms,ustarns,modwm,utmin
-!JE20150202   REAL :: cdnms,ustarns,modwm
-  REAL :: fdp1,fdp2,ad1,ad2,ad3,flux_diam
-  REAL :: dfec1,dfec2,dfec3,t1,t2,t3,p1,p2,p3,dec,ec
-  ! auxiliar counters
-  INTEGER                               :: kwb
-  INTEGER                               :: i,j,k,l,n
-  INTEGER  :: kfin,ideb,ifin,kfin2,istep
-  REAL :: auxreal
-
-  ! Output
-  !REAL,DIMENSION(:,:), ALLOCATABLE,SAVE  :: emisbin ! vertical emission fluxes in UNITS for the 12 bins
-  REAL,DIMENSION(klon,nbins)  :: emisbin ! vertical emission fluxes in UNITS for the 12 bins
-!$OMP THREADPRIVATE(fluxdust) 
-!$OMP THREADPRIVATE(wind10ms) 
-!$OMP THREADPRIVATE(wind10cm) 
-
-  !----------------------------------------------------
-  ! initialization
-  !----------------------------------------------------
-  IF (debutphy) THEN
-!   ALLOCATE( emisbin(klon,nbins) )
-   ALLOCATE( fluxdust(klon,nmode) )
-   ALLOCATE( wind10ms(nwb) )
-   ALLOCATE( wind10cm(nwb) )
-  ENDIF !debutphy
-
-  
-  DO i=1,klon
-   DO j=1,nbins
-    emisbin(i,j)  = 0.0 
-   ENDDO !j,nbind
-   DO j=1,nmode
-    fluxdust(i,j) = 0.0
-   ENDDO !j,nmode
-  zwstar(i) = 0.0
-  ENDDO !i,klon
-  !----------------------------------------------------
-  ! calculations
-  !----------------------------------------------------
-
-  ! including BL processes..
-!JE201041120  zwstar=sqrt(2.*(ale_bl+0.01*(flag_wstar-100)*ale_wake))
-!JE20141124  zwstar=sqrt(2.*(flag_wstarBL*ale_bl+0.01*(flag_wstar-100)*ale_wake))
-!  print
-!*,'zwstar=sqrt(2.*(',flag_wstarBL,'ale_bl+0.01*(',flag_wstar,'-100)*ale_wake))'
-  !
-    DO i=1,klon  ! main loop
-     zwstar(i)=sqrt(2.*(param_wstarBL(i)*ale_bl(i)+param_wstarWAKE(i)*ale_wake(i)))
-     U10mMOD=MAX(woff,sqrt(zu10m(i)*zu10m(i)+zv10m(i)*zv10m(i)))
-     pdfcum=0.
-     ! Wind weibull distribution:
-
-           DO kwb=1,nwb
-                flux1=0.
-                flux2=0.
-                flux3=0.
-!JE20141205<< differences in weibull distribution: expectance of the distribution is
-!0.89*U10mMODD instead of U10mMOD
-! now: lambda parameter of weibull ditribution is estimated as
-! lambda=U10mMOD/gamma(1+1/kref)
-! gamma function estimated with stirling formula
-                auxreal=1.+1./kref
-                weilambda = U10mMOD/exp(auxreal*log(auxreal)-auxreal &
-                         - 0.5*log(auxreal/(2.*pi))+1./(12.*auxreal) &
-                         -1./(360.*(auxreal**3.))+1./(1260.*(auxreal**5.)))
-                IF(nwb.gt.1)THEN
-                   wind10ms(kwb)=kwb*2.*U10mMOD/nwb
-!original
-!                   pdfu=(kref/U10mMOD)*(wind10ms(kwb)/U10mMOD)**(kref-1) &
-!                      *exp(-(wind10ms(kwb)/U10mMOD)**kref)
-                   pdfu=(kref/weilambda)*(wind10ms(kwb)/weilambda)**(kref-1) &
-                      *exp(-(wind10ms(kwb)/weilambda)**kref)
-!                   !print *,'JEdbg  U10mMOD weilambda  ',U10mMOD,weilambda
-!JE20141205>>
-
-                   probu(kwb)=pdfu*2.*U10mMOD/nwb
-                   pdfcum=pdfcum+probu(kwb)
-                      IF(probu(kwb).le.1.e-2)GOTO 70
-                ELSE
-                   wind10ms(kwb)=U10mMOD
-                   probu(kwb)=1.
-                ENDIF
-             wind10cm(kwb)=wind10ms(kwb)*100.
-             DO n=1,ntyp
-                   ft1=0.
-                   ft2=0.
-                   ft3=0.
-!JE20150129<<<<
-
-             IF(.FALSE.) THEN
-!                  nat=int(sol(i,n))
-!                    print *,i,n
-                    IF(sol(i,n).gt.1..and.sol(i,n).lt.15.) nat=int(sol(i,n))
-!JE20140526<<
-!                    print *,'JE: WARNING: nat=0 forced to nat=99!! and doing nothing'
-                   IF(sol(i,n).lt.0.5) THEN
-                      nat=99
-                      GOTO 80
-                    ENDIF
-!JE20140526>>
- 
-
-                 !IF(n.eq.1.and.nat.eq.99)GOTO 80
-             !      if(n.eq.1) print*,'nat1=',nat,'sol1=',sol(i,n)
-                   IF(n.eq.1.and.nat.eq.99)GOTO 80
-
-             ENDIF
-             IF(.TRUE.) THEN
-                nat=int(sol(i,n))
-                if(n == 1 .and. nat >= 14 .or. nat < 1 .or. nat > 19) GOTO 80
-             ENDIF
-!JE20150129>>>>
-
-                      z0salt=z02(i,n)
-                      ceff=feff(i,n)
-                      cerod=A(i,n)
-                      cpcent=P(i,n)
-                      ustarsalt=0.
-                   IF(ceff.le.0..or.z0salt.eq.0.)GOTO 80
-                   IF(cerod.eq.0.or.cpcent.eq.0.)GOTO 80
-! in cm: utmin, umin, z10m, z0salt, ustarns
-! in meters: modwm
-! no dimension for: cdnms
-! Cas ou wsta=0.
-                      cdnms=vkarm/(log(z10m/z0salt))
-                      modwm=sqrt((wind10ms(kwb)**2)+(1.2*zwstar(i))**2)
-                      ustarns=cdnms*modwm*100.
-                    ustarsalt=ustarns
-
-
-                   IF(ustarsalt.lt.umin/ceff)GOTO 80
-!                      print*,'ustarsalt = ',ustarsalt
-!----------------------------------------
-                    CALL def_copyncl(kfin)
-
-!                  CALL def_ag01(kfin,ft1,ft2,ft3)
-      do ni=1,kfin
-         fdp1=1.-(uth2(ni)/(ceff*ustarsalt))
-         if (fdp1.le.0..or.srel2(nat,ni).eq.0.) then
-            ad1=0.
-            ad2=0.
-            ad3=0.
-         else
-       
-            fdp2=(1.+(uth2(ni)/(ceff*ustarsalt)))**2.
-            flux_diam=cd*srel2(nat,ni)*fdp1*fdp2*(ustarsalt**3)
-            dec=flux_diam*beta
-            ec=(pi/3.)*1.e+2*rop* (sizeclass2(ni)**3) *(ustarsalt**2)
-            dfec1=(ec-e1)
-            dfec2=(ec-e2)
-            dfec3=(ec-e3)
-            t1=0.
-            t2=0.
-            t3=0.
-            if(ec.ge.e1)t1=1.
-            if(ec.ge.e2)t2=1.
-            if(ec.ge.e3)t3=1.
-            if(dfec3.ne.0.)then
-               p1=t1*dfec1/dfec3
-               p2=t2*(1.-p1)*dfec2/dfec3
-            else
-               p1=0.
-               p2=0.
-            endif
-            p3=t3*(1.-p1-p2)
-            ad1=(pi/6.)*dec*rop*p1*((diam(1)*1.e-4)**3.)/e1
-            ad2=(pi/6.)*dec*rop*p2*((diam(2)*1.e-4)**3.)/e2
-            ad3=(pi/6.)*dec*rop*p3*((diam(3)*1.e-4)**3.)/e3
-
-         endif
-         ft1=ft1+ad1
-         ft2=ft2+ad2
-         ft3=ft3+ad3
-      enddo ! of loop over nc
-
-!....
-
-        flux1=flux1+ft1*cpcent*cerod
-        flux2=flux2+ft2*cpcent*cerod
-        flux3=flux3+ft3*cpcent*cerod
-!       print *,'JEflux :',kwb,n,flux1,flux2,flux3
-80 CONTINUE
-             ENDDO !n=1,ntyp
-70 CONTINUE
-        fluxdust(i,1)=fluxdust(i,1)+flux1*probu(kwb)
-        fluxdust(i,2)=fluxdust(i,2)+flux2*probu(kwb)
-        fluxdust(i,3)=fluxdust(i,3)+flux3*probu(kwb)
-   ENDDO !kwb=1,nwb
-      m1dflux(i)=10.*fluxdust(i,1)
-      m2dflux(i)=10.*fluxdust(i,2)          ! tous en Kg/m2/s
-      m3dflux(i)=10.*fluxdust(i,3)
-
-
-
-    ENDDO  ! i, klon
-
-
-
-   
-  !from horizontal to  vertical fluxes for each bin
-  DO k=1,klon
-   DO i=1,ndistb
-    DO j=1,nbins
-!JE20150202 <<
-    emisbin(k,j) = emisbin(k,j)+10*fluxdust(k,i)*massfrac(i,j)  
-!JE20150202 >>
-    ENDDO !j, nbind
-   ENDDO  !i, nmode
-  ENDDO !k,klon
-
-
-!print *,' JE fluxdust in calcdust'
-! DO k=1,klon
-!   DO i=1,ndistb
-!!print *,k,i,fluxdust(k,i)
-!enddo
-!enddo
-!print *,' JE emisbin in calcdust'
-!do k=1,klon
-!do j=1,nbins
-!!print *,k,j,emisbin(k,j)
-!enddo
-!enddo 
-!  CALL abort_gcm('calcdustemission', 'OK1',1)
-
-  END SUBROUTINE calcdustemission
-!--------------------------------------------------------------------------------------
-!======================================================================================
-!**************************************************************************************
-!======================================================================================
-!--------------------------------------------------------------------------------------
-
-
-
-SUBROUTINE def_copyncl(kfin)
-      implicit none
-
- integer i,n,kfin,ideb,ifin,istep,kfin2
-    real dsmin,dsmax
-
-! estimation of the reduced soil size distribution
-         dsmin=var3a*(ustarsalt**(-2./3.))
-         dsmax=var3b*(ustarsalt**(-2./3.))
-!      print*,'ustarsalt = ',ustarsalt,'dsmin=',dsmin,'dsmax=',dsmax
-! dichotomy
-         call def_dichotomy(sizeclass,nclass,1,ncl,dsmin,ideb)
-   !      print*,'ideb = ',ideb
-         call def_dichotomy(sizeclass,nclass,ideb,ncl,dsmax,ifin)
-   !      print*,'ifin = ',ifin
-! readaptation of large sizes particles
-         kfin=0
-         do i=ideb,ifin
-            kfin=kfin+1
-            sizeclass2(kfin)=sizeclass(i)
-            uth2(kfin)=uth(i)
-            srel2(nat,kfin)=srel(nat,i)
-         enddo
-  !          print*,'je suis la'
-         kfin2=kfin
-         istep=50
-         do i=ifin,ncl,istep
-            kfin=kfin+1
-            sizeclass2(kfin)=sizeclass(i)
-            uth2(kfin)=uth(i)
-            srel2(nat,kfin)=srel(nat,i)*istep
-         enddo
-         if(kfin.ge.nclass)then
-            print*,'$$$$ Tables dimension problem:',kfin,'>',nclass
-         endif
-!---------------        
-
-      return
-END SUBROUTINE def_copyncl
-
-!--------------------------------------------------------------------------------------
-!======================================================================================
-!**************************************************************************************
-!======================================================================================
-!--------------------------------------------------------------------------------------
-
-subroutine def_dichotomy(siz,nclass,i1,i2,ds,iout)
-!c---------------------------------------------------------------
-!c 'size' is the table to scan
-!c      of dimension 'nclass', and reduced size of interest [i1:i2]
-!c 'ds' is the value to find in 'size'
-!c 'iout' is the number in the table 'size' correspondig to 'ds'
-!c---------------------------------------------------------------
-
-      implicit none
-      integer i1,i2,nclass,iout,ismin,ismax,k2,ihalf,idiff
-      real siz(nclass),ds
-!c-----------------------------
-      iout=0
-      ismin=i1
-      ismax=i2
-      ihalf=int((ismax+ismin)/2.)
-      do k2=1,1000000
-          if(ds.gt.siz(ihalf))then
-             ismin=ihalf
-          else
-             ismax=ihalf
-          endif
-          ihalf=int((ismax+ismin)/2.)
-          idiff=ismax-ismin
-          if(idiff.le.1)then
-             iout=ismin
-             goto 52
-          endif
-      enddo
- 52   continue
-      if(iout.eq.0)then
-        print*,'$$$$ Tables dimension problem: ',iout
-      endif
-
-      end subroutine def_dichotomy
-
-!--------------------------------------------------------------------------------------
-!======================================================================================
-!**************************************************************************************
-!======================================================================================
-!--------------------------------------------------------------------------------------
-
-
-  SUBROUTINE calcvd(vdout)
-  IMPLICIT NONE
-  INTEGER                     :: nb
-!JE already def in module  INTEGER,PARAMETER           :: nbinsHR=3000
-  INTEGER,PARAMETER           :: idiffusi=1
-  INTEGER,PARAMETER           :: idrydep=2
-  REAL                        :: dmn1,dmn2,dmn3,ra,rb
-  REAL                        :: rhod,muair,nuair,R,airmolw
-  REAL                        :: bolz,rhoair,gravity,karman,zed,z0m
-  REAL                        :: ustarbin,temp,pres,rac,lambda,ccexp
-  REAL                        :: Cc,rexp,pi,St
-  REAL,DIMENSION(nbinsHR)     :: setvel
-  REAL,DIMENSION(nbinsHR)     :: diffmol1
-  REAL,DIMENSION(nbinsHR)     :: diffmol2
-  REAL,DIMENSION(nbinsHR)     :: schmidtnumb
-  REAL,DIMENSION(nbinsHR)     :: diffmole
-
-  REAL,DIMENSION(nbinsHR),   INTENT(OUT)              :: vdout
-! users physical parameters
-       temp=273.15+25. ! in Kelvin degrees
-       pres=1013. ! in hPa
-! calculation of Ra
-       zed=10.
-       z0m=0.05
-       karman=0.41
-       ustarbin=30. ! cm/s
-       ra=log(zed/z0m)/(karman*ustarbin)
-!c physical constants (all must in units g / cm / s)
-       rhod=2.65                 ! g.cm-3
-       muair=1.72e-4             ! g.cm-1.s-1
-       nuair=0.1461              ! air kinematic viscosity [cm2.s-1]
-       R=8.314                   ! molar gas constant J.mol-1.K-1
-       airmolw=28.8              ! molar weight of air
-       bolz=1.38e-16                    ! g.cm2.s-2
-       rhoair=1.225e-3                  ! g.cm-3
-       gravity=981.                ! gravity [cm.s-2]
-       pi=3.14159
-       rac=sqrt(8.0*airmolw/(pi*R*temp))
-       lambda=(2.*muair)/(pres*rac)
-! c Cc and Vs
-!       binsHRcm=binsize*1.e-4
-       DO nb=1,nbinsHR
-       ccexp=exp((-0.55*binsHRcm(nb))/lambda)
-       Cc=1.+(2.*lambda)/binsHRcm(nb)*(1.257+0.4*ccexp)
-       setvel(nb)=(1./18.)*((binsHRcm(nb))**2*rhod*gravity*Cc)/muair
-!c Molecular diffusivity (s/cm2) and Schmidt number
-!c Note that the molecular diffusivity uses diameter in micro-m
-!c to give a result directly in s/cm2
-       dmn1=2.38e-7/binsHR(nb)
-       dmn2=0.163/binsHR(nb)
-       dmn3=0.0548*exp(-6.66*binsHR(nb))/binsHR(nb)
-       diffmol1(nb)=dmn1*(1.+dmn2+dmn3)
-       diffmol2(nb)=bolz*temp*Cc/(3.*pi*muair*binsHRcm(nb))
-       IF(idiffusi.EQ.1)diffmole(nb)=diffmol1(nb)
-       IF(idiffusi.EQ.2)diffmole(nb)=diffmol2(nb)
-       schmidtnumb(nb)=nuair/diffmole(nb)
-       St=setvel(nb)*ustarbin*ustarbin/(gravity*nuair)
-       rb=1./(ustarbin*((schmidtnumb(nb))**(-2./3.)+10.**(-3./St)))
-!c wesely (primarily designed for gases)
-       IF(idrydep.EQ.1)THEN
-          vdout(nb)=1./(ra+rb+ra*rb*setvel(nb))+setvel(nb)
-       END IF
-!c venkatram and pleim (more adaptated to particles but numerically unstable)
-       IF(idrydep.EQ.2)THEN
-        rexp=exp(-(ra+rb)*setvel(nb))
-        vdout(nb)=setvel(nb)/(1.-rexp)
-       END IF
-       END DO
-!c-----------------
-       RETURN
-      END SUBROUTINE calcvd
-
-
-
-END MODULE dustemission_mod
-
Index: /LMDZ6/trunk/libf/phylmd/Dust/dustemission_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/Dust/dustemission_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/Dust/dustemission_mod.f90	(revision 5268)
@@ -0,0 +1,1543 @@
+MODULE dustemission_mod
+
+  IMPLICIT NONE
+  !Parameters   
+!  INTEGER, PARAMETER     :: nbins=12  ! number of aerosol bins: original 
+!  INTEGER, PARAMETER     :: nbins=800  ! number of aerosol bins: for spla
+!  INTEGER, PARAMETER     :: nbins=8000  ! number of aerosol bins: for spla
+  
+  INTEGER, PARAMETER     :: flag_feff=1 ! 0: deactivate feff (drag partition scheme)
+  INTEGER, PARAMETER     :: nbins=800  ! number of aerosol bins: for spla
+  INTEGER, PARAMETER     :: nmode=3   ! number of soil-dust modes 
+  INTEGER, PARAMETER     :: ntyp=5   ! number of soil types 
+  INTEGER, PARAMETER     :: nwb=12   ! number of points for the 10m wind
+! speed weibull distribution (>=2)
+  real   ,parameter     :: z10m=1000. !10m in cm
+  REAL,PARAMETER         :: kref=3. !weibull parameter
+  INTEGER, PARAMETER    :: nats=14 !number of mineral types (14 here for sand,
+                                   ! silt, clay etc.)
+  integer, parameter :: nclass=200000
+
+
+  real   , parameter :: dmin=0.0001
+  real   , parameter :: dmax=0.2
+  integer, parameter :: nspe=nmode*3+1
+  real   ,parameter     :: vkarm=0.41
+!JE20150202 : updating scheme to chimere13b <<<
+! original values
+!  integer, parameter :: div1=3.
+!  integer, parameter :: div2=3.
+!  integer, parameter :: div3=3.
+!  real   , parameter :: e1=3.61/div1
+!  real   , parameter :: e2=3.52/div2
+!  real   , parameter :: e3=3.46/div3
+!  real   , parameter :: rop=2.65 ! particle density g/m3
+!  real   , parameter :: roa=0.001227  ! air density g/m3
+!  real   , parameter :: pi=3.14159  !!
+!  real   , parameter :: gravity=981. !! cm!!
+!  real   , parameter :: cd=1.*roa/gravity
+! new values
+!  logical, parameter :: ok_splatuning=.true.
+! Div=3 from S. Alfaro (Sow et al ACPD 2011)
+!JE 20150206
+!  integer, parameter :: div1=3.
+!  integer, parameter :: div2=3.
+!  integer, parameter :: div3=3.
+  integer, parameter :: div1=6.
+  integer, parameter :: div2=6.
+  integer, parameter :: div3=6.
+  real   , parameter :: e1=3.61/div1
+  real   , parameter :: e2=3.52/div2
+  real   , parameter :: e3=3.46/div3
+  real   , parameter :: rop=2.65 ! particle density g/m3
+  real   , parameter :: roa=0.001227  ! air density g/m3
+  real   , parameter :: pi=3.14159  !!
+  real   , parameter :: gravity=981. !! cm!!
+! C=2.61 from Marticorena and Bergametti 1995 instead of Gillete and Chen 2001
+! (recommended C=1.1  in supply-limited dust source area.. )
+   real   , parameter :: cd=2.61*roa/gravity
+!  real   , parameter :: cd=1.0*roa/gravity
+!JE20150202>>>>
+  real,parameter     :: beta=16300.
+  real, parameter, dimension(3) :: diam=(/1.5,6.7,14.2/)
+  INTEGER, PARAMETER     :: ndistb=3
+  real, parameter, dimension(3) :: sig=(/1.7,1.6,1.5/)
+
+!   INTEGER, PARAMETER     :: nbinsHR=3000 !original
+   INTEGER, PARAMETER     :: nbinsHR=30000
+!min and max dust size in um
+      REAL, PARAMETER     :: sizedustmin=0.0599 ! for spla
+      REAL, PARAMETER     :: sizedustmax=63.
+!      REAL, PARAMETER     :: sizedustmin=0.09  ! original
+!      REAL, PARAMETER     :: sizedustmax=63.
+
+
+  ! Calc variables
+  REAL,DIMENSION(:,:), ALLOCATABLE,SAVE  :: massfrac
+  REAL,DIMENSION(:),  ALLOCATABLE,SAVE :: binsHR
+  REAL,DIMENSION(:),  ALLOCATABLE,SAVE :: binsHRcm
+  REAL,DIMENSION(:),  ALLOCATABLE,SAVE :: itv
+  REAL,DIMENSION(:),  ALLOCATABLE,SAVE :: sizedust !size dust bin (in um)
+  REAL,DIMENSION(:),  ALLOCATABLE,SAVE :: szdcm !the same but (in cm)
+
+  !soil inputs from file donnees_lisa.nc . Should be in the same grid as the
+  !model (regridded with nearest neighborhood from surfnew.nc)
+  REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: sol
+  REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: P
+  REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: zos
+  REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: z01
+  REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: z02
+  REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: D
+  REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: A
+  REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: solspe
+  INTEGER,DIMENSION(:,:),ALLOCATABLE,SAVE :: masklisa
+!!!  INTEGER,DIMENSION(:),ALLOCATABLE,SAVE :: maskdust
+  REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: feff
+  REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: feffdbg
+
+  REAL,DIMENSION(:),  ALLOCATABLE,SAVE :: sizeclass 
+  REAL,DIMENSION(:),  ALLOCATABLE,SAVE :: sizeclass2 
+  REAL,DIMENSION(:),  ALLOCATABLE,SAVE :: uth
+  REAL,DIMENSION(:),  ALLOCATABLE,SAVE :: uth2
+  REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: srel
+  REAL,DIMENSION(:,:),  ALLOCATABLE,SAVE :: srel2
+
+  INTEGER :: nat ! SOL data inside the loop (use as soil type index?)
+  REAL :: ustarsalt 
+  REAL :: var3a,var3b
+  INTEGER  :: ns,nd,nsi,npi,ni ! counters
+  INTEGER :: ncl
+
+! outputs
+  REAL,DIMENSION(:),  ALLOCATABLE,SAVE :: m1dflux !fluxes for each soil mode
+  REAL,DIMENSION(:),  ALLOCATABLE,SAVE :: m2dflux
+  REAL,DIMENSION(:),  ALLOCATABLE,SAVE :: m3dflux
+
+
+
+!$OMP THREADPRIVATE(m1dflux)
+!$OMP THREADPRIVATE(m2dflux)
+!$OMP THREADPRIVATE(m3dflux)
+!$OMP THREADPRIVATE(massfrac) 
+!$OMP THREADPRIVATE(binsHR) 
+!$OMP THREADPRIVATE(binsHRcm) 
+!$OMP THREADPRIVATE(itv) 
+!$OMP THREADPRIVATE(sizedust) 
+!$OMP THREADPRIVATE(szdcm) 
+!$OMP THREADPRIVATE(sol) 
+!$OMP THREADPRIVATE(P) 
+!$OMP THREADPRIVATE(zos) 
+!$OMP THREADPRIVATE(z01) 
+!$OMP THREADPRIVATE(z02) 
+!$OMP THREADPRIVATE(D) 
+!$OMP THREADPRIVATE(A) 
+!$OMP THREADPRIVATE(solspe) 
+!$OMP THREADPRIVATE(masklisa) 
+!!!!$OMP THREADPRIVATE(maskdust) 
+!$OMP THREADPRIVATE(feff) 
+!$OMP THREADPRIVATE(feffdbg) 
+!$OMP THREADPRIVATE(sizeclass) 
+!$OMP THREADPRIVATE(sizeclass2) 
+!$OMP THREADPRIVATE(uth) 
+!$OMP THREADPRIVATE(uth2) 
+!$OMP THREADPRIVATE(srel) 
+!$OMP THREADPRIVATE(srel2) 
+
+
+
+  CONTAINS
+
+!--------------------------------------------------------------------------------------
+!======================================================================================
+!**************************************************************************************
+!======================================================================================
+!--------------------------------------------------------------------------------------
+
+  SUBROUTINE dustemis_out_init()
+
+    USE dimphy
+
+    !AS: moved here from subroutine initdust
+    ALLOCATE( m1dflux(klon) )
+    ALLOCATE( m2dflux(klon) )
+    ALLOCATE( m3dflux(klon) )
+
+  END SUBROUTINE dustemis_out_init
+
+  SUBROUTINE dustemission( debutphy, xlat, xlon, &    !Input
+                          pctsrf,zu10m,zv10m,wstar, & !Input
+                          ale_bl,ale_wake, &          !Input
+                          param_wstarBL, param_wstarWAKE, &  !Input
+                          emdustacc,emdustcoa,emdustsco,maskdust)    !Output
+  USE dimphy
+  USE infotrac
+  USE write_field_phy
+  USE mod_grid_phy_lmdz
+  USE mod_phys_lmdz_para
+  USE indice_sol_mod
+
+  IMPLICIT NONE
+  ! input :
+  ! output: flux_sparam_ddfine,flux_sparam_ddcoa,
+  ! first: 
+  ! Model grid parameters
+  REAL,DIMENSION(klon),     INTENT(IN)     :: xlat
+  REAL,DIMENSION(klon),     INTENT(IN)     :: xlon
+  REAL,DIMENSION(klon,nbsrf), INTENT(IN)     :: pctsrf
+  REAL,DIMENSION(klon),INTENT(IN)          :: zu10m   ! 10m zonal wind
+  REAL,DIMENSION(klon),INTENT(IN)          :: zv10m   ! meridional 10m wind
+  REAL,DIMENSION(klon),INTENT(IN)          :: wstar
+  REAL,DIMENSION(klon),INTENT(IN)          :: ale_bl
+  REAL,DIMENSION(klon),INTENT(IN)          :: ale_wake
+  REAL,DIMENSION(klon), INTENT(IN) :: param_wstarWAKE
+  REAL,DIMENSION(klon), INTENT(IN) :: param_wstarBL
+ 
+ 
+  LOGICAL  :: debutphy ! First physiqs run or not
+  ! Intermediate variable: 12 bins emissions
+  REAL,DIMENSION(:,:), ALLOCATABLE,SAVE  :: emisbinloc ! vertical emission fluxes
+
+  !OUT variables
+  REAL,DIMENSION(klon)  :: emdustacc,emdustcoa,emdustsco ! emission in spla dust bins:
+! old radio : acc=0.03-0.5 micrometers, ccoa:0.5-10 micrometers
+! new acc=0.03-0.5 micrometers, coa:0.5-3 micrometers ,sco:3-15 um
+  INTEGER,DIMENSION(klon) :: maskdust ! where the emissions were calculated
+!  INTEGER,DIMENSION(klon_glo) :: maskdust_glo ! auxiliar 
+!  REAL,DIMENSION(klon_glo) :: raux_klon_glo ! auxiliar 
+
+!$OMP THREADPRIVATE(emisbinloc)
+!!!!!!$OMP THREADPRIVATE(maskdust)
+  IF (debutphy) THEN
+     ALLOCATE( emisbinloc(klon,nbins) )
+  ENDIF
+
+  IF( debutphy ) THEN  
+     CALL initdust(xlat,xlon,pctsrf)
+  ENDIF
+
+!JE20141124  CALL  calcdustemission(debutphy,zu10m,zv10m,wstar,ale_bl,ale_wake,emisbinloc)
+  CALL  calcdustemission(debutphy,zu10m,zv10m,wstar,ale_bl,ale_wake,param_wstarBL,param_wstarWAKE, & !I
+                         emisbinloc)   !O
+
+  CALL makemask(maskdust)
+
+  IF( debutphy ) THEN  
+!       call gather(maskdust,maskdust_glo)
+!     !$OMP MASTER
+!     IF (is_mpi_root .AND. is_omp_root) THEN
+!       CALL writefield_phy("maskdust",float(maskdust_glo),1)
+       CALL writefield_phy("maskdust",float(maskdust),1)
+!     ENDIF
+!     !$OMP END MASTER
+!     !$OMP BARRIER
+  ENDIF
+
+  !CALL adaptdustemission(debutphy,emisbinloc,emdustacc,emdustcoa,emdustsco)
+  CALL adaptdustemission(debutphy,emisbinloc,emdustacc,emdustcoa,emdustsco,maskdust,pctsrf)
+  ! output in kg/m2/s
+
+
+  END SUBROUTINE dustemission
+
+!--------------------------------------------------------------------------------------
+!======================================================================================
+!**************************************************************************************
+!======================================================================================
+!--------------------------------------------------------------------------------------
+
+ SUBROUTINE makemask(maskdustloc) 
+  USE dimphy
+  USE infotrac
+  IMPLICIT NONE
+  !Input
+  INTEGER,DIMENSION(klon) :: maskdustloc
+  INTEGER :: i,j,k
+  integer :: iaux
+ 
+
+  do k=1,klon
+      maskdustloc(k)=0
+      do i=1,ntyp
+         if (masklisa(k,i)>0) then
+             maskdustloc(k)=1
+         endif
+      enddo
+  enddo
+
+  END SUBROUTINE makemask
+
+!--------------------------------------------------------------------------------------
+!======================================================================================
+!**************************************************************************************
+!======================================================================================
+!--------------------------------------------------------------------------------------
+
+ SUBROUTINE adaptdustemission(debutphy,emisbinlocal, &
+                emdustacc,emdustcoa,emdustsco,maskdust,pctsrf)
+!                               emdustacc,emdustcoa,emdustsco)
+
+  USE dimphy
+  USE infotrac
+  USE write_field_phy
+  USE mod_grid_phy_lmdz
+  USE mod_phys_lmdz_para
+  USE indice_sol_mod
+
+  IMPLICIT NONE
+  !Input
+  REAL,DIMENSION(klon) :: emdustacc,emdustcoa,emdustsco
+  REAL, DIMENSION(klon,nbins) :: emisbinlocal
+  ! Local
+  INTEGER  :: i,j,k
+!!!  INTEGER,DIMENSION(2) :: iminacclow,iminacchigh,imincoalow,imincoahigh ! in
+!case of small nbins.... not ready
+  INTEGER,SAVE ::iminacclow,iminacchigh,imincoalow
+  INTEGER,SAVE ::imincoahigh,iminscohigh,iminscolow
+  INTEGER,DIMENSION(klon) :: maskdust ! where the emissions were calculated
+  REAL,DIMENSION(klon,nbsrf),     INTENT(IN)     :: pctsrf
+!  real,parameter :: sizeacclow=0.03
+!  real,parameter :: sizeacchigh=0.5
+!  real,parameter :: sizecoalow=0.5
+!  real,parameter :: sizecoahigh=10.  ! in micrometers
+  real,parameter :: sizeacclow=0.06
+  real,parameter :: sizeacchigh=1.0
+  real,parameter :: sizecoalow=1.0
+  real,parameter :: sizecoahigh=6.  !20 ! diameter in micrometers
+  real,parameter :: sizescolow=6.
+  real,parameter :: sizescohigh=30.  ! in micrometers
+!--------------------------------
+!  real,parameter :: tuningfactorfine=0.9  ! factor for fine bins!!! important!!
+  real,parameter :: tuningfactorfine=0.8  ! factor for fine bins!!! important!!
+!  real,parameter :: tuningfactorfine=4.5  ! factor for fine bins!!! important!!
+!  real,parameter :: tuningfactorcoa=3.6 ! factor for coarse bins!!! important!!
+  real,parameter :: tuningfactorcoa=3.25 ! factor for coarse bins!!! important!!
+!  real,parameter :: tuningfactorcoa=4.5  ! factor for coarse bins!!! important!!
+!  real,parameter :: tuningfactorsco=3.6  ! factor for supercoarse bins!!! important!!
+  real,parameter :: tuningfactorsco=3.25  ! factor for supercoarse bins!!! important!!
+!  real,parameter :: tuningfactorsco=4.5  ! factor for supercoarse bins!!! important!!
+  real,parameter :: basesumemission= 0.0  !1.e-6  ! emissions to SUM to each land pixel FOR ASSIMILATION ONLY important!!  in mg/m2/s, per bin
+ !basesumemission = 1.e-6 increase the AOD in about 12%  (0.03 of AOD) , 
+ !while 1e-8 increase in about 0.12%  (0.003 of AOD)
+
+  real,dimension(klon) :: basesumacc,basesumcoa,basesumsco
+!--------------------------------
+!JE20140915  real,parameter :: sizeacclow=0.06
+!JE20140915  real,parameter :: sizeacchigh=1.0
+!JE20140915  real,parameter :: sizecoalow=1.0
+!JE20140915  real,parameter :: sizecoahigh=10.  !20 ! diameter in micrometers
+!JE20140915  real,parameter :: sizescolow=10.
+!JE20140915  real,parameter :: sizescohigh=30.  ! in micrometers
+
+
+
+  logical ::  debutphy
+  real :: diff, auxr1,auxr2,auxr3,auxr4
+  real,dimension(klon,nbins) :: itvmean
+  real,dimension(klon,nbins+1) :: itv2
+!  real,dimension(klon_glo,nbins) :: itvmean_glo
+!  real,dimension(:,:) , allocatable  :: itvmean_glo
+!  real,dimension(:,:), allocatable :: itv2_glo
+  
+  integer, save :: counter,counter1 !dbg
+  REAL, DIMENSION(:,:),ALLOCATABLE,SAVE :: emisbinlocalmean,emisbinlocalmean2 !dbg
+  REAL, DIMENSION(:,:),ALLOCATABLE :: emisbinlocalmean2_glo 
+  logical :: writeaerosoldistrib
+!$OMP THREADPRIVATE(iminacclow,iminacchigh,imincoalow,imincoahigh)
+
+writeaerosoldistrib=.false.
+if (debutphy) then
+
+  if (sizedustmin>sizeacclow .or. sizedustmax<sizescohigh) then 
+   call abort_physic('adaptdustemission', 'Dust range problem',1)
+  endif
+  print *,'FINE DUST BIN: tuning EMISSION factor= ',tuningfactorfine
+  print *,'COA DUST BIN: tuning EMISSION factor= ',tuningfactorcoa
+  print *,'SCO DUST BIN: tuning EMISSION factor= ',tuningfactorsco
+  print *,'ALL DUST BIN: SUM to the emissions (mg/m2/s) = ',basesumemission
+  auxr1=9999.
+  auxr2=9999.
+  auxr3=9999.
+  auxr4=9999.
+  do i=1,nbins+1
+   if (abs(sizeacclow-itv(i))<auxr1) then
+          auxr1=abs( sizeacclow-itv(i))
+          iminacclow=i
+   endif
+   if (abs(sizeacchigh-itv(i))<auxr2) then
+          auxr2=abs( sizeacchigh-itv(i))
+          iminacchigh=i
+          imincoalow=i
+   endif
+   if (abs(sizecoahigh-itv(i))<auxr3) then
+          auxr3=abs( sizecoahigh-itv(i))
+          imincoahigh=i
+          iminscolow=i
+   endif
+   if (abs(sizescohigh-itv(i))<auxr4) then
+          auxr4=abs( sizescohigh-itv(i))
+          iminscohigh=i
+   endif
+  enddo
+if (writeaerosoldistrib) then
+!JEdbg<<
+  do j=1,klon
+  do i=1,nbins
+    itvmean(j,i)=(itv(i)+itv(i+1))/2.
+    itv2(j,i)=itv(i)
+    !print*, itv(i),itvmean(i),itv(i+1)
+    !print*, sizedust(i)
+  enddo
+  itv2(j,nbins+1)=itv(nbins+1)
+  enddo
+!  allocate(itv2_glo(klon_glo,nbins+1))
+!  allocate(itvmean_glo(klon_glo,nbins))
+!  ALLOCATE(emisbinlocalmean2_glo(klon_glo,nbins))
+!  call gather(itv2,itv2_glo)
+!  call gather(itvmean,itvmean_glo)
+!!$OMP MASTER
+!  IF (is_mpi_root .AND. is_omp_root) THEN
+!  CALL writefield_phy("itv2",itv2_glo,nbins+1)
+!  CALL writefield_phy("itvmean",itvmean_glo,nbins)
+  CALL writefield_phy("itv2",itv2,nbins+1)
+  CALL writefield_phy("itvmean",itvmean,nbins)
+!  ENDIF
+!!$OMP END MASTER
+!!$OMP BARRIER
+  ALLOCATE(emisbinlocalmean(klon,nbins))
+  ALLOCATE(emisbinlocalmean2(klon,nbins))
+  do i=1,nbins
+    do j=1,klon
+       emisbinlocalmean(j,i)=0.0
+       emisbinlocalmean2(j,i)=0.0
+    enddo
+  enddo
+  counter=1
+  counter1=0
+!JEdbg>>
+endif
+endif
+
+
+!print *,'JE'
+!print *,iminacclow,iminacchigh,imincoalow,imincoahigh
+
+! estimate and integrate bins into only accumulation and coarse
+do k=1,klon
+  basesumacc(k)=basesumemission*(pctsrf(k,is_ter))*1.e-6 ! from mg/m2/s
+  basesumcoa(k)=basesumemission*(pctsrf(k,is_ter))*1.e-6
+  basesumsco(k)=basesumemission*(pctsrf(k,is_ter))*1.e-6
+enddo
+
+
+do k=1,klon
+auxr1=0.0
+auxr2=0.0
+auxr3=0.0
+  do i=iminacclow,iminacchigh-1
+   auxr1=auxr1+emisbinlocal(k,i)
+  enddo
+  emdustacc(k)=(auxr1 + basesumacc(k))*tuningfactorfine
+  do i=imincoalow,imincoahigh-1
+    auxr2=auxr2+emisbinlocal(k,i)
+  enddo
+  emdustcoa(k)=(auxr2 + basesumcoa(k))*tuningfactorcoa
+  do i=iminscolow,iminscohigh-1
+    auxr3=auxr3+emisbinlocal(k,i)
+  enddo
+  emdustsco(k)=(auxr3 + basesumsco(k))*tuningfactorsco
+enddo
+
+
+!do k=1,klon
+!auxr1=0.0
+!auxr2=0.0
+!auxr3=0.0
+!  do i=iminacclow,iminacchigh-1
+!   auxr1=auxr1+emisbinlocal(k,i)
+!  enddo
+!  emdustacc(k)= auxr1*tuningfactor
+!  do i=imincoalow,imincoahigh-1
+!    auxr2=auxr2+emisbinlocal(k,i)
+!  enddo
+!  emdustcoa(k)=auxr2*tuningfactor
+!  do i=iminscolow,iminscohigh-1
+!    auxr3=auxr3+emisbinlocal(k,i)
+!  enddo
+!  emdustsco(k)=auxr3*tuningfactor
+!enddo
+!
+
+
+
+
+!JEdbg<<
+if (writeaerosoldistrib) then
+  do i=1,nbins
+    do j=1,klon
+        emisbinlocalmean(j,i)=emisbinlocalmean(j,i)+emisbinlocal(j,i)
+    enddo 
+  enddo
+counter1=counter1+1
+! 4 timesteps of physics=4*15min=1hour..
+! 1440 = 15 days
+! 480 = 5 days
+if (MOD(counter,1440).eq. 0) THEN
+   !if (MOD(counter,480).eq. 0) THEN
+   do k = 1,klon
+   do i=1,nbins
+     emisbinlocalmean2(k,i)=emisbinlocalmean(k,i)/float(counter1)
+   enddo
+   enddo
+   counter1=0
+!   call gather(emisbinlocalmean2,emisbinlocalmean2_glo)
+!!$OMP MASTER
+!   IF (is_mpi_root .AND. is_omp_root) THEN
+!   CALL writefield_phy("emisbinlocalmean2",emisbinlocalmean2_glo,nbins)
+   CALL writefield_phy("emisbinlocalmean2",emisbinlocalmean2,nbins)
+!   ENDIF
+!!$OMP END MASTER
+!!$OMP BARRIER
+   do i=1,nbins
+     do j=1,klon
+        emisbinlocalmean(j,i)=0.0
+     enddo
+   enddo
+endif
+counter=counter+1
+endif
+!JEdbg>>
+
+!CALL abort_gcm('calcdustemission', 'OK1',1)
+ 
+END SUBROUTINE adaptdustemission
+
+
+!--------------------------------------------------------------------------------------
+!======================================================================================
+!**************************************************************************************
+!======================================================================================
+!--------------------------------------------------------------------------------------
+
+
+!--------------------------------------------------------
+  SUBROUTINE initdust(xlat,xlon,pctsrf)
+  USE dimphy
+  USE infotrac
+  USE write_field_phy
+  USE mod_grid_phy_lmdz
+  USE mod_phys_lmdz_para
+  USE indice_sol_mod
+
+  IMPLICIT NONE
+  !Inputs
+  REAL,DIMENSION(klon),     INTENT(IN)     :: xlat
+  REAL,DIMENSION(klon),     INTENT(IN)     :: xlon
+  ! JE20150605<< better to read
+  ! REAL,DIMENSION(klon),     INTENT(IN)     :: pctsrf
+  REAL,DIMENSION(klon,nbsrf),     INTENT(IN)     :: pctsrf
+  ! JE20150605>>
+
+  !Local
+  REAL,DIMENSION(klon,ntyp)                :: solini
+  REAL,DIMENSION(klon,ntyp)                :: Pini
+  REAL,DIMENSION(klon,ntyp)                :: zosini
+  REAL,DIMENSION(klon,ntyp)                :: z01ini
+  REAL,DIMENSION(klon,ntyp)                :: z02ini
+  REAL,DIMENSION(klon,ntyp)                :: Dini
+  REAL,DIMENSION(klon,ntyp)                :: Aini
+
+  REAL,DIMENSION(nclass)                   :: newstep
+
+ !TEMPORAL/ MAKE MASK!!!
+  REAL, PARAMETER        :: longmin=-20.
+  REAL, PARAMETER        :: longmax=77.          !35.  
+  REAL, PARAMETER        :: latmin=10.
+  REAL, PARAMETER        :: latmax=40.
+ !TEMPORAL/ MAKE MASK!!!
+  !Local
+  REAL, PARAMETER        :: eps=1.e-5
+  REAL, PARAMETER        :: aeff=0.35
+  REAL, PARAMETER        :: xeff=10.
+  REAL, PARAMETER        :: trctunt=0.310723
+ 
+  INTEGER     :: i,j,k,nts
+  REAL :: dp,dstep
+! Parametres pour le calcul de la repartition de l energie feff(klon,ntyp)
+  REAL :: aa,bb,cc,dd,ee,ff
+  REAL,DIMENSION(klon,ntyp) :: tmp1
+  REAL :: p3t,var1,var2,et
+
+! Parametres pour le calcul de la surface couverte par les particule de diametre
+! dp srel(nats,nclass)
+  REAL :: stotale,su,su_loc,xk,xl,xm,xn
+  REAL,DIMENSION(nclass)                   :: subsoildist
+
+! isolog and massfrac calcs
+  INTEGER :: nbinsout,nb,miniso,nbins1,nbins2,istart,no
+  REAL :: b1,b2,stepbin,minisograd,exden,d2min,d2max,numin,numax
+  REAL                   :: delta1,delta2,ldmd
+!  REAL, PARAMETER     :: sizedustmin=0.09
+  REAL,DIMENSION(nbinsHR):: binsISOGRAD
+  REAL,DIMENSION(nbinsHR):: vdISOGRAD
+  REAL,DIMENSION(nbinsHR):: logvdISOGRAD
+  REAL                   :: curvd
+  REAL                   :: avdhr
+  REAL                   :: bvdhr
+  REAL,DIMENSION(nbins)  :: dmn1
+  REAL,DIMENSION(nbins)  :: dmn2
+  REAL,DIMENSION(nbins)  :: dmn3
+  REAL,DIMENSION(nbinsHR) :: vdHR
+  REAL,DIMENSION(nbinsHR)  :: vdout
+
+
+
+! Parametres pour le calcul de la vitesse de friction seuil uth(nclass)
+! calcul de la vitesse seuil selon la parametrisation de Shao and Lu
+! 2000(icuth=1).
+!  INTEGER                :: ich1
+  REAL                   :: an
+  REAL                   :: gam
+  REAL                   :: sigshao
+  REAL                   :: x1
+  REAL                   :: x2
+! Cas de Iversen and White 1982 (icuth=0) si necessaire.
+  REAL, PARAMETER        :: adust=1331.647
+  REAL, PARAMETER        :: bdust=0.38194
+  REAL, PARAMETER        :: xdust=1.561228
+  REAL, PARAMETER        :: ddust=0.006/(rop*gravity)
+
+  CHARACTER(LEN=10) :: varname
+  CHARACTER(LEN=80) :: fnsolspe
+  CHARACTER(LEN=200) :: line
+  
+
+! nats: number of mineral types (14 here for sand, silt, clay etc.)
+    ALLOCATE( binsHR(nbinsHR) )
+    ALLOCATE( binsHRcm(nbinsHR) )
+    ALLOCATE( itv(nbins+1) )
+    ALLOCATE( sizedust(nbins) )
+    ALLOCATE( szdcm(nbins) )
+    ALLOCATE( massfrac(ndistb,nbins) )
+    ALLOCATE( sol(klon,ntyp) )
+    ALLOCATE( P(klon,ntyp) )
+    ALLOCATE( zos(klon,ntyp) )
+    ALLOCATE( z01(klon,ntyp) )
+    ALLOCATE( z02(klon,ntyp) )
+    ALLOCATE( D(klon,ntyp) )
+    ALLOCATE( A(klon,ntyp) )
+    ALLOCATE( masklisa(klon,ntyp) )
+    ALLOCATE( solspe(nats,nspe) )
+    ALLOCATE( feff(klon,ntyp) ) 
+    ALLOCATE( feffdbg(klon,ntyp) ) 
+    ALLOCATE( sizeclass(nclass) )
+    ALLOCATE( sizeclass2(nclass) )
+    ALLOCATE( uth(nclass) )
+    ALLOCATE( uth2(nclass) )
+    ALLOCATE( srel(nats,nclass) )
+    ALLOCATE( srel2(nats,nclass) )
+
+
+
+  ! read input data from donnees_lisa.nc
+  varname='SOL'
+  CALL read_surface(varname,solini)
+  varname='P'
+  CALL read_surface(varname,Pini)
+  varname='ZOS_'
+  CALL read_surface(varname,zosini)
+  varname='ZO1_'
+  CALL read_surface(varname,z01ini)
+  varname='ZO2_'
+  CALL read_surface(varname,z02ini)
+  varname='D'
+  CALL read_surface(varname,Dini)
+  varname='A'
+  CALL read_surface(varname,Aini)
+print *,'beforewritephy',mpi_rank,omp_rank
+  CALL writefield_phy("SOLinit",solini,5)
+  CALL writefield_phy("Pinit",Pini,5)
+  CALL writefield_phy("ZOSinit",zosini,5)
+  CALL writefield_phy("ZO1init",z01ini,5)
+  CALL writefield_phy("ZO2init",z02ini,5)
+  CALL writefield_phy("Dinit",Dini,5)
+  CALL writefield_phy("Ainit",Aini,5)
+print *,'afterwritephy',mpi_rank,omp_rank
+
+  DO i=1,klon
+    DO nts=1,ntyp
+        masklisa(i,nts)=0
+        IF(Pini(i,nts)>=0.) THEN
+               masklisa(i,nts)=1
+        ENDIF 
+    ENDDO
+  ENDDO
+!print *,'JEOK1',mpi_rank,omp_rank
+  DO i=1,klon
+    !print *,Pini(i,1),Pini(i,2),Pini(i,3),Pini(i,4),Pini(i,5)
+    DO nts=1,ntyp
+      !IF(xlon(i).ge.longmin.and.xlon(i).le.longmax.and. &
+      !&      xlat(i).ge.latmin.and.xlat(i).le.latmax    &
+      !&      .and.pctsrf(i)>0.5.and.Pini(i,nts)>0.)THEN
+  ! JE20150605<< easier to read
+      IF(pctsrf(i,is_ter)>0.5.and.Pini(i,nts)>0.)THEN
+  ! JE20150605>>
+           sol(i,nts) = solini(i,nts)
+             P(i,nts) = Pini(i,nts)
+           zos(i,nts) = zosini(i,nts)
+           z01(i,nts) = z01ini(i,nts)
+           z02(i,nts) = z02ini(i,nts)
+             D(i,nts) = Dini(i,nts)
+             A(i,nts) = Aini(i,nts)
+!             masklisa(i,nts)=1
+      ELSE
+              sol(i,nts) =0.0
+               P(i,nts)  =0.0
+              zos(i,nts) =0.0
+              z01(i,nts) =0.0
+              z02(i,nts) =0.0
+               D(i,nts)  =0.0
+               A(i,nts)  =0.0
+!            masklisa(i,nts)=0
+      ENDIF
+    ENDDO
+  ENDDO
+
+! print *,'JEOK2',mpi_rank,omp_rank
+if ( 1==1 ) then
+
+! print *,'JEOK4',mpi_rank,omp_rank
+   CALL writefield_phy("SOL",sol,5)
+   CALL writefield_phy("P"  ,P  ,5)
+   CALL writefield_phy("ZOS",zos,5)
+   CALL writefield_phy("ZO1",z01,5)
+   CALL writefield_phy("ZO2",z02,5)
+   CALL writefield_phy("D"  ,D  ,5)
+   CALL writefield_phy("A"  ,A  ,5)
+   CALL writefield_phy("masklisa",float(masklisa),5)
+   CALL writefield_phy("pctsrf",pctsrf,1)
+   CALL writefield_phy("xlon",xlon,1)
+   CALL writefield_phy("xlat",xlat,1)
+!print *,'JEOK5',mpi_rank,omp_rank
+!print *,'JEOK6',mpi_rank,omp_rank
+
+endif
+
+  !CALL abort_gcm('initdustemission', 'OK1',1)
+
+! Lecture des donnees du LISA indiquant le type de sol utilise.
+       ! in lines: landuse
+! nats: number of mineral types (14 here for sand, silt, clay etc.)
+! data format in columns
+! mmd1  sigma1  p1  mmd2  sigma2  p2 mmd3 ... alpha
+!print *,'JEOK7',mpi_rank,omp_rank
+!$OMP MASTER
+IF (is_mpi_root .AND. is_omp_root) THEN
+!print *,'JEOK9',mpi_rank,omp_rank
+ fnsolspe='SOILSPEC.data'
+  PRINT*,'  o Reading ',fnsolspe(1:40)
+  OPEN(10,file=fnsolspe)
+  READ(10,*)line
+  DO i=1,nats
+     READ(10,*)line
+     READ(10,*)(solspe(i,j),j=1,nspe)
+!JE     alfa(i)=solspe(i,10)
+!     PRINT*,'i,alfa(i)',i,alfa(i)
+!     WRITE(18,*)i,alfa(i)
+  END DO
+!     print*,'solspe(14,10)= ',solspe(14,10)
+  CLOSE(10)
+ENDIF
+!$OMP END MASTER
+!$OMP BARRIER
+!print *,'JEOK10',mpi_rank,omp_rank
+  call bcast(solspe)
+! Calcul de la distribution en taille des particules de Dust
+! Elle depend du nombre de classe des particules nclass.
+!c making full resolution soil diameter table
+      dstep=0.0005
+      dp=dmin
+      do i=1,nclass
+         dp=dp*exp(dstep)
+         sizeclass(i)=dp
+         if(dp.ge.dmax+eps)goto 30
+         newstep(i)=dstep
+        ! WRITE(18,*)i,sizeclass(i)
+      enddo
+30   continue
+      print*,'IK5'
+      ncl=i-1
+      print*,'   soil size classes used   ',ncl,' / ',nclass
+      print*,'   soil size min: ',sizeclass(1),' soil size max: ',sizeclass(ncl)
+      if(ncl.gt.nclass)stop
+
+! Threshold velocity:
+if (.false.) then
+!if (.true.) then
+!c 0: Iversen and White 1982
+       print *,'Using  Iversen and White 1982 Uth'
+         do i=1,ncl
+            bb=adust*(sizeclass(i)**xdust)+bdust
+            cc=sqrt(1+ddust*(sizeclass(i)**(-2.5)))
+            xk=sqrt(abs(rop*gravity*sizeclass(i)/roa))
+            if (bb.lt.10.) then
+               dd=sqrt(1.928*(bb**0.092)-1.)
+               uth(i)=0.129*xk*cc/dd
+            else
+               ee=-0.0617*(bb-10.)
+               ff=1.-0.0858*exp(ee)
+               uth(i)=0.12*xk*cc*ff
+            endif
+         enddo
+endif
+if(.true.) then
+! 1: Shao and Lu 2000
+       print *,'Using  Shao and Lu 2000 Uth'
+            an=0.0123
+            gam=0.3
+            do i=1,ncl
+               sigshao=rop/roa
+               x1=sigshao*gravity*sizeclass(i)
+               x2=gam/(roa*sizeclass(i))
+               uth(i)=sqrt(an*(x1+x2))
+            enddo
+endif
+
+
+
+!Calcul de la surface couverte par les particules de diametre dp
+!srel(nats,nclass)
+
+!  OPEN(18,file='srel.dat',form='formatted',access='sequential')
+  DO ns=1,nats
+     stotale=0.
+     DO i=1,ncl
+        su=0.
+        DO j=1,nmode
+           nd=((j-1)*3)+1
+           nsi=((j-1)*3)+2
+           npi=((j-1)*3)+3
+           IF (solspe(ns,nd).EQ.0.)THEN
+              su_loc=0.
+           ELSE
+              xk=solspe(ns,npi)/(sqrt(2.*pi)*log(solspe(ns,nsi)))
+              xl=((log(sizeclass(i))-log(solspe(ns,nd)))**2) &
+     &              /(2.*(log(solspe(ns,nsi)))**2)
+              xm=xk*exp(-xl)
+              xn=rop*(2./3.)*(sizeclass(i)/2.)
+              su_loc=xm*newstep(i)/xn
+           END IF
+           su=su+su_loc
+        END DO
+        subsoildist(i)=su
+        stotale=stotale+su
+     END DO
+     DO i=1,ncl
+        IF (subsoildist(i).gt.0..and.stotale.gt.0.)THEN
+            srel(ns,i)=subsoildist(i)/stotale
+
+        ELSE
+            srel(ns,i)=0.
+        END IF
+!        WRITE(18,*)i,srel(1,i)
+     END DO
+!     PRINT*,'ns , srel(10000) ',ns,srel(ns,10000)
+  END DO
+
+
+! Calcul de la repartition de l energie feff(klon,ntyp)
+
+  !efficient fraction for the friction velocities as a function
+  !of z0s, Zo1 et Zo2 to retrieve the apparent threshold
+  !wind friction velocity.
+      !    feff(:,:)=0.
+       do i=1,klon
+          do k=1,ntyp
+     !     print*,'IKKK ',i,klon,k,ntyp
+             if (zos(i,k).eq.0..or.z01(i,k).eq.0.) then
+     !       if (zos(i,k)<=0..or.z01(i,k)<=0.) then
+!              if (zos(i,k)<0..or.z01(i,k)<0.) then
+     !            print*,'INI DUST WARNING zos ou z01<0',zos(i,k),z01(i,k)
+!              endif
+              feff(i,k)=0.
+              feffdbg(i,k)=0.
+ !         print*,'IKKK A ',i,klon,k,ntyp
+            else
+! drag partition betzeen the erodable surface and zo1
+     !     print*,'IKKK B0 ',i,klon,k,ntyp,z01(i,k),zos(i,k),xeff,aeff
+              aa=log(z01(i,k)/zos(i,k))
+              tmp1(i,k)=aa
+              bb=log(aeff*(xeff/zos(i,k))**0.8)
+              cc=1.-aa/bb
+              feffdbg(i,k)=cc
+       !   print*,'IKKK B1 ',i,klon,k,ntyp
+! drag partition between zo1 and zo2
+! feff: total efficient fraction
+              if(D(i,k).eq.0.)then
+                 feff(i,k)=cc
+   !       print*,'IKKK C ',i,klon,k,ntyp
+              else
+                 dd=log(z02(i,k)/z01(i,k))
+                 ee=log(aeff*(D(i,k)/z01(i,k))**0.8)
+                 feff(i,k)=(1.-dd/ee)*cc
+   !       print*,'IKKK D ',i,klon,k,ntyp
+              endif
+              if (feff(i,k).lt.0.)feff(i,k)=0.
+              if (feffdbg(i,k).lt.0.)feffdbg(i,k)=0.
+              if (feff(i,k).gt.1.)feff(i,k)=1.
+              if (feffdbg(i,k).gt.1.)feffdbg(i,k)=1.
+    !      print*,'IKKK E ',i,klon,k,ntyp
+            endif
+          enddo
+        enddo
+! JE20150120<<
+  if (flag_feff .eq. 0) then
+    print *,'JE_dbg FORCED deactivated feff'
+    do i=1,klon
+      do k=1,ntyp
+        feff(i,k)=1.
+      enddo
+    enddo
+  endif
+! JE20150120>>
+
+
+if (1==1) then
+!  !  CALL writefield_phy("AA",tmp1(1:klon,1:5),5)
+!
+    CALL writefield_phy("REPART5",feff(1:klon,1:5),5)
+    CALL writefield_phy("REPART5dbg",feffdbg(1:klon,1:5),5)
+endif
+
+
+!c---------------FOR def_prepag01modif(var3a,var3b)-----------------------
+        p3t=0.0001
+        var1=e3**(1./3.)
+        var2=(rop*pi)**(1./3.)
+        var3a=trctunt*var1/var2
+        et=e1+(sqrt(p3t*(e3*e3+e1*e2-e2*e3-e1*e3))/p3t)
+        var1=et**(1./3.)
+        var2=(rop*pi)**(1./3.)
+        var3b=trctunt*var1/var2
+
+! JE20140902: comment all isograd distributions and make own massfrac:
+
+
+!  if (.false.) then
+!!**************L718
+!
+!!c------------------------------------------------------------------------
+!! isolog distrib and massfrac calculations.
+!
+!      nbinsout=nbins+1
+!      b1=log(sizedustmin)
+!      b2=log(sizedustmax)
+!! restricted ISOLOG bins distributions
+!
+!!      step=(b2-b1)/(nbinsout-1)
+!!      DO ni=1,nbinsout
+!!         itv(ni)=exp(b1+(ni-1)*step)
+!!      ENDDO
+!!OPEN(18,file='vdepothrsizbin.dat',form='formatted',access='sequential')
+!! Restricted ISOGRADIENT bins distributions
+!!!!!!!Making HIGH RESOLUTION dust size distribution (in um)!!!!!!
+!  stepbin=(b2-b1)/(nbinsHR-1)
+!  DO nb=1,nbinsHR
+!     binsHR(nb)=exp(b1+(nb-1)*stepbin)
+!  END DO
+!
+!  DO nb=1,nbinsHR
+!     binsHRcm(nb)=binsHR(nb)*1.e-4
+!  END DO
+!! Making HIGH RESOLUTION dry deposition velocity
+!     CALL calcvd(vdout)
+!
+!
+! DO nb=1,nbinsHR
+!     vdHR(nb)=vdout(nb)
+!!  WRITE(18,*),binsHR(nb),vdHR(nb)
+!  END DO
+!
+!   !searching for minimum value of dry deposition velocity
+!  minisograd=1.e20
+!  DO nb=1,nbinsHR
+!     IF(vdHR(nb).le.minisograd)THEN
+!       minisograd=vdHR(nb)
+!       miniso=nb
+!     END IF
+!  END DO
+!
+!! searching for optimal number of bins in positive slope Vd part
+!
+!  nbins1=1
+!  nbins2=nbinsout-1
+!     DO k=1,1000
+!        delta1=abs(log(vdHR(1))-log(vdHR(miniso)) )/nbins1
+!        delta2=abs(log(vdHR(nbinsHR))-log(vdHR(miniso)))/(nbins2-1)
+!        IF(delta2.GE.delta1)THEN
+!        GOTO 50
+!
+!        ELSE
+!           nbins2=nbins2-1
+!           nbins1=nbins1+1
+!        END IF
+!        IF(nbins2.EQ.1)THEN
+!           PRINT*,'!! warning: lower limit was found: STOP'
+!           STOP
+!        END IF
+!     END DO
+! 50  CONTINUE
+!print*,'IK10'
+!! building the optimized distribution
+!  logvdISOGRAD(1)=log(vdHR(1))
+!  binsISOGRAD(1)=binsHR(1)
+!  DO k=2,nbins1
+!     logvdISOGRAD(k)=logvdISOGRAD(1)-(k-1)*delta1
+!  END DO
+!
+!  logvdISOGRAD(nbins1+1)=log(minisograd)
+!
+!  DO k=1,nbins2
+!     logvdISOGRAD(nbins1+1+k)=logvdISOGRAD(nbins1+1)+k*delta2
+!  END DO
+!
+!  DO k=1,nbinsout
+!     vdISOGRAD(k)=exp(logvdISOGRAD(k))
+!  END DO
+!! sequential search of the correspondig particle diameter
+!  istart=1
+!  DO k=2,nbinsout-1
+!     curvd=vdISOGRAD(k)
+!     DO nb=istart,nbinsHR
+!        avdhr=vdHR(nb)
+!        bvdhr=vdHR(nb+1)
+!        IF(nb.LT.(miniso-1).AND.curvd.LT.avdhr.AND. &
+!           curvd.GT.bvdhr)THEN
+!           binsISOGRAD(k)=binsHR(nb)
+!           istart=nb
+!           GOTO 60
+!        END IF
+!        IF(nb.eq.miniso)THEN
+!           binsISOGRAD(k)=binsHR(nb)
+!           istart=nb+1
+!           GOTO 60
+!        END IF
+!        IF(nb.GT.miniso.AND.curvd.GT.avdhr.AND. &
+!                              curvd.LT.bvdhr)THEN
+!           binsISOGRAD(k)=binsHR(nb)
+!           istart=nb
+!           GOTO 60
+!        END IF
+!     END DO
+! 60  CONTINUE
+!  END DO
+!print*,'IK11'
+!  binsISOGRAD(nbinsout)=binsHR(nbinsHR)
+!  vdISOGRAD(nbinsout)=vdHR(nbinsHR)
+!  DO nb=1,nbinsout
+!     itv(nb)=binsISOGRAD(nb)
+!  END DO
+!  end ! JE20140902 if false
+
+! Making dust size distribution (in um)
+!
+      nbinsout=nbins+1
+      b1=log(sizedustmin)
+      b2=log(sizedustmax)
+      stepbin=(b2-b1)/(nbinsout-1)
+     DO ni=1,nbinsout
+        itv(ni)=exp(b1+(ni-1)*stepbin)
+     ENDDO
+
+!  stepbin=(b2-b1)/(nbinsHR-1)
+!  DO nb=1,nbinsHR
+!     binsHR(nb)=exp(b1+(nb-1)*stepbin)
+!  END DO
+!
+!  DO nb=1,nbinsHR
+!     binsHRcm(nb)=binsHR(nb)*1.e-4
+!  END DO
+
+
+
+      DO nb=1,nbins
+         ldmd=(log(itv(nb+1))-log(itv(nb)))/2.
+         sizedust(nb)=exp(log(itv(nb))+ldmd)
+        PRINT*,nb, itv(nb),' < ',sizedust(nb),' < ',itv(nb+1)
+      ENDDO
+! Making dust size distribution (in cm) ???
+      DO nb=1,nbins
+         szdcm(nb)=sizedust(nb)*1.e-4
+      ENDDO
+!c preparation of emissions reaffectation.
+      DO k=1,ndistb
+         exden=sqrt(2.)*log(sig(k))
+         DO nb=1,nbins
+            d2min=itv(nb)
+            d2max=itv(nb+1)
+            numin=log(d2min/diam(k))
+            numax=log(d2max/diam(k))
+            massfrac(k,nb)=0.5*(erf(numax/exden)-erf(numin/exden))
+            !print *,k,nb,massfrac(k,nb)
+         ENDDO
+      ENDDO
+
+!$OMP MASTER
+IF (is_mpi_root .AND. is_omp_root) THEN
+      OPEN (unit=15001, file='massfrac')
+      DO k=1,ndistb
+        DO nb=1,nbins
+            write(15001,*),k,nb,massfrac(k,nb)
+        ENDDO
+      ENDDO
+ENDIF
+!$OMP END MASTER
+!$OMP BARRIER
+
+ !CALL abort_gcm('calcdustemission', 'OK1',1)
+
+  !------------
+
+
+  END SUBROUTINE initdust
+
+!--------------------------------------------------------------------------------------
+!======================================================================================
+!**************************************************************************************
+!======================================================================================
+!--------------------------------------------------------------------------------------
+
+  SUBROUTINE calcdustemission(debutphy,zu10m,zv10m,wstar, &
+                              ale_bl,ale_wake,param_wstarBL,param_wstarWAKE, &
+                              emisbin)
+  ! emisions over 12 dust bin
+  USE dimphy
+  USE infotrac
+
+  IMPLICIT NONE
+  ! Input
+  LOGICAL, INTENT(IN)                   :: debutphy ! First physiqs run or not
+  REAL,DIMENSION(klon),INTENT(IN)          :: zu10m   ! 10m zonal wind
+  REAL,DIMENSION(klon),INTENT(IN)          :: zv10m   ! meridional 10m wind
+  REAL,DIMENSION(klon),INTENT(IN)          :: wstar   
+  REAL,DIMENSION(klon),INTENT(IN)          :: ale_bl
+  REAL,DIMENSION(klon),INTENT(IN)          :: ale_wake
+  
+  ! Local variables
+!  INTEGER, PARAMETER :: flag_wstar=150
+!  INTEGER, PARAMETER :: flag_wstar=120
+!  INTEGER, PARAMETER :: flag_wstar=125
+  REAL,DIMENSION(klon), INTENT(IN) :: param_wstarWAKE
+  REAL,DIMENSION(klon), INTENT(IN) :: param_wstarBL
+  REAL,DIMENSION(:,:), ALLOCATABLE,SAVE :: fluxdust ! horizonal emission fluxes in UNITS for the nmod soil aerosol modes
+  REAL,DIMENSION(:), ALLOCATABLE,SAVE   :: wind10ms   ! 10m wind distribution in m/s
+  REAL,DIMENSION(:), ALLOCATABLE,SAVE   :: wind10cm   ! 10m wind distribution in cm/s
+  REAL,DIMENSION(klon)                  :: zwstar   
+  REAL,DIMENSION(nwb)                :: probu
+!  REAL, DIMENSION(nmode) :: fluxN,ftN,adN,fdpN,pN,eN ! in the original code N=1,2,3
+  REAL :: flux1,flux2,flux3,ft1,ft2,ft3
+
+
+  REAL, PARAMETER        :: umin=21.
+  REAL, PARAMETER        :: woff=0.5  ! min value of 10m wind speed accepted for emissions
+  REAL :: pdfcum,U10mMOD,pdfu,weilambda
+  REAL :: z0salt,ceff,cerod,cpcent
+  REAL :: cdnms,ustarns,modwm,utmin
+!JE20150202   REAL :: cdnms,ustarns,modwm
+  REAL :: fdp1,fdp2,ad1,ad2,ad3,flux_diam
+  REAL :: dfec1,dfec2,dfec3,t1,t2,t3,p1,p2,p3,dec,ec
+  ! auxiliar counters
+  INTEGER                               :: kwb
+  INTEGER                               :: i,j,k,l,n
+  INTEGER  :: kfin,ideb,ifin,kfin2,istep
+  REAL :: auxreal
+
+  ! Output
+  !REAL,DIMENSION(:,:), ALLOCATABLE,SAVE  :: emisbin ! vertical emission fluxes in UNITS for the 12 bins
+  REAL,DIMENSION(klon,nbins)  :: emisbin ! vertical emission fluxes in UNITS for the 12 bins
+!$OMP THREADPRIVATE(fluxdust) 
+!$OMP THREADPRIVATE(wind10ms) 
+!$OMP THREADPRIVATE(wind10cm) 
+
+  !----------------------------------------------------
+  ! initialization
+  !----------------------------------------------------
+  IF (debutphy) THEN
+!   ALLOCATE( emisbin(klon,nbins) )
+   ALLOCATE( fluxdust(klon,nmode) )
+   ALLOCATE( wind10ms(nwb) )
+   ALLOCATE( wind10cm(nwb) )
+  ENDIF !debutphy
+
+  
+  DO i=1,klon
+   DO j=1,nbins
+    emisbin(i,j)  = 0.0 
+   ENDDO !j,nbind
+   DO j=1,nmode
+    fluxdust(i,j) = 0.0
+   ENDDO !j,nmode
+  zwstar(i) = 0.0
+  ENDDO !i,klon
+  !----------------------------------------------------
+  ! calculations
+  !----------------------------------------------------
+
+  ! including BL processes..
+!JE201041120  zwstar=sqrt(2.*(ale_bl+0.01*(flag_wstar-100)*ale_wake))
+!JE20141124  zwstar=sqrt(2.*(flag_wstarBL*ale_bl+0.01*(flag_wstar-100)*ale_wake))
+!  print
+!*,'zwstar=sqrt(2.*(',flag_wstarBL,'ale_bl+0.01*(',flag_wstar,'-100)*ale_wake))'
+  !
+    DO i=1,klon  ! main loop
+     zwstar(i)=sqrt(2.*(param_wstarBL(i)*ale_bl(i)+param_wstarWAKE(i)*ale_wake(i)))
+     U10mMOD=MAX(woff,sqrt(zu10m(i)*zu10m(i)+zv10m(i)*zv10m(i)))
+     pdfcum=0.
+     ! Wind weibull distribution:
+
+           DO kwb=1,nwb
+                flux1=0.
+                flux2=0.
+                flux3=0.
+!JE20141205<< differences in weibull distribution: expectance of the distribution is
+!0.89*U10mMODD instead of U10mMOD
+! now: lambda parameter of weibull ditribution is estimated as
+! lambda=U10mMOD/gamma(1+1/kref)
+! gamma function estimated with stirling formula
+                auxreal=1.+1./kref
+                weilambda = U10mMOD/exp(auxreal*log(auxreal)-auxreal &
+                         - 0.5*log(auxreal/(2.*pi))+1./(12.*auxreal) &
+                         -1./(360.*(auxreal**3.))+1./(1260.*(auxreal**5.)))
+                IF(nwb.gt.1)THEN
+                   wind10ms(kwb)=kwb*2.*U10mMOD/nwb
+!original
+!                   pdfu=(kref/U10mMOD)*(wind10ms(kwb)/U10mMOD)**(kref-1) &
+!                      *exp(-(wind10ms(kwb)/U10mMOD)**kref)
+                   pdfu=(kref/weilambda)*(wind10ms(kwb)/weilambda)**(kref-1) &
+                      *exp(-(wind10ms(kwb)/weilambda)**kref)
+!                   !print *,'JEdbg  U10mMOD weilambda  ',U10mMOD,weilambda
+!JE20141205>>
+
+                   probu(kwb)=pdfu*2.*U10mMOD/nwb
+                   pdfcum=pdfcum+probu(kwb)
+                      IF(probu(kwb).le.1.e-2)GOTO 70
+                ELSE
+                   wind10ms(kwb)=U10mMOD
+                   probu(kwb)=1.
+                ENDIF
+             wind10cm(kwb)=wind10ms(kwb)*100.
+             DO n=1,ntyp
+                   ft1=0.
+                   ft2=0.
+                   ft3=0.
+!JE20150129<<<<
+
+             IF(.FALSE.) THEN
+!                  nat=int(sol(i,n))
+!                    print *,i,n
+                    IF(sol(i,n).gt.1..and.sol(i,n).lt.15.) nat=int(sol(i,n))
+!JE20140526<<
+!                    print *,'JE: WARNING: nat=0 forced to nat=99!! and doing nothing'
+                   IF(sol(i,n).lt.0.5) THEN
+                      nat=99
+                      GOTO 80
+                    ENDIF
+!JE20140526>>
+ 
+
+                 !IF(n.eq.1.and.nat.eq.99)GOTO 80
+             !      if(n.eq.1) print*,'nat1=',nat,'sol1=',sol(i,n)
+                   IF(n.eq.1.and.nat.eq.99)GOTO 80
+
+             ENDIF
+             IF(.TRUE.) THEN
+                nat=int(sol(i,n))
+                if(n == 1 .and. nat >= 14 .or. nat < 1 .or. nat > 19) GOTO 80
+             ENDIF
+!JE20150129>>>>
+
+                      z0salt=z02(i,n)
+                      ceff=feff(i,n)
+                      cerod=A(i,n)
+                      cpcent=P(i,n)
+                      ustarsalt=0.
+                   IF(ceff.le.0..or.z0salt.eq.0.)GOTO 80
+                   IF(cerod.eq.0.or.cpcent.eq.0.)GOTO 80
+! in cm: utmin, umin, z10m, z0salt, ustarns
+! in meters: modwm
+! no dimension for: cdnms
+! Cas ou wsta=0.
+                      cdnms=vkarm/(log(z10m/z0salt))
+                      modwm=sqrt((wind10ms(kwb)**2)+(1.2*zwstar(i))**2)
+                      ustarns=cdnms*modwm*100.
+                    ustarsalt=ustarns
+
+
+                   IF(ustarsalt.lt.umin/ceff)GOTO 80
+!                      print*,'ustarsalt = ',ustarsalt
+!----------------------------------------
+                    CALL def_copyncl(kfin)
+
+!                  CALL def_ag01(kfin,ft1,ft2,ft3)
+      do ni=1,kfin
+         fdp1=1.-(uth2(ni)/(ceff*ustarsalt))
+         if (fdp1.le.0..or.srel2(nat,ni).eq.0.) then
+            ad1=0.
+            ad2=0.
+            ad3=0.
+         else
+       
+            fdp2=(1.+(uth2(ni)/(ceff*ustarsalt)))**2.
+            flux_diam=cd*srel2(nat,ni)*fdp1*fdp2*(ustarsalt**3)
+            dec=flux_diam*beta
+            ec=(pi/3.)*1.e+2*rop* (sizeclass2(ni)**3) *(ustarsalt**2)
+            dfec1=(ec-e1)
+            dfec2=(ec-e2)
+            dfec3=(ec-e3)
+            t1=0.
+            t2=0.
+            t3=0.
+            if(ec.ge.e1)t1=1.
+            if(ec.ge.e2)t2=1.
+            if(ec.ge.e3)t3=1.
+            if(dfec3.ne.0.)then
+               p1=t1*dfec1/dfec3
+               p2=t2*(1.-p1)*dfec2/dfec3
+            else
+               p1=0.
+               p2=0.
+            endif
+            p3=t3*(1.-p1-p2)
+            ad1=(pi/6.)*dec*rop*p1*((diam(1)*1.e-4)**3.)/e1
+            ad2=(pi/6.)*dec*rop*p2*((diam(2)*1.e-4)**3.)/e2
+            ad3=(pi/6.)*dec*rop*p3*((diam(3)*1.e-4)**3.)/e3
+
+         endif
+         ft1=ft1+ad1
+         ft2=ft2+ad2
+         ft3=ft3+ad3
+      enddo ! of loop over nc
+
+!....
+
+        flux1=flux1+ft1*cpcent*cerod
+        flux2=flux2+ft2*cpcent*cerod
+        flux3=flux3+ft3*cpcent*cerod
+!       print *,'JEflux :',kwb,n,flux1,flux2,flux3
+80 CONTINUE
+             ENDDO !n=1,ntyp
+70 CONTINUE
+        fluxdust(i,1)=fluxdust(i,1)+flux1*probu(kwb)
+        fluxdust(i,2)=fluxdust(i,2)+flux2*probu(kwb)
+        fluxdust(i,3)=fluxdust(i,3)+flux3*probu(kwb)
+   ENDDO !kwb=1,nwb
+      m1dflux(i)=10.*fluxdust(i,1)
+      m2dflux(i)=10.*fluxdust(i,2)          ! tous en Kg/m2/s
+      m3dflux(i)=10.*fluxdust(i,3)
+
+
+
+    ENDDO  ! i, klon
+
+
+
+   
+  !from horizontal to  vertical fluxes for each bin
+  DO k=1,klon
+   DO i=1,ndistb
+    DO j=1,nbins
+!JE20150202 <<
+    emisbin(k,j) = emisbin(k,j)+10*fluxdust(k,i)*massfrac(i,j)  
+!JE20150202 >>
+    ENDDO !j, nbind
+   ENDDO  !i, nmode
+  ENDDO !k,klon
+
+
+!print *,' JE fluxdust in calcdust'
+! DO k=1,klon
+!   DO i=1,ndistb
+!!print *,k,i,fluxdust(k,i)
+!enddo
+!enddo
+!print *,' JE emisbin in calcdust'
+!do k=1,klon
+!do j=1,nbins
+!!print *,k,j,emisbin(k,j)
+!enddo
+!enddo 
+!  CALL abort_gcm('calcdustemission', 'OK1',1)
+
+  END SUBROUTINE calcdustemission
+!--------------------------------------------------------------------------------------
+!======================================================================================
+!**************************************************************************************
+!======================================================================================
+!--------------------------------------------------------------------------------------
+
+
+
+SUBROUTINE def_copyncl(kfin)
+      implicit none
+
+ integer i,n,kfin,ideb,ifin,istep,kfin2
+    real dsmin,dsmax
+
+! estimation of the reduced soil size distribution
+         dsmin=var3a*(ustarsalt**(-2./3.))
+         dsmax=var3b*(ustarsalt**(-2./3.))
+!      print*,'ustarsalt = ',ustarsalt,'dsmin=',dsmin,'dsmax=',dsmax
+! dichotomy
+         call def_dichotomy(sizeclass,nclass,1,ncl,dsmin,ideb)
+   !      print*,'ideb = ',ideb
+         call def_dichotomy(sizeclass,nclass,ideb,ncl,dsmax,ifin)
+   !      print*,'ifin = ',ifin
+! readaptation of large sizes particles
+         kfin=0
+         do i=ideb,ifin
+            kfin=kfin+1
+            sizeclass2(kfin)=sizeclass(i)
+            uth2(kfin)=uth(i)
+            srel2(nat,kfin)=srel(nat,i)
+         enddo
+  !          print*,'je suis la'
+         kfin2=kfin
+         istep=50
+         do i=ifin,ncl,istep
+            kfin=kfin+1
+            sizeclass2(kfin)=sizeclass(i)
+            uth2(kfin)=uth(i)
+            srel2(nat,kfin)=srel(nat,i)*istep
+         enddo
+         if(kfin.ge.nclass)then
+            print*,'$$$$ Tables dimension problem:',kfin,'>',nclass
+         endif
+!---------------        
+
+      return
+END SUBROUTINE def_copyncl
+
+!--------------------------------------------------------------------------------------
+!======================================================================================
+!**************************************************************************************
+!======================================================================================
+!--------------------------------------------------------------------------------------
+
+subroutine def_dichotomy(siz,nclass,i1,i2,ds,iout)
+!c---------------------------------------------------------------
+!c 'size' is the table to scan
+!c      of dimension 'nclass', and reduced size of interest [i1:i2]
+!c 'ds' is the value to find in 'size'
+!c 'iout' is the number in the table 'size' correspondig to 'ds'
+!c---------------------------------------------------------------
+
+      implicit none
+      integer i1,i2,nclass,iout,ismin,ismax,k2,ihalf,idiff
+      real siz(nclass),ds
+!c-----------------------------
+      iout=0
+      ismin=i1
+      ismax=i2
+      ihalf=int((ismax+ismin)/2.)
+      do k2=1,1000000
+          if(ds.gt.siz(ihalf))then
+             ismin=ihalf
+          else
+             ismax=ihalf
+          endif
+          ihalf=int((ismax+ismin)/2.)
+          idiff=ismax-ismin
+          if(idiff.le.1)then
+             iout=ismin
+             goto 52
+          endif
+      enddo
+ 52   continue
+      if(iout.eq.0)then
+        print*,'$$$$ Tables dimension problem: ',iout
+      endif
+
+      end subroutine def_dichotomy
+
+!--------------------------------------------------------------------------------------
+!======================================================================================
+!**************************************************************************************
+!======================================================================================
+!--------------------------------------------------------------------------------------
+
+
+  SUBROUTINE calcvd(vdout)
+  IMPLICIT NONE
+  INTEGER                     :: nb
+!JE already def in module  INTEGER,PARAMETER           :: nbinsHR=3000
+  INTEGER,PARAMETER           :: idiffusi=1
+  INTEGER,PARAMETER           :: idrydep=2
+  REAL                        :: dmn1,dmn2,dmn3,ra,rb
+  REAL                        :: rhod,muair,nuair,R,airmolw
+  REAL                        :: bolz,rhoair,gravity,karman,zed,z0m
+  REAL                        :: ustarbin,temp,pres,rac,lambda,ccexp
+  REAL                        :: Cc,rexp,pi,St
+  REAL,DIMENSION(nbinsHR)     :: setvel
+  REAL,DIMENSION(nbinsHR)     :: diffmol1
+  REAL,DIMENSION(nbinsHR)     :: diffmol2
+  REAL,DIMENSION(nbinsHR)     :: schmidtnumb
+  REAL,DIMENSION(nbinsHR)     :: diffmole
+
+  REAL,DIMENSION(nbinsHR),   INTENT(OUT)              :: vdout
+! users physical parameters
+       temp=273.15+25. ! in Kelvin degrees
+       pres=1013. ! in hPa
+! calculation of Ra
+       zed=10.
+       z0m=0.05
+       karman=0.41
+       ustarbin=30. ! cm/s
+       ra=log(zed/z0m)/(karman*ustarbin)
+!c physical constants (all must in units g / cm / s)
+       rhod=2.65                 ! g.cm-3
+       muair=1.72e-4             ! g.cm-1.s-1
+       nuair=0.1461              ! air kinematic viscosity [cm2.s-1]
+       R=8.314                   ! molar gas constant J.mol-1.K-1
+       airmolw=28.8              ! molar weight of air
+       bolz=1.38e-16                    ! g.cm2.s-2
+       rhoair=1.225e-3                  ! g.cm-3
+       gravity=981.                ! gravity [cm.s-2]
+       pi=3.14159
+       rac=sqrt(8.0*airmolw/(pi*R*temp))
+       lambda=(2.*muair)/(pres*rac)
+! c Cc and Vs
+!       binsHRcm=binsize*1.e-4
+       DO nb=1,nbinsHR
+       ccexp=exp((-0.55*binsHRcm(nb))/lambda)
+       Cc=1.+(2.*lambda)/binsHRcm(nb)*(1.257+0.4*ccexp)
+       setvel(nb)=(1./18.)*((binsHRcm(nb))**2*rhod*gravity*Cc)/muair
+!c Molecular diffusivity (s/cm2) and Schmidt number
+!c Note that the molecular diffusivity uses diameter in micro-m
+!c to give a result directly in s/cm2
+       dmn1=2.38e-7/binsHR(nb)
+       dmn2=0.163/binsHR(nb)
+       dmn3=0.0548*exp(-6.66*binsHR(nb))/binsHR(nb)
+       diffmol1(nb)=dmn1*(1.+dmn2+dmn3)
+       diffmol2(nb)=bolz*temp*Cc/(3.*pi*muair*binsHRcm(nb))
+       IF(idiffusi.EQ.1)diffmole(nb)=diffmol1(nb)
+       IF(idiffusi.EQ.2)diffmole(nb)=diffmol2(nb)
+       schmidtnumb(nb)=nuair/diffmole(nb)
+       St=setvel(nb)*ustarbin*ustarbin/(gravity*nuair)
+       rb=1./(ustarbin*((schmidtnumb(nb))**(-2./3.)+10.**(-3./St)))
+!c wesely (primarily designed for gases)
+       IF(idrydep.EQ.1)THEN
+          vdout(nb)=1./(ra+rb+ra*rb*setvel(nb))+setvel(nb)
+       END IF
+!c venkatram and pleim (more adaptated to particles but numerically unstable)
+       IF(idrydep.EQ.2)THEN
+        rexp=exp(-(ra+rb)*setvel(nb))
+        vdout(nb)=setvel(nb)/(1.-rexp)
+       END IF
+       END DO
+!c-----------------
+       RETURN
+      END SUBROUTINE calcvd
+
+
+
+END MODULE dustemission_mod
+
Index: DZ6/trunk/libf/phylmd/Dust/lsc_scav_orig.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/Dust/lsc_scav_orig.F90	(revision 5267)
+++ 	(revision )
@@ -1,291 +1,0 @@
-!$Id $
-
-SUBROUTINE lsc_scav_orig(pdtime,it,iflag_lscav,oliq,flxr,flxs,rneb,beta_fisrt,  &
-                    beta_v1,pplay,paprs,t,tr_seri,d_tr_insc,          &
-                    d_tr_bcscav,d_tr_evap,qPrls) 
-  USE ioipsl
-  USE dimphy
-  USE mod_grid_phy_lmdz
-  USE mod_phys_lmdz_para
-  USE traclmdz_mod
-  USE infotrac,ONLY : nbtr
-!!!  USE geometry_mod
-  USE iophy
-
-  IMPLICIT NONE 
-!=====================================================================
-! Objet : depot humide (lessivage et evaporation) de traceurs
-! Inspired by routines of Olivier Boucher (mars 1998)
-! author R. Pilon 10 octobre 2012
-! last modification 16/01/2013 (reformulation partie evaporation)
-!=====================================================================
-
-  include "dimensions.h"
-  include "chem.h"
-  include "YOMCST.h"
-  include "YOECUMF.h" 
-
-  REAL,INTENT(IN)                        :: pdtime ! time step (s)
-  INTEGER,INTENT(IN)                     :: it     ! tracer number
-  INTEGER,INTENT(IN)                     :: iflag_lscav ! LS scavenging param:
-!                                             3=Reddy_Boucher2004, 4=3+RPilon.
-  REAL,DIMENSION(klon,klev+1),INTENT(IN) :: flxr     ! flux precipitant de pluie
-  REAL,DIMENSION(klon,klev+1),INTENT(IN) :: flxs     ! flux precipitant de neige
-  REAL,INTENT(IN)                        :: oliq ! contenu en eau liquide dans le nuage (kg/kg)
-  REAL,DIMENSION(klon,klev),INTENT(IN)   :: rneb
-  REAL,DIMENSION(klon,klev),INTENT(IN)   :: pplay    ! pression
-  REAL,DIMENSION(klon,klev+1),INTENT(IN) :: paprs    ! pression
-  REAL,DIMENSION(klon,klev),INTENT(IN)   :: t        ! temperature
-! tracers
-  REAL,DIMENSION(klon,klev,nbtr),INTENT(IN)   :: tr_seri        ! q de traceur  
-  REAL,DIMENSION(klon,klev),INTENT(IN)        :: beta_fisrt     ! taux de conversion de l'eau cond
-  REAL,DIMENSION(klon,klev),INTENT(OUT)       :: beta_v1        ! -- (originale version)
-  REAL,DIMENSION(klon)                        :: his_dh         ! tendance de traceur integre verticalement
-  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)  :: d_tr_insc      ! tendance du traceur 
-  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)  :: d_tr_bcscav  ! tendance de traceur
-  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)  :: d_tr_evap
-  REAL,DIMENSION(klon,nbtr),INTENT(OUT)       :: qPrls      !jyg: concentration tra dans pluie LS a la surf.
-  REAL :: dxin,dxev                              ! tendance temporaire de traceur incloud
-  REAL,DIMENSION(klon,klev) :: dxbc       ! tendance temporaire de traceur bc
-
-
-!  variables locales      
- LOGICAL,SAVE :: debut=.true.
-!$OMP THREADPRIVATE(debut)
-!
-  REAL,PARAMETER :: henry=1.4  ! constante de Henry en mol/l/atm ~1.4 for gases
-  REAL           :: henry_t    !  constante de Henry a T t  (mol/l/atm)
-  REAL,PARAMETER :: kk=2900.   ! coefficient de dependence en T (K)
-  REAL :: f_a     !  rapport de la phase aqueuse a la phase gazeuse
-  REAL :: beta    !  taux de conversion de l'eau en pluie
-
-  INTEGER :: i, k
-  REAL,DIMENSION(klon,klev)    :: scav  !  water liquid content / fraction aqueuse du constituant
-  REAL,DIMENSION(klon,klev)    :: zrho
-  REAL,DIMENSION(klon,klev)    :: zdz
-  REAL,DIMENSION(klon,klev)    :: zmass ! layer mass
-
-  REAL           :: frac_ev       ! cste pour la reevaporation : dropplet shrinking
-!  frac_ev = frac_gas ou frac_aer
-  REAL,PARAMETER :: frac_gas=1.0  ! cste pour la reevaporation pour les gaz
-  REAL           :: frac_aer      ! cste pour la reevaporation pour les particules
-  REAL,DIMENSION(klon,klev) :: deltaP     ! P(i+1)-P(i)
-  REAL,DIMENSION(klon,klev) :: beta_ev    !  dP/P(i+1)
-
-!  101.325  m3/l x Pa/atm
-!  R        Pa.m3/mol/K
-!   cste de dissolution pour le depot humide
-  REAL,SAVE :: frac_fine_scav
-  REAL,SAVE :: frac_coar_scav
-!$OMP THREADPRIVATE(frac_fine_scav, frac_coar_scav)
-
-! below-cloud scav variables
-! aerosol : alpha_r=0.001, gas 0.001  (Pruppacher & Klett 1967)
-  REAL,SAVE :: alpha_r  !  coefficient d'impaction pour la pluie
-  REAL,SAVE :: alpha_s  !  coefficient d'impaction pour la neige  
-  REAL,SAVE :: R_r      !  mean raindrop radius (m) 
-  REAL,SAVE :: R_s      !  mean snow crystal radius (m)
-!$OMP THREADPRIVATE(alpha_r, alpha_s, R_r, R_s)
-  REAL           :: pr, ps, ice, water
-  real :: conserv
-!
-!!!!!!!!!!!!!!!!!!!! choix lessivage !!!!!!!!!!!!!!!!!!!!!!!!
-!!  logical,save  :: inscav_fisrt
-!!! $OMP THREADPRIVATE(inscav_first)
-!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!
-  IF (debut) THEN
-!
-!  inscav_fisrt=.true.
-!  call getin('inscav_fisrt',inscav_fisrt)
-!  if(inscav_fisrt) then 
-!   print*,'beta from fisrtilp.F90, beta = (z_cond - z_oliq)/z_cond, inscav_fisrt=',inscav_fisrt
-!  else
-!   print*,'beta from Reddy and Bocuher 2004 (original version), inscav_fisrt=',inscav_fisrt
-!  endif
-!
-      alpha_r=0.001        !  coefficient d'impaction pour la pluie
-      alpha_s=0.01         !  coefficient d'impaction pour la neige  
-      R_r=0.001            !  mean raindrop radius (m) 
-      R_s=0.001            !  mean snow crystal radius (m)
-      frac_fine_scav=0.7
-      frac_coar_scav=0.7
-!     frac_aer=0.5 ~ droplet size shrinks by evap
-      frac_aer=0.5
-!
-
-!JE to speed up, commented 20140219
-!
-!      OPEN(99,file='lsc_scav_param.data',status='old', &
-!                form='formatted',err=9999)
-!      READ(99,*,end=9998)  alpha_r
-!      READ(99,*,end=9998)  alpha_s
-!      READ(99,*,end=9998)  R_r
-!      READ(99,*,end=9998)  R_s
-!      READ(99,*,end=9998)  frac_fine_scav
-!      READ(99,*,end=9998)  frac_coar_scav
-!      READ(99,*,end=9998)  frac_aer
-!9998  Continue
-!      CLOSE(99)
-!9999  Continue
-!
-!   print*,'alpha_r',alpha_r
-!   print*,'alpha_s',alpha_s
-!   print*,'R_r',R_r
-!   print*,'R_s',R_s
-!   print*,'frac_fine_scav',frac_fine_scav
-!   print*,'frac_coar_scav',frac_coar_scav
-!   print*,'frac_aer ev',frac_aer
-!
-! JE endcomment
-!
-  ENDIF !(debut)
-!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!
-! initialization
-  dxin=0.
-  dxev=0.
-  beta_ev=0.
-
-  DO i=1,klon
-   his_dh(i)=0.
-  ENDDO
-
-  DO k=1,klev
-   DO i=1, klon 
-    dxbc(i,k)=0.
-    beta_v1(i,k)=0.
-    deltaP(i,k)=0.
-   ENDDO
-  ENDDO
-
-  DO k=1,klev
-    DO i=1, klon
-     d_tr_insc(i,k,it)=0.
-     d_tr_bcscav(i,k,it)=0.
-     d_tr_evap(i,k,it)=0.
-    ENDDO
-  ENDDO
-
-!  pressure and size of the layer
-  DO k=klev-1, 1, -1
-   DO i=1, klon 
-     zrho(i,k)=pplay(i,k)/t(i,k)/RD   
-     zdz(i,k)=(paprs(i,k)-paprs(i,k+1))/zrho(i,k)/RG
-     zmass(i,k)=(paprs(i,k)-paprs(i,k+1))/RG
-   ENDDO
-  ENDDO
-
-    IF (it.gt.1) THEN                               !  aerosol   
-      frac_ev=frac_aer
-    ELSE                                                !  gas
-      frac_ev=frac_gas
-    ENDIF
-
-    IF(it.gt.1) then  ! aerosol
-     DO k=1, klev
-      DO i=1, klon 
-       scav(i,k)=frac_fine_scav
-      ENDDO 
-     ENDDO
-    ELSE                  ! gas
-     DO k=1, klev
-      DO i=1, klon 
-       henry_t=henry*exp(-kk*(1./298.-1./t(i,k)))    !  mol/l/atm
-       f_a=henry_t/101.325*R*t(i,k)*oliq*zrho(i,k)/rho_water
-       scav(i,k)=f_a/(1.+f_a)
-      ENDDO 
-     ENDDO
-    ENDIF
-
-   DO k=klev-1, 1, -1
-    DO i=1, klon 
-!  incloud scavenging
-!   if(inscav_fisrt) then 
-   if (iflag_lscav .eq. 4) then
-      beta=beta_fisrt(i,k)*rneb(i,k)
-   else
-      beta=flxr(i,k)-flxr(i,k+1)+flxs(i,k)-flxs(i,k+1)
-!      beta=beta/zdz(i,k)/oliq/zrho(i,k)
-      beta=beta/zmass(i,k)/oliq
-      beta=MAX(0.,beta)
-   endif ! (iflag_lscav .eq. 4)
-   beta_v1(i,k)=beta    !! for output
-!
-      dxin=tr_seri(i,k,it)*(exp(-scav(i,k)*beta*pdtime)-1.)
-!      his_dh(i)=his_dh(i)-dxin*zrho(i,k)*zdz(i,k)/pdtime !  kg/m2/s
-      his_dh(i)=his_dh(i)-dxin*zmass(i,k)/pdtime !  kg/m2/s
-      d_tr_insc(i,k,it)=dxin
-
-!  below-cloud impaction
-    IF(it.eq.1) then
-      d_tr_bcscav(i,k,it)=0.
-    ELSE
-     pr=0.5*(flxr(i,k)+flxr(i,k+1))
-     ps=0.5*(flxs(i,k)+flxs(i,k+1))
-     water=pr*alpha_r/R_r/rho_water
-     ice=ps*alpha_s/R_s/rho_ice
-     dxbc(i,k)=-3./4.*tr_seri(i,k,it)*pdtime*(water+ice)
-!   add tracers from below cloud scav in his_dh
-     his_dh(i)=his_dh(i)-dxbc(i,k)*zmass(i,k)/pdtime !  kg/m2/s
-     d_tr_bcscav(i,k,it)=dxbc(i,k)
-    ENDIF
-
-!  reevaporation
-      deltaP(i,k)=flxr(i,k+1)+flxs(i,k+1)-flxr(i,k)-flxs(i,k)
-      deltaP(i,k)=max(deltaP(i,k),0.)
-
-      if(flxr(i,k+1)+flxs(i,k+1).gt.1.e-16) then
-       beta_ev(i,k)=deltaP(i,k)/(flxr(i,k+1)+flxs(i,k+1))
-      else
-       beta_ev(i,k)=0.
-      endif
-
-      beta_ev(i,k)=max(min(1.,beta_ev(i,k)),0.)
-
-!jyg
-      
-      if(abs(1-(1-frac_ev)*beta_ev(i,k)).gt.1.e-16) then
-! remove tracers from precipitation owing to release by evaporation in his_dh
-!      dxev=frac_ev*beta_ev(i,k)*his_dh(i) *pdtime/(zrho(i,k)*zdz(i,k)) &
-      dxev=frac_ev*beta_ev(i,k)*his_dh(i) *pdtime/(zmass(i,k)) &
-                                      /(1 -(1-frac_ev)*beta_ev(i,k))
-       his_dh(i)=his_dh(i)*(1 - frac_ev*beta_ev(i,k) / (1 -(1-frac_ev)*beta_ev(i,k)))
-      else
-!       dxev=his_dh(i) *pdtime/(zrho(i,k)*zdz(i,k))
-       dxev=his_dh(i) *pdtime/(zmass(i,k))
-       his_dh(i)=0.
-      endif
-!      print*,  k, 'beta_ev',beta_ev
-! remove tracers from precipitation owing to release by evaporation in his_dh
-!!      dxev=frac_ev*deltaP(i,k)*pdtime * his_dh(i) /(zrho(i,k)*zdz(i,k))
-!rplmd
-!!      dxev=frac_ev*deltaP(i,k)*his_dh(i) *pdtime/(zrho(i,k)*zdz(i,k)) &
-!!                                      /max(flxr(i,k)+flxs(i,k),1.e-16)
-
-
-      d_tr_evap(i,k,it)=dxev
-!!     tendency is further added in phytrac x = x + dx
-    ENDDO !!  do i
-   ENDDO  !! do k
-
-!jyg (20130114)
-   DO i = 1,klon
-     qPrls(i,it) = his_dh(i)/max(flxr(i,1)+flxs(i,1),1.e-16)
-   ENDDO
-!jyg end
-
-
-! test de conservation
-      conserv=0.
-!      DO k= klev,1,-1
-!        DO i=1, klon
-!         conserv=conserv+d_tr_insc(i,k,it)*(paprs(i,k)-paprs(i,k+1))/RG &
-!                +d_tr_bcscav(i,k,it)*(paprs(i,k)-paprs(i,k+1))/RG  &
-!                +d_tr_evap(i,k,it)*(paprs(i,k)-paprs(i,k+1))/RG
-!      if(it.eq.3) write(*,'(I2,2X,a,e20.12,2X,a,e20.12,2X,a,e20.12,2X,a,e20.12)'),&
-!      k,'lsc conserv ',conserv,'insc',d_tr_insc(i,k,it),'bc',d_tr_bcscav(i,k,it),'ev',d_tr_evap(i,k,it)
-!       ENDDO
-!     ENDDO
-
-END SUBROUTINE lsc_scav_orig
Index: /LMDZ6/trunk/libf/phylmd/Dust/lsc_scav_orig.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/Dust/lsc_scav_orig.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/Dust/lsc_scav_orig.f90	(revision 5268)
@@ -0,0 +1,291 @@
+!$Id $
+
+SUBROUTINE lsc_scav_orig(pdtime,it,iflag_lscav,oliq,flxr,flxs,rneb,beta_fisrt,  &
+                    beta_v1,pplay,paprs,t,tr_seri,d_tr_insc,          &
+                    d_tr_bcscav,d_tr_evap,qPrls) 
+  USE ioipsl
+  USE dimphy
+  USE mod_grid_phy_lmdz
+  USE mod_phys_lmdz_para
+  USE traclmdz_mod
+  USE infotrac,ONLY : nbtr
+!!!  USE geometry_mod
+  USE iophy
+
+  IMPLICIT NONE 
+!=====================================================================
+! Objet : depot humide (lessivage et evaporation) de traceurs
+! Inspired by routines of Olivier Boucher (mars 1998)
+! author R. Pilon 10 octobre 2012
+! last modification 16/01/2013 (reformulation partie evaporation)
+!=====================================================================
+
+  include "dimensions.h"
+  include "chem.h"
+  include "YOMCST.h"
+  include "YOECUMF.h" 
+
+  REAL,INTENT(IN)                        :: pdtime ! time step (s)
+  INTEGER,INTENT(IN)                     :: it     ! tracer number
+  INTEGER,INTENT(IN)                     :: iflag_lscav ! LS scavenging param:
+!                                             3=Reddy_Boucher2004, 4=3+RPilon.
+  REAL,DIMENSION(klon,klev+1),INTENT(IN) :: flxr     ! flux precipitant de pluie
+  REAL,DIMENSION(klon,klev+1),INTENT(IN) :: flxs     ! flux precipitant de neige
+  REAL,INTENT(IN)                        :: oliq ! contenu en eau liquide dans le nuage (kg/kg)
+  REAL,DIMENSION(klon,klev),INTENT(IN)   :: rneb
+  REAL,DIMENSION(klon,klev),INTENT(IN)   :: pplay    ! pression
+  REAL,DIMENSION(klon,klev+1),INTENT(IN) :: paprs    ! pression
+  REAL,DIMENSION(klon,klev),INTENT(IN)   :: t        ! temperature
+! tracers
+  REAL,DIMENSION(klon,klev,nbtr),INTENT(IN)   :: tr_seri        ! q de traceur  
+  REAL,DIMENSION(klon,klev),INTENT(IN)        :: beta_fisrt     ! taux de conversion de l'eau cond
+  REAL,DIMENSION(klon,klev),INTENT(OUT)       :: beta_v1        ! -- (originale version)
+  REAL,DIMENSION(klon)                        :: his_dh         ! tendance de traceur integre verticalement
+  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)  :: d_tr_insc      ! tendance du traceur 
+  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)  :: d_tr_bcscav  ! tendance de traceur
+  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)  :: d_tr_evap
+  REAL,DIMENSION(klon,nbtr),INTENT(OUT)       :: qPrls      !jyg: concentration tra dans pluie LS a la surf.
+  REAL :: dxin,dxev                              ! tendance temporaire de traceur incloud
+  REAL,DIMENSION(klon,klev) :: dxbc       ! tendance temporaire de traceur bc
+
+
+!  variables locales      
+ LOGICAL,SAVE :: debut=.true.
+!$OMP THREADPRIVATE(debut)
+!
+  REAL,PARAMETER :: henry=1.4  ! constante de Henry en mol/l/atm ~1.4 for gases
+  REAL           :: henry_t    !  constante de Henry a T t  (mol/l/atm)
+  REAL,PARAMETER :: kk=2900.   ! coefficient de dependence en T (K)
+  REAL :: f_a     !  rapport de la phase aqueuse a la phase gazeuse
+  REAL :: beta    !  taux de conversion de l'eau en pluie
+
+  INTEGER :: i, k
+  REAL,DIMENSION(klon,klev)    :: scav  !  water liquid content / fraction aqueuse du constituant
+  REAL,DIMENSION(klon,klev)    :: zrho
+  REAL,DIMENSION(klon,klev)    :: zdz
+  REAL,DIMENSION(klon,klev)    :: zmass ! layer mass
+
+  REAL           :: frac_ev       ! cste pour la reevaporation : dropplet shrinking
+!  frac_ev = frac_gas ou frac_aer
+  REAL,PARAMETER :: frac_gas=1.0  ! cste pour la reevaporation pour les gaz
+  REAL           :: frac_aer      ! cste pour la reevaporation pour les particules
+  REAL,DIMENSION(klon,klev) :: deltaP     ! P(i+1)-P(i)
+  REAL,DIMENSION(klon,klev) :: beta_ev    !  dP/P(i+1)
+
+!  101.325  m3/l x Pa/atm
+!  R        Pa.m3/mol/K
+!   cste de dissolution pour le depot humide
+  REAL,SAVE :: frac_fine_scav
+  REAL,SAVE :: frac_coar_scav
+!$OMP THREADPRIVATE(frac_fine_scav, frac_coar_scav)
+
+! below-cloud scav variables
+! aerosol : alpha_r=0.001, gas 0.001  (Pruppacher & Klett 1967)
+  REAL,SAVE :: alpha_r  !  coefficient d'impaction pour la pluie
+  REAL,SAVE :: alpha_s  !  coefficient d'impaction pour la neige  
+  REAL,SAVE :: R_r      !  mean raindrop radius (m) 
+  REAL,SAVE :: R_s      !  mean snow crystal radius (m)
+!$OMP THREADPRIVATE(alpha_r, alpha_s, R_r, R_s)
+  REAL           :: pr, ps, ice, water
+  real :: conserv
+!
+!!!!!!!!!!!!!!!!!!!! choix lessivage !!!!!!!!!!!!!!!!!!!!!!!!
+!!  logical,save  :: inscav_fisrt
+!!! $OMP THREADPRIVATE(inscav_first)
+!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!
+  IF (debut) THEN
+!
+!  inscav_fisrt=.true.
+!  call getin('inscav_fisrt',inscav_fisrt)
+!  if(inscav_fisrt) then 
+!   print*,'beta from fisrtilp.F90, beta = (z_cond - z_oliq)/z_cond, inscav_fisrt=',inscav_fisrt
+!  else
+!   print*,'beta from Reddy and Bocuher 2004 (original version), inscav_fisrt=',inscav_fisrt
+!  endif
+!
+      alpha_r=0.001        !  coefficient d'impaction pour la pluie
+      alpha_s=0.01         !  coefficient d'impaction pour la neige  
+      R_r=0.001            !  mean raindrop radius (m) 
+      R_s=0.001            !  mean snow crystal radius (m)
+      frac_fine_scav=0.7
+      frac_coar_scav=0.7
+!     frac_aer=0.5 ~ droplet size shrinks by evap
+      frac_aer=0.5
+!
+
+!JE to speed up, commented 20140219
+!
+!      OPEN(99,file='lsc_scav_param.data',status='old', &
+!                form='formatted',err=9999)
+!      READ(99,*,end=9998)  alpha_r
+!      READ(99,*,end=9998)  alpha_s
+!      READ(99,*,end=9998)  R_r
+!      READ(99,*,end=9998)  R_s
+!      READ(99,*,end=9998)  frac_fine_scav
+!      READ(99,*,end=9998)  frac_coar_scav
+!      READ(99,*,end=9998)  frac_aer
+!9998  Continue
+!      CLOSE(99)
+!9999  Continue
+!
+!   print*,'alpha_r',alpha_r
+!   print*,'alpha_s',alpha_s
+!   print*,'R_r',R_r
+!   print*,'R_s',R_s
+!   print*,'frac_fine_scav',frac_fine_scav
+!   print*,'frac_coar_scav',frac_coar_scav
+!   print*,'frac_aer ev',frac_aer
+!
+! JE endcomment
+!
+  ENDIF !(debut)
+!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
+! initialization
+  dxin=0.
+  dxev=0.
+  beta_ev=0.
+
+  DO i=1,klon
+   his_dh(i)=0.
+  ENDDO
+
+  DO k=1,klev
+   DO i=1, klon 
+    dxbc(i,k)=0.
+    beta_v1(i,k)=0.
+    deltaP(i,k)=0.
+   ENDDO
+  ENDDO
+
+  DO k=1,klev
+    DO i=1, klon
+     d_tr_insc(i,k,it)=0.
+     d_tr_bcscav(i,k,it)=0.
+     d_tr_evap(i,k,it)=0.
+    ENDDO
+  ENDDO
+
+!  pressure and size of the layer
+  DO k=klev-1, 1, -1
+   DO i=1, klon 
+     zrho(i,k)=pplay(i,k)/t(i,k)/RD   
+     zdz(i,k)=(paprs(i,k)-paprs(i,k+1))/zrho(i,k)/RG
+     zmass(i,k)=(paprs(i,k)-paprs(i,k+1))/RG
+   ENDDO
+  ENDDO
+
+    IF (it.gt.1) THEN                               !  aerosol   
+      frac_ev=frac_aer
+    ELSE                                                !  gas
+      frac_ev=frac_gas
+    ENDIF
+
+    IF(it.gt.1) then  ! aerosol
+     DO k=1, klev
+      DO i=1, klon 
+       scav(i,k)=frac_fine_scav
+      ENDDO 
+     ENDDO
+    ELSE                  ! gas
+     DO k=1, klev
+      DO i=1, klon 
+       henry_t=henry*exp(-kk*(1./298.-1./t(i,k)))    !  mol/l/atm
+       f_a=henry_t/101.325*R*t(i,k)*oliq*zrho(i,k)/rho_water
+       scav(i,k)=f_a/(1.+f_a)
+      ENDDO 
+     ENDDO
+    ENDIF
+
+   DO k=klev-1, 1, -1
+    DO i=1, klon 
+!  incloud scavenging
+!   if(inscav_fisrt) then 
+   if (iflag_lscav .eq. 4) then
+      beta=beta_fisrt(i,k)*rneb(i,k)
+   else
+      beta=flxr(i,k)-flxr(i,k+1)+flxs(i,k)-flxs(i,k+1)
+!      beta=beta/zdz(i,k)/oliq/zrho(i,k)
+      beta=beta/zmass(i,k)/oliq
+      beta=MAX(0.,beta)
+   endif ! (iflag_lscav .eq. 4)
+   beta_v1(i,k)=beta    !! for output
+!
+      dxin=tr_seri(i,k,it)*(exp(-scav(i,k)*beta*pdtime)-1.)
+!      his_dh(i)=his_dh(i)-dxin*zrho(i,k)*zdz(i,k)/pdtime !  kg/m2/s
+      his_dh(i)=his_dh(i)-dxin*zmass(i,k)/pdtime !  kg/m2/s
+      d_tr_insc(i,k,it)=dxin
+
+!  below-cloud impaction
+    IF(it.eq.1) then
+      d_tr_bcscav(i,k,it)=0.
+    ELSE
+     pr=0.5*(flxr(i,k)+flxr(i,k+1))
+     ps=0.5*(flxs(i,k)+flxs(i,k+1))
+     water=pr*alpha_r/R_r/rho_water
+     ice=ps*alpha_s/R_s/rho_ice
+     dxbc(i,k)=-3./4.*tr_seri(i,k,it)*pdtime*(water+ice)
+!   add tracers from below cloud scav in his_dh
+     his_dh(i)=his_dh(i)-dxbc(i,k)*zmass(i,k)/pdtime !  kg/m2/s
+     d_tr_bcscav(i,k,it)=dxbc(i,k)
+    ENDIF
+
+!  reevaporation
+      deltaP(i,k)=flxr(i,k+1)+flxs(i,k+1)-flxr(i,k)-flxs(i,k)
+      deltaP(i,k)=max(deltaP(i,k),0.)
+
+      if(flxr(i,k+1)+flxs(i,k+1).gt.1.e-16) then
+       beta_ev(i,k)=deltaP(i,k)/(flxr(i,k+1)+flxs(i,k+1))
+      else
+       beta_ev(i,k)=0.
+      endif
+
+      beta_ev(i,k)=max(min(1.,beta_ev(i,k)),0.)
+
+!jyg
+      
+      if(abs(1-(1-frac_ev)*beta_ev(i,k)).gt.1.e-16) then
+! remove tracers from precipitation owing to release by evaporation in his_dh
+!      dxev=frac_ev*beta_ev(i,k)*his_dh(i) *pdtime/(zrho(i,k)*zdz(i,k)) &
+      dxev=frac_ev*beta_ev(i,k)*his_dh(i) *pdtime/(zmass(i,k)) &
+                                      /(1 -(1-frac_ev)*beta_ev(i,k))
+       his_dh(i)=his_dh(i)*(1 - frac_ev*beta_ev(i,k) / (1 -(1-frac_ev)*beta_ev(i,k)))
+      else
+!       dxev=his_dh(i) *pdtime/(zrho(i,k)*zdz(i,k))
+       dxev=his_dh(i) *pdtime/(zmass(i,k))
+       his_dh(i)=0.
+      endif
+!      print*,  k, 'beta_ev',beta_ev
+! remove tracers from precipitation owing to release by evaporation in his_dh
+!!      dxev=frac_ev*deltaP(i,k)*pdtime * his_dh(i) /(zrho(i,k)*zdz(i,k))
+!rplmd
+!!      dxev=frac_ev*deltaP(i,k)*his_dh(i) *pdtime/(zrho(i,k)*zdz(i,k)) &
+!!                                      /max(flxr(i,k)+flxs(i,k),1.e-16)
+
+
+      d_tr_evap(i,k,it)=dxev
+!!     tendency is further added in phytrac x = x + dx
+    ENDDO !!  do i
+   ENDDO  !! do k
+
+!jyg (20130114)
+   DO i = 1,klon
+     qPrls(i,it) = his_dh(i)/max(flxr(i,1)+flxs(i,1),1.e-16)
+   ENDDO
+!jyg end
+
+
+! test de conservation
+      conserv=0.
+!      DO k= klev,1,-1
+!        DO i=1, klon
+!         conserv=conserv+d_tr_insc(i,k,it)*(paprs(i,k)-paprs(i,k+1))/RG &
+!                +d_tr_bcscav(i,k,it)*(paprs(i,k)-paprs(i,k+1))/RG  &
+!                +d_tr_evap(i,k,it)*(paprs(i,k)-paprs(i,k+1))/RG
+!      if(it.eq.3) write(*,'(I2,2X,a,e20.12,2X,a,e20.12,2X,a,e20.12,2X,a,e20.12)'),&
+!      k,'lsc conserv ',conserv,'insc',d_tr_insc(i,k,it),'bc',d_tr_bcscav(i,k,it),'ev',d_tr_evap(i,k,it)
+!       ENDDO
+!     ENDDO
+
+END SUBROUTINE lsc_scav_orig
Index: DZ6/trunk/libf/phylmd/Dust/lsc_scav_spl.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/Dust/lsc_scav_spl.F90	(revision 5267)
+++ 	(revision )
@@ -1,302 +1,0 @@
-!$Id $
-
-SUBROUTINE lsc_scav_spl(pdtime,it,iflag_lscav,oliq,flxr,flxs,rneb,beta_fisrt,  &
-                    beta_v1,pplay,paprs,t,tr_seri,d_tr_insc,          &
-                    alpha_r,alpha_s,kk, henry,     &
-                    id_prec,id_fine,id_coss, id_codu, id_scdu, &
-                    d_tr_bcscav,d_tr_evap,qPrls) 
-  USE ioipsl
-  USE dimphy
-  USE mod_grid_phy_lmdz
-  USE mod_phys_lmdz_para
-  USE traclmdz_mod
-  USE infotrac,ONLY : nbtr
-!  USE comgeomphy
-  USE iophy
-  IMPLICIT NONE 
-!=====================================================================
-! Objet : depot humide (lessivage et evaporation) de traceurs
-! Inspired by routines of Olivier Boucher (mars 1998)
-! author R. Pilon 10 octobre 2012
-! last modification 16/01/2013 (reformulation partie evaporation)
-!=====================================================================
-! SPLA version taken from trunk revision 2041
-
-  include "dimensions.h"
-  include "chem.h"
-  include "YOMCST.h"
-  include "YOECUMF.h" 
-
-  REAL,INTENT(IN)                        :: pdtime ! time step (s)
-  INTEGER,INTENT(IN)                     :: it     ! tracer number
-  INTEGER,INTENT(IN)                     :: iflag_lscav ! LS scavenging param:
-!                                             3=Reddy_Boucher2004, 4=3+RPilon.
-  REAL,DIMENSION(klon,klev+1),INTENT(IN) :: flxr     ! flux precipitant de pluie
-  REAL,DIMENSION(klon,klev+1),INTENT(IN) :: flxs     ! flux precipitant de neige
-  REAL,INTENT(IN)                        :: oliq ! contenu en eau liquide dans le nuage (kg/kg)
-  REAL,DIMENSION(klon,klev),INTENT(IN)   :: rneb
-  REAL,DIMENSION(klon,klev),INTENT(IN)   :: pplay    ! pression
-  REAL,DIMENSION(klon,klev+1),INTENT(IN) :: paprs    ! pression
-  REAL,DIMENSION(klon,klev),INTENT(IN)   :: t        ! temperature
-! tracers
-  REAL,DIMENSION(klon,klev,nbtr),INTENT(IN)   :: tr_seri        ! q de traceur  
-  REAL,DIMENSION(klon,klev),INTENT(IN)        :: beta_fisrt     ! taux de conversion de l'eau cond
-  REAL,DIMENSION(klon,klev),INTENT(OUT)       :: beta_v1        ! -- (originale version)
-  REAL,DIMENSION(klon)                        :: his_dh         ! tendance de traceur integre verticalement
-  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)  :: d_tr_insc      ! tendance du traceur 
-  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)  :: d_tr_bcscav  ! tendance de traceur
-  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)  :: d_tr_evap
-  REAL,DIMENSION(klon,nbtr),INTENT(OUT)       :: qPrls      !jyg: concentration tra dans pluie LS a la surf.
-  REAL :: dxin,dxev                              ! tendance temporaire de traceur incloud
-  REAL,DIMENSION(klon,klev) :: dxbc       ! tendance temporaire de traceur bc
-
-  INTEGER :: id_prec,id_fine,id_coss, id_codu, id_scdu
-
-!  variables locales      
- LOGICAL,SAVE :: debut=.true.
-!$OMP THREADPRIVATE(debut)
-!
-!JE  REAL,PARAMETER :: henry=1.4  ! constante de Henry en mol/l/atm ~1.4 for gases
-  REAL,DIMENSION(nbtr) :: henry  ! constante de Henry en mol/l/atm ~1.4 for gases
-  REAL           :: henry_t    !  constante de Henry a T t  (mol/l/atm)
-!JE  REAL,PARAMETER :: kk=2900.   ! coefficient de dependence en T (K)
-  REAL,DIMENSION(nbtr) :: kk   ! coefficient de dependence en T (K)
-  REAL :: f_a     !  rapport de la phase aqueuse a la phase gazeuse
-  REAL :: beta    !  taux de conversion de l'eau en pluie
-
-  INTEGER :: i, k
-  REAL,DIMENSION(klon,klev)    :: scav  !  water liquid content / fraction aqueuse du constituant
-  REAL,DIMENSION(klon,klev)    :: zrho
-  REAL,DIMENSION(klon,klev)    :: zdz
-  REAL,DIMENSION(klon,klev)    :: zmass ! layer mass
-
-  REAL           :: frac_ev       ! cste pour la reevaporation : dropplet shrinking
-!  frac_ev = frac_gas ou frac_aer
-  REAL,PARAMETER :: frac_gas=1.0  ! cste pour la reevaporation pour les gaz
-  REAL           :: frac_aer      ! cste pour la reevaporation pour les particules
-  REAL,DIMENSION(klon,klev) :: deltaP     ! P(i+1)-P(i)
-  REAL,DIMENSION(klon,klev) :: beta_ev    !  dP/P(i+1)
-
-!  101.325  m3/l x Pa/atm
-!  R        Pa.m3/mol/K
-!   cste de dissolution pour le depot humide
-  REAL,SAVE :: frac_fine_scav
-  REAL,SAVE :: frac_coar_scav
-!$OMP THREADPRIVATE(frac_fine_scav, frac_coar_scav)
-
-! below-cloud scav variables
-! aerosol : alpha_r=0.001, gas 0.001  (Pruppacher & Klett 1967)
-!JE<<
-!  REAL,SAVE :: alpha_r  !  coefficient d'impaction pour la pluie
-!  REAL,SAVE :: alpha_s  !  coefficient d'impaction pour la neige  
-!JE>>
-  REAL, DIMENSION(nbtr) :: alpha_r  !  coefficient d'impaction pour la pluie
-  REAL, DIMENSION(nbtr) :: alpha_s  !  coefficient d'impaction pour la neige  
-  REAL,SAVE :: R_r      !  mean raindrop radius (m) 
-  REAL,SAVE :: R_s      !  mean snow crystal radius (m)
-!!! $OMP THREADPRIVATE(alpha_r, alpha_s, R_r, R_s)
-!$OMP THREADPRIVATE(R_r, R_s)
-  REAL           :: pr, ps, ice, water
-  real :: conserv
-!
-!!!!!!!!!!!!!!!!!!!! choix lessivage !!!!!!!!!!!!!!!!!!!!!!!!
-!!  logical,save  :: inscav_fisrt
-!!! $OMP THREADPRIVATE(inscav_first)
-!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!
-  IF (debut) THEN
-!
-!  inscav_fisrt=.true.
-!  call getin('inscav_fisrt',inscav_fisrt)
-!  if(inscav_fisrt) then 
-!   print*,'beta from fisrtilp.F90, beta = (z_cond - z_oliq)/z_cond, inscav_fisrt=',inscav_fisrt
-!  else
-!   print*,'beta from Reddy and Bocuher 2004 (original version), inscav_fisrt=',inscav_fisrt
-!  endif
-!
-!JE      alpha_r=0.001        !  coefficient d'impaction pour la pluie
-!JE      alpha_s=0.01         !  coefficient d'impaction pour la neige  
-      R_r=0.001            !  mean raindrop radius (m) 
-      R_s=0.001            !  mean snow crystal radius (m)
-      frac_fine_scav=0.7
-      frac_coar_scav=0.7
-!     frac_aer=0.5 ~ droplet size shrinks by evap
-      frac_aer=0.5
-!
-
-!JE to speed up, commented 20140219
-!
-!      OPEN(99,file='lsc_scav_param.data',status='old', &
-!                form='formatted',err=9999)
-!      READ(99,*,end=9998)  alpha_r
-!      READ(99,*,end=9998)  alpha_s
-!      READ(99,*,end=9998)  R_r
-!      READ(99,*,end=9998)  R_s
-!      READ(99,*,end=9998)  frac_fine_scav
-!      READ(99,*,end=9998)  frac_coar_scav
-!      READ(99,*,end=9998)  frac_aer
-!9998  Continue
-!      CLOSE(99)
-!9999  Continue
-!
-!   print*,'JE alpha_r',alpha_r
-!   print*,'JE alpha_s',alpha_s
-!   print*,'JE R_r',R_r
-!   print*,'JE R_s',R_s
-!   print*,'frac_fine_scav',frac_fine_scav
-!   print*,'frac_coar_scav',frac_coar_scav
-!   print*,'frac_aer ev',frac_aer
-!
-! JE endcomment
-!
-  ENDIF !(debut)
-!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!
-! initialization
-  dxin=0.
-  dxev=0.
-  beta_ev=0.
-
-  DO i=1,klon
-   his_dh(i)=0.
-  ENDDO
-
-  DO k=1,klev
-   DO i=1, klon 
-    dxbc(i,k)=0.
-    beta_v1(i,k)=0.
-    deltaP(i,k)=0.
-   ENDDO
-  ENDDO
-
-  DO k=1,klev
-    DO i=1, klon
-     d_tr_insc(i,k,it)=0.
-     d_tr_bcscav(i,k,it)=0.
-     d_tr_evap(i,k,it)=0.
-    ENDDO
-  ENDDO
-
-!  pressure and size of the layer
-  DO k=klev, 1, -1
-   DO i=1, klon 
-     zrho(i,k)=pplay(i,k)/t(i,k)/RD   
-     zdz(i,k)=(paprs(i,k)-paprs(i,k+1))/zrho(i,k)/RG
-     zmass(i,k)=(paprs(i,k)-paprs(i,k+1))/RG
-   ENDDO
-  ENDDO
-
-!JE<<
-    IF (it.eq.id_prec) THEN                               !  gas
-      frac_ev=frac_gas
-    ELSE                                   !aerosol
-      frac_ev=frac_aer
-    ENDIF
-
-    IF (it.eq.id_prec) THEN                               !  gas
-     DO k=1, klev
-      DO i=1, klon 
-       henry_t=henry(it)*exp(-kk(it)*(1./298.-1./t(i,k)))    !  mol/l/atm
-       f_a=henry_t/101.325*R*t(i,k)*oliq*zrho(i,k)/rho_water
-       scav(i,k)=f_a/(1.+f_a)
-      ENDDO 
-     ENDDO
-    ELSE                            !aerosol
-     DO k=1, klev
-      DO i=1, klon
-       scav(i,k)=frac_fine_scav
-      ENDDO
-     ENDDO
-    ENDIF
-!JE>>
-   DO k=klev-1, 1, -1
-    DO i=1, klon 
-!  incloud scavenging
-!   if(inscav_fisrt) then 
-   if (iflag_lscav .eq. 4) then
-      beta=beta_fisrt(i,k)*rneb(i,k)
-   else
-      beta=flxr(i,k)-flxr(i,k+1)+flxs(i,k)-flxs(i,k+1)
-!      beta=beta/zdz(i,k)/oliq/zrho(i,k)
-      beta=beta/zmass(i,k)/oliq
-      beta=MAX(0.,beta)
-   endif ! (iflag_lscav .eq. 4)
-   beta_v1(i,k)=beta    !! for output
-!
-      dxin=tr_seri(i,k,it)*(exp(-scav(i,k)*beta*pdtime)-1.)
-!      his_dh(i)=his_dh(i)-dxin*zrho(i,k)*zdz(i,k)/pdtime !  kg/m2/s
-      his_dh(i)=his_dh(i)-dxin*zmass(i,k)/pdtime !  kg/m2/s
-      d_tr_insc(i,k,it)=dxin
-
-!  below-cloud impaction
-    IF(it.eq.id_prec) then
-      d_tr_bcscav(i,k,it)=0.
-    ELSE
-     pr=0.5*(flxr(i,k)+flxr(i,k+1))
-     ps=0.5*(flxs(i,k)+flxs(i,k+1))
-     water=pr*alpha_r(it)/R_r/rho_water
-     ice=ps*alpha_s(it)/R_s/rho_ice
-     dxbc(i,k)=-3./4.*tr_seri(i,k,it)*pdtime*(water+ice)
-!   add tracers from below cloud scav in his_dh
-     his_dh(i)=his_dh(i)-dxbc(i,k)*zmass(i,k)/pdtime !  kg/m2/s
-     d_tr_bcscav(i,k,it)=dxbc(i,k)
-    ENDIF
-
-!  reevaporation
-      deltaP(i,k)=flxr(i,k+1)+flxs(i,k+1)-flxr(i,k)-flxs(i,k)
-      deltaP(i,k)=max(deltaP(i,k),0.)
-
-      if(flxr(i,k+1)+flxs(i,k+1).gt.1.e-16) then
-       beta_ev(i,k)=deltaP(i,k)/(flxr(i,k+1)+flxs(i,k+1))
-      else
-       beta_ev(i,k)=0.
-      endif
-
-      beta_ev(i,k)=max(min(1.,beta_ev(i,k)),0.)
-
-!jyg
-      
-      if(abs(1-(1-frac_ev)*beta_ev(i,k)).gt.1.e-16) then
-! remove tracers from precipitation owing to release by evaporation in his_dh
-!      dxev=frac_ev*beta_ev(i,k)*his_dh(i) *pdtime/(zrho(i,k)*zdz(i,k)) &
-      dxev=frac_ev*beta_ev(i,k)*his_dh(i) *pdtime/(zmass(i,k)) &
-                                      /(1 -(1-frac_ev)*beta_ev(i,k))
-       his_dh(i)=his_dh(i)*(1 - frac_ev*beta_ev(i,k) / (1 -(1-frac_ev)*beta_ev(i,k)))
-      else
-!       dxev=his_dh(i) *pdtime/(zrho(i,k)*zdz(i,k))
-       dxev=his_dh(i) *pdtime/(zmass(i,k))
-       his_dh(i)=0.
-      endif
-!      print*,  k, 'beta_ev',beta_ev
-! remove tracers from precipitation owing to release by evaporation in his_dh
-!!      dxev=frac_ev*deltaP(i,k)*pdtime * his_dh(i) /(zrho(i,k)*zdz(i,k))
-!rplmd
-!!      dxev=frac_ev*deltaP(i,k)*his_dh(i) *pdtime/(zrho(i,k)*zdz(i,k)) &
-!!                                      /max(flxr(i,k)+flxs(i,k),1.e-16)
-
-
-      d_tr_evap(i,k,it)=dxev
-!!     tendency is further added in phytrac x = x + dx
-    ENDDO !!  do i
-   ENDDO  !! do k
-
-!jyg (20130114)
-   DO i = 1,klon
-     qPrls(i,it) = his_dh(i)/max(flxr(i,1)+flxs(i,1),1.e-16)
-   ENDDO
-!jyg end
-
-
-! test de conservation
-      conserv=0.
-!      DO k= klev,1,-1
-!        DO i=1, klon
-!         conserv=conserv+d_tr_insc(i,k,it)*(paprs(i,k)-paprs(i,k+1))/RG &
-!                +d_tr_bcscav(i,k,it)*(paprs(i,k)-paprs(i,k+1))/RG  &
-!                +d_tr_evap(i,k,it)*(paprs(i,k)-paprs(i,k+1))/RG
-!      if(it.eq.3) write(*,'(I2,2X,a,e20.12,2X,a,e20.12,2X,a,e20.12,2X,a,e20.12)'),&
-!      k,'lsc conserv ',conserv,'insc',d_tr_insc(i,k,it),'bc',d_tr_bcscav(i,k,it),'ev',d_tr_evap(i,k,it)
-!       ENDDO
-!     ENDDO
-
-END SUBROUTINE lsc_scav_spl
Index: /LMDZ6/trunk/libf/phylmd/Dust/lsc_scav_spl.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/Dust/lsc_scav_spl.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/Dust/lsc_scav_spl.f90	(revision 5268)
@@ -0,0 +1,302 @@
+!$Id $
+
+SUBROUTINE lsc_scav_spl(pdtime,it,iflag_lscav,oliq,flxr,flxs,rneb,beta_fisrt,  &
+                    beta_v1,pplay,paprs,t,tr_seri,d_tr_insc,          &
+                    alpha_r,alpha_s,kk, henry,     &
+                    id_prec,id_fine,id_coss, id_codu, id_scdu, &
+                    d_tr_bcscav,d_tr_evap,qPrls) 
+  USE ioipsl
+  USE dimphy
+  USE mod_grid_phy_lmdz
+  USE mod_phys_lmdz_para
+  USE traclmdz_mod
+  USE infotrac,ONLY : nbtr
+!  USE comgeomphy
+  USE iophy
+  IMPLICIT NONE 
+!=====================================================================
+! Objet : depot humide (lessivage et evaporation) de traceurs
+! Inspired by routines of Olivier Boucher (mars 1998)
+! author R. Pilon 10 octobre 2012
+! last modification 16/01/2013 (reformulation partie evaporation)
+!=====================================================================
+! SPLA version taken from trunk revision 2041
+
+  include "dimensions.h"
+  include "chem.h"
+  include "YOMCST.h"
+  include "YOECUMF.h" 
+
+  REAL,INTENT(IN)                        :: pdtime ! time step (s)
+  INTEGER,INTENT(IN)                     :: it     ! tracer number
+  INTEGER,INTENT(IN)                     :: iflag_lscav ! LS scavenging param:
+!                                             3=Reddy_Boucher2004, 4=3+RPilon.
+  REAL,DIMENSION(klon,klev+1),INTENT(IN) :: flxr     ! flux precipitant de pluie
+  REAL,DIMENSION(klon,klev+1),INTENT(IN) :: flxs     ! flux precipitant de neige
+  REAL,INTENT(IN)                        :: oliq ! contenu en eau liquide dans le nuage (kg/kg)
+  REAL,DIMENSION(klon,klev),INTENT(IN)   :: rneb
+  REAL,DIMENSION(klon,klev),INTENT(IN)   :: pplay    ! pression
+  REAL,DIMENSION(klon,klev+1),INTENT(IN) :: paprs    ! pression
+  REAL,DIMENSION(klon,klev),INTENT(IN)   :: t        ! temperature
+! tracers
+  REAL,DIMENSION(klon,klev,nbtr),INTENT(IN)   :: tr_seri        ! q de traceur  
+  REAL,DIMENSION(klon,klev),INTENT(IN)        :: beta_fisrt     ! taux de conversion de l'eau cond
+  REAL,DIMENSION(klon,klev),INTENT(OUT)       :: beta_v1        ! -- (originale version)
+  REAL,DIMENSION(klon)                        :: his_dh         ! tendance de traceur integre verticalement
+  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)  :: d_tr_insc      ! tendance du traceur 
+  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)  :: d_tr_bcscav  ! tendance de traceur
+  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)  :: d_tr_evap
+  REAL,DIMENSION(klon,nbtr),INTENT(OUT)       :: qPrls      !jyg: concentration tra dans pluie LS a la surf.
+  REAL :: dxin,dxev                              ! tendance temporaire de traceur incloud
+  REAL,DIMENSION(klon,klev) :: dxbc       ! tendance temporaire de traceur bc
+
+  INTEGER :: id_prec,id_fine,id_coss, id_codu, id_scdu
+
+!  variables locales      
+ LOGICAL,SAVE :: debut=.true.
+!$OMP THREADPRIVATE(debut)
+!
+!JE  REAL,PARAMETER :: henry=1.4  ! constante de Henry en mol/l/atm ~1.4 for gases
+  REAL,DIMENSION(nbtr) :: henry  ! constante de Henry en mol/l/atm ~1.4 for gases
+  REAL           :: henry_t    !  constante de Henry a T t  (mol/l/atm)
+!JE  REAL,PARAMETER :: kk=2900.   ! coefficient de dependence en T (K)
+  REAL,DIMENSION(nbtr) :: kk   ! coefficient de dependence en T (K)
+  REAL :: f_a     !  rapport de la phase aqueuse a la phase gazeuse
+  REAL :: beta    !  taux de conversion de l'eau en pluie
+
+  INTEGER :: i, k
+  REAL,DIMENSION(klon,klev)    :: scav  !  water liquid content / fraction aqueuse du constituant
+  REAL,DIMENSION(klon,klev)    :: zrho
+  REAL,DIMENSION(klon,klev)    :: zdz
+  REAL,DIMENSION(klon,klev)    :: zmass ! layer mass
+
+  REAL           :: frac_ev       ! cste pour la reevaporation : dropplet shrinking
+!  frac_ev = frac_gas ou frac_aer
+  REAL,PARAMETER :: frac_gas=1.0  ! cste pour la reevaporation pour les gaz
+  REAL           :: frac_aer      ! cste pour la reevaporation pour les particules
+  REAL,DIMENSION(klon,klev) :: deltaP     ! P(i+1)-P(i)
+  REAL,DIMENSION(klon,klev) :: beta_ev    !  dP/P(i+1)
+
+!  101.325  m3/l x Pa/atm
+!  R        Pa.m3/mol/K
+!   cste de dissolution pour le depot humide
+  REAL,SAVE :: frac_fine_scav
+  REAL,SAVE :: frac_coar_scav
+!$OMP THREADPRIVATE(frac_fine_scav, frac_coar_scav)
+
+! below-cloud scav variables
+! aerosol : alpha_r=0.001, gas 0.001  (Pruppacher & Klett 1967)
+!JE<<
+!  REAL,SAVE :: alpha_r  !  coefficient d'impaction pour la pluie
+!  REAL,SAVE :: alpha_s  !  coefficient d'impaction pour la neige  
+!JE>>
+  REAL, DIMENSION(nbtr) :: alpha_r  !  coefficient d'impaction pour la pluie
+  REAL, DIMENSION(nbtr) :: alpha_s  !  coefficient d'impaction pour la neige  
+  REAL,SAVE :: R_r      !  mean raindrop radius (m) 
+  REAL,SAVE :: R_s      !  mean snow crystal radius (m)
+!!! $OMP THREADPRIVATE(alpha_r, alpha_s, R_r, R_s)
+!$OMP THREADPRIVATE(R_r, R_s)
+  REAL           :: pr, ps, ice, water
+  real :: conserv
+!
+!!!!!!!!!!!!!!!!!!!! choix lessivage !!!!!!!!!!!!!!!!!!!!!!!!
+!!  logical,save  :: inscav_fisrt
+!!! $OMP THREADPRIVATE(inscav_first)
+!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!
+  IF (debut) THEN
+!
+!  inscav_fisrt=.true.
+!  call getin('inscav_fisrt',inscav_fisrt)
+!  if(inscav_fisrt) then 
+!   print*,'beta from fisrtilp.F90, beta = (z_cond - z_oliq)/z_cond, inscav_fisrt=',inscav_fisrt
+!  else
+!   print*,'beta from Reddy and Bocuher 2004 (original version), inscav_fisrt=',inscav_fisrt
+!  endif
+!
+!JE      alpha_r=0.001        !  coefficient d'impaction pour la pluie
+!JE      alpha_s=0.01         !  coefficient d'impaction pour la neige  
+      R_r=0.001            !  mean raindrop radius (m) 
+      R_s=0.001            !  mean snow crystal radius (m)
+      frac_fine_scav=0.7
+      frac_coar_scav=0.7
+!     frac_aer=0.5 ~ droplet size shrinks by evap
+      frac_aer=0.5
+!
+
+!JE to speed up, commented 20140219
+!
+!      OPEN(99,file='lsc_scav_param.data',status='old', &
+!                form='formatted',err=9999)
+!      READ(99,*,end=9998)  alpha_r
+!      READ(99,*,end=9998)  alpha_s
+!      READ(99,*,end=9998)  R_r
+!      READ(99,*,end=9998)  R_s
+!      READ(99,*,end=9998)  frac_fine_scav
+!      READ(99,*,end=9998)  frac_coar_scav
+!      READ(99,*,end=9998)  frac_aer
+!9998  Continue
+!      CLOSE(99)
+!9999  Continue
+!
+!   print*,'JE alpha_r',alpha_r
+!   print*,'JE alpha_s',alpha_s
+!   print*,'JE R_r',R_r
+!   print*,'JE R_s',R_s
+!   print*,'frac_fine_scav',frac_fine_scav
+!   print*,'frac_coar_scav',frac_coar_scav
+!   print*,'frac_aer ev',frac_aer
+!
+! JE endcomment
+!
+  ENDIF !(debut)
+!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
+! initialization
+  dxin=0.
+  dxev=0.
+  beta_ev=0.
+
+  DO i=1,klon
+   his_dh(i)=0.
+  ENDDO
+
+  DO k=1,klev
+   DO i=1, klon 
+    dxbc(i,k)=0.
+    beta_v1(i,k)=0.
+    deltaP(i,k)=0.
+   ENDDO
+  ENDDO
+
+  DO k=1,klev
+    DO i=1, klon
+     d_tr_insc(i,k,it)=0.
+     d_tr_bcscav(i,k,it)=0.
+     d_tr_evap(i,k,it)=0.
+    ENDDO
+  ENDDO
+
+!  pressure and size of the layer
+  DO k=klev, 1, -1
+   DO i=1, klon 
+     zrho(i,k)=pplay(i,k)/t(i,k)/RD   
+     zdz(i,k)=(paprs(i,k)-paprs(i,k+1))/zrho(i,k)/RG
+     zmass(i,k)=(paprs(i,k)-paprs(i,k+1))/RG
+   ENDDO
+  ENDDO
+
+!JE<<
+    IF (it.eq.id_prec) THEN                               !  gas
+      frac_ev=frac_gas
+    ELSE                                   !aerosol
+      frac_ev=frac_aer
+    ENDIF
+
+    IF (it.eq.id_prec) THEN                               !  gas
+     DO k=1, klev
+      DO i=1, klon 
+       henry_t=henry(it)*exp(-kk(it)*(1./298.-1./t(i,k)))    !  mol/l/atm
+       f_a=henry_t/101.325*R*t(i,k)*oliq*zrho(i,k)/rho_water
+       scav(i,k)=f_a/(1.+f_a)
+      ENDDO 
+     ENDDO
+    ELSE                            !aerosol
+     DO k=1, klev
+      DO i=1, klon
+       scav(i,k)=frac_fine_scav
+      ENDDO
+     ENDDO
+    ENDIF
+!JE>>
+   DO k=klev-1, 1, -1
+    DO i=1, klon 
+!  incloud scavenging
+!   if(inscav_fisrt) then 
+   if (iflag_lscav .eq. 4) then
+      beta=beta_fisrt(i,k)*rneb(i,k)
+   else
+      beta=flxr(i,k)-flxr(i,k+1)+flxs(i,k)-flxs(i,k+1)
+!      beta=beta/zdz(i,k)/oliq/zrho(i,k)
+      beta=beta/zmass(i,k)/oliq
+      beta=MAX(0.,beta)
+   endif ! (iflag_lscav .eq. 4)
+   beta_v1(i,k)=beta    !! for output
+!
+      dxin=tr_seri(i,k,it)*(exp(-scav(i,k)*beta*pdtime)-1.)
+!      his_dh(i)=his_dh(i)-dxin*zrho(i,k)*zdz(i,k)/pdtime !  kg/m2/s
+      his_dh(i)=his_dh(i)-dxin*zmass(i,k)/pdtime !  kg/m2/s
+      d_tr_insc(i,k,it)=dxin
+
+!  below-cloud impaction
+    IF(it.eq.id_prec) then
+      d_tr_bcscav(i,k,it)=0.
+    ELSE
+     pr=0.5*(flxr(i,k)+flxr(i,k+1))
+     ps=0.5*(flxs(i,k)+flxs(i,k+1))
+     water=pr*alpha_r(it)/R_r/rho_water
+     ice=ps*alpha_s(it)/R_s/rho_ice
+     dxbc(i,k)=-3./4.*tr_seri(i,k,it)*pdtime*(water+ice)
+!   add tracers from below cloud scav in his_dh
+     his_dh(i)=his_dh(i)-dxbc(i,k)*zmass(i,k)/pdtime !  kg/m2/s
+     d_tr_bcscav(i,k,it)=dxbc(i,k)
+    ENDIF
+
+!  reevaporation
+      deltaP(i,k)=flxr(i,k+1)+flxs(i,k+1)-flxr(i,k)-flxs(i,k)
+      deltaP(i,k)=max(deltaP(i,k),0.)
+
+      if(flxr(i,k+1)+flxs(i,k+1).gt.1.e-16) then
+       beta_ev(i,k)=deltaP(i,k)/(flxr(i,k+1)+flxs(i,k+1))
+      else
+       beta_ev(i,k)=0.
+      endif
+
+      beta_ev(i,k)=max(min(1.,beta_ev(i,k)),0.)
+
+!jyg
+      
+      if(abs(1-(1-frac_ev)*beta_ev(i,k)).gt.1.e-16) then
+! remove tracers from precipitation owing to release by evaporation in his_dh
+!      dxev=frac_ev*beta_ev(i,k)*his_dh(i) *pdtime/(zrho(i,k)*zdz(i,k)) &
+      dxev=frac_ev*beta_ev(i,k)*his_dh(i) *pdtime/(zmass(i,k)) &
+                                      /(1 -(1-frac_ev)*beta_ev(i,k))
+       his_dh(i)=his_dh(i)*(1 - frac_ev*beta_ev(i,k) / (1 -(1-frac_ev)*beta_ev(i,k)))
+      else
+!       dxev=his_dh(i) *pdtime/(zrho(i,k)*zdz(i,k))
+       dxev=his_dh(i) *pdtime/(zmass(i,k))
+       his_dh(i)=0.
+      endif
+!      print*,  k, 'beta_ev',beta_ev
+! remove tracers from precipitation owing to release by evaporation in his_dh
+!!      dxev=frac_ev*deltaP(i,k)*pdtime * his_dh(i) /(zrho(i,k)*zdz(i,k))
+!rplmd
+!!      dxev=frac_ev*deltaP(i,k)*his_dh(i) *pdtime/(zrho(i,k)*zdz(i,k)) &
+!!                                      /max(flxr(i,k)+flxs(i,k),1.e-16)
+
+
+      d_tr_evap(i,k,it)=dxev
+!!     tendency is further added in phytrac x = x + dx
+    ENDDO !!  do i
+   ENDDO  !! do k
+
+!jyg (20130114)
+   DO i = 1,klon
+     qPrls(i,it) = his_dh(i)/max(flxr(i,1)+flxs(i,1),1.e-16)
+   ENDDO
+!jyg end
+
+
+! test de conservation
+      conserv=0.
+!      DO k= klev,1,-1
+!        DO i=1, klon
+!         conserv=conserv+d_tr_insc(i,k,it)*(paprs(i,k)-paprs(i,k+1))/RG &
+!                +d_tr_bcscav(i,k,it)*(paprs(i,k)-paprs(i,k+1))/RG  &
+!                +d_tr_evap(i,k,it)*(paprs(i,k)-paprs(i,k+1))/RG
+!      if(it.eq.3) write(*,'(I2,2X,a,e20.12,2X,a,e20.12,2X,a,e20.12,2X,a,e20.12)'),&
+!      k,'lsc conserv ',conserv,'insc',d_tr_insc(i,k,it),'bc',d_tr_bcscav(i,k,it),'ev',d_tr_evap(i,k,it)
+!       ENDDO
+!     ENDDO
+
+END SUBROUTINE lsc_scav_spl
Index: DZ6/trunk/libf/phylmd/Dust/read_dust.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/Dust/read_dust.F90	(revision 5267)
+++ 	(revision )
@@ -1,81 +1,0 @@
-SUBROUTINE read_dust(debutphy, step, nbjour, dust_ec)
-  USE dimphy
-  USE mod_grid_phy_lmdz
-  USE mod_phys_lmdz_para
-  USE netcdf, ONLY: nf90_get_var
-  IMPLICIT NONE
-  !
-  INCLUDE "dimensions.h"
-  INCLUDE "paramet.h"
-  INCLUDE "netcdf.inc"
-  !
-  INTEGER :: step, nbjour
-  LOGICAL :: debutphy
-  real :: dust_ec(klon)
-  real :: dust_ec_glo(klon_glo)
-  !
-  ! as      real dust_nc(iip1,jjp1)
-  real :: dust_nc_glo(nbp_lon+1,nbp_lat)
-  real :: rcode
-  integer :: ncid1, varid1, ncid2, varid2
-
-  save ncid1, varid1, ncid2, varid2
-!$OMP THREADPRIVATE(ncid1, varid1, ncid2, varid2)
-  integer :: start(4),count(4), status
-  integer :: i, j, ig
-  !
-!$OMP MASTER
-  IF (is_mpi_root .AND. is_omp_root) THEN
-  if (debutphy) then
-  !
-     ncid1=NCOPN('dust.nc',NCNOWRIT,rcode)
-     varid1=NCVID(ncid1,'EMISSION',rcode)
-  !
-  endif
-  !
-  start(1)=1
-  start(2)=1
-  start(4)=0
-
-   ! count(1)=iip1
-  count(1)=nbp_lon+1
-   ! count(2)=jjp1
-  count(2)=nbp_lat
-  count(3)=1
-  count(4)=0
-  !
-  start(3)=step
-  !
-  status = nf90_get_var(ncid1, varid1, dust_nc_glo, start, count)
-
-  !
-  !  call correctbid(iim,jjp1,dust_nc)
-  call correctbid(nbp_lon,nbp_lat,dust_nc_glo)
-  !
-  !--upside down + physical grid
-  !
-  !--OB=change jjp1 to 1 here ;
-  !----AS: OB's change is needed if lats N to S (90 to -90) in dust.nc
-  !  dust_ec(1)=MAX(dust_nc(1,jjp1),0.0)
-  dust_ec_glo(1)=MAX(dust_nc_glo(1,nbp_lat),0.0)
-  ig=2
-   ! DO j=2,jjm
-  DO j=2,nbp_lat-1
-      ! DO i = 1, iim
-     DO i = 1, nbp_lon
-  !--OB=change jjp1+1-j to j here
-        ! dust_ec(ig)=MAX(dust_nc(i,jjp1+1-j),0.0)
-       dust_ec_glo(ig)=MAX(dust_nc_glo(i,nbp_lat+1-j),0.0)
-       ig=ig+1
-     ENDDO
-  ENDDO
-  !--OB=change second 1 to jjp1 here
-  dust_ec_glo(ig)=MAX(dust_nc_glo(1,1),0.0)
-   ! end if master
-  ENDIF
-!$OMP END MASTER
-!$OMP BARRIER
-  CALL scatter(dust_ec_glo,dust_ec)
-  !
-  RETURN
-END SUBROUTINE read_dust
Index: /LMDZ6/trunk/libf/phylmd/Dust/read_dust.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/Dust/read_dust.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/Dust/read_dust.f90	(revision 5268)
@@ -0,0 +1,81 @@
+SUBROUTINE read_dust(debutphy, step, nbjour, dust_ec)
+  USE dimphy
+  USE mod_grid_phy_lmdz
+  USE mod_phys_lmdz_para
+  USE netcdf, ONLY: nf90_get_var
+  IMPLICIT NONE
+  !
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  INCLUDE "netcdf.inc"
+  !
+  INTEGER :: step, nbjour
+  LOGICAL :: debutphy
+  real :: dust_ec(klon)
+  real :: dust_ec_glo(klon_glo)
+  !
+  ! as      real dust_nc(iip1,jjp1)
+  real :: dust_nc_glo(nbp_lon+1,nbp_lat)
+  real :: rcode
+  integer :: ncid1, varid1, ncid2, varid2
+
+  save ncid1, varid1, ncid2, varid2
+!$OMP THREADPRIVATE(ncid1, varid1, ncid2, varid2)
+  integer :: start(4),count(4), status
+  integer :: i, j, ig
+  !
+!$OMP MASTER
+  IF (is_mpi_root .AND. is_omp_root) THEN
+  if (debutphy) then
+  !
+     ncid1=NCOPN('dust.nc',NCNOWRIT,rcode)
+     varid1=NCVID(ncid1,'EMISSION',rcode)
+  !
+  endif
+  !
+  start(1)=1
+  start(2)=1
+  start(4)=0
+
+   ! count(1)=iip1
+  count(1)=nbp_lon+1
+   ! count(2)=jjp1
+  count(2)=nbp_lat
+  count(3)=1
+  count(4)=0
+  !
+  start(3)=step
+  !
+  status = nf90_get_var(ncid1, varid1, dust_nc_glo, start, count)
+
+  !
+  !  call correctbid(iim,jjp1,dust_nc)
+  call correctbid(nbp_lon,nbp_lat,dust_nc_glo)
+  !
+  !--upside down + physical grid
+  !
+  !--OB=change jjp1 to 1 here ;
+  !----AS: OB's change is needed if lats N to S (90 to -90) in dust.nc
+  !  dust_ec(1)=MAX(dust_nc(1,jjp1),0.0)
+  dust_ec_glo(1)=MAX(dust_nc_glo(1,nbp_lat),0.0)
+  ig=2
+   ! DO j=2,jjm
+  DO j=2,nbp_lat-1
+      ! DO i = 1, iim
+     DO i = 1, nbp_lon
+  !--OB=change jjp1+1-j to j here
+        ! dust_ec(ig)=MAX(dust_nc(i,jjp1+1-j),0.0)
+       dust_ec_glo(ig)=MAX(dust_nc_glo(i,nbp_lat+1-j),0.0)
+       ig=ig+1
+     ENDDO
+  ENDDO
+  !--OB=change second 1 to jjp1 here
+  dust_ec_glo(ig)=MAX(dust_nc_glo(1,1),0.0)
+   ! end if master
+  ENDIF
+!$OMP END MASTER
+!$OMP BARRIER
+  CALL scatter(dust_ec_glo,dust_ec)
+  !
+  RETURN
+END SUBROUTINE read_dust
Index: DZ6/trunk/libf/phylmd/Dust/read_surface.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/Dust/read_surface.F90	(revision 5267)
+++ 	(revision )
@@ -1,156 +1,0 @@
-       subroutine read_surface(name,surfa)
-
-     
-! common
-! ------
-       USE ioipsl
-!       USE comgeomphy
-       USE dimphy
-       USE mod_grid_phy_lmdz
-       USE mod_phys_lmdz_para
-       USE iophy
-       USE netcdf, ONLY: nf90_get_var
-       IMPLICIT NONE
-
-       INCLUDE "netcdf.inc"
-       INCLUDE "dimensions.h"
-       INCLUDE "paramet.h"
-
-       character*10 name
-       character*10 varname
-!
-       real tmp_dyn(iip1,jjp1)
-       real tmp_dyn_glo(nbp_lon+1,nbp_lat)
-!       real tmp_dyn_glo(nbp_lon,nbp_lat)
-       REAL tmp_dyn_invers(iip1,jjp1)
-       real tmp_dyn_invers_glo(nbp_lon+1,nbp_lat)
-!       real tmp_dyn_invers_glo(nbp_lon,nbp_lat)
-       real tmp_fi(klon)
-       real tmp_fi_glo(klon_glo)
-       real surfa(klon,5)
-       real surfa_glo(klon_glo,5)
-!
-       integer ncid
-       integer varid
-       real rcode
-       integer start(2),count(2),status
-       integer i,j,l,ig
-       character*1 str1
-
-!JE20140526<<
-      character*4 ::  latstr,aux4s
-      logical :: outcycle, isinversed
-      real, dimension(jjp1) :: lats
-      real, dimension(nbp_lat) :: lats_glo
-      real :: rcode2
-      integer, dimension(1) :: startj,endj
-!JE20140526>>
-!$OMP MASTER
-       IF (is_mpi_root .AND. is_omp_root) THEN
-
-       print*,'Lecture du fichier donnees_lisa.nc' 
-       ncid=NCOPN('donnees_lisa.nc',NCNOWRIT,rcode)
-
-!JE20140526<<: check if are inversed or not the latitude grid in donnes_lisa
-      outcycle=.false.
-      latstr='null'
-      isinversed=.false.
-      do i=1,5
-       if (i==1) aux4s='latu'
-       if (i==2) aux4s='LATU'
-       if (i==3) aux4s='LatU'
-       if (i==4) aux4s='Latu'
-       if (i==5) aux4s='latU'
-       status = NF_INQ_VARID (ncid, aux4s, rcode)
-!       print *,'stat,i',status,i,outcycle,aux4s
-!       print *,'ifclause',status.NE. NF_NOERR ,outcycle == .false.
-       IF ((.not.(status.NE. NF_NOERR) ).and.( .not. outcycle )) THEN
-         outcycle=.true.
-         latstr=aux4s
-       ENDIF
-      enddo ! check if it inversed lat
-      startj(1)=1
-!      endj(1)=jjp1
-      endj(1)=nbp_lat
-      varid=NCVID(ncid,latstr,rcode)
-
-          status = nf90_get_var(ncid, varid, lats_glo, startj, endj)
-!      print *,latstr,varid,status,jjp1,rcode
-!      IF (status .NE. NF_NOERR) print*,'NOOOOOOO'
-!      print *,lats
-!stop
-
-! check if netcdf is latitude inversed or not. 
-      if (lats_glo(1)<lats_glo(2)) isinversed=.true.
-! JE20140526>>
-
-
-       DO i=1,5
-          write(str1,'(i1)') i
-          varname=trim(name)//str1
-       print*,'lecture variable:',varname
-          varid=NCVID(ncid,trim(varname),rcode)
-!          varid=NCVID(ncid,varname,rcode)
-
-!  dimensions pour les champs scalaires et le vent zonal
-!  -----------------------------------------------------
-
-          start(1)=1
-          start(2)=1      
-          count(1)=nbp_lon+1
-!          count(1)=iip1
-          count(2)=nbp_lat
-!          count(2)=jjp1
-
-! mise a zero des tableaux 
-! ------------------------
-          tmp_dyn(:,:)=0.0
-          tmp_fi(:)=0.0
-! Lecture
-! -----------------------
-          status = nf90_get_var(ncid, varid, tmp_dyn_glo, start, count)
-
-!      call dump2d(iip1,jjp1,tmp_dyn,'tmp_dyn   ')
-       DO j=1, nbp_lat
-          DO ig=1, nbp_lon+1
-             tmp_dyn_invers_glo(ig,j)=tmp_dyn_glo(ig,nbp_lat-j+1)
-          ENDDO
-       ENDDO
-
-       
-!JE20140522!          call gr_dyn_fi_p(1, iip1, jjp1, klon, tmp_dyn_invers, tmp_fi)
-
-!JE20140526<<
-!              call gr_dyn_fi(1, iip1, jjp1, klon, tmp_dyn_invers, tmp_fi)
-           if (isinversed) then
-                        call gr_dyn_fi(1, nbp_lon+1, nbp_lat, klon_glo, &
-     & tmp_dyn_invers_glo, tmp_fi_glo)
-!              call gr_dyn_fi(1, iip1, jjp1, klon, tmp_dyn_invers, tmp_fi)
-!              call gr_dyn_fi_p(1, iip1, jjp1, klon, tmp_dyn_invers, tmp_fi)
-           else      
-                        call gr_dyn_fi(1, nbp_lon+1, nbp_lat, klon_glo, &
-     &   tmp_dyn_glo, tmp_fi_glo)
-!              call gr_dyn_fi(1, iip1, jjp1, klon, tmp_dyn, tmp_fi)
-!              call gr_dyn_fi_p(1, iip1, jjp1, klon, tmp_dyn, tmp_fi)
-           endif
-!JE20140526>>
-!      call dump2d(iim,jjm-1,tmp_fi(2),'tmp_fi   ')
-!
-          DO j=1,klon_glo
-
-                surfa_glo(j,i)=tmp_fi_glo(j)
-
-          ENDDO ! Fin de recopie du tableau
-!
-       ENDDO ! Fin boucle 1 a 5
-       print*,'Passage Grille Dyn -> Phys'
-
-
-      ENDIF !mpi 
-!$OMP END MASTER
-!$OMP BARRIER
-      call scatter(surfa_glo,surfa)
-
-
-       return
-       end subroutine read_surface
Index: /LMDZ6/trunk/libf/phylmd/Dust/read_surface.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/Dust/read_surface.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/Dust/read_surface.f90	(revision 5268)
@@ -0,0 +1,156 @@
+       subroutine read_surface(name,surfa)
+
+     
+! common
+! ------
+       USE ioipsl
+!       USE comgeomphy
+       USE dimphy
+       USE mod_grid_phy_lmdz
+       USE mod_phys_lmdz_para
+       USE iophy
+       USE netcdf, ONLY: nf90_get_var
+       IMPLICIT NONE
+
+       INCLUDE "netcdf.inc"
+       INCLUDE "dimensions.h"
+       INCLUDE "paramet.h"
+
+       character*10 name
+       character*10 varname
+!
+       real tmp_dyn(iip1,jjp1)
+       real tmp_dyn_glo(nbp_lon+1,nbp_lat)
+!       real tmp_dyn_glo(nbp_lon,nbp_lat)
+       REAL tmp_dyn_invers(iip1,jjp1)
+       real tmp_dyn_invers_glo(nbp_lon+1,nbp_lat)
+!       real tmp_dyn_invers_glo(nbp_lon,nbp_lat)
+       real tmp_fi(klon)
+       real tmp_fi_glo(klon_glo)
+       real surfa(klon,5)
+       real surfa_glo(klon_glo,5)
+!
+       integer ncid
+       integer varid
+       real rcode
+       integer start(2),count(2),status
+       integer i,j,l,ig
+       character*1 str1
+
+!JE20140526<<
+      character*4 ::  latstr,aux4s
+      logical :: outcycle, isinversed
+      real, dimension(jjp1) :: lats
+      real, dimension(nbp_lat) :: lats_glo
+      real :: rcode2
+      integer, dimension(1) :: startj,endj
+!JE20140526>>
+!$OMP MASTER
+       IF (is_mpi_root .AND. is_omp_root) THEN
+
+       print*,'Lecture du fichier donnees_lisa.nc' 
+       ncid=NCOPN('donnees_lisa.nc',NCNOWRIT,rcode)
+
+!JE20140526<<: check if are inversed or not the latitude grid in donnes_lisa
+      outcycle=.false.
+      latstr='null'
+      isinversed=.false.
+      do i=1,5
+       if (i==1) aux4s='latu'
+       if (i==2) aux4s='LATU'
+       if (i==3) aux4s='LatU'
+       if (i==4) aux4s='Latu'
+       if (i==5) aux4s='latU'
+       status = NF_INQ_VARID (ncid, aux4s, rcode)
+!       print *,'stat,i',status,i,outcycle,aux4s
+!       print *,'ifclause',status.NE. NF_NOERR ,outcycle == .false.
+       IF ((.not.(status.NE. NF_NOERR) ).and.( .not. outcycle )) THEN
+         outcycle=.true.
+         latstr=aux4s
+       ENDIF
+      enddo ! check if it inversed lat
+      startj(1)=1
+!      endj(1)=jjp1
+      endj(1)=nbp_lat
+      varid=NCVID(ncid,latstr,rcode)
+
+          status = nf90_get_var(ncid, varid, lats_glo, startj, endj)
+!      print *,latstr,varid,status,jjp1,rcode
+!      IF (status .NE. NF_NOERR) print*,'NOOOOOOO'
+!      print *,lats
+!stop
+
+! check if netcdf is latitude inversed or not. 
+      if (lats_glo(1)<lats_glo(2)) isinversed=.true.
+! JE20140526>>
+
+
+       DO i=1,5
+          write(str1,'(i1)') i
+          varname=trim(name)//str1
+       print*,'lecture variable:',varname
+          varid=NCVID(ncid,trim(varname),rcode)
+!          varid=NCVID(ncid,varname,rcode)
+
+!  dimensions pour les champs scalaires et le vent zonal
+!  -----------------------------------------------------
+
+          start(1)=1
+          start(2)=1      
+          count(1)=nbp_lon+1
+!          count(1)=iip1
+          count(2)=nbp_lat
+!          count(2)=jjp1
+
+! mise a zero des tableaux 
+! ------------------------
+          tmp_dyn(:,:)=0.0
+          tmp_fi(:)=0.0
+! Lecture
+! -----------------------
+          status = nf90_get_var(ncid, varid, tmp_dyn_glo, start, count)
+
+!      call dump2d(iip1,jjp1,tmp_dyn,'tmp_dyn   ')
+       DO j=1, nbp_lat
+          DO ig=1, nbp_lon+1
+             tmp_dyn_invers_glo(ig,j)=tmp_dyn_glo(ig,nbp_lat-j+1)
+          ENDDO
+       ENDDO
+
+       
+!JE20140522!          call gr_dyn_fi_p(1, iip1, jjp1, klon, tmp_dyn_invers, tmp_fi)
+
+!JE20140526<<
+!              call gr_dyn_fi(1, iip1, jjp1, klon, tmp_dyn_invers, tmp_fi)
+           if (isinversed) then
+                        call gr_dyn_fi(1, nbp_lon+1, nbp_lat, klon_glo, &
+     & tmp_dyn_invers_glo, tmp_fi_glo)
+!              call gr_dyn_fi(1, iip1, jjp1, klon, tmp_dyn_invers, tmp_fi)
+!              call gr_dyn_fi_p(1, iip1, jjp1, klon, tmp_dyn_invers, tmp_fi)
+           else      
+                        call gr_dyn_fi(1, nbp_lon+1, nbp_lat, klon_glo, &
+     &   tmp_dyn_glo, tmp_fi_glo)
+!              call gr_dyn_fi(1, iip1, jjp1, klon, tmp_dyn, tmp_fi)
+!              call gr_dyn_fi_p(1, iip1, jjp1, klon, tmp_dyn, tmp_fi)
+           endif
+!JE20140526>>
+!      call dump2d(iim,jjm-1,tmp_fi(2),'tmp_fi   ')
+!
+          DO j=1,klon_glo
+
+                surfa_glo(j,i)=tmp_fi_glo(j)
+
+          ENDDO ! Fin de recopie du tableau
+!
+       ENDDO ! Fin boucle 1 a 5
+       print*,'Passage Grille Dyn -> Phys'
+
+
+      ENDIF !mpi 
+!$OMP END MASTER
+!$OMP BARRIER
+      call scatter(surfa_glo,surfa)
+
+
+       return
+       end subroutine read_surface
Index: DZ6/trunk/libf/phylmd/Dust/read_vent.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/Dust/read_vent.F90	(revision 5267)
+++ 	(revision )
@@ -1,136 +1,0 @@
-SUBROUTINE read_vent(debutphy, step, nbjour, u10m_ec, v10m_ec)
-  USE dimphy
-  USE mod_grid_phy_lmdz
-  USE mod_phys_lmdz_para
-  USE netcdf, ONLY: nf90_get_var
-   ! USE write_field_phy
-  IMPLICIT NONE
-  INCLUDE "dimensions.h"
-    ! INCLUDE "dimphy.h"
-  INCLUDE "paramet.h"
-  INCLUDE "netcdf.inc"
-  !
-  INTEGER :: step, nbjour
-  LOGICAL :: debutphy
-  real :: u10m_ec(klon), v10m_ec(klon)
-  real :: u10m_ec_glo(klon_glo), v10m_ec_glo(klon_glo)
-  !
-  !  real u10m_nc(iip1,jjp1) !, v10m_nc(iip1,jjm) ! dim 97x72
-  !  real v10m_nc(iip1,jjp1)  ! dim 97x73
-  real :: u10m_nc_glo(nbp_lon+1,nbp_lat) !, v10m_nc(iip1,jjm) ! dim 97x72
-  real :: v10m_nc_glo(nbp_lon+1,nbp_lat)  ! dim 97x73
-  real :: rcode
-  integer :: ncidu1, varidu1, ncidv1, varidv1
-  save ncidu1, varidu1, ncidv1, varidv1
-!$OMP THREADPRIVATE(ncidu1, varidu1, ncidv1, varidv1)
-  integer :: start(4),count(4), status
-  integer :: i, j, ig
-
-
-  !
-!$OMP MASTER
-  IF (is_mpi_root .AND. is_omp_root) THEN
-  if (debutphy) then
-  !
-     ncidu1=NCOPN('u10m.nc',NCNOWRIT,rcode)
-     varidu1=NCVID(ncidu1,'U10M',rcode)
-     ncidv1=NCOPN('v10m.nc',NCNOWRIT,rcode)
-     varidv1=NCVID(ncidv1,'V10M',rcode)
-  !
-  endif
-  !
-  start(1)=1
-  start(2)=1
-  start(4)=0
-
-   ! count(1)=iip1
-  count(1)=nbp_lon+1
-   ! count(2)=jjp1
-  count(2)=nbp_lat
-  count(3)=1
-  count(4)=0
-  !
-  start(3)=step
-  !
-  status = nf90_get_var(ncidu1, varidu1, u10m_nc_glo, start, count)
-
-    ! print *,status
-  !
-  status = nf90_get_var(ncidv1, varidv1, v10m_nc_glo, start, count)
-
-  !
-
-  !  print *,'beforebidcor u10m_nc', u10m_nc(1,jjp1)
-  !  print *,'beforebidcor v10m_nc', v10m_nc(1,jjp1)
-
-  !   print *,status
-  !  call correctbid(iim,jjp1,u10m_nc)
-  !  call correctbid(iim,jjp1,v10m_nc)
-  call correctbid(nbp_lon,nbp_lat,u10m_nc_glo)
-  call correctbid(nbp_lon,nbp_lat,v10m_nc_glo)
-
-   ! print *,'afterbidcor u10m_nc', u10m_nc(1,jjp1)
-   ! print *,'afterbidcor v10m_nc', v10m_nc(1,jjp1)
-  !
-  !--upside down + physical grid
-  !
-  !  u10m_ec(1)=u10m_nc(1,jjp1)
-  !  v10m_ec(1)=v10m_nc(1,jjp1)
-  u10m_ec_glo(1)=u10m_nc_glo(1,nbp_lat)
-  v10m_ec_glo(1)=v10m_nc_glo(1,nbp_lat)
-  ig=2
-   ! DO j=2,jjm
-   !    DO i = 1, iim
-  DO j=2,nbp_lat-1
-     DO i = 1, nbp_lon
-        ! u10m_ec(ig)=u10m_nc(i,jjp1+1-j)
-        ! v10m_ec(ig)=v10m_nc(i,jjp1+1-j)
-       u10m_ec_glo(ig)=u10m_nc_glo(i,nbp_lat+1-j)
-       v10m_ec_glo(ig)=v10m_nc_glo(i,nbp_lat+1-j)
-       ig=ig+1
-      ! print *,u10m_ec(ig) ,v10m_ec(ig)
-     ENDDO
-  ENDDO
-  u10m_ec_glo(ig)=u10m_nc_glo(1,1)
-  v10m_ec_glo(ig)=v10m_nc_glo(1,1)
-
-
-   ! end if master
-  ENDIF
-!$OMP END MASTER
-!$OMP BARRIER
-  CALL scatter(u10m_ec_glo,u10m_ec)
-  CALL scatter(v10m_ec_glo,v10m_ec)
-
-   ! print *,'JE  tamagno viento ig= ', ig
-   ! print *,'READ_VENT U = ',SUM(u10m_ec),MINVAL(u10m_ec),
-  ! .                                      MAXVAL(u10m_ec)
-  !  print *,'READ_VENT V = ',SUM(v10m_ec),MINVAL(v10m_ec),
-  ! .                                      MAXVAL(v10m_ec)
-  !   print *,'u v 1 ', u10m_ec(1),v10m_ec(1)
-  !   print *,'u v klon ', u10m_ec(klon),v10m_ec(klon)
-  RETURN
-END SUBROUTINE read_vent
-
-! added by JE from the nh SPLA, dyn3d/read_reanalyse.F which is not available any more
-subroutine correctbid(iim,nl,x)
-  integer :: iim,nl
-  real :: x(iim+1,nl)
-  integer :: i,l
-  real :: zz
-
-  do l=1,nl
-     do i=2,iim-1
-        if(abs(x(i,l)).gt.1.e10) then
-           zz=0.5*(x(i-1,l)+x(i+1,l))
-           ! print*,'correction ',i,l,x(i,l),zz
-           x(i,l)=zz
-        endif
-     enddo
-  enddo
-
-  return
-end subroutine correctbid
-
-
-
Index: /LMDZ6/trunk/libf/phylmd/Dust/read_vent.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/Dust/read_vent.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/Dust/read_vent.f90	(revision 5268)
@@ -0,0 +1,136 @@
+SUBROUTINE read_vent(debutphy, step, nbjour, u10m_ec, v10m_ec)
+  USE dimphy
+  USE mod_grid_phy_lmdz
+  USE mod_phys_lmdz_para
+  USE netcdf, ONLY: nf90_get_var
+   ! USE write_field_phy
+  IMPLICIT NONE
+  INCLUDE "dimensions.h"
+    ! INCLUDE "dimphy.h"
+  INCLUDE "paramet.h"
+  INCLUDE "netcdf.inc"
+  !
+  INTEGER :: step, nbjour
+  LOGICAL :: debutphy
+  real :: u10m_ec(klon), v10m_ec(klon)
+  real :: u10m_ec_glo(klon_glo), v10m_ec_glo(klon_glo)
+  !
+  !  real u10m_nc(iip1,jjp1) !, v10m_nc(iip1,jjm) ! dim 97x72
+  !  real v10m_nc(iip1,jjp1)  ! dim 97x73
+  real :: u10m_nc_glo(nbp_lon+1,nbp_lat) !, v10m_nc(iip1,jjm) ! dim 97x72
+  real :: v10m_nc_glo(nbp_lon+1,nbp_lat)  ! dim 97x73
+  real :: rcode
+  integer :: ncidu1, varidu1, ncidv1, varidv1
+  save ncidu1, varidu1, ncidv1, varidv1
+!$OMP THREADPRIVATE(ncidu1, varidu1, ncidv1, varidv1)
+  integer :: start(4),count(4), status
+  integer :: i, j, ig
+
+
+  !
+!$OMP MASTER
+  IF (is_mpi_root .AND. is_omp_root) THEN
+  if (debutphy) then
+  !
+     ncidu1=NCOPN('u10m.nc',NCNOWRIT,rcode)
+     varidu1=NCVID(ncidu1,'U10M',rcode)
+     ncidv1=NCOPN('v10m.nc',NCNOWRIT,rcode)
+     varidv1=NCVID(ncidv1,'V10M',rcode)
+  !
+  endif
+  !
+  start(1)=1
+  start(2)=1
+  start(4)=0
+
+   ! count(1)=iip1
+  count(1)=nbp_lon+1
+   ! count(2)=jjp1
+  count(2)=nbp_lat
+  count(3)=1
+  count(4)=0
+  !
+  start(3)=step
+  !
+  status = nf90_get_var(ncidu1, varidu1, u10m_nc_glo, start, count)
+
+    ! print *,status
+  !
+  status = nf90_get_var(ncidv1, varidv1, v10m_nc_glo, start, count)
+
+  !
+
+  !  print *,'beforebidcor u10m_nc', u10m_nc(1,jjp1)
+  !  print *,'beforebidcor v10m_nc', v10m_nc(1,jjp1)
+
+  !   print *,status
+  !  call correctbid(iim,jjp1,u10m_nc)
+  !  call correctbid(iim,jjp1,v10m_nc)
+  call correctbid(nbp_lon,nbp_lat,u10m_nc_glo)
+  call correctbid(nbp_lon,nbp_lat,v10m_nc_glo)
+
+   ! print *,'afterbidcor u10m_nc', u10m_nc(1,jjp1)
+   ! print *,'afterbidcor v10m_nc', v10m_nc(1,jjp1)
+  !
+  !--upside down + physical grid
+  !
+  !  u10m_ec(1)=u10m_nc(1,jjp1)
+  !  v10m_ec(1)=v10m_nc(1,jjp1)
+  u10m_ec_glo(1)=u10m_nc_glo(1,nbp_lat)
+  v10m_ec_glo(1)=v10m_nc_glo(1,nbp_lat)
+  ig=2
+   ! DO j=2,jjm
+   !    DO i = 1, iim
+  DO j=2,nbp_lat-1
+     DO i = 1, nbp_lon
+        ! u10m_ec(ig)=u10m_nc(i,jjp1+1-j)
+        ! v10m_ec(ig)=v10m_nc(i,jjp1+1-j)
+       u10m_ec_glo(ig)=u10m_nc_glo(i,nbp_lat+1-j)
+       v10m_ec_glo(ig)=v10m_nc_glo(i,nbp_lat+1-j)
+       ig=ig+1
+      ! print *,u10m_ec(ig) ,v10m_ec(ig)
+     ENDDO
+  ENDDO
+  u10m_ec_glo(ig)=u10m_nc_glo(1,1)
+  v10m_ec_glo(ig)=v10m_nc_glo(1,1)
+
+
+   ! end if master
+  ENDIF
+!$OMP END MASTER
+!$OMP BARRIER
+  CALL scatter(u10m_ec_glo,u10m_ec)
+  CALL scatter(v10m_ec_glo,v10m_ec)
+
+   ! print *,'JE  tamagno viento ig= ', ig
+   ! print *,'READ_VENT U = ',SUM(u10m_ec),MINVAL(u10m_ec),
+  ! .                                      MAXVAL(u10m_ec)
+  !  print *,'READ_VENT V = ',SUM(v10m_ec),MINVAL(v10m_ec),
+  ! .                                      MAXVAL(v10m_ec)
+  !   print *,'u v 1 ', u10m_ec(1),v10m_ec(1)
+  !   print *,'u v klon ', u10m_ec(klon),v10m_ec(klon)
+  RETURN
+END SUBROUTINE read_vent
+
+! added by JE from the nh SPLA, dyn3d/read_reanalyse.F which is not available any more
+subroutine correctbid(iim,nl,x)
+  integer :: iim,nl
+  real :: x(iim+1,nl)
+  integer :: i,l
+  real :: zz
+
+  do l=1,nl
+     do i=2,iim-1
+        if(abs(x(i,l)).gt.1.e10) then
+           zz=0.5*(x(i-1,l)+x(i+1,l))
+           ! print*,'correction ',i,l,x(i,l),zz
+           x(i,l)=zz
+        endif
+     enddo
+  enddo
+
+  return
+end subroutine correctbid
+
+
+
Index: DZ6/trunk/libf/phylmd/Dust/satellite_out_spla.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/Dust/satellite_out_spla.F90	(revision 5267)
+++ 	(revision )
@@ -1,192 +1,0 @@
-
-SUBROUTINE satellite_out_spla(jD_cur,jH_cur,pdtphys,rlat,rlon, &
-                              masque_aqua, masque_terra )
-
-  USE dimphy
-  USE IOIPSL
-  USE write_field_phy
-
-  IMPLICIT NONE
-
-  REAL :: pdtphys, jD_cur,jH_cur, hour
-  INTEGER :: year_cur, mth_cur, day_cur
-  INTEGER :: masque_polder(klon)  ! masque polder
-  INTEGER :: masque_aqua(klon)  ! masque polder
-  INTEGER :: masque_terra(klon)  ! masque polder
-  INTEGER :: i
-  REAL :: overpassaqua, overpassterra
-  REAL,dimension(klon) :: rlat,rlon
-
-
-  masque_polder(:) = 0.
-
-  CALL ju2ymds(jD_cur+jH_cur, year_cur, mth_cur, day_cur, hour)
-!  print*,'JDcur=',jD_cur,'JHcur=',jH_cur,'year_cur' ,year_cur,'mth_cur' ,mth_cur, 'day_cur',day_cur,'hour' ,hour
-
-!  IF ( (year_cur*100.+mth_cur .GE. 199611 ) .AND. (year_cur*100.+mth_cur .LE. 199706)) THEN 
-!          CALL swathpolder(year_cur,mth_cur,day_cur,hour/86400., &
-!            pdtphys,rlon,rlat,masque_polder)
-!  ENDIF
-!
-!  DO i=1,klon
-!    IF ( masque_polder(i) .EQ. 1 ) THEN
-!        print *,'polder output point, lon:', rlon(i),', lat: ',rlat(i)
-!    ENDIF
-!  ENDDO
-!  CALL writefield_phy("masque_polder",float(masque_polder),1)
-
-! Aqua
-  masque_aqua(:) = 0.
-  overpassaqua=48600.  ! 13.30 p.m. local time
-  CALL swathpolarsat(year_cur,mth_cur,day_cur,hour, &
-            pdtphys,rlon,rlat,overpassaqua,masque_aqua)
-
-!  DO i=1,klon
-!    IF ( masque_aqua(i) .EQ. 1 ) THEN
-!        print *,'aqua output point, lon:', rlon(i),', lat: ',rlat(i)
-!    ENDIF
-!  ENDDO
-!  CALL writefield_phy("masque_aqua",float(masque_aqua),1)
-
-  masque_terra(:) = 0.
-  overpassterra=37800.  ! 10.30 a.m. local time
-  CALL swathpolarsat(year_cur,mth_cur,day_cur,hour, &
-            pdtphys,rlon,rlat,overpassterra,masque_terra)
-
-!  DO i=1,klon
-!    IF ( masque_terra(i) .EQ. 1 ) THEN
-!        print *,'terra output point, lon:', rlon(i),', lat: ',rlat(i)
-!    ENDIF
-!  ENDDO
-!  CALL writefield_phy("masque_terra",float(masque_terra),1)
-
-  RETURN
-END SUBROUTINE satellite_out_spla
-
-
-
-
-SUBROUTINE swathpolarsat(annee,mois,jour,heure,pdtphys, &
-     rlon,rlat,overpasstime,masque)
-  ! Adaptation from the simple satellite simulator of AeroCom working group Indirect
-  ! forcing ( Johannes Quaas, MPI for Meteorology, Hamburg )
-  ! http://wiki.esipfed.org/index.php/Indirect_forcing
-  
-  USE dimphy
-  IMPLICIT NONE
-
-  INTEGER :: annee, mois, jour, i
-  REAL :: heure                      !--heure en jour
-  REAL :: pdtphys                    !--pas de temps en seconde
-  REAL :: rlon(1:klon), rlat(1:klon) !--longitude et latitude
-  INTEGER :: masque(1:klon)
-  REAL :: localtime(1:klon)
-  REAL :: overpasstime, utctime
-
-  masque(:) = 0
-  utctime=heure
-  DO i=1,klon
-        localtime(i) = utctime + 240. * rlon(i) ! for each degree of longitude east,4 min earlier local time
-!        IF ( localtime(i) > 86400. ) THEN ! this is still the previous day
-!                localtime(i) = localtime(i) - 86400.
-!        ENDIF
-        ! Select 10.30 a.m. ± dt/2
-!       IF ( ABS( localtime(i) - overpasstime ) <= pdtphys/2. ) THEN 
-        IF ( ABS(MOD(localtime(i)+86400.*100,86400.) - overpasstime ) <= pdtphys/2. ) THEN 
-                masque(i) = 1
-        ENDIF
-   ENDDO
-
-
-END SUBROUTINE swathpolarsat
-
-SUBROUTINE swathpolder(annee,mois,jour,heure,pdtphys, &
-     rlon,rlat,masque)
-!  Adapted from INCA
-
-!  USE inca_dim
-  USE dimphy
-  IMPLICIT NONE
-
-  !--Auteurs : Francois-Marie Breon + Olivier Boucher
-
-  !-- adapted to be used in INCA aerosol module Michael Schulz
-
-  ! not needed?
-
-  INTEGER :: annee, mois, jour 
-  REAL :: heure                      !--heure en jour
-  REAL :: pdtphys                    !--pas de temps en seconde
-  REAL :: rlon(1:klon), rlat(1:klon) !--longitude et latitude
-  INTEGER :: masque(1:klon)
-
-  REAL :: J0              !--origine des temps pour les orbites ADEOS 
-  PARAMETER (J0=183.91267)
-  REAL :: secinday
-  PARAMETER (secinday=86400.)
-  REAL :: duree_orb       !--Duree d une orbite ADEOS en jour 
-  PARAMETER (duree_orb=6055.3715/secinday)
-  REAL :: deltalon        !--Decalage en longitude entre 2 orbites successives
-  PARAMETER (deltalon=41./585.*360.)
-  REAL :: demi_larg_eq    !--demi-largeur d'une orbite a l equateur
-  PARAMETER (demi_larg_eq=11.)
-  REAL :: incli, inclideg
-  PARAMETER (inclideg=98.59)
-  REAL :: RADEG, DTOR, RPI
-  REAL :: demi_periode
-  INTEGER :: jacum(1:12)
-  DATA jacum/0,31,59,90,120,151,181,212,243,273,304,334/
-  INTEGER :: an, orb, i, j
-  REAL :: timepolder, lon0, posnorm, lim_nord, lim_sud
-  REAL :: tempo, lon_cen, demi_larg
-  REAL :: lat_debut, lat_fin, lon_west, lon_east
-  REAL :: zlon            !--rlon mais remis entre 0 et 360
-  REAL :: deltat          !--plage de temps a considerer en jours  
-
-
-  RPI = 4 * atan (1.0)
-  deltat=pdtphys/secinday
-  demi_periode=deltat/2./duree_orb
-  RADEG=180./RPI
-  DTOR=RPI/180.
-  incli=inclideg*DTOR
-
-  an = MOD(annee, 100) 
-  timepolder=FLOAT((an-96)*365+jacum(mois)+jour)+heure
-  orb=INT((timepolder-J0)/duree_orb+0.5) 
-  lon0=360.-MOD(168.02+FLOAT(orb)*deltalon,360.)
-  posnorm=(timepolder-j0)/duree_orb-FLOAT(orb)
-  j=jacum(mois)+jour
-  lim_nord=60.5 + 25.*(1.-COS((FLOAT(J)+10.)/365.*2.*RPI))
-  lim_sud=-53.0 - 20.*(1.+COS(FLOAT(J)/365.*2*RPI))
-  !--lat de debut
-  lat_debut=MIN(MIN(90.,(-posnorm+demi_periode)*360.),lim_nord) 
-  !--lat de fin
-  lat_fin  =MAX(MAX(-90.,(-posnorm-demi_periode)*360.),lim_sud) 
-
-  DO i=1, klon
-     masque(i)=0
-     tempo=ASIN( MAX(-1.,MIN(1., -SIN(rlat(i)*DTOR)/SIN(incli))))
-     lon_cen=(ATAN(TAN(tempo)*COS(incli))-duree_orb*tempo)*RADEG
-     demi_larg=demi_larg_eq/COS(rlat(i)*DTOR)
-     IF (ABS(SIN(rlat(i)*DTOR)/SIN(incli)).GE.1.0) demi_larg=200.0
-     IF (rlat(i).GE.lat_fin.AND.rlat(i).LE.lat_debut) THEN 
-        IF (demi_larg.GE. 180.) THEN 
-           masque(i)=1
-        ELSE  
-           lon_west = MOD(lon0+lon_cen-demi_larg+720., 360.)
-           lon_east = MOD(lon0+lon_cen+demi_larg,      360.)
-           zlon     = MOD(rlon(i)+360.,                360.)
-           IF (lon_west.LE.lon_east) THEN 
-              IF (zlon.GE.lon_west.AND.zlon.LE.lon_east) masque(i)=1
-           ELSE               
-              IF (zlon.GE.lon_west.OR.zlon.LE.lon_east) masque(i)=1
-           ENDIF
-        ENDIF
-     ENDIF
-  ENDDO
-
-  RETURN
-END SUBROUTINE swathpolder
-
-
Index: /LMDZ6/trunk/libf/phylmd/Dust/satellite_out_spla.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/Dust/satellite_out_spla.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/Dust/satellite_out_spla.f90	(revision 5268)
@@ -0,0 +1,192 @@
+
+SUBROUTINE satellite_out_spla(jD_cur,jH_cur,pdtphys,rlat,rlon, &
+                              masque_aqua, masque_terra )
+
+  USE dimphy
+  USE IOIPSL
+  USE write_field_phy
+
+  IMPLICIT NONE
+
+  REAL :: pdtphys, jD_cur,jH_cur, hour
+  INTEGER :: year_cur, mth_cur, day_cur
+  INTEGER :: masque_polder(klon)  ! masque polder
+  INTEGER :: masque_aqua(klon)  ! masque polder
+  INTEGER :: masque_terra(klon)  ! masque polder
+  INTEGER :: i
+  REAL :: overpassaqua, overpassterra
+  REAL,dimension(klon) :: rlat,rlon
+
+
+  masque_polder(:) = 0.
+
+  CALL ju2ymds(jD_cur+jH_cur, year_cur, mth_cur, day_cur, hour)
+!  print*,'JDcur=',jD_cur,'JHcur=',jH_cur,'year_cur' ,year_cur,'mth_cur' ,mth_cur, 'day_cur',day_cur,'hour' ,hour
+
+!  IF ( (year_cur*100.+mth_cur .GE. 199611 ) .AND. (year_cur*100.+mth_cur .LE. 199706)) THEN 
+!          CALL swathpolder(year_cur,mth_cur,day_cur,hour/86400., &
+!            pdtphys,rlon,rlat,masque_polder)
+!  ENDIF
+!
+!  DO i=1,klon
+!    IF ( masque_polder(i) .EQ. 1 ) THEN
+!        print *,'polder output point, lon:', rlon(i),', lat: ',rlat(i)
+!    ENDIF
+!  ENDDO
+!  CALL writefield_phy("masque_polder",float(masque_polder),1)
+
+! Aqua
+  masque_aqua(:) = 0.
+  overpassaqua=48600.  ! 13.30 p.m. local time
+  CALL swathpolarsat(year_cur,mth_cur,day_cur,hour, &
+            pdtphys,rlon,rlat,overpassaqua,masque_aqua)
+
+!  DO i=1,klon
+!    IF ( masque_aqua(i) .EQ. 1 ) THEN
+!        print *,'aqua output point, lon:', rlon(i),', lat: ',rlat(i)
+!    ENDIF
+!  ENDDO
+!  CALL writefield_phy("masque_aqua",float(masque_aqua),1)
+
+  masque_terra(:) = 0.
+  overpassterra=37800.  ! 10.30 a.m. local time
+  CALL swathpolarsat(year_cur,mth_cur,day_cur,hour, &
+            pdtphys,rlon,rlat,overpassterra,masque_terra)
+
+!  DO i=1,klon
+!    IF ( masque_terra(i) .EQ. 1 ) THEN
+!        print *,'terra output point, lon:', rlon(i),', lat: ',rlat(i)
+!    ENDIF
+!  ENDDO
+!  CALL writefield_phy("masque_terra",float(masque_terra),1)
+
+  RETURN
+END SUBROUTINE satellite_out_spla
+
+
+
+
+SUBROUTINE swathpolarsat(annee,mois,jour,heure,pdtphys, &
+     rlon,rlat,overpasstime,masque)
+  ! Adaptation from the simple satellite simulator of AeroCom working group Indirect
+  ! forcing ( Johannes Quaas, MPI for Meteorology, Hamburg )
+  ! http://wiki.esipfed.org/index.php/Indirect_forcing
+  
+  USE dimphy
+  IMPLICIT NONE
+
+  INTEGER :: annee, mois, jour, i
+  REAL :: heure                      !--heure en jour
+  REAL :: pdtphys                    !--pas de temps en seconde
+  REAL :: rlon(1:klon), rlat(1:klon) !--longitude et latitude
+  INTEGER :: masque(1:klon)
+  REAL :: localtime(1:klon)
+  REAL :: overpasstime, utctime
+
+  masque(:) = 0
+  utctime=heure
+  DO i=1,klon
+        localtime(i) = utctime + 240. * rlon(i) ! for each degree of longitude east,4 min earlier local time
+!        IF ( localtime(i) > 86400. ) THEN ! this is still the previous day
+!                localtime(i) = localtime(i) - 86400.
+!        ENDIF
+        ! Select 10.30 a.m. ± dt/2
+!       IF ( ABS( localtime(i) - overpasstime ) <= pdtphys/2. ) THEN 
+        IF ( ABS(MOD(localtime(i)+86400.*100,86400.) - overpasstime ) <= pdtphys/2. ) THEN 
+                masque(i) = 1
+        ENDIF
+   ENDDO
+
+
+END SUBROUTINE swathpolarsat
+
+SUBROUTINE swathpolder(annee,mois,jour,heure,pdtphys, &
+     rlon,rlat,masque)
+!  Adapted from INCA
+
+!  USE inca_dim
+  USE dimphy
+  IMPLICIT NONE
+
+  !--Auteurs : Francois-Marie Breon + Olivier Boucher
+
+  !-- adapted to be used in INCA aerosol module Michael Schulz
+
+  ! not needed?
+
+  INTEGER :: annee, mois, jour 
+  REAL :: heure                      !--heure en jour
+  REAL :: pdtphys                    !--pas de temps en seconde
+  REAL :: rlon(1:klon), rlat(1:klon) !--longitude et latitude
+  INTEGER :: masque(1:klon)
+
+  REAL :: J0              !--origine des temps pour les orbites ADEOS 
+  PARAMETER (J0=183.91267)
+  REAL :: secinday
+  PARAMETER (secinday=86400.)
+  REAL :: duree_orb       !--Duree d une orbite ADEOS en jour 
+  PARAMETER (duree_orb=6055.3715/secinday)
+  REAL :: deltalon        !--Decalage en longitude entre 2 orbites successives
+  PARAMETER (deltalon=41./585.*360.)
+  REAL :: demi_larg_eq    !--demi-largeur d'une orbite a l equateur
+  PARAMETER (demi_larg_eq=11.)
+  REAL :: incli, inclideg
+  PARAMETER (inclideg=98.59)
+  REAL :: RADEG, DTOR, RPI
+  REAL :: demi_periode
+  INTEGER :: jacum(1:12)
+  DATA jacum/0,31,59,90,120,151,181,212,243,273,304,334/
+  INTEGER :: an, orb, i, j
+  REAL :: timepolder, lon0, posnorm, lim_nord, lim_sud
+  REAL :: tempo, lon_cen, demi_larg
+  REAL :: lat_debut, lat_fin, lon_west, lon_east
+  REAL :: zlon            !--rlon mais remis entre 0 et 360
+  REAL :: deltat          !--plage de temps a considerer en jours  
+
+
+  RPI = 4 * atan (1.0)
+  deltat=pdtphys/secinday
+  demi_periode=deltat/2./duree_orb
+  RADEG=180./RPI
+  DTOR=RPI/180.
+  incli=inclideg*DTOR
+
+  an = MOD(annee, 100) 
+  timepolder=FLOAT((an-96)*365+jacum(mois)+jour)+heure
+  orb=INT((timepolder-J0)/duree_orb+0.5) 
+  lon0=360.-MOD(168.02+FLOAT(orb)*deltalon,360.)
+  posnorm=(timepolder-j0)/duree_orb-FLOAT(orb)
+  j=jacum(mois)+jour
+  lim_nord=60.5 + 25.*(1.-COS((FLOAT(J)+10.)/365.*2.*RPI))
+  lim_sud=-53.0 - 20.*(1.+COS(FLOAT(J)/365.*2*RPI))
+  !--lat de debut
+  lat_debut=MIN(MIN(90.,(-posnorm+demi_periode)*360.),lim_nord) 
+  !--lat de fin
+  lat_fin  =MAX(MAX(-90.,(-posnorm-demi_periode)*360.),lim_sud) 
+
+  DO i=1, klon
+     masque(i)=0
+     tempo=ASIN( MAX(-1.,MIN(1., -SIN(rlat(i)*DTOR)/SIN(incli))))
+     lon_cen=(ATAN(TAN(tempo)*COS(incli))-duree_orb*tempo)*RADEG
+     demi_larg=demi_larg_eq/COS(rlat(i)*DTOR)
+     IF (ABS(SIN(rlat(i)*DTOR)/SIN(incli)).GE.1.0) demi_larg=200.0
+     IF (rlat(i).GE.lat_fin.AND.rlat(i).LE.lat_debut) THEN 
+        IF (demi_larg.GE. 180.) THEN 
+           masque(i)=1
+        ELSE  
+           lon_west = MOD(lon0+lon_cen-demi_larg+720., 360.)
+           lon_east = MOD(lon0+lon_cen+demi_larg,      360.)
+           zlon     = MOD(rlon(i)+360.,                360.)
+           IF (lon_west.LE.lon_east) THEN 
+              IF (zlon.GE.lon_west.AND.zlon.LE.lon_east) masque(i)=1
+           ELSE               
+              IF (zlon.GE.lon_west.OR.zlon.LE.lon_east) masque(i)=1
+           ENDIF
+        ENDIF
+     ENDIF
+  ENDDO
+
+  RETURN
+END SUBROUTINE swathpolder
+
+
Index: DZ6/trunk/libf/phylmd/Dust/splaeropt_5wv_rrtm.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/Dust/splaeropt_5wv_rrtm.F90	(revision 5267)
+++ 	(revision )
@@ -1,169 +1,0 @@
-!
-! $Id: splaeropt_5wv_rrtm.F90 2644 2016-10-02 16:55:08Z oboucher $
-!
-
-SUBROUTINE SPLAEROPT_5WV_RRTM(  &
-   zdm, zdh, tr_seri, RHcl,     &
-   tausum, tau )
-
-  USE DIMPHY
-  USE aero_mod
-  USE infotrac_phy, ONLY: nqtot, nbtr, tracers
-  USE phys_local_var_mod, ONLY: od550aer,od865aer,ec550aer,od550lt1aer
-  !
-  ! Olivier Boucher Jan 2017
-  ! Based on Mie routines on ciclad CMIP6
-  !
-  IMPLICIT NONE
-  !
-  ! Input arguments:
-  !
-  REAL, DIMENSION(klon,klev), INTENT(IN)   :: zdh      !--m
-  REAL, DIMENSION(klon,klev), INTENT(IN)   :: zdm      !--kg/m2
-  REAL, DIMENSION(klon,klev), INTENT(IN)   :: RHcl     ! humidite relative ciel clair
-  REAL, DIMENSION(klon,klev,nbtr), INTENT(IN) :: tr_seri
-  !
-  ! Output arguments:
-  !
-  REAL, DIMENSION(klon,nwave,naero_tot), INTENT(OUT)      :: tausum
-  REAL, DIMENSION(klon,klev,nwave,naero_tot), INTENT(OUT) :: tau
-  !
-  ! Local
-  !
-  INTEGER, PARAMETER :: las = nwave_sw
-  LOGICAL :: soluble
-  
-  INTEGER :: i, k, m, iq, itr, irh, aerindex
-  INTEGER :: spsol, spinsol, la
-  INTEGER :: RH_num(klon,klev)
-  INTEGER, PARAMETER :: la443 = 1
-  INTEGER, PARAMETER :: la550 = 2
-  INTEGER, PARAMETER :: la670 = 3
-  INTEGER, PARAMETER :: la765 = 4
-  INTEGER, PARAMETER :: la865 = 5
-  INTEGER, PARAMETER :: nbre_RH=12
-  INTEGER, PARAMETER :: naero_soluble=2
-  INTEGER, PARAMETER :: naero_insoluble=2
-  INTEGER, PARAMETER :: naero=naero_soluble+naero_insoluble
-
-  REAL, PARAMETER :: RH_tab(nbre_RH)=(/0.,10.,20.,30.,40.,50.,60.,70.,80.,85.,90.,95./)
-  REAL, PARAMETER :: RH_MAX=95.
-  REAL :: delta(klon,klev), rh(klon,klev)
-  REAL :: tau_ae5wv_int   ! Intermediate computation of epaisseur optique aerosol
-  REAL :: zrho
-  CHARACTER*20 modname
-  
-  ! Soluble components 1-accumulation mode soluble; 2- seasalt coarse
-  REAL :: alpha_aers_5wv(nbre_RH,las,naero_soluble)   ! Ext. coeff. ** m2/g 
-  ! Insoluble components 1- Dust: 2- BC; 3- POM
-  REAL :: alpha_aeri_5wv(las,naero_insoluble)         ! Ext. coeff. ** m2/g 
-  !
-  ! Proprietes optiques
-  !
-  REAL :: fact_RH(nbre_RH)
-
-! From here on we look at the optical parameters at 5 wavelengths:  
-! 443nm, 550, 670, 765 and 865 nm 
-!                                   le 12 AVRIL 2006 
-!  
- DATA alpha_aers_5wv/ & 
-                           ! accumulation mode (sulfate+2% bc) soluble 
-       4.632, 4.632, 4.632, 4.632, 6.206, 6.827, 7.616, 8.716,10.514,12.025,14.688,21.539, &
-       3.981, 3.981, 3.981, 3.981, 5.346, 5.923, 6.662, 7.704, 9.437,10.914,13.562,20.591, &
-       3.265, 3.265, 3.265, 3.265, 4.400, 4.909, 5.565, 6.500, 8.081, 9.449,11.943,18.791, &
-       2.761, 2.761, 2.761, 2.761, 3.731, 4.182, 4.767, 5.606, 7.041, 8.294,10.610,17.118, &
-       2.307, 2.307, 2.307, 2.307, 3.129, 3.522, 4.034, 4.774, 6.052, 7.180, 9.286,15.340, &
-
-                           ! seasalt seasalt Coarse Soluble (CS)      
-       0.576, 0.690, 0.738, 0.789, 0.855, 0.935, 1.046, 1.212, 1.512, 1.785, 2.258, 3.449, &
-       0.595, 0.713, 0.763, 0.814, 0.880, 0.963, 1.079, 1.248, 1.550, 1.826, 2.306, 3.507, &
-       0.617, 0.738, 0.789, 0.842, 0.911, 0.996, 1.113, 1.286, 1.592, 1.871, 2.369, 3.562, &
-       0.632, 0.755, 0.808, 0.862, 0.931, 1.018, 1.140, 1.316, 1.626, 1.909, 2.409, 3.622, &
-       0.645, 0.771, 0.825, 0.880, 0.951, 1.039, 1.164, 1.344, 1.661, 1.948, 2.455, 3.682  /
-
-  DATA alpha_aeri_5wv/ &
-                                 ! coarse dust insoluble 
-       0.605, 0.611, 0.661, 0.714, 0.760, &
-                                 ! super coarse insoluble 
-       0.153, 0.156, 0.158, 0.157, 0.161 /
-  ! 
-  ! Initialisations
-  tausum(:,:,:)=0.
-  tau(:,:,:,:)=0.
-
-  modname='splaeropt_5wv_rrtm'
-
-  IF (naero.GT.naero_tot) THEN 
-    CALL abort_physic(modname,'Too many aerosol types',1)
-  ENDIF
-
-  DO irh=1,nbre_RH-1
-    fact_RH(irh)=1./(RH_tab(irh+1)-RH_tab(irh))
-  ENDDO
-   
-  DO k=1, klev
-    DO i=1, klon
-      rh(i,k)=MIN(RHcl(i,k)*100.,RH_MAX)
-      RH_num(i,k) = INT( rh(i,k)/10. + 1.)
-      IF (rh(i,k).GT.85.) RH_num(i,k)=10
-      IF (rh(i,k).GT.90.) RH_num(i,k)=11
-      delta(i,k)=(rh(i,k)-RH_tab(RH_num(i,k)))*fact_RH(RH_num(i,k))
-    ENDDO
-  ENDDO
-
-  itr = 0
-  DO iq = 1, nqtot
-    IF(.NOT.tracers(iq)%isInPhysics) CYCLE
-    itr = itr+1
-    SELECT CASE(tracers(iq)%name)
-      CASE('PREC'); CYCLE                                  !--precursor
-      CASE('FINE'); soluble=.TRUE.;  spsol=1; aerindex=1   !--fine mode accumulation mode
-      CASE('COSS'); soluble=.TRUE.;  spsol=2; aerindex=2   !--coarse mode sea salt
-      CASE('CODU'); soluble=.FALSE.; spinsol=1; aerindex=3   !--coarse mode dust
-      CASE('SCDU'); soluble=.FALSE.; spinsol=2; aerindex=4   !--super coarse mode dust
-      CASE DEFAULT; CALL abort_physic(modname,'I cannot do aerosol optics for '//tracers(iq)%name,1)
-    END SELECT
-
-    DO la=1,las
-
-      !--only 550 and 865 nm are used
-      IF (la.NE.la550.AND.la.NE.la865) CYCLE
-
-      IF (soluble) THEN  !--soluble aerosol with RH dependence
-
-        DO k=1, klev
-          DO i=1, klon
-            tau_ae5wv_int = alpha_aers_5wv(RH_num(i,k),la,spsol)+DELTA(i,k)* &
-                           (alpha_aers_5wv(RH_num(i,k)+1,la,spsol) - & 
-                            alpha_aers_5wv(RH_num(i,k),la,spsol))
-            tau(i,k,la,aerindex) = tr_seri(i,k,itr)*zdm(i,k)*tau_ae5wv_int
-            tausum(i,la,aerindex)=tausum(i,la,aerindex)+tau(i,k,la,aerindex)
-          ENDDO
-        ENDDO
-
-      ELSE               !--cases of insoluble aerosol
-
-        DO k=1, klev
-          DO i=1, klon
-            tau_ae5wv_int = alpha_aeri_5wv(la,spinsol)
-            tau(i,k,la,aerindex) = tr_seri(i,k,itr)*zdm(i,k)*tau_ae5wv_int
-            tausum(i,la,aerindex)= tausum(i,la,aerindex)+tau(i,k,la,aerindex)
-          ENDDO
-        ENDDO
-
-      ENDIF
-
-    ENDDO   ! Boucle sur les longueurs d'onde
-  ENDDO     ! Boucle sur les masses de traceurs
-
-!--AOD calculations for diagnostics
-  od550aer(:)=SUM(tausum(:,la550,1:naero),dim=2)
-  od865aer(:)=SUM(tausum(:,la865,1:naero),dim=2)
-
-!--extinction coefficient for diagnostic
-  ec550aer(:,:)=SUM(tau(:,:,la550,1:naero),dim=3)/zdh(:,:)
-
-!--aod for particles lower than 1 micron
-  od550lt1aer(:)=tausum(:,la550,1)+tausum(:,la550,2)*0.3+tausum(:,la550,3)*0.2
-
-END SUBROUTINE SPLAEROPT_5WV_RRTM
Index: /LMDZ6/trunk/libf/phylmd/Dust/splaeropt_5wv_rrtm.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/Dust/splaeropt_5wv_rrtm.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/Dust/splaeropt_5wv_rrtm.f90	(revision 5268)
@@ -0,0 +1,169 @@
+!
+! $Id: splaeropt_5wv_rrtm.F90 2644 2016-10-02 16:55:08Z oboucher $
+!
+
+SUBROUTINE SPLAEROPT_5WV_RRTM(  &
+   zdm, zdh, tr_seri, RHcl,     &
+   tausum, tau )
+
+  USE DIMPHY
+  USE aero_mod
+  USE infotrac_phy, ONLY: nqtot, nbtr, tracers
+  USE phys_local_var_mod, ONLY: od550aer,od865aer,ec550aer,od550lt1aer
+  !
+  ! Olivier Boucher Jan 2017
+  ! Based on Mie routines on ciclad CMIP6
+  !
+  IMPLICIT NONE
+  !
+  ! Input arguments:
+  !
+  REAL, DIMENSION(klon,klev), INTENT(IN)   :: zdh      !--m
+  REAL, DIMENSION(klon,klev), INTENT(IN)   :: zdm      !--kg/m2
+  REAL, DIMENSION(klon,klev), INTENT(IN)   :: RHcl     ! humidite relative ciel clair
+  REAL, DIMENSION(klon,klev,nbtr), INTENT(IN) :: tr_seri
+  !
+  ! Output arguments:
+  !
+  REAL, DIMENSION(klon,nwave,naero_tot), INTENT(OUT)      :: tausum
+  REAL, DIMENSION(klon,klev,nwave,naero_tot), INTENT(OUT) :: tau
+  !
+  ! Local
+  !
+  INTEGER, PARAMETER :: las = nwave_sw
+  LOGICAL :: soluble
+  
+  INTEGER :: i, k, m, iq, itr, irh, aerindex
+  INTEGER :: spsol, spinsol, la
+  INTEGER :: RH_num(klon,klev)
+  INTEGER, PARAMETER :: la443 = 1
+  INTEGER, PARAMETER :: la550 = 2
+  INTEGER, PARAMETER :: la670 = 3
+  INTEGER, PARAMETER :: la765 = 4
+  INTEGER, PARAMETER :: la865 = 5
+  INTEGER, PARAMETER :: nbre_RH=12
+  INTEGER, PARAMETER :: naero_soluble=2
+  INTEGER, PARAMETER :: naero_insoluble=2
+  INTEGER, PARAMETER :: naero=naero_soluble+naero_insoluble
+
+  REAL, PARAMETER :: RH_tab(nbre_RH)=(/0.,10.,20.,30.,40.,50.,60.,70.,80.,85.,90.,95./)
+  REAL, PARAMETER :: RH_MAX=95.
+  REAL :: delta(klon,klev), rh(klon,klev)
+  REAL :: tau_ae5wv_int   ! Intermediate computation of epaisseur optique aerosol
+  REAL :: zrho
+  CHARACTER*20 modname
+  
+  ! Soluble components 1-accumulation mode soluble; 2- seasalt coarse
+  REAL :: alpha_aers_5wv(nbre_RH,las,naero_soluble)   ! Ext. coeff. ** m2/g 
+  ! Insoluble components 1- Dust: 2- BC; 3- POM
+  REAL :: alpha_aeri_5wv(las,naero_insoluble)         ! Ext. coeff. ** m2/g 
+  !
+  ! Proprietes optiques
+  !
+  REAL :: fact_RH(nbre_RH)
+
+! From here on we look at the optical parameters at 5 wavelengths:  
+! 443nm, 550, 670, 765 and 865 nm 
+!                                   le 12 AVRIL 2006 
+!  
+ DATA alpha_aers_5wv/ & 
+                           ! accumulation mode (sulfate+2% bc) soluble 
+       4.632, 4.632, 4.632, 4.632, 6.206, 6.827, 7.616, 8.716,10.514,12.025,14.688,21.539, &
+       3.981, 3.981, 3.981, 3.981, 5.346, 5.923, 6.662, 7.704, 9.437,10.914,13.562,20.591, &
+       3.265, 3.265, 3.265, 3.265, 4.400, 4.909, 5.565, 6.500, 8.081, 9.449,11.943,18.791, &
+       2.761, 2.761, 2.761, 2.761, 3.731, 4.182, 4.767, 5.606, 7.041, 8.294,10.610,17.118, &
+       2.307, 2.307, 2.307, 2.307, 3.129, 3.522, 4.034, 4.774, 6.052, 7.180, 9.286,15.340, &
+
+                           ! seasalt seasalt Coarse Soluble (CS)      
+       0.576, 0.690, 0.738, 0.789, 0.855, 0.935, 1.046, 1.212, 1.512, 1.785, 2.258, 3.449, &
+       0.595, 0.713, 0.763, 0.814, 0.880, 0.963, 1.079, 1.248, 1.550, 1.826, 2.306, 3.507, &
+       0.617, 0.738, 0.789, 0.842, 0.911, 0.996, 1.113, 1.286, 1.592, 1.871, 2.369, 3.562, &
+       0.632, 0.755, 0.808, 0.862, 0.931, 1.018, 1.140, 1.316, 1.626, 1.909, 2.409, 3.622, &
+       0.645, 0.771, 0.825, 0.880, 0.951, 1.039, 1.164, 1.344, 1.661, 1.948, 2.455, 3.682  /
+
+  DATA alpha_aeri_5wv/ &
+                                 ! coarse dust insoluble 
+       0.605, 0.611, 0.661, 0.714, 0.760, &
+                                 ! super coarse insoluble 
+       0.153, 0.156, 0.158, 0.157, 0.161 /
+  ! 
+  ! Initialisations
+  tausum(:,:,:)=0.
+  tau(:,:,:,:)=0.
+
+  modname='splaeropt_5wv_rrtm'
+
+  IF (naero.GT.naero_tot) THEN 
+    CALL abort_physic(modname,'Too many aerosol types',1)
+  ENDIF
+
+  DO irh=1,nbre_RH-1
+    fact_RH(irh)=1./(RH_tab(irh+1)-RH_tab(irh))
+  ENDDO
+   
+  DO k=1, klev
+    DO i=1, klon
+      rh(i,k)=MIN(RHcl(i,k)*100.,RH_MAX)
+      RH_num(i,k) = INT( rh(i,k)/10. + 1.)
+      IF (rh(i,k).GT.85.) RH_num(i,k)=10
+      IF (rh(i,k).GT.90.) RH_num(i,k)=11
+      delta(i,k)=(rh(i,k)-RH_tab(RH_num(i,k)))*fact_RH(RH_num(i,k))
+    ENDDO
+  ENDDO
+
+  itr = 0
+  DO iq = 1, nqtot
+    IF(.NOT.tracers(iq)%isInPhysics) CYCLE
+    itr = itr+1
+    SELECT CASE(tracers(iq)%name)
+      CASE('PREC'); CYCLE                                  !--precursor
+      CASE('FINE'); soluble=.TRUE.;  spsol=1; aerindex=1   !--fine mode accumulation mode
+      CASE('COSS'); soluble=.TRUE.;  spsol=2; aerindex=2   !--coarse mode sea salt
+      CASE('CODU'); soluble=.FALSE.; spinsol=1; aerindex=3   !--coarse mode dust
+      CASE('SCDU'); soluble=.FALSE.; spinsol=2; aerindex=4   !--super coarse mode dust
+      CASE DEFAULT; CALL abort_physic(modname,'I cannot do aerosol optics for '//tracers(iq)%name,1)
+    END SELECT
+
+    DO la=1,las
+
+      !--only 550 and 865 nm are used
+      IF (la.NE.la550.AND.la.NE.la865) CYCLE
+
+      IF (soluble) THEN  !--soluble aerosol with RH dependence
+
+        DO k=1, klev
+          DO i=1, klon
+            tau_ae5wv_int = alpha_aers_5wv(RH_num(i,k),la,spsol)+DELTA(i,k)* &
+                           (alpha_aers_5wv(RH_num(i,k)+1,la,spsol) - & 
+                            alpha_aers_5wv(RH_num(i,k),la,spsol))
+            tau(i,k,la,aerindex) = tr_seri(i,k,itr)*zdm(i,k)*tau_ae5wv_int
+            tausum(i,la,aerindex)=tausum(i,la,aerindex)+tau(i,k,la,aerindex)
+          ENDDO
+        ENDDO
+
+      ELSE               !--cases of insoluble aerosol
+
+        DO k=1, klev
+          DO i=1, klon
+            tau_ae5wv_int = alpha_aeri_5wv(la,spinsol)
+            tau(i,k,la,aerindex) = tr_seri(i,k,itr)*zdm(i,k)*tau_ae5wv_int
+            tausum(i,la,aerindex)= tausum(i,la,aerindex)+tau(i,k,la,aerindex)
+          ENDDO
+        ENDDO
+
+      ENDIF
+
+    ENDDO   ! Boucle sur les longueurs d'onde
+  ENDDO     ! Boucle sur les masses de traceurs
+
+!--AOD calculations for diagnostics
+  od550aer(:)=SUM(tausum(:,la550,1:naero),dim=2)
+  od865aer(:)=SUM(tausum(:,la865,1:naero),dim=2)
+
+!--extinction coefficient for diagnostic
+  ec550aer(:,:)=SUM(tau(:,:,la550,1:naero),dim=3)/zdh(:,:)
+
+!--aod for particles lower than 1 micron
+  od550lt1aer(:)=tausum(:,la550,1)+tausum(:,la550,2)*0.3+tausum(:,la550,3)*0.2
+
+END SUBROUTINE SPLAEROPT_5WV_RRTM
Index: DZ6/trunk/libf/phylmd/Dust/splaeropt_6bands_rrtm.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/Dust/splaeropt_6bands_rrtm.F90	(revision 5267)
+++ 	(revision )
@@ -1,253 +1,0 @@
-!
-! $Id: splaeropt_6bands_rrtm.F90 2644 2016-10-02 16:55:08Z oboucher $
-!
-SUBROUTINE SPLAEROPT_6BANDS_RRTM ( &
-     zdm, tr_seri, RHcl,           &
-     tau_allaer, piz_allaer, cg_allaer )
-
-  USE dimphy
-  USE aero_mod
-  USE infotrac_phy, ONLY: nqtot, nbtr, tracers
-  USE phys_local_var_mod, ONLY: abs550aer
-
-  ! Olivier Boucher Jan 2017
-  ! based on Mie routines on ciclad CMIP6
-  !
-  IMPLICIT NONE
-
-  INCLUDE "clesphys.h"
-  !
-  ! Input arguments:
-  !
-  REAL, DIMENSION(klon,klev),     INTENT(IN)  :: zdm        !--hauteur des couches en kg/m2
-  REAL, DIMENSION(klon,klev),     INTENT(IN)  :: RHcl       ! humidite relative ciel clair
-  REAL, DIMENSION(klon,klev,nbtr),INTENT(IN)  :: tr_seri
-  !
-  ! Output arguments:
-  ! 2= total aerosols 
-  ! 1= natural aerosols
-  !
-  REAL, DIMENSION(klon,klev,2,nbands_sw_rrtm), INTENT(OUT) :: tau_allaer ! epaisseur optique aerosol
-  REAL, DIMENSION(klon,klev,2,nbands_sw_rrtm), INTENT(OUT) :: piz_allaer ! single scattering albedo aerosol
-  REAL, DIMENSION(klon,klev,2,nbands_sw_rrtm), INTENT(OUT) :: cg_allaer  ! asymmetry parameter aerosol
-  !
-  ! Local
-  !
-  LOGICAL :: soluble
-  INTEGER :: i, k, irh, iq, itr, inu
-  INTEGER :: aerindex, spsol, spinsol
-  INTEGER :: RH_num(klon,klev)
-
-  INTEGER, PARAMETER :: naero_soluble=2    ! 1- accumulation soluble; 2- coarse soluble
-  INTEGER, PARAMETER :: naero_insoluble=2  ! 1- coarse dust; 2- supercoarse dust
-  INTEGER, PARAMETER :: naero=naero_soluble+naero_insoluble
-
-  INTEGER, PARAMETER :: nbre_RH=12
-  REAL,PARAMETER :: RH_tab(nbre_RH)=(/0.,10.,20.,30.,40.,50.,60.,70.,80.,85.,90.,95./)
-  REAL, PARAMETER :: RH_MAX=95.
-  REAL :: delta(klon,klev), rh(klon,klev)
-  REAL :: tau_ae2b_int   ! Intermediate computation of epaisseur optique aerosol
-  REAL :: piz_ae2b_int   ! Intermediate computation of Single scattering albedo
-  REAL :: cg_ae2b_int    ! Intermediate computation of Assymetry parameter
-  REAL :: fact_RH(nbre_RH), tmp_var
-  !
-  REAL, DIMENSION(klon,klev,naero_tot,nbands_sw_rrtm) ::  tau_ae
-  REAL, DIMENSION(klon,klev,naero_tot,nbands_sw_rrtm) ::  piz_ae
-  REAL, DIMENSION(klon,klev,naero_tot,nbands_sw_rrtm) ::  cg_ae
-  !
-  ! Proprietes optiques
-  !
-  REAL:: alpha_aers_6bands(nbre_RH,nbands_sw_rrtm,naero_soluble)   !--unit m2/g aer
-  REAL:: alpha_aeri_6bands(nbands_sw_rrtm,naero_insoluble)         !--unit m2/g aer
-  REAL:: cg_aers_6bands(nbre_RH,nbands_sw_rrtm,naero_soluble)      !--unitless 
-  REAL:: cg_aeri_6bands(nbands_sw_rrtm,naero_insoluble)            !--unitless
-  REAL:: piz_aers_6bands(nbre_RH,nbands_sw_rrtm,naero_soluble)     !--unitless
-  REAL:: piz_aeri_6bands(nbands_sw_rrtm,naero_insoluble)           !--unitless
-  !
-  REAL, PARAMETER :: tau_min = 1.e-8
-  CHARACTER*20 modname
-
-!***************************************************************************
-!--the order of the soluble   species has to follow the spsol   index below
-!--the order of the insoluble species has to follow the spinsol index below
-
-  DATA alpha_aers_6bands/  & 
-       ! accumulation (sulfate+2% bc) mode soluble
-  5.212, 5.212, 5.212, 5.212, 6.973, 7.581, 8.349, 9.400,11.078,12.463,14.857,20.837, &
-  4.906, 4.906, 4.906, 4.906, 6.568, 7.195, 7.989, 9.088,10.869,12.354,14.951,21.545, &
-  3.940, 3.940, 3.940, 3.940, 5.291, 5.861, 6.591, 7.620, 9.332,10.791,13.410,20.370, &
-  2.292, 2.292, 2.292, 2.292, 3.105, 3.493, 3.996, 4.724, 5.978, 7.084, 9.146,15.067, &
-  0.762, 0.762, 0.762, 0.762, 1.050, 1.201, 1.401, 1.699, 2.232, 2.721, 3.675, 6.678, &
-  0.090, 0.090, 0.090, 0.090, 0.122, 0.141, 0.166, 0.204, 0.275, 0.344, 0.484, 0.973, &
-        ! coarse seasalt
-  0.547, 0.657, 0.705, 0.754, 0.817, 0.896, 1.008, 1.169, 1.456, 1.724, 2.199, 3.358, &
-  0.566, 0.679, 0.727, 0.776, 0.840, 0.920, 1.032, 1.196, 1.492, 1.760, 2.238, 3.416, &
-  0.596, 0.714, 0.764, 0.816, 0.882, 0.965, 1.081, 1.250, 1.552, 1.828, 2.310, 3.509, &
-  0.644, 0.771, 0.825, 0.880, 0.951, 1.040, 1.164, 1.345, 1.666, 1.957, 2.462, 3.700, &
-  0.640, 0.772, 0.829, 0.887, 0.965, 1.061, 1.198, 1.398, 1.758, 2.085, 2.658, 4.031, &
-  0.452, 0.562, 0.609, 0.659, 0.728, 0.813, 0.938, 1.125, 1.471, 1.797, 2.384, 3.855  /
-
-  DATA alpha_aeri_6bands/  & 
-       ! coarse dust insoluble
-  0.594, 0.610, 0.619, 0.762, 0.791, 0.495, &
-       ! supercoarse dust insoluble 
-  0.151, 0.152, 0.155, 0.159, 0.168, 0.167  /
-
-  DATA cg_aers_6bands/ &
-       ! accumulation (sulfate+2% bc) mode soluble 
-  0.692, 0.692, 0.692, 0.692, 0.735, 0.739, 0.744, 0.749, 0.755, 0.759, 0.765, 0.772, &
-  0.690, 0.690, 0.690, 0.690, 0.736, 0.740, 0.746, 0.752, 0.760, 0.765, 0.771, 0.779, &
-  0.678, 0.678, 0.678, 0.678, 0.727, 0.733, 0.740, 0.748, 0.759, 0.766, 0.775, 0.787, &
-  0.641, 0.641, 0.641, 0.641, 0.692, 0.700, 0.710, 0.721, 0.736, 0.746, 0.760, 0.781, &
-  0.553, 0.553, 0.553, 0.553, 0.603, 0.615, 0.627, 0.643, 0.664, 0.678, 0.699, 0.735, &
-  0.343, 0.343, 0.343, 0.343, 0.386, 0.399, 0.414, 0.433, 0.460, 0.480, 0.510, 0.569, &
-       ! seasalt coarse Soluble
-  0.754, 0.770, 0.776, 0.781, 0.784, 0.791, 0.797, 0.805, 0.815, 0.822, 0.828, 0.840, &
-  0.736, 0.753, 0.759, 0.765, 0.771, 0.778, 0.785, 0.793, 0.804, 0.811, 0.820, 0.831, &
-  0.716, 0.735, 0.742, 0.748, 0.754, 0.762, 0.769, 0.778, 0.789, 0.796, 0.807, 0.819, &
-  0.704, 0.725, 0.733, 0.739, 0.745, 0.752, 0.759, 0.768, 0.778, 0.784, 0.792, 0.803, &
-  0.716, 0.737, 0.744, 0.751, 0.756, 0.763, 0.770, 0.777, 0.786, 0.790, 0.795, 0.800, &
-  0.688, 0.730, 0.741, 0.751, 0.761, 0.771, 0.782, 0.795, 0.810, 0.820, 0.833, 0.849  /
-
-  DATA cg_aeri_6bands/ &
-       ! coarse dust insoluble
-  0.801, 0.779, 0.709, 0.698, 0.710, 0.687, &
-       ! super coarse dust insoluble
-  0.862, 0.871, 0.852, 0.799, 0.758, 0.651  /
-
-  DATA piz_aers_6bands/&
-       ! accumulation (sulfate+2% bc) mode soluble
-  0.941, 0.941, 0.941, 0.941, 0.958, 0.961, 0.965, 0.969, 0.974, 0.977, 0.981, 0.987, &
-  0.941, 0.941, 0.941, 0.941, 0.959, 0.963, 0.967, 0.971, 0.976, 0.979, 0.983, 0.988, &
-  0.953, 0.953, 0.953, 0.953, 0.967, 0.971, 0.974, 0.978, 0.982, 0.984, 0.988, 0.992, &
-  0.955, 0.955, 0.955, 0.955, 0.969, 0.972, 0.976, 0.980, 0.984, 0.986, 0.989, 0.994, &
-  0.936, 0.936, 0.936, 0.936, 0.955, 0.961, 0.966, 0.972, 0.978, 0.982, 0.987, 0.993, &
-  0.792, 0.792, 0.792, 0.792, 0.848, 0.867, 0.887, 0.907, 0.931, 0.944, 0.960, 0.980, &
-       ! seasalt coarse soluble
-  1.000, 1.000, 1.000, 1.000, 1.000, 1.000, 1.000, 1.000, 1.000, 1.000, 1.001, 1.000, &
-  1.000, 1.000, 1.000, 1.000, 1.000, 1.000, 1.000, 1.000, 1.000, 1.000, 1.000, 1.000, &
-  1.000, 1.000, 1.000, 1.000, 1.000, 1.000, 1.000, 1.000, 1.000, 1.000, 1.000, 1.000, &
-  1.000, 1.000, 1.000, 1.000, 1.000, 1.000, 1.000, 1.000, 1.000, 1.000, 1.000, 1.000, &
-  0.994, 0.994, 0.995, 0.995, 0.995, 0.995, 0.996, 0.996, 0.996, 0.996, 0.996, 0.996, &
-  0.976, 0.867, 0.837, 0.814, 0.796, 0.774, 0.754, 0.735, 0.713, 0.702, 0.690, 0.675  /
-
-  DATA piz_aeri_6bands/ &
-       ! coarse dust insoluble
-  0.866, 0.875, 0.915, 0.977, 0.993, 0.971, &
-       ! super coarse dust insoluble
-  0.789, 0.749, 0.791, 0.918, 0.970, 0.909  /
-!
-  spsol = 0
-  spinsol = 0 
-
-  modname='splaeropt_6bands_rrt'
-
-  IF (NSW.NE.nbands_sw_rrtm) THEN
-     CALL abort_physic(modname,'Erreur NSW doit etre egal a 6 pour cette routine',1)
-  ENDIF
-
-  DO irh=1,nbre_RH-1
-    fact_RH(irh)=1./(RH_tab(irh+1)-RH_tab(irh))
-  ENDDO
-   
-  DO k=1, klev
-    DO i=1, klon
-      rh(i,k)=MIN(RHcl(i,k)*100.,RH_MAX)
-      RH_num(i,k) = INT(rh(i,k)/10. + 1.)
-      IF (rh(i,k).GT.85.) RH_num(i,k)=10
-      IF (rh(i,k).GT.90.) RH_num(i,k)=11
-      delta(i,k)=(rh(i,k)-RH_tab(RH_num(i,k)))*fact_RH(RH_num(i,k))
-    ENDDO
-  ENDDO
-
-  tau_ae(:,:,:,:)=0.
-  piz_ae(:,:,:,:)=0.
-  cg_ae(:,:,:,:)=0.
-    
-  itr = 0
-  DO iq = 1, nqtot
-    IF(.NOT.tracers(iq)%isInPhysics) CYCLE
-    itr = itr+1
-    SELECT CASE(tracers(iq)%name)
-      CASE('PREC'); CYCLE                                  !--precursor
-      CASE('FINE'); soluble=.TRUE.;  spsol=1; aerindex=1   !--fine mode accumulation mode
-      CASE('COSS'); soluble=.TRUE.;  spsol=2; aerindex=2   !--coarse mode sea salt
-      CASE('CODU'); soluble=.FALSE.; spinsol=1; aerindex=3   !--coarse mode dust
-      CASE('SCDU'); soluble=.FALSE.; spinsol=2; aerindex=4   !--super coarse mode dust
-      CASE DEFAULT; CALL abort_physic(modname,'I cannot do aerosol optics for '//tracers(iq)%name,1)
-    END SELECT
-
-    IF (soluble) THEN ! For aerosol soluble components
-
-         DO k=1, klev
-           DO i=1, klon
-
-             tmp_var=tr_seri(i,k,itr)*zdm(i,k) !-- g/m2
-
-             DO inu=1,NSW
-
-               tau_ae2b_int= alpha_aers_6bands(RH_num(i,k),inu,spsol)+ & 
-                             delta(i,k)* (alpha_aers_6bands(RH_num(i,k)+1,inu,spsol) - & 
-                             alpha_aers_6bands(RH_num(i,k),inu,spsol))
-                   
-               piz_ae2b_int = piz_aers_6bands(RH_num(i,k),inu,spsol) + & 
-                              delta(i,k)* (piz_aers_6bands(RH_num(i,k)+1,inu,spsol) - & 
-                              piz_aers_6bands(RH_num(i,k),inu,spsol))
-                   
-               cg_ae2b_int = cg_aers_6bands(RH_num(i,k),inu,spsol) + & 
-                             delta(i,k)* (cg_aers_6bands(RH_num(i,k)+1,inu,spsol) - & 
-                             cg_aers_6bands(RH_num(i,k),inu,spsol))
-
-               tau_ae(i,k,aerindex,inu)    = tmp_var*tau_ae2b_int
-               piz_ae(i,k,aerindex,inu)    = piz_ae2b_int
-               cg_ae(i,k,aerindex,inu)     = cg_ae2b_int
-
-             ENDDO
-           ENDDO
-         ENDDO
-
-    ELSE    ! For all aerosol insoluble components
-
-       DO k=1, klev
-         DO i=1, klon
-
-           tmp_var=tr_seri(i,k,itr)*zdm(i,k) !-- g/m2
-
-           DO inu=1,NSW
-             tau_ae2b_int = alpha_aeri_6bands(inu,spinsol)
-             piz_ae2b_int = piz_aeri_6bands(inu,spinsol)
-             cg_ae2b_int = cg_aeri_6bands(inu,spinsol) 
-
-             tau_ae(i,k,aerindex,inu) = tmp_var*tau_ae2b_int
-             piz_ae(i,k,aerindex,inu) = piz_ae2b_int
-             cg_ae(i,k,aerindex,inu)= cg_ae2b_int
-           ENDDO
-         ENDDO
-       ENDDO
-
-     ENDIF ! soluble / insoluble
-
-  ENDDO  ! nbtr
-
-!--all (natural + anthropogenic) aerosol
-  tau_allaer(:,:,2,:)=SUM(tau_ae(:,:,1:naero,:),dim=3) 
-  tau_allaer(:,:,2,:)=MAX(tau_allaer(:,:,2,:),tau_min)
-
-  piz_allaer(:,:,2,:)=SUM(tau_ae(:,:,1:naero,:)*piz_ae(:,:,1:naero,:),dim=3)/tau_allaer(:,:,2,:)
-  piz_allaer(:,:,2,:)=MIN(MAX(piz_allaer(:,:,2,:),0.01),1.0)
-  WHERE (tau_allaer(:,:,2,:).LE.tau_min) piz_allaer(:,:,2,:)=1.0
-
-  cg_allaer(:,:,2,:)=SUM(tau_ae(:,:,1:naero,:)*piz_ae(:,:,1:naero,:)*cg_ae(:,:,1:naero,:),dim=3)/  & 
-                     (tau_allaer(:,:,2,:)*piz_allaer(:,:,2,:))
-  cg_allaer(:,:,2,:)=MIN(MAX(cg_allaer(:,:,2,:),0.0),1.0)
-
-!--no aerosol
-  tau_allaer(:,:,1,:)=tau_min 
-  piz_allaer(:,:,1,:)=1.0 
-  cg_allaer(:,:,1,:)=0.0
-
-!--waveband 2 and all aerosol (third index = 2)
-  inu=2
-  abs550aer(:)=SUM((1-piz_allaer(:,:,2,inu))*tau_allaer(:,:,2,inu),dim=2)
-
-END SUBROUTINE SPLAEROPT_6BANDS_RRTM
Index: /LMDZ6/trunk/libf/phylmd/Dust/splaeropt_6bands_rrtm.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/Dust/splaeropt_6bands_rrtm.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/Dust/splaeropt_6bands_rrtm.f90	(revision 5268)
@@ -0,0 +1,253 @@
+!
+! $Id: splaeropt_6bands_rrtm.F90 2644 2016-10-02 16:55:08Z oboucher $
+!
+SUBROUTINE SPLAEROPT_6BANDS_RRTM ( &
+     zdm, tr_seri, RHcl,           &
+     tau_allaer, piz_allaer, cg_allaer )
+
+  USE dimphy
+  USE aero_mod
+  USE infotrac_phy, ONLY: nqtot, nbtr, tracers
+  USE phys_local_var_mod, ONLY: abs550aer
+
+  ! Olivier Boucher Jan 2017
+  ! based on Mie routines on ciclad CMIP6
+  !
+  IMPLICIT NONE
+
+  INCLUDE "clesphys.h"
+  !
+  ! Input arguments:
+  !
+  REAL, DIMENSION(klon,klev),     INTENT(IN)  :: zdm        !--hauteur des couches en kg/m2
+  REAL, DIMENSION(klon,klev),     INTENT(IN)  :: RHcl       ! humidite relative ciel clair
+  REAL, DIMENSION(klon,klev,nbtr),INTENT(IN)  :: tr_seri
+  !
+  ! Output arguments:
+  ! 2= total aerosols 
+  ! 1= natural aerosols
+  !
+  REAL, DIMENSION(klon,klev,2,nbands_sw_rrtm), INTENT(OUT) :: tau_allaer ! epaisseur optique aerosol
+  REAL, DIMENSION(klon,klev,2,nbands_sw_rrtm), INTENT(OUT) :: piz_allaer ! single scattering albedo aerosol
+  REAL, DIMENSION(klon,klev,2,nbands_sw_rrtm), INTENT(OUT) :: cg_allaer  ! asymmetry parameter aerosol
+  !
+  ! Local
+  !
+  LOGICAL :: soluble
+  INTEGER :: i, k, irh, iq, itr, inu
+  INTEGER :: aerindex, spsol, spinsol
+  INTEGER :: RH_num(klon,klev)
+
+  INTEGER, PARAMETER :: naero_soluble=2    ! 1- accumulation soluble; 2- coarse soluble
+  INTEGER, PARAMETER :: naero_insoluble=2  ! 1- coarse dust; 2- supercoarse dust
+  INTEGER, PARAMETER :: naero=naero_soluble+naero_insoluble
+
+  INTEGER, PARAMETER :: nbre_RH=12
+  REAL,PARAMETER :: RH_tab(nbre_RH)=(/0.,10.,20.,30.,40.,50.,60.,70.,80.,85.,90.,95./)
+  REAL, PARAMETER :: RH_MAX=95.
+  REAL :: delta(klon,klev), rh(klon,klev)
+  REAL :: tau_ae2b_int   ! Intermediate computation of epaisseur optique aerosol
+  REAL :: piz_ae2b_int   ! Intermediate computation of Single scattering albedo
+  REAL :: cg_ae2b_int    ! Intermediate computation of Assymetry parameter
+  REAL :: fact_RH(nbre_RH), tmp_var
+  !
+  REAL, DIMENSION(klon,klev,naero_tot,nbands_sw_rrtm) ::  tau_ae
+  REAL, DIMENSION(klon,klev,naero_tot,nbands_sw_rrtm) ::  piz_ae
+  REAL, DIMENSION(klon,klev,naero_tot,nbands_sw_rrtm) ::  cg_ae
+  !
+  ! Proprietes optiques
+  !
+  REAL:: alpha_aers_6bands(nbre_RH,nbands_sw_rrtm,naero_soluble)   !--unit m2/g aer
+  REAL:: alpha_aeri_6bands(nbands_sw_rrtm,naero_insoluble)         !--unit m2/g aer
+  REAL:: cg_aers_6bands(nbre_RH,nbands_sw_rrtm,naero_soluble)      !--unitless 
+  REAL:: cg_aeri_6bands(nbands_sw_rrtm,naero_insoluble)            !--unitless
+  REAL:: piz_aers_6bands(nbre_RH,nbands_sw_rrtm,naero_soluble)     !--unitless
+  REAL:: piz_aeri_6bands(nbands_sw_rrtm,naero_insoluble)           !--unitless
+  !
+  REAL, PARAMETER :: tau_min = 1.e-8
+  CHARACTER*20 modname
+
+!***************************************************************************
+!--the order of the soluble   species has to follow the spsol   index below
+!--the order of the insoluble species has to follow the spinsol index below
+
+  DATA alpha_aers_6bands/  & 
+       ! accumulation (sulfate+2% bc) mode soluble
+  5.212, 5.212, 5.212, 5.212, 6.973, 7.581, 8.349, 9.400,11.078,12.463,14.857,20.837, &
+  4.906, 4.906, 4.906, 4.906, 6.568, 7.195, 7.989, 9.088,10.869,12.354,14.951,21.545, &
+  3.940, 3.940, 3.940, 3.940, 5.291, 5.861, 6.591, 7.620, 9.332,10.791,13.410,20.370, &
+  2.292, 2.292, 2.292, 2.292, 3.105, 3.493, 3.996, 4.724, 5.978, 7.084, 9.146,15.067, &
+  0.762, 0.762, 0.762, 0.762, 1.050, 1.201, 1.401, 1.699, 2.232, 2.721, 3.675, 6.678, &
+  0.090, 0.090, 0.090, 0.090, 0.122, 0.141, 0.166, 0.204, 0.275, 0.344, 0.484, 0.973, &
+        ! coarse seasalt
+  0.547, 0.657, 0.705, 0.754, 0.817, 0.896, 1.008, 1.169, 1.456, 1.724, 2.199, 3.358, &
+  0.566, 0.679, 0.727, 0.776, 0.840, 0.920, 1.032, 1.196, 1.492, 1.760, 2.238, 3.416, &
+  0.596, 0.714, 0.764, 0.816, 0.882, 0.965, 1.081, 1.250, 1.552, 1.828, 2.310, 3.509, &
+  0.644, 0.771, 0.825, 0.880, 0.951, 1.040, 1.164, 1.345, 1.666, 1.957, 2.462, 3.700, &
+  0.640, 0.772, 0.829, 0.887, 0.965, 1.061, 1.198, 1.398, 1.758, 2.085, 2.658, 4.031, &
+  0.452, 0.562, 0.609, 0.659, 0.728, 0.813, 0.938, 1.125, 1.471, 1.797, 2.384, 3.855  /
+
+  DATA alpha_aeri_6bands/  & 
+       ! coarse dust insoluble
+  0.594, 0.610, 0.619, 0.762, 0.791, 0.495, &
+       ! supercoarse dust insoluble 
+  0.151, 0.152, 0.155, 0.159, 0.168, 0.167  /
+
+  DATA cg_aers_6bands/ &
+       ! accumulation (sulfate+2% bc) mode soluble 
+  0.692, 0.692, 0.692, 0.692, 0.735, 0.739, 0.744, 0.749, 0.755, 0.759, 0.765, 0.772, &
+  0.690, 0.690, 0.690, 0.690, 0.736, 0.740, 0.746, 0.752, 0.760, 0.765, 0.771, 0.779, &
+  0.678, 0.678, 0.678, 0.678, 0.727, 0.733, 0.740, 0.748, 0.759, 0.766, 0.775, 0.787, &
+  0.641, 0.641, 0.641, 0.641, 0.692, 0.700, 0.710, 0.721, 0.736, 0.746, 0.760, 0.781, &
+  0.553, 0.553, 0.553, 0.553, 0.603, 0.615, 0.627, 0.643, 0.664, 0.678, 0.699, 0.735, &
+  0.343, 0.343, 0.343, 0.343, 0.386, 0.399, 0.414, 0.433, 0.460, 0.480, 0.510, 0.569, &
+       ! seasalt coarse Soluble
+  0.754, 0.770, 0.776, 0.781, 0.784, 0.791, 0.797, 0.805, 0.815, 0.822, 0.828, 0.840, &
+  0.736, 0.753, 0.759, 0.765, 0.771, 0.778, 0.785, 0.793, 0.804, 0.811, 0.820, 0.831, &
+  0.716, 0.735, 0.742, 0.748, 0.754, 0.762, 0.769, 0.778, 0.789, 0.796, 0.807, 0.819, &
+  0.704, 0.725, 0.733, 0.739, 0.745, 0.752, 0.759, 0.768, 0.778, 0.784, 0.792, 0.803, &
+  0.716, 0.737, 0.744, 0.751, 0.756, 0.763, 0.770, 0.777, 0.786, 0.790, 0.795, 0.800, &
+  0.688, 0.730, 0.741, 0.751, 0.761, 0.771, 0.782, 0.795, 0.810, 0.820, 0.833, 0.849  /
+
+  DATA cg_aeri_6bands/ &
+       ! coarse dust insoluble
+  0.801, 0.779, 0.709, 0.698, 0.710, 0.687, &
+       ! super coarse dust insoluble
+  0.862, 0.871, 0.852, 0.799, 0.758, 0.651  /
+
+  DATA piz_aers_6bands/&
+       ! accumulation (sulfate+2% bc) mode soluble
+  0.941, 0.941, 0.941, 0.941, 0.958, 0.961, 0.965, 0.969, 0.974, 0.977, 0.981, 0.987, &
+  0.941, 0.941, 0.941, 0.941, 0.959, 0.963, 0.967, 0.971, 0.976, 0.979, 0.983, 0.988, &
+  0.953, 0.953, 0.953, 0.953, 0.967, 0.971, 0.974, 0.978, 0.982, 0.984, 0.988, 0.992, &
+  0.955, 0.955, 0.955, 0.955, 0.969, 0.972, 0.976, 0.980, 0.984, 0.986, 0.989, 0.994, &
+  0.936, 0.936, 0.936, 0.936, 0.955, 0.961, 0.966, 0.972, 0.978, 0.982, 0.987, 0.993, &
+  0.792, 0.792, 0.792, 0.792, 0.848, 0.867, 0.887, 0.907, 0.931, 0.944, 0.960, 0.980, &
+       ! seasalt coarse soluble
+  1.000, 1.000, 1.000, 1.000, 1.000, 1.000, 1.000, 1.000, 1.000, 1.000, 1.001, 1.000, &
+  1.000, 1.000, 1.000, 1.000, 1.000, 1.000, 1.000, 1.000, 1.000, 1.000, 1.000, 1.000, &
+  1.000, 1.000, 1.000, 1.000, 1.000, 1.000, 1.000, 1.000, 1.000, 1.000, 1.000, 1.000, &
+  1.000, 1.000, 1.000, 1.000, 1.000, 1.000, 1.000, 1.000, 1.000, 1.000, 1.000, 1.000, &
+  0.994, 0.994, 0.995, 0.995, 0.995, 0.995, 0.996, 0.996, 0.996, 0.996, 0.996, 0.996, &
+  0.976, 0.867, 0.837, 0.814, 0.796, 0.774, 0.754, 0.735, 0.713, 0.702, 0.690, 0.675  /
+
+  DATA piz_aeri_6bands/ &
+       ! coarse dust insoluble
+  0.866, 0.875, 0.915, 0.977, 0.993, 0.971, &
+       ! super coarse dust insoluble
+  0.789, 0.749, 0.791, 0.918, 0.970, 0.909  /
+!
+  spsol = 0
+  spinsol = 0 
+
+  modname='splaeropt_6bands_rrt'
+
+  IF (NSW.NE.nbands_sw_rrtm) THEN
+     CALL abort_physic(modname,'Erreur NSW doit etre egal a 6 pour cette routine',1)
+  ENDIF
+
+  DO irh=1,nbre_RH-1
+    fact_RH(irh)=1./(RH_tab(irh+1)-RH_tab(irh))
+  ENDDO
+   
+  DO k=1, klev
+    DO i=1, klon
+      rh(i,k)=MIN(RHcl(i,k)*100.,RH_MAX)
+      RH_num(i,k) = INT(rh(i,k)/10. + 1.)
+      IF (rh(i,k).GT.85.) RH_num(i,k)=10
+      IF (rh(i,k).GT.90.) RH_num(i,k)=11
+      delta(i,k)=(rh(i,k)-RH_tab(RH_num(i,k)))*fact_RH(RH_num(i,k))
+    ENDDO
+  ENDDO
+
+  tau_ae(:,:,:,:)=0.
+  piz_ae(:,:,:,:)=0.
+  cg_ae(:,:,:,:)=0.
+    
+  itr = 0
+  DO iq = 1, nqtot
+    IF(.NOT.tracers(iq)%isInPhysics) CYCLE
+    itr = itr+1
+    SELECT CASE(tracers(iq)%name)
+      CASE('PREC'); CYCLE                                  !--precursor
+      CASE('FINE'); soluble=.TRUE.;  spsol=1; aerindex=1   !--fine mode accumulation mode
+      CASE('COSS'); soluble=.TRUE.;  spsol=2; aerindex=2   !--coarse mode sea salt
+      CASE('CODU'); soluble=.FALSE.; spinsol=1; aerindex=3   !--coarse mode dust
+      CASE('SCDU'); soluble=.FALSE.; spinsol=2; aerindex=4   !--super coarse mode dust
+      CASE DEFAULT; CALL abort_physic(modname,'I cannot do aerosol optics for '//tracers(iq)%name,1)
+    END SELECT
+
+    IF (soluble) THEN ! For aerosol soluble components
+
+         DO k=1, klev
+           DO i=1, klon
+
+             tmp_var=tr_seri(i,k,itr)*zdm(i,k) !-- g/m2
+
+             DO inu=1,NSW
+
+               tau_ae2b_int= alpha_aers_6bands(RH_num(i,k),inu,spsol)+ & 
+                             delta(i,k)* (alpha_aers_6bands(RH_num(i,k)+1,inu,spsol) - & 
+                             alpha_aers_6bands(RH_num(i,k),inu,spsol))
+                   
+               piz_ae2b_int = piz_aers_6bands(RH_num(i,k),inu,spsol) + & 
+                              delta(i,k)* (piz_aers_6bands(RH_num(i,k)+1,inu,spsol) - & 
+                              piz_aers_6bands(RH_num(i,k),inu,spsol))
+                   
+               cg_ae2b_int = cg_aers_6bands(RH_num(i,k),inu,spsol) + & 
+                             delta(i,k)* (cg_aers_6bands(RH_num(i,k)+1,inu,spsol) - & 
+                             cg_aers_6bands(RH_num(i,k),inu,spsol))
+
+               tau_ae(i,k,aerindex,inu)    = tmp_var*tau_ae2b_int
+               piz_ae(i,k,aerindex,inu)    = piz_ae2b_int
+               cg_ae(i,k,aerindex,inu)     = cg_ae2b_int
+
+             ENDDO
+           ENDDO
+         ENDDO
+
+    ELSE    ! For all aerosol insoluble components
+
+       DO k=1, klev
+         DO i=1, klon
+
+           tmp_var=tr_seri(i,k,itr)*zdm(i,k) !-- g/m2
+
+           DO inu=1,NSW
+             tau_ae2b_int = alpha_aeri_6bands(inu,spinsol)
+             piz_ae2b_int = piz_aeri_6bands(inu,spinsol)
+             cg_ae2b_int = cg_aeri_6bands(inu,spinsol) 
+
+             tau_ae(i,k,aerindex,inu) = tmp_var*tau_ae2b_int
+             piz_ae(i,k,aerindex,inu) = piz_ae2b_int
+             cg_ae(i,k,aerindex,inu)= cg_ae2b_int
+           ENDDO
+         ENDDO
+       ENDDO
+
+     ENDIF ! soluble / insoluble
+
+  ENDDO  ! nbtr
+
+!--all (natural + anthropogenic) aerosol
+  tau_allaer(:,:,2,:)=SUM(tau_ae(:,:,1:naero,:),dim=3) 
+  tau_allaer(:,:,2,:)=MAX(tau_allaer(:,:,2,:),tau_min)
+
+  piz_allaer(:,:,2,:)=SUM(tau_ae(:,:,1:naero,:)*piz_ae(:,:,1:naero,:),dim=3)/tau_allaer(:,:,2,:)
+  piz_allaer(:,:,2,:)=MIN(MAX(piz_allaer(:,:,2,:),0.01),1.0)
+  WHERE (tau_allaer(:,:,2,:).LE.tau_min) piz_allaer(:,:,2,:)=1.0
+
+  cg_allaer(:,:,2,:)=SUM(tau_ae(:,:,1:naero,:)*piz_ae(:,:,1:naero,:)*cg_ae(:,:,1:naero,:),dim=3)/  & 
+                     (tau_allaer(:,:,2,:)*piz_allaer(:,:,2,:))
+  cg_allaer(:,:,2,:)=MIN(MAX(cg_allaer(:,:,2,:),0.0),1.0)
+
+!--no aerosol
+  tau_allaer(:,:,1,:)=tau_min 
+  piz_allaer(:,:,1,:)=1.0 
+  cg_allaer(:,:,1,:)=0.0
+
+!--waveband 2 and all aerosol (third index = 2)
+  inu=2
+  abs550aer(:)=SUM((1-piz_allaer(:,:,2,inu))*tau_allaer(:,:,2,inu),dim=2)
+
+END SUBROUTINE SPLAEROPT_6BANDS_RRTM
Index: DZ6/trunk/libf/phylmd/Dust/splaeropt_lw_rrtm.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/Dust/splaeropt_lw_rrtm.F90	(revision 5267)
+++ 	(revision )
@@ -1,87 +1,0 @@
-!
-! splaeropt_lw_rrtm.F90 2014-05-13 C. Kleinschmitt
-!                      2016-05-03 O. Boucher 
-!
-! This routine feeds aerosol LW properties to RRTM
-! we only consider absorption (not scattering)
-
-SUBROUTINE SPLAEROPT_LW_RRTM(ok_alw,zdm,tr_seri)
-
-  USE dimphy
-  USE aero_mod
-  USE infotrac_phy, ONLY: nqtot, nbtr, tracers
-  USE phys_state_var_mod, ONLY : tau_aero_lw_rrtm
-  USE YOERAD, ONLY : NLW
-
-  IMPLICIT NONE
-
-  INCLUDE "clesphys.h"
-  !
-  ! Input arguments:
-  !
-  LOGICAL, INTENT(IN) :: ok_alw
-  REAL, DIMENSION(klon,klev), INTENT(IN)      :: zdm
-  REAL, DIMENSION(klon,klev,nbtr), INTENT(IN) :: tr_seri
-  !
-  ! Local arguments : 
-  !
-  INTEGER, PARAMETER :: naero_soluble=2    ! 1- accumulation soluble; 2- coarse soluble
-  INTEGER, PARAMETER :: naero_insoluble=2  ! 1- coarse dust; 2- supercoarse dust
-  INTEGER, PARAMETER :: naero=naero_soluble+naero_insoluble
-  !
-  INTEGER inu, itr, iq, spinsol
-  CHARACTER*20 modname
-  !
-  !--absorption coefficient for coarse and super-coarse DUST
-  REAL:: alpha_abs_CIDUST_16bands(nbands_lw_rrtm,naero_insoluble)   !--unit m2/g 
-  DATA alpha_abs_CIDUST_16bands /                         &
-   ! Dust CO insoluble
-  0.001, 0.003, 0.005, 0.006, 0.011, 0.031, 0.157, 0.102, &
-  0.017, 0.056, 0.032, 0.008, 0.010, 0.011, 0.013, 0.016, & 
-   ! Dust SC insoluble
-  0.002, 0.004, 0.007, 0.010, 0.018, 0.043, 0.099, 0.071, &
-  0.021, 0.056, 0.033, 0.011, 0.013, 0.014, 0.016, 0.018 /
-
-  modname='splaeropt_lw_rrtm'
-  ! 
-  IF (NLW.NE.nbands_lw_rrtm) THEN
-    CALL abort_physic(modname,'Erreur NLW doit etre egal a 16 pour cette routine',1)
-  ENDIF
-  !
-  IF (ok_alw) THEN 
-    !
-    !--initialisation
-    tau_aero_lw_rrtm = 0.0
-    !
-    
-    itr = 0
-    DO iq = 1, nqtot
-      IF(.NOT.tracers(iq)%isInPhysics) CYCLE
-      itr = itr+1
-      SELECT CASE(tracers(iq)%name)
-        CASE('PREC','FINE','COSS'); CYCLE                  !--precursor or fine/coarde accumulation mode
-        CASE('CODU'); spinsol=1                            !--coarse mode dust
-        CASE('SCDU'); spinsol=2                            !--super coarse mode dust
-        CASE DEFAULT; CALL abort_physic(modname,'I cannot do aerosol optics for '//tracers(iq)%name,1)
-      END SELECT
-      !
-      DO inu=1,NLW
-        !
-        !--total aerosol
-        tau_aero_lw_rrtm(:,:,2,inu) = tau_aero_lw_rrtm(:,:,2,inu) + tr_seri(:,:,itr)*zdm(:,:)*alpha_abs_CIDUST_16bands(inu,spinsol)
-        !--no aerosol at all
-        tau_aero_lw_rrtm(:,:,1,inu) = tau_aero_lw_rrtm(:,:,1,inu) + 0.0
-        !
-      ENDDO
-    !
-    ENDDO
-    !
-    !--avoid very small values
-    tau_aero_lw_rrtm = MAX(tau_aero_lw_rrtm,1.e-15)
-    ! 
-  ELSE
-    !--default value
-    tau_aero_lw_rrtm = 1.e-15
-  ENDIF
-  !
-END SUBROUTINE SPLAEROPT_LW_RRTM
Index: /LMDZ6/trunk/libf/phylmd/Dust/splaeropt_lw_rrtm.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/Dust/splaeropt_lw_rrtm.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/Dust/splaeropt_lw_rrtm.f90	(revision 5268)
@@ -0,0 +1,87 @@
+!
+! splaeropt_lw_rrtm.F90 2014-05-13 C. Kleinschmitt
+!                      2016-05-03 O. Boucher 
+!
+! This routine feeds aerosol LW properties to RRTM
+! we only consider absorption (not scattering)
+
+SUBROUTINE SPLAEROPT_LW_RRTM(ok_alw,zdm,tr_seri)
+
+  USE dimphy
+  USE aero_mod
+  USE infotrac_phy, ONLY: nqtot, nbtr, tracers
+  USE phys_state_var_mod, ONLY : tau_aero_lw_rrtm
+  USE YOERAD, ONLY : NLW
+
+  IMPLICIT NONE
+
+  INCLUDE "clesphys.h"
+  !
+  ! Input arguments:
+  !
+  LOGICAL, INTENT(IN) :: ok_alw
+  REAL, DIMENSION(klon,klev), INTENT(IN)      :: zdm
+  REAL, DIMENSION(klon,klev,nbtr), INTENT(IN) :: tr_seri
+  !
+  ! Local arguments : 
+  !
+  INTEGER, PARAMETER :: naero_soluble=2    ! 1- accumulation soluble; 2- coarse soluble
+  INTEGER, PARAMETER :: naero_insoluble=2  ! 1- coarse dust; 2- supercoarse dust
+  INTEGER, PARAMETER :: naero=naero_soluble+naero_insoluble
+  !
+  INTEGER inu, itr, iq, spinsol
+  CHARACTER*20 modname
+  !
+  !--absorption coefficient for coarse and super-coarse DUST
+  REAL:: alpha_abs_CIDUST_16bands(nbands_lw_rrtm,naero_insoluble)   !--unit m2/g 
+  DATA alpha_abs_CIDUST_16bands /                         &
+   ! Dust CO insoluble
+  0.001, 0.003, 0.005, 0.006, 0.011, 0.031, 0.157, 0.102, &
+  0.017, 0.056, 0.032, 0.008, 0.010, 0.011, 0.013, 0.016, & 
+   ! Dust SC insoluble
+  0.002, 0.004, 0.007, 0.010, 0.018, 0.043, 0.099, 0.071, &
+  0.021, 0.056, 0.033, 0.011, 0.013, 0.014, 0.016, 0.018 /
+
+  modname='splaeropt_lw_rrtm'
+  ! 
+  IF (NLW.NE.nbands_lw_rrtm) THEN
+    CALL abort_physic(modname,'Erreur NLW doit etre egal a 16 pour cette routine',1)
+  ENDIF
+  !
+  IF (ok_alw) THEN 
+    !
+    !--initialisation
+    tau_aero_lw_rrtm = 0.0
+    !
+    
+    itr = 0
+    DO iq = 1, nqtot
+      IF(.NOT.tracers(iq)%isInPhysics) CYCLE
+      itr = itr+1
+      SELECT CASE(tracers(iq)%name)
+        CASE('PREC','FINE','COSS'); CYCLE                  !--precursor or fine/coarde accumulation mode
+        CASE('CODU'); spinsol=1                            !--coarse mode dust
+        CASE('SCDU'); spinsol=2                            !--super coarse mode dust
+        CASE DEFAULT; CALL abort_physic(modname,'I cannot do aerosol optics for '//tracers(iq)%name,1)
+      END SELECT
+      !
+      DO inu=1,NLW
+        !
+        !--total aerosol
+        tau_aero_lw_rrtm(:,:,2,inu) = tau_aero_lw_rrtm(:,:,2,inu) + tr_seri(:,:,itr)*zdm(:,:)*alpha_abs_CIDUST_16bands(inu,spinsol)
+        !--no aerosol at all
+        tau_aero_lw_rrtm(:,:,1,inu) = tau_aero_lw_rrtm(:,:,1,inu) + 0.0
+        !
+      ENDDO
+    !
+    ENDDO
+    !
+    !--avoid very small values
+    tau_aero_lw_rrtm = MAX(tau_aero_lw_rrtm,1.e-15)
+    ! 
+  ELSE
+    !--default value
+    tau_aero_lw_rrtm = 1.e-15
+  ENDIF
+  !
+END SUBROUTINE SPLAEROPT_LW_RRTM
Index: DZ6/trunk/libf/phylmd/Dust/splaerosol_optic_rrtm.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/Dust/splaerosol_optic_rrtm.F90	(revision 5267)
+++ 	(revision )
@@ -1,86 +1,0 @@
-! $Id: splaerosol_optic_rrtm.F90 2644 2016-10-02 16:55:08Z oboucher $
-!
-SUBROUTINE splaerosol_optic_rrtm( ok_alw, pplay, paprs, t_seri, rhcl, &
-     tr_seri, mass_solu_aero, mass_solu_aero_pi, &
-     tau_aero, piz_aero, cg_aero, &
-     tausum_aero, tau3d_aero )
-
-  ! This routine will :
-  ! 1) recevie the aerosols(already read and interpolated) corresponding to flag_aerosol
-  ! 2) calculate the optical properties for the aerosols
-  !
-
-  USE dimphy
-  USE aero_mod
-  USE infotrac_phy, ONLY: nbtr, nqtot, tracers
-  USE yomcst_mod_h, ONLY: RD, RG
-
-  IMPLICIT NONE
-
-  INCLUDE "clesphys.h"
-
-
-  ! Input arguments
-  !****************************************************************************************
-  LOGICAL, INTENT(IN) :: ok_alw                      ! Apply aerosol LW effect or not
-  REAL, DIMENSION(klon,klev), INTENT(IN)   :: pplay
-  REAL, DIMENSION(klon,klev+1), INTENT(IN) :: paprs
-  REAL, DIMENSION(klon,klev), INTENT(IN)   :: t_seri
-  REAL, DIMENSION(klon,klev), INTENT(IN)   :: rhcl   ! humidite relative ciel clair
-  REAL, DIMENSION(klon,klev,nbtr), INTENT(IN) :: tr_seri ! concentration tracer
-
-  ! Output arguments
-  !****************************************************************************************
-  REAL, DIMENSION(klon,klev), INTENT(OUT)     :: mass_solu_aero    ! Total mass for all soluble aerosols
-  REAL, DIMENSION(klon,klev), INTENT(OUT)     :: mass_solu_aero_pi !     -"-     preindustrial values
-  REAL, DIMENSION(klon,klev,2,NSW), INTENT(OUT) :: tau_aero    ! Aerosol optical thickness
-  REAL, DIMENSION(klon,klev,2,NSW), INTENT(OUT) :: piz_aero    ! Single scattering albedo aerosol
-  REAL, DIMENSION(klon,klev,2,NSW), INTENT(OUT) :: cg_aero     ! asymmetry parameter aerosol
-  REAL, DIMENSION(klon,nwave,naero_tot), INTENT(OUT)       :: tausum_aero
-  REAL, DIMENSION(klon,klev,nwave,naero_tot), INTENT(OUT)  :: tau3d_aero
-
-  INTEGER i, k, iq, itr
-  REAL, DIMENSION(klon,klev) :: zdm, zdh
-  REAL zrho, pdel
-  !
-  ! Calculate the total mass of all soluble accumulation mode aerosols
-  ! to be revisited for AR6
-  !
-  mass_solu_aero(:,:)    = 0.0
-  mass_solu_aero_pi(:,:) = 0.0
-  !
-  itr = 0
-  DO iq = 1, nqtot
-    IF(.NOT.tracers(iq)%isInPhysics) CYCLE
-    itr = itr+1
-    IF(tracers(iq)%name/='FINE') THEN
-      mass_solu_aero(:,:)    = tr_seri(:,:,itr)
-      mass_solu_aero_pi(:,:) = tr_seri(:,:,itr)
-    ENDIF
-  ENDDO
-
-  ! Calculate layer thickness
-  DO k = 1, klev
-    DO i = 1, klon
-      pdel=paprs(i,k)-paprs(i,k+1)
-      zrho=pplay(i,k)/t_seri(i,k)/RD             ! kg/m3
-      zdh(i,k)=pdel/(RG*zrho)                    ! m
-      zdm(i,k)=pdel/RG                           ! kg/m2
-    ENDDO
-  ENDDO
-
-!--new aerosol properties
-! aeropt_6bands for rrtm
-  CALL splaeropt_6bands_rrtm(       &
-       zdm, tr_seri, rhcl,          & 
-       tau_aero, piz_aero, cg_aero )
-
-! aeropt_5wv only for validation and diagnostics
-  CALL splaeropt_5wv_rrtm(          &
-       zdm, zdh, tr_seri, rhcl,     & 
-       tausum_aero, tau3d_aero )
-
-! LW optical properties for tropospheric aerosols
-  CALL splaeropt_lw_rrtm(ok_alw,zdm,tr_seri)
-
-END SUBROUTINE splaerosol_optic_rrtm
Index: /LMDZ6/trunk/libf/phylmd/Dust/splaerosol_optic_rrtm.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/Dust/splaerosol_optic_rrtm.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/Dust/splaerosol_optic_rrtm.f90	(revision 5268)
@@ -0,0 +1,86 @@
+! $Id: splaerosol_optic_rrtm.F90 2644 2016-10-02 16:55:08Z oboucher $
+!
+SUBROUTINE splaerosol_optic_rrtm( ok_alw, pplay, paprs, t_seri, rhcl, &
+     tr_seri, mass_solu_aero, mass_solu_aero_pi, &
+     tau_aero, piz_aero, cg_aero, &
+     tausum_aero, tau3d_aero )
+
+  ! This routine will :
+  ! 1) recevie the aerosols(already read and interpolated) corresponding to flag_aerosol
+  ! 2) calculate the optical properties for the aerosols
+  !
+
+  USE dimphy
+  USE aero_mod
+  USE infotrac_phy, ONLY: nbtr, nqtot, tracers
+  USE yomcst_mod_h, ONLY: RD, RG
+
+  IMPLICIT NONE
+
+  INCLUDE "clesphys.h"
+
+
+  ! Input arguments
+  !****************************************************************************************
+  LOGICAL, INTENT(IN) :: ok_alw                      ! Apply aerosol LW effect or not
+  REAL, DIMENSION(klon,klev), INTENT(IN)   :: pplay
+  REAL, DIMENSION(klon,klev+1), INTENT(IN) :: paprs
+  REAL, DIMENSION(klon,klev), INTENT(IN)   :: t_seri
+  REAL, DIMENSION(klon,klev), INTENT(IN)   :: rhcl   ! humidite relative ciel clair
+  REAL, DIMENSION(klon,klev,nbtr), INTENT(IN) :: tr_seri ! concentration tracer
+
+  ! Output arguments
+  !****************************************************************************************
+  REAL, DIMENSION(klon,klev), INTENT(OUT)     :: mass_solu_aero    ! Total mass for all soluble aerosols
+  REAL, DIMENSION(klon,klev), INTENT(OUT)     :: mass_solu_aero_pi !     -"-     preindustrial values
+  REAL, DIMENSION(klon,klev,2,NSW), INTENT(OUT) :: tau_aero    ! Aerosol optical thickness
+  REAL, DIMENSION(klon,klev,2,NSW), INTENT(OUT) :: piz_aero    ! Single scattering albedo aerosol
+  REAL, DIMENSION(klon,klev,2,NSW), INTENT(OUT) :: cg_aero     ! asymmetry parameter aerosol
+  REAL, DIMENSION(klon,nwave,naero_tot), INTENT(OUT)       :: tausum_aero
+  REAL, DIMENSION(klon,klev,nwave,naero_tot), INTENT(OUT)  :: tau3d_aero
+
+  INTEGER i, k, iq, itr
+  REAL, DIMENSION(klon,klev) :: zdm, zdh
+  REAL zrho, pdel
+  !
+  ! Calculate the total mass of all soluble accumulation mode aerosols
+  ! to be revisited for AR6
+  !
+  mass_solu_aero(:,:)    = 0.0
+  mass_solu_aero_pi(:,:) = 0.0
+  !
+  itr = 0
+  DO iq = 1, nqtot
+    IF(.NOT.tracers(iq)%isInPhysics) CYCLE
+    itr = itr+1
+    IF(tracers(iq)%name/='FINE') THEN
+      mass_solu_aero(:,:)    = tr_seri(:,:,itr)
+      mass_solu_aero_pi(:,:) = tr_seri(:,:,itr)
+    ENDIF
+  ENDDO
+
+  ! Calculate layer thickness
+  DO k = 1, klev
+    DO i = 1, klon
+      pdel=paprs(i,k)-paprs(i,k+1)
+      zrho=pplay(i,k)/t_seri(i,k)/RD             ! kg/m3
+      zdh(i,k)=pdel/(RG*zrho)                    ! m
+      zdm(i,k)=pdel/RG                           ! kg/m2
+    ENDDO
+  ENDDO
+
+!--new aerosol properties
+! aeropt_6bands for rrtm
+  CALL splaeropt_6bands_rrtm(       &
+       zdm, tr_seri, rhcl,          & 
+       tau_aero, piz_aero, cg_aero )
+
+! aeropt_5wv only for validation and diagnostics
+  CALL splaeropt_5wv_rrtm(          &
+       zdm, zdh, tr_seri, rhcl,     & 
+       tausum_aero, tau3d_aero )
+
+! LW optical properties for tropospheric aerosols
+  CALL splaeropt_lw_rrtm(ok_alw,zdm,tr_seri)
+
+END SUBROUTINE splaerosol_optic_rrtm
Index: DZ6/trunk/libf/phylmd/Ocean_skin/bulk_flux_m.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/Ocean_skin/bulk_flux_m.F90	(revision 5267)
+++ 	(revision )
@@ -1,155 +1,0 @@
-module bulk_flux_m
-
-  implicit none
-
-contains
-
-  subroutine bulk_flux(tkt, tks, taur, dter, dser, t_int, s_int, ds_ns, dt_ns, &
-       u, t_ocean_1, s1, rain, hf, hlb, rnl, tau, rhoa, xlv, rf, dtime, rns)
-
-    use config_ocean_skin_m, only: jwarm, jcool, rain_effect
-    use Microlayer_m, only: Microlayer
-    use mom_flux_rain_m, only: mom_flux_rain
-    use Near_Surface_m, only: Near_Surface, depth
-    use therm_expans_m, only: therm_expans
-
-    real, intent(out):: tkt(:)
-    ! thickness of cool skin (microlayer), in m
-
-    real, intent(out):: tks(:)
-    ! thickness of mass diffusion layer (microlayer), in m
-
-    real, intent(out):: taur(:) ! momentum flux due to rain, in Pa
-
-    real, intent(out):: dter(:)
-    ! Temperature variation in the diffusive microlayer, that is
-    ! ocean-air interface temperature minus subskin temperature. In K.
-
-    real, intent(out):: dser(:)
-    ! Salinity variation in the diffusive microlayer, that is ocean-air
-    ! interface salinity minus subskin salinity. In ppt.
-
-    real, intent(out):: t_int(:) ! interface temperature, in K
-    real, intent(out):: s_int(:) ! interface salinity, in ppt
-
-    real, intent(inout):: ds_ns(:)
-    ! "delta salinity near surface". Salinity variation in the
-    ! near-surface turbulent layer. That is subskin salinity minus
-    ! foundation salinity. In ppt.
-
-    real, intent(inout):: dt_ns(:)
-    ! "delta temperature near surface". Temperature variation in the
-    ! near-surface turbulent layer. That is subskin temperature minus
-    ! foundation temperature. (Can be negative.) In K.
-
-    real, intent(in):: u(:)
-    ! Wind speed relative to the sea surface, i. e. taking current
-    ! vector into account. In m s-1.
-
-    real, intent(in):: t_ocean_1(:) ! input sea temperature, at depth_1, in K
-    real, intent(in):: S1(:) ! salinity at depth_1, in ppt
-
-    real, intent(in):: rain(:)
-    ! rain mass flux, averaged on a timestep, in kg m-2 s-1
-
-    real, intent(in):: hf(:)
-    !  turbulent part of sensible heat flux, positive upward, in W m-2
-
-    real, intent(in):: hlb(:)
-    ! latent heat flux at the surface, positive upward (W m-2)
-
-    real, intent(in):: rnl(:)
-    ! net longwave radiation, positive upward, in W m-2
-
-    real, intent(in):: tau(:)
-    ! wind stress at the surface, turbulent part only, in Pa
-    
-    real, intent(in):: rhoa(:) ! density of moist air  (kg / m3)
-    real, intent(in):: xlv(:) ! latent heat of evaporation (J / kg)
-
-    real, intent(in):: rf(:)
-    ! sensible heat flux at the surface due to rainfall, in W m-2,
-    ! positive upward
-
-    real, intent(in):: dtime ! time step, in s
-    real, intent(in):: rns(:) ! net downward shortwave radiation, in W m-2
-
-    ! Local:
-    
-    real al(size(t_ocean_1)) ! water thermal expansion coefficient (in K-1)
-    real dels(size(t_ocean_1)), null_array(size(t_ocean_1))
-    integer iter
-    real t_subskin(size(t_ocean_1)) ! subskin temperature, in K
-    real s_subskin(size(t_ocean_1)) ! subskin salinity, in ppt
-
-    real, parameter:: fxp = 1. - (0.28 * 0.014 &
-         + 0.27 * 0.357 * (1. - exp(- depth / 0.357)) &
-         + .45 * 12.82 * (1.- exp(- depth / 12.82))) / depth
-    ! underflow ! fxp = 1. - (0.28 * 0.014 * (1. - exp(- depth / 0.014)) &
-    ! Soloviev solar absorption profile
-    ! H. Bellenger 2016
-
-    real tau_with_min(size(t_ocean_1))
-    ! modified wind stress, avoiding very low values
-    
-    real, parameter:: tau_0 = 1e-3 ! in N m-2
-
-    !-------------------------------------------------------------------
-
-    if (rain_effect) then
-       taur = mom_flux_rain(u, rain)
-    else
-       if (jwarm .or. jcool) null_array = 0.
-       taur = 0.
-    end if
-
-    if (jwarm .or. jcool) tau_with_min = tau + tau_0 * (1. - exp(- tau_0 / tau))
-
-    if (Jwarm) then
-       if (rain_effect) then
-          call Near_Surface(al, t_subskin, s_subskin, ds_ns, dt_ns, &
-               tau_with_min, taur, hlb, rhoa, xlv, dtime, t_ocean_1, s1, rain, &
-               q_pwp = fxp * rns - (hf + hlb + rnl + rf))
-       else
-          call Near_Surface(al, t_subskin, s_subskin, ds_ns, dt_ns, &
-               tau_with_min, taur, hlb, rhoa, xlv, dtime, t_ocean_1, s1, &
-               rain = null_array, q_pwp = fxp * rns - (hf + hlb + rnl))
-       end if
-    else
-       if (Jcool) al = therm_expans(t_ocean_1)
-       t_subskin = t_ocean_1
-       s_subskin = s1
-    end if
-
-    if (Jcool) then
-       ! First guess:
-       tkt = 0.001
-       tks = 5e-4
-
-       do iter = 1, 3
-          ! Cool skin
-          dels = rns * (0.065 + 11. * tkt - 6.6e-5 / tkt &
-               * (1. - exp(- tkt / 8e-4))) ! equation 16 Ohlmann
-          if (rain_effect) then
-             call Microlayer(dter, dser, tkt, tks, hlb, tau_with_min, &
-                  s_subskin, al, xlv, taur, rf, rain, &
-                  qcol = rnl + hf + hlb - dels)
-          else
-             call Microlayer(dter, dser, tkt, tks, hlb, tau_with_min, &
-                  s_subskin, al, xlv, taur, rf = null_array, &
-                  rain = null_array, qcol = rnl + hf + hlb - dels)
-          end if
-       end do
-    else
-       tkt = 0.
-       tks = 0.
-       dter = 0.
-       dser = 0.
-    end if
-
-    t_int = t_subskin + dter
-    s_int = s_subskin + dser
-
-  end subroutine bulk_flux
-
-end module bulk_flux_m
Index: /LMDZ6/trunk/libf/phylmd/Ocean_skin/bulk_flux_m.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/Ocean_skin/bulk_flux_m.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/Ocean_skin/bulk_flux_m.f90	(revision 5268)
@@ -0,0 +1,155 @@
+module bulk_flux_m
+
+  implicit none
+
+contains
+
+  subroutine bulk_flux(tkt, tks, taur, dter, dser, t_int, s_int, ds_ns, dt_ns, &
+       u, t_ocean_1, s1, rain, hf, hlb, rnl, tau, rhoa, xlv, rf, dtime, rns)
+
+    use config_ocean_skin_m, only: jwarm, jcool, rain_effect
+    use Microlayer_m, only: Microlayer
+    use mom_flux_rain_m, only: mom_flux_rain
+    use Near_Surface_m, only: Near_Surface, depth
+    use therm_expans_m, only: therm_expans
+
+    real, intent(out):: tkt(:)
+    ! thickness of cool skin (microlayer), in m
+
+    real, intent(out):: tks(:)
+    ! thickness of mass diffusion layer (microlayer), in m
+
+    real, intent(out):: taur(:) ! momentum flux due to rain, in Pa
+
+    real, intent(out):: dter(:)
+    ! Temperature variation in the diffusive microlayer, that is
+    ! ocean-air interface temperature minus subskin temperature. In K.
+
+    real, intent(out):: dser(:)
+    ! Salinity variation in the diffusive microlayer, that is ocean-air
+    ! interface salinity minus subskin salinity. In ppt.
+
+    real, intent(out):: t_int(:) ! interface temperature, in K
+    real, intent(out):: s_int(:) ! interface salinity, in ppt
+
+    real, intent(inout):: ds_ns(:)
+    ! "delta salinity near surface". Salinity variation in the
+    ! near-surface turbulent layer. That is subskin salinity minus
+    ! foundation salinity. In ppt.
+
+    real, intent(inout):: dt_ns(:)
+    ! "delta temperature near surface". Temperature variation in the
+    ! near-surface turbulent layer. That is subskin temperature minus
+    ! foundation temperature. (Can be negative.) In K.
+
+    real, intent(in):: u(:)
+    ! Wind speed relative to the sea surface, i. e. taking current
+    ! vector into account. In m s-1.
+
+    real, intent(in):: t_ocean_1(:) ! input sea temperature, at depth_1, in K
+    real, intent(in):: S1(:) ! salinity at depth_1, in ppt
+
+    real, intent(in):: rain(:)
+    ! rain mass flux, averaged on a timestep, in kg m-2 s-1
+
+    real, intent(in):: hf(:)
+    !  turbulent part of sensible heat flux, positive upward, in W m-2
+
+    real, intent(in):: hlb(:)
+    ! latent heat flux at the surface, positive upward (W m-2)
+
+    real, intent(in):: rnl(:)
+    ! net longwave radiation, positive upward, in W m-2
+
+    real, intent(in):: tau(:)
+    ! wind stress at the surface, turbulent part only, in Pa
+    
+    real, intent(in):: rhoa(:) ! density of moist air  (kg / m3)
+    real, intent(in):: xlv(:) ! latent heat of evaporation (J / kg)
+
+    real, intent(in):: rf(:)
+    ! sensible heat flux at the surface due to rainfall, in W m-2,
+    ! positive upward
+
+    real, intent(in):: dtime ! time step, in s
+    real, intent(in):: rns(:) ! net downward shortwave radiation, in W m-2
+
+    ! Local:
+    
+    real al(size(t_ocean_1)) ! water thermal expansion coefficient (in K-1)
+    real dels(size(t_ocean_1)), null_array(size(t_ocean_1))
+    integer iter
+    real t_subskin(size(t_ocean_1)) ! subskin temperature, in K
+    real s_subskin(size(t_ocean_1)) ! subskin salinity, in ppt
+
+    real, parameter:: fxp = 1. - (0.28 * 0.014 &
+         + 0.27 * 0.357 * (1. - exp(- depth / 0.357)) &
+         + .45 * 12.82 * (1.- exp(- depth / 12.82))) / depth
+    ! underflow ! fxp = 1. - (0.28 * 0.014 * (1. - exp(- depth / 0.014)) &
+    ! Soloviev solar absorption profile
+    ! H. Bellenger 2016
+
+    real tau_with_min(size(t_ocean_1))
+    ! modified wind stress, avoiding very low values
+    
+    real, parameter:: tau_0 = 1e-3 ! in N m-2
+
+    !-------------------------------------------------------------------
+
+    if (rain_effect) then
+       taur = mom_flux_rain(u, rain)
+    else
+       if (jwarm .or. jcool) null_array = 0.
+       taur = 0.
+    end if
+
+    if (jwarm .or. jcool) tau_with_min = tau + tau_0 * (1. - exp(- tau_0 / tau))
+
+    if (Jwarm) then
+       if (rain_effect) then
+          call Near_Surface(al, t_subskin, s_subskin, ds_ns, dt_ns, &
+               tau_with_min, taur, hlb, rhoa, xlv, dtime, t_ocean_1, s1, rain, &
+               q_pwp = fxp * rns - (hf + hlb + rnl + rf))
+       else
+          call Near_Surface(al, t_subskin, s_subskin, ds_ns, dt_ns, &
+               tau_with_min, taur, hlb, rhoa, xlv, dtime, t_ocean_1, s1, &
+               rain = null_array, q_pwp = fxp * rns - (hf + hlb + rnl))
+       end if
+    else
+       if (Jcool) al = therm_expans(t_ocean_1)
+       t_subskin = t_ocean_1
+       s_subskin = s1
+    end if
+
+    if (Jcool) then
+       ! First guess:
+       tkt = 0.001
+       tks = 5e-4
+
+       do iter = 1, 3
+          ! Cool skin
+          dels = rns * (0.065 + 11. * tkt - 6.6e-5 / tkt &
+               * (1. - exp(- tkt / 8e-4))) ! equation 16 Ohlmann
+          if (rain_effect) then
+             call Microlayer(dter, dser, tkt, tks, hlb, tau_with_min, &
+                  s_subskin, al, xlv, taur, rf, rain, &
+                  qcol = rnl + hf + hlb - dels)
+          else
+             call Microlayer(dter, dser, tkt, tks, hlb, tau_with_min, &
+                  s_subskin, al, xlv, taur, rf = null_array, &
+                  rain = null_array, qcol = rnl + hf + hlb - dels)
+          end if
+       end do
+    else
+       tkt = 0.
+       tks = 0.
+       dter = 0.
+       dser = 0.
+    end if
+
+    t_int = t_subskin + dter
+    s_int = s_subskin + dser
+
+  end subroutine bulk_flux
+
+end module bulk_flux_m
Index: DZ6/trunk/libf/phylmd/Ocean_skin/const.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/Ocean_skin/const.F90	(revision 5267)
+++ 	(revision )
@@ -1,27 +1,0 @@
-module const
-
-  implicit none
-
-  real, parameter:: beta = 0.756 / 1023.343
-  ! Salinity expansion coefficient. Derivative with respect to
-  ! practical salinity, not mass fraction of salt. Value at 25 Celsius
-  ! degrees, zero pressure, practical salinity 35, from Gill (1982
-  ! k0829, table A.3.1).
-
-  real, parameter:: cpa = 1004.67
-  ! specific heat of dry air, in J / kg / K (Businger 1982)
-
-  real, parameter:: cpw = 4000. ! specific heat of liquid water, in J / kg / K
-  real, parameter:: grav  = 9.780326772 ! constante de gravitation, m s-2
-  real, parameter::  rhow = 1022. ! density of liquid water, in kg / m3
-
-  real, parameter:: rgas = 287.1
-  ! specific ideal gas constant for dry air, in J / kg / K
-
-  real, parameter:: von = 0.4 ! von Karman's "constant"
-
-  real, parameter:: eps_w = 0.62197
-  ! molecular mass of water over molecular mass of dry air (Gill 1982
-  ! k0829, equation 3.1.13)
-
-end module const
Index: /LMDZ6/trunk/libf/phylmd/Ocean_skin/const.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/Ocean_skin/const.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/Ocean_skin/const.f90	(revision 5268)
@@ -0,0 +1,27 @@
+module const
+
+  implicit none
+
+  real, parameter:: beta = 0.756 / 1023.343
+  ! Salinity expansion coefficient. Derivative with respect to
+  ! practical salinity, not mass fraction of salt. Value at 25 Celsius
+  ! degrees, zero pressure, practical salinity 35, from Gill (1982
+  ! k0829, table A.3.1).
+
+  real, parameter:: cpa = 1004.67
+  ! specific heat of dry air, in J / kg / K (Businger 1982)
+
+  real, parameter:: cpw = 4000. ! specific heat of liquid water, in J / kg / K
+  real, parameter:: grav  = 9.780326772 ! constante de gravitation, m s-2
+  real, parameter::  rhow = 1022. ! density of liquid water, in kg / m3
+
+  real, parameter:: rgas = 287.1
+  ! specific ideal gas constant for dry air, in J / kg / K
+
+  real, parameter:: von = 0.4 ! von Karman's "constant"
+
+  real, parameter:: eps_w = 0.62197
+  ! molecular mass of water over molecular mass of dry air (Gill 1982
+  ! k0829, equation 3.1.13)
+
+end module const
Index: DZ6/trunk/libf/phylmd/Ocean_skin/esat_m.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/Ocean_skin/esat_m.F90	(revision 5267)
+++ 	(revision )
@@ -1,22 +1,0 @@
-module esat_m
-
-  implicit none
-
-contains
-
-  elemental real function esat(T, P)
-
-    ! Saturation vapor pressure of water in Pa. Buck, 1981,
-    ! J. Appl. Meteor. 20, 1527-1532, equation (8).
-
-    real, intent(in):: T ! temperature, in K
-    real, intent(in):: P ! air pressure, in Pa
-
-    !--------------------------------------------------------------------
-
-    esat = (1.0007 + 3.46e-8 * P) * 6.1121e2 &
-         * exp(17.502 * (T - 273.15) / (T - 32.18))
-
-  end function esat
-
-end module esat_m
Index: /LMDZ6/trunk/libf/phylmd/Ocean_skin/esat_m.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/Ocean_skin/esat_m.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/Ocean_skin/esat_m.f90	(revision 5268)
@@ -0,0 +1,22 @@
+module esat_m
+
+  implicit none
+
+contains
+
+  elemental real function esat(T, P)
+
+    ! Saturation vapor pressure of water in Pa. Buck, 1981,
+    ! J. Appl. Meteor. 20, 1527-1532, equation (8).
+
+    real, intent(in):: T ! temperature, in K
+    real, intent(in):: P ! air pressure, in Pa
+
+    !--------------------------------------------------------------------
+
+    esat = (1.0007 + 3.46e-8 * P) * 6.1121e2 &
+         * exp(17.502 * (T - 273.15) / (T - 32.18))
+
+  end function esat
+
+end module esat_m
Index: DZ6/trunk/libf/phylmd/Ocean_skin/fv_m.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/Ocean_skin/fv_m.F90	(revision 5267)
+++ 	(revision )
@@ -1,46 +1,0 @@
-module fv_m
-
-  implicit none
-
-contains
-
-  elemental real function fV(z, rain)
-
-    ! H. Bellenger 2016
-
-    real, intent(in):: z ! profondeur en m (z < 0)
-    real, intent(in):: rain ! rain mass flux, in kg m-2 s-1
-
-    ! Local:
-
-    real dfV
-    ! fraction of rain volume entering the ocean and deposited within depth "z"
-
-    real rc, lbd, f0
-    real z_mm
-
-    ! Schlussel et al. 1997, Table 1:
-    real, parameter:: zeta(14) = [0.0026091, 0.0022743, 0.0015406, 0.0012281, &
-         0.0008795, 0.00077123, 0.00057451, 0.000438, 6.7228e-5, 6.4955e-5, &
-         4.4234e-5, 3.3906e-5, 2.7433e-6, 4.0283e-7]
-    real, parameter:: psi(14) = [0.60107, 0.29968, 0.5563, 1.80858, 0.2175, &
-         0.33961, 0.96368, 0.65081, 0.5967, 2.7661, 2.2812, 2.7674, 2.6095, &
-         6.5308]
-
-    !---------------------------------------------------------------------
-
-    if (rain > 0.) then
-       rc = 0.4 ! mm
-       z_mm = z * 1000. ! mm and <0
-       lbd = 4.1 * (rain * 3600.)**(- 0.21) ! mm-1
-       f0 = (1. + 2. * lbd * rc + 0.5 * (2. * lbd * rc)**2 &
-            + 1. / 6. * (2. * lbd * rc)**3) * exp(- 1. * 2. * lbd * rc)
-       dfv = sum(zeta * exp(- psi * lbd * abs(z_mm) / 100.))
-       fV = - dfV * abs(z_mm) + f0
-    else
-       fV = 0.
-    endif
-
-  end function fV
-
-end module fv_m
Index: /LMDZ6/trunk/libf/phylmd/Ocean_skin/fv_m.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/Ocean_skin/fv_m.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/Ocean_skin/fv_m.f90	(revision 5268)
@@ -0,0 +1,46 @@
+module fv_m
+
+  implicit none
+
+contains
+
+  elemental real function fV(z, rain)
+
+    ! H. Bellenger 2016
+
+    real, intent(in):: z ! profondeur en m (z < 0)
+    real, intent(in):: rain ! rain mass flux, in kg m-2 s-1
+
+    ! Local:
+
+    real dfV
+    ! fraction of rain volume entering the ocean and deposited within depth "z"
+
+    real rc, lbd, f0
+    real z_mm
+
+    ! Schlussel et al. 1997, Table 1:
+    real, parameter:: zeta(14) = [0.0026091, 0.0022743, 0.0015406, 0.0012281, &
+         0.0008795, 0.00077123, 0.00057451, 0.000438, 6.7228e-5, 6.4955e-5, &
+         4.4234e-5, 3.3906e-5, 2.7433e-6, 4.0283e-7]
+    real, parameter:: psi(14) = [0.60107, 0.29968, 0.5563, 1.80858, 0.2175, &
+         0.33961, 0.96368, 0.65081, 0.5967, 2.7661, 2.2812, 2.7674, 2.6095, &
+         6.5308]
+
+    !---------------------------------------------------------------------
+
+    if (rain > 0.) then
+       rc = 0.4 ! mm
+       z_mm = z * 1000. ! mm and <0
+       lbd = 4.1 * (rain * 3600.)**(- 0.21) ! mm-1
+       f0 = (1. + 2. * lbd * rc + 0.5 * (2. * lbd * rc)**2 &
+            + 1. / 6. * (2. * lbd * rc)**3) * exp(- 1. * 2. * lbd * rc)
+       dfv = sum(zeta * exp(- psi * lbd * abs(z_mm) / 100.))
+       fV = - dfV * abs(z_mm) + f0
+    else
+       fV = 0.
+    endif
+
+  end function fV
+
+end module fv_m
Index: DZ6/trunk/libf/phylmd/Ocean_skin/microlayer_m.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/Ocean_skin/microlayer_m.F90	(revision 5267)
+++ 	(revision )
@@ -1,106 +1,0 @@
-module Microlayer_m
-
-  Implicit none
-
-contains
-
-  subroutine Microlayer(dter, dser, tkt, tks, hlb, tau, s_subskin, al, &
-       xlv, taur, rf, rain, qcol)
-
-    ! H. Bellenger 2016
-
-    use const, only: beta, cpw, grav, rhow
-    use fv_m, only: fv
-
-    real, intent(out):: dter(:)
-    ! Temperature variation in the diffusive microlayer, that is
-    ! ocean-air interface temperature minus subskin temperature. In K.
-
-    real, intent(out):: dser(:)
-    ! Salinity variation in the diffusive microlayer, that is ocean-air
-    ! interface salinity minus subskin salinity. In ppt.
-
-    real, intent(inout):: tkt(:)
-    ! thickness of cool skin (microlayer), in m
-
-    real, intent(inout):: tks(:)
-    ! thickness of mass diffusion layer (microlayer), in m
-
-    real, intent(in):: hlb(:)
-    ! latent heat flux at the surface, positive upward (W m-2)
-
-    real, intent(in):: tau(:) ! wind stress, turbulent part only, in Pa
-    real, intent(in):: s_subskin(:) ! subskin salinity, in ppt
-    real, intent(in):: al(:) ! water thermal expansion coefficient (in K-1)
-    real, intent(in):: xlv(:) ! latent heat of evaporation (J/kg)
-    real, intent(in):: taur(:) ! momentum flux due to rainfall, in Pa
-
-    real, intent(in):: rf(:)
-    ! sensible heat flux at the surface due to rainfall, in W m-2
-
-    real, intent(in):: rain(:) ! rain mass flux, in kg m-2 s-1
-
-    real, intent(in):: qcol(:)
-    ! net flux at the surface, without sensible heat flux due to rain, in W m-2
-
-    ! Local:
-
-    real, dimension(size(qcol)):: usrk, usrct, usrcs, alq
-    real xlamx(size(qcol)) ! Saunders coefficient
-    real, parameter:: visw = 1e-6
-    real, parameter:: tcw = 0.6 ! thermal conductivity of water
-
-    real, parameter:: mu = 0.0129e-7 ! in m2 / s
-    ! molecular salinity diffusivity, Kraus and Businger, page 47
-
-    real, parameter:: kappa = 1.49e-7 ! thermal diffusivity, in m2 / s
-
-    real, parameter:: afk = 4e-4
-    real, parameter:: bfk = 1.3
-    ! a and b coefficient for the power function fitting the TKE flux 
-    ! carried by rain:  Fk = a * R**b, derived form the exact solution
-    ! of Soloviev and Lukas 2006 (Schlussel et al 1997, Craeye and
-    ! Schlussel 1998)
-
-    !--------------------------------------------------------------------------
-
-    alq = al * (qcol + rf * (1 - fV(tkt, rain))) - beta * s_subskin * cpw &
-         * (hlb / xlv - rain * (1 - fV(tks, rain)))
-
-    usrk = (afk / rhow)**(1. / 3.) * (rain * 3600.)**(bfk / 3.)
-    ! Equivalent friction velocity due to the TKE input by the penetrating
-    ! raindrops Fk
-
-    ! Friction velocities in the air:
-    usrct = sqrt((tau + (1. - fV(tkt, rain)) * taur) / rhow &
-         + (fV(0., rain) - fV(tkt, rain)) * usrk**2)
-    usrcs = sqrt((tau + (1. - fV(tks, rain)) * taur) / rhow &
-         + (fV(0., rain) - fV(tks, rain)) * usrk**2)
-
-    where (alq > 0.)
-       ! Fairall 1996 982, equation (14):
-       xlamx = 6. * (1. + (16. * grav * cpw * rhow * visw**3 * alq &
-            / (tcw**2 * usrct**4 ))**0.75)**(- 1. / 3.)
-
-       ! Fairall 1996 982, equation (12):
-       tkt = xlamx * visw / usrct
-
-       tks = xlamx * mu * (kappa / mu)**(2. / 3.) &
-            * visw * cpw * rhow / ( tcw * usrcs)
-       ! From Saunders 1967 (4)
-    elsewhere
-       xlamx = 6. ! prevent excessive warm skins
-       tkt = min(.01, xlamx * visw / usrct) ! Limit tkt
-       tks = min(.001, xlamx * mu * (kappa / mu)**(2. / 3.) * visw * cpw &
-            * rhow / (tcw * usrcs))
-    end where
-
-    ! Fairall 1996 982, equation (13):
-    dter = - (qcol + rf * (1 - fV(tkt, rain))) * tkt / tcw
-
-    dser = s_subskin * (hlb / xlv - rain * (1 - fV(tks, rain))) * tks &
-         / (rhow * mu) ! eq. fresh skin
-
-  end subroutine Microlayer
-
-end module Microlayer_m
Index: /LMDZ6/trunk/libf/phylmd/Ocean_skin/microlayer_m.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/Ocean_skin/microlayer_m.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/Ocean_skin/microlayer_m.f90	(revision 5268)
@@ -0,0 +1,106 @@
+module Microlayer_m
+
+  Implicit none
+
+contains
+
+  subroutine Microlayer(dter, dser, tkt, tks, hlb, tau, s_subskin, al, &
+       xlv, taur, rf, rain, qcol)
+
+    ! H. Bellenger 2016
+
+    use const, only: beta, cpw, grav, rhow
+    use fv_m, only: fv
+
+    real, intent(out):: dter(:)
+    ! Temperature variation in the diffusive microlayer, that is
+    ! ocean-air interface temperature minus subskin temperature. In K.
+
+    real, intent(out):: dser(:)
+    ! Salinity variation in the diffusive microlayer, that is ocean-air
+    ! interface salinity minus subskin salinity. In ppt.
+
+    real, intent(inout):: tkt(:)
+    ! thickness of cool skin (microlayer), in m
+
+    real, intent(inout):: tks(:)
+    ! thickness of mass diffusion layer (microlayer), in m
+
+    real, intent(in):: hlb(:)
+    ! latent heat flux at the surface, positive upward (W m-2)
+
+    real, intent(in):: tau(:) ! wind stress, turbulent part only, in Pa
+    real, intent(in):: s_subskin(:) ! subskin salinity, in ppt
+    real, intent(in):: al(:) ! water thermal expansion coefficient (in K-1)
+    real, intent(in):: xlv(:) ! latent heat of evaporation (J/kg)
+    real, intent(in):: taur(:) ! momentum flux due to rainfall, in Pa
+
+    real, intent(in):: rf(:)
+    ! sensible heat flux at the surface due to rainfall, in W m-2
+
+    real, intent(in):: rain(:) ! rain mass flux, in kg m-2 s-1
+
+    real, intent(in):: qcol(:)
+    ! net flux at the surface, without sensible heat flux due to rain, in W m-2
+
+    ! Local:
+
+    real, dimension(size(qcol)):: usrk, usrct, usrcs, alq
+    real xlamx(size(qcol)) ! Saunders coefficient
+    real, parameter:: visw = 1e-6
+    real, parameter:: tcw = 0.6 ! thermal conductivity of water
+
+    real, parameter:: mu = 0.0129e-7 ! in m2 / s
+    ! molecular salinity diffusivity, Kraus and Businger, page 47
+
+    real, parameter:: kappa = 1.49e-7 ! thermal diffusivity, in m2 / s
+
+    real, parameter:: afk = 4e-4
+    real, parameter:: bfk = 1.3
+    ! a and b coefficient for the power function fitting the TKE flux 
+    ! carried by rain:  Fk = a * R**b, derived form the exact solution
+    ! of Soloviev and Lukas 2006 (Schlussel et al 1997, Craeye and
+    ! Schlussel 1998)
+
+    !--------------------------------------------------------------------------
+
+    alq = al * (qcol + rf * (1 - fV(tkt, rain))) - beta * s_subskin * cpw &
+         * (hlb / xlv - rain * (1 - fV(tks, rain)))
+
+    usrk = (afk / rhow)**(1. / 3.) * (rain * 3600.)**(bfk / 3.)
+    ! Equivalent friction velocity due to the TKE input by the penetrating
+    ! raindrops Fk
+
+    ! Friction velocities in the air:
+    usrct = sqrt((tau + (1. - fV(tkt, rain)) * taur) / rhow &
+         + (fV(0., rain) - fV(tkt, rain)) * usrk**2)
+    usrcs = sqrt((tau + (1. - fV(tks, rain)) * taur) / rhow &
+         + (fV(0., rain) - fV(tks, rain)) * usrk**2)
+
+    where (alq > 0.)
+       ! Fairall 1996 982, equation (14):
+       xlamx = 6. * (1. + (16. * grav * cpw * rhow * visw**3 * alq &
+            / (tcw**2 * usrct**4 ))**0.75)**(- 1. / 3.)
+
+       ! Fairall 1996 982, equation (12):
+       tkt = xlamx * visw / usrct
+
+       tks = xlamx * mu * (kappa / mu)**(2. / 3.) &
+            * visw * cpw * rhow / ( tcw * usrcs)
+       ! From Saunders 1967 (4)
+    elsewhere
+       xlamx = 6. ! prevent excessive warm skins
+       tkt = min(.01, xlamx * visw / usrct) ! Limit tkt
+       tks = min(.001, xlamx * mu * (kappa / mu)**(2. / 3.) * visw * cpw &
+            * rhow / (tcw * usrcs))
+    end where
+
+    ! Fairall 1996 982, equation (13):
+    dter = - (qcol + rf * (1 - fV(tkt, rain))) * tkt / tcw
+
+    dser = s_subskin * (hlb / xlv - rain * (1 - fV(tks, rain))) * tks &
+         / (rhow * mu) ! eq. fresh skin
+
+  end subroutine Microlayer
+
+end module Microlayer_m
Index: DZ6/trunk/libf/phylmd/Ocean_skin/mom_flux_rain_m.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/Ocean_skin/mom_flux_rain_m.F90	(revision 5267)
+++ 	(revision )
@@ -1,24 +1,0 @@
-module mom_flux_rain_m
-
-  implicit none
-
-contains
-
-  elemental real function mom_flux_rain(u, rain)
-
-    ! Computes momentum flux due to rainfall, in Pa.
-
-    real, intent(in):: U
-    ! difference of velocity between air and sea, including gustiness, in m / s
-
-    real, intent(in):: rain ! rain mass flux, in kg m-2 s-1
-
-    !------------------------------------------------------------------------
-
-    mom_flux_rain = 0.85 * U * rain
-    ! (Caldwell 1971 k1001, equation (1) and 15 % reduction in speed
-    ! as in paragraph 3.a, maybe adequate if u is the wind at 10 m)
-
-  end function mom_flux_rain
-  
-end module mom_flux_rain_m
Index: /LMDZ6/trunk/libf/phylmd/Ocean_skin/mom_flux_rain_m.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/Ocean_skin/mom_flux_rain_m.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/Ocean_skin/mom_flux_rain_m.f90	(revision 5268)
@@ -0,0 +1,24 @@
+module mom_flux_rain_m
+
+  implicit none
+
+contains
+
+  elemental real function mom_flux_rain(u, rain)
+
+    ! Computes momentum flux due to rainfall, in Pa.
+
+    real, intent(in):: U
+    ! difference of velocity between air and sea, including gustiness, in m / s
+
+    real, intent(in):: rain ! rain mass flux, in kg m-2 s-1
+
+    !------------------------------------------------------------------------
+
+    mom_flux_rain = 0.85 * U * rain
+    ! (Caldwell 1971 k1001, equation (1) and 15 % reduction in speed
+    ! as in paragraph 3.a, maybe adequate if u is the wind at 10 m)
+
+  end function mom_flux_rain
+  
+end module mom_flux_rain_m
Index: DZ6/trunk/libf/phylmd/Ocean_skin/near_surface_m.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/Ocean_skin/near_surface_m.F90	(revision 5267)
+++ 	(revision )
@@ -1,156 +1,0 @@
-module Near_Surface_m
-
-  Implicit none
-
-  real, parameter:: depth = 3.
-  ! diurnal warm layer and fresh water lens depth, in m (Zeng and Beljaars 2005)
-
-contains
-
-  subroutine near_surface(al, t_subskin, s_subskin, ds_ns, dt_ns, tau, taur, &
-       hlb, rhoa, xlv, dtime, t_ocean_1, s1, rain, q_pwp)
-
-    ! Hugo Bellenger, 2016
-
-    use config_ocean_skin_m, only: depth_1
-    use const, only: beta, cpw, grav, rhow, von
-    use Phiw_m, only: Phiw
-    use therm_expans_m, only: therm_expans
-
-    real, intent(out):: al(:) ! water thermal expansion coefficient (in K-1)
-    real, intent(out):: t_subskin(:) ! subskin temperature, in K
-    real, intent(out):: s_subskin(:) ! subskin salinity, in ppt
-
-    real, intent(inout):: ds_ns(:)
-    ! "delta salinity near surface". Salinity variation in the
-    ! near-surface turbulent layer. That is subskin salinity minus
-    ! foundation salinity. In ppt.
-
-    real, intent(inout):: dt_ns(:)
-    ! "delta temperature near surface". Temperature variation in the
-    ! near-surface turbulent layer. That is subskin temperature minus
-    ! foundation temperature. (Can be negative.) In K.
-
-    real, intent(in):: tau(:)
-    ! wind stress at the surface, turbulent part only, in Pa
-
-    real, intent(in):: taur(:) ! momentum flux due to rainfall, in Pa
-    real, intent(in):: hlb(:) ! latent heat flux, turbulent part only, in W / m2
-    real, intent(in):: rhoa(:) ! density of moist air  (kg / m3)
-    real, intent(in):: xlv(:) ! latent heat of evaporation (J/kg)
-    real, intent(in):: dtime ! time step (s)
-    real, intent(in):: t_ocean_1(:) ! input sea temperature, at depth_1, in K
-    real, intent(in):: S1(:) ! salinity at depth_1, in ppt
-    real, intent(in):: rain(:) ! rain mass flux, in kg m-2 s-1
-
-    real, intent(in):: q_pwp(:)
-    ! net flux absorbed by the warm layer (part of the solar flux
-    ! absorbed at "depth"), minus surface fluxes, in W m-2
-
-    ! Local:
-
-    real, parameter:: khor = 1. / 1.5e4
-    ! Parameter for the lens spread, in m-1. Inverse of the size of
-    ! the lens.
-
-    real, parameter:: umax = 15.
-    real, parameter:: fact = 1.
-    real buoyf(size(t_ocean_1)) ! buoyancy flux
-    real usrc(size(t_ocean_1))
-    real drho(size(t_ocean_1)) ! rho(- delta) - rho(- d)
-    real Lmo(size(t_ocean_1)) ! Monin-Obukhov length
-
-    real u(size(t_ocean_1))
-    ! Wind speed at 15 m relative to the sea surface, i. e. taking
-    ! current vector into account. In m s-1.
-
-    real, dimension(size(t_ocean_1)):: At, Bt, As, Bs, correction
-
-    real eta(size(t_ocean_1))
-    ! exponent in the function giving T(z) and S(z), equation (11) in
-    ! Bellenger et al. 2017 JGR
-
-    real t_fnd(size(t_ocean_1)) ! foundation temperature, in K
-    real s_fnd(size(t_ocean_1)) ! foundation salinity, in ppt
-
-    !----------------------------------------------------------------------
-
-    ! Temperature and salinity profiles change with wind:
-
-    u = 28. * sqrt(tau / rhoa)
-
-    where (dt_ns < 0.)
-       where (u >= umax)
-          eta = 1. / fact
-       elsewhere (u <= 2.)
-          eta = 2. / (fact * umax)
-       elsewhere
-          ! {u > 2. .and. u < umax}
-          eta = u / (fact * umax)
-       end where
-    elsewhere
-       eta = 0.3
-    end where
-
-    if (depth_1 < depth) then
-       correction = 1. - (depth_1 / depth)**eta
-       ! (neglecting microlayer thickness compared to depth_1 and depth)
-
-       t_fnd = t_ocean_1 - dt_ns * correction
-       s_fnd = s1 - ds_ns * correction
-    else
-       t_fnd = t_ocean_1
-       s_fnd = s1
-    end if
-
-    al = therm_expans(t_fnd)
-
-    ! Bellenger 2017 k0976, equation (13):
-    buoyf = Al * grav / (rhow * cpw) * q_pwp &
-         - beta * S_FND * grav * (hlb / xlv - rain) / rhow
-
-    usrc = sqrt((tau + taur) / rhow)
-    drho = rhow * (- al * dt_ns + beta * ds_ns)
-
-    ! Case of stable stratification and negative flux, Bellenger 2017
-    ! k0976, equation (15):
-    where (buoyf < 0. .and. drho < 0.)
-       buoyf = sqrt(- eta * grav / (5. * depth * rhow) * drho) * usrc**2
-    elsewhere (buoyf == 0.)
-       buoyf = tiny(0.)
-    end where
-       
-
-    Lmo = usrc**3 / (von * buoyf)
-
-    ! Equation (14) for temperature. Implicit scheme for time integration:
-    ! \Delta T_{i + 1} - \Delta T_i = \delta t (Bt + At \Delta T_{i + 1})
-    At = - (eta + 1.) * von * usrc / (depth * Phiw(depth / Lmo))
-
-    ! Lens horizontal spreading:
-    where (drho < 0. .and. ds_ns < 0.) At = At &
-         - (eta + 1.) * khor * sqrt(depth * grav * abs(drho) / rhow)
-
-    Bt = q_pwp / (depth * rhow * cpw * eta / (eta + 1.))
-    dt_ns = (dtime * Bt + dt_ns) / (1 - dtime * At)
-
-    ! Equation (14) for salinity:
-    ! \frac{\partial \Delta S}{\partial t}
-    ! = (\Delta S + S_\mathrm{fnd}) B_S + A_S \Delta S
-    As = - (eta + 1.) * von * usrc / (depth * Phiw(depth / Lmo))
-
-    ! Lens horizontal spreading:
-    where (drho < 0. .and. ds_ns < 0.) As = As &
-         - (eta + 1.) * khor * sqrt(depth * grav * abs(drho) / rhow)
-
-    Bs = (hlb / xlv - rain) * (eta + 1.) / (depth * rhow * eta)
-
-    ! Implicit scheme for time integration:
-    ds_ns = (dtime * Bs * S_fnd + ds_ns) / (1 - dtime * (As + bs))
-
-    t_subskin = t_fnd + dt_ns
-    s_subskin = s_fnd + ds_ns
-
-  end subroutine Near_Surface
-
-end module Near_Surface_m
Index: /LMDZ6/trunk/libf/phylmd/Ocean_skin/near_surface_m.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/Ocean_skin/near_surface_m.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/Ocean_skin/near_surface_m.f90	(revision 5268)
@@ -0,0 +1,156 @@
+module Near_Surface_m
+
+  Implicit none
+
+  real, parameter:: depth = 3.
+  ! diurnal warm layer and fresh water lens depth, in m (Zeng and Beljaars 2005)
+
+contains
+
+  subroutine near_surface(al, t_subskin, s_subskin, ds_ns, dt_ns, tau, taur, &
+       hlb, rhoa, xlv, dtime, t_ocean_1, s1, rain, q_pwp)
+
+    ! Hugo Bellenger, 2016
+
+    use config_ocean_skin_m, only: depth_1
+    use const, only: beta, cpw, grav, rhow, von
+    use Phiw_m, only: Phiw
+    use therm_expans_m, only: therm_expans
+
+    real, intent(out):: al(:) ! water thermal expansion coefficient (in K-1)
+    real, intent(out):: t_subskin(:) ! subskin temperature, in K
+    real, intent(out):: s_subskin(:) ! subskin salinity, in ppt
+
+    real, intent(inout):: ds_ns(:)
+    ! "delta salinity near surface". Salinity variation in the
+    ! near-surface turbulent layer. That is subskin salinity minus
+    ! foundation salinity. In ppt.
+
+    real, intent(inout):: dt_ns(:)
+    ! "delta temperature near surface". Temperature variation in the
+    ! near-surface turbulent layer. That is subskin temperature minus
+    ! foundation temperature. (Can be negative.) In K.
+
+    real, intent(in):: tau(:)
+    ! wind stress at the surface, turbulent part only, in Pa
+
+    real, intent(in):: taur(:) ! momentum flux due to rainfall, in Pa
+    real, intent(in):: hlb(:) ! latent heat flux, turbulent part only, in W / m2
+    real, intent(in):: rhoa(:) ! density of moist air  (kg / m3)
+    real, intent(in):: xlv(:) ! latent heat of evaporation (J/kg)
+    real, intent(in):: dtime ! time step (s)
+    real, intent(in):: t_ocean_1(:) ! input sea temperature, at depth_1, in K
+    real, intent(in):: S1(:) ! salinity at depth_1, in ppt
+    real, intent(in):: rain(:) ! rain mass flux, in kg m-2 s-1
+
+    real, intent(in):: q_pwp(:)
+    ! net flux absorbed by the warm layer (part of the solar flux
+    ! absorbed at "depth"), minus surface fluxes, in W m-2
+
+    ! Local:
+
+    real, parameter:: khor = 1. / 1.5e4
+    ! Parameter for the lens spread, in m-1. Inverse of the size of
+    ! the lens.
+
+    real, parameter:: umax = 15.
+    real, parameter:: fact = 1.
+    real buoyf(size(t_ocean_1)) ! buoyancy flux
+    real usrc(size(t_ocean_1))
+    real drho(size(t_ocean_1)) ! rho(- delta) - rho(- d)
+    real Lmo(size(t_ocean_1)) ! Monin-Obukhov length
+
+    real u(size(t_ocean_1))
+    ! Wind speed at 15 m relative to the sea surface, i. e. taking
+    ! current vector into account. In m s-1.
+
+    real, dimension(size(t_ocean_1)):: At, Bt, As, Bs, correction
+
+    real eta(size(t_ocean_1))
+    ! exponent in the function giving T(z) and S(z), equation (11) in
+    ! Bellenger et al. 2017 JGR
+
+    real t_fnd(size(t_ocean_1)) ! foundation temperature, in K
+    real s_fnd(size(t_ocean_1)) ! foundation salinity, in ppt
+
+    !----------------------------------------------------------------------
+
+    ! Temperature and salinity profiles change with wind:
+
+    u = 28. * sqrt(tau / rhoa)
+
+    where (dt_ns < 0.)
+       where (u >= umax)
+          eta = 1. / fact
+       elsewhere (u <= 2.)
+          eta = 2. / (fact * umax)
+       elsewhere
+          ! {u > 2. .and. u < umax}
+          eta = u / (fact * umax)
+       end where
+    elsewhere
+       eta = 0.3
+    end where
+
+    if (depth_1 < depth) then
+       correction = 1. - (depth_1 / depth)**eta
+       ! (neglecting microlayer thickness compared to depth_1 and depth)
+
+       t_fnd = t_ocean_1 - dt_ns * correction
+       s_fnd = s1 - ds_ns * correction
+    else
+       t_fnd = t_ocean_1
+       s_fnd = s1
+    end if
+
+    al = therm_expans(t_fnd)
+
+    ! Bellenger 2017 k0976, equation (13):
+    buoyf = Al * grav / (rhow * cpw) * q_pwp &
+         - beta * S_FND * grav * (hlb / xlv - rain) / rhow
+
+    usrc = sqrt((tau + taur) / rhow)
+    drho = rhow * (- al * dt_ns + beta * ds_ns)
+
+    ! Case of stable stratification and negative flux, Bellenger 2017
+    ! k0976, equation (15):
+    where (buoyf < 0. .and. drho < 0.)
+       buoyf = sqrt(- eta * grav / (5. * depth * rhow) * drho) * usrc**2
+    elsewhere (buoyf == 0.)
+       buoyf = tiny(0.)
+    end where
+       
+
+    Lmo = usrc**3 / (von * buoyf)
+
+    ! Equation (14) for temperature. Implicit scheme for time integration:
+    ! \Delta T_{i + 1} - \Delta T_i = \delta t (Bt + At \Delta T_{i + 1})
+    At = - (eta + 1.) * von * usrc / (depth * Phiw(depth / Lmo))
+
+    ! Lens horizontal spreading:
+    where (drho < 0. .and. ds_ns < 0.) At = At &
+         - (eta + 1.) * khor * sqrt(depth * grav * abs(drho) / rhow)
+
+    Bt = q_pwp / (depth * rhow * cpw * eta / (eta + 1.))
+    dt_ns = (dtime * Bt + dt_ns) / (1 - dtime * At)
+
+    ! Equation (14) for salinity:
+    ! \frac{\partial \Delta S}{\partial t}
+    ! = (\Delta S + S_\mathrm{fnd}) B_S + A_S \Delta S
+    As = - (eta + 1.) * von * usrc / (depth * Phiw(depth / Lmo))
+
+    ! Lens horizontal spreading:
+    where (drho < 0. .and. ds_ns < 0.) As = As &
+         - (eta + 1.) * khor * sqrt(depth * grav * abs(drho) / rhow)
+
+    Bs = (hlb / xlv - rain) * (eta + 1.) / (depth * rhow * eta)
+
+    ! Implicit scheme for time integration:
+    ds_ns = (dtime * Bs * S_fnd + ds_ns) / (1 - dtime * (As + bs))
+
+    t_subskin = t_fnd + dt_ns
+    s_subskin = s_fnd + ds_ns
+
+  end subroutine Near_Surface
+
+end module Near_Surface_m
Index: DZ6/trunk/libf/phylmd/Ocean_skin/phiw_m.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/Ocean_skin/phiw_m.F90	(revision 5267)
+++ 	(revision )
@@ -1,24 +1,0 @@
-module Phiw_m
-
-  implicit none
-
-contains
-
-  elemental real function Phiw(zL)
-
-    ! Fonction de stabilit\'e (Monin Obukhov)
-
-    real, intent(in):: zL ! profondeur  / longueur de Monin-Obukhov
-
-    !----------------------------------------------
-
-    if (zL < 0.) then
-       Phiw = (1. - 16. * zL)**(- 0.5)
-    else
-       Phiw = 1. + (5. * zL + 4. * zL**2)/(1. + 3. * zL + 0.25 * zL**2)
-       ! (Takaya et al. 2010)
-    end if
-
-  end function Phiw
-
-end module Phiw_m
Index: /LMDZ6/trunk/libf/phylmd/Ocean_skin/phiw_m.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/Ocean_skin/phiw_m.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/Ocean_skin/phiw_m.f90	(revision 5268)
@@ -0,0 +1,24 @@
+module Phiw_m
+
+  implicit none
+
+contains
+
+  elemental real function Phiw(zL)
+
+    ! Fonction de stabilit\'e (Monin Obukhov)
+
+    real, intent(in):: zL ! profondeur  / longueur de Monin-Obukhov
+
+    !----------------------------------------------
+
+    if (zL < 0.) then
+       Phiw = (1. - 16. * zL)**(- 0.5)
+    else
+       Phiw = 1. + (5. * zL + 4. * zL**2)/(1. + 3. * zL + 0.25 * zL**2)
+       ! (Takaya et al. 2010)
+    end if
+
+  end function Phiw
+
+end module Phiw_m
Index: DZ6/trunk/libf/phylmd/Ocean_skin/therm_expans_m.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/Ocean_skin/therm_expans_m.F90	(revision 5267)
+++ 	(revision )
@@ -1,19 +1,0 @@
-module therm_expans_m
-
-  implicit none
-
-contains
-
-  elemental real function therm_expans(t)
-
-    ! Compute the thermal expansion coefficient of sea water.
-
-    real, intent(in):: t ! temperature, in K
-
-    !--------------------------------------------------------------
-
-    therm_expans = 2.1e-5 * (t - 269.95)**0.79
-
-  end function therm_expans
-
-end module therm_expans_m
Index: /LMDZ6/trunk/libf/phylmd/Ocean_skin/therm_expans_m.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/Ocean_skin/therm_expans_m.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/Ocean_skin/therm_expans_m.f90	(revision 5268)
@@ -0,0 +1,19 @@
+module therm_expans_m
+
+  implicit none
+
+contains
+
+  elemental real function therm_expans(t)
+
+    ! Compute the thermal expansion coefficient of sea water.
+
+    real, intent(in):: t ! temperature, in K
+
+    !--------------------------------------------------------------
+
+    therm_expans = 2.1e-5 * (t - 269.95)**0.79
+
+  end function therm_expans
+
+end module therm_expans_m
Index: DZ6/trunk/libf/phylmd/StratAer/aer_sedimnt.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/StratAer/aer_sedimnt.F90	(revision 5267)
+++ 	(revision )
@@ -1,140 +1,0 @@
-!
-! $Id$
-!
-SUBROUTINE AER_SEDIMNT(pdtphys, t_seri, pplay, paprs, tr_seri, dens_aer)
-
-!**** *AER_SEDIMNT* -  ROUTINE FOR PARAMETRIZATION OF AEROSOL SEDIMENTATION
-
-!      Christoph Kleinschmitt
-!      based on the sedimentation scheme of
-!      Olivier Boucher & Jean-Jacques Morcrette 
-!      (following the ice sedimentation scheme of Adrian Tompkins)
-
-!**   INTERFACE.
-!     ----------
-!          *AER_SEDIMNT* IS CALLED FROM *traccoag_mod*.
-
-!-----------------------------------------------------------------------
-
-  USE phys_local_var_mod, ONLY: mdw, budg_sed_part, DENSO4, DENSO4B, f_r_wet, f_r_wetB, vsed_aer
-  USE strataer_local_var_mod, ONLY: flag_new_strat_compo
-  USE dimphy, ONLY : klon,klev
-  USE infotrac_phy
-  USE aerophys
-  USE yomcst_mod_h
-
-IMPLICIT NONE
-
-!-----------------------------------------------------------------------
-
-  ! transfer variables when calling this routine
-  REAL,INTENT(IN)                             :: pdtphys ! Pas d'integration pour la physique (seconde)
-  REAL,DIMENSION(klon,klev),INTENT(IN)        :: t_seri  ! Temperature
-  REAL,DIMENSION(klon,klev),INTENT(IN)        :: pplay   ! pression pour le mileu de chaque couche (en Pa)
-  REAL,DIMENSION(klon,klev+1),INTENT(IN)      :: paprs   ! pression pour chaque inter-couche (en Pa)
-  REAL,DIMENSION(klon,klev,nbtr),INTENT(INOUT):: tr_seri ! Concentration Traceur [U/KgA]
-  REAL,DIMENSION(klon,klev)                   :: dens_aer! density of aerosol particles [kg/m3 aerosol] with default H2SO4 mass
-
-  ! local variables in sedimentation routine
-  INTEGER :: JL,JK,nb    
-  REAL,DIMENSION(klon,klev)                   :: zvis     ! dynamic viscosity of air [kg/(m*s)]
-  REAL,DIMENSION(klon,klev)                   :: zlair    ! mean free path of air [m]
-  REAL                                        :: ZRHO     ! air density [kg/m^3]
-  REAL                                        :: ZGDP     ! =g/dp=1/(rho*dz)
-  REAL                                        :: ZDTGDP   ! =dt/(rho*dz)
-  REAL,DIMENSION(klon,nbtr_bin)               :: ZSEDFLX  ! sedimentation flux of tracer [U/(m^2*s)]
-  REAL,DIMENSION(nbtr_bin)                    :: ZAERONW  ! tracer concentration at current time step [U/KgA]
-  REAL,DIMENSION(klon,nbtr_bin)               :: ZAERONWM1! tracer concentration at preceding time step [U/KgA]
-  REAL,DIMENSION(klon,klev,nbtr_bin)          :: ZVAER    ! sedimentation velocity [m/s]
-  REAL,DIMENSION(nbtr_bin)                    :: ZSOLAERS ! sedimentation flux arriving from above [U/(m^2*s)]
-  REAL,DIMENSION(nbtr_bin)                    :: ZSOLAERB ! sedimentation flux leaving gridbox [U/(m^2*s)]
-  REAL,DIMENSION(klon,klev)                   :: m_sulf
-
-! dynamic viscosity of air (Pruppacher and Klett, 1978) [kg/(m*s)]
-WHERE (t_seri.GE.273.15)
-  zvis=(1.718 + 0.0049*(t_seri-273.15))*1.E-5
-  ELSEWHERE
-  zvis=(1.718 + 0.0049*(t_seri-273.15)-1.2E-05*(t_seri-273.15)**2)*1.E-5
-END WHERE
-
-! mean free path of air (Prupp. Klett) [m]
-zlair(:,:) = 0.066 *(1.01325E+5/pplay(:,:))*(t_seri(:,:)/293.15)*1.E-06
-
-!--initialisations of variables carried out from one layer to the next layer
-!--actually not needed if (JK>1) test is on
-DO JL=1,klon
-  DO nb=1,nbtr_bin
-    ZSEDFLX(JL,nb)=0.0
-    ZAERONWM1(JL,nb)=0.0
-  ENDDO
-ENDDO
-
-!--from top to bottom (!)
-DO JK=klev,1,-1
-  DO JL=1,klon
-    DO nb=1,nbtr_bin
-  !--initialisations
-      ZSOLAERS(nb)=0.0
-      ZSOLAERB(nb)=0.0
-      ZGDP=RG/(paprs(JL,JK)-paprs(JL,JK+1))
-      ZDTGDP=pdtphys*ZGDP
-
-  ! source from above
-      IF (JK<klev) THEN 
-        ZSEDFLX(JL,nb)=ZSEDFLX(JL,nb)*ZAERONWM1(JL,nb)  
-        ZSOLAERS(nb)=ZSOLAERS(nb)+ZSEDFLX(JL,nb)*ZDTGDP
-      ENDIF
-
-  ! sink to next layer
-      ZRHO=pplay(JL,JK)/(RD*t_seri(JL,JK))
-
-      ! stokes-velocity with cunnigham slip- flow correction
-      IF(flag_new_strat_compo) THEN
-         ! stokes-velocity with cunnigham slip- flow correction
-         ZVAER(JL,JK,nb) = 2./9.*(DENSO4B(JL,JK,nb)*1000.-ZRHO)*RG/zvis(JL,JK)*(f_r_wetB(JL,JK,nb)*mdw(nb)/2.)**2.* &
-              (1.+ 2.*zlair(JL,JK)/(f_r_wetB(JL,JK,nb)*mdw(nb))*(1.257+0.4*EXP(-0.55*f_r_wetB(JL,JK,nb)*mdw(nb)/zlair(JL,JK))))
-      ELSE
-         ZVAER(JL,JK,nb) = 2./9.*(DENSO4(JL,JK)*1000.-ZRHO)*RG/zvis(JL,JK)*(f_r_wet(JL,JK)*mdw(nb)/2.)**2.* &
-              (1.+ 2.*zlair(JL,JK)/(f_r_wet(JL,JK)*mdw(nb))*(1.257+0.4*EXP(-0.55*f_r_wet(JL,JK)*mdw(nb)/zlair(JL,JK))))
-      ENDIF
-      
-      ZSEDFLX(JL,nb)=ZVAER(JL,JK,nb)*ZRHO
-      ZSOLAERB(nb)=ZSOLAERB(nb)+ZDTGDP*ZSEDFLX(JL,nb)
-
-  !---implicit solver
-      ZAERONW(nb)=(tr_seri(JL,JK,nb+nbtr_sulgas)+ZSOLAERS(nb))/(1.0+ZSOLAERB(nb))
-
-  !---new time-step AER variable needed for next layer
-      ZAERONWM1(JL,nb)=ZAERONW(nb)
-
-      tr_seri(JL,JK,nb+nbtr_sulgas)=ZAERONWM1(JL,nb)
-    ENDDO
-  ENDDO
-ENDDO
-
-!---sedimentation flux to the surface
-!---ZAERONWM1 now contains the surface concentration at the new timestep
-!---PFLUXAER in unit of xx m-2 s-1 
-budg_sed_part(:)=0.0
-DO JL=1,klon
-  ZRHO=pplay(JL,1)/(RD*t_seri(JL,1))
-  DO nb=1,nbtr_bin
-    !compute budg_sed_part as sum over bins in kg(S)/m2/s
-    budg_sed_part(JL)=budg_sed_part(JL)+ZRHO*ZAERONWM1(JL,nb)*ZVAER(JL,1,nb)*(mSatom/mH2SO4mol) &
-                & *dens_aer_dry*4./3.*RPI*(mdw(nb)/2.)**3
-  ENDDO
-ENDDO
-
-vsed_aer(:,:)=0.0
-m_sulf(:,:)=0.0
-
-DO nb=1,nbtr_bin
-  !compute mass-weighted mean of sedimentation velocity
-  vsed_aer(:,:)=vsed_aer(:,:)+ZVAER(:,:,nb)*(mdw(nb)/2.)**3*MAX(1.e-30, tr_seri(:,:,nb+nbtr_sulgas))
-  m_sulf(:,:)=m_sulf(:,:)+(mdw(nb)/2.)**3*MAX(1.e-30, tr_seri(:,:,nb+nbtr_sulgas))
-ENDDO
-
-!divide by total aerosol mass in grid cell
-vsed_aer(:,:)=vsed_aer(:,:)/m_sulf(:,:)
-
-END SUBROUTINE AER_SEDIMNT
Index: /LMDZ6/trunk/libf/phylmd/StratAer/aer_sedimnt.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/StratAer/aer_sedimnt.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/StratAer/aer_sedimnt.f90	(revision 5268)
@@ -0,0 +1,140 @@
+!
+! $Id$
+!
+SUBROUTINE AER_SEDIMNT(pdtphys, t_seri, pplay, paprs, tr_seri, dens_aer)
+
+!**** *AER_SEDIMNT* -  ROUTINE FOR PARAMETRIZATION OF AEROSOL SEDIMENTATION
+
+!      Christoph Kleinschmitt
+!      based on the sedimentation scheme of
+!      Olivier Boucher & Jean-Jacques Morcrette 
+!      (following the ice sedimentation scheme of Adrian Tompkins)
+
+!**   INTERFACE.
+!     ----------
+!          *AER_SEDIMNT* IS CALLED FROM *traccoag_mod*.
+
+!-----------------------------------------------------------------------
+
+  USE phys_local_var_mod, ONLY: mdw, budg_sed_part, DENSO4, DENSO4B, f_r_wet, f_r_wetB, vsed_aer
+  USE strataer_local_var_mod, ONLY: flag_new_strat_compo
+  USE dimphy, ONLY : klon,klev
+  USE infotrac_phy
+  USE aerophys
+  USE yomcst_mod_h
+
+IMPLICIT NONE
+
+!-----------------------------------------------------------------------
+
+  ! transfer variables when calling this routine
+  REAL,INTENT(IN)                             :: pdtphys ! Pas d'integration pour la physique (seconde)
+  REAL,DIMENSION(klon,klev),INTENT(IN)        :: t_seri  ! Temperature
+  REAL,DIMENSION(klon,klev),INTENT(IN)        :: pplay   ! pression pour le mileu de chaque couche (en Pa)
+  REAL,DIMENSION(klon,klev+1),INTENT(IN)      :: paprs   ! pression pour chaque inter-couche (en Pa)
+  REAL,DIMENSION(klon,klev,nbtr),INTENT(INOUT):: tr_seri ! Concentration Traceur [U/KgA]
+  REAL,DIMENSION(klon,klev)                   :: dens_aer! density of aerosol particles [kg/m3 aerosol] with default H2SO4 mass
+
+  ! local variables in sedimentation routine
+  INTEGER :: JL,JK,nb    
+  REAL,DIMENSION(klon,klev)                   :: zvis     ! dynamic viscosity of air [kg/(m*s)]
+  REAL,DIMENSION(klon,klev)                   :: zlair    ! mean free path of air [m]
+  REAL                                        :: ZRHO     ! air density [kg/m^3]
+  REAL                                        :: ZGDP     ! =g/dp=1/(rho*dz)
+  REAL                                        :: ZDTGDP   ! =dt/(rho*dz)
+  REAL,DIMENSION(klon,nbtr_bin)               :: ZSEDFLX  ! sedimentation flux of tracer [U/(m^2*s)]
+  REAL,DIMENSION(nbtr_bin)                    :: ZAERONW  ! tracer concentration at current time step [U/KgA]
+  REAL,DIMENSION(klon,nbtr_bin)               :: ZAERONWM1! tracer concentration at preceding time step [U/KgA]
+  REAL,DIMENSION(klon,klev,nbtr_bin)          :: ZVAER    ! sedimentation velocity [m/s]
+  REAL,DIMENSION(nbtr_bin)                    :: ZSOLAERS ! sedimentation flux arriving from above [U/(m^2*s)]
+  REAL,DIMENSION(nbtr_bin)                    :: ZSOLAERB ! sedimentation flux leaving gridbox [U/(m^2*s)]
+  REAL,DIMENSION(klon,klev)                   :: m_sulf
+
+! dynamic viscosity of air (Pruppacher and Klett, 1978) [kg/(m*s)]
+WHERE (t_seri.GE.273.15)
+  zvis=(1.718 + 0.0049*(t_seri-273.15))*1.E-5
+  ELSEWHERE
+  zvis=(1.718 + 0.0049*(t_seri-273.15)-1.2E-05*(t_seri-273.15)**2)*1.E-5
+END WHERE
+
+! mean free path of air (Prupp. Klett) [m]
+zlair(:,:) = 0.066 *(1.01325E+5/pplay(:,:))*(t_seri(:,:)/293.15)*1.E-06
+
+!--initialisations of variables carried out from one layer to the next layer
+!--actually not needed if (JK>1) test is on
+DO JL=1,klon
+  DO nb=1,nbtr_bin
+    ZSEDFLX(JL,nb)=0.0
+    ZAERONWM1(JL,nb)=0.0
+  ENDDO
+ENDDO
+
+!--from top to bottom (!)
+DO JK=klev,1,-1
+  DO JL=1,klon
+    DO nb=1,nbtr_bin
+  !--initialisations
+      ZSOLAERS(nb)=0.0
+      ZSOLAERB(nb)=0.0
+      ZGDP=RG/(paprs(JL,JK)-paprs(JL,JK+1))
+      ZDTGDP=pdtphys*ZGDP
+
+  ! source from above
+      IF (JK<klev) THEN 
+        ZSEDFLX(JL,nb)=ZSEDFLX(JL,nb)*ZAERONWM1(JL,nb)  
+        ZSOLAERS(nb)=ZSOLAERS(nb)+ZSEDFLX(JL,nb)*ZDTGDP
+      ENDIF
+
+  ! sink to next layer
+      ZRHO=pplay(JL,JK)/(RD*t_seri(JL,JK))
+
+      ! stokes-velocity with cunnigham slip- flow correction
+      IF(flag_new_strat_compo) THEN
+         ! stokes-velocity with cunnigham slip- flow correction
+         ZVAER(JL,JK,nb) = 2./9.*(DENSO4B(JL,JK,nb)*1000.-ZRHO)*RG/zvis(JL,JK)*(f_r_wetB(JL,JK,nb)*mdw(nb)/2.)**2.* &
+              (1.+ 2.*zlair(JL,JK)/(f_r_wetB(JL,JK,nb)*mdw(nb))*(1.257+0.4*EXP(-0.55*f_r_wetB(JL,JK,nb)*mdw(nb)/zlair(JL,JK))))
+      ELSE
+         ZVAER(JL,JK,nb) = 2./9.*(DENSO4(JL,JK)*1000.-ZRHO)*RG/zvis(JL,JK)*(f_r_wet(JL,JK)*mdw(nb)/2.)**2.* &
+              (1.+ 2.*zlair(JL,JK)/(f_r_wet(JL,JK)*mdw(nb))*(1.257+0.4*EXP(-0.55*f_r_wet(JL,JK)*mdw(nb)/zlair(JL,JK))))
+      ENDIF
+      
+      ZSEDFLX(JL,nb)=ZVAER(JL,JK,nb)*ZRHO
+      ZSOLAERB(nb)=ZSOLAERB(nb)+ZDTGDP*ZSEDFLX(JL,nb)
+
+  !---implicit solver
+      ZAERONW(nb)=(tr_seri(JL,JK,nb+nbtr_sulgas)+ZSOLAERS(nb))/(1.0+ZSOLAERB(nb))
+
+  !---new time-step AER variable needed for next layer
+      ZAERONWM1(JL,nb)=ZAERONW(nb)
+
+      tr_seri(JL,JK,nb+nbtr_sulgas)=ZAERONWM1(JL,nb)
+    ENDDO
+  ENDDO
+ENDDO
+
+!---sedimentation flux to the surface
+!---ZAERONWM1 now contains the surface concentration at the new timestep
+!---PFLUXAER in unit of xx m-2 s-1 
+budg_sed_part(:)=0.0
+DO JL=1,klon
+  ZRHO=pplay(JL,1)/(RD*t_seri(JL,1))
+  DO nb=1,nbtr_bin
+    !compute budg_sed_part as sum over bins in kg(S)/m2/s
+    budg_sed_part(JL)=budg_sed_part(JL)+ZRHO*ZAERONWM1(JL,nb)*ZVAER(JL,1,nb)*(mSatom/mH2SO4mol) &
+                & *dens_aer_dry*4./3.*RPI*(mdw(nb)/2.)**3
+  ENDDO
+ENDDO
+
+vsed_aer(:,:)=0.0
+m_sulf(:,:)=0.0
+
+DO nb=1,nbtr_bin
+  !compute mass-weighted mean of sedimentation velocity
+  vsed_aer(:,:)=vsed_aer(:,:)+ZVAER(:,:,nb)*(mdw(nb)/2.)**3*MAX(1.e-30, tr_seri(:,:,nb+nbtr_sulgas))
+  m_sulf(:,:)=m_sulf(:,:)+(mdw(nb)/2.)**3*MAX(1.e-30, tr_seri(:,:,nb+nbtr_sulgas))
+ENDDO
+
+!divide by total aerosol mass in grid cell
+vsed_aer(:,:)=vsed_aer(:,:)/m_sulf(:,:)
+
+END SUBROUTINE AER_SEDIMNT
Index: DZ6/trunk/libf/phylmd/StratAer/aerophys.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/StratAer/aerophys.F90	(revision 5267)
+++ 	(revision )
@@ -1,32 +1,0 @@
-! $Id$
-!
-MODULE aerophys
-!
-  IMPLICIT NONE
-!
-  REAL,PARAMETER    :: ropx=1500.0              ! default aerosol particle mass density [kg/m3]
-  REAL,PARAMETER    :: dens_aer_dry=1848.682308 ! dry aerosol particle mass density at T_0=293K[kg/m3]
-  REAL,PARAMETER    :: dens_aer_ref=1483.905336 ! aerosol particle mass density with 75% H2SO4 at T_0=293K[kg/m3]
-  REAL,PARAMETER    :: mdwmin=0.002e-6          ! dry diameter of smallest aerosol particles [m]
-  REAL,PARAMETER    :: V_rat=2.0                ! volume ratio of neighboring size bins
-  REAL,PARAMETER    :: mfrac_H2SO4=0.75         ! default mass fraction of H2SO4 in the aerosol
-  REAL, PARAMETER   :: mAIRmol=28.949*1.66E-27  ! Average mass of an air molecule [kg]
-  REAL, PARAMETER   :: mH2Omol=18.016*1.66E-27  ! Mass of an H2O molecule [kg]
-  REAL, PARAMETER   :: mH2SO4mol=98.082*1.66E-27! Mass of an H2SO4 molecule [kg]
-  REAL, PARAMETER   :: mSO2mol=64.06*1.66E-27   ! Mass of an SO2 molecule [kg]
-  REAL, PARAMETER   :: mSatom=32.06*1.66E-27    ! Mass of a S atom [kg]
-  REAL, PARAMETER   :: mOCSmol=60.07*1.66E-27   ! Mass of an OCS molecule [kg]
-  REAL, PARAMETER   :: mClatom=35.45*1.66E-27   ! Mass of an Cl atom [kg]
-  REAL, PARAMETER   :: mHClmol=36.46*1.66E-27   ! Mass of an HCl molecule [kg]
-  REAL, PARAMETER   :: mBratom=79.90*1.66E-27   ! Mass of an Br atom [kg]
-  REAL, PARAMETER   :: mHBrmol=80.92*1.66E-27   ! Mass of an HBr molecule [kg]
-  REAL, PARAMETER   :: mNOmol=30.01*1.66E-27    ! Mass of an NO molecule [kg]
-  REAL, PARAMETER   :: mNO2mol=46.01*1.66E-27   ! Mass of an NO2 molecule [kg]
-  REAL, PARAMETER   :: mNatome=14.0067*1.66E-27 ! Mass of an N atome [kg]
-  REAL, PARAMETER   :: rgas=8.3145 ! molar gas cste (J⋅K−1⋅mol−1=m3⋅Pa⋅K−1⋅mol−1=kg⋅m2⋅s−2⋅K−1⋅mol−1)
-  ! 
-  REAL, PARAMETER   :: MH2O  =1000.*mH2Omol     ! Mass of 1 molec [g] (18.016*1.66E-24)
-  REAL, PARAMETER   :: MH2SO4=1000.*mH2SO4mol   ! Mass of 1 molec [g] (98.082*1.66E-24)
-  REAL, PARAMETER   :: BOLZ  =1.381E-16         ! Boltzmann constant [dyn.cm/K]
-!
-END MODULE aerophys
Index: /LMDZ6/trunk/libf/phylmd/StratAer/aerophys.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/StratAer/aerophys.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/StratAer/aerophys.f90	(revision 5268)
@@ -0,0 +1,32 @@
+! $Id$
+!
+MODULE aerophys
+!
+  IMPLICIT NONE
+!
+  REAL,PARAMETER    :: ropx=1500.0              ! default aerosol particle mass density [kg/m3]
+  REAL,PARAMETER    :: dens_aer_dry=1848.682308 ! dry aerosol particle mass density at T_0=293K[kg/m3]
+  REAL,PARAMETER    :: dens_aer_ref=1483.905336 ! aerosol particle mass density with 75% H2SO4 at T_0=293K[kg/m3]
+  REAL,PARAMETER    :: mdwmin=0.002e-6          ! dry diameter of smallest aerosol particles [m]
+  REAL,PARAMETER    :: V_rat=2.0                ! volume ratio of neighboring size bins
+  REAL,PARAMETER    :: mfrac_H2SO4=0.75         ! default mass fraction of H2SO4 in the aerosol
+  REAL, PARAMETER   :: mAIRmol=28.949*1.66E-27  ! Average mass of an air molecule [kg]
+  REAL, PARAMETER   :: mH2Omol=18.016*1.66E-27  ! Mass of an H2O molecule [kg]
+  REAL, PARAMETER   :: mH2SO4mol=98.082*1.66E-27! Mass of an H2SO4 molecule [kg]
+  REAL, PARAMETER   :: mSO2mol=64.06*1.66E-27   ! Mass of an SO2 molecule [kg]
+  REAL, PARAMETER   :: mSatom=32.06*1.66E-27    ! Mass of a S atom [kg]
+  REAL, PARAMETER   :: mOCSmol=60.07*1.66E-27   ! Mass of an OCS molecule [kg]
+  REAL, PARAMETER   :: mClatom=35.45*1.66E-27   ! Mass of an Cl atom [kg]
+  REAL, PARAMETER   :: mHClmol=36.46*1.66E-27   ! Mass of an HCl molecule [kg]
+  REAL, PARAMETER   :: mBratom=79.90*1.66E-27   ! Mass of an Br atom [kg]
+  REAL, PARAMETER   :: mHBrmol=80.92*1.66E-27   ! Mass of an HBr molecule [kg]
+  REAL, PARAMETER   :: mNOmol=30.01*1.66E-27    ! Mass of an NO molecule [kg]
+  REAL, PARAMETER   :: mNO2mol=46.01*1.66E-27   ! Mass of an NO2 molecule [kg]
+  REAL, PARAMETER   :: mNatome=14.0067*1.66E-27 ! Mass of an N atome [kg]
+  REAL, PARAMETER   :: rgas=8.3145 ! molar gas cste (J⋅K−1⋅mol−1=m3⋅Pa⋅K−1⋅mol−1=kg⋅m2⋅s−2⋅K−1⋅mol−1)
+  ! 
+  REAL, PARAMETER   :: MH2O  =1000.*mH2Omol     ! Mass of 1 molec [g] (18.016*1.66E-24)
+  REAL, PARAMETER   :: MH2SO4=1000.*mH2SO4mol   ! Mass of 1 molec [g] (98.082*1.66E-24)
+  REAL, PARAMETER   :: BOLZ  =1.381E-16         ! Boltzmann constant [dyn.cm/K]
+!
+END MODULE aerophys
Index: DZ6/trunk/libf/phylmd/StratAer/calcaerosolstrato_rrtm.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/StratAer/calcaerosolstrato_rrtm.F90	(revision 5267)
+++ 	(revision )
@@ -1,122 +1,0 @@
-!
-! $Id$
-!
-SUBROUTINE calcaerosolstrato_rrtm(pplay,t_seri,paprs,debut)
-
-  USE phys_state_var_mod, ONLY: tau_aero_sw_rrtm, piz_aero_sw_rrtm, cg_aero_sw_rrtm, tau_aero_lw_rrtm
-  USE phys_local_var_mod, ONLY: mdw, tausum_aero, tausum_strat, tau_strat_550, tau_strat_1020, stratomask
-  USE aero_mod
-  USE dimphy
-  USE temps_mod
-  USE yomcst_mod_h
-
-  IMPLICIT NONE
-
-  INCLUDE "dimensions.h"
-  INCLUDE "clesphys.h"
-  INCLUDE "paramet.h"
-  INCLUDE "iniprint.h"
-
-! Variable input
-  REAL,DIMENSION(klon,klev),INTENT(IN)   :: t_seri  ! Temperature
-  REAL,DIMENSION(klon,klev),INTENT(IN)   :: pplay   ! pression pour le mileu de chaque couche (en Pa)
-  LOGICAL,INTENT(IN)                     :: debut   ! le flag de l'initialisation de la physique
-  REAL,DIMENSION(klon,klev+1),INTENT(IN) :: paprs   ! pression pour chaque inter-couche (en Pa)
-
-! Stratospheric aerosols optical properties
-  REAL, DIMENSION(klon,klev,nbands_sw_rrtm) :: tau_strat, piz_strat, cg_strat
-  REAL, DIMENSION(klon,klev,nwave_sw+nwave_lw) :: tau_strat_wave
-  REAL, DIMENSION(klon,klev,nbands_lw_rrtm) :: tau_lw_abs_rrtm
-
-  INTEGER k, band, wave, i
-  REAL zrho, zdz
-
-!--calculate optical properties of the aerosol size distribution from tr_seri
-  tau_strat=0.0
-  piz_strat=0.0
-  cg_strat=0.0
-  tau_strat_wave=0.0
-  tau_lw_abs_rrtm=0.0
-
-  CALL miecalc_aer(tau_strat, piz_strat, cg_strat, tau_strat_wave, tau_lw_abs_rrtm, paprs, debut)
-
-!!--test CK: deactivate radiative effect of aerosol
-!  tau_strat=0.0
-!  piz_strat=0.0
-!  cg_strat=0.0
-!  tau_strat_wave=0.0
-!  tau_lw_abs_rrtm=0.0
-
-!--test CK: deactivate SW radiative effect of aerosol (but leave LW)
-!  tau_strat=0.0
-!  piz_strat=0.0
-!  cg_strat=0.0
-
-!  DO wave=1, nwave_sw
-!  tau_strat_wave(:,:,wave)=0.0
-!  ENDDO
-
-!--test CK: deactivate LW radiative effect of aerosol (but leave SW)
-!  tau_lw_abs_rrtm=0.0
-
-!  DO wave=nwave_sw+1, nwave_sw+nwave_lw
-!  tau_strat_wave(:,:,wave)=0.0
-!  ENDDO
-
-!--total vertical aod at the 5 SW + 1 LW wavelengths
-  DO wave=1, nwave_sw+nwave_lw
-    DO k=1, klev
-      tausum_aero(:,wave,id_STRAT_phy)=tausum_aero(:,wave,id_STRAT_phy)+tau_strat_wave(:,k,wave)
-    ENDDO
-  ENDDO
-
-!--weighted average for cg, piz and tau, adding strat aerosols on top of tropospheric ones
-  DO band=1, nbands_sw_rrtm
-    !--no stratospheric aerosol in index 1
-    cg_aero_sw_rrtm(:,:,1,band)  =  cg_aero_sw_rrtm(:,:,2,band)
-    piz_aero_sw_rrtm(:,:,1,band)  = piz_aero_sw_rrtm(:,:,2,band)
-    tau_aero_sw_rrtm(:,:,1,band)  = tau_aero_sw_rrtm(:,:,2,band)
-
-    !--tropospheric and stratospheric aerosol in index 2
-    cg_aero_sw_rrtm(:,:,2,band) = ( cg_aero_sw_rrtm(:,:,2,band)*piz_aero_sw_rrtm(:,:,2,band)*tau_aero_sw_rrtm(:,:,2,band) + &
-                                cg_strat(:,:,band)*piz_strat(:,:,band)*tau_strat(:,:,band) ) /                              &
-                                MAX( piz_aero_sw_rrtm(:,:,2,band)*tau_aero_sw_rrtm(:,:,2,band) +                            &
-                                piz_strat(:,:,band)*tau_strat(:,:,band), 1.e-15 )
-    piz_aero_sw_rrtm(:,:,2,band)= ( piz_aero_sw_rrtm(:,:,2,band)*tau_aero_sw_rrtm(:,:,2,band) +                             &
-                                piz_strat(:,:,band)*tau_strat(:,:,band) ) /                                                 &
-                                MAX( tau_aero_sw_rrtm(:,:,2,band) + tau_strat(:,:,band), 1.e-15 )
-    tau_aero_sw_rrtm(:,:,2,band)= tau_aero_sw_rrtm(:,:,2,band) + tau_strat(:,:,band)
-  ENDDO
-
-  DO band=1, nbands_lw_rrtm
-    !--no stratospheric aerosols in index 1
-    tau_aero_lw_rrtm(:,:,1,band)  = tau_aero_lw_rrtm(:,:,2,band)
-    !--tropospheric and stratospheric aerosol in index 2
-    tau_aero_lw_rrtm(:,:,2,band)  = tau_aero_lw_rrtm(:,:,2,band) + tau_lw_abs_rrtm(:,:,band) 
-  ENDDO
-
-  WHERE (tau_aero_sw_rrtm .LT. 1.e-14) piz_aero_sw_rrtm=1.0
-  WHERE (tau_aero_sw_rrtm .LT. 1.e-14) tau_aero_sw_rrtm=1.e-15
-  WHERE (tau_aero_lw_rrtm .LT. 1.e-14) tau_aero_lw_rrtm=1.e-15
-
-  tausum_strat(:,:)=0.0
-  DO i=1,klon
-  DO k=1,klev
-    IF (stratomask(i,k).GT.0.5) THEN
-      tausum_strat(i,1)=tausum_strat(i,1)+tau_strat_wave(i,k,2)  !--550 nm
-      tausum_strat(i,2)=tausum_strat(i,2)+tau_strat_wave(i,k,5)  !--1020 nm
-      tausum_strat(i,3)=tausum_strat(i,3)+tau_strat_wave(i,k,6)  !--10 um
-    ENDIF
-  ENDDO
-  ENDDO
-
-  DO i=1,klon
-  DO k=1,klev
-    zrho=pplay(i,k)/t_seri(i,k)/RD            !air density in kg/m3
-    zdz=(paprs(i,k)-paprs(i,k+1))/zrho/RG     !thickness of layer in m
-    tau_strat_550(i,k)=tau_strat_wave(i,k,2)/zdz
-    tau_strat_1020(i,k)=tau_strat_wave(i,k,5)/zdz
-  ENDDO
-  ENDDO
-
-END SUBROUTINE calcaerosolstrato_rrtm
Index: /LMDZ6/trunk/libf/phylmd/StratAer/calcaerosolstrato_rrtm.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/StratAer/calcaerosolstrato_rrtm.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/StratAer/calcaerosolstrato_rrtm.f90	(revision 5268)
@@ -0,0 +1,122 @@
+!
+! $Id$
+!
+SUBROUTINE calcaerosolstrato_rrtm(pplay,t_seri,paprs,debut)
+
+  USE phys_state_var_mod, ONLY: tau_aero_sw_rrtm, piz_aero_sw_rrtm, cg_aero_sw_rrtm, tau_aero_lw_rrtm
+  USE phys_local_var_mod, ONLY: mdw, tausum_aero, tausum_strat, tau_strat_550, tau_strat_1020, stratomask
+  USE aero_mod
+  USE dimphy
+  USE temps_mod
+  USE yomcst_mod_h
+
+  IMPLICIT NONE
+
+  INCLUDE "dimensions.h"
+  INCLUDE "clesphys.h"
+  INCLUDE "paramet.h"
+  INCLUDE "iniprint.h"
+
+! Variable input
+  REAL,DIMENSION(klon,klev),INTENT(IN)   :: t_seri  ! Temperature
+  REAL,DIMENSION(klon,klev),INTENT(IN)   :: pplay   ! pression pour le mileu de chaque couche (en Pa)
+  LOGICAL,INTENT(IN)                     :: debut   ! le flag de l'initialisation de la physique
+  REAL,DIMENSION(klon,klev+1),INTENT(IN) :: paprs   ! pression pour chaque inter-couche (en Pa)
+
+! Stratospheric aerosols optical properties
+  REAL, DIMENSION(klon,klev,nbands_sw_rrtm) :: tau_strat, piz_strat, cg_strat
+  REAL, DIMENSION(klon,klev,nwave_sw+nwave_lw) :: tau_strat_wave
+  REAL, DIMENSION(klon,klev,nbands_lw_rrtm) :: tau_lw_abs_rrtm
+
+  INTEGER k, band, wave, i
+  REAL zrho, zdz
+
+!--calculate optical properties of the aerosol size distribution from tr_seri
+  tau_strat=0.0
+  piz_strat=0.0
+  cg_strat=0.0
+  tau_strat_wave=0.0
+  tau_lw_abs_rrtm=0.0
+
+  CALL miecalc_aer(tau_strat, piz_strat, cg_strat, tau_strat_wave, tau_lw_abs_rrtm, paprs, debut)
+
+!!--test CK: deactivate radiative effect of aerosol
+!  tau_strat=0.0
+!  piz_strat=0.0
+!  cg_strat=0.0
+!  tau_strat_wave=0.0
+!  tau_lw_abs_rrtm=0.0
+
+!--test CK: deactivate SW radiative effect of aerosol (but leave LW)
+!  tau_strat=0.0
+!  piz_strat=0.0
+!  cg_strat=0.0
+
+!  DO wave=1, nwave_sw
+!  tau_strat_wave(:,:,wave)=0.0
+!  ENDDO
+
+!--test CK: deactivate LW radiative effect of aerosol (but leave SW)
+!  tau_lw_abs_rrtm=0.0
+
+!  DO wave=nwave_sw+1, nwave_sw+nwave_lw
+!  tau_strat_wave(:,:,wave)=0.0
+!  ENDDO
+
+!--total vertical aod at the 5 SW + 1 LW wavelengths
+  DO wave=1, nwave_sw+nwave_lw
+    DO k=1, klev
+      tausum_aero(:,wave,id_STRAT_phy)=tausum_aero(:,wave,id_STRAT_phy)+tau_strat_wave(:,k,wave)
+    ENDDO
+  ENDDO
+
+!--weighted average for cg, piz and tau, adding strat aerosols on top of tropospheric ones
+  DO band=1, nbands_sw_rrtm
+    !--no stratospheric aerosol in index 1
+    cg_aero_sw_rrtm(:,:,1,band)  =  cg_aero_sw_rrtm(:,:,2,band)
+    piz_aero_sw_rrtm(:,:,1,band)  = piz_aero_sw_rrtm(:,:,2,band)
+    tau_aero_sw_rrtm(:,:,1,band)  = tau_aero_sw_rrtm(:,:,2,band)
+
+    !--tropospheric and stratospheric aerosol in index 2
+    cg_aero_sw_rrtm(:,:,2,band) = ( cg_aero_sw_rrtm(:,:,2,band)*piz_aero_sw_rrtm(:,:,2,band)*tau_aero_sw_rrtm(:,:,2,band) + &
+                                cg_strat(:,:,band)*piz_strat(:,:,band)*tau_strat(:,:,band) ) /                              &
+                                MAX( piz_aero_sw_rrtm(:,:,2,band)*tau_aero_sw_rrtm(:,:,2,band) +                            &
+                                piz_strat(:,:,band)*tau_strat(:,:,band), 1.e-15 )
+    piz_aero_sw_rrtm(:,:,2,band)= ( piz_aero_sw_rrtm(:,:,2,band)*tau_aero_sw_rrtm(:,:,2,band) +                             &
+                                piz_strat(:,:,band)*tau_strat(:,:,band) ) /                                                 &
+                                MAX( tau_aero_sw_rrtm(:,:,2,band) + tau_strat(:,:,band), 1.e-15 )
+    tau_aero_sw_rrtm(:,:,2,band)= tau_aero_sw_rrtm(:,:,2,band) + tau_strat(:,:,band)
+  ENDDO
+
+  DO band=1, nbands_lw_rrtm
+    !--no stratospheric aerosols in index 1
+    tau_aero_lw_rrtm(:,:,1,band)  = tau_aero_lw_rrtm(:,:,2,band)
+    !--tropospheric and stratospheric aerosol in index 2
+    tau_aero_lw_rrtm(:,:,2,band)  = tau_aero_lw_rrtm(:,:,2,band) + tau_lw_abs_rrtm(:,:,band) 
+  ENDDO
+
+  WHERE (tau_aero_sw_rrtm .LT. 1.e-14) piz_aero_sw_rrtm=1.0
+  WHERE (tau_aero_sw_rrtm .LT. 1.e-14) tau_aero_sw_rrtm=1.e-15
+  WHERE (tau_aero_lw_rrtm .LT. 1.e-14) tau_aero_lw_rrtm=1.e-15
+
+  tausum_strat(:,:)=0.0
+  DO i=1,klon
+  DO k=1,klev
+    IF (stratomask(i,k).GT.0.5) THEN
+      tausum_strat(i,1)=tausum_strat(i,1)+tau_strat_wave(i,k,2)  !--550 nm
+      tausum_strat(i,2)=tausum_strat(i,2)+tau_strat_wave(i,k,5)  !--1020 nm
+      tausum_strat(i,3)=tausum_strat(i,3)+tau_strat_wave(i,k,6)  !--10 um
+    ENDIF
+  ENDDO
+  ENDDO
+
+  DO i=1,klon
+  DO k=1,klev
+    zrho=pplay(i,k)/t_seri(i,k)/RD            !air density in kg/m3
+    zdz=(paprs(i,k)-paprs(i,k+1))/zrho/RG     !thickness of layer in m
+    tau_strat_550(i,k)=tau_strat_wave(i,k,2)/zdz
+    tau_strat_1020(i,k)=tau_strat_wave(i,k,5)/zdz
+  ENDDO
+  ENDDO
+
+END SUBROUTINE calcaerosolstrato_rrtm
Index: DZ6/trunk/libf/phylmd/StratAer/coagulate.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/StratAer/coagulate.F90	(revision 5267)
+++ 	(revision )
@@ -1,292 +1,0 @@
-!
-! $Id$
-!
-SUBROUTINE COAGULATE(pdtcoag,mdw,tr_seri,t_seri,pplay,dens_aer,is_strato)
-  !     -----------------------------------------------------------------------
-  !
-  !     Author : Christoph Kleinschmitt (with Olivier Boucher)
-  !     ------
-  !
-  !     purpose
-  !     -------
-  !
-  !     interface
-  !     ---------
-  !      input 
-  !       pdtphys        time step duration                 [sec]
-  !       tr_seri        tracer mixing ratios               [kg/kg]
-  !       mdw             # or mass median diameter          [m]
-  !
-  !     method
-  !     ------
-  !
-  !     -----------------------------------------------------------------------
-
-  USE dimphy, ONLY : klon,klev
-  USE aerophys
-  USE infotrac_phy
-  USE phys_local_var_mod, ONLY: DENSO4, DENSO4B, f_r_wet, f_r_wetB
-  USE strataer_local_var_mod, ONLY: flag_new_strat_compo
-  
-  IMPLICIT NONE
-
-  !--------------------------------------------------------
-
-  ! transfer variables when calling this routine
-  REAL,INTENT(IN)                               :: pdtcoag ! Time step in coagulation routine [s]
-  REAL,DIMENSION(nbtr_bin),INTENT(IN)           :: mdw     ! aerosol particle diameter in each bin [m]
-  REAL,DIMENSION(klon,klev,nbtr),INTENT(INOUT)  :: tr_seri ! Concentration Traceur [U/KgA]
-  REAL,DIMENSION(klon,klev),INTENT(IN)          :: t_seri  ! Temperature
-  REAL,DIMENSION(klon,klev),INTENT(IN)          :: pplay   ! pression pour le mileu de chaque couche (en Pa)
-  REAL,DIMENSION(klon,klev)                     :: dens_aer! density of aerosol [kg/m3 aerosol] with default H2SO4 mass
-  LOGICAL,DIMENSION(klon,klev),INTENT(IN)       :: is_strato
-
-  ! local variables in coagulation routine
-  INTEGER                                       :: i,j,k,nb,ilon,ilev
-  REAL, DIMENSION(nbtr_bin)                     :: radiusdry ! dry aerosol particle radius in each bin [m]
-  REAL, DIMENSION(nbtr_bin)                     :: radiuswet ! wet aerosol particle radius in each bin [m]
-  REAL, DIMENSION(klon,klev,nbtr_bin)           :: tr_t ! Concentration Traceur at time t [U/KgA]
-  REAL, DIMENSION(klon,klev,nbtr_bin)           :: tr_tp1 ! Concentration Traceur at time t+1 [U/KgA]
-  REAL, DIMENSION(nbtr_bin,nbtr_bin,nbtr_bin)   :: ff   ! Volume fraction of intermediate particles
-  REAL, DIMENSION(nbtr_bin)                     :: Vdry ! Volume dry of bins
-  REAL, DIMENSION(nbtr_bin)                     :: Vwet ! Volume wet of bins
-  REAL, DIMENSION(nbtr_bin,nbtr_bin)            :: Vij  ! Volume sum of i and j
-  REAL                                          :: eta  ! Dynamic viscosity of air
-  REAL, PARAMETER                               :: mair=4.8097E-26 ! Average mass of an air molecule [kg]
-  REAL                                          :: zrho ! Density of air
-  REAL                                          :: mnfrpth ! Mean free path of air
-  REAL, DIMENSION(nbtr_bin)                     :: Kn   ! Knudsen number of particle i
-  REAL, DIMENSION(nbtr_bin)                     :: Di   ! Particle diffusion coefficient
-  REAL, DIMENSION(nbtr_bin)                     :: m_par   ! Mass of particle i
-  REAL, DIMENSION(nbtr_bin)                     :: thvelpar! Thermal velocity of particle i
-  REAL, DIMENSION(nbtr_bin)                     :: mfppar  ! Mean free path of particle i
-  REAL, DIMENSION(nbtr_bin)                     :: delta! delta of particle i (from equation 21)
-  REAL, DIMENSION(nbtr_bin,nbtr_bin)            :: beta ! Coagulation kernel from Brownian diffusion
-  REAL                                          :: beta_const ! Constant coagulation kernel (for comparison)
-  REAL                                          :: num
-  REAL                                          :: numi
-  REAL                                          :: denom
-
-  ! Additional variables for coagulation enhancement factor due to van der Waals forces
-  ! Taken from Chan and Mozurkewich, Measurement of the coagulation rate constant for sulfuric acid 
-  ! particles as a function of particle size using TDMA, Aerosol Science, 32, 321-339, 2001.
-  !--ok_vdw is 0 for no vdW forces, 1 for E(0), 2 for E(infinity)
-  INTEGER, PARAMETER                            :: ok_vdw = 0
-  REAL, PARAMETER                               :: avdW1 = 0.0757
-  REAL, PARAMETER                               :: avdW3 = 0.0015
-  REAL, PARAMETER                               :: bvdW0 = 0.0151
-  REAL, PARAMETER                               :: bvdW1 = -0.186
-  REAL, PARAMETER                               :: bvdW3 = -0.0163
-  REAL, PARAMETER                               :: AvdW = 6.4e-20 !Hamaker constant in J = 1e7 erg
-  REAL                                          :: AvdWi
-  REAL                                          :: xvdW
-  REAL                                          :: EvdW
-
-  include "YOMCST.h"
-
-! ff(i,j,k): Volume fraction of Vi,j that is partitioned to each model bin k
-! just need to be calculated in model initialization because mdw(:) size is fixed
-! no need to recalculate radius, Vdry, Vij, and ff every timestep because it is for  
-! dry aerosols
-  DO i=1, nbtr_bin
-     radiusdry(i)=mdw(i)/2.
-     Vdry(i)=radiusdry(i)**3.  !neglecting factor 4*RPI/3
-     Vwet(i)=0.0
-  ENDDO
-
-  DO j=1, nbtr_bin
-     DO i=1, nbtr_bin
-        Vij(i,j)= Vdry(i)+Vdry(j)
-     ENDDO
-  ENDDO
-  
-!--pre-compute the f(i,j,k) from Jacobson equation 13
-  ff=0.0 
-  DO k=1, nbtr_bin 
-  DO j=1, nbtr_bin
-  DO i=1, nbtr_bin
-    IF (k.EQ.1) THEN
-      ff(i,j,k)= 0.0
-    ELSEIF (k.GT.1.AND.Vdry(k-1).LT.Vij(i,j).AND.Vij(i,j).LT.Vdry(k)) THEN
-      ff(i,j,k)= 1.-ff(i,j,k-1)
-    ELSEIF (k.EQ.nbtr_bin) THEN
-      IF (Vij(i,j).GE.Vdry(k)) THEN
-        ff(i,j,k)= 1.
-      ELSE
-        ff(i,j,k)= 0.0
-      ENDIF
-    ELSEIF (k.LE.(nbtr_bin-1).AND.Vdry(k).LE.Vij(i,j).AND.Vij(i,j).LT.Vdry(k+1)) THEN
-      ff(i,j,k)= Vdry(k)/Vij(i,j)*(Vdry(k+1)-Vij(i,j))/(Vdry(k+1)-Vdry(k))
-    ENDIF
-  ENDDO
-  ENDDO
-  ENDDO
-! End of just need to be calculated at initialization because mdw(:) size is fixed
-  
-  DO ilon=1, klon
-  DO ilev=1, klev 
-  !only in the stratosphere
-  IF (is_strato(ilon,ilev)) THEN
-  !compute actual wet particle radius & volume for every grid box
-  IF(flag_new_strat_compo) THEN
-     DO i=1, nbtr_bin
-        radiuswet(i)=f_r_wetB(ilon,ilev,i)*mdw(i)/2.
-        Vwet(i)= radiuswet(i)**3.  !neglecting factor 4*RPI/3
-!!      Vwet(i)= Vdry(i)*(f_r_wetB(ilon,ilev,i)**3)
-     ENDDO
-  ELSE
-     DO i=1, nbtr_bin
-        radiuswet(i)=f_r_wet(ilon,ilev)*mdw(i)/2.
-        Vwet(i)= radiuswet(i)**3.  !neglecting factor 4*RPI/3
-!!      Vwet(i)= Vdry(i)*(f_r_wet(ilon,ilev)**3)
-     ENDDO
-  ENDIF
-  
-!--Calculations for the coagulation kernel---------------------------------------------------------
-
-  zrho=pplay(ilon,ilev)/t_seri(ilon,ilev)/RD
-
-!--initialize the tracer at time t and convert from [number/KgA] to [number/m3]
-  DO i=1, nbtr_bin
-  tr_t(ilon,ilev,i) = tr_seri(ilon,ilev,i+nbtr_sulgas) * zrho
-  ENDDO
-
-  ! mean free path of air (Pruppacher and Klett, 2010, p.417) [m]
-  mnfrpth=6.6E-8*(1.01325E+5/pplay(ilon,ilev))*(t_seri(ilon,ilev)/293.15)
-  ! mnfrpth=2.*eta/(zrho*thvelair)
-  ! mean free path of air (Prupp. Klett) in [10^-6 m]
-  ! ZLAIR = 0.066 *(1.01325E+5/PPLAY)*(T_SERI/293.15)*1.E-06
-
-  ! dynamic viscosity of air (Pruppacher and Klett, 2010, p.417) [kg/(m*s)]
-  IF (t_seri(ilon,ilev).GE.273.15) THEN
-    eta=(1.718+0.0049*(t_seri(ilon,ilev)-273.15))*1.E-5
-  ELSE
-    eta=(1.718+0.0049*(t_seri(ilon,ilev)-273.15)-1.2E-5*(t_seri(ilon,ilev)-273.15)**2)*1.E-5
-  ENDIF
-
-!--pre-compute the particle diffusion coefficient Di(i) from equation 18
-  Di=0.0
-  DO i=1, nbtr_bin
-      Kn(i)=mnfrpth/radiuswet(i)
-      Di(i)=RKBOL*t_seri(ilon,ilev)/(6.*RPI*radiuswet(i)*eta)*(1.+Kn(i)*(1.249+0.42*exp(-0.87/Kn(i))))
-  ENDDO
-
-!--pre-compute the thermal velocity of a particle thvelpar(i) from equation 20
-  thvelpar=0.0
-  IF(flag_new_strat_compo) THEN
-     DO i=1, nbtr_bin
-        m_par(i)=4./3.*RPI*radiuswet(i)**3.*DENSO4B(ilon,ilev,i)*1000.
-        thvelpar(i)=sqrt(8.*RKBOL*t_seri(ilon,ilev)/(RPI*m_par(i)))
-     ENDDO
-  ELSE
-     DO i=1, nbtr_bin
-        m_par(i)=4./3.*RPI*radiuswet(i)**3.*DENSO4(ilon,ilev)*1000.
-        thvelpar(i)=sqrt(8.*RKBOL*t_seri(ilon,ilev)/(RPI*m_par(i)))
-     ENDDO
-  ENDIF
-
-!--pre-compute the particle mean free path mfppar(i) from equation 22
-  mfppar=0.0
-  DO i=1, nbtr_bin
-   mfppar(i)=8.*Di(i)/(RPI*thvelpar(i))
-  ENDDO
-
-!--pre-compute the mean distance delta(i) from the center of a sphere reached by particles 
-!--leaving the surface of the sphere and traveling a distance of particle mfppar(i) from equation 21
-  delta=0.0
-  DO i=1, nbtr_bin
-      delta(i)=((2.*radiuswet(i)+mfppar(i))**3.-(4.*radiuswet(i)**2.+mfppar(i)**2.)**1.5)/ &
-           & (6.*radiuswet(i)*mfppar(i))-2.*radiuswet(i)
-  ENDDO
-
-!   beta(i,j): coagulation kernel (rate coefficient) of 2 colliding particles i,j 
-!--pre-compute the beta(i,j) from equation 17 in Jacobson
-  num=0.0
-  DO j=1, nbtr_bin
-  DO i=1, nbtr_bin
-!
-     num=4.*RPI*(radiuswet(i)+radiuswet(j))*(Di(i)+Di(j))
-     denom=(radiuswet(i)+radiuswet(j))/(radiuswet(i)+radiuswet(j)+sqrt(delta(i)**2.+delta(j)**2.))+ &
-          & 4.*(Di(i)+Di(j))/(sqrt(thvelpar(i)**2.+thvelpar(j)**2.)*(radiuswet(i)+radiuswet(j)))
-     beta(i,j)=num/denom
-!
-!--compute enhancement factor due to van der Waals forces
-   IF (ok_vdw .EQ. 0) THEN      !--no enhancement factor
-      Evdw=1.0
-   ELSEIF (ok_vdw .EQ. 1) THEN  !--E(0) case
-      AvdWi = AvdW/(RKBOL*t_seri(ilon,ilev))*(4.*radiuswet(i)*radiuswet(j))/(radiuswet(i)+radiuswet(j))**2.
-      xvdW = LOG(1.+AvdWi)
-      EvdW = 1. + avdW1*xvdW + avdW3*xvdW**3
-   ELSEIF (ok_vdw .EQ. 2) THEN  !--E(infinity) case
-      AvdWi = AvdW/(RKBOL*t_seri(ilon,ilev))*(4.*radiuswet(i)*radiuswet(j))/(radiuswet(i)+radiuswet(j))**2.
-      xvdW = LOG(1.+AvdWi)
-      EvdW = 1. + SQRT(AvdWi/3.)/(1.+bvdW0*SQRT(AvdWi)) + bvdW1*xvdW + bvdW3*xvdW**3.
-   ENDIF
-!
-   beta(i,j)=beta(i,j)*EvdW
-
-  ENDDO
-  ENDDO
-
-!--external loop for equation 14
-  DO k=1, nbtr_bin
-
-!--calculating denominator sum 
-  denom=0.0
-  DO j=1, nbtr_bin
-     !    fraction of coagulation of k and j that is not giving k
-     denom=denom+(1.-ff(k,j,k))*beta(k,j)*tr_t(ilon,ilev,j)
-  ENDDO
-
-  IF (k.EQ.1) THEN
-!--calculate new concentration of smallest bin
-    tr_tp1(ilon,ilev,k)=tr_t(ilon,ilev,k)/(1.+pdtcoag*denom)
-    ELSE
-!--calculating double sum terms in numerator of eq 14
-    num=0.0
-    DO j=1, k
-       numi=0.0
-       DO i=1, k-1
-!           
-!           see Jacobson: " In order to conserve volume and volume concentration (which
-!           coagulation physically does) while giving up some accuracy in number concentration" 
-!
-!           Coagulation of i and j giving k
-!           with V(i) and then V(j) because it considers i,j and j,i with the double loop
-!
-!           BUT WHY WET VOLUME V(i) in old STRATAER? tracers are already dry aerosols and coagulation 
-!           kernel beta(i,j) accounts for wet aerosols -> reply below
-!
-!             numi=numi+ff(i,j,k)*beta(i,j)*V(i)*tr_tp1(ilon,ilev,i)*tr_t(ilon,ilev,j)
-            numi=numi+ff(i,j,k)*beta(i,j)*Vdry(i)*tr_tp1(ilon,ilev,i)*tr_t(ilon,ilev,j)
-       ENDDO
-       num=num+numi
-    ENDDO
-
-!--calculate new concentration of other bins
-!      tr_tp1(ilon,ilev,k)=(V(k)*tr_t(ilon,ilev,k)+pdtcoag*num)/( (1.+pdtcoag*denom)*V(k) )
-    tr_tp1(ilon,ilev,k)=(Vdry(k)*tr_t(ilon,ilev,k)+pdtcoag*num)/( (1.+pdtcoag*denom)*Vdry(k) )
-!
-!       In constant composition (no dependency on aerosol size because no kelvin effect)
-!       V(l)= (f_r_wet(ilon,ilev)**3)*((mdw(l)/2.)**3) = (f_r_wet(ilon,ilev)**3)*Vdry(i)
-!       so numi and num are proportional (f_r_wet(ilon,ilev)**3)
-!       and so 
-!        tr_tp1(ilon,ilev,k)=(V(k)*tr_t(ilon,ilev,k)+pdtcoag*num)/( (1.+pdtcoag*denom)*V(k) )
-!                     =(Vdry(k)*tr_t(ilon,ilev,k)+pdtcoag*num_dry)/( (1.+pdtcoag*denom)*Vdry(k) ) 
-!          with num_dry=...beta(i,j)*Vdry(i)*....
-!       so in old STRATAER (.not.flag_new_strat_compo), it was correct
-  ENDIF
-
-  ENDDO !--end of loop k
-
-!--convert tracer concentration back from [number/m3] to [number/KgA] and write into tr_seri
-  DO i=1, nbtr_bin
-     tr_seri(ilon,ilev,i+nbtr_sulgas) = tr_tp1(ilon,ilev,i) / zrho
-  ENDDO
-
-  ENDIF ! IF IN STRATOSPHERE
-  ENDDO !--end of loop klev
-  ENDDO !--end of loop klon
-! *********************************************
-
-END SUBROUTINE COAGULATE
Index: /LMDZ6/trunk/libf/phylmd/StratAer/coagulate.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/StratAer/coagulate.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/StratAer/coagulate.f90	(revision 5268)
@@ -0,0 +1,292 @@
+!
+! $Id$
+!
+SUBROUTINE COAGULATE(pdtcoag,mdw,tr_seri,t_seri,pplay,dens_aer,is_strato)
+  !     -----------------------------------------------------------------------
+  !
+  !     Author : Christoph Kleinschmitt (with Olivier Boucher)
+  !     ------
+  !
+  !     purpose
+  !     -------
+  !
+  !     interface
+  !     ---------
+  !      input 
+  !       pdtphys        time step duration                 [sec]
+  !       tr_seri        tracer mixing ratios               [kg/kg]
+  !       mdw             # or mass median diameter          [m]
+  !
+  !     method
+  !     ------
+  !
+  !     -----------------------------------------------------------------------
+
+  USE dimphy, ONLY : klon,klev
+  USE aerophys
+  USE infotrac_phy
+  USE phys_local_var_mod, ONLY: DENSO4, DENSO4B, f_r_wet, f_r_wetB
+  USE strataer_local_var_mod, ONLY: flag_new_strat_compo
+  
+  IMPLICIT NONE
+
+  !--------------------------------------------------------
+
+  ! transfer variables when calling this routine
+  REAL,INTENT(IN)                               :: pdtcoag ! Time step in coagulation routine [s]
+  REAL,DIMENSION(nbtr_bin),INTENT(IN)           :: mdw     ! aerosol particle diameter in each bin [m]
+  REAL,DIMENSION(klon,klev,nbtr),INTENT(INOUT)  :: tr_seri ! Concentration Traceur [U/KgA]
+  REAL,DIMENSION(klon,klev),INTENT(IN)          :: t_seri  ! Temperature
+  REAL,DIMENSION(klon,klev),INTENT(IN)          :: pplay   ! pression pour le mileu de chaque couche (en Pa)
+  REAL,DIMENSION(klon,klev)                     :: dens_aer! density of aerosol [kg/m3 aerosol] with default H2SO4 mass
+  LOGICAL,DIMENSION(klon,klev),INTENT(IN)       :: is_strato
+
+  ! local variables in coagulation routine
+  INTEGER                                       :: i,j,k,nb,ilon,ilev
+  REAL, DIMENSION(nbtr_bin)                     :: radiusdry ! dry aerosol particle radius in each bin [m]
+  REAL, DIMENSION(nbtr_bin)                     :: radiuswet ! wet aerosol particle radius in each bin [m]
+  REAL, DIMENSION(klon,klev,nbtr_bin)           :: tr_t ! Concentration Traceur at time t [U/KgA]
+  REAL, DIMENSION(klon,klev,nbtr_bin)           :: tr_tp1 ! Concentration Traceur at time t+1 [U/KgA]
+  REAL, DIMENSION(nbtr_bin,nbtr_bin,nbtr_bin)   :: ff   ! Volume fraction of intermediate particles
+  REAL, DIMENSION(nbtr_bin)                     :: Vdry ! Volume dry of bins
+  REAL, DIMENSION(nbtr_bin)                     :: Vwet ! Volume wet of bins
+  REAL, DIMENSION(nbtr_bin,nbtr_bin)            :: Vij  ! Volume sum of i and j
+  REAL                                          :: eta  ! Dynamic viscosity of air
+  REAL, PARAMETER                               :: mair=4.8097E-26 ! Average mass of an air molecule [kg]
+  REAL                                          :: zrho ! Density of air
+  REAL                                          :: mnfrpth ! Mean free path of air
+  REAL, DIMENSION(nbtr_bin)                     :: Kn   ! Knudsen number of particle i
+  REAL, DIMENSION(nbtr_bin)                     :: Di   ! Particle diffusion coefficient
+  REAL, DIMENSION(nbtr_bin)                     :: m_par   ! Mass of particle i
+  REAL, DIMENSION(nbtr_bin)                     :: thvelpar! Thermal velocity of particle i
+  REAL, DIMENSION(nbtr_bin)                     :: mfppar  ! Mean free path of particle i
+  REAL, DIMENSION(nbtr_bin)                     :: delta! delta of particle i (from equation 21)
+  REAL, DIMENSION(nbtr_bin,nbtr_bin)            :: beta ! Coagulation kernel from Brownian diffusion
+  REAL                                          :: beta_const ! Constant coagulation kernel (for comparison)
+  REAL                                          :: num
+  REAL                                          :: numi
+  REAL                                          :: denom
+
+  ! Additional variables for coagulation enhancement factor due to van der Waals forces
+  ! Taken from Chan and Mozurkewich, Measurement of the coagulation rate constant for sulfuric acid 
+  ! particles as a function of particle size using TDMA, Aerosol Science, 32, 321-339, 2001.
+  !--ok_vdw is 0 for no vdW forces, 1 for E(0), 2 for E(infinity)
+  INTEGER, PARAMETER                            :: ok_vdw = 0
+  REAL, PARAMETER                               :: avdW1 = 0.0757
+  REAL, PARAMETER                               :: avdW3 = 0.0015
+  REAL, PARAMETER                               :: bvdW0 = 0.0151
+  REAL, PARAMETER                               :: bvdW1 = -0.186
+  REAL, PARAMETER                               :: bvdW3 = -0.0163
+  REAL, PARAMETER                               :: AvdW = 6.4e-20 !Hamaker constant in J = 1e7 erg
+  REAL                                          :: AvdWi
+  REAL                                          :: xvdW
+  REAL                                          :: EvdW
+
+  include "YOMCST.h"
+
+! ff(i,j,k): Volume fraction of Vi,j that is partitioned to each model bin k
+! just need to be calculated in model initialization because mdw(:) size is fixed
+! no need to recalculate radius, Vdry, Vij, and ff every timestep because it is for  
+! dry aerosols
+  DO i=1, nbtr_bin
+     radiusdry(i)=mdw(i)/2.
+     Vdry(i)=radiusdry(i)**3.  !neglecting factor 4*RPI/3
+     Vwet(i)=0.0
+  ENDDO
+
+  DO j=1, nbtr_bin
+     DO i=1, nbtr_bin
+        Vij(i,j)= Vdry(i)+Vdry(j)
+     ENDDO
+  ENDDO
+  
+!--pre-compute the f(i,j,k) from Jacobson equation 13
+  ff=0.0 
+  DO k=1, nbtr_bin 
+  DO j=1, nbtr_bin
+  DO i=1, nbtr_bin
+    IF (k.EQ.1) THEN
+      ff(i,j,k)= 0.0
+    ELSEIF (k.GT.1.AND.Vdry(k-1).LT.Vij(i,j).AND.Vij(i,j).LT.Vdry(k)) THEN
+      ff(i,j,k)= 1.-ff(i,j,k-1)
+    ELSEIF (k.EQ.nbtr_bin) THEN
+      IF (Vij(i,j).GE.Vdry(k)) THEN
+        ff(i,j,k)= 1.
+      ELSE
+        ff(i,j,k)= 0.0
+      ENDIF
+    ELSEIF (k.LE.(nbtr_bin-1).AND.Vdry(k).LE.Vij(i,j).AND.Vij(i,j).LT.Vdry(k+1)) THEN
+      ff(i,j,k)= Vdry(k)/Vij(i,j)*(Vdry(k+1)-Vij(i,j))/(Vdry(k+1)-Vdry(k))
+    ENDIF
+  ENDDO
+  ENDDO
+  ENDDO
+! End of just need to be calculated at initialization because mdw(:) size is fixed
+  
+  DO ilon=1, klon
+  DO ilev=1, klev 
+  !only in the stratosphere
+  IF (is_strato(ilon,ilev)) THEN
+  !compute actual wet particle radius & volume for every grid box
+  IF(flag_new_strat_compo) THEN
+     DO i=1, nbtr_bin
+        radiuswet(i)=f_r_wetB(ilon,ilev,i)*mdw(i)/2.
+        Vwet(i)= radiuswet(i)**3.  !neglecting factor 4*RPI/3
+!!      Vwet(i)= Vdry(i)*(f_r_wetB(ilon,ilev,i)**3)
+     ENDDO
+  ELSE
+     DO i=1, nbtr_bin
+        radiuswet(i)=f_r_wet(ilon,ilev)*mdw(i)/2.
+        Vwet(i)= radiuswet(i)**3.  !neglecting factor 4*RPI/3
+!!      Vwet(i)= Vdry(i)*(f_r_wet(ilon,ilev)**3)
+     ENDDO
+  ENDIF
+  
+!--Calculations for the coagulation kernel---------------------------------------------------------
+
+  zrho=pplay(ilon,ilev)/t_seri(ilon,ilev)/RD
+
+!--initialize the tracer at time t and convert from [number/KgA] to [number/m3]
+  DO i=1, nbtr_bin
+  tr_t(ilon,ilev,i) = tr_seri(ilon,ilev,i+nbtr_sulgas) * zrho
+  ENDDO
+
+  ! mean free path of air (Pruppacher and Klett, 2010, p.417) [m]
+  mnfrpth=6.6E-8*(1.01325E+5/pplay(ilon,ilev))*(t_seri(ilon,ilev)/293.15)
+  ! mnfrpth=2.*eta/(zrho*thvelair)
+  ! mean free path of air (Prupp. Klett) in [10^-6 m]
+  ! ZLAIR = 0.066 *(1.01325E+5/PPLAY)*(T_SERI/293.15)*1.E-06
+
+  ! dynamic viscosity of air (Pruppacher and Klett, 2010, p.417) [kg/(m*s)]
+  IF (t_seri(ilon,ilev).GE.273.15) THEN
+    eta=(1.718+0.0049*(t_seri(ilon,ilev)-273.15))*1.E-5
+  ELSE
+    eta=(1.718+0.0049*(t_seri(ilon,ilev)-273.15)-1.2E-5*(t_seri(ilon,ilev)-273.15)**2)*1.E-5
+  ENDIF
+
+!--pre-compute the particle diffusion coefficient Di(i) from equation 18
+  Di=0.0
+  DO i=1, nbtr_bin
+      Kn(i)=mnfrpth/radiuswet(i)
+      Di(i)=RKBOL*t_seri(ilon,ilev)/(6.*RPI*radiuswet(i)*eta)*(1.+Kn(i)*(1.249+0.42*exp(-0.87/Kn(i))))
+  ENDDO
+
+!--pre-compute the thermal velocity of a particle thvelpar(i) from equation 20
+  thvelpar=0.0
+  IF(flag_new_strat_compo) THEN
+     DO i=1, nbtr_bin
+        m_par(i)=4./3.*RPI*radiuswet(i)**3.*DENSO4B(ilon,ilev,i)*1000.
+        thvelpar(i)=sqrt(8.*RKBOL*t_seri(ilon,ilev)/(RPI*m_par(i)))
+     ENDDO
+  ELSE
+     DO i=1, nbtr_bin
+        m_par(i)=4./3.*RPI*radiuswet(i)**3.*DENSO4(ilon,ilev)*1000.
+        thvelpar(i)=sqrt(8.*RKBOL*t_seri(ilon,ilev)/(RPI*m_par(i)))
+     ENDDO
+  ENDIF
+
+!--pre-compute the particle mean free path mfppar(i) from equation 22
+  mfppar=0.0
+  DO i=1, nbtr_bin
+   mfppar(i)=8.*Di(i)/(RPI*thvelpar(i))
+  ENDDO
+
+!--pre-compute the mean distance delta(i) from the center of a sphere reached by particles 
+!--leaving the surface of the sphere and traveling a distance of particle mfppar(i) from equation 21
+  delta=0.0
+  DO i=1, nbtr_bin
+      delta(i)=((2.*radiuswet(i)+mfppar(i))**3.-(4.*radiuswet(i)**2.+mfppar(i)**2.)**1.5)/ &
+           & (6.*radiuswet(i)*mfppar(i))-2.*radiuswet(i)
+  ENDDO
+
+!   beta(i,j): coagulation kernel (rate coefficient) of 2 colliding particles i,j 
+!--pre-compute the beta(i,j) from equation 17 in Jacobson
+  num=0.0
+  DO j=1, nbtr_bin
+  DO i=1, nbtr_bin
+!
+     num=4.*RPI*(radiuswet(i)+radiuswet(j))*(Di(i)+Di(j))
+     denom=(radiuswet(i)+radiuswet(j))/(radiuswet(i)+radiuswet(j)+sqrt(delta(i)**2.+delta(j)**2.))+ &
+          & 4.*(Di(i)+Di(j))/(sqrt(thvelpar(i)**2.+thvelpar(j)**2.)*(radiuswet(i)+radiuswet(j)))
+     beta(i,j)=num/denom
+!
+!--compute enhancement factor due to van der Waals forces
+   IF (ok_vdw .EQ. 0) THEN      !--no enhancement factor
+      Evdw=1.0
+   ELSEIF (ok_vdw .EQ. 1) THEN  !--E(0) case
+      AvdWi = AvdW/(RKBOL*t_seri(ilon,ilev))*(4.*radiuswet(i)*radiuswet(j))/(radiuswet(i)+radiuswet(j))**2.
+      xvdW = LOG(1.+AvdWi)
+      EvdW = 1. + avdW1*xvdW + avdW3*xvdW**3
+   ELSEIF (ok_vdw .EQ. 2) THEN  !--E(infinity) case
+      AvdWi = AvdW/(RKBOL*t_seri(ilon,ilev))*(4.*radiuswet(i)*radiuswet(j))/(radiuswet(i)+radiuswet(j))**2.
+      xvdW = LOG(1.+AvdWi)
+      EvdW = 1. + SQRT(AvdWi/3.)/(1.+bvdW0*SQRT(AvdWi)) + bvdW1*xvdW + bvdW3*xvdW**3.
+   ENDIF
+!
+   beta(i,j)=beta(i,j)*EvdW
+
+  ENDDO
+  ENDDO
+
+!--external loop for equation 14
+  DO k=1, nbtr_bin
+
+!--calculating denominator sum 
+  denom=0.0
+  DO j=1, nbtr_bin
+     !    fraction of coagulation of k and j that is not giving k
+     denom=denom+(1.-ff(k,j,k))*beta(k,j)*tr_t(ilon,ilev,j)
+  ENDDO
+
+  IF (k.EQ.1) THEN
+!--calculate new concentration of smallest bin
+    tr_tp1(ilon,ilev,k)=tr_t(ilon,ilev,k)/(1.+pdtcoag*denom)
+    ELSE
+!--calculating double sum terms in numerator of eq 14
+    num=0.0
+    DO j=1, k
+       numi=0.0
+       DO i=1, k-1
+!           
+!           see Jacobson: " In order to conserve volume and volume concentration (which
+!           coagulation physically does) while giving up some accuracy in number concentration" 
+!
+!           Coagulation of i and j giving k
+!           with V(i) and then V(j) because it considers i,j and j,i with the double loop
+!
+!           BUT WHY WET VOLUME V(i) in old STRATAER? tracers are already dry aerosols and coagulation 
+!           kernel beta(i,j) accounts for wet aerosols -> reply below
+!
+!             numi=numi+ff(i,j,k)*beta(i,j)*V(i)*tr_tp1(ilon,ilev,i)*tr_t(ilon,ilev,j)
+            numi=numi+ff(i,j,k)*beta(i,j)*Vdry(i)*tr_tp1(ilon,ilev,i)*tr_t(ilon,ilev,j)
+       ENDDO
+       num=num+numi
+    ENDDO
+
+!--calculate new concentration of other bins
+!      tr_tp1(ilon,ilev,k)=(V(k)*tr_t(ilon,ilev,k)+pdtcoag*num)/( (1.+pdtcoag*denom)*V(k) )
+    tr_tp1(ilon,ilev,k)=(Vdry(k)*tr_t(ilon,ilev,k)+pdtcoag*num)/( (1.+pdtcoag*denom)*Vdry(k) )
+!
+!       In constant composition (no dependency on aerosol size because no kelvin effect)
+!       V(l)= (f_r_wet(ilon,ilev)**3)*((mdw(l)/2.)**3) = (f_r_wet(ilon,ilev)**3)*Vdry(i)
+!       so numi and num are proportional (f_r_wet(ilon,ilev)**3)
+!       and so 
+!        tr_tp1(ilon,ilev,k)=(V(k)*tr_t(ilon,ilev,k)+pdtcoag*num)/( (1.+pdtcoag*denom)*V(k) )
+!                     =(Vdry(k)*tr_t(ilon,ilev,k)+pdtcoag*num_dry)/( (1.+pdtcoag*denom)*Vdry(k) ) 
+!          with num_dry=...beta(i,j)*Vdry(i)*....
+!       so in old STRATAER (.not.flag_new_strat_compo), it was correct
+  ENDIF
+
+  ENDDO !--end of loop k
+
+!--convert tracer concentration back from [number/m3] to [number/KgA] and write into tr_seri
+  DO i=1, nbtr_bin
+     tr_seri(ilon,ilev,i+nbtr_sulgas) = tr_tp1(ilon,ilev,i) / zrho
+  ENDDO
+
+  ENDIF ! IF IN STRATOSPHERE
+  ENDDO !--end of loop klev
+  ENDDO !--end of loop klon
+! *********************************************
+
+END SUBROUTINE COAGULATE
Index: DZ6/trunk/libf/phylmd/StratAer/cond_evap_tstep_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/StratAer/cond_evap_tstep_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,362 +1,0 @@
-!
-! $Id$
-!
-MODULE cond_evap_tstep_mod
-
-! based on UPMC aerosol model by Slimane Bekki
-! adapted for stratospheric sulfate aerosol in LMDZ by Christoph Kleinschmitt 
-
-CONTAINS
-
-      SUBROUTINE condens_evapor_rate_kelvin(R2SO4G,t_seri,pplay,R2SO4, &
-          & DENSO4,f_r_wet,R2SO4ik,DENSO4ik,f_r_wetik,FL,ASO4,DNDR)
-!
-!     INPUT: 
-!     R2SO4G: number density of gaseous H2SO4 [molecules/cm3]
-!     t_seri: temperature (K)
-!     pplay: pressure (Pa)
-!     R2SO4: aerosol H2SO4 weight fraction (percent) - flat surface (does not depend on aerosol size)
-!     DENSO4: aerosol density (gr/cm3) 
-!     f_r_wet: factor for converting dry to wet radius 
-!        assuming 'flat surface' composition (does not depend on aerosol size)
-!     variables that depends on aerosol size because of Kelvin effect
-!     R2SO4Gik: number density of gaseous H2SO4 [molecules/cm3] - depends on aerosol size
-!     DENSO4ik: aerosol density (gr/cm3) - depends on aerosol size
-!     f_r_wetik: factor for converting dry to wet radius - depends on aerosol size
-!     RRSI: radius [cm]
-
-      USE aerophys
-      USE infotrac_phy
-      USE yomcst_mod_h, ONLY : RPI
-      USE sulfate_aer_mod, ONLY : wph2so4, surftension, solh2so4, rpmvh2so4
-      USE strataer_local_var_mod, ONLY : ALPH2SO4, RRSI
-      
-      IMPLICIT NONE
-      
-      REAL, PARAMETER :: third=1./3.
-      
-      ! input variables
-      REAL            :: R2SO4G !H2SO4 number density [molecules/cm3]
-      REAL            :: t_seri
-      REAL            :: pplay
-      REAL            :: R2SO4
-      REAL            :: DENSO4
-      REAL            :: f_r_wet
-      REAL            :: R2SO4ik(nbtr_bin), DENSO4ik(nbtr_bin), f_r_wetik(nbtr_bin)
-      
-      ! output variables
-      REAL            :: FL(nbtr_bin)
-      REAL            :: ASO4(nbtr_bin)
-      REAL            :: DNDR(nbtr_bin)
-      
-      ! local variables
-      INTEGER            :: IK
-      REAL            :: ALPHA,CST
-      REAL            :: WH2(nbtr_bin)
-      REAL            :: RP,VTK,AA,FL1,RKNUD
-      REAL            :: DND
-      REAL            :: ATOT,AH2O
-      REAL            :: RRSI_wet(nbtr_bin)
-      REAL            :: FPATH, WPP, XA, FKELVIN
-      REAL            :: surtens, mvh2so4, temp
-      
-! ///    MOLEC CONDENSATION GROWTH (DUE TO CHANGES IN H2SO4 AND SO H2O)
-!    ------------------------------------------------------------------
-!                                  EXCEPT CN
-!       RK:H2SO4 WEIGHT PERCENT DOESN'T CHANGE
-!     BE CAREFUL,H2SO4 WEIGHT PERCENTAGE
-
-!                   MOLECULAR ACCOMODATION OF H2SO4
-!     H2SO4 accommodation  coefficient [condensation/evaporation]
-      ALPHA = ALPH2SO4
-!      FPLAIR=(2.281238E-5)*TAIR/PAIR
-!     1.E2 (m to cm), 
-      CST=1.E2*2.281238E-5
-!     same expression as in coagulate
-!     in coagulate: mean free path of air (Pruppacher and Klett, 2010, p.417) [m]
-!     mnfrpth=6.6E-8*(1.01325E+5/pplay(ilon,ilev))*(t_seri(ilon,ilev)/293.15)
-!     mnfrpth=2.28E-5*t_seri/pplay
-      
-      temp = min( max(t_seri, 190.), 300.) ! 190K <= temp <= 300K
-      
-      RRSI_wet(:)=RRSI(:)*f_r_wetik(:)
-
-!     Pruppa and Klett
-      FPATH=CST*t_seri/pplay
-    
-!     H2SO4 mass fraction in aerosol
-      WH2(:)=R2SO4ik(:)*1.0E-2
-
-!                               ACTIVITY COEFFICIENT(SEE GIAUQUE,1951)
-!                               AYERS ET AL (1980)
-!                                  (MU-MU0)
-!      RP=-10156.0/t_seri +16.259-(ACTSO4*4.184)/(8.31441*t_seri)
-!                                  DROPLET H2SO4 PRESSURE IN DYN.CM-2
-!      RP=EXP(RP)*1.01325E6/0.086
-!!      RP=EXP(RP)*1.01325E6
-!                                  H2SO4 NUMBER DENSITY NEAR DROPLET
-
-!      DND=RP*6.02E23/(8.31E7*t_seri)
-
-!                                 KELVIN EFFECT FACTOR
-!CK 20160613: bug fix, removed factor 250 (from original code by S. Bekki)
-!!      AA =2.0*MH2O*72.0/(DENSO4*BOLZ*t_seri*250.0)
-!      AA =2.0*MH2O*72.0/(DENSO4*BOLZ*t_seri)
-
-!                                  MEAN KINETIC VELOCITY
-!     DYN*CM*K/(K*GR)=(CM/SEC2)*CM
-!                                  IN CM/SEC
-      VTK=SQRT(8.0*BOLZ*t_seri/(RPI*MH2SO4))
-!                                 KELVIN EFFECT FACTOR
-
-!     Loop on bin radius (RRSI in cm)
-      DO IK=1,nbtr_bin
-
-      IF(R2SO4ik(IK) > 0.0) THEN
-
-!       h2so4 mass fraction (0<wpp<1)
-        wpp=R2SO4ik(IK)*1.e-2    
-        xa=18.*wpp/(18.*wpp+98.*(1.-wpp)) 
-!       equilibrium h2so4 number density over H2SO4/H2O solution (molec/cm3)
-        DND=solh2so4(t_seri,xa)
-!          KELVIN EFFECT:  
-!       surface tension (mN/m=1.e-3.kg/s2) = f(T,h2so4 mole fraction)
-        surtens=surftension(temp,xa)
-!       partial molar volume of h2so4 (cm3.mol-1 =1.e-6.m3.mol-1)
-        mvh2so4= rpmvh2so4(temp,R2SO4ik(IK))
-!       Kelvin factor (MKS)
-        fkelvin=exp( 2.*1.e-3*surtens*1.e-6*mvh2so4/ (1.e-2*RRSI_wet(IK)*rgas*temp) )
-!                              
-        DNDR(IK) =DND*fkelvin
-
-        FL1=RPI*ALPHA*VTK*(R2SO4G-DNDR(IK))
-
-!       TURCO(1979) FOR HNO3:ALH2SO4 CONDENSATION= ALH2SO4 EVAPORATION
-!       RPI*R2*VTK IS EQUIVALENT TO DIFFUSION COEFFICIENT
-!       EXTENSION OF THE RELATION FOR DIFFUSION KINETICS
-!       KNUDSEN NUMBER FPATH/RRSI
-!       NEW VERSION (SEE NOTES)
-        RKNUD=FPATH/RRSI_wet(IK)
-!       SENFELD
-        FL(IK)=FL1*RRSI_wet(IK)**2*( 1.0 +RKNUD ) & 
-     &     /( 1.0 +ALPHA/(2.0*RKNUD) +RKNUD )
-!       TURCO
-!        RL= (4.0/3.0 +0.71/RKNUD)/(1.0+1.0/RKNUD)
-!     *         +4.0*(1.0-ALPHA)/(3.0*ALPHA)
-!        FL=FL1*RRSI(IK)*RRSI(IK)
-!     *         /( (3.0*ALPHA/4.0)*(1.0/RKNUD+RL*ALPHA) )
-
-!                         INITIAL NUMBER OF H2SO4 MOLEC OF 1 DROPLET
-        ATOT=4.0*RPI*DENSO4ik(IK)*(RRSI_wet(IK)**3)/3.0 !attention: g and cm
-        ASO4(IK)=WH2(IK)*ATOT/MH2SO4 !attention: g
-!        ATOT=4.0*RPI*dens_aer(I,J)/1000.*(RRSI(IK)**3)/3.0
-!        ASO4=mfrac_H2SO4*ATOT/MH2SO4
-!                        INITIAL NUMBER OF H2O MOLEC OF 1 DROPLET
-        AH2O=(1.0-WH2(IK))*ATOT/MH2O !attention: g
-
-!       CHANGE OF THE NUMBER OF H2SO4 MOLEC OF 1 DROPLET DURING DT
-!       IT IS FOR KEM BUT THERE ARE OTHER WAYS
-
-      ENDIF  
-
-      ENDDO !loop over bins
-
-      END SUBROUTINE condens_evapor_rate_kelvin
-      
-!********************************************************************
-      SUBROUTINE condens_evapor_rate(R2SO4G,t_seri,pplay,ACTSO4,R2SO4, &
-                   & DENSO4,f_r_wet,FL,ASO4,DNDR)
-!
-!     INPUT: 
-!     R2SO4: aerosol H2SO4 weight fraction (percent)
-!     ACTSO4: H2SO4 activity
-!     R2SO4G: number density of gaseous H2SO4 [molecules/cm3]
-!     t_seri: temperature (K)
-!     DENSO4: aerosol density (gr/cm3)
-
-      USE aerophys
-      USE infotrac_phy
-      USE yomcst_mod_h, ONLY : RPI
-      USE strataer_local_var_mod, ONLY : ALPH2SO4, RRSI
-
-      IMPLICIT NONE
-
-      ! input variables
-      REAL R2SO4G !H2SO4 number density [molecules/cm3]
-      REAL t_seri
-      REAL pplay
-      REAL ACTSO4
-      REAL R2SO4
-      REAL DENSO4
-      REAL f_r_wet
-      
-      ! output variables
-      REAL FL(nbtr_bin)
-      REAL ASO4(nbtr_bin)
-      REAL DNDR(nbtr_bin)
-
-      ! local variables
-      INTEGER IK
-      REAL ALPHA,CST
-      REAL WH2,RP,VTK,AA,FL1,RKNUD
-      REAL DND
-      REAL ATOT,AH2O
-      REAL RRSI_wet(nbtr_bin)
-      REAL FPATH
-
-! ///    MOLEC CONDENSATION GROWTH (DUE TO CHANGES IN H2SO4 AND SO H2O)
-!    ------------------------------------------------------------------
-!                                  EXCEPT CN
-!       RK:H2SO4 WEIGHT PERCENT DOESN'T CHANGE
-!     BE CAREFUL,H2SO4 WEIGHT PERCENTAGE
-
-!                   MOLECULAR ACCOMODATION OF H2SO4
-!     H2SO4 accommodation coefficient [condensation/evaporation]
-      ALPHA = ALPH2SO4
-!      FPLAIR=(2.281238E-5)*TAIR/PAIR
-!     1.E2 (m to cm), 
-      CST=1.E2*2.281238E-5
-
-      ! compute local wet particle radius [cm]
-      RRSI_wet(:)=RRSI(:)*f_r_wet
-      
-!     Pruppa and Klett
-      FPATH=CST*t_seri/pplay
-
-      
-!     H2SO4 mass fraction in aerosol
-      WH2=R2SO4*1.0E-2
-      IF(WH2.EQ.0.0) RETURN
-!                               ACTIVITY COEFFICIENT(SEE GIAUQUE,1951)
-!                               AYERS ET AL (1980)
-!                                  (MU-MU0)
-      RP=-10156.0/t_seri +16.259-(ACTSO4*4.184)/(8.31441*t_seri)
-!                                  DROPLET H2SO4 PRESSURE IN DYN.CM-2
-      RP=EXP(RP)*1.01325E6/0.086
-!      RP=EXP(RP)*1.01325E6
-!                                  H2SO4 NUMBER DENSITY NEAR DROPLET
-!     R=8.31E7 DYN.CM.MOL-1*K-1
-!                               R/AVOGADRO NUMBER=DYN.CM.MOLEC-1*K-1
-      DND=RP*6.02E23/(8.31E7*t_seri)
-!                                  MEAN KINETIC VELOCITY
-!     DYN*CM*K/(K*GR)=(CM/SEC2)*CM
-!                                  IN CM/SEC
-      VTK=SQRT(8.0*BOLZ*t_seri/(RPI*MH2SO4))
-!                                 KELVIN EFFECT FACTOR
-!CK 20160613: bug fix, removed factor 250 (from original code by S. Bekki)
-!      AA =2.0*MH2O*72.0/(DENSO4*BOLZ*t_seri*250.0)
-      AA =2.0*MH2O*72.0/(DENSO4*BOLZ*t_seri)
-
-!     Loop on bin radius (RRSI in cm)
-      DO IK=1,nbtr_bin
-!                                 KELVIN EFFECT
-        DNDR(IK) =DND*EXP(AA/RRSI_wet(IK))
-
-        FL1=RPI*ALPHA*VTK*(R2SO4G-DNDR(IK))
-
-!       TURCO(1979) FOR HNO3:ALH2SO4 CONDENSATION= ALH2SO4 EVAPORATION
-!       RPI*R2*VTK IS EQUIVALENT TO DIFFUSION COEFFICIENT
-!       EXTENSION OF THE RELATION FOR DIFFUSION KINETICS
-!       KNUDSEN NUMBER FPATH/RRSI
-!       NEW VERSION (SEE NOTES)
-        RKNUD=FPATH/RRSI_wet(IK)
-!       SENFELD
-        FL(IK)=FL1*RRSI_wet(IK)**2*( 1.0 +RKNUD ) & 
-     &     /( 1.0 +ALPHA/(2.0*RKNUD) +RKNUD )
-!       TURCO
-!        RL= (4.0/3.0 +0.71/RKNUD)/(1.0+1.0/RKNUD)
-!     *         +4.0*(1.0-ALPHA)/(3.0*ALPHA)
-!        FL=FL1*RRSI(IK)*RRSI(IK)
-!     *         /( (3.0*ALPHA/4.0)*(1.0/RKNUD+RL*ALPHA) )
-
-!                         INITIAL NUMBER OF H2SO4 MOLEC OF 1 DROPLET
-        ATOT=4.0*RPI*DENSO4*(RRSI_wet(IK)**3)/3.0 !attention: g and cm
-        ASO4(IK)=WH2*ATOT/MH2SO4 !attention: g
-!        ATOT=4.0*RPI*dens_aer(I,J)/1000.*(RRSI(IK)**3)/3.0
-!        ASO4=mfrac_H2SO4*ATOT/MH2SO4
-!                        INITIAL NUMBER OF H2O MOLEC OF 1 DROPLET
-        AH2O=(1.0-WH2)*ATOT/MH2O !attention: g
-
-!       CHANGE OF THE NUMBER OF H2SO4 MOLEC OF 1 DROPLET DURING DT
-!       IT IS FOR KEM BUT THERE ARE OTHER WAYS
-
-      ENDDO !loop over bins
-
-      END SUBROUTINE condens_evapor_rate
-
-!********************************************************************
-      SUBROUTINE condens_evapor_part(dt,FL,ASO4,f_r_wet,tr_seri)
-
-      USE aerophys
-      USE infotrac_phy
-      USE yomcst_mod_h, ONLY : RPI
-      USE strataer_local_var_mod, ONLY : RRSI,Vbin
-      
-      IMPLICIT NONE
-
-      ! input variables
-      REAL dt
-      REAL FL(nbtr_bin)
-      REAL ASO4(nbtr_bin)
-      REAL f_r_wet
-      
-      ! output variables
-      REAL tr_seri(nbtr)
-      
-      ! local variables
-      REAL tr_seri_new(nbtr)
-      INTEGER IK,JK,k
-      REAL Vnew
-      REAL RRSI_wet(nbtr_bin)
-      REAL Vbin_wet(nbtr_bin)
-      REAL sum_IK(nbtr_bin)
-      REAL ff(nbtr_bin,nbtr_bin)
-
-      tr_seri_new(:)=tr_seri(:)
-
-      ! compute local wet particle radius and volume
-      RRSI_wet(:)=RRSI(:)*f_r_wet
-      Vbin_wet(:)=Vbin(:)*f_r_wet**3 *1.e6 !Vbin_wet in cm3 (as Vnew)
-
-      ! compute distribution factor for particles of intermediate size (from Jacobson 1994, equation 13)
-      DO IK=1,nbtr_bin
-        Vnew=4.0*RPI*(RRSI_wet(IK)**3)/3.0*(1.+FL(IK)*dt/ASO4(IK))
-        ff(IK,:)=0.0 
-        DO k=1, nbtr_bin 
-          IF (k.LE.(nbtr_bin-1)) THEN 
-            IF (Vbin_wet(k).LE.Vnew.AND.Vnew.LT.Vbin_wet(k+1)) THEN
-              ff(IK,k)= Vbin_wet(k)/Vnew*(Vbin_wet(k+1)-Vnew)/(Vbin_wet(k+1)-Vbin_wet(k))
-            ENDIF
-          ENDIF
-          IF (k.EQ.1.AND.Vnew.LE.Vbin_wet(k)) THEN
-            ff(IK,k)= 1.
-          ENDIF
-          IF (k.GT.1) THEN 
-            IF (Vbin_wet(k-1).LT.Vnew.AND.Vnew.LT.Vbin_wet(k)) THEN
-              ff(IK,k)= 1.-ff(IK,k-1)
-            ENDIF
-          ENDIF
-          IF (k.EQ.nbtr_bin.AND.Vnew.GE.Vbin_wet(k)) THEN
-            ff(IK,k)= 1.
-          ENDIF
-        ENDDO
-        ! correction of ff for volume conservation
-        DO k=1, nbtr_bin         
-          ff(IK,k)=ff(IK,k)*Vnew/Vbin_wet(k)
-        ENDDO
-      ENDDO !loop over bins
-
-      DO IK=1, nbtr_bin
-        sum_IK(IK)=0.0
-        DO JK=1, nbtr_bin
-          sum_IK(IK)=sum_IK(IK)+tr_seri(JK+nbtr_sulgas)*ff(JK,IK)
-        ENDDO
-        ! compute new particle concentrations
-        tr_seri_new(IK+nbtr_sulgas)=sum_IK(IK)
-      ENDDO
-
-      tr_seri(:)=tr_seri_new(:)
-
-      END SUBROUTINE condens_evapor_part
-
-END MODULE cond_evap_tstep_mod
Index: /LMDZ6/trunk/libf/phylmd/StratAer/cond_evap_tstep_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/StratAer/cond_evap_tstep_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/StratAer/cond_evap_tstep_mod.f90	(revision 5268)
@@ -0,0 +1,362 @@
+!
+! $Id$
+!
+MODULE cond_evap_tstep_mod
+
+! based on UPMC aerosol model by Slimane Bekki
+! adapted for stratospheric sulfate aerosol in LMDZ by Christoph Kleinschmitt 
+
+CONTAINS
+
+      SUBROUTINE condens_evapor_rate_kelvin(R2SO4G,t_seri,pplay,R2SO4, &
+          & DENSO4,f_r_wet,R2SO4ik,DENSO4ik,f_r_wetik,FL,ASO4,DNDR)
+!
+!     INPUT: 
+!     R2SO4G: number density of gaseous H2SO4 [molecules/cm3]
+!     t_seri: temperature (K)
+!     pplay: pressure (Pa)
+!     R2SO4: aerosol H2SO4 weight fraction (percent) - flat surface (does not depend on aerosol size)
+!     DENSO4: aerosol density (gr/cm3) 
+!     f_r_wet: factor for converting dry to wet radius 
+!        assuming 'flat surface' composition (does not depend on aerosol size)
+!     variables that depends on aerosol size because of Kelvin effect
+!     R2SO4Gik: number density of gaseous H2SO4 [molecules/cm3] - depends on aerosol size
+!     DENSO4ik: aerosol density (gr/cm3) - depends on aerosol size
+!     f_r_wetik: factor for converting dry to wet radius - depends on aerosol size
+!     RRSI: radius [cm]
+
+      USE aerophys
+      USE infotrac_phy
+      USE yomcst_mod_h, ONLY : RPI
+      USE sulfate_aer_mod, ONLY : wph2so4, surftension, solh2so4, rpmvh2so4
+      USE strataer_local_var_mod, ONLY : ALPH2SO4, RRSI
+      
+      IMPLICIT NONE
+      
+      REAL, PARAMETER :: third=1./3.
+      
+      ! input variables
+      REAL            :: R2SO4G !H2SO4 number density [molecules/cm3]
+      REAL            :: t_seri
+      REAL            :: pplay
+      REAL            :: R2SO4
+      REAL            :: DENSO4
+      REAL            :: f_r_wet
+      REAL            :: R2SO4ik(nbtr_bin), DENSO4ik(nbtr_bin), f_r_wetik(nbtr_bin)
+      
+      ! output variables
+      REAL            :: FL(nbtr_bin)
+      REAL            :: ASO4(nbtr_bin)
+      REAL            :: DNDR(nbtr_bin)
+      
+      ! local variables
+      INTEGER            :: IK
+      REAL            :: ALPHA,CST
+      REAL            :: WH2(nbtr_bin)
+      REAL            :: RP,VTK,AA,FL1,RKNUD
+      REAL            :: DND
+      REAL            :: ATOT,AH2O
+      REAL            :: RRSI_wet(nbtr_bin)
+      REAL            :: FPATH, WPP, XA, FKELVIN
+      REAL            :: surtens, mvh2so4, temp
+      
+! ///    MOLEC CONDENSATION GROWTH (DUE TO CHANGES IN H2SO4 AND SO H2O)
+!    ------------------------------------------------------------------
+!                                  EXCEPT CN
+!       RK:H2SO4 WEIGHT PERCENT DOESN'T CHANGE
+!     BE CAREFUL,H2SO4 WEIGHT PERCENTAGE
+
+!                   MOLECULAR ACCOMODATION OF H2SO4
+!     H2SO4 accommodation  coefficient [condensation/evaporation]
+      ALPHA = ALPH2SO4
+!      FPLAIR=(2.281238E-5)*TAIR/PAIR
+!     1.E2 (m to cm), 
+      CST=1.E2*2.281238E-5
+!     same expression as in coagulate
+!     in coagulate: mean free path of air (Pruppacher and Klett, 2010, p.417) [m]
+!     mnfrpth=6.6E-8*(1.01325E+5/pplay(ilon,ilev))*(t_seri(ilon,ilev)/293.15)
+!     mnfrpth=2.28E-5*t_seri/pplay
+      
+      temp = min( max(t_seri, 190.), 300.) ! 190K <= temp <= 300K
+      
+      RRSI_wet(:)=RRSI(:)*f_r_wetik(:)
+
+!     Pruppa and Klett
+      FPATH=CST*t_seri/pplay
+    
+!     H2SO4 mass fraction in aerosol
+      WH2(:)=R2SO4ik(:)*1.0E-2
+
+!                               ACTIVITY COEFFICIENT(SEE GIAUQUE,1951)
+!                               AYERS ET AL (1980)
+!                                  (MU-MU0)
+!      RP=-10156.0/t_seri +16.259-(ACTSO4*4.184)/(8.31441*t_seri)
+!                                  DROPLET H2SO4 PRESSURE IN DYN.CM-2
+!      RP=EXP(RP)*1.01325E6/0.086
+!!      RP=EXP(RP)*1.01325E6
+!                                  H2SO4 NUMBER DENSITY NEAR DROPLET
+
+!      DND=RP*6.02E23/(8.31E7*t_seri)
+
+!                                 KELVIN EFFECT FACTOR
+!CK 20160613: bug fix, removed factor 250 (from original code by S. Bekki)
+!!      AA =2.0*MH2O*72.0/(DENSO4*BOLZ*t_seri*250.0)
+!      AA =2.0*MH2O*72.0/(DENSO4*BOLZ*t_seri)
+
+!                                  MEAN KINETIC VELOCITY
+!     DYN*CM*K/(K*GR)=(CM/SEC2)*CM
+!                                  IN CM/SEC
+      VTK=SQRT(8.0*BOLZ*t_seri/(RPI*MH2SO4))
+!                                 KELVIN EFFECT FACTOR
+
+!     Loop on bin radius (RRSI in cm)
+      DO IK=1,nbtr_bin
+
+      IF(R2SO4ik(IK) > 0.0) THEN
+
+!       h2so4 mass fraction (0<wpp<1)
+        wpp=R2SO4ik(IK)*1.e-2    
+        xa=18.*wpp/(18.*wpp+98.*(1.-wpp)) 
+!       equilibrium h2so4 number density over H2SO4/H2O solution (molec/cm3)
+        DND=solh2so4(t_seri,xa)
+!          KELVIN EFFECT:  
+!       surface tension (mN/m=1.e-3.kg/s2) = f(T,h2so4 mole fraction)
+        surtens=surftension(temp,xa)
+!       partial molar volume of h2so4 (cm3.mol-1 =1.e-6.m3.mol-1)
+        mvh2so4= rpmvh2so4(temp,R2SO4ik(IK))
+!       Kelvin factor (MKS)
+        fkelvin=exp( 2.*1.e-3*surtens*1.e-6*mvh2so4/ (1.e-2*RRSI_wet(IK)*rgas*temp) )
+!                              
+        DNDR(IK) =DND*fkelvin
+
+        FL1=RPI*ALPHA*VTK*(R2SO4G-DNDR(IK))
+
+!       TURCO(1979) FOR HNO3:ALH2SO4 CONDENSATION= ALH2SO4 EVAPORATION
+!       RPI*R2*VTK IS EQUIVALENT TO DIFFUSION COEFFICIENT
+!       EXTENSION OF THE RELATION FOR DIFFUSION KINETICS
+!       KNUDSEN NUMBER FPATH/RRSI
+!       NEW VERSION (SEE NOTES)
+        RKNUD=FPATH/RRSI_wet(IK)
+!       SENFELD
+        FL(IK)=FL1*RRSI_wet(IK)**2*( 1.0 +RKNUD ) & 
+     &     /( 1.0 +ALPHA/(2.0*RKNUD) +RKNUD )
+!       TURCO
+!        RL= (4.0/3.0 +0.71/RKNUD)/(1.0+1.0/RKNUD)
+!     *         +4.0*(1.0-ALPHA)/(3.0*ALPHA)
+!        FL=FL1*RRSI(IK)*RRSI(IK)
+!     *         /( (3.0*ALPHA/4.0)*(1.0/RKNUD+RL*ALPHA) )
+
+!                         INITIAL NUMBER OF H2SO4 MOLEC OF 1 DROPLET
+        ATOT=4.0*RPI*DENSO4ik(IK)*(RRSI_wet(IK)**3)/3.0 !attention: g and cm
+        ASO4(IK)=WH2(IK)*ATOT/MH2SO4 !attention: g
+!        ATOT=4.0*RPI*dens_aer(I,J)/1000.*(RRSI(IK)**3)/3.0
+!        ASO4=mfrac_H2SO4*ATOT/MH2SO4
+!                        INITIAL NUMBER OF H2O MOLEC OF 1 DROPLET
+        AH2O=(1.0-WH2(IK))*ATOT/MH2O !attention: g
+
+!       CHANGE OF THE NUMBER OF H2SO4 MOLEC OF 1 DROPLET DURING DT
+!       IT IS FOR KEM BUT THERE ARE OTHER WAYS
+
+      ENDIF  
+
+      ENDDO !loop over bins
+
+      END SUBROUTINE condens_evapor_rate_kelvin
+      
+!********************************************************************
+      SUBROUTINE condens_evapor_rate(R2SO4G,t_seri,pplay,ACTSO4,R2SO4, &
+                   & DENSO4,f_r_wet,FL,ASO4,DNDR)
+!
+!     INPUT: 
+!     R2SO4: aerosol H2SO4 weight fraction (percent)
+!     ACTSO4: H2SO4 activity
+!     R2SO4G: number density of gaseous H2SO4 [molecules/cm3]
+!     t_seri: temperature (K)
+!     DENSO4: aerosol density (gr/cm3)
+
+      USE aerophys
+      USE infotrac_phy
+      USE yomcst_mod_h, ONLY : RPI
+      USE strataer_local_var_mod, ONLY : ALPH2SO4, RRSI
+
+      IMPLICIT NONE
+
+      ! input variables
+      REAL R2SO4G !H2SO4 number density [molecules/cm3]
+      REAL t_seri
+      REAL pplay
+      REAL ACTSO4
+      REAL R2SO4
+      REAL DENSO4
+      REAL f_r_wet
+      
+      ! output variables
+      REAL FL(nbtr_bin)
+      REAL ASO4(nbtr_bin)
+      REAL DNDR(nbtr_bin)
+
+      ! local variables
+      INTEGER IK
+      REAL ALPHA,CST
+      REAL WH2,RP,VTK,AA,FL1,RKNUD
+      REAL DND
+      REAL ATOT,AH2O
+      REAL RRSI_wet(nbtr_bin)
+      REAL FPATH
+
+! ///    MOLEC CONDENSATION GROWTH (DUE TO CHANGES IN H2SO4 AND SO H2O)
+!    ------------------------------------------------------------------
+!                                  EXCEPT CN
+!       RK:H2SO4 WEIGHT PERCENT DOESN'T CHANGE
+!     BE CAREFUL,H2SO4 WEIGHT PERCENTAGE
+
+!                   MOLECULAR ACCOMODATION OF H2SO4
+!     H2SO4 accommodation coefficient [condensation/evaporation]
+      ALPHA = ALPH2SO4
+!      FPLAIR=(2.281238E-5)*TAIR/PAIR
+!     1.E2 (m to cm), 
+      CST=1.E2*2.281238E-5
+
+      ! compute local wet particle radius [cm]
+      RRSI_wet(:)=RRSI(:)*f_r_wet
+      
+!     Pruppa and Klett
+      FPATH=CST*t_seri/pplay
+
+      
+!     H2SO4 mass fraction in aerosol
+      WH2=R2SO4*1.0E-2
+      IF(WH2.EQ.0.0) RETURN
+!                               ACTIVITY COEFFICIENT(SEE GIAUQUE,1951)
+!                               AYERS ET AL (1980)
+!                                  (MU-MU0)
+      RP=-10156.0/t_seri +16.259-(ACTSO4*4.184)/(8.31441*t_seri)
+!                                  DROPLET H2SO4 PRESSURE IN DYN.CM-2
+      RP=EXP(RP)*1.01325E6/0.086
+!      RP=EXP(RP)*1.01325E6
+!                                  H2SO4 NUMBER DENSITY NEAR DROPLET
+!     R=8.31E7 DYN.CM.MOL-1*K-1
+!                               R/AVOGADRO NUMBER=DYN.CM.MOLEC-1*K-1
+      DND=RP*6.02E23/(8.31E7*t_seri)
+!                                  MEAN KINETIC VELOCITY
+!     DYN*CM*K/(K*GR)=(CM/SEC2)*CM
+!                                  IN CM/SEC
+      VTK=SQRT(8.0*BOLZ*t_seri/(RPI*MH2SO4))
+!                                 KELVIN EFFECT FACTOR
+!CK 20160613: bug fix, removed factor 250 (from original code by S. Bekki)
+!      AA =2.0*MH2O*72.0/(DENSO4*BOLZ*t_seri*250.0)
+      AA =2.0*MH2O*72.0/(DENSO4*BOLZ*t_seri)
+
+!     Loop on bin radius (RRSI in cm)
+      DO IK=1,nbtr_bin
+!                                 KELVIN EFFECT
+        DNDR(IK) =DND*EXP(AA/RRSI_wet(IK))
+
+        FL1=RPI*ALPHA*VTK*(R2SO4G-DNDR(IK))
+
+!       TURCO(1979) FOR HNO3:ALH2SO4 CONDENSATION= ALH2SO4 EVAPORATION
+!       RPI*R2*VTK IS EQUIVALENT TO DIFFUSION COEFFICIENT
+!       EXTENSION OF THE RELATION FOR DIFFUSION KINETICS
+!       KNUDSEN NUMBER FPATH/RRSI
+!       NEW VERSION (SEE NOTES)
+        RKNUD=FPATH/RRSI_wet(IK)
+!       SENFELD
+        FL(IK)=FL1*RRSI_wet(IK)**2*( 1.0 +RKNUD ) & 
+     &     /( 1.0 +ALPHA/(2.0*RKNUD) +RKNUD )
+!       TURCO
+!        RL= (4.0/3.0 +0.71/RKNUD)/(1.0+1.0/RKNUD)
+!     *         +4.0*(1.0-ALPHA)/(3.0*ALPHA)
+!        FL=FL1*RRSI(IK)*RRSI(IK)
+!     *         /( (3.0*ALPHA/4.0)*(1.0/RKNUD+RL*ALPHA) )
+
+!                         INITIAL NUMBER OF H2SO4 MOLEC OF 1 DROPLET
+        ATOT=4.0*RPI*DENSO4*(RRSI_wet(IK)**3)/3.0 !attention: g and cm
+        ASO4(IK)=WH2*ATOT/MH2SO4 !attention: g
+!        ATOT=4.0*RPI*dens_aer(I,J)/1000.*(RRSI(IK)**3)/3.0
+!        ASO4=mfrac_H2SO4*ATOT/MH2SO4
+!                        INITIAL NUMBER OF H2O MOLEC OF 1 DROPLET
+        AH2O=(1.0-WH2)*ATOT/MH2O !attention: g
+
+!       CHANGE OF THE NUMBER OF H2SO4 MOLEC OF 1 DROPLET DURING DT
+!       IT IS FOR KEM BUT THERE ARE OTHER WAYS
+
+      ENDDO !loop over bins
+
+      END SUBROUTINE condens_evapor_rate
+
+!********************************************************************
+      SUBROUTINE condens_evapor_part(dt,FL,ASO4,f_r_wet,tr_seri)
+
+      USE aerophys
+      USE infotrac_phy
+      USE yomcst_mod_h, ONLY : RPI
+      USE strataer_local_var_mod, ONLY : RRSI,Vbin
+      
+      IMPLICIT NONE
+
+      ! input variables
+      REAL dt
+      REAL FL(nbtr_bin)
+      REAL ASO4(nbtr_bin)
+      REAL f_r_wet
+      
+      ! output variables
+      REAL tr_seri(nbtr)
+      
+      ! local variables
+      REAL tr_seri_new(nbtr)
+      INTEGER IK,JK,k
+      REAL Vnew
+      REAL RRSI_wet(nbtr_bin)
+      REAL Vbin_wet(nbtr_bin)
+      REAL sum_IK(nbtr_bin)
+      REAL ff(nbtr_bin,nbtr_bin)
+
+      tr_seri_new(:)=tr_seri(:)
+
+      ! compute local wet particle radius and volume
+      RRSI_wet(:)=RRSI(:)*f_r_wet
+      Vbin_wet(:)=Vbin(:)*f_r_wet**3 *1.e6 !Vbin_wet in cm3 (as Vnew)
+
+      ! compute distribution factor for particles of intermediate size (from Jacobson 1994, equation 13)
+      DO IK=1,nbtr_bin
+        Vnew=4.0*RPI*(RRSI_wet(IK)**3)/3.0*(1.+FL(IK)*dt/ASO4(IK))
+        ff(IK,:)=0.0 
+        DO k=1, nbtr_bin 
+          IF (k.LE.(nbtr_bin-1)) THEN 
+            IF (Vbin_wet(k).LE.Vnew.AND.Vnew.LT.Vbin_wet(k+1)) THEN
+              ff(IK,k)= Vbin_wet(k)/Vnew*(Vbin_wet(k+1)-Vnew)/(Vbin_wet(k+1)-Vbin_wet(k))
+            ENDIF
+          ENDIF
+          IF (k.EQ.1.AND.Vnew.LE.Vbin_wet(k)) THEN
+            ff(IK,k)= 1.
+          ENDIF
+          IF (k.GT.1) THEN 
+            IF (Vbin_wet(k-1).LT.Vnew.AND.Vnew.LT.Vbin_wet(k)) THEN
+              ff(IK,k)= 1.-ff(IK,k-1)
+            ENDIF
+          ENDIF
+          IF (k.EQ.nbtr_bin.AND.Vnew.GE.Vbin_wet(k)) THEN
+            ff(IK,k)= 1.
+          ENDIF
+        ENDDO
+        ! correction of ff for volume conservation
+        DO k=1, nbtr_bin         
+          ff(IK,k)=ff(IK,k)*Vnew/Vbin_wet(k)
+        ENDDO
+      ENDDO !loop over bins
+
+      DO IK=1, nbtr_bin
+        sum_IK(IK)=0.0
+        DO JK=1, nbtr_bin
+          sum_IK(IK)=sum_IK(IK)+tr_seri(JK+nbtr_sulgas)*ff(JK,IK)
+        ENDDO
+        ! compute new particle concentrations
+        tr_seri_new(IK+nbtr_sulgas)=sum_IK(IK)
+      ENDDO
+
+      tr_seri(:)=tr_seri_new(:)
+
+      END SUBROUTINE condens_evapor_part
+
+END MODULE cond_evap_tstep_mod
Index: DZ6/trunk/libf/phylmd/StratAer/interp_sulf_input.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/StratAer/interp_sulf_input.F90	(revision 5267)
+++ 	(revision )
@@ -1,357 +1,0 @@
-!
-! $Id$
-!
-SUBROUTINE interp_sulf_input(debutphy,pdtphys,paprs,tr_seri)
-
-  USE netcdf95, ONLY: nf95_close, nf95_gw_var, nf95_inq_dimid, & 
-                      nf95_inq_varid, nf95_inquire_dimension, nf95_open
-  USE netcdf, ONLY: nf90_get_var, nf90_noerr, nf90_nowrite
-
-  USE mod_grid_phy_lmdz
-  USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
-  USE mod_phys_lmdz_omp_data, ONLY :  is_omp_root
-  USE phys_local_var_mod, ONLY : budg_3D_backgr_ocs, budg_3D_backgr_so2
-  USE phys_local_var_mod, ONLY : OCS_lifetime, SO2_lifetime, H2SO4_lifetime, O3_clim
-  USE mod_phys_lmdz_para 
-  USE dimphy
-  USE phys_cal_mod
-  USE infotrac_phy
-  USE aerophys
-  USE yomcst_mod_h
-  USE strataer_local_var_mod, ONLY : flag_newclim_file,flag_verbose_strataer
-
-  IMPLICIT NONE
-
-  include "dimensions.h"
-
-! Variable input
-  REAL paprs(klon,klev+1)
-  REAL tr_seri(klon,klev,nbtr)
-  REAL, INTENT(IN)    :: pdtphys    ! Pas d'integration pour la physique (seconde)
-  LOGICAL, INTENT(IN) :: debutphy   ! le flag de l'initialisation de la physique
-
-! Variables locales
-  INTEGER n_lat   ! number of latitudes in the input data
-  INTEGER n_lon   ! number of longitudes in the input data
-  INTEGER, SAVE :: n_lev   ! number of levels in the input data
-!$OMP THREADPRIVATE(n_lev)
-  INTEGER n_mth   ! number of months in the input data
-  INTEGER, SAVE :: mth_pre
-!$OMP THREADPRIVATE(mth_pre)
-
-! Champs reconstitues
-  REAL paprs_glo(klon_glo,klev+1)
-
-  REAL, ALLOCATABLE :: latitude(:)
-! (of input data sorted in strictly ascending order)
-
-  REAL, ALLOCATABLE :: longitude(:)
-! (of input data sorted in strictly ascending order)
-
-  REAL, ALLOCATABLE :: time(:)
-! (of input data sorted in strictly ascending order)
-
-  REAL, ALLOCATABLE :: lev(:)
-! levels of input data
-
-  REAL, ALLOCATABLE :: OCS_clim_in(:, :, :, :)
-  REAL, ALLOCATABLE :: SO2_clim_in(:, :, :, :)
-  REAL, ALLOCATABLE :: OCS_clim_mth(:, :, :)
-  REAL, ALLOCATABLE :: SO2_clim_mth(:, :, :)
-  REAL, ALLOCATABLE :: OCS_clim_tmp(:, :)
-  REAL, ALLOCATABLE :: SO2_clim_tmp(:, :)
-  REAL OCS_clim_glo(klon_glo,klev)
-  REAL SO2_clim_glo(klon_glo,klev)
-  
-  REAL, ALLOCATABLE :: O3_clim_in(:, :, :, :)
-  REAL, ALLOCATABLE :: O3_clim_mth(:, :, :)
-  REAL, ALLOCATABLE :: O3_clim_tmp(:, :)
-  REAL O3_clim_glo(klon_glo,klev)
-  
-  ! fixed climatos
-  REAL, ALLOCATABLE :: OCS_lifetime_in(:, :, :, :)
-  REAL, ALLOCATABLE :: SO2_lifetime_in(:, :, :, :)
-  REAL, ALLOCATABLE :: OCS_lifetime_mth(:, :, :)
-  REAL, ALLOCATABLE :: SO2_lifetime_mth(:, :, :)
-  REAL, ALLOCATABLE :: OCS_lifetime_tmp(:, :)
-  REAL, ALLOCATABLE :: SO2_lifetime_tmp(:, :)
-  REAL OCS_lifetime_glo(klon_glo,klev)
-  REAL SO2_lifetime_glo(klon_glo,klev)
-  
-  REAL, ALLOCATABLE :: H2SO4_lifetime_in(:, :, :, :)
-  REAL, ALLOCATABLE :: H2SO4_lifetime_mth(:, :, :)
-  REAL, ALLOCATABLE :: H2SO4_lifetime_tmp(:, :)
-
-  REAL H2SO4_lifetime_glo(klon_glo,klev)
-!
-  REAL, ALLOCATABLE, SAVE :: OCS_clim(:,:)
-  REAL, ALLOCATABLE, SAVE :: SO2_clim(:,:)
-!$OMP THREADPRIVATE(OCS_clim,SO2_clim)
-!
-  INTEGER i, k, kk, j
-  REAL p_bound
-
-! For NetCDF:
-  INTEGER             :: ncid_in  ! IDs for input files
-  INTEGER             :: varid, ncerr
-  CHARACTER (LEN=3)   :: nc_lat, nc_lon
-  CHARACTER (LEN=256) :: nc_fname
-    
-  INTEGER, PARAMETER :: lev_input=17
-!--pressure at interfaces of input data (in Pa)
-  REAL, DIMENSION(lev_input+1), PARAMETER ::          & 
-                    paprs_input=(/                    &
-  1.00000002e+05,   6.06530673e+04,   3.67879449e+04, &
-  2.23130165e+04,   1.35335286e+04,   8.20850004e+03, &
-  4.97870695e+03,   3.01973841e+03,   1.83156393e+03, &
-  1.11089968e+03,   6.73794715e+02,   4.08677153e+02, &
-  2.47875223e+02,   1.50343923e+02,   9.11881985e+01, &
-  5.53084382e+01,   3.35462635e+01,   0.0           /)
-!
- IF (.NOT.ALLOCATED(OCS_clim)) ALLOCATE(OCS_clim(klon,klev))
- IF (.NOT.ALLOCATED(SO2_clim)) ALLOCATE(SO2_clim(klon,klev))
-
-  IF (debutphy.OR.mth_cur.NE.mth_pre) THEN
-
-!--preparation of global fields
-  CALL gather(paprs, paprs_glo)
-
-  IF (is_mpi_root.AND.is_omp_root) THEN
-
-    !--init ncdf variables
-    IF(flag_newclim_file) THEN
-      nc_fname = "ocs_so2_h2so4_annual_lmdz.nc"
-      nc_lat   = "LAT"
-      nc_lon   = "LON"
-    ELSE
-      ! old file for retro compatibility
-      nc_fname = "ocs_so2_annual_lmdz.nc"
-      nc_lat   = "lat"
-      nc_lon   = "lon"
-    ENDIF
-
-    !--reading emission files
-    CALL nf95_open(nc_fname, nf90_nowrite, ncid_in)
-    IF(flag_verbose_strataer) print *, "Open file ", nc_fname
-    
-    CALL nf95_inq_varid(ncid_in, "LEV", varid)
-    CALL nf95_gw_var(ncid_in, varid, lev)
-    n_lev = size(lev)
-    
-    CALL nf95_inq_varid(ncid_in, nc_lat, varid)
-    CALL nf95_gw_var(ncid_in, varid, latitude)
-    n_lat = size(latitude)
-    
-    CALL nf95_inq_varid(ncid_in, nc_lon, varid)
-    CALL nf95_gw_var(ncid_in, varid, longitude)
-    n_lon = size(longitude)
-    
-    CALL nf95_inq_varid(ncid_in, "TIME", varid)
-    CALL nf95_gw_var(ncid_in, varid, time)
-    n_mth = size(time)
-    
-    IF (.NOT.ALLOCATED(OCS_clim_in))     ALLOCATE(OCS_clim_in(n_lon, n_lat, n_lev, n_mth))
-    IF (.NOT.ALLOCATED(SO2_clim_in))     ALLOCATE(SO2_clim_in(n_lon, n_lat, n_lev, n_mth))
-    IF (.NOT.ALLOCATED(O3_clim_in))      ALLOCATE(O3_clim_in(n_lon, n_lat, n_lev, n_mth))
-    
-    IF (.NOT.ALLOCATED(OCS_lifetime_in)) ALLOCATE(OCS_lifetime_in(n_lon, n_lat, n_lev, n_mth))
-    IF (.NOT.ALLOCATED(SO2_lifetime_in)) ALLOCATE(SO2_lifetime_in(n_lon, n_lat, n_lev, n_mth))
-    IF (.NOT.ALLOCATED(H2SO4_lifetime_in)) ALLOCATE(H2SO4_lifetime_in(n_lon, n_lat, n_lev, n_mth))
-    
-    CALL nf95_inq_varid(ncid_in, "OCS", varid)
-    ncerr = nf90_get_var(ncid_in, varid, OCS_clim_in)
-    IF(flag_verbose_strataer) print *,'code erreur OCS=', ncerr, varid
-
-    CALL nf95_inq_varid(ncid_in, "SO2", varid)
-    ncerr = nf90_get_var(ncid_in, varid, SO2_clim_in)
-    IF(flag_verbose_strataer) print *,'code erreur SO2=', ncerr, varid
-
-    CALL nf95_inq_varid(ncid_in, "OCS_LIFET", varid)
-    ncerr = nf90_get_var(ncid_in, varid, OCS_lifetime_in)
-    IF(flag_verbose_strataer) print *,'code erreur OCS_lifetime_in=', ncerr, varid
-
-    CALL nf95_inq_varid(ncid_in, "SO2_LIFET", varid)
-    ncerr = nf90_get_var(ncid_in, varid, SO2_lifetime_in)
-    IF(flag_verbose_strataer) print *,'code erreur SO2_lifetime_in=', ncerr, varid
-    
-    IF(flag_newclim_file) THEN
-       CALL nf95_inq_varid(ncid_in, "O3", varid)
-       ncerr = nf90_get_var(ncid_in, varid, O3_clim_in)
-       IF(flag_verbose_strataer) print *,'code erreur O3=', ncerr, varid
-       
-       CALL nf95_inq_varid(ncid_in, "H2SO4_LIFET", varid)
-       ncerr = nf90_get_var(ncid_in, varid, H2SO4_lifetime_in)
-       IF(flag_verbose_strataer) print *,'code erreur H2SO4_lifetime_in=', ncerr, varid
-    ENDIF
-    
-    CALL nf95_close(ncid_in)
-
-    IF (.NOT.ALLOCATED(OCS_clim_mth)) ALLOCATE(OCS_clim_mth(n_lon, n_lat, n_lev))
-    IF (.NOT.ALLOCATED(SO2_clim_mth)) ALLOCATE(SO2_clim_mth(n_lon, n_lat, n_lev))
-    IF (.NOT.ALLOCATED(OCS_clim_tmp)) ALLOCATE(OCS_clim_tmp(klon_glo, n_lev))
-    IF (.NOT.ALLOCATED(SO2_clim_tmp)) ALLOCATE(SO2_clim_tmp(klon_glo, n_lev))
-    IF (.NOT.ALLOCATED(O3_clim_mth))  ALLOCATE(O3_clim_mth(n_lon, n_lat, n_lev))
-    IF (.NOT.ALLOCATED(O3_clim_tmp))  ALLOCATE(O3_clim_tmp(klon_glo, n_lev))
-    
-    IF (.NOT.ALLOCATED(OCS_lifetime_mth)) ALLOCATE(OCS_lifetime_mth(n_lon, n_lat, n_lev))
-    IF (.NOT.ALLOCATED(SO2_lifetime_mth)) ALLOCATE(SO2_lifetime_mth(n_lon, n_lat, n_lev))
-    IF (.NOT.ALLOCATED(OCS_lifetime_tmp)) ALLOCATE(OCS_lifetime_tmp(klon_glo, n_lev))
-    IF (.NOT.ALLOCATED(SO2_lifetime_tmp)) ALLOCATE(SO2_lifetime_tmp(klon_glo, n_lev))
-    IF (.NOT.ALLOCATED(H2SO4_lifetime_mth)) ALLOCATE(H2SO4_lifetime_mth(n_lon, n_lat, n_lev))
-    IF (.NOT.ALLOCATED(H2SO4_lifetime_tmp)) ALLOCATE(H2SO4_lifetime_tmp(klon_glo, n_lev))
-    
-!---select the correct month, undo multiplication with 1.e12 (precision reasons)
-!---correct latitudinal order and convert input from volume mixing ratio to mass mixing ratio
-    DO j=1,n_lat
-      SO2_clim_mth(:,j,:) = 1.e-12*SO2_clim_in(:,n_lat+1-j,:,mth_cur)*mSO2mol/mAIRmol
-      OCS_clim_mth(:,j,:) = 1.e-12*OCS_clim_in(:,n_lat+1-j,:,mth_cur)*mOCSmol/mAIRmol
-      SO2_lifetime_mth(:,j,:) = SO2_lifetime_in(:,n_lat+1-j,:,mth_cur)
-      OCS_lifetime_mth(:,j,:) = OCS_lifetime_in(:,n_lat+1-j,:,mth_cur)
-      
-      ! O3 from 2d model is not tracer, in VMR
-      IF(flag_newclim_file) THEN
-         H2SO4_lifetime_mth(:,j,:) = H2SO4_lifetime_in(:,n_lat+1-j,:,mth_cur)
-         ! new input files
-         O3_clim_mth(:,j,:) = 1.e-6*O3_clim_in(:,n_lat+1-j,:,mth_cur)
-      ELSE
-         H2SO4_lifetime_mth(:,j,:) = 1.e-6
-         O3_clim_mth(:,j,:) = 1.e-6
-      ENDIF
-    ENDDO
-
-!---reduce to a klon_glo grid but keep the levels
-    CALL grid2dTo1d_glo(OCS_clim_mth,OCS_clim_tmp)
-    CALL grid2dTo1d_glo(SO2_clim_mth,SO2_clim_tmp)
-    CALL grid2dTo1d_glo(O3_clim_mth,O3_clim_tmp)
-    
-    CALL grid2dTo1d_glo(OCS_lifetime_mth,OCS_lifetime_tmp)
-    CALL grid2dTo1d_glo(SO2_lifetime_mth,SO2_lifetime_tmp)
-    CALL grid2dTo1d_glo(H2SO4_lifetime_mth,H2SO4_lifetime_tmp)
-
-!--set lifetime to very high value in uninsolated areas
-    DO i=1, klon_glo
-      DO kk=1, n_lev
-!--added tests on VMR of species for realism
-        IF (OCS_clim_tmp(i,kk).LT.1.e-20) THEN
-          OCS_clim_tmp(i,kk)=1.0e-20
-        ENDIF
-        IF (SO2_clim_tmp(i,kk).LT.1.e-20) THEN
-          SO2_clim_tmp(i,kk)=1.0e-20
-        ENDIF
-        !       50 ppbv min for O3
-        IF (O3_clim_tmp(i,kk).LT.50.0e-9) THEN
-           O3_clim_tmp(i,kk)=50.0e-9
-        ENDIF
-        
-        IF (OCS_lifetime_tmp(i,kk)==0.0) THEN
-          OCS_lifetime_tmp(i,kk)=1.0e12
-        ENDIF
-        IF (SO2_lifetime_tmp(i,kk)==0.0) THEN
-          SO2_lifetime_tmp(i,kk)=1.0e12
-        ENDIF
-       IF (H2SO4_lifetime_tmp(i,kk)==0.0) THEN
-          H2SO4_lifetime_tmp(i,kk)=1.0e12
-       ENDIF
-      ENDDO
-    ENDDO
-
-  !---regrid weighted lifetime and climatologies
-  DO i=1, klon_glo
-    DO k=1, klev
-     OCS_lifetime_glo(i,k)=0.0
-     SO2_lifetime_glo(i,k)=0.0
-     O3_clim_glo(i,k)=0.0
-     
-     OCS_clim_glo(i,k)=0.0
-     SO2_clim_glo(i,k)=0.0
-     H2SO4_lifetime_glo(i,k)=0.0
-     
-     DO kk=1, n_lev
-      OCS_lifetime_glo(i,k)=OCS_lifetime_glo(i,k)+ &
-           MAX(0.0,MIN(paprs_glo(i,k),paprs_input(kk))-MAX(paprs_glo(i,k+1),paprs_input(kk+1))) &
-           *OCS_lifetime_tmp(i,kk)/(paprs_glo(i,k)-paprs_glo(i,k+1))
-      SO2_lifetime_glo(i,k)=SO2_lifetime_glo(i,k)+ &
-           MAX(0.0,MIN(paprs_glo(i,k),paprs_input(kk))-MAX(paprs_glo(i,k+1),paprs_input(kk+1))) &
-           *SO2_lifetime_tmp(i,kk)/(paprs_glo(i,k)-paprs_glo(i,k+1))
-      IF(flag_newclim_file) THEN
-         H2SO4_lifetime_glo(i,k)=H2SO4_lifetime_glo(i,k)+ &
-              MAX(0.0,MIN(paprs_glo(i,k),paprs_input(kk)) &
-              -MAX(paprs_glo(i,k+1),paprs_input(kk+1))) &
-              *H2SO4_lifetime_tmp(i,kk)/(paprs_glo(i,k)-paprs_glo(i,k+1))
-      ENDIF
-      
-      OCS_clim_glo(i,k)=OCS_clim_glo(i,k)+ &
-           MAX(0.0,MIN(paprs_glo(i,k),paprs_input(kk))-MAX(paprs_glo(i,k+1),paprs_input(kk+1))) &
-           *OCS_clim_tmp(i,kk)/(paprs_glo(i,k)-paprs_glo(i,k+1))
-      SO2_clim_glo(i,k)=SO2_clim_glo(i,k)+ &
-           MAX(0.0,MIN(paprs_glo(i,k),paprs_input(kk))-MAX(paprs_glo(i,k+1),paprs_input(kk+1))) &
-           *SO2_clim_tmp(i,kk)/(paprs_glo(i,k)-paprs_glo(i,k+1))
-      IF(flag_newclim_file) THEN
-         O3_clim_glo(i,k)=O3_clim_glo(i,k)+ &
-              MAX(0.0,MIN(paprs_glo(i,k),paprs_input(kk)) &
-              -MAX(paprs_glo(i,k+1),paprs_input(kk+1))) &
-              *O3_clim_tmp(i,kk)/(paprs_glo(i,k)-paprs_glo(i,k+1))
-      ENDIF
-      ENDDO
-    ENDDO
-  ENDDO
-
-  ENDIF !--is_mpi_root and is_omp_root
-
-!--keep memory of previous month
-  mth_pre=mth_cur
-
-!--scatter global fields around
-  CALL scatter(OCS_clim_glo, OCS_clim)
-  CALL scatter(SO2_clim_glo, SO2_clim)
-  CALL scatter(O3_clim_glo, O3_clim)
-  CALL scatter(OCS_lifetime_glo, OCS_lifetime)
-  CALL scatter(SO2_lifetime_glo, SO2_lifetime)
-  CALL scatter(H2SO4_lifetime_glo, H2SO4_lifetime)
-  
-  IF (is_mpi_root.AND.is_omp_root) THEN
-!
-    DEALLOCATE(OCS_clim_in,SO2_clim_in,O3_clim_in)
-    DEALLOCATE(OCS_clim_mth,SO2_clim_mth,O3_clim_mth)
-    DEALLOCATE(OCS_clim_tmp,SO2_clim_tmp,O3_clim_tmp)
-    DEALLOCATE(OCS_lifetime_in, SO2_lifetime_in, H2SO4_lifetime_in)
-    DEALLOCATE(OCS_lifetime_mth, SO2_lifetime_mth, H2SO4_lifetime_mth)
-    DEALLOCATE(OCS_lifetime_tmp, SO2_lifetime_tmp, H2SO4_lifetime_tmp)
-!
-  ENDIF !--is_mpi_root and is_omp_root
-
-  ENDIF ! debutphy.OR.new month
-
-!--set to background value everywhere in the very beginning, later only in the troposphere
-!--a little dangerous as the MAXVAL is not computed on the global field
-  IF (debutphy.AND.MAXVAL(tr_seri).LT.1.e-30) THEN
-    p_bound=0.0
-  ELSE
-    p_bound=50000.
-  ENDIF
-
-!--regridding tracer concentration on the vertical
-  DO i=1, klon
-    DO k=1, klev
-      !
-      !--OCS and SO2 prescribed back to their clim values below p_bound
-      IF (paprs(i,k).GT.p_bound) THEN
-        budg_3D_backgr_ocs(i,k)=OCS_clim(i,k)-tr_seri(i,k,id_OCS_strat)
-        budg_3D_backgr_so2(i,k)=SO2_clim(i,k)-tr_seri(i,k,id_SO2_strat)
-        tr_seri(i,k,id_OCS_strat)=OCS_clim(i,k)
-        tr_seri(i,k,id_SO2_strat)=SO2_clim(i,k)
-      ENDIF
-    ENDDO
-  ENDDO
-
-  !convert SO2_backgr_tend from kg(SO2)/kgA to kg(S)/m2/layer/s for saving as diagnostic
-  DO i=1, klon
-    DO k=1, klev
-      budg_3D_backgr_ocs(i,k)=budg_3D_backgr_ocs(i,k)*mSatom/mOCSmol*(paprs(i,k)-paprs(i,k+1))/RG/pdtphys
-      budg_3D_backgr_so2(i,k)=budg_3D_backgr_so2(i,k)*mSatom/mSO2mol*(paprs(i,k)-paprs(i,k+1))/RG/pdtphys
-    ENDDO
-  ENDDO
- 
-  RETURN
-
-END SUBROUTINE interp_sulf_input
Index: /LMDZ6/trunk/libf/phylmd/StratAer/interp_sulf_input.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/StratAer/interp_sulf_input.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/StratAer/interp_sulf_input.f90	(revision 5268)
@@ -0,0 +1,357 @@
+!
+! $Id$
+!
+SUBROUTINE interp_sulf_input(debutphy,pdtphys,paprs,tr_seri)
+
+  USE netcdf95, ONLY: nf95_close, nf95_gw_var, nf95_inq_dimid, & 
+                      nf95_inq_varid, nf95_inquire_dimension, nf95_open
+  USE netcdf, ONLY: nf90_get_var, nf90_noerr, nf90_nowrite
+
+  USE mod_grid_phy_lmdz
+  USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+  USE mod_phys_lmdz_omp_data, ONLY :  is_omp_root
+  USE phys_local_var_mod, ONLY : budg_3D_backgr_ocs, budg_3D_backgr_so2
+  USE phys_local_var_mod, ONLY : OCS_lifetime, SO2_lifetime, H2SO4_lifetime, O3_clim
+  USE mod_phys_lmdz_para 
+  USE dimphy
+  USE phys_cal_mod
+  USE infotrac_phy
+  USE aerophys
+  USE yomcst_mod_h
+  USE strataer_local_var_mod, ONLY : flag_newclim_file,flag_verbose_strataer
+
+  IMPLICIT NONE
+
+  include "dimensions.h"
+
+! Variable input
+  REAL paprs(klon,klev+1)
+  REAL tr_seri(klon,klev,nbtr)
+  REAL, INTENT(IN)    :: pdtphys    ! Pas d'integration pour la physique (seconde)
+  LOGICAL, INTENT(IN) :: debutphy   ! le flag de l'initialisation de la physique
+
+! Variables locales
+  INTEGER n_lat   ! number of latitudes in the input data
+  INTEGER n_lon   ! number of longitudes in the input data
+  INTEGER, SAVE :: n_lev   ! number of levels in the input data
+!$OMP THREADPRIVATE(n_lev)
+  INTEGER n_mth   ! number of months in the input data
+  INTEGER, SAVE :: mth_pre
+!$OMP THREADPRIVATE(mth_pre)
+
+! Champs reconstitues
+  REAL paprs_glo(klon_glo,klev+1)
+
+  REAL, ALLOCATABLE :: latitude(:)
+! (of input data sorted in strictly ascending order)
+
+  REAL, ALLOCATABLE :: longitude(:)
+! (of input data sorted in strictly ascending order)
+
+  REAL, ALLOCATABLE :: time(:)
+! (of input data sorted in strictly ascending order)
+
+  REAL, ALLOCATABLE :: lev(:)
+! levels of input data
+
+  REAL, ALLOCATABLE :: OCS_clim_in(:, :, :, :)
+  REAL, ALLOCATABLE :: SO2_clim_in(:, :, :, :)
+  REAL, ALLOCATABLE :: OCS_clim_mth(:, :, :)
+  REAL, ALLOCATABLE :: SO2_clim_mth(:, :, :)
+  REAL, ALLOCATABLE :: OCS_clim_tmp(:, :)
+  REAL, ALLOCATABLE :: SO2_clim_tmp(:, :)
+  REAL OCS_clim_glo(klon_glo,klev)
+  REAL SO2_clim_glo(klon_glo,klev)
+  
+  REAL, ALLOCATABLE :: O3_clim_in(:, :, :, :)
+  REAL, ALLOCATABLE :: O3_clim_mth(:, :, :)
+  REAL, ALLOCATABLE :: O3_clim_tmp(:, :)
+  REAL O3_clim_glo(klon_glo,klev)
+  
+  ! fixed climatos
+  REAL, ALLOCATABLE :: OCS_lifetime_in(:, :, :, :)
+  REAL, ALLOCATABLE :: SO2_lifetime_in(:, :, :, :)
+  REAL, ALLOCATABLE :: OCS_lifetime_mth(:, :, :)
+  REAL, ALLOCATABLE :: SO2_lifetime_mth(:, :, :)
+  REAL, ALLOCATABLE :: OCS_lifetime_tmp(:, :)
+  REAL, ALLOCATABLE :: SO2_lifetime_tmp(:, :)
+  REAL OCS_lifetime_glo(klon_glo,klev)
+  REAL SO2_lifetime_glo(klon_glo,klev)
+  
+  REAL, ALLOCATABLE :: H2SO4_lifetime_in(:, :, :, :)
+  REAL, ALLOCATABLE :: H2SO4_lifetime_mth(:, :, :)
+  REAL, ALLOCATABLE :: H2SO4_lifetime_tmp(:, :)
+
+  REAL H2SO4_lifetime_glo(klon_glo,klev)
+!
+  REAL, ALLOCATABLE, SAVE :: OCS_clim(:,:)
+  REAL, ALLOCATABLE, SAVE :: SO2_clim(:,:)
+!$OMP THREADPRIVATE(OCS_clim,SO2_clim)
+!
+  INTEGER i, k, kk, j
+  REAL p_bound
+
+! For NetCDF:
+  INTEGER             :: ncid_in  ! IDs for input files
+  INTEGER             :: varid, ncerr
+  CHARACTER (LEN=3)   :: nc_lat, nc_lon
+  CHARACTER (LEN=256) :: nc_fname
+    
+  INTEGER, PARAMETER :: lev_input=17
+!--pressure at interfaces of input data (in Pa)
+  REAL, DIMENSION(lev_input+1), PARAMETER ::          & 
+                    paprs_input=(/                    &
+  1.00000002e+05,   6.06530673e+04,   3.67879449e+04, &
+  2.23130165e+04,   1.35335286e+04,   8.20850004e+03, &
+  4.97870695e+03,   3.01973841e+03,   1.83156393e+03, &
+  1.11089968e+03,   6.73794715e+02,   4.08677153e+02, &
+  2.47875223e+02,   1.50343923e+02,   9.11881985e+01, &
+  5.53084382e+01,   3.35462635e+01,   0.0           /)
+!
+ IF (.NOT.ALLOCATED(OCS_clim)) ALLOCATE(OCS_clim(klon,klev))
+ IF (.NOT.ALLOCATED(SO2_clim)) ALLOCATE(SO2_clim(klon,klev))
+
+  IF (debutphy.OR.mth_cur.NE.mth_pre) THEN
+
+!--preparation of global fields
+  CALL gather(paprs, paprs_glo)
+
+  IF (is_mpi_root.AND.is_omp_root) THEN
+
+    !--init ncdf variables
+    IF(flag_newclim_file) THEN
+      nc_fname = "ocs_so2_h2so4_annual_lmdz.nc"
+      nc_lat   = "LAT"
+      nc_lon   = "LON"
+    ELSE
+      ! old file for retro compatibility
+      nc_fname = "ocs_so2_annual_lmdz.nc"
+      nc_lat   = "lat"
+      nc_lon   = "lon"
+    ENDIF
+
+    !--reading emission files
+    CALL nf95_open(nc_fname, nf90_nowrite, ncid_in)
+    IF(flag_verbose_strataer) print *, "Open file ", nc_fname
+    
+    CALL nf95_inq_varid(ncid_in, "LEV", varid)
+    CALL nf95_gw_var(ncid_in, varid, lev)
+    n_lev = size(lev)
+    
+    CALL nf95_inq_varid(ncid_in, nc_lat, varid)
+    CALL nf95_gw_var(ncid_in, varid, latitude)
+    n_lat = size(latitude)
+    
+    CALL nf95_inq_varid(ncid_in, nc_lon, varid)
+    CALL nf95_gw_var(ncid_in, varid, longitude)
+    n_lon = size(longitude)
+    
+    CALL nf95_inq_varid(ncid_in, "TIME", varid)
+    CALL nf95_gw_var(ncid_in, varid, time)
+    n_mth = size(time)
+    
+    IF (.NOT.ALLOCATED(OCS_clim_in))     ALLOCATE(OCS_clim_in(n_lon, n_lat, n_lev, n_mth))
+    IF (.NOT.ALLOCATED(SO2_clim_in))     ALLOCATE(SO2_clim_in(n_lon, n_lat, n_lev, n_mth))
+    IF (.NOT.ALLOCATED(O3_clim_in))      ALLOCATE(O3_clim_in(n_lon, n_lat, n_lev, n_mth))
+    
+    IF (.NOT.ALLOCATED(OCS_lifetime_in)) ALLOCATE(OCS_lifetime_in(n_lon, n_lat, n_lev, n_mth))
+    IF (.NOT.ALLOCATED(SO2_lifetime_in)) ALLOCATE(SO2_lifetime_in(n_lon, n_lat, n_lev, n_mth))
+    IF (.NOT.ALLOCATED(H2SO4_lifetime_in)) ALLOCATE(H2SO4_lifetime_in(n_lon, n_lat, n_lev, n_mth))
+    
+    CALL nf95_inq_varid(ncid_in, "OCS", varid)
+    ncerr = nf90_get_var(ncid_in, varid, OCS_clim_in)
+    IF(flag_verbose_strataer) print *,'code erreur OCS=', ncerr, varid
+
+    CALL nf95_inq_varid(ncid_in, "SO2", varid)
+    ncerr = nf90_get_var(ncid_in, varid, SO2_clim_in)
+    IF(flag_verbose_strataer) print *,'code erreur SO2=', ncerr, varid
+
+    CALL nf95_inq_varid(ncid_in, "OCS_LIFET", varid)
+    ncerr = nf90_get_var(ncid_in, varid, OCS_lifetime_in)
+    IF(flag_verbose_strataer) print *,'code erreur OCS_lifetime_in=', ncerr, varid
+
+    CALL nf95_inq_varid(ncid_in, "SO2_LIFET", varid)
+    ncerr = nf90_get_var(ncid_in, varid, SO2_lifetime_in)
+    IF(flag_verbose_strataer) print *,'code erreur SO2_lifetime_in=', ncerr, varid
+    
+    IF(flag_newclim_file) THEN
+       CALL nf95_inq_varid(ncid_in, "O3", varid)
+       ncerr = nf90_get_var(ncid_in, varid, O3_clim_in)
+       IF(flag_verbose_strataer) print *,'code erreur O3=', ncerr, varid
+       
+       CALL nf95_inq_varid(ncid_in, "H2SO4_LIFET", varid)
+       ncerr = nf90_get_var(ncid_in, varid, H2SO4_lifetime_in)
+       IF(flag_verbose_strataer) print *,'code erreur H2SO4_lifetime_in=', ncerr, varid
+    ENDIF
+    
+    CALL nf95_close(ncid_in)
+
+    IF (.NOT.ALLOCATED(OCS_clim_mth)) ALLOCATE(OCS_clim_mth(n_lon, n_lat, n_lev))
+    IF (.NOT.ALLOCATED(SO2_clim_mth)) ALLOCATE(SO2_clim_mth(n_lon, n_lat, n_lev))
+    IF (.NOT.ALLOCATED(OCS_clim_tmp)) ALLOCATE(OCS_clim_tmp(klon_glo, n_lev))
+    IF (.NOT.ALLOCATED(SO2_clim_tmp)) ALLOCATE(SO2_clim_tmp(klon_glo, n_lev))
+    IF (.NOT.ALLOCATED(O3_clim_mth))  ALLOCATE(O3_clim_mth(n_lon, n_lat, n_lev))
+    IF (.NOT.ALLOCATED(O3_clim_tmp))  ALLOCATE(O3_clim_tmp(klon_glo, n_lev))
+    
+    IF (.NOT.ALLOCATED(OCS_lifetime_mth)) ALLOCATE(OCS_lifetime_mth(n_lon, n_lat, n_lev))
+    IF (.NOT.ALLOCATED(SO2_lifetime_mth)) ALLOCATE(SO2_lifetime_mth(n_lon, n_lat, n_lev))
+    IF (.NOT.ALLOCATED(OCS_lifetime_tmp)) ALLOCATE(OCS_lifetime_tmp(klon_glo, n_lev))
+    IF (.NOT.ALLOCATED(SO2_lifetime_tmp)) ALLOCATE(SO2_lifetime_tmp(klon_glo, n_lev))
+    IF (.NOT.ALLOCATED(H2SO4_lifetime_mth)) ALLOCATE(H2SO4_lifetime_mth(n_lon, n_lat, n_lev))
+    IF (.NOT.ALLOCATED(H2SO4_lifetime_tmp)) ALLOCATE(H2SO4_lifetime_tmp(klon_glo, n_lev))
+    
+!---select the correct month, undo multiplication with 1.e12 (precision reasons)
+!---correct latitudinal order and convert input from volume mixing ratio to mass mixing ratio
+    DO j=1,n_lat
+      SO2_clim_mth(:,j,:) = 1.e-12*SO2_clim_in(:,n_lat+1-j,:,mth_cur)*mSO2mol/mAIRmol
+      OCS_clim_mth(:,j,:) = 1.e-12*OCS_clim_in(:,n_lat+1-j,:,mth_cur)*mOCSmol/mAIRmol
+      SO2_lifetime_mth(:,j,:) = SO2_lifetime_in(:,n_lat+1-j,:,mth_cur)
+      OCS_lifetime_mth(:,j,:) = OCS_lifetime_in(:,n_lat+1-j,:,mth_cur)
+      
+      ! O3 from 2d model is not tracer, in VMR
+      IF(flag_newclim_file) THEN
+         H2SO4_lifetime_mth(:,j,:) = H2SO4_lifetime_in(:,n_lat+1-j,:,mth_cur)
+         ! new input files
+         O3_clim_mth(:,j,:) = 1.e-6*O3_clim_in(:,n_lat+1-j,:,mth_cur)
+      ELSE
+         H2SO4_lifetime_mth(:,j,:) = 1.e-6
+         O3_clim_mth(:,j,:) = 1.e-6
+      ENDIF
+    ENDDO
+
+!---reduce to a klon_glo grid but keep the levels
+    CALL grid2dTo1d_glo(OCS_clim_mth,OCS_clim_tmp)
+    CALL grid2dTo1d_glo(SO2_clim_mth,SO2_clim_tmp)
+    CALL grid2dTo1d_glo(O3_clim_mth,O3_clim_tmp)
+    
+    CALL grid2dTo1d_glo(OCS_lifetime_mth,OCS_lifetime_tmp)
+    CALL grid2dTo1d_glo(SO2_lifetime_mth,SO2_lifetime_tmp)
+    CALL grid2dTo1d_glo(H2SO4_lifetime_mth,H2SO4_lifetime_tmp)
+
+!--set lifetime to very high value in uninsolated areas
+    DO i=1, klon_glo
+      DO kk=1, n_lev
+!--added tests on VMR of species for realism
+        IF (OCS_clim_tmp(i,kk).LT.1.e-20) THEN
+          OCS_clim_tmp(i,kk)=1.0e-20
+        ENDIF
+        IF (SO2_clim_tmp(i,kk).LT.1.e-20) THEN
+          SO2_clim_tmp(i,kk)=1.0e-20
+        ENDIF
+        !       50 ppbv min for O3
+        IF (O3_clim_tmp(i,kk).LT.50.0e-9) THEN
+           O3_clim_tmp(i,kk)=50.0e-9
+        ENDIF
+        
+        IF (OCS_lifetime_tmp(i,kk)==0.0) THEN
+          OCS_lifetime_tmp(i,kk)=1.0e12
+        ENDIF
+        IF (SO2_lifetime_tmp(i,kk)==0.0) THEN
+          SO2_lifetime_tmp(i,kk)=1.0e12
+        ENDIF
+       IF (H2SO4_lifetime_tmp(i,kk)==0.0) THEN
+          H2SO4_lifetime_tmp(i,kk)=1.0e12
+       ENDIF
+      ENDDO
+    ENDDO
+
+  !---regrid weighted lifetime and climatologies
+  DO i=1, klon_glo
+    DO k=1, klev
+     OCS_lifetime_glo(i,k)=0.0
+     SO2_lifetime_glo(i,k)=0.0
+     O3_clim_glo(i,k)=0.0
+     
+     OCS_clim_glo(i,k)=0.0
+     SO2_clim_glo(i,k)=0.0
+     H2SO4_lifetime_glo(i,k)=0.0
+     
+     DO kk=1, n_lev
+      OCS_lifetime_glo(i,k)=OCS_lifetime_glo(i,k)+ &
+           MAX(0.0,MIN(paprs_glo(i,k),paprs_input(kk))-MAX(paprs_glo(i,k+1),paprs_input(kk+1))) &
+           *OCS_lifetime_tmp(i,kk)/(paprs_glo(i,k)-paprs_glo(i,k+1))
+      SO2_lifetime_glo(i,k)=SO2_lifetime_glo(i,k)+ &
+           MAX(0.0,MIN(paprs_glo(i,k),paprs_input(kk))-MAX(paprs_glo(i,k+1),paprs_input(kk+1))) &
+           *SO2_lifetime_tmp(i,kk)/(paprs_glo(i,k)-paprs_glo(i,k+1))
+      IF(flag_newclim_file) THEN
+         H2SO4_lifetime_glo(i,k)=H2SO4_lifetime_glo(i,k)+ &
+              MAX(0.0,MIN(paprs_glo(i,k),paprs_input(kk)) &
+              -MAX(paprs_glo(i,k+1),paprs_input(kk+1))) &
+              *H2SO4_lifetime_tmp(i,kk)/(paprs_glo(i,k)-paprs_glo(i,k+1))
+      ENDIF
+      
+      OCS_clim_glo(i,k)=OCS_clim_glo(i,k)+ &
+           MAX(0.0,MIN(paprs_glo(i,k),paprs_input(kk))-MAX(paprs_glo(i,k+1),paprs_input(kk+1))) &
+           *OCS_clim_tmp(i,kk)/(paprs_glo(i,k)-paprs_glo(i,k+1))
+      SO2_clim_glo(i,k)=SO2_clim_glo(i,k)+ &
+           MAX(0.0,MIN(paprs_glo(i,k),paprs_input(kk))-MAX(paprs_glo(i,k+1),paprs_input(kk+1))) &
+           *SO2_clim_tmp(i,kk)/(paprs_glo(i,k)-paprs_glo(i,k+1))
+      IF(flag_newclim_file) THEN
+         O3_clim_glo(i,k)=O3_clim_glo(i,k)+ &
+              MAX(0.0,MIN(paprs_glo(i,k),paprs_input(kk)) &
+              -MAX(paprs_glo(i,k+1),paprs_input(kk+1))) &
+              *O3_clim_tmp(i,kk)/(paprs_glo(i,k)-paprs_glo(i,k+1))
+      ENDIF
+      ENDDO
+    ENDDO
+  ENDDO
+
+  ENDIF !--is_mpi_root and is_omp_root
+
+!--keep memory of previous month
+  mth_pre=mth_cur
+
+!--scatter global fields around
+  CALL scatter(OCS_clim_glo, OCS_clim)
+  CALL scatter(SO2_clim_glo, SO2_clim)
+  CALL scatter(O3_clim_glo, O3_clim)
+  CALL scatter(OCS_lifetime_glo, OCS_lifetime)
+  CALL scatter(SO2_lifetime_glo, SO2_lifetime)
+  CALL scatter(H2SO4_lifetime_glo, H2SO4_lifetime)
+  
+  IF (is_mpi_root.AND.is_omp_root) THEN
+!
+    DEALLOCATE(OCS_clim_in,SO2_clim_in,O3_clim_in)
+    DEALLOCATE(OCS_clim_mth,SO2_clim_mth,O3_clim_mth)
+    DEALLOCATE(OCS_clim_tmp,SO2_clim_tmp,O3_clim_tmp)
+    DEALLOCATE(OCS_lifetime_in, SO2_lifetime_in, H2SO4_lifetime_in)
+    DEALLOCATE(OCS_lifetime_mth, SO2_lifetime_mth, H2SO4_lifetime_mth)
+    DEALLOCATE(OCS_lifetime_tmp, SO2_lifetime_tmp, H2SO4_lifetime_tmp)
+!
+  ENDIF !--is_mpi_root and is_omp_root
+
+  ENDIF ! debutphy.OR.new month
+
+!--set to background value everywhere in the very beginning, later only in the troposphere
+!--a little dangerous as the MAXVAL is not computed on the global field
+  IF (debutphy.AND.MAXVAL(tr_seri).LT.1.e-30) THEN
+    p_bound=0.0
+  ELSE
+    p_bound=50000.
+  ENDIF
+
+!--regridding tracer concentration on the vertical
+  DO i=1, klon
+    DO k=1, klev
+      !
+      !--OCS and SO2 prescribed back to their clim values below p_bound
+      IF (paprs(i,k).GT.p_bound) THEN
+        budg_3D_backgr_ocs(i,k)=OCS_clim(i,k)-tr_seri(i,k,id_OCS_strat)
+        budg_3D_backgr_so2(i,k)=SO2_clim(i,k)-tr_seri(i,k,id_SO2_strat)
+        tr_seri(i,k,id_OCS_strat)=OCS_clim(i,k)
+        tr_seri(i,k,id_SO2_strat)=SO2_clim(i,k)
+      ENDIF
+    ENDDO
+  ENDDO
+
+  !convert SO2_backgr_tend from kg(SO2)/kgA to kg(S)/m2/layer/s for saving as diagnostic
+  DO i=1, klon
+    DO k=1, klev
+      budg_3D_backgr_ocs(i,k)=budg_3D_backgr_ocs(i,k)*mSatom/mOCSmol*(paprs(i,k)-paprs(i,k+1))/RG/pdtphys
+      budg_3D_backgr_so2(i,k)=budg_3D_backgr_so2(i,k)*mSatom/mSO2mol*(paprs(i,k)-paprs(i,k+1))/RG/pdtphys
+    ENDDO
+  ENDDO
+ 
+  RETURN
+
+END SUBROUTINE interp_sulf_input
Index: DZ6/trunk/libf/phylmd/StratAer/micphy_tstep.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/StratAer/micphy_tstep.F90	(revision 5267)
+++ 	(revision )
@@ -1,192 +1,0 @@
-!
-! $Id$
-!
-SUBROUTINE micphy_tstep(pdtphys,tr_seri,t_seri,pplay,paprs,rh,is_strato)
-
-  USE geometry_mod, ONLY : latitude_deg !NL- latitude corr. to local domain
-  USE dimphy, ONLY : klon,klev
-  USE aerophys
-  USE infotrac_phy, ONLY : nbtr_bin, nbtr_sulgas, nbtr, id_H2SO4_strat
-  USE phys_local_var_mod, ONLY: mdw, budg_3D_nucl, budg_3D_cond_evap, budg_h2so4_to_part, R2SO4, DENSO4, &
-       f_r_wet, R2SO4B, DENSO4B, f_r_wetB
-  USE nucleation_tstep_mod
-  USE cond_evap_tstep_mod
-  USE sulfate_aer_mod, ONLY : STRAACT
-  USE yomcst_mod_h, ONLY : RPI, RD, RG
-  USE print_control_mod, ONLY: lunout
-  USE strataer_local_var_mod ! contains also RRSI and Vbin
-  
-  IMPLICIT NONE
-
-  !--------------------------------------------------------
-
-  ! transfer variables when calling this routine
-  REAL,INTENT(IN)                               :: pdtphys ! Pas d'integration pour la physique (seconde)
-  REAL,DIMENSION(klon,klev,nbtr),INTENT(INOUT)  :: tr_seri ! Concentration Traceur [U/KgA]
-  REAL,DIMENSION(klon,klev),INTENT(IN)          :: t_seri  ! Temperature
-  REAL,DIMENSION(klon,klev),INTENT(IN)          :: pplay   ! pression pour le mileu de chaque couche (en Pa)
-  REAL,DIMENSION(klon,klev+1),INTENT(IN)        :: paprs   ! pression pour chaque inter-couche (en Pa)
-  REAL,DIMENSION(klon,klev),INTENT(IN)          :: rh      ! humidite relative
-  LOGICAL,DIMENSION(klon,klev),INTENT(IN)       :: is_strato
-
-  ! local variables in coagulation routine
-  INTEGER, PARAMETER        :: nbtstep=4  ! Max number of time steps in microphysics per time step in physics
-  INTEGER                   :: it,ilon,ilev,count_tstep
-  REAL                      :: rhoa !H2SO4 number density [molecules/cm3]
-  REAL                      :: ntot !total number of molecules in the critical cluster (ntot>4)
-  REAL                      :: x    ! molefraction of H2SO4 in the critical cluster     
-  REAL a_xm, b_xm, c_xm
-  REAL PDT, dt
-  REAL H2SO4_init
-  REAL ACTSO4(klon,klev)
-  REAL nucl_rate
-  REAL cond_evap_rate
-  REAL evap_rate
-  REAL FL(nbtr_bin)
-  REAL ASO4(nbtr_bin)
-  REAL DNDR(nbtr_bin)
-  REAL H2SO4_sat
-  REAL R2SO4ik(nbtr_bin), DENSO4ik(nbtr_bin), f_r_wetik(nbtr_bin)
-  
-  !coefficients for H2SO4 density parametrization used for nucleation if ntot<4
-  a_xm = 0.7681724 + 1.*(2.1847140 + 1.*(7.1630022 + 1.*(-44.31447 + &
-       & 1.*(88.75606 + 1.*(-75.73729 + 1.*23.43228)))))
-  b_xm = 1.808225e-3 + 1.*(-9.294656e-3 + 1.*(-0.03742148 + 1.*(0.2565321 + &
-       & 1.*(-0.5362872 + 1.*(0.4857736 - 1.*0.1629592)))))
-  c_xm = -3.478524e-6 + 1.*(1.335867e-5 + 1.*(5.195706e-5 + 1.*(-3.717636e-4 + &
-       & 1.*(7.990811e-4 + 1.*(-7.458060e-4 + 1.*2.58139e-4 )))))
-
-  IF(.not.flag_new_strat_compo) THEN
-     ! STRAACT (R2SO4, t_seri -> H2SO4 activity coefficient (ACTSO4)) for cond/evap
-     CALL STRAACT(ACTSO4)
-  ENDIF
-  
-  DO ilon=1, klon
-!
-!--initialisation of diagnostic
-  budg_h2so4_to_part(ilon)=0.0
-!
-  DO ilev=1, klev
-!
-!--initialisation of diagnostic
-  budg_3D_nucl(ilon,ilev)=0.0
-  budg_3D_cond_evap(ilon,ilev)=0.0
-!
-  ! only in the stratosphere
-  IF (is_strato(ilon,ilev)) THEN
-    ! initialize sulfur fluxes
-    H2SO4_init=tr_seri(ilon,ilev,id_H2SO4_strat)
-    ! adaptive timestep for nucleation and condensation
-    PDT=pdtphys
-    count_tstep=0
-    DO WHILE (PDT>0.0)
-      count_tstep=count_tstep+1
-      IF (count_tstep .GT. nbtstep)  EXIT
-      ! convert tr_seri(GASH2SO4) (in kg/kgA) to H2SO4 number density (in molecules/cm3) 
-      rhoa=tr_seri(ilon,ilev,id_H2SO4_strat) &
-          & *pplay(ilon,ilev)/t_seri(ilon,ilev)/RD/1.E6/mH2SO4mol
-      ! compute nucleation rate in kg(H2SO4)/kgA/s
-      CALL nucleation_rate(rhoa,t_seri(ilon,ilev),pplay(ilon,ilev),rh(ilon,ilev), &
-           & a_xm,b_xm,c_xm,nucl_rate,ntot,x)
-      !NL - add nucleation box (if flag on)
-      IF (flag_nuc_rate_box) THEN
-         IF (latitude_deg(ilon).LE.nuclat_min .OR. latitude_deg(ilon).GE.nuclat_max &
-              .OR. pplay(ilon,ilev).GE.nucpres_max .AND. pplay(ilon,ilev).LE.nucpres_min) THEN
-            nucl_rate=0.0
-         ENDIF
-      ENDIF
-      ! compute cond/evap rate in kg(H2SO4)/kgA/s
-      IF(flag_new_strat_compo) THEN
-         R2SO4ik(:)   = R2SO4B(ilon,ilev,:)
-         DENSO4ik(:)  = DENSO4B(ilon,ilev,:)
-         f_r_wetik(:) = f_r_wetB(ilon,ilev,:)
-         CALL condens_evapor_rate_kelvin(rhoa,t_seri(ilon,ilev),pplay(ilon,ilev), &
-              & R2SO4(ilon,ilev),DENSO4(ilon,ilev),f_r_wet(ilon,ilev), &
-              & R2SO4ik,DENSO4ik,f_r_wetik,FL,ASO4,DNDR)
-      ELSE
-         CALL condens_evapor_rate(rhoa,t_seri(ilon,ilev),pplay(ilon,ilev), &
-              & ACTSO4(ilon,ilev),R2SO4(ilon,ilev),DENSO4(ilon,ilev),f_r_wet(ilon,ilev), &
-              & FL,ASO4,DNDR)
-      ENDIF
-      ! Compute H2SO4 saturate vapor for big particules
-      H2SO4_sat = DNDR(nbtr_bin)/(pplay(ilon,ilev)/t_seri(ilon,ilev)/RD/1.E6/mH2SO4mol)
-      ! consider only condensation (positive FL)
-      DO it=1,nbtr_bin
-        FL(it)=MAX(FL(it),0.)
-      ENDDO
-      ! compute total H2SO4 cond flux for all particles
-      cond_evap_rate=0.0
-      DO it=1, nbtr_bin
-        cond_evap_rate=cond_evap_rate+tr_seri(ilon,ilev,it+nbtr_sulgas)*FL(it)*mH2SO4mol
-      ENDDO
-      ! determine appropriate time step
-      dt=(H2SO4_init-H2SO4_sat)/float(nbtstep)/MAX(1.e-30, nucl_rate+cond_evap_rate) !cond_evap_rate pos. for cond. and neg. for evap.
-      IF (dt.LT.0.0) THEN
-        dt=PDT
-      ENDIF
-      dt=MIN(dt,PDT)
-      ! update H2SO4 concentration
-      tr_seri(ilon,ilev,id_H2SO4_strat)=MAX(0.,tr_seri(ilon,ilev,id_H2SO4_strat)-(nucl_rate+cond_evap_rate)*dt)
-      ! apply cond to bins
-      CALL condens_evapor_part(dt,FL,ASO4,f_r_wet(ilon,ilev),tr_seri(ilon,ilev,:))
-      ! apply nucl. to bins
-      CALL nucleation_part(nucl_rate,ntot,x,dt,tr_seri(ilon,ilev,:))
-      ! compute fluxes as diagnostic in [kg(S)/m2/layer/s] (now - for evap and + for cond)
-      budg_3D_cond_evap(ilon,ilev)=budg_3D_cond_evap(ilon,ilev)+mSatom/mH2SO4mol &
-               & *cond_evap_rate*(paprs(ilon,ilev)-paprs(ilon,ilev+1))/RG*dt/pdtphys
-      budg_3D_nucl(ilon,ilev)=budg_3D_nucl(ilon,ilev)+mSatom/mH2SO4mol &
-               & *nucl_rate*(paprs(ilon,ilev)-paprs(ilon,ilev+1))/RG*dt/pdtphys
-      ! update time step
-      PDT=PDT-dt
-    ENDDO
-    ! convert tr_seri(GASH2SO4) (in kg/kgA) to H2SO4 number density (in molecules/cm3) 
-    rhoa=tr_seri(ilon,ilev,id_H2SO4_strat) &
-        & *pplay(ilon,ilev)/t_seri(ilon,ilev)/RD/1.E6/mH2SO4mol
-    ! compute cond/evap rate in kg(H2SO4)/kgA/s (now only evap for pdtphys)
-    IF(flag_new_strat_compo) THEN
-       CALL condens_evapor_rate_kelvin(rhoa,t_seri(ilon,ilev),pplay(ilon,ilev), &
-            & R2SO4(ilon,ilev),DENSO4(ilon,ilev),f_r_wet(ilon,ilev), &
-            & R2SO4ik,DENSO4ik,f_r_wetik,FL,ASO4,DNDR)
-    ELSE
-       CALL condens_evapor_rate(rhoa,t_seri(ilon,ilev),pplay(ilon,ilev), &
-            & ACTSO4(ilon,ilev),R2SO4(ilon,ilev),DENSO4(ilon,ilev),f_r_wet(ilon,ilev), &
-            & FL,ASO4,DNDR)
-    ENDIF
-    ! limit evaporation (negative FL) over one physics time step to H2SO4 content of the droplet
-    DO it=1,nbtr_bin
-      FL(it)=MAX(FL(it)*pdtphys,0.-ASO4(it))/pdtphys
-      ! consider only evap (negative FL)
-      FL(it)=MIN(FL(it),0.)
-    ENDDO
-    ! compute total H2SO4 evap flux for all particles
-    evap_rate=0.0
-    DO it=1, nbtr_bin
-      evap_rate=evap_rate+tr_seri(ilon,ilev,it+nbtr_sulgas)*FL(it)*mH2SO4mol
-    ENDDO
-    ! update H2SO4 concentration after evap
-    tr_seri(ilon,ilev,id_H2SO4_strat)=MAX(0.,tr_seri(ilon,ilev,id_H2SO4_strat)-evap_rate*pdtphys)
-    ! apply evap to bins
-    CALL condens_evapor_part(pdtphys,FL,ASO4,f_r_wet(ilon,ilev),tr_seri(ilon,ilev,:))
-    ! compute fluxes as diagnostic in [kg(S)/m2/layer/s] (now - for evap and + for cond)
-    budg_3D_cond_evap(ilon,ilev)=budg_3D_cond_evap(ilon,ilev)+mSatom/mH2SO4mol &
-             & *evap_rate*(paprs(ilon,ilev)-paprs(ilon,ilev+1))/RG
-    ! compute vertically integrated flux due to the net effect of nucleation and condensation/evaporation
-    budg_h2so4_to_part(ilon)=budg_h2so4_to_part(ilon)+(H2SO4_init-tr_seri(ilon,ilev,id_H2SO4_strat)) &
-             & *mSatom/mH2SO4mol*(paprs(ilon,ilev)-paprs(ilon,ilev+1))/RG/pdtphys
-  ENDIF
-  ENDDO
-  ENDDO
-
-  IF (MINVAL(tr_seri).LT.0.0) THEN
-    DO ilon=1, klon
-    DO ilev=1, klev    
-    DO it=1, nbtr
-      IF (tr_seri(ilon,ilev,it).LT.0.0) THEN
-         WRITE(lunout,*) 'micphy_tstep: negative concentration', tr_seri(ilon,ilev,it), ilon, ilev, it
-      ENDIF
-    ENDDO
-    ENDDO
-    ENDDO
-  ENDIF
-
-END SUBROUTINE micphy_tstep
Index: /LMDZ6/trunk/libf/phylmd/StratAer/micphy_tstep.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/StratAer/micphy_tstep.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/StratAer/micphy_tstep.f90	(revision 5268)
@@ -0,0 +1,192 @@
+!
+! $Id$
+!
+SUBROUTINE micphy_tstep(pdtphys,tr_seri,t_seri,pplay,paprs,rh,is_strato)
+
+  USE geometry_mod, ONLY : latitude_deg !NL- latitude corr. to local domain
+  USE dimphy, ONLY : klon,klev
+  USE aerophys
+  USE infotrac_phy, ONLY : nbtr_bin, nbtr_sulgas, nbtr, id_H2SO4_strat
+  USE phys_local_var_mod, ONLY: mdw, budg_3D_nucl, budg_3D_cond_evap, budg_h2so4_to_part, R2SO4, DENSO4, &
+       f_r_wet, R2SO4B, DENSO4B, f_r_wetB
+  USE nucleation_tstep_mod
+  USE cond_evap_tstep_mod
+  USE sulfate_aer_mod, ONLY : STRAACT
+  USE yomcst_mod_h, ONLY : RPI, RD, RG
+  USE print_control_mod, ONLY: lunout
+  USE strataer_local_var_mod ! contains also RRSI and Vbin
+  
+  IMPLICIT NONE
+
+  !--------------------------------------------------------
+
+  ! transfer variables when calling this routine
+  REAL,INTENT(IN)                               :: pdtphys ! Pas d'integration pour la physique (seconde)
+  REAL,DIMENSION(klon,klev,nbtr),INTENT(INOUT)  :: tr_seri ! Concentration Traceur [U/KgA]
+  REAL,DIMENSION(klon,klev),INTENT(IN)          :: t_seri  ! Temperature
+  REAL,DIMENSION(klon,klev),INTENT(IN)          :: pplay   ! pression pour le mileu de chaque couche (en Pa)
+  REAL,DIMENSION(klon,klev+1),INTENT(IN)        :: paprs   ! pression pour chaque inter-couche (en Pa)
+  REAL,DIMENSION(klon,klev),INTENT(IN)          :: rh      ! humidite relative
+  LOGICAL,DIMENSION(klon,klev),INTENT(IN)       :: is_strato
+
+  ! local variables in coagulation routine
+  INTEGER, PARAMETER        :: nbtstep=4  ! Max number of time steps in microphysics per time step in physics
+  INTEGER                   :: it,ilon,ilev,count_tstep
+  REAL                      :: rhoa !H2SO4 number density [molecules/cm3]
+  REAL                      :: ntot !total number of molecules in the critical cluster (ntot>4)
+  REAL                      :: x    ! molefraction of H2SO4 in the critical cluster     
+  REAL a_xm, b_xm, c_xm
+  REAL PDT, dt
+  REAL H2SO4_init
+  REAL ACTSO4(klon,klev)
+  REAL nucl_rate
+  REAL cond_evap_rate
+  REAL evap_rate
+  REAL FL(nbtr_bin)
+  REAL ASO4(nbtr_bin)
+  REAL DNDR(nbtr_bin)
+  REAL H2SO4_sat
+  REAL R2SO4ik(nbtr_bin), DENSO4ik(nbtr_bin), f_r_wetik(nbtr_bin)
+  
+  !coefficients for H2SO4 density parametrization used for nucleation if ntot<4
+  a_xm = 0.7681724 + 1.*(2.1847140 + 1.*(7.1630022 + 1.*(-44.31447 + &
+       & 1.*(88.75606 + 1.*(-75.73729 + 1.*23.43228)))))
+  b_xm = 1.808225e-3 + 1.*(-9.294656e-3 + 1.*(-0.03742148 + 1.*(0.2565321 + &
+       & 1.*(-0.5362872 + 1.*(0.4857736 - 1.*0.1629592)))))
+  c_xm = -3.478524e-6 + 1.*(1.335867e-5 + 1.*(5.195706e-5 + 1.*(-3.717636e-4 + &
+       & 1.*(7.990811e-4 + 1.*(-7.458060e-4 + 1.*2.58139e-4 )))))
+
+  IF(.not.flag_new_strat_compo) THEN
+     ! STRAACT (R2SO4, t_seri -> H2SO4 activity coefficient (ACTSO4)) for cond/evap
+     CALL STRAACT(ACTSO4)
+  ENDIF
+  
+  DO ilon=1, klon
+!
+!--initialisation of diagnostic
+  budg_h2so4_to_part(ilon)=0.0
+!
+  DO ilev=1, klev
+!
+!--initialisation of diagnostic
+  budg_3D_nucl(ilon,ilev)=0.0
+  budg_3D_cond_evap(ilon,ilev)=0.0
+!
+  ! only in the stratosphere
+  IF (is_strato(ilon,ilev)) THEN
+    ! initialize sulfur fluxes
+    H2SO4_init=tr_seri(ilon,ilev,id_H2SO4_strat)
+    ! adaptive timestep for nucleation and condensation
+    PDT=pdtphys
+    count_tstep=0
+    DO WHILE (PDT>0.0)
+      count_tstep=count_tstep+1
+      IF (count_tstep .GT. nbtstep)  EXIT
+      ! convert tr_seri(GASH2SO4) (in kg/kgA) to H2SO4 number density (in molecules/cm3) 
+      rhoa=tr_seri(ilon,ilev,id_H2SO4_strat) &
+          & *pplay(ilon,ilev)/t_seri(ilon,ilev)/RD/1.E6/mH2SO4mol
+      ! compute nucleation rate in kg(H2SO4)/kgA/s
+      CALL nucleation_rate(rhoa,t_seri(ilon,ilev),pplay(ilon,ilev),rh(ilon,ilev), &
+           & a_xm,b_xm,c_xm,nucl_rate,ntot,x)
+      !NL - add nucleation box (if flag on)
+      IF (flag_nuc_rate_box) THEN
+         IF (latitude_deg(ilon).LE.nuclat_min .OR. latitude_deg(ilon).GE.nuclat_max &
+              .OR. pplay(ilon,ilev).GE.nucpres_max .AND. pplay(ilon,ilev).LE.nucpres_min) THEN
+            nucl_rate=0.0
+         ENDIF
+      ENDIF
+      ! compute cond/evap rate in kg(H2SO4)/kgA/s
+      IF(flag_new_strat_compo) THEN
+         R2SO4ik(:)   = R2SO4B(ilon,ilev,:)
+         DENSO4ik(:)  = DENSO4B(ilon,ilev,:)
+         f_r_wetik(:) = f_r_wetB(ilon,ilev,:)
+         CALL condens_evapor_rate_kelvin(rhoa,t_seri(ilon,ilev),pplay(ilon,ilev), &
+              & R2SO4(ilon,ilev),DENSO4(ilon,ilev),f_r_wet(ilon,ilev), &
+              & R2SO4ik,DENSO4ik,f_r_wetik,FL,ASO4,DNDR)
+      ELSE
+         CALL condens_evapor_rate(rhoa,t_seri(ilon,ilev),pplay(ilon,ilev), &
+              & ACTSO4(ilon,ilev),R2SO4(ilon,ilev),DENSO4(ilon,ilev),f_r_wet(ilon,ilev), &
+              & FL,ASO4,DNDR)
+      ENDIF
+      ! Compute H2SO4 saturate vapor for big particules
+      H2SO4_sat = DNDR(nbtr_bin)/(pplay(ilon,ilev)/t_seri(ilon,ilev)/RD/1.E6/mH2SO4mol)
+      ! consider only condensation (positive FL)
+      DO it=1,nbtr_bin
+        FL(it)=MAX(FL(it),0.)
+      ENDDO
+      ! compute total H2SO4 cond flux for all particles
+      cond_evap_rate=0.0
+      DO it=1, nbtr_bin
+        cond_evap_rate=cond_evap_rate+tr_seri(ilon,ilev,it+nbtr_sulgas)*FL(it)*mH2SO4mol
+      ENDDO
+      ! determine appropriate time step
+      dt=(H2SO4_init-H2SO4_sat)/float(nbtstep)/MAX(1.e-30, nucl_rate+cond_evap_rate) !cond_evap_rate pos. for cond. and neg. for evap.
+      IF (dt.LT.0.0) THEN
+        dt=PDT
+      ENDIF
+      dt=MIN(dt,PDT)
+      ! update H2SO4 concentration
+      tr_seri(ilon,ilev,id_H2SO4_strat)=MAX(0.,tr_seri(ilon,ilev,id_H2SO4_strat)-(nucl_rate+cond_evap_rate)*dt)
+      ! apply cond to bins
+      CALL condens_evapor_part(dt,FL,ASO4,f_r_wet(ilon,ilev),tr_seri(ilon,ilev,:))
+      ! apply nucl. to bins
+      CALL nucleation_part(nucl_rate,ntot,x,dt,tr_seri(ilon,ilev,:))
+      ! compute fluxes as diagnostic in [kg(S)/m2/layer/s] (now - for evap and + for cond)
+      budg_3D_cond_evap(ilon,ilev)=budg_3D_cond_evap(ilon,ilev)+mSatom/mH2SO4mol &
+               & *cond_evap_rate*(paprs(ilon,ilev)-paprs(ilon,ilev+1))/RG*dt/pdtphys
+      budg_3D_nucl(ilon,ilev)=budg_3D_nucl(ilon,ilev)+mSatom/mH2SO4mol &
+               & *nucl_rate*(paprs(ilon,ilev)-paprs(ilon,ilev+1))/RG*dt/pdtphys
+      ! update time step
+      PDT=PDT-dt
+    ENDDO
+    ! convert tr_seri(GASH2SO4) (in kg/kgA) to H2SO4 number density (in molecules/cm3) 
+    rhoa=tr_seri(ilon,ilev,id_H2SO4_strat) &
+        & *pplay(ilon,ilev)/t_seri(ilon,ilev)/RD/1.E6/mH2SO4mol
+    ! compute cond/evap rate in kg(H2SO4)/kgA/s (now only evap for pdtphys)
+    IF(flag_new_strat_compo) THEN
+       CALL condens_evapor_rate_kelvin(rhoa,t_seri(ilon,ilev),pplay(ilon,ilev), &
+            & R2SO4(ilon,ilev),DENSO4(ilon,ilev),f_r_wet(ilon,ilev), &
+            & R2SO4ik,DENSO4ik,f_r_wetik,FL,ASO4,DNDR)
+    ELSE
+       CALL condens_evapor_rate(rhoa,t_seri(ilon,ilev),pplay(ilon,ilev), &
+            & ACTSO4(ilon,ilev),R2SO4(ilon,ilev),DENSO4(ilon,ilev),f_r_wet(ilon,ilev), &
+            & FL,ASO4,DNDR)
+    ENDIF
+    ! limit evaporation (negative FL) over one physics time step to H2SO4 content of the droplet
+    DO it=1,nbtr_bin
+      FL(it)=MAX(FL(it)*pdtphys,0.-ASO4(it))/pdtphys
+      ! consider only evap (negative FL)
+      FL(it)=MIN(FL(it),0.)
+    ENDDO
+    ! compute total H2SO4 evap flux for all particles
+    evap_rate=0.0
+    DO it=1, nbtr_bin
+      evap_rate=evap_rate+tr_seri(ilon,ilev,it+nbtr_sulgas)*FL(it)*mH2SO4mol
+    ENDDO
+    ! update H2SO4 concentration after evap
+    tr_seri(ilon,ilev,id_H2SO4_strat)=MAX(0.,tr_seri(ilon,ilev,id_H2SO4_strat)-evap_rate*pdtphys)
+    ! apply evap to bins
+    CALL condens_evapor_part(pdtphys,FL,ASO4,f_r_wet(ilon,ilev),tr_seri(ilon,ilev,:))
+    ! compute fluxes as diagnostic in [kg(S)/m2/layer/s] (now - for evap and + for cond)
+    budg_3D_cond_evap(ilon,ilev)=budg_3D_cond_evap(ilon,ilev)+mSatom/mH2SO4mol &
+             & *evap_rate*(paprs(ilon,ilev)-paprs(ilon,ilev+1))/RG
+    ! compute vertically integrated flux due to the net effect of nucleation and condensation/evaporation
+    budg_h2so4_to_part(ilon)=budg_h2so4_to_part(ilon)+(H2SO4_init-tr_seri(ilon,ilev,id_H2SO4_strat)) &
+             & *mSatom/mH2SO4mol*(paprs(ilon,ilev)-paprs(ilon,ilev+1))/RG/pdtphys
+  ENDIF
+  ENDDO
+  ENDDO
+
+  IF (MINVAL(tr_seri).LT.0.0) THEN
+    DO ilon=1, klon
+    DO ilev=1, klev    
+    DO it=1, nbtr
+      IF (tr_seri(ilon,ilev,it).LT.0.0) THEN
+         WRITE(lunout,*) 'micphy_tstep: negative concentration', tr_seri(ilon,ilev,it), ilon, ilev, it
+      ENDIF
+    ENDDO
+    ENDDO
+    ENDDO
+  ENDIF
+
+END SUBROUTINE micphy_tstep
Index: DZ6/trunk/libf/phylmd/StratAer/miecalc_aer.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/StratAer/miecalc_aer.F90	(revision 5267)
+++ 	(revision )
@@ -1,617 +1,0 @@
-SUBROUTINE MIECALC_AER(tau_strat, piz_strat, cg_strat, tau_strat_wave, tau_lw_abs_rrtm, paprs, debut)
-
-!-------Mie computations for a size distribution 
-!       of homogeneous spheres.
-!
-!==========================================================
-!--Ref : Toon and Ackerman, Applied Optics, 1981
-!        Stephens, CSIRO, 1979
-! Attention : surdimensionement des tableaux
-! to be compiled with double precision option (-r8 on Sun)
-! AUTHOR: Olivier Boucher, Christoph Kleinschmitt
-!-------SIZE distribution properties----------------
-!--sigma_g : geometric standard deviation 
-!--r_0     : geometric number mean radius (um)/modal radius
-!--Ntot    : total concentration in m-3 
-
-  USE phys_local_var_mod, ONLY: tr_seri, mdw, alpha_bin, piz_bin, cg_bin
-  USE aerophys, ONLY: dens_aer_dry, dens_aer_ref, V_rat
-  USE aero_mod
-  USE infotrac_phy, ONLY : nbtr, nbtr_bin, nbtr_sulgas, id_SO2_strat
-  USE dimphy
-  USE yomcst_mod_h  , ONLY : RG, RPI
-  USE mod_phys_lmdz_para, only: gather, scatter, bcast
-  USE mod_grid_phy_lmdz, ONLY : klon_glo
-  USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
-  USE print_control_mod, ONLY: prt_level, lunout
-
-  IMPLICIT NONE
-
-! Variable input
-  LOGICAL,INTENT(IN) :: debut   ! le flag de l'initialisation de la physique
-  REAL,DIMENSION(klon,klev+1),INTENT(IN) :: paprs   ! pression pour chaque inter-couche (en Pa)
-
-! Stratospheric aerosols optical properties
-  REAL, DIMENSION(klon,klev,nbands_sw_rrtm) :: tau_strat, piz_strat, cg_strat
-  REAL, DIMENSION(klon,klev,nwave_sw+nwave_lw) :: tau_strat_wave
-  REAL, DIMENSION(klon,klev,nbands_lw_rrtm) :: tau_lw_abs_rrtm
-
-!!  REAL,DIMENSION(klon_glo,klev,nbtr)     :: tr_seri_glo         ! Concentration Traceur [U/KgA]  
-
-! local variables
-  REAL Ntot
-  PARAMETER (Ntot=1.0)
-  LOGICAL, PARAMETER :: refr_ind_interpol = .TRUE. ! set interpolation of refractive index
-  REAL r_0    ! aerosol particle radius [m]
-  INTEGER bin_number, ilon, ilev
-  REAL masse,volume,surface
-  REAL rmin, rmax    !----integral bounds in  m
-
-!-------------------------------------
-
-  COMPLEX m          !----refractive index m=n_r-i*n_i
-  INTEGER Nmax,Nstart !--number of iterations
-  COMPLEX k2, k3, z1, z2
-  COMPLEX u1,u5,u6,u8
-  COMPLEX a(1:21000), b(1:21000)
-  COMPLEX I 
-  INTEGER n  !--loop index
-  REAL nnn
-  COMPLEX nn
-  REAL Q_ext, Q_abs, Q_sca, g, omega   !--parameters for radius r
-  REAL x, x_old  !--size parameter
-  REAL r, r_lower, r_upper  !--radius
-  REAL sigma_sca, sigma_ext, sigma_abs
-  REAL omegatot,  gtot !--averaged parameters
-  COMPLEX ksiz2(-1:21000), psiz2(1:21000)
-  COMPLEX nu1z1(1:21010), nu1z2(1:21010)
-  COMPLEX nu3z2(0:21000)
-  REAL number, deltar
-  INTEGER bin, Nbin, it
-  PARAMETER (Nbin=10)
-  LOGICAL smallx
-
-!---wavelengths STREAMER
-  INTEGER Nwv, NwvmaxSW
-  PARAMETER (NwvmaxSW=24)
-  REAL lambda(1:NwvmaxSW+1)
-  DATA lambda/0.28E-6, 0.30E-6, 0.33E-6, 0.36E-6, 0.40E-6, &
-              0.44E-6, 0.48E-6, 0.52E-6, 0.57E-6, 0.64E-6, &
-              0.69E-6, 0.75E-6, 0.78E-6, 0.87E-6, 1.00E-6, &
-              1.10E-6, 1.19E-6, 1.28E-6, 1.53E-6, 1.64E-6, &
-              2.13E-6, 2.38E-6, 2.91E-6, 3.42E-6, 4.00E-6/
-
-!---wavelengths de references
-!---be careful here the 5th wavelength is 1020 nm
-  INTEGER nb
-  REAL lambda_ref(nwave_sw+nwave_lw)
-  DATA lambda_ref /0.443E-6,0.550E-6,0.670E-6,  &
-                   0.765E-6,1.020E-6,10.E-6/
-
-!--LW 
-  INTEGER NwvmaxLW
-  PARAMETER (NwvmaxLW=500)
-  REAL Tb, hh, cc, kb
-  PARAMETER (Tb=220.0, hh=6.62607e-34)
-  PARAMETER (cc=2.99792e8, kb=1.38065e-23)
-
-!---TOA fluxes - Streamer Cs
-  REAL weight(1:NwvmaxSW), weightLW
-!c        DATA weight/0.839920E1, 0.231208E2, 0.322393E2, 0.465058E2,
-!c     .              0.678199E2, 0.798964E2, 0.771359E2, 0.888472E2,
-!c     .              0.115281E3, 0.727565E2, 0.816992E2, 0.336172E2,
-!c     .              0.914603E2, 0.112706E3, 0.658840E2, 0.524470E2,
-!c     .              0.391067E2, 0.883864E2, 0.276672E2, 0.681812E2,
-!c     .              0.190966E2, 0.250766E2, 0.128704E2, 0.698720E1/
-!---TOA fluxes - Tad
-  DATA weight/ 4.20, 11.56, 16.12, 23.25, 33.91, 39.95, 38.57, &
-              44.42, 57.64, 29.36, 47.87, 16.81, 45.74, 56.35, &
-              32.94, 26.22, 19.55, 44.19, 13.83, 34.09,  9.55, &
-              12.54,  6.44,  3.49/
-!C---BOA fluxes - Tad
-!c        DATA weight/ 0.01,  4.05, 9.51,  15.99, 26.07, 33.10, 33.07,
-!c     .              39.91, 52.67, 27.89, 43.60, 13.67, 42.22, 40.12,
-!c     .              32.70, 14.44, 19.48, 14.23, 13.43, 16.42,  8.33,
-!c     .               0.95,  0.65, 2.76/
-
-  REAL lambda_int(1:NwvmaxSW+nwave_sw+nwave_lw+NwvmaxLW), ll
-  REAL dlambda_int(1:NwvmaxSW+nwave_sw+nwave_lw+NwvmaxLW), dl
-
-  REAL n_r(1:NwvmaxSW+nwave_sw+nwave_lw+NwvmaxLW)
-  REAL n_i(1:NwvmaxSW+nwave_sw+nwave_lw+NwvmaxLW)
-
-  REAL ilambda, ilambda_prev, ilambda_max, ilambda_min
-  REAL n_r_h2so4, n_i_h2so4
-  REAL n_r_h2so4_prev, n_i_h2so4_prev
-
-  REAL final_a(1:NwvmaxSW+nwave_sw+nwave_lw+NwvmaxLW)
-  REAL final_g(1:NwvmaxSW+nwave_sw+nwave_lw+NwvmaxLW)
-  REAL final_w(1:NwvmaxSW+nwave_sw+nwave_lw+NwvmaxLW)
-
-  INTEGER band, bandSW, bandLW, wavenumber
-
-!---wavelengths SW RRTM
-  REAL wv_rrtm_SW(nbands_sw_rrtm+1)
-  DATA wv_rrtm_SW/  0.185E-6, 0.25E-6, 0.44E-6, 0.69E-6,  &
-                     1.19E-6, 2.38E-6, 4.00E-6/
-
-!---wavenumbers and wavelengths LW RRTM
-  REAL wn_rrtm(nbands_lw_rrtm+1), wv_rrtm(nbands_lw_rrtm+1)
-  DATA wn_rrtm/  10.,  250.,  500.,  630.,  700.,  820.,  &
-                980., 1080., 1180., 1390., 1480., 1800.,  &
-               2080., 2250., 2380., 2600., 3000./
-
-!--GCM results
-  REAL gcm_a(nbands_sw_rrtm+nbands_lw_rrtm)
-  REAL gcm_g(nbands_sw_rrtm+nbands_lw_rrtm)
-  REAL gcm_w(nbands_sw_rrtm+nbands_lw_rrtm)
-  REAL gcm_weight_a(nbands_sw_rrtm+nbands_lw_rrtm)
-  REAL gcm_weight_g(nbands_sw_rrtm+nbands_lw_rrtm)
-  REAL gcm_weight_w(nbands_sw_rrtm+nbands_lw_rrtm)
-
-  REAL ss_a(nbands_sw_rrtm+nbands_lw_rrtm+nwave_sw+nwave_lw)
-  REAL ss_w(nbands_sw_rrtm+nbands_lw_rrtm+nwave_sw+nwave_lw)
-  REAL ss_g(nbands_sw_rrtm+nbands_lw_rrtm+nwave_sw+nwave_lw)
-
-  !-- fichier h2so4_0.75_300.00_hummel_1988_p_q.dat
-  ! -- wavenumber (cm-1), wavelength (um), n_r, n_i
-  INTEGER, PARAMETER :: nb_lambda_h2so4=62
-  REAL, DIMENSION (nb_lambda_h2so4,4) :: ref_ind
-
-!---------------------------------------------------------
-
-  IF (debut) THEN   
-
-     ref_ind = RESHAPE( (/ &
-      200.000,   50.0000,   2.01000,   6.5000E-01, &
-      250.000,   40.0000,   1.94000,   6.3000E-01, & 
-      285.714,   35.0000,   1.72000,   5.2000E-01, & 
-      333.333,   30.0000,   1.73000,   2.9000E-01, & 
-      358.423,   27.9000,   1.78000,   2.5000E-01, & 
-      400.000,   25.0000,   1.84000,   2.4000E-01, &
-      444.444,   22.5000,   1.82000,   2.9000E-01, &
-      469.484,   21.3000,   1.79000,   2.5000E-01, &
-      500.000,   20.0000,   1.81000,   2.3000E-01, &
-      540.541,   18.5000,   1.92700,   3.0200E-01, &
-      555.556,   18.0000,   1.95000,   4.1000E-01, &
-      581.395,   17.2000,   1.72400,   5.9000E-01, &
-      609.756,   16.4000,   1.52000,   4.1400E-01, &
-      666.667,   15.0000,   1.59000,   2.1100E-01, &
-      675.676,   14.8000,   1.61000,   2.0500E-01, &
-      714.286,   14.0000,   1.64000,   1.9500E-01, &
-      769.231,   13.0000,   1.69000,   1.9500E-01, &
-      800.000,   12.5000,   1.74000,   1.9800E-01, &
-      869.565,   11.5000,   1.89000,   3.7400E-01, &
-      909.091,   11.0000,   1.67000,   4.8500E-01, &
-      944.198,   10.5910,   1.72000,   3.4000E-01, &
-     1000.000,   10.0000,   1.89000,   4.5500E-01, &
-     1020.408,    9.8000,   1.91000,   6.8000E-01, &
-     1052.632,    9.5000,   1.67000,   7.5000E-01, &
-     1086.957,    9.2000,   1.60000,   5.8600E-01, &
-     1111.111,    9.0000,   1.65000,   6.3300E-01, &
-     1149.425,    8.7000,   1.53000,   7.7200E-01, &
-     1176.471,    8.5000,   1.37000,   7.5500E-01, &
-     1219.512,    8.2000,   1.20000,   6.4500E-01, &
-     1265.823,    7.9000,   1.14000,   4.8800E-01, &
-     1388.889,    7.2000,   1.21000,   1.7600E-01, &
-     1538.462,    6.5000,   1.37000,   1.2800E-01, &
-     1612.903,    6.2000,   1.42400,   1.6500E-01, &
-     1666.667,    6.0000,   1.42500,   1.9500E-01, &
-     1818.182,    5.5000,   1.33700,   1.8300E-01, &
-     2000.000,    5.0000,   1.36000,   1.2100E-01, &
-     2222.222,    4.5000,   1.38500,   1.2000E-01, &
-     2500.000,    4.0000,   1.39800,   1.2600E-01, &
-     2666.667,    3.7500,   1.39600,   1.3100E-01, &
-     2857.143,    3.5000,   1.37600,   1.5800E-01, &
-     2948.113,    3.3920,   1.35200,   1.5900E-01, &
-     3125.000,    3.2000,   1.31100,   1.3500E-01, &
-     3333.333,    3.0000,   1.29300,   9.5500E-02, &
-     3703.704,    2.7000,   1.30300,   5.7000E-03, &
-     4000.000,    2.5000,   1.34400,   3.7600E-03, &
-     4444.444,    2.2500,   1.37000,   1.8000E-03, &
-     5000.000,    2.0000,   1.38400,   1.2600E-03, &
-     5555.556,    1.8000,   1.39000,   5.5000E-04, &
-     6510.417,    1.5360,   1.40300,   1.3700E-04, &
-     7692.308,    1.3000,   1.41000,   1.0000E-05, &
-     9433.962,    1.0600,   1.42000,   1.5000E-06, &
-    11627.907,    0.8600,   1.42500,   1.7900E-07, &
-    14409.222,    0.6940,   1.42800,   1.9900E-08, &
-    15797.788,    0.6330,   1.42900,   1.4700E-08, &
-    18181.818,    0.5500,   1.43000,   1.0000E-08, &
-    19417.476,    0.5150,   1.43100,   1.0000E-08, &
-    20491.803,    0.4880,   1.43200,   1.0000E-08, &
-    25000.000,    0.4000,   1.44000,   1.0000E-08, &
-    29673.591,    0.3370,   1.45900,   1.0000E-08, &
-    33333.333,    0.3000,   1.46900,   1.0000E-08, &
-    40000.000,    0.2500,   1.48400,   1.0000E-08, &
-    50000.000,    0.2000,   1.49800,   1.0000E-08 /), (/nb_lambda_h2so4,4/), order=(/2,1/) )
-     
-    !--compute particle radius for a composition of 75% H2SO4 / 25% H2O at T=293K
-    DO bin_number=1, nbtr_bin
-      r_0=(dens_aer_dry/dens_aer_ref/0.75)**(1./3.)*mdw(bin_number)/2.
-    !--integral boundaries set to bin boundaries
-      rmin=r_0/sqrt(V_rat**(1./3.))
-      rmax=r_0*sqrt(V_rat**(1./3.))
-
-    !--set up SW
-      DO Nwv=1, NwvmaxSW
-        lambda_int(Nwv)=( lambda(Nwv)+lambda(Nwv+1) ) /2.
-      ENDDO
-
-      DO nb=1, nwave_sw+nwave_lw
-        lambda_int(NwvmaxSW+nb)=lambda_ref(nb)
-      ENDDO
-
-    !--set up LW
-    !--conversion wavenumber in cm-1 to wavelength in m
-      DO Nwv=1, nbands_lw_rrtm+1
-        wv_rrtm(Nwv)=10000./wn_rrtm(Nwv)*1.e-6
-      ENDDO
-
-      DO Nwv=1, NwvmaxLW
-        lambda_int(NwvmaxSW+nwave_sw+nwave_lw+Nwv)= &
-          exp( log(wv_rrtm(1))+float(Nwv-1)/float(NwvmaxLW-1)* &
-          (log(wv_rrtm(nbands_lw_rrtm+1))-log(wv_rrtm(1))) )
-      ENDDO
-
-!--computing the dlambdas
-      Nwv=1
-      dlambda_int(NwvmaxSW+nwave_sw+nwave_lw+Nwv)= &
-      &  lambda_int(NwvmaxSW+nwave_sw+nwave_lw+Nwv)- &
-      &  lambda_int(NwvmaxSW+nwave_sw+nwave_lw+Nwv+1)
-      DO Nwv=2, NwvmaxLW-1
-      dlambda_int(NwvmaxSW+nwave_sw+nwave_lw+Nwv)= &
-      &  (lambda_int(NwvmaxSW+nwave_sw+nwave_lw+Nwv-1)- &
-      &  lambda_int(NwvmaxSW+nwave_sw+nwave_lw+Nwv+1))/2.
-      ENDDO
-      Nwv=NwvmaxLW
-      dlambda_int(NwvmaxSW+nwave_sw+nwave_lw+Nwv)= &
-      &  lambda_int(NwvmaxSW+nwave_sw+nwave_lw+Nwv-1)- &
-      &  lambda_int(NwvmaxSW+nwave_sw+nwave_lw+Nwv)
-
-      IF (refr_ind_interpol) THEN
- 
-        ilambda_max=ref_ind(1,2)/1.e6 !--in m
-        ilambda_min=ref_ind(nb_lambda_h2so4,2)/1.e6 !--in m
-        DO Nwv=1, NwvmaxSW+nwave_sw+nwave_lw+NwvmaxLW
-          IF (lambda_int(Nwv).GT.ilambda_max) THEN
-            !for lambda out of data range, take boundary values
-            n_r(Nwv)=ref_ind(1,3)
-            n_i(Nwv)=ref_ind(1,4)
-          ELSEIF (lambda_int(Nwv).LE.ilambda_min) THEN
-            n_r(Nwv)=ref_ind(nb_lambda_h2so4,3)
-            n_i(Nwv)=ref_ind(nb_lambda_h2so4,4)
-          ELSE
-            DO nb=2,nb_lambda_h2so4
-              ilambda=ref_ind(nb,2)/1.e6
-              ilambda_prev=ref_ind(nb-1,2)/1.e6
-              n_r_h2so4=ref_ind(nb,3)
-              n_r_h2so4_prev=ref_ind(nb-1,3)
-              n_i_h2so4=ref_ind(nb,4)
-              n_i_h2so4_prev=ref_ind(nb-1,4)
-              IF (lambda_int(Nwv).GT.ilambda.AND. &
-                lambda_int(Nwv).LE.ilambda_prev) THEN !--- linear interpolation
-                n_r(Nwv)=n_r_h2so4+(lambda_int(Nwv)-ilambda)/ &
-                     (ilambda_prev-ilambda)*(n_r_h2so4_prev-n_r_h2so4)
-                n_i(Nwv)=n_i_h2so4+(lambda_int(Nwv)-ilambda)/ &
-                     (ilambda_prev-ilambda)*(n_i_h2so4_prev-n_i_h2so4)
-              ENDIF
-            ENDDO
-          ENDIF
-        ENDDO
-
-      ELSE  !-- no refr_ind_interpol, closest neighbour from upper wavelength
-
-        DO Nwv=1, NwvmaxSW+nwave_sw+nwave_lw+NwvmaxLW
-          n_r(Nwv)=ref_ind(1,3)
-          n_i(Nwv)=ref_ind(1,4)
-          DO nb=2,nb_lambda_h2so4
-            IF (ref_ind(nb,2)/1.e6.GT.lambda_int(Nwv)) THEN !--- step function
-              n_r(Nwv)=ref_ind(nb,3)
-              n_i(Nwv)=ref_ind(nb,4)
-            ENDIF  
-          ENDDO
-        ENDDO
-      ENDIF
-
-    !---Loop on wavelengths
-      DO Nwv=1, NwvmaxSW+nwave_sw+nwave_lw+NwvmaxLW
-
-      m=CMPLX(n_r(Nwv),-n_i(Nwv))
-
-      I=CMPLX(0.,1.)
-
-      sigma_sca=0.0
-      sigma_ext=0.0
-      sigma_abs=0.0
-      gtot=0.0
-      omegatot=0.0
-      masse = 0.0
-      volume=0.0
-      surface=0.0
-
-      DO bin=1, Nbin !---loop on size bins
-
-      r_lower=exp(log(rmin)+FLOAT(bin-1)/FLOAT(Nbin)*(log(rmax)-log(rmin)))
-      r_upper=exp(log(rmin)+FLOAT(bin)/FLOAT(Nbin)*(log(rmax)-log(rmin)))
-      deltar=r_upper-r_lower
-
-      r=sqrt(r_lower*r_upper)
-      x=2.*RPI*r/lambda_int(Nwv)
-
-!we impose a minimum value for x and extrapolate quantities for small x values
-      smallx = .FALSE.
-      IF (x.LT.0.001) THEN
-        smallx = .TRUE.
-        x_old = x
-        x = 0.001
-      ENDIF
-
-      number=Ntot*deltar/(rmax-rmin) !dN/dr constant over tracer bin
-!      masse=masse  +4./3.*RPI*(r**3)*number*deltar*ropx*1.E3  !--g/m3
-      volume=volume+4./3.*RPI*(r**3)*number*deltar
-      surface=surface+4.*RPI*r**2*number*deltar
-
-      k2=m
-      k3=CMPLX(1.0,0.0)
-
-      z2=CMPLX(x,0.0)
-      z1=m*z2
-
-      IF (0.0.LE.x.AND.x.LE.8.) THEN
-        Nmax=INT(x+4*x**(1./3.)+1.)+2
-      ELSEIF (8..LT.x.AND.x.LT.4200.) THEN
-        Nmax=INT(x+4.05*x**(1./3.)+2.)+1
-      ELSEIF (4200..LE.x.AND.x.LE.20000.) THEN
-        Nmax=INT(x+4*x**(1./3.)+2.)+1
-      ELSE
-        WRITE(lunout,*) 'x out of bound, x=', x
-        STOP
-      ENDIF
-
-      Nstart=Nmax+100
-
-    !-----------loop for nu1z1, nu1z2
-
-      nu1z1(Nstart)=CMPLX(0.0,0.0)
-      nu1z2(Nstart)=CMPLX(0.0,0.0)
-      DO n=Nstart-1, 1 , -1
-        nn=CMPLX(FLOAT(n),0.0)
-        nu1z1(n)=(nn+1.)/z1 - 1./( (nn+1.)/z1 + nu1z1(n+1) ) 
-        nu1z2(n)=(nn+1.)/z2 - 1./( (nn+1.)/z2 + nu1z2(n+1) )
-      ENDDO
-
-    !------------loop for nu3z2
-
-      nu3z2(0)=-I
-      DO n=1, Nmax
-        nn=CMPLX(FLOAT(n),0.0)
-        nu3z2(n)=-nn/z2 + 1./ (nn/z2 - nu3z2(n-1) ) 
-      ENDDO
-
-    !-----------loop for psiz2 and ksiz2 (z2)
-      ksiz2(-1)=COS(REAL(z2))-I*SIN(REAL(z2))
-      ksiz2(0)=SIN(REAL(z2))+I*COS(REAL(z2))
-      DO n=1,Nmax
-       nn=CMPLX(FLOAT(n),0.0)
-       ksiz2(n)=(2.*nn-1.)/z2 * ksiz2(n-1) - ksiz2(n-2)
-       psiz2(n)=CMPLX(REAL(ksiz2(n)),0.0)
-      ENDDO
-
-    !-----------loop for a(n) and b(n)
-
-      DO n=1, Nmax
-        u1=k3*nu1z1(n) - k2*nu1z2(n)
-        u5=k3*nu1z1(n) - k2*nu3z2(n)
-        u6=k2*nu1z1(n) - k3*nu1z2(n)
-        u8=k2*nu1z1(n) - k3*nu3z2(n)
-        a(n)=psiz2(n)/ksiz2(n) * u1/u5
-        b(n)=psiz2(n)/ksiz2(n) * u6/u8
-      ENDDO
-
-    !-----------------final loop--------------
-      Q_ext=0.0
-      Q_sca=0.0
-      g=0.0
-
-      DO n=Nmax-1,1,-1
-        nnn=FLOAT(n)
-        Q_ext=Q_ext+ (2.*nnn+1.) * REAL( a(n)+b(n) ) 
-        Q_sca=Q_sca+ (2.*nnn+1.) *  &
-                   REAL( a(n)*CONJG(a(n)) + b(n)*CONJG(b(n)) )
-        g=g + nnn*(nnn+2.)/(nnn+1.) *   &
-           REAL( a(n)*CONJG(a(n+1))+b(n)*CONJG(b(n+1)) )  +   &
-              (2.*nnn+1.)/nnn/(nnn+1.) * REAL(a(n)*CONJG(b(n)))
-      ENDDO
-
-      Q_ext=2./x**2 * Q_ext
-      Q_sca=2./x**2 * Q_sca
-    !--extrapolation in case of small x values
-      IF (smallx) THEN
-        Q_ext = x_old/x * Q_ext
-        Q_sca = x_old/x * Q_sca
-      ENDIF
-
-      Q_abs=Q_ext-Q_sca
-
-      IF (AIMAG(m).EQ.0.0) Q_abs=0.0
-      omega=Q_sca/Q_ext
-
-    ! g is wrong in the smallx case (but that does not matter as long as we ignore LW scattering)
-      g=g*4./x**2/Q_sca
-
-      sigma_sca=sigma_sca+r**2*Q_sca*number
-      sigma_abs=sigma_abs+r**2*Q_abs*number
-      sigma_ext=sigma_ext+r**2*Q_ext*number
-      omegatot=omegatot+r**2*Q_ext*omega*number
-      gtot    =gtot+r**2*Q_sca*g*number
- 
-      ENDDO   !---bin
-
-    !------------------------------------------------------------------
-
-      sigma_sca=RPI*sigma_sca
-      sigma_abs=RPI*sigma_abs
-      sigma_ext=RPI*sigma_ext
-      gtot=RPI*gtot/sigma_sca
-      omegatot=RPI*omegatot/sigma_ext
-
-      final_g(Nwv)=gtot
-      final_w(Nwv)=omegatot
-!      final_a(Nwv)=sigma_ext/masse
-      final_a(Nwv)=sigma_ext !extinction/absorption cross section per particle
-
-      ENDDO  !--loop on wavelength
-
-    !---averaging over LMDZ wavebands
-
-      DO band=1, nbands_sw_rrtm+nbands_lw_rrtm
-        gcm_a(band)=0.0
-        gcm_g(band)=0.0
-        gcm_w(band)=0.0
-        gcm_weight_a(band)=0.0
-        gcm_weight_g(band)=0.0
-        gcm_weight_w(band)=0.0
-      ENDDO
-
-    !---band 1 is now in the UV, so we take the first wavelength as being representative 
-      DO Nwv=1,1
-        bandSW=1
-        gcm_a(bandSW)=gcm_a(bandSW)+final_a(Nwv)*weight(Nwv)
-        gcm_weight_a(bandSW)=gcm_weight_a(bandSW)+weight(Nwv)
-        gcm_w(bandSW)=gcm_w(bandSW)+final_w(Nwv)*final_a(Nwv)*weight(Nwv)
-        gcm_weight_w(bandSW)=gcm_weight_w(bandSW)+final_a(Nwv)*weight(Nwv)
-        gcm_g(bandSW)=gcm_g(bandSW)+final_g(Nwv)*final_a(Nwv)*final_w(Nwv)*weight(Nwv)
-        gcm_weight_g(bandSW)=gcm_weight_g(bandSW)+final_a(Nwv)*final_w(Nwv)*weight(Nwv)
-      ENDDO
-
-      DO Nwv=1,NwvmaxSW
-
-        IF (lambda_int(Nwv).LE.wv_rrtm_SW(3)) THEN      !--RRTM spectral interval 2
-          bandSW=2
-        ELSEIF (lambda_int(Nwv).LE.wv_rrtm_SW(4)) THEN  !--RRTM spectral interval 3
-          bandSW=3
-        ELSEIF (lambda_int(Nwv).LE.wv_rrtm_SW(5)) THEN  !--RRTM spectral interval 4
-          bandSW=4
-        ELSEIF (lambda_int(Nwv).LE.wv_rrtm_SW(6)) THEN  !--RRTM spectral interval 5
-          bandSW=5
-        ELSE                                            !--RRTM spectral interval 6
-          bandSW=6
-        ENDIF
-
-        gcm_a(bandSW)=gcm_a(bandSW)+final_a(Nwv)*weight(Nwv)
-        gcm_weight_a(bandSW)=gcm_weight_a(bandSW)+weight(Nwv)
-        gcm_w(bandSW)=gcm_w(bandSW)+final_w(Nwv)*final_a(Nwv)*weight(Nwv)
-        gcm_weight_w(bandSW)=gcm_weight_w(bandSW)+final_a(Nwv)*weight(Nwv)
-        gcm_g(bandSW)=gcm_g(bandSW)+final_g(Nwv)*final_a(Nwv)*final_w(Nwv)*weight(Nwv)
-        gcm_weight_g(bandSW)=gcm_weight_g(bandSW)+final_a(Nwv)*final_w(Nwv)*weight(Nwv)
-
-      ENDDO
-
-      DO Nwv=NwvmaxSW+nwave_sw+nwave_lw+1,NwvmaxSW+nwave_sw+nwave_lw+NwvmaxLW
-        ll=lambda_int(Nwv)
-        dl=dlambda_int(Nwv)
-        weightLW=1./ll**5./(exp(hh*cc/kb/Tb/ll)-1.)*dl
-        bandLW=1  !--default value starting from the highest lambda
-        DO band=2, nbands_lw_rrtm
-          IF (ll.LT.wv_rrtm(band)) THEN   !--as long as
-            bandLW=band
-          ENDIF
-        ENDDO
-        gcm_a(nbands_sw_rrtm+bandLW)=gcm_a(nbands_sw_rrtm+bandLW)+final_a(Nwv)*   &
-             (1.-final_w(Nwv))*weightLW
-        gcm_weight_a(nbands_sw_rrtm+bandLW)=gcm_weight_a(nbands_sw_rrtm+bandLW)+weightLW
-
-        gcm_w(nbands_sw_rrtm+bandLW)=gcm_w(nbands_sw_rrtm+bandLW)+final_w(Nwv)*   &
-             final_a(Nwv)*weightLW
-        gcm_weight_w(nbands_sw_rrtm+bandLW)=gcm_weight_w(nbands_sw_rrtm+bandLW)+  &
-             final_a(Nwv)*weightLW
-
-        gcm_g(nbands_sw_rrtm+bandLW)=gcm_g(nbands_sw_rrtm+bandLW)+final_g(Nwv)*   &
-             final_a(Nwv)*final_w(Nwv)*weightLW
-        gcm_weight_g(nbands_sw_rrtm+bandLW)=gcm_weight_g(nbands_sw_rrtm+bandLW)+  &
-             final_a(Nwv)*final_w(Nwv)*weightLW
-      ENDDO
-
-      DO band=1, nbands_sw_rrtm+nbands_lw_rrtm
-        gcm_a(band)=gcm_a(band)/gcm_weight_a(band)
-        gcm_w(band)=gcm_w(band)/gcm_weight_w(band)
-        gcm_g(band)=gcm_g(band)/gcm_weight_g(band)
-        ss_a(band)=gcm_a(band)
-        ss_w(band)=gcm_w(band)
-        ss_g(band)=gcm_g(band)
-      ENDDO
-
-      DO nb=1, nwave_sw+nwave_lw
-        ss_a(nbands_sw_rrtm+nbands_lw_rrtm+nb)=final_a(NwvmaxSW+nb)
-        ss_w(nbands_sw_rrtm+nbands_lw_rrtm+nb)=final_w(NwvmaxSW+nb)
-        ss_g(nbands_sw_rrtm+nbands_lw_rrtm+nb)=final_g(NwvmaxSW+nb)
-      ENDDO
-
-      DO nb=1,nbands_sw_rrtm+nbands_lw_rrtm+nwave_sw+nwave_lw
-        alpha_bin(nb,bin_number)=ss_a(nb) !extinction/absorption cross section per particle
-        piz_bin(nb,bin_number)=ss_w(nb)
-        cg_bin(nb,bin_number)=ss_g(nb)
-      ENDDO
-
-    ENDDO !loop over tracer bins
-
-!!$OMP END MASTER
-!  CALL bcast(alpha_bin)
-!  CALL bcast(piz_bin)
-!  CALL bcast(cg_bin)
-!!$OMP BARRIER
-
-    !set to default values at first time step (tr_seri still zero)
-    tau_strat(:,:,:)=1.e-15
-    piz_strat(:,:,:)=1.0
-    cg_strat(:,:,:)=0.0
-    tau_lw_abs_rrtm(:,:,:)=1.e-15
-    tau_strat_wave(:,:,:)=1.e-15
-
-  ELSE  !-- not debut
-
-  !--compute optical properties of actual size distribution (from tr_seri)
-    DO ilon=1,klon
-      DO ilev=1, klev
-        DO nb=1,nbands_sw_rrtm
-          tau_strat(ilon,ilev,nb)=0.0
-          DO bin_number=1, nbtr_bin
-            tau_strat(ilon,ilev,nb)=tau_strat(ilon,ilev,nb)+alpha_bin(nb,bin_number) &
-                                *tr_seri(ilon,ilev,bin_number+nbtr_sulgas)*(paprs(ilon,ilev)-paprs(ilon,ilev+1))/RG
-          ENDDO
-
-          piz_strat(ilon,ilev,nb)=0.0
-          DO bin_number=1, nbtr_bin
-            piz_strat(ilon,ilev,nb)=piz_strat(ilon,ilev,nb)+piz_bin(nb,bin_number)*alpha_bin(nb,bin_number) &
-                                *tr_seri(ilon,ilev,bin_number+nbtr_sulgas)*(paprs(ilon,ilev)-paprs(ilon,ilev+1))/RG
-          ENDDO
-          piz_strat(ilon,ilev,nb)=piz_strat(ilon,ilev,nb)/MAX(tau_strat(ilon,ilev,nb),1.e-15)
-
-          cg_strat(ilon,ilev,nb)=0.0
-          DO bin_number=1, nbtr_bin
-            cg_strat(ilon,ilev,nb)=cg_strat(ilon,ilev,nb)+cg_bin(nb,bin_number)*piz_bin(nb,bin_number)*alpha_bin(nb,bin_number) &
-                                *tr_seri(ilon,ilev,bin_number+nbtr_sulgas)*(paprs(ilon,ilev)-paprs(ilon,ilev+1))/RG
-          ENDDO
-          cg_strat(ilon,ilev,nb)=cg_strat(ilon,ilev,nb)/MAX(tau_strat(ilon,ilev,nb)*piz_strat(ilon,ilev,nb),1.e-15)
-        ENDDO
-        DO nb=1,nbands_lw_rrtm
-          tau_lw_abs_rrtm(ilon,ilev,nb)=0.0
-          DO bin_number=1, nbtr_bin
-            tau_lw_abs_rrtm(ilon,ilev,nb)=tau_lw_abs_rrtm(ilon,ilev,nb)+alpha_bin(nbands_sw_rrtm+nb,bin_number) &
-                                *tr_seri(ilon,ilev,bin_number+nbtr_sulgas)*(paprs(ilon,ilev)-paprs(ilon,ilev+1))/RG
-          ENDDO
-        ENDDO
-        DO nb=1,nwave_sw+nwave_lw
-          tau_strat_wave(ilon,ilev,nb)=0.0
-          DO bin_number=1, nbtr_bin
-            tau_strat_wave(ilon,ilev,nb)=tau_strat_wave(ilon,ilev,nb)+alpha_bin(nbands_sw_rrtm+nbands_lw_rrtm+nb,bin_number) &
-                                *tr_seri(ilon,ilev,bin_number+nbtr_sulgas)*(paprs(ilon,ilev)-paprs(ilon,ilev+1))/RG
-          ENDDO
-        ENDDO
-      ENDDO
-    ENDDO
-
-  ENDIF !debut
-
-END SUBROUTINE MIECALC_AER
Index: /LMDZ6/trunk/libf/phylmd/StratAer/miecalc_aer.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/StratAer/miecalc_aer.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/StratAer/miecalc_aer.f90	(revision 5268)
@@ -0,0 +1,617 @@
+SUBROUTINE MIECALC_AER(tau_strat, piz_strat, cg_strat, tau_strat_wave, tau_lw_abs_rrtm, paprs, debut)
+
+!-------Mie computations for a size distribution 
+!       of homogeneous spheres.
+!
+!==========================================================
+!--Ref : Toon and Ackerman, Applied Optics, 1981
+!        Stephens, CSIRO, 1979
+! Attention : surdimensionement des tableaux
+! to be compiled with double precision option (-r8 on Sun)
+! AUTHOR: Olivier Boucher, Christoph Kleinschmitt
+!-------SIZE distribution properties----------------
+!--sigma_g : geometric standard deviation 
+!--r_0     : geometric number mean radius (um)/modal radius
+!--Ntot    : total concentration in m-3 
+
+  USE phys_local_var_mod, ONLY: tr_seri, mdw, alpha_bin, piz_bin, cg_bin
+  USE aerophys, ONLY: dens_aer_dry, dens_aer_ref, V_rat
+  USE aero_mod
+  USE infotrac_phy, ONLY : nbtr, nbtr_bin, nbtr_sulgas, id_SO2_strat
+  USE dimphy
+  USE yomcst_mod_h  , ONLY : RG, RPI
+  USE mod_phys_lmdz_para, only: gather, scatter, bcast
+  USE mod_grid_phy_lmdz, ONLY : klon_glo
+  USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+  USE print_control_mod, ONLY: prt_level, lunout
+
+  IMPLICIT NONE
+
+! Variable input
+  LOGICAL,INTENT(IN) :: debut   ! le flag de l'initialisation de la physique
+  REAL,DIMENSION(klon,klev+1),INTENT(IN) :: paprs   ! pression pour chaque inter-couche (en Pa)
+
+! Stratospheric aerosols optical properties
+  REAL, DIMENSION(klon,klev,nbands_sw_rrtm) :: tau_strat, piz_strat, cg_strat
+  REAL, DIMENSION(klon,klev,nwave_sw+nwave_lw) :: tau_strat_wave
+  REAL, DIMENSION(klon,klev,nbands_lw_rrtm) :: tau_lw_abs_rrtm
+
+!!  REAL,DIMENSION(klon_glo,klev,nbtr)     :: tr_seri_glo         ! Concentration Traceur [U/KgA]  
+
+! local variables
+  REAL Ntot
+  PARAMETER (Ntot=1.0)
+  LOGICAL, PARAMETER :: refr_ind_interpol = .TRUE. ! set interpolation of refractive index
+  REAL r_0    ! aerosol particle radius [m]
+  INTEGER bin_number, ilon, ilev
+  REAL masse,volume,surface
+  REAL rmin, rmax    !----integral bounds in  m
+
+!-------------------------------------
+
+  COMPLEX m          !----refractive index m=n_r-i*n_i
+  INTEGER Nmax,Nstart !--number of iterations
+  COMPLEX k2, k3, z1, z2
+  COMPLEX u1,u5,u6,u8
+  COMPLEX a(1:21000), b(1:21000)
+  COMPLEX I 
+  INTEGER n  !--loop index
+  REAL nnn
+  COMPLEX nn
+  REAL Q_ext, Q_abs, Q_sca, g, omega   !--parameters for radius r
+  REAL x, x_old  !--size parameter
+  REAL r, r_lower, r_upper  !--radius
+  REAL sigma_sca, sigma_ext, sigma_abs
+  REAL omegatot,  gtot !--averaged parameters
+  COMPLEX ksiz2(-1:21000), psiz2(1:21000)
+  COMPLEX nu1z1(1:21010), nu1z2(1:21010)
+  COMPLEX nu3z2(0:21000)
+  REAL number, deltar
+  INTEGER bin, Nbin, it
+  PARAMETER (Nbin=10)
+  LOGICAL smallx
+
+!---wavelengths STREAMER
+  INTEGER Nwv, NwvmaxSW
+  PARAMETER (NwvmaxSW=24)
+  REAL lambda(1:NwvmaxSW+1)
+  DATA lambda/0.28E-6, 0.30E-6, 0.33E-6, 0.36E-6, 0.40E-6, &
+              0.44E-6, 0.48E-6, 0.52E-6, 0.57E-6, 0.64E-6, &
+              0.69E-6, 0.75E-6, 0.78E-6, 0.87E-6, 1.00E-6, &
+              1.10E-6, 1.19E-6, 1.28E-6, 1.53E-6, 1.64E-6, &
+              2.13E-6, 2.38E-6, 2.91E-6, 3.42E-6, 4.00E-6/
+
+!---wavelengths de references
+!---be careful here the 5th wavelength is 1020 nm
+  INTEGER nb
+  REAL lambda_ref(nwave_sw+nwave_lw)
+  DATA lambda_ref /0.443E-6,0.550E-6,0.670E-6,  &
+                   0.765E-6,1.020E-6,10.E-6/
+
+!--LW 
+  INTEGER NwvmaxLW
+  PARAMETER (NwvmaxLW=500)
+  REAL Tb, hh, cc, kb
+  PARAMETER (Tb=220.0, hh=6.62607e-34)
+  PARAMETER (cc=2.99792e8, kb=1.38065e-23)
+
+!---TOA fluxes - Streamer Cs
+  REAL weight(1:NwvmaxSW), weightLW
+!c        DATA weight/0.839920E1, 0.231208E2, 0.322393E2, 0.465058E2,
+!c     .              0.678199E2, 0.798964E2, 0.771359E2, 0.888472E2,
+!c     .              0.115281E3, 0.727565E2, 0.816992E2, 0.336172E2,
+!c     .              0.914603E2, 0.112706E3, 0.658840E2, 0.524470E2,
+!c     .              0.391067E2, 0.883864E2, 0.276672E2, 0.681812E2,
+!c     .              0.190966E2, 0.250766E2, 0.128704E2, 0.698720E1/
+!---TOA fluxes - Tad
+  DATA weight/ 4.20, 11.56, 16.12, 23.25, 33.91, 39.95, 38.57, &
+              44.42, 57.64, 29.36, 47.87, 16.81, 45.74, 56.35, &
+              32.94, 26.22, 19.55, 44.19, 13.83, 34.09,  9.55, &
+              12.54,  6.44,  3.49/
+!C---BOA fluxes - Tad
+!c        DATA weight/ 0.01,  4.05, 9.51,  15.99, 26.07, 33.10, 33.07,
+!c     .              39.91, 52.67, 27.89, 43.60, 13.67, 42.22, 40.12,
+!c     .              32.70, 14.44, 19.48, 14.23, 13.43, 16.42,  8.33,
+!c     .               0.95,  0.65, 2.76/
+
+  REAL lambda_int(1:NwvmaxSW+nwave_sw+nwave_lw+NwvmaxLW), ll
+  REAL dlambda_int(1:NwvmaxSW+nwave_sw+nwave_lw+NwvmaxLW), dl
+
+  REAL n_r(1:NwvmaxSW+nwave_sw+nwave_lw+NwvmaxLW)
+  REAL n_i(1:NwvmaxSW+nwave_sw+nwave_lw+NwvmaxLW)
+
+  REAL ilambda, ilambda_prev, ilambda_max, ilambda_min
+  REAL n_r_h2so4, n_i_h2so4
+  REAL n_r_h2so4_prev, n_i_h2so4_prev
+
+  REAL final_a(1:NwvmaxSW+nwave_sw+nwave_lw+NwvmaxLW)
+  REAL final_g(1:NwvmaxSW+nwave_sw+nwave_lw+NwvmaxLW)
+  REAL final_w(1:NwvmaxSW+nwave_sw+nwave_lw+NwvmaxLW)
+
+  INTEGER band, bandSW, bandLW, wavenumber
+
+!---wavelengths SW RRTM
+  REAL wv_rrtm_SW(nbands_sw_rrtm+1)
+  DATA wv_rrtm_SW/  0.185E-6, 0.25E-6, 0.44E-6, 0.69E-6,  &
+                     1.19E-6, 2.38E-6, 4.00E-6/
+
+!---wavenumbers and wavelengths LW RRTM
+  REAL wn_rrtm(nbands_lw_rrtm+1), wv_rrtm(nbands_lw_rrtm+1)
+  DATA wn_rrtm/  10.,  250.,  500.,  630.,  700.,  820.,  &
+                980., 1080., 1180., 1390., 1480., 1800.,  &
+               2080., 2250., 2380., 2600., 3000./
+
+!--GCM results
+  REAL gcm_a(nbands_sw_rrtm+nbands_lw_rrtm)
+  REAL gcm_g(nbands_sw_rrtm+nbands_lw_rrtm)
+  REAL gcm_w(nbands_sw_rrtm+nbands_lw_rrtm)
+  REAL gcm_weight_a(nbands_sw_rrtm+nbands_lw_rrtm)
+  REAL gcm_weight_g(nbands_sw_rrtm+nbands_lw_rrtm)
+  REAL gcm_weight_w(nbands_sw_rrtm+nbands_lw_rrtm)
+
+  REAL ss_a(nbands_sw_rrtm+nbands_lw_rrtm+nwave_sw+nwave_lw)
+  REAL ss_w(nbands_sw_rrtm+nbands_lw_rrtm+nwave_sw+nwave_lw)
+  REAL ss_g(nbands_sw_rrtm+nbands_lw_rrtm+nwave_sw+nwave_lw)
+
+  !-- fichier h2so4_0.75_300.00_hummel_1988_p_q.dat
+  ! -- wavenumber (cm-1), wavelength (um), n_r, n_i
+  INTEGER, PARAMETER :: nb_lambda_h2so4=62
+  REAL, DIMENSION (nb_lambda_h2so4,4) :: ref_ind
+
+!---------------------------------------------------------
+
+  IF (debut) THEN   
+
+     ref_ind = RESHAPE( (/ &
+      200.000,   50.0000,   2.01000,   6.5000E-01, &
+      250.000,   40.0000,   1.94000,   6.3000E-01, & 
+      285.714,   35.0000,   1.72000,   5.2000E-01, & 
+      333.333,   30.0000,   1.73000,   2.9000E-01, & 
+      358.423,   27.9000,   1.78000,   2.5000E-01, & 
+      400.000,   25.0000,   1.84000,   2.4000E-01, &
+      444.444,   22.5000,   1.82000,   2.9000E-01, &
+      469.484,   21.3000,   1.79000,   2.5000E-01, &
+      500.000,   20.0000,   1.81000,   2.3000E-01, &
+      540.541,   18.5000,   1.92700,   3.0200E-01, &
+      555.556,   18.0000,   1.95000,   4.1000E-01, &
+      581.395,   17.2000,   1.72400,   5.9000E-01, &
+      609.756,   16.4000,   1.52000,   4.1400E-01, &
+      666.667,   15.0000,   1.59000,   2.1100E-01, &
+      675.676,   14.8000,   1.61000,   2.0500E-01, &
+      714.286,   14.0000,   1.64000,   1.9500E-01, &
+      769.231,   13.0000,   1.69000,   1.9500E-01, &
+      800.000,   12.5000,   1.74000,   1.9800E-01, &
+      869.565,   11.5000,   1.89000,   3.7400E-01, &
+      909.091,   11.0000,   1.67000,   4.8500E-01, &
+      944.198,   10.5910,   1.72000,   3.4000E-01, &
+     1000.000,   10.0000,   1.89000,   4.5500E-01, &
+     1020.408,    9.8000,   1.91000,   6.8000E-01, &
+     1052.632,    9.5000,   1.67000,   7.5000E-01, &
+     1086.957,    9.2000,   1.60000,   5.8600E-01, &
+     1111.111,    9.0000,   1.65000,   6.3300E-01, &
+     1149.425,    8.7000,   1.53000,   7.7200E-01, &
+     1176.471,    8.5000,   1.37000,   7.5500E-01, &
+     1219.512,    8.2000,   1.20000,   6.4500E-01, &
+     1265.823,    7.9000,   1.14000,   4.8800E-01, &
+     1388.889,    7.2000,   1.21000,   1.7600E-01, &
+     1538.462,    6.5000,   1.37000,   1.2800E-01, &
+     1612.903,    6.2000,   1.42400,   1.6500E-01, &
+     1666.667,    6.0000,   1.42500,   1.9500E-01, &
+     1818.182,    5.5000,   1.33700,   1.8300E-01, &
+     2000.000,    5.0000,   1.36000,   1.2100E-01, &
+     2222.222,    4.5000,   1.38500,   1.2000E-01, &
+     2500.000,    4.0000,   1.39800,   1.2600E-01, &
+     2666.667,    3.7500,   1.39600,   1.3100E-01, &
+     2857.143,    3.5000,   1.37600,   1.5800E-01, &
+     2948.113,    3.3920,   1.35200,   1.5900E-01, &
+     3125.000,    3.2000,   1.31100,   1.3500E-01, &
+     3333.333,    3.0000,   1.29300,   9.5500E-02, &
+     3703.704,    2.7000,   1.30300,   5.7000E-03, &
+     4000.000,    2.5000,   1.34400,   3.7600E-03, &
+     4444.444,    2.2500,   1.37000,   1.8000E-03, &
+     5000.000,    2.0000,   1.38400,   1.2600E-03, &
+     5555.556,    1.8000,   1.39000,   5.5000E-04, &
+     6510.417,    1.5360,   1.40300,   1.3700E-04, &
+     7692.308,    1.3000,   1.41000,   1.0000E-05, &
+     9433.962,    1.0600,   1.42000,   1.5000E-06, &
+    11627.907,    0.8600,   1.42500,   1.7900E-07, &
+    14409.222,    0.6940,   1.42800,   1.9900E-08, &
+    15797.788,    0.6330,   1.42900,   1.4700E-08, &
+    18181.818,    0.5500,   1.43000,   1.0000E-08, &
+    19417.476,    0.5150,   1.43100,   1.0000E-08, &
+    20491.803,    0.4880,   1.43200,   1.0000E-08, &
+    25000.000,    0.4000,   1.44000,   1.0000E-08, &
+    29673.591,    0.3370,   1.45900,   1.0000E-08, &
+    33333.333,    0.3000,   1.46900,   1.0000E-08, &
+    40000.000,    0.2500,   1.48400,   1.0000E-08, &
+    50000.000,    0.2000,   1.49800,   1.0000E-08 /), (/nb_lambda_h2so4,4/), order=(/2,1/) )
+     
+    !--compute particle radius for a composition of 75% H2SO4 / 25% H2O at T=293K
+    DO bin_number=1, nbtr_bin
+      r_0=(dens_aer_dry/dens_aer_ref/0.75)**(1./3.)*mdw(bin_number)/2.
+    !--integral boundaries set to bin boundaries
+      rmin=r_0/sqrt(V_rat**(1./3.))
+      rmax=r_0*sqrt(V_rat**(1./3.))
+
+    !--set up SW
+      DO Nwv=1, NwvmaxSW
+        lambda_int(Nwv)=( lambda(Nwv)+lambda(Nwv+1) ) /2.
+      ENDDO
+
+      DO nb=1, nwave_sw+nwave_lw
+        lambda_int(NwvmaxSW+nb)=lambda_ref(nb)
+      ENDDO
+
+    !--set up LW
+    !--conversion wavenumber in cm-1 to wavelength in m
+      DO Nwv=1, nbands_lw_rrtm+1
+        wv_rrtm(Nwv)=10000./wn_rrtm(Nwv)*1.e-6
+      ENDDO
+
+      DO Nwv=1, NwvmaxLW
+        lambda_int(NwvmaxSW+nwave_sw+nwave_lw+Nwv)= &
+          exp( log(wv_rrtm(1))+float(Nwv-1)/float(NwvmaxLW-1)* &
+          (log(wv_rrtm(nbands_lw_rrtm+1))-log(wv_rrtm(1))) )
+      ENDDO
+
+!--computing the dlambdas
+      Nwv=1
+      dlambda_int(NwvmaxSW+nwave_sw+nwave_lw+Nwv)= &
+      &  lambda_int(NwvmaxSW+nwave_sw+nwave_lw+Nwv)- &
+      &  lambda_int(NwvmaxSW+nwave_sw+nwave_lw+Nwv+1)
+      DO Nwv=2, NwvmaxLW-1
+      dlambda_int(NwvmaxSW+nwave_sw+nwave_lw+Nwv)= &
+      &  (lambda_int(NwvmaxSW+nwave_sw+nwave_lw+Nwv-1)- &
+      &  lambda_int(NwvmaxSW+nwave_sw+nwave_lw+Nwv+1))/2.
+      ENDDO
+      Nwv=NwvmaxLW
+      dlambda_int(NwvmaxSW+nwave_sw+nwave_lw+Nwv)= &
+      &  lambda_int(NwvmaxSW+nwave_sw+nwave_lw+Nwv-1)- &
+      &  lambda_int(NwvmaxSW+nwave_sw+nwave_lw+Nwv)
+
+      IF (refr_ind_interpol) THEN
+ 
+        ilambda_max=ref_ind(1,2)/1.e6 !--in m
+        ilambda_min=ref_ind(nb_lambda_h2so4,2)/1.e6 !--in m
+        DO Nwv=1, NwvmaxSW+nwave_sw+nwave_lw+NwvmaxLW
+          IF (lambda_int(Nwv).GT.ilambda_max) THEN
+            !for lambda out of data range, take boundary values
+            n_r(Nwv)=ref_ind(1,3)
+            n_i(Nwv)=ref_ind(1,4)
+          ELSEIF (lambda_int(Nwv).LE.ilambda_min) THEN
+            n_r(Nwv)=ref_ind(nb_lambda_h2so4,3)
+            n_i(Nwv)=ref_ind(nb_lambda_h2so4,4)
+          ELSE
+            DO nb=2,nb_lambda_h2so4
+              ilambda=ref_ind(nb,2)/1.e6
+              ilambda_prev=ref_ind(nb-1,2)/1.e6
+              n_r_h2so4=ref_ind(nb,3)
+              n_r_h2so4_prev=ref_ind(nb-1,3)
+              n_i_h2so4=ref_ind(nb,4)
+              n_i_h2so4_prev=ref_ind(nb-1,4)
+              IF (lambda_int(Nwv).GT.ilambda.AND. &
+                lambda_int(Nwv).LE.ilambda_prev) THEN !--- linear interpolation
+                n_r(Nwv)=n_r_h2so4+(lambda_int(Nwv)-ilambda)/ &
+                     (ilambda_prev-ilambda)*(n_r_h2so4_prev-n_r_h2so4)
+                n_i(Nwv)=n_i_h2so4+(lambda_int(Nwv)-ilambda)/ &
+                     (ilambda_prev-ilambda)*(n_i_h2so4_prev-n_i_h2so4)
+              ENDIF
+            ENDDO
+          ENDIF
+        ENDDO
+
+      ELSE  !-- no refr_ind_interpol, closest neighbour from upper wavelength
+
+        DO Nwv=1, NwvmaxSW+nwave_sw+nwave_lw+NwvmaxLW
+          n_r(Nwv)=ref_ind(1,3)
+          n_i(Nwv)=ref_ind(1,4)
+          DO nb=2,nb_lambda_h2so4
+            IF (ref_ind(nb,2)/1.e6.GT.lambda_int(Nwv)) THEN !--- step function
+              n_r(Nwv)=ref_ind(nb,3)
+              n_i(Nwv)=ref_ind(nb,4)
+            ENDIF  
+          ENDDO
+        ENDDO
+      ENDIF
+
+    !---Loop on wavelengths
+      DO Nwv=1, NwvmaxSW+nwave_sw+nwave_lw+NwvmaxLW
+
+      m=CMPLX(n_r(Nwv),-n_i(Nwv))
+
+      I=CMPLX(0.,1.)
+
+      sigma_sca=0.0
+      sigma_ext=0.0
+      sigma_abs=0.0
+      gtot=0.0
+      omegatot=0.0
+      masse = 0.0
+      volume=0.0
+      surface=0.0
+
+      DO bin=1, Nbin !---loop on size bins
+
+      r_lower=exp(log(rmin)+FLOAT(bin-1)/FLOAT(Nbin)*(log(rmax)-log(rmin)))
+      r_upper=exp(log(rmin)+FLOAT(bin)/FLOAT(Nbin)*(log(rmax)-log(rmin)))
+      deltar=r_upper-r_lower
+
+      r=sqrt(r_lower*r_upper)
+      x=2.*RPI*r/lambda_int(Nwv)
+
+!we impose a minimum value for x and extrapolate quantities for small x values
+      smallx = .FALSE.
+      IF (x.LT.0.001) THEN
+        smallx = .TRUE.
+        x_old = x
+        x = 0.001
+      ENDIF
+
+      number=Ntot*deltar/(rmax-rmin) !dN/dr constant over tracer bin
+!      masse=masse  +4./3.*RPI*(r**3)*number*deltar*ropx*1.E3  !--g/m3
+      volume=volume+4./3.*RPI*(r**3)*number*deltar
+      surface=surface+4.*RPI*r**2*number*deltar
+
+      k2=m
+      k3=CMPLX(1.0,0.0)
+
+      z2=CMPLX(x,0.0)
+      z1=m*z2
+
+      IF (0.0.LE.x.AND.x.LE.8.) THEN
+        Nmax=INT(x+4*x**(1./3.)+1.)+2
+      ELSEIF (8..LT.x.AND.x.LT.4200.) THEN
+        Nmax=INT(x+4.05*x**(1./3.)+2.)+1
+      ELSEIF (4200..LE.x.AND.x.LE.20000.) THEN
+        Nmax=INT(x+4*x**(1./3.)+2.)+1
+      ELSE
+        WRITE(lunout,*) 'x out of bound, x=', x
+        STOP
+      ENDIF
+
+      Nstart=Nmax+100
+
+    !-----------loop for nu1z1, nu1z2
+
+      nu1z1(Nstart)=CMPLX(0.0,0.0)
+      nu1z2(Nstart)=CMPLX(0.0,0.0)
+      DO n=Nstart-1, 1 , -1
+        nn=CMPLX(FLOAT(n),0.0)
+        nu1z1(n)=(nn+1.)/z1 - 1./( (nn+1.)/z1 + nu1z1(n+1) ) 
+        nu1z2(n)=(nn+1.)/z2 - 1./( (nn+1.)/z2 + nu1z2(n+1) )
+      ENDDO
+
+    !------------loop for nu3z2
+
+      nu3z2(0)=-I
+      DO n=1, Nmax
+        nn=CMPLX(FLOAT(n),0.0)
+        nu3z2(n)=-nn/z2 + 1./ (nn/z2 - nu3z2(n-1) ) 
+      ENDDO
+
+    !-----------loop for psiz2 and ksiz2 (z2)
+      ksiz2(-1)=COS(REAL(z2))-I*SIN(REAL(z2))
+      ksiz2(0)=SIN(REAL(z2))+I*COS(REAL(z2))
+      DO n=1,Nmax
+       nn=CMPLX(FLOAT(n),0.0)
+       ksiz2(n)=(2.*nn-1.)/z2 * ksiz2(n-1) - ksiz2(n-2)
+       psiz2(n)=CMPLX(REAL(ksiz2(n)),0.0)
+      ENDDO
+
+    !-----------loop for a(n) and b(n)
+
+      DO n=1, Nmax
+        u1=k3*nu1z1(n) - k2*nu1z2(n)
+        u5=k3*nu1z1(n) - k2*nu3z2(n)
+        u6=k2*nu1z1(n) - k3*nu1z2(n)
+        u8=k2*nu1z1(n) - k3*nu3z2(n)
+        a(n)=psiz2(n)/ksiz2(n) * u1/u5
+        b(n)=psiz2(n)/ksiz2(n) * u6/u8
+      ENDDO
+
+    !-----------------final loop--------------
+      Q_ext=0.0
+      Q_sca=0.0
+      g=0.0
+
+      DO n=Nmax-1,1,-1
+        nnn=FLOAT(n)
+        Q_ext=Q_ext+ (2.*nnn+1.) * REAL( a(n)+b(n) ) 
+        Q_sca=Q_sca+ (2.*nnn+1.) *  &
+                   REAL( a(n)*CONJG(a(n)) + b(n)*CONJG(b(n)) )
+        g=g + nnn*(nnn+2.)/(nnn+1.) *   &
+           REAL( a(n)*CONJG(a(n+1))+b(n)*CONJG(b(n+1)) )  +   &
+              (2.*nnn+1.)/nnn/(nnn+1.) * REAL(a(n)*CONJG(b(n)))
+      ENDDO
+
+      Q_ext=2./x**2 * Q_ext
+      Q_sca=2./x**2 * Q_sca
+    !--extrapolation in case of small x values
+      IF (smallx) THEN
+        Q_ext = x_old/x * Q_ext
+        Q_sca = x_old/x * Q_sca
+      ENDIF
+
+      Q_abs=Q_ext-Q_sca
+
+      IF (AIMAG(m).EQ.0.0) Q_abs=0.0
+      omega=Q_sca/Q_ext
+
+    ! g is wrong in the smallx case (but that does not matter as long as we ignore LW scattering)
+      g=g*4./x**2/Q_sca
+
+      sigma_sca=sigma_sca+r**2*Q_sca*number
+      sigma_abs=sigma_abs+r**2*Q_abs*number
+      sigma_ext=sigma_ext+r**2*Q_ext*number
+      omegatot=omegatot+r**2*Q_ext*omega*number
+      gtot    =gtot+r**2*Q_sca*g*number
+ 
+      ENDDO   !---bin
+
+    !------------------------------------------------------------------
+
+      sigma_sca=RPI*sigma_sca
+      sigma_abs=RPI*sigma_abs
+      sigma_ext=RPI*sigma_ext
+      gtot=RPI*gtot/sigma_sca
+      omegatot=RPI*omegatot/sigma_ext
+
+      final_g(Nwv)=gtot
+      final_w(Nwv)=omegatot
+!      final_a(Nwv)=sigma_ext/masse
+      final_a(Nwv)=sigma_ext !extinction/absorption cross section per particle
+
+      ENDDO  !--loop on wavelength
+
+    !---averaging over LMDZ wavebands
+
+      DO band=1, nbands_sw_rrtm+nbands_lw_rrtm
+        gcm_a(band)=0.0
+        gcm_g(band)=0.0
+        gcm_w(band)=0.0
+        gcm_weight_a(band)=0.0
+        gcm_weight_g(band)=0.0
+        gcm_weight_w(band)=0.0
+      ENDDO
+
+    !---band 1 is now in the UV, so we take the first wavelength as being representative 
+      DO Nwv=1,1
+        bandSW=1
+        gcm_a(bandSW)=gcm_a(bandSW)+final_a(Nwv)*weight(Nwv)
+        gcm_weight_a(bandSW)=gcm_weight_a(bandSW)+weight(Nwv)
+        gcm_w(bandSW)=gcm_w(bandSW)+final_w(Nwv)*final_a(Nwv)*weight(Nwv)
+        gcm_weight_w(bandSW)=gcm_weight_w(bandSW)+final_a(Nwv)*weight(Nwv)
+        gcm_g(bandSW)=gcm_g(bandSW)+final_g(Nwv)*final_a(Nwv)*final_w(Nwv)*weight(Nwv)
+        gcm_weight_g(bandSW)=gcm_weight_g(bandSW)+final_a(Nwv)*final_w(Nwv)*weight(Nwv)
+      ENDDO
+
+      DO Nwv=1,NwvmaxSW
+
+        IF (lambda_int(Nwv).LE.wv_rrtm_SW(3)) THEN      !--RRTM spectral interval 2
+          bandSW=2
+        ELSEIF (lambda_int(Nwv).LE.wv_rrtm_SW(4)) THEN  !--RRTM spectral interval 3
+          bandSW=3
+        ELSEIF (lambda_int(Nwv).LE.wv_rrtm_SW(5)) THEN  !--RRTM spectral interval 4
+          bandSW=4
+        ELSEIF (lambda_int(Nwv).LE.wv_rrtm_SW(6)) THEN  !--RRTM spectral interval 5
+          bandSW=5
+        ELSE                                            !--RRTM spectral interval 6
+          bandSW=6
+        ENDIF
+
+        gcm_a(bandSW)=gcm_a(bandSW)+final_a(Nwv)*weight(Nwv)
+        gcm_weight_a(bandSW)=gcm_weight_a(bandSW)+weight(Nwv)
+        gcm_w(bandSW)=gcm_w(bandSW)+final_w(Nwv)*final_a(Nwv)*weight(Nwv)
+        gcm_weight_w(bandSW)=gcm_weight_w(bandSW)+final_a(Nwv)*weight(Nwv)
+        gcm_g(bandSW)=gcm_g(bandSW)+final_g(Nwv)*final_a(Nwv)*final_w(Nwv)*weight(Nwv)
+        gcm_weight_g(bandSW)=gcm_weight_g(bandSW)+final_a(Nwv)*final_w(Nwv)*weight(Nwv)
+
+      ENDDO
+
+      DO Nwv=NwvmaxSW+nwave_sw+nwave_lw+1,NwvmaxSW+nwave_sw+nwave_lw+NwvmaxLW
+        ll=lambda_int(Nwv)
+        dl=dlambda_int(Nwv)
+        weightLW=1./ll**5./(exp(hh*cc/kb/Tb/ll)-1.)*dl
+        bandLW=1  !--default value starting from the highest lambda
+        DO band=2, nbands_lw_rrtm
+          IF (ll.LT.wv_rrtm(band)) THEN   !--as long as
+            bandLW=band
+          ENDIF
+        ENDDO
+        gcm_a(nbands_sw_rrtm+bandLW)=gcm_a(nbands_sw_rrtm+bandLW)+final_a(Nwv)*   &
+             (1.-final_w(Nwv))*weightLW
+        gcm_weight_a(nbands_sw_rrtm+bandLW)=gcm_weight_a(nbands_sw_rrtm+bandLW)+weightLW
+
+        gcm_w(nbands_sw_rrtm+bandLW)=gcm_w(nbands_sw_rrtm+bandLW)+final_w(Nwv)*   &
+             final_a(Nwv)*weightLW
+        gcm_weight_w(nbands_sw_rrtm+bandLW)=gcm_weight_w(nbands_sw_rrtm+bandLW)+  &
+             final_a(Nwv)*weightLW
+
+        gcm_g(nbands_sw_rrtm+bandLW)=gcm_g(nbands_sw_rrtm+bandLW)+final_g(Nwv)*   &
+             final_a(Nwv)*final_w(Nwv)*weightLW
+        gcm_weight_g(nbands_sw_rrtm+bandLW)=gcm_weight_g(nbands_sw_rrtm+bandLW)+  &
+             final_a(Nwv)*final_w(Nwv)*weightLW
+      ENDDO
+
+      DO band=1, nbands_sw_rrtm+nbands_lw_rrtm
+        gcm_a(band)=gcm_a(band)/gcm_weight_a(band)
+        gcm_w(band)=gcm_w(band)/gcm_weight_w(band)
+        gcm_g(band)=gcm_g(band)/gcm_weight_g(band)
+        ss_a(band)=gcm_a(band)
+        ss_w(band)=gcm_w(band)
+        ss_g(band)=gcm_g(band)
+      ENDDO
+
+      DO nb=1, nwave_sw+nwave_lw
+        ss_a(nbands_sw_rrtm+nbands_lw_rrtm+nb)=final_a(NwvmaxSW+nb)
+        ss_w(nbands_sw_rrtm+nbands_lw_rrtm+nb)=final_w(NwvmaxSW+nb)
+        ss_g(nbands_sw_rrtm+nbands_lw_rrtm+nb)=final_g(NwvmaxSW+nb)
+      ENDDO
+
+      DO nb=1,nbands_sw_rrtm+nbands_lw_rrtm+nwave_sw+nwave_lw
+        alpha_bin(nb,bin_number)=ss_a(nb) !extinction/absorption cross section per particle
+        piz_bin(nb,bin_number)=ss_w(nb)
+        cg_bin(nb,bin_number)=ss_g(nb)
+      ENDDO
+
+    ENDDO !loop over tracer bins
+
+!!$OMP END MASTER
+!  CALL bcast(alpha_bin)
+!  CALL bcast(piz_bin)
+!  CALL bcast(cg_bin)
+!!$OMP BARRIER
+
+    !set to default values at first time step (tr_seri still zero)
+    tau_strat(:,:,:)=1.e-15
+    piz_strat(:,:,:)=1.0
+    cg_strat(:,:,:)=0.0
+    tau_lw_abs_rrtm(:,:,:)=1.e-15
+    tau_strat_wave(:,:,:)=1.e-15
+
+  ELSE  !-- not debut
+
+  !--compute optical properties of actual size distribution (from tr_seri)
+    DO ilon=1,klon
+      DO ilev=1, klev
+        DO nb=1,nbands_sw_rrtm
+          tau_strat(ilon,ilev,nb)=0.0
+          DO bin_number=1, nbtr_bin
+            tau_strat(ilon,ilev,nb)=tau_strat(ilon,ilev,nb)+alpha_bin(nb,bin_number) &
+                                *tr_seri(ilon,ilev,bin_number+nbtr_sulgas)*(paprs(ilon,ilev)-paprs(ilon,ilev+1))/RG
+          ENDDO
+
+          piz_strat(ilon,ilev,nb)=0.0
+          DO bin_number=1, nbtr_bin
+            piz_strat(ilon,ilev,nb)=piz_strat(ilon,ilev,nb)+piz_bin(nb,bin_number)*alpha_bin(nb,bin_number) &
+                                *tr_seri(ilon,ilev,bin_number+nbtr_sulgas)*(paprs(ilon,ilev)-paprs(ilon,ilev+1))/RG
+          ENDDO
+          piz_strat(ilon,ilev,nb)=piz_strat(ilon,ilev,nb)/MAX(tau_strat(ilon,ilev,nb),1.e-15)
+
+          cg_strat(ilon,ilev,nb)=0.0
+          DO bin_number=1, nbtr_bin
+            cg_strat(ilon,ilev,nb)=cg_strat(ilon,ilev,nb)+cg_bin(nb,bin_number)*piz_bin(nb,bin_number)*alpha_bin(nb,bin_number) &
+                                *tr_seri(ilon,ilev,bin_number+nbtr_sulgas)*(paprs(ilon,ilev)-paprs(ilon,ilev+1))/RG
+          ENDDO
+          cg_strat(ilon,ilev,nb)=cg_strat(ilon,ilev,nb)/MAX(tau_strat(ilon,ilev,nb)*piz_strat(ilon,ilev,nb),1.e-15)
+        ENDDO
+        DO nb=1,nbands_lw_rrtm
+          tau_lw_abs_rrtm(ilon,ilev,nb)=0.0
+          DO bin_number=1, nbtr_bin
+            tau_lw_abs_rrtm(ilon,ilev,nb)=tau_lw_abs_rrtm(ilon,ilev,nb)+alpha_bin(nbands_sw_rrtm+nb,bin_number) &
+                                *tr_seri(ilon,ilev,bin_number+nbtr_sulgas)*(paprs(ilon,ilev)-paprs(ilon,ilev+1))/RG
+          ENDDO
+        ENDDO
+        DO nb=1,nwave_sw+nwave_lw
+          tau_strat_wave(ilon,ilev,nb)=0.0
+          DO bin_number=1, nbtr_bin
+            tau_strat_wave(ilon,ilev,nb)=tau_strat_wave(ilon,ilev,nb)+alpha_bin(nbands_sw_rrtm+nbands_lw_rrtm+nb,bin_number) &
+                                *tr_seri(ilon,ilev,bin_number+nbtr_sulgas)*(paprs(ilon,ilev)-paprs(ilon,ilev+1))/RG
+          ENDDO
+        ENDDO
+      ENDDO
+    ENDDO
+
+  ENDIF !debut
+
+END SUBROUTINE MIECALC_AER
Index: DZ6/trunk/libf/phylmd/StratAer/minmaxsimple.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/StratAer/minmaxsimple.F90	(revision 5267)
+++ 	(revision )
@@ -1,23 +1,0 @@
-!
-! $Id$
-!
-SUBROUTINE minmaxsimple(zq,qmin,qmax,comment)
-  USE dimphy
-  IMPLICIT NONE
-
-! Entrees
-  REAL,DIMENSION(klon,klev), INTENT(IN)   :: zq
-  REAL,INTENT(IN)                         :: qmin,qmax
-  CHARACTER(LEN=*),INTENT(IN)             :: comment
-
-! Local  
-  REAL zmin, zmax
-  
-  zmin=MINVAL(zq)
-  zmax=MAXVAL(zq)
-  PRINT *, "qmin qmax=", zmin, zmax, comment
-!  IF (zmin.LT.qmin.OR.zmax.GT.qmax) THEN
-!      WRITE(*,*) "qmin qmax=", zmin, zmax, comment
-!  ENDIF
-  
-END SUBROUTINE minmaxsimple
Index: /LMDZ6/trunk/libf/phylmd/StratAer/minmaxsimple.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/StratAer/minmaxsimple.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/StratAer/minmaxsimple.f90	(revision 5268)
@@ -0,0 +1,23 @@
+!
+! $Id$
+!
+SUBROUTINE minmaxsimple(zq,qmin,qmax,comment)
+  USE dimphy
+  IMPLICIT NONE
+
+! Entrees
+  REAL,DIMENSION(klon,klev), INTENT(IN)   :: zq
+  REAL,INTENT(IN)                         :: qmin,qmax
+  CHARACTER(LEN=*),INTENT(IN)             :: comment
+
+! Local  
+  REAL zmin, zmax
+  
+  zmin=MINVAL(zq)
+  zmax=MAXVAL(zq)
+  PRINT *, "qmin qmax=", zmin, zmax, comment
+!  IF (zmin.LT.qmin.OR.zmax.GT.qmax) THEN
+!      WRITE(*,*) "qmin qmax=", zmin, zmax, comment
+!  ENDIF
+  
+END SUBROUTINE minmaxsimple
Index: DZ6/trunk/libf/phylmd/StratAer/nucleation_tstep_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/StratAer/nucleation_tstep_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,813 +1,0 @@
-!
-! $Id$
-!
-MODULE nucleation_tstep_mod
-
-CONTAINS
-
-SUBROUTINE nucleation_rate(rhoa,t_seri,pplay,rh,a_xm,b_xm,c_xm,nucl_rate,ntot_n,x_n)
-
-  USE aerophys
-  USE infotrac_phy
-  USE strataer_local_var_mod, ONLY : flag_new_nucl
-  
-  IMPLICIT NONE
-
-  ! input variables
-  REAL rhoa    ! H2SO4 number density [molecules/cm3]
-  REAL t_seri  ! temperature (K)
-  REAL pplay   ! pressure (Pa)
-  REAL rh      ! relative humidity (between 0 and 1)
-  REAL a_xm, b_xm, c_xm
-
-  ! output variables
-  REAL nucl_rate
-  REAL ntot_n ! total number of molecules in the critical cluster for neutral nucleation
-  REAL x_n    ! mole fraction of H2SO4 in the critical cluster for neutral nucleation
-
-  ! local variables
-  REAL jnuc_n ! nucleation rate in 1/cm3s (10^-7-10^10 1/cm3s) for neutral nucleation
-  REAL rc_n   ! radius of the critical cluster in nm for neutral nucleation
-  REAL na_n   ! sulfuric acid molecules in the neutral critical cluster (NOT IN USE)
-  LOGICAL kinetic_n ! true if kinetic neutral nucleation (NOT IN USE)
-  LOGICAL kinetic_i ! true if kinetic ion-induced nucleation (NOT IN USE)
-  REAL VH2SO4mol
-  REAL ntot_i, x_i, jnuc_i, rc_i, na_i, n_i ! quantities for charged nucleation (NOT IN USE)
-  REAL csi     ! Ion condensation sink (s-1) NOT IN USE
-  REAL airn    ! Air molecule concentration in (cm-3) NOT IN USE
-  REAL ipr     ! Ion pair production rate (cm-3 s-1) NOT IN USE
-
-  include "YOMCST.h"
-
-  ! call nucleation routine
-  IF (.NOT.flag_new_nucl) THEN
-    ! Use older routine from Hanna Vehkamäki (FMI)
-    CALL binapara(t_seri,rh,rhoa,jnuc_n,x_n,ntot_n,rc_n)
-    ! when total number of molecules is too small 
-    ! then set jnuc_n to collision rate of two H2SO4 molecules (following personal communication of Ulrike Niemeier and Hanna Vehkamäki)
-    IF (ntot_n < 4.0) THEN
-      VH2SO4mol=mH2SO4mol/(1.E-3*(a_xm+t_seri*(b_xm+t_seri*c_xm))) !cm3
-      jnuc_n = rhoa**2. *(3./4.*RPI)**(1./6.) *(12.*RKBOL*t_seri/mH2SO4mol)**0.5 &
-           & *100.*(2.*VH2SO4mol**(1./3.))**2. !1/(cm3s)
-      ntot_n=2.0
-      x_n=1.0
-    ENDIF
-  ELSE
-    ! Use new routine from Anni Maattanen (LATMOS)
-    csi=0.0   ! no charged nucleation for now
-    ipr=-1.0  ! dummy value to make sure charged nucleation does not occur
-    airn=0.0  ! NOT IN USE
-!   airn=pplay/t_seri/RD/1.E3*RNAVO/RMD ! molec cm-3 (for future use, to be confirmed)
-    CALL newbinapara(t_seri,rh,rhoa,csi,airn,ipr,jnuc_n,ntot_n,jnuc_i,ntot_i, &
-                   & x_n,x_i,na_n,na_i,rc_n,rc_i,n_i,kinetic_n,kinetic_i)
-  ENDIF
-
-  ! convert jnuc_n from particles/cm3/s to kg(H2SO4)/kgA/s
-  nucl_rate=jnuc_n*ntot_n*x_n*mH2SO4mol/(pplay/t_seri/RD/1.E6)
-
-END SUBROUTINE nucleation_rate
-
-!--------------------------------------------------------------------------------------------------
-
-SUBROUTINE nucleation_part(nucl_rate,ntot,x,dt,tr_seri)
-
-  USE aerophys
-  USE infotrac_phy
-  USE strataer_local_var_mod, ONLY : Vbin
-  
-  IMPLICIT NONE
-
-  ! input variable
-  REAL nucl_rate
-  REAL ntot ! total number of molecules in the critical cluster
-  REAL x    ! mole raction of H2SO4 in the critical cluster
-  REAL dt
-  
-  ! output variable
-  REAL tr_seri(nbtr)
-
-  ! local variable
-  INTEGER k
-  REAL Vnew
-  REAL ff(nbtr_bin)
-
-  ! dry volume of nucleated particle (at reference temperature)
-  !  dens_aer_dry (density of dry aerosol []kg/m3)
-  !  H2SO4mol: mass of an H2SO4 molecule [kg]
-  !  Vnew [m3]
-  Vnew=mH2SO4mol*ntot*x/dens_aer_dry
-
-  ! compute distribution factor for particles of intermediate size (from Jacobson 1994, equation 13)
-  ff(:)=0.0 
-  DO k=1, nbtr_bin 
-  ! CK 20160531: bug fix for first bin
-    IF (k.LE.nbtr_bin-1) THEN 
-      IF (Vbin(k).LE.Vnew.AND.Vnew.LT.Vbin(k+1)) THEN
-        ff(k)= Vbin(k)/Vnew*(Vbin(k+1)-Vnew)/(Vbin(k+1)-Vbin(k))
-      ENDIF
-    ENDIF
-    IF (k.EQ.1.AND.Vnew.LE.Vbin(k)) THEN
-      ff(k)= 1.
-    ENDIF
-    IF (k.GT.1) THEN 
-      IF (Vbin(k-1).LT.Vnew.AND.Vnew.LT.Vbin(k)) THEN
-        ff(k)= 1.-ff(k-1)
-      ENDIF
-    ENDIF
-    IF (k.EQ.nbtr_bin.AND.Vnew.GE.Vbin(k)) THEN
-      ff(k)= 1.
-    ENDIF
-  ENDDO
-  ! correction of ff for volume conservation
-  DO k=1, nbtr_bin         
-    ff(k)=ff(k)*Vnew/Vbin(k)
-  ENDDO
-
-  ! add nucleated H2SO4 to corresponding aerosol bin
-  DO k=1, nbtr_bin
-    tr_seri(k+nbtr_sulgas)=tr_seri(k+nbtr_sulgas)+nucl_rate*dt/(mH2SO4mol*ntot*x)*ff(k)
-  ENDDO
-
-END SUBROUTINE nucleation_part
-
-!---------------------------------------------------------------------------------------------------
-
-SUBROUTINE binapara(pt,prh,rhoa_in,jnuc,x,ntot,rc)
-
-
-  !    Fortran 90 subroutine binapara
-  !
-  !    Calculates parametrized values of nucleation rate,
-  !    mole fraction of sulphuric acid
-  !    total number of particles, and the radius of the critical cluster
-  !    in H2O-H2SO4 system IF temperature, saturatio ratio of water and 
-  !    sulfuric acid concentration  are given. 
-  !
-  !    Copyright (C) 2002 Hanna Vehkamäki
-  !
-  !    Division of Atmospheric Sciences
-  !    Department of Physical Sciences
-  !    P.O. Box 64
-  !    FIN-00014 University of Helsinki
-  !    Finland
-  !    
-  !    hanna.vehkamaki@helsinki.fi
-
-  IMPLICIT NONE 
-
-  REAL :: pt,t     !temperature in K (190.15-300.15K)
-  REAL :: prh,rh    !saturation ratio of water (0.0001-1)
-  REAL,INTENT(IN) :: rhoa_in    !sulfuric acid concentration in 1/cm3 (10^4-10^11 1/cm3)
-  REAL,INTENT(OUT) :: jnuc    !nucleation rate in 1/cm3s (10^-7-10^10 1/cm3s)
-  REAL,INTENT(OUT) :: ntot !total number of molecules in the critical cluster (ntot>4)
-  REAL,INTENT(OUT) :: x    ! mole fraction of H2SO4 in the critical cluster       
-  REAL,INTENT(OUT) :: rc    !radius of the critical cluster in nm     
-  REAL :: rhotres    ! threshold concentration of h2so4 (1/cm^3)
-                     ! which produces nucleation rate   1/(cm^3 s) as a function of rh and t 
-  REAL rhoa
-
-! CK: use intermediate variable to avoid overwriting
-  t=pt
-  rh=prh
-  rhoa=rhoa_in
-
-  IF (t < 190.15) THEN
-     t=190.15
-  ENDIF
-
-  IF (t > 300.15) THEN
-     t=300.15
-  ENDIF
-
-  IF (rh < 0.0001) THEN
-     rh=0.0001
-  ENDIF
-
-  IF (rh > 1.0) THEN
-     rh=1.0
-  ENDIF
-
-  IF (rhoa < 1.e4) THEN
-     rhoa=1.e4
-  ENDIF
-
-  IF (rhoa > 1.e11) THEN
-     rhoa=1.e11
-  ENDIF
-
-  x=  0.7409967177282139 - 0.002663785665140117*t + 0.002010478847383187*LOG(rh)  &
-       & - 0.0001832894131464668*t*LOG(rh) + 0.001574072538464286*LOG(rh)**2      &
-       & - 0.00001790589121766952*t*LOG(rh)**2 + 0.0001844027436573778*LOG(rh)**3 &
-       & -  1.503452308794887E-6*t*LOG(rh)**3 - 0.003499978417957668*LOG(rhoa)    &
-       & + 0.0000504021689382576*t*LOG(rhoa)
-
-  jnuc= 0.1430901615568665 + 2.219563673425199*t - 0.02739106114964264*t**2 + &
-       &  0.00007228107239317088*t**3 + 5.91822263375044/x +                  &
-       &  0.1174886643003278*LOG(rh) + 0.4625315047693772*t*LOG(rh) -          &
-       &  0.01180591129059253*t**2*LOG(rh) +                                  &
-       &  0.0000404196487152575*t**3*LOG(rh) + (15.79628615047088*LOG(rh))/x - &
-       &  0.215553951893509*LOG(rh)**2 - 0.0810269192332194*t*LOG(rh)**2 +    &
-       &  0.001435808434184642*t**2*LOG(rh)**2 -                               &
-       &  4.775796947178588E-6*t**3*LOG(rh)**2 -                               &
-       &  (2.912974063702185*LOG(rh)**2)/x - 3.588557942822751*LOG(rh)**3 +   &
-       &  0.04950795302831703*t*LOG(rh)**3 -                                   &
-       &  0.0002138195118737068*t**2*LOG(rh)**3 +                             &
-       &  3.108005107949533E-7*t**3*LOG(rh)**3 -                               &
-       &  (0.02933332747098296*LOG(rh)**3)/x +                                &
-       &  1.145983818561277*LOG(rhoa) -                                        &
-       &  0.6007956227856778*t*LOG(rhoa) +                                    &
-       &  0.00864244733283759*t**2*LOG(rhoa) -                                 &
-       &  0.00002289467254710888*t**3*LOG(rhoa) -                              &
-       &  (8.44984513869014*LOG(rhoa))/x +                                    &
-       &  2.158548369286559*LOG(rh)*LOG(rhoa) +                               &
-       &  0.0808121412840917*t*LOG(rh)*LOG(rhoa) -                             &
-       &  0.0004073815255395214*t**2*LOG(rh)*LOG(rhoa) -                       &
-       &  4.019572560156515E-7*t**3*LOG(rh)*LOG(rhoa) +                       &
-       &  (0.7213255852557236*LOG(rh)*LOG(rhoa))/x +                          &
-       &  1.62409850488771*LOG(rh)**2*LOG(rhoa) -                              &
-       &  0.01601062035325362*t*LOG(rh)**2*LOG(rhoa) +                        &
-       &  0.00003771238979714162*t**2*LOG(rh)**2*LOG(rhoa) +                  &
-       &  3.217942606371182E-8*t**3*LOG(rh)**2*LOG(rhoa) -                     &
-       &  (0.01132550810022116*LOG(rh)**2*LOG(rhoa))/x +                      &
-       &  9.71681713056504*LOG(rhoa)**2 -                                      &
-       &  0.1150478558347306*t*LOG(rhoa)**2 +                                 &
-       &  0.0001570982486038294*t**2*LOG(rhoa)**2 +                           &
-       &  4.009144680125015E-7*t**3*LOG(rhoa)**2 +                            &
-       &  (0.7118597859976135*LOG(rhoa)**2)/x -                                &
-       &  1.056105824379897*LOG(rh)*LOG(rhoa)**2 +                            &
-       &  0.00903377584628419*t*LOG(rh)*LOG(rhoa)**2 -                         &
-       &  0.00001984167387090606*t**2*LOG(rh)*LOG(rhoa)**2 +                  &
-       &  2.460478196482179E-8*t**3*LOG(rh)*LOG(rhoa)**2 -                     &
-       &  (0.05790872906645181*LOG(rh)*LOG(rhoa)**2)/x -                       &
-       &  0.1487119673397459*LOG(rhoa)**3 +                                   &
-       &  0.002835082097822667*t*LOG(rhoa)**3 -                                &
-       &  9.24618825471694E-6*t**2*LOG(rhoa)**3 +                             &
-       &  5.004267665960894E-9*t**3*LOG(rhoa)**3 -                             &
-       &  (0.01270805101481648*LOG(rhoa)**3)/x
-  jnuc=EXP(jnuc) !1/(cm3s)
-
-  ntot =-0.002954125078716302 - 0.0976834264241286*t + 0.001024847927067835*t**2 - 2.186459697726116E-6*t**3 -    &
-       &   0.1017165718716887/x - 0.002050640345231486*LOG(rh) - 0.007585041382707174*t*LOG(rh) +                &
-       &   0.0001926539658089536*t**2*LOG(rh) - 6.70429719683894E-7*t**3*LOG(rh) -                                &
-       &   (0.2557744774673163*LOG(rh))/x + 0.003223076552477191*LOG(rh)**2 + 0.000852636632240633*t*LOG(rh)**2 - &
-       &   0.00001547571354871789*t**2*LOG(rh)**2 + 5.666608424980593E-8*t**3*LOG(rh)**2 +                       &
-       &   (0.03384437400744206*LOG(rh)**2)/x + 0.04743226764572505*LOG(rh)**3 -                                  &
-       &   0.0006251042204583412*t*LOG(rh)**3 + 2.650663328519478E-6*t**2*LOG(rh)**3 -                            &
-       &   3.674710848763778E-9*t**3*LOG(rh)**3 - (0.0002672510825259393*LOG(rh)**3)/x -                          &
-       &   0.01252108546759328*LOG(rhoa) + 0.005806550506277202*t*LOG(rhoa) -                                     &
-       &   0.0001016735312443444*t**2*LOG(rhoa) + 2.881946187214505E-7*t**3*LOG(rhoa) +                          &
-       &   (0.0942243379396279*LOG(rhoa))/x - 0.0385459592773097*LOG(rh)*LOG(rhoa) -                              &
-       &   0.0006723156277391984*t*LOG(rh)*LOG(rhoa) + 2.602884877659698E-6*t**2*LOG(rh)*LOG(rhoa) +             &
-       &   1.194163699688297E-8*t**3*LOG(rh)*LOG(rhoa) - (0.00851515345806281*LOG(rh)*LOG(rhoa))/x -              &
-       &   0.01837488495738111*LOG(rh)**2*LOG(rhoa) + 0.0001720723574407498*t*LOG(rh)**2*LOG(rhoa) -              &
-       &   3.717657974086814E-7*t**2*LOG(rh)**2*LOG(rhoa) -                                                       &
-       &   5.148746022615196E-10*t**3*LOG(rh)**2*LOG(rhoa) +                                                     &
-       &   (0.0002686602132926594*LOG(rh)**2*LOG(rhoa))/x - 0.06199739728812199*LOG(rhoa)**2 +                   &
-       &   0.000906958053583576*t*LOG(rhoa)**2 - 9.11727926129757E-7*t**2*LOG(rhoa)**2 -                          &
-       &   5.367963396508457E-9*t**3*LOG(rhoa)**2 - (0.007742343393937707*LOG(rhoa)**2)/x +                      &
-       &   0.0121827103101659*LOG(rh)*LOG(rhoa)**2 - 0.0001066499571188091*t*LOG(rh)*LOG(rhoa)**2 +              &
-       &   2.534598655067518E-7*t**2*LOG(rh)*LOG(rhoa)**2 -                                                       &
-       &   3.635186504599571E-10*t**3*LOG(rh)*LOG(rhoa)**2 +                                                     &
-       &   (0.0006100650851863252*LOG(rh)*LOG(rhoa)**2)/x + 0.0003201836700403512*LOG(rhoa)**3 -                  &
-       &   0.0000174761713262546*t*LOG(rhoa)**3 + 6.065037668052182E-8*t**2*LOG(rhoa)**3 -                        &
-       &   1.421771723004557E-11*t**3*LOG(rhoa)**3 + (0.0001357509859501723*LOG(rhoa)**3)/x
-  ntot=EXP(ntot)
-
-  rc=EXP(-1.6524245+0.42316402*x+0.33466487*LOG(ntot)) !nm
-
-  IF (jnuc < 1.E-7) THEN
-     jnuc=0.0
-  ENDIF
-
-  IF (jnuc > 1.e10) THEN
-     jnuc=1.e10
-  ENDIF
-
-  rhotres=EXP( -279.2430007512709 + 11.73439886096903*rh + 22700.92970508331/t &
-       & - (1088.644983466801*rh)/t + 1.144362942094912*t                      &
-       & - 0.03023314602163684*rh*t - 0.001302541390154324*t**2                &
-       & - 6.386965238433532*LOG(rh) + (854.980361026715*LOG(rh))/t            &
-       & + 0.00879662256826497*t*LOG(rh)) !1/cm3
-
-  RETURN
-
-END SUBROUTINE binapara
-
-!---------------------------------------------------------------------------------------------------
-
-SUBROUTINE newbinapara(t,satrat,rhoa,csi,airn,ipr,jnuc_n_real,ntot_n_real,jnuc_i_real,ntot_i_real,        &
-                   &   x_n_real,x_i_real,na_n_real,na_i_real,rc_n_real,rc_i_real,n_i_real,                & 
-                   &   kinetic_n,kinetic_i)
-
-  !    Fortran 90 subroutine newbinapara
-  !
-  !    Calculates parametrized values for neutral and ion-induced sulfuric acid-water particle formation rate
-  !    of critical clusters, 
-  !    number of particle in the critical clusters, the radii of the critical clusters
-  !    in H2O-H2SO4-ion system if temperature, saturation ratio of water, sulfuric acid concentration, 
-  !    and, optionally, either condensation sink due to pre-existing particle and ion pair production rate,
-  !    or atmospheric concentration of negative ions are given. 
-  !
-  !    The code calculates also the kinetic limit and the particle formation rate
-  !    above this limit (in which case we set ntot=1 and na=1)
-  !
-  !    Copyright (C)2018 Määttänen et al. 2018
-  !    
-  !    anni.maattanen@latmos.ipsl.fr
-  !    joonas.merikanto@fmi.fi
-  !    hanna.vehkamaki@helsinki.fi
-  !
-  !    References
-  !    A. Määttänen, J. Merikanto, H. Henschel, J. Duplissy, R. Makkonen, 
-  !    I. K. Ortega and H. Vehkamäki (2018), New parameterizations for 
-  !    neutral and ion-induced sulfuric acid-water particle formation in 
-  !    nucleation and kinetic regimes, J. Geophys. Res. Atmos., 122, doi:10.1002/2017JD027429.
-  !
-  !    Brasseur, G., and A.  Chatel (1983),  paper  presented  at  the  9th  Annual  Meeting  of  the  
-  !    European Geophysical Society, Leeds, Great Britain, August 1982.
-  !  
-  !    Dunne, Eimear M., et al.(2016), Global atmospheric particle formation from CERN CLOUD measurements,
-  !    Science 354.6316, 1119-1124.   
-  !
-
-  USE aerophys
-
-  IMPLICIT NONE 
-
-  !----------------------------------------------------
-  
-  !Global intent in
-  REAL,INTENT(IN) :: t         ! temperature in K 
-  REAL,INTENT(IN) :: satrat    ! saturatio ratio of water (between zero and 1)
-  REAL,INTENT(IN) :: rhoa      ! sulfuric acid concentration in 1/cm3
-  REAL,INTENT(IN) :: csi       ! Ion condensation sink (s-1)
-  REAL,INTENT(IN) :: airn      ! Air molecule concentration in (cm-3)
-  REAL,INTENT(IN) :: ipr       ! Ion pair production rate (cm-3 s-1)
-  !Global intent out
-  REAL,INTENT(OUT) :: jnuc_n_real   ! Neutral nucleation rate in 1/cm3s (J>10^-7 1/cm3s)
-  REAL,INTENT(OUT) :: ntot_n_real   ! total number of molecules in the neutral critical cluster
-  REAL,INTENT(OUT) :: jnuc_i_real   ! Charged nucleation rate in 1/cm3s (J>10^-7 1/cm3s)
-  REAL,INTENT(OUT) :: ntot_i_real   ! total number of molecules in the charged critical cluster
-  REAL,INTENT(OUT) :: x_n_real      ! mole fraction of H2SO4 in the neutral critical cluster 
-  REAL,INTENT(OUT) :: x_i_real      ! mole fraction of H2SO4 in the charged critical cluster 
-                                           ! (note that x_n=x_i in nucleation regime) 
-  REAL,INTENT(OUT) :: na_n_real     ! sulfuric acid molecules in the neutral critical cluster
-  REAL,INTENT(OUT) :: na_i_real     ! sulfuric molecules in the charged critical cluster
-  REAL,INTENT(OUT) :: rc_n_real     ! radius of the charged critical cluster in nm 
-  REAL,INTENT(OUT) :: rc_i_real     ! radius of the charged critical cluster in nm 
-  REAL,INTENT(OUT) :: n_i_real      ! number of ion pairs in air (cm-3) 
-  LOGICAL,INTENT(OUT)  :: kinetic_n        ! true if kinetic neutral nucleation
-  LOGICAL,INTENT(OUT)  :: kinetic_i        ! true if kinetic ion-induced nucleation
-
-  ! Local
-  DOUBLE PRECISION :: jnuc_n      ! Neutral nucleation rate in 1/cm3s (J>10^-7 1/cm3s)
-  DOUBLE PRECISION :: ntot_n      ! total number of molecules in the neutral critical cluster
-  DOUBLE PRECISION :: jnuc_i      ! Charged nucleation rate in 1/cm3s (J>10^-7 1/cm3s)
-  DOUBLE PRECISION :: ntot_i      ! total number of molecules in the charged critical cluster
-  DOUBLE PRECISION :: x_n         ! mole fraction of H2SO4 in the neutral critical cluster 
-  DOUBLE PRECISION :: x_i         ! mole fraction of H2SO4 in the charged critical cluster 
-                                              ! (note that x_n=x_i in nucleation regime) 
-  DOUBLE PRECISION :: na_n        ! sulfuric acid molecules in the neutral critical cluster
-  DOUBLE PRECISION :: na_i        ! sulfuric molecules in the charged critical cluster
-  DOUBLE PRECISION :: rc_n        ! radius of the charged critical cluster in nm 
-  DOUBLE PRECISION :: rc_i        ! radius of the charged critical cluster in nm 
-  DOUBLE PRECISION :: n_i         ! number of ion pairs in air (cm-3) 
-  DOUBLE PRECISION :: x           ! mole fraction of H2SO4 in the critical cluster 
-  DOUBLE PRECISION :: satratln    ! bounded water saturation ratio for neutral case (between 5.E-6 - 1.0)
-  DOUBLE PRECISION :: satratli    ! bounded water saturation ratio for ion-induced case (between 1.E-7 - 0.95)
-  DOUBLE PRECISION :: rhoaln      ! bounded concentration of h2so4 for neutral case (between 10^10 - 10^19 m-3)
-  DOUBLE PRECISION :: rhoali      ! bounded concentration of h2so4 for ion-induced case (between 10^10 - 10^22 m-3)
-  DOUBLE PRECISION :: tln         ! bounded temperature for neutral case (between 165-400 K)
-  DOUBLE PRECISION :: tli         ! bounded temperature for ion-induced case (195-400 K)
-  DOUBLE PRECISION :: kinrhotresn ! threshold sulfuric acid for neutral kinetic nucleation   
-  DOUBLE PRECISION :: kinrhotresi ! threshold sulfuric acid for ion-induced kinetic nucleation 
-  DOUBLE PRECISION :: jnuc_i1     ! Ion-induced rate for n_i=1 cm-3 
-  DOUBLE PRECISION :: xloss       ! Ion loss rate 
-  DOUBLE PRECISION :: recomb      ! Ion-ion recombination rate 
-
-  include "YOMCST.h"
-
-  !--- 0) Initializations:
-
-  kinetic_n=.FALSE.
-  kinetic_i=.FALSE.
-  jnuc_n=0.0
-  jnuc_i=0.0
-  ntot_n=0.0
-  ntot_i=0.0
-  na_n=0.0
-  na_i=0.0
-  rc_n=0.0
-  rc_i=0.0
-  x=0.0
-  x_n=0.0
-  x_i=0.0
-  satratln=satrat
-  satratli=satrat
-  rhoaln=rhoa
-  rhoali=rhoa
-  tln=t
-  tli=t
-  n_i=0.0
-
-  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-  !Boundary values according to parameterization limits   
-
-  !Temperature bounds
-  IF (t.LE.165.) THEN
-     tln=165.0
-  ENDIF
-  IF (t.LE.195.) THEN
-     tli=195.0
-  ENDIF
-  IF (t.GE.400.) THEN
-     tln=400.
-     tli=400.
-  ENDIF
-  
-  ! Saturation ratio bounds
-  IF (satrat.LT.1.E-7) THEN
-     satratli=1.E-7
-  ENDIF
-  IF (satrat.LT.1.E-5) THEN
-     satratln=1.E-5
-  ENDIF
-  IF (satrat.GT.0.95) THEN
-     satratli=0.95
-  ENDIF
-  IF (satrat.GT.1.0) THEN
-     satratln=1.0
-  ENDIF
-  
-  ! Sulfuric acid concentration bounds
-  IF (rhoa.LE.1.E4) THEN
-     rhoaln=1.E4
-     rhoali=1.E4
-  ENDIF
-  IF (rhoa.GT.1.E13) THEN
-     rhoaln=1.E13
-  ENDIF
-  IF (rhoa.GT.1.E16) THEN
-     rhoali=1.E16
-  ENDIF
-  
-  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-  
-  !Critical cluster composition (valid for both cases, bounds not used here) 
-  x_n=  7.9036365428891719E-1 - 2.8414059650092153E-3*tln + 1.4976802556584141E-2*LOG(satratln)  &
-       & - 2.4511581740839115E-4*tln*LOG(satratln) + 3.4319869471066424E-3 *LOG(satratln)**2     &
-       & - 2.8799393617748428E-5*tln*LOG(satratln)**2 + 3.0174314126331765E-4*LOG(satratln)**3   &
-       & - 2.2673492408841294E-6*tln*LOG(satratln)**3 - 4.3948464567032377E-3*LOG(rhoaln)        &
-       & + 5.3305314722492146E-5*tln*LOG(rhoaln)
-  x_i=  7.9036365428891719E-1 - 2.8414059650092153E-3*tli + 1.4976802556584141E-2*LOG(satratli)  &
-       & - 2.4511581740839115E-4*tli*LOG(satratli) + 3.4319869471066424E-3 *LOG(satratli)**2     &
-       & - 2.8799393617748428E-5*tli*LOG(satratli)**2 + 3.0174314126331765E-4*LOG(satratli)**3   &
-       & - 2.2673492408841294E-6*tli*LOG(satratli)**3 - 4.3948464567032377E-3*LOG(rhoali)        &
-       & + 5.3305314722492146E-5*tli*LOG(rhoali)
-       
-  x_n=MIN(MAX(x_n,1.E-30),1.) 
-  x_i=MIN(MAX(x_i,1.E-30),1.) 
-  
-  !Neutral nucleation
-  
-  !Kinetic limit check
-  IF (satratln .GE. 1.E-2 .AND. satratln .LE. 1.) THEN
-     kinrhotresn=EXP(7.8920778706888086E+1 + 7.3665492897447082*satratln - 1.2420166571163805E+4/tln &
-          & + (-6.1831234251470971E+2*satratln)/tln - 2.4501159970109945E-2*tln                      &
-          & -1.3463066443605762E-2*satratln*tln + 8.3736373989909194E-06*tln**2                      &
-          & -1.4673887785408892*LOG(satratln) + (-3.2141890006517094E+1*LOG(satratln))/tln           &
-          & + 2.7137429081917556E-3*tln*LOG(satratln)) !1/cm3     
-     IF (kinrhotresn.LT.rhoaln) kinetic_n=.TRUE.
-  ENDIF
-
-  IF (satratln .GE. 1.E-4  .AND. satratln .LT. 1.E-2) THEN     
-     kinrhotresn=EXP(7.9074383049843647E+1 - 2.8746005462158347E+1*satratln - 1.2070272068458380E+4/tln &
-          & + (-5.9205040320056632E+3*satratln)/tln - 2.4800372593452726E-2*tln                         &
-          & -4.3983007681295948E-2*satratln*tln + 2.5943854791342071E-5*tln**2                          &
-          & -2.3141363245211317*LOG(satratln) + (9.9186787997857735E+1*LOG(satratln))/tln               &
-          & + 5.6819382556144681E-3*tln*LOG(satratln)) !1/cm3
-     IF (kinrhotresn.LT.rhoaln) kinetic_n=.TRUE.
-  ENDIF
-
-  IF (satratln .GE. 5.E-6  .AND. satratln .LT. 1.E-4) THEN
-     kinrhotresn=EXP(8.5599712000361677E+1 + 2.7335119660796581E+3*satratln - 1.1842350246291651E+4/tln &
-          & + (-1.2439843468881438E+6*satratln)/tln - 5.4536964974944230E-2*tln                         &
-          & + 5.0886987425326087*satratln*tln + 7.1964722655507067E-5*tln**2                            &
-          & -2.4472627526306372*LOG(satratln) + (1.7561478001423779E+2*LOG(satratln))/tln               &
-          & + 6.2640132818141811E-3*tln*LOG(satratln)) !1/cm3
-     IF (kinrhotresn.LT.rhoaln) kinetic_n=.TRUE. 
-  ENDIF
-  
-  IF (kinetic_n) THEN    
-     ! Dimer formation rate
-     jnuc_n=1.E6*(2.*0.3E-9)**2.*SQRT(8.*RPI*RKBOL*(1./mH2SO4mol+1./mH2SO4mol))/2.*SQRT(t)*rhoa**2.
-     ntot_n=1. !set to 1 
-     na_n=1.   ! The critical cluster contains one molecules but the produced cluster contains 2 molecules
-     x_n=na_n/ntot_n  ! so also set this to 1
-     rc_n=0.3E-9
-  ELSE
-     jnuc_n= 2.1361182605986115E-1 + 3.3827029855551838*tln -3.2423555796175563E-2*tln**2 +        &
-          &  7.0120069477221989E-5*tln**3 +8.0286874752695141/x_n +                                &
-          &  (-2.6939840579762231E-1)*LOG(satratln) +1.6079879299099518*tln*LOG(satratln) +        &
-          &  (-1.9667486968141933E-2)*tln**2*LOG(satratln) +                                       &
-          &  5.5244755979770844E-5*tln**3*LOG(satratln) + (7.8884704837892468*LOG(satratln))/x_n + &
-          &  4.6374659198909596*LOG(satratln)**2 - 8.2002809894792153E-2*tln*LOG(satratln)**2 +    &
-          &  8.5077424451172196E-4*tln**2*LOG(satratln)**2 +                                       &
-          &  (-2.6518510168987462E-6)*tln**3*LOG(satratln)**2 +                                    &
-          &  (-1.4625482500575278*LOG(satratln)**2)/x_n - 5.2413002989192037E-1*LOG(satratln)**3 + &
-          &  5.2755117653715865E-3*tln*LOG(satratln)**3 +                                          &
-          &  (-2.9491061332113830E-6)*tln**2*LOG(satratln)**3 +                                    &
-          &  (-2.4815454194486752E-8)*tln**3*LOG(satratln)**3 +                                    &
-          &  (-5.2663760117394626E-2*LOG(satratln)**3)/x_n +                                       &
-          &  1.6496664658266762*LOG(rhoaln) +                                                      &
-          &  (-8.0809397859218401E-1)*tln*LOG(rhoaln) +                                            &
-          &  8.9302927091946642E-3*tln**2*LOG(rhoaln) +                                            &
-          &  (-1.9583649496497497E-5)*tln**3*LOG(rhoaln) +                                         &
-          &  (-8.9505572676891685*LOG(rhoaln))/x_n +                                               &
-          &  (-3.0025283601622881E+1)*LOG(satratln)*LOG(rhoaln) +                                  &
-          &  3.0783365644763633E-1*tln*LOG(satratln)*LOG(rhoaln) +                                 &
-          &  (-7.4521756337984706E-4)*tln**2*LOG(satratln)*LOG(rhoaln) +                           &
-          &  (-5.7651433870681853E-7)*tln**3*LOG(satratln)*LOG(rhoaln) +                           &
-          &  (1.2872868529673207*LOG(satratln)*LOG(rhoaln))/x_n +                                  &
-          &  (-6.1739867501526535E-1)*LOG(satratln)**2*LOG(rhoaln) +                               &
-          &  7.2347385705333975E-3*tln*LOG(satratln)**2*LOG(rhoaln) +                              &
-          &  (-3.0640494530822439E-5)*tln**2*LOG(satratln)**2*LOG(rhoaln) +                        &
-          &  6.5944609194346214E-8*tln**3*LOG(satratln)**2*LOG(rhoaln) +                           &
-          &  (-2.8681650332461055E-2*LOG(satratln)**2*LOG(rhoaln))/x_n +                           &
-          &  6.5213802375160306*LOG(rhoaln)**2 +                                                   &
-          &  (-4.7907162004793016E-2)*tln*LOG(rhoaln)**2 +                                         &
-          &  (-1.0727890114215117E-4)*tln**2*LOG(rhoaln)**2 +                                      &
-          &  5.6401818280534507E-7*tln**3*LOG(rhoaln)**2 +                                         &
-          &  (5.4113070888923009E-1*LOG(rhoaln)**2)/x_n +                                          &
-          &  5.2062808476476330E-1*LOG(satratln)*LOG(rhoaln)**2 +                                  &
-          &  (-6.0696882500824584E-3)*tln*LOG(satratln)*LOG(rhoaln)**2 +                           &
-          &  2.3851383302608477E-5*tln**2*LOG(satratln)*LOG(rhoaln)**2 +                           &
-          &  (-1.5243837103067096E-8)*tln**3*LOG(satratln)*LOG(rhoaln)**2 +                        &
-          &  (-5.6543192378015687E-2*LOG(satratln)*LOG(rhoaln)**2)/x_n +                           &
-          &  (-1.1630806410696815E-1)*LOG(rhoaln)**3 +                                             &
-          &  1.3806404273119610E-3*tln*LOG(rhoaln)**3 +                                            &
-          &  (-2.0199865087650833E-6)*tln**2*LOG(rhoaln)**3 +                                      &
-          &  (-3.0200284885763192E-9)*tln**3*LOG(rhoaln)**3 +                                      &
-          &  (-6.9425267104126316E-3*LOG(rhoaln)**3)/x_n
-     jnuc_n=EXP(jnuc_n) 
-     
-     ntot_n =-3.5863435141979573E-3 - 1.0098670235841110E-1*tln + 8.9741268319259721E-4*tln**2 - 1.4855098605195757E-6*tln**3  &
-          &   - 1.2080330016937095E-1/x_n + 1.1902674923928015E-3*LOG(satratln) - 1.9211358507172177E-2*tln*LOG(satratln) +    &
-          &   2.4648094311204255E-4*tln**2*LOG(satratln) - 7.5641448594711666E-7*tln**3*LOG(satratln) +                        &
-          &   (-2.0668639384228818E-02*LOG(satratln))/x_n - 3.7593072011595188E-2*LOG(satratln)**2 +                           &
-          &   9.0993182774415718E-4 *tln*LOG(satratln)**2 +                                                                    &
-          &   (-9.5698412164297149E-6)*tln**2*LOG(satratln)**2 + 3.7163166416110421E-8*tln**3*LOG(satratln)**2 +               &
-          &   (1.1026579525210847E-2*LOG(satratln)**2)/x_n + 1.1530844115561925E-2 *LOG(satratln)**3 +                         &
-          &   (-1.8083253906466668E-4)*tln*LOG(satratln)**3 + 8.0213604053330654E-7*tln**2*LOG(satratln)**3 +                  &
-          &   (-8.5797885383051337E-10)*tln**3*LOG(satratln)**3 + (1.0243693899717402E-3*LOG(satratln)**3)/x_n +               &
-          &   (-1.7248695296299649E-2)*LOG(rhoaln) + 1.1294004162437157E-2*tln*LOG(rhoaln) +                                   &
-          &   (-1.2283640163189278E-4)*tln**2*LOG(rhoaln) + 2.7391732258259009E-7*tln**3*LOG(rhoaln) +                         &
-          &   (6.8505583974029602E-2*LOG(rhoaln))/x_n +2.9750968179523635E-1*LOG(satratln)*LOG(rhoaln) +                       &
-          &   (-3.6681154503992296E-3)*tln*LOG(satratln)*LOG(rhoaln) + 1.0636473034653114E-5*tln**2*LOG(satratln)*LOG(rhoaln)+ &
-          &   5.8687098466515866E-9*tln**3*LOG(satratln)*LOG(rhoaln) + (-5.2028866094191509E-3*LOG(satratln)*LOG(rhoaln))/x_n+ &
-          &   7.6971988880587231E-4*LOG(satratln)**2*LOG(rhoaln) - 2.4605575820433763E-5*tln*LOG(satratln)**2*LOG(rhoaln) +    &
-          &   2.3818484400893008E-7*tln**2*LOG(satratln)**2*LOG(rhoaln) +                                                      &
-          &   (-8.8474102392445200E-10)*tln**3*LOG(satratln)**2*LOG(rhoaln) +                                                  &
-          &   (-1.6640566678168968E-4*LOG(satratln)**2*LOG(rhoaln))/x_n - 7.7390093776705471E-2*LOG(rhoaln)**2 +               &
-          &   5.8220163188828482E-4*tln*LOG(rhoaln)**2 + 1.2291679321523287E-6*tln**2*LOG(rhoaln)**2 +                         &
-          &   (-7.4690997508075749E-9)*tln**3*LOG(rhoaln)**2 + (-5.6357941220497648E-3*LOG(rhoaln)**2)/x_n +                   &
-          &   (-4.7170109625089768E-3)*LOG(satratln)*LOG(rhoaln)**2 + 6.9828868534370193E-5*tln*LOG(satratln)*LOG(rhoaln)**2 + &
-          &   (-3.1738912157036403E-7)*tln**2*LOG(satratln)*LOG(rhoaln)**2 +                                                   &
-          &   2.3975538706787416E-10*tln**3*LOG(satratln)*LOG(rhoaln)**2 +                                                     &
-          &   (4.2304213386288567E-4*LOG(satratln)*LOG(rhoaln)**2)/x_n + 1.3696520973423231E-3*LOG(rhoaln)**3 +                &
-          &   (-1.6863387574788199E-5)*tln*LOG(rhoaln)**3 + 2.7959499278844516E-8*tln**2*LOG(rhoaln)**3 +                      &
-          &   3.9423927013227455E-11*tln**3*LOG(rhoaln)**3 + (8.6136359966337272E-5*LOG(rhoaln)**3)/x_n
-     ntot_n=EXP(ntot_n)
-     
-     rc_n=EXP(-22.378268374023630+0.44462953606125100*x_n+0.33499495707849131*LOG(ntot_n)) !in meters
-     
-     na_n=x_n*ntot_n
-     IF (na_n .LT. 1.) THEN
-        na_n=1.0
-     ENDIF
-  ENDIF
-  
-  ! Set the neutral nucleation rate to 0.0 if less than 1.0E-7      
-  IF (jnuc_n.LT.1.E-7) THEN
-     jnuc_n=0.0
-  ENDIF
-  
-  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-  
-  ! Ion-induced nucleation parameterization 
- 
-  IF (ipr.GT.0.0) THEN ! if the ion production rate is above zero
-     
-     ! Calculate the ion induced nucleation rate wrt. concentration of 1 ion/cm3
-     
-     kinrhotresi = 5.3742280876674478E1  - 6.6837931590012266E-3 *LOG(satratli)**(-2)                                     &
-          & - 1.0142598385422842E-01 * LOG(satratli)**(-1) - 6.4170597272606873E+00 * LOG(satratli)                       &
-          & - 6.4315798914824518E-01 * LOG(satratli)**2 - 2.4428391714772721E-02 * LOG(satratli)**3                       &
-          & - 3.5356658734539019E-04 * LOG(satratli)**4 + 2.5400015099140506E-05 * tli * LOG(satratli)**(-2)              &
-          & - 2.7928900816637790E-04 * tli * LOG(satratli)**(-1) + 4.4108573484923690E-02 * tli * LOG(satratli)           &
-          & + 6.3943789012475532E-03 * tli * LOG(satratli)**(2) + 2.3164296174966580E-04 * tli * LOG(satratli)**(3)       &
-          & + 3.0372070669934950E-06 * tli * LOG(satratli)**4 + 3.8255873977423475E-06 * tli**2 * LOG(satratli)**(-1)     &
-          & - 1.2344793083561629E-04 * tli**2 * LOG(satratli) - 1.7959048869810192E-05 * tli**2 * LOG(satratli)**(2)      &
-          & - 3.2165622558722767E-07 * tli**2 * LOG(satratli)**3 - 4.7136923780988659E-09 * tli**3 * LOG(satratli)**(-1)  &
-          & + 1.1873317184482216E-07 * tli**3 * LOG(satratli) + 1.5685860354866621E-08 * tli**3 * LOG(satratli)**2        &
-          & - 1.4329645891059557E+04 * tli**(-1) + 1.3842599842575321E-01 * tli                                           &
-          & - 4.1376265912842938E-04 * tli**(2) + 3.9147639775826004E-07 * tli**3
-     
-     kinrhotresi=EXP(kinrhotresi) !1/cm3
-     
-     IF (kinrhotresi.LT.rhoali) kinetic_i=.true.
-     
-     IF (kinetic_i) THEN    
-        jnuc_i1=1.0E6*(0.3E-9 + 0.487E-9)**2.*SQRT(8.*RPI*RKBOL*(1./mH2SO4mol+1./mH2SO4mol))*  &
-             &  SQRT(tli)*rhoali !1/cm3s  
-        ntot_i=1. !set to 1 
-        na_i=1.
-        x_i=na_i/ntot_i  ! so also set this to 1
-        rc_i=0.487E-9
-     ELSE
-        jnuc_i1 = 3.0108954259038608E+01+tli*6.1176722090512577E+01+(tli**2)*8.7240333618891663E-01+(tli**3)*                &
-             & (-4.6191788649375719E-03)+(tli**(-1))*8.3537059107024481E-01 +                                                &
-             & (1.5028549216690628E+01+tli*(-1.9310989753720623E-01)+(tli**2)*8.0155514634860480E-04+(tli**3)*               &
-             & (-1.0832730707799128E-06)+(tli**(-1))*1.7577660457989019)*(LOG(satratli)**(-2)) +                             &
-             & (-2.0487870170216488E-01 + tli * 1.3263949252910405E-03 + (tli**2) *(-8.4195688402450274E-06) +               &
-             & (tli**3)*1.6154895940993287E-08 + (tli**(-1))*3.8734212545203874E+01) * (LOG(satratli)**(-2)*LOG(rhoali)) +   &
-             & (1.4955918863858371 + tli * 9.2290004245522454E+01 + (tli**2) *(-8.9006965195392618E-01) +                    &
-             & (tli**3) * 2.2319123411013099E-03 + (tli**(-1)) * 4.0180079996840852E-03) *                                   &
-             & (LOG(satratli)**(-1) * LOG(rhoali)**(-1)) +                                                                   &
-             & (7.9018031228561085 + tli *(-1.1649433968658949E+01) + (tli**2) * 1.1400827854910951E-01 +                    &
-             & (tli**3) *(-3.1941526492127755E-04) + (tli**(-1)) *(-3.7662115740271446E-01)) * (LOG(satratli)**(-1)) +       &
-             & (1.5725237111225979E+02 + tli *(-1.0051649979836277) + (tli**2) * 1.1866484014507624E-03 +                    &
-             & (tli**3) * 7.3557614998540389E-06 + (tli**(-1)) * 2.6270197023115189) * (LOG(satratli)**(-1) * LOG(rhoali)) + &
-             & (-1.6973840122470968E+01 + tli * 1.1258423691432135E-01 + (tli**2) *(-2.9850139351463793E-04) + (tli**3) *    &
-             & 1.4301286324827064E-07 + (tli**(-1)) * 1.3163389235253725E+01) * (LOG(satratli)**(-1) * LOG(rhoali)**2) +     &
-             & (-1.0399591631839757 + tli * 2.7022055588257691E-03 + (tli**2) *(-2.1507467231330936E-06) + (tli**3) *        &
-             & 3.8059489037584171E-10 + (tli**(-1)) * 1.5000492788553410E+02) * (LOG(satratli)**(-1) * LOG(rhoali)**3) +     &
-             & (1.2250990965305315 + tli * 3.0495946490079444E+01 + (tli**2) * 2.1051563135187106E+01 + (tli**3) *           &
-             & (-8.2200682916580878E-02) + (tli**(-1)) * 2.9965871386685029E-02) * (LOG(rhoali)**(-2)) +                     &
-             & (4.8281605955680433 + tli * 1.7346551710836445E+02 + (tli**2) *(-1.0113602140796010E+01) + (tli**3) *         &
-             & 3.7482518458685089E-02 + (tli**(-1)) *(-1.4449998158558205E-01)) * (LOG(rhoali)**(-1)) +                      &
-             & (2.3399230964451237E+02 + tli *(-2.3099267235261948E+01) + (tli**2) * 8.0122962140916354E-02 +                &
-             & (tli**3) * 6.1542576994557088E-05 + (tli**(-1)) * 5.3718413254843007) * (LOG(rhoali)) +                       &
-             & (1.0299715519499360E+02 + tli *(-6.4663357203364136E-02) + (tli**2) *(-2.0487150565050316E-03) +              &
-             & (tli**3) * 8.7935289055530897E-07 + (tli**(-1)) * 3.6013204601215229E+01) * (LOG(rhoali)**2) +                &
-             & (-3.5452115439584042 + tli * 1.7083445731159330E-02 + (tli**2) *(-1.2552625290862626E-05) + (tli**3) *        &
-             & 1.2968447449182847E-09 + (tli**(-1)) * 1.5748687512056560E+02) * (LOG(rhoali)**3) +                           &
-             & (2.2338490119517975 + tli * 1.0229410216045540E+02 + (tli**2) *(-3.2103611955174052) + (tli**3) *             &
-             & 1.3397152304977591E-02 + (tli**(-1)) *(-2.4155187776460030E-02)) * (LOG(satratli)* LOG(rhoali)**(-2)) +       &
-             & (3.7592282990713963 + tli *(-1.5257988769009816E+02) + (tli**2) * 2.6113805420558802 + (tli**3) *             &
-             & (-9.0380721653694363E-03) + (tli**(-1)) *(-1.3974197138171082E-01)) * (LOG(satratli)* LOG(rhoali)**(-1)) +    &
-             & (1.8293600730573988E+01 + tli * 1.8344728606002992E+01 + (tli**2) *(-4.0063363221106751E-01) + (tli**3)       &
-             & * 1.4842749371258522E-03 + (tli**(-1)) * 1.1848846003282287) * (LOG(satratli)) +                              &
-             & (-1.7634531623032314E+02 + tli * 4.9011762441271278 + (tli**2) *(-1.3195821562746339E-02) + (tli**3) *        &
-             & (-2.8668619526430859E-05) + (tli**(-1)) *(-2.9823396976393551E-01)) * (LOG(satratli)* LOG(rhoali)) +          &
-             & (-3.2944043694275727E+01 + tli * 1.2517571921051887E-01 + (tli**2) * 8.3239769771186714E-05 + (tli**3) *      &
-             & 2.8191859341519507E-07 + (tli**(-1)) *(-2.7352880736682319E+01)) * (LOG(satratli)* LOG(rhoali)**2) +          &
-             & (-1.1451811137553243 + tli * 2.0625997485732494E-03 + (tli**2) *(-3.4225389469233624E-06) + (tli**3) *        &
-             & 4.4437613496984567E-10 + (tli**(-1)) * 1.8666644332606754E+02) * (LOG(satratli)* LOG(rhoali)**3) +            &
-             & (3.2270897099493567E+01 + tli * 7.7898447327513687E-01 + (tli**2) *(-6.5662738484679626E-03) + (tli**3) *     &
-             & 3.7899330796456790E-06 + (tli**(-1)) * 7.1106427501756542E-01) * (LOG(satratli)**2 * LOG(rhoali)**(-1)) +     &
-             & (-2.8901906781697811E+01 + tli *(-1.5356398793054860) + (tli**2) * 1.9267271774384788E-02 + (tli**3) *        &
-             & (-5.3886270475516162E-05) + (tli**(-1)) * 5.0490415975693426E-01) * (LOG(satratli)**2) +                      &
-             & (3.3365683645733924E+01 + tli *(-3.6114561564894537E-01) + (tli**2) * 9.2977354471929262E-04 + (tli**3) *     &
-             & 1.9549769069511355E-07 + (tli**(-1)) *(-8.8865930095112855)) * (LOG(satratli)**2 * LOG(rhoali)) +             &
-             & (2.4592563042806375 + tli *(-8.3227071743101084E-03) + (tli**2) * 8.2563338043447783E-06 + (tli**3) *         &
-             & (-8.4374976698593496E-09) + (tli**(-1)) *(-2.0938173949893473E+02)) * (LOG(satratli)**2 * LOG(rhoali)**2) +   &
-             & (4.4099823444352317E+01 + tli * 2.5915665826835252 + (tli**2) *(-1.6449091819482634E-02) + (tli**3) *         &
-             & 2.6797249816144721E-05 + (tli**(-1)) * 5.5045672663909995E-01)* satratli
-        jnuc_i1=EXP(jnuc_i1)
-        
-        ntot_i = ABS((-4.8324296064013375E+04 + tli * 5.0469120697428906E+02 + (tli**2) *(-1.1528940488496042E+00) +         &
-             & (tli**(-1)) *(-8.6892744676239192E+02) + (tli**(3)) * 4.0030302028120469E-04) +                               &
-             & (-6.7259105232039847E+03 + tli * 1.9197488157452008E+02 + (tli**2) *(-1.3602976930126354E+00) +               &
-             & (tli**(-1)) *(-1.1212637938360332E+02) + (tli**(3)) * 2.8515597265933207E-03) *                               &
-             & LOG(satratli)**(-2) * LOG(rhoali)**(-2) +                                                                     &
-             & (2.6216455217763342E+02 + tli *(-2.3687553252750821E+00) + (tli**2) * 7.4074554767517521E-03 +                &
-             & (tli**(-1)) *(-1.9213956820114927E+03) + (tli**(3)) *(-9.3839114856129453E-06)) * LOG(satratli)**(-2) +       &
-             & (3.9652478944137344E+00 + tli * 1.2469375098256536E-02 + (tli**2) *(-9.9837754694045633E-05) + (tli**(-1)) *  &
-             & (-5.1919499210175138E+02) + (tli**(3)) * 1.6489001324583862E-07) * LOG(satratli)**(-2) * LOG(rhoali) +        &
-             & (2.4975714429096206E+02 + tli * 1.7107594562445172E+02 + (tli**2) *(-7.8988711365135289E-01) + (tli**(-1)) *  &
-             & (-2.2243599782483177E+01) + (tli**(3)) *(-1.6291523004095427E-04)) * LOG(satratli)**(-1) * LOG(rhoali)**(-2) +&
-             & (-8.9270715592533611E+02 + tli * 1.2053538883338946E+02 + (tli**2) *(-1.5490408828541018E+00) + (tli**(-1)) * &
-             & (-1.1243275579419826E+01) + (tli**(3)) * 4.8053105606904655E-03) * LOG(satratli)**(-1) * LOG(rhoali)**(-1) +  &
-             & (7.6426441642091631E+03 + tli *(-7.1785462414656578E+01) + (tli**2) * 2.3851864923199523E-01 + (tli**(-1)) *  &
-             & 8.5591775688708395E+01 + (tli**(3)) *(-3.7000473243342858E-04)) * LOG(satratli)**(-1) +                       &
-             & (-5.1516826398607911E+01 + tli * 9.1385720811460558E-01 + (tli**2) *(-3.5477100262158974E-03) +               &
-             & (tli**(-1)) * 2.7545544507625586E+03 + (tli**(3)) * 5.4708262093640928E-06) * LOG(satratli)**(-1) * LOG(rhoali) + &
-             & (-3.0386767129196176E+02 + tli *(-1.1033438883583569E+04) + (tli**2) * 8.1296859732896067E+01 + (tli**(-1)) * &
-             & 1.2625883141097162E+01 + (tli**(3)) *(-1.2728497822219101E-01)) * LOG(rhoali)**(-2) +                         &
-             & (-3.3763494256461472E+03 + tli * 3.1916579136391006E+03 + (tli**2) *(-2.7234339474441143E+01) + (tli**(-1)) * &
-             & (-2.1897653262707397E+01) + (tli**(3)) * 5.1788505812259071E-02) * LOG(rhoali)**(-1) +                        &
-             & (-1.8817843873687068E+03 + tli * 4.3038072285882070E+00 + (tli**2) * 6.6244087689671860E-03 + (tli**(-1)) *   &
-             & (-2.7133073605696295E+03) + (tli**(3)) *(-1.7951557394285043E-05)) * LOG(rhoali) +                            &
-             & (-1.7668827539244447E+02 + tli * 4.8160932330629913E-01 + (tli**2) *(-6.3133007671100293E-04) + (tli**(-1)) * &
-             & 2.5631774669873157E+04 + (tli**(3)) * 4.1534484127873519E-07) * LOG(rhoali)**(2) +                            &
-             & (-1.6661835889222382E+03 + tli * 1.3708900504682877E+03 + (tli**2) *(-1.7919060052198969E+01) + (tli**(-1)) * &
-             & (-3.5145029804436405E+01) + (tli**(3)) * 5.1047240947371224E-02) * LOG(satratli)* LOG(rhoali)**(-2) +         &
-             & (1.0843549363030939E+04 + tli *(-7.3557073636139577E+01) + (tli**2) * 1.2054625131778862E+00 + (tli**(-1)) *  &
-             & 1.9358737917864391E+02 + (tli**(3)) *(-4.2871620775911338E-03)) * LOG(satratli)* LOG(rhoali)**(-1) +          &
-             & (-2.4269802549752835E+03 + tli * 1.1348265061941714E+01 + (tli**2) *(-5.0430423939495157E-02) + (tli**(-1)) * &
-             & 2.3709874548950634E+03 + (tli**(3)) * 1.4091851828620244E-04) * LOG(satratli) +                               &
-             & (5.2745372575251588E+02 + tli *(-2.6080675912627314E+00) + (tli**2) * 5.6902218056670145E-03 + (tli**(-1)) *  &
-             & (-3.2149319482897838E+04) + (tli**(3)) *(-5.4121996056745853E-06)) * LOG(satratli)* LOG(rhoali) +             &
-             & (-1.6401959518360403E+01 + tli * 2.4322962162439640E-01 + (tli**2) * 1.1744366627725344E-03 + (tli**(-1)) *   &
-             & (-8.2694427518413195E+03) + (tli**(3)) *(-5.0028379203873102E-06))* LOG(satratli)**(2) +                      &
-             & (-2.7556572017167782E+03 + tli * 4.9293344495058264E+01 + (tli**2) *(-2.6503456520676050E-01) + (tli**(-1)) * &
-             & 1.2130698030982167E+03 + (tli**(3)) * 4.3530610668042957E-04)* LOG(satratli)**2 * LOG(rhoali)**(-1) +         &
-             & (-6.3419182228959192E+00 + tli * 4.0636212834605827E-02 + (tli**2) *(-1.0450112687842742E-04) + (tli**(-1)) * &
-             & 3.1035882189759656E+02 + (tli**(3)) * 9.4328418657873500E-08)* LOG(satratli)**(-3) +                          &
-             & (3.0189213304689042E+03 + tli *(-2.3804654203861684E+01) + (tli**2) * 6.8113013411972942E-02 + (tli**(-1)) *  &
-             & 6.3112071081188913E+02 + (tli**(3)) *(-9.4460854261685723E-05))* (satratli) * LOG(rhoali) +                   &
-             & (1.1924791930673702E+04 + tli *(-1.1973824959206000E+02) + (tli**2) * 1.6888713097971020E-01 + (tli**(-1)) *  &
-             & 1.8735938211539585E+02 + (tli**(3)) * 5.0974564680442852E-04)* (satratli) +                                   &
-             & (3.6409071302482083E+01 + tli * 1.7919859306449623E-01 + (tli**2) *(-1.0020116255895206E-03) + (tli**(-1)) *  &
-             & (-8.3521083354432303E+03) + (tli**(3)) * 1.5879900546795635E-06)* satratli * LOG(rhoali)**(2))
-          
-        rc_i = (-3.6318550637865524E-08 + tli * 2.1740704135789128E-09   + (tli**2) *                            &
-             & (-8.5521429066506161E-12) + (tli**3) *(-9.3538647454573390E-15)) +                                &
-             & (2.1366936839394922E-08 + tli *(-2.4087168827395623E-10) + (tli**2) * 8.7969869277074319E-13 +    &
-             & (tli**3) *(-1.0294466881303291E-15))* LOG(satratli)**(-2) * LOG(rhoali)**(-1) +                   &
-             & (-7.7804007761164303E-10 + tli * 1.0327058173517932E-11 + (tli**2) *(-4.2557697639692428E-14) +   &
-             & (tli**3) * 5.4082507061618662E-17)* LOG(satratli)**(-2) +                                         &
-             & (3.2628927397420860E-12 + tli *(-7.6475692919751066E-14) + (tli**2) * 4.1985816845259788E-16 +    &
-             & (tli**3) *(-6.2281395889592719E-19))* LOG(satratli)**(-2) * LOG(rhoali) +                         &
-             & (2.0442205540818555E-09 + tli * 4.0441858911249830E-08 + (tli**2) *(-3.3423487629482825E-10) +    &
-             & (tli**3) * 6.8000404742985678E-13)* LOG(satratli)**(-1) * LOG(rhoali)**(-2) +                     &
-             & (1.8381489183824627E-08 + tli *(-8.9853322951518919E-09) + (tli**2) * 7.5888799566036185E-11 +    &
-             & (tli**3) *(-1.5823457864755549E-13))* LOG(satratli)**(-1) * LOG(rhoali)**(-1) +                   &
-             & (1.1795760639695057E-07 + tli *(-8.1046722896375875E-10) + (tli**2) * 9.1868604369041857E-14 +    &
-             & (tli**3) * 4.7882428237444610E-15)* LOG(satratli)**(-1) +                                         &
-             & (-4.4028846582545952E-09 + tli * 4.6541269232626618E-11 + (tli**2) *(-1.1939929984285194E-13) +   &
-             & (tli**3) * 2.3602037016614437E-17)* LOG(satratli)**(-1) * LOG(rhoali) +                           &
-             & (2.7885056884209128E-11 + tli *(-4.5167129624119121E-13) + (tli**2) * 1.6558404997394422E-15 +    &
-             & (tli**3) *(-1.2037336621218054E-18))* LOG(satratli)**(-1) * LOG(rhoali)**2 +                      &
-             & (-2.3719627171699983E-09 + tli *(-1.5260127909292053E-07) + (tli**2) * 1.7177017944754134E-09 +   &
-             & (tli**3) *(-4.7031737537526395E-12))* LOG(rhoali)**(-2) +                                         &
-             & (-5.6946433724699646E-09 + tli * 8.4629788237081735E-09 + (tli**2) *(-1.7674135187061521E-10) +   &
-             & (tli**3) * 6.6236547903091862E-13)* LOG(rhoali)**(-1) +                                           &
-             & (-2.2808617930606012E-08 + tli * 1.4773376696847775E-10 + (tli**2) *(-1.3076953119957355E-13) +   &
-             & (tli**3) * 2.3625301497914000E-16)* LOG(rhoali) +                                                 &
-             & (1.4014269939947841E-10 + tli *(-2.3675117757377632E-12) + (tli**2) * 5.1514033966707879E-15 +    &
-             & (tli**3) *(-4.8864233454747856E-18))* LOG(rhoali)**2 +                                            &
-             & (6.5464943868885886E-11 + tli * 1.6494354816942769E-08 + (tli**2) *(-1.7480097393483653E-10) +    &
-             & (tli**3) * 4.7460075628523984E-13)* LOG(satratli)* LOG(rhoali)**(-2) +                            &
-             & (8.4737893183927871E-09 + tli *(-6.0243327445597118E-09) + (tli**2) * 5.8766070529814883E-11 +    &
-             & (tli**3) *(-1.4926748560042018E-13))* LOG(satratli)* LOG(rhoali)**(-1) +                          &
-             & (1.0761964135701397E-07 + tli *(-1.0142496009071148E-09) + (tli**2) * 2.1337312466519190E-12 +    &
-             & (tli**3) * 1.6376014957685404E-15)* LOG(satratli) +                                               &
-             & (-3.5621571395968670E-09 + tli * 4.1175339587760905E-11 + (tli**2) *(-1.3535372357998504E-13) +   &
-             & (tli**3) * 8.9334219536920720E-17)* LOG(satratli)* LOG(rhoali) +                                  &
-             & (2.0700482083136289E-11 + tli *(-3.9238944562717421E-13) + (tli**2) * 1.5850961422040196E-15 +    &
-             & (tli**3) *(-1.5336775610911665E-18))* LOG(satratli)* LOG(rhoali)**2 +                             &
-             & (1.8524255464416206E-09 + tli *(-2.1959816152743264E-11) + (tli**2) *(-6.4478119501677012E-14) +  &
-             & (tli**3) * 5.5135243833766056E-16)* LOG(satratli)**2 * LOG(rhoali)**(-1) +                        &
-             & (1.9349488650922679E-09 + tli *(-2.2647295919976428E-11) + (tli**2) * 9.2917479748268751E-14 +    &
-             & (tli**3) *(-1.2741959892173170E-16))* LOG(satratli)**2 +                                          &
-             & (2.1484978031650972E-11 + tli *(-9.3976642475838013E-14) + (tli**2) *(-4.8892738002751923E-16) +  &
-             & (tli**3) * 1.4676120441783832E-18)* LOG(satratli)**2 * LOG(rhoali) +                              &
-             & (6.7565715216420310E-13 + tli *(-3.5421162549480807E-15) + (tli**2) *(-3.4201196868693569E-18) +  &
-             & (tli**3) * 2.2260187650412392E-20)* LOG(satratli)**3 * LOG(rhoali)
-                    
-        na_i=x_i*ntot_i
-        IF (na_i .LT. 1.) THEN
-           na_n=1.0
-        ENDIF
-     ENDIF
-    
-     jnuc_i=jnuc_i1 
-     ! Ion loss rate (1/s)
-     xloss=csi+jnuc_i
-     
-     ! Recombination (here following Brasseur and Chatel, 1983)   
-     recomb=6.0E-8*SQRT(300./tli)+6.0E-26*airn*(300./tli)**4
-     
-     ! Small ion concentration in air (1/cm3) (following Dunne et al., 2016)
-     ! max function is to avoid n_i to go practically zero at very high J_ion 
-     n_i=MAX(0.01,(SQRT(xloss**2.0+4.0*recomb*ipr)-xloss)/(2.0*recomb))
-     
-     ! Ion-induced nucleation rate
-     ! Min function is to ensure that max function above does not cause J_ion to overshoot 
-     jnuc_i=MIN(ipr,n_i*jnuc_i1)
-     ! Set the ion-induced nucleation rate to 0.0 if less than 1.0E-7      
-     IF (jnuc_i.LT.1.E-7) THEN
-        jnuc_i=0.0
-     ENDIF
-
-  ENDIF
-
-!--conversion from double precision to float in case the model is run in single precision
-  jnuc_n_real   = jnuc_n
-  ntot_n_real   = ntot_n
-  jnuc_i_real   = jnuc_i
-  ntot_i_real   = ntot_i
-  x_n_real      = x_n
-  x_i_real      = x_i
-  na_n_real     = na_n
-  na_i_real     = na_i
-  rc_n_real     = rc_n
-  rc_i_real     = rc_i
-  n_i_real      = n_i
-  
-END SUBROUTINE newbinapara
-
-END MODULE nucleation_tstep_mod
Index: /LMDZ6/trunk/libf/phylmd/StratAer/nucleation_tstep_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/StratAer/nucleation_tstep_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/StratAer/nucleation_tstep_mod.f90	(revision 5268)
@@ -0,0 +1,813 @@
+!
+! $Id$
+!
+MODULE nucleation_tstep_mod
+
+CONTAINS
+
+SUBROUTINE nucleation_rate(rhoa,t_seri,pplay,rh,a_xm,b_xm,c_xm,nucl_rate,ntot_n,x_n)
+
+  USE aerophys
+  USE infotrac_phy
+  USE strataer_local_var_mod, ONLY : flag_new_nucl
+  
+  IMPLICIT NONE
+
+  ! input variables
+  REAL rhoa    ! H2SO4 number density [molecules/cm3]
+  REAL t_seri  ! temperature (K)
+  REAL pplay   ! pressure (Pa)
+  REAL rh      ! relative humidity (between 0 and 1)
+  REAL a_xm, b_xm, c_xm
+
+  ! output variables
+  REAL nucl_rate
+  REAL ntot_n ! total number of molecules in the critical cluster for neutral nucleation
+  REAL x_n    ! mole fraction of H2SO4 in the critical cluster for neutral nucleation
+
+  ! local variables
+  REAL jnuc_n ! nucleation rate in 1/cm3s (10^-7-10^10 1/cm3s) for neutral nucleation
+  REAL rc_n   ! radius of the critical cluster in nm for neutral nucleation
+  REAL na_n   ! sulfuric acid molecules in the neutral critical cluster (NOT IN USE)
+  LOGICAL kinetic_n ! true if kinetic neutral nucleation (NOT IN USE)
+  LOGICAL kinetic_i ! true if kinetic ion-induced nucleation (NOT IN USE)
+  REAL VH2SO4mol
+  REAL ntot_i, x_i, jnuc_i, rc_i, na_i, n_i ! quantities for charged nucleation (NOT IN USE)
+  REAL csi     ! Ion condensation sink (s-1) NOT IN USE
+  REAL airn    ! Air molecule concentration in (cm-3) NOT IN USE
+  REAL ipr     ! Ion pair production rate (cm-3 s-1) NOT IN USE
+
+  include "YOMCST.h"
+
+  ! call nucleation routine
+  IF (.NOT.flag_new_nucl) THEN
+    ! Use older routine from Hanna Vehkamäki (FMI)
+    CALL binapara(t_seri,rh,rhoa,jnuc_n,x_n,ntot_n,rc_n)
+    ! when total number of molecules is too small 
+    ! then set jnuc_n to collision rate of two H2SO4 molecules (following personal communication of Ulrike Niemeier and Hanna Vehkamäki)
+    IF (ntot_n < 4.0) THEN
+      VH2SO4mol=mH2SO4mol/(1.E-3*(a_xm+t_seri*(b_xm+t_seri*c_xm))) !cm3
+      jnuc_n = rhoa**2. *(3./4.*RPI)**(1./6.) *(12.*RKBOL*t_seri/mH2SO4mol)**0.5 &
+           & *100.*(2.*VH2SO4mol**(1./3.))**2. !1/(cm3s)
+      ntot_n=2.0
+      x_n=1.0
+    ENDIF
+  ELSE
+    ! Use new routine from Anni Maattanen (LATMOS)
+    csi=0.0   ! no charged nucleation for now
+    ipr=-1.0  ! dummy value to make sure charged nucleation does not occur
+    airn=0.0  ! NOT IN USE
+!   airn=pplay/t_seri/RD/1.E3*RNAVO/RMD ! molec cm-3 (for future use, to be confirmed)
+    CALL newbinapara(t_seri,rh,rhoa,csi,airn,ipr,jnuc_n,ntot_n,jnuc_i,ntot_i, &
+                   & x_n,x_i,na_n,na_i,rc_n,rc_i,n_i,kinetic_n,kinetic_i)
+  ENDIF
+
+  ! convert jnuc_n from particles/cm3/s to kg(H2SO4)/kgA/s
+  nucl_rate=jnuc_n*ntot_n*x_n*mH2SO4mol/(pplay/t_seri/RD/1.E6)
+
+END SUBROUTINE nucleation_rate
+
+!--------------------------------------------------------------------------------------------------
+
+SUBROUTINE nucleation_part(nucl_rate,ntot,x,dt,tr_seri)
+
+  USE aerophys
+  USE infotrac_phy
+  USE strataer_local_var_mod, ONLY : Vbin
+  
+  IMPLICIT NONE
+
+  ! input variable
+  REAL nucl_rate
+  REAL ntot ! total number of molecules in the critical cluster
+  REAL x    ! mole raction of H2SO4 in the critical cluster
+  REAL dt
+  
+  ! output variable
+  REAL tr_seri(nbtr)
+
+  ! local variable
+  INTEGER k
+  REAL Vnew
+  REAL ff(nbtr_bin)
+
+  ! dry volume of nucleated particle (at reference temperature)
+  !  dens_aer_dry (density of dry aerosol []kg/m3)
+  !  H2SO4mol: mass of an H2SO4 molecule [kg]
+  !  Vnew [m3]
+  Vnew=mH2SO4mol*ntot*x/dens_aer_dry
+
+  ! compute distribution factor for particles of intermediate size (from Jacobson 1994, equation 13)
+  ff(:)=0.0 
+  DO k=1, nbtr_bin 
+  ! CK 20160531: bug fix for first bin
+    IF (k.LE.nbtr_bin-1) THEN 
+      IF (Vbin(k).LE.Vnew.AND.Vnew.LT.Vbin(k+1)) THEN
+        ff(k)= Vbin(k)/Vnew*(Vbin(k+1)-Vnew)/(Vbin(k+1)-Vbin(k))
+      ENDIF
+    ENDIF
+    IF (k.EQ.1.AND.Vnew.LE.Vbin(k)) THEN
+      ff(k)= 1.
+    ENDIF
+    IF (k.GT.1) THEN 
+      IF (Vbin(k-1).LT.Vnew.AND.Vnew.LT.Vbin(k)) THEN
+        ff(k)= 1.-ff(k-1)
+      ENDIF
+    ENDIF
+    IF (k.EQ.nbtr_bin.AND.Vnew.GE.Vbin(k)) THEN
+      ff(k)= 1.
+    ENDIF
+  ENDDO
+  ! correction of ff for volume conservation
+  DO k=1, nbtr_bin         
+    ff(k)=ff(k)*Vnew/Vbin(k)
+  ENDDO
+
+  ! add nucleated H2SO4 to corresponding aerosol bin
+  DO k=1, nbtr_bin
+    tr_seri(k+nbtr_sulgas)=tr_seri(k+nbtr_sulgas)+nucl_rate*dt/(mH2SO4mol*ntot*x)*ff(k)
+  ENDDO
+
+END SUBROUTINE nucleation_part
+
+!---------------------------------------------------------------------------------------------------
+
+SUBROUTINE binapara(pt,prh,rhoa_in,jnuc,x,ntot,rc)
+
+
+  !    Fortran 90 subroutine binapara
+  !
+  !    Calculates parametrized values of nucleation rate,
+  !    mole fraction of sulphuric acid
+  !    total number of particles, and the radius of the critical cluster
+  !    in H2O-H2SO4 system IF temperature, saturatio ratio of water and 
+  !    sulfuric acid concentration  are given. 
+  !
+  !    Copyright (C) 2002 Hanna Vehkamäki
+  !
+  !    Division of Atmospheric Sciences
+  !    Department of Physical Sciences
+  !    P.O. Box 64
+  !    FIN-00014 University of Helsinki
+  !    Finland
+  !    
+  !    hanna.vehkamaki@helsinki.fi
+
+  IMPLICIT NONE 
+
+  REAL :: pt,t     !temperature in K (190.15-300.15K)
+  REAL :: prh,rh    !saturation ratio of water (0.0001-1)
+  REAL,INTENT(IN) :: rhoa_in    !sulfuric acid concentration in 1/cm3 (10^4-10^11 1/cm3)
+  REAL,INTENT(OUT) :: jnuc    !nucleation rate in 1/cm3s (10^-7-10^10 1/cm3s)
+  REAL,INTENT(OUT) :: ntot !total number of molecules in the critical cluster (ntot>4)
+  REAL,INTENT(OUT) :: x    ! mole fraction of H2SO4 in the critical cluster       
+  REAL,INTENT(OUT) :: rc    !radius of the critical cluster in nm     
+  REAL :: rhotres    ! threshold concentration of h2so4 (1/cm^3)
+                     ! which produces nucleation rate   1/(cm^3 s) as a function of rh and t 
+  REAL rhoa
+
+! CK: use intermediate variable to avoid overwriting
+  t=pt
+  rh=prh
+  rhoa=rhoa_in
+
+  IF (t < 190.15) THEN
+     t=190.15
+  ENDIF
+
+  IF (t > 300.15) THEN
+     t=300.15
+  ENDIF
+
+  IF (rh < 0.0001) THEN
+     rh=0.0001
+  ENDIF
+
+  IF (rh > 1.0) THEN
+     rh=1.0
+  ENDIF
+
+  IF (rhoa < 1.e4) THEN
+     rhoa=1.e4
+  ENDIF
+
+  IF (rhoa > 1.e11) THEN
+     rhoa=1.e11
+  ENDIF
+
+  x=  0.7409967177282139 - 0.002663785665140117*t + 0.002010478847383187*LOG(rh)  &
+       & - 0.0001832894131464668*t*LOG(rh) + 0.001574072538464286*LOG(rh)**2      &
+       & - 0.00001790589121766952*t*LOG(rh)**2 + 0.0001844027436573778*LOG(rh)**3 &
+       & -  1.503452308794887E-6*t*LOG(rh)**3 - 0.003499978417957668*LOG(rhoa)    &
+       & + 0.0000504021689382576*t*LOG(rhoa)
+
+  jnuc= 0.1430901615568665 + 2.219563673425199*t - 0.02739106114964264*t**2 + &
+       &  0.00007228107239317088*t**3 + 5.91822263375044/x +                  &
+       &  0.1174886643003278*LOG(rh) + 0.4625315047693772*t*LOG(rh) -          &
+       &  0.01180591129059253*t**2*LOG(rh) +                                  &
+       &  0.0000404196487152575*t**3*LOG(rh) + (15.79628615047088*LOG(rh))/x - &
+       &  0.215553951893509*LOG(rh)**2 - 0.0810269192332194*t*LOG(rh)**2 +    &
+       &  0.001435808434184642*t**2*LOG(rh)**2 -                               &
+       &  4.775796947178588E-6*t**3*LOG(rh)**2 -                               &
+       &  (2.912974063702185*LOG(rh)**2)/x - 3.588557942822751*LOG(rh)**3 +   &
+       &  0.04950795302831703*t*LOG(rh)**3 -                                   &
+       &  0.0002138195118737068*t**2*LOG(rh)**3 +                             &
+       &  3.108005107949533E-7*t**3*LOG(rh)**3 -                               &
+       &  (0.02933332747098296*LOG(rh)**3)/x +                                &
+       &  1.145983818561277*LOG(rhoa) -                                        &
+       &  0.6007956227856778*t*LOG(rhoa) +                                    &
+       &  0.00864244733283759*t**2*LOG(rhoa) -                                 &
+       &  0.00002289467254710888*t**3*LOG(rhoa) -                              &
+       &  (8.44984513869014*LOG(rhoa))/x +                                    &
+       &  2.158548369286559*LOG(rh)*LOG(rhoa) +                               &
+       &  0.0808121412840917*t*LOG(rh)*LOG(rhoa) -                             &
+       &  0.0004073815255395214*t**2*LOG(rh)*LOG(rhoa) -                       &
+       &  4.019572560156515E-7*t**3*LOG(rh)*LOG(rhoa) +                       &
+       &  (0.7213255852557236*LOG(rh)*LOG(rhoa))/x +                          &
+       &  1.62409850488771*LOG(rh)**2*LOG(rhoa) -                              &
+       &  0.01601062035325362*t*LOG(rh)**2*LOG(rhoa) +                        &
+       &  0.00003771238979714162*t**2*LOG(rh)**2*LOG(rhoa) +                  &
+       &  3.217942606371182E-8*t**3*LOG(rh)**2*LOG(rhoa) -                     &
+       &  (0.01132550810022116*LOG(rh)**2*LOG(rhoa))/x +                      &
+       &  9.71681713056504*LOG(rhoa)**2 -                                      &
+       &  0.1150478558347306*t*LOG(rhoa)**2 +                                 &
+       &  0.0001570982486038294*t**2*LOG(rhoa)**2 +                           &
+       &  4.009144680125015E-7*t**3*LOG(rhoa)**2 +                            &
+       &  (0.7118597859976135*LOG(rhoa)**2)/x -                                &
+       &  1.056105824379897*LOG(rh)*LOG(rhoa)**2 +                            &
+       &  0.00903377584628419*t*LOG(rh)*LOG(rhoa)**2 -                         &
+       &  0.00001984167387090606*t**2*LOG(rh)*LOG(rhoa)**2 +                  &
+       &  2.460478196482179E-8*t**3*LOG(rh)*LOG(rhoa)**2 -                     &
+       &  (0.05790872906645181*LOG(rh)*LOG(rhoa)**2)/x -                       &
+       &  0.1487119673397459*LOG(rhoa)**3 +                                   &
+       &  0.002835082097822667*t*LOG(rhoa)**3 -                                &
+       &  9.24618825471694E-6*t**2*LOG(rhoa)**3 +                             &
+       &  5.004267665960894E-9*t**3*LOG(rhoa)**3 -                             &
+       &  (0.01270805101481648*LOG(rhoa)**3)/x
+  jnuc=EXP(jnuc) !1/(cm3s)
+
+  ntot =-0.002954125078716302 - 0.0976834264241286*t + 0.001024847927067835*t**2 - 2.186459697726116E-6*t**3 -    &
+       &   0.1017165718716887/x - 0.002050640345231486*LOG(rh) - 0.007585041382707174*t*LOG(rh) +                &
+       &   0.0001926539658089536*t**2*LOG(rh) - 6.70429719683894E-7*t**3*LOG(rh) -                                &
+       &   (0.2557744774673163*LOG(rh))/x + 0.003223076552477191*LOG(rh)**2 + 0.000852636632240633*t*LOG(rh)**2 - &
+       &   0.00001547571354871789*t**2*LOG(rh)**2 + 5.666608424980593E-8*t**3*LOG(rh)**2 +                       &
+       &   (0.03384437400744206*LOG(rh)**2)/x + 0.04743226764572505*LOG(rh)**3 -                                  &
+       &   0.0006251042204583412*t*LOG(rh)**3 + 2.650663328519478E-6*t**2*LOG(rh)**3 -                            &
+       &   3.674710848763778E-9*t**3*LOG(rh)**3 - (0.0002672510825259393*LOG(rh)**3)/x -                          &
+       &   0.01252108546759328*LOG(rhoa) + 0.005806550506277202*t*LOG(rhoa) -                                     &
+       &   0.0001016735312443444*t**2*LOG(rhoa) + 2.881946187214505E-7*t**3*LOG(rhoa) +                          &
+       &   (0.0942243379396279*LOG(rhoa))/x - 0.0385459592773097*LOG(rh)*LOG(rhoa) -                              &
+       &   0.0006723156277391984*t*LOG(rh)*LOG(rhoa) + 2.602884877659698E-6*t**2*LOG(rh)*LOG(rhoa) +             &
+       &   1.194163699688297E-8*t**3*LOG(rh)*LOG(rhoa) - (0.00851515345806281*LOG(rh)*LOG(rhoa))/x -              &
+       &   0.01837488495738111*LOG(rh)**2*LOG(rhoa) + 0.0001720723574407498*t*LOG(rh)**2*LOG(rhoa) -              &
+       &   3.717657974086814E-7*t**2*LOG(rh)**2*LOG(rhoa) -                                                       &
+       &   5.148746022615196E-10*t**3*LOG(rh)**2*LOG(rhoa) +                                                     &
+       &   (0.0002686602132926594*LOG(rh)**2*LOG(rhoa))/x - 0.06199739728812199*LOG(rhoa)**2 +                   &
+       &   0.000906958053583576*t*LOG(rhoa)**2 - 9.11727926129757E-7*t**2*LOG(rhoa)**2 -                          &
+       &   5.367963396508457E-9*t**3*LOG(rhoa)**2 - (0.007742343393937707*LOG(rhoa)**2)/x +                      &
+       &   0.0121827103101659*LOG(rh)*LOG(rhoa)**2 - 0.0001066499571188091*t*LOG(rh)*LOG(rhoa)**2 +              &
+       &   2.534598655067518E-7*t**2*LOG(rh)*LOG(rhoa)**2 -                                                       &
+       &   3.635186504599571E-10*t**3*LOG(rh)*LOG(rhoa)**2 +                                                     &
+       &   (0.0006100650851863252*LOG(rh)*LOG(rhoa)**2)/x + 0.0003201836700403512*LOG(rhoa)**3 -                  &
+       &   0.0000174761713262546*t*LOG(rhoa)**3 + 6.065037668052182E-8*t**2*LOG(rhoa)**3 -                        &
+       &   1.421771723004557E-11*t**3*LOG(rhoa)**3 + (0.0001357509859501723*LOG(rhoa)**3)/x
+  ntot=EXP(ntot)
+
+  rc=EXP(-1.6524245+0.42316402*x+0.33466487*LOG(ntot)) !nm
+
+  IF (jnuc < 1.E-7) THEN
+     jnuc=0.0
+  ENDIF
+
+  IF (jnuc > 1.e10) THEN
+     jnuc=1.e10
+  ENDIF
+
+  rhotres=EXP( -279.2430007512709 + 11.73439886096903*rh + 22700.92970508331/t &
+       & - (1088.644983466801*rh)/t + 1.144362942094912*t                      &
+       & - 0.03023314602163684*rh*t - 0.001302541390154324*t**2                &
+       & - 6.386965238433532*LOG(rh) + (854.980361026715*LOG(rh))/t            &
+       & + 0.00879662256826497*t*LOG(rh)) !1/cm3
+
+  RETURN
+
+END SUBROUTINE binapara
+
+!---------------------------------------------------------------------------------------------------
+
+SUBROUTINE newbinapara(t,satrat,rhoa,csi,airn,ipr,jnuc_n_real,ntot_n_real,jnuc_i_real,ntot_i_real,        &
+                   &   x_n_real,x_i_real,na_n_real,na_i_real,rc_n_real,rc_i_real,n_i_real,                & 
+                   &   kinetic_n,kinetic_i)
+
+  !    Fortran 90 subroutine newbinapara
+  !
+  !    Calculates parametrized values for neutral and ion-induced sulfuric acid-water particle formation rate
+  !    of critical clusters, 
+  !    number of particle in the critical clusters, the radii of the critical clusters
+  !    in H2O-H2SO4-ion system if temperature, saturation ratio of water, sulfuric acid concentration, 
+  !    and, optionally, either condensation sink due to pre-existing particle and ion pair production rate,
+  !    or atmospheric concentration of negative ions are given. 
+  !
+  !    The code calculates also the kinetic limit and the particle formation rate
+  !    above this limit (in which case we set ntot=1 and na=1)
+  !
+  !    Copyright (C)2018 Määttänen et al. 2018
+  !    
+  !    anni.maattanen@latmos.ipsl.fr
+  !    joonas.merikanto@fmi.fi
+  !    hanna.vehkamaki@helsinki.fi
+  !
+  !    References
+  !    A. Määttänen, J. Merikanto, H. Henschel, J. Duplissy, R. Makkonen, 
+  !    I. K. Ortega and H. Vehkamäki (2018), New parameterizations for 
+  !    neutral and ion-induced sulfuric acid-water particle formation in 
+  !    nucleation and kinetic regimes, J. Geophys. Res. Atmos., 122, doi:10.1002/2017JD027429.
+  !
+  !    Brasseur, G., and A.  Chatel (1983),  paper  presented  at  the  9th  Annual  Meeting  of  the  
+  !    European Geophysical Society, Leeds, Great Britain, August 1982.
+  !  
+  !    Dunne, Eimear M., et al.(2016), Global atmospheric particle formation from CERN CLOUD measurements,
+  !    Science 354.6316, 1119-1124.   
+  !
+
+  USE aerophys
+
+  IMPLICIT NONE 
+
+  !----------------------------------------------------
+  
+  !Global intent in
+  REAL,INTENT(IN) :: t         ! temperature in K 
+  REAL,INTENT(IN) :: satrat    ! saturatio ratio of water (between zero and 1)
+  REAL,INTENT(IN) :: rhoa      ! sulfuric acid concentration in 1/cm3
+  REAL,INTENT(IN) :: csi       ! Ion condensation sink (s-1)
+  REAL,INTENT(IN) :: airn      ! Air molecule concentration in (cm-3)
+  REAL,INTENT(IN) :: ipr       ! Ion pair production rate (cm-3 s-1)
+  !Global intent out
+  REAL,INTENT(OUT) :: jnuc_n_real   ! Neutral nucleation rate in 1/cm3s (J>10^-7 1/cm3s)
+  REAL,INTENT(OUT) :: ntot_n_real   ! total number of molecules in the neutral critical cluster
+  REAL,INTENT(OUT) :: jnuc_i_real   ! Charged nucleation rate in 1/cm3s (J>10^-7 1/cm3s)
+  REAL,INTENT(OUT) :: ntot_i_real   ! total number of molecules in the charged critical cluster
+  REAL,INTENT(OUT) :: x_n_real      ! mole fraction of H2SO4 in the neutral critical cluster 
+  REAL,INTENT(OUT) :: x_i_real      ! mole fraction of H2SO4 in the charged critical cluster 
+                                           ! (note that x_n=x_i in nucleation regime) 
+  REAL,INTENT(OUT) :: na_n_real     ! sulfuric acid molecules in the neutral critical cluster
+  REAL,INTENT(OUT) :: na_i_real     ! sulfuric molecules in the charged critical cluster
+  REAL,INTENT(OUT) :: rc_n_real     ! radius of the charged critical cluster in nm 
+  REAL,INTENT(OUT) :: rc_i_real     ! radius of the charged critical cluster in nm 
+  REAL,INTENT(OUT) :: n_i_real      ! number of ion pairs in air (cm-3) 
+  LOGICAL,INTENT(OUT)  :: kinetic_n        ! true if kinetic neutral nucleation
+  LOGICAL,INTENT(OUT)  :: kinetic_i        ! true if kinetic ion-induced nucleation
+
+  ! Local
+  DOUBLE PRECISION :: jnuc_n      ! Neutral nucleation rate in 1/cm3s (J>10^-7 1/cm3s)
+  DOUBLE PRECISION :: ntot_n      ! total number of molecules in the neutral critical cluster
+  DOUBLE PRECISION :: jnuc_i      ! Charged nucleation rate in 1/cm3s (J>10^-7 1/cm3s)
+  DOUBLE PRECISION :: ntot_i      ! total number of molecules in the charged critical cluster
+  DOUBLE PRECISION :: x_n         ! mole fraction of H2SO4 in the neutral critical cluster 
+  DOUBLE PRECISION :: x_i         ! mole fraction of H2SO4 in the charged critical cluster 
+                                              ! (note that x_n=x_i in nucleation regime) 
+  DOUBLE PRECISION :: na_n        ! sulfuric acid molecules in the neutral critical cluster
+  DOUBLE PRECISION :: na_i        ! sulfuric molecules in the charged critical cluster
+  DOUBLE PRECISION :: rc_n        ! radius of the charged critical cluster in nm 
+  DOUBLE PRECISION :: rc_i        ! radius of the charged critical cluster in nm 
+  DOUBLE PRECISION :: n_i         ! number of ion pairs in air (cm-3) 
+  DOUBLE PRECISION :: x           ! mole fraction of H2SO4 in the critical cluster 
+  DOUBLE PRECISION :: satratln    ! bounded water saturation ratio for neutral case (between 5.E-6 - 1.0)
+  DOUBLE PRECISION :: satratli    ! bounded water saturation ratio for ion-induced case (between 1.E-7 - 0.95)
+  DOUBLE PRECISION :: rhoaln      ! bounded concentration of h2so4 for neutral case (between 10^10 - 10^19 m-3)
+  DOUBLE PRECISION :: rhoali      ! bounded concentration of h2so4 for ion-induced case (between 10^10 - 10^22 m-3)
+  DOUBLE PRECISION :: tln         ! bounded temperature for neutral case (between 165-400 K)
+  DOUBLE PRECISION :: tli         ! bounded temperature for ion-induced case (195-400 K)
+  DOUBLE PRECISION :: kinrhotresn ! threshold sulfuric acid for neutral kinetic nucleation   
+  DOUBLE PRECISION :: kinrhotresi ! threshold sulfuric acid for ion-induced kinetic nucleation 
+  DOUBLE PRECISION :: jnuc_i1     ! Ion-induced rate for n_i=1 cm-3 
+  DOUBLE PRECISION :: xloss       ! Ion loss rate 
+  DOUBLE PRECISION :: recomb      ! Ion-ion recombination rate 
+
+  include "YOMCST.h"
+
+  !--- 0) Initializations:
+
+  kinetic_n=.FALSE.
+  kinetic_i=.FALSE.
+  jnuc_n=0.0
+  jnuc_i=0.0
+  ntot_n=0.0
+  ntot_i=0.0
+  na_n=0.0
+  na_i=0.0
+  rc_n=0.0
+  rc_i=0.0
+  x=0.0
+  x_n=0.0
+  x_i=0.0
+  satratln=satrat
+  satratli=satrat
+  rhoaln=rhoa
+  rhoali=rhoa
+  tln=t
+  tli=t
+  n_i=0.0
+
+  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+  !Boundary values according to parameterization limits   
+
+  !Temperature bounds
+  IF (t.LE.165.) THEN
+     tln=165.0
+  ENDIF
+  IF (t.LE.195.) THEN
+     tli=195.0
+  ENDIF
+  IF (t.GE.400.) THEN
+     tln=400.
+     tli=400.
+  ENDIF
+  
+  ! Saturation ratio bounds
+  IF (satrat.LT.1.E-7) THEN
+     satratli=1.E-7
+  ENDIF
+  IF (satrat.LT.1.E-5) THEN
+     satratln=1.E-5
+  ENDIF
+  IF (satrat.GT.0.95) THEN
+     satratli=0.95
+  ENDIF
+  IF (satrat.GT.1.0) THEN
+     satratln=1.0
+  ENDIF
+  
+  ! Sulfuric acid concentration bounds
+  IF (rhoa.LE.1.E4) THEN
+     rhoaln=1.E4
+     rhoali=1.E4
+  ENDIF
+  IF (rhoa.GT.1.E13) THEN
+     rhoaln=1.E13
+  ENDIF
+  IF (rhoa.GT.1.E16) THEN
+     rhoali=1.E16
+  ENDIF
+  
+  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+  
+  !Critical cluster composition (valid for both cases, bounds not used here) 
+  x_n=  7.9036365428891719E-1 - 2.8414059650092153E-3*tln + 1.4976802556584141E-2*LOG(satratln)  &
+       & - 2.4511581740839115E-4*tln*LOG(satratln) + 3.4319869471066424E-3 *LOG(satratln)**2     &
+       & - 2.8799393617748428E-5*tln*LOG(satratln)**2 + 3.0174314126331765E-4*LOG(satratln)**3   &
+       & - 2.2673492408841294E-6*tln*LOG(satratln)**3 - 4.3948464567032377E-3*LOG(rhoaln)        &
+       & + 5.3305314722492146E-5*tln*LOG(rhoaln)
+  x_i=  7.9036365428891719E-1 - 2.8414059650092153E-3*tli + 1.4976802556584141E-2*LOG(satratli)  &
+       & - 2.4511581740839115E-4*tli*LOG(satratli) + 3.4319869471066424E-3 *LOG(satratli)**2     &
+       & - 2.8799393617748428E-5*tli*LOG(satratli)**2 + 3.0174314126331765E-4*LOG(satratli)**3   &
+       & - 2.2673492408841294E-6*tli*LOG(satratli)**3 - 4.3948464567032377E-3*LOG(rhoali)        &
+       & + 5.3305314722492146E-5*tli*LOG(rhoali)
+       
+  x_n=MIN(MAX(x_n,1.E-30),1.) 
+  x_i=MIN(MAX(x_i,1.E-30),1.) 
+  
+  !Neutral nucleation
+  
+  !Kinetic limit check
+  IF (satratln .GE. 1.E-2 .AND. satratln .LE. 1.) THEN
+     kinrhotresn=EXP(7.8920778706888086E+1 + 7.3665492897447082*satratln - 1.2420166571163805E+4/tln &
+          & + (-6.1831234251470971E+2*satratln)/tln - 2.4501159970109945E-2*tln                      &
+          & -1.3463066443605762E-2*satratln*tln + 8.3736373989909194E-06*tln**2                      &
+          & -1.4673887785408892*LOG(satratln) + (-3.2141890006517094E+1*LOG(satratln))/tln           &
+          & + 2.7137429081917556E-3*tln*LOG(satratln)) !1/cm3     
+     IF (kinrhotresn.LT.rhoaln) kinetic_n=.TRUE.
+  ENDIF
+
+  IF (satratln .GE. 1.E-4  .AND. satratln .LT. 1.E-2) THEN     
+     kinrhotresn=EXP(7.9074383049843647E+1 - 2.8746005462158347E+1*satratln - 1.2070272068458380E+4/tln &
+          & + (-5.9205040320056632E+3*satratln)/tln - 2.4800372593452726E-2*tln                         &
+          & -4.3983007681295948E-2*satratln*tln + 2.5943854791342071E-5*tln**2                          &
+          & -2.3141363245211317*LOG(satratln) + (9.9186787997857735E+1*LOG(satratln))/tln               &
+          & + 5.6819382556144681E-3*tln*LOG(satratln)) !1/cm3
+     IF (kinrhotresn.LT.rhoaln) kinetic_n=.TRUE.
+  ENDIF
+
+  IF (satratln .GE. 5.E-6  .AND. satratln .LT. 1.E-4) THEN
+     kinrhotresn=EXP(8.5599712000361677E+1 + 2.7335119660796581E+3*satratln - 1.1842350246291651E+4/tln &
+          & + (-1.2439843468881438E+6*satratln)/tln - 5.4536964974944230E-2*tln                         &
+          & + 5.0886987425326087*satratln*tln + 7.1964722655507067E-5*tln**2                            &
+          & -2.4472627526306372*LOG(satratln) + (1.7561478001423779E+2*LOG(satratln))/tln               &
+          & + 6.2640132818141811E-3*tln*LOG(satratln)) !1/cm3
+     IF (kinrhotresn.LT.rhoaln) kinetic_n=.TRUE. 
+  ENDIF
+  
+  IF (kinetic_n) THEN    
+     ! Dimer formation rate
+     jnuc_n=1.E6*(2.*0.3E-9)**2.*SQRT(8.*RPI*RKBOL*(1./mH2SO4mol+1./mH2SO4mol))/2.*SQRT(t)*rhoa**2.
+     ntot_n=1. !set to 1 
+     na_n=1.   ! The critical cluster contains one molecules but the produced cluster contains 2 molecules
+     x_n=na_n/ntot_n  ! so also set this to 1
+     rc_n=0.3E-9
+  ELSE
+     jnuc_n= 2.1361182605986115E-1 + 3.3827029855551838*tln -3.2423555796175563E-2*tln**2 +        &
+          &  7.0120069477221989E-5*tln**3 +8.0286874752695141/x_n +                                &
+          &  (-2.6939840579762231E-1)*LOG(satratln) +1.6079879299099518*tln*LOG(satratln) +        &
+          &  (-1.9667486968141933E-2)*tln**2*LOG(satratln) +                                       &
+          &  5.5244755979770844E-5*tln**3*LOG(satratln) + (7.8884704837892468*LOG(satratln))/x_n + &
+          &  4.6374659198909596*LOG(satratln)**2 - 8.2002809894792153E-2*tln*LOG(satratln)**2 +    &
+          &  8.5077424451172196E-4*tln**2*LOG(satratln)**2 +                                       &
+          &  (-2.6518510168987462E-6)*tln**3*LOG(satratln)**2 +                                    &
+          &  (-1.4625482500575278*LOG(satratln)**2)/x_n - 5.2413002989192037E-1*LOG(satratln)**3 + &
+          &  5.2755117653715865E-3*tln*LOG(satratln)**3 +                                          &
+          &  (-2.9491061332113830E-6)*tln**2*LOG(satratln)**3 +                                    &
+          &  (-2.4815454194486752E-8)*tln**3*LOG(satratln)**3 +                                    &
+          &  (-5.2663760117394626E-2*LOG(satratln)**3)/x_n +                                       &
+          &  1.6496664658266762*LOG(rhoaln) +                                                      &
+          &  (-8.0809397859218401E-1)*tln*LOG(rhoaln) +                                            &
+          &  8.9302927091946642E-3*tln**2*LOG(rhoaln) +                                            &
+          &  (-1.9583649496497497E-5)*tln**3*LOG(rhoaln) +                                         &
+          &  (-8.9505572676891685*LOG(rhoaln))/x_n +                                               &
+          &  (-3.0025283601622881E+1)*LOG(satratln)*LOG(rhoaln) +                                  &
+          &  3.0783365644763633E-1*tln*LOG(satratln)*LOG(rhoaln) +                                 &
+          &  (-7.4521756337984706E-4)*tln**2*LOG(satratln)*LOG(rhoaln) +                           &
+          &  (-5.7651433870681853E-7)*tln**3*LOG(satratln)*LOG(rhoaln) +                           &
+          &  (1.2872868529673207*LOG(satratln)*LOG(rhoaln))/x_n +                                  &
+          &  (-6.1739867501526535E-1)*LOG(satratln)**2*LOG(rhoaln) +                               &
+          &  7.2347385705333975E-3*tln*LOG(satratln)**2*LOG(rhoaln) +                              &
+          &  (-3.0640494530822439E-5)*tln**2*LOG(satratln)**2*LOG(rhoaln) +                        &
+          &  6.5944609194346214E-8*tln**3*LOG(satratln)**2*LOG(rhoaln) +                           &
+          &  (-2.8681650332461055E-2*LOG(satratln)**2*LOG(rhoaln))/x_n +                           &
+          &  6.5213802375160306*LOG(rhoaln)**2 +                                                   &
+          &  (-4.7907162004793016E-2)*tln*LOG(rhoaln)**2 +                                         &
+          &  (-1.0727890114215117E-4)*tln**2*LOG(rhoaln)**2 +                                      &
+          &  5.6401818280534507E-7*tln**3*LOG(rhoaln)**2 +                                         &
+          &  (5.4113070888923009E-1*LOG(rhoaln)**2)/x_n +                                          &
+          &  5.2062808476476330E-1*LOG(satratln)*LOG(rhoaln)**2 +                                  &
+          &  (-6.0696882500824584E-3)*tln*LOG(satratln)*LOG(rhoaln)**2 +                           &
+          &  2.3851383302608477E-5*tln**2*LOG(satratln)*LOG(rhoaln)**2 +                           &
+          &  (-1.5243837103067096E-8)*tln**3*LOG(satratln)*LOG(rhoaln)**2 +                        &
+          &  (-5.6543192378015687E-2*LOG(satratln)*LOG(rhoaln)**2)/x_n +                           &
+          &  (-1.1630806410696815E-1)*LOG(rhoaln)**3 +                                             &
+          &  1.3806404273119610E-3*tln*LOG(rhoaln)**3 +                                            &
+          &  (-2.0199865087650833E-6)*tln**2*LOG(rhoaln)**3 +                                      &
+          &  (-3.0200284885763192E-9)*tln**3*LOG(rhoaln)**3 +                                      &
+          &  (-6.9425267104126316E-3*LOG(rhoaln)**3)/x_n
+     jnuc_n=EXP(jnuc_n) 
+     
+     ntot_n =-3.5863435141979573E-3 - 1.0098670235841110E-1*tln + 8.9741268319259721E-4*tln**2 - 1.4855098605195757E-6*tln**3  &
+          &   - 1.2080330016937095E-1/x_n + 1.1902674923928015E-3*LOG(satratln) - 1.9211358507172177E-2*tln*LOG(satratln) +    &
+          &   2.4648094311204255E-4*tln**2*LOG(satratln) - 7.5641448594711666E-7*tln**3*LOG(satratln) +                        &
+          &   (-2.0668639384228818E-02*LOG(satratln))/x_n - 3.7593072011595188E-2*LOG(satratln)**2 +                           &
+          &   9.0993182774415718E-4 *tln*LOG(satratln)**2 +                                                                    &
+          &   (-9.5698412164297149E-6)*tln**2*LOG(satratln)**2 + 3.7163166416110421E-8*tln**3*LOG(satratln)**2 +               &
+          &   (1.1026579525210847E-2*LOG(satratln)**2)/x_n + 1.1530844115561925E-2 *LOG(satratln)**3 +                         &
+          &   (-1.8083253906466668E-4)*tln*LOG(satratln)**3 + 8.0213604053330654E-7*tln**2*LOG(satratln)**3 +                  &
+          &   (-8.5797885383051337E-10)*tln**3*LOG(satratln)**3 + (1.0243693899717402E-3*LOG(satratln)**3)/x_n +               &
+          &   (-1.7248695296299649E-2)*LOG(rhoaln) + 1.1294004162437157E-2*tln*LOG(rhoaln) +                                   &
+          &   (-1.2283640163189278E-4)*tln**2*LOG(rhoaln) + 2.7391732258259009E-7*tln**3*LOG(rhoaln) +                         &
+          &   (6.8505583974029602E-2*LOG(rhoaln))/x_n +2.9750968179523635E-1*LOG(satratln)*LOG(rhoaln) +                       &
+          &   (-3.6681154503992296E-3)*tln*LOG(satratln)*LOG(rhoaln) + 1.0636473034653114E-5*tln**2*LOG(satratln)*LOG(rhoaln)+ &
+          &   5.8687098466515866E-9*tln**3*LOG(satratln)*LOG(rhoaln) + (-5.2028866094191509E-3*LOG(satratln)*LOG(rhoaln))/x_n+ &
+          &   7.6971988880587231E-4*LOG(satratln)**2*LOG(rhoaln) - 2.4605575820433763E-5*tln*LOG(satratln)**2*LOG(rhoaln) +    &
+          &   2.3818484400893008E-7*tln**2*LOG(satratln)**2*LOG(rhoaln) +                                                      &
+          &   (-8.8474102392445200E-10)*tln**3*LOG(satratln)**2*LOG(rhoaln) +                                                  &
+          &   (-1.6640566678168968E-4*LOG(satratln)**2*LOG(rhoaln))/x_n - 7.7390093776705471E-2*LOG(rhoaln)**2 +               &
+          &   5.8220163188828482E-4*tln*LOG(rhoaln)**2 + 1.2291679321523287E-6*tln**2*LOG(rhoaln)**2 +                         &
+          &   (-7.4690997508075749E-9)*tln**3*LOG(rhoaln)**2 + (-5.6357941220497648E-3*LOG(rhoaln)**2)/x_n +                   &
+          &   (-4.7170109625089768E-3)*LOG(satratln)*LOG(rhoaln)**2 + 6.9828868534370193E-5*tln*LOG(satratln)*LOG(rhoaln)**2 + &
+          &   (-3.1738912157036403E-7)*tln**2*LOG(satratln)*LOG(rhoaln)**2 +                                                   &
+          &   2.3975538706787416E-10*tln**3*LOG(satratln)*LOG(rhoaln)**2 +                                                     &
+          &   (4.2304213386288567E-4*LOG(satratln)*LOG(rhoaln)**2)/x_n + 1.3696520973423231E-3*LOG(rhoaln)**3 +                &
+          &   (-1.6863387574788199E-5)*tln*LOG(rhoaln)**3 + 2.7959499278844516E-8*tln**2*LOG(rhoaln)**3 +                      &
+          &   3.9423927013227455E-11*tln**3*LOG(rhoaln)**3 + (8.6136359966337272E-5*LOG(rhoaln)**3)/x_n
+     ntot_n=EXP(ntot_n)
+     
+     rc_n=EXP(-22.378268374023630+0.44462953606125100*x_n+0.33499495707849131*LOG(ntot_n)) !in meters
+     
+     na_n=x_n*ntot_n
+     IF (na_n .LT. 1.) THEN
+        na_n=1.0
+     ENDIF
+  ENDIF
+  
+  ! Set the neutral nucleation rate to 0.0 if less than 1.0E-7      
+  IF (jnuc_n.LT.1.E-7) THEN
+     jnuc_n=0.0
+  ENDIF
+  
+  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+  
+  ! Ion-induced nucleation parameterization 
+ 
+  IF (ipr.GT.0.0) THEN ! if the ion production rate is above zero
+     
+     ! Calculate the ion induced nucleation rate wrt. concentration of 1 ion/cm3
+     
+     kinrhotresi = 5.3742280876674478E1  - 6.6837931590012266E-3 *LOG(satratli)**(-2)                                     &
+          & - 1.0142598385422842E-01 * LOG(satratli)**(-1) - 6.4170597272606873E+00 * LOG(satratli)                       &
+          & - 6.4315798914824518E-01 * LOG(satratli)**2 - 2.4428391714772721E-02 * LOG(satratli)**3                       &
+          & - 3.5356658734539019E-04 * LOG(satratli)**4 + 2.5400015099140506E-05 * tli * LOG(satratli)**(-2)              &
+          & - 2.7928900816637790E-04 * tli * LOG(satratli)**(-1) + 4.4108573484923690E-02 * tli * LOG(satratli)           &
+          & + 6.3943789012475532E-03 * tli * LOG(satratli)**(2) + 2.3164296174966580E-04 * tli * LOG(satratli)**(3)       &
+          & + 3.0372070669934950E-06 * tli * LOG(satratli)**4 + 3.8255873977423475E-06 * tli**2 * LOG(satratli)**(-1)     &
+          & - 1.2344793083561629E-04 * tli**2 * LOG(satratli) - 1.7959048869810192E-05 * tli**2 * LOG(satratli)**(2)      &
+          & - 3.2165622558722767E-07 * tli**2 * LOG(satratli)**3 - 4.7136923780988659E-09 * tli**3 * LOG(satratli)**(-1)  &
+          & + 1.1873317184482216E-07 * tli**3 * LOG(satratli) + 1.5685860354866621E-08 * tli**3 * LOG(satratli)**2        &
+          & - 1.4329645891059557E+04 * tli**(-1) + 1.3842599842575321E-01 * tli                                           &
+          & - 4.1376265912842938E-04 * tli**(2) + 3.9147639775826004E-07 * tli**3
+     
+     kinrhotresi=EXP(kinrhotresi) !1/cm3
+     
+     IF (kinrhotresi.LT.rhoali) kinetic_i=.true.
+     
+     IF (kinetic_i) THEN    
+        jnuc_i1=1.0E6*(0.3E-9 + 0.487E-9)**2.*SQRT(8.*RPI*RKBOL*(1./mH2SO4mol+1./mH2SO4mol))*  &
+             &  SQRT(tli)*rhoali !1/cm3s  
+        ntot_i=1. !set to 1 
+        na_i=1.
+        x_i=na_i/ntot_i  ! so also set this to 1
+        rc_i=0.487E-9
+     ELSE
+        jnuc_i1 = 3.0108954259038608E+01+tli*6.1176722090512577E+01+(tli**2)*8.7240333618891663E-01+(tli**3)*                &
+             & (-4.6191788649375719E-03)+(tli**(-1))*8.3537059107024481E-01 +                                                &
+             & (1.5028549216690628E+01+tli*(-1.9310989753720623E-01)+(tli**2)*8.0155514634860480E-04+(tli**3)*               &
+             & (-1.0832730707799128E-06)+(tli**(-1))*1.7577660457989019)*(LOG(satratli)**(-2)) +                             &
+             & (-2.0487870170216488E-01 + tli * 1.3263949252910405E-03 + (tli**2) *(-8.4195688402450274E-06) +               &
+             & (tli**3)*1.6154895940993287E-08 + (tli**(-1))*3.8734212545203874E+01) * (LOG(satratli)**(-2)*LOG(rhoali)) +   &
+             & (1.4955918863858371 + tli * 9.2290004245522454E+01 + (tli**2) *(-8.9006965195392618E-01) +                    &
+             & (tli**3) * 2.2319123411013099E-03 + (tli**(-1)) * 4.0180079996840852E-03) *                                   &
+             & (LOG(satratli)**(-1) * LOG(rhoali)**(-1)) +                                                                   &
+             & (7.9018031228561085 + tli *(-1.1649433968658949E+01) + (tli**2) * 1.1400827854910951E-01 +                    &
+             & (tli**3) *(-3.1941526492127755E-04) + (tli**(-1)) *(-3.7662115740271446E-01)) * (LOG(satratli)**(-1)) +       &
+             & (1.5725237111225979E+02 + tli *(-1.0051649979836277) + (tli**2) * 1.1866484014507624E-03 +                    &
+             & (tli**3) * 7.3557614998540389E-06 + (tli**(-1)) * 2.6270197023115189) * (LOG(satratli)**(-1) * LOG(rhoali)) + &
+             & (-1.6973840122470968E+01 + tli * 1.1258423691432135E-01 + (tli**2) *(-2.9850139351463793E-04) + (tli**3) *    &
+             & 1.4301286324827064E-07 + (tli**(-1)) * 1.3163389235253725E+01) * (LOG(satratli)**(-1) * LOG(rhoali)**2) +     &
+             & (-1.0399591631839757 + tli * 2.7022055588257691E-03 + (tli**2) *(-2.1507467231330936E-06) + (tli**3) *        &
+             & 3.8059489037584171E-10 + (tli**(-1)) * 1.5000492788553410E+02) * (LOG(satratli)**(-1) * LOG(rhoali)**3) +     &
+             & (1.2250990965305315 + tli * 3.0495946490079444E+01 + (tli**2) * 2.1051563135187106E+01 + (tli**3) *           &
+             & (-8.2200682916580878E-02) + (tli**(-1)) * 2.9965871386685029E-02) * (LOG(rhoali)**(-2)) +                     &
+             & (4.8281605955680433 + tli * 1.7346551710836445E+02 + (tli**2) *(-1.0113602140796010E+01) + (tli**3) *         &
+             & 3.7482518458685089E-02 + (tli**(-1)) *(-1.4449998158558205E-01)) * (LOG(rhoali)**(-1)) +                      &
+             & (2.3399230964451237E+02 + tli *(-2.3099267235261948E+01) + (tli**2) * 8.0122962140916354E-02 +                &
+             & (tli**3) * 6.1542576994557088E-05 + (tli**(-1)) * 5.3718413254843007) * (LOG(rhoali)) +                       &
+             & (1.0299715519499360E+02 + tli *(-6.4663357203364136E-02) + (tli**2) *(-2.0487150565050316E-03) +              &
+             & (tli**3) * 8.7935289055530897E-07 + (tli**(-1)) * 3.6013204601215229E+01) * (LOG(rhoali)**2) +                &
+             & (-3.5452115439584042 + tli * 1.7083445731159330E-02 + (tli**2) *(-1.2552625290862626E-05) + (tli**3) *        &
+             & 1.2968447449182847E-09 + (tli**(-1)) * 1.5748687512056560E+02) * (LOG(rhoali)**3) +                           &
+             & (2.2338490119517975 + tli * 1.0229410216045540E+02 + (tli**2) *(-3.2103611955174052) + (tli**3) *             &
+             & 1.3397152304977591E-02 + (tli**(-1)) *(-2.4155187776460030E-02)) * (LOG(satratli)* LOG(rhoali)**(-2)) +       &
+             & (3.7592282990713963 + tli *(-1.5257988769009816E+02) + (tli**2) * 2.6113805420558802 + (tli**3) *             &
+             & (-9.0380721653694363E-03) + (tli**(-1)) *(-1.3974197138171082E-01)) * (LOG(satratli)* LOG(rhoali)**(-1)) +    &
+             & (1.8293600730573988E+01 + tli * 1.8344728606002992E+01 + (tli**2) *(-4.0063363221106751E-01) + (tli**3)       &
+             & * 1.4842749371258522E-03 + (tli**(-1)) * 1.1848846003282287) * (LOG(satratli)) +                              &
+             & (-1.7634531623032314E+02 + tli * 4.9011762441271278 + (tli**2) *(-1.3195821562746339E-02) + (tli**3) *        &
+             & (-2.8668619526430859E-05) + (tli**(-1)) *(-2.9823396976393551E-01)) * (LOG(satratli)* LOG(rhoali)) +          &
+             & (-3.2944043694275727E+01 + tli * 1.2517571921051887E-01 + (tli**2) * 8.3239769771186714E-05 + (tli**3) *      &
+             & 2.8191859341519507E-07 + (tli**(-1)) *(-2.7352880736682319E+01)) * (LOG(satratli)* LOG(rhoali)**2) +          &
+             & (-1.1451811137553243 + tli * 2.0625997485732494E-03 + (tli**2) *(-3.4225389469233624E-06) + (tli**3) *        &
+             & 4.4437613496984567E-10 + (tli**(-1)) * 1.8666644332606754E+02) * (LOG(satratli)* LOG(rhoali)**3) +            &
+             & (3.2270897099493567E+01 + tli * 7.7898447327513687E-01 + (tli**2) *(-6.5662738484679626E-03) + (tli**3) *     &
+             & 3.7899330796456790E-06 + (tli**(-1)) * 7.1106427501756542E-01) * (LOG(satratli)**2 * LOG(rhoali)**(-1)) +     &
+             & (-2.8901906781697811E+01 + tli *(-1.5356398793054860) + (tli**2) * 1.9267271774384788E-02 + (tli**3) *        &
+             & (-5.3886270475516162E-05) + (tli**(-1)) * 5.0490415975693426E-01) * (LOG(satratli)**2) +                      &
+             & (3.3365683645733924E+01 + tli *(-3.6114561564894537E-01) + (tli**2) * 9.2977354471929262E-04 + (tli**3) *     &
+             & 1.9549769069511355E-07 + (tli**(-1)) *(-8.8865930095112855)) * (LOG(satratli)**2 * LOG(rhoali)) +             &
+             & (2.4592563042806375 + tli *(-8.3227071743101084E-03) + (tli**2) * 8.2563338043447783E-06 + (tli**3) *         &
+             & (-8.4374976698593496E-09) + (tli**(-1)) *(-2.0938173949893473E+02)) * (LOG(satratli)**2 * LOG(rhoali)**2) +   &
+             & (4.4099823444352317E+01 + tli * 2.5915665826835252 + (tli**2) *(-1.6449091819482634E-02) + (tli**3) *         &
+             & 2.6797249816144721E-05 + (tli**(-1)) * 5.5045672663909995E-01)* satratli
+        jnuc_i1=EXP(jnuc_i1)
+        
+        ntot_i = ABS((-4.8324296064013375E+04 + tli * 5.0469120697428906E+02 + (tli**2) *(-1.1528940488496042E+00) +         &
+             & (tli**(-1)) *(-8.6892744676239192E+02) + (tli**(3)) * 4.0030302028120469E-04) +                               &
+             & (-6.7259105232039847E+03 + tli * 1.9197488157452008E+02 + (tli**2) *(-1.3602976930126354E+00) +               &
+             & (tli**(-1)) *(-1.1212637938360332E+02) + (tli**(3)) * 2.8515597265933207E-03) *                               &
+             & LOG(satratli)**(-2) * LOG(rhoali)**(-2) +                                                                     &
+             & (2.6216455217763342E+02 + tli *(-2.3687553252750821E+00) + (tli**2) * 7.4074554767517521E-03 +                &
+             & (tli**(-1)) *(-1.9213956820114927E+03) + (tli**(3)) *(-9.3839114856129453E-06)) * LOG(satratli)**(-2) +       &
+             & (3.9652478944137344E+00 + tli * 1.2469375098256536E-02 + (tli**2) *(-9.9837754694045633E-05) + (tli**(-1)) *  &
+             & (-5.1919499210175138E+02) + (tli**(3)) * 1.6489001324583862E-07) * LOG(satratli)**(-2) * LOG(rhoali) +        &
+             & (2.4975714429096206E+02 + tli * 1.7107594562445172E+02 + (tli**2) *(-7.8988711365135289E-01) + (tli**(-1)) *  &
+             & (-2.2243599782483177E+01) + (tli**(3)) *(-1.6291523004095427E-04)) * LOG(satratli)**(-1) * LOG(rhoali)**(-2) +&
+             & (-8.9270715592533611E+02 + tli * 1.2053538883338946E+02 + (tli**2) *(-1.5490408828541018E+00) + (tli**(-1)) * &
+             & (-1.1243275579419826E+01) + (tli**(3)) * 4.8053105606904655E-03) * LOG(satratli)**(-1) * LOG(rhoali)**(-1) +  &
+             & (7.6426441642091631E+03 + tli *(-7.1785462414656578E+01) + (tli**2) * 2.3851864923199523E-01 + (tli**(-1)) *  &
+             & 8.5591775688708395E+01 + (tli**(3)) *(-3.7000473243342858E-04)) * LOG(satratli)**(-1) +                       &
+             & (-5.1516826398607911E+01 + tli * 9.1385720811460558E-01 + (tli**2) *(-3.5477100262158974E-03) +               &
+             & (tli**(-1)) * 2.7545544507625586E+03 + (tli**(3)) * 5.4708262093640928E-06) * LOG(satratli)**(-1) * LOG(rhoali) + &
+             & (-3.0386767129196176E+02 + tli *(-1.1033438883583569E+04) + (tli**2) * 8.1296859732896067E+01 + (tli**(-1)) * &
+             & 1.2625883141097162E+01 + (tli**(3)) *(-1.2728497822219101E-01)) * LOG(rhoali)**(-2) +                         &
+             & (-3.3763494256461472E+03 + tli * 3.1916579136391006E+03 + (tli**2) *(-2.7234339474441143E+01) + (tli**(-1)) * &
+             & (-2.1897653262707397E+01) + (tli**(3)) * 5.1788505812259071E-02) * LOG(rhoali)**(-1) +                        &
+             & (-1.8817843873687068E+03 + tli * 4.3038072285882070E+00 + (tli**2) * 6.6244087689671860E-03 + (tli**(-1)) *   &
+             & (-2.7133073605696295E+03) + (tli**(3)) *(-1.7951557394285043E-05)) * LOG(rhoali) +                            &
+             & (-1.7668827539244447E+02 + tli * 4.8160932330629913E-01 + (tli**2) *(-6.3133007671100293E-04) + (tli**(-1)) * &
+             & 2.5631774669873157E+04 + (tli**(3)) * 4.1534484127873519E-07) * LOG(rhoali)**(2) +                            &
+             & (-1.6661835889222382E+03 + tli * 1.3708900504682877E+03 + (tli**2) *(-1.7919060052198969E+01) + (tli**(-1)) * &
+             & (-3.5145029804436405E+01) + (tli**(3)) * 5.1047240947371224E-02) * LOG(satratli)* LOG(rhoali)**(-2) +         &
+             & (1.0843549363030939E+04 + tli *(-7.3557073636139577E+01) + (tli**2) * 1.2054625131778862E+00 + (tli**(-1)) *  &
+             & 1.9358737917864391E+02 + (tli**(3)) *(-4.2871620775911338E-03)) * LOG(satratli)* LOG(rhoali)**(-1) +          &
+             & (-2.4269802549752835E+03 + tli * 1.1348265061941714E+01 + (tli**2) *(-5.0430423939495157E-02) + (tli**(-1)) * &
+             & 2.3709874548950634E+03 + (tli**(3)) * 1.4091851828620244E-04) * LOG(satratli) +                               &
+             & (5.2745372575251588E+02 + tli *(-2.6080675912627314E+00) + (tli**2) * 5.6902218056670145E-03 + (tli**(-1)) *  &
+             & (-3.2149319482897838E+04) + (tli**(3)) *(-5.4121996056745853E-06)) * LOG(satratli)* LOG(rhoali) +             &
+             & (-1.6401959518360403E+01 + tli * 2.4322962162439640E-01 + (tli**2) * 1.1744366627725344E-03 + (tli**(-1)) *   &
+             & (-8.2694427518413195E+03) + (tli**(3)) *(-5.0028379203873102E-06))* LOG(satratli)**(2) +                      &
+             & (-2.7556572017167782E+03 + tli * 4.9293344495058264E+01 + (tli**2) *(-2.6503456520676050E-01) + (tli**(-1)) * &
+             & 1.2130698030982167E+03 + (tli**(3)) * 4.3530610668042957E-04)* LOG(satratli)**2 * LOG(rhoali)**(-1) +         &
+             & (-6.3419182228959192E+00 + tli * 4.0636212834605827E-02 + (tli**2) *(-1.0450112687842742E-04) + (tli**(-1)) * &
+             & 3.1035882189759656E+02 + (tli**(3)) * 9.4328418657873500E-08)* LOG(satratli)**(-3) +                          &
+             & (3.0189213304689042E+03 + tli *(-2.3804654203861684E+01) + (tli**2) * 6.8113013411972942E-02 + (tli**(-1)) *  &
+             & 6.3112071081188913E+02 + (tli**(3)) *(-9.4460854261685723E-05))* (satratli) * LOG(rhoali) +                   &
+             & (1.1924791930673702E+04 + tli *(-1.1973824959206000E+02) + (tli**2) * 1.6888713097971020E-01 + (tli**(-1)) *  &
+             & 1.8735938211539585E+02 + (tli**(3)) * 5.0974564680442852E-04)* (satratli) +                                   &
+             & (3.6409071302482083E+01 + tli * 1.7919859306449623E-01 + (tli**2) *(-1.0020116255895206E-03) + (tli**(-1)) *  &
+             & (-8.3521083354432303E+03) + (tli**(3)) * 1.5879900546795635E-06)* satratli * LOG(rhoali)**(2))
+          
+        rc_i = (-3.6318550637865524E-08 + tli * 2.1740704135789128E-09   + (tli**2) *                            &
+             & (-8.5521429066506161E-12) + (tli**3) *(-9.3538647454573390E-15)) +                                &
+             & (2.1366936839394922E-08 + tli *(-2.4087168827395623E-10) + (tli**2) * 8.7969869277074319E-13 +    &
+             & (tli**3) *(-1.0294466881303291E-15))* LOG(satratli)**(-2) * LOG(rhoali)**(-1) +                   &
+             & (-7.7804007761164303E-10 + tli * 1.0327058173517932E-11 + (tli**2) *(-4.2557697639692428E-14) +   &
+             & (tli**3) * 5.4082507061618662E-17)* LOG(satratli)**(-2) +                                         &
+             & (3.2628927397420860E-12 + tli *(-7.6475692919751066E-14) + (tli**2) * 4.1985816845259788E-16 +    &
+             & (tli**3) *(-6.2281395889592719E-19))* LOG(satratli)**(-2) * LOG(rhoali) +                         &
+             & (2.0442205540818555E-09 + tli * 4.0441858911249830E-08 + (tli**2) *(-3.3423487629482825E-10) +    &
+             & (tli**3) * 6.8000404742985678E-13)* LOG(satratli)**(-1) * LOG(rhoali)**(-2) +                     &
+             & (1.8381489183824627E-08 + tli *(-8.9853322951518919E-09) + (tli**2) * 7.5888799566036185E-11 +    &
+             & (tli**3) *(-1.5823457864755549E-13))* LOG(satratli)**(-1) * LOG(rhoali)**(-1) +                   &
+             & (1.1795760639695057E-07 + tli *(-8.1046722896375875E-10) + (tli**2) * 9.1868604369041857E-14 +    &
+             & (tli**3) * 4.7882428237444610E-15)* LOG(satratli)**(-1) +                                         &
+             & (-4.4028846582545952E-09 + tli * 4.6541269232626618E-11 + (tli**2) *(-1.1939929984285194E-13) +   &
+             & (tli**3) * 2.3602037016614437E-17)* LOG(satratli)**(-1) * LOG(rhoali) +                           &
+             & (2.7885056884209128E-11 + tli *(-4.5167129624119121E-13) + (tli**2) * 1.6558404997394422E-15 +    &
+             & (tli**3) *(-1.2037336621218054E-18))* LOG(satratli)**(-1) * LOG(rhoali)**2 +                      &
+             & (-2.3719627171699983E-09 + tli *(-1.5260127909292053E-07) + (tli**2) * 1.7177017944754134E-09 +   &
+             & (tli**3) *(-4.7031737537526395E-12))* LOG(rhoali)**(-2) +                                         &
+             & (-5.6946433724699646E-09 + tli * 8.4629788237081735E-09 + (tli**2) *(-1.7674135187061521E-10) +   &
+             & (tli**3) * 6.6236547903091862E-13)* LOG(rhoali)**(-1) +                                           &
+             & (-2.2808617930606012E-08 + tli * 1.4773376696847775E-10 + (tli**2) *(-1.3076953119957355E-13) +   &
+             & (tli**3) * 2.3625301497914000E-16)* LOG(rhoali) +                                                 &
+             & (1.4014269939947841E-10 + tli *(-2.3675117757377632E-12) + (tli**2) * 5.1514033966707879E-15 +    &
+             & (tli**3) *(-4.8864233454747856E-18))* LOG(rhoali)**2 +                                            &
+             & (6.5464943868885886E-11 + tli * 1.6494354816942769E-08 + (tli**2) *(-1.7480097393483653E-10) +    &
+             & (tli**3) * 4.7460075628523984E-13)* LOG(satratli)* LOG(rhoali)**(-2) +                            &
+             & (8.4737893183927871E-09 + tli *(-6.0243327445597118E-09) + (tli**2) * 5.8766070529814883E-11 +    &
+             & (tli**3) *(-1.4926748560042018E-13))* LOG(satratli)* LOG(rhoali)**(-1) +                          &
+             & (1.0761964135701397E-07 + tli *(-1.0142496009071148E-09) + (tli**2) * 2.1337312466519190E-12 +    &
+             & (tli**3) * 1.6376014957685404E-15)* LOG(satratli) +                                               &
+             & (-3.5621571395968670E-09 + tli * 4.1175339587760905E-11 + (tli**2) *(-1.3535372357998504E-13) +   &
+             & (tli**3) * 8.9334219536920720E-17)* LOG(satratli)* LOG(rhoali) +                                  &
+             & (2.0700482083136289E-11 + tli *(-3.9238944562717421E-13) + (tli**2) * 1.5850961422040196E-15 +    &
+             & (tli**3) *(-1.5336775610911665E-18))* LOG(satratli)* LOG(rhoali)**2 +                             &
+             & (1.8524255464416206E-09 + tli *(-2.1959816152743264E-11) + (tli**2) *(-6.4478119501677012E-14) +  &
+             & (tli**3) * 5.5135243833766056E-16)* LOG(satratli)**2 * LOG(rhoali)**(-1) +                        &
+             & (1.9349488650922679E-09 + tli *(-2.2647295919976428E-11) + (tli**2) * 9.2917479748268751E-14 +    &
+             & (tli**3) *(-1.2741959892173170E-16))* LOG(satratli)**2 +                                          &
+             & (2.1484978031650972E-11 + tli *(-9.3976642475838013E-14) + (tli**2) *(-4.8892738002751923E-16) +  &
+             & (tli**3) * 1.4676120441783832E-18)* LOG(satratli)**2 * LOG(rhoali) +                              &
+             & (6.7565715216420310E-13 + tli *(-3.5421162549480807E-15) + (tli**2) *(-3.4201196868693569E-18) +  &
+             & (tli**3) * 2.2260187650412392E-20)* LOG(satratli)**3 * LOG(rhoali)
+                    
+        na_i=x_i*ntot_i
+        IF (na_i .LT. 1.) THEN
+           na_n=1.0
+        ENDIF
+     ENDIF
+    
+     jnuc_i=jnuc_i1 
+     ! Ion loss rate (1/s)
+     xloss=csi+jnuc_i
+     
+     ! Recombination (here following Brasseur and Chatel, 1983)   
+     recomb=6.0E-8*SQRT(300./tli)+6.0E-26*airn*(300./tli)**4
+     
+     ! Small ion concentration in air (1/cm3) (following Dunne et al., 2016)
+     ! max function is to avoid n_i to go practically zero at very high J_ion 
+     n_i=MAX(0.01,(SQRT(xloss**2.0+4.0*recomb*ipr)-xloss)/(2.0*recomb))
+     
+     ! Ion-induced nucleation rate
+     ! Min function is to ensure that max function above does not cause J_ion to overshoot 
+     jnuc_i=MIN(ipr,n_i*jnuc_i1)
+     ! Set the ion-induced nucleation rate to 0.0 if less than 1.0E-7      
+     IF (jnuc_i.LT.1.E-7) THEN
+        jnuc_i=0.0
+     ENDIF
+
+  ENDIF
+
+!--conversion from double precision to float in case the model is run in single precision
+  jnuc_n_real   = jnuc_n
+  ntot_n_real   = ntot_n
+  jnuc_i_real   = jnuc_i
+  ntot_i_real   = ntot_i
+  x_n_real      = x_n
+  x_i_real      = x_i
+  na_n_real     = na_n
+  na_i_real     = na_i
+  rc_n_real     = rc_n
+  rc_i_real     = rc_i
+  n_i_real      = n_i
+  
+END SUBROUTINE newbinapara
+
+END MODULE nucleation_tstep_mod
Index: DZ6/trunk/libf/phylmd/StratAer/ocs_to_so2.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/StratAer/ocs_to_so2.F90	(revision 5267)
+++ 	(revision )
@@ -1,55 +1,0 @@
-!
-! $Id$
-!
-SUBROUTINE ocs_to_so2(pdtphys,tr_seri,t_seri,pplay,paprs,is_strato)
-
-  USE dimphy, ONLY : klon,klev
-  USE aerophys
-  USE infotrac_phy
-  USE yomcst_mod_h, ONLY : RG
-  USE phys_local_var_mod, ONLY : OCS_lifetime, budg_3D_ocs_to_so2, budg_ocs_to_so2
-  USE strataer_local_var_mod, ONLY : flag_min_rreduce
-
-  IMPLICIT NONE
-
-  !--------------------------------------------------------
-  ! transfer variables when calling this routine
-  REAL,INTENT(IN)                               :: pdtphys ! Pas d'integration pour la physique (seconde)
-  REAL,DIMENSION(klon,klev,nbtr),INTENT(INOUT)  :: tr_seri ! Concentration Traceur [U/KgA]
-  REAL,DIMENSION(klon,klev),INTENT(IN)          :: t_seri  ! Temperature
-  REAL,DIMENSION(klon,klev),INTENT(IN)          :: pplay   ! pression pour le mileu de chaque couche (en Pa)
-  REAL,DIMENSION(klon,klev+1),INTENT(IN)        :: paprs   ! pression pour chaque inter-couche (en Pa)
-  LOGICAL,DIMENSION(klon,klev),INTENT(IN)       :: is_strato
-
-  ! local variables
-  INTEGER                                       :: i,j,k,nb,ilon,ilev
-  REAL                                          :: rreduce
-  
-!--convert OCS to SO2
-  budg_3D_ocs_to_so2(:,:)=0.0
-  budg_ocs_to_so2(:)=0.0
-
-  DO ilon=1, klon
-     DO ilev=1, klev
-        !only in the stratosphere
-        IF (is_strato(ilon,ilev)) THEN
-          IF (OCS_lifetime(ilon,ilev).GT.0.0.AND.OCS_lifetime(ilon,ilev).LT.1.E10) THEN
-            rreduce = OCS_lifetime(ilon,ilev)
-            ! Check lifetime rreduce < timestep*3 (such as H2SO4 loss > 0.28*H2SO4) with exp(-1/3)=0.72
-            IF(flag_min_rreduce) THEN
-               IF (rreduce .LT. (3.*pdtphys)) rreduce = 3.*pdtphys
-            ENDIF
-            budg_3D_ocs_to_so2(ilon,ilev)=tr_seri(ilon,ilev,id_OCS_strat)*(1.0-exp(-pdtphys/rreduce))
-            tr_seri(ilon,ilev,id_OCS_strat)=tr_seri(ilon,ilev,id_OCS_strat) - budg_3D_ocs_to_so2(ilon,ilev)
-            tr_seri(ilon,ilev,id_SO2_strat)=tr_seri(ilon,ilev,id_SO2_strat) + mSO2mol/mOCSmol*budg_3D_ocs_to_so2(ilon,ilev)
-            !convert budget from kg(OCS)/kgA to kg(S)/m2/layer/s for saving as diagnostic
-            budg_3D_ocs_to_so2(ilon,ilev)=budg_3D_ocs_to_so2(ilon,ilev)*mSatom/mOCSmol*(paprs(ilon,ilev)-paprs(ilon,ilev+1))/RG/pdtphys
-            budg_ocs_to_so2(ilon)=budg_ocs_to_so2(ilon)+budg_3D_ocs_to_so2(ilon,ilev)
-         ENDIF
-         ! END IF(OCS_lifetime(ilon,ilev).GT.0.0.AND.OCS_lifetime(ilon,ilev).LT.1.E10)
-      ENDIF
-      ! END IF(is_strato(ilon,ilev))
-   ENDDO
-  ENDDO
-
-END SUBROUTINE ocs_to_so2
Index: /LMDZ6/trunk/libf/phylmd/StratAer/ocs_to_so2.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/StratAer/ocs_to_so2.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/StratAer/ocs_to_so2.f90	(revision 5268)
@@ -0,0 +1,55 @@
+!
+! $Id$
+!
+SUBROUTINE ocs_to_so2(pdtphys,tr_seri,t_seri,pplay,paprs,is_strato)
+
+  USE dimphy, ONLY : klon,klev
+  USE aerophys
+  USE infotrac_phy
+  USE yomcst_mod_h, ONLY : RG
+  USE phys_local_var_mod, ONLY : OCS_lifetime, budg_3D_ocs_to_so2, budg_ocs_to_so2
+  USE strataer_local_var_mod, ONLY : flag_min_rreduce
+
+  IMPLICIT NONE
+
+  !--------------------------------------------------------
+  ! transfer variables when calling this routine
+  REAL,INTENT(IN)                               :: pdtphys ! Pas d'integration pour la physique (seconde)
+  REAL,DIMENSION(klon,klev,nbtr),INTENT(INOUT)  :: tr_seri ! Concentration Traceur [U/KgA]
+  REAL,DIMENSION(klon,klev),INTENT(IN)          :: t_seri  ! Temperature
+  REAL,DIMENSION(klon,klev),INTENT(IN)          :: pplay   ! pression pour le mileu de chaque couche (en Pa)
+  REAL,DIMENSION(klon,klev+1),INTENT(IN)        :: paprs   ! pression pour chaque inter-couche (en Pa)
+  LOGICAL,DIMENSION(klon,klev),INTENT(IN)       :: is_strato
+
+  ! local variables
+  INTEGER                                       :: i,j,k,nb,ilon,ilev
+  REAL                                          :: rreduce
+  
+!--convert OCS to SO2
+  budg_3D_ocs_to_so2(:,:)=0.0
+  budg_ocs_to_so2(:)=0.0
+
+  DO ilon=1, klon
+     DO ilev=1, klev
+        !only in the stratosphere
+        IF (is_strato(ilon,ilev)) THEN
+          IF (OCS_lifetime(ilon,ilev).GT.0.0.AND.OCS_lifetime(ilon,ilev).LT.1.E10) THEN
+            rreduce = OCS_lifetime(ilon,ilev)
+            ! Check lifetime rreduce < timestep*3 (such as H2SO4 loss > 0.28*H2SO4) with exp(-1/3)=0.72
+            IF(flag_min_rreduce) THEN
+               IF (rreduce .LT. (3.*pdtphys)) rreduce = 3.*pdtphys
+            ENDIF
+            budg_3D_ocs_to_so2(ilon,ilev)=tr_seri(ilon,ilev,id_OCS_strat)*(1.0-exp(-pdtphys/rreduce))
+            tr_seri(ilon,ilev,id_OCS_strat)=tr_seri(ilon,ilev,id_OCS_strat) - budg_3D_ocs_to_so2(ilon,ilev)
+            tr_seri(ilon,ilev,id_SO2_strat)=tr_seri(ilon,ilev,id_SO2_strat) + mSO2mol/mOCSmol*budg_3D_ocs_to_so2(ilon,ilev)
+            !convert budget from kg(OCS)/kgA to kg(S)/m2/layer/s for saving as diagnostic
+            budg_3D_ocs_to_so2(ilon,ilev)=budg_3D_ocs_to_so2(ilon,ilev)*mSatom/mOCSmol*(paprs(ilon,ilev)-paprs(ilon,ilev+1))/RG/pdtphys
+            budg_ocs_to_so2(ilon)=budg_ocs_to_so2(ilon)+budg_3D_ocs_to_so2(ilon,ilev)
+         ENDIF
+         ! END IF(OCS_lifetime(ilon,ilev).GT.0.0.AND.OCS_lifetime(ilon,ilev).LT.1.E10)
+      ENDIF
+      ! END IF(is_strato(ilon,ilev))
+   ENDDO
+  ENDDO
+
+END SUBROUTINE ocs_to_so2
Index: DZ6/trunk/libf/phylmd/StratAer/so2_to_h2so4.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/StratAer/so2_to_h2so4.F90	(revision 5267)
+++ 	(revision )
@@ -1,152 +1,0 @@
-!
-! $Id$
-!
-SUBROUTINE SO2_TO_H2SO4(pdtphys,tr_seri,t_seri,pplay,paprs,is_strato)
-
-  USE dimphy, ONLY : klon,klev
-  USE aerophys
-  USE infotrac_phy
-  USE yomcst_mod_h, ONLY : RG, RD
-  ! lifetime (sec) et O3_clim (VMR)
-  USE phys_local_var_mod, ONLY : SO2_lifetime, H2SO4_lifetime, O3_clim, budg_3D_so2_to_h2so4, budg_so2_to_h2so4
-  USE strataer_local_var_mod, ONLY : flag_OH_reduced, flag_H2SO4_photolysis, flag_min_rreduce
-  
-  IMPLICIT NONE
-
-  !--------------------------------------------------------
-
-  ! transfer variables when calling this routine
-  REAL,INTENT(IN)                               :: pdtphys ! Pas d'integration pour la physique (seconde)
-  REAL,DIMENSION(klon,klev,nbtr),INTENT(INOUT)  :: tr_seri ! Concentration Traceur [U/KgA]
-  REAL,DIMENSION(klon,klev),INTENT(IN)          :: t_seri  ! Temperature
-  REAL,DIMENSION(klon,klev),INTENT(IN)          :: pplay   ! pression pour le mileu de chaque couche (en Pa)
-  REAL,DIMENSION(klon,klev+1),INTENT(IN)        :: paprs   ! pression pour chaque inter-couche (en Pa)
-  LOGICAL,DIMENSION(klon,klev),INTENT(IN)       :: is_strato ! stratospheric flag
-
-  ! local variables in coagulation routine
-  INTEGER                                       :: i,j,k,nb,ilon,ilev
-  REAL                                          :: dummyso4toso2,rkho2o3,rkoho3,rkso2oh
-  REAL                                          :: rmairdens,rrak0,rrak1,rrate,rreduce
-  
-!--convert SO2 to H2SO4
-  budg_3D_so2_to_h2so4(:,:)=0.0
-  budg_so2_to_h2so4(:)=0.0
-
-  DO ilon=1, klon
-     DO ilev=1, klev
-     !only in the stratosphere
-        IF (is_strato(ilon,ilev)) THEN
-           IF (SO2_lifetime(ilon,ilev).GT.0.0 .AND. SO2_lifetime(ilon,ilev).LT.1.E10) THEN
-              IF (flag_OH_reduced) THEN
-                 !--convert SO2 to H2SO4 (slimane)
-                 ! Reduce OH because of SO2
-                 ! d[OH]/dt = k1[HO2][O] +k2[HO2][O3] +k3[HO2][NO]
-                 ! − (k4[O] +k5[O3] +k6[CO] +ks[SO2])[OH]
-                 ! In steady-state: d[OH]/dt = 0, so the ratio [OH]/[HO2] =
-                 ! (k1[O] +k2[O3] +k3[NO]) / (k4[O] +k5[O3] +k6[CO] +ks[SO2])
-                 ! In the lower and middle stratosphere,
-                 ! [OH]/[HO2] ~(k2[O3] +k3[NO]) / (k5[O3] +k6[CO] +ks[SO2])
-                 ! CO is only important near the tropopause. NO should not dominate over O3.
-                 ! So when consideringthe big terms: [OH]/[HO2] ~ ~ k2[O3] / (k5[O3] +ks[SO2])
-                 ! For c: control run c (no effect of SO2), [OHc]/[HO2c] ~ ~ k2[O3] / k5[O3] = 1/ Rc
-                 ! For p: perturbed run (high SO2), [OHp]/[HO2p] ~ ~ k2[O3] / (k5[O3] +ks[SO2]) =1/Rp
-                 ! If HOx = OH + HO2 = constante,
-                 ! OHc + HO2c = OHp + HO2p
-                 ! OHc (1+Rc) = OHp (1+Rp)
-                 ! OHp = OHc (1+Rc) / (1+Rp)
-                 ! 1+Rc = (k2[O3] +k5[O3] ) / k2[O3]
-                 ! 1+Rp = (k2[O3] +k5[O3] +ks[SO2]) / k2[O3]
-                 ! (1+Rc) / (1+Rp)= (k2[O3] +k5[O3] )/ (k2[O3] +k5[O3] +ks[SO2])
-                 ! OHp = OHc * (k(HO2+OH)*[O3] +k(OH+O3)[O3] ) /
-                 ! (k(HO2+OH)*[O3] +k(OH+O3)[O3] +k(SO2+OH)[SO2])
-                 ! Final: OHp = OHc * (k(HO2+O3)*[O3] +k(OH+O3)[O3] ) /
-                 !  (k(HO2+O3)*[O3] +k(OH+O3)[O3] +k(SO2+OH)[SO2])
-                 
-                 !   latest jpl 2020
-                 rkho2o3 = 1.0e-14*exp( -490./t_seri(ilon,ilev) )
-                 rkoho3 = 1.7e-12*exp( -940./t_seri(ilon,ilev) )
-                 
-                 ! rkso2oh= so2 + oh + m  ->hso3 + m-> h2so4 + m
-                 ! air density M(molecule/cm3) = Pa/(K*1.38e-19)
-                 rmairdens =  pplay(ilon,ilev)/(t_seri(ilon,ilev)*1.38e-19)
-                 ! JPL 2020
-                 rrak0 = 3.3e-31*( (300./t_seri(ilon,ilev))**4.3 )
-                 rrak1 = 1.6e-12
-                 rrate = (rrak0*rmairdens) / ( 1. + rrak0*rmairdens/rrak1 )
-                 rreduce = 1./( 1. + log10((rrak0*rmairdens)/rrak1)**2 )
-                 rkso2oh = rrate*(0.6**rreduce)
-                 
-                 ! O3 (molec/cm3): O3_clim in vmr
-                 rrak0 = O3_clim(ilon,ilev)*rmairdens
-                 ! SO2 (molec/cm3): convert from kg/kgA
-                 rrak1 = tr_seri(ilon,ilev,id_SO2_strat) &
-                      & *pplay(ilon,ilev)/t_seri(ilon,ilev)/RD/1.E6/mSO2mol
-                 
-                 IF (rrak1 .GE. 0.0) THEN
-                    rreduce =( (rkho2o3+rkoho3)*rrak0 + rkso2oh*rrak1 ) / &
-                         (  (rkho2o3+rkoho3)*rrak0 )
-                    ! reduce OH, so extend SO2 lifetime
-                    rreduce = rreduce*SO2_lifetime(ilon,ilev)
-                 ELSE
-                    rreduce =  SO2_lifetime(ilon,ilev)
-                 ENDIF
-                 ! end of IF (rrak1) THEN
-              ELSE
-                 rreduce =  SO2_lifetime(ilon,ilev)
-              ENDIF
-              ! end of IF (flag_OH_reduced) THEN
-              
-              ! Check lifetime rreduce < timestep*1.5 (such as SO2 loss > 0.5*SO2) with exp(-1/1.5)=0.52
-              ! Check lifetime rreduce < timestep*3 (such as SO2 loss > 0.28*SO2) with exp(-1/3)=0.72
-              IF(flag_min_rreduce) THEN
-                 IF (rreduce .LT. (3.*pdtphys)) rreduce = 3.*pdtphys
-              ENDIF
-              budg_3D_so2_to_h2so4(ilon,ilev)=tr_seri(ilon,ilev,id_SO2_strat)*(1.0-exp(-pdtphys/rreduce))
-              tr_seri(ilon,ilev,id_SO2_strat)=tr_seri(ilon,ilev,id_SO2_strat) - budg_3D_so2_to_h2so4(ilon,ilev)
-              tr_seri(ilon,ilev,id_H2SO4_strat)=tr_seri(ilon,ilev,id_H2SO4_strat) + mH2SO4mol/mSO2mol*budg_3D_so2_to_h2so4(ilon,ilev)
-           ENDIF
-           ! IF (SO2_lifetime(ilon,ilev).GT.0.0 .AND. SO2_lifetime(ilon,ilev).LT.1.E10) THEN
-           
-           
-           IF (flag_H2SO4_photolysis) THEN
-              !--convert H2SO4 to SO2 using HCl photolysis (Rinsland et al, 1995)
-              ! 4.6e-8 sec-1: J strato taken from Feierabend, et al., Chem. Phys. Lett., 2006.
-              ! error before:  ...exp(-pdtphys/4.6e-8) so negligible photolysis,
-              !                 should have been exp(-pdtphys*4.6e-8)
-              ! Also: Lane and Kjaergaard: ,J. Phys. Chem. A, 2008
-              ! We find that the dominant photodissociation mechanism of H2SO4
-              ! below 70 km is absorption in the visible region by OH stretching overtone
-              ! transitions, whereas above 70 km, absorption of Lyman-R ...
-              ! In 2D model, 0.3 Rinsland et al, 1995 but Burkholder, Mills and McKeen say 0.016
-              ! JH2SO4=JHCL*0.3   (*0.016 would be too slow)
-              ! test: quick sequential integration for SO2 to H2SO4 and reverse
-              
-              IF (H2SO4_lifetime(ilon,ilev).GT.0.0 .AND. H2SO4_lifetime(ilon,ilev).LT.1.E10) THEN
-                 
-                 rreduce = H2SO4_lifetime(ilon,ilev)
-                 dummyso4toso2 = 0.0
-                 
-                 ! Check lifetime rreduce < timestep*1.5 (such as H2SO4 loss > 0.5*H2SO4) with exp(-1/1.5)=0.52
-                 ! Check lifetime rreduce < timestep*3 (such as H2SO4 loss > 0.28*H2SO4) with exp(-1/3)=0.72
-                 IF(flag_min_rreduce) THEN
-                    IF (rreduce .LT. (3.*pdtphys)) rreduce = 3.*pdtphys
-                 ENDIF
-                 dummyso4toso2 = (mSO2mol/mH2SO4mol)*tr_seri(ilon,ilev,id_H2SO4_strat)*(1.0-exp(-pdtphys/rreduce))
-                 budg_3D_so2_to_h2so4(ilon,ilev) = budg_3D_so2_to_h2so4(ilon,ilev) + dummyso4toso2
-                 tr_seri(ilon,ilev,id_SO2_strat)=tr_seri(ilon,ilev,id_SO2_strat) + dummyso4toso2
-                 tr_seri(ilon,ilev,id_H2SO4_strat)=tr_seri(ilon,ilev,id_H2SO4_strat) - (mH2SO4mol/mSO2mol)*dummyso4toso2
-              ENDIF
-              ! IF (H2SO4_lifetime(ilon,ilev).GT.0.0 .AND. H2SO4_lifetime(ilon,ilev).LT.1.E10) THEN
-           ENDIF
-           ! end of IF (flag_H2SO4_photolysis) THEN
-           
-           !convert budget from kg(SO2)/kgA to kg(S)/m2/layer/s for saving as diagnostic
-           budg_3D_so2_to_h2so4(ilon,ilev)=budg_3D_so2_to_h2so4(ilon,ilev)*mSatom/mSO2mol* &
-                (paprs(ilon,ilev)-paprs(ilon,ilev+1))/RG/pdtphys
-           budg_so2_to_h2so4(ilon)=budg_so2_to_h2so4(ilon)+budg_3D_so2_to_h2so4(ilon,ilev)
-        ENDIF
-        ! IF (is_strato(ilon,ilev)) THEN
-     ENDDO ! DO (klev)
-  ENDDO ! DO (klon)
-  
-END SUBROUTINE SO2_TO_H2SO4
Index: /LMDZ6/trunk/libf/phylmd/StratAer/so2_to_h2so4.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/StratAer/so2_to_h2so4.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/StratAer/so2_to_h2so4.f90	(revision 5268)
@@ -0,0 +1,152 @@
+!
+! $Id$
+!
+SUBROUTINE SO2_TO_H2SO4(pdtphys,tr_seri,t_seri,pplay,paprs,is_strato)
+
+  USE dimphy, ONLY : klon,klev
+  USE aerophys
+  USE infotrac_phy
+  USE yomcst_mod_h, ONLY : RG, RD
+  ! lifetime (sec) et O3_clim (VMR)
+  USE phys_local_var_mod, ONLY : SO2_lifetime, H2SO4_lifetime, O3_clim, budg_3D_so2_to_h2so4, budg_so2_to_h2so4
+  USE strataer_local_var_mod, ONLY : flag_OH_reduced, flag_H2SO4_photolysis, flag_min_rreduce
+  
+  IMPLICIT NONE
+
+  !--------------------------------------------------------
+
+  ! transfer variables when calling this routine
+  REAL,INTENT(IN)                               :: pdtphys ! Pas d'integration pour la physique (seconde)
+  REAL,DIMENSION(klon,klev,nbtr),INTENT(INOUT)  :: tr_seri ! Concentration Traceur [U/KgA]
+  REAL,DIMENSION(klon,klev),INTENT(IN)          :: t_seri  ! Temperature
+  REAL,DIMENSION(klon,klev),INTENT(IN)          :: pplay   ! pression pour le mileu de chaque couche (en Pa)
+  REAL,DIMENSION(klon,klev+1),INTENT(IN)        :: paprs   ! pression pour chaque inter-couche (en Pa)
+  LOGICAL,DIMENSION(klon,klev),INTENT(IN)       :: is_strato ! stratospheric flag
+
+  ! local variables in coagulation routine
+  INTEGER                                       :: i,j,k,nb,ilon,ilev
+  REAL                                          :: dummyso4toso2,rkho2o3,rkoho3,rkso2oh
+  REAL                                          :: rmairdens,rrak0,rrak1,rrate,rreduce
+  
+!--convert SO2 to H2SO4
+  budg_3D_so2_to_h2so4(:,:)=0.0
+  budg_so2_to_h2so4(:)=0.0
+
+  DO ilon=1, klon
+     DO ilev=1, klev
+     !only in the stratosphere
+        IF (is_strato(ilon,ilev)) THEN
+           IF (SO2_lifetime(ilon,ilev).GT.0.0 .AND. SO2_lifetime(ilon,ilev).LT.1.E10) THEN
+              IF (flag_OH_reduced) THEN
+                 !--convert SO2 to H2SO4 (slimane)
+                 ! Reduce OH because of SO2
+                 ! d[OH]/dt = k1[HO2][O] +k2[HO2][O3] +k3[HO2][NO]
+                 ! − (k4[O] +k5[O3] +k6[CO] +ks[SO2])[OH]
+                 ! In steady-state: d[OH]/dt = 0, so the ratio [OH]/[HO2] =
+                 ! (k1[O] +k2[O3] +k3[NO]) / (k4[O] +k5[O3] +k6[CO] +ks[SO2])
+                 ! In the lower and middle stratosphere,
+                 ! [OH]/[HO2] ~(k2[O3] +k3[NO]) / (k5[O3] +k6[CO] +ks[SO2])
+                 ! CO is only important near the tropopause. NO should not dominate over O3.
+                 ! So when consideringthe big terms: [OH]/[HO2] ~ ~ k2[O3] / (k5[O3] +ks[SO2])
+                 ! For c: control run c (no effect of SO2), [OHc]/[HO2c] ~ ~ k2[O3] / k5[O3] = 1/ Rc
+                 ! For p: perturbed run (high SO2), [OHp]/[HO2p] ~ ~ k2[O3] / (k5[O3] +ks[SO2]) =1/Rp
+                 ! If HOx = OH + HO2 = constante,
+                 ! OHc + HO2c = OHp + HO2p
+                 ! OHc (1+Rc) = OHp (1+Rp)
+                 ! OHp = OHc (1+Rc) / (1+Rp)
+                 ! 1+Rc = (k2[O3] +k5[O3] ) / k2[O3]
+                 ! 1+Rp = (k2[O3] +k5[O3] +ks[SO2]) / k2[O3]
+                 ! (1+Rc) / (1+Rp)= (k2[O3] +k5[O3] )/ (k2[O3] +k5[O3] +ks[SO2])
+                 ! OHp = OHc * (k(HO2+OH)*[O3] +k(OH+O3)[O3] ) /
+                 ! (k(HO2+OH)*[O3] +k(OH+O3)[O3] +k(SO2+OH)[SO2])
+                 ! Final: OHp = OHc * (k(HO2+O3)*[O3] +k(OH+O3)[O3] ) /
+                 !  (k(HO2+O3)*[O3] +k(OH+O3)[O3] +k(SO2+OH)[SO2])
+                 
+                 !   latest jpl 2020
+                 rkho2o3 = 1.0e-14*exp( -490./t_seri(ilon,ilev) )
+                 rkoho3 = 1.7e-12*exp( -940./t_seri(ilon,ilev) )
+                 
+                 ! rkso2oh= so2 + oh + m  ->hso3 + m-> h2so4 + m
+                 ! air density M(molecule/cm3) = Pa/(K*1.38e-19)
+                 rmairdens =  pplay(ilon,ilev)/(t_seri(ilon,ilev)*1.38e-19)
+                 ! JPL 2020
+                 rrak0 = 3.3e-31*( (300./t_seri(ilon,ilev))**4.3 )
+                 rrak1 = 1.6e-12
+                 rrate = (rrak0*rmairdens) / ( 1. + rrak0*rmairdens/rrak1 )
+                 rreduce = 1./( 1. + log10((rrak0*rmairdens)/rrak1)**2 )
+                 rkso2oh = rrate*(0.6**rreduce)
+                 
+                 ! O3 (molec/cm3): O3_clim in vmr
+                 rrak0 = O3_clim(ilon,ilev)*rmairdens
+                 ! SO2 (molec/cm3): convert from kg/kgA
+                 rrak1 = tr_seri(ilon,ilev,id_SO2_strat) &
+                      & *pplay(ilon,ilev)/t_seri(ilon,ilev)/RD/1.E6/mSO2mol
+                 
+                 IF (rrak1 .GE. 0.0) THEN
+                    rreduce =( (rkho2o3+rkoho3)*rrak0 + rkso2oh*rrak1 ) / &
+                         (  (rkho2o3+rkoho3)*rrak0 )
+                    ! reduce OH, so extend SO2 lifetime
+                    rreduce = rreduce*SO2_lifetime(ilon,ilev)
+                 ELSE
+                    rreduce =  SO2_lifetime(ilon,ilev)
+                 ENDIF
+                 ! end of IF (rrak1) THEN
+              ELSE
+                 rreduce =  SO2_lifetime(ilon,ilev)
+              ENDIF
+              ! end of IF (flag_OH_reduced) THEN
+              
+              ! Check lifetime rreduce < timestep*1.5 (such as SO2 loss > 0.5*SO2) with exp(-1/1.5)=0.52
+              ! Check lifetime rreduce < timestep*3 (such as SO2 loss > 0.28*SO2) with exp(-1/3)=0.72
+              IF(flag_min_rreduce) THEN
+                 IF (rreduce .LT. (3.*pdtphys)) rreduce = 3.*pdtphys
+              ENDIF
+              budg_3D_so2_to_h2so4(ilon,ilev)=tr_seri(ilon,ilev,id_SO2_strat)*(1.0-exp(-pdtphys/rreduce))
+              tr_seri(ilon,ilev,id_SO2_strat)=tr_seri(ilon,ilev,id_SO2_strat) - budg_3D_so2_to_h2so4(ilon,ilev)
+              tr_seri(ilon,ilev,id_H2SO4_strat)=tr_seri(ilon,ilev,id_H2SO4_strat) + mH2SO4mol/mSO2mol*budg_3D_so2_to_h2so4(ilon,ilev)
+           ENDIF
+           ! IF (SO2_lifetime(ilon,ilev).GT.0.0 .AND. SO2_lifetime(ilon,ilev).LT.1.E10) THEN
+           
+           
+           IF (flag_H2SO4_photolysis) THEN
+              !--convert H2SO4 to SO2 using HCl photolysis (Rinsland et al, 1995)
+              ! 4.6e-8 sec-1: J strato taken from Feierabend, et al., Chem. Phys. Lett., 2006.
+              ! error before:  ...exp(-pdtphys/4.6e-8) so negligible photolysis,
+              !                 should have been exp(-pdtphys*4.6e-8)
+              ! Also: Lane and Kjaergaard: ,J. Phys. Chem. A, 2008
+              ! We find that the dominant photodissociation mechanism of H2SO4
+              ! below 70 km is absorption in the visible region by OH stretching overtone
+              ! transitions, whereas above 70 km, absorption of Lyman-R ...
+              ! In 2D model, 0.3 Rinsland et al, 1995 but Burkholder, Mills and McKeen say 0.016
+              ! JH2SO4=JHCL*0.3   (*0.016 would be too slow)
+              ! test: quick sequential integration for SO2 to H2SO4 and reverse
+              
+              IF (H2SO4_lifetime(ilon,ilev).GT.0.0 .AND. H2SO4_lifetime(ilon,ilev).LT.1.E10) THEN
+                 
+                 rreduce = H2SO4_lifetime(ilon,ilev)
+                 dummyso4toso2 = 0.0
+                 
+                 ! Check lifetime rreduce < timestep*1.5 (such as H2SO4 loss > 0.5*H2SO4) with exp(-1/1.5)=0.52
+                 ! Check lifetime rreduce < timestep*3 (such as H2SO4 loss > 0.28*H2SO4) with exp(-1/3)=0.72
+                 IF(flag_min_rreduce) THEN
+                    IF (rreduce .LT. (3.*pdtphys)) rreduce = 3.*pdtphys
+                 ENDIF
+                 dummyso4toso2 = (mSO2mol/mH2SO4mol)*tr_seri(ilon,ilev,id_H2SO4_strat)*(1.0-exp(-pdtphys/rreduce))
+                 budg_3D_so2_to_h2so4(ilon,ilev) = budg_3D_so2_to_h2so4(ilon,ilev) + dummyso4toso2
+                 tr_seri(ilon,ilev,id_SO2_strat)=tr_seri(ilon,ilev,id_SO2_strat) + dummyso4toso2
+                 tr_seri(ilon,ilev,id_H2SO4_strat)=tr_seri(ilon,ilev,id_H2SO4_strat) - (mH2SO4mol/mSO2mol)*dummyso4toso2
+              ENDIF
+              ! IF (H2SO4_lifetime(ilon,ilev).GT.0.0 .AND. H2SO4_lifetime(ilon,ilev).LT.1.E10) THEN
+           ENDIF
+           ! end of IF (flag_H2SO4_photolysis) THEN
+           
+           !convert budget from kg(SO2)/kgA to kg(S)/m2/layer/s for saving as diagnostic
+           budg_3D_so2_to_h2so4(ilon,ilev)=budg_3D_so2_to_h2so4(ilon,ilev)*mSatom/mSO2mol* &
+                (paprs(ilon,ilev)-paprs(ilon,ilev+1))/RG/pdtphys
+           budg_so2_to_h2so4(ilon)=budg_so2_to_h2so4(ilon)+budg_3D_so2_to_h2so4(ilon,ilev)
+        ENDIF
+        ! IF (is_strato(ilon,ilev)) THEN
+     ENDDO ! DO (klev)
+  ENDDO ! DO (klon)
+  
+END SUBROUTINE SO2_TO_H2SO4
Index: DZ6/trunk/libf/phylmd/StratAer/stratH2O_methox.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/StratAer/stratH2O_methox.F90	(revision 5267)
+++ 	(revision )
@@ -1,161 +1,0 @@
-!
-! $Id: stratH2O_methox.F90 3677 2020-05-06 15:18:32Z oboucher $
-!
-SUBROUTINE stratH2O_methox(debutphy,paprs,dq_ch4mmr)
-!
-! output: CH4VMR in MMR/s (mass mixing ratio/s or kg H2O/kg air/s)
-
-  USE netcdf95, ONLY: nf95_close, nf95_gw_var, nf95_inq_dimid, & 
-                      nf95_inq_varid, nf95_inquire_dimension, nf95_open
-  USE netcdf, ONLY: nf90_get_var, nf90_noerr, nf90_nowrite
-
-  USE mod_grid_phy_lmdz
-  USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
-  USE mod_phys_lmdz_omp_data, ONLY :  is_omp_root
-
-  USE mod_phys_lmdz_para 
-  USE dimphy
-  USE phys_cal_mod, ONLY : mth_cur
-  USE infotrac_phy
-  USE aerophys
-  USE yomcst_mod_h
-  USE strataer_local_var_mod, ONLY : flag_newclim_file
-  
-  IMPLICIT NONE
-  
-  include "dimensions.h"
-  
-! Input variables
-  REAL paprs(klon,klev+1)
-  LOGICAL, INTENT(IN) :: debutphy   ! flag for first physiq step
-! Output variables
-! tendency buffer used in add_phys_tend subroutine (in physiq_mod)
-  REAL, INTENT(INOUT), DIMENSION(klon,klev)  :: dq_ch4mmr
-  
-! Local variables
-  INTEGER n_lat   ! number of latitudes in the input data
-  INTEGER n_lon   ! number of longitudes in the input data
-  INTEGER, SAVE :: n_lev   ! number of levels in the input data
-!$OMP THREADPRIVATE(n_lev)
-  INTEGER n_mth   ! number of months in the input data
-  INTEGER, SAVE :: mth_pre
-!$OMP THREADPRIVATE(mth_pre)
-  
-! Reconstitutes fields
-  REAL paprs_glo(klon_glo,klev+1)
-  
-  REAL, ALLOCATABLE:: latitude(:)
-! (of input data sorted in strictly ascending order)
-  REAL, ALLOCATABLE:: longitude(:)
-! (of input data sorted in strictly ascending order)
-  REAL, ALLOCATABLE:: time(:)
-! (of input data sorted in strictly ascending order)
-  REAL, ALLOCATABLE:: lev(:)
-! levels of input data
-  
-! Stratospheric H2O source from CH4 oxidation from fixed climatos
-! (H2O production in VMR/sec)
-  REAL, ALLOCATABLE :: CH4RVMR_in(:, :, :, :)
-  REAL, ALLOCATABLE :: CH4RVMR_mth(:, :, :)
-  REAL, ALLOCATABLE :: CH4RVMR_tmp(:, :)
-  REAL CH4RVMR_glo(klon_glo,klev)
-!
-  INTEGER i, k, kk, j
-  
-! For NetCDF:
-  INTEGER ncid_in  ! IDs for input files
-  INTEGER varid, ncerr
-    
-  INTEGER, PARAMETER :: lev_input=17
-!--pressure at interfaces of input data (in Pa)
-  REAL, DIMENSION(lev_input+1), PARAMETER ::          & 
-                    paprs_input=(/                    &
-  1.00000002e+05,   6.06530673e+04,   3.67879449e+04, &
-  2.23130165e+04,   1.35335286e+04,   8.20850004e+03, &
-  4.97870695e+03,   3.01973841e+03,   1.83156393e+03, &
-  1.11089968e+03,   6.73794715e+02,   4.08677153e+02, &
-  2.47875223e+02,   1.50343923e+02,   9.11881985e+01, &
-  5.53084382e+01,   3.35462635e+01,   0.0           /)
-!
-  
-  IF (debutphy .OR. mth_cur .NE. mth_pre) THEN
-     
-!--preparation of global fields
-     CALL gather(paprs, paprs_glo)
-     
-     IF (is_mpi_root.AND.is_omp_root) THEN
-        
-        print *,'In stratH2O_methox read file: ch4r_annual_lmdz.nc'
-        
-        !--reading strat. H2O source (CH4 oxidation) files
-        CALL nf95_open("ch4r_annual_lmdz.nc", nf90_nowrite, ncid_in)
-        
-        CALL  nf95_inq_varid(ncid_in, "LEV", varid)
-        CALL nf95_gw_var(ncid_in, varid, lev)
-        n_lev = size(lev)
-        
-        CALL nf95_inq_varid(ncid_in, "LAT", varid)
-        CALL nf95_gw_var(ncid_in, varid, latitude)
-        n_lat = size(latitude)
-        
-        CALL nf95_inq_varid(ncid_in, "LON", varid)
-        CALL nf95_gw_var(ncid_in, varid, longitude)
-        n_lon = size(longitude)
-        
-        CALL nf95_inq_varid(ncid_in, "TIME", varid)
-        CALL nf95_gw_var(ncid_in, varid, time)
-        n_mth = size(time)
-        
-        IF (.NOT.ALLOCATED(CH4RVMR_in)) ALLOCATE(CH4RVMR_in(n_lon, n_lat, n_lev, n_mth))
-        
-        CALL nf95_inq_varid(ncid_in, "CH4RVMR", varid)
-        ncerr = nf90_get_var(ncid_in, varid, CH4RVMR_in)
-        print *,'code erreur CH4RVMR=', ncerr, varid
-        
-        CALL nf95_close(ncid_in)
-        
-        IF (.NOT.ALLOCATED(CH4RVMR_mth)) ALLOCATE(CH4RVMR_mth(n_lon, n_lat, n_lev))
-        IF (.NOT.ALLOCATED(CH4RVMR_tmp)) ALLOCATE(CH4RVMR_tmp(klon_glo, n_lev))
-        
-        !---select the correct month,
-        !---correct latitudinal order,convert input from volume mixing ratio to mass mixing ratio
-        DO j=1,n_lat
-           ! convert VMR/s in MMR/s (mass mixing ratio/s or kg H2O/kg air/s)
-           ! x2 because CH4->2*H2O
-           CH4RVMR_mth(:,j,:) = 2*CH4RVMR_in(:,n_lat+1-j,:,mth_cur)*mH2Omol/mAIRmol
-        ENDDO
-        
-        !---reduce to a klon_glo grid but keep the levels
-        CALL grid2dTo1d_glo(CH4RVMR_mth,CH4RVMR_tmp)
-        
-        !---regrid weighted climatologies
-        DO i=1, klon_glo
-           DO k=1, klev
-              
-              CH4RVMR_glo(i,k)=0.0
-              
-              DO kk=1, n_lev
-                 !
-                 CH4RVMR_glo(i,k)=CH4RVMR_glo(i,k)+ &
-                      MAX(0.0,MIN(paprs_glo(i,k),paprs_input(kk)) &
-                      -MAX(paprs_glo(i,k+1),paprs_input(kk+1))) &
-                      *CH4RVMR_tmp(i,kk)/(paprs_glo(i,k)-paprs_glo(i,k+1))
-              ENDDO ! kk loop
-           ENDDO ! k loop
-        ENDDO ! i loop
-     ENDIF !--is_mpi_root and is_omp_root
-     
-     !--keep memory of previous month
-     mth_pre=mth_cur
-     
-     !--scatter global fields around
-     CALL scatter(CH4RVMR_glo, dq_ch4mmr)
-     
-     IF (is_mpi_root.AND.is_omp_root) THEN
-        DEALLOCATE(CH4RVMR_in,CH4RVMR_mth,CH4RVMR_tmp)
-     ENDIF !--is_mpi_root and is_omp_root
-  ENDIF ! debutphy.OR.new month
-  
-  RETURN
-  
-END SUBROUTINE stratH2O_methox
Index: /LMDZ6/trunk/libf/phylmd/StratAer/stratH2O_methox.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/StratAer/stratH2O_methox.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/StratAer/stratH2O_methox.f90	(revision 5268)
@@ -0,0 +1,161 @@
+!
+! $Id: stratH2O_methox.F90 3677 2020-05-06 15:18:32Z oboucher $
+!
+SUBROUTINE stratH2O_methox(debutphy,paprs,dq_ch4mmr)
+!
+! output: CH4VMR in MMR/s (mass mixing ratio/s or kg H2O/kg air/s)
+
+  USE netcdf95, ONLY: nf95_close, nf95_gw_var, nf95_inq_dimid, & 
+                      nf95_inq_varid, nf95_inquire_dimension, nf95_open
+  USE netcdf, ONLY: nf90_get_var, nf90_noerr, nf90_nowrite
+
+  USE mod_grid_phy_lmdz
+  USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+  USE mod_phys_lmdz_omp_data, ONLY :  is_omp_root
+
+  USE mod_phys_lmdz_para 
+  USE dimphy
+  USE phys_cal_mod, ONLY : mth_cur
+  USE infotrac_phy
+  USE aerophys
+  USE yomcst_mod_h
+  USE strataer_local_var_mod, ONLY : flag_newclim_file
+  
+  IMPLICIT NONE
+  
+  include "dimensions.h"
+  
+! Input variables
+  REAL paprs(klon,klev+1)
+  LOGICAL, INTENT(IN) :: debutphy   ! flag for first physiq step
+! Output variables
+! tendency buffer used in add_phys_tend subroutine (in physiq_mod)
+  REAL, INTENT(INOUT), DIMENSION(klon,klev)  :: dq_ch4mmr
+  
+! Local variables
+  INTEGER n_lat   ! number of latitudes in the input data
+  INTEGER n_lon   ! number of longitudes in the input data
+  INTEGER, SAVE :: n_lev   ! number of levels in the input data
+!$OMP THREADPRIVATE(n_lev)
+  INTEGER n_mth   ! number of months in the input data
+  INTEGER, SAVE :: mth_pre
+!$OMP THREADPRIVATE(mth_pre)
+  
+! Reconstitutes fields
+  REAL paprs_glo(klon_glo,klev+1)
+  
+  REAL, ALLOCATABLE:: latitude(:)
+! (of input data sorted in strictly ascending order)
+  REAL, ALLOCATABLE:: longitude(:)
+! (of input data sorted in strictly ascending order)
+  REAL, ALLOCATABLE:: time(:)
+! (of input data sorted in strictly ascending order)
+  REAL, ALLOCATABLE:: lev(:)
+! levels of input data
+  
+! Stratospheric H2O source from CH4 oxidation from fixed climatos
+! (H2O production in VMR/sec)
+  REAL, ALLOCATABLE :: CH4RVMR_in(:, :, :, :)
+  REAL, ALLOCATABLE :: CH4RVMR_mth(:, :, :)
+  REAL, ALLOCATABLE :: CH4RVMR_tmp(:, :)
+  REAL CH4RVMR_glo(klon_glo,klev)
+!
+  INTEGER i, k, kk, j
+  
+! For NetCDF:
+  INTEGER ncid_in  ! IDs for input files
+  INTEGER varid, ncerr
+    
+  INTEGER, PARAMETER :: lev_input=17
+!--pressure at interfaces of input data (in Pa)
+  REAL, DIMENSION(lev_input+1), PARAMETER ::          & 
+                    paprs_input=(/                    &
+  1.00000002e+05,   6.06530673e+04,   3.67879449e+04, &
+  2.23130165e+04,   1.35335286e+04,   8.20850004e+03, &
+  4.97870695e+03,   3.01973841e+03,   1.83156393e+03, &
+  1.11089968e+03,   6.73794715e+02,   4.08677153e+02, &
+  2.47875223e+02,   1.50343923e+02,   9.11881985e+01, &
+  5.53084382e+01,   3.35462635e+01,   0.0           /)
+!
+  
+  IF (debutphy .OR. mth_cur .NE. mth_pre) THEN
+     
+!--preparation of global fields
+     CALL gather(paprs, paprs_glo)
+     
+     IF (is_mpi_root.AND.is_omp_root) THEN
+        
+        print *,'In stratH2O_methox read file: ch4r_annual_lmdz.nc'
+        
+        !--reading strat. H2O source (CH4 oxidation) files
+        CALL nf95_open("ch4r_annual_lmdz.nc", nf90_nowrite, ncid_in)
+        
+        CALL  nf95_inq_varid(ncid_in, "LEV", varid)
+        CALL nf95_gw_var(ncid_in, varid, lev)
+        n_lev = size(lev)
+        
+        CALL nf95_inq_varid(ncid_in, "LAT", varid)
+        CALL nf95_gw_var(ncid_in, varid, latitude)
+        n_lat = size(latitude)
+        
+        CALL nf95_inq_varid(ncid_in, "LON", varid)
+        CALL nf95_gw_var(ncid_in, varid, longitude)
+        n_lon = size(longitude)
+        
+        CALL nf95_inq_varid(ncid_in, "TIME", varid)
+        CALL nf95_gw_var(ncid_in, varid, time)
+        n_mth = size(time)
+        
+        IF (.NOT.ALLOCATED(CH4RVMR_in)) ALLOCATE(CH4RVMR_in(n_lon, n_lat, n_lev, n_mth))
+        
+        CALL nf95_inq_varid(ncid_in, "CH4RVMR", varid)
+        ncerr = nf90_get_var(ncid_in, varid, CH4RVMR_in)
+        print *,'code erreur CH4RVMR=', ncerr, varid
+        
+        CALL nf95_close(ncid_in)
+        
+        IF (.NOT.ALLOCATED(CH4RVMR_mth)) ALLOCATE(CH4RVMR_mth(n_lon, n_lat, n_lev))
+        IF (.NOT.ALLOCATED(CH4RVMR_tmp)) ALLOCATE(CH4RVMR_tmp(klon_glo, n_lev))
+        
+        !---select the correct month,
+        !---correct latitudinal order,convert input from volume mixing ratio to mass mixing ratio
+        DO j=1,n_lat
+           ! convert VMR/s in MMR/s (mass mixing ratio/s or kg H2O/kg air/s)
+           ! x2 because CH4->2*H2O
+           CH4RVMR_mth(:,j,:) = 2*CH4RVMR_in(:,n_lat+1-j,:,mth_cur)*mH2Omol/mAIRmol
+        ENDDO
+        
+        !---reduce to a klon_glo grid but keep the levels
+        CALL grid2dTo1d_glo(CH4RVMR_mth,CH4RVMR_tmp)
+        
+        !---regrid weighted climatologies
+        DO i=1, klon_glo
+           DO k=1, klev
+              
+              CH4RVMR_glo(i,k)=0.0
+              
+              DO kk=1, n_lev
+                 !
+                 CH4RVMR_glo(i,k)=CH4RVMR_glo(i,k)+ &
+                      MAX(0.0,MIN(paprs_glo(i,k),paprs_input(kk)) &
+                      -MAX(paprs_glo(i,k+1),paprs_input(kk+1))) &
+                      *CH4RVMR_tmp(i,kk)/(paprs_glo(i,k)-paprs_glo(i,k+1))
+              ENDDO ! kk loop
+           ENDDO ! k loop
+        ENDDO ! i loop
+     ENDIF !--is_mpi_root and is_omp_root
+     
+     !--keep memory of previous month
+     mth_pre=mth_cur
+     
+     !--scatter global fields around
+     CALL scatter(CH4RVMR_glo, dq_ch4mmr)
+     
+     IF (is_mpi_root.AND.is_omp_root) THEN
+        DEALLOCATE(CH4RVMR_in,CH4RVMR_mth,CH4RVMR_tmp)
+     ENDIF !--is_mpi_root and is_omp_root
+  ENDIF ! debutphy.OR.new month
+  
+  RETURN
+  
+END SUBROUTINE stratH2O_methox
Index: DZ6/trunk/libf/phylmd/StratAer/strataer_emiss_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/StratAer/strataer_emiss_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,259 +1,0 @@
-MODULE strataer_emiss_mod
-  ! This module contains information about strato microphysic model emission parameters
-
-CONTAINS
-
-  SUBROUTINE strataer_emiss_init()
-
-    USE strataer_local_var_mod
-    USE ioipsl_getin_p_mod, ONLY : getin_p
-    USE print_control_mod, ONLY : lunout
-    USE mod_phys_lmdz_para, ONLY : is_master
-
-    ! Local variables
-    INTEGER                  :: ispec
-
-    WRITE(lunout,*) 'IN STRATAER_EMISS INIT WELCOME!'
-
-    IF (flag_emit.EQ.1 .OR. flag_emit.EQ.4) THEN ! Volcano
-       CALL getin_p('nErupt',nErupt) !eruption nb
-       CALL getin_p('injdur',injdur) !injection duration
-
-       IF (flag_emit==1) THEN
-          CALL getin_p('nAerErupt', nAerErupt) !sulfur aer nb
-       ELSEIF (flag_emit==4) THEN
-          CALL getin_p('nSpeciesErupt', nSpeciesErupt) !chimical species nb
-       ENDIF
-
-       IF (nErupt.GT.0) THEN
-          ALLOCATE(year_emit_vol(nErupt),mth_emit_vol(nErupt),day_emit_vol(nErupt))
-          year_emit_vol=0 ; mth_emit_vol=0 ; day_emit_vol=0
-          ALLOCATE(altemiss_vol(nErupt),sigma_alt_vol(nErupt))
-          ALLOCATE(xlat_min_vol(nErupt),xlon_min_vol(nErupt))
-          ALLOCATE(xlat_max_vol(nErupt),xlon_max_vol(nErupt))
-          altemiss_vol=0. ; sigma_alt_vol=0.
-          xlon_min_vol=0. ; xlon_max_vol=0.
-          xlat_min_vol=0. ; xlat_max_vol=0.
-          ! injection params (dates, loc, injections params)
-          CALL getin_p('year_emit_vol',year_emit_vol)
-          CALL getin_p('mth_emit_vol',mth_emit_vol)
-          CALL getin_p('day_emit_vol',day_emit_vol)
-          CALL getin_p('altemiss_vol',altemiss_vol)
-          CALL getin_p('sigma_alt_vol',sigma_alt_vol)
-          CALL getin_p('xlon_min_vol',xlon_min_vol)
-          CALL getin_p('xlon_max_vol',xlon_max_vol)
-          CALL getin_p('xlat_min_vol',xlat_min_vol)
-          CALL getin_p('xlat_max_vol',xlat_max_vol)
-          IF (flag_emit==1) THEN
-             ALLOCATE(m_sulf_emiss_vol(nErupt))
-             ALLOCATE(m_aer_emiss_vol(nErupt,nAerErupt))
-             m_aer_emiss_vol=0. ; m_sulf_emiss_vol=0.
-             IF (ok_qemiss) then
-                ALLOCATE(m_H2O_emiss_vol(nErupt))
-                ALLOCATE(m_H2O_emiss_vol_daily(nErupt))
-                !                ALLOCATE(d_q_emiss(klon,klev))
-                ALLOCATE(budg_emi(klon,nAerErupt+1))
-                m_H2O_emiss_vol(:)=0.
-                m_H2O_emiss_vol_daily(:)=0.
-                !                d_q_emiss(:,:)=0.
-             ELSE
-                ALLOCATE(budg_emi(klon,nAerErupt))
-             ENDIF
-             budg_emi(:,:)=0.
-          ELSEIF (flag_emit==4) THEN
-             ALLOCATE(m_Chlore_emiss_vol(nErupt))
-             ALLOCATE(id_HCl)
-             ALLOCATE(m_Brome_emiss_vol(nErupt))
-             ALLOCATE(id_HBr)
-             ALLOCATE(id_species(nSpeciesErupt))
-             id_species = 0
-             ALLOCATE(m_species_emiss_vol(nErupt,nSpeciesErupt))
-             m_species_emiss_vol=0.
-             ALLOCATE(m_NOx_emiss_vol(nErupt))
-             ALLOCATE(m_H2O_emiss_vol(nErupt))
-             m_Chlore_emiss_vol=0. ; m_Brome_emiss_vol=0.
-             m_NOx_emiss_vol=0. ; m_H2O_emiss_vol=0.
-             ALLOCATE(id_NOx)
-             ALLOCATE(id_H2O)
-             ALLOCATE(budg_emi(klon,nSpeciesErupt))
-             budg_emi(:,:)=0.
-          ENDIF
-       ELSE
-          WRITE(lunout,*) 'ERROR : Using flag_emit=1 or 4 (ie Volcanic eruption) but nErupt (',nErupt,') <=0 !'
-          CALL abort_physic('strataer_emiss_mod', &
-               'No eruption define in physiq_def (nErupt=0). Add at one eruption or use background condition.',1)
-       ENDIF ! fin if nerupt
-
-       IF (flag_emit==1) THEN
-          CALL getin_p('m_sulf_emiss_vol',m_sulf_emiss_vol)
-          if (ok_qemiss) then
-             CALL getin_p('m_H2O_emiss_vol',m_H2O_emiss_vol)
-          endif
-       ELSEIF (flag_emit==4) THEN
-          CALL getin_p('id_species',id_species)
-          CALL getin_p('m_Chlore_emiss_vol',m_Chlore_emiss_vol)
-          CALL getin_p('id_HCl',id_HCl)
-          CALL getin_p('m_Brome_emiss_vol',m_Brome_emiss_vol)
-          CALL getin_p('id_HBr',id_HBr)
-          CALL getin_p('m_NOx_emiss_vol',m_NOx_emiss_vol)
-          CALL getin_p('id_NOx',id_NOx)
-          CALL getin_p('m_H2O_emiss_vol',m_H2O_emiss_vol)
-          CALL getin_p('id_H2O',id_H2O)
-       ENDIF
-
-    ELSEIF (flag_emit == 2) THEN ! SAI
-       CALL getin_p('m_aer_emiss_sai',m_aer_emiss_sai)
-       CALL getin_p('altemiss_sai',altemiss_sai)
-       CALL getin_p('sigma_alt_sai',sigma_alt_sai)
-       CALL getin_p('xlat_sai',xlat_sai)
-       CALL getin_p('xlon_sai',xlon_sai)
-       CALL getin_p('year_emit_sai_start',year_emit_sai_start)
-       CALL getin_p('year_emit_sai_end',year_emit_sai_end)
-       CALL getin_p('mth_emit_sai_start',mth_emit_sai_start)
-       CALL getin_p('mth_emit_sai_end',mth_emit_sai_end)
-       CALL getin_p('day_emit_sai_start',day_emit_sai_start)
-       CALL getin_p('day_emit_sai_end',day_emit_sai_end)
-
-    ELSEIF (flag_emit == 3) THEN ! SAI between latitudes
-       CALL getin_p('m_aer_emiss_sai',m_aer_emiss_sai)
-       CALL getin_p('altemiss_sai',altemiss_sai)
-       CALL getin_p('sigma_alt_sai',sigma_alt_sai)
-       CALL getin_p('xlon_sai',xlon_sai)
-       CALL getin_p('xlat_max_sai',xlat_max_sai)
-       CALL getin_p('xlat_min_sai',xlat_min_sai)
-    ENDIF
-
-    IF (flag_emit == 1) THEN
-       DO ispec=1,nAerErupt
-          m_aer_emiss_vol(:,ispec) = m_sulf_emiss_vol(:)
-       ENDDO
-    ELSEIF (flag_emit== 4) THEN
-       DO ispec=1,nSpeciesErupt
-          IF(id_species(ispec) == id_HCl) THEN
-             m_species_emiss_vol(:,ispec) = m_Chlore_emiss_vol(:)
-          ENDIF
-          IF (id_species(ispec) == id_HBr) THEN
-             m_species_emiss_vol(:,ispec) = m_Brome_emiss_vol(:)
-          ENDIF
-          IF (id_species(ispec) == id_NOx) THEN
-             m_species_emiss_vol(:,ispec) = m_NOx_emiss_vol(:)
-          ENDIF
-          IF (id_species(ispec) == id_H2O) THEN
-             m_species_emiss_vol(:,ispec) = m_H2O_emiss_vol(:)
-          ENDIF
-       ENDDO
-    ENDIF
-
-    !============= Injection ponderation =============
-    IF (flag_emit > 0) THEN
-       CALL strataer_ponde_init
-       WRITE(lunout,*) 'IN STRATAER INIT : ponde_lonlat_vol',ponde_lonlat_vol
-    ENDIF
-
-    !============= Print params =============
-    IF (is_master) THEN
-       IF (nErupt > 0) then
-          if (flag_emit == 1 .OR. flag_emit == 4) THEN
-             WRITE(lunout,*) 'IN STRATAER nErupt: ',nErupt
-             WRITE(lunout,*) 'IN STRATAER injdur: ',injdur
-             WRITE(lunout,*) 'IN STRATAER nAerErupt: ',nAerErupt
-
-             WRITE(lunout,*) 'IN STRATAER : year_emit_vol',year_emit_vol
-             WRITE(lunout,*) 'IN STRATAER : mth_emit_vol',mth_emit_vol
-             WRITE(lunout,*) 'IN STRATAER : day_emit_vol',day_emit_vol
-             WRITE(lunout,*) 'IN STRATAER : altemiss_vol',altemiss_vol
-             WRITE(lunout,*) 'IN STRATAER : sigma_alt_vol',sigma_alt_vol
-             WRITE(lunout,*) 'IN STRATAER : xlat_min_vol',xlat_min_vol
-             WRITE(lunout,*) 'IN STRATAER : xlat_max_vol',xlat_max_vol
-             WRITE(lunout,*) 'IN STRATAER : xlon_min_vol',xlon_min_vol
-             WRITE(lunout,*) 'IN STRATAER : xlon_max_vol',xlon_max_vol
-             IF (flag_emit==1) THEN
-                WRITE(lunout,*) 'IN STRATAEREMISS : m_sulf_emiss_vol',m_sulf_emiss_vol
-                WRITE(lunout,*) 'IN STRATAER : m_aer_emiss_vol',m_aer_emiss_vol
-                IF (ok_qemiss) then
-                   WRITE(lunout,*) 'IN STRATAEREMISS : m_H2O_emiss_vol',m_H2O_emiss_vol
-                ENDIF
-             ENDIF
-          ELSEIF (flag_emit == 2) THEN
-             WRITE(lunout,*) 'IN STRATAER : m_aer_emiss_sai',m_aer_emiss_sai
-             WRITE(lunout,*) 'IN STRATAER : altemiss_sai',altemiss_sai
-             WRITE(lunout,*) 'IN STRATAER : sigma_alt_sai',sigma_alt_sai
-             WRITE(lunout,*) 'IN STRATAER : xlat_sai',xlat_sai
-             WRITE(lunout,*) 'IN STRATAER : xlon_sai',xlon_sai
-          ELSEIF (flag_emit == 3) THEN
-             WRITE(lunout,*) 'IN STRATAER : m_aer_emiss_sai',m_aer_emiss_sai
-             WRITE(lunout,*) 'IN STRATAER : altemiss_sai',altemiss_sai
-             WRITE(lunout,*) 'IN STRATAER : sigma_alt_sai',sigma_alt_sai
-             WRITE(lunout,*) 'IN STRATAER : year_emit_sai start/end',year_emit_sai_start,year_emit_sai_end
-             WRITE(lunout,*) 'IN STRATAER : mth_emit_sai start/end',mth_emit_sai_start,mth_emit_sai_end
-             WRITE(lunout,*) 'IN STRATAER : day_emit_sai start/end',day_emit_sai_start,day_emit_sai_end
-             WRITE(lunout,*) 'IN STRATAER : xlat_min_sai',xlat_min_sai
-             WRITE(lunout,*) 'IN STRATAER : xlat_max_sai',xlat_max_sai
-             WRITE(lunout,*) 'IN STRATAER : xlon_sai',xlon_sai
-          ENDIF
-          IF(flag_emit == 4) THEN
-             WRITE(lunout,*) 'IN STRATAER : nSpeciesErupt: ',nSpeciesErupt
-             WRITE(lunout,*) 'IN STRATAER : id_species = ',id_species
-             WRITE(lunout,*) 'IN STRATAER : id_HCl = ',id_HCl
-             WRITE(lunout,*) 'IN STRATAER : id_HBr = ',id_HBr
-             WRITE(lunout,*) 'IN STRATAER : id_NOx = ',id_NOx
-             WRITE(lunout,*) 'IN STRATAER : id_H2O = ',id_H2O
-             WRITE(lunout,*) 'IN STRATAER : m_Chlore_emiss_vol = ',m_Chlore_emiss_vol
-             WRITE(lunout,*) 'IN STRATAER : m_Brome_emiss_vol = ',m_Brome_emiss_vol
-             WRITE(lunout,*) 'IN STRATAER : m_NOx_emiss_vol = ',m_NOx_emiss_vol
-             WRITE(lunout,*) 'IN STRATAER : m_H2O_emiss_vol = ',m_H2O_emiss_vol
-          ENDIF
-       endif
-    ENDIF ! if master
-
-    WRITE(lunout,*) 'IN STRATAER_EMISS END'
-  END SUBROUTINE strataer_emiss_init
-
-  ! Compute the ponderation to applicate in each grid point for all eruptions and init
-  ! dlat & dlon variables
-  SUBROUTINE strataer_ponde_init()
-
-    USE regular_lonlat_mod, ONLY: lon_reg, lat_reg
-    USE dimphy, ONLY: klon
-    USE mod_grid_phy_lmdz, ONLY: nbp_lat, nbp_lon
-    USE print_control_mod, ONLY : lunout
-    USE strataer_local_var_mod
-
-    INCLUDE "YOMCST.h"  !--RPI
-
-    ! local var
-    REAL                :: lat_reg_deg,lon_reg_deg ! lat and lon of grid points in degree
-    INTEGER             :: ieru, i, j
-
-    ALLOCATE(ponde_lonlat_vol(nErupt))
-
-    !Compute lon/lat ponderation for injection
-    dlat=180./2./FLOAT(nbp_lat)   ! d latitude in degree
-    dlon=360./2./FLOAT(nbp_lon)   ! d longitude in degree
-    WRITE(lunout,*) 'IN STRATAER_INIT dlat=',dlat,'dlon=',dlon
-    WRITE(lunout,*) 'IN STRATAER_INIT nErupt=',nErupt
-    WRITE(lunout,*) 'IN STRATAER_INIT xlat_min=',xlat_min_vol,'xlat_max=',xlat_max_vol
-    WRITE(lunout,*) 'IN STRATAER_INIT xlon_min=',xlon_min_vol,'xlon_max=',xlon_max_vol
-
-    DO ieru=1, nErupt
-       ponde_lonlat_vol(ieru) = 0
-       DO i=1,nbp_lon
-          lon_reg_deg = lon_reg(i)*180./RPI
-          DO j=1,nbp_lat
-             lat_reg_deg = lat_reg(j)*180./RPI
-             IF  ( lat_reg_deg.GE.xlat_min_vol(ieru)-dlat .AND. lat_reg_deg.LT.xlat_max_vol(ieru)+dlat .AND. &
-                  lon_reg_deg.GE.xlon_min_vol(ieru)-dlon .AND. lon_reg_deg.LT.xlon_max_vol(ieru)+dlon ) THEN
-                ponde_lonlat_vol(ieru) = ponde_lonlat_vol(ieru) + 1
-             ENDIF
-          ENDDO
-       ENDDO
-       IF(ponde_lonlat_vol(ieru) == 0) THEN
-          WRITE(lunout,*) 'STRATAER_INIT ERROR: no grid point found for eruption ieru=',ieru
-       ENDIF
-    ENDDO !ieru
-
-    WRITE(lunout,*) 'IN STRATAER_PONDE_INIT ponde_lonlat: ', ponde_lonlat_vol
-
-  END SUBROUTINE strataer_ponde_init
-
-END MODULE strataer_emiss_mod
Index: /LMDZ6/trunk/libf/phylmd/StratAer/strataer_emiss_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/StratAer/strataer_emiss_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/StratAer/strataer_emiss_mod.f90	(revision 5268)
@@ -0,0 +1,259 @@
+MODULE strataer_emiss_mod
+  ! This module contains information about strato microphysic model emission parameters
+
+CONTAINS
+
+  SUBROUTINE strataer_emiss_init()
+
+    USE strataer_local_var_mod
+    USE ioipsl_getin_p_mod, ONLY : getin_p
+    USE print_control_mod, ONLY : lunout
+    USE mod_phys_lmdz_para, ONLY : is_master
+
+    ! Local variables
+    INTEGER                  :: ispec
+
+    WRITE(lunout,*) 'IN STRATAER_EMISS INIT WELCOME!'
+
+    IF (flag_emit.EQ.1 .OR. flag_emit.EQ.4) THEN ! Volcano
+       CALL getin_p('nErupt',nErupt) !eruption nb
+       CALL getin_p('injdur',injdur) !injection duration
+
+       IF (flag_emit==1) THEN
+          CALL getin_p('nAerErupt', nAerErupt) !sulfur aer nb
+       ELSEIF (flag_emit==4) THEN
+          CALL getin_p('nSpeciesErupt', nSpeciesErupt) !chimical species nb
+       ENDIF
+
+       IF (nErupt.GT.0) THEN
+          ALLOCATE(year_emit_vol(nErupt),mth_emit_vol(nErupt),day_emit_vol(nErupt))
+          year_emit_vol=0 ; mth_emit_vol=0 ; day_emit_vol=0
+          ALLOCATE(altemiss_vol(nErupt),sigma_alt_vol(nErupt))
+          ALLOCATE(xlat_min_vol(nErupt),xlon_min_vol(nErupt))
+          ALLOCATE(xlat_max_vol(nErupt),xlon_max_vol(nErupt))
+          altemiss_vol=0. ; sigma_alt_vol=0.
+          xlon_min_vol=0. ; xlon_max_vol=0.
+          xlat_min_vol=0. ; xlat_max_vol=0.
+          ! injection params (dates, loc, injections params)
+          CALL getin_p('year_emit_vol',year_emit_vol)
+          CALL getin_p('mth_emit_vol',mth_emit_vol)
+          CALL getin_p('day_emit_vol',day_emit_vol)
+          CALL getin_p('altemiss_vol',altemiss_vol)
+          CALL getin_p('sigma_alt_vol',sigma_alt_vol)
+          CALL getin_p('xlon_min_vol',xlon_min_vol)
+          CALL getin_p('xlon_max_vol',xlon_max_vol)
+          CALL getin_p('xlat_min_vol',xlat_min_vol)
+          CALL getin_p('xlat_max_vol',xlat_max_vol)
+          IF (flag_emit==1) THEN
+             ALLOCATE(m_sulf_emiss_vol(nErupt))
+             ALLOCATE(m_aer_emiss_vol(nErupt,nAerErupt))
+             m_aer_emiss_vol=0. ; m_sulf_emiss_vol=0.
+             IF (ok_qemiss) then
+                ALLOCATE(m_H2O_emiss_vol(nErupt))
+                ALLOCATE(m_H2O_emiss_vol_daily(nErupt))
+                !                ALLOCATE(d_q_emiss(klon,klev))
+                ALLOCATE(budg_emi(klon,nAerErupt+1))
+                m_H2O_emiss_vol(:)=0.
+                m_H2O_emiss_vol_daily(:)=0.
+                !                d_q_emiss(:,:)=0.
+             ELSE
+                ALLOCATE(budg_emi(klon,nAerErupt))
+             ENDIF
+             budg_emi(:,:)=0.
+          ELSEIF (flag_emit==4) THEN
+             ALLOCATE(m_Chlore_emiss_vol(nErupt))
+             ALLOCATE(id_HCl)
+             ALLOCATE(m_Brome_emiss_vol(nErupt))
+             ALLOCATE(id_HBr)
+             ALLOCATE(id_species(nSpeciesErupt))
+             id_species = 0
+             ALLOCATE(m_species_emiss_vol(nErupt,nSpeciesErupt))
+             m_species_emiss_vol=0.
+             ALLOCATE(m_NOx_emiss_vol(nErupt))
+             ALLOCATE(m_H2O_emiss_vol(nErupt))
+             m_Chlore_emiss_vol=0. ; m_Brome_emiss_vol=0.
+             m_NOx_emiss_vol=0. ; m_H2O_emiss_vol=0.
+             ALLOCATE(id_NOx)
+             ALLOCATE(id_H2O)
+             ALLOCATE(budg_emi(klon,nSpeciesErupt))
+             budg_emi(:,:)=0.
+          ENDIF
+       ELSE
+          WRITE(lunout,*) 'ERROR : Using flag_emit=1 or 4 (ie Volcanic eruption) but nErupt (',nErupt,') <=0 !'
+          CALL abort_physic('strataer_emiss_mod', &
+               'No eruption define in physiq_def (nErupt=0). Add at one eruption or use background condition.',1)
+       ENDIF ! fin if nerupt
+
+       IF (flag_emit==1) THEN
+          CALL getin_p('m_sulf_emiss_vol',m_sulf_emiss_vol)
+          if (ok_qemiss) then
+             CALL getin_p('m_H2O_emiss_vol',m_H2O_emiss_vol)
+          endif
+       ELSEIF (flag_emit==4) THEN
+          CALL getin_p('id_species',id_species)
+          CALL getin_p('m_Chlore_emiss_vol',m_Chlore_emiss_vol)
+          CALL getin_p('id_HCl',id_HCl)
+          CALL getin_p('m_Brome_emiss_vol',m_Brome_emiss_vol)
+          CALL getin_p('id_HBr',id_HBr)
+          CALL getin_p('m_NOx_emiss_vol',m_NOx_emiss_vol)
+          CALL getin_p('id_NOx',id_NOx)
+          CALL getin_p('m_H2O_emiss_vol',m_H2O_emiss_vol)
+          CALL getin_p('id_H2O',id_H2O)
+       ENDIF
+
+    ELSEIF (flag_emit == 2) THEN ! SAI
+       CALL getin_p('m_aer_emiss_sai',m_aer_emiss_sai)
+       CALL getin_p('altemiss_sai',altemiss_sai)
+       CALL getin_p('sigma_alt_sai',sigma_alt_sai)
+       CALL getin_p('xlat_sai',xlat_sai)
+       CALL getin_p('xlon_sai',xlon_sai)
+       CALL getin_p('year_emit_sai_start',year_emit_sai_start)
+       CALL getin_p('year_emit_sai_end',year_emit_sai_end)
+       CALL getin_p('mth_emit_sai_start',mth_emit_sai_start)
+       CALL getin_p('mth_emit_sai_end',mth_emit_sai_end)
+       CALL getin_p('day_emit_sai_start',day_emit_sai_start)
+       CALL getin_p('day_emit_sai_end',day_emit_sai_end)
+
+    ELSEIF (flag_emit == 3) THEN ! SAI between latitudes
+       CALL getin_p('m_aer_emiss_sai',m_aer_emiss_sai)
+       CALL getin_p('altemiss_sai',altemiss_sai)
+       CALL getin_p('sigma_alt_sai',sigma_alt_sai)
+       CALL getin_p('xlon_sai',xlon_sai)
+       CALL getin_p('xlat_max_sai',xlat_max_sai)
+       CALL getin_p('xlat_min_sai',xlat_min_sai)
+    ENDIF
+
+    IF (flag_emit == 1) THEN
+       DO ispec=1,nAerErupt
+          m_aer_emiss_vol(:,ispec) = m_sulf_emiss_vol(:)
+       ENDDO
+    ELSEIF (flag_emit== 4) THEN
+       DO ispec=1,nSpeciesErupt
+          IF(id_species(ispec) == id_HCl) THEN
+             m_species_emiss_vol(:,ispec) = m_Chlore_emiss_vol(:)
+          ENDIF
+          IF (id_species(ispec) == id_HBr) THEN
+             m_species_emiss_vol(:,ispec) = m_Brome_emiss_vol(:)
+          ENDIF
+          IF (id_species(ispec) == id_NOx) THEN
+             m_species_emiss_vol(:,ispec) = m_NOx_emiss_vol(:)
+          ENDIF
+          IF (id_species(ispec) == id_H2O) THEN
+             m_species_emiss_vol(:,ispec) = m_H2O_emiss_vol(:)
+          ENDIF
+       ENDDO
+    ENDIF
+
+    !============= Injection ponderation =============
+    IF (flag_emit > 0) THEN
+       CALL strataer_ponde_init
+       WRITE(lunout,*) 'IN STRATAER INIT : ponde_lonlat_vol',ponde_lonlat_vol
+    ENDIF
+
+    !============= Print params =============
+    IF (is_master) THEN
+       IF (nErupt > 0) then
+          if (flag_emit == 1 .OR. flag_emit == 4) THEN
+             WRITE(lunout,*) 'IN STRATAER nErupt: ',nErupt
+             WRITE(lunout,*) 'IN STRATAER injdur: ',injdur
+             WRITE(lunout,*) 'IN STRATAER nAerErupt: ',nAerErupt
+
+             WRITE(lunout,*) 'IN STRATAER : year_emit_vol',year_emit_vol
+             WRITE(lunout,*) 'IN STRATAER : mth_emit_vol',mth_emit_vol
+             WRITE(lunout,*) 'IN STRATAER : day_emit_vol',day_emit_vol
+             WRITE(lunout,*) 'IN STRATAER : altemiss_vol',altemiss_vol
+             WRITE(lunout,*) 'IN STRATAER : sigma_alt_vol',sigma_alt_vol
+             WRITE(lunout,*) 'IN STRATAER : xlat_min_vol',xlat_min_vol
+             WRITE(lunout,*) 'IN STRATAER : xlat_max_vol',xlat_max_vol
+             WRITE(lunout,*) 'IN STRATAER : xlon_min_vol',xlon_min_vol
+             WRITE(lunout,*) 'IN STRATAER : xlon_max_vol',xlon_max_vol
+             IF (flag_emit==1) THEN
+                WRITE(lunout,*) 'IN STRATAEREMISS : m_sulf_emiss_vol',m_sulf_emiss_vol
+                WRITE(lunout,*) 'IN STRATAER : m_aer_emiss_vol',m_aer_emiss_vol
+                IF (ok_qemiss) then
+                   WRITE(lunout,*) 'IN STRATAEREMISS : m_H2O_emiss_vol',m_H2O_emiss_vol
+                ENDIF
+             ENDIF
+          ELSEIF (flag_emit == 2) THEN
+             WRITE(lunout,*) 'IN STRATAER : m_aer_emiss_sai',m_aer_emiss_sai
+             WRITE(lunout,*) 'IN STRATAER : altemiss_sai',altemiss_sai
+             WRITE(lunout,*) 'IN STRATAER : sigma_alt_sai',sigma_alt_sai
+             WRITE(lunout,*) 'IN STRATAER : xlat_sai',xlat_sai
+             WRITE(lunout,*) 'IN STRATAER : xlon_sai',xlon_sai
+          ELSEIF (flag_emit == 3) THEN
+             WRITE(lunout,*) 'IN STRATAER : m_aer_emiss_sai',m_aer_emiss_sai
+             WRITE(lunout,*) 'IN STRATAER : altemiss_sai',altemiss_sai
+             WRITE(lunout,*) 'IN STRATAER : sigma_alt_sai',sigma_alt_sai
+             WRITE(lunout,*) 'IN STRATAER : year_emit_sai start/end',year_emit_sai_start,year_emit_sai_end
+             WRITE(lunout,*) 'IN STRATAER : mth_emit_sai start/end',mth_emit_sai_start,mth_emit_sai_end
+             WRITE(lunout,*) 'IN STRATAER : day_emit_sai start/end',day_emit_sai_start,day_emit_sai_end
+             WRITE(lunout,*) 'IN STRATAER : xlat_min_sai',xlat_min_sai
+             WRITE(lunout,*) 'IN STRATAER : xlat_max_sai',xlat_max_sai
+             WRITE(lunout,*) 'IN STRATAER : xlon_sai',xlon_sai
+          ENDIF
+          IF(flag_emit == 4) THEN
+             WRITE(lunout,*) 'IN STRATAER : nSpeciesErupt: ',nSpeciesErupt
+             WRITE(lunout,*) 'IN STRATAER : id_species = ',id_species
+             WRITE(lunout,*) 'IN STRATAER : id_HCl = ',id_HCl
+             WRITE(lunout,*) 'IN STRATAER : id_HBr = ',id_HBr
+             WRITE(lunout,*) 'IN STRATAER : id_NOx = ',id_NOx
+             WRITE(lunout,*) 'IN STRATAER : id_H2O = ',id_H2O
+             WRITE(lunout,*) 'IN STRATAER : m_Chlore_emiss_vol = ',m_Chlore_emiss_vol
+             WRITE(lunout,*) 'IN STRATAER : m_Brome_emiss_vol = ',m_Brome_emiss_vol
+             WRITE(lunout,*) 'IN STRATAER : m_NOx_emiss_vol = ',m_NOx_emiss_vol
+             WRITE(lunout,*) 'IN STRATAER : m_H2O_emiss_vol = ',m_H2O_emiss_vol
+          ENDIF
+       endif
+    ENDIF ! if master
+
+    WRITE(lunout,*) 'IN STRATAER_EMISS END'
+  END SUBROUTINE strataer_emiss_init
+
+  ! Compute the ponderation to applicate in each grid point for all eruptions and init
+  ! dlat & dlon variables
+  SUBROUTINE strataer_ponde_init()
+
+    USE regular_lonlat_mod, ONLY: lon_reg, lat_reg
+    USE dimphy, ONLY: klon
+    USE mod_grid_phy_lmdz, ONLY: nbp_lat, nbp_lon
+    USE print_control_mod, ONLY : lunout
+    USE strataer_local_var_mod
+
+    INCLUDE "YOMCST.h"  !--RPI
+
+    ! local var
+    REAL                :: lat_reg_deg,lon_reg_deg ! lat and lon of grid points in degree
+    INTEGER             :: ieru, i, j
+
+    ALLOCATE(ponde_lonlat_vol(nErupt))
+
+    !Compute lon/lat ponderation for injection
+    dlat=180./2./FLOAT(nbp_lat)   ! d latitude in degree
+    dlon=360./2./FLOAT(nbp_lon)   ! d longitude in degree
+    WRITE(lunout,*) 'IN STRATAER_INIT dlat=',dlat,'dlon=',dlon
+    WRITE(lunout,*) 'IN STRATAER_INIT nErupt=',nErupt
+    WRITE(lunout,*) 'IN STRATAER_INIT xlat_min=',xlat_min_vol,'xlat_max=',xlat_max_vol
+    WRITE(lunout,*) 'IN STRATAER_INIT xlon_min=',xlon_min_vol,'xlon_max=',xlon_max_vol
+
+    DO ieru=1, nErupt
+       ponde_lonlat_vol(ieru) = 0
+       DO i=1,nbp_lon
+          lon_reg_deg = lon_reg(i)*180./RPI
+          DO j=1,nbp_lat
+             lat_reg_deg = lat_reg(j)*180./RPI
+             IF  ( lat_reg_deg.GE.xlat_min_vol(ieru)-dlat .AND. lat_reg_deg.LT.xlat_max_vol(ieru)+dlat .AND. &
+                  lon_reg_deg.GE.xlon_min_vol(ieru)-dlon .AND. lon_reg_deg.LT.xlon_max_vol(ieru)+dlon ) THEN
+                ponde_lonlat_vol(ieru) = ponde_lonlat_vol(ieru) + 1
+             ENDIF
+          ENDDO
+       ENDDO
+       IF(ponde_lonlat_vol(ieru) == 0) THEN
+          WRITE(lunout,*) 'STRATAER_INIT ERROR: no grid point found for eruption ieru=',ieru
+       ENDIF
+    ENDDO !ieru
+
+    WRITE(lunout,*) 'IN STRATAER_PONDE_INIT ponde_lonlat: ', ponde_lonlat_vol
+
+  END SUBROUTINE strataer_ponde_init
+
+END MODULE strataer_emiss_mod
Index: DZ6/trunk/libf/phylmd/StratAer/strataer_local_var_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/StratAer/strataer_local_var_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,284 +1,0 @@
-MODULE strataer_local_var_mod
-! This module contains strato microphysic model parameters & variables
-  
-  IMPLICIT NONE
-  
-  !============= GENERAL PARAMS =============
-  !flag for type emission scenario: (0) background aer ; (1) volcanic eruption with Sulfur ;
-  !(2,3) strato aer injections (SAI) ; (4) volcanic eruption chimistry; (5) rocket
-  INTEGER,SAVE :: flag_emit
-  !$OMP THREADPRIVATE(flag_emit)
-  
-  ! flag for emission altitude distribution: (0) gaussian; (1) uniform
-  INTEGER,SAVE :: flag_emit_distrib
-  !$OMP THREADPRIVATE(flag_emit_distrib)
-  
-  ! flag to choose nucleation nucleation method
-  LOGICAL,SAVE :: flag_new_nucl   ! T=new routine from A. Maattanen (LATMOS), F=older routine from H. Vehkamäki (FMI)
-  !$OMP THREADPRIVATE(flag_new_nucl)
-  
-  ! Use relative humidity from 2D model stratospheric H2O because LMDz is too dry in the stratosphere
-  ! (no CH4 oxidation)
-  LOGICAL,SAVE :: flag_H2O2d_nucleation
-  !$OMP THREADPRIVATE(flag_H2O2d_nucleation)
-  
-  ! OH reduction from SO2. OH is reduced when its reaction with SO2 competes sufficiently with its reaction
-  ! with O3 (Bekki, 1995). As a result, SO2 lifetime is extended. 2D model O3 climatologies are needed.
-  LOGICAL,SAVE :: flag_OH_reduced
-  !$OMP THREADPRIVATE(flag_OH_reduced)
-  
-  ! H2SO4 photolysis: H2SO4 is converted into SO2 by complex photolytic processes. Here simplified approach
-  ! by setting H2SO4 cross-sections = 0.3*HCl cross-sections (Rinsland et al., 1995)
-  LOGICAL,SAVE :: flag_H2SO4_photolysis
-  !$OMP THREADPRIVATE(flag_H2SO4_photolysis)
-  
-  ! flag for minimum lifetime (=1.5 pdt phys)
-  LOGICAL,SAVE :: flag_min_rreduce
-  !$OMP THREADPRIVATE(flag_min_rreduce)
-  
-  ! flag to read new climato (O3, H2O & H2SO4_LIFET)
-  LOGICAL,SAVE :: flag_newclim_file
-  !$OMP THREADPRIVATE(flag_newclim_file)
-  
-  ! flag to choose new H2SO4 density and weight percent from Tabazadeh et al. (1994).
-  LOGICAL,SAVE :: flag_new_strat_compo
-  !$OMP THREADPRIVATE(flag_new_strat_compo)
-  
-  ! Verbose mode to get more print info
-  LOGICAL, SAVE :: flag_verbose_strataer
-  !$OMP THREADPRIVATE(flag_verbose_strataer)
-  
-  
-  !============= NUCLEATION VARS =============
-  ! MOLECULAR ACCOMODATION OF H2SO4 (Raes and Van Dingen)
-  REAL,SAVE    :: ALPH2SO4               ! H2SO4 accommodation  coefficient [condensation/evaporation]
-  !$OMP THREADPRIVATE(ALPH2SO4)
-  
-  ! flag to constraint nucleation rate in a lat/pres box
-  LOGICAL,SAVE :: flag_nuc_rate_box      ! Nucleation rate limit or not to a lat/pres
-  !$OMP THREADPRIVATE(flag_nuc_rate_box)
-  REAL,SAVE    :: nuclat_min             ! min lat to activate nuc rate
-  REAL,SAVE    :: nuclat_max             ! max lat to activate nuc rate
-  REAL,SAVE    :: nucpres_min            ! min pres to activate nuc rate
-  REAL,SAVE    :: nucpres_max            ! max pres to activate nuc rate
-  !$OMP THREADPRIVATE(nuclat_min, nuclat_max, nucpres_min, nucpres_max)
-
-  LOGICAL,SAVE :: ok_qemiss
-  !$OMP THREADPRIVATE(ok_qemiss)
-  INTEGER,SAVE :: flh2o  ! ds stratemit : flh2o =0 (tr_seri), flh2o=1 (dq) 
-  !$OMP THREADPRIVATE(flh2o)
-  
-  REAL,ALLOCATABLE,SAVE    :: budg_emi(:,:)            !DIMENSION(klon,n)
-  !$OMP THREADPRIVATE(budg_emi)
-  
-  
-  !============= EMISSION VARS =============
-  !--flag_emit=1 OR == 4 -- Volcanic eruption(s)
-  INTEGER,SAVE             :: nErupt                    ! number of eruptions specs
-  REAL,SAVE                :: injdur                    ! volcanic injection duration
-  !$OMP THREADPRIVATE(nErupt, injdur)
-  INTEGER,ALLOCATABLE,SAVE :: year_emit_vol(:)          ! year of emission date
-  INTEGER,ALLOCATABLE,SAVE :: mth_emit_vol(:)           ! month of emission date
-  INTEGER,ALLOCATABLE,SAVE :: day_emit_vol(:)           ! day of emission date
-  !$OMP THREADPRIVATE(year_emit_vol, mth_emit_vol, day_emit_vol)
-  REAL,ALLOCATABLE,SAVE    :: altemiss_vol(:)           ! emission altitude in m
-  REAL,ALLOCATABLE,SAVE    :: sigma_alt_vol(:)          ! standard deviation of emission altitude in m
-  !$OMP THREADPRIVATE(altemiss_vol, sigma_alt_vol)
-  INTEGER,ALLOCATABLE,SAVE :: ponde_lonlat_vol(:)       ! lon/lat ponderation factor
-  REAL,ALLOCATABLE,SAVE    :: xlat_min_vol(:)           ! min latitude of volcano in degree
-  REAL,ALLOCATABLE,SAVE    :: xlat_max_vol(:)           ! max latitude of volcano in degree
-  REAL,ALLOCATABLE,SAVE    :: xlon_min_vol(:)           ! min longitude of volcano in degree
-  REAL,ALLOCATABLE,SAVE    :: xlon_max_vol(:)           ! max longitude of volcano in degree
-  !$OMP THREADPRIVATE(ponde_lonlat_vol, xlat_min_vol, xlat_max_vol, xlon_min_vol, xlon_max_vol)
-  
-  !--flag_emit=1
-  INTEGER,SAVE             :: nAerErupt                 ! number Aerosol 
-  !$OMP THREADPRIVATE(nAerErupt)
-  REAL,ALLOCATABLE,SAVE    :: m_sulf_emiss_vol(:)        ! emitted sulfur mass in kgS, e.g. 7Tg(S)=14Tg(SO2)
-  REAL,ALLOCATABLE,SAVE    :: m_aer_emiss_vol(:,:)
-  !$OMP THREADPRIVATE(m_sulf_emiss_vol,m_aer_emiss_vol)
-  
-  !--flag_emit=2 --SAI
-  REAL,SAVE    :: m_aer_emiss_sai        ! emitted sulfur mass in kgS, eg 1e9=1TgS, 1e10=10TgS
-  REAL,SAVE    :: altemiss_sai           ! emission altitude in m
-  REAL,SAVE    :: sigma_alt_sai          ! standard deviation of emission altitude in m
-  !$OMP THREADPRIVATE(m_aer_emiss_sai, altemiss_sai, sigma_alt_sai)
-  INTEGER,SAVE    :: year_emit_sai_start
-  INTEGER,SAVE    :: year_emit_sai_end
-  INTEGER,SAVE    :: mth_emit_sai_start
-  INTEGER,SAVE    :: mth_emit_sai_end
-  INTEGER,SAVE    :: day_emit_sai_start
-  INTEGER,SAVE    :: day_emit_sai_end
-  !$OMP THREADPRIVATE(year_emit_sai_start, year_emit_sai_end)
-  !$OMP THREADPRIVATE(mth_emit_sai_start, mth_emit_sai_end)
-  !$OMP THREADPRIVATE(day_emit_sai_start, day_emit_sai_end)
-  REAL,SAVE    :: xlat_sai               ! latitude of SAI in degree
-  REAL,SAVE    :: xlon_sai               ! longitude of SAI in degree
-  !$OMP THREADPRIVATE(xlat_sai, xlon_sai)
-  
-  !--flag_emit=3 -- SAI
-  REAL,SAVE    :: xlat_max_sai           ! maximum latitude of SAI in degrees
-  REAL,SAVE    :: xlat_min_sai           ! minimum latitude of SAI in degrees
-  !$OMP THREADPRIVATE(xlat_min_sai,xlat_max_sai)
-  
-  !--flag_emit=4 -- volc species
-  INTEGER,SAVE             :: nSpeciesErupt            ! number of species Repr
-  INTEGER,ALLOCATABLE,SAVE :: id_species(:)            ! indice species Repr
-  REAL,ALLOCATABLE,SAVE    :: m_species_emiss_vol(:,:) ! emitted species 
-  !$OMP THREADPRIVATE(nSpeciesErupt,id_species,m_species_emiss_vol)
-  INTEGER,ALLOCATABLE,SAVE :: id_HCl
-  INTEGER,ALLOCATABLE,SAVE :: id_HBr
-  INTEGER,ALLOCATABLE,SAVE :: id_NOx
-  INTEGER,ALLOCATABLE,SAVE :: id_H2O
-  !$OMP THREADPRIVATE(id_HCl,id_HBr,id_NOx,id_H2O)
-  REAL,ALLOCATABLE,SAVE    :: m_Chlore_emiss_vol(:)   ! emitted Chlore mass 
-  REAL,ALLOCATABLE,SAVE    :: m_Brome_emiss_vol(:)    ! emitted Brome mass
-  REAL,ALLOCATABLE,SAVE    :: m_NOx_emiss_vol(:)      ! emitted NOx mass
-  REAL,ALLOCATABLE,SAVE    :: m_H2O_emiss_vol(:)      ! emitted H2O mass
-  REAL,ALLOCATABLE,SAVE    :: m_H2O_emiss_vol_daily(:)
-  !$OMP THREADPRIVATE(m_Chlore_emiss_vol,m_Brome_emiss_vol,m_NOx_emiss_vol,m_H2O_emiss_vol)
-  !$OMP THREADPRIVATE(m_H2O_emiss_vol_daily)
-  
-  !--flag_emit=5 -- Rockets Emitted
-  INTEGER, SAVE            :: ifreqroc        ! frequence (=2 ex: tous les 2 mois)
-  !$OMP THREADPRIVATE(ifreqroc)
-  INTEGER,ALLOCATABLE,SAVE :: day_emit_roc(:) ! day of emission date
-  !$OMP THREADPRIVATE(day_emit_roc)
-  
-  REAL,ALLOCATABLE,SAVE    :: RRSI(:) ! radius [cm] for each aerosol size
-  REAL,ALLOCATABLE,SAVE    :: Vbin(:) ! volume [m3] for each aerosol size  
-  !$OMP THREADPRIVATE(RRSI, Vbin)
-  REAL,SAVE    :: dlat, dlon             ! delta latitude and d longitude of grid in degree
-  !$OMP THREADPRIVATE(dlat, dlon)
-  
-CONTAINS
-    
-  SUBROUTINE strataer_init()
-    USE ioipsl_getin_p_mod, ONLY : getin_p
-    USE print_control_mod, ONLY : lunout
-    USE mod_phys_lmdz_para, ONLY : is_master
-    USE infotrac_phy, ONLY: id_OCS_strat,id_SO2_strat,id_H2SO4_strat,nbtr_sulgas,nbtr_bin
-    USE phys_local_var_mod, ONLY : mdw
-    USE aerophys, ONLY: mdwmin, V_rat
-    USE yomcst_mod_h  , ONLY : RPI
-    
-    INTEGER :: it
-    
-    WRITE(lunout,*) 'IN STRATAER_LOCAL_VAR INIT WELCOME!'
-    
-    !============= Check Sulfur aerosols ID =============
-    WRITE(lunout,*) 'STRATAER_LOCAL_VAR INIT: id_OCS_strat=',id_OCS_strat,' id_SO2_strat=',id_SO2_strat,' id_H2SO4_strat=',id_H2SO4_strat
-    
-    IF(id_OCS_strat < 0 .OR. id_OCS_strat > nbtr_sulgas) THEN
-       WRITE(lunout,*) 'ERROR : OCS index id_OCS_strat=',id_OCS_strat,' is negative or superior than the total sulfur gases !'
-       CALL abort_physic('strataer_local_var_mod','Wrong OCS index, check your tracer.def file.',1)
-    ELSEIF(id_SO2_strat < 0 .OR. id_SO2_strat > nbtr_sulgas) THEN
-       WRITE(lunout,*) 'ERROR : SO2 index id_SO2_strat=',id_SO2_strat,' is negative or superior than the total sulfur gases !'
-       CALL abort_physic('strataer_local_var_mod','Wrong SO2 index, check your tracer.def file.',1)
-    ELSEIF(id_H2SO4_strat < 0 .OR. id_H2SO4_strat > nbtr_sulgas) THEN
-       WRITE(lunout,*) 'ERROR : H2SO4 index id_H2SO4_strat=',id_H2SO4_strat,' is negative or superior than the total sulfur gases !'
-       CALL abort_physic('strataer_local_var_mod','Wrong H2SO4 index, check your tracer.def file.',1)
-    ENDIF
-    
-    !============= Init params =============
-    flag_emit = 0                   ! Background (default)
-    flag_emit_distrib = 0           ! Gaussian (default)
-    flag_new_nucl = .TRUE.          ! Define nucleation routine (default: A. Maattanen - LATMOS)
-    flag_verbose_strataer = .FALSE. ! verbose mode
-    flag_newclim_file = .TRUE.      ! Define input climato file (default: all climato)
-    flag_H2O2d_nucleation = .FALSE. ! Use H2O 2D climato (default: No)
-    flag_OH_reduced = .FALSE.       ! OH reduce (default: No)
-    flag_H2SO4_photolysis = .FALSE. ! H2SO4 photolysis (default: No)
-    flag_min_rreduce = .TRUE.       ! Minimum lifetime=1.5 pdt phys (default: Yes)
-    flag_new_strat_compo =.FALSE.   ! H2SO4/H2O weight percent & density routine (default: S. Bekki)
-    ok_qemiss = .FALSE.             ! H2O emission flag
-    
-    ! nuc init
-    ALPH2SO4 = 0.1
-    flag_nuc_rate_box = .FALSE.
-    nuclat_min=0  ; nuclat_max=0
-    nucpres_min=0 ; nucpres_max=0
-    
-    ! emiss init
-    nErupt = 0 ! eruption number
-    injdur = 0 ! init injection duration
-    nAerErupt = 1 ; nSpeciesErupt = 1
-    ifreqroc=2 ; flh2o=0
-    
-    !============= Read params =============
-    CALL getin_p('flag_emit',flag_emit)
-    CALL getin_p('flag_emit_distrib',flag_emit_distrib)
-    CALL getin_p('flag_verbose_strataer',flag_verbose_strataer)
-    CALL getin_p('flag_new_nucl',flag_new_nucl)
-    CALL getin_p('flag_newclim_file',flag_newclim_file)
-    CALL getin_p('flag_H2O2d_nucleation',flag_H2O2d_nucleation)
-    CALL getin_p('flag_OH_reduced',flag_OH_reduced)
-    CALL getin_p('flag_H2SO4_photolysis',flag_H2SO4_photolysis)
-    CALL getin_p('flag_min_rreduce',flag_min_rreduce)
-    CALL getin_p('flag_new_strat_compo',flag_new_strat_compo)
-    CALL getin_p('ok_qemiss',ok_qemiss)
-    
-    !============= Test flag coherence =============
-    IF (.NOT. flag_newclim_file) THEN
-       IF (flag_H2SO4_photolysis .OR. flag_OH_reduced .OR. flag_H2O2d_nucleation) THEN
-          WRITE(lunout,*) 'ERROR : flag_newclim_file=',flag_newclim_file, &
-               ' whereas flag_H2SO4_photolysis=',flag_H2SO4_photolysis,', flag_OH_reduced=',flag_OH_reduced, &
-               ' and flag_H2O2d_nucleation=',flag_H2O2d_nucleation
-          CALL abort_physic('strataer_local_var_mod','Incompatible options in physiq_def file !',1)
-       ENDIF
-       IF(flag_min_rreduce) THEN
-          WRITE(lunout,*) 'Warning : flag_min_rreduce will be ignored with old climato file !'
-       ENDIF
-    ENDIF
-    
-    !============= Print params =============
-    IF (is_master) THEN
-       WRITE(lunout,*) 'flag_emit = ',flag_emit
-       WRITE(lunout,*) 'IN STRATAER : flag_new_nucl = ',flag_new_nucl
-       WRITE(lunout,*) 'IN STRATAER : flag_newclim_file = ',flag_newclim_file
-       WRITE(lunout,*) 'IN STRATAER : flag_emit_distrib = ',flag_emit_distrib
-       WRITE(lunout,*) 'IN STRATAER : flag_verbose_strataer = ',flag_verbose_strataer
-       IF (flag_emit == 1 .OR. flag_emit == 4) THEN
-          WRITE(lunout,*) 'IN STRATAER : flag_H2O2d_nucleation = ',flag_H2O2d_nucleation
-          WRITE(lunout,*) 'IN STRATAER : flag_OH_reduced = ',flag_OH_reduced
-          WRITE(lunout,*) 'IN STRATAER : flag_H2SO4_photolysis = ',flag_H2SO4_photolysis
-          WRITE(lunout,*) 'IN STRATAER : flag_min_rreduce = ',flag_min_rreduce
-          WRITE(lunout,*) 'IN STRATAER : flag_new_strat_compo = ',flag_new_strat_compo
-          WRITE(lunout,*) 'IN STRATAER : ok_qemiss = ',ok_qemiss
-       ENDIF
-    ENDIF ! if master
-    
-    !--initialising dry diameters to geometrically spaced mass/volume (see Jacobson 1994)
-    mdw(1)=mdwmin
-    IF (V_rat.LT.1.62) THEN ! compensate for dip in second bin for lower volume ratio
-       mdw(2)=mdw(1)*2.**(1./3.)
-       DO it=3, nbtr_bin
-          mdw(it)=mdw(it-1)*V_rat**(1./3.)
-       ENDDO
-    ELSE
-       DO it=2, nbtr_bin
-          mdw(it)=mdw(it-1)*V_rat**(1./3.)
-       ENDDO
-    ENDIF
-    IF (is_master) WRITE(lunout,*) 'init mdw=', mdw
-    
-    !   compute particle radius RRSI [cm] and volume Vbin [m3] from diameter mdw [m]
-    ALLOCATE(RRSI(nbtr_bin), Vbin(nbtr_bin))
-    
-    DO it=1,nbtr_bin
-       !     [cm]
-       RRSI(it)=mdw(it)/2.*100.
-       !     [m3]
-       Vbin(it)=4.0*RPI*((mdw(it)/2.)**3)/3.0
-    ENDDO
-    
-    IF (is_master) THEN
-       WRITE(lunout,*) 'init RRSI=', RRSI
-       WRITE(lunout,*) 'init Vbin=', Vbin
-    ENDIF
-    
-    WRITE(lunout,*) 'IN STRATAER INIT END'
-    
-  END SUBROUTINE strataer_init
-  
-END MODULE strataer_local_var_mod
Index: /LMDZ6/trunk/libf/phylmd/StratAer/strataer_local_var_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/StratAer/strataer_local_var_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/StratAer/strataer_local_var_mod.f90	(revision 5268)
@@ -0,0 +1,284 @@
+MODULE strataer_local_var_mod
+! This module contains strato microphysic model parameters & variables
+  
+  IMPLICIT NONE
+  
+  !============= GENERAL PARAMS =============
+  !flag for type emission scenario: (0) background aer ; (1) volcanic eruption with Sulfur ;
+  !(2,3) strato aer injections (SAI) ; (4) volcanic eruption chimistry; (5) rocket
+  INTEGER,SAVE :: flag_emit
+  !$OMP THREADPRIVATE(flag_emit)
+  
+  ! flag for emission altitude distribution: (0) gaussian; (1) uniform
+  INTEGER,SAVE :: flag_emit_distrib
+  !$OMP THREADPRIVATE(flag_emit_distrib)
+  
+  ! flag to choose nucleation nucleation method
+  LOGICAL,SAVE :: flag_new_nucl   ! T=new routine from A. Maattanen (LATMOS), F=older routine from H. Vehkamäki (FMI)
+  !$OMP THREADPRIVATE(flag_new_nucl)
+  
+  ! Use relative humidity from 2D model stratospheric H2O because LMDz is too dry in the stratosphere
+  ! (no CH4 oxidation)
+  LOGICAL,SAVE :: flag_H2O2d_nucleation
+  !$OMP THREADPRIVATE(flag_H2O2d_nucleation)
+  
+  ! OH reduction from SO2. OH is reduced when its reaction with SO2 competes sufficiently with its reaction
+  ! with O3 (Bekki, 1995). As a result, SO2 lifetime is extended. 2D model O3 climatologies are needed.
+  LOGICAL,SAVE :: flag_OH_reduced
+  !$OMP THREADPRIVATE(flag_OH_reduced)
+  
+  ! H2SO4 photolysis: H2SO4 is converted into SO2 by complex photolytic processes. Here simplified approach
+  ! by setting H2SO4 cross-sections = 0.3*HCl cross-sections (Rinsland et al., 1995)
+  LOGICAL,SAVE :: flag_H2SO4_photolysis
+  !$OMP THREADPRIVATE(flag_H2SO4_photolysis)
+  
+  ! flag for minimum lifetime (=1.5 pdt phys)
+  LOGICAL,SAVE :: flag_min_rreduce
+  !$OMP THREADPRIVATE(flag_min_rreduce)
+  
+  ! flag to read new climato (O3, H2O & H2SO4_LIFET)
+  LOGICAL,SAVE :: flag_newclim_file
+  !$OMP THREADPRIVATE(flag_newclim_file)
+  
+  ! flag to choose new H2SO4 density and weight percent from Tabazadeh et al. (1994).
+  LOGICAL,SAVE :: flag_new_strat_compo
+  !$OMP THREADPRIVATE(flag_new_strat_compo)
+  
+  ! Verbose mode to get more print info
+  LOGICAL, SAVE :: flag_verbose_strataer
+  !$OMP THREADPRIVATE(flag_verbose_strataer)
+  
+  
+  !============= NUCLEATION VARS =============
+  ! MOLECULAR ACCOMODATION OF H2SO4 (Raes and Van Dingen)
+  REAL,SAVE    :: ALPH2SO4               ! H2SO4 accommodation  coefficient [condensation/evaporation]
+  !$OMP THREADPRIVATE(ALPH2SO4)
+  
+  ! flag to constraint nucleation rate in a lat/pres box
+  LOGICAL,SAVE :: flag_nuc_rate_box      ! Nucleation rate limit or not to a lat/pres
+  !$OMP THREADPRIVATE(flag_nuc_rate_box)
+  REAL,SAVE    :: nuclat_min             ! min lat to activate nuc rate
+  REAL,SAVE    :: nuclat_max             ! max lat to activate nuc rate
+  REAL,SAVE    :: nucpres_min            ! min pres to activate nuc rate
+  REAL,SAVE    :: nucpres_max            ! max pres to activate nuc rate
+  !$OMP THREADPRIVATE(nuclat_min, nuclat_max, nucpres_min, nucpres_max)
+
+  LOGICAL,SAVE :: ok_qemiss
+  !$OMP THREADPRIVATE(ok_qemiss)
+  INTEGER,SAVE :: flh2o  ! ds stratemit : flh2o =0 (tr_seri), flh2o=1 (dq) 
+  !$OMP THREADPRIVATE(flh2o)
+  
+  REAL,ALLOCATABLE,SAVE    :: budg_emi(:,:)            !DIMENSION(klon,n)
+  !$OMP THREADPRIVATE(budg_emi)
+  
+  
+  !============= EMISSION VARS =============
+  !--flag_emit=1 OR == 4 -- Volcanic eruption(s)
+  INTEGER,SAVE             :: nErupt                    ! number of eruptions specs
+  REAL,SAVE                :: injdur                    ! volcanic injection duration
+  !$OMP THREADPRIVATE(nErupt, injdur)
+  INTEGER,ALLOCATABLE,SAVE :: year_emit_vol(:)          ! year of emission date
+  INTEGER,ALLOCATABLE,SAVE :: mth_emit_vol(:)           ! month of emission date
+  INTEGER,ALLOCATABLE,SAVE :: day_emit_vol(:)           ! day of emission date
+  !$OMP THREADPRIVATE(year_emit_vol, mth_emit_vol, day_emit_vol)
+  REAL,ALLOCATABLE,SAVE    :: altemiss_vol(:)           ! emission altitude in m
+  REAL,ALLOCATABLE,SAVE    :: sigma_alt_vol(:)          ! standard deviation of emission altitude in m
+  !$OMP THREADPRIVATE(altemiss_vol, sigma_alt_vol)
+  INTEGER,ALLOCATABLE,SAVE :: ponde_lonlat_vol(:)       ! lon/lat ponderation factor
+  REAL,ALLOCATABLE,SAVE    :: xlat_min_vol(:)           ! min latitude of volcano in degree
+  REAL,ALLOCATABLE,SAVE    :: xlat_max_vol(:)           ! max latitude of volcano in degree
+  REAL,ALLOCATABLE,SAVE    :: xlon_min_vol(:)           ! min longitude of volcano in degree
+  REAL,ALLOCATABLE,SAVE    :: xlon_max_vol(:)           ! max longitude of volcano in degree
+  !$OMP THREADPRIVATE(ponde_lonlat_vol, xlat_min_vol, xlat_max_vol, xlon_min_vol, xlon_max_vol)
+  
+  !--flag_emit=1
+  INTEGER,SAVE             :: nAerErupt                 ! number Aerosol 
+  !$OMP THREADPRIVATE(nAerErupt)
+  REAL,ALLOCATABLE,SAVE    :: m_sulf_emiss_vol(:)        ! emitted sulfur mass in kgS, e.g. 7Tg(S)=14Tg(SO2)
+  REAL,ALLOCATABLE,SAVE    :: m_aer_emiss_vol(:,:)
+  !$OMP THREADPRIVATE(m_sulf_emiss_vol,m_aer_emiss_vol)
+  
+  !--flag_emit=2 --SAI
+  REAL,SAVE    :: m_aer_emiss_sai        ! emitted sulfur mass in kgS, eg 1e9=1TgS, 1e10=10TgS
+  REAL,SAVE    :: altemiss_sai           ! emission altitude in m
+  REAL,SAVE    :: sigma_alt_sai          ! standard deviation of emission altitude in m
+  !$OMP THREADPRIVATE(m_aer_emiss_sai, altemiss_sai, sigma_alt_sai)
+  INTEGER,SAVE    :: year_emit_sai_start
+  INTEGER,SAVE    :: year_emit_sai_end
+  INTEGER,SAVE    :: mth_emit_sai_start
+  INTEGER,SAVE    :: mth_emit_sai_end
+  INTEGER,SAVE    :: day_emit_sai_start
+  INTEGER,SAVE    :: day_emit_sai_end
+  !$OMP THREADPRIVATE(year_emit_sai_start, year_emit_sai_end)
+  !$OMP THREADPRIVATE(mth_emit_sai_start, mth_emit_sai_end)
+  !$OMP THREADPRIVATE(day_emit_sai_start, day_emit_sai_end)
+  REAL,SAVE    :: xlat_sai               ! latitude of SAI in degree
+  REAL,SAVE    :: xlon_sai               ! longitude of SAI in degree
+  !$OMP THREADPRIVATE(xlat_sai, xlon_sai)
+  
+  !--flag_emit=3 -- SAI
+  REAL,SAVE    :: xlat_max_sai           ! maximum latitude of SAI in degrees
+  REAL,SAVE    :: xlat_min_sai           ! minimum latitude of SAI in degrees
+  !$OMP THREADPRIVATE(xlat_min_sai,xlat_max_sai)
+  
+  !--flag_emit=4 -- volc species
+  INTEGER,SAVE             :: nSpeciesErupt            ! number of species Repr
+  INTEGER,ALLOCATABLE,SAVE :: id_species(:)            ! indice species Repr
+  REAL,ALLOCATABLE,SAVE    :: m_species_emiss_vol(:,:) ! emitted species 
+  !$OMP THREADPRIVATE(nSpeciesErupt,id_species,m_species_emiss_vol)
+  INTEGER,ALLOCATABLE,SAVE :: id_HCl
+  INTEGER,ALLOCATABLE,SAVE :: id_HBr
+  INTEGER,ALLOCATABLE,SAVE :: id_NOx
+  INTEGER,ALLOCATABLE,SAVE :: id_H2O
+  !$OMP THREADPRIVATE(id_HCl,id_HBr,id_NOx,id_H2O)
+  REAL,ALLOCATABLE,SAVE    :: m_Chlore_emiss_vol(:)   ! emitted Chlore mass 
+  REAL,ALLOCATABLE,SAVE    :: m_Brome_emiss_vol(:)    ! emitted Brome mass
+  REAL,ALLOCATABLE,SAVE    :: m_NOx_emiss_vol(:)      ! emitted NOx mass
+  REAL,ALLOCATABLE,SAVE    :: m_H2O_emiss_vol(:)      ! emitted H2O mass
+  REAL,ALLOCATABLE,SAVE    :: m_H2O_emiss_vol_daily(:)
+  !$OMP THREADPRIVATE(m_Chlore_emiss_vol,m_Brome_emiss_vol,m_NOx_emiss_vol,m_H2O_emiss_vol)
+  !$OMP THREADPRIVATE(m_H2O_emiss_vol_daily)
+  
+  !--flag_emit=5 -- Rockets Emitted
+  INTEGER, SAVE            :: ifreqroc        ! frequence (=2 ex: tous les 2 mois)
+  !$OMP THREADPRIVATE(ifreqroc)
+  INTEGER,ALLOCATABLE,SAVE :: day_emit_roc(:) ! day of emission date
+  !$OMP THREADPRIVATE(day_emit_roc)
+  
+  REAL,ALLOCATABLE,SAVE    :: RRSI(:) ! radius [cm] for each aerosol size
+  REAL,ALLOCATABLE,SAVE    :: Vbin(:) ! volume [m3] for each aerosol size  
+  !$OMP THREADPRIVATE(RRSI, Vbin)
+  REAL,SAVE    :: dlat, dlon             ! delta latitude and d longitude of grid in degree
+  !$OMP THREADPRIVATE(dlat, dlon)
+  
+CONTAINS
+    
+  SUBROUTINE strataer_init()
+    USE ioipsl_getin_p_mod, ONLY : getin_p
+    USE print_control_mod, ONLY : lunout
+    USE mod_phys_lmdz_para, ONLY : is_master
+    USE infotrac_phy, ONLY: id_OCS_strat,id_SO2_strat,id_H2SO4_strat,nbtr_sulgas,nbtr_bin
+    USE phys_local_var_mod, ONLY : mdw
+    USE aerophys, ONLY: mdwmin, V_rat
+    USE yomcst_mod_h  , ONLY : RPI
+    
+    INTEGER :: it
+    
+    WRITE(lunout,*) 'IN STRATAER_LOCAL_VAR INIT WELCOME!'
+    
+    !============= Check Sulfur aerosols ID =============
+    WRITE(lunout,*) 'STRATAER_LOCAL_VAR INIT: id_OCS_strat=',id_OCS_strat,' id_SO2_strat=',id_SO2_strat,' id_H2SO4_strat=',id_H2SO4_strat
+    
+    IF(id_OCS_strat < 0 .OR. id_OCS_strat > nbtr_sulgas) THEN
+       WRITE(lunout,*) 'ERROR : OCS index id_OCS_strat=',id_OCS_strat,' is negative or superior than the total sulfur gases !'
+       CALL abort_physic('strataer_local_var_mod','Wrong OCS index, check your tracer.def file.',1)
+    ELSEIF(id_SO2_strat < 0 .OR. id_SO2_strat > nbtr_sulgas) THEN
+       WRITE(lunout,*) 'ERROR : SO2 index id_SO2_strat=',id_SO2_strat,' is negative or superior than the total sulfur gases !'
+       CALL abort_physic('strataer_local_var_mod','Wrong SO2 index, check your tracer.def file.',1)
+    ELSEIF(id_H2SO4_strat < 0 .OR. id_H2SO4_strat > nbtr_sulgas) THEN
+       WRITE(lunout,*) 'ERROR : H2SO4 index id_H2SO4_strat=',id_H2SO4_strat,' is negative or superior than the total sulfur gases !'
+       CALL abort_physic('strataer_local_var_mod','Wrong H2SO4 index, check your tracer.def file.',1)
+    ENDIF
+    
+    !============= Init params =============
+    flag_emit = 0                   ! Background (default)
+    flag_emit_distrib = 0           ! Gaussian (default)
+    flag_new_nucl = .TRUE.          ! Define nucleation routine (default: A. Maattanen - LATMOS)
+    flag_verbose_strataer = .FALSE. ! verbose mode
+    flag_newclim_file = .TRUE.      ! Define input climato file (default: all climato)
+    flag_H2O2d_nucleation = .FALSE. ! Use H2O 2D climato (default: No)
+    flag_OH_reduced = .FALSE.       ! OH reduce (default: No)
+    flag_H2SO4_photolysis = .FALSE. ! H2SO4 photolysis (default: No)
+    flag_min_rreduce = .TRUE.       ! Minimum lifetime=1.5 pdt phys (default: Yes)
+    flag_new_strat_compo =.FALSE.   ! H2SO4/H2O weight percent & density routine (default: S. Bekki)
+    ok_qemiss = .FALSE.             ! H2O emission flag
+    
+    ! nuc init
+    ALPH2SO4 = 0.1
+    flag_nuc_rate_box = .FALSE.
+    nuclat_min=0  ; nuclat_max=0
+    nucpres_min=0 ; nucpres_max=0
+    
+    ! emiss init
+    nErupt = 0 ! eruption number
+    injdur = 0 ! init injection duration
+    nAerErupt = 1 ; nSpeciesErupt = 1
+    ifreqroc=2 ; flh2o=0
+    
+    !============= Read params =============
+    CALL getin_p('flag_emit',flag_emit)
+    CALL getin_p('flag_emit_distrib',flag_emit_distrib)
+    CALL getin_p('flag_verbose_strataer',flag_verbose_strataer)
+    CALL getin_p('flag_new_nucl',flag_new_nucl)
+    CALL getin_p('flag_newclim_file',flag_newclim_file)
+    CALL getin_p('flag_H2O2d_nucleation',flag_H2O2d_nucleation)
+    CALL getin_p('flag_OH_reduced',flag_OH_reduced)
+    CALL getin_p('flag_H2SO4_photolysis',flag_H2SO4_photolysis)
+    CALL getin_p('flag_min_rreduce',flag_min_rreduce)
+    CALL getin_p('flag_new_strat_compo',flag_new_strat_compo)
+    CALL getin_p('ok_qemiss',ok_qemiss)
+    
+    !============= Test flag coherence =============
+    IF (.NOT. flag_newclim_file) THEN
+       IF (flag_H2SO4_photolysis .OR. flag_OH_reduced .OR. flag_H2O2d_nucleation) THEN
+          WRITE(lunout,*) 'ERROR : flag_newclim_file=',flag_newclim_file, &
+               ' whereas flag_H2SO4_photolysis=',flag_H2SO4_photolysis,', flag_OH_reduced=',flag_OH_reduced, &
+               ' and flag_H2O2d_nucleation=',flag_H2O2d_nucleation
+          CALL abort_physic('strataer_local_var_mod','Incompatible options in physiq_def file !',1)
+       ENDIF
+       IF(flag_min_rreduce) THEN
+          WRITE(lunout,*) 'Warning : flag_min_rreduce will be ignored with old climato file !'
+       ENDIF
+    ENDIF
+    
+    !============= Print params =============
+    IF (is_master) THEN
+       WRITE(lunout,*) 'flag_emit = ',flag_emit
+       WRITE(lunout,*) 'IN STRATAER : flag_new_nucl = ',flag_new_nucl
+       WRITE(lunout,*) 'IN STRATAER : flag_newclim_file = ',flag_newclim_file
+       WRITE(lunout,*) 'IN STRATAER : flag_emit_distrib = ',flag_emit_distrib
+       WRITE(lunout,*) 'IN STRATAER : flag_verbose_strataer = ',flag_verbose_strataer
+       IF (flag_emit == 1 .OR. flag_emit == 4) THEN
+          WRITE(lunout,*) 'IN STRATAER : flag_H2O2d_nucleation = ',flag_H2O2d_nucleation
+          WRITE(lunout,*) 'IN STRATAER : flag_OH_reduced = ',flag_OH_reduced
+          WRITE(lunout,*) 'IN STRATAER : flag_H2SO4_photolysis = ',flag_H2SO4_photolysis
+          WRITE(lunout,*) 'IN STRATAER : flag_min_rreduce = ',flag_min_rreduce
+          WRITE(lunout,*) 'IN STRATAER : flag_new_strat_compo = ',flag_new_strat_compo
+          WRITE(lunout,*) 'IN STRATAER : ok_qemiss = ',ok_qemiss
+       ENDIF
+    ENDIF ! if master
+    
+    !--initialising dry diameters to geometrically spaced mass/volume (see Jacobson 1994)
+    mdw(1)=mdwmin
+    IF (V_rat.LT.1.62) THEN ! compensate for dip in second bin for lower volume ratio
+       mdw(2)=mdw(1)*2.**(1./3.)
+       DO it=3, nbtr_bin
+          mdw(it)=mdw(it-1)*V_rat**(1./3.)
+       ENDDO
+    ELSE
+       DO it=2, nbtr_bin
+          mdw(it)=mdw(it-1)*V_rat**(1./3.)
+       ENDDO
+    ENDIF
+    IF (is_master) WRITE(lunout,*) 'init mdw=', mdw
+    
+    !   compute particle radius RRSI [cm] and volume Vbin [m3] from diameter mdw [m]
+    ALLOCATE(RRSI(nbtr_bin), Vbin(nbtr_bin))
+    
+    DO it=1,nbtr_bin
+       !     [cm]
+       RRSI(it)=mdw(it)/2.*100.
+       !     [m3]
+       Vbin(it)=4.0*RPI*((mdw(it)/2.)**3)/3.0
+    ENDDO
+    
+    IF (is_master) THEN
+       WRITE(lunout,*) 'init RRSI=', RRSI
+       WRITE(lunout,*) 'init Vbin=', Vbin
+    ENDIF
+    
+    WRITE(lunout,*) 'IN STRATAER INIT END'
+    
+  END SUBROUTINE strataer_init
+  
+END MODULE strataer_local_var_mod
Index: DZ6/trunk/libf/phylmd/StratAer/strataer_nuc_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/StratAer/strataer_nuc_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,78 +1,0 @@
-! $Id: strataer_nuc_mod.F90 3930 2021-06-11 19:39:09Z oboucher $
-MODULE strataer_nuc_mod
-! This module contains information about strato microphysic model nucleation parameters
-  
-  IMPLICIT NONE
-  
-CONTAINS
-  
-  ! Init all nucleation params
-  SUBROUTINE strataer_nuc_init()
-    
-    USE ioipsl_getin_p_mod, ONLY : getin_p
-    USE print_control_mod, ONLY : lunout
-    USE mod_phys_lmdz_para, ONLY : is_master
-    USE strataer_local_var_mod, ONLY: ALPH2SO4,flag_nuc_rate_box,nuclat_min,nuclat_max, &
-         nucpres_min,nucpres_max
-    
-    !Config Key  = flag_nuc_rate_box
-    !Config Desc = define or not a box for nucleation rate
-    ! - F = global nucleation
-    ! - T = 2D-box for nucleation need nuclat_min, nuclat_max, nucpres_min and
-    ! nucpres_max
-    !       to define its bounds.
-    !Config Def  = F
-    !Config Help = Used in physiq.F
-    !
-    CALL getin_p('flag_nuc_rate_box',flag_nuc_rate_box)
-    CALL getin_p('nuclat_min',nuclat_min)
-    CALL getin_p('nuclat_max',nuclat_max)
-    CALL getin_p('nucpres_min',nucpres_min)
-    CALL getin_p('nucpres_max',nucpres_max)
-    
-    ! Read argument H2SO4 accommodation  coefficient [condensation/evaporation]
-    CALL getin_p('alph2so4',ALPH2SO4)
-    
-    !============= Print params =============
-    IF (is_master) THEN
-       WRITE(lunout,*) 'IN STRATAER_NUC : ALPH2SO4 = ',alph2so4
-       WRITE(lunout,*) 'IN STRATAER_NUC : flag_nuc_rate_box = ',flag_nuc_rate_box
-       IF (flag_nuc_rate_box) THEN
-          WRITE(lunout,*) 'IN STRATAER_NUC : nuclat_min = ',nuclat_min,', nuclat_max = ',nuclat_max
-          WRITE(lunout,*) 'IN STRATAER_NUC : nucpres_min = ',nucpres_min,', nucpres_max = ',nucpres_max
-       ENDIF
-    ENDIF ! if master
-    
-  END SUBROUTINE strataer_nuc_init
-  
-  ! Init aerosol tracers and large scale scavinging
-  SUBROUTINE tracstrataer_init(aerosol,lessivage)
-    
-    USE infotrac_phy, ONLY: nbtr, nbtr_sulgas, id_H2SO4_strat
-    USE ioipsl, ONLY : getin
-    USE print_control_mod, ONLY : lunout
-    
-    ! Output variables
-    LOGICAL,DIMENSION(nbtr), INTENT(INOUT) :: aerosol
-    LOGICAL,INTENT(INOUT)                  :: lessivage
-    INTEGER :: it
-    
-    ! Initialization
-    lessivage  =.TRUE.
-    aerosol(:) = .FALSE.
-    
-    DO it= 1, nbtr_sulgas
-       aerosol(it)=.FALSE.
-       IF (it==id_H2SO4_strat) aerosol(it)=.TRUE.
-    ENDDO
-    DO it= nbtr_sulgas+1, nbtr
-       aerosol(it)=.TRUE.
-    ENDDO
-    
-    !!jyg(20130206) : le choix d activation du lessivage est fait dans phytrac avec iflag_lscav
-!    CALL getin('lessivage',lessivage)
-    WRITE(lunout,*) 'IN TRACSTRATAER_INIT lessivage: ',lessivage
-    
-  END SUBROUTINE tracstrataer_init
-  
-END MODULE strataer_nuc_mod
Index: /LMDZ6/trunk/libf/phylmd/StratAer/strataer_nuc_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/StratAer/strataer_nuc_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/StratAer/strataer_nuc_mod.f90	(revision 5268)
@@ -0,0 +1,78 @@
+! $Id: strataer_nuc_mod.F90 3930 2021-06-11 19:39:09Z oboucher $
+MODULE strataer_nuc_mod
+! This module contains information about strato microphysic model nucleation parameters
+  
+  IMPLICIT NONE
+  
+CONTAINS
+  
+  ! Init all nucleation params
+  SUBROUTINE strataer_nuc_init()
+    
+    USE ioipsl_getin_p_mod, ONLY : getin_p
+    USE print_control_mod, ONLY : lunout
+    USE mod_phys_lmdz_para, ONLY : is_master
+    USE strataer_local_var_mod, ONLY: ALPH2SO4,flag_nuc_rate_box,nuclat_min,nuclat_max, &
+         nucpres_min,nucpres_max
+    
+    !Config Key  = flag_nuc_rate_box
+    !Config Desc = define or not a box for nucleation rate
+    ! - F = global nucleation
+    ! - T = 2D-box for nucleation need nuclat_min, nuclat_max, nucpres_min and
+    ! nucpres_max
+    !       to define its bounds.
+    !Config Def  = F
+    !Config Help = Used in physiq.F
+    !
+    CALL getin_p('flag_nuc_rate_box',flag_nuc_rate_box)
+    CALL getin_p('nuclat_min',nuclat_min)
+    CALL getin_p('nuclat_max',nuclat_max)
+    CALL getin_p('nucpres_min',nucpres_min)
+    CALL getin_p('nucpres_max',nucpres_max)
+    
+    ! Read argument H2SO4 accommodation  coefficient [condensation/evaporation]
+    CALL getin_p('alph2so4',ALPH2SO4)
+    
+    !============= Print params =============
+    IF (is_master) THEN
+       WRITE(lunout,*) 'IN STRATAER_NUC : ALPH2SO4 = ',alph2so4
+       WRITE(lunout,*) 'IN STRATAER_NUC : flag_nuc_rate_box = ',flag_nuc_rate_box
+       IF (flag_nuc_rate_box) THEN
+          WRITE(lunout,*) 'IN STRATAER_NUC : nuclat_min = ',nuclat_min,', nuclat_max = ',nuclat_max
+          WRITE(lunout,*) 'IN STRATAER_NUC : nucpres_min = ',nucpres_min,', nucpres_max = ',nucpres_max
+       ENDIF
+    ENDIF ! if master
+    
+  END SUBROUTINE strataer_nuc_init
+  
+  ! Init aerosol tracers and large scale scavinging
+  SUBROUTINE tracstrataer_init(aerosol,lessivage)
+    
+    USE infotrac_phy, ONLY: nbtr, nbtr_sulgas, id_H2SO4_strat
+    USE ioipsl, ONLY : getin
+    USE print_control_mod, ONLY : lunout
+    
+    ! Output variables
+    LOGICAL,DIMENSION(nbtr), INTENT(INOUT) :: aerosol
+    LOGICAL,INTENT(INOUT)                  :: lessivage
+    INTEGER :: it
+    
+    ! Initialization
+    lessivage  =.TRUE.
+    aerosol(:) = .FALSE.
+    
+    DO it= 1, nbtr_sulgas
+       aerosol(it)=.FALSE.
+       IF (it==id_H2SO4_strat) aerosol(it)=.TRUE.
+    ENDDO
+    DO it= nbtr_sulgas+1, nbtr
+       aerosol(it)=.TRUE.
+    ENDDO
+    
+    !!jyg(20130206) : le choix d activation du lessivage est fait dans phytrac avec iflag_lscav
+!    CALL getin('lessivage',lessivage)
+    WRITE(lunout,*) 'IN TRACSTRATAER_INIT lessivage: ',lessivage
+    
+  END SUBROUTINE tracstrataer_init
+  
+END MODULE strataer_nuc_mod
Index: DZ6/trunk/libf/phylmd/StratAer/stratdistrib.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/StratAer/stratdistrib.F90	(revision 5267)
+++ 	(revision )
@@ -1,68 +1,0 @@
-!
-! $Id: stratemit.F90  2022-07-04 mmarchand $
-!
-SUBROUTINE STRATDISTRIB(altLMDz,altemiss,sigma_alt,f_lay_emiss)
-!
-  USE dimphy, ONLY : klon,klev
-  USE strataer_local_var_mod
-  USE yomcst_mod_h, only : RPI
-
-  IMPLICIT NONE
-
-! Input argument
-!---------------
-    REAL,DIMENSION(klev+1)  :: altLMDz    ! altitude of layer interfaces in m
-    REAL                    :: sigma_alt
-    REAL                    :: altemiss
-
-! Local variables
-!----------------
-    REAL                 :: f_lay_sum     ! sum of layer emission fractions
-    REAL                 :: alt
-    INTEGER              :: k,i_int
-    INTEGER,PARAMETER    :: n_int_alt=10  ! subintervals nb for integration over Gaussian emission
-
-! Output argument
-!----------------
-    REAL,DIMENSION(klev) :: f_lay_emiss   ! emiss fraction for every emiss for every vertical layer
-    
-    
-! Inject distrib
-!----------------
-    SELECT CASE(flag_emit_distrib)
-       
-    CASE(0) ! Gaussian distribution
-            ! Compute distribution of emission to vertical model layers
-            ! (based on Gaussian peak in altitude)
-       f_lay_sum=0.0
-       DO k=1, klev
-          f_lay_emiss(k)=0.0
-          DO i_int=1, n_int_alt
-             alt=altLMDz(k)+float(i_int)*(altLMDz(k+1)-altLMDz(k))/float(n_int_alt)
-             f_lay_emiss(k)=f_lay_emiss(k)+1./(sqrt(2.*RPI)*sigma_alt)* &
-                   & exp(-0.5*((alt-altemiss)/sigma_alt)**2.)* &           
-                   & (altLMDz(k+1)-altLMDz(k))/float(n_int_alt)
-          ENDDO
-          f_lay_sum=f_lay_sum+f_lay_emiss(k)
-        ENDDO
-        
-     CASE(1) ! Uniform distribution
-             ! In this case, parameter sigma_alt is considered
-             ! to be half the
-             ! height of the injection, centered around altemiss)
-       f_lay_sum=0.0
-       DO k=1, klev
-          f_lay_emiss(k)=max(min(altemiss+sigma_alt,altLMDz(k+1))- &
-                      & max(altemiss-sigma_alt, &
-                      & altLMDz(k)),0.)/(2.*sigma_alt)
-          f_lay_sum=f_lay_sum+f_lay_emiss(k)
-       ENDDO
-
-       END SELECT        ! End CASE over flag_emit_distrib)
-       
-       WRITE(*,*) "IN stratdistrib f_lay_emiss=",f_lay_emiss
-
-       !correct for step integration error
-       f_lay_emiss(:)=f_lay_emiss(:)/f_lay_sum
-
-END SUBROUTINE STRATDISTRIB
Index: /LMDZ6/trunk/libf/phylmd/StratAer/stratdistrib.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/StratAer/stratdistrib.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/StratAer/stratdistrib.f90	(revision 5268)
@@ -0,0 +1,68 @@
+!
+! $Id: stratemit.F90  2022-07-04 mmarchand $
+!
+SUBROUTINE STRATDISTRIB(altLMDz,altemiss,sigma_alt,f_lay_emiss)
+!
+  USE dimphy, ONLY : klon,klev
+  USE strataer_local_var_mod
+  USE yomcst_mod_h, only : RPI
+
+  IMPLICIT NONE
+
+! Input argument
+!---------------
+    REAL,DIMENSION(klev+1)  :: altLMDz    ! altitude of layer interfaces in m
+    REAL                    :: sigma_alt
+    REAL                    :: altemiss
+
+! Local variables
+!----------------
+    REAL                 :: f_lay_sum     ! sum of layer emission fractions
+    REAL                 :: alt
+    INTEGER              :: k,i_int
+    INTEGER,PARAMETER    :: n_int_alt=10  ! subintervals nb for integration over Gaussian emission
+
+! Output argument
+!----------------
+    REAL,DIMENSION(klev) :: f_lay_emiss   ! emiss fraction for every emiss for every vertical layer
+    
+    
+! Inject distrib
+!----------------
+    SELECT CASE(flag_emit_distrib)
+       
+    CASE(0) ! Gaussian distribution
+            ! Compute distribution of emission to vertical model layers
+            ! (based on Gaussian peak in altitude)
+       f_lay_sum=0.0
+       DO k=1, klev
+          f_lay_emiss(k)=0.0
+          DO i_int=1, n_int_alt
+             alt=altLMDz(k)+float(i_int)*(altLMDz(k+1)-altLMDz(k))/float(n_int_alt)
+             f_lay_emiss(k)=f_lay_emiss(k)+1./(sqrt(2.*RPI)*sigma_alt)* &
+                   & exp(-0.5*((alt-altemiss)/sigma_alt)**2.)* &           
+                   & (altLMDz(k+1)-altLMDz(k))/float(n_int_alt)
+          ENDDO
+          f_lay_sum=f_lay_sum+f_lay_emiss(k)
+        ENDDO
+        
+     CASE(1) ! Uniform distribution
+             ! In this case, parameter sigma_alt is considered
+             ! to be half the
+             ! height of the injection, centered around altemiss)
+       f_lay_sum=0.0
+       DO k=1, klev
+          f_lay_emiss(k)=max(min(altemiss+sigma_alt,altLMDz(k+1))- &
+                      & max(altemiss-sigma_alt, &
+                      & altLMDz(k)),0.)/(2.*sigma_alt)
+          f_lay_sum=f_lay_sum+f_lay_emiss(k)
+       ENDDO
+
+       END SELECT        ! End CASE over flag_emit_distrib)
+       
+       WRITE(*,*) "IN stratdistrib f_lay_emiss=",f_lay_emiss
+
+       !correct for step integration error
+       f_lay_emiss(:)=f_lay_emiss(:)/f_lay_sum
+
+END SUBROUTINE STRATDISTRIB
Index: DZ6/trunk/libf/phylmd/StratAer/stratemit.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/StratAer/stratemit.F90	(revision 5267)
+++ 	(revision )
@@ -1,162 +1,0 @@
-!
-! $Id: stratemit.F90  2022-07-04 mmarchand $
-!
-SUBROUTINE STRATEMIT(pdtphys,pdt,xlat,xlon,t_seri,pplay,paprs,tr_seri,&
-                    m_emiss_vol_daily,latmin,latmax,lonmin,lonmax,altemiss,sigma_alt,id_spec,&
-                    stretchlong,ispeci,id_species_total) 
-
-  USE dimphy, ONLY : klon,klev
-  USE strataer_local_var_mod
-  USE phys_cal_mod
-  USE phys_local_var_mod, ONLY: d_q_emiss
-  USE yomcst_mod_h, only : RD, RPI, RG
-  USE geometry_mod, ONLY : cell_area, boundslat
-  USE aerophys
-  USE infotrac_phy
-  USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
-  USE mod_grid_phy_lmdz, ONLY: nbp_lon
- 
-  IMPLICIT NONE
-
-! Input argument
-!---------------
-    REAL,INTENT(IN)    :: pdtphys, pdt               ! Pas d'integration pour la physique(seconde)
-    REAL,DIMENSION(klon),INTENT(IN)    :: xlat       ! latitudes pour chaque point
-    REAL,DIMENSION(klon),INTENT(IN)    :: xlon       ! longitudes pour chaque point
-    REAL,DIMENSION(klon,klev),INTENT(IN)   :: pplay
-    ! pression pour le mileu de chaque couche (en Pa)
-    REAL,DIMENSION(klon,klev+1),INTENT(IN) :: paprs
-    ! pression pour chaque inter-couche (en Pa)
-    REAL,DIMENSION(klon,klev),INTENT(IN)   :: t_seri ! Temperature
-    REAL,INTENT(IN)    :: latmin,latmax,lonmin,lonmax
-    REAL,INTENT(IN)    :: m_emiss_vol_daily          ! daily injection mass emission
-    REAL,INTENT(IN)    :: stretchlong                ! length to stretch emission (day)
-    REAL,DIMENSION(klon,klev) :: m_air_gridbox       ! mass ofair in every grid box[kg
-    REAL,INTENT(IN)     :: sigma_alt, altemiss
-    INTEGER,INTENT(IN)  :: id_spec, ispeci, id_species_total
-    
-! Output argument
-!----------------
-    REAL,DIMENSION(klon,klev,nbtr),INTENT(INOUT)  :: tr_seri ! Concentration Traceur [U/KgA]
-! Local variables
-!----------------
-    INTEGER              :: ieru, i, k, i_int, ilon, ilev
-    REAL                 :: dlat_loc
-    REAL,DIMENSION(klev+1)  :: altLMDz    ! altitude of layer interfaces in m
-    REAL                 :: zrho          ! Density of air [kg/m3]
-    REAL,DIMENSION(klev) :: zdm           ! mass of atm. model layer in kg  
-    REAL                 :: zdz           ! thickness of atm. model layer in m
-    REAL                 :: f_lay_sum     ! sum of layer emission fractions
-    REAL,DIMENSION(klev) :: f_lay_emiss   ! emiss fraction for every emiss for every vertical layer
-    REAL                 :: emission      ! emission
-    REAL                 :: theta_min, theta_max, theta ! for SAI computation between two latitudes
-    
-    IF (is_mpi_root) THEN
-       WRITE(*,*) 'IN STRATEMIT: date from phys_cal_mod=',year_cur,'-',&
-                      &  mth_cur,'-',day_cur,'-',hour,' flh2o=',flh2o
-    ENDIF
-
-!--calculate mass of air in every grid box !NL: DONE ABOVE DIRECTLY IN MAIN LOOP I,K
-!    DO ilon=1, klon
-!       DO ilev=1, klev
-!          m_air_gridbox(ilon,ilev)=(paprs(ilon,ilev)-paprs(ilon,ilev+1))/RG*cell_area(ilon)
-!       ENDDO
-!    ENDDO
-    
-    DO i=1,klon
-       
-       dlat_loc=180./RPI/2.*(boundslat(i,1)-boundslat(i,3))
-       dlon=360./2./FLOAT(nbp_lon) 
-       ! dlat = half difference of boundary latitudes
-       IF(flag_verbose_strataer) WRITE(*,*) 'IN STRATEMIT, dlat=',dlat_loc,xlat(i),xlon(i)
-       
-       theta_min = max(xlat(i)-dlat_loc,latmin)
-       theta_max = min(xlat(i)+dlat_loc,latmax)
-                
-       IF (  xlat(i).GE.latmin-dlat_loc .AND. &
-         &   xlat(i).LT.latmax+dlat_loc .AND. &
-         &   xlon(i).GE.lonmin-dlon .AND. &
-         &   xlon(i).LT.lonmax+dlon ) THEN
-                   !
-          WRITE(*,*) 'coordinates of volcanic injection point=',&
-            &    xlat(i),xlon(i),day_cur,mth_cur,year_cur
-          WRITE(*,*) 'DD m_emiss_vol_daily=', &
-            &    m_emiss_vol_daily
-          
-          !compute altLMDz
-          altLMDz(:)=0.0
-          DO k=1, klev
-             zrho=pplay(i,k)/t_seri(i,k)/RD       !air density in kg/m3
-             zdm(k)=(paprs(i,k)-paprs(i,k+1))/RG  !mass of layer in kg
-             zdz=zdm(k)/zrho                   !thickness of layer in m
-             altLMDz(k+1)=altLMDz(k)+zdz       !altitude of interface
-          ENDDO
-          
-          CALL STRATDISTRIB(altLMDz,altemiss,sigma_alt,f_lay_emiss)
-          
-          IF (flag_emit.EQ.3) then
-             theta=(sin(theta_max/180.*RPI)-sin(theta_min/180.*RPI))/ &
-               & (sin(xlat_max_sai/180.*RPI)-sin(xlat_min_sai/180.*RPI))
-          ELSE
-             theta=1.
-          ENDIF
-
-          !vertically distributed emission
-          DO k=1, klev
-            !--calculate mass of air in every grid box
-            m_air_gridbox(i,k)=(paprs(i,k)-paprs(i,k+1))/RG*cell_area(i)
-            ! stretch emission over stretchlong period
-            emission=m_emiss_vol_daily/m_air_gridbox(i,k)*f_lay_emiss(k)/stretchlong/ &
-                 &     (86400.-pdt)*theta
-            
-             IF(flag_verbose_strataer) WRITE(*,*) 'IN STRATEMIT: emission avant/apres', &
-              &  'alt= ', altLMDz(k), &
-              &  'flh2o= ',flh2o, &
-              &  'id_speac= ',id_spec,id_species_total, &
-              &  'emission= ',emission, &
-              &  'pdtphys= ',pdtphys, &
-              &  'rapport m_emiss/m_air*f_lay= ', m_emiss_vol_daily/m_air_gridbox(i,k)*f_lay_emiss(k), &
-              &   'stretchlong= ', stretchlong, &
-              &   'theta= ', theta
-             
-             IF(emission < 1.E-34) emission = 0.0
-             
-             IF (flh2o.EQ.0) THEN
-                IF(flag_verbose_strataer) WRITE(*,*) 'IN STRATEMIT: tr_ser avant/apres',&
-                  &  'i= ',i,'k= ',k, 'flh2o= ',flh2o, &
-                  &  tr_seri(i,k,id_spec), &
-                  &  tr_seri(i,k,id_spec)+emission*pdtphys
-              
-                tr_seri(i,k,id_spec)=tr_seri(i,k,id_spec)+emission*pdtphys
-                IF (id_species_total.NE.0) THEN
-                   tr_seri(i,k,id_species_total)=tr_seri(i,k,id_species_total)+emission*pdtphys
-                ENDIF
-             ELSE IF(flh2o.EQ.1) THEN
-                d_q_emiss(i,k)=emission*pdtphys
-                IF(d_q_emiss(i,k) > 1.E34) THEN
-                   WRITE(*,*) 'IN STRATEMIT: d_q_emiss(i,k) > 1.E34 = ',d_q_emiss(i,k)
-                ELSE IF(d_q_emiss(i,k) < -1.E34) THEN
-                   WRITE(*,*) 'IN STRATEMIT: d_q_emiss(i,k) < -1.E34 = ',d_q_emiss(i,k)
-                ENDIF
-                
-                IF(flag_verbose_strataer) WRITE(*,*) 'IN STRATEMIT: ',&
-                     &  'i= ',i,'k= ',k, 'flh2o= ',flh2o, &
-                     &  'emission= ',emission, &
-                     &  'd_q_emiss(i,k)= ',d_q_emiss(i,k)
-                
-                IF(d_q_emiss(i,k) > 1.E34) THEN
-                   d_q_emiss(i,k) = 1.E34
-                   WRITE(*,*) 'IN STRATEMIT: d_q_emiss(i,k) > 1.E34 : ',d_q_emiss(i,k)
-                ELSE IF(d_q_emiss(i,k) < -1.E34) THEN
-                   d_q_emiss(i,k) = -1.E34
-                   WRITE(*,*) 'IN STRATEMIT: d_q_emiss(i,k) < -1.E34 : ',d_q_emiss(i,k)
-                ENDIF
-             ENDIF
-             budg_emi(i,ispeci)=budg_emi(i,ispeci)+emission*zdm(k)
-          ENDDO
-          
-       ENDIF ! emission grid cell
-
-    ENDDO ! klon loop
-
-END SUBROUTINE STRATEMIT
Index: /LMDZ6/trunk/libf/phylmd/StratAer/stratemit.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/StratAer/stratemit.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/StratAer/stratemit.f90	(revision 5268)
@@ -0,0 +1,162 @@
+!
+! $Id: stratemit.F90  2022-07-04 mmarchand $
+!
+SUBROUTINE STRATEMIT(pdtphys,pdt,xlat,xlon,t_seri,pplay,paprs,tr_seri,&
+                    m_emiss_vol_daily,latmin,latmax,lonmin,lonmax,altemiss,sigma_alt,id_spec,&
+                    stretchlong,ispeci,id_species_total) 
+
+  USE dimphy, ONLY : klon,klev
+  USE strataer_local_var_mod
+  USE phys_cal_mod
+  USE phys_local_var_mod, ONLY: d_q_emiss
+  USE yomcst_mod_h, only : RD, RPI, RG
+  USE geometry_mod, ONLY : cell_area, boundslat
+  USE aerophys
+  USE infotrac_phy
+  USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+  USE mod_grid_phy_lmdz, ONLY: nbp_lon
+ 
+  IMPLICIT NONE
+
+! Input argument
+!---------------
+    REAL,INTENT(IN)    :: pdtphys, pdt               ! Pas d'integration pour la physique(seconde)
+    REAL,DIMENSION(klon),INTENT(IN)    :: xlat       ! latitudes pour chaque point
+    REAL,DIMENSION(klon),INTENT(IN)    :: xlon       ! longitudes pour chaque point
+    REAL,DIMENSION(klon,klev),INTENT(IN)   :: pplay
+    ! pression pour le mileu de chaque couche (en Pa)
+    REAL,DIMENSION(klon,klev+1),INTENT(IN) :: paprs
+    ! pression pour chaque inter-couche (en Pa)
+    REAL,DIMENSION(klon,klev),INTENT(IN)   :: t_seri ! Temperature
+    REAL,INTENT(IN)    :: latmin,latmax,lonmin,lonmax
+    REAL,INTENT(IN)    :: m_emiss_vol_daily          ! daily injection mass emission
+    REAL,INTENT(IN)    :: stretchlong                ! length to stretch emission (day)
+    REAL,DIMENSION(klon,klev) :: m_air_gridbox       ! mass ofair in every grid box[kg
+    REAL,INTENT(IN)     :: sigma_alt, altemiss
+    INTEGER,INTENT(IN)  :: id_spec, ispeci, id_species_total
+    
+! Output argument
+!----------------
+    REAL,DIMENSION(klon,klev,nbtr),INTENT(INOUT)  :: tr_seri ! Concentration Traceur [U/KgA]
+! Local variables
+!----------------
+    INTEGER              :: ieru, i, k, i_int, ilon, ilev
+    REAL                 :: dlat_loc
+    REAL,DIMENSION(klev+1)  :: altLMDz    ! altitude of layer interfaces in m
+    REAL                 :: zrho          ! Density of air [kg/m3]
+    REAL,DIMENSION(klev) :: zdm           ! mass of atm. model layer in kg  
+    REAL                 :: zdz           ! thickness of atm. model layer in m
+    REAL                 :: f_lay_sum     ! sum of layer emission fractions
+    REAL,DIMENSION(klev) :: f_lay_emiss   ! emiss fraction for every emiss for every vertical layer
+    REAL                 :: emission      ! emission
+    REAL                 :: theta_min, theta_max, theta ! for SAI computation between two latitudes
+    
+    IF (is_mpi_root) THEN
+       WRITE(*,*) 'IN STRATEMIT: date from phys_cal_mod=',year_cur,'-',&
+                      &  mth_cur,'-',day_cur,'-',hour,' flh2o=',flh2o
+    ENDIF
+
+!--calculate mass of air in every grid box !NL: DONE ABOVE DIRECTLY IN MAIN LOOP I,K
+!    DO ilon=1, klon
+!       DO ilev=1, klev
+!          m_air_gridbox(ilon,ilev)=(paprs(ilon,ilev)-paprs(ilon,ilev+1))/RG*cell_area(ilon)
+!       ENDDO
+!    ENDDO
+    
+    DO i=1,klon
+       
+       dlat_loc=180./RPI/2.*(boundslat(i,1)-boundslat(i,3))
+       dlon=360./2./FLOAT(nbp_lon) 
+       ! dlat = half difference of boundary latitudes
+       IF(flag_verbose_strataer) WRITE(*,*) 'IN STRATEMIT, dlat=',dlat_loc,xlat(i),xlon(i)
+       
+       theta_min = max(xlat(i)-dlat_loc,latmin)
+       theta_max = min(xlat(i)+dlat_loc,latmax)
+                
+       IF (  xlat(i).GE.latmin-dlat_loc .AND. &
+         &   xlat(i).LT.latmax+dlat_loc .AND. &
+         &   xlon(i).GE.lonmin-dlon .AND. &
+         &   xlon(i).LT.lonmax+dlon ) THEN
+                   !
+          WRITE(*,*) 'coordinates of volcanic injection point=',&
+            &    xlat(i),xlon(i),day_cur,mth_cur,year_cur
+          WRITE(*,*) 'DD m_emiss_vol_daily=', &
+            &    m_emiss_vol_daily
+          
+          !compute altLMDz
+          altLMDz(:)=0.0
+          DO k=1, klev
+             zrho=pplay(i,k)/t_seri(i,k)/RD       !air density in kg/m3
+             zdm(k)=(paprs(i,k)-paprs(i,k+1))/RG  !mass of layer in kg
+             zdz=zdm(k)/zrho                   !thickness of layer in m
+             altLMDz(k+1)=altLMDz(k)+zdz       !altitude of interface
+          ENDDO
+          
+          CALL STRATDISTRIB(altLMDz,altemiss,sigma_alt,f_lay_emiss)
+          
+          IF (flag_emit.EQ.3) then
+             theta=(sin(theta_max/180.*RPI)-sin(theta_min/180.*RPI))/ &
+               & (sin(xlat_max_sai/180.*RPI)-sin(xlat_min_sai/180.*RPI))
+          ELSE
+             theta=1.
+          ENDIF
+
+          !vertically distributed emission
+          DO k=1, klev
+            !--calculate mass of air in every grid box
+            m_air_gridbox(i,k)=(paprs(i,k)-paprs(i,k+1))/RG*cell_area(i)
+            ! stretch emission over stretchlong period
+            emission=m_emiss_vol_daily/m_air_gridbox(i,k)*f_lay_emiss(k)/stretchlong/ &
+                 &     (86400.-pdt)*theta
+            
+             IF(flag_verbose_strataer) WRITE(*,*) 'IN STRATEMIT: emission avant/apres', &
+              &  'alt= ', altLMDz(k), &
+              &  'flh2o= ',flh2o, &
+              &  'id_speac= ',id_spec,id_species_total, &
+              &  'emission= ',emission, &
+              &  'pdtphys= ',pdtphys, &
+              &  'rapport m_emiss/m_air*f_lay= ', m_emiss_vol_daily/m_air_gridbox(i,k)*f_lay_emiss(k), &
+              &   'stretchlong= ', stretchlong, &
+              &   'theta= ', theta
+             
+             IF(emission < 1.E-34) emission = 0.0
+             
+             IF (flh2o.EQ.0) THEN
+                IF(flag_verbose_strataer) WRITE(*,*) 'IN STRATEMIT: tr_ser avant/apres',&
+                  &  'i= ',i,'k= ',k, 'flh2o= ',flh2o, &
+                  &  tr_seri(i,k,id_spec), &
+                  &  tr_seri(i,k,id_spec)+emission*pdtphys
+              
+                tr_seri(i,k,id_spec)=tr_seri(i,k,id_spec)+emission*pdtphys
+                IF (id_species_total.NE.0) THEN
+                   tr_seri(i,k,id_species_total)=tr_seri(i,k,id_species_total)+emission*pdtphys
+                ENDIF
+             ELSE IF(flh2o.EQ.1) THEN
+                d_q_emiss(i,k)=emission*pdtphys
+                IF(d_q_emiss(i,k) > 1.E34) THEN
+                   WRITE(*,*) 'IN STRATEMIT: d_q_emiss(i,k) > 1.E34 = ',d_q_emiss(i,k)
+                ELSE IF(d_q_emiss(i,k) < -1.E34) THEN
+                   WRITE(*,*) 'IN STRATEMIT: d_q_emiss(i,k) < -1.E34 = ',d_q_emiss(i,k)
+                ENDIF
+                
+                IF(flag_verbose_strataer) WRITE(*,*) 'IN STRATEMIT: ',&
+                     &  'i= ',i,'k= ',k, 'flh2o= ',flh2o, &
+                     &  'emission= ',emission, &
+                     &  'd_q_emiss(i,k)= ',d_q_emiss(i,k)
+                
+                IF(d_q_emiss(i,k) > 1.E34) THEN
+                   d_q_emiss(i,k) = 1.E34
+                   WRITE(*,*) 'IN STRATEMIT: d_q_emiss(i,k) > 1.E34 : ',d_q_emiss(i,k)
+                ELSE IF(d_q_emiss(i,k) < -1.E34) THEN
+                   d_q_emiss(i,k) = -1.E34
+                   WRITE(*,*) 'IN STRATEMIT: d_q_emiss(i,k) < -1.E34 : ',d_q_emiss(i,k)
+                ENDIF
+             ENDIF
+             budg_emi(i,ispeci)=budg_emi(i,ispeci)+emission*zdm(k)
+          ENDDO
+          
+       ENDIF ! emission grid cell
+
+    ENDDO ! klon loop
+
+END SUBROUTINE STRATEMIT
Index: DZ6/trunk/libf/phylmd/StratAer/sulfate_aer_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/StratAer/sulfate_aer_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,1062 +1,0 @@
-MODULE sulfate_aer_mod
-
-! microphysical routines based on UPMC aerosol model by Slimane Bekki
-! adapted for stratospheric sulfate aerosol in LMDZ by Christoph Kleinschmitt 
-
-CONTAINS
-
-!*******************************************************************
-      SUBROUTINE STRACOMP_KELVIN(sh,t_seri,pplay)
-!
-!     Aerosol H2SO4 weight fraction as a function of PH2O and temperature
-!     INPUT:
-!     sh: MMR of H2O
-!     t_seri: temperature (K)
-!     pplay: middle layer pression (Pa)
-!
-!     Modified in modules:
-!     R2SO4: aerosol H2SO4 weight fraction (percent)
-!     R2SO4B: aerosol H2SO4 weight fraction (percent) for each aerosol bin
-!     DENSO4: aerosol density (gr/cm3)
-!     DENSO4B: aerosol density (gr/cm3)for each aerosol bin
-!     f_r_wet: factor for converting dry to wet radius 
-!        assuming 'flat surface' composition (does not depend on aerosol size)
-!     f_r_wetB: factor for converting dry to wet radius 
-!        assuming 'curved surface' composition (depends on aerosol size)
-    
-      USE dimphy, ONLY : klon,klev ! nb of longitude and altitude bands
-      USE infotrac_phy, ONLY : nbtr_bin
-      USE aerophys
-      USE phys_local_var_mod, ONLY: R2SO4, R2SO4B, DENSO4, DENSO4B, f_r_wet, f_r_wetB
-      USE strataer_local_var_mod, ONLY: RRSI
-!     WARNING: in phys_local_var_mod R2SO4B, DENSO4B, f_r_wetB (klon,klev,nbtr_bin)
-!          and dens_aer_dry must be declared somewhere
-    
-      IMPLICIT NONE
-    
-      REAL,DIMENSION(klon,klev),INTENT(IN)    :: t_seri  ! Temperature
-      REAL,DIMENSION(klon,klev),INTENT(IN)    :: pplay   ! pression in the middle of each layer (Pa)
-      REAL,DIMENSION(klon,klev),INTENT(IN)    :: sh      ! specific humidity (kg h2o/kg air)
-      
-!     local variables
-      integer         :: ilon,ilev,ik
-      real, parameter :: rath2oair = mAIRmol/mH2Omol  
-      real, parameter :: third = 1./3.
-      real            :: pph2ogas(klon,klev) 
-      real            :: temp, wpp, xa, surtens, mvh2o, radwet, fkelvin, pph2okel, r2so4ik, denso4ik
-!----------------------------------------
-  
-!     gas-phase h2o partial pressure (Pa) 
-!                                vmr=sh*rath2oair
-      pph2ogas(:,:) = pplay(:,:)*sh(:,:)*rath2oair
-    
-      DO ilon=1,klon
-      DO ilev=1,klev
-          
-        temp = max(t_seri(ilon,ilev),190.)
-        temp = min(temp,300.)
-
-!    ***   H2SO4-H2O flat surface ***
-!!       equilibrium H2O pressure over pure flat liquid water (Pa)
-!!        pflath2o=psh2o(temp)
-!       h2so4 weight percent(%) = f(P_h2o(Pa),T)
-        R2SO4(ilon,ilev)=wph2so4(pph2ogas(ilon,ilev),temp)  
-!       h2so4 mass fraction (0<wpp<1)
-        wpp=R2SO4(ilon,ilev)*1.e-2     
-!       mole fraction
-        xa=18.*wpp/(18.*wpp+98.*(1.-wpp))
-
-!        CHECK:compare h2so4 sat/ pressure (see Marti et al., 97 & reef. therein)
-!               R2SO4(ilon,ilev)=70.    temp=298.15
-!        equilibrium h2so4 number density over H2SO4/H2O solution (molec/cm3)
-!        include conversion from molec/cm3 to Pa
-!        ph2so4=solh2so4(temp,xa)*(1.38065e-16*temp)/10.
-!        print*,' ph2so4=',ph2so4,temp,R2SO4(ilon,ilev)
-!        good match with Martin, et Ayers, not with Gmitro (the famous 0.086)
-
-!       surface tension (mN/m=1.e-3.kg/s2) = f(T,h2so4 mole fraction)
-        surtens=surftension(temp,xa)
-!       molar volume of pure h2o (cm3.mol-1 =1.e-6.m3.mol-1)
-        mvh2o= rmvh2o(temp)
-!       aerosol density (gr/cm3) = f(T,h2so4 mass fraction)
-        DENSO4(ilon,ilev)=density(temp,wpp) 
-!           ->x1000., to have it in kg/m3
-!       factor for converting dry to wet radius
-        f_r_wet(ilon,ilev) = (dens_aer_dry/(DENSO4(ilon,ilev)*1.e3)/ & 
-                   &    (R2SO4(ilon,ilev)*1.e-2))**third
-!    ***   End of H2SO4-H2O flat surface ***
-
-
-!          Loop on bin radius (RRSI in cm)
-           DO IK=1,nbtr_bin 
- 
-!      ***   H2SO4-H2O curved surface - Kelvin effect factor ***
-!            wet radius (m) (RRSI(IK) in [cm])
-             if (f_r_wetB(ilon,ilev,IK) .gt. 1.0) then 
-               radwet = 1.e-2*RRSI(IK)*f_r_wetB(ilon,ilev,IK)
-             else 
-!              H2SO4-H2O flat surface, only on the first timestep
-               radwet = 1.e-2*RRSI(IK)*f_r_wet(ilon,ilev)
-             endif
-!            Kelvin factor: 
-!            surface tension (mN/m=1.e-3.kg/s2) 
-!            molar volume of pure h2o (cm3.mol-1 =1.e-6.m3.mol-1)
-             fkelvin=exp( 2.*1.e-3*surtens*1.e-6*mvh2o/ (radwet*rgas*temp) )
-!            equilibrium: pph2o(gas) = pph2o(liq) = pph2o(liq_flat) * fkelvin
-!            equilibrium: pph2o(liq_flat) = pph2o(gas) / fkelvin
-!            h2o liquid partial pressure before Kelvin effect (Pa)
-             pph2okel = pph2ogas(ilon,ilev) / fkelvin
-!            h2so4 weight percent(%) = f(P_h2o(Pa),temp)
-             r2so4ik=wph2so4(pph2okel,temp)
-!            h2so4 mass fraction (0<wpp<1)
-             wpp=r2so4ik*1.e-2    
-!            mole fraction
-             xa=18.*wpp/(18.*wpp+98.*(1.-wpp)) 
-!            aerosol density (gr/cm3) = f(T,h2so4 mass fraction)
-             denso4ik=density(temp,wpp)
-!           
-!            recalculate Kelvin factor with surface tension and radwet 
-!                              with new R2SO4B and DENSO4B
-             surtens=surftension(temp,xa)
-!            wet radius (m)
-             radwet = 1.e-2*RRSI(IK)*(dens_aer_dry/(denso4ik*1.e3)/ & 
-                   &    (r2so4ik*1.e-2))**third
-             fkelvin=exp( 2.*1.e-3*surtens*1.e-6*mvh2o / (radwet*rgas*temp) ) 
-             pph2okel=pph2ogas(ilon,ilev) / fkelvin
-!            h2so4 weight percent(%) = f(P_h2o(Pa),temp)
-             R2SO4B(ilon,ilev,IK)=wph2so4(pph2okel,temp)
-!            h2so4 mass fraction (0<wpp<1)
-             wpp=R2SO4B(ilon,ilev,IK)*1.e-2    
-             xa=18.*wpp/(18.*wpp+98.*(1.-wpp)) 
-!            aerosol density (gr/cm3) = f(T,h2so4 mass fraction)
-             DENSO4B(ilon,ilev,IK)=density(temp,wpp)
-!            factor for converting dry to wet radius
-             f_r_wetB(ilon,ilev,IK) = (dens_aer_dry/(DENSO4B(ilon,ilev,IK)*1.e3)/ & 
-                   &    (R2SO4B(ilon,ilev,IK)*1.e-2))**third
-!
-!             print*,'R,Rwet(m),kelvin,h2so4(%),ro=',RRSI(ik),radwet,fkelvin, &
-!              &  R2SO4B(ilon,ilev,IK),DENSO4B(ilon,ilev,IK)
-!             print*,' equil.h2so4(molec/cm3), & 
-!              & sigma',solh2so4(temp,xa),surftension(temp,xa)
-
-           ENDDO
-
-      ENDDO
-      ENDDO
-
-      RETURN
-    
-  END SUBROUTINE STRACOMP_KELVIN
-!********************************************************************
-    SUBROUTINE STRACOMP(sh,t_seri,pplay)
-
-!   AEROSOL H2SO4 WEIGHT FRACTION AS A FUNCTION OF PH2O AND TEMPERATURE
-!   ----------------------------------------------------------------
-!   INPUT: 
-!   H2O: VMR of H2O
-!   t_seri: temperature (K)
-!   PMB: pressure (mb)
-!   klon: number of latitude bands in the model domain
-!   klev: number of altitude bands in the model domain
-!   for IFS: perhaps add another dimension for longitude
-!
-!   OUTPUT: 
-!   R2SO4: aerosol H2SO4 weight fraction (percent)
- 
-    USE dimphy, ONLY : klon,klev
-    USE aerophys
-    USE phys_local_var_mod, ONLY: R2SO4
-
-    IMPLICIT NONE
-
-    REAL,DIMENSION(klon,klev),INTENT(IN)          :: t_seri  ! Temperature
-    REAL,DIMENSION(klon,klev),INTENT(IN)          :: pplay   ! pression pour le mileu de chaque couche (en Pa)
-    REAL,DIMENSION(klon,klev),INTENT(IN)          :: sh      ! humidite specifique
-     
-    REAL PMB(klon,klev), H2O(klon,klev)
-!
-!   working variables
-    INTEGER I,J,K
-    REAL TP, PH2O, VAL, A, B
-!     local variables to be saved on exit
-    INTEGER INSTEP
-    INTEGER, PARAMETER :: N=16, M=28
-    DATA INSTEP/0/
-    REAL F(N,M)
-    REAL XC(N)
-    REAL YC(M)
-    REAL XC1, XC16, YC1, YC28
-!
-    SAVE INSTEP,F,XC,YC,XC1,XC16,YC1,YC28
-!$OMP THREADPRIVATE(INSTEP,F,XC,YC,XC1,XC16,YC1,YC28)
-
-! convert pplay (in Pa) to PMB (in mb)
-    PMB(:,:)=pplay(:,:)/100.0
-
-! convert specific humidity sh (in kg/kg) to VMR H2O
-    H2O(:,:)=sh(:,:)*mAIRmol/mH2Omol
-
-    IF(INSTEP.EQ.0) THEN
-    
-       INSTEP=1
-       XC(1)=0.01
-       XC(2)=0.1
-       XC(3)=0.5
-       XC(4)=1.0
-       XC(5)=1.5
-       XC(6)=2.0
-       XC(7)=3.0
-       XC(8)=5.0
-       XC(9)=6.0
-       XC(10)=8.0
-       XC(11)=10.0
-       XC(12)=12.0
-       XC(13)=15.0
-       XC(14)=20.0
-       XC(15)=30.0
-       XC(16)=100.0
-!
-       YC(1)=175.0
-       DO I=2,28
-         YC(I)=YC(I-1)+5.0
-       ENDDO
-
-!      CONVERSION mb IN 1.0E-4mB
-       DO I=1,16
-         XC(I)=XC(I)*1.0E-4
-       ENDDO
-!
-       XC1=XC(1)+1.E-10
-       XC16=XC(16)-1.E-8
-       YC1=YC(1)+1.E-5
-       YC28=YC(28)-1.E-5
-
-       F(6,4)=43.45
-       F(6,5)=53.96
-       F(6,6)=60.62
-       F(6,7)=65.57
-       F(6,8)=69.42
-       F(6,9)=72.56
-       F(6,10)=75.17
-       F(6,11)=77.38
-       F(6,12)=79.3
-       F(6,13)=80.99
-       F(6,14)=82.5
-       F(6,15)=83.92
-       F(6,16)=85.32
-       F(6,17)=86.79
-       F(6,18)=88.32
-!
-!      ADD FACTOR  BECAUSE THE SLOP IS TOO IMPORTANT
-!      NOT FOR THIS ONE BUT THE REST
-!      LOG DOESN'T WORK
-       A=(F(6,5)-F(6,4))/( (YC(5)-YC(4))*2.0)
-       B=-A*YC(4) + F(6,4)
-       F(6,1)=A*YC(1) + B
-       F(6,2)=A*YC(2) + B
-       F(6,3)=A*YC(3) + B
-!
-       F(7,4)=37.02
-       F(7,5)=49.46
-       F(7,6)=57.51
-       F(7,7)=63.12
-       F(7,8)=67.42
-       F(7,9)=70.85
-       F(7,10)=73.70
-       F(7,11)=76.09
-       F(7,12)=78.15
-       F(7,13)=79.96
-       F(7,14)=81.56
-       F(7,15)=83.02
-       F(7,16)=84.43
-       F(7,17)=85.85
-       F(7,18)=87.33
-!
-       A=(F(7,5)-F(7,4))/( (YC(5)-YC(4))*2.0)
-       B=-A*YC(4) + F(7,4)
-       F(7,1)=A*YC(1) + B
-       F(7,2)=A*YC(2) + B
-       F(7,3)=A*YC(3) + B
-!
-       F(8,4)=25.85
-       F(8,5)=42.26
-       F(8,6)=52.78
-       F(8,7)=59.55
-       F(8,8)=64.55
-       F(8,9)=68.45
-       F(8,10)=71.63
-       F(8,11)=74.29
-       F(8,12)=76.56
-       F(8,13)=78.53
-       F(8,14)=80.27
-       F(8,15)=81.83
-       F(8,16)=83.27
-       F(8,17)=84.67
-       F(8,18)=86.10
-!
-       A=(F(8,5)-F(8,4))/( (YC(5)-YC(4))*2.5 )
-       B=-A*YC(4) + F(8,4)
-       F(8,1)=A*YC(1) + B
-       F(8,2)=A*YC(2) + B
-       F(8,3)=A*YC(3) + B
-!
-       F(9,4)=15.38
-       F(9,5)=39.35
-       F(9,6)=50.73
-       F(9,7)=58.11
-       F(9,8)=63.41
-       F(9,9)=67.52
-       F(9,10)=70.83
-       F(9,11)=73.6
-       F(9,12)=75.95
-       F(9,13)=77.98
-       F(9,14)=79.77
-       F(9,15)=81.38
-       F(9,16)=82.84
-       F(9,17)=84.25
-       F(9,18)=85.66
-!
-       A=(F(9,5)-F(9,4))/( (YC(5)-YC(4))*7.0)
-       B=-A*YC(4) + F(9,4)
-       F(9,1)=A*YC(1) + B
-       F(9,2)=A*YC(2) + B
-       F(9,3)=A*YC(3) + B
-!
-       F(10,4)=0.0
-       F(10,5)=34.02
-       F(10,6)=46.93
-       F(10,7)=55.61
-       F(10,8)=61.47
-       F(10,9)=65.94
-       F(10,10)=69.49
-       F(10,11)=72.44
-       F(10,12)=74.93
-       F(10,13)=77.08
-       F(10,14)=78.96
-       F(10,15)=80.63
-       F(10,16)=82.15
-       F(10,17)=83.57
-       F(10,18)=84.97
-!
-       A=(F(10,6)-F(10,5))/( (YC(6)-YC(5))*1.5)
-       B=-A*YC(5) + F(10,5)
-       F(10,1)=A*YC(1) + B
-       F(10,2)=A*YC(2) + B
-       F(10,3)=A*YC(3) + B
-       F(10,4)=A*YC(4) + B
-!
-       F(11,4)=0.0
-       F(11,5)=29.02
-       F(11,6)=43.69
-       F(11,7)=53.44
-       F(11,8)=59.83
-       F(11,9)=64.62
-       F(11,10)=68.39
-       F(11,11)=71.48
-       F(11,12)=74.10
-       F(11,13)=76.33
-       F(11,14)=78.29
-       F(11,15)=80.02
-       F(11,16)=81.58
-       F(11,17)=83.03
-       F(11,18)=84.44
-!
-       A=(F(11,6)-F(11,5))/( (YC(6)-YC(5))*2.5 )
-       B=-A*YC(5) + F(11,5)
-       F(11,1)=A*YC(1) + B
-       F(11,2)=A*YC(2) + B
-       F(11,3)=A*YC(3) + B
-       F(11,4)=A*YC(4) + B
-!
-       F(12,4)=0.0
-       F(12,5)=23.13
-       F(12,6)=40.86
-       F(12,7)=51.44
-       F(12,8)=58.38
-       F(12,9)=63.47
-       F(12,10)=67.43
-       F(12,11)=70.66
-       F(12,12)=73.38
-       F(12,13)=75.70
-       F(12,14)=77.72
-       F(12,15)=79.51
-       F(12,16)=81.11
-       F(12,17)=82.58
-       F(12,18)=83.99
-!
-       A=(F(12,6)-F(12,5))/( (YC(6)-YC(5))*3.5 )
-       B=-A*YC(5) + F(12,5)
-       F(12,1)=A*YC(1) + B
-       F(12,2)=A*YC(2) + B
-       F(12,3)=A*YC(3) + B
-       F(12,4)=A*YC(4) + B
-!
-       F(13,4)=0.0
-       F(13,5)=0.0
-       F(13,6)=36.89
-       F(13,7)=48.63
-       F(13,8)=56.46
-       F(13,9)=61.96
-       F(13,10)=66.19
-       F(13,11)=69.6
-       F(13,12)=72.45
-       F(13,13)=74.89
-       F(13,14)=76.99
-       F(13,15)=78.85
-       F(13,16)=80.50
-       F(13,17)=82.02
-       F(13,18)=83.44
-!
-       A=(F(13,7)-F(13,6))/( (YC(7)-YC(6))*2.0)
-       B=-A*YC(6) + F(13,6)
-       F(13,1)=A*YC(1) + B
-       F(13,2)=A*YC(2) + B
-       F(13,3)=A*YC(3) + B
-       F(13,4)=A*YC(4) + B
-       F(13,5)=A*YC(5) + B
-!
-       F(14,4)=0.0
-       F(14,5)=0.0
-       F(14,6)=30.82
-       F(14,7)=44.49
-       F(14,8)=53.69
-       F(14,9)=59.83
-       F(14,10)=64.47
-       F(14,11)=68.15
-       F(14,12)=71.19
-       F(14,13)=73.77
-       F(14,14)=76.0
-       F(14,15)=77.95
-       F(14,16)=79.69
-       F(14,17)=81.26
-       F(14,18)=82.72
-!
-       A=(F(14,7)-F(14,6))/( (YC(7)-YC(6))*2.5 )
-       B=-A*YC(6) + F(14,6)
-       F(14,1)=A*YC(1) + B
-       F(14,2)=A*YC(2) + B
-       F(14,3)=A*YC(3) + B
-       F(14,4)=A*YC(4) + B
-       F(14,5)=A*YC(5) + B
-!
-       F(15,4)=0.0
-       F(15,5)=0.0
-       F(15,6)=0.0
-       F(15,7)=37.71
-       F(15,8)=48.49
-       F(15,9)=56.40
-       F(15,10)=61.75
-       F(15,11)=65.89
-       F(15,12)=69.25
-       F(15,13)=72.07
-       F(15,14)=74.49
-       F(15,15)=76.59
-       F(15,16)=78.45
-       F(15,17)=80.12
-       F(15,18)=81.64
-!
-       A=(F(15,8)-F(15,7))/( (YC(8)-YC(7))*1.5)
-       B=-A*YC(7) + F(15,7)
-       F(15,1)=A*YC(1) + B
-       F(15,2)=A*YC(2) + B
-       F(15,3)=A*YC(3) + B
-       F(15,4)=A*YC(4) + B
-       F(15,5)=A*YC(5) + B
-       F(15,6)=A*YC(6) + B
-
-!      SUPPOSE THAT AT GIVEN  AND PH2O<2mB,
-!      %H2SO4 = A *LOG(PH2O) +B
-!      XC(1-5) :EXTENSION LEFT (LOW H2O)
-       DO J=1,18
-         A=(F(6,J)-F(7,J))/(LOG(XC(6))-LOG(XC(7)))
-         B=-A*LOG(XC(6)) + F(6,J)
-         DO K=1,5
-           F(K,J)=A*LOG(XC(K)) + B
-         ENDDO
-       ENDDO
-
-!      XC(16) :EXTENSION RIGHT (HIGH H2O)
-       DO J=1,18
-         A=(F(15,J)-F(14,J))/(XC(15)-XC(14))
-         B=-A*XC(15) + F(15,J)
-       F(16,J)=A*XC(16) + B
-!       F(16,2)=1.0
-       ENDDO
-
-!      YC(16-25) :EXTENSION DOWN (HIGH T)
-       DO I=1,16
-         A=(F(I,18)-F(I,17))/(YC(18)-YC(17))
-         B=-A*YC(18) + F(I,18)
-         DO K=19,28
-         F(I,K)=A*YC(K) + B
-         ENDDO
-       ENDDO
-
-!      MANUAL CORRECTIONS
-       DO J=1,10
-       F(1,J)=94.0
-       ENDDO
-
-       DO J=1,6
-       F(2,J)=77.0 +REAL(J)
-       ENDDO
-
-       DO J=1,7
-       F(16,J)=9.0
-       ENDDO
-
-       DO I=1,16
-       DO J=1,28
-         IF (F(I,J).LT.9.0)  F(I,J)=30.0
-         IF (F(I,J).GT.99.99) F(I,J)=99.99
-       ENDDO
-       ENDDO
-      
-    ENDIF
-
-    DO I=1,klon
-    DO J=1,klev
-        TP=t_seri(I,J)
-        IF (TP.LT.175.1) TP=175.1
-!    Partial pressure of H2O (mb)
-        PH2O =PMB(I,J)*H2O(I,J)
-        IF (PH2O.LT.XC1) THEN 
-          R2SO4(I,J)=99.99
-!          PH2O=XC(1)+1.0E-10
-        ELSE 
-          IF (PH2O.GT.XC16) PH2O=XC16 
-!         SIMPLE LINEAR INTERPOLATIONS
-          CALL FIND(PH2O,TP,XC,YC,F,VAL,N,M)
-          IF (PMB(I,J).GE.10.0.AND.VAL.LT.60.0) VAL=60.0
-          R2SO4(I,J)=VAL
-        ENDIF
-    ENDDO
-    ENDDO
-
-    END SUBROUTINE
-
-!****************************************************************
-    SUBROUTINE STRAACT(ACTSO4)
-
-!   H2SO4 ACTIVITY (GIAUQUE) AS A FUNCTION OF H2SO4 WP
-!   ----------------------------------------
-!   INPUT: 
-!   H2SO4: VMR of H2SO4
-!   klon: number of latitude bands in the model domain
-!   klev: number of altitude bands in the model domain
-!   for IFS: perhaps add another dimension for longitude
-!
-!   OUTPUT: 
-!   ACTSO4: H2SO4 activity (percent)
- 
-    USE dimphy, ONLY : klon,klev
-    USE phys_local_var_mod, ONLY: R2SO4
-
-    IMPLICIT NONE
-     
-    REAL ACTSO4(klon,klev)
-   
-!   Working variables         
-    INTEGER NN,I,J,JX,JX1
-    REAL TC,TB,TA,XT
-    PARAMETER (NN=109)
-    REAL XC(NN),  X(NN)
-
-!   H2SO4 activity 
-    DATA X/ & 
-     &   0.0,0.25,0.78,1.437,2.19,3.07,4.03,5.04,6.08 & 
-     &  ,7.13,8.18,14.33,18.59,28.59,39.17,49.49 & 
-     &  ,102.4,157.8,215.7,276.9,341.6,409.8,481.5,556.6 & 
-     &  ,635.5,719.,808.,902.,1000.,1103.,1211.,1322.,1437.,1555. & 
-     &  ,1677.,1800.,1926.,2054.,2183.,2312.,2442.,2572.,2701.,2829. & 
-     &  ,2955.,3080.,3203.,3325.,3446.,3564.,3681.,3796.,3910.,4022. & 
-     &  ,4134.,4351.,4564.,4771.,4974.,5171.,5364.,5551.,5732.,5908. & 
-     &  ,6079.,6244.,6404.,6559.,6709.,6854.,6994.,7131.,7264.,7393. & 
-     &  ,7520.,7821.,8105.,8373.,8627.,8867.,9093.,9308.,9511.,9703. & 
-     &  ,9885.,10060.,10225.,10535.,10819.,11079.,11318.,11537. & 
-     &  ,11740.,12097.,12407.,12676.,12915.,13126.,13564.,13910. & 
-     &  ,14191.,14423.,14617.,14786.,10568.,15299.,15491.,15654. & 
-     &  ,15811./
-!   H2SO4 weight fraction (percent)
-    DATA XC/ & 
-     &   100.0,99.982,99.963,99.945,99.927,99.908,99.890,99.872 & 
-     &  ,99.853,99.835,99.817,99.725,99.634,99.452,99.270 & 
-     &  ,99.090,98.196,97.319,96.457,95.610,94.777,93.959,93.156 & 
-     &  ,92.365,91.588,90.824,90.073,89.334,88.607,87.892,87.188 & 
-     &  ,86.495,85.814,85.143,84.482,83.832,83.191,82.560,81.939 & 
-     &  ,81.327,80.724,80.130,79.545,78.968,78.399,77.839,77.286 & 
-     &  ,76.741,76.204,75.675,75.152,74.637,74.129,73.628,73.133 & 
-     &  ,72.164,71.220,70.300,69.404,68.530,67.678,66.847,66.037 & 
-     &  ,65.245,64.472,63.718,62.981,62.261,61.557,60.868,60.195 & 
-     &  ,59.537,58.893,58.263,57.646,56.159,54.747,53.405,52.126 & 
-     &  ,50.908,49.745,48.634,47.572,46.555,45.580,44.646,43.749 & 
-     &  ,42.059,40.495,39.043,37.691,36.430,35.251,33.107,31.209 & 
-     &  ,29.517,27.999,26.629,23.728,21.397,19.482,17.882,16.525 & 
-     &  ,15.360,13.461,11.980,10.792,9.819,8.932/
-
-    DO I=1,klon
-    DO J=1,klev
-!     HERE LINEAR INTERPOLATIONS
-        XT=R2SO4(I,J)
-        CALL POSACT(XT,XC,NN,JX)
-        JX1=JX+1
-        IF(JX.EQ.0) THEN
-          ACTSO4(I,J)=0.0 
-        ELSE IF(JX.GE.NN) THEN
-          ACTSO4(I,J)=15811.0 
-        ELSE 
-          TC=XT            -XC(JX)
-          TB=X(JX1)        -X(JX)
-          TA=XC(JX1)       -XC(JX)
-          TA=TB/TA
-          ACTSO4(I,J)=X(JX)  + TA*TC
-        ENDIF
-    ENDDO
-    ENDDO
-
-    END SUBROUTINE
-  
-!****************************************************************
-    SUBROUTINE DENH2SA(t_seri)
-
-!   AERSOL DENSITY AS A FUNCTION OF H2SO4 WEIGHT PERCENT AND T
-!   ---------------------------------------------
-!   VERY ROUGH APPROXIMATION (SEE FOR WATER IN HANDBOOK
-!   LINEAR 2% FOR 30 DEGREES with RESPECT TO WATER)
-!   
-!   INPUT: 
-!   R2SO4: aerosol H2SO4 weight fraction (percent)
-!   t_seri: temperature (K)
-!   klon: number of latitude bands in the model domain
-!   klev: number of altitude bands in the model domain
-!   for IFS: perhaps add another dimension for longitude
-!
-!   OUTPUT: 
-!   DENSO4: aerosol mass density (gr/cm3 = aerosol mass/aerosol volume)
-!   
-    USE dimphy, ONLY : klon,klev
-    USE phys_local_var_mod, ONLY: R2SO4, DENSO4
-
-    IMPLICIT NONE
-
-    REAL,DIMENSION(klon,klev),INTENT(IN)   :: t_seri  ! Temperature
-        
-    INTEGER I,J
-
-!   Loop on model domain (2 dimension for UPMC model; 3 for IFS)
-    DO I=1,klon
-    DO J=1,klev
-!     RO AT 20C
-      DENSO4(I,J)=0.78681252E-5*R2SO4(I,J)*R2SO4(I,J)+ 0.82185978E-2*R2SO4(I,J)+0.97968381
-      DENSO4(I,J)=DENSO4(I,J)* ( 1.0 - (t_seri(I,J)-293.0)*0.02/30.0 )
-    ENDDO
-    ENDDO
-
-    END SUBROUTINE
-
-!***********************************************************
-    SUBROUTINE FIND(X,Y,XC,YC,F,VAL,N,M)
-!
-!   BI-LINEAR INTERPOLATION
-
-!   INPUT: 
-!   X: Partial pressure of H2O (mb)
-!   Y: temperature (K)
-!   XC: Table partial pressure of H2O (mb)
-!   YC: Table temperature (K)
-!   F: Table aerosol H2SO4 weight fraction=f(XC,YC) (percent)
-!
-!   OUTPUT: 
-!   VAL: aerosol H2SO4 weight fraction (percent)
- 
-    IMPLICIT NONE
-   
-    INTEGER N,M
-    REAL X,Y,XC(N),YC(M),F(N,M),VAL
-!
-!   working variables
-    INTEGER  IERX,IERY,JX,JY,JXP1,JYP1
-    REAL SXY,SX1Y,SX1Y1,SXY1,TA,TB,T,UA,UB,U
-
-    IERX=0
-    IERY=0
-    CALL POSITION(XC,X,N,JX,IERX)
-    CALL POSITION(YC,Y,M,JY,IERY)
-
-    IF(JX.EQ.0.OR.IERY.EQ.1) THEN
-       VAL=99.99
-       RETURN
-    ENDIF
-
-    IF(JY.EQ.0.OR.IERX.EQ.1) THEN
-       VAL=9.0
-       RETURN
-    ENDIF
-
-    JXP1=JX+1
-    JYP1=JY+1
-    SXY=F(JX,  JY  )
-    SX1Y=F(JXP1,JY  )
-    SX1Y1=F(JXP1,JYP1)
-    SXY1=F(JX,  JYP1)
-
-!   x-slope.
-    TA=X       -XC(JX)
-    TB=XC(JXP1)-XC(JX)
-    T=TA/TB
-
-!   y-slope.
-    UA=Y       -YC(JY)
-    UB=YC(JYP1)-YC(JY)
-    U=UA/UB
-
-!   Use bilinear interpolation to determine function at point X,Y.
-    VAL=(1.-T)*(1.-U)*SXY + T*(1.0-U)*SX1Y + T*U*SX1Y1 + (1.0-T)*U*SXY1
-
-    IF(VAL.LT.9.0) VAL=9.0
-    IF(VAL.GT.99.99) VAL=99.99
-   
-    RETURN
-    END SUBROUTINE
-!****************************************************************
-       SUBROUTINE POSITION(XC,X,N,JX,IER)
- 
-       IMPLICIT NONE
-   
-       INTEGER N,JX,IER,I
-       REAL X,XC(N)
-
-       IER=0
-       IF(X.LT.XC(1)) THEN
-         JX=0
-       ELSE
-         DO 10 I=1,N
-           IF (X.LT.XC(I)) GO TO 20
- 10      CONTINUE
-         IER=1
- 20      JX=I-1
-       ENDIF
-
-       RETURN
-       END SUBROUTINE
-!********************************************************************
-       SUBROUTINE POSACT(XT,X,N,JX)
-   
-!      POSITION OF XT IN THE ARRAY X
-!    -----------------------------------------------
-   
-       IMPLICIT NONE
-   
-       INTEGER N
-       REAL XT,X(N)
-!      Working variables	  	   
-       INTEGER JX,I
-  
-       IF(XT.GT.X(1)) THEN
-         JX=0
-       ELSE
-         DO 10 I=1,N
-           IF (XT.GT.X(I)) GO TO 20
- 10      CONTINUE
- 20      JX=I
-       ENDIF
-   
-       RETURN
-       END SUBROUTINE
-!********************************************************************
-!-----------------------------------------------------------------------
-      real function psh2so4(T) result(psh2so4_out)
-!     equilibrium H2SO4 pressure over pure H2SO4 solution (Pa)
-!
-!---->Ayers et.al. (1980), GRL (7) pp 433-436
-!     plus corrections for lower temperatures by Kulmala and Laaksonen (1990)
-!     and Noppel et al. (1990)
-
-      implicit none
-      real, intent(in) :: T
-      real, parameter ::      &
-              &  b1=1.01325e5, &
-              &  b2=11.5,  &
-              &  b3=1.0156e4,  &
-              &  b4=0.38/545., &
-              &  tref=360.15
-
-!     saturation vapor pressure ( N/m2 = Pa = kg/(m.s2) )
-      psh2so4_out=b1*exp(  -b2 +b3*( 1./tref-1./T  &
-           &  +b4*(1.+log(tref/T)-tref/T) )   )  
-
-       return
-    end function psh2so4
-!-----------------------------------------------------------------------
-    real function ndsh2so4(T) result(ndsh2so4_out)
-!     equilibrium H2SO4 number density over pure H2SO4 (molec/cm3)
-
-      implicit none
-      real, intent(in) :: T
-      real :: presat
-
-!     Boltzmann constant ( 1.38065e-23 J/K = m2⋅kg/(s2⋅K) )
-!      akb idem in cm2⋅g/(s2⋅K) 
-      real, parameter :: akb=1.38065e-16
-
-!     pure h2so4 saturation vapor pressure (Pa)
-      presat=psh2so4(T)
-!     saturation number density (1/cm3) - (molec/cm3)
-      ndsh2so4_out=presat*10./(akb*T)
-
-       return
-     end function ndsh2so4
-!-----------------------------------------------------------------------
-     real function psh2o(T) result(psh2o_out)
-!     equilibrium H2O pressure over pure liquid water (Pa)
-!
-      implicit none
-      real, intent(in) :: T
-
-      if(T.gt.229.) then
-!        Preining et al., 1981 (from Kulmala et al., 1998)
-!        saturation vapor pressure (N/m2 = 1 Pa = 1 kg/(m·s2))
-         psh2o_out=exp( 77.34491296  -7235.424651/T &
-             &                 -8.2*log(T) + 5.7133e-3*T )
-      else
-!        Tabazadeh et al., 1997, parameterization for 185<T<260
-!        saturation water vapor partial pressure (mb = hPa =1.E2 kg/(m·s2))
-!        or from Clegg and Brimblecombe , J. Chem. Eng., p43, 1995.
-;
-         psh2o_out=18.452406985 -3505.1578807/T &
-              &    -330918.55082/(T*T)             &
-              &    +12725068.262/(T*T*T)
-!        in Pa
-         psh2o_out=100.*exp(psh2o_out)
-      end if
-!      print*,psh2o_out
-      
-       return
-     end function psh2o
-!-----------------------------------------------------------------------
-     real function density(T,so4mfrac) result(density_out)
-!        calculation of particle density (gr/cm3)
-
-!        requires Temperature (T) and acid mass fraction (so4mfrac)
-!---->Vehkamaeki et al. (2002)
-
-      implicit none
-      real, intent(in) :: T, so4mfrac
-      real, parameter :: &
-           &      a1= 0.7681724,&
-           &      a2= 2.184714, &
-           &      a3= 7.163002, &
-           &      a4=-44.31447, &
-           &      a5= 88.74606, &
-           &      a6=-75.73729, &
-           &      a7= 23.43228
-      real, parameter :: &
-           &      b1= 1.808225e-3, &
-           &      b2=-9.294656e-3, &
-           &      b3=-3.742148e-2, &
-           &      b4= 2.565321e-1, &
-           &      b5=-5.362872e-1, &
-           &      b6= 4.857736e-1, &
-           &      b7=-1.629592e-1
-      real, parameter :: &
-           &      c1=-3.478524e-6, &
-           &      c2= 1.335867e-5, &
-           &      c3= 5.195706e-5, &
-           &      c4=-3.717636e-4, &
-           &      c5= 7.990811e-4, &
-           &      c6=-7.458060e-4, &
-           &      c7= 2.581390e-4
-      real :: a,b,c,so4m2,so4m3,so4m4,so4m5,so4m6
-      
-      so4m2=so4mfrac*so4mfrac
-      so4m3=so4mfrac*so4m2
-      so4m4=so4mfrac*so4m3
-      so4m5=so4mfrac*so4m4
-      so4m6=so4mfrac*so4m5
-
-      a=+a1+a2*so4mfrac+a3*so4m2+a4*so4m3 &
-         &     +a5*so4m4+a6*so4m5+a7*so4m6
-      b=+b1+b2*so4mfrac+b3*so4m2+b4*so4m3 &
-         &     +b5*so4m4+b6*so4m5+b7*so4m6
-      c=+c1+c2*so4mfrac+c3*so4m2+c4*so4m3 &
-         &     +c5*so4m4+c6*so4m5+c7*so4m6
-      density_out=(a+b*T+c*T*T) ! units are gm/cm**3
-
-       return
-     end function density
-!-----------------------------------------------------------------------
-     real function surftension(T,so4frac) result(surftension_out)
-!        calculation of surface tension (mN/meter)
-!        requires Temperature (T) and acid mole fraction (so4frac)
-!---->Vehkamaeki et al. (2002)
-
-      implicit none
-      real,intent(in) :: T, so4frac
-      real :: a,b,so4mfrac,so4m2,so4m3,so4m4,so4m5,so4sig
-      real, parameter :: &
-            &     a1= 0.11864, &
-            &     a2=-0.11651, &
-            &     a3= 0.76852, &
-            &     a4=-2.40909, &
-            &     a5= 2.95434, &
-            &     a6=-1.25852
-      real, parameter :: &
-            &     b1=-1.5709e-4, &
-            &     b2= 4.0102e-4, &
-            &     b3=-2.3995e-3, &
-            &     b4= 7.611235e-3, &
-            &     b5=-9.37386e-3, &
-            &     b6= 3.89722e-3
-      real, parameter :: convfac=1.e3  ! convert from newton/m to dyne/cm
-      real, parameter :: Mw=18.01528, Ma=98.079
-
-!     so4 mass fraction
-      so4mfrac=Ma*so4frac/( Ma*so4frac+Mw*(1.-so4frac) )
-      so4m2=so4mfrac*so4mfrac
-      so4m3=so4mfrac*so4m2
-      so4m4=so4mfrac*so4m3
-      so4m5=so4mfrac*so4m4
-
-      a=+a1+a2*so4mfrac+a3*so4m2+a4*so4m3+a5*so4m4+a6*so4m5
-      b=+b1+b2*so4mfrac+b3*so4m2+b4*so4m3+b5*so4m4+b6*so4m5
-      so4sig=a+b*T
-      surftension_out=so4sig*convfac
-
-       return
-     end function surftension
-!-----------------------------------------------------------------------
-     real function wph2so4(pph2o,T) result(wph2so4_out)
-!     Calculates the equilibrium composition of h2so4 aerosols
-!     as a function of temperature and  H2O pressure, using
-!     the parameterization of Tabazadeh et al., GRL, p1931, 1997.
-!
-!   Parameters
-!
-!    input:
-!      T.....temperature (K)
-!      pph2o..... amhbiant 2o pressure (Pa)
-!
-!    output:
-!      wph2so4......sulfuric acid composition (weight percent wt % h2so4)
-!                     = h2so4 mass fraction*100.
-!
-      implicit none
-      real, intent(in) :: pph2o, T 
-      
-      real :: aw, rh, y1, y2, sulfmolal
-  
-!       psh2o(T): equilibrium H2O pressure over pure liquid water (Pa)
-!       relative humidity 
-        rh=pph2o/psh2o(T)
-!       water activity
-!        aw=min( 0.999,max(1.e-3,rh) )
-        aw=min( 0.999999999,max(1.e-8,rh) ) 
-
-!       composition
-!       calculation of h2so4 molality
-            if(aw .le. 0.05 .and. aw .gt. 0.) then
-               y1=12.372089320*aw**(-0.16125516114) &
-                 &  -30.490657554*aw -2.1133114241
-               y2=13.455394705*aw**(-0.19213122550) &
-                 &  -34.285174607*aw -1.7620073078
-            else if(aw .le. 0.85 .and. aw .gt. 0.05) then
-               y1=11.820654354*aw**(-0.20786404244) &
-                 &  -4.8073063730*aw -5.1727540348
-               y2=12.891938068*aw**(-0.23233847708) &
-                 &  -6.4261237757*aw -4.9005471319
-            else
-               y1=-180.06541028*aw**(-0.38601102592) &
-                 &  -93.317846778*aw +273.88132245
-               y2=-176.95814097*aw**(-0.36257048154) &
-                 &  -90.469744201*aw +267.45509988
-            end if
-!        h2so4 molality (m=moles of h2so4 (solute)/ kg of h2o(solvent))
-         sulfmolal = y1+((T-190.)*(y2-y1)/70.)
-
-!        for a solution containing mh2so4 and mh2o: 
-!        sulfmolal = (mh2so4(gr)/h2so4_molar_mass(gr/mole)) / (mh2o(gr)*1.e-3)
-!        mh2o=1.e3*(mh2so4/Mh2so4)/sulfmolal=1.e3*mh2so4/(Mh2so4*sulfmolal)
-!        h2so4_mass_fraction = mfh2so4 = mh2so4/(mh2o + mh2so4)
-!        mh2o=mh2so4*(1-mfh2so4)/mfh2so4
-!        combining the 2 equations
-!        1.e3*mh2so4/(Mh2so4*sulfmolal) = mh2so4*(1-mfh2so4)/mfh2so4
-!        1.e3/(Mh2so4*sulfmolal) = (1-mfh2so4)/mfh2so4
-!        1000*mfh2so4 = (1-mfh2so4)*Mh2so4*sulfmolal
-!        mfh2so4*(1000.+Mh2so4*sulfmolal) = Mh2so4*sulfmolal
-!        mfh2so4 = Mh2so4*sulfmolal / (1000.+Mh2so4*sulfmolal) 
-!        wph2so4 (% mass fraction)= 100.*Mh2so4*sulfmolal / (1000.+Mh2so4*sulfmolal) 
-!        recall activity of i = a_i = P_i/P_pure_i and 
-!          activity coefficient of i = gamma_i = a_i/X_i (X_i: mole fraction of i)
-!        so  P_i = gamma_i*X_i*P_pure_i
-!        if ideal solution, gamma_i=1, P_i = X_i*P_pure_i
-
-!        h2so4 weight precent
-         wph2so4_out = 9800.*sulfmolal/(98.*sulfmolal+1000.)
-!         print*,rh,pph2o,psh2o(T),vpice(T)
-!         print*,T,aw,sulfmolal,wph2so4_out
-         wph2so4_out = max(wph2so4_out,15.)
-         wph2so4_out = min(wph2so4_out,99.999)
-
-       return
-     end function wph2so4
-!-----------------------------------------------------------------------
-     real function solh2so4(T,xa) result(solh2so4_out)
-!     equilibrium h2so4 number density over H2SO4/H2O solution (molec/cm3)
-
-      implicit none
-      real, intent(in) :: T, xa       ! T(K)  xa(H2SO4 mass fraction)
-      
-      real :: xw, a12,b12, cacta, presat
-      
-      xw=1.0-xa
-
-!     pure h2so4 saturation number density (molec/cm3)
-      presat=ndsh2so4(T)
-!     compute activity of acid 
-      a12=5.672E3 -4.074E6/T +4.421E8/(T*T)
-      b12=1./0.527
-      cacta=10.**(a12*xw*xw/(xw+b12*xa)**2/T)
-!     h2so4 saturation number density over H2SO4/H2O solution (molec/cm3)
-      solh2so4_out=cacta*xa*presat
-
-       return
-     end function solh2so4
-!-----------------------------------------------------------------------      
-     real function rpmvh2so4(T,ws) result(rpmvh2so4_out)
-!     partial molar volume of h2so4 in h2so4/h2o solution (cm3/mole)
-
-      implicit none
-      real, intent(in) :: T, ws
-      real, dimension(22),parameter :: x=(/  &
-       & 2.393284E-02,-4.359335E-05,7.961181E-08,0.0,-0.198716351, &
-       & 1.39564574E-03,-2.020633E-06,0.51684706,-3.0539E-03,4.505475E-06, &
-       & -0.30119511,1.840408E-03,-2.7221253742E-06,-0.11331674116, &
-       & 8.47763E-04,-1.22336185E-06,0.3455282,-2.2111E-03,3.503768245E-06, &
-       & -0.2315332,1.60074E-03,-2.5827835E-06/)
-      
-      real :: w
-
-        w=ws*0.01
-        rpmvh2so4_out=x(5)+x(6)*T+x(7)*T*T+(x(8)+x(9)*T+x(10)*T*T)*w &
-          +(x(11)+x(12)*T+x(13)*T*T)*w*w
-!       h2so4 partial molar volume in h2so4/h2o solution (cm3/mole)
-        rpmvh2so4_out=rpmvh2so4_out*1000.
-        
-       return
-     end function rpmvh2so4
-!-----------------------------------------------------------------------
-     real function rmvh2o(T) result(rmvh2o_out)
-!     molar volume of pure h2o (cm3/mole)
-
-       implicit none
-       real, intent(in) :: T 
-       real, parameter :: x1=2.393284E-02,x2=-4.359335E-05,x3=7.961181E-08
-
-!      1000: L/mole ->  cm3/mole
-!      pure h2o molar volume (cm3/mole)
-       rmvh2o_out=(x1+x2*T+x3*T*T)*1000.
-       
-       return
-     end function rmvh2o
-!
-END MODULE sulfate_aer_mod
Index: /LMDZ6/trunk/libf/phylmd/StratAer/sulfate_aer_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/StratAer/sulfate_aer_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/StratAer/sulfate_aer_mod.f90	(revision 5268)
@@ -0,0 +1,1062 @@
+MODULE sulfate_aer_mod
+
+! microphysical routines based on UPMC aerosol model by Slimane Bekki
+! adapted for stratospheric sulfate aerosol in LMDZ by Christoph Kleinschmitt 
+
+CONTAINS
+
+!*******************************************************************
+      SUBROUTINE STRACOMP_KELVIN(sh,t_seri,pplay)
+!
+!     Aerosol H2SO4 weight fraction as a function of PH2O and temperature
+!     INPUT:
+!     sh: MMR of H2O
+!     t_seri: temperature (K)
+!     pplay: middle layer pression (Pa)
+!
+!     Modified in modules:
+!     R2SO4: aerosol H2SO4 weight fraction (percent)
+!     R2SO4B: aerosol H2SO4 weight fraction (percent) for each aerosol bin
+!     DENSO4: aerosol density (gr/cm3)
+!     DENSO4B: aerosol density (gr/cm3)for each aerosol bin
+!     f_r_wet: factor for converting dry to wet radius 
+!        assuming 'flat surface' composition (does not depend on aerosol size)
+!     f_r_wetB: factor for converting dry to wet radius 
+!        assuming 'curved surface' composition (depends on aerosol size)
+    
+      USE dimphy, ONLY : klon,klev ! nb of longitude and altitude bands
+      USE infotrac_phy, ONLY : nbtr_bin
+      USE aerophys
+      USE phys_local_var_mod, ONLY: R2SO4, R2SO4B, DENSO4, DENSO4B, f_r_wet, f_r_wetB
+      USE strataer_local_var_mod, ONLY: RRSI
+!     WARNING: in phys_local_var_mod R2SO4B, DENSO4B, f_r_wetB (klon,klev,nbtr_bin)
+!          and dens_aer_dry must be declared somewhere
+    
+      IMPLICIT NONE
+    
+      REAL,DIMENSION(klon,klev),INTENT(IN)    :: t_seri  ! Temperature
+      REAL,DIMENSION(klon,klev),INTENT(IN)    :: pplay   ! pression in the middle of each layer (Pa)
+      REAL,DIMENSION(klon,klev),INTENT(IN)    :: sh      ! specific humidity (kg h2o/kg air)
+      
+!     local variables
+      integer         :: ilon,ilev,ik
+      real, parameter :: rath2oair = mAIRmol/mH2Omol  
+      real, parameter :: third = 1./3.
+      real            :: pph2ogas(klon,klev) 
+      real            :: temp, wpp, xa, surtens, mvh2o, radwet, fkelvin, pph2okel, r2so4ik, denso4ik
+!----------------------------------------
+  
+!     gas-phase h2o partial pressure (Pa) 
+!                                vmr=sh*rath2oair
+      pph2ogas(:,:) = pplay(:,:)*sh(:,:)*rath2oair
+    
+      DO ilon=1,klon
+      DO ilev=1,klev
+          
+        temp = max(t_seri(ilon,ilev),190.)
+        temp = min(temp,300.)
+
+!    ***   H2SO4-H2O flat surface ***
+!!       equilibrium H2O pressure over pure flat liquid water (Pa)
+!!        pflath2o=psh2o(temp)
+!       h2so4 weight percent(%) = f(P_h2o(Pa),T)
+        R2SO4(ilon,ilev)=wph2so4(pph2ogas(ilon,ilev),temp)  
+!       h2so4 mass fraction (0<wpp<1)
+        wpp=R2SO4(ilon,ilev)*1.e-2     
+!       mole fraction
+        xa=18.*wpp/(18.*wpp+98.*(1.-wpp))
+
+!        CHECK:compare h2so4 sat/ pressure (see Marti et al., 97 & reef. therein)
+!               R2SO4(ilon,ilev)=70.    temp=298.15
+!        equilibrium h2so4 number density over H2SO4/H2O solution (molec/cm3)
+!        include conversion from molec/cm3 to Pa
+!        ph2so4=solh2so4(temp,xa)*(1.38065e-16*temp)/10.
+!        print*,' ph2so4=',ph2so4,temp,R2SO4(ilon,ilev)
+!        good match with Martin, et Ayers, not with Gmitro (the famous 0.086)
+
+!       surface tension (mN/m=1.e-3.kg/s2) = f(T,h2so4 mole fraction)
+        surtens=surftension(temp,xa)
+!       molar volume of pure h2o (cm3.mol-1 =1.e-6.m3.mol-1)
+        mvh2o= rmvh2o(temp)
+!       aerosol density (gr/cm3) = f(T,h2so4 mass fraction)
+        DENSO4(ilon,ilev)=density(temp,wpp) 
+!           ->x1000., to have it in kg/m3
+!       factor for converting dry to wet radius
+        f_r_wet(ilon,ilev) = (dens_aer_dry/(DENSO4(ilon,ilev)*1.e3)/ & 
+                   &    (R2SO4(ilon,ilev)*1.e-2))**third
+!    ***   End of H2SO4-H2O flat surface ***
+
+
+!          Loop on bin radius (RRSI in cm)
+           DO IK=1,nbtr_bin 
+ 
+!      ***   H2SO4-H2O curved surface - Kelvin effect factor ***
+!            wet radius (m) (RRSI(IK) in [cm])
+             if (f_r_wetB(ilon,ilev,IK) .gt. 1.0) then 
+               radwet = 1.e-2*RRSI(IK)*f_r_wetB(ilon,ilev,IK)
+             else 
+!              H2SO4-H2O flat surface, only on the first timestep
+               radwet = 1.e-2*RRSI(IK)*f_r_wet(ilon,ilev)
+             endif
+!            Kelvin factor: 
+!            surface tension (mN/m=1.e-3.kg/s2) 
+!            molar volume of pure h2o (cm3.mol-1 =1.e-6.m3.mol-1)
+             fkelvin=exp( 2.*1.e-3*surtens*1.e-6*mvh2o/ (radwet*rgas*temp) )
+!            equilibrium: pph2o(gas) = pph2o(liq) = pph2o(liq_flat) * fkelvin
+!            equilibrium: pph2o(liq_flat) = pph2o(gas) / fkelvin
+!            h2o liquid partial pressure before Kelvin effect (Pa)
+             pph2okel = pph2ogas(ilon,ilev) / fkelvin
+!            h2so4 weight percent(%) = f(P_h2o(Pa),temp)
+             r2so4ik=wph2so4(pph2okel,temp)
+!            h2so4 mass fraction (0<wpp<1)
+             wpp=r2so4ik*1.e-2    
+!            mole fraction
+             xa=18.*wpp/(18.*wpp+98.*(1.-wpp)) 
+!            aerosol density (gr/cm3) = f(T,h2so4 mass fraction)
+             denso4ik=density(temp,wpp)
+!           
+!            recalculate Kelvin factor with surface tension and radwet 
+!                              with new R2SO4B and DENSO4B
+             surtens=surftension(temp,xa)
+!            wet radius (m)
+             radwet = 1.e-2*RRSI(IK)*(dens_aer_dry/(denso4ik*1.e3)/ & 
+                   &    (r2so4ik*1.e-2))**third
+             fkelvin=exp( 2.*1.e-3*surtens*1.e-6*mvh2o / (radwet*rgas*temp) ) 
+             pph2okel=pph2ogas(ilon,ilev) / fkelvin
+!            h2so4 weight percent(%) = f(P_h2o(Pa),temp)
+             R2SO4B(ilon,ilev,IK)=wph2so4(pph2okel,temp)
+!            h2so4 mass fraction (0<wpp<1)
+             wpp=R2SO4B(ilon,ilev,IK)*1.e-2    
+             xa=18.*wpp/(18.*wpp+98.*(1.-wpp)) 
+!            aerosol density (gr/cm3) = f(T,h2so4 mass fraction)
+             DENSO4B(ilon,ilev,IK)=density(temp,wpp)
+!            factor for converting dry to wet radius
+             f_r_wetB(ilon,ilev,IK) = (dens_aer_dry/(DENSO4B(ilon,ilev,IK)*1.e3)/ & 
+                   &    (R2SO4B(ilon,ilev,IK)*1.e-2))**third
+!
+!             print*,'R,Rwet(m),kelvin,h2so4(%),ro=',RRSI(ik),radwet,fkelvin, &
+!              &  R2SO4B(ilon,ilev,IK),DENSO4B(ilon,ilev,IK)
+!             print*,' equil.h2so4(molec/cm3), & 
+!              & sigma',solh2so4(temp,xa),surftension(temp,xa)
+
+           ENDDO
+
+      ENDDO
+      ENDDO
+
+      RETURN
+    
+  END SUBROUTINE STRACOMP_KELVIN
+!********************************************************************
+    SUBROUTINE STRACOMP(sh,t_seri,pplay)
+
+!   AEROSOL H2SO4 WEIGHT FRACTION AS A FUNCTION OF PH2O AND TEMPERATURE
+!   ----------------------------------------------------------------
+!   INPUT: 
+!   H2O: VMR of H2O
+!   t_seri: temperature (K)
+!   PMB: pressure (mb)
+!   klon: number of latitude bands in the model domain
+!   klev: number of altitude bands in the model domain
+!   for IFS: perhaps add another dimension for longitude
+!
+!   OUTPUT: 
+!   R2SO4: aerosol H2SO4 weight fraction (percent)
+ 
+    USE dimphy, ONLY : klon,klev
+    USE aerophys
+    USE phys_local_var_mod, ONLY: R2SO4
+
+    IMPLICIT NONE
+
+    REAL,DIMENSION(klon,klev),INTENT(IN)          :: t_seri  ! Temperature
+    REAL,DIMENSION(klon,klev),INTENT(IN)          :: pplay   ! pression pour le mileu de chaque couche (en Pa)
+    REAL,DIMENSION(klon,klev),INTENT(IN)          :: sh      ! humidite specifique
+     
+    REAL PMB(klon,klev), H2O(klon,klev)
+!
+!   working variables
+    INTEGER I,J,K
+    REAL TP, PH2O, VAL, A, B
+!     local variables to be saved on exit
+    INTEGER INSTEP
+    INTEGER, PARAMETER :: N=16, M=28
+    DATA INSTEP/0/
+    REAL F(N,M)
+    REAL XC(N)
+    REAL YC(M)
+    REAL XC1, XC16, YC1, YC28
+!
+    SAVE INSTEP,F,XC,YC,XC1,XC16,YC1,YC28
+!$OMP THREADPRIVATE(INSTEP,F,XC,YC,XC1,XC16,YC1,YC28)
+
+! convert pplay (in Pa) to PMB (in mb)
+    PMB(:,:)=pplay(:,:)/100.0
+
+! convert specific humidity sh (in kg/kg) to VMR H2O
+    H2O(:,:)=sh(:,:)*mAIRmol/mH2Omol
+
+    IF(INSTEP.EQ.0) THEN
+    
+       INSTEP=1
+       XC(1)=0.01
+       XC(2)=0.1
+       XC(3)=0.5
+       XC(4)=1.0
+       XC(5)=1.5
+       XC(6)=2.0
+       XC(7)=3.0
+       XC(8)=5.0
+       XC(9)=6.0
+       XC(10)=8.0
+       XC(11)=10.0
+       XC(12)=12.0
+       XC(13)=15.0
+       XC(14)=20.0
+       XC(15)=30.0
+       XC(16)=100.0
+!
+       YC(1)=175.0
+       DO I=2,28
+         YC(I)=YC(I-1)+5.0
+       ENDDO
+
+!      CONVERSION mb IN 1.0E-4mB
+       DO I=1,16
+         XC(I)=XC(I)*1.0E-4
+       ENDDO
+!
+       XC1=XC(1)+1.E-10
+       XC16=XC(16)-1.E-8
+       YC1=YC(1)+1.E-5
+       YC28=YC(28)-1.E-5
+
+       F(6,4)=43.45
+       F(6,5)=53.96
+       F(6,6)=60.62
+       F(6,7)=65.57
+       F(6,8)=69.42
+       F(6,9)=72.56
+       F(6,10)=75.17
+       F(6,11)=77.38
+       F(6,12)=79.3
+       F(6,13)=80.99
+       F(6,14)=82.5
+       F(6,15)=83.92
+       F(6,16)=85.32
+       F(6,17)=86.79
+       F(6,18)=88.32
+!
+!      ADD FACTOR  BECAUSE THE SLOP IS TOO IMPORTANT
+!      NOT FOR THIS ONE BUT THE REST
+!      LOG DOESN'T WORK
+       A=(F(6,5)-F(6,4))/( (YC(5)-YC(4))*2.0)
+       B=-A*YC(4) + F(6,4)
+       F(6,1)=A*YC(1) + B
+       F(6,2)=A*YC(2) + B
+       F(6,3)=A*YC(3) + B
+!
+       F(7,4)=37.02
+       F(7,5)=49.46
+       F(7,6)=57.51
+       F(7,7)=63.12
+       F(7,8)=67.42
+       F(7,9)=70.85
+       F(7,10)=73.70
+       F(7,11)=76.09
+       F(7,12)=78.15
+       F(7,13)=79.96
+       F(7,14)=81.56
+       F(7,15)=83.02
+       F(7,16)=84.43
+       F(7,17)=85.85
+       F(7,18)=87.33
+!
+       A=(F(7,5)-F(7,4))/( (YC(5)-YC(4))*2.0)
+       B=-A*YC(4) + F(7,4)
+       F(7,1)=A*YC(1) + B
+       F(7,2)=A*YC(2) + B
+       F(7,3)=A*YC(3) + B
+!
+       F(8,4)=25.85
+       F(8,5)=42.26
+       F(8,6)=52.78
+       F(8,7)=59.55
+       F(8,8)=64.55
+       F(8,9)=68.45
+       F(8,10)=71.63
+       F(8,11)=74.29
+       F(8,12)=76.56
+       F(8,13)=78.53
+       F(8,14)=80.27
+       F(8,15)=81.83
+       F(8,16)=83.27
+       F(8,17)=84.67
+       F(8,18)=86.10
+!
+       A=(F(8,5)-F(8,4))/( (YC(5)-YC(4))*2.5 )
+       B=-A*YC(4) + F(8,4)
+       F(8,1)=A*YC(1) + B
+       F(8,2)=A*YC(2) + B
+       F(8,3)=A*YC(3) + B
+!
+       F(9,4)=15.38
+       F(9,5)=39.35
+       F(9,6)=50.73
+       F(9,7)=58.11
+       F(9,8)=63.41
+       F(9,9)=67.52
+       F(9,10)=70.83
+       F(9,11)=73.6
+       F(9,12)=75.95
+       F(9,13)=77.98
+       F(9,14)=79.77
+       F(9,15)=81.38
+       F(9,16)=82.84
+       F(9,17)=84.25
+       F(9,18)=85.66
+!
+       A=(F(9,5)-F(9,4))/( (YC(5)-YC(4))*7.0)
+       B=-A*YC(4) + F(9,4)
+       F(9,1)=A*YC(1) + B
+       F(9,2)=A*YC(2) + B
+       F(9,3)=A*YC(3) + B
+!
+       F(10,4)=0.0
+       F(10,5)=34.02
+       F(10,6)=46.93
+       F(10,7)=55.61
+       F(10,8)=61.47
+       F(10,9)=65.94
+       F(10,10)=69.49
+       F(10,11)=72.44
+       F(10,12)=74.93
+       F(10,13)=77.08
+       F(10,14)=78.96
+       F(10,15)=80.63
+       F(10,16)=82.15
+       F(10,17)=83.57
+       F(10,18)=84.97
+!
+       A=(F(10,6)-F(10,5))/( (YC(6)-YC(5))*1.5)
+       B=-A*YC(5) + F(10,5)
+       F(10,1)=A*YC(1) + B
+       F(10,2)=A*YC(2) + B
+       F(10,3)=A*YC(3) + B
+       F(10,4)=A*YC(4) + B
+!
+       F(11,4)=0.0
+       F(11,5)=29.02
+       F(11,6)=43.69
+       F(11,7)=53.44
+       F(11,8)=59.83
+       F(11,9)=64.62
+       F(11,10)=68.39
+       F(11,11)=71.48
+       F(11,12)=74.10
+       F(11,13)=76.33
+       F(11,14)=78.29
+       F(11,15)=80.02
+       F(11,16)=81.58
+       F(11,17)=83.03
+       F(11,18)=84.44
+!
+       A=(F(11,6)-F(11,5))/( (YC(6)-YC(5))*2.5 )
+       B=-A*YC(5) + F(11,5)
+       F(11,1)=A*YC(1) + B
+       F(11,2)=A*YC(2) + B
+       F(11,3)=A*YC(3) + B
+       F(11,4)=A*YC(4) + B
+!
+       F(12,4)=0.0
+       F(12,5)=23.13
+       F(12,6)=40.86
+       F(12,7)=51.44
+       F(12,8)=58.38
+       F(12,9)=63.47
+       F(12,10)=67.43
+       F(12,11)=70.66
+       F(12,12)=73.38
+       F(12,13)=75.70
+       F(12,14)=77.72
+       F(12,15)=79.51
+       F(12,16)=81.11
+       F(12,17)=82.58
+       F(12,18)=83.99
+!
+       A=(F(12,6)-F(12,5))/( (YC(6)-YC(5))*3.5 )
+       B=-A*YC(5) + F(12,5)
+       F(12,1)=A*YC(1) + B
+       F(12,2)=A*YC(2) + B
+       F(12,3)=A*YC(3) + B
+       F(12,4)=A*YC(4) + B
+!
+       F(13,4)=0.0
+       F(13,5)=0.0
+       F(13,6)=36.89
+       F(13,7)=48.63
+       F(13,8)=56.46
+       F(13,9)=61.96
+       F(13,10)=66.19
+       F(13,11)=69.6
+       F(13,12)=72.45
+       F(13,13)=74.89
+       F(13,14)=76.99
+       F(13,15)=78.85
+       F(13,16)=80.50
+       F(13,17)=82.02
+       F(13,18)=83.44
+!
+       A=(F(13,7)-F(13,6))/( (YC(7)-YC(6))*2.0)
+       B=-A*YC(6) + F(13,6)
+       F(13,1)=A*YC(1) + B
+       F(13,2)=A*YC(2) + B
+       F(13,3)=A*YC(3) + B
+       F(13,4)=A*YC(4) + B
+       F(13,5)=A*YC(5) + B
+!
+       F(14,4)=0.0
+       F(14,5)=0.0
+       F(14,6)=30.82
+       F(14,7)=44.49
+       F(14,8)=53.69
+       F(14,9)=59.83
+       F(14,10)=64.47
+       F(14,11)=68.15
+       F(14,12)=71.19
+       F(14,13)=73.77
+       F(14,14)=76.0
+       F(14,15)=77.95
+       F(14,16)=79.69
+       F(14,17)=81.26
+       F(14,18)=82.72
+!
+       A=(F(14,7)-F(14,6))/( (YC(7)-YC(6))*2.5 )
+       B=-A*YC(6) + F(14,6)
+       F(14,1)=A*YC(1) + B
+       F(14,2)=A*YC(2) + B
+       F(14,3)=A*YC(3) + B
+       F(14,4)=A*YC(4) + B
+       F(14,5)=A*YC(5) + B
+!
+       F(15,4)=0.0
+       F(15,5)=0.0
+       F(15,6)=0.0
+       F(15,7)=37.71
+       F(15,8)=48.49
+       F(15,9)=56.40
+       F(15,10)=61.75
+       F(15,11)=65.89
+       F(15,12)=69.25
+       F(15,13)=72.07
+       F(15,14)=74.49
+       F(15,15)=76.59
+       F(15,16)=78.45
+       F(15,17)=80.12
+       F(15,18)=81.64
+!
+       A=(F(15,8)-F(15,7))/( (YC(8)-YC(7))*1.5)
+       B=-A*YC(7) + F(15,7)
+       F(15,1)=A*YC(1) + B
+       F(15,2)=A*YC(2) + B
+       F(15,3)=A*YC(3) + B
+       F(15,4)=A*YC(4) + B
+       F(15,5)=A*YC(5) + B
+       F(15,6)=A*YC(6) + B
+
+!      SUPPOSE THAT AT GIVEN  AND PH2O<2mB,
+!      %H2SO4 = A *LOG(PH2O) +B
+!      XC(1-5) :EXTENSION LEFT (LOW H2O)
+       DO J=1,18
+         A=(F(6,J)-F(7,J))/(LOG(XC(6))-LOG(XC(7)))
+         B=-A*LOG(XC(6)) + F(6,J)
+         DO K=1,5
+           F(K,J)=A*LOG(XC(K)) + B
+         ENDDO
+       ENDDO
+
+!      XC(16) :EXTENSION RIGHT (HIGH H2O)
+       DO J=1,18
+         A=(F(15,J)-F(14,J))/(XC(15)-XC(14))
+         B=-A*XC(15) + F(15,J)
+       F(16,J)=A*XC(16) + B
+!       F(16,2)=1.0
+       ENDDO
+
+!      YC(16-25) :EXTENSION DOWN (HIGH T)
+       DO I=1,16
+         A=(F(I,18)-F(I,17))/(YC(18)-YC(17))
+         B=-A*YC(18) + F(I,18)
+         DO K=19,28
+         F(I,K)=A*YC(K) + B
+         ENDDO
+       ENDDO
+
+!      MANUAL CORRECTIONS
+       DO J=1,10
+       F(1,J)=94.0
+       ENDDO
+
+       DO J=1,6
+       F(2,J)=77.0 +REAL(J)
+       ENDDO
+
+       DO J=1,7
+       F(16,J)=9.0
+       ENDDO
+
+       DO I=1,16
+       DO J=1,28
+         IF (F(I,J).LT.9.0)  F(I,J)=30.0
+         IF (F(I,J).GT.99.99) F(I,J)=99.99
+       ENDDO
+       ENDDO
+      
+    ENDIF
+
+    DO I=1,klon
+    DO J=1,klev
+        TP=t_seri(I,J)
+        IF (TP.LT.175.1) TP=175.1
+!    Partial pressure of H2O (mb)
+        PH2O =PMB(I,J)*H2O(I,J)
+        IF (PH2O.LT.XC1) THEN 
+          R2SO4(I,J)=99.99
+!          PH2O=XC(1)+1.0E-10
+        ELSE 
+          IF (PH2O.GT.XC16) PH2O=XC16 
+!         SIMPLE LINEAR INTERPOLATIONS
+          CALL FIND(PH2O,TP,XC,YC,F,VAL,N,M)
+          IF (PMB(I,J).GE.10.0.AND.VAL.LT.60.0) VAL=60.0
+          R2SO4(I,J)=VAL
+        ENDIF
+    ENDDO
+    ENDDO
+
+    END SUBROUTINE
+
+!****************************************************************
+    SUBROUTINE STRAACT(ACTSO4)
+
+!   H2SO4 ACTIVITY (GIAUQUE) AS A FUNCTION OF H2SO4 WP
+!   ----------------------------------------
+!   INPUT: 
+!   H2SO4: VMR of H2SO4
+!   klon: number of latitude bands in the model domain
+!   klev: number of altitude bands in the model domain
+!   for IFS: perhaps add another dimension for longitude
+!
+!   OUTPUT: 
+!   ACTSO4: H2SO4 activity (percent)
+ 
+    USE dimphy, ONLY : klon,klev
+    USE phys_local_var_mod, ONLY: R2SO4
+
+    IMPLICIT NONE
+     
+    REAL ACTSO4(klon,klev)
+   
+!   Working variables         
+    INTEGER NN,I,J,JX,JX1
+    REAL TC,TB,TA,XT
+    PARAMETER (NN=109)
+    REAL XC(NN),  X(NN)
+
+!   H2SO4 activity 
+    DATA X/ & 
+     &   0.0,0.25,0.78,1.437,2.19,3.07,4.03,5.04,6.08 & 
+     &  ,7.13,8.18,14.33,18.59,28.59,39.17,49.49 & 
+     &  ,102.4,157.8,215.7,276.9,341.6,409.8,481.5,556.6 & 
+     &  ,635.5,719.,808.,902.,1000.,1103.,1211.,1322.,1437.,1555. & 
+     &  ,1677.,1800.,1926.,2054.,2183.,2312.,2442.,2572.,2701.,2829. & 
+     &  ,2955.,3080.,3203.,3325.,3446.,3564.,3681.,3796.,3910.,4022. & 
+     &  ,4134.,4351.,4564.,4771.,4974.,5171.,5364.,5551.,5732.,5908. & 
+     &  ,6079.,6244.,6404.,6559.,6709.,6854.,6994.,7131.,7264.,7393. & 
+     &  ,7520.,7821.,8105.,8373.,8627.,8867.,9093.,9308.,9511.,9703. & 
+     &  ,9885.,10060.,10225.,10535.,10819.,11079.,11318.,11537. & 
+     &  ,11740.,12097.,12407.,12676.,12915.,13126.,13564.,13910. & 
+     &  ,14191.,14423.,14617.,14786.,10568.,15299.,15491.,15654. & 
+     &  ,15811./
+!   H2SO4 weight fraction (percent)
+    DATA XC/ & 
+     &   100.0,99.982,99.963,99.945,99.927,99.908,99.890,99.872 & 
+     &  ,99.853,99.835,99.817,99.725,99.634,99.452,99.270 & 
+     &  ,99.090,98.196,97.319,96.457,95.610,94.777,93.959,93.156 & 
+     &  ,92.365,91.588,90.824,90.073,89.334,88.607,87.892,87.188 & 
+     &  ,86.495,85.814,85.143,84.482,83.832,83.191,82.560,81.939 & 
+     &  ,81.327,80.724,80.130,79.545,78.968,78.399,77.839,77.286 & 
+     &  ,76.741,76.204,75.675,75.152,74.637,74.129,73.628,73.133 & 
+     &  ,72.164,71.220,70.300,69.404,68.530,67.678,66.847,66.037 & 
+     &  ,65.245,64.472,63.718,62.981,62.261,61.557,60.868,60.195 & 
+     &  ,59.537,58.893,58.263,57.646,56.159,54.747,53.405,52.126 & 
+     &  ,50.908,49.745,48.634,47.572,46.555,45.580,44.646,43.749 & 
+     &  ,42.059,40.495,39.043,37.691,36.430,35.251,33.107,31.209 & 
+     &  ,29.517,27.999,26.629,23.728,21.397,19.482,17.882,16.525 & 
+     &  ,15.360,13.461,11.980,10.792,9.819,8.932/
+
+    DO I=1,klon
+    DO J=1,klev
+!     HERE LINEAR INTERPOLATIONS
+        XT=R2SO4(I,J)
+        CALL POSACT(XT,XC,NN,JX)
+        JX1=JX+1
+        IF(JX.EQ.0) THEN
+          ACTSO4(I,J)=0.0 
+        ELSE IF(JX.GE.NN) THEN
+          ACTSO4(I,J)=15811.0 
+        ELSE 
+          TC=XT            -XC(JX)
+          TB=X(JX1)        -X(JX)
+          TA=XC(JX1)       -XC(JX)
+          TA=TB/TA
+          ACTSO4(I,J)=X(JX)  + TA*TC
+        ENDIF
+    ENDDO
+    ENDDO
+
+    END SUBROUTINE
+  
+!****************************************************************
+    SUBROUTINE DENH2SA(t_seri)
+
+!   AERSOL DENSITY AS A FUNCTION OF H2SO4 WEIGHT PERCENT AND T
+!   ---------------------------------------------
+!   VERY ROUGH APPROXIMATION (SEE FOR WATER IN HANDBOOK
+!   LINEAR 2% FOR 30 DEGREES with RESPECT TO WATER)
+!   
+!   INPUT: 
+!   R2SO4: aerosol H2SO4 weight fraction (percent)
+!   t_seri: temperature (K)
+!   klon: number of latitude bands in the model domain
+!   klev: number of altitude bands in the model domain
+!   for IFS: perhaps add another dimension for longitude
+!
+!   OUTPUT: 
+!   DENSO4: aerosol mass density (gr/cm3 = aerosol mass/aerosol volume)
+!   
+    USE dimphy, ONLY : klon,klev
+    USE phys_local_var_mod, ONLY: R2SO4, DENSO4
+
+    IMPLICIT NONE
+
+    REAL,DIMENSION(klon,klev),INTENT(IN)   :: t_seri  ! Temperature
+        
+    INTEGER I,J
+
+!   Loop on model domain (2 dimension for UPMC model; 3 for IFS)
+    DO I=1,klon
+    DO J=1,klev
+!     RO AT 20C
+      DENSO4(I,J)=0.78681252E-5*R2SO4(I,J)*R2SO4(I,J)+ 0.82185978E-2*R2SO4(I,J)+0.97968381
+      DENSO4(I,J)=DENSO4(I,J)* ( 1.0 - (t_seri(I,J)-293.0)*0.02/30.0 )
+    ENDDO
+    ENDDO
+
+    END SUBROUTINE
+
+!***********************************************************
+    SUBROUTINE FIND(X,Y,XC,YC,F,VAL,N,M)
+!
+!   BI-LINEAR INTERPOLATION
+
+!   INPUT: 
+!   X: Partial pressure of H2O (mb)
+!   Y: temperature (K)
+!   XC: Table partial pressure of H2O (mb)
+!   YC: Table temperature (K)
+!   F: Table aerosol H2SO4 weight fraction=f(XC,YC) (percent)
+!
+!   OUTPUT: 
+!   VAL: aerosol H2SO4 weight fraction (percent)
+ 
+    IMPLICIT NONE
+   
+    INTEGER N,M
+    REAL X,Y,XC(N),YC(M),F(N,M),VAL
+!
+!   working variables
+    INTEGER  IERX,IERY,JX,JY,JXP1,JYP1
+    REAL SXY,SX1Y,SX1Y1,SXY1,TA,TB,T,UA,UB,U
+
+    IERX=0
+    IERY=0
+    CALL POSITION(XC,X,N,JX,IERX)
+    CALL POSITION(YC,Y,M,JY,IERY)
+
+    IF(JX.EQ.0.OR.IERY.EQ.1) THEN
+       VAL=99.99
+       RETURN
+    ENDIF
+
+    IF(JY.EQ.0.OR.IERX.EQ.1) THEN
+       VAL=9.0
+       RETURN
+    ENDIF
+
+    JXP1=JX+1
+    JYP1=JY+1
+    SXY=F(JX,  JY  )
+    SX1Y=F(JXP1,JY  )
+    SX1Y1=F(JXP1,JYP1)
+    SXY1=F(JX,  JYP1)
+
+!   x-slope.
+    TA=X       -XC(JX)
+    TB=XC(JXP1)-XC(JX)
+    T=TA/TB
+
+!   y-slope.
+    UA=Y       -YC(JY)
+    UB=YC(JYP1)-YC(JY)
+    U=UA/UB
+
+!   Use bilinear interpolation to determine function at point X,Y.
+    VAL=(1.-T)*(1.-U)*SXY + T*(1.0-U)*SX1Y + T*U*SX1Y1 + (1.0-T)*U*SXY1
+
+    IF(VAL.LT.9.0) VAL=9.0
+    IF(VAL.GT.99.99) VAL=99.99
+   
+    RETURN
+    END SUBROUTINE
+!****************************************************************
+       SUBROUTINE POSITION(XC,X,N,JX,IER)
+ 
+       IMPLICIT NONE
+   
+       INTEGER N,JX,IER,I
+       REAL X,XC(N)
+
+       IER=0
+       IF(X.LT.XC(1)) THEN
+         JX=0
+       ELSE
+         DO 10 I=1,N
+           IF (X.LT.XC(I)) GO TO 20
+ 10      CONTINUE
+         IER=1
+ 20      JX=I-1
+       ENDIF
+
+       RETURN
+       END SUBROUTINE
+!********************************************************************
+       SUBROUTINE POSACT(XT,X,N,JX)
+   
+!      POSITION OF XT IN THE ARRAY X
+!    -----------------------------------------------
+   
+       IMPLICIT NONE
+   
+       INTEGER N
+       REAL XT,X(N)
+!      Working variables	  	   
+       INTEGER JX,I
+  
+       IF(XT.GT.X(1)) THEN
+         JX=0
+       ELSE
+         DO 10 I=1,N
+           IF (XT.GT.X(I)) GO TO 20
+ 10      CONTINUE
+ 20      JX=I
+       ENDIF
+   
+       RETURN
+       END SUBROUTINE
+!********************************************************************
+!-----------------------------------------------------------------------
+      real function psh2so4(T) result(psh2so4_out)
+!     equilibrium H2SO4 pressure over pure H2SO4 solution (Pa)
+!
+!---->Ayers et.al. (1980), GRL (7) pp 433-436
+!     plus corrections for lower temperatures by Kulmala and Laaksonen (1990)
+!     and Noppel et al. (1990)
+
+      implicit none
+      real, intent(in) :: T
+      real, parameter ::      &
+              &  b1=1.01325e5, &
+              &  b2=11.5,  &
+              &  b3=1.0156e4,  &
+              &  b4=0.38/545., &
+              &  tref=360.15
+
+!     saturation vapor pressure ( N/m2 = Pa = kg/(m.s2) )
+      psh2so4_out=b1*exp(  -b2 +b3*( 1./tref-1./T  &
+           &  +b4*(1.+log(tref/T)-tref/T) )   )  
+
+       return
+    end function psh2so4
+!-----------------------------------------------------------------------
+    real function ndsh2so4(T) result(ndsh2so4_out)
+!     equilibrium H2SO4 number density over pure H2SO4 (molec/cm3)
+
+      implicit none
+      real, intent(in) :: T
+      real :: presat
+
+!     Boltzmann constant ( 1.38065e-23 J/K = m2⋅kg/(s2⋅K) )
+!      akb idem in cm2⋅g/(s2⋅K) 
+      real, parameter :: akb=1.38065e-16
+
+!     pure h2so4 saturation vapor pressure (Pa)
+      presat=psh2so4(T)
+!     saturation number density (1/cm3) - (molec/cm3)
+      ndsh2so4_out=presat*10./(akb*T)
+
+       return
+     end function ndsh2so4
+!-----------------------------------------------------------------------
+     real function psh2o(T) result(psh2o_out)
+!     equilibrium H2O pressure over pure liquid water (Pa)
+!
+      implicit none
+      real, intent(in) :: T
+
+      if(T.gt.229.) then
+!        Preining et al., 1981 (from Kulmala et al., 1998)
+!        saturation vapor pressure (N/m2 = 1 Pa = 1 kg/(m·s2))
+         psh2o_out=exp( 77.34491296  -7235.424651/T &
+             &                 -8.2*log(T) + 5.7133e-3*T )
+      else
+!        Tabazadeh et al., 1997, parameterization for 185<T<260
+!        saturation water vapor partial pressure (mb = hPa =1.E2 kg/(m·s2))
+!        or from Clegg and Brimblecombe , J. Chem. Eng., p43, 1995.
+;
+         psh2o_out=18.452406985 -3505.1578807/T &
+              &    -330918.55082/(T*T)             &
+              &    +12725068.262/(T*T*T)
+!        in Pa
+         psh2o_out=100.*exp(psh2o_out)
+      end if
+!      print*,psh2o_out
+      
+       return
+     end function psh2o
+!-----------------------------------------------------------------------
+     real function density(T,so4mfrac) result(density_out)
+!        calculation of particle density (gr/cm3)
+
+!        requires Temperature (T) and acid mass fraction (so4mfrac)
+!---->Vehkamaeki et al. (2002)
+
+      implicit none
+      real, intent(in) :: T, so4mfrac
+      real, parameter :: &
+           &      a1= 0.7681724,&
+           &      a2= 2.184714, &
+           &      a3= 7.163002, &
+           &      a4=-44.31447, &
+           &      a5= 88.74606, &
+           &      a6=-75.73729, &
+           &      a7= 23.43228
+      real, parameter :: &
+           &      b1= 1.808225e-3, &
+           &      b2=-9.294656e-3, &
+           &      b3=-3.742148e-2, &
+           &      b4= 2.565321e-1, &
+           &      b5=-5.362872e-1, &
+           &      b6= 4.857736e-1, &
+           &      b7=-1.629592e-1
+      real, parameter :: &
+           &      c1=-3.478524e-6, &
+           &      c2= 1.335867e-5, &
+           &      c3= 5.195706e-5, &
+           &      c4=-3.717636e-4, &
+           &      c5= 7.990811e-4, &
+           &      c6=-7.458060e-4, &
+           &      c7= 2.581390e-4
+      real :: a,b,c,so4m2,so4m3,so4m4,so4m5,so4m6
+      
+      so4m2=so4mfrac*so4mfrac
+      so4m3=so4mfrac*so4m2
+      so4m4=so4mfrac*so4m3
+      so4m5=so4mfrac*so4m4
+      so4m6=so4mfrac*so4m5
+
+      a=+a1+a2*so4mfrac+a3*so4m2+a4*so4m3 &
+         &     +a5*so4m4+a6*so4m5+a7*so4m6
+      b=+b1+b2*so4mfrac+b3*so4m2+b4*so4m3 &
+         &     +b5*so4m4+b6*so4m5+b7*so4m6
+      c=+c1+c2*so4mfrac+c3*so4m2+c4*so4m3 &
+         &     +c5*so4m4+c6*so4m5+c7*so4m6
+      density_out=(a+b*T+c*T*T) ! units are gm/cm**3
+
+       return
+     end function density
+!-----------------------------------------------------------------------
+     real function surftension(T,so4frac) result(surftension_out)
+!        calculation of surface tension (mN/meter)
+!        requires Temperature (T) and acid mole fraction (so4frac)
+!---->Vehkamaeki et al. (2002)
+
+      implicit none
+      real,intent(in) :: T, so4frac
+      real :: a,b,so4mfrac,so4m2,so4m3,so4m4,so4m5,so4sig
+      real, parameter :: &
+            &     a1= 0.11864, &
+            &     a2=-0.11651, &
+            &     a3= 0.76852, &
+            &     a4=-2.40909, &
+            &     a5= 2.95434, &
+            &     a6=-1.25852
+      real, parameter :: &
+            &     b1=-1.5709e-4, &
+            &     b2= 4.0102e-4, &
+            &     b3=-2.3995e-3, &
+            &     b4= 7.611235e-3, &
+            &     b5=-9.37386e-3, &
+            &     b6= 3.89722e-3
+      real, parameter :: convfac=1.e3  ! convert from newton/m to dyne/cm
+      real, parameter :: Mw=18.01528, Ma=98.079
+
+!     so4 mass fraction
+      so4mfrac=Ma*so4frac/( Ma*so4frac+Mw*(1.-so4frac) )
+      so4m2=so4mfrac*so4mfrac
+      so4m3=so4mfrac*so4m2
+      so4m4=so4mfrac*so4m3
+      so4m5=so4mfrac*so4m4
+
+      a=+a1+a2*so4mfrac+a3*so4m2+a4*so4m3+a5*so4m4+a6*so4m5
+      b=+b1+b2*so4mfrac+b3*so4m2+b4*so4m3+b5*so4m4+b6*so4m5
+      so4sig=a+b*T
+      surftension_out=so4sig*convfac
+
+       return
+     end function surftension
+!-----------------------------------------------------------------------
+     real function wph2so4(pph2o,T) result(wph2so4_out)
+!     Calculates the equilibrium composition of h2so4 aerosols
+!     as a function of temperature and  H2O pressure, using
+!     the parameterization of Tabazadeh et al., GRL, p1931, 1997.
+!
+!   Parameters
+!
+!    input:
+!      T.....temperature (K)
+!      pph2o..... amhbiant 2o pressure (Pa)
+!
+!    output:
+!      wph2so4......sulfuric acid composition (weight percent wt % h2so4)
+!                     = h2so4 mass fraction*100.
+!
+      implicit none
+      real, intent(in) :: pph2o, T 
+      
+      real :: aw, rh, y1, y2, sulfmolal
+  
+!       psh2o(T): equilibrium H2O pressure over pure liquid water (Pa)
+!       relative humidity 
+        rh=pph2o/psh2o(T)
+!       water activity
+!        aw=min( 0.999,max(1.e-3,rh) )
+        aw=min( 0.999999999,max(1.e-8,rh) ) 
+
+!       composition
+!       calculation of h2so4 molality
+            if(aw .le. 0.05 .and. aw .gt. 0.) then
+               y1=12.372089320*aw**(-0.16125516114) &
+                 &  -30.490657554*aw -2.1133114241
+               y2=13.455394705*aw**(-0.19213122550) &
+                 &  -34.285174607*aw -1.7620073078
+            else if(aw .le. 0.85 .and. aw .gt. 0.05) then
+               y1=11.820654354*aw**(-0.20786404244) &
+                 &  -4.8073063730*aw -5.1727540348
+               y2=12.891938068*aw**(-0.23233847708) &
+                 &  -6.4261237757*aw -4.9005471319
+            else
+               y1=-180.06541028*aw**(-0.38601102592) &
+                 &  -93.317846778*aw +273.88132245
+               y2=-176.95814097*aw**(-0.36257048154) &
+                 &  -90.469744201*aw +267.45509988
+            end if
+!        h2so4 molality (m=moles of h2so4 (solute)/ kg of h2o(solvent))
+         sulfmolal = y1+((T-190.)*(y2-y1)/70.)
+
+!        for a solution containing mh2so4 and mh2o: 
+!        sulfmolal = (mh2so4(gr)/h2so4_molar_mass(gr/mole)) / (mh2o(gr)*1.e-3)
+!        mh2o=1.e3*(mh2so4/Mh2so4)/sulfmolal=1.e3*mh2so4/(Mh2so4*sulfmolal)
+!        h2so4_mass_fraction = mfh2so4 = mh2so4/(mh2o + mh2so4)
+!        mh2o=mh2so4*(1-mfh2so4)/mfh2so4
+!        combining the 2 equations
+!        1.e3*mh2so4/(Mh2so4*sulfmolal) = mh2so4*(1-mfh2so4)/mfh2so4
+!        1.e3/(Mh2so4*sulfmolal) = (1-mfh2so4)/mfh2so4
+!        1000*mfh2so4 = (1-mfh2so4)*Mh2so4*sulfmolal
+!        mfh2so4*(1000.+Mh2so4*sulfmolal) = Mh2so4*sulfmolal
+!        mfh2so4 = Mh2so4*sulfmolal / (1000.+Mh2so4*sulfmolal) 
+!        wph2so4 (% mass fraction)= 100.*Mh2so4*sulfmolal / (1000.+Mh2so4*sulfmolal) 
+!        recall activity of i = a_i = P_i/P_pure_i and 
+!          activity coefficient of i = gamma_i = a_i/X_i (X_i: mole fraction of i)
+!        so  P_i = gamma_i*X_i*P_pure_i
+!        if ideal solution, gamma_i=1, P_i = X_i*P_pure_i
+
+!        h2so4 weight precent
+         wph2so4_out = 9800.*sulfmolal/(98.*sulfmolal+1000.)
+!         print*,rh,pph2o,psh2o(T),vpice(T)
+!         print*,T,aw,sulfmolal,wph2so4_out
+         wph2so4_out = max(wph2so4_out,15.)
+         wph2so4_out = min(wph2so4_out,99.999)
+
+       return
+     end function wph2so4
+!-----------------------------------------------------------------------
+     real function solh2so4(T,xa) result(solh2so4_out)
+!     equilibrium h2so4 number density over H2SO4/H2O solution (molec/cm3)
+
+      implicit none
+      real, intent(in) :: T, xa       ! T(K)  xa(H2SO4 mass fraction)
+      
+      real :: xw, a12,b12, cacta, presat
+      
+      xw=1.0-xa
+
+!     pure h2so4 saturation number density (molec/cm3)
+      presat=ndsh2so4(T)
+!     compute activity of acid 
+      a12=5.672E3 -4.074E6/T +4.421E8/(T*T)
+      b12=1./0.527
+      cacta=10.**(a12*xw*xw/(xw+b12*xa)**2/T)
+!     h2so4 saturation number density over H2SO4/H2O solution (molec/cm3)
+      solh2so4_out=cacta*xa*presat
+
+       return
+     end function solh2so4
+!-----------------------------------------------------------------------      
+     real function rpmvh2so4(T,ws) result(rpmvh2so4_out)
+!     partial molar volume of h2so4 in h2so4/h2o solution (cm3/mole)
+
+      implicit none
+      real, intent(in) :: T, ws
+      real, dimension(22),parameter :: x=(/  &
+       & 2.393284E-02,-4.359335E-05,7.961181E-08,0.0,-0.198716351, &
+       & 1.39564574E-03,-2.020633E-06,0.51684706,-3.0539E-03,4.505475E-06, &
+       & -0.30119511,1.840408E-03,-2.7221253742E-06,-0.11331674116, &
+       & 8.47763E-04,-1.22336185E-06,0.3455282,-2.2111E-03,3.503768245E-06, &
+       & -0.2315332,1.60074E-03,-2.5827835E-06/)
+      
+      real :: w
+
+        w=ws*0.01
+        rpmvh2so4_out=x(5)+x(6)*T+x(7)*T*T+(x(8)+x(9)*T+x(10)*T*T)*w &
+          +(x(11)+x(12)*T+x(13)*T*T)*w*w
+!       h2so4 partial molar volume in h2so4/h2o solution (cm3/mole)
+        rpmvh2so4_out=rpmvh2so4_out*1000.
+        
+       return
+     end function rpmvh2so4
+!-----------------------------------------------------------------------
+     real function rmvh2o(T) result(rmvh2o_out)
+!     molar volume of pure h2o (cm3/mole)
+
+       implicit none
+       real, intent(in) :: T 
+       real, parameter :: x1=2.393284E-02,x2=-4.359335E-05,x3=7.961181E-08
+
+!      1000: L/mole ->  cm3/mole
+!      pure h2o molar volume (cm3/mole)
+       rmvh2o_out=(x1+x2*T+x3*T*T)*1000.
+       
+       return
+     end function rmvh2o
+!
+END MODULE sulfate_aer_mod
Index: DZ6/trunk/libf/phylmd/StratAer/traccoag_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/StratAer/traccoag_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,423 +1,0 @@
-MODULE traccoag_mod
-!
-! This module calculates the concentration of aerosol particles in certain size bins
-! considering coagulation and sedimentation.
-!
-CONTAINS
-
-  SUBROUTINE traccoag(pdtphys, gmtime, debutphy, julien, &
-       presnivs, xlat, xlon, pphis, pphi, &
-       t_seri, pplay, paprs, sh, rh, tr_seri)
-    
-    USE phys_local_var_mod, ONLY: mdw, R2SO4, DENSO4, f_r_wet, surf_PM25_sulf, & 
-        & budg_emi_ocs, budg_emi_so2, budg_emi_h2so4, budg_emi_part, &
-        & R2SO4B, DENSO4B, f_r_wetB, sulfmmr, SAD_sulfate, sulfmmr_mode, nd_mode, reff_sulfate
-    
-    USE dimphy
-    USE infotrac_phy, ONLY : nbtr_bin, nbtr_sulgas, nbtr, id_SO2_strat
-    USE aerophys
-    USE geometry_mod, ONLY : cell_area, boundslat
-    USE mod_grid_phy_lmdz
-    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
-    USE mod_phys_lmdz_para, only: gather, scatter
-    USE phys_cal_mod, ONLY : year_len, year_cur, mth_cur, day_cur, hour
-    USE sulfate_aer_mod
-    USE phys_local_var_mod, ONLY: stratomask
-    USE yomcst_mod_h
-    USE print_control_mod, ONLY: lunout
-    USE strataer_local_var_mod
-    
-    IMPLICIT NONE
-
-! Input argument
-!---------------
-    REAL,INTENT(IN)    :: pdtphys    ! Pas d'integration pour la physique (seconde)
-    REAL,INTENT(IN)    :: gmtime     ! Heure courante
-    LOGICAL,INTENT(IN) :: debutphy   ! le flag de l'initialisation de la physique
-    INTEGER,INTENT(IN) :: julien     ! Jour julien
-
-    REAL,DIMENSION(klev),INTENT(IN)        :: presnivs! pressions approximat. des milieux couches (en PA)
-    REAL,DIMENSION(klon),INTENT(IN)        :: xlat    ! latitudes pour chaque point 
-    REAL,DIMENSION(klon),INTENT(IN)        :: xlon    ! longitudes pour chaque point 
-    REAL,DIMENSION(klon),INTENT(IN)        :: pphis   ! geopotentiel du sol
-    REAL,DIMENSION(klon,klev),INTENT(IN)   :: pphi    ! geopotentiel de chaque couche
-
-    REAL,DIMENSION(klon,klev),INTENT(IN)   :: t_seri  ! Temperature
-    REAL,DIMENSION(klon,klev),INTENT(IN)   :: pplay   ! pression pour le mileu de chaque couche (en Pa)
-    REAL,DIMENSION(klon,klev+1),INTENT(IN) :: paprs   ! pression pour chaque inter-couche (en Pa)
-    REAL,DIMENSION(klon,klev),INTENT(IN)   :: sh      ! humidite specifique
-    REAL,DIMENSION(klon,klev),INTENT(IN)   :: rh      ! humidite relative   
-
-! Output argument
-!----------------
-    REAL,DIMENSION(klon,klev,nbtr),INTENT(INOUT)  :: tr_seri ! Concentration Traceur [U/KgA]  
-
-! Local variables
-!----------------
-    REAL                                   :: m_aer_emiss_vol_daily ! daily injection mass emission
-    REAL                                   :: m_aer               ! aerosol mass
-    INTEGER                                :: it, k, i, j, ilon, ilev, itime, i_int, ieru
-    LOGICAL,DIMENSION(klon,klev)           :: is_strato           ! true = above tropopause, false = below
-    REAL,DIMENSION(klon,klev)              :: m_air_gridbox       ! mass of air in every grid box [kg]
-    REAL,DIMENSION(klon_glo,klev,nbtr)     :: tr_seri_glo         ! Concentration Traceur [U/KgA]  
-    REAL,DIMENSION(klev+1)                 :: altLMDz             ! altitude of layer interfaces in m
-    REAL,DIMENSION(klev)                   :: f_lay_emiss         ! fraction of emission for every vertical layer
-    REAL                                   :: f_lay_sum           ! sum of layer emission fractions
-    REAL                                   :: alt                 ! altitude for integral calculation
-    INTEGER,PARAMETER                      :: n_int_alt=10        ! number of subintervals for integration over Gaussian emission profile
-    REAL,DIMENSION(nbtr_bin)               :: r_bin               ! particle radius in size bin [m]
-    REAL,DIMENSION(nbtr_bin)               :: r_lower             ! particle radius at lower bin boundary [m]
-    REAL,DIMENSION(nbtr_bin)               :: r_upper             ! particle radius at upper bin boundary [m]
-    REAL,DIMENSION(nbtr_bin)               :: m_part_dry          ! mass of one dry particle in size bin [kg]
-    REAL                                   :: zrho                ! Density of air [kg/m3]
-    REAL                                   :: zdz                 ! thickness of atm. model layer in m
-    REAL,DIMENSION(klev)                   :: zdm                 ! mass of atm. model layer in kg
-    REAL,DIMENSION(klon,klev)              :: dens_aer            ! density of aerosol particles [kg/m3 aerosol] with default H2SO4 mass fraction
-    REAL                                   :: emission            ! emission
-    REAL                                   :: theta_min, theta_max ! for SAI computation between two latitudes
-    REAL                                   :: dlat_loc
-    REAL                                   :: latmin,latmax,lonmin,lonmax ! lat/lon min/max for injection
-    REAL                                   :: sigma_alt, altemiss ! injection altitude + sigma for distrib
-    REAL                                   :: pdt,stretchlong     ! physic timestep, stretch emission over one day
-    
-    INTEGER                                :: injdur_sai          ! injection duration for SAI case [days]
-    INTEGER                                :: yr, is_bissext
-    REAL                                   :: samoment2, samoment3! 2nd and 3rd order moments of size distribution
-
-    IF (is_mpi_root .AND. flag_verbose_strataer) THEN
-       WRITE(lunout,*) 'in traccoag: date from phys_cal_mod =',year_cur,'-',mth_cur,'-',day_cur,'-',hour
-       WRITE(lunout,*) 'IN traccoag flag_emit: ',flag_emit
-    ENDIF
-    
-    !   radius [m]
-    DO it=1, nbtr_bin
-      r_bin(it)=mdw(it)/2.
-    ENDDO
-
-!--set boundaries of size bins
-    DO it=1, nbtr_bin
-    IF (it.EQ.1) THEN
-      r_upper(it)=sqrt(r_bin(it+1)*r_bin(it))
-      r_lower(it)=r_bin(it)**2./r_upper(it)
-    ELSEIF (it.EQ.nbtr_bin) THEN
-      r_lower(it)=sqrt(r_bin(it)*r_bin(it-1))
-      r_upper(it)=r_bin(it)**2./r_lower(it)
-    ELSE
-      r_lower(it)=sqrt(r_bin(it)*r_bin(it-1))
-      r_upper(it)=sqrt(r_bin(it+1)*r_bin(it))
-    ENDIF
-    ENDDO
-
-    IF (debutphy .and. is_mpi_root) THEN
-      DO it=1, nbtr_bin
-        WRITE(lunout,*) 'radius bin', it, ':', r_bin(it), '(from',  r_lower(it), 'to', r_upper(it), ')'
-      ENDDO
-    ENDIF
-
-!--initialising logical is_strato from stratomask
-    is_strato(:,:)=.FALSE. 
-    WHERE (stratomask.GT.0.5) is_strato=.TRUE. 
-
-    IF(flag_new_strat_compo) THEN
-       IF(debutphy) WRITE(lunout,*) 'traccoag: COMPO/DENSITY (Tabazadeh 97) + H2O kelvin effect', flag_new_strat_compo
-       ! STRACOMP (H2O, P, t_seri, R -> R2SO4 + Kelvin effect) : Taba97, Socol, etc...
-       CALL stracomp_kelvin(sh,t_seri,pplay)
-    ELSE
-       IF(debutphy) WRITE(lunout,*) 'traccoag: COMPO from Bekki 2D model', flag_new_strat_compo
-       ! STRACOMP (H2O, P, t_seri -> aerosol composition (R2SO4)) 
-       ! H2SO4 mass fraction in aerosol (%)
-       CALL stracomp(sh,t_seri,pplay)
-       
-       ! aerosol density (gr/cm3)
-       CALL denh2sa(t_seri)
-       
-       ! compute factor for converting dry to wet radius (for every grid box)
-       f_r_wet(:,:) = (dens_aer_dry/(DENSO4(:,:)*1000.)/(R2SO4(:,:)/100.))**(1./3.)
-    ENDIF
-    
-!--calculate mass of air in every grid box
-    DO ilon=1, klon
-       DO ilev=1, klev
-          m_air_gridbox(ilon,ilev)=(paprs(ilon,ilev)-paprs(ilon,ilev+1))/RG*cell_area(ilon)
-       ENDDO
-    ENDDO
-    
-!--initialise emission diagnostics
-    if (nErupt > 0 .and. (flag_emit == 1 .or. flag_emit == 4)) budg_emi(:,1)=0.0
-    budg_emi_ocs(:)=0.0
-    budg_emi_so2(:)=0.0
-    budg_emi_h2so4(:)=0.0
-    budg_emi_part(:)=0.0
-
-!--sulfur emission, depending on chosen scenario (flag_emit)
-    SELECT CASE(flag_emit)
-
-    CASE(0) ! background aerosol
-      ! do nothing (no emission)
-
-    CASE(1) ! volcanic eruption
-      !--only emit on day of eruption
-      ! stretch emission over one day of Pinatubo eruption
-       DO ieru=1, nErupt
-          IF (year_cur==year_emit_vol(ieru).AND.mth_cur==mth_emit_vol(ieru).AND.&
-               day_cur>=day_emit_vol(ieru).AND.day_cur<(day_emit_vol(ieru)+injdur)) THEN
-
-             ! daily injection mass emission
-             m_aer=m_aer_emiss_vol(ieru,1)/(REAL(injdur)*REAL(ponde_lonlat_vol(ieru)))
-             !emission as SO2 gas (with m(SO2)=64/32*m_aer_emiss)
-             m_aer=m_aer*(mSO2mol/mSatom)
-             
-             WRITE(lunout,*) 'IN traccoag m_aer_emiss_vol(ieru)=',m_aer_emiss_vol(ieru,1), &
-                  'ponde_lonlat_vol(ieru)=',ponde_lonlat_vol(ieru),'(injdur*ponde_lonlat_vol(ieru))', &
-                  (injdur*ponde_lonlat_vol(ieru)),'m_aer_emiss_vol_daily=',m_aer,'ieru=',ieru
-             WRITE(lunout,*) 'IN traccoag, dlon=',dlon
-             
-             latmin=xlat_min_vol(ieru)
-             latmax=xlat_max_vol(ieru)
-             lonmin=xlon_min_vol(ieru)
-             lonmax=xlon_max_vol(ieru)
-             altemiss = altemiss_vol(ieru)
-             sigma_alt = sigma_alt_vol(ieru)
-             pdt=pdtphys
-             ! stretch emission over one day of eruption
-             stretchlong = 1.
-             
-             CALL STRATEMIT(pdtphys,pdt,xlat,xlon,t_seri,pplay,paprs,tr_seri,&
-                  m_aer,latmin,latmax,lonmin,lonmax,altemiss,sigma_alt,id_SO2_strat, &
-                  stretchlong,1,0)
-             
-          ENDIF ! emission period
-       ENDDO ! eruption number
-       
-    CASE(2) ! stratospheric aerosol injections (SAI)
-!
-     ! Computing duration of SAI in days...
-     ! ... starting from 0...
-     injdur_sai = 0
-     ! ... then adding whole years from first to (n-1)th...
-     DO yr = year_emit_sai_start, year_emit_sai_end-1
-       ! (n % 4 == 0) and (n % 100 != 0 or n % 400 == 0)
-       is_bissext = (MOD(yr,4)==0) .AND. (MOD(yr,100) /= 0 .OR. MOD(yr,400) == 0)
-       injdur_sai = injdur_sai+365+is_bissext
-     ENDDO
-     ! ... then subtracting part of the first year where no injection yet...
-     is_bissext = (MOD(year_emit_sai_start,4)==0) .AND. (MOD(year_emit_sai_start,100) /= 0 .OR. MOD(year_emit_sai_start,400) == 0)
-     SELECT CASE(mth_emit_sai_start)
-     CASE(2)
-        injdur_sai = injdur_sai-31
-     CASE(3)
-        injdur_sai = injdur_sai-31-28-is_bissext
-     CASE(4)
-        injdur_sai = injdur_sai-31-28-is_bissext-31
-     CASE(5)
-        injdur_sai = injdur_sai-31-28-is_bissext-31-30
-     CASE(6)
-        injdur_sai = injdur_sai-31-28-is_bissext-31-30-31
-     CASE(7)
-        injdur_sai = injdur_sai-31-28-is_bissext-31-30-31-30
-     CASE(8)
-        injdur_sai = injdur_sai-31-28-is_bissext-31-30-31-30-31
-     CASE(9)
-        injdur_sai = injdur_sai-31-28-is_bissext-31-30-31-30-31-31
-     CASE(10)
-        injdur_sai = injdur_sai-31-28-is_bissext-31-30-31-30-31-31-30
-     CASE(11)
-        injdur_sai = injdur_sai-31-28-is_bissext-31-30-31-30-31-31-30-31
-     CASE(12)
-        injdur_sai = injdur_sai-31-28-is_bissext-31-30-31-30-31-31-30-31-30
-     END SELECT
-     injdur_sai = injdur_sai-day_emit_sai_start+1
-     ! ... then adding part of the n-th year 
-     is_bissext = (MOD(year_emit_sai_end,4)==0) .AND. (MOD(year_emit_sai_end,100) /= 0 .OR. MOD(year_emit_sai_end,400) == 0)
-     SELECT CASE(mth_emit_sai_end)
-     CASE(2)
-        injdur_sai = injdur_sai+31
-     CASE(3)
-        injdur_sai = injdur_sai+31+28+is_bissext
-     CASE(4)
-        injdur_sai = injdur_sai+31+28+is_bissext+31
-     CASE(5)
-        injdur_sai = injdur_sai+31+28+is_bissext+31+30
-     CASE(6)
-        injdur_sai = injdur_sai+31+28+is_bissext+31+30+31
-     CASE(7)
-        injdur_sai = injdur_sai+31+28+is_bissext+31+30+31+30
-     CASE(8)
-        injdur_sai = injdur_sai+31+28+is_bissext+31+30+31+30+31
-     CASE(9)
-        injdur_sai = injdur_sai+31+28+is_bissext+31+30+31+30+31+31
-     CASE(10)
-        injdur_sai = injdur_sai+31+28+is_bissext+31+30+31+30+31+31+30
-     CASE(11)
-        injdur_sai = injdur_sai+31+28+is_bissext+31+30+31+30+31+31+30+31
-     CASE(12)
-        injdur_sai = injdur_sai+31+28+is_bissext+31+30+31+30+31+31+30+31+30
-     END SELECT
-     injdur_sai = injdur_sai+day_emit_sai_end
-     ! A security: are SAI dates of injection consistent?
-     IF (injdur_sai <= 0) THEN
-        CALL abort_physic('traccoag_mod', 'Pb in SAI dates of injection.',1)
-     ENDIF
-     ! Injection in itself
-     IF (( year_emit_sai_start <= year_cur ) &
-        .AND. ( year_cur <= year_emit_sai_end ) &
-        .AND. ( mth_emit_sai_start <= mth_cur .OR. year_emit_sai_start < year_cur ) &
-        .AND. ( mth_cur <= mth_emit_sai_end .OR. year_cur < year_emit_sai_end ) &
-        .AND. ( day_emit_sai_start <= day_cur .OR. mth_emit_sai_start < mth_cur .OR. year_emit_sai_start < year_cur ) &
-        .AND. ( day_cur <= day_emit_sai_end .OR. mth_cur < mth_emit_sai_end .OR. year_cur < year_emit_sai_end )) THEN
-        
-       m_aer=m_aer_emiss_sai
-       !emission as SO2 gas (with m(SO2)=64/32*m_aer_emiss)
-       m_aer=m_aer*(mSO2mol/mSatom)
-       
-       latmin=xlat_sai
-       latmax=xlat_sai
-       lonmin=xlon_sai
-       lonmax=xlon_sai
-       altemiss = altemiss_sai
-       sigma_alt = sigma_alt_sai
-       pdt=0.
-       ! stretch emission over whole year (360d)
-       stretchlong=FLOAT(year_len)
-       
-       CALL STRATEMIT(pdtphys,pdt,xlat,xlon,t_seri,pplay,paprs,m_air_gridbox,tr_seri,&
-            m_aer,latmin,latmax,lonmin,lonmax,altemiss,sigma_alt,id_SO2_strat, &
-            stretchlong,1,0)
-       
-       budg_emi_so2(:) = budg_emi(:,1)*mSatom/mSO2mol
-     ENDIF ! Condition over injection dates
-
-    CASE(3) ! --- SAI injection over a single band of longitude and between
-            !     lat_min and lat_max
-
-       m_aer=m_aer_emiss_sai
-       !emission as SO2 gas (with m(SO2)=64/32*m_aer_emiss)
-       m_aer=m_aer*(mSO2mol/mSatom)
-
-       latmin=xlat_min_sai
-       latmax=xlat_max_sai
-       lonmin=xlon_sai
-       lonmax=xlon_sai
-       altemiss = altemiss_sai
-       sigma_alt = sigma_alt_sai
-       pdt=0.
-       ! stretch emission over whole year (360d)
-       stretchlong=FLOAT(year_len)
-
-       CALL STRATEMIT(pdtphys,pdt,xlat,xlon,t_seri,pplay,paprs,m_air_gridbox,tr_seri,&
-            m_aer,latmin,latmax,lonmin,lonmax,altemiss,sigma_alt,id_SO2_strat, &
-            stretchlong,1,0)
-
-       budg_emi_so2(:) = budg_emi(:,1)*mSatom/mSO2mol
-       
-    END SELECT ! emission scenario (flag_emit)
-
-!--read background concentrations of OCS and SO2 and lifetimes from input file
-!--update the variables defined in phys_local_var_mod
-    CALL interp_sulf_input(debutphy,pdtphys,paprs,tr_seri)
-
-!--convert OCS to SO2 in the stratosphere
-    CALL ocs_to_so2(pdtphys,tr_seri,t_seri,pplay,paprs,is_strato)
-
-!--convert SO2 to H2SO4
-    CALL so2_to_h2so4(pdtphys,tr_seri,t_seri,pplay,paprs,is_strato)
-
-!--common routine for nucleation and condensation/evaporation with adaptive timestep
-    CALL micphy_tstep(pdtphys,tr_seri,t_seri,pplay,paprs,rh,is_strato)
-
-!--call coagulation routine 
-    CALL coagulate(pdtphys,mdw,tr_seri,t_seri,pplay,dens_aer,is_strato)
-
-!--call sedimentation routine
-    CALL aer_sedimnt(pdtphys, t_seri, pplay, paprs, tr_seri, dens_aer)
-
-!--compute mass concentration of PM2.5 sulfate particles (wet diameter and mass) at the surface for health studies
-    surf_PM25_sulf(:)=0.0
-    DO i=1,klon
-      DO it=1, nbtr_bin
-        IF (mdw(it) .LT. 2.5e-6) THEN
-          !surf_PM25_sulf(i)=surf_PM25_sulf(i)+tr_seri(i,1,it+nbtr_sulgas)*m_part(i,1,it) &
-          !assume that particles consist of ammonium sulfate at the surface (132g/mol) 
-          !and are dry at T = 20 deg. C and 50 perc. humidity
-          surf_PM25_sulf(i)=surf_PM25_sulf(i)+tr_seri(i,1,it+nbtr_sulgas) &
-                           & *132./98.*dens_aer_dry*4./3.*RPI*(mdw(it)/2.)**3 &
-                           & *pplay(i,1)/t_seri(i,1)/RD*1.e9
-        ENDIF
-      ENDDO
-    ENDDO
-    
-!--compute 
-!     sulfmmr: Sulfate aerosol concentration (dry mixing ratio) (condensed H2SO4 mmr)
-!     SAD_sulfate: SAD all aerosols (cm2/cm3) (must be WET)
-!     sulfmmr_mode: sulfate(=H2SO4 if dry) MMR in different modes (ambiguous but based on sulfmmr, it mus be DRY(?) mmr)
-!     nd_mode: DRY(?) particle concentration in different modes (part/m3)
-     sulfmmr(:,:)=0.0
-     SAD_sulfate(:,:)=0.0
-     sulfmmr_mode(:,:,:)=0.0
-     nd_mode(:,:,:)=0.0
-     reff_sulfate(:,:)=0.0
-     
-     DO i=1,klon
-        DO j=1,klev
-           samoment2=0.0
-           samoment3=0.0
-           DO it=1, nbtr_bin
-              !surf_PM25_sulf(i)=surf_PM25_sulf(i)+tr_seri(i,1,it+nbtr_sulgas)*m_part(i,1,it) &
-              !assume that particles consist of ammonium sulfate at the surface (132g/mol) 
-              !and are dry at T = 20 deg. C and 50 perc. humidity
-              
-              !     sulfmmr_mode: sulfate(=H2SO4 if dry) MMR in different modes (based on sulfmmr, it must be DRY mmr)
-              !     equivalent to condensed H2SO4 mmr= H2SO4 kg / kgA in bin it
-              sulfmmr_mode(i,j,it) = tr_seri(i,j,it+nbtr_sulgas) &        ! [DRY part/kgA in bin it] 
-                   &  *(4./3.)*RPI*(mdw(it)/2.)**3.   &                   ! [mdw: dry diameter in m] 
-                   &  *dens_aer_dry                                       ! [dry aerosol mass density in kg/m3] 
-              
-              !     sulfmmr: Sulfate aerosol concentration (dry mass mixing ratio) 
-              !     equivalent to total condensed H2SO4 mmr (H2SO4 kg / kgA
-              sulfmmr(i,j) = sulfmmr(i,j) + sulfmmr_mode(i,j,it)
-              
-              !     nd_mode: particle concentration in different modes (DRY part/m3)
-              nd_mode(i,j,it) = tr_seri(i,j,it+nbtr_sulgas) &             ! [DRY part/kgA in bin it] 
-                   & *pplay(i,j)/t_seri(i,j)/RD                           ! [air mass concentration in kg air /m3A]
-              
-              IF(flag_new_strat_compo) THEN
-                 !     SAD_sulfate: SAD WET sulfate aerosols (cm2/cm3)
-                 SAD_sulfate(i,j) = SAD_sulfate(i,j) + nd_mode(i,j,it) &     ! [DRY part/m3A (in bin it)] 
-                      &  *4.*RPI*( mdw(it)*f_r_wetB(i,j,it)/2. )**2. &       ! [WET SA of part it in m2] 
-                      &  *1.e-2                                              ! conversion from m2/m3 to cm2/cm3A
-!    samoment2 : 2nd order moment of WET sulfate aerosols (m2/m3)
-                 samoment2 = samoment2 + nd_mode(i,j,it) &     ! [DRY part/m3A (in bin it)]
-                      &  *( mdw(it)*f_r_wetB(i,j,it)/2. )**2.                     ! [WET SA of part it in m2]
-!    samoment3 : 3nd order moment of WET sulfate aerosols (cm2/cm3)
-                 samoment3 = samoment3 + nd_mode(i,j,it) &     ! [DRY part/m3A (in bin it)]
-                      &  *( mdw(it)*f_r_wetB(i,j,it)/2. )**3.                     ! [WET SA of part it in m2]
-              ELSE
-!     SAD_sulfate: SAD WET sulfate aerosols (cm2/cm3)
-                 SAD_sulfate(i,j) = SAD_sulfate(i,j) + nd_mode(i,j,it) &     ! [DRY part/m3A (in bin it)] 
-                      &  *4.*RPI*( mdw(it)*f_r_wet(i,j)/2. )**2. &           ! [WET SA of part it in m2] 
-                      &  *1.e-2                                              ! conversion from m2/m3 to cm2/cm3A
-!    samoment2 : 2nd order moment of WET sulfate aerosols (m2/m3)
-                 samoment2 = samoment2 + nd_mode(i,j,it) &     ! [DRY part/m3A (in bin it)]
-                      &  *( mdw(it)*f_r_wet(i,j)/2. )**2.                          ! [WET SA of part it in m2]
-!    samoment3 : 3nd order moment of WET sulfate aerosols (cm2/cm3)
-                 samoment3 = samoment3 + nd_mode(i,j,it) &     ! [DRY part/m3A (in bin it)]
-                      &  *( mdw(it)*f_r_wet(i,j)/2. )**3.                          ! [WET SA of part it in m2]
-              ENDIF
-           ENDDO
-!     reff_sulfate: effective radius of WET sulfate aerosols (cm)
-           IF(samoment2 > 1.e-30) THEN
-              reff_sulfate(i,j) = (samoment3 / samoment2) &
-                   & *1.e2                                              ! conversion from m to cm
-              
-              ! Sanity check
-              IF(reff_sulfate(i,j) > 5.e-4) reff_sulfate(i,j) = 5.e-4   ! reff_sulfate max = 5 micron
-              IF(reff_sulfate(i,j) < 1.e-6) reff_sulfate(i,j) = 1.e-6   ! reff_sulfate min = 10 nm
-           ELSE
-              reff_sulfate(i,j) = 1.e-5                                 ! reff_sulfate N part = nul (ref = 100 nm)
-           ENDIF
-        ENDDO
-     ENDDO
-     
-  END SUBROUTINE traccoag
-
-END MODULE traccoag_mod
Index: /LMDZ6/trunk/libf/phylmd/StratAer/traccoag_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/StratAer/traccoag_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/StratAer/traccoag_mod.f90	(revision 5268)
@@ -0,0 +1,423 @@
+MODULE traccoag_mod
+!
+! This module calculates the concentration of aerosol particles in certain size bins
+! considering coagulation and sedimentation.
+!
+CONTAINS
+
+  SUBROUTINE traccoag(pdtphys, gmtime, debutphy, julien, &
+       presnivs, xlat, xlon, pphis, pphi, &
+       t_seri, pplay, paprs, sh, rh, tr_seri)
+    
+    USE phys_local_var_mod, ONLY: mdw, R2SO4, DENSO4, f_r_wet, surf_PM25_sulf, & 
+        & budg_emi_ocs, budg_emi_so2, budg_emi_h2so4, budg_emi_part, &
+        & R2SO4B, DENSO4B, f_r_wetB, sulfmmr, SAD_sulfate, sulfmmr_mode, nd_mode, reff_sulfate
+    
+    USE dimphy
+    USE infotrac_phy, ONLY : nbtr_bin, nbtr_sulgas, nbtr, id_SO2_strat
+    USE aerophys
+    USE geometry_mod, ONLY : cell_area, boundslat
+    USE mod_grid_phy_lmdz
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    USE mod_phys_lmdz_para, only: gather, scatter
+    USE phys_cal_mod, ONLY : year_len, year_cur, mth_cur, day_cur, hour
+    USE sulfate_aer_mod
+    USE phys_local_var_mod, ONLY: stratomask
+    USE yomcst_mod_h
+    USE print_control_mod, ONLY: lunout
+    USE strataer_local_var_mod
+    
+    IMPLICIT NONE
+
+! Input argument
+!---------------
+    REAL,INTENT(IN)    :: pdtphys    ! Pas d'integration pour la physique (seconde)
+    REAL,INTENT(IN)    :: gmtime     ! Heure courante
+    LOGICAL,INTENT(IN) :: debutphy   ! le flag de l'initialisation de la physique
+    INTEGER,INTENT(IN) :: julien     ! Jour julien
+
+    REAL,DIMENSION(klev),INTENT(IN)        :: presnivs! pressions approximat. des milieux couches (en PA)
+    REAL,DIMENSION(klon),INTENT(IN)        :: xlat    ! latitudes pour chaque point 
+    REAL,DIMENSION(klon),INTENT(IN)        :: xlon    ! longitudes pour chaque point 
+    REAL,DIMENSION(klon),INTENT(IN)        :: pphis   ! geopotentiel du sol
+    REAL,DIMENSION(klon,klev),INTENT(IN)   :: pphi    ! geopotentiel de chaque couche
+
+    REAL,DIMENSION(klon,klev),INTENT(IN)   :: t_seri  ! Temperature
+    REAL,DIMENSION(klon,klev),INTENT(IN)   :: pplay   ! pression pour le mileu de chaque couche (en Pa)
+    REAL,DIMENSION(klon,klev+1),INTENT(IN) :: paprs   ! pression pour chaque inter-couche (en Pa)
+    REAL,DIMENSION(klon,klev),INTENT(IN)   :: sh      ! humidite specifique
+    REAL,DIMENSION(klon,klev),INTENT(IN)   :: rh      ! humidite relative   
+
+! Output argument
+!----------------
+    REAL,DIMENSION(klon,klev,nbtr),INTENT(INOUT)  :: tr_seri ! Concentration Traceur [U/KgA]  
+
+! Local variables
+!----------------
+    REAL                                   :: m_aer_emiss_vol_daily ! daily injection mass emission
+    REAL                                   :: m_aer               ! aerosol mass
+    INTEGER                                :: it, k, i, j, ilon, ilev, itime, i_int, ieru
+    LOGICAL,DIMENSION(klon,klev)           :: is_strato           ! true = above tropopause, false = below
+    REAL,DIMENSION(klon,klev)              :: m_air_gridbox       ! mass of air in every grid box [kg]
+    REAL,DIMENSION(klon_glo,klev,nbtr)     :: tr_seri_glo         ! Concentration Traceur [U/KgA]  
+    REAL,DIMENSION(klev+1)                 :: altLMDz             ! altitude of layer interfaces in m
+    REAL,DIMENSION(klev)                   :: f_lay_emiss         ! fraction of emission for every vertical layer
+    REAL                                   :: f_lay_sum           ! sum of layer emission fractions
+    REAL                                   :: alt                 ! altitude for integral calculation
+    INTEGER,PARAMETER                      :: n_int_alt=10        ! number of subintervals for integration over Gaussian emission profile
+    REAL,DIMENSION(nbtr_bin)               :: r_bin               ! particle radius in size bin [m]
+    REAL,DIMENSION(nbtr_bin)               :: r_lower             ! particle radius at lower bin boundary [m]
+    REAL,DIMENSION(nbtr_bin)               :: r_upper             ! particle radius at upper bin boundary [m]
+    REAL,DIMENSION(nbtr_bin)               :: m_part_dry          ! mass of one dry particle in size bin [kg]
+    REAL                                   :: zrho                ! Density of air [kg/m3]
+    REAL                                   :: zdz                 ! thickness of atm. model layer in m
+    REAL,DIMENSION(klev)                   :: zdm                 ! mass of atm. model layer in kg
+    REAL,DIMENSION(klon,klev)              :: dens_aer            ! density of aerosol particles [kg/m3 aerosol] with default H2SO4 mass fraction
+    REAL                                   :: emission            ! emission
+    REAL                                   :: theta_min, theta_max ! for SAI computation between two latitudes
+    REAL                                   :: dlat_loc
+    REAL                                   :: latmin,latmax,lonmin,lonmax ! lat/lon min/max for injection
+    REAL                                   :: sigma_alt, altemiss ! injection altitude + sigma for distrib
+    REAL                                   :: pdt,stretchlong     ! physic timestep, stretch emission over one day
+    
+    INTEGER                                :: injdur_sai          ! injection duration for SAI case [days]
+    INTEGER                                :: yr, is_bissext
+    REAL                                   :: samoment2, samoment3! 2nd and 3rd order moments of size distribution
+
+    IF (is_mpi_root .AND. flag_verbose_strataer) THEN
+       WRITE(lunout,*) 'in traccoag: date from phys_cal_mod =',year_cur,'-',mth_cur,'-',day_cur,'-',hour
+       WRITE(lunout,*) 'IN traccoag flag_emit: ',flag_emit
+    ENDIF
+    
+    !   radius [m]
+    DO it=1, nbtr_bin
+      r_bin(it)=mdw(it)/2.
+    ENDDO
+
+!--set boundaries of size bins
+    DO it=1, nbtr_bin
+    IF (it.EQ.1) THEN
+      r_upper(it)=sqrt(r_bin(it+1)*r_bin(it))
+      r_lower(it)=r_bin(it)**2./r_upper(it)
+    ELSEIF (it.EQ.nbtr_bin) THEN
+      r_lower(it)=sqrt(r_bin(it)*r_bin(it-1))
+      r_upper(it)=r_bin(it)**2./r_lower(it)
+    ELSE
+      r_lower(it)=sqrt(r_bin(it)*r_bin(it-1))
+      r_upper(it)=sqrt(r_bin(it+1)*r_bin(it))
+    ENDIF
+    ENDDO
+
+    IF (debutphy .and. is_mpi_root) THEN
+      DO it=1, nbtr_bin
+        WRITE(lunout,*) 'radius bin', it, ':', r_bin(it), '(from',  r_lower(it), 'to', r_upper(it), ')'
+      ENDDO
+    ENDIF
+
+!--initialising logical is_strato from stratomask
+    is_strato(:,:)=.FALSE. 
+    WHERE (stratomask.GT.0.5) is_strato=.TRUE. 
+
+    IF(flag_new_strat_compo) THEN
+       IF(debutphy) WRITE(lunout,*) 'traccoag: COMPO/DENSITY (Tabazadeh 97) + H2O kelvin effect', flag_new_strat_compo
+       ! STRACOMP (H2O, P, t_seri, R -> R2SO4 + Kelvin effect) : Taba97, Socol, etc...
+       CALL stracomp_kelvin(sh,t_seri,pplay)
+    ELSE
+       IF(debutphy) WRITE(lunout,*) 'traccoag: COMPO from Bekki 2D model', flag_new_strat_compo
+       ! STRACOMP (H2O, P, t_seri -> aerosol composition (R2SO4)) 
+       ! H2SO4 mass fraction in aerosol (%)
+       CALL stracomp(sh,t_seri,pplay)
+       
+       ! aerosol density (gr/cm3)
+       CALL denh2sa(t_seri)
+       
+       ! compute factor for converting dry to wet radius (for every grid box)
+       f_r_wet(:,:) = (dens_aer_dry/(DENSO4(:,:)*1000.)/(R2SO4(:,:)/100.))**(1./3.)
+    ENDIF
+    
+!--calculate mass of air in every grid box
+    DO ilon=1, klon
+       DO ilev=1, klev
+          m_air_gridbox(ilon,ilev)=(paprs(ilon,ilev)-paprs(ilon,ilev+1))/RG*cell_area(ilon)
+       ENDDO
+    ENDDO
+    
+!--initialise emission diagnostics
+    if (nErupt > 0 .and. (flag_emit == 1 .or. flag_emit == 4)) budg_emi(:,1)=0.0
+    budg_emi_ocs(:)=0.0
+    budg_emi_so2(:)=0.0
+    budg_emi_h2so4(:)=0.0
+    budg_emi_part(:)=0.0
+
+!--sulfur emission, depending on chosen scenario (flag_emit)
+    SELECT CASE(flag_emit)
+
+    CASE(0) ! background aerosol
+      ! do nothing (no emission)
+
+    CASE(1) ! volcanic eruption
+      !--only emit on day of eruption
+      ! stretch emission over one day of Pinatubo eruption
+       DO ieru=1, nErupt
+          IF (year_cur==year_emit_vol(ieru).AND.mth_cur==mth_emit_vol(ieru).AND.&
+               day_cur>=day_emit_vol(ieru).AND.day_cur<(day_emit_vol(ieru)+injdur)) THEN
+
+             ! daily injection mass emission
+             m_aer=m_aer_emiss_vol(ieru,1)/(REAL(injdur)*REAL(ponde_lonlat_vol(ieru)))
+             !emission as SO2 gas (with m(SO2)=64/32*m_aer_emiss)
+             m_aer=m_aer*(mSO2mol/mSatom)
+             
+             WRITE(lunout,*) 'IN traccoag m_aer_emiss_vol(ieru)=',m_aer_emiss_vol(ieru,1), &
+                  'ponde_lonlat_vol(ieru)=',ponde_lonlat_vol(ieru),'(injdur*ponde_lonlat_vol(ieru))', &
+                  (injdur*ponde_lonlat_vol(ieru)),'m_aer_emiss_vol_daily=',m_aer,'ieru=',ieru
+             WRITE(lunout,*) 'IN traccoag, dlon=',dlon
+             
+             latmin=xlat_min_vol(ieru)
+             latmax=xlat_max_vol(ieru)
+             lonmin=xlon_min_vol(ieru)
+             lonmax=xlon_max_vol(ieru)
+             altemiss = altemiss_vol(ieru)
+             sigma_alt = sigma_alt_vol(ieru)
+             pdt=pdtphys
+             ! stretch emission over one day of eruption
+             stretchlong = 1.
+             
+             CALL STRATEMIT(pdtphys,pdt,xlat,xlon,t_seri,pplay,paprs,tr_seri,&
+                  m_aer,latmin,latmax,lonmin,lonmax,altemiss,sigma_alt,id_SO2_strat, &
+                  stretchlong,1,0)
+             
+          ENDIF ! emission period
+       ENDDO ! eruption number
+       
+    CASE(2) ! stratospheric aerosol injections (SAI)
+!
+     ! Computing duration of SAI in days...
+     ! ... starting from 0...
+     injdur_sai = 0
+     ! ... then adding whole years from first to (n-1)th...
+     DO yr = year_emit_sai_start, year_emit_sai_end-1
+       ! (n % 4 == 0) and (n % 100 != 0 or n % 400 == 0)
+       is_bissext = (MOD(yr,4)==0) .AND. (MOD(yr,100) /= 0 .OR. MOD(yr,400) == 0)
+       injdur_sai = injdur_sai+365+is_bissext
+     ENDDO
+     ! ... then subtracting part of the first year where no injection yet...
+     is_bissext = (MOD(year_emit_sai_start,4)==0) .AND. (MOD(year_emit_sai_start,100) /= 0 .OR. MOD(year_emit_sai_start,400) == 0)
+     SELECT CASE(mth_emit_sai_start)
+     CASE(2)
+        injdur_sai = injdur_sai-31
+     CASE(3)
+        injdur_sai = injdur_sai-31-28-is_bissext
+     CASE(4)
+        injdur_sai = injdur_sai-31-28-is_bissext-31
+     CASE(5)
+        injdur_sai = injdur_sai-31-28-is_bissext-31-30
+     CASE(6)
+        injdur_sai = injdur_sai-31-28-is_bissext-31-30-31
+     CASE(7)
+        injdur_sai = injdur_sai-31-28-is_bissext-31-30-31-30
+     CASE(8)
+        injdur_sai = injdur_sai-31-28-is_bissext-31-30-31-30-31
+     CASE(9)
+        injdur_sai = injdur_sai-31-28-is_bissext-31-30-31-30-31-31
+     CASE(10)
+        injdur_sai = injdur_sai-31-28-is_bissext-31-30-31-30-31-31-30
+     CASE(11)
+        injdur_sai = injdur_sai-31-28-is_bissext-31-30-31-30-31-31-30-31
+     CASE(12)
+        injdur_sai = injdur_sai-31-28-is_bissext-31-30-31-30-31-31-30-31-30
+     END SELECT
+     injdur_sai = injdur_sai-day_emit_sai_start+1
+     ! ... then adding part of the n-th year 
+     is_bissext = (MOD(year_emit_sai_end,4)==0) .AND. (MOD(year_emit_sai_end,100) /= 0 .OR. MOD(year_emit_sai_end,400) == 0)
+     SELECT CASE(mth_emit_sai_end)
+     CASE(2)
+        injdur_sai = injdur_sai+31
+     CASE(3)
+        injdur_sai = injdur_sai+31+28+is_bissext
+     CASE(4)
+        injdur_sai = injdur_sai+31+28+is_bissext+31
+     CASE(5)
+        injdur_sai = injdur_sai+31+28+is_bissext+31+30
+     CASE(6)
+        injdur_sai = injdur_sai+31+28+is_bissext+31+30+31
+     CASE(7)
+        injdur_sai = injdur_sai+31+28+is_bissext+31+30+31+30
+     CASE(8)
+        injdur_sai = injdur_sai+31+28+is_bissext+31+30+31+30+31
+     CASE(9)
+        injdur_sai = injdur_sai+31+28+is_bissext+31+30+31+30+31+31
+     CASE(10)
+        injdur_sai = injdur_sai+31+28+is_bissext+31+30+31+30+31+31+30
+     CASE(11)
+        injdur_sai = injdur_sai+31+28+is_bissext+31+30+31+30+31+31+30+31
+     CASE(12)
+        injdur_sai = injdur_sai+31+28+is_bissext+31+30+31+30+31+31+30+31+30
+     END SELECT
+     injdur_sai = injdur_sai+day_emit_sai_end
+     ! A security: are SAI dates of injection consistent?
+     IF (injdur_sai <= 0) THEN
+        CALL abort_physic('traccoag_mod', 'Pb in SAI dates of injection.',1)
+     ENDIF
+     ! Injection in itself
+     IF (( year_emit_sai_start <= year_cur ) &
+        .AND. ( year_cur <= year_emit_sai_end ) &
+        .AND. ( mth_emit_sai_start <= mth_cur .OR. year_emit_sai_start < year_cur ) &
+        .AND. ( mth_cur <= mth_emit_sai_end .OR. year_cur < year_emit_sai_end ) &
+        .AND. ( day_emit_sai_start <= day_cur .OR. mth_emit_sai_start < mth_cur .OR. year_emit_sai_start < year_cur ) &
+        .AND. ( day_cur <= day_emit_sai_end .OR. mth_cur < mth_emit_sai_end .OR. year_cur < year_emit_sai_end )) THEN
+        
+       m_aer=m_aer_emiss_sai
+       !emission as SO2 gas (with m(SO2)=64/32*m_aer_emiss)
+       m_aer=m_aer*(mSO2mol/mSatom)
+       
+       latmin=xlat_sai
+       latmax=xlat_sai
+       lonmin=xlon_sai
+       lonmax=xlon_sai
+       altemiss = altemiss_sai
+       sigma_alt = sigma_alt_sai
+       pdt=0.
+       ! stretch emission over whole year (360d)
+       stretchlong=FLOAT(year_len)
+       
+       CALL STRATEMIT(pdtphys,pdt,xlat,xlon,t_seri,pplay,paprs,m_air_gridbox,tr_seri,&
+            m_aer,latmin,latmax,lonmin,lonmax,altemiss,sigma_alt,id_SO2_strat, &
+            stretchlong,1,0)
+       
+       budg_emi_so2(:) = budg_emi(:,1)*mSatom/mSO2mol
+     ENDIF ! Condition over injection dates
+
+    CASE(3) ! --- SAI injection over a single band of longitude and between
+            !     lat_min and lat_max
+
+       m_aer=m_aer_emiss_sai
+       !emission as SO2 gas (with m(SO2)=64/32*m_aer_emiss)
+       m_aer=m_aer*(mSO2mol/mSatom)
+
+       latmin=xlat_min_sai
+       latmax=xlat_max_sai
+       lonmin=xlon_sai
+       lonmax=xlon_sai
+       altemiss = altemiss_sai
+       sigma_alt = sigma_alt_sai
+       pdt=0.
+       ! stretch emission over whole year (360d)
+       stretchlong=FLOAT(year_len)
+
+       CALL STRATEMIT(pdtphys,pdt,xlat,xlon,t_seri,pplay,paprs,m_air_gridbox,tr_seri,&
+            m_aer,latmin,latmax,lonmin,lonmax,altemiss,sigma_alt,id_SO2_strat, &
+            stretchlong,1,0)
+
+       budg_emi_so2(:) = budg_emi(:,1)*mSatom/mSO2mol
+       
+    END SELECT ! emission scenario (flag_emit)
+
+!--read background concentrations of OCS and SO2 and lifetimes from input file
+!--update the variables defined in phys_local_var_mod
+    CALL interp_sulf_input(debutphy,pdtphys,paprs,tr_seri)
+
+!--convert OCS to SO2 in the stratosphere
+    CALL ocs_to_so2(pdtphys,tr_seri,t_seri,pplay,paprs,is_strato)
+
+!--convert SO2 to H2SO4
+    CALL so2_to_h2so4(pdtphys,tr_seri,t_seri,pplay,paprs,is_strato)
+
+!--common routine for nucleation and condensation/evaporation with adaptive timestep
+    CALL micphy_tstep(pdtphys,tr_seri,t_seri,pplay,paprs,rh,is_strato)
+
+!--call coagulation routine 
+    CALL coagulate(pdtphys,mdw,tr_seri,t_seri,pplay,dens_aer,is_strato)
+
+!--call sedimentation routine
+    CALL aer_sedimnt(pdtphys, t_seri, pplay, paprs, tr_seri, dens_aer)
+
+!--compute mass concentration of PM2.5 sulfate particles (wet diameter and mass) at the surface for health studies
+    surf_PM25_sulf(:)=0.0
+    DO i=1,klon
+      DO it=1, nbtr_bin
+        IF (mdw(it) .LT. 2.5e-6) THEN
+          !surf_PM25_sulf(i)=surf_PM25_sulf(i)+tr_seri(i,1,it+nbtr_sulgas)*m_part(i,1,it) &
+          !assume that particles consist of ammonium sulfate at the surface (132g/mol) 
+          !and are dry at T = 20 deg. C and 50 perc. humidity
+          surf_PM25_sulf(i)=surf_PM25_sulf(i)+tr_seri(i,1,it+nbtr_sulgas) &
+                           & *132./98.*dens_aer_dry*4./3.*RPI*(mdw(it)/2.)**3 &
+                           & *pplay(i,1)/t_seri(i,1)/RD*1.e9
+        ENDIF
+      ENDDO
+    ENDDO
+    
+!--compute 
+!     sulfmmr: Sulfate aerosol concentration (dry mixing ratio) (condensed H2SO4 mmr)
+!     SAD_sulfate: SAD all aerosols (cm2/cm3) (must be WET)
+!     sulfmmr_mode: sulfate(=H2SO4 if dry) MMR in different modes (ambiguous but based on sulfmmr, it mus be DRY(?) mmr)
+!     nd_mode: DRY(?) particle concentration in different modes (part/m3)
+     sulfmmr(:,:)=0.0
+     SAD_sulfate(:,:)=0.0
+     sulfmmr_mode(:,:,:)=0.0
+     nd_mode(:,:,:)=0.0
+     reff_sulfate(:,:)=0.0
+     
+     DO i=1,klon
+        DO j=1,klev
+           samoment2=0.0
+           samoment3=0.0
+           DO it=1, nbtr_bin
+              !surf_PM25_sulf(i)=surf_PM25_sulf(i)+tr_seri(i,1,it+nbtr_sulgas)*m_part(i,1,it) &
+              !assume that particles consist of ammonium sulfate at the surface (132g/mol) 
+              !and are dry at T = 20 deg. C and 50 perc. humidity
+              
+              !     sulfmmr_mode: sulfate(=H2SO4 if dry) MMR in different modes (based on sulfmmr, it must be DRY mmr)
+              !     equivalent to condensed H2SO4 mmr= H2SO4 kg / kgA in bin it
+              sulfmmr_mode(i,j,it) = tr_seri(i,j,it+nbtr_sulgas) &        ! [DRY part/kgA in bin it] 
+                   &  *(4./3.)*RPI*(mdw(it)/2.)**3.   &                   ! [mdw: dry diameter in m] 
+                   &  *dens_aer_dry                                       ! [dry aerosol mass density in kg/m3] 
+              
+              !     sulfmmr: Sulfate aerosol concentration (dry mass mixing ratio) 
+              !     equivalent to total condensed H2SO4 mmr (H2SO4 kg / kgA
+              sulfmmr(i,j) = sulfmmr(i,j) + sulfmmr_mode(i,j,it)
+              
+              !     nd_mode: particle concentration in different modes (DRY part/m3)
+              nd_mode(i,j,it) = tr_seri(i,j,it+nbtr_sulgas) &             ! [DRY part/kgA in bin it] 
+                   & *pplay(i,j)/t_seri(i,j)/RD                           ! [air mass concentration in kg air /m3A]
+              
+              IF(flag_new_strat_compo) THEN
+                 !     SAD_sulfate: SAD WET sulfate aerosols (cm2/cm3)
+                 SAD_sulfate(i,j) = SAD_sulfate(i,j) + nd_mode(i,j,it) &     ! [DRY part/m3A (in bin it)] 
+                      &  *4.*RPI*( mdw(it)*f_r_wetB(i,j,it)/2. )**2. &       ! [WET SA of part it in m2] 
+                      &  *1.e-2                                              ! conversion from m2/m3 to cm2/cm3A
+!    samoment2 : 2nd order moment of WET sulfate aerosols (m2/m3)
+                 samoment2 = samoment2 + nd_mode(i,j,it) &     ! [DRY part/m3A (in bin it)]
+                      &  *( mdw(it)*f_r_wetB(i,j,it)/2. )**2.                     ! [WET SA of part it in m2]
+!    samoment3 : 3nd order moment of WET sulfate aerosols (cm2/cm3)
+                 samoment3 = samoment3 + nd_mode(i,j,it) &     ! [DRY part/m3A (in bin it)]
+                      &  *( mdw(it)*f_r_wetB(i,j,it)/2. )**3.                     ! [WET SA of part it in m2]
+              ELSE
+!     SAD_sulfate: SAD WET sulfate aerosols (cm2/cm3)
+                 SAD_sulfate(i,j) = SAD_sulfate(i,j) + nd_mode(i,j,it) &     ! [DRY part/m3A (in bin it)] 
+                      &  *4.*RPI*( mdw(it)*f_r_wet(i,j)/2. )**2. &           ! [WET SA of part it in m2] 
+                      &  *1.e-2                                              ! conversion from m2/m3 to cm2/cm3A
+!    samoment2 : 2nd order moment of WET sulfate aerosols (m2/m3)
+                 samoment2 = samoment2 + nd_mode(i,j,it) &     ! [DRY part/m3A (in bin it)]
+                      &  *( mdw(it)*f_r_wet(i,j)/2. )**2.                          ! [WET SA of part it in m2]
+!    samoment3 : 3nd order moment of WET sulfate aerosols (cm2/cm3)
+                 samoment3 = samoment3 + nd_mode(i,j,it) &     ! [DRY part/m3A (in bin it)]
+                      &  *( mdw(it)*f_r_wet(i,j)/2. )**3.                          ! [WET SA of part it in m2]
+              ENDIF
+           ENDDO
+!     reff_sulfate: effective radius of WET sulfate aerosols (cm)
+           IF(samoment2 > 1.e-30) THEN
+              reff_sulfate(i,j) = (samoment3 / samoment2) &
+                   & *1.e2                                              ! conversion from m to cm
+              
+              ! Sanity check
+              IF(reff_sulfate(i,j) > 5.e-4) reff_sulfate(i,j) = 5.e-4   ! reff_sulfate max = 5 micron
+              IF(reff_sulfate(i,j) < 1.e-6) reff_sulfate(i,j) = 1.e-6   ! reff_sulfate min = 10 nm
+           ELSE
+              reff_sulfate(i,j) = 1.e-5                                 ! reff_sulfate N part = nul (ref = 100 nm)
+           ENDIF
+        ENDDO
+     ENDDO
+     
+  END SUBROUTINE traccoag
+
+END MODULE traccoag_mod
Index: DZ6/trunk/libf/phylmd/YOEMETH.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/YOEMETH.F90	(revision 5267)
+++ 	(revision )
@@ -1,46 +1,0 @@
-MODULE YOEMETH
-
-IMPLICIT NONE
-
-SAVE
-
-!     -----------------------------------------------------------------
-!     ** YOEMETH - CONTROL PARAMETERS FOR METHANE OXIDATION
-!     -----------------------------------------------------------------
-
-!     * E.C.M.W.F. PHYSICS PACKAGE *
-
-!     C. JAKOB        E.C.M.W.F.          98/04/07
-!     D. Cugnet       Adapted for LMDZ    12/02/24
-
-!      NAME     TYPE      PURPOSE
-!      ----     ----      -------
-
-!     *RALPHA1* REAL      CONSTANT IN TIME SCALE 1 CALCULATIONS
-!     *RALPHA2* REAL      CONSTANT IN TIME SCALE 2 CALCULATIONS
-!     *RQLIM*   REAL      UPPERLIMIT OD SPECIFIC HUMIDITY FOR 
-!                         METHANE OXIDATION TO BE ACTIVE
-!     *RPBOTOX* REAL      PRESSURE BELOW WHICH METHANE OXIDATION
-!                         IS CONSIDERED ACTIVE
-!     *RPBOTPH* REAL      PRESSURE BELOW WHICH H2O PHOTOLYSIS
-!                         IS CONSIDERED ACTIVE
-!     *RPTOPOX* REAL      PRESSURE BELOW WHICH SHORTEST TIME SCALE
-!                         IS USED IN METHANE OXIDATION
-!     *RPTOPPH* REAL      PRESSURE BELOW WHICH SHORTEST TIME SCALE
-!                         IS USED IN H2O PHOTOLYISIS
-!     *RALPHA3* REAL      CONSTANT IN TIME SCALE 2 CALCULATIONS
-!     *RLOGPPH* REAL      CONSTANT IN TIME SCALE 2 CALCULATIONS
-
-REAL :: RALPHA1
-REAL :: RALPHA2
-REAL :: RQLIM
-REAL :: RPBOTOX
-REAL :: RPBOTPH
-REAL :: RPTOPOX
-REAL :: RPTOPPH
-REAL :: RALPHA3
-REAL :: RLOGPPH
-
-END MODULE YOEMETH
-
-
Index: /LMDZ6/trunk/libf/phylmd/YOEMETH.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/YOEMETH.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/YOEMETH.f90	(revision 5268)
@@ -0,0 +1,46 @@
+MODULE YOEMETH
+
+IMPLICIT NONE
+
+SAVE
+
+!     -----------------------------------------------------------------
+!     ** YOEMETH - CONTROL PARAMETERS FOR METHANE OXIDATION
+!     -----------------------------------------------------------------
+
+!     * E.C.M.W.F. PHYSICS PACKAGE *
+
+!     C. JAKOB        E.C.M.W.F.          98/04/07
+!     D. Cugnet       Adapted for LMDZ    12/02/24
+
+!      NAME     TYPE      PURPOSE
+!      ----     ----      -------
+
+!     *RALPHA1* REAL      CONSTANT IN TIME SCALE 1 CALCULATIONS
+!     *RALPHA2* REAL      CONSTANT IN TIME SCALE 2 CALCULATIONS
+!     *RQLIM*   REAL      UPPERLIMIT OD SPECIFIC HUMIDITY FOR 
+!                         METHANE OXIDATION TO BE ACTIVE
+!     *RPBOTOX* REAL      PRESSURE BELOW WHICH METHANE OXIDATION
+!                         IS CONSIDERED ACTIVE
+!     *RPBOTPH* REAL      PRESSURE BELOW WHICH H2O PHOTOLYSIS
+!                         IS CONSIDERED ACTIVE
+!     *RPTOPOX* REAL      PRESSURE BELOW WHICH SHORTEST TIME SCALE
+!                         IS USED IN METHANE OXIDATION
+!     *RPTOPPH* REAL      PRESSURE BELOW WHICH SHORTEST TIME SCALE
+!                         IS USED IN H2O PHOTOLYISIS
+!     *RALPHA3* REAL      CONSTANT IN TIME SCALE 2 CALCULATIONS
+!     *RLOGPPH* REAL      CONSTANT IN TIME SCALE 2 CALCULATIONS
+
+REAL :: RALPHA1
+REAL :: RALPHA2
+REAL :: RQLIM
+REAL :: RPBOTOX
+REAL :: RPBOTPH
+REAL :: RPTOPOX
+REAL :: RPTOPPH
+REAL :: RALPHA3
+REAL :: RLOGPPH
+
+END MODULE YOEMETH
+
+
Index: DZ6/trunk/libf/phylmd/aaam_bud.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/aaam_bud.F90	(revision 5267)
+++ 	(revision )
@@ -1,358 +1,0 @@
-
-! $Id$
-
-SUBROUTINE aaam_bud(iam, nlon, nlev, rjour, rsec, rea, rg, ome, plat, plon, &
-    phis, dragu, liftu, phyu, dragv, liftv, phyv, p, u, v, aam, torsfc)
-
-  USE dimphy
-  USE mod_grid_phy_lmdz, ONLY: nbp_lon, nbp_lat, klon_glo
-  IMPLICIT NONE
-  ! ======================================================================
-  ! Auteur(s): F.Lott (LMD/CNRS) date: 20031020
-  ! Object: Compute different terms of the axial AAAM Budget.
-  ! No outputs, every AAM quantities are written on the IAM
-  ! File.
-
-  ! Modif : I.Musat (LMD/CNRS) date : 20041020
-  ! Outputs : axial components of wind AAM "aam" and total surface torque
-  ! "torsfc",
-  ! but no write in the iam file.
-
-  ! WARNING: Only valid for regular rectangular grids.
-  ! REMARK: CALL DANS PHYSIQ AFTER lift_noro:
-  ! CALL aaam_bud (27,klon,klev,rjourvrai,gmtime,
-  ! C               ra,rg,romega,
-  ! C               rlat,rlon,pphis,
-  ! C               zustrdr,zustrli,zustrph,
-  ! C               zvstrdr,zvstrli,zvstrph,
-  ! C               paprs,u,v)
-
-  ! ======================================================================
-  ! Explicit Arguments:
-  ! ==================
-  ! iam-----input-I-File number where AAMs and torques are written
-  ! It is a formatted file that has been opened
-  ! in physiq.F
-  ! nlon----input-I-Total number of horizontal points that get into physics
-  ! nlev----input-I-Number of vertical levels
-  ! rjour        -R-Jour compte depuis le debut de la simu (run.def)
-  ! rsec         -R-Seconde de la journee
-  ! rea          -R-Earth radius
-  ! rg           -R-gravity constant
-  ! ome          -R-Earth rotation rate
-  ! plat ---input-R-Latitude en degres
-  ! plon ---input-R-Longitude en degres
-  ! phis ---input-R-Geopotential at the ground
-  ! dragu---input-R-orodrag stress (zonal)
-  ! liftu---input-R-orolift stress (zonal)
-  ! phyu----input-R-Stress total de la physique (zonal)
-  ! dragv---input-R-orodrag stress (Meridional)
-  ! liftv---input-R-orolift stress (Meridional)
-  ! phyv----input-R-Stress total de la physique (Meridional)
-  ! p-------input-R-Pressure (Pa) at model half levels
-  ! u-------input-R-Horizontal wind (m/s)
-  ! v-------input-R-Meridional wind (m/s)
-  ! aam-----output-R-Axial Wind AAM (=raam(3))
-  ! torsfc--output-R-Total surface torque (=tmou(3)+tsso(3)+tbls(3))
-
-  ! Implicit Arguments:
-  ! ===================
-
-  ! nbp_lon--common-I: Number of longitude intervals
-  ! (nbp_lat-1)--common-I: Number of latitude intervals
-  ! klon-common-I: Number of points seen by the physics
-  ! nbp_lon*(nbp_lat-2)+2 for instance
-  ! klev-common-I: Number of vertical layers
-  ! ======================================================================
-  ! Local Variables:
-  ! ================
-  ! dlat-----R: Latitude increment (Radians)
-  ! dlon-----R: Longitude increment (Radians)
-  ! raam  ---R: Wind AAM (3 Components, 1 & 2 Equatoriales; 3 Axiale)
-  ! oaam  ---R: Mass AAM (3 Components, 1 & 2 Equatoriales; 3 Axiale)
-  ! tmou-----R: Resolved Mountain torque (3 components)
-  ! tsso-----R: Parameterised Moutain drag torque (3 components)
-  ! tbls-----R: Parameterised Boundary layer torque (3 components)
-
-  ! LOCAL ARRAY:
-  ! ===========
-  ! zs    ---R: Topographic height
-  ! ps    ---R: Surface Pressure
-  ! ub    ---R: Barotropic wind zonal
-  ! vb    ---R: Barotropic wind meridional
-  ! zlat  ---R: Latitude in radians
-  ! zlon  ---R: Longitude in radians
-  ! ======================================================================
-
-  ! ARGUMENTS
-
-  INTEGER iam, nlon, nlev
-  REAL, INTENT (IN) :: rjour, rsec, rea, rg, ome
-  REAL plat(nlon), plon(nlon), phis(nlon)
-  REAL dragu(nlon), liftu(nlon), phyu(nlon)
-  REAL dragv(nlon), liftv(nlon), phyv(nlon)
-  REAL p(nlon, nlev+1), u(nlon, nlev), v(nlon, nlev)
-
-  ! Variables locales:
-
-  INTEGER i, j, k, l
-  REAL xpi, hadley, hadday
-  REAL dlat, dlon
-  REAL raam(3), oaam(3), tmou(3), tsso(3), tbls(3)
-  INTEGER iax
-  ! IM ajout aam, torsfc
-  ! aam = composante axiale du Wind AAM raam
-  ! torsfc = composante axiale de (tmou+tsso+tbls)
-  REAL aam, torsfc
-
-  REAL zs(801, 401), ps(801, 401)
-  REAL ub(801, 401), vb(801, 401)
-  REAL ssou(801, 401), ssov(801, 401)
-  REAL blsu(801, 401), blsv(801, 401)
-  REAL zlon(801), zlat(401)
-
-  CHARACTER (LEN=20) :: modname = 'aaam_bud'
-  CHARACTER (LEN=80) :: abort_message
-
-
-
-  ! PUT AAM QUANTITIES AT ZERO:
-
-  IF (nbp_lon+1>801 .OR. nbp_lat>401) THEN
-    abort_message = 'Pb de dimension dans aaam_bud'
-    CALL abort_physic(modname, abort_message, 1)
-  END IF
-
-  xpi = acos(-1.)
-  hadley = 1.E18
-  hadday = 1.E18*24.*3600.
-  IF(klon_glo.EQ.1) THEN
-    dlat = xpi
-  ELSE
-    dlat = xpi/real(nbp_lat-1)
-  ENDIF
-  dlon = 2.*xpi/real(nbp_lon)
-
-  DO iax = 1, 3
-    oaam(iax) = 0.
-    raam(iax) = 0.
-    tmou(iax) = 0.
-    tsso(iax) = 0.
-    tbls(iax) = 0.
-  END DO
-
-  ! MOUNTAIN HEIGHT, PRESSURE AND BAROTROPIC WIND:
-
-  ! North pole values (j=1):
-
-  l = 1
-
-  ub(1, 1) = 0.
-  vb(1, 1) = 0.
-  DO k = 1, nlev
-    ub(1, 1) = ub(1, 1) + u(l, k)*(p(l,k)-p(l,k+1))/rg
-    vb(1, 1) = vb(1, 1) + v(l, k)*(p(l,k)-p(l,k+1))/rg
-  END DO
-
-  zlat(1) = plat(l)*xpi/180.
-
-  DO i = 1, nbp_lon + 1
-
-    zs(i, 1) = phis(l)/rg
-    ps(i, 1) = p(l, 1)
-    ub(i, 1) = ub(1, 1)
-    vb(i, 1) = vb(1, 1)
-    ssou(i, 1) = dragu(l) + liftu(l)
-    ssov(i, 1) = dragv(l) + liftv(l)
-    blsu(i, 1) = phyu(l) - dragu(l) - liftu(l)
-    blsv(i, 1) = phyv(l) - dragv(l) - liftv(l)
-
-  END DO
-
-
-  DO j = 2, nbp_lat-1
-
-    ! Values at Greenwich (Periodicity)
-
-    zs(nbp_lon+1, j) = phis(l+1)/rg
-    ps(nbp_lon+1, j) = p(l+1, 1)
-    ssou(nbp_lon+1, j) = dragu(l+1) + liftu(l+1)
-    ssov(nbp_lon+1, j) = dragv(l+1) + liftv(l+1)
-    blsu(nbp_lon+1, j) = phyu(l+1) - dragu(l+1) - liftu(l+1)
-    blsv(nbp_lon+1, j) = phyv(l+1) - dragv(l+1) - liftv(l+1)
-    zlon(nbp_lon+1) = -plon(l+1)*xpi/180.
-    zlat(j) = plat(l+1)*xpi/180.
-
-    ub(nbp_lon+1, j) = 0.
-    vb(nbp_lon+1, j) = 0.
-    DO k = 1, nlev
-      ub(nbp_lon+1, j) = ub(nbp_lon+1, j) + u(l+1, k)*(p(l+1,k)-p(l+1,k+1))/rg
-      vb(nbp_lon+1, j) = vb(nbp_lon+1, j) + v(l+1, k)*(p(l+1,k)-p(l+1,k+1))/rg
-    END DO
-
-
-    DO i = 1, nbp_lon
-
-      l = l + 1
-      zs(i, j) = phis(l)/rg
-      ps(i, j) = p(l, 1)
-      ssou(i, j) = dragu(l) + liftu(l)
-      ssov(i, j) = dragv(l) + liftv(l)
-      blsu(i, j) = phyu(l) - dragu(l) - liftu(l)
-      blsv(i, j) = phyv(l) - dragv(l) - liftv(l)
-      zlon(i) = plon(l)*xpi/180.
-
-      ub(i, j) = 0.
-      vb(i, j) = 0.
-      DO k = 1, nlev
-        ub(i, j) = ub(i, j) + u(l, k)*(p(l,k)-p(l,k+1))/rg
-        vb(i, j) = vb(i, j) + v(l, k)*(p(l,k)-p(l,k+1))/rg
-      END DO
-
-    END DO
-
-  END DO
-
-
-  ! South Pole
-
-  IF (nbp_lat-1>1) THEN
-    l = l + 1
-    ub(1, nbp_lat) = 0.
-    vb(1, nbp_lat) = 0.
-    DO k = 1, nlev
-      ub(1, nbp_lat) = ub(1, nbp_lat) + u(l, k)*(p(l,k)-p(l,k+1))/rg
-      vb(1, nbp_lat) = vb(1, nbp_lat) + v(l, k)*(p(l,k)-p(l,k+1))/rg
-    END DO
-    zlat(nbp_lat) = plat(l)*xpi/180.
-
-    DO i = 1, nbp_lon + 1
-      zs(i, nbp_lat) = phis(l)/rg
-      ps(i, nbp_lat) = p(l, 1)
-      ssou(i, nbp_lat) = dragu(l) + liftu(l)
-      ssov(i, nbp_lat) = dragv(l) + liftv(l)
-      blsu(i, nbp_lat) = phyu(l) - dragu(l) - liftu(l)
-      blsv(i, nbp_lat) = phyv(l) - dragv(l) - liftv(l)
-      ub(i, nbp_lat) = ub(1, nbp_lat)
-      vb(i, nbp_lat) = vb(1, nbp_lat)
-    END DO
-  END IF
-
-
-  ! MOMENT ANGULAIRE
-
-  DO j = 1, nbp_lat-1
-    DO i = 1, nbp_lon
-
-      raam(1) = raam(1) - rea**3*dlon*dlat*0.5*(cos(zlon(i))*sin(zlat(j))*cos &
-        (zlat(j))*ub(i,j)+cos(zlon(i))*sin(zlat(j+1))*cos(zlat(j+ &
-        1))*ub(i,j+1)) + rea**3*dlon*dlat*0.5*(sin(zlon(i))*cos(zlat(j))*vb(i &
-        ,j)+sin(zlon(i))*cos(zlat(j+1))*vb(i,j+1))
-
-      oaam(1) = oaam(1) - ome*rea**4*dlon*dlat/rg*0.5*(cos(zlon(i))*cos(zlat( &
-        j))**2*sin(zlat(j))*ps(i,j)+cos(zlon(i))*cos(zlat(j+ &
-        1))**2*sin(zlat(j+1))*ps(i,j+1))
-
-      raam(2) = raam(2) - rea**3*dlon*dlat*0.5*(sin(zlon(i))*sin(zlat(j))*cos &
-        (zlat(j))*ub(i,j)+sin(zlon(i))*sin(zlat(j+1))*cos(zlat(j+ &
-        1))*ub(i,j+1)) - rea**3*dlon*dlat*0.5*(cos(zlon(i))*cos(zlat(j))*vb(i &
-        ,j)+cos(zlon(i))*cos(zlat(j+1))*vb(i,j+1))
-
-      oaam(2) = oaam(2) - ome*rea**4*dlon*dlat/rg*0.5*(sin(zlon(i))*cos(zlat( &
-        j))**2*sin(zlat(j))*ps(i,j)+sin(zlon(i))*cos(zlat(j+ &
-        1))**2*sin(zlat(j+1))*ps(i,j+1))
-
-      raam(3) = raam(3) + rea**3*dlon*dlat*0.5*(cos(zlat(j))**2*ub(i,j)+cos( &
-        zlat(j+1))**2*ub(i,j+1))
-
-      oaam(3) = oaam(3) + ome*rea**4*dlon*dlat/rg*0.5*(cos(zlat(j))**3*ps(i,j &
-        )+cos(zlat(j+1))**3*ps(i,j+1))
-
-    END DO
-  END DO
-
-
-  ! COUPLE DES MONTAGNES:
-
-
-  DO j = 1, nbp_lat-1
-    DO i = 1, nbp_lon
-      tmou(1) = tmou(1) - rea**2*dlon*0.5*sin(zlon(i))*(zs(i,j)-zs(i,j+1))*( &
-        cos(zlat(j+1))*ps(i,j+1)+cos(zlat(j))*ps(i,j))
-      tmou(2) = tmou(2) + rea**2*dlon*0.5*cos(zlon(i))*(zs(i,j)-zs(i,j+1))*( &
-        cos(zlat(j+1))*ps(i,j+1)+cos(zlat(j))*ps(i,j))
-    END DO
-  END DO
-
-  DO j = 2, nbp_lat-1
-    DO i = 1, nbp_lon
-      tmou(1) = tmou(1) + rea**2*dlat*0.5*sin(zlat(j))*(zs(i+1,j)-zs(i,j))*( &
-        cos(zlon(i+1))*ps(i+1,j)+cos(zlon(i))*ps(i,j))
-      tmou(2) = tmou(2) + rea**2*dlat*0.5*sin(zlat(j))*(zs(i+1,j)-zs(i,j))*( &
-        sin(zlon(i+1))*ps(i+1,j)+sin(zlon(i))*ps(i,j))
-      tmou(3) = tmou(3) - rea**2*dlat*0.5*cos(zlat(j))*(zs(i+1,j)-zs(i,j))*( &
-        ps(i+1,j)+ps(i,j))
-    END DO
-  END DO
-
-
-  ! COUPLES DES DIFFERENTES FRICTION AU SOL:
-
-  l = 1
-  DO j = 2, nbp_lat-1
-    DO i = 1, nbp_lon
-      l = l + 1
-      tsso(1) = tsso(1) - rea**3*cos(zlat(j))*dlon*dlat*ssou(i, j)*sin(zlat(j &
-        ))*cos(zlon(i)) + rea**3*cos(zlat(j))*dlon*dlat*ssov(i, j)*sin(zlon(i &
-        ))
-
-      tsso(2) = tsso(2) - rea**3*cos(zlat(j))*dlon*dlat*ssou(i, j)*sin(zlat(j &
-        ))*sin(zlon(i)) - rea**3*cos(zlat(j))*dlon*dlat*ssov(i, j)*cos(zlon(i &
-        ))
-
-      tsso(3) = tsso(3) + rea**3*cos(zlat(j))*dlon*dlat*ssou(i, j)*cos(zlat(j &
-        ))
-
-      tbls(1) = tbls(1) - rea**3*cos(zlat(j))*dlon*dlat*blsu(i, j)*sin(zlat(j &
-        ))*cos(zlon(i)) + rea**3*cos(zlat(j))*dlon*dlat*blsv(i, j)*sin(zlon(i &
-        ))
-
-      tbls(2) = tbls(2) - rea**3*cos(zlat(j))*dlon*dlat*blsu(i, j)*sin(zlat(j &
-        ))*sin(zlon(i)) - rea**3*cos(zlat(j))*dlon*dlat*blsv(i, j)*cos(zlon(i &
-        ))
-
-      tbls(3) = tbls(3) + rea**3*cos(zlat(j))*dlon*dlat*blsu(i, j)*cos(zlat(j &
-        ))
-
-    END DO
-  END DO
-
-
-  ! write(*,*) 'AAM',rsec,
-  ! write(*,*) 'AAM',rjour+rsec/86400.,
-  ! c      raam(3)/hadday,oaam(3)/hadday,
-  ! c      tmou(3)/hadley,tsso(3)/hadley,tbls(3)/hadley
-
-  ! write(iam,100)rjour+rsec/86400.,
-  ! c      raam(1)/hadday,oaam(1)/hadday,
-  ! c      tmou(1)/hadley,tsso(1)/hadley,tbls(1)/hadley,
-  ! c      raam(2)/hadday,oaam(2)/hadday,
-  ! c      tmou(2)/hadley,tsso(2)/hadley,tbls(2)/hadley,
-  ! c      raam(3)/hadday,oaam(3)/hadday,
-  ! c      tmou(3)/hadley,tsso(3)/hadley,tbls(3)/hadley
-100 FORMAT (F12.5, 15(1X,F12.5))
-
-  ! write(iam+1,*)((zs(i,j),i=1,nbp_lon),j=1,nbp_lat)
-  ! write(iam+1,*)((ps(i,j),i=1,nbp_lon),j=1,nbp_lat)
-  ! write(iam+1,*)((ub(i,j),i=1,nbp_lon),j=1,nbp_lat)
-  ! write(iam+1,*)((vb(i,j),i=1,nbp_lon),j=1,nbp_lat)
-  ! write(iam+1,*)((ssou(i,j),i=1,nbp_lon),j=1,nbp_lat)
-  ! write(iam+1,*)((ssov(i,j),i=1,nbp_lon),j=1,nbp_lat)
-  ! write(iam+1,*)((blsu(i,j),i=1,nbp_lon),j=1,nbp_lat)
-  ! write(iam+1,*)((blsv(i,j),i=1,nbp_lon),j=1,nbp_lat)
-
-  aam = raam(3)
-  torsfc = tmou(3) + tsso(3) + tbls(3)
-
-  RETURN
-END SUBROUTINE aaam_bud
Index: /LMDZ6/trunk/libf/phylmd/aaam_bud.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/aaam_bud.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/aaam_bud.f90	(revision 5268)
@@ -0,0 +1,358 @@
+
+! $Id$
+
+SUBROUTINE aaam_bud(iam, nlon, nlev, rjour, rsec, rea, rg, ome, plat, plon, &
+    phis, dragu, liftu, phyu, dragv, liftv, phyv, p, u, v, aam, torsfc)
+
+  USE dimphy
+  USE mod_grid_phy_lmdz, ONLY: nbp_lon, nbp_lat, klon_glo
+  IMPLICIT NONE
+  ! ======================================================================
+  ! Auteur(s): F.Lott (LMD/CNRS) date: 20031020
+  ! Object: Compute different terms of the axial AAAM Budget.
+  ! No outputs, every AAM quantities are written on the IAM
+  ! File.
+
+  ! Modif : I.Musat (LMD/CNRS) date : 20041020
+  ! Outputs : axial components of wind AAM "aam" and total surface torque
+  ! "torsfc",
+  ! but no write in the iam file.
+
+  ! WARNING: Only valid for regular rectangular grids.
+  ! REMARK: CALL DANS PHYSIQ AFTER lift_noro:
+  ! CALL aaam_bud (27,klon,klev,rjourvrai,gmtime,
+  ! C               ra,rg,romega,
+  ! C               rlat,rlon,pphis,
+  ! C               zustrdr,zustrli,zustrph,
+  ! C               zvstrdr,zvstrli,zvstrph,
+  ! C               paprs,u,v)
+
+  ! ======================================================================
+  ! Explicit Arguments:
+  ! ==================
+  ! iam-----input-I-File number where AAMs and torques are written
+  ! It is a formatted file that has been opened
+  ! in physiq.F
+  ! nlon----input-I-Total number of horizontal points that get into physics
+  ! nlev----input-I-Number of vertical levels
+  ! rjour        -R-Jour compte depuis le debut de la simu (run.def)
+  ! rsec         -R-Seconde de la journee
+  ! rea          -R-Earth radius
+  ! rg           -R-gravity constant
+  ! ome          -R-Earth rotation rate
+  ! plat ---input-R-Latitude en degres
+  ! plon ---input-R-Longitude en degres
+  ! phis ---input-R-Geopotential at the ground
+  ! dragu---input-R-orodrag stress (zonal)
+  ! liftu---input-R-orolift stress (zonal)
+  ! phyu----input-R-Stress total de la physique (zonal)
+  ! dragv---input-R-orodrag stress (Meridional)
+  ! liftv---input-R-orolift stress (Meridional)
+  ! phyv----input-R-Stress total de la physique (Meridional)
+  ! p-------input-R-Pressure (Pa) at model half levels
+  ! u-------input-R-Horizontal wind (m/s)
+  ! v-------input-R-Meridional wind (m/s)
+  ! aam-----output-R-Axial Wind AAM (=raam(3))
+  ! torsfc--output-R-Total surface torque (=tmou(3)+tsso(3)+tbls(3))
+
+  ! Implicit Arguments:
+  ! ===================
+
+  ! nbp_lon--common-I: Number of longitude intervals
+  ! (nbp_lat-1)--common-I: Number of latitude intervals
+  ! klon-common-I: Number of points seen by the physics
+  ! nbp_lon*(nbp_lat-2)+2 for instance
+  ! klev-common-I: Number of vertical layers
+  ! ======================================================================
+  ! Local Variables:
+  ! ================
+  ! dlat-----R: Latitude increment (Radians)
+  ! dlon-----R: Longitude increment (Radians)
+  ! raam  ---R: Wind AAM (3 Components, 1 & 2 Equatoriales; 3 Axiale)
+  ! oaam  ---R: Mass AAM (3 Components, 1 & 2 Equatoriales; 3 Axiale)
+  ! tmou-----R: Resolved Mountain torque (3 components)
+  ! tsso-----R: Parameterised Moutain drag torque (3 components)
+  ! tbls-----R: Parameterised Boundary layer torque (3 components)
+
+  ! LOCAL ARRAY:
+  ! ===========
+  ! zs    ---R: Topographic height
+  ! ps    ---R: Surface Pressure
+  ! ub    ---R: Barotropic wind zonal
+  ! vb    ---R: Barotropic wind meridional
+  ! zlat  ---R: Latitude in radians
+  ! zlon  ---R: Longitude in radians
+  ! ======================================================================
+
+  ! ARGUMENTS
+
+  INTEGER iam, nlon, nlev
+  REAL, INTENT (IN) :: rjour, rsec, rea, rg, ome
+  REAL plat(nlon), plon(nlon), phis(nlon)
+  REAL dragu(nlon), liftu(nlon), phyu(nlon)
+  REAL dragv(nlon), liftv(nlon), phyv(nlon)
+  REAL p(nlon, nlev+1), u(nlon, nlev), v(nlon, nlev)
+
+  ! Variables locales:
+
+  INTEGER i, j, k, l
+  REAL xpi, hadley, hadday
+  REAL dlat, dlon
+  REAL raam(3), oaam(3), tmou(3), tsso(3), tbls(3)
+  INTEGER iax
+  ! IM ajout aam, torsfc
+  ! aam = composante axiale du Wind AAM raam
+  ! torsfc = composante axiale de (tmou+tsso+tbls)
+  REAL aam, torsfc
+
+  REAL zs(801, 401), ps(801, 401)
+  REAL ub(801, 401), vb(801, 401)
+  REAL ssou(801, 401), ssov(801, 401)
+  REAL blsu(801, 401), blsv(801, 401)
+  REAL zlon(801), zlat(401)
+
+  CHARACTER (LEN=20) :: modname = 'aaam_bud'
+  CHARACTER (LEN=80) :: abort_message
+
+
+
+  ! PUT AAM QUANTITIES AT ZERO:
+
+  IF (nbp_lon+1>801 .OR. nbp_lat>401) THEN
+    abort_message = 'Pb de dimension dans aaam_bud'
+    CALL abort_physic(modname, abort_message, 1)
+  END IF
+
+  xpi = acos(-1.)
+  hadley = 1.E18
+  hadday = 1.E18*24.*3600.
+  IF(klon_glo.EQ.1) THEN
+    dlat = xpi
+  ELSE
+    dlat = xpi/real(nbp_lat-1)
+  ENDIF
+  dlon = 2.*xpi/real(nbp_lon)
+
+  DO iax = 1, 3
+    oaam(iax) = 0.
+    raam(iax) = 0.
+    tmou(iax) = 0.
+    tsso(iax) = 0.
+    tbls(iax) = 0.
+  END DO
+
+  ! MOUNTAIN HEIGHT, PRESSURE AND BAROTROPIC WIND:
+
+  ! North pole values (j=1):
+
+  l = 1
+
+  ub(1, 1) = 0.
+  vb(1, 1) = 0.
+  DO k = 1, nlev
+    ub(1, 1) = ub(1, 1) + u(l, k)*(p(l,k)-p(l,k+1))/rg
+    vb(1, 1) = vb(1, 1) + v(l, k)*(p(l,k)-p(l,k+1))/rg
+  END DO
+
+  zlat(1) = plat(l)*xpi/180.
+
+  DO i = 1, nbp_lon + 1
+
+    zs(i, 1) = phis(l)/rg
+    ps(i, 1) = p(l, 1)
+    ub(i, 1) = ub(1, 1)
+    vb(i, 1) = vb(1, 1)
+    ssou(i, 1) = dragu(l) + liftu(l)
+    ssov(i, 1) = dragv(l) + liftv(l)
+    blsu(i, 1) = phyu(l) - dragu(l) - liftu(l)
+    blsv(i, 1) = phyv(l) - dragv(l) - liftv(l)
+
+  END DO
+
+
+  DO j = 2, nbp_lat-1
+
+    ! Values at Greenwich (Periodicity)
+
+    zs(nbp_lon+1, j) = phis(l+1)/rg
+    ps(nbp_lon+1, j) = p(l+1, 1)
+    ssou(nbp_lon+1, j) = dragu(l+1) + liftu(l+1)
+    ssov(nbp_lon+1, j) = dragv(l+1) + liftv(l+1)
+    blsu(nbp_lon+1, j) = phyu(l+1) - dragu(l+1) - liftu(l+1)
+    blsv(nbp_lon+1, j) = phyv(l+1) - dragv(l+1) - liftv(l+1)
+    zlon(nbp_lon+1) = -plon(l+1)*xpi/180.
+    zlat(j) = plat(l+1)*xpi/180.
+
+    ub(nbp_lon+1, j) = 0.
+    vb(nbp_lon+1, j) = 0.
+    DO k = 1, nlev
+      ub(nbp_lon+1, j) = ub(nbp_lon+1, j) + u(l+1, k)*(p(l+1,k)-p(l+1,k+1))/rg
+      vb(nbp_lon+1, j) = vb(nbp_lon+1, j) + v(l+1, k)*(p(l+1,k)-p(l+1,k+1))/rg
+    END DO
+
+
+    DO i = 1, nbp_lon
+
+      l = l + 1
+      zs(i, j) = phis(l)/rg
+      ps(i, j) = p(l, 1)
+      ssou(i, j) = dragu(l) + liftu(l)
+      ssov(i, j) = dragv(l) + liftv(l)
+      blsu(i, j) = phyu(l) - dragu(l) - liftu(l)
+      blsv(i, j) = phyv(l) - dragv(l) - liftv(l)
+      zlon(i) = plon(l)*xpi/180.
+
+      ub(i, j) = 0.
+      vb(i, j) = 0.
+      DO k = 1, nlev
+        ub(i, j) = ub(i, j) + u(l, k)*(p(l,k)-p(l,k+1))/rg
+        vb(i, j) = vb(i, j) + v(l, k)*(p(l,k)-p(l,k+1))/rg
+      END DO
+
+    END DO
+
+  END DO
+
+
+  ! South Pole
+
+  IF (nbp_lat-1>1) THEN
+    l = l + 1
+    ub(1, nbp_lat) = 0.
+    vb(1, nbp_lat) = 0.
+    DO k = 1, nlev
+      ub(1, nbp_lat) = ub(1, nbp_lat) + u(l, k)*(p(l,k)-p(l,k+1))/rg
+      vb(1, nbp_lat) = vb(1, nbp_lat) + v(l, k)*(p(l,k)-p(l,k+1))/rg
+    END DO
+    zlat(nbp_lat) = plat(l)*xpi/180.
+
+    DO i = 1, nbp_lon + 1
+      zs(i, nbp_lat) = phis(l)/rg
+      ps(i, nbp_lat) = p(l, 1)
+      ssou(i, nbp_lat) = dragu(l) + liftu(l)
+      ssov(i, nbp_lat) = dragv(l) + liftv(l)
+      blsu(i, nbp_lat) = phyu(l) - dragu(l) - liftu(l)
+      blsv(i, nbp_lat) = phyv(l) - dragv(l) - liftv(l)
+      ub(i, nbp_lat) = ub(1, nbp_lat)
+      vb(i, nbp_lat) = vb(1, nbp_lat)
+    END DO
+  END IF
+
+
+  ! MOMENT ANGULAIRE
+
+  DO j = 1, nbp_lat-1
+    DO i = 1, nbp_lon
+
+      raam(1) = raam(1) - rea**3*dlon*dlat*0.5*(cos(zlon(i))*sin(zlat(j))*cos &
+        (zlat(j))*ub(i,j)+cos(zlon(i))*sin(zlat(j+1))*cos(zlat(j+ &
+        1))*ub(i,j+1)) + rea**3*dlon*dlat*0.5*(sin(zlon(i))*cos(zlat(j))*vb(i &
+        ,j)+sin(zlon(i))*cos(zlat(j+1))*vb(i,j+1))
+
+      oaam(1) = oaam(1) - ome*rea**4*dlon*dlat/rg*0.5*(cos(zlon(i))*cos(zlat( &
+        j))**2*sin(zlat(j))*ps(i,j)+cos(zlon(i))*cos(zlat(j+ &
+        1))**2*sin(zlat(j+1))*ps(i,j+1))
+
+      raam(2) = raam(2) - rea**3*dlon*dlat*0.5*(sin(zlon(i))*sin(zlat(j))*cos &
+        (zlat(j))*ub(i,j)+sin(zlon(i))*sin(zlat(j+1))*cos(zlat(j+ &
+        1))*ub(i,j+1)) - rea**3*dlon*dlat*0.5*(cos(zlon(i))*cos(zlat(j))*vb(i &
+        ,j)+cos(zlon(i))*cos(zlat(j+1))*vb(i,j+1))
+
+      oaam(2) = oaam(2) - ome*rea**4*dlon*dlat/rg*0.5*(sin(zlon(i))*cos(zlat( &
+        j))**2*sin(zlat(j))*ps(i,j)+sin(zlon(i))*cos(zlat(j+ &
+        1))**2*sin(zlat(j+1))*ps(i,j+1))
+
+      raam(3) = raam(3) + rea**3*dlon*dlat*0.5*(cos(zlat(j))**2*ub(i,j)+cos( &
+        zlat(j+1))**2*ub(i,j+1))
+
+      oaam(3) = oaam(3) + ome*rea**4*dlon*dlat/rg*0.5*(cos(zlat(j))**3*ps(i,j &
+        )+cos(zlat(j+1))**3*ps(i,j+1))
+
+    END DO
+  END DO
+
+
+  ! COUPLE DES MONTAGNES:
+
+
+  DO j = 1, nbp_lat-1
+    DO i = 1, nbp_lon
+      tmou(1) = tmou(1) - rea**2*dlon*0.5*sin(zlon(i))*(zs(i,j)-zs(i,j+1))*( &
+        cos(zlat(j+1))*ps(i,j+1)+cos(zlat(j))*ps(i,j))
+      tmou(2) = tmou(2) + rea**2*dlon*0.5*cos(zlon(i))*(zs(i,j)-zs(i,j+1))*( &
+        cos(zlat(j+1))*ps(i,j+1)+cos(zlat(j))*ps(i,j))
+    END DO
+  END DO
+
+  DO j = 2, nbp_lat-1
+    DO i = 1, nbp_lon
+      tmou(1) = tmou(1) + rea**2*dlat*0.5*sin(zlat(j))*(zs(i+1,j)-zs(i,j))*( &
+        cos(zlon(i+1))*ps(i+1,j)+cos(zlon(i))*ps(i,j))
+      tmou(2) = tmou(2) + rea**2*dlat*0.5*sin(zlat(j))*(zs(i+1,j)-zs(i,j))*( &
+        sin(zlon(i+1))*ps(i+1,j)+sin(zlon(i))*ps(i,j))
+      tmou(3) = tmou(3) - rea**2*dlat*0.5*cos(zlat(j))*(zs(i+1,j)-zs(i,j))*( &
+        ps(i+1,j)+ps(i,j))
+    END DO
+  END DO
+
+
+  ! COUPLES DES DIFFERENTES FRICTION AU SOL:
+
+  l = 1
+  DO j = 2, nbp_lat-1
+    DO i = 1, nbp_lon
+      l = l + 1
+      tsso(1) = tsso(1) - rea**3*cos(zlat(j))*dlon*dlat*ssou(i, j)*sin(zlat(j &
+        ))*cos(zlon(i)) + rea**3*cos(zlat(j))*dlon*dlat*ssov(i, j)*sin(zlon(i &
+        ))
+
+      tsso(2) = tsso(2) - rea**3*cos(zlat(j))*dlon*dlat*ssou(i, j)*sin(zlat(j &
+        ))*sin(zlon(i)) - rea**3*cos(zlat(j))*dlon*dlat*ssov(i, j)*cos(zlon(i &
+        ))
+
+      tsso(3) = tsso(3) + rea**3*cos(zlat(j))*dlon*dlat*ssou(i, j)*cos(zlat(j &
+        ))
+
+      tbls(1) = tbls(1) - rea**3*cos(zlat(j))*dlon*dlat*blsu(i, j)*sin(zlat(j &
+        ))*cos(zlon(i)) + rea**3*cos(zlat(j))*dlon*dlat*blsv(i, j)*sin(zlon(i &
+        ))
+
+      tbls(2) = tbls(2) - rea**3*cos(zlat(j))*dlon*dlat*blsu(i, j)*sin(zlat(j &
+        ))*sin(zlon(i)) - rea**3*cos(zlat(j))*dlon*dlat*blsv(i, j)*cos(zlon(i &
+        ))
+
+      tbls(3) = tbls(3) + rea**3*cos(zlat(j))*dlon*dlat*blsu(i, j)*cos(zlat(j &
+        ))
+
+    END DO
+  END DO
+
+
+  ! write(*,*) 'AAM',rsec,
+  ! write(*,*) 'AAM',rjour+rsec/86400.,
+  ! c      raam(3)/hadday,oaam(3)/hadday,
+  ! c      tmou(3)/hadley,tsso(3)/hadley,tbls(3)/hadley
+
+  ! write(iam,100)rjour+rsec/86400.,
+  ! c      raam(1)/hadday,oaam(1)/hadday,
+  ! c      tmou(1)/hadley,tsso(1)/hadley,tbls(1)/hadley,
+  ! c      raam(2)/hadday,oaam(2)/hadday,
+  ! c      tmou(2)/hadley,tsso(2)/hadley,tbls(2)/hadley,
+  ! c      raam(3)/hadday,oaam(3)/hadday,
+  ! c      tmou(3)/hadley,tsso(3)/hadley,tbls(3)/hadley
+100 FORMAT (F12.5, 15(1X,F12.5))
+
+  ! write(iam+1,*)((zs(i,j),i=1,nbp_lon),j=1,nbp_lat)
+  ! write(iam+1,*)((ps(i,j),i=1,nbp_lon),j=1,nbp_lat)
+  ! write(iam+1,*)((ub(i,j),i=1,nbp_lon),j=1,nbp_lat)
+  ! write(iam+1,*)((vb(i,j),i=1,nbp_lon),j=1,nbp_lat)
+  ! write(iam+1,*)((ssou(i,j),i=1,nbp_lon),j=1,nbp_lat)
+  ! write(iam+1,*)((ssov(i,j),i=1,nbp_lon),j=1,nbp_lat)
+  ! write(iam+1,*)((blsu(i,j),i=1,nbp_lon),j=1,nbp_lat)
+  ! write(iam+1,*)((blsv(i,j),i=1,nbp_lon),j=1,nbp_lat)
+
+  aam = raam(3)
+  torsfc = tmou(3) + tsso(3) + tbls(3)
+
+  RETURN
+END SUBROUTINE aaam_bud
Index: DZ6/trunk/libf/phylmd/acama_gwd_rando_m.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/acama_gwd_rando_m.F90	(revision 5267)
+++ 	(revision )
@@ -1,536 +1,0 @@
-!
-! $Id$
-!
-module ACAMA_GWD_rando_m
-
-  implicit none
-
-contains
-
-  SUBROUTINE ACAMA_GWD_rando(DTIME, pp, plat, tt, uu, vv, rot, &
-       zustr, zvstr, d_u, d_v,east_gwstress,west_gwstress)
-
-    ! Parametrization of the momentum flux deposition due to a discrete
-    ! number of gravity waves. 
-    ! Author: F. Lott, A. de la Camara
-    ! July, 24th, 2014
-    ! Gaussian distribution of the source, source is vorticity squared
-    ! Reference: de la Camara and Lott (GRL, 2015, vol 42, 2071-2078 )
-    ! Lott et al (JAS, 2010, vol 67, page 157-170)
-    ! Lott et al (JAS, 2012, vol 69, page 2134-2151)
-
-!  ONLINE:
-    use dimphy, only: klon, klev
-    use assert_m, only: assert
-    USE ioipsl_getin_p_mod, ONLY : getin_p
-    USE vertical_layers_mod, ONLY : presnivs
-
-    include "YOMCST.h"
-    include "clesphys.h"
-!  OFFLINE:
-!   include "dimensions.h"
-!   include "dimphy.h"
-!END DIFFERENCE
-    include "YOEGWD.h"
-
-    ! 0. DECLARATIONS:
-
-    ! 0.1 INPUTS
-    REAL, intent(in)::DTIME ! Time step of the Physics
-    REAL, intent(in):: PP(:, :) ! (KLON, KLEV) Pressure at full levels
-    REAL, intent(in):: ROT(:,:) ! Relative vorticity              
-    REAL, intent(in):: TT(:, :) ! (KLON, KLEV) Temp at full levels 
-    REAL, intent(in):: UU(:, :) ! (KLON, KLEV) Zonal wind at full levels
-    REAL, intent(in):: VV(:, :) ! (KLON, KLEV) Merid wind at full levels
-    REAL, intent(in):: PLAT(:) ! (KLON) LATITUDE                   
-
-    ! 0.2 OUTPUTS
-    REAL, intent(out):: zustr(:), zvstr(:) ! (KLON) Surface Stresses
-
-    REAL, intent(inout):: d_u(:, :), d_v(:, :) 
-    REAL, intent(inout):: east_gwstress(:, :) !  Profile of eastward stress
-    REAL, intent(inout):: west_gwstress(:, :) !  Profile of westward stress 
-    ! (KLON, KLEV) tendencies on winds
-
-    ! O.3 INTERNAL ARRAYS
-    REAL BVLOW(klon)  !  LOW LEVEL BV FREQUENCY
-    REAL ROTBA(KLON),CORIO(KLON)  !  BAROTROPIC REL. VORTICITY AND PLANETARY
-    REAL UZ(KLON, KLEV + 1)
-
-    INTEGER II, JJ, LL
-
-    ! 0.3.0 TIME SCALE OF THE LIFE CYCLE OF THE WAVES PARAMETERIZED
-
-    REAL DELTAT
-
-    ! 0.3.1 GRAVITY-WAVES SPECIFICATIONS
-
-    INTEGER, PARAMETER:: NK = 2, NP = 2, NO = 2, NW = NK * NP * NO
-    INTEGER JK, JP, JO, JW
-    INTEGER, PARAMETER:: NA = 5  !number of realizations to get the phase speed
-    REAL KMIN, KMAX ! Min and Max horizontal wavenumbers
-    REAL CMIN, CMAX ! Min and Max absolute ph. vel.
-    REAL CPHA ! absolute PHASE VELOCITY frequency
-    REAL ZK(NW, KLON) ! Horizontal wavenumber amplitude
-    REAL ZP(NW, KLON) ! Horizontal wavenumber angle 
-    REAL ZO(NW, KLON) ! Absolute frequency !
-
-    ! Waves Intr. freq. at the 1/2 lev surrounding the full level
-    REAL ZOM(NW, KLON), ZOP(NW, KLON)
-
-    ! Wave EP-fluxes at the 2 semi levels surrounding the full level
-    REAL WWM(NW, KLON), WWP(NW, KLON)
-
-    REAL RUW0(NW, KLON) ! Fluxes at launching level
-
-    REAL RUWP(NW, KLON), RVWP(NW, KLON)
-    ! Fluxes X and Y for each waves at 1/2 Levels
-
-    INTEGER LAUNCH, LTROP ! Launching altitude and tropo altitude
-
-    REAL XLAUNCH ! Controle the launching altitude
-    REAL XTROP ! SORT of Tropopause altitude 
-    REAL RUW(KLON, KLEV + 1) ! Flux x at semi levels
-    REAL RVW(KLON, KLEV + 1) ! Flux y at semi levels
-
-    REAL PRMAX ! Maximum value of PREC, and for which our linear formula
-    ! for GWs parameterisation apply
-
-    ! 0.3.2 PARAMETERS OF WAVES DISSIPATIONS
-
-    REAL RDISS, ZOISEC ! COEFF DE DISSIPATION, SECURITY FOR INTRINSIC FREQ
-    REAL CORSEC ! SECURITY FOR INTRINSIC CORIOLIS
-    REAL RUWFRT,SATFRT
-
-    ! 0.3.3 BACKGROUND FLOW AT 1/2 LEVELS AND VERTICAL COORDINATE
-
-    REAL H0 ! Characteristic Height of the atmosphere
-    REAL DZ ! Characteristic depth of the source!
-    REAL PR, TR ! Reference Pressure and Temperature
-
-    REAL ZH(KLON, KLEV + 1) ! Log-pressure altitude
-
-    REAL UH(KLON, KLEV + 1), VH(KLON, KLEV + 1) ! Winds at 1/2 levels
-    REAL PH(KLON, KLEV + 1) ! Pressure at 1/2 levels
-    REAL PSEC ! Security to avoid division by 0 pressure
-    REAL PHM1(KLON, KLEV + 1) ! 1/Press at 1/2 levels
-    REAL BV(KLON, KLEV + 1) ! Brunt Vaisala freq. (BVF) at 1/2 levels
-    REAL BVSEC ! Security to avoid negative BVF
-
-    REAL, DIMENSION(klev+1) ::HREF
-    LOGICAL, SAVE :: gwd_reproductibilite_mpiomp=.true.
-    LOGICAL, SAVE :: firstcall = .TRUE.
-  !$OMP THREADPRIVATE(firstcall,gwd_reproductibilite_mpiomp)
-
-    CHARACTER (LEN=20) :: modname='acama_gwd_rando_m'
-    CHARACTER (LEN=80) :: abort_message
-
-
-
-  IF (firstcall) THEN
-    ! Cle introduite pour resoudre un probleme de non reproductibilite
-    ! Le but est de pouvoir tester de revenir a la version precedenete
-    ! A eliminer rapidement
-    CALL getin_p('gwd_reproductibilite_mpiomp',gwd_reproductibilite_mpiomp)
-    IF (NW+4*(NA-1)+NA>=KLEV) THEN
-       abort_message = 'NW+3*NA>=KLEV Probleme pour generation des ondes'
-       CALL abort_physic (modname,abort_message,1)
-    ENDIF
-    firstcall=.false.
-!    CALL iophys_ini(dtime)
-  ENDIF
-
-    !-----------------------------------------------------------------
-
-    ! 1. INITIALISATIONS
-
-    ! 1.1 Basic parameter
-
-    ! Are provided from elsewhere (latent heat of vaporization, dry
-    ! gaz constant for air, gravity constant, heat capacity of dry air
-    ! at constant pressure, earth rotation rate, pi).
-
-    ! 1.2 Tuning parameters of V14
-
-! Values for linear in rot (recommended):
-!   RUWFRT=0.005 ! As RUWMAX but for frontal waves 
-!   SATFRT=1.00  ! As SAT    but for frontal waves
-! Values when rot^2 is used                          
-!    RUWFRT=0.02  ! As RUWMAX but for frontal waves 
-!    SATFRT=1.00  ! As SAT    but for frontal waves
-!    CMAX = 30.   ! Characteristic phase speed
-! Values when rot^2*EXP(-pi*sqrt(J)) is used                          
-!   RUWFRT=2.5   ! As RUWMAX but for frontal waves ~ N0*F0/4*DZ
-!   SATFRT=0.60   ! As SAT    but for frontal waves
-    RUWFRT=gwd_front_ruwmax  
-    SATFRT=gwd_front_sat
-    CMAX = 50.    ! Characteristic phase speed
-! Phase speed test
-!   RUWFRT=0.01
-!   CMAX = 50.   ! Characteristic phase speed (TEST)
-! Values when rot^2 and exp(-m^2*dz^2) are used      
-!   RUWFRT=0.03  ! As RUWMAX but for frontal waves 
-!   SATFRT=1.00  ! As SAT    but for frontal waves
-! CRUCIAL PARAMETERS FOR THE WIND FILTERING
-    XLAUNCH=0.95 ! Parameter that control launching altitude
-    RDISS = 0.5  ! Diffusion parameter 
-
-    ! maximum of rain for which our theory applies (in kg/m^2/s)
-
-    DZ = 1000. ! Characteristic depth of the source
-    XTROP=0.2 ! Parameter that control tropopause altitude
-    DELTAT=24.*3600. ! Time scale of the waves (first introduced in 9b)
-!   DELTAT=DTIME     ! No AR-1 Accumulation, OR OFFLINE             
-
-    KMIN = 2.E-5
-    ! minimum horizontal wavenumber (inverse of the subgrid scale resolution)
-
-    KMAX = 1.E-3  ! Max horizontal wavenumber
-    CMIN = 1.     ! Min phase velocity
-
-    TR = 240. ! Reference Temperature
-    PR = 101300. ! Reference pressure
-    H0 = RD * TR / RG ! Characteristic vertical scale height
-
-    BVSEC = 5.E-3 ! Security to avoid negative BVF 
-    PSEC = 1.E-6 ! Security to avoid division by 0 pressure
-    ZOISEC = 1.E-6 ! Security FOR 0 INTRINSIC FREQ
-    CORSEC = ROMEGA*2.*SIN(2.*RPI/180.)! Security for CORIO
-
-!  ONLINE
-    call assert(klon == (/size(pp, 1), size(tt, 1), size(uu, 1), &
-         size(vv, 1), size(rot,1), size(zustr), size(zvstr), size(d_u, 1), &
-         size(d_v, 1), &
-        size(east_gwstress,1), size(west_gwstress,1) /), &
-        "ACAMA_GWD_RANDO klon")
-    call assert(klev == (/size(pp, 2), size(tt, 2), size(uu, 2), &
-         size(vv, 2), size(d_u, 2), size(d_v, 2), &
-         size(east_gwstress,2), size(west_gwstress,2) /), &
-         "ACAMA_GWD_RANDO klev")
-!  END ONLINE
-
-    IF(DELTAT < DTIME)THEN
-!       PRINT *, 'flott_gwd_rando: deltat < dtime!'
-!       STOP 1
-       abort_message=' deltat < dtime! '
-       CALL abort_physic(modname,abort_message,1)
-    ENDIF
-
-    IF (KLEV < NW) THEN
-!       PRINT *, 'flott_gwd_rando: you will have problem with random numbers'
-!       STOP 1
-       abort_message=' you will have problem with random numbers'
-       CALL abort_physic(modname,abort_message,1)
-    ENDIF
-
-    ! 2. EVALUATION OF THE BACKGROUND FLOW AT SEMI-LEVELS
-
-    ! Pressure and Inv of pressure
-    DO LL = 2, KLEV
-       PH(:, LL) = EXP((LOG(PP(:, LL)) + LOG(PP(:, LL - 1))) / 2.)
-       PHM1(:, LL) = 1. / PH(:, LL) 
-    end DO
-
-    PH(:, KLEV + 1) = 0. 
-    PHM1(:, KLEV + 1) = 1. / PSEC
-    PH(:, 1) = 2. * PP(:, 1) - PH(:, 2)
-
-    ! Launching altitude
-
-    IF (gwd_reproductibilite_mpiomp) THEN
-       ! Reprend la formule qui calcule PH en fonction de PP=play
-       DO LL = 2, KLEV
-          HREF(LL) = EXP((LOG(presnivs(LL)) + LOG(presnivs(LL - 1))) / 2.)
-       end DO
-       HREF(KLEV + 1) = 0.
-       HREF(1) = 2. * presnivs(1) - HREF(2)
-    ELSE
-       HREF(1:KLEV)=PH(KLON/2,1:KLEV)
-    ENDIF
-
-    LAUNCH=0
-    LTROP =0
-    DO LL = 1, KLEV
-       IF (HREF(LL) / HREF(1) > XLAUNCH) LAUNCH = LL
-    ENDDO
-    DO LL = 1, KLEV
-       IF (HREF(LL) / HREF(1) > XTROP) LTROP = LL
-    ENDDO
-    !LAUNCH=22 ; LTROP=33
-!   print*,'LAUNCH=',LAUNCH,'LTROP=',LTROP
-
-
-!   PRINT *,'LAUNCH IN ACAMARA:',LAUNCH
-
-    ! Log pressure vert. coordinate
-    DO LL = 1, KLEV + 1 
-       ZH(:, LL) = H0 * LOG(PR / (PH(:, LL) + PSEC))
-    end DO
-
-    ! BV frequency
-    DO LL = 2, KLEV
-       ! BVSEC: BV Frequency (UH USED IS AS A TEMPORARY ARRAY DOWN TO WINDS)
-       UH(:, LL) = 0.5 * (TT(:, LL) + TT(:, LL - 1)) &
-            * RD**2 / RCPD / H0**2 + (TT(:, LL) &
-            - TT(:, LL - 1)) / (ZH(:, LL) - ZH(:, LL - 1)) * RD / H0
-    end DO
-    BVLOW = 0.5 * (TT(:, LTROP )+ TT(:, LAUNCH)) &
-         * RD**2 / RCPD / H0**2 + (TT(:, LTROP ) &
-         - TT(:, LAUNCH))/(ZH(:, LTROP )- ZH(:, LAUNCH)) * RD / H0
-
-    UH(:, 1) = UH(:, 2)
-    UH(:, KLEV + 1) = UH(:, KLEV)
-    BV(:, 1) = UH(:, 2)
-    BV(:, KLEV + 1) = UH(:, KLEV)
-    ! SMOOTHING THE BV HELPS
-    DO LL = 2, KLEV
-       BV(:, LL)=(UH(:, LL+1)+2.*UH(:, LL)+UH(:, LL-1))/4.
-    end DO
-
-    BV=MAX(SQRT(MAX(BV, 0.)), BVSEC)
-    BVLOW=MAX(SQRT(MAX(BVLOW, 0.)), BVSEC)
-
-    ! WINDS
-    DO LL = 2, KLEV
-       UH(:, LL) = 0.5 * (UU(:, LL) + UU(:, LL - 1)) ! Zonal wind
-       VH(:, LL) = 0.5 * (VV(:, LL) + VV(:, LL - 1)) ! Meridional wind
-       UZ(:, LL) = ABS((SQRT(UU(:, LL)**2+VV(:, LL)**2) & 
-          - SQRT(UU(:,LL-1)**2+VV(:, LL-1)**2)) &
-          /(ZH(:, LL)-ZH(:, LL-1)) )
-    end DO
-    UH(:, 1) = 0.
-    VH(:, 1) = 0.
-    UH(:, KLEV + 1) = UU(:, KLEV)
-    VH(:, KLEV + 1) = VV(:, KLEV)
-
-    UZ(:, 1) = UZ(:, 2)
-    UZ(:, KLEV + 1) = UZ(:, KLEV)
-    UZ(:, :) = MAX(UZ(:,:), PSEC)
-
-   ! BAROTROPIC VORTICITY AND INTEGRATED CORIOLIS PARAMETER
-    
-    CORIO(:) = MAX(ROMEGA*2.*ABS(SIN(PLAT(:)*RPI/180.)),CORSEC)
-    ROTBA(:)=0.
-    DO LL = 1,KLEV-1
-        !ROTBA(:) = ROTBA(:) + (ROT(:,LL)+ROT(:,LL+1))/2./RG*(PP(:,LL)-PP(:,LL+1))
-        ! Introducing the complete formula (exp of Richardson number):
-        ROTBA(:) = ROTBA(:) + &
-                !((ROT(:,LL)+ROT(:,LL+1))/2.)**2 &
-                (CORIO(:)*TANH(ABS(ROT(:,LL)+ROT(:,LL+1))/2./CORIO(:)))**2 &
-                /RG*(PP(:,LL)-PP(:,LL+1)) &
-                * EXP(-RPI*BV(:,LL+1)/UZ(:,LL+1)) &
-!               * DZ*BV(:,LL+1)/4./ABS(CORIO(:)) 
-                * DZ*BV(:,LL+1)/4./1.E-4           !  Changes after 1991
-!ARRET
-    ENDDO
-    !   PRINT *,'MAX ROTBA:',MAXVAL(ROTBA)
-    !   ROTBA(:)=(1.*ROTBA(:)  & ! Testing zone
-    !           +0.15*CORIO(:)**2                &
-    !           /(COS(PLAT(:)*RPI/180.)+0.02)  &
-    !           )*DZ*0.01/0.0001/4. ! & ! Testing zone
-    !   MODIF GWD4 AFTER 1985
-    !            *(1.25+SIN(PLAT(:)*RPI/180.))/(1.05+SIN(PLAT(:)*RPI/180.))/1.25
-    !          *1./(COS(PLAT(:)*RPI/180.)+0.02)
-    !    CORIO(:) = MAX(ROMEGA*2.*ABS(SIN(PLAT(:)*RPI/180.)),ZOISEC)/RG*PP(:,1)
-
-    ! 3 WAVES CHARACTERISTICS CHOSEN RANDOMLY AT THE LAUNCH ALTITUDE
-
-    ! The mod functions of weird arguments are used to produce the
-    ! waves characteristics in an almost stochastic way
-
-    JW = 0
-    DO JW = 1, NW
-             ! Angle
-             DO II = 1, KLON
-                ! Angle (0 or PI so far)
-                ! ZP(JW, II) = (SIGN(1., 0.5 - MOD(TT(II, JW) * 10., 1.)) + 1.) &
-                !      * RPI / 2.
-                ! Angle between 0 and pi
-                  ZP(JW, II) = MOD(TT(II, JW) * 10., 1.) * RPI
-! TEST WITH POSITIVE WAVES ONLY (Part I/II)
-!               ZP(JW, II) = 0.
-                ! Horizontal wavenumber amplitude
-                ZK(JW, II) = KMIN + (KMAX - KMIN) * MOD(TT(II, JW) * 100., 1.)
-                ! Horizontal phase speed
-                CPHA = 0.
-                DO JJ = 1, NA
-                    CPHA = CPHA + &
-         CMAX*2.*(MOD(TT(II, JW+4*(JJ-1)+JJ)**2, 1.)-0.5)*SQRT(3.)/SQRT(NA*1.)
-                END DO
-                IF (CPHA.LT.0.)  THEN
-                   CPHA = -1.*CPHA
-                   ZP(JW,II) = ZP(JW,II) + RPI
-! TEST WITH POSITIVE WAVES ONLY (Part II/II)
-!               ZP(JW, II) = 0.
-                ENDIF
-                CPHA = CPHA + CMIN !we dont allow |c|<1m/s
-                ! Absolute frequency is imposed
-                ZO(JW, II) = CPHA * ZK(JW, II) 
-                ! Intrinsic frequency is imposed
-                ZO(JW, II) = ZO(JW, II) &
-                     + ZK(JW, II) * COS(ZP(JW, II)) * UH(II, LAUNCH) &
-                     + ZK(JW, II) * SIN(ZP(JW, II)) * VH(II, LAUNCH)
-                ! Momentum flux at launch lev 
-                ! LAUNCHED RANDOM WAVES WITH LOG-NORMAL AMPLITUDE
-                !  RIGHT IN THE SH (GWD4 after 1990)
-                  RUW0(JW, II) = 0.
-                 DO JJ = 1, NA
-                    RUW0(JW, II) = RUW0(JW,II) + &
-         2.*(MOD(TT(II, JW+4*(JJ-1)+JJ)**2, 1.)-0.5)*SQRT(3.)/SQRT(NA*1.)
-                END DO
-                RUW0(JW, II) = RUWFRT &
-                          * EXP(RUW0(JW,II))/1250. &  ! 2 mpa at south pole
-       *((1.05+SIN(PLAT(II)*RPI/180.))/(1.01+SIN(PLAT(II)*RPI/180.))-2.05/2.01)
-                ! RUW0(JW, II) = RUWFRT
-             ENDDO
-    end DO
-
-    ! 4. COMPUTE THE FLUXES
-
-    ! 4.0 
-
-    ! 4.1 Vertical velocity at launching altitude to ensure 
-    ! the correct value to the imposed fluxes.
-
-    DO JW = 1, NW
-
-       ! Evaluate intrinsic frequency at launching altitude:
-       ZOP(JW, :) = ZO(JW, :) &
-            - ZK(JW, :) * COS(ZP(JW, :)) * UH(:, LAUNCH) &
-            - ZK(JW, :) * SIN(ZP(JW, :)) * VH(:, LAUNCH) 
-
-       ! VERSION WITH FRONTAL SOURCES
-
-       ! Momentum flux at launch level imposed by vorticity sources
-
-       ! tanh limitation for values above CORIO (inertial instability).
-       ! WWP(JW, :) = RUW0(JW, :) &
-       WWP(JW, :) = RUWFRT      &
-       !     * (CORIO(:)*TANH(ROTBA(:)/CORIO(:)))**2 &
-       !    * ABS((CORIO(:)*TANH(ROTBA(:)/CORIO(:)))*CORIO(:)) &
-       !  CONSTANT FLUX
-       !    * (CORIO(:)*CORIO(:)) &
-       ! MODERATION BY THE DEPTH OF THE SOURCE (DZ HERE)
-       !      *EXP(-BVLOW(:)**2/MAX(ABS(ZOP(JW, :)),ZOISEC)**2 &
-       !      *ZK(JW, :)**2*DZ**2) &
-       ! COMPLETE FORMULA:
-            !* CORIO(:)**2*TANH(ROTBA(:)/CORIO(:)**2) &
-            * ROTBA(:) &
-       !  RESTORE DIMENSION OF A FLUX
-       !     *RD*TR/PR
-       !     *1. + RUW0(JW, :)
-             *1.
-
-       ! Factor related to the characteristics of the waves: NONE
-
-       ! Moderation by the depth of the source (dz here): NONE
-
-       ! Put the stress in the right direction:
-
-        RUWP(JW, :) = SIGN(1., ZOP(JW, :))*COS(ZP(JW, :)) * WWP(JW, :)
-        RVWP(JW, :) = SIGN(1., ZOP(JW, :))*SIN(ZP(JW, :)) * WWP(JW, :)
-
-    end DO
-
-    ! 4.2 Uniform values below the launching altitude
-
-    DO LL = 1, LAUNCH
-       RUW(:, LL) = 0
-       RVW(:, LL) = 0
-       DO JW = 1, NW
-          RUW(:, LL) = RUW(:, LL) + RUWP(JW, :)
-          RVW(:, LL) = RVW(:, LL) + RVWP(JW, :)
-       end DO
-    end DO
-
-    ! 4.3 Loop over altitudes, with passage from one level to the next
-    ! done by i) conserving the EP flux, ii) dissipating a little,
-    ! iii) testing critical levels, and vi) testing the breaking.
-
-    DO LL = LAUNCH, KLEV - 1
-       ! Warning: all the physics is here (passage from one level
-       ! to the next)
-       DO JW = 1, NW
-          ZOM(JW, :) = ZOP(JW, :)
-          WWM(JW, :) = WWP(JW, :)
-          ! Intrinsic Frequency
-          ZOP(JW, :) = ZO(JW, :) - ZK(JW, :) * COS(ZP(JW, :)) * UH(:, LL + 1) &
-               - ZK(JW, :) * SIN(ZP(JW, :)) * VH(:, LL + 1) 
-
-          ! No breaking (Eq.6)
-          ! Dissipation (Eq. 8)
-          WWP(JW, :) = WWM(JW, :) * EXP(- 4. * RDISS * PR / (PH(:, LL + 1) &
-               + PH(:, LL)) * ((BV(:, LL + 1) + BV(:, LL)) / 2.)**3 &
-               / MAX(ABS(ZOP(JW, :) + ZOM(JW, :)) / 2., ZOISEC)**4 &
-               * ZK(JW, :)**3 * (ZH(:, LL + 1) - ZH(:, LL)))
-
-          ! Critical levels (forced to zero if intrinsic frequency changes sign)
-          ! Saturation (Eq. 12)
-          WWP(JW, :) = min(WWP(JW, :), MAX(0., &
-               SIGN(1., ZOP(JW, :) * ZOM(JW, :))) * ABS(ZOP(JW, :))**3 &
-          !    / BV(:, LL + 1) * EXP(- ZH(:, LL + 1) / H0) * SATFRT**2 * KMIN**2 &
-               / BV(:, LL + 1) * EXP(- ZH(:, LL + 1) / H0) * KMIN**2 &
-!              *(SATFRT*(2.5+1.5*TANH((ZH(:,LL+1)/H0-8.)/2.)))**2 &
-               *SATFRT**2       &
-               / ZK(JW, :)**4)
-       end DO
-
-       ! Evaluate EP-flux from Eq. 7 and give the right orientation to
-       ! the stress
-
-       DO JW = 1, NW
-          RUWP(JW, :) = SIGN(1., ZOP(JW, :))*COS(ZP(JW, :)) * WWP(JW, :)
-          RVWP(JW, :) = SIGN(1., ZOP(JW, :))*SIN(ZP(JW, :)) * WWP(JW, :)
-       end DO
-
-       RUW(:, LL + 1) = 0.
-       RVW(:, LL + 1) = 0.
-
-       DO JW = 1, NW
-          RUW(:, LL + 1) = RUW(:, LL + 1) + RUWP(JW, :) 
-          RVW(:, LL + 1) = RVW(:, LL + 1) + RVWP(JW, :) 
-          EAST_GWSTRESS(:, LL)=EAST_GWSTRESS(:, LL)+MAX(0.,RUWP(JW,:))/FLOAT(NW)
-          WEST_GWSTRESS(:, LL)=WEST_GWSTRESS(:, LL)+MIN(0.,RUWP(JW,:))/FLOAT(NW)
-       end DO
-    end DO
-
-    ! 5 CALCUL DES TENDANCES:
-
-    ! 5.1 Rectification des flux au sommet et dans les basses couches
-
-    RUW(:, KLEV + 1) = 0.
-    RVW(:, KLEV + 1) = 0.
-    RUW(:, 1) = RUW(:, LAUNCH)
-    RVW(:, 1) = RVW(:, LAUNCH)
-    DO LL = 1, LAUNCH
-       RUW(:, LL) = RUW(:, LAUNCH+1)
-       RVW(:, LL) = RVW(:, LAUNCH+1)
-       EAST_GWSTRESS(:, LL)=EAST_GWSTRESS(:, LAUNCH)
-       WEST_GWSTRESS(:, LL)=WEST_GWSTRESS(:, LAUNCH)
-    end DO
-
-    ! AR-1 RECURSIVE FORMULA (13) IN VERSION 4
-    DO LL = 1, KLEV
-       D_U(:, LL) = (1.-DTIME/DELTAT) * D_U(:, LL) + DTIME/DELTAT/REAL(NW) * &
-            RG * (RUW(:, LL + 1) - RUW(:, LL)) &
-            / (PH(:, LL + 1) - PH(:, LL)) * DTIME
-!  NO AR1 FOR MERIDIONAL TENDENCIES
-!      D_V(:, LL) = (1.-DTIME/DELTAT) * D_V(:, LL) + DTIME/DELTAT/REAL(NW) * &
-       D_V(:, LL) =                                            1./REAL(NW) * &
-            RG * (RVW(:, LL + 1) - RVW(:, LL)) &
-            / (PH(:, LL + 1) - PH(:, LL)) * DTIME
-    ENDDO
-
-    ! Cosmetic: evaluation of the cumulated stress
-    ZUSTR = 0.
-    ZVSTR = 0.
-    DO LL = 1, KLEV
-       ZUSTR = ZUSTR + D_U(:, LL) / RG * (PH(:, LL + 1) - PH(:, LL))/DTIME
-!      ZVSTR = ZVSTR + D_V(:, LL) / RG * (PH(:, LL + 1) - PH(:, LL))/DTIME
-    ENDDO
-! COSMETICS TO VISUALIZE ROTBA
-    ZVSTR = ROTBA
-
-  END SUBROUTINE ACAMA_GWD_RANDO
-
-end module ACAMA_GWD_rando_m
Index: /LMDZ6/trunk/libf/phylmd/acama_gwd_rando_m.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/acama_gwd_rando_m.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/acama_gwd_rando_m.f90	(revision 5268)
@@ -0,0 +1,536 @@
+!
+! $Id$
+!
+module ACAMA_GWD_rando_m
+
+  implicit none
+
+contains
+
+  SUBROUTINE ACAMA_GWD_rando(DTIME, pp, plat, tt, uu, vv, rot, &
+       zustr, zvstr, d_u, d_v,east_gwstress,west_gwstress)
+
+    ! Parametrization of the momentum flux deposition due to a discrete
+    ! number of gravity waves. 
+    ! Author: F. Lott, A. de la Camara
+    ! July, 24th, 2014
+    ! Gaussian distribution of the source, source is vorticity squared
+    ! Reference: de la Camara and Lott (GRL, 2015, vol 42, 2071-2078 )
+    ! Lott et al (JAS, 2010, vol 67, page 157-170)
+    ! Lott et al (JAS, 2012, vol 69, page 2134-2151)
+
+!  ONLINE:
+    use dimphy, only: klon, klev
+    use assert_m, only: assert
+    USE ioipsl_getin_p_mod, ONLY : getin_p
+    USE vertical_layers_mod, ONLY : presnivs
+
+    include "YOMCST.h"
+    include "clesphys.h"
+!  OFFLINE:
+!   include "dimensions.h"
+!   include "dimphy.h"
+!END DIFFERENCE
+    include "YOEGWD.h"
+
+    ! 0. DECLARATIONS:
+
+    ! 0.1 INPUTS
+    REAL, intent(in)::DTIME ! Time step of the Physics
+    REAL, intent(in):: PP(:, :) ! (KLON, KLEV) Pressure at full levels
+    REAL, intent(in):: ROT(:,:) ! Relative vorticity              
+    REAL, intent(in):: TT(:, :) ! (KLON, KLEV) Temp at full levels 
+    REAL, intent(in):: UU(:, :) ! (KLON, KLEV) Zonal wind at full levels
+    REAL, intent(in):: VV(:, :) ! (KLON, KLEV) Merid wind at full levels
+    REAL, intent(in):: PLAT(:) ! (KLON) LATITUDE                   
+
+    ! 0.2 OUTPUTS
+    REAL, intent(out):: zustr(:), zvstr(:) ! (KLON) Surface Stresses
+
+    REAL, intent(inout):: d_u(:, :), d_v(:, :) 
+    REAL, intent(inout):: east_gwstress(:, :) !  Profile of eastward stress
+    REAL, intent(inout):: west_gwstress(:, :) !  Profile of westward stress 
+    ! (KLON, KLEV) tendencies on winds
+
+    ! O.3 INTERNAL ARRAYS
+    REAL BVLOW(klon)  !  LOW LEVEL BV FREQUENCY
+    REAL ROTBA(KLON),CORIO(KLON)  !  BAROTROPIC REL. VORTICITY AND PLANETARY
+    REAL UZ(KLON, KLEV + 1)
+
+    INTEGER II, JJ, LL
+
+    ! 0.3.0 TIME SCALE OF THE LIFE CYCLE OF THE WAVES PARAMETERIZED
+
+    REAL DELTAT
+
+    ! 0.3.1 GRAVITY-WAVES SPECIFICATIONS
+
+    INTEGER, PARAMETER:: NK = 2, NP = 2, NO = 2, NW = NK * NP * NO
+    INTEGER JK, JP, JO, JW
+    INTEGER, PARAMETER:: NA = 5  !number of realizations to get the phase speed
+    REAL KMIN, KMAX ! Min and Max horizontal wavenumbers
+    REAL CMIN, CMAX ! Min and Max absolute ph. vel.
+    REAL CPHA ! absolute PHASE VELOCITY frequency
+    REAL ZK(NW, KLON) ! Horizontal wavenumber amplitude
+    REAL ZP(NW, KLON) ! Horizontal wavenumber angle 
+    REAL ZO(NW, KLON) ! Absolute frequency !
+
+    ! Waves Intr. freq. at the 1/2 lev surrounding the full level
+    REAL ZOM(NW, KLON), ZOP(NW, KLON)
+
+    ! Wave EP-fluxes at the 2 semi levels surrounding the full level
+    REAL WWM(NW, KLON), WWP(NW, KLON)
+
+    REAL RUW0(NW, KLON) ! Fluxes at launching level
+
+    REAL RUWP(NW, KLON), RVWP(NW, KLON)
+    ! Fluxes X and Y for each waves at 1/2 Levels
+
+    INTEGER LAUNCH, LTROP ! Launching altitude and tropo altitude
+
+    REAL XLAUNCH ! Controle the launching altitude
+    REAL XTROP ! SORT of Tropopause altitude 
+    REAL RUW(KLON, KLEV + 1) ! Flux x at semi levels
+    REAL RVW(KLON, KLEV + 1) ! Flux y at semi levels
+
+    REAL PRMAX ! Maximum value of PREC, and for which our linear formula
+    ! for GWs parameterisation apply
+
+    ! 0.3.2 PARAMETERS OF WAVES DISSIPATIONS
+
+    REAL RDISS, ZOISEC ! COEFF DE DISSIPATION, SECURITY FOR INTRINSIC FREQ
+    REAL CORSEC ! SECURITY FOR INTRINSIC CORIOLIS
+    REAL RUWFRT,SATFRT
+
+    ! 0.3.3 BACKGROUND FLOW AT 1/2 LEVELS AND VERTICAL COORDINATE
+
+    REAL H0 ! Characteristic Height of the atmosphere
+    REAL DZ ! Characteristic depth of the source!
+    REAL PR, TR ! Reference Pressure and Temperature
+
+    REAL ZH(KLON, KLEV + 1) ! Log-pressure altitude
+
+    REAL UH(KLON, KLEV + 1), VH(KLON, KLEV + 1) ! Winds at 1/2 levels
+    REAL PH(KLON, KLEV + 1) ! Pressure at 1/2 levels
+    REAL PSEC ! Security to avoid division by 0 pressure
+    REAL PHM1(KLON, KLEV + 1) ! 1/Press at 1/2 levels
+    REAL BV(KLON, KLEV + 1) ! Brunt Vaisala freq. (BVF) at 1/2 levels
+    REAL BVSEC ! Security to avoid negative BVF
+
+    REAL, DIMENSION(klev+1) ::HREF
+    LOGICAL, SAVE :: gwd_reproductibilite_mpiomp=.true.
+    LOGICAL, SAVE :: firstcall = .TRUE.
+  !$OMP THREADPRIVATE(firstcall,gwd_reproductibilite_mpiomp)
+
+    CHARACTER (LEN=20) :: modname='acama_gwd_rando_m'
+    CHARACTER (LEN=80) :: abort_message
+
+
+
+  IF (firstcall) THEN
+    ! Cle introduite pour resoudre un probleme de non reproductibilite
+    ! Le but est de pouvoir tester de revenir a la version precedenete
+    ! A eliminer rapidement
+    CALL getin_p('gwd_reproductibilite_mpiomp',gwd_reproductibilite_mpiomp)
+    IF (NW+4*(NA-1)+NA>=KLEV) THEN
+       abort_message = 'NW+3*NA>=KLEV Probleme pour generation des ondes'
+       CALL abort_physic (modname,abort_message,1)
+    ENDIF
+    firstcall=.false.
+!    CALL iophys_ini(dtime)
+  ENDIF
+
+    !-----------------------------------------------------------------
+
+    ! 1. INITIALISATIONS
+
+    ! 1.1 Basic parameter
+
+    ! Are provided from elsewhere (latent heat of vaporization, dry
+    ! gaz constant for air, gravity constant, heat capacity of dry air
+    ! at constant pressure, earth rotation rate, pi).
+
+    ! 1.2 Tuning parameters of V14
+
+! Values for linear in rot (recommended):
+!   RUWFRT=0.005 ! As RUWMAX but for frontal waves 
+!   SATFRT=1.00  ! As SAT    but for frontal waves
+! Values when rot^2 is used                          
+!    RUWFRT=0.02  ! As RUWMAX but for frontal waves 
+!    SATFRT=1.00  ! As SAT    but for frontal waves
+!    CMAX = 30.   ! Characteristic phase speed
+! Values when rot^2*EXP(-pi*sqrt(J)) is used                          
+!   RUWFRT=2.5   ! As RUWMAX but for frontal waves ~ N0*F0/4*DZ
+!   SATFRT=0.60   ! As SAT    but for frontal waves
+    RUWFRT=gwd_front_ruwmax  
+    SATFRT=gwd_front_sat
+    CMAX = 50.    ! Characteristic phase speed
+! Phase speed test
+!   RUWFRT=0.01
+!   CMAX = 50.   ! Characteristic phase speed (TEST)
+! Values when rot^2 and exp(-m^2*dz^2) are used      
+!   RUWFRT=0.03  ! As RUWMAX but for frontal waves 
+!   SATFRT=1.00  ! As SAT    but for frontal waves
+! CRUCIAL PARAMETERS FOR THE WIND FILTERING
+    XLAUNCH=0.95 ! Parameter that control launching altitude
+    RDISS = 0.5  ! Diffusion parameter 
+
+    ! maximum of rain for which our theory applies (in kg/m^2/s)
+
+    DZ = 1000. ! Characteristic depth of the source
+    XTROP=0.2 ! Parameter that control tropopause altitude
+    DELTAT=24.*3600. ! Time scale of the waves (first introduced in 9b)
+!   DELTAT=DTIME     ! No AR-1 Accumulation, OR OFFLINE             
+
+    KMIN = 2.E-5
+    ! minimum horizontal wavenumber (inverse of the subgrid scale resolution)
+
+    KMAX = 1.E-3  ! Max horizontal wavenumber
+    CMIN = 1.     ! Min phase velocity
+
+    TR = 240. ! Reference Temperature
+    PR = 101300. ! Reference pressure
+    H0 = RD * TR / RG ! Characteristic vertical scale height
+
+    BVSEC = 5.E-3 ! Security to avoid negative BVF 
+    PSEC = 1.E-6 ! Security to avoid division by 0 pressure
+    ZOISEC = 1.E-6 ! Security FOR 0 INTRINSIC FREQ
+    CORSEC = ROMEGA*2.*SIN(2.*RPI/180.)! Security for CORIO
+
+!  ONLINE
+    call assert(klon == (/size(pp, 1), size(tt, 1), size(uu, 1), &
+         size(vv, 1), size(rot,1), size(zustr), size(zvstr), size(d_u, 1), &
+         size(d_v, 1), &
+        size(east_gwstress,1), size(west_gwstress,1) /), &
+        "ACAMA_GWD_RANDO klon")
+    call assert(klev == (/size(pp, 2), size(tt, 2), size(uu, 2), &
+         size(vv, 2), size(d_u, 2), size(d_v, 2), &
+         size(east_gwstress,2), size(west_gwstress,2) /), &
+         "ACAMA_GWD_RANDO klev")
+!  END ONLINE
+
+    IF(DELTAT < DTIME)THEN
+!       PRINT *, 'flott_gwd_rando: deltat < dtime!'
+!       STOP 1
+       abort_message=' deltat < dtime! '
+       CALL abort_physic(modname,abort_message,1)
+    ENDIF
+
+    IF (KLEV < NW) THEN
+!       PRINT *, 'flott_gwd_rando: you will have problem with random numbers'
+!       STOP 1
+       abort_message=' you will have problem with random numbers'
+       CALL abort_physic(modname,abort_message,1)
+    ENDIF
+
+    ! 2. EVALUATION OF THE BACKGROUND FLOW AT SEMI-LEVELS
+
+    ! Pressure and Inv of pressure
+    DO LL = 2, KLEV
+       PH(:, LL) = EXP((LOG(PP(:, LL)) + LOG(PP(:, LL - 1))) / 2.)
+       PHM1(:, LL) = 1. / PH(:, LL) 
+    end DO
+
+    PH(:, KLEV + 1) = 0. 
+    PHM1(:, KLEV + 1) = 1. / PSEC
+    PH(:, 1) = 2. * PP(:, 1) - PH(:, 2)
+
+    ! Launching altitude
+
+    IF (gwd_reproductibilite_mpiomp) THEN
+       ! Reprend la formule qui calcule PH en fonction de PP=play
+       DO LL = 2, KLEV
+          HREF(LL) = EXP((LOG(presnivs(LL)) + LOG(presnivs(LL - 1))) / 2.)
+       end DO
+       HREF(KLEV + 1) = 0.
+       HREF(1) = 2. * presnivs(1) - HREF(2)
+    ELSE
+       HREF(1:KLEV)=PH(KLON/2,1:KLEV)
+    ENDIF
+
+    LAUNCH=0
+    LTROP =0
+    DO LL = 1, KLEV
+       IF (HREF(LL) / HREF(1) > XLAUNCH) LAUNCH = LL
+    ENDDO
+    DO LL = 1, KLEV
+       IF (HREF(LL) / HREF(1) > XTROP) LTROP = LL
+    ENDDO
+    !LAUNCH=22 ; LTROP=33
+!   print*,'LAUNCH=',LAUNCH,'LTROP=',LTROP
+
+
+!   PRINT *,'LAUNCH IN ACAMARA:',LAUNCH
+
+    ! Log pressure vert. coordinate
+    DO LL = 1, KLEV + 1 
+       ZH(:, LL) = H0 * LOG(PR / (PH(:, LL) + PSEC))
+    end DO
+
+    ! BV frequency
+    DO LL = 2, KLEV
+       ! BVSEC: BV Frequency (UH USED IS AS A TEMPORARY ARRAY DOWN TO WINDS)
+       UH(:, LL) = 0.5 * (TT(:, LL) + TT(:, LL - 1)) &
+            * RD**2 / RCPD / H0**2 + (TT(:, LL) &
+            - TT(:, LL - 1)) / (ZH(:, LL) - ZH(:, LL - 1)) * RD / H0
+    end DO
+    BVLOW = 0.5 * (TT(:, LTROP )+ TT(:, LAUNCH)) &
+         * RD**2 / RCPD / H0**2 + (TT(:, LTROP ) &
+         - TT(:, LAUNCH))/(ZH(:, LTROP )- ZH(:, LAUNCH)) * RD / H0
+
+    UH(:, 1) = UH(:, 2)
+    UH(:, KLEV + 1) = UH(:, KLEV)
+    BV(:, 1) = UH(:, 2)
+    BV(:, KLEV + 1) = UH(:, KLEV)
+    ! SMOOTHING THE BV HELPS
+    DO LL = 2, KLEV
+       BV(:, LL)=(UH(:, LL+1)+2.*UH(:, LL)+UH(:, LL-1))/4.
+    end DO
+
+    BV=MAX(SQRT(MAX(BV, 0.)), BVSEC)
+    BVLOW=MAX(SQRT(MAX(BVLOW, 0.)), BVSEC)
+
+    ! WINDS
+    DO LL = 2, KLEV
+       UH(:, LL) = 0.5 * (UU(:, LL) + UU(:, LL - 1)) ! Zonal wind
+       VH(:, LL) = 0.5 * (VV(:, LL) + VV(:, LL - 1)) ! Meridional wind
+       UZ(:, LL) = ABS((SQRT(UU(:, LL)**2+VV(:, LL)**2) & 
+          - SQRT(UU(:,LL-1)**2+VV(:, LL-1)**2)) &
+          /(ZH(:, LL)-ZH(:, LL-1)) )
+    end DO
+    UH(:, 1) = 0.
+    VH(:, 1) = 0.
+    UH(:, KLEV + 1) = UU(:, KLEV)
+    VH(:, KLEV + 1) = VV(:, KLEV)
+
+    UZ(:, 1) = UZ(:, 2)
+    UZ(:, KLEV + 1) = UZ(:, KLEV)
+    UZ(:, :) = MAX(UZ(:,:), PSEC)
+
+   ! BAROTROPIC VORTICITY AND INTEGRATED CORIOLIS PARAMETER
+    
+    CORIO(:) = MAX(ROMEGA*2.*ABS(SIN(PLAT(:)*RPI/180.)),CORSEC)
+    ROTBA(:)=0.
+    DO LL = 1,KLEV-1
+        !ROTBA(:) = ROTBA(:) + (ROT(:,LL)+ROT(:,LL+1))/2./RG*(PP(:,LL)-PP(:,LL+1))
+        ! Introducing the complete formula (exp of Richardson number):
+        ROTBA(:) = ROTBA(:) + &
+                !((ROT(:,LL)+ROT(:,LL+1))/2.)**2 &
+                (CORIO(:)*TANH(ABS(ROT(:,LL)+ROT(:,LL+1))/2./CORIO(:)))**2 &
+                /RG*(PP(:,LL)-PP(:,LL+1)) &
+                * EXP(-RPI*BV(:,LL+1)/UZ(:,LL+1)) &
+!               * DZ*BV(:,LL+1)/4./ABS(CORIO(:)) 
+                * DZ*BV(:,LL+1)/4./1.E-4           !  Changes after 1991
+!ARRET
+    ENDDO
+    !   PRINT *,'MAX ROTBA:',MAXVAL(ROTBA)
+    !   ROTBA(:)=(1.*ROTBA(:)  & ! Testing zone
+    !           +0.15*CORIO(:)**2                &
+    !           /(COS(PLAT(:)*RPI/180.)+0.02)  &
+    !           )*DZ*0.01/0.0001/4. ! & ! Testing zone
+    !   MODIF GWD4 AFTER 1985
+    !            *(1.25+SIN(PLAT(:)*RPI/180.))/(1.05+SIN(PLAT(:)*RPI/180.))/1.25
+    !          *1./(COS(PLAT(:)*RPI/180.)+0.02)
+    !    CORIO(:) = MAX(ROMEGA*2.*ABS(SIN(PLAT(:)*RPI/180.)),ZOISEC)/RG*PP(:,1)
+
+    ! 3 WAVES CHARACTERISTICS CHOSEN RANDOMLY AT THE LAUNCH ALTITUDE
+
+    ! The mod functions of weird arguments are used to produce the
+    ! waves characteristics in an almost stochastic way
+
+    JW = 0
+    DO JW = 1, NW
+             ! Angle
+             DO II = 1, KLON
+                ! Angle (0 or PI so far)
+                ! ZP(JW, II) = (SIGN(1., 0.5 - MOD(TT(II, JW) * 10., 1.)) + 1.) &
+                !      * RPI / 2.
+                ! Angle between 0 and pi
+                  ZP(JW, II) = MOD(TT(II, JW) * 10., 1.) * RPI
+! TEST WITH POSITIVE WAVES ONLY (Part I/II)
+!               ZP(JW, II) = 0.
+                ! Horizontal wavenumber amplitude
+                ZK(JW, II) = KMIN + (KMAX - KMIN) * MOD(TT(II, JW) * 100., 1.)
+                ! Horizontal phase speed
+                CPHA = 0.
+                DO JJ = 1, NA
+                    CPHA = CPHA + &
+         CMAX*2.*(MOD(TT(II, JW+4*(JJ-1)+JJ)**2, 1.)-0.5)*SQRT(3.)/SQRT(NA*1.)
+                END DO
+                IF (CPHA.LT.0.)  THEN
+                   CPHA = -1.*CPHA
+                   ZP(JW,II) = ZP(JW,II) + RPI
+! TEST WITH POSITIVE WAVES ONLY (Part II/II)
+!               ZP(JW, II) = 0.
+                ENDIF
+                CPHA = CPHA + CMIN !we dont allow |c|<1m/s
+                ! Absolute frequency is imposed
+                ZO(JW, II) = CPHA * ZK(JW, II) 
+                ! Intrinsic frequency is imposed
+                ZO(JW, II) = ZO(JW, II) &
+                     + ZK(JW, II) * COS(ZP(JW, II)) * UH(II, LAUNCH) &
+                     + ZK(JW, II) * SIN(ZP(JW, II)) * VH(II, LAUNCH)
+                ! Momentum flux at launch lev 
+                ! LAUNCHED RANDOM WAVES WITH LOG-NORMAL AMPLITUDE
+                !  RIGHT IN THE SH (GWD4 after 1990)
+                  RUW0(JW, II) = 0.
+                 DO JJ = 1, NA
+                    RUW0(JW, II) = RUW0(JW,II) + &
+         2.*(MOD(TT(II, JW+4*(JJ-1)+JJ)**2, 1.)-0.5)*SQRT(3.)/SQRT(NA*1.)
+                END DO
+                RUW0(JW, II) = RUWFRT &
+                          * EXP(RUW0(JW,II))/1250. &  ! 2 mpa at south pole
+       *((1.05+SIN(PLAT(II)*RPI/180.))/(1.01+SIN(PLAT(II)*RPI/180.))-2.05/2.01)
+                ! RUW0(JW, II) = RUWFRT
+             ENDDO
+    end DO
+
+    ! 4. COMPUTE THE FLUXES
+
+    ! 4.0 
+
+    ! 4.1 Vertical velocity at launching altitude to ensure 
+    ! the correct value to the imposed fluxes.
+
+    DO JW = 1, NW
+
+       ! Evaluate intrinsic frequency at launching altitude:
+       ZOP(JW, :) = ZO(JW, :) &
+            - ZK(JW, :) * COS(ZP(JW, :)) * UH(:, LAUNCH) &
+            - ZK(JW, :) * SIN(ZP(JW, :)) * VH(:, LAUNCH) 
+
+       ! VERSION WITH FRONTAL SOURCES
+
+       ! Momentum flux at launch level imposed by vorticity sources
+
+       ! tanh limitation for values above CORIO (inertial instability).
+       ! WWP(JW, :) = RUW0(JW, :) &
+       WWP(JW, :) = RUWFRT      &
+       !     * (CORIO(:)*TANH(ROTBA(:)/CORIO(:)))**2 &
+       !    * ABS((CORIO(:)*TANH(ROTBA(:)/CORIO(:)))*CORIO(:)) &
+       !  CONSTANT FLUX
+       !    * (CORIO(:)*CORIO(:)) &
+       ! MODERATION BY THE DEPTH OF THE SOURCE (DZ HERE)
+       !      *EXP(-BVLOW(:)**2/MAX(ABS(ZOP(JW, :)),ZOISEC)**2 &
+       !      *ZK(JW, :)**2*DZ**2) &
+       ! COMPLETE FORMULA:
+            !* CORIO(:)**2*TANH(ROTBA(:)/CORIO(:)**2) &
+            * ROTBA(:) &
+       !  RESTORE DIMENSION OF A FLUX
+       !     *RD*TR/PR
+       !     *1. + RUW0(JW, :)
+             *1.
+
+       ! Factor related to the characteristics of the waves: NONE
+
+       ! Moderation by the depth of the source (dz here): NONE
+
+       ! Put the stress in the right direction:
+
+        RUWP(JW, :) = SIGN(1., ZOP(JW, :))*COS(ZP(JW, :)) * WWP(JW, :)
+        RVWP(JW, :) = SIGN(1., ZOP(JW, :))*SIN(ZP(JW, :)) * WWP(JW, :)
+
+    end DO
+
+    ! 4.2 Uniform values below the launching altitude
+
+    DO LL = 1, LAUNCH
+       RUW(:, LL) = 0
+       RVW(:, LL) = 0
+       DO JW = 1, NW
+          RUW(:, LL) = RUW(:, LL) + RUWP(JW, :)
+          RVW(:, LL) = RVW(:, LL) + RVWP(JW, :)
+       end DO
+    end DO
+
+    ! 4.3 Loop over altitudes, with passage from one level to the next
+    ! done by i) conserving the EP flux, ii) dissipating a little,
+    ! iii) testing critical levels, and vi) testing the breaking.
+
+    DO LL = LAUNCH, KLEV - 1
+       ! Warning: all the physics is here (passage from one level
+       ! to the next)
+       DO JW = 1, NW
+          ZOM(JW, :) = ZOP(JW, :)
+          WWM(JW, :) = WWP(JW, :)
+          ! Intrinsic Frequency
+          ZOP(JW, :) = ZO(JW, :) - ZK(JW, :) * COS(ZP(JW, :)) * UH(:, LL + 1) &
+               - ZK(JW, :) * SIN(ZP(JW, :)) * VH(:, LL + 1) 
+
+          ! No breaking (Eq.6)
+          ! Dissipation (Eq. 8)
+          WWP(JW, :) = WWM(JW, :) * EXP(- 4. * RDISS * PR / (PH(:, LL + 1) &
+               + PH(:, LL)) * ((BV(:, LL + 1) + BV(:, LL)) / 2.)**3 &
+               / MAX(ABS(ZOP(JW, :) + ZOM(JW, :)) / 2., ZOISEC)**4 &
+               * ZK(JW, :)**3 * (ZH(:, LL + 1) - ZH(:, LL)))
+
+          ! Critical levels (forced to zero if intrinsic frequency changes sign)
+          ! Saturation (Eq. 12)
+          WWP(JW, :) = min(WWP(JW, :), MAX(0., &
+               SIGN(1., ZOP(JW, :) * ZOM(JW, :))) * ABS(ZOP(JW, :))**3 &
+          !    / BV(:, LL + 1) * EXP(- ZH(:, LL + 1) / H0) * SATFRT**2 * KMIN**2 &
+               / BV(:, LL + 1) * EXP(- ZH(:, LL + 1) / H0) * KMIN**2 &
+!              *(SATFRT*(2.5+1.5*TANH((ZH(:,LL+1)/H0-8.)/2.)))**2 &
+               *SATFRT**2       &
+               / ZK(JW, :)**4)
+       end DO
+
+       ! Evaluate EP-flux from Eq. 7 and give the right orientation to
+       ! the stress
+
+       DO JW = 1, NW
+          RUWP(JW, :) = SIGN(1., ZOP(JW, :))*COS(ZP(JW, :)) * WWP(JW, :)
+          RVWP(JW, :) = SIGN(1., ZOP(JW, :))*SIN(ZP(JW, :)) * WWP(JW, :)
+       end DO
+
+       RUW(:, LL + 1) = 0.
+       RVW(:, LL + 1) = 0.
+
+       DO JW = 1, NW
+          RUW(:, LL + 1) = RUW(:, LL + 1) + RUWP(JW, :) 
+          RVW(:, LL + 1) = RVW(:, LL + 1) + RVWP(JW, :) 
+          EAST_GWSTRESS(:, LL)=EAST_GWSTRESS(:, LL)+MAX(0.,RUWP(JW,:))/FLOAT(NW)
+          WEST_GWSTRESS(:, LL)=WEST_GWSTRESS(:, LL)+MIN(0.,RUWP(JW,:))/FLOAT(NW)
+       end DO
+    end DO
+
+    ! 5 CALCUL DES TENDANCES:
+
+    ! 5.1 Rectification des flux au sommet et dans les basses couches
+
+    RUW(:, KLEV + 1) = 0.
+    RVW(:, KLEV + 1) = 0.
+    RUW(:, 1) = RUW(:, LAUNCH)
+    RVW(:, 1) = RVW(:, LAUNCH)
+    DO LL = 1, LAUNCH
+       RUW(:, LL) = RUW(:, LAUNCH+1)
+       RVW(:, LL) = RVW(:, LAUNCH+1)
+       EAST_GWSTRESS(:, LL)=EAST_GWSTRESS(:, LAUNCH)
+       WEST_GWSTRESS(:, LL)=WEST_GWSTRESS(:, LAUNCH)
+    end DO
+
+    ! AR-1 RECURSIVE FORMULA (13) IN VERSION 4
+    DO LL = 1, KLEV
+       D_U(:, LL) = (1.-DTIME/DELTAT) * D_U(:, LL) + DTIME/DELTAT/REAL(NW) * &
+            RG * (RUW(:, LL + 1) - RUW(:, LL)) &
+            / (PH(:, LL + 1) - PH(:, LL)) * DTIME
+!  NO AR1 FOR MERIDIONAL TENDENCIES
+!      D_V(:, LL) = (1.-DTIME/DELTAT) * D_V(:, LL) + DTIME/DELTAT/REAL(NW) * &
+       D_V(:, LL) =                                            1./REAL(NW) * &
+            RG * (RVW(:, LL + 1) - RVW(:, LL)) &
+            / (PH(:, LL + 1) - PH(:, LL)) * DTIME
+    ENDDO
+
+    ! Cosmetic: evaluation of the cumulated stress
+    ZUSTR = 0.
+    ZVSTR = 0.
+    DO LL = 1, KLEV
+       ZUSTR = ZUSTR + D_U(:, LL) / RG * (PH(:, LL + 1) - PH(:, LL))/DTIME
+!      ZVSTR = ZVSTR + D_V(:, LL) / RG * (PH(:, LL + 1) - PH(:, LL))/DTIME
+    ENDDO
+! COSMETICS TO VISUALIZE ROTBA
+    ZVSTR = ROTBA
+
+  END SUBROUTINE ACAMA_GWD_RANDO
+
+end module ACAMA_GWD_rando_m
Index: DZ6/trunk/libf/phylmd/add_phys_tend_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/add_phys_tend_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,843 +1,0 @@
-!
-! $Id$
-!
-!
-MODULE add_phys_tend_mod
-
-  IMPLICIT NONE  
-  ! flag to compute diagnostics to check energy conservation. If  fl_ebil==0, no check
-  INTEGER, SAVE ::   fl_ebil
-!$OMP THREADPRIVATE(fl_ebil)
-  ! flag to include modifcations to ensure energy conservation. If  fl_cor_ebil==0, no corrections
-  ! Note that with time, all these modifications should be included by default
-  INTEGER, SAVE ::   fl_cor_ebil
-!$OMP THREADPRIVATE(fl_cor_ebil)
-
-CONTAINS
-
-SUBROUTINE add_pbl_tend(zdu, zdv, zdt, zdq, zdql, zdqi, zdqbs, paprs, text,abortphy,flag_inhib_tend, itap)
-  ! ======================================================================
-  ! Ajoute les tendances de couche limite, soit determinees par la
-  ! parametrisation
-  ! physique, soit forcees,  aux variables d etat de la dynamique t_seri,
-  ! q_seri ...
-  ! ======================================================================
-
-
-  ! ======================================================================
-  ! Declarations
-  ! ======================================================================
-
-  USE dimphy, ONLY: klon, klev
-!  USE dimphy
-  USE phys_local_var_mod
-  USE phys_state_var_mod
-  USE mod_grid_phy_lmdz, ONLY: nbp_lev
-  IMPLICIT NONE
-  REAL,SAVE,ALLOCATABLE :: hthturb_gcssold(:)
-  REAL,SAVE,ALLOCATABLE :: hqturb_gcssold(:)
-!$OMP THREADPRIVATE(hthturb_gcssold,hqturb_gcssold)
-  REAL,SAVE :: dtime_frcg
-  LOGICAL,SAVE :: turb_fcg_gcssold
-  LOGICAL,SAVE :: firstcall=.true.
-!$OMP THREADPRIVATE(firstcall,turb_fcg_gcssold,dtime_frcg)
-  INTEGER abortphy
-!  COMMON /turb_forcing/dtime_frcg, hthturb_gcssold, hqturb_gcssold, &
-!    turb_fcg_gcssold
-
-  ! Arguments :
-  ! ------------
-  REAL zdu(klon, klev), zdv(klon, klev)
-  REAL zdt(klon, klev), zdq(klon, klev), zdql(klon, klev), zdqi(klon, klev), zdqbs(klon,klev)
-  CHARACTER *(*) text
-  REAL paprs(klon,klev+1)
-  INTEGER flag_inhib_tend ! if flag_inhib_tend != 0, tendencies are not added
-  INTEGER itap ! time step number
-
-  ! Local :
-  ! --------
-  REAL zzdt(klon, klev), zzdq(klon, klev)
-  INTEGER i, k
-
-  IF (firstcall) THEN
-    ALLOCATE(hthturb_gcssold(nbp_lev))
-    ALLOCATE(hqturb_gcssold(nbp_lev))
-    firstcall=.false.
-  ENDIF
-
-  IF (turb_fcg_gcssold) THEN
-    DO k = 1, klev
-      DO i = 1, klon
-        zzdt(i, k) = hthturb_gcssold(k)*dtime_frcg
-        zzdq(i, k) = hqturb_gcssold(k)*dtime_frcg
-      ENDDO
-    ENDDO
-    PRINT *, ' add_pbl_tend, dtime_frcg ', dtime_frcg
-    PRINT *, ' add_pbl_tend, zzdt ', zzdt
-    PRINT *, ' add_pbl_tend, zzdq ', zzdq
-    CALL add_phys_tend(zdu, zdv, zzdt, zzdq, zdql, zdqi, zdqbs, paprs, text,abortphy,flag_inhib_tend, itap, 0)
-  ELSE
-    CALL add_phys_tend(zdu, zdv, zdt, zdq, zdql, zdqi, zdqbs, paprs, text,abortphy,flag_inhib_tend, itap, 0)
-  ENDIF
-
-  RETURN
-END SUBROUTINE add_pbl_tend
-!
-! $Id: add_phys_tend.F90 2611 2016-08-03 15:41:26Z jyg $
-!
-SUBROUTINE add_phys_tend (zdu,zdv,zdt,zdq,zdql,zdqi,zdqbs,paprs,text, &
-                          abortphy,flag_inhib_tend, itap, diag_mode)
-!======================================================================
-! Ajoute les tendances des variables physiques aux variables 
-! d'etat de la dynamique t_seri, q_seri ...
-! On en profite pour faire des tests sur les tendances en question.
-!======================================================================
-
-
-!======================================================================
-! Declarations
-!======================================================================
-
-USE dimphy, ONLY: klon, klev
-USE phys_state_var_mod, ONLY : phys_tstep
-USE phys_local_var_mod, ONLY: u_seri, v_seri, ql_seri, qs_seri, qbs_seri, q_seri, t_seri
-USE phys_state_var_mod, ONLY: ftsol
-USE geometry_mod, ONLY: longitude_deg, latitude_deg
-USE print_control_mod, ONLY: prt_level
-USE cmp_seri_mod
-USE phys_output_var_mod, ONLY : d_qw_col, d_ql_col, d_qs_col, d_qbs_col, d_qt_col, d_ek_col, d_h_dair_col &
-  &           , d_h_qw_col, d_h_ql_col, d_h_qs_col, d_h_qbs_col, d_h_col
-IMPLICIT none
-INCLUDE "YOMCST.h"
-INCLUDE "clesphys.h"
-
-! Arguments :
-!------------
-REAL, DIMENSION(klon,klev),     INTENT(IN)    :: zdu, zdv
-REAL, DIMENSION(klon,klev),     INTENT(IN)    :: zdt, zdql, zdqi, zdqbs
-REAL, DIMENSION(klon,klev+1),   INTENT(IN)    :: paprs
-CHARACTER*(*),                  INTENT(IN)    :: text
-INTEGER,                        INTENT(IN)    :: abortphy
-INTEGER,                        INTENT(IN)    :: flag_inhib_tend ! if not 0, tendencies are not added
-INTEGER,                        INTENT(IN)    :: itap            ! time step number
-INTEGER,                        INTENT(IN)    :: diag_mode       ! 0 -> normal effective mode
-                                                                 ! 1 -> only conservation stats are computed
-!
-REAL, DIMENSION(klon,klev),     INTENT(INOUT) :: zdq
-
-! Local :
-!--------
-REAL zt,zq
-REAL zq_int, zqp_int, zq_new
-
-REAL zqp(klev)
-
-! Save variables, used in diagnostic mode (diag_mode=1).
-REAL, DIMENSION(klon,klev)   :: sav_u_seri, sav_v_seri
-REAL, DIMENSION(klon,klev)   :: sav_ql_seri, sav_qs_seri, sav_qbs_seri, sav_q_seri
-REAL, DIMENSION(klon,klev)   :: sav_t_seri
-REAL, DIMENSION(klon,klev)   :: sav_zdq
-!
-INTEGER i, k,j, n
-INTEGER jadrs(klon*klev), jbad
-INTEGER jqadrs(klon*klev), jqbad
-INTEGER kadrs(klon*klev)
-INTEGER kqadrs(klon*klev)
-
-LOGICAL done(klon)
-
-INTEGER debug_level
-LOGICAL, SAVE :: first=.true.
-!$OMP THREADPRIVATE(first)
-!
-!======================================================================
-! Variables for energy conservation tests
-!======================================================================
-!
-
-! zh_col-------  total enthalpy of vertical air column
-! (air with watter vapour, liquid and solid) (J/m2)
-! zh_dair_col--- total enthalpy of dry air (J/m2)
-! zh_qw_col----  total enthalpy of watter vapour (J/m2)
-! zh_ql_col----  total enthalpy of liquid watter (J/m2)
-! zh_qs_col----  total enthalpy of solid watter  (J/m2)
-! zh_qbs_col----  total enthalpy of blowing snow  (J/m2)
-! zqw_col------  total mass of watter vapour (kg/m2)
-! zql_col------  total mass of liquid watter (kg/m2)
-! zqs_col------  total mass of cloud ice (kg/m2)
-! zqbs_col------  total mass of blowing snow (kg/m2)
-! zek_col------  total kinetic energy (kg/m2)
-!
-REAL zairm(klon, klev) ! layer air mass (kg/m2)
-REAL zqw_col(klon,2)
-REAL zql_col(klon,2)
-REAL zqs_col(klon,2)
-REAL zqbs_col(klon,2)
-REAL zek_col(klon,2)
-REAL zh_dair_col(klon,2)
-REAL zh_qw_col(klon,2), zh_ql_col(klon,2), zh_qs_col(klon,2), zh_qbs_col(klon,2)
-REAL zh_col(klon,2)
-REAL zcpvap, zcwat, zcice
-
-!======================================================================
-! Initialisations
-
-  IF (prt_level >= 5) THEN
-     write (*,*) "In add_phys_tend, after ",text
-     CALL flush
-  ENDIf
-
-  ! if flag_inhib_tend != 0, tendencies are not added
-  IF (flag_inhib_tend /= 0) THEN
-     ! If requiered, diagnostics are shown
-     IF (flag_inhib_tend > 0) THEN
-        ! print some diagnostics if xxx_seri have changed
-        call cmp_seri(flag_inhib_tend,text)
-     ENDIF
-     RETURN ! on n ajoute pas les tendance
-  ENDIF
-
-  IF (abortphy==1) RETURN ! on n ajoute pas les tendance si le modele a deja plante.
-
-  debug_level=10
-  IF (first) THEN
-     print *,"TestJLD rcpv, rcw, rcs",rcpv, rcw, rcs
-     first=.false.
-  ENDIF
-!
-!  print *,'add_phys_tend: paprs ',paprs
-! When in diagnostic mode, save initial values of out variables
-  IF (diag_mode == 1) THEN
-    sav_u_seri(:,:)  = u_seri(:,:)
-    sav_v_seri(:,:)  = v_seri(:,:)
-    sav_ql_seri(:,:) = ql_seri(:,:)
-    sav_qs_seri(:,:) = qs_seri(:,:)
-    sav_qbs_seri(:,:) = qbs_seri(:,:)
-    sav_q_seri(:,:)  = q_seri(:,:)
-    sav_t_seri(:,:)  = t_seri(:,:)
-    sav_zdq(:,:)     = zdq(:,:)   
-  ENDIF ! (diag_mode == 1)
-!======================================================================
-! Diagnostics for energy conservation tests
-!======================================================================
-  DO k = 1, klev
-    ! layer air mass
-    zairm(:, k) = (paprs(:,k)-paprs(:,k+1))/rg
-  ENDDO
-
-  IF (fl_ebil .GT. 0) THEN
-    ! ------------------------------------------------
-    ! Compute vertical sum for each atmospheric column
-    ! ------------------------------------------------
-    n=1   ! begining of time step
-
-    zcpvap = rcpv
-    zcwat = rcw
-    zcice = rcs
-
-    CALL integr_v(klon, klev, zcpvap, &
-                  t_seri, q_seri, ql_seri, qs_seri, qbs_seri, u_seri, v_seri, zairm, &
-                    zqw_col(:,n), zql_col(:,n), zqs_col(:,n), zqbs_col(:,n), zek_col(:,n), zh_dair_col(:,n), &
-                    zh_qw_col(:,n), zh_ql_col(:,n), zh_qs_col(:,n), zh_qbs_col(:,n), zh_col(:,n))
-
-  ENDIF ! endif (fl_ebil .GT. 0)
-
-!======================================================================
-! Ajout des tendances sur le vent et l'eau liquide
-!======================================================================
-
-  u_seri(:,:)=u_seri(:,:)+zdu(:,:)
-  v_seri(:,:)=v_seri(:,:)+zdv(:,:)
-  ql_seri(:,:)=ql_seri(:,:)+zdql(:,:)
-  qs_seri(:,:)=qs_seri(:,:)+zdqi(:,:)
-  qbs_seri(:,:)=qbs_seri(:,:)+zdqbs(:,:)
-
-!======================================================================
-! On ajoute les tendances de la temperature et de la vapeur d'eau
-! en verifiant que ca ne part pas dans les choux
-!======================================================================
-
-  jbad=0
-  jqbad=0
-  DO k = 1, klev
-     DO i = 1, klon
-        zt=t_seri(i,k)+zdt(i,k)
-        zq=q_seri(i,k)+zdq(i,k)
-        IF ( zt>370. .or. zt<130. .or. abs(zdt(i,k))>50. ) THEN
-           jbad = jbad + 1
-           jadrs(jbad) = i
-           kadrs(jbad) = k
-        ENDIF
-        IF ( zq<0. .or. zq>0.1 .or. abs(zdq(i,k))>1.e-2 ) THEN
-           jqbad = jqbad + 1
-           jqadrs(jqbad) = i
-           kqadrs(jqbad) = k
-        ENDIF
-        t_seri(i,k)=zt
-        q_seri(i,k)=zq
-     ENDDO
-  ENDDO
-
-!=====================================================================================
-! Impression et stop en cas de probleme important
-!=====================================================================================
-
-  IF (jbad .GT. 0) THEN
-     DO j = 1, jbad
-        i=jadrs(j)
-        IF (prt_level.ge.debug_level) THEN
-          print*,'PLANTAGE POUR LE POINT i lon lat =',&
-                 i,longitude_deg(i),latitude_deg(i),text
-          print*,'l    T     dT       Q     dQ    '
-          DO k = 1, klev
-             write(*,'(i3,2f14.4,2e14.2)') k,t_seri(i,k),zdt(i,k),q_seri(i,k),zdq(i,k)
-          ENDDO
-          call print_debug_phys(i,debug_level,text)
-        ENDIF
-     ENDDO
-  ENDIF
-!
-!=====================================================================================
-! Impression, warning et correction en cas de probleme moins important
-!=====================================================================================
-  IF (jqbad .GT. 0) THEN
-      done(:) = .false.                         !jyg
-      DO j = 1, jqbad
-        i=jqadrs(j)
-          if(prt_level.ge.debug_level) THEN
-           print*,'WARNING  : EAU POUR LE POINT i lon lat =',&
-                  i,longitude_deg(i),latitude_deg(i),text
-           print*,'l    T     dT       Q     dQ    '
-           DO k = 1, klev
-              write(*,'(i3,2f14.4,2e14.2)') k,t_seri(i,k),zdt(i,k),q_seri(i,k),zdq(i,k)
-           ENDDO
-          ENDIF
-          IF (ok_conserv_q) THEN
-!jyg<20140228 Corrections pour conservation de l'eau
-            IF (.NOT.done(i)) THEN                  !jyg
-              DO k = 1, klev
-                zqp(k) = max(q_seri(i,k),1.e-15)
-              ENDDO
-              zq_int  = 0.
-              zqp_int = 0.
-              DO k = 1, klev
-                zq_int  = zq_int  + q_seri(i,k)*(paprs(i,k)-paprs(i,k+1))/Rg
-                zqp_int = zqp_int + zqp(k)     *(paprs(i,k)-paprs(i,k+1))/Rg
-              ENDDO
-              IF (prt_level.ge.debug_level) THEN
-               print*,' cas q_seri<1.e-15 i k zq_int zqp_int zq_int/zqp_int :', &
-                                    i, kqadrs(j), zq_int, zqp_int, zq_int/zqp_int
-              ENDIF
-              DO k = 1, klev
-                zq_new = zqp(k)*zq_int/zqp_int
-                zdq(i,k) = zdq(i,k) + zq_new - q_seri(i,k)
-                q_seri(i,k) = zq_new
-              ENDDO
-              done(i) = .true.
-            ENDIF !(.NOT.done(i))
-          ELSE 
-!jyg>
-            DO k = 1, klev
-              zq=q_seri(i,k)+zdq(i,k)
-              IF (zq.lt.1.e-15) THEN
-                 IF (q_seri(i,k).lt.1.e-15) THEN
-                   IF (prt_level.ge.debug_level) THEN
-                    print*,' cas q_seri<1.e-15 i k q_seri zq zdq :',i,k,q_seri(i,k),zq,zdq(i,k)
-                   ENDIF
-                   q_seri(i,k)=1.e-15
-                   zdq(i,k)=(1.e-15-q_seri(i,k))
-                 ENDIF
-              ENDIF
-!              zq=q_seri(i,k)+zdq(i,k)
-!              if (zq.lt.1.e-15) THEN
-!                 zdq(i,k)=(1.e-15-q_seri(i,k))
-!              endif
-            ENDDO
-!jyg<20140228
-          ENDIF   !  (ok_conserv_q)
-!jyg>
-      ENDDO ! j = 1, jqbad
-  ENDIF
-!
-
-!IM ajout memes tests pour reverifier les jbad, jqbad beg
-  jbad=0
-  jqbad=0
-  DO k = 1, klev
-     DO i = 1, klon
-        IF ( t_seri(i,k)>370. .or. t_seri(i,k)<130. .or. abs(zdt(i,k))>50. ) THEN
-        jbad = jbad + 1
-        jadrs(jbad) = i
-!         if(prt_level.ge.debug_level) THEN
-!         print*,'cas2 i k t_seri zdt',i,k,t_seri(i,k),zdt(i,k)
-!        endif
-        ENDIF
-        IF ( q_seri(i,k)<0. .or. q_seri(i,k)>0.1 .or. abs(zdq(i,k))>1.e-2 ) THEN
-        jqbad = jqbad + 1
-        jqadrs(jqbad) = i
-        kqadrs(jqbad) = k
-!        if(prt_level.ge.debug_level) THEN
-!         print*,'cas2 i k q_seri zdq',i,k,q_seri(i,k),zdq(i,k)
-!        endif
-        ENDIF
-     ENDDO
-  ENDDO
-  IF (jbad .GT. 0) THEN
-      DO j = 1, jbad
-         i=jadrs(j)
-         k=kadrs(j)
-         if(prt_level.ge.debug_level) THEN
-          print*,'PLANTAGE2 POUR LE POINT i itap lon lat txt jbad zdt t',&
-                 i,itap,longitude_deg(i),latitude_deg(i),text,jbad, &
-       &        zdt(i,k),t_seri(i,k)-zdt(i,k)
-!!!       if(prt_level.ge.10.and.itap.GE.229.and.i.EQ.3027) THEN 
-          print*,'l    T     dT       Q     dQ    '
-          DO k = 1, klev
-             write(*,'(i3,2f14.4,2e14.2)') k,t_seri(i,k),zdt(i,k),q_seri(i,k),zdq(i,k)
-          ENDDO
-          call print_debug_phys(i,debug_level,text)
-         ENDIF
-      ENDDO
-  ENDIF 
-!
-  IF (jqbad .GT. 0) THEN
-      DO j = 1, jqbad
-         i=jqadrs(j)
-         k=kqadrs(j)
-         IF (prt_level.ge.debug_level) THEN
-          print*,'WARNING  : EAU2 POUR LE POINT i itap lon lat txt jqbad zdq q zdql ql',&
-                 i,itap,longitude_deg(i),latitude_deg(i),text,jqbad,&
-       &        zdq(i,k), q_seri(i,k)-zdq(i,k), zdql(i,k), ql_seri(i,k)-zdql(i,k)
-!!!       if(prt_level.ge.10.and.itap.GE.229.and.i.EQ.3027) THEN 
-          print*,'l    T     dT       Q     dQ    '
-          DO k = 1, klev
-            write(*,'(i3,2f14.4,2e14.2)') k,t_seri(i,k),zdt(i,k),q_seri(i,k),zdq(i,k)
-          ENDDO
-          call print_debug_phys(i,debug_level,text)
-         ENDIF
-      ENDDO
-  ENDIF
-
-!======================================================================
-! Contrôle des min/max pour arrêt du modèle
-! Si le modele est en mode abortphy, on retire les tendances qu'on
-! vient d'ajouter. Pas exactement parce qu'on ne tient pas compte des
-! seuils.
-!======================================================================
-
-  CALL hgardfou(t_seri,ftsol,text,abortphy) 
-  IF (abortphy==1) THEN
-    print*,'ERROR ABORT hgardfou dans ',text
-! JLD pourquoi on ne modifie pas de meme t_seri et q_seri ?
-    u_seri(:,:)=u_seri(:,:)-zdu(:,:)
-    v_seri(:,:)=v_seri(:,:)-zdv(:,:)
-    ql_seri(:,:)=ql_seri(:,:)-zdql(:,:)
-    qs_seri(:,:)=qs_seri(:,:)-zdqi(:,:)
-    qbs_seri(:,:)=qbs_seri(:,:)-zdqbs(:,:)
-  ENDIF
-
-!======================================================================
-! Diagnostics for energy conservation tests
-!======================================================================
-
-  IF (fl_ebil .GT. 0) THEn
-  
-    ! ------------------------------------------------
-    ! Compute vertical sum for each atmospheric column
-    ! ------------------------------------------------
-    n=2   ! end of time step
-
-    CALL integr_v(klon, klev, zcpvap, &
-                  t_seri, q_seri, ql_seri, qs_seri, qbs_seri, u_seri, v_seri, zairm, &
-                    zqw_col(:,n), zql_col(:,n), zqs_col(:,n), zqbs_col(:,n), zek_col(:,n), zh_dair_col(:,n), &
-                    zh_qw_col(:,n), zh_ql_col(:,n), zh_qs_col(:,n), zh_qbs_col(:,n), zh_col(:,n))
-
-    ! ------------------------------------------------
-    ! Compute the changes by unit of time
-    ! ------------------------------------------------
-
-    d_qw_col(:) = (zqw_col(:,2)-zqw_col(:,1))/phys_tstep
-    d_ql_col(:) = (zql_col(:,2)-zql_col(:,1))/phys_tstep
-    d_qs_col(:) = (zqs_col(:,2)-zqs_col(:,1))/phys_tstep
-    d_qbs_col(:) = (zqbs_col(:,2)-zqbs_col(:,1))/phys_tstep
-    d_qt_col(:) = d_qw_col(:) + d_ql_col(:) + d_qs_col(:) + d_qbs_col(:)
-
-    d_ek_col(:) = (zek_col(:,2)-zek_col(:,1))/phys_tstep
-
-    d_h_dair_col(:) = (zh_dair_col(:,2)-zh_dair_col(:,1))/phys_tstep
-    d_h_qw_col(:) = (zh_qw_col(:,2)-zh_qw_col(:,1))/phys_tstep
-    d_h_ql_col(:) = (zh_ql_col(:,2)-zh_ql_col(:,1))/phys_tstep
-    d_h_qs_col(:) = (zh_qs_col(:,2)-zh_qs_col(:,1))/phys_tstep
-    d_h_qbs_col(:) = (zh_qbs_col(:,2)-zh_qbs_col(:,1))/phys_tstep
-
-    d_h_col = (zh_col(:,2)-zh_col(:,1))/phys_tstep 
-
-  ENDIF ! endif (fl_ebil .GT. 0)
-!
-! When in diagnostic mode, restore "out" variables to initial values.
-  IF (diag_mode == 1) THEN
-    u_seri(:,:)  = sav_u_seri(:,:)
-    v_seri(:,:)  = sav_v_seri(:,:)
-    ql_seri(:,:) = sav_ql_seri(:,:)
-    qs_seri(:,:) = sav_qs_seri(:,:)
-    qbs_seri(:,:) = sav_qbs_seri(:,:)
-    q_seri(:,:)  = sav_q_seri(:,:)
-    t_seri(:,:)  = sav_t_seri(:,:)
-    zdq(:,:)     = sav_zdq(:,:)   
-  ENDIF ! (mode == 1)
-
-  RETURN
-END SUBROUTINE add_phys_tend
-
-SUBROUTINE diag_phys_tend (nlon, nlev, uu, vv, temp, qv, ql, qs, qbs, &
-                          zdu,zdv,zdt,zdq,zdql,zdqs,zdqbs,paprs,text)
-!======================================================================
-! Ajoute les tendances des variables physiques aux variables 
-! d'etat de la dynamique t_seri, q_seri ...
-! On en profite pour faire des tests sur les tendances en question.
-!======================================================================
-
-
-!======================================================================
-! Declarations
-!======================================================================
-
-USE phys_state_var_mod, ONLY : phys_tstep, ftsol
-USE geometry_mod, ONLY: longitude_deg, latitude_deg
-USE print_control_mod, ONLY: prt_level
-USE cmp_seri_mod
-USE phys_output_var_mod, ONLY : d_qw_col, d_ql_col, d_qs_col, d_qbs_col, d_qt_col, d_ek_col, d_h_dair_col &
-  &           , d_h_qw_col, d_h_ql_col, d_h_qs_col, d_h_qbs_col, d_h_col
-IMPLICIT none
-  include "YOMCST.h"
-  include "clesphys.h"
-
-! Arguments :
-!------------
-INTEGER, INTENT(IN)                           :: nlon, nlev
-REAL, DIMENSION(nlon,nlev),     INTENT(IN)    :: uu, vv
-REAL, DIMENSION(nlon,nlev),     INTENT(IN)    :: temp, qv, ql, qs, qbs
-REAL, DIMENSION(nlon,nlev),     INTENT(IN)    :: zdu, zdv
-REAL, DIMENSION(nlon,nlev),     INTENT(IN)    :: zdt, zdq, zdql, zdqs, zdqbs
-REAL, DIMENSION(nlon,nlev+1),   INTENT(IN)    :: paprs
-CHARACTER*(*),                  INTENT(IN)    :: text
-
-! Local :
-!--------
-REAL, DIMENSION(nlon,nlev)      :: uu_n, vv_n
-REAL, DIMENSION(nlon,nlev)      :: temp_n, qv_n, ql_n, qs_n, qbs_n
-!
-INTEGER k, n
-
-INTEGER debug_level
-LOGICAL, SAVE :: first=.true.
-!$OMP THREADPRIVATE(first)
-!
-!======================================================================
-! Variables for energy conservation tests
-!======================================================================
-!
-
-! zh_col-------  total enthalpy of vertical air column
-! (air with watter vapour, liquid and solid) (J/m2)
-! zh_dair_col--- total enthalpy of dry air (J/m2)
-! zh_qw_col----  total enthalpy of watter vapour (J/m2)
-! zh_ql_col----  total enthalpy of liquid watter (J/m2)
-! zh_qs_col----  total enthalpy of solid watter  (J/m2)
-! zqw_col------  total mass of watter vapour (kg/m2)
-! zql_col------  total mass of liquid watter (kg/m2)
-! zqs_col------  total mass of cloud ice (kg/m2)
-! zqbs_col------  total mass of blowing snow (kg/m2)
-! zek_col------  total kinetic energy (kg/m2)
-!
-REAL zairm(nlon, nlev) ! layer air mass (kg/m2)
-REAL zqw_col(nlon,2)
-REAL zql_col(nlon,2)
-REAL zqs_col(nlon,2)
-REAL zqbs_col(nlon,2)
-REAL zek_col(nlon,2)
-REAL zh_dair_col(nlon,2)
-REAL zh_qw_col(nlon,2), zh_ql_col(nlon,2), zh_qs_col(nlon,2), zh_qbs_col(nlon,2)
-REAL zh_col(nlon,2)
-
-!======================================================================
-! Initialisations
-
-  IF (prt_level >= 5) THEN
-     write (*,*) "In diag_phys_tend, after ",text
-     CALL flush
-  ENDIF
-
-  debug_level=10
-  IF (first) THEN
-     print *,"TestJLD rcpv, rcw, rcs",rcpv, rcw, rcs
-     first=.false.
-  ENDIF
-!
-!  print *,'add_phys_tend: paprs ',paprs
-!======================================================================
-! Diagnostics for energy conservation tests
-!======================================================================
-  DO k = 1, nlev
-    ! layer air mass
-    zairm(:, k) = (paprs(:,k)-paprs(:,k+1))/rg
-  ENDDO
-
-  IF (fl_ebil .GT. 0) THEN
-    ! ------------------------------------------------
-    ! Compute vertical sum for each atmospheric column
-    ! ------------------------------------------------
-    n=1   ! begining of time step
-
-    CALL integr_v(nlon, nlev, rcpv, &
-                  temp, qv, ql, qs, qbs, uu, vv, zairm, &
-                    zqw_col(:,n), zql_col(:,n), zqs_col(:,n), zqbs_col(:,n), zek_col(:,n), zh_dair_col(:,n), &
-                    zh_qw_col(:,n), zh_ql_col(:,n), zh_qs_col(:,n), zh_qbs_col(:,n), zh_col(:,n))
-
-  ENDIF ! endif (fl_ebil .GT. 0)
-
-!======================================================================
-! Ajout des tendances sur le vent, la temperature et les diverses phases de l'eau
-!======================================================================
-
-  uu_n(:,:)=uu(:,:)+zdu(:,:)
-  vv_n(:,:)=vv(:,:)+zdv(:,:)
-  qv_n(:,:)=qv(:,:)+zdq(:,:)
-  ql_n(:,:)=ql(:,:)+zdql(:,:)
-  qs_n(:,:)=qs(:,:)+zdqs(:,:)
-  qbs_n(:,:)=qbs(:,:)+zdqbs(:,:)
-  temp_n(:,:)=temp(:,:)+zdt(:,:)
-
-!======================================================================
-! Diagnostics for energy conservation tests
-!======================================================================
-
-  IF (fl_ebil .GT. 0) THEN
-  
-    ! ------------------------------------------------
-    ! Compute vertical sum for each atmospheric column
-    ! ------------------------------------------------
-    n=2   ! end of time step
-
-    CALL integr_v(nlon, nlev, rcpv, &
-                  temp_n, qv_n, ql_n, qs_n, qbs_n, uu_n, vv_n, zairm, &
-                    zqw_col(:,n), zql_col(:,n), zqs_col(:,n), zqbs_col(:,n), zek_col(:,n), zh_dair_col(:,n), &
-                    zh_qw_col(:,n), zh_ql_col(:,n), zh_qs_col(:,n), zh_qbs_col(:,n), zh_col(:,n))
-
-    ! ------------------------------------------------
-    ! Compute the changes by unit of time
-    ! ------------------------------------------------
-
-    d_qw_col(:) = (zqw_col(:,2)-zqw_col(:,1))/phys_tstep
-    d_ql_col(:) = (zql_col(:,2)-zql_col(:,1))/phys_tstep
-    d_qs_col(:) = (zqs_col(:,2)-zqs_col(:,1))/phys_tstep
-    d_qbs_col(:) = (zqbs_col(:,2)-zqbs_col(:,1))/phys_tstep
-    d_qt_col(:) = d_qw_col(:) + d_ql_col(:) + d_qs_col(:) + d_qbs_col(:)
-
-    d_ek_col(:) = (zek_col(:,2)-zek_col(:,1))/phys_tstep
-
-    print *,'zdu ', zdu
-    print *,'zdv ', zdv
-    print *,'d_ek_col, zek_col(2), zek_col(1) ',d_ek_col(1), zek_col(1,2), zek_col(1,1)
-
-    d_h_dair_col(:) = (zh_dair_col(:,2)-zh_dair_col(:,1))/phys_tstep
-    d_h_qw_col(:) = (zh_qw_col(:,2)-zh_qw_col(:,1))/phys_tstep
-    d_h_ql_col(:) = (zh_ql_col(:,2)-zh_ql_col(:,1))/phys_tstep
-    d_h_qs_col(:) = (zh_qs_col(:,2)-zh_qs_col(:,1))/phys_tstep
-    d_h_qbs_col(:) = (zh_qbs_col(:,2)-zh_qbs_col(:,1))/phys_tstep
-
-    d_h_col = (zh_col(:,2)-zh_col(:,1))/phys_tstep 
-
-  ENDIF ! endif (fl_ebil .GT. 0)
-!
-
-  RETURN
-END SUBROUTINE diag_phys_tend
-
-SUBROUTINE integr_v(nlon, nlev, zcpvap, &
-                    temp, qv, ql, qs, qbs, uu, vv, zairm,  &
-                    zqw_col, zql_col, zqs_col, zqbs_col, zek_col, zh_dair_col, &
-                    zh_qw_col, zh_ql_col, zh_qs_col, zh_qbs_col, zh_col)
-
-IMPLICIT none
-INCLUDE "YOMCST.h"
-
-INTEGER,                    INTENT(IN)    :: nlon,nlev
-REAL,                       INTENT(IN)    :: zcpvap
-REAL, DIMENSION(nlon,nlev), INTENT(IN)    :: temp, qv, ql, qs, qbs, uu, vv
-REAL, DIMENSION(nlon,nlev), INTENT(IN)    :: zairm
-REAL, DIMENSION(nlon),      INTENT(OUT)   :: zqw_col
-REAL, DIMENSION(nlon),      INTENT(OUT)   :: zql_col
-REAL, DIMENSION(nlon),      INTENT(OUT)   :: zqs_col, zqbs_col
-REAL, DIMENSION(nlon),      INTENT(OUT)   :: zek_col
-REAL, DIMENSION(nlon),      INTENT(OUT)   :: zh_dair_col
-REAL, DIMENSION(nlon),      INTENT(OUT)   :: zh_qw_col
-REAL, DIMENSION(nlon),      INTENT(OUT)   :: zh_ql_col
-REAL, DIMENSION(nlon),      INTENT(OUT)   :: zh_qs_col, zh_qbs_col
-REAL, DIMENSION(nlon),      INTENT(OUT)   :: zh_col
-
-INTEGER          :: i, k
-
-  ! Reset variables
-    zqw_col(:) = 0.
-    zql_col(:) = 0.
-    zqs_col(:) = 0.
-    zqbs_col(:) = 0.
-    zek_col(:) = 0.
-    zh_dair_col(:) = 0.
-    zh_qw_col(:) = 0.
-    zh_ql_col(:) = 0.
-    zh_qs_col(:) = 0.
-    zh_qbs_col(:) = 0.
-
-!JLD    write (*,*) "rcpd, zcpvap, zcwat, zcice ",rcpd, zcpvap, zcwat, zcice
-  
-    ! ------------------------------------------------
-    ! Compute vertical sum for each atmospheric column
-    ! ------------------------------------------------
-    DO k = 1, nlev
-      DO i = 1, nlon
-        ! Watter mass
-        zqw_col(i) = zqw_col(i) + qv(i, k)*zairm(i, k)
-        zql_col(i) = zql_col(i) + ql(i, k)*zairm(i, k)
-        zqs_col(i) = zqs_col(i) + qs(i, k)*zairm(i, k)
-        zqbs_col(i)= zqbs_col(i) + qbs(i,k)*zairm(i,k)
-        ! Kinetic Energy
-        zek_col(i) = zek_col(i) + 0.5*(uu(i,k)**2+vv(i,k)**2)*zairm(i, k)
-        ! Air enthalpy : dry air, water vapour, liquid, solid
-        zh_dair_col(i) = zh_dair_col(i) + rcpd*(1.-qv(i,k)-ql(i,k)-qs(i,k))* &
-                                               zairm(i, k)*temp(i, k)
-        zh_qw_col(i) = zh_qw_col(i) +  zcpvap*temp(i, k)         *qv(i, k)*zairm(i, k)    !jyg
-        zh_ql_col(i) = zh_ql_col(i) + (zcpvap*temp(i, k) - rlvtt)*ql(i, k)*zairm(i, k)   !jyg
-        zh_qs_col(i) = zh_qs_col(i) + (zcpvap*temp(i, k) - rlstt)*qs(i, k)*zairm(i, k)   !jyg
-        zh_qbs_col(i) = zh_qbs_col(i) + (zcpvap*temp(i, k) - rlstt)*qbs(i, k)*zairm(i, k)   !jyg
-      ENDDO
-    ENDDO
-    ! compute total air enthalpy
-    zh_col(:) = zh_dair_col(:) + zh_qw_col(:) + zh_ql_col(:) + zh_qs_col(:) + zh_qbs_col(:)
-
-END SUBROUTINE integr_v
-
-SUBROUTINE prt_enerbil (text, itap)
-!======================================================================
-! Print enenrgy budget diagnotics for the 1D case
-!======================================================================
-
-!======================================================================
-! Declarations
-!======================================================================
-
-USE dimphy, ONLY: klon, klev
-USE phys_state_var_mod, ONLY : phys_tstep
-USE phys_state_var_mod, ONLY : topsw, toplw, solsw, sollw, rain_con, snow_con, bs_fall
-USE geometry_mod, ONLY: longitude_deg, latitude_deg
-USE print_control_mod, ONLY: prt_level
-USE cmp_seri_mod
-USE phys_output_var_mod, ONLY : d_qw_col, d_ql_col, d_qs_col, d_qbs_col, d_qt_col, d_ek_col, d_h_dair_col &
-  &           , d_h_qw_col, d_h_ql_col, d_h_qs_col, d_h_qbs_col, d_h_col
-USE phys_local_var_mod, ONLY: evap, sens
-USE phys_local_var_mod, ONLY: u_seri, v_seri, ql_seri, qs_seri, qbs_seri, q_seri, t_seri &
-   &  , rain_lsc, snow_lsc
-USE climb_hq_mod, ONLY : d_h_col_vdf, f_h_bnd
-IMPLICIT none
-INCLUDE "YOMCST.h"
-
-! Arguments :
-!------------
-CHARACTER*(*) text ! text specifing the involved parametrization 
-INTEGER itap        ! time step number
-! local variables
-! ---------------
-REAL bilq_seuil,  bilh_seuil ! thresold on error in Q and H budget
-REAL bilq_error,  bilh_error ! erros in Q and H budget
-REAL bilq_bnd,  bilh_bnd     ! Q and H budget due to exchange with boundaries
-INTEGER bilq_ok,  bilh_ok
-CHARACTER*(12) status
-
-bilq_seuil = 1.E-10
-bilh_seuil = 1.E-1
-bilq_ok=0
-bilh_ok=0
-
-!!print *,'prt_level:',prt_level,' fl_ebil:',fl_ebil,' fl_cor_ebil:',fl_cor_ebil
-IF ((fl_ebil .GT. 0) .AND. (klon .EQ. 1)) THEN
-
-  bilq_bnd = 0.
-  bilh_bnd = 0.
-
-  param: SELECT CASE (text)
-  CASE("vdf") param
-      bilq_bnd = evap(1)
-      bilh_bnd = sens(1)+(rcpv-rcpd)*evap(1)*t_seri(1,1)
-  CASE("lsc") param
-      bilq_bnd = - rain_lsc(1) - snow_lsc(1)
-      bilh_bnd = (-(rcw-rcpd)*t_seri(1,1) + rlvtt) * rain_lsc(1) &
-    &         + (-(rcs-rcpd)*t_seri(1,1) + rlstt) * snow_lsc(1)
-  CASE("bsss") param
-      bilq_bnd = - bs_fall(1)
-      bilh_bnd = (-(rcs-rcpd)*t_seri(1,1) + rlstt) * bs_fall(1)
-  CASE("convection") param
-      bilq_bnd = - rain_con(1) - snow_con(1)
-      bilh_bnd = (-(rcw-rcpd)*t_seri(1,1) + rlvtt) * rain_con(1) &
-    &         + (-(rcs-rcpd)*t_seri(1,1) + rlstt) * snow_con(1)
-  CASE("SW") param
-      bilh_bnd = topsw(1) - solsw(1)
-  CASE("LW") param
-      bilh_bnd = -(toplw(1) + sollw(1))
-  CASE DEFAULT param
-      bilq_bnd = 0.
-      bilh_bnd = 0.
-  END SELECT param
-
-  bilq_error = d_qt_col(1) - bilq_bnd
-  bilh_error = d_h_col(1) - bilh_bnd
-! are the errors too large?
-  IF (abs(bilq_error) .GT. bilq_seuil) bilq_ok=1
-  IF (abs(bilh_error) .GT. bilh_seuil) bilh_ok=1
-!
-! Print diagnostics
-! =================
-  IF ( (bilq_ok .eq. 0).AND.(bilh_ok .eq. 0) ) THEN
-    status="enerbil-OK"
-  ELSE
-    status="enerbil-PB"
-  ENDIF
-
-  IF (prt_level .GE. 3) THEN
-    write(*,9010) text,status," itap:",itap,"enerbilERROR: Q", bilq_error,"  H", bilh_error
-9010  format (1x,A8,2x,A12,A6,I4,A18,E15.6,A5,E15.6)
-  ENDIF
-  IF (prt_level .GE. 3) THEN
-    write(*,9000) text,"enerbil: Q,H,KE budget", d_qt_col(1), d_h_col(1),d_ek_col(1)
-  ENDIF
-  IF (prt_level .GE. 5) THEN
-    write(*,9000) text,"enerbil at boundaries: Q, H",bilq_bnd, bilh_bnd
-    write(*,9000) text,"enerbil: water budget",d_qt_col(1),d_qw_col(1),d_ql_col(1),d_qs_col(1), d_qbs_col(1)
-    write(*,9000) text,"enerbil: enthalpy budget",d_h_col(1),d_h_dair_col(1),d_h_qw_col(1),d_h_ql_col(1),d_h_qs_col(1),d_h_qbs_col(1)
-  ENDIF
-
-  specific_diag: SELECT CASE (text)
-  CASE("vdf") specific_diag
-    IF (prt_level .GE. 5) THEN
-      write(*,9000) text,"enerbil: d_h, bilh, sens,t_seri", d_h_col(1), bilh_bnd, sens(1), t_seri(1,1)
-      write(*,9000) text,"enerbil: d_h_col_vdf, f_h, diff",d_h_col_vdf, f_h_bnd, bilh_bnd-sens(1)
-    ENDIF
-  CASE("lsc") specific_diag
-    IF (prt_level .GE. 5) THEN
-      write(*,9000) text,"enerbil: rain, bil_lat, bil_sens", rain_lsc(1), rlvtt * rain_lsc(1), -(rcw-rcpd)*t_seri(1,1) * rain_lsc(1)
-      write(*,9000) text,"enerbil: snow, bil_lat, bil_sens", snow_lsc(1), rlstt * snow_lsc(1), -(rcs-rcpd)*t_seri(1,1) * snow_lsc(1)
-    ENDIF
-  CASE("convection") specific_diag
-    IF (prt_level .GE. 5) THEN
-      write(*,9000) text,"enerbil: rain, bil_lat, bil_sens", rain_con(1), rlvtt * rain_con(1), -(rcw-rcpd)*t_seri(1,1) * rain_con(1)
-      write(*,9000) text,"enerbil: snow, bil_lat, bil_sens", snow_con(1), rlstt * snow_con(1), -(rcs-rcpd)*t_seri(1,1) * snow_con(1)
-    ENDIF
-  END SELECT specific_diag
-
-9000 FORMAT(1x,A8,2x,A35,10E15.6)
-
-ENDIF ! endif (fl_ebil .GT. 0)
-
-END SUBROUTINE prt_enerbil
-
-END MODULE add_phys_tend_mod
Index: /LMDZ6/trunk/libf/phylmd/add_phys_tend_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/add_phys_tend_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/add_phys_tend_mod.f90	(revision 5268)
@@ -0,0 +1,843 @@
+!
+! $Id$
+!
+!
+MODULE add_phys_tend_mod
+
+  IMPLICIT NONE  
+  ! flag to compute diagnostics to check energy conservation. If  fl_ebil==0, no check
+  INTEGER, SAVE ::   fl_ebil
+!$OMP THREADPRIVATE(fl_ebil)
+  ! flag to include modifcations to ensure energy conservation. If  fl_cor_ebil==0, no corrections
+  ! Note that with time, all these modifications should be included by default
+  INTEGER, SAVE ::   fl_cor_ebil
+!$OMP THREADPRIVATE(fl_cor_ebil)
+
+CONTAINS
+
+SUBROUTINE add_pbl_tend(zdu, zdv, zdt, zdq, zdql, zdqi, zdqbs, paprs, text,abortphy,flag_inhib_tend, itap)
+  ! ======================================================================
+  ! Ajoute les tendances de couche limite, soit determinees par la
+  ! parametrisation
+  ! physique, soit forcees,  aux variables d etat de la dynamique t_seri,
+  ! q_seri ...
+  ! ======================================================================
+
+
+  ! ======================================================================
+  ! Declarations
+  ! ======================================================================
+
+  USE dimphy, ONLY: klon, klev
+!  USE dimphy
+  USE phys_local_var_mod
+  USE phys_state_var_mod
+  USE mod_grid_phy_lmdz, ONLY: nbp_lev
+  IMPLICIT NONE
+  REAL,SAVE,ALLOCATABLE :: hthturb_gcssold(:)
+  REAL,SAVE,ALLOCATABLE :: hqturb_gcssold(:)
+!$OMP THREADPRIVATE(hthturb_gcssold,hqturb_gcssold)
+  REAL,SAVE :: dtime_frcg
+  LOGICAL,SAVE :: turb_fcg_gcssold
+  LOGICAL,SAVE :: firstcall=.true.
+!$OMP THREADPRIVATE(firstcall,turb_fcg_gcssold,dtime_frcg)
+  INTEGER abortphy
+!  COMMON /turb_forcing/dtime_frcg, hthturb_gcssold, hqturb_gcssold, &
+!    turb_fcg_gcssold
+
+  ! Arguments :
+  ! ------------
+  REAL zdu(klon, klev), zdv(klon, klev)
+  REAL zdt(klon, klev), zdq(klon, klev), zdql(klon, klev), zdqi(klon, klev), zdqbs(klon,klev)
+  CHARACTER *(*) text
+  REAL paprs(klon,klev+1)
+  INTEGER flag_inhib_tend ! if flag_inhib_tend != 0, tendencies are not added
+  INTEGER itap ! time step number
+
+  ! Local :
+  ! --------
+  REAL zzdt(klon, klev), zzdq(klon, klev)
+  INTEGER i, k
+
+  IF (firstcall) THEN
+    ALLOCATE(hthturb_gcssold(nbp_lev))
+    ALLOCATE(hqturb_gcssold(nbp_lev))
+    firstcall=.false.
+  ENDIF
+
+  IF (turb_fcg_gcssold) THEN
+    DO k = 1, klev
+      DO i = 1, klon
+        zzdt(i, k) = hthturb_gcssold(k)*dtime_frcg
+        zzdq(i, k) = hqturb_gcssold(k)*dtime_frcg
+      ENDDO
+    ENDDO
+    PRINT *, ' add_pbl_tend, dtime_frcg ', dtime_frcg
+    PRINT *, ' add_pbl_tend, zzdt ', zzdt
+    PRINT *, ' add_pbl_tend, zzdq ', zzdq
+    CALL add_phys_tend(zdu, zdv, zzdt, zzdq, zdql, zdqi, zdqbs, paprs, text,abortphy,flag_inhib_tend, itap, 0)
+  ELSE
+    CALL add_phys_tend(zdu, zdv, zdt, zdq, zdql, zdqi, zdqbs, paprs, text,abortphy,flag_inhib_tend, itap, 0)
+  ENDIF
+
+  RETURN
+END SUBROUTINE add_pbl_tend
+!
+! $Id: add_phys_tend.F90 2611 2016-08-03 15:41:26Z jyg $
+!
+SUBROUTINE add_phys_tend (zdu,zdv,zdt,zdq,zdql,zdqi,zdqbs,paprs,text, &
+                          abortphy,flag_inhib_tend, itap, diag_mode)
+!======================================================================
+! Ajoute les tendances des variables physiques aux variables 
+! d'etat de la dynamique t_seri, q_seri ...
+! On en profite pour faire des tests sur les tendances en question.
+!======================================================================
+
+
+!======================================================================
+! Declarations
+!======================================================================
+
+USE dimphy, ONLY: klon, klev
+USE phys_state_var_mod, ONLY : phys_tstep
+USE phys_local_var_mod, ONLY: u_seri, v_seri, ql_seri, qs_seri, qbs_seri, q_seri, t_seri
+USE phys_state_var_mod, ONLY: ftsol
+USE geometry_mod, ONLY: longitude_deg, latitude_deg
+USE print_control_mod, ONLY: prt_level
+USE cmp_seri_mod
+USE phys_output_var_mod, ONLY : d_qw_col, d_ql_col, d_qs_col, d_qbs_col, d_qt_col, d_ek_col, d_h_dair_col &
+  &           , d_h_qw_col, d_h_ql_col, d_h_qs_col, d_h_qbs_col, d_h_col
+IMPLICIT none
+INCLUDE "YOMCST.h"
+INCLUDE "clesphys.h"
+
+! Arguments :
+!------------
+REAL, DIMENSION(klon,klev),     INTENT(IN)    :: zdu, zdv
+REAL, DIMENSION(klon,klev),     INTENT(IN)    :: zdt, zdql, zdqi, zdqbs
+REAL, DIMENSION(klon,klev+1),   INTENT(IN)    :: paprs
+CHARACTER*(*),                  INTENT(IN)    :: text
+INTEGER,                        INTENT(IN)    :: abortphy
+INTEGER,                        INTENT(IN)    :: flag_inhib_tend ! if not 0, tendencies are not added
+INTEGER,                        INTENT(IN)    :: itap            ! time step number
+INTEGER,                        INTENT(IN)    :: diag_mode       ! 0 -> normal effective mode
+                                                                 ! 1 -> only conservation stats are computed
+!
+REAL, DIMENSION(klon,klev),     INTENT(INOUT) :: zdq
+
+! Local :
+!--------
+REAL zt,zq
+REAL zq_int, zqp_int, zq_new
+
+REAL zqp(klev)
+
+! Save variables, used in diagnostic mode (diag_mode=1).
+REAL, DIMENSION(klon,klev)   :: sav_u_seri, sav_v_seri
+REAL, DIMENSION(klon,klev)   :: sav_ql_seri, sav_qs_seri, sav_qbs_seri, sav_q_seri
+REAL, DIMENSION(klon,klev)   :: sav_t_seri
+REAL, DIMENSION(klon,klev)   :: sav_zdq
+!
+INTEGER i, k,j, n
+INTEGER jadrs(klon*klev), jbad
+INTEGER jqadrs(klon*klev), jqbad
+INTEGER kadrs(klon*klev)
+INTEGER kqadrs(klon*klev)
+
+LOGICAL done(klon)
+
+INTEGER debug_level
+LOGICAL, SAVE :: first=.true.
+!$OMP THREADPRIVATE(first)
+!
+!======================================================================
+! Variables for energy conservation tests
+!======================================================================
+!
+
+! zh_col-------  total enthalpy of vertical air column
+! (air with watter vapour, liquid and solid) (J/m2)
+! zh_dair_col--- total enthalpy of dry air (J/m2)
+! zh_qw_col----  total enthalpy of watter vapour (J/m2)
+! zh_ql_col----  total enthalpy of liquid watter (J/m2)
+! zh_qs_col----  total enthalpy of solid watter  (J/m2)
+! zh_qbs_col----  total enthalpy of blowing snow  (J/m2)
+! zqw_col------  total mass of watter vapour (kg/m2)
+! zql_col------  total mass of liquid watter (kg/m2)
+! zqs_col------  total mass of cloud ice (kg/m2)
+! zqbs_col------  total mass of blowing snow (kg/m2)
+! zek_col------  total kinetic energy (kg/m2)
+!
+REAL zairm(klon, klev) ! layer air mass (kg/m2)
+REAL zqw_col(klon,2)
+REAL zql_col(klon,2)
+REAL zqs_col(klon,2)
+REAL zqbs_col(klon,2)
+REAL zek_col(klon,2)
+REAL zh_dair_col(klon,2)
+REAL zh_qw_col(klon,2), zh_ql_col(klon,2), zh_qs_col(klon,2), zh_qbs_col(klon,2)
+REAL zh_col(klon,2)
+REAL zcpvap, zcwat, zcice
+
+!======================================================================
+! Initialisations
+
+  IF (prt_level >= 5) THEN
+     write (*,*) "In add_phys_tend, after ",text
+     CALL flush
+  ENDIf
+
+  ! if flag_inhib_tend != 0, tendencies are not added
+  IF (flag_inhib_tend /= 0) THEN
+     ! If requiered, diagnostics are shown
+     IF (flag_inhib_tend > 0) THEN
+        ! print some diagnostics if xxx_seri have changed
+        call cmp_seri(flag_inhib_tend,text)
+     ENDIF
+     RETURN ! on n ajoute pas les tendance
+  ENDIF
+
+  IF (abortphy==1) RETURN ! on n ajoute pas les tendance si le modele a deja plante.
+
+  debug_level=10
+  IF (first) THEN
+     print *,"TestJLD rcpv, rcw, rcs",rcpv, rcw, rcs
+     first=.false.
+  ENDIF
+!
+!  print *,'add_phys_tend: paprs ',paprs
+! When in diagnostic mode, save initial values of out variables
+  IF (diag_mode == 1) THEN
+    sav_u_seri(:,:)  = u_seri(:,:)
+    sav_v_seri(:,:)  = v_seri(:,:)
+    sav_ql_seri(:,:) = ql_seri(:,:)
+    sav_qs_seri(:,:) = qs_seri(:,:)
+    sav_qbs_seri(:,:) = qbs_seri(:,:)
+    sav_q_seri(:,:)  = q_seri(:,:)
+    sav_t_seri(:,:)  = t_seri(:,:)
+    sav_zdq(:,:)     = zdq(:,:)   
+  ENDIF ! (diag_mode == 1)
+!======================================================================
+! Diagnostics for energy conservation tests
+!======================================================================
+  DO k = 1, klev
+    ! layer air mass
+    zairm(:, k) = (paprs(:,k)-paprs(:,k+1))/rg
+  ENDDO
+
+  IF (fl_ebil .GT. 0) THEN
+    ! ------------------------------------------------
+    ! Compute vertical sum for each atmospheric column
+    ! ------------------------------------------------
+    n=1   ! begining of time step
+
+    zcpvap = rcpv
+    zcwat = rcw
+    zcice = rcs
+
+    CALL integr_v(klon, klev, zcpvap, &
+                  t_seri, q_seri, ql_seri, qs_seri, qbs_seri, u_seri, v_seri, zairm, &
+                    zqw_col(:,n), zql_col(:,n), zqs_col(:,n), zqbs_col(:,n), zek_col(:,n), zh_dair_col(:,n), &
+                    zh_qw_col(:,n), zh_ql_col(:,n), zh_qs_col(:,n), zh_qbs_col(:,n), zh_col(:,n))
+
+  ENDIF ! endif (fl_ebil .GT. 0)
+
+!======================================================================
+! Ajout des tendances sur le vent et l'eau liquide
+!======================================================================
+
+  u_seri(:,:)=u_seri(:,:)+zdu(:,:)
+  v_seri(:,:)=v_seri(:,:)+zdv(:,:)
+  ql_seri(:,:)=ql_seri(:,:)+zdql(:,:)
+  qs_seri(:,:)=qs_seri(:,:)+zdqi(:,:)
+  qbs_seri(:,:)=qbs_seri(:,:)+zdqbs(:,:)
+
+!======================================================================
+! On ajoute les tendances de la temperature et de la vapeur d'eau
+! en verifiant que ca ne part pas dans les choux
+!======================================================================
+
+  jbad=0
+  jqbad=0
+  DO k = 1, klev
+     DO i = 1, klon
+        zt=t_seri(i,k)+zdt(i,k)
+        zq=q_seri(i,k)+zdq(i,k)
+        IF ( zt>370. .or. zt<130. .or. abs(zdt(i,k))>50. ) THEN
+           jbad = jbad + 1
+           jadrs(jbad) = i
+           kadrs(jbad) = k
+        ENDIF
+        IF ( zq<0. .or. zq>0.1 .or. abs(zdq(i,k))>1.e-2 ) THEN
+           jqbad = jqbad + 1
+           jqadrs(jqbad) = i
+           kqadrs(jqbad) = k
+        ENDIF
+        t_seri(i,k)=zt
+        q_seri(i,k)=zq
+     ENDDO
+  ENDDO
+
+!=====================================================================================
+! Impression et stop en cas de probleme important
+!=====================================================================================
+
+  IF (jbad .GT. 0) THEN
+     DO j = 1, jbad
+        i=jadrs(j)
+        IF (prt_level.ge.debug_level) THEN
+          print*,'PLANTAGE POUR LE POINT i lon lat =',&
+                 i,longitude_deg(i),latitude_deg(i),text
+          print*,'l    T     dT       Q     dQ    '
+          DO k = 1, klev
+             write(*,'(i3,2f14.4,2e14.2)') k,t_seri(i,k),zdt(i,k),q_seri(i,k),zdq(i,k)
+          ENDDO
+          call print_debug_phys(i,debug_level,text)
+        ENDIF
+     ENDDO
+  ENDIF
+!
+!=====================================================================================
+! Impression, warning et correction en cas de probleme moins important
+!=====================================================================================
+  IF (jqbad .GT. 0) THEN
+      done(:) = .false.                         !jyg
+      DO j = 1, jqbad
+        i=jqadrs(j)
+          if(prt_level.ge.debug_level) THEN
+           print*,'WARNING  : EAU POUR LE POINT i lon lat =',&
+                  i,longitude_deg(i),latitude_deg(i),text
+           print*,'l    T     dT       Q     dQ    '
+           DO k = 1, klev
+              write(*,'(i3,2f14.4,2e14.2)') k,t_seri(i,k),zdt(i,k),q_seri(i,k),zdq(i,k)
+           ENDDO
+          ENDIF
+          IF (ok_conserv_q) THEN
+!jyg<20140228 Corrections pour conservation de l'eau
+            IF (.NOT.done(i)) THEN                  !jyg
+              DO k = 1, klev
+                zqp(k) = max(q_seri(i,k),1.e-15)
+              ENDDO
+              zq_int  = 0.
+              zqp_int = 0.
+              DO k = 1, klev
+                zq_int  = zq_int  + q_seri(i,k)*(paprs(i,k)-paprs(i,k+1))/Rg
+                zqp_int = zqp_int + zqp(k)     *(paprs(i,k)-paprs(i,k+1))/Rg
+              ENDDO
+              IF (prt_level.ge.debug_level) THEN
+               print*,' cas q_seri<1.e-15 i k zq_int zqp_int zq_int/zqp_int :', &
+                                    i, kqadrs(j), zq_int, zqp_int, zq_int/zqp_int
+              ENDIF
+              DO k = 1, klev
+                zq_new = zqp(k)*zq_int/zqp_int
+                zdq(i,k) = zdq(i,k) + zq_new - q_seri(i,k)
+                q_seri(i,k) = zq_new
+              ENDDO
+              done(i) = .true.
+            ENDIF !(.NOT.done(i))
+          ELSE 
+!jyg>
+            DO k = 1, klev
+              zq=q_seri(i,k)+zdq(i,k)
+              IF (zq.lt.1.e-15) THEN
+                 IF (q_seri(i,k).lt.1.e-15) THEN
+                   IF (prt_level.ge.debug_level) THEN
+                    print*,' cas q_seri<1.e-15 i k q_seri zq zdq :',i,k,q_seri(i,k),zq,zdq(i,k)
+                   ENDIF
+                   q_seri(i,k)=1.e-15
+                   zdq(i,k)=(1.e-15-q_seri(i,k))
+                 ENDIF
+              ENDIF
+!              zq=q_seri(i,k)+zdq(i,k)
+!              if (zq.lt.1.e-15) THEN
+!                 zdq(i,k)=(1.e-15-q_seri(i,k))
+!              endif
+            ENDDO
+!jyg<20140228
+          ENDIF   !  (ok_conserv_q)
+!jyg>
+      ENDDO ! j = 1, jqbad
+  ENDIF
+!
+
+!IM ajout memes tests pour reverifier les jbad, jqbad beg
+  jbad=0
+  jqbad=0
+  DO k = 1, klev
+     DO i = 1, klon
+        IF ( t_seri(i,k)>370. .or. t_seri(i,k)<130. .or. abs(zdt(i,k))>50. ) THEN
+        jbad = jbad + 1
+        jadrs(jbad) = i
+!         if(prt_level.ge.debug_level) THEN
+!         print*,'cas2 i k t_seri zdt',i,k,t_seri(i,k),zdt(i,k)
+!        endif
+        ENDIF
+        IF ( q_seri(i,k)<0. .or. q_seri(i,k)>0.1 .or. abs(zdq(i,k))>1.e-2 ) THEN
+        jqbad = jqbad + 1
+        jqadrs(jqbad) = i
+        kqadrs(jqbad) = k
+!        if(prt_level.ge.debug_level) THEN
+!         print*,'cas2 i k q_seri zdq',i,k,q_seri(i,k),zdq(i,k)
+!        endif
+        ENDIF
+     ENDDO
+  ENDDO
+  IF (jbad .GT. 0) THEN
+      DO j = 1, jbad
+         i=jadrs(j)
+         k=kadrs(j)
+         if(prt_level.ge.debug_level) THEN
+          print*,'PLANTAGE2 POUR LE POINT i itap lon lat txt jbad zdt t',&
+                 i,itap,longitude_deg(i),latitude_deg(i),text,jbad, &
+       &        zdt(i,k),t_seri(i,k)-zdt(i,k)
+!!!       if(prt_level.ge.10.and.itap.GE.229.and.i.EQ.3027) THEN 
+          print*,'l    T     dT       Q     dQ    '
+          DO k = 1, klev
+             write(*,'(i3,2f14.4,2e14.2)') k,t_seri(i,k),zdt(i,k),q_seri(i,k),zdq(i,k)
+          ENDDO
+          call print_debug_phys(i,debug_level,text)
+         ENDIF
+      ENDDO
+  ENDIF 
+!
+  IF (jqbad .GT. 0) THEN
+      DO j = 1, jqbad
+         i=jqadrs(j)
+         k=kqadrs(j)
+         IF (prt_level.ge.debug_level) THEN
+          print*,'WARNING  : EAU2 POUR LE POINT i itap lon lat txt jqbad zdq q zdql ql',&
+                 i,itap,longitude_deg(i),latitude_deg(i),text,jqbad,&
+       &        zdq(i,k), q_seri(i,k)-zdq(i,k), zdql(i,k), ql_seri(i,k)-zdql(i,k)
+!!!       if(prt_level.ge.10.and.itap.GE.229.and.i.EQ.3027) THEN 
+          print*,'l    T     dT       Q     dQ    '
+          DO k = 1, klev
+            write(*,'(i3,2f14.4,2e14.2)') k,t_seri(i,k),zdt(i,k),q_seri(i,k),zdq(i,k)
+          ENDDO
+          call print_debug_phys(i,debug_level,text)
+         ENDIF
+      ENDDO
+  ENDIF
+
+!======================================================================
+! Contrôle des min/max pour arrêt du modèle
+! Si le modele est en mode abortphy, on retire les tendances qu'on
+! vient d'ajouter. Pas exactement parce qu'on ne tient pas compte des
+! seuils.
+!======================================================================
+
+  CALL hgardfou(t_seri,ftsol,text,abortphy) 
+  IF (abortphy==1) THEN
+    print*,'ERROR ABORT hgardfou dans ',text
+! JLD pourquoi on ne modifie pas de meme t_seri et q_seri ?
+    u_seri(:,:)=u_seri(:,:)-zdu(:,:)
+    v_seri(:,:)=v_seri(:,:)-zdv(:,:)
+    ql_seri(:,:)=ql_seri(:,:)-zdql(:,:)
+    qs_seri(:,:)=qs_seri(:,:)-zdqi(:,:)
+    qbs_seri(:,:)=qbs_seri(:,:)-zdqbs(:,:)
+  ENDIF
+
+!======================================================================
+! Diagnostics for energy conservation tests
+!======================================================================
+
+  IF (fl_ebil .GT. 0) THEn
+  
+    ! ------------------------------------------------
+    ! Compute vertical sum for each atmospheric column
+    ! ------------------------------------------------
+    n=2   ! end of time step
+
+    CALL integr_v(klon, klev, zcpvap, &
+                  t_seri, q_seri, ql_seri, qs_seri, qbs_seri, u_seri, v_seri, zairm, &
+                    zqw_col(:,n), zql_col(:,n), zqs_col(:,n), zqbs_col(:,n), zek_col(:,n), zh_dair_col(:,n), &
+                    zh_qw_col(:,n), zh_ql_col(:,n), zh_qs_col(:,n), zh_qbs_col(:,n), zh_col(:,n))
+
+    ! ------------------------------------------------
+    ! Compute the changes by unit of time
+    ! ------------------------------------------------
+
+    d_qw_col(:) = (zqw_col(:,2)-zqw_col(:,1))/phys_tstep
+    d_ql_col(:) = (zql_col(:,2)-zql_col(:,1))/phys_tstep
+    d_qs_col(:) = (zqs_col(:,2)-zqs_col(:,1))/phys_tstep
+    d_qbs_col(:) = (zqbs_col(:,2)-zqbs_col(:,1))/phys_tstep
+    d_qt_col(:) = d_qw_col(:) + d_ql_col(:) + d_qs_col(:) + d_qbs_col(:)
+
+    d_ek_col(:) = (zek_col(:,2)-zek_col(:,1))/phys_tstep
+
+    d_h_dair_col(:) = (zh_dair_col(:,2)-zh_dair_col(:,1))/phys_tstep
+    d_h_qw_col(:) = (zh_qw_col(:,2)-zh_qw_col(:,1))/phys_tstep
+    d_h_ql_col(:) = (zh_ql_col(:,2)-zh_ql_col(:,1))/phys_tstep
+    d_h_qs_col(:) = (zh_qs_col(:,2)-zh_qs_col(:,1))/phys_tstep
+    d_h_qbs_col(:) = (zh_qbs_col(:,2)-zh_qbs_col(:,1))/phys_tstep
+
+    d_h_col = (zh_col(:,2)-zh_col(:,1))/phys_tstep 
+
+  ENDIF ! endif (fl_ebil .GT. 0)
+!
+! When in diagnostic mode, restore "out" variables to initial values.
+  IF (diag_mode == 1) THEN
+    u_seri(:,:)  = sav_u_seri(:,:)
+    v_seri(:,:)  = sav_v_seri(:,:)
+    ql_seri(:,:) = sav_ql_seri(:,:)
+    qs_seri(:,:) = sav_qs_seri(:,:)
+    qbs_seri(:,:) = sav_qbs_seri(:,:)
+    q_seri(:,:)  = sav_q_seri(:,:)
+    t_seri(:,:)  = sav_t_seri(:,:)
+    zdq(:,:)     = sav_zdq(:,:)   
+  ENDIF ! (mode == 1)
+
+  RETURN
+END SUBROUTINE add_phys_tend
+
+SUBROUTINE diag_phys_tend (nlon, nlev, uu, vv, temp, qv, ql, qs, qbs, &
+                          zdu,zdv,zdt,zdq,zdql,zdqs,zdqbs,paprs,text)
+!======================================================================
+! Ajoute les tendances des variables physiques aux variables 
+! d'etat de la dynamique t_seri, q_seri ...
+! On en profite pour faire des tests sur les tendances en question.
+!======================================================================
+
+
+!======================================================================
+! Declarations
+!======================================================================
+
+USE phys_state_var_mod, ONLY : phys_tstep, ftsol
+USE geometry_mod, ONLY: longitude_deg, latitude_deg
+USE print_control_mod, ONLY: prt_level
+USE cmp_seri_mod
+USE phys_output_var_mod, ONLY : d_qw_col, d_ql_col, d_qs_col, d_qbs_col, d_qt_col, d_ek_col, d_h_dair_col &
+  &           , d_h_qw_col, d_h_ql_col, d_h_qs_col, d_h_qbs_col, d_h_col
+IMPLICIT none
+  include "YOMCST.h"
+  include "clesphys.h"
+
+! Arguments :
+!------------
+INTEGER, INTENT(IN)                           :: nlon, nlev
+REAL, DIMENSION(nlon,nlev),     INTENT(IN)    :: uu, vv
+REAL, DIMENSION(nlon,nlev),     INTENT(IN)    :: temp, qv, ql, qs, qbs
+REAL, DIMENSION(nlon,nlev),     INTENT(IN)    :: zdu, zdv
+REAL, DIMENSION(nlon,nlev),     INTENT(IN)    :: zdt, zdq, zdql, zdqs, zdqbs
+REAL, DIMENSION(nlon,nlev+1),   INTENT(IN)    :: paprs
+CHARACTER*(*),                  INTENT(IN)    :: text
+
+! Local :
+!--------
+REAL, DIMENSION(nlon,nlev)      :: uu_n, vv_n
+REAL, DIMENSION(nlon,nlev)      :: temp_n, qv_n, ql_n, qs_n, qbs_n
+!
+INTEGER k, n
+
+INTEGER debug_level
+LOGICAL, SAVE :: first=.true.
+!$OMP THREADPRIVATE(first)
+!
+!======================================================================
+! Variables for energy conservation tests
+!======================================================================
+!
+
+! zh_col-------  total enthalpy of vertical air column
+! (air with watter vapour, liquid and solid) (J/m2)
+! zh_dair_col--- total enthalpy of dry air (J/m2)
+! zh_qw_col----  total enthalpy of watter vapour (J/m2)
+! zh_ql_col----  total enthalpy of liquid watter (J/m2)
+! zh_qs_col----  total enthalpy of solid watter  (J/m2)
+! zqw_col------  total mass of watter vapour (kg/m2)
+! zql_col------  total mass of liquid watter (kg/m2)
+! zqs_col------  total mass of cloud ice (kg/m2)
+! zqbs_col------  total mass of blowing snow (kg/m2)
+! zek_col------  total kinetic energy (kg/m2)
+!
+REAL zairm(nlon, nlev) ! layer air mass (kg/m2)
+REAL zqw_col(nlon,2)
+REAL zql_col(nlon,2)
+REAL zqs_col(nlon,2)
+REAL zqbs_col(nlon,2)
+REAL zek_col(nlon,2)
+REAL zh_dair_col(nlon,2)
+REAL zh_qw_col(nlon,2), zh_ql_col(nlon,2), zh_qs_col(nlon,2), zh_qbs_col(nlon,2)
+REAL zh_col(nlon,2)
+
+!======================================================================
+! Initialisations
+
+  IF (prt_level >= 5) THEN
+     write (*,*) "In diag_phys_tend, after ",text
+     CALL flush
+  ENDIF
+
+  debug_level=10
+  IF (first) THEN
+     print *,"TestJLD rcpv, rcw, rcs",rcpv, rcw, rcs
+     first=.false.
+  ENDIF
+!
+!  print *,'add_phys_tend: paprs ',paprs
+!======================================================================
+! Diagnostics for energy conservation tests
+!======================================================================
+  DO k = 1, nlev
+    ! layer air mass
+    zairm(:, k) = (paprs(:,k)-paprs(:,k+1))/rg
+  ENDDO
+
+  IF (fl_ebil .GT. 0) THEN
+    ! ------------------------------------------------
+    ! Compute vertical sum for each atmospheric column
+    ! ------------------------------------------------
+    n=1   ! begining of time step
+
+    CALL integr_v(nlon, nlev, rcpv, &
+                  temp, qv, ql, qs, qbs, uu, vv, zairm, &
+                    zqw_col(:,n), zql_col(:,n), zqs_col(:,n), zqbs_col(:,n), zek_col(:,n), zh_dair_col(:,n), &
+                    zh_qw_col(:,n), zh_ql_col(:,n), zh_qs_col(:,n), zh_qbs_col(:,n), zh_col(:,n))
+
+  ENDIF ! endif (fl_ebil .GT. 0)
+
+!======================================================================
+! Ajout des tendances sur le vent, la temperature et les diverses phases de l'eau
+!======================================================================
+
+  uu_n(:,:)=uu(:,:)+zdu(:,:)
+  vv_n(:,:)=vv(:,:)+zdv(:,:)
+  qv_n(:,:)=qv(:,:)+zdq(:,:)
+  ql_n(:,:)=ql(:,:)+zdql(:,:)
+  qs_n(:,:)=qs(:,:)+zdqs(:,:)
+  qbs_n(:,:)=qbs(:,:)+zdqbs(:,:)
+  temp_n(:,:)=temp(:,:)+zdt(:,:)
+
+!======================================================================
+! Diagnostics for energy conservation tests
+!======================================================================
+
+  IF (fl_ebil .GT. 0) THEN
+  
+    ! ------------------------------------------------
+    ! Compute vertical sum for each atmospheric column
+    ! ------------------------------------------------
+    n=2   ! end of time step
+
+    CALL integr_v(nlon, nlev, rcpv, &
+                  temp_n, qv_n, ql_n, qs_n, qbs_n, uu_n, vv_n, zairm, &
+                    zqw_col(:,n), zql_col(:,n), zqs_col(:,n), zqbs_col(:,n), zek_col(:,n), zh_dair_col(:,n), &
+                    zh_qw_col(:,n), zh_ql_col(:,n), zh_qs_col(:,n), zh_qbs_col(:,n), zh_col(:,n))
+
+    ! ------------------------------------------------
+    ! Compute the changes by unit of time
+    ! ------------------------------------------------
+
+    d_qw_col(:) = (zqw_col(:,2)-zqw_col(:,1))/phys_tstep
+    d_ql_col(:) = (zql_col(:,2)-zql_col(:,1))/phys_tstep
+    d_qs_col(:) = (zqs_col(:,2)-zqs_col(:,1))/phys_tstep
+    d_qbs_col(:) = (zqbs_col(:,2)-zqbs_col(:,1))/phys_tstep
+    d_qt_col(:) = d_qw_col(:) + d_ql_col(:) + d_qs_col(:) + d_qbs_col(:)
+
+    d_ek_col(:) = (zek_col(:,2)-zek_col(:,1))/phys_tstep
+
+    print *,'zdu ', zdu
+    print *,'zdv ', zdv
+    print *,'d_ek_col, zek_col(2), zek_col(1) ',d_ek_col(1), zek_col(1,2), zek_col(1,1)
+
+    d_h_dair_col(:) = (zh_dair_col(:,2)-zh_dair_col(:,1))/phys_tstep
+    d_h_qw_col(:) = (zh_qw_col(:,2)-zh_qw_col(:,1))/phys_tstep
+    d_h_ql_col(:) = (zh_ql_col(:,2)-zh_ql_col(:,1))/phys_tstep
+    d_h_qs_col(:) = (zh_qs_col(:,2)-zh_qs_col(:,1))/phys_tstep
+    d_h_qbs_col(:) = (zh_qbs_col(:,2)-zh_qbs_col(:,1))/phys_tstep
+
+    d_h_col = (zh_col(:,2)-zh_col(:,1))/phys_tstep 
+
+  ENDIF ! endif (fl_ebil .GT. 0)
+!
+
+  RETURN
+END SUBROUTINE diag_phys_tend
+
+SUBROUTINE integr_v(nlon, nlev, zcpvap, &
+                    temp, qv, ql, qs, qbs, uu, vv, zairm,  &
+                    zqw_col, zql_col, zqs_col, zqbs_col, zek_col, zh_dair_col, &
+                    zh_qw_col, zh_ql_col, zh_qs_col, zh_qbs_col, zh_col)
+
+IMPLICIT none
+INCLUDE "YOMCST.h"
+
+INTEGER,                    INTENT(IN)    :: nlon,nlev
+REAL,                       INTENT(IN)    :: zcpvap
+REAL, DIMENSION(nlon,nlev), INTENT(IN)    :: temp, qv, ql, qs, qbs, uu, vv
+REAL, DIMENSION(nlon,nlev), INTENT(IN)    :: zairm
+REAL, DIMENSION(nlon),      INTENT(OUT)   :: zqw_col
+REAL, DIMENSION(nlon),      INTENT(OUT)   :: zql_col
+REAL, DIMENSION(nlon),      INTENT(OUT)   :: zqs_col, zqbs_col
+REAL, DIMENSION(nlon),      INTENT(OUT)   :: zek_col
+REAL, DIMENSION(nlon),      INTENT(OUT)   :: zh_dair_col
+REAL, DIMENSION(nlon),      INTENT(OUT)   :: zh_qw_col
+REAL, DIMENSION(nlon),      INTENT(OUT)   :: zh_ql_col
+REAL, DIMENSION(nlon),      INTENT(OUT)   :: zh_qs_col, zh_qbs_col
+REAL, DIMENSION(nlon),      INTENT(OUT)   :: zh_col
+
+INTEGER          :: i, k
+
+  ! Reset variables
+    zqw_col(:) = 0.
+    zql_col(:) = 0.
+    zqs_col(:) = 0.
+    zqbs_col(:) = 0.
+    zek_col(:) = 0.
+    zh_dair_col(:) = 0.
+    zh_qw_col(:) = 0.
+    zh_ql_col(:) = 0.
+    zh_qs_col(:) = 0.
+    zh_qbs_col(:) = 0.
+
+!JLD    write (*,*) "rcpd, zcpvap, zcwat, zcice ",rcpd, zcpvap, zcwat, zcice
+  
+    ! ------------------------------------------------
+    ! Compute vertical sum for each atmospheric column
+    ! ------------------------------------------------
+    DO k = 1, nlev
+      DO i = 1, nlon
+        ! Watter mass
+        zqw_col(i) = zqw_col(i) + qv(i, k)*zairm(i, k)
+        zql_col(i) = zql_col(i) + ql(i, k)*zairm(i, k)
+        zqs_col(i) = zqs_col(i) + qs(i, k)*zairm(i, k)
+        zqbs_col(i)= zqbs_col(i) + qbs(i,k)*zairm(i,k)
+        ! Kinetic Energy
+        zek_col(i) = zek_col(i) + 0.5*(uu(i,k)**2+vv(i,k)**2)*zairm(i, k)
+        ! Air enthalpy : dry air, water vapour, liquid, solid
+        zh_dair_col(i) = zh_dair_col(i) + rcpd*(1.-qv(i,k)-ql(i,k)-qs(i,k))* &
+                                               zairm(i, k)*temp(i, k)
+        zh_qw_col(i) = zh_qw_col(i) +  zcpvap*temp(i, k)         *qv(i, k)*zairm(i, k)    !jyg
+        zh_ql_col(i) = zh_ql_col(i) + (zcpvap*temp(i, k) - rlvtt)*ql(i, k)*zairm(i, k)   !jyg
+        zh_qs_col(i) = zh_qs_col(i) + (zcpvap*temp(i, k) - rlstt)*qs(i, k)*zairm(i, k)   !jyg
+        zh_qbs_col(i) = zh_qbs_col(i) + (zcpvap*temp(i, k) - rlstt)*qbs(i, k)*zairm(i, k)   !jyg
+      ENDDO
+    ENDDO
+    ! compute total air enthalpy
+    zh_col(:) = zh_dair_col(:) + zh_qw_col(:) + zh_ql_col(:) + zh_qs_col(:) + zh_qbs_col(:)
+
+END SUBROUTINE integr_v
+
+SUBROUTINE prt_enerbil (text, itap)
+!======================================================================
+! Print enenrgy budget diagnotics for the 1D case
+!======================================================================
+
+!======================================================================
+! Declarations
+!======================================================================
+
+USE dimphy, ONLY: klon, klev
+USE phys_state_var_mod, ONLY : phys_tstep
+USE phys_state_var_mod, ONLY : topsw, toplw, solsw, sollw, rain_con, snow_con, bs_fall
+USE geometry_mod, ONLY: longitude_deg, latitude_deg
+USE print_control_mod, ONLY: prt_level
+USE cmp_seri_mod
+USE phys_output_var_mod, ONLY : d_qw_col, d_ql_col, d_qs_col, d_qbs_col, d_qt_col, d_ek_col, d_h_dair_col &
+  &           , d_h_qw_col, d_h_ql_col, d_h_qs_col, d_h_qbs_col, d_h_col
+USE phys_local_var_mod, ONLY: evap, sens
+USE phys_local_var_mod, ONLY: u_seri, v_seri, ql_seri, qs_seri, qbs_seri, q_seri, t_seri &
+   &  , rain_lsc, snow_lsc
+USE climb_hq_mod, ONLY : d_h_col_vdf, f_h_bnd
+IMPLICIT none
+INCLUDE "YOMCST.h"
+
+! Arguments :
+!------------
+CHARACTER*(*) text ! text specifing the involved parametrization 
+INTEGER itap        ! time step number
+! local variables
+! ---------------
+REAL bilq_seuil,  bilh_seuil ! thresold on error in Q and H budget
+REAL bilq_error,  bilh_error ! erros in Q and H budget
+REAL bilq_bnd,  bilh_bnd     ! Q and H budget due to exchange with boundaries
+INTEGER bilq_ok,  bilh_ok
+CHARACTER*(12) status
+
+bilq_seuil = 1.E-10
+bilh_seuil = 1.E-1
+bilq_ok=0
+bilh_ok=0
+
+!!print *,'prt_level:',prt_level,' fl_ebil:',fl_ebil,' fl_cor_ebil:',fl_cor_ebil
+IF ((fl_ebil .GT. 0) .AND. (klon .EQ. 1)) THEN
+
+  bilq_bnd = 0.
+  bilh_bnd = 0.
+
+  param: SELECT CASE (text)
+  CASE("vdf") param
+      bilq_bnd = evap(1)
+      bilh_bnd = sens(1)+(rcpv-rcpd)*evap(1)*t_seri(1,1)
+  CASE("lsc") param
+      bilq_bnd = - rain_lsc(1) - snow_lsc(1)
+      bilh_bnd = (-(rcw-rcpd)*t_seri(1,1) + rlvtt) * rain_lsc(1) &
+    &         + (-(rcs-rcpd)*t_seri(1,1) + rlstt) * snow_lsc(1)
+  CASE("bsss") param
+      bilq_bnd = - bs_fall(1)
+      bilh_bnd = (-(rcs-rcpd)*t_seri(1,1) + rlstt) * bs_fall(1)
+  CASE("convection") param
+      bilq_bnd = - rain_con(1) - snow_con(1)
+      bilh_bnd = (-(rcw-rcpd)*t_seri(1,1) + rlvtt) * rain_con(1) &
+    &         + (-(rcs-rcpd)*t_seri(1,1) + rlstt) * snow_con(1)
+  CASE("SW") param
+      bilh_bnd = topsw(1) - solsw(1)
+  CASE("LW") param
+      bilh_bnd = -(toplw(1) + sollw(1))
+  CASE DEFAULT param
+      bilq_bnd = 0.
+      bilh_bnd = 0.
+  END SELECT param
+
+  bilq_error = d_qt_col(1) - bilq_bnd
+  bilh_error = d_h_col(1) - bilh_bnd
+! are the errors too large?
+  IF (abs(bilq_error) .GT. bilq_seuil) bilq_ok=1
+  IF (abs(bilh_error) .GT. bilh_seuil) bilh_ok=1
+!
+! Print diagnostics
+! =================
+  IF ( (bilq_ok .eq. 0).AND.(bilh_ok .eq. 0) ) THEN
+    status="enerbil-OK"
+  ELSE
+    status="enerbil-PB"
+  ENDIF
+
+  IF (prt_level .GE. 3) THEN
+    write(*,9010) text,status," itap:",itap,"enerbilERROR: Q", bilq_error,"  H", bilh_error
+9010  format (1x,A8,2x,A12,A6,I4,A18,E15.6,A5,E15.6)
+  ENDIF
+  IF (prt_level .GE. 3) THEN
+    write(*,9000) text,"enerbil: Q,H,KE budget", d_qt_col(1), d_h_col(1),d_ek_col(1)
+  ENDIF
+  IF (prt_level .GE. 5) THEN
+    write(*,9000) text,"enerbil at boundaries: Q, H",bilq_bnd, bilh_bnd
+    write(*,9000) text,"enerbil: water budget",d_qt_col(1),d_qw_col(1),d_ql_col(1),d_qs_col(1), d_qbs_col(1)
+    write(*,9000) text,"enerbil: enthalpy budget",d_h_col(1),d_h_dair_col(1),d_h_qw_col(1),d_h_ql_col(1),d_h_qs_col(1),d_h_qbs_col(1)
+  ENDIF
+
+  specific_diag: SELECT CASE (text)
+  CASE("vdf") specific_diag
+    IF (prt_level .GE. 5) THEN
+      write(*,9000) text,"enerbil: d_h, bilh, sens,t_seri", d_h_col(1), bilh_bnd, sens(1), t_seri(1,1)
+      write(*,9000) text,"enerbil: d_h_col_vdf, f_h, diff",d_h_col_vdf, f_h_bnd, bilh_bnd-sens(1)
+    ENDIF
+  CASE("lsc") specific_diag
+    IF (prt_level .GE. 5) THEN
+      write(*,9000) text,"enerbil: rain, bil_lat, bil_sens", rain_lsc(1), rlvtt * rain_lsc(1), -(rcw-rcpd)*t_seri(1,1) * rain_lsc(1)
+      write(*,9000) text,"enerbil: snow, bil_lat, bil_sens", snow_lsc(1), rlstt * snow_lsc(1), -(rcs-rcpd)*t_seri(1,1) * snow_lsc(1)
+    ENDIF
+  CASE("convection") specific_diag
+    IF (prt_level .GE. 5) THEN
+      write(*,9000) text,"enerbil: rain, bil_lat, bil_sens", rain_con(1), rlvtt * rain_con(1), -(rcw-rcpd)*t_seri(1,1) * rain_con(1)
+      write(*,9000) text,"enerbil: snow, bil_lat, bil_sens", snow_con(1), rlstt * snow_con(1), -(rcs-rcpd)*t_seri(1,1) * snow_con(1)
+    ENDIF
+  END SELECT specific_diag
+
+9000 FORMAT(1x,A8,2x,A35,10E15.6)
+
+ENDIF ! endif (fl_ebil .GT. 0)
+
+END SUBROUTINE prt_enerbil
+
+END MODULE add_phys_tend_mod
Index: DZ6/trunk/libf/phylmd/add_wake_tend.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/add_wake_tend.F90	(revision 5267)
+++ 	(revision )
@@ -1,69 +1,0 @@
-SUBROUTINE add_wake_tend(zddeltat, zddeltaq, zds, zdas, zddensw, zddensaw, zoccur, text, abortphy)
-!===================================================================
-! Ajoute les tendances liées aux diverses parametrisations physiques aux
-! variables d'etat des poches froides.
-!===================================================================
-!======================================================================
-! Declarations
-!======================================================================
-
-USE dimphy, ONLY: klon, klev
-USE phys_state_var_mod, ONLY: wake_deltat, wake_deltaq, wake_s, awake_s,  &
-                              wake_dens, awake_dens
-
-USE print_control_mod, ONLY: prt_level
-IMPLICIT none
-
-! Arguments :
-!------------
-  REAL, DIMENSION(klon, klev),   INTENT (IN)         :: zddeltat, zddeltaq
-  REAL, DIMENSION(klon),         INTENT (IN)         :: zds, zdas, zddensw, zddensaw
-  INTEGER, DIMENSION(klon),      INTENT (IN)         :: zoccur
-  CHARACTER*(*),                 INTENT (IN)         :: text
-  INTEGER,                       INTENT (IN)         :: abortphy
-
-! Local :
-!--------
-
-INTEGER                                              :: i, l
-
-
-
-     IF (prt_level >= 5) then
-        write (*,*) "In add_wake_tend, after ",text
-        call flush
-     end if
-
-     IF (abortphy==1) RETURN ! on n ajoute pas les tendance si le modele
-                              ! a deja plante.
-
-!======================================================================
-!    Add tendencies to wake state variables
-!======================================================================
-         DO l = 1, klev
-           DO i = 1, klon
-             IF (zoccur(i) .GE. 1) THEN
-               wake_deltat(i, l) = wake_deltat(i, l) + zddeltat(i,l)
-               wake_deltaq(i, l) = wake_deltaq(i, l) + zddeltaq(i,l)
-             ELSE
-               wake_deltat(i, l) = 0.
-               wake_deltaq(i, l) = 0.
-             ENDIF   ! (zoccur(i) .GE. 1)
-           END DO
-         END DO
-         DO i = 1, klon
-           IF (zoccur(i) .GE. 1) THEN
-             wake_s(i)     = wake_s(i)    + zds(i)
-             awake_s(i)    = awake_s(i)    + zdas(i)
-             wake_dens(i)  = wake_dens(i) + zddensw(i)
-             awake_dens(i) = awake_dens(i) + zddensaw(i)
-           ELSE
-             wake_s(i)     = 0.
-             awake_s(i)    = 0.
-             wake_dens(i)  = 0.
-             awake_dens(i) = 0.
-           ENDIF   ! (zoccur(i) .GE. 1)
-         END DO
-
-RETURN
-END
Index: /LMDZ6/trunk/libf/phylmd/add_wake_tend.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/add_wake_tend.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/add_wake_tend.f90	(revision 5268)
@@ -0,0 +1,69 @@
+SUBROUTINE add_wake_tend(zddeltat, zddeltaq, zds, zdas, zddensw, zddensaw, zoccur, text, abortphy)
+!===================================================================
+! Ajoute les tendances liées aux diverses parametrisations physiques aux
+! variables d'etat des poches froides.
+!===================================================================
+!======================================================================
+! Declarations
+!======================================================================
+
+USE dimphy, ONLY: klon, klev
+USE phys_state_var_mod, ONLY: wake_deltat, wake_deltaq, wake_s, awake_s,  &
+                              wake_dens, awake_dens
+
+USE print_control_mod, ONLY: prt_level
+IMPLICIT none
+
+! Arguments :
+!------------
+  REAL, DIMENSION(klon, klev),   INTENT (IN)         :: zddeltat, zddeltaq
+  REAL, DIMENSION(klon),         INTENT (IN)         :: zds, zdas, zddensw, zddensaw
+  INTEGER, DIMENSION(klon),      INTENT (IN)         :: zoccur
+  CHARACTER*(*),                 INTENT (IN)         :: text
+  INTEGER,                       INTENT (IN)         :: abortphy
+
+! Local :
+!--------
+
+INTEGER                                              :: i, l
+
+
+
+     IF (prt_level >= 5) then
+        write (*,*) "In add_wake_tend, after ",text
+        call flush
+     end if
+
+     IF (abortphy==1) RETURN ! on n ajoute pas les tendance si le modele
+                              ! a deja plante.
+
+!======================================================================
+!    Add tendencies to wake state variables
+!======================================================================
+         DO l = 1, klev
+           DO i = 1, klon
+             IF (zoccur(i) .GE. 1) THEN
+               wake_deltat(i, l) = wake_deltat(i, l) + zddeltat(i,l)
+               wake_deltaq(i, l) = wake_deltaq(i, l) + zddeltaq(i,l)
+             ELSE
+               wake_deltat(i, l) = 0.
+               wake_deltaq(i, l) = 0.
+             ENDIF   ! (zoccur(i) .GE. 1)
+           END DO
+         END DO
+         DO i = 1, klon
+           IF (zoccur(i) .GE. 1) THEN
+             wake_s(i)     = wake_s(i)    + zds(i)
+             awake_s(i)    = awake_s(i)    + zdas(i)
+             wake_dens(i)  = wake_dens(i) + zddensw(i)
+             awake_dens(i) = awake_dens(i) + zddensaw(i)
+           ELSE
+             wake_s(i)     = 0.
+             awake_s(i)    = 0.
+             wake_dens(i)  = 0.
+             awake_dens(i) = 0.
+           ENDIF   ! (zoccur(i) .GE. 1)
+         END DO
+
+RETURN
+END
Index: DZ6/trunk/libf/phylmd/aero_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/aero_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,106 +1,0 @@
-! $Id$
-!
-MODULE aero_mod
-
-  IMPLICIT NONE
-
-! Declaration des indices pour les aerosols 
-
-! 1/ Total number of aerosols for which an aerosol optical depth is provided
-!--strat aerosols are only prescribed naero_tot = 10 ==> 11 
-!--adding nitrate naero_tot = 14 OB
-
-  INTEGER, PARAMETER :: naero_tot = 14
-
-! Identification number used in aeropt_2bands and aeropt_5wv
-! corresponding to naero_tot
-  INTEGER, PARAMETER :: id_ASBCM_phy    = 1
-  INTEGER, PARAMETER :: id_ASPOMM_phy   = 2
-  INTEGER, PARAMETER :: id_ASSO4M_phy   = 3
-  INTEGER, PARAMETER :: id_CSSO4M_phy   = 4
-  INTEGER, PARAMETER :: id_SSSSM_phy    = 5
-  INTEGER, PARAMETER :: id_CSSSM_phy    = 6
-  INTEGER, PARAMETER :: id_ASSSM_phy    = 7
-  INTEGER, PARAMETER :: id_CIDUSTM_phy  = 8
-  INTEGER, PARAMETER :: id_AIBCM_phy    = 9
-  INTEGER, PARAMETER :: id_AIPOMM_phy   = 10
-  INTEGER, PARAMETER :: id_ASNO3M_phy   = 11
-  INTEGER, PARAMETER :: id_CSNO3M_phy   = 12
-  INTEGER, PARAMETER :: id_CINO3M_phy   = 13
-  INTEGER, PARAMETER :: id_STRAT_phy    = 14
-
-! Corresponding names for the aerosols
-  CHARACTER(len=7),DIMENSION(naero_tot), PARAMETER :: name_aero_tau=(/&
-       "ASBCM  ", &
-       "ASPOMM ", &
-       "ASSO4M ", &
-       "CSSO4M ", &
-       "SSSSM  ", &
-       "CSSSM  ", &
-       "ASSSM  ", &
-       "CIDUSTM", &
-       "AIBCM  ", &
-       "AIPOMM ", &
-       "ASNO3M ", & 
-       "CSNO3M ", &
-       "CINO3M ", &
-       "STRAT  " /)
-
-! 2/ Total number of aerosols for which an aerosol mass is provided
-
-  INTEGER, PARAMETER :: naero_spc = 13
-
-! Corresponding names for the aerosols
-  CHARACTER(len=7),DIMENSION(naero_spc), PARAMETER :: name_aero=(/&
-       "ASBCM  ", & ! Accumulation-mode Soluble Black Carbon Mass 
-       "ASPOMM ", & ! Accumulation-mode Soluble Particle Organic Matter Mass
-       "SO4    ", & ! Accumulation-mode Soluble Sulfate
-       "CSSO4M ", & ! Coarse-mode Soluble Sulfate Mass
-       "SSSSM  ", & ! Super-coarse mode Soluble Sea-Salt Mass
-       "CSSSM  ", & ! Coarse-mode Soluble Sea-Salt Mass
-       "ASSSM  ", & ! Accumulation-mode Soluble Sea-Salt Mass
-       "CIDUSTM", & ! Coarse-mode Insoluble Dust Mass
-       "AIBCM  ", & ! Accumulation-mode Insoluble Black Carbon Mass
-       "AIPOMM " ,& ! Accumulation-mode Insoluble Particle Organic Matter Mass 
-       "ASNO3M ", & ! Accumulation-mode Soluble Nitrate Mass
-       "CSNO3M ", & ! Coarse-mode Soluble Nitrate Mass
-       "CINO3M " /) ! Coarse-mode Insoluble Nitrate Mass
-
-! 3/ Number of aerosol groups
-  INTEGER, PARAMETER :: naero_grp = 13
-  ! if info_trac = inca
-  ! 1 = ZERO    
-  ! 2 = AER total    
-  ! 3 = NAT    
-  ! 4 = BC    
-  ! 5 = SO4    
-  ! 6 = POM    
-  ! 7 = DUST    
-  ! 8 = SS    
-  ! 9 = FNO3    
-  ! 10 = DNO3
-  ! 11 = SNO3
-  ! 12 = SOAA
-  ! 13 = SOAB 
-  ! else 
-  ! 1 = ZERO    
-  ! 2 = AER total    
-  ! 3 = NAT    
-  ! 4 = BC    
-  ! 5 = SO4    
-  ! 6 = POM    
-  ! 7 = DUST    
-  ! 8 = SS    
-  ! 9 = NO3    
-
-! Number of diagnostics wavelengths (5 SW + 1 LW @ 10 um)
-  INTEGER, PARAMETER :: nwave_sw = 5
-  INTEGER, PARAMETER :: nwave_lw = 1
-  INTEGER, PARAMETER :: nwave = nwave_sw + nwave_lw
-
-! Number of modes spectral bands
-  INTEGER, parameter :: nbands = 2
-  INTEGER, parameter :: nbands_sw_rrtm = 6
-  INTEGER, parameter :: nbands_lw_rrtm = 16
-
-END MODULE aero_mod
Index: /LMDZ6/trunk/libf/phylmd/aero_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/aero_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/aero_mod.f90	(revision 5268)
@@ -0,0 +1,106 @@
+! $Id$
+!
+MODULE aero_mod
+
+  IMPLICIT NONE
+
+! Declaration des indices pour les aerosols 
+
+! 1/ Total number of aerosols for which an aerosol optical depth is provided
+!--strat aerosols are only prescribed naero_tot = 10 ==> 11 
+!--adding nitrate naero_tot = 14 OB
+
+  INTEGER, PARAMETER :: naero_tot = 14
+
+! Identification number used in aeropt_2bands and aeropt_5wv
+! corresponding to naero_tot
+  INTEGER, PARAMETER :: id_ASBCM_phy    = 1
+  INTEGER, PARAMETER :: id_ASPOMM_phy   = 2
+  INTEGER, PARAMETER :: id_ASSO4M_phy   = 3
+  INTEGER, PARAMETER :: id_CSSO4M_phy   = 4
+  INTEGER, PARAMETER :: id_SSSSM_phy    = 5
+  INTEGER, PARAMETER :: id_CSSSM_phy    = 6
+  INTEGER, PARAMETER :: id_ASSSM_phy    = 7
+  INTEGER, PARAMETER :: id_CIDUSTM_phy  = 8
+  INTEGER, PARAMETER :: id_AIBCM_phy    = 9
+  INTEGER, PARAMETER :: id_AIPOMM_phy   = 10
+  INTEGER, PARAMETER :: id_ASNO3M_phy   = 11
+  INTEGER, PARAMETER :: id_CSNO3M_phy   = 12
+  INTEGER, PARAMETER :: id_CINO3M_phy   = 13
+  INTEGER, PARAMETER :: id_STRAT_phy    = 14
+
+! Corresponding names for the aerosols
+  CHARACTER(len=7),DIMENSION(naero_tot), PARAMETER :: name_aero_tau=(/&
+       "ASBCM  ", &
+       "ASPOMM ", &
+       "ASSO4M ", &
+       "CSSO4M ", &
+       "SSSSM  ", &
+       "CSSSM  ", &
+       "ASSSM  ", &
+       "CIDUSTM", &
+       "AIBCM  ", &
+       "AIPOMM ", &
+       "ASNO3M ", & 
+       "CSNO3M ", &
+       "CINO3M ", &
+       "STRAT  " /)
+
+! 2/ Total number of aerosols for which an aerosol mass is provided
+
+  INTEGER, PARAMETER :: naero_spc = 13
+
+! Corresponding names for the aerosols
+  CHARACTER(len=7),DIMENSION(naero_spc), PARAMETER :: name_aero=(/&
+       "ASBCM  ", & ! Accumulation-mode Soluble Black Carbon Mass 
+       "ASPOMM ", & ! Accumulation-mode Soluble Particle Organic Matter Mass
+       "SO4    ", & ! Accumulation-mode Soluble Sulfate
+       "CSSO4M ", & ! Coarse-mode Soluble Sulfate Mass
+       "SSSSM  ", & ! Super-coarse mode Soluble Sea-Salt Mass
+       "CSSSM  ", & ! Coarse-mode Soluble Sea-Salt Mass
+       "ASSSM  ", & ! Accumulation-mode Soluble Sea-Salt Mass
+       "CIDUSTM", & ! Coarse-mode Insoluble Dust Mass
+       "AIBCM  ", & ! Accumulation-mode Insoluble Black Carbon Mass
+       "AIPOMM " ,& ! Accumulation-mode Insoluble Particle Organic Matter Mass 
+       "ASNO3M ", & ! Accumulation-mode Soluble Nitrate Mass
+       "CSNO3M ", & ! Coarse-mode Soluble Nitrate Mass
+       "CINO3M " /) ! Coarse-mode Insoluble Nitrate Mass
+
+! 3/ Number of aerosol groups
+  INTEGER, PARAMETER :: naero_grp = 13
+  ! if info_trac = inca
+  ! 1 = ZERO    
+  ! 2 = AER total    
+  ! 3 = NAT    
+  ! 4 = BC    
+  ! 5 = SO4    
+  ! 6 = POM    
+  ! 7 = DUST    
+  ! 8 = SS    
+  ! 9 = FNO3    
+  ! 10 = DNO3
+  ! 11 = SNO3
+  ! 12 = SOAA
+  ! 13 = SOAB 
+  ! else 
+  ! 1 = ZERO    
+  ! 2 = AER total    
+  ! 3 = NAT    
+  ! 4 = BC    
+  ! 5 = SO4    
+  ! 6 = POM    
+  ! 7 = DUST    
+  ! 8 = SS    
+  ! 9 = NO3    
+
+! Number of diagnostics wavelengths (5 SW + 1 LW @ 10 um)
+  INTEGER, PARAMETER :: nwave_sw = 5
+  INTEGER, PARAMETER :: nwave_lw = 1
+  INTEGER, PARAMETER :: nwave = nwave_sw + nwave_lw
+
+! Number of modes spectral bands
+  INTEGER, parameter :: nbands = 2
+  INTEGER, parameter :: nbands_sw_rrtm = 6
+  INTEGER, parameter :: nbands_lw_rrtm = 16
+
+END MODULE aero_mod
Index: DZ6/trunk/libf/phylmd/aeropt.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/aeropt.F90	(revision 5267)
+++ 	(revision )
@@ -1,124 +1,0 @@
-
-! $Id$
-
-SUBROUTINE aeropt(pplay, paprs, t_seri, msulfate, rhcl, tau_ae, piz_ae, &
-    cg_ae, ai)
-
-  USE dimphy
-  IMPLICIT NONE
-
-
-
-  include "YOMCST.h"
-
-  ! Arguments:
-
-  REAL, INTENT (IN) :: paprs(klon, klev+1)
-  REAL, INTENT (IN) :: pplay(klon, klev), t_seri(klon, klev)
-  REAL, INTENT (IN) :: msulfate(klon, klev) ! masse sulfate ug SO4/m3  [ug/m^3]
-  REAL, INTENT (IN) :: rhcl(klon, klev) ! humidite relative ciel clair
-  REAL, INTENT (OUT) :: tau_ae(klon, klev, 2) ! epaisseur optique aerosol
-  REAL, INTENT (OUT) :: piz_ae(klon, klev, 2) ! single scattering albedo aerosol
-  REAL, INTENT (OUT) :: cg_ae(klon, klev, 2) ! asymmetry parameter aerosol
-  REAL, INTENT (OUT) :: ai(klon) ! POLDER aerosol index
-
-  ! Local
-
-  INTEGER i, k, inu
-  INTEGER rh_num, nbre_rh
-  PARAMETER (nbre_rh=12)
-  REAL rh_tab(nbre_rh)
-  REAL rh_max, delta, rh
-  PARAMETER (rh_max=95.)
-  DATA rh_tab/0., 10., 20., 30., 40., 50., 60., 70., 80., 85., 90., 95./
-  REAL zrho, zdz
-  REAL taue670(klon) ! epaisseur optique aerosol absorption 550 nm
-  REAL taue865(klon) ! epaisseur optique aerosol extinction 865 nm
-  REAL alpha_aer_sulfate(nbre_rh, 5) !--unit m2/g SO4
-  REAL alphasulfate
-
-  CHARACTER (LEN=20) :: modname = 'aeropt'
-  CHARACTER (LEN=80) :: abort_message
-
-
-  ! Proprietes optiques
-
-  REAL alpha_aer(nbre_rh, 2) !--unit m2/g SO4
-  REAL cg_aer(nbre_rh, 2)
-  DATA alpha_aer/.500130E+01, .500130E+01, .500130E+01, .500130E+01, &
-    .500130E+01, .616710E+01, .826850E+01, .107687E+02, .136976E+02, &
-    .162972E+02, .211690E+02, .354833E+02, .139460E+01, .139460E+01, &
-    .139460E+01, .139460E+01, .139460E+01, .173910E+01, .244380E+01, &
-    .332320E+01, .440120E+01, .539570E+01, .734580E+01, .136038E+02/
-  DATA cg_aer/.619800E+00, .619800E+00, .619800E+00, .619800E+00, &
-    .619800E+00, .662700E+00, .682100E+00, .698500E+00, .712500E+00, &
-    .721800E+00, .734600E+00, .755800E+00, .545600E+00, .545600E+00, &
-    .545600E+00, .545600E+00, .545600E+00, .583700E+00, .607100E+00, &
-    .627700E+00, .645800E+00, .658400E+00, .676500E+00, .708500E+00/
-  DATA alpha_aer_sulfate/4.910, 4.910, 4.910, 4.910, 6.547, 7.373, 8.373, &
-    9.788, 12.167, 14.256, 17.924, 28.433, 1.453, 1.453, 1.453, 1.453, 2.003, &
-    2.321, 2.711, 3.282, 4.287, 5.210, 6.914, 12.305, 4.308, 4.308, 4.308, &
-    4.308, 5.753, 6.521, 7.449, 8.772, 11.014, 12.999, 16.518, 26.772, 3.265, &
-    3.265, 3.265, 3.265, 4.388, 5.016, 5.775, 6.868, 8.745, 10.429, 13.457, &
-    22.538, 2.116, 2.116, 2.116, 2.116, 2.882, 3.330, 3.876, 4.670, 6.059, &
-    7.327, 9.650, 16.883/
-
-  DO i = 1, klon
-    taue670(i) = 0.0
-    taue865(i) = 0.0
-  END DO
-
-  DO k = 1, klev
-    DO i = 1, klon
-      IF (t_seri(i,k)==0) WRITE (*, *) 'aeropt T ', i, k, t_seri(i, k)
-      IF (pplay(i,k)==0) WRITE (*, *) 'aeropt p ', i, k, pplay(i, k)
-      zrho = pplay(i, k)/t_seri(i, k)/rd ! kg/m3
-      zdz = (paprs(i,k)-paprs(i,k+1))/zrho/rg ! m
-      rh = min(rhcl(i,k)*100., rh_max)
-      rh_num = int(rh/10.+1.)
-      IF (rh<0.) THEN
-        abort_message = 'aeropt: RH < 0 not possible'
-        CALL abort_physic(modname, abort_message, 1)
-      END IF
-      IF (rh>85.) rh_num = 10
-      IF (rh>90.) rh_num = 11
-      delta = (rh-rh_tab(rh_num))/(rh_tab(rh_num+1)-rh_tab(rh_num))
-
-      inu = 1
-      tau_ae(i, k, inu) = alpha_aer(rh_num, inu) + delta*(alpha_aer(rh_num+1, &
-        inu)-alpha_aer(rh_num,inu))
-      tau_ae(i, k, inu) = tau_ae(i, k, inu)*msulfate(i, k)*zdz*1.E-6
-      piz_ae(i, k, inu) = 1.0
-      cg_ae(i, k, inu) = cg_aer(rh_num, inu) + delta*(cg_aer(rh_num+1,inu)- &
-        cg_aer(rh_num,inu))
-
-      inu = 2
-      tau_ae(i, k, inu) = alpha_aer(rh_num, inu) + delta*(alpha_aer(rh_num+1, &
-        inu)-alpha_aer(rh_num,inu))
-      tau_ae(i, k, inu) = tau_ae(i, k, inu)*msulfate(i, k)*zdz*1.E-6
-      piz_ae(i, k, inu) = 1.0
-      cg_ae(i, k, inu) = cg_aer(rh_num, inu) + delta*(cg_aer(rh_num+1,inu)- &
-        cg_aer(rh_num,inu))
-      ! jq
-      ! jq for aerosol index
-
-      alphasulfate = alpha_aer_sulfate(rh_num, 4) + &
-        delta*(alpha_aer_sulfate(rh_num+1,4)-alpha_aer_sulfate(rh_num,4)) !--m2/g
-
-      taue670(i) = taue670(i) + alphasulfate*msulfate(i, k)*zdz*1.E-6
-
-      alphasulfate = alpha_aer_sulfate(rh_num, 5) + &
-        delta*(alpha_aer_sulfate(rh_num+1,5)-alpha_aer_sulfate(rh_num,5)) !--m2/g
-
-      taue865(i) = taue865(i) + alphasulfate*msulfate(i, k)*zdz*1.E-6
-
-    END DO
-  END DO
-
-  DO i = 1, klon
-    ai(i) = (-log(max(taue670(i),0.0001)/max(taue865(i), &
-      0.0001))/log(670./865.))*taue865(i)
-  END DO
-
-  RETURN
-END SUBROUTINE aeropt
Index: /LMDZ6/trunk/libf/phylmd/aeropt.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/aeropt.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/aeropt.f90	(revision 5268)
@@ -0,0 +1,124 @@
+
+! $Id$
+
+SUBROUTINE aeropt(pplay, paprs, t_seri, msulfate, rhcl, tau_ae, piz_ae, &
+    cg_ae, ai)
+
+  USE dimphy
+  IMPLICIT NONE
+
+
+
+  include "YOMCST.h"
+
+  ! Arguments:
+
+  REAL, INTENT (IN) :: paprs(klon, klev+1)
+  REAL, INTENT (IN) :: pplay(klon, klev), t_seri(klon, klev)
+  REAL, INTENT (IN) :: msulfate(klon, klev) ! masse sulfate ug SO4/m3  [ug/m^3]
+  REAL, INTENT (IN) :: rhcl(klon, klev) ! humidite relative ciel clair
+  REAL, INTENT (OUT) :: tau_ae(klon, klev, 2) ! epaisseur optique aerosol
+  REAL, INTENT (OUT) :: piz_ae(klon, klev, 2) ! single scattering albedo aerosol
+  REAL, INTENT (OUT) :: cg_ae(klon, klev, 2) ! asymmetry parameter aerosol
+  REAL, INTENT (OUT) :: ai(klon) ! POLDER aerosol index
+
+  ! Local
+
+  INTEGER i, k, inu
+  INTEGER rh_num, nbre_rh
+  PARAMETER (nbre_rh=12)
+  REAL rh_tab(nbre_rh)
+  REAL rh_max, delta, rh
+  PARAMETER (rh_max=95.)
+  DATA rh_tab/0., 10., 20., 30., 40., 50., 60., 70., 80., 85., 90., 95./
+  REAL zrho, zdz
+  REAL taue670(klon) ! epaisseur optique aerosol absorption 550 nm
+  REAL taue865(klon) ! epaisseur optique aerosol extinction 865 nm
+  REAL alpha_aer_sulfate(nbre_rh, 5) !--unit m2/g SO4
+  REAL alphasulfate
+
+  CHARACTER (LEN=20) :: modname = 'aeropt'
+  CHARACTER (LEN=80) :: abort_message
+
+
+  ! Proprietes optiques
+
+  REAL alpha_aer(nbre_rh, 2) !--unit m2/g SO4
+  REAL cg_aer(nbre_rh, 2)
+  DATA alpha_aer/.500130E+01, .500130E+01, .500130E+01, .500130E+01, &
+    .500130E+01, .616710E+01, .826850E+01, .107687E+02, .136976E+02, &
+    .162972E+02, .211690E+02, .354833E+02, .139460E+01, .139460E+01, &
+    .139460E+01, .139460E+01, .139460E+01, .173910E+01, .244380E+01, &
+    .332320E+01, .440120E+01, .539570E+01, .734580E+01, .136038E+02/
+  DATA cg_aer/.619800E+00, .619800E+00, .619800E+00, .619800E+00, &
+    .619800E+00, .662700E+00, .682100E+00, .698500E+00, .712500E+00, &
+    .721800E+00, .734600E+00, .755800E+00, .545600E+00, .545600E+00, &
+    .545600E+00, .545600E+00, .545600E+00, .583700E+00, .607100E+00, &
+    .627700E+00, .645800E+00, .658400E+00, .676500E+00, .708500E+00/
+  DATA alpha_aer_sulfate/4.910, 4.910, 4.910, 4.910, 6.547, 7.373, 8.373, &
+    9.788, 12.167, 14.256, 17.924, 28.433, 1.453, 1.453, 1.453, 1.453, 2.003, &
+    2.321, 2.711, 3.282, 4.287, 5.210, 6.914, 12.305, 4.308, 4.308, 4.308, &
+    4.308, 5.753, 6.521, 7.449, 8.772, 11.014, 12.999, 16.518, 26.772, 3.265, &
+    3.265, 3.265, 3.265, 4.388, 5.016, 5.775, 6.868, 8.745, 10.429, 13.457, &
+    22.538, 2.116, 2.116, 2.116, 2.116, 2.882, 3.330, 3.876, 4.670, 6.059, &
+    7.327, 9.650, 16.883/
+
+  DO i = 1, klon
+    taue670(i) = 0.0
+    taue865(i) = 0.0
+  END DO
+
+  DO k = 1, klev
+    DO i = 1, klon
+      IF (t_seri(i,k)==0) WRITE (*, *) 'aeropt T ', i, k, t_seri(i, k)
+      IF (pplay(i,k)==0) WRITE (*, *) 'aeropt p ', i, k, pplay(i, k)
+      zrho = pplay(i, k)/t_seri(i, k)/rd ! kg/m3
+      zdz = (paprs(i,k)-paprs(i,k+1))/zrho/rg ! m
+      rh = min(rhcl(i,k)*100., rh_max)
+      rh_num = int(rh/10.+1.)
+      IF (rh<0.) THEN
+        abort_message = 'aeropt: RH < 0 not possible'
+        CALL abort_physic(modname, abort_message, 1)
+      END IF
+      IF (rh>85.) rh_num = 10
+      IF (rh>90.) rh_num = 11
+      delta = (rh-rh_tab(rh_num))/(rh_tab(rh_num+1)-rh_tab(rh_num))
+
+      inu = 1
+      tau_ae(i, k, inu) = alpha_aer(rh_num, inu) + delta*(alpha_aer(rh_num+1, &
+        inu)-alpha_aer(rh_num,inu))
+      tau_ae(i, k, inu) = tau_ae(i, k, inu)*msulfate(i, k)*zdz*1.E-6
+      piz_ae(i, k, inu) = 1.0
+      cg_ae(i, k, inu) = cg_aer(rh_num, inu) + delta*(cg_aer(rh_num+1,inu)- &
+        cg_aer(rh_num,inu))
+
+      inu = 2
+      tau_ae(i, k, inu) = alpha_aer(rh_num, inu) + delta*(alpha_aer(rh_num+1, &
+        inu)-alpha_aer(rh_num,inu))
+      tau_ae(i, k, inu) = tau_ae(i, k, inu)*msulfate(i, k)*zdz*1.E-6
+      piz_ae(i, k, inu) = 1.0
+      cg_ae(i, k, inu) = cg_aer(rh_num, inu) + delta*(cg_aer(rh_num+1,inu)- &
+        cg_aer(rh_num,inu))
+      ! jq
+      ! jq for aerosol index
+
+      alphasulfate = alpha_aer_sulfate(rh_num, 4) + &
+        delta*(alpha_aer_sulfate(rh_num+1,4)-alpha_aer_sulfate(rh_num,4)) !--m2/g
+
+      taue670(i) = taue670(i) + alphasulfate*msulfate(i, k)*zdz*1.E-6
+
+      alphasulfate = alpha_aer_sulfate(rh_num, 5) + &
+        delta*(alpha_aer_sulfate(rh_num+1,5)-alpha_aer_sulfate(rh_num,5)) !--m2/g
+
+      taue865(i) = taue865(i) + alphasulfate*msulfate(i, k)*zdz*1.E-6
+
+    END DO
+  END DO
+
+  DO i = 1, klon
+    ai(i) = (-log(max(taue670(i),0.0001)/max(taue865(i), &
+      0.0001))/log(670./865.))*taue865(i)
+  END DO
+
+  RETURN
+END SUBROUTINE aeropt
Index: DZ6/trunk/libf/phylmd/aeropt_2bands.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/aeropt_2bands.F90	(revision 5267)
+++ 	(revision )
@@ -1,1130 +1,0 @@
-!
-! $Id$
-!
-SUBROUTINE AEROPT_2BANDS( &
-     pdel, m_allaer, delt, RHcl, &
-     tau_allaer, piz_allaer, &
-     cg_allaer, m_allaer_pi, &
-     flag_aerosol, pplay, t_seri, presnivs)
-
-  USE dimphy
-  USE aero_mod
-  USE pres2lev_mod
-
-  !    Yves Balkanski le 12 avril 2006
-  !    Celine Deandreis
-  !    Anne Cozic Avril 2009
-  !    a partir d'une sous-routine de Johannes Quaas pour les sulfates
-  !
-  IMPLICIT NONE
-
-  INCLUDE "YOMCST.h"
-
-  !
-  ! Input arguments:
-  !
-  REAL, DIMENSION(klon,klev),     INTENT(in)  :: pdel
-  REAL,                           INTENT(in)  :: delt
-  REAL, DIMENSION(klon,klev,naero_tot),   INTENT(in)  :: m_allaer
-  REAL, DIMENSION(klon,klev,naero_tot),   INTENT(in)  :: m_allaer_pi
-  REAL, DIMENSION(klon,klev),     INTENT(in)  :: RHcl       ! humidite relative ciel clair
-  INTEGER,                        INTENT(in)  :: flag_aerosol
-  REAL, DIMENSION(klon,klev),     INTENT(in)  :: pplay
-  REAL, DIMENSION(klon,klev),     INTENT(in)  :: t_seri
-  REAL, DIMENSION(klev),          INTENT(in)  :: presnivs
-  !
-  ! Output arguments:
-  !
-  REAL, DIMENSION(klon,klev,naero_grp,nbands), INTENT(out) :: tau_allaer ! epaisseur optique aerosol
-  REAL, DIMENSION(klon,klev,naero_grp,nbands), INTENT(out) :: piz_allaer ! single scattering albedo aerosol
-  REAL, DIMENSION(klon,klev,naero_grp,nbands), INTENT(out) :: cg_allaer  ! asymmetry parameter aerosol
-
-  !
-  ! Local
-  !
-  REAL, DIMENSION(klon,klev,naero_tot,nbands) ::  tau_ae
-  REAL, DIMENSION(klon,klev,naero_tot,nbands) ::  tau_ae_pi
-  REAL, DIMENSION(klon,klev,naero_tot,nbands) ::  piz_ae
-  REAL, DIMENSION(klon,klev,naero_tot,nbands) ::  cg_ae
-  LOGICAL ::  soluble
-  INTEGER :: i, k,n, ierr, inu, m, mrfspecies
-  INTEGER :: spsol, spinsol, spss
-  INTEGER :: RH_num(klon,klev)
-  INTEGER, PARAMETER :: nb_level=19 ! number of vertical levels in DATA
-
-  INTEGER, PARAMETER :: nbre_RH=12
-  INTEGER, PARAMETER :: naero_soluble=7    ! 1- BC soluble; 2- POM soluble; 3- SO4. acc. 4- SO4 coarse
-                                           ! 5- seasalt super coarse  6- seasalt coarse   7- seasalt acc.
-  INTEGER, PARAMETER :: naero_insoluble=3  ! 1- Dust; 2- BC insoluble; 3- POM insoluble
-  LOGICAL, SAVE :: firstcall=.TRUE. 
-!$OMP THREADPRIVATE(firstcall)
-
-! Coefficient optiques sur 19 niveaux
-  REAL, SAVE, DIMENSION(nb_level) :: presnivs_19  ! Pression milieux couche pour 19 niveaux (nb_level)
-!$OMP THREADPRIVATE(presnivs_19)
-
-  REAL, SAVE, DIMENSION(nb_level) :: A1_ASSSM_b1_19, A2_ASSSM_b1_19, A3_ASSSM_b1_19,&
-          B1_ASSSM_b1_19, B2_ASSSM_b1_19, C1_ASSSM_b1_19, C2_ASSSM_b1_19,&
-          A1_CSSSM_b1_19, A2_CSSSM_b1_19, A3_CSSSM_b1_19,&
-          B1_CSSSM_b1_19, B2_CSSSM_b1_19, C1_CSSSM_b1_19, C2_CSSSM_b1_19,&
-          A1_SSSSM_b1_19, A2_SSSSM_b1_19, A3_SSSSM_b1_19,&
-          B1_SSSSM_b1_19, B2_SSSSM_b1_19, C1_SSSSM_b1_19, C2_SSSSM_b1_19,&
-          A1_ASSSM_b2_19, A2_ASSSM_b2_19, A3_ASSSM_b2_19,&
-          B1_ASSSM_b2_19, B2_ASSSM_b2_19, C1_ASSSM_b2_19, C2_ASSSM_b2_19,&
-          A1_CSSSM_b2_19, A2_CSSSM_b2_19, A3_CSSSM_b2_19,&
-          B1_CSSSM_b2_19, B2_CSSSM_b2_19, C1_CSSSM_b2_19, C2_CSSSM_b2_19,&
-          A1_SSSSM_b2_19, A2_SSSSM_b2_19, A3_SSSSM_b2_19,&
-          B1_SSSSM_b2_19, B2_SSSSM_b2_19, C1_SSSSM_b2_19, C2_SSSSM_b2_19
-!$OMP THREADPRIVATE(A1_ASSSM_b1_19, A2_ASSSM_b1_19, A3_ASSSM_b1_19)
-!$OMP THREADPRIVATE(B1_ASSSM_b1_19, B2_ASSSM_b1_19, C1_ASSSM_b1_19, C2_ASSSM_b1_19)
-!$OMP THREADPRIVATE(A1_CSSSM_b1_19, A2_CSSSM_b1_19, A3_CSSSM_b1_19)
-!$OMP THREADPRIVATE(B1_CSSSM_b1_19, B2_CSSSM_b1_19, C1_CSSSM_b1_19, C2_CSSSM_b1_19)
-!$OMP THREADPRIVATE(A1_SSSSM_b1_19, A2_SSSSM_b1_19, A3_SSSSM_b1_19)
-!$OMP THREADPRIVATE(B1_SSSSM_b1_19, B2_SSSSM_b1_19, C1_SSSSM_b1_19, C2_SSSSM_b1_19)
-!$OMP THREADPRIVATE(A1_ASSSM_b2_19, A2_ASSSM_b2_19, A3_ASSSM_b2_19)
-!$OMP THREADPRIVATE(B1_ASSSM_b2_19, B2_ASSSM_b2_19, C1_ASSSM_b2_19, C2_ASSSM_b2_19)
-!$OMP THREADPRIVATE(A1_CSSSM_b2_19, A2_CSSSM_b2_19, A3_CSSSM_b2_19)
-!$OMP THREADPRIVATE(B1_CSSSM_b2_19, B2_CSSSM_b2_19, C1_CSSSM_b2_19, C2_CSSSM_b2_19)
-!$OMP THREADPRIVATE(A1_SSSSM_b2_19, A2_SSSSM_b2_19, A3_SSSSM_b2_19)
-!$OMP THREADPRIVATE(B1_SSSSM_b2_19, B2_SSSSM_b2_19, C1_SSSSM_b2_19, C2_SSSSM_b2_19)
-
-
-! Coefficient optiques interpole sur le nombre de niveau du modele
-  REAL, ALLOCATABLE, DIMENSION(:), SAVE :: &
-          A1_ASSSM_b1, A2_ASSSM_b1, A3_ASSSM_b1,&
-          B1_ASSSM_b1, B2_ASSSM_b1, C1_ASSSM_b1, C2_ASSSM_b1,&
-          A1_CSSSM_b1, A2_CSSSM_b1, A3_CSSSM_b1,&
-          B1_CSSSM_b1, B2_CSSSM_b1, C1_CSSSM_b1, C2_CSSSM_b1,&
-          A1_SSSSM_b1, A2_SSSSM_b1, A3_SSSSM_b1,&
-          B1_SSSSM_b1, B2_SSSSM_b1, C1_SSSSM_b1, C2_SSSSM_b1,&
-          A1_ASSSM_b2, A2_ASSSM_b2, A3_ASSSM_b2,&
-          B1_ASSSM_b2, B2_ASSSM_b2, C1_ASSSM_b2, C2_ASSSM_b2,&
-          A1_CSSSM_b2, A2_CSSSM_b2, A3_CSSSM_b2,&
-          B1_CSSSM_b2, B2_CSSSM_b2, C1_CSSSM_b2, C2_CSSSM_b2,&
-          A1_SSSSM_b2, A2_SSSSM_b2, A3_SSSSM_b2,&
-          B1_SSSSM_b2, B2_SSSSM_b2, C1_SSSSM_b2, C2_SSSSM_b2
-!$OMP THREADPRIVATE(A1_ASSSM_b1, A2_ASSSM_b1, A3_ASSSM_b1)
-!$OMP THREADPRIVATE(B1_ASSSM_b1, B2_ASSSM_b1, C1_ASSSM_b1, C2_ASSSM_b1)
-!$OMP THREADPRIVATE(A1_CSSSM_b1, A2_CSSSM_b1, A3_CSSSM_b1)
-!$OMP THREADPRIVATE(B1_CSSSM_b1, B2_CSSSM_b1, C1_CSSSM_b1, C2_CSSSM_b1)
-!$OMP THREADPRIVATE(A1_SSSSM_b1, A2_SSSSM_b1, A3_SSSSM_b1)
-!$OMP THREADPRIVATE(B1_SSSSM_b1, B2_SSSSM_b1, C1_SSSSM_b1, C2_SSSSM_b1)
-!$OMP THREADPRIVATE(A1_ASSSM_b2, A2_ASSSM_b2, A3_ASSSM_b2)
-!$OMP THREADPRIVATE(B1_ASSSM_b2, B2_ASSSM_b2, C1_ASSSM_b2, C2_ASSSM_b2)
-!$OMP THREADPRIVATE(A1_CSSSM_b2, A2_CSSSM_b2, A3_CSSSM_b2)
-!$OMP THREADPRIVATE(B1_CSSSM_b2, B2_CSSSM_b2, C1_CSSSM_b2, C2_CSSSM_b2)
-!$OMP THREADPRIVATE(A1_SSSSM_b2, A2_SSSSM_b2, A3_SSSSM_b2)
-!$OMP THREADPRIVATE(B1_SSSSM_b2, B2_SSSSM_b2, C1_SSSSM_b2, C2_SSSSM_b2)
-  
-  REAL,PARAMETER :: RH_tab(nbre_RH)=(/0.,10.,20.,30.,40.,50.,60.,70.,80.,85.,90.,95./)
-  REAL, PARAMETER :: RH_MAX=95.
-  REAL:: DELTA(klon,klev), rh(klon,klev), H
-  REAL:: tau_ae2b_int   ! Intermediate computation of epaisseur optique aerosol
-  REAL:: piz_ae2b_int   ! Intermediate computation of Single scattering albedo
-  REAL:: cg_ae2b_int    ! Intermediate computation of Assymetry parameter
-  REAL :: Fact_RH(nbre_RH)
-  REAL :: zrho
-  REAL :: fac
-  REAL :: zdh(klon,klev) 
-  INTEGER, ALLOCATABLE, DIMENSION(:)   :: aerosol_name
-  INTEGER :: nb_aer
-
-  !
-  ! Proprietes optiques
-  !
-  REAL:: alpha_aers_2bands(nbre_RH,nbands,naero_soluble)   !--unit m2/g SO4
-  REAL:: alpha_aeri_2bands(nbands,naero_insoluble)
-  REAL:: cg_aers_2bands(nbre_RH,nbands,naero_soluble)      !--unit 
-  REAL:: cg_aeri_2bands(nbands,naero_insoluble)
-  REAL:: piz_aers_2bands(nbre_RH,nbands,naero_soluble)     !-- unit
-  REAL:: piz_aeri_2bands(nbands,naero_insoluble)           !-- unit
-
-  INTEGER :: id
-  LOGICAL :: used_aer(naero_tot)
-  REAL :: tmp_var, tmp_var_pi
-
-  DATA presnivs_19/&
-       100426.5,  98327.6, 95346.5, 90966.8, 84776.9, &
-       76536.5,   66292.2, 54559.3, 42501.8, 31806, &
-       23787.5,   18252.7, 13996,   10320.8, 7191.1, &
-       4661.7,    2732.9,  1345.6,  388.2/  
-
-
-!***********************BAND 1***********************************
-!ACCUMULATION MODE
-  DATA A1_ASSSM_b1_19/ 4.373E+00,  4.361E+00,  4.331E+00, &
-                    4.278E+00,  4.223E+00,  4.162E+00, &
-                    4.103E+00,  4.035E+00,  3.962E+00, &
-                    3.904E+00,  3.871E+00,  3.847E+00, &
-                    3.824E+00,  3.780E+00,  3.646E+00, &
-                    3.448E+00,  3.179E+00,  2.855E+00,  2.630E+00/
-  DATA A2_ASSSM_b1_19/ 2.496E+00,  2.489E+00,  2.472E+00, &
-                    2.442E+00,  2.411E+00,  2.376E+00, &
-                    2.342E+00,  2.303E+00,  2.261E+00, &
-                    2.228E+00,  2.210E+00,  2.196E+00, &
-                    2.183E+00,  2.158E+00,  2.081E+00, &
-                    1.968E+00,  1.814E+00,  1.630E+00,  1.501E+00/
-  DATA A3_ASSSM_b1_19/-4.688E-02, -4.676E-02, -4.644E-02, &
-                   -4.587E-02, -4.528E-02, -4.463E-02, &
-                   -4.399E-02, -4.326E-02, -4.248E-02, &
-                   -4.186E-02, -4.151E-02, -4.125E-02, &
-                   -4.100E-02, -4.053E-02, -3.910E-02, &
-                   -3.697E-02, -3.408E-02, -3.061E-02, -2.819E-02/
-  DATA B1_ASSSM_b1_19/ 1.165E-08,  1.145E-08,  1.097E-08, &
-                    1.012E-08,  9.233E-09,  8.261E-09, &
-                    7.297E-09,  6.201E-09,  5.026E-09, &
-                    4.098E-09,  3.567E-09,  3.187E-09, &
-                    2.807E-09,  2.291E-09,  2.075E-09, &
-                    1.756E-09,  1.322E-09,  8.011E-10, 4.379E-10/
-  DATA B2_ASSSM_b1_19/ 2.193E-08,  2.192E-08,  2.187E-08, &
-                    2.179E-08,  2.171E-08,  2.162E-08, &
-                    2.153E-08,  2.143E-08,  2.132E-08, &
-                    2.124E-08,  2.119E-08,  2.115E-08, &
-                    2.112E-08,  2.106E-08,  2.100E-08, &
-                    2.090E-08,  2.077E-08,  2.061E-08,  2.049E-08/
-  DATA C1_ASSSM_b1_19/ 7.365E-01,  7.365E-01,  7.365E-01, &
-                    7.364E-01,  7.363E-01,  7.362E-01, &
-                    7.361E-01,  7.359E-01,  7.358E-01, &
-                    7.357E-01,  7.356E-01,  7.356E-01, &
-                    7.356E-01,  7.355E-01,  7.354E-01, &
-                    7.352E-01,  7.350E-01,  7.347E-01,  7.345E-01/
-  DATA C2_ASSSM_b1_19/ 5.833E-02,  5.835E-02,  5.841E-02, &
-                    5.850E-02,  5.859E-02,  5.870E-02, &
-                    5.880E-02,  5.891E-02,  5.904E-02, &
-                    5.914E-02,  5.920E-02,  5.924E-02, &
-                    5.928E-02,  5.934E-02,  5.944E-02, &
-                    5.959E-02,  5.979E-02,  6.003E-02,  6.020E-02/
-!COARSE MODE
-  DATA A1_CSSSM_b1_19/ 7.403E-01,  7.422E-01,  7.626E-01, &
-                    8.019E-01,  8.270E-01,  8.527E-01, &
-                    8.702E-01,  8.806E-01,  8.937E-01, &
-                    9.489E-01,  1.030E+00,  1.105E+00, &
-                    1.199E+00,  1.357E+00,  1.660E+00, &
-                    2.540E+00,  4.421E+00,  2.151E+00,  9.518E-01/
-  DATA A2_CSSSM_b1_19/ 4.522E-01,  4.532E-01,  4.644E-01, &
-                    4.859E-01,  4.996E-01,  5.137E-01, &
-                    5.233E-01,  5.290E-01,  5.361E-01, &
-                    5.655E-01,  6.085E-01,  6.483E-01, &
-                    6.979E-01,  7.819E-01,  9.488E-01, &
-                    1.450E+00,  2.523E+00,  1.228E+00,  5.433E-01/
-  DATA A3_CSSSM_b1_19/-8.516E-03, -8.535E-03, -8.744E-03, &
-                   -9.148E-03, -9.406E-03, -9.668E-03, &
-                   -9.848E-03, -9.955E-03, -1.009E-02, &
-                   -1.064E-02, -1.145E-02, -1.219E-02, &
-                   -1.312E-02, -1.470E-02, -1.783E-02, &
-                   -2.724E-02, -4.740E-02, -2.306E-02, -1.021E-02/
-  DATA B1_CSSSM_b1_19/ 2.535E-07,  2.530E-07,  2.479E-07, &
-                    2.380E-07,  2.317E-07,  2.252E-07, &
-                    2.208E-07,  2.182E-07,  2.149E-07, &
-                    2.051E-07,  1.912E-07,  1.784E-07, &
-                    1.624E-07,  1.353E-07,  1.012E-07, &
-                    6.016E-08,  2.102E-08,  0.000E+00,  0.000E+00/
-  DATA B2_CSSSM_b1_19/ 1.221E-07,  1.217E-07,  1.179E-07, &
-                    1.104E-07,  1.056E-07,  1.008E-07, &
-                    9.744E-08,  9.546E-08,  9.299E-08, &
-                    8.807E-08,  8.150E-08,  7.544E-08, &
-                    6.786E-08,  5.504E-08,  4.080E-08, &
-                    2.960E-08,  2.300E-08,  2.030E-08,  1.997E-08/
-  DATA C1_CSSSM_b1_19/ 7.659E-01,  7.658E-01,  7.652E-01, &
-                    7.639E-01,  7.631E-01,  7.623E-01, &
-                    7.618E-01,  7.614E-01,  7.610E-01, &
-                    7.598E-01,  7.581E-01,  7.566E-01, &
-                    7.546E-01,  7.513E-01,  7.472E-01, &
-                    7.423E-01,  7.376E-01,  7.342E-01,  7.334E-01/
-  DATA C2_CSSSM_b1_19/ 3.691E-02,  3.694E-02,  3.729E-02, &
-                    3.796E-02,  3.839E-02,  3.883E-02, &
-                    3.913E-02,  3.931E-02,  3.953E-02, &
-                    4.035E-02,  4.153E-02,  4.263E-02, &
-                    4.400E-02,  4.631E-02,  4.933E-02, &
-                    5.331E-02,  5.734E-02,  6.053E-02,  6.128E-02/
-!SUPER COARSE MODE
-  DATA A1_SSSSM_b1_19/ 2.836E-01,  2.876E-01,  2.563E-01, &
-                    2.414E-01,  2.541E-01,  2.546E-01, &
-                    2.572E-01,  2.638E-01,  2.781E-01, &
-                    3.167E-01,  4.209E-01,  5.286E-01, &
-                    6.959E-01,  9.233E-01,  1.282E+00, &
-                    1.836E+00,  2.981E+00,  4.355E+00,  4.059E+00/
-  DATA A2_SSSSM_b1_19/ 1.608E-01,  1.651E-01,  1.577E-01, &
-                    1.587E-01,  1.686E-01,  1.690E-01, &
-                    1.711E-01,  1.762E-01,  1.874E-01, &
-                    2.138E-01,  2.751E-01,  3.363E-01, &
-                    4.279E-01,  5.519E-01,  7.421E-01, &
-                    1.048E+00,  1.702E+00,  2.485E+00,  2.317E+00/
-  DATA A3_SSSSM_b1_19/-3.025E-03, -3.111E-03, -2.981E-03, &
-                   -3.005E-03, -3.193E-03, -3.200E-03, &
-                   -3.239E-03, -3.336E-03, -3.548E-03, &
-                   -4.047E-03, -5.196E-03, -6.345E-03, &
-                   -8.061E-03, -1.038E-02, -1.395E-02, &
-                   -1.970E-02, -3.197E-02, -4.669E-02, -4.352E-02/
-  DATA B1_SSSSM_b1_19/ 6.759E-07,  6.246E-07,  5.542E-07, &
-                    4.953E-07,  4.746E-07,  4.738E-07, &
-                    4.695E-07,  4.588E-07,  4.354E-07, &
-                    3.947E-07,  3.461E-07,  3.067E-07, &
-                    2.646E-07,  2.095E-07,  1.481E-07, &
-                    9.024E-08,  5.747E-08,  2.384E-08,  6.599E-09/
-  DATA B2_SSSSM_b1_19/ 5.977E-07,  5.390E-07,  4.468E-07, &
-                    3.696E-07,  3.443E-07,  3.433E-07, &
-                    3.380E-07,  3.249E-07,  2.962E-07, &
-                    2.483E-07,  1.989E-07,  1.623E-07, &
-                    1.305E-07,  9.015E-08,  6.111E-08, &
-                    3.761E-08,  2.903E-08,  2.337E-08,  2.147E-08/
-  DATA C1_SSSSM_b1_19/ 8.120E-01,  8.084E-01,  8.016E-01, &
-                    7.953E-01,  7.929E-01,  7.928E-01, &
-                    7.923E-01,  7.910E-01,  7.882E-01, &
-                    7.834E-01,  7.774E-01,  7.725E-01, &
-                    7.673E-01,  7.604E-01,  7.529E-01, &
-                    7.458E-01,  7.419E-01,  7.379E-01,  7.360E-01/
-  DATA C2_SSSSM_b1_19/ 2.388E-02,  2.392E-02,  2.457E-02,  2.552E-02, &
-                    2.615E-02,  2.618E-02,  2.631E-02,  2.663E-02, &
-                    2.735E-02,  2.875E-02,  3.113E-02,  3.330E-02, &
-                    3.615E-02,  3.997E-02,  4.521E-02,  5.038E-02, &
-                    5.358E-02,  5.705E-02,  5.887E-02/
-!*********************BAND 2************************************************
-!ACCUMULATION MODE
-  DATA A1_ASSSM_b2_19/1.256E+00, 1.246E+00, 1.226E+00, 1.187E+00, 1.148E+00, &
-                   1.105E+00, 1.062E+00, 1.014E+00, 9.616E-01, 9.205E-01, &
-                   8.970E-01, 8.800E-01, 8.632E-01, 8.371E-01, 7.943E-01, &
-                   7.308E-01, 6.448E-01, 5.414E-01, 4.693E-01/
-  DATA A2_ASSSM_b2_19/5.321E-01, 5.284E-01, 5.196E-01, 5.036E-01, 4.872E-01, &
-                   4.691E-01, 4.512E-01, 4.308E-01, 4.089E-01, 3.917E-01, &
-                   3.818E-01, 3.747E-01, 3.676E-01, 3.567E-01, 3.385E-01, &
-                   3.116E-01, 2.751E-01, 2.312E-01, 2.006E-01/
-  DATA A3_ASSSM_b2_19/-1.053E-02, -1.046E-02, -1.028E-02, -9.964E-03, -9.637E-03, &
-                   -9.279E-03, -8.923E-03, -8.518E-03, -8.084E-03, -7.741E-03, &
-                   -7.545E-03, -7.405E-03, -7.265E-03, -7.048E-03, -6.687E-03, &
-                   -6.156E-03, -5.433E-03, -4.565E-03, -3.961E-03/
-  DATA B1_ASSSM_b2_19/1.560E-02, 1.560E-02, 1.561E-02, 1.565E-02, 1.568E-02, &
-                   1.572E-02, 1.576E-02, 1.580E-02, 1.584E-02, 1.588E-02, &
-                   1.590E-02, 1.592E-02, 1.593E-02, 1.595E-02, 1.599E-02, &
-                   1.605E-02, 1.612E-02, 1.621E-02, 1.627E-02/
-  DATA B2_ASSSM_b2_19/1.073E-02, 1.074E-02, 1.076E-02, 1.079E-02, 1.082E-02, &
-                   1.085E-02, 1.089E-02, 1.093E-02, 1.097E-02, 1.100E-02, &
-                   1.102E-02, 1.103E-02, 1.105E-02, 1.107E-02, 1.110E-02, &
-                   1.115E-02, 1.122E-02, 1.130E-02, 1.136E-02/
-  DATA C1_ASSSM_b2_19/7.429E-01, 7.429E-01, 7.429E-01, 7.427E-01, 7.427E-01, &
-                   7.424E-01, 7.423E-01, 7.422E-01, 7.421E-01, 7.420E-01, &
-                   7.419E-01, 7.419E-01, 7.418E-01, 7.417E-01, 7.416E-01, &
-                   7.415E-01, 7.413E-01, 7.409E-01, 7.408E-01/
-  DATA C2_ASSSM_b2_19/3.031E-02, 3.028E-02, 3.022E-02, 3.011E-02, 2.999E-02, &
-                   2.986E-02, 2.973E-02, 2.959E-02, 2.943E-02, 2.931E-02, &
-                   2.924E-02, 2.919E-02, 2.913E-02, 2.905E-02, 2.893E-02, &
-                   2.874E-02, 2.847E-02, 2.817E-02, 2.795E-02/
-!COARSE MODE
-  DATA A1_CSSSM_b2_19/7.061E-01, 7.074E-01, 7.211E-01, 7.476E-01, 7.647E-01, &
-                   7.817E-01, 7.937E-01, 8.007E-01, 8.095E-01, 8.436E-01, &
-                   8.932E-01, 9.390E-01, 9.963E-01, 1.093E+00, 1.256E+00, &
-                   1.668E+00, 1.581E+00, 3.457E-01, 1.331E-01/
-  DATA A2_CSSSM_b2_19/3.617E-01, 3.621E-01, 3.662E-01, 3.739E-01, 3.789E-01, &
-                   3.840E-01, 3.874E-01, 3.895E-01, 3.921E-01, 4.001E-01, &
-                   4.117E-01, 4.223E-01, 4.356E-01, 4.581E-01, 5.099E-01, &
-                   6.831E-01, 6.663E-01, 1.481E-01, 5.703E-02/
-  DATA A3_CSSSM_b2_19/-6.953E-03, -6.961E-03, -7.048E-03, -7.216E-03, -7.322E-03, &
-                   -7.431E-03, -7.506E-03, -7.551E-03, -7.606E-03, -7.791E-03, &
-                   -8.059E-03, -8.305E-03, -8.613E-03, -9.134E-03, -1.023E-02, &
-                   -1.365E-02, -1.320E-02, -2.922E-03, -1.125E-03/
-  DATA B1_CSSSM_b2_19/1.007E-02, 1.008E-02, 1.012E-02, 1.019E-02, 1.024E-02, &
-                   1.029E-02, 1.033E-02, 1.035E-02, 1.038E-02, 1.056E-02, &
-                   1.083E-02, 1.109E-02, 1.140E-02, 1.194E-02, 1.270E-02, &
-                   1.390E-02, 1.524E-02, 1.639E-02, 1.667E-02/
-  DATA B2_CSSSM_b2_19/4.675E-03, 4.682E-03, 4.760E-03, 4.908E-03, 5.004E-03, &
-                   5.102E-03, 5.168E-03, 5.207E-03, 5.256E-03, 5.474E-03, &
-                   5.793E-03, 6.089E-03, 6.457E-03, 7.081E-03, 7.923E-03, &
-                   9.127E-03, 1.041E-02, 1.147E-02, 1.173E-02/
-  DATA C1_CSSSM_b2_19/7.571E-01, 7.571E-01, 7.570E-01, 7.568E-01, 7.565E-01, &
-                   7.564E-01, 7.563E-01, 7.562E-01, 7.562E-01, 7.557E-01, &
-                   7.552E-01, 7.545E-01, 7.539E-01, 7.527E-01, 7.509E-01, &
-                   7.478E-01, 7.440E-01, 7.404E-01, 7.394E-01/
-  DATA C2_CSSSM_b2_19/4.464E-02, 4.465E-02, 4.468E-02, 4.474E-02, 4.477E-02, &
-                   4.480E-02, 4.482E-02, 4.484E-02, 4.486E-02, 4.448E-02, &
-                   4.389E-02, 4.334E-02, 4.264E-02, 4.148E-02, 3.957E-02, &
-                   3.588E-02, 3.149E-02, 2.751E-02, 2.650E-02/
-!SUPER COARSE MODE
-  DATA A1_SSSSM_b2_19/2.357E-01, 2.490E-01, 2.666E-01, 2.920E-01, 3.120E-01, &
-                   3.128E-01, 3.169E-01, 3.272E-01, 3.498E-01, 3.960E-01, &
-                   4.822E-01, 5.634E-01, 6.763E-01, 8.278E-01, 1.047E+00, &
-                   1.340E+00, 1.927E+00, 1.648E+00, 1.031E+00/
-  DATA A2_SSSSM_b2_19/1.219E-01, 1.337E-01, 1.633E-01, 1.929E-01, 2.057E-01, &
-                   2.062E-01, 2.089E-01, 2.155E-01, 2.300E-01, 2.560E-01, &
-                   2.908E-01, 3.199E-01, 3.530E-01, 3.965E-01, 4.475E-01, &
-                   5.443E-01, 7.943E-01, 6.928E-01, 4.381E-01/
-  DATA A3_SSSSM_b2_19/-2.387E-03, -2.599E-03, -3.092E-03, -3.599E-03, -3.832E-03, &
-                   -3.842E-03, -3.890E-03, -4.012E-03, -4.276E-03, -4.763E-03, &
-                   -5.455E-03, -6.051E-03, -6.763E-03, -7.708E-03, -8.887E-03, &
-                   -1.091E-02, -1.585E-02, -1.373E-02, -8.665E-03/
-  DATA B1_SSSSM_b2_19/1.260E-02, 1.211E-02, 1.126E-02, 1.056E-02, 1.038E-02, &
-                   1.037E-02, 1.033E-02, 1.023E-02, 1.002E-02, 9.717E-03, &
-                   9.613E-03, 9.652E-03, 9.983E-03, 1.047E-02, 1.168E-02, &
-                   1.301E-02, 1.399E-02, 1.514E-02, 1.578E-02/
-  DATA B2_SSSSM_b2_19/2.336E-03, 2.419E-03, 2.506E-03, 2.610E-03, 2.690E-03, &
-                   2.694E-03, 2.711E-03, 2.752E-03, 2.844E-03, 3.043E-03, &
-                   3.455E-03, 3.871E-03, 4.507E-03, 5.373E-03, 6.786E-03, &
-                   8.238E-03, 9.208E-03, 1.032E-02, 1.091E-02/
-  DATA C1_SSSSM_b2_19/7.832E-01, 7.787E-01, 7.721E-01, 7.670E-01, 7.657E-01, &
-                   7.657E-01, 7.654E-01, 7.648E-01, 7.634E-01, 7.613E-01, &
-                   7.596E-01, 7.585E-01, 7.574E-01, 7.560E-01, 7.533E-01, &
-                   7.502E-01, 7.476E-01, 7.443E-01, 7.423E-01/
-  DATA C2_SSSSM_b2_19/3.144E-02, 3.268E-02, 3.515E-02, 3.748E-02, 3.837E-02, &
-                   3.840E-02, 3.860E-02, 3.906E-02, 4.006E-02, 4.173E-02, &
-                   4.338E-02, 4.435E-02, 4.459E-02, 4.467E-02, 4.202E-02, &
-                   3.864E-02, 3.559E-02, 3.183E-02, 2.964E-02/
-!***************************************************************************
-
-  spsol = 0
-  spinsol = 0 
-  spss = 0 
-
-  DATA alpha_aers_2bands/  & 
-       ! bc soluble
-       7.675,7.675,7.675,7.675,7.675,7.675,    &
-       7.675,7.675,10.433,11.984,13.767,15.567,& 
-       4.720,4.720,4.720,4.720,4.720,4.720,    & 
-       4.720,4.720,6.081,6.793,7.567,9.344,    & 
-       ! pom soluble
-       5.503,5.503,5.503,5.503,5.588,5.957,    & 
-       6.404,7.340,8.545,10.319,13.595,20.398, & 
-       1.402,1.402,1.402,1.402,1.431,1.562,    & 
-       1.715,2.032,2.425,2.991,4.193,7.133,    & 
-       ! sulfate    
-       4.681,5.062,5.460,5.798,6.224,6.733,    & 
-       7.556,8.613,10.687,12.265,16.32,21.692, & 
-       1.107,1.239,1.381,1.490,1.635,1.8030,   &
-       2.071,2.407,3.126,3.940,5.539,7.921,    &
-                                ! sulfate coarse
-       4.681,5.062,5.460,5.798,6.224,6.733,    & 
-       7.556,8.613,10.687,12.265,16.32,21.692, & 
-       1.107,1.239,1.381,1.490,1.635,1.8030,   &
-       2.071,2.407,3.126,3.940,5.539,7.921,    &
-                                ! seasalt Super Coarse Soluble (SS)
-       0.5090,0.6554,0.7129,0.7767,0.8529,1.2728, &
-       1.3820,1.5792,1.9173,2.2002,2.7173,4.1487, &
-       0.5167,0.6613,0.7221,0.7868,0.8622,1.3027, &
-       1.4227,1.6317,1.9887,2.2883,2.8356,4.3453, &
-                                ! seasalt  Coarse Soluble (CS)
-       0.5090,0.6554,0.7129,0.7767,0.8529,1.2728, &
-       1.3820,1.5792,1.9173,2.2002,2.7173,4.1487, &
-       0.5167,0.6613,0.7221,0.7868,0.8622,1.3027, &
-       1.4227,1.6317,1.9887,2.2883,2.8356,4.3453, &
-                                ! seasalt  Accumulation Soluble (AS)
-       4.125, 4.674, 5.005, 5.434, 5.985, 10.006, &
-       11.175,13.376,17.264,20.540,26.604, 42.349,&
-       4.187, 3.939, 3.919, 3.937, 3.995,  5.078, &
-       5.511, 6.434, 8.317,10.152,14.024, 26.537/
-
-  DATA alpha_aeri_2bands/  & 
-       ! dust insoluble
-       0.7661,0.7123,&
-       ! bc insoluble
-       10.360,4.437, &
-       ! pom insoluble
-       3.741,0.606/
-
-  DATA cg_aers_2bands/ &
-       ! bc soluble
-       .612, .612, .612, .612, .612, .612, &
-       .612, .612, .702, .734, .760, .796, &
-       .433, .433, .433, .433, .433, .433, &
-       .433, .433, .534, .575, .613, .669, &
-       ! pom soluble
-       .663, .663, .663, .663, .666, .674, &
-       .685, .702, .718, .737, .757, .777, &
-       .544, .544, .544, .544, .547, .554, &
-       .565, .583, .604, .631, .661, .698, &
-       ! sulfate    
-       .658, .669, .680, .688, .698, .707, &
-       .719, .733, .752, .760, .773, .786, &
-       .544, .555, .565, .573, .583, .593, &
-       .610, .628, .655, .666, .692, .719, &
-                                ! sulfate coarse
-       .658, .669, .680, .688, .698, .707, &
-       .719, .733, .752, .760, .773, .786, &
-       .544, .555, .565, .573, .583, .593, &
-       .610, .628, .655, .666, .692, .719, &
-                                ! seasalt Super Coarse soluble (SS)
-       .727, .747, .755, .761, .770, .788, &
-       .792, .799, .805, .809, .815, .826, &
-       .717, .738, .745, .752, .761, .779, &
-       .781, .786, .793, .797, .803, .813, &
-                                ! seasalt Coarse soluble (CS)
-       .727, .747, .755, .761, .770, .788, &
-       .792, .799, .805, .809, .815, .826, &
-       .717, .738, .745, .752, .761, .779, &
-       .781, .786, .793, .797, .803, .813, &
-                                ! Sesalt Accumulation Soluble (AS)
-       .727, .741, .748, .754, .761, .782, &
-       .787, .792, .797, .799, .801, .799, &
-       .606, .645, .658, .669, .681, .726, &
-       .734, .746, .761, .770, .782, .798/
-
-  DATA cg_aeri_2bands/ &
-       ! dust insoluble
-       .701, .670, &
-       ! bc insoluble
-       .471, .297, &
-       ! pom insoluble
-       .568, .365/
-
-  DATA piz_aers_2bands/&
-       ! bc soluble
-       .445, .445, .445, .445, .445, .445, &
-       .445, .445, .461, .480, .505, .528, &
-       .362, .362, .362, .362, .362, .362, &
-       .362, .362, .381, .405, .437, .483, &
-       ! pom soluble
-       .972, .972, .972, .972, .972, .974, &
-       .976, .979, .982, .986, .989, .992, &
-       .924, .924, .924, .924, .925, .927, &
-       .932, .938, .945, .952, .961, .970, &
-       ! sulfate
-       1.000,1.000,1.000,1.000,1.000,1.000, &
-       1.000,1.000,1.000,1.000,1.000,1.000, &
-       .992, .988, .988, .987, .986, .985,  &
-       .985, .985, .984, .984, .984, .984,  &
-                                ! sulfate coarse
-       1.000,1.000,1.000,1.000,1.000,1.000, &
-       1.000,1.000,1.000,1.000,1.000,1.000, &
-       .992, .988, .988, .987, .986, .985,  &
-       .985, .985, .984, .984, .984, .984,  &
-                                ! seasalt Super Coarse Soluble (SS)
-       1.000,1.000,1.000,1.000,1.000,1.000, &
-       1.000,1.000,1.000,1.000,1.000,1.000, &
-       0.992,0.989,0.987,0.986,0.986,0.980, &
-       0.980,0.978,0.976,0.976,0.974,0.971, &
-                                ! seasalt Coarse soluble (CS)
-       1.000,1.000,1.000,1.000,1.000,1.000, &
-       1.000,1.000,1.000,1.000,1.000,1.000, &
-       0.992,0.989,0.987,0.986,0.986,0.980, &
-       0.980,0.978,0.976,0.976,0.974,0.971, &
-                                ! seasalt Accumulation Soluble (AS)
-       1.000, 1.000, 1.000, 1.000, 1.000, 1.000, &
-       1.000, 1.000, 1.000, 1.000, 1.000, 1.000, &
-       0.970, 0.975, 0.976, 0.977, 0.978, 0.982, &
-       0.982, 0.983, 0.984, 0.984, 0.985, 0.985/
-
-  DATA piz_aeri_2bands/ &
-       ! dust insoluble
-       .963, .987, &
-       ! bc insoluble
-       .395, .264, &
-       ! pom insoluble
-       .966, .859/
-
-! Interpolation des coefficients optiques de 19 niveaux vers le nombre des niveaux du model
-  IF (firstcall) THEN
-     firstcall=.FALSE.
-     
-     IF (.NOT. ALLOCATED(A1_ASSSM_b1)) THEN
-        ALLOCATE(A1_ASSSM_b1(klev),A2_ASSSM_b1(klev), A3_ASSSM_b1(klev),&
-          B1_ASSSM_b1(klev), B2_ASSSM_b1(klev), C1_ASSSM_b1(klev), C2_ASSSM_b1(klev),&
-          A1_CSSSM_b1(klev), A2_CSSSM_b1(klev), A3_CSSSM_b1(klev),&
-          B1_CSSSM_b1(klev), B2_CSSSM_b1(klev), C1_CSSSM_b1(klev), C2_CSSSM_b1(klev),&
-          A1_SSSSM_b1(klev), A2_SSSSM_b1(klev), A3_SSSSM_b1(klev),&
-          B1_SSSSM_b1(klev), B2_SSSSM_b1(klev), C1_SSSSM_b1(klev), C2_SSSSM_b1(klev),&
-          A1_ASSSM_b2(klev), A2_ASSSM_b2(klev), A3_ASSSM_b2(klev),&
-          B1_ASSSM_b2(klev), B2_ASSSM_b2(klev), C1_ASSSM_b2(klev), C2_ASSSM_b2(klev),&
-          A1_CSSSM_b2(klev), A2_CSSSM_b2(klev), A3_CSSSM_b2(klev),&
-          B1_CSSSM_b2(klev), B2_CSSSM_b2(klev), C1_CSSSM_b2(klev), C2_CSSSM_b2(klev),&
-          A1_SSSSM_b2(klev), A2_SSSSM_b2(klev), A3_SSSSM_b2(klev),&
-          B1_SSSSM_b2(klev), B2_SSSSM_b2(klev), C1_SSSSM_b2(klev), C2_SSSSM_b2(klev), stat=ierr)
-        IF (ierr /= 0) CALL abort_physic('aeropt_2bands', 'pb in allocation 1',1)
-     END IF
-     
-! bande 1
-     CALL pres2lev(A1_ASSSM_b1_19, A1_ASSSM_b1, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
-     CALL pres2lev(A2_ASSSM_b1_19, A2_ASSSM_b1, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
-     CALL pres2lev(A3_ASSSM_b1_19, A3_ASSSM_b1, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
-     CALL pres2lev(B1_ASSSM_b1_19, B1_ASSSM_b1, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
-     CALL pres2lev(B2_ASSSM_b1_19, B2_ASSSM_b1, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
-     CALL pres2lev(C1_ASSSM_b1_19, C1_ASSSM_b1, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
-     CALL pres2lev(C2_ASSSM_b1_19, C2_ASSSM_b1, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
-
-     CALL pres2lev(A1_CSSSM_b1_19, A1_CSSSM_b1, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
-     CALL pres2lev(A2_CSSSM_b1_19, A2_CSSSM_b1, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
-     CALL pres2lev(A3_CSSSM_b1_19, A3_CSSSM_b1, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
-     CALL pres2lev(B1_CSSSM_b1_19, B1_CSSSM_b1, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
-     CALL pres2lev(B2_CSSSM_b1_19, B2_CSSSM_b1, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
-     CALL pres2lev(C1_CSSSM_b1_19, C1_CSSSM_b1, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
-     CALL pres2lev(C2_CSSSM_b1_19, C2_CSSSM_b1, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
-
-     CALL pres2lev(A1_SSSSM_b1_19, A1_SSSSM_b1, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
-     CALL pres2lev(A2_SSSSM_b1_19, A2_SSSSM_b1, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
-     CALL pres2lev(A3_SSSSM_b1_19, A3_SSSSM_b1, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
-     CALL pres2lev(B1_SSSSM_b1_19, B1_SSSSM_b1, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
-     CALL pres2lev(B2_SSSSM_b1_19, B2_SSSSM_b1, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
-     CALL pres2lev(C1_SSSSM_b1_19, C1_SSSSM_b1, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
-     CALL pres2lev(C2_SSSSM_b1_19, C2_SSSSM_b1, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
-
-! bande 2
-     CALL pres2lev(A1_ASSSM_b2_19, A1_ASSSM_b2, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
-     CALL pres2lev(A2_ASSSM_b2_19, A2_ASSSM_b2, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
-     CALL pres2lev(A3_ASSSM_b2_19, A3_ASSSM_b2, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
-     CALL pres2lev(B1_ASSSM_b2_19, B1_ASSSM_b2, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
-     CALL pres2lev(B2_ASSSM_b2_19, B2_ASSSM_b2, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
-     CALL pres2lev(C1_ASSSM_b2_19, C1_ASSSM_b2, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
-     CALL pres2lev(C2_ASSSM_b2_19, C2_ASSSM_b2, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
-
-     CALL pres2lev(A1_CSSSM_b2_19, A1_CSSSM_b2, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
-     CALL pres2lev(A2_CSSSM_b2_19, A2_CSSSM_b2, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
-     CALL pres2lev(A3_CSSSM_b2_19, A3_CSSSM_b2, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
-     CALL pres2lev(B1_CSSSM_b2_19, B1_CSSSM_b2, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
-     CALL pres2lev(B2_CSSSM_b2_19, B2_CSSSM_b2, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
-     CALL pres2lev(C1_CSSSM_b2_19, C1_CSSSM_b2, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
-     CALL pres2lev(C2_CSSSM_b2_19, C2_CSSSM_b2, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
-
-     CALL pres2lev(A1_SSSSM_b2_19, A1_SSSSM_b2, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
-     CALL pres2lev(A2_SSSSM_b2_19, A2_SSSSM_b2, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
-     CALL pres2lev(A3_SSSSM_b2_19, A3_SSSSM_b2, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
-     CALL pres2lev(B1_SSSSM_b2_19, B1_SSSSM_b2, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
-     CALL pres2lev(B2_SSSSM_b2_19, B2_SSSSM_b2, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
-     CALL pres2lev(C1_SSSSM_b2_19, C1_SSSSM_b2, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
-     CALL pres2lev(C2_SSSSM_b2_19, C2_SSSSM_b2, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
-
-  END IF ! firstcall
-
-  DO k=1, klev
-    DO i=1, klon
-      zrho=pplay(i,k)/t_seri(i,k)/RD    ! kg/m3
-      zdh(i,k)=pdel(i,k)/(RG*zrho)      ! m
-    ENDDO
-  ENDDO
-
-  IF (flag_aerosol .EQ. 1) THEN 
-     nb_aer = 2
-     ALLOCATE (aerosol_name(nb_aer)) 
-     aerosol_name(1) = id_ASSO4M_phy
-     aerosol_name(2) = id_CSSO4M_phy
-  ELSEIF (flag_aerosol .EQ. 2) THEN
-     nb_aer = 2
-     ALLOCATE (aerosol_name(nb_aer)) 
-     aerosol_name(1) = id_ASBCM_phy
-     aerosol_name(2) = id_AIBCM_phy
-  ELSEIF (flag_aerosol .EQ. 3) THEN 
-     nb_aer = 2
-     ALLOCATE (aerosol_name(nb_aer)) 
-     aerosol_name(1) = id_ASPOMM_phy
-     aerosol_name(2) = id_AIPOMM_phy
-  ELSEIF (flag_aerosol .EQ. 4) THEN 
-     nb_aer = 3
-     ALLOCATE (aerosol_name(nb_aer)) 
-     aerosol_name(1) = id_CSSSM_phy
-     aerosol_name(2) = id_SSSSM_phy
-     aerosol_name(3) = id_ASSSM_phy
-  ELSEIF (flag_aerosol .EQ. 5) THEN 
-     nb_aer = 1
-     ALLOCATE (aerosol_name(nb_aer)) 
-     aerosol_name(1) = id_CIDUSTM_phy
-  ELSEIF (flag_aerosol .EQ. 6) THEN 
-     nb_aer = 10
-     ALLOCATE (aerosol_name(nb_aer)) 
-     aerosol_name(1) = id_ASSO4M_phy
-     aerosol_name(2) = id_ASBCM_phy
-     aerosol_name(3) = id_AIBCM_phy
-     aerosol_name(4) = id_ASPOMM_phy
-     aerosol_name(5) = id_AIPOMM_phy
-     aerosol_name(6) = id_CSSSM_phy
-     aerosol_name(7) = id_SSSSM_phy
-     aerosol_name(8) = id_ASSSM_phy
-     aerosol_name(9) = id_CIDUSTM_phy
-     aerosol_name(10)= id_CSSO4M_phy
-  ENDIF
-
-
-  !
-  ! loop over modes, use of precalculated nmd and corresponding sigma
-  !    loop over wavelengths
-  !    for each mass species in mode
-  !      interpolate from Sext to retrieve Sext_at_gridpoint_per_species
-  !      compute optical_thickness_at_gridpoint_per_species
-
-!CDIR ON_ADB(fact_RH)
-!CDIR SHORTLOOP
-  DO n=1,nbre_RH-1
-    fact_RH(n)=1./(RH_tab(n+1)-RH_tab(n))
-  ENDDO
-   
-  DO k=1, KLEV
-!CDIR ON_ADB(fact_RH)
-    DO i=1, KLON
-      rh(i,k)=MIN(RHcl(i,k)*100.,RH_MAX)
-      RH_num(i,k) = INT( rh(i,k)/10. + 1.)
-      IF (rh(i,k).GT.85.) RH_num(i,k)=10
-      IF (rh(i,k).GT.90.) RH_num(i,k)=11
-      DELTA(i,k)=(rh(i,k)-RH_tab(RH_num(i,k)))*fact_RH(RH_num(i,k))
-    ENDDO
-  ENDDO
-
-  used_aer(:)=.FALSE.
-    
-  DO m=1,nb_aer   ! tau is only computed for each mass
-    fac=1.0
-     IF (aerosol_name(m).EQ.id_ASBCM_phy) THEN
-         soluble=.TRUE.
-         spsol=1
-         spss=0
-     ELSEIF (aerosol_name(m).EQ.id_ASPOMM_phy) THEN 
-        soluble=.TRUE.
-        spsol=2 
-        spss=0
-     ELSEIF (aerosol_name(m).EQ.id_ASSO4M_phy) THEN 
-        soluble=.TRUE.
-        spsol=3
-        spss=0
-        fac=1.375    ! (NH4)2-SO4/SO4 132/96 mass conversion factor for OD
-     ELSEIF  (aerosol_name(m).EQ.id_CSSO4M_phy) THEN
-        soluble=.TRUE.
-        spsol=4
-        spss=0
-        fac=1.375    ! (NH4)2-SO4/SO4 132/96 mass conversion factor for OD
-     ELSEIF (aerosol_name(m).EQ.id_SSSSM_phy) THEN 
-         soluble=.TRUE.
-         spsol=5
-         spss=3
-     ELSEIF (aerosol_name(m).EQ.id_CSSSM_phy) THEN 
-         soluble=.TRUE.
-         spsol=6
-         spss=2
-     ELSEIF (aerosol_name(m).EQ.id_ASSSM_phy) THEN
-         soluble=.TRUE.
-         spsol=7
-         spss=1
-     ELSEIF (aerosol_name(m).EQ.id_CIDUSTM_phy) THEN 
-         soluble=.FALSE.
-         spinsol=1
-         spss=0
-     ELSEIF  (aerosol_name(m).EQ.id_AIBCM_phy) THEN 
-         soluble=.FALSE.
-         spinsol=2
-         spss=0
-     ELSEIF (aerosol_name(m).EQ.id_AIPOMM_phy) THEN 
-         soluble=.FALSE.
-         spinsol=3
-         spss=0
-     ELSE 
-         CYCLE
-     ENDIF
-
-    id=aerosol_name(m)
-    used_aer(id)=.TRUE.
-
-    IF (soluble) THEN
-
-      IF (spss.NE.0) THEN
-
-         IF (spss.EQ.1) THEN !accumulation mode
-            DO k=1, KLEV
-!CDIR ON_ADB(A1_ASSSM_b1)
-!CDIR ON_ADB(A2_ASSSM_b1)
-!CDIR ON_ADB(A3_ASSSM_b1)
-!CDIR ON_ADB(B1_ASSSM_b1)
-!CDIR ON_ADB(B2_ASSSM_b1)
-!CDIR ON_ADB(C1_ASSSM_b1)
-!CDIR ON_ADB(C2_ASSSM_b2)
-!CDIR ON_ADB(A1_ASSSM_b2)
-!CDIR ON_ADB(A2_ASSSM_b2)
-!CDIR ON_ADB(A3_ASSSM_b2)
-!CDIR ON_ADB(B1_ASSSM_b2)
-!CDIR ON_ADB(B2_ASSSM_b2)
-!CDIR ON_ADB(C1_ASSSM_b2)
-!CDIR ON_ADB(C2_ASSSM_b2)
-
-              DO i=1, KLON
-
-                H=rh(i,k)/100
-                tmp_var=m_allaer(i,k,spsol)/1.e6*zdh(i,k)*fac
-                tmp_var_pi=m_allaer_pi(i,k,spsol)/1.e6*zdh(i,k)*fac
-
-                ! band 1
-                tau_ae2b_int=A1_ASSSM_b1(k)+A2_ASSSM_b1(k)*H+A3_ASSSM_b1(k)/(H-1.05)
-                piz_ae2b_int=1-B1_ASSSM_b1(k)-B2_ASSSM_b1(k)*H
-                cg_ae2b_int=C1_ASSSM_b1(k)+C2_ASSSM_b1(k)*H
-
-                tau_ae(i,k,id,1) = tmp_var*tau_ae2b_int
-                tau_ae_pi(i,k,id,1) =  tmp_var_pi* tau_ae2b_int
-                piz_ae(i,k,id,1) = piz_ae2b_int
-                cg_ae(i,k,id,1)= cg_ae2b_int
-                
-                !band 2
-                tau_ae2b_int=A1_ASSSM_b2(k)+A2_ASSSM_b2(k)*H+A3_ASSSM_b2(k)/(H-1.05)
-                piz_ae2b_int=1-B1_ASSSM_b2(k)-B2_ASSSM_b2(k)*H
-                cg_ae2b_int=C1_ASSSM_b2(k)+C2_ASSSM_b2(k)*H
-
-                tau_ae(i,k,id,2) = tmp_var*tau_ae2b_int
-                tau_ae_pi(i,k,id,2) =  tmp_var_pi* tau_ae2b_int
-                piz_ae(i,k,id,2) = piz_ae2b_int
-                cg_ae(i,k,id,2)= cg_ae2b_int
-
-              ENDDO
-            ENDDO
-          ENDIF
-
-          IF (spss.EQ.2) THEN !coarse mode
-            DO k=1, KLEV
-!CDIR ON_ADB(A1_CSSSM_b1)
-!CDIR ON_ADB(A2_CSSSM_b1)
-!CDIR ON_ADB(A3_CSSSM_b1)
-!CDIR ON_ADB(B1_CSSSM_b1)
-!CDIR ON_ADB(B2_CSSSM_b1)
-!CDIR ON_ADB(C1_CSSSM_b1)
-!CDIR ON_ADB(C2_CSSSM_b2)
-!CDIR ON_ADB(A1_CSSSM_b2)
-!CDIR ON_ADB(A2_CSSSM_b2)
-!CDIR ON_ADB(A3_CSSSM_b2)
-!CDIR ON_ADB(B1_CSSSM_b2)
-!CDIR ON_ADB(B2_CSSSM_b2)
-!CDIR ON_ADB(C1_CSSSM_b2)
-!CDIR ON_ADB(C2_CSSSM_b2)
-
-              DO i=1, KLON
-
-                H=rh(i,k)/100
-                tmp_var=m_allaer(i,k,spsol)/1.e6*zdh(i,k)*fac
-                tmp_var_pi=m_allaer_pi(i,k,spsol)/1.e6*zdh(i,k)*fac
-                ! band 1
-                tau_ae2b_int=A1_CSSSM_b1(k)+A2_CSSSM_b1(k)*H+A3_CSSSM_b1(k)/(H-1.05)
-                piz_ae2b_int=1-B1_CSSSM_b1(k)-B2_CSSSM_b1(k)*H
-                cg_ae2b_int=C1_CSSSM_b1(k)+C2_CSSSM_b1(k)*H
-
-                tau_ae(i,k,id,1) = tmp_var*tau_ae2b_int
-                tau_ae_pi(i,k,id,1) =  tmp_var_pi* tau_ae2b_int
-                piz_ae(i,k,id,1) = piz_ae2b_int
-                cg_ae(i,k,id,1)= cg_ae2b_int
-
-                ! band 2
-                tau_ae2b_int=A1_CSSSM_b2(k)+A2_CSSSM_b2(k)*H+A3_CSSSM_b2(k)/(H-1.05)
-                piz_ae2b_int=1-B1_CSSSM_b2(k)-B2_CSSSM_b2(k)*H
-                cg_ae2b_int=C1_CSSSM_b2(k)+C2_CSSSM_b2(k)*H
-
-                tau_ae(i,k,id,2) = tmp_var*tau_ae2b_int
-                tau_ae_pi(i,k,id,2) =  tmp_var_pi* tau_ae2b_int
-                piz_ae(i,k,id,2) = piz_ae2b_int
-                cg_ae(i,k,id,2)= cg_ae2b_int
-
-             ENDDO
-           ENDDO
-         ENDIF
-
-         IF (spss.EQ.3) THEN !super coarse mode
-            DO k=1, KLEV
-!CDIR ON_ADB(A1_SSSSM_b1)
-!CDIR ON_ADB(A2_SSSSM_b1)
-!CDIR ON_ADB(A3_SSSSM_b1)
-!CDIR ON_ADB(B1_SSSSM_b1)
-!CDIR ON_ADB(B2_SSSSM_b1)
-!CDIR ON_ADB(C1_SSSSM_b1)
-!CDIR ON_ADB(C2_SSSSM_b2)
-!CDIR ON_ADB(A1_SSSSM_b2)
-!CDIR ON_ADB(A2_SSSSM_b2)
-!CDIR ON_ADB(A3_SSSSM_b2)
-!CDIR ON_ADB(B1_SSSSM_b2)
-!CDIR ON_ADB(B2_SSSSM_b2)
-!CDIR ON_ADB(C1_SSSSM_b2)
-!CDIR ON_ADB(C2_SSSSM_b2)
-
-              DO i=1, KLON
-
-                H=rh(i,k)/100
-                tmp_var=m_allaer(i,k,spsol)/1.e6*zdh(i,k)*fac
-                tmp_var_pi=m_allaer_pi(i,k,spsol)/1.e6*zdh(i,k)*fac
-
-                ! band 1 
-                tau_ae2b_int=A1_SSSSM_b1(k)+A2_SSSSM_b1(k)*H+A3_SSSSM_b1(k)/(H-1.05)
-                piz_ae2b_int=1-B1_SSSSM_b1(k)-B2_SSSSM_b1(k)*H
-                cg_ae2b_int=C1_SSSSM_b1(k)+C2_SSSSM_b1(k)*H
-
-                tau_ae(i,k,id,1) = tmp_var*tau_ae2b_int
-                tau_ae_pi(i,k,id,1) =  tmp_var_pi* tau_ae2b_int
-                piz_ae(i,k,id,1) = piz_ae2b_int
-                cg_ae(i,k,id,1)= cg_ae2b_int
-
-                ! band 2
-                tau_ae2b_int=A1_SSSSM_b2(k)+A2_SSSSM_b2(k)*H+A3_SSSSM_b2(k)/(H-1.05)
-                piz_ae2b_int=1-B1_SSSSM_b2(k)-B2_SSSSM_b2(k)*H
-                cg_ae2b_int=C1_SSSSM_b2(k)+C2_SSSSM_b2(k)*H
-
-                tau_ae(i,k,id,2) = tmp_var*tau_ae2b_int
-                tau_ae_pi(i,k,id,2) =  tmp_var_pi* tau_ae2b_int
-                piz_ae(i,k,id,2) = piz_ae2b_int
-                cg_ae(i,k,id,2)= cg_ae2b_int
-
-              ENDDO
-            ENDDO
-          ENDIF
-
-        ELSE
-                        
-!CDIR ON_ADB(alpha_aers_2bands)
-!CDIR ON_ADB(piz_aers_2bands)
-!CDIR ON_ADB(cg_aers_2bands)
-          DO k=1, KLEV
-            DO i=1, KLON
-              tmp_var=m_allaer(i,k,spsol)/1.e6*zdh(i,k)*fac
-              tmp_var_pi=m_allaer_pi(i,k,spsol)/1.e6*zdh(i,k)*fac
-!CDIR UNROLL=nbands
-              DO inu=1,nbands
-
-                tau_ae2b_int= alpha_aers_2bands(RH_num(i,k),inu,spsol)+ & 
-                              DELTA(i,k)* (alpha_aers_2bands(RH_num(i,k)+1,inu,spsol) - & 
-                              alpha_aers_2bands(RH_num(i,k),inu,spsol))
-                      
-                piz_ae2b_int = piz_aers_2bands(RH_num(i,k),inu,spsol) + & 
-                               DELTA(i,k)* (piz_aers_2bands(RH_num(i,k)+1,inu,spsol) - & 
-                               piz_aers_2bands(RH_num(i,k),inu,spsol))
-                      
-                cg_ae2b_int = cg_aers_2bands(RH_num(i,k),inu,spsol) + & 
-                              DELTA(i,k)* (cg_aers_2bands(RH_num(i,k)+1,inu,spsol) - & 
-                              cg_aers_2bands(RH_num(i,k),inu,spsol))
-
-                tau_ae(i,k,id,inu) = tmp_var*tau_ae2b_int
-                tau_ae_pi(i,k,id,inu) =  tmp_var_pi* tau_ae2b_int
-                piz_ae(i,k,id,inu) = piz_ae2b_int
-                cg_ae(i,k,id,inu)= cg_ae2b_int
-                         
-              ENDDO
-            ENDDO
-          ENDDO
-        
-        ENDIF                     
-
-      ELSE                                                    ! For all aerosol insoluble components
-
-!CDIR ON_ADB(alpha_aers_2bands)
-!CDIR ON_ADB(piz_aers_2bands)
-!CDIR ON_ADB(cg_aers_2bands)
-        DO k=1, KLEV
-          DO i=1, KLON
-            tmp_var=m_allaer(i,k,naero_soluble+spinsol)/1.e6*zdh(i,k)*fac
-            tmp_var_pi=m_allaer_pi(i,k,naero_soluble+spinsol)/1.e6*zdh(i,k)*fac
-!CDIR UNROLL=nbands
-            DO inu=1,nbands
-              tau_ae2b_int = alpha_aeri_2bands(inu,spinsol)
-              piz_ae2b_int = piz_aeri_2bands(inu,spinsol)
-              cg_ae2b_int = cg_aeri_2bands(inu,spinsol) 
-
-              tau_ae(i,k,id,inu) = tmp_var*tau_ae2b_int
-              tau_ae_pi(i,k,id,inu) = tmp_var_pi*tau_ae2b_int
-              piz_ae(i,k,id,inu) = piz_ae2b_int
-              cg_ae(i,k,id,inu)= cg_ae2b_int
-            ENDDO
-          ENDDO
-        ENDDO
-
-      ENDIF ! soluble
-
-    ENDDO  ! nb_aer  
-
-!correction bug OB
-!  DO m=1,nb_aer   
-  DO m=1,naero_tot   
-    IF (.NOT. used_aer(m)) THEN
-      tau_ae(:,:,m,:)=0.
-      tau_ae_pi(:,:,m,:)=0.
-      piz_ae(:,:,m,:)=0.
-      cg_ae(:,:,m,:)=0.
-    ENDIF
-  ENDDO
-
-  DO inu=1, nbands
-
-    !!DO mrfspecies=1,naero_grp
-    DO mrfspecies=2,3    !--only deal with total and natural aerosols
-
-      IF (mrfspecies .EQ. 2) THEN             ! = total aerosol AER	 
-
-        DO k=1, KLEV
-          DO i=1, KLON
-            tau_allaer(i,k,mrfspecies,inu)=tau_ae(i,k,id_ASSO4M_phy,inu)+tau_ae(i,k,id_CSSO4M_phy,inu)+ &
-                                           tau_ae(i,k,id_ASBCM_phy,inu)+tau_ae(i,k,id_AIBCM_phy,inu)+   &
-                                           tau_ae(i,k,id_ASPOMM_phy,inu)+tau_ae(i,k,id_AIPOMM_phy,inu)+ &
-                                           tau_ae(i,k,id_ASSSM_phy,inu)+tau_ae(i,k,id_CSSSM_phy,inu)+   &
-                                           tau_ae(i,k,id_SSSSM_phy,inu)+ tau_ae(i,k,id_CIDUSTM_phy,inu)
-            tau_allaer(i,k,mrfspecies,inu)=MAX(tau_allaer(i,k,mrfspecies,inu),1e-5)
-                 
-            piz_allaer(i,k,mrfspecies,inu)=(tau_ae(i,k,id_ASSO4M_phy,inu)*piz_ae(i,k,id_ASSO4M_phy,inu)+ &
-                                            tau_ae(i,k,id_CSSO4M_phy,inu)*piz_ae(i,k,id_CSSO4M_phy,inu)+ &
-                                            tau_ae(i,k,id_ASBCM_phy,inu)*piz_ae(i,k,id_ASBCM_phy,inu)+   &
-                                            tau_ae(i,k,id_AIBCM_phy,inu)*piz_ae(i,k,id_AIBCM_phy,inu)+   &
-                                            tau_ae(i,k,id_ASPOMM_phy,inu)*piz_ae(i,k,id_ASPOMM_phy,inu)+ &
-                                            tau_ae(i,k,id_AIPOMM_phy,inu)*piz_ae(i,k,id_AIPOMM_phy,inu)+ &
-                                            tau_ae(i,k,id_ASSSM_phy,inu)*piz_ae(i,k,id_ASSSM_phy,inu)+   &
-                                            tau_ae(i,k,id_CSSSM_phy,inu)*piz_ae(i,k,id_CSSSM_phy,inu)+   &
-                                            tau_ae(i,k,id_SSSSM_phy,inu)*piz_ae(i,k,id_SSSSM_phy,inu)+   &
-                                            tau_ae(i,k,id_CIDUSTM_phy,inu)*piz_ae(i,k,id_CIDUSTM_phy,inu)) &
-                                            /tau_allaer(i,k,mrfspecies,inu)
-            piz_allaer(i,k,mrfspecies,inu)=MAX(piz_allaer(i,k,mrfspecies,inu),0.1)
-
-            cg_allaer(i,k,mrfspecies,inu)=(tau_ae(i,k,id_ASSO4M_phy,inu)* &
-              piz_ae(i,k,id_ASSO4M_phy,inu)*cg_ae(i,k,id_ASSO4M_phy,inu)+ &
-              tau_ae(i,k,id_CSSO4M_phy,inu)*piz_ae(i,k,id_CSSO4M_phy,inu)* &
-              cg_ae(i,k,id_CSSO4M_phy,inu)+ &
-              tau_ae(i,k,id_ASBCM_phy,inu)*piz_ae(i,k,id_ASBCM_phy,inu)* &
-              cg_ae(i,k,id_ASBCM_phy,inu)+ &
-              tau_ae(i,k,id_AIBCM_phy,inu)*piz_ae(i,k,id_AIBCM_phy,inu)* &
-              cg_ae(i,k,id_AIBCM_phy,inu)+ &
-              tau_ae(i,k,id_ASPOMM_phy,inu)*piz_ae(i,k,id_ASPOMM_phy,inu)* &
-              cg_ae(i,k,id_ASPOMM_phy,inu)+ &
-              tau_ae(i,k,id_AIPOMM_phy,inu)*piz_ae(i,k,id_AIPOMM_phy,inu)* &
-              cg_ae(i,k,id_AIPOMM_phy,inu)+ &
-              tau_ae(i,k,id_ASSSM_phy,inu)*piz_ae(i,k,id_ASSSM_phy,inu)* &
-              cg_ae(i,k,id_ASSSM_phy,inu)+ &
-              tau_ae(i,k,id_CSSSM_phy,inu)*piz_ae(i,k,id_CSSSM_phy,inu)* &
-              cg_ae(i,k,id_CSSSM_phy,inu)+ &
-              tau_ae(i,k,id_SSSSM_phy,inu)*piz_ae(i,k,id_SSSSM_phy,inu)* &
-              cg_ae(i,k,id_SSSSM_phy,inu)+ &
-              tau_ae(i,k,id_CIDUSTM_phy,inu)*piz_ae(i,k,id_CIDUSTM_phy,inu)* &
-              cg_ae(i,k,id_CIDUSTM_phy,inu))/ &
-              (tau_allaer(i,k,mrfspecies,inu)*piz_allaer(i,k,mrfspecies,inu))
-          ENDDO    
-        ENDDO 
-
-      ELSEIF (mrfspecies .EQ. 3) THEN             ! = natural aerosol NAT
-
-        DO k=1, KLEV
-          DO i=1, KLON
-
-              tau_allaer(i,k,mrfspecies,inu)=tau_ae_pi(i,k,id_ASSO4M_phy,inu)+ &
-                      tau_ae_pi(i,k,id_CSSO4M_phy,inu)+ &
-                      tau_ae_pi(i,k,id_ASBCM_phy,inu)+  &
-                      tau_ae_pi(i,k,id_AIBCM_phy,inu)+  &
-                      tau_ae_pi(i,k,id_ASPOMM_phy,inu)+ &
-                      tau_ae_pi(i,k,id_AIPOMM_phy,inu)+ &
-                      tau_ae_pi(i,k,id_ASSSM_phy,inu)+  &
-                      tau_ae_pi(i,k,id_CSSSM_phy,inu)+  &
-                      tau_ae_pi(i,k,id_SSSSM_phy,inu)+  &
-                      tau_ae_pi(i,k,id_CIDUSTM_phy,inu)
-              tau_allaer(i,k,mrfspecies,inu)=MAX(tau_allaer(i,k,mrfspecies,inu),1e-5)
-
-              piz_allaer(i,k,mrfspecies,inu)=(tau_ae_pi(i,k,id_ASSO4M_phy,inu)*piz_ae(i,k,id_ASSO4M_phy,inu)+ &
-                      tau_ae_pi(i,k,id_CSSO4M_phy,inu)*piz_ae(i,k,id_CSSO4M_phy,inu)+ &
-                      tau_ae_pi(i,k,id_ASBCM_phy,inu)*piz_ae(i,k,id_ASBCM_phy,inu)+   &
-                      tau_ae_pi(i,k,id_AIBCM_phy,inu)*piz_ae(i,k,id_AIBCM_phy,inu)+   &
-                      tau_ae_pi(i,k,id_ASPOMM_phy,inu)*piz_ae(i,k,id_ASPOMM_phy,inu)+ &
-                      tau_ae_pi(i,k,id_AIPOMM_phy,inu)*piz_ae(i,k,id_AIPOMM_phy,inu)+ &
-                      tau_ae_pi(i,k,id_ASSSM_phy,inu)*piz_ae(i,k,id_ASSSM_phy,inu)+   &
-                      tau_ae_pi(i,k,id_CSSSM_phy,inu)*piz_ae(i,k,id_CSSSM_phy,inu)+   &
-                      tau_ae_pi(i,k,id_SSSSM_phy,inu)*piz_ae(i,k,id_SSSSM_phy,inu)+   &
-                      tau_ae_pi(i,k,id_CIDUSTM_phy,inu)*piz_ae(i,k,id_CIDUSTM_phy,inu)) &
-                      /tau_allaer(i,k,mrfspecies,inu)
-              piz_allaer(i,k,mrfspecies,inu)=MAX(piz_allaer(i,k,mrfspecies,inu),0.1)
-
-              cg_allaer(i,k,mrfspecies,inu)=(&
-                      tau_ae_pi(i,k,id_ASSO4M_phy,inu)*piz_ae(i,k,id_ASSO4M_phy,inu)*cg_ae(i,k,id_ASSO4M_phy,inu)+ &
-                      tau_ae_pi(i,k,id_CSSO4M_phy,inu)*piz_ae(i,k,id_CSSO4M_phy,inu)*cg_ae(i,k,id_CSSO4M_phy,inu)+ &
-                      tau_ae_pi(i,k,id_ASBCM_phy,inu)*piz_ae(i,k,id_ASBCM_phy,inu)*cg_ae(i,k,id_ASBCM_phy,inu)+ &
-                      tau_ae_pi(i,k,id_AIBCM_phy,inu)*piz_ae(i,k,id_AIBCM_phy,inu)*cg_ae(i,k,id_AIBCM_phy,inu)+ &
-                      tau_ae_pi(i,k,id_ASPOMM_phy,inu)*piz_ae(i,k,id_ASPOMM_phy,inu)*cg_ae(i,k,id_ASPOMM_phy,inu)+ &
-                      tau_ae_pi(i,k,id_AIPOMM_phy,inu)*piz_ae(i,k,id_AIPOMM_phy,inu)*cg_ae(i,k,id_AIPOMM_phy,inu)+ &
-                      tau_ae_pi(i,k,id_ASSSM_phy,inu)*piz_ae(i,k,id_ASSSM_phy,inu)*cg_ae(i,k,id_ASSSM_phy,inu)+ &
-                      tau_ae_pi(i,k,id_CSSSM_phy,inu)*piz_ae(i,k,id_CSSSM_phy,inu)*cg_ae(i,k,id_CSSSM_phy,inu)+ &
-                      tau_ae_pi(i,k,id_SSSSM_phy,inu)*piz_ae(i,k,id_SSSSM_phy,inu)*cg_ae(i,k,id_SSSSM_phy,inu)+ &
-                      tau_ae_pi(i,k,id_CIDUSTM_phy,inu)*piz_ae(i,k,id_CIDUSTM_phy,inu)*&
-                      cg_ae(i,k,id_CIDUSTM_phy,inu))/ &
-                      (tau_allaer(i,k,mrfspecies,inu)*piz_allaer(i,k,mrfspecies,inu))
-          ENDDO
-        ENDDO
-                   
-      ELSEIF (mrfspecies .EQ. 4) THEN             ! = BC
-
-        DO k=1, KLEV
-          DO i=1, KLON
-            tau_allaer(i,k,mrfspecies,inu)=tau_ae(i,k,id_ASBCM_phy,inu)+tau_ae(i,k,id_AIBCM_phy,inu)
-            tau_allaer(i,k,mrfspecies,inu)=MAX(tau_allaer(i,k,mrfspecies,inu),1e-5)
-            piz_allaer(i,k,mrfspecies,inu)=(tau_ae(i,k,id_ASBCM_phy,inu)*piz_ae(i,k,id_ASBCM_phy,inu) &
-                      +tau_ae(i,k,id_AIBCM_phy,inu)*piz_ae(i,k,id_AIBCM_phy,inu))/ &
-                      tau_allaer(i,k,mrfspecies,inu)
-            piz_allaer(i,k,mrfspecies,inu)=MAX(piz_allaer(i,k,mrfspecies,inu),0.1)
-            cg_allaer(i,k,mrfspecies,inu)=(tau_ae(i,k,id_ASBCM_phy,inu)*piz_ae(i,k,id_ASBCM_phy,inu) *cg_ae(i,k,id_ASBCM_phy,inu)&
-                      +tau_ae(i,k,id_AIBCM_phy,inu)*piz_ae(i,k,id_AIBCM_phy,inu)*cg_ae(i,k,id_AIBCM_phy,inu))/ &
-                      (tau_allaer(i,k,mrfspecies,inu)*piz_allaer(i,k,mrfspecies,inu))
-          ENDDO
-        ENDDO
-              
-      ELSEIF (mrfspecies .EQ. 5) THEN             ! = SO4
-
-        DO k=1, KLEV
-          DO i=1, KLON
-            tau_allaer(i,k,mrfspecies,inu)=tau_ae(i,k,id_ASSO4M_phy,inu)+tau_ae(i,k,id_CSSO4M_phy,inu)
-            tau_allaer(i,k,mrfspecies,inu)=MAX(tau_allaer(i,k,mrfspecies,inu),1e-5)
-            piz_allaer(i,k,mrfspecies,inu)=(tau_ae(i,k,id_CSSO4M_phy,inu)*piz_ae(i,k,id_CSSO4M_phy,inu) &
-                      +tau_ae(i,k,id_ASSO4M_phy,inu)*piz_ae(i,k,id_ASSO4M_phy,inu))/ &
-                      tau_allaer(i,k,mrfspecies,inu)
-            piz_allaer(i,k,mrfspecies,inu)=MAX(piz_allaer(i,k,mrfspecies,inu),0.1)
-            cg_allaer(i,k,mrfspecies,inu)=(tau_ae(i,k,id_CSSO4M_phy,inu)* &
-            piz_ae(i,k,id_CSSO4M_phy,inu) *cg_ae(i,k,id_CSSO4M_phy,inu)&
-            +tau_ae(i,k,id_ASSO4M_phy,inu)*piz_ae(i,k,id_ASSO4M_phy,inu)* &
-            cg_ae(i,k,id_ASSO4M_phy,inu))/ &
-            (tau_allaer(i,k,mrfspecies,inu)*piz_allaer(i,k,mrfspecies,inu))
-          ENDDO
-        ENDDO
-
-      ELSEIF (mrfspecies .EQ. 6) THEN             ! = POM
-
-        DO k=1, KLEV
-          DO i=1, KLON
-            tau_allaer(i,k,mrfspecies,inu)=tau_ae(i,k,id_ASPOMM_phy,inu)+tau_ae(i,k,id_AIPOMM_phy,inu)
-            tau_allaer(i,k,mrfspecies,inu)=MAX(tau_allaer(i,k,mrfspecies,inu),1e-5)
-            piz_allaer(i,k,mrfspecies,inu)=(tau_ae(i,k,id_ASPOMM_phy,inu)*piz_ae(i,k,id_ASPOMM_phy,inu) &
-                      +tau_ae(i,k,id_AIPOMM_phy,inu)*piz_ae(i,k,id_AIPOMM_phy,inu))/ &
-                      tau_allaer(i,k,mrfspecies,inu)
-            piz_allaer(i,k,mrfspecies,inu)=MAX(piz_allaer(i,k,mrfspecies,inu),0.1)
-            cg_allaer(i,k,mrfspecies,inu)=(tau_ae(i,k,id_ASPOMM_phy,inu)*piz_ae(i,k,id_ASPOMM_phy,inu)*cg_ae(i,k,id_ASPOMM_phy,inu)&
-                      +tau_ae(i,k,id_AIPOMM_phy,inu)*piz_ae(i,k,id_AIPOMM_phy,inu)*cg_ae(i,k,id_AIPOMM_phy,inu))/ &
-                      (tau_allaer(i,k,mrfspecies,inu)*piz_allaer(i,k,mrfspecies,inu))
-          ENDDO
-        ENDDO
-              
-      ELSEIF (mrfspecies .EQ. 7) THEN             ! = DUST
-
-        DO k=1, KLEV
-          DO i=1, KLON
-            tau_allaer(i,k,mrfspecies,inu)=tau_ae(i,k,id_CIDUSTM_phy,inu)
-            tau_allaer(i,k,mrfspecies,inu)=MAX(tau_allaer(i,k,mrfspecies,inu),1e-5)
-            piz_allaer(i,k,mrfspecies,inu)=piz_ae(i,k,id_CIDUSTM_phy,inu)
-            cg_allaer(i,k,mrfspecies,inu)=cg_ae(i,k,id_CIDUSTM_phy,inu)
-          ENDDO
-        ENDDO
-
-      ELSEIF (mrfspecies .EQ. 8) THEN             ! = SS
-
-        DO k=1, KLEV
-          DO i=1, KLON
-            tau_allaer(i,k,mrfspecies,inu)=tau_ae(i,k,id_ASSSM_phy,inu)+tau_ae(i,k,id_CSSSM_phy,inu)+tau_ae(i,k,id_SSSSM_phy,inu)
-            tau_allaer(i,k,mrfspecies,inu)=MAX(tau_allaer(i,k,mrfspecies,inu),1e-5)
-            piz_allaer(i,k,mrfspecies,inu)=(tau_ae(i,k,id_ASSSM_phy,inu)*piz_ae(i,k,id_ASSSM_phy,inu) &
-                    +tau_ae(i,k,id_CSSSM_phy,inu)*piz_ae(i,k,id_CSSSM_phy,inu) &
-                    +tau_ae(i,k,id_SSSSM_phy,inu)*piz_ae(i,k,id_SSSSM_phy,inu))/ &
-                    tau_allaer(i,k,mrfspecies,inu)
-            piz_allaer(i,k,mrfspecies,inu)=MAX(piz_allaer(i,k,mrfspecies,inu),0.1)
-            cg_allaer(i,k,mrfspecies,inu)=(tau_ae(i,k,id_ASSSM_phy,inu)*piz_ae(i,k,id_ASSSM_phy,inu) *cg_ae(i,k,id_ASSSM_phy,inu)&
-                    +tau_ae(i,k,id_CSSSM_phy,inu)*piz_ae(i,k,id_CSSSM_phy,inu)*cg_ae(i,k,id_CSSSM_phy,inu) &
-                    +tau_ae(i,k,id_SSSSM_phy,inu)*piz_ae(i,k,id_SSSSM_phy,inu)*cg_ae(i,k,id_SSSSM_phy,inu))/ &
-                    (tau_allaer(i,k,mrfspecies,inu)*piz_allaer(i,k,mrfspecies,inu))
-          ENDDO
-        ENDDO
-      
-      ELSEIF (mrfspecies .EQ. 9) THEN             ! = NO3
-      
-        DO k=1, KLEV
-          DO i=1, KLON
-            tau_allaer(i,k,mrfspecies,inu)=0.   ! preliminary
-            piz_allaer(i,k,mrfspecies,inu)=0.
-            cg_allaer(i,k,mrfspecies,inu)=0.
-          ENDDO
-        ENDDO
-      
-      ELSE
-
-        DO k=1, KLEV
-          DO i=1, KLON
-            tau_allaer(i,k,mrfspecies,inu)=0.  
-            piz_allaer(i,k,mrfspecies,inu)=0.
-            cg_allaer(i,k,mrfspecies,inu)=0.
-          ENDDO
-        ENDDO
-           
-      ENDIF
-
-    ENDDO
-  ENDDO
-
-  DEALLOCATE(aerosol_name) 
-
-END SUBROUTINE AEROPT_2BANDS
Index: /LMDZ6/trunk/libf/phylmd/aeropt_2bands.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/aeropt_2bands.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/aeropt_2bands.f90	(revision 5268)
@@ -0,0 +1,1130 @@
+!
+! $Id$
+!
+SUBROUTINE AEROPT_2BANDS( &
+     pdel, m_allaer, delt, RHcl, &
+     tau_allaer, piz_allaer, &
+     cg_allaer, m_allaer_pi, &
+     flag_aerosol, pplay, t_seri, presnivs)
+
+  USE dimphy
+  USE aero_mod
+  USE pres2lev_mod
+
+  !    Yves Balkanski le 12 avril 2006
+  !    Celine Deandreis
+  !    Anne Cozic Avril 2009
+  !    a partir d'une sous-routine de Johannes Quaas pour les sulfates
+  !
+  IMPLICIT NONE
+
+  INCLUDE "YOMCST.h"
+
+  !
+  ! Input arguments:
+  !
+  REAL, DIMENSION(klon,klev),     INTENT(in)  :: pdel
+  REAL,                           INTENT(in)  :: delt
+  REAL, DIMENSION(klon,klev,naero_tot),   INTENT(in)  :: m_allaer
+  REAL, DIMENSION(klon,klev,naero_tot),   INTENT(in)  :: m_allaer_pi
+  REAL, DIMENSION(klon,klev),     INTENT(in)  :: RHcl       ! humidite relative ciel clair
+  INTEGER,                        INTENT(in)  :: flag_aerosol
+  REAL, DIMENSION(klon,klev),     INTENT(in)  :: pplay
+  REAL, DIMENSION(klon,klev),     INTENT(in)  :: t_seri
+  REAL, DIMENSION(klev),          INTENT(in)  :: presnivs
+  !
+  ! Output arguments:
+  !
+  REAL, DIMENSION(klon,klev,naero_grp,nbands), INTENT(out) :: tau_allaer ! epaisseur optique aerosol
+  REAL, DIMENSION(klon,klev,naero_grp,nbands), INTENT(out) :: piz_allaer ! single scattering albedo aerosol
+  REAL, DIMENSION(klon,klev,naero_grp,nbands), INTENT(out) :: cg_allaer  ! asymmetry parameter aerosol
+
+  !
+  ! Local
+  !
+  REAL, DIMENSION(klon,klev,naero_tot,nbands) ::  tau_ae
+  REAL, DIMENSION(klon,klev,naero_tot,nbands) ::  tau_ae_pi
+  REAL, DIMENSION(klon,klev,naero_tot,nbands) ::  piz_ae
+  REAL, DIMENSION(klon,klev,naero_tot,nbands) ::  cg_ae
+  LOGICAL ::  soluble
+  INTEGER :: i, k,n, ierr, inu, m, mrfspecies
+  INTEGER :: spsol, spinsol, spss
+  INTEGER :: RH_num(klon,klev)
+  INTEGER, PARAMETER :: nb_level=19 ! number of vertical levels in DATA
+
+  INTEGER, PARAMETER :: nbre_RH=12
+  INTEGER, PARAMETER :: naero_soluble=7    ! 1- BC soluble; 2- POM soluble; 3- SO4. acc. 4- SO4 coarse
+                                           ! 5- seasalt super coarse  6- seasalt coarse   7- seasalt acc.
+  INTEGER, PARAMETER :: naero_insoluble=3  ! 1- Dust; 2- BC insoluble; 3- POM insoluble
+  LOGICAL, SAVE :: firstcall=.TRUE. 
+!$OMP THREADPRIVATE(firstcall)
+
+! Coefficient optiques sur 19 niveaux
+  REAL, SAVE, DIMENSION(nb_level) :: presnivs_19  ! Pression milieux couche pour 19 niveaux (nb_level)
+!$OMP THREADPRIVATE(presnivs_19)
+
+  REAL, SAVE, DIMENSION(nb_level) :: A1_ASSSM_b1_19, A2_ASSSM_b1_19, A3_ASSSM_b1_19,&
+          B1_ASSSM_b1_19, B2_ASSSM_b1_19, C1_ASSSM_b1_19, C2_ASSSM_b1_19,&
+          A1_CSSSM_b1_19, A2_CSSSM_b1_19, A3_CSSSM_b1_19,&
+          B1_CSSSM_b1_19, B2_CSSSM_b1_19, C1_CSSSM_b1_19, C2_CSSSM_b1_19,&
+          A1_SSSSM_b1_19, A2_SSSSM_b1_19, A3_SSSSM_b1_19,&
+          B1_SSSSM_b1_19, B2_SSSSM_b1_19, C1_SSSSM_b1_19, C2_SSSSM_b1_19,&
+          A1_ASSSM_b2_19, A2_ASSSM_b2_19, A3_ASSSM_b2_19,&
+          B1_ASSSM_b2_19, B2_ASSSM_b2_19, C1_ASSSM_b2_19, C2_ASSSM_b2_19,&
+          A1_CSSSM_b2_19, A2_CSSSM_b2_19, A3_CSSSM_b2_19,&
+          B1_CSSSM_b2_19, B2_CSSSM_b2_19, C1_CSSSM_b2_19, C2_CSSSM_b2_19,&
+          A1_SSSSM_b2_19, A2_SSSSM_b2_19, A3_SSSSM_b2_19,&
+          B1_SSSSM_b2_19, B2_SSSSM_b2_19, C1_SSSSM_b2_19, C2_SSSSM_b2_19
+!$OMP THREADPRIVATE(A1_ASSSM_b1_19, A2_ASSSM_b1_19, A3_ASSSM_b1_19)
+!$OMP THREADPRIVATE(B1_ASSSM_b1_19, B2_ASSSM_b1_19, C1_ASSSM_b1_19, C2_ASSSM_b1_19)
+!$OMP THREADPRIVATE(A1_CSSSM_b1_19, A2_CSSSM_b1_19, A3_CSSSM_b1_19)
+!$OMP THREADPRIVATE(B1_CSSSM_b1_19, B2_CSSSM_b1_19, C1_CSSSM_b1_19, C2_CSSSM_b1_19)
+!$OMP THREADPRIVATE(A1_SSSSM_b1_19, A2_SSSSM_b1_19, A3_SSSSM_b1_19)
+!$OMP THREADPRIVATE(B1_SSSSM_b1_19, B2_SSSSM_b1_19, C1_SSSSM_b1_19, C2_SSSSM_b1_19)
+!$OMP THREADPRIVATE(A1_ASSSM_b2_19, A2_ASSSM_b2_19, A3_ASSSM_b2_19)
+!$OMP THREADPRIVATE(B1_ASSSM_b2_19, B2_ASSSM_b2_19, C1_ASSSM_b2_19, C2_ASSSM_b2_19)
+!$OMP THREADPRIVATE(A1_CSSSM_b2_19, A2_CSSSM_b2_19, A3_CSSSM_b2_19)
+!$OMP THREADPRIVATE(B1_CSSSM_b2_19, B2_CSSSM_b2_19, C1_CSSSM_b2_19, C2_CSSSM_b2_19)
+!$OMP THREADPRIVATE(A1_SSSSM_b2_19, A2_SSSSM_b2_19, A3_SSSSM_b2_19)
+!$OMP THREADPRIVATE(B1_SSSSM_b2_19, B2_SSSSM_b2_19, C1_SSSSM_b2_19, C2_SSSSM_b2_19)
+
+
+! Coefficient optiques interpole sur le nombre de niveau du modele
+  REAL, ALLOCATABLE, DIMENSION(:), SAVE :: &
+          A1_ASSSM_b1, A2_ASSSM_b1, A3_ASSSM_b1,&
+          B1_ASSSM_b1, B2_ASSSM_b1, C1_ASSSM_b1, C2_ASSSM_b1,&
+          A1_CSSSM_b1, A2_CSSSM_b1, A3_CSSSM_b1,&
+          B1_CSSSM_b1, B2_CSSSM_b1, C1_CSSSM_b1, C2_CSSSM_b1,&
+          A1_SSSSM_b1, A2_SSSSM_b1, A3_SSSSM_b1,&
+          B1_SSSSM_b1, B2_SSSSM_b1, C1_SSSSM_b1, C2_SSSSM_b1,&
+          A1_ASSSM_b2, A2_ASSSM_b2, A3_ASSSM_b2,&
+          B1_ASSSM_b2, B2_ASSSM_b2, C1_ASSSM_b2, C2_ASSSM_b2,&
+          A1_CSSSM_b2, A2_CSSSM_b2, A3_CSSSM_b2,&
+          B1_CSSSM_b2, B2_CSSSM_b2, C1_CSSSM_b2, C2_CSSSM_b2,&
+          A1_SSSSM_b2, A2_SSSSM_b2, A3_SSSSM_b2,&
+          B1_SSSSM_b2, B2_SSSSM_b2, C1_SSSSM_b2, C2_SSSSM_b2
+!$OMP THREADPRIVATE(A1_ASSSM_b1, A2_ASSSM_b1, A3_ASSSM_b1)
+!$OMP THREADPRIVATE(B1_ASSSM_b1, B2_ASSSM_b1, C1_ASSSM_b1, C2_ASSSM_b1)
+!$OMP THREADPRIVATE(A1_CSSSM_b1, A2_CSSSM_b1, A3_CSSSM_b1)
+!$OMP THREADPRIVATE(B1_CSSSM_b1, B2_CSSSM_b1, C1_CSSSM_b1, C2_CSSSM_b1)
+!$OMP THREADPRIVATE(A1_SSSSM_b1, A2_SSSSM_b1, A3_SSSSM_b1)
+!$OMP THREADPRIVATE(B1_SSSSM_b1, B2_SSSSM_b1, C1_SSSSM_b1, C2_SSSSM_b1)
+!$OMP THREADPRIVATE(A1_ASSSM_b2, A2_ASSSM_b2, A3_ASSSM_b2)
+!$OMP THREADPRIVATE(B1_ASSSM_b2, B2_ASSSM_b2, C1_ASSSM_b2, C2_ASSSM_b2)
+!$OMP THREADPRIVATE(A1_CSSSM_b2, A2_CSSSM_b2, A3_CSSSM_b2)
+!$OMP THREADPRIVATE(B1_CSSSM_b2, B2_CSSSM_b2, C1_CSSSM_b2, C2_CSSSM_b2)
+!$OMP THREADPRIVATE(A1_SSSSM_b2, A2_SSSSM_b2, A3_SSSSM_b2)
+!$OMP THREADPRIVATE(B1_SSSSM_b2, B2_SSSSM_b2, C1_SSSSM_b2, C2_SSSSM_b2)
+  
+  REAL,PARAMETER :: RH_tab(nbre_RH)=(/0.,10.,20.,30.,40.,50.,60.,70.,80.,85.,90.,95./)
+  REAL, PARAMETER :: RH_MAX=95.
+  REAL:: DELTA(klon,klev), rh(klon,klev), H
+  REAL:: tau_ae2b_int   ! Intermediate computation of epaisseur optique aerosol
+  REAL:: piz_ae2b_int   ! Intermediate computation of Single scattering albedo
+  REAL:: cg_ae2b_int    ! Intermediate computation of Assymetry parameter
+  REAL :: Fact_RH(nbre_RH)
+  REAL :: zrho
+  REAL :: fac
+  REAL :: zdh(klon,klev) 
+  INTEGER, ALLOCATABLE, DIMENSION(:)   :: aerosol_name
+  INTEGER :: nb_aer
+
+  !
+  ! Proprietes optiques
+  !
+  REAL:: alpha_aers_2bands(nbre_RH,nbands,naero_soluble)   !--unit m2/g SO4
+  REAL:: alpha_aeri_2bands(nbands,naero_insoluble)
+  REAL:: cg_aers_2bands(nbre_RH,nbands,naero_soluble)      !--unit 
+  REAL:: cg_aeri_2bands(nbands,naero_insoluble)
+  REAL:: piz_aers_2bands(nbre_RH,nbands,naero_soluble)     !-- unit
+  REAL:: piz_aeri_2bands(nbands,naero_insoluble)           !-- unit
+
+  INTEGER :: id
+  LOGICAL :: used_aer(naero_tot)
+  REAL :: tmp_var, tmp_var_pi
+
+  DATA presnivs_19/&
+       100426.5,  98327.6, 95346.5, 90966.8, 84776.9, &
+       76536.5,   66292.2, 54559.3, 42501.8, 31806, &
+       23787.5,   18252.7, 13996,   10320.8, 7191.1, &
+       4661.7,    2732.9,  1345.6,  388.2/  
+
+
+!***********************BAND 1***********************************
+!ACCUMULATION MODE
+  DATA A1_ASSSM_b1_19/ 4.373E+00,  4.361E+00,  4.331E+00, &
+                    4.278E+00,  4.223E+00,  4.162E+00, &
+                    4.103E+00,  4.035E+00,  3.962E+00, &
+                    3.904E+00,  3.871E+00,  3.847E+00, &
+                    3.824E+00,  3.780E+00,  3.646E+00, &
+                    3.448E+00,  3.179E+00,  2.855E+00,  2.630E+00/
+  DATA A2_ASSSM_b1_19/ 2.496E+00,  2.489E+00,  2.472E+00, &
+                    2.442E+00,  2.411E+00,  2.376E+00, &
+                    2.342E+00,  2.303E+00,  2.261E+00, &
+                    2.228E+00,  2.210E+00,  2.196E+00, &
+                    2.183E+00,  2.158E+00,  2.081E+00, &
+                    1.968E+00,  1.814E+00,  1.630E+00,  1.501E+00/
+  DATA A3_ASSSM_b1_19/-4.688E-02, -4.676E-02, -4.644E-02, &
+                   -4.587E-02, -4.528E-02, -4.463E-02, &
+                   -4.399E-02, -4.326E-02, -4.248E-02, &
+                   -4.186E-02, -4.151E-02, -4.125E-02, &
+                   -4.100E-02, -4.053E-02, -3.910E-02, &
+                   -3.697E-02, -3.408E-02, -3.061E-02, -2.819E-02/
+  DATA B1_ASSSM_b1_19/ 1.165E-08,  1.145E-08,  1.097E-08, &
+                    1.012E-08,  9.233E-09,  8.261E-09, &
+                    7.297E-09,  6.201E-09,  5.026E-09, &
+                    4.098E-09,  3.567E-09,  3.187E-09, &
+                    2.807E-09,  2.291E-09,  2.075E-09, &
+                    1.756E-09,  1.322E-09,  8.011E-10, 4.379E-10/
+  DATA B2_ASSSM_b1_19/ 2.193E-08,  2.192E-08,  2.187E-08, &
+                    2.179E-08,  2.171E-08,  2.162E-08, &
+                    2.153E-08,  2.143E-08,  2.132E-08, &
+                    2.124E-08,  2.119E-08,  2.115E-08, &
+                    2.112E-08,  2.106E-08,  2.100E-08, &
+                    2.090E-08,  2.077E-08,  2.061E-08,  2.049E-08/
+  DATA C1_ASSSM_b1_19/ 7.365E-01,  7.365E-01,  7.365E-01, &
+                    7.364E-01,  7.363E-01,  7.362E-01, &
+                    7.361E-01,  7.359E-01,  7.358E-01, &
+                    7.357E-01,  7.356E-01,  7.356E-01, &
+                    7.356E-01,  7.355E-01,  7.354E-01, &
+                    7.352E-01,  7.350E-01,  7.347E-01,  7.345E-01/
+  DATA C2_ASSSM_b1_19/ 5.833E-02,  5.835E-02,  5.841E-02, &
+                    5.850E-02,  5.859E-02,  5.870E-02, &
+                    5.880E-02,  5.891E-02,  5.904E-02, &
+                    5.914E-02,  5.920E-02,  5.924E-02, &
+                    5.928E-02,  5.934E-02,  5.944E-02, &
+                    5.959E-02,  5.979E-02,  6.003E-02,  6.020E-02/
+!COARSE MODE
+  DATA A1_CSSSM_b1_19/ 7.403E-01,  7.422E-01,  7.626E-01, &
+                    8.019E-01,  8.270E-01,  8.527E-01, &
+                    8.702E-01,  8.806E-01,  8.937E-01, &
+                    9.489E-01,  1.030E+00,  1.105E+00, &
+                    1.199E+00,  1.357E+00,  1.660E+00, &
+                    2.540E+00,  4.421E+00,  2.151E+00,  9.518E-01/
+  DATA A2_CSSSM_b1_19/ 4.522E-01,  4.532E-01,  4.644E-01, &
+                    4.859E-01,  4.996E-01,  5.137E-01, &
+                    5.233E-01,  5.290E-01,  5.361E-01, &
+                    5.655E-01,  6.085E-01,  6.483E-01, &
+                    6.979E-01,  7.819E-01,  9.488E-01, &
+                    1.450E+00,  2.523E+00,  1.228E+00,  5.433E-01/
+  DATA A3_CSSSM_b1_19/-8.516E-03, -8.535E-03, -8.744E-03, &
+                   -9.148E-03, -9.406E-03, -9.668E-03, &
+                   -9.848E-03, -9.955E-03, -1.009E-02, &
+                   -1.064E-02, -1.145E-02, -1.219E-02, &
+                   -1.312E-02, -1.470E-02, -1.783E-02, &
+                   -2.724E-02, -4.740E-02, -2.306E-02, -1.021E-02/
+  DATA B1_CSSSM_b1_19/ 2.535E-07,  2.530E-07,  2.479E-07, &
+                    2.380E-07,  2.317E-07,  2.252E-07, &
+                    2.208E-07,  2.182E-07,  2.149E-07, &
+                    2.051E-07,  1.912E-07,  1.784E-07, &
+                    1.624E-07,  1.353E-07,  1.012E-07, &
+                    6.016E-08,  2.102E-08,  0.000E+00,  0.000E+00/
+  DATA B2_CSSSM_b1_19/ 1.221E-07,  1.217E-07,  1.179E-07, &
+                    1.104E-07,  1.056E-07,  1.008E-07, &
+                    9.744E-08,  9.546E-08,  9.299E-08, &
+                    8.807E-08,  8.150E-08,  7.544E-08, &
+                    6.786E-08,  5.504E-08,  4.080E-08, &
+                    2.960E-08,  2.300E-08,  2.030E-08,  1.997E-08/
+  DATA C1_CSSSM_b1_19/ 7.659E-01,  7.658E-01,  7.652E-01, &
+                    7.639E-01,  7.631E-01,  7.623E-01, &
+                    7.618E-01,  7.614E-01,  7.610E-01, &
+                    7.598E-01,  7.581E-01,  7.566E-01, &
+                    7.546E-01,  7.513E-01,  7.472E-01, &
+                    7.423E-01,  7.376E-01,  7.342E-01,  7.334E-01/
+  DATA C2_CSSSM_b1_19/ 3.691E-02,  3.694E-02,  3.729E-02, &
+                    3.796E-02,  3.839E-02,  3.883E-02, &
+                    3.913E-02,  3.931E-02,  3.953E-02, &
+                    4.035E-02,  4.153E-02,  4.263E-02, &
+                    4.400E-02,  4.631E-02,  4.933E-02, &
+                    5.331E-02,  5.734E-02,  6.053E-02,  6.128E-02/
+!SUPER COARSE MODE
+  DATA A1_SSSSM_b1_19/ 2.836E-01,  2.876E-01,  2.563E-01, &
+                    2.414E-01,  2.541E-01,  2.546E-01, &
+                    2.572E-01,  2.638E-01,  2.781E-01, &
+                    3.167E-01,  4.209E-01,  5.286E-01, &
+                    6.959E-01,  9.233E-01,  1.282E+00, &
+                    1.836E+00,  2.981E+00,  4.355E+00,  4.059E+00/
+  DATA A2_SSSSM_b1_19/ 1.608E-01,  1.651E-01,  1.577E-01, &
+                    1.587E-01,  1.686E-01,  1.690E-01, &
+                    1.711E-01,  1.762E-01,  1.874E-01, &
+                    2.138E-01,  2.751E-01,  3.363E-01, &
+                    4.279E-01,  5.519E-01,  7.421E-01, &
+                    1.048E+00,  1.702E+00,  2.485E+00,  2.317E+00/
+  DATA A3_SSSSM_b1_19/-3.025E-03, -3.111E-03, -2.981E-03, &
+                   -3.005E-03, -3.193E-03, -3.200E-03, &
+                   -3.239E-03, -3.336E-03, -3.548E-03, &
+                   -4.047E-03, -5.196E-03, -6.345E-03, &
+                   -8.061E-03, -1.038E-02, -1.395E-02, &
+                   -1.970E-02, -3.197E-02, -4.669E-02, -4.352E-02/
+  DATA B1_SSSSM_b1_19/ 6.759E-07,  6.246E-07,  5.542E-07, &
+                    4.953E-07,  4.746E-07,  4.738E-07, &
+                    4.695E-07,  4.588E-07,  4.354E-07, &
+                    3.947E-07,  3.461E-07,  3.067E-07, &
+                    2.646E-07,  2.095E-07,  1.481E-07, &
+                    9.024E-08,  5.747E-08,  2.384E-08,  6.599E-09/
+  DATA B2_SSSSM_b1_19/ 5.977E-07,  5.390E-07,  4.468E-07, &
+                    3.696E-07,  3.443E-07,  3.433E-07, &
+                    3.380E-07,  3.249E-07,  2.962E-07, &
+                    2.483E-07,  1.989E-07,  1.623E-07, &
+                    1.305E-07,  9.015E-08,  6.111E-08, &
+                    3.761E-08,  2.903E-08,  2.337E-08,  2.147E-08/
+  DATA C1_SSSSM_b1_19/ 8.120E-01,  8.084E-01,  8.016E-01, &
+                    7.953E-01,  7.929E-01,  7.928E-01, &
+                    7.923E-01,  7.910E-01,  7.882E-01, &
+                    7.834E-01,  7.774E-01,  7.725E-01, &
+                    7.673E-01,  7.604E-01,  7.529E-01, &
+                    7.458E-01,  7.419E-01,  7.379E-01,  7.360E-01/
+  DATA C2_SSSSM_b1_19/ 2.388E-02,  2.392E-02,  2.457E-02,  2.552E-02, &
+                    2.615E-02,  2.618E-02,  2.631E-02,  2.663E-02, &
+                    2.735E-02,  2.875E-02,  3.113E-02,  3.330E-02, &
+                    3.615E-02,  3.997E-02,  4.521E-02,  5.038E-02, &
+                    5.358E-02,  5.705E-02,  5.887E-02/
+!*********************BAND 2************************************************
+!ACCUMULATION MODE
+  DATA A1_ASSSM_b2_19/1.256E+00, 1.246E+00, 1.226E+00, 1.187E+00, 1.148E+00, &
+                   1.105E+00, 1.062E+00, 1.014E+00, 9.616E-01, 9.205E-01, &
+                   8.970E-01, 8.800E-01, 8.632E-01, 8.371E-01, 7.943E-01, &
+                   7.308E-01, 6.448E-01, 5.414E-01, 4.693E-01/
+  DATA A2_ASSSM_b2_19/5.321E-01, 5.284E-01, 5.196E-01, 5.036E-01, 4.872E-01, &
+                   4.691E-01, 4.512E-01, 4.308E-01, 4.089E-01, 3.917E-01, &
+                   3.818E-01, 3.747E-01, 3.676E-01, 3.567E-01, 3.385E-01, &
+                   3.116E-01, 2.751E-01, 2.312E-01, 2.006E-01/
+  DATA A3_ASSSM_b2_19/-1.053E-02, -1.046E-02, -1.028E-02, -9.964E-03, -9.637E-03, &
+                   -9.279E-03, -8.923E-03, -8.518E-03, -8.084E-03, -7.741E-03, &
+                   -7.545E-03, -7.405E-03, -7.265E-03, -7.048E-03, -6.687E-03, &
+                   -6.156E-03, -5.433E-03, -4.565E-03, -3.961E-03/
+  DATA B1_ASSSM_b2_19/1.560E-02, 1.560E-02, 1.561E-02, 1.565E-02, 1.568E-02, &
+                   1.572E-02, 1.576E-02, 1.580E-02, 1.584E-02, 1.588E-02, &
+                   1.590E-02, 1.592E-02, 1.593E-02, 1.595E-02, 1.599E-02, &
+                   1.605E-02, 1.612E-02, 1.621E-02, 1.627E-02/
+  DATA B2_ASSSM_b2_19/1.073E-02, 1.074E-02, 1.076E-02, 1.079E-02, 1.082E-02, &
+                   1.085E-02, 1.089E-02, 1.093E-02, 1.097E-02, 1.100E-02, &
+                   1.102E-02, 1.103E-02, 1.105E-02, 1.107E-02, 1.110E-02, &
+                   1.115E-02, 1.122E-02, 1.130E-02, 1.136E-02/
+  DATA C1_ASSSM_b2_19/7.429E-01, 7.429E-01, 7.429E-01, 7.427E-01, 7.427E-01, &
+                   7.424E-01, 7.423E-01, 7.422E-01, 7.421E-01, 7.420E-01, &
+                   7.419E-01, 7.419E-01, 7.418E-01, 7.417E-01, 7.416E-01, &
+                   7.415E-01, 7.413E-01, 7.409E-01, 7.408E-01/
+  DATA C2_ASSSM_b2_19/3.031E-02, 3.028E-02, 3.022E-02, 3.011E-02, 2.999E-02, &
+                   2.986E-02, 2.973E-02, 2.959E-02, 2.943E-02, 2.931E-02, &
+                   2.924E-02, 2.919E-02, 2.913E-02, 2.905E-02, 2.893E-02, &
+                   2.874E-02, 2.847E-02, 2.817E-02, 2.795E-02/
+!COARSE MODE
+  DATA A1_CSSSM_b2_19/7.061E-01, 7.074E-01, 7.211E-01, 7.476E-01, 7.647E-01, &
+                   7.817E-01, 7.937E-01, 8.007E-01, 8.095E-01, 8.436E-01, &
+                   8.932E-01, 9.390E-01, 9.963E-01, 1.093E+00, 1.256E+00, &
+                   1.668E+00, 1.581E+00, 3.457E-01, 1.331E-01/
+  DATA A2_CSSSM_b2_19/3.617E-01, 3.621E-01, 3.662E-01, 3.739E-01, 3.789E-01, &
+                   3.840E-01, 3.874E-01, 3.895E-01, 3.921E-01, 4.001E-01, &
+                   4.117E-01, 4.223E-01, 4.356E-01, 4.581E-01, 5.099E-01, &
+                   6.831E-01, 6.663E-01, 1.481E-01, 5.703E-02/
+  DATA A3_CSSSM_b2_19/-6.953E-03, -6.961E-03, -7.048E-03, -7.216E-03, -7.322E-03, &
+                   -7.431E-03, -7.506E-03, -7.551E-03, -7.606E-03, -7.791E-03, &
+                   -8.059E-03, -8.305E-03, -8.613E-03, -9.134E-03, -1.023E-02, &
+                   -1.365E-02, -1.320E-02, -2.922E-03, -1.125E-03/
+  DATA B1_CSSSM_b2_19/1.007E-02, 1.008E-02, 1.012E-02, 1.019E-02, 1.024E-02, &
+                   1.029E-02, 1.033E-02, 1.035E-02, 1.038E-02, 1.056E-02, &
+                   1.083E-02, 1.109E-02, 1.140E-02, 1.194E-02, 1.270E-02, &
+                   1.390E-02, 1.524E-02, 1.639E-02, 1.667E-02/
+  DATA B2_CSSSM_b2_19/4.675E-03, 4.682E-03, 4.760E-03, 4.908E-03, 5.004E-03, &
+                   5.102E-03, 5.168E-03, 5.207E-03, 5.256E-03, 5.474E-03, &
+                   5.793E-03, 6.089E-03, 6.457E-03, 7.081E-03, 7.923E-03, &
+                   9.127E-03, 1.041E-02, 1.147E-02, 1.173E-02/
+  DATA C1_CSSSM_b2_19/7.571E-01, 7.571E-01, 7.570E-01, 7.568E-01, 7.565E-01, &
+                   7.564E-01, 7.563E-01, 7.562E-01, 7.562E-01, 7.557E-01, &
+                   7.552E-01, 7.545E-01, 7.539E-01, 7.527E-01, 7.509E-01, &
+                   7.478E-01, 7.440E-01, 7.404E-01, 7.394E-01/
+  DATA C2_CSSSM_b2_19/4.464E-02, 4.465E-02, 4.468E-02, 4.474E-02, 4.477E-02, &
+                   4.480E-02, 4.482E-02, 4.484E-02, 4.486E-02, 4.448E-02, &
+                   4.389E-02, 4.334E-02, 4.264E-02, 4.148E-02, 3.957E-02, &
+                   3.588E-02, 3.149E-02, 2.751E-02, 2.650E-02/
+!SUPER COARSE MODE
+  DATA A1_SSSSM_b2_19/2.357E-01, 2.490E-01, 2.666E-01, 2.920E-01, 3.120E-01, &
+                   3.128E-01, 3.169E-01, 3.272E-01, 3.498E-01, 3.960E-01, &
+                   4.822E-01, 5.634E-01, 6.763E-01, 8.278E-01, 1.047E+00, &
+                   1.340E+00, 1.927E+00, 1.648E+00, 1.031E+00/
+  DATA A2_SSSSM_b2_19/1.219E-01, 1.337E-01, 1.633E-01, 1.929E-01, 2.057E-01, &
+                   2.062E-01, 2.089E-01, 2.155E-01, 2.300E-01, 2.560E-01, &
+                   2.908E-01, 3.199E-01, 3.530E-01, 3.965E-01, 4.475E-01, &
+                   5.443E-01, 7.943E-01, 6.928E-01, 4.381E-01/
+  DATA A3_SSSSM_b2_19/-2.387E-03, -2.599E-03, -3.092E-03, -3.599E-03, -3.832E-03, &
+                   -3.842E-03, -3.890E-03, -4.012E-03, -4.276E-03, -4.763E-03, &
+                   -5.455E-03, -6.051E-03, -6.763E-03, -7.708E-03, -8.887E-03, &
+                   -1.091E-02, -1.585E-02, -1.373E-02, -8.665E-03/
+  DATA B1_SSSSM_b2_19/1.260E-02, 1.211E-02, 1.126E-02, 1.056E-02, 1.038E-02, &
+                   1.037E-02, 1.033E-02, 1.023E-02, 1.002E-02, 9.717E-03, &
+                   9.613E-03, 9.652E-03, 9.983E-03, 1.047E-02, 1.168E-02, &
+                   1.301E-02, 1.399E-02, 1.514E-02, 1.578E-02/
+  DATA B2_SSSSM_b2_19/2.336E-03, 2.419E-03, 2.506E-03, 2.610E-03, 2.690E-03, &
+                   2.694E-03, 2.711E-03, 2.752E-03, 2.844E-03, 3.043E-03, &
+                   3.455E-03, 3.871E-03, 4.507E-03, 5.373E-03, 6.786E-03, &
+                   8.238E-03, 9.208E-03, 1.032E-02, 1.091E-02/
+  DATA C1_SSSSM_b2_19/7.832E-01, 7.787E-01, 7.721E-01, 7.670E-01, 7.657E-01, &
+                   7.657E-01, 7.654E-01, 7.648E-01, 7.634E-01, 7.613E-01, &
+                   7.596E-01, 7.585E-01, 7.574E-01, 7.560E-01, 7.533E-01, &
+                   7.502E-01, 7.476E-01, 7.443E-01, 7.423E-01/
+  DATA C2_SSSSM_b2_19/3.144E-02, 3.268E-02, 3.515E-02, 3.748E-02, 3.837E-02, &
+                   3.840E-02, 3.860E-02, 3.906E-02, 4.006E-02, 4.173E-02, &
+                   4.338E-02, 4.435E-02, 4.459E-02, 4.467E-02, 4.202E-02, &
+                   3.864E-02, 3.559E-02, 3.183E-02, 2.964E-02/
+!***************************************************************************
+
+  spsol = 0
+  spinsol = 0 
+  spss = 0 
+
+  DATA alpha_aers_2bands/  & 
+       ! bc soluble
+       7.675,7.675,7.675,7.675,7.675,7.675,    &
+       7.675,7.675,10.433,11.984,13.767,15.567,& 
+       4.720,4.720,4.720,4.720,4.720,4.720,    & 
+       4.720,4.720,6.081,6.793,7.567,9.344,    & 
+       ! pom soluble
+       5.503,5.503,5.503,5.503,5.588,5.957,    & 
+       6.404,7.340,8.545,10.319,13.595,20.398, & 
+       1.402,1.402,1.402,1.402,1.431,1.562,    & 
+       1.715,2.032,2.425,2.991,4.193,7.133,    & 
+       ! sulfate    
+       4.681,5.062,5.460,5.798,6.224,6.733,    & 
+       7.556,8.613,10.687,12.265,16.32,21.692, & 
+       1.107,1.239,1.381,1.490,1.635,1.8030,   &
+       2.071,2.407,3.126,3.940,5.539,7.921,    &
+                                ! sulfate coarse
+       4.681,5.062,5.460,5.798,6.224,6.733,    & 
+       7.556,8.613,10.687,12.265,16.32,21.692, & 
+       1.107,1.239,1.381,1.490,1.635,1.8030,   &
+       2.071,2.407,3.126,3.940,5.539,7.921,    &
+                                ! seasalt Super Coarse Soluble (SS)
+       0.5090,0.6554,0.7129,0.7767,0.8529,1.2728, &
+       1.3820,1.5792,1.9173,2.2002,2.7173,4.1487, &
+       0.5167,0.6613,0.7221,0.7868,0.8622,1.3027, &
+       1.4227,1.6317,1.9887,2.2883,2.8356,4.3453, &
+                                ! seasalt  Coarse Soluble (CS)
+       0.5090,0.6554,0.7129,0.7767,0.8529,1.2728, &
+       1.3820,1.5792,1.9173,2.2002,2.7173,4.1487, &
+       0.5167,0.6613,0.7221,0.7868,0.8622,1.3027, &
+       1.4227,1.6317,1.9887,2.2883,2.8356,4.3453, &
+                                ! seasalt  Accumulation Soluble (AS)
+       4.125, 4.674, 5.005, 5.434, 5.985, 10.006, &
+       11.175,13.376,17.264,20.540,26.604, 42.349,&
+       4.187, 3.939, 3.919, 3.937, 3.995,  5.078, &
+       5.511, 6.434, 8.317,10.152,14.024, 26.537/
+
+  DATA alpha_aeri_2bands/  & 
+       ! dust insoluble
+       0.7661,0.7123,&
+       ! bc insoluble
+       10.360,4.437, &
+       ! pom insoluble
+       3.741,0.606/
+
+  DATA cg_aers_2bands/ &
+       ! bc soluble
+       .612, .612, .612, .612, .612, .612, &
+       .612, .612, .702, .734, .760, .796, &
+       .433, .433, .433, .433, .433, .433, &
+       .433, .433, .534, .575, .613, .669, &
+       ! pom soluble
+       .663, .663, .663, .663, .666, .674, &
+       .685, .702, .718, .737, .757, .777, &
+       .544, .544, .544, .544, .547, .554, &
+       .565, .583, .604, .631, .661, .698, &
+       ! sulfate    
+       .658, .669, .680, .688, .698, .707, &
+       .719, .733, .752, .760, .773, .786, &
+       .544, .555, .565, .573, .583, .593, &
+       .610, .628, .655, .666, .692, .719, &
+                                ! sulfate coarse
+       .658, .669, .680, .688, .698, .707, &
+       .719, .733, .752, .760, .773, .786, &
+       .544, .555, .565, .573, .583, .593, &
+       .610, .628, .655, .666, .692, .719, &
+                                ! seasalt Super Coarse soluble (SS)
+       .727, .747, .755, .761, .770, .788, &
+       .792, .799, .805, .809, .815, .826, &
+       .717, .738, .745, .752, .761, .779, &
+       .781, .786, .793, .797, .803, .813, &
+                                ! seasalt Coarse soluble (CS)
+       .727, .747, .755, .761, .770, .788, &
+       .792, .799, .805, .809, .815, .826, &
+       .717, .738, .745, .752, .761, .779, &
+       .781, .786, .793, .797, .803, .813, &
+                                ! Sesalt Accumulation Soluble (AS)
+       .727, .741, .748, .754, .761, .782, &
+       .787, .792, .797, .799, .801, .799, &
+       .606, .645, .658, .669, .681, .726, &
+       .734, .746, .761, .770, .782, .798/
+
+  DATA cg_aeri_2bands/ &
+       ! dust insoluble
+       .701, .670, &
+       ! bc insoluble
+       .471, .297, &
+       ! pom insoluble
+       .568, .365/
+
+  DATA piz_aers_2bands/&
+       ! bc soluble
+       .445, .445, .445, .445, .445, .445, &
+       .445, .445, .461, .480, .505, .528, &
+       .362, .362, .362, .362, .362, .362, &
+       .362, .362, .381, .405, .437, .483, &
+       ! pom soluble
+       .972, .972, .972, .972, .972, .974, &
+       .976, .979, .982, .986, .989, .992, &
+       .924, .924, .924, .924, .925, .927, &
+       .932, .938, .945, .952, .961, .970, &
+       ! sulfate
+       1.000,1.000,1.000,1.000,1.000,1.000, &
+       1.000,1.000,1.000,1.000,1.000,1.000, &
+       .992, .988, .988, .987, .986, .985,  &
+       .985, .985, .984, .984, .984, .984,  &
+                                ! sulfate coarse
+       1.000,1.000,1.000,1.000,1.000,1.000, &
+       1.000,1.000,1.000,1.000,1.000,1.000, &
+       .992, .988, .988, .987, .986, .985,  &
+       .985, .985, .984, .984, .984, .984,  &
+                                ! seasalt Super Coarse Soluble (SS)
+       1.000,1.000,1.000,1.000,1.000,1.000, &
+       1.000,1.000,1.000,1.000,1.000,1.000, &
+       0.992,0.989,0.987,0.986,0.986,0.980, &
+       0.980,0.978,0.976,0.976,0.974,0.971, &
+                                ! seasalt Coarse soluble (CS)
+       1.000,1.000,1.000,1.000,1.000,1.000, &
+       1.000,1.000,1.000,1.000,1.000,1.000, &
+       0.992,0.989,0.987,0.986,0.986,0.980, &
+       0.980,0.978,0.976,0.976,0.974,0.971, &
+                                ! seasalt Accumulation Soluble (AS)
+       1.000, 1.000, 1.000, 1.000, 1.000, 1.000, &
+       1.000, 1.000, 1.000, 1.000, 1.000, 1.000, &
+       0.970, 0.975, 0.976, 0.977, 0.978, 0.982, &
+       0.982, 0.983, 0.984, 0.984, 0.985, 0.985/
+
+  DATA piz_aeri_2bands/ &
+       ! dust insoluble
+       .963, .987, &
+       ! bc insoluble
+       .395, .264, &
+       ! pom insoluble
+       .966, .859/
+
+! Interpolation des coefficients optiques de 19 niveaux vers le nombre des niveaux du model
+  IF (firstcall) THEN
+     firstcall=.FALSE.
+     
+     IF (.NOT. ALLOCATED(A1_ASSSM_b1)) THEN
+        ALLOCATE(A1_ASSSM_b1(klev),A2_ASSSM_b1(klev), A3_ASSSM_b1(klev),&
+          B1_ASSSM_b1(klev), B2_ASSSM_b1(klev), C1_ASSSM_b1(klev), C2_ASSSM_b1(klev),&
+          A1_CSSSM_b1(klev), A2_CSSSM_b1(klev), A3_CSSSM_b1(klev),&
+          B1_CSSSM_b1(klev), B2_CSSSM_b1(klev), C1_CSSSM_b1(klev), C2_CSSSM_b1(klev),&
+          A1_SSSSM_b1(klev), A2_SSSSM_b1(klev), A3_SSSSM_b1(klev),&
+          B1_SSSSM_b1(klev), B2_SSSSM_b1(klev), C1_SSSSM_b1(klev), C2_SSSSM_b1(klev),&
+          A1_ASSSM_b2(klev), A2_ASSSM_b2(klev), A3_ASSSM_b2(klev),&
+          B1_ASSSM_b2(klev), B2_ASSSM_b2(klev), C1_ASSSM_b2(klev), C2_ASSSM_b2(klev),&
+          A1_CSSSM_b2(klev), A2_CSSSM_b2(klev), A3_CSSSM_b2(klev),&
+          B1_CSSSM_b2(klev), B2_CSSSM_b2(klev), C1_CSSSM_b2(klev), C2_CSSSM_b2(klev),&
+          A1_SSSSM_b2(klev), A2_SSSSM_b2(klev), A3_SSSSM_b2(klev),&
+          B1_SSSSM_b2(klev), B2_SSSSM_b2(klev), C1_SSSSM_b2(klev), C2_SSSSM_b2(klev), stat=ierr)
+        IF (ierr /= 0) CALL abort_physic('aeropt_2bands', 'pb in allocation 1',1)
+     END IF
+     
+! bande 1
+     CALL pres2lev(A1_ASSSM_b1_19, A1_ASSSM_b1, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(A2_ASSSM_b1_19, A2_ASSSM_b1, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(A3_ASSSM_b1_19, A3_ASSSM_b1, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(B1_ASSSM_b1_19, B1_ASSSM_b1, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(B2_ASSSM_b1_19, B2_ASSSM_b1, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(C1_ASSSM_b1_19, C1_ASSSM_b1, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(C2_ASSSM_b1_19, C2_ASSSM_b1, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+
+     CALL pres2lev(A1_CSSSM_b1_19, A1_CSSSM_b1, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(A2_CSSSM_b1_19, A2_CSSSM_b1, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(A3_CSSSM_b1_19, A3_CSSSM_b1, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(B1_CSSSM_b1_19, B1_CSSSM_b1, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(B2_CSSSM_b1_19, B2_CSSSM_b1, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(C1_CSSSM_b1_19, C1_CSSSM_b1, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(C2_CSSSM_b1_19, C2_CSSSM_b1, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+
+     CALL pres2lev(A1_SSSSM_b1_19, A1_SSSSM_b1, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(A2_SSSSM_b1_19, A2_SSSSM_b1, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(A3_SSSSM_b1_19, A3_SSSSM_b1, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(B1_SSSSM_b1_19, B1_SSSSM_b1, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(B2_SSSSM_b1_19, B2_SSSSM_b1, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(C1_SSSSM_b1_19, C1_SSSSM_b1, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(C2_SSSSM_b1_19, C2_SSSSM_b1, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+
+! bande 2
+     CALL pres2lev(A1_ASSSM_b2_19, A1_ASSSM_b2, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(A2_ASSSM_b2_19, A2_ASSSM_b2, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(A3_ASSSM_b2_19, A3_ASSSM_b2, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(B1_ASSSM_b2_19, B1_ASSSM_b2, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(B2_ASSSM_b2_19, B2_ASSSM_b2, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(C1_ASSSM_b2_19, C1_ASSSM_b2, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(C2_ASSSM_b2_19, C2_ASSSM_b2, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+
+     CALL pres2lev(A1_CSSSM_b2_19, A1_CSSSM_b2, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(A2_CSSSM_b2_19, A2_CSSSM_b2, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(A3_CSSSM_b2_19, A3_CSSSM_b2, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(B1_CSSSM_b2_19, B1_CSSSM_b2, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(B2_CSSSM_b2_19, B2_CSSSM_b2, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(C1_CSSSM_b2_19, C1_CSSSM_b2, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(C2_CSSSM_b2_19, C2_CSSSM_b2, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+
+     CALL pres2lev(A1_SSSSM_b2_19, A1_SSSSM_b2, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(A2_SSSSM_b2_19, A2_SSSSM_b2, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(A3_SSSSM_b2_19, A3_SSSSM_b2, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(B1_SSSSM_b2_19, B1_SSSSM_b2, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(B2_SSSSM_b2_19, B2_SSSSM_b2, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(C1_SSSSM_b2_19, C1_SSSSM_b2, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(C2_SSSSM_b2_19, C2_SSSSM_b2, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+
+  END IF ! firstcall
+
+  DO k=1, klev
+    DO i=1, klon
+      zrho=pplay(i,k)/t_seri(i,k)/RD    ! kg/m3
+      zdh(i,k)=pdel(i,k)/(RG*zrho)      ! m
+    ENDDO
+  ENDDO
+
+  IF (flag_aerosol .EQ. 1) THEN 
+     nb_aer = 2
+     ALLOCATE (aerosol_name(nb_aer)) 
+     aerosol_name(1) = id_ASSO4M_phy
+     aerosol_name(2) = id_CSSO4M_phy
+  ELSEIF (flag_aerosol .EQ. 2) THEN
+     nb_aer = 2
+     ALLOCATE (aerosol_name(nb_aer)) 
+     aerosol_name(1) = id_ASBCM_phy
+     aerosol_name(2) = id_AIBCM_phy
+  ELSEIF (flag_aerosol .EQ. 3) THEN 
+     nb_aer = 2
+     ALLOCATE (aerosol_name(nb_aer)) 
+     aerosol_name(1) = id_ASPOMM_phy
+     aerosol_name(2) = id_AIPOMM_phy
+  ELSEIF (flag_aerosol .EQ. 4) THEN 
+     nb_aer = 3
+     ALLOCATE (aerosol_name(nb_aer)) 
+     aerosol_name(1) = id_CSSSM_phy
+     aerosol_name(2) = id_SSSSM_phy
+     aerosol_name(3) = id_ASSSM_phy
+  ELSEIF (flag_aerosol .EQ. 5) THEN 
+     nb_aer = 1
+     ALLOCATE (aerosol_name(nb_aer)) 
+     aerosol_name(1) = id_CIDUSTM_phy
+  ELSEIF (flag_aerosol .EQ. 6) THEN 
+     nb_aer = 10
+     ALLOCATE (aerosol_name(nb_aer)) 
+     aerosol_name(1) = id_ASSO4M_phy
+     aerosol_name(2) = id_ASBCM_phy
+     aerosol_name(3) = id_AIBCM_phy
+     aerosol_name(4) = id_ASPOMM_phy
+     aerosol_name(5) = id_AIPOMM_phy
+     aerosol_name(6) = id_CSSSM_phy
+     aerosol_name(7) = id_SSSSM_phy
+     aerosol_name(8) = id_ASSSM_phy
+     aerosol_name(9) = id_CIDUSTM_phy
+     aerosol_name(10)= id_CSSO4M_phy
+  ENDIF
+
+
+  !
+  ! loop over modes, use of precalculated nmd and corresponding sigma
+  !    loop over wavelengths
+  !    for each mass species in mode
+  !      interpolate from Sext to retrieve Sext_at_gridpoint_per_species
+  !      compute optical_thickness_at_gridpoint_per_species
+
+!CDIR ON_ADB(fact_RH)
+!CDIR SHORTLOOP
+  DO n=1,nbre_RH-1
+    fact_RH(n)=1./(RH_tab(n+1)-RH_tab(n))
+  ENDDO
+   
+  DO k=1, KLEV
+!CDIR ON_ADB(fact_RH)
+    DO i=1, KLON
+      rh(i,k)=MIN(RHcl(i,k)*100.,RH_MAX)
+      RH_num(i,k) = INT( rh(i,k)/10. + 1.)
+      IF (rh(i,k).GT.85.) RH_num(i,k)=10
+      IF (rh(i,k).GT.90.) RH_num(i,k)=11
+      DELTA(i,k)=(rh(i,k)-RH_tab(RH_num(i,k)))*fact_RH(RH_num(i,k))
+    ENDDO
+  ENDDO
+
+  used_aer(:)=.FALSE.
+    
+  DO m=1,nb_aer   ! tau is only computed for each mass
+    fac=1.0
+     IF (aerosol_name(m).EQ.id_ASBCM_phy) THEN
+         soluble=.TRUE.
+         spsol=1
+         spss=0
+     ELSEIF (aerosol_name(m).EQ.id_ASPOMM_phy) THEN 
+        soluble=.TRUE.
+        spsol=2 
+        spss=0
+     ELSEIF (aerosol_name(m).EQ.id_ASSO4M_phy) THEN 
+        soluble=.TRUE.
+        spsol=3
+        spss=0
+        fac=1.375    ! (NH4)2-SO4/SO4 132/96 mass conversion factor for OD
+     ELSEIF  (aerosol_name(m).EQ.id_CSSO4M_phy) THEN
+        soluble=.TRUE.
+        spsol=4
+        spss=0
+        fac=1.375    ! (NH4)2-SO4/SO4 132/96 mass conversion factor for OD
+     ELSEIF (aerosol_name(m).EQ.id_SSSSM_phy) THEN 
+         soluble=.TRUE.
+         spsol=5
+         spss=3
+     ELSEIF (aerosol_name(m).EQ.id_CSSSM_phy) THEN 
+         soluble=.TRUE.
+         spsol=6
+         spss=2
+     ELSEIF (aerosol_name(m).EQ.id_ASSSM_phy) THEN
+         soluble=.TRUE.
+         spsol=7
+         spss=1
+     ELSEIF (aerosol_name(m).EQ.id_CIDUSTM_phy) THEN 
+         soluble=.FALSE.
+         spinsol=1
+         spss=0
+     ELSEIF  (aerosol_name(m).EQ.id_AIBCM_phy) THEN 
+         soluble=.FALSE.
+         spinsol=2
+         spss=0
+     ELSEIF (aerosol_name(m).EQ.id_AIPOMM_phy) THEN 
+         soluble=.FALSE.
+         spinsol=3
+         spss=0
+     ELSE 
+         CYCLE
+     ENDIF
+
+    id=aerosol_name(m)
+    used_aer(id)=.TRUE.
+
+    IF (soluble) THEN
+
+      IF (spss.NE.0) THEN
+
+         IF (spss.EQ.1) THEN !accumulation mode
+            DO k=1, KLEV
+!CDIR ON_ADB(A1_ASSSM_b1)
+!CDIR ON_ADB(A2_ASSSM_b1)
+!CDIR ON_ADB(A3_ASSSM_b1)
+!CDIR ON_ADB(B1_ASSSM_b1)
+!CDIR ON_ADB(B2_ASSSM_b1)
+!CDIR ON_ADB(C1_ASSSM_b1)
+!CDIR ON_ADB(C2_ASSSM_b2)
+!CDIR ON_ADB(A1_ASSSM_b2)
+!CDIR ON_ADB(A2_ASSSM_b2)
+!CDIR ON_ADB(A3_ASSSM_b2)
+!CDIR ON_ADB(B1_ASSSM_b2)
+!CDIR ON_ADB(B2_ASSSM_b2)
+!CDIR ON_ADB(C1_ASSSM_b2)
+!CDIR ON_ADB(C2_ASSSM_b2)
+
+              DO i=1, KLON
+
+                H=rh(i,k)/100
+                tmp_var=m_allaer(i,k,spsol)/1.e6*zdh(i,k)*fac
+                tmp_var_pi=m_allaer_pi(i,k,spsol)/1.e6*zdh(i,k)*fac
+
+                ! band 1
+                tau_ae2b_int=A1_ASSSM_b1(k)+A2_ASSSM_b1(k)*H+A3_ASSSM_b1(k)/(H-1.05)
+                piz_ae2b_int=1-B1_ASSSM_b1(k)-B2_ASSSM_b1(k)*H
+                cg_ae2b_int=C1_ASSSM_b1(k)+C2_ASSSM_b1(k)*H
+
+                tau_ae(i,k,id,1) = tmp_var*tau_ae2b_int
+                tau_ae_pi(i,k,id,1) =  tmp_var_pi* tau_ae2b_int
+                piz_ae(i,k,id,1) = piz_ae2b_int
+                cg_ae(i,k,id,1)= cg_ae2b_int
+                
+                !band 2
+                tau_ae2b_int=A1_ASSSM_b2(k)+A2_ASSSM_b2(k)*H+A3_ASSSM_b2(k)/(H-1.05)
+                piz_ae2b_int=1-B1_ASSSM_b2(k)-B2_ASSSM_b2(k)*H
+                cg_ae2b_int=C1_ASSSM_b2(k)+C2_ASSSM_b2(k)*H
+
+                tau_ae(i,k,id,2) = tmp_var*tau_ae2b_int
+                tau_ae_pi(i,k,id,2) =  tmp_var_pi* tau_ae2b_int
+                piz_ae(i,k,id,2) = piz_ae2b_int
+                cg_ae(i,k,id,2)= cg_ae2b_int
+
+              ENDDO
+            ENDDO
+          ENDIF
+
+          IF (spss.EQ.2) THEN !coarse mode
+            DO k=1, KLEV
+!CDIR ON_ADB(A1_CSSSM_b1)
+!CDIR ON_ADB(A2_CSSSM_b1)
+!CDIR ON_ADB(A3_CSSSM_b1)
+!CDIR ON_ADB(B1_CSSSM_b1)
+!CDIR ON_ADB(B2_CSSSM_b1)
+!CDIR ON_ADB(C1_CSSSM_b1)
+!CDIR ON_ADB(C2_CSSSM_b2)
+!CDIR ON_ADB(A1_CSSSM_b2)
+!CDIR ON_ADB(A2_CSSSM_b2)
+!CDIR ON_ADB(A3_CSSSM_b2)
+!CDIR ON_ADB(B1_CSSSM_b2)
+!CDIR ON_ADB(B2_CSSSM_b2)
+!CDIR ON_ADB(C1_CSSSM_b2)
+!CDIR ON_ADB(C2_CSSSM_b2)
+
+              DO i=1, KLON
+
+                H=rh(i,k)/100
+                tmp_var=m_allaer(i,k,spsol)/1.e6*zdh(i,k)*fac
+                tmp_var_pi=m_allaer_pi(i,k,spsol)/1.e6*zdh(i,k)*fac
+                ! band 1
+                tau_ae2b_int=A1_CSSSM_b1(k)+A2_CSSSM_b1(k)*H+A3_CSSSM_b1(k)/(H-1.05)
+                piz_ae2b_int=1-B1_CSSSM_b1(k)-B2_CSSSM_b1(k)*H
+                cg_ae2b_int=C1_CSSSM_b1(k)+C2_CSSSM_b1(k)*H
+
+                tau_ae(i,k,id,1) = tmp_var*tau_ae2b_int
+                tau_ae_pi(i,k,id,1) =  tmp_var_pi* tau_ae2b_int
+                piz_ae(i,k,id,1) = piz_ae2b_int
+                cg_ae(i,k,id,1)= cg_ae2b_int
+
+                ! band 2
+                tau_ae2b_int=A1_CSSSM_b2(k)+A2_CSSSM_b2(k)*H+A3_CSSSM_b2(k)/(H-1.05)
+                piz_ae2b_int=1-B1_CSSSM_b2(k)-B2_CSSSM_b2(k)*H
+                cg_ae2b_int=C1_CSSSM_b2(k)+C2_CSSSM_b2(k)*H
+
+                tau_ae(i,k,id,2) = tmp_var*tau_ae2b_int
+                tau_ae_pi(i,k,id,2) =  tmp_var_pi* tau_ae2b_int
+                piz_ae(i,k,id,2) = piz_ae2b_int
+                cg_ae(i,k,id,2)= cg_ae2b_int
+
+             ENDDO
+           ENDDO
+         ENDIF
+
+         IF (spss.EQ.3) THEN !super coarse mode
+            DO k=1, KLEV
+!CDIR ON_ADB(A1_SSSSM_b1)
+!CDIR ON_ADB(A2_SSSSM_b1)
+!CDIR ON_ADB(A3_SSSSM_b1)
+!CDIR ON_ADB(B1_SSSSM_b1)
+!CDIR ON_ADB(B2_SSSSM_b1)
+!CDIR ON_ADB(C1_SSSSM_b1)
+!CDIR ON_ADB(C2_SSSSM_b2)
+!CDIR ON_ADB(A1_SSSSM_b2)
+!CDIR ON_ADB(A2_SSSSM_b2)
+!CDIR ON_ADB(A3_SSSSM_b2)
+!CDIR ON_ADB(B1_SSSSM_b2)
+!CDIR ON_ADB(B2_SSSSM_b2)
+!CDIR ON_ADB(C1_SSSSM_b2)
+!CDIR ON_ADB(C2_SSSSM_b2)
+
+              DO i=1, KLON
+
+                H=rh(i,k)/100
+                tmp_var=m_allaer(i,k,spsol)/1.e6*zdh(i,k)*fac
+                tmp_var_pi=m_allaer_pi(i,k,spsol)/1.e6*zdh(i,k)*fac
+
+                ! band 1 
+                tau_ae2b_int=A1_SSSSM_b1(k)+A2_SSSSM_b1(k)*H+A3_SSSSM_b1(k)/(H-1.05)
+                piz_ae2b_int=1-B1_SSSSM_b1(k)-B2_SSSSM_b1(k)*H
+                cg_ae2b_int=C1_SSSSM_b1(k)+C2_SSSSM_b1(k)*H
+
+                tau_ae(i,k,id,1) = tmp_var*tau_ae2b_int
+                tau_ae_pi(i,k,id,1) =  tmp_var_pi* tau_ae2b_int
+                piz_ae(i,k,id,1) = piz_ae2b_int
+                cg_ae(i,k,id,1)= cg_ae2b_int
+
+                ! band 2
+                tau_ae2b_int=A1_SSSSM_b2(k)+A2_SSSSM_b2(k)*H+A3_SSSSM_b2(k)/(H-1.05)
+                piz_ae2b_int=1-B1_SSSSM_b2(k)-B2_SSSSM_b2(k)*H
+                cg_ae2b_int=C1_SSSSM_b2(k)+C2_SSSSM_b2(k)*H
+
+                tau_ae(i,k,id,2) = tmp_var*tau_ae2b_int
+                tau_ae_pi(i,k,id,2) =  tmp_var_pi* tau_ae2b_int
+                piz_ae(i,k,id,2) = piz_ae2b_int
+                cg_ae(i,k,id,2)= cg_ae2b_int
+
+              ENDDO
+            ENDDO
+          ENDIF
+
+        ELSE
+                        
+!CDIR ON_ADB(alpha_aers_2bands)
+!CDIR ON_ADB(piz_aers_2bands)
+!CDIR ON_ADB(cg_aers_2bands)
+          DO k=1, KLEV
+            DO i=1, KLON
+              tmp_var=m_allaer(i,k,spsol)/1.e6*zdh(i,k)*fac
+              tmp_var_pi=m_allaer_pi(i,k,spsol)/1.e6*zdh(i,k)*fac
+!CDIR UNROLL=nbands
+              DO inu=1,nbands
+
+                tau_ae2b_int= alpha_aers_2bands(RH_num(i,k),inu,spsol)+ & 
+                              DELTA(i,k)* (alpha_aers_2bands(RH_num(i,k)+1,inu,spsol) - & 
+                              alpha_aers_2bands(RH_num(i,k),inu,spsol))
+                      
+                piz_ae2b_int = piz_aers_2bands(RH_num(i,k),inu,spsol) + & 
+                               DELTA(i,k)* (piz_aers_2bands(RH_num(i,k)+1,inu,spsol) - & 
+                               piz_aers_2bands(RH_num(i,k),inu,spsol))
+                      
+                cg_ae2b_int = cg_aers_2bands(RH_num(i,k),inu,spsol) + & 
+                              DELTA(i,k)* (cg_aers_2bands(RH_num(i,k)+1,inu,spsol) - & 
+                              cg_aers_2bands(RH_num(i,k),inu,spsol))
+
+                tau_ae(i,k,id,inu) = tmp_var*tau_ae2b_int
+                tau_ae_pi(i,k,id,inu) =  tmp_var_pi* tau_ae2b_int
+                piz_ae(i,k,id,inu) = piz_ae2b_int
+                cg_ae(i,k,id,inu)= cg_ae2b_int
+                         
+              ENDDO
+            ENDDO
+          ENDDO
+        
+        ENDIF                     
+
+      ELSE                                                    ! For all aerosol insoluble components
+
+!CDIR ON_ADB(alpha_aers_2bands)
+!CDIR ON_ADB(piz_aers_2bands)
+!CDIR ON_ADB(cg_aers_2bands)
+        DO k=1, KLEV
+          DO i=1, KLON
+            tmp_var=m_allaer(i,k,naero_soluble+spinsol)/1.e6*zdh(i,k)*fac
+            tmp_var_pi=m_allaer_pi(i,k,naero_soluble+spinsol)/1.e6*zdh(i,k)*fac
+!CDIR UNROLL=nbands
+            DO inu=1,nbands
+              tau_ae2b_int = alpha_aeri_2bands(inu,spinsol)
+              piz_ae2b_int = piz_aeri_2bands(inu,spinsol)
+              cg_ae2b_int = cg_aeri_2bands(inu,spinsol) 
+
+              tau_ae(i,k,id,inu) = tmp_var*tau_ae2b_int
+              tau_ae_pi(i,k,id,inu) = tmp_var_pi*tau_ae2b_int
+              piz_ae(i,k,id,inu) = piz_ae2b_int
+              cg_ae(i,k,id,inu)= cg_ae2b_int
+            ENDDO
+          ENDDO
+        ENDDO
+
+      ENDIF ! soluble
+
+    ENDDO  ! nb_aer  
+
+!correction bug OB
+!  DO m=1,nb_aer   
+  DO m=1,naero_tot   
+    IF (.NOT. used_aer(m)) THEN
+      tau_ae(:,:,m,:)=0.
+      tau_ae_pi(:,:,m,:)=0.
+      piz_ae(:,:,m,:)=0.
+      cg_ae(:,:,m,:)=0.
+    ENDIF
+  ENDDO
+
+  DO inu=1, nbands
+
+    !!DO mrfspecies=1,naero_grp
+    DO mrfspecies=2,3    !--only deal with total and natural aerosols
+
+      IF (mrfspecies .EQ. 2) THEN             ! = total aerosol AER	 
+
+        DO k=1, KLEV
+          DO i=1, KLON
+            tau_allaer(i,k,mrfspecies,inu)=tau_ae(i,k,id_ASSO4M_phy,inu)+tau_ae(i,k,id_CSSO4M_phy,inu)+ &
+                                           tau_ae(i,k,id_ASBCM_phy,inu)+tau_ae(i,k,id_AIBCM_phy,inu)+   &
+                                           tau_ae(i,k,id_ASPOMM_phy,inu)+tau_ae(i,k,id_AIPOMM_phy,inu)+ &
+                                           tau_ae(i,k,id_ASSSM_phy,inu)+tau_ae(i,k,id_CSSSM_phy,inu)+   &
+                                           tau_ae(i,k,id_SSSSM_phy,inu)+ tau_ae(i,k,id_CIDUSTM_phy,inu)
+            tau_allaer(i,k,mrfspecies,inu)=MAX(tau_allaer(i,k,mrfspecies,inu),1e-5)
+                 
+            piz_allaer(i,k,mrfspecies,inu)=(tau_ae(i,k,id_ASSO4M_phy,inu)*piz_ae(i,k,id_ASSO4M_phy,inu)+ &
+                                            tau_ae(i,k,id_CSSO4M_phy,inu)*piz_ae(i,k,id_CSSO4M_phy,inu)+ &
+                                            tau_ae(i,k,id_ASBCM_phy,inu)*piz_ae(i,k,id_ASBCM_phy,inu)+   &
+                                            tau_ae(i,k,id_AIBCM_phy,inu)*piz_ae(i,k,id_AIBCM_phy,inu)+   &
+                                            tau_ae(i,k,id_ASPOMM_phy,inu)*piz_ae(i,k,id_ASPOMM_phy,inu)+ &
+                                            tau_ae(i,k,id_AIPOMM_phy,inu)*piz_ae(i,k,id_AIPOMM_phy,inu)+ &
+                                            tau_ae(i,k,id_ASSSM_phy,inu)*piz_ae(i,k,id_ASSSM_phy,inu)+   &
+                                            tau_ae(i,k,id_CSSSM_phy,inu)*piz_ae(i,k,id_CSSSM_phy,inu)+   &
+                                            tau_ae(i,k,id_SSSSM_phy,inu)*piz_ae(i,k,id_SSSSM_phy,inu)+   &
+                                            tau_ae(i,k,id_CIDUSTM_phy,inu)*piz_ae(i,k,id_CIDUSTM_phy,inu)) &
+                                            /tau_allaer(i,k,mrfspecies,inu)
+            piz_allaer(i,k,mrfspecies,inu)=MAX(piz_allaer(i,k,mrfspecies,inu),0.1)
+
+            cg_allaer(i,k,mrfspecies,inu)=(tau_ae(i,k,id_ASSO4M_phy,inu)* &
+              piz_ae(i,k,id_ASSO4M_phy,inu)*cg_ae(i,k,id_ASSO4M_phy,inu)+ &
+              tau_ae(i,k,id_CSSO4M_phy,inu)*piz_ae(i,k,id_CSSO4M_phy,inu)* &
+              cg_ae(i,k,id_CSSO4M_phy,inu)+ &
+              tau_ae(i,k,id_ASBCM_phy,inu)*piz_ae(i,k,id_ASBCM_phy,inu)* &
+              cg_ae(i,k,id_ASBCM_phy,inu)+ &
+              tau_ae(i,k,id_AIBCM_phy,inu)*piz_ae(i,k,id_AIBCM_phy,inu)* &
+              cg_ae(i,k,id_AIBCM_phy,inu)+ &
+              tau_ae(i,k,id_ASPOMM_phy,inu)*piz_ae(i,k,id_ASPOMM_phy,inu)* &
+              cg_ae(i,k,id_ASPOMM_phy,inu)+ &
+              tau_ae(i,k,id_AIPOMM_phy,inu)*piz_ae(i,k,id_AIPOMM_phy,inu)* &
+              cg_ae(i,k,id_AIPOMM_phy,inu)+ &
+              tau_ae(i,k,id_ASSSM_phy,inu)*piz_ae(i,k,id_ASSSM_phy,inu)* &
+              cg_ae(i,k,id_ASSSM_phy,inu)+ &
+              tau_ae(i,k,id_CSSSM_phy,inu)*piz_ae(i,k,id_CSSSM_phy,inu)* &
+              cg_ae(i,k,id_CSSSM_phy,inu)+ &
+              tau_ae(i,k,id_SSSSM_phy,inu)*piz_ae(i,k,id_SSSSM_phy,inu)* &
+              cg_ae(i,k,id_SSSSM_phy,inu)+ &
+              tau_ae(i,k,id_CIDUSTM_phy,inu)*piz_ae(i,k,id_CIDUSTM_phy,inu)* &
+              cg_ae(i,k,id_CIDUSTM_phy,inu))/ &
+              (tau_allaer(i,k,mrfspecies,inu)*piz_allaer(i,k,mrfspecies,inu))
+          ENDDO    
+        ENDDO 
+
+      ELSEIF (mrfspecies .EQ. 3) THEN             ! = natural aerosol NAT
+
+        DO k=1, KLEV
+          DO i=1, KLON
+
+              tau_allaer(i,k,mrfspecies,inu)=tau_ae_pi(i,k,id_ASSO4M_phy,inu)+ &
+                      tau_ae_pi(i,k,id_CSSO4M_phy,inu)+ &
+                      tau_ae_pi(i,k,id_ASBCM_phy,inu)+  &
+                      tau_ae_pi(i,k,id_AIBCM_phy,inu)+  &
+                      tau_ae_pi(i,k,id_ASPOMM_phy,inu)+ &
+                      tau_ae_pi(i,k,id_AIPOMM_phy,inu)+ &
+                      tau_ae_pi(i,k,id_ASSSM_phy,inu)+  &
+                      tau_ae_pi(i,k,id_CSSSM_phy,inu)+  &
+                      tau_ae_pi(i,k,id_SSSSM_phy,inu)+  &
+                      tau_ae_pi(i,k,id_CIDUSTM_phy,inu)
+              tau_allaer(i,k,mrfspecies,inu)=MAX(tau_allaer(i,k,mrfspecies,inu),1e-5)
+
+              piz_allaer(i,k,mrfspecies,inu)=(tau_ae_pi(i,k,id_ASSO4M_phy,inu)*piz_ae(i,k,id_ASSO4M_phy,inu)+ &
+                      tau_ae_pi(i,k,id_CSSO4M_phy,inu)*piz_ae(i,k,id_CSSO4M_phy,inu)+ &
+                      tau_ae_pi(i,k,id_ASBCM_phy,inu)*piz_ae(i,k,id_ASBCM_phy,inu)+   &
+                      tau_ae_pi(i,k,id_AIBCM_phy,inu)*piz_ae(i,k,id_AIBCM_phy,inu)+   &
+                      tau_ae_pi(i,k,id_ASPOMM_phy,inu)*piz_ae(i,k,id_ASPOMM_phy,inu)+ &
+                      tau_ae_pi(i,k,id_AIPOMM_phy,inu)*piz_ae(i,k,id_AIPOMM_phy,inu)+ &
+                      tau_ae_pi(i,k,id_ASSSM_phy,inu)*piz_ae(i,k,id_ASSSM_phy,inu)+   &
+                      tau_ae_pi(i,k,id_CSSSM_phy,inu)*piz_ae(i,k,id_CSSSM_phy,inu)+   &
+                      tau_ae_pi(i,k,id_SSSSM_phy,inu)*piz_ae(i,k,id_SSSSM_phy,inu)+   &
+                      tau_ae_pi(i,k,id_CIDUSTM_phy,inu)*piz_ae(i,k,id_CIDUSTM_phy,inu)) &
+                      /tau_allaer(i,k,mrfspecies,inu)
+              piz_allaer(i,k,mrfspecies,inu)=MAX(piz_allaer(i,k,mrfspecies,inu),0.1)
+
+              cg_allaer(i,k,mrfspecies,inu)=(&
+                      tau_ae_pi(i,k,id_ASSO4M_phy,inu)*piz_ae(i,k,id_ASSO4M_phy,inu)*cg_ae(i,k,id_ASSO4M_phy,inu)+ &
+                      tau_ae_pi(i,k,id_CSSO4M_phy,inu)*piz_ae(i,k,id_CSSO4M_phy,inu)*cg_ae(i,k,id_CSSO4M_phy,inu)+ &
+                      tau_ae_pi(i,k,id_ASBCM_phy,inu)*piz_ae(i,k,id_ASBCM_phy,inu)*cg_ae(i,k,id_ASBCM_phy,inu)+ &
+                      tau_ae_pi(i,k,id_AIBCM_phy,inu)*piz_ae(i,k,id_AIBCM_phy,inu)*cg_ae(i,k,id_AIBCM_phy,inu)+ &
+                      tau_ae_pi(i,k,id_ASPOMM_phy,inu)*piz_ae(i,k,id_ASPOMM_phy,inu)*cg_ae(i,k,id_ASPOMM_phy,inu)+ &
+                      tau_ae_pi(i,k,id_AIPOMM_phy,inu)*piz_ae(i,k,id_AIPOMM_phy,inu)*cg_ae(i,k,id_AIPOMM_phy,inu)+ &
+                      tau_ae_pi(i,k,id_ASSSM_phy,inu)*piz_ae(i,k,id_ASSSM_phy,inu)*cg_ae(i,k,id_ASSSM_phy,inu)+ &
+                      tau_ae_pi(i,k,id_CSSSM_phy,inu)*piz_ae(i,k,id_CSSSM_phy,inu)*cg_ae(i,k,id_CSSSM_phy,inu)+ &
+                      tau_ae_pi(i,k,id_SSSSM_phy,inu)*piz_ae(i,k,id_SSSSM_phy,inu)*cg_ae(i,k,id_SSSSM_phy,inu)+ &
+                      tau_ae_pi(i,k,id_CIDUSTM_phy,inu)*piz_ae(i,k,id_CIDUSTM_phy,inu)*&
+                      cg_ae(i,k,id_CIDUSTM_phy,inu))/ &
+                      (tau_allaer(i,k,mrfspecies,inu)*piz_allaer(i,k,mrfspecies,inu))
+          ENDDO
+        ENDDO
+                   
+      ELSEIF (mrfspecies .EQ. 4) THEN             ! = BC
+
+        DO k=1, KLEV
+          DO i=1, KLON
+            tau_allaer(i,k,mrfspecies,inu)=tau_ae(i,k,id_ASBCM_phy,inu)+tau_ae(i,k,id_AIBCM_phy,inu)
+            tau_allaer(i,k,mrfspecies,inu)=MAX(tau_allaer(i,k,mrfspecies,inu),1e-5)
+            piz_allaer(i,k,mrfspecies,inu)=(tau_ae(i,k,id_ASBCM_phy,inu)*piz_ae(i,k,id_ASBCM_phy,inu) &
+                      +tau_ae(i,k,id_AIBCM_phy,inu)*piz_ae(i,k,id_AIBCM_phy,inu))/ &
+                      tau_allaer(i,k,mrfspecies,inu)
+            piz_allaer(i,k,mrfspecies,inu)=MAX(piz_allaer(i,k,mrfspecies,inu),0.1)
+            cg_allaer(i,k,mrfspecies,inu)=(tau_ae(i,k,id_ASBCM_phy,inu)*piz_ae(i,k,id_ASBCM_phy,inu) *cg_ae(i,k,id_ASBCM_phy,inu)&
+                      +tau_ae(i,k,id_AIBCM_phy,inu)*piz_ae(i,k,id_AIBCM_phy,inu)*cg_ae(i,k,id_AIBCM_phy,inu))/ &
+                      (tau_allaer(i,k,mrfspecies,inu)*piz_allaer(i,k,mrfspecies,inu))
+          ENDDO
+        ENDDO
+              
+      ELSEIF (mrfspecies .EQ. 5) THEN             ! = SO4
+
+        DO k=1, KLEV
+          DO i=1, KLON
+            tau_allaer(i,k,mrfspecies,inu)=tau_ae(i,k,id_ASSO4M_phy,inu)+tau_ae(i,k,id_CSSO4M_phy,inu)
+            tau_allaer(i,k,mrfspecies,inu)=MAX(tau_allaer(i,k,mrfspecies,inu),1e-5)
+            piz_allaer(i,k,mrfspecies,inu)=(tau_ae(i,k,id_CSSO4M_phy,inu)*piz_ae(i,k,id_CSSO4M_phy,inu) &
+                      +tau_ae(i,k,id_ASSO4M_phy,inu)*piz_ae(i,k,id_ASSO4M_phy,inu))/ &
+                      tau_allaer(i,k,mrfspecies,inu)
+            piz_allaer(i,k,mrfspecies,inu)=MAX(piz_allaer(i,k,mrfspecies,inu),0.1)
+            cg_allaer(i,k,mrfspecies,inu)=(tau_ae(i,k,id_CSSO4M_phy,inu)* &
+            piz_ae(i,k,id_CSSO4M_phy,inu) *cg_ae(i,k,id_CSSO4M_phy,inu)&
+            +tau_ae(i,k,id_ASSO4M_phy,inu)*piz_ae(i,k,id_ASSO4M_phy,inu)* &
+            cg_ae(i,k,id_ASSO4M_phy,inu))/ &
+            (tau_allaer(i,k,mrfspecies,inu)*piz_allaer(i,k,mrfspecies,inu))
+          ENDDO
+        ENDDO
+
+      ELSEIF (mrfspecies .EQ. 6) THEN             ! = POM
+
+        DO k=1, KLEV
+          DO i=1, KLON
+            tau_allaer(i,k,mrfspecies,inu)=tau_ae(i,k,id_ASPOMM_phy,inu)+tau_ae(i,k,id_AIPOMM_phy,inu)
+            tau_allaer(i,k,mrfspecies,inu)=MAX(tau_allaer(i,k,mrfspecies,inu),1e-5)
+            piz_allaer(i,k,mrfspecies,inu)=(tau_ae(i,k,id_ASPOMM_phy,inu)*piz_ae(i,k,id_ASPOMM_phy,inu) &
+                      +tau_ae(i,k,id_AIPOMM_phy,inu)*piz_ae(i,k,id_AIPOMM_phy,inu))/ &
+                      tau_allaer(i,k,mrfspecies,inu)
+            piz_allaer(i,k,mrfspecies,inu)=MAX(piz_allaer(i,k,mrfspecies,inu),0.1)
+            cg_allaer(i,k,mrfspecies,inu)=(tau_ae(i,k,id_ASPOMM_phy,inu)*piz_ae(i,k,id_ASPOMM_phy,inu)*cg_ae(i,k,id_ASPOMM_phy,inu)&
+                      +tau_ae(i,k,id_AIPOMM_phy,inu)*piz_ae(i,k,id_AIPOMM_phy,inu)*cg_ae(i,k,id_AIPOMM_phy,inu))/ &
+                      (tau_allaer(i,k,mrfspecies,inu)*piz_allaer(i,k,mrfspecies,inu))
+          ENDDO
+        ENDDO
+              
+      ELSEIF (mrfspecies .EQ. 7) THEN             ! = DUST
+
+        DO k=1, KLEV
+          DO i=1, KLON
+            tau_allaer(i,k,mrfspecies,inu)=tau_ae(i,k,id_CIDUSTM_phy,inu)
+            tau_allaer(i,k,mrfspecies,inu)=MAX(tau_allaer(i,k,mrfspecies,inu),1e-5)
+            piz_allaer(i,k,mrfspecies,inu)=piz_ae(i,k,id_CIDUSTM_phy,inu)
+            cg_allaer(i,k,mrfspecies,inu)=cg_ae(i,k,id_CIDUSTM_phy,inu)
+          ENDDO
+        ENDDO
+
+      ELSEIF (mrfspecies .EQ. 8) THEN             ! = SS
+
+        DO k=1, KLEV
+          DO i=1, KLON
+            tau_allaer(i,k,mrfspecies,inu)=tau_ae(i,k,id_ASSSM_phy,inu)+tau_ae(i,k,id_CSSSM_phy,inu)+tau_ae(i,k,id_SSSSM_phy,inu)
+            tau_allaer(i,k,mrfspecies,inu)=MAX(tau_allaer(i,k,mrfspecies,inu),1e-5)
+            piz_allaer(i,k,mrfspecies,inu)=(tau_ae(i,k,id_ASSSM_phy,inu)*piz_ae(i,k,id_ASSSM_phy,inu) &
+                    +tau_ae(i,k,id_CSSSM_phy,inu)*piz_ae(i,k,id_CSSSM_phy,inu) &
+                    +tau_ae(i,k,id_SSSSM_phy,inu)*piz_ae(i,k,id_SSSSM_phy,inu))/ &
+                    tau_allaer(i,k,mrfspecies,inu)
+            piz_allaer(i,k,mrfspecies,inu)=MAX(piz_allaer(i,k,mrfspecies,inu),0.1)
+            cg_allaer(i,k,mrfspecies,inu)=(tau_ae(i,k,id_ASSSM_phy,inu)*piz_ae(i,k,id_ASSSM_phy,inu) *cg_ae(i,k,id_ASSSM_phy,inu)&
+                    +tau_ae(i,k,id_CSSSM_phy,inu)*piz_ae(i,k,id_CSSSM_phy,inu)*cg_ae(i,k,id_CSSSM_phy,inu) &
+                    +tau_ae(i,k,id_SSSSM_phy,inu)*piz_ae(i,k,id_SSSSM_phy,inu)*cg_ae(i,k,id_SSSSM_phy,inu))/ &
+                    (tau_allaer(i,k,mrfspecies,inu)*piz_allaer(i,k,mrfspecies,inu))
+          ENDDO
+        ENDDO
+      
+      ELSEIF (mrfspecies .EQ. 9) THEN             ! = NO3
+      
+        DO k=1, KLEV
+          DO i=1, KLON
+            tau_allaer(i,k,mrfspecies,inu)=0.   ! preliminary
+            piz_allaer(i,k,mrfspecies,inu)=0.
+            cg_allaer(i,k,mrfspecies,inu)=0.
+          ENDDO
+        ENDDO
+      
+      ELSE
+
+        DO k=1, KLEV
+          DO i=1, KLON
+            tau_allaer(i,k,mrfspecies,inu)=0.  
+            piz_allaer(i,k,mrfspecies,inu)=0.
+            cg_allaer(i,k,mrfspecies,inu)=0.
+          ENDDO
+        ENDDO
+           
+      ENDIF
+
+    ENDDO
+  ENDDO
+
+  DEALLOCATE(aerosol_name) 
+
+END SUBROUTINE AEROPT_2BANDS
Index: DZ6/trunk/libf/phylmd/aeropt_5wv.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/aeropt_5wv.F90	(revision 5267)
+++ 	(revision )
@@ -1,826 +1,0 @@
-!
-! $Id$
-!
-
-SUBROUTINE AEROPT_5WV(&
-   pdel, m_allaer, delt, &
-   RHcl, ai, flag_aerosol, &
-   pplay, t_seri, &
-   tausum, tau, presnivs)
-
-  USE DIMPHY
-  USE aero_mod
-  USE phys_local_var_mod, only: od550aer,od865aer,ec550aer,od550lt1aer
-  USE pres2lev_mod
-
-  !
-  !    Yves Balkanski le 12 avril 2006
-  !    Celine Deandreis
-  !    Anne Cozic  Avril 2009
-  !    a partir d'une sous-routine de Johannes Quaas pour les sulfates
-  !
-  !
-  ! Refractive indices for seasalt come from Shettle and Fenn (1979)
-  !
-  ! Refractive indices from water come from Hale and Querry (1973)
-  !
-  ! Refractive indices from Ammonium Sulfate Toon and Pollack (1976)
-  !
-  ! Refractive indices for Dust, internal mixture of minerals coated with 1.5% hematite 
-  ! by Volume (Balkanski et al., 2006)
-  !
-  ! Refractive indices for POM: Kinne (pers. Communication 
-  !
-  ! Refractive index for BC from Shettle and Fenn (1979)
-  !
-  ! Shettle, E. P., & Fenn, R. W. (1979), Models for the aerosols of the lower atmosphere and 
-  ! the effects of humidity variations on their optical properties, U.S. Air Force Geophysics 
-  ! Laboratory Rept. AFGL-TR-79-0214, Hanscomb Air Force Base, MA.
-  !
-  ! Hale, G. M. and M. R. Querry, Optical constants of water in the 200-nm to 200-m 
-  ! wavelength region, Appl. Opt., 12, 555-563, 1973.
-  !
-  ! Toon, O. B. and J. B. Pollack, The optical constants of several atmospheric aerosol species:
-  ! Ammonium sulfate, aluminum oxide, and sodium chloride, J. Geohys. Res., 81, 5733-5748,
-  ! 1976.
-  !
-  ! Balkanski, Y., M. Schulz, T. Claquin And O. Boucher, Reevaluation of mineral aerosol 
-  ! radiative forcings suggests a better agreement with satellite and AERONET data, Atmospheric 
-  ! Chemistry and Physics Discussions., 6, pp 8383-8419, 2006.
-  !
-  IMPLICIT NONE
-  INCLUDE "YOMCST.h"
-  !
-  ! Input arguments:
-  !
-  REAL, DIMENSION(klon,klev), INTENT(in)   :: pdel
-  REAL, INTENT(in)                         :: delt
-  REAL, DIMENSION(klon,klev,naero_tot), INTENT(in) :: m_allaer
-  REAL, DIMENSION(klon,klev), INTENT(in)   :: RHcl     ! humidite relative ciel clair
-  INTEGER,INTENT(in)                       :: flag_aerosol
-  REAL, DIMENSION(klon,klev), INTENT(in)   :: pplay
-  REAL, DIMENSION(klon,klev), INTENT(in)   :: t_seri
-  REAL, DIMENSION(klev),      INTENT(in)   :: presnivs
-  !
-  ! Output arguments:
-  !
-  REAL, DIMENSION(klon), INTENT(out)          :: ai      ! POLDER aerosol index
-  REAL, DIMENSION(klon,nwave,naero_tot), INTENT(out)      :: tausum
-  REAL, DIMENSION(klon,klev,nwave,naero_tot), INTENT(out) :: tau
-  !
-  ! Local
-  !
-  INTEGER, PARAMETER :: las = nwave_sw
-  LOGICAL :: soluble
-  
-  INTEGER :: i, k, ierr, m, aerindex
-  INTEGER :: spsol, spinsol, spss, la
-  INTEGER :: RH_num(klon,klev)
-  INTEGER, PARAMETER :: la443 = 1
-  INTEGER, PARAMETER :: la550 = 2
-  INTEGER, PARAMETER :: la670 = 3
-  INTEGER, PARAMETER :: la765 = 4
-  INTEGER, PARAMETER :: la865 = 5
-  INTEGER, PARAMETER :: nbre_RH=12
-  INTEGER, PARAMETER :: naero_soluble=7   !  1- BC soluble; 2- POM soluble; 3- SO4 acc.
-                                          !  4- SO4 coarse; 5 seasalt super-C; 6 seasalt coarse; 7 seasalt acc.
-  INTEGER, PARAMETER :: naero_insoluble=3 !  1- Dust; 2- BC insoluble; 3- POM insoluble
-  INTEGER, PARAMETER :: nb_level = 19     ! number of vertical levels
-  LOGICAL, SAVE :: firstcall=.TRUE.
-!$OMP THREADPRIVATE(firstcall)
-
-  REAL :: zrho
-
-  ! Coefficient optiques sur 19 niveaux
-  REAL, SAVE, DIMENSION(nb_level) :: presnivs_19  ! Pression milieux couche pour 19 niveaux (nb_level)
-!$OMP THREADPRIVATE(presnivs_19)
-
-  REAL, SAVE, DIMENSION(nb_level) :: A1_ASSSM_19, A2_ASSSM_19, A3_ASSSM_19,&
-          B1_ASSSM_19, B2_ASSSM_19, C1_ASSSM_19, C2_ASSSM_19,&
-          A1_CSSSM_19, A2_CSSSM_19, A3_CSSSM_19,&
-          B1_CSSSM_19, B2_CSSSM_19, C1_CSSSM_19, C2_CSSSM_19, &
-          A1_SSSSM_19, A2_SSSSM_19, A3_SSSSM_19,&
-          B1_SSSSM_19, B2_SSSSM_19, C1_SSSSM_19, C2_SSSSM_19
-!$OMP THREADPRIVATE(A1_ASSSM_19, A2_ASSSM_19, A3_ASSSM_19)
-!$OMP THREADPRIVATE(B1_ASSSM_19, B2_ASSSM_19, C1_ASSSM_19, C2_ASSSM_19)
-!$OMP THREADPRIVATE(A1_CSSSM_19, A2_CSSSM_19, A3_CSSSM_19)
-!$OMP THREADPRIVATE(B1_CSSSM_19, B2_CSSSM_19, C1_CSSSM_19, C2_CSSSM_19)
-!$OMP THREADPRIVATE(A1_SSSSM_19, A2_SSSSM_19, A3_SSSSM_19)
-!$OMP THREADPRIVATE(B1_SSSSM_19, B2_SSSSM_19, C1_SSSSM_19, C2_SSSSM_19)
-
-  ! Coefficient optiques interpole sur le nombre de niveau du modele
-  REAL, ALLOCATABLE,  DIMENSION(:), SAVE :: &
-          A1_ASSSM, A2_ASSSM, A3_ASSSM,&
-          B1_ASSSM, B2_ASSSM, C1_ASSSM, C2_ASSSM,&
-          A1_CSSSM, A2_CSSSM, A3_CSSSM,&
-          B1_CSSSM, B2_CSSSM, C1_CSSSM, C2_CSSSM, &
-          A1_SSSSM, A2_SSSSM, A3_SSSSM,&
-          B1_SSSSM, B2_SSSSM, C1_SSSSM, C2_SSSSM
-!$OMP THREADPRIVATE(A1_ASSSM, A2_ASSSM, A3_ASSSM)
-!$OMP THREADPRIVATE(B1_ASSSM, B2_ASSSM, C1_ASSSM, C2_ASSSM)
-!$OMP THREADPRIVATE(A1_CSSSM, A2_CSSSM, A3_CSSSM)
-!$OMP THREADPRIVATE(B1_CSSSM, B2_CSSSM, C1_CSSSM, C2_CSSSM)
-!$OMP THREADPRIVATE(A1_SSSSM, A2_SSSSM, A3_SSSSM)
-!$OMP THREADPRIVATE(B1_SSSSM, B2_SSSSM, C1_SSSSM, C2_SSSSM)
-
-
-  REAL,PARAMETER :: RH_tab(nbre_RH)=(/0.,10.,20.,30.,40.,50.,60.,70.,80.,85.,90.,95./)
-  REAL :: DELTA(klon,klev), rh(klon,klev), H
-  REAL :: tau_ae5wv_int ! Intermediate computation of epaisseur optique aerosol
-  REAL :: piz_ae5wv_int ! Intermediate single scattering albedo aerosol
-  REAL :: cg_ae5wv_int  ! Intermediate asymmetry parameter aerosol
-  REAL, PARAMETER :: RH_MAX=95.
-  REAL :: taue670(klon)       ! epaisseur optique aerosol absorption 550 nm
-  REAL :: taue865(klon)       ! epaisseur optique aerosol extinction 865 nm
-  REAL :: fac
-  INTEGER, ALLOCATABLE, DIMENSION(:)  :: aerosol_name
-  INTEGER :: nb_aer
-  
-  REAL :: tau3d(klon,klev), piz3d(klon,klev), cg3d(klon,klev)
-  REAL :: abs3d(klon,klev)     ! epaisseur optique d'absorption
-  REAL :: dh(klon,klev)
-  
-  REAL :: alpha_aers_5wv(nbre_RH,las,naero_soluble)   ! ext. coeff. Soluble comp. units *** m2/g 
-   !  1- BC soluble; 2- POM soluble; 3- SO4 acc.; 4- SO4 coarse; 5 seasalt super-C; 6 seasalt coarse; 7 seasalt acc.
-  REAL :: alpha_aeri_5wv(las,naero_insoluble)         ! ext. coeff. Insoluble comp. 1- Dust: 2- BC; 3- POM
-  REAL :: cg_aers_5wv(nbre_RH,las,naero_soluble)      ! Asym. param. soluble comp. 
-   !  1- BC soluble; 2- POM soluble; 3- SO4 acc.; 4- SO4 coarse; 5 seasalt super-C; 6 seasalt coarse; 7 seasalt acc.
-  REAL :: cg_aeri_5wv(las,naero_insoluble)            ! Asym. param. insoluble comp. 1- Dust: 2- BC; 3- POM
-  REAL :: piz_aers_5wv(nbre_RH,las,naero_soluble)   
-   !  1- BC soluble; 2- POM soluble; 3- SO4 acc.; 4- SO4 coarse; 5 seasalt super-C; 6 seasalt coarse; 7 seasalt acc.
-  REAL :: piz_aeri_5wv(las,naero_insoluble)           ! Insoluble comp. 1- Dust: 2- BC; 3- POM
-  !
-  ! Proprietes optiques
-  !
-  REAL :: fact_RH(nbre_RH)
-  LOGICAL :: used_tau(naero_spc)
-  INTEGER :: n
-  
-  DATA presnivs_19/&
-       100426.5,  98327.6, 95346.5, 90966.8, 84776.9, &
-       76536.5,   66292.2, 54559.3, 42501.8, 31806, &
-       23787.5,   18252.7, 13996,   10320.8, 7191.1, &
-       4661.7,    2732.9,  1345.6,  388.2/
-
-!!ACCUMULATION MODE
-  DATA A1_ASSSM_19/ 4.373E+00,  4.361E+00,  4.331E+00, &
-                 4.278E+00,  4.223E+00,  4.162E+00, &
-                 4.103E+00,  4.035E+00,  3.962E+00, &
-                 3.904E+00,  3.871E+00,  3.847E+00, &
-                 3.824E+00,  3.780E+00,  3.646E+00, &
-                 3.448E+00,  3.179E+00,  2.855E+00,  2.630E+00/
-  DATA A2_ASSSM_19/ 2.496E+00,  2.489E+00,  2.472E+00, &
-                 2.442E+00,  2.411E+00,  2.376E+00, &
-                 2.342E+00,  2.303E+00,  2.261E+00, &
-                 2.228E+00,  2.210E+00,  2.196E+00, &
-                 2.183E+00,  2.158E+00,  2.081E+00, &
-                 1.968E+00,  1.814E+00,  1.630E+00,  1.501E+00/
-  DATA A3_ASSSM_19/-4.688E-02, -4.676E-02, -4.644E-02, &
-                -4.587E-02, -4.528E-02, -4.463E-02, &
-                -4.399E-02, -4.326E-02, -4.248E-02, &
-                -4.186E-02, -4.151E-02, -4.125E-02, &
-                -4.100E-02, -4.053E-02, -3.910E-02, &
-                -3.697E-02, -3.408E-02, -3.061E-02, -2.819E-02/
-  DATA B1_ASSSM_19/ 1.165E-08,  1.145E-08,  1.097E-08, &
-                 1.012E-08,  9.233E-09,  8.261E-09, &
-                 7.297E-09,  6.201E-09,  5.026E-09, &
-                 4.098E-09,  3.567E-09,  3.187E-09, &
-                 2.807E-09,  2.291E-09,  2.075E-09, &
-                 1.756E-09,  1.322E-09,  8.011E-10, 4.379E-10/
-  DATA B2_ASSSM_19/ 2.193E-08,  2.192E-08,  2.187E-08, &
-                 2.179E-08,  2.171E-08,  2.162E-08, &
-                 2.153E-08,  2.143E-08,  2.132E-08, &
-                 2.124E-08,  2.119E-08,  2.115E-08, &
-                 2.112E-08,  2.106E-08,  2.100E-08, &
-                 2.090E-08,  2.077E-08,  2.061E-08,  2.049E-08/
-  DATA C1_ASSSM_19/ 7.365E-01,  7.365E-01,  7.365E-01, &
-                 7.364E-01,  7.363E-01,  7.362E-01, &
-                 7.361E-01,  7.359E-01,  7.358E-01, &
-                 7.357E-01,  7.356E-01,  7.356E-01, &
-                 7.356E-01,  7.355E-01,  7.354E-01, &
-                 7.352E-01,  7.350E-01,  7.347E-01,  7.345E-01/
-  DATA C2_ASSSM_19/ 5.833E-02,  5.835E-02,  5.841E-02, &
-                 5.850E-02,  5.859E-02,  5.870E-02, &
-                 5.880E-02,  5.891E-02,  5.904E-02, &
-                 5.914E-02,  5.920E-02,  5.924E-02, &
-                 5.928E-02,  5.934E-02,  5.944E-02, &
-                 5.959E-02,  5.979E-02,  6.003E-02,  6.020E-02/
-!COARSE MODE
-  DATA A1_CSSSM_19/ 7.403E-01,  7.422E-01,  7.626E-01, &
-                 8.019E-01,  8.270E-01,  8.527E-01, &
-                 8.702E-01,  8.806E-01,  8.937E-01, &
-                 9.489E-01,  1.030E+00,  1.105E+00, &
-                 1.199E+00,  1.357E+00,  1.660E+00, &
-                 2.540E+00,  4.421E+00,  2.151E+00,  9.518E-01/
-  DATA A2_CSSSM_19/ 4.522E-01,  4.532E-01,  4.644E-01, &
-                 4.859E-01,  4.996E-01,  5.137E-01, &
-                 5.233E-01,  5.290E-01,  5.361E-01, &
-                 5.655E-01,  6.085E-01,  6.483E-01, &
-                 6.979E-01,  7.819E-01,  9.488E-01, &
-                 1.450E+00,  2.523E+00,  1.228E+00,  5.433E-01/
-  DATA A3_CSSSM_19/-8.516E-03, -8.535E-03, -8.744E-03, &
-                -9.148E-03, -9.406E-03, -9.668E-03, &
-                -9.848E-03, -9.955E-03, -1.009E-02, &
-                -1.064E-02, -1.145E-02, -1.219E-02, &
-                -1.312E-02, -1.470E-02, -1.783E-02, &
-                -2.724E-02, -4.740E-02, -2.306E-02, -1.021E-02/
-  DATA B1_CSSSM_19/ 2.535E-07,  2.530E-07,  2.479E-07, &
-                 2.380E-07,  2.317E-07,  2.252E-07, &
-                 2.208E-07,  2.182E-07,  2.149E-07, &
-                 2.051E-07,  1.912E-07,  1.784E-07, &
-                 1.624E-07,  1.353E-07,  1.012E-07, &
-                 6.016E-08,  2.102E-08,  0.000E+00,  0.000E+00/
-  DATA B2_CSSSM_19/ 1.221E-07,  1.217E-07,  1.179E-07, &
-                 1.104E-07,  1.056E-07,  1.008E-07, &
-                 9.744E-08,  9.546E-08,  9.299E-08, &
-                 8.807E-08,  8.150E-08,  7.544E-08, &
-                 6.786E-08,  5.504E-08,  4.080E-08, &
-                 2.960E-08,  2.300E-08,  2.030E-08,  1.997E-08/
-  DATA C1_CSSSM_19/ 7.659E-01,  7.658E-01,  7.652E-01, &
-                 7.639E-01,  7.631E-01,  7.623E-01, &
-                 7.618E-01,  7.614E-01,  7.610E-01, &
-                 7.598E-01,  7.581E-01,  7.566E-01, &
-                 7.546E-01,  7.513E-01,  7.472E-01, &
-                 7.423E-01,  7.376E-01,  7.342E-01,  7.334E-01/
-  DATA C2_CSSSM_19/ 3.691E-02,  3.694E-02,  3.729E-02, &
-                 3.796E-02,  3.839E-02,  3.883E-02, &
-                 3.913E-02,  3.931E-02,  3.953E-02, &
-                 4.035E-02,  4.153E-02,  4.263E-02, &
-                 4.400E-02,  4.631E-02,  4.933E-02, &
-                 5.331E-02,  5.734E-02,  6.053E-02,  6.128E-02/
-!SUPER COARSE MODE
-  DATA A1_SSSSM_19/ 2.836E-01,  2.876E-01,  2.563E-01, &
-                 2.414E-01,  2.541E-01,  2.546E-01, &
-                 2.572E-01,  2.638E-01,  2.781E-01, &
-                 3.167E-01,  4.209E-01,  5.286E-01, &
-                 6.959E-01,  9.233E-01,  1.282E+00, &
-                 1.836E+00,  2.981E+00,  4.355E+00,  4.059E+00/
-  DATA A2_SSSSM_19/ 1.608E-01,  1.651E-01,  1.577E-01, &
-                 1.587E-01,  1.686E-01,  1.690E-01, &
-                 1.711E-01,  1.762E-01,  1.874E-01, &
-                 2.138E-01,  2.751E-01,  3.363E-01, &
-                 4.279E-01,  5.519E-01,  7.421E-01, &
-                 1.048E+00,  1.702E+00,  2.485E+00,  2.317E+00/
-  DATA A3_SSSSM_19/-3.025E-03, -3.111E-03, -2.981E-03, &
-                -3.005E-03, -3.193E-03, -3.200E-03, &
-                -3.239E-03, -3.336E-03, -3.548E-03, &
-                -4.047E-03, -5.196E-03, -6.345E-03, &
-                -8.061E-03, -1.038E-02, -1.395E-02, &
-                -1.970E-02, -3.197E-02, -4.669E-02, -4.352E-02/
-  DATA B1_SSSSM_19/ 6.759E-07,  6.246E-07,  5.542E-07, &
-                 4.953E-07,  4.746E-07,  4.738E-07, &
-                 4.695E-07,  4.588E-07,  4.354E-07, &
-                 3.947E-07,  3.461E-07,  3.067E-07, &
-                 2.646E-07,  2.095E-07,  1.481E-07, &
-                 9.024E-08,  5.747E-08,  2.384E-08,  6.599E-09/
-  DATA B2_SSSSM_19/ 5.977E-07,  5.390E-07,  4.468E-07, &
-                 3.696E-07,  3.443E-07,  3.433E-07, &
-                 3.380E-07,  3.249E-07,  2.962E-07, &
-                 2.483E-07,  1.989E-07,  1.623E-07, &
-                 1.305E-07,  9.015E-08,  6.111E-08, &
-                 3.761E-08,  2.903E-08,  2.337E-08,  2.147E-08/
-  DATA C1_SSSSM_19/ 8.120E-01,  8.084E-01,  8.016E-01, &
-                 7.953E-01,  7.929E-01,  7.928E-01, &
-                 7.923E-01,  7.910E-01,  7.882E-01, &
-                 7.834E-01,  7.774E-01,  7.725E-01, &
-                 7.673E-01,  7.604E-01,  7.529E-01, &
-                 7.458E-01,  7.419E-01,  7.379E-01,  7.360E-01/
-  DATA C2_SSSSM_19/ 2.388E-02,  2.392E-02,  2.457E-02,  2.552E-02, &
-                 2.615E-02,  2.618E-02,  2.631E-02,  2.663E-02, &
-                 2.735E-02,  2.875E-02,  3.113E-02,  3.330E-02, &
-                 3.615E-02,  3.997E-02,  4.521E-02,  5.038E-02, &
-                 5.358E-02,  5.705E-02,  5.887E-02/
-!*********************************************************************
-!
-! 
-! From here on we look at the optical parameters at 5 wavelengths:  
-! 443nm, 550, 670, 765 and 865 nm 
-!                                   le 12 AVRIL 2006 
-!  
- DATA alpha_aers_5wv/ & 
-                                ! bc soluble 
-       7.930,7.930,7.930,7.930,7.930,7.930,     & 
-       7.930,7.930,10.893,12.618,14.550,16.613, & 
-       7.658,7.658,7.658,7.658,7.658,7.658,     & 
-       7.658,7.658,10.351,11.879,13.642,15.510, & 
-       7.195,7.195,7.195,7.195,7.195,7.195,     & 
-       7.195,7.195,9.551,10.847,12.381,13.994,  & 
-       6.736,6.736,6.736,6.736,6.736,6.736,     & 
-       6.736,6.736,8.818,9.938,11.283,12.687,   & 
-       6.277,6.277,6.277,6.277,6.277,6.277,     & 
-       6.277,6.277,8.123,9.094,10.275,11.501,   & 
-                                ! pom soluble 
-       6.676,6.676,6.676,6.676,6.710,6.934,   & 
-       7.141,7.569,8.034,8.529,9.456,10.511,  & 
-       5.109,5.109,5.109,5.109,5.189,5.535,   & 
-       5.960,6.852,8.008,9.712,12.897,19.676, & 
-       3.718,3.718,3.718,3.718,3.779,4.042,   & 
-       4.364,5.052,5.956,7.314,9.896,15.688,  & 
-       2.849,2.849,2.849,2.849,2.897,3.107,   & 
-       3.365,3.916,4.649,5.760,7.900,12.863,  & 
-       2.229,2.229,2.229,2.229,2.268,2.437,   & 
-       2.645,3.095,3.692,4.608,6.391,10.633,  & 
-                                ! Sulfate (Accumulation) 
-       5.751,6.215,6.690,7.024,7.599,8.195,      & 
-       9.156,10.355,12.660,14.823,18.908,24.508, & 
-       4.320,4.675,5.052,5.375,5.787,6.274,      & 
-       7.066,8.083,10.088,12.003,15.697,21.133,  & 
-       3.079,3.351,3.639,3.886,4.205,4.584,      & 
-       5.206,6.019,7.648,9.234,12.391,17.220,    & 
-       2.336,2.552,2.781,2.979,3.236,3.540,      & 
-       4.046,4.711,6.056,7.388,10.093,14.313,    & 
-       1.777,1.949,2.134,2.292,2.503,2.751,      & 
-       3.166,3.712,4.828,5.949,8.264,11.922,     & 
-                                ! Sulfate (Coarse) 
-       5.751,6.215,6.690,7.024,7.599,8.195,      & 
-       9.156,10.355,12.660,14.823,18.908,24.508, & 
-       4.320,4.675,5.052,5.375,5.787,6.274,      & 
-       7.066,8.083,10.088,12.003,15.697,21.133,  & 
-       3.079,3.351,3.639,3.886,4.205,4.584,      & 
-       5.206,6.019,7.648,9.234,12.391,17.220,    & 
-       2.336,2.552,2.781,2.979,3.236,3.540,      & 
-       4.046,4.711,6.056,7.388,10.093,14.313,    & 
-       1.777,1.949,2.134,2.292,2.503,2.751,      & 
-       3.166,3.712,4.828,5.949,8.264,11.922,     & 
-                                ! Seasalt soluble super_coarse (computed below for 550nm) 
-       0.50,0.90,1.05,1.21,1.40,2.41, &  
-       2.66,3.11,3.88,4.52,5.69,8.84, &  
-       0.000,0.000,0.000,0.000,0.000,0.000, &  
-       0.000,0.000,0.000,0.000,0.000,0.000, &  
-     0.52,0.93,1.08,1.24,1.43,2.47, &  
-     2.73,3.20,3.99,4.64,5.84,9.04, &  
-     0.52,0.93,1.09,1.25,1.44,2.50, &  
-     2.76,3.23,4.03,4.68,5.89,9.14, &  
-     0.52,0.94,1.09,1.26,1.45,2.51, &  
-     2.78,3.25,4.06,4.72,5.94,9.22, &  
-                                ! seasalt soluble coarse (computed below for 550nm) 
-       0.50,0.90,1.05,1.21,1.40,2.41, &  
-       2.66,3.11,3.88,4.52,5.69,8.84, &  
-       0.000,0.000,0.000,0.000,0.000,0.000, &  
-       0.000,0.000,0.000,0.000,0.000,0.000, &  
-     0.52,0.93,1.08,1.24,1.43,2.47, &  
-     2.73,3.20,3.99,4.64,5.84,9.04, &  
-     0.52,0.93,1.09,1.25,1.44,2.50, &  
-     2.76,3.23,4.03,4.68,5.89,9.14, &  
-     0.52,0.94,1.09,1.26,1.45,2.51, &  
-     2.78,3.25,4.06,4.72,5.94,9.22, &  
-                                ! seasalt soluble accumulation (computed below for 550nm) 
-     4.28, 7.17, 8.44, 9.85,11.60,22.44,  &  
-     25.34,30.54,39.38,46.52,59.33,91.77, &  
-       0.000,0.000,0.000,0.000,0.000,0.000, &  
-       0.000,0.000,0.000,0.000,0.000,0.000, &  
-     2.48, 4.22, 5.02, 5.94, 7.11,15.29,  &  
-     17.70,22.31,30.73,38.06,52.15,90.59, &  
-     1.90, 3.29, 3.94, 4.69, 5.65, 12.58, &  
-     14.68,18.77,26.41,33.25,46.77,85.50, &  
-     1.47, 2.59, 3.12, 3.74, 4.54, 10.42, &  
-     12.24,15.82,22.66,28.91,41.54,79.33/ 
-
-  DATA alpha_aeri_5wv/ &
-                                 ! dust insoluble 
-        0.759, 0.770, 0.775, 0.775, 0.772, & 
-                                 !!jb bc insoluble 
-        11.536,10.033, 8.422, 7.234, 6.270, & 
-                                 ! pom insoluble 
-        5.042, 3.101, 1.890, 1.294, 0.934/ 
-   ! 
-  DATA cg_aers_5wv/ &  
-                                 ! bc soluble 
-      .651, .651, .651, .651, .651, .651, & 
-      .651, .651, .738, .764, .785, .800, & 
-      .597, .597, .597, .597, .597, .597, & 
-      .597, .597, .695, .725, .751, .770, & 
-      .543, .543, .543, .543, .543, .543, & 
-      .543, .543, .650, .684, .714, .736, &  
-      .504, .504, .504, .504, .504, .504, & 
-      .504, .504, .614, .651, .683, .708, &  
-      .469, .469, .469, .469, .469, .469, & 
-      .469, .469, .582, .620, .655, .681, & 
-                                 ! pom soluble 
-      .679, .679, .679, .679, .683, .691, & 
-      .703, .720, .736, .751, .766, .784, & 
-      .656, .656, .656, .656, .659, .669, & 
-      .681, .699, .717, .735, .750, .779, &  
-      .623, .623, .623, .623, .627, .637, & 
-      .649, .668, .688, .709, .734, .762, & 
-      .592, .592, .592, .592, .595, .605, & 
-      .618, .639, .660, .682, .711, .743, & 
-      .561, .561, .561, .561, .565, .575, & 
-      .588, .609, .632, .656, .688, .724, & 
-                                 ! Accumulation sulfate 
-      .671, .684, .697, .704, .714, .723, & 
-      .734, .746, .762, .771, .781, .789, & 
-      .653, .666, .678, .687, .697, .707, & 
-      .719, .732, .751, .762, .775, .789, & 
-      .622, .635, .648, .657, .667, .678, & 
-      .691, .705, .728, .741, .758, .777, & 
-      .591, .604, .617, .627, .638, .650, & 
-      .664, .679, .704, .719, .739, .761, & 
-      .560, .574, .587, .597, .609, .621, &  
-      .637, .653, .680, .697, .719, .745, & 
-                                 ! Coarse sulfate 
-      .671, .684, .697, .704, .714, .723, & 
-      .734, .746, .762, .771, .781, .789, & 
-      .653, .666, .678, .687, .697, .707, & 
-      .719, .732, .751, .762, .775, .789, & 
-      .622, .635, .648, .657, .667, .678, & 
-      .691, .705, .728, .741, .758, .777, & 
-      .591, .604, .617, .627, .638, .650, & 
-      .664, .679, .704, .719, .739, .761, & 
-      .560, .574, .587, .597, .609, .621, &  
-      .637, .653, .680, .697, .719, .745, & 
-                                 ! For super coarse seasalt (computed below for 550nm!) 
-      0.730,0.753,0.760,0.766,0.772,0.793, &  
-      0.797,0.802,0.809,0.813,0.820,0.830, &  
-      0.000,0.000,0.000,0.000,0.000,0.000, &  
-      0.000,0.000,0.000,0.000,0.000,0.000, &  
-      0.721,0.744,0.750,0.756,0.762,0.784, &  
-      0.787,0.793,0.800,0.804,0.811,0.822, &  
-      0.717,0.741,0.747,0.753,0.759,0.780, &  
-      0.784,0.789,0.795,0.800,0.806,0.817, &  
-      0.715,0.739,0.745,0.751,0.757,0.777, &   
-      0.781,0.786,0.793,0.797,0.803,0.814, &  
-                                 ! For coarse-soluble seasalt (computed below for 550nm!) 
-      0.730,0.753,0.760,0.766,0.772,0.793, &  
-      0.797,0.802,0.809,0.813,0.820,0.830, &  
-      0.000,0.000,0.000,0.000,0.000,0.000, &  
-      0.000,0.000,0.000,0.000,0.000,0.000, &  
-      0.721,0.744,0.750,0.756,0.762,0.784, &  
-      0.787,0.793,0.800,0.804,0.811,0.822, &  
-      0.717,0.741,0.747,0.753,0.759,0.780, &  
-      0.784,0.789,0.795,0.800,0.806,0.817, &  
-      0.715,0.739,0.745,0.751,0.757,0.777, &   
-      0.781,0.786,0.793,0.797,0.803,0.814, &  
-                                 ! accumulation-seasalt soluble (computed below for 550nm!)  
-      0.698,0.722,0.729,0.736,0.743,0.765, &  
-      0.768,0.773,0.777,0.779,0.781,0.779, &  
-      0.000,0.000,0.000,0.000,0.000,0.000, &  
-      0.000,0.000,0.000,0.000,0.000,0.000, &  
-      0.658,0.691,0.701,0.710,0.720,0.756, &  
-      0.763,0.771,0.782,0.788,0.795,0.801, &  
-      0.632,0.668,0.679,0.690,0.701,0.743, &  
-      0.750,0.762,0.775,0.783,0.792,0.804, &  
-      0.605,0.644,0.656,0.669,0.681,0.729, &  
-      0.737,0.750,0.765,0.775,0.787,0.803/
- !
-  DATA cg_aeri_5wv/&
-     ! dust insoluble
-     0.714, 0.697, 0.688, 0.683, 0.679, &
-     ! bc insoluble
-     0.511, 0.445, 0.384, 0.342, 0.307, &
-     !c pom insoluble
-     0.596, 0.536, 0.466, 0.409, 0.359/
-  !
-  DATA piz_aers_5wv/&
-                           ! bc soluble 
-  .445, .445, .445, .445, .445, .445, & 
-  .445, .445, .470, .487, .508, .531, & 
-  .442, .442, .442, .442, .442, .442, & 
-  .442, .442, .462, .481, .506, .533, & 
-  .427, .427, .427, .427, .427, .427, & 
-  .427, .427, .449, .470, .497, .526, & 
-  .413, .413, .413, .413, .413, .413, & 
-  .413, .413, .437, .458, .486, .516, & 
-  .399, .399, .399, .399, .399, .399, & 
-  .399, .399, .423, .445, .473, .506, & 
-                           ! pom soluble 
-  .975, .975, .975, .975, .975, .977, & 
-  .979, .982, .984, .987, .990, .994, & 
-  .972, .972, .972, .972, .973, .974, & 
-  .977, .980, .983, .986, .989, .993, & 
-  .963, .963, .963, .963, .964, .966, & 
-  .969, .974, .977, .982, .986, .991, & 
-  .955, .955, .955, .955, .955, .958, & 
-  .962, .967, .972, .977, .983, .989, & 
-  .944, .944, .944, .944, .944, .948, & 
-  .952, .959, .962, .972, .979, .987, & 
-                           ! sulfate soluble accumulation 
-  1.000,1.000,1.000,1.000,1.000,1.000, & 
-  1.000,1.000,1.000,1.000,1.000,1.000, & 
-  1.000,1.000,1.000,1.000,1.000,1.000, & 
-  1.000,1.000,1.000,1.000,1.000,1.000, & 
-  1.000,1.000,1.000,1.000,1.000,1.000, & 
-  1.000,1.000,1.000,1.000,1.000,1.000, & 
-  1.000,1.000,1.000,1.000,1.000,1.000, & 
-  1.000,1.000,1.000,1.000,1.000,1.000, & 
-  1.000,1.000,1.000,1.000,1.000,1.000, & 
-  1.000,1.000,1.000,1.000,1.000,1.000, & 
-                           ! sulfate soluble coarse 
-  1.000,1.000,1.000,1.000,1.000,1.000, &  
-  1.000,1.000,1.000,1.000,1.000,1.000, &  
-  1.000,1.000,1.000,1.000,1.000,1.000, &  
-  1.000,1.000,1.000,1.000,1.000,1.000, &  
-  1.000,1.000,1.000,1.000,1.000,1.000, &  
-  1.000,1.000,1.000,1.000,1.000,1.000, &  
-  1.000,1.000,1.000,1.000,1.000,1.000, &  
-  1.000,1.000,1.000,1.000,1.000,1.000, &  
-  1.000,1.000,1.000,1.000,1.000,1.000, &  
-  1.000,1.000,1.000,1.000,1.000,1.000, &  
-                           ! seasalt super coarse (computed below for 550nm) 
-  1.000,1.000,1.000,1.000,1.000,1.000, &  
-  1.000,1.000,1.000,1.000,1.000,1.000, &  
-  1.000,1.000,1.000,1.000,1.000,1.000, &  
-  1.000,1.000,1.000,1.000,1.000,1.000, &  
-  1.000,1.000,1.000,1.000,1.000,1.000, &  
-  1.000,1.000,1.000,1.000,1.000,1.000, &  
-  1.000,1.000,1.000,1.000,1.000,1.000, &  
-  1.000,1.000,1.000,1.000,1.000,1.000, &  
-  1.000,1.000,1.000,1.000,1.000,1.000, &  
-  1.000,1.000,1.000,1.000,1.000,1.000, & 
-                           ! seasalt coarse (computed below for 550nm) 
-  1.000,1.000,1.000,1.000,1.000,1.000, &  
-  1.000,1.000,1.000,1.000,1.000,1.000, &  
-  1.000,1.000,1.000,1.000,1.000,1.000, &  
-  1.000,1.000,1.000,1.000,1.000,1.000, &  
-  1.000,1.000,1.000,1.000,1.000,1.000, &  
-  1.000,1.000,1.000,1.000,1.000,1.000, &  
-  1.000,1.000,1.000,1.000,1.000,1.000, &  
-  1.000,1.000,1.000,1.000,1.000,1.000, &  
-  1.000,1.000,1.000,1.000,1.000,1.000, &  
-  1.000,1.000,1.000,1.000,1.000,1.000, &  
-                           ! seasalt soluble accumulation (computed below for 550nm) 
-  1.000,1.000,1.000,1.000,1.000,1.000, &  
-  1.000,1.000,1.000,1.000,1.000,1.000, &  
-  1.000,1.000,1.000,1.000,1.000,1.000, &  
-  1.000,1.000,1.000,1.000,1.000,1.000, &  
-  1.000,1.000,1.000,1.000,1.000,1.000, &  
-  1.000,1.000,1.000,1.000,1.000,1.000, &  
-  1.000,1.000,1.000,1.000,1.000,1.000, &  
-  1.000,1.000,1.000,1.000,1.000,1.000, &  
-  1.000,1.000,1.000,1.000,1.000,1.000, &  
-  1.000,1.000,1.000,1.000,1.000,1.000/ 
-
- !
-  DATA piz_aeri_5wv/&
-     ! dust insoluble
-     0.944, 0.970, 0.977, 0.982, 0.987, &
-     ! bc insoluble
-     0.415, 0.387, 0.355, 0.328, 0.301, &
-     ! pom insoluble
-     0.972, 0.963, 0.943, 0.923, 0.897/
-
-! Interpolation des coefficients optiques de 19 niveaux vers le nombre des niveaux du model
-  IF (firstcall) THEN
-     firstcall=.FALSE.
-! Allocation
-    IF (.NOT. ALLOCATED(A1_ASSSM)) THEN
-        ALLOCATE(A1_ASSSM(klev),A2_ASSSM(klev), A3_ASSSM(klev),&
-          B1_ASSSM(klev), B2_ASSSM(klev), C1_ASSSM(klev), C2_ASSSM(klev),&
-          A1_CSSSM(klev), A2_CSSSM(klev), A3_CSSSM(klev),&
-          B1_CSSSM(klev), B2_CSSSM(klev), C1_CSSSM(klev), C2_CSSSM(klev),&
-          A1_SSSSM(klev), A2_SSSSM(klev), A3_SSSSM(klev),&
-          B1_SSSSM(klev), B2_SSSSM(klev), C1_SSSSM(klev), C2_SSSSM(klev), stat=ierr)
-        IF (ierr /= 0) CALL abort_physic('aeropt_5mw', 'pb in allocation 1',1)
-     END IF
-
-!Accumulation mode
-     CALL pres2lev(A1_ASSSM_19, A1_ASSSM, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
-     CALL pres2lev(A2_ASSSM_19, A2_ASSSM, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
-     CALL pres2lev(A3_ASSSM_19, A3_ASSSM, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
-     CALL pres2lev(B1_ASSSM_19, B1_ASSSM, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
-     CALL pres2lev(B2_ASSSM_19, B2_ASSSM, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
-     CALL pres2lev(C1_ASSSM_19, C1_ASSSM, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
-     CALL pres2lev(C2_ASSSM_19, C2_ASSSM, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
-!Coarse mode
-     CALL pres2lev(A1_CSSSM_19, A1_CSSSM, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
-     CALL pres2lev(A2_CSSSM_19, A2_CSSSM, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
-     CALL pres2lev(A3_CSSSM_19, A3_CSSSM, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
-     CALL pres2lev(B1_CSSSM_19, B1_CSSSM, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
-     CALL pres2lev(B2_CSSSM_19, B2_CSSSM, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
-     CALL pres2lev(C1_CSSSM_19, C1_CSSSM, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
-     CALL pres2lev(C2_CSSSM_19, C2_CSSSM, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
-!Super coarse mode
-     CALL pres2lev(A1_SSSSM_19, A1_SSSSM, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
-     CALL pres2lev(A2_SSSSM_19, A2_SSSSM, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
-     CALL pres2lev(A3_SSSSM_19, A3_SSSSM, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
-     CALL pres2lev(B1_SSSSM_19, B1_SSSSM, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
-     CALL pres2lev(B2_SSSSM_19, B2_SSSSM, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
-     CALL pres2lev(C1_SSSSM_19, C1_SSSSM, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
-     CALL pres2lev(C2_SSSSM_19, C2_SSSSM, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
-
-  END IF ! firstcall
-
-  ! Initialisations
-  tau(:,:,:,:) =0.
-  tausum(:,:,:)= 0.
-  ai(:)=0.0
-
-  DO k=1, klev
-    DO i=1, klon
-      zrho=pplay(i,k)/t_seri(i,k)/RD     ! kg/m3
-      dh(i,k)=pdel(i,k)/(RG*zrho)    ! m
-    ENDDO
-  ENDDO
-
-  IF (flag_aerosol .EQ. 1) THEN 
-     nb_aer = 2
-     ALLOCATE (aerosol_name(nb_aer)) 
-     aerosol_name(1) = id_ASSO4M_phy
-     aerosol_name(2) = id_CSSO4M_phy
-  ELSEIF (flag_aerosol .EQ. 2) THEN
-     nb_aer = 2
-     ALLOCATE (aerosol_name(nb_aer)) 
-     aerosol_name(1) = id_ASBCM_phy
-     aerosol_name(2) = id_AIBCM_phy
-  ELSEIF (flag_aerosol .EQ. 3) THEN 
-     nb_aer = 2
-     ALLOCATE (aerosol_name(nb_aer)) 
-     aerosol_name(1) = id_ASPOMM_phy
-     aerosol_name(2) = id_AIPOMM_phy
-  ELSEIF (flag_aerosol .EQ. 4) THEN 
-     nb_aer = 3
-     ALLOCATE (aerosol_name(nb_aer)) 
-     aerosol_name(1) = id_CSSSM_phy
-     aerosol_name(2) = id_SSSSM_phy
-     aerosol_name(3) = id_ASSSM_phy
-  ELSEIF (flag_aerosol .EQ. 5) THEN 
-     nb_aer = 1
-     ALLOCATE (aerosol_name(nb_aer)) 
-     aerosol_name(1) = id_CIDUSTM_phy
-  ELSEIF (flag_aerosol .EQ. 6) THEN 
-     nb_aer = 10
-     ALLOCATE (aerosol_name(nb_aer)) 
-     aerosol_name(1) = id_ASSO4M_phy
-     aerosol_name(2) = id_ASBCM_phy
-     aerosol_name(3) = id_AIBCM_phy
-     aerosol_name(4) = id_ASPOMM_phy
-     aerosol_name(5) = id_AIPOMM_phy
-     aerosol_name(6) = id_CSSSM_phy
-     aerosol_name(7) = id_SSSSM_phy
-     aerosol_name(8) = id_ASSSM_phy
-     aerosol_name(9) = id_CIDUSTM_phy
-     aerosol_name(10) = id_CSSO4M_phy
-  ENDIF
-
-  ! 
-  ! loop over modes, use of precalculated nmd and corresponding sigma
-  !    loop over wavelengths
-  !    for each mass species in mode
-  !      interpolate from Sext to retrieve Sext_at_gridpoint_per_species
-  !      compute optical_thickness_at_gridpoint_per_species
-  
-  !
-  ! Calculations that need to be done since we are not in the subroutines INCA
-  !      
-
-  DO n=1,nbre_RH-1
-    fact_RH(n)=1./(RH_tab(n+1)-RH_tab(n))
-  ENDDO
-   
-  DO k=1, klev
-    DO i=1, klon
-      rh(i,k)=MIN(RHcl(i,k)*100.,RH_MAX)
-      RH_num(i,k) = INT( rh(i,k)/10. + 1.)
-!--test olivier pour pas de reindicage
-!      RH_num(i,k) =1
-      IF (rh(i,k).GT.85.) RH_num(i,k)=10
-      IF (rh(i,k).GT.90.) RH_num(i,k)=11
-      DELTA(i,k)=(rh(i,k)-RH_tab(RH_num(i,k)))*fact_RH(RH_num(i,k))
-    ENDDO
-  ENDDO
-
-  used_tau(:)=.FALSE.
-    
-  DO m=1,nb_aer   ! tau is only computed for each mass    
-    fac=1.0
-    IF (aerosol_name(m).EQ.id_ASBCM_phy) THEN
-        soluble=.TRUE.
-        spsol=1
-        spss=0
-    ELSEIF (aerosol_name(m).EQ.id_ASPOMM_phy) THEN 
-        soluble=.TRUE.
-        spsol=2 
-        spss=0
-    ELSEIF (aerosol_name(m).EQ.id_ASSO4M_phy) THEN
-        soluble=.TRUE.
-        spsol=3
-        spss=0
-        fac=1.375    ! (NH4)2-SO4/SO4 132/96 mass conversion factor for OD
-    ELSEIF (aerosol_name(m).EQ.id_CSSO4M_phy) THEN
-        soluble=.TRUE.
-        spsol=4
-        spss=0
-        fac=1.375    ! (NH4)2-SO4/SO4 132/96 mass conversion factor for OD
-    ELSEIF (aerosol_name(m).EQ.id_SSSSM_phy) THEN 
-        soluble=.TRUE.
-        spsol=5
-        spss=3
-    ELSEIF (aerosol_name(m).EQ.id_CSSSM_phy) THEN 
-        soluble=.TRUE.
-        spsol=6
-        spss=2
-    ELSEIF (aerosol_name(m).EQ.id_ASSSM_phy) THEN
-        soluble=.TRUE.
-        spsol=7
-        spss=1
-    ELSEIF (aerosol_name(m).EQ.id_CIDUSTM_phy) THEN 
-        soluble=.FALSE.
-        spinsol=1
-        spss=0
-    ELSEIF  (aerosol_name(m).EQ.id_AIBCM_phy) THEN 
-        soluble=.FALSE.
-        spinsol=2
-        spss=0
-    ELSEIF (aerosol_name(m).EQ.id_AIPOMM_phy) THEN 
-        soluble=.FALSE.
-        spinsol=3
-        spss=0
-    ELSE 
-        CYCLE
-    ENDIF
-
-    IF (soluble) then
-      used_tau(spsol)=.TRUE.
-    ELSE
-      used_tau(naero_soluble+spinsol)=.TRUE.
-    ENDIF
-
-    aerindex=aerosol_name(m)
-
-    DO la=1,las
-
-    !--only 550 and 865 nm are used
-    IF (la.NE.la550.AND.la.NE.la865) CYCLE
-
-      IF (soluble) THEN
-
-        IF ((la.EQ.2).AND.(spss.NE.0)) THEN !la=2 corresponds to 550 nm
-          IF (spss.EQ.1) THEN !accumulation mode
-            DO k=1, klev
-              DO i=1, klon
-                H=rh(i,k)/100.
-                tau_ae5wv_int=A1_ASSSM(k)+A2_ASSSM(k)*H+A3_ASSSM(k)/(H-1.05)
-                tau(i,k,la,aerindex) = m_allaer(i,k,aerindex)/1.e6*dh(i,k)*tau_ae5wv_int*fac
-                tausum(i,la,aerindex)=tausum(i,la,aerindex)+tau(i,k,la,aerindex)
-              ENDDO
-            ENDDO
-          ENDIF
-  
-          IF (spss.EQ.2) THEN !coarse mode
-            DO k=1, klev
-              DO i=1, klon
-                H=rh(i,k)/100.
-                tau_ae5wv_int=A1_CSSSM(k)+A2_CSSSM(k)*H+A3_CSSSM(k)/(H-1.05)
-                tau(i,k,la,aerindex) = m_allaer(i,k,aerindex)/1.e6*dh(i,k)*tau_ae5wv_int*fac
-                tausum(i,la,aerindex)=tausum(i,la,aerindex)+tau(i,k,la,aerindex)
-              ENDDO
-            ENDDO
-          ENDIF
-
-          IF (spss.EQ.3) THEN !super coarse mode
-            DO k=1, klev
-              DO i=1, klon
-                H=rh(i,k)/100.
-                tau_ae5wv_int=A1_SSSSM(k)+A2_SSSSM(k)*H+A3_SSSSM(k)/(H-1.05)
-                tau(i,k,la,aerindex) = m_allaer(i,k,aerindex)/1.e6*dh(i,k)*tau_ae5wv_int*fac
-                tausum(i,la,aerindex)=tausum(i,la,aerindex)+tau(i,k,la,aerindex)
-              ENDDO
-            ENDDO
-          ENDIF
-
-        ELSE
-          DO k=1, klev
-            DO i=1, klon
-              tau_ae5wv_int = alpha_aers_5wv(RH_num(i,k),la,spsol)+DELTA(i,k)* &
-                             (alpha_aers_5wv(RH_num(i,k)+1,la,spsol) - & 
-                              alpha_aers_5wv(RH_num(i,k),la,spsol))
-              tau(i,k,la,aerindex) = m_allaer(i,k,aerindex)/1.e6*dh(i,k)*tau_ae5wv_int*fac
-              tausum(i,la,aerindex)=tausum(i,la,aerindex)+tau(i,k,la,aerindex)
-            ENDDO
-          ENDDO
-        ENDIF
-
-      ELSE                                                  ! For insoluble aerosol
-
-        DO k=1, klev
-          DO i=1, klon
-            tau_ae5wv_int = alpha_aeri_5wv(la,spinsol)
-            tau(i,k,la,aerindex) = m_allaer(i,k,aerindex)/1.e6*dh(i,k)*tau_ae5wv_int*fac
-            tausum(i,la,aerindex)=tausum(i,la,aerindex)+tau(i,k,la,aerindex)
-          ENDDO
-        ENDDO
-
-      ENDIF
-
-    ENDDO   ! boucle sur les longueurs d'onde
-  ENDDO     ! Boucle  sur les masses de traceurs
-
-  DO m=1,naero_spc
-    IF (.NOT.used_tau(m)) tau(:,:,:,m)=0.
-  ENDDO  
-
-!--AOD calculations for diagnostics
-  od550aer(:)=SUM(tausum(:,la550,:),dim=2)
-  od865aer(:)=SUM(tausum(:,la865,:),dim=2)
-
-!--extinction coefficient for diagnostic
-  ec550aer(:,:)=SUM(tau(:,:,la550,:),dim=3)/dh(:,:)
-  
-!--acc mode AOD calculation for diagnostic
-  od550lt1aer(:)=tausum(:,la550,id_ASSO4M_phy)+tausum(:,la550,id_ASBCM_phy)+tausum(:,la550,id_AIBCM_phy)+  &
-                 tausum(:,la550,id_ASPOMM_phy)+tausum(:,la550,id_AIPOMM_phy)+tausum(:,la550,id_ASSSM_phy)+ &
-                 0.03*tausum(:,la550,id_CSSSM_phy)+0.4*tausum(:,la550,id_CIDUSTM_phy)
-
-  DEALLOCATE(aerosol_name) 
-  
-END SUBROUTINE AEROPT_5WV
Index: /LMDZ6/trunk/libf/phylmd/aeropt_5wv.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/aeropt_5wv.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/aeropt_5wv.f90	(revision 5268)
@@ -0,0 +1,826 @@
+!
+! $Id$
+!
+
+SUBROUTINE AEROPT_5WV(&
+   pdel, m_allaer, delt, &
+   RHcl, ai, flag_aerosol, &
+   pplay, t_seri, &
+   tausum, tau, presnivs)
+
+  USE DIMPHY
+  USE aero_mod
+  USE phys_local_var_mod, only: od550aer,od865aer,ec550aer,od550lt1aer
+  USE pres2lev_mod
+
+  !
+  !    Yves Balkanski le 12 avril 2006
+  !    Celine Deandreis
+  !    Anne Cozic  Avril 2009
+  !    a partir d'une sous-routine de Johannes Quaas pour les sulfates
+  !
+  !
+  ! Refractive indices for seasalt come from Shettle and Fenn (1979)
+  !
+  ! Refractive indices from water come from Hale and Querry (1973)
+  !
+  ! Refractive indices from Ammonium Sulfate Toon and Pollack (1976)
+  !
+  ! Refractive indices for Dust, internal mixture of minerals coated with 1.5% hematite 
+  ! by Volume (Balkanski et al., 2006)
+  !
+  ! Refractive indices for POM: Kinne (pers. Communication 
+  !
+  ! Refractive index for BC from Shettle and Fenn (1979)
+  !
+  ! Shettle, E. P., & Fenn, R. W. (1979), Models for the aerosols of the lower atmosphere and 
+  ! the effects of humidity variations on their optical properties, U.S. Air Force Geophysics 
+  ! Laboratory Rept. AFGL-TR-79-0214, Hanscomb Air Force Base, MA.
+  !
+  ! Hale, G. M. and M. R. Querry, Optical constants of water in the 200-nm to 200-m 
+  ! wavelength region, Appl. Opt., 12, 555-563, 1973.
+  !
+  ! Toon, O. B. and J. B. Pollack, The optical constants of several atmospheric aerosol species:
+  ! Ammonium sulfate, aluminum oxide, and sodium chloride, J. Geohys. Res., 81, 5733-5748,
+  ! 1976.
+  !
+  ! Balkanski, Y., M. Schulz, T. Claquin And O. Boucher, Reevaluation of mineral aerosol 
+  ! radiative forcings suggests a better agreement with satellite and AERONET data, Atmospheric 
+  ! Chemistry and Physics Discussions., 6, pp 8383-8419, 2006.
+  !
+  IMPLICIT NONE
+  INCLUDE "YOMCST.h"
+  !
+  ! Input arguments:
+  !
+  REAL, DIMENSION(klon,klev), INTENT(in)   :: pdel
+  REAL, INTENT(in)                         :: delt
+  REAL, DIMENSION(klon,klev,naero_tot), INTENT(in) :: m_allaer
+  REAL, DIMENSION(klon,klev), INTENT(in)   :: RHcl     ! humidite relative ciel clair
+  INTEGER,INTENT(in)                       :: flag_aerosol
+  REAL, DIMENSION(klon,klev), INTENT(in)   :: pplay
+  REAL, DIMENSION(klon,klev), INTENT(in)   :: t_seri
+  REAL, DIMENSION(klev),      INTENT(in)   :: presnivs
+  !
+  ! Output arguments:
+  !
+  REAL, DIMENSION(klon), INTENT(out)          :: ai      ! POLDER aerosol index
+  REAL, DIMENSION(klon,nwave,naero_tot), INTENT(out)      :: tausum
+  REAL, DIMENSION(klon,klev,nwave,naero_tot), INTENT(out) :: tau
+  !
+  ! Local
+  !
+  INTEGER, PARAMETER :: las = nwave_sw
+  LOGICAL :: soluble
+  
+  INTEGER :: i, k, ierr, m, aerindex
+  INTEGER :: spsol, spinsol, spss, la
+  INTEGER :: RH_num(klon,klev)
+  INTEGER, PARAMETER :: la443 = 1
+  INTEGER, PARAMETER :: la550 = 2
+  INTEGER, PARAMETER :: la670 = 3
+  INTEGER, PARAMETER :: la765 = 4
+  INTEGER, PARAMETER :: la865 = 5
+  INTEGER, PARAMETER :: nbre_RH=12
+  INTEGER, PARAMETER :: naero_soluble=7   !  1- BC soluble; 2- POM soluble; 3- SO4 acc.
+                                          !  4- SO4 coarse; 5 seasalt super-C; 6 seasalt coarse; 7 seasalt acc.
+  INTEGER, PARAMETER :: naero_insoluble=3 !  1- Dust; 2- BC insoluble; 3- POM insoluble
+  INTEGER, PARAMETER :: nb_level = 19     ! number of vertical levels
+  LOGICAL, SAVE :: firstcall=.TRUE.
+!$OMP THREADPRIVATE(firstcall)
+
+  REAL :: zrho
+
+  ! Coefficient optiques sur 19 niveaux
+  REAL, SAVE, DIMENSION(nb_level) :: presnivs_19  ! Pression milieux couche pour 19 niveaux (nb_level)
+!$OMP THREADPRIVATE(presnivs_19)
+
+  REAL, SAVE, DIMENSION(nb_level) :: A1_ASSSM_19, A2_ASSSM_19, A3_ASSSM_19,&
+          B1_ASSSM_19, B2_ASSSM_19, C1_ASSSM_19, C2_ASSSM_19,&
+          A1_CSSSM_19, A2_CSSSM_19, A3_CSSSM_19,&
+          B1_CSSSM_19, B2_CSSSM_19, C1_CSSSM_19, C2_CSSSM_19, &
+          A1_SSSSM_19, A2_SSSSM_19, A3_SSSSM_19,&
+          B1_SSSSM_19, B2_SSSSM_19, C1_SSSSM_19, C2_SSSSM_19
+!$OMP THREADPRIVATE(A1_ASSSM_19, A2_ASSSM_19, A3_ASSSM_19)
+!$OMP THREADPRIVATE(B1_ASSSM_19, B2_ASSSM_19, C1_ASSSM_19, C2_ASSSM_19)
+!$OMP THREADPRIVATE(A1_CSSSM_19, A2_CSSSM_19, A3_CSSSM_19)
+!$OMP THREADPRIVATE(B1_CSSSM_19, B2_CSSSM_19, C1_CSSSM_19, C2_CSSSM_19)
+!$OMP THREADPRIVATE(A1_SSSSM_19, A2_SSSSM_19, A3_SSSSM_19)
+!$OMP THREADPRIVATE(B1_SSSSM_19, B2_SSSSM_19, C1_SSSSM_19, C2_SSSSM_19)
+
+  ! Coefficient optiques interpole sur le nombre de niveau du modele
+  REAL, ALLOCATABLE,  DIMENSION(:), SAVE :: &
+          A1_ASSSM, A2_ASSSM, A3_ASSSM,&
+          B1_ASSSM, B2_ASSSM, C1_ASSSM, C2_ASSSM,&
+          A1_CSSSM, A2_CSSSM, A3_CSSSM,&
+          B1_CSSSM, B2_CSSSM, C1_CSSSM, C2_CSSSM, &
+          A1_SSSSM, A2_SSSSM, A3_SSSSM,&
+          B1_SSSSM, B2_SSSSM, C1_SSSSM, C2_SSSSM
+!$OMP THREADPRIVATE(A1_ASSSM, A2_ASSSM, A3_ASSSM)
+!$OMP THREADPRIVATE(B1_ASSSM, B2_ASSSM, C1_ASSSM, C2_ASSSM)
+!$OMP THREADPRIVATE(A1_CSSSM, A2_CSSSM, A3_CSSSM)
+!$OMP THREADPRIVATE(B1_CSSSM, B2_CSSSM, C1_CSSSM, C2_CSSSM)
+!$OMP THREADPRIVATE(A1_SSSSM, A2_SSSSM, A3_SSSSM)
+!$OMP THREADPRIVATE(B1_SSSSM, B2_SSSSM, C1_SSSSM, C2_SSSSM)
+
+
+  REAL,PARAMETER :: RH_tab(nbre_RH)=(/0.,10.,20.,30.,40.,50.,60.,70.,80.,85.,90.,95./)
+  REAL :: DELTA(klon,klev), rh(klon,klev), H
+  REAL :: tau_ae5wv_int ! Intermediate computation of epaisseur optique aerosol
+  REAL :: piz_ae5wv_int ! Intermediate single scattering albedo aerosol
+  REAL :: cg_ae5wv_int  ! Intermediate asymmetry parameter aerosol
+  REAL, PARAMETER :: RH_MAX=95.
+  REAL :: taue670(klon)       ! epaisseur optique aerosol absorption 550 nm
+  REAL :: taue865(klon)       ! epaisseur optique aerosol extinction 865 nm
+  REAL :: fac
+  INTEGER, ALLOCATABLE, DIMENSION(:)  :: aerosol_name
+  INTEGER :: nb_aer
+  
+  REAL :: tau3d(klon,klev), piz3d(klon,klev), cg3d(klon,klev)
+  REAL :: abs3d(klon,klev)     ! epaisseur optique d'absorption
+  REAL :: dh(klon,klev)
+  
+  REAL :: alpha_aers_5wv(nbre_RH,las,naero_soluble)   ! ext. coeff. Soluble comp. units *** m2/g 
+   !  1- BC soluble; 2- POM soluble; 3- SO4 acc.; 4- SO4 coarse; 5 seasalt super-C; 6 seasalt coarse; 7 seasalt acc.
+  REAL :: alpha_aeri_5wv(las,naero_insoluble)         ! ext. coeff. Insoluble comp. 1- Dust: 2- BC; 3- POM
+  REAL :: cg_aers_5wv(nbre_RH,las,naero_soluble)      ! Asym. param. soluble comp. 
+   !  1- BC soluble; 2- POM soluble; 3- SO4 acc.; 4- SO4 coarse; 5 seasalt super-C; 6 seasalt coarse; 7 seasalt acc.
+  REAL :: cg_aeri_5wv(las,naero_insoluble)            ! Asym. param. insoluble comp. 1- Dust: 2- BC; 3- POM
+  REAL :: piz_aers_5wv(nbre_RH,las,naero_soluble)   
+   !  1- BC soluble; 2- POM soluble; 3- SO4 acc.; 4- SO4 coarse; 5 seasalt super-C; 6 seasalt coarse; 7 seasalt acc.
+  REAL :: piz_aeri_5wv(las,naero_insoluble)           ! Insoluble comp. 1- Dust: 2- BC; 3- POM
+  !
+  ! Proprietes optiques
+  !
+  REAL :: fact_RH(nbre_RH)
+  LOGICAL :: used_tau(naero_spc)
+  INTEGER :: n
+  
+  DATA presnivs_19/&
+       100426.5,  98327.6, 95346.5, 90966.8, 84776.9, &
+       76536.5,   66292.2, 54559.3, 42501.8, 31806, &
+       23787.5,   18252.7, 13996,   10320.8, 7191.1, &
+       4661.7,    2732.9,  1345.6,  388.2/
+
+!!ACCUMULATION MODE
+  DATA A1_ASSSM_19/ 4.373E+00,  4.361E+00,  4.331E+00, &
+                 4.278E+00,  4.223E+00,  4.162E+00, &
+                 4.103E+00,  4.035E+00,  3.962E+00, &
+                 3.904E+00,  3.871E+00,  3.847E+00, &
+                 3.824E+00,  3.780E+00,  3.646E+00, &
+                 3.448E+00,  3.179E+00,  2.855E+00,  2.630E+00/
+  DATA A2_ASSSM_19/ 2.496E+00,  2.489E+00,  2.472E+00, &
+                 2.442E+00,  2.411E+00,  2.376E+00, &
+                 2.342E+00,  2.303E+00,  2.261E+00, &
+                 2.228E+00,  2.210E+00,  2.196E+00, &
+                 2.183E+00,  2.158E+00,  2.081E+00, &
+                 1.968E+00,  1.814E+00,  1.630E+00,  1.501E+00/
+  DATA A3_ASSSM_19/-4.688E-02, -4.676E-02, -4.644E-02, &
+                -4.587E-02, -4.528E-02, -4.463E-02, &
+                -4.399E-02, -4.326E-02, -4.248E-02, &
+                -4.186E-02, -4.151E-02, -4.125E-02, &
+                -4.100E-02, -4.053E-02, -3.910E-02, &
+                -3.697E-02, -3.408E-02, -3.061E-02, -2.819E-02/
+  DATA B1_ASSSM_19/ 1.165E-08,  1.145E-08,  1.097E-08, &
+                 1.012E-08,  9.233E-09,  8.261E-09, &
+                 7.297E-09,  6.201E-09,  5.026E-09, &
+                 4.098E-09,  3.567E-09,  3.187E-09, &
+                 2.807E-09,  2.291E-09,  2.075E-09, &
+                 1.756E-09,  1.322E-09,  8.011E-10, 4.379E-10/
+  DATA B2_ASSSM_19/ 2.193E-08,  2.192E-08,  2.187E-08, &
+                 2.179E-08,  2.171E-08,  2.162E-08, &
+                 2.153E-08,  2.143E-08,  2.132E-08, &
+                 2.124E-08,  2.119E-08,  2.115E-08, &
+                 2.112E-08,  2.106E-08,  2.100E-08, &
+                 2.090E-08,  2.077E-08,  2.061E-08,  2.049E-08/
+  DATA C1_ASSSM_19/ 7.365E-01,  7.365E-01,  7.365E-01, &
+                 7.364E-01,  7.363E-01,  7.362E-01, &
+                 7.361E-01,  7.359E-01,  7.358E-01, &
+                 7.357E-01,  7.356E-01,  7.356E-01, &
+                 7.356E-01,  7.355E-01,  7.354E-01, &
+                 7.352E-01,  7.350E-01,  7.347E-01,  7.345E-01/
+  DATA C2_ASSSM_19/ 5.833E-02,  5.835E-02,  5.841E-02, &
+                 5.850E-02,  5.859E-02,  5.870E-02, &
+                 5.880E-02,  5.891E-02,  5.904E-02, &
+                 5.914E-02,  5.920E-02,  5.924E-02, &
+                 5.928E-02,  5.934E-02,  5.944E-02, &
+                 5.959E-02,  5.979E-02,  6.003E-02,  6.020E-02/
+!COARSE MODE
+  DATA A1_CSSSM_19/ 7.403E-01,  7.422E-01,  7.626E-01, &
+                 8.019E-01,  8.270E-01,  8.527E-01, &
+                 8.702E-01,  8.806E-01,  8.937E-01, &
+                 9.489E-01,  1.030E+00,  1.105E+00, &
+                 1.199E+00,  1.357E+00,  1.660E+00, &
+                 2.540E+00,  4.421E+00,  2.151E+00,  9.518E-01/
+  DATA A2_CSSSM_19/ 4.522E-01,  4.532E-01,  4.644E-01, &
+                 4.859E-01,  4.996E-01,  5.137E-01, &
+                 5.233E-01,  5.290E-01,  5.361E-01, &
+                 5.655E-01,  6.085E-01,  6.483E-01, &
+                 6.979E-01,  7.819E-01,  9.488E-01, &
+                 1.450E+00,  2.523E+00,  1.228E+00,  5.433E-01/
+  DATA A3_CSSSM_19/-8.516E-03, -8.535E-03, -8.744E-03, &
+                -9.148E-03, -9.406E-03, -9.668E-03, &
+                -9.848E-03, -9.955E-03, -1.009E-02, &
+                -1.064E-02, -1.145E-02, -1.219E-02, &
+                -1.312E-02, -1.470E-02, -1.783E-02, &
+                -2.724E-02, -4.740E-02, -2.306E-02, -1.021E-02/
+  DATA B1_CSSSM_19/ 2.535E-07,  2.530E-07,  2.479E-07, &
+                 2.380E-07,  2.317E-07,  2.252E-07, &
+                 2.208E-07,  2.182E-07,  2.149E-07, &
+                 2.051E-07,  1.912E-07,  1.784E-07, &
+                 1.624E-07,  1.353E-07,  1.012E-07, &
+                 6.016E-08,  2.102E-08,  0.000E+00,  0.000E+00/
+  DATA B2_CSSSM_19/ 1.221E-07,  1.217E-07,  1.179E-07, &
+                 1.104E-07,  1.056E-07,  1.008E-07, &
+                 9.744E-08,  9.546E-08,  9.299E-08, &
+                 8.807E-08,  8.150E-08,  7.544E-08, &
+                 6.786E-08,  5.504E-08,  4.080E-08, &
+                 2.960E-08,  2.300E-08,  2.030E-08,  1.997E-08/
+  DATA C1_CSSSM_19/ 7.659E-01,  7.658E-01,  7.652E-01, &
+                 7.639E-01,  7.631E-01,  7.623E-01, &
+                 7.618E-01,  7.614E-01,  7.610E-01, &
+                 7.598E-01,  7.581E-01,  7.566E-01, &
+                 7.546E-01,  7.513E-01,  7.472E-01, &
+                 7.423E-01,  7.376E-01,  7.342E-01,  7.334E-01/
+  DATA C2_CSSSM_19/ 3.691E-02,  3.694E-02,  3.729E-02, &
+                 3.796E-02,  3.839E-02,  3.883E-02, &
+                 3.913E-02,  3.931E-02,  3.953E-02, &
+                 4.035E-02,  4.153E-02,  4.263E-02, &
+                 4.400E-02,  4.631E-02,  4.933E-02, &
+                 5.331E-02,  5.734E-02,  6.053E-02,  6.128E-02/
+!SUPER COARSE MODE
+  DATA A1_SSSSM_19/ 2.836E-01,  2.876E-01,  2.563E-01, &
+                 2.414E-01,  2.541E-01,  2.546E-01, &
+                 2.572E-01,  2.638E-01,  2.781E-01, &
+                 3.167E-01,  4.209E-01,  5.286E-01, &
+                 6.959E-01,  9.233E-01,  1.282E+00, &
+                 1.836E+00,  2.981E+00,  4.355E+00,  4.059E+00/
+  DATA A2_SSSSM_19/ 1.608E-01,  1.651E-01,  1.577E-01, &
+                 1.587E-01,  1.686E-01,  1.690E-01, &
+                 1.711E-01,  1.762E-01,  1.874E-01, &
+                 2.138E-01,  2.751E-01,  3.363E-01, &
+                 4.279E-01,  5.519E-01,  7.421E-01, &
+                 1.048E+00,  1.702E+00,  2.485E+00,  2.317E+00/
+  DATA A3_SSSSM_19/-3.025E-03, -3.111E-03, -2.981E-03, &
+                -3.005E-03, -3.193E-03, -3.200E-03, &
+                -3.239E-03, -3.336E-03, -3.548E-03, &
+                -4.047E-03, -5.196E-03, -6.345E-03, &
+                -8.061E-03, -1.038E-02, -1.395E-02, &
+                -1.970E-02, -3.197E-02, -4.669E-02, -4.352E-02/
+  DATA B1_SSSSM_19/ 6.759E-07,  6.246E-07,  5.542E-07, &
+                 4.953E-07,  4.746E-07,  4.738E-07, &
+                 4.695E-07,  4.588E-07,  4.354E-07, &
+                 3.947E-07,  3.461E-07,  3.067E-07, &
+                 2.646E-07,  2.095E-07,  1.481E-07, &
+                 9.024E-08,  5.747E-08,  2.384E-08,  6.599E-09/
+  DATA B2_SSSSM_19/ 5.977E-07,  5.390E-07,  4.468E-07, &
+                 3.696E-07,  3.443E-07,  3.433E-07, &
+                 3.380E-07,  3.249E-07,  2.962E-07, &
+                 2.483E-07,  1.989E-07,  1.623E-07, &
+                 1.305E-07,  9.015E-08,  6.111E-08, &
+                 3.761E-08,  2.903E-08,  2.337E-08,  2.147E-08/
+  DATA C1_SSSSM_19/ 8.120E-01,  8.084E-01,  8.016E-01, &
+                 7.953E-01,  7.929E-01,  7.928E-01, &
+                 7.923E-01,  7.910E-01,  7.882E-01, &
+                 7.834E-01,  7.774E-01,  7.725E-01, &
+                 7.673E-01,  7.604E-01,  7.529E-01, &
+                 7.458E-01,  7.419E-01,  7.379E-01,  7.360E-01/
+  DATA C2_SSSSM_19/ 2.388E-02,  2.392E-02,  2.457E-02,  2.552E-02, &
+                 2.615E-02,  2.618E-02,  2.631E-02,  2.663E-02, &
+                 2.735E-02,  2.875E-02,  3.113E-02,  3.330E-02, &
+                 3.615E-02,  3.997E-02,  4.521E-02,  5.038E-02, &
+                 5.358E-02,  5.705E-02,  5.887E-02/
+!*********************************************************************
+!
+! 
+! From here on we look at the optical parameters at 5 wavelengths:  
+! 443nm, 550, 670, 765 and 865 nm 
+!                                   le 12 AVRIL 2006 
+!  
+ DATA alpha_aers_5wv/ & 
+                                ! bc soluble 
+       7.930,7.930,7.930,7.930,7.930,7.930,     & 
+       7.930,7.930,10.893,12.618,14.550,16.613, & 
+       7.658,7.658,7.658,7.658,7.658,7.658,     & 
+       7.658,7.658,10.351,11.879,13.642,15.510, & 
+       7.195,7.195,7.195,7.195,7.195,7.195,     & 
+       7.195,7.195,9.551,10.847,12.381,13.994,  & 
+       6.736,6.736,6.736,6.736,6.736,6.736,     & 
+       6.736,6.736,8.818,9.938,11.283,12.687,   & 
+       6.277,6.277,6.277,6.277,6.277,6.277,     & 
+       6.277,6.277,8.123,9.094,10.275,11.501,   & 
+                                ! pom soluble 
+       6.676,6.676,6.676,6.676,6.710,6.934,   & 
+       7.141,7.569,8.034,8.529,9.456,10.511,  & 
+       5.109,5.109,5.109,5.109,5.189,5.535,   & 
+       5.960,6.852,8.008,9.712,12.897,19.676, & 
+       3.718,3.718,3.718,3.718,3.779,4.042,   & 
+       4.364,5.052,5.956,7.314,9.896,15.688,  & 
+       2.849,2.849,2.849,2.849,2.897,3.107,   & 
+       3.365,3.916,4.649,5.760,7.900,12.863,  & 
+       2.229,2.229,2.229,2.229,2.268,2.437,   & 
+       2.645,3.095,3.692,4.608,6.391,10.633,  & 
+                                ! Sulfate (Accumulation) 
+       5.751,6.215,6.690,7.024,7.599,8.195,      & 
+       9.156,10.355,12.660,14.823,18.908,24.508, & 
+       4.320,4.675,5.052,5.375,5.787,6.274,      & 
+       7.066,8.083,10.088,12.003,15.697,21.133,  & 
+       3.079,3.351,3.639,3.886,4.205,4.584,      & 
+       5.206,6.019,7.648,9.234,12.391,17.220,    & 
+       2.336,2.552,2.781,2.979,3.236,3.540,      & 
+       4.046,4.711,6.056,7.388,10.093,14.313,    & 
+       1.777,1.949,2.134,2.292,2.503,2.751,      & 
+       3.166,3.712,4.828,5.949,8.264,11.922,     & 
+                                ! Sulfate (Coarse) 
+       5.751,6.215,6.690,7.024,7.599,8.195,      & 
+       9.156,10.355,12.660,14.823,18.908,24.508, & 
+       4.320,4.675,5.052,5.375,5.787,6.274,      & 
+       7.066,8.083,10.088,12.003,15.697,21.133,  & 
+       3.079,3.351,3.639,3.886,4.205,4.584,      & 
+       5.206,6.019,7.648,9.234,12.391,17.220,    & 
+       2.336,2.552,2.781,2.979,3.236,3.540,      & 
+       4.046,4.711,6.056,7.388,10.093,14.313,    & 
+       1.777,1.949,2.134,2.292,2.503,2.751,      & 
+       3.166,3.712,4.828,5.949,8.264,11.922,     & 
+                                ! Seasalt soluble super_coarse (computed below for 550nm) 
+       0.50,0.90,1.05,1.21,1.40,2.41, &  
+       2.66,3.11,3.88,4.52,5.69,8.84, &  
+       0.000,0.000,0.000,0.000,0.000,0.000, &  
+       0.000,0.000,0.000,0.000,0.000,0.000, &  
+     0.52,0.93,1.08,1.24,1.43,2.47, &  
+     2.73,3.20,3.99,4.64,5.84,9.04, &  
+     0.52,0.93,1.09,1.25,1.44,2.50, &  
+     2.76,3.23,4.03,4.68,5.89,9.14, &  
+     0.52,0.94,1.09,1.26,1.45,2.51, &  
+     2.78,3.25,4.06,4.72,5.94,9.22, &  
+                                ! seasalt soluble coarse (computed below for 550nm) 
+       0.50,0.90,1.05,1.21,1.40,2.41, &  
+       2.66,3.11,3.88,4.52,5.69,8.84, &  
+       0.000,0.000,0.000,0.000,0.000,0.000, &  
+       0.000,0.000,0.000,0.000,0.000,0.000, &  
+     0.52,0.93,1.08,1.24,1.43,2.47, &  
+     2.73,3.20,3.99,4.64,5.84,9.04, &  
+     0.52,0.93,1.09,1.25,1.44,2.50, &  
+     2.76,3.23,4.03,4.68,5.89,9.14, &  
+     0.52,0.94,1.09,1.26,1.45,2.51, &  
+     2.78,3.25,4.06,4.72,5.94,9.22, &  
+                                ! seasalt soluble accumulation (computed below for 550nm) 
+     4.28, 7.17, 8.44, 9.85,11.60,22.44,  &  
+     25.34,30.54,39.38,46.52,59.33,91.77, &  
+       0.000,0.000,0.000,0.000,0.000,0.000, &  
+       0.000,0.000,0.000,0.000,0.000,0.000, &  
+     2.48, 4.22, 5.02, 5.94, 7.11,15.29,  &  
+     17.70,22.31,30.73,38.06,52.15,90.59, &  
+     1.90, 3.29, 3.94, 4.69, 5.65, 12.58, &  
+     14.68,18.77,26.41,33.25,46.77,85.50, &  
+     1.47, 2.59, 3.12, 3.74, 4.54, 10.42, &  
+     12.24,15.82,22.66,28.91,41.54,79.33/ 
+
+  DATA alpha_aeri_5wv/ &
+                                 ! dust insoluble 
+        0.759, 0.770, 0.775, 0.775, 0.772, & 
+                                 !!jb bc insoluble 
+        11.536,10.033, 8.422, 7.234, 6.270, & 
+                                 ! pom insoluble 
+        5.042, 3.101, 1.890, 1.294, 0.934/ 
+   ! 
+  DATA cg_aers_5wv/ &  
+                                 ! bc soluble 
+      .651, .651, .651, .651, .651, .651, & 
+      .651, .651, .738, .764, .785, .800, & 
+      .597, .597, .597, .597, .597, .597, & 
+      .597, .597, .695, .725, .751, .770, & 
+      .543, .543, .543, .543, .543, .543, & 
+      .543, .543, .650, .684, .714, .736, &  
+      .504, .504, .504, .504, .504, .504, & 
+      .504, .504, .614, .651, .683, .708, &  
+      .469, .469, .469, .469, .469, .469, & 
+      .469, .469, .582, .620, .655, .681, & 
+                                 ! pom soluble 
+      .679, .679, .679, .679, .683, .691, & 
+      .703, .720, .736, .751, .766, .784, & 
+      .656, .656, .656, .656, .659, .669, & 
+      .681, .699, .717, .735, .750, .779, &  
+      .623, .623, .623, .623, .627, .637, & 
+      .649, .668, .688, .709, .734, .762, & 
+      .592, .592, .592, .592, .595, .605, & 
+      .618, .639, .660, .682, .711, .743, & 
+      .561, .561, .561, .561, .565, .575, & 
+      .588, .609, .632, .656, .688, .724, & 
+                                 ! Accumulation sulfate 
+      .671, .684, .697, .704, .714, .723, & 
+      .734, .746, .762, .771, .781, .789, & 
+      .653, .666, .678, .687, .697, .707, & 
+      .719, .732, .751, .762, .775, .789, & 
+      .622, .635, .648, .657, .667, .678, & 
+      .691, .705, .728, .741, .758, .777, & 
+      .591, .604, .617, .627, .638, .650, & 
+      .664, .679, .704, .719, .739, .761, & 
+      .560, .574, .587, .597, .609, .621, &  
+      .637, .653, .680, .697, .719, .745, & 
+                                 ! Coarse sulfate 
+      .671, .684, .697, .704, .714, .723, & 
+      .734, .746, .762, .771, .781, .789, & 
+      .653, .666, .678, .687, .697, .707, & 
+      .719, .732, .751, .762, .775, .789, & 
+      .622, .635, .648, .657, .667, .678, & 
+      .691, .705, .728, .741, .758, .777, & 
+      .591, .604, .617, .627, .638, .650, & 
+      .664, .679, .704, .719, .739, .761, & 
+      .560, .574, .587, .597, .609, .621, &  
+      .637, .653, .680, .697, .719, .745, & 
+                                 ! For super coarse seasalt (computed below for 550nm!) 
+      0.730,0.753,0.760,0.766,0.772,0.793, &  
+      0.797,0.802,0.809,0.813,0.820,0.830, &  
+      0.000,0.000,0.000,0.000,0.000,0.000, &  
+      0.000,0.000,0.000,0.000,0.000,0.000, &  
+      0.721,0.744,0.750,0.756,0.762,0.784, &  
+      0.787,0.793,0.800,0.804,0.811,0.822, &  
+      0.717,0.741,0.747,0.753,0.759,0.780, &  
+      0.784,0.789,0.795,0.800,0.806,0.817, &  
+      0.715,0.739,0.745,0.751,0.757,0.777, &   
+      0.781,0.786,0.793,0.797,0.803,0.814, &  
+                                 ! For coarse-soluble seasalt (computed below for 550nm!) 
+      0.730,0.753,0.760,0.766,0.772,0.793, &  
+      0.797,0.802,0.809,0.813,0.820,0.830, &  
+      0.000,0.000,0.000,0.000,0.000,0.000, &  
+      0.000,0.000,0.000,0.000,0.000,0.000, &  
+      0.721,0.744,0.750,0.756,0.762,0.784, &  
+      0.787,0.793,0.800,0.804,0.811,0.822, &  
+      0.717,0.741,0.747,0.753,0.759,0.780, &  
+      0.784,0.789,0.795,0.800,0.806,0.817, &  
+      0.715,0.739,0.745,0.751,0.757,0.777, &   
+      0.781,0.786,0.793,0.797,0.803,0.814, &  
+                                 ! accumulation-seasalt soluble (computed below for 550nm!)  
+      0.698,0.722,0.729,0.736,0.743,0.765, &  
+      0.768,0.773,0.777,0.779,0.781,0.779, &  
+      0.000,0.000,0.000,0.000,0.000,0.000, &  
+      0.000,0.000,0.000,0.000,0.000,0.000, &  
+      0.658,0.691,0.701,0.710,0.720,0.756, &  
+      0.763,0.771,0.782,0.788,0.795,0.801, &  
+      0.632,0.668,0.679,0.690,0.701,0.743, &  
+      0.750,0.762,0.775,0.783,0.792,0.804, &  
+      0.605,0.644,0.656,0.669,0.681,0.729, &  
+      0.737,0.750,0.765,0.775,0.787,0.803/
+ !
+  DATA cg_aeri_5wv/&
+     ! dust insoluble
+     0.714, 0.697, 0.688, 0.683, 0.679, &
+     ! bc insoluble
+     0.511, 0.445, 0.384, 0.342, 0.307, &
+     !c pom insoluble
+     0.596, 0.536, 0.466, 0.409, 0.359/
+  !
+  DATA piz_aers_5wv/&
+                           ! bc soluble 
+  .445, .445, .445, .445, .445, .445, & 
+  .445, .445, .470, .487, .508, .531, & 
+  .442, .442, .442, .442, .442, .442, & 
+  .442, .442, .462, .481, .506, .533, & 
+  .427, .427, .427, .427, .427, .427, & 
+  .427, .427, .449, .470, .497, .526, & 
+  .413, .413, .413, .413, .413, .413, & 
+  .413, .413, .437, .458, .486, .516, & 
+  .399, .399, .399, .399, .399, .399, & 
+  .399, .399, .423, .445, .473, .506, & 
+                           ! pom soluble 
+  .975, .975, .975, .975, .975, .977, & 
+  .979, .982, .984, .987, .990, .994, & 
+  .972, .972, .972, .972, .973, .974, & 
+  .977, .980, .983, .986, .989, .993, & 
+  .963, .963, .963, .963, .964, .966, & 
+  .969, .974, .977, .982, .986, .991, & 
+  .955, .955, .955, .955, .955, .958, & 
+  .962, .967, .972, .977, .983, .989, & 
+  .944, .944, .944, .944, .944, .948, & 
+  .952, .959, .962, .972, .979, .987, & 
+                           ! sulfate soluble accumulation 
+  1.000,1.000,1.000,1.000,1.000,1.000, & 
+  1.000,1.000,1.000,1.000,1.000,1.000, & 
+  1.000,1.000,1.000,1.000,1.000,1.000, & 
+  1.000,1.000,1.000,1.000,1.000,1.000, & 
+  1.000,1.000,1.000,1.000,1.000,1.000, & 
+  1.000,1.000,1.000,1.000,1.000,1.000, & 
+  1.000,1.000,1.000,1.000,1.000,1.000, & 
+  1.000,1.000,1.000,1.000,1.000,1.000, & 
+  1.000,1.000,1.000,1.000,1.000,1.000, & 
+  1.000,1.000,1.000,1.000,1.000,1.000, & 
+                           ! sulfate soluble coarse 
+  1.000,1.000,1.000,1.000,1.000,1.000, &  
+  1.000,1.000,1.000,1.000,1.000,1.000, &  
+  1.000,1.000,1.000,1.000,1.000,1.000, &  
+  1.000,1.000,1.000,1.000,1.000,1.000, &  
+  1.000,1.000,1.000,1.000,1.000,1.000, &  
+  1.000,1.000,1.000,1.000,1.000,1.000, &  
+  1.000,1.000,1.000,1.000,1.000,1.000, &  
+  1.000,1.000,1.000,1.000,1.000,1.000, &  
+  1.000,1.000,1.000,1.000,1.000,1.000, &  
+  1.000,1.000,1.000,1.000,1.000,1.000, &  
+                           ! seasalt super coarse (computed below for 550nm) 
+  1.000,1.000,1.000,1.000,1.000,1.000, &  
+  1.000,1.000,1.000,1.000,1.000,1.000, &  
+  1.000,1.000,1.000,1.000,1.000,1.000, &  
+  1.000,1.000,1.000,1.000,1.000,1.000, &  
+  1.000,1.000,1.000,1.000,1.000,1.000, &  
+  1.000,1.000,1.000,1.000,1.000,1.000, &  
+  1.000,1.000,1.000,1.000,1.000,1.000, &  
+  1.000,1.000,1.000,1.000,1.000,1.000, &  
+  1.000,1.000,1.000,1.000,1.000,1.000, &  
+  1.000,1.000,1.000,1.000,1.000,1.000, & 
+                           ! seasalt coarse (computed below for 550nm) 
+  1.000,1.000,1.000,1.000,1.000,1.000, &  
+  1.000,1.000,1.000,1.000,1.000,1.000, &  
+  1.000,1.000,1.000,1.000,1.000,1.000, &  
+  1.000,1.000,1.000,1.000,1.000,1.000, &  
+  1.000,1.000,1.000,1.000,1.000,1.000, &  
+  1.000,1.000,1.000,1.000,1.000,1.000, &  
+  1.000,1.000,1.000,1.000,1.000,1.000, &  
+  1.000,1.000,1.000,1.000,1.000,1.000, &  
+  1.000,1.000,1.000,1.000,1.000,1.000, &  
+  1.000,1.000,1.000,1.000,1.000,1.000, &  
+                           ! seasalt soluble accumulation (computed below for 550nm) 
+  1.000,1.000,1.000,1.000,1.000,1.000, &  
+  1.000,1.000,1.000,1.000,1.000,1.000, &  
+  1.000,1.000,1.000,1.000,1.000,1.000, &  
+  1.000,1.000,1.000,1.000,1.000,1.000, &  
+  1.000,1.000,1.000,1.000,1.000,1.000, &  
+  1.000,1.000,1.000,1.000,1.000,1.000, &  
+  1.000,1.000,1.000,1.000,1.000,1.000, &  
+  1.000,1.000,1.000,1.000,1.000,1.000, &  
+  1.000,1.000,1.000,1.000,1.000,1.000, &  
+  1.000,1.000,1.000,1.000,1.000,1.000/ 
+
+ !
+  DATA piz_aeri_5wv/&
+     ! dust insoluble
+     0.944, 0.970, 0.977, 0.982, 0.987, &
+     ! bc insoluble
+     0.415, 0.387, 0.355, 0.328, 0.301, &
+     ! pom insoluble
+     0.972, 0.963, 0.943, 0.923, 0.897/
+
+! Interpolation des coefficients optiques de 19 niveaux vers le nombre des niveaux du model
+  IF (firstcall) THEN
+     firstcall=.FALSE.
+! Allocation
+    IF (.NOT. ALLOCATED(A1_ASSSM)) THEN
+        ALLOCATE(A1_ASSSM(klev),A2_ASSSM(klev), A3_ASSSM(klev),&
+          B1_ASSSM(klev), B2_ASSSM(klev), C1_ASSSM(klev), C2_ASSSM(klev),&
+          A1_CSSSM(klev), A2_CSSSM(klev), A3_CSSSM(klev),&
+          B1_CSSSM(klev), B2_CSSSM(klev), C1_CSSSM(klev), C2_CSSSM(klev),&
+          A1_SSSSM(klev), A2_SSSSM(klev), A3_SSSSM(klev),&
+          B1_SSSSM(klev), B2_SSSSM(klev), C1_SSSSM(klev), C2_SSSSM(klev), stat=ierr)
+        IF (ierr /= 0) CALL abort_physic('aeropt_5mw', 'pb in allocation 1',1)
+     END IF
+
+!Accumulation mode
+     CALL pres2lev(A1_ASSSM_19, A1_ASSSM, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(A2_ASSSM_19, A2_ASSSM, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(A3_ASSSM_19, A3_ASSSM, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(B1_ASSSM_19, B1_ASSSM, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(B2_ASSSM_19, B2_ASSSM, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(C1_ASSSM_19, C1_ASSSM, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(C2_ASSSM_19, C2_ASSSM, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+!Coarse mode
+     CALL pres2lev(A1_CSSSM_19, A1_CSSSM, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(A2_CSSSM_19, A2_CSSSM, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(A3_CSSSM_19, A3_CSSSM, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(B1_CSSSM_19, B1_CSSSM, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(B2_CSSSM_19, B2_CSSSM, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(C1_CSSSM_19, C1_CSSSM, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(C2_CSSSM_19, C2_CSSSM, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+!Super coarse mode
+     CALL pres2lev(A1_SSSSM_19, A1_SSSSM, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(A2_SSSSM_19, A2_SSSSM, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(A3_SSSSM_19, A3_SSSSM, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(B1_SSSSM_19, B1_SSSSM, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(B2_SSSSM_19, B2_SSSSM, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(C1_SSSSM_19, C1_SSSSM, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(C2_SSSSM_19, C2_SSSSM, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+
+  END IF ! firstcall
+
+  ! Initialisations
+  tau(:,:,:,:) =0.
+  tausum(:,:,:)= 0.
+  ai(:)=0.0
+
+  DO k=1, klev
+    DO i=1, klon
+      zrho=pplay(i,k)/t_seri(i,k)/RD     ! kg/m3
+      dh(i,k)=pdel(i,k)/(RG*zrho)    ! m
+    ENDDO
+  ENDDO
+
+  IF (flag_aerosol .EQ. 1) THEN 
+     nb_aer = 2
+     ALLOCATE (aerosol_name(nb_aer)) 
+     aerosol_name(1) = id_ASSO4M_phy
+     aerosol_name(2) = id_CSSO4M_phy
+  ELSEIF (flag_aerosol .EQ. 2) THEN
+     nb_aer = 2
+     ALLOCATE (aerosol_name(nb_aer)) 
+     aerosol_name(1) = id_ASBCM_phy
+     aerosol_name(2) = id_AIBCM_phy
+  ELSEIF (flag_aerosol .EQ. 3) THEN 
+     nb_aer = 2
+     ALLOCATE (aerosol_name(nb_aer)) 
+     aerosol_name(1) = id_ASPOMM_phy
+     aerosol_name(2) = id_AIPOMM_phy
+  ELSEIF (flag_aerosol .EQ. 4) THEN 
+     nb_aer = 3
+     ALLOCATE (aerosol_name(nb_aer)) 
+     aerosol_name(1) = id_CSSSM_phy
+     aerosol_name(2) = id_SSSSM_phy
+     aerosol_name(3) = id_ASSSM_phy
+  ELSEIF (flag_aerosol .EQ. 5) THEN 
+     nb_aer = 1
+     ALLOCATE (aerosol_name(nb_aer)) 
+     aerosol_name(1) = id_CIDUSTM_phy
+  ELSEIF (flag_aerosol .EQ. 6) THEN 
+     nb_aer = 10
+     ALLOCATE (aerosol_name(nb_aer)) 
+     aerosol_name(1) = id_ASSO4M_phy
+     aerosol_name(2) = id_ASBCM_phy
+     aerosol_name(3) = id_AIBCM_phy
+     aerosol_name(4) = id_ASPOMM_phy
+     aerosol_name(5) = id_AIPOMM_phy
+     aerosol_name(6) = id_CSSSM_phy
+     aerosol_name(7) = id_SSSSM_phy
+     aerosol_name(8) = id_ASSSM_phy
+     aerosol_name(9) = id_CIDUSTM_phy
+     aerosol_name(10) = id_CSSO4M_phy
+  ENDIF
+
+  ! 
+  ! loop over modes, use of precalculated nmd and corresponding sigma
+  !    loop over wavelengths
+  !    for each mass species in mode
+  !      interpolate from Sext to retrieve Sext_at_gridpoint_per_species
+  !      compute optical_thickness_at_gridpoint_per_species
+  
+  !
+  ! Calculations that need to be done since we are not in the subroutines INCA
+  !      
+
+  DO n=1,nbre_RH-1
+    fact_RH(n)=1./(RH_tab(n+1)-RH_tab(n))
+  ENDDO
+   
+  DO k=1, klev
+    DO i=1, klon
+      rh(i,k)=MIN(RHcl(i,k)*100.,RH_MAX)
+      RH_num(i,k) = INT( rh(i,k)/10. + 1.)
+!--test olivier pour pas de reindicage
+!      RH_num(i,k) =1
+      IF (rh(i,k).GT.85.) RH_num(i,k)=10
+      IF (rh(i,k).GT.90.) RH_num(i,k)=11
+      DELTA(i,k)=(rh(i,k)-RH_tab(RH_num(i,k)))*fact_RH(RH_num(i,k))
+    ENDDO
+  ENDDO
+
+  used_tau(:)=.FALSE.
+    
+  DO m=1,nb_aer   ! tau is only computed for each mass    
+    fac=1.0
+    IF (aerosol_name(m).EQ.id_ASBCM_phy) THEN
+        soluble=.TRUE.
+        spsol=1
+        spss=0
+    ELSEIF (aerosol_name(m).EQ.id_ASPOMM_phy) THEN 
+        soluble=.TRUE.
+        spsol=2 
+        spss=0
+    ELSEIF (aerosol_name(m).EQ.id_ASSO4M_phy) THEN
+        soluble=.TRUE.
+        spsol=3
+        spss=0
+        fac=1.375    ! (NH4)2-SO4/SO4 132/96 mass conversion factor for OD
+    ELSEIF (aerosol_name(m).EQ.id_CSSO4M_phy) THEN
+        soluble=.TRUE.
+        spsol=4
+        spss=0
+        fac=1.375    ! (NH4)2-SO4/SO4 132/96 mass conversion factor for OD
+    ELSEIF (aerosol_name(m).EQ.id_SSSSM_phy) THEN 
+        soluble=.TRUE.
+        spsol=5
+        spss=3
+    ELSEIF (aerosol_name(m).EQ.id_CSSSM_phy) THEN 
+        soluble=.TRUE.
+        spsol=6
+        spss=2
+    ELSEIF (aerosol_name(m).EQ.id_ASSSM_phy) THEN
+        soluble=.TRUE.
+        spsol=7
+        spss=1
+    ELSEIF (aerosol_name(m).EQ.id_CIDUSTM_phy) THEN 
+        soluble=.FALSE.
+        spinsol=1
+        spss=0
+    ELSEIF  (aerosol_name(m).EQ.id_AIBCM_phy) THEN 
+        soluble=.FALSE.
+        spinsol=2
+        spss=0
+    ELSEIF (aerosol_name(m).EQ.id_AIPOMM_phy) THEN 
+        soluble=.FALSE.
+        spinsol=3
+        spss=0
+    ELSE 
+        CYCLE
+    ENDIF
+
+    IF (soluble) then
+      used_tau(spsol)=.TRUE.
+    ELSE
+      used_tau(naero_soluble+spinsol)=.TRUE.
+    ENDIF
+
+    aerindex=aerosol_name(m)
+
+    DO la=1,las
+
+    !--only 550 and 865 nm are used
+    IF (la.NE.la550.AND.la.NE.la865) CYCLE
+
+      IF (soluble) THEN
+
+        IF ((la.EQ.2).AND.(spss.NE.0)) THEN !la=2 corresponds to 550 nm
+          IF (spss.EQ.1) THEN !accumulation mode
+            DO k=1, klev
+              DO i=1, klon
+                H=rh(i,k)/100.
+                tau_ae5wv_int=A1_ASSSM(k)+A2_ASSSM(k)*H+A3_ASSSM(k)/(H-1.05)
+                tau(i,k,la,aerindex) = m_allaer(i,k,aerindex)/1.e6*dh(i,k)*tau_ae5wv_int*fac
+                tausum(i,la,aerindex)=tausum(i,la,aerindex)+tau(i,k,la,aerindex)
+              ENDDO
+            ENDDO
+          ENDIF
+  
+          IF (spss.EQ.2) THEN !coarse mode
+            DO k=1, klev
+              DO i=1, klon
+                H=rh(i,k)/100.
+                tau_ae5wv_int=A1_CSSSM(k)+A2_CSSSM(k)*H+A3_CSSSM(k)/(H-1.05)
+                tau(i,k,la,aerindex) = m_allaer(i,k,aerindex)/1.e6*dh(i,k)*tau_ae5wv_int*fac
+                tausum(i,la,aerindex)=tausum(i,la,aerindex)+tau(i,k,la,aerindex)
+              ENDDO
+            ENDDO
+          ENDIF
+
+          IF (spss.EQ.3) THEN !super coarse mode
+            DO k=1, klev
+              DO i=1, klon
+                H=rh(i,k)/100.
+                tau_ae5wv_int=A1_SSSSM(k)+A2_SSSSM(k)*H+A3_SSSSM(k)/(H-1.05)
+                tau(i,k,la,aerindex) = m_allaer(i,k,aerindex)/1.e6*dh(i,k)*tau_ae5wv_int*fac
+                tausum(i,la,aerindex)=tausum(i,la,aerindex)+tau(i,k,la,aerindex)
+              ENDDO
+            ENDDO
+          ENDIF
+
+        ELSE
+          DO k=1, klev
+            DO i=1, klon
+              tau_ae5wv_int = alpha_aers_5wv(RH_num(i,k),la,spsol)+DELTA(i,k)* &
+                             (alpha_aers_5wv(RH_num(i,k)+1,la,spsol) - & 
+                              alpha_aers_5wv(RH_num(i,k),la,spsol))
+              tau(i,k,la,aerindex) = m_allaer(i,k,aerindex)/1.e6*dh(i,k)*tau_ae5wv_int*fac
+              tausum(i,la,aerindex)=tausum(i,la,aerindex)+tau(i,k,la,aerindex)
+            ENDDO
+          ENDDO
+        ENDIF
+
+      ELSE                                                  ! For insoluble aerosol
+
+        DO k=1, klev
+          DO i=1, klon
+            tau_ae5wv_int = alpha_aeri_5wv(la,spinsol)
+            tau(i,k,la,aerindex) = m_allaer(i,k,aerindex)/1.e6*dh(i,k)*tau_ae5wv_int*fac
+            tausum(i,la,aerindex)=tausum(i,la,aerindex)+tau(i,k,la,aerindex)
+          ENDDO
+        ENDDO
+
+      ENDIF
+
+    ENDDO   ! boucle sur les longueurs d'onde
+  ENDDO     ! Boucle  sur les masses de traceurs
+
+  DO m=1,naero_spc
+    IF (.NOT.used_tau(m)) tau(:,:,:,m)=0.
+  ENDDO  
+
+!--AOD calculations for diagnostics
+  od550aer(:)=SUM(tausum(:,la550,:),dim=2)
+  od865aer(:)=SUM(tausum(:,la865,:),dim=2)
+
+!--extinction coefficient for diagnostic
+  ec550aer(:,:)=SUM(tau(:,:,la550,:),dim=3)/dh(:,:)
+  
+!--acc mode AOD calculation for diagnostic
+  od550lt1aer(:)=tausum(:,la550,id_ASSO4M_phy)+tausum(:,la550,id_ASBCM_phy)+tausum(:,la550,id_AIBCM_phy)+  &
+                 tausum(:,la550,id_ASPOMM_phy)+tausum(:,la550,id_AIPOMM_phy)+tausum(:,la550,id_ASSSM_phy)+ &
+                 0.03*tausum(:,la550,id_CSSSM_phy)+0.4*tausum(:,la550,id_CIDUSTM_phy)
+
+  DEALLOCATE(aerosol_name) 
+  
+END SUBROUTINE AEROPT_5WV
Index: DZ6/trunk/libf/phylmd/ajsec.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/ajsec.F90	(revision 5267)
+++ 	(revision )
@@ -1,397 +1,0 @@
-
-! $Header$
-
-SUBROUTINE ajsec(paprs, pplay, t, q, limbas, d_t, d_q)
-  USE dimphy
-  IMPLICIT NONE
-  ! ======================================================================
-  ! Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818
-  ! Objet: ajustement sec (adaptation du GCM du LMD)
-  ! ======================================================================
-  ! Arguments:
-  ! t-------input-R- Temperature
-
-  ! d_t-----output-R-Incrementation de la temperature
-  ! ======================================================================
-  include "YOMCST.h"
-  REAL paprs(klon, klev+1), pplay(klon, klev)
-  REAL t(klon, klev), q(klon, klev)
-  REAL d_t(klon, klev), d_q(klon, klev)
-
-  INTEGER limbas(klon), limhau ! les couches a ajuster
-
-  LOGICAL mixq
-  ! cc      PARAMETER (mixq=.TRUE.)
-  PARAMETER (mixq=.FALSE.)
-
-  REAL zh(klon, klev)
-  REAL zho(klon, klev)
-  REAL zq(klon, klev)
-  REAL zpk(klon, klev)
-  REAL zpkdp(klon, klev)
-  REAL hm, sm, qm
-  LOGICAL modif(klon), down
-  INTEGER i, k, k1, k2
-
-  ! Initialisation:
-
-  ! ym
-  limhau = klev
-
-  DO k = 1, klev
-    DO i = 1, klon
-      d_t(i, k) = 0.0
-      d_q(i, k) = 0.0
-    END DO
-  END DO
-  ! ------------------------------------- detection des profils a modifier
-  DO k = 1, limhau
-    DO i = 1, klon
-      zpk(i, k) = pplay(i, k)**rkappa
-      zh(i, k) = rcpd*t(i, k)/zpk(i, k)
-      zho(i, k) = zh(i, k)
-      zq(i, k) = q(i, k)
-    END DO
-  END DO
-
-  DO k = 1, limhau
-    DO i = 1, klon
-      zpkdp(i, k) = zpk(i, k)*(paprs(i,k)-paprs(i,k+1))
-    END DO
-  END DO
-
-  DO i = 1, klon
-    modif(i) = .FALSE.
-  END DO
-  DO k = 2, limhau
-    DO i = 1, klon
-      IF (.NOT. modif(i) .AND. k-1>limbas(i)) THEN
-        IF (zh(i,k)<zh(i,k-1)) modif(i) = .TRUE.
-      END IF
-    END DO
-  END DO
-  ! ------------------------------------- correction des profils instables
-  DO i = 1, klon
-    IF (modif(i)) THEN
-      k2 = limbas(i)
-8000  CONTINUE
-      k2 = k2 + 1
-      IF (k2>limhau) GO TO 8001
-      IF (zh(i,k2)<zh(i,k2-1)) THEN
-        k1 = k2 - 1
-        k = k1
-        sm = zpkdp(i, k2)
-        hm = zh(i, k2)
-        qm = zq(i, k2)
-8020    CONTINUE
-        sm = sm + zpkdp(i, k)
-        hm = hm + zpkdp(i, k)*(zh(i,k)-hm)/sm
-        qm = qm + zpkdp(i, k)*(zq(i,k)-qm)/sm
-        down = .FALSE.
-        IF (k1/=limbas(i)) THEN
-          IF (hm<zh(i,k1-1)) down = .TRUE.
-        END IF
-        IF (down) THEN
-          k1 = k1 - 1
-          k = k1
-        ELSE
-          IF ((k2==limhau)) GO TO 8021
-          IF ((zh(i,k2+1)>=hm)) GO TO 8021
-          k2 = k2 + 1
-          k = k2
-        END IF
-        GO TO 8020
-8021    CONTINUE
-        ! ------------ nouveau profil : constant (valeur moyenne)
-        DO k = k1, k2
-          zh(i, k) = hm
-          zq(i, k) = qm
-        END DO
-        k2 = k2 + 1
-      END IF
-      GO TO 8000
-8001  CONTINUE
-    END IF
-  END DO
-
-  DO k = 1, limhau
-    DO i = 1, klon
-      d_t(i, k) = (zh(i,k)-zho(i,k))*zpk(i, k)/rcpd
-      d_q(i, k) = zq(i, k) - q(i, k)
-    END DO
-  END DO
-
-  ! FH : les d_q et d_t sont maintenant calcules de facon a valoir
-  ! effectivement 0. si on ne fait rien.
-
-  ! IF (limbas.GT.1) THEN
-  ! DO k = 1, limbas-1
-  ! DO i = 1, klon
-  ! d_t(i,k) = 0.0
-  ! d_q(i,k) = 0.0
-  ! ENDDO
-  ! ENDDO
-  ! ENDIF
-
-  ! IF (limhau.LT.klev) THEN
-  ! DO k = limhau+1, klev
-  ! DO i = 1, klon
-  ! d_t(i,k) = 0.0
-  ! d_q(i,k) = 0.0
-  ! ENDDO
-  ! ENDDO
-  ! ENDIF
-
-  IF (.NOT. mixq) THEN
-    DO k = 1, klev
-      DO i = 1, klon
-        d_q(i, k) = 0.0
-      END DO
-    END DO
-  END IF
-
-  RETURN
-END SUBROUTINE ajsec
-
-SUBROUTINE ajsec_convv2(paprs, pplay, t, q, d_t, d_q)
-  USE dimphy
-  IMPLICIT NONE
-  ! ======================================================================
-  ! Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818
-  ! Objet: ajustement sec (adaptation du GCM du LMD)
-  ! ======================================================================
-  ! Arguments:
-  ! t-------input-R- Temperature
-
-  ! d_t-----output-R-Incrementation de la temperature
-  ! ======================================================================
-  include "YOMCST.h"
-  REAL paprs(klon, klev+1), pplay(klon, klev)
-  REAL t(klon, klev), q(klon, klev)
-  REAL d_t(klon, klev), d_q(klon, klev)
-
-  INTEGER limbas, limhau ! les couches a ajuster
-  ! cc      PARAMETER (limbas=klev-3, limhau=klev)
-  ! ym      PARAMETER (limbas=1, limhau=klev)
-
-  LOGICAL mixq
-  ! cc      PARAMETER (mixq=.TRUE.)
-  PARAMETER (mixq=.FALSE.)
-
-  REAL zh(klon, klev)
-  REAL zq(klon, klev)
-  REAL zpk(klon, klev)
-  REAL zpkdp(klon, klev)
-  REAL hm, sm, qm
-  LOGICAL modif(klon), down
-  INTEGER i, k, k1, k2
-
-  ! Initialisation:
-
-  ! ym
-  limbas = 1
-  limhau = klev
-
-  DO k = 1, klev
-    DO i = 1, klon
-      d_t(i, k) = 0.0
-      d_q(i, k) = 0.0
-    END DO
-  END DO
-  ! ------------------------------------- detection des profils a modifier
-  DO k = limbas, limhau
-    DO i = 1, klon
-      zpk(i, k) = pplay(i, k)**rkappa
-      zh(i, k) = rcpd*t(i, k)/zpk(i, k)
-      zq(i, k) = q(i, k)
-    END DO
-  END DO
-
-  DO k = limbas, limhau
-    DO i = 1, klon
-      zpkdp(i, k) = zpk(i, k)*(paprs(i,k)-paprs(i,k+1))
-    END DO
-  END DO
-
-  DO i = 1, klon
-    modif(i) = .FALSE.
-  END DO
-  DO k = limbas + 1, limhau
-    DO i = 1, klon
-      IF (.NOT. modif(i)) THEN
-        IF (zh(i,k)<zh(i,k-1)) modif(i) = .TRUE.
-      END IF
-    END DO
-  END DO
-  ! ------------------------------------- correction des profils instables
-  DO i = 1, klon
-    IF (modif(i)) THEN
-      k2 = limbas
-8000  CONTINUE
-      k2 = k2 + 1
-      IF (k2>limhau) GO TO 8001
-      IF (zh(i,k2)<zh(i,k2-1)) THEN
-        k1 = k2 - 1
-        k = k1
-        sm = zpkdp(i, k2)
-        hm = zh(i, k2)
-        qm = zq(i, k2)
-8020    CONTINUE
-        sm = sm + zpkdp(i, k)
-        hm = hm + zpkdp(i, k)*(zh(i,k)-hm)/sm
-        qm = qm + zpkdp(i, k)*(zq(i,k)-qm)/sm
-        down = .FALSE.
-        IF (k1/=limbas) THEN
-          IF (hm<zh(i,k1-1)) down = .TRUE.
-        END IF
-        IF (down) THEN
-          k1 = k1 - 1
-          k = k1
-        ELSE
-          IF ((k2==limhau)) GO TO 8021
-          IF ((zh(i,k2+1)>=hm)) GO TO 8021
-          k2 = k2 + 1
-          k = k2
-        END IF
-        GO TO 8020
-8021    CONTINUE
-        ! ------------ nouveau profil : constant (valeur moyenne)
-        DO k = k1, k2
-          zh(i, k) = hm
-          zq(i, k) = qm
-        END DO
-        k2 = k2 + 1
-      END IF
-      GO TO 8000
-8001  CONTINUE
-    END IF
-  END DO
-
-  DO k = limbas, limhau
-    DO i = 1, klon
-      d_t(i, k) = zh(i, k)*zpk(i, k)/rcpd - t(i, k)
-      d_q(i, k) = zq(i, k) - q(i, k)
-    END DO
-  END DO
-
-  IF (limbas>1) THEN
-    DO k = 1, limbas - 1
-      DO i = 1, klon
-        d_t(i, k) = 0.0
-        d_q(i, k) = 0.0
-      END DO
-    END DO
-  END IF
-
-  IF (limhau<klev) THEN
-    DO k = limhau + 1, klev
-      DO i = 1, klon
-        d_t(i, k) = 0.0
-        d_q(i, k) = 0.0
-      END DO
-    END DO
-  END IF
-
-  IF (.NOT. mixq) THEN
-    DO k = 1, klev
-      DO i = 1, klon
-        d_q(i, k) = 0.0
-      END DO
-    END DO
-  END IF
-
-  RETURN
-END SUBROUTINE ajsec_convv2
-SUBROUTINE ajsec_old(paprs, pplay, t, d_t)
-  USE dimphy
-  IMPLICIT NONE
-  ! ======================================================================
-  ! Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818
-  ! Objet: ajustement sec (adaptation du GCM du LMD)
-  ! ======================================================================
-  ! Arguments:
-  ! t-------input-R- Temperature
-
-  ! d_t-----output-R-Incrementation de la temperature
-  ! ======================================================================
-  include "YOMCST.h"
-  REAL paprs(klon, klev+1), pplay(klon, klev)
-  REAL t(klon, klev)
-  REAL d_t(klon, klev)
-
-  REAL local_h(klon, klev)
-  REAL hm, sm
-  LOGICAL modif(klon), down
-  INTEGER i, l, l1, l2
-  ! ------------------------------------- detection des profils a modifier
-  DO i = 1, klon
-    modif(i) = .FALSE.
-  END DO
-
-  DO l = 1, klev
-    DO i = 1, klon
-      local_h(i, l) = rcpd*t(i, l)/(pplay(i,l)**rkappa)
-    END DO
-  END DO
-
-  DO l = 2, klev
-    DO i = 1, klon
-      IF (local_h(i,l)<local_h(i,l-1)) THEN
-        modif(i) = .TRUE.
-      ELSE
-        modif(i) = modif(i)
-      END IF
-    END DO
-  END DO
-  ! ------------------------------------- correction des profils instables
-  DO i = 1, klon
-    IF (modif(i)) THEN
-      l2 = 1
-8000  CONTINUE
-      l2 = l2 + 1
-      IF (l2>klev) GO TO 8001
-      IF (local_h(i,l2)<local_h(i,l2-1)) THEN
-        l1 = l2 - 1
-        l = l1
-        sm = pplay(i, l2)**rkappa*(paprs(i,l2)-paprs(i,l2+1))
-        hm = local_h(i, l2)
-8020    CONTINUE
-        sm = sm + pplay(i, l)**rkappa*(paprs(i,l)-paprs(i,l+1))
-        hm = hm + pplay(i, l)**rkappa*(paprs(i,l)-paprs(i,l+1))*(local_h(i,l) &
-          -hm)/sm
-        down = .FALSE.
-        IF (l1/=1) THEN
-          IF (hm<local_h(i,l1-1)) THEN
-            down = .TRUE.
-          END IF
-        END IF
-        IF (down) THEN
-          l1 = l1 - 1
-          l = l1
-        ELSE
-          IF ((l2==klev)) GO TO 8021
-          IF ((local_h(i,l2+1)>=hm)) GO TO 8021
-          l2 = l2 + 1
-          l = l2
-        END IF
-        GO TO 8020
-8021    CONTINUE
-        ! ------------ nouveau profil : constant (valeur moyenne)
-        DO l = l1, l2
-          local_h(i, l) = hm
-        END DO
-        l2 = l2 + 1
-      END IF
-      GO TO 8000
-8001  CONTINUE
-    END IF
-  END DO
-
-  DO l = 1, klev
-    DO i = 1, klon
-      d_t(i, l) = local_h(i, l)*(pplay(i,l)**rkappa)/rcpd - t(i, l)
-    END DO
-  END DO
-
-  RETURN
-END SUBROUTINE ajsec_old
Index: /LMDZ6/trunk/libf/phylmd/ajsec.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/ajsec.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/ajsec.f90	(revision 5268)
@@ -0,0 +1,397 @@
+
+! $Header$
+
+SUBROUTINE ajsec(paprs, pplay, t, q, limbas, d_t, d_q)
+  USE dimphy
+  IMPLICIT NONE
+  ! ======================================================================
+  ! Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818
+  ! Objet: ajustement sec (adaptation du GCM du LMD)
+  ! ======================================================================
+  ! Arguments:
+  ! t-------input-R- Temperature
+
+  ! d_t-----output-R-Incrementation de la temperature
+  ! ======================================================================
+  include "YOMCST.h"
+  REAL paprs(klon, klev+1), pplay(klon, klev)
+  REAL t(klon, klev), q(klon, klev)
+  REAL d_t(klon, klev), d_q(klon, klev)
+
+  INTEGER limbas(klon), limhau ! les couches a ajuster
+
+  LOGICAL mixq
+  ! cc      PARAMETER (mixq=.TRUE.)
+  PARAMETER (mixq=.FALSE.)
+
+  REAL zh(klon, klev)
+  REAL zho(klon, klev)
+  REAL zq(klon, klev)
+  REAL zpk(klon, klev)
+  REAL zpkdp(klon, klev)
+  REAL hm, sm, qm
+  LOGICAL modif(klon), down
+  INTEGER i, k, k1, k2
+
+  ! Initialisation:
+
+  ! ym
+  limhau = klev
+
+  DO k = 1, klev
+    DO i = 1, klon
+      d_t(i, k) = 0.0
+      d_q(i, k) = 0.0
+    END DO
+  END DO
+  ! ------------------------------------- detection des profils a modifier
+  DO k = 1, limhau
+    DO i = 1, klon
+      zpk(i, k) = pplay(i, k)**rkappa
+      zh(i, k) = rcpd*t(i, k)/zpk(i, k)
+      zho(i, k) = zh(i, k)
+      zq(i, k) = q(i, k)
+    END DO
+  END DO
+
+  DO k = 1, limhau
+    DO i = 1, klon
+      zpkdp(i, k) = zpk(i, k)*(paprs(i,k)-paprs(i,k+1))
+    END DO
+  END DO
+
+  DO i = 1, klon
+    modif(i) = .FALSE.
+  END DO
+  DO k = 2, limhau
+    DO i = 1, klon
+      IF (.NOT. modif(i) .AND. k-1>limbas(i)) THEN
+        IF (zh(i,k)<zh(i,k-1)) modif(i) = .TRUE.
+      END IF
+    END DO
+  END DO
+  ! ------------------------------------- correction des profils instables
+  DO i = 1, klon
+    IF (modif(i)) THEN
+      k2 = limbas(i)
+8000  CONTINUE
+      k2 = k2 + 1
+      IF (k2>limhau) GO TO 8001
+      IF (zh(i,k2)<zh(i,k2-1)) THEN
+        k1 = k2 - 1
+        k = k1
+        sm = zpkdp(i, k2)
+        hm = zh(i, k2)
+        qm = zq(i, k2)
+8020    CONTINUE
+        sm = sm + zpkdp(i, k)
+        hm = hm + zpkdp(i, k)*(zh(i,k)-hm)/sm
+        qm = qm + zpkdp(i, k)*(zq(i,k)-qm)/sm
+        down = .FALSE.
+        IF (k1/=limbas(i)) THEN
+          IF (hm<zh(i,k1-1)) down = .TRUE.
+        END IF
+        IF (down) THEN
+          k1 = k1 - 1
+          k = k1
+        ELSE
+          IF ((k2==limhau)) GO TO 8021
+          IF ((zh(i,k2+1)>=hm)) GO TO 8021
+          k2 = k2 + 1
+          k = k2
+        END IF
+        GO TO 8020
+8021    CONTINUE
+        ! ------------ nouveau profil : constant (valeur moyenne)
+        DO k = k1, k2
+          zh(i, k) = hm
+          zq(i, k) = qm
+        END DO
+        k2 = k2 + 1
+      END IF
+      GO TO 8000
+8001  CONTINUE
+    END IF
+  END DO
+
+  DO k = 1, limhau
+    DO i = 1, klon
+      d_t(i, k) = (zh(i,k)-zho(i,k))*zpk(i, k)/rcpd
+      d_q(i, k) = zq(i, k) - q(i, k)
+    END DO
+  END DO
+
+  ! FH : les d_q et d_t sont maintenant calcules de facon a valoir
+  ! effectivement 0. si on ne fait rien.
+
+  ! IF (limbas.GT.1) THEN
+  ! DO k = 1, limbas-1
+  ! DO i = 1, klon
+  ! d_t(i,k) = 0.0
+  ! d_q(i,k) = 0.0
+  ! ENDDO
+  ! ENDDO
+  ! ENDIF
+
+  ! IF (limhau.LT.klev) THEN
+  ! DO k = limhau+1, klev
+  ! DO i = 1, klon
+  ! d_t(i,k) = 0.0
+  ! d_q(i,k) = 0.0
+  ! ENDDO
+  ! ENDDO
+  ! ENDIF
+
+  IF (.NOT. mixq) THEN
+    DO k = 1, klev
+      DO i = 1, klon
+        d_q(i, k) = 0.0
+      END DO
+    END DO
+  END IF
+
+  RETURN
+END SUBROUTINE ajsec
+
+SUBROUTINE ajsec_convv2(paprs, pplay, t, q, d_t, d_q)
+  USE dimphy
+  IMPLICIT NONE
+  ! ======================================================================
+  ! Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818
+  ! Objet: ajustement sec (adaptation du GCM du LMD)
+  ! ======================================================================
+  ! Arguments:
+  ! t-------input-R- Temperature
+
+  ! d_t-----output-R-Incrementation de la temperature
+  ! ======================================================================
+  include "YOMCST.h"
+  REAL paprs(klon, klev+1), pplay(klon, klev)
+  REAL t(klon, klev), q(klon, klev)
+  REAL d_t(klon, klev), d_q(klon, klev)
+
+  INTEGER limbas, limhau ! les couches a ajuster
+  ! cc      PARAMETER (limbas=klev-3, limhau=klev)
+  ! ym      PARAMETER (limbas=1, limhau=klev)
+
+  LOGICAL mixq
+  ! cc      PARAMETER (mixq=.TRUE.)
+  PARAMETER (mixq=.FALSE.)
+
+  REAL zh(klon, klev)
+  REAL zq(klon, klev)
+  REAL zpk(klon, klev)
+  REAL zpkdp(klon, klev)
+  REAL hm, sm, qm
+  LOGICAL modif(klon), down
+  INTEGER i, k, k1, k2
+
+  ! Initialisation:
+
+  ! ym
+  limbas = 1
+  limhau = klev
+
+  DO k = 1, klev
+    DO i = 1, klon
+      d_t(i, k) = 0.0
+      d_q(i, k) = 0.0
+    END DO
+  END DO
+  ! ------------------------------------- detection des profils a modifier
+  DO k = limbas, limhau
+    DO i = 1, klon
+      zpk(i, k) = pplay(i, k)**rkappa
+      zh(i, k) = rcpd*t(i, k)/zpk(i, k)
+      zq(i, k) = q(i, k)
+    END DO
+  END DO
+
+  DO k = limbas, limhau
+    DO i = 1, klon
+      zpkdp(i, k) = zpk(i, k)*(paprs(i,k)-paprs(i,k+1))
+    END DO
+  END DO
+
+  DO i = 1, klon
+    modif(i) = .FALSE.
+  END DO
+  DO k = limbas + 1, limhau
+    DO i = 1, klon
+      IF (.NOT. modif(i)) THEN
+        IF (zh(i,k)<zh(i,k-1)) modif(i) = .TRUE.
+      END IF
+    END DO
+  END DO
+  ! ------------------------------------- correction des profils instables
+  DO i = 1, klon
+    IF (modif(i)) THEN
+      k2 = limbas
+8000  CONTINUE
+      k2 = k2 + 1
+      IF (k2>limhau) GO TO 8001
+      IF (zh(i,k2)<zh(i,k2-1)) THEN
+        k1 = k2 - 1
+        k = k1
+        sm = zpkdp(i, k2)
+        hm = zh(i, k2)
+        qm = zq(i, k2)
+8020    CONTINUE
+        sm = sm + zpkdp(i, k)
+        hm = hm + zpkdp(i, k)*(zh(i,k)-hm)/sm
+        qm = qm + zpkdp(i, k)*(zq(i,k)-qm)/sm
+        down = .FALSE.
+        IF (k1/=limbas) THEN
+          IF (hm<zh(i,k1-1)) down = .TRUE.
+        END IF
+        IF (down) THEN
+          k1 = k1 - 1
+          k = k1
+        ELSE
+          IF ((k2==limhau)) GO TO 8021
+          IF ((zh(i,k2+1)>=hm)) GO TO 8021
+          k2 = k2 + 1
+          k = k2
+        END IF
+        GO TO 8020
+8021    CONTINUE
+        ! ------------ nouveau profil : constant (valeur moyenne)
+        DO k = k1, k2
+          zh(i, k) = hm
+          zq(i, k) = qm
+        END DO
+        k2 = k2 + 1
+      END IF
+      GO TO 8000
+8001  CONTINUE
+    END IF
+  END DO
+
+  DO k = limbas, limhau
+    DO i = 1, klon
+      d_t(i, k) = zh(i, k)*zpk(i, k)/rcpd - t(i, k)
+      d_q(i, k) = zq(i, k) - q(i, k)
+    END DO
+  END DO
+
+  IF (limbas>1) THEN
+    DO k = 1, limbas - 1
+      DO i = 1, klon
+        d_t(i, k) = 0.0
+        d_q(i, k) = 0.0
+      END DO
+    END DO
+  END IF
+
+  IF (limhau<klev) THEN
+    DO k = limhau + 1, klev
+      DO i = 1, klon
+        d_t(i, k) = 0.0
+        d_q(i, k) = 0.0
+      END DO
+    END DO
+  END IF
+
+  IF (.NOT. mixq) THEN
+    DO k = 1, klev
+      DO i = 1, klon
+        d_q(i, k) = 0.0
+      END DO
+    END DO
+  END IF
+
+  RETURN
+END SUBROUTINE ajsec_convv2
+SUBROUTINE ajsec_old(paprs, pplay, t, d_t)
+  USE dimphy
+  IMPLICIT NONE
+  ! ======================================================================
+  ! Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818
+  ! Objet: ajustement sec (adaptation du GCM du LMD)
+  ! ======================================================================
+  ! Arguments:
+  ! t-------input-R- Temperature
+
+  ! d_t-----output-R-Incrementation de la temperature
+  ! ======================================================================
+  include "YOMCST.h"
+  REAL paprs(klon, klev+1), pplay(klon, klev)
+  REAL t(klon, klev)
+  REAL d_t(klon, klev)
+
+  REAL local_h(klon, klev)
+  REAL hm, sm
+  LOGICAL modif(klon), down
+  INTEGER i, l, l1, l2
+  ! ------------------------------------- detection des profils a modifier
+  DO i = 1, klon
+    modif(i) = .FALSE.
+  END DO
+
+  DO l = 1, klev
+    DO i = 1, klon
+      local_h(i, l) = rcpd*t(i, l)/(pplay(i,l)**rkappa)
+    END DO
+  END DO
+
+  DO l = 2, klev
+    DO i = 1, klon
+      IF (local_h(i,l)<local_h(i,l-1)) THEN
+        modif(i) = .TRUE.
+      ELSE
+        modif(i) = modif(i)
+      END IF
+    END DO
+  END DO
+  ! ------------------------------------- correction des profils instables
+  DO i = 1, klon
+    IF (modif(i)) THEN
+      l2 = 1
+8000  CONTINUE
+      l2 = l2 + 1
+      IF (l2>klev) GO TO 8001
+      IF (local_h(i,l2)<local_h(i,l2-1)) THEN
+        l1 = l2 - 1
+        l = l1
+        sm = pplay(i, l2)**rkappa*(paprs(i,l2)-paprs(i,l2+1))
+        hm = local_h(i, l2)
+8020    CONTINUE
+        sm = sm + pplay(i, l)**rkappa*(paprs(i,l)-paprs(i,l+1))
+        hm = hm + pplay(i, l)**rkappa*(paprs(i,l)-paprs(i,l+1))*(local_h(i,l) &
+          -hm)/sm
+        down = .FALSE.
+        IF (l1/=1) THEN
+          IF (hm<local_h(i,l1-1)) THEN
+            down = .TRUE.
+          END IF
+        END IF
+        IF (down) THEN
+          l1 = l1 - 1
+          l = l1
+        ELSE
+          IF ((l2==klev)) GO TO 8021
+          IF ((local_h(i,l2+1)>=hm)) GO TO 8021
+          l2 = l2 + 1
+          l = l2
+        END IF
+        GO TO 8020
+8021    CONTINUE
+        ! ------------ nouveau profil : constant (valeur moyenne)
+        DO l = l1, l2
+          local_h(i, l) = hm
+        END DO
+        l2 = l2 + 1
+      END IF
+      GO TO 8000
+8001  CONTINUE
+    END IF
+  END DO
+
+  DO l = 1, klev
+    DO i = 1, klon
+      d_t(i, l) = local_h(i, l)*(pplay(i,l)**rkappa)/rcpd - t(i, l)
+    END DO
+  END DO
+
+  RETURN
+END SUBROUTINE ajsec_old
Index: DZ6/trunk/libf/phylmd/albedo.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/albedo.F90	(revision 5267)
+++ 	(revision )
@@ -1,161 +1,0 @@
-! $Id$
-module albedo
-
-  IMPLICIT NONE
-
-contains
-
-  SUBROUTINE alboc(rjour, rlat, albedo)
-    USE dimphy
-    ! ======================================================================
-    ! Auteur(s): Z.X. Li (LMD/CNRS) (adaptation du GCM du LMD)
-    ! Date: le 16 mars 1995
-    ! Objet: Calculer l'albedo sur l'ocean
-    ! Methode: Integrer numeriquement l'albedo pendant une journee
-
-    ! Arguments;
-    ! rjour (in,R)  : jour dans l'annee (a compter du 1 janvier)
-    ! rlat (in,R)   : latitude en degre
-    ! albedo (out,R): albedo obtenu (de 0 a 1)
-    ! ======================================================================
-    include "YOMCST.h"
-    include "clesphys.h"
-
-    INTEGER npts ! il controle la precision de l'integration
-    PARAMETER (npts=120) ! 120 correspond a l'interval 6 minutes
-
-    REAL rlat(klon), rjour, albedo(klon)
-    REAL zdist, zlonsun, zpi, zdeclin
-    REAL rmu, alb, srmu, salb, fauxo, aa, bb
-    INTEGER i, k
-    ! ccIM
-    LOGICAL ancien_albedo
-    PARAMETER (ancien_albedo=.FALSE.)
-    ! SAVE albedo
-
-    IF (ancien_albedo) THEN
-
-       zpi = 4.*atan(1.)
-
-       ! Calculer la longitude vraie de l'orbite terrestre:
-       CALL orbite(rjour, zlonsun, zdist)
-
-       ! Calculer la declinaison du soleil (qui varie entre + et - R_incl):
-       zdeclin = asin(sin(zlonsun*zpi/180.0)*sin(r_incl*zpi/180.0))
-
-       DO i = 1, klon
-          aa = sin(rlat(i)*zpi/180.0)*sin(zdeclin)
-          bb = cos(rlat(i)*zpi/180.0)*cos(zdeclin)
-
-          ! Midi local (angle du temps = 0.0):
-          rmu = aa + bb*cos(0.0)
-          rmu = max(0.0, rmu)
-          fauxo = (1.47-acos(rmu))/.15
-          alb = 0.03 + 0.630/(1.+fauxo*fauxo)
-          srmu = rmu
-          salb = alb*rmu
-
-          ! Faire l'integration numerique de midi a minuit (le facteur 2
-          ! prend en compte l'autre moitie de la journee):
-          DO k = 1, npts
-             rmu = aa + bb*cos(real(k)/real(npts)*zpi)
-             rmu = max(0.0, rmu)
-             fauxo = (1.47-acos(rmu))/.15
-             alb = 0.03 + 0.630/(1.+fauxo*fauxo)
-             srmu = srmu + rmu*2.0
-             salb = salb + alb*rmu*2.0
-          END DO
-          IF (srmu/=0.0) THEN
-             albedo(i) = salb/srmu
-          ELSE ! nuit polaire (on peut prendre une valeur quelconque)
-             albedo(i) = 1.0
-          END IF
-       END DO
-
-       ! nouvel albedo
-
-    ELSE
-
-       zpi = 4.*atan(1.)
-
-       ! Calculer la longitude vraie de l'orbite terrestre:
-       CALL orbite(rjour, zlonsun, zdist)
-
-       ! Calculer la declinaison du soleil (qui varie entre + et - R_incl):
-       zdeclin = asin(sin(zlonsun*zpi/180.0)*sin(r_incl*zpi/180.0))
-
-       DO i = 1, klon
-          aa = sin(rlat(i)*zpi/180.0)*sin(zdeclin)
-          bb = cos(rlat(i)*zpi/180.0)*cos(zdeclin)
-
-          ! Midi local (angle du temps = 0.0):
-          rmu = aa + bb*cos(0.0)
-          rmu = max(0.0, rmu)
-          ! IM cf. PB  alb = 0.058/(rmu + 0.30)
-          ! alb = 0.058/(rmu + 0.30) * 1.5
-          alb = 0.058/(rmu+0.30)*1.2
-          ! alb = 0.058/(rmu + 0.30) * 1.3
-          srmu = rmu
-          salb = alb*rmu
-
-          ! Faire l'integration numerique de midi a minuit (le facteur 2
-          ! prend en compte l'autre moitie de la journee):
-          DO k = 1, npts
-             rmu = aa + bb*cos(real(k)/real(npts)*zpi)
-             rmu = max(0.0, rmu)
-             ! IM cf. PB      alb = 0.058/(rmu + 0.30)
-             ! alb = 0.058/(rmu + 0.30) * 1.5
-             alb = 0.058/(rmu+0.30)*1.2
-             ! alb = 0.058/(rmu + 0.30) * 1.3
-             srmu = srmu + rmu*2.0
-             salb = salb + alb*rmu*2.0
-          END DO
-          IF (srmu/=0.0) THEN
-             albedo(i) = salb/srmu
-          ELSE ! nuit polaire (on peut prendre une valeur quelconque)
-             albedo(i) = 1.0
-          END IF
-       END DO
-    END IF
-    RETURN
-  END SUBROUTINE alboc
-  ! =====================================================================
-  SUBROUTINE alboc_cd(rmu0, albedo)
-    USE dimphy
-
-    ! Auteur(s): Z.X. Li (LMD/CNRS)
-    ! date: 19940624
-    ! Calculer l'albedo sur l'ocean en fonction de l'angle zenithal moyen
-    ! Formule due a Larson and Barkstrom (1977) Proc. of the symposium
-    ! on radiation in the atmosphere, 19-28 August 1976, science Press,
-    ! 1977 pp 451-453, ou These de 3eme cycle de Sylvie Joussaume.
-
-    ! Arguments
-    ! rmu0    (in): cosinus de l'angle solaire zenithal
-    ! albedo (out): albedo de surface de l'ocean
-    ! ======================================================================
-    include "clesphys.h"
-    REAL, intent(in):: rmu0(klon)
-    real, intent(out):: albedo(klon)
-
-    REAL fauxo
-    INTEGER i
-    LOGICAL ancien_albedo
-    PARAMETER (ancien_albedo=.FALSE.)
-
-    IF (ancien_albedo) THEN
-       DO i = 1, klon
-          fauxo = (1.47-acos(max(rmu0(i), 0.0)))/0.15
-          albedo(i) = 0.03+.630/(1.+fauxo*fauxo)
-          albedo(i) = max(min(albedo(i),0.60), 0.04)
-       END DO
-    ELSE
-       DO i = 1, klon
-          albedo(i) = 0.058/(max(rmu0(i), 0.0)+0.30)
-          albedo(i) = max(min(albedo(i),0.60), 0.04)
-       END DO
-    END IF
-
-  END SUBROUTINE alboc_cd
-
-end module albedo
Index: /LMDZ6/trunk/libf/phylmd/albedo.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/albedo.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/albedo.f90	(revision 5268)
@@ -0,0 +1,161 @@
+! $Id$
+module albedo
+
+  IMPLICIT NONE
+
+contains
+
+  SUBROUTINE alboc(rjour, rlat, albedo)
+    USE dimphy
+    ! ======================================================================
+    ! Auteur(s): Z.X. Li (LMD/CNRS) (adaptation du GCM du LMD)
+    ! Date: le 16 mars 1995
+    ! Objet: Calculer l'albedo sur l'ocean
+    ! Methode: Integrer numeriquement l'albedo pendant une journee
+
+    ! Arguments;
+    ! rjour (in,R)  : jour dans l'annee (a compter du 1 janvier)
+    ! rlat (in,R)   : latitude en degre
+    ! albedo (out,R): albedo obtenu (de 0 a 1)
+    ! ======================================================================
+    include "YOMCST.h"
+    include "clesphys.h"
+
+    INTEGER npts ! il controle la precision de l'integration
+    PARAMETER (npts=120) ! 120 correspond a l'interval 6 minutes
+
+    REAL rlat(klon), rjour, albedo(klon)
+    REAL zdist, zlonsun, zpi, zdeclin
+    REAL rmu, alb, srmu, salb, fauxo, aa, bb
+    INTEGER i, k
+    ! ccIM
+    LOGICAL ancien_albedo
+    PARAMETER (ancien_albedo=.FALSE.)
+    ! SAVE albedo
+
+    IF (ancien_albedo) THEN
+
+       zpi = 4.*atan(1.)
+
+       ! Calculer la longitude vraie de l'orbite terrestre:
+       CALL orbite(rjour, zlonsun, zdist)
+
+       ! Calculer la declinaison du soleil (qui varie entre + et - R_incl):
+       zdeclin = asin(sin(zlonsun*zpi/180.0)*sin(r_incl*zpi/180.0))
+
+       DO i = 1, klon
+          aa = sin(rlat(i)*zpi/180.0)*sin(zdeclin)
+          bb = cos(rlat(i)*zpi/180.0)*cos(zdeclin)
+
+          ! Midi local (angle du temps = 0.0):
+          rmu = aa + bb*cos(0.0)
+          rmu = max(0.0, rmu)
+          fauxo = (1.47-acos(rmu))/.15
+          alb = 0.03 + 0.630/(1.+fauxo*fauxo)
+          srmu = rmu
+          salb = alb*rmu
+
+          ! Faire l'integration numerique de midi a minuit (le facteur 2
+          ! prend en compte l'autre moitie de la journee):
+          DO k = 1, npts
+             rmu = aa + bb*cos(real(k)/real(npts)*zpi)
+             rmu = max(0.0, rmu)
+             fauxo = (1.47-acos(rmu))/.15
+             alb = 0.03 + 0.630/(1.+fauxo*fauxo)
+             srmu = srmu + rmu*2.0
+             salb = salb + alb*rmu*2.0
+          END DO
+          IF (srmu/=0.0) THEN
+             albedo(i) = salb/srmu
+          ELSE ! nuit polaire (on peut prendre une valeur quelconque)
+             albedo(i) = 1.0
+          END IF
+       END DO
+
+       ! nouvel albedo
+
+    ELSE
+
+       zpi = 4.*atan(1.)
+
+       ! Calculer la longitude vraie de l'orbite terrestre:
+       CALL orbite(rjour, zlonsun, zdist)
+
+       ! Calculer la declinaison du soleil (qui varie entre + et - R_incl):
+       zdeclin = asin(sin(zlonsun*zpi/180.0)*sin(r_incl*zpi/180.0))
+
+       DO i = 1, klon
+          aa = sin(rlat(i)*zpi/180.0)*sin(zdeclin)
+          bb = cos(rlat(i)*zpi/180.0)*cos(zdeclin)
+
+          ! Midi local (angle du temps = 0.0):
+          rmu = aa + bb*cos(0.0)
+          rmu = max(0.0, rmu)
+          ! IM cf. PB  alb = 0.058/(rmu + 0.30)
+          ! alb = 0.058/(rmu + 0.30) * 1.5
+          alb = 0.058/(rmu+0.30)*1.2
+          ! alb = 0.058/(rmu + 0.30) * 1.3
+          srmu = rmu
+          salb = alb*rmu
+
+          ! Faire l'integration numerique de midi a minuit (le facteur 2
+          ! prend en compte l'autre moitie de la journee):
+          DO k = 1, npts
+             rmu = aa + bb*cos(real(k)/real(npts)*zpi)
+             rmu = max(0.0, rmu)
+             ! IM cf. PB      alb = 0.058/(rmu + 0.30)
+             ! alb = 0.058/(rmu + 0.30) * 1.5
+             alb = 0.058/(rmu+0.30)*1.2
+             ! alb = 0.058/(rmu + 0.30) * 1.3
+             srmu = srmu + rmu*2.0
+             salb = salb + alb*rmu*2.0
+          END DO
+          IF (srmu/=0.0) THEN
+             albedo(i) = salb/srmu
+          ELSE ! nuit polaire (on peut prendre une valeur quelconque)
+             albedo(i) = 1.0
+          END IF
+       END DO
+    END IF
+    RETURN
+  END SUBROUTINE alboc
+  ! =====================================================================
+  SUBROUTINE alboc_cd(rmu0, albedo)
+    USE dimphy
+
+    ! Auteur(s): Z.X. Li (LMD/CNRS)
+    ! date: 19940624
+    ! Calculer l'albedo sur l'ocean en fonction de l'angle zenithal moyen
+    ! Formule due a Larson and Barkstrom (1977) Proc. of the symposium
+    ! on radiation in the atmosphere, 19-28 August 1976, science Press,
+    ! 1977 pp 451-453, ou These de 3eme cycle de Sylvie Joussaume.
+
+    ! Arguments
+    ! rmu0    (in): cosinus de l'angle solaire zenithal
+    ! albedo (out): albedo de surface de l'ocean
+    ! ======================================================================
+    include "clesphys.h"
+    REAL, intent(in):: rmu0(klon)
+    real, intent(out):: albedo(klon)
+
+    REAL fauxo
+    INTEGER i
+    LOGICAL ancien_albedo
+    PARAMETER (ancien_albedo=.FALSE.)
+
+    IF (ancien_albedo) THEN
+       DO i = 1, klon
+          fauxo = (1.47-acos(max(rmu0(i), 0.0)))/0.15
+          albedo(i) = 0.03+.630/(1.+fauxo*fauxo)
+          albedo(i) = max(min(albedo(i),0.60), 0.04)
+       END DO
+    ELSE
+       DO i = 1, klon
+          albedo(i) = 0.058/(max(rmu0(i), 0.0)+0.30)
+          albedo(i) = max(min(albedo(i),0.60), 0.04)
+       END DO
+    END IF
+
+  END SUBROUTINE alboc_cd
+
+end module albedo
Index: DZ6/trunk/libf/phylmd/albsno.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/albsno.F90	(revision 5267)
+++ 	(revision )
@@ -1,62 +1,0 @@
-!
-! $Header$
-!
-SUBROUTINE albsno(klon, knon, dtime, agesno, alb_neig_grid, precip_snow)
-
-  IMPLICIT NONE
-
-  INCLUDE "clesphys.h"
-
-! Input arguments
-!****************************************************************************************
-  INTEGER, INTENT(IN)                  :: klon, knon
-  REAL, INTENT(IN)                     :: dtime
-  REAL, DIMENSION(klon), INTENT(IN)    :: precip_snow
-
-! In/Output arguments
-!****************************************************************************************
-  REAL, DIMENSION(klon), INTENT(INOUT) :: agesno
-
-! Output arguments
-!****************************************************************************************
-  REAL, DIMENSION(klon), INTENT(OUT)   :: alb_neig_grid
-
-! Local variables
-!****************************************************************************************
-  INTEGER                              :: i, nv
-  INTEGER, PARAMETER                   :: nvm = 8 
-  REAL                                 :: as
-  REAL, DIMENSION(klon,nvm)            :: veget
-  REAL, DIMENSION(nvm),SAVE            :: init, decay
-  !$OMP THREADPRIVATE(init, decay)
-
-  DATA init /0.55, 0.14, 0.18, 0.29, 0.15, 0.15, 0.14, 0./
-  DATA decay/0.30, 0.67, 0.63, 0.45, 0.40, 0.14, 0.06, 1./
-!****************************************************************************************
-
-  if (albsno0>=0.) then
-     init(:)=albsno0
-     decay(:)=0.
-  endif
-
-  veget = 0.
-  veget(:,1) = 1.     ! desert partout
-  DO i = 1, knon
-     alb_neig_grid(i) = 0.0
-  ENDDO
-  DO nv = 1, nvm
-     DO i = 1, knon
-        as = init(nv)+decay(nv)*EXP(-agesno(i)/5.)
-        alb_neig_grid(i) = alb_neig_grid(i) + veget(i,nv)*as
-     ENDDO
-  ENDDO
-  
-
-! modilation en fonction de l'age de la neige
-  DO i = 1, knon
-     agesno(i)  = (agesno(i) + (1.-agesno(i)/50.)*dtime/86400.)&
-          &             * EXP(-1.*MAX(0.0,precip_snow(i))*dtime/0.3)
-     agesno(i) =  MAX(agesno(i),0.0)
-  ENDDO
-  
-END SUBROUTINE albsno
Index: /LMDZ6/trunk/libf/phylmd/albsno.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/albsno.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/albsno.f90	(revision 5268)
@@ -0,0 +1,62 @@
+!
+! $Header$
+!
+SUBROUTINE albsno(klon, knon, dtime, agesno, alb_neig_grid, precip_snow)
+
+  IMPLICIT NONE
+
+  INCLUDE "clesphys.h"
+
+! Input arguments
+!****************************************************************************************
+  INTEGER, INTENT(IN)                  :: klon, knon
+  REAL, INTENT(IN)                     :: dtime
+  REAL, DIMENSION(klon), INTENT(IN)    :: precip_snow
+
+! In/Output arguments
+!****************************************************************************************
+  REAL, DIMENSION(klon), INTENT(INOUT) :: agesno
+
+! Output arguments
+!****************************************************************************************
+  REAL, DIMENSION(klon), INTENT(OUT)   :: alb_neig_grid
+
+! Local variables
+!****************************************************************************************
+  INTEGER                              :: i, nv
+  INTEGER, PARAMETER                   :: nvm = 8 
+  REAL                                 :: as
+  REAL, DIMENSION(klon,nvm)            :: veget
+  REAL, DIMENSION(nvm),SAVE            :: init, decay
+  !$OMP THREADPRIVATE(init, decay)
+
+  DATA init /0.55, 0.14, 0.18, 0.29, 0.15, 0.15, 0.14, 0./
+  DATA decay/0.30, 0.67, 0.63, 0.45, 0.40, 0.14, 0.06, 1./
+!****************************************************************************************
+
+  if (albsno0>=0.) then
+     init(:)=albsno0
+     decay(:)=0.
+  endif
+
+  veget = 0.
+  veget(:,1) = 1.     ! desert partout
+  DO i = 1, knon
+     alb_neig_grid(i) = 0.0
+  ENDDO
+  DO nv = 1, nvm
+     DO i = 1, knon
+        as = init(nv)+decay(nv)*EXP(-agesno(i)/5.)
+        alb_neig_grid(i) = alb_neig_grid(i) + veget(i,nv)*as
+     ENDDO
+  ENDDO
+  
+
+! modilation en fonction de l'age de la neige
+  DO i = 1, knon
+     agesno(i)  = (agesno(i) + (1.-agesno(i)/50.)*dtime/86400.)&
+          &             * EXP(-1.*MAX(0.0,precip_snow(i))*dtime/0.3)
+     agesno(i) =  MAX(agesno(i),0.0)
+  ENDDO
+  
+END SUBROUTINE albsno
Index: DZ6/trunk/libf/phylmd/alpale.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/alpale.F90	(revision 5267)
+++ 	(revision )
@@ -1,197 +1,0 @@
-SUBROUTINE alpale ( debut, itap, dtime, paprs, omega, t_seri,   &
-                    alp_offset, it_wape_prescr,  wape_prescr, fip_prescr, &
-                    ale_bl_prescr, alp_bl_prescr, &
-                    wake_pe, wake_fip,  &
-                    Ale_bl, Ale_bl_trig, Alp_bl, &
-                    Ale, Alp, Ale_wake, Alp_wake )
-
-! **************************************************************
-! *
-! ALPALE                                                       *
-! *
-! *
-! written by   : Jean-Yves Grandpeix, 12/05/2016              *
-! modified by :                                               *
-! **************************************************************
-
-  USE dimphy
-  USE ioipsl_getin_p_mod, ONLY : getin_p
-  USE print_control_mod, ONLY: mydebug=>debug , lunout, prt_level
-  USE phys_local_var_mod, ONLY: zw2       ! Variables internes non sauvegardees de la physique
-!
-  IMPLICIT NONE
-
-!================================================================
-! Auteur(s)   : Jean-Yves Grandpeix, 12/05/2016
-! Objet : Sums up all contributions to Ale and Alp
-!================================================================
-
-! Input arguments
-!----------------
-  LOGICAL, INTENT(IN)                                        :: debut
-  INTEGER, INTENT(IN)                                        :: itap
-  REAL, INTENT(IN)                                           :: dtime
-  INTEGER, INTENT(IN)                                        :: it_wape_prescr
-  REAL, INTENT(IN)                                           :: wape_prescr, fip_prescr
-  REAL, INTENT(IN)                                           :: Ale_bl_prescr, Alp_bl_prescr
-  REAL, INTENT(IN)                                           :: alp_offset
-  REAL, DIMENSION(klon,klev+1), INTENT(IN)                   :: paprs
-  REAL, DIMENSION(klon,klev), INTENT(IN)                     :: t_seri
-  REAL, DIMENSION(klon,klev), INTENT(IN)                     :: omega
-  REAL, DIMENSION(klon), INTENT(IN)                          :: wake_pe, wake_fip
-  REAL, DIMENSION(klon), INTENT(IN)                          :: Ale_bl, Ale_bl_trig, Alp_bl
-
-
-! Output arguments
-!----------------
-  REAL, DIMENSION(klon), INTENT(OUT)                         :: Ale, Alp
-  REAL, DIMENSION(klon), INTENT(OUT)                         :: Ale_wake, Alp_wake
-
-  include "alpale.h"
-  include "YOMCST.h"
-  include "YOETHF.h"
-
-! Local variables
-!----------------
-  INTEGER                                                    :: i, k
-  REAL, DIMENSION(klon)                                      :: www
-  REAL, SAVE                                                 :: ale_max=1000.
-  REAL, SAVE                                                 :: alp_max=2.
-  CHARACTER*20 modname
-  CHARACTER*80 abort_message
-
-
-    !$OMP THREADPRIVATE(ale_max,alp_max)
-
-       ! Calcul de l'energie disponible ALE (J/kg) et de la puissance
-       ! disponible ALP (W/m2) pour le soulevement des particules dans
-       ! le modele convectif
-       !
-       do i = 1,klon
-          ALE(i) = 0.
-          ALP(i) = 0.
-       enddo
-       !
-       !calcul de ale_wake et alp_wake
-       if (iflag_wake>=1) then
-          if (itap .le. it_wape_prescr) then
-             do i = 1,klon
-                ale_wake(i) = wape_prescr
-                alp_wake(i) = fip_prescr
-             enddo
-          else
-             do i = 1,klon
-                !jyg  ALE=WAPE au lieu de ALE = 1/2 Cstar**2
-                !cc           ale_wake(i) = 0.5*wake_cstar(i)**2
-                ale_wake(i) = wake_pe(i)
-                alp_wake(i) = wake_fip(i)
-             enddo
-          endif
-       else
-          do i = 1,klon
-             ale_wake(i) = 0.
-             alp_wake(i) = 0.
-          enddo
-       endif
-       !combinaison avec ale et alp de couche limite: constantes si pas
-       !de couplage, valeurs calculees dans le thermique sinon
-       if (iflag_coupl.eq.0) then
-          if (debut.and.prt_level.gt.9) &
-               WRITE(lunout,*)'ALE et ALP imposes'
-          do i = 1,klon
-             !on ne couple que ale
-             !           ALE(i) = max(ale_wake(i),Ale_bl(i))
-             ALE(i) = max(ale_wake(i),ale_bl_prescr)
-             !on ne couple que alp
-             !           ALP(i) = alp_wake(i) + Alp_bl(i)
-             ALP(i) = alp_wake(i) + alp_bl_prescr
-          enddo
-       else
-          IF(prt_level>9)WRITE(lunout,*)'ALE et ALP couples au thermique'
-          !         do i = 1,klon
-          !             ALE(i) = max(ale_wake(i),Ale_bl(i))
-          ! avant        ALP(i) = alp_wake(i) + Alp_bl(i)
-          !             ALP(i) = alp_wake(i) + Alp_bl(i) + alp_offset ! modif sb
-          !         write(20,*)'ALE',ALE(i),Ale_bl(i),ale_wake(i)
-          !         write(21,*)'ALP',ALP(i),Alp_bl(i),alp_wake(i)
-          !         enddo
-
-          ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-          ! Modif FH 2010/04/27. Sans doute temporaire.
-          ! Deux options pour le alp_offset : constant si >?? 0 ou
-          ! proportionnel ??a w si <0
-          ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-          ! Estimation d'une vitesse verticale effective pour ALP
-          if (1==0) THEN
-             www(1:klon)=0.
-             do k=2,klev-1
-                do i=1,klon
-                   www(i)=max(www(i),-omega(i,k)*RD*t_seri(i,k) &
-                        /(RG*paprs(i,k)) *zw2(i,k)*zw2(i,k))
-                   ! if (paprs(i,k)>pbase(i)) then
-                   ! calcul approche de la vitesse verticale en m/s
-                   !  www(i)=max(www(i),-omega(i,k)*RD*temp(i,k)/(RG*paprs(i,k))
-                   !             endif
-                   !   Le 0.1 est en gros H / ps = 1e4 / 1e5
-                enddo
-             enddo
-             do i=1,klon
-                if (www(i)>0. .and. ale_bl(i)>0. ) www(i)=www(i)/ale_bl(i)
-             enddo
-          ENDIF
-
-
-          do i = 1,klon
-             ALE(i) = max(ale_wake(i),Ale_bl(i))
-             !cc nrlmd le 10/04/2012----------Stochastic triggering------------
-             if (iflag_trig_bl.ge.1) then
-                ALE(i) = max(ale_wake(i),Ale_bl_trig(i))
-             endif
-             !cc fin nrlmd le 10/04/2012
-             if (alp_offset>=0.) then
-                ALP(i) = alp_wake(i) + Alp_bl(i) + alp_offset ! modif sb
-             else
-                abort_message ='Ne pas passer la car www non calcule'
-                CALL abort_physic (modname,abort_message,1)
-
-                ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-                !                                _                  _
-                ! Ajout d'une composante 3 * A * w w'2 a w'3 avec
-                ! w=www : w max sous pbase ou A est la fraction
-                ! couverte par les ascendances w' on utilise le fait
-                ! que A * w'3 = ALP et donc A * w'2 ~ ALP / sqrt(ALE)
-                ! (on ajoute 0.1 pour les singularites)
-                ALP(i)=alp_wake(i)*(1.+3.*www(i)/( sqrt(ale_wake(i))+0.1) ) &
-                     +alp_bl(i)  *(1.+3.*www(i)/( sqrt(ale_bl(i))  +0.1) )
-                !    ALP(i)=alp_wake(i)+Alp_bl(i)+alp_offset*min(omega(i,6),0.)
-                !             if (alp(i)<0.) then
-                !                print*,'ALP ',alp(i),alp_wake(i) &
-                !                     ,Alp_bl(i),alp_offset*min(omega(i,6),0.)
-                !             endif
-             endif
-          enddo
-          ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-       endif
-       do i=1,klon
-          if (alp(i)>alp_max) then
-             IF(prt_level>9)WRITE(lunout,*)                             &
-                  'WARNING SUPER ALP (seuil=',alp_max, &
-                  '): i, alp, alp_wake,ale',i,alp(i),alp_wake(i),ale(i)
-             alp(i)=alp_max
-          endif
-          if (ale(i)>ale_max) then
-             IF(prt_level>9)WRITE(lunout,*)                             &
-                  'WARNING SUPER ALE (seuil=',ale_max, &
-                  '): i, alp, alp_wake,ale',i,ale(i),ale_wake(i),alp(i)
-             ale(i)=ale_max
-          endif
-       enddo
-
-       !fin calcul ale et alp
-       !=======================================================================
-
-
-  RETURN
-  END
-
Index: /LMDZ6/trunk/libf/phylmd/alpale.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/alpale.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/alpale.f90	(revision 5268)
@@ -0,0 +1,197 @@
+SUBROUTINE alpale ( debut, itap, dtime, paprs, omega, t_seri,   &
+                    alp_offset, it_wape_prescr,  wape_prescr, fip_prescr, &
+                    ale_bl_prescr, alp_bl_prescr, &
+                    wake_pe, wake_fip,  &
+                    Ale_bl, Ale_bl_trig, Alp_bl, &
+                    Ale, Alp, Ale_wake, Alp_wake )
+
+! **************************************************************
+! *
+! ALPALE                                                       *
+! *
+! *
+! written by   : Jean-Yves Grandpeix, 12/05/2016              *
+! modified by :                                               *
+! **************************************************************
+
+  USE dimphy
+  USE ioipsl_getin_p_mod, ONLY : getin_p
+  USE print_control_mod, ONLY: mydebug=>debug , lunout, prt_level
+  USE phys_local_var_mod, ONLY: zw2       ! Variables internes non sauvegardees de la physique
+!
+  IMPLICIT NONE
+
+!================================================================
+! Auteur(s)   : Jean-Yves Grandpeix, 12/05/2016
+! Objet : Sums up all contributions to Ale and Alp
+!================================================================
+
+! Input arguments
+!----------------
+  LOGICAL, INTENT(IN)                                        :: debut
+  INTEGER, INTENT(IN)                                        :: itap
+  REAL, INTENT(IN)                                           :: dtime
+  INTEGER, INTENT(IN)                                        :: it_wape_prescr
+  REAL, INTENT(IN)                                           :: wape_prescr, fip_prescr
+  REAL, INTENT(IN)                                           :: Ale_bl_prescr, Alp_bl_prescr
+  REAL, INTENT(IN)                                           :: alp_offset
+  REAL, DIMENSION(klon,klev+1), INTENT(IN)                   :: paprs
+  REAL, DIMENSION(klon,klev), INTENT(IN)                     :: t_seri
+  REAL, DIMENSION(klon,klev), INTENT(IN)                     :: omega
+  REAL, DIMENSION(klon), INTENT(IN)                          :: wake_pe, wake_fip
+  REAL, DIMENSION(klon), INTENT(IN)                          :: Ale_bl, Ale_bl_trig, Alp_bl
+
+
+! Output arguments
+!----------------
+  REAL, DIMENSION(klon), INTENT(OUT)                         :: Ale, Alp
+  REAL, DIMENSION(klon), INTENT(OUT)                         :: Ale_wake, Alp_wake
+
+  include "alpale.h"
+  include "YOMCST.h"
+  include "YOETHF.h"
+
+! Local variables
+!----------------
+  INTEGER                                                    :: i, k
+  REAL, DIMENSION(klon)                                      :: www
+  REAL, SAVE                                                 :: ale_max=1000.
+  REAL, SAVE                                                 :: alp_max=2.
+  CHARACTER*20 modname
+  CHARACTER*80 abort_message
+
+
+    !$OMP THREADPRIVATE(ale_max,alp_max)
+
+       ! Calcul de l'energie disponible ALE (J/kg) et de la puissance
+       ! disponible ALP (W/m2) pour le soulevement des particules dans
+       ! le modele convectif
+       !
+       do i = 1,klon
+          ALE(i) = 0.
+          ALP(i) = 0.
+       enddo
+       !
+       !calcul de ale_wake et alp_wake
+       if (iflag_wake>=1) then
+          if (itap .le. it_wape_prescr) then
+             do i = 1,klon
+                ale_wake(i) = wape_prescr
+                alp_wake(i) = fip_prescr
+             enddo
+          else
+             do i = 1,klon
+                !jyg  ALE=WAPE au lieu de ALE = 1/2 Cstar**2
+                !cc           ale_wake(i) = 0.5*wake_cstar(i)**2
+                ale_wake(i) = wake_pe(i)
+                alp_wake(i) = wake_fip(i)
+             enddo
+          endif
+       else
+          do i = 1,klon
+             ale_wake(i) = 0.
+             alp_wake(i) = 0.
+          enddo
+       endif
+       !combinaison avec ale et alp de couche limite: constantes si pas
+       !de couplage, valeurs calculees dans le thermique sinon
+       if (iflag_coupl.eq.0) then
+          if (debut.and.prt_level.gt.9) &
+               WRITE(lunout,*)'ALE et ALP imposes'
+          do i = 1,klon
+             !on ne couple que ale
+             !           ALE(i) = max(ale_wake(i),Ale_bl(i))
+             ALE(i) = max(ale_wake(i),ale_bl_prescr)
+             !on ne couple que alp
+             !           ALP(i) = alp_wake(i) + Alp_bl(i)
+             ALP(i) = alp_wake(i) + alp_bl_prescr
+          enddo
+       else
+          IF(prt_level>9)WRITE(lunout,*)'ALE et ALP couples au thermique'
+          !         do i = 1,klon
+          !             ALE(i) = max(ale_wake(i),Ale_bl(i))
+          ! avant        ALP(i) = alp_wake(i) + Alp_bl(i)
+          !             ALP(i) = alp_wake(i) + Alp_bl(i) + alp_offset ! modif sb
+          !         write(20,*)'ALE',ALE(i),Ale_bl(i),ale_wake(i)
+          !         write(21,*)'ALP',ALP(i),Alp_bl(i),alp_wake(i)
+          !         enddo
+
+          ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+          ! Modif FH 2010/04/27. Sans doute temporaire.
+          ! Deux options pour le alp_offset : constant si >?? 0 ou
+          ! proportionnel ??a w si <0
+          ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+          ! Estimation d'une vitesse verticale effective pour ALP
+          if (1==0) THEN
+             www(1:klon)=0.
+             do k=2,klev-1
+                do i=1,klon
+                   www(i)=max(www(i),-omega(i,k)*RD*t_seri(i,k) &
+                        /(RG*paprs(i,k)) *zw2(i,k)*zw2(i,k))
+                   ! if (paprs(i,k)>pbase(i)) then
+                   ! calcul approche de la vitesse verticale en m/s
+                   !  www(i)=max(www(i),-omega(i,k)*RD*temp(i,k)/(RG*paprs(i,k))
+                   !             endif
+                   !   Le 0.1 est en gros H / ps = 1e4 / 1e5
+                enddo
+             enddo
+             do i=1,klon
+                if (www(i)>0. .and. ale_bl(i)>0. ) www(i)=www(i)/ale_bl(i)
+             enddo
+          ENDIF
+
+
+          do i = 1,klon
+             ALE(i) = max(ale_wake(i),Ale_bl(i))
+             !cc nrlmd le 10/04/2012----------Stochastic triggering------------
+             if (iflag_trig_bl.ge.1) then
+                ALE(i) = max(ale_wake(i),Ale_bl_trig(i))
+             endif
+             !cc fin nrlmd le 10/04/2012
+             if (alp_offset>=0.) then
+                ALP(i) = alp_wake(i) + Alp_bl(i) + alp_offset ! modif sb
+             else
+                abort_message ='Ne pas passer la car www non calcule'
+                CALL abort_physic (modname,abort_message,1)
+
+                ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+                !                                _                  _
+                ! Ajout d'une composante 3 * A * w w'2 a w'3 avec
+                ! w=www : w max sous pbase ou A est la fraction
+                ! couverte par les ascendances w' on utilise le fait
+                ! que A * w'3 = ALP et donc A * w'2 ~ ALP / sqrt(ALE)
+                ! (on ajoute 0.1 pour les singularites)
+                ALP(i)=alp_wake(i)*(1.+3.*www(i)/( sqrt(ale_wake(i))+0.1) ) &
+                     +alp_bl(i)  *(1.+3.*www(i)/( sqrt(ale_bl(i))  +0.1) )
+                !    ALP(i)=alp_wake(i)+Alp_bl(i)+alp_offset*min(omega(i,6),0.)
+                !             if (alp(i)<0.) then
+                !                print*,'ALP ',alp(i),alp_wake(i) &
+                !                     ,Alp_bl(i),alp_offset*min(omega(i,6),0.)
+                !             endif
+             endif
+          enddo
+          ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+       endif
+       do i=1,klon
+          if (alp(i)>alp_max) then
+             IF(prt_level>9)WRITE(lunout,*)                             &
+                  'WARNING SUPER ALP (seuil=',alp_max, &
+                  '): i, alp, alp_wake,ale',i,alp(i),alp_wake(i),ale(i)
+             alp(i)=alp_max
+          endif
+          if (ale(i)>ale_max) then
+             IF(prt_level>9)WRITE(lunout,*)                             &
+                  'WARNING SUPER ALE (seuil=',ale_max, &
+                  '): i, alp, alp_wake,ale',i,ale(i),ale_wake(i),alp(i)
+             ale(i)=ale_max
+          endif
+       enddo
+
+       !fin calcul ale et alp
+       !=======================================================================
+
+
+  RETURN
+  END
+
Index: DZ6/trunk/libf/phylmd/alpale_th.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/alpale_th.F90	(revision 5267)
+++ 	(revision )
@@ -1,347 +1,0 @@
-!
-! $Id$
-!
-SUBROUTINE alpale_th ( dtime, lmax_th, t_seri, cell_area,  &
-                       cin, s2, n2, strig,  &
-                       ale_bl_trig, ale_bl_stat, ale_bl,  &
-                       alp_bl, alp_bl_stat, &
-                       proba_notrig, random_notrig, birth_rate)
-
-! **************************************************************
-! *
-! ALPALE_TH                                                    *
-! *
-! *
-! written by   : Jean-Yves Grandpeix, 11/05/2016              *
-! modified by :                                               *
-! **************************************************************
-
-  USE dimphy
-  USE ioipsl_getin_p_mod, ONLY : getin_p
-  USE print_control_mod, ONLY: mydebug=>debug , lunout, prt_level
-!
-  IMPLICIT NONE
-
-!================================================================
-! Auteur(s)   : Jean-Yves Grandpeix, 11/05/2016
-! Objet : Contribution of the thermal scheme to Ale and Alp
-!================================================================
-
-! Input arguments
-!----------------
-  REAL, INTENT(IN)                                           :: dtime
-  REAL, DIMENSION(klon), INTENT(IN)                          :: cell_area
-  INTEGER, DIMENSION(klon), INTENT(IN)                       :: lmax_th
-  REAL, DIMENSION(klon,klev), INTENT(IN)                     :: t_seri
-  REAL, DIMENSION(klon), INTENT(IN)                          :: ale_bl_stat
-  REAL, DIMENSION(klon), INTENT(IN)                          :: cin
-  REAL, DIMENSION(klon), INTENT(IN)                          :: s2, n2, strig
-                                                                
-  REAL, DIMENSION(klon), INTENT(INOUT)                       :: ale_bl_trig, ale_bl
-  REAL, DIMENSION(klon), INTENT(INOUT)                       :: alp_bl
-  REAL, DIMENSION(klon), INTENT(INOUT)                       :: alp_bl_stat
-  REAL, DIMENSION(klon), INTENT(INOUT)                       :: proba_notrig
-
-  REAL, DIMENSION(klon), INTENT(OUT)                         :: random_notrig
-
-  REAL, DIMENSION(klon), INTENT(OUT)                         :: birth_rate
-
-  include "alpale.h"
-
-! Local variables
-!----------------
-  INTEGER                                                    :: i
-  LOGICAL, SAVE                                              :: first = .TRUE.
-  LOGICAL, SAVE                                              :: multiply_proba_notrig = .FALSE.
-  REAL, SAVE                                                 :: random_notrig_max=1.
-  REAL, SAVE                                                 :: cv_feed_area
-  REAL                                                       :: birth_number
-  REAL, DIMENSION(klon)                                      :: ale_bl_ref
-  REAL, DIMENSION(klon)                                      :: tau_trig
-!
-    !$OMP THREADPRIVATE(multiply_proba_notrig) 
-    !$OMP THREADPRIVATE(random_notrig_max) 
-    !$OMP THREADPRIVATE(cv_feed_area) 
-    !$OMP THREADPRIVATE(first)
-!
- REAL umexp  ! expression of (1.-exp(-x))/x valid for all x, especially when x->0
- REAL x
-!
-     CHARACTER (LEN=20) :: modname='alpale_th'
-     CHARACTER (LEN=80) :: abort_message
-     
- umexp(x) = max(sign(1.,x-1.e-3),0.)*(1.-exp(-x))/max(x,1.e-3) + &
-            (1.-max(sign(1.,x-1.e-3),0.))*(1.-0.5*x*(1.-x/3.*(1.-0.25*x)))  !!! correct formula            (jyg)
-!!!            (1.-max(sign(1.,x-1.e-3),0.))*(-0.5*x*(1.-x/3.*(1.-0.25*x))) !!! bug introduced by mistake  (jyg)
-!!!            (1.-max(sign(1.,x-1.e-3),0.))*(1.-0.5*x*(1.-x/3.*(1.-0.25*x)))  !!! initial correct formula (jyg)
-!
-!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-!  JYG, 20160513 : Introduction of the Effective Lifting Power (ELP), which 
-! takes into account the area (cv_feed_area) covered by thermals contributing 
-! to each cumulonimbus.
-!   The use of ELP prevents singularities when the trigger probability tends to
-! zero. It is activated by iflag_clos_bl = 3.
-!   The ELP values are stored in the ALP_bl variable.
-!   
-!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-!
-
-    IF (first) THEN
-      CALL getin_p('multiply_proba_notrig',multiply_proba_notrig)
-      IF (iflag_clos_bl .LT. 3) THEN
-         random_notrig_max=1.
-         CALL getin_p('random_notrig_max',random_notrig_max)
-      ELSEIF (iflag_clos_bl .EQ. 3) THEN  ! (iflag_clos_bl .LT. 3)
-         cv_feed_area = 1.e10   ! m2
-         CALL getin_p('cv_feed_area', cv_feed_area)
-      ENDIF  !! (iflag_clos_bl .LT. 3)
-      first=.FALSE.
-    ENDIF
-
-!!
-!!   Control of the multiplication of no-trigger probabilities between calls 
-!! to the convection scheme. If multiply_proba_notrig is .false., then
-!! proba_notrig is set to 1 at each call to alpale_th, so that only the last call 
-!! plays a role in the triggering of convection. If it is .true., then propa_notrig 
-!! is saved between calls to convection and is reset to 1 only after calling the 
-!! convection scheme.
-!!    For instance, if the probability of no_trigger is 0.9 at each call, and if 
-!! there are 3 calls to alpale_th between calls to the convection scheme, then the 
-!! probability of triggering convection will be 0.1 (= 1.-0.9) if 
-!! multiply_proba_notrig is .false. and 0.271 (= 1.-0.9^3) if multiply_proba_notrig 
-!! is .true.
-!!
-    IF (.NOT.multiply_proba_notrig) THEN
-             DO i=1,klon
-                proba_notrig(i)=1.
-             ENDDO
-    ENDIF  !! (.NOT.multiply_proba_notrig)
-!!
-!!
-!---------------------------------------
-  IF (iflag_clos_bl .LT. 3) THEN
-!---------------------------------------
-!
-!      Original code (Nicolas Rochetin)
-!     --------------------------------
-          !cc nrlmd le 10/04/2012
-          !-----------Stochastic triggering-----------
-          if (iflag_trig_bl.ge.1) then
-             !
-             IF (prt_level .GE. 10) THEN
-                WRITE(lunout,*)'cin, ale_bl_stat, alp_bl, alp_bl_stat ', &
-                     cin, ale_bl_stat, alp_bl, alp_bl_stat
-             ENDIF
-
-
-             !----Initialisations
-             do i=1,klon
-!!jyg                proba_notrig(i)=1.
-                random_notrig(i)=1e6*ale_bl_stat(i)-int(1e6*ale_bl_stat(i))
-                if ( random_notrig(i) > random_notrig_max ) random_notrig(i)=0.
-                if ( ale_bl_trig(i) .lt. abs(cin(i))+1.e-10 ) then 
-                   tau_trig(i)=tau_trig_shallow
-                else
-                   tau_trig(i)=tau_trig_deep
-                endif
-             enddo
-             !
-             IF (prt_level .GE. 10) THEN
-                WRITE(lunout,*)'random_notrig, tau_trig ', &
-                     random_notrig, tau_trig
-                WRITE(lunout,*)'s_trig,s2,n2 ', &
-                     s_trig,s2,n2
-             ENDIF
-
-             !Option pour re-activer l'ancien calcul de Ale_bl (iflag_trig_bl=2)
-             IF (iflag_trig_bl.eq.1) then
-
-                !----Tirage al\'eatoire et calcul de ale_bl_trig
-                do i=1,klon
-                   if ( (ale_bl_stat(i) .gt. abs(cin(i))+1.e-10) )  then
-                      proba_notrig(i)=proba_notrig(i)* &
-                         (1.-exp(-strig(i)/s2(i)))**(n2(i)*dtime/tau_trig(i))
-                      !        print *, 'proba_notrig(i) ',proba_notrig(i)
-                      if (random_notrig(i) .ge. proba_notrig(i)) then 
-                         ale_bl_trig(i)=ale_bl_stat(i)
-                      else
-                         ale_bl_trig(i)=0.
-                      endif
-                      birth_rate(i) = n2(i)*exp(-strig(i)/s2(i))/(tau_trig(i)*cell_area(i))
-!!!                      birth_rate(i) = max(birth_rate(i),1.e-18)
-                   else
-!!jyg                      proba_notrig(i)=1.
-                      birth_rate(i) = 0.
-                      random_notrig(i)=0.
-                      ale_bl_trig(i)=0.
-                   endif
-                enddo
-
-             ELSE IF (iflag_trig_bl.ge.2) then
-
-                do i=1,klon
-                   if ( (Ale_bl(i) .gt. abs(cin(i))+1.e-10) )  then
-                      proba_notrig(i)=proba_notrig(i)* &
-                         (1.-exp(-strig(i)/s2(i)))**(n2(i)*dtime/tau_trig(i))
-                      !        print *, 'proba_notrig(i) ',proba_notrig(i)
-                      if (random_notrig(i) .ge. proba_notrig(i)) then 
-                         ale_bl_trig(i)=Ale_bl(i)
-                      else
-                         ale_bl_trig(i)=0.
-                      endif
-                      birth_rate(i) = n2(i)*exp(-strig(i)/s2(i))/(tau_trig(i)*cell_area(i))
-!!!                      birth_rate(i) = max(birth_rate(i),1.e-18)
-                   else
-!!jyg                      proba_notrig(i)=1.
-                      birth_rate(i) = 0.
-                      random_notrig(i)=0.
-                      ale_bl_trig(i)=0.
-                   endif
-                enddo
-
-             ENDIF
-
-             !
-             IF (prt_level .GE. 10) THEN
-                WRITE(lunout,*)'proba_notrig, ale_bl_trig ', &
-                     proba_notrig, ale_bl_trig
-             ENDIF
-
-          endif !(iflag_trig_bl)
-
-          !-----------Statistical closure-----------
-          if (iflag_clos_bl.eq.1) then 
-
-             do i=1,klon
-                !CR: alp probabiliste
-                if (ale_bl_trig(i).gt.0.) then
-                   alp_bl(i)=alp_bl(i)/(1.-min(proba_notrig(i),0.999))
-                endif
-             enddo
-
-          else if (iflag_clos_bl.eq.2) then
-
-             !CR: alp calculee dans thermcell_main
-             do i=1,klon
-                alp_bl(i)=alp_bl_stat(i)
-             enddo
-
-          else
-
-             alp_bl_stat(:)=0.
-
-          endif !(iflag_clos_bl)
-
-!
-!---------------------------------------
-  ELSEIF (iflag_clos_bl .EQ. 3) THEN  ! (iflag_clos_bl .LT. 3)
-!---------------------------------------
-!
-!      New code with Effective Lifting Power
-!     -------------------------------------
-
-          !-----------Stochastic triggering-----------
-     if (iflag_trig_bl.ge.1) then
-        !
-        IF (prt_level .GE. 10) THEN
-           WRITE(lunout,*)'cin, ale_bl_stat, alp_bl_stat ', &
-                cin, ale_bl_stat, alp_bl_stat
-        ENDIF
-
-        ! Use ale_bl_stat (Rochetin's code) or ale_bl (old code) according to 
-        ! iflag_trig_bl value.
-        IF (iflag_trig_bl.eq.1) then         ! use ale_bl_stat (Rochetin computation)
-         do i=1,klon
-              ale_bl_ref(i)=ale_bl_stat(i)
-         enddo
-        ELSE IF (iflag_trig_bl.ge.2) then    ! use ale_bl (old computation)
-         do i=1,klon
-              ale_bl_ref(i)=Ale_bl(i)
-         enddo
-        ENDIF ! (iflag_trig_bl.eq.1)
-
-
-        !----Initializations and random number generation
-        do i=1,klon
-!!jyg           proba_notrig(i)=1.
-           random_notrig(i)=1e6*ale_bl_stat(i)-int(1e6*ale_bl_stat(i))
-           if ( ale_bl_trig(i) .lt. abs(cin(i))+1.e-10 ) then 
-              tau_trig(i)=tau_trig_shallow
-           else
-              tau_trig(i)=tau_trig_deep
-           endif
-        enddo
-        !
-        IF (prt_level .GE. 10) THEN
-           WRITE(lunout,*)'random_notrig, tau_trig ', &
-                random_notrig, tau_trig
-           WRITE(lunout,*)'s_trig,s2,n2 ', &
-                s_trig,s2,n2
-        ENDIF
-
-        !----alp_bl computation
-        do i=1,klon
-           if ( (ale_bl_ref(i) .gt. abs(cin(i))+1.e-10) )  then
-              birth_number = n2(i)*exp(-strig(i)/s2(i))
-              birth_rate(i) = birth_number/(tau_trig(i)*cell_area(i))
-!!!              birth_rate(i) = max(birth_rate(i),1.e-18)
-              proba_notrig(i)=proba_notrig(i)*exp(-birth_number*dtime/tau_trig(i))
-              Alp_bl(i) = Alp_bl(i)* &
-                          umexp(-birth_number*cv_feed_area/cell_area(i))/ &
-                          umexp(-birth_number*dtime/tau_trig(i))*  &
-                          tau_trig(i)*cv_feed_area/(dtime*cell_area(i))
-          else 
-!!jyg              proba_notrig(i)=1.
-              birth_rate(i)=0.
-              random_notrig(i)=0.
-              alp_bl(i)=0.
-           endif
-        enddo
-
-        !----ale_bl_trig computation
-         do i=1,klon
-           if (random_notrig(i) .ge. proba_notrig(i)) then 
-              ale_bl_trig(i)=ale_bl_ref(i)
-           else
-              ale_bl_trig(i)=0.
-           endif
-         enddo
-
-        !
-        IF (prt_level .GE. 10) THEN
-           WRITE(lunout,*)'proba_notrig, ale_bl_trig ', &
-                proba_notrig, ale_bl_trig
-        ENDIF
-
-     endif !(iflag_trig_bl .ge. 1)
-
-!---------------------------------------
-  ENDIF ! (iflag_clos_bl .LT. 3)
-!---------------------------------------
-
-          IF (prt_level .GE. 10) THEN
-             WRITE(lunout,*)'alpale_th: ale_bl_trig, alp_bl_stat, birth_rate ', &
-                      ale_bl_trig(1), alp_bl_stat(1), birth_rate(1)
-          ENDIF
-
-          !cc fin nrlmd le 10/04/2012
-!
-          !IM/FH: 2011/02/23 
-          ! Couplage Thermiques/Emanuel seulement si T<0
-          if (iflag_coupl==2) then
-             IF (prt_level .GE. 10) THEN
-                WRITE(lunout,*)'Couplage Thermiques/Emanuel seulement si T<0'
-             ENDIF
-             do i=1,klon
-                if (t_seri(i,lmax_th(i))>273.) then
-                   Ale_bl(i)=0.
-                endif
-             enddo
-!    print *,'In order to run with iflag_coupl=2, you have to comment out the following stop'
-!             STOP
-             abort_message='In order to run with iflag_coupl=2, you have to comment out the following abort'
-             CALL abort_physic(modname,abort_message,1)
-          endif
-   RETURN
-   END
-
Index: /LMDZ6/trunk/libf/phylmd/alpale_th.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/alpale_th.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/alpale_th.f90	(revision 5268)
@@ -0,0 +1,347 @@
+!
+! $Id$
+!
+SUBROUTINE alpale_th ( dtime, lmax_th, t_seri, cell_area,  &
+                       cin, s2, n2, strig,  &
+                       ale_bl_trig, ale_bl_stat, ale_bl,  &
+                       alp_bl, alp_bl_stat, &
+                       proba_notrig, random_notrig, birth_rate)
+
+! **************************************************************
+! *
+! ALPALE_TH                                                    *
+! *
+! *
+! written by   : Jean-Yves Grandpeix, 11/05/2016              *
+! modified by :                                               *
+! **************************************************************
+
+  USE dimphy
+  USE ioipsl_getin_p_mod, ONLY : getin_p
+  USE print_control_mod, ONLY: mydebug=>debug , lunout, prt_level
+!
+  IMPLICIT NONE
+
+!================================================================
+! Auteur(s)   : Jean-Yves Grandpeix, 11/05/2016
+! Objet : Contribution of the thermal scheme to Ale and Alp
+!================================================================
+
+! Input arguments
+!----------------
+  REAL, INTENT(IN)                                           :: dtime
+  REAL, DIMENSION(klon), INTENT(IN)                          :: cell_area
+  INTEGER, DIMENSION(klon), INTENT(IN)                       :: lmax_th
+  REAL, DIMENSION(klon,klev), INTENT(IN)                     :: t_seri
+  REAL, DIMENSION(klon), INTENT(IN)                          :: ale_bl_stat
+  REAL, DIMENSION(klon), INTENT(IN)                          :: cin
+  REAL, DIMENSION(klon), INTENT(IN)                          :: s2, n2, strig
+                                                                
+  REAL, DIMENSION(klon), INTENT(INOUT)                       :: ale_bl_trig, ale_bl
+  REAL, DIMENSION(klon), INTENT(INOUT)                       :: alp_bl
+  REAL, DIMENSION(klon), INTENT(INOUT)                       :: alp_bl_stat
+  REAL, DIMENSION(klon), INTENT(INOUT)                       :: proba_notrig
+
+  REAL, DIMENSION(klon), INTENT(OUT)                         :: random_notrig
+
+  REAL, DIMENSION(klon), INTENT(OUT)                         :: birth_rate
+
+  include "alpale.h"
+
+! Local variables
+!----------------
+  INTEGER                                                    :: i
+  LOGICAL, SAVE                                              :: first = .TRUE.
+  LOGICAL, SAVE                                              :: multiply_proba_notrig = .FALSE.
+  REAL, SAVE                                                 :: random_notrig_max=1.
+  REAL, SAVE                                                 :: cv_feed_area
+  REAL                                                       :: birth_number
+  REAL, DIMENSION(klon)                                      :: ale_bl_ref
+  REAL, DIMENSION(klon)                                      :: tau_trig
+!
+    !$OMP THREADPRIVATE(multiply_proba_notrig) 
+    !$OMP THREADPRIVATE(random_notrig_max) 
+    !$OMP THREADPRIVATE(cv_feed_area) 
+    !$OMP THREADPRIVATE(first)
+!
+ REAL umexp  ! expression of (1.-exp(-x))/x valid for all x, especially when x->0
+ REAL x
+!
+     CHARACTER (LEN=20) :: modname='alpale_th'
+     CHARACTER (LEN=80) :: abort_message
+     
+ umexp(x) = max(sign(1.,x-1.e-3),0.)*(1.-exp(-x))/max(x,1.e-3) + &
+            (1.-max(sign(1.,x-1.e-3),0.))*(1.-0.5*x*(1.-x/3.*(1.-0.25*x)))  !!! correct formula            (jyg)
+!!!            (1.-max(sign(1.,x-1.e-3),0.))*(-0.5*x*(1.-x/3.*(1.-0.25*x))) !!! bug introduced by mistake  (jyg)
+!!!            (1.-max(sign(1.,x-1.e-3),0.))*(1.-0.5*x*(1.-x/3.*(1.-0.25*x)))  !!! initial correct formula (jyg)
+!
+!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+!  JYG, 20160513 : Introduction of the Effective Lifting Power (ELP), which 
+! takes into account the area (cv_feed_area) covered by thermals contributing 
+! to each cumulonimbus.
+!   The use of ELP prevents singularities when the trigger probability tends to
+! zero. It is activated by iflag_clos_bl = 3.
+!   The ELP values are stored in the ALP_bl variable.
+!   
+!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+!
+
+    IF (first) THEN
+      CALL getin_p('multiply_proba_notrig',multiply_proba_notrig)
+      IF (iflag_clos_bl .LT. 3) THEN
+         random_notrig_max=1.
+         CALL getin_p('random_notrig_max',random_notrig_max)
+      ELSEIF (iflag_clos_bl .EQ. 3) THEN  ! (iflag_clos_bl .LT. 3)
+         cv_feed_area = 1.e10   ! m2
+         CALL getin_p('cv_feed_area', cv_feed_area)
+      ENDIF  !! (iflag_clos_bl .LT. 3)
+      first=.FALSE.
+    ENDIF
+
+!!
+!!   Control of the multiplication of no-trigger probabilities between calls 
+!! to the convection scheme. If multiply_proba_notrig is .false., then
+!! proba_notrig is set to 1 at each call to alpale_th, so that only the last call 
+!! plays a role in the triggering of convection. If it is .true., then propa_notrig 
+!! is saved between calls to convection and is reset to 1 only after calling the 
+!! convection scheme.
+!!    For instance, if the probability of no_trigger is 0.9 at each call, and if 
+!! there are 3 calls to alpale_th between calls to the convection scheme, then the 
+!! probability of triggering convection will be 0.1 (= 1.-0.9) if 
+!! multiply_proba_notrig is .false. and 0.271 (= 1.-0.9^3) if multiply_proba_notrig 
+!! is .true.
+!!
+    IF (.NOT.multiply_proba_notrig) THEN
+             DO i=1,klon
+                proba_notrig(i)=1.
+             ENDDO
+    ENDIF  !! (.NOT.multiply_proba_notrig)
+!!
+!!
+!---------------------------------------
+  IF (iflag_clos_bl .LT. 3) THEN
+!---------------------------------------
+!
+!      Original code (Nicolas Rochetin)
+!     --------------------------------
+          !cc nrlmd le 10/04/2012
+          !-----------Stochastic triggering-----------
+          if (iflag_trig_bl.ge.1) then
+             !
+             IF (prt_level .GE. 10) THEN
+                WRITE(lunout,*)'cin, ale_bl_stat, alp_bl, alp_bl_stat ', &
+                     cin, ale_bl_stat, alp_bl, alp_bl_stat
+             ENDIF
+
+
+             !----Initialisations
+             do i=1,klon
+!!jyg                proba_notrig(i)=1.
+                random_notrig(i)=1e6*ale_bl_stat(i)-int(1e6*ale_bl_stat(i))
+                if ( random_notrig(i) > random_notrig_max ) random_notrig(i)=0.
+                if ( ale_bl_trig(i) .lt. abs(cin(i))+1.e-10 ) then 
+                   tau_trig(i)=tau_trig_shallow
+                else
+                   tau_trig(i)=tau_trig_deep
+                endif
+             enddo
+             !
+             IF (prt_level .GE. 10) THEN
+                WRITE(lunout,*)'random_notrig, tau_trig ', &
+                     random_notrig, tau_trig
+                WRITE(lunout,*)'s_trig,s2,n2 ', &
+                     s_trig,s2,n2
+             ENDIF
+
+             !Option pour re-activer l'ancien calcul de Ale_bl (iflag_trig_bl=2)
+             IF (iflag_trig_bl.eq.1) then
+
+                !----Tirage al\'eatoire et calcul de ale_bl_trig
+                do i=1,klon
+                   if ( (ale_bl_stat(i) .gt. abs(cin(i))+1.e-10) )  then
+                      proba_notrig(i)=proba_notrig(i)* &
+                         (1.-exp(-strig(i)/s2(i)))**(n2(i)*dtime/tau_trig(i))
+                      !        print *, 'proba_notrig(i) ',proba_notrig(i)
+                      if (random_notrig(i) .ge. proba_notrig(i)) then 
+                         ale_bl_trig(i)=ale_bl_stat(i)
+                      else
+                         ale_bl_trig(i)=0.
+                      endif
+                      birth_rate(i) = n2(i)*exp(-strig(i)/s2(i))/(tau_trig(i)*cell_area(i))
+!!!                      birth_rate(i) = max(birth_rate(i),1.e-18)
+                   else
+!!jyg                      proba_notrig(i)=1.
+                      birth_rate(i) = 0.
+                      random_notrig(i)=0.
+                      ale_bl_trig(i)=0.
+                   endif
+                enddo
+
+             ELSE IF (iflag_trig_bl.ge.2) then
+
+                do i=1,klon
+                   if ( (Ale_bl(i) .gt. abs(cin(i))+1.e-10) )  then
+                      proba_notrig(i)=proba_notrig(i)* &
+                         (1.-exp(-strig(i)/s2(i)))**(n2(i)*dtime/tau_trig(i))
+                      !        print *, 'proba_notrig(i) ',proba_notrig(i)
+                      if (random_notrig(i) .ge. proba_notrig(i)) then 
+                         ale_bl_trig(i)=Ale_bl(i)
+                      else
+                         ale_bl_trig(i)=0.
+                      endif
+                      birth_rate(i) = n2(i)*exp(-strig(i)/s2(i))/(tau_trig(i)*cell_area(i))
+!!!                      birth_rate(i) = max(birth_rate(i),1.e-18)
+                   else
+!!jyg                      proba_notrig(i)=1.
+                      birth_rate(i) = 0.
+                      random_notrig(i)=0.
+                      ale_bl_trig(i)=0.
+                   endif
+                enddo
+
+             ENDIF
+
+             !
+             IF (prt_level .GE. 10) THEN
+                WRITE(lunout,*)'proba_notrig, ale_bl_trig ', &
+                     proba_notrig, ale_bl_trig
+             ENDIF
+
+          endif !(iflag_trig_bl)
+
+          !-----------Statistical closure-----------
+          if (iflag_clos_bl.eq.1) then 
+
+             do i=1,klon
+                !CR: alp probabiliste
+                if (ale_bl_trig(i).gt.0.) then
+                   alp_bl(i)=alp_bl(i)/(1.-min(proba_notrig(i),0.999))
+                endif
+             enddo
+
+          else if (iflag_clos_bl.eq.2) then
+
+             !CR: alp calculee dans thermcell_main
+             do i=1,klon
+                alp_bl(i)=alp_bl_stat(i)
+             enddo
+
+          else
+
+             alp_bl_stat(:)=0.
+
+          endif !(iflag_clos_bl)
+
+!
+!---------------------------------------
+  ELSEIF (iflag_clos_bl .EQ. 3) THEN  ! (iflag_clos_bl .LT. 3)
+!---------------------------------------
+!
+!      New code with Effective Lifting Power
+!     -------------------------------------
+
+          !-----------Stochastic triggering-----------
+     if (iflag_trig_bl.ge.1) then
+        !
+        IF (prt_level .GE. 10) THEN
+           WRITE(lunout,*)'cin, ale_bl_stat, alp_bl_stat ', &
+                cin, ale_bl_stat, alp_bl_stat
+        ENDIF
+
+        ! Use ale_bl_stat (Rochetin's code) or ale_bl (old code) according to 
+        ! iflag_trig_bl value.
+        IF (iflag_trig_bl.eq.1) then         ! use ale_bl_stat (Rochetin computation)
+         do i=1,klon
+              ale_bl_ref(i)=ale_bl_stat(i)
+         enddo
+        ELSE IF (iflag_trig_bl.ge.2) then    ! use ale_bl (old computation)
+         do i=1,klon
+              ale_bl_ref(i)=Ale_bl(i)
+         enddo
+        ENDIF ! (iflag_trig_bl.eq.1)
+
+
+        !----Initializations and random number generation
+        do i=1,klon
+!!jyg           proba_notrig(i)=1.
+           random_notrig(i)=1e6*ale_bl_stat(i)-int(1e6*ale_bl_stat(i))
+           if ( ale_bl_trig(i) .lt. abs(cin(i))+1.e-10 ) then 
+              tau_trig(i)=tau_trig_shallow
+           else
+              tau_trig(i)=tau_trig_deep
+           endif
+        enddo
+        !
+        IF (prt_level .GE. 10) THEN
+           WRITE(lunout,*)'random_notrig, tau_trig ', &
+                random_notrig, tau_trig
+           WRITE(lunout,*)'s_trig,s2,n2 ', &
+                s_trig,s2,n2
+        ENDIF
+
+        !----alp_bl computation
+        do i=1,klon
+           if ( (ale_bl_ref(i) .gt. abs(cin(i))+1.e-10) )  then
+              birth_number = n2(i)*exp(-strig(i)/s2(i))
+              birth_rate(i) = birth_number/(tau_trig(i)*cell_area(i))
+!!!              birth_rate(i) = max(birth_rate(i),1.e-18)
+              proba_notrig(i)=proba_notrig(i)*exp(-birth_number*dtime/tau_trig(i))
+              Alp_bl(i) = Alp_bl(i)* &
+                          umexp(-birth_number*cv_feed_area/cell_area(i))/ &
+                          umexp(-birth_number*dtime/tau_trig(i))*  &
+                          tau_trig(i)*cv_feed_area/(dtime*cell_area(i))
+          else 
+!!jyg              proba_notrig(i)=1.
+              birth_rate(i)=0.
+              random_notrig(i)=0.
+              alp_bl(i)=0.
+           endif
+        enddo
+
+        !----ale_bl_trig computation
+         do i=1,klon
+           if (random_notrig(i) .ge. proba_notrig(i)) then 
+              ale_bl_trig(i)=ale_bl_ref(i)
+           else
+              ale_bl_trig(i)=0.
+           endif
+         enddo
+
+        !
+        IF (prt_level .GE. 10) THEN
+           WRITE(lunout,*)'proba_notrig, ale_bl_trig ', &
+                proba_notrig, ale_bl_trig
+        ENDIF
+
+     endif !(iflag_trig_bl .ge. 1)
+
+!---------------------------------------
+  ENDIF ! (iflag_clos_bl .LT. 3)
+!---------------------------------------
+
+          IF (prt_level .GE. 10) THEN
+             WRITE(lunout,*)'alpale_th: ale_bl_trig, alp_bl_stat, birth_rate ', &
+                      ale_bl_trig(1), alp_bl_stat(1), birth_rate(1)
+          ENDIF
+
+          !cc fin nrlmd le 10/04/2012
+!
+          !IM/FH: 2011/02/23 
+          ! Couplage Thermiques/Emanuel seulement si T<0
+          if (iflag_coupl==2) then
+             IF (prt_level .GE. 10) THEN
+                WRITE(lunout,*)'Couplage Thermiques/Emanuel seulement si T<0'
+             ENDIF
+             do i=1,klon
+                if (t_seri(i,lmax_th(i))>273.) then
+                   Ale_bl(i)=0.
+                endif
+             enddo
+!    print *,'In order to run with iflag_coupl=2, you have to comment out the following stop'
+!             STOP
+             abort_message='In order to run with iflag_coupl=2, you have to comment out the following abort'
+             CALL abort_physic(modname,abort_message,1)
+          endif
+   RETURN
+   END
+
Index: DZ6/trunk/libf/phylmd/alpale_wk.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/alpale_wk.F90	(revision 5267)
+++ 	(revision )
@@ -1,84 +1,0 @@
-SUBROUTINE alpale_wk ( dtime, cell_area, zoccur, sigmaw, wdens, fip ,  &
-                       fip_cond)
-
-! **************************************************************
-!                                                              *
-! ALPALE_WK                                                    *
-!                                                              *
-!                                                              *
-! written by   : Jean-Yves Grandpeix, 07/08/2017               *
-! modified by :                                                *
-! **************************************************************
-
-  USE dimphy, ONLY: klon
-  USE ioipsl_getin_p_mod, ONLY : getin_p
-  USE print_control_mod, ONLY: mydebug=>debug , lunout, prt_level
-!
-  IMPLICIT NONE
-
-!================================================================
-! Auteur(s)   : Jean-Yves Grandpeix, 07/08/2017
-! Objet : Contribution of the wake scheme to Ale and Alp
-!================================================================
-
-! Input arguments
-!----------------
-  REAL, INTENT(IN)                                           :: dtime
-  REAL, DIMENSION(klon),    INTENT(IN)                       :: cell_area
-  INTEGER, DIMENSION(klon), INTENT (IN)                      :: zoccur
-  REAL, DIMENSION(klon),    INTENT(IN)                       :: sigmaw
-  REAL, DIMENSION(klon),    INTENT(IN)                       :: wdens
-  REAL, DIMENSION(klon),    INTENT(IN)                       :: fip
-! Output arguments
-!-----------------
-  REAL, DIMENSION(klon), INTENT(OUT)                         :: fip_cond
-
-
-! Local variables
-!----------------
-  INTEGER                                                    :: i
-  LOGICAL, SAVE                                              :: first = .TRUE.
-  !$OMP THREADPRIVATE(first)
-  REAL, ALLOCATABLE, SAVE, DIMENSION(:)                      :: cellrad
-  !$OMP THREADPRIVATE(cellrad)
-  REAL, DIMENSION(klon)                                      :: wkrad
-  REAL, DIMENSION(klon)                                      :: proba_gf
-
-  INCLUDE "YOMCST.h"   ! rpi
-
-IF (first) THEN
-  ALLOCATE (cellrad(klon))
-!  Compute pseudo grid-cell radius cellrad, such that pi*cellrad^2=cell_area
-  print *,'alpale_wk: cell_area(1) ',cell_area(1)
-  cellrad(:)=sqrt(cell_area(:)/rpi)
-  first = .FALSE.
-ENDIF
-
-!  Compute wake radius
-!!  print *,'alpale_wk: sigmaw(1), wdens(1) ', sigmaw(1), wdens(1)
-  DO i = 1,klon
-    IF (zoccur(i) .GE. 1) THEN
-      wkrad(i) = sqrt(sigmaw(i)/(rpi*wdens(i)))
-    ELSE
-      wkrad(i) = 0.
-    ENDIF ! (zoccur(i) .GE. 1)
-  ENDDO
-
-!  Compute probability that the grid-cell is intersected by a gust front
-!!  print *,'alpale_wk: wkrad(1), cellrad(1) ', wkrad(1), cellrad(1)
-!!  proba_gf(:) = exp(-wdens(:)*rpi*max(wkrad(:)-cellrad(:),0.)**2) - &   ! Formules
-!!                exp(-wdens(:)*rpi*(wkrad(:)+cellrad(:))**2)             ! fausses !
-  proba_gf(:) = 1. - exp(-wdens(:)*rpi*((wkrad(:)+cellrad(:))**2 - &
-                                        max(wkrad(:)-cellrad(:),0.)**2) )
-!
-  proba_gf(:) = max(proba_gf(:),1.e-3)
-!  Compute Fip conditionned on the presence of some gust front within the 
-!  grid-cell
-!!  print *,'alpale_wk: proba_gf(1), fip(1), ', proba_gf(1), fip(1)
-  fip_cond(:) = fip(:)/proba_gf(:)
-!!    print *,'alpale_wk: wkrad(1), cellrad(1), proba_gf(1), fip(1), fip_cond(1) ', &
-!!                        wkrad(1), cellrad(1), proba_gf(1), fip(1), fip_cond(1)
-
-   RETURN
-   END SUBROUTINE alpale_wk
-
Index: /LMDZ6/trunk/libf/phylmd/alpale_wk.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/alpale_wk.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/alpale_wk.f90	(revision 5268)
@@ -0,0 +1,84 @@
+SUBROUTINE alpale_wk ( dtime, cell_area, zoccur, sigmaw, wdens, fip ,  &
+                       fip_cond)
+
+! **************************************************************
+!                                                              *
+! ALPALE_WK                                                    *
+!                                                              *
+!                                                              *
+! written by   : Jean-Yves Grandpeix, 07/08/2017               *
+! modified by :                                                *
+! **************************************************************
+
+  USE dimphy, ONLY: klon
+  USE ioipsl_getin_p_mod, ONLY : getin_p
+  USE print_control_mod, ONLY: mydebug=>debug , lunout, prt_level
+!
+  IMPLICIT NONE
+
+!================================================================
+! Auteur(s)   : Jean-Yves Grandpeix, 07/08/2017
+! Objet : Contribution of the wake scheme to Ale and Alp
+!================================================================
+
+! Input arguments
+!----------------
+  REAL, INTENT(IN)                                           :: dtime
+  REAL, DIMENSION(klon),    INTENT(IN)                       :: cell_area
+  INTEGER, DIMENSION(klon), INTENT (IN)                      :: zoccur
+  REAL, DIMENSION(klon),    INTENT(IN)                       :: sigmaw
+  REAL, DIMENSION(klon),    INTENT(IN)                       :: wdens
+  REAL, DIMENSION(klon),    INTENT(IN)                       :: fip
+! Output arguments
+!-----------------
+  REAL, DIMENSION(klon), INTENT(OUT)                         :: fip_cond
+
+
+! Local variables
+!----------------
+  INTEGER                                                    :: i
+  LOGICAL, SAVE                                              :: first = .TRUE.
+  !$OMP THREADPRIVATE(first)
+  REAL, ALLOCATABLE, SAVE, DIMENSION(:)                      :: cellrad
+  !$OMP THREADPRIVATE(cellrad)
+  REAL, DIMENSION(klon)                                      :: wkrad
+  REAL, DIMENSION(klon)                                      :: proba_gf
+
+  INCLUDE "YOMCST.h"   ! rpi
+
+IF (first) THEN
+  ALLOCATE (cellrad(klon))
+!  Compute pseudo grid-cell radius cellrad, such that pi*cellrad^2=cell_area
+  print *,'alpale_wk: cell_area(1) ',cell_area(1)
+  cellrad(:)=sqrt(cell_area(:)/rpi)
+  first = .FALSE.
+ENDIF
+
+!  Compute wake radius
+!!  print *,'alpale_wk: sigmaw(1), wdens(1) ', sigmaw(1), wdens(1)
+  DO i = 1,klon
+    IF (zoccur(i) .GE. 1) THEN
+      wkrad(i) = sqrt(sigmaw(i)/(rpi*wdens(i)))
+    ELSE
+      wkrad(i) = 0.
+    ENDIF ! (zoccur(i) .GE. 1)
+  ENDDO
+
+!  Compute probability that the grid-cell is intersected by a gust front
+!!  print *,'alpale_wk: wkrad(1), cellrad(1) ', wkrad(1), cellrad(1)
+!!  proba_gf(:) = exp(-wdens(:)*rpi*max(wkrad(:)-cellrad(:),0.)**2) - &   ! Formules
+!!                exp(-wdens(:)*rpi*(wkrad(:)+cellrad(:))**2)             ! fausses !
+  proba_gf(:) = 1. - exp(-wdens(:)*rpi*((wkrad(:)+cellrad(:))**2 - &
+                                        max(wkrad(:)-cellrad(:),0.)**2) )
+!
+  proba_gf(:) = max(proba_gf(:),1.e-3)
+!  Compute Fip conditionned on the presence of some gust front within the 
+!  grid-cell
+!!  print *,'alpale_wk: proba_gf(1), fip(1), ', proba_gf(1), fip(1)
+  fip_cond(:) = fip(:)/proba_gf(:)
+!!    print *,'alpale_wk: wkrad(1), cellrad(1), proba_gf(1), fip(1), fip_cond(1) ', &
+!!                        wkrad(1), cellrad(1), proba_gf(1), fip(1), fip_cond(1)
+
+   RETURN
+   END SUBROUTINE alpale_wk
+
Index: DZ6/trunk/libf/phylmd/atm2geo.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/atm2geo.F90	(revision 5267)
+++ 	(revision )
@@ -1,72 +1,0 @@
-!
-! $Id$
-!
-SUBROUTINE atm2geo ( im, jm, pte, ptn, plon, plat, pxx, pyy, pzz )
-  USE dimphy
-  USE mod_phys_lmdz_para
-  USE mod_grid_phy_lmdz, only: grid_type, unstructured, regular_lonlat
-  IMPLICIT NONE
-  INCLUDE 'YOMCST.h'
-
-  CHARACTER (len = 6)                :: clmodnam
-  CHARACTER (len = 20)               :: modname = 'atm2geo'
-  CHARACTER (len = 80)               :: abort_message
-
-!
-! Change wind local atmospheric coordinates to geocentric
-!
-! Geocentric :
-! axe x is eastward : crosses (0 N, 0 E) point.
-! axe y crosses (0 N, 90 E) point.
-! axe z is 'up' : crosses north pole
-  INTEGER, INTENT (in)                 :: im, jm
-  REAL, DIMENSION (im,jm), INTENT (in) :: pte  ! Eastward vector component
-  REAL, DIMENSION (im,jm), INTENT (in) :: ptn  ! Northward vector component
-  REAL, DIMENSION (im,jm), INTENT (in) :: plon, plat
-  REAL, DIMENSION (im,jm), INTENT(out) :: pxx, pyy, pzz  ! Component in the geocentric referential 
-  REAL :: rad, reps
-
-  rad = rpi / 180.0E0
-  reps = 1.0e-5
-  
-  pxx(:,:) = & 
-       - pte(:,:) * SIN(rad * plon(:,:)) &
-       - ptn(:,:) * SIN(rad * plat(:,:)) * COS(rad * plon(:,:))
-
-  pyy(:,:) = &
-       + pte(:,:) * COS(rad * plon(:,:)) &
-       - ptn(:,:) * SIN(rad * plat(:,:)) * SIN(rad * plon(:,:))
-  
-  pzz(:,:) = &
-       + ptn(:,:) * COS(rad * plat (:,:))
-  
-  IF (grid_type==regular_lonlat) THEN
-  ! Value at North Pole  
-    IF (is_north_pole_dyn) THEN
-       pxx(:, 1) = - pte (1, 1)
-       pyy(:, 1) = - ptn (1, 1) 
-       pzz(:, 1) = pzz(1,1) ! => 0
-    ENDIF
-
-  ! Value at South Pole
-    IF (is_south_pole_dyn) THEN
-      pxx(:,jm) = pxx(1,jm)
-       pyy(:,jm) = pyy(1,jm)
-       pzz(:,jm) = pzz(1,jm) ! => 0
-    ENDIF
- 
-  ELSE IF (grid_type==unstructured) THEN
-     ! Pole nord pour Dynamico
-     WHERE ( plat(:,:) >= 90.0d+0-reps )
-        pxx (:,:) = -ptn (:,:)
-        pyy (:,:) =  pte (:,:)
-        pzz (:,:) =  0.0e0
-     END WHERE
-
-  ELSE
-     abort_message='Problem: unknown grid type'
-     CALL abort_physic(modname,abort_message,1)
-  END IF
-
-  
-END SUBROUTINE atm2geo
Index: /LMDZ6/trunk/libf/phylmd/atm2geo.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/atm2geo.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/atm2geo.f90	(revision 5268)
@@ -0,0 +1,72 @@
+!
+! $Id$
+!
+SUBROUTINE atm2geo ( im, jm, pte, ptn, plon, plat, pxx, pyy, pzz )
+  USE dimphy
+  USE mod_phys_lmdz_para
+  USE mod_grid_phy_lmdz, only: grid_type, unstructured, regular_lonlat
+  IMPLICIT NONE
+  INCLUDE 'YOMCST.h'
+
+  CHARACTER (len = 6)                :: clmodnam
+  CHARACTER (len = 20)               :: modname = 'atm2geo'
+  CHARACTER (len = 80)               :: abort_message
+
+!
+! Change wind local atmospheric coordinates to geocentric
+!
+! Geocentric :
+! axe x is eastward : crosses (0 N, 0 E) point.
+! axe y crosses (0 N, 90 E) point.
+! axe z is 'up' : crosses north pole
+  INTEGER, INTENT (in)                 :: im, jm
+  REAL, DIMENSION (im,jm), INTENT (in) :: pte  ! Eastward vector component
+  REAL, DIMENSION (im,jm), INTENT (in) :: ptn  ! Northward vector component
+  REAL, DIMENSION (im,jm), INTENT (in) :: plon, plat
+  REAL, DIMENSION (im,jm), INTENT(out) :: pxx, pyy, pzz  ! Component in the geocentric referential 
+  REAL :: rad, reps
+
+  rad = rpi / 180.0E0
+  reps = 1.0e-5
+  
+  pxx(:,:) = & 
+       - pte(:,:) * SIN(rad * plon(:,:)) &
+       - ptn(:,:) * SIN(rad * plat(:,:)) * COS(rad * plon(:,:))
+
+  pyy(:,:) = &
+       + pte(:,:) * COS(rad * plon(:,:)) &
+       - ptn(:,:) * SIN(rad * plat(:,:)) * SIN(rad * plon(:,:))
+  
+  pzz(:,:) = &
+       + ptn(:,:) * COS(rad * plat (:,:))
+  
+  IF (grid_type==regular_lonlat) THEN
+  ! Value at North Pole  
+    IF (is_north_pole_dyn) THEN
+       pxx(:, 1) = - pte (1, 1)
+       pyy(:, 1) = - ptn (1, 1) 
+       pzz(:, 1) = pzz(1,1) ! => 0
+    ENDIF
+
+  ! Value at South Pole
+    IF (is_south_pole_dyn) THEN
+      pxx(:,jm) = pxx(1,jm)
+       pyy(:,jm) = pyy(1,jm)
+       pzz(:,jm) = pzz(1,jm) ! => 0
+    ENDIF
+ 
+  ELSE IF (grid_type==unstructured) THEN
+     ! Pole nord pour Dynamico
+     WHERE ( plat(:,:) >= 90.0d+0-reps )
+        pxx (:,:) = -ptn (:,:)
+        pyy (:,:) =  pte (:,:)
+        pzz (:,:) =  0.0e0
+     END WHERE
+
+  ELSE
+     abort_message='Problem: unknown grid type'
+     CALL abort_physic(modname,abort_message,1)
+  END IF
+
+  
+END SUBROUTINE atm2geo
Index: DZ6/trunk/libf/phylmd/borne_var_surf.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/borne_var_surf.F90	(revision 5267)
+++ 	(revision )
@@ -1,111 +1,0 @@
-SUBROUTINE borne_var_surf(klon,klev,nbsrf,                   &
-         iflag_bug_t2m_stab_ipslcm61,                        &
-         t1,q1,u1,v1,                                        &
-         ftsol, qsurf, pctsrf, paprs,                        &
-         t2m, q2m, u10m, v10m,                               &
-         zt2m_cor, zq2m_cor, zu10m_cor, zv10m_cor,           &
-         zrh2m_cor, zqsat2m_cor)
-
-IMPLICIT NONE
-
-!==================================================================
-! Declarations
-!==================================================================
-
-! arguments
-INTEGER klon,klev,nbsrf,iflag_bug_t2m_stab_ipslcm61
-REAL,DIMENSION(klon),INTENT(IN) :: t1, q1, u1, v1
-REAL,DIMENSION(klon,nbsrf),INTENT(IN) :: t2m, q2m, u10m, v10m
-REAL,DIMENSION(klon,nbsrf),INTENT(IN) :: ftsol, pctsrf
-REAL,DIMENSION(klon,klev+1),INTENT(IN) :: paprs 
-REAL,DIMENSION(klon),INTENT(IN) :: qsurf
-REAL,DIMENSION (klon),INTENT(OUT) :: zt2m_cor, zq2m_cor, zu10m_cor, zv10m_cor
-REAL,DIMENSION (klon),INTENT(OUT)  :: zrh2m_cor, zqsat2m_cor
-
-
-! local
-INTEGER i,nsrf
-REAL,DIMENSION (klon,nbsrf) :: t2m_cor, q2m_cor, u10m_cor, v10m_cor
-REAL                               :: zx_qs1, zcor1, zdelta1
-include "YOMCST.h"
-include "YOETHF.h"
-include "FCTTRE.h"
-!==================================================================
-! Correction of sub surface variables
-!==================================================================
-
-zrh2m_cor=0.
-zqsat2m_cor=0.
-
-DO nsrf=1,nbsrf
-   DO i=1,klon
-    t2m_cor(i,nsrf)=t2m(i,nsrf)
-    q2m_cor(i,nsrf)=q2m(i,nsrf)
-    u10m_cor(i,nsrf)=u10m(i,nsrf)
-    v10m_cor(i,nsrf)=v10m(i,nsrf)
-     IF(iflag_bug_t2m_stab_ipslcm61.EQ.-2.AND.q2m(i,nsrf).LT.0.) THEN
-      t2m_cor(i,nsrf)=MIN(t2m(i,nsrf),MAX(t1(i),ftsol(i,nsrf)))
-      t2m_cor(i,nsrf)=MAX(t2m_cor(i,nsrf),MIN(t1(i),ftsol(i,nsrf)))
-      q2m_cor(i,nsrf)=MIN(q2m(i,nsrf),MAX(q1(i),qsurf(i)))
-      q2m_cor(i,nsrf)=MAX(q2m_cor(i,nsrf),MIN(q1(i),qsurf(i)))
-      q2m_cor(i,nsrf)=MAX(q2m_cor(i,nsrf),0.)
-      u10m_cor(i,nsrf)=SIGN(MIN(ABS(u1(i)),ABS(u10m(i,nsrf))),u1(i))
-      v10m_cor(i,nsrf)=SIGN(MIN(ABS(v1(i)),ABS(v10m(i,nsrf))),v1(i))
-     ELSEIF(iflag_bug_t2m_stab_ipslcm61.EQ.-1.AND.(ftsol(i,nsrf).LE.t1(i).OR.q2m(i,nsrf).LT.0.)) THEN
-      t2m_cor(i,nsrf)=MIN(t2m(i,nsrf),MAX(t1(i),ftsol(i,nsrf)))
-      t2m_cor(i,nsrf)=MAX(t2m_cor(i,nsrf),MIN(t1(i),ftsol(i,nsrf)))
-      q2m_cor(i,nsrf)=MIN(q2m(i,nsrf),MAX(q1(i),qsurf(i)))
-      q2m_cor(i,nsrf)=MAX(q2m_cor(i,nsrf),MIN(q1(i),qsurf(i)))
-      q2m_cor(i,nsrf)=MAX(q2m_cor(i,nsrf),0.)
-      u10m_cor(i,nsrf)=SIGN(MIN(ABS(u1(i)),ABS(u10m(i,nsrf))),u1(i))
-      v10m_cor(i,nsrf)=SIGN(MIN(ABS(v1(i)),ABS(v10m(i,nsrf))),v1(i))
-     ELSEIF(iflag_bug_t2m_stab_ipslcm61.EQ.1.AND.ftsol(i,nsrf).LE.t1(i)) THEN
-      t2m_cor(i,nsrf)=MIN(t2m(i,nsrf),MAX(t1(i),ftsol(i,nsrf)))
-      t2m_cor(i,nsrf)=MAX(t2m_cor(i,nsrf),MIN(t1(i),ftsol(i,nsrf)))
-      q2m_cor(i,nsrf)=MIN(q2m(i,nsrf),MAX(q1(i),qsurf(i)))
-      q2m_cor(i,nsrf)=MAX(q2m_cor(i,nsrf),MIN(q1(i),qsurf(i)))
-      q2m_cor(i,nsrf)=MAX(q2m_cor(i,nsrf),0.)
-      u10m_cor(i,nsrf)=SIGN(MIN(ABS(u1(i)),ABS(u10m(i,nsrf))),u1(i))
-      v10m_cor(i,nsrf)=SIGN(MIN(ABS(v1(i)),ABS(v10m(i,nsrf))),v1(i))
-     ELSEIF(iflag_bug_t2m_stab_ipslcm61.EQ.0) THEN
-      t2m_cor(i,nsrf)=MIN(t2m(i,nsrf),MAX(t1(i),ftsol(i,nsrf)))
-      t2m_cor(i,nsrf)=MAX(t2m_cor(i,nsrf),MIN(t1(i),ftsol(i,nsrf)))
-      q2m_cor(i,nsrf)=MIN(q2m(i,nsrf),MAX(q1(i),qsurf(i)))
-      q2m_cor(i,nsrf)=MAX(q2m_cor(i,nsrf),MIN(q1(i),qsurf(i)))
-      q2m_cor(i,nsrf)=MAX(q2m_cor(i,nsrf),0.)
-      u10m_cor(i,nsrf)=SIGN(MIN(ABS(u1(i)),ABS(u10m(i,nsrf))),u1(i))
-      v10m_cor(i,nsrf)=SIGN(MIN(ABS(v1(i)),ABS(v10m(i,nsrf))),v1(i))
-     ENDIF
-!!!
-     zdelta1 = MAX(0.,SIGN(1., rtt-t2m_cor(i,nsrf) ))
-     zx_qs1  = r2es * FOEEW(t2m_cor(i,nsrf),zdelta1)/paprs(i,1)
-     zx_qs1  = MIN(0.5,zx_qs1)
-     zcor1   = 1./(1.-RETV*zx_qs1)
-     zx_qs1  = zx_qs1*zcor1
-     zrh2m_cor(i) = zrh2m_cor(i) + q2m_cor(i,nsrf)/zx_qs1 * pctsrf(i,nsrf)
-     zqsat2m_cor(i) = zqsat2m_cor(i) + zx_qs1  * pctsrf(i,nsrf)
-!!!
-   ENDDO
-ENDDO
-
-!==================================================================
-! Agregation of sub surfaces
-!==================================================================
-
-zt2m_cor=0.
-zq2m_cor=0.
-zu10m_cor=0.
-zv10m_cor=0.
-DO nsrf = 1, nbsrf
-   DO i = 1, klon
-      zt2m_cor(i)  = zt2m_cor(i)  + t2m_cor(i,nsrf)  * pctsrf(i,nsrf)
-      zq2m_cor(i)  = zq2m_cor(i)  + q2m_cor(i,nsrf)  * pctsrf(i,nsrf)
-      zu10m_cor(i) = zu10m_cor(i) + u10m_cor(i,nsrf) * pctsrf(i,nsrf)
-      zv10m_cor(i) = zv10m_cor(i) + v10m_cor(i,nsrf) * pctsrf(i,nsrf)
-   ENDDO
-ENDDO
-
-RETURN
-END
-
-
Index: /LMDZ6/trunk/libf/phylmd/borne_var_surf.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/borne_var_surf.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/borne_var_surf.f90	(revision 5268)
@@ -0,0 +1,111 @@
+SUBROUTINE borne_var_surf(klon,klev,nbsrf,                   &
+         iflag_bug_t2m_stab_ipslcm61,                        &
+         t1,q1,u1,v1,                                        &
+         ftsol, qsurf, pctsrf, paprs,                        &
+         t2m, q2m, u10m, v10m,                               &
+         zt2m_cor, zq2m_cor, zu10m_cor, zv10m_cor,           &
+         zrh2m_cor, zqsat2m_cor)
+
+IMPLICIT NONE
+
+!==================================================================
+! Declarations
+!==================================================================
+
+! arguments
+INTEGER klon,klev,nbsrf,iflag_bug_t2m_stab_ipslcm61
+REAL,DIMENSION(klon),INTENT(IN) :: t1, q1, u1, v1
+REAL,DIMENSION(klon,nbsrf),INTENT(IN) :: t2m, q2m, u10m, v10m
+REAL,DIMENSION(klon,nbsrf),INTENT(IN) :: ftsol, pctsrf
+REAL,DIMENSION(klon,klev+1),INTENT(IN) :: paprs 
+REAL,DIMENSION(klon),INTENT(IN) :: qsurf
+REAL,DIMENSION (klon),INTENT(OUT) :: zt2m_cor, zq2m_cor, zu10m_cor, zv10m_cor
+REAL,DIMENSION (klon),INTENT(OUT)  :: zrh2m_cor, zqsat2m_cor
+
+
+! local
+INTEGER i,nsrf
+REAL,DIMENSION (klon,nbsrf) :: t2m_cor, q2m_cor, u10m_cor, v10m_cor
+REAL                               :: zx_qs1, zcor1, zdelta1
+include "YOMCST.h"
+include "YOETHF.h"
+include "FCTTRE.h"
+!==================================================================
+! Correction of sub surface variables
+!==================================================================
+
+zrh2m_cor=0.
+zqsat2m_cor=0.
+
+DO nsrf=1,nbsrf
+   DO i=1,klon
+    t2m_cor(i,nsrf)=t2m(i,nsrf)
+    q2m_cor(i,nsrf)=q2m(i,nsrf)
+    u10m_cor(i,nsrf)=u10m(i,nsrf)
+    v10m_cor(i,nsrf)=v10m(i,nsrf)
+     IF(iflag_bug_t2m_stab_ipslcm61.EQ.-2.AND.q2m(i,nsrf).LT.0.) THEN
+      t2m_cor(i,nsrf)=MIN(t2m(i,nsrf),MAX(t1(i),ftsol(i,nsrf)))
+      t2m_cor(i,nsrf)=MAX(t2m_cor(i,nsrf),MIN(t1(i),ftsol(i,nsrf)))
+      q2m_cor(i,nsrf)=MIN(q2m(i,nsrf),MAX(q1(i),qsurf(i)))
+      q2m_cor(i,nsrf)=MAX(q2m_cor(i,nsrf),MIN(q1(i),qsurf(i)))
+      q2m_cor(i,nsrf)=MAX(q2m_cor(i,nsrf),0.)
+      u10m_cor(i,nsrf)=SIGN(MIN(ABS(u1(i)),ABS(u10m(i,nsrf))),u1(i))
+      v10m_cor(i,nsrf)=SIGN(MIN(ABS(v1(i)),ABS(v10m(i,nsrf))),v1(i))
+     ELSEIF(iflag_bug_t2m_stab_ipslcm61.EQ.-1.AND.(ftsol(i,nsrf).LE.t1(i).OR.q2m(i,nsrf).LT.0.)) THEN
+      t2m_cor(i,nsrf)=MIN(t2m(i,nsrf),MAX(t1(i),ftsol(i,nsrf)))
+      t2m_cor(i,nsrf)=MAX(t2m_cor(i,nsrf),MIN(t1(i),ftsol(i,nsrf)))
+      q2m_cor(i,nsrf)=MIN(q2m(i,nsrf),MAX(q1(i),qsurf(i)))
+      q2m_cor(i,nsrf)=MAX(q2m_cor(i,nsrf),MIN(q1(i),qsurf(i)))
+      q2m_cor(i,nsrf)=MAX(q2m_cor(i,nsrf),0.)
+      u10m_cor(i,nsrf)=SIGN(MIN(ABS(u1(i)),ABS(u10m(i,nsrf))),u1(i))
+      v10m_cor(i,nsrf)=SIGN(MIN(ABS(v1(i)),ABS(v10m(i,nsrf))),v1(i))
+     ELSEIF(iflag_bug_t2m_stab_ipslcm61.EQ.1.AND.ftsol(i,nsrf).LE.t1(i)) THEN
+      t2m_cor(i,nsrf)=MIN(t2m(i,nsrf),MAX(t1(i),ftsol(i,nsrf)))
+      t2m_cor(i,nsrf)=MAX(t2m_cor(i,nsrf),MIN(t1(i),ftsol(i,nsrf)))
+      q2m_cor(i,nsrf)=MIN(q2m(i,nsrf),MAX(q1(i),qsurf(i)))
+      q2m_cor(i,nsrf)=MAX(q2m_cor(i,nsrf),MIN(q1(i),qsurf(i)))
+      q2m_cor(i,nsrf)=MAX(q2m_cor(i,nsrf),0.)
+      u10m_cor(i,nsrf)=SIGN(MIN(ABS(u1(i)),ABS(u10m(i,nsrf))),u1(i))
+      v10m_cor(i,nsrf)=SIGN(MIN(ABS(v1(i)),ABS(v10m(i,nsrf))),v1(i))
+     ELSEIF(iflag_bug_t2m_stab_ipslcm61.EQ.0) THEN
+      t2m_cor(i,nsrf)=MIN(t2m(i,nsrf),MAX(t1(i),ftsol(i,nsrf)))
+      t2m_cor(i,nsrf)=MAX(t2m_cor(i,nsrf),MIN(t1(i),ftsol(i,nsrf)))
+      q2m_cor(i,nsrf)=MIN(q2m(i,nsrf),MAX(q1(i),qsurf(i)))
+      q2m_cor(i,nsrf)=MAX(q2m_cor(i,nsrf),MIN(q1(i),qsurf(i)))
+      q2m_cor(i,nsrf)=MAX(q2m_cor(i,nsrf),0.)
+      u10m_cor(i,nsrf)=SIGN(MIN(ABS(u1(i)),ABS(u10m(i,nsrf))),u1(i))
+      v10m_cor(i,nsrf)=SIGN(MIN(ABS(v1(i)),ABS(v10m(i,nsrf))),v1(i))
+     ENDIF
+!!!
+     zdelta1 = MAX(0.,SIGN(1., rtt-t2m_cor(i,nsrf) ))
+     zx_qs1  = r2es * FOEEW(t2m_cor(i,nsrf),zdelta1)/paprs(i,1)
+     zx_qs1  = MIN(0.5,zx_qs1)
+     zcor1   = 1./(1.-RETV*zx_qs1)
+     zx_qs1  = zx_qs1*zcor1
+     zrh2m_cor(i) = zrh2m_cor(i) + q2m_cor(i,nsrf)/zx_qs1 * pctsrf(i,nsrf)
+     zqsat2m_cor(i) = zqsat2m_cor(i) + zx_qs1  * pctsrf(i,nsrf)
+!!!
+   ENDDO
+ENDDO
+
+!==================================================================
+! Agregation of sub surfaces
+!==================================================================
+
+zt2m_cor=0.
+zq2m_cor=0.
+zu10m_cor=0.
+zv10m_cor=0.
+DO nsrf = 1, nbsrf
+   DO i = 1, klon
+      zt2m_cor(i)  = zt2m_cor(i)  + t2m_cor(i,nsrf)  * pctsrf(i,nsrf)
+      zq2m_cor(i)  = zq2m_cor(i)  + q2m_cor(i,nsrf)  * pctsrf(i,nsrf)
+      zu10m_cor(i) = zu10m_cor(i) + u10m_cor(i,nsrf) * pctsrf(i,nsrf)
+      zv10m_cor(i) = zv10m_cor(i) + v10m_cor(i,nsrf) * pctsrf(i,nsrf)
+   ENDDO
+ENDDO
+
+RETURN
+END
+
+
Index: DZ6/trunk/libf/phylmd/buffer_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/buffer_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,86 +1,0 @@
-MODULE buffer_mod
-
-PRIVATE
-  REAL,PARAMETER :: grow_factor=1.5
-
-  INTEGER, POINTER, SAVE :: buffer_i(:)
-  INTEGER,SAVE :: size_buffer_i = 0
-!$OMP THREADPRIVATE(buffer_i,size_buffer_i)
-
-  REAL,POINTER,SAVE      :: buffer_r(:)
-  INTEGER,SAVE :: size_buffer_r = 0 
-!$OMP THREADPRIVATE(buffer_r,size_buffer_r)
-  
-  LOGICAL,POINTER,SAVE   :: buffer_l(:)
-  INTEGER,SAVE :: size_buffer_l = 0
-!$OMP THREADPRIVATE(buffer_l,size_buffer_l)
-
-  CHARACTER,POINTER,SAVE :: buffer_c(:)
-  INTEGER,SAVE :: size_buffer_c = 0
-!$OMP THREADPRIVATE(buffer_c,size_buffer_c)
-
-INTERFACE get_buffer
-  MODULE PROCEDURE get_buffer_i, get_buffer_r, get_buffer_l, get_buffer_c
-END INTERFACE
-  
-PUBLIC :: get_buffer
-
-CONTAINS
-
-  SUBROUTINE get_buffer_i(buff,buff_size)
-  IMPLICIT NONE
-    INTEGER,POINTER    :: buff(:)
-    INTEGER,INTENT(IN) :: buff_size 
-
-    IF (buff_size>size_buffer_i) THEN
-      DEALLOCATE(buffer_i)
-      size_buffer_i=MAX(2,INT(size_buffer_i*grow_factor))
-      ALLOCATE(buffer_i(size_buffer_i))
-    ENDIF
-    
-    buff=>buffer_i
-  END SUBROUTINE get_buffer_i
-
-  SUBROUTINE get_buffer_r(buff,buff_size)
-  IMPLICIT NONE
-    REAL,POINTER       :: buff(:)
-    INTEGER,INTENT(IN) :: buff_size 
-
-    IF (buff_size>size_buffer_r) THEN
-      DEALLOCATE(buffer_r)
-      size_buffer_r=MAX(2,INT(size_buffer_r*grow_factor))
-      ALLOCATE(buffer_r(size_buffer_r))
-    ENDIF
-    
-    buff=>buffer_r
-  END SUBROUTINE get_buffer_r
-
-  SUBROUTINE get_buffer_l(buff,buff_size)
-  IMPLICIT NONE
-    LOGICAL,POINTER    :: buff(:)
-    INTEGER,INTENT(IN) :: buff_size 
-
-    IF (buff_size>size_buffer_l) THEN
-      DEALLOCATE(buffer_l)
-      size_buffer_l=MAX(2,INT(size_buffer_l*grow_factor))
-      ALLOCATE(buffer_l(size_buffer_l))
-    ENDIF
-    
-    buff=>buffer_l
-  END SUBROUTINE get_buffer_l
-  
-  SUBROUTINE get_buffer_c(buff,buff_size)
-  IMPLICIT NONE
-    CHARACTER,POINTER  :: buff(:)
-    INTEGER,INTENT(IN) :: buff_size 
-
-    IF (buff_size>size_buffer_c) THEN
-      DEALLOCATE(buffer_c)
-      size_buffer_c=MAX(2,INT(size_buffer_c*grow_factor))
-      ALLOCATE(buffer_c(size_buffer_c))
-    ENDIF
-    
-    buff=>buffer_c
-  END SUBROUTINE get_buffer_c
-  
-END MODULE buffer_mod
Index: /LMDZ6/trunk/libf/phylmd/buffer_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/buffer_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/buffer_mod.f90	(revision 5268)
@@ -0,0 +1,86 @@
+MODULE buffer_mod
+
+PRIVATE
+  REAL,PARAMETER :: grow_factor=1.5
+
+  INTEGER, POINTER, SAVE :: buffer_i(:)
+  INTEGER,SAVE :: size_buffer_i = 0
+!$OMP THREADPRIVATE(buffer_i,size_buffer_i)
+
+  REAL,POINTER,SAVE      :: buffer_r(:)
+  INTEGER,SAVE :: size_buffer_r = 0 
+!$OMP THREADPRIVATE(buffer_r,size_buffer_r)
+  
+  LOGICAL,POINTER,SAVE   :: buffer_l(:)
+  INTEGER,SAVE :: size_buffer_l = 0
+!$OMP THREADPRIVATE(buffer_l,size_buffer_l)
+
+  CHARACTER,POINTER,SAVE :: buffer_c(:)
+  INTEGER,SAVE :: size_buffer_c = 0
+!$OMP THREADPRIVATE(buffer_c,size_buffer_c)
+
+INTERFACE get_buffer
+  MODULE PROCEDURE get_buffer_i, get_buffer_r, get_buffer_l, get_buffer_c
+END INTERFACE
+  
+PUBLIC :: get_buffer
+
+CONTAINS
+
+  SUBROUTINE get_buffer_i(buff,buff_size)
+  IMPLICIT NONE
+    INTEGER,POINTER    :: buff(:)
+    INTEGER,INTENT(IN) :: buff_size 
+
+    IF (buff_size>size_buffer_i) THEN
+      DEALLOCATE(buffer_i)
+      size_buffer_i=MAX(2,INT(size_buffer_i*grow_factor))
+      ALLOCATE(buffer_i(size_buffer_i))
+    ENDIF
+    
+    buff=>buffer_i
+  END SUBROUTINE get_buffer_i
+
+  SUBROUTINE get_buffer_r(buff,buff_size)
+  IMPLICIT NONE
+    REAL,POINTER       :: buff(:)
+    INTEGER,INTENT(IN) :: buff_size 
+
+    IF (buff_size>size_buffer_r) THEN
+      DEALLOCATE(buffer_r)
+      size_buffer_r=MAX(2,INT(size_buffer_r*grow_factor))
+      ALLOCATE(buffer_r(size_buffer_r))
+    ENDIF
+    
+    buff=>buffer_r
+  END SUBROUTINE get_buffer_r
+
+  SUBROUTINE get_buffer_l(buff,buff_size)
+  IMPLICIT NONE
+    LOGICAL,POINTER    :: buff(:)
+    INTEGER,INTENT(IN) :: buff_size 
+
+    IF (buff_size>size_buffer_l) THEN
+      DEALLOCATE(buffer_l)
+      size_buffer_l=MAX(2,INT(size_buffer_l*grow_factor))
+      ALLOCATE(buffer_l(size_buffer_l))
+    ENDIF
+    
+    buff=>buffer_l
+  END SUBROUTINE get_buffer_l
+  
+  SUBROUTINE get_buffer_c(buff,buff_size)
+  IMPLICIT NONE
+    CHARACTER,POINTER  :: buff(:)
+    INTEGER,INTENT(IN) :: buff_size 
+
+    IF (buff_size>size_buffer_c) THEN
+      DEALLOCATE(buffer_c)
+      size_buffer_c=MAX(2,INT(size_buffer_c*grow_factor))
+      ALLOCATE(buffer_c(size_buffer_c))
+    ENDIF
+    
+    buff=>buffer_c
+  END SUBROUTINE get_buffer_c
+  
+END MODULE buffer_mod
Index: DZ6/trunk/libf/phylmd/cal_tools_m.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cal_tools_m.F90	(revision 5267)
+++ 	(revision )
@@ -1,89 +1,0 @@
-MODULE cal_tools_m
-
-  USE ioipsl, ONLY: ioconf_calendar, ioget_mon_len, lock_calendar,             &
-                     ioget_calendar, ioget_year_len
-
-CONTAINS
-
-!-------------------------------------------------------------------------------
-!
-FUNCTION year_len(y,cal_in)
-!
-!-------------------------------------------------------------------------------
-  IMPLICIT NONE
-!-------------------------------------------------------------------------------
-! Arguments:
-  INTEGER                                :: year_len
-  INTEGER,                    INTENT(IN) :: y
-  CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: cal_in
-!-------------------------------------------------------------------------------
-! Local variables:
-  CHARACTER(LEN=20) :: cal_lmdz
-!-------------------------------------------------------------------------------
-  !--- No specified calendar: we need lmdz days number for current year
-  IF(.NOT.PRESENT(cal_in)) THEN; year_len=ioget_year_len(y); RETURN; END IF
-
-  !--- Get the lmdz calendar to reset at the end of the function
-  CALL ioget_calendar(cal_lmdz)
-
-  !--- Unlock calendar and set it to wanted one
-  CALL lock_calendar(.FALSE.); CALL ioconf_calendar(TRIM(cal_in))
-
-  !--- Get the number of days in this year
-  year_len=ioget_year_len(y)
-
-  !--- Back to original calendar
-  CALL lock_calendar(.FALSE.); CALL ioconf_calendar(TRIM(cal_lmdz))
-
-END FUNCTION year_len
-!
-!-------------------------------------------------------------------------------
-
-
-!-------------------------------------------------------------------------------
-!
-FUNCTION mid_month(y,cal_in)
-!
-!-------------------------------------------------------------------------------
-  IMPLICIT NONE
-!-------------------------------------------------------------------------------
-! Arguments:
-  INTEGER,                    INTENT(IN) :: y           ! year
-  CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: cal_in      ! calendar
-  REAL,                    DIMENSION(14) :: mid_month   ! mid-bins times
-!-------------------------------------------------------------------------------
-! Local variables:
-  CHARACTER(LEN=20)      :: cal_lmdz          ! lmdz current calendar
-  INTEGER, DIMENSION(14) :: tlen              ! months lengths (days)
-  INTEGER                :: m                 ! months counter
-  INTEGER                :: nd                ! number of days
-!-------------------------------------------------------------------------------
-  IF(PRESENT(cal_in)) THEN
-    CALL ioget_calendar(cal_lmdz)             !--- Keep track of lmdz calendar
-    CALL lock_calendar(.FALSE.)               !--- Unlock calendar
-    CALL ioconf_calendar(TRIM(cal_in))        !--- Change calendar to "cal_in"
-  END IF
-
-  !--- Get the length of each month
-  tlen(1 )=ioget_mon_len(y-1,12)
-  DO m=1,12; tlen(m+1)=ioget_mon_len(y,m); END DO
-  tlen(14)=ioget_mon_len(y+1, 1)
-
-  !--- Mid-bins times
-  mid_month(1)=-0.5*REAL(tlen(1))
-  DO m=2,14; mid_month(m)=mid_month(m-1)+0.5*REAL(tlen(m-1)+tlen(m)); END DO
-
-  IF(PRESENT(cal_in)) THEN
-    CALL lock_calendar(.FALSE.)               !--- Unlock calendar
-    CALL ioconf_calendar(TRIM(cal_lmdz))      !--- Restore original calendar
-  END IF
-
-END FUNCTION mid_month
-!
-!-------------------------------------------------------------------------------
-
-
-END MODULE cal_tools_m
-!
-!*******************************************************************************
-
Index: /LMDZ6/trunk/libf/phylmd/cal_tools_m.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cal_tools_m.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/cal_tools_m.f90	(revision 5268)
@@ -0,0 +1,89 @@
+MODULE cal_tools_m
+
+  USE ioipsl, ONLY: ioconf_calendar, ioget_mon_len, lock_calendar,             &
+                     ioget_calendar, ioget_year_len
+
+CONTAINS
+
+!-------------------------------------------------------------------------------
+!
+FUNCTION year_len(y,cal_in)
+!
+!-------------------------------------------------------------------------------
+  IMPLICIT NONE
+!-------------------------------------------------------------------------------
+! Arguments:
+  INTEGER                                :: year_len
+  INTEGER,                    INTENT(IN) :: y
+  CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: cal_in
+!-------------------------------------------------------------------------------
+! Local variables:
+  CHARACTER(LEN=20) :: cal_lmdz
+!-------------------------------------------------------------------------------
+  !--- No specified calendar: we need lmdz days number for current year
+  IF(.NOT.PRESENT(cal_in)) THEN; year_len=ioget_year_len(y); RETURN; END IF
+
+  !--- Get the lmdz calendar to reset at the end of the function
+  CALL ioget_calendar(cal_lmdz)
+
+  !--- Unlock calendar and set it to wanted one
+  CALL lock_calendar(.FALSE.); CALL ioconf_calendar(TRIM(cal_in))
+
+  !--- Get the number of days in this year
+  year_len=ioget_year_len(y)
+
+  !--- Back to original calendar
+  CALL lock_calendar(.FALSE.); CALL ioconf_calendar(TRIM(cal_lmdz))
+
+END FUNCTION year_len
+!
+!-------------------------------------------------------------------------------
+
+
+!-------------------------------------------------------------------------------
+!
+FUNCTION mid_month(y,cal_in)
+!
+!-------------------------------------------------------------------------------
+  IMPLICIT NONE
+!-------------------------------------------------------------------------------
+! Arguments:
+  INTEGER,                    INTENT(IN) :: y           ! year
+  CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: cal_in      ! calendar
+  REAL,                    DIMENSION(14) :: mid_month   ! mid-bins times
+!-------------------------------------------------------------------------------
+! Local variables:
+  CHARACTER(LEN=20)      :: cal_lmdz          ! lmdz current calendar
+  INTEGER, DIMENSION(14) :: tlen              ! months lengths (days)
+  INTEGER                :: m                 ! months counter
+  INTEGER                :: nd                ! number of days
+!-------------------------------------------------------------------------------
+  IF(PRESENT(cal_in)) THEN
+    CALL ioget_calendar(cal_lmdz)             !--- Keep track of lmdz calendar
+    CALL lock_calendar(.FALSE.)               !--- Unlock calendar
+    CALL ioconf_calendar(TRIM(cal_in))        !--- Change calendar to "cal_in"
+  END IF
+
+  !--- Get the length of each month
+  tlen(1 )=ioget_mon_len(y-1,12)
+  DO m=1,12; tlen(m+1)=ioget_mon_len(y,m); END DO
+  tlen(14)=ioget_mon_len(y+1, 1)
+
+  !--- Mid-bins times
+  mid_month(1)=-0.5*REAL(tlen(1))
+  DO m=2,14; mid_month(m)=mid_month(m-1)+0.5*REAL(tlen(m-1)+tlen(m)); END DO
+
+  IF(PRESENT(cal_in)) THEN
+    CALL lock_calendar(.FALSE.)               !--- Unlock calendar
+    CALL ioconf_calendar(TRIM(cal_lmdz))      !--- Restore original calendar
+  END IF
+
+END FUNCTION mid_month
+!
+!-------------------------------------------------------------------------------
+
+
+END MODULE cal_tools_m
+!
+!*******************************************************************************
+
Index: DZ6/trunk/libf/phylmd/calbeta.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/calbeta.F90	(revision 5267)
+++ 	(revision )
@@ -1,113 +1,0 @@
-!
-! $Header$
-!
-SUBROUTINE calbeta(dtime,indice,knon,snow,qsol, &
-     vbeta,vcal,vdif)
-
-  USE dimphy
-  USE indice_sol_mod
-
-  IMPLICIT none
-
-  INCLUDE "flux_arp.h"
-
-!======================================================================
-! Auteur(s): Z.X. Li (LMD/CNRS) (adaptation du GCM au LMD)
-! date: 19940414
-!======================================================================
-!
-! Calculer quelques parametres pour appliquer la couche limite
-! ------------------------------------------------------------ 
-! Variables d'entrees
-!****************************************************************************************
-  REAL, INTENT(IN)                   :: dtime
-  INTEGER, INTENT(IN)                :: indice
-  INTEGER, INTENT(IN)                :: knon
-  REAL, DIMENSION(klon), INTENT(IN)  :: snow
-  REAL, DIMENSION(klon), INTENT(IN)  :: qsol
-
-  
-! Variables de sorties
-!****************************************************************************************
-  REAL, DIMENSION(klon), INTENT(OUT) :: vbeta
-  REAL, DIMENSION(klon), INTENT(OUT) :: vcal
-  REAL, DIMENSION(klon), INTENT(OUT) :: vdif
-
-! Variables locales
-!****************************************************************************************
-  REAL, PARAMETER :: tau_gl=86400.0*5.0 ! temps de relaxation pour la glace de mer
-!cc      PARAMETER (tau_gl=86400.0*30.0)
-  REAL, PARAMETER :: mx_eau_sol=150.0
-  REAL, PARAMETER :: calsol=1.0/(2.5578E+06*0.15)
-  REAL, PARAMETER :: calsno=1.0/(2.3867E+06*0.15)
-  REAL, PARAMETER :: calice=1.0/(5.1444E+06*0.15)
-  
-  INTEGER         :: i
-
-!****************************************************************************************  
-   
-  vbeta(:) = 0.0
-  vcal(:) = 0.0
-  vdif(:) = 0.0
-  
-  IF (indice.EQ.is_oce) THEN
-     DO i = 1, knon
-        vcal(i)   = 0.0
-        vbeta(i)  = 1.0
-        vdif(i) = 0.0
-     ENDDO
-  ENDIF
-  
-  IF (indice.EQ.is_sic) THEN
-     DO i = 1, knon
-        vcal(i) = calice
-        IF (snow(i) .GT. 0.0) vcal(i) = calsno
-        vbeta(i)  = 1.0
-        vdif(i) = 1.0/tau_gl
-!          vdif(i) = calice/tau_gl ! c'etait une erreur
-     ENDDO
-  ENDIF
-  
-  IF (indice.EQ.is_ter) THEN
-     DO i = 1, knon
-        vcal(i) = calsol
-        IF (snow(i) .GT. 0.0) vcal(i) = calsno
-        vbeta(i)  = MIN(2.0*qsol(i)/mx_eau_sol, 1.0)
-        vdif(i) = 0.0
-     ENDDO
-  ENDIF
-  
-  IF (indice.EQ.is_lic) THEN
-     DO i = 1, knon
-        vcal(i) = calice
-        IF (snow(i) .GT. 0.0) vcal(i) = calsno
-        vbeta(i)  = 1.0
-        vdif(i) = 0.0
-     ENDDO
-  ENDIF
-
-  ! EV: when beta is prescribed for 1D cases:
-  IF (knon.EQ.1 .AND. ok_prescr_beta) THEN
-     DO i = 1, knon
-          vbeta(i)=betaevap
-      ENDDO
-  ENDIF
-  
-END SUBROUTINE calbeta
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
Index: /LMDZ6/trunk/libf/phylmd/calbeta.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/calbeta.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/calbeta.f90	(revision 5268)
@@ -0,0 +1,113 @@
+!
+! $Header$
+!
+SUBROUTINE calbeta(dtime,indice,knon,snow,qsol, &
+     vbeta,vcal,vdif)
+
+  USE dimphy
+  USE indice_sol_mod
+
+  IMPLICIT none
+
+  INCLUDE "flux_arp.h"
+
+!======================================================================
+! Auteur(s): Z.X. Li (LMD/CNRS) (adaptation du GCM au LMD)
+! date: 19940414
+!======================================================================
+!
+! Calculer quelques parametres pour appliquer la couche limite
+! ------------------------------------------------------------ 
+! Variables d'entrees
+!****************************************************************************************
+  REAL, INTENT(IN)                   :: dtime
+  INTEGER, INTENT(IN)                :: indice
+  INTEGER, INTENT(IN)                :: knon
+  REAL, DIMENSION(klon), INTENT(IN)  :: snow
+  REAL, DIMENSION(klon), INTENT(IN)  :: qsol
+
+  
+! Variables de sorties
+!****************************************************************************************
+  REAL, DIMENSION(klon), INTENT(OUT) :: vbeta
+  REAL, DIMENSION(klon), INTENT(OUT) :: vcal
+  REAL, DIMENSION(klon), INTENT(OUT) :: vdif
+
+! Variables locales
+!****************************************************************************************
+  REAL, PARAMETER :: tau_gl=86400.0*5.0 ! temps de relaxation pour la glace de mer
+!cc      PARAMETER (tau_gl=86400.0*30.0)
+  REAL, PARAMETER :: mx_eau_sol=150.0
+  REAL, PARAMETER :: calsol=1.0/(2.5578E+06*0.15)
+  REAL, PARAMETER :: calsno=1.0/(2.3867E+06*0.15)
+  REAL, PARAMETER :: calice=1.0/(5.1444E+06*0.15)
+  
+  INTEGER         :: i
+
+!****************************************************************************************  
+   
+  vbeta(:) = 0.0
+  vcal(:) = 0.0
+  vdif(:) = 0.0
+  
+  IF (indice.EQ.is_oce) THEN
+     DO i = 1, knon
+        vcal(i)   = 0.0
+        vbeta(i)  = 1.0
+        vdif(i) = 0.0
+     ENDDO
+  ENDIF
+  
+  IF (indice.EQ.is_sic) THEN
+     DO i = 1, knon
+        vcal(i) = calice
+        IF (snow(i) .GT. 0.0) vcal(i) = calsno
+        vbeta(i)  = 1.0
+        vdif(i) = 1.0/tau_gl
+!          vdif(i) = calice/tau_gl ! c'etait une erreur
+     ENDDO
+  ENDIF
+  
+  IF (indice.EQ.is_ter) THEN
+     DO i = 1, knon
+        vcal(i) = calsol
+        IF (snow(i) .GT. 0.0) vcal(i) = calsno
+        vbeta(i)  = MIN(2.0*qsol(i)/mx_eau_sol, 1.0)
+        vdif(i) = 0.0
+     ENDDO
+  ENDIF
+  
+  IF (indice.EQ.is_lic) THEN
+     DO i = 1, knon
+        vcal(i) = calice
+        IF (snow(i) .GT. 0.0) vcal(i) = calsno
+        vbeta(i)  = 1.0
+        vdif(i) = 0.0
+     ENDDO
+  ENDIF
+
+  ! EV: when beta is prescribed for 1D cases:
+  IF (knon.EQ.1 .AND. ok_prescr_beta) THEN
+     DO i = 1, knon
+          vbeta(i)=betaevap
+      ENDDO
+  ENDIF
+  
+END SUBROUTINE calbeta
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
Index: DZ6/trunk/libf/phylmd/calbeta_clim.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/calbeta_clim.F90	(revision 5267)
+++ 	(revision )
@@ -1,72 +1,0 @@
-!
-! $Header: /home/cvsroot/LMDZ4/libf/phylmd/calbeta.F90,v 1.2 2007/06/22 12:49:51
-! fairhead Exp $
-!
-
-SUBROUTINE calbeta_clim(klon,time,lat_radian,beta)
-
-  !======================================================================
-  ! Auteur(s): A.K. TRAORE
-  !======================================================================
-
-  !USE phys_local_var_mod, ONLY : ideal_beta !pour faire la variable dans le
-  ! physiq.f pour des sorties directes de beta
-
-  USE phys_cal_mod, only: year_len
-  USE print_control_mod, ONLY: prt_level
-
-  implicit none
-  integer klon,nt,j,it
-  real logbeta(klon),pi
-  real lat(klon),lat_radian(klon)
-  integer time
-  real time_radian
-  real lat_sahel,beta(klon)
-  real lat_nord,lat_sud
-
-  !==============================================
-
-  pi=2.*asin(1.)
-  beta=0.
-
-  !calcul des cordonnees
-
-  ! print*,'LATITUDES BETA ',lat_radian
-  time_radian=(time+15.)*2.*pi / year_len
-
-  if (prt_level >= 1) print *, 'time_radian time', time_radian, time
-
-  lat(:)=180.*lat_radian(:)/pi !lat(:)=lat_radian(:)
-
-  lat_sahel=-5*sin(time_radian)+13
-  lat_nord=lat_sahel+25.
-  lat_sud=lat_sahel-25.
-  do j=1,klon
-     !===========
-     if (lat(j) < 5. ) then
-
-        logbeta(j)=0.2*(lat(j)-lat_sud)-1.6
-        beta(j)=10**(logbeta(j))
-        beta(j)=max(beta(j),0.03)
-        beta(j)=min(beta(j),0.22)
-        ! print*,'j,lat,lat_radian,beta',j,lat(j),lat_radian(j),beta(j)
-        !===========
-     elseif (lat(j) < 22.) then !lat(j)<22.
-
-        logbeta(j)=-0.25*(lat(j)-lat_sahel)-1.6
-        beta(j)=10**(logbeta(j))
-        beta(j)=max(beta(j),1.e-2)
-        beta(j)=min(beta(j),0.22)
-        ! print*,'j,lat,lat_radian,beta',j,lat(j),lat_radian(j),beta(j)
-        !===========
-     else
-        logbeta(j)=0.25*(lat(j)-lat_nord)-1.
-        beta(j)=10**(logbeta(j))
-        beta(j)=max(beta(j),1.e-2)
-        beta(j)=min(beta(j),0.25)
-        ! print*,'j,lat,lat_radian,beta',j,lat(j),lat_radian(j),beta(j)
-     endif
-     !===========
-  enddo
-
-end SUBROUTINE calbeta_clim
Index: /LMDZ6/trunk/libf/phylmd/calbeta_clim.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/calbeta_clim.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/calbeta_clim.f90	(revision 5268)
@@ -0,0 +1,72 @@
+!
+! $Header: /home/cvsroot/LMDZ4/libf/phylmd/calbeta.F90,v 1.2 2007/06/22 12:49:51
+! fairhead Exp $
+!
+
+SUBROUTINE calbeta_clim(klon,time,lat_radian,beta)
+
+  !======================================================================
+  ! Auteur(s): A.K. TRAORE
+  !======================================================================
+
+  !USE phys_local_var_mod, ONLY : ideal_beta !pour faire la variable dans le
+  ! physiq.f pour des sorties directes de beta
+
+  USE phys_cal_mod, only: year_len
+  USE print_control_mod, ONLY: prt_level
+
+  implicit none
+  integer klon,nt,j,it
+  real logbeta(klon),pi
+  real lat(klon),lat_radian(klon)
+  integer time
+  real time_radian
+  real lat_sahel,beta(klon)
+  real lat_nord,lat_sud
+
+  !==============================================
+
+  pi=2.*asin(1.)
+  beta=0.
+
+  !calcul des cordonnees
+
+  ! print*,'LATITUDES BETA ',lat_radian
+  time_radian=(time+15.)*2.*pi / year_len
+
+  if (prt_level >= 1) print *, 'time_radian time', time_radian, time
+
+  lat(:)=180.*lat_radian(:)/pi !lat(:)=lat_radian(:)
+
+  lat_sahel=-5*sin(time_radian)+13
+  lat_nord=lat_sahel+25.
+  lat_sud=lat_sahel-25.
+  do j=1,klon
+     !===========
+     if (lat(j) < 5. ) then
+
+        logbeta(j)=0.2*(lat(j)-lat_sud)-1.6
+        beta(j)=10**(logbeta(j))
+        beta(j)=max(beta(j),0.03)
+        beta(j)=min(beta(j),0.22)
+        ! print*,'j,lat,lat_radian,beta',j,lat(j),lat_radian(j),beta(j)
+        !===========
+     elseif (lat(j) < 22.) then !lat(j)<22.
+
+        logbeta(j)=-0.25*(lat(j)-lat_sahel)-1.6
+        beta(j)=10**(logbeta(j))
+        beta(j)=max(beta(j),1.e-2)
+        beta(j)=min(beta(j),0.22)
+        ! print*,'j,lat,lat_radian,beta',j,lat(j),lat_radian(j),beta(j)
+        !===========
+     else
+        logbeta(j)=0.25*(lat(j)-lat_nord)-1.
+        beta(j)=10**(logbeta(j))
+        beta(j)=max(beta(j),1.e-2)
+        beta(j)=min(beta(j),0.25)
+        ! print*,'j,lat,lat_radian,beta',j,lat(j),lat_radian(j),beta(j)
+     endif
+     !===========
+  enddo
+
+end SUBROUTINE calbeta_clim
Index: DZ6/trunk/libf/phylmd/calcul_fluxs_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/calcul_fluxs_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,329 +1,0 @@
-!
-! $Id$
-!
-MODULE calcul_fluxs_mod
-
-  IMPLICIT NONE
-
-CONTAINS
-  SUBROUTINE calcul_fluxs( knon, nisurf, dtime, &
-       tsurf, p1lay, cal, beta, cdragh, cdragq, ps, &
-       precip_rain, precip_snow, snow, qsurf, &
-       radsol, dif_grnd, t1lay, q1lay, u1lay, v1lay, gustiness, &
-       fqsat, petAcoef, peqAcoef, petBcoef, peqBcoef, &
-       tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l, &
-       sens_prec_liq, sens_prec_sol, lat_prec_liq, lat_prec_sol, rhoa)
- 
-    
-    USE dimphy, ONLY : klon
-    USE indice_sol_mod
-    use sens_heat_rain_m, only: sens_heat_rain
-
-    INCLUDE "clesphys.h"
-
-! Cette routine calcule les fluxs en h et q a l'interface et eventuellement
-! une temperature de surface (au cas ou ok_veget = false)
-!
-! L. Fairhead 4/2000
-!
-! input:
-!   knon         nombre de points a traiter
-!   nisurf       surface a traiter
-!   tsurf        temperature de surface
-!   p1lay        pression 1er niveau (milieu de couche)
-!   cal          capacite calorifique du sol
-!   beta         evap reelle
-!   cdragh       coefficient d'echange temperature
-!   cdragq       coefficient d'echange evaporation
-!   ps           pression au sol
-!   precip_rain  precipitations liquides
-!   precip_snow  precipitations solides
-!   snow         champs hauteur de neige
-!   runoff       runoff en cas de trop plein
-!   petAcoef     coeff. A de la resolution de la CL pour t
-!   peqAcoef     coeff. A de la resolution de la CL pour q
-!   petBcoef     coeff. B de la resolution de la CL pour t
-!   peqBcoef     coeff. B de la resolution de la CL pour q
-!   radsol       rayonnement net aus sol (LW + SW)
-!   dif_grnd     coeff. diffusion vers le sol profond
-!
-! output:
-!   tsurf_new    temperature au sol
-!   qsurf        humidite de l'air au dessus du sol
-!   fluxsens     flux de chaleur sensible
-!   fluxlat      flux de chaleur latente
-!   dflux_s      derivee du flux de chaleur sensible / Ts
-!   dflux_l      derivee du flux de chaleur latente  / Ts
-!   sens_prec_liq flux sensible lié aux echanges de precipitations liquides
-!   sens_prec_sol                                    precipitations solides
-!   lat_prec_liq  flux latent lié aux echanges de precipitations liquides
-!   lat_prec_sol                                  precipitations solides
-
-    INCLUDE "YOETHF.h"
-    INCLUDE "FCTTRE.h"
-    INCLUDE "YOMCST.h"
-
-! Parametres d'entree
-!****************************************************************************************
-    INTEGER, INTENT(IN)                  :: knon, nisurf
-    REAL   , INTENT(IN)                  :: dtime
-    REAL, DIMENSION(klon), INTENT(IN)    :: petAcoef, peqAcoef
-    REAL, DIMENSION(klon), INTENT(IN)    :: petBcoef, peqBcoef
-    REAL, DIMENSION(klon), INTENT(IN)    :: ps, q1lay
-    REAL, DIMENSION(klon), INTENT(IN)    :: tsurf, p1lay, cal, beta, cdragh,cdragq
-    REAL, DIMENSION(klon), INTENT(IN)    :: precip_rain, precip_snow
-    REAL, DIMENSION(klon), INTENT(IN)    :: radsol, dif_grnd
-    REAL, DIMENSION(klon), INTENT(IN)    :: t1lay, u1lay, v1lay,gustiness
-    REAL,                  INTENT(IN)    :: fqsat ! correction factor on qsat (generally 0.98 over salty water, 1 everywhere else)
-
-    real, intent(in), optional:: rhoa(:) ! (knon)
-    ! density of moist air  (kg / m3)
-
-! Parametres entree-sorties
-!****************************************************************************************
-    REAL, DIMENSION(klon), INTENT(INOUT) :: snow  ! snow pas utile
-
-! Parametres sorties
-!****************************************************************************************
-    REAL, DIMENSION(klon), INTENT(OUT)   :: qsurf
-    REAL, DIMENSION(klon), INTENT(OUT)   :: tsurf_new, evap, fluxsens, fluxlat
-    REAL, DIMENSION(klon), INTENT(OUT)   :: dflux_s, dflux_l
-    REAL, intent(out), OPTIONAL:: sens_prec_liq(:), sens_prec_sol(:) ! (knon)
-    REAL, DIMENSION(klon), OPTIONAL      :: lat_prec_liq, lat_prec_sol
-
-! Variables locales
-!****************************************************************************************
-    INTEGER                              :: i
-    REAL, DIMENSION(klon)                :: zx_mh, zx_nh, zx_oh
-    REAL, DIMENSION(klon)                :: zx_mq, zx_nq, zx_oq
-    REAL, DIMENSION(klon)                :: zx_pkh, zx_dq_s_dt, zx_qsat
-    REAL, DIMENSION(klon)                :: zx_sl, zx_coefh, zx_coefq, zx_wind
-    REAL, DIMENSION(klon)                :: d_ts
-    REAL                                 :: zdelta, zcvm5, zx_qs, zcor, zx_dq_s_dh
-    REAL                                 :: qsat_new, q1_new
-    REAL, PARAMETER                      :: t_grnd = 271.35, t_coup = 273.15
-    REAL, PARAMETER                      :: max_eau_sol = 150.0
-    CHARACTER (len = 20)                 :: modname = 'calcul_fluxs'
-    LOGICAL                              :: fonte_neige
-    LOGICAL, SAVE                        :: check = .FALSE.
-    !$OMP THREADPRIVATE(check)
-
-! End definition
-!****************************************************************************************
-
-    IF (check) WRITE(*,*)'Entree ', modname,' surface = ',nisurf
-    
-    IF (check) THEN
-       WRITE(*,*)' radsol (min, max)', &
-            MINVAL(radsol(1:knon)), MAXVAL(radsol(1:knon))
-    ENDIF
-  
-! Traitement neige et humidite du sol
-!****************************************************************************************
-!
-!!$  WRITE(*,*)'test calcul_flux, surface ', nisurf
-!!PB test
-!!$    if (nisurf == is_oce) then
-!!$      snow = 0.
-!!$      qsol = max_eau_sol
-!!$    else
-!!$      where (precip_snow > 0.) snow = snow + (precip_snow * dtime)
-!!$      where (snow > epsilon(snow)) snow = max(0.0, snow - (evap * dtime))
-!!$!      snow = max(0.0, snow + (precip_snow - evap) * dtime)
-!!$      where (precip_rain > 0.) qsol = qsol + (precip_rain - evap) * dtime
-!!$    endif 
-!!$    IF (nisurf /= is_ter) qsol = max_eau_sol
-
-
-! 
-! Initialisation
-!****************************************************************************************
-    evap = 0.
-    fluxsens=0.
-    fluxlat=0.
-    dflux_s = 0.
-    dflux_l = 0.
-    if (PRESENT(lat_prec_liq)) lat_prec_liq = 0.
-    if (PRESENT(lat_prec_sol)) lat_prec_sol = 0.
-!
-! zx_qs = qsat en kg/kg
-!****************************************************************************************
-    DO i = 1, knon
-       zx_pkh(i) = (ps(i)/ps(i))**RKAPPA
-       IF (thermcep) THEN
-          zdelta=MAX(0.,SIGN(1.,rtt-tsurf(i)))
-          zcvm5 = R5LES*RLVTT*(1.-zdelta) + R5IES*RLSTT*zdelta
-          zcvm5 = zcvm5 / RCPD / (1.0+RVTMP2*q1lay(i))
-          zx_qs= r2es * FOEEW(tsurf(i),zdelta)/ps(i)
-          zx_qs=MIN(0.5,zx_qs)
-          zcor=1./(1.-retv*zx_qs)
-          zx_qs=zx_qs*zcor
-          zx_dq_s_dh = FOEDE(tsurf(i),zdelta,zcvm5,zx_qs,zcor) &
-               /RLVTT / zx_pkh(i)
-       ELSE
-          IF (tsurf(i).LT.t_coup) THEN
-             zx_qs = qsats(tsurf(i)) / ps(i)
-             zx_dq_s_dh = dqsats(tsurf(i),zx_qs)/RLVTT &
-                  / zx_pkh(i)
-          ELSE
-             zx_qs = qsatl(tsurf(i)) / ps(i)
-             zx_dq_s_dh = dqsatl(tsurf(i),zx_qs)/RLVTT &
-                  / zx_pkh(i)
-          ENDIF
-       ENDIF
-       zx_dq_s_dt(i) = RCPD * zx_pkh(i) * zx_dq_s_dh
-       zx_qsat(i) = zx_qs
-       zx_wind(i)=min_wind_speed+SQRT(gustiness(i)+u1lay(i)**2+v1lay(i)**2)
-       zx_coefh(i) = cdragh(i) * zx_wind(i) * p1lay(i)/(RD*t1lay(i))
-       zx_coefq(i) = cdragq(i) * zx_wind(i) * p1lay(i)/(RD*t1lay(i))
-!      zx_wind(i)=min_wind_speed+SQRT(gustiness(i)+u1lay(i)**2+v1lay(i)**2) &
-!                * p1lay(i)/(RD*t1lay(i))
-!      zx_coefh(i) = cdragh(i) * zx_wind(i)
-!      zx_coefq(i) = cdragq(i) * zx_wind(i)
-    ENDDO
-
-
-! === Calcul de la temperature de surface ===
-! zx_sl = chaleur latente d'evaporation ou de sublimation
-!****************************************************************************************
-
-    DO i = 1, knon
-       zx_sl(i) = RLVTT
-       IF (tsurf(i) .LT. RTT) zx_sl(i) = RLSTT
-    ENDDO
-    
-
-    DO i = 1, knon
-! Q
-       zx_oq(i) = 1. - (beta(i) * zx_coefq(i) * peqBcoef(i) * dtime)
-       zx_mq(i) = beta(i) * zx_coefq(i) * &
-            (peqAcoef(i) -             &
-! conv num avec precedente version
-            fqsat * zx_qsat(i) + fqsat * zx_dq_s_dt(i) * tsurf(i))  &
-!           fqsat * ( zx_qsat(i) - zx_dq_s_dt(i) * tsurf(i)) ) &
-            / zx_oq(i)
-       zx_nq(i) = beta(i) * zx_coefq(i) * (- fqsat * zx_dq_s_dt(i)) &
-            / zx_oq(i)
-       
-! H
-       zx_oh(i) = 1. - (zx_coefh(i) * petBcoef(i) * dtime)
-       zx_mh(i) = zx_coefh(i) * petAcoef(i) / zx_oh(i)
-       zx_nh(i) = - (zx_coefh(i) * RCPD * zx_pkh(i))/ zx_oh(i)
-     
-! Tsurface
-       tsurf_new(i) = (tsurf(i) + cal(i)/(RCPD * zx_pkh(i)) * dtime * &
-            (radsol(i) + zx_mh(i) + zx_sl(i) * zx_mq(i)) & 
-            + dif_grnd(i) * t_grnd * dtime)/ &
-            ( 1. - dtime * cal(i)/(RCPD * zx_pkh(i)) * ( &
-            zx_nh(i) + zx_sl(i) * zx_nq(i)) &  
-            + dtime * dif_grnd(i))
-
-!
-! Y'a-t-il fonte de neige?
-!
-!    fonte_neige = (nisurf /= is_oce) .AND. &
-!     & (snow(i) > epsfra .OR. nisurf == is_sic .OR. nisurf == is_lic) &
-!     & .AND. (tsurf_new(i) >= RTT)
-!    if (fonte_neige) tsurf_new(i) = RTT  
-       d_ts(i) = tsurf_new(i) - tsurf(i)
-!    zx_h_ts(i) = tsurf_new(i) * RCPD * zx_pkh(i)
-!    zx_q_0(i) = zx_qsat(i) + zx_dq_s_dt(i) * d_ts(i)
-
-!== flux_q est le flux de vapeur d'eau: kg/(m**2 s)  positive vers bas
-!== flux_t est le flux de cpt (energie sensible): j/(m**2 s)
-       evap(i) = - zx_mq(i) - zx_nq(i) * tsurf_new(i) 
-       fluxlat(i) = - evap(i) * zx_sl(i)
-       fluxsens(i) = zx_mh(i) + zx_nh(i) * tsurf_new(i)
-       
-! Derives des flux dF/dTs (W m-2 K-1):
-       dflux_s(i) = zx_nh(i)
-       dflux_l(i) = (zx_sl(i) * zx_nq(i))
-
-! Nouvelle valeure de l'humidite au dessus du sol
-       qsat_new=zx_qsat(i) + zx_dq_s_dt(i) * d_ts(i)
-       q1_new = peqAcoef(i) - peqBcoef(i)*evap(i)*dtime
-       qsurf(i)=q1_new*(1.-beta(i)) + beta(i)*qsat_new
-!
-! en cas de fonte de neige
-!
-!    if (fonte_neige) then
-!      bilan_f = radsol(i) + fluxsens(i) - (zx_sl(i) * evap (i)) - &
-!     &          dif_grnd(i) * (tsurf_new(i) - t_grnd) - &
-!     &          RCPD * (zx_pkh(i))/cal(i)/dtime * (tsurf_new(i) - tsurf(i))
-!      bilan_f = max(0., bilan_f)
-!      fq_fonte = bilan_f / zx_sl(i)
-!      snow(i) = max(0., snow(i) - fq_fonte * dtime)
-!      qsol(i) = qsol(i) + (fq_fonte * dtime)
-!    endif
-!!$    if (nisurf == is_ter)  &
-!!$     &  run_off(i) = run_off(i) + max(qsol(i) - max_eau_sol, 0.0)
-!!$    qsol(i) = min(qsol(i), max_eau_sol) 
-!
-! calcul de l'enthalpie des precipitations liquides et solides
-       if (PRESENT(sens_prec_liq)) sens_prec_liq(i) &
-            = - sens_heat_rain(precip_rain(i) + precip_snow(i), t1lay(i), &
-            q1lay(i), rhoa(i), rlvtt, tsurf_new(i), ps(i))
-       if (PRESENT(sens_prec_sol)) sens_prec_sol(i) = 0.
-       ! On calcule par rapport a T=0
-       !! sens_prec_liq(i) = rcw * (t1lay(i) - RTT) * precip_rain(i)
-       !! sens_prec_sol(i) = rcs * (t1lay(i) - RTT) * precip_snow(i)
-
-       if (PRESENT(lat_prec_liq))                    &
-         lat_prec_liq(i) =  precip_rain(i) * (RLVTT - RLVTT) 
-       if (PRESENT(lat_prec_sol))                    &
-         lat_prec_sol(i) = precip_snow(i) * (RLSTT - RLVTT)
-    ENDDO
-
-    
-!**************************************************************************
-!
-  END SUBROUTINE calcul_fluxs
-!
-!****************************************************************************************
-!
-  SUBROUTINE calcul_flux_wind(knon, dtime, &
-       u0, v0, u1, v1, gustiness, cdrag_m, &
-       AcoefU, AcoefV, BcoefU, BcoefV, &
-       p1lay, t1lay, &
-       flux_u1, flux_v1)
-
-    USE dimphy
-    INCLUDE "YOMCST.h"
-    INCLUDE "clesphys.h"
-
-! Input arguments
-!****************************************************************************************
-    INTEGER, INTENT(IN)                  :: knon
-    REAL, INTENT(IN)                     :: dtime
-    REAL, DIMENSION(klon), INTENT(IN)    :: u0, v0  ! u and v at niveau 0
-    REAL, DIMENSION(klon), INTENT(IN)    :: u1, v1, gustiness  ! u and v at niveau 1
-    REAL, DIMENSION(klon), INTENT(IN)    :: cdrag_m ! cdrag pour momentum
-    REAL, DIMENSION(klon), INTENT(IN)    :: AcoefU, AcoefV, BcoefU, BcoefV
-    REAL, DIMENSION(klon), INTENT(IN)    :: p1lay   ! pression 1er niveau (milieu de couche)
-    REAL, DIMENSION(klon), INTENT(IN)    :: t1lay   ! temperature 
-! Output arguments
-!****************************************************************************************
-    REAL, DIMENSION(klon), INTENT(OUT)   :: flux_u1
-    REAL, DIMENSION(klon), INTENT(OUT)   :: flux_v1
-
-! Local variables
-!****************************************************************************************
-    INTEGER                              :: i
-    REAL                                 :: mod_wind, buf
-
-!****************************************************************************************
-! Calculate the surface flux
-!
-!****************************************************************************************
-    DO i=1,knon
-       mod_wind = min_wind_speed + SQRT(gustiness(i)+(u1(i) - u0(i))**2 + (v1(i)-v0(i))**2)
-       buf = cdrag_m(i) * mod_wind * p1lay(i)/(RD*t1lay(i))
-       flux_u1(i) = (AcoefU(i) - u0(i)) / (1/buf - BcoefU(i)*dtime )
-       flux_v1(i) = (AcoefV(i) - v0(i)) / (1/buf - BcoefV(i)*dtime )
-    END DO
-
-  END SUBROUTINE calcul_flux_wind
-!
-!****************************************************************************************
-!
-END MODULE calcul_fluxs_mod
Index: /LMDZ6/trunk/libf/phylmd/calcul_fluxs_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/calcul_fluxs_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/calcul_fluxs_mod.f90	(revision 5268)
@@ -0,0 +1,329 @@
+!
+! $Id$
+!
+MODULE calcul_fluxs_mod
+
+  IMPLICIT NONE
+
+CONTAINS
+  SUBROUTINE calcul_fluxs( knon, nisurf, dtime, &
+       tsurf, p1lay, cal, beta, cdragh, cdragq, ps, &
+       precip_rain, precip_snow, snow, qsurf, &
+       radsol, dif_grnd, t1lay, q1lay, u1lay, v1lay, gustiness, &
+       fqsat, petAcoef, peqAcoef, petBcoef, peqBcoef, &
+       tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l, &
+       sens_prec_liq, sens_prec_sol, lat_prec_liq, lat_prec_sol, rhoa)
+ 
+    
+    USE dimphy, ONLY : klon
+    USE indice_sol_mod
+    use sens_heat_rain_m, only: sens_heat_rain
+
+    INCLUDE "clesphys.h"
+
+! Cette routine calcule les fluxs en h et q a l'interface et eventuellement
+! une temperature de surface (au cas ou ok_veget = false)
+!
+! L. Fairhead 4/2000
+!
+! input:
+!   knon         nombre de points a traiter
+!   nisurf       surface a traiter
+!   tsurf        temperature de surface
+!   p1lay        pression 1er niveau (milieu de couche)
+!   cal          capacite calorifique du sol
+!   beta         evap reelle
+!   cdragh       coefficient d'echange temperature
+!   cdragq       coefficient d'echange evaporation
+!   ps           pression au sol
+!   precip_rain  precipitations liquides
+!   precip_snow  precipitations solides
+!   snow         champs hauteur de neige
+!   runoff       runoff en cas de trop plein
+!   petAcoef     coeff. A de la resolution de la CL pour t
+!   peqAcoef     coeff. A de la resolution de la CL pour q
+!   petBcoef     coeff. B de la resolution de la CL pour t
+!   peqBcoef     coeff. B de la resolution de la CL pour q
+!   radsol       rayonnement net aus sol (LW + SW)
+!   dif_grnd     coeff. diffusion vers le sol profond
+!
+! output:
+!   tsurf_new    temperature au sol
+!   qsurf        humidite de l'air au dessus du sol
+!   fluxsens     flux de chaleur sensible
+!   fluxlat      flux de chaleur latente
+!   dflux_s      derivee du flux de chaleur sensible / Ts
+!   dflux_l      derivee du flux de chaleur latente  / Ts
+!   sens_prec_liq flux sensible lié aux echanges de precipitations liquides
+!   sens_prec_sol                                    precipitations solides
+!   lat_prec_liq  flux latent lié aux echanges de precipitations liquides
+!   lat_prec_sol                                  precipitations solides
+
+    INCLUDE "YOETHF.h"
+    INCLUDE "FCTTRE.h"
+    INCLUDE "YOMCST.h"
+
+! Parametres d'entree
+!****************************************************************************************
+    INTEGER, INTENT(IN)                  :: knon, nisurf
+    REAL   , INTENT(IN)                  :: dtime
+    REAL, DIMENSION(klon), INTENT(IN)    :: petAcoef, peqAcoef
+    REAL, DIMENSION(klon), INTENT(IN)    :: petBcoef, peqBcoef
+    REAL, DIMENSION(klon), INTENT(IN)    :: ps, q1lay
+    REAL, DIMENSION(klon), INTENT(IN)    :: tsurf, p1lay, cal, beta, cdragh,cdragq
+    REAL, DIMENSION(klon), INTENT(IN)    :: precip_rain, precip_snow
+    REAL, DIMENSION(klon), INTENT(IN)    :: radsol, dif_grnd
+    REAL, DIMENSION(klon), INTENT(IN)    :: t1lay, u1lay, v1lay,gustiness
+    REAL,                  INTENT(IN)    :: fqsat ! correction factor on qsat (generally 0.98 over salty water, 1 everywhere else)
+
+    real, intent(in), optional:: rhoa(:) ! (knon)
+    ! density of moist air  (kg / m3)
+
+! Parametres entree-sorties
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(INOUT) :: snow  ! snow pas utile
+
+! Parametres sorties
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(OUT)   :: qsurf
+    REAL, DIMENSION(klon), INTENT(OUT)   :: tsurf_new, evap, fluxsens, fluxlat
+    REAL, DIMENSION(klon), INTENT(OUT)   :: dflux_s, dflux_l
+    REAL, intent(out), OPTIONAL:: sens_prec_liq(:), sens_prec_sol(:) ! (knon)
+    REAL, DIMENSION(klon), OPTIONAL      :: lat_prec_liq, lat_prec_sol
+
+! Variables locales
+!****************************************************************************************
+    INTEGER                              :: i
+    REAL, DIMENSION(klon)                :: zx_mh, zx_nh, zx_oh
+    REAL, DIMENSION(klon)                :: zx_mq, zx_nq, zx_oq
+    REAL, DIMENSION(klon)                :: zx_pkh, zx_dq_s_dt, zx_qsat
+    REAL, DIMENSION(klon)                :: zx_sl, zx_coefh, zx_coefq, zx_wind
+    REAL, DIMENSION(klon)                :: d_ts
+    REAL                                 :: zdelta, zcvm5, zx_qs, zcor, zx_dq_s_dh
+    REAL                                 :: qsat_new, q1_new
+    REAL, PARAMETER                      :: t_grnd = 271.35, t_coup = 273.15
+    REAL, PARAMETER                      :: max_eau_sol = 150.0
+    CHARACTER (len = 20)                 :: modname = 'calcul_fluxs'
+    LOGICAL                              :: fonte_neige
+    LOGICAL, SAVE                        :: check = .FALSE.
+    !$OMP THREADPRIVATE(check)
+
+! End definition
+!****************************************************************************************
+
+    IF (check) WRITE(*,*)'Entree ', modname,' surface = ',nisurf
+    
+    IF (check) THEN
+       WRITE(*,*)' radsol (min, max)', &
+            MINVAL(radsol(1:knon)), MAXVAL(radsol(1:knon))
+    ENDIF
+  
+! Traitement neige et humidite du sol
+!****************************************************************************************
+!
+!!$  WRITE(*,*)'test calcul_flux, surface ', nisurf
+!!PB test
+!!$    if (nisurf == is_oce) then
+!!$      snow = 0.
+!!$      qsol = max_eau_sol
+!!$    else
+!!$      where (precip_snow > 0.) snow = snow + (precip_snow * dtime)
+!!$      where (snow > epsilon(snow)) snow = max(0.0, snow - (evap * dtime))
+!!$!      snow = max(0.0, snow + (precip_snow - evap) * dtime)
+!!$      where (precip_rain > 0.) qsol = qsol + (precip_rain - evap) * dtime
+!!$    endif 
+!!$    IF (nisurf /= is_ter) qsol = max_eau_sol
+
+
+! 
+! Initialisation
+!****************************************************************************************
+    evap = 0.
+    fluxsens=0.
+    fluxlat=0.
+    dflux_s = 0.
+    dflux_l = 0.
+    if (PRESENT(lat_prec_liq)) lat_prec_liq = 0.
+    if (PRESENT(lat_prec_sol)) lat_prec_sol = 0.
+!
+! zx_qs = qsat en kg/kg
+!****************************************************************************************
+    DO i = 1, knon
+       zx_pkh(i) = (ps(i)/ps(i))**RKAPPA
+       IF (thermcep) THEN
+          zdelta=MAX(0.,SIGN(1.,rtt-tsurf(i)))
+          zcvm5 = R5LES*RLVTT*(1.-zdelta) + R5IES*RLSTT*zdelta
+          zcvm5 = zcvm5 / RCPD / (1.0+RVTMP2*q1lay(i))
+          zx_qs= r2es * FOEEW(tsurf(i),zdelta)/ps(i)
+          zx_qs=MIN(0.5,zx_qs)
+          zcor=1./(1.-retv*zx_qs)
+          zx_qs=zx_qs*zcor
+          zx_dq_s_dh = FOEDE(tsurf(i),zdelta,zcvm5,zx_qs,zcor) &
+               /RLVTT / zx_pkh(i)
+       ELSE
+          IF (tsurf(i).LT.t_coup) THEN
+             zx_qs = qsats(tsurf(i)) / ps(i)
+             zx_dq_s_dh = dqsats(tsurf(i),zx_qs)/RLVTT &
+                  / zx_pkh(i)
+          ELSE
+             zx_qs = qsatl(tsurf(i)) / ps(i)
+             zx_dq_s_dh = dqsatl(tsurf(i),zx_qs)/RLVTT &
+                  / zx_pkh(i)
+          ENDIF
+       ENDIF
+       zx_dq_s_dt(i) = RCPD * zx_pkh(i) * zx_dq_s_dh
+       zx_qsat(i) = zx_qs
+       zx_wind(i)=min_wind_speed+SQRT(gustiness(i)+u1lay(i)**2+v1lay(i)**2)
+       zx_coefh(i) = cdragh(i) * zx_wind(i) * p1lay(i)/(RD*t1lay(i))
+       zx_coefq(i) = cdragq(i) * zx_wind(i) * p1lay(i)/(RD*t1lay(i))
+!      zx_wind(i)=min_wind_speed+SQRT(gustiness(i)+u1lay(i)**2+v1lay(i)**2) &
+!                * p1lay(i)/(RD*t1lay(i))
+!      zx_coefh(i) = cdragh(i) * zx_wind(i)
+!      zx_coefq(i) = cdragq(i) * zx_wind(i)
+    ENDDO
+
+
+! === Calcul de la temperature de surface ===
+! zx_sl = chaleur latente d'evaporation ou de sublimation
+!****************************************************************************************
+
+    DO i = 1, knon
+       zx_sl(i) = RLVTT
+       IF (tsurf(i) .LT. RTT) zx_sl(i) = RLSTT
+    ENDDO
+    
+
+    DO i = 1, knon
+! Q
+       zx_oq(i) = 1. - (beta(i) * zx_coefq(i) * peqBcoef(i) * dtime)
+       zx_mq(i) = beta(i) * zx_coefq(i) * &
+            (peqAcoef(i) -             &
+! conv num avec precedente version
+            fqsat * zx_qsat(i) + fqsat * zx_dq_s_dt(i) * tsurf(i))  &
+!           fqsat * ( zx_qsat(i) - zx_dq_s_dt(i) * tsurf(i)) ) &
+            / zx_oq(i)
+       zx_nq(i) = beta(i) * zx_coefq(i) * (- fqsat * zx_dq_s_dt(i)) &
+            / zx_oq(i)
+       
+! H
+       zx_oh(i) = 1. - (zx_coefh(i) * petBcoef(i) * dtime)
+       zx_mh(i) = zx_coefh(i) * petAcoef(i) / zx_oh(i)
+       zx_nh(i) = - (zx_coefh(i) * RCPD * zx_pkh(i))/ zx_oh(i)
+     
+! Tsurface
+       tsurf_new(i) = (tsurf(i) + cal(i)/(RCPD * zx_pkh(i)) * dtime * &
+            (radsol(i) + zx_mh(i) + zx_sl(i) * zx_mq(i)) & 
+            + dif_grnd(i) * t_grnd * dtime)/ &
+            ( 1. - dtime * cal(i)/(RCPD * zx_pkh(i)) * ( &
+            zx_nh(i) + zx_sl(i) * zx_nq(i)) &  
+            + dtime * dif_grnd(i))
+
+!
+! Y'a-t-il fonte de neige?
+!
+!    fonte_neige = (nisurf /= is_oce) .AND. &
+!     & (snow(i) > epsfra .OR. nisurf == is_sic .OR. nisurf == is_lic) &
+!     & .AND. (tsurf_new(i) >= RTT)
+!    if (fonte_neige) tsurf_new(i) = RTT  
+       d_ts(i) = tsurf_new(i) - tsurf(i)
+!    zx_h_ts(i) = tsurf_new(i) * RCPD * zx_pkh(i)
+!    zx_q_0(i) = zx_qsat(i) + zx_dq_s_dt(i) * d_ts(i)
+
+!== flux_q est le flux de vapeur d'eau: kg/(m**2 s)  positive vers bas
+!== flux_t est le flux de cpt (energie sensible): j/(m**2 s)
+       evap(i) = - zx_mq(i) - zx_nq(i) * tsurf_new(i) 
+       fluxlat(i) = - evap(i) * zx_sl(i)
+       fluxsens(i) = zx_mh(i) + zx_nh(i) * tsurf_new(i)
+       
+! Derives des flux dF/dTs (W m-2 K-1):
+       dflux_s(i) = zx_nh(i)
+       dflux_l(i) = (zx_sl(i) * zx_nq(i))
+
+! Nouvelle valeure de l'humidite au dessus du sol
+       qsat_new=zx_qsat(i) + zx_dq_s_dt(i) * d_ts(i)
+       q1_new = peqAcoef(i) - peqBcoef(i)*evap(i)*dtime
+       qsurf(i)=q1_new*(1.-beta(i)) + beta(i)*qsat_new
+!
+! en cas de fonte de neige
+!
+!    if (fonte_neige) then
+!      bilan_f = radsol(i) + fluxsens(i) - (zx_sl(i) * evap (i)) - &
+!     &          dif_grnd(i) * (tsurf_new(i) - t_grnd) - &
+!     &          RCPD * (zx_pkh(i))/cal(i)/dtime * (tsurf_new(i) - tsurf(i))
+!      bilan_f = max(0., bilan_f)
+!      fq_fonte = bilan_f / zx_sl(i)
+!      snow(i) = max(0., snow(i) - fq_fonte * dtime)
+!      qsol(i) = qsol(i) + (fq_fonte * dtime)
+!    endif
+!!$    if (nisurf == is_ter)  &
+!!$     &  run_off(i) = run_off(i) + max(qsol(i) - max_eau_sol, 0.0)
+!!$    qsol(i) = min(qsol(i), max_eau_sol) 
+!
+! calcul de l'enthalpie des precipitations liquides et solides
+       if (PRESENT(sens_prec_liq)) sens_prec_liq(i) &
+            = - sens_heat_rain(precip_rain(i) + precip_snow(i), t1lay(i), &
+            q1lay(i), rhoa(i), rlvtt, tsurf_new(i), ps(i))
+       if (PRESENT(sens_prec_sol)) sens_prec_sol(i) = 0.
+       ! On calcule par rapport a T=0
+       !! sens_prec_liq(i) = rcw * (t1lay(i) - RTT) * precip_rain(i)
+       !! sens_prec_sol(i) = rcs * (t1lay(i) - RTT) * precip_snow(i)
+
+       if (PRESENT(lat_prec_liq))                    &
+         lat_prec_liq(i) =  precip_rain(i) * (RLVTT - RLVTT) 
+       if (PRESENT(lat_prec_sol))                    &
+         lat_prec_sol(i) = precip_snow(i) * (RLSTT - RLVTT)
+    ENDDO
+
+    
+!**************************************************************************
+!
+  END SUBROUTINE calcul_fluxs
+!
+!****************************************************************************************
+!
+  SUBROUTINE calcul_flux_wind(knon, dtime, &
+       u0, v0, u1, v1, gustiness, cdrag_m, &
+       AcoefU, AcoefV, BcoefU, BcoefV, &
+       p1lay, t1lay, &
+       flux_u1, flux_v1)
+
+    USE dimphy
+    INCLUDE "YOMCST.h"
+    INCLUDE "clesphys.h"
+
+! Input arguments
+!****************************************************************************************
+    INTEGER, INTENT(IN)                  :: knon
+    REAL, INTENT(IN)                     :: dtime
+    REAL, DIMENSION(klon), INTENT(IN)    :: u0, v0  ! u and v at niveau 0
+    REAL, DIMENSION(klon), INTENT(IN)    :: u1, v1, gustiness  ! u and v at niveau 1
+    REAL, DIMENSION(klon), INTENT(IN)    :: cdrag_m ! cdrag pour momentum
+    REAL, DIMENSION(klon), INTENT(IN)    :: AcoefU, AcoefV, BcoefU, BcoefV
+    REAL, DIMENSION(klon), INTENT(IN)    :: p1lay   ! pression 1er niveau (milieu de couche)
+    REAL, DIMENSION(klon), INTENT(IN)    :: t1lay   ! temperature 
+! Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(OUT)   :: flux_u1
+    REAL, DIMENSION(klon), INTENT(OUT)   :: flux_v1
+
+! Local variables
+!****************************************************************************************
+    INTEGER                              :: i
+    REAL                                 :: mod_wind, buf
+
+!****************************************************************************************
+! Calculate the surface flux
+!
+!****************************************************************************************
+    DO i=1,knon
+       mod_wind = min_wind_speed + SQRT(gustiness(i)+(u1(i) - u0(i))**2 + (v1(i)-v0(i))**2)
+       buf = cdrag_m(i) * mod_wind * p1lay(i)/(RD*t1lay(i))
+       flux_u1(i) = (AcoefU(i) - u0(i)) / (1/buf - BcoefU(i)*dtime )
+       flux_v1(i) = (AcoefV(i) - v0(i)) / (1/buf - BcoefV(i)*dtime )
+    END DO
+
+  END SUBROUTINE calcul_flux_wind
+!
+!****************************************************************************************
+!
+END MODULE calcul_fluxs_mod
Index: DZ6/trunk/libf/phylmd/call_ini_replay.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/call_ini_replay.F90	(revision 5267)
+++ 	(revision )
@@ -1,4 +1,0 @@
-   subroutine call_ini_replay
-   stop 'In call_ini_replay : You should run replay_equip.sh before runing replay[13]d'
-   return
-   end
Index: /LMDZ6/trunk/libf/phylmd/call_ini_replay.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/call_ini_replay.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/call_ini_replay.f90	(revision 5268)
@@ -0,0 +1,4 @@
+   subroutine call_ini_replay
+   stop 'In call_ini_replay : You should run replay_equip.sh before runing replay[13]d'
+   return
+   end
Index: DZ6/trunk/libf/phylmd/call_param_replay.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/call_param_replay.F90	(revision 5267)
+++ 	(revision )
@@ -1,5 +1,0 @@
-   subroutine call_param_replay(ngrid,nlay)
-   integer,intent(in) :: ngrid,nlay
-   stop 'In call_param_replay : You should run replay_equip.sh before runing replay[13]d'
-   return
-   end
Index: /LMDZ6/trunk/libf/phylmd/call_param_replay.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/call_param_replay.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/call_param_replay.f90	(revision 5268)
@@ -0,0 +1,5 @@
+   subroutine call_param_replay(ngrid,nlay)
+   integer,intent(in) :: ngrid,nlay
+   stop 'In call_param_replay : You should run replay_equip.sh before runing replay[13]d'
+   return
+   end
Index: DZ6/trunk/libf/phylmd/calwake.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/calwake.F90	(revision 5267)
+++ 	(revision )
@@ -1,335 +1,0 @@
-
-! $Id$
-
-SUBROUTINE calwake(iflag_wake_tend, paprs, pplay, dtime, &
-    t, q, omgb, &
-    dt_dwn, dq_dwn, m_dwn, m_up, dt_a, dq_a, wgen, &
-    sigd, Cin, &
-    wake_deltat, wake_deltaq, wake_s, awake_s, wake_dens, awake_dens, &
-    wake_dth, wake_h, &
-    wake_pe, wake_fip, wake_gfl, &
-    dt_wake, dq_wake, wake_k, t_x, q_x, wake_omgbdth, &
-    wake_dp_omgb, &
-    wake_dtke, wake_dqke, &
-    wake_omg, wake_dp_deltomg, &
-    wake_spread, wake_cstar, wake_d_deltat_gw, &
-    wake_ddeltat, wake_ddeltaq, wake_ds, awake_ds, wake_ddens, awake_ddens)
-  ! **************************************************************
-  ! *
-  ! CALWAKE                                                     *
-  ! interface avec le schema de calcul de la poche    *
-  ! froide                                            *
-  ! *
-  ! written by   : CHERUY Frederique, 13/03/2000, 10.31.05      *
-  ! modified by :  ROEHRIG Romain,    01/30/2007                *
-  ! **************************************************************
-
-  USE dimphy
-  USE phys_state_var_mod, ONLY: pctsrf
-  USE indice_sol_mod, ONLY: is_oce
-  USE print_control_mod, ONLY: mydebug=>debug , lunout, prt_level
-  USE lmdz_wake, ONLY : wake
-  IMPLICIT NONE
-  ! ======================================================================
-  include "YOMCST.h"
-
-  ! Arguments
-  ! ----------
-  ! Input
-  ! ----
-  INTEGER,                       INTENT (IN)         :: iflag_wake_tend
-  REAL,                          INTENT (IN)         :: dtime
-  REAL, DIMENSION(klon, klev),   INTENT (IN)         :: pplay
-  REAL, DIMENSION(klon, klev+1), INTENT (IN)         :: paprs
-  REAL, DIMENSION(klon, klev),   INTENT (IN)         :: t, q, omgb
-  REAL, DIMENSION(klon, klev),   INTENT (IN)         :: dt_dwn, dq_dwn
-  REAL, DIMENSION(klon, klev),   INTENT (IN)         :: m_up, m_dwn
-  REAL, DIMENSION(klon, klev),   INTENT (IN)         :: dt_a, dq_a
-  REAL, DIMENSION(klon),         INTENT (IN)         :: wgen
-  REAL, DIMENSION(klon),         INTENT (IN)         :: sigd
-  REAL, DIMENSION(klon),         INTENT (IN)         :: Cin
-  ! Input/Output
-  ! ------------
-  REAL, DIMENSION(klon, klev),   INTENT (INOUT)      :: wake_deltat, wake_deltaq
-  REAL, DIMENSION(klon),         INTENT (INOUT)      :: wake_s, awake_s
-  REAL, DIMENSION(klon),         INTENT (INOUT)      :: wake_dens, awake_dens
-  ! Output
-  ! ------
-  REAL, DIMENSION(klon, klev),   INTENT (OUT)        :: dt_wake, dq_wake
-!!jyg  REAL, DIMENSION(klon),         INTENT (OUT)        :: wake_k
-  INTEGER, DIMENSION(klon),      INTENT (OUT)        :: wake_k
-  REAL, DIMENSION(klon, klev),   INTENT (OUT)        :: wake_d_deltat_gw
-  REAL, DIMENSION(klon),         INTENT (OUT)        :: wake_h
-  REAL, DIMENSION(klon, klev),   INTENT (OUT)        :: wake_dth
-  REAL, DIMENSION(klon),         INTENT (OUT)        :: wake_pe, wake_fip, wake_gfl
-  REAL, DIMENSION(klon, klev),   INTENT (OUT)        :: t_x, q_x
-  REAL, DIMENSION(klon, klev),   INTENT (OUT)        :: wake_omgbdth, wake_dp_omgb
-  REAL, DIMENSION(klon, klev),   INTENT (OUT)        :: wake_dtke, wake_dqke
-  REAL, DIMENSION(klon, klev),   INTENT (OUT)        :: wake_omg, wake_dp_deltomg
-  REAL, DIMENSION(klon, klev),   INTENT (OUT)        :: wake_spread
-  REAL, DIMENSION(klon),         INTENT (OUT)        :: wake_cstar
-  REAL, DIMENSION(klon, klev),   INTENT (OUT)        :: wake_ddeltat, wake_ddeltaq
-  REAL, DIMENSION(klon),         INTENT (OUT)        :: wake_ds, awake_ds, wake_ddens, awake_ddens
-
-
-  ! Variable internes
-  ! -----------------
-  LOGICAL, SAVE                                      :: first = .TRUE.
-  !$OMP THREADPRIVATE(first)
-  INTEGER                                            :: i, l
-  INTEGER, DIMENSION(klon)                           :: znatsurf    ! 0 if pctsrf(is_oce)>0.1; 1 else.
-  REAL                                               :: aire
-  REAL, DIMENSION(klon, klev)                        :: p,  pi
-  REAL, DIMENSION(klon, klev+1)                      ::  ph
-  REAL, DIMENSION(klon, klev)                        ::  omgbe
-  REAL, DIMENSION(klon, klev)                        :: te, qe
-  REAL, DIMENSION(klon, klev)                        :: dtdwn, dqdwn
-  REAL, DIMENSION(klon, klev)                        :: dta, dqa
-  REAL, DIMENSION(klon, klev)                        :: amdwn, amup
-  REAL, DIMENSION(klon, klev)                        :: dtw, dqw, dth
-  REAL, DIMENSION(klon, klev)                        :: dtls, dqls
-  REAL, DIMENSION(klon, klev)                        :: tx, qx
-  REAL, DIMENSION(klon)                              :: hw, wape, fip, gfl
-  REAL, DIMENSION(klon)                              :: sigmaw, asigmaw, wdens, awdens
-  REAL, DIMENSION(klon, klev)                        :: omgbdth
-  REAL, DIMENSION(klon, klev)                        :: dp_omgb
-  REAL, DIMENSION(klon, klev)                        :: dtke, dqke
-  REAL, DIMENSION(klon, klev)                        :: omg
-  REAL, DIMENSION(klon, klev)                        :: dp_deltomg, spread
-  REAL, DIMENSION(klon)                              :: cstar
-  REAL, DIMENSION(klon)                              :: sigd0
-  INTEGER, DIMENSION(klon)                           :: ktopw
-  REAL, DIMENSION(klon, klev)                        :: d_deltat_gw
-  REAL, DIMENSION(klon, klev)                        :: d_deltatw, d_deltaqw
-  REAL, DIMENSION(klon)                              :: d_sigmaw, d_asigmaw, d_wdens, d_awdens
-
-  REAL                                               :: rdcp
-
-
-  IF (prt_level >= 10) THEN
-    print *, '-> calwake, wake_s, awake_s, wgen input ', wake_s(1), awake_s(1), wgen(1)
-  ENDIF
-
-  rdcp = 1./3.5
-
-  znatsurf(:) = 0
-  DO i = 1,klon
-    IF (pctsrf(i,is_oce) < 0.1) znatsurf(i) = 1
-  ENDDO
-
-
-  ! -----------------------------------------------------------
-  ! IM 290108     DO 999 i=1,klon   ! a vectoriser
-  ! ----------------------------------------------------------
-
-
-  DO l = 1, klev
-    DO i = 1, klon
-      p(i, l) = pplay(i, l)
-      ph(i, l) = paprs(i, l)
-      pi(i, l) = (pplay(i,l)/100000.)**rdcp
-
-      te(i, l) = t(i, l)
-      qe(i, l) = q(i, l)
-      omgbe(i, l) = omgb(i, l)
-
-      dtdwn(i, l) = dt_dwn(i, l)
-      dqdwn(i, l) = dq_dwn(i, l)
-      dta(i, l) = dt_a(i, l)
-      dqa(i, l) = dq_a(i, l)
-    END DO
-  END DO
-
-!----------------------------------------------------------------
-!         Initialize tendencies to zero
-!----------------------------------------------------------------
-dtls(:,:) = 0.
-dqls(:,:) = 0.
-d_deltat_gw(:,:) = 0.
-d_deltatw(:,:) = 0.
-d_deltaqw(:,:) = 0.
-d_sigmaw(:) = 0.
-d_asigmaw(:) = 0.
-d_wdens(:) = 0.
-d_awdens(:) = 0.
-!
-
-  DO i = 1, klon
-    sigd0(i) = sigd(i)
-  END DO
-  ! print*, 'sigd0,sigd', sigd0, sigd(i)
-  DO i = 1, klon
-    ph(i, klev+1) = 0.
-  END DO
-
-!!jyg!  DO i = 1, klon                  
-!!jyg!    ktopw(i) = NINT(wake_k(i))    
-!!jyg!  END DO                          
-
-  DO i = 1, klon
-    hw(i) = wake_h(i)
-  END DO
-!
-!    Make a copy of state variables
-  DO l = 1, klev
-    DO i = 1, klon
-      dtw(i, l) = wake_deltat(i, l)
-      dqw(i, l) = wake_deltaq(i, l)
-    END DO
-  END DO
-
-  DO i = 1, klon
-    sigmaw(i)  = wake_s(i)
-    asigmaw(i) = awake_s(i)
-  END DO
-
-  DO i = 1, klon
-    wdens(i) = max(0., wake_dens(i))
-    awdens(i) = max(0., awake_dens(i))
-  END DO
-
-  ! fkc les flux de masses sont evalues aux niveaux et valent 0 a la surface
-  ! fkc  on veut le flux de masse au milieu des couches
-
-  DO l = 1, klev - 1
-    DO i = 1, klon
-      amdwn(i, l) = 0.5*(m_dwn(i,l)+m_dwn(i,l+1))
-      amdwn(i, l) = (m_dwn(i,l+1))
-    END DO
-  END DO
-
-  ! au sommet le flux de masse est nul
-
-  DO i = 1, klon
-    amdwn(i, klev) = 0.5*m_dwn(i, klev)
-  END DO
-
-  DO l = 1, klev
-    DO i = 1, klon
-      amup(i, l) = m_up(i, l)
-    END DO
-  END DO
-
-
-
-  CALL wake(klon,klev,znatsurf, p, ph, pi, dtime, &
-    te, qe, omgbe, &
-    dtdwn, dqdwn, amdwn, amup, dta, dqa, wgen, &
-    sigd0, Cin, &
-    dtw, dqw, sigmaw, asigmaw, wdens, awdens, &                      ! state variables
-    dth, hw, wape, fip, gfl, &
-    dtls, dqls, ktopw, omgbdth, dp_omgb, tx, qx, &
-    dtke, dqke, omg, dp_deltomg, spread, cstar, &
-    d_deltat_gw, &
-    d_deltatw, d_deltaqw, d_sigmaw, d_asigmaw, d_wdens, d_awdens)      ! tendencies
-
-!
-  DO l = 1, klev
-    DO i = 1, klon
-      IF (ktopw(i)>0) THEN
-        wake_d_deltat_gw(i, l) = d_deltat_gw(i, l)
-        wake_omgbdth(i, l) = omgbdth(i, l)
-        wake_dp_omgb(i, l) = dp_omgb(i, l)
-        wake_dtke(i, l) = dtke(i, l)
-        wake_dqke(i, l) = dqke(i, l)
-        wake_omg(i, l) = omg(i, l)
-        wake_dp_deltomg(i, l) = dp_deltomg(i, l)
-        wake_spread(i, l) = spread(i, l)
-        wake_dth(i, l) = dth(i, l)
-        dt_wake(i, l) = dtls(i, l)*dtime         ! derivative -> tendency
-        dq_wake(i, l) = dqls(i, l)*dtime         ! derivative -> tendency
-        t_x(i, l) = tx(i, l)
-        q_x(i, l) = qx(i, l)
-      ELSE
-        wake_d_deltat_gw(i, l) = 0.
-        wake_omgbdth(i, l) = 0.
-        wake_dp_omgb(i, l) = 0.
-        wake_dtke(i, l) = 0.
-        wake_dqke(i, l) = 0.
-        wake_omg(i, l) = 0.
-        wake_dp_deltomg(i, l) = 0.
-        wake_spread(i, l) = 0.
-        wake_dth(i, l) = 0.
-        dt_wake(i, l) = 0.
-        dq_wake(i, l) = 0.
-        t_x(i, l) = te(i, l)
-        q_x(i, l) = qe(i, l)
-      END IF
-    END DO
-  END DO
-
-  DO i = 1, klon
-    wake_h(i) = hw(i)
-    wake_pe(i) = wape(i)
-    wake_fip(i) = fip(i)
-    wake_gfl(i) = gfl(i)
-    wake_k(i) = ktopw(i)
-    wake_cstar(i) = cstar(i)
-  END DO
-
-!  Tendencies of state variables
-  DO l = 1, klev
-    DO i = 1, klon
-      IF (ktopw(i)>0) THEN
-        wake_ddeltat(i, l) = d_deltatw(i, l)*dtime
-        wake_ddeltaq(i, l) = d_deltaqw(i, l)*dtime
-      ELSE
-        wake_ddeltat(i, l) = -wake_deltat(i, l)
-        wake_ddeltaq(i, l) = -wake_deltaq(i, l)
-      END IF
-    END DO
-  END DO
-  DO i = 1, klon
-    IF (ktopw(i)>0) THEN
-      wake_ds(i) = d_sigmaw(i)*dtime
-      awake_ds(i) = d_asigmaw(i)*dtime
-      awake_ddens(i) = d_awdens(i)*dtime
-      wake_ddens(i) = d_wdens(i)*dtime
-    ELSE
-      wake_ds(i)    = -wake_s(i)
-      awake_ds(i)   = -awake_s(i)
-      wake_ddens(i) = -wake_dens(i)
-      awake_ddens(i)= -awake_dens(i)
-    END IF
-  END DO
-!
-
-!jyg<  
-  IF (iflag_wake_tend .EQ. 0) THEN
-!  Update State variables
-    DO l = 1, klev
-      DO i = 1, klon
-        IF (ktopw(i)>0) THEN
-          wake_deltat(i, l) = dtw(i, l)
-          wake_deltaq(i, l) = dqw(i, l)
-        ELSE
-          wake_deltat(i, l) = 0.
-          wake_deltaq(i, l) = 0.
-        END IF
-      END DO
-    END DO
-    DO i = 1, klon
-      wake_s(i) = sigmaw(i)
-      awake_s(i) = asigmaw(i)
-      awake_dens(i) = awdens(i)
-      wake_dens(i) = wdens(i)
-    END DO
-  ENDIF  ! (iflag_wake_tend .EQ. 0)
-!
-  IF (first) THEN
-    DO i = 1,klon
-      IF (wake_dens(i) < -1.) THEN
-        wake_dens(i) = wdens(i)
-      ENDIF
-    ENDDO
-    first=.false.
-  ENDIF  ! (first)
-!>jyg
-  IF (prt_level >= 10) THEN
-    print *, 'calwake ->, wake_s, awake_s ', wake_s(1), awake_s(1)
-  ENDIF
-
-  RETURN
-END SUBROUTINE calwake
-
-
Index: /LMDZ6/trunk/libf/phylmd/calwake.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/calwake.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/calwake.f90	(revision 5268)
@@ -0,0 +1,335 @@
+
+! $Id$
+
+SUBROUTINE calwake(iflag_wake_tend, paprs, pplay, dtime, &
+    t, q, omgb, &
+    dt_dwn, dq_dwn, m_dwn, m_up, dt_a, dq_a, wgen, &
+    sigd, Cin, &
+    wake_deltat, wake_deltaq, wake_s, awake_s, wake_dens, awake_dens, &
+    wake_dth, wake_h, &
+    wake_pe, wake_fip, wake_gfl, &
+    dt_wake, dq_wake, wake_k, t_x, q_x, wake_omgbdth, &
+    wake_dp_omgb, &
+    wake_dtke, wake_dqke, &
+    wake_omg, wake_dp_deltomg, &
+    wake_spread, wake_cstar, wake_d_deltat_gw, &
+    wake_ddeltat, wake_ddeltaq, wake_ds, awake_ds, wake_ddens, awake_ddens)
+  ! **************************************************************
+  ! *
+  ! CALWAKE                                                     *
+  ! interface avec le schema de calcul de la poche    *
+  ! froide                                            *
+  ! *
+  ! written by   : CHERUY Frederique, 13/03/2000, 10.31.05      *
+  ! modified by :  ROEHRIG Romain,    01/30/2007                *
+  ! **************************************************************
+
+  USE dimphy
+  USE phys_state_var_mod, ONLY: pctsrf
+  USE indice_sol_mod, ONLY: is_oce
+  USE print_control_mod, ONLY: mydebug=>debug , lunout, prt_level
+  USE lmdz_wake, ONLY : wake
+  IMPLICIT NONE
+  ! ======================================================================
+  include "YOMCST.h"
+
+  ! Arguments
+  ! ----------
+  ! Input
+  ! ----
+  INTEGER,                       INTENT (IN)         :: iflag_wake_tend
+  REAL,                          INTENT (IN)         :: dtime
+  REAL, DIMENSION(klon, klev),   INTENT (IN)         :: pplay
+  REAL, DIMENSION(klon, klev+1), INTENT (IN)         :: paprs
+  REAL, DIMENSION(klon, klev),   INTENT (IN)         :: t, q, omgb
+  REAL, DIMENSION(klon, klev),   INTENT (IN)         :: dt_dwn, dq_dwn
+  REAL, DIMENSION(klon, klev),   INTENT (IN)         :: m_up, m_dwn
+  REAL, DIMENSION(klon, klev),   INTENT (IN)         :: dt_a, dq_a
+  REAL, DIMENSION(klon),         INTENT (IN)         :: wgen
+  REAL, DIMENSION(klon),         INTENT (IN)         :: sigd
+  REAL, DIMENSION(klon),         INTENT (IN)         :: Cin
+  ! Input/Output
+  ! ------------
+  REAL, DIMENSION(klon, klev),   INTENT (INOUT)      :: wake_deltat, wake_deltaq
+  REAL, DIMENSION(klon),         INTENT (INOUT)      :: wake_s, awake_s
+  REAL, DIMENSION(klon),         INTENT (INOUT)      :: wake_dens, awake_dens
+  ! Output
+  ! ------
+  REAL, DIMENSION(klon, klev),   INTENT (OUT)        :: dt_wake, dq_wake
+!!jyg  REAL, DIMENSION(klon),         INTENT (OUT)        :: wake_k
+  INTEGER, DIMENSION(klon),      INTENT (OUT)        :: wake_k
+  REAL, DIMENSION(klon, klev),   INTENT (OUT)        :: wake_d_deltat_gw
+  REAL, DIMENSION(klon),         INTENT (OUT)        :: wake_h
+  REAL, DIMENSION(klon, klev),   INTENT (OUT)        :: wake_dth
+  REAL, DIMENSION(klon),         INTENT (OUT)        :: wake_pe, wake_fip, wake_gfl
+  REAL, DIMENSION(klon, klev),   INTENT (OUT)        :: t_x, q_x
+  REAL, DIMENSION(klon, klev),   INTENT (OUT)        :: wake_omgbdth, wake_dp_omgb
+  REAL, DIMENSION(klon, klev),   INTENT (OUT)        :: wake_dtke, wake_dqke
+  REAL, DIMENSION(klon, klev),   INTENT (OUT)        :: wake_omg, wake_dp_deltomg
+  REAL, DIMENSION(klon, klev),   INTENT (OUT)        :: wake_spread
+  REAL, DIMENSION(klon),         INTENT (OUT)        :: wake_cstar
+  REAL, DIMENSION(klon, klev),   INTENT (OUT)        :: wake_ddeltat, wake_ddeltaq
+  REAL, DIMENSION(klon),         INTENT (OUT)        :: wake_ds, awake_ds, wake_ddens, awake_ddens
+
+
+  ! Variable internes
+  ! -----------------
+  LOGICAL, SAVE                                      :: first = .TRUE.
+  !$OMP THREADPRIVATE(first)
+  INTEGER                                            :: i, l
+  INTEGER, DIMENSION(klon)                           :: znatsurf    ! 0 if pctsrf(is_oce)>0.1; 1 else.
+  REAL                                               :: aire
+  REAL, DIMENSION(klon, klev)                        :: p,  pi
+  REAL, DIMENSION(klon, klev+1)                      ::  ph
+  REAL, DIMENSION(klon, klev)                        ::  omgbe
+  REAL, DIMENSION(klon, klev)                        :: te, qe
+  REAL, DIMENSION(klon, klev)                        :: dtdwn, dqdwn
+  REAL, DIMENSION(klon, klev)                        :: dta, dqa
+  REAL, DIMENSION(klon, klev)                        :: amdwn, amup
+  REAL, DIMENSION(klon, klev)                        :: dtw, dqw, dth
+  REAL, DIMENSION(klon, klev)                        :: dtls, dqls
+  REAL, DIMENSION(klon, klev)                        :: tx, qx
+  REAL, DIMENSION(klon)                              :: hw, wape, fip, gfl
+  REAL, DIMENSION(klon)                              :: sigmaw, asigmaw, wdens, awdens
+  REAL, DIMENSION(klon, klev)                        :: omgbdth
+  REAL, DIMENSION(klon, klev)                        :: dp_omgb
+  REAL, DIMENSION(klon, klev)                        :: dtke, dqke
+  REAL, DIMENSION(klon, klev)                        :: omg
+  REAL, DIMENSION(klon, klev)                        :: dp_deltomg, spread
+  REAL, DIMENSION(klon)                              :: cstar
+  REAL, DIMENSION(klon)                              :: sigd0
+  INTEGER, DIMENSION(klon)                           :: ktopw
+  REAL, DIMENSION(klon, klev)                        :: d_deltat_gw
+  REAL, DIMENSION(klon, klev)                        :: d_deltatw, d_deltaqw
+  REAL, DIMENSION(klon)                              :: d_sigmaw, d_asigmaw, d_wdens, d_awdens
+
+  REAL                                               :: rdcp
+
+
+  IF (prt_level >= 10) THEN
+    print *, '-> calwake, wake_s, awake_s, wgen input ', wake_s(1), awake_s(1), wgen(1)
+  ENDIF
+
+  rdcp = 1./3.5
+
+  znatsurf(:) = 0
+  DO i = 1,klon
+    IF (pctsrf(i,is_oce) < 0.1) znatsurf(i) = 1
+  ENDDO
+
+
+  ! -----------------------------------------------------------
+  ! IM 290108     DO 999 i=1,klon   ! a vectoriser
+  ! ----------------------------------------------------------
+
+
+  DO l = 1, klev
+    DO i = 1, klon
+      p(i, l) = pplay(i, l)
+      ph(i, l) = paprs(i, l)
+      pi(i, l) = (pplay(i,l)/100000.)**rdcp
+
+      te(i, l) = t(i, l)
+      qe(i, l) = q(i, l)
+      omgbe(i, l) = omgb(i, l)
+
+      dtdwn(i, l) = dt_dwn(i, l)
+      dqdwn(i, l) = dq_dwn(i, l)
+      dta(i, l) = dt_a(i, l)
+      dqa(i, l) = dq_a(i, l)
+    END DO
+  END DO
+
+!----------------------------------------------------------------
+!         Initialize tendencies to zero
+!----------------------------------------------------------------
+dtls(:,:) = 0.
+dqls(:,:) = 0.
+d_deltat_gw(:,:) = 0.
+d_deltatw(:,:) = 0.
+d_deltaqw(:,:) = 0.
+d_sigmaw(:) = 0.
+d_asigmaw(:) = 0.
+d_wdens(:) = 0.
+d_awdens(:) = 0.
+!
+
+  DO i = 1, klon
+    sigd0(i) = sigd(i)
+  END DO
+  ! print*, 'sigd0,sigd', sigd0, sigd(i)
+  DO i = 1, klon
+    ph(i, klev+1) = 0.
+  END DO
+
+!!jyg!  DO i = 1, klon                  
+!!jyg!    ktopw(i) = NINT(wake_k(i))    
+!!jyg!  END DO                          
+
+  DO i = 1, klon
+    hw(i) = wake_h(i)
+  END DO
+!
+!    Make a copy of state variables
+  DO l = 1, klev
+    DO i = 1, klon
+      dtw(i, l) = wake_deltat(i, l)
+      dqw(i, l) = wake_deltaq(i, l)
+    END DO
+  END DO
+
+  DO i = 1, klon
+    sigmaw(i)  = wake_s(i)
+    asigmaw(i) = awake_s(i)
+  END DO
+
+  DO i = 1, klon
+    wdens(i) = max(0., wake_dens(i))
+    awdens(i) = max(0., awake_dens(i))
+  END DO
+
+  ! fkc les flux de masses sont evalues aux niveaux et valent 0 a la surface
+  ! fkc  on veut le flux de masse au milieu des couches
+
+  DO l = 1, klev - 1
+    DO i = 1, klon
+      amdwn(i, l) = 0.5*(m_dwn(i,l)+m_dwn(i,l+1))
+      amdwn(i, l) = (m_dwn(i,l+1))
+    END DO
+  END DO
+
+  ! au sommet le flux de masse est nul
+
+  DO i = 1, klon
+    amdwn(i, klev) = 0.5*m_dwn(i, klev)
+  END DO
+
+  DO l = 1, klev
+    DO i = 1, klon
+      amup(i, l) = m_up(i, l)
+    END DO
+  END DO
+
+
+
+  CALL wake(klon,klev,znatsurf, p, ph, pi, dtime, &
+    te, qe, omgbe, &
+    dtdwn, dqdwn, amdwn, amup, dta, dqa, wgen, &
+    sigd0, Cin, &
+    dtw, dqw, sigmaw, asigmaw, wdens, awdens, &                      ! state variables
+    dth, hw, wape, fip, gfl, &
+    dtls, dqls, ktopw, omgbdth, dp_omgb, tx, qx, &
+    dtke, dqke, omg, dp_deltomg, spread, cstar, &
+    d_deltat_gw, &
+    d_deltatw, d_deltaqw, d_sigmaw, d_asigmaw, d_wdens, d_awdens)      ! tendencies
+
+!
+  DO l = 1, klev
+    DO i = 1, klon
+      IF (ktopw(i)>0) THEN
+        wake_d_deltat_gw(i, l) = d_deltat_gw(i, l)
+        wake_omgbdth(i, l) = omgbdth(i, l)
+        wake_dp_omgb(i, l) = dp_omgb(i, l)
+        wake_dtke(i, l) = dtke(i, l)
+        wake_dqke(i, l) = dqke(i, l)
+        wake_omg(i, l) = omg(i, l)
+        wake_dp_deltomg(i, l) = dp_deltomg(i, l)
+        wake_spread(i, l) = spread(i, l)
+        wake_dth(i, l) = dth(i, l)
+        dt_wake(i, l) = dtls(i, l)*dtime         ! derivative -> tendency
+        dq_wake(i, l) = dqls(i, l)*dtime         ! derivative -> tendency
+        t_x(i, l) = tx(i, l)
+        q_x(i, l) = qx(i, l)
+      ELSE
+        wake_d_deltat_gw(i, l) = 0.
+        wake_omgbdth(i, l) = 0.
+        wake_dp_omgb(i, l) = 0.
+        wake_dtke(i, l) = 0.
+        wake_dqke(i, l) = 0.
+        wake_omg(i, l) = 0.
+        wake_dp_deltomg(i, l) = 0.
+        wake_spread(i, l) = 0.
+        wake_dth(i, l) = 0.
+        dt_wake(i, l) = 0.
+        dq_wake(i, l) = 0.
+        t_x(i, l) = te(i, l)
+        q_x(i, l) = qe(i, l)
+      END IF
+    END DO
+  END DO
+
+  DO i = 1, klon
+    wake_h(i) = hw(i)
+    wake_pe(i) = wape(i)
+    wake_fip(i) = fip(i)
+    wake_gfl(i) = gfl(i)
+    wake_k(i) = ktopw(i)
+    wake_cstar(i) = cstar(i)
+  END DO
+
+!  Tendencies of state variables
+  DO l = 1, klev
+    DO i = 1, klon
+      IF (ktopw(i)>0) THEN
+        wake_ddeltat(i, l) = d_deltatw(i, l)*dtime
+        wake_ddeltaq(i, l) = d_deltaqw(i, l)*dtime
+      ELSE
+        wake_ddeltat(i, l) = -wake_deltat(i, l)
+        wake_ddeltaq(i, l) = -wake_deltaq(i, l)
+      END IF
+    END DO
+  END DO
+  DO i = 1, klon
+    IF (ktopw(i)>0) THEN
+      wake_ds(i) = d_sigmaw(i)*dtime
+      awake_ds(i) = d_asigmaw(i)*dtime
+      awake_ddens(i) = d_awdens(i)*dtime
+      wake_ddens(i) = d_wdens(i)*dtime
+    ELSE
+      wake_ds(i)    = -wake_s(i)
+      awake_ds(i)   = -awake_s(i)
+      wake_ddens(i) = -wake_dens(i)
+      awake_ddens(i)= -awake_dens(i)
+    END IF
+  END DO
+!
+
+!jyg<  
+  IF (iflag_wake_tend .EQ. 0) THEN
+!  Update State variables
+    DO l = 1, klev
+      DO i = 1, klon
+        IF (ktopw(i)>0) THEN
+          wake_deltat(i, l) = dtw(i, l)
+          wake_deltaq(i, l) = dqw(i, l)
+        ELSE
+          wake_deltat(i, l) = 0.
+          wake_deltaq(i, l) = 0.
+        END IF
+      END DO
+    END DO
+    DO i = 1, klon
+      wake_s(i) = sigmaw(i)
+      awake_s(i) = asigmaw(i)
+      awake_dens(i) = awdens(i)
+      wake_dens(i) = wdens(i)
+    END DO
+  ENDIF  ! (iflag_wake_tend .EQ. 0)
+!
+  IF (first) THEN
+    DO i = 1,klon
+      IF (wake_dens(i) < -1.) THEN
+        wake_dens(i) = wdens(i)
+      ENDIF
+    ENDDO
+    first=.false.
+  ENDIF  ! (first)
+!>jyg
+  IF (prt_level >= 10) THEN
+    print *, 'calwake ->, wake_s, awake_s ', wake_s(1), awake_s(1)
+  ENDIF
+
+  RETURN
+END SUBROUTINE calwake
+
+
Index: DZ6/trunk/libf/phylmd/carbon_cycle_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/carbon_cycle_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,542 +1,0 @@
-MODULE carbon_cycle_mod
-!=======================================================================
-!   Authors: Patricia Cadule and Laurent Fairhead
-!            base sur un travail anterieur mene par Patricia Cadule et Josefine Ghattas
-!
-!  Purpose and description:
-!  -----------------------
-! Control module for the carbon CO2 tracers :
-!   - Initialisation of carbon cycle fields
-!   - Definition of fluxes to be exchanged
-!
-! Rest of code is in tracco2i.F90
-!
-! Le cas online/offline est defini par le flag carbon_cycle_cpl (y/n)
-! Le transport du traceur CO2 est defini par le flag carbon_cycle_tr (y/n)
-! la provenance des champs (termes de puits) est denini par le flag level_coupling_esm
-!
-! level_coupling_esm : level of coupling of the biogeochemical fields between
-! LMDZ, ORCHIDEE and NEMO
-! Definitions of level_coupling_esm in physiq.def
-! level_coupling_esm = 0  ! No field exchange between LMDZ and ORCHIDEE models
-!                         ! No field exchange between LMDZ and NEMO
-! level_coupling_esm = 1  ! Field exchange between LMDZ and ORCHIDEE models
-!                         ! No field exchange between LMDZ and NEMO models
-! level_coupling_esm = 2  ! No field exchange between LMDZ and ORCHIDEE models
-!                         ! Field exchange between LMDZ and NEMO models
-! level_coupling_esm = 3  ! Field exchange between LMDZ and ORCHIDEE models
-!                         ! Field exchange between LMDZ and NEMO models
-!=======================================================================
-
-  IMPLICIT NONE
-  SAVE
-  PRIVATE
-  PUBLIC :: carbon_cycle_init, infocfields_init
-
-! Variables read from parmeter file physiq.def
-  LOGICAL, PUBLIC :: carbon_cycle_cpl       ! Coupling of CO2 fluxes between LMDZ/ORCHIDEE and LMDZ/OCEAN(PISCES) 
-!$OMP THREADPRIVATE(carbon_cycle_cpl)
-  LOGICAL, PUBLIC :: carbon_cycle_tr        ! 3D transport of CO2 in the atmosphere, parameter read in conf_phys
-!$OMP THREADPRIVATE(carbon_cycle_tr)
-  LOGICAL, PUBLIC :: carbon_cycle_rad       ! flag to activate CO2 interactive radiatively 
-!$OMP THREADPRIVATE(carbon_cycle_rad)
-  INTEGER, PUBLIC :: level_coupling_esm     ! Level of coupling for the ESM - 0, 1, 2, 3
-!$OMP THREADPRIVATE(level_coupling_esm)
-  LOGICAL, PUBLIC :: read_fco2_ocean_cor    ! flag to read corrective oceanic CO2 flux
-!$OMP THREADPRIVATE(read_fco2_ocean_cor)  
-  REAL, PUBLIC :: var_fco2_ocean_cor        ! corrective oceanic CO2 flux
-!$OMP THREADPRIVATE(var_fco2_ocean_cor)
-  REAL, PUBLIC :: ocean_area_tot            ! total oceanic area to convert flux
-!$OMP THREADPRIVATE(ocean_area_tot)
-  LOGICAL, PUBLIC :: read_fco2_land_cor     ! flag to read corrective land CO2 flux
-!$OMP THREADPRIVATE(read_fco2_land_cor)  
-  REAL, PUBLIC :: var_fco2_land_cor         ! corrective land CO2 flux
-!$OMP THREADPRIVATE(var_fco2_land_cor)
-  REAL, PUBLIC :: land_area_tot             ! total land area to convert flux
-!$OMP THREADPRIVATE(land_area_tot)
-
-  REAL, PUBLIC :: RCO2_glo
-!$OMP THREADPRIVATE(RCO2_glo)
-  REAL, PUBLIC :: RCO2_tot
-!$OMP THREADPRIVATE(RCO2_tot)
-
-  LOGICAL :: carbon_cycle_emis_comp_omp=.FALSE.
-  LOGICAL :: carbon_cycle_emis_comp=.FALSE. ! Calculation of emission compatible
-!$OMP THREADPRIVATE(carbon_cycle_emis_comp)
-
-  LOGICAL :: RCO2_inter_omp
-  LOGICAL :: RCO2_inter  ! RCO2 interactive : if true calculate new value RCO2 for the radiation scheme
-!$OMP THREADPRIVATE(RCO2_inter)
-
-! Scalare values when no transport, from physiq.def
-  REAL :: fos_fuel_s_omp
-  REAL :: fos_fuel_s  ! carbon_cycle_fos_fuel dans physiq.def
-!$OMP THREADPRIVATE(fos_fuel_s)
-  REAL :: emis_land_s ! not yet implemented
-!$OMP THREADPRIVATE(emis_land_s)
-
-  REAL :: airetot     ! Total area of the earth surface
-!$OMP THREADPRIVATE(airetot)
-
-  INTEGER :: ntr_co2  ! Number of tracers concerning the carbon cycle
-!$OMP THREADPRIVATE(ntr_co2)
-
-! fco2_ocn_day : flux CO2 from ocean for 1 day (cumulated) [gC/m2/d]. Allocation and initalization done in cpl_mod
-  REAL, DIMENSION(:), ALLOCATABLE, PUBLIC :: fco2_ocn_day 
-!$OMP THREADPRIVATE(fco2_ocn_day)
-
-  REAL, DIMENSION(:), ALLOCATABLE :: fco2_land_day   ! flux CO2 from land for 1 day (cumulated)  [gC/m2/d]
-!$OMP THREADPRIVATE(fco2_land_day)
-  REAL, DIMENSION(:), ALLOCATABLE :: fco2_lu_day     ! Emission from land use change for 1 day (cumulated) [gC/m2/d]
-!$OMP THREADPRIVATE(fco2_lu_day)
-  REAL, DIMENSION(:), ALLOCATABLE, PUBLIC :: fco2_ff ! Emission from fossil fuel [kgCO2/m2/s]
-!$OMP THREADPRIVATE(fco2_ff)
-  REAL, DIMENSION(:), ALLOCATABLE, PUBLIC :: fco2_bb ! Emission from biomass burning [kgCO2/m2/s]
-!$OMP THREADPRIVATE(fco2_bb)
-  REAL, DIMENSION(:), ALLOCATABLE, PUBLIC :: fco2_land  ! Net flux from terrestrial ecocsystems [kgCO2/m2/s]
-!$OMP THREADPRIVATE(fco2_land)
-  REAL, DIMENSION(:), ALLOCATABLE, PUBLIC :: fco2_land_nbp  ! Net flux from terrestrial ecocsystems [kgCO2/m2/s]
-!$OMP THREADPRIVATE(fco2_land_nbp)
-  REAL, DIMENSION(:), ALLOCATABLE, PUBLIC :: fco2_land_nep  ! Net flux from terrestrial ecocsystems [kgCO2/m2/s]
-!$OMP THREADPRIVATE(fco2_land_nep)
-  REAL, DIMENSION(:), ALLOCATABLE, PUBLIC :: fco2_land_fLuc  ! Net flux from terrestrial ecocsystems [kgCO2/m2/s]
-!$OMP THREADPRIVATE(fco2_land_fLuc)
-  REAL, DIMENSION(:), ALLOCATABLE, PUBLIC :: fco2_land_fwoodharvest  ! Net flux from terrestrial ecocsystems [kgCO2/m2/s]
-!$OMP THREADPRIVATE(fco2_land_fwoodharvest)
-  REAL, DIMENSION(:), ALLOCATABLE, PUBLIC :: fco2_land_fHarvest  ! Net flux from terrestrial ecocsystems [kgCO2/m2/s]
-!$OMP THREADPRIVATE(fco2_land_fHarvest)
-  REAL, DIMENSION(:), ALLOCATABLE, PUBLIC :: fco2_ocean ! Net flux from ocean [kgCO2/m2/s]
-!$OMP THREADPRIVATE(fco2_ocean)
-  REAL, DIMENSION(:), ALLOCATABLE, PUBLIC :: fco2_ocean_cor ! Net corrective flux from ocean [kgCO2/m2/s]
-!$OMP THREADPRIVATE(fco2_ocean_cor)
-  REAL, DIMENSION(:), ALLOCATABLE, PUBLIC :: fco2_land_cor  ! Net corrective flux from land [kgCO2/m2/s]
-!$OMP THREADPRIVATE(fco2_land_cor)
-
-  REAL, DIMENSION(:,:), ALLOCATABLE :: dtr_add       ! Tracer concentration to be injected 
-!$OMP THREADPRIVATE(dtr_add)
-
-! Following 2 fields will be allocated and initialized in surf_land_orchidee
-  REAL, DIMENSION(:), ALLOCATABLE, PUBLIC :: fco2_land_inst  ! flux CO2 from land at one time step
-!$OMP THREADPRIVATE(fco2_land_inst)
-  REAL, DIMENSION(:), ALLOCATABLE, PUBLIC :: fco2_lu_inst    ! Emission from land use change at one time step
-!$OMP THREADPRIVATE(fco2_lu_inst)
-
-! Calculated co2 field to be send to the ocean via the coupler and to ORCHIDEE 
-  REAL, DIMENSION(:), ALLOCATABLE, PUBLIC :: co2_send ! Field allocated in phyetat0
-!$OMP THREADPRIVATE(co2_send)
-
-  INTEGER, PARAMETER, PUBLIC :: id_CO2=1              !--temporaire OB -- to be changed
-
-! nbfields : total number of fields 
-  INTEGER, PUBLIC :: nbcf
-!$OMP THREADPRIVATE(nbcf)
-
-! nbcf_in : number of fields IN
-  INTEGER, PUBLIC  :: nbcf_in
-!$OMP THREADPRIVATE(nbcf_in)
-
-! nbcf_in_orc : number of fields IN 
-  INTEGER, PUBLIC  :: nbcf_in_orc
-!$OMP THREADPRIVATE(nbcf_in_orc)
-
-! nbcf_in_inca : number of fields IN (from INCA)
-  INTEGER, PUBLIC  :: nbcf_in_inca
-!$OMP THREADPRIVATE(nbcf_in_inca)
-
-! nbcf_in_nemo : number of fields IN (from nemo)
-  INTEGER, PUBLIC  :: nbcf_in_nemo
-!$OMP THREADPRIVATE(nbcf_in_nemo)
-
-! nbcf_in_ant : number of fields IN (from anthropogenic sources)
-  INTEGER, PUBLIC  :: nbcf_in_ant
-!$OMP THREADPRIVATE(nbcf_in_ant)
-
-! nbcf_out : number of fields OUT
-  INTEGER, PUBLIC :: nbcf_out
-!$OMP THREADPRIVATE(nbcf_out)
-
-! Name of variables
-  CHARACTER(len=25), ALLOCATABLE, DIMENSION(:), PUBLIC :: cfname     ! coupling field short name for restart (?) and diagnostics
-!$OMP THREADPRIVATE(cfname)
-
-  CHARACTER(len=25), ALLOCATABLE, DIMENSION(:), PUBLIC :: cfname_in  ! coupling field short name for restart (?) and diagnostics
-!$OMP THREADPRIVATE(cfname_in)
-
-  CHARACTER(len=25), ALLOCATABLE, DIMENSION(:), PUBLIC :: cfname_out ! coupling field short name for restart (?) and diagnostics
-!$OMP THREADPRIVATE(cfname_out)
-
-  CHARACTER(len=15), ALLOCATABLE, DIMENSION(:), PUBLIC :: cfunits_in  !  coupling field units for diagnostics
-!$OMP THREADPRIVATE(cfunits_in)
-
-  CHARACTER(len=15), ALLOCATABLE, DIMENSION(:), PUBLIC :: cfunits_out !  coupling field units for diagnostics
-!$OMP THREADPRIVATE(cfunits_out)
-
-  CHARACTER(len=120), ALLOCATABLE, DIMENSION(:), PUBLIC :: cftext_in  ! coupling field long name for diagnostics
-!$OMP THREADPRIVATE(cftext_in)
-
-  CHARACTER(len=120), ALLOCATABLE, DIMENSION(:), PUBLIC :: cftext_out ! coupling field long name for diagnostics
-!$OMP THREADPRIVATE(cftext_out)
-
-  CHARACTER(len=5), ALLOCATABLE, DIMENSION(:), PUBLIC :: cfmod1 ! model 1 (rreference) : LMDz
-!$OMP THREADPRIVATE(cfmod1)
-
-  CHARACTER(len=5), ALLOCATABLE, DIMENSION(:), PUBLIC :: cfmod2 ! model 2
-!$OMP THREADPRIVATE(cfmod2)
-
-  CHARACTER(LEN=20), ALLOCATABLE, DIMENSION(:), PUBLIC :: field_out_names
-!$OMP THREADPRIVATE(field_out_names)
-
-  CHARACTER(LEN=20), ALLOCATABLE, DIMENSION(:), PUBLIC :: field_in_names
-!$OMP THREADPRIVATE(field_in_names)
-
-  REAL, ALLOCATABLE, DIMENSION(:,:), PUBLIC :: fields_in   !  klon,nbcf_in
-!$OMP THREADPRIVATE(fields_in)
-
-  REAL, ALLOCATABLE, DIMENSION(:,:), PUBLIC :: yfields_in  !  knon,nbcf_in
-!$OMP THREADPRIVATE(yfields_in)
-
-  REAL, ALLOCATABLE, DIMENSION(:,:), PUBLIC :: fields_out  !  klon,nbcf_out
-!$OMP THREADPRIVATE(fields_out)
-
-  REAL, ALLOCATABLE, DIMENSION(:,:), PUBLIC :: yfields_out !  knon,nbcf_out
-!$OMP THREADPRIVATE(yfields_out)
-
-  TYPE, PUBLIC :: co2_trac_type
-     CHARACTER(len = 8) :: name       ! Tracer name in tracer.def
-     INTEGER            :: id         ! Index in total tracer list, tr_seri
-     CHARACTER(len=30)  :: file       ! File name
-     LOGICAL            :: cpl        ! True if this tracers is coupled from ORCHIDEE or PISCES. 
-                                      ! False if read from file.
-     INTEGER            :: updatefreq ! Frequence to inject in second
-     INTEGER            :: readstep   ! Actual time step to read in file
-     LOGICAL            :: updatenow  ! True if this tracer should be updated this time step
-  END TYPE co2_trac_type
-  INTEGER,PARAMETER :: maxco2trac=5  ! Maximum number of different CO2 fluxes
-  TYPE(co2_trac_type), DIMENSION(maxco2trac) :: co2trac
-
-CONTAINS
-  
-  SUBROUTINE carbon_cycle_init()
-    ! This subroutine is called from tracco2i_init, which is called from phytrac_init only at first timestep.
-    ! - Allocate variables. These variables must be allocated before first call to phys_output_write in physiq.
-
-    USE dimphy
-    USE IOIPSL
-    USE print_control_mod, ONLY: lunout
-
-    IMPLICIT NONE
-    INCLUDE "clesphys.h"
- 
-! Local variables
-    INTEGER               :: ierr
-
-    IF (carbon_cycle_cpl) THEN
-
-       ierr=0
-
-       IF (.NOT.ALLOCATED(fco2_land)) ALLOCATE(fco2_land(klon), stat=ierr)
-       IF (ierr /= 0) CALL abort_physic('carbon_cycle_init', 'pb in allocation fco2_land',1)
-
-       IF (.NOT.ALLOCATED(fco2_land_nbp)) ALLOCATE(fco2_land_nbp(klon), stat=ierr)
-       IF (ierr /= 0) CALL abort_physic('carbon_cycle_init', 'pb in allocation fco2_land_nbp',1)
-
-       IF (.NOT.ALLOCATED(fco2_land_nep)) ALLOCATE(fco2_land_nep(klon), stat=ierr)
-       IF (ierr /= 0) CALL abort_physic('carbon_cycle_init', 'pb in allocation fco2_land_nep',1)
-
-       IF (.NOT.ALLOCATED(fco2_land_fLuc)) ALLOCATE(fco2_land_fLuc(klon), stat=ierr)
-       IF (ierr /= 0) CALL abort_physic('carbon_cycle_init', 'pb in allocation fco2_land_fLuc',1)
-
-       IF (.NOT.ALLOCATED(fco2_land_fwoodharvest)) ALLOCATE(fco2_land_fwoodharvest(klon), stat=ierr)
-       IF (ierr /= 0) CALL abort_physic('carbon_cycle_init', 'pb in allocation fco2_land_fwoodharvest',1)
-
-       IF (.NOT.ALLOCATED(fco2_land_fHarvest)) ALLOCATE(fco2_land_fHarvest(klon), stat=ierr)
-       IF (ierr /= 0) CALL abort_physic('carbon_cycle_init', 'pb in allocation fco2_land_fHarvest',1)
-
-       IF (.NOT.ALLOCATED(fco2_ff)) ALLOCATE(fco2_ff(klon), stat=ierr)
-       IF (ierr /= 0) CALL abort_physic('carbon_cycle_init', 'pb in allocation fco2_ff',1)
-
-       IF (.NOT.ALLOCATED(fco2_bb)) ALLOCATE(fco2_bb(klon), stat=ierr)
-       IF (ierr /= 0) CALL abort_physic('carbon_cycle_init', 'pb in allocation fco2_bb',1)
-
-       IF (.NOT.ALLOCATED(fco2_ocean)) ALLOCATE(fco2_ocean(klon), stat=ierr)
-       IF (ierr /= 0) CALL abort_physic('carbon_cycle_init', 'pb in allocation fco2_ocean',1)
-
-       IF (.NOT.ALLOCATED(fco2_ocean_cor)) ALLOCATE(fco2_ocean_cor(klon), stat=ierr)
-       IF (ierr /= 0) CALL abort_physic('carbon_cycle_init', 'pb in allocation fco2_ocean_cor',1)
-
-       IF (.NOT.ALLOCATED(fco2_land_cor)) ALLOCATE(fco2_land_cor(klon), stat=ierr)
-       IF (ierr /= 0) CALL abort_physic('carbon_cycle_init', 'pb in allocation fco2_land_cor',1)
-
-    ENDIF
-
-  END SUBROUTINE carbon_cycle_init
-
-  SUBROUTINE infocfields_init
-
-!    USE control_mod, ONLY: planet_type
-    USE phys_cal_mod, ONLY : mth_cur
-    USE mod_synchro_omp
-    USE mod_phys_lmdz_para, ONLY: is_mpi_root, is_omp_root
-    USE mod_phys_lmdz_transfert_para
-    USE mod_phys_lmdz_omp_transfert
-    USE dimphy, ONLY: klon
-
-    IMPLICIT NONE
-
-!=======================================================================
-!
-!   Authors: Patricia Cadule and Laurent Fairhead  
-!   -------
-!
-!  Purpose and description:
-!  -----------------------
-!
-! Infofields
-! this routine enables to define the field exchanges in both directions between
-! the atmospheric circulation model (LMDZ) and ORCHIDEE. In the future this
-! routing might apply to other models (e.g., NEMO, INCA, ...).
-! Therefore, currently with this routine, it is possible to define the coupling
-! fields only between LMDZ and ORCHIDEE.
-! The coupling_fields.def file enables to define the name of the exchanged
-! fields at the coupling interface.
-! field_in_names : the set of names of the exchanged fields in input to ORCHIDEE
-! (LMDZ to ORCHIDEE)
-! field_out_names : the set of names of the exchanged fields in output of
-! ORCHIDEE (ORCHIDEE to LMDZ)
-! n : the number of exchanged fields at th coupling interface
-! nb_fields_in : number of inputs fields to ORCHIDEE (LMDZ to ORCHIDEE)
-! nb_fields_out : number of ouput fields of ORCHIDEE (ORCHIDEE to LMDZ)
-!
-! The syntax for coupling_fields.def is as follows:
-! IMPORTANT: each column entry must be separated from the previous one by 3
-! spaces and only that
-! field name         coupling          model 1         model 2         long_name
-!                    direction
-!   10char  -3spaces-  3char  -3spaces- 4char -3spaces- 4char -3spaces-  30char 
-!
-! n
-! FIELD1 IN LMDZ ORC
-! ....
-! FIELD(j) IN LMDZ ORC
-! FIELD(j+1) OUT LMDZ ORC
-! ...
-! FIELDn OUT LMDZ ORC   
-! 
-!=======================================================================
-!   ... 22/12/2017 ....
-!-----------------------------------------------------------------------
-! Declarations
-
-  INCLUDE "clesphys.h"
-  INCLUDE "dimensions.h"
-  INCLUDE "iniprint.h"
-
-! Local variables
-
-  INTEGER :: iq,  ierr, stat, error
-
-  CHARACTER(LEN=20), ALLOCATABLE, DIMENSION(:), SAVE  :: cfname_root
-  CHARACTER(LEN=120), ALLOCATABLE, DIMENSION(:), SAVE :: cftext_root
-  CHARACTER(LEN=15), ALLOCATABLE, DIMENSION(:), SAVE  :: cfunits_root
-
-  CHARACTER(len=3), ALLOCATABLE, DIMENSION(:) :: cfintent_root
-  CHARACTER(len=5), ALLOCATABLE, DIMENSION(:) :: cfmod1_root
-  CHARACTER(len=5), ALLOCATABLE, DIMENSION(:) :: cfmod2_root
-
-  LOGICAL, ALLOCATABLE, DIMENSION(:), SAVE :: mask_in_root
-  LOGICAL, ALLOCATABLE, DIMENSION(:), SAVE :: mask_out_root
-
-  CHARACTER(len=*),parameter :: modname="infocfields"
-
-  CHARACTER(len=10),SAVE :: planet_type="earth"
-
-!-----------------------------------------------------------------------
-
-nbcf=0
-nbcf_in=0
-nbcf_out=0
-
-IF (planet_type=='earth') THEN
-
-    IF (is_mpi_root .AND. is_omp_root) THEN
-
-       IF (level_coupling_esm.GT.0) THEN
-
-          OPEN(200,file='coupling_fields.def',form='formatted',status='old', iostat=ierr)
-
-          IF (ierr.EQ.0) THEN
-
-             WRITE(lunout,*) trim(modname),': Open coupling_fields.def : ok'
-             READ(200,*) nbcf
-             WRITE(lunout,*) 'infocfields_mod.F90 --- nbcf=',nbcf
-             ALLOCATE(cfname_root(nbcf))
-             ALLOCATE(cfintent_root(nbcf))
-             ALLOCATE(cfmod1_root(nbcf))
-             ALLOCATE(cfmod2_root(nbcf))
-             ALLOCATE(cftext_root(nbcf))
-             ALLOCATE(cfunits_root(nbcf))
-             ALLOCATE(mask_in_root(nbcf))
-             ALLOCATE(mask_out_root(nbcf))
-
-             nbcf_in=0
-             nbcf_out=0
-
-             DO iq=1,nbcf
-                WRITE(lunout,*) 'infofields : field=',iq
-                READ(200,'(A15,3X,A3,3X,A5,3X,A5,3X,A120,3X,A15)',IOSTAT=ierr) &
-                   cfname_root(iq),cfintent_root(iq),cfmod1_root(iq),cfmod2_root(iq),cftext_root(iq),cfunits_root(iq)
-                cfname_root(iq)=TRIM(cfname_root(iq))
-                cfintent_root(iq)=TRIM(cfintent_root(iq))
-                cfmod1_root(iq)=TRIM(cfmod1_root(iq))
-                cfmod2_root(iq)=TRIM(cfmod2_root(iq))
-                cftext_root(iq)=TRIM(cftext_root(iq))
-                cfunits_root(iq)=TRIM(cfunits_root(iq))
-                WRITE(lunout,*) 'coupling field: ',cfname_root(iq), &  
-                               ', number: ',iq,', INTENT: ',cfintent_root(iq)
-                WRITE(lunout,*) 'coupling field: ',cfname_root(iq), & 
-                               ', number: ',iq,', model 1 (ref): ',cfmod1_root(iq),', model 2: ',cfmod2_root(iq)
-                WRITE(lunout,*) 'coupling field: ',cfname_root(iq), & 
-                               ', number: ',iq,', long name: ',cftext_root(iq),', units ',cfunits_root(iq)
-                IF (nbcf_in+nbcf_out.LT.nbcf) THEN
-                  IF (cfintent_root(iq).NE.'OUT') THEN
-                    nbcf_in=nbcf_in+1
-                    mask_in_root(iq)=.TRUE.
-                    mask_out_root(iq)=.FALSE.
-                  ELSE IF (cfintent_root(iq).EQ.'OUT') THEN
-                    nbcf_out=nbcf_out+1
-                    mask_in_root(iq)=.FALSE.
-                    mask_out_root(iq)=.TRUE.
-                  ENDIF
-                ELSE
-                  WRITE(lunout,*) 'abort_gcm --- nbcf    : ',nbcf
-                  WRITE(lunout,*) 'abort_gcm --- nbcf_in : ',nbcf_in
-                  WRITE(lunout,*) 'abort_gcm --- nbcf_out: ',nbcf_out
-                  CALL abort_physic('infocfields_init','Problem in the definition of the coupling fields',1)
-               ENDIF
-             ENDDO !DO iq=1,nbcf
-          ELSE
-             WRITE(lunout,*) trim(modname),': infocfields_mod.F90 --- Problem in opening coupling_fields.def'
-             WRITE(lunout,*) trim(modname),': infocfields_mod.F90 --- WARNING using defaut values'
-          ENDIF ! ierr
-          CLOSE(200)
-
-       ENDIF ! level_coupling_esm
-
-    ENDIF !   (is_mpi_root .AND. is_omp_root)
-!$OMP BARRIER
-
-    CALL bcast(nbcf)
-    CALL bcast(nbcf_in)
-    CALL bcast(nbcf_out)
-
-    WRITE(lunout,*) 'infocfields_mod.F90 --- nbcf    =',nbcf
-    WRITE(lunout,*) 'infocfields_mod.F90 --- nbcf_in =',nbcf_in
-    WRITE(lunout,*) 'infocfields_mod.F90 --- nbcf_out=',nbcf_out
-
-    ALLOCATE(cfname(nbcf))
-    ALLOCATE(cfname_in(nbcf_in))
-    ALLOCATE(cftext_in(nbcf_in))
-    ALLOCATE(cfname_out(nbcf_out))
-    ALLOCATE(cftext_out(nbcf_out))
-    ALLOCATE(cfmod1(nbcf))
-    ALLOCATE(cfmod2(nbcf))
-    ALLOCATE(cfunits_in(nbcf_in))
-    ALLOCATE(cfunits_out(nbcf_out))
-       
-    IF (is_mpi_root .AND. is_omp_root) THEN
-
-        IF (nbcf.GT.0)     cfname=cfname_root
-        IF (nbcf_in.GT.0)  cfname_in=PACK(cfname_root,mask_in_root)
-        IF (nbcf_out.GT.0) cfname_out=PACK(cfname_root,mask_out_root)
-        IF (nbcf_in.GT.0)  cftext_in=PACK(cftext_root,mask_in_root)
-        IF (nbcf_out.GT.0) cftext_out=PACK(cftext_root,mask_out_root)
-        IF (nbcf.GT.0)     cfmod1=cfmod1_root
-        IF (nbcf.GT.0)     cfmod2=cfmod2_root
-        IF (nbcf_in.GT.0)  cfunits_in=PACK(cfunits_root,mask_in_root)
-        IF (nbcf_out.GT.0) cfunits_out=PACK(cfunits_root,mask_out_root)
-
-        nbcf_in_orc=0
-        nbcf_in_nemo=0
-        nbcf_in_inca=0
-        nbcf_in_ant=0
-
-        DO iq=1,nbcf
-            IF (cfmod1(iq) == "ORC")  nbcf_in_orc  = nbcf_in_orc  + 1  
-            IF (cfmod1(iq) == "NEMO") nbcf_in_nemo = nbcf_in_nemo + 1  
-            IF (cfmod1(iq) == "INCA") nbcf_in_inca = nbcf_in_inca + 1
-            IF (cfmod1(iq) == "ALL")  nbcf_in_orc  = nbcf_in_orc  + 1  ! ALL = ORC/NEMO/INCA
-            IF (cfmod1(iq) == "ALL")  nbcf_in_nemo = nbcf_in_nemo + 1  ! ALL = ORC/NEMO/INCA 
-            IF (cfmod1(iq) == "ALL")  nbcf_in_inca = nbcf_in_inca + 1  ! ALL = ORC/NEMO/INCA 
-            IF (cfmod1(iq) == "ANT")  nbcf_in_ant  = nbcf_in_ant  + 1  
-        ENDDO
-
-    ENDIF !   (is_mpi_root .AND. is_omp_root)
-!$OMP BARRIER
-
-    CALL bcast(nbcf_in_orc)
-    CALL bcast(nbcf_in_nemo)
-    CALL bcast(nbcf_in_inca)
-    CALL bcast(nbcf_in_ant)
-
-    WRITE(lunout,*) 'nbcf_in_orc  =',nbcf_in_orc
-    WRITE(lunout,*) 'nbcf_in_nemo =',nbcf_in_nemo
-    WRITE(lunout,*) 'nbcf_in_inca =',nbcf_in_inca
-    WRITE(lunout,*) 'nbcf_in_ant  =',nbcf_in_ant
-
-    IF (nbcf_in.GT.0) THEN 
-        DO iq=1,nbcf_in
-          CALL bcast(cfname_in(iq))
-          CALL bcast(cftext_in(iq))
-          CALL bcast(cfunits_in(iq))
-        ENDDO
-    ENDIF
-
-    IF (nbcf_out.GT.0) THEN
-        DO iq=1,nbcf_out
-          CALL bcast(cfname_out(iq))
-          CALL bcast(cftext_out(iq))
-          CALL bcast(cfunits_out(iq))
-        ENDDO
-    ENDIF
-
-    IF (nbcf.GT.0) THEN
-        DO iq=1,nbcf
-          CALL bcast(cfmod1(iq))
-          CALL bcast(cfmod2(iq))
-        ENDDO
-    ENDIF
-
-    IF (nbcf_in.GT.0)  WRITE(lunout,*)'infocfields_mod --- cfname_in: ',cfname_in
-    IF (nbcf_out.GT.0) WRITE(lunout,*)'infocfields_mod --- cfname_out: ',cfname_out
-
-    IF (nbcf_in.GT.0)  WRITE(lunout,*)'infocfields_mod --- cftext_in: ',cftext_in
-    IF (nbcf_out.GT.0) WRITE(lunout,*)'infocfields_mod --- cftext_out: ',cftext_out
-
-    IF (nbcf.GT.0) WRITE(lunout,*)'infocfields_mod --- cfmod1: ',cfmod1 
-    IF (nbcf.GT.0) WRITE(lunout,*)'infocfields_mod --- cfmod2: ',cfmod2 
-
-    IF (nbcf_in.GT.0)  WRITE(lunout,*)'infocfunits_mod --- cfunits_in: ',cfunits_in
-    IF (nbcf_out.GT.0) WRITE(lunout,*)'infocfunits_mod --- cfunits_out: ',cfunits_out
-
-    IF (nbcf_in.GT.0)  WRITE(*,*)'infocfields_init --- number of fields in to LMDZ: ',nbcf_in
-    IF (nbcf_out.GT.0) WRITE(*,*)'infocfields_init --- number of fields out of LMDZ: ',nbcf_out
-
- ELSE
- ! Default values for other planets
-    nbcf=0 
-    nbcf_in=0
-    nbcf_out=0
- ENDIF ! planet_type
-
- ALLOCATE(fields_in(klon,nbcf_in),stat=error)
- IF (error /= 0)  CALL abort_physic(modname,'Pb in allocation fields_in',1)
- ALLOCATE(yfields_in(klon,nbcf_in),stat=error)
- IF (error /= 0)  CALL abort_physic(modname,'Pb in allocation yfields_in',1)
- ALLOCATE(fields_out(klon,nbcf_out),stat=error)
- IF (error /= 0)  CALL abort_physic(modname,'Pb in allocation fields_out',1)
- ALLOCATE(yfields_out(klon,nbcf_out),stat=error)
- IF (error /= 0)  CALL abort_physic(modname,'Pb in allocation yfields_out',1)
-
-END SUBROUTINE infocfields_init
-
-END MODULE carbon_cycle_mod
Index: /LMDZ6/trunk/libf/phylmd/carbon_cycle_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/carbon_cycle_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/carbon_cycle_mod.f90	(revision 5268)
@@ -0,0 +1,542 @@
+MODULE carbon_cycle_mod
+!=======================================================================
+!   Authors: Patricia Cadule and Laurent Fairhead
+!            base sur un travail anterieur mene par Patricia Cadule et Josefine Ghattas
+!
+!  Purpose and description:
+!  -----------------------
+! Control module for the carbon CO2 tracers :
+!   - Initialisation of carbon cycle fields
+!   - Definition of fluxes to be exchanged
+!
+! Rest of code is in tracco2i.F90
+!
+! Le cas online/offline est defini par le flag carbon_cycle_cpl (y/n)
+! Le transport du traceur CO2 est defini par le flag carbon_cycle_tr (y/n)
+! la provenance des champs (termes de puits) est denini par le flag level_coupling_esm
+!
+! level_coupling_esm : level of coupling of the biogeochemical fields between
+! LMDZ, ORCHIDEE and NEMO
+! Definitions of level_coupling_esm in physiq.def
+! level_coupling_esm = 0  ! No field exchange between LMDZ and ORCHIDEE models
+!                         ! No field exchange between LMDZ and NEMO
+! level_coupling_esm = 1  ! Field exchange between LMDZ and ORCHIDEE models
+!                         ! No field exchange between LMDZ and NEMO models
+! level_coupling_esm = 2  ! No field exchange between LMDZ and ORCHIDEE models
+!                         ! Field exchange between LMDZ and NEMO models
+! level_coupling_esm = 3  ! Field exchange between LMDZ and ORCHIDEE models
+!                         ! Field exchange between LMDZ and NEMO models
+!=======================================================================
+
+  IMPLICIT NONE
+  SAVE
+  PRIVATE
+  PUBLIC :: carbon_cycle_init, infocfields_init
+
+! Variables read from parmeter file physiq.def
+  LOGICAL, PUBLIC :: carbon_cycle_cpl       ! Coupling of CO2 fluxes between LMDZ/ORCHIDEE and LMDZ/OCEAN(PISCES) 
+!$OMP THREADPRIVATE(carbon_cycle_cpl)
+  LOGICAL, PUBLIC :: carbon_cycle_tr        ! 3D transport of CO2 in the atmosphere, parameter read in conf_phys
+!$OMP THREADPRIVATE(carbon_cycle_tr)
+  LOGICAL, PUBLIC :: carbon_cycle_rad       ! flag to activate CO2 interactive radiatively 
+!$OMP THREADPRIVATE(carbon_cycle_rad)
+  INTEGER, PUBLIC :: level_coupling_esm     ! Level of coupling for the ESM - 0, 1, 2, 3
+!$OMP THREADPRIVATE(level_coupling_esm)
+  LOGICAL, PUBLIC :: read_fco2_ocean_cor    ! flag to read corrective oceanic CO2 flux
+!$OMP THREADPRIVATE(read_fco2_ocean_cor)  
+  REAL, PUBLIC :: var_fco2_ocean_cor        ! corrective oceanic CO2 flux
+!$OMP THREADPRIVATE(var_fco2_ocean_cor)
+  REAL, PUBLIC :: ocean_area_tot            ! total oceanic area to convert flux
+!$OMP THREADPRIVATE(ocean_area_tot)
+  LOGICAL, PUBLIC :: read_fco2_land_cor     ! flag to read corrective land CO2 flux
+!$OMP THREADPRIVATE(read_fco2_land_cor)  
+  REAL, PUBLIC :: var_fco2_land_cor         ! corrective land CO2 flux
+!$OMP THREADPRIVATE(var_fco2_land_cor)
+  REAL, PUBLIC :: land_area_tot             ! total land area to convert flux
+!$OMP THREADPRIVATE(land_area_tot)
+
+  REAL, PUBLIC :: RCO2_glo
+!$OMP THREADPRIVATE(RCO2_glo)
+  REAL, PUBLIC :: RCO2_tot
+!$OMP THREADPRIVATE(RCO2_tot)
+
+  LOGICAL :: carbon_cycle_emis_comp_omp=.FALSE.
+  LOGICAL :: carbon_cycle_emis_comp=.FALSE. ! Calculation of emission compatible
+!$OMP THREADPRIVATE(carbon_cycle_emis_comp)
+
+  LOGICAL :: RCO2_inter_omp
+  LOGICAL :: RCO2_inter  ! RCO2 interactive : if true calculate new value RCO2 for the radiation scheme
+!$OMP THREADPRIVATE(RCO2_inter)
+
+! Scalare values when no transport, from physiq.def
+  REAL :: fos_fuel_s_omp
+  REAL :: fos_fuel_s  ! carbon_cycle_fos_fuel dans physiq.def
+!$OMP THREADPRIVATE(fos_fuel_s)
+  REAL :: emis_land_s ! not yet implemented
+!$OMP THREADPRIVATE(emis_land_s)
+
+  REAL :: airetot     ! Total area of the earth surface
+!$OMP THREADPRIVATE(airetot)
+
+  INTEGER :: ntr_co2  ! Number of tracers concerning the carbon cycle
+!$OMP THREADPRIVATE(ntr_co2)
+
+! fco2_ocn_day : flux CO2 from ocean for 1 day (cumulated) [gC/m2/d]. Allocation and initalization done in cpl_mod
+  REAL, DIMENSION(:), ALLOCATABLE, PUBLIC :: fco2_ocn_day 
+!$OMP THREADPRIVATE(fco2_ocn_day)
+
+  REAL, DIMENSION(:), ALLOCATABLE :: fco2_land_day   ! flux CO2 from land for 1 day (cumulated)  [gC/m2/d]
+!$OMP THREADPRIVATE(fco2_land_day)
+  REAL, DIMENSION(:), ALLOCATABLE :: fco2_lu_day     ! Emission from land use change for 1 day (cumulated) [gC/m2/d]
+!$OMP THREADPRIVATE(fco2_lu_day)
+  REAL, DIMENSION(:), ALLOCATABLE, PUBLIC :: fco2_ff ! Emission from fossil fuel [kgCO2/m2/s]
+!$OMP THREADPRIVATE(fco2_ff)
+  REAL, DIMENSION(:), ALLOCATABLE, PUBLIC :: fco2_bb ! Emission from biomass burning [kgCO2/m2/s]
+!$OMP THREADPRIVATE(fco2_bb)
+  REAL, DIMENSION(:), ALLOCATABLE, PUBLIC :: fco2_land  ! Net flux from terrestrial ecocsystems [kgCO2/m2/s]
+!$OMP THREADPRIVATE(fco2_land)
+  REAL, DIMENSION(:), ALLOCATABLE, PUBLIC :: fco2_land_nbp  ! Net flux from terrestrial ecocsystems [kgCO2/m2/s]
+!$OMP THREADPRIVATE(fco2_land_nbp)
+  REAL, DIMENSION(:), ALLOCATABLE, PUBLIC :: fco2_land_nep  ! Net flux from terrestrial ecocsystems [kgCO2/m2/s]
+!$OMP THREADPRIVATE(fco2_land_nep)
+  REAL, DIMENSION(:), ALLOCATABLE, PUBLIC :: fco2_land_fLuc  ! Net flux from terrestrial ecocsystems [kgCO2/m2/s]
+!$OMP THREADPRIVATE(fco2_land_fLuc)
+  REAL, DIMENSION(:), ALLOCATABLE, PUBLIC :: fco2_land_fwoodharvest  ! Net flux from terrestrial ecocsystems [kgCO2/m2/s]
+!$OMP THREADPRIVATE(fco2_land_fwoodharvest)
+  REAL, DIMENSION(:), ALLOCATABLE, PUBLIC :: fco2_land_fHarvest  ! Net flux from terrestrial ecocsystems [kgCO2/m2/s]
+!$OMP THREADPRIVATE(fco2_land_fHarvest)
+  REAL, DIMENSION(:), ALLOCATABLE, PUBLIC :: fco2_ocean ! Net flux from ocean [kgCO2/m2/s]
+!$OMP THREADPRIVATE(fco2_ocean)
+  REAL, DIMENSION(:), ALLOCATABLE, PUBLIC :: fco2_ocean_cor ! Net corrective flux from ocean [kgCO2/m2/s]
+!$OMP THREADPRIVATE(fco2_ocean_cor)
+  REAL, DIMENSION(:), ALLOCATABLE, PUBLIC :: fco2_land_cor  ! Net corrective flux from land [kgCO2/m2/s]
+!$OMP THREADPRIVATE(fco2_land_cor)
+
+  REAL, DIMENSION(:,:), ALLOCATABLE :: dtr_add       ! Tracer concentration to be injected 
+!$OMP THREADPRIVATE(dtr_add)
+
+! Following 2 fields will be allocated and initialized in surf_land_orchidee
+  REAL, DIMENSION(:), ALLOCATABLE, PUBLIC :: fco2_land_inst  ! flux CO2 from land at one time step
+!$OMP THREADPRIVATE(fco2_land_inst)
+  REAL, DIMENSION(:), ALLOCATABLE, PUBLIC :: fco2_lu_inst    ! Emission from land use change at one time step
+!$OMP THREADPRIVATE(fco2_lu_inst)
+
+! Calculated co2 field to be send to the ocean via the coupler and to ORCHIDEE 
+  REAL, DIMENSION(:), ALLOCATABLE, PUBLIC :: co2_send ! Field allocated in phyetat0
+!$OMP THREADPRIVATE(co2_send)
+
+  INTEGER, PARAMETER, PUBLIC :: id_CO2=1              !--temporaire OB -- to be changed
+
+! nbfields : total number of fields 
+  INTEGER, PUBLIC :: nbcf
+!$OMP THREADPRIVATE(nbcf)
+
+! nbcf_in : number of fields IN
+  INTEGER, PUBLIC  :: nbcf_in
+!$OMP THREADPRIVATE(nbcf_in)
+
+! nbcf_in_orc : number of fields IN 
+  INTEGER, PUBLIC  :: nbcf_in_orc
+!$OMP THREADPRIVATE(nbcf_in_orc)
+
+! nbcf_in_inca : number of fields IN (from INCA)
+  INTEGER, PUBLIC  :: nbcf_in_inca
+!$OMP THREADPRIVATE(nbcf_in_inca)
+
+! nbcf_in_nemo : number of fields IN (from nemo)
+  INTEGER, PUBLIC  :: nbcf_in_nemo
+!$OMP THREADPRIVATE(nbcf_in_nemo)
+
+! nbcf_in_ant : number of fields IN (from anthropogenic sources)
+  INTEGER, PUBLIC  :: nbcf_in_ant
+!$OMP THREADPRIVATE(nbcf_in_ant)
+
+! nbcf_out : number of fields OUT
+  INTEGER, PUBLIC :: nbcf_out
+!$OMP THREADPRIVATE(nbcf_out)
+
+! Name of variables
+  CHARACTER(len=25), ALLOCATABLE, DIMENSION(:), PUBLIC :: cfname     ! coupling field short name for restart (?) and diagnostics
+!$OMP THREADPRIVATE(cfname)
+
+  CHARACTER(len=25), ALLOCATABLE, DIMENSION(:), PUBLIC :: cfname_in  ! coupling field short name for restart (?) and diagnostics
+!$OMP THREADPRIVATE(cfname_in)
+
+  CHARACTER(len=25), ALLOCATABLE, DIMENSION(:), PUBLIC :: cfname_out ! coupling field short name for restart (?) and diagnostics
+!$OMP THREADPRIVATE(cfname_out)
+
+  CHARACTER(len=15), ALLOCATABLE, DIMENSION(:), PUBLIC :: cfunits_in  !  coupling field units for diagnostics
+!$OMP THREADPRIVATE(cfunits_in)
+
+  CHARACTER(len=15), ALLOCATABLE, DIMENSION(:), PUBLIC :: cfunits_out !  coupling field units for diagnostics
+!$OMP THREADPRIVATE(cfunits_out)
+
+  CHARACTER(len=120), ALLOCATABLE, DIMENSION(:), PUBLIC :: cftext_in  ! coupling field long name for diagnostics
+!$OMP THREADPRIVATE(cftext_in)
+
+  CHARACTER(len=120), ALLOCATABLE, DIMENSION(:), PUBLIC :: cftext_out ! coupling field long name for diagnostics
+!$OMP THREADPRIVATE(cftext_out)
+
+  CHARACTER(len=5), ALLOCATABLE, DIMENSION(:), PUBLIC :: cfmod1 ! model 1 (rreference) : LMDz
+!$OMP THREADPRIVATE(cfmod1)
+
+  CHARACTER(len=5), ALLOCATABLE, DIMENSION(:), PUBLIC :: cfmod2 ! model 2
+!$OMP THREADPRIVATE(cfmod2)
+
+  CHARACTER(LEN=20), ALLOCATABLE, DIMENSION(:), PUBLIC :: field_out_names
+!$OMP THREADPRIVATE(field_out_names)
+
+  CHARACTER(LEN=20), ALLOCATABLE, DIMENSION(:), PUBLIC :: field_in_names
+!$OMP THREADPRIVATE(field_in_names)
+
+  REAL, ALLOCATABLE, DIMENSION(:,:), PUBLIC :: fields_in   !  klon,nbcf_in
+!$OMP THREADPRIVATE(fields_in)
+
+  REAL, ALLOCATABLE, DIMENSION(:,:), PUBLIC :: yfields_in  !  knon,nbcf_in
+!$OMP THREADPRIVATE(yfields_in)
+
+  REAL, ALLOCATABLE, DIMENSION(:,:), PUBLIC :: fields_out  !  klon,nbcf_out
+!$OMP THREADPRIVATE(fields_out)
+
+  REAL, ALLOCATABLE, DIMENSION(:,:), PUBLIC :: yfields_out !  knon,nbcf_out
+!$OMP THREADPRIVATE(yfields_out)
+
+  TYPE, PUBLIC :: co2_trac_type
+     CHARACTER(len = 8) :: name       ! Tracer name in tracer.def
+     INTEGER            :: id         ! Index in total tracer list, tr_seri
+     CHARACTER(len=30)  :: file       ! File name
+     LOGICAL            :: cpl        ! True if this tracers is coupled from ORCHIDEE or PISCES. 
+                                      ! False if read from file.
+     INTEGER            :: updatefreq ! Frequence to inject in second
+     INTEGER            :: readstep   ! Actual time step to read in file
+     LOGICAL            :: updatenow  ! True if this tracer should be updated this time step
+  END TYPE co2_trac_type
+  INTEGER,PARAMETER :: maxco2trac=5  ! Maximum number of different CO2 fluxes
+  TYPE(co2_trac_type), DIMENSION(maxco2trac) :: co2trac
+
+CONTAINS
+  
+  SUBROUTINE carbon_cycle_init()
+    ! This subroutine is called from tracco2i_init, which is called from phytrac_init only at first timestep.
+    ! - Allocate variables. These variables must be allocated before first call to phys_output_write in physiq.
+
+    USE dimphy
+    USE IOIPSL
+    USE print_control_mod, ONLY: lunout
+
+    IMPLICIT NONE
+    INCLUDE "clesphys.h"
+ 
+! Local variables
+    INTEGER               :: ierr
+
+    IF (carbon_cycle_cpl) THEN
+
+       ierr=0
+
+       IF (.NOT.ALLOCATED(fco2_land)) ALLOCATE(fco2_land(klon), stat=ierr)
+       IF (ierr /= 0) CALL abort_physic('carbon_cycle_init', 'pb in allocation fco2_land',1)
+
+       IF (.NOT.ALLOCATED(fco2_land_nbp)) ALLOCATE(fco2_land_nbp(klon), stat=ierr)
+       IF (ierr /= 0) CALL abort_physic('carbon_cycle_init', 'pb in allocation fco2_land_nbp',1)
+
+       IF (.NOT.ALLOCATED(fco2_land_nep)) ALLOCATE(fco2_land_nep(klon), stat=ierr)
+       IF (ierr /= 0) CALL abort_physic('carbon_cycle_init', 'pb in allocation fco2_land_nep',1)
+
+       IF (.NOT.ALLOCATED(fco2_land_fLuc)) ALLOCATE(fco2_land_fLuc(klon), stat=ierr)
+       IF (ierr /= 0) CALL abort_physic('carbon_cycle_init', 'pb in allocation fco2_land_fLuc',1)
+
+       IF (.NOT.ALLOCATED(fco2_land_fwoodharvest)) ALLOCATE(fco2_land_fwoodharvest(klon), stat=ierr)
+       IF (ierr /= 0) CALL abort_physic('carbon_cycle_init', 'pb in allocation fco2_land_fwoodharvest',1)
+
+       IF (.NOT.ALLOCATED(fco2_land_fHarvest)) ALLOCATE(fco2_land_fHarvest(klon), stat=ierr)
+       IF (ierr /= 0) CALL abort_physic('carbon_cycle_init', 'pb in allocation fco2_land_fHarvest',1)
+
+       IF (.NOT.ALLOCATED(fco2_ff)) ALLOCATE(fco2_ff(klon), stat=ierr)
+       IF (ierr /= 0) CALL abort_physic('carbon_cycle_init', 'pb in allocation fco2_ff',1)
+
+       IF (.NOT.ALLOCATED(fco2_bb)) ALLOCATE(fco2_bb(klon), stat=ierr)
+       IF (ierr /= 0) CALL abort_physic('carbon_cycle_init', 'pb in allocation fco2_bb',1)
+
+       IF (.NOT.ALLOCATED(fco2_ocean)) ALLOCATE(fco2_ocean(klon), stat=ierr)
+       IF (ierr /= 0) CALL abort_physic('carbon_cycle_init', 'pb in allocation fco2_ocean',1)
+
+       IF (.NOT.ALLOCATED(fco2_ocean_cor)) ALLOCATE(fco2_ocean_cor(klon), stat=ierr)
+       IF (ierr /= 0) CALL abort_physic('carbon_cycle_init', 'pb in allocation fco2_ocean_cor',1)
+
+       IF (.NOT.ALLOCATED(fco2_land_cor)) ALLOCATE(fco2_land_cor(klon), stat=ierr)
+       IF (ierr /= 0) CALL abort_physic('carbon_cycle_init', 'pb in allocation fco2_land_cor',1)
+
+    ENDIF
+
+  END SUBROUTINE carbon_cycle_init
+
+  SUBROUTINE infocfields_init
+
+!    USE control_mod, ONLY: planet_type
+    USE phys_cal_mod, ONLY : mth_cur
+    USE mod_synchro_omp
+    USE mod_phys_lmdz_para, ONLY: is_mpi_root, is_omp_root
+    USE mod_phys_lmdz_transfert_para
+    USE mod_phys_lmdz_omp_transfert
+    USE dimphy, ONLY: klon
+
+    IMPLICIT NONE
+
+!=======================================================================
+!
+!   Authors: Patricia Cadule and Laurent Fairhead  
+!   -------
+!
+!  Purpose and description:
+!  -----------------------
+!
+! Infofields
+! this routine enables to define the field exchanges in both directions between
+! the atmospheric circulation model (LMDZ) and ORCHIDEE. In the future this
+! routing might apply to other models (e.g., NEMO, INCA, ...).
+! Therefore, currently with this routine, it is possible to define the coupling
+! fields only between LMDZ and ORCHIDEE.
+! The coupling_fields.def file enables to define the name of the exchanged
+! fields at the coupling interface.
+! field_in_names : the set of names of the exchanged fields in input to ORCHIDEE
+! (LMDZ to ORCHIDEE)
+! field_out_names : the set of names of the exchanged fields in output of
+! ORCHIDEE (ORCHIDEE to LMDZ)
+! n : the number of exchanged fields at th coupling interface
+! nb_fields_in : number of inputs fields to ORCHIDEE (LMDZ to ORCHIDEE)
+! nb_fields_out : number of ouput fields of ORCHIDEE (ORCHIDEE to LMDZ)
+!
+! The syntax for coupling_fields.def is as follows:
+! IMPORTANT: each column entry must be separated from the previous one by 3
+! spaces and only that
+! field name         coupling          model 1         model 2         long_name
+!                    direction
+!   10char  -3spaces-  3char  -3spaces- 4char -3spaces- 4char -3spaces-  30char 
+!
+! n
+! FIELD1 IN LMDZ ORC
+! ....
+! FIELD(j) IN LMDZ ORC
+! FIELD(j+1) OUT LMDZ ORC
+! ...
+! FIELDn OUT LMDZ ORC   
+! 
+!=======================================================================
+!   ... 22/12/2017 ....
+!-----------------------------------------------------------------------
+! Declarations
+
+  INCLUDE "clesphys.h"
+  INCLUDE "dimensions.h"
+  INCLUDE "iniprint.h"
+
+! Local variables
+
+  INTEGER :: iq,  ierr, stat, error
+
+  CHARACTER(LEN=20), ALLOCATABLE, DIMENSION(:), SAVE  :: cfname_root
+  CHARACTER(LEN=120), ALLOCATABLE, DIMENSION(:), SAVE :: cftext_root
+  CHARACTER(LEN=15), ALLOCATABLE, DIMENSION(:), SAVE  :: cfunits_root
+
+  CHARACTER(len=3), ALLOCATABLE, DIMENSION(:) :: cfintent_root
+  CHARACTER(len=5), ALLOCATABLE, DIMENSION(:) :: cfmod1_root
+  CHARACTER(len=5), ALLOCATABLE, DIMENSION(:) :: cfmod2_root
+
+  LOGICAL, ALLOCATABLE, DIMENSION(:), SAVE :: mask_in_root
+  LOGICAL, ALLOCATABLE, DIMENSION(:), SAVE :: mask_out_root
+
+  CHARACTER(len=*),parameter :: modname="infocfields"
+
+  CHARACTER(len=10),SAVE :: planet_type="earth"
+
+!-----------------------------------------------------------------------
+
+nbcf=0
+nbcf_in=0
+nbcf_out=0
+
+IF (planet_type=='earth') THEN
+
+    IF (is_mpi_root .AND. is_omp_root) THEN
+
+       IF (level_coupling_esm.GT.0) THEN
+
+          OPEN(200,file='coupling_fields.def',form='formatted',status='old', iostat=ierr)
+
+          IF (ierr.EQ.0) THEN
+
+             WRITE(lunout,*) trim(modname),': Open coupling_fields.def : ok'
+             READ(200,*) nbcf
+             WRITE(lunout,*) 'infocfields_mod.F90 --- nbcf=',nbcf
+             ALLOCATE(cfname_root(nbcf))
+             ALLOCATE(cfintent_root(nbcf))
+             ALLOCATE(cfmod1_root(nbcf))
+             ALLOCATE(cfmod2_root(nbcf))
+             ALLOCATE(cftext_root(nbcf))
+             ALLOCATE(cfunits_root(nbcf))
+             ALLOCATE(mask_in_root(nbcf))
+             ALLOCATE(mask_out_root(nbcf))
+
+             nbcf_in=0
+             nbcf_out=0
+
+             DO iq=1,nbcf
+                WRITE(lunout,*) 'infofields : field=',iq
+                READ(200,'(A15,3X,A3,3X,A5,3X,A5,3X,A120,3X,A15)',IOSTAT=ierr) &
+                   cfname_root(iq),cfintent_root(iq),cfmod1_root(iq),cfmod2_root(iq),cftext_root(iq),cfunits_root(iq)
+                cfname_root(iq)=TRIM(cfname_root(iq))
+                cfintent_root(iq)=TRIM(cfintent_root(iq))
+                cfmod1_root(iq)=TRIM(cfmod1_root(iq))
+                cfmod2_root(iq)=TRIM(cfmod2_root(iq))
+                cftext_root(iq)=TRIM(cftext_root(iq))
+                cfunits_root(iq)=TRIM(cfunits_root(iq))
+                WRITE(lunout,*) 'coupling field: ',cfname_root(iq), &  
+                               ', number: ',iq,', INTENT: ',cfintent_root(iq)
+                WRITE(lunout,*) 'coupling field: ',cfname_root(iq), & 
+                               ', number: ',iq,', model 1 (ref): ',cfmod1_root(iq),', model 2: ',cfmod2_root(iq)
+                WRITE(lunout,*) 'coupling field: ',cfname_root(iq), & 
+                               ', number: ',iq,', long name: ',cftext_root(iq),', units ',cfunits_root(iq)
+                IF (nbcf_in+nbcf_out.LT.nbcf) THEN
+                  IF (cfintent_root(iq).NE.'OUT') THEN
+                    nbcf_in=nbcf_in+1
+                    mask_in_root(iq)=.TRUE.
+                    mask_out_root(iq)=.FALSE.
+                  ELSE IF (cfintent_root(iq).EQ.'OUT') THEN
+                    nbcf_out=nbcf_out+1
+                    mask_in_root(iq)=.FALSE.
+                    mask_out_root(iq)=.TRUE.
+                  ENDIF
+                ELSE
+                  WRITE(lunout,*) 'abort_gcm --- nbcf    : ',nbcf
+                  WRITE(lunout,*) 'abort_gcm --- nbcf_in : ',nbcf_in
+                  WRITE(lunout,*) 'abort_gcm --- nbcf_out: ',nbcf_out
+                  CALL abort_physic('infocfields_init','Problem in the definition of the coupling fields',1)
+               ENDIF
+             ENDDO !DO iq=1,nbcf
+          ELSE
+             WRITE(lunout,*) trim(modname),': infocfields_mod.F90 --- Problem in opening coupling_fields.def'
+             WRITE(lunout,*) trim(modname),': infocfields_mod.F90 --- WARNING using defaut values'
+          ENDIF ! ierr
+          CLOSE(200)
+
+       ENDIF ! level_coupling_esm
+
+    ENDIF !   (is_mpi_root .AND. is_omp_root)
+!$OMP BARRIER
+
+    CALL bcast(nbcf)
+    CALL bcast(nbcf_in)
+    CALL bcast(nbcf_out)
+
+    WRITE(lunout,*) 'infocfields_mod.F90 --- nbcf    =',nbcf
+    WRITE(lunout,*) 'infocfields_mod.F90 --- nbcf_in =',nbcf_in
+    WRITE(lunout,*) 'infocfields_mod.F90 --- nbcf_out=',nbcf_out
+
+    ALLOCATE(cfname(nbcf))
+    ALLOCATE(cfname_in(nbcf_in))
+    ALLOCATE(cftext_in(nbcf_in))
+    ALLOCATE(cfname_out(nbcf_out))
+    ALLOCATE(cftext_out(nbcf_out))
+    ALLOCATE(cfmod1(nbcf))
+    ALLOCATE(cfmod2(nbcf))
+    ALLOCATE(cfunits_in(nbcf_in))
+    ALLOCATE(cfunits_out(nbcf_out))
+       
+    IF (is_mpi_root .AND. is_omp_root) THEN
+
+        IF (nbcf.GT.0)     cfname=cfname_root
+        IF (nbcf_in.GT.0)  cfname_in=PACK(cfname_root,mask_in_root)
+        IF (nbcf_out.GT.0) cfname_out=PACK(cfname_root,mask_out_root)
+        IF (nbcf_in.GT.0)  cftext_in=PACK(cftext_root,mask_in_root)
+        IF (nbcf_out.GT.0) cftext_out=PACK(cftext_root,mask_out_root)
+        IF (nbcf.GT.0)     cfmod1=cfmod1_root
+        IF (nbcf.GT.0)     cfmod2=cfmod2_root
+        IF (nbcf_in.GT.0)  cfunits_in=PACK(cfunits_root,mask_in_root)
+        IF (nbcf_out.GT.0) cfunits_out=PACK(cfunits_root,mask_out_root)
+
+        nbcf_in_orc=0
+        nbcf_in_nemo=0
+        nbcf_in_inca=0
+        nbcf_in_ant=0
+
+        DO iq=1,nbcf
+            IF (cfmod1(iq) == "ORC")  nbcf_in_orc  = nbcf_in_orc  + 1  
+            IF (cfmod1(iq) == "NEMO") nbcf_in_nemo = nbcf_in_nemo + 1  
+            IF (cfmod1(iq) == "INCA") nbcf_in_inca = nbcf_in_inca + 1
+            IF (cfmod1(iq) == "ALL")  nbcf_in_orc  = nbcf_in_orc  + 1  ! ALL = ORC/NEMO/INCA
+            IF (cfmod1(iq) == "ALL")  nbcf_in_nemo = nbcf_in_nemo + 1  ! ALL = ORC/NEMO/INCA 
+            IF (cfmod1(iq) == "ALL")  nbcf_in_inca = nbcf_in_inca + 1  ! ALL = ORC/NEMO/INCA 
+            IF (cfmod1(iq) == "ANT")  nbcf_in_ant  = nbcf_in_ant  + 1  
+        ENDDO
+
+    ENDIF !   (is_mpi_root .AND. is_omp_root)
+!$OMP BARRIER
+
+    CALL bcast(nbcf_in_orc)
+    CALL bcast(nbcf_in_nemo)
+    CALL bcast(nbcf_in_inca)
+    CALL bcast(nbcf_in_ant)
+
+    WRITE(lunout,*) 'nbcf_in_orc  =',nbcf_in_orc
+    WRITE(lunout,*) 'nbcf_in_nemo =',nbcf_in_nemo
+    WRITE(lunout,*) 'nbcf_in_inca =',nbcf_in_inca
+    WRITE(lunout,*) 'nbcf_in_ant  =',nbcf_in_ant
+
+    IF (nbcf_in.GT.0) THEN 
+        DO iq=1,nbcf_in
+          CALL bcast(cfname_in(iq))
+          CALL bcast(cftext_in(iq))
+          CALL bcast(cfunits_in(iq))
+        ENDDO
+    ENDIF
+
+    IF (nbcf_out.GT.0) THEN
+        DO iq=1,nbcf_out
+          CALL bcast(cfname_out(iq))
+          CALL bcast(cftext_out(iq))
+          CALL bcast(cfunits_out(iq))
+        ENDDO
+    ENDIF
+
+    IF (nbcf.GT.0) THEN
+        DO iq=1,nbcf
+          CALL bcast(cfmod1(iq))
+          CALL bcast(cfmod2(iq))
+        ENDDO
+    ENDIF
+
+    IF (nbcf_in.GT.0)  WRITE(lunout,*)'infocfields_mod --- cfname_in: ',cfname_in
+    IF (nbcf_out.GT.0) WRITE(lunout,*)'infocfields_mod --- cfname_out: ',cfname_out
+
+    IF (nbcf_in.GT.0)  WRITE(lunout,*)'infocfields_mod --- cftext_in: ',cftext_in
+    IF (nbcf_out.GT.0) WRITE(lunout,*)'infocfields_mod --- cftext_out: ',cftext_out
+
+    IF (nbcf.GT.0) WRITE(lunout,*)'infocfields_mod --- cfmod1: ',cfmod1 
+    IF (nbcf.GT.0) WRITE(lunout,*)'infocfields_mod --- cfmod2: ',cfmod2 
+
+    IF (nbcf_in.GT.0)  WRITE(lunout,*)'infocfunits_mod --- cfunits_in: ',cfunits_in
+    IF (nbcf_out.GT.0) WRITE(lunout,*)'infocfunits_mod --- cfunits_out: ',cfunits_out
+
+    IF (nbcf_in.GT.0)  WRITE(*,*)'infocfields_init --- number of fields in to LMDZ: ',nbcf_in
+    IF (nbcf_out.GT.0) WRITE(*,*)'infocfields_init --- number of fields out of LMDZ: ',nbcf_out
+
+ ELSE
+ ! Default values for other planets
+    nbcf=0 
+    nbcf_in=0
+    nbcf_out=0
+ ENDIF ! planet_type
+
+ ALLOCATE(fields_in(klon,nbcf_in),stat=error)
+ IF (error /= 0)  CALL abort_physic(modname,'Pb in allocation fields_in',1)
+ ALLOCATE(yfields_in(klon,nbcf_in),stat=error)
+ IF (error /= 0)  CALL abort_physic(modname,'Pb in allocation yfields_in',1)
+ ALLOCATE(fields_out(klon,nbcf_out),stat=error)
+ IF (error /= 0)  CALL abort_physic(modname,'Pb in allocation fields_out',1)
+ ALLOCATE(yfields_out(klon,nbcf_out),stat=error)
+ IF (error /= 0)  CALL abort_physic(modname,'Pb in allocation yfields_out',1)
+
+END SUBROUTINE infocfields_init
+
+END MODULE carbon_cycle_mod
Index: DZ6/trunk/libf/phylmd/cdrag_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cdrag_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,643 +1,0 @@
-!
-!$Id$
-!
-!
-MODULE cdrag_mod
-!
-! This module contains some procedures for calculation of the cdrag
-! coefficients for turbulent diffusion at surface
-!
-  IMPLICIT NONE
-
-CONTAINS
-!
-!****************************************************************************************
-!
-!r original routine svn3623
-!
- SUBROUTINE cdrag(knon,  nsrf,   &
-     speed, t1,    q1,    zgeop1, &
-     psol, pblh,  tsurf, qsurf, z0m, z0h,  &
-     ri_in, iri_in, &
-     cdm,  cdh,  zri,   pref, prain, tsol , pat1)
-
-  USE dimphy
-  USE coare_cp_mod, ONLY: coare_cp
-  USE coare30_flux_cnrm_mod, ONLY: coare30_flux_cnrm
-  USE indice_sol_mod
-  USE print_control_mod, ONLY: lunout, prt_level
-  USE ioipsl_getin_p_mod, ONLY : getin_p
-  USE lmdz_atke_turbulence_ini, ONLY : smmin, ric, cinf, cepsilon, pr_slope, pr_asym, pr_neut
-
-  IMPLICIT NONE
-! ================================================================= c
-!
-! Objet : calcul des cdrags pour le moment (pcfm) et 
-!         les flux de chaleur sensible et latente (pcfh) d'apr??s
-!         Louis 1982, Louis 1979, King et al 2001
-!         ou Zilitinkevich et al 2002  pour les cas stables, Louis 1979
-!         et 1982 pour les cas instables 
-!
-! Modified history: 
-!  writting on the 20/05/2016
-!  modified on the 13/12/2016 to be adapted to LMDZ6
-!
-! References:
-!   Louis, J. F., 1979: A parametric model of vertical eddy fluxes in the
-!     atmosphere. Boundary-Layer Meteorology. 01/1979; 17(2):187-202. 
-!   Louis, J. F., Tiedtke, M. and Geleyn, J. F., 1982: `A short history of the
-!     operational PBL parametrization at ECMWF'. Workshop on boundary layer
-!     parametrization, November 1981, ECMWF, Reading, England. 
-!     Page: 19. Equations in Table 1.
-!   Mascart P, Noilhan J, Giordani H 1995.A MODIFIED PARAMETERIZATION OF FLUX-PROFILE RELATIONSHIPS 
-!    IN THE SURFACE LAYER USING DIFFERENT ROUGHNESS LENGTH VALUES FOR HEAT AND MOMENTUM
-!    Boundary-Layer Meteorology 72: 331-344
-!   Anton Beljaars. May 1992. The parametrization of the planetary boundary layer.  
-!     European Centre for Medium-Range Weather Forecasts.
-!     Equations: 110-113. Page 40.
-!   Miller,M.J., A.C.M.Beljaars, T.N.Palmer. 1992. The sensitivity of the ECMWF
-!     model to the parameterization of evaporation from the tropical oceans. J.
-!     Climate, 5:418-434.
-!   King J.C, Connolley, W.M ad Derbyshire S.H. 2001, Sensitivity of Modelled Antarctic climate
-!   to surface and boundary-layer flux parametrizations
-!   QJRMS, 127, pp 779-794
-!
-! ================================================================= c
-! ================================================================= c
-! On choisit le couple de fonctions de correction avec deux flags:
-! Un pour les cas instables, un autre pour les cas stables
-!
-! iflag_corr_insta:
-!                   1: Louis 1979 avec les modifications de Mascart 1995 (z0/= z0h)
-!                   2: Louis 1982 
-!                   3: Laurent Li
-!
-! iflag_corr_sta:
-!                   1: Louis 1979 avec les modifications de Mascart 1995 (z0/= z0h)
-!                   2: Louis 1982 
-!                   3: Laurent Li
-!                   4: King  2001 (SHARP)
-!                   5: MO 1st order theory (allow collapse of turbulence)
-!            
-!
-!*****************************************************************
-! Parametres d'entree
-!***************************************************************** 
-  
-  INTEGER, INTENT(IN)                      :: knon, nsrf ! nombre de points de grille sur l'horizontal + type de surface
-  REAL, DIMENSION(klon), INTENT(IN)        :: speed    ! module du vent au 1er niveau du modele
-  REAL, DIMENSION(klon), INTENT(IN)        :: zgeop1   ! geopotentiel au 1er niveau du modele
-  REAL, DIMENSION(klon), INTENT(IN)        :: tsurf    ! Surface temperature (K)
-  REAL, DIMENSION(klon), INTENT(IN)        :: qsurf    ! Surface humidity (Kg/Kg)
-  REAL, DIMENSION(klon), INTENT(INOUT)     :: z0m, z0h ! Rugosity at surface (m) 
-  REAL, DIMENSION(klon), INTENT(IN)        :: ri_in ! Input Richardson 1st layer for first guess calculations of screen var. 
-  INTEGER, INTENT(IN)                      :: iri_in! iflag to activate cdrag calculation using ri1
-  REAL, DIMENSION(klon), INTENT(IN)        :: t1       ! Temperature au premier niveau (K) 
-  REAL, DIMENSION(klon), INTENT(IN)        :: q1       ! humidite specifique au premier niveau (kg/kg)
-  REAL, DIMENSION(klon), INTENT(IN)        :: psol     ! pression au sol
-
-!------------------ Rajout pour COARE (OT2018) --------------------
-  REAL, DIMENSION(klon), INTENT(INOUT)     :: pblh  !hauteur de CL
-  REAL, DIMENSION(klon), INTENT(IN)        :: prain !rapport au precipitation
-  REAL, DIMENSION(klon), INTENT(IN)        :: tsol  !SST imposé sur la surface oceanique
-  REAL, DIMENSION(klon), INTENT(IN)        :: pat1  !pression premier lev
-
-
-
-! Parametres de sortie
-!******************************************************************
-  REAL, DIMENSION(klon), INTENT(OUT)       :: cdm   ! Drag coefficient for momentum
-  REAL, DIMENSION(klon), INTENT(OUT)       :: cdh   ! Drag coefficient for heat flux
-  REAL, DIMENSION(klon), INTENT(OUT)       :: zri   ! Richardson number
-  REAL, DIMENSION(klon), INTENT(INOUT)       :: pref  ! Pression au niveau zgeop/RG
-
-! Variables Locales
-!******************************************************************
- 
-
-  INCLUDE "YOMCST.h"
-  INCLUDE "YOETHF.h"
-  INCLUDE "clesphys.h"
-
-
-  REAL, PARAMETER       :: CKAP=0.40, CKAPT=0.42
-  REAL                   CEPDU2
-  REAL                   ALPHA
-  REAL                   CB,CC,CD,C2,C3
-  REAL                   MU, CM, CH, B, CMstar, CHstar
-  REAL                   PM, PH, BPRIME
-  INTEGER                ng_q1                      ! Number of grids that q1 < 0.0
-  INTEGER                ng_qsurf                   ! Number of grids that qsurf < 0.0
-  INTEGER                i, k
-  REAL                   zdu2, ztsolv
-  REAL                   ztvd, zscf
-  REAL                   zucf, zcr
-  REAL, DIMENSION(klon) :: FM, FH                   ! stability functions
-  REAL, DIMENSION(klon) :: cdmn, cdhn               ! Drag coefficient in neutral conditions
-  REAL zzzcd
-  REAL, DIMENSION(klon) :: sm, prandtl              ! Stability function from atke turbulence scheme
-  REAL                  ri0, ri1, cn                ! to have dimensionless term in sm and prandtl
-
-!------------------ Rajout (OT2018) --------------------
-!------------------ Rajout pour les appelles BULK (OT) --------------------
-  REAL, DIMENSION(klon,2) :: rugos_itm 
-  REAL, DIMENSION(klon,2) :: rugos_ith 
-  REAL, PARAMETER         :: tol_it_rugos=1.e-4
-  REAL, DIMENSION(3)      :: coeffs
-  LOGICAL                 :: mixte
-  REAL                    :: z_0m
-  REAL                    :: z_0h
-  REAL, DIMENSION(klon)   :: cdmm
-  REAL, DIMENSION(klon)   :: cdhh
-
-!------------------RAJOUT POUR ECUME -------------------
-
-  REAL, DIMENSION(klon) :: PQSAT 
-  REAL, DIMENSION(klon) :: PSFTH
-  REAL, DIMENSION(klon) :: PFSTQ 
-  REAL, DIMENSION(klon) :: PUSTAR
-  REAL, DIMENSION(klon) :: PCD      ! Drag coefficient for momentum
-  REAL, DIMENSION(klon) :: PCDN     ! Drag coefficient for momentum
-  REAL, DIMENSION(klon) :: PCH      ! Drag coefficient for momentum
-  REAL, DIMENSION(klon) :: PCE      ! Drag coefficient for momentum
-  REAL, DIMENSION(klon) :: PRI 
-  REAL, DIMENSION(klon) :: PRESA
-  REAL, DIMENSION(klon) :: PSSS
-
-  LOGICAL               :: OPRECIP
-  LOGICAL               :: OPWEBB
-  LOGICAL               :: OPERTFLUX
-  LOGICAL               :: LPRECIP
-  LOGICAL               :: LPWG
-
-
-
-  LOGICAL, SAVE :: firstcall = .TRUE.
-  !$OMP THREADPRIVATE(firstcall)
-  INTEGER, SAVE :: iflag_corr_sta
-  !$OMP THREADPRIVATE(iflag_corr_sta)
-  INTEGER, SAVE :: iflag_corr_insta
-  !$OMP THREADPRIVATE(iflag_corr_insta)
-  LOGICAL, SAVE :: ok_cdrag_iter
-  !$OMP THREADPRIVATE(ok_cdrag_iter)
-
-!===================================================================c
-! Valeurs numeriques des constantes
-!===================================================================c
-
-
-! Minimum du carre du vent
-
- CEPDU2 = (0.1)**2
-
-! Louis 1982
-
-  CB=5.0
-  CC=5.0
-  CD=5.0
-
-
-! King 2001
-
-  C2=0.25
-  C3=0.0625
-
-  
-! Louis 1979
-
-  BPRIME=4.7
-  B=9.4
-  
-
-!MO
-
-  ALPHA=5.0
-
-! Consistent with atke scheme
-  cn=(1./sqrt(cepsilon))**(2./3.)
-  ri0=2./rpi*(cinf - cn)*ric/cn
-  ri1=-2./rpi * (pr_asym - pr_neut)/pr_slope
-
-
-! ================================================================= c
-! Tests avant de commencer
-! Fuxing WANG, 04/03/2015
-! To check if there are negative q1, qsurf values.
-!====================================================================c
-  ng_q1 = 0     ! Initialization
-  ng_qsurf = 0  ! Initialization
-  DO i = 1, knon
-     IF (q1(i).LT.0.0)     ng_q1 = ng_q1 + 1
-     IF (qsurf(i).LT.0.0)  ng_qsurf = ng_qsurf + 1
-  ENDDO
-  IF (ng_q1.GT.0 .and. prt_level > 5) THEN
-      WRITE(lunout,*)" *** Warning: Negative q1(humidity at 1st level) values in cdrag.F90 !"
-      WRITE(lunout,*)" The total number of the grids is: ", ng_q1
-      WRITE(lunout,*)" The negative q1 is set to zero "
-!      abort_message="voir ci-dessus"
-!      CALL abort_physic(modname,abort_message,1)
-  ENDIF
-  IF (ng_qsurf.GT.0 .and. prt_level > 5) THEN
-      WRITE(lunout,*)" *** Warning: Negative qsurf(humidity at surface) values in cdrag.F90 !"
-      WRITE(lunout,*)" The total number of the grids is: ", ng_qsurf
-      WRITE(lunout,*)" The negative qsurf is set to zero "
-!      abort_message="voir ci-dessus"
-!      CALL abort_physic(modname,abort_message,1)
-  ENDIF
-
-
-
-!=============================================================================c
-! Calcul du cdrag
-!=============================================================================c
-
-! On choisit les fonctions de stabilite utilisees au premier appel
-!**************************************************************************
- IF (firstcall) THEN
-   iflag_corr_sta=2
-   iflag_corr_insta=2
-   ok_cdrag_iter = .FALSE.
- 
-   CALL getin_p('iflag_corr_sta',iflag_corr_sta)
-   CALL getin_p('iflag_corr_insta',iflag_corr_insta)
-   CALL getin_p('ok_cdrag_iter',ok_cdrag_iter)
-
-   firstcall = .FALSE.
- ENDIF
-
-!------------------ Rajout (OT2018) --------------------
-!---------    Rajout pour itération sur rugosité     ----------------
-  rugos_itm(:,2) = z0m
-  rugos_itm(:,1) = 3.*tol_it_rugos*z0m
-
-  rugos_ith(:,2) = z0h !cp nouveau rugos_it
-  rugos_ith(:,1) = 3.*tol_it_rugos*z0h
-!--------------------------------------------------------------------
-
-!xxxxxxxxxxxxxxxxxxxxxxx
-  DO i = 1, knon        ! Boucle sur l'horizontal
-!xxxxxxxxxxxxxxxxxxxxxxx
-
-
-! calculs preliminaires:
-!***********************
-     
-     zdu2 = MAX(CEPDU2, speed(i)**2)
-     pref(i) = EXP(LOG(psol(i)) - zgeop1(i)/(RD*t1(i)* &
-          (1.+ RETV * max(q1(i),0.0))))           ! negative q1 set to zero
-     ztsolv = tsurf(i) * (1.0+RETV*max(qsurf(i),0.0))    ! negative qsurf set to zero
-     ztvd = (t1(i)+zgeop1(i)/RCPD/(1.+RVTMP2*q1(i))) &
-          *(1.+RETV*max(q1(i),0.0))                      ! negative q1 set to zero
-     
-!------------------ Rajout (OT2018) --------------------
-!--------------   ON DUPLIQUE POUR METTRE ITERATION SUR OCEAN    ------------------------     
-     IF (iri_in.EQ.1) THEN
-       zri(i) = ri_in(i)
-     ENDIF
-
-     IF (nsrf == is_oce) THEN
-        
-!------------------  Pour Core 2 choix Core Pur ou Core Mixte  --------------------
-       IF ((choix_bulk > 1 .AND. choix_bulk < 4) .AND. (nsrf .eq. is_oce)) THEN
-         IF(choix_bulk .eq. 2) THEN
-           mixte = .false.
-         ELSE
-            mixte = .true.
-         ENDIF
-         call clc_core_cp ( sqrt(zdu2),t1(i)-tsurf(i),q1(i)-qsurf(i),t1(i),q1(i),&
-             zgeop1(i)/RG, zgeop1(i)/RG,  zgeop1(i)/RG,&
-             psol(i),nit_bulk,mixte,&
-             coeffs,z_0m,z_0h)
-         cdmm(i) = coeffs(1)
-         cdhh(i) = coeffs(2)
-         cdm(i)=cdmm(i)
-         cdh(i)=cdhh(i)
-         write(*,*) "clc_core cd ch",cdmm(i),cdhh(i)
-
-!------------------                 Pour ECUME                 --------------------
-       ELSE IF ((choix_bulk .eq. 4) .and. (nsrf .eq. is_oce)) THEN
-         OPRECIP = .false.
-         OPWEBB  = .false.
-         OPERTFLUX = .false.
-         IF (nsrf .eq. is_oce) THEN
-           PSSS = 0.0
-         ENDIF
-         call ini_csts
-         call ecumev6_flux( z_0m,t1(i),tsurf(i),&
-             q1(i),qsurf(i),sqrt(zdu2),zgeop1(i)/RG,PSSS,zgeop1(i)/RG,&
-             psol(i),pat1(i), OPRECIP, OPWEBB,&
-             PSFTH,PFSTQ,PUSTAR,PCD,PCDN,&
-             PCH,PCE,PRI,PRESA,prain,&
-             z_0h,OPERTFLUX,coeffs)
-
-         cdmm(i) = coeffs(1)
-         cdhh(i) = coeffs(2)
-         cdm(i)=cdmm(i)
-         cdh(i)=cdhh(i)
-   
-         write(*,*) "ecume cd ch",cdmm(i),cdhh(i)
-
-!------------------                 Pour COARE CNRM                 --------------------
-       ELSE IF ((choix_bulk .eq. 5) .and. (nsrf .eq. is_oce)) THEN
-         LPRECIP = .false.
-         LPWG    = .false.
-         call ini_csts
-         block
-           real, dimension(1) :: z0m_1d, z_0h_1d, sqrt_zdu2_1d, zgeop1_rg_1d  ! convert scalar to 1D for call
-           z0m_1d = z0m
-           z_0h_1d = z0h
-           sqrt_zdu2_1d = sqrt(zdu2)
-           zgeop1_rg_1d=zgeop1(i)/RG
-           call coare30_flux_cnrm(z0m_1d,t1(i),tsurf(i), q1(i),  &
-               sqrt_zdu2_1d,zgeop1_rg_1d,zgeop1_rg_1d,psol(i),qsurf(i),PQSAT, &
-               PSFTH,PFSTQ,PUSTAR,PCD,PCDN,PCH,PCE,PRI, &
-               PRESA,prain,pat1(i),z_0h_1d, LPRECIP, LPWG, coeffs)
-
-         end block
-         cdmm(i) = coeffs(1)
-         cdhh(i) = coeffs(2)
-         cdm(i)=cdmm(i)
-         cdh(i)=cdhh(i)
-         write(*,*) "coare CNRM cd ch",cdmm(i),cdhh(i)
-
-!------------------                 Pour COARE Maison                 --------------------
-       ELSE IF ((choix_bulk .eq. 1) .and. (nsrf .eq. is_oce)) THEN
-         IF ( pblh(i) .eq. 0. ) THEN
-           pblh(i) = 1500.
-         ENDIF
-         write(*,*) "debug size",size(coeffs)
-         call coare_cp(sqrt(zdu2),t1(i)-tsurf(i),q1(i)-qsurf(i),&
-               t1(i),q1(i),&
-               zgeop1(i)/RG,zgeop1(i)/RG,zgeop1(i)/RG,&
-               psol(i), pblh(i),&
-               nit_bulk,&
-               coeffs,z_0m,z_0h)
-         cdmm(i) = coeffs(1)
-         cdhh(i) = coeffs(3)
-         cdm(i)=cdmm(i)
-         cdh(i)=cdhh(i)
-         write(*,*) "coare cd ch",cdmm(i),cdhh(i)
-       ELSE
-!------------------                 Pour La param LMDZ (ocean)              --------------------
-         zri(i) = zgeop1(i)*(ztvd-ztsolv)/(zdu2*ztvd)
-         IF (iri_in.EQ.1) THEN
-           zri(i) = ri_in(i)
-         ENDIF
-       ENDIF
-     
-
-!----------------------- Rajout des itérations --------------
-       DO  k=1,nit_bulk
-
-! Coefficients CD neutres : k^2/ln(z/z0) et k^2/(ln(z/z0)*ln(z/z0h)):
-!********************************************************************
-         zzzcd=CKAP/LOG(1.+zgeop1(i)/(RG*rugos_itm(i,2)))
-         cdmn(i) = zzzcd*zzzcd
-         cdhn(i) = zzzcd*(CKAP/LOG(1.+zgeop1(i)/(RG*rugos_ith(i,2))))
-
-! Calcul des fonctions de stabilite FMs, FHs, FMi, FHi :
-!*******************************************************
-         IF (zri(i) .LT. 0.) THEN    
-           SELECT CASE (iflag_corr_insta)
-             CASE (1) ! Louis 1979 + Mascart 1995
-                  MU=LOG(MAX(z0m(i)/z0h(i),0.01))
-                  CMstar=6.8741+2.6933*MU-0.3601*(MU**2)+0.0154*(MU**3)
-                  PM=0.5233-0.0815*MU+0.0135*(MU**2)-0.001*(MU**3)
-                  CHstar=3.2165+4.3431*MU+0.536*(MU**2)-0.0781*(MU**3)
-                  PH=0.5802-0.1571*MU+0.0327*(MU**2)-0.0026*(MU**3)
-                  CH=CHstar*B*CKAP/LOG(z0m(i)+zgeop1(i)/(RG*z0m(i))) &
-                     & * CKAPT/LOG(z0h(i)+zgeop1(i)/(RG*z0h(i)))       &
-                     & * ((zgeop1(i)/(RG*z0h(i)))**PH)
-                  CM=CMstar*B*CKAP/LOG(z0m(i)+zgeop1(i)/(RG*z0m(i))) &
-                     & *CKAP/LOG(z0m(i)+zgeop1(i)/(RG*z0m(i)))         &
-                     & * ((zgeop1(i)/(RG*z0m(i)))**PM)
-                  FM(i)=1.-B*zri(i)/(1.+CM*SQRT(ABS(zri(i))))
-                  FH(i)=1.-B*zri(i)/(1.+CH*SQRT(ABS(zri(i))))
-             CASE (2) ! Louis 1982
-                  zucf = 1./(1.+3.0*CB*CC*cdmn(i)*SQRT(ABS(zri(i)) &
-                        *(1.0+zgeop1(i)/(RG*z0m(i)))))
-                  FM(i) = AMAX1((1.-2.0*CB*zri(i)*zucf),f_ri_cd_min)
-                  FH(i) = AMAX1((1.-3.0*CB*zri(i)*zucf),f_ri_cd_min)
-             CASE (3) ! Laurent Li
-                  FM(i) = MAX(SQRT(1.0-18.0*zri(i)),f_ri_cd_min)
-                  FH(i) = MAX(SQRT(1.0-18.0*zri(i)),f_ri_cd_min)
-             CASE (6) ! Consistent with turbulence scheme (in stationary case) derived in atke (2023)
-                  sm(i) = 2./rpi * (cinf - cn) * atan(-zri(i)/ri0) + cn
-                  prandtl(i) = -2./rpi * (pr_asym - pr_neut) * atan(zri(i)/ri1) + pr_neut
-                  FM(i) = MAX((sm(i)**(3./2.) * sqrt(cepsilon) * (1 - zri(i) / prandtl(i))**(1./2.)),f_ri_cd_min)
-                  FH(i) = MAX((FM(i) / prandtl(i)), f_ri_cd_min)
-             CASE default ! Louis 1982
-                  zucf = 1./(1.+3.0*CB*CC*cdmn(i)*SQRT(ABS(zri(i)) &
-                         *(1.0+zgeop1(i)/(RG*z0m(i)))))
-                  FM(i) = AMAX1((1.-2.0*CB*zri(i)*zucf),f_ri_cd_min)
-                  FH(i) = AMAX1((1.-3.0*CB*zri(i)*zucf),f_ri_cd_min)
-           END SELECT
-! Calcul des drags
-           cdmm(i)=cdmn(i)*FM(i)
-           cdhh(i)=f_cdrag_ter*cdhn(i)*FH(i)
-! Traitement particulier des cas oceaniques
-! on applique Miller et al 1992 en l'absence de gustiness 
-           IF (nsrf == is_oce) THEN
-!            cdh(i)=f_cdrag_oce*cdhn(i)*FH(i)
-             IF (iflag_gusts==0) THEN
-               zcr = (0.0016/(cdmn(i)*SQRT(zdu2)))*ABS(ztvd-ztsolv)**(1./3.)
-               cdhh(i) =f_cdrag_oce* cdhn(i)*(1.0+zcr**1.25)**(1./1.25)
-             ENDIF
-             cdmm(i)=MIN(cdmm(i),cdmmax)
-             cdhh(i)=MIN(cdhh(i),cdhmax)
-!             write(*,*) "LMDZ cd ch",cdmm(i),cdhh(i)
-           END IF
-         ELSE                          
-
-!'''''''''''''''
-! Cas stables :
-!'''''''''''''''
-           zri(i) = MIN(20.,zri(i))
-           SELECT CASE (iflag_corr_sta)
-             CASE (1) ! Louis 1979 + Mascart 1995
-                  FM(i)=MAX(1./((1+BPRIME*zri(i))**2),f_ri_cd_min)
-                  FH(i)=FM(i)
-             CASE (2) ! Louis 1982
-                  zscf = SQRT(1.+CD*ABS(zri(i)))
-                  FM(i)= AMAX1(1. / (1.+2.*CB*zri(i)/zscf), f_ri_cd_min)
-                  FH(i)= AMAX1(1./ (1.+3.*CB*zri(i)*zscf), f_ri_cd_min )
-             CASE (3) ! Laurent Li
-                  FM(i)=MAX(1.0 / (1.0+10.0*zri(i)*(1+8.0*zri(i))),f_ri_cd_min)
-                  FH(i)=FM(i)
-             CASE (4)  ! King 2001
-                  IF (zri(i) .LT. C2/2.) THEN
-                    FM(i)=MAX((1.-zri(i)/C2)**2,f_ri_cd_min)
-                    FH(i)=  FM(i)
-                  ELSE
-                    FM(i)=MAX(C3*((C2/zri(i))**2),f_ri_cd_min)
-                    FH(i)= FM(i)
-                  ENDIF
-             CASE (5) ! MO
-                  if (zri(i) .LT. 1./alpha) then
-                    FM(i)=MAX((1.-alpha*zri(i))**2,f_ri_cd_min)
-                    FH(i)=FM(i)
-                  else 
-                    FM(i)=MAX(1E-7,f_ri_cd_min)
-                    FH(i)=FM(i)
-                  endif
-             CASE (6) ! Consistent with turbulence scheme (in stationary case) derived in atke (2023)
-                  sm(i) = MAX(smmin,cn*(1.-zri(i)/ric))
-                           ! prandlt expression from venayagamoorthy and stretch 2010, Li et al 2019
-                  prandtl(i) = pr_neut*exp(-pr_slope/pr_neut*zri(i)+zri(i)/pr_neut) &
-                                + zri(i) * pr_slope
-                  FM(i) = MAX((sm(i)**(3./2.) * sqrt(cepsilon) * (1 - zri(i) / prandtl(i))**(1./2.)),f_ri_cd_min)
-                  FH(i) = MAX((FM(i) / prandtl(i)), f_ri_cd_min)
-             CASE default ! Louis 1982
-                  zscf = SQRT(1.+CD*ABS(zri(i)))
-                  FM(i)= AMAX1(1. / (1.+2.*CB*zri(i)/zscf), f_ri_cd_min)
-                  FH(i)= AMAX1(1./ (1.+3.*CB*zri(i)*zscf), f_ri_cd_min )
-           END SELECT
-
-! Calcul des drags
-           
-           cdmm(i)=cdmn(i)*FM(i)
-           cdhh(i)=f_cdrag_ter*cdhn(i)*FH(i)
-           
-           IF (choix_bulk == 0) THEN
-             cdm(i)=cdmn(i)*FM(i)
-             cdh(i)=f_cdrag_ter*cdhn(i)*FH(i)
-           ENDIF
-
-           IF (nsrf.EQ.is_oce) THEN
-             cdhh(i)=f_cdrag_oce*cdhn(i)*FH(i)
-             cdmm(i)=MIN(cdmm(i),cdmmax)
-             cdhh(i)=MIN(cdhh(i),cdhmax)
-           ENDIF
-           IF (ok_cdrag_iter) THEN
-             rugos_itm(i,1) = rugos_itm(i,2)
-             rugos_ith(i,1) = rugos_ith(i,2)
-             rugos_itm(i,2) =  0.018*cdmm(i) * (speed(i))/RG  &
-                              +  0.11*14e-6 / SQRT(cdmm(i) * zdu2)
-
-!---------- Version SEPARATION DES Z0 ----------------------
-             IF (iflag_z0_oce==0) THEN
-               rugos_ith(i,2) = rugos_itm(i,2)
-             ELSE IF (iflag_z0_oce==1) THEN
-               rugos_ith(i,2) = 0.40*14e-6 / SQRT(cdmm(i) * zdu2)
-             ENDIF
-           ENDIF
-         ENDIF
-         IF (ok_cdrag_iter) THEN
-           rugos_itm(i,2) = MAX(1.5e-05,rugos_itm(i,2))
-           rugos_ith(i,2) = MAX(1.5e-05,rugos_ith(i,2))
-         ENDIF
-       ENDDO
-       IF (nsrf.EQ.is_oce) THEN
-         cdm(i)=MIN(cdmm(i),cdmmax)
-         cdh(i)=MIN(cdhh(i),cdhmax)
-       ENDIF
-       z0m = rugos_itm(:,2)
-       z0h = rugos_ith(:,2)
-     ELSE ! (nsrf == is_oce)
-       zri(i) = zgeop1(i)*(ztvd-ztsolv)/(zdu2*ztvd)
-       IF (iri_in.EQ.1) THEN
-         zri(i) = ri_in(i)
-       ENDIF
-
-! Coefficients CD neutres : k^2/ln(z/z0) et k^2/(ln(z/z0)*ln(z/z0h)):
-!********************************************************************
-       zzzcd=CKAP/LOG(1.+zgeop1(i)/(RG*z0m(i)))
-       cdmn(i) = zzzcd*zzzcd
-       cdhn(i) = zzzcd*(CKAP/LOG(1.+zgeop1(i)/(RG*z0h(i))))
-
-
-! Calcul des fonctions de stabilit?? FMs, FHs, FMi, FHi :
-!*******************************************************
-!''''''''''''''
-! Cas instables
-!''''''''''''''
-       IF (zri(i) .LT. 0.) THEN    
-         SELECT CASE (iflag_corr_insta)
-           CASE (1) ! Louis 1979 + Mascart 1995
-                MU=LOG(MAX(z0m(i)/z0h(i),0.01))
-                CMstar=6.8741+2.6933*MU-0.3601*(MU**2)+0.0154*(MU**3)
-                PM=0.5233-0.0815*MU+0.0135*(MU**2)-0.001*(MU**3)
-                CHstar=3.2165+4.3431*MU+0.536*(MU**2)-0.0781*(MU**3)
-                PH=0.5802-0.1571*MU+0.0327*(MU**2)-0.0026*(MU**3)
-                CH=CHstar*B*CKAP/LOG(z0m(i)+zgeop1(i)/(RG*z0m(i))) &
-                   & * CKAPT/LOG(z0h(i)+zgeop1(i)/(RG*z0h(i)))       &
-                   & * ((zgeop1(i)/(RG*z0h(i)))**PH)
-                CM=CMstar*B*CKAP/LOG(z0m(i)+zgeop1(i)/(RG*z0m(i))) &
-                   & *CKAP/LOG(z0m(i)+zgeop1(i)/(RG*z0m(i)))         &
-                   & * ((zgeop1(i)/(RG*z0m(i)))**PM)
-                FM(i)=1.-B*zri(i)/(1.+CM*SQRT(ABS(zri(i))))
-                FH(i)=1.-B*zri(i)/(1.+CH*SQRT(ABS(zri(i))))
-           CASE (2) ! Louis 1982
-                zucf = 1./(1.+3.0*CB*CC*cdmn(i)*SQRT(ABS(zri(i)) &
-                       *(1.0+zgeop1(i)/(RG*z0m(i)))))
-                FM(i) = AMAX1((1.-2.0*CB*zri(i)*zucf),f_ri_cd_min)
-                FH(i) = AMAX1((1.-3.0*CB*zri(i)*zucf),f_ri_cd_min)
-           CASE (3) ! Laurent Li
-                FM(i) = MAX(SQRT(1.0-18.0*zri(i)),f_ri_cd_min)
-                FH(i) = MAX(SQRT(1.0-18.0*zri(i)),f_ri_cd_min)
-           CASE (6) ! Consistent with turbulence scheme (in stationary case) derived in atke (2023)
-                 sm(i) = 2./rpi * (cinf - cn) * atan(-zri(i)/ri0) + cn
-                 prandtl(i) = -2./rpi * (pr_asym - pr_neut) * atan(zri(i)/ri1) + pr_neut
-                 FM(i) = MAX((sm(i)**(3./2.) * sqrt(cepsilon) * (1 - zri(i) / prandtl(i))**(1./2.)),f_ri_cd_min)
-                 FH(i) = MAX((FM(i) / prandtl(i)), f_ri_cd_min)
-           CASE default ! Louis 1982
-                zucf = 1./(1.+3.0*CB*CC*cdmn(i)*SQRT(ABS(zri(i)) &
-                      *(1.0+zgeop1(i)/(RG*z0m(i)))))
-                FM(i) = AMAX1((1.-2.0*CB*zri(i)*zucf),f_ri_cd_min)
-                FH(i) = AMAX1((1.-3.0*CB*zri(i)*zucf),f_ri_cd_min)
-         END SELECT
-! Calcul des drags
-         cdm(i)=cdmn(i)*FM(i)
-         cdh(i)=f_cdrag_ter*cdhn(i)*FH(i)
-       ELSE                          
-!'''''''''''''''
-! Cas stables :
-!'''''''''''''''
-         zri(i) = MIN(20.,zri(i))
-         SELECT CASE (iflag_corr_sta)
-           CASE (1) ! Louis 1979 + Mascart 1995
-                FM(i)=MAX(1./((1+BPRIME*zri(i))**2),f_ri_cd_min)
-                FH(i)=FM(i)
-           CASE (2) ! Louis 1982
-                zscf = SQRT(1.+CD*ABS(zri(i)))
-                FM(i)= AMAX1(1. / (1.+2.*CB*zri(i)/zscf), f_ri_cd_min)
-                FH(i)= AMAX1(1./ (1.+3.*CB*zri(i)*zscf), f_ri_cd_min )
-           CASE (3) ! Laurent Li
-                FM(i)=MAX(1.0 / (1.0+10.0*zri(i)*(1+8.0*zri(i))),f_ri_cd_min)
-                FH(i)=FM(i)
-           CASE (4)  ! King 2001
-                if (zri(i) .LT. C2/2.) then
-                  FM(i)=MAX((1.-zri(i)/C2)**2,f_ri_cd_min)
-                  FH(i)=  FM(i)
-                else
-                  FM(i)=MAX(C3*((C2/zri(i))**2),f_ri_cd_min)
-                  FH(i)= FM(i)
-                endif
-           CASE (5) ! MO
-                if (zri(i) .LT. 1./alpha) then
-                  FM(i)=MAX((1.-alpha*zri(i))**2,f_ri_cd_min)
-                  FH(i)=FM(i)
-                else 
-                  FM(i)=MAX(1E-7,f_ri_cd_min)
-                  FH(i)=FM(i)
-                endif
-           CASE (6) ! Consistent with turbulence scheme (in stationary case) derived in atke (2023)
-                sm(i) = MAX(0.,cn*(1.-zri(i)/ric))
-                prandtl(i) = pr_neut + zri(i) * pr_slope
-                FM(i) = MAX((sm(i)**(3./2.) * sqrt(cepsilon) * (1 - zri(i) / prandtl(i))**(1./2.)),f_ri_cd_min)
-                FH(i) = MAX((FM(i) / prandtl(i)), f_ri_cd_min)
-           CASE default ! Louis 1982
-                zscf = SQRT(1.+CD*ABS(zri(i)))
-                FM(i)= AMAX1(1. / (1.+2.*CB*zri(i)/zscf), f_ri_cd_min)
-                FH(i)= AMAX1(1./ (1.+3.*CB*zri(i)*zscf), f_ri_cd_min )
-         END SELECT
-! Calcul des drags
-         cdm(i)=cdmn(i)*FM(i)
-         cdh(i)=f_cdrag_ter*cdhn(i)*FH(i)
-       ENDIF
-     ENDIF ! fin du if (nsrf == is_oce)
-  END DO   !  Fin de la boucle sur l'horizontal
-
-END SUBROUTINE cdrag
-
-END MODULE cdrag_mod
Index: /LMDZ6/trunk/libf/phylmd/cdrag_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cdrag_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/cdrag_mod.f90	(revision 5268)
@@ -0,0 +1,643 @@
+!
+!$Id$
+!
+!
+MODULE cdrag_mod
+!
+! This module contains some procedures for calculation of the cdrag
+! coefficients for turbulent diffusion at surface
+!
+  IMPLICIT NONE
+
+CONTAINS
+!
+!****************************************************************************************
+!
+!r original routine svn3623
+!
+ SUBROUTINE cdrag(knon,  nsrf,   &
+     speed, t1,    q1,    zgeop1, &
+     psol, pblh,  tsurf, qsurf, z0m, z0h,  &
+     ri_in, iri_in, &
+     cdm,  cdh,  zri,   pref, prain, tsol , pat1)
+
+  USE dimphy
+  USE coare_cp_mod, ONLY: coare_cp
+  USE coare30_flux_cnrm_mod, ONLY: coare30_flux_cnrm
+  USE indice_sol_mod
+  USE print_control_mod, ONLY: lunout, prt_level
+  USE ioipsl_getin_p_mod, ONLY : getin_p
+  USE lmdz_atke_turbulence_ini, ONLY : smmin, ric, cinf, cepsilon, pr_slope, pr_asym, pr_neut
+
+  IMPLICIT NONE
+! ================================================================= c
+!
+! Objet : calcul des cdrags pour le moment (pcfm) et 
+!         les flux de chaleur sensible et latente (pcfh) d'apr??s
+!         Louis 1982, Louis 1979, King et al 2001
+!         ou Zilitinkevich et al 2002  pour les cas stables, Louis 1979
+!         et 1982 pour les cas instables 
+!
+! Modified history: 
+!  writting on the 20/05/2016
+!  modified on the 13/12/2016 to be adapted to LMDZ6
+!
+! References:
+!   Louis, J. F., 1979: A parametric model of vertical eddy fluxes in the
+!     atmosphere. Boundary-Layer Meteorology. 01/1979; 17(2):187-202. 
+!   Louis, J. F., Tiedtke, M. and Geleyn, J. F., 1982: `A short history of the
+!     operational PBL parametrization at ECMWF'. Workshop on boundary layer
+!     parametrization, November 1981, ECMWF, Reading, England. 
+!     Page: 19. Equations in Table 1.
+!   Mascart P, Noilhan J, Giordani H 1995.A MODIFIED PARAMETERIZATION OF FLUX-PROFILE RELATIONSHIPS 
+!    IN THE SURFACE LAYER USING DIFFERENT ROUGHNESS LENGTH VALUES FOR HEAT AND MOMENTUM
+!    Boundary-Layer Meteorology 72: 331-344
+!   Anton Beljaars. May 1992. The parametrization of the planetary boundary layer.  
+!     European Centre for Medium-Range Weather Forecasts.
+!     Equations: 110-113. Page 40.
+!   Miller,M.J., A.C.M.Beljaars, T.N.Palmer. 1992. The sensitivity of the ECMWF
+!     model to the parameterization of evaporation from the tropical oceans. J.
+!     Climate, 5:418-434.
+!   King J.C, Connolley, W.M ad Derbyshire S.H. 2001, Sensitivity of Modelled Antarctic climate
+!   to surface and boundary-layer flux parametrizations
+!   QJRMS, 127, pp 779-794
+!
+! ================================================================= c
+! ================================================================= c
+! On choisit le couple de fonctions de correction avec deux flags:
+! Un pour les cas instables, un autre pour les cas stables
+!
+! iflag_corr_insta:
+!                   1: Louis 1979 avec les modifications de Mascart 1995 (z0/= z0h)
+!                   2: Louis 1982 
+!                   3: Laurent Li
+!
+! iflag_corr_sta:
+!                   1: Louis 1979 avec les modifications de Mascart 1995 (z0/= z0h)
+!                   2: Louis 1982 
+!                   3: Laurent Li
+!                   4: King  2001 (SHARP)
+!                   5: MO 1st order theory (allow collapse of turbulence)
+!            
+!
+!*****************************************************************
+! Parametres d'entree
+!***************************************************************** 
+  
+  INTEGER, INTENT(IN)                      :: knon, nsrf ! nombre de points de grille sur l'horizontal + type de surface
+  REAL, DIMENSION(klon), INTENT(IN)        :: speed    ! module du vent au 1er niveau du modele
+  REAL, DIMENSION(klon), INTENT(IN)        :: zgeop1   ! geopotentiel au 1er niveau du modele
+  REAL, DIMENSION(klon), INTENT(IN)        :: tsurf    ! Surface temperature (K)
+  REAL, DIMENSION(klon), INTENT(IN)        :: qsurf    ! Surface humidity (Kg/Kg)
+  REAL, DIMENSION(klon), INTENT(INOUT)     :: z0m, z0h ! Rugosity at surface (m) 
+  REAL, DIMENSION(klon), INTENT(IN)        :: ri_in ! Input Richardson 1st layer for first guess calculations of screen var. 
+  INTEGER, INTENT(IN)                      :: iri_in! iflag to activate cdrag calculation using ri1
+  REAL, DIMENSION(klon), INTENT(IN)        :: t1       ! Temperature au premier niveau (K) 
+  REAL, DIMENSION(klon), INTENT(IN)        :: q1       ! humidite specifique au premier niveau (kg/kg)
+  REAL, DIMENSION(klon), INTENT(IN)        :: psol     ! pression au sol
+
+!------------------ Rajout pour COARE (OT2018) --------------------
+  REAL, DIMENSION(klon), INTENT(INOUT)     :: pblh  !hauteur de CL
+  REAL, DIMENSION(klon), INTENT(IN)        :: prain !rapport au precipitation
+  REAL, DIMENSION(klon), INTENT(IN)        :: tsol  !SST imposé sur la surface oceanique
+  REAL, DIMENSION(klon), INTENT(IN)        :: pat1  !pression premier lev
+
+
+
+! Parametres de sortie
+!******************************************************************
+  REAL, DIMENSION(klon), INTENT(OUT)       :: cdm   ! Drag coefficient for momentum
+  REAL, DIMENSION(klon), INTENT(OUT)       :: cdh   ! Drag coefficient for heat flux
+  REAL, DIMENSION(klon), INTENT(OUT)       :: zri   ! Richardson number
+  REAL, DIMENSION(klon), INTENT(INOUT)       :: pref  ! Pression au niveau zgeop/RG
+
+! Variables Locales
+!******************************************************************
+ 
+
+  INCLUDE "YOMCST.h"
+  INCLUDE "YOETHF.h"
+  INCLUDE "clesphys.h"
+
+
+  REAL, PARAMETER       :: CKAP=0.40, CKAPT=0.42
+  REAL                   CEPDU2
+  REAL                   ALPHA
+  REAL                   CB,CC,CD,C2,C3
+  REAL                   MU, CM, CH, B, CMstar, CHstar
+  REAL                   PM, PH, BPRIME
+  INTEGER                ng_q1                      ! Number of grids that q1 < 0.0
+  INTEGER                ng_qsurf                   ! Number of grids that qsurf < 0.0
+  INTEGER                i, k
+  REAL                   zdu2, ztsolv
+  REAL                   ztvd, zscf
+  REAL                   zucf, zcr
+  REAL, DIMENSION(klon) :: FM, FH                   ! stability functions
+  REAL, DIMENSION(klon) :: cdmn, cdhn               ! Drag coefficient in neutral conditions
+  REAL zzzcd
+  REAL, DIMENSION(klon) :: sm, prandtl              ! Stability function from atke turbulence scheme
+  REAL                  ri0, ri1, cn                ! to have dimensionless term in sm and prandtl
+
+!------------------ Rajout (OT2018) --------------------
+!------------------ Rajout pour les appelles BULK (OT) --------------------
+  REAL, DIMENSION(klon,2) :: rugos_itm 
+  REAL, DIMENSION(klon,2) :: rugos_ith 
+  REAL, PARAMETER         :: tol_it_rugos=1.e-4
+  REAL, DIMENSION(3)      :: coeffs
+  LOGICAL                 :: mixte
+  REAL                    :: z_0m
+  REAL                    :: z_0h
+  REAL, DIMENSION(klon)   :: cdmm
+  REAL, DIMENSION(klon)   :: cdhh
+
+!------------------RAJOUT POUR ECUME -------------------
+
+  REAL, DIMENSION(klon) :: PQSAT 
+  REAL, DIMENSION(klon) :: PSFTH
+  REAL, DIMENSION(klon) :: PFSTQ 
+  REAL, DIMENSION(klon) :: PUSTAR
+  REAL, DIMENSION(klon) :: PCD      ! Drag coefficient for momentum
+  REAL, DIMENSION(klon) :: PCDN     ! Drag coefficient for momentum
+  REAL, DIMENSION(klon) :: PCH      ! Drag coefficient for momentum
+  REAL, DIMENSION(klon) :: PCE      ! Drag coefficient for momentum
+  REAL, DIMENSION(klon) :: PRI 
+  REAL, DIMENSION(klon) :: PRESA
+  REAL, DIMENSION(klon) :: PSSS
+
+  LOGICAL               :: OPRECIP
+  LOGICAL               :: OPWEBB
+  LOGICAL               :: OPERTFLUX
+  LOGICAL               :: LPRECIP
+  LOGICAL               :: LPWG
+
+
+
+  LOGICAL, SAVE :: firstcall = .TRUE.
+  !$OMP THREADPRIVATE(firstcall)
+  INTEGER, SAVE :: iflag_corr_sta
+  !$OMP THREADPRIVATE(iflag_corr_sta)
+  INTEGER, SAVE :: iflag_corr_insta
+  !$OMP THREADPRIVATE(iflag_corr_insta)
+  LOGICAL, SAVE :: ok_cdrag_iter
+  !$OMP THREADPRIVATE(ok_cdrag_iter)
+
+!===================================================================c
+! Valeurs numeriques des constantes
+!===================================================================c
+
+
+! Minimum du carre du vent
+
+ CEPDU2 = (0.1)**2
+
+! Louis 1982
+
+  CB=5.0
+  CC=5.0
+  CD=5.0
+
+
+! King 2001
+
+  C2=0.25
+  C3=0.0625
+
+  
+! Louis 1979
+
+  BPRIME=4.7
+  B=9.4
+  
+
+!MO
+
+  ALPHA=5.0
+
+! Consistent with atke scheme
+  cn=(1./sqrt(cepsilon))**(2./3.)
+  ri0=2./rpi*(cinf - cn)*ric/cn
+  ri1=-2./rpi * (pr_asym - pr_neut)/pr_slope
+
+
+! ================================================================= c
+! Tests avant de commencer
+! Fuxing WANG, 04/03/2015
+! To check if there are negative q1, qsurf values.
+!====================================================================c
+  ng_q1 = 0     ! Initialization
+  ng_qsurf = 0  ! Initialization
+  DO i = 1, knon
+     IF (q1(i).LT.0.0)     ng_q1 = ng_q1 + 1
+     IF (qsurf(i).LT.0.0)  ng_qsurf = ng_qsurf + 1
+  ENDDO
+  IF (ng_q1.GT.0 .and. prt_level > 5) THEN
+      WRITE(lunout,*)" *** Warning: Negative q1(humidity at 1st level) values in cdrag.F90 !"
+      WRITE(lunout,*)" The total number of the grids is: ", ng_q1
+      WRITE(lunout,*)" The negative q1 is set to zero "
+!      abort_message="voir ci-dessus"
+!      CALL abort_physic(modname,abort_message,1)
+  ENDIF
+  IF (ng_qsurf.GT.0 .and. prt_level > 5) THEN
+      WRITE(lunout,*)" *** Warning: Negative qsurf(humidity at surface) values in cdrag.F90 !"
+      WRITE(lunout,*)" The total number of the grids is: ", ng_qsurf
+      WRITE(lunout,*)" The negative qsurf is set to zero "
+!      abort_message="voir ci-dessus"
+!      CALL abort_physic(modname,abort_message,1)
+  ENDIF
+
+
+
+!=============================================================================c
+! Calcul du cdrag
+!=============================================================================c
+
+! On choisit les fonctions de stabilite utilisees au premier appel
+!**************************************************************************
+ IF (firstcall) THEN
+   iflag_corr_sta=2
+   iflag_corr_insta=2
+   ok_cdrag_iter = .FALSE.
+ 
+   CALL getin_p('iflag_corr_sta',iflag_corr_sta)
+   CALL getin_p('iflag_corr_insta',iflag_corr_insta)
+   CALL getin_p('ok_cdrag_iter',ok_cdrag_iter)
+
+   firstcall = .FALSE.
+ ENDIF
+
+!------------------ Rajout (OT2018) --------------------
+!---------    Rajout pour itération sur rugosité     ----------------
+  rugos_itm(:,2) = z0m
+  rugos_itm(:,1) = 3.*tol_it_rugos*z0m
+
+  rugos_ith(:,2) = z0h !cp nouveau rugos_it
+  rugos_ith(:,1) = 3.*tol_it_rugos*z0h
+!--------------------------------------------------------------------
+
+!xxxxxxxxxxxxxxxxxxxxxxx
+  DO i = 1, knon        ! Boucle sur l'horizontal
+!xxxxxxxxxxxxxxxxxxxxxxx
+
+
+! calculs preliminaires:
+!***********************
+     
+     zdu2 = MAX(CEPDU2, speed(i)**2)
+     pref(i) = EXP(LOG(psol(i)) - zgeop1(i)/(RD*t1(i)* &
+          (1.+ RETV * max(q1(i),0.0))))           ! negative q1 set to zero
+     ztsolv = tsurf(i) * (1.0+RETV*max(qsurf(i),0.0))    ! negative qsurf set to zero
+     ztvd = (t1(i)+zgeop1(i)/RCPD/(1.+RVTMP2*q1(i))) &
+          *(1.+RETV*max(q1(i),0.0))                      ! negative q1 set to zero
+     
+!------------------ Rajout (OT2018) --------------------
+!--------------   ON DUPLIQUE POUR METTRE ITERATION SUR OCEAN    ------------------------     
+     IF (iri_in.EQ.1) THEN
+       zri(i) = ri_in(i)
+     ENDIF
+
+     IF (nsrf == is_oce) THEN
+        
+!------------------  Pour Core 2 choix Core Pur ou Core Mixte  --------------------
+       IF ((choix_bulk > 1 .AND. choix_bulk < 4) .AND. (nsrf .eq. is_oce)) THEN
+         IF(choix_bulk .eq. 2) THEN
+           mixte = .false.
+         ELSE
+            mixte = .true.
+         ENDIF
+         call clc_core_cp ( sqrt(zdu2),t1(i)-tsurf(i),q1(i)-qsurf(i),t1(i),q1(i),&
+             zgeop1(i)/RG, zgeop1(i)/RG,  zgeop1(i)/RG,&
+             psol(i),nit_bulk,mixte,&
+             coeffs,z_0m,z_0h)
+         cdmm(i) = coeffs(1)
+         cdhh(i) = coeffs(2)
+         cdm(i)=cdmm(i)
+         cdh(i)=cdhh(i)
+         write(*,*) "clc_core cd ch",cdmm(i),cdhh(i)
+
+!------------------                 Pour ECUME                 --------------------
+       ELSE IF ((choix_bulk .eq. 4) .and. (nsrf .eq. is_oce)) THEN
+         OPRECIP = .false.
+         OPWEBB  = .false.
+         OPERTFLUX = .false.
+         IF (nsrf .eq. is_oce) THEN
+           PSSS = 0.0
+         ENDIF
+         call ini_csts
+         call ecumev6_flux( z_0m,t1(i),tsurf(i),&
+             q1(i),qsurf(i),sqrt(zdu2),zgeop1(i)/RG,PSSS,zgeop1(i)/RG,&
+             psol(i),pat1(i), OPRECIP, OPWEBB,&
+             PSFTH,PFSTQ,PUSTAR,PCD,PCDN,&
+             PCH,PCE,PRI,PRESA,prain,&
+             z_0h,OPERTFLUX,coeffs)
+
+         cdmm(i) = coeffs(1)
+         cdhh(i) = coeffs(2)
+         cdm(i)=cdmm(i)
+         cdh(i)=cdhh(i)
+   
+         write(*,*) "ecume cd ch",cdmm(i),cdhh(i)
+
+!------------------                 Pour COARE CNRM                 --------------------
+       ELSE IF ((choix_bulk .eq. 5) .and. (nsrf .eq. is_oce)) THEN
+         LPRECIP = .false.
+         LPWG    = .false.
+         call ini_csts
+         block
+           real, dimension(1) :: z0m_1d, z_0h_1d, sqrt_zdu2_1d, zgeop1_rg_1d  ! convert scalar to 1D for call
+           z0m_1d = z0m
+           z_0h_1d = z0h
+           sqrt_zdu2_1d = sqrt(zdu2)
+           zgeop1_rg_1d=zgeop1(i)/RG
+           call coare30_flux_cnrm(z0m_1d,t1(i),tsurf(i), q1(i),  &
+               sqrt_zdu2_1d,zgeop1_rg_1d,zgeop1_rg_1d,psol(i),qsurf(i),PQSAT, &
+               PSFTH,PFSTQ,PUSTAR,PCD,PCDN,PCH,PCE,PRI, &
+               PRESA,prain,pat1(i),z_0h_1d, LPRECIP, LPWG, coeffs)
+
+         end block
+         cdmm(i) = coeffs(1)
+         cdhh(i) = coeffs(2)
+         cdm(i)=cdmm(i)
+         cdh(i)=cdhh(i)
+         write(*,*) "coare CNRM cd ch",cdmm(i),cdhh(i)
+
+!------------------                 Pour COARE Maison                 --------------------
+       ELSE IF ((choix_bulk .eq. 1) .and. (nsrf .eq. is_oce)) THEN
+         IF ( pblh(i) .eq. 0. ) THEN
+           pblh(i) = 1500.
+         ENDIF
+         write(*,*) "debug size",size(coeffs)
+         call coare_cp(sqrt(zdu2),t1(i)-tsurf(i),q1(i)-qsurf(i),&
+               t1(i),q1(i),&
+               zgeop1(i)/RG,zgeop1(i)/RG,zgeop1(i)/RG,&
+               psol(i), pblh(i),&
+               nit_bulk,&
+               coeffs,z_0m,z_0h)
+         cdmm(i) = coeffs(1)
+         cdhh(i) = coeffs(3)
+         cdm(i)=cdmm(i)
+         cdh(i)=cdhh(i)
+         write(*,*) "coare cd ch",cdmm(i),cdhh(i)
+       ELSE
+!------------------                 Pour La param LMDZ (ocean)              --------------------
+         zri(i) = zgeop1(i)*(ztvd-ztsolv)/(zdu2*ztvd)
+         IF (iri_in.EQ.1) THEN
+           zri(i) = ri_in(i)
+         ENDIF
+       ENDIF
+     
+
+!----------------------- Rajout des itérations --------------
+       DO  k=1,nit_bulk
+
+! Coefficients CD neutres : k^2/ln(z/z0) et k^2/(ln(z/z0)*ln(z/z0h)):
+!********************************************************************
+         zzzcd=CKAP/LOG(1.+zgeop1(i)/(RG*rugos_itm(i,2)))
+         cdmn(i) = zzzcd*zzzcd
+         cdhn(i) = zzzcd*(CKAP/LOG(1.+zgeop1(i)/(RG*rugos_ith(i,2))))
+
+! Calcul des fonctions de stabilite FMs, FHs, FMi, FHi :
+!*******************************************************
+         IF (zri(i) .LT. 0.) THEN    
+           SELECT CASE (iflag_corr_insta)
+             CASE (1) ! Louis 1979 + Mascart 1995
+                  MU=LOG(MAX(z0m(i)/z0h(i),0.01))
+                  CMstar=6.8741+2.6933*MU-0.3601*(MU**2)+0.0154*(MU**3)
+                  PM=0.5233-0.0815*MU+0.0135*(MU**2)-0.001*(MU**3)
+                  CHstar=3.2165+4.3431*MU+0.536*(MU**2)-0.0781*(MU**3)
+                  PH=0.5802-0.1571*MU+0.0327*(MU**2)-0.0026*(MU**3)
+                  CH=CHstar*B*CKAP/LOG(z0m(i)+zgeop1(i)/(RG*z0m(i))) &
+                     & * CKAPT/LOG(z0h(i)+zgeop1(i)/(RG*z0h(i)))       &
+                     & * ((zgeop1(i)/(RG*z0h(i)))**PH)
+                  CM=CMstar*B*CKAP/LOG(z0m(i)+zgeop1(i)/(RG*z0m(i))) &
+                     & *CKAP/LOG(z0m(i)+zgeop1(i)/(RG*z0m(i)))         &
+                     & * ((zgeop1(i)/(RG*z0m(i)))**PM)
+                  FM(i)=1.-B*zri(i)/(1.+CM*SQRT(ABS(zri(i))))
+                  FH(i)=1.-B*zri(i)/(1.+CH*SQRT(ABS(zri(i))))
+             CASE (2) ! Louis 1982
+                  zucf = 1./(1.+3.0*CB*CC*cdmn(i)*SQRT(ABS(zri(i)) &
+                        *(1.0+zgeop1(i)/(RG*z0m(i)))))
+                  FM(i) = AMAX1((1.-2.0*CB*zri(i)*zucf),f_ri_cd_min)
+                  FH(i) = AMAX1((1.-3.0*CB*zri(i)*zucf),f_ri_cd_min)
+             CASE (3) ! Laurent Li
+                  FM(i) = MAX(SQRT(1.0-18.0*zri(i)),f_ri_cd_min)
+                  FH(i) = MAX(SQRT(1.0-18.0*zri(i)),f_ri_cd_min)
+             CASE (6) ! Consistent with turbulence scheme (in stationary case) derived in atke (2023)
+                  sm(i) = 2./rpi * (cinf - cn) * atan(-zri(i)/ri0) + cn
+                  prandtl(i) = -2./rpi * (pr_asym - pr_neut) * atan(zri(i)/ri1) + pr_neut
+                  FM(i) = MAX((sm(i)**(3./2.) * sqrt(cepsilon) * (1 - zri(i) / prandtl(i))**(1./2.)),f_ri_cd_min)
+                  FH(i) = MAX((FM(i) / prandtl(i)), f_ri_cd_min)
+             CASE default ! Louis 1982
+                  zucf = 1./(1.+3.0*CB*CC*cdmn(i)*SQRT(ABS(zri(i)) &
+                         *(1.0+zgeop1(i)/(RG*z0m(i)))))
+                  FM(i) = AMAX1((1.-2.0*CB*zri(i)*zucf),f_ri_cd_min)
+                  FH(i) = AMAX1((1.-3.0*CB*zri(i)*zucf),f_ri_cd_min)
+           END SELECT
+! Calcul des drags
+           cdmm(i)=cdmn(i)*FM(i)
+           cdhh(i)=f_cdrag_ter*cdhn(i)*FH(i)
+! Traitement particulier des cas oceaniques
+! on applique Miller et al 1992 en l'absence de gustiness 
+           IF (nsrf == is_oce) THEN
+!            cdh(i)=f_cdrag_oce*cdhn(i)*FH(i)
+             IF (iflag_gusts==0) THEN
+               zcr = (0.0016/(cdmn(i)*SQRT(zdu2)))*ABS(ztvd-ztsolv)**(1./3.)
+               cdhh(i) =f_cdrag_oce* cdhn(i)*(1.0+zcr**1.25)**(1./1.25)
+             ENDIF
+             cdmm(i)=MIN(cdmm(i),cdmmax)
+             cdhh(i)=MIN(cdhh(i),cdhmax)
+!             write(*,*) "LMDZ cd ch",cdmm(i),cdhh(i)
+           END IF
+         ELSE                          
+
+!'''''''''''''''
+! Cas stables :
+!'''''''''''''''
+           zri(i) = MIN(20.,zri(i))
+           SELECT CASE (iflag_corr_sta)
+             CASE (1) ! Louis 1979 + Mascart 1995
+                  FM(i)=MAX(1./((1+BPRIME*zri(i))**2),f_ri_cd_min)
+                  FH(i)=FM(i)
+             CASE (2) ! Louis 1982
+                  zscf = SQRT(1.+CD*ABS(zri(i)))
+                  FM(i)= AMAX1(1. / (1.+2.*CB*zri(i)/zscf), f_ri_cd_min)
+                  FH(i)= AMAX1(1./ (1.+3.*CB*zri(i)*zscf), f_ri_cd_min )
+             CASE (3) ! Laurent Li
+                  FM(i)=MAX(1.0 / (1.0+10.0*zri(i)*(1+8.0*zri(i))),f_ri_cd_min)
+                  FH(i)=FM(i)
+             CASE (4)  ! King 2001
+                  IF (zri(i) .LT. C2/2.) THEN
+                    FM(i)=MAX((1.-zri(i)/C2)**2,f_ri_cd_min)
+                    FH(i)=  FM(i)
+                  ELSE
+                    FM(i)=MAX(C3*((C2/zri(i))**2),f_ri_cd_min)
+                    FH(i)= FM(i)
+                  ENDIF
+             CASE (5) ! MO
+                  if (zri(i) .LT. 1./alpha) then
+                    FM(i)=MAX((1.-alpha*zri(i))**2,f_ri_cd_min)
+                    FH(i)=FM(i)
+                  else 
+                    FM(i)=MAX(1E-7,f_ri_cd_min)
+                    FH(i)=FM(i)
+                  endif
+             CASE (6) ! Consistent with turbulence scheme (in stationary case) derived in atke (2023)
+                  sm(i) = MAX(smmin,cn*(1.-zri(i)/ric))
+                           ! prandlt expression from venayagamoorthy and stretch 2010, Li et al 2019
+                  prandtl(i) = pr_neut*exp(-pr_slope/pr_neut*zri(i)+zri(i)/pr_neut) &
+                                + zri(i) * pr_slope
+                  FM(i) = MAX((sm(i)**(3./2.) * sqrt(cepsilon) * (1 - zri(i) / prandtl(i))**(1./2.)),f_ri_cd_min)
+                  FH(i) = MAX((FM(i) / prandtl(i)), f_ri_cd_min)
+             CASE default ! Louis 1982
+                  zscf = SQRT(1.+CD*ABS(zri(i)))
+                  FM(i)= AMAX1(1. / (1.+2.*CB*zri(i)/zscf), f_ri_cd_min)
+                  FH(i)= AMAX1(1./ (1.+3.*CB*zri(i)*zscf), f_ri_cd_min )
+           END SELECT
+
+! Calcul des drags
+           
+           cdmm(i)=cdmn(i)*FM(i)
+           cdhh(i)=f_cdrag_ter*cdhn(i)*FH(i)
+           
+           IF (choix_bulk == 0) THEN
+             cdm(i)=cdmn(i)*FM(i)
+             cdh(i)=f_cdrag_ter*cdhn(i)*FH(i)
+           ENDIF
+
+           IF (nsrf.EQ.is_oce) THEN
+             cdhh(i)=f_cdrag_oce*cdhn(i)*FH(i)
+             cdmm(i)=MIN(cdmm(i),cdmmax)
+             cdhh(i)=MIN(cdhh(i),cdhmax)
+           ENDIF
+           IF (ok_cdrag_iter) THEN
+             rugos_itm(i,1) = rugos_itm(i,2)
+             rugos_ith(i,1) = rugos_ith(i,2)
+             rugos_itm(i,2) =  0.018*cdmm(i) * (speed(i))/RG  &
+                              +  0.11*14e-6 / SQRT(cdmm(i) * zdu2)
+
+!---------- Version SEPARATION DES Z0 ----------------------
+             IF (iflag_z0_oce==0) THEN
+               rugos_ith(i,2) = rugos_itm(i,2)
+             ELSE IF (iflag_z0_oce==1) THEN
+               rugos_ith(i,2) = 0.40*14e-6 / SQRT(cdmm(i) * zdu2)
+             ENDIF
+           ENDIF
+         ENDIF
+         IF (ok_cdrag_iter) THEN
+           rugos_itm(i,2) = MAX(1.5e-05,rugos_itm(i,2))
+           rugos_ith(i,2) = MAX(1.5e-05,rugos_ith(i,2))
+         ENDIF
+       ENDDO
+       IF (nsrf.EQ.is_oce) THEN
+         cdm(i)=MIN(cdmm(i),cdmmax)
+         cdh(i)=MIN(cdhh(i),cdhmax)
+       ENDIF
+       z0m = rugos_itm(:,2)
+       z0h = rugos_ith(:,2)
+     ELSE ! (nsrf == is_oce)
+       zri(i) = zgeop1(i)*(ztvd-ztsolv)/(zdu2*ztvd)
+       IF (iri_in.EQ.1) THEN
+         zri(i) = ri_in(i)
+       ENDIF
+
+! Coefficients CD neutres : k^2/ln(z/z0) et k^2/(ln(z/z0)*ln(z/z0h)):
+!********************************************************************
+       zzzcd=CKAP/LOG(1.+zgeop1(i)/(RG*z0m(i)))
+       cdmn(i) = zzzcd*zzzcd
+       cdhn(i) = zzzcd*(CKAP/LOG(1.+zgeop1(i)/(RG*z0h(i))))
+
+
+! Calcul des fonctions de stabilit?? FMs, FHs, FMi, FHi :
+!*******************************************************
+!''''''''''''''
+! Cas instables
+!''''''''''''''
+       IF (zri(i) .LT. 0.) THEN    
+         SELECT CASE (iflag_corr_insta)
+           CASE (1) ! Louis 1979 + Mascart 1995
+                MU=LOG(MAX(z0m(i)/z0h(i),0.01))
+                CMstar=6.8741+2.6933*MU-0.3601*(MU**2)+0.0154*(MU**3)
+                PM=0.5233-0.0815*MU+0.0135*(MU**2)-0.001*(MU**3)
+                CHstar=3.2165+4.3431*MU+0.536*(MU**2)-0.0781*(MU**3)
+                PH=0.5802-0.1571*MU+0.0327*(MU**2)-0.0026*(MU**3)
+                CH=CHstar*B*CKAP/LOG(z0m(i)+zgeop1(i)/(RG*z0m(i))) &
+                   & * CKAPT/LOG(z0h(i)+zgeop1(i)/(RG*z0h(i)))       &
+                   & * ((zgeop1(i)/(RG*z0h(i)))**PH)
+                CM=CMstar*B*CKAP/LOG(z0m(i)+zgeop1(i)/(RG*z0m(i))) &
+                   & *CKAP/LOG(z0m(i)+zgeop1(i)/(RG*z0m(i)))         &
+                   & * ((zgeop1(i)/(RG*z0m(i)))**PM)
+                FM(i)=1.-B*zri(i)/(1.+CM*SQRT(ABS(zri(i))))
+                FH(i)=1.-B*zri(i)/(1.+CH*SQRT(ABS(zri(i))))
+           CASE (2) ! Louis 1982
+                zucf = 1./(1.+3.0*CB*CC*cdmn(i)*SQRT(ABS(zri(i)) &
+                       *(1.0+zgeop1(i)/(RG*z0m(i)))))
+                FM(i) = AMAX1((1.-2.0*CB*zri(i)*zucf),f_ri_cd_min)
+                FH(i) = AMAX1((1.-3.0*CB*zri(i)*zucf),f_ri_cd_min)
+           CASE (3) ! Laurent Li
+                FM(i) = MAX(SQRT(1.0-18.0*zri(i)),f_ri_cd_min)
+                FH(i) = MAX(SQRT(1.0-18.0*zri(i)),f_ri_cd_min)
+           CASE (6) ! Consistent with turbulence scheme (in stationary case) derived in atke (2023)
+                 sm(i) = 2./rpi * (cinf - cn) * atan(-zri(i)/ri0) + cn
+                 prandtl(i) = -2./rpi * (pr_asym - pr_neut) * atan(zri(i)/ri1) + pr_neut
+                 FM(i) = MAX((sm(i)**(3./2.) * sqrt(cepsilon) * (1 - zri(i) / prandtl(i))**(1./2.)),f_ri_cd_min)
+                 FH(i) = MAX((FM(i) / prandtl(i)), f_ri_cd_min)
+           CASE default ! Louis 1982
+                zucf = 1./(1.+3.0*CB*CC*cdmn(i)*SQRT(ABS(zri(i)) &
+                      *(1.0+zgeop1(i)/(RG*z0m(i)))))
+                FM(i) = AMAX1((1.-2.0*CB*zri(i)*zucf),f_ri_cd_min)
+                FH(i) = AMAX1((1.-3.0*CB*zri(i)*zucf),f_ri_cd_min)
+         END SELECT
+! Calcul des drags
+         cdm(i)=cdmn(i)*FM(i)
+         cdh(i)=f_cdrag_ter*cdhn(i)*FH(i)
+       ELSE                          
+!'''''''''''''''
+! Cas stables :
+!'''''''''''''''
+         zri(i) = MIN(20.,zri(i))
+         SELECT CASE (iflag_corr_sta)
+           CASE (1) ! Louis 1979 + Mascart 1995
+                FM(i)=MAX(1./((1+BPRIME*zri(i))**2),f_ri_cd_min)
+                FH(i)=FM(i)
+           CASE (2) ! Louis 1982
+                zscf = SQRT(1.+CD*ABS(zri(i)))
+                FM(i)= AMAX1(1. / (1.+2.*CB*zri(i)/zscf), f_ri_cd_min)
+                FH(i)= AMAX1(1./ (1.+3.*CB*zri(i)*zscf), f_ri_cd_min )
+           CASE (3) ! Laurent Li
+                FM(i)=MAX(1.0 / (1.0+10.0*zri(i)*(1+8.0*zri(i))),f_ri_cd_min)
+                FH(i)=FM(i)
+           CASE (4)  ! King 2001
+                if (zri(i) .LT. C2/2.) then
+                  FM(i)=MAX((1.-zri(i)/C2)**2,f_ri_cd_min)
+                  FH(i)=  FM(i)
+                else
+                  FM(i)=MAX(C3*((C2/zri(i))**2),f_ri_cd_min)
+                  FH(i)= FM(i)
+                endif
+           CASE (5) ! MO
+                if (zri(i) .LT. 1./alpha) then
+                  FM(i)=MAX((1.-alpha*zri(i))**2,f_ri_cd_min)
+                  FH(i)=FM(i)
+                else 
+                  FM(i)=MAX(1E-7,f_ri_cd_min)
+                  FH(i)=FM(i)
+                endif
+           CASE (6) ! Consistent with turbulence scheme (in stationary case) derived in atke (2023)
+                sm(i) = MAX(0.,cn*(1.-zri(i)/ric))
+                prandtl(i) = pr_neut + zri(i) * pr_slope
+                FM(i) = MAX((sm(i)**(3./2.) * sqrt(cepsilon) * (1 - zri(i) / prandtl(i))**(1./2.)),f_ri_cd_min)
+                FH(i) = MAX((FM(i) / prandtl(i)), f_ri_cd_min)
+           CASE default ! Louis 1982
+                zscf = SQRT(1.+CD*ABS(zri(i)))
+                FM(i)= AMAX1(1. / (1.+2.*CB*zri(i)/zscf), f_ri_cd_min)
+                FH(i)= AMAX1(1./ (1.+3.*CB*zri(i)*zscf), f_ri_cd_min )
+         END SELECT
+! Calcul des drags
+         cdm(i)=cdmn(i)*FM(i)
+         cdh(i)=f_cdrag_ter*cdhn(i)*FH(i)
+       ENDIF
+     ENDIF ! fin du if (nsrf == is_oce)
+  END DO   !  Fin de la boucle sur l'horizontal
+
+END SUBROUTINE cdrag
+
+END MODULE cdrag_mod
Index: DZ6/trunk/libf/phylmd/cfmip_point_locations.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cfmip_point_locations.F90	(revision 5267)
+++ 	(revision )
@@ -1,120 +1,0 @@
-MODULE cfmip_point_locations
-  IMPLICIT NONE
-
-CONTAINS
-
- SUBROUTINE read_CFMIP_point_locations(npCFMIP, tab, lonCFMIP, latCFMIP)
-  IMPLICIT none
-  INTEGER :: npCFMIP
-  REAL, DIMENSION(npCFMIP) :: lonCFMIP, latCFMIP
-  INTEGER :: tab(npCFMIP), np
-
-  WRITE(*,*) 'npCFMIP=',npCFMIP
-! OPEN(20, file="pointlocations.txt",status='old')
-  OPEN(20, file="pointlocations.txt",status='old',err=999)
-  OPEN(21, file="pointlocations_lon180.txt")
-  np=1
-10 READ(20,*) tab(np), lonCFMIP(np), latCFMIP(np)
-!!! passage de 0-360 a -180/180
-   IF (lonCFMIP(np).GT.180.) THEN
-    lonCFMIP(np)=lonCFMIP(np)-360.
-   ENDIF 
-   WRITE(21,*) np, lonCFMIP(np), latCFMIP(np)
-   np=np+1
-   IF(np.LE.npCFMIP) THEN 
-    GOTO 10
-   ENDIF
-   CLOSE(20)
-   CLOSE(21)
-999 RETURN
- END SUBROUTINE read_CFMIP_point_locations
-
- SUBROUTINE LMDZ_CFMIP_point_locations(npCFMIP, lonCFMIP, latCFMIP, &
-  tabijGCM, lonGCM, latGCM, ipt, jpt)
-  USE dimphy
-  USE iophy
-  USE mod_grid_phy_lmdz, ONLY: nbp_lon, nbp_lat, klon_glo
-
-  IMPLICIT none 
-  INTEGER :: npCFMIP
-  REAL, DIMENSION(npCFMIP) :: lonCFMIP, latCFMIP
-  INTEGER :: i, j, np, ip
-  INTEGER, DIMENSION(npCFMIP) :: ipt, jpt 
-  REAL :: dlon1, dlon2
-  REAL :: dlat1, dlat2
-  REAL, DIMENSION(nbp_lon+1) :: lon
-  INTEGER, DIMENSION(npCFMIP) :: tabijGCM
-  REAL, DIMENSION(npCFMIP) :: lonGCM, latGCM
-
-  lon(1:nbp_lon)=io_lon(:)
-  lon(nbp_lon+1)=-1*lon(1)
-  OPEN(22, file="LMDZ_pointsCFMIP.txt")
-  DO np=1, npCFMIP
-  DO i=1, nbp_lon
-!
-! PRINT*,'IM np i lonCF lonGCM lonGCM+1',np,i,lonCFMIP(np),lon(i), &
-!  lon(i+1)
-!
-   IF(lonCFMIP(np).GE.lon(i).AND.lonCFMIP(np).LT.lon(i+1)) THEN
-    dlon1 = abs (lonCFMIP(np) - lon(i))
-    dlon2 = abs (lonCFMIP(np) - lon(i+1))
-    IF (dlon1.LE.dlon2) THEN
-     ipt(np)=i
-    ELSE
-     ipt(np)=i+1
-    ENDIF
-   ENDIF
-  END DO
-  END DO
-!
-   np=1
-30 j=1
-40 IF(latCFMIP(np).LE.io_lat(j).AND.latCFMIP(np).GE.io_lat(j+1)) THEN
-    dlat1 = abs (latCFMIP(np) - io_lat(j))
-    dlat2 = abs (latCFMIP(np) - io_lat(j+1))
-    IF (dlat1.LE.dlat2) THEN
-     jpt(np)=j
-    ELSE
-     jpt(np)=j+1
-    ENDIF
-    np=np+1
-    IF(np.LE.npCFMIP) THEN
-     GOTO 30
-    ENDIF 
-   ELSE
-    j=j+1
-    IF(j.LE.nbp_lat-1) THEN 
-     GOTO 40
-    ENDIF
-   ENDIF
-
-  DO np=1, npCFMIP
-   WRITE(22,*) lon(ipt(np)), io_lat(jpt(np))
-  ENDDO
-  CLOSE(22)
-
-  OPEN(23, file="pointsCFMIPvsLMDZ.txt")
-    DO ip=1, npCFMIP
-     lonGCM(ip)=lon(ipt(ip))
-     latGCM(ip)=io_lat(jpt(ip))
-     if(jpt(ip).GE.2.AND.jpt(ip).LE.nbp_lat-1) THEN     
-      tabijGCM(ip)=1+(jpt(ip)-2)*nbp_lon+ipt(ip)
-     else if(jpt(ip).EQ.1) THEN
-      tabijGCM(ip)=1
-     else if(jpt(ip).EQ.nbp_lat) THEN
-      tabijGCM(ip)=klon_glo
-     else 
-      print*,'ip jpt tabijGCM',ip,jpt(ip),tabijGCM(ip)
-     endif
-!    PRINT*,'CFMIP ip lon lat tabijGCM',ip,lonGCM(ip),latGCM(ip),tabijGCM(ip)
-    ENDDO
-    DO ip=1, npCFMIP
-     if(lonGCM(ip).EQ.io_lon(1)) lonGCM(ip)=360.+lonGCM(ip)
-    ENDDO
-   DO i=1, npCFMIP
-    WRITE(23,*) i, lonCFMIP(i), latCFMIP(i), lonGCM(i), latGCM(i), tabijGCM(i)
-   ENDDO
-   CLOSE(23)
- END SUBROUTINE LMDZ_CFMIP_point_locations 
-
-END MODULE CFMIP_point_locations
Index: /LMDZ6/trunk/libf/phylmd/cfmip_point_locations.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cfmip_point_locations.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/cfmip_point_locations.f90	(revision 5268)
@@ -0,0 +1,120 @@
+MODULE cfmip_point_locations
+  IMPLICIT NONE
+
+CONTAINS
+
+ SUBROUTINE read_CFMIP_point_locations(npCFMIP, tab, lonCFMIP, latCFMIP)
+  IMPLICIT none
+  INTEGER :: npCFMIP
+  REAL, DIMENSION(npCFMIP) :: lonCFMIP, latCFMIP
+  INTEGER :: tab(npCFMIP), np
+
+  WRITE(*,*) 'npCFMIP=',npCFMIP
+! OPEN(20, file="pointlocations.txt",status='old')
+  OPEN(20, file="pointlocations.txt",status='old',err=999)
+  OPEN(21, file="pointlocations_lon180.txt")
+  np=1
+10 READ(20,*) tab(np), lonCFMIP(np), latCFMIP(np)
+!!! passage de 0-360 a -180/180
+   IF (lonCFMIP(np).GT.180.) THEN
+    lonCFMIP(np)=lonCFMIP(np)-360.
+   ENDIF 
+   WRITE(21,*) np, lonCFMIP(np), latCFMIP(np)
+   np=np+1
+   IF(np.LE.npCFMIP) THEN 
+    GOTO 10
+   ENDIF
+   CLOSE(20)
+   CLOSE(21)
+999 RETURN
+ END SUBROUTINE read_CFMIP_point_locations
+
+ SUBROUTINE LMDZ_CFMIP_point_locations(npCFMIP, lonCFMIP, latCFMIP, &
+  tabijGCM, lonGCM, latGCM, ipt, jpt)
+  USE dimphy
+  USE iophy
+  USE mod_grid_phy_lmdz, ONLY: nbp_lon, nbp_lat, klon_glo
+
+  IMPLICIT none 
+  INTEGER :: npCFMIP
+  REAL, DIMENSION(npCFMIP) :: lonCFMIP, latCFMIP
+  INTEGER :: i, j, np, ip
+  INTEGER, DIMENSION(npCFMIP) :: ipt, jpt 
+  REAL :: dlon1, dlon2
+  REAL :: dlat1, dlat2
+  REAL, DIMENSION(nbp_lon+1) :: lon
+  INTEGER, DIMENSION(npCFMIP) :: tabijGCM
+  REAL, DIMENSION(npCFMIP) :: lonGCM, latGCM
+
+  lon(1:nbp_lon)=io_lon(:)
+  lon(nbp_lon+1)=-1*lon(1)
+  OPEN(22, file="LMDZ_pointsCFMIP.txt")
+  DO np=1, npCFMIP
+  DO i=1, nbp_lon
+!
+! PRINT*,'IM np i lonCF lonGCM lonGCM+1',np,i,lonCFMIP(np),lon(i), &
+!  lon(i+1)
+!
+   IF(lonCFMIP(np).GE.lon(i).AND.lonCFMIP(np).LT.lon(i+1)) THEN
+    dlon1 = abs (lonCFMIP(np) - lon(i))
+    dlon2 = abs (lonCFMIP(np) - lon(i+1))
+    IF (dlon1.LE.dlon2) THEN
+     ipt(np)=i
+    ELSE
+     ipt(np)=i+1
+    ENDIF
+   ENDIF
+  END DO
+  END DO
+!
+   np=1
+30 j=1
+40 IF(latCFMIP(np).LE.io_lat(j).AND.latCFMIP(np).GE.io_lat(j+1)) THEN
+    dlat1 = abs (latCFMIP(np) - io_lat(j))
+    dlat2 = abs (latCFMIP(np) - io_lat(j+1))
+    IF (dlat1.LE.dlat2) THEN
+     jpt(np)=j
+    ELSE
+     jpt(np)=j+1
+    ENDIF
+    np=np+1
+    IF(np.LE.npCFMIP) THEN
+     GOTO 30
+    ENDIF 
+   ELSE
+    j=j+1
+    IF(j.LE.nbp_lat-1) THEN 
+     GOTO 40
+    ENDIF
+   ENDIF
+
+  DO np=1, npCFMIP
+   WRITE(22,*) lon(ipt(np)), io_lat(jpt(np))
+  ENDDO
+  CLOSE(22)
+
+  OPEN(23, file="pointsCFMIPvsLMDZ.txt")
+    DO ip=1, npCFMIP
+     lonGCM(ip)=lon(ipt(ip))
+     latGCM(ip)=io_lat(jpt(ip))
+     if(jpt(ip).GE.2.AND.jpt(ip).LE.nbp_lat-1) THEN     
+      tabijGCM(ip)=1+(jpt(ip)-2)*nbp_lon+ipt(ip)
+     else if(jpt(ip).EQ.1) THEN
+      tabijGCM(ip)=1
+     else if(jpt(ip).EQ.nbp_lat) THEN
+      tabijGCM(ip)=klon_glo
+     else 
+      print*,'ip jpt tabijGCM',ip,jpt(ip),tabijGCM(ip)
+     endif
+!    PRINT*,'CFMIP ip lon lat tabijGCM',ip,lonGCM(ip),latGCM(ip),tabijGCM(ip)
+    ENDDO
+    DO ip=1, npCFMIP
+     if(lonGCM(ip).EQ.io_lon(1)) lonGCM(ip)=360.+lonGCM(ip)
+    ENDDO
+   DO i=1, npCFMIP
+    WRITE(23,*) i, lonCFMIP(i), latCFMIP(i), lonGCM(i), latGCM(i), tabijGCM(i)
+   ENDDO
+   CLOSE(23)
+ END SUBROUTINE LMDZ_CFMIP_point_locations 
+
+END MODULE CFMIP_point_locations
Index: DZ6/trunk/libf/phylmd/change_srf_frac_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/change_srf_frac_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,194 +1,0 @@
-!
-! $Id$
-!
-MODULE change_srf_frac_mod
-
-  IMPLICIT NONE
-
-CONTAINS
-! 
-! Change Surface Fractions
-! Author J Ghattas 2008
-
-  SUBROUTINE change_srf_frac(itime, dtime, jour, &
-        pctsrf, evap, z0m, z0h, agesno,              &
-        alb_dir, alb_dif, tsurf, ustar, u10m, v10m, pbl_tke)
-   
-
-
-!
-! This subroutine is called from physiq.F at each timestep. 
-! 1- For each type of ocean (force, slab, couple) receive new fractions only if
-!    it's time to modify (is_modified=true). Otherwise nothing is done (is_modified=false).   
-! If received new fraction :
-! 2- Tests and ajustements are done on the fractions 
-! 3- Initialize variables where a new fraction(new or melted ice) has appered, 
-!
-
-    USE dimphy 
-    USE surface_data, ONLY : type_ocean,version_ocean
-    USE limit_read_mod
-    USE pbl_surface_mod, ONLY : pbl_surface_newfrac
-    USE cpl_mod, ONLY : cpl_receive_frac
-    USE ocean_slab_mod, ONLY : fsic, ocean_slab_frac
-    USE indice_sol_mod
-    USE print_control_mod, ONLY: lunout
-    
-    INCLUDE "YOMCST.h"
-!albedo SB >>>
-    include "clesphys.h"
-!albedo SB <<<
-
-
-
-! Input arguments
-!****************************************************************************************
-    INTEGER, INTENT(IN)                     :: itime   ! current time step
-    INTEGER, INTENT(IN)                     :: jour    ! day of the year
-    REAL,    INTENT(IN)                     :: dtime   ! length of time step (s)
-  
-! In-Output arguments
-!****************************************************************************************
-   
-    REAL, DIMENSION(klon,nbsrf), INTENT(INOUT) :: pctsrf ! sub-surface fraction
-    REAL, DIMENSION(klon,nbsrf), INTENT(INOUT) :: evap, agesno ! sub-surface fraction
-    REAL, DIMENSION(klon,nbsrf+1), INTENT(INOUT) :: z0m,z0h ! sub-surface fraction
-!albedo SB >>>
-    REAL, DIMENSION(klon,nsw,nbsrf), INTENT(INOUT) :: alb_dir,alb_dif
-!albedo SB <<<
-
-    REAL, DIMENSION(klon,nbsrf), INTENT(INOUT) :: tsurf
-    REAL, DIMENSION(klon,nbsrf), INTENT(INOUT) :: ustar
-    REAL, DIMENSION(klon,nbsrf), INTENT(INOUT) :: u10m
-    REAL, DIMENSION(klon,nbsrf), INTENT(INOUT) :: v10m
-!jyg<
-!!    REAL, DIMENSION(klon,klev+1,nbsrf), INTENT(INOUT) :: pbl_tke
-    REAL, DIMENSION(klon,klev+1,nbsrf+1), INTENT(INOUT) :: pbl_tke
-!>jyg
-
-! Loccal variables
-!****************************************************************************************
-    INTEGER                        :: i, nsrf
-    LOGICAL                        :: is_modified   ! true if pctsrf is modified at this time step
-    LOGICAL                        :: test_sum=.FALSE.
-    LOGICAL, DIMENSION(klon,nbsrf) :: new_surf
-    REAL, DIMENSION(klon,nbsrf)    :: pctsrf_old    ! fraction from previous time-step
-    REAL                           :: tmpsum
-
-    pctsrf_old(:,:) = pctsrf(:,:)
-!****************************************************************************************
-! 1) 
-! For each type of ocean (force, slab, couple) receive new fractions only if it's time  
-! to modify (is_modified=true). Otherwise nothing is done (is_modified=false).   
-!****************************************************************************************
-    SELECT CASE (type_ocean)
-    CASE ('force')
-       ! Read fraction from limit.nc
-       CALL limit_read_frac(itime, dtime, jour, pctsrf, is_modified)
-    CASE ('slab')
-       IF (version_ocean == 'sicOBS'.OR. version_ocean == 'sicNO') THEN
-       ! Read fraction from limit.nc
-           CALL limit_read_frac(itime, dtime, jour, pctsrf, is_modified)
-       ELSE
-       ! Get fraction from slab module
-           CALL ocean_slab_frac(itime, dtime, jour, pctsrf, is_modified)
-       ENDIF
-    CASE ('couple')
-       ! Get fraction from the coupler
-       CALL cpl_receive_frac(itime, dtime, pctsrf, is_modified)
-    END SELECT
-
-
-!****************************************************************************************
-! 2) 
-! Tests and ajustements on the new fractions :
-! - Put to zero fractions that are too small
-! - Test total fraction sum is one for each grid point
-!
-!****************************************************************************************
-    IF (is_modified) THEN
-  
-! Test and exit if a fraction is negative
-       IF (MINVAL(pctsrf(:,:)) < 0.) THEN
-          WRITE(lunout,*)'Warning! One or several fractions are negative, itime=',itime
-          WRITE(lunout,*)'at point = ',MINLOC(pctsrf(:,:))
-          WRITE(lunout,*)'value = ',MINVAL(pctsrf(:,:)) 
-          CALL abort_physic('change_srf_frac','Negative fraction',1)
-       END IF
-
-! Optional test on the incoming fraction 
-       IF (test_sum) THEN
-          DO i= 1, klon
-             tmpsum = SUM(pctsrf(i,:))
-             IF (ABS(1. - tmpsum) > 0.05) CALL abort_physic('change_srf_frac','Total fraction not equal 1.',1)
-          END DO
-       END IF
-
-! Test for too small fractions of the sum land+landice and ocean+sea-ice
-       WHERE ((pctsrf(:,is_ter) + pctsrf(:,is_lic)) < 2*EPSFRA)
-          pctsrf(:,is_ter) = 0.
-          pctsrf(:,is_lic) = 0.
-       END WHERE
-
-       WHERE ((pctsrf(:,is_oce) + pctsrf(:,is_sic)) < 2*EPSFRA)
-          pctsrf(:,is_oce) = 0.
-          pctsrf(:,is_sic) = 0.
-       END WHERE
-
-! Normalize to force total fraction to be equal one
-       DO i= 1, klon
-          tmpsum = SUM(pctsrf(i,:))
-          DO nsrf = 1, nbsrf
-             pctsrf(i,nsrf) = pctsrf(i,nsrf) / tmpsum
-          END DO
-       END DO
-
-! Test for too small fractions at each sub-surface
-       WHERE (pctsrf(:,is_ter) < EPSFRA)
-          pctsrf(:,is_lic) = pctsrf(:,is_ter) + pctsrf(:,is_lic)
-          pctsrf(:,is_ter) = 0.
-       END WHERE
-
-       WHERE (pctsrf(:,is_lic) < EPSFRA)
-          pctsrf(:,is_ter) = pctsrf(:,is_ter) + pctsrf(:,is_lic)
-          pctsrf(:,is_lic) = 0.
-       END WHERE
-
-       WHERE (pctsrf(:,is_oce) < EPSFRA)
-          pctsrf(:,is_sic) = pctsrf(:,is_oce) + pctsrf(:,is_sic)
-          pctsrf(:,is_oce) = 0.
-       END WHERE
-
-       WHERE (pctsrf(:,is_sic) < EPSFRA)
-          pctsrf(:,is_oce) = pctsrf(:,is_oce) + pctsrf(:,is_sic)
-          pctsrf(:,is_sic) = 0.
-       END WHERE
-! Send fractions back to slab ocean if needed
-       IF (type_ocean == 'slab'.AND. version_ocean.NE.'sicINT') THEN
-           WHERE (1.-zmasq(:)>EPSFRA)
-               fsic(:)=pctsrf(:,is_sic)/(1.-zmasq(:))
-           END WHERE
-       END IF
-
-!****************************************************************************************
-! 3)
-! Initialize variables where a new fraction has appered, 
-! i.e. where new sea ice has been formed
-! or where ice free ocean has appread in a grid cell
-! 
-!****************************************************************************************
-
-       CALL pbl_surface_newfrac(itime, pctsrf, pctsrf_old,        &
-           evap, z0m, z0h, agesno,                                &
-           tsurf, alb_dir,alb_dif, ustar, u10m, v10m, pbl_tke)
-
-    ELSE
-       ! No modifcation should be done
-       pctsrf(:,:) = pctsrf_old(:,:)
-
-    END IF ! is_modified
-
-  END SUBROUTINE change_srf_frac
-
-
-END MODULE change_srf_frac_mod
Index: /LMDZ6/trunk/libf/phylmd/change_srf_frac_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/change_srf_frac_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/change_srf_frac_mod.f90	(revision 5268)
@@ -0,0 +1,194 @@
+!
+! $Id$
+!
+MODULE change_srf_frac_mod
+
+  IMPLICIT NONE
+
+CONTAINS
+! 
+! Change Surface Fractions
+! Author J Ghattas 2008
+
+  SUBROUTINE change_srf_frac(itime, dtime, jour, &
+        pctsrf, evap, z0m, z0h, agesno,              &
+        alb_dir, alb_dif, tsurf, ustar, u10m, v10m, pbl_tke)
+   
+
+
+!
+! This subroutine is called from physiq.F at each timestep. 
+! 1- For each type of ocean (force, slab, couple) receive new fractions only if
+!    it's time to modify (is_modified=true). Otherwise nothing is done (is_modified=false).   
+! If received new fraction :
+! 2- Tests and ajustements are done on the fractions 
+! 3- Initialize variables where a new fraction(new or melted ice) has appered, 
+!
+
+    USE dimphy 
+    USE surface_data, ONLY : type_ocean,version_ocean
+    USE limit_read_mod
+    USE pbl_surface_mod, ONLY : pbl_surface_newfrac
+    USE cpl_mod, ONLY : cpl_receive_frac
+    USE ocean_slab_mod, ONLY : fsic, ocean_slab_frac
+    USE indice_sol_mod
+    USE print_control_mod, ONLY: lunout
+    
+    INCLUDE "YOMCST.h"
+!albedo SB >>>
+    include "clesphys.h"
+!albedo SB <<<
+
+
+
+! Input arguments
+!****************************************************************************************
+    INTEGER, INTENT(IN)                     :: itime   ! current time step
+    INTEGER, INTENT(IN)                     :: jour    ! day of the year
+    REAL,    INTENT(IN)                     :: dtime   ! length of time step (s)
+  
+! In-Output arguments
+!****************************************************************************************
+   
+    REAL, DIMENSION(klon,nbsrf), INTENT(INOUT) :: pctsrf ! sub-surface fraction
+    REAL, DIMENSION(klon,nbsrf), INTENT(INOUT) :: evap, agesno ! sub-surface fraction
+    REAL, DIMENSION(klon,nbsrf+1), INTENT(INOUT) :: z0m,z0h ! sub-surface fraction
+!albedo SB >>>
+    REAL, DIMENSION(klon,nsw,nbsrf), INTENT(INOUT) :: alb_dir,alb_dif
+!albedo SB <<<
+
+    REAL, DIMENSION(klon,nbsrf), INTENT(INOUT) :: tsurf
+    REAL, DIMENSION(klon,nbsrf), INTENT(INOUT) :: ustar
+    REAL, DIMENSION(klon,nbsrf), INTENT(INOUT) :: u10m
+    REAL, DIMENSION(klon,nbsrf), INTENT(INOUT) :: v10m
+!jyg<
+!!    REAL, DIMENSION(klon,klev+1,nbsrf), INTENT(INOUT) :: pbl_tke
+    REAL, DIMENSION(klon,klev+1,nbsrf+1), INTENT(INOUT) :: pbl_tke
+!>jyg
+
+! Loccal variables
+!****************************************************************************************
+    INTEGER                        :: i, nsrf
+    LOGICAL                        :: is_modified   ! true if pctsrf is modified at this time step
+    LOGICAL                        :: test_sum=.FALSE.
+    LOGICAL, DIMENSION(klon,nbsrf) :: new_surf
+    REAL, DIMENSION(klon,nbsrf)    :: pctsrf_old    ! fraction from previous time-step
+    REAL                           :: tmpsum
+
+    pctsrf_old(:,:) = pctsrf(:,:)
+!****************************************************************************************
+! 1) 
+! For each type of ocean (force, slab, couple) receive new fractions only if it's time  
+! to modify (is_modified=true). Otherwise nothing is done (is_modified=false).   
+!****************************************************************************************
+    SELECT CASE (type_ocean)
+    CASE ('force')
+       ! Read fraction from limit.nc
+       CALL limit_read_frac(itime, dtime, jour, pctsrf, is_modified)
+    CASE ('slab')
+       IF (version_ocean == 'sicOBS'.OR. version_ocean == 'sicNO') THEN
+       ! Read fraction from limit.nc
+           CALL limit_read_frac(itime, dtime, jour, pctsrf, is_modified)
+       ELSE
+       ! Get fraction from slab module
+           CALL ocean_slab_frac(itime, dtime, jour, pctsrf, is_modified)
+       ENDIF
+    CASE ('couple')
+       ! Get fraction from the coupler
+       CALL cpl_receive_frac(itime, dtime, pctsrf, is_modified)
+    END SELECT
+
+
+!****************************************************************************************
+! 2) 
+! Tests and ajustements on the new fractions :
+! - Put to zero fractions that are too small
+! - Test total fraction sum is one for each grid point
+!
+!****************************************************************************************
+    IF (is_modified) THEN
+  
+! Test and exit if a fraction is negative
+       IF (MINVAL(pctsrf(:,:)) < 0.) THEN
+          WRITE(lunout,*)'Warning! One or several fractions are negative, itime=',itime
+          WRITE(lunout,*)'at point = ',MINLOC(pctsrf(:,:))
+          WRITE(lunout,*)'value = ',MINVAL(pctsrf(:,:)) 
+          CALL abort_physic('change_srf_frac','Negative fraction',1)
+       END IF
+
+! Optional test on the incoming fraction 
+       IF (test_sum) THEN
+          DO i= 1, klon
+             tmpsum = SUM(pctsrf(i,:))
+             IF (ABS(1. - tmpsum) > 0.05) CALL abort_physic('change_srf_frac','Total fraction not equal 1.',1)
+          END DO
+       END IF
+
+! Test for too small fractions of the sum land+landice and ocean+sea-ice
+       WHERE ((pctsrf(:,is_ter) + pctsrf(:,is_lic)) < 2*EPSFRA)
+          pctsrf(:,is_ter) = 0.
+          pctsrf(:,is_lic) = 0.
+       END WHERE
+
+       WHERE ((pctsrf(:,is_oce) + pctsrf(:,is_sic)) < 2*EPSFRA)
+          pctsrf(:,is_oce) = 0.
+          pctsrf(:,is_sic) = 0.
+       END WHERE
+
+! Normalize to force total fraction to be equal one
+       DO i= 1, klon
+          tmpsum = SUM(pctsrf(i,:))
+          DO nsrf = 1, nbsrf
+             pctsrf(i,nsrf) = pctsrf(i,nsrf) / tmpsum
+          END DO
+       END DO
+
+! Test for too small fractions at each sub-surface
+       WHERE (pctsrf(:,is_ter) < EPSFRA)
+          pctsrf(:,is_lic) = pctsrf(:,is_ter) + pctsrf(:,is_lic)
+          pctsrf(:,is_ter) = 0.
+       END WHERE
+
+       WHERE (pctsrf(:,is_lic) < EPSFRA)
+          pctsrf(:,is_ter) = pctsrf(:,is_ter) + pctsrf(:,is_lic)
+          pctsrf(:,is_lic) = 0.
+       END WHERE
+
+       WHERE (pctsrf(:,is_oce) < EPSFRA)
+          pctsrf(:,is_sic) = pctsrf(:,is_oce) + pctsrf(:,is_sic)
+          pctsrf(:,is_oce) = 0.
+       END WHERE
+
+       WHERE (pctsrf(:,is_sic) < EPSFRA)
+          pctsrf(:,is_oce) = pctsrf(:,is_oce) + pctsrf(:,is_sic)
+          pctsrf(:,is_sic) = 0.
+       END WHERE
+! Send fractions back to slab ocean if needed
+       IF (type_ocean == 'slab'.AND. version_ocean.NE.'sicINT') THEN
+           WHERE (1.-zmasq(:)>EPSFRA)
+               fsic(:)=pctsrf(:,is_sic)/(1.-zmasq(:))
+           END WHERE
+       END IF
+
+!****************************************************************************************
+! 3)
+! Initialize variables where a new fraction has appered, 
+! i.e. where new sea ice has been formed
+! or where ice free ocean has appread in a grid cell
+! 
+!****************************************************************************************
+
+       CALL pbl_surface_newfrac(itime, pctsrf, pctsrf_old,        &
+           evap, z0m, z0h, agesno,                                &
+           tsurf, alb_dir,alb_dif, ustar, u10m, v10m, pbl_tke)
+
+    ELSE
+       ! No modifcation should be done
+       pctsrf(:,:) = pctsrf_old(:,:)
+
+    END IF ! is_modified
+
+  END SUBROUTINE change_srf_frac
+
+
+END MODULE change_srf_frac_mod
Index: DZ6/trunk/libf/phylmd/chemistry_cycle_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/chemistry_cycle_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,25 +1,0 @@
-MODULE chemistry_cycle_mod
-
-!=======================================================================
-!   Authors: Anne Cozic and Thibaut Lurton
-!
-!  Purpose and description:
-!  -----------------------
-! Control module for the chemistry  tracers :
-!   - Definition of fluxes to be exchanged with Pisces and Inca 
-!
-!=======================================================================
-
-
-  IMPLICIT NONE
-
-! Variables read from parmeter file physiq.def
-  LOGICAL, SAVE, PUBLIC :: dms_cycle_cpl       ! Coupling of DMS fluxes between LMDZ/ORCHIDEE and LMDZ/OCEAN(PISCES) 
-!$OMP THREADPRIVATE(dms_cycle_cpl)   
-
-  LOGICAL, SAVE, PUBLIC :: n2o_cycle_cpl       ! Coupling of N2O fluxes between LMDZ/ORCHIDEE and LMDZ/OCEAN(PISCES) 
-!$OMP THREADPRIVATE(n2o_cycle_cpl)   
-
-
-  
-END MODULE chemistry_cycle_mod
Index: /LMDZ6/trunk/libf/phylmd/chemistry_cycle_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/chemistry_cycle_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/chemistry_cycle_mod.f90	(revision 5268)
@@ -0,0 +1,25 @@
+MODULE chemistry_cycle_mod
+
+!=======================================================================
+!   Authors: Anne Cozic and Thibaut Lurton
+!
+!  Purpose and description:
+!  -----------------------
+! Control module for the chemistry  tracers :
+!   - Definition of fluxes to be exchanged with Pisces and Inca 
+!
+!=======================================================================
+
+
+  IMPLICIT NONE
+
+! Variables read from parmeter file physiq.def
+  LOGICAL, SAVE, PUBLIC :: dms_cycle_cpl       ! Coupling of DMS fluxes between LMDZ/ORCHIDEE and LMDZ/OCEAN(PISCES) 
+!$OMP THREADPRIVATE(dms_cycle_cpl)   
+
+  LOGICAL, SAVE, PUBLIC :: n2o_cycle_cpl       ! Coupling of N2O fluxes between LMDZ/ORCHIDEE and LMDZ/OCEAN(PISCES) 
+!$OMP THREADPRIVATE(n2o_cycle_cpl)   
+
+
+  
+END MODULE chemistry_cycle_mod
Index: DZ6/trunk/libf/phylmd/clc_core_cp.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/clc_core_cp.F90	(revision 5267)
+++ 	(revision )
@@ -1,232 +1,0 @@
-!
-! $Id$
-!
-      SUBROUTINE clc_core_cp(du, dt, dq, t1, q1, &
-     				zu, zt, zq, &
-     					P,&
-     				n_it, mixte, &
-    			 coeffs, rugosm, rugosh)
-
-      IMPLICIT NONE
-
-
-  !  INTEGER     :: i,j,k
-  REAL, INTENT(IN) :: du,dt,dq,t1,q1
-  REAL, INTENT(IN) :: zu,zt,zq, P
-  INTEGER, INTENT(IN):: n_it
-  LOGICAL, INTENT(IN) :: mixte
-  REAL, DIMENSION(3), INTENT(OUT) :: coeffs
-  real, intent(out) :: rugosm
-  real, intent(out) :: rugosh
-
-
-!  REAL :: du,dt,t1,dq,q1
-  REAL :: dt_u, dq_u
-
-
-
-  REAL :: cd, ch, cd_rt, cd_n10, ce_n10, ce,&
-       u_N, X,&
-       rho,cpa,le
-
-  REAL :: usr,tsr,qsr
-  REAL, DIMENSION(3) :: zeta                           ! dans l'ordre: it courant, it precedente, var
-  REAL, DIMENSION(2,3) :: psi
-  REAL, PARAMETER :: g = 9.81, k=.41, sqrt_k = .640312 !avec g= gravité, k = cste von karman, sqrt_k = racine(k)
-  REAL :: logzu_10,logzt_10,logzq_10,logzt_zu,logzq_zu,&
-       u,cd_n10_rt,ch_n10_rt,ch_n10,chi,z_0m,z_0h,tv
-  INTEGER :: i,j,m1,m2,m3,m4,m5
-
-
-  REAL :: phih,phid,phie
-
-  
-  REAL, parameter :: alpha=2.7e-3,&           !alpha = a1 ds formulation smith 
-       beta = 1.42e-4,&                       !beta = a2 ds la formulation smith
-       gamma = 7.64e-5,&        !Large and yaeger 2006              !gamma = a3 ds formulation smith
-!       gamma = 13.09e-3,&         !Large and yaeger 2004
-       q0 = 1.64474                           ! q0 dzfinis mais pas reutilisée ds la suite ??
-
-  REAL, dimension(3) :: z
-  integer, dimension(2) :: tmp_shape
-  z = [zu, zt, zq]
- 
-
-
-  logzu_10 = LOG(zu/10.)
-  logzt_10 = LOG(zt/10.)
-  logzq_10 = LOG(zq/10.)
-  logzt_zu = logzt_10 - logzu_10
-  logzq_zu = logzq_10 - logzu_10
-
-  cpa = 1004.67                               !!! pas reutilise ds nvelle formulation...
-
-  tv = t1 * (1+.608*q1)                       !!!!! tv pas reutiliser ds nvelle formulation...
-  rho = p / (287.1 * t1 * (1.+.61*q1))        !!!! rho pas reutiliser ds nvelle formulation....
-
-
-  le = (2.501-.00237*(t1-273.15-dt))*1.e6     !!!!!! le pas reutiliser ds nvelle formulation....
-  
-  u = max(du,.5)                              !!!! u = vitesse du vent 1 er niveau
-  u_N = u                                     !!!!!!! u_N utilisée pour le calcul des premier calcul...
-  
-
-  !!!!! initialisation des parametres et premier calcul de z_0 cd et ch
-
-
-  if (mixte) then 
-     z_0m = 1.e-4                             !!!!! pour l'initialisation on fixe z_0 a 10-4
-     cd_n10 = k**2 / (log(10/z_0m))**2        !!!!! on calcul ensuite cd a 10 m d'après smith 
-     cd_n10_rt = sqrt(cd_n10)   
-  else
-! Large and yaeger 2006
-     cd_n10 = alpha / u_n + beta + gamma * u_n !!!!! calcul de cd pour core pur
-! Large and yaeger 2004
-!     cd_n10 = 1E-3 * (2.7/U_n + 0.142 + U_n/13.09) 
-     cd_n10_rt = sqrt(cd_n10)                  !!!!!!
-     z_0m = 10. * exp(-k/cd_n10_rt)            !!!!!!! on calcul le premier z_0
-  endif
-
-
-  if ( dt .gt. 0. ) then
-     ch_n10 = 0.018 * cd_n10_rt                !!!!!!! si regime stable calcul du ch
-!     z_0h = 10. * exp(-k/ch_n10)
-  else
-     ch_n10 = 0.0327 * cd_n10_rt               !!!!!!! si regime instable calcul du ch
-!     z_0h = 10. * exp(-k/ch_n10)
-  endif
-
-  ce_n10 = 3.46e-2 *cd_n10_rt                  !!!!!! calcul ensuite de ce
-
-
-  dt_u = dt                                    !!! def
-  dq_u = dq                                    !!! def
-
-  cd = cd_n10                                  !!! def
-  ch = ch_n10                                  !!! def
-  ce = ce_n10                                  !!! def
-
-  cd_rt = sqrt(cd)                             !!! def
-
-  !  open(7,file="err_rel.dat",position="append")
-
-
-!!!!!!!!! début des itérations....
-
-  do i = 1,n_it
-
-     usr = cd_rt * u 
-     tsr = ch / cd_rt *  dt_u
-     qsr = ce / cd_rt * dq_u
-
-
-     zeta = k*g / (usr**2) * tsr / t1&
-          * z
-
-     zeta = sign( min(abs(zeta),10.0), zeta )
-
-
-!!!! calcul du zeta pour connaitre le signe et donc en deduire le regime...
-
-
-
-
-     IF ( zeta(1) .GT. 0 ) THEN !!! si regime stable alors valeurs pr chi et psi 
-
-        chi = 0.018 
-
-
-        psi(1,1) = -5.*zeta(1)
-        psi(2,1) = psi(1,1)
-
-     ELSE !!!!! si regime instable alors valeurs pr psi et chi !!!
-
-        chi = 0.0327
-
-        X = sqrt( sqrt( 1-16.*zeta(1) ))
-        psi(1,1) =  3.1415695 / 2 + 2 * LOG( ( 1 + X ) / 2 ) + LOG( (1 + X**2) / 2 ) - 2*ATAN(X)
-        psi(2,1) =  2.*LOG( (1 + X**2) / 2 )
-
-     END IF
-
-     do j =2,3
-        IF ( zeta(j) .GT. 0 ) THEN
-           psi(1,j) = -5.*zeta(j)
-           psi(2,j) = psi(1,1)
-
-        ELSE
-           X = sqrt( sqrt( 1-16.*zeta(j) ))
-           psi(1,j) =  3.1415695 / 2 + 2 * LOG( ( 1 + X ) / 2 ) + LOG( (1 + X**2) / 2 ) - 2*ATAN(X)
-           psi(2,j) =  2.*LOG( (1 + X**2) / 2 )
-
-        END IF
-     enddo
-
-
-     dt_u = dt - tsr / k * &
-          ( logzt_zu + psi(2,1) - psi(2,2) )
-
-     dq_u = dq - qsr / k * &
-          ( logzq_zu + psi(2,1) - psi(2,3) )
-
-
-
-     u_N = u / ( 1 + cd_n10_rt / k * ( logzu_10 - psi(1,1)) )
-
-     if (mixte) then
-        z_0m=0.018*usr**2/9.81 + 0.11*14e-6 / (usr)
-!        z_0h=(0.11*14e-6 / (usr)) + 1.4e-5 
-        cd_n10 = k**2 / (log(10/z_0m))**2
-        cd_n10_rt = sqrt(cd_n10)
-!        ch_n10 = k**2 / ((log(10/z_0m))*(log(10/z_0h)))
-!        ch_n10_rt = sqrt(ch_n10)
-        ch_n10 = 1.e-3
-     else
-! Large and yaeger 2006
-        cd_n10 = alpha / u_n + beta + gamma * u_n !!!!! calcul de cd pour core pur
-! Large and yaeger 2004
-!        cd_n10 = 1E-3 * (2.7/U_n + 0.142 + U_n/13.09) 
-        !        cd_n10_dun = -alpha / u_n**2 + gamma
-        cd_n10_rt = sqrt(cd_n10)
-        z_0m = 10. * exp(-k/cd_n10_rt) !!!!! c'est sur cette ligne la qu'il y a un bug... ou sur la ligne du u_N
-!        ch_n10 = chi * cd_n10_rt
-!        z_0h = 10. * exp(-k/ch_n10)
-!        ch_n10_rt = sqrt(ch_n10)
-        ch_n10 = chi * cd_n10_rt
-     endif
-
-
-     ce_n10 = 3.46e-2*cd_n10_rt
-
-
-
-     phid = 1+cd_n10_rt/k * (logzu_10 - psi(1,1))
-     phih = 1+chi/k * (logzu_10 - psi(2,1))
-     phie = 1+3.46e-2/k * (logzu_10 - psi(2,1))
-
-
-     cd_rt = cd_n10_rt / abs( phid )
-     ch = ch_n10 / ( phih * phid )
-     ce = ce_n10 / ( phie * phid )
-
-     cd=cd_rt**2
-
-  END DO
-
-  usr = cd_rt * u
-  tsr = ch / cd_rt *  dt_u
-  qsr = ce / cd_rt * dq_u
-
-
-  ! coeffs(:,m) = [ &
-  !      rho * usr**2,&
-  !      rho * cpa * usr *tsr,&
-  !      rho * le * usr *qsr]
-
-  coeffs = [ cd_rt**2, ch , ce ]
-
-  rugosm =  z_0m
-  rugosh =  z_0h
-
-      RETURN
-      END subroutine clc_core_cp
Index: /LMDZ6/trunk/libf/phylmd/clc_core_cp.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/clc_core_cp.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/clc_core_cp.f90	(revision 5268)
@@ -0,0 +1,232 @@
+!
+! $Id$
+!
+      SUBROUTINE clc_core_cp(du, dt, dq, t1, q1, &
+     				zu, zt, zq, &
+     					P,&
+     				n_it, mixte, &
+    			 coeffs, rugosm, rugosh)
+
+      IMPLICIT NONE
+
+
+  !  INTEGER     :: i,j,k
+  REAL, INTENT(IN) :: du,dt,dq,t1,q1
+  REAL, INTENT(IN) :: zu,zt,zq, P
+  INTEGER, INTENT(IN):: n_it
+  LOGICAL, INTENT(IN) :: mixte
+  REAL, DIMENSION(3), INTENT(OUT) :: coeffs
+  real, intent(out) :: rugosm
+  real, intent(out) :: rugosh
+
+
+!  REAL :: du,dt,t1,dq,q1
+  REAL :: dt_u, dq_u
+
+
+
+  REAL :: cd, ch, cd_rt, cd_n10, ce_n10, ce,&
+       u_N, X,&
+       rho,cpa,le
+
+  REAL :: usr,tsr,qsr
+  REAL, DIMENSION(3) :: zeta                           ! dans l'ordre: it courant, it precedente, var
+  REAL, DIMENSION(2,3) :: psi
+  REAL, PARAMETER :: g = 9.81, k=.41, sqrt_k = .640312 !avec g= gravité, k = cste von karman, sqrt_k = racine(k)
+  REAL :: logzu_10,logzt_10,logzq_10,logzt_zu,logzq_zu,&
+       u,cd_n10_rt,ch_n10_rt,ch_n10,chi,z_0m,z_0h,tv
+  INTEGER :: i,j,m1,m2,m3,m4,m5
+
+
+  REAL :: phih,phid,phie
+
+  
+  REAL, parameter :: alpha=2.7e-3,&           !alpha = a1 ds formulation smith 
+       beta = 1.42e-4,&                       !beta = a2 ds la formulation smith
+       gamma = 7.64e-5,&        !Large and yaeger 2006              !gamma = a3 ds formulation smith
+!       gamma = 13.09e-3,&         !Large and yaeger 2004
+       q0 = 1.64474                           ! q0 dzfinis mais pas reutilisée ds la suite ??
+
+  REAL, dimension(3) :: z
+  integer, dimension(2) :: tmp_shape
+  z = [zu, zt, zq]
+ 
+
+
+  logzu_10 = LOG(zu/10.)
+  logzt_10 = LOG(zt/10.)
+  logzq_10 = LOG(zq/10.)
+  logzt_zu = logzt_10 - logzu_10
+  logzq_zu = logzq_10 - logzu_10
+
+  cpa = 1004.67                               !!! pas reutilise ds nvelle formulation...
+
+  tv = t1 * (1+.608*q1)                       !!!!! tv pas reutiliser ds nvelle formulation...
+  rho = p / (287.1 * t1 * (1.+.61*q1))        !!!! rho pas reutiliser ds nvelle formulation....
+
+
+  le = (2.501-.00237*(t1-273.15-dt))*1.e6     !!!!!! le pas reutiliser ds nvelle formulation....
+  
+  u = max(du,.5)                              !!!! u = vitesse du vent 1 er niveau
+  u_N = u                                     !!!!!!! u_N utilisée pour le calcul des premier calcul...
+  
+
+  !!!!! initialisation des parametres et premier calcul de z_0 cd et ch
+
+
+  if (mixte) then 
+     z_0m = 1.e-4                             !!!!! pour l'initialisation on fixe z_0 a 10-4
+     cd_n10 = k**2 / (log(10/z_0m))**2        !!!!! on calcul ensuite cd a 10 m d'après smith 
+     cd_n10_rt = sqrt(cd_n10)   
+  else
+! Large and yaeger 2006
+     cd_n10 = alpha / u_n + beta + gamma * u_n !!!!! calcul de cd pour core pur
+! Large and yaeger 2004
+!     cd_n10 = 1E-3 * (2.7/U_n + 0.142 + U_n/13.09) 
+     cd_n10_rt = sqrt(cd_n10)                  !!!!!!
+     z_0m = 10. * exp(-k/cd_n10_rt)            !!!!!!! on calcul le premier z_0
+  endif
+
+
+  if ( dt .gt. 0. ) then
+     ch_n10 = 0.018 * cd_n10_rt                !!!!!!! si regime stable calcul du ch
+!     z_0h = 10. * exp(-k/ch_n10)
+  else
+     ch_n10 = 0.0327 * cd_n10_rt               !!!!!!! si regime instable calcul du ch
+!     z_0h = 10. * exp(-k/ch_n10)
+  endif
+
+  ce_n10 = 3.46e-2 *cd_n10_rt                  !!!!!! calcul ensuite de ce
+
+
+  dt_u = dt                                    !!! def
+  dq_u = dq                                    !!! def
+
+  cd = cd_n10                                  !!! def
+  ch = ch_n10                                  !!! def
+  ce = ce_n10                                  !!! def
+
+  cd_rt = sqrt(cd)                             !!! def
+
+  !  open(7,file="err_rel.dat",position="append")
+
+
+!!!!!!!!! début des itérations....
+
+  do i = 1,n_it
+
+     usr = cd_rt * u 
+     tsr = ch / cd_rt *  dt_u
+     qsr = ce / cd_rt * dq_u
+
+
+     zeta = k*g / (usr**2) * tsr / t1&
+          * z
+
+     zeta = sign( min(abs(zeta),10.0), zeta )
+
+
+!!!! calcul du zeta pour connaitre le signe et donc en deduire le regime...
+
+
+
+
+     IF ( zeta(1) .GT. 0 ) THEN !!! si regime stable alors valeurs pr chi et psi 
+
+        chi = 0.018 
+
+
+        psi(1,1) = -5.*zeta(1)
+        psi(2,1) = psi(1,1)
+
+     ELSE !!!!! si regime instable alors valeurs pr psi et chi !!!
+
+        chi = 0.0327
+
+        X = sqrt( sqrt( 1-16.*zeta(1) ))
+        psi(1,1) =  3.1415695 / 2 + 2 * LOG( ( 1 + X ) / 2 ) + LOG( (1 + X**2) / 2 ) - 2*ATAN(X)
+        psi(2,1) =  2.*LOG( (1 + X**2) / 2 )
+
+     END IF
+
+     do j =2,3
+        IF ( zeta(j) .GT. 0 ) THEN
+           psi(1,j) = -5.*zeta(j)
+           psi(2,j) = psi(1,1)
+
+        ELSE
+           X = sqrt( sqrt( 1-16.*zeta(j) ))
+           psi(1,j) =  3.1415695 / 2 + 2 * LOG( ( 1 + X ) / 2 ) + LOG( (1 + X**2) / 2 ) - 2*ATAN(X)
+           psi(2,j) =  2.*LOG( (1 + X**2) / 2 )
+
+        END IF
+     enddo
+
+
+     dt_u = dt - tsr / k * &
+          ( logzt_zu + psi(2,1) - psi(2,2) )
+
+     dq_u = dq - qsr / k * &
+          ( logzq_zu + psi(2,1) - psi(2,3) )
+
+
+
+     u_N = u / ( 1 + cd_n10_rt / k * ( logzu_10 - psi(1,1)) )
+
+     if (mixte) then
+        z_0m=0.018*usr**2/9.81 + 0.11*14e-6 / (usr)
+!        z_0h=(0.11*14e-6 / (usr)) + 1.4e-5 
+        cd_n10 = k**2 / (log(10/z_0m))**2
+        cd_n10_rt = sqrt(cd_n10)
+!        ch_n10 = k**2 / ((log(10/z_0m))*(log(10/z_0h)))
+!        ch_n10_rt = sqrt(ch_n10)
+        ch_n10 = 1.e-3
+     else
+! Large and yaeger 2006
+        cd_n10 = alpha / u_n + beta + gamma * u_n !!!!! calcul de cd pour core pur
+! Large and yaeger 2004
+!        cd_n10 = 1E-3 * (2.7/U_n + 0.142 + U_n/13.09) 
+        !        cd_n10_dun = -alpha / u_n**2 + gamma
+        cd_n10_rt = sqrt(cd_n10)
+        z_0m = 10. * exp(-k/cd_n10_rt) !!!!! c'est sur cette ligne la qu'il y a un bug... ou sur la ligne du u_N
+!        ch_n10 = chi * cd_n10_rt
+!        z_0h = 10. * exp(-k/ch_n10)
+!        ch_n10_rt = sqrt(ch_n10)
+        ch_n10 = chi * cd_n10_rt
+     endif
+
+
+     ce_n10 = 3.46e-2*cd_n10_rt
+
+
+
+     phid = 1+cd_n10_rt/k * (logzu_10 - psi(1,1))
+     phih = 1+chi/k * (logzu_10 - psi(2,1))
+     phie = 1+3.46e-2/k * (logzu_10 - psi(2,1))
+
+
+     cd_rt = cd_n10_rt / abs( phid )
+     ch = ch_n10 / ( phih * phid )
+     ce = ce_n10 / ( phie * phid )
+
+     cd=cd_rt**2
+
+  END DO
+
+  usr = cd_rt * u
+  tsr = ch / cd_rt *  dt_u
+  qsr = ce / cd_rt * dq_u
+
+
+  ! coeffs(:,m) = [ &
+  !      rho * usr**2,&
+  !      rho * cpa * usr *tsr,&
+  !      rho * le * usr *qsr]
+
+  coeffs = [ cd_rt**2, ch , ce ]
+
+  rugosm =  z_0m
+  rugosh =  z_0h
+
+      RETURN
+      END subroutine clc_core_cp
Index: DZ6/trunk/libf/phylmd/clcdrag.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/clcdrag.F90	(revision 5267)
+++ 	(revision )
@@ -1,149 +1,0 @@
-!
-!$Id$
-!
-SUBROUTINE clcdrag(knon, nsrf, paprs, pplay,&
-     u1, v1, t1, q1, &
-     tsurf, qsurf, rugos, &
-     pcfm, pcfh)
-
-  USE dimphy
-  USE indice_sol_mod
-
-  IMPLICIT NONE
-! ================================================================= c
-!
-! Objet : calcul des cdrags pour le moment (pcfm) et 
-!         les flux de chaleur sensible et latente (pcfh).   
-!
-! ================================================================= c
-!
-! knon----input-I- nombre de points pour un type de surface
-! nsrf----input-I- indice pour le type de surface; voir indice_sol_mod.F90
-! u1-------input-R- vent zonal au 1er niveau du modele
-! v1-------input-R- vent meridien au 1er niveau du modele
-! t1-------input-R- temperature de l'air au 1er niveau du modele
-! q1-------input-R- humidite de l'air au 1er niveau du modele
-! tsurf------input-R- temperature de l'air a la surface
-! qsurf---input-R- humidite de l'air a la surface
-! rugos---input-R- rugosite
-!
-! pcfm---output-R- cdrag pour le moment 
-! pcfh---output-R- cdrag pour les flux de chaleur latente et sensible
-!
-  INTEGER, INTENT(IN)                      :: knon, nsrf
-  REAL, DIMENSION(klon,klev+1), INTENT(IN) :: paprs
-  REAL, DIMENSION(klon,klev), INTENT(IN)   :: pplay
-  REAL, DIMENSION(klon), INTENT(IN)        :: u1, v1, t1, q1
-  REAL, DIMENSION(klon), INTENT(IN)        :: tsurf, qsurf
-  REAL, DIMENSION(klon), INTENT(IN)        :: rugos
-  REAL, DIMENSION(klon), INTENT(OUT)       :: pcfm, pcfh
-!
-! ================================================================= c
-!
-  INCLUDE "YOMCST.h"
-  INCLUDE "YOETHF.h"
-  INCLUDE "clesphys.h"
-!
-! Quelques constantes et options:
-!!$PB      REAL, PARAMETER :: ckap=0.35, cb=5.0, cc=5.0, cd=5.0, cepdu2=(0.1)**2
-  REAL, PARAMETER :: ckap=0.40, cb=5.0, cc=5.0, cd=5.0, cepdu2=(0.1)**2
-!
-! Variables locales :
-  INTEGER               :: i
-  REAL                  :: zdu2, ztsolv
-  REAL                  :: ztvd, zscf
-  REAL                  :: zucf, zcr
-  REAL                  :: friv, frih
-  REAL, DIMENSION(klon) :: zcfm1, zcfm2
-  REAL, DIMENSION(klon) :: zcfh1, zcfh2
-  REAL, DIMENSION(klon) :: zcdn
-  REAL, DIMENSION(klon) :: zri
-  REAL, DIMENSION(klon) :: zgeop1       ! geopotentiel au 1er niveau du modele
-  LOGICAL, PARAMETER    :: zxli=.FALSE. ! calcul des cdrags selon Laurent Li
-
-  CHARACTER (LEN=80) :: abort_message
-  CHARACTER (LEN=20) :: modname = 'clcdrag'
-
-
-!
-! Fonctions thermodynamiques et fonctions d'instabilite
-  REAL                  :: fsta, fins, x
-  fsta(x) = 1.0 / (1.0+10.0*x*(1+8.0*x))
-  fins(x) = SQRT(1.0-18.0*x)
-
-  abort_message='obsolete, remplace par cdrag, use at you own risk'
-  CALL abort_physic(modname,abort_message,1)
-
-
-
-! ================================================================= c
-!
-! Calculer le geopotentiel du premier couche de modele
-!
-  DO i = 1, knon
-     zgeop1(i) = RD * t1(i) / (0.5*(paprs(i,1)+pplay(i,1))) &
-          * (paprs(i,1)-pplay(i,1))
-  END DO
-! ================================================================= c
-!
-! Calculer le frottement au sol (Cdrag)
-!
-  DO i = 1, knon
-     zdu2 = MAX(cepdu2,u1(i)**2+v1(i)**2)
-     ztsolv = tsurf(i) * (1.0+RETV*qsurf(i))
-     ztvd = (t1(i)+zgeop1(i)/RCPD/(1.+RVTMP2*q1(i))) &
-          *(1.+RETV*q1(i))
-     zri(i) = zgeop1(i)*(ztvd-ztsolv)/(zdu2*ztvd)
-     zcdn(i) = (ckap/LOG(1.+zgeop1(i)/(RG*rugos(i))))**2
-
-!!$        IF (zri(i) .ge. 0.) THEN      ! situation stable
-     IF (zri(i) .GT. 0.) THEN      ! situation stable
-        zri(i) = MIN(20.,zri(i))
-        IF (.NOT.zxli) THEN
-           zscf = SQRT(1.+cd*ABS(zri(i)))
-           FRIV = AMAX1(1. / (1.+2.*CB*zri(i)/ZSCF), f_ri_cd_min)
-           zcfm1(i) = zcdn(i) * FRIV
-           FRIH = AMAX1(1./ (1.+3.*CB*zri(i)*ZSCF), f_ri_cd_min )
-!!$  PB          zcfh1(i) = zcdn(i) * FRIH
-!!$ PB           zcfh1(i) = f_cdrag_stable * zcdn(i) * FRIH
-           zcfh1(i) = f_cdrag_ter * zcdn(i) * FRIH
-           IF(nsrf.EQ.is_oce) zcfh1(i) = f_cdrag_oce * zcdn(i) * FRIH
-!!$ PB
-           pcfm(i) = zcfm1(i)
-           pcfh(i) = zcfh1(i)
-        ELSE
-           pcfm(i) = zcdn(i)* fsta(zri(i))
-           pcfh(i) = zcdn(i)* fsta(zri(i))
-        ENDIF
-     ELSE                          ! situation instable
-        IF (.NOT.zxli) THEN
-           zucf = 1./(1.+3.0*cb*cc*zcdn(i)*SQRT(ABS(zri(i)) &
-                *(1.0+zgeop1(i)/(RG*rugos(i)))))
-           zcfm2(i) = zcdn(i)*amax1((1.-2.0*cb*zri(i)*zucf),f_ri_cd_min)
-!!$PB            zcfh2(i) = zcdn(i)*amax1((1.-3.0*cb*zri(i)*zucf),f_ri_cd_min)
-           zcfh2(i) = f_cdrag_ter*zcdn(i)*amax1((1.-3.0*cb*zri(i)*zucf),f_ri_cd_min)
-           pcfm(i) = zcfm2(i)
-           pcfh(i) = zcfh2(i)
-        ELSE
-           pcfm(i) = zcdn(i)* fins(zri(i))
-           pcfh(i) = zcdn(i)* fins(zri(i))
-        ENDIF
-        IF(iflag_gusts==0) THEN
-! cdrah sur l'ocean cf. Miller et al. (1992) - only active when gustiness parameterization is not active
-           zcr = (0.0016/(zcdn(i)*SQRT(zdu2)))*ABS(ztvd-ztsolv)**(1./3.)
-           IF(nsrf.EQ.is_oce) pcfh(i) =f_cdrag_oce* zcdn(i)*(1.0+zcr**1.25)**(1./1.25)
-        ENDIF
-     ENDIF
-  END DO
-
-! ================================================================= c
-     
-  ! IM cf JLD : on seuille cdrag_m et cdrag_h
-  IF (nsrf == is_oce) THEN
-     DO i=1,knon
-        pcfm(i)=MIN(pcfm(i),cdmmax)
-        pcfh(i)=MIN(pcfh(i),cdhmax)
-     END DO
-  END IF
-
-END SUBROUTINE clcdrag
Index: /LMDZ6/trunk/libf/phylmd/clcdrag.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/clcdrag.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/clcdrag.f90	(revision 5268)
@@ -0,0 +1,149 @@
+!
+!$Id$
+!
+SUBROUTINE clcdrag(knon, nsrf, paprs, pplay,&
+     u1, v1, t1, q1, &
+     tsurf, qsurf, rugos, &
+     pcfm, pcfh)
+
+  USE dimphy
+  USE indice_sol_mod
+
+  IMPLICIT NONE
+! ================================================================= c
+!
+! Objet : calcul des cdrags pour le moment (pcfm) et 
+!         les flux de chaleur sensible et latente (pcfh).   
+!
+! ================================================================= c
+!
+! knon----input-I- nombre de points pour un type de surface
+! nsrf----input-I- indice pour le type de surface; voir indice_sol_mod.F90
+! u1-------input-R- vent zonal au 1er niveau du modele
+! v1-------input-R- vent meridien au 1er niveau du modele
+! t1-------input-R- temperature de l'air au 1er niveau du modele
+! q1-------input-R- humidite de l'air au 1er niveau du modele
+! tsurf------input-R- temperature de l'air a la surface
+! qsurf---input-R- humidite de l'air a la surface
+! rugos---input-R- rugosite
+!
+! pcfm---output-R- cdrag pour le moment 
+! pcfh---output-R- cdrag pour les flux de chaleur latente et sensible
+!
+  INTEGER, INTENT(IN)                      :: knon, nsrf
+  REAL, DIMENSION(klon,klev+1), INTENT(IN) :: paprs
+  REAL, DIMENSION(klon,klev), INTENT(IN)   :: pplay
+  REAL, DIMENSION(klon), INTENT(IN)        :: u1, v1, t1, q1
+  REAL, DIMENSION(klon), INTENT(IN)        :: tsurf, qsurf
+  REAL, DIMENSION(klon), INTENT(IN)        :: rugos
+  REAL, DIMENSION(klon), INTENT(OUT)       :: pcfm, pcfh
+!
+! ================================================================= c
+!
+  INCLUDE "YOMCST.h"
+  INCLUDE "YOETHF.h"
+  INCLUDE "clesphys.h"
+!
+! Quelques constantes et options:
+!!$PB      REAL, PARAMETER :: ckap=0.35, cb=5.0, cc=5.0, cd=5.0, cepdu2=(0.1)**2
+  REAL, PARAMETER :: ckap=0.40, cb=5.0, cc=5.0, cd=5.0, cepdu2=(0.1)**2
+!
+! Variables locales :
+  INTEGER               :: i
+  REAL                  :: zdu2, ztsolv
+  REAL                  :: ztvd, zscf
+  REAL                  :: zucf, zcr
+  REAL                  :: friv, frih
+  REAL, DIMENSION(klon) :: zcfm1, zcfm2
+  REAL, DIMENSION(klon) :: zcfh1, zcfh2
+  REAL, DIMENSION(klon) :: zcdn
+  REAL, DIMENSION(klon) :: zri
+  REAL, DIMENSION(klon) :: zgeop1       ! geopotentiel au 1er niveau du modele
+  LOGICAL, PARAMETER    :: zxli=.FALSE. ! calcul des cdrags selon Laurent Li
+
+  CHARACTER (LEN=80) :: abort_message
+  CHARACTER (LEN=20) :: modname = 'clcdrag'
+
+
+!
+! Fonctions thermodynamiques et fonctions d'instabilite
+  REAL                  :: fsta, fins, x
+  fsta(x) = 1.0 / (1.0+10.0*x*(1+8.0*x))
+  fins(x) = SQRT(1.0-18.0*x)
+
+  abort_message='obsolete, remplace par cdrag, use at you own risk'
+  CALL abort_physic(modname,abort_message,1)
+
+
+
+! ================================================================= c
+!
+! Calculer le geopotentiel du premier couche de modele
+!
+  DO i = 1, knon
+     zgeop1(i) = RD * t1(i) / (0.5*(paprs(i,1)+pplay(i,1))) &
+          * (paprs(i,1)-pplay(i,1))
+  END DO
+! ================================================================= c
+!
+! Calculer le frottement au sol (Cdrag)
+!
+  DO i = 1, knon
+     zdu2 = MAX(cepdu2,u1(i)**2+v1(i)**2)
+     ztsolv = tsurf(i) * (1.0+RETV*qsurf(i))
+     ztvd = (t1(i)+zgeop1(i)/RCPD/(1.+RVTMP2*q1(i))) &
+          *(1.+RETV*q1(i))
+     zri(i) = zgeop1(i)*(ztvd-ztsolv)/(zdu2*ztvd)
+     zcdn(i) = (ckap/LOG(1.+zgeop1(i)/(RG*rugos(i))))**2
+
+!!$        IF (zri(i) .ge. 0.) THEN      ! situation stable
+     IF (zri(i) .GT. 0.) THEN      ! situation stable
+        zri(i) = MIN(20.,zri(i))
+        IF (.NOT.zxli) THEN
+           zscf = SQRT(1.+cd*ABS(zri(i)))
+           FRIV = AMAX1(1. / (1.+2.*CB*zri(i)/ZSCF), f_ri_cd_min)
+           zcfm1(i) = zcdn(i) * FRIV
+           FRIH = AMAX1(1./ (1.+3.*CB*zri(i)*ZSCF), f_ri_cd_min )
+!!$  PB          zcfh1(i) = zcdn(i) * FRIH
+!!$ PB           zcfh1(i) = f_cdrag_stable * zcdn(i) * FRIH
+           zcfh1(i) = f_cdrag_ter * zcdn(i) * FRIH
+           IF(nsrf.EQ.is_oce) zcfh1(i) = f_cdrag_oce * zcdn(i) * FRIH
+!!$ PB
+           pcfm(i) = zcfm1(i)
+           pcfh(i) = zcfh1(i)
+        ELSE
+           pcfm(i) = zcdn(i)* fsta(zri(i))
+           pcfh(i) = zcdn(i)* fsta(zri(i))
+        ENDIF
+     ELSE                          ! situation instable
+        IF (.NOT.zxli) THEN
+           zucf = 1./(1.+3.0*cb*cc*zcdn(i)*SQRT(ABS(zri(i)) &
+                *(1.0+zgeop1(i)/(RG*rugos(i)))))
+           zcfm2(i) = zcdn(i)*amax1((1.-2.0*cb*zri(i)*zucf),f_ri_cd_min)
+!!$PB            zcfh2(i) = zcdn(i)*amax1((1.-3.0*cb*zri(i)*zucf),f_ri_cd_min)
+           zcfh2(i) = f_cdrag_ter*zcdn(i)*amax1((1.-3.0*cb*zri(i)*zucf),f_ri_cd_min)
+           pcfm(i) = zcfm2(i)
+           pcfh(i) = zcfh2(i)
+        ELSE
+           pcfm(i) = zcdn(i)* fins(zri(i))
+           pcfh(i) = zcdn(i)* fins(zri(i))
+        ENDIF
+        IF(iflag_gusts==0) THEN
+! cdrah sur l'ocean cf. Miller et al. (1992) - only active when gustiness parameterization is not active
+           zcr = (0.0016/(zcdn(i)*SQRT(zdu2)))*ABS(ztvd-ztsolv)**(1./3.)
+           IF(nsrf.EQ.is_oce) pcfh(i) =f_cdrag_oce* zcdn(i)*(1.0+zcr**1.25)**(1./1.25)
+        ENDIF
+     ENDIF
+  END DO
+
+! ================================================================= c
+     
+  ! IM cf JLD : on seuille cdrag_m et cdrag_h
+  IF (nsrf == is_oce) THEN
+     DO i=1,knon
+        pcfm(i)=MIN(pcfm(i),cdmmax)
+        pcfh(i)=MIN(pcfh(i),cdhmax)
+     END DO
+  END IF
+
+END SUBROUTINE clcdrag
Index: DZ6/trunk/libf/phylmd/clift.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/clift.F90	(revision 5267)
+++ 	(revision )
@@ -1,74 +1,0 @@
-
-! $Header$
-
-SUBROUTINE clift(p, t, rr, rs, plcl, dplcldt, dplcldq)
-IMPLICIT NONE
-  ! ***************************************************************
-  ! *                                                             *
-  ! * CLIFT : COMPUTE LIFTING CONDENSATION LEVEL AND ITS          *
-  ! *         DERIVATIVES RELATIVE TO T AND R                     *
-  ! *   (WITHIN 0.2% OF FORMULA OF BOLTON, MON. WEA. REV.,1980)   *
-  ! *                                                             *
-  ! * written by   : GRANDPEIX Jean-Yves, 17/11/98, 12.39.01      *
-  ! * modified by :                                               *
-  ! ***************************************************************
-  ! *
-  ! *Arguments :
-  ! *
-  ! * Input :  P = pressure of level from wich lifting is performed
-  ! *          T = temperature of level P
-  ! *          RR = vapour mixing ratio at level P
-  ! *          RS = vapour saturation mixing ratio at level P
-  ! *
-  ! * Output : PLCL = lifting condensation level
-  ! *          DPLCLDT = derivative of PLCL relative to T
-  ! *          DPLCLDQ = derivative of PLCL relative to R
-  ! *
-  ! cccccccccccccccccccccc
-  ! constantes coherentes avec le modele du Centre Europeen
-  ! RD = 1000.0 * 1.380658E-23 * 6.0221367E+23 / 28.9644
-  ! RV = 1000.0 * 1.380658E-23 * 6.0221367E+23 / 18.0153
-  ! CPD = 3.5 * RD
-  ! CPV = 4.0 * RV
-  ! CL = 4218.0
-  ! CI=2090.0
-  ! CPVMCL=CL-CPV
-  ! CLMCI=CL-CI
-  ! EPS=RD/RV
-  ! ALV0=2.5008E+06
-  ! ALF0=3.34E+05
-
-  ! on utilise les constantes thermo du Centre Europeen: (sb)
-
-  include "YOMCST.h"
-  real :: p,t,rr,rs,plcl,dplcldt,dplcldq,cpd,cpv,cl,cpvmcl,eps,alv0,a,b
-  real :: rh,chi,alv
-
-  cpd = rcpd
-  cpv = rcpv
-  cl = rcw
-  cpvmcl = cl - cpv
-  eps = rd/rv
-  alv0 = rlvtt
-
-
-  ! Bolton formula coefficients :
-  a = 1669.0
-  b = 122.0
-
-  rh = rr/rs
-  chi = t/(a-b*rh-t)
-  plcl = p*(rh**chi)
-
-  alv = alv0 - cpvmcl*(t-273.15)
-
-  ! -- sb: correction:
-  ! DPLCLDQ = PLCL*CHI*( 1./RR - B*CHI/T/RS*ALOG(RH) )
-  dplcldq = plcl*chi*(1./rr+b*chi/t/rs*alog(rh))
-  ! sb --
-
-  dplcldt = plcl*chi*((a-b*rh*(1.+alv/rv/t))/t**2*chi*alog(rh)-alv/rv/t**2)
-
-
-  RETURN
-END SUBROUTINE clift
Index: /LMDZ6/trunk/libf/phylmd/clift.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/clift.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/clift.f90	(revision 5268)
@@ -0,0 +1,74 @@
+
+! $Header$
+
+SUBROUTINE clift(p, t, rr, rs, plcl, dplcldt, dplcldq)
+IMPLICIT NONE
+  ! ***************************************************************
+  ! *                                                             *
+  ! * CLIFT : COMPUTE LIFTING CONDENSATION LEVEL AND ITS          *
+  ! *         DERIVATIVES RELATIVE TO T AND R                     *
+  ! *   (WITHIN 0.2% OF FORMULA OF BOLTON, MON. WEA. REV.,1980)   *
+  ! *                                                             *
+  ! * written by   : GRANDPEIX Jean-Yves, 17/11/98, 12.39.01      *
+  ! * modified by :                                               *
+  ! ***************************************************************
+  ! *
+  ! *Arguments :
+  ! *
+  ! * Input :  P = pressure of level from wich lifting is performed
+  ! *          T = temperature of level P
+  ! *          RR = vapour mixing ratio at level P
+  ! *          RS = vapour saturation mixing ratio at level P
+  ! *
+  ! * Output : PLCL = lifting condensation level
+  ! *          DPLCLDT = derivative of PLCL relative to T
+  ! *          DPLCLDQ = derivative of PLCL relative to R
+  ! *
+  ! cccccccccccccccccccccc
+  ! constantes coherentes avec le modele du Centre Europeen
+  ! RD = 1000.0 * 1.380658E-23 * 6.0221367E+23 / 28.9644
+  ! RV = 1000.0 * 1.380658E-23 * 6.0221367E+23 / 18.0153
+  ! CPD = 3.5 * RD
+  ! CPV = 4.0 * RV
+  ! CL = 4218.0
+  ! CI=2090.0
+  ! CPVMCL=CL-CPV
+  ! CLMCI=CL-CI
+  ! EPS=RD/RV
+  ! ALV0=2.5008E+06
+  ! ALF0=3.34E+05
+
+  ! on utilise les constantes thermo du Centre Europeen: (sb)
+
+  include "YOMCST.h"
+  real :: p,t,rr,rs,plcl,dplcldt,dplcldq,cpd,cpv,cl,cpvmcl,eps,alv0,a,b
+  real :: rh,chi,alv
+
+  cpd = rcpd
+  cpv = rcpv
+  cl = rcw
+  cpvmcl = cl - cpv
+  eps = rd/rv
+  alv0 = rlvtt
+
+
+  ! Bolton formula coefficients :
+  a = 1669.0
+  b = 122.0
+
+  rh = rr/rs
+  chi = t/(a-b*rh-t)
+  plcl = p*(rh**chi)
+
+  alv = alv0 - cpvmcl*(t-273.15)
+
+  ! -- sb: correction:
+  ! DPLCLDQ = PLCL*CHI*( 1./RR - B*CHI/T/RS*ALOG(RH) )
+  dplcldq = plcl*chi*(1./rr+b*chi/t/rs*alog(rh))
+  ! sb --
+
+  dplcldt = plcl*chi*((a-b*rh*(1.+alv/rv/t))/t**2*chi*alog(rh)-alv/rv/t**2)
+
+
+  RETURN
+END SUBROUTINE clift
Index: DZ6/trunk/libf/phylmd/climb_hq_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/climb_hq_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,488 +1,0 @@
-MODULE climb_hq_mod
-!
-! Module to solve the verctical diffusion of "q" and "H"; 
-! specific humidity and potential energi.
-!
-  USE dimphy
-
-  IMPLICIT NONE
-  SAVE 
-  PRIVATE
-  PUBLIC :: climb_hq_down, climb_hq_up, d_h_col_vdf, f_h_bnd
-
-  REAL, DIMENSION(:,:), ALLOCATABLE :: gamaq, gamah
-  !$OMP THREADPRIVATE(gamaq,gamah)
-  REAL, DIMENSION(:,:), ALLOCATABLE :: Ccoef_Q, Dcoef_Q
-  !$OMP THREADPRIVATE(Ccoef_Q, Dcoef_Q)
-  REAL, DIMENSION(:,:), ALLOCATABLE :: Ccoef_H, Dcoef_H
-  !$OMP THREADPRIVATE(Ccoef_H, Dcoef_H)
-  REAL, DIMENSION(:), ALLOCATABLE   :: Acoef_Q, Bcoef_Q
-  !$OMP THREADPRIVATE(Acoef_Q, Bcoef_Q)
-  REAL, DIMENSION(:), ALLOCATABLE   :: Acoef_H, Bcoef_H
-  !$OMP THREADPRIVATE(Acoef_H, Bcoef_H)
-  REAL, DIMENSION(:,:), ALLOCATABLE :: Kcoefhq
-  !$OMP THREADPRIVATE(Kcoefhq)
-  REAL, SAVE, DIMENSION(:,:), ALLOCATABLE :: h_old ! for diagnostics, h before solving diffusion
-  !$OMP THREADPRIVATE(h_old)
-  REAL, SAVE, DIMENSION(:), ALLOCATABLE :: d_h_col_vdf ! for diagnostics, vertical integral of enthalpy change
-  !$OMP THREADPRIVATE(d_h_col_vdf)
-  REAL, SAVE, DIMENSION(:), ALLOCATABLE :: f_h_bnd ! for diagnostics, enthalpy flux at surface
-  !$OMP THREADPRIVATE(f_h_bnd)
-
-CONTAINS
-!
-!****************************************************************************************
-!
-  SUBROUTINE climb_hq_down(knon, coefhq, paprs, pplay, &
-       delp, temp, q, dtime, &
-!!! nrlmd le 02/05/2011
-       Ccoef_H_out, Ccoef_Q_out, Dcoef_H_out, Dcoef_Q_out, &
-       Kcoef_hq_out, gama_q_out, gama_h_out, &
-!!!
-       Acoef_H_out, Acoef_Q_out, Bcoef_H_out, Bcoef_Q_out)
-
-! This routine calculates recursivly the coefficients C and D
-! for the quantity X=[Q,H] in equation X(k) = C(k) + D(k)*X(k-1), where k is
-! the index of the vertical layer.
-!
-! Input arguments
-!****************************************************************************************
-    INTEGER, INTENT(IN)                      :: knon
-    REAL, DIMENSION(klon,klev), INTENT(IN)   :: coefhq
-    REAL, DIMENSION(klon,klev), INTENT(IN)   :: pplay 
-    REAL, DIMENSION(klon,klev+1), INTENT(IN) :: paprs 
-    REAL, DIMENSION(klon,klev), INTENT(IN)   :: temp, delp  ! temperature
-    REAL, DIMENSION(klon,klev), INTENT(IN)   :: q
-    REAL, INTENT(IN)                         :: dtime
-
-! Output arguments
-!****************************************************************************************
-    REAL, DIMENSION(klon), INTENT(OUT)       :: Acoef_H_out
-    REAL, DIMENSION(klon), INTENT(OUT)       :: Acoef_Q_out
-    REAL, DIMENSION(klon), INTENT(OUT)       :: Bcoef_H_out
-    REAL, DIMENSION(klon), INTENT(OUT)       :: Bcoef_Q_out
-
-!!! nrlmd le 02/05/2011
-    REAL, DIMENSION(klon,klev), INTENT(OUT)  :: Ccoef_H_out
-    REAL, DIMENSION(klon,klev), INTENT(OUT)  :: Ccoef_Q_out
-    REAL, DIMENSION(klon,klev), INTENT(OUT)  :: Dcoef_H_out
-    REAL, DIMENSION(klon,klev), INTENT(OUT)  :: Dcoef_Q_out
-    REAL, DIMENSION(klon,klev), INTENT(OUT)  :: Kcoef_hq_out
-    REAL, DIMENSION(klon,klev), INTENT(OUT)  :: gama_q_out
-    REAL, DIMENSION(klon,klev), INTENT(OUT)  :: gama_h_out
-!!!
-
-! Local variables
-!****************************************************************************************
-    LOGICAL, SAVE                            :: first=.TRUE.
-    !$OMP THREADPRIVATE(first)
-! JLD now renamed h_old and declared in module
-!    REAL, DIMENSION(klon,klev)               :: local_H
-    REAL, DIMENSION(klon)                    :: psref 
-    REAL                                     :: delz, pkh
-    INTEGER                                  :: k, i, ierr
-! Include
-!****************************************************************************************
-    INCLUDE "YOMCST.h"
-    INCLUDE "compbl.h"    
-
-
-!****************************************************************************************
-! 1)
-! Allocation at first time step only
-!   
-!****************************************************************************************
-
-    IF (first) THEN
-       first=.FALSE.
-       ALLOCATE(Ccoef_Q(klon,klev), STAT=ierr)
-       IF ( ierr /= 0 )  PRINT*,' pb in allloc Ccoef_Q, ierr=', ierr
-       
-       ALLOCATE(Dcoef_Q(klon,klev), STAT=ierr)
-       IF ( ierr /= 0 )  PRINT*,' pb in allloc Dcoef_Q, ierr=', ierr
-       
-       ALLOCATE(Ccoef_H(klon,klev), STAT=ierr)
-       IF ( ierr /= 0 )  PRINT*,' pb in allloc Ccoef_H, ierr=', ierr
-       
-       ALLOCATE(Dcoef_H(klon,klev), STAT=ierr)
-       IF ( ierr /= 0 )  PRINT*,' pb in allloc Dcoef_H, ierr=', ierr
-       
-       ALLOCATE(Acoef_Q(klon), Bcoef_Q(klon), Acoef_H(klon), Bcoef_H(klon), STAT=ierr)
-       IF ( ierr /= 0 )  PRINT*,' pb in allloc Acoef_X and Bcoef_X, ierr=', ierr
-       
-       ALLOCATE(Kcoefhq(klon,klev), STAT=ierr)
-       IF ( ierr /= 0 )  PRINT*,' pb in allloc Kcoefhq, ierr=', ierr
-       
-       ALLOCATE(gamaq(1:klon,2:klev), STAT=ierr)
-       IF ( ierr /= 0 ) PRINT*,' pb in allloc gamaq, ierr=', ierr
-       
-       ALLOCATE(gamah(1:klon,2:klev), STAT=ierr)
-       IF ( ierr /= 0 ) PRINT*,' pb in allloc gamah, ierr=', ierr
-       
-       ALLOCATE(h_old(klon,klev), STAT=ierr)
-       IF ( ierr /= 0 )  PRINT*,' pb in allloc h_old, ierr=', ierr
-       
-       ALLOCATE(d_h_col_vdf(klon), STAT=ierr)
-       IF ( ierr /= 0 )  PRINT*,' pb in allloc d_h_col_vdf, ierr=', ierr
-       
-       ALLOCATE(f_h_bnd(klon), STAT=ierr)
-       IF ( ierr /= 0 )  PRINT*,' pb in allloc f_h_bnd, ierr=', ierr
-    END IF
-
-!****************************************************************************************
-! 2)
-! Definition of the coeficient K 
-!
-!****************************************************************************************
-    Kcoefhq(:,:) = 0.0
-    DO k = 2, klev
-       DO i = 1, knon
-          Kcoefhq(i,k) = &
-               coefhq(i,k)*RG*RG*dtime /(pplay(i,k-1)-pplay(i,k)) &
-               *(paprs(i,k)*2/(temp(i,k)+temp(i,k-1))/RD)**2
-       ENDDO
-    ENDDO
-
-!****************************************************************************************
-! 3)
-! Calculation of gama for "Q" and "H"
-!
-!****************************************************************************************
-!   surface pressure is used as reference
-    psref(:) = paprs(:,1) 
-
-!   definition of gama
-    IF (iflag_pbl == 1) THEN
-       gamaq(:,:) = 0.0
-       gamah(:,:) = -1.0e-03
-       gamah(:,2) = -2.5e-03
- 
-! conversion de gama
-       DO k = 2, klev
-          DO i = 1, knon
-             delz = RD * (temp(i,k-1)+temp(i,k)) / & 
-                    2.0 / RG / paprs(i,k) * (pplay(i,k-1)-pplay(i,k))
-             pkh  = (psref(i)/paprs(i,k))**RKAPPA
-          
-! convertie gradient verticale d'humidite specifique en difference d'humidite specifique entre centre de couches
-             gamaq(i,k) = gamaq(i,k) * delz    
-! convertie gradient verticale de temperature en difference de temperature potentielle entre centre de couches 
-             gamah(i,k) = gamah(i,k) * delz * RCPD * pkh
-          ENDDO
-       ENDDO
-
-    ELSE
-       gamaq(:,:) = 0.0
-       gamah(:,:) = 0.0
-    ENDIF
-    
-
-!****************************************************************************************    
-! 4)
-! Calculte the coefficients C and D for specific humidity, q
-!
-!****************************************************************************************
-    
-    CALL calc_coef(knon, Kcoefhq(:,:), gamaq(:,:), delp(:,:), q(:,:), &
-         Ccoef_Q(:,:), Dcoef_Q(:,:), Acoef_Q, Bcoef_Q)
-
-!****************************************************************************************
-! 5)
-! Calculte the coefficients C and D for potentiel entalpie, H 
-!
-!****************************************************************************************
-    h_old(:,:) = 0.0
-
-    DO k=1,klev
-       DO i = 1, knon
-          ! convertie la temperature en entalpie potentielle
-          h_old(i,k) = RCPD * temp(i,k) * &
-               (psref(i)/pplay(i,k))**RKAPPA
-       ENDDO
-    ENDDO
-
-    CALL calc_coef(knon, Kcoefhq(:,:), gamah(:,:), delp(:,:), h_old(:,:), &
-         Ccoef_H(:,:), Dcoef_H(:,:), Acoef_H, Bcoef_H)
- 
-!****************************************************************************************
-! 6)
-! Return the first layer in output variables
-!
-!****************************************************************************************
-    Acoef_H_out = Acoef_H
-    Bcoef_H_out = Bcoef_H
-    Acoef_Q_out = Acoef_Q
-    Bcoef_Q_out = Bcoef_Q
-
-!****************************************************************************************
-! 7)
-! If Pbl is split, return also the other layers in output variables
-!
-!****************************************************************************************
-!!! jyg le 07/02/2012
-!!jyg       IF (mod(iflag_pbl_split,2) .eq.1) THEN
-       IF (mod(iflag_pbl_split,10) .ge.1) THEN
-!!! nrlmd le 02/05/2011
-    DO k= 1, klev
-      DO i= 1, klon
-        Ccoef_H_out(i,k) = Ccoef_H(i,k)
-        Dcoef_H_out(i,k) = Dcoef_H(i,k)
-        Ccoef_Q_out(i,k) = Ccoef_Q(i,k)
-        Dcoef_Q_out(i,k) = Dcoef_Q(i,k)
-        Kcoef_hq_out(i,k) = Kcoefhq(i,k)
-          IF (k.eq.1) THEN
-            gama_h_out(i,k)  = 0.
-            gama_q_out(i,k)  = 0.
-          ELSE
-            gama_h_out(i,k)  = gamah(i,k)
-            gama_q_out(i,k)  = gamaq(i,k)
-          ENDIF
-      ENDDO
-    ENDDO
-!!!      
-       ENDIF  ! (mod(iflag_pbl_split,2) .ge.1)
-!!!
-
-  END SUBROUTINE climb_hq_down
-!
-!****************************************************************************************
-!
-  SUBROUTINE calc_coef(knon, Kcoef, gama, delp, X, Ccoef, Dcoef, Acoef, Bcoef)
-!
-! Calculate the coefficients C and D in : X(k) = C(k) + D(k)*X(k-1)
-! where X is H or Q, and k the vertical level k=1,klev
-!
-    INCLUDE "YOMCST.h"
-! Input arguments
-!****************************************************************************************
-    INTEGER, INTENT(IN)                      :: knon
-    REAL, DIMENSION(klon,klev), INTENT(IN)   :: Kcoef, delp
-    REAL, DIMENSION(klon,klev), INTENT(IN)   :: X
-    REAL, DIMENSION(klon,2:klev), INTENT(IN) :: gama
-
-! Output arguments
-!****************************************************************************************
-    REAL, DIMENSION(klon), INTENT(OUT)       :: Acoef, Bcoef
-    REAL, DIMENSION(klon,klev), INTENT(OUT)  :: Ccoef, Dcoef
-
-! Local variables
-!****************************************************************************************
-    INTEGER                                  :: k, i
-    REAL                                     :: buf
-
-!****************************************************************************************
-! Niveau au sommet, k=klev
-!
-!****************************************************************************************
-    Ccoef(:,:) = 0.0
-    Dcoef(:,:) = 0.0
-
-    DO i = 1, knon
-       buf = delp(i,klev) + Kcoef(i,klev)
-       
-       Ccoef(i,klev) = (X(i,klev)*delp(i,klev) - Kcoef(i,klev)*gama(i,klev))/buf
-       Dcoef(i,klev) = Kcoef(i,klev)/buf
-    END DO
-
-
-!****************************************************************************************
-! Niveau  (klev-1) <= k <= 2
-!
-!****************************************************************************************
-
-    DO k=(klev-1),2,-1
-       DO i = 1, knon
-          buf = delp(i,k) + Kcoef(i,k) + Kcoef(i,k+1)*(1.-Dcoef(i,k+1))
-          Ccoef(i,k) = (X(i,k)*delp(i,k) + Kcoef(i,k+1)*Ccoef(i,k+1) + &
-               Kcoef(i,k+1)*gama(i,k+1) - Kcoef(i,k)*gama(i,k))/buf
-          Dcoef(i,k) = Kcoef(i,k)/buf
-       END DO
-    END DO
-
-!****************************************************************************************
-! Niveau k=1
-!
-!****************************************************************************************
-
-    DO i = 1, knon
-       buf = delp(i,1) + Kcoef(i,2)*(1.-Dcoef(i,2))
-       Acoef(i) = (X(i,1)*delp(i,1) + Kcoef(i,2)*(gama(i,2)+Ccoef(i,2)))/buf
-       Bcoef(i) = -1. * RG / buf
-    END DO
-
-  END SUBROUTINE calc_coef
-!
-!****************************************************************************************
-!
-  SUBROUTINE climb_hq_up(knon, dtime, t_old, q_old, &
-       flx_q1, flx_h1, paprs, pplay, &
-!!! nrlmd le 02/05/2011
-       Acoef_H_in, Acoef_Q_in, Bcoef_H_in, Bcoef_Q_in, &
-       Ccoef_H_in, Ccoef_Q_in, Dcoef_H_in, Dcoef_Q_in, &
-       Kcoef_hq_in, gama_q_in, gama_h_in, &
-!!!
-       flux_q, flux_h, d_q, d_t)
-! 
-! This routine calculates the flux and tendency of the specific humidity q and 
-! the potential engergi H. 
-! The quantities q and H are calculated according to 
-! X(k) = C(k) + D(k)*X(k-1) for X=[q,H], where the coefficients 
-! C and D are known from before and k is index of the vertical layer.
-!   
-
-! Input arguments
-!****************************************************************************************
-    INTEGER, INTENT(IN)                      :: knon
-    REAL, INTENT(IN)                         :: dtime
-    REAL, DIMENSION(klon,klev), INTENT(IN)   :: t_old, q_old
-    REAL, DIMENSION(klon), INTENT(IN)        :: flx_q1, flx_h1
-    REAL, DIMENSION(klon,klev+1), INTENT(IN) :: paprs
-    REAL, DIMENSION(klon,klev), INTENT(IN)   :: pplay
-
-!!! nrlmd le 02/05/2011
-    REAL, DIMENSION(klon), INTENT(IN)        :: Acoef_H_in,Acoef_Q_in, Bcoef_H_in, Bcoef_Q_in
-    REAL, DIMENSION(klon,klev), INTENT(IN)   :: Ccoef_H_in, Ccoef_Q_in, Dcoef_H_in, Dcoef_Q_in
-    REAL, DIMENSION(klon,klev), INTENT(IN)   :: Kcoef_hq_in, gama_q_in, gama_h_in
-!!!
-
-! Output arguments
-!****************************************************************************************
-    REAL, DIMENSION(klon,klev), INTENT(OUT)  :: flux_q, flux_h, d_q, d_t
-
-! Local variables
-!****************************************************************************************
-    LOGICAL, SAVE                            :: last=.FALSE.
-    REAL, DIMENSION(klon,klev)               :: h_new, q_new
-    REAL, DIMENSION(klon)                    :: psref         
-    INTEGER                                  :: k, i, ierr
- 
-! Include
-!****************************************************************************************
-    INCLUDE "YOMCST.h"
-    INCLUDE "compbl.h"    
-
-!****************************************************************************************
-! 1) 
-! Definition of some variables
-    REAL, DIMENSION(klon,klev)               :: d_h, zairm
-!
-!****************************************************************************************
-    flux_q(:,:) = 0.0
-    flux_h(:,:) = 0.0
-    d_q(:,:)    = 0.0
-    d_t(:,:)    = 0.0
-    d_h(:,:)    = 0.0
-    f_h_bnd(:)= 0.0
-
-    psref(1:knon) = paprs(1:knon,1)  
-
-!!! jyg le 07/02/2012
-!!jyg       IF (mod(iflag_pbl_split,2) .eq.1) THEN
-       IF (mod(iflag_pbl_split,10) .ge.1) THEN
-!!! nrlmd le 02/05/2011
-    DO i = 1, knon
-      Acoef_H(i)=Acoef_H_in(i)
-      Acoef_Q(i)=Acoef_Q_in(i)
-      Bcoef_H(i)=Bcoef_H_in(i)
-      Bcoef_Q(i)=Bcoef_Q_in(i)
-    ENDDO
-    DO k = 1, klev
-      DO i = 1, knon
-        Ccoef_H(i,k)=Ccoef_H_in(i,k)
-        Ccoef_Q(i,k)=Ccoef_Q_in(i,k)
-        Dcoef_H(i,k)=Dcoef_H_in(i,k)
-        Dcoef_Q(i,k)=Dcoef_Q_in(i,k)
-        Kcoefhq(i,k)=Kcoef_hq_in(i,k)
-          IF (k.gt.1) THEN
-            gamah(i,k)=gama_h_in(i,k)
-            gamaq(i,k)=gama_q_in(i,k)
-          ENDIF
-      ENDDO
-    ENDDO
-!!!      
-       ENDIF  ! (mod(iflag_pbl_split,2) .ge.1)
-!!!
-
-!****************************************************************************************
-! 2)
-! Calculation of Q and H
-!
-!****************************************************************************************
-
-!- First layer
-    q_new(1:knon,1) = Acoef_Q(1:knon) + Bcoef_Q(1:knon)*flx_q1(1:knon)*dtime
-    h_new(1:knon,1) = Acoef_H(1:knon) + Bcoef_H(1:knon)*flx_h1(1:knon)*dtime
-    f_h_bnd(1:knon) = flx_h1(1:knon)
-!- All the other layers 
-    DO k = 2, klev
-       DO i = 1, knon
-          q_new(i,k) = Ccoef_Q(i,k) + Dcoef_Q(i,k)*q_new(i,k-1)
-          h_new(i,k) = Ccoef_H(i,k) + Dcoef_H(i,k)*h_new(i,k-1)
-       END DO
-    END DO
-!****************************************************************************************
-! 3)
-! Calculation of the flux for Q and H
-!
-!****************************************************************************************
-
-!- The flux at first layer, k=1
-    flux_q(1:knon,1)=flx_q1(1:knon)
-    flux_h(1:knon,1)=flx_h1(1:knon)
-
-!- The flux at all layers above surface
-    DO k = 2, klev
-       DO i = 1, knon
-          flux_q(i,k) = (Kcoefhq(i,k)/RG/dtime) * &
-               (q_new(i,k)-q_new(i,k-1)+gamaq(i,k))
-
-          flux_h(i,k) = (Kcoefhq(i,k)/RG/dtime) * &
-               (h_new(i,k)-h_new(i,k-1)+gamah(i,k)) 
-       END DO
-    END DO
-
-!****************************************************************************************
-! 4)
-! Calculation of tendency for Q and H
-!
-!****************************************************************************************
-    d_h_col_vdf(:) = 0.0
-    DO k = 1, klev
-       DO i = 1, knon
-          d_t(i,k) = h_new(i,k)/(psref(i)/pplay(i,k))**RKAPPA/RCPD - t_old(i,k)
-          d_q(i,k) = q_new(i,k) - q_old(i,k)
-          d_h(i,k) = h_new(i,k) - h_old(i,k)
-!JLD          d_t(i,k) = d_h(i,k)/(psref(i)/pplay(i,k))**RKAPPA/RCPD    !correction a venir
-    ! layer air mass
-          zairm(i, k) = (paprs(i,k)-paprs(i,k+1))/rg
-          d_h_col_vdf(i) = d_h_col_vdf(i) + d_h(i,k)*zairm(i,k)
-        END DO
-    END DO
-
-!****************************************************************************************
-! Some deallocations
-!
-!****************************************************************************************
-    IF (last) THEN
-       DEALLOCATE(Ccoef_Q, Dcoef_Q, Ccoef_H, Dcoef_H,stat=ierr)    
-       IF ( ierr /= 0 )  PRINT*,' pb in dealllocate Ccoef_Q, Dcoef_Q, Ccoef_H, Dcoef_H, ierr=', ierr
-       DEALLOCATE(Acoef_Q, Bcoef_Q, Acoef_H, Bcoef_H,stat=ierr)    
-       IF ( ierr /= 0 )  PRINT*,' pb in dealllocate Acoef_Q, Bcoef_Q, Acoef_H, Bcoef_H, ierr=', ierr
-       DEALLOCATE(gamaq, gamah,stat=ierr)
-       IF ( ierr /= 0 )  PRINT*,' pb in dealllocate gamaq, gamah, ierr=', ierr
-       DEALLOCATE(Kcoefhq,stat=ierr)
-       IF ( ierr /= 0 )  PRINT*,' pb in dealllocate Kcoefhq, ierr=', ierr
-       DEALLOCATE(h_old, d_h_col_vdf, f_h_bnd, stat=ierr)
-       IF ( ierr /= 0 )  PRINT*,' pb in dealllocate h_old, d_h_col_vdf, f_h_bnd, ierr=', ierr
-    END IF
-  END SUBROUTINE climb_hq_up
-!
-!****************************************************************************************
-!
-END MODULE climb_hq_mod
-
- 
-
-
-
-
Index: /LMDZ6/trunk/libf/phylmd/climb_hq_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/climb_hq_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/climb_hq_mod.f90	(revision 5268)
@@ -0,0 +1,488 @@
+MODULE climb_hq_mod
+!
+! Module to solve the verctical diffusion of "q" and "H"; 
+! specific humidity and potential energi.
+!
+  USE dimphy
+
+  IMPLICIT NONE
+  SAVE 
+  PRIVATE
+  PUBLIC :: climb_hq_down, climb_hq_up, d_h_col_vdf, f_h_bnd
+
+  REAL, DIMENSION(:,:), ALLOCATABLE :: gamaq, gamah
+  !$OMP THREADPRIVATE(gamaq,gamah)
+  REAL, DIMENSION(:,:), ALLOCATABLE :: Ccoef_Q, Dcoef_Q
+  !$OMP THREADPRIVATE(Ccoef_Q, Dcoef_Q)
+  REAL, DIMENSION(:,:), ALLOCATABLE :: Ccoef_H, Dcoef_H
+  !$OMP THREADPRIVATE(Ccoef_H, Dcoef_H)
+  REAL, DIMENSION(:), ALLOCATABLE   :: Acoef_Q, Bcoef_Q
+  !$OMP THREADPRIVATE(Acoef_Q, Bcoef_Q)
+  REAL, DIMENSION(:), ALLOCATABLE   :: Acoef_H, Bcoef_H
+  !$OMP THREADPRIVATE(Acoef_H, Bcoef_H)
+  REAL, DIMENSION(:,:), ALLOCATABLE :: Kcoefhq
+  !$OMP THREADPRIVATE(Kcoefhq)
+  REAL, SAVE, DIMENSION(:,:), ALLOCATABLE :: h_old ! for diagnostics, h before solving diffusion
+  !$OMP THREADPRIVATE(h_old)
+  REAL, SAVE, DIMENSION(:), ALLOCATABLE :: d_h_col_vdf ! for diagnostics, vertical integral of enthalpy change
+  !$OMP THREADPRIVATE(d_h_col_vdf)
+  REAL, SAVE, DIMENSION(:), ALLOCATABLE :: f_h_bnd ! for diagnostics, enthalpy flux at surface
+  !$OMP THREADPRIVATE(f_h_bnd)
+
+CONTAINS
+!
+!****************************************************************************************
+!
+  SUBROUTINE climb_hq_down(knon, coefhq, paprs, pplay, &
+       delp, temp, q, dtime, &
+!!! nrlmd le 02/05/2011
+       Ccoef_H_out, Ccoef_Q_out, Dcoef_H_out, Dcoef_Q_out, &
+       Kcoef_hq_out, gama_q_out, gama_h_out, &
+!!!
+       Acoef_H_out, Acoef_Q_out, Bcoef_H_out, Bcoef_Q_out)
+
+! This routine calculates recursivly the coefficients C and D
+! for the quantity X=[Q,H] in equation X(k) = C(k) + D(k)*X(k-1), where k is
+! the index of the vertical layer.
+!
+! Input arguments
+!****************************************************************************************
+    INTEGER, INTENT(IN)                      :: knon
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: coefhq
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: pplay 
+    REAL, DIMENSION(klon,klev+1), INTENT(IN) :: paprs 
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: temp, delp  ! temperature
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: q
+    REAL, INTENT(IN)                         :: dtime
+
+! Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(OUT)       :: Acoef_H_out
+    REAL, DIMENSION(klon), INTENT(OUT)       :: Acoef_Q_out
+    REAL, DIMENSION(klon), INTENT(OUT)       :: Bcoef_H_out
+    REAL, DIMENSION(klon), INTENT(OUT)       :: Bcoef_Q_out
+
+!!! nrlmd le 02/05/2011
+    REAL, DIMENSION(klon,klev), INTENT(OUT)  :: Ccoef_H_out
+    REAL, DIMENSION(klon,klev), INTENT(OUT)  :: Ccoef_Q_out
+    REAL, DIMENSION(klon,klev), INTENT(OUT)  :: Dcoef_H_out
+    REAL, DIMENSION(klon,klev), INTENT(OUT)  :: Dcoef_Q_out
+    REAL, DIMENSION(klon,klev), INTENT(OUT)  :: Kcoef_hq_out
+    REAL, DIMENSION(klon,klev), INTENT(OUT)  :: gama_q_out
+    REAL, DIMENSION(klon,klev), INTENT(OUT)  :: gama_h_out
+!!!
+
+! Local variables
+!****************************************************************************************
+    LOGICAL, SAVE                            :: first=.TRUE.
+    !$OMP THREADPRIVATE(first)
+! JLD now renamed h_old and declared in module
+!    REAL, DIMENSION(klon,klev)               :: local_H
+    REAL, DIMENSION(klon)                    :: psref 
+    REAL                                     :: delz, pkh
+    INTEGER                                  :: k, i, ierr
+! Include
+!****************************************************************************************
+    INCLUDE "YOMCST.h"
+    INCLUDE "compbl.h"    
+
+
+!****************************************************************************************
+! 1)
+! Allocation at first time step only
+!   
+!****************************************************************************************
+
+    IF (first) THEN
+       first=.FALSE.
+       ALLOCATE(Ccoef_Q(klon,klev), STAT=ierr)
+       IF ( ierr /= 0 )  PRINT*,' pb in allloc Ccoef_Q, ierr=', ierr
+       
+       ALLOCATE(Dcoef_Q(klon,klev), STAT=ierr)
+       IF ( ierr /= 0 )  PRINT*,' pb in allloc Dcoef_Q, ierr=', ierr
+       
+       ALLOCATE(Ccoef_H(klon,klev), STAT=ierr)
+       IF ( ierr /= 0 )  PRINT*,' pb in allloc Ccoef_H, ierr=', ierr
+       
+       ALLOCATE(Dcoef_H(klon,klev), STAT=ierr)
+       IF ( ierr /= 0 )  PRINT*,' pb in allloc Dcoef_H, ierr=', ierr
+       
+       ALLOCATE(Acoef_Q(klon), Bcoef_Q(klon), Acoef_H(klon), Bcoef_H(klon), STAT=ierr)
+       IF ( ierr /= 0 )  PRINT*,' pb in allloc Acoef_X and Bcoef_X, ierr=', ierr
+       
+       ALLOCATE(Kcoefhq(klon,klev), STAT=ierr)
+       IF ( ierr /= 0 )  PRINT*,' pb in allloc Kcoefhq, ierr=', ierr
+       
+       ALLOCATE(gamaq(1:klon,2:klev), STAT=ierr)
+       IF ( ierr /= 0 ) PRINT*,' pb in allloc gamaq, ierr=', ierr
+       
+       ALLOCATE(gamah(1:klon,2:klev), STAT=ierr)
+       IF ( ierr /= 0 ) PRINT*,' pb in allloc gamah, ierr=', ierr
+       
+       ALLOCATE(h_old(klon,klev), STAT=ierr)
+       IF ( ierr /= 0 )  PRINT*,' pb in allloc h_old, ierr=', ierr
+       
+       ALLOCATE(d_h_col_vdf(klon), STAT=ierr)
+       IF ( ierr /= 0 )  PRINT*,' pb in allloc d_h_col_vdf, ierr=', ierr
+       
+       ALLOCATE(f_h_bnd(klon), STAT=ierr)
+       IF ( ierr /= 0 )  PRINT*,' pb in allloc f_h_bnd, ierr=', ierr
+    END IF
+
+!****************************************************************************************
+! 2)
+! Definition of the coeficient K 
+!
+!****************************************************************************************
+    Kcoefhq(:,:) = 0.0
+    DO k = 2, klev
+       DO i = 1, knon
+          Kcoefhq(i,k) = &
+               coefhq(i,k)*RG*RG*dtime /(pplay(i,k-1)-pplay(i,k)) &
+               *(paprs(i,k)*2/(temp(i,k)+temp(i,k-1))/RD)**2
+       ENDDO
+    ENDDO
+
+!****************************************************************************************
+! 3)
+! Calculation of gama for "Q" and "H"
+!
+!****************************************************************************************
+!   surface pressure is used as reference
+    psref(:) = paprs(:,1) 
+
+!   definition of gama
+    IF (iflag_pbl == 1) THEN
+       gamaq(:,:) = 0.0
+       gamah(:,:) = -1.0e-03
+       gamah(:,2) = -2.5e-03
+ 
+! conversion de gama
+       DO k = 2, klev
+          DO i = 1, knon
+             delz = RD * (temp(i,k-1)+temp(i,k)) / & 
+                    2.0 / RG / paprs(i,k) * (pplay(i,k-1)-pplay(i,k))
+             pkh  = (psref(i)/paprs(i,k))**RKAPPA
+          
+! convertie gradient verticale d'humidite specifique en difference d'humidite specifique entre centre de couches
+             gamaq(i,k) = gamaq(i,k) * delz    
+! convertie gradient verticale de temperature en difference de temperature potentielle entre centre de couches 
+             gamah(i,k) = gamah(i,k) * delz * RCPD * pkh
+          ENDDO
+       ENDDO
+
+    ELSE
+       gamaq(:,:) = 0.0
+       gamah(:,:) = 0.0
+    ENDIF
+    
+
+!****************************************************************************************    
+! 4)
+! Calculte the coefficients C and D for specific humidity, q
+!
+!****************************************************************************************
+    
+    CALL calc_coef(knon, Kcoefhq(:,:), gamaq(:,:), delp(:,:), q(:,:), &
+         Ccoef_Q(:,:), Dcoef_Q(:,:), Acoef_Q, Bcoef_Q)
+
+!****************************************************************************************
+! 5)
+! Calculte the coefficients C and D for potentiel entalpie, H 
+!
+!****************************************************************************************
+    h_old(:,:) = 0.0
+
+    DO k=1,klev
+       DO i = 1, knon
+          ! convertie la temperature en entalpie potentielle
+          h_old(i,k) = RCPD * temp(i,k) * &
+               (psref(i)/pplay(i,k))**RKAPPA
+       ENDDO
+    ENDDO
+
+    CALL calc_coef(knon, Kcoefhq(:,:), gamah(:,:), delp(:,:), h_old(:,:), &
+         Ccoef_H(:,:), Dcoef_H(:,:), Acoef_H, Bcoef_H)
+ 
+!****************************************************************************************
+! 6)
+! Return the first layer in output variables
+!
+!****************************************************************************************
+    Acoef_H_out = Acoef_H
+    Bcoef_H_out = Bcoef_H
+    Acoef_Q_out = Acoef_Q
+    Bcoef_Q_out = Bcoef_Q
+
+!****************************************************************************************
+! 7)
+! If Pbl is split, return also the other layers in output variables
+!
+!****************************************************************************************
+!!! jyg le 07/02/2012
+!!jyg       IF (mod(iflag_pbl_split,2) .eq.1) THEN
+       IF (mod(iflag_pbl_split,10) .ge.1) THEN
+!!! nrlmd le 02/05/2011
+    DO k= 1, klev
+      DO i= 1, klon
+        Ccoef_H_out(i,k) = Ccoef_H(i,k)
+        Dcoef_H_out(i,k) = Dcoef_H(i,k)
+        Ccoef_Q_out(i,k) = Ccoef_Q(i,k)
+        Dcoef_Q_out(i,k) = Dcoef_Q(i,k)
+        Kcoef_hq_out(i,k) = Kcoefhq(i,k)
+          IF (k.eq.1) THEN
+            gama_h_out(i,k)  = 0.
+            gama_q_out(i,k)  = 0.
+          ELSE
+            gama_h_out(i,k)  = gamah(i,k)
+            gama_q_out(i,k)  = gamaq(i,k)
+          ENDIF
+      ENDDO
+    ENDDO
+!!!      
+       ENDIF  ! (mod(iflag_pbl_split,2) .ge.1)
+!!!
+
+  END SUBROUTINE climb_hq_down
+!
+!****************************************************************************************
+!
+  SUBROUTINE calc_coef(knon, Kcoef, gama, delp, X, Ccoef, Dcoef, Acoef, Bcoef)
+!
+! Calculate the coefficients C and D in : X(k) = C(k) + D(k)*X(k-1)
+! where X is H or Q, and k the vertical level k=1,klev
+!
+    INCLUDE "YOMCST.h"
+! Input arguments
+!****************************************************************************************
+    INTEGER, INTENT(IN)                      :: knon
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: Kcoef, delp
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: X
+    REAL, DIMENSION(klon,2:klev), INTENT(IN) :: gama
+
+! Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(OUT)       :: Acoef, Bcoef
+    REAL, DIMENSION(klon,klev), INTENT(OUT)  :: Ccoef, Dcoef
+
+! Local variables
+!****************************************************************************************
+    INTEGER                                  :: k, i
+    REAL                                     :: buf
+
+!****************************************************************************************
+! Niveau au sommet, k=klev
+!
+!****************************************************************************************
+    Ccoef(:,:) = 0.0
+    Dcoef(:,:) = 0.0
+
+    DO i = 1, knon
+       buf = delp(i,klev) + Kcoef(i,klev)
+       
+       Ccoef(i,klev) = (X(i,klev)*delp(i,klev) - Kcoef(i,klev)*gama(i,klev))/buf
+       Dcoef(i,klev) = Kcoef(i,klev)/buf
+    END DO
+
+
+!****************************************************************************************
+! Niveau  (klev-1) <= k <= 2
+!
+!****************************************************************************************
+
+    DO k=(klev-1),2,-1
+       DO i = 1, knon
+          buf = delp(i,k) + Kcoef(i,k) + Kcoef(i,k+1)*(1.-Dcoef(i,k+1))
+          Ccoef(i,k) = (X(i,k)*delp(i,k) + Kcoef(i,k+1)*Ccoef(i,k+1) + &
+               Kcoef(i,k+1)*gama(i,k+1) - Kcoef(i,k)*gama(i,k))/buf
+          Dcoef(i,k) = Kcoef(i,k)/buf
+       END DO
+    END DO
+
+!****************************************************************************************
+! Niveau k=1
+!
+!****************************************************************************************
+
+    DO i = 1, knon
+       buf = delp(i,1) + Kcoef(i,2)*(1.-Dcoef(i,2))
+       Acoef(i) = (X(i,1)*delp(i,1) + Kcoef(i,2)*(gama(i,2)+Ccoef(i,2)))/buf
+       Bcoef(i) = -1. * RG / buf
+    END DO
+
+  END SUBROUTINE calc_coef
+!
+!****************************************************************************************
+!
+  SUBROUTINE climb_hq_up(knon, dtime, t_old, q_old, &
+       flx_q1, flx_h1, paprs, pplay, &
+!!! nrlmd le 02/05/2011
+       Acoef_H_in, Acoef_Q_in, Bcoef_H_in, Bcoef_Q_in, &
+       Ccoef_H_in, Ccoef_Q_in, Dcoef_H_in, Dcoef_Q_in, &
+       Kcoef_hq_in, gama_q_in, gama_h_in, &
+!!!
+       flux_q, flux_h, d_q, d_t)
+! 
+! This routine calculates the flux and tendency of the specific humidity q and 
+! the potential engergi H. 
+! The quantities q and H are calculated according to 
+! X(k) = C(k) + D(k)*X(k-1) for X=[q,H], where the coefficients 
+! C and D are known from before and k is index of the vertical layer.
+!   
+
+! Input arguments
+!****************************************************************************************
+    INTEGER, INTENT(IN)                      :: knon
+    REAL, INTENT(IN)                         :: dtime
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: t_old, q_old
+    REAL, DIMENSION(klon), INTENT(IN)        :: flx_q1, flx_h1
+    REAL, DIMENSION(klon,klev+1), INTENT(IN) :: paprs
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: pplay
+
+!!! nrlmd le 02/05/2011
+    REAL, DIMENSION(klon), INTENT(IN)        :: Acoef_H_in,Acoef_Q_in, Bcoef_H_in, Bcoef_Q_in
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: Ccoef_H_in, Ccoef_Q_in, Dcoef_H_in, Dcoef_Q_in
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: Kcoef_hq_in, gama_q_in, gama_h_in
+!!!
+
+! Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon,klev), INTENT(OUT)  :: flux_q, flux_h, d_q, d_t
+
+! Local variables
+!****************************************************************************************
+    LOGICAL, SAVE                            :: last=.FALSE.
+    REAL, DIMENSION(klon,klev)               :: h_new, q_new
+    REAL, DIMENSION(klon)                    :: psref         
+    INTEGER                                  :: k, i, ierr
+ 
+! Include
+!****************************************************************************************
+    INCLUDE "YOMCST.h"
+    INCLUDE "compbl.h"    
+
+!****************************************************************************************
+! 1) 
+! Definition of some variables
+    REAL, DIMENSION(klon,klev)               :: d_h, zairm
+!
+!****************************************************************************************
+    flux_q(:,:) = 0.0
+    flux_h(:,:) = 0.0
+    d_q(:,:)    = 0.0
+    d_t(:,:)    = 0.0
+    d_h(:,:)    = 0.0
+    f_h_bnd(:)= 0.0
+
+    psref(1:knon) = paprs(1:knon,1)  
+
+!!! jyg le 07/02/2012
+!!jyg       IF (mod(iflag_pbl_split,2) .eq.1) THEN
+       IF (mod(iflag_pbl_split,10) .ge.1) THEN
+!!! nrlmd le 02/05/2011
+    DO i = 1, knon
+      Acoef_H(i)=Acoef_H_in(i)
+      Acoef_Q(i)=Acoef_Q_in(i)
+      Bcoef_H(i)=Bcoef_H_in(i)
+      Bcoef_Q(i)=Bcoef_Q_in(i)
+    ENDDO
+    DO k = 1, klev
+      DO i = 1, knon
+        Ccoef_H(i,k)=Ccoef_H_in(i,k)
+        Ccoef_Q(i,k)=Ccoef_Q_in(i,k)
+        Dcoef_H(i,k)=Dcoef_H_in(i,k)
+        Dcoef_Q(i,k)=Dcoef_Q_in(i,k)
+        Kcoefhq(i,k)=Kcoef_hq_in(i,k)
+          IF (k.gt.1) THEN
+            gamah(i,k)=gama_h_in(i,k)
+            gamaq(i,k)=gama_q_in(i,k)
+          ENDIF
+      ENDDO
+    ENDDO
+!!!      
+       ENDIF  ! (mod(iflag_pbl_split,2) .ge.1)
+!!!
+
+!****************************************************************************************
+! 2)
+! Calculation of Q and H
+!
+!****************************************************************************************
+
+!- First layer
+    q_new(1:knon,1) = Acoef_Q(1:knon) + Bcoef_Q(1:knon)*flx_q1(1:knon)*dtime
+    h_new(1:knon,1) = Acoef_H(1:knon) + Bcoef_H(1:knon)*flx_h1(1:knon)*dtime
+    f_h_bnd(1:knon) = flx_h1(1:knon)
+!- All the other layers 
+    DO k = 2, klev
+       DO i = 1, knon
+          q_new(i,k) = Ccoef_Q(i,k) + Dcoef_Q(i,k)*q_new(i,k-1)
+          h_new(i,k) = Ccoef_H(i,k) + Dcoef_H(i,k)*h_new(i,k-1)
+       END DO
+    END DO
+!****************************************************************************************
+! 3)
+! Calculation of the flux for Q and H
+!
+!****************************************************************************************
+
+!- The flux at first layer, k=1
+    flux_q(1:knon,1)=flx_q1(1:knon)
+    flux_h(1:knon,1)=flx_h1(1:knon)
+
+!- The flux at all layers above surface
+    DO k = 2, klev
+       DO i = 1, knon
+          flux_q(i,k) = (Kcoefhq(i,k)/RG/dtime) * &
+               (q_new(i,k)-q_new(i,k-1)+gamaq(i,k))
+
+          flux_h(i,k) = (Kcoefhq(i,k)/RG/dtime) * &
+               (h_new(i,k)-h_new(i,k-1)+gamah(i,k)) 
+       END DO
+    END DO
+
+!****************************************************************************************
+! 4)
+! Calculation of tendency for Q and H
+!
+!****************************************************************************************
+    d_h_col_vdf(:) = 0.0
+    DO k = 1, klev
+       DO i = 1, knon
+          d_t(i,k) = h_new(i,k)/(psref(i)/pplay(i,k))**RKAPPA/RCPD - t_old(i,k)
+          d_q(i,k) = q_new(i,k) - q_old(i,k)
+          d_h(i,k) = h_new(i,k) - h_old(i,k)
+!JLD          d_t(i,k) = d_h(i,k)/(psref(i)/pplay(i,k))**RKAPPA/RCPD    !correction a venir
+    ! layer air mass
+          zairm(i, k) = (paprs(i,k)-paprs(i,k+1))/rg
+          d_h_col_vdf(i) = d_h_col_vdf(i) + d_h(i,k)*zairm(i,k)
+        END DO
+    END DO
+
+!****************************************************************************************
+! Some deallocations
+!
+!****************************************************************************************
+    IF (last) THEN
+       DEALLOCATE(Ccoef_Q, Dcoef_Q, Ccoef_H, Dcoef_H,stat=ierr)    
+       IF ( ierr /= 0 )  PRINT*,' pb in dealllocate Ccoef_Q, Dcoef_Q, Ccoef_H, Dcoef_H, ierr=', ierr
+       DEALLOCATE(Acoef_Q, Bcoef_Q, Acoef_H, Bcoef_H,stat=ierr)    
+       IF ( ierr /= 0 )  PRINT*,' pb in dealllocate Acoef_Q, Bcoef_Q, Acoef_H, Bcoef_H, ierr=', ierr
+       DEALLOCATE(gamaq, gamah,stat=ierr)
+       IF ( ierr /= 0 )  PRINT*,' pb in dealllocate gamaq, gamah, ierr=', ierr
+       DEALLOCATE(Kcoefhq,stat=ierr)
+       IF ( ierr /= 0 )  PRINT*,' pb in dealllocate Kcoefhq, ierr=', ierr
+       DEALLOCATE(h_old, d_h_col_vdf, f_h_bnd, stat=ierr)
+       IF ( ierr /= 0 )  PRINT*,' pb in dealllocate h_old, d_h_col_vdf, f_h_bnd, ierr=', ierr
+    END IF
+  END SUBROUTINE climb_hq_up
+!
+!****************************************************************************************
+!
+END MODULE climb_hq_mod
+
+ 
+
+
+
+
Index: DZ6/trunk/libf/phylmd/climb_qbs_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/climb_qbs_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,389 +1,0 @@
-MODULE climb_qbs_mod
-!
-! Module to solve the verctical diffusion of blowing snow; 
-!
-  USE dimphy
-
-  IMPLICIT NONE
-  SAVE 
-  PRIVATE
-  PUBLIC :: climb_qbs_down, climb_qbs_up
-
-  REAL, DIMENSION(:,:), ALLOCATABLE :: gamaqbs
-  !$OMP THREADPRIVATE(gamaqbs)
-  REAL, DIMENSION(:,:), ALLOCATABLE :: Ccoef_QBS, Dcoef_QBS
-  !$OMP THREADPRIVATE(Ccoef_QBS, Dcoef_QBS)
-  REAL, DIMENSION(:), ALLOCATABLE   :: Acoef_QBS, Bcoef_QBS
-  !$OMP THREADPRIVATE(Acoef_QBS, Bcoef_QBS)
-  REAL, DIMENSION(:,:), ALLOCATABLE :: Kcoefqbs
-  !$OMP THREADPRIVATE(Kcoefqbs)
-
-CONTAINS
-!
-!****************************************************************************************
-!
-  SUBROUTINE climb_qbs_down(knon, coefqbs, paprs, pplay, &
-       delp, temp, qbs, dtime, &
-       Ccoef_QBS_out, Dcoef_QBS_out, &
-       Kcoef_qbs_out, gama_qbs_out, &
-       Acoef_QBS_out, Bcoef_QBS_out)
-
-! This routine calculates recursivly the coefficients C and D
-! for the quantity X=[QBS] in equation X(k) = C(k) + D(k)*X(k-1), where k is
-! the index of the vertical layer.
-!
-! Input arguments
-!****************************************************************************************
-    INTEGER, INTENT(IN)                      :: knon
-    REAL, DIMENSION(klon,klev), INTENT(IN)   :: coefqbs
-    REAL, DIMENSION(klon,klev), INTENT(IN)   :: pplay 
-    REAL, DIMENSION(klon,klev+1), INTENT(IN) :: paprs 
-    REAL, DIMENSION(klon,klev), INTENT(IN)   :: delp  
-    REAL, DIMENSION(klon,klev), INTENT(IN)   :: temp
-    REAL, DIMENSION(klon,klev), INTENT(IN)   :: qbs
-    REAL, INTENT(IN)                         :: dtime
-
-! Output arguments
-!****************************************************************************************
-    REAL, DIMENSION(klon), INTENT(OUT)       :: Acoef_QBS_out
-    REAL, DIMENSION(klon), INTENT(OUT)       :: Bcoef_QBS_out
-
-    REAL, DIMENSION(klon,klev), INTENT(OUT)  :: Ccoef_QBS_out
-    REAL, DIMENSION(klon,klev), INTENT(OUT)  :: Dcoef_QBS_out
-    REAL, DIMENSION(klon,klev), INTENT(OUT)  :: Kcoef_qbs_out
-    REAL, DIMENSION(klon,klev), INTENT(OUT)  :: gama_qbs_out
-
-! Local variables
-!****************************************************************************************
-    LOGICAL, SAVE                            :: first=.TRUE.
-    !$OMP THREADPRIVATE(first)
-    REAL, DIMENSION(klon)                    :: psref 
-    REAL                                     :: delz, pkh
-    INTEGER                                  :: k, i, ierr
-! Include
-!****************************************************************************************
-    INCLUDE "YOMCST.h"
-    INCLUDE "compbl.h"    
-
-
-!****************************************************************************************
-! 1)
-! Allocation at first time step only
-!   
-!****************************************************************************************
-
-    IF (first) THEN
-       first=.FALSE.
-       ALLOCATE(Ccoef_QBS(klon,klev), STAT=ierr)
-       IF ( ierr /= 0 )  PRINT*,' pb in allloc Ccoef_QBS, ierr=', ierr
-       
-       ALLOCATE(Dcoef_QBS(klon,klev), STAT=ierr)
-       IF ( ierr /= 0 )  PRINT*,' pb in allloc Dcoef_QBS, ierr=', ierr
-       
-       ALLOCATE(Acoef_QBS(klon), Bcoef_QBS(klon), STAT=ierr)
-       IF ( ierr /= 0 )  PRINT*,' pb in allloc Acoef_BS and Bcoef_BS, ierr=', ierr
-       
-       ALLOCATE(Kcoefqbs(klon,klev), STAT=ierr)
-       IF ( ierr /= 0 )  PRINT*,' pb in allloc Kcoefqbs, ierr=', ierr
-       
-       ALLOCATE(gamaqbs(1:klon,2:klev), STAT=ierr)
-       IF ( ierr /= 0 ) PRINT*,' pb in allloc gamaqbs, ierr=', ierr
-       
-    END IF
-
-!****************************************************************************************
-! 2)
-! Definition of the coeficient K 
-!
-!****************************************************************************************
-    Kcoefqbs(:,:) = 0.0
-    DO k = 2, klev
-       DO i = 1, knon
-          Kcoefqbs(i,k) = &
-               coefqbs(i,k)*RG*RG*dtime /(pplay(i,k-1)-pplay(i,k)) &
-               *(paprs(i,k)*2/(temp(i,k)+temp(i,k-1))/RD)**2
-       ENDDO
-    ENDDO
-
-!****************************************************************************************
-! 3)
-! Calculation of gama for "Q" and "H"
-!
-!****************************************************************************************
-!   surface pressure is used as reference
-    psref(:) = paprs(:,1) 
-
-!   definition of gama
-    IF (iflag_pbl == 1) THEN
-       gamaqbs(:,:) = 0.0
- 
-! conversion de gama
-       DO k = 2, klev
-          DO i = 1, knon
-             delz = RD * (temp(i,k-1)+temp(i,k)) / & 
-                    2.0 / RG / paprs(i,k) * (pplay(i,k-1)-pplay(i,k))
-             pkh  = (psref(i)/paprs(i,k))**RKAPPA
-          
-! convertie gradient verticale de contenu en neige soufflee en difference de neige soufflee entre centre de couches
-             gamaqbs(i,k) = gamaqbs(i,k) * delz    
-          ENDDO
-       ENDDO
-
-    ELSE
-       gamaqbs(:,:) = 0.0
-    ENDIF
-    
-
-!****************************************************************************************    
-! 4)
-! Calculte the coefficients C and D for specific content of blowing snow, qbs
-!
-!****************************************************************************************
-    
-    CALL calc_coef_qbs(knon, Kcoefqbs(:,:), gamaqbs(:,:), delp(:,:), qbs(:,:), &
-         Ccoef_QBS(:,:), Dcoef_QBS(:,:), Acoef_QBS, Bcoef_QBS)
-
- 
-!****************************************************************************************
-! 5)
-! Return the first layer in output variables
-!
-!****************************************************************************************
-    Acoef_QBS_out = Acoef_QBS
-    Bcoef_QBS_out = Bcoef_QBS
-
-!****************************************************************************************
-! 6)
-! If Pbl is split, return also the other layers in output variables
-!
-!****************************************************************************************
-    IF (mod(iflag_pbl_split,10) .ge.1) THEN
-    DO k= 1, klev
-      DO i= 1, klon
-        Ccoef_QBS_out(i,k) = Ccoef_QBS(i,k)
-        Dcoef_QBS_out(i,k) = Dcoef_QBS(i,k)
-        Kcoef_qbs_out(i,k) = Kcoefqbs(i,k)
-          IF (k.eq.1) THEN
-            gama_qbs_out(i,k)  = 0.
-          ELSE
-            gama_qbs_out(i,k)  = gamaqbs(i,k)
-          ENDIF
-      ENDDO
-    ENDDO
-!!!      
-       ENDIF  ! (mod(iflag_pbl_split,2) .ge.1)
-!!!
-
-  END SUBROUTINE climb_qbs_down
-!
-!****************************************************************************************
-!
-  SUBROUTINE calc_coef_qbs(knon, Kcoef, gama, delp, X, Ccoef, Dcoef, Acoef, Bcoef)
-!
-! Calculate the coefficients C and D in : X(k) = C(k) + D(k)*X(k-1)
-! where X is QQBS, and k the vertical level k=1,klev
-!
-    INCLUDE "YOMCST.h"
-! Input arguments
-!****************************************************************************************
-    INTEGER, INTENT(IN)                      :: knon
-    REAL, DIMENSION(klon,klev), INTENT(IN)   :: Kcoef, delp
-    REAL, DIMENSION(klon,klev), INTENT(IN)   :: X
-    REAL, DIMENSION(klon,2:klev), INTENT(IN) :: gama
-
-! Output arguments
-!****************************************************************************************
-    REAL, DIMENSION(klon), INTENT(OUT)       :: Acoef, Bcoef
-    REAL, DIMENSION(klon,klev), INTENT(OUT)  :: Ccoef, Dcoef
-
-! Local variables
-!****************************************************************************************
-    INTEGER                                  :: k, i
-    REAL                                     :: buf
-
-!****************************************************************************************
-! Niveau au sommet, k=klev
-!
-!****************************************************************************************
-    Ccoef(:,:) = 0.0
-    Dcoef(:,:) = 0.0
-
-    DO i = 1, knon
-       buf = delp(i,klev) + Kcoef(i,klev)
-       
-       Ccoef(i,klev) = (X(i,klev)*delp(i,klev) - Kcoef(i,klev)*gama(i,klev))/buf
-       Dcoef(i,klev) = Kcoef(i,klev)/buf
-    END DO
-
-
-!****************************************************************************************
-! Niveau  (klev-1) <= k <= 2
-!
-!****************************************************************************************
-
-    DO k=(klev-1),2,-1
-       DO i = 1, knon
-          buf = delp(i,k) + Kcoef(i,k) + Kcoef(i,k+1)*(1.-Dcoef(i,k+1))
-          Ccoef(i,k) = (X(i,k)*delp(i,k) + Kcoef(i,k+1)*Ccoef(i,k+1) + &
-               Kcoef(i,k+1)*gama(i,k+1) - Kcoef(i,k)*gama(i,k))/buf
-          Dcoef(i,k) = Kcoef(i,k)/buf
-       END DO
-    END DO
-
-!****************************************************************************************
-! Niveau k=1
-!
-!****************************************************************************************
-
-    DO i = 1, knon
-       buf = delp(i,1) + Kcoef(i,2)*(1.-Dcoef(i,2))
-       Acoef(i) = (X(i,1)*delp(i,1) + Kcoef(i,2)*(gama(i,2)+Ccoef(i,2)))/buf
-       Bcoef(i) = -1. * RG / buf
-    END DO
-
-  END SUBROUTINE calc_coef_qbs
-!
-!****************************************************************************************
-!
-  SUBROUTINE climb_qbs_up(knon, dtime, qbs_old, &
-       flx_qbs1, paprs, pplay, &
-       Acoef_QBS_in, Bcoef_QBS_in, &
-       Ccoef_QBS_in, Dcoef_QBS_in, &
-       Kcoef_qbs_in, gama_qbs_in, &
-       flux_qbs, d_qbs)
-! 
-! This routine calculates the flux and tendency of the specific content of blowing snow qbs 
-! The quantity qbs is calculated according to 
-! X(k) = C(k) + D(k)*X(k-1) for X=[qbs], where the coefficients 
-! C and D are known from before and k is index of the vertical layer.
-!   
-
-! Input arguments
-!****************************************************************************************
-    INTEGER, INTENT(IN)                      :: knon
-    REAL, INTENT(IN)                         :: dtime
-    REAL, DIMENSION(klon,klev), INTENT(IN)   :: qbs_old
-    REAL, DIMENSION(klon), INTENT(IN)        :: flx_qbs1
-    REAL, DIMENSION(klon,klev+1), INTENT(IN) :: paprs
-    REAL, DIMENSION(klon,klev), INTENT(IN)   :: pplay
-
-!!! nrlmd le 02/05/2011
-    REAL, DIMENSION(klon), INTENT(IN)        :: Acoef_QBS_in, Bcoef_QBS_in
-    REAL, DIMENSION(klon,klev), INTENT(IN)   :: Ccoef_QBS_in, Dcoef_QBS_in
-    REAL, DIMENSION(klon,klev), INTENT(IN)   :: Kcoef_qbs_in, gama_qbs_in
-!!!
-
-! Output arguments
-!****************************************************************************************
-    REAL, DIMENSION(klon,klev), INTENT(OUT)  :: flux_qbs, d_qbs
-
-! Local variables
-!****************************************************************************************
-    LOGICAL, SAVE                            :: last=.FALSE.
-    REAL, DIMENSION(klon,klev)               :: qbs_new
-    REAL, DIMENSION(klon)                    :: psref         
-    INTEGER                                  :: k, i, ierr
- 
-! Include
-!****************************************************************************************
-    INCLUDE "YOMCST.h"
-    INCLUDE "compbl.h"    
-
-!****************************************************************************************
-! 1) 
-! Definition of some variables
-    REAL, DIMENSION(klon,klev)               :: zairm
-!
-!****************************************************************************************
-    flux_qbs(:,:) = 0.0
-    d_qbs(:,:)    = 0.0
-
-    psref(1:knon) = paprs(1:knon,1)  
-
-       IF (mod(iflag_pbl_split,10) .ge.1) THEN
-    DO i = 1, knon
-      Acoef_QBS(i)=Acoef_QBS_in(i)
-      Bcoef_QBS(i)=Bcoef_QBS_in(i)
-    ENDDO
-    DO k = 1, klev
-      DO i = 1, knon
-        Ccoef_QBS(i,k)=Ccoef_QBS_in(i,k)
-        Dcoef_QBS(i,k)=Dcoef_QBS_in(i,k)
-        Kcoefqbs(i,k)=Kcoef_qbs_in(i,k)
-          IF (k.gt.1) THEN
-            gamaqbs(i,k)=gama_qbs_in(i,k)
-          ENDIF
-      ENDDO
-    ENDDO
-!!!      
-       ENDIF  ! (mod(iflag_pbl_split,2) .ge.1)
-!!!
-
-!****************************************************************************************
-! 2)
-! Calculation of QBS
-!
-!****************************************************************************************
-
-!- First layer
-    qbs_new(1:knon,1) = Acoef_QBS(1:knon) + Bcoef_QBS(1:knon)*flx_qbs1(1:knon)*dtime
-!- All the other layers 
-    DO k = 2, klev
-       DO i = 1, knon
-          qbs_new(i,k) = Ccoef_QBS(i,k) + Dcoef_QBS(i,k)*qbs_new(i,k-1)
-       END DO
-    END DO
-!****************************************************************************************
-! 3)
-! Calculation of the flux for QBS
-!
-!****************************************************************************************
-
-!- The flux at first layer, k=1
-    flux_qbs(1:knon,1)=flx_qbs1(1:knon)
-
-!- The flux at all layers above surface
-    DO k = 2, klev
-       DO i = 1, knon
-          flux_qbs(i,k) = (Kcoefqbs(i,k)/RG/dtime) * &
-               (qbs_new(i,k)-qbs_new(i,k-1)+gamaqbs(i,k))
-       END DO
-    END DO
-
-!****************************************************************************************
-! 4)
-! Calculation of tendency for QBS
-!
-!****************************************************************************************
-    DO k = 1, klev
-       DO i = 1, knon
-          d_qbs(i,k) = qbs_new(i,k) - qbs_old(i,k)
-          zairm(i, k) = (paprs(i,k)-paprs(i,k+1))/rg
-        END DO
-    END DO
-
-!****************************************************************************************
-! Some deallocations
-!
-!****************************************************************************************
-    IF (last) THEN
-       DEALLOCATE(Ccoef_QBS, Dcoef_QBS,stat=ierr)    
-       IF ( ierr /= 0 )  PRINT*,' pb in dealllocate Ccoef_QBS, Dcoef_QBS, ierr=', ierr
-       DEALLOCATE(Acoef_QBS, Bcoef_QBS,stat=ierr)    
-       IF ( ierr /= 0 )  PRINT*,' pb in dealllocate Acoef_QBS, Bcoef_QBS, ierr=', ierr
-       DEALLOCATE(gamaqbs,stat=ierr)
-       IF ( ierr /= 0 )  PRINT*,' pb in dealllocate gamaqbs, ierr=', ierr
-       DEALLOCATE(Kcoefqbs,stat=ierr)
-       IF ( ierr /= 0 )  PRINT*,' pb in dealllocate Kcoefqbs, ierr=', ierr
-    END IF
-  END SUBROUTINE climb_qbs_up
-!
-!****************************************************************************************
-!
-END MODULE climb_qbs_mod
-
- 
-
-
-
-
Index: /LMDZ6/trunk/libf/phylmd/climb_qbs_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/climb_qbs_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/climb_qbs_mod.f90	(revision 5268)
@@ -0,0 +1,389 @@
+MODULE climb_qbs_mod
+!
+! Module to solve the verctical diffusion of blowing snow; 
+!
+  USE dimphy
+
+  IMPLICIT NONE
+  SAVE 
+  PRIVATE
+  PUBLIC :: climb_qbs_down, climb_qbs_up
+
+  REAL, DIMENSION(:,:), ALLOCATABLE :: gamaqbs
+  !$OMP THREADPRIVATE(gamaqbs)
+  REAL, DIMENSION(:,:), ALLOCATABLE :: Ccoef_QBS, Dcoef_QBS
+  !$OMP THREADPRIVATE(Ccoef_QBS, Dcoef_QBS)
+  REAL, DIMENSION(:), ALLOCATABLE   :: Acoef_QBS, Bcoef_QBS
+  !$OMP THREADPRIVATE(Acoef_QBS, Bcoef_QBS)
+  REAL, DIMENSION(:,:), ALLOCATABLE :: Kcoefqbs
+  !$OMP THREADPRIVATE(Kcoefqbs)
+
+CONTAINS
+!
+!****************************************************************************************
+!
+  SUBROUTINE climb_qbs_down(knon, coefqbs, paprs, pplay, &
+       delp, temp, qbs, dtime, &
+       Ccoef_QBS_out, Dcoef_QBS_out, &
+       Kcoef_qbs_out, gama_qbs_out, &
+       Acoef_QBS_out, Bcoef_QBS_out)
+
+! This routine calculates recursivly the coefficients C and D
+! for the quantity X=[QBS] in equation X(k) = C(k) + D(k)*X(k-1), where k is
+! the index of the vertical layer.
+!
+! Input arguments
+!****************************************************************************************
+    INTEGER, INTENT(IN)                      :: knon
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: coefqbs
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: pplay 
+    REAL, DIMENSION(klon,klev+1), INTENT(IN) :: paprs 
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: delp  
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: temp
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: qbs
+    REAL, INTENT(IN)                         :: dtime
+
+! Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(OUT)       :: Acoef_QBS_out
+    REAL, DIMENSION(klon), INTENT(OUT)       :: Bcoef_QBS_out
+
+    REAL, DIMENSION(klon,klev), INTENT(OUT)  :: Ccoef_QBS_out
+    REAL, DIMENSION(klon,klev), INTENT(OUT)  :: Dcoef_QBS_out
+    REAL, DIMENSION(klon,klev), INTENT(OUT)  :: Kcoef_qbs_out
+    REAL, DIMENSION(klon,klev), INTENT(OUT)  :: gama_qbs_out
+
+! Local variables
+!****************************************************************************************
+    LOGICAL, SAVE                            :: first=.TRUE.
+    !$OMP THREADPRIVATE(first)
+    REAL, DIMENSION(klon)                    :: psref 
+    REAL                                     :: delz, pkh
+    INTEGER                                  :: k, i, ierr
+! Include
+!****************************************************************************************
+    INCLUDE "YOMCST.h"
+    INCLUDE "compbl.h"    
+
+
+!****************************************************************************************
+! 1)
+! Allocation at first time step only
+!   
+!****************************************************************************************
+
+    IF (first) THEN
+       first=.FALSE.
+       ALLOCATE(Ccoef_QBS(klon,klev), STAT=ierr)
+       IF ( ierr /= 0 )  PRINT*,' pb in allloc Ccoef_QBS, ierr=', ierr
+       
+       ALLOCATE(Dcoef_QBS(klon,klev), STAT=ierr)
+       IF ( ierr /= 0 )  PRINT*,' pb in allloc Dcoef_QBS, ierr=', ierr
+       
+       ALLOCATE(Acoef_QBS(klon), Bcoef_QBS(klon), STAT=ierr)
+       IF ( ierr /= 0 )  PRINT*,' pb in allloc Acoef_BS and Bcoef_BS, ierr=', ierr
+       
+       ALLOCATE(Kcoefqbs(klon,klev), STAT=ierr)
+       IF ( ierr /= 0 )  PRINT*,' pb in allloc Kcoefqbs, ierr=', ierr
+       
+       ALLOCATE(gamaqbs(1:klon,2:klev), STAT=ierr)
+       IF ( ierr /= 0 ) PRINT*,' pb in allloc gamaqbs, ierr=', ierr
+       
+    END IF
+
+!****************************************************************************************
+! 2)
+! Definition of the coeficient K 
+!
+!****************************************************************************************
+    Kcoefqbs(:,:) = 0.0
+    DO k = 2, klev
+       DO i = 1, knon
+          Kcoefqbs(i,k) = &
+               coefqbs(i,k)*RG*RG*dtime /(pplay(i,k-1)-pplay(i,k)) &
+               *(paprs(i,k)*2/(temp(i,k)+temp(i,k-1))/RD)**2
+       ENDDO
+    ENDDO
+
+!****************************************************************************************
+! 3)
+! Calculation of gama for "Q" and "H"
+!
+!****************************************************************************************
+!   surface pressure is used as reference
+    psref(:) = paprs(:,1) 
+
+!   definition of gama
+    IF (iflag_pbl == 1) THEN
+       gamaqbs(:,:) = 0.0
+ 
+! conversion de gama
+       DO k = 2, klev
+          DO i = 1, knon
+             delz = RD * (temp(i,k-1)+temp(i,k)) / & 
+                    2.0 / RG / paprs(i,k) * (pplay(i,k-1)-pplay(i,k))
+             pkh  = (psref(i)/paprs(i,k))**RKAPPA
+          
+! convertie gradient verticale de contenu en neige soufflee en difference de neige soufflee entre centre de couches
+             gamaqbs(i,k) = gamaqbs(i,k) * delz    
+          ENDDO
+       ENDDO
+
+    ELSE
+       gamaqbs(:,:) = 0.0
+    ENDIF
+    
+
+!****************************************************************************************    
+! 4)
+! Calculte the coefficients C and D for specific content of blowing snow, qbs
+!
+!****************************************************************************************
+    
+    CALL calc_coef_qbs(knon, Kcoefqbs(:,:), gamaqbs(:,:), delp(:,:), qbs(:,:), &
+         Ccoef_QBS(:,:), Dcoef_QBS(:,:), Acoef_QBS, Bcoef_QBS)
+
+ 
+!****************************************************************************************
+! 5)
+! Return the first layer in output variables
+!
+!****************************************************************************************
+    Acoef_QBS_out = Acoef_QBS
+    Bcoef_QBS_out = Bcoef_QBS
+
+!****************************************************************************************
+! 6)
+! If Pbl is split, return also the other layers in output variables
+!
+!****************************************************************************************
+    IF (mod(iflag_pbl_split,10) .ge.1) THEN
+    DO k= 1, klev
+      DO i= 1, klon
+        Ccoef_QBS_out(i,k) = Ccoef_QBS(i,k)
+        Dcoef_QBS_out(i,k) = Dcoef_QBS(i,k)
+        Kcoef_qbs_out(i,k) = Kcoefqbs(i,k)
+          IF (k.eq.1) THEN
+            gama_qbs_out(i,k)  = 0.
+          ELSE
+            gama_qbs_out(i,k)  = gamaqbs(i,k)
+          ENDIF
+      ENDDO
+    ENDDO
+!!!      
+       ENDIF  ! (mod(iflag_pbl_split,2) .ge.1)
+!!!
+
+  END SUBROUTINE climb_qbs_down
+!
+!****************************************************************************************
+!
+  SUBROUTINE calc_coef_qbs(knon, Kcoef, gama, delp, X, Ccoef, Dcoef, Acoef, Bcoef)
+!
+! Calculate the coefficients C and D in : X(k) = C(k) + D(k)*X(k-1)
+! where X is QQBS, and k the vertical level k=1,klev
+!
+    INCLUDE "YOMCST.h"
+! Input arguments
+!****************************************************************************************
+    INTEGER, INTENT(IN)                      :: knon
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: Kcoef, delp
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: X
+    REAL, DIMENSION(klon,2:klev), INTENT(IN) :: gama
+
+! Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(OUT)       :: Acoef, Bcoef
+    REAL, DIMENSION(klon,klev), INTENT(OUT)  :: Ccoef, Dcoef
+
+! Local variables
+!****************************************************************************************
+    INTEGER                                  :: k, i
+    REAL                                     :: buf
+
+!****************************************************************************************
+! Niveau au sommet, k=klev
+!
+!****************************************************************************************
+    Ccoef(:,:) = 0.0
+    Dcoef(:,:) = 0.0
+
+    DO i = 1, knon
+       buf = delp(i,klev) + Kcoef(i,klev)
+       
+       Ccoef(i,klev) = (X(i,klev)*delp(i,klev) - Kcoef(i,klev)*gama(i,klev))/buf
+       Dcoef(i,klev) = Kcoef(i,klev)/buf
+    END DO
+
+
+!****************************************************************************************
+! Niveau  (klev-1) <= k <= 2
+!
+!****************************************************************************************
+
+    DO k=(klev-1),2,-1
+       DO i = 1, knon
+          buf = delp(i,k) + Kcoef(i,k) + Kcoef(i,k+1)*(1.-Dcoef(i,k+1))
+          Ccoef(i,k) = (X(i,k)*delp(i,k) + Kcoef(i,k+1)*Ccoef(i,k+1) + &
+               Kcoef(i,k+1)*gama(i,k+1) - Kcoef(i,k)*gama(i,k))/buf
+          Dcoef(i,k) = Kcoef(i,k)/buf
+       END DO
+    END DO
+
+!****************************************************************************************
+! Niveau k=1
+!
+!****************************************************************************************
+
+    DO i = 1, knon
+       buf = delp(i,1) + Kcoef(i,2)*(1.-Dcoef(i,2))
+       Acoef(i) = (X(i,1)*delp(i,1) + Kcoef(i,2)*(gama(i,2)+Ccoef(i,2)))/buf
+       Bcoef(i) = -1. * RG / buf
+    END DO
+
+  END SUBROUTINE calc_coef_qbs
+!
+!****************************************************************************************
+!
+  SUBROUTINE climb_qbs_up(knon, dtime, qbs_old, &
+       flx_qbs1, paprs, pplay, &
+       Acoef_QBS_in, Bcoef_QBS_in, &
+       Ccoef_QBS_in, Dcoef_QBS_in, &
+       Kcoef_qbs_in, gama_qbs_in, &
+       flux_qbs, d_qbs)
+! 
+! This routine calculates the flux and tendency of the specific content of blowing snow qbs 
+! The quantity qbs is calculated according to 
+! X(k) = C(k) + D(k)*X(k-1) for X=[qbs], where the coefficients 
+! C and D are known from before and k is index of the vertical layer.
+!   
+
+! Input arguments
+!****************************************************************************************
+    INTEGER, INTENT(IN)                      :: knon
+    REAL, INTENT(IN)                         :: dtime
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: qbs_old
+    REAL, DIMENSION(klon), INTENT(IN)        :: flx_qbs1
+    REAL, DIMENSION(klon,klev+1), INTENT(IN) :: paprs
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: pplay
+
+!!! nrlmd le 02/05/2011
+    REAL, DIMENSION(klon), INTENT(IN)        :: Acoef_QBS_in, Bcoef_QBS_in
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: Ccoef_QBS_in, Dcoef_QBS_in
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: Kcoef_qbs_in, gama_qbs_in
+!!!
+
+! Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon,klev), INTENT(OUT)  :: flux_qbs, d_qbs
+
+! Local variables
+!****************************************************************************************
+    LOGICAL, SAVE                            :: last=.FALSE.
+    REAL, DIMENSION(klon,klev)               :: qbs_new
+    REAL, DIMENSION(klon)                    :: psref         
+    INTEGER                                  :: k, i, ierr
+ 
+! Include
+!****************************************************************************************
+    INCLUDE "YOMCST.h"
+    INCLUDE "compbl.h"    
+
+!****************************************************************************************
+! 1) 
+! Definition of some variables
+    REAL, DIMENSION(klon,klev)               :: zairm
+!
+!****************************************************************************************
+    flux_qbs(:,:) = 0.0
+    d_qbs(:,:)    = 0.0
+
+    psref(1:knon) = paprs(1:knon,1)  
+
+       IF (mod(iflag_pbl_split,10) .ge.1) THEN
+    DO i = 1, knon
+      Acoef_QBS(i)=Acoef_QBS_in(i)
+      Bcoef_QBS(i)=Bcoef_QBS_in(i)
+    ENDDO
+    DO k = 1, klev
+      DO i = 1, knon
+        Ccoef_QBS(i,k)=Ccoef_QBS_in(i,k)
+        Dcoef_QBS(i,k)=Dcoef_QBS_in(i,k)
+        Kcoefqbs(i,k)=Kcoef_qbs_in(i,k)
+          IF (k.gt.1) THEN
+            gamaqbs(i,k)=gama_qbs_in(i,k)
+          ENDIF
+      ENDDO
+    ENDDO
+!!!      
+       ENDIF  ! (mod(iflag_pbl_split,2) .ge.1)
+!!!
+
+!****************************************************************************************
+! 2)
+! Calculation of QBS
+!
+!****************************************************************************************
+
+!- First layer
+    qbs_new(1:knon,1) = Acoef_QBS(1:knon) + Bcoef_QBS(1:knon)*flx_qbs1(1:knon)*dtime
+!- All the other layers 
+    DO k = 2, klev
+       DO i = 1, knon
+          qbs_new(i,k) = Ccoef_QBS(i,k) + Dcoef_QBS(i,k)*qbs_new(i,k-1)
+       END DO
+    END DO
+!****************************************************************************************
+! 3)
+! Calculation of the flux for QBS
+!
+!****************************************************************************************
+
+!- The flux at first layer, k=1
+    flux_qbs(1:knon,1)=flx_qbs1(1:knon)
+
+!- The flux at all layers above surface
+    DO k = 2, klev
+       DO i = 1, knon
+          flux_qbs(i,k) = (Kcoefqbs(i,k)/RG/dtime) * &
+               (qbs_new(i,k)-qbs_new(i,k-1)+gamaqbs(i,k))
+       END DO
+    END DO
+
+!****************************************************************************************
+! 4)
+! Calculation of tendency for QBS
+!
+!****************************************************************************************
+    DO k = 1, klev
+       DO i = 1, knon
+          d_qbs(i,k) = qbs_new(i,k) - qbs_old(i,k)
+          zairm(i, k) = (paprs(i,k)-paprs(i,k+1))/rg
+        END DO
+    END DO
+
+!****************************************************************************************
+! Some deallocations
+!
+!****************************************************************************************
+    IF (last) THEN
+       DEALLOCATE(Ccoef_QBS, Dcoef_QBS,stat=ierr)    
+       IF ( ierr /= 0 )  PRINT*,' pb in dealllocate Ccoef_QBS, Dcoef_QBS, ierr=', ierr
+       DEALLOCATE(Acoef_QBS, Bcoef_QBS,stat=ierr)    
+       IF ( ierr /= 0 )  PRINT*,' pb in dealllocate Acoef_QBS, Bcoef_QBS, ierr=', ierr
+       DEALLOCATE(gamaqbs,stat=ierr)
+       IF ( ierr /= 0 )  PRINT*,' pb in dealllocate gamaqbs, ierr=', ierr
+       DEALLOCATE(Kcoefqbs,stat=ierr)
+       IF ( ierr /= 0 )  PRINT*,' pb in dealllocate Kcoefqbs, ierr=', ierr
+    END IF
+  END SUBROUTINE climb_qbs_up
+!
+!****************************************************************************************
+!
+END MODULE climb_qbs_mod
+
+ 
+
+
+
+
Index: DZ6/trunk/libf/phylmd/climb_wind_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/climb_wind_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,389 +1,0 @@
-!
-MODULE climb_wind_mod
-!
-! Module to solve the verctical diffusion of the wind components "u" and "v".
-!
-  USE dimphy
-
-  IMPLICIT NONE
-
-  SAVE
-  PRIVATE
-  
-  REAL, DIMENSION(:),   ALLOCATABLE  :: alf1, alf2
-  !$OMP THREADPRIVATE(alf1,alf2)
-  REAL, DIMENSION(:,:), ALLOCATABLE  :: Kcoefm
-  !$OMP THREADPRIVATE(Kcoefm)
-  REAL, DIMENSION(:,:), ALLOCATABLE  :: Ccoef_U, Dcoef_U
-  !$OMP THREADPRIVATE(Ccoef_U, Dcoef_U)
-  REAL, DIMENSION(:,:), ALLOCATABLE  :: Ccoef_V, Dcoef_V
-  !$OMP THREADPRIVATE(Ccoef_V, Dcoef_V)
-  REAL, DIMENSION(:), ALLOCATABLE   :: Acoef_U, Bcoef_U
-  !$OMP THREADPRIVATE(Acoef_U, Bcoef_U)
-  REAL, DIMENSION(:), ALLOCATABLE   :: Acoef_V, Bcoef_V
-  !$OMP THREADPRIVATE(Acoef_V, Bcoef_V)
-  LOGICAL                            :: firstcall=.TRUE.
-  !$OMP THREADPRIVATE(firstcall)
-
-  
-  PUBLIC :: climb_wind_down, climb_wind_up
-
-CONTAINS
-!
-!****************************************************************************************
-!
-  SUBROUTINE climb_wind_init
-
-    INTEGER             :: ierr
-    CHARACTER(len = 20) :: modname = 'climb_wind_init'    
-
-!****************************************************************************************
-! Allocation of global module variables
-!
-!****************************************************************************************
-
-    ALLOCATE(alf1(klon), stat=ierr)
-    IF (ierr /= 0) CALL abort_physic(modname,'Pb in allocate alf1',1)
-
-    ALLOCATE(alf2(klon), stat=ierr)
-    IF (ierr /= 0) CALL abort_physic(modname,'Pb in allocate alf2',1)
-
-    ALLOCATE(Kcoefm(klon,klev), stat=ierr)
-    IF (ierr /= 0) CALL abort_physic(modname,'Pb in allocate Kcoefm',1)
-
-    ALLOCATE(Ccoef_U(klon,klev), stat=ierr)
-    IF (ierr /= 0) CALL abort_physic(modname,'Pb in allocate Ccoef_U',1)
-
-    ALLOCATE(Dcoef_U(klon,klev), stat=ierr)
-    IF (ierr /= 0) CALL abort_physic(modname,'Pb in allocation Dcoef_U',1)
-
-    ALLOCATE(Ccoef_V(klon,klev), stat=ierr)
-    IF (ierr /= 0) CALL abort_physic(modname,'Pb in allocation Ccoef_V',1)
-
-    ALLOCATE(Dcoef_V(klon,klev), stat=ierr)
-    IF (ierr /= 0) CALL abort_physic(modname,'Pb in allocation Dcoef_V',1)
-
-    ALLOCATE(Acoef_U(klon), Bcoef_U(klon), Acoef_V(klon), Bcoef_V(klon), STAT=ierr)
-    IF ( ierr /= 0 )  PRINT*,' pb in allloc Acoef_U and Bcoef_U, ierr=', ierr
-
-    firstcall=.FALSE.
-
-  END SUBROUTINE climb_wind_init
-!
-!****************************************************************************************
-!
-  SUBROUTINE climb_wind_down(knon, dtime, coef_in, pplay, paprs, temp, delp, u_old, v_old, &
-!!! nrlmd le 02/05/2011
-       Ccoef_U_out, Ccoef_V_out, Dcoef_U_out, Dcoef_V_out, &
-       Kcoef_m_out, alf_1_out, alf_2_out, &
-!!!
-       Acoef_U_out, Acoef_V_out, Bcoef_U_out, Bcoef_V_out)
-!
-! This routine calculates for the wind components u and v,
-! recursivly the coefficients C and D in equation 
-! X(k) = C(k) + D(k)*X(k-1), X=[u,v], k=[1,klev] is the vertical layer.
-!
-!
-
-! Input arguments
-!****************************************************************************************
-    INTEGER, INTENT(IN)                      :: knon
-    REAL, INTENT(IN)                         :: dtime
-    REAL, DIMENSION(klon,klev), INTENT(IN)   :: coef_in
-    REAL, DIMENSION(klon,klev), INTENT(IN)   :: pplay ! pres au milieu de couche (Pa)
-    REAL, DIMENSION(klon,klev+1), INTENT(IN) :: paprs ! pression a inter-couche (Pa)
-    REAL, DIMENSION(klon,klev), INTENT(IN)   :: temp  ! temperature
-    REAL, DIMENSION(klon,klev), INTENT(IN)   :: delp
-    REAL, DIMENSION(klon,klev), INTENT(IN)   :: u_old
-    REAL, DIMENSION(klon,klev), INTENT(IN)   :: v_old
-
-! Output arguments
-!****************************************************************************************
-    REAL, DIMENSION(klon), INTENT(OUT)       :: Acoef_U_out
-    REAL, DIMENSION(klon), INTENT(OUT)       :: Acoef_V_out
-    REAL, DIMENSION(klon), INTENT(OUT)       :: Bcoef_U_out
-    REAL, DIMENSION(klon), INTENT(OUT)       :: Bcoef_V_out
-
-!!! nrlmd le 02/05/2011
-    REAL, DIMENSION(klon,klev), INTENT(OUT)  :: Ccoef_U_out
-    REAL, DIMENSION(klon,klev), INTENT(OUT)  :: Ccoef_V_out
-    REAL, DIMENSION(klon,klev), INTENT(OUT)  :: Dcoef_U_out
-    REAL, DIMENSION(klon,klev), INTENT(OUT)  :: Dcoef_V_out
-    REAL, DIMENSION(klon,klev), INTENT(OUT)  :: Kcoef_m_out
-    REAL, DIMENSION(klon), INTENT(OUT)       :: alf_1_out
-    REAL, DIMENSION(klon), INTENT(OUT)       :: alf_2_out
-!!!
-
-! Local variables
-!****************************************************************************************
-    REAL, DIMENSION(klon)                    :: u1lay, v1lay
-    INTEGER                                  :: k, i
-
-! Include
-!****************************************************************************************
-    INCLUDE "YOMCST.h"
-    INCLUDE "compbl.h"    
-
-!****************************************************************************************
-! Initialize module
-    IF (firstcall) CALL climb_wind_init
-
-!****************************************************************************************
-! Calculate the coefficients C and D in : u(k) = C(k) + D(k)*u(k-1)
-!
-!****************************************************************************************
-! - Define alpha (alf1 and alf2) 
-    alf1(:) = 1.0
-    alf2(:) = 1.0 - alf1(:)
-
-! - Calculate the coefficients K
-    Kcoefm(:,:) = 0.0
-    DO k = 2, klev
-       DO i=1,knon
-          Kcoefm(i,k) = coef_in(i,k)*RG*RG*dtime/(pplay(i,k-1)-pplay(i,k)) &
-               *(paprs(i,k)*2/(temp(i,k)+temp(i,k-1))/RD)**2
-       END DO
-    END DO
-
-! - Calculate the coefficients C and D, component "u"
-    CALL calc_coef(knon, Kcoefm(:,:), delp(:,:), &
-         u_old(:,:), alf1(:), alf2(:),  &
-         Ccoef_U(:,:), Dcoef_U(:,:), Acoef_U(:), Bcoef_U(:))
-
-! - Calculate the coefficients C and D, component "v"
-    CALL calc_coef(knon, Kcoefm(:,:), delp(:,:), &
-         v_old(:,:), alf1(:), alf2(:),  &
-         Ccoef_V(:,:), Dcoef_V(:,:), Acoef_V(:), Bcoef_V(:))
-
-!****************************************************************************************
-! 6)
-! Return the first layer in output variables
-!
-!****************************************************************************************
-    Acoef_U_out = Acoef_U
-    Bcoef_U_out = Bcoef_U
-    Acoef_V_out = Acoef_V
-    Bcoef_V_out = Bcoef_V
-
-!****************************************************************************************
-! 7)
-! If Pbl is split, return also the other layers in output variables
-!
-!****************************************************************************************
-!!! jyg le 07/02/2012
-!!jyg       IF (mod(iflag_pbl_split,2) .eq.1) THEN
-       IF (mod(iflag_pbl_split,10) .ge.1) THEN
-!!! nrlmd le 02/05/2011
-    DO k= 1, klev
-      DO i= 1, klon
-        Ccoef_U_out(i,k) = Ccoef_U(i,k)
-        Ccoef_V_out(i,k) = Ccoef_V(i,k)
-        Dcoef_U_out(i,k) = Dcoef_U(i,k)
-        Dcoef_V_out(i,k) = Dcoef_V(i,k)
-        Kcoef_m_out(i,k) = Kcoefm(i,k)
-      ENDDO
-    ENDDO
-    DO i= 1, klon
-      alf_1_out(i)   = alf1(i)
-      alf_2_out(i)   = alf2(i)
-    ENDDO
-!!!      
-       ENDIF  ! (mod(iflag_pbl_split,2) .ge.1)
-!!!
-
-  END SUBROUTINE climb_wind_down
-!
-!****************************************************************************************
-!
-  SUBROUTINE calc_coef(knon, Kcoef, delp, X, alfa1, alfa2, Ccoef, Dcoef, Acoef, Bcoef)
-!
-! Find the coefficients C and D in fonction of alfa, K and delp
-!
-! Input arguments
-!****************************************************************************************
-    INTEGER, INTENT(IN)                      :: knon
-    REAL, DIMENSION(klon,klev), INTENT(IN)   :: Kcoef, delp
-    REAL, DIMENSION(klon,klev), INTENT(IN)   :: X
-    REAL, DIMENSION(klon), INTENT(IN)        :: alfa1, alfa2
-
-! Output arguments
-!****************************************************************************************
-    REAL, DIMENSION(klon), INTENT(OUT)       :: Acoef, Bcoef
-    REAL, DIMENSION(klon,klev), INTENT(OUT)  :: Ccoef, Dcoef
-  
-! local variables
-!****************************************************************************************
-    INTEGER                                  :: k, i
-    REAL                                     :: buf
-
-    INCLUDE "YOMCST.h"
-!****************************************************************************************
-! 
-
-! Calculate coefficients C and D at top level, k=klev
-!
-    Ccoef(:,:) = 0.0
-    Dcoef(:,:) = 0.0
-
-    DO i = 1, knon
-       buf = delp(i,klev) + Kcoef(i,klev)
-
-       Ccoef(i,klev) = X(i,klev)*delp(i,klev)/buf 
-       Dcoef(i,klev) = Kcoef(i,klev)/buf
-    END DO
-    
-! 
-! Calculate coefficients C and D at top level (klev-1) <= k <= 2
-!
-    DO k=(klev-1),2,-1
-       DO i = 1, knon
-          buf = delp(i,k) + Kcoef(i,k) + Kcoef(i,k+1)*(1.-Dcoef(i,k+1))
-          
-          Ccoef(i,k) = (X(i,k)*delp(i,k) + Kcoef(i,k+1)*Ccoef(i,k+1))/buf
-          Dcoef(i,k) = Kcoef(i,k)/buf
-       END DO
-    END DO
-
-!
-! Calculate coeffiecent A and B at surface
-!
-    DO i = 1, knon
-       buf = delp(i,1) + Kcoef(i,2)*(1-Dcoef(i,2))
-       Acoef(i) = (X(i,1)*delp(i,1) + Kcoef(i,2)*Ccoef(i,2))/buf
-       Bcoef(i) = -RG/buf
-    END DO
-
-  END SUBROUTINE calc_coef
-!
-!****************************************************************************************
-!
-
-  SUBROUTINE climb_wind_up(knon, dtime, u_old, v_old, flx_u1, flx_v1,  &
-!!! nrlmd le 02/05/2011
-       Acoef_U_in, Acoef_V_in, Bcoef_U_in, Bcoef_V_in, &
-       Ccoef_U_in, Ccoef_V_in, Dcoef_U_in, Dcoef_V_in, &
-       Kcoef_m_in, &
-!!!
-       flx_u_new, flx_v_new, d_u_new, d_v_new)
-!
-! Diffuse the wind components from the surface layer and up to the top layer. 
-! Coefficents A, B, C and D are known from before. Start values for the diffusion are the
-! momentum fluxes at surface.
-!
-! u(k=1) = A + B*flx*dtime
-! u(k)   = C(k) + D(k)*u(k-1)  [2 <= k <= klev]
-!
-!****************************************************************************************
-
-! Input arguments
-!****************************************************************************************
-    INTEGER, INTENT(IN)                     :: knon
-    REAL, INTENT(IN)                        :: dtime
-    REAL, DIMENSION(klon,klev), INTENT(IN)  :: u_old
-    REAL, DIMENSION(klon,klev), INTENT(IN)  :: v_old
-    REAL, DIMENSION(klon), INTENT(IN)       :: flx_u1, flx_v1 ! momentum flux
-
-!!! nrlmd le 02/05/2011
-    REAL, DIMENSION(klon), INTENT(IN)       :: Acoef_U_in,Acoef_V_in, Bcoef_U_in, Bcoef_V_in
-    REAL, DIMENSION(klon,klev), INTENT(IN)  :: Ccoef_U_in, Ccoef_V_in, Dcoef_U_in, Dcoef_V_in
-    REAL, DIMENSION(klon,klev), INTENT(IN)  :: Kcoef_m_in
-!!!
-
-! Output arguments
-!****************************************************************************************
-    REAL, DIMENSION(klon,klev), INTENT(OUT) :: flx_u_new, flx_v_new
-    REAL, DIMENSION(klon,klev), INTENT(OUT) :: d_u_new, d_v_new
-
-! Local variables
-!****************************************************************************************
-    REAL, DIMENSION(klon,klev)              :: u_new, v_new
-    INTEGER                                 :: k, i
-
-! Include
-!****************************************************************************************
-    INCLUDE "YOMCST.h"
-    INCLUDE "compbl.h"    
-    
-!
-!****************************************************************************************
-
-!!! jyg le 07/02/2012
-!!jyg       IF (mod(iflag_pbl_split,2) .eq.1) THEN
-       IF (mod(iflag_pbl_split,10) .ge.1) THEN
-!!! nrlmd le 02/05/2011
-    DO i = 1, knon
-      Acoef_U(i)=Acoef_U_in(i)
-      Acoef_V(i)=Acoef_V_in(i)
-      Bcoef_U(i)=Bcoef_U_in(i)
-      Bcoef_V(i)=Bcoef_V_in(i)
-    ENDDO
-    DO k = 1, klev
-      DO i = 1, knon
-        Ccoef_U(i,k)=Ccoef_U_in(i,k)
-        Ccoef_V(i,k)=Ccoef_V_in(i,k)
-        Dcoef_U(i,k)=Dcoef_U_in(i,k)
-        Dcoef_V(i,k)=Dcoef_V_in(i,k)
-        Kcoefm(i,k)=Kcoef_m_in(i,k)
-      ENDDO
-    ENDDO
-!!!
-       ENDIF  ! (mod(iflag_pbl_split,2) .ge.1)
-!!!
-
-! Niveau 1
-    DO i = 1, knon
-       u_new(i,1) = Acoef_U(i) + Bcoef_U(i)*flx_u1(i)*dtime
-       v_new(i,1) = Acoef_V(i) + Bcoef_V(i)*flx_v1(i)*dtime
-    END DO
-
-! Niveau 2 jusqu'au sommet klev
-    DO k = 2, klev
-       DO i=1, knon
-          u_new(i,k) = Ccoef_U(i,k) + Dcoef_U(i,k) * u_new(i,k-1)
-          v_new(i,k) = Ccoef_V(i,k) + Dcoef_V(i,k) * v_new(i,k-1)
-       END DO
-    END DO
-
-!****************************************************************************************
-! Calcul flux
-!
-!== flux_u/v est le flux de moment angulaire (positif vers bas)
-!== dont l'unite est: (kg m/s)/(m**2 s) 
-!
-!****************************************************************************************
-!
-    flx_u_new(:,:) = 0.0
-    flx_v_new(:,:) = 0.0
-
-    flx_u_new(1:knon,1)=flx_u1(1:knon)
-    flx_v_new(1:knon,1)=flx_v1(1:knon)
-
-! Niveau 2->klev
-    DO k = 2, klev
-       DO i = 1, knon
-          flx_u_new(i,k) = Kcoefm(i,k)/RG/dtime * &
-               (u_new(i,k)-u_new(i,k-1))
-          
-          flx_v_new(i,k) = Kcoefm(i,k)/RG/dtime * &
-               (v_new(i,k)-v_new(i,k-1))
-       END DO
-    END DO
-
-!****************************************************************************************
-! Calcul tendances
-!
-!****************************************************************************************
-    d_u_new(:,:) = 0.0
-    d_v_new(:,:) = 0.0
-    DO k = 1, klev
-       DO i = 1, knon
-          d_u_new(i,k) = u_new(i,k) - u_old(i,k)
-          d_v_new(i,k) = v_new(i,k) - v_old(i,k)
-       END DO
-    END DO
-
-  END SUBROUTINE climb_wind_up
-!
-!****************************************************************************************
-!
-END MODULE climb_wind_mod
Index: /LMDZ6/trunk/libf/phylmd/climb_wind_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/climb_wind_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/climb_wind_mod.f90	(revision 5268)
@@ -0,0 +1,389 @@
+!
+MODULE climb_wind_mod
+!
+! Module to solve the verctical diffusion of the wind components "u" and "v".
+!
+  USE dimphy
+
+  IMPLICIT NONE
+
+  SAVE
+  PRIVATE
+  
+  REAL, DIMENSION(:),   ALLOCATABLE  :: alf1, alf2
+  !$OMP THREADPRIVATE(alf1,alf2)
+  REAL, DIMENSION(:,:), ALLOCATABLE  :: Kcoefm
+  !$OMP THREADPRIVATE(Kcoefm)
+  REAL, DIMENSION(:,:), ALLOCATABLE  :: Ccoef_U, Dcoef_U
+  !$OMP THREADPRIVATE(Ccoef_U, Dcoef_U)
+  REAL, DIMENSION(:,:), ALLOCATABLE  :: Ccoef_V, Dcoef_V
+  !$OMP THREADPRIVATE(Ccoef_V, Dcoef_V)
+  REAL, DIMENSION(:), ALLOCATABLE   :: Acoef_U, Bcoef_U
+  !$OMP THREADPRIVATE(Acoef_U, Bcoef_U)
+  REAL, DIMENSION(:), ALLOCATABLE   :: Acoef_V, Bcoef_V
+  !$OMP THREADPRIVATE(Acoef_V, Bcoef_V)
+  LOGICAL                            :: firstcall=.TRUE.
+  !$OMP THREADPRIVATE(firstcall)
+
+  
+  PUBLIC :: climb_wind_down, climb_wind_up
+
+CONTAINS
+!
+!****************************************************************************************
+!
+  SUBROUTINE climb_wind_init
+
+    INTEGER             :: ierr
+    CHARACTER(len = 20) :: modname = 'climb_wind_init'    
+
+!****************************************************************************************
+! Allocation of global module variables
+!
+!****************************************************************************************
+
+    ALLOCATE(alf1(klon), stat=ierr)
+    IF (ierr /= 0) CALL abort_physic(modname,'Pb in allocate alf1',1)
+
+    ALLOCATE(alf2(klon), stat=ierr)
+    IF (ierr /= 0) CALL abort_physic(modname,'Pb in allocate alf2',1)
+
+    ALLOCATE(Kcoefm(klon,klev), stat=ierr)
+    IF (ierr /= 0) CALL abort_physic(modname,'Pb in allocate Kcoefm',1)
+
+    ALLOCATE(Ccoef_U(klon,klev), stat=ierr)
+    IF (ierr /= 0) CALL abort_physic(modname,'Pb in allocate Ccoef_U',1)
+
+    ALLOCATE(Dcoef_U(klon,klev), stat=ierr)
+    IF (ierr /= 0) CALL abort_physic(modname,'Pb in allocation Dcoef_U',1)
+
+    ALLOCATE(Ccoef_V(klon,klev), stat=ierr)
+    IF (ierr /= 0) CALL abort_physic(modname,'Pb in allocation Ccoef_V',1)
+
+    ALLOCATE(Dcoef_V(klon,klev), stat=ierr)
+    IF (ierr /= 0) CALL abort_physic(modname,'Pb in allocation Dcoef_V',1)
+
+    ALLOCATE(Acoef_U(klon), Bcoef_U(klon), Acoef_V(klon), Bcoef_V(klon), STAT=ierr)
+    IF ( ierr /= 0 )  PRINT*,' pb in allloc Acoef_U and Bcoef_U, ierr=', ierr
+
+    firstcall=.FALSE.
+
+  END SUBROUTINE climb_wind_init
+!
+!****************************************************************************************
+!
+  SUBROUTINE climb_wind_down(knon, dtime, coef_in, pplay, paprs, temp, delp, u_old, v_old, &
+!!! nrlmd le 02/05/2011
+       Ccoef_U_out, Ccoef_V_out, Dcoef_U_out, Dcoef_V_out, &
+       Kcoef_m_out, alf_1_out, alf_2_out, &
+!!!
+       Acoef_U_out, Acoef_V_out, Bcoef_U_out, Bcoef_V_out)
+!
+! This routine calculates for the wind components u and v,
+! recursivly the coefficients C and D in equation 
+! X(k) = C(k) + D(k)*X(k-1), X=[u,v], k=[1,klev] is the vertical layer.
+!
+!
+
+! Input arguments
+!****************************************************************************************
+    INTEGER, INTENT(IN)                      :: knon
+    REAL, INTENT(IN)                         :: dtime
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: coef_in
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: pplay ! pres au milieu de couche (Pa)
+    REAL, DIMENSION(klon,klev+1), INTENT(IN) :: paprs ! pression a inter-couche (Pa)
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: temp  ! temperature
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: delp
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: u_old
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: v_old
+
+! Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(OUT)       :: Acoef_U_out
+    REAL, DIMENSION(klon), INTENT(OUT)       :: Acoef_V_out
+    REAL, DIMENSION(klon), INTENT(OUT)       :: Bcoef_U_out
+    REAL, DIMENSION(klon), INTENT(OUT)       :: Bcoef_V_out
+
+!!! nrlmd le 02/05/2011
+    REAL, DIMENSION(klon,klev), INTENT(OUT)  :: Ccoef_U_out
+    REAL, DIMENSION(klon,klev), INTENT(OUT)  :: Ccoef_V_out
+    REAL, DIMENSION(klon,klev), INTENT(OUT)  :: Dcoef_U_out
+    REAL, DIMENSION(klon,klev), INTENT(OUT)  :: Dcoef_V_out
+    REAL, DIMENSION(klon,klev), INTENT(OUT)  :: Kcoef_m_out
+    REAL, DIMENSION(klon), INTENT(OUT)       :: alf_1_out
+    REAL, DIMENSION(klon), INTENT(OUT)       :: alf_2_out
+!!!
+
+! Local variables
+!****************************************************************************************
+    REAL, DIMENSION(klon)                    :: u1lay, v1lay
+    INTEGER                                  :: k, i
+
+! Include
+!****************************************************************************************
+    INCLUDE "YOMCST.h"
+    INCLUDE "compbl.h"    
+
+!****************************************************************************************
+! Initialize module
+    IF (firstcall) CALL climb_wind_init
+
+!****************************************************************************************
+! Calculate the coefficients C and D in : u(k) = C(k) + D(k)*u(k-1)
+!
+!****************************************************************************************
+! - Define alpha (alf1 and alf2) 
+    alf1(:) = 1.0
+    alf2(:) = 1.0 - alf1(:)
+
+! - Calculate the coefficients K
+    Kcoefm(:,:) = 0.0
+    DO k = 2, klev
+       DO i=1,knon
+          Kcoefm(i,k) = coef_in(i,k)*RG*RG*dtime/(pplay(i,k-1)-pplay(i,k)) &
+               *(paprs(i,k)*2/(temp(i,k)+temp(i,k-1))/RD)**2
+       END DO
+    END DO
+
+! - Calculate the coefficients C and D, component "u"
+    CALL calc_coef(knon, Kcoefm(:,:), delp(:,:), &
+         u_old(:,:), alf1(:), alf2(:),  &
+         Ccoef_U(:,:), Dcoef_U(:,:), Acoef_U(:), Bcoef_U(:))
+
+! - Calculate the coefficients C and D, component "v"
+    CALL calc_coef(knon, Kcoefm(:,:), delp(:,:), &
+         v_old(:,:), alf1(:), alf2(:),  &
+         Ccoef_V(:,:), Dcoef_V(:,:), Acoef_V(:), Bcoef_V(:))
+
+!****************************************************************************************
+! 6)
+! Return the first layer in output variables
+!
+!****************************************************************************************
+    Acoef_U_out = Acoef_U
+    Bcoef_U_out = Bcoef_U
+    Acoef_V_out = Acoef_V
+    Bcoef_V_out = Bcoef_V
+
+!****************************************************************************************
+! 7)
+! If Pbl is split, return also the other layers in output variables
+!
+!****************************************************************************************
+!!! jyg le 07/02/2012
+!!jyg       IF (mod(iflag_pbl_split,2) .eq.1) THEN
+       IF (mod(iflag_pbl_split,10) .ge.1) THEN
+!!! nrlmd le 02/05/2011
+    DO k= 1, klev
+      DO i= 1, klon
+        Ccoef_U_out(i,k) = Ccoef_U(i,k)
+        Ccoef_V_out(i,k) = Ccoef_V(i,k)
+        Dcoef_U_out(i,k) = Dcoef_U(i,k)
+        Dcoef_V_out(i,k) = Dcoef_V(i,k)
+        Kcoef_m_out(i,k) = Kcoefm(i,k)
+      ENDDO
+    ENDDO
+    DO i= 1, klon
+      alf_1_out(i)   = alf1(i)
+      alf_2_out(i)   = alf2(i)
+    ENDDO
+!!!      
+       ENDIF  ! (mod(iflag_pbl_split,2) .ge.1)
+!!!
+
+  END SUBROUTINE climb_wind_down
+!
+!****************************************************************************************
+!
+  SUBROUTINE calc_coef(knon, Kcoef, delp, X, alfa1, alfa2, Ccoef, Dcoef, Acoef, Bcoef)
+!
+! Find the coefficients C and D in fonction of alfa, K and delp
+!
+! Input arguments
+!****************************************************************************************
+    INTEGER, INTENT(IN)                      :: knon
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: Kcoef, delp
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: X
+    REAL, DIMENSION(klon), INTENT(IN)        :: alfa1, alfa2
+
+! Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(OUT)       :: Acoef, Bcoef
+    REAL, DIMENSION(klon,klev), INTENT(OUT)  :: Ccoef, Dcoef
+  
+! local variables
+!****************************************************************************************
+    INTEGER                                  :: k, i
+    REAL                                     :: buf
+
+    INCLUDE "YOMCST.h"
+!****************************************************************************************
+! 
+
+! Calculate coefficients C and D at top level, k=klev
+!
+    Ccoef(:,:) = 0.0
+    Dcoef(:,:) = 0.0
+
+    DO i = 1, knon
+       buf = delp(i,klev) + Kcoef(i,klev)
+
+       Ccoef(i,klev) = X(i,klev)*delp(i,klev)/buf 
+       Dcoef(i,klev) = Kcoef(i,klev)/buf
+    END DO
+    
+! 
+! Calculate coefficients C and D at top level (klev-1) <= k <= 2
+!
+    DO k=(klev-1),2,-1
+       DO i = 1, knon
+          buf = delp(i,k) + Kcoef(i,k) + Kcoef(i,k+1)*(1.-Dcoef(i,k+1))
+          
+          Ccoef(i,k) = (X(i,k)*delp(i,k) + Kcoef(i,k+1)*Ccoef(i,k+1))/buf
+          Dcoef(i,k) = Kcoef(i,k)/buf
+       END DO
+    END DO
+
+!
+! Calculate coeffiecent A and B at surface
+!
+    DO i = 1, knon
+       buf = delp(i,1) + Kcoef(i,2)*(1-Dcoef(i,2))
+       Acoef(i) = (X(i,1)*delp(i,1) + Kcoef(i,2)*Ccoef(i,2))/buf
+       Bcoef(i) = -RG/buf
+    END DO
+
+  END SUBROUTINE calc_coef
+!
+!****************************************************************************************
+!
+
+  SUBROUTINE climb_wind_up(knon, dtime, u_old, v_old, flx_u1, flx_v1,  &
+!!! nrlmd le 02/05/2011
+       Acoef_U_in, Acoef_V_in, Bcoef_U_in, Bcoef_V_in, &
+       Ccoef_U_in, Ccoef_V_in, Dcoef_U_in, Dcoef_V_in, &
+       Kcoef_m_in, &
+!!!
+       flx_u_new, flx_v_new, d_u_new, d_v_new)
+!
+! Diffuse the wind components from the surface layer and up to the top layer. 
+! Coefficents A, B, C and D are known from before. Start values for the diffusion are the
+! momentum fluxes at surface.
+!
+! u(k=1) = A + B*flx*dtime
+! u(k)   = C(k) + D(k)*u(k-1)  [2 <= k <= klev]
+!
+!****************************************************************************************
+
+! Input arguments
+!****************************************************************************************
+    INTEGER, INTENT(IN)                     :: knon
+    REAL, INTENT(IN)                        :: dtime
+    REAL, DIMENSION(klon,klev), INTENT(IN)  :: u_old
+    REAL, DIMENSION(klon,klev), INTENT(IN)  :: v_old
+    REAL, DIMENSION(klon), INTENT(IN)       :: flx_u1, flx_v1 ! momentum flux
+
+!!! nrlmd le 02/05/2011
+    REAL, DIMENSION(klon), INTENT(IN)       :: Acoef_U_in,Acoef_V_in, Bcoef_U_in, Bcoef_V_in
+    REAL, DIMENSION(klon,klev), INTENT(IN)  :: Ccoef_U_in, Ccoef_V_in, Dcoef_U_in, Dcoef_V_in
+    REAL, DIMENSION(klon,klev), INTENT(IN)  :: Kcoef_m_in
+!!!
+
+! Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon,klev), INTENT(OUT) :: flx_u_new, flx_v_new
+    REAL, DIMENSION(klon,klev), INTENT(OUT) :: d_u_new, d_v_new
+
+! Local variables
+!****************************************************************************************
+    REAL, DIMENSION(klon,klev)              :: u_new, v_new
+    INTEGER                                 :: k, i
+
+! Include
+!****************************************************************************************
+    INCLUDE "YOMCST.h"
+    INCLUDE "compbl.h"    
+    
+!
+!****************************************************************************************
+
+!!! jyg le 07/02/2012
+!!jyg       IF (mod(iflag_pbl_split,2) .eq.1) THEN
+       IF (mod(iflag_pbl_split,10) .ge.1) THEN
+!!! nrlmd le 02/05/2011
+    DO i = 1, knon
+      Acoef_U(i)=Acoef_U_in(i)
+      Acoef_V(i)=Acoef_V_in(i)
+      Bcoef_U(i)=Bcoef_U_in(i)
+      Bcoef_V(i)=Bcoef_V_in(i)
+    ENDDO
+    DO k = 1, klev
+      DO i = 1, knon
+        Ccoef_U(i,k)=Ccoef_U_in(i,k)
+        Ccoef_V(i,k)=Ccoef_V_in(i,k)
+        Dcoef_U(i,k)=Dcoef_U_in(i,k)
+        Dcoef_V(i,k)=Dcoef_V_in(i,k)
+        Kcoefm(i,k)=Kcoef_m_in(i,k)
+      ENDDO
+    ENDDO
+!!!
+       ENDIF  ! (mod(iflag_pbl_split,2) .ge.1)
+!!!
+
+! Niveau 1
+    DO i = 1, knon
+       u_new(i,1) = Acoef_U(i) + Bcoef_U(i)*flx_u1(i)*dtime
+       v_new(i,1) = Acoef_V(i) + Bcoef_V(i)*flx_v1(i)*dtime
+    END DO
+
+! Niveau 2 jusqu'au sommet klev
+    DO k = 2, klev
+       DO i=1, knon
+          u_new(i,k) = Ccoef_U(i,k) + Dcoef_U(i,k) * u_new(i,k-1)
+          v_new(i,k) = Ccoef_V(i,k) + Dcoef_V(i,k) * v_new(i,k-1)
+       END DO
+    END DO
+
+!****************************************************************************************
+! Calcul flux
+!
+!== flux_u/v est le flux de moment angulaire (positif vers bas)
+!== dont l'unite est: (kg m/s)/(m**2 s) 
+!
+!****************************************************************************************
+!
+    flx_u_new(:,:) = 0.0
+    flx_v_new(:,:) = 0.0
+
+    flx_u_new(1:knon,1)=flx_u1(1:knon)
+    flx_v_new(1:knon,1)=flx_v1(1:knon)
+
+! Niveau 2->klev
+    DO k = 2, klev
+       DO i = 1, knon
+          flx_u_new(i,k) = Kcoefm(i,k)/RG/dtime * &
+               (u_new(i,k)-u_new(i,k-1))
+          
+          flx_v_new(i,k) = Kcoefm(i,k)/RG/dtime * &
+               (v_new(i,k)-v_new(i,k-1))
+       END DO
+    END DO
+
+!****************************************************************************************
+! Calcul tendances
+!
+!****************************************************************************************
+    d_u_new(:,:) = 0.0
+    d_v_new(:,:) = 0.0
+    DO k = 1, klev
+       DO i = 1, knon
+          d_u_new(i,k) = u_new(i,k) - u_old(i,k)
+          d_v_new(i,k) = v_new(i,k) - v_old(i,k)
+       END DO
+    END DO
+
+  END SUBROUTINE climb_wind_up
+!
+!****************************************************************************************
+!
+END MODULE climb_wind_mod
Index: DZ6/trunk/libf/phylmd/clouds_bigauss.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/clouds_bigauss.F90	(revision 5267)
+++ 	(revision )
@@ -1,119 +1,0 @@
-
-! $Header$
-
-
-! ================================================================================
-
-SUBROUTINE clouds_bigauss(klon, nd, r, rs, qtc, sigt, ptconv, ratqsc, cldf)
-  IMPLICIT NONE
-
-  ! --------------------------------------------------------------------------------
-
-  ! Inputs:
-
-  ! ND----------: Number of vertical levels
-  ! R--------ND-: Domain-averaged mixing ratio of total water
-  ! RS-------ND-: Mean saturation humidity mixing ratio within the gridbox
-  ! QSUB-----ND-: Mixing ratio of condensed water within clouds associated
-  ! with SUBGRID-SCALE condensation processes (here, it is
-  ! predicted by the convection scheme)
-  ! Outputs:
-
-  ! PTCONV-----ND-: Point convectif = TRUE
-  ! RATQSC-----ND-: Largeur normalisee de la distribution
-  ! CLDF-----ND-: Fraction nuageuse
-
-  ! --------------------------------------------------------------------------------
-
-
-  INTEGER klon, nd
-  REAL r(klon, nd), rs(klon, nd), qtc(klon, nd), sigt(klon, nd)
-  LOGICAL ptconv(klon, nd)
-  REAL ratqsc(klon, nd)
-  REAL cldf(klon, nd)
-
-  ! -- parameters controlling the iteration:
-  ! --    nmax    : maximum nb of iterations (hopefully never reached)
-  ! --    epsilon : accuracy of the numerical resolution
-  ! --    vmax    : v-value above which we use an asymptotic expression for
-  ! ERF(v)
-
-  INTEGER nmax
-  PARAMETER (nmax=10)
-  REAL epsilon, vmax0, vmax(klon)
-  PARAMETER (epsilon=0.02, vmax0=2.0)
-
-  REAL min_mu, min_q
-  PARAMETER (min_mu=1.E-12, min_q=1.E-12)
-
-  INTEGER i, k, n, m
-  REAL mu, qsat, delta
-  REAL sigma1, sigma2, alpha, qconv
-  REAL xconv, xenv
-  REAL cconv, cenv
-  REAL pi, u, v
-  REAL erf
-  REAL sqrtpi, sqrt2
-  ! lconv = true si le calcul a converge (entre autre si qsub < min_q)
-  LOGICAL lconv(klon)
-
-
-  cldf(1:klon, 1:nd) = 0.0 ! cym
-  ratqsc(1:klon, 1:nd) = 0.0
-  ptconv(1:klon, 1:nd) = .FALSE.
-  ! cdir end arraycomb
-
-  pi = acos(-1.)
-  sqrtpi = sqrt(pi)
-  sqrt2 = sqrt(2.)
-
-
-  DO k = 1, nd
-
-  DO i = 1, klon ! vector
-
-      mu = r(i, k)
-      mu = max(mu, min_mu)
-      qsat = rs(i, k)
-      qsat = max(qsat, min_mu)
-      delta = log(mu/qsat)
-      qconv=qtc(i,k)
-      alpha=sigt(i,k)
-
-     IF (qconv<min_q) THEN
-        ptconv(i, k) = .FALSE.
-        ratqsc(i, k) = 0.
-
-        ! Rien on a deja initialise
-
-      ELSE
-    
-      sigma1=0.1*((qconv-mu)**2)**0.5+0.002*mu
-      sigma2=0.1*((qconv-mu)**2)**0.5+0.002*qconv 
-
-!      sigma2=0.09*((qconv-mu)**2)**0.5/(alpha+0.01)**0.5+0.002*qconv 
-!-----------------------------------------------------------------------------------------------------------------
-! Calcul de la couverture nuageuse et de ratqs
-!-----------------------------------------------------------------------------------------------------------------
-
-      xconv=(qsat-qconv)/(sqrt(2.)*sigma2)
-      xenv=(qsat-mu)/(sqrt(2.)*sigma1)
-
-      cconv=0.5*(1.-1.*erf(xconv))
-      cenv=0.5*(1.-1.*erf(xenv)) 
-      cldf(i,k)=alpha*cconv+(1.-1.*alpha)*cenv
-      ratqsc(i,k)= alpha*sigma1+(1.-1.*alpha)*sigma2
-      ptconv(i,k)= .TRUE.
-
-     END IF
-
-  END DO ! vector
-
-
-  END DO  ! K
-
-  RETURN
-  END SUBROUTINE clouds_bigauss
-
-
-
Index: /LMDZ6/trunk/libf/phylmd/clouds_bigauss.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/clouds_bigauss.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/clouds_bigauss.f90	(revision 5268)
@@ -0,0 +1,119 @@
+
+! $Header$
+
+
+! ================================================================================
+
+SUBROUTINE clouds_bigauss(klon, nd, r, rs, qtc, sigt, ptconv, ratqsc, cldf)
+  IMPLICIT NONE
+
+  ! --------------------------------------------------------------------------------
+
+  ! Inputs:
+
+  ! ND----------: Number of vertical levels
+  ! R--------ND-: Domain-averaged mixing ratio of total water
+  ! RS-------ND-: Mean saturation humidity mixing ratio within the gridbox
+  ! QSUB-----ND-: Mixing ratio of condensed water within clouds associated
+  ! with SUBGRID-SCALE condensation processes (here, it is
+  ! predicted by the convection scheme)
+  ! Outputs:
+
+  ! PTCONV-----ND-: Point convectif = TRUE
+  ! RATQSC-----ND-: Largeur normalisee de la distribution
+  ! CLDF-----ND-: Fraction nuageuse
+
+  ! --------------------------------------------------------------------------------
+
+
+  INTEGER klon, nd
+  REAL r(klon, nd), rs(klon, nd), qtc(klon, nd), sigt(klon, nd)
+  LOGICAL ptconv(klon, nd)
+  REAL ratqsc(klon, nd)
+  REAL cldf(klon, nd)
+
+  ! -- parameters controlling the iteration:
+  ! --    nmax    : maximum nb of iterations (hopefully never reached)
+  ! --    epsilon : accuracy of the numerical resolution
+  ! --    vmax    : v-value above which we use an asymptotic expression for
+  ! ERF(v)
+
+  INTEGER nmax
+  PARAMETER (nmax=10)
+  REAL epsilon, vmax0, vmax(klon)
+  PARAMETER (epsilon=0.02, vmax0=2.0)
+
+  REAL min_mu, min_q
+  PARAMETER (min_mu=1.E-12, min_q=1.E-12)
+
+  INTEGER i, k, n, m
+  REAL mu, qsat, delta
+  REAL sigma1, sigma2, alpha, qconv
+  REAL xconv, xenv
+  REAL cconv, cenv
+  REAL pi, u, v
+  REAL erf
+  REAL sqrtpi, sqrt2
+  ! lconv = true si le calcul a converge (entre autre si qsub < min_q)
+  LOGICAL lconv(klon)
+
+
+  cldf(1:klon, 1:nd) = 0.0 ! cym
+  ratqsc(1:klon, 1:nd) = 0.0
+  ptconv(1:klon, 1:nd) = .FALSE.
+  ! cdir end arraycomb
+
+  pi = acos(-1.)
+  sqrtpi = sqrt(pi)
+  sqrt2 = sqrt(2.)
+
+
+  DO k = 1, nd
+
+  DO i = 1, klon ! vector
+
+      mu = r(i, k)
+      mu = max(mu, min_mu)
+      qsat = rs(i, k)
+      qsat = max(qsat, min_mu)
+      delta = log(mu/qsat)
+      qconv=qtc(i,k)
+      alpha=sigt(i,k)
+
+     IF (qconv<min_q) THEN
+        ptconv(i, k) = .FALSE.
+        ratqsc(i, k) = 0.
+
+        ! Rien on a deja initialise
+
+      ELSE
+    
+      sigma1=0.1*((qconv-mu)**2)**0.5+0.002*mu
+      sigma2=0.1*((qconv-mu)**2)**0.5+0.002*qconv 
+
+!      sigma2=0.09*((qconv-mu)**2)**0.5/(alpha+0.01)**0.5+0.002*qconv 
+!-----------------------------------------------------------------------------------------------------------------
+! Calcul de la couverture nuageuse et de ratqs
+!-----------------------------------------------------------------------------------------------------------------
+
+      xconv=(qsat-qconv)/(sqrt(2.)*sigma2)
+      xenv=(qsat-mu)/(sqrt(2.)*sigma1)
+
+      cconv=0.5*(1.-1.*erf(xconv))
+      cenv=0.5*(1.-1.*erf(xenv)) 
+      cldf(i,k)=alpha*cconv+(1.-1.*alpha)*cenv
+      ratqsc(i,k)= alpha*sigma1+(1.-1.*alpha)*sigma2
+      ptconv(i,k)= .TRUE.
+
+     END IF
+
+  END DO ! vector
+
+
+  END DO  ! K
+
+  RETURN
+  END SUBROUTINE clouds_bigauss
+
+
+
Index: DZ6/trunk/libf/phylmd/clouds_gno.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/clouds_gno.F90	(revision 5267)
+++ 	(revision )
@@ -1,261 +1,0 @@
-
-! $Header$
-
-
-! ================================================================================
-
-SUBROUTINE clouds_gno(klon, nd, r, rs, qsub, ptconv, ratqsc, cldf)
-  IMPLICIT NONE
-
-  ! --------------------------------------------------------------------------------
-
-  ! Inputs:
-
-  ! ND----------: Number of vertical levels
-  ! R--------ND-: Domain-averaged mixing ratio of total water
-  ! RS-------ND-: Mean saturation humidity mixing ratio within the gridbox
-  ! QSUB-----ND-: Mixing ratio of condensed water within clouds associated
-  ! with SUBGRID-SCALE condensation processes (here, it is
-  ! predicted by the convection scheme)
-  ! Outputs:
-
-  ! PTCONV-----ND-: Point convectif = TRUE
-  ! RATQSC-----ND-: Largeur normalisee de la distribution
-  ! CLDF-----ND-: Fraction nuageuse
-
-  ! --------------------------------------------------------------------------------
-
-
-  INTEGER klon, nd
-  REAL r(klon, nd), rs(klon, nd), qsub(klon, nd)
-  LOGICAL ptconv(klon, nd)
-  REAL ratqsc(klon, nd)
-  REAL cldf(klon, nd)
-
-  ! -- parameters controlling the iteration:
-  ! --    nmax    : maximum nb of iterations (hopefully never reached)
-  ! --    epsilon : accuracy of the numerical resolution
-  ! --    vmax    : v-value above which we use an asymptotic expression for
-  ! ERF(v)
-
-  INTEGER nmax
-  PARAMETER (nmax=10)
-  REAL epsilon, vmax0, vmax(klon)
-  PARAMETER (epsilon=0.02, vmax0=2.0)
-
-  REAL min_mu, min_q
-  PARAMETER (min_mu=1.E-12, min_q=1.E-12)
-
-  INTEGER i, k, n, m
-  REAL mu(klon), qsat, delta(klon), beta(klon)
-  REAL zu2, zv2
-  REAL xx(klon), aux(klon), coeff, block
-  REAL dist, fprime, det
-  REAL pi, u, v, erfcu, erfcv
-  REAL xx1, xx2
-  REAL erf, hsqrtlog_2, v2
-  REAL sqrtpi, sqrt2, zx1, zx2, exdel
-  ! lconv = true si le calcul a converge (entre autre si qsub < min_q)
-  LOGICAL lconv(klon)
-
-  ! cdir arraycomb
-  cldf(1:klon, 1:nd) = 0.0 ! cym
-  ratqsc(1:klon, 1:nd) = 0.0
-  ptconv(1:klon, 1:nd) = .FALSE.
-  ! cdir end arraycomb
-
-  pi = acos(-1.)
-  sqrtpi = sqrt(pi)
-  sqrt2 = sqrt(2.)
-  hsqrtlog_2 = 0.5*sqrt(log(2.))
-
-  DO k = 1, nd
-
-    DO i = 1, klon ! vector
-      mu(i) = r(i, k)
-      mu(i) = max(mu(i), min_mu)
-      qsat = rs(i, k)
-      qsat = max(qsat, min_mu)
-      delta(i) = log(mu(i)/qsat)
-      ! enddo ! vector
-
-
-      ! ***          There is no subgrid-scale condensation;        ***
-      ! ***   the scheme becomes equivalent to an "all-or-nothing"  ***
-      ! ***             large-scale condensation scheme.            ***
-
-
-
-      ! ***     Some condensation is produced at the subgrid-scale       ***
-      ! ***                                                              ***
-      ! ***       PDF = generalized log-normal distribution (GNO)        ***
-      ! ***   (k<0 because a lower bound is considered for the PDF)      ***
-      ! ***                                                              ***
-      ! ***  -> Determine x (the parameter k of the GNO PDF) such        ***
-      ! ***  that the contribution of subgrid-scale processes to         ***
-      ! ***  the in-cloud water content is equal to QSUB(K)              ***
-      ! ***  (equations (13), (14), (15) + Appendix B of the paper)      ***
-      ! ***                                                              ***
-      ! ***    Here, an iterative method is used for this purpose        ***
-      ! ***    (other numerical methods might be more efficient)         ***
-      ! ***                                                              ***
-      ! ***          NB: the "error function" is called ERF              ***
-      ! ***                 (ERF in double precision)                   ***
-
-
-      ! On commence par eliminer les cas pour lesquels on n'a pas
-      ! suffisamment d'eau nuageuse.
-
-      ! do i=1,klon ! vector
-
-      IF (qsub(i,k)<min_q) THEN
-        ptconv(i, k) = .FALSE.
-        ratqsc(i, k) = 0.
-        lconv(i) = .TRUE.
-
-        ! Rien on a deja initialise
-
-      ELSE
-
-        lconv(i) = .FALSE.
-        vmax(i) = vmax0
-
-        beta(i) = qsub(i, k)/mu(i) + exp(-min(0.0,delta(i)))
-
-        ! --  roots of equation v > vmax:
-
-        det = delta(i) + vmax(i)*vmax(i)
-        IF (det<=0.0) vmax(i) = vmax0 + 1.0
-        det = delta(i) + vmax(i)*vmax(i)
-
-        IF (det<=0.) THEN
-          xx(i) = -0.0001
-        ELSE
-          zx1 = -sqrt2*vmax(i)
-          zx2 = sqrt(1.0+delta(i)/(vmax(i)*vmax(i)))
-          xx1 = zx1*(1.0-zx2)
-          xx2 = zx1*(1.0+zx2)
-          xx(i) = 1.01*xx1
-          IF (xx1>=0.0) xx(i) = 0.5*xx2
-        END IF
-        IF (delta(i)<0.) xx(i) = -hsqrtlog_2
-
-      END IF
-
-    END DO ! vector
-
-    ! ----------------------------------------------------------------------
-    ! Debut des nmax iterations pour trouver la solution.
-    ! ----------------------------------------------------------------------
-
-    DO n = 1, nmax
-
-      DO i = 1, klon ! vector
-        IF (.NOT. lconv(i)) THEN
-
-          u = delta(i)/(xx(i)*sqrt2) + xx(i)/(2.*sqrt2)
-          v = delta(i)/(xx(i)*sqrt2) - xx(i)/(2.*sqrt2)
-          v2 = v*v
-
-          IF (v>vmax(i)) THEN
-
-            IF (abs(u)>vmax(i) .AND. delta(i)<0.) THEN
-
-              ! -- use asymptotic expression of erf for u and v large:
-              ! ( -> analytic solution for xx )
-              exdel = beta(i)*exp(delta(i))
-              aux(i) = 2.0*delta(i)*(1.-exdel)/(1.+exdel)
-              IF (aux(i)<0.) THEN
-                ! print*,'AUX(',i,',',k,')<0',aux(i),delta(i),beta(i)
-                aux(i) = 0.
-              END IF
-              xx(i) = -sqrt(aux(i))
-              block = exp(-v*v)/v/sqrtpi
-              dist = 0.0
-              fprime = 1.0
-
-            ELSE
-
-              ! -- erfv -> 1.0, use an asymptotic expression of erfv for v
-              ! large:
-
-              erfcu = 1.0 - erf(u)
-              ! !!! ATTENTION : rajout d'un seuil pour l'exponentiel
-              aux(i) = sqrtpi*erfcu*exp(min(v2,100.))
-              coeff = 1.0 - 0.5/(v2) + 0.75/(v2*v2)
-              block = coeff*exp(-v2)/v/sqrtpi
-              dist = v*aux(i)/coeff - beta(i)
-              fprime = 2.0/xx(i)*(v2)*(exp(-delta(i))-u*aux(i)/coeff)/coeff
-
-            END IF ! ABS(u)
-
-          ELSE
-
-            ! -- general case:
-
-            erfcu = 1.0 - erf(u)
-            erfcv = 1.0 - erf(v)
-            block = erfcv
-            dist = erfcu/erfcv - beta(i)
-            zu2 = u*u
-            zv2 = v2
-            IF (zu2>20. .OR. zv2>20.) THEN
-              ! print*,'ATTENTION !!! xx(',i,') =', xx(i)
-              ! print*,'ATTENTION !!! klon,ND,R,RS,QSUB,PTCONV,RATQSC,CLDF',
-              ! .klon,ND,R(i,k),RS(i,k),QSUB(i,k),PTCONV(i,k),RATQSC(i,k),
-              ! .CLDF(i,k)
-              ! print*,'ATTENTION !!! zu2 zv2 =',zu2(i),zv2(i)
-              zu2 = 20.
-              zv2 = 20.
-              fprime = 0.
-            ELSE
-              fprime = 2./sqrtpi/xx(i)/(erfcv*erfcv)* &
-                (erfcv*v*exp(-zu2)-erfcu*u*exp(-zv2))
-            END IF
-          END IF ! x
-
-          ! -- test numerical convergence:
-
-          ! if (beta(i).lt.1.e-10) then
-          ! print*,'avant test ',i,k,lconv(i),u(i),v(i),beta(i)
-          ! stop
-          ! endif
-          IF (abs(fprime)<1.E-11) THEN
-            ! print*,'avant test fprime<.e-11 '
-            ! s        ,i,k,lconv(i),u(i),v(i),beta(i),fprime(i)
-            ! print*,'klon,ND,R,RS,QSUB',
-            ! s        klon,ND,R(i,k),rs(i,k),qsub(i,k)
-            fprime = sign(1.E-11, fprime)
-          END IF
-
-
-          IF (abs(dist/beta(i))<epsilon) THEN
-            ! print*,'v-u **2',(v(i)-u(i))**2
-            ! print*,'exp v-u **2',exp((v(i)-u(i))**2)
-            ptconv(i, k) = .TRUE.
-            lconv(i) = .TRUE.
-            ! borne pour l'exponentielle
-            ratqsc(i, k) = min(2.*(v-u)*(v-u), 20.)
-            ratqsc(i, k) = sqrt(exp(ratqsc(i,k))-1.)
-            cldf(i, k) = 0.5*block
-          ELSE
-            xx(i) = xx(i) - dist/fprime
-          END IF
-          ! print*,'apres test ',i,k,lconv(i)
-
-        END IF ! lconv
-      END DO ! vector
-
-      ! ----------------------------------------------------------------------
-      ! Fin des nmax iterations pour trouver la solution.
-    END DO ! n
-    ! ----------------------------------------------------------------------
-
-
-  END DO
-  ! K
-  RETURN
-END SUBROUTINE clouds_gno
-
-
-
Index: /LMDZ6/trunk/libf/phylmd/clouds_gno.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/clouds_gno.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/clouds_gno.f90	(revision 5268)
@@ -0,0 +1,261 @@
+
+! $Header$
+
+
+! ================================================================================
+
+SUBROUTINE clouds_gno(klon, nd, r, rs, qsub, ptconv, ratqsc, cldf)
+  IMPLICIT NONE
+
+  ! --------------------------------------------------------------------------------
+
+  ! Inputs:
+
+  ! ND----------: Number of vertical levels
+  ! R--------ND-: Domain-averaged mixing ratio of total water
+  ! RS-------ND-: Mean saturation humidity mixing ratio within the gridbox
+  ! QSUB-----ND-: Mixing ratio of condensed water within clouds associated
+  ! with SUBGRID-SCALE condensation processes (here, it is
+  ! predicted by the convection scheme)
+  ! Outputs:
+
+  ! PTCONV-----ND-: Point convectif = TRUE
+  ! RATQSC-----ND-: Largeur normalisee de la distribution
+  ! CLDF-----ND-: Fraction nuageuse
+
+  ! --------------------------------------------------------------------------------
+
+
+  INTEGER klon, nd
+  REAL r(klon, nd), rs(klon, nd), qsub(klon, nd)
+  LOGICAL ptconv(klon, nd)
+  REAL ratqsc(klon, nd)
+  REAL cldf(klon, nd)
+
+  ! -- parameters controlling the iteration:
+  ! --    nmax    : maximum nb of iterations (hopefully never reached)
+  ! --    epsilon : accuracy of the numerical resolution
+  ! --    vmax    : v-value above which we use an asymptotic expression for
+  ! ERF(v)
+
+  INTEGER nmax
+  PARAMETER (nmax=10)
+  REAL epsilon, vmax0, vmax(klon)
+  PARAMETER (epsilon=0.02, vmax0=2.0)
+
+  REAL min_mu, min_q
+  PARAMETER (min_mu=1.E-12, min_q=1.E-12)
+
+  INTEGER i, k, n, m
+  REAL mu(klon), qsat, delta(klon), beta(klon)
+  REAL zu2, zv2
+  REAL xx(klon), aux(klon), coeff, block
+  REAL dist, fprime, det
+  REAL pi, u, v, erfcu, erfcv
+  REAL xx1, xx2
+  REAL erf, hsqrtlog_2, v2
+  REAL sqrtpi, sqrt2, zx1, zx2, exdel
+  ! lconv = true si le calcul a converge (entre autre si qsub < min_q)
+  LOGICAL lconv(klon)
+
+  ! cdir arraycomb
+  cldf(1:klon, 1:nd) = 0.0 ! cym
+  ratqsc(1:klon, 1:nd) = 0.0
+  ptconv(1:klon, 1:nd) = .FALSE.
+  ! cdir end arraycomb
+
+  pi = acos(-1.)
+  sqrtpi = sqrt(pi)
+  sqrt2 = sqrt(2.)
+  hsqrtlog_2 = 0.5*sqrt(log(2.))
+
+  DO k = 1, nd
+
+    DO i = 1, klon ! vector
+      mu(i) = r(i, k)
+      mu(i) = max(mu(i), min_mu)
+      qsat = rs(i, k)
+      qsat = max(qsat, min_mu)
+      delta(i) = log(mu(i)/qsat)
+      ! enddo ! vector
+
+
+      ! ***          There is no subgrid-scale condensation;        ***
+      ! ***   the scheme becomes equivalent to an "all-or-nothing"  ***
+      ! ***             large-scale condensation scheme.            ***
+
+
+
+      ! ***     Some condensation is produced at the subgrid-scale       ***
+      ! ***                                                              ***
+      ! ***       PDF = generalized log-normal distribution (GNO)        ***
+      ! ***   (k<0 because a lower bound is considered for the PDF)      ***
+      ! ***                                                              ***
+      ! ***  -> Determine x (the parameter k of the GNO PDF) such        ***
+      ! ***  that the contribution of subgrid-scale processes to         ***
+      ! ***  the in-cloud water content is equal to QSUB(K)              ***
+      ! ***  (equations (13), (14), (15) + Appendix B of the paper)      ***
+      ! ***                                                              ***
+      ! ***    Here, an iterative method is used for this purpose        ***
+      ! ***    (other numerical methods might be more efficient)         ***
+      ! ***                                                              ***
+      ! ***          NB: the "error function" is called ERF              ***
+      ! ***                 (ERF in double precision)                   ***
+
+
+      ! On commence par eliminer les cas pour lesquels on n'a pas
+      ! suffisamment d'eau nuageuse.
+
+      ! do i=1,klon ! vector
+
+      IF (qsub(i,k)<min_q) THEN
+        ptconv(i, k) = .FALSE.
+        ratqsc(i, k) = 0.
+        lconv(i) = .TRUE.
+
+        ! Rien on a deja initialise
+
+      ELSE
+
+        lconv(i) = .FALSE.
+        vmax(i) = vmax0
+
+        beta(i) = qsub(i, k)/mu(i) + exp(-min(0.0,delta(i)))
+
+        ! --  roots of equation v > vmax:
+
+        det = delta(i) + vmax(i)*vmax(i)
+        IF (det<=0.0) vmax(i) = vmax0 + 1.0
+        det = delta(i) + vmax(i)*vmax(i)
+
+        IF (det<=0.) THEN
+          xx(i) = -0.0001
+        ELSE
+          zx1 = -sqrt2*vmax(i)
+          zx2 = sqrt(1.0+delta(i)/(vmax(i)*vmax(i)))
+          xx1 = zx1*(1.0-zx2)
+          xx2 = zx1*(1.0+zx2)
+          xx(i) = 1.01*xx1
+          IF (xx1>=0.0) xx(i) = 0.5*xx2
+        END IF
+        IF (delta(i)<0.) xx(i) = -hsqrtlog_2
+
+      END IF
+
+    END DO ! vector
+
+    ! ----------------------------------------------------------------------
+    ! Debut des nmax iterations pour trouver la solution.
+    ! ----------------------------------------------------------------------
+
+    DO n = 1, nmax
+
+      DO i = 1, klon ! vector
+        IF (.NOT. lconv(i)) THEN
+
+          u = delta(i)/(xx(i)*sqrt2) + xx(i)/(2.*sqrt2)
+          v = delta(i)/(xx(i)*sqrt2) - xx(i)/(2.*sqrt2)
+          v2 = v*v
+
+          IF (v>vmax(i)) THEN
+
+            IF (abs(u)>vmax(i) .AND. delta(i)<0.) THEN
+
+              ! -- use asymptotic expression of erf for u and v large:
+              ! ( -> analytic solution for xx )
+              exdel = beta(i)*exp(delta(i))
+              aux(i) = 2.0*delta(i)*(1.-exdel)/(1.+exdel)
+              IF (aux(i)<0.) THEN
+                ! print*,'AUX(',i,',',k,')<0',aux(i),delta(i),beta(i)
+                aux(i) = 0.
+              END IF
+              xx(i) = -sqrt(aux(i))
+              block = exp(-v*v)/v/sqrtpi
+              dist = 0.0
+              fprime = 1.0
+
+            ELSE
+
+              ! -- erfv -> 1.0, use an asymptotic expression of erfv for v
+              ! large:
+
+              erfcu = 1.0 - erf(u)
+              ! !!! ATTENTION : rajout d'un seuil pour l'exponentiel
+              aux(i) = sqrtpi*erfcu*exp(min(v2,100.))
+              coeff = 1.0 - 0.5/(v2) + 0.75/(v2*v2)
+              block = coeff*exp(-v2)/v/sqrtpi
+              dist = v*aux(i)/coeff - beta(i)
+              fprime = 2.0/xx(i)*(v2)*(exp(-delta(i))-u*aux(i)/coeff)/coeff
+
+            END IF ! ABS(u)
+
+          ELSE
+
+            ! -- general case:
+
+            erfcu = 1.0 - erf(u)
+            erfcv = 1.0 - erf(v)
+            block = erfcv
+            dist = erfcu/erfcv - beta(i)
+            zu2 = u*u
+            zv2 = v2
+            IF (zu2>20. .OR. zv2>20.) THEN
+              ! print*,'ATTENTION !!! xx(',i,') =', xx(i)
+              ! print*,'ATTENTION !!! klon,ND,R,RS,QSUB,PTCONV,RATQSC,CLDF',
+              ! .klon,ND,R(i,k),RS(i,k),QSUB(i,k),PTCONV(i,k),RATQSC(i,k),
+              ! .CLDF(i,k)
+              ! print*,'ATTENTION !!! zu2 zv2 =',zu2(i),zv2(i)
+              zu2 = 20.
+              zv2 = 20.
+              fprime = 0.
+            ELSE
+              fprime = 2./sqrtpi/xx(i)/(erfcv*erfcv)* &
+                (erfcv*v*exp(-zu2)-erfcu*u*exp(-zv2))
+            END IF
+          END IF ! x
+
+          ! -- test numerical convergence:
+
+          ! if (beta(i).lt.1.e-10) then
+          ! print*,'avant test ',i,k,lconv(i),u(i),v(i),beta(i)
+          ! stop
+          ! endif
+          IF (abs(fprime)<1.E-11) THEN
+            ! print*,'avant test fprime<.e-11 '
+            ! s        ,i,k,lconv(i),u(i),v(i),beta(i),fprime(i)
+            ! print*,'klon,ND,R,RS,QSUB',
+            ! s        klon,ND,R(i,k),rs(i,k),qsub(i,k)
+            fprime = sign(1.E-11, fprime)
+          END IF
+
+
+          IF (abs(dist/beta(i))<epsilon) THEN
+            ! print*,'v-u **2',(v(i)-u(i))**2
+            ! print*,'exp v-u **2',exp((v(i)-u(i))**2)
+            ptconv(i, k) = .TRUE.
+            lconv(i) = .TRUE.
+            ! borne pour l'exponentielle
+            ratqsc(i, k) = min(2.*(v-u)*(v-u), 20.)
+            ratqsc(i, k) = sqrt(exp(ratqsc(i,k))-1.)
+            cldf(i, k) = 0.5*block
+          ELSE
+            xx(i) = xx(i) - dist/fprime
+          END IF
+          ! print*,'apres test ',i,k,lconv(i)
+
+        END IF ! lconv
+      END DO ! vector
+
+      ! ----------------------------------------------------------------------
+      ! Fin des nmax iterations pour trouver la solution.
+    END DO ! n
+    ! ----------------------------------------------------------------------
+
+
+  END DO
+  ! K
+  RETURN
+END SUBROUTINE clouds_gno
+
+
+
Index: DZ6/trunk/libf/phylmd/cltrac.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cltrac.F90	(revision 5267)
+++ 	(revision )
@@ -1,149 +1,0 @@
-!
-! $Id $
-!
-SUBROUTINE cltrac(dtime,coef,t,tr,flux,paprs,pplay,delp, &
-                  d_tr,d_tr_dry,flux_tr_dry)                    !jyg
-
-  USE dimphy
-  IMPLICIT NONE
-!======================================================================
-! Auteur(s): O. Boucher (LOA/LMD) date: 19961127
-!            inspire de clvent
-! Objet: diffusion verticale de traceurs avec flux fixe a la surface
-!        ou/et flux du type c-drag
-!
-! Arguments:
-!-----------
-! dtime.......input-R- intervalle du temps (en secondes)
-! coef........input-R- le coefficient d'echange (m**2/s) l>1
-! t...........input-R- temperature (K)
-! tr..........input-R- la q. de traceurs
-! flux........input-R- le flux de traceurs a la surface
-! paprs.......input-R- pression a inter-couche (Pa)
-! pplay.......input-R- pression au milieu de couche (Pa)
-! delp........input-R- epaisseur de couche (Pa)
-! cdrag.......input-R- cdrag pour le flux de surface (non active)
-! tr0.........input-R- traceurs a la surface ou dans l'ocean (non active)
-! d_tr........output-R- le changement de tr
-! d_tr_dry....output-R- le changement de tr du au depot sec (1st layer)
-! flux_tr_dry.output-R- depot sec
-!!! flux_tr..output-R- flux de tr
-!======================================================================
-  include "YOMCST.h"
-!
-! Entree
-! 
-  REAL,INTENT(IN)                        :: dtime
-  REAL,DIMENSION(klon,klev),INTENT(IN)   :: coef
-  REAL,DIMENSION(klon,klev),INTENT(IN)   :: t, tr
-  REAL,DIMENSION(klon),INTENT(IN)        :: flux !(at/s/m2)
-  REAL,DIMENSION(klon,klev+1),INTENT(IN) :: paprs 
-  REAL,DIMENSION(klon,klev),INTENT(IN)   :: pplay, delp
-!
-! Sorties
-!
-  REAL ,DIMENSION(klon,klev),INTENT(OUT) :: d_tr
-  REAL ,DIMENSION(klon),INTENT(OUT)       :: d_tr_dry          !jyg
-  REAL ,DIMENSION(klon),INTENT(OUT)       :: flux_tr_dry       !jyg
-!  REAL ,DIMENSION(klon,klev),INTENT(OUT) :: flux_tr
-!
-! Local
-! 
-  INTEGER                   :: i, k
-  REAL,DIMENSION(klon)      :: cdrag, tr0
-  REAL,DIMENSION(klon,klev) :: zx_ctr
-  REAL,DIMENSION(klon,klev) :: zx_dtr
-  REAL,DIMENSION(klon)      :: zx_buf
-  REAL,DIMENSION(klon,klev) :: zx_coef
-  REAL,DIMENSION(klon,klev) :: local_tr
-  REAL,DIMENSION(klon)      :: zx_alf1,zx_alf2,zx_flux
-
-!======================================================================
-
-  DO k = 1, klev
-     DO i = 1, klon
-        local_tr(i,k) = tr(i,k)
-     ENDDO
-  ENDDO
-
-!======================================================================
-
-  DO i = 1, klon
-     zx_alf1(i) = (paprs(i,1)-pplay(i,2))/(pplay(i,1)-pplay(i,2))
-     zx_alf2(i) = 1.0 - zx_alf1(i)
-     flux_tr_dry(i) = -flux(i)*dtime                              !jyg
-     zx_flux(i) =  flux_tr_dry(i)*RG                              !jyg
-!!     zx_flux(i) =  -flux(i)*dtime*RG                            !jyg
-! Pour le moment le flux est prescrit cdrag et zx_coef(1) vaut 0
-     cdrag(i) = 0.0 
-     tr0(i) = 0.0
-     zx_coef(i,1) = cdrag(i)*dtime*RG 
-     zx_ctr(i,1)=0.
-     zx_dtr(i,1)=0.
-  ENDDO
-
-!======================================================================
-
-  DO k = 2, klev
-     DO i = 1, klon
-        zx_coef(i,k) = coef(i,k)*RG/(pplay(i,k-1)-pplay(i,k))   &
-             *(paprs(i,k)*2/(t(i,k)+t(i,k-1))/RD)**2
-        zx_coef(i,k) = zx_coef(i,k)*dtime*RG  
-     ENDDO
-  ENDDO
-
-!======================================================================
-
-  DO i = 1, klon
-     zx_buf(i) = delp(i,1) + zx_coef(i,1)*zx_alf1(i) + zx_coef(i,2)
-     !
-     zx_ctr(i,2) = (local_tr(i,1)*delp(i,1)+                  &
-          zx_coef(i,1)*tr0(i)-zx_flux(i))/zx_buf(i)
-     !
-     zx_dtr(i,2) = (zx_coef(i,2)-zx_alf2(i)*zx_coef(i,1)) /   & 
-          zx_buf(i)
-     d_tr_dry(i) = -zx_flux(i)/zx_buf(i)                          !jyg
-  ENDDO
-
-  DO k = 3, klev
-     DO i = 1, klon
-        zx_buf(i) = delp(i,k-1) + zx_coef(i,k)      &
-             + zx_coef(i,k-1)*(1.-zx_dtr(i,k-1))
-        zx_ctr(i,k) = (local_tr(i,k-1)*delp(i,k-1)  & 
-             +zx_coef(i,k-1)*zx_ctr(i,k-1) )/zx_buf(i)
-        zx_dtr(i,k) = zx_coef(i,k)/zx_buf(i)
-     ENDDO
-  ENDDO
-
-  DO i = 1, klon
-     local_tr(i,klev) = ( local_tr(i,klev)*delp(i,klev) &
-          +zx_coef(i,klev)*zx_ctr(i,klev) )             &
-          / ( delp(i,klev) + zx_coef(i,klev)            &
-          -zx_coef(i,klev)*zx_dtr(i,klev) )
-  ENDDO
-
-  DO k = klev-1, 1, -1
-     DO i = 1, klon
-        local_tr(i,k) = zx_ctr(i,k+1) + zx_dtr(i,k+1)*local_tr(i,k+1)
-     ENDDO
-  ENDDO
-
-!======================================================================
-!== flux_tr est le flux de traceur (positif vers bas)
-!      DO i = 1, klon
-!         flux_tr(i,1) = zx_coef(i,1)/(RG*dtime)
-!      ENDDO
-!      DO k = 2, klev
-!      DO i = 1, klon
-!         flux_tr(i,k) = zx_coef(i,k)/(RG*dtime)
-!     .               * (local_tr(i,k)-local_tr(i,k-1))
-!      ENDDO
-!      ENDDO
-!======================================================================
-  DO k = 1, klev
-     DO i = 1, klon
-        d_tr(i,k) = local_tr(i,k) - tr(i,k)
-     ENDDO
-  ENDDO
-  
-END SUBROUTINE cltrac
Index: /LMDZ6/trunk/libf/phylmd/cltrac.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cltrac.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/cltrac.f90	(revision 5268)
@@ -0,0 +1,149 @@
+!
+! $Id $
+!
+SUBROUTINE cltrac(dtime,coef,t,tr,flux,paprs,pplay,delp, &
+                  d_tr,d_tr_dry,flux_tr_dry)                    !jyg
+
+  USE dimphy
+  IMPLICIT NONE
+!======================================================================
+! Auteur(s): O. Boucher (LOA/LMD) date: 19961127
+!            inspire de clvent
+! Objet: diffusion verticale de traceurs avec flux fixe a la surface
+!        ou/et flux du type c-drag
+!
+! Arguments:
+!-----------
+! dtime.......input-R- intervalle du temps (en secondes)
+! coef........input-R- le coefficient d'echange (m**2/s) l>1
+! t...........input-R- temperature (K)
+! tr..........input-R- la q. de traceurs
+! flux........input-R- le flux de traceurs a la surface
+! paprs.......input-R- pression a inter-couche (Pa)
+! pplay.......input-R- pression au milieu de couche (Pa)
+! delp........input-R- epaisseur de couche (Pa)
+! cdrag.......input-R- cdrag pour le flux de surface (non active)
+! tr0.........input-R- traceurs a la surface ou dans l'ocean (non active)
+! d_tr........output-R- le changement de tr
+! d_tr_dry....output-R- le changement de tr du au depot sec (1st layer)
+! flux_tr_dry.output-R- depot sec
+!!! flux_tr..output-R- flux de tr
+!======================================================================
+  include "YOMCST.h"
+!
+! Entree
+! 
+  REAL,INTENT(IN)                        :: dtime
+  REAL,DIMENSION(klon,klev),INTENT(IN)   :: coef
+  REAL,DIMENSION(klon,klev),INTENT(IN)   :: t, tr
+  REAL,DIMENSION(klon),INTENT(IN)        :: flux !(at/s/m2)
+  REAL,DIMENSION(klon,klev+1),INTENT(IN) :: paprs 
+  REAL,DIMENSION(klon,klev),INTENT(IN)   :: pplay, delp
+!
+! Sorties
+!
+  REAL ,DIMENSION(klon,klev),INTENT(OUT) :: d_tr
+  REAL ,DIMENSION(klon),INTENT(OUT)       :: d_tr_dry          !jyg
+  REAL ,DIMENSION(klon),INTENT(OUT)       :: flux_tr_dry       !jyg
+!  REAL ,DIMENSION(klon,klev),INTENT(OUT) :: flux_tr
+!
+! Local
+! 
+  INTEGER                   :: i, k
+  REAL,DIMENSION(klon)      :: cdrag, tr0
+  REAL,DIMENSION(klon,klev) :: zx_ctr
+  REAL,DIMENSION(klon,klev) :: zx_dtr
+  REAL,DIMENSION(klon)      :: zx_buf
+  REAL,DIMENSION(klon,klev) :: zx_coef
+  REAL,DIMENSION(klon,klev) :: local_tr
+  REAL,DIMENSION(klon)      :: zx_alf1,zx_alf2,zx_flux
+
+!======================================================================
+
+  DO k = 1, klev
+     DO i = 1, klon
+        local_tr(i,k) = tr(i,k)
+     ENDDO
+  ENDDO
+
+!======================================================================
+
+  DO i = 1, klon
+     zx_alf1(i) = (paprs(i,1)-pplay(i,2))/(pplay(i,1)-pplay(i,2))
+     zx_alf2(i) = 1.0 - zx_alf1(i)
+     flux_tr_dry(i) = -flux(i)*dtime                              !jyg
+     zx_flux(i) =  flux_tr_dry(i)*RG                              !jyg
+!!     zx_flux(i) =  -flux(i)*dtime*RG                            !jyg
+! Pour le moment le flux est prescrit cdrag et zx_coef(1) vaut 0
+     cdrag(i) = 0.0 
+     tr0(i) = 0.0
+     zx_coef(i,1) = cdrag(i)*dtime*RG 
+     zx_ctr(i,1)=0.
+     zx_dtr(i,1)=0.
+  ENDDO
+
+!======================================================================
+
+  DO k = 2, klev
+     DO i = 1, klon
+        zx_coef(i,k) = coef(i,k)*RG/(pplay(i,k-1)-pplay(i,k))   &
+             *(paprs(i,k)*2/(t(i,k)+t(i,k-1))/RD)**2
+        zx_coef(i,k) = zx_coef(i,k)*dtime*RG  
+     ENDDO
+  ENDDO
+
+!======================================================================
+
+  DO i = 1, klon
+     zx_buf(i) = delp(i,1) + zx_coef(i,1)*zx_alf1(i) + zx_coef(i,2)
+     !
+     zx_ctr(i,2) = (local_tr(i,1)*delp(i,1)+                  &
+          zx_coef(i,1)*tr0(i)-zx_flux(i))/zx_buf(i)
+     !
+     zx_dtr(i,2) = (zx_coef(i,2)-zx_alf2(i)*zx_coef(i,1)) /   & 
+          zx_buf(i)
+     d_tr_dry(i) = -zx_flux(i)/zx_buf(i)                          !jyg
+  ENDDO
+
+  DO k = 3, klev
+     DO i = 1, klon
+        zx_buf(i) = delp(i,k-1) + zx_coef(i,k)      &
+             + zx_coef(i,k-1)*(1.-zx_dtr(i,k-1))
+        zx_ctr(i,k) = (local_tr(i,k-1)*delp(i,k-1)  & 
+             +zx_coef(i,k-1)*zx_ctr(i,k-1) )/zx_buf(i)
+        zx_dtr(i,k) = zx_coef(i,k)/zx_buf(i)
+     ENDDO
+  ENDDO
+
+  DO i = 1, klon
+     local_tr(i,klev) = ( local_tr(i,klev)*delp(i,klev) &
+          +zx_coef(i,klev)*zx_ctr(i,klev) )             &
+          / ( delp(i,klev) + zx_coef(i,klev)            &
+          -zx_coef(i,klev)*zx_dtr(i,klev) )
+  ENDDO
+
+  DO k = klev-1, 1, -1
+     DO i = 1, klon
+        local_tr(i,k) = zx_ctr(i,k+1) + zx_dtr(i,k+1)*local_tr(i,k+1)
+     ENDDO
+  ENDDO
+
+!======================================================================
+!== flux_tr est le flux de traceur (positif vers bas)
+!      DO i = 1, klon
+!         flux_tr(i,1) = zx_coef(i,1)/(RG*dtime)
+!      ENDDO
+!      DO k = 2, klev
+!      DO i = 1, klon
+!         flux_tr(i,k) = zx_coef(i,k)/(RG*dtime)
+!     .               * (local_tr(i,k)-local_tr(i,k-1))
+!      ENDDO
+!      ENDDO
+!======================================================================
+  DO k = 1, klev
+     DO i = 1, klon
+        d_tr(i,k) = local_tr(i,k) - tr(i,k)
+     ENDDO
+  ENDDO
+  
+END SUBROUTINE cltrac
Index: DZ6/trunk/libf/phylmd/cltracrn.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cltracrn.F90	(revision 5267)
+++ 	(revision )
@@ -1,288 +1,0 @@
-!$Id $
-
-SUBROUTINE cltracrn( itr, dtime,u1lay, v1lay, &
-     cdrag,coef,t,ftsol,pctsrf,               &
-     tr,trs,paprs,pplay,delp,                 &
-     masktr,fshtr,hsoltr,tautr,vdeptr,        &
-     lat,d_tr,d_trs )
-  
-  USE dimphy
-  USE traclmdz_mod, ONLY : id_rn, id_pb
-  USE indice_sol_mod
-
-  IMPLICIT NONE
-!======================================================================
-! Auteur(s): Alex/LMD) date:  fev 99
-!            inspire de clqh + clvent
-! Objet: diffusion verticale de traceurs avec quantite de traceur ds 
-!        le sol ( reservoir de sol de radon ) 
-!        
-! note : pour l'instant le traceur dans le sol et le flux sont
-!        calcules mais ils ne servent que de diagnostiques
-!        seule la tendance sur le traceur est sortie (d_tr)
-!---------------------------------------------------------------------
-! Arguments:
-! itr......input-R-  le type de traceur : id_rn(radon), id_pb(plomb)
-! dtime....input-R-  intervalle du temps (en secondes) ~ pdtphys
-! u1lay....input-R-  vent u de la premiere couche (m/s)
-! v1lay....input-R-  vent v de la premiere couche (m/s)
-! cdrag....input-R-  cdrag
-! coef.....input-R-  le coefficient d'echange (m**2/s) l>1, valable uniquement pour k entre 2 et klev
-! t........input-R-  temperature (K)
-! paprs....input-R-  pression a inter-couche (Pa)
-! pplay....input-R-  pression au milieu de couche (Pa)
-! delp.....input-R-  epaisseur de couche (Pa)
-! ftsol....input-R-  temperature du sol (en Kelvin)
-! tr.......input-R-  traceurs
-! trs......input-R-  traceurs dans le sol
-! masktr...input-R-  Masque reservoir de sol traceur (1 = reservoir)
-! fshtr....input-R-  Flux surfacique de production dans le sol
-! tautr....input-R-  Constante de decroissance du traceur
-! vdeptr...input-R-  Vitesse de depot sec dans la couche brownienne
-! hsoltr...input-R-  Epaisseur equivalente du reservoir de sol
-! lat......input-R-  latitude en degree
-! d_tr.....output-R- le changement de "tr"
-! d_trs....output-R- le changement de "trs"
-!======================================================================
-  include "YOMCST.h"
-!
-!Entrees
-  INTEGER,INTENT(IN)                     :: itr
-  REAL,INTENT(IN)                        :: dtime
-  REAL,DIMENSION(klon),INTENT(IN)        :: u1lay, v1lay
-  REAL,DIMENSION(klon),INTENT(IN)        :: cdrag
-  REAL,DIMENSION(klon,klev),INTENT(IN)   :: coef, t
-  REAL,DIMENSION(klon,nbsrf),INTENT(IN)  :: ftsol, pctsrf 
-  REAL,DIMENSION(klon,klev),INTENT(IN)   :: tr 
-  REAL,DIMENSION(klon),INTENT(IN)        :: trs
-  REAL,DIMENSION(klon,klev+1),INTENT(IN) :: paprs 
-  REAL,DIMENSION(klon,klev),INTENT(IN)   :: pplay, delp
-  REAL,DIMENSION(klon),INTENT(IN)        :: masktr 
-  REAL,DIMENSION(klon),INTENT(IN)        :: fshtr 
-  REAL,INTENT(IN)                        :: hsoltr
-  REAL,INTENT(IN)                        :: tautr
-  REAL,INTENT(IN)                        :: vdeptr
-  REAL,DIMENSION(klon),INTENT(IN)        :: lat   
-
-!Sorties
-  REAL,DIMENSION(klon,klev),INTENT(OUT) :: d_tr
-  REAL,DIMENSION(klon),INTENT(OUT) :: d_trs  ! (diagnostic) traceur ds le sol
-
-!Locales
-  REAL,DIMENSION(klon,klev) :: flux_tr  ! (diagnostic) flux de traceur
-  INTEGER                   :: i, k, n, l
-  REAL,DIMENSION(klon)      :: rotrhi
-  REAL,DIMENSION(klon,klev) :: zx_coef
-  REAL,DIMENSION(klon)      :: zx_buf
-  REAL,DIMENSION(klon,klev) :: zx_ctr
-  REAL,DIMENSION(klon,klev) :: zx_dtr
-  REAL,DIMENSION(klon)      :: zx_trs
-  REAL                      :: zx_a, zx_b
-  
-  REAL,DIMENSION(klon,klev) :: local_tr
-  REAL,DIMENSION(klon)      :: local_trs
-  REAL,DIMENSION(klon)      :: zts      ! champ de temperature du sol
-  REAL,DIMENSION(klon)      :: zx_alpha1, zx_alpha2
-!======================================================================
-!AA Pour l'instant les 4 types de surface ne sont pas pris en compte
-!AA On fabrique avec zts un champ de temperature de sol  
-!AA que le pondere par la fraction de nature de sol.
- 
-  DO i = 1,klon
-     zts(i) = 0. 
-  ENDDO
-
-  DO n=1,nbsrf
-     DO i = 1,klon
-        zts(i) = zts(i) + ftsol(i,n)*pctsrf(i,n)
-     ENDDO
-  ENDDO
-
-  DO i = 1,klon
-     rotrhi(i) = RD * zts(i) / hsoltr 
-  ENDDO
-
-  DO k = 1, klev
-     DO i = 1, klon
-        local_tr(i,k) = tr(i,k)
-     ENDDO
-  ENDDO
-
-  DO i = 1, klon
-     local_trs(i) = trs(i)
-  ENDDO
-!======================================================================
-!AA   Attention si dans clmain zx_alf1(i) = 1.0 
-!AA   Il doit y avoir coherence (dc la meme chose ici)
-
-  DO i = 1, klon
-!AA         zx_alpha1(i) = (paprs(i,1)-pplay(i,2))/(pplay(i,1)-pplay(i,2))
-     zx_alpha1(i) = 1.0
-     zx_alpha2(i) = 1.0 - zx_alpha1(i)
-  ENDDO
-!======================================================================
-  DO i = 1, klon
-     zx_coef(i,1) = cdrag(i)*(1.0+SQRT(u1lay(i)**2+v1lay(i)**2)) &
-          *pplay(i,1)/(RD*t(i,1))
-     zx_coef(i,1) = zx_coef(i,1) * dtime*RG
-  ENDDO
-
-  DO k = 2, klev
-     DO i = 1, klon
-        zx_coef(i,k) = coef(i,k)*RG/(pplay(i,k-1)-pplay(i,k)) &
-             *(paprs(i,k)*2/(t(i,k)+t(i,k-1))/RD)**2
-        zx_coef(i,k) = zx_coef(i,k) * dtime*RG
-     ENDDO
-  ENDDO
-!======================================================================
-  DO i = 1, klon
-     zx_buf(i)      = delp(i,klev) + zx_coef(i,klev)
-     zx_ctr(i,klev) = local_tr(i,klev)*delp(i,klev)/zx_buf(i)
-     zx_dtr(i,klev) = zx_coef(i,klev) / zx_buf(i)
-  ENDDO
-
-  DO l = klev-1, 2 , -1
-     DO i = 1, klon
-        zx_buf(i) = delp(i,l)+zx_coef(i,l)      &
-             +zx_coef(i,l+1)*(1.-zx_dtr(i,l+1))
- 
-        zx_ctr(i,l) = ( local_tr(i,l)*delp(i,l) &
-             + zx_coef(i,l+1)*zx_ctr(i,l+1) )/zx_buf(i)
-        zx_dtr(i,l) = zx_coef(i,l) / zx_buf(i)
-     ENDDO
-  ENDDO
-
-  DO i = 1, klon
-     zx_buf(i) = delp(i,1) + zx_coef(i,2)*(1.-zx_dtr(i,2))  &
-          + masktr(i) * zx_coef(i,1)                        &
-          *( zx_alpha1(i)+zx_alpha2(i)*zx_dtr(i,2) )
-
-     zx_ctr(i,1) = ( local_tr(i,1)*delp(i,1)                &
-          + zx_ctr(i,2)                                     &
-          *(zx_coef(i,2)                                    &
-          - masktr(i) * zx_coef(i,1)                        &
-          *zx_alpha2(i) ) ) / zx_buf(i)
-     zx_dtr(i,1) = masktr(i) * zx_coef(i,1) / zx_buf(i)
-  ENDDO
-!======================================================================
-! Calculer d'abord local_trs nouvelle quantite dans le reservoir
-! de sol
-!=====================================================================
-
-  DO i = 1, klon
-!-------------------------
-! Au dessus des continents
-!--
-! Le pb peut se deposer partout : vdeptr = 10-3 m/s
-! Le Rn est traiter commme une couche Brownienne puisque vdeptr = 0.
-!-------------------------------------------------------------------
-     IF ( NINT(masktr(i)) .EQ. 1 ) THEN
-        zx_trs(i) = local_trs(i)
-        zx_a = zx_trs(i)                                           &
-             +fshtr(i)*dtime*rotrhi(i)                             &
-             +rotrhi(i)*masktr(i)*zx_coef(i,1)/RG                  &
-             *(zx_ctr(i,1)*(zx_alpha1(i)+zx_alpha2(i)*zx_dtr(i,2)) &
-             +zx_alpha2(i)*zx_ctr(i,2))
-! Pour l'instant, pour aller vite, le depot sec est traite comme une decroissance
-        zx_b = 1. + rotrhi(i)*masktr(i)*zx_coef(i,1)/RG            &
-             * (1.-zx_dtr(i,1)                                     &
-             *(zx_alpha1(i)+zx_alpha2(i)*zx_dtr(i,2)))             &
-             + dtime / tautr                                       & 
-             + dtime * vdeptr / hsoltr 
-        zx_trs(i) = zx_a / zx_b
-        local_trs(i) = zx_trs(i)
-     ENDIF
-!--------------------------------------------------------
-! Si on est entre 60N et 70N on divise par 2 l'emanation
-!--------------------------------------------------------
-
-     IF ( (itr.eq.id_rn.AND.NINT(masktr(i)).EQ.1.AND.lat(i).GE.60..AND.lat(i).LE.70.).OR.      &
-          (itr.eq.id_pb.AND.NINT(masktr(i)).EQ.1.AND.lat(i).GE.60..AND.lat(i).LE.70.) ) THEN
-        zx_trs(i) = local_trs(i)
-        zx_a = zx_trs(i)                                           &
-             +(fshtr(i)/2.)*dtime*rotrhi(i)                        & 
-             +rotrhi(i)*masktr(i)*zx_coef(i,1)/RG                  &
-             *(zx_ctr(i,1)*(zx_alpha1(i)+zx_alpha2(i)*zx_dtr(i,2)) &
-             +zx_alpha2(i)*zx_ctr(i,2))
-        !
-        zx_b = 1. + rotrhi(i)*masktr(i)*zx_coef(i,1)/RG  &
-             * (1.-zx_dtr(i,1)                           &
-             *(zx_alpha1(i)+zx_alpha2(i)*zx_dtr(i,2)))   &
-             + dtime / tautr                             &
-             + dtime * vdeptr / hsoltr
-        ! 
-        zx_trs(i) = zx_a / zx_b
-        local_trs(i) = zx_trs(i)
-     ENDIF
-
-!----------------------------------------------
-! Au dessus des oceans et aux hautes latitudes
-!--
-! au dessous de -60S  pas d'emission de radon au dessus 
-! des oceans et des continents
-!---------------------------------------------------------------
-
-     IF ( (itr.EQ.id_rn.AND.NINT(masktr(i)).EQ.0).OR.       &
-          (itr.EQ.id_rn.AND.NINT(masktr(i)).EQ.1.AND.lat(i).LT.-60.)) THEN
-        zx_trs(i) = 0.
-        local_trs(i) = 0.
-     END IF
-!--
-! au dessus de 70 N pas d'emission de radon au dessus 
-! des oceans et des continents
-!--------------------------------------------------------------
-     IF ( (itr.EQ.id_rn.AND.NINT(masktr(i)).EQ.0).OR.    &
-          (itr.EQ.id_rn.AND.NINT(masktr(i)).EQ.1.AND.lat(i).GT.70.)) THEN
-        zx_trs(i) = 0.
-        local_trs(i) = 0.
-     END IF
-!---------------------------------------------
-! Au dessus des oceans la source est nulle
-!--------------------------------------------
-
-     IF (itr.eq.id_rn.AND.NINT(masktr(i)).EQ.0) THEN
-        zx_trs(i) = 0.
-        local_trs(i) = 0.
-     END IF
-
-  ENDDO    ! sur le i=1,klon
-!
-!======================================================================
-! Une fois on a zx_trs, on peut faire l'iteration 
-!====================================================================== 
-
-  DO i = 1, klon
-     local_tr(i,1) = zx_ctr(i,1)+zx_dtr(i,1)*zx_trs(i)
-  ENDDO
-  DO l = 2, klev
-     DO i = 1, klon
-        local_tr(i,l) = zx_ctr(i,l) + zx_dtr(i,l)*local_tr(i,l-1)
-     ENDDO
-  ENDDO
-!======================================================================
-! Calcul du flux de traceur (flux_tr): UA/(m**2 s)
-!======================================================================
-  DO i = 1, klon
-     flux_tr(i,1) = masktr(i)*zx_coef(i,1)/RG                      &
-          * (zx_alpha1(i)*local_tr(i,1)+zx_alpha2(i)*local_tr(i,2) &
-          -zx_trs(i)) / dtime
-  ENDDO
-  DO l = 2, klev
-     DO i = 1, klon
-        flux_tr(i,l) = zx_coef(i,l)/RG                    &
-             * (local_tr(i,l)-local_tr(i,l-1)) / dtime
-     ENDDO
-  ENDDO
-!======================================================================
-! Calcul des tendances du traceur ds le sol et dans l'atmosphere
-!======================================================================
-  DO l = 1, klev
-     DO i = 1, klon
-        d_tr(i,l) = local_tr(i,l) - tr(i,l)
-     ENDDO
-  ENDDO
-  DO i = 1, klon
-     d_trs(i) = local_trs(i) - trs(i)
-  ENDDO
-
-END SUBROUTINE cltracrn
Index: /LMDZ6/trunk/libf/phylmd/cltracrn.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cltracrn.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/cltracrn.f90	(revision 5268)
@@ -0,0 +1,288 @@
+!$Id $
+
+SUBROUTINE cltracrn( itr, dtime,u1lay, v1lay, &
+     cdrag,coef,t,ftsol,pctsrf,               &
+     tr,trs,paprs,pplay,delp,                 &
+     masktr,fshtr,hsoltr,tautr,vdeptr,        &
+     lat,d_tr,d_trs )
+  
+  USE dimphy
+  USE traclmdz_mod, ONLY : id_rn, id_pb
+  USE indice_sol_mod
+
+  IMPLICIT NONE
+!======================================================================
+! Auteur(s): Alex/LMD) date:  fev 99
+!            inspire de clqh + clvent
+! Objet: diffusion verticale de traceurs avec quantite de traceur ds 
+!        le sol ( reservoir de sol de radon ) 
+!        
+! note : pour l'instant le traceur dans le sol et le flux sont
+!        calcules mais ils ne servent que de diagnostiques
+!        seule la tendance sur le traceur est sortie (d_tr)
+!---------------------------------------------------------------------
+! Arguments:
+! itr......input-R-  le type de traceur : id_rn(radon), id_pb(plomb)
+! dtime....input-R-  intervalle du temps (en secondes) ~ pdtphys
+! u1lay....input-R-  vent u de la premiere couche (m/s)
+! v1lay....input-R-  vent v de la premiere couche (m/s)
+! cdrag....input-R-  cdrag
+! coef.....input-R-  le coefficient d'echange (m**2/s) l>1, valable uniquement pour k entre 2 et klev
+! t........input-R-  temperature (K)
+! paprs....input-R-  pression a inter-couche (Pa)
+! pplay....input-R-  pression au milieu de couche (Pa)
+! delp.....input-R-  epaisseur de couche (Pa)
+! ftsol....input-R-  temperature du sol (en Kelvin)
+! tr.......input-R-  traceurs
+! trs......input-R-  traceurs dans le sol
+! masktr...input-R-  Masque reservoir de sol traceur (1 = reservoir)
+! fshtr....input-R-  Flux surfacique de production dans le sol
+! tautr....input-R-  Constante de decroissance du traceur
+! vdeptr...input-R-  Vitesse de depot sec dans la couche brownienne
+! hsoltr...input-R-  Epaisseur equivalente du reservoir de sol
+! lat......input-R-  latitude en degree
+! d_tr.....output-R- le changement de "tr"
+! d_trs....output-R- le changement de "trs"
+!======================================================================
+  include "YOMCST.h"
+!
+!Entrees
+  INTEGER,INTENT(IN)                     :: itr
+  REAL,INTENT(IN)                        :: dtime
+  REAL,DIMENSION(klon),INTENT(IN)        :: u1lay, v1lay
+  REAL,DIMENSION(klon),INTENT(IN)        :: cdrag
+  REAL,DIMENSION(klon,klev),INTENT(IN)   :: coef, t
+  REAL,DIMENSION(klon,nbsrf),INTENT(IN)  :: ftsol, pctsrf 
+  REAL,DIMENSION(klon,klev),INTENT(IN)   :: tr 
+  REAL,DIMENSION(klon),INTENT(IN)        :: trs
+  REAL,DIMENSION(klon,klev+1),INTENT(IN) :: paprs 
+  REAL,DIMENSION(klon,klev),INTENT(IN)   :: pplay, delp
+  REAL,DIMENSION(klon),INTENT(IN)        :: masktr 
+  REAL,DIMENSION(klon),INTENT(IN)        :: fshtr 
+  REAL,INTENT(IN)                        :: hsoltr
+  REAL,INTENT(IN)                        :: tautr
+  REAL,INTENT(IN)                        :: vdeptr
+  REAL,DIMENSION(klon),INTENT(IN)        :: lat   
+
+!Sorties
+  REAL,DIMENSION(klon,klev),INTENT(OUT) :: d_tr
+  REAL,DIMENSION(klon),INTENT(OUT) :: d_trs  ! (diagnostic) traceur ds le sol
+
+!Locales
+  REAL,DIMENSION(klon,klev) :: flux_tr  ! (diagnostic) flux de traceur
+  INTEGER                   :: i, k, n, l
+  REAL,DIMENSION(klon)      :: rotrhi
+  REAL,DIMENSION(klon,klev) :: zx_coef
+  REAL,DIMENSION(klon)      :: zx_buf
+  REAL,DIMENSION(klon,klev) :: zx_ctr
+  REAL,DIMENSION(klon,klev) :: zx_dtr
+  REAL,DIMENSION(klon)      :: zx_trs
+  REAL                      :: zx_a, zx_b
+  
+  REAL,DIMENSION(klon,klev) :: local_tr
+  REAL,DIMENSION(klon)      :: local_trs
+  REAL,DIMENSION(klon)      :: zts      ! champ de temperature du sol
+  REAL,DIMENSION(klon)      :: zx_alpha1, zx_alpha2
+!======================================================================
+!AA Pour l'instant les 4 types de surface ne sont pas pris en compte
+!AA On fabrique avec zts un champ de temperature de sol  
+!AA que le pondere par la fraction de nature de sol.
+ 
+  DO i = 1,klon
+     zts(i) = 0. 
+  ENDDO
+
+  DO n=1,nbsrf
+     DO i = 1,klon
+        zts(i) = zts(i) + ftsol(i,n)*pctsrf(i,n)
+     ENDDO
+  ENDDO
+
+  DO i = 1,klon
+     rotrhi(i) = RD * zts(i) / hsoltr 
+  ENDDO
+
+  DO k = 1, klev
+     DO i = 1, klon
+        local_tr(i,k) = tr(i,k)
+     ENDDO
+  ENDDO
+
+  DO i = 1, klon
+     local_trs(i) = trs(i)
+  ENDDO
+!======================================================================
+!AA   Attention si dans clmain zx_alf1(i) = 1.0 
+!AA   Il doit y avoir coherence (dc la meme chose ici)
+
+  DO i = 1, klon
+!AA         zx_alpha1(i) = (paprs(i,1)-pplay(i,2))/(pplay(i,1)-pplay(i,2))
+     zx_alpha1(i) = 1.0
+     zx_alpha2(i) = 1.0 - zx_alpha1(i)
+  ENDDO
+!======================================================================
+  DO i = 1, klon
+     zx_coef(i,1) = cdrag(i)*(1.0+SQRT(u1lay(i)**2+v1lay(i)**2)) &
+          *pplay(i,1)/(RD*t(i,1))
+     zx_coef(i,1) = zx_coef(i,1) * dtime*RG
+  ENDDO
+
+  DO k = 2, klev
+     DO i = 1, klon
+        zx_coef(i,k) = coef(i,k)*RG/(pplay(i,k-1)-pplay(i,k)) &
+             *(paprs(i,k)*2/(t(i,k)+t(i,k-1))/RD)**2
+        zx_coef(i,k) = zx_coef(i,k) * dtime*RG
+     ENDDO
+  ENDDO
+!======================================================================
+  DO i = 1, klon
+     zx_buf(i)      = delp(i,klev) + zx_coef(i,klev)
+     zx_ctr(i,klev) = local_tr(i,klev)*delp(i,klev)/zx_buf(i)
+     zx_dtr(i,klev) = zx_coef(i,klev) / zx_buf(i)
+  ENDDO
+
+  DO l = klev-1, 2 , -1
+     DO i = 1, klon
+        zx_buf(i) = delp(i,l)+zx_coef(i,l)      &
+             +zx_coef(i,l+1)*(1.-zx_dtr(i,l+1))
+ 
+        zx_ctr(i,l) = ( local_tr(i,l)*delp(i,l) &
+             + zx_coef(i,l+1)*zx_ctr(i,l+1) )/zx_buf(i)
+        zx_dtr(i,l) = zx_coef(i,l) / zx_buf(i)
+     ENDDO
+  ENDDO
+
+  DO i = 1, klon
+     zx_buf(i) = delp(i,1) + zx_coef(i,2)*(1.-zx_dtr(i,2))  &
+          + masktr(i) * zx_coef(i,1)                        &
+          *( zx_alpha1(i)+zx_alpha2(i)*zx_dtr(i,2) )
+
+     zx_ctr(i,1) = ( local_tr(i,1)*delp(i,1)                &
+          + zx_ctr(i,2)                                     &
+          *(zx_coef(i,2)                                    &
+          - masktr(i) * zx_coef(i,1)                        &
+          *zx_alpha2(i) ) ) / zx_buf(i)
+     zx_dtr(i,1) = masktr(i) * zx_coef(i,1) / zx_buf(i)
+  ENDDO
+!======================================================================
+! Calculer d'abord local_trs nouvelle quantite dans le reservoir
+! de sol
+!=====================================================================
+
+  DO i = 1, klon
+!-------------------------
+! Au dessus des continents
+!--
+! Le pb peut se deposer partout : vdeptr = 10-3 m/s
+! Le Rn est traiter commme une couche Brownienne puisque vdeptr = 0.
+!-------------------------------------------------------------------
+     IF ( NINT(masktr(i)) .EQ. 1 ) THEN
+        zx_trs(i) = local_trs(i)
+        zx_a = zx_trs(i)                                           &
+             +fshtr(i)*dtime*rotrhi(i)                             &
+             +rotrhi(i)*masktr(i)*zx_coef(i,1)/RG                  &
+             *(zx_ctr(i,1)*(zx_alpha1(i)+zx_alpha2(i)*zx_dtr(i,2)) &
+             +zx_alpha2(i)*zx_ctr(i,2))
+! Pour l'instant, pour aller vite, le depot sec est traite comme une decroissance
+        zx_b = 1. + rotrhi(i)*masktr(i)*zx_coef(i,1)/RG            &
+             * (1.-zx_dtr(i,1)                                     &
+             *(zx_alpha1(i)+zx_alpha2(i)*zx_dtr(i,2)))             &
+             + dtime / tautr                                       & 
+             + dtime * vdeptr / hsoltr 
+        zx_trs(i) = zx_a / zx_b
+        local_trs(i) = zx_trs(i)
+     ENDIF
+!--------------------------------------------------------
+! Si on est entre 60N et 70N on divise par 2 l'emanation
+!--------------------------------------------------------
+
+     IF ( (itr.eq.id_rn.AND.NINT(masktr(i)).EQ.1.AND.lat(i).GE.60..AND.lat(i).LE.70.).OR.      &
+          (itr.eq.id_pb.AND.NINT(masktr(i)).EQ.1.AND.lat(i).GE.60..AND.lat(i).LE.70.) ) THEN
+        zx_trs(i) = local_trs(i)
+        zx_a = zx_trs(i)                                           &
+             +(fshtr(i)/2.)*dtime*rotrhi(i)                        & 
+             +rotrhi(i)*masktr(i)*zx_coef(i,1)/RG                  &
+             *(zx_ctr(i,1)*(zx_alpha1(i)+zx_alpha2(i)*zx_dtr(i,2)) &
+             +zx_alpha2(i)*zx_ctr(i,2))
+        !
+        zx_b = 1. + rotrhi(i)*masktr(i)*zx_coef(i,1)/RG  &
+             * (1.-zx_dtr(i,1)                           &
+             *(zx_alpha1(i)+zx_alpha2(i)*zx_dtr(i,2)))   &
+             + dtime / tautr                             &
+             + dtime * vdeptr / hsoltr
+        ! 
+        zx_trs(i) = zx_a / zx_b
+        local_trs(i) = zx_trs(i)
+     ENDIF
+
+!----------------------------------------------
+! Au dessus des oceans et aux hautes latitudes
+!--
+! au dessous de -60S  pas d'emission de radon au dessus 
+! des oceans et des continents
+!---------------------------------------------------------------
+
+     IF ( (itr.EQ.id_rn.AND.NINT(masktr(i)).EQ.0).OR.       &
+          (itr.EQ.id_rn.AND.NINT(masktr(i)).EQ.1.AND.lat(i).LT.-60.)) THEN
+        zx_trs(i) = 0.
+        local_trs(i) = 0.
+     END IF
+!--
+! au dessus de 70 N pas d'emission de radon au dessus 
+! des oceans et des continents
+!--------------------------------------------------------------
+     IF ( (itr.EQ.id_rn.AND.NINT(masktr(i)).EQ.0).OR.    &
+          (itr.EQ.id_rn.AND.NINT(masktr(i)).EQ.1.AND.lat(i).GT.70.)) THEN
+        zx_trs(i) = 0.
+        local_trs(i) = 0.
+     END IF
+!---------------------------------------------
+! Au dessus des oceans la source est nulle
+!--------------------------------------------
+
+     IF (itr.eq.id_rn.AND.NINT(masktr(i)).EQ.0) THEN
+        zx_trs(i) = 0.
+        local_trs(i) = 0.
+     END IF
+
+  ENDDO    ! sur le i=1,klon
+!
+!======================================================================
+! Une fois on a zx_trs, on peut faire l'iteration 
+!====================================================================== 
+
+  DO i = 1, klon
+     local_tr(i,1) = zx_ctr(i,1)+zx_dtr(i,1)*zx_trs(i)
+  ENDDO
+  DO l = 2, klev
+     DO i = 1, klon
+        local_tr(i,l) = zx_ctr(i,l) + zx_dtr(i,l)*local_tr(i,l-1)
+     ENDDO
+  ENDDO
+!======================================================================
+! Calcul du flux de traceur (flux_tr): UA/(m**2 s)
+!======================================================================
+  DO i = 1, klon
+     flux_tr(i,1) = masktr(i)*zx_coef(i,1)/RG                      &
+          * (zx_alpha1(i)*local_tr(i,1)+zx_alpha2(i)*local_tr(i,2) &
+          -zx_trs(i)) / dtime
+  ENDDO
+  DO l = 2, klev
+     DO i = 1, klon
+        flux_tr(i,l) = zx_coef(i,l)/RG                    &
+             * (local_tr(i,l)-local_tr(i,l-1)) / dtime
+     ENDDO
+  ENDDO
+!======================================================================
+! Calcul des tendances du traceur ds le sol et dans l'atmosphere
+!======================================================================
+  DO l = 1, klev
+     DO i = 1, klon
+        d_tr(i,l) = local_tr(i,l) - tr(i,l)
+     ENDDO
+  ENDDO
+  DO i = 1, klon
+     d_trs(i) = local_trs(i) - trs(i)
+  ENDDO
+
+END SUBROUTINE cltracrn
Index: DZ6/trunk/libf/phylmd/cmp_seri_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cmp_seri_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,156 +1,0 @@
-!
-! $Id:  ??? $
-!
-MODULE cmp_seri_mod
-  !======================================================================
-  ! to check if the x_seri vaariables have changed
-  !
-  !======================================================================
-
-  REAL,SAVE,ALLOCATABLE ::  u_prev(:,:), v_prev(:,:), ql_prev(:,:), &
-       qs_prev(:,:), q_prev(:,:), t_prev(:,:)
-  !$OMP THREADPRIVATE(u_prev, v_prev, ql_prev, qs_prev, q_prev, t_prev)
-
-CONTAINS
-
-  SUBROUTINE init_cmp_seri
-    !======================================================================
-    !
-    !======================================================================
-
-    !======================================================================
-    ! Declarations
-    !======================================================================
-    USE dimphy, ONLY: klon, klev
-    USE phys_local_var_mod, ONLY: u_seri, v_seri, ql_seri, qs_seri, q_seri, &
-         t_seri
-    !
-    IMPLICIT none
-    ! Local :
-    !--------
-    logical, save :: first=.true.
-    !$OMP THREADPRIVATE(first)
-
-    !
-    !======================================================================
-    !
-    if (first) then
-       ALLOCATE(u_prev(klon,klev))
-       ALLOCATE(v_prev(klon,klev))
-       ALLOCATE(ql_prev(klon,klev))
-       ALLOCATE(qs_prev(klon,klev))
-       ALLOCATE(q_prev(klon,klev))
-       ALLOCATE(t_prev(klon,klev))
-       first=.false.
-    endif
-    ! store current values of x_seri variables
-    u_prev(:,:) =u_seri(:,:)
-    v_prev(:,:) =v_seri(:,:)
-    ql_prev(:,:)=ql_seri(:,:)
-    qs_prev(:,:)=qs_seri(:,:)
-    t_prev(:,:) =t_seri(:,:)
-    q_prev(:,:) =q_seri(:,:)
-
-  END SUBROUTINE init_cmp_seri
-
-  !======================================================================
-  !
-  !======================================================================
-  SUBROUTINE cmp_seri(iflag,text)
-    !
-    USE dimphy, ONLY: klon, klev
-    USE phys_local_var_mod, ONLY: u_seri, v_seri, ql_seri, qs_seri, q_seri, &
-         t_seri
-    USE print_control_mod, ONLY: prt_level
-    IMPLICIT none
-    ! Arguments :
-    !------------
-    integer iflag
-    CHARACTER*(*) text
-    ! Local :
-    !--------
-    integer i, k
-    real du_seri(klon,klev), dv_seri(klon,klev), dql_seri(klon,klev), &
-         dqs_seri(klon,klev), dq_seri(klon,klev), dt_seri(klon,klev)
-    logical t_differ, u_differ, v_differ, ql_differ, qs_differ, q_differ
-    logical any_differ
-    !
-    any_differ = .false.
-    !
-    dt_seri(:,:)=t_seri(:,:)-t_prev(:,:)
-    IF (any(t_seri/=t_prev)) then
-       if ( .not. any_differ ) write (*,*) "In cmp_seri, after ",text
-       write (*,*) '*** t_seri has changed',minval(dt_seri),maxval(dt_seri)
-       t_differ=.true.
-       any_differ = .true.
-    ELSE
-       t_differ=.false.
-    END IF
-    !
-    dq_seri(:,:)=q_seri(:,:)-q_prev(:,:)
-    IF (any(q_seri/=q_prev)) then
-       if ( .not. any_differ ) write (*,*) "In cmp_seri, after ",text
-       write (*,*) '*** q_seri has changed',minval(dq_seri),maxval(dq_seri)
-       q_differ=.true.
-       any_differ = .true.
-    ELSE
-       q_differ=.false.
-    END IF
-    !
-    dql_seri(:,:)=ql_seri(:,:)-ql_prev(:,:)
-    IF (any(ql_seri/=ql_prev)) then
-       if ( .not. any_differ ) write (*,*) "In cmp_seri, after ",text
-       write (*,*) '*** ql_seri has changed',minval(dql_seri),maxval(dql_seri)
-       ql_differ=.true.
-       any_differ = .true.
-    ELSE
-       ql_differ=.false.
-    END IF
-    !
-    dqs_seri(:,:)=qs_seri(:,:)-qs_prev(:,:)
-    IF (any(qs_seri/=qs_prev)) then
-       if ( .not. any_differ ) write (*,*) "In cmp_seri, after ",text
-       write (*,*) '*** qs_seri has changed',minval(dqs_seri),maxval(dqs_seri)
-       qs_differ=.true.
-       any_differ = .true.
-    ELSE
-       qs_differ=.false.
-    END IF
-    !
-    du_seri(:,:)=u_seri(:,:)-u_prev(:,:)
-    IF (any(u_seri/=u_prev)) then
-       if ( .not. any_differ ) write (*,*) "In cmp_seri, after ",text
-       write (*,*) '*** u_seri has changed',minval(du_seri),maxval(du_seri)
-       u_differ=.true.
-       any_differ = .true.
-    ELSE
-       u_differ=.false.
-    END IF
-    !
-    dv_seri(:,:)=v_seri(:,:)-v_prev(:,:)
-    IF (any(v_seri/=v_prev)) then
-       if ( .not. any_differ ) write (*,*) "In cmp_seri, after ",text
-       write (*,*) '*** v_seri has changed',minval(dv_seri),maxval(dv_seri)
-       v_differ=.true.
-       any_differ = .true.
-    ELSE
-       v_differ=.false.
-    END IF
-    !
-    if (any_differ) then
-       IF (iflag >= 2 .and. prt_level >= 5) then
-          i=1
-          DO k = 1, klev
-             write(*,'(i3,6e14.6)')k, t_seri(i,k)-t_prev(i,k), u_seri(i,k)-u_prev(i,k), &
-                  v_seri(i,k)-v_prev(i,k), ql_seri(i,k)-ql_prev(i,k),&
-                  qs_seri(i,k)-qs_prev(i,k), q_seri(i,k)-q_prev(i,k)
-          ENDDO
-       END IF
-    else
-       write (*,*) 'No change for any xxx_seri after ',text
-    end if
-
-  END SUBROUTINE cmp_seri
-
-END MODULE cmp_seri_mod
-
Index: /LMDZ6/trunk/libf/phylmd/cmp_seri_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cmp_seri_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/cmp_seri_mod.f90	(revision 5268)
@@ -0,0 +1,156 @@
+!
+! $Id:  ??? $
+!
+MODULE cmp_seri_mod
+  !======================================================================
+  ! to check if the x_seri vaariables have changed
+  !
+  !======================================================================
+
+  REAL,SAVE,ALLOCATABLE ::  u_prev(:,:), v_prev(:,:), ql_prev(:,:), &
+       qs_prev(:,:), q_prev(:,:), t_prev(:,:)
+  !$OMP THREADPRIVATE(u_prev, v_prev, ql_prev, qs_prev, q_prev, t_prev)
+
+CONTAINS
+
+  SUBROUTINE init_cmp_seri
+    !======================================================================
+    !
+    !======================================================================
+
+    !======================================================================
+    ! Declarations
+    !======================================================================
+    USE dimphy, ONLY: klon, klev
+    USE phys_local_var_mod, ONLY: u_seri, v_seri, ql_seri, qs_seri, q_seri, &
+         t_seri
+    !
+    IMPLICIT none
+    ! Local :
+    !--------
+    logical, save :: first=.true.
+    !$OMP THREADPRIVATE(first)
+
+    !
+    !======================================================================
+    !
+    if (first) then
+       ALLOCATE(u_prev(klon,klev))
+       ALLOCATE(v_prev(klon,klev))
+       ALLOCATE(ql_prev(klon,klev))
+       ALLOCATE(qs_prev(klon,klev))
+       ALLOCATE(q_prev(klon,klev))
+       ALLOCATE(t_prev(klon,klev))
+       first=.false.
+    endif
+    ! store current values of x_seri variables
+    u_prev(:,:) =u_seri(:,:)
+    v_prev(:,:) =v_seri(:,:)
+    ql_prev(:,:)=ql_seri(:,:)
+    qs_prev(:,:)=qs_seri(:,:)
+    t_prev(:,:) =t_seri(:,:)
+    q_prev(:,:) =q_seri(:,:)
+
+  END SUBROUTINE init_cmp_seri
+
+  !======================================================================
+  !
+  !======================================================================
+  SUBROUTINE cmp_seri(iflag,text)
+    !
+    USE dimphy, ONLY: klon, klev
+    USE phys_local_var_mod, ONLY: u_seri, v_seri, ql_seri, qs_seri, q_seri, &
+         t_seri
+    USE print_control_mod, ONLY: prt_level
+    IMPLICIT none
+    ! Arguments :
+    !------------
+    integer iflag
+    CHARACTER*(*) text
+    ! Local :
+    !--------
+    integer i, k
+    real du_seri(klon,klev), dv_seri(klon,klev), dql_seri(klon,klev), &
+         dqs_seri(klon,klev), dq_seri(klon,klev), dt_seri(klon,klev)
+    logical t_differ, u_differ, v_differ, ql_differ, qs_differ, q_differ
+    logical any_differ
+    !
+    any_differ = .false.
+    !
+    dt_seri(:,:)=t_seri(:,:)-t_prev(:,:)
+    IF (any(t_seri/=t_prev)) then
+       if ( .not. any_differ ) write (*,*) "In cmp_seri, after ",text
+       write (*,*) '*** t_seri has changed',minval(dt_seri),maxval(dt_seri)
+       t_differ=.true.
+       any_differ = .true.
+    ELSE
+       t_differ=.false.
+    END IF
+    !
+    dq_seri(:,:)=q_seri(:,:)-q_prev(:,:)
+    IF (any(q_seri/=q_prev)) then
+       if ( .not. any_differ ) write (*,*) "In cmp_seri, after ",text
+       write (*,*) '*** q_seri has changed',minval(dq_seri),maxval(dq_seri)
+       q_differ=.true.
+       any_differ = .true.
+    ELSE
+       q_differ=.false.
+    END IF
+    !
+    dql_seri(:,:)=ql_seri(:,:)-ql_prev(:,:)
+    IF (any(ql_seri/=ql_prev)) then
+       if ( .not. any_differ ) write (*,*) "In cmp_seri, after ",text
+       write (*,*) '*** ql_seri has changed',minval(dql_seri),maxval(dql_seri)
+       ql_differ=.true.
+       any_differ = .true.
+    ELSE
+       ql_differ=.false.
+    END IF
+    !
+    dqs_seri(:,:)=qs_seri(:,:)-qs_prev(:,:)
+    IF (any(qs_seri/=qs_prev)) then
+       if ( .not. any_differ ) write (*,*) "In cmp_seri, after ",text
+       write (*,*) '*** qs_seri has changed',minval(dqs_seri),maxval(dqs_seri)
+       qs_differ=.true.
+       any_differ = .true.
+    ELSE
+       qs_differ=.false.
+    END IF
+    !
+    du_seri(:,:)=u_seri(:,:)-u_prev(:,:)
+    IF (any(u_seri/=u_prev)) then
+       if ( .not. any_differ ) write (*,*) "In cmp_seri, after ",text
+       write (*,*) '*** u_seri has changed',minval(du_seri),maxval(du_seri)
+       u_differ=.true.
+       any_differ = .true.
+    ELSE
+       u_differ=.false.
+    END IF
+    !
+    dv_seri(:,:)=v_seri(:,:)-v_prev(:,:)
+    IF (any(v_seri/=v_prev)) then
+       if ( .not. any_differ ) write (*,*) "In cmp_seri, after ",text
+       write (*,*) '*** v_seri has changed',minval(dv_seri),maxval(dv_seri)
+       v_differ=.true.
+       any_differ = .true.
+    ELSE
+       v_differ=.false.
+    END IF
+    !
+    if (any_differ) then
+       IF (iflag >= 2 .and. prt_level >= 5) then
+          i=1
+          DO k = 1, klev
+             write(*,'(i3,6e14.6)')k, t_seri(i,k)-t_prev(i,k), u_seri(i,k)-u_prev(i,k), &
+                  v_seri(i,k)-v_prev(i,k), ql_seri(i,k)-ql_prev(i,k),&
+                  qs_seri(i,k)-qs_prev(i,k), q_seri(i,k)-q_prev(i,k)
+          ENDDO
+       END IF
+    else
+       write (*,*) 'No change for any xxx_seri after ',text
+    end if
+
+  END SUBROUTINE cmp_seri
+
+END MODULE cmp_seri_mod
+
Index: DZ6/trunk/libf/phylmd/coare30_flux_cnrm_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/coare30_flux_cnrm_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,598 +1,0 @@
-!SFX_LIC Copyright 1994-2014 CNRS, Meteo-France and Universite Paul Sabatier
-!SFX_LIC This is part of the SURFEX software governed by the CeCILL-C licence
-!SFX_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt  
-!SFX_LIC for details. version 1.
-!     #########
-
-module coare30_flux_cnrm_mod
-  implicit none
-  private
-  public COARE30_FLUX_CNRM
-
-contains
-
-
-SUBROUTINE COARE30_FLUX_CNRM(PZ0SEA,PTA,PSST,PQA,  &
-            PVMOD,PZREF,PUREF,PPS,PQSATA,PQSAT,PSFTH,PSFTQ,PUSTAR,PCD,PCDN,PCH,PCE,PRI,&
-            PRESA,PRAIN,PPA,PZ0HSEA,LPRECIP, LPWG,coeffs )
-!     #######################################################################
-!
-!
-!!****  *COARE25_FLUX*
-!!
-!!    PURPOSE
-!!    -------
-!      Calculate the surface fluxes of heat, moisture, and momentum over
-!      sea surface with bulk algorithm COARE3.0.
-!
-!!**  METHOD
-!!    ------
-!      transfer coefficients were obtained using a dataset which combined COARE
-!      data with those from three other ETL field experiments, and reanalysis of
-!      the HEXMAX data (DeCosmos et al. 1996).
-!      ITERMAX=3
-!      Take account of the surface gravity waves on the velocity roughness and
-!      hence the momentum transfer coefficient
-!        NGRVWAVES=0 no gravity waves action (Charnock) !default value
-!        NGRVWAVES=1 wave age parameterization of Oost et al. 2002
-!        NGRVWAVES=2 model of Taylor and Yelland 2001
-!
-!!    EXTERNAL
-!!    --------
-!!
-!!    IMPLICIT ARGUMENTS
-!!    ------------------
-!!
-!!    REFERENCE
-!!    ---------
-!!      Fairall et al (2003), J. of Climate, vol. 16, 571-591
-!!      Fairall et al (1996), JGR, 3747-3764
-!!      Gosnell et al (1995), JGR, 437-442
-!!      Fairall et al (1996), JGR, 1295-1308
-!!
-!!    AUTHOR
-!!    ------
-!!     C. Lebeaupin  *Météo-France* (adapted from C. Fairall's code)
-!!
-!!    MODIFICATIONS
-!!    -------------
-!!      Original     1/06/2006
-!!      B. Decharme    06/2009 limitation of Ri
-!!      B. Decharme    09/2012 Bug in Ri calculation and limitation of Ri in surface_ri.F90
-!!      B. Decharme    06/2013 bug in z0 (output) computation
-!!      J.Escobar      06/2013  for REAL4/8 add EPSILON management
-!!      C. Lebeaupin   03/2014 bug if PTA=PSST and PEXNA=PEXNS: set a minimum value
-!!                             add abort if no convergence
-!-------------------------------------------------------------------------------
-!
-!*       0.     DECLARATIONS
-!               ------------
-!
-!
-!USE MODD_SEAFLUX_n, ONLY : SEAFLUX_t
-!
-
-!----------Rajout Olive ---------
-USE dimphy
-USE indice_sol_mod
-USE coare_cp_mod, ONLY: PSIFCTT=>psit_30, PSIFCTU=>psiuo
-
-!--------------------------------
-
-USE MODD_CSTS,       ONLY : XKARMAN, XG, XSTEFAN, XRD, XRV, XPI, &
-                            XLVTT, XCL, XCPD, XCPV, XRHOLW, XTT, &
-                            XP00
-
-!USE MODD_SURF_ATM,   ONLY : XVZ0CM
-!
-!USE MODD_SURF_PAR,   ONLY : XUNDEF, XSURF_EPSILON
-!USE MODD_WATER_PAR
-!
-!USE MODI_SURFACE_RI
-!USE MODI_WIND_THRESHOLD
-!USE MODE_COARE30_PSI
-!
-!USE MODE_THERMOS
-!
-!
-!USE MODI_ABOR1_SFX
-!
-!
-!USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK
-!USE PARKIND1  ,ONLY : JPRB
-!
-IMPLICIT NONE
-!
-!*      0.1    declarations of arguments
-!
-!
-!
-!TYPE(SEAFLUX_t), INTENT(INOUT) :: S
-!
-REAL, DIMENSION(klon), INTENT(IN)       :: PTA   ! air temperature at atm. level (K)
-REAL, DIMENSION(klon), INTENT(IN)       :: PQA   ! air humidity at atm. level (kg/kg)
-!REAL, DIMENSION(:), INTENT(IN)       :: PEXNA ! Exner function at atm. level
-!REAL, DIMENSION(:), INTENT(IN)       :: PRHOA ! air density at atm. level
-REAL, DIMENSION(klon), INTENT(IN)       :: PVMOD ! module of wind at atm. wind level (m/s)
-REAL, DIMENSION(klon), INTENT(IN)       :: PZREF ! atm. level for temp. and humidity (m)
-REAL, DIMENSION(klon), INTENT(IN)       :: PUREF ! atm. level for wind (m)
-REAL, DIMENSION(klon), INTENT(IN)       :: PSST  ! Sea Surface Temperature (K)
-!REAL, DIMENSION(:), INTENT(IN)       :: PEXNS ! Exner function at sea surface
-REAL, DIMENSION(klon), INTENT(IN)       :: PPS   ! air pressure at sea surface (Pa)
-REAL, DIMENSION(klon), INTENT(IN)       :: PRAIN !precipitation rate (kg/s/m2)
-REAL, DIMENSION(klon), INTENT(IN)       :: PPA        ! air pressure at atm level (Pa)
-REAL, DIMENSION(klon), INTENT(IN)       :: PQSATA        ! air pressure at atm level (Pa)
-!
-REAL, DIMENSION(klon), INTENT(INOUT)    :: PZ0SEA! roughness length over the ocean
-!
-!  surface fluxes : latent heat, sensible heat, friction fluxes
-REAL, DIMENSION(klon), INTENT(OUT)      :: PSFTH ! heat flux (W/m2)
-REAL, DIMENSION(klon), INTENT(OUT)      :: PSFTQ ! water flux (kg/m2/s)
-REAL, DIMENSION(klon), INTENT(OUT)      :: PUSTAR! friction velocity (m/s)
-!
-! diagnostics
-REAL, DIMENSION(klon), INTENT(OUT)      :: PQSAT ! humidity at saturation
-REAL, DIMENSION(klon), INTENT(OUT)      :: PCD   ! heat drag coefficient
-REAL, DIMENSION(klon), INTENT(OUT)      :: PCDN  ! momentum drag coefficient
-REAL, DIMENSION(klon), INTENT(OUT)      :: PCH   ! neutral momentum drag coefficient
-REAL, DIMENSION(klon), INTENT(OUT)      :: PCE  !transfer coef. for latent heat flux
-REAL, DIMENSION(klon), INTENT(OUT)      :: PRI   ! Richardson number
-REAL, DIMENSION(klon), INTENT(OUT)      :: PRESA ! aerodynamical resistance
-REAL, DIMENSION(klon), INTENT(OUT)      :: PZ0HSEA ! heat roughness length
-
-LOGICAL,            INTENT(IN)    :: LPRECIP   !
-LOGICAL,            INTENT(IN)    :: LPWG    !
-real, dimension(3), intent(inout)      :: coeffs
-!
-!
-
-!INCLUDE "YOMCST.h"
-!INCLUDE "clesphys.h"
-
-!*      0.2    declarations of local variables
-!
-REAL, DIMENSION(SIZE(PTA))      :: ZVMOD    ! wind intensity
-REAL, DIMENSION(SIZE(PTA))      :: ZPA      ! Pressure at atm. level
-REAL, DIMENSION(SIZE(PTA))      :: ZTA      ! Temperature at atm. level
-REAL, DIMENSION(SIZE(PTA))      :: ZQASAT   ! specific humidity at saturation  at atm. level (kg/kg)
-!
-!rajout
-REAL, DIMENSION(SIZE(PTA))       :: PEXNA      ! Exner function at atm level
-REAL, DIMENSION(SIZE(PTA))       :: PEXNS      ! Exner function at atm level
-!
-REAL, DIMENSION(SIZE(PTA))      :: ZO       ! rougness length ref
-REAL, DIMENSION(SIZE(PTA))      :: ZWG      ! gustiness factor (m/s)
-!
-REAL, DIMENSION(SIZE(PTA))      :: ZDU,ZDT,ZDQ,ZDUWG !differences
-!
-REAL, DIMENSION(SIZE(PTA))      :: ZUSR        !velocity scaling parameter "ustar" (m/s) = friction velocity
-REAL, DIMENSION(SIZE(PTA))      :: ZTSR        !temperature sacling parameter "tstar" (degC)
-REAL, DIMENSION(SIZE(PTA))      :: ZQSR        !humidity scaling parameter "qstar" (kg/kg)
-!
-REAL, DIMENSION(SIZE(PTA))      :: ZU10,ZT10   !vertical profils (10-m height)
-REAL, DIMENSION(SIZE(PTA))      :: ZVISA       !kinematic viscosity of dry air
-REAL, DIMENSION(SIZE(PTA))      :: ZO10,ZOT10  !roughness length at 10m
-REAL, DIMENSION(SIZE(PTA))      :: ZCD,ZCT,ZCC
-REAL, DIMENSION(SIZE(PTA))      :: ZCD10,ZCT10 !transfer coef. at 10m
-REAL, DIMENSION(SIZE(PTA))      :: ZRIBU,ZRIBCU
-REAL, DIMENSION(SIZE(PTA))      :: ZETU,ZL10
-!
-REAL, DIMENSION(SIZE(PTA))      :: ZCHARN                      !Charnock number depends on wind module
-REAL, DIMENSION(SIZE(PTA))      :: ZTWAVE,ZHWAVE,ZCWAVE,ZLWAVE !to compute gravity waves' impact
-!
-REAL, DIMENSION(SIZE(PTA))      :: ZZL,ZZTL!,ZZQL    !Obukhovs stability
-                                                     !param. z/l for u,T,q
-REAL, DIMENSION(SIZE(PTA))      :: ZRR
-REAL, DIMENSION(SIZE(PTA))      :: ZOT,ZOQ           !rougness length ref
-REAL, DIMENSION(SIZE(PTA))      :: ZPUZ,ZPTZ,ZPQZ    !PHI funct. for u,T,q
-!
-REAL, DIMENSION(SIZE(PTA))      :: ZBF               !constants to compute gustiness factor
-!
-REAL, DIMENSION(SIZE(PTA))      :: ZTAU       !momentum flux (W/m2)
-REAL, DIMENSION(SIZE(PTA))      :: ZHF        !sensible heat flux (W/m2)
-REAL, DIMENSION(SIZE(PTA))      :: ZEF        !latent heat flux (W/m2)
-REAL, DIMENSION(SIZE(PTA))      :: ZWBAR      !diag for webb correction but not used here after
-REAL, DIMENSION(SIZE(PTA))      :: ZTAUR      !momentum flux due to rain (W/m2)
-REAL, DIMENSION(SIZE(PTA))      :: ZRF        !sensible heat flux due to rain (W/m2)
-REAL, DIMENSION(SIZE(PTA))      :: ZCHN,ZCEN  !neutral coef. for heat and vapor
-!
-REAL, DIMENSION(SIZE(PTA))      :: ZLV      !latent heat constant
-!
-REAL, DIMENSION(SIZE(PTA))      :: ZTAC,ZDQSDT,ZDTMP,ZDWAT,ZALFAC ! for precipitation impact
-REAL, DIMENSION(SIZE(PTA))      :: ZXLR                           ! vaporisation  heat  at a given temperature
-REAL, DIMENSION(SIZE(PTA))      :: ZCPLW                          ! specific heat for water at a given temperature
-!
-REAL, DIMENSION(SIZE(PTA))      :: ZUSTAR2  ! square of friction velocity
-!
-REAL, DIMENSION(SIZE(PTA))      :: ZDIRCOSZW! orography slope cosine (=1 on water!)
-REAL, DIMENSION(SIZE(PTA))      :: ZAC      ! Aerodynamical conductance
-!
-!
-INTEGER, DIMENSION(SIZE(PTA))   :: ITERMAX             ! maximum number of iterations
-!
-REAL    :: ZRVSRDM1,ZRDSRV,ZR2 ! thermodynamic constants
-REAL    :: ZBETAGUST           !gustiness factor
-REAL    :: ZZBL                !atm. boundary layer depth (m)
-REAL    :: ZVISW               !m2/s kinematic viscosity of water
-REAL    :: ZS                  !height of rougness length ref
-REAL    :: ZCH10               !transfer coef. at 10m
-
-REAL    :: QSAT_SEAWATER
-REAL    :: QSATSEAW_1D
-!
-INTEGER :: J, JLOOP    !loop indice
-!REAL(KIND=JPRB) :: ZHOOK_HANDLE
-
-!--------- Modif Olive -----------------
-REAL, DIMENSION(SIZE(PTA))        :: PRHOA
-REAL, PARAMETER                   :: XUNDEF = 1.E+20
-
-REAL       :: XVCHRNK = 0.021
-REAL       :: XVZ0CM = 1.0E-5
-!REAL       :: XRIMAX
-
-
-INTEGER :: PREF             ! reference pressure for exner function
-INTEGER :: NGRVWAVES        ! Pour le choix du z0
-
-INCLUDE "YOMCST.h"
-INCLUDE "clesphys.h"
-
-!--------------------------------------
-
-
-PRHOA(:) = PPS(:) / (287.1 * PTA(:) * (1.+.61*PQA(:)))
-
-PREF = 100000.                     ! = 1000 hPa
-NGRVWAVES = 1
-
-PEXNA = (PPA/PREF)**(RD/RCPD)
-PEXNS = (PPS/PREF)**(RD/RCPD)
-
-!
-!-------------------------------------------------------------------------------
-!
-!       1.     Initializations
-!              ---------------
-!
-!       1.1   Constants and parameters
-!
-!IF (LHOOK) CALL DR_HOOK('COARE30_FLUX',0,ZHOOK_HANDLE)
-!
-ZRVSRDM1  = XRV/XRD-1. ! 0.607766
-ZRDSRV    = XRD/XRV    ! 0.62198
-ZR2       = 1.-ZRDSRV  ! pas utilisé dans cette routine
-ZBETAGUST = 1.2        ! value based on TOGA-COARE experiment
-ZZBL      = 600.       ! Set a default value for boundary layer depth
-ZS        = 10.        ! Standard heigth =10m
-ZCH10     = 0.00115
-!
-ZVISW     = 1.E-6
-!
-!       1.2   Array initialization by undefined values
-!
-PSFTH (:)=XUNDEF
-PSFTQ (:)=XUNDEF
-PUSTAR(:)=XUNDEF
-!
-PCD(:) = XUNDEF
-PCDN(:) = XUNDEF
-PCH(:) = XUNDEF
-PCE(:) =XUNDEF
-PRI(:) = XUNDEF
-!
-PRESA(:)=XUNDEF
-!
-!-------------------------------------------------------------------------------
-!       2. INITIAL GUESS FOR THE ITERATIVE METHOD
-!          -------------------------------------
-!
-!       2.0     Temperature
-!
-! Set a non-zero value for the temperature gradient
-!
-WHERE((PTA(:)*PEXNS(:)/PEXNA(:)-PSST(:))==0.)
-      ZTA(:)=PTA(:)-1E-3
-ELSEWHERE
-      ZTA(:)=PTA(:)
-ENDWHERE
-
-!       2.1     Wind and humidity
-!
-! Sea surface specific humidity
-!
-!PQSAT(:)=QSAT_SEAWATER(PSST(:),PPS(:))
-PQSAT(:)=QSATSEAW_1D(PSST(:),PPS(:))
-
-
-
-!
-! Set a minimum value to wind
-!
-!ZVMOD(:) = WIND_THRESHOLD(PVMOD(:),PUREF(:))
-
-
-ZVMOD = MAX(PVMOD , 0.1 * MIN(10.,PUREF) )    !set a minimum value to wind
-!ZVMOD = PVMOD    !set a minimum value to wind
-
-!
-! Specific humidity at saturation at the atm. level
-!
-ZPA(:) = XP00* (PEXNA(:)**(XCPD/XRD))
-!ZQASAT(:) = QSAT_SEAWATER(ZTA(:),ZPA(:))
-ZQASAT = QSATSEAW_1D(ZTA(:),ZPA(:))
-
-
-!
-!
-ZO(:)  = 0.0001
-ZWG(:) = 0.
-IF (LPWG) ZWG(:) = 0.5
-!
-ZCHARN(:) = 0.011
-!
-DO J=1,SIZE(PTA)
-  !
-  !      2.2       initial guess
-  !
-  ZDU(J) = ZVMOD(J)   !wind speed difference with surface current(=0) (m/s)
-                      !initial guess for gustiness factor
-  ZDT(J) = -(ZTA(J)/PEXNA(J)) + (PSST(J)/PEXNS(J)) !potential temperature difference
-  ZDQ(J) = PQSAT(J)-PQA(J)                         !specific humidity difference
-  !
-  ZDUWG(J) = SQRT(ZDU(J)**2+ZWG(J)**2)     !wind speed difference including gustiness ZWG
-  !
-  !      2.3   initialization of neutral coefficients
-  !
-  ZU10(J)  = ZDUWG(J)*LOG(ZS/ZO(J))/LOG(PUREF(J)/ZO(J))
-  ZUSR(J)  = 0.035*ZU10(J)
-  ZVISA(J) = 1.326E-5*(1.+6.542E-3*(ZTA(J)-XTT)+&
-             8.301E-6*(ZTA(J)-XTT)**2-4.84E-9*(ZTA(J)-XTT)**3) !Andrea (1989) CRREL Rep. 89-11
-  !
-  ZO10(J) = ZCHARN(J)*ZUSR(J)*ZUSR(J)/XG+0.11*ZVISA(J)/ZUSR(J)
-  ZCD(J)  = (XKARMAN/LOG(PUREF(J)/ZO10(J)))**2  !drag coefficient
-  ZCD10(J)= (XKARMAN/LOG(ZS/ZO10(J)))**2
-  ZCT10(J)= ZCH10/SQRT(ZCD10(J))
-  ZOT10(J)= ZS/EXP(XKARMAN/ZCT10(J))
-  !
-  !-------------------------------------------------------------------------------
-  !             Grachev and Fairall (JAM, 1997)
-  ZCT(J) = XKARMAN/LOG(PZREF(J)/ZOT10(J))      !temperature transfer coefficient
-  ZCC(J) = XKARMAN*ZCT(J)/ZCD(J)               !z/L vs Rib linear coef.
-  !
-  ZRIBCU(J) = -PUREF(J)/(ZZBL*0.004*ZBETAGUST**3) !saturation or plateau Rib
-  !ZRIBU(J) =-XG*PUREF(J)*(ZDT(J)+ZRVSRDM1*(ZTA(J)-XTT)*ZDQ)/&
-  !     &((ZTA(J)-XTT)*ZDUWG(J)**2)
-  ZRIBU(J)  = -XG*PUREF(J)*(ZDT(J)+ZRVSRDM1*ZTA(J)*ZDQ(J))/&
-               (ZTA(J)*ZDUWG(J)**2)
-  !
-  IF (ZRIBU(J)<0.) THEN
-    ZETU(J) = ZCC(J)*ZRIBU(J)/(1.+ZRIBU(J)/ZRIBCU(J))    !Unstable G and F
-  ELSE
-    ZETU(J) = ZCC(J)*ZRIBU(J)/(1.+27./9.*ZRIBU(J)/ZCC(J))!Stable
-  ENDIF
-  !
-  ZL10(J) = PUREF(J)/ZETU(J) !MO length
-  !
-ENDDO
-!
-!  First guess M-O stability dependent scaling params. (u*,T*,q*) to estimate ZO and z/L (ZZL)
-ZUSR(:) = ZDUWG(:)*XKARMAN/(LOG(PUREF(:)/ZO10(:))-PSIFCTU(PUREF(1)/ZL10(1)))
-ZTSR(:) = -ZDT(:)*XKARMAN/(LOG(PZREF(:)/ZOT10(:))-PSIFCTT(PZREF(1)/ZL10(1)))
-ZQSR(:) = -ZDQ(:)*XKARMAN/(LOG(PZREF(:)/ZOT10(:))-PSIFCTT(PZREF(1)/ZL10(1)))
-!
-ZZL(:) = 0.0
-!
-DO J=1,SIZE(PTA)
-  !
-  IF (ZETU(J)>50.) THEN
-    ITERMAX(J) = 1
-  ELSE
-    ITERMAX(J) = 3 !number of iterations
-  ENDIF
-  !
-  !then modify Charnork for high wind speeds Chris Fairall's data
-  IF (ZDUWG(J)>10.) ZCHARN(J) = 0.011 + (0.018-0.011)*(ZDUWG(J)-10.)/(18.-10.)
-  IF (ZDUWG(J)>18.) ZCHARN(J) = 0.018
-  !
-  !                3.  ITERATIVE LOOP TO COMPUTE USR, TSR, QSR
-  !                -------------------------------------------
-  !
-  ZHWAVE(J) = 0.018*ZVMOD(J)*ZVMOD(J)*(1.+0.015*ZVMOD(J))
-  ZTWAVE(J) = 0.729*ZVMOD(J)
-  ZCWAVE(J) = XG*ZTWAVE(J)/(2.*XPI)
-  ZLWAVE(J) = ZTWAVE(J)*ZCWAVE(J)
-  !
-ENDDO
-!
-
-!
-DO JLOOP=1,MAXVAL(ITERMAX) ! begin of iterative loop
-  !
-  DO J=1,SIZE(PTA)
-    !
-    IF (JLOOP>ITERMAX(J)) CYCLE
-    !
-    IF (NGRVWAVES==0) THEN
-      ZO(J) = ZCHARN(J)*ZUSR(J)*ZUSR(J)/XG + 0.11*ZVISA(J)/ZUSR(J) !Smith 1988
-    ELSE IF (NGRVWAVES==1) THEN
-      ZO(J) = (50./(2.*XPI))*ZLWAVE(J)*(ZUSR(J)/ZCWAVE(J))**4.5 &
-              + 0.11*ZVISA(J)/ZUSR(J)                       !Oost et al. 2002
-    ELSE IF (NGRVWAVES==2) THEN
-      ZO(J) = 1200.*ZHWAVE(J)*(ZHWAVE(J)/ZLWAVE(J))**4.5 &
-              + 0.11*ZVISA(J)/ZUSR(J)                       !Taulor and Yelland 2001
-    ENDIF
-    !
-    ZRR(J) = ZO(J)*ZUSR(J)/ZVISA(J)
-    ZOQ(J) = MIN(1.15E-4 , 5.5E-5/ZRR(J)**0.6)
-    ZOT(J) = ZOQ(J)
-    !
-    ZZL(J) = XKARMAN * XG * PUREF(J) * &
-              ( ZTSR(J)*(1.+ZRVSRDM1*PQA(J)) + ZRVSRDM1*ZTA(J)*ZQSR(J) ) / &
-              ( ZTA(J)*ZUSR(J)*ZUSR(J)*(1.+ZRVSRDM1*PQA(J)) )
-    ZZTL(J)= ZZL(J)*PZREF(J)/PUREF(J)  ! for T
-!    ZZQL(J)=ZZL(J)*PZREF(J)/PUREF(J)  ! for Q
-  ENDDO
-  !
-  ZPUZ(:) = PSIFCTU(ZZL(1))
-  ZPTZ(:) = PSIFCTT(ZZTL(1))
-  !
-  DO J=1,SIZE(PTA)
-    !
-    ! ZPQZ(J)=PSIFCTT(ZZQL(J))
-    ZPQZ(J) = ZPTZ(J)
-    !
-    !             3.1 scale parameters
-    !
-    ZUSR(J) = ZDUWG(J)*XKARMAN/(LOG(PUREF(J)/ZO(J)) -ZPUZ(J))
-    ZTSR(J) = -ZDT(J)  *XKARMAN/(LOG(PZREF(J)/ZOT(J))-ZPTZ(J))
-    ZQSR(J) = -ZDQ(J)  *XKARMAN/(LOG(PZREF(J)/ZOQ(J))-ZPQZ(J))
-    !
-    !             3.2 Gustiness factor (ZWG)
-    !
-    IF(LPWG) THEN
-      ZBF(J) = -XG/ZTA(J)*ZUSR(J)*(ZTSR(J)+ZRVSRDM1*ZTA(J)*ZQSR(J))
-      IF (ZBF(J)>0.) THEN
-        ZWG(J) = ZBETAGUST*(ZBF(J)*ZZBL)**(1./3.)
-      ELSE
-        ZWG(J) = 0.2
-      ENDIF
-    ENDIF
-    ZDUWG(J) = SQRT(ZVMOD(J)**2 + ZWG(J)**2)
-    !
-  ENDDO
-  !
-ENDDO
-!-------------------------------------------------------------------------------
-!
-!            4.  COMPUTE transfer coefficients PCD, PCH, ZCE and SURFACE FLUXES
-!                --------------------------------------------------------------
-!
-ZTAU(:) = XUNDEF
-ZHF(:)  = XUNDEF
-ZEF(:)  = XUNDEF
-!
-ZWBAR(:) = 0.
-ZTAUR(:) = 0.
-ZRF(:)   = 0.
-!
-DO J=1,SIZE(PTA)
-  !
-  !
-  !            4. transfert coefficients PCD, PCH and PCE
-  !                 and neutral PCDN, ZCHN, ZCEN
-  !
-  PCD(J) = (ZUSR(J)/ZDUWG(J))**2.
-  PCH(J) = ZUSR(J)*ZTSR(J)/(ZDUWG(J)*(ZTA(J)*PEXNS(J)/PEXNA(J)-PSST(J)))
-  PCE(J) = ZUSR(J)*ZQSR(J)/(ZDUWG(J)*(PQA(J)-PQSAT(J)))
-  !
-  PCDN(J) = (XKARMAN/LOG(ZS/ZO(J)))**2.
-  ZCHN(J) = (XKARMAN/LOG(ZS/ZO(J)))*(XKARMAN/LOG(ZS/ZOT(J)))
-  ZCEN(J) = (XKARMAN/LOG(ZS/ZO(J)))*(XKARMAN/LOG(ZS/ZOQ(J)))
-  !
-  ZLV(J) = XLVTT + (XCPV-XCL)*(PSST(J)-XTT)
-  !
-  !            4. 2 surface fluxes
-  !
-  IF (ABS(PCDN(J))>1.E-2) THEN   !!!! secure COARE3.0 CODE
-    write(*,*) 'pb PCDN in COARE30: ',PCDN(J)
-    write(*,*) 'point: ',J,"/",SIZE(PTA)
-    write(*,*) 'roughness: ', ZO(J)
-    write(*,*) 'ustar: ',ZUSR(J)
-    write(*,*) 'wind: ',ZDUWG(J)
-    CALL abort_physic('COARE30',': PCDN too large -> no convergence',1)
-  ELSE
-    ZTSR(J) = -ZTSR(J)
-    ZQSR(J) = -ZQSR(J)
-    ZTAU(J) = -PRHOA(J)*ZUSR(J)*ZUSR(J)*ZVMOD(J)/ZDUWG(J)
-    ZHF(J)  =  PRHOA(J)*XCPD*ZUSR(J)*ZTSR(J)
-    ZEF(J)  =  PRHOA(J)*ZLV(J)*ZUSR(J)*ZQSR(J)
-    !
-    !           4.3 Contributions to surface  fluxes due to rainfall
-    !
-    ! SB: a priori, le facteur ZRDSRV=XRD/XRV est introduit pour
-    !     adapter la formule de Clausius-Clapeyron (pour l'air
-    !     sec) au cas humide.
-    IF (LPRECIP) THEN
-      !
-      ! heat surface  fluxes
-      !
-      ZTAC(J)  = ZTA(J)-XTT
-      !
-      ZXLR(J)  = XLVTT + (XCPV-XCL)* ZTAC(J)                            ! latent heat of rain vaporization
-      ZDQSDT(J)= ZQASAT(J) * ZXLR(J) / (XRD*ZTA(J)**2)                  ! Clausius-Clapeyron relation
-      ZDTMP(J) = (1.0 + 3.309e-3*ZTAC(J) -1.44e-6*ZTAC(J)*ZTAC(J)) * &  !heat diffusivity
-                  0.02411 / (PRHOA(J)*XCPD)
-      !
-      ZDWAT(J) = 2.11e-5 * (XP00/ZPA(J)) * (ZTA(J)/XTT)**1.94           ! water vapour diffusivity from eq (13.3)
-      !                                                                 ! of Pruppacher and Klett (1978)
-      ZALFAC(J)= 1.0 / (1.0 + &                                         ! Eq.11 in GoF95
-                   ZRDSRV*ZDQSDT(J)*ZXLR(J)*ZDWAT(J)/(ZDTMP(J)*XCPD))   ! ZALFAC=wet-bulb factor (sans dim)
-      ZCPLW(J) = 4224.8482 + ZTAC(J) * &
-                              ( -4.707 + ZTAC(J) * &
-                                (0.08499 + ZTAC(J) * &
-                                  (1.2826e-3 + ZTAC(J) * &
-                                    (4.7884e-5 - 2.0027e-6* ZTAC(J))))) ! specific heat
-      !
-      ZRF(J)   = PRAIN(J) * ZCPLW(J) * ZALFAC(J) * &                    !Eq.12 in GoF95 !SIGNE?
-                   (PSST(J) - ZTA(J) + (PQSAT(J)-PQA(J))*ZXLR(J)/XCPD )
-      !
-      ! Momentum flux due to rainfall
-      !
-      ZTAUR(J)=-0.85*(PRAIN(J) *ZVMOD(J)) !pp3752 in FBR96
-      !
-    ENDIF
-    !
-    !             4.4   Webb correction to latent heat flux
-    !
-    ZWBAR(J)=- (1./ZRDSRV)*ZUSR(J)*ZQSR(J) / (1.0+(1./ZRDSRV)*PQA(J)) &
-               - ZUSR(J)*ZTSR(J)/ZTA(J)                        ! Eq.21*rhoa in FBR96
-    !
-    !             4.5   friction velocity which contains correction du to rain
-    !
-    ZUSTAR2(J)= - (ZTAU(J) + ZTAUR(J)) / PRHOA(J)
-    PUSTAR(J) =  SQRT(ZUSTAR2(J))
-    !
-    !             4.6   Total surface fluxes
-    !
-    PSFTH (J) =  ZHF(J) + ZRF(J)
-    PSFTQ (J) =  ZEF(J) / ZLV(J)
-    !
-  ENDIF
-ENDDO
-
-
-coeffs = [PCD,&
-       PCE,&
-       PCH]
-
-!-------------------------------------------------------------------------------
-!
-!       5.  FINAL STEP : TOTAL SURFACE FLUXES AND DERIVED DIAGNOSTICS
-!           -----------
-!       5.1    Richardson number
-!
-!
-!------------STOP LA --------------------
-!ZDIRCOSZW(:) = 1.
-! CALL SURFACE_RI(PSST,PQSAT,PEXNS,PEXNA,ZTA,ZQASAT,&
-!                PZREF,PUREF,ZDIRCOSZW,PVMOD,PRI   )
-!!
-!!       5.2     Aerodynamical conductance and resistance
-!!
-!ZAC(:) = PCH(:)*ZVMOD(:)
-!PRESA(:) = 1. / MAX(ZAC(:),XSURF_EPSILON)
-!
-!!       5.3 Z0 and Z0H over sea
-!!
-!PZ0SEA(:) =  ZCHARN(:) * ZUSTAR2(:) / XG + XVZ0CM * PCD(:) / PCDN(:)
-!!
-!!PZ0HSEA(:) = PZ0SEA(:)
-!!
-!IF (LHOOK) CALL DR_HOOK('COARE30_FLUX',1,ZHOOK_HANDLE)
-!
-!-------------------------------------------------------------------------------
-!
-END SUBROUTINE COARE30_FLUX_CNRM
-
-end module coare30_flux_cnrm_mod
Index: /LMDZ6/trunk/libf/phylmd/coare30_flux_cnrm_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/coare30_flux_cnrm_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/coare30_flux_cnrm_mod.f90	(revision 5268)
@@ -0,0 +1,598 @@
+!SFX_LIC Copyright 1994-2014 CNRS, Meteo-France and Universite Paul Sabatier
+!SFX_LIC This is part of the SURFEX software governed by the CeCILL-C licence
+!SFX_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt  
+!SFX_LIC for details. version 1.
+!     #########
+
+module coare30_flux_cnrm_mod
+  implicit none
+  private
+  public COARE30_FLUX_CNRM
+
+contains
+
+
+SUBROUTINE COARE30_FLUX_CNRM(PZ0SEA,PTA,PSST,PQA,  &
+            PVMOD,PZREF,PUREF,PPS,PQSATA,PQSAT,PSFTH,PSFTQ,PUSTAR,PCD,PCDN,PCH,PCE,PRI,&
+            PRESA,PRAIN,PPA,PZ0HSEA,LPRECIP, LPWG,coeffs )
+!     #######################################################################
+!
+!
+!!****  *COARE25_FLUX*
+!!
+!!    PURPOSE
+!!    -------
+!      Calculate the surface fluxes of heat, moisture, and momentum over
+!      sea surface with bulk algorithm COARE3.0.
+!
+!!**  METHOD
+!!    ------
+!      transfer coefficients were obtained using a dataset which combined COARE
+!      data with those from three other ETL field experiments, and reanalysis of
+!      the HEXMAX data (DeCosmos et al. 1996).
+!      ITERMAX=3
+!      Take account of the surface gravity waves on the velocity roughness and
+!      hence the momentum transfer coefficient
+!        NGRVWAVES=0 no gravity waves action (Charnock) !default value
+!        NGRVWAVES=1 wave age parameterization of Oost et al. 2002
+!        NGRVWAVES=2 model of Taylor and Yelland 2001
+!
+!!    EXTERNAL
+!!    --------
+!!
+!!    IMPLICIT ARGUMENTS
+!!    ------------------
+!!
+!!    REFERENCE
+!!    ---------
+!!      Fairall et al (2003), J. of Climate, vol. 16, 571-591
+!!      Fairall et al (1996), JGR, 3747-3764
+!!      Gosnell et al (1995), JGR, 437-442
+!!      Fairall et al (1996), JGR, 1295-1308
+!!
+!!    AUTHOR
+!!    ------
+!!     C. Lebeaupin  *Météo-France* (adapted from C. Fairall's code)
+!!
+!!    MODIFICATIONS
+!!    -------------
+!!      Original     1/06/2006
+!!      B. Decharme    06/2009 limitation of Ri
+!!      B. Decharme    09/2012 Bug in Ri calculation and limitation of Ri in surface_ri.F90
+!!      B. Decharme    06/2013 bug in z0 (output) computation
+!!      J.Escobar      06/2013  for REAL4/8 add EPSILON management
+!!      C. Lebeaupin   03/2014 bug if PTA=PSST and PEXNA=PEXNS: set a minimum value
+!!                             add abort if no convergence
+!-------------------------------------------------------------------------------
+!
+!*       0.     DECLARATIONS
+!               ------------
+!
+!
+!USE MODD_SEAFLUX_n, ONLY : SEAFLUX_t
+!
+
+!----------Rajout Olive ---------
+USE dimphy
+USE indice_sol_mod
+USE coare_cp_mod, ONLY: PSIFCTT=>psit_30, PSIFCTU=>psiuo
+
+!--------------------------------
+
+USE MODD_CSTS,       ONLY : XKARMAN, XG, XSTEFAN, XRD, XRV, XPI, &
+                            XLVTT, XCL, XCPD, XCPV, XRHOLW, XTT, &
+                            XP00
+
+!USE MODD_SURF_ATM,   ONLY : XVZ0CM
+!
+!USE MODD_SURF_PAR,   ONLY : XUNDEF, XSURF_EPSILON
+!USE MODD_WATER_PAR
+!
+!USE MODI_SURFACE_RI
+!USE MODI_WIND_THRESHOLD
+!USE MODE_COARE30_PSI
+!
+!USE MODE_THERMOS
+!
+!
+!USE MODI_ABOR1_SFX
+!
+!
+!USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK
+!USE PARKIND1  ,ONLY : JPRB
+!
+IMPLICIT NONE
+!
+!*      0.1    declarations of arguments
+!
+!
+!
+!TYPE(SEAFLUX_t), INTENT(INOUT) :: S
+!
+REAL, DIMENSION(klon), INTENT(IN)       :: PTA   ! air temperature at atm. level (K)
+REAL, DIMENSION(klon), INTENT(IN)       :: PQA   ! air humidity at atm. level (kg/kg)
+!REAL, DIMENSION(:), INTENT(IN)       :: PEXNA ! Exner function at atm. level
+!REAL, DIMENSION(:), INTENT(IN)       :: PRHOA ! air density at atm. level
+REAL, DIMENSION(klon), INTENT(IN)       :: PVMOD ! module of wind at atm. wind level (m/s)
+REAL, DIMENSION(klon), INTENT(IN)       :: PZREF ! atm. level for temp. and humidity (m)
+REAL, DIMENSION(klon), INTENT(IN)       :: PUREF ! atm. level for wind (m)
+REAL, DIMENSION(klon), INTENT(IN)       :: PSST  ! Sea Surface Temperature (K)
+!REAL, DIMENSION(:), INTENT(IN)       :: PEXNS ! Exner function at sea surface
+REAL, DIMENSION(klon), INTENT(IN)       :: PPS   ! air pressure at sea surface (Pa)
+REAL, DIMENSION(klon), INTENT(IN)       :: PRAIN !precipitation rate (kg/s/m2)
+REAL, DIMENSION(klon), INTENT(IN)       :: PPA        ! air pressure at atm level (Pa)
+REAL, DIMENSION(klon), INTENT(IN)       :: PQSATA        ! air pressure at atm level (Pa)
+!
+REAL, DIMENSION(klon), INTENT(INOUT)    :: PZ0SEA! roughness length over the ocean
+!
+!  surface fluxes : latent heat, sensible heat, friction fluxes
+REAL, DIMENSION(klon), INTENT(OUT)      :: PSFTH ! heat flux (W/m2)
+REAL, DIMENSION(klon), INTENT(OUT)      :: PSFTQ ! water flux (kg/m2/s)
+REAL, DIMENSION(klon), INTENT(OUT)      :: PUSTAR! friction velocity (m/s)
+!
+! diagnostics
+REAL, DIMENSION(klon), INTENT(OUT)      :: PQSAT ! humidity at saturation
+REAL, DIMENSION(klon), INTENT(OUT)      :: PCD   ! heat drag coefficient
+REAL, DIMENSION(klon), INTENT(OUT)      :: PCDN  ! momentum drag coefficient
+REAL, DIMENSION(klon), INTENT(OUT)      :: PCH   ! neutral momentum drag coefficient
+REAL, DIMENSION(klon), INTENT(OUT)      :: PCE  !transfer coef. for latent heat flux
+REAL, DIMENSION(klon), INTENT(OUT)      :: PRI   ! Richardson number
+REAL, DIMENSION(klon), INTENT(OUT)      :: PRESA ! aerodynamical resistance
+REAL, DIMENSION(klon), INTENT(OUT)      :: PZ0HSEA ! heat roughness length
+
+LOGICAL,            INTENT(IN)    :: LPRECIP   !
+LOGICAL,            INTENT(IN)    :: LPWG    !
+real, dimension(3), intent(inout)      :: coeffs
+!
+!
+
+!INCLUDE "YOMCST.h"
+!INCLUDE "clesphys.h"
+
+!*      0.2    declarations of local variables
+!
+REAL, DIMENSION(SIZE(PTA))      :: ZVMOD    ! wind intensity
+REAL, DIMENSION(SIZE(PTA))      :: ZPA      ! Pressure at atm. level
+REAL, DIMENSION(SIZE(PTA))      :: ZTA      ! Temperature at atm. level
+REAL, DIMENSION(SIZE(PTA))      :: ZQASAT   ! specific humidity at saturation  at atm. level (kg/kg)
+!
+!rajout
+REAL, DIMENSION(SIZE(PTA))       :: PEXNA      ! Exner function at atm level
+REAL, DIMENSION(SIZE(PTA))       :: PEXNS      ! Exner function at atm level
+!
+REAL, DIMENSION(SIZE(PTA))      :: ZO       ! rougness length ref
+REAL, DIMENSION(SIZE(PTA))      :: ZWG      ! gustiness factor (m/s)
+!
+REAL, DIMENSION(SIZE(PTA))      :: ZDU,ZDT,ZDQ,ZDUWG !differences
+!
+REAL, DIMENSION(SIZE(PTA))      :: ZUSR        !velocity scaling parameter "ustar" (m/s) = friction velocity
+REAL, DIMENSION(SIZE(PTA))      :: ZTSR        !temperature sacling parameter "tstar" (degC)
+REAL, DIMENSION(SIZE(PTA))      :: ZQSR        !humidity scaling parameter "qstar" (kg/kg)
+!
+REAL, DIMENSION(SIZE(PTA))      :: ZU10,ZT10   !vertical profils (10-m height)
+REAL, DIMENSION(SIZE(PTA))      :: ZVISA       !kinematic viscosity of dry air
+REAL, DIMENSION(SIZE(PTA))      :: ZO10,ZOT10  !roughness length at 10m
+REAL, DIMENSION(SIZE(PTA))      :: ZCD,ZCT,ZCC
+REAL, DIMENSION(SIZE(PTA))      :: ZCD10,ZCT10 !transfer coef. at 10m
+REAL, DIMENSION(SIZE(PTA))      :: ZRIBU,ZRIBCU
+REAL, DIMENSION(SIZE(PTA))      :: ZETU,ZL10
+!
+REAL, DIMENSION(SIZE(PTA))      :: ZCHARN                      !Charnock number depends on wind module
+REAL, DIMENSION(SIZE(PTA))      :: ZTWAVE,ZHWAVE,ZCWAVE,ZLWAVE !to compute gravity waves' impact
+!
+REAL, DIMENSION(SIZE(PTA))      :: ZZL,ZZTL!,ZZQL    !Obukhovs stability
+                                                     !param. z/l for u,T,q
+REAL, DIMENSION(SIZE(PTA))      :: ZRR
+REAL, DIMENSION(SIZE(PTA))      :: ZOT,ZOQ           !rougness length ref
+REAL, DIMENSION(SIZE(PTA))      :: ZPUZ,ZPTZ,ZPQZ    !PHI funct. for u,T,q
+!
+REAL, DIMENSION(SIZE(PTA))      :: ZBF               !constants to compute gustiness factor
+!
+REAL, DIMENSION(SIZE(PTA))      :: ZTAU       !momentum flux (W/m2)
+REAL, DIMENSION(SIZE(PTA))      :: ZHF        !sensible heat flux (W/m2)
+REAL, DIMENSION(SIZE(PTA))      :: ZEF        !latent heat flux (W/m2)
+REAL, DIMENSION(SIZE(PTA))      :: ZWBAR      !diag for webb correction but not used here after
+REAL, DIMENSION(SIZE(PTA))      :: ZTAUR      !momentum flux due to rain (W/m2)
+REAL, DIMENSION(SIZE(PTA))      :: ZRF        !sensible heat flux due to rain (W/m2)
+REAL, DIMENSION(SIZE(PTA))      :: ZCHN,ZCEN  !neutral coef. for heat and vapor
+!
+REAL, DIMENSION(SIZE(PTA))      :: ZLV      !latent heat constant
+!
+REAL, DIMENSION(SIZE(PTA))      :: ZTAC,ZDQSDT,ZDTMP,ZDWAT,ZALFAC ! for precipitation impact
+REAL, DIMENSION(SIZE(PTA))      :: ZXLR                           ! vaporisation  heat  at a given temperature
+REAL, DIMENSION(SIZE(PTA))      :: ZCPLW                          ! specific heat for water at a given temperature
+!
+REAL, DIMENSION(SIZE(PTA))      :: ZUSTAR2  ! square of friction velocity
+!
+REAL, DIMENSION(SIZE(PTA))      :: ZDIRCOSZW! orography slope cosine (=1 on water!)
+REAL, DIMENSION(SIZE(PTA))      :: ZAC      ! Aerodynamical conductance
+!
+!
+INTEGER, DIMENSION(SIZE(PTA))   :: ITERMAX             ! maximum number of iterations
+!
+REAL    :: ZRVSRDM1,ZRDSRV,ZR2 ! thermodynamic constants
+REAL    :: ZBETAGUST           !gustiness factor
+REAL    :: ZZBL                !atm. boundary layer depth (m)
+REAL    :: ZVISW               !m2/s kinematic viscosity of water
+REAL    :: ZS                  !height of rougness length ref
+REAL    :: ZCH10               !transfer coef. at 10m
+
+REAL    :: QSAT_SEAWATER
+REAL    :: QSATSEAW_1D
+!
+INTEGER :: J, JLOOP    !loop indice
+!REAL(KIND=JPRB) :: ZHOOK_HANDLE
+
+!--------- Modif Olive -----------------
+REAL, DIMENSION(SIZE(PTA))        :: PRHOA
+REAL, PARAMETER                   :: XUNDEF = 1.E+20
+
+REAL       :: XVCHRNK = 0.021
+REAL       :: XVZ0CM = 1.0E-5
+!REAL       :: XRIMAX
+
+
+INTEGER :: PREF             ! reference pressure for exner function
+INTEGER :: NGRVWAVES        ! Pour le choix du z0
+
+INCLUDE "YOMCST.h"
+INCLUDE "clesphys.h"
+
+!--------------------------------------
+
+
+PRHOA(:) = PPS(:) / (287.1 * PTA(:) * (1.+.61*PQA(:)))
+
+PREF = 100000.                     ! = 1000 hPa
+NGRVWAVES = 1
+
+PEXNA = (PPA/PREF)**(RD/RCPD)
+PEXNS = (PPS/PREF)**(RD/RCPD)
+
+!
+!-------------------------------------------------------------------------------
+!
+!       1.     Initializations
+!              ---------------
+!
+!       1.1   Constants and parameters
+!
+!IF (LHOOK) CALL DR_HOOK('COARE30_FLUX',0,ZHOOK_HANDLE)
+!
+ZRVSRDM1  = XRV/XRD-1. ! 0.607766
+ZRDSRV    = XRD/XRV    ! 0.62198
+ZR2       = 1.-ZRDSRV  ! pas utilisé dans cette routine
+ZBETAGUST = 1.2        ! value based on TOGA-COARE experiment
+ZZBL      = 600.       ! Set a default value for boundary layer depth
+ZS        = 10.        ! Standard heigth =10m
+ZCH10     = 0.00115
+!
+ZVISW     = 1.E-6
+!
+!       1.2   Array initialization by undefined values
+!
+PSFTH (:)=XUNDEF
+PSFTQ (:)=XUNDEF
+PUSTAR(:)=XUNDEF
+!
+PCD(:) = XUNDEF
+PCDN(:) = XUNDEF
+PCH(:) = XUNDEF
+PCE(:) =XUNDEF
+PRI(:) = XUNDEF
+!
+PRESA(:)=XUNDEF
+!
+!-------------------------------------------------------------------------------
+!       2. INITIAL GUESS FOR THE ITERATIVE METHOD
+!          -------------------------------------
+!
+!       2.0     Temperature
+!
+! Set a non-zero value for the temperature gradient
+!
+WHERE((PTA(:)*PEXNS(:)/PEXNA(:)-PSST(:))==0.)
+      ZTA(:)=PTA(:)-1E-3
+ELSEWHERE
+      ZTA(:)=PTA(:)
+ENDWHERE
+
+!       2.1     Wind and humidity
+!
+! Sea surface specific humidity
+!
+!PQSAT(:)=QSAT_SEAWATER(PSST(:),PPS(:))
+PQSAT(:)=QSATSEAW_1D(PSST(:),PPS(:))
+
+
+
+!
+! Set a minimum value to wind
+!
+!ZVMOD(:) = WIND_THRESHOLD(PVMOD(:),PUREF(:))
+
+
+ZVMOD = MAX(PVMOD , 0.1 * MIN(10.,PUREF) )    !set a minimum value to wind
+!ZVMOD = PVMOD    !set a minimum value to wind
+
+!
+! Specific humidity at saturation at the atm. level
+!
+ZPA(:) = XP00* (PEXNA(:)**(XCPD/XRD))
+!ZQASAT(:) = QSAT_SEAWATER(ZTA(:),ZPA(:))
+ZQASAT = QSATSEAW_1D(ZTA(:),ZPA(:))
+
+
+!
+!
+ZO(:)  = 0.0001
+ZWG(:) = 0.
+IF (LPWG) ZWG(:) = 0.5
+!
+ZCHARN(:) = 0.011
+!
+DO J=1,SIZE(PTA)
+  !
+  !      2.2       initial guess
+  !
+  ZDU(J) = ZVMOD(J)   !wind speed difference with surface current(=0) (m/s)
+                      !initial guess for gustiness factor
+  ZDT(J) = -(ZTA(J)/PEXNA(J)) + (PSST(J)/PEXNS(J)) !potential temperature difference
+  ZDQ(J) = PQSAT(J)-PQA(J)                         !specific humidity difference
+  !
+  ZDUWG(J) = SQRT(ZDU(J)**2+ZWG(J)**2)     !wind speed difference including gustiness ZWG
+  !
+  !      2.3   initialization of neutral coefficients
+  !
+  ZU10(J)  = ZDUWG(J)*LOG(ZS/ZO(J))/LOG(PUREF(J)/ZO(J))
+  ZUSR(J)  = 0.035*ZU10(J)
+  ZVISA(J) = 1.326E-5*(1.+6.542E-3*(ZTA(J)-XTT)+&
+             8.301E-6*(ZTA(J)-XTT)**2-4.84E-9*(ZTA(J)-XTT)**3) !Andrea (1989) CRREL Rep. 89-11
+  !
+  ZO10(J) = ZCHARN(J)*ZUSR(J)*ZUSR(J)/XG+0.11*ZVISA(J)/ZUSR(J)
+  ZCD(J)  = (XKARMAN/LOG(PUREF(J)/ZO10(J)))**2  !drag coefficient
+  ZCD10(J)= (XKARMAN/LOG(ZS/ZO10(J)))**2
+  ZCT10(J)= ZCH10/SQRT(ZCD10(J))
+  ZOT10(J)= ZS/EXP(XKARMAN/ZCT10(J))
+  !
+  !-------------------------------------------------------------------------------
+  !             Grachev and Fairall (JAM, 1997)
+  ZCT(J) = XKARMAN/LOG(PZREF(J)/ZOT10(J))      !temperature transfer coefficient
+  ZCC(J) = XKARMAN*ZCT(J)/ZCD(J)               !z/L vs Rib linear coef.
+  !
+  ZRIBCU(J) = -PUREF(J)/(ZZBL*0.004*ZBETAGUST**3) !saturation or plateau Rib
+  !ZRIBU(J) =-XG*PUREF(J)*(ZDT(J)+ZRVSRDM1*(ZTA(J)-XTT)*ZDQ)/&
+  !     &((ZTA(J)-XTT)*ZDUWG(J)**2)
+  ZRIBU(J)  = -XG*PUREF(J)*(ZDT(J)+ZRVSRDM1*ZTA(J)*ZDQ(J))/&
+               (ZTA(J)*ZDUWG(J)**2)
+  !
+  IF (ZRIBU(J)<0.) THEN
+    ZETU(J) = ZCC(J)*ZRIBU(J)/(1.+ZRIBU(J)/ZRIBCU(J))    !Unstable G and F
+  ELSE
+    ZETU(J) = ZCC(J)*ZRIBU(J)/(1.+27./9.*ZRIBU(J)/ZCC(J))!Stable
+  ENDIF
+  !
+  ZL10(J) = PUREF(J)/ZETU(J) !MO length
+  !
+ENDDO
+!
+!  First guess M-O stability dependent scaling params. (u*,T*,q*) to estimate ZO and z/L (ZZL)
+ZUSR(:) = ZDUWG(:)*XKARMAN/(LOG(PUREF(:)/ZO10(:))-PSIFCTU(PUREF(1)/ZL10(1)))
+ZTSR(:) = -ZDT(:)*XKARMAN/(LOG(PZREF(:)/ZOT10(:))-PSIFCTT(PZREF(1)/ZL10(1)))
+ZQSR(:) = -ZDQ(:)*XKARMAN/(LOG(PZREF(:)/ZOT10(:))-PSIFCTT(PZREF(1)/ZL10(1)))
+!
+ZZL(:) = 0.0
+!
+DO J=1,SIZE(PTA)
+  !
+  IF (ZETU(J)>50.) THEN
+    ITERMAX(J) = 1
+  ELSE
+    ITERMAX(J) = 3 !number of iterations
+  ENDIF
+  !
+  !then modify Charnork for high wind speeds Chris Fairall's data
+  IF (ZDUWG(J)>10.) ZCHARN(J) = 0.011 + (0.018-0.011)*(ZDUWG(J)-10.)/(18.-10.)
+  IF (ZDUWG(J)>18.) ZCHARN(J) = 0.018
+  !
+  !                3.  ITERATIVE LOOP TO COMPUTE USR, TSR, QSR
+  !                -------------------------------------------
+  !
+  ZHWAVE(J) = 0.018*ZVMOD(J)*ZVMOD(J)*(1.+0.015*ZVMOD(J))
+  ZTWAVE(J) = 0.729*ZVMOD(J)
+  ZCWAVE(J) = XG*ZTWAVE(J)/(2.*XPI)
+  ZLWAVE(J) = ZTWAVE(J)*ZCWAVE(J)
+  !
+ENDDO
+!
+
+!
+DO JLOOP=1,MAXVAL(ITERMAX) ! begin of iterative loop
+  !
+  DO J=1,SIZE(PTA)
+    !
+    IF (JLOOP>ITERMAX(J)) CYCLE
+    !
+    IF (NGRVWAVES==0) THEN
+      ZO(J) = ZCHARN(J)*ZUSR(J)*ZUSR(J)/XG + 0.11*ZVISA(J)/ZUSR(J) !Smith 1988
+    ELSE IF (NGRVWAVES==1) THEN
+      ZO(J) = (50./(2.*XPI))*ZLWAVE(J)*(ZUSR(J)/ZCWAVE(J))**4.5 &
+              + 0.11*ZVISA(J)/ZUSR(J)                       !Oost et al. 2002
+    ELSE IF (NGRVWAVES==2) THEN
+      ZO(J) = 1200.*ZHWAVE(J)*(ZHWAVE(J)/ZLWAVE(J))**4.5 &
+              + 0.11*ZVISA(J)/ZUSR(J)                       !Taulor and Yelland 2001
+    ENDIF
+    !
+    ZRR(J) = ZO(J)*ZUSR(J)/ZVISA(J)
+    ZOQ(J) = MIN(1.15E-4 , 5.5E-5/ZRR(J)**0.6)
+    ZOT(J) = ZOQ(J)
+    !
+    ZZL(J) = XKARMAN * XG * PUREF(J) * &
+              ( ZTSR(J)*(1.+ZRVSRDM1*PQA(J)) + ZRVSRDM1*ZTA(J)*ZQSR(J) ) / &
+              ( ZTA(J)*ZUSR(J)*ZUSR(J)*(1.+ZRVSRDM1*PQA(J)) )
+    ZZTL(J)= ZZL(J)*PZREF(J)/PUREF(J)  ! for T
+!    ZZQL(J)=ZZL(J)*PZREF(J)/PUREF(J)  ! for Q
+  ENDDO
+  !
+  ZPUZ(:) = PSIFCTU(ZZL(1))
+  ZPTZ(:) = PSIFCTT(ZZTL(1))
+  !
+  DO J=1,SIZE(PTA)
+    !
+    ! ZPQZ(J)=PSIFCTT(ZZQL(J))
+    ZPQZ(J) = ZPTZ(J)
+    !
+    !             3.1 scale parameters
+    !
+    ZUSR(J) = ZDUWG(J)*XKARMAN/(LOG(PUREF(J)/ZO(J)) -ZPUZ(J))
+    ZTSR(J) = -ZDT(J)  *XKARMAN/(LOG(PZREF(J)/ZOT(J))-ZPTZ(J))
+    ZQSR(J) = -ZDQ(J)  *XKARMAN/(LOG(PZREF(J)/ZOQ(J))-ZPQZ(J))
+    !
+    !             3.2 Gustiness factor (ZWG)
+    !
+    IF(LPWG) THEN
+      ZBF(J) = -XG/ZTA(J)*ZUSR(J)*(ZTSR(J)+ZRVSRDM1*ZTA(J)*ZQSR(J))
+      IF (ZBF(J)>0.) THEN
+        ZWG(J) = ZBETAGUST*(ZBF(J)*ZZBL)**(1./3.)
+      ELSE
+        ZWG(J) = 0.2
+      ENDIF
+    ENDIF
+    ZDUWG(J) = SQRT(ZVMOD(J)**2 + ZWG(J)**2)
+    !
+  ENDDO
+  !
+ENDDO
+!-------------------------------------------------------------------------------
+!
+!            4.  COMPUTE transfer coefficients PCD, PCH, ZCE and SURFACE FLUXES
+!                --------------------------------------------------------------
+!
+ZTAU(:) = XUNDEF
+ZHF(:)  = XUNDEF
+ZEF(:)  = XUNDEF
+!
+ZWBAR(:) = 0.
+ZTAUR(:) = 0.
+ZRF(:)   = 0.
+!
+DO J=1,SIZE(PTA)
+  !
+  !
+  !            4. transfert coefficients PCD, PCH and PCE
+  !                 and neutral PCDN, ZCHN, ZCEN
+  !
+  PCD(J) = (ZUSR(J)/ZDUWG(J))**2.
+  PCH(J) = ZUSR(J)*ZTSR(J)/(ZDUWG(J)*(ZTA(J)*PEXNS(J)/PEXNA(J)-PSST(J)))
+  PCE(J) = ZUSR(J)*ZQSR(J)/(ZDUWG(J)*(PQA(J)-PQSAT(J)))
+  !
+  PCDN(J) = (XKARMAN/LOG(ZS/ZO(J)))**2.
+  ZCHN(J) = (XKARMAN/LOG(ZS/ZO(J)))*(XKARMAN/LOG(ZS/ZOT(J)))
+  ZCEN(J) = (XKARMAN/LOG(ZS/ZO(J)))*(XKARMAN/LOG(ZS/ZOQ(J)))
+  !
+  ZLV(J) = XLVTT + (XCPV-XCL)*(PSST(J)-XTT)
+  !
+  !            4. 2 surface fluxes
+  !
+  IF (ABS(PCDN(J))>1.E-2) THEN   !!!! secure COARE3.0 CODE
+    write(*,*) 'pb PCDN in COARE30: ',PCDN(J)
+    write(*,*) 'point: ',J,"/",SIZE(PTA)
+    write(*,*) 'roughness: ', ZO(J)
+    write(*,*) 'ustar: ',ZUSR(J)
+    write(*,*) 'wind: ',ZDUWG(J)
+    CALL abort_physic('COARE30',': PCDN too large -> no convergence',1)
+  ELSE
+    ZTSR(J) = -ZTSR(J)
+    ZQSR(J) = -ZQSR(J)
+    ZTAU(J) = -PRHOA(J)*ZUSR(J)*ZUSR(J)*ZVMOD(J)/ZDUWG(J)
+    ZHF(J)  =  PRHOA(J)*XCPD*ZUSR(J)*ZTSR(J)
+    ZEF(J)  =  PRHOA(J)*ZLV(J)*ZUSR(J)*ZQSR(J)
+    !
+    !           4.3 Contributions to surface  fluxes due to rainfall
+    !
+    ! SB: a priori, le facteur ZRDSRV=XRD/XRV est introduit pour
+    !     adapter la formule de Clausius-Clapeyron (pour l'air
+    !     sec) au cas humide.
+    IF (LPRECIP) THEN
+      !
+      ! heat surface  fluxes
+      !
+      ZTAC(J)  = ZTA(J)-XTT
+      !
+      ZXLR(J)  = XLVTT + (XCPV-XCL)* ZTAC(J)                            ! latent heat of rain vaporization
+      ZDQSDT(J)= ZQASAT(J) * ZXLR(J) / (XRD*ZTA(J)**2)                  ! Clausius-Clapeyron relation
+      ZDTMP(J) = (1.0 + 3.309e-3*ZTAC(J) -1.44e-6*ZTAC(J)*ZTAC(J)) * &  !heat diffusivity
+                  0.02411 / (PRHOA(J)*XCPD)
+      !
+      ZDWAT(J) = 2.11e-5 * (XP00/ZPA(J)) * (ZTA(J)/XTT)**1.94           ! water vapour diffusivity from eq (13.3)
+      !                                                                 ! of Pruppacher and Klett (1978)
+      ZALFAC(J)= 1.0 / (1.0 + &                                         ! Eq.11 in GoF95
+                   ZRDSRV*ZDQSDT(J)*ZXLR(J)*ZDWAT(J)/(ZDTMP(J)*XCPD))   ! ZALFAC=wet-bulb factor (sans dim)
+      ZCPLW(J) = 4224.8482 + ZTAC(J) * &
+                              ( -4.707 + ZTAC(J) * &
+                                (0.08499 + ZTAC(J) * &
+                                  (1.2826e-3 + ZTAC(J) * &
+                                    (4.7884e-5 - 2.0027e-6* ZTAC(J))))) ! specific heat
+      !
+      ZRF(J)   = PRAIN(J) * ZCPLW(J) * ZALFAC(J) * &                    !Eq.12 in GoF95 !SIGNE?
+                   (PSST(J) - ZTA(J) + (PQSAT(J)-PQA(J))*ZXLR(J)/XCPD )
+      !
+      ! Momentum flux due to rainfall
+      !
+      ZTAUR(J)=-0.85*(PRAIN(J) *ZVMOD(J)) !pp3752 in FBR96
+      !
+    ENDIF
+    !
+    !             4.4   Webb correction to latent heat flux
+    !
+    ZWBAR(J)=- (1./ZRDSRV)*ZUSR(J)*ZQSR(J) / (1.0+(1./ZRDSRV)*PQA(J)) &
+               - ZUSR(J)*ZTSR(J)/ZTA(J)                        ! Eq.21*rhoa in FBR96
+    !
+    !             4.5   friction velocity which contains correction du to rain
+    !
+    ZUSTAR2(J)= - (ZTAU(J) + ZTAUR(J)) / PRHOA(J)
+    PUSTAR(J) =  SQRT(ZUSTAR2(J))
+    !
+    !             4.6   Total surface fluxes
+    !
+    PSFTH (J) =  ZHF(J) + ZRF(J)
+    PSFTQ (J) =  ZEF(J) / ZLV(J)
+    !
+  ENDIF
+ENDDO
+
+
+coeffs = [PCD,&
+       PCE,&
+       PCH]
+
+!-------------------------------------------------------------------------------
+!
+!       5.  FINAL STEP : TOTAL SURFACE FLUXES AND DERIVED DIAGNOSTICS
+!           -----------
+!       5.1    Richardson number
+!
+!
+!------------STOP LA --------------------
+!ZDIRCOSZW(:) = 1.
+! CALL SURFACE_RI(PSST,PQSAT,PEXNS,PEXNA,ZTA,ZQASAT,&
+!                PZREF,PUREF,ZDIRCOSZW,PVMOD,PRI   )
+!!
+!!       5.2     Aerodynamical conductance and resistance
+!!
+!ZAC(:) = PCH(:)*ZVMOD(:)
+!PRESA(:) = 1. / MAX(ZAC(:),XSURF_EPSILON)
+!
+!!       5.3 Z0 and Z0H over sea
+!!
+!PZ0SEA(:) =  ZCHARN(:) * ZUSTAR2(:) / XG + XVZ0CM * PCD(:) / PCDN(:)
+!!
+!!PZ0HSEA(:) = PZ0SEA(:)
+!!
+!IF (LHOOK) CALL DR_HOOK('COARE30_FLUX',1,ZHOOK_HANDLE)
+!
+!-------------------------------------------------------------------------------
+!
+END SUBROUTINE COARE30_FLUX_CNRM
+
+end module coare30_flux_cnrm_mod
Index: DZ6/trunk/libf/phylmd/coare_cp_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/coare_cp_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,249 +1,0 @@
-module coare_cp_mod
-  implicit none
-  private
-  public psit_30, psiuo, coare_cp
-
-contains
-
-  real function psit_30(zet)
-    implicit none
-    real, intent(in) :: zet
-
-    real :: x, psik, psic, f, c
-
-    if(zet<0) then
-      x=(1.-(15.*zet))**.5
-      psik=2.*log((1.+x)/2)
-      x=(1.-(34.15*zet))**.3333
-      psic=1.5*log((1.+x+x*x)/3.)-sqrt(3.)*atan((1.+2.*x)/sqrt(3.))+4.*atan(1.)/sqrt(3.)
-      f=zet*zet/(1.+zet*zet)
-      psit_30=(1.-f)*psik+f*psic
-    else
-      c=min(50.,.35*zet)
-      psit_30=-((1.+2./3.*zet)**1.5+.6667*(zet-14.28)/exp(c)+8.525)
-    endif
-
-  end function psit_30
-
-  real function psiuo(zet)
-    implicit none
-    real, intent(in) :: zet
-
-    real :: x, psik, psic, f, c
-
-    if (zet<0) then
-       x=(1.-15.*zet)**.25
-       psik=2.*log((1.+x)/2.)+log((1.+x*x)/2.)-2.*atan(x)+2.*atan(1.)
-       x=(1.-10.15*zet)**.3333
-       psic=1.5*log((1.+x+x*x)/3.)-sqrt(3.)*atan((1.+2.*x)/sqrt(3.))+4.*atan(1.)/sqrt(3.)
-       f=zet*zet/(1+zet*zet)
-       psiuo=(1-f)*psik+f*psic
-    else
-     c=min(50.,.35*zet)
-     psiuo=-((1.+1.0*zet)**1.0+.667*(zet-14.28)/exp(c)+8.525)
-  endif
-
-end function psiuo
-
-
-subroutine coare_cp(du,dt,dq,&
-     t,q,&
-     zu,zt,zq,&
-     p,zi,&
-     nits,&
-     coeffs,rugosm,rugosh)
-  !     zo,tau,hsb,hlb,&
-  !     var)
-  !version with shortened iteration  modified Rt and Rq
-  !uses wave information wave period in s and wave ht in m
-  !no wave, standard coare 2.6 charnock:  jwave=0
-  !Oost et al.  zo=50/2/pi L (u*/c)**4.5 if jwave=1
-  !taylor and yelland  zo=1200 h*(L/h)**4.5 jwave=2
-  !
-  USE MODD_CSTS,       ONLY : XKARMAN, XG, XSTEFAN, XRD, XRV, XPI, &
-                            XLVTT, XCL, XCPD, XCPV, XRHOLW, XTT, &
-                            XP00
-
-  IMPLICIT NONE
-
-  real, intent(in) :: du,dt,dq,t,q
-  real, intent(in) :: zu,zt,zq,p,zi
-  integer, intent(in) :: nits
-  ! real, dimension (nits), intent(out) :: zo,tau,hsb,hlb
-  ! real, dimension(nits,3), intent(out) :: var
-  real, dimension(3), intent(out) :: coeffs
-  real, intent(out) :: rugosm
-  real, intent(out) :: rugosh
-
-  real, parameter ::  beta=1.2, von=.4, fdg = 1. ,&
-       tdk = 273.16, pi = 3.141593, grav = 9.82,&
-       rgas = 287.1
-
-  integer, dimension(3) :: shape_input
-
-  real bf, cc, rhoa, visa,&
-       u10, ut, uts, ut0, ug,&
-       cd10, ch10, ct, ct10,&
-       charn, ribu,&
-       l, l10, &
-       ribcu,rr,&
-       zet,zetu, zom10, zoh10, zot, zoq, zot10,&
-       cd, ch, le, cpa, cpv,&
-       usr,qsr,tsr,&
-       zom, t_c
-
-!, ZTWAVE, ZHWAVE, ZCWAVE, ZLWAVE
-
-
-
-
-  real old_usr, old_tsr, old_qsr,tmp
-
-  real, external :: grv
-  integer i,j,k
-!---------------- Rajout pour prendre en compte différent Z0 --------------------------------!
-!  INTEGER :: NGRVWAVES        ! Pour le choix du z0
-!  NGRVWAVES = 2
-!---------------------------------------------------------------------------------------------
-!-------------------- Attention Modif réalisée pas SURRR -------------------------------------
-!---------------------------------------------------------------------------------------------
-
-  Ribcu=-zu/zi/.004/Beta**3
-  cpa=1004.67
-
-  t_c = t - 273.15
-
-
-  Le=(2.501-.00237*(t_c-dt))*1e6
-
-
-  visa=1.326e-5*(1+6.542e-3*(t_c)+8.301e-6*t_c**2-4.84e-9*t_c**3)
-
-
-  cpv=cpa*(1+0.84*Q)
-  rhoa=P/(Rgas*t*(1+0.61*Q))
-
-
-
-
-
-
-  ug=.2
-
-  ut=sqrt(du*du+ug*ug)
-  ut=MAX(ut , 0.1 * MIN(10.,zu) )
-
-  u10=ut*log(10/1e-4)/log(zu/1e-4)
-  usr=.035*u10                              ! turbulent friction velocity (m/s), including gustiness
-  zom10=0.011*usr*usr/grav+0.11*visa/usr     ! roughness length for u (smith 88)
-  Cd10=(von/log(10/zom10))**2
-!  zoh10=0.40*visa/usr+1.4e-5
-!  Ch10=((von**2)/((log(10/zom10))*(log(10/zoh10)))) !ammener à devenir ca
-  Ch10=0.00115
-  Ct10=Ch10/sqrt(Cd10)
-  zot10=10/exp(von/Ct10)                    ! roughness length for t
-  Cd=(von/log(zu/zom10))**2
-  Ct=von/log(zt/zot10)
-  CC=von*Ct/Cd
-
-  ut0 = ut
-
-
-  ut = ut0
-  Ribu=grav*zu/t*(dt+.61*t*dq)/ut**2
-
-  if (Ribu < 0) then
-     zetu=CC*Ribu/(1+Ribu/Ribcu)
-  else
-     zetu=CC*Ribu*(1+27/9*Ribu/CC)
-  endif
-
-  L10=zu/zetu
-
-  ! if (zetu .GT. 50) then
-  !    nits=1
-  ! endif
-
-  usr=ut*von/(log(zu/zom10)-psiuo(zetu))
-  tsr=dt*von*fdg/(log(zt/zot10)-psit_30(zt/L10))
-  qsr=dq*von*fdg/(log(zq/zot10)-psit_30(zq/L10))
-  !  tkt=.001
-
-  ! charnock constant - lin par morceau - constant
-  if ( ut <= 10. ) then
-     charn=0.011
-  else
-     if (ut > 18) then
-        charn=0.018
-     else
-        charn=0.011+(ut-10)/(18-10)*(0.018-0.011)
-     endif
-  endif
-
-!  ZHWAVE = 0.018*ut*ut*(1.+0.015*ut)
-!  ZTWAVE = 0.729*ut
-!  ZCWAVE = XG*ZTWAVE/(2.*pi)
-!  ZLWAVE = ZTWAVE*ZCWAVE
-
-
-  !***************  bulk loop ************
-  do i=1, nits
-
-     zet=von*grav*zu/t*(tsr*(1+0.61*Q)+.61*t*qsr)/(usr*usr)/(1+0.61*Q)
-
-!     IF (NGRVWAVES==0) THEN
-!       zom = charn*usr*usr/XG + 0.11*visa/usr !Smith 1988
-!     ELSE IF (NGRVWAVES==1) THEN
-!       zom = (50./(2.*pi))*ZLWAVE*(usr/ZCWAVE)**4.5 &
-!               + 0.11*visa/usr                       !Oost et al. 2002
-!     ELSE IF (NGRVWAVES==2) THEN
-!       zom = 1200.*ZHWAVE*(ZHWAVE/ZLWAVE)**4.5 &
-!               + 0.11*visa/usr                       !Taulor and Yelland 2001
-!     ENDIF
-
-     zom=charn*usr*usr/grav+0.11*visa/usr
-
-     rr=zom*usr/visa
-     L=zu/zet
-     zoq=min(1.15e-4,5.5e-5/rr**.6)  ! a modifier
-     zot=zoq                         ! a modifier
-!     zot=0.40*visa/usr+1.4e-5
-
-     old_usr = usr
-     old_tsr = tsr
-     old_qsr = qsr
-
-     usr=ut*von/(log(zu/zom)-psiuo(zu/L))
-     tsr=dt*von*fdg/(log(zt/zot)-psit_30(zt/L))
-     qsr=dq*von*fdg/(log(zq/zoq)-psit_30(zq/L))
-
-     Bf=-grav/t*usr*(tsr+.61*t*qsr)
-
-     if (Bf > 0) then
-        ug=Beta*(Bf*zi)**.333
-     else
-        ug=.2
-     endif
-
-     ut=sqrt(du*du+ug*ug)
-     ut=MAX(ut , 0.1 * MIN(10.,zu) )
-
-
-  enddo !bulk iter loop
-
-  ! coeffs(m1,m2,m3,m4,m5,1)=rhoa*usr*usr*du/ut !stress
-  ! coeffs(m1,m2,m3,m4,m5,2)=rhoa*cpa*usr*tsr
-  ! coeffs(m1,m2,m3,m4,m5,3)=rhoa*Le*usr*qsr
-
-  tmp = (von/(log(zu/zom)-psiuo(zu/L)) ) * ut / du
-
-  coeffs = [tmp**2,&
-       von*fdg/(log(zt/zot)-psit_30(zt/L)) * tmp,&
-       von*fdg/(log(zq/zoq)-psit_30(zq/L)) * tmp]
-
-  rugosm = zom
-  rugosh = zot
-
-end subroutine coare_cp
-
-end module coare_cp_mod
Index: /LMDZ6/trunk/libf/phylmd/coare_cp_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/coare_cp_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/coare_cp_mod.f90	(revision 5268)
@@ -0,0 +1,249 @@
+module coare_cp_mod
+  implicit none
+  private
+  public psit_30, psiuo, coare_cp
+
+contains
+
+  real function psit_30(zet)
+    implicit none
+    real, intent(in) :: zet
+
+    real :: x, psik, psic, f, c
+
+    if(zet<0) then
+      x=(1.-(15.*zet))**.5
+      psik=2.*log((1.+x)/2)
+      x=(1.-(34.15*zet))**.3333
+      psic=1.5*log((1.+x+x*x)/3.)-sqrt(3.)*atan((1.+2.*x)/sqrt(3.))+4.*atan(1.)/sqrt(3.)
+      f=zet*zet/(1.+zet*zet)
+      psit_30=(1.-f)*psik+f*psic
+    else
+      c=min(50.,.35*zet)
+      psit_30=-((1.+2./3.*zet)**1.5+.6667*(zet-14.28)/exp(c)+8.525)
+    endif
+
+  end function psit_30
+
+  real function psiuo(zet)
+    implicit none
+    real, intent(in) :: zet
+
+    real :: x, psik, psic, f, c
+
+    if (zet<0) then
+       x=(1.-15.*zet)**.25
+       psik=2.*log((1.+x)/2.)+log((1.+x*x)/2.)-2.*atan(x)+2.*atan(1.)
+       x=(1.-10.15*zet)**.3333
+       psic=1.5*log((1.+x+x*x)/3.)-sqrt(3.)*atan((1.+2.*x)/sqrt(3.))+4.*atan(1.)/sqrt(3.)
+       f=zet*zet/(1+zet*zet)
+       psiuo=(1-f)*psik+f*psic
+    else
+     c=min(50.,.35*zet)
+     psiuo=-((1.+1.0*zet)**1.0+.667*(zet-14.28)/exp(c)+8.525)
+  endif
+
+end function psiuo
+
+
+subroutine coare_cp(du,dt,dq,&
+     t,q,&
+     zu,zt,zq,&
+     p,zi,&
+     nits,&
+     coeffs,rugosm,rugosh)
+  !     zo,tau,hsb,hlb,&
+  !     var)
+  !version with shortened iteration  modified Rt and Rq
+  !uses wave information wave period in s and wave ht in m
+  !no wave, standard coare 2.6 charnock:  jwave=0
+  !Oost et al.  zo=50/2/pi L (u*/c)**4.5 if jwave=1
+  !taylor and yelland  zo=1200 h*(L/h)**4.5 jwave=2
+  !
+  USE MODD_CSTS,       ONLY : XKARMAN, XG, XSTEFAN, XRD, XRV, XPI, &
+                            XLVTT, XCL, XCPD, XCPV, XRHOLW, XTT, &
+                            XP00
+
+  IMPLICIT NONE
+
+  real, intent(in) :: du,dt,dq,t,q
+  real, intent(in) :: zu,zt,zq,p,zi
+  integer, intent(in) :: nits
+  ! real, dimension (nits), intent(out) :: zo,tau,hsb,hlb
+  ! real, dimension(nits,3), intent(out) :: var
+  real, dimension(3), intent(out) :: coeffs
+  real, intent(out) :: rugosm
+  real, intent(out) :: rugosh
+
+  real, parameter ::  beta=1.2, von=.4, fdg = 1. ,&
+       tdk = 273.16, pi = 3.141593, grav = 9.82,&
+       rgas = 287.1
+
+  integer, dimension(3) :: shape_input
+
+  real bf, cc, rhoa, visa,&
+       u10, ut, uts, ut0, ug,&
+       cd10, ch10, ct, ct10,&
+       charn, ribu,&
+       l, l10, &
+       ribcu,rr,&
+       zet,zetu, zom10, zoh10, zot, zoq, zot10,&
+       cd, ch, le, cpa, cpv,&
+       usr,qsr,tsr,&
+       zom, t_c
+
+!, ZTWAVE, ZHWAVE, ZCWAVE, ZLWAVE
+
+
+
+
+  real old_usr, old_tsr, old_qsr,tmp
+
+  real, external :: grv
+  integer i,j,k
+!---------------- Rajout pour prendre en compte différent Z0 --------------------------------!
+!  INTEGER :: NGRVWAVES        ! Pour le choix du z0
+!  NGRVWAVES = 2
+!---------------------------------------------------------------------------------------------
+!-------------------- Attention Modif réalisée pas SURRR -------------------------------------
+!---------------------------------------------------------------------------------------------
+
+  Ribcu=-zu/zi/.004/Beta**3
+  cpa=1004.67
+
+  t_c = t - 273.15
+
+
+  Le=(2.501-.00237*(t_c-dt))*1e6
+
+
+  visa=1.326e-5*(1+6.542e-3*(t_c)+8.301e-6*t_c**2-4.84e-9*t_c**3)
+
+
+  cpv=cpa*(1+0.84*Q)
+  rhoa=P/(Rgas*t*(1+0.61*Q))
+
+
+
+
+
+
+  ug=.2
+
+  ut=sqrt(du*du+ug*ug)
+  ut=MAX(ut , 0.1 * MIN(10.,zu) )
+
+  u10=ut*log(10/1e-4)/log(zu/1e-4)
+  usr=.035*u10                              ! turbulent friction velocity (m/s), including gustiness
+  zom10=0.011*usr*usr/grav+0.11*visa/usr     ! roughness length for u (smith 88)
+  Cd10=(von/log(10/zom10))**2
+!  zoh10=0.40*visa/usr+1.4e-5
+!  Ch10=((von**2)/((log(10/zom10))*(log(10/zoh10)))) !ammener à devenir ca
+  Ch10=0.00115
+  Ct10=Ch10/sqrt(Cd10)
+  zot10=10/exp(von/Ct10)                    ! roughness length for t
+  Cd=(von/log(zu/zom10))**2
+  Ct=von/log(zt/zot10)
+  CC=von*Ct/Cd
+
+  ut0 = ut
+
+
+  ut = ut0
+  Ribu=grav*zu/t*(dt+.61*t*dq)/ut**2
+
+  if (Ribu < 0) then
+     zetu=CC*Ribu/(1+Ribu/Ribcu)
+  else
+     zetu=CC*Ribu*(1+27/9*Ribu/CC)
+  endif
+
+  L10=zu/zetu
+
+  ! if (zetu .GT. 50) then
+  !    nits=1
+  ! endif
+
+  usr=ut*von/(log(zu/zom10)-psiuo(zetu))
+  tsr=dt*von*fdg/(log(zt/zot10)-psit_30(zt/L10))
+  qsr=dq*von*fdg/(log(zq/zot10)-psit_30(zq/L10))
+  !  tkt=.001
+
+  ! charnock constant - lin par morceau - constant
+  if ( ut <= 10. ) then
+     charn=0.011
+  else
+     if (ut > 18) then
+        charn=0.018
+     else
+        charn=0.011+(ut-10)/(18-10)*(0.018-0.011)
+     endif
+  endif
+
+!  ZHWAVE = 0.018*ut*ut*(1.+0.015*ut)
+!  ZTWAVE = 0.729*ut
+!  ZCWAVE = XG*ZTWAVE/(2.*pi)
+!  ZLWAVE = ZTWAVE*ZCWAVE
+
+
+  !***************  bulk loop ************
+  do i=1, nits
+
+     zet=von*grav*zu/t*(tsr*(1+0.61*Q)+.61*t*qsr)/(usr*usr)/(1+0.61*Q)
+
+!     IF (NGRVWAVES==0) THEN
+!       zom = charn*usr*usr/XG + 0.11*visa/usr !Smith 1988
+!     ELSE IF (NGRVWAVES==1) THEN
+!       zom = (50./(2.*pi))*ZLWAVE*(usr/ZCWAVE)**4.5 &
+!               + 0.11*visa/usr                       !Oost et al. 2002
+!     ELSE IF (NGRVWAVES==2) THEN
+!       zom = 1200.*ZHWAVE*(ZHWAVE/ZLWAVE)**4.5 &
+!               + 0.11*visa/usr                       !Taulor and Yelland 2001
+!     ENDIF
+
+     zom=charn*usr*usr/grav+0.11*visa/usr
+
+     rr=zom*usr/visa
+     L=zu/zet
+     zoq=min(1.15e-4,5.5e-5/rr**.6)  ! a modifier
+     zot=zoq                         ! a modifier
+!     zot=0.40*visa/usr+1.4e-5
+
+     old_usr = usr
+     old_tsr = tsr
+     old_qsr = qsr
+
+     usr=ut*von/(log(zu/zom)-psiuo(zu/L))
+     tsr=dt*von*fdg/(log(zt/zot)-psit_30(zt/L))
+     qsr=dq*von*fdg/(log(zq/zoq)-psit_30(zq/L))
+
+     Bf=-grav/t*usr*(tsr+.61*t*qsr)
+
+     if (Bf > 0) then
+        ug=Beta*(Bf*zi)**.333
+     else
+        ug=.2
+     endif
+
+     ut=sqrt(du*du+ug*ug)
+     ut=MAX(ut , 0.1 * MIN(10.,zu) )
+
+
+  enddo !bulk iter loop
+
+  ! coeffs(m1,m2,m3,m4,m5,1)=rhoa*usr*usr*du/ut !stress
+  ! coeffs(m1,m2,m3,m4,m5,2)=rhoa*cpa*usr*tsr
+  ! coeffs(m1,m2,m3,m4,m5,3)=rhoa*Le*usr*qsr
+
+  tmp = (von/(log(zu/zom)-psiuo(zu/L)) ) * ut / du
+
+  coeffs = [tmp**2,&
+       von*fdg/(log(zt/zot)-psit_30(zt/L)) * tmp,&
+       von*fdg/(log(zq/zoq)-psit_30(zq/L)) * tmp]
+
+  rugosm = zom
+  rugosh = zot
+
+end subroutine coare_cp
+
+end module coare_cp_mod
Index: DZ6/trunk/libf/phylmd/coef_diff_turb_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/coef_diff_turb_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,606 +1,0 @@
-!
-MODULE coef_diff_turb_mod
-!
-! This module contains some procedures for calculation of the coefficients of the
-! turbulent diffusion in the atmosphere and coefficients for turbulent diffusion 
-! at surface(cdrag)
-!
-  IMPLICIT NONE
-  
-CONTAINS
-!
-!****************************************************************************************
-!
-  SUBROUTINE coef_diff_turb(dtime, nsrf, knon, ni, &
-       ypaprs, ypplay, yu, yv, yq, yt, yts, yqsurf, ycdragm, &
-       ycoefm, ycoefh ,yq2, yeps, ydrgpro)
- 
-    USE dimphy
-    USE indice_sol_mod
-    USE print_control_mod, ONLY: prt_level, lunout
-!
-! Calculate coefficients(ycoefm, ycoefh) for turbulent diffusion in the 
-! atmosphere 
-! NB! No values are calculated between surface and the first model layer. 
-!     ycoefm(:,1) and ycoefh(:,1) are not valid !!!
-!
-!
-! Input arguments
-!****************************************************************************************
-    REAL, INTENT(IN)                           :: dtime
-    INTEGER, INTENT(IN)                        :: nsrf, knon
-    INTEGER, DIMENSION(klon), INTENT(IN)       :: ni
-    REAL, DIMENSION(klon,klev+1), INTENT(IN)   :: ypaprs
-    REAL, DIMENSION(klon,klev), INTENT(IN)     :: ypplay
-    REAL, DIMENSION(klon,klev), INTENT(IN)     :: yu, yv
-    REAL, DIMENSION(klon,klev), INTENT(IN)     :: yq, yt
-    REAL, DIMENSION(klon), INTENT(IN)          :: yts, yqsurf
-    REAL, DIMENSION(klon), INTENT(IN)          :: ycdragm
-!FC
-    REAL, DIMENSION(klon,klev), INTENT(IN)     :: ydrgpro
-
-
-! InOutput arguments
-!****************************************************************************************
-    REAL, DIMENSION(klon,klev+1), INTENT(INOUT):: yq2
-  
-! Output arguments
-!****************************************************************************************
-    REAL, DIMENSION(klon,klev+1), INTENT(OUT)  :: yeps
-    REAL, DIMENSION(klon,klev), INTENT(OUT)    :: ycoefh
-    REAL, DIMENSION(klon,klev), INTENT(OUT)    :: ycoefm
-
-! Other local variables
-!****************************************************************************************
-    INTEGER                                    :: k, i, j
-    REAL, DIMENSION(klon,klev)                 :: ycoefm0, ycoefh0, yzlay, yteta
-    REAL, DIMENSION(klon,klev+1)               :: yzlev, q2diag, ykmm, ykmn, ykmq
-    REAL, DIMENSION(klon)                      :: yustar
-
-! Include
-!****************************************************************************************
-    INCLUDE "clesphys.h"
-    INCLUDE "compbl.h"
-    INCLUDE "YOETHF.h"
-    INCLUDE "YOMCST.h"
-
-
-    ykmm = 0 !ym missing init
-    ykmn = 0 !ym missing init
-    ykmq = 0 !ym missing init
-    
-    yeps(:,:) = 0.
-
-!****************************************************************************************    
-! Calcul de coefficients de diffusion turbulent de l'atmosphere : 
-! ycoefm(:,2:klev), ycoefh(:,2:klev) 
-!
-!****************************************************************************************    
-
-    CALL coefkz(nsrf, knon, ypaprs, ypplay, &
-         ksta, ksta_ter, &
-         yts, yu, yv, yt, yq, &
-         yqsurf, &
-         ycoefm, ycoefh)
-  
-!****************************************************************************************
-! Eventuelle recalcule des coeffeicients de diffusion turbulent de l'atmosphere : 
-! ycoefm(:,2:klev), ycoefh(:,2:klev) 
-!
-!****************************************************************************************
-
-    IF (iflag_pbl.EQ.1) THEN
-       CALL coefkz2(nsrf, knon, ypaprs, ypplay, yt, &
-            ycoefm0, ycoefh0)
-
-       DO k = 2, klev
-          DO i = 1, knon
-             ycoefm(i,k) = MAX(ycoefm(i,k),ycoefm0(i,k))
-             ycoefh(i,k) = MAX(ycoefh(i,k),ycoefh0(i,k))
-          ENDDO
-       ENDDO
-    ENDIF
-
-  
-!****************************************************************************************  
-! Calcul d'une diffusion minimale pour les conditions tres stables
-!
-!****************************************************************************************
-    IF (ok_kzmin) THEN
-       CALL coefkzmin(knon,ypaprs,ypplay,yu,yv,yt,yq,ycdragm, &
-            ycoefm0,ycoefh0)
-       
-       DO k = 2, klev
-          DO i = 1, knon
-             ycoefm(i,k) = MAX(ycoefm(i,k),ycoefm0(i,k))
-             ycoefh(i,k) = MAX(ycoefh(i,k),ycoefh0(i,k))
-          ENDDO
-       ENDDO
-       
-    ENDIF
-
-  
-!****************************************************************************************
-! MELLOR ET YAMADA adapte a Mars Richard Fournier et Frederic Hourdin
-! 
-!****************************************************************************************
-
-    IF (iflag_pbl.GE.3) THEN
-
-       yzlay(1:knon,1)= &
-            RD*yt(1:knon,1)/(0.5*(ypaprs(1:knon,1)+ypplay(1:knon,1))) &
-            *(ypaprs(1:knon,1)-ypplay(1:knon,1))/RG
-       DO k=2,klev
-          DO i = 1, knon
-             yzlay(i,k)= &
-                  yzlay(i,k-1)+RD*0.5*(yt(i,k-1)+yt(i,k)) &
-                  /ypaprs(i,k)*(ypplay(i,k-1)-ypplay(i,k))/RG
-          END DO
-       END DO
-
-       DO k=1,klev
-          DO i = 1, knon
-             yteta(i,k)= &
-                  yt(i,k)*(ypaprs(i,1)/ypplay(i,k))**RKAPPA &
-                  *(1.+0.61*yq(i,k))
-          END DO
-       END DO
-
-       yzlev(1:knon,1)=0.
-       yzlev(1:knon,klev+1)=2.*yzlay(1:knon,klev)-yzlay(1:knon,klev-1)
-       DO k=2,klev
-          DO i = 1, knon
-             yzlev(i,k)=0.5*(yzlay(i,k)+yzlay(i,k-1))
-          END DO
-       END DO
-
-!!$!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!!$! Pour memoire, le papier Hourdin et al. 2002 a ete obtenur avec un
-!!$! bug sur les coefficients de surface :
-!!$!          ycdragh(1:knon) = ycoefm(1:knon,1)
-!!$!          ycdragm(1:knon) = ycoefh(1:knon,1)
-!!$!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-       ! Normalement, on peut passer dans les codes avec knon=0
-       ! Mais ca fait planter le replay.
-       ! En attendant une réécriture, on a joute des if (Fredho)
-       if ( klon>1 .or. (klon==1 .and. knon==1) ) then
-          CALL ustarhb(knon,klev,knon,yu,yv,ycdragm, yustar)
-       endif
-     
-       IF (prt_level > 9) THEN
-          WRITE(lunout,*) 'USTAR = ',(yustar(i),i=1,knon)
-       ENDIF
-         
-!   iflag_pbl peut etre utilise comme longuer de melange
-       IF (iflag_pbl.GE.31) THEN
-          if ( klon>1 .or. (klon==1 .and. knon==1) ) then
-          CALL vdif_kcay(knon,klev,knon,dtime,RG,RD,ypaprs,yt, &
-               yzlev,yzlay,yu,yv,yteta, &
-               ycdragm,yq2,q2diag,ykmm,ykmn,yustar, &
-               iflag_pbl)
-          endif
-       ELSE IF (iflag_pbl<20) THEN
-          CALL yamada4(ni,nsrf,knon,dtime,RG,RD,ypaprs,yt, &
-               yzlev,yzlay,yu,yv,yteta, &
-               ycdragm,yq2,yeps,ykmm,ykmn,ykmq,yustar, &
-               iflag_pbl,ydrgpro)
-!FC
-       ENDIF
-       
-       ycoefm(1:knon,2:klev)=ykmm(1:knon,2:klev)
-       ycoefh(1:knon,2:klev)=ykmn(1:knon,2:klev)
-                
-    ELSE
-       ! No TKE for Standard Physics
-       yq2=0.
-    ENDIF !(iflag_pbl.ge.3)
-
-  END SUBROUTINE coef_diff_turb
-!
-!****************************************************************************************
-!
-  SUBROUTINE coefkz(nsrf, knon, paprs, pplay, &
-       ksta, ksta_ter, &
-       ts, &
-       u,v,t,q, &
-       qsurf, &
-       pcfm, pcfh)
-    
-    USE dimphy
-    USE indice_sol_mod
-    USE print_control_mod, ONLY: prt_level, lunout
-  
-!======================================================================
-! Auteur(s) F. Hourdin, M. Forichon, Z.X. Li (LMD/CNRS) date: 19930922
-!           (une version strictement identique a l'ancien modele)
-! Objet: calculer le coefficient du frottement du sol (Cdrag) et les
-!        coefficients d'echange turbulent dans l'atmosphere.
-! Arguments:
-! nsrf-----input-I- indicateur de la nature du sol
-! knon-----input-I- nombre de points a traiter
-! paprs----input-R- pregssion a chaque intercouche (en Pa)
-! pplay----input-R- pression au milieu de chaque couche (en Pa)
-! ts-------input-R- temperature du sol (en Kelvin)
-! u--------input-R- vitesse u
-! v--------input-R- vitesse v
-! t--------input-R- temperature (K)
-! q--------input-R- vapeur d'eau (kg/kg)
-!
-! pcfm-----output-R- coefficients a calculer (vitesse)
-! pcfh-----output-R- coefficients a calculer (chaleur et humidite)
-!======================================================================
-    INCLUDE "YOETHF.h"
-    INCLUDE "YOMCST.h"
-    INCLUDE "FCTTRE.h"
-    INCLUDE "compbl.h"
-!
-! Arguments:
-!
-    INTEGER, INTENT(IN)                      :: knon, nsrf
-    REAL, INTENT(IN)                         :: ksta, ksta_ter
-    REAL, DIMENSION(klon), INTENT(IN)        :: ts
-    REAL, DIMENSION(klon,klev+1), INTENT(IN) :: paprs
-    REAL, DIMENSION(klon,klev), INTENT(IN)   :: pplay
-    REAL, DIMENSION(klon,klev), INTENT(IN)   :: u, v, t, q
-    REAL, DIMENSION(klon), INTENT(IN)        :: qsurf
-
-    REAL, DIMENSION(klon,klev), INTENT(OUT)  :: pcfm, pcfh
-
-!
-! Local variables:
-!
-    INTEGER, DIMENSION(klon)    :: itop ! numero de couche du sommet de la couche limite
-!
-! Quelques constantes et options:
-!
-    REAL, PARAMETER :: cepdu2=0.1**2
-    REAL, PARAMETER :: CKAP=0.4
-    REAL, PARAMETER :: cb=5.0
-    REAL, PARAMETER :: cc=5.0
-    REAL, PARAMETER :: cd=5.0
-    REAL, PARAMETER :: clam=160.0
-    REAL, PARAMETER :: ratqs=0.05 ! largeur de distribution de vapeur d'eau
-    LOGICAL, PARAMETER :: richum=.TRUE. ! utilise le nombre de Richardson humide
-    REAL, PARAMETER :: ric=0.4 ! nombre de Richardson critique
-    REAL, PARAMETER :: prandtl=0.4
-    REAL kstable ! diffusion minimale (situation stable)
-    ! GKtest
-    ! PARAMETER (kstable=1.0e-10)
-!IM: 261103     REAL kstable_ter, kstable_sinon
-!IM: 211003 cf GK   PARAMETER (kstable_ter = 1.0e-6)
-!IM: 261103     PARAMETER (kstable_ter = 1.0e-8)
-!IM: 261103   PARAMETER (kstable_ter = 1.0e-10)
-!IM: 261103   PARAMETER (kstable_sinon = 1.0e-10)
-    ! fin GKtest
-    REAL, PARAMETER :: mixlen=35.0 ! constante controlant longueur de melange
-    INTEGER isommet ! le sommet de la couche limite
-    LOGICAL, PARAMETER :: tvirtu=.TRUE. ! calculer Ri d'une maniere plus performante
-    LOGICAL, PARAMETER :: opt_ec=.FALSE.! formule du Centre Europeen dans l'atmosphere
-
-!
-! Variables locales:
-    INTEGER i, k !IM 120704
-    REAL zgeop(klon,klev)
-    REAL zmgeom(klon)
-    REAL zri(klon)
-    REAL zl2(klon)
-    REAL zdphi, zdu2, ztvd, ztvu, zcdn
-    REAL zscf
-    REAL zt, zq, zdelta, zcvm5, zcor, zqs, zfr, zdqs
-    REAL z2geomf, zalh2, zalm2, zscfh, zscfm
-    REAL, PARAMETER :: t_coup=273.15
-    LOGICAL, PARAMETER :: check=.FALSE.
-!
-! contre-gradient pour la chaleur sensible: Kelvin/metre
-    REAL gamt(2:klev)
-
-    LOGICAL, SAVE :: appel1er=.TRUE.
-    !$OMP THREADPRIVATE(appel1er)
-!
-! Fonctions thermodynamiques et fonctions d'instabilite
-    REAL fsta, fins, x
-
-    fsta(x) = 1.0 / (1.0+10.0*x*(1+8.0*x))
-    fins(x) = SQRT(1.0-18.0*x)
-
-    isommet=klev
-      
-    IF (appel1er) THEN
-       IF (prt_level > 9) THEN
-          WRITE(lunout,*)'coefkz, opt_ec:', opt_ec
-          WRITE(lunout,*)'coefkz, richum:', richum
-          IF (richum) WRITE(lunout,*)'coefkz, ratqs:', ratqs
-          WRITE(lunout,*)'coefkz, isommet:', isommet
-          WRITE(lunout,*)'coefkz, tvirtu:', tvirtu
-          appel1er = .FALSE.
-       ENDIF
-    ENDIF
-!
-! Initialiser les sorties
-!
-    DO k = 1, klev
-       DO i = 1, knon
-          pcfm(i,k) = 0.0
-          pcfh(i,k) = 0.0
-       ENDDO
-    ENDDO
-    DO i = 1, knon
-       itop(i) = 0
-    ENDDO
-    
-!
-! Prescrire la valeur de contre-gradient
-!
-    IF (iflag_pbl.EQ.1) THEN
-       DO k = 3, klev
-          gamt(k) = -1.0E-03
-       ENDDO
-       gamt(2) = -2.5E-03
-    ELSE
-       DO k = 2, klev
-          gamt(k) = 0.0
-       ENDDO
-    ENDIF
-!IM cf JLD/ GKtest
-    IF ( nsrf .NE. is_oce ) THEN
-!IM 261103     kstable = kstable_ter
-       kstable = ksta_ter
-    ELSE
-!IM 261103     kstable = kstable_sinon
-       kstable = ksta
-    ENDIF
-!IM cf JLD/ GKtest fin
-
-!
-! Calculer les geopotentiels de chaque couche
-!
-    DO i = 1, knon
-       zgeop(i,1) = RD * t(i,1) / (0.5*(paprs(i,1)+pplay(i,1))) &
-            * (paprs(i,1)-pplay(i,1))
-    ENDDO
-    DO k = 2, klev
-       DO i = 1, knon
-          zgeop(i,k) = zgeop(i,k-1) &
-               + RD * 0.5*(t(i,k-1)+t(i,k)) / paprs(i,k) &
-               * (pplay(i,k-1)-pplay(i,k))
-       ENDDO
-    ENDDO
-
-!
-! Calculer les coefficients turbulents dans l'atmosphere
-!
-    DO i = 1, knon
-       itop(i) = isommet
-    ENDDO
-
-
-    DO k = 2, isommet
-       DO i = 1, knon
-          zdu2=MAX(cepdu2,(u(i,k)-u(i,k-1))**2 &
-               +(v(i,k)-v(i,k-1))**2)
-          zmgeom(i)=zgeop(i,k)-zgeop(i,k-1)
-          zdphi =zmgeom(i) / 2.0
-          zt = (t(i,k)+t(i,k-1)) * 0.5
-          zq = (q(i,k)+q(i,k-1)) * 0.5
-
-!
-! Calculer Qs et dQs/dT:
-!
-          IF (thermcep) THEN
-             zdelta = MAX(0.,SIGN(1.,RTT-zt))
-             zcvm5 = R5LES*RLVTT/RCPD/(1.0+RVTMP2*zq)*(1.-zdelta) &
-                  + R5IES*RLSTT/RCPD/(1.0+RVTMP2*zq)*zdelta
-             zqs = R2ES * FOEEW(zt,zdelta) / pplay(i,k)
-             zqs = MIN(0.5,zqs)
-             zcor = 1./(1.-RETV*zqs)
-             zqs = zqs*zcor
-             zdqs = FOEDE(zt,zdelta,zcvm5,zqs,zcor)
-          ELSE
-             IF (zt .LT. t_coup) THEN
-                zqs = qsats(zt) / pplay(i,k)
-                zdqs = dqsats(zt,zqs)
-             ELSE
-                zqs = qsatl(zt) / pplay(i,k)
-                zdqs = dqsatl(zt,zqs)
-             ENDIF
-          ENDIF
-!
-!           calculer la fraction nuageuse (processus humide):
-!
-          if (zq /= 0.) then
-             zfr = (zq+ratqs*zq-zqs) / (2.0*ratqs*zq)
-          else
-             zfr = 0.
-          end if
-          zfr = MAX(0.0,MIN(1.0,zfr))
-          IF (.NOT.richum) zfr = 0.0
-!
-!           calculer le nombre de Richardson:
-!
-          IF (tvirtu) THEN
-             ztvd =( t(i,k) &
-                  + zdphi/RCPD/(1.+RVTMP2*zq) &
-                  *( (1.-zfr) + zfr*(1.+RLVTT*zqs/RD/zt)/(1.+zdqs) ) &
-                  )*(1.+RETV*q(i,k))
-             ztvu =( t(i,k-1) &
-                  - zdphi/RCPD/(1.+RVTMP2*zq) &
-                  *( (1.-zfr) + zfr*(1.+RLVTT*zqs/RD/zt)/(1.+zdqs) ) &
-                  )*(1.+RETV*q(i,k-1))
-             zri(i) =zmgeom(i)*(ztvd-ztvu)/(zdu2*0.5*(ztvd+ztvu))
-             zri(i) = zri(i) &
-                  + zmgeom(i)*zmgeom(i)/RG*gamt(k) &
-                  *(paprs(i,k)/101325.0)**RKAPPA &
-                  /(zdu2*0.5*(ztvd+ztvu))
-
-          ELSE ! calcul de Ridchardson compatible LMD5
-
-             zri(i) =(RCPD*(t(i,k)-t(i,k-1)) &
-                  -RD*0.5*(t(i,k)+t(i,k-1))/paprs(i,k) &
-                  *(pplay(i,k)-pplay(i,k-1)) &
-                  )*zmgeom(i)/(zdu2*0.5*RCPD*(t(i,k-1)+t(i,k)))
-             zri(i) = zri(i) + &
-                  zmgeom(i)*zmgeom(i)*gamt(k)/RG &
-                  *(paprs(i,k)/101325.0)**RKAPPA &
-                  /(zdu2*0.5*(t(i,k-1)+t(i,k)))
-          ENDIF
-!
-!           finalement, les coefficients d'echange sont obtenus:
-!
-          zcdn=SQRT(zdu2) / zmgeom(i) * RG
-
-          IF (opt_ec) THEN
-             z2geomf=zgeop(i,k-1)+zgeop(i,k)
-             zalm2=(0.5*ckap/RG*z2geomf &
-                  /(1.+0.5*ckap/rg/clam*z2geomf))**2
-             zalh2=(0.5*ckap/rg*z2geomf &
-                  /(1.+0.5*ckap/RG/(clam*SQRT(1.5*cd))*z2geomf))**2
-             IF (zri(i).LT.0.0) THEN  ! situation instable
-                zscf = ((zgeop(i,k)/zgeop(i,k-1))**(1./3.)-1.)**3 &
-                     / (zmgeom(i)/RG)**3 / (zgeop(i,k-1)/RG)
-                zscf = SQRT(-zri(i)*zscf)
-                zscfm = 1.0 / (1.0+3.0*cb*cc*zalm2*zscf)
-                zscfh = 1.0 / (1.0+3.0*cb*cc*zalh2*zscf)
-                pcfm(i,k)=zcdn*zalm2*(1.-2.0*cb*zri(i)*zscfm)
-                pcfh(i,k)=zcdn*zalh2*(1.-3.0*cb*zri(i)*zscfh)
-             ELSE ! situation stable
-                zscf=SQRT(1.+cd*zri(i))
-                pcfm(i,k)=zcdn*zalm2/(1.+2.0*cb*zri(i)/zscf)
-                pcfh(i,k)=zcdn*zalh2/(1.+3.0*cb*zri(i)*zscf)
-             ENDIF
-          ELSE
-             zl2(i)=(mixlen*MAX(0.0,(paprs(i,k)-paprs(i,itop(i)+1)) &
-                  /(paprs(i,2)-paprs(i,itop(i)+1)) ))**2
-             pcfm(i,k)=SQRT(MAX(zcdn*zcdn*(ric-zri(i))/ric, kstable))
-             pcfm(i,k)= zl2(i)* pcfm(i,k)
-             pcfh(i,k) = pcfm(i,k) /prandtl ! h et m different
-          ENDIF
-       ENDDO
-    ENDDO
-
-!
-! Au-dela du sommet, pas de diffusion turbulente:
-!
-    DO i = 1, knon
-       IF (itop(i)+1 .LE. klev) THEN
-          DO k = itop(i)+1, klev
-             pcfh(i,k) = 0.0
-             pcfm(i,k) = 0.0
-          ENDDO
-       ENDIF
-    ENDDO
-      
-  END SUBROUTINE coefkz
-!
-!****************************************************************************************
-!
-  SUBROUTINE coefkz2(nsrf, knon, paprs, pplay,t, &
-       pcfm, pcfh)
-
-    USE dimphy
-    USE indice_sol_mod
-
-!======================================================================
-! J'introduit un peu de diffusion sauf dans les endroits
-! ou une forte inversion est presente
-! On peut dire qu'il represente la convection peu profonde
-!
-! Arguments:
-! nsrf-----input-I- indicateur de la nature du sol
-! knon-----input-I- nombre de points a traiter
-! paprs----input-R- pression a chaque intercouche (en Pa)
-! pplay----input-R- pression au milieu de chaque couche (en Pa)
-! t--------input-R- temperature (K)
-!
-! pcfm-----output-R- coefficients a calculer (vitesse)
-! pcfh-----output-R- coefficients a calculer (chaleur et humidite)
-!======================================================================
-!
-! Arguments:
-!
-    INTEGER, INTENT(IN)                       :: knon, nsrf
-    REAL, DIMENSION(klon, klev+1), INTENT(IN) ::  paprs
-    REAL, DIMENSION(klon, klev), INTENT(IN)   ::  pplay
-    REAL, DIMENSION(klon, klev), INTENT(IN)   :: t(klon,klev)
-    
-    REAL, DIMENSION(klon, klev), INTENT(OUT)  :: pcfm, pcfh
-!
-! Quelques constantes et options:
-!
-    REAL, PARAMETER :: prandtl=0.4
-    REAL, PARAMETER :: kstable=0.002
-!   REAL, PARAMETER :: kstable=0.001
-    REAL, PARAMETER :: mixlen=35.0 ! constante controlant longueur de melange
-    REAL, PARAMETER :: seuil=-0.02 ! au-dela l'inversion est consideree trop faible
-!    PARAMETER (seuil=-0.04)
-!    PARAMETER (seuil=-0.06)
-!    PARAMETER (seuil=-0.09)
-
-!
-! Variables locales:
-!
-    INTEGER i, k, invb(knon)
-    REAL zl2(knon)
-    REAL zdthmin(knon), zdthdp
-
-    INCLUDE "YOMCST.h"
-!
-! Initialiser les sorties
-!
-    DO k = 1, klev
-       DO i = 1, knon
-          pcfm(i,k) = 0.0
-          pcfh(i,k) = 0.0
-       ENDDO
-    ENDDO
-
-!
-! Chercher la zone d'inversion forte
-!
-    DO i = 1, knon
-       invb(i) = klev
-       zdthmin(i)=0.0
-    ENDDO
-    DO k = 2, klev/2-1
-       DO i = 1, knon
-          zdthdp = (t(i,k)-t(i,k+1))/(pplay(i,k)-pplay(i,k+1)) &
-               - RD * 0.5*(t(i,k)+t(i,k+1))/RCPD/paprs(i,k+1)
-          zdthdp = zdthdp * 100.0
-          IF (pplay(i,k).GT.0.8*paprs(i,1) .AND. &
-               zdthdp.LT.zdthmin(i) ) THEN
-             zdthmin(i) = zdthdp
-             invb(i) = k
-          ENDIF
-       ENDDO
-    ENDDO
-
-!
-! Introduire une diffusion:
-!
-    IF ( nsrf.EQ.is_oce ) THEN
-       DO k = 2, klev
-          DO i = 1, knon
-!IM cf FH/GK   IF ( (nsrf.NE.is_oce) .OR.  ! si ce n'est pas sur l'ocean
-!IM cf FH/GK  .     (invb(i).EQ.klev) .OR. ! s'il n'y a pas d'inversion
-      !IM cf JLD/ GKtest TERkz2
-      ! IF ( (nsrf.EQ.is_ter) .OR.  ! si on est sur la terre
-      ! fin GKtest
-
-
-! s'il n'y a pas d'inversion ou si l'inversion est trop faible
-!          IF ( (nsrf.EQ.is_oce) .AND. &
-             IF ( (invb(i).EQ.klev) .OR. (zdthmin(i).GT.seuil) ) THEN 
-                zl2(i)=(mixlen*MAX(0.0,(paprs(i,k)-paprs(i,klev+1)) &
-                     /(paprs(i,2)-paprs(i,klev+1)) ))**2
-                pcfm(i,k)= zl2(i)* kstable
-                pcfh(i,k) = pcfm(i,k) /prandtl ! h et m different
-             ENDIF
-          ENDDO
-       ENDDO
-    ENDIF
-
-  END SUBROUTINE coefkz2
-!
-!****************************************************************************************
-!
-END MODULE coef_diff_turb_mod
Index: /LMDZ6/trunk/libf/phylmd/coef_diff_turb_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/coef_diff_turb_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/coef_diff_turb_mod.f90	(revision 5268)
@@ -0,0 +1,606 @@
+!
+MODULE coef_diff_turb_mod
+!
+! This module contains some procedures for calculation of the coefficients of the
+! turbulent diffusion in the atmosphere and coefficients for turbulent diffusion 
+! at surface(cdrag)
+!
+  IMPLICIT NONE
+  
+CONTAINS
+!
+!****************************************************************************************
+!
+  SUBROUTINE coef_diff_turb(dtime, nsrf, knon, ni, &
+       ypaprs, ypplay, yu, yv, yq, yt, yts, yqsurf, ycdragm, &
+       ycoefm, ycoefh ,yq2, yeps, ydrgpro)
+ 
+    USE dimphy
+    USE indice_sol_mod
+    USE print_control_mod, ONLY: prt_level, lunout
+!
+! Calculate coefficients(ycoefm, ycoefh) for turbulent diffusion in the 
+! atmosphere 
+! NB! No values are calculated between surface and the first model layer. 
+!     ycoefm(:,1) and ycoefh(:,1) are not valid !!!
+!
+!
+! Input arguments
+!****************************************************************************************
+    REAL, INTENT(IN)                           :: dtime
+    INTEGER, INTENT(IN)                        :: nsrf, knon
+    INTEGER, DIMENSION(klon), INTENT(IN)       :: ni
+    REAL, DIMENSION(klon,klev+1), INTENT(IN)   :: ypaprs
+    REAL, DIMENSION(klon,klev), INTENT(IN)     :: ypplay
+    REAL, DIMENSION(klon,klev), INTENT(IN)     :: yu, yv
+    REAL, DIMENSION(klon,klev), INTENT(IN)     :: yq, yt
+    REAL, DIMENSION(klon), INTENT(IN)          :: yts, yqsurf
+    REAL, DIMENSION(klon), INTENT(IN)          :: ycdragm
+!FC
+    REAL, DIMENSION(klon,klev), INTENT(IN)     :: ydrgpro
+
+
+! InOutput arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon,klev+1), INTENT(INOUT):: yq2
+  
+! Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon,klev+1), INTENT(OUT)  :: yeps
+    REAL, DIMENSION(klon,klev), INTENT(OUT)    :: ycoefh
+    REAL, DIMENSION(klon,klev), INTENT(OUT)    :: ycoefm
+
+! Other local variables
+!****************************************************************************************
+    INTEGER                                    :: k, i, j
+    REAL, DIMENSION(klon,klev)                 :: ycoefm0, ycoefh0, yzlay, yteta
+    REAL, DIMENSION(klon,klev+1)               :: yzlev, q2diag, ykmm, ykmn, ykmq
+    REAL, DIMENSION(klon)                      :: yustar
+
+! Include
+!****************************************************************************************
+    INCLUDE "clesphys.h"
+    INCLUDE "compbl.h"
+    INCLUDE "YOETHF.h"
+    INCLUDE "YOMCST.h"
+
+
+    ykmm = 0 !ym missing init
+    ykmn = 0 !ym missing init
+    ykmq = 0 !ym missing init
+    
+    yeps(:,:) = 0.
+
+!****************************************************************************************    
+! Calcul de coefficients de diffusion turbulent de l'atmosphere : 
+! ycoefm(:,2:klev), ycoefh(:,2:klev) 
+!
+!****************************************************************************************    
+
+    CALL coefkz(nsrf, knon, ypaprs, ypplay, &
+         ksta, ksta_ter, &
+         yts, yu, yv, yt, yq, &
+         yqsurf, &
+         ycoefm, ycoefh)
+  
+!****************************************************************************************
+! Eventuelle recalcule des coeffeicients de diffusion turbulent de l'atmosphere : 
+! ycoefm(:,2:klev), ycoefh(:,2:klev) 
+!
+!****************************************************************************************
+
+    IF (iflag_pbl.EQ.1) THEN
+       CALL coefkz2(nsrf, knon, ypaprs, ypplay, yt, &
+            ycoefm0, ycoefh0)
+
+       DO k = 2, klev
+          DO i = 1, knon
+             ycoefm(i,k) = MAX(ycoefm(i,k),ycoefm0(i,k))
+             ycoefh(i,k) = MAX(ycoefh(i,k),ycoefh0(i,k))
+          ENDDO
+       ENDDO
+    ENDIF
+
+  
+!****************************************************************************************  
+! Calcul d'une diffusion minimale pour les conditions tres stables
+!
+!****************************************************************************************
+    IF (ok_kzmin) THEN
+       CALL coefkzmin(knon,ypaprs,ypplay,yu,yv,yt,yq,ycdragm, &
+            ycoefm0,ycoefh0)
+       
+       DO k = 2, klev
+          DO i = 1, knon
+             ycoefm(i,k) = MAX(ycoefm(i,k),ycoefm0(i,k))
+             ycoefh(i,k) = MAX(ycoefh(i,k),ycoefh0(i,k))
+          ENDDO
+       ENDDO
+       
+    ENDIF
+
+  
+!****************************************************************************************
+! MELLOR ET YAMADA adapte a Mars Richard Fournier et Frederic Hourdin
+! 
+!****************************************************************************************
+
+    IF (iflag_pbl.GE.3) THEN
+
+       yzlay(1:knon,1)= &
+            RD*yt(1:knon,1)/(0.5*(ypaprs(1:knon,1)+ypplay(1:knon,1))) &
+            *(ypaprs(1:knon,1)-ypplay(1:knon,1))/RG
+       DO k=2,klev
+          DO i = 1, knon
+             yzlay(i,k)= &
+                  yzlay(i,k-1)+RD*0.5*(yt(i,k-1)+yt(i,k)) &
+                  /ypaprs(i,k)*(ypplay(i,k-1)-ypplay(i,k))/RG
+          END DO
+       END DO
+
+       DO k=1,klev
+          DO i = 1, knon
+             yteta(i,k)= &
+                  yt(i,k)*(ypaprs(i,1)/ypplay(i,k))**RKAPPA &
+                  *(1.+0.61*yq(i,k))
+          END DO
+       END DO
+
+       yzlev(1:knon,1)=0.
+       yzlev(1:knon,klev+1)=2.*yzlay(1:knon,klev)-yzlay(1:knon,klev-1)
+       DO k=2,klev
+          DO i = 1, knon
+             yzlev(i,k)=0.5*(yzlay(i,k)+yzlay(i,k-1))
+          END DO
+       END DO
+
+!!$!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!$! Pour memoire, le papier Hourdin et al. 2002 a ete obtenur avec un
+!!$! bug sur les coefficients de surface :
+!!$!          ycdragh(1:knon) = ycoefm(1:knon,1)
+!!$!          ycdragm(1:knon) = ycoefh(1:knon,1)
+!!$!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+       ! Normalement, on peut passer dans les codes avec knon=0
+       ! Mais ca fait planter le replay.
+       ! En attendant une réécriture, on a joute des if (Fredho)
+       if ( klon>1 .or. (klon==1 .and. knon==1) ) then
+          CALL ustarhb(knon,klev,knon,yu,yv,ycdragm, yustar)
+       endif
+     
+       IF (prt_level > 9) THEN
+          WRITE(lunout,*) 'USTAR = ',(yustar(i),i=1,knon)
+       ENDIF
+         
+!   iflag_pbl peut etre utilise comme longuer de melange
+       IF (iflag_pbl.GE.31) THEN
+          if ( klon>1 .or. (klon==1 .and. knon==1) ) then
+          CALL vdif_kcay(knon,klev,knon,dtime,RG,RD,ypaprs,yt, &
+               yzlev,yzlay,yu,yv,yteta, &
+               ycdragm,yq2,q2diag,ykmm,ykmn,yustar, &
+               iflag_pbl)
+          endif
+       ELSE IF (iflag_pbl<20) THEN
+          CALL yamada4(ni,nsrf,knon,dtime,RG,RD,ypaprs,yt, &
+               yzlev,yzlay,yu,yv,yteta, &
+               ycdragm,yq2,yeps,ykmm,ykmn,ykmq,yustar, &
+               iflag_pbl,ydrgpro)
+!FC
+       ENDIF
+       
+       ycoefm(1:knon,2:klev)=ykmm(1:knon,2:klev)
+       ycoefh(1:knon,2:klev)=ykmn(1:knon,2:klev)
+                
+    ELSE
+       ! No TKE for Standard Physics
+       yq2=0.
+    ENDIF !(iflag_pbl.ge.3)
+
+  END SUBROUTINE coef_diff_turb
+!
+!****************************************************************************************
+!
+  SUBROUTINE coefkz(nsrf, knon, paprs, pplay, &
+       ksta, ksta_ter, &
+       ts, &
+       u,v,t,q, &
+       qsurf, &
+       pcfm, pcfh)
+    
+    USE dimphy
+    USE indice_sol_mod
+    USE print_control_mod, ONLY: prt_level, lunout
+  
+!======================================================================
+! Auteur(s) F. Hourdin, M. Forichon, Z.X. Li (LMD/CNRS) date: 19930922
+!           (une version strictement identique a l'ancien modele)
+! Objet: calculer le coefficient du frottement du sol (Cdrag) et les
+!        coefficients d'echange turbulent dans l'atmosphere.
+! Arguments:
+! nsrf-----input-I- indicateur de la nature du sol
+! knon-----input-I- nombre de points a traiter
+! paprs----input-R- pregssion a chaque intercouche (en Pa)
+! pplay----input-R- pression au milieu de chaque couche (en Pa)
+! ts-------input-R- temperature du sol (en Kelvin)
+! u--------input-R- vitesse u
+! v--------input-R- vitesse v
+! t--------input-R- temperature (K)
+! q--------input-R- vapeur d'eau (kg/kg)
+!
+! pcfm-----output-R- coefficients a calculer (vitesse)
+! pcfh-----output-R- coefficients a calculer (chaleur et humidite)
+!======================================================================
+    INCLUDE "YOETHF.h"
+    INCLUDE "YOMCST.h"
+    INCLUDE "FCTTRE.h"
+    INCLUDE "compbl.h"
+!
+! Arguments:
+!
+    INTEGER, INTENT(IN)                      :: knon, nsrf
+    REAL, INTENT(IN)                         :: ksta, ksta_ter
+    REAL, DIMENSION(klon), INTENT(IN)        :: ts
+    REAL, DIMENSION(klon,klev+1), INTENT(IN) :: paprs
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: pplay
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: u, v, t, q
+    REAL, DIMENSION(klon), INTENT(IN)        :: qsurf
+
+    REAL, DIMENSION(klon,klev), INTENT(OUT)  :: pcfm, pcfh
+
+!
+! Local variables:
+!
+    INTEGER, DIMENSION(klon)    :: itop ! numero de couche du sommet de la couche limite
+!
+! Quelques constantes et options:
+!
+    REAL, PARAMETER :: cepdu2=0.1**2
+    REAL, PARAMETER :: CKAP=0.4
+    REAL, PARAMETER :: cb=5.0
+    REAL, PARAMETER :: cc=5.0
+    REAL, PARAMETER :: cd=5.0
+    REAL, PARAMETER :: clam=160.0
+    REAL, PARAMETER :: ratqs=0.05 ! largeur de distribution de vapeur d'eau
+    LOGICAL, PARAMETER :: richum=.TRUE. ! utilise le nombre de Richardson humide
+    REAL, PARAMETER :: ric=0.4 ! nombre de Richardson critique
+    REAL, PARAMETER :: prandtl=0.4
+    REAL kstable ! diffusion minimale (situation stable)
+    ! GKtest
+    ! PARAMETER (kstable=1.0e-10)
+!IM: 261103     REAL kstable_ter, kstable_sinon
+!IM: 211003 cf GK   PARAMETER (kstable_ter = 1.0e-6)
+!IM: 261103     PARAMETER (kstable_ter = 1.0e-8)
+!IM: 261103   PARAMETER (kstable_ter = 1.0e-10)
+!IM: 261103   PARAMETER (kstable_sinon = 1.0e-10)
+    ! fin GKtest
+    REAL, PARAMETER :: mixlen=35.0 ! constante controlant longueur de melange
+    INTEGER isommet ! le sommet de la couche limite
+    LOGICAL, PARAMETER :: tvirtu=.TRUE. ! calculer Ri d'une maniere plus performante
+    LOGICAL, PARAMETER :: opt_ec=.FALSE.! formule du Centre Europeen dans l'atmosphere
+
+!
+! Variables locales:
+    INTEGER i, k !IM 120704
+    REAL zgeop(klon,klev)
+    REAL zmgeom(klon)
+    REAL zri(klon)
+    REAL zl2(klon)
+    REAL zdphi, zdu2, ztvd, ztvu, zcdn
+    REAL zscf
+    REAL zt, zq, zdelta, zcvm5, zcor, zqs, zfr, zdqs
+    REAL z2geomf, zalh2, zalm2, zscfh, zscfm
+    REAL, PARAMETER :: t_coup=273.15
+    LOGICAL, PARAMETER :: check=.FALSE.
+!
+! contre-gradient pour la chaleur sensible: Kelvin/metre
+    REAL gamt(2:klev)
+
+    LOGICAL, SAVE :: appel1er=.TRUE.
+    !$OMP THREADPRIVATE(appel1er)
+!
+! Fonctions thermodynamiques et fonctions d'instabilite
+    REAL fsta, fins, x
+
+    fsta(x) = 1.0 / (1.0+10.0*x*(1+8.0*x))
+    fins(x) = SQRT(1.0-18.0*x)
+
+    isommet=klev
+      
+    IF (appel1er) THEN
+       IF (prt_level > 9) THEN
+          WRITE(lunout,*)'coefkz, opt_ec:', opt_ec
+          WRITE(lunout,*)'coefkz, richum:', richum
+          IF (richum) WRITE(lunout,*)'coefkz, ratqs:', ratqs
+          WRITE(lunout,*)'coefkz, isommet:', isommet
+          WRITE(lunout,*)'coefkz, tvirtu:', tvirtu
+          appel1er = .FALSE.
+       ENDIF
+    ENDIF
+!
+! Initialiser les sorties
+!
+    DO k = 1, klev
+       DO i = 1, knon
+          pcfm(i,k) = 0.0
+          pcfh(i,k) = 0.0
+       ENDDO
+    ENDDO
+    DO i = 1, knon
+       itop(i) = 0
+    ENDDO
+    
+!
+! Prescrire la valeur de contre-gradient
+!
+    IF (iflag_pbl.EQ.1) THEN
+       DO k = 3, klev
+          gamt(k) = -1.0E-03
+       ENDDO
+       gamt(2) = -2.5E-03
+    ELSE
+       DO k = 2, klev
+          gamt(k) = 0.0
+       ENDDO
+    ENDIF
+!IM cf JLD/ GKtest
+    IF ( nsrf .NE. is_oce ) THEN
+!IM 261103     kstable = kstable_ter
+       kstable = ksta_ter
+    ELSE
+!IM 261103     kstable = kstable_sinon
+       kstable = ksta
+    ENDIF
+!IM cf JLD/ GKtest fin
+
+!
+! Calculer les geopotentiels de chaque couche
+!
+    DO i = 1, knon
+       zgeop(i,1) = RD * t(i,1) / (0.5*(paprs(i,1)+pplay(i,1))) &
+            * (paprs(i,1)-pplay(i,1))
+    ENDDO
+    DO k = 2, klev
+       DO i = 1, knon
+          zgeop(i,k) = zgeop(i,k-1) &
+               + RD * 0.5*(t(i,k-1)+t(i,k)) / paprs(i,k) &
+               * (pplay(i,k-1)-pplay(i,k))
+       ENDDO
+    ENDDO
+
+!
+! Calculer les coefficients turbulents dans l'atmosphere
+!
+    DO i = 1, knon
+       itop(i) = isommet
+    ENDDO
+
+
+    DO k = 2, isommet
+       DO i = 1, knon
+          zdu2=MAX(cepdu2,(u(i,k)-u(i,k-1))**2 &
+               +(v(i,k)-v(i,k-1))**2)
+          zmgeom(i)=zgeop(i,k)-zgeop(i,k-1)
+          zdphi =zmgeom(i) / 2.0
+          zt = (t(i,k)+t(i,k-1)) * 0.5
+          zq = (q(i,k)+q(i,k-1)) * 0.5
+
+!
+! Calculer Qs et dQs/dT:
+!
+          IF (thermcep) THEN
+             zdelta = MAX(0.,SIGN(1.,RTT-zt))
+             zcvm5 = R5LES*RLVTT/RCPD/(1.0+RVTMP2*zq)*(1.-zdelta) &
+                  + R5IES*RLSTT/RCPD/(1.0+RVTMP2*zq)*zdelta
+             zqs = R2ES * FOEEW(zt,zdelta) / pplay(i,k)
+             zqs = MIN(0.5,zqs)
+             zcor = 1./(1.-RETV*zqs)
+             zqs = zqs*zcor
+             zdqs = FOEDE(zt,zdelta,zcvm5,zqs,zcor)
+          ELSE
+             IF (zt .LT. t_coup) THEN
+                zqs = qsats(zt) / pplay(i,k)
+                zdqs = dqsats(zt,zqs)
+             ELSE
+                zqs = qsatl(zt) / pplay(i,k)
+                zdqs = dqsatl(zt,zqs)
+             ENDIF
+          ENDIF
+!
+!           calculer la fraction nuageuse (processus humide):
+!
+          if (zq /= 0.) then
+             zfr = (zq+ratqs*zq-zqs) / (2.0*ratqs*zq)
+          else
+             zfr = 0.
+          end if
+          zfr = MAX(0.0,MIN(1.0,zfr))
+          IF (.NOT.richum) zfr = 0.0
+!
+!           calculer le nombre de Richardson:
+!
+          IF (tvirtu) THEN
+             ztvd =( t(i,k) &
+                  + zdphi/RCPD/(1.+RVTMP2*zq) &
+                  *( (1.-zfr) + zfr*(1.+RLVTT*zqs/RD/zt)/(1.+zdqs) ) &
+                  )*(1.+RETV*q(i,k))
+             ztvu =( t(i,k-1) &
+                  - zdphi/RCPD/(1.+RVTMP2*zq) &
+                  *( (1.-zfr) + zfr*(1.+RLVTT*zqs/RD/zt)/(1.+zdqs) ) &
+                  )*(1.+RETV*q(i,k-1))
+             zri(i) =zmgeom(i)*(ztvd-ztvu)/(zdu2*0.5*(ztvd+ztvu))
+             zri(i) = zri(i) &
+                  + zmgeom(i)*zmgeom(i)/RG*gamt(k) &
+                  *(paprs(i,k)/101325.0)**RKAPPA &
+                  /(zdu2*0.5*(ztvd+ztvu))
+
+          ELSE ! calcul de Ridchardson compatible LMD5
+
+             zri(i) =(RCPD*(t(i,k)-t(i,k-1)) &
+                  -RD*0.5*(t(i,k)+t(i,k-1))/paprs(i,k) &
+                  *(pplay(i,k)-pplay(i,k-1)) &
+                  )*zmgeom(i)/(zdu2*0.5*RCPD*(t(i,k-1)+t(i,k)))
+             zri(i) = zri(i) + &
+                  zmgeom(i)*zmgeom(i)*gamt(k)/RG &
+                  *(paprs(i,k)/101325.0)**RKAPPA &
+                  /(zdu2*0.5*(t(i,k-1)+t(i,k)))
+          ENDIF
+!
+!           finalement, les coefficients d'echange sont obtenus:
+!
+          zcdn=SQRT(zdu2) / zmgeom(i) * RG
+
+          IF (opt_ec) THEN
+             z2geomf=zgeop(i,k-1)+zgeop(i,k)
+             zalm2=(0.5*ckap/RG*z2geomf &
+                  /(1.+0.5*ckap/rg/clam*z2geomf))**2
+             zalh2=(0.5*ckap/rg*z2geomf &
+                  /(1.+0.5*ckap/RG/(clam*SQRT(1.5*cd))*z2geomf))**2
+             IF (zri(i).LT.0.0) THEN  ! situation instable
+                zscf = ((zgeop(i,k)/zgeop(i,k-1))**(1./3.)-1.)**3 &
+                     / (zmgeom(i)/RG)**3 / (zgeop(i,k-1)/RG)
+                zscf = SQRT(-zri(i)*zscf)
+                zscfm = 1.0 / (1.0+3.0*cb*cc*zalm2*zscf)
+                zscfh = 1.0 / (1.0+3.0*cb*cc*zalh2*zscf)
+                pcfm(i,k)=zcdn*zalm2*(1.-2.0*cb*zri(i)*zscfm)
+                pcfh(i,k)=zcdn*zalh2*(1.-3.0*cb*zri(i)*zscfh)
+             ELSE ! situation stable
+                zscf=SQRT(1.+cd*zri(i))
+                pcfm(i,k)=zcdn*zalm2/(1.+2.0*cb*zri(i)/zscf)
+                pcfh(i,k)=zcdn*zalh2/(1.+3.0*cb*zri(i)*zscf)
+             ENDIF
+          ELSE
+             zl2(i)=(mixlen*MAX(0.0,(paprs(i,k)-paprs(i,itop(i)+1)) &
+                  /(paprs(i,2)-paprs(i,itop(i)+1)) ))**2
+             pcfm(i,k)=SQRT(MAX(zcdn*zcdn*(ric-zri(i))/ric, kstable))
+             pcfm(i,k)= zl2(i)* pcfm(i,k)
+             pcfh(i,k) = pcfm(i,k) /prandtl ! h et m different
+          ENDIF
+       ENDDO
+    ENDDO
+
+!
+! Au-dela du sommet, pas de diffusion turbulente:
+!
+    DO i = 1, knon
+       IF (itop(i)+1 .LE. klev) THEN
+          DO k = itop(i)+1, klev
+             pcfh(i,k) = 0.0
+             pcfm(i,k) = 0.0
+          ENDDO
+       ENDIF
+    ENDDO
+      
+  END SUBROUTINE coefkz
+!
+!****************************************************************************************
+!
+  SUBROUTINE coefkz2(nsrf, knon, paprs, pplay,t, &
+       pcfm, pcfh)
+
+    USE dimphy
+    USE indice_sol_mod
+
+!======================================================================
+! J'introduit un peu de diffusion sauf dans les endroits
+! ou une forte inversion est presente
+! On peut dire qu'il represente la convection peu profonde
+!
+! Arguments:
+! nsrf-----input-I- indicateur de la nature du sol
+! knon-----input-I- nombre de points a traiter
+! paprs----input-R- pression a chaque intercouche (en Pa)
+! pplay----input-R- pression au milieu de chaque couche (en Pa)
+! t--------input-R- temperature (K)
+!
+! pcfm-----output-R- coefficients a calculer (vitesse)
+! pcfh-----output-R- coefficients a calculer (chaleur et humidite)
+!======================================================================
+!
+! Arguments:
+!
+    INTEGER, INTENT(IN)                       :: knon, nsrf
+    REAL, DIMENSION(klon, klev+1), INTENT(IN) ::  paprs
+    REAL, DIMENSION(klon, klev), INTENT(IN)   ::  pplay
+    REAL, DIMENSION(klon, klev), INTENT(IN)   :: t(klon,klev)
+    
+    REAL, DIMENSION(klon, klev), INTENT(OUT)  :: pcfm, pcfh
+!
+! Quelques constantes et options:
+!
+    REAL, PARAMETER :: prandtl=0.4
+    REAL, PARAMETER :: kstable=0.002
+!   REAL, PARAMETER :: kstable=0.001
+    REAL, PARAMETER :: mixlen=35.0 ! constante controlant longueur de melange
+    REAL, PARAMETER :: seuil=-0.02 ! au-dela l'inversion est consideree trop faible
+!    PARAMETER (seuil=-0.04)
+!    PARAMETER (seuil=-0.06)
+!    PARAMETER (seuil=-0.09)
+
+!
+! Variables locales:
+!
+    INTEGER i, k, invb(knon)
+    REAL zl2(knon)
+    REAL zdthmin(knon), zdthdp
+
+    INCLUDE "YOMCST.h"
+!
+! Initialiser les sorties
+!
+    DO k = 1, klev
+       DO i = 1, knon
+          pcfm(i,k) = 0.0
+          pcfh(i,k) = 0.0
+       ENDDO
+    ENDDO
+
+!
+! Chercher la zone d'inversion forte
+!
+    DO i = 1, knon
+       invb(i) = klev
+       zdthmin(i)=0.0
+    ENDDO
+    DO k = 2, klev/2-1
+       DO i = 1, knon
+          zdthdp = (t(i,k)-t(i,k+1))/(pplay(i,k)-pplay(i,k+1)) &
+               - RD * 0.5*(t(i,k)+t(i,k+1))/RCPD/paprs(i,k+1)
+          zdthdp = zdthdp * 100.0
+          IF (pplay(i,k).GT.0.8*paprs(i,1) .AND. &
+               zdthdp.LT.zdthmin(i) ) THEN
+             zdthmin(i) = zdthdp
+             invb(i) = k
+          ENDIF
+       ENDDO
+    ENDDO
+
+!
+! Introduire une diffusion:
+!
+    IF ( nsrf.EQ.is_oce ) THEN
+       DO k = 2, klev
+          DO i = 1, knon
+!IM cf FH/GK   IF ( (nsrf.NE.is_oce) .OR.  ! si ce n'est pas sur l'ocean
+!IM cf FH/GK  .     (invb(i).EQ.klev) .OR. ! s'il n'y a pas d'inversion
+      !IM cf JLD/ GKtest TERkz2
+      ! IF ( (nsrf.EQ.is_ter) .OR.  ! si on est sur la terre
+      ! fin GKtest
+
+
+! s'il n'y a pas d'inversion ou si l'inversion est trop faible
+!          IF ( (nsrf.EQ.is_oce) .AND. &
+             IF ( (invb(i).EQ.klev) .OR. (zdthmin(i).GT.seuil) ) THEN 
+                zl2(i)=(mixlen*MAX(0.0,(paprs(i,k)-paprs(i,klev+1)) &
+                     /(paprs(i,2)-paprs(i,klev+1)) ))**2
+                pcfm(i,k)= zl2(i)* kstable
+                pcfh(i,k) = pcfm(i,k) /prandtl ! h et m different
+             ENDIF
+          ENDDO
+       ENDDO
+    ENDIF
+
+  END SUBROUTINE coefkz2
+!
+!****************************************************************************************
+!
+END MODULE coef_diff_turb_mod
Index: DZ6/trunk/libf/phylmd/coefcdrag.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/coefcdrag.F90	(revision 5267)
+++ 	(revision )
@@ -1,167 +1,0 @@
-!
-!
-!
-      SUBROUTINE coefcdrag (klon, knon, nsrf, zxli, &
-                            speed, t, q, zgeop, psol, &
-                            ts, qsurf, rugos, okri, ri1, &
-                            cdram, cdrah, cdran, zri1, pref)
-
-      USE indice_sol_mod
-
-      IMPLICIT none
-!-------------------------------------------------------------------------
-! Objet : calcul des cdrags pour le moment (cdram) et les flux de chaleur 
-!         sensible et latente (cdrah), du cdrag neutre (cdran), 
-!         du nombre de Richardson entre la surface et le niveau de reference 
-!         (zri1) et de la pression au niveau de reference (pref).    
-!
-! I. Musat, 01.07.2002
-!-------------------------------------------------------------------------
-!
-! klon----input-I- dimension de la grille physique (= nb_pts_latitude X nb_pts_longitude)
-! knon----input-I- nombre de points pour un type de surface
-! nsrf----input-I- indice pour le type de surface; voir indice_sol_mod.F90
-! zxli----input-L- TRUE si calcul des cdrags selon Laurent Li
-! speed---input-R- module du vent au 1er niveau du modele
-! t-------input-R- temperature de l'air au 1er niveau du modele
-! q-------input-R- humidite de l'air au 1er niveau du modele
-! zgeop---input-R- geopotentiel au 1er niveau du modele
-! psol----input-R- pression au sol 
-! ts------input-R- temperature de l'air a la surface
-! qsurf---input-R- humidite de l'air a la surface
-! rugos---input-R- rugosite
-! okri----input-L- TRUE si on veut tester le nb. Richardson entre la sfce 
-!                  et zref par rapport au Ri entre la sfce et la 1ere couche
-! ri1-----input-R- nb. Richardson entre la surface et la 1ere couche
-!
-! cdram--output-R- cdrag pour le moment
-! cdrah--output-R- cdrag pour les flux de chaleur latente et sensible
-! cdran--output-R- cdrag neutre
-! zri1---output-R- nb. Richardson entre la surface et la couche zgeop/RG
-! pref---output-R- pression au niveau zgeop/RG
-!
-      INTEGER, intent(in) :: klon, knon, nsrf
-      LOGICAL, intent(in) :: zxli 
-      REAL, dimension(klon), intent(in) :: speed, t, q, zgeop, psol
-      REAL, dimension(klon), intent(in) :: ts, qsurf, rugos, ri1 
-      LOGICAL, intent(in) :: okri    
-!
-      REAL, dimension(klon), intent(out) :: cdram, cdrah, cdran, zri1, pref
-!-------------------------------------------------------------------------
-!
-      include "YOMCST.h"
-      include "YOETHF.h"
-      INCLUDE "clesphys.h"
-! Quelques constantes :
-      REAL, parameter :: RKAR=0.40, CB=5.0, CC=5.0, CD=5.0, cepdu2=(0.1)**2
-!
-! Variables locales :
-      INTEGER :: i
-      REAL, dimension(klon) :: zdu2, zdphi, ztsolv, ztvd
-      REAL, dimension(klon) :: zscf, friv, frih, zucf, zcr
-      REAL, dimension(klon) :: zcfm1, zcfh1
-      REAL, dimension(klon) :: zcfm2, zcfh2
-      REAL, dimension(klon) :: trm0, trm1
-
-  CHARACTER (LEN=80) :: abort_message
-  CHARACTER (LEN=20) :: modname = 'coefcdra'
-
-
-!
-
-
-!-------------------------------------------------------------------------
-      REAL :: fsta, fins, x
-      fsta(x) = 1.0 / (1.0+10.0*x*(1+8.0*x))
-      fins(x) = SQRT(1.0-18.0*x)
-!-------------------------------------------------------------------------
-
-  abort_message='obsolete, remplace par cdrag, use at you own risk'
-  CALL abort_physic(modname,abort_message,1)
-
-!
-      DO i = 1, knon
-!
-       zdphi(i) = zgeop(i)
-       zdu2(i) = max(cepdu2,speed(i)**2)
-       pref(i) = exp(log(psol(i)) - zdphi(i)/(RD*t(i)* &
-                 (1.+ RETV * max(q(i),0.0))))
-       ztsolv(i) = ts(i)
-!       ztvd(i) = t(i) * (psol(i)/pref(i))**RKAPPA
-!       ztvd(i) = (t(i)+zdphi(i)/RCPD/(1.+RVTMP2*q(i))) &
-!          *(1.+RETV*q(i))
-       ztvd(i) = (t(i)+zdphi(i)/RCPD/(1.+RVTMP2*q(i)))
-       trm0(i) = 1. + RETV * max(qsurf(i),0.0)
-       trm1(i) = 1. + RETV * max(q(i),0.0)
-       ztsolv(i) = ztsolv(i) * trm0(i)
-       ztvd(i) = ztvd(i) * trm1(i)
-       zri1(i) = zdphi(i)*(ztvd(i)-ztsolv(i))/(zdu2(i)*ztvd(i))
-!
-! on teste zri1 par rapport au Richardson de la 1ere couche ri1 
-!
-!IM +++
-       IF(1.EQ.0) THEN
-       IF (okri) THEN
-         IF (ri1(i).GE.0.0.AND.zri1(i).LT.0.0) THEN
-           zri1(i) = ri1(i)
-         ELSE IF(ri1(i).LT.0.0.AND.zri1(i).GE.0.0) THEN
-           zri1(i) = ri1(i)
-         ENDIF 
-       ENDIF
-       ENDIF
-!IM ---
-! 
-       cdran(i) = (RKAR/log(1.+zdphi(i)/(RG*rugos(i))))**2
-
-       IF (zri1(i) .ge. 0.) THEN 
-!
-! situation stable : pour eviter les inconsistances dans les cas 
-! tres stables on limite zri1 a 20. cf Hess et al. (1995)
-!
-         zri1(i) = min(20.,zri1(i))
-!
-         IF (.NOT.zxli) THEN
-           zscf(i) = SQRT(1.+CD*ABS(zri1(i)))
-           friv(i) = max(1. / (1.+2.*CB*zri1(i)/ zscf(i)), f_ri_cd_min)
-           zcfm1(i) = cdran(i) * friv(i)
-           frih(i) = max(1./ (1.+3.*CB*zri1(i)*zscf(i)), f_ri_cd_min )
-!           zcfh1(i) = cdran(i) * frih(i)
-           zcfh1(i) = f_cdrag_ter*cdran(i) * frih(i)
-           IF(nsrf.EQ.is_oce) zcfh1(i)=f_cdrag_oce*cdran(i)*frih(i)
-           cdram(i) = zcfm1(i)
-           cdrah(i) = zcfh1(i)
-         ELSE
-           cdram(i) = cdran(i)* fsta(zri1(i))
-           cdrah(i) = cdran(i)* fsta(zri1(i))
-         ENDIF
-!
-       ELSE
-! 
-! situation instable
-!
-         IF (.NOT.zxli) THEN
-           zucf(i) = 1./(1.+3.0*CB*CC*cdran(i)*SQRT(ABS(zri1(i)) &
-                 *(1.0+zdphi(i)/(RG*rugos(i)))))
-           zcfm2(i) = cdran(i)*max((1.-2.0*CB*zri1(i)*zucf(i)),f_ri_cd_min)
-!           zcfh2(i) = cdran(i)*max((1.-3.0*CB*zri1(i)*zucf(i)),f_ri_cd_min)
-           zcfh2(i) = f_cdrag_ter*cdran(i)*max((1.-3.0*CB*zri1(i)*zucf(i)),f_ri_cd_min)
-           cdram(i) = zcfm2(i)
-           cdrah(i) = zcfh2(i)
-         ELSE
-           cdram(i) = cdran(i)* fins(zri1(i))
-           cdrah(i) = cdran(i)* fins(zri1(i))
-         ENDIF
-!
-! cdrah sur l'ocean cf. Miller et al. (1992)
-!
-         zcr(i) = (0.0016/(cdran(i)*SQRT(zdu2(i))))*ABS(ztvd(i)-ztsolv(i)) &
-               **(1./3.)
-!         IF (nsrf.EQ.is_oce) cdrah(i) = cdran(i)*(1.0+zcr(i)**1.25) &
-!                  **(1./1.25)
-         IF (nsrf.EQ.is_oce) cdrah(i)=f_cdrag_oce*cdran(i)*(1.0+zcr(i)**1.25) &
-                  **(1./1.25)
-       ENDIF
-!
-      END DO
-      RETURN 
-      END SUBROUTINE coefcdrag
Index: /LMDZ6/trunk/libf/phylmd/coefcdrag.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/coefcdrag.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/coefcdrag.f90	(revision 5268)
@@ -0,0 +1,167 @@
+!
+!
+!
+      SUBROUTINE coefcdrag (klon, knon, nsrf, zxli, &
+                            speed, t, q, zgeop, psol, &
+                            ts, qsurf, rugos, okri, ri1, &
+                            cdram, cdrah, cdran, zri1, pref)
+
+      USE indice_sol_mod
+
+      IMPLICIT none
+!-------------------------------------------------------------------------
+! Objet : calcul des cdrags pour le moment (cdram) et les flux de chaleur 
+!         sensible et latente (cdrah), du cdrag neutre (cdran), 
+!         du nombre de Richardson entre la surface et le niveau de reference 
+!         (zri1) et de la pression au niveau de reference (pref).    
+!
+! I. Musat, 01.07.2002
+!-------------------------------------------------------------------------
+!
+! klon----input-I- dimension de la grille physique (= nb_pts_latitude X nb_pts_longitude)
+! knon----input-I- nombre de points pour un type de surface
+! nsrf----input-I- indice pour le type de surface; voir indice_sol_mod.F90
+! zxli----input-L- TRUE si calcul des cdrags selon Laurent Li
+! speed---input-R- module du vent au 1er niveau du modele
+! t-------input-R- temperature de l'air au 1er niveau du modele
+! q-------input-R- humidite de l'air au 1er niveau du modele
+! zgeop---input-R- geopotentiel au 1er niveau du modele
+! psol----input-R- pression au sol 
+! ts------input-R- temperature de l'air a la surface
+! qsurf---input-R- humidite de l'air a la surface
+! rugos---input-R- rugosite
+! okri----input-L- TRUE si on veut tester le nb. Richardson entre la sfce 
+!                  et zref par rapport au Ri entre la sfce et la 1ere couche
+! ri1-----input-R- nb. Richardson entre la surface et la 1ere couche
+!
+! cdram--output-R- cdrag pour le moment
+! cdrah--output-R- cdrag pour les flux de chaleur latente et sensible
+! cdran--output-R- cdrag neutre
+! zri1---output-R- nb. Richardson entre la surface et la couche zgeop/RG
+! pref---output-R- pression au niveau zgeop/RG
+!
+      INTEGER, intent(in) :: klon, knon, nsrf
+      LOGICAL, intent(in) :: zxli 
+      REAL, dimension(klon), intent(in) :: speed, t, q, zgeop, psol
+      REAL, dimension(klon), intent(in) :: ts, qsurf, rugos, ri1 
+      LOGICAL, intent(in) :: okri    
+!
+      REAL, dimension(klon), intent(out) :: cdram, cdrah, cdran, zri1, pref
+!-------------------------------------------------------------------------
+!
+      include "YOMCST.h"
+      include "YOETHF.h"
+      INCLUDE "clesphys.h"
+! Quelques constantes :
+      REAL, parameter :: RKAR=0.40, CB=5.0, CC=5.0, CD=5.0, cepdu2=(0.1)**2
+!
+! Variables locales :
+      INTEGER :: i
+      REAL, dimension(klon) :: zdu2, zdphi, ztsolv, ztvd
+      REAL, dimension(klon) :: zscf, friv, frih, zucf, zcr
+      REAL, dimension(klon) :: zcfm1, zcfh1
+      REAL, dimension(klon) :: zcfm2, zcfh2
+      REAL, dimension(klon) :: trm0, trm1
+
+  CHARACTER (LEN=80) :: abort_message
+  CHARACTER (LEN=20) :: modname = 'coefcdra'
+
+
+!
+
+
+!-------------------------------------------------------------------------
+      REAL :: fsta, fins, x
+      fsta(x) = 1.0 / (1.0+10.0*x*(1+8.0*x))
+      fins(x) = SQRT(1.0-18.0*x)
+!-------------------------------------------------------------------------
+
+  abort_message='obsolete, remplace par cdrag, use at you own risk'
+  CALL abort_physic(modname,abort_message,1)
+
+!
+      DO i = 1, knon
+!
+       zdphi(i) = zgeop(i)
+       zdu2(i) = max(cepdu2,speed(i)**2)
+       pref(i) = exp(log(psol(i)) - zdphi(i)/(RD*t(i)* &
+                 (1.+ RETV * max(q(i),0.0))))
+       ztsolv(i) = ts(i)
+!       ztvd(i) = t(i) * (psol(i)/pref(i))**RKAPPA
+!       ztvd(i) = (t(i)+zdphi(i)/RCPD/(1.+RVTMP2*q(i))) &
+!          *(1.+RETV*q(i))
+       ztvd(i) = (t(i)+zdphi(i)/RCPD/(1.+RVTMP2*q(i)))
+       trm0(i) = 1. + RETV * max(qsurf(i),0.0)
+       trm1(i) = 1. + RETV * max(q(i),0.0)
+       ztsolv(i) = ztsolv(i) * trm0(i)
+       ztvd(i) = ztvd(i) * trm1(i)
+       zri1(i) = zdphi(i)*(ztvd(i)-ztsolv(i))/(zdu2(i)*ztvd(i))
+!
+! on teste zri1 par rapport au Richardson de la 1ere couche ri1 
+!
+!IM +++
+       IF(1.EQ.0) THEN
+       IF (okri) THEN
+         IF (ri1(i).GE.0.0.AND.zri1(i).LT.0.0) THEN
+           zri1(i) = ri1(i)
+         ELSE IF(ri1(i).LT.0.0.AND.zri1(i).GE.0.0) THEN
+           zri1(i) = ri1(i)
+         ENDIF 
+       ENDIF
+       ENDIF
+!IM ---
+! 
+       cdran(i) = (RKAR/log(1.+zdphi(i)/(RG*rugos(i))))**2
+
+       IF (zri1(i) .ge. 0.) THEN 
+!
+! situation stable : pour eviter les inconsistances dans les cas 
+! tres stables on limite zri1 a 20. cf Hess et al. (1995)
+!
+         zri1(i) = min(20.,zri1(i))
+!
+         IF (.NOT.zxli) THEN
+           zscf(i) = SQRT(1.+CD*ABS(zri1(i)))
+           friv(i) = max(1. / (1.+2.*CB*zri1(i)/ zscf(i)), f_ri_cd_min)
+           zcfm1(i) = cdran(i) * friv(i)
+           frih(i) = max(1./ (1.+3.*CB*zri1(i)*zscf(i)), f_ri_cd_min )
+!           zcfh1(i) = cdran(i) * frih(i)
+           zcfh1(i) = f_cdrag_ter*cdran(i) * frih(i)
+           IF(nsrf.EQ.is_oce) zcfh1(i)=f_cdrag_oce*cdran(i)*frih(i)
+           cdram(i) = zcfm1(i)
+           cdrah(i) = zcfh1(i)
+         ELSE
+           cdram(i) = cdran(i)* fsta(zri1(i))
+           cdrah(i) = cdran(i)* fsta(zri1(i))
+         ENDIF
+!
+       ELSE
+! 
+! situation instable
+!
+         IF (.NOT.zxli) THEN
+           zucf(i) = 1./(1.+3.0*CB*CC*cdran(i)*SQRT(ABS(zri1(i)) &
+                 *(1.0+zdphi(i)/(RG*rugos(i)))))
+           zcfm2(i) = cdran(i)*max((1.-2.0*CB*zri1(i)*zucf(i)),f_ri_cd_min)
+!           zcfh2(i) = cdran(i)*max((1.-3.0*CB*zri1(i)*zucf(i)),f_ri_cd_min)
+           zcfh2(i) = f_cdrag_ter*cdran(i)*max((1.-3.0*CB*zri1(i)*zucf(i)),f_ri_cd_min)
+           cdram(i) = zcfm2(i)
+           cdrah(i) = zcfh2(i)
+         ELSE
+           cdram(i) = cdran(i)* fins(zri1(i))
+           cdrah(i) = cdran(i)* fins(zri1(i))
+         ENDIF
+!
+! cdrah sur l'ocean cf. Miller et al. (1992)
+!
+         zcr(i) = (0.0016/(cdran(i)*SQRT(zdu2(i))))*ABS(ztvd(i)-ztsolv(i)) &
+               **(1./3.)
+!         IF (nsrf.EQ.is_oce) cdrah(i) = cdran(i)*(1.0+zcr(i)**1.25) &
+!                  **(1./1.25)
+         IF (nsrf.EQ.is_oce) cdrah(i)=f_cdrag_oce*cdran(i)*(1.0+zcr(i)**1.25) &
+                  **(1./1.25)
+       ENDIF
+!
+      END DO
+      RETURN 
+      END SUBROUTINE coefcdrag
Index: DZ6/trunk/libf/phylmd/coefkzmin.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/coefkzmin.F90	(revision 5267)
+++ 	(revision )
@@ -1,132 +1,0 @@
-
-SUBROUTINE coefkzmin(knon, ypaprs, ypplay, yu, yv, yt, yq, ycdragm, km, kn)
-
-  USE dimphy
-  IMPLICIT NONE
-
-  include "YOMCST.h"
-
-  ! .......................................................................
-  ! Entrees modifies en attendant une version ou les zlev, et zlay soient
-  ! disponibles.
-
-  REAL ycdragm(klon)
-
-  REAL yu(klon, klev), yv(klon, klev)
-  REAL yt(klon, klev), yq(klon, klev)
-  REAL ypaprs(klon, klev+1), ypplay(klon, klev)
-  REAL yustar(klon)
-  REAL yzlay(klon, klev), yzlev(klon, klev+1), yteta(klon, klev)
-
-  INTEGER i
-
-  ! .......................................................................
-
-  ! En entree :
-  ! -----------
-
-  ! zlev : altitude a chaque niveau (interface inferieure de la couche
-  ! de meme indice)
-  ! ustar : u*
-
-  ! teta : temperature potentielle au centre de chaque couche
-  ! (en entree : la valeur au debut du pas de temps)
-
-  ! en sortier :
-  ! ------------
-
-  ! km : diffusivite turbulente de quantite de mouvement (au bas de chaque
-  ! couche)
-  ! (en sortie : la valeur a la fin du pas de temps)
-  ! kn : diffusivite turbulente des scalaires (au bas de chaque couche)
-  ! (en sortie : la valeur a la fin du pas de temps)
-
-  ! .......................................................................
-
-  REAL ustar(klon)
-  REAL kmin, qmin, pblhmin(klon), coriol(klon)
-  REAL zlev(klon, klev+1)
-  REAL teta(klon, klev)
-
-  REAL km(klon, klev)
-  REAL kn(klon, klev)
-  INTEGER knon
-
-
-  INTEGER nlay, nlev
-  INTEGER ig, k
-
-  REAL, PARAMETER :: kap = 0.4
-
-  nlay = klev
-  nlev = klev + 1
-  ! .......................................................................
-  ! en attendant une version ou les zlev, et zlay soient
-  ! disponibles.
-  ! Debut de la partie qui doit etre unclue a terme dans clmain.
-
-  DO i = 1, knon
-    yzlay(i, 1) = rd*yt(i, 1)/(0.5*(ypaprs(i,1)+ypplay(i, &
-      1)))*(ypaprs(i,1)-ypplay(i,1))/rg
-  END DO
-  DO k = 2, klev
-    DO i = 1, knon
-      yzlay(i, k) = yzlay(i, k-1) + rd*0.5*(yt(i,k-1)+yt(i,k))/ypaprs(i, k)*( &
-        ypplay(i,k-1)-ypplay(i,k))/rg
-    END DO
-  END DO
-  DO k = 1, klev
-    DO i = 1, knon
-      ! ATTENTION:on passe la temperature potentielle virt. pour le calcul de
-      ! K
-      yteta(i, k) = yt(i, k)*(ypaprs(i,1)/ypplay(i,k))**rkappa* &
-        (1.+0.61*yq(i,k))
-    END DO
-  END DO
-  DO i = 1, knon
-    yzlev(i, 1) = 0.
-    yzlev(i, klev+1) = 2.*yzlay(i, klev) - yzlay(i, klev-1)
-  END DO
-  DO k = 2, klev
-    DO i = 1, knon
-      yzlev(i, k) = 0.5*(yzlay(i,k)+yzlay(i,k-1))
-    END DO
-  END DO
-
-  yustar(1:knon) = sqrt(ycdragm(1:knon)*(yu(1:knon,1)*yu(1:knon,1)+yv(1:knon, &
-    1)*yv(1:knon,1)))
-
-  ! Fin de la partie qui doit etre unclue a terme dans clmain.
-
-  ! ette routine est ecrite pour avoir en entree ustar, teta et zlev
-  ! Ici, on a inclut le calcul de ces trois variables dans la routine
-  ! coefkzmin en attendant une nouvelle version de la couche limite
-  ! ou ces variables seront disponibles.
-
-  ! Debut de la routine coefkzmin proprement dite.
-
-  ustar = yustar
-  teta = yteta
-  zlev = yzlev
-
-  DO ig = 1, knon
-    coriol(ig) = 1.E-4
-    pblhmin(ig) = 0.07*ustar(ig)/max(abs(coriol(ig)), 2.546E-5)
-  END DO
-
-  DO k = 2, klev
-    DO ig = 1, knon
-      IF (teta(ig,2)>teta(ig,1)) THEN
-        qmin = ustar(ig)*(max(1.-zlev(ig,k)/pblhmin(ig),0.))**2
-        kmin = kap*zlev(ig, k)*qmin
-      ELSE
-        kmin = 0. ! kmin n'est utilise que pour les SL stables.
-      END IF
-      kn(ig, k) = kmin
-      km(ig, k) = kmin
-    END DO
-  END DO
-
-
-  RETURN
-END SUBROUTINE coefkzmin
Index: /LMDZ6/trunk/libf/phylmd/coefkzmin.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/coefkzmin.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/coefkzmin.f90	(revision 5268)
@@ -0,0 +1,132 @@
+
+SUBROUTINE coefkzmin(knon, ypaprs, ypplay, yu, yv, yt, yq, ycdragm, km, kn)
+
+  USE dimphy
+  IMPLICIT NONE
+
+  include "YOMCST.h"
+
+  ! .......................................................................
+  ! Entrees modifies en attendant une version ou les zlev, et zlay soient
+  ! disponibles.
+
+  REAL ycdragm(klon)
+
+  REAL yu(klon, klev), yv(klon, klev)
+  REAL yt(klon, klev), yq(klon, klev)
+  REAL ypaprs(klon, klev+1), ypplay(klon, klev)
+  REAL yustar(klon)
+  REAL yzlay(klon, klev), yzlev(klon, klev+1), yteta(klon, klev)
+
+  INTEGER i
+
+  ! .......................................................................
+
+  ! En entree :
+  ! -----------
+
+  ! zlev : altitude a chaque niveau (interface inferieure de la couche
+  ! de meme indice)
+  ! ustar : u*
+
+  ! teta : temperature potentielle au centre de chaque couche
+  ! (en entree : la valeur au debut du pas de temps)
+
+  ! en sortier :
+  ! ------------
+
+  ! km : diffusivite turbulente de quantite de mouvement (au bas de chaque
+  ! couche)
+  ! (en sortie : la valeur a la fin du pas de temps)
+  ! kn : diffusivite turbulente des scalaires (au bas de chaque couche)
+  ! (en sortie : la valeur a la fin du pas de temps)
+
+  ! .......................................................................
+
+  REAL ustar(klon)
+  REAL kmin, qmin, pblhmin(klon), coriol(klon)
+  REAL zlev(klon, klev+1)
+  REAL teta(klon, klev)
+
+  REAL km(klon, klev)
+  REAL kn(klon, klev)
+  INTEGER knon
+
+
+  INTEGER nlay, nlev
+  INTEGER ig, k
+
+  REAL, PARAMETER :: kap = 0.4
+
+  nlay = klev
+  nlev = klev + 1
+  ! .......................................................................
+  ! en attendant une version ou les zlev, et zlay soient
+  ! disponibles.
+  ! Debut de la partie qui doit etre unclue a terme dans clmain.
+
+  DO i = 1, knon
+    yzlay(i, 1) = rd*yt(i, 1)/(0.5*(ypaprs(i,1)+ypplay(i, &
+      1)))*(ypaprs(i,1)-ypplay(i,1))/rg
+  END DO
+  DO k = 2, klev
+    DO i = 1, knon
+      yzlay(i, k) = yzlay(i, k-1) + rd*0.5*(yt(i,k-1)+yt(i,k))/ypaprs(i, k)*( &
+        ypplay(i,k-1)-ypplay(i,k))/rg
+    END DO
+  END DO
+  DO k = 1, klev
+    DO i = 1, knon
+      ! ATTENTION:on passe la temperature potentielle virt. pour le calcul de
+      ! K
+      yteta(i, k) = yt(i, k)*(ypaprs(i,1)/ypplay(i,k))**rkappa* &
+        (1.+0.61*yq(i,k))
+    END DO
+  END DO
+  DO i = 1, knon
+    yzlev(i, 1) = 0.
+    yzlev(i, klev+1) = 2.*yzlay(i, klev) - yzlay(i, klev-1)
+  END DO
+  DO k = 2, klev
+    DO i = 1, knon
+      yzlev(i, k) = 0.5*(yzlay(i,k)+yzlay(i,k-1))
+    END DO
+  END DO
+
+  yustar(1:knon) = sqrt(ycdragm(1:knon)*(yu(1:knon,1)*yu(1:knon,1)+yv(1:knon, &
+    1)*yv(1:knon,1)))
+
+  ! Fin de la partie qui doit etre unclue a terme dans clmain.
+
+  ! ette routine est ecrite pour avoir en entree ustar, teta et zlev
+  ! Ici, on a inclut le calcul de ces trois variables dans la routine
+  ! coefkzmin en attendant une nouvelle version de la couche limite
+  ! ou ces variables seront disponibles.
+
+  ! Debut de la routine coefkzmin proprement dite.
+
+  ustar = yustar
+  teta = yteta
+  zlev = yzlev
+
+  DO ig = 1, knon
+    coriol(ig) = 1.E-4
+    pblhmin(ig) = 0.07*ustar(ig)/max(abs(coriol(ig)), 2.546E-5)
+  END DO
+
+  DO k = 2, klev
+    DO ig = 1, knon
+      IF (teta(ig,2)>teta(ig,1)) THEN
+        qmin = ustar(ig)*(max(1.-zlev(ig,k)/pblhmin(ig),0.))**2
+        kmin = kap*zlev(ig, k)*qmin
+      ELSE
+        kmin = 0. ! kmin n'est utilise que pour les SL stables.
+      END IF
+      kn(ig, k) = kmin
+      km(ig, k) = kmin
+    END DO
+  END DO
+
+
+  RETURN
+END SUBROUTINE coefkzmin
Index: DZ6/trunk/libf/phylmd/conccm.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/conccm.F90	(revision 5267)
+++ 	(revision )
@@ -1,818 +1,0 @@
-
-! $Header$
-
-SUBROUTINE conccm(dtime, paprs, pplay, t, q, conv_q, d_t, d_q, rain, snow, &
-    kbascm, ktopcm)
-
-  USE dimphy
-  IMPLICIT NONE
-  ! ======================================================================
-  ! Auteur(s): Z.X. Li (LMD/CNRS) date: le 14 mars 1996
-  ! Objet: Schema simple (avec flux de masse) pour la convection
-  ! (schema standard du modele NCAR CCM2)
-  ! ======================================================================
-  include "YOMCST.h"
-  include "YOETHF.h"
-
-  ! Entree:
-  REAL dtime ! pas d'integration
-  REAL paprs(klon, klev+1) ! pression inter-couche (Pa)
-  REAL pplay(klon, klev) ! pression au milieu de couche (Pa)
-  REAL t(klon, klev) ! temperature (K)
-  REAL q(klon, klev) ! humidite specifique (g/g)
-  REAL conv_q(klon, klev) ! taux de convergence humidite (g/g/s)
-  ! Sortie:
-  REAL d_t(klon, klev) ! incrementation temperature
-  REAL d_q(klon, klev) ! incrementation vapeur
-  REAL rain(klon) ! pluie (mm/s)
-  REAL snow(klon) ! neige (mm/s)
-  INTEGER kbascm(klon) ! niveau du bas de convection
-  INTEGER ktopcm(klon) ! niveau du haut de convection
-
-  REAL pt(klon, klev)
-  REAL pq(klon, klev)
-  REAL pres(klon, klev)
-  REAL dp(klon, klev)
-  REAL zgeom(klon, klev)
-  REAL cmfprs(klon)
-  REAL cmfprt(klon)
-  INTEGER ntop(klon)
-  INTEGER nbas(klon)
-  INTEGER i, k
-  REAL zlvdcp, zlsdcp, zdelta, zz, za, zb
-
-  LOGICAL usekuo ! utiliser convection profonde (schema Kuo)
-  PARAMETER (usekuo=.TRUE.)
-
-  REAL d_t_bis(klon, klev)
-  REAL d_q_bis(klon, klev)
-  REAL rain_bis(klon)
-  REAL snow_bis(klon)
-  INTEGER ibas_bis(klon)
-  INTEGER itop_bis(klon)
-  REAL d_ql_bis(klon, klev)
-  REAL rneb_bis(klon, klev)
-
-  ! initialiser les variables de sortie (pour securite)
-  DO i = 1, klon
-    rain(i) = 0.0
-    snow(i) = 0.0
-    kbascm(i) = 0
-    ktopcm(i) = 0
-  END DO
-  DO k = 1, klev
-    DO i = 1, klon
-      d_t(i, k) = 0.0
-      d_q(i, k) = 0.0
-    END DO
-  END DO
-
-  ! preparer les variables d'entree (attention: l'ordre des niveaux
-  ! verticaux augmente du haut vers le bas)
-  DO k = 1, klev
-    DO i = 1, klon
-      pt(i, k) = t(i, klev-k+1)
-      pq(i, k) = q(i, klev-k+1)
-      pres(i, k) = pplay(i, klev-k+1)
-      dp(i, k) = paprs(i, klev+1-k) - paprs(i, klev+1-k+1)
-    END DO
-  END DO
-  DO i = 1, klon
-    zgeom(i, klev) = rd*t(i, 1)/(0.5*(paprs(i,1)+pplay(i, &
-      1)))*(paprs(i,1)-pplay(i,1))
-  END DO
-  DO k = 2, klev
-    DO i = 1, klon
-      zgeom(i, klev+1-k) = zgeom(i, klev+1-k+1) + rd*0.5*(t(i,k-1)+t(i,k))/ &
-        paprs(i, k)*(pplay(i,k-1)-pplay(i,k))
-    END DO
-  END DO
-
-  CALL cmfmca(dtime, pres, dp, zgeom, pt, pq, cmfprt, cmfprs, ntop, nbas)
-
-  DO k = 1, klev
-    DO i = 1, klon
-      d_q(i, klev+1-k) = pq(i, k) - q(i, klev+1-k)
-      d_t(i, klev+1-k) = pt(i, k) - t(i, klev+1-k)
-    END DO
-  END DO
-
-  DO i = 1, klon
-    rain(i) = cmfprt(i)*rhoh2o
-    snow(i) = cmfprs(i)*rhoh2o
-    kbascm(i) = klev + 1 - nbas(i)
-    ktopcm(i) = klev + 1 - ntop(i)
-  END DO
-
-  IF (usekuo) THEN
-    CALL conkuo(dtime, paprs, pplay, t, q, conv_q, d_t_bis, d_q_bis, &
-      d_ql_bis, rneb_bis, rain_bis, snow_bis, ibas_bis, itop_bis)
-    DO k = 1, klev
-      DO i = 1, klon
-        d_t(i, k) = d_t(i, k) + d_t_bis(i, k)
-        d_q(i, k) = d_q(i, k) + d_q_bis(i, k)
-      END DO
-    END DO
-    DO i = 1, klon
-      rain(i) = rain(i) + rain_bis(i)
-      snow(i) = snow(i) + snow_bis(i)
-      kbascm(i) = min(kbascm(i), ibas_bis(i))
-      ktopcm(i) = max(ktopcm(i), itop_bis(i))
-    END DO
-    DO k = 1, klev ! eau liquide convective est
-      DO i = 1, klon ! dispersee dans l'air
-        zlvdcp = rlvtt/rcpd/(1.0+rvtmp2*q(i,k))
-        zlsdcp = rlstt/rcpd/(1.0+rvtmp2*q(i,k))
-        zdelta = max(0., sign(1.,rtt-t(i,k)))
-        zz = d_ql_bis(i, k) ! re-evap. de l'eau liquide
-        zb = max(0.0, zz)
-        za = -max(0.0, zz)*(zlvdcp*(1.-zdelta)+zlsdcp*zdelta)
-        d_t(i, k) = d_t(i, k) + za
-        d_q(i, k) = d_q(i, k) + zb
-      END DO
-    END DO
-  END IF
-
-  RETURN
-END SUBROUTINE conccm
-SUBROUTINE cmfmca(deltat, p, dp, gz, tb, shb, cmfprt, cmfprs, cnt, cnb)
-  USE dimphy
-  IMPLICIT NONE
-  ! -----------------------------------------------------------------------
-  ! Moist convective mass flux procedure:
-  ! If stratification is unstable to nonentraining parcel ascent,
-  ! complete an adjustment making use of a simple cloud model
-
-  ! Code generalized to allow specification of parcel ("updraft")
-  ! properties, as well as convective transport of an arbitrary
-  ! number of passive constituents (see cmrb array).
-  ! ----------------------------Code History-------------------------------
-  ! Original version:  J. J. Hack, March 22, 1990
-  ! Standardized:      J. Rosinski, June 1992
-  ! Reviewed:          J. Hack, G. Taylor, August 1992
-  ! Adaptation au LMD: Z.X. Li, mars 1996 (reference: Hack 1994,
-  ! J. Geophys. Res. vol 99, D3, 5551-5568). J'ai
-  ! introduit les constantes et les fonctions thermo-
-  ! dynamiques du Centre Europeen. J'ai elimine le
-  ! re-indicage du code en esperant que cela pourra
-  ! simplifier la lecture et la comprehension.
-  ! -----------------------------------------------------------------------
-  INTEGER pcnst ! nombre de traceurs passifs
-  PARAMETER (pcnst=1)
-  ! ------------------------------Arguments--------------------------------
-  ! Input arguments
-
-  REAL deltat ! time step (seconds)
-  REAL p(klon, klev) ! pressure
-  REAL dp(klon, klev) ! delta-p
-  REAL gz(klon, klev) ! geopotential (a partir du sol)
-
-  REAL thtap(klon) ! PBL perturbation theta
-  REAL shp(klon) ! PBL perturbation specific humidity
-  REAL pblh(klon) ! PBL height (provided by PBL routine)
-  REAL cmrp(klon, pcnst) ! constituent perturbations in PBL
-
-  ! Updated arguments:
-
-  REAL tb(klon, klev) ! temperature (t bar)
-  REAL shb(klon, klev) ! specific humidity (sh bar)
-  REAL cmrb(klon, klev, pcnst) ! constituent mixing ratios (cmr bar)
-
-  ! Output arguments
-
-  REAL cmfdt(klon, klev) ! dT/dt due to moist convection
-  REAL cmfdq(klon, klev) ! dq/dt due to moist convection
-  REAL cmfmc(klon, klev) ! moist convection cloud mass flux
-  REAL cmfdqr(klon, klev) ! dq/dt due to convective rainout
-  REAL cmfsl(klon, klev) ! convective lw static energy flux
-  REAL cmflq(klon, klev) ! convective total water flux
-  REAL cmfprt(klon) ! convective precipitation rate
-  REAL cmfprs(klon) ! convective snowfall rate
-  REAL qc(klon, klev) ! dq/dt due to rainout terms
-  INTEGER cnt(klon) ! top level of convective activity
-  INTEGER cnb(klon) ! bottom level of convective activity
-  ! ------------------------------Parameters-------------------------------
-  REAL c0 ! rain water autoconversion coefficient
-  PARAMETER (c0=1.0E-4)
-  REAL dzmin ! minimum convective depth for precipitation
-  PARAMETER (dzmin=0.0)
-  REAL betamn ! minimum overshoot parameter
-  PARAMETER (betamn=0.10)
-  REAL cmftau ! characteristic adjustment time scale
-  PARAMETER (cmftau=3600.)
-  INTEGER limcnv ! top interface level limit for convection
-  PARAMETER (limcnv=1)
-  REAL tpmax ! maximum acceptable t perturbation (degrees C)
-  PARAMETER (tpmax=1.50)
-  REAL shpmax ! maximum acceptable q perturbation (g/g)
-  PARAMETER (shpmax=1.50E-3)
-  REAL tiny ! arbitrary small num used in transport estimates
-  PARAMETER (tiny=1.0E-36)
-  REAL eps ! convergence criteria (machine dependent)
-  PARAMETER (eps=1.0E-13)
-  REAL tmelt ! freezing point of water(req'd for rain vs snow)
-  PARAMETER (tmelt=273.15)
-  REAL ssfac ! supersaturation bound (detrained air)
-  PARAMETER (ssfac=1.001)
-
-  ! ---------------------------Local workspace-----------------------------
-  REAL gam(klon, klev) ! L/cp (d(qsat)/dT)
-  REAL sb(klon, klev) ! dry static energy (s bar)
-  REAL hb(klon, klev) ! moist static energy (h bar)
-  REAL shbs(klon, klev) ! sat. specific humidity (sh bar star)
-  REAL hbs(klon, klev) ! sat. moist static energy (h bar star)
-  REAL shbh(klon, klev+1) ! specific humidity on interfaces
-  REAL sbh(klon, klev+1) ! s bar on interfaces
-  REAL hbh(klon, klev+1) ! h bar on interfaces
-  REAL cmrh(klon, klev+1) ! interface constituent mixing ratio
-  REAL prec(klon) ! instantaneous total precipitation
-  REAL dzcld(klon) ! depth of convective layer (m)
-  REAL beta(klon) ! overshoot parameter (fraction)
-  REAL betamx ! local maximum on overshoot
-  REAL eta(klon) ! convective mass flux (kg/m^2 s)
-  REAL etagdt ! eta*grav*deltat
-  REAL cldwtr(klon) ! cloud water (mass)
-  REAL rnwtr(klon) ! rain water  (mass)
-  REAL sc(klon) ! dry static energy   ("in-cloud")
-  REAL shc(klon) ! specific humidity   ("in-cloud")
-  REAL hc(klon) ! moist static energy ("in-cloud")
-  REAL cmrc(klon) ! constituent mix rat ("in-cloud")
-  REAL dq1(klon) ! shb  convective change (lower lvl)
-  REAL dq2(klon) ! shb  convective change (mid level)
-  REAL dq3(klon) ! shb  convective change (upper lvl)
-  REAL ds1(klon) ! sb   convective change (lower lvl)
-  REAL ds2(klon) ! sb   convective change (mid level)
-  REAL ds3(klon) ! sb   convective change (upper lvl)
-  REAL dcmr1(klon) ! cmrb convective change (lower lvl)
-  REAL dcmr2(klon) ! cmrb convective change (mid level)
-  REAL dcmr3(klon) ! cmrb convective change (upper lvl)
-  REAL flotab(klon) ! hc - hbs (mesure d'instabilite)
-  LOGICAL ldcum(klon) ! .true. si la convection existe
-  LOGICAL etagt0 ! true if eta > 0.0
-  REAL dt ! current 2 delta-t (model time step)
-  REAL cats ! modified characteristic adj. time
-  REAL rdt ! 1./dt
-  REAL qprime ! modified specific humidity pert.
-  REAL tprime ! modified thermal perturbation
-  REAL pblhgt ! bounded pbl height (max[pblh,1m])
-  REAL fac1 ! intermediate scratch variable
-  REAL shprme ! intermediate specific humidity pert.
-  REAL qsattp ! saturation mixing ratio for
-  ! !  thermally perturbed PBL parcels
-  REAL dz ! local layer depth
-  REAL b1 ! bouyancy measure in detrainment lvl
-  REAL b2 ! bouyancy measure in condensation lvl
-  REAL g ! bounded vertical gradient of hb
-  REAL tmass ! total mass available for convective exchange
-  REAL denom ! intermediate scratch variable
-  REAL qtest1 ! used in negative q test (middle lvl)
-  REAL qtest2 ! used in negative q test (lower lvl)
-  REAL fslkp ! flux lw static energy (bot interface)
-  REAL fslkm ! flux lw static energy (top interface)
-  REAL fqlkp ! flux total water (bottom interface)
-  REAL fqlkm ! flux total water (top interface)
-  REAL botflx ! bottom constituent mixing ratio flux
-  REAL topflx ! top constituent mixing ratio flux
-  REAL efac1 ! ratio cmrb to convectively induced change (bot lvl)
-  REAL efac2 ! ratio cmrb to convectively induced change (mid lvl)
-  REAL efac3 ! ratio cmrb to convectively induced change (top lvl)
-
-  INTEGER i, k ! indices horizontal et vertical
-  INTEGER km1 ! k-1 (index offset)
-  INTEGER kp1 ! k+1 (index offset)
-  INTEGER m ! constituent index
-  INTEGER ktp ! temporary index used to track top
-  INTEGER is ! nombre de points a ajuster
-
-  REAL tmp1, tmp2, tmp3, tmp4
-  REAL zx_t, zx_p, zx_q, zx_qs, zx_gam
-  REAL zcor, zdelta, zcvm5
-
-  REAL qhalf, sh1, sh2, shbs1, shbs2
-  include "YOMCST.h"
-  include "YOETHF.h"
-  include "FCTTRE.h"
-  qhalf(sh1, sh2, shbs1, shbs2) = min(max(sh1,sh2), &
-    (shbs2*sh1+shbs1*sh2)/(shbs1+shbs2))
-
-  ! -----------------------------------------------------------------------
-  ! pas de traceur pour l'instant
-  DO m = 1, pcnst
-    DO k = 1, klev
-      DO i = 1, klon
-        cmrb(i, k, m) = 0.0
-      END DO
-    END DO
-  END DO
-
-  ! Les perturbations de la couche limite sont zero pour l'instant
-
-  DO m = 1, pcnst
-    DO i = 1, klon
-      cmrp(i, m) = 0.0
-    END DO
-  END DO
-  DO i = 1, klon
-    thtap(i) = 0.0
-    shp(i) = 0.0
-    pblh(i) = 1.0
-  END DO
-
-  ! Ensure that characteristic adjustment time scale (cmftau) assumed
-  ! in estimate of eta isn't smaller than model time scale (deltat)
-
-  dt = deltat
-  cats = max(dt, cmftau)
-  rdt = 1.0/dt
-
-  ! Compute sb,hb,shbs,hbs
-
-  DO k = 1, klev
-    DO i = 1, klon
-      zx_t = tb(i, k)
-      zx_p = p(i, k)
-      zx_q = shb(i, k)
-      zdelta = max(0., sign(1.,rtt-zx_t))
-      zcvm5 = r5les*rlvtt*(1.-zdelta) + r5ies*rlstt*zdelta
-      zcvm5 = zcvm5/rcpd/(1.0+rvtmp2*zx_q)
-      zx_qs = r2es*foeew(zx_t, zdelta)/zx_p
-      zx_qs = min(0.5, zx_qs)
-      zcor = 1./(1.-retv*zx_qs)
-      zx_qs = zx_qs*zcor
-      zx_gam = foede(zx_t, zdelta, zcvm5, zx_qs, zcor)
-      shbs(i, k) = zx_qs
-      gam(i, k) = zx_gam
-    END DO
-  END DO
-
-  DO k = limcnv, klev
-    DO i = 1, klon
-      sb(i, k) = rcpd*tb(i, k) + gz(i, k)
-      hb(i, k) = sb(i, k) + rlvtt*shb(i, k)
-      hbs(i, k) = sb(i, k) + rlvtt*shbs(i, k)
-    END DO
-  END DO
-
-  ! Compute sbh, shbh
-
-  DO k = limcnv + 1, klev
-    km1 = k - 1
-    DO i = 1, klon
-      sbh(i, k) = 0.5*(sb(i,km1)+sb(i,k))
-      shbh(i, k) = qhalf(shb(i,km1), shb(i,k), shbs(i,km1), shbs(i,k))
-      hbh(i, k) = sbh(i, k) + rlvtt*shbh(i, k)
-    END DO
-  END DO
-
-  ! Specify properties at top of model (not used, but filling anyway)
-
-  DO i = 1, klon
-    sbh(i, limcnv) = sb(i, limcnv)
-    shbh(i, limcnv) = shb(i, limcnv)
-    hbh(i, limcnv) = hb(i, limcnv)
-  END DO
-
-  ! Zero vertically independent control, tendency & diagnostic arrays
-
-  DO i = 1, klon
-    prec(i) = 0.0
-    dzcld(i) = 0.0
-    cnb(i) = 0
-    cnt(i) = klev + 1
-  END DO
-
-  DO k = 1, klev
-    DO i = 1, klon
-      cmfdt(i, k) = 0.
-      cmfdq(i, k) = 0.
-      cmfdqr(i, k) = 0.
-      cmfmc(i, k) = 0.
-      cmfsl(i, k) = 0.
-      cmflq(i, k) = 0.
-    END DO
-  END DO
-
-  ! Begin moist convective mass flux adjustment procedure.
-  ! Formalism ensures that negative cloud liquid water can never occur
-
-  DO k = klev - 1, limcnv + 1, -1
-    km1 = k - 1
-    kp1 = k + 1
-    DO i = 1, klon
-      eta(i) = 0.0
-      beta(i) = 0.0
-      ds1(i) = 0.0
-      ds2(i) = 0.0
-      ds3(i) = 0.0
-      dq1(i) = 0.0
-      dq2(i) = 0.0
-      dq3(i) = 0.0
-
-      ! Specification of "cloud base" conditions
-
-      qprime = 0.0
-      tprime = 0.0
-
-      ! Assign tprime within the PBL to be proportional to the quantity
-      ! thtap (which will be bounded by tpmax), passed to this routine by
-      ! the PBL routine.  Don't allow perturbation to produce a dry
-      ! adiabatically unstable parcel.  Assign qprime within the PBL to be
-      ! an appropriately modified value of the quantity shp (which will be
-      ! bounded by shpmax) passed to this routine by the PBL routine.  The
-      ! quantity qprime should be less than the local saturation value
-      ! (qsattp=qsat[t+tprime,p]).  In both cases, thtap and shp are
-      ! linearly reduced toward zero as the PBL top is approached.
-
-      pblhgt = max(pblh(i), 1.0)
-      IF (gz(i,kp1)/rg<=pblhgt .AND. dzcld(i)==0.0) THEN
-        fac1 = max(0.0, 1.0-gz(i,kp1)/rg/pblhgt)
-        tprime = min(thtap(i), tpmax)*fac1
-        qsattp = shbs(i, kp1) + rcpd/rlvtt*gam(i, kp1)*tprime
-        shprme = min(min(shp(i),shpmax)*fac1, max(qsattp-shb(i,kp1),0.0))
-        qprime = max(qprime, shprme)
-      ELSE
-        tprime = 0.0
-        qprime = 0.0
-      END IF
-
-      ! Specify "updraft" (in-cloud) thermodynamic properties
-
-      sc(i) = sb(i, kp1) + rcpd*tprime
-      shc(i) = shb(i, kp1) + qprime
-      hc(i) = sc(i) + rlvtt*shc(i)
-      flotab(i) = hc(i) - hbs(i, k)
-      dz = dp(i, k)*rd*tb(i, k)/rg/p(i, k)
-      IF (flotab(i)>0.0) THEN
-        dzcld(i) = dzcld(i) + dz
-      ELSE
-        dzcld(i) = 0.0
-      END IF
-    END DO
-
-    ! Check on moist convective instability
-
-    is = 0
-    DO i = 1, klon
-      IF (flotab(i)>0.0) THEN
-        ldcum(i) = .TRUE.
-        is = is + 1
-      ELSE
-        ldcum(i) = .FALSE.
-      END IF
-    END DO
-
-    IF (is==0) THEN
-      DO i = 1, klon
-        dzcld(i) = 0.0
-      END DO
-      GO TO 70
-    END IF
-
-    ! Current level just below top level => no overshoot
-
-    IF (k<=limcnv+1) THEN
-      DO i = 1, klon
-        IF (ldcum(i)) THEN
-          cldwtr(i) = sb(i, k) - sc(i) + flotab(i)/(1.0+gam(i,k))
-          cldwtr(i) = max(0.0, cldwtr(i))
-          beta(i) = 0.0
-        END IF
-      END DO
-      GO TO 20
-    END IF
-
-    ! First guess at overshoot parameter using crude buoyancy closure
-    ! 10% overshoot assumed as a minimum and 1-c0*dz maximum to start
-    ! If pre-existing supersaturation in detrainment layer, beta=0
-    ! cldwtr is temporarily equal to RLVTT*l (l=> liquid water)
-
-    DO i = 1, klon
-      IF (ldcum(i)) THEN
-        cldwtr(i) = sb(i, k) - sc(i) + flotab(i)/(1.0+gam(i,k))
-        cldwtr(i) = max(0.0, cldwtr(i))
-        betamx = 1.0 - c0*max(0.0, (dzcld(i)-dzmin))
-        b1 = (hc(i)-hbs(i,km1))*dp(i, km1)
-        b2 = (hc(i)-hbs(i,k))*dp(i, k)
-        beta(i) = max(betamn, min(betamx,1.0+b1/b2))
-        IF (hbs(i,km1)<=hb(i,km1)) beta(i) = 0.0
-      END IF
-    END DO
-
-    ! Bound maximum beta to ensure physically realistic solutions
-
-    ! First check constrains beta so that eta remains positive
-    ! (assuming that eta is already positive for beta equal zero)
-    ! La premiere contrainte de beta est que le flux eta doit etre positif.
-
-    DO i = 1, klon
-      IF (ldcum(i)) THEN
-        tmp1 = (1.0+gam(i,k))*(sc(i)-sbh(i,kp1)+cldwtr(i)) - &
-          (hbh(i,kp1)-hc(i))*dp(i, k)/dp(i, kp1)
-        tmp2 = (1.0+gam(i,k))*(sc(i)-sbh(i,k))
-        IF ((beta(i)*tmp2-tmp1)>0.0) THEN
-          betamx = 0.99*(tmp1/tmp2)
-          beta(i) = max(0.0, min(betamx,beta(i)))
-        END IF
-
-        ! Second check involves supersaturation of "detrainment layer"
-        ! small amount of supersaturation acceptable (by ssfac factor)
-        ! La 2e contrainte est que la convection ne doit pas sursaturer
-        ! la "detrainment layer", Neanmoins, une petite sursaturation
-        ! est acceptee (facteur ssfac).
-
-        IF (hb(i,km1)<hbs(i,km1)) THEN
-          tmp1 = (1.0+gam(i,k))*(sc(i)-sbh(i,kp1)+cldwtr(i)) - &
-            (hbh(i,kp1)-hc(i))*dp(i, k)/dp(i, kp1)
-          tmp1 = tmp1/dp(i, k)
-          tmp2 = gam(i, km1)*(sbh(i,k)-sc(i)+cldwtr(i)) - hbh(i, k) + hc(i) - &
-            sc(i) + sbh(i, k)
-          tmp3 = (1.0+gam(i,k))*(sc(i)-sbh(i,k))/dp(i, k)
-          tmp4 = (dt/cats)*(hc(i)-hbs(i,k))*tmp2/(dp(i,km1)*(hbs(i,km1)-hb(i, &
-            km1))) + tmp3
-          IF ((beta(i)*tmp4-tmp1)>0.0) THEN
-            betamx = ssfac*(tmp1/tmp4)
-            beta(i) = max(0.0, min(betamx,beta(i)))
-          END IF
-        ELSE
-          beta(i) = 0.0
-        END IF
-
-        ! Third check to avoid introducing 2 delta x thermodynamic
-        ! noise in the vertical ... constrain adjusted h (or theta e)
-        ! so that the adjustment doesn't contribute to "kinks" in h
-
-        g = min(0.0, hb(i,k)-hb(i,km1))
-        tmp3 = (hb(i,k)-hb(i,km1)-g)*(cats/dt)/(hc(i)-hbs(i,k))
-        tmp1 = (1.0+gam(i,k))*(sc(i)-sbh(i,kp1)+cldwtr(i)) - &
-          (hbh(i,kp1)-hc(i))*dp(i, k)/dp(i, kp1)
-        tmp1 = tmp1/dp(i, k)
-        tmp1 = tmp3*tmp1 + (hc(i)-hbh(i,kp1))/dp(i, k)
-        tmp2 = tmp3*(1.0+gam(i,k))*(sc(i)-sbh(i,k))/dp(i, k) + &
-          (hc(i)-hbh(i,k)-cldwtr(i))*(1.0/dp(i,k)+1.0/dp(i,kp1))
-        IF ((beta(i)*tmp2-tmp1)>0.0) THEN
-          betamx = 0.0
-          IF (tmp2/=0.0) betamx = tmp1/tmp2
-          beta(i) = max(0.0, min(betamx,beta(i)))
-        END IF
-      END IF
-    END DO
-
-    ! Calculate mass flux required for stabilization.
-
-    ! Ensure that the convective mass flux, eta, is positive by
-    ! setting negative values of eta to zero..
-    ! Ensure that estimated mass flux cannot move more than the
-    ! minimum of total mass contained in either layer k or layer k+1.
-    ! Also test for other pathological cases that result in non-
-    ! physical states and adjust eta accordingly.
-
-20  CONTINUE
-    DO i = 1, klon
-      IF (ldcum(i)) THEN
-        beta(i) = max(0.0, beta(i))
-        tmp1 = hc(i) - hbs(i, k)
-        tmp2 = ((1.0+gam(i,k))*(sc(i)-sbh(i,kp1)+cldwtr(i))-beta(i)*(1.0+gam( &
-          i,k))*(sc(i)-sbh(i,k)))/dp(i, k) - (hbh(i,kp1)-hc(i))/dp(i, kp1)
-        eta(i) = tmp1/(tmp2*rg*cats)
-        tmass = min(dp(i,k), dp(i,kp1))/rg
-        IF (eta(i)>tmass*rdt .OR. eta(i)<=0.0) eta(i) = 0.0
-
-        ! Check on negative q in top layer (bound beta)
-
-        IF (shc(i)-shbh(i,k)<0.0 .AND. beta(i)*eta(i)/=0.0) THEN
-          denom = eta(i)*rg*dt*(shc(i)-shbh(i,k))/dp(i, km1)
-          beta(i) = max(0.0, min(-0.999*shb(i,km1)/denom,beta(i)))
-        END IF
-
-        ! Check on negative q in middle layer (zero eta)
-
-        qtest1 = shb(i, k) + eta(i)*rg*dt*((shc(i)-shbh(i, &
-          kp1))-(1.0-beta(i))*cldwtr(i)/rlvtt-beta(i)*(shc(i)-shbh(i, &
-          k)))/dp(i, k)
-        IF (qtest1<=0.0) eta(i) = 0.0
-
-        ! Check on negative q in lower layer (bound eta)
-
-        fac1 = -(shbh(i,kp1)-shc(i))/dp(i, kp1)
-        qtest2 = shb(i, kp1) - eta(i)*rg*dt*fac1
-        IF (qtest2<0.0) THEN
-          eta(i) = 0.99*shb(i, kp1)/(rg*dt*fac1)
-        END IF
-      END IF
-    END DO
-
-
-    ! Calculate cloud water, rain water, and thermodynamic changes
-
-    DO i = 1, klon
-      IF (ldcum(i)) THEN
-        etagdt = eta(i)*rg*dt
-        cldwtr(i) = etagdt*cldwtr(i)/rlvtt/rg
-        rnwtr(i) = (1.0-beta(i))*cldwtr(i)
-        ds1(i) = etagdt*(sbh(i,kp1)-sc(i))/dp(i, kp1)
-        dq1(i) = etagdt*(shbh(i,kp1)-shc(i))/dp(i, kp1)
-        ds2(i) = (etagdt*(sc(i)-sbh(i,kp1))+rlvtt*rg*cldwtr(i)-beta(i)*etagdt &
-          *(sc(i)-sbh(i,k)))/dp(i, k)
-        dq2(i) = (etagdt*(shc(i)-shbh(i,kp1))-rg*rnwtr(i)-beta(i)*etagdt*(shc &
-          (i)-shbh(i,k)))/dp(i, k)
-        ds3(i) = beta(i)*(etagdt*(sc(i)-sbh(i,k))-rlvtt*rg*cldwtr(i))/dp(i, &
-          km1)
-        dq3(i) = beta(i)*etagdt*(shc(i)-shbh(i,k))/dp(i, km1)
-
-        ! Isolate convective fluxes for later diagnostics
-
-        fslkp = eta(i)*(sc(i)-sbh(i,kp1))
-        fslkm = beta(i)*(eta(i)*(sc(i)-sbh(i,k))-rlvtt*cldwtr(i)*rdt)
-        fqlkp = eta(i)*(shc(i)-shbh(i,kp1))
-        fqlkm = beta(i)*eta(i)*(shc(i)-shbh(i,k))
-
-
-        ! Update thermodynamic profile (update sb, hb, & hbs later)
-
-        tb(i, kp1) = tb(i, kp1) + ds1(i)/rcpd
-        tb(i, k) = tb(i, k) + ds2(i)/rcpd
-        tb(i, km1) = tb(i, km1) + ds3(i)/rcpd
-        shb(i, kp1) = shb(i, kp1) + dq1(i)
-        shb(i, k) = shb(i, k) + dq2(i)
-        shb(i, km1) = shb(i, km1) + dq3(i)
-        prec(i) = prec(i) + rnwtr(i)/rhoh2o
-
-        ! Update diagnostic information for final budget
-        ! Tracking temperature & specific humidity tendencies,
-        ! rainout term, convective mass flux, convective liquid
-        ! water static energy flux, and convective total water flux
-
-        cmfdt(i, kp1) = cmfdt(i, kp1) + ds1(i)/rcpd*rdt
-        cmfdt(i, k) = cmfdt(i, k) + ds2(i)/rcpd*rdt
-        cmfdt(i, km1) = cmfdt(i, km1) + ds3(i)/rcpd*rdt
-        cmfdq(i, kp1) = cmfdq(i, kp1) + dq1(i)*rdt
-        cmfdq(i, k) = cmfdq(i, k) + dq2(i)*rdt
-        cmfdq(i, km1) = cmfdq(i, km1) + dq3(i)*rdt
-        cmfdqr(i, k) = cmfdqr(i, k) + (rg*rnwtr(i)/dp(i,k))*rdt
-        cmfmc(i, kp1) = cmfmc(i, kp1) + eta(i)
-        cmfmc(i, k) = cmfmc(i, k) + beta(i)*eta(i)
-        cmfsl(i, kp1) = cmfsl(i, kp1) + fslkp
-        cmfsl(i, k) = cmfsl(i, k) + fslkm
-        cmflq(i, kp1) = cmflq(i, kp1) + rlvtt*fqlkp
-        cmflq(i, k) = cmflq(i, k) + rlvtt*fqlkm
-        qc(i, k) = (rg*rnwtr(i)/dp(i,k))*rdt
-      END IF
-    END DO
-
-    ! Next, convectively modify passive constituents
-
-    DO m = 1, pcnst
-      DO i = 1, klon
-        IF (ldcum(i)) THEN
-
-          ! If any of the reported values of the constituent is negative in
-          ! the three adjacent levels, nothing will be done to the profile
-
-          IF ((cmrb(i,kp1,m)<0.0) .OR. (cmrb(i,k,m)<0.0) .OR. (cmrb(i,km1, &
-            m)<0.0)) GO TO 40
-
-          ! Specify constituent interface values (linear interpolation)
-
-          cmrh(i, k) = 0.5*(cmrb(i,km1,m)+cmrb(i,k,m))
-          cmrh(i, kp1) = 0.5*(cmrb(i,k,m)+cmrb(i,kp1,m))
-
-          ! Specify perturbation properties of constituents in PBL
-
-          pblhgt = max(pblh(i), 1.0)
-          IF (gz(i,kp1)/rg<=pblhgt .AND. dzcld(i)==0.) THEN
-            fac1 = max(0.0, 1.0-gz(i,kp1)/rg/pblhgt)
-            cmrc(i) = cmrb(i, kp1, m) + cmrp(i, m)*fac1
-          ELSE
-            cmrc(i) = cmrb(i, kp1, m)
-          END IF
-
-          ! Determine fluxes, flux divergence => changes due to convection
-          ! Logic must be included to avoid producing negative values. A bit
-          ! messy since there are no a priori assumptions about profiles.
-          ! Tendency is modified (reduced) when pending disaster detected.
-
-          etagdt = eta(i)*rg*dt
-          botflx = etagdt*(cmrc(i)-cmrh(i,kp1))
-          topflx = beta(i)*etagdt*(cmrc(i)-cmrh(i,k))
-          dcmr1(i) = -botflx/dp(i, kp1)
-          efac1 = 1.0
-          efac2 = 1.0
-          efac3 = 1.0
-
-          IF (cmrb(i,kp1,m)+dcmr1(i)<0.0) THEN
-            efac1 = max(tiny, abs(cmrb(i,kp1,m)/dcmr1(i))-eps)
-          END IF
-
-          IF (efac1==tiny .OR. efac1>1.0) efac1 = 0.0
-          dcmr1(i) = -efac1*botflx/dp(i, kp1)
-          dcmr2(i) = (efac1*botflx-topflx)/dp(i, k)
-
-          IF (cmrb(i,k,m)+dcmr2(i)<0.0) THEN
-            efac2 = max(tiny, abs(cmrb(i,k,m)/dcmr2(i))-eps)
-          END IF
-
-          IF (efac2==tiny .OR. efac2>1.0) efac2 = 0.0
-          dcmr2(i) = (efac1*botflx-efac2*topflx)/dp(i, k)
-          dcmr3(i) = efac2*topflx/dp(i, km1)
-
-          IF (cmrb(i,km1,m)+dcmr3(i)<0.0) THEN
-            efac3 = max(tiny, abs(cmrb(i,km1,m)/dcmr3(i))-eps)
-          END IF
-
-          IF (efac3==tiny .OR. efac3>1.0) efac3 = 0.0
-          efac3 = min(efac2, efac3)
-          dcmr2(i) = (efac1*botflx-efac3*topflx)/dp(i, k)
-          dcmr3(i) = efac3*topflx/dp(i, km1)
-
-          cmrb(i, kp1, m) = cmrb(i, kp1, m) + dcmr1(i)
-          cmrb(i, k, m) = cmrb(i, k, m) + dcmr2(i)
-          cmrb(i, km1, m) = cmrb(i, km1, m) + dcmr3(i)
-        END IF
-40    END DO
-    END DO ! end of m=1,pcnst loop
-
-    IF (k==limcnv+1) GO TO 60 ! on ne pourra plus glisser
-
-    ! Dans la procedure de glissage ascendant, les variables thermo-
-    ! dynamiques des couches k et km1 servent au calcul des couches
-    ! superieures. Elles ont donc besoin d'une mise-a-jour.
-
-    DO i = 1, klon
-      IF (ldcum(i)) THEN
-        zx_t = tb(i, k)
-        zx_p = p(i, k)
-        zx_q = shb(i, k)
-        zdelta = max(0., sign(1.,rtt-zx_t))
-        zcvm5 = r5les*rlvtt*(1.-zdelta) + r5ies*rlstt*zdelta
-        zcvm5 = zcvm5/rcpd/(1.0+rvtmp2*zx_q)
-        zx_qs = r2es*foeew(zx_t, zdelta)/zx_p
-        zx_qs = min(0.5, zx_qs)
-        zcor = 1./(1.-retv*zx_qs)
-        zx_qs = zx_qs*zcor
-        zx_gam = foede(zx_t, zdelta, zcvm5, zx_qs, zcor)
-        shbs(i, k) = zx_qs
-        gam(i, k) = zx_gam
-
-        zx_t = tb(i, km1)
-        zx_p = p(i, km1)
-        zx_q = shb(i, km1)
-        zdelta = max(0., sign(1.,rtt-zx_t))
-        zcvm5 = r5les*rlvtt*(1.-zdelta) + r5ies*rlstt*zdelta
-        zcvm5 = zcvm5/rcpd/(1.0+rvtmp2*zx_q)
-        zx_qs = r2es*foeew(zx_t, zdelta)/zx_p
-        zx_qs = min(0.5, zx_qs)
-        zcor = 1./(1.-retv*zx_qs)
-        zx_qs = zx_qs*zcor
-        zx_gam = foede(zx_t, zdelta, zcvm5, zx_qs, zcor)
-        shbs(i, km1) = zx_qs
-        gam(i, km1) = zx_gam
-
-        sb(i, k) = sb(i, k) + ds2(i)
-        sb(i, km1) = sb(i, km1) + ds3(i)
-        hb(i, k) = sb(i, k) + rlvtt*shb(i, k)
-        hb(i, km1) = sb(i, km1) + rlvtt*shb(i, km1)
-        hbs(i, k) = sb(i, k) + rlvtt*shbs(i, k)
-        hbs(i, km1) = sb(i, km1) + rlvtt*shbs(i, km1)
-
-        sbh(i, k) = 0.5*(sb(i,k)+sb(i,km1))
-        shbh(i, k) = qhalf(shb(i,km1), shb(i,k), shbs(i,km1), shbs(i,k))
-        hbh(i, k) = sbh(i, k) + rlvtt*shbh(i, k)
-        sbh(i, km1) = 0.5*(sb(i,km1)+sb(i,k-2))
-        shbh(i, km1) = qhalf(shb(i,k-2), shb(i,km1), shbs(i,k-2), &
-          shbs(i,km1))
-        hbh(i, km1) = sbh(i, km1) + rlvtt*shbh(i, km1)
-      END IF
-    END DO
-
-    ! Ensure that dzcld is reset if convective mass flux zero
-    ! specify the current vertical extent of the convective activity
-    ! top of convective layer determined by size of overshoot param.
-
-60  CONTINUE
-    DO i = 1, klon
-      etagt0 = eta(i) > 0.0
-      IF (.NOT. etagt0) dzcld(i) = 0.0
-      IF (etagt0 .AND. beta(i)>betamn) THEN
-        ktp = km1
-      ELSE
-        ktp = k
-      END IF
-      IF (etagt0) THEN
-        cnt(i) = min(cnt(i), ktp)
-        cnb(i) = max(cnb(i), k)
-      END IF
-    END DO
-70 END DO ! end of k loop
-
-  ! determine whether precipitation, prec, is frozen (snow) or not
-
-  DO i = 1, klon
-    IF (tb(i,klev)<tmelt .AND. tb(i,klev-1)<tmelt) THEN
-      cmfprs(i) = prec(i)*rdt
-    ELSE
-      cmfprt(i) = prec(i)*rdt
-    END IF
-  END DO
-
-  RETURN ! we're all done ... return to calling procedure
-END SUBROUTINE cmfmca
Index: /LMDZ6/trunk/libf/phylmd/conccm.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/conccm.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/conccm.f90	(revision 5268)
@@ -0,0 +1,818 @@
+
+! $Header$
+
+SUBROUTINE conccm(dtime, paprs, pplay, t, q, conv_q, d_t, d_q, rain, snow, &
+    kbascm, ktopcm)
+
+  USE dimphy
+  IMPLICIT NONE
+  ! ======================================================================
+  ! Auteur(s): Z.X. Li (LMD/CNRS) date: le 14 mars 1996
+  ! Objet: Schema simple (avec flux de masse) pour la convection
+  ! (schema standard du modele NCAR CCM2)
+  ! ======================================================================
+  include "YOMCST.h"
+  include "YOETHF.h"
+
+  ! Entree:
+  REAL dtime ! pas d'integration
+  REAL paprs(klon, klev+1) ! pression inter-couche (Pa)
+  REAL pplay(klon, klev) ! pression au milieu de couche (Pa)
+  REAL t(klon, klev) ! temperature (K)
+  REAL q(klon, klev) ! humidite specifique (g/g)
+  REAL conv_q(klon, klev) ! taux de convergence humidite (g/g/s)
+  ! Sortie:
+  REAL d_t(klon, klev) ! incrementation temperature
+  REAL d_q(klon, klev) ! incrementation vapeur
+  REAL rain(klon) ! pluie (mm/s)
+  REAL snow(klon) ! neige (mm/s)
+  INTEGER kbascm(klon) ! niveau du bas de convection
+  INTEGER ktopcm(klon) ! niveau du haut de convection
+
+  REAL pt(klon, klev)
+  REAL pq(klon, klev)
+  REAL pres(klon, klev)
+  REAL dp(klon, klev)
+  REAL zgeom(klon, klev)
+  REAL cmfprs(klon)
+  REAL cmfprt(klon)
+  INTEGER ntop(klon)
+  INTEGER nbas(klon)
+  INTEGER i, k
+  REAL zlvdcp, zlsdcp, zdelta, zz, za, zb
+
+  LOGICAL usekuo ! utiliser convection profonde (schema Kuo)
+  PARAMETER (usekuo=.TRUE.)
+
+  REAL d_t_bis(klon, klev)
+  REAL d_q_bis(klon, klev)
+  REAL rain_bis(klon)
+  REAL snow_bis(klon)
+  INTEGER ibas_bis(klon)
+  INTEGER itop_bis(klon)
+  REAL d_ql_bis(klon, klev)
+  REAL rneb_bis(klon, klev)
+
+  ! initialiser les variables de sortie (pour securite)
+  DO i = 1, klon
+    rain(i) = 0.0
+    snow(i) = 0.0
+    kbascm(i) = 0
+    ktopcm(i) = 0
+  END DO
+  DO k = 1, klev
+    DO i = 1, klon
+      d_t(i, k) = 0.0
+      d_q(i, k) = 0.0
+    END DO
+  END DO
+
+  ! preparer les variables d'entree (attention: l'ordre des niveaux
+  ! verticaux augmente du haut vers le bas)
+  DO k = 1, klev
+    DO i = 1, klon
+      pt(i, k) = t(i, klev-k+1)
+      pq(i, k) = q(i, klev-k+1)
+      pres(i, k) = pplay(i, klev-k+1)
+      dp(i, k) = paprs(i, klev+1-k) - paprs(i, klev+1-k+1)
+    END DO
+  END DO
+  DO i = 1, klon
+    zgeom(i, klev) = rd*t(i, 1)/(0.5*(paprs(i,1)+pplay(i, &
+      1)))*(paprs(i,1)-pplay(i,1))
+  END DO
+  DO k = 2, klev
+    DO i = 1, klon
+      zgeom(i, klev+1-k) = zgeom(i, klev+1-k+1) + rd*0.5*(t(i,k-1)+t(i,k))/ &
+        paprs(i, k)*(pplay(i,k-1)-pplay(i,k))
+    END DO
+  END DO
+
+  CALL cmfmca(dtime, pres, dp, zgeom, pt, pq, cmfprt, cmfprs, ntop, nbas)
+
+  DO k = 1, klev
+    DO i = 1, klon
+      d_q(i, klev+1-k) = pq(i, k) - q(i, klev+1-k)
+      d_t(i, klev+1-k) = pt(i, k) - t(i, klev+1-k)
+    END DO
+  END DO
+
+  DO i = 1, klon
+    rain(i) = cmfprt(i)*rhoh2o
+    snow(i) = cmfprs(i)*rhoh2o
+    kbascm(i) = klev + 1 - nbas(i)
+    ktopcm(i) = klev + 1 - ntop(i)
+  END DO
+
+  IF (usekuo) THEN
+    CALL conkuo(dtime, paprs, pplay, t, q, conv_q, d_t_bis, d_q_bis, &
+      d_ql_bis, rneb_bis, rain_bis, snow_bis, ibas_bis, itop_bis)
+    DO k = 1, klev
+      DO i = 1, klon
+        d_t(i, k) = d_t(i, k) + d_t_bis(i, k)
+        d_q(i, k) = d_q(i, k) + d_q_bis(i, k)
+      END DO
+    END DO
+    DO i = 1, klon
+      rain(i) = rain(i) + rain_bis(i)
+      snow(i) = snow(i) + snow_bis(i)
+      kbascm(i) = min(kbascm(i), ibas_bis(i))
+      ktopcm(i) = max(ktopcm(i), itop_bis(i))
+    END DO
+    DO k = 1, klev ! eau liquide convective est
+      DO i = 1, klon ! dispersee dans l'air
+        zlvdcp = rlvtt/rcpd/(1.0+rvtmp2*q(i,k))
+        zlsdcp = rlstt/rcpd/(1.0+rvtmp2*q(i,k))
+        zdelta = max(0., sign(1.,rtt-t(i,k)))
+        zz = d_ql_bis(i, k) ! re-evap. de l'eau liquide
+        zb = max(0.0, zz)
+        za = -max(0.0, zz)*(zlvdcp*(1.-zdelta)+zlsdcp*zdelta)
+        d_t(i, k) = d_t(i, k) + za
+        d_q(i, k) = d_q(i, k) + zb
+      END DO
+    END DO
+  END IF
+
+  RETURN
+END SUBROUTINE conccm
+SUBROUTINE cmfmca(deltat, p, dp, gz, tb, shb, cmfprt, cmfprs, cnt, cnb)
+  USE dimphy
+  IMPLICIT NONE
+  ! -----------------------------------------------------------------------
+  ! Moist convective mass flux procedure:
+  ! If stratification is unstable to nonentraining parcel ascent,
+  ! complete an adjustment making use of a simple cloud model
+
+  ! Code generalized to allow specification of parcel ("updraft")
+  ! properties, as well as convective transport of an arbitrary
+  ! number of passive constituents (see cmrb array).
+  ! ----------------------------Code History-------------------------------
+  ! Original version:  J. J. Hack, March 22, 1990
+  ! Standardized:      J. Rosinski, June 1992
+  ! Reviewed:          J. Hack, G. Taylor, August 1992
+  ! Adaptation au LMD: Z.X. Li, mars 1996 (reference: Hack 1994,
+  ! J. Geophys. Res. vol 99, D3, 5551-5568). J'ai
+  ! introduit les constantes et les fonctions thermo-
+  ! dynamiques du Centre Europeen. J'ai elimine le
+  ! re-indicage du code en esperant que cela pourra
+  ! simplifier la lecture et la comprehension.
+  ! -----------------------------------------------------------------------
+  INTEGER pcnst ! nombre de traceurs passifs
+  PARAMETER (pcnst=1)
+  ! ------------------------------Arguments--------------------------------
+  ! Input arguments
+
+  REAL deltat ! time step (seconds)
+  REAL p(klon, klev) ! pressure
+  REAL dp(klon, klev) ! delta-p
+  REAL gz(klon, klev) ! geopotential (a partir du sol)
+
+  REAL thtap(klon) ! PBL perturbation theta
+  REAL shp(klon) ! PBL perturbation specific humidity
+  REAL pblh(klon) ! PBL height (provided by PBL routine)
+  REAL cmrp(klon, pcnst) ! constituent perturbations in PBL
+
+  ! Updated arguments:
+
+  REAL tb(klon, klev) ! temperature (t bar)
+  REAL shb(klon, klev) ! specific humidity (sh bar)
+  REAL cmrb(klon, klev, pcnst) ! constituent mixing ratios (cmr bar)
+
+  ! Output arguments
+
+  REAL cmfdt(klon, klev) ! dT/dt due to moist convection
+  REAL cmfdq(klon, klev) ! dq/dt due to moist convection
+  REAL cmfmc(klon, klev) ! moist convection cloud mass flux
+  REAL cmfdqr(klon, klev) ! dq/dt due to convective rainout
+  REAL cmfsl(klon, klev) ! convective lw static energy flux
+  REAL cmflq(klon, klev) ! convective total water flux
+  REAL cmfprt(klon) ! convective precipitation rate
+  REAL cmfprs(klon) ! convective snowfall rate
+  REAL qc(klon, klev) ! dq/dt due to rainout terms
+  INTEGER cnt(klon) ! top level of convective activity
+  INTEGER cnb(klon) ! bottom level of convective activity
+  ! ------------------------------Parameters-------------------------------
+  REAL c0 ! rain water autoconversion coefficient
+  PARAMETER (c0=1.0E-4)
+  REAL dzmin ! minimum convective depth for precipitation
+  PARAMETER (dzmin=0.0)
+  REAL betamn ! minimum overshoot parameter
+  PARAMETER (betamn=0.10)
+  REAL cmftau ! characteristic adjustment time scale
+  PARAMETER (cmftau=3600.)
+  INTEGER limcnv ! top interface level limit for convection
+  PARAMETER (limcnv=1)
+  REAL tpmax ! maximum acceptable t perturbation (degrees C)
+  PARAMETER (tpmax=1.50)
+  REAL shpmax ! maximum acceptable q perturbation (g/g)
+  PARAMETER (shpmax=1.50E-3)
+  REAL tiny ! arbitrary small num used in transport estimates
+  PARAMETER (tiny=1.0E-36)
+  REAL eps ! convergence criteria (machine dependent)
+  PARAMETER (eps=1.0E-13)
+  REAL tmelt ! freezing point of water(req'd for rain vs snow)
+  PARAMETER (tmelt=273.15)
+  REAL ssfac ! supersaturation bound (detrained air)
+  PARAMETER (ssfac=1.001)
+
+  ! ---------------------------Local workspace-----------------------------
+  REAL gam(klon, klev) ! L/cp (d(qsat)/dT)
+  REAL sb(klon, klev) ! dry static energy (s bar)
+  REAL hb(klon, klev) ! moist static energy (h bar)
+  REAL shbs(klon, klev) ! sat. specific humidity (sh bar star)
+  REAL hbs(klon, klev) ! sat. moist static energy (h bar star)
+  REAL shbh(klon, klev+1) ! specific humidity on interfaces
+  REAL sbh(klon, klev+1) ! s bar on interfaces
+  REAL hbh(klon, klev+1) ! h bar on interfaces
+  REAL cmrh(klon, klev+1) ! interface constituent mixing ratio
+  REAL prec(klon) ! instantaneous total precipitation
+  REAL dzcld(klon) ! depth of convective layer (m)
+  REAL beta(klon) ! overshoot parameter (fraction)
+  REAL betamx ! local maximum on overshoot
+  REAL eta(klon) ! convective mass flux (kg/m^2 s)
+  REAL etagdt ! eta*grav*deltat
+  REAL cldwtr(klon) ! cloud water (mass)
+  REAL rnwtr(klon) ! rain water  (mass)
+  REAL sc(klon) ! dry static energy   ("in-cloud")
+  REAL shc(klon) ! specific humidity   ("in-cloud")
+  REAL hc(klon) ! moist static energy ("in-cloud")
+  REAL cmrc(klon) ! constituent mix rat ("in-cloud")
+  REAL dq1(klon) ! shb  convective change (lower lvl)
+  REAL dq2(klon) ! shb  convective change (mid level)
+  REAL dq3(klon) ! shb  convective change (upper lvl)
+  REAL ds1(klon) ! sb   convective change (lower lvl)
+  REAL ds2(klon) ! sb   convective change (mid level)
+  REAL ds3(klon) ! sb   convective change (upper lvl)
+  REAL dcmr1(klon) ! cmrb convective change (lower lvl)
+  REAL dcmr2(klon) ! cmrb convective change (mid level)
+  REAL dcmr3(klon) ! cmrb convective change (upper lvl)
+  REAL flotab(klon) ! hc - hbs (mesure d'instabilite)
+  LOGICAL ldcum(klon) ! .true. si la convection existe
+  LOGICAL etagt0 ! true if eta > 0.0
+  REAL dt ! current 2 delta-t (model time step)
+  REAL cats ! modified characteristic adj. time
+  REAL rdt ! 1./dt
+  REAL qprime ! modified specific humidity pert.
+  REAL tprime ! modified thermal perturbation
+  REAL pblhgt ! bounded pbl height (max[pblh,1m])
+  REAL fac1 ! intermediate scratch variable
+  REAL shprme ! intermediate specific humidity pert.
+  REAL qsattp ! saturation mixing ratio for
+  ! !  thermally perturbed PBL parcels
+  REAL dz ! local layer depth
+  REAL b1 ! bouyancy measure in detrainment lvl
+  REAL b2 ! bouyancy measure in condensation lvl
+  REAL g ! bounded vertical gradient of hb
+  REAL tmass ! total mass available for convective exchange
+  REAL denom ! intermediate scratch variable
+  REAL qtest1 ! used in negative q test (middle lvl)
+  REAL qtest2 ! used in negative q test (lower lvl)
+  REAL fslkp ! flux lw static energy (bot interface)
+  REAL fslkm ! flux lw static energy (top interface)
+  REAL fqlkp ! flux total water (bottom interface)
+  REAL fqlkm ! flux total water (top interface)
+  REAL botflx ! bottom constituent mixing ratio flux
+  REAL topflx ! top constituent mixing ratio flux
+  REAL efac1 ! ratio cmrb to convectively induced change (bot lvl)
+  REAL efac2 ! ratio cmrb to convectively induced change (mid lvl)
+  REAL efac3 ! ratio cmrb to convectively induced change (top lvl)
+
+  INTEGER i, k ! indices horizontal et vertical
+  INTEGER km1 ! k-1 (index offset)
+  INTEGER kp1 ! k+1 (index offset)
+  INTEGER m ! constituent index
+  INTEGER ktp ! temporary index used to track top
+  INTEGER is ! nombre de points a ajuster
+
+  REAL tmp1, tmp2, tmp3, tmp4
+  REAL zx_t, zx_p, zx_q, zx_qs, zx_gam
+  REAL zcor, zdelta, zcvm5
+
+  REAL qhalf, sh1, sh2, shbs1, shbs2
+  include "YOMCST.h"
+  include "YOETHF.h"
+  include "FCTTRE.h"
+  qhalf(sh1, sh2, shbs1, shbs2) = min(max(sh1,sh2), &
+    (shbs2*sh1+shbs1*sh2)/(shbs1+shbs2))
+
+  ! -----------------------------------------------------------------------
+  ! pas de traceur pour l'instant
+  DO m = 1, pcnst
+    DO k = 1, klev
+      DO i = 1, klon
+        cmrb(i, k, m) = 0.0
+      END DO
+    END DO
+  END DO
+
+  ! Les perturbations de la couche limite sont zero pour l'instant
+
+  DO m = 1, pcnst
+    DO i = 1, klon
+      cmrp(i, m) = 0.0
+    END DO
+  END DO
+  DO i = 1, klon
+    thtap(i) = 0.0
+    shp(i) = 0.0
+    pblh(i) = 1.0
+  END DO
+
+  ! Ensure that characteristic adjustment time scale (cmftau) assumed
+  ! in estimate of eta isn't smaller than model time scale (deltat)
+
+  dt = deltat
+  cats = max(dt, cmftau)
+  rdt = 1.0/dt
+
+  ! Compute sb,hb,shbs,hbs
+
+  DO k = 1, klev
+    DO i = 1, klon
+      zx_t = tb(i, k)
+      zx_p = p(i, k)
+      zx_q = shb(i, k)
+      zdelta = max(0., sign(1.,rtt-zx_t))
+      zcvm5 = r5les*rlvtt*(1.-zdelta) + r5ies*rlstt*zdelta
+      zcvm5 = zcvm5/rcpd/(1.0+rvtmp2*zx_q)
+      zx_qs = r2es*foeew(zx_t, zdelta)/zx_p
+      zx_qs = min(0.5, zx_qs)
+      zcor = 1./(1.-retv*zx_qs)
+      zx_qs = zx_qs*zcor
+      zx_gam = foede(zx_t, zdelta, zcvm5, zx_qs, zcor)
+      shbs(i, k) = zx_qs
+      gam(i, k) = zx_gam
+    END DO
+  END DO
+
+  DO k = limcnv, klev
+    DO i = 1, klon
+      sb(i, k) = rcpd*tb(i, k) + gz(i, k)
+      hb(i, k) = sb(i, k) + rlvtt*shb(i, k)
+      hbs(i, k) = sb(i, k) + rlvtt*shbs(i, k)
+    END DO
+  END DO
+
+  ! Compute sbh, shbh
+
+  DO k = limcnv + 1, klev
+    km1 = k - 1
+    DO i = 1, klon
+      sbh(i, k) = 0.5*(sb(i,km1)+sb(i,k))
+      shbh(i, k) = qhalf(shb(i,km1), shb(i,k), shbs(i,km1), shbs(i,k))
+      hbh(i, k) = sbh(i, k) + rlvtt*shbh(i, k)
+    END DO
+  END DO
+
+  ! Specify properties at top of model (not used, but filling anyway)
+
+  DO i = 1, klon
+    sbh(i, limcnv) = sb(i, limcnv)
+    shbh(i, limcnv) = shb(i, limcnv)
+    hbh(i, limcnv) = hb(i, limcnv)
+  END DO
+
+  ! Zero vertically independent control, tendency & diagnostic arrays
+
+  DO i = 1, klon
+    prec(i) = 0.0
+    dzcld(i) = 0.0
+    cnb(i) = 0
+    cnt(i) = klev + 1
+  END DO
+
+  DO k = 1, klev
+    DO i = 1, klon
+      cmfdt(i, k) = 0.
+      cmfdq(i, k) = 0.
+      cmfdqr(i, k) = 0.
+      cmfmc(i, k) = 0.
+      cmfsl(i, k) = 0.
+      cmflq(i, k) = 0.
+    END DO
+  END DO
+
+  ! Begin moist convective mass flux adjustment procedure.
+  ! Formalism ensures that negative cloud liquid water can never occur
+
+  DO k = klev - 1, limcnv + 1, -1
+    km1 = k - 1
+    kp1 = k + 1
+    DO i = 1, klon
+      eta(i) = 0.0
+      beta(i) = 0.0
+      ds1(i) = 0.0
+      ds2(i) = 0.0
+      ds3(i) = 0.0
+      dq1(i) = 0.0
+      dq2(i) = 0.0
+      dq3(i) = 0.0
+
+      ! Specification of "cloud base" conditions
+
+      qprime = 0.0
+      tprime = 0.0
+
+      ! Assign tprime within the PBL to be proportional to the quantity
+      ! thtap (which will be bounded by tpmax), passed to this routine by
+      ! the PBL routine.  Don't allow perturbation to produce a dry
+      ! adiabatically unstable parcel.  Assign qprime within the PBL to be
+      ! an appropriately modified value of the quantity shp (which will be
+      ! bounded by shpmax) passed to this routine by the PBL routine.  The
+      ! quantity qprime should be less than the local saturation value
+      ! (qsattp=qsat[t+tprime,p]).  In both cases, thtap and shp are
+      ! linearly reduced toward zero as the PBL top is approached.
+
+      pblhgt = max(pblh(i), 1.0)
+      IF (gz(i,kp1)/rg<=pblhgt .AND. dzcld(i)==0.0) THEN
+        fac1 = max(0.0, 1.0-gz(i,kp1)/rg/pblhgt)
+        tprime = min(thtap(i), tpmax)*fac1
+        qsattp = shbs(i, kp1) + rcpd/rlvtt*gam(i, kp1)*tprime
+        shprme = min(min(shp(i),shpmax)*fac1, max(qsattp-shb(i,kp1),0.0))
+        qprime = max(qprime, shprme)
+      ELSE
+        tprime = 0.0
+        qprime = 0.0
+      END IF
+
+      ! Specify "updraft" (in-cloud) thermodynamic properties
+
+      sc(i) = sb(i, kp1) + rcpd*tprime
+      shc(i) = shb(i, kp1) + qprime
+      hc(i) = sc(i) + rlvtt*shc(i)
+      flotab(i) = hc(i) - hbs(i, k)
+      dz = dp(i, k)*rd*tb(i, k)/rg/p(i, k)
+      IF (flotab(i)>0.0) THEN
+        dzcld(i) = dzcld(i) + dz
+      ELSE
+        dzcld(i) = 0.0
+      END IF
+    END DO
+
+    ! Check on moist convective instability
+
+    is = 0
+    DO i = 1, klon
+      IF (flotab(i)>0.0) THEN
+        ldcum(i) = .TRUE.
+        is = is + 1
+      ELSE
+        ldcum(i) = .FALSE.
+      END IF
+    END DO
+
+    IF (is==0) THEN
+      DO i = 1, klon
+        dzcld(i) = 0.0
+      END DO
+      GO TO 70
+    END IF
+
+    ! Current level just below top level => no overshoot
+
+    IF (k<=limcnv+1) THEN
+      DO i = 1, klon
+        IF (ldcum(i)) THEN
+          cldwtr(i) = sb(i, k) - sc(i) + flotab(i)/(1.0+gam(i,k))
+          cldwtr(i) = max(0.0, cldwtr(i))
+          beta(i) = 0.0
+        END IF
+      END DO
+      GO TO 20
+    END IF
+
+    ! First guess at overshoot parameter using crude buoyancy closure
+    ! 10% overshoot assumed as a minimum and 1-c0*dz maximum to start
+    ! If pre-existing supersaturation in detrainment layer, beta=0
+    ! cldwtr is temporarily equal to RLVTT*l (l=> liquid water)
+
+    DO i = 1, klon
+      IF (ldcum(i)) THEN
+        cldwtr(i) = sb(i, k) - sc(i) + flotab(i)/(1.0+gam(i,k))
+        cldwtr(i) = max(0.0, cldwtr(i))
+        betamx = 1.0 - c0*max(0.0, (dzcld(i)-dzmin))
+        b1 = (hc(i)-hbs(i,km1))*dp(i, km1)
+        b2 = (hc(i)-hbs(i,k))*dp(i, k)
+        beta(i) = max(betamn, min(betamx,1.0+b1/b2))
+        IF (hbs(i,km1)<=hb(i,km1)) beta(i) = 0.0
+      END IF
+    END DO
+
+    ! Bound maximum beta to ensure physically realistic solutions
+
+    ! First check constrains beta so that eta remains positive
+    ! (assuming that eta is already positive for beta equal zero)
+    ! La premiere contrainte de beta est que le flux eta doit etre positif.
+
+    DO i = 1, klon
+      IF (ldcum(i)) THEN
+        tmp1 = (1.0+gam(i,k))*(sc(i)-sbh(i,kp1)+cldwtr(i)) - &
+          (hbh(i,kp1)-hc(i))*dp(i, k)/dp(i, kp1)
+        tmp2 = (1.0+gam(i,k))*(sc(i)-sbh(i,k))
+        IF ((beta(i)*tmp2-tmp1)>0.0) THEN
+          betamx = 0.99*(tmp1/tmp2)
+          beta(i) = max(0.0, min(betamx,beta(i)))
+        END IF
+
+        ! Second check involves supersaturation of "detrainment layer"
+        ! small amount of supersaturation acceptable (by ssfac factor)
+        ! La 2e contrainte est que la convection ne doit pas sursaturer
+        ! la "detrainment layer", Neanmoins, une petite sursaturation
+        ! est acceptee (facteur ssfac).
+
+        IF (hb(i,km1)<hbs(i,km1)) THEN
+          tmp1 = (1.0+gam(i,k))*(sc(i)-sbh(i,kp1)+cldwtr(i)) - &
+            (hbh(i,kp1)-hc(i))*dp(i, k)/dp(i, kp1)
+          tmp1 = tmp1/dp(i, k)
+          tmp2 = gam(i, km1)*(sbh(i,k)-sc(i)+cldwtr(i)) - hbh(i, k) + hc(i) - &
+            sc(i) + sbh(i, k)
+          tmp3 = (1.0+gam(i,k))*(sc(i)-sbh(i,k))/dp(i, k)
+          tmp4 = (dt/cats)*(hc(i)-hbs(i,k))*tmp2/(dp(i,km1)*(hbs(i,km1)-hb(i, &
+            km1))) + tmp3
+          IF ((beta(i)*tmp4-tmp1)>0.0) THEN
+            betamx = ssfac*(tmp1/tmp4)
+            beta(i) = max(0.0, min(betamx,beta(i)))
+          END IF
+        ELSE
+          beta(i) = 0.0
+        END IF
+
+        ! Third check to avoid introducing 2 delta x thermodynamic
+        ! noise in the vertical ... constrain adjusted h (or theta e)
+        ! so that the adjustment doesn't contribute to "kinks" in h
+
+        g = min(0.0, hb(i,k)-hb(i,km1))
+        tmp3 = (hb(i,k)-hb(i,km1)-g)*(cats/dt)/(hc(i)-hbs(i,k))
+        tmp1 = (1.0+gam(i,k))*(sc(i)-sbh(i,kp1)+cldwtr(i)) - &
+          (hbh(i,kp1)-hc(i))*dp(i, k)/dp(i, kp1)
+        tmp1 = tmp1/dp(i, k)
+        tmp1 = tmp3*tmp1 + (hc(i)-hbh(i,kp1))/dp(i, k)
+        tmp2 = tmp3*(1.0+gam(i,k))*(sc(i)-sbh(i,k))/dp(i, k) + &
+          (hc(i)-hbh(i,k)-cldwtr(i))*(1.0/dp(i,k)+1.0/dp(i,kp1))
+        IF ((beta(i)*tmp2-tmp1)>0.0) THEN
+          betamx = 0.0
+          IF (tmp2/=0.0) betamx = tmp1/tmp2
+          beta(i) = max(0.0, min(betamx,beta(i)))
+        END IF
+      END IF
+    END DO
+
+    ! Calculate mass flux required for stabilization.
+
+    ! Ensure that the convective mass flux, eta, is positive by
+    ! setting negative values of eta to zero..
+    ! Ensure that estimated mass flux cannot move more than the
+    ! minimum of total mass contained in either layer k or layer k+1.
+    ! Also test for other pathological cases that result in non-
+    ! physical states and adjust eta accordingly.
+
+20  CONTINUE
+    DO i = 1, klon
+      IF (ldcum(i)) THEN
+        beta(i) = max(0.0, beta(i))
+        tmp1 = hc(i) - hbs(i, k)
+        tmp2 = ((1.0+gam(i,k))*(sc(i)-sbh(i,kp1)+cldwtr(i))-beta(i)*(1.0+gam( &
+          i,k))*(sc(i)-sbh(i,k)))/dp(i, k) - (hbh(i,kp1)-hc(i))/dp(i, kp1)
+        eta(i) = tmp1/(tmp2*rg*cats)
+        tmass = min(dp(i,k), dp(i,kp1))/rg
+        IF (eta(i)>tmass*rdt .OR. eta(i)<=0.0) eta(i) = 0.0
+
+        ! Check on negative q in top layer (bound beta)
+
+        IF (shc(i)-shbh(i,k)<0.0 .AND. beta(i)*eta(i)/=0.0) THEN
+          denom = eta(i)*rg*dt*(shc(i)-shbh(i,k))/dp(i, km1)
+          beta(i) = max(0.0, min(-0.999*shb(i,km1)/denom,beta(i)))
+        END IF
+
+        ! Check on negative q in middle layer (zero eta)
+
+        qtest1 = shb(i, k) + eta(i)*rg*dt*((shc(i)-shbh(i, &
+          kp1))-(1.0-beta(i))*cldwtr(i)/rlvtt-beta(i)*(shc(i)-shbh(i, &
+          k)))/dp(i, k)
+        IF (qtest1<=0.0) eta(i) = 0.0
+
+        ! Check on negative q in lower layer (bound eta)
+
+        fac1 = -(shbh(i,kp1)-shc(i))/dp(i, kp1)
+        qtest2 = shb(i, kp1) - eta(i)*rg*dt*fac1
+        IF (qtest2<0.0) THEN
+          eta(i) = 0.99*shb(i, kp1)/(rg*dt*fac1)
+        END IF
+      END IF
+    END DO
+
+
+    ! Calculate cloud water, rain water, and thermodynamic changes
+
+    DO i = 1, klon
+      IF (ldcum(i)) THEN
+        etagdt = eta(i)*rg*dt
+        cldwtr(i) = etagdt*cldwtr(i)/rlvtt/rg
+        rnwtr(i) = (1.0-beta(i))*cldwtr(i)
+        ds1(i) = etagdt*(sbh(i,kp1)-sc(i))/dp(i, kp1)
+        dq1(i) = etagdt*(shbh(i,kp1)-shc(i))/dp(i, kp1)
+        ds2(i) = (etagdt*(sc(i)-sbh(i,kp1))+rlvtt*rg*cldwtr(i)-beta(i)*etagdt &
+          *(sc(i)-sbh(i,k)))/dp(i, k)
+        dq2(i) = (etagdt*(shc(i)-shbh(i,kp1))-rg*rnwtr(i)-beta(i)*etagdt*(shc &
+          (i)-shbh(i,k)))/dp(i, k)
+        ds3(i) = beta(i)*(etagdt*(sc(i)-sbh(i,k))-rlvtt*rg*cldwtr(i))/dp(i, &
+          km1)
+        dq3(i) = beta(i)*etagdt*(shc(i)-shbh(i,k))/dp(i, km1)
+
+        ! Isolate convective fluxes for later diagnostics
+
+        fslkp = eta(i)*(sc(i)-sbh(i,kp1))
+        fslkm = beta(i)*(eta(i)*(sc(i)-sbh(i,k))-rlvtt*cldwtr(i)*rdt)
+        fqlkp = eta(i)*(shc(i)-shbh(i,kp1))
+        fqlkm = beta(i)*eta(i)*(shc(i)-shbh(i,k))
+
+
+        ! Update thermodynamic profile (update sb, hb, & hbs later)
+
+        tb(i, kp1) = tb(i, kp1) + ds1(i)/rcpd
+        tb(i, k) = tb(i, k) + ds2(i)/rcpd
+        tb(i, km1) = tb(i, km1) + ds3(i)/rcpd
+        shb(i, kp1) = shb(i, kp1) + dq1(i)
+        shb(i, k) = shb(i, k) + dq2(i)
+        shb(i, km1) = shb(i, km1) + dq3(i)
+        prec(i) = prec(i) + rnwtr(i)/rhoh2o
+
+        ! Update diagnostic information for final budget
+        ! Tracking temperature & specific humidity tendencies,
+        ! rainout term, convective mass flux, convective liquid
+        ! water static energy flux, and convective total water flux
+
+        cmfdt(i, kp1) = cmfdt(i, kp1) + ds1(i)/rcpd*rdt
+        cmfdt(i, k) = cmfdt(i, k) + ds2(i)/rcpd*rdt
+        cmfdt(i, km1) = cmfdt(i, km1) + ds3(i)/rcpd*rdt
+        cmfdq(i, kp1) = cmfdq(i, kp1) + dq1(i)*rdt
+        cmfdq(i, k) = cmfdq(i, k) + dq2(i)*rdt
+        cmfdq(i, km1) = cmfdq(i, km1) + dq3(i)*rdt
+        cmfdqr(i, k) = cmfdqr(i, k) + (rg*rnwtr(i)/dp(i,k))*rdt
+        cmfmc(i, kp1) = cmfmc(i, kp1) + eta(i)
+        cmfmc(i, k) = cmfmc(i, k) + beta(i)*eta(i)
+        cmfsl(i, kp1) = cmfsl(i, kp1) + fslkp
+        cmfsl(i, k) = cmfsl(i, k) + fslkm
+        cmflq(i, kp1) = cmflq(i, kp1) + rlvtt*fqlkp
+        cmflq(i, k) = cmflq(i, k) + rlvtt*fqlkm
+        qc(i, k) = (rg*rnwtr(i)/dp(i,k))*rdt
+      END IF
+    END DO
+
+    ! Next, convectively modify passive constituents
+
+    DO m = 1, pcnst
+      DO i = 1, klon
+        IF (ldcum(i)) THEN
+
+          ! If any of the reported values of the constituent is negative in
+          ! the three adjacent levels, nothing will be done to the profile
+
+          IF ((cmrb(i,kp1,m)<0.0) .OR. (cmrb(i,k,m)<0.0) .OR. (cmrb(i,km1, &
+            m)<0.0)) GO TO 40
+
+          ! Specify constituent interface values (linear interpolation)
+
+          cmrh(i, k) = 0.5*(cmrb(i,km1,m)+cmrb(i,k,m))
+          cmrh(i, kp1) = 0.5*(cmrb(i,k,m)+cmrb(i,kp1,m))
+
+          ! Specify perturbation properties of constituents in PBL
+
+          pblhgt = max(pblh(i), 1.0)
+          IF (gz(i,kp1)/rg<=pblhgt .AND. dzcld(i)==0.) THEN
+            fac1 = max(0.0, 1.0-gz(i,kp1)/rg/pblhgt)
+            cmrc(i) = cmrb(i, kp1, m) + cmrp(i, m)*fac1
+          ELSE
+            cmrc(i) = cmrb(i, kp1, m)
+          END IF
+
+          ! Determine fluxes, flux divergence => changes due to convection
+          ! Logic must be included to avoid producing negative values. A bit
+          ! messy since there are no a priori assumptions about profiles.
+          ! Tendency is modified (reduced) when pending disaster detected.
+
+          etagdt = eta(i)*rg*dt
+          botflx = etagdt*(cmrc(i)-cmrh(i,kp1))
+          topflx = beta(i)*etagdt*(cmrc(i)-cmrh(i,k))
+          dcmr1(i) = -botflx/dp(i, kp1)
+          efac1 = 1.0
+          efac2 = 1.0
+          efac3 = 1.0
+
+          IF (cmrb(i,kp1,m)+dcmr1(i)<0.0) THEN
+            efac1 = max(tiny, abs(cmrb(i,kp1,m)/dcmr1(i))-eps)
+          END IF
+
+          IF (efac1==tiny .OR. efac1>1.0) efac1 = 0.0
+          dcmr1(i) = -efac1*botflx/dp(i, kp1)
+          dcmr2(i) = (efac1*botflx-topflx)/dp(i, k)
+
+          IF (cmrb(i,k,m)+dcmr2(i)<0.0) THEN
+            efac2 = max(tiny, abs(cmrb(i,k,m)/dcmr2(i))-eps)
+          END IF
+
+          IF (efac2==tiny .OR. efac2>1.0) efac2 = 0.0
+          dcmr2(i) = (efac1*botflx-efac2*topflx)/dp(i, k)
+          dcmr3(i) = efac2*topflx/dp(i, km1)
+
+          IF (cmrb(i,km1,m)+dcmr3(i)<0.0) THEN
+            efac3 = max(tiny, abs(cmrb(i,km1,m)/dcmr3(i))-eps)
+          END IF
+
+          IF (efac3==tiny .OR. efac3>1.0) efac3 = 0.0
+          efac3 = min(efac2, efac3)
+          dcmr2(i) = (efac1*botflx-efac3*topflx)/dp(i, k)
+          dcmr3(i) = efac3*topflx/dp(i, km1)
+
+          cmrb(i, kp1, m) = cmrb(i, kp1, m) + dcmr1(i)
+          cmrb(i, k, m) = cmrb(i, k, m) + dcmr2(i)
+          cmrb(i, km1, m) = cmrb(i, km1, m) + dcmr3(i)
+        END IF
+40    END DO
+    END DO ! end of m=1,pcnst loop
+
+    IF (k==limcnv+1) GO TO 60 ! on ne pourra plus glisser
+
+    ! Dans la procedure de glissage ascendant, les variables thermo-
+    ! dynamiques des couches k et km1 servent au calcul des couches
+    ! superieures. Elles ont donc besoin d'une mise-a-jour.
+
+    DO i = 1, klon
+      IF (ldcum(i)) THEN
+        zx_t = tb(i, k)
+        zx_p = p(i, k)
+        zx_q = shb(i, k)
+        zdelta = max(0., sign(1.,rtt-zx_t))
+        zcvm5 = r5les*rlvtt*(1.-zdelta) + r5ies*rlstt*zdelta
+        zcvm5 = zcvm5/rcpd/(1.0+rvtmp2*zx_q)
+        zx_qs = r2es*foeew(zx_t, zdelta)/zx_p
+        zx_qs = min(0.5, zx_qs)
+        zcor = 1./(1.-retv*zx_qs)
+        zx_qs = zx_qs*zcor
+        zx_gam = foede(zx_t, zdelta, zcvm5, zx_qs, zcor)
+        shbs(i, k) = zx_qs
+        gam(i, k) = zx_gam
+
+        zx_t = tb(i, km1)
+        zx_p = p(i, km1)
+        zx_q = shb(i, km1)
+        zdelta = max(0., sign(1.,rtt-zx_t))
+        zcvm5 = r5les*rlvtt*(1.-zdelta) + r5ies*rlstt*zdelta
+        zcvm5 = zcvm5/rcpd/(1.0+rvtmp2*zx_q)
+        zx_qs = r2es*foeew(zx_t, zdelta)/zx_p
+        zx_qs = min(0.5, zx_qs)
+        zcor = 1./(1.-retv*zx_qs)
+        zx_qs = zx_qs*zcor
+        zx_gam = foede(zx_t, zdelta, zcvm5, zx_qs, zcor)
+        shbs(i, km1) = zx_qs
+        gam(i, km1) = zx_gam
+
+        sb(i, k) = sb(i, k) + ds2(i)
+        sb(i, km1) = sb(i, km1) + ds3(i)
+        hb(i, k) = sb(i, k) + rlvtt*shb(i, k)
+        hb(i, km1) = sb(i, km1) + rlvtt*shb(i, km1)
+        hbs(i, k) = sb(i, k) + rlvtt*shbs(i, k)
+        hbs(i, km1) = sb(i, km1) + rlvtt*shbs(i, km1)
+
+        sbh(i, k) = 0.5*(sb(i,k)+sb(i,km1))
+        shbh(i, k) = qhalf(shb(i,km1), shb(i,k), shbs(i,km1), shbs(i,k))
+        hbh(i, k) = sbh(i, k) + rlvtt*shbh(i, k)
+        sbh(i, km1) = 0.5*(sb(i,km1)+sb(i,k-2))
+        shbh(i, km1) = qhalf(shb(i,k-2), shb(i,km1), shbs(i,k-2), &
+          shbs(i,km1))
+        hbh(i, km1) = sbh(i, km1) + rlvtt*shbh(i, km1)
+      END IF
+    END DO
+
+    ! Ensure that dzcld is reset if convective mass flux zero
+    ! specify the current vertical extent of the convective activity
+    ! top of convective layer determined by size of overshoot param.
+
+60  CONTINUE
+    DO i = 1, klon
+      etagt0 = eta(i) > 0.0
+      IF (.NOT. etagt0) dzcld(i) = 0.0
+      IF (etagt0 .AND. beta(i)>betamn) THEN
+        ktp = km1
+      ELSE
+        ktp = k
+      END IF
+      IF (etagt0) THEN
+        cnt(i) = min(cnt(i), ktp)
+        cnb(i) = max(cnb(i), k)
+      END IF
+    END DO
+70 END DO ! end of k loop
+
+  ! determine whether precipitation, prec, is frozen (snow) or not
+
+  DO i = 1, klon
+    IF (tb(i,klev)<tmelt .AND. tb(i,klev-1)<tmelt) THEN
+      cmfprs(i) = prec(i)*rdt
+    ELSE
+      cmfprt(i) = prec(i)*rdt
+    END IF
+  END DO
+
+  RETURN ! we're all done ... return to calling procedure
+END SUBROUTINE cmfmca
Index: DZ6/trunk/libf/phylmd/concvl.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/concvl.F90	(revision 5267)
+++ 	(revision )
@@ -1,591 +1,0 @@
-SUBROUTINE concvl(iflag_clos, &
-                  dtime, paprs, pplay, k_upper_cv, &
-                  t, q, t_wake, q_wake, s_wake, u, v, tra, ntra, &
-                  Ale, Alp, sig1, w01, &
-                  d_t, d_q, d_qcomp, d_u, d_v, d_tra, &
-                  rain, snow, kbas, ktop, sigd, &
-                  cbmf, plcl, plfc, wbeff, convoccur, &
-                  upwd, dnwd, dnwdbis, &
-                  Ma, mip, Vprecip, &
-                  cape, cin, tvp, Tconv, iflag, &
-                  pbase, bbase, dtvpdt1, dtvpdq1, dplcldt, dplcldr, &
-                  qcondc, wd, pmflxr, pmflxs, &
-!RomP >>>
-!!     .             da,phi,mp,dd_t,dd_q,lalim_conv,wght_th)
-                  da, phi, mp, phii, d1a, dam, sij, qta, clw, elij, &! RomP
-                  dd_t, dd_q, lalim_conv, wght_th, &                 ! RomP
-                  evap, ep, epmlmMm, eplaMm, &                       ! RomP
-                  wdtrainA, wdtrainS, wdtrainM, wght, qtc, sigt, detrain, &
-                  tau_cld_cv, coefw_cld_cv, &                           ! RomP+RL, AJ
-!RomP <<<
-                  epmax_diag) ! epmax_cape
-! **************************************************************
-! *
-! CONCVL                                                      *
-! *
-! *
-! written by   : Sandrine Bony-Lena, 17/05/2003, 11.16.04    *
-! modified by :                                               *
-! **************************************************************
-
-
-  USE dimphy
-  USE infotrac_phy, ONLY: nbtr
-  USE phys_local_var_mod, ONLY: omega
-  USE print_control_mod, ONLY: prt_level, lunout
-  IMPLICIT NONE
-! ======================================================================
-! Auteur(s): S. Bony-Lena (LMD/CNRS) date: ???
-! Objet: schema de convection de Emanuel (1991) interface
-! ======================================================================
-! Arguments:
-! dtime--input-R-pas d'integration (s)
-! s-------input-R-la vAleur "s" pour chaque couche
-! sigs----input-R-la vAleur "sigma" de chaque couche
-! sig-----input-R-la vAleur de "sigma" pour chaque niveau
-! psolpa--input-R-la pression au sol (en Pa)
-! pskapa--input-R-exponentiel kappa de psolpa
-! h-------input-R-enthAlpie potentielle (Cp*T/P**kappa)
-! q-------input-R-vapeur d'eau (en kg/kg)
-
-! work*: input et output: deux variables de travail,
-! on peut les mettre a 0 au debut
-! ALE--------input-R-energie disponible pour soulevement
-! ALP--------input-R-puissance disponible pour soulevement
-
-! d_h--------output-R-increment de l'enthAlpie potentielle (h)
-! d_q--------output-R-increment de la vapeur d'eau
-! rain-------output-R-la pluie (mm/s)
-! snow-------output-R-la neige (mm/s)
-! upwd-------output-R-saturated updraft mass flux (kg/m**2/s)
-! dnwd-------output-R-saturated downdraft mass flux (kg/m**2/s)
-! dnwd0------output-R-unsaturated downdraft mass flux (kg/m**2/s)
-! Ma---------output-R-adiabatic ascent mass flux (kg/m2/s)
-! mip--------output-R-mass flux shed by adiabatic ascent (kg/m2/s)
-! Vprecip----output-R-vertical profile of total precipitation (kg/m2/s)
-! Tconv------output-R-environment temperature seen by convective scheme (K)
-! Cape-------output-R-CAPE (J/kg)
-! Cin -------output-R-CIN  (J/kg)
-! Tvp--------output-R-Temperature virtuelle d'une parcelle soulevee
-! adiabatiquement a partir du niveau 1 (K)
-! deltapb----output-R-distance entre LCL et base de la colonne (<0 ; Pa)
-! Ice_flag---input-L-TRUE->prise en compte de la thermodynamique de la glace
-! dd_t-------output-R-increment de la temperature du aux descentes precipitantes
-! dd_q-------output-R-increment de la vapeur d'eau du aux desc precip
-! lalim_conv-
-! wght_th----
-! evap-------output-R
-! ep---------output-R
-! epmlmMm----output-R
-! eplaMm-----output-R
-! wdtrainA---output-R
-! wdtrainS---output-R
-! wdtrainM---output-R
-! wght-------output-R
-! ======================================================================
-
-
-  include "clesphys.h"
-
-  INTEGER, INTENT(IN)                           :: iflag_clos
-  REAL, INTENT(IN)                              :: dtime
-  REAL, DIMENSION(klon,klev),   INTENT(IN)      :: pplay
-  REAL, DIMENSION(klon,klev+1), INTENT(IN)      :: paprs
-  INTEGER,                      INTENT(IN)      :: k_upper_cv
-  REAL, DIMENSION(klon,klev),   INTENT(IN)      :: t, q, u, v
-  REAL, DIMENSION(klon,klev),   INTENT(IN)      :: t_wake, q_wake
-  REAL, DIMENSION(klon),        INTENT(IN)      :: s_wake
-  REAL, DIMENSION(klon,klev, nbtr),INTENT(IN)   :: tra
-  INTEGER,                      INTENT(IN)      :: ntra
-  REAL, DIMENSION(klon),        INTENT(IN)      :: Ale, Alp
-!CR:test: on passe lentr et alim_star des thermiques
-  INTEGER, DIMENSION(klon),     INTENT(IN)      :: lalim_conv
-  REAL, DIMENSION(klon,klev),   INTENT(IN)      :: wght_th
-
-  REAL, DIMENSION(klon,klev),   INTENT(INOUT)   :: sig1, w01
-
-  REAL, DIMENSION(klon,klev),   INTENT(OUT)     :: d_t, d_q, d_qcomp, d_u, d_v
-  REAL, DIMENSION(klon,klev, nbtr),INTENT(OUT)  :: d_tra
-  REAL, DIMENSION(klon),        INTENT(OUT)     :: rain, snow
-
-  INTEGER, DIMENSION(klon),     INTENT(OUT)     :: kbas, ktop
-  REAL, DIMENSION(klon),        INTENT(OUT)     :: sigd
-  REAL, DIMENSION(klon),        INTENT(OUT)     :: cbmf, plcl, plfc, wbeff
-  REAL, DIMENSION(klon),        INTENT(OUT)     :: convoccur
-  REAL, DIMENSION(klon,klev),   INTENT(OUT)     :: upwd, dnwd, dnwdbis
-
-!!       REAL Ma(klon,klev), mip(klon,klev),Vprecip(klon,klev)                    !jyg
-  REAL, DIMENSION(klon,klev),   INTENT(OUT)     :: Ma, mip 
-  REAL, DIMENSION(klon,klev+1), INTENT(OUT)     :: Vprecip                        !jyg
-  REAL, DIMENSION(klon),        INTENT(OUT)     :: cape, cin
-  REAL, DIMENSION(klon,klev),   INTENT(OUT)     :: tvp
-  REAL, DIMENSION(klon,klev),   INTENT(OUT)     :: Tconv
-  INTEGER, DIMENSION(klon),     INTENT(OUT)     :: iflag
-  REAL, DIMENSION(klon),        INTENT(OUT)     :: pbase, bbase
-  REAL, DIMENSION(klon,klev),   INTENT(OUT)     :: dtvpdt1, dtvpdq1
-  REAL, DIMENSION(klon),        INTENT(OUT)     :: dplcldt, dplcldr
-  REAL, DIMENSION(klon,klev),   INTENT(OUT)     :: qcondc
-  REAL, DIMENSION(klon),        INTENT(OUT)     :: wd
-  REAL, DIMENSION(klon,klev+1), INTENT(OUT)     :: pmflxr, pmflxs
-
-  REAL, DIMENSION(klon,klev),   INTENT(OUT)     :: da, mp
-  REAL, DIMENSION(klon,klev,klev),INTENT(OUT)   :: phi
-! RomP >>>
-  REAL, DIMENSION(klon,klev,klev),INTENT(OUT)   :: phii
-  REAL, DIMENSION(klon,klev),   INTENT(OUT)     :: d1a, dam
-  REAL, DIMENSION(klon,klev,klev),INTENT(OUT)   :: sij, elij
-  REAL, DIMENSION(klon,klev),   INTENT(OUT)     :: qta
-  REAL, DIMENSION(klon,klev),   INTENT(OUT)     :: clw
-  REAL, DIMENSION(klon,klev),   INTENT(OUT)     :: dd_t, dd_q
-  REAL, DIMENSION(klon,klev),   INTENT(OUT)     :: evap, ep
-  REAL, DIMENSION(klon,klev),   INTENT(OUT)     :: eplaMm
-  REAL, DIMENSION(klon,klev,klev), INTENT(OUT)  :: epmlmMm
-  REAL, DIMENSION(klon,klev),   INTENT(OUT)     :: wdtrainA, wdtrainS, wdtrainM
-! RomP <<<
-  REAL, DIMENSION(klon,klev),   INTENT(OUT)     :: wght                       !RL
-  REAL, DIMENSION(klon,klev),   INTENT(OUT)     :: qtc
-  REAL, DIMENSION(klon,klev),   INTENT(OUT)     :: sigt, detrain
-  REAL,                         INTENT(OUT)     :: tau_cld_cv, coefw_cld_cv
-  REAL, DIMENSION(klon),        INTENT(OUT)     :: epmax_diag                ! epmax_cape
-
-!
-!  Local
-!  ----
-  REAL, DIMENSION(klon,klev)                    :: em_p
-  REAL, DIMENSION(klon,klev+1)                  :: em_ph
-  REAL                                          :: em_sig1feed ! sigma at lower bound of feeding layer
-  REAL                                          :: em_sig2feed ! sigma at upper bound of feeding layer
-  REAL, DIMENSION(klev)                         :: em_wght ! weight density determining the feeding mixture
-  REAL, DIMENSION(klon,klev+1)                  :: Vprecipi                       !jyg
-!on enleve le save
-! SAVE em_sig1feed,em_sig2feed,em_wght
-
-  REAL, DIMENSION(klon)                         :: rflag
-  REAL, DIMENSION(klon)                         :: plim1, plim2
-  REAL, DIMENSION(klon)                         :: ptop2
-  REAL, DIMENSION(klon,klev)                    :: asupmax
-  REAL, DIMENSION(klon)                         :: supmax0, asupmaxmin
-  REAL                                          :: zx_t, zdelta, zx_qs, zcor
-!
-!   INTEGER iflag_mix
-!   SAVE iflag_mix
-  INTEGER                                       :: noff, minorig
-  INTEGER                                       :: i,j, k, itra
-  REAL, DIMENSION(klon,klev)                    :: qs, qs_wake
-!LF          SAVE cbmf
-!IM/JYG      REAL, SAVE, ALLOCATABLE :: cbmf(:)
-!!!$OMP THREADPRIVATE(cbmf)!
-  REAL, DIMENSION(klon)                         :: cbmflast
-
-
-! Variables supplementaires liees au bilan d'energie
-! Real paire(klon)
-!LF      Real ql(klon,klev)
-! Save paire
-!LF      Save ql
-!LF      Real t1(klon,klev),q1(klon,klev)
-!LF      Save t1,q1
-! Data paire /1./
-  REAL, SAVE, ALLOCATABLE :: ql(:, :), q1(:, :), t1(:, :)
-!$OMP THREADPRIVATE(ql, q1, t1)
-
-! Variables liees au bilan d'energie et d'enthAlpi
-  REAL ztsol(klon)
-  REAL        h_vcol_tot, h_dair_tot, h_qw_tot, h_ql_tot, &
-              h_qs_tot, qw_tot, ql_tot, qs_tot, ec_tot
-  SAVE        h_vcol_tot, h_dair_tot, h_qw_tot, h_ql_tot, &
-              h_qs_tot, qw_tot, ql_tot, qs_tot, ec_tot
-!$OMP THREADPRIVATE(h_vcol_tot, h_dair_tot, h_qw_tot, h_ql_tot)
-!$OMP THREADPRIVATE(h_qs_tot, qw_tot, ql_tot, qs_tot , ec_tot)
-  REAL        d_h_vcol, d_h_dair, d_qt, d_qw, d_ql, d_qs, d_ec
-  REAL        d_h_vcol_phy
-  REAL        fs_bound, fq_bound
-  SAVE        d_h_vcol_phy
-!$OMP THREADPRIVATE(d_h_vcol_phy)
-  REAL        zero_v(klon)
-  CHARACTER *15 ztit
-  INTEGER     ip_ebil ! PRINT level for energy conserv. diag.
-  SAVE        ip_ebil
-  DATA        ip_ebil/2/
-!$OMP THREADPRIVATE(ip_ebil)
-  INTEGER     if_ebil ! level for energy conserv. dignostics
-  SAVE        if_ebil
-  DATA        if_ebil/2/
-!$OMP THREADPRIVATE(if_ebil)
-!+jld ec_conser
-  REAL d_t_ec(klon, klev) ! tendance du a la conersion Ec -> E thermique
-  REAL zrcpd
-!-jld ec_conser
-!LF
-  INTEGER nloc
-  LOGICAL, SAVE            :: first = .TRUE.
-!$OMP THREADPRIVATE(first)
-  INTEGER, SAVE            :: itap, igout
-!$OMP THREADPRIVATE(itap, igout)
-
-
-  include "YOMCST.h"
-  include "YOMCST2.h"
-  include "YOETHF.h"
-  include "FCTTRE.h"
-!jyg<
-  include "conema3.h"
-!>jyg
-
-  IF (first) THEN
-! Allocate some variables LF 04/2008
-
-!IM/JYG allocate(cbmf(klon))
-    ALLOCATE (ql(klon,klev))
-    ALLOCATE (t1(klon,klev))
-    ALLOCATE (q1(klon,klev))
-!
-    convoccur(:) = 0.
-!
-    itap = 0
-    igout = klon/2 + 1/klon
-  END IF
-! Incrementer le compteur de la physique
-  itap = itap + 1
-
-! Copy T into Tconv
-  DO k = 1, klev
-    DO i = 1, klon
-      Tconv(i, k) = t(i, k)
-    END DO
-  END DO
-
-  IF (if_ebil>=1) THEN
-    DO i = 1, klon
-      ztsol(i) = t(i, 1)
-      zero_v(i) = 0.
-      DO k = 1, klev
-        ql(i, k) = 0.
-      END DO
-    END DO
-  END IF
-
-! ym
-  snow(:) = 0
-
-  IF (first) THEN
-    first = .FALSE.
-
-! ===========================================================================
-! READ IN PARAMETERS FOR THE CLOSURE AND THE MIXING DISTRIBUTION
-! ===========================================================================
-
-    IF (iflag_con==3) THEN
-!      CALL cv3_inicp()
-      CALL cv3_inip()
-    END IF
-
-! ===========================================================================
-! READ IN PARAMETERS FOR CONVECTIVE INHIBITION BY TROPOS. DRYNESS
-! ===========================================================================
-
-! c$$$         open (56,file='supcrit.data')
-! c$$$         read (56,*) Supcrit1, Supcrit2
-! c$$$         close (56)
-
-    IF (prt_level>=10) WRITE (lunout, *) 'supcrit1, supcrit2', supcrit1, supcrit2
-
-! ===========================================================================
-! Initialisation pour les bilans d'eau et d'energie
-! ===========================================================================
-    IF (if_ebil>=1) d_h_vcol_phy = 0.
-
-    DO i = 1, klon
-      cbmf(i) = 0.
-!!          plcl(i) = 0.
-      sigd(i) = 0.
-    END DO
-  END IF !(first)
-
-! Initialisation a chaque pas de temps
-  plfc(:) = 0.
-  wbeff(:) = 100.
-  plcl(:) = 0.
-
-  DO k = 1, klev + 1
-    DO i = 1, klon
-      em_ph(i, k) = paprs(i, k)/100.0
-      pmflxr(i, k) = 0.
-      pmflxs(i, k) = 0.
-    END DO
-  END DO
-
-  DO k = 1, klev
-    DO i = 1, klon
-      em_p(i, k) = pplay(i, k)/100.0
-    END DO
-  END DO
-
-
-! Feeding layer
-
-  em_sig1feed = 1.
-!jyg<
-!  em_sig2feed = 0.97
-  em_sig2feed = cvl_sig2feed
-!>jyg
-! em_sig2feed = 0.8
-! Relative Weight densities
-  DO k = 1, klev
-    em_wght(k) = 1.
-  END DO
-!CRtest: couche alim des tehrmiques ponderee par a*
-! DO i = 1, klon
-! do k=1,lalim_conv(i)
-! em_wght(k)=wght_th(i,k)
-! print*,'em_wght=',em_wght(k),wght_th(i,k)
-! end do
-! END DO
-
-  IF (iflag_con==4) THEN
-    DO k = 1, klev
-      DO i = 1, klon
-        zx_t = t(i, k)
-        zdelta = max(0., sign(1.,rtt-zx_t))
-        zx_qs = min(0.5, r2es*foeew(zx_t,zdelta)/em_p(i,k)/100.0)
-        zcor = 1./(1.-retv*zx_qs)
-        qs(i, k) = zx_qs*zcor
-      END DO
-      DO i = 1, klon
-        zx_t = t_wake(i, k)
-        zdelta = max(0., sign(1.,rtt-zx_t))
-        zx_qs = min(0.5, r2es*foeew(zx_t,zdelta)/em_p(i,k)/100.0)
-        zcor = 1./(1.-retv*zx_qs)
-        qs_wake(i, k) = zx_qs*zcor
-      END DO
-    END DO
-  ELSE ! iflag_con=3 (modif de puristes qui fait la diffce pour la convergence numerique)
-    DO k = 1, klev
-      DO i = 1, klon
-        zx_t = t(i, k)
-        zdelta = max(0., sign(1.,rtt-zx_t))
-        zx_qs = r2es*foeew(zx_t, zdelta)/em_p(i, k)/100.0
-        zx_qs = min(0.5, zx_qs)
-        zcor = 1./(1.-retv*zx_qs)
-        zx_qs = zx_qs*zcor
-        qs(i, k) = zx_qs
-      END DO
-      DO i = 1, klon
-        zx_t = t_wake(i, k)
-        zdelta = max(0., sign(1.,rtt-zx_t))
-        zx_qs = r2es*foeew(zx_t, zdelta)/em_p(i, k)/100.0
-        zx_qs = min(0.5, zx_qs)
-        zcor = 1./(1.-retv*zx_qs)
-        zx_qs = zx_qs*zcor
-        qs_wake(i, k) = zx_qs
-      END DO
-    END DO
-  END IF ! iflag_con
-
-! ------------------------------------------------------------------
-
-! Main driver for convection:
-!                   iflag_con=3 -> nvlle version de KE (JYG)
-!                   iflag_con = 30  -> equivAlent to convect3
-!                   iflag_con = 4  -> equivAlent to convect1/2
-
-
-  IF (iflag_con==30) THEN
-
-! print *, '-> cv_driver'      !jyg
-    CALL cv_driver(klon, klev, klevp1, ntra, iflag_con, &
-                   t, q, qs, u, v, tra, &
-                   em_p, em_ph, iflag, &
-                   d_t, d_q, d_u, d_v, d_tra, rain, &
-                   Vprecip, cbmf, sig1, w01, & !jyg
-                   kbas, ktop, &
-                   dtime, Ma, upwd, dnwd, dnwdbis, qcondc, wd, cape, &
-                   da, phi, mp, phii, d1a, dam, sij, clw, elij, &       !RomP
-                   evap, ep, epmlmMm, eplaMm, &                         !RomP
-                   wdtrainA, wdtrainM, &                                !RomP
-                   epmax_diag) ! epmax_cape
-!           print *, 'cv_driver ->'      !jyg
-
-    DO i = 1, klon
-      cbmf(i) = Ma(i, kbas(i))
-    END DO
-
-!RL
-    wght(:, :) = 0.
-    DO i = 1, klon
-      wght(i, 1) = 1.
-    END DO
-!RL
-
-  ELSE
-
-!LF   necessary for gathered fields
-    nloc = klon
-    CALL cva_driver(klon, klev, klev+1, ntra, nloc, k_upper_cv, &
-                    iflag_con, iflag_mix, iflag_ice_thermo, &
-                    iflag_clos, ok_conserv_q, dtime, cvl_comp_threshold, &
-                    t, q, qs, t_wake, q_wake, qs_wake, s_wake, u, v, tra, &
-                    em_p, em_ph, &
-                    Ale, Alp, omega, &
-                    em_sig1feed, em_sig2feed, em_wght, &
-                    iflag, d_t, d_q, d_qcomp, d_u, d_v, d_tra, rain, kbas, ktop, &
-                    cbmf, plcl, plfc, wbeff, sig1, w01, ptop2, sigd, &
-                    Ma, mip, Vprecip, Vprecipi, upwd, dnwd, dnwdbis, qcondc, wd, &
-                    cape, cin, tvp, &
-                    dd_t, dd_q, plim1, plim2, asupmax, supmax0, &
-                    asupmaxmin, lalim_conv, &
-!AC!+!RomP+jyg
-!!                   da,phi,mp,phii,d1a,dam,sij,clw,elij, &               ! RomP
-!!                   evap,ep,epmlmMm,eplaMm,                              ! RomP
-                    da, phi, mp, phii, d1a, dam, sij, wght, &           ! RomP+RL
-                    qta, clw, elij, evap, ep, epmlmMm, eplaMm, &        ! RomP+RL
-                    wdtrainA, wdtrainS, wdtrainM, qtc, sigt, detrain, &
-                    tau_cld_cv, coefw_cld_cv, &                         ! RomP,AJ
-!AC!+!RomP+jyg
-                    epmax_diag) ! epmax_cape
-  END IF
-! ------------------------------------------------------------------
-  IF (prt_level>=10) WRITE (lunout, *) ' cva_driver -> cbmf,plcl,plfc,wbeff, d_t, d_q ', &
-                                         cbmf(1), plcl(1), plfc(1), wbeff(1), d_t(1,1), d_q(1,1)
-
-  DO i = 1, klon
-    rain(i) = rain(i)/86400.
-    rflag(i) = iflag(i)
-  END DO
-
-  DO k = 1, klev
-    DO i = 1, klon
-      d_t(i, k) = dtime*d_t(i, k)
-      d_q(i, k) = dtime*d_q(i, k)
-      d_u(i, k) = dtime*d_u(i, k)
-      d_v(i, k) = dtime*d_v(i, k)
-    END DO
-  END DO
-
-  IF (iflag_con==3) THEN
-    DO i = 1,klon
-      IF (wbeff(i) > 100. .OR. wbeff(i) == 0 .OR. iflag(i) > 3) THEN
-        wbeff(i) = 0.
-        convoccur(i) = 0.  
-      ELSE
-        convoccur(i) = 1.
-      ENDIF
-    ENDDO
-  ENDIF
-
-  IF (iflag_con==30) THEN
-    DO itra = 1, ntra
-      DO k = 1, klev
-        DO i = 1, klon
-!RL!            d_tra(i,k,itra) =dtime*d_tra(i,k,itra)
-          d_tra(i, k, itra) = 0.
-        END DO
-      END DO
-    END DO
-  END IF
-
-!!AC!
-  IF (iflag_con==3) THEN
-    DO itra = 1, ntra
-      DO k = 1, klev
-        DO i = 1, klon
-!RL!            d_tra(i,k,itra) =dtime*d_tra(i,k,itra)
-          d_tra(i, k, itra) = 0.
-        END DO
-      END DO
-    END DO
-  END IF
-!!AC!
-
-  DO k = 1, klev
-    DO i = 1, klon
-      t1(i, k) = t(i, k) + d_t(i, k)
-      q1(i, k) = q(i, k) + d_q(i, k)
-    END DO
-  END DO
-!                                                     !jyg
-  IF (iflag_con == 30 .OR. iflag_ice_thermo ==0) THEN
-! --Separation neige/pluie (pour diagnostics)         !jyg
-    DO k = 1, klev                                    !jyg
-      DO i = 1, klon                                  !jyg
-        IF (t1(i,k)<rtt) THEN                         !jyg
-          pmflxs(i, k) = Vprecip(i, k)                !jyg
-        ELSE                                          !jyg
-          pmflxr(i, k) = Vprecip(i, k)                !jyg
-        END IF                                        !jyg
-      END DO                                          !jyg
-    END DO                                            !jyg
-  ELSE
-    DO k = 1, klev                                    !jyg
-      DO i = 1, klon                                  !jyg
-        pmflxs(i, k) = Vprecipi(i, k)                 !jyg
-        pmflxr(i, k) = Vprecip(i, k)-Vprecipi(i, k)   !jyg
-      END DO                                          !jyg
-    END DO                                            !jyg
-  ENDIF
-
-! c      IF (if_ebil.ge.2) THEN
-! c        ztit='after convect'
-! c        CALL diagetpq(paire,ztit,ip_ebil,2,2,dtime
-! c     e      , t1,q1,ql,qs,u,v,paprs,pplay
-! c     s      , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec)
-! c         call diagphy(paire,ztit,ip_ebil
-! c     e      , zero_v, zero_v, zero_v, zero_v, zero_v
-! c     e      , zero_v, rain, zero_v, ztsol
-! c     e      , d_h_vcol, d_qt, d_ec
-! c     s      , fs_bound, fq_bound )
-! c      END IF
-
-
-! les traceurs ne sont pas mis dans cette version de convect4:
-  IF (iflag_con==4) THEN
-    DO itra = 1, ntra
-      DO k = 1, klev
-        DO i = 1, klon
-          d_tra(i, k, itra) = 0.
-        END DO
-      END DO
-    END DO
-  END IF
-! print*, 'concvl->: dd_t,dd_q ',dd_t(1,1),dd_q(1,1)
-
-  DO k = 1, klev
-    DO i = 1, klon
-      dtvpdt1(i, k) = 0.
-      dtvpdq1(i, k) = 0.
-    END DO
-  END DO
-  DO i = 1, klon
-    dplcldt(i) = 0.
-    dplcldr(i) = 0.
-  END DO
-
-  IF (prt_level>=20) THEN
-    DO k = 1, klev
-! print*,'physiq apres_add_con i k it d_u d_v d_t d_q qdl0',igout, &
-!         k,itap,d_u_con(igout,k) ,d_v_con(igout,k), d_t_con(igout,k), &
-!         d_q_con(igout,k),dql0(igout,k)
-! print*,'phys apres_add_con itap Ma cin ALE ALP wak t q undi t q', &
-!         itap,Ma(igout,k),cin(igout),ALE(igout), ALP(igout), &
-!         t_wake(igout,k),q_wake(igout,k),t_undi(igout,k),q_undi(igout,k)
-! print*,'phy apres_add_con itap CON rain snow EMA wk1 wk2 Vpp mip', &
-!         itap,rain_con(igout),snow_con(igout),ema_work1(igout,k), &
-!         ema_work2(igout,k),Vprecip(igout,k), mip(igout,k)
-! print*,'phy apres_add_con itap upwd dnwd dnwd0 cape tvp Tconv ', &
-!         itap,upwd(igout,k),dnwd(igout,k),dnwd0(igout,k),cape(igout), &
-!         tvp(igout,k),Tconv(igout,k)
-! print*,'phy apres_add_con itap dtvpdt dtvdq dplcl dplcldr qcondc', &
-!         itap,dtvpdt1(igout,k),dtvpdq1(igout,k),dplcldt(igout), &
-!         dplcldr(igout),qcondc(igout,k)
-! print*,'phy apres_add_con itap wd pmflxr Kpmflxr Kp1 Kpmflxs Kp1', &
-!         itap,wd(igout),pmflxr(igout,k),pmflxr(igout,k+1),pmflxs(igout,k), &
-!         pmflxs(igout,k+1)
-! print*,'phy apres_add_con itap da phi mp ftd fqd lalim wgth', &
-!         itap,da(igout,k),phi(igout,k,k),mp(igout,k),ftd(igout,k), &
-!         fqd(igout,k),lalim_conv(igout),wght_th(igout,k)
-    END DO
-  END IF !(prt_level.EQ.20) THEN
-
-  RETURN
-END SUBROUTINE concvl
-
Index: /LMDZ6/trunk/libf/phylmd/concvl.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/concvl.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/concvl.f90	(revision 5268)
@@ -0,0 +1,591 @@
+SUBROUTINE concvl(iflag_clos, &
+                  dtime, paprs, pplay, k_upper_cv, &
+                  t, q, t_wake, q_wake, s_wake, u, v, tra, ntra, &
+                  Ale, Alp, sig1, w01, &
+                  d_t, d_q, d_qcomp, d_u, d_v, d_tra, &
+                  rain, snow, kbas, ktop, sigd, &
+                  cbmf, plcl, plfc, wbeff, convoccur, &
+                  upwd, dnwd, dnwdbis, &
+                  Ma, mip, Vprecip, &
+                  cape, cin, tvp, Tconv, iflag, &
+                  pbase, bbase, dtvpdt1, dtvpdq1, dplcldt, dplcldr, &
+                  qcondc, wd, pmflxr, pmflxs, &
+!RomP >>>
+!!     .             da,phi,mp,dd_t,dd_q,lalim_conv,wght_th)
+                  da, phi, mp, phii, d1a, dam, sij, qta, clw, elij, &! RomP
+                  dd_t, dd_q, lalim_conv, wght_th, &                 ! RomP
+                  evap, ep, epmlmMm, eplaMm, &                       ! RomP
+                  wdtrainA, wdtrainS, wdtrainM, wght, qtc, sigt, detrain, &
+                  tau_cld_cv, coefw_cld_cv, &                           ! RomP+RL, AJ
+!RomP <<<
+                  epmax_diag) ! epmax_cape
+! **************************************************************
+! *
+! CONCVL                                                      *
+! *
+! *
+! written by   : Sandrine Bony-Lena, 17/05/2003, 11.16.04    *
+! modified by :                                               *
+! **************************************************************
+
+
+  USE dimphy
+  USE infotrac_phy, ONLY: nbtr
+  USE phys_local_var_mod, ONLY: omega
+  USE print_control_mod, ONLY: prt_level, lunout
+  IMPLICIT NONE
+! ======================================================================
+! Auteur(s): S. Bony-Lena (LMD/CNRS) date: ???
+! Objet: schema de convection de Emanuel (1991) interface
+! ======================================================================
+! Arguments:
+! dtime--input-R-pas d'integration (s)
+! s-------input-R-la vAleur "s" pour chaque couche
+! sigs----input-R-la vAleur "sigma" de chaque couche
+! sig-----input-R-la vAleur de "sigma" pour chaque niveau
+! psolpa--input-R-la pression au sol (en Pa)
+! pskapa--input-R-exponentiel kappa de psolpa
+! h-------input-R-enthAlpie potentielle (Cp*T/P**kappa)
+! q-------input-R-vapeur d'eau (en kg/kg)
+
+! work*: input et output: deux variables de travail,
+! on peut les mettre a 0 au debut
+! ALE--------input-R-energie disponible pour soulevement
+! ALP--------input-R-puissance disponible pour soulevement
+
+! d_h--------output-R-increment de l'enthAlpie potentielle (h)
+! d_q--------output-R-increment de la vapeur d'eau
+! rain-------output-R-la pluie (mm/s)
+! snow-------output-R-la neige (mm/s)
+! upwd-------output-R-saturated updraft mass flux (kg/m**2/s)
+! dnwd-------output-R-saturated downdraft mass flux (kg/m**2/s)
+! dnwd0------output-R-unsaturated downdraft mass flux (kg/m**2/s)
+! Ma---------output-R-adiabatic ascent mass flux (kg/m2/s)
+! mip--------output-R-mass flux shed by adiabatic ascent (kg/m2/s)
+! Vprecip----output-R-vertical profile of total precipitation (kg/m2/s)
+! Tconv------output-R-environment temperature seen by convective scheme (K)
+! Cape-------output-R-CAPE (J/kg)
+! Cin -------output-R-CIN  (J/kg)
+! Tvp--------output-R-Temperature virtuelle d'une parcelle soulevee
+! adiabatiquement a partir du niveau 1 (K)
+! deltapb----output-R-distance entre LCL et base de la colonne (<0 ; Pa)
+! Ice_flag---input-L-TRUE->prise en compte de la thermodynamique de la glace
+! dd_t-------output-R-increment de la temperature du aux descentes precipitantes
+! dd_q-------output-R-increment de la vapeur d'eau du aux desc precip
+! lalim_conv-
+! wght_th----
+! evap-------output-R
+! ep---------output-R
+! epmlmMm----output-R
+! eplaMm-----output-R
+! wdtrainA---output-R
+! wdtrainS---output-R
+! wdtrainM---output-R
+! wght-------output-R
+! ======================================================================
+
+
+  include "clesphys.h"
+
+  INTEGER, INTENT(IN)                           :: iflag_clos
+  REAL, INTENT(IN)                              :: dtime
+  REAL, DIMENSION(klon,klev),   INTENT(IN)      :: pplay
+  REAL, DIMENSION(klon,klev+1), INTENT(IN)      :: paprs
+  INTEGER,                      INTENT(IN)      :: k_upper_cv
+  REAL, DIMENSION(klon,klev),   INTENT(IN)      :: t, q, u, v
+  REAL, DIMENSION(klon,klev),   INTENT(IN)      :: t_wake, q_wake
+  REAL, DIMENSION(klon),        INTENT(IN)      :: s_wake
+  REAL, DIMENSION(klon,klev, nbtr),INTENT(IN)   :: tra
+  INTEGER,                      INTENT(IN)      :: ntra
+  REAL, DIMENSION(klon),        INTENT(IN)      :: Ale, Alp
+!CR:test: on passe lentr et alim_star des thermiques
+  INTEGER, DIMENSION(klon),     INTENT(IN)      :: lalim_conv
+  REAL, DIMENSION(klon,klev),   INTENT(IN)      :: wght_th
+
+  REAL, DIMENSION(klon,klev),   INTENT(INOUT)   :: sig1, w01
+
+  REAL, DIMENSION(klon,klev),   INTENT(OUT)     :: d_t, d_q, d_qcomp, d_u, d_v
+  REAL, DIMENSION(klon,klev, nbtr),INTENT(OUT)  :: d_tra
+  REAL, DIMENSION(klon),        INTENT(OUT)     :: rain, snow
+
+  INTEGER, DIMENSION(klon),     INTENT(OUT)     :: kbas, ktop
+  REAL, DIMENSION(klon),        INTENT(OUT)     :: sigd
+  REAL, DIMENSION(klon),        INTENT(OUT)     :: cbmf, plcl, plfc, wbeff
+  REAL, DIMENSION(klon),        INTENT(OUT)     :: convoccur
+  REAL, DIMENSION(klon,klev),   INTENT(OUT)     :: upwd, dnwd, dnwdbis
+
+!!       REAL Ma(klon,klev), mip(klon,klev),Vprecip(klon,klev)                    !jyg
+  REAL, DIMENSION(klon,klev),   INTENT(OUT)     :: Ma, mip 
+  REAL, DIMENSION(klon,klev+1), INTENT(OUT)     :: Vprecip                        !jyg
+  REAL, DIMENSION(klon),        INTENT(OUT)     :: cape, cin
+  REAL, DIMENSION(klon,klev),   INTENT(OUT)     :: tvp
+  REAL, DIMENSION(klon,klev),   INTENT(OUT)     :: Tconv
+  INTEGER, DIMENSION(klon),     INTENT(OUT)     :: iflag
+  REAL, DIMENSION(klon),        INTENT(OUT)     :: pbase, bbase
+  REAL, DIMENSION(klon,klev),   INTENT(OUT)     :: dtvpdt1, dtvpdq1
+  REAL, DIMENSION(klon),        INTENT(OUT)     :: dplcldt, dplcldr
+  REAL, DIMENSION(klon,klev),   INTENT(OUT)     :: qcondc
+  REAL, DIMENSION(klon),        INTENT(OUT)     :: wd
+  REAL, DIMENSION(klon,klev+1), INTENT(OUT)     :: pmflxr, pmflxs
+
+  REAL, DIMENSION(klon,klev),   INTENT(OUT)     :: da, mp
+  REAL, DIMENSION(klon,klev,klev),INTENT(OUT)   :: phi
+! RomP >>>
+  REAL, DIMENSION(klon,klev,klev),INTENT(OUT)   :: phii
+  REAL, DIMENSION(klon,klev),   INTENT(OUT)     :: d1a, dam
+  REAL, DIMENSION(klon,klev,klev),INTENT(OUT)   :: sij, elij
+  REAL, DIMENSION(klon,klev),   INTENT(OUT)     :: qta
+  REAL, DIMENSION(klon,klev),   INTENT(OUT)     :: clw
+  REAL, DIMENSION(klon,klev),   INTENT(OUT)     :: dd_t, dd_q
+  REAL, DIMENSION(klon,klev),   INTENT(OUT)     :: evap, ep
+  REAL, DIMENSION(klon,klev),   INTENT(OUT)     :: eplaMm
+  REAL, DIMENSION(klon,klev,klev), INTENT(OUT)  :: epmlmMm
+  REAL, DIMENSION(klon,klev),   INTENT(OUT)     :: wdtrainA, wdtrainS, wdtrainM
+! RomP <<<
+  REAL, DIMENSION(klon,klev),   INTENT(OUT)     :: wght                       !RL
+  REAL, DIMENSION(klon,klev),   INTENT(OUT)     :: qtc
+  REAL, DIMENSION(klon,klev),   INTENT(OUT)     :: sigt, detrain
+  REAL,                         INTENT(OUT)     :: tau_cld_cv, coefw_cld_cv
+  REAL, DIMENSION(klon),        INTENT(OUT)     :: epmax_diag                ! epmax_cape
+
+!
+!  Local
+!  ----
+  REAL, DIMENSION(klon,klev)                    :: em_p
+  REAL, DIMENSION(klon,klev+1)                  :: em_ph
+  REAL                                          :: em_sig1feed ! sigma at lower bound of feeding layer
+  REAL                                          :: em_sig2feed ! sigma at upper bound of feeding layer
+  REAL, DIMENSION(klev)                         :: em_wght ! weight density determining the feeding mixture
+  REAL, DIMENSION(klon,klev+1)                  :: Vprecipi                       !jyg
+!on enleve le save
+! SAVE em_sig1feed,em_sig2feed,em_wght
+
+  REAL, DIMENSION(klon)                         :: rflag
+  REAL, DIMENSION(klon)                         :: plim1, plim2
+  REAL, DIMENSION(klon)                         :: ptop2
+  REAL, DIMENSION(klon,klev)                    :: asupmax
+  REAL, DIMENSION(klon)                         :: supmax0, asupmaxmin
+  REAL                                          :: zx_t, zdelta, zx_qs, zcor
+!
+!   INTEGER iflag_mix
+!   SAVE iflag_mix
+  INTEGER                                       :: noff, minorig
+  INTEGER                                       :: i,j, k, itra
+  REAL, DIMENSION(klon,klev)                    :: qs, qs_wake
+!LF          SAVE cbmf
+!IM/JYG      REAL, SAVE, ALLOCATABLE :: cbmf(:)
+!!!$OMP THREADPRIVATE(cbmf)!
+  REAL, DIMENSION(klon)                         :: cbmflast
+
+
+! Variables supplementaires liees au bilan d'energie
+! Real paire(klon)
+!LF      Real ql(klon,klev)
+! Save paire
+!LF      Save ql
+!LF      Real t1(klon,klev),q1(klon,klev)
+!LF      Save t1,q1
+! Data paire /1./
+  REAL, SAVE, ALLOCATABLE :: ql(:, :), q1(:, :), t1(:, :)
+!$OMP THREADPRIVATE(ql, q1, t1)
+
+! Variables liees au bilan d'energie et d'enthAlpi
+  REAL ztsol(klon)
+  REAL        h_vcol_tot, h_dair_tot, h_qw_tot, h_ql_tot, &
+              h_qs_tot, qw_tot, ql_tot, qs_tot, ec_tot
+  SAVE        h_vcol_tot, h_dair_tot, h_qw_tot, h_ql_tot, &
+              h_qs_tot, qw_tot, ql_tot, qs_tot, ec_tot
+!$OMP THREADPRIVATE(h_vcol_tot, h_dair_tot, h_qw_tot, h_ql_tot)
+!$OMP THREADPRIVATE(h_qs_tot, qw_tot, ql_tot, qs_tot , ec_tot)
+  REAL        d_h_vcol, d_h_dair, d_qt, d_qw, d_ql, d_qs, d_ec
+  REAL        d_h_vcol_phy
+  REAL        fs_bound, fq_bound
+  SAVE        d_h_vcol_phy
+!$OMP THREADPRIVATE(d_h_vcol_phy)
+  REAL        zero_v(klon)
+  CHARACTER *15 ztit
+  INTEGER     ip_ebil ! PRINT level for energy conserv. diag.
+  SAVE        ip_ebil
+  DATA        ip_ebil/2/
+!$OMP THREADPRIVATE(ip_ebil)
+  INTEGER     if_ebil ! level for energy conserv. dignostics
+  SAVE        if_ebil
+  DATA        if_ebil/2/
+!$OMP THREADPRIVATE(if_ebil)
+!+jld ec_conser
+  REAL d_t_ec(klon, klev) ! tendance du a la conersion Ec -> E thermique
+  REAL zrcpd
+!-jld ec_conser
+!LF
+  INTEGER nloc
+  LOGICAL, SAVE            :: first = .TRUE.
+!$OMP THREADPRIVATE(first)
+  INTEGER, SAVE            :: itap, igout
+!$OMP THREADPRIVATE(itap, igout)
+
+
+  include "YOMCST.h"
+  include "YOMCST2.h"
+  include "YOETHF.h"
+  include "FCTTRE.h"
+!jyg<
+  include "conema3.h"
+!>jyg
+
+  IF (first) THEN
+! Allocate some variables LF 04/2008
+
+!IM/JYG allocate(cbmf(klon))
+    ALLOCATE (ql(klon,klev))
+    ALLOCATE (t1(klon,klev))
+    ALLOCATE (q1(klon,klev))
+!
+    convoccur(:) = 0.
+!
+    itap = 0
+    igout = klon/2 + 1/klon
+  END IF
+! Incrementer le compteur de la physique
+  itap = itap + 1
+
+! Copy T into Tconv
+  DO k = 1, klev
+    DO i = 1, klon
+      Tconv(i, k) = t(i, k)
+    END DO
+  END DO
+
+  IF (if_ebil>=1) THEN
+    DO i = 1, klon
+      ztsol(i) = t(i, 1)
+      zero_v(i) = 0.
+      DO k = 1, klev
+        ql(i, k) = 0.
+      END DO
+    END DO
+  END IF
+
+! ym
+  snow(:) = 0
+
+  IF (first) THEN
+    first = .FALSE.
+
+! ===========================================================================
+! READ IN PARAMETERS FOR THE CLOSURE AND THE MIXING DISTRIBUTION
+! ===========================================================================
+
+    IF (iflag_con==3) THEN
+!      CALL cv3_inicp()
+      CALL cv3_inip()
+    END IF
+
+! ===========================================================================
+! READ IN PARAMETERS FOR CONVECTIVE INHIBITION BY TROPOS. DRYNESS
+! ===========================================================================
+
+! c$$$         open (56,file='supcrit.data')
+! c$$$         read (56,*) Supcrit1, Supcrit2
+! c$$$         close (56)
+
+    IF (prt_level>=10) WRITE (lunout, *) 'supcrit1, supcrit2', supcrit1, supcrit2
+
+! ===========================================================================
+! Initialisation pour les bilans d'eau et d'energie
+! ===========================================================================
+    IF (if_ebil>=1) d_h_vcol_phy = 0.
+
+    DO i = 1, klon
+      cbmf(i) = 0.
+!!          plcl(i) = 0.
+      sigd(i) = 0.
+    END DO
+  END IF !(first)
+
+! Initialisation a chaque pas de temps
+  plfc(:) = 0.
+  wbeff(:) = 100.
+  plcl(:) = 0.
+
+  DO k = 1, klev + 1
+    DO i = 1, klon
+      em_ph(i, k) = paprs(i, k)/100.0
+      pmflxr(i, k) = 0.
+      pmflxs(i, k) = 0.
+    END DO
+  END DO
+
+  DO k = 1, klev
+    DO i = 1, klon
+      em_p(i, k) = pplay(i, k)/100.0
+    END DO
+  END DO
+
+
+! Feeding layer
+
+  em_sig1feed = 1.
+!jyg<
+!  em_sig2feed = 0.97
+  em_sig2feed = cvl_sig2feed
+!>jyg
+! em_sig2feed = 0.8
+! Relative Weight densities
+  DO k = 1, klev
+    em_wght(k) = 1.
+  END DO
+!CRtest: couche alim des tehrmiques ponderee par a*
+! DO i = 1, klon
+! do k=1,lalim_conv(i)
+! em_wght(k)=wght_th(i,k)
+! print*,'em_wght=',em_wght(k),wght_th(i,k)
+! end do
+! END DO
+
+  IF (iflag_con==4) THEN
+    DO k = 1, klev
+      DO i = 1, klon
+        zx_t = t(i, k)
+        zdelta = max(0., sign(1.,rtt-zx_t))
+        zx_qs = min(0.5, r2es*foeew(zx_t,zdelta)/em_p(i,k)/100.0)
+        zcor = 1./(1.-retv*zx_qs)
+        qs(i, k) = zx_qs*zcor
+      END DO
+      DO i = 1, klon
+        zx_t = t_wake(i, k)
+        zdelta = max(0., sign(1.,rtt-zx_t))
+        zx_qs = min(0.5, r2es*foeew(zx_t,zdelta)/em_p(i,k)/100.0)
+        zcor = 1./(1.-retv*zx_qs)
+        qs_wake(i, k) = zx_qs*zcor
+      END DO
+    END DO
+  ELSE ! iflag_con=3 (modif de puristes qui fait la diffce pour la convergence numerique)
+    DO k = 1, klev
+      DO i = 1, klon
+        zx_t = t(i, k)
+        zdelta = max(0., sign(1.,rtt-zx_t))
+        zx_qs = r2es*foeew(zx_t, zdelta)/em_p(i, k)/100.0
+        zx_qs = min(0.5, zx_qs)
+        zcor = 1./(1.-retv*zx_qs)
+        zx_qs = zx_qs*zcor
+        qs(i, k) = zx_qs
+      END DO
+      DO i = 1, klon
+        zx_t = t_wake(i, k)
+        zdelta = max(0., sign(1.,rtt-zx_t))
+        zx_qs = r2es*foeew(zx_t, zdelta)/em_p(i, k)/100.0
+        zx_qs = min(0.5, zx_qs)
+        zcor = 1./(1.-retv*zx_qs)
+        zx_qs = zx_qs*zcor
+        qs_wake(i, k) = zx_qs
+      END DO
+    END DO
+  END IF ! iflag_con
+
+! ------------------------------------------------------------------
+
+! Main driver for convection:
+!                   iflag_con=3 -> nvlle version de KE (JYG)
+!                   iflag_con = 30  -> equivAlent to convect3
+!                   iflag_con = 4  -> equivAlent to convect1/2
+
+
+  IF (iflag_con==30) THEN
+
+! print *, '-> cv_driver'      !jyg
+    CALL cv_driver(klon, klev, klevp1, ntra, iflag_con, &
+                   t, q, qs, u, v, tra, &
+                   em_p, em_ph, iflag, &
+                   d_t, d_q, d_u, d_v, d_tra, rain, &
+                   Vprecip, cbmf, sig1, w01, & !jyg
+                   kbas, ktop, &
+                   dtime, Ma, upwd, dnwd, dnwdbis, qcondc, wd, cape, &
+                   da, phi, mp, phii, d1a, dam, sij, clw, elij, &       !RomP
+                   evap, ep, epmlmMm, eplaMm, &                         !RomP
+                   wdtrainA, wdtrainM, &                                !RomP
+                   epmax_diag) ! epmax_cape
+!           print *, 'cv_driver ->'      !jyg
+
+    DO i = 1, klon
+      cbmf(i) = Ma(i, kbas(i))
+    END DO
+
+!RL
+    wght(:, :) = 0.
+    DO i = 1, klon
+      wght(i, 1) = 1.
+    END DO
+!RL
+
+  ELSE
+
+!LF   necessary for gathered fields
+    nloc = klon
+    CALL cva_driver(klon, klev, klev+1, ntra, nloc, k_upper_cv, &
+                    iflag_con, iflag_mix, iflag_ice_thermo, &
+                    iflag_clos, ok_conserv_q, dtime, cvl_comp_threshold, &
+                    t, q, qs, t_wake, q_wake, qs_wake, s_wake, u, v, tra, &
+                    em_p, em_ph, &
+                    Ale, Alp, omega, &
+                    em_sig1feed, em_sig2feed, em_wght, &
+                    iflag, d_t, d_q, d_qcomp, d_u, d_v, d_tra, rain, kbas, ktop, &
+                    cbmf, plcl, plfc, wbeff, sig1, w01, ptop2, sigd, &
+                    Ma, mip, Vprecip, Vprecipi, upwd, dnwd, dnwdbis, qcondc, wd, &
+                    cape, cin, tvp, &
+                    dd_t, dd_q, plim1, plim2, asupmax, supmax0, &
+                    asupmaxmin, lalim_conv, &
+!AC!+!RomP+jyg
+!!                   da,phi,mp,phii,d1a,dam,sij,clw,elij, &               ! RomP
+!!                   evap,ep,epmlmMm,eplaMm,                              ! RomP
+                    da, phi, mp, phii, d1a, dam, sij, wght, &           ! RomP+RL
+                    qta, clw, elij, evap, ep, epmlmMm, eplaMm, &        ! RomP+RL
+                    wdtrainA, wdtrainS, wdtrainM, qtc, sigt, detrain, &
+                    tau_cld_cv, coefw_cld_cv, &                         ! RomP,AJ
+!AC!+!RomP+jyg
+                    epmax_diag) ! epmax_cape
+  END IF
+! ------------------------------------------------------------------
+  IF (prt_level>=10) WRITE (lunout, *) ' cva_driver -> cbmf,plcl,plfc,wbeff, d_t, d_q ', &
+                                         cbmf(1), plcl(1), plfc(1), wbeff(1), d_t(1,1), d_q(1,1)
+
+  DO i = 1, klon
+    rain(i) = rain(i)/86400.
+    rflag(i) = iflag(i)
+  END DO
+
+  DO k = 1, klev
+    DO i = 1, klon
+      d_t(i, k) = dtime*d_t(i, k)
+      d_q(i, k) = dtime*d_q(i, k)
+      d_u(i, k) = dtime*d_u(i, k)
+      d_v(i, k) = dtime*d_v(i, k)
+    END DO
+  END DO
+
+  IF (iflag_con==3) THEN
+    DO i = 1,klon
+      IF (wbeff(i) > 100. .OR. wbeff(i) == 0 .OR. iflag(i) > 3) THEN
+        wbeff(i) = 0.
+        convoccur(i) = 0.  
+      ELSE
+        convoccur(i) = 1.
+      ENDIF
+    ENDDO
+  ENDIF
+
+  IF (iflag_con==30) THEN
+    DO itra = 1, ntra
+      DO k = 1, klev
+        DO i = 1, klon
+!RL!            d_tra(i,k,itra) =dtime*d_tra(i,k,itra)
+          d_tra(i, k, itra) = 0.
+        END DO
+      END DO
+    END DO
+  END IF
+
+!!AC!
+  IF (iflag_con==3) THEN
+    DO itra = 1, ntra
+      DO k = 1, klev
+        DO i = 1, klon
+!RL!            d_tra(i,k,itra) =dtime*d_tra(i,k,itra)
+          d_tra(i, k, itra) = 0.
+        END DO
+      END DO
+    END DO
+  END IF
+!!AC!
+
+  DO k = 1, klev
+    DO i = 1, klon
+      t1(i, k) = t(i, k) + d_t(i, k)
+      q1(i, k) = q(i, k) + d_q(i, k)
+    END DO
+  END DO
+!                                                     !jyg
+  IF (iflag_con == 30 .OR. iflag_ice_thermo ==0) THEN
+! --Separation neige/pluie (pour diagnostics)         !jyg
+    DO k = 1, klev                                    !jyg
+      DO i = 1, klon                                  !jyg
+        IF (t1(i,k)<rtt) THEN                         !jyg
+          pmflxs(i, k) = Vprecip(i, k)                !jyg
+        ELSE                                          !jyg
+          pmflxr(i, k) = Vprecip(i, k)                !jyg
+        END IF                                        !jyg
+      END DO                                          !jyg
+    END DO                                            !jyg
+  ELSE
+    DO k = 1, klev                                    !jyg
+      DO i = 1, klon                                  !jyg
+        pmflxs(i, k) = Vprecipi(i, k)                 !jyg
+        pmflxr(i, k) = Vprecip(i, k)-Vprecipi(i, k)   !jyg
+      END DO                                          !jyg
+    END DO                                            !jyg
+  ENDIF
+
+! c      IF (if_ebil.ge.2) THEN
+! c        ztit='after convect'
+! c        CALL diagetpq(paire,ztit,ip_ebil,2,2,dtime
+! c     e      , t1,q1,ql,qs,u,v,paprs,pplay
+! c     s      , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec)
+! c         call diagphy(paire,ztit,ip_ebil
+! c     e      , zero_v, zero_v, zero_v, zero_v, zero_v
+! c     e      , zero_v, rain, zero_v, ztsol
+! c     e      , d_h_vcol, d_qt, d_ec
+! c     s      , fs_bound, fq_bound )
+! c      END IF
+
+
+! les traceurs ne sont pas mis dans cette version de convect4:
+  IF (iflag_con==4) THEN
+    DO itra = 1, ntra
+      DO k = 1, klev
+        DO i = 1, klon
+          d_tra(i, k, itra) = 0.
+        END DO
+      END DO
+    END DO
+  END IF
+! print*, 'concvl->: dd_t,dd_q ',dd_t(1,1),dd_q(1,1)
+
+  DO k = 1, klev
+    DO i = 1, klon
+      dtvpdt1(i, k) = 0.
+      dtvpdq1(i, k) = 0.
+    END DO
+  END DO
+  DO i = 1, klon
+    dplcldt(i) = 0.
+    dplcldr(i) = 0.
+  END DO
+
+  IF (prt_level>=20) THEN
+    DO k = 1, klev
+! print*,'physiq apres_add_con i k it d_u d_v d_t d_q qdl0',igout, &
+!         k,itap,d_u_con(igout,k) ,d_v_con(igout,k), d_t_con(igout,k), &
+!         d_q_con(igout,k),dql0(igout,k)
+! print*,'phys apres_add_con itap Ma cin ALE ALP wak t q undi t q', &
+!         itap,Ma(igout,k),cin(igout),ALE(igout), ALP(igout), &
+!         t_wake(igout,k),q_wake(igout,k),t_undi(igout,k),q_undi(igout,k)
+! print*,'phy apres_add_con itap CON rain snow EMA wk1 wk2 Vpp mip', &
+!         itap,rain_con(igout),snow_con(igout),ema_work1(igout,k), &
+!         ema_work2(igout,k),Vprecip(igout,k), mip(igout,k)
+! print*,'phy apres_add_con itap upwd dnwd dnwd0 cape tvp Tconv ', &
+!         itap,upwd(igout,k),dnwd(igout,k),dnwd0(igout,k),cape(igout), &
+!         tvp(igout,k),Tconv(igout,k)
+! print*,'phy apres_add_con itap dtvpdt dtvdq dplcl dplcldr qcondc', &
+!         itap,dtvpdt1(igout,k),dtvpdq1(igout,k),dplcldt(igout), &
+!         dplcldr(igout),qcondc(igout,k)
+! print*,'phy apres_add_con itap wd pmflxr Kpmflxr Kp1 Kpmflxs Kp1', &
+!         itap,wd(igout),pmflxr(igout,k),pmflxr(igout,k+1),pmflxs(igout,k), &
+!         pmflxs(igout,k+1)
+! print*,'phy apres_add_con itap da phi mp ftd fqd lalim wgth', &
+!         itap,da(igout,k),phi(igout,k,k),mp(igout,k),ftd(igout,k), &
+!         fqd(igout,k),lalim_conv(igout),wght_th(igout,k)
+    END DO
+  END IF !(prt_level.EQ.20) THEN
+
+  RETURN
+END SUBROUTINE concvl
+
Index: DZ6/trunk/libf/phylmd/condsurf.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/condsurf.F90	(revision 5267)
+++ 	(revision )
@@ -1,133 +1,0 @@
-! $Header$
-
-SUBROUTINE condsurf(jour, jourvrai, lmt_bils)
-  USE dimphy
-  USE mod_grid_phy_lmdz
-  USE mod_phys_lmdz_para
-  USE indice_sol_mod
-  USE time_phylmdz_mod, ONLY: annee_ref
-  USE netcdf, ONLY: nf90_get_var
-  IMPLICIT NONE
-
-  ! I. Musat 05.2005
-
-  ! Lire chaque jour le bilan de chaleur au sol issu
-  ! d'un run atmospherique afin de l'utiliser dans
-  ! dans un run "slab" ocean
-  ! -----------------------------------------
-  ! jour     : input  , numero du jour a lire
-  ! jourvrai : input  , vrai jour de la simulation
-
-  ! lmt_bils: bilan chaleur au sol (a utiliser pour "slab-ocean")
-
-  include "netcdf.inc"
-  INTEGER nid, nvarid
-  INTEGER debut(2)
-  INTEGER epais(2)
-
-  include "clesphys.h"
-
-  INTEGER nannemax
-  PARAMETER (nannemax=60)
-
-  INTEGER jour, jourvrai
-  REAL lmt_bils(klon) !bilan chaleur au sol
-
-  ! Variables locales:
-  INTEGER ig, i, kt, ierr
-  LOGICAL ok
-  INTEGER anneelim, anneemax
-  CHARACTER *20 fich
-
-  REAL :: lmt_bils_glo(klon_glo)
-
-  ! c
-  ! c   .....................................................................
-  ! c
-  ! c    Pour lire le fichier limit correspondant vraiment  a l'annee de la
-  ! c     simulation en cours , il suffit de mettre  ok_limitvrai = .TRUE.
-  ! c
-  ! c
-  ! ......................................................................
-
-
-
-  IF (jour<0 .OR. jour>(360-1)) THEN
-    PRINT *, 'Le jour demande n est pas correct: ', jour
-    CALL abort_physic('condsurf', '', 1)
-  END IF
-
-  anneelim = annee_ref
-  anneemax = annee_ref + nannemax
-
-
-  IF (ok_limitvrai) THEN
-    DO kt = 1, nannemax
-      IF (jourvrai<=(kt-1)*360+359) THEN
-        WRITE (fich, '("limit",i4,".nc")') anneelim
-        ! PRINT *,' Fichier  Limite ',fich
-        GO TO 100
-      END IF
-      anneelim = anneelim + 1
-    END DO
-
-    PRINT *, ' PBS ! Le jour a lire sur le fichier limit ne se '
-    PRINT *, ' trouve pas sur les ', nannemax, ' annees a partir de '
-    PRINT *, ' l annee de debut', annee_ref
-    CALL abort_physic('condsurf', '', 1)
-
-100 CONTINUE
-
-  ELSE
-
-    WRITE (fich, '("limitNEW.nc")')
-    ! PRINT *,' Fichier  Limite ',fich
-  END IF
-
-  ! Ouvrir le fichier en format NetCDF:
-
-  !$OMP MASTER
-  IF (is_mpi_root) THEN
-    ierr = nf_open(fich, nf_nowrite, nid)
-    IF (ierr/=nf_noerr) THEN
-      WRITE (6, *) ' Pb d''ouverture du fichier ', fich
-      WRITE (6, *) ' Le fichier limit ', fich, ' (avec 4 chiffres , pour'
-      WRITE (6, *) '       l an 2000 )  ,  n existe  pas !  '
-      WRITE (6, *) ' ierr = ', ierr
-      CALL abort_physic('condsurf', '', 1)
-    END IF
-    ! DO k = 1, jour
-    ! La tranche de donnees a lire:
-
-    debut(1) = 1
-    debut(2) = jourvrai
-    epais(1) = klon_glo
-    epais(2) = 1
-    ! Bilan flux de chaleur au sol:
-
-    ierr = nf_inq_varid(nid, 'BILS', nvarid)
-    IF (ierr/=nf_noerr) THEN
-      CALL abort_physic('cond_surf', 'Le champ <BILS> est absent', 1)
-    END IF
-    PRINT *, 'debut,epais', debut, epais, 'jour,jourvrai', jour, jourvrai
-    ierr = nf90_get_var(nid, nvarid,  lmt_bils_glo, debut, epais)
-    IF (ierr/=nf_noerr) THEN
-      CALL abort_physic('condsurf', 'Lecture echouee pour <BILS>', 1)
-    END IF
-    ! ENDDO !k = 1, jour
-
-    ! Fermer le fichier:
-
-    ierr = nf_close(nid)
-
-  END IF ! is_mpi_root==0
-
-  !$OMP END MASTER
-  CALL scatter(lmt_bils_glo, lmt_bils)
-
-
-
-  ! PRINT*, 'lmt_bils est lu pour jour: ', jour
-
-  RETURN
-END SUBROUTINE condsurf
Index: /LMDZ6/trunk/libf/phylmd/condsurf.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/condsurf.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/condsurf.f90	(revision 5268)
@@ -0,0 +1,133 @@
+! $Header$
+
+SUBROUTINE condsurf(jour, jourvrai, lmt_bils)
+  USE dimphy
+  USE mod_grid_phy_lmdz
+  USE mod_phys_lmdz_para
+  USE indice_sol_mod
+  USE time_phylmdz_mod, ONLY: annee_ref
+  USE netcdf, ONLY: nf90_get_var
+  IMPLICIT NONE
+
+  ! I. Musat 05.2005
+
+  ! Lire chaque jour le bilan de chaleur au sol issu
+  ! d'un run atmospherique afin de l'utiliser dans
+  ! dans un run "slab" ocean
+  ! -----------------------------------------
+  ! jour     : input  , numero du jour a lire
+  ! jourvrai : input  , vrai jour de la simulation
+
+  ! lmt_bils: bilan chaleur au sol (a utiliser pour "slab-ocean")
+
+  include "netcdf.inc"
+  INTEGER nid, nvarid
+  INTEGER debut(2)
+  INTEGER epais(2)
+
+  include "clesphys.h"
+
+  INTEGER nannemax
+  PARAMETER (nannemax=60)
+
+  INTEGER jour, jourvrai
+  REAL lmt_bils(klon) !bilan chaleur au sol
+
+  ! Variables locales:
+  INTEGER ig, i, kt, ierr
+  LOGICAL ok
+  INTEGER anneelim, anneemax
+  CHARACTER *20 fich
+
+  REAL :: lmt_bils_glo(klon_glo)
+
+  ! c
+  ! c   .....................................................................
+  ! c
+  ! c    Pour lire le fichier limit correspondant vraiment  a l'annee de la
+  ! c     simulation en cours , il suffit de mettre  ok_limitvrai = .TRUE.
+  ! c
+  ! c
+  ! ......................................................................
+
+
+
+  IF (jour<0 .OR. jour>(360-1)) THEN
+    PRINT *, 'Le jour demande n est pas correct: ', jour
+    CALL abort_physic('condsurf', '', 1)
+  END IF
+
+  anneelim = annee_ref
+  anneemax = annee_ref + nannemax
+
+
+  IF (ok_limitvrai) THEN
+    DO kt = 1, nannemax
+      IF (jourvrai<=(kt-1)*360+359) THEN
+        WRITE (fich, '("limit",i4,".nc")') anneelim
+        ! PRINT *,' Fichier  Limite ',fich
+        GO TO 100
+      END IF
+      anneelim = anneelim + 1
+    END DO
+
+    PRINT *, ' PBS ! Le jour a lire sur le fichier limit ne se '
+    PRINT *, ' trouve pas sur les ', nannemax, ' annees a partir de '
+    PRINT *, ' l annee de debut', annee_ref
+    CALL abort_physic('condsurf', '', 1)
+
+100 CONTINUE
+
+  ELSE
+
+    WRITE (fich, '("limitNEW.nc")')
+    ! PRINT *,' Fichier  Limite ',fich
+  END IF
+
+  ! Ouvrir le fichier en format NetCDF:
+
+  !$OMP MASTER
+  IF (is_mpi_root) THEN
+    ierr = nf_open(fich, nf_nowrite, nid)
+    IF (ierr/=nf_noerr) THEN
+      WRITE (6, *) ' Pb d''ouverture du fichier ', fich
+      WRITE (6, *) ' Le fichier limit ', fich, ' (avec 4 chiffres , pour'
+      WRITE (6, *) '       l an 2000 )  ,  n existe  pas !  '
+      WRITE (6, *) ' ierr = ', ierr
+      CALL abort_physic('condsurf', '', 1)
+    END IF
+    ! DO k = 1, jour
+    ! La tranche de donnees a lire:
+
+    debut(1) = 1
+    debut(2) = jourvrai
+    epais(1) = klon_glo
+    epais(2) = 1
+    ! Bilan flux de chaleur au sol:
+
+    ierr = nf_inq_varid(nid, 'BILS', nvarid)
+    IF (ierr/=nf_noerr) THEN
+      CALL abort_physic('cond_surf', 'Le champ <BILS> est absent', 1)
+    END IF
+    PRINT *, 'debut,epais', debut, epais, 'jour,jourvrai', jour, jourvrai
+    ierr = nf90_get_var(nid, nvarid,  lmt_bils_glo, debut, epais)
+    IF (ierr/=nf_noerr) THEN
+      CALL abort_physic('condsurf', 'Lecture echouee pour <BILS>', 1)
+    END IF
+    ! ENDDO !k = 1, jour
+
+    ! Fermer le fichier:
+
+    ierr = nf_close(nid)
+
+  END IF ! is_mpi_root==0
+
+  !$OMP END MASTER
+  CALL scatter(lmt_bils_glo, lmt_bils)
+
+
+
+  ! PRINT*, 'lmt_bils est lu pour jour: ', jour
+
+  RETURN
+END SUBROUTINE condsurf
Index: DZ6/trunk/libf/phylmd/conema3.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/conema3.F90	(revision 5267)
+++ 	(revision )
@@ -1,412 +1,0 @@
-
-! $Id$
-
-SUBROUTINE conema3(dtime, paprs, pplay, t, q, u, v, tra, ntra, work1, work2, &
-    d_t, d_q, d_u, d_v, d_tra, rain, snow, kbas, ktop, upwd, dnwd, dnwdbis, &
-    bas, top, ma, cape, tvp, rflag, pbase, bbase, dtvpdt1, dtvpdq1, dplcldt, &
-    dplcldr, qcond_incld)
-
-  USE dimphy
-  USE infotrac_phy, ONLY: nbtr
-  IMPLICIT NONE
-  ! ======================================================================
-  ! Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818
-  ! Objet: schema de convection de Emanuel (1991) interface
-  ! Mai 1998: Interface modifiee pour implementation dans LMDZ
-  ! ======================================================================
-  ! Arguments:
-  ! dtime---input-R-pas d'integration (s)
-  ! paprs---input-R-pression inter-couches (Pa)
-  ! pplay---input-R-pression au milieu des couches (Pa)
-  ! t-------input-R-temperature (K)
-  ! q-------input-R-humidite specifique (kg/kg)
-  ! u-------input-R-vitesse du vent zonal (m/s)
-  ! v-------input-R-vitesse duvent meridien (m/s)
-  ! tra-----input-R-tableau de rapport de melange des traceurs
-  ! work*: input et output: deux variables de travail,
-  ! on peut les mettre a 0 au debut
-
-  ! d_t-----output-R-increment de la temperature
-  ! d_q-----output-R-increment de la vapeur d'eau
-  ! d_u-----output-R-increment de la vitesse zonale
-  ! d_v-----output-R-increment de la vitesse meridienne
-  ! d_tra---output-R-increment du contenu en traceurs
-  ! rain----output-R-la pluie (mm/s)
-  ! snow----output-R-la neige (mm/s)
-  ! kbas----output-R-bas du nuage (integer)
-  ! ktop----output-R-haut du nuage (integer)
-  ! upwd----output-R-saturated updraft mass flux (kg/m**2/s)
-  ! dnwd----output-R-saturated downdraft mass flux (kg/m**2/s)
-  ! dnwdbis-output-R-unsaturated downdraft mass flux (kg/m**2/s)
-  ! bas-----output-R-bas du nuage (real)
-  ! top-----output-R-haut du nuage (real)
-  ! Ma------output-R-flux ascendant non dilue (kg/m**2/s)
-  ! cape----output-R-CAPE
-  ! tvp-----output-R-virtual temperature of the lifted parcel
-  ! rflag---output-R-flag sur le fonctionnement de convect
-  ! pbase---output-R-pression a la base du nuage (Pa)
-  ! bbase---output-R-buoyancy a la base du nuage (K)
-  ! dtvpdt1-output-R-derivative of parcel virtual temp wrt T1
-  ! dtvpdq1-output-R-derivative of parcel virtual temp wrt Q1
-  ! dplcldt-output-R-derivative of the PCP pressure wrt T1
-  ! dplcldr-output-R-derivative of the PCP pressure wrt Q1
-  ! ======================================================================
-
-  include "conema3.h"
-  INTEGER i, l, m, itra
-  INTEGER ntra ! if no tracer transport
-    ! is needed, set ntra = 1 (or 0)
-  REAL dtime
-
-  REAL d_t2(klon, klev), d_q2(klon, klev) ! sbl
-  REAL d_u2(klon, klev), d_v2(klon, klev) ! sbl
-  REAL em_d_t2(klev), em_d_q2(klev) ! sbl
-  REAL em_d_u2(klev), em_d_v2(klev) ! sbl
-
-  REAL paprs(klon, klev+1), pplay(klon, klev)
-  REAL t(klon, klev), q(klon, klev), d_t(klon, klev), d_q(klon, klev)
-  REAL u(klon, klev), v(klon, klev), tra(klon, klev, ntra)
-  REAL d_u(klon, klev), d_v(klon, klev), d_tra(klon, klev, ntra)
-  REAL work1(klon, klev), work2(klon, klev)
-  REAL upwd(klon, klev), dnwd(klon, klev), dnwdbis(klon, klev)
-  REAL rain(klon)
-  REAL snow(klon)
-  REAL cape(klon), tvp(klon, klev), rflag(klon)
-  REAL pbase(klon), bbase(klon)
-  REAL dtvpdt1(klon, klev), dtvpdq1(klon, klev)
-  REAL dplcldt(klon), dplcldr(klon)
-  INTEGER kbas(klon), ktop(klon)
-
-  REAL wd(klon)
-  REAL qcond_incld(klon, klev)
-
-  LOGICAL, SAVE :: first = .TRUE.
-  !$OMP THREADPRIVATE(first)
-
-  ! ym      REAL em_t(klev)
-  REAL, ALLOCATABLE, SAVE :: em_t(:)
-  !$OMP THREADPRIVATE(em_t)
-  ! ym      REAL em_q(klev)
-  REAL, ALLOCATABLE, SAVE :: em_q(:)
-  !$OMP THREADPRIVATE(em_q)
-  ! ym      REAL em_qs(klev)
-  REAL, ALLOCATABLE, SAVE :: em_qs(:)
-  !$OMP THREADPRIVATE(em_qs)
-  ! ym      REAL em_u(klev), em_v(klev), em_tra(klev,nbtr)
-  REAL, ALLOCATABLE, SAVE :: em_u(:), em_v(:), em_tra(:, :)
-  !$OMP THREADPRIVATE(em_u,em_v,em_tra)
-  ! ym      REAL em_ph(klev+1), em_p(klev)
-  REAL, ALLOCATABLE, SAVE :: em_ph(:), em_p(:)
-  !$OMP THREADPRIVATE(em_ph,em_p)
-  ! ym      REAL em_work1(klev), em_work2(klev)
-  REAL, ALLOCATABLE, SAVE :: em_work1(:), em_work2(:)
-  !$OMP THREADPRIVATE(em_work1,em_work2)
-  ! ym      REAL em_precip, em_d_t(klev), em_d_q(klev)
-  REAL, SAVE :: em_precip
-  !$OMP THREADPRIVATE(em_precip)
-  REAL, ALLOCATABLE, SAVE :: em_d_t(:), em_d_q(:)
-  !$OMP THREADPRIVATE(em_d_t,em_d_q)
-  ! ym      REAL em_d_u(klev), em_d_v(klev), em_d_tra(klev,nbtr)
-  REAL, ALLOCATABLE, SAVE :: em_d_u(:), em_d_v(:), em_d_tra(:, :)
-  !$OMP THREADPRIVATE(em_d_u,em_d_v,em_d_tra)
-  ! ym      REAL em_upwd(klev), em_dnwd(klev), em_dnwdbis(klev)
-  REAL, ALLOCATABLE, SAVE :: em_upwd(:), em_dnwd(:), em_dnwdbis(:)
-  !$OMP THREADPRIVATE(em_upwd,em_dnwd,em_dnwdbis)
-  REAL em_dtvpdt1(klev), em_dtvpdq1(klev)
-  REAL em_dplcldt, em_dplcldr
-  ! ym      SAVE em_t,em_q, em_qs, em_ph, em_p, em_work1, em_work2
-  ! ym      SAVE em_u,em_v, em_tra
-  ! ym      SAVE em_d_u,em_d_v, em_d_tra
-  ! ym      SAVE em_precip, em_d_t, em_d_q, em_upwd, em_dnwd, em_dnwdbis
-
-  INTEGER em_bas, em_top
-  SAVE em_bas, em_top
-  !$OMP THREADPRIVATE(em_bas,em_top)
-  REAL em_wd
-  REAL em_qcond(klev)
-  REAL em_qcondc(klev)
-
-  REAL zx_t, zx_qs, zdelta, zcor
-  INTEGER iflag
-  REAL sigsum
-  ! cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
-  ! VARIABLES A SORTIR
-  ! ccccccccccccccccccccccccccccccccccccccccccccccccc
-
-  ! ym      REAL emmip(klev) !variation de flux ascnon dilue i et i+1
-  REAL, ALLOCATABLE, SAVE :: emmip(:)
-  !$OMP THREADPRIVATE(emmip)
-  ! ym      SAVE emmip
-  ! ym      real emMke(klev)
-  REAL, ALLOCATABLE, SAVE :: emmke(:)
-  !$OMP THREADPRIVATE(emMke)
-  ! ym      save emMke
-  REAL top
-  REAL bas
-  ! ym      real emMa(klev)
-  REAL, ALLOCATABLE, SAVE :: emma(:)
-  !$OMP THREADPRIVATE(emMa)
-  ! ym      save emMa
-  REAL ma(klon, klev)
-  REAL ment(klev, klev)
-  REAL qent(klev, klev)
-  REAL tps(klev), tls(klev)
-  REAL sij(klev, klev)
-  REAL em_cape, em_tvp(klev)
-  REAL em_pbase, em_bbase
-  INTEGER iw, j, k, ix, iy
-
-  ! -- sb: pour schema nuages:
-
-  INTEGER iflagcon
-  INTEGER em_ifc(klev)
-
-  REAL em_pradj
-  REAL em_cldf(klev), em_cldq(klev)
-  REAL em_ftadj(klev), em_fradj(klev)
-
-  INTEGER ifc(klon, klev)
-  REAL pradj(klon)
-  REAL cldf(klon, klev), cldq(klon, klev)
-  REAL ftadj(klon, klev), fqadj(klon, klev)
-
-  ! sb --
-
-  ! cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
-
-  include "YOMCST.h"
-  include "YOETHF.h"
-  include "FCTTRE.h"
-
-  IF (first) THEN
-
-    ALLOCATE (em_t(klev))
-    ALLOCATE (em_q(klev))
-    ALLOCATE (em_qs(klev))
-    ALLOCATE (em_u(klev), em_v(klev), em_tra(klev,nbtr))
-    ALLOCATE (em_ph(klev+1), em_p(klev))
-    ALLOCATE (em_work1(klev), em_work2(klev))
-    ALLOCATE (em_d_t(klev), em_d_q(klev))
-    ALLOCATE (em_d_u(klev), em_d_v(klev), em_d_tra(klev,nbtr))
-    ALLOCATE (em_upwd(klev), em_dnwd(klev), em_dnwdbis(klev))
-    ALLOCATE (emmip(klev))
-    ALLOCATE (emmke(klev))
-    ALLOCATE (emma(klev))
-
-    first = .FALSE.
-  END IF
-
-  qcond_incld(:, :) = 0.
-
-  ! @$$      print*,'debut conema'
-
-  DO i = 1, klon
-    DO l = 1, klev + 1
-      em_ph(l) = paprs(i, l)/100.0
-    END DO
-
-    DO l = 1, klev
-      em_p(l) = pplay(i, l)/100.0
-      em_t(l) = t(i, l)
-      em_q(l) = q(i, l)
-      em_u(l) = u(i, l)
-      em_v(l) = v(i, l)
-      DO itra = 1, ntra
-        em_tra(l, itra) = tra(i, l, itra)
-      END DO
-      ! @$$      print*,'em_t',em_t
-      ! @$$      print*,'em_q',em_q
-      ! @$$      print*,'em_qs',em_qs
-      ! @$$      print*,'em_u',em_u
-      ! @$$      print*,'em_v',em_v
-      ! @$$      print*,'em_tra',em_tra
-      ! @$$      print*,'em_p',em_p
-
-
-
-      zx_t = em_t(l)
-      zdelta = max(0., sign(1.,rtt-zx_t))
-      zx_qs = r2es*foeew(zx_t, zdelta)/em_p(l)/100.0
-      zx_qs = min(0.5, zx_qs)
-      ! @$$       print*,'zx_qs',zx_qs
-      zcor = 1./(1.-retv*zx_qs)
-      zx_qs = zx_qs*zcor
-      em_qs(l) = zx_qs
-      ! @$$      print*,'em_qs',em_qs
-
-      em_work1(l) = work1(i, l)
-      em_work2(l) = work2(i, l)
-      emmke(l) = 0
-      ! emMa(l)=0
-      ! Ma(i,l)=0
-
-      em_dtvpdt1(l) = 0.
-      em_dtvpdq1(l) = 0.
-      dtvpdt1(i, l) = 0.
-      dtvpdq1(i, l) = 0.
-    END DO
-
-    em_dplcldt = 0.
-    em_dplcldr = 0.
-    rain(i) = 0.0
-    snow(i) = 0.0
-    kbas(i) = 1
-    ktop(i) = 1
-    ! ajout SB:
-    bas = 1
-    top = 1
-
-
-    ! sb3d      write(*,1792) (em_work1(m),m=1,klev)
-1792 FORMAT ('sig avant convect ', /, 10(1X,E13.5))
-
-    ! sb d      write(*,1793) (em_work2(m),m=1,klev)
-1793 FORMAT ('w avant convect ', /, 10(1X,E13.5))
-
-    ! @$$      print*,'avant convect'
-    ! cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
-
-
-    ! print*,'avant convect i=',i
-    CALL convect3(dtime, epmax, ok_adj_ema, em_t, em_q, em_qs, em_u, em_v, &
-      em_tra, em_p, em_ph, klev, klev+1, klev-1, ntra, dtime, iflag, em_d_t, &
-      em_d_q, em_d_u, em_d_v, em_d_tra, em_precip, em_bas, em_top, em_upwd, &
-      em_dnwd, em_dnwdbis, em_work1, em_work2, emmip, emmke, emma, ment, &
-      qent, tps, tls, sij, em_cape, em_tvp, em_pbase, em_bbase, em_dtvpdt1, &
-      em_dtvpdq1, em_dplcldt, em_dplcldr, & ! sbl
-      em_d_t2, em_d_q2, em_d_u2, em_d_v2, em_wd, em_qcond, em_qcondc) !sbl
-    ! print*,'apres convect '
-
-    ! cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
-
-    ! -- sb: Appel schema statistique de nuages couple a la convection
-    ! (Bony et Emanuel 2001):
-
-    ! -- creer cvthermo.h qui contiendra les cstes thermo de LMDZ:
-
-    iflagcon = 3
-    ! CALL cv_thermo(iflagcon)
-
-    ! -- appel schema de nuages:
-
-    ! CALL CLOUDS_SUB_LS(klev,em_q,em_qs,em_t
-    ! i          ,em_p,em_ph,dtime,em_qcondc
-    ! o          ,em_cldf,em_cldq,em_pradj,em_ftadj,em_fradj,em_ifc)
-
-    DO k = 1, klev
-      cldf(i, k) = em_cldf(k) ! cloud fraction (0-1)
-      cldq(i, k) = em_cldq(k) ! in-cloud water content (kg/kg)
-      ftadj(i, k) = em_ftadj(k) ! (dT/dt)_{LS adj} (K/s)
-      fqadj(i, k) = em_fradj(k) ! (dq/dt)_{LS adj} (kg/kg/s)
-      ifc(i, k) = em_ifc(k) ! flag convergence clouds_gno (1 ou 2)
-    END DO
-    pradj(i) = em_pradj ! precip from LS supersat adj (mm/day)
-
-    ! sb --
-
-    ! SB:
-    IF (iflag/=1 .AND. iflag/=4) THEN
-      em_cape = 0.
-      DO l = 1, klev
-        em_upwd(l) = 0.
-        em_dnwd(l) = 0.
-        em_dnwdbis(l) = 0.
-        emma(l) = 0.
-        em_tvp(l) = 0.
-      END DO
-    END IF
-    ! fin SB
-
-    ! If sig has been set to zero, then set Ma to zero
-
-    sigsum = 0.
-    DO k = 1, klev
-      sigsum = sigsum + em_work1(k)
-    END DO
-    IF (sigsum==0.0) THEN
-      DO k = 1, klev
-        emma(k) = 0.
-      END DO
-    END IF
-
-    ! sb3d       print*,'i, iflag=',i,iflag
-
-    ! cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
-
-    ! SORTIE DES ICB ET INB
-    ! en fait inb et icb correspondent au niveau ou se trouve
-    ! le nuage,le numero d'interface
-    ! ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
-
-    ! modif SB:
-    IF (iflag==1 .OR. iflag==4) THEN
-      top = em_top
-      bas = em_bas
-      kbas(i) = em_bas
-      ktop(i) = em_top
-    END IF
-
-    pbase(i) = em_pbase
-    bbase(i) = em_bbase
-    rain(i) = em_precip/86400.0
-    snow(i) = 0.0
-    cape(i) = em_cape
-    wd(i) = em_wd
-    rflag(i) = real(iflag)
-    ! SB      kbas(i) = em_bas
-    ! SB      ktop(i) = em_top
-    dplcldt(i) = em_dplcldt
-    dplcldr(i) = em_dplcldr
-    DO l = 1, klev
-      d_t2(i, l) = dtime*em_d_t2(l)
-      d_q2(i, l) = dtime*em_d_q2(l)
-      d_u2(i, l) = dtime*em_d_u2(l)
-      d_v2(i, l) = dtime*em_d_v2(l)
-
-      d_t(i, l) = dtime*em_d_t(l)
-      d_q(i, l) = dtime*em_d_q(l)
-      d_u(i, l) = dtime*em_d_u(l)
-      d_v(i, l) = dtime*em_d_v(l)
-      DO itra = 1, ntra
-        d_tra(i, l, itra) = dtime*em_d_tra(l, itra)
-      END DO
-      upwd(i, l) = em_upwd(l)
-      dnwd(i, l) = em_dnwd(l)
-      dnwdbis(i, l) = em_dnwdbis(l)
-      work1(i, l) = em_work1(l)
-      work2(i, l) = em_work2(l)
-      ma(i, l) = emma(l)
-      tvp(i, l) = em_tvp(l)
-      dtvpdt1(i, l) = em_dtvpdt1(l)
-      dtvpdq1(i, l) = em_dtvpdq1(l)
-
-      IF (iflag_clw==0) THEN
-        qcond_incld(i, l) = em_qcondc(l)
-      ELSE IF (iflag_clw==1) THEN
-        qcond_incld(i, l) = em_qcond(l)
-      END IF
-    END DO
-  END DO
-
-  ! On calcule une eau liquide diagnostique en fonction de la
-  ! precip.
-  IF (iflag_clw==2) THEN
-    DO l = 1, klev
-      DO i = 1, klon
-        IF (ktop(i)-kbas(i)>0 .AND. l>=kbas(i) .AND. l<=ktop(i)) THEN
-          qcond_incld(i, l) = rain(i)*8.E4 & ! s         *(pplay(i,l
-                                             ! )-paprs(i,ktop(i)+1))
-            /(pplay(i,kbas(i))-pplay(i,ktop(i)))
-          ! s         **2
-        ELSE
-          qcond_incld(i, l) = 0.
-        END IF
-      END DO
-      PRINT *, 'l=', l, ',   qcond_incld=', qcond_incld(1, l)
-    END DO
-  END IF
-
-
-  RETURN
-END SUBROUTINE conema3
-
Index: /LMDZ6/trunk/libf/phylmd/conema3.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/conema3.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/conema3.f90	(revision 5268)
@@ -0,0 +1,412 @@
+
+! $Id$
+
+SUBROUTINE conema3(dtime, paprs, pplay, t, q, u, v, tra, ntra, work1, work2, &
+    d_t, d_q, d_u, d_v, d_tra, rain, snow, kbas, ktop, upwd, dnwd, dnwdbis, &
+    bas, top, ma, cape, tvp, rflag, pbase, bbase, dtvpdt1, dtvpdq1, dplcldt, &
+    dplcldr, qcond_incld)
+
+  USE dimphy
+  USE infotrac_phy, ONLY: nbtr
+  IMPLICIT NONE
+  ! ======================================================================
+  ! Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818
+  ! Objet: schema de convection de Emanuel (1991) interface
+  ! Mai 1998: Interface modifiee pour implementation dans LMDZ
+  ! ======================================================================
+  ! Arguments:
+  ! dtime---input-R-pas d'integration (s)
+  ! paprs---input-R-pression inter-couches (Pa)
+  ! pplay---input-R-pression au milieu des couches (Pa)
+  ! t-------input-R-temperature (K)
+  ! q-------input-R-humidite specifique (kg/kg)
+  ! u-------input-R-vitesse du vent zonal (m/s)
+  ! v-------input-R-vitesse duvent meridien (m/s)
+  ! tra-----input-R-tableau de rapport de melange des traceurs
+  ! work*: input et output: deux variables de travail,
+  ! on peut les mettre a 0 au debut
+
+  ! d_t-----output-R-increment de la temperature
+  ! d_q-----output-R-increment de la vapeur d'eau
+  ! d_u-----output-R-increment de la vitesse zonale
+  ! d_v-----output-R-increment de la vitesse meridienne
+  ! d_tra---output-R-increment du contenu en traceurs
+  ! rain----output-R-la pluie (mm/s)
+  ! snow----output-R-la neige (mm/s)
+  ! kbas----output-R-bas du nuage (integer)
+  ! ktop----output-R-haut du nuage (integer)
+  ! upwd----output-R-saturated updraft mass flux (kg/m**2/s)
+  ! dnwd----output-R-saturated downdraft mass flux (kg/m**2/s)
+  ! dnwdbis-output-R-unsaturated downdraft mass flux (kg/m**2/s)
+  ! bas-----output-R-bas du nuage (real)
+  ! top-----output-R-haut du nuage (real)
+  ! Ma------output-R-flux ascendant non dilue (kg/m**2/s)
+  ! cape----output-R-CAPE
+  ! tvp-----output-R-virtual temperature of the lifted parcel
+  ! rflag---output-R-flag sur le fonctionnement de convect
+  ! pbase---output-R-pression a la base du nuage (Pa)
+  ! bbase---output-R-buoyancy a la base du nuage (K)
+  ! dtvpdt1-output-R-derivative of parcel virtual temp wrt T1
+  ! dtvpdq1-output-R-derivative of parcel virtual temp wrt Q1
+  ! dplcldt-output-R-derivative of the PCP pressure wrt T1
+  ! dplcldr-output-R-derivative of the PCP pressure wrt Q1
+  ! ======================================================================
+
+  include "conema3.h"
+  INTEGER i, l, m, itra
+  INTEGER ntra ! if no tracer transport
+    ! is needed, set ntra = 1 (or 0)
+  REAL dtime
+
+  REAL d_t2(klon, klev), d_q2(klon, klev) ! sbl
+  REAL d_u2(klon, klev), d_v2(klon, klev) ! sbl
+  REAL em_d_t2(klev), em_d_q2(klev) ! sbl
+  REAL em_d_u2(klev), em_d_v2(klev) ! sbl
+
+  REAL paprs(klon, klev+1), pplay(klon, klev)
+  REAL t(klon, klev), q(klon, klev), d_t(klon, klev), d_q(klon, klev)
+  REAL u(klon, klev), v(klon, klev), tra(klon, klev, ntra)
+  REAL d_u(klon, klev), d_v(klon, klev), d_tra(klon, klev, ntra)
+  REAL work1(klon, klev), work2(klon, klev)
+  REAL upwd(klon, klev), dnwd(klon, klev), dnwdbis(klon, klev)
+  REAL rain(klon)
+  REAL snow(klon)
+  REAL cape(klon), tvp(klon, klev), rflag(klon)
+  REAL pbase(klon), bbase(klon)
+  REAL dtvpdt1(klon, klev), dtvpdq1(klon, klev)
+  REAL dplcldt(klon), dplcldr(klon)
+  INTEGER kbas(klon), ktop(klon)
+
+  REAL wd(klon)
+  REAL qcond_incld(klon, klev)
+
+  LOGICAL, SAVE :: first = .TRUE.
+  !$OMP THREADPRIVATE(first)
+
+  ! ym      REAL em_t(klev)
+  REAL, ALLOCATABLE, SAVE :: em_t(:)
+  !$OMP THREADPRIVATE(em_t)
+  ! ym      REAL em_q(klev)
+  REAL, ALLOCATABLE, SAVE :: em_q(:)
+  !$OMP THREADPRIVATE(em_q)
+  ! ym      REAL em_qs(klev)
+  REAL, ALLOCATABLE, SAVE :: em_qs(:)
+  !$OMP THREADPRIVATE(em_qs)
+  ! ym      REAL em_u(klev), em_v(klev), em_tra(klev,nbtr)
+  REAL, ALLOCATABLE, SAVE :: em_u(:), em_v(:), em_tra(:, :)
+  !$OMP THREADPRIVATE(em_u,em_v,em_tra)
+  ! ym      REAL em_ph(klev+1), em_p(klev)
+  REAL, ALLOCATABLE, SAVE :: em_ph(:), em_p(:)
+  !$OMP THREADPRIVATE(em_ph,em_p)
+  ! ym      REAL em_work1(klev), em_work2(klev)
+  REAL, ALLOCATABLE, SAVE :: em_work1(:), em_work2(:)
+  !$OMP THREADPRIVATE(em_work1,em_work2)
+  ! ym      REAL em_precip, em_d_t(klev), em_d_q(klev)
+  REAL, SAVE :: em_precip
+  !$OMP THREADPRIVATE(em_precip)
+  REAL, ALLOCATABLE, SAVE :: em_d_t(:), em_d_q(:)
+  !$OMP THREADPRIVATE(em_d_t,em_d_q)
+  ! ym      REAL em_d_u(klev), em_d_v(klev), em_d_tra(klev,nbtr)
+  REAL, ALLOCATABLE, SAVE :: em_d_u(:), em_d_v(:), em_d_tra(:, :)
+  !$OMP THREADPRIVATE(em_d_u,em_d_v,em_d_tra)
+  ! ym      REAL em_upwd(klev), em_dnwd(klev), em_dnwdbis(klev)
+  REAL, ALLOCATABLE, SAVE :: em_upwd(:), em_dnwd(:), em_dnwdbis(:)
+  !$OMP THREADPRIVATE(em_upwd,em_dnwd,em_dnwdbis)
+  REAL em_dtvpdt1(klev), em_dtvpdq1(klev)
+  REAL em_dplcldt, em_dplcldr
+  ! ym      SAVE em_t,em_q, em_qs, em_ph, em_p, em_work1, em_work2
+  ! ym      SAVE em_u,em_v, em_tra
+  ! ym      SAVE em_d_u,em_d_v, em_d_tra
+  ! ym      SAVE em_precip, em_d_t, em_d_q, em_upwd, em_dnwd, em_dnwdbis
+
+  INTEGER em_bas, em_top
+  SAVE em_bas, em_top
+  !$OMP THREADPRIVATE(em_bas,em_top)
+  REAL em_wd
+  REAL em_qcond(klev)
+  REAL em_qcondc(klev)
+
+  REAL zx_t, zx_qs, zdelta, zcor
+  INTEGER iflag
+  REAL sigsum
+  ! cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+  ! VARIABLES A SORTIR
+  ! ccccccccccccccccccccccccccccccccccccccccccccccccc
+
+  ! ym      REAL emmip(klev) !variation de flux ascnon dilue i et i+1
+  REAL, ALLOCATABLE, SAVE :: emmip(:)
+  !$OMP THREADPRIVATE(emmip)
+  ! ym      SAVE emmip
+  ! ym      real emMke(klev)
+  REAL, ALLOCATABLE, SAVE :: emmke(:)
+  !$OMP THREADPRIVATE(emMke)
+  ! ym      save emMke
+  REAL top
+  REAL bas
+  ! ym      real emMa(klev)
+  REAL, ALLOCATABLE, SAVE :: emma(:)
+  !$OMP THREADPRIVATE(emMa)
+  ! ym      save emMa
+  REAL ma(klon, klev)
+  REAL ment(klev, klev)
+  REAL qent(klev, klev)
+  REAL tps(klev), tls(klev)
+  REAL sij(klev, klev)
+  REAL em_cape, em_tvp(klev)
+  REAL em_pbase, em_bbase
+  INTEGER iw, j, k, ix, iy
+
+  ! -- sb: pour schema nuages:
+
+  INTEGER iflagcon
+  INTEGER em_ifc(klev)
+
+  REAL em_pradj
+  REAL em_cldf(klev), em_cldq(klev)
+  REAL em_ftadj(klev), em_fradj(klev)
+
+  INTEGER ifc(klon, klev)
+  REAL pradj(klon)
+  REAL cldf(klon, klev), cldq(klon, klev)
+  REAL ftadj(klon, klev), fqadj(klon, klev)
+
+  ! sb --
+
+  ! cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+
+  include "YOMCST.h"
+  include "YOETHF.h"
+  include "FCTTRE.h"
+
+  IF (first) THEN
+
+    ALLOCATE (em_t(klev))
+    ALLOCATE (em_q(klev))
+    ALLOCATE (em_qs(klev))
+    ALLOCATE (em_u(klev), em_v(klev), em_tra(klev,nbtr))
+    ALLOCATE (em_ph(klev+1), em_p(klev))
+    ALLOCATE (em_work1(klev), em_work2(klev))
+    ALLOCATE (em_d_t(klev), em_d_q(klev))
+    ALLOCATE (em_d_u(klev), em_d_v(klev), em_d_tra(klev,nbtr))
+    ALLOCATE (em_upwd(klev), em_dnwd(klev), em_dnwdbis(klev))
+    ALLOCATE (emmip(klev))
+    ALLOCATE (emmke(klev))
+    ALLOCATE (emma(klev))
+
+    first = .FALSE.
+  END IF
+
+  qcond_incld(:, :) = 0.
+
+  ! @$$      print*,'debut conema'
+
+  DO i = 1, klon
+    DO l = 1, klev + 1
+      em_ph(l) = paprs(i, l)/100.0
+    END DO
+
+    DO l = 1, klev
+      em_p(l) = pplay(i, l)/100.0
+      em_t(l) = t(i, l)
+      em_q(l) = q(i, l)
+      em_u(l) = u(i, l)
+      em_v(l) = v(i, l)
+      DO itra = 1, ntra
+        em_tra(l, itra) = tra(i, l, itra)
+      END DO
+      ! @$$      print*,'em_t',em_t
+      ! @$$      print*,'em_q',em_q
+      ! @$$      print*,'em_qs',em_qs
+      ! @$$      print*,'em_u',em_u
+      ! @$$      print*,'em_v',em_v
+      ! @$$      print*,'em_tra',em_tra
+      ! @$$      print*,'em_p',em_p
+
+
+
+      zx_t = em_t(l)
+      zdelta = max(0., sign(1.,rtt-zx_t))
+      zx_qs = r2es*foeew(zx_t, zdelta)/em_p(l)/100.0
+      zx_qs = min(0.5, zx_qs)
+      ! @$$       print*,'zx_qs',zx_qs
+      zcor = 1./(1.-retv*zx_qs)
+      zx_qs = zx_qs*zcor
+      em_qs(l) = zx_qs
+      ! @$$      print*,'em_qs',em_qs
+
+      em_work1(l) = work1(i, l)
+      em_work2(l) = work2(i, l)
+      emmke(l) = 0
+      ! emMa(l)=0
+      ! Ma(i,l)=0
+
+      em_dtvpdt1(l) = 0.
+      em_dtvpdq1(l) = 0.
+      dtvpdt1(i, l) = 0.
+      dtvpdq1(i, l) = 0.
+    END DO
+
+    em_dplcldt = 0.
+    em_dplcldr = 0.
+    rain(i) = 0.0
+    snow(i) = 0.0
+    kbas(i) = 1
+    ktop(i) = 1
+    ! ajout SB:
+    bas = 1
+    top = 1
+
+
+    ! sb3d      write(*,1792) (em_work1(m),m=1,klev)
+1792 FORMAT ('sig avant convect ', /, 10(1X,E13.5))
+
+    ! sb d      write(*,1793) (em_work2(m),m=1,klev)
+1793 FORMAT ('w avant convect ', /, 10(1X,E13.5))
+
+    ! @$$      print*,'avant convect'
+    ! cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+
+
+    ! print*,'avant convect i=',i
+    CALL convect3(dtime, epmax, ok_adj_ema, em_t, em_q, em_qs, em_u, em_v, &
+      em_tra, em_p, em_ph, klev, klev+1, klev-1, ntra, dtime, iflag, em_d_t, &
+      em_d_q, em_d_u, em_d_v, em_d_tra, em_precip, em_bas, em_top, em_upwd, &
+      em_dnwd, em_dnwdbis, em_work1, em_work2, emmip, emmke, emma, ment, &
+      qent, tps, tls, sij, em_cape, em_tvp, em_pbase, em_bbase, em_dtvpdt1, &
+      em_dtvpdq1, em_dplcldt, em_dplcldr, & ! sbl
+      em_d_t2, em_d_q2, em_d_u2, em_d_v2, em_wd, em_qcond, em_qcondc) !sbl
+    ! print*,'apres convect '
+
+    ! cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+
+    ! -- sb: Appel schema statistique de nuages couple a la convection
+    ! (Bony et Emanuel 2001):
+
+    ! -- creer cvthermo.h qui contiendra les cstes thermo de LMDZ:
+
+    iflagcon = 3
+    ! CALL cv_thermo(iflagcon)
+
+    ! -- appel schema de nuages:
+
+    ! CALL CLOUDS_SUB_LS(klev,em_q,em_qs,em_t
+    ! i          ,em_p,em_ph,dtime,em_qcondc
+    ! o          ,em_cldf,em_cldq,em_pradj,em_ftadj,em_fradj,em_ifc)
+
+    DO k = 1, klev
+      cldf(i, k) = em_cldf(k) ! cloud fraction (0-1)
+      cldq(i, k) = em_cldq(k) ! in-cloud water content (kg/kg)
+      ftadj(i, k) = em_ftadj(k) ! (dT/dt)_{LS adj} (K/s)
+      fqadj(i, k) = em_fradj(k) ! (dq/dt)_{LS adj} (kg/kg/s)
+      ifc(i, k) = em_ifc(k) ! flag convergence clouds_gno (1 ou 2)
+    END DO
+    pradj(i) = em_pradj ! precip from LS supersat adj (mm/day)
+
+    ! sb --
+
+    ! SB:
+    IF (iflag/=1 .AND. iflag/=4) THEN
+      em_cape = 0.
+      DO l = 1, klev
+        em_upwd(l) = 0.
+        em_dnwd(l) = 0.
+        em_dnwdbis(l) = 0.
+        emma(l) = 0.
+        em_tvp(l) = 0.
+      END DO
+    END IF
+    ! fin SB
+
+    ! If sig has been set to zero, then set Ma to zero
+
+    sigsum = 0.
+    DO k = 1, klev
+      sigsum = sigsum + em_work1(k)
+    END DO
+    IF (sigsum==0.0) THEN
+      DO k = 1, klev
+        emma(k) = 0.
+      END DO
+    END IF
+
+    ! sb3d       print*,'i, iflag=',i,iflag
+
+    ! cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+
+    ! SORTIE DES ICB ET INB
+    ! en fait inb et icb correspondent au niveau ou se trouve
+    ! le nuage,le numero d'interface
+    ! ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+
+    ! modif SB:
+    IF (iflag==1 .OR. iflag==4) THEN
+      top = em_top
+      bas = em_bas
+      kbas(i) = em_bas
+      ktop(i) = em_top
+    END IF
+
+    pbase(i) = em_pbase
+    bbase(i) = em_bbase
+    rain(i) = em_precip/86400.0
+    snow(i) = 0.0
+    cape(i) = em_cape
+    wd(i) = em_wd
+    rflag(i) = real(iflag)
+    ! SB      kbas(i) = em_bas
+    ! SB      ktop(i) = em_top
+    dplcldt(i) = em_dplcldt
+    dplcldr(i) = em_dplcldr
+    DO l = 1, klev
+      d_t2(i, l) = dtime*em_d_t2(l)
+      d_q2(i, l) = dtime*em_d_q2(l)
+      d_u2(i, l) = dtime*em_d_u2(l)
+      d_v2(i, l) = dtime*em_d_v2(l)
+
+      d_t(i, l) = dtime*em_d_t(l)
+      d_q(i, l) = dtime*em_d_q(l)
+      d_u(i, l) = dtime*em_d_u(l)
+      d_v(i, l) = dtime*em_d_v(l)
+      DO itra = 1, ntra
+        d_tra(i, l, itra) = dtime*em_d_tra(l, itra)
+      END DO
+      upwd(i, l) = em_upwd(l)
+      dnwd(i, l) = em_dnwd(l)
+      dnwdbis(i, l) = em_dnwdbis(l)
+      work1(i, l) = em_work1(l)
+      work2(i, l) = em_work2(l)
+      ma(i, l) = emma(l)
+      tvp(i, l) = em_tvp(l)
+      dtvpdt1(i, l) = em_dtvpdt1(l)
+      dtvpdq1(i, l) = em_dtvpdq1(l)
+
+      IF (iflag_clw==0) THEN
+        qcond_incld(i, l) = em_qcondc(l)
+      ELSE IF (iflag_clw==1) THEN
+        qcond_incld(i, l) = em_qcond(l)
+      END IF
+    END DO
+  END DO
+
+  ! On calcule une eau liquide diagnostique en fonction de la
+  ! precip.
+  IF (iflag_clw==2) THEN
+    DO l = 1, klev
+      DO i = 1, klon
+        IF (ktop(i)-kbas(i)>0 .AND. l>=kbas(i) .AND. l<=ktop(i)) THEN
+          qcond_incld(i, l) = rain(i)*8.E4 & ! s         *(pplay(i,l
+                                             ! )-paprs(i,ktop(i)+1))
+            /(pplay(i,kbas(i))-pplay(i,ktop(i)))
+          ! s         **2
+        ELSE
+          qcond_incld(i, l) = 0.
+        END IF
+      END DO
+      PRINT *, 'l=', l, ',   qcond_incld=', qcond_incld(1, l)
+    END DO
+  END IF
+
+
+  RETURN
+END SUBROUTINE conema3
+
Index: DZ6/trunk/libf/phylmd/conemav.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/conemav.F90	(revision 5267)
+++ 	(revision )
@@ -1,146 +1,0 @@
-
-! $Header$
-
-SUBROUTINE conemav(dtime, paprs, pplay, t, q, u, v, tra, ntra, work1, work2, &
-    d_t, d_q, d_u, d_v, d_tra, rain, snow, kbas, ktop, upwd, dnwd, dnwdbis, &
-    ma, cape, tvp, iflag, pbase, bbase, dtvpdt1, dtvpdq1, dplcldt, dplcldr)
-
-
-  USE dimphy
-  USE infotrac_phy, ONLY: nbtr
-  IMPLICIT NONE
-  ! ======================================================================
-  ! Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818
-  ! Objet: schema de convection de Emanuel (1991) interface
-  ! ======================================================================
-  ! Arguments:
-  ! dtime--input-R-pas d'integration (s)
-  ! s-------input-R-la valeur "s" pour chaque couche
-  ! sigs----input-R-la valeur "sigma" de chaque couche
-  ! sig-----input-R-la valeur de "sigma" pour chaque niveau
-  ! psolpa--input-R-la pression au sol (en Pa)
-  ! pskapa--input-R-exponentiel kappa de psolpa
-  ! h-------input-R-enthalpie potentielle (Cp*T/P**kappa)
-  ! q-------input-R-vapeur d'eau (en kg/kg)
-
-  ! work*: input et output: deux variables de travail,
-  ! on peut les mettre a 0 au debut
-  ! ALE-----input-R-energie disponible pour soulevement
-
-  ! d_h-----output-R-increment de l'enthalpie potentielle (h)
-  ! d_q-----output-R-increment de la vapeur d'eau
-  ! rain----output-R-la pluie (mm/s)
-  ! snow----output-R-la neige (mm/s)
-  ! upwd----output-R-saturated updraft mass flux (kg/m**2/s)
-  ! dnwd----output-R-saturated downdraft mass flux (kg/m**2/s)
-  ! dnwd0---output-R-unsaturated downdraft mass flux (kg/m**2/s)
-  ! Cape----output-R-CAPE (J/kg)
-  ! Tvp-----output-R-Temperature virtuelle d'une parcelle soulevee
-  ! adiabatiquement a partir du niveau 1 (K)
-  ! deltapb-output-R-distance entre LCL et base de la colonne (<0 ; Pa)
-  ! Ice_flag-input-L-TRUE->prise en compte de la thermodynamique de la glace
-  ! ======================================================================
-
-
-  REAL dtime, paprs(klon, klev+1), pplay(klon, klev)
-  REAL t(klon, klev), q(klon, klev), u(klon, klev), v(klon, klev)
-  REAL tra(klon, klev, nbtr)
-  INTEGER ntra
-  REAL work1(klon, klev), work2(klon, klev)
-
-  REAL d_t(klon, klev), d_q(klon, klev), d_u(klon, klev), d_v(klon, klev)
-  REAL d_tra(klon, klev, nbtr)
-  REAL rain(klon), snow(klon)
-
-  INTEGER kbas(klon), ktop(klon)
-  REAL em_ph(klon, klev+1), em_p(klon, klev)
-  REAL upwd(klon, klev), dnwd(klon, klev), dnwdbis(klon, klev)
-  REAL ma(klon, klev), cape(klon), tvp(klon, klev)
-  INTEGER iflag(klon)
-  REAL rflag(klon)
-  REAL pbase(klon), bbase(klon)
-  REAL dtvpdt1(klon, klev), dtvpdq1(klon, klev)
-  REAL dplcldt(klon), dplcldr(klon)
-
-  REAL zx_t, zdelta, zx_qs, zcor
-
-  INTEGER noff, minorig
-  INTEGER i, k, itra
-  REAL qs(klon, klev)
-  REAL, ALLOCATABLE, SAVE :: cbmf(:)
-  !$OMP THREADPRIVATE(cbmf)
-  INTEGER ifrst
-  SAVE ifrst
-  DATA ifrst/0/
-  !$OMP THREADPRIVATE(ifrst)
-  include "YOMCST.h"
-  include "YOETHF.h"
-  include "FCTTRE.h"
-
-
-  IF (ifrst==0) THEN
-    ifrst = 1
-    ALLOCATE (cbmf(klon))
-    DO i = 1, klon
-      cbmf(i) = 0.
-    END DO
-  END IF
-
-  DO k = 1, klev + 1
-    DO i = 1, klon
-      em_ph(i, k) = paprs(i, k)/100.0
-    END DO
-  END DO
-
-  DO k = 1, klev
-    DO i = 1, klon
-      em_p(i, k) = pplay(i, k)/100.0
-    END DO
-  END DO
-
-
-  DO k = 1, klev
-    DO i = 1, klon
-      zx_t = t(i, k)
-      zdelta = max(0., sign(1.,rtt-zx_t))
-      zx_qs = min(0.5, r2es*foeew(zx_t,zdelta)/em_p(i,k)/100.0)
-      zcor = 1./(1.-retv*zx_qs)
-      qs(i, k) = zx_qs*zcor
-    END DO
-  END DO
-
-  noff = 2
-  minorig = 2
-  CALL convect1(klon, klev, klev+1, noff, minorig, t, q, qs, u, v, em_p, &
-    em_ph, iflag, d_t, d_q, d_u, d_v, rain, cbmf, dtime, ma)
-
-  DO i = 1, klon
-    rain(i) = rain(i)/86400.
-    rflag(i) = iflag(i)
-  END DO
-  ! call dump2d(iim,jjm-1,rflag(2:klon-1),'FLAG CONVECTION   ')
-  ! if (klon.eq.1) then
-  ! print*,'IFLAG ',iflag
-  ! else
-  ! write(*,'(96i1)') (iflag(i),i=2,klon-1)
-  ! endif
-  DO k = 1, klev
-    DO i = 1, klon
-      d_t(i, k) = dtime*d_t(i, k)
-      d_q(i, k) = dtime*d_q(i, k)
-      d_u(i, k) = dtime*d_u(i, k)
-      d_v(i, k) = dtime*d_v(i, k)
-    END DO
-    DO itra = 1, ntra
-      DO i = 1, klon
-        d_tra(i, k, itra) = 0.
-      END DO
-    END DO
-  END DO
-
-
-
-
-  RETURN
-END SUBROUTINE conemav
-
Index: /LMDZ6/trunk/libf/phylmd/conemav.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/conemav.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/conemav.f90	(revision 5268)
@@ -0,0 +1,146 @@
+
+! $Header$
+
+SUBROUTINE conemav(dtime, paprs, pplay, t, q, u, v, tra, ntra, work1, work2, &
+    d_t, d_q, d_u, d_v, d_tra, rain, snow, kbas, ktop, upwd, dnwd, dnwdbis, &
+    ma, cape, tvp, iflag, pbase, bbase, dtvpdt1, dtvpdq1, dplcldt, dplcldr)
+
+
+  USE dimphy
+  USE infotrac_phy, ONLY: nbtr
+  IMPLICIT NONE
+  ! ======================================================================
+  ! Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818
+  ! Objet: schema de convection de Emanuel (1991) interface
+  ! ======================================================================
+  ! Arguments:
+  ! dtime--input-R-pas d'integration (s)
+  ! s-------input-R-la valeur "s" pour chaque couche
+  ! sigs----input-R-la valeur "sigma" de chaque couche
+  ! sig-----input-R-la valeur de "sigma" pour chaque niveau
+  ! psolpa--input-R-la pression au sol (en Pa)
+  ! pskapa--input-R-exponentiel kappa de psolpa
+  ! h-------input-R-enthalpie potentielle (Cp*T/P**kappa)
+  ! q-------input-R-vapeur d'eau (en kg/kg)
+
+  ! work*: input et output: deux variables de travail,
+  ! on peut les mettre a 0 au debut
+  ! ALE-----input-R-energie disponible pour soulevement
+
+  ! d_h-----output-R-increment de l'enthalpie potentielle (h)
+  ! d_q-----output-R-increment de la vapeur d'eau
+  ! rain----output-R-la pluie (mm/s)
+  ! snow----output-R-la neige (mm/s)
+  ! upwd----output-R-saturated updraft mass flux (kg/m**2/s)
+  ! dnwd----output-R-saturated downdraft mass flux (kg/m**2/s)
+  ! dnwd0---output-R-unsaturated downdraft mass flux (kg/m**2/s)
+  ! Cape----output-R-CAPE (J/kg)
+  ! Tvp-----output-R-Temperature virtuelle d'une parcelle soulevee
+  ! adiabatiquement a partir du niveau 1 (K)
+  ! deltapb-output-R-distance entre LCL et base de la colonne (<0 ; Pa)
+  ! Ice_flag-input-L-TRUE->prise en compte de la thermodynamique de la glace
+  ! ======================================================================
+
+
+  REAL dtime, paprs(klon, klev+1), pplay(klon, klev)
+  REAL t(klon, klev), q(klon, klev), u(klon, klev), v(klon, klev)
+  REAL tra(klon, klev, nbtr)
+  INTEGER ntra
+  REAL work1(klon, klev), work2(klon, klev)
+
+  REAL d_t(klon, klev), d_q(klon, klev), d_u(klon, klev), d_v(klon, klev)
+  REAL d_tra(klon, klev, nbtr)
+  REAL rain(klon), snow(klon)
+
+  INTEGER kbas(klon), ktop(klon)
+  REAL em_ph(klon, klev+1), em_p(klon, klev)
+  REAL upwd(klon, klev), dnwd(klon, klev), dnwdbis(klon, klev)
+  REAL ma(klon, klev), cape(klon), tvp(klon, klev)
+  INTEGER iflag(klon)
+  REAL rflag(klon)
+  REAL pbase(klon), bbase(klon)
+  REAL dtvpdt1(klon, klev), dtvpdq1(klon, klev)
+  REAL dplcldt(klon), dplcldr(klon)
+
+  REAL zx_t, zdelta, zx_qs, zcor
+
+  INTEGER noff, minorig
+  INTEGER i, k, itra
+  REAL qs(klon, klev)
+  REAL, ALLOCATABLE, SAVE :: cbmf(:)
+  !$OMP THREADPRIVATE(cbmf)
+  INTEGER ifrst
+  SAVE ifrst
+  DATA ifrst/0/
+  !$OMP THREADPRIVATE(ifrst)
+  include "YOMCST.h"
+  include "YOETHF.h"
+  include "FCTTRE.h"
+
+
+  IF (ifrst==0) THEN
+    ifrst = 1
+    ALLOCATE (cbmf(klon))
+    DO i = 1, klon
+      cbmf(i) = 0.
+    END DO
+  END IF
+
+  DO k = 1, klev + 1
+    DO i = 1, klon
+      em_ph(i, k) = paprs(i, k)/100.0
+    END DO
+  END DO
+
+  DO k = 1, klev
+    DO i = 1, klon
+      em_p(i, k) = pplay(i, k)/100.0
+    END DO
+  END DO
+
+
+  DO k = 1, klev
+    DO i = 1, klon
+      zx_t = t(i, k)
+      zdelta = max(0., sign(1.,rtt-zx_t))
+      zx_qs = min(0.5, r2es*foeew(zx_t,zdelta)/em_p(i,k)/100.0)
+      zcor = 1./(1.-retv*zx_qs)
+      qs(i, k) = zx_qs*zcor
+    END DO
+  END DO
+
+  noff = 2
+  minorig = 2
+  CALL convect1(klon, klev, klev+1, noff, minorig, t, q, qs, u, v, em_p, &
+    em_ph, iflag, d_t, d_q, d_u, d_v, rain, cbmf, dtime, ma)
+
+  DO i = 1, klon
+    rain(i) = rain(i)/86400.
+    rflag(i) = iflag(i)
+  END DO
+  ! call dump2d(iim,jjm-1,rflag(2:klon-1),'FLAG CONVECTION   ')
+  ! if (klon.eq.1) then
+  ! print*,'IFLAG ',iflag
+  ! else
+  ! write(*,'(96i1)') (iflag(i),i=2,klon-1)
+  ! endif
+  DO k = 1, klev
+    DO i = 1, klon
+      d_t(i, k) = dtime*d_t(i, k)
+      d_q(i, k) = dtime*d_q(i, k)
+      d_u(i, k) = dtime*d_u(i, k)
+      d_v(i, k) = dtime*d_v(i, k)
+    END DO
+    DO itra = 1, ntra
+      DO i = 1, klon
+        d_tra(i, k, itra) = 0.
+      END DO
+    END DO
+  END DO
+
+
+
+
+  RETURN
+END SUBROUTINE conemav
+
Index: DZ6/trunk/libf/phylmd/conf_phys_m.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/conf_phys_m.F90	(revision 5267)
+++ 	(revision )
@@ -1,2963 +1,0 @@
-!
-! $Id: conf_phys.F90 1668 2012-10-12 10:47:37Z idelkadi $
-!
-!
-!
-MODULE conf_phys_m
-
-  IMPLICIT NONE
-
-CONTAINS
-
-  SUBROUTINE conf_phys(ok_journe, ok_mensuel, ok_instan, ok_hf, &
-       ok_LES,&
-       callstats,&
-       solarlong0,seuil_inversion, &
-       fact_cldcon, facttemps,ok_newmicro,iflag_radia,&
-       iflag_cld_th, &
-       ratqsbas,ratqshaut,tau_ratqs, &
-       ok_ade, ok_aie, ok_alw, ok_cdnc, ok_volcan, flag_volc_surfstrat, aerosol_couple, & 
-       chemistry_couple, flag_aerosol, flag_aerosol_strat, flag_aer_feedback, &
-       flag_bc_internal_mixture, bl95_b0, bl95_b1,&
-       read_climoz, &
-       alp_offset)
-
-    USE IOIPSL
-    USE surface_data
-    USE phys_cal_mod
-    USE carbon_cycle_mod,  ONLY: carbon_cycle_tr, carbon_cycle_cpl, carbon_cycle_rad, level_coupling_esm
-    USE carbon_cycle_mod,  ONLY: read_fco2_ocean_cor,var_fco2_ocean_cor
-    USE carbon_cycle_mod,  ONLY: read_fco2_land_cor,var_fco2_land_cor
-    USE chemistry_cycle_mod, ONLY: dms_cycle_cpl, n2o_cycle_cpl
-    USE mod_grid_phy_lmdz, ONLY: klon_glo
-    USE print_control_mod, ONLY: lunout
-    use config_ocean_skin_m, only: config_ocean_skin
-    USE phys_state_var_mod, ONLY: phys_tstep
-    USE infotrac_phy, ONLY: type_trac
-    USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_STRATAER
-
-    INCLUDE "conema3.h"
-    INCLUDE "nuage.h"
-    INCLUDE "YOMCST.h"
-    INCLUDE "YOMCST2.h"
-    INCLUDE "alpale.h"
-
-    !IM : on inclut/initialise les taux de CH4, N2O, CFC11 et CFC12
-    INCLUDE "clesphys.h"
-    INCLUDE "compbl.h"
-    INCLUDE "comsoil.h"
-    INCLUDE "YOEGWD.h"
-    !
-    ! Configuration de la "physique" de LMDZ a l'aide de la fonction
-    ! GETIN de IOIPSL
-    !
-    ! LF 05/2001
-    !
-    ! type_ocean:      type d'ocean (force, slab, couple)
-    ! version_ocean:   version d'ocean (opa8/nemo pour type_ocean=couple ou 
-    !                                   sicOBS,sicINT,sicNO pour type_ocean=slab)
-    ! ok_veget:   type de modele de vegetation
-    ! ok_journe:  sorties journalieres
-    ! ok_hf:  sorties haute frequence
-    ! ok_mensuel: sorties mensuelles
-    ! ok_instan:  sorties instantanees
-    ! ok_ade, ok_aie: apply or not aerosol direct and indirect effects
-    ! ok_alw: activate aerosol LW effect
-    ! ok_cdnc, ok cloud droplet number concentration
-    ! flag_aerosol_strat : flag pour les aerosols stratos
-    ! flag_bc_internal_mixture : use BC internal mixture if true
-    ! bl95_b*: parameters in the formula to link CDNC to aerosol mass conc 
-    ! ok_volcan: activate volcanic diags (SW heat & LW cool rate, SW & LW flux)
-    ! flag_volc_surfstrat: VolMIP flag, activate forcing surface cooling rate (=1), strato heating rate (=2) or nothing (=0, default)
-    !
-
-    ! Sortie:
-    LOGICAL              :: ok_newmicro
-    INTEGER              :: iflag_radia
-    LOGICAL              :: ok_journe, ok_mensuel, ok_instan, ok_hf
-    LOGICAL              :: ok_LES
-    LOGICAL              :: callstats
-    LOGICAL              :: ok_ade, ok_aie, ok_alw, ok_cdnc, ok_volcan
-    LOGICAL              :: aerosol_couple, chemistry_couple
-    INTEGER              :: flag_aerosol
-    INTEGER              :: flag_aerosol_strat
-    INTEGER              :: flag_volc_surfstrat
-    LOGICAL              :: flag_aer_feedback
-    LOGICAL              :: flag_bc_internal_mixture
-    REAL                 :: bl95_b0, bl95_b1
-    REAL                 :: fact_cldcon, facttemps,ratqsbas,ratqshaut,tau_ratqs
-    INTEGER              :: iflag_cld_th
-     
-
-    CHARACTER (len = 6), SAVE  :: type_ocean_omp, version_ocean_omp, ocean_omp
-    CHARACTER (len = 10),SAVE  :: type_veget_omp
-    CHARACTER (len = 8), SAVE  :: aer_type_omp
-    INTEGER, SAVE       :: landice_opt_omp
-    INTEGER, SAVE       :: iflag_tsurf_inlandsis_omp,iflag_temp_inlandsis_omp
-    INTEGER, SAVE       :: iflag_albcalc_omp,iflag_z0m_snow_omp   
-    LOGICAL, SAVE       :: SnoMod_omp,BloMod_omp,ok_outfor_omp,ok_zsn_ii_omp
-    LOGICAL, SAVE       :: discret_xf_omp,opt_runoff_ac_omp  
-    LOGICAL, SAVE       :: is_ok_slush_omp,is_ok_z0h_rn_omp,is_ok_density_kotlyakov_omp
-    REAL, SAVE          :: prescribed_z0m_snow_omp,correc_alb_omp
-    REAL, SAVE          :: buf_sph_pol_omp,buf_siz_pol_omp
-    LOGICAL, SAVE       :: ok_newmicro_omp
-    LOGICAL, SAVE       :: ok_all_xml_omp
-    LOGICAL, SAVE       :: ok_lwoff_omp
-    LOGICAL, SAVE       :: ok_journe_omp, ok_mensuel_omp, ok_instan_omp, ok_hf_omp        
-    LOGICAL, SAVE       :: ok_LES_omp   
-    LOGICAL, SAVE       :: callstats_omp
-    LOGICAL, SAVE       :: ok_ade_omp, ok_aie_omp, ok_alw_omp, ok_cdnc_omp, ok_volcan_omp
-    LOGICAL, SAVE       :: aerosol_couple_omp, chemistry_couple_omp
-    INTEGER, SAVE       :: flag_aerosol_omp
-    INTEGER, SAVE       :: flag_aerosol_strat_omp
-    INTEGER, SAVE       :: flag_volc_surfstrat_omp
-    LOGICAL, SAVE       :: flag_aer_feedback_omp
-    LOGICAL, SAVE       :: flag_bc_internal_mixture_omp
-    REAL,SAVE           :: bl95_b0_omp, bl95_b1_omp
-    REAL,SAVE           :: freq_ISCCP_omp, ecrit_ISCCP_omp
-    REAL,SAVE           :: freq_COSP_omp, freq_AIRS_omp 
-    REAL,SAVE           :: fact_cldcon_omp, facttemps_omp,ratqsbas_omp
-    REAL,SAVE           :: tau_cld_cv_omp, coefw_cld_cv_omp
-    INTEGER, SAVE       :: iflag_cld_cv_omp
-
-    REAL, SAVE          :: ratqshaut_omp
-    REAL, SAVE          :: tau_ratqs_omp
-    REAL, SAVE          :: t_coupl_omp
-    INTEGER, SAVE       :: iflag_radia_omp
-    INTEGER, SAVE       :: iflag_rrtm_omp
-    INTEGER, SAVE       :: iflag_albedo_omp !albedo SB
-    LOGICAL, SAVE       :: ok_chlorophyll_omp ! albedo SB  
-    INTEGER, SAVE       :: NSW_omp
-    INTEGER, SAVE       :: iflag_cld_th_omp, ip_ebil_phy_omp
-    INTEGER, SAVE       :: iflag_ratqs_omp
-
-    REAL, SAVE          :: f_cdrag_ter_omp,f_cdrag_oce_omp
-    REAL, SAVE          :: f_rugoro_omp   , z0min_omp
-    REAL, SAVE          :: z0m_seaice_omp,z0h_seaice_omp
-    REAL, SAVE          :: z0m_landice_omp,z0h_landice_omp
-    REAL, SAVE          :: min_wind_speed_omp,f_gust_wk_omp,f_gust_bl_omp,f_qsat_oce_omp, f_z0qh_oce_omp
-    INTEGER, SAVE       :: iflag_gusts_omp,iflag_z0_oce_omp
-
-    REAL :: seuil_inversion
-    REAL,SAVE :: seuil_inversion_omp
-
-    INTEGER,SAVE :: iflag_thermals_omp,nsplit_thermals_omp
-    REAL,SAVE :: tau_thermals_omp,alp_bl_k_omp
-    ! nrlmd le 10/04/2012
-    INTEGER,SAVE :: iflag_trig_bl_omp,iflag_clos_bl_omp,iflag_strig_omp
-    INTEGER,SAVE :: tau_trig_shallow_omp,tau_trig_deep_omp
-    REAL,SAVE    :: s_trig_omp,h_trig_omp
-    ! fin nrlmd le 10/04/2012
-    REAL :: alp_offset
-    REAL, SAVE :: alp_offset_omp
-    INTEGER,SAVE :: iflag_coupl_omp,iflag_clos_omp,iflag_wake_omp
-    INTEGER,SAVE :: iflag_cvl_sigd_omp
-    REAL, SAVE :: coef_clos_ls_omp
-    REAL, SAVE :: supcrit1_omp, supcrit2_omp
-    INTEGER, SAVE :: iflag_mix_omp
-    INTEGER, SAVE :: iflag_mix_adiab_omp
-    REAL, SAVE :: scut_omp, qqa1_omp, qqa2_omp, gammas_omp, Fmax_omp, alphas_omp
-    REAL, SAVE :: tmax_fonte_cv_omp
-
-    REAL,SAVE :: R_ecc_omp,R_peri_omp,R_incl_omp,solaire_omp
-    REAL,SAVE :: solaire_omp_init
-    LOGICAL,SAVE :: ok_suntime_rrtm_omp
-    REAL,SAVE :: co2_ppm_omp, RCO2_omp, co2_ppm_per_omp, RCO2_per_omp
-    REAL,SAVE :: co2_ppm0_omp
-    REAL,SAVE :: CH4_ppb_omp, RCH4_omp, CH4_ppb_per_omp, RCH4_per_omp
-    REAL,SAVE :: N2O_ppb_omp, RN2O_omp, N2O_ppb_per_omp, RN2O_per_omp
-    REAL,SAVE :: CFC11_ppt_omp,RCFC11_omp,CFC11_ppt_per_omp,RCFC11_per_omp
-    REAL,SAVE :: CFC12_ppt_omp,RCFC12_omp,CFC12_ppt_per_omp,RCFC12_per_omp
-    REAL,SAVE :: epmax_omp
-    REAL,SAVE :: coef_epmax_cape_omp
-    LOGICAL,SAVE :: ok_adj_ema_omp
-    INTEGER,SAVE :: iflag_clw_omp
-    INTEGER,SAVE :: iflag_ice_thermo_omp
-    LOGICAL,SAVE :: ok_ice_supersat_omp
-    LOGICAL,SAVE :: ok_plane_h2o_omp, ok_plane_contrail_omp
-    REAL,SAVE :: rad_froid_omp, rad_chau1_omp, rad_chau2_omp
-    INTEGER,SAVE :: iflag_sic_omp, iflag_inertie_omp
-    REAL,SAVE :: inertie_sol_omp,inertie_sno_omp,inertie_sic_omp
-    REAL,SAVE :: inertie_lic_omp
-    REAL,SAVE :: qsol0_omp
-    REAL,SAVE :: evap0_omp
-    REAL,SAVE :: albsno0_omp
-    REAL      :: solarlong0
-    REAL,SAVE :: solarlong0_omp
-    INTEGER,SAVE :: top_height_omp,overlap_omp
-    REAL,SAVE :: cdmmax_omp,cdhmax_omp,ksta_omp,ksta_ter_omp,f_ri_cd_min_omp
-    LOGICAL,SAVE :: ok_kzmin_omp
-    REAL, SAVE ::  fmagic_omp, pmagic_omp
-    INTEGER,SAVE :: iflag_pbl_omp,lev_histhf_omp,lev_histday_omp,lev_histmth_omp
-    INTEGER,SAVE :: iflag_pbl_split_omp,iflag_physiq_omp
-!FC
-    INTEGER,SAVE :: ifl_pbltree_omp
-    REAL,SAVE :: Cd_frein_omp
-!FC
-    INTEGER,SAVE :: iflag_order2_sollw_omp
-    INTEGER, SAVE :: lev_histins_omp, lev_histLES_omp 
-    INTEGER, SAVE :: lev_histdayNMC_omp
-    INTEGER, SAVE :: levout_histNMC_omp(3)
-    LOGICAL, SAVE :: ok_histNMC_omp(3)
-    REAL, SAVE    :: freq_outNMC_omp(3), freq_calNMC_omp(3)
-    CHARACTER*4, SAVE :: type_run_omp
-    LOGICAL, SAVE :: ok_cosp_omp, ok_airs_omp
-    LOGICAL, SAVE :: ok_mensuelCOSP_omp,ok_journeCOSP_omp,ok_hfCOSP_omp
-    REAL, SAVE    :: lonmin_ins_omp, lonmax_ins_omp, latmin_ins_omp, latmax_ins_omp
-    REAL, SAVE    :: ecrit_hf_omp, ecrit_day_omp, ecrit_mth_omp, ecrit_reg_omp
-    REAL, SAVE    :: ecrit_ins_omp
-    REAL, SAVE    :: ecrit_LES_omp
-    REAL, SAVE    :: ecrit_tra_omp
-    REAL, SAVE    :: cvl_comp_threshold_omp
-    REAL, SAVE    :: cvl_sig2feed_omp
-    REAL, SAVE    :: cvl_corr_omp
-    LOGICAL, SAVE :: ok_lic_melt_omp
-    LOGICAL, SAVE :: ok_lic_cond_omp
-    !
-    REAL, SAVE    :: zrel_oro_t_omp, zstd_orodr_t_omp
-    REAL, SAVE    :: zpmm_orodr_t_omp, zpmm_orolf_t_omp
-    INTEGER, SAVE :: iflag_cycle_diurne_omp
-    LOGICAL, SAVE :: soil_model_omp,new_oliq_omp
-    LOGICAL, SAVE :: ok_orodr_omp, ok_orolf_omp, ok_limitvrai_omp
-    INTEGER, SAVE :: nbapp_rad_omp, iflag_con_omp
-    INTEGER, SAVE :: nbapp_cv_omp, nbapp_wk_omp
-    INTEGER, SAVE :: iflag_ener_conserv_omp
-    LOGICAL, SAVE :: ok_conserv_q_omp
-    LOGICAL,SAVE  :: ok_strato_omp
-    LOGICAL,SAVE  :: ok_hines_omp, ok_gwd_rando_omp
-    REAL, SAVE    :: gwd_rando_ruwmax_omp, gwd_rando_sat_omp
-    REAL, SAVE    :: gwd_front_ruwmax_omp, gwd_front_sat_omp
-    REAL, SAVE    :: sso_gkdrag_omp,sso_grahil_omp,sso_grcrit_omp
-    REAL, SAVE    :: sso_gfrcri_omp,sso_gkwake_omp,sso_gklift_omp
-    LOGICAL, SAVE :: ok_qch4_omp
-    LOGICAL, SAVE :: carbon_cycle_tr_omp
-    LOGICAL, SAVE :: carbon_cycle_cpl_omp
-    LOGICAL, SAVE :: carbon_cycle_rad_omp
-    LOGICAL, SAVE :: dms_cycle_cpl_omp, n2o_cycle_cpl_omp
-    INTEGER, SAVE :: level_coupling_esm_omp
-    LOGICAL, SAVE :: read_fco2_ocean_cor_omp
-    REAL, SAVE    :: var_fco2_ocean_cor_omp
-    LOGICAL, SAVE :: read_fco2_land_cor_omp
-    REAL, SAVE    :: var_fco2_land_cor_omp
-    LOGICAL, SAVE :: adjust_tropopause_omp
-    LOGICAL, SAVE :: ok_daily_climoz_omp
-    LOGICAL, SAVE :: ok_new_lscp_omp
-    LOGICAL, SAVE :: ok_icefra_lscp_omp
-    !rajout de choix_bulk et nit_bulk par Olivier Torres
-    INTEGER,SAVE  :: choix_bulk_omp
-    INTEGER,SAVE  :: nit_bulk_omp
-    INTEGER,SAVE  :: kz0_omp
-    LOGICAL, SAVE :: ok_bs_omp, ok_rad_bs_omp
-
-
-    INTEGER, INTENT(OUT):: read_climoz ! read ozone climatology, OpenMP shared
-    ! Allowed values are 0, 1 and 2
-    ! 0: do not read an ozone climatology
-    ! 1: read a single ozone climatology that will be used day and night
-    ! 2: read two ozone climatologies, the average day and night
-    ! climatology and the daylight climatology
-
-    !-----------------------------------------------------------------
-
-    print*,'CONFPHYS ENTREE'
-    !$OMP MASTER 
-    !Config Key  = type_ocean 
-    !Config Desc = Type d'ocean
-    !Config Def  = force
-    !Config Help = Type d'ocean utilise: force, slab,couple
-    !
-    type_ocean_omp = 'force '
-    CALL getin('type_ocean', type_ocean_omp)
-    !
-    !Config Key  = version_ocean 
-    !Config Desc = Version d'ocean
-    !Config Def  = xxxxxx
-    !Config Help = Version d'ocean utilise: opa8/nemo/sicOBS/xxxxxx
-    !
-    version_ocean_omp = 'xxxxxx'
-    CALL getin('version_ocean', version_ocean_omp)
-
-    !Config Key  = OCEAN
-    !Config Desc = Old parameter name for type_ocean
-    !Config Def  = yyyyyy
-    !Config Help = This is only for testing purpose
-    !
-    ocean_omp = 'yyyyyy'
-    CALL getin('OCEAN', ocean_omp)
-    IF (ocean_omp /= 'yyyyyy') THEN
-       WRITE(lunout,*)'ERROR! Old variable name OCEAN used in parmeter file.'
-       WRITE(lunout,*)'Variable OCEAN has been replaced by the variable type_ocean.'
-       WRITE(lunout,*)'You have to update your parameter file physiq.def to succed running'
-       CALL abort_physic('conf_phys','Variable OCEAN no longer existing, use variable name type_ocean',1)
-    ENDIF
-
-    !Config Key  = t_coupl
-    !Config Desc = Pas de temps du couplage atm/oce en sec.
-    !Config Def  = 86400
-    !Config Help = This is only for testing purpose
-    !
-    t_coupl_omp = 86400.
-    CALL getin('t_coupl', t_coupl_omp)
-    IF (t_coupl_omp == 0) THEN
-       WRITE(lunout,*)'ERROR! Timestep of coupling between atmosphere and ocean'
-       WRITE(lunout,*)'cannot be zero.'
-       CALL abort_physic('conf_phys','t_coupl = 0.',1)
-    ENDIF
-
-    !
-    !Config Key  = ok_all_xml 
-    !Config Desc = utiliser les xml pourles définitions des champs pour xios
-    !Config Def  = .FALSE.
-    !Config Help = 
-    !
-    ok_all_xml_omp = .FALSE.
-    CALL getin('ok_all_xml', ok_all_xml_omp)
-
-    !
-    !Config Key  = ok_lwoff
-    !Config Desc = inhiber l effet radiatif LW des nuages
-    !Config Def  = .FALSE.
-    !Config Help = 
-    !
-    ok_lwoff_omp = .FALSE.
-    CALL getin('ok_lwoff', ok_lwoff_omp)
-    !
-
-    !
-    !Config Key  = VEGET 
-    !Config Desc = Type de modele de vegetation
-    !Config Def  = .FALSE.
-    !Config Help = Type de modele de vegetation utilise
-    !
-    type_veget_omp ='orchidee'
-    CALL getin('VEGET', type_veget_omp)
-    !
-
-    ! INLANDSIS
-    !==================================================================
-    ! Martin et Etienne
-    !Config Key  = landice_opt
-    !Config Desc = which landice snow model (BULK, or INLANDSIS)
-    !Config Def  = 0
-    landice_opt_omp = 0
-    CALL getin('landice_opt', landice_opt_omp)
-    ! Martin et Etienne
-
-    !Etienne
-    !Config Key  = iflag_temp_inlandsis
-    !Config Desc = which method to calculate temp within the soil in INLANDSIS
-    !Config Def  = 0
-    iflag_temp_inlandsis_omp = 0
-    CALL getin('iflag_temp_inlandsis', iflag_temp_inlandsis_omp)
-
-    !Etienne
-    !Config Key  = iflag_tsurf_inlandsis
-    !Config Desc = which method to calculate tsurf in INLANDSIS
-    !Config Def  = 0
-    iflag_tsurf_inlandsis_omp = 1
-    CALL getin('iflag_tsurf_inlandsis', iflag_tsurf_inlandsis_omp)
-
-
-    !Etienne
-    !Config Key  = iflag_albcalc
-    !Config Desc = method to calculate snow albedo in INLANDSIS
-    !Config Def  = 0
-    iflag_albcalc_omp = 0
-    CALL getin('iflag_albcalc', iflag_albcalc_omp)
-
-
-    !Etienne
-    !Config Key  = SnoMod
-    !Config Desc = activation of snow modules in inlandsis
-    !Config Def  = .TRUE.
-    SnoMod_omp = .TRUE.
-    CALL getin('SnoMod', SnoMod_omp)
-
-    !Etienne
-    !Config Key  = BloMod
-    !Config Desc = activation of blowing snow in inlandsis
-    !Config Def  = .FALSE.
-    BloMod_omp = .FALSE.
-    CALL getin('BloMod', BloMod_omp)
-
-    !Etienne
-    !Config Key  = ok_outfor
-    !Config Desc = activation of output ascii file in inlandsis
-    !Config Def  = .FALSE.
-    ok_outfor_omp = .FALSE.
-    CALL getin('ok_outfor', ok_outfor_omp)
-
-
-    !Etienne
-    !Config Key  = ok_sn_ii
-    !Config Desc = activation of ice/snow detection
-    !Config Def  = .TRUE.
-    ok_zsn_ii_omp = .TRUE.
-    CALL getin('ok_zsn_ii', ok_zsn_ii_omp)
-
-
-    !Etienne
-    !Config Key  = discret_xf
-    !Config Desc = snow discretization following XF
-    !Config Def  = .TRUE.
-    discret_xf_omp = .TRUE.
-    CALL getin('discret_xf', discret_xf_omp)
-
-
-    !Etienne
-    !Config Key  = is_ok_slush
-    !Config Desc = activation of the slush option
-    !Config Def  = .TRUE.
-    is_ok_slush_omp = .TRUE.
-    CALL getin('is_ok_slush', is_ok_slush_omp)
-
-    !Etienne
-    !Config Key  = opt_runoff_ac
-    !Config Desc = option runoff AC
-    !Config Def  = .TRUE.
-    opt_runoff_ac_omp = .TRUE.
-    CALL getin('opt_runoff_ac', opt_runoff_ac_omp)
-
-    !Etienne
-    !Config Key  = is_ok_z0h_rn
-    !Config Desc = z0h calculation following RN method
-    !Config Def  = .TRUE.
-    is_ok_z0h_rn_omp = .TRUE.
-    CALL getin('is_ok_z0h_rn', is_ok_z0h_rn_omp)
-
-
-    !Etienne
-    !Config Key  = is_ok_density_kotlyakov
-    !Config Desc = snow density calculation following kotlyakov
-    !Config Def  = .FALSE.
-    is_ok_density_kotlyakov_omp = .FALSE.
-    CALL getin('is_ok_density_kotlyakov', is_ok_density_kotlyakov_omp)
-
-
-    !Etienne
-    !Config Key  = prescribed_z0m_snow
-    !Config Desc = prescribed snow z0m
-    !Config Def  = 0.005
-    prescribed_z0m_snow_omp = 0.005
-    CALL getin('prescribed_z0m_snow', prescribed_z0m_snow_omp)
-
-
-    !Etienne
-    !Config Key  = iflag_z0m_snow
-    !Config Desc = method to calculate snow z0m
-    !Config Def  = 0
-    iflag_z0m_snow_omp = 0
-    CALL getin('iflag_z0m_snow', iflag_z0m_snow_omp)
-
-
-    !Etienne
-    !Config Key  = correc_alb
-    !Config Desc = correction term for albedo
-    !Config Def  = 1.01
-    correc_alb_omp=1.01
-    CALL getin('correc_alb', correc_alb_omp)
-
-
-    !Etienne
-    !Config Key  = buf_sph_pol
-    !Config Desc = sphericity of buffer layer in polar regions
-    !Config Def  = 99.
-    buf_sph_pol_omp=99.
-    CALL getin('buf_sph_pol', buf_sph_pol_omp)
-
-    !Etienne
-    !Config Key  = buf_siz_pol
-    !Config Desc = grain size of buffer layer in polar regions in e-4m
-    !Config Def  = 4.
-    buf_siz_pol_omp=4.
-    CALL getin('buf_siz_pol', buf_siz_pol_omp)
-
-    !==================================================================
-    
-    !Config Key  = OK_journe
-    !Config Desc = Pour des sorties journalieres 
-    !Config Def  = .FALSE.
-    !Config Help = Pour creer le fichier histday contenant les sorties
-    !              journalieres 
-    !
-    ok_journe_omp = .FALSE.
-    CALL getin('OK_journe', ok_journe_omp)
-    !
-    !Config Key  = ok_hf
-    !Config Desc = Pour des sorties haute frequence
-    !Config Def  = .FALSE.
-    !Config Help = Pour creer le fichier histhf contenant les sorties
-    !              haute frequence ( 3h ou 6h)
-    !
-    ok_hf_omp = .FALSE.
-    CALL getin('ok_hf', ok_hf_omp)
-    !
-    !Config Key  = OK_mensuel
-    !Config Desc = Pour des sorties mensuelles 
-    !Config Def  = .TRUE.
-    !Config Help = Pour creer le fichier histmth contenant les sorties
-    !              mensuelles 
-    !
-    ok_mensuel_omp = .TRUE.
-    CALL getin('OK_mensuel', ok_mensuel_omp)
-    !
-    !Config Key  = OK_instan
-    !Config Desc = Pour des sorties instantanees 
-    !Config Def  = .FALSE.
-    !Config Help = Pour creer le fichier histins contenant les sorties
-    !              instantanees 
-    !
-    ok_instan_omp = .FALSE.
-    CALL getin('OK_instan', ok_instan_omp)
-    !
-    !Config Key  = ok_ade
-    !Config Desc = Aerosol direct effect or not?
-    !Config Def  = .FALSE.
-    !Config Help = Used in radlwsw.F
-    !
-    ok_ade_omp = .FALSE.
-    CALL getin('ok_ade', ok_ade_omp)
-
-    !Config Key  = ok_alw
-    !Config Desc = Aerosol longwave effect or not?
-    !Config Def  = .FALSE.
-    !Config Help = Used in radlwsw.F
-    !
-    ok_alw_omp = .FALSE.
-    CALL getin('ok_alw', ok_alw_omp)
-
-    !
-    !Config Key  = ok_aie
-    !Config Desc = Aerosol indirect effect or not?
-    !Config Def  = .FALSE.
-    !Config Help = Used in nuage.F and radlwsw.F
-    !
-    ok_aie_omp = .FALSE.
-    CALL getin('ok_aie', ok_aie_omp)
-
-    !
-    !Config Key  = ok_cdnc
-    !Config Desc = ok cloud droplet number concentration
-    !Config Def  = .FALSE.
-    !Config Help = Used in newmicro.F
-    !
-    ok_cdnc_omp = .FALSE.
-    CALL getin('ok_cdnc', ok_cdnc_omp)
-
-    !
-    !Config Key  = ok_volcan
-    !Config Desc = ok to generate volcanic diags
-    !Config Def  = .FALSE.
-    !Config Help = Used in radlwsw_m.F
-    !
-    ok_volcan_omp = .FALSE.
-    CALL getin('ok_volcan', ok_volcan_omp)
-
-    !
-    !Config Key  = flag_volc_surfstrat
-    !Config Desc = impose cooling rate at the surface (=1),
-    !              heating rate in the strato (=2), or nothing (=0)
-    !Config Def  = 0
-    !Config Help = Used in radlwsw_m.F
-    !
-    flag_volc_surfstrat_omp = 0 ! NL: SURFSTRAT
-    CALL getin('flag_volc_surfstrat', flag_volc_surfstrat_omp) 
-
-    !
-    !Config Key  = aerosol_couple
-    !Config Desc = read aerosol in file or calcul by inca
-    !Config Def  = .FALSE.
-    !Config Help = Used in physiq.F
-    !
-    aerosol_couple_omp = .FALSE.
-    CALL getin('aerosol_couple',aerosol_couple_omp)
-    !
-    !Config Key  = chemistry_couple
-    !Config Desc = read O3 chemistry in file or calcul by inca
-    !Config Def  = .FALSE.
-    !Config Help = Used in physiq.F
-    !
-    chemistry_couple_omp = .FALSE.
-    CALL getin('chemistry_couple',chemistry_couple_omp)
-    !
-    !Config Key  = flag_aerosol
-    !Config Desc = which aerosol is use for coupled model
-    !Config Def  = 1
-    !Config Help = Used in physiq.F
-    !
-    ! - flag_aerosol=0 => no aerosol
-    ! - flag_aerosol=1 => so4 only (defaut) 
-    ! - flag_aerosol=2 => bc  only 
-    ! - flag_aerosol=3 => pom only
-    ! - flag_aerosol=4 => seasalt only 
-    ! - flag_aerosol=5 => dust only
-    ! - flag_aerosol=6 => all aerosol
-    ! - flag_aerosol=7 => natural aerosol + MACv2SP
-    ! - (in this case aerosols.1980.nc should point to aerosols.nat.nc)
-
-    flag_aerosol_omp = 0
-    CALL getin('flag_aerosol',flag_aerosol_omp)
-
-    !
-    !Config Key  = flag_bc_internal_mixture
-    !Config Desc = state of mixture for BC aerosols
-    ! - n = external mixture
-    ! - y = internal mixture
-    !Config Def  = n
-    !Config Help = Used in physiq.F / aeropt
-    !
-    flag_bc_internal_mixture_omp = .FALSE.
-    CALL getin('flag_bc_internal_mixture',flag_bc_internal_mixture_omp)
-
-    ! 
-    !Config Key  = aer_type 
-    !Config Desc = Use a constant field for the aerosols 
-    !Config Def  = scenario 
-    !Config Help = Used in readaerosol.F90 
-    ! 
-    aer_type_omp = 'scenario' 
-    CALL getin('aer_type', aer_type_omp) 
-
-    !
-    !Config Key  = bl95_b0
-    !Config Desc = Parameter in CDNC-maer link (Boucher&Lohmann 1995)
-    !Config Def  = .FALSE.
-    !Config Help = Used in nuage.F
-    !
-    bl95_b0_omp = 2.
-    CALL getin('bl95_b0', bl95_b0_omp)
-
-    !Config Key  = bl95_b1
-    !Config Desc = Parameter in CDNC-maer link (Boucher&Lohmann 1995)
-    !Config Def  = .FALSE.
-    !Config Help = Used in nuage.F
-    !
-    bl95_b1_omp = 0.2
-    CALL getin('bl95_b1', bl95_b1_omp)
-
-    !Config Key  = freq_ISCCP
-    !Config Desc = Frequence d'appel du simulateur ISCCP en secondes;
-    !              par defaut 10800, i.e. 3 heures 
-    !Config Def  = 10800.
-    !Config Help = Used in ini_histISCCP.h
-    !
-    freq_ISCCP_omp = 10800.
-    CALL getin('freq_ISCCP', freq_ISCCP_omp)
-    !
-    !Config Key  = ecrit_ISCCP
-    !Config Desc = Frequence d'ecriture des resultats du simulateur ISCCP en nombre de jours;
-    !              par defaut 1., i.e. 1 jour
-    !Config Def  = 1.
-    !Config Help = Used in ini_histISCCP.h
-    !
-    !
-    ecrit_ISCCP_omp = 1.
-    CALL getin('ecrit_ISCCP', ecrit_ISCCP_omp)
-
-    !Config Key  = freq_COSP
-    !Config Desc = Frequence d'appel du simulateur COSP en secondes;
-    !              par defaut 10800, i.e. 3 heures
-    !Config Def  = 10800.
-    !Config Help = Used in ini_histdayCOSP.h
-    !
-    freq_COSP_omp = 10800.
-    CALL getin('freq_COSP', freq_COSP_omp)
-
-    !Config Key  = freq_AIRS
-    !Config Desc = Frequence d'appel du simulateur AIRS en secondes;
-    !              par defaut 10800, i.e. 3 heures
-    !Config Def  = 10800.
-    !Config Help = Used in ini_histdayAIRS.h
-    !
-    freq_AIRS_omp = 10800.
-    CALL getin('freq_AIRS', freq_AIRS_omp)
-
-    !
-    !Config Key  = ip_ebil_phy
-    !Config Desc = Niveau de sortie pour les diags bilan d'energie 
-    !Config Def  = 0
-    !Config Help = 
-    !               
-    ip_ebil_phy_omp = 0
-    CALL getin('ip_ebil_phy', ip_ebil_phy_omp)
-    IF (ip_ebil_phy_omp/=0) THEN
-       CALL abort_physic('conf_phys','ip_ebil_phy_omp doit etre 0 sur cette version',1)
-    ENDIF
-
-    !
-    !Config Key  = seuil_inversion
-    !Config Desc = Seuil ur dTh pour le choix entre les schemas de CL
-    !Config Def  = -0.1
-    !Config Help = 
-    !               
-    seuil_inversion_omp = -0.1
-    CALL getin('seuil_inversion', seuil_inversion_omp)
-
-    !
-    ! Constante solaire & Parametres orbitaux & taux gaz effet de serre BEG
-    !
-    !Config Key  = R_ecc
-    !Config Desc = Excentricite
-    !Config Def  = 0.016715
-    !Config Help = 
-    !               
-    !valeur AMIP II
-    R_ecc_omp = 0.016715
-    CALL getin('R_ecc', R_ecc_omp)
-    !
-    !Config Key  = R_peri
-    !Config Desc = Equinoxe
-    !Config Def  = 
-    !Config Help = 
-    !               
-    !
-    !valeur AMIP II
-    R_peri_omp = 102.7
-    CALL getin('R_peri', R_peri_omp)
-    !
-    !Config Key  = R_incl
-    !Config Desc = Inclinaison
-    !Config Def  = 
-    !Config Help = 
-    !               
-    !
-    !valeur AMIP II
-    R_incl_omp = 23.441
-    CALL getin('R_incl', R_incl_omp)
-    !
-    !Config Key  = solaire
-    !Config Desc = Constante solaire en W/m2
-    !Config Def  = 1365.
-    !Config Help = 
-    !               
-    !
-    !valeur AMIP II
-    solaire_omp = 1365.
-    solaire_omp_init = solaire_omp     !--we keep track of the default value
-    CALL getin('solaire', solaire_omp)
-    !
-    !Config Key  = co2_ppm
-    !Config Desc = concentration du CO2 en ppmv
-    !Config Def  = 348.
-    !Config Help = 
-    !               
-    !valeur AMIP II
-    co2_ppm_omp = 348.
-    CALL getin('co2_ppm', co2_ppm_omp)
-    !
-    !conversion en rapport de mélange massique
-    RCO2_omp = co2_ppm_omp * 1.0e-06 * RMCO2 / RMD
-
-    !
-    !Config Key  = co2_ppm0
-    !Config Desc = concentration initiale du CO2 en ppmv pour la version ESM avec CO2 interactif dans le cas 
-    !              où cette concentration de figure pas dans l'état de redémarrage de la physique
-    !Config Def  = 284.32
-    !Config Help = 
-    !               
-    co2_ppm0_omp = 284.32
-    CALL getin('co2_ppm0', co2_ppm0_omp)
-    !
-    !Config Key  = RCH4
-    !Config Desc = Concentration du CH4
-    !Config Def  = 1.65E-06* 16.043/28.97
-    !Config Help = 
-    !               
-    CH4_ppb_omp = 1650.
-    CALL getin('CH4_ppb', CH4_ppb_omp)
-    !conversion en rapport de mélange massique
-    RCH4_omp = CH4_ppb_omp * 1.0E-09 * RMCH4 / RMD
-    !
-    !Config Key  = RN2O
-    !Config Desc = Concentration du N2O
-    !Config Def  = 306.E-09* 44.013/28.97
-    !Config Help = 
-    !               
-    N2O_ppb_omp = 306.
-    CALL getin('N2O_ppb', N2O_ppb_omp)
-    !conversion en rapport de mélange massique
-    RN2O_omp = N2O_ppb_omp * 1.0E-09 * RMN2O / RMD
-    !
-    !Config Key  = RCFC11
-    !Config Desc = Concentration du CFC11
-    !Config Def  = 280.E-12* 137.3686/28.97
-    !Config Help = 
-    !               
-    CFC11_ppt_omp = 280.
-    CALL getin('CFC11_ppt',CFC11_ppt_omp)
-    !conversion en rapport de mélange massique
-    RCFC11_omp=CFC11_ppt_omp* 1.0E-12 * RMCFC11 / RMD
-    !
-    !Config Key  = RCFC12
-    !Config Desc = Concentration du CFC12
-    !Config Def  = 484.E-12* 120.9140/28.97
-    !Config Help = 
-    !               
-    CFC12_ppt_omp = 484.
-    CALL getin('CFC12_ppt',CFC12_ppt_omp)
-    !conversion en rapport de mélange massique
-    RCFC12_omp = CFC12_ppt_omp * 1.0E-12 * RMCFC12 / RMD
-
-    !
-    !Config Key  = co2_ppm_per
-    !Config Desc = concentration du CO2 perturbé en ppmv (CFMIP)
-    !Config Def  = 348.
-    !Config Help = 
-    !               
-    co2_ppm_per_omp = co2_ppm_omp
-    CALL getin('co2_ppm_per', co2_ppm_per_omp)
-    !conversion en rapport de mélange massique
-    RCO2_per_omp = co2_ppm_per_omp * 1.0e-06 * RMCO2 / RMD
-
-    !Config Key  = RCH4_per
-    !Config Desc = Concentration du CH4_per
-    !Config Def  = 1.65E-06* 16.043/28.97
-    !Config Help = 
-    !               
-    CH4_ppb_per_omp = CH4_ppb_omp
-    CALL getin('CH4_ppb_per', CH4_ppb_per_omp)
-    !conversion en rapport de mélange massique
-    RCH4_per_omp = CH4_ppb_per_omp * 1.0E-09 * RMCH4 / RMD
-    !
-    !Config Key  = RN2O_per
-    !Config Desc = Concentration du N2O_per
-    !Config Def  = 306.E-09* 44.013/28.97
-    !Config Help = 
-    !               
-    N2O_ppb_per_omp = N2O_ppb_omp
-    CALL getin('N2O_ppb_per', N2O_ppb_per_omp)
-    !conversion en rapport de mélange massique
-    RN2O_per_omp = N2O_ppb_per_omp * 1.0E-09 * RMN2O / RMD
-    !
-    !Config Key  = RCFC11_per
-    !Config Desc = Concentration du CFC11_per
-    !Config Def  = 280.E-12* 137.3686/28.97
-    !Config Help = 
-    !               
-    CFC11_ppt_per_omp = CFC11_ppt_omp
-    CALL getin('CFC11_ppt_per',CFC11_ppt_per_omp)
-    !conversion en rapport de mélange massique
-    RCFC11_per_omp=CFC11_ppt_per_omp* 1.0E-12 * RMCFC11 / RMD
-    !
-    !Config Key  = RCFC12_per
-    !Config Desc = Concentration du CFC12_per
-    !Config Def  = 484.E-12* 120.9140/28.97
-    !Config Help = 
-    !               
-    CFC12_ppt_per_omp = CFC12_ppt_omp
-    CALL getin('CFC12_ppt_per',CFC12_ppt_per_omp)
-    !conversion en rapport de mélange massique
-    RCFC12_per_omp = CFC12_ppt_per_omp * 1.0E-12 * RMCFC12 / RMD
-
-    !
-    ! FH 2008/05/09 On elimine toutes les clefs physiques dans la dynamique
-    ! Constantes precedemment dans dyn3d/conf_gcm
-
-    !Config  Key  = iflag_cycle_diurne
-    !Config  Desc = Cycle diurne
-    !Config  Def  = 1
-    !Config  Help = Cette option permet d'eteidre le cycle diurne.
-    !Config         Peut etre util pour accelerer le code !
-    iflag_cycle_diurne_omp = 1
-    CALL getin('iflag_cycle_diurne',iflag_cycle_diurne_omp)
-
-    !Config  Key  = soil_model
-    !Config  Desc = Modele de sol
-    !Config  Def  = y
-    !Config  Help = Choix du modele de sol (Thermique ?)
-    !Config         Option qui pourait un string afin de pouvoir
-    !Config         plus de choix ! Ou meme une liste d'options !
-    soil_model_omp = .TRUE.
-    CALL getin('soil_model',soil_model_omp)
-
-    !Config  Key  = new_oliq
-    !Config  Desc = Nouvelle eau liquide
-    !Config  Def  = y
-    !Config  Help = Permet de mettre en route la
-    !Config         nouvelle parametrisation de l'eau liquide !
-    new_oliq_omp = .TRUE.
-    CALL getin('new_oliq',new_oliq_omp)
-
-    !Config  Key  = ok_orodr
-    !Config  Desc = Orodr ???
-    !Config  Def  = y
-    !Config  Help = Y en a pas comprendre !
-    !Config         
-    ok_orodr_omp = .TRUE.
-    CALL getin('ok_orodr',ok_orodr_omp)
-
-    !Config  Key  =  ok_orolf
-    !Config  Desc = Orolf ??
-    !Config  Def  = y
-    !Config  Help = Connais pas !
-    ok_orolf_omp = .TRUE.
-    CALL getin('ok_orolf', ok_orolf_omp)
-
-
-    !Config  Key  =  zrel_oro_t
-    !Config  Desc = zrel_oro_t
-    !Config  Def  = 9999.
-    !Config  Help = Connais pas !
-    zrel_oro_t_omp = 9999.
-    CALL getin('zrel_oro_t', zrel_oro_t_omp)
-
-    !Config  Key  =  zstd_orodr_t
-    !Config  Desc = zstd_orodr_t
-    !Config  Def  = 0.
-    !Config  Help = Connais pas !
-    zstd_orodr_t_omp = 10.
-    CALL getin('zstd_orodr_t', zstd_orodr_t_omp)
-
-
-    !Config  Key  =  zpmm_orodr_t
-    !Config  Desc = zpmm_orodr_t
-    !Config  Def  = 0.
-    !Config  Help = Connais pas !
-    zpmm_orodr_t_omp = 100.
-    CALL getin('zpmm_orodr_t', zpmm_orodr_t_omp)
-
-
-    !Config  Key  =  zpmm_orolf_t
-    !Config  Desc = zpmm_orolf_t
-    !Config  Def  = 0.
-    !Config  Help = Connais pas !
-    zpmm_orolf_t_omp = 100.
-    CALL getin('zpmm_orolf_t', zpmm_orolf_t_omp)
-
-    !Config  Key  = ok_limitvrai
-    !Config  Desc = Force la lecture de la bonne annee
-    !Config  Def  = n
-    !Config  Help = On peut forcer le modele a lire le
-    !Config         fichier SST de la bonne annee. C'est une tres bonne
-    !Config         idee, pourquoi ne pas mettre toujours a y ???
-    ok_limitvrai_omp = .FALSE.
-    CALL getin('ok_limitvrai',ok_limitvrai_omp)
-
-    !Config  Key  = nbapp_rad
-    !Config  Desc = Frequence d'appel au rayonnement
-    !Config  Def  = 12
-    !Config  Help = Nombre  d'appels des routines de rayonnements
-    !Config         par jour.
-    nbapp_rad_omp = 12
-    CALL getin('nbapp_rad',nbapp_rad_omp)
-
-    !rajout Olivier Torres
-    !Config  Key  = choix_bulk
-    !Config  Desc = choix de la formulation bulk a prendre dans clcdrag au-dessus de l'ocean
-    !Config  Def  = 0
-    !Config         0 -> originale (lmdz/Louis 79)
-    !Config         1 -> COARE
-    !Config         2 -> CORE-"pure" (cf. Large)
-    !Config         3 -> CORE-"mixte" (avec z_0 et C_T^N donnees par Smith 88)
-    choix_bulk_omp = 0
-    CALL getin('choix_bulk',choix_bulk_omp)
-
-    !Config  Key  = nit_bulk
-    !Config  Desc = choix du nombre d'it de pt fixe dans la bulk
-    !Config  Def  = 5
-    nit_bulk_omp = 1
-    CALL getin('nit_bulk',nit_bulk_omp)
-
-    !Config  Key  = kz0
-    !Config  Desc = choix de la formulation z0 pour la bulk ECUME
-    !Config  Def  = 1
-    !Config         0 -> ARPEGE formulation
-    !Config         1 -> Smith Formulation
-    !Config         2 -> Direct computation using the stability functions
-    kz0_omp = 0
-    CALL getin('kz0',kz0_omp)
-
-
-    !Config  Key  = iflag_con
-    !Config  Desc = Flag de convection
-    !Config  Def  = 2
-    !Config  Help = Flag  pour la convection les options suivantes existent :
-    !Config         1 pour LMD,
-    !Config         2 pour Tiedtke,
-    !Config         3 pour CCM(NCAR)  
-    iflag_con_omp = 2
-    CALL getin('iflag_con',iflag_con_omp)
-
-    !Config  Key  = nbapp_cv
-    !Config  Desc = Frequence d'appel a la convection
-    !Config  Def  = 0
-    !Config  Help = Nombre  d'appels des routines de convection
-    !Config         par jour. Si =0, appel a chaque pas de temps physique.
-    nbapp_cv_omp = 0
-    CALL getin('nbapp_cv',nbapp_cv_omp)
-
-    !Config  Key  = nbapp_wk
-    !Config  Desc = Frequence d'appel aux wakes
-    !Config  Def  = 0
-    !Config  Help = Nombre  d'appels des routines de wakes
-    !Config         par jour. Si =0, appel a chaque pas de temps physique.
-    nbapp_wk_omp = 0
-    CALL getin('nbapp_wk',nbapp_wk_omp)
-
-    !Config  Key  = iflag_ener_conserv
-    !Config  Desc = Flag de convection
-    !Config  Def  = 1
-    !Config  Help = Flag  pour la convection les options suivantes existent :
-    !Config         -1 pour Kinetic energy correction
-    !Config         1  conservation kinetic and enthalpy
-    iflag_ener_conserv_omp = -1
-    CALL getin('iflag_ener_conserv',iflag_ener_conserv_omp)
-
-    !Config  Key  = ok_conserv_q
-    !Config  Desc = Switch des corrections de conservation de l'eau
-    !Config  Def  = y
-    !Config  Help = Switch des corrections de conservation de l'eau
-    !Config         y -> corrections activees
-    !Config         n -> conformite avec versions anterieures au 1/4/2014
-    ok_conserv_q_omp = .FALSE.
-    CALL getin('ok_conserv_q',ok_conserv_q_omp)
-
-    !
-    !
-    !
-    ! Constante solaire & Parametres orbitaux & taux gaz effet de serre END
-    !
-    ! KE
-    !
-
-    !Config key  = cvl_comp_threshold
-    !Config Desc = maximum fraction of convective points enabling compression
-    !Config Def  = 1.00
-    !Config Help = fields are compressed when less than a fraction cvl_comp_threshold
-    !Config Help = of the points is convective.
-    cvl_comp_threshold_omp = 1.00
-    CALL getin('cvl_comp_threshold', cvl_comp_threshold_omp)
-
-    !Config key  = cvl_sig2feed
-    !Config Desc = sigma coordinate at top of feeding layer
-    !Config Def  = 0.97
-    !Config Help = deep convection is fed by the layer extending from the surface (pressure ps)
-    !Config Help = and cvl_sig2feed*ps.
-    cvl_sig2feed_omp = 0.97
-    CALL getin('cvl_sig2feed', cvl_sig2feed_omp)
-
-    !Config key  = cvl_corr
-    !Config Desc = Facteur multiplication des precip convectives dans KE
-    !Config Def  = 1.00
-    !Config Help = 1.02 pour un moderne ou un pre-ind. A ajuster pour un glaciaire
-    cvl_corr_omp = 1.00
-    CALL getin('cvl_corr', cvl_corr_omp)
-
-
-    !Config Key  = epmax
-    !Config Desc = Efficacite precip
-    !Config Def  = 0.993
-    !Config Help = 
-    !
-    epmax_omp = .993
-    CALL getin('epmax', epmax_omp)
-
-    coef_epmax_cape_omp = 0.0   
-    CALL getin('coef_epmax_cape', coef_epmax_cape_omp)        
-    !
-    !Config Key  = ok_adj_ema
-    !Config Desc =  
-    !Config Def  = FALSE
-    !Config Help = 
-    !
-    ok_adj_ema_omp = .FALSE.
-    CALL getin('ok_adj_ema',ok_adj_ema_omp)
-    !
-    !Config Key  = iflag_clw
-    !Config Desc =  
-    !Config Def  = 0
-    !Config Help = 
-    !
-    iflag_clw_omp = 0
-    CALL getin('iflag_clw',iflag_clw_omp)
-    
-
-    !Config Key  = iflag_ratqs
-    !Config Desc =
-    !Config Def  = 1
-    !Config Help =
-    !
-    iflag_ratqs_omp = 1
-    CALL getin('iflag_ratqs',iflag_ratqs_omp)
-
-    !
-    !Config Key  = iflag_radia 
-    !Config Desc =  
-    !Config Def  = 1
-    !Config Help = 
-    !
-    iflag_radia_omp = 1
-    CALL getin('iflag_radia',iflag_radia_omp)
-
-    !
-    !Config Key  = iflag_rrtm 
-    !Config Desc =  
-    !Config Def  = 0
-    !Config Help = 
-    !
-    iflag_rrtm_omp = 0
-    CALL getin('iflag_rrtm',iflag_rrtm_omp)
-
-    !
-    !Config Key  = NSW 
-    !Config Desc =  
-    !Config Def  = 0
-    !Config Help = 
-    !
-    NSW_omp = 2
-    CALL getin('NSW',NSW_omp)
-    !albedo SB >>>
-    iflag_albedo_omp = 0
-    CALL getin('iflag_albedo',iflag_albedo_omp)
-
-    ok_chlorophyll_omp=.FALSE.
-    CALL getin('ok_chlorophyll',ok_chlorophyll_omp)
-    !albedo SB <<<
-    !
-    !Config Key  = ok_sun_time
-    !Config Desc = oui ou non variabilite solaire
-    !Config Def  = .FALSE.
-    !Config Help =
-    !
-    !
-    !valeur AMIP II
-    ok_suntime_rrtm_omp = .FALSE.
-    IF (iflag_rrtm_omp==1) THEN
-      CALL getin('ok_suntime_rrtm',ok_suntime_rrtm_omp)
-    ENDIF
-    
-    !Config Key  = flag_aerosol_strat
-    !Config Desc = use stratospheric aerosols 0, 1, 2
-    ! - 0 = no stratospheric aerosols 
-    ! - 1 = stratospheric aerosols scaled from 550 nm AOD 
-    ! - 2 = stratospheric aerosol properties from CMIP6
-    !Option 2 is only available with RRTM, this is tested later on 
-    !Config Def  = 0
-    !Config Help = Used in physiq.F
-    !
-    flag_aerosol_strat_omp = 0
-    CALL getin('flag_aerosol_strat',flag_aerosol_strat_omp)
-
-    !Config Key  = flag_aer_feedback
-    !Config Desc = (des)activate aerosol radiative feedback
-    ! - F = no aerosol radiative feedback
-    ! - T = aerosol radiative feedback
-    !Config Def  = T
-    !Config Help = Used in physiq.F
-    !
-    flag_aer_feedback_omp = .TRUE. 
-    IF (iflag_rrtm_omp==1) THEN
-       CALL getin('flag_aer_feedback',flag_aer_feedback_omp)
-    ENDIF
-
-    !Config Key  = iflag_cld_th 
-    !Config Desc =  
-    !Config Def  = 1
-    !Config Help = 
-    !
-    iflag_cld_th_omp = 1
-    ! On lit deux fois avec l'ancien et le nouveau nom 
-    ! pour assurer une retrocompatiblite.
-    ! A abandonner un jour
-    CALL getin('iflag_cldcon',iflag_cld_th_omp)
-    CALL getin('iflag_cld_th',iflag_cld_th_omp)
-    iflag_cld_cv_omp = 0 
-    CALL getin('iflag_cld_cv',iflag_cld_cv_omp)
-
-    !
-    !Config Key  = tau_cld_cv
-    !Config Desc =
-    !Config Def  = 10.
-    !Config Help =
-    !
-    tau_cld_cv_omp = 10.
-    CALL getin('tau_cld_cv',tau_cld_cv_omp)
-
-    !
-    !Config Key  = coefw_cld_cv
-    !Config Desc =
-    !Config Def  = 0.1
-    !Config Help =
-    !
-    coefw_cld_cv_omp = 0.1
-    CALL getin('coefw_cld_cv',coefw_cld_cv_omp)
-
-
-
-
-    !
-    !Config Key  = fact_cldcon
-    !Config Desc =  
-    !Config Def  = 0.375
-    !Config Help = 
-    !
-    fact_cldcon_omp = 0.375
-    CALL getin('fact_cldcon',fact_cldcon_omp)
-
-    !
-    !Config Key  = facttemps
-    !Config Desc =  
-    !Config Def  = 1.e-4
-    !Config Help = 
-    !
-    facttemps_omp = 1.e-4
-    CALL getin('facttemps',facttemps_omp)
-
-    !
-    !Config Key  = ok_newmicro
-    !Config Desc =  
-    !Config Def  = .TRUE.
-    !Config Help = 
-    !
-    ok_newmicro_omp = .TRUE.
-    CALL getin('ok_newmicro',ok_newmicro_omp)
-    !
-    !Config Key  = ratqsbas
-    !Config Desc =  
-    !Config Def  = 0.01
-    !Config Help = 
-    !
-    ratqsbas_omp = 0.01
-    CALL getin('ratqsbas',ratqsbas_omp)
-    !
-    !Config Key  = ratqshaut
-    !Config Desc =  
-    !Config Def  = 0.3
-    !Config Help = 
-    !
-    ratqshaut_omp = 0.3
-    CALL getin('ratqshaut',ratqshaut_omp)
-
-    !Config Key  = tau_ratqs
-    !Config Desc =  
-    !Config Def  = 1800.
-    !Config Help = 
-    !
-    tau_ratqs_omp = 1800.
-    CALL getin('tau_ratqs',tau_ratqs_omp)
-
-    !
-    !-----------------------------------------------------------------------
-    ! Longitude solaire pour le calcul de l'ensoleillement en degre
-    ! si on veut imposer la saison. Sinon, solarlong0=-999.999
-    !Config Key  = solarlong0
-    !Config Desc =  
-    !Config Def  = -999.999 
-    !Config Help = 
-    !
-    solarlong0_omp = -999.999
-    CALL getin('solarlong0',solarlong0_omp)
-    !
-    !-----------------------------------------------------------------------
-    !  Valeur imposee pour configuration idealisees
-    !Config Key  = qsol0 pour le bucket, evap0 pour aquaplanetes, albsno0
-    ! Default value -1 to activate the full computation
-    qsol0_omp = -1.
-    CALL getin('qsol0',qsol0_omp)
-    evap0_omp = -1.
-    CALL getin('evap0',evap0_omp)
-    albsno0_omp = -1.
-    CALL getin('albsno0',albsno0_omp)
-    !
-    !-----------------------------------------------------------------------
-    !
-    !Config Key  = iflag_sic
-    !Config Desc =  
-    !Config Def  = 0
-    !Config Help = 
-    !
-    iflag_sic_omp = 0
-    CALL getin('iflag_sic',iflag_sic_omp)
-    !
-    !Config Key  = iflag_inertie
-    !Config Desc =
-    !Config Def  = 0
-    !Config Help =
-    !
-    iflag_inertie_omp = 0
-    CALL getin('iflag_inertie',iflag_inertie_omp)
-    !
-    !Config Key  = inertie_sic
-    !Config Desc =  
-    !Config Def  = 2000.
-    !Config Help = 
-    !
-    inertie_sic_omp = 2000.
-    CALL getin('inertie_sic',inertie_sic_omp)
-    !
-    !Config Key  = inertie_lic
-    !Config Desc =  
-    !Config Def  = 2000.
-    !Config Help = 
-    !
-    inertie_lic_omp = 2000.
-    CALL getin('inertie_lic',inertie_lic_omp)
-    !
-    !Config Key  = inertie_sno
-    !Config Desc =  
-    !Config Def  = 2000.
-    !Config Help = 
-    !
-    inertie_sno_omp = 2000.
-    CALL getin('inertie_sno',inertie_sno_omp)
-    !
-    !Config Key  = inertie_sol
-    !Config Desc =  
-    !Config Def  = 2000.
-    !Config Help = 
-    !
-    inertie_sol_omp = 2000.
-    CALL getin('inertie_sol',inertie_sol_omp)
-
-    !
-    !Config Key  = rad_froid
-    !Config Desc =  
-    !Config Def  = 35.0
-    !Config Help = 
-    !
-    rad_froid_omp = 35.0
-    CALL getin('rad_froid',rad_froid_omp)
-
-    !
-    !Config Key  = rad_chau1
-    !Config Desc =  
-    !Config Def  = 13.0
-    !Config Help = 
-    !
-    rad_chau1_omp = 13.0
-    CALL getin('rad_chau1',rad_chau1_omp)
-
-    !
-    !Config Key  = rad_chau2
-    !Config Desc =  
-    !Config Def  = 9.0
-    !Config Help = 
-    !
-    rad_chau2_omp = 9.0
-    CALL getin('rad_chau2',rad_chau2_omp)
-
-
-    !
-    !Config Key  = iflag_ice_thermo
-    !Config Desc =  
-    !Config Def  = 0
-    !Config Help = 
-    !
-    iflag_ice_thermo_omp = 0
-    CALL getin('iflag_ice_thermo',iflag_ice_thermo_omp)
-
-    !
-    !Config Key  = ok_ice_supersat
-    !Config Desc = include ice supersaturation for cold clouds
-    !Config Def  = .FALSE.
-    !Config Help =
-    !
-    ok_ice_supersat_omp = .FALSE.
-    CALL getin('ok_ice_supersat',ok_ice_supersat_omp)
-
-    !Config Key  = ok_plane_h2o
-    !Config Desc = include H2O emissions from aviation
-    !Config Def  = .FALSE.
-    !Config Help =
-    !
-    ok_plane_h2o_omp = .FALSE.
-    CALL getin('ok_plane_h2o',ok_plane_h2o_omp)
-
-    !Config Key  = ok_plane_contrail
-    !Config Desc = include the formation of contrail cirrus clouds
-    !Config Def  = .FALSE.
-    !Config Help =
-    !
-    ok_plane_contrail_omp = .FALSE.
-    CALL getin('ok_plane_contrail',ok_plane_contrail_omp)
-
-    !
-    !Config Key  = top_height
-    !Config Desc =
-    !Config Def  = 3
-    !Config Help =
-    !
-    top_height_omp = 3
-    CALL getin('top_height',top_height_omp)
-
-    !
-    !Config Key  = overlap
-    !Config Desc =
-    !Config Def  = 3
-    !Config Help =
-    !
-    overlap_omp = 3
-    CALL getin('overlap',overlap_omp)
-
-    !
-    !Config Key  = cdmmax
-    !Config Desc =
-    !Config Def  = 1.3E-3
-    !Config Help =
-    !
-    cdmmax_omp = 1.3E-3
-    CALL getin('cdmmax',cdmmax_omp)
-
-    !
-    !Config Key  = cdhmax
-    !Config Desc =
-    !Config Def  = 1.1E-3
-    !Config Help =
-    !
-    cdhmax_omp = 1.1E-3
-    CALL getin('cdhmax',cdhmax_omp)
-
-    !261103
-    !
-    !Config Key  = ksta
-    !Config Desc =
-    !Config Def  = 1.0e-10
-    !Config Help =
-    !
-    ksta_omp = 1.0e-10
-    CALL getin('ksta',ksta_omp)
-
-    !
-    !Config Key  = ksta_ter
-    !Config Desc =
-    !Config Def  = 1.0e-10
-    !Config Help =
-    !
-    ksta_ter_omp = 1.0e-10
-    CALL getin('ksta_ter',ksta_ter_omp)
-
-    !Config Key  = f_ri_cd_min
-    !Config Desc =
-    !Config Def  = 0.1
-    !Config Help =
-    !
-    f_ri_cd_min_omp = 0.1
-    CALL getin('f_ri_cd_min',f_ri_cd_min_omp)
-
-    !
-    !Config Key  = ok_kzmin
-    !Config Desc =
-    !Config Def  = .TRUE.
-    !Config Help =
-    !
-    ok_kzmin_omp = .TRUE.
-    CALL getin('ok_kzmin',ok_kzmin_omp)
-
-    !
-    !Config Key  = fmagic
-    !Config Desc = additionnal multiplicator factor used for albedo
-    !Config Def  = 1.
-    !Config Help = additionnal multiplicator factor used in albedo.F
-    !
-    fmagic_omp = 1.
-    CALL getin('fmagic',fmagic_omp)
-
-    !
-    !Config Key  = pmagic
-    !Config Desc = additional factor used for albedo
-    !Config Def  = 0.
-    !Config Help = additional factor used in albedo.F
-    !
-    pmagic_omp = 0.
-    CALL getin('pmagic',pmagic_omp)
-
-
-    !Config Key = ok_lic_melt
-    !Config Desc = Prise en compte de la fonte de la calotte dans le bilan d'eau
-    !Config Def  = .FALSE.
-    !Config Help = mettre a .FALSE. pour assurer la conservation en eau
-    ok_lic_melt_omp = .FALSE.
-    CALL getin('ok_lic_melt', ok_lic_melt_omp)
-
-
-    !Config Key = ok_lic_cond
-    !Config Desc = Prise en compte depot de vapeur d'eau sur la calotte dans le bilan d'eau
-    !Config Def  = .FALSE.
-    !Config Help = mettre a .TRUE. pour assurer la conservation en eau
-    ok_lic_cond_omp = .FALSE.
-    CALL getin('ok_lic_cond', ok_lic_cond_omp)
-
-    !
-    ! PARAMETER FOR THE PLANETARY BOUNDARY LAYER
-    !
-
-    !Config Key  = iflag_pbl
-    !Config Desc =
-    !Config Def  = 1
-    !Config Help =
-    !
-    iflag_pbl_omp = 1
-    CALL getin('iflag_pbl',iflag_pbl_omp)
-
-    iflag_physiq_omp = 0 ! 0: std, 1: with physiqex output, 2: for physiqex
-    CALL getin('iflag_physiq',iflag_physiq_omp)
-
-!FC
-    !Config Key  = ifl_pbltree
-    !Config Desc = drag from trees 0 no activated
-    !Config Def  = 0
-    !Config Help =
-    !
-    ifl_pbltree_omp = 0
-    CALL getin('ifl_pbltree',ifl_pbltree_omp)
-!FC
-    !Config Key  = Cd_frein
-    !Config Desc = drag from trees 
-    !Config Def  = 7.5E-02 (valeur Masson mais fait planter avec des LAI eleves)
-    !Config Help =
-    !
-    Cd_frein_omp = 7.5E-02
-    CALL getin('Cd_frein',Cd_frein_omp)
-
-    !
-    !Config Key  = iflag_pbl_split
-    !Config Desc = decimal flag: least signif digit = split vdf; next digit = split thermals
-    !Config Def  = 0
-    !Config Help = 0-> no splitting; 1-> vdf splitting; 10-> thermals splitting; 11-> full splitting
-    !
-    iflag_pbl_split_omp = 0
-    call getin('iflag_pbl_split',iflag_pbl_split_omp)
-    !
-    !Config Key  = iflag_order2_sollw
-    !Config Desc =
-    !Config Def  = 0
-    !Config Help =
-    !
-    iflag_order2_sollw_omp = 0
-    CALL getin('iflag_order2_sollw',iflag_order2_sollw_omp)
-    !
-    !Config Key  = iflag_thermals
-    !Config Desc =
-    !Config Def  = 0
-    !Config Help =
-    !
-    iflag_thermals_omp = 0
-    CALL getin('iflag_thermals',iflag_thermals_omp)
-    !
-    !Config Key  = nsplit_thermals
-    !Config Desc =
-    !Config Def  = 0
-    !Config Help =
-    !
-    nsplit_thermals_omp = 1
-    CALL getin('nsplit_thermals',nsplit_thermals_omp)
-    !
-    !Config Key  = nsplit_thermals
-    !Config Desc =
-    !Config Def  = 0
-    !Config Help =
-    alp_bl_k_omp = 1.
-    CALL getin('alp_bl_k',alp_bl_k_omp)
-
-    ! nrlmd le 10/04/2012
-
-    !Config Key  = iflag_trig_bl
-    !Config Desc =  
-    !Config Def  = 0
-    !Config Help = 
-    !
-    iflag_trig_bl_omp = 0
-    CALL getin('iflag_trig_bl',iflag_trig_bl_omp)
-
-    !Config Key  = iflag_strig
-    !Config Desc =  
-    !Config Def  = 0
-    !Config Help = 
-    !
-    iflag_strig_omp = 0
-    CALL getin('iflag_strig',iflag_strig_omp)
-
-    !Config Key  = s_trig_bl
-    !Config Desc =  
-    !Config Def  = 0
-    !Config Help = 
-    !
-    s_trig_omp = 2e7
-    CALL getin('s_trig',s_trig_omp)
-
-    !Config Key  = h_trig
-    !Config Desc =  
-    !Config Def  = 0
-    !Config Help = 
-    !
-    h_trig_omp = 6000.
-    CALL getin('h_trig',h_trig_omp)
-
-    !Config Key  = tau_trig_shallow
-    !Config Desc =  
-    !Config Def  = 0
-    !Config Help = 
-    !
-    tau_trig_shallow_omp = 600
-    CALL getin('tau_trig_shallow',tau_trig_shallow_omp)
-
-    !Config Key  = tau_trig_deep
-    !Config Desc =  
-    !Config Def  = 0
-    !Config Help = 
-    !
-    tau_trig_deep_omp = 1800
-    CALL getin('tau_trig_deep',tau_trig_deep_omp)
-
-    !Config Key  = iflag_clos_bl
-    !Config Desc =  
-    !Config Def  = 0
-    !Config Help = 
-    !
-    iflag_clos_bl_omp = 0
-    CALL getin('iflag_clos_bl',iflag_clos_bl_omp)
-
-    ! fin nrlmd le 10/04/2012
-
-    !
-    !Config Key  = tau_thermals
-    !Config Desc =
-    !Config Def  = 0.
-    !Config Help =
-    !
-    tau_thermals_omp = 0.
-    CALL getin('tau_thermals',tau_thermals_omp)
-
-    !
-    !Config Key  = iflag_coupl
-    !Config Desc =
-    !Config Def  = 0
-    !Config Help =
-    !
-    iflag_coupl_omp = 0
-    CALL getin('iflag_coupl',iflag_coupl_omp)
-
-    !
-    !Config Key  = iflag_clos
-    !Config Desc =  
-    !Config Def  = 0
-    !Config Help = 
-    !
-    iflag_clos_omp = 1
-    CALL getin('iflag_clos',iflag_clos_omp)
-    !
-    !Config Key  = coef_clos_ls
-    !Config Desc =  
-    !Config Def  = 0
-    !Config Help = 
-    !
-    coef_clos_ls_omp = 0.
-    CALL getin('coef_clos_ls',coef_clos_ls_omp)
-
-    !
-    !Config Key  = iflag_cvl_sigd
-    !Config Desc =  
-    !Config Def  = 0
-    !Config Help = 
-    !
-    iflag_cvl_sigd_omp = 0
-    CALL getin('iflag_cvl_sigd',iflag_cvl_sigd_omp)
-
-    !Config Key  = iflag_wake
-    !Config Desc =  
-    !Config Def  = 0
-    !Config Help = 
-    !
-    iflag_wake_omp = 0
-    CALL getin('iflag_wake',iflag_wake_omp)
-
-    !Config Key  = alp_offset
-    !Config Desc =  
-    !Config Def  = 0
-    !Config Help = 
-    !
-    alp_offset_omp = 0.
-    CALL getin('alp_offset',alp_offset_omp)
-
-    !
-    !Config Key  = lev_histhf
-    !Config Desc =
-    !Config Def  = 1
-    !Config Help =
-    !
-    lev_histhf_omp = 1
-    CALL getin('lev_histhf',lev_histhf_omp)
-
-    !
-    !Config Key  = lev_histday
-    !Config Desc =
-    !Config Def  = 1
-    !Config Help =
-    !
-    lev_histday_omp = 1
-    CALL getin('lev_histday',lev_histday_omp)
-
-    !
-    !Config Key  = lev_histmth
-    !Config Desc =
-    !Config Def  = 2
-    !Config Help =
-    !
-    lev_histmth_omp = 2
-    CALL getin('lev_histmth',lev_histmth_omp)
-    !
-    !Config Key  = lev_histins
-    !Config Desc =
-    !Config Def  = 1
-    !Config Help =
-    !
-    lev_histins_omp = 1
-    CALL getin('lev_histins',lev_histins_omp)
-    !
-    !Config Key  = lev_histLES
-    !Config Desc =
-    !Config Def  = 1
-    !Config Help =
-    !
-    lev_histLES_omp = 1
-    CALL getin('lev_histLES',lev_histLES_omp)
-    ! 
-    !Config Key  = lev_histdayNMC
-    !Config Desc =
-    !Config Def  = 8
-    !Config Help =
-    !
-    lev_histdayNMC_omp = 8
-    CALL getin('lev_histdayNMC',lev_histdayNMC_omp)
-    !
-    !Config Key  = levout_histNMC
-    !Config Desc =
-    !Config Def  = 5
-    !Config Help =
-    !
-    levout_histNMC_omp(1) = 5
-    levout_histNMC_omp(2) = 5
-    levout_histNMC_omp(3) = 5
-    CALL getin('levout_histNMC',levout_histNMC_omp)
-    !
-    !histNMC BEG
-    !Config Key  = ok_histNMC
-    !Config Desc = ok_histNMC(1) = frequence de sortie fichiers histmthNMC
-    !Config Desc = ok_histNMC(2) = frequence de sortie fichiers histdayNMC
-    !Config Desc = ok_histNMC(3) = frequence de sortie fichiers histhfNMC
-    !Config Def  = n, n, n
-    !Config Help =
-    !
-    ok_histNMC_omp(1) = .FALSE.
-    ok_histNMC_omp(2) = .FALSE.
-    ok_histNMC_omp(3) = .FALSE.
-    CALL getin('ok_histNMC',ok_histNMC_omp)
-    !
-    !Config Key  = freq_outNMC
-    !Config Desc = freq_outNMC(1) = frequence de sortie fichiers histmthNMC
-    !Config Desc = freq_outNMC(2) = frequence de sortie fichiers histdayNMC
-    !Config Desc = freq_outNMC(3) = frequence de sortie fichiers histhfNMC
-    !Config Def  = 2592000., 86400., 21600. (1mois, 1jour, 6h) 
-    !Config Help =
-    !
-    freq_outNMC_omp(1) = mth_len
-    freq_outNMC_omp(2) = 1.
-    freq_outNMC_omp(3) = 1./4.
-    CALL getin('freq_outNMC',freq_outNMC_omp)
-    !
-    !Config Key  = freq_calNMC
-    !Config Desc = freq_calNMC(1) = frequence de calcul fichiers histmthNMC
-    !Config Desc = freq_calNMC(2) = frequence de calcul fichiers histdayNMC
-    !Config Desc = freq_calNMC(3) = frequence de calcul fichiers histhfNMC
-    !Config Def  = phys_tstep
-    !Config Help =
-    !
-    freq_calNMC_omp(1) = phys_tstep
-    freq_calNMC_omp(2) = phys_tstep
-    freq_calNMC_omp(3) = phys_tstep
-    CALL getin('freq_calNMC',freq_calNMC_omp)
-    !
-    !Config Key  = type_run
-    !Config Desc =
-    !Config Def  = 'AMIP'/'CFMIP'  ou 'CLIM'/'ENSP'
-    !Config Help =
-    !
-    type_run_omp = 'AMIP'
-    CALL getin('type_run',type_run_omp)
-
-    !
-    !Config Key  = ok_cosp
-    !Config Desc =
-    !Config Def  = .FALSE.
-    !Config Help =
-    !
-    ok_cosp_omp = .FALSE.
-    CALL getin('ok_cosp',ok_cosp_omp)
-
-    !
-    !Config Key  = ok_airs
-    !Config Desc =
-    !Config Def  = .FALSE.
-    !Config Help =
-    !
-    ok_airs_omp = .FALSE.
-    CALL getin('ok_airs',ok_airs_omp)
-
-    !
-    !Config Key  = ok_mensuelCOSP
-    !Config Desc =
-    !Config Def  = .TRUE.
-    !Config Help =
-    !
-    ok_mensuelCOSP_omp = .TRUE.
-    CALL getin('ok_mensuelCOSP',ok_mensuelCOSP_omp)
-
-    !
-    !Config Key  = ok_journeCOSP
-    !Config Desc =
-    !Config Def  = .TRUE.
-    !Config Help = 
-    !
-    ok_journeCOSP_omp = .TRUE.
-    CALL getin('ok_journeCOSP',ok_journeCOSP_omp)
-
-    !
-    !Config Key  = ok_hfCOSP
-    !Config Desc =
-    !Config Def  = .FALSE.
-    !Config Help =
-    !
-    ok_hfCOSP_omp = .FALSE.
-    CALL getin('ok_hfCOSP',ok_hfCOSP_omp)
-
-    !
-    ! coordonnees (lonmin_ins, lonmax_ins, latmin_ins, latmax_ins) pour la zone 
-    ! avec sorties instantannees tous les pas de temps de la physique => "histbilKP_ins.nc"
-    !
-    !Config Key  = lonmin_ins
-    !Config Desc = 100.  
-    !Config Def  = longitude minimale sorties "bilKP_ins"
-    !Config Help = 
-    !
-    lonmin_ins_omp = 100.
-    CALL getin('lonmin_ins',lonmin_ins_omp)
-    !
-    !Config Key  = lonmax_ins
-    !Config Desc = 130. 
-    !Config Def  = longitude maximale sorties "bilKP_ins"
-    !Config Help =
-    !
-    lonmax_ins_omp = 130.
-    CALL getin('lonmax_ins',lonmax_ins_omp)
-    !
-    !Config Key  = latmin_ins
-    !Config Desc = -20.  
-    !Config Def  = latitude minimale sorties "bilKP_ins"
-    !Config Help = 
-    !
-    latmin_ins_omp = -20.
-    CALL getin('latmin_ins',latmin_ins_omp)
-    !
-    !Config Key  = latmax_ins
-    !Config Desc = 20. 
-    !Config Def  = latitude maximale sorties "bilKP_ins"
-    !Config Help =
-    !
-    latmax_ins_omp = 20.
-    CALL getin('latmax_ins',latmax_ins_omp)
-    !
-    !Config Key  = ecrit_hf
-    !Config Desc =
-    !Config Def  = 1./8. !toutes les 3h
-    !Config Help =
-    !
-    ecrit_hf_omp = 1./8.
-    CALL getin('ecrit_hf',ecrit_hf_omp)
-    !
-    !Config Key  = ecrit_ins
-    !Config Desc =
-    !Config Def  = 1./48. ! toutes les 1/2 h
-    !Config Help =
-    !
-    ecrit_ins_omp = 1./48.
-    CALL getin('ecrit_ins',ecrit_ins_omp)
-    !
-    !Config Key  = ecrit_day
-    !Config Desc =
-    !Config Def  = 1.0 !tous les jours
-    !Config Help = nombre de jours pour ecriture fichier histday.nc
-    !
-    ecrit_day_omp = 1.0
-    CALL getin('ecrit_day',ecrit_day_omp)
-    !
-    !Config Key  = ecrit_mth
-    !Config Desc =
-    !Config Def  = 30. !tous les 30jours (1 fois par mois)
-    !Config Help =
-    !
-    ecrit_mth_omp = 30.
-    CALL getin('ecrit_mth',ecrit_mth_omp)
-    !
-    !Config Key  = ecrit_tra
-    !Config Desc =
-    !Config Def  = 30. !tous les 30jours (1 fois par mois)
-    !Config Help =
-    !
-    ecrit_tra_omp = 0.
-    CALL getin('ecrit_tra',ecrit_tra_omp)
-    !
-    !Config Key  = ecrit_reg
-    !Config Desc =
-    !Config Def  = 0.25  !4 fois par jour
-    !Config Help =
-    !
-    ecrit_reg_omp = 0.25   !4 fois par jour
-    CALL getin('ecrit_reg',ecrit_reg_omp)
-    !
-    !
-    print*,'CONFPHYS OOK avant drag_ter'
-    !
-    ! PARAMETRES CDRAG
-    !
-    f_cdrag_ter_omp = 0.8
-    CALL getin('f_cdrag_ter',f_cdrag_ter_omp)
-    !
-    f_cdrag_oce_omp = 0.8
-    CALL getin('f_cdrag_oce',f_cdrag_oce_omp)
-    !
-
-    ! Gustiness flags
-    f_z0qh_oce_omp = 1.
-    CALL getin('f_z0qh_oce',f_z0qh_oce_omp)
-    !
-    f_qsat_oce_omp = 1.
-    CALL getin('f_qsat_oce',f_qsat_oce_omp)
-    !
-    f_gust_bl_omp = 0.
-    CALL getin('f_gust_bl',f_gust_bl_omp)
-    !
-    f_gust_wk_omp = 0.
-    CALL getin('f_gust_wk',f_gust_wk_omp)
-    !
-    !Config Key  = iflag_z0_oce
-    !Config Desc = 0 (z0h=z0m), 1 (diff. equ. for z0h and z0m), -1 (z0m=z0h=z0min)
-    !Config Def  = 0   ! z0h = z0m
-    !Config Help =
-    !
-    iflag_z0_oce_omp=0
-    CALL getin('iflag_z0_oce',iflag_z0_oce_omp)
-    !
-    iflag_gusts_omp=0
-    CALL getin('iflag_gusts',iflag_gusts_omp)
-    !
-    min_wind_speed_omp = 1.
-    CALL getin('min_wind_speed',min_wind_speed_omp)
-
-    z0m_seaice_omp = 0.002 ; CALL getin('z0m_seaice',z0m_seaice_omp)
-    z0h_seaice_omp = 0.002 ; CALL getin('z0h_seaice',z0h_seaice_omp)
-
-
-    z0m_landice_omp = 0.001 ; CALL getin('z0m_landice',z0m_landice_omp)
-    z0h_landice_omp = 0.001 ; CALL getin('z0h_landice',z0h_landice_omp)
-
-    f_rugoro_omp = 0.
-    CALL getin('f_rugoro',f_rugoro_omp)
-
-    z0min_omp = 0.000015
-    CALL getin('z0min',z0min_omp)
-
-
-    ! PARAMETERS FOR CONVECTIVE INHIBITION BY TROPOS. DRYNESS
-    !
-    !Config Key  = supcrit1
-    !Config Desc =
-    !Config Def  = .540
-    !Config Help =
-    !
-    supcrit1_omp = .540
-    CALL getin('supcrit1',supcrit1_omp)
-
-    !
-    !Config Key  = supcrit2
-    !Config Desc =
-    !Config Def  = .600
-    !Config Help =
-    !
-    supcrit2_omp = .600
-    CALL getin('supcrit2',supcrit2_omp)
-
-    !
-    ! PARAMETERS FOR THE MIXING DISTRIBUTION
-    ! iflag_mix: 0=OLD, 
-    !            1=NEW (JYG),            
-    !            2=NEW + conv. depth inhib. by tropos. dryness
-    ! '2' is NOT operationnal and should not be used.
-    !
-    !Config Key  = iflag_mix
-    !Config Desc =
-    !Config Def  = 1
-    !Config Help =
-    !
-    iflag_mix_omp = 1
-    CALL getin('iflag_mix',iflag_mix_omp)
-
-!
-    ! PARAMETERS FOR THE EROSION OF THE ADIABATIC ASCENTS
-    ! iflag_mix_adiab: 0=OLD, 
-    !                  1=NEW (CR),            
-    !            
-    !
-    !Config Key  = iflag_mix_adiab
-    !Config Desc =
-    !Config Def  = 1
-    !Config Help =
-    !
-    iflag_mix_adiab_omp = 0
-    CALL getin('iflag_mix_adiab',iflag_mix_adiab_omp)
-
-    !
-    !Config Key  = scut
-    !Config Desc =
-    !Config Def  = 0.95
-    !Config Help =
-    !
-    scut_omp = 0.95
-    CALL getin('scut',scut_omp)
-
-    !
-    !Config Key  = qqa1
-    !Config Desc =
-    !Config Def  = 1.0
-    !Config Help =
-    !
-    qqa1_omp = 1.0
-    CALL getin('qqa1',qqa1_omp)
-
-    !
-    !Config Key  = qqa2
-    !Config Desc =
-    !Config Def  = 0.0
-    !Config Help =
-    !
-    qqa2_omp = 0.0
-    CALL getin('qqa2',qqa2_omp)
-
-    !
-    !Config Key  = gammas
-    !Config Desc =
-    !Config Def  = 0.05
-    !Config Help =
-    !
-    gammas_omp = 0.05
-    CALL getin('gammas',gammas_omp)
-
-    !
-    !Config Key  = Fmax
-    !Config Desc =
-    !Config Def  = 0.65
-    !Config Help =
-    !
-    Fmax_omp = 0.65
-    CALL getin('Fmax',Fmax_omp)
-
-    !
-    !Config Key  = tmax_fonte_cv
-    !Config Desc =
-    !Config Def  = 275.15
-    !Config Help =
-    !
-    tmax_fonte_cv_omp = 275.15
-    CALL getin('tmax_fonte_cv',tmax_fonte_cv_omp)
-
-    !
-    !Config Key  = alphas  
-    !Config Desc =
-    !Config Def  = -5.
-    !Config Help =
-    !
-    alphas_omp = -5.
-    CALL getin('alphas',alphas_omp)
-
-    !Config key = ok_strato
-    !Config  Desc = activation de la version strato
-    !Config  Def  = .FALSE.
-    !Config  Help = active la version stratosph\'erique de LMDZ de F. Lott
-    !               Et la sponge layer (Runs Stratospheriques)
-
-    ok_strato_omp=.FALSE.
-    CALL getin('ok_strato',ok_strato_omp)
-
-    !Config  key = ok_hines
-    !Config  Desc = activation de la parametrisation de hines
-    !Config  Def  = .FALSE.
-    !Config  Help = Clefs controlant la parametrization de Hines
-
-    ok_hines_omp=.FALSE.
-    CALL getin('ok_hines',ok_hines_omp)
-
-    !  Parametres pour les ondes de gravite
-    !  
-    !  Subgrid Scale Orography (Lott Miller (1997), Lott (1999))
-
-    sso_gkdrag_omp = merge(0.1875, 0.2, ok_strato_omp)
-    CALL getin('sso_gkdrag', sso_gkdrag_omp)
-
-    sso_grahil_omp=merge(0.1,1.,ok_strato_omp)
-    CALL getin('sso_grahil', sso_grahil_omp)
-
-    sso_grcrit_omp =merge(1.,0.01,ok_strato_omp)
-    CALL getin('sso_grcrit', sso_grcrit_omp)
-
-    sso_gfrcri_omp = 1.
-    CALL getin('sso_gfrcri', sso_gfrcri_omp)
-
-    sso_gkwake_omp = 0.50
-    CALL getin('sso_gkwake', sso_gkwake_omp)
-
-    sso_gklift_omp = merge(0.25,0.50,ok_strato_omp)
-    CALL getin('sso_gklift', sso_gklift_omp)
-
-    ! Random gravity waves:
-
-    ok_gwd_rando_omp = .FALSE.
-    IF ( klon_glo == 1 ) THEN
-       print*,'La parametrisation des ondes de gravites non orographiques'
-       print*,'ne fonctionne pas en 1D'
-    ELSE
-       CALL getin('ok_gwd_rando', ok_gwd_rando_omp)
-    ENDIF
-
-    gwd_rando_ruwmax_omp = 2.00
-    CALL getin('gwd_rando_ruwmax', gwd_rando_ruwmax_omp)
-
-    gwd_rando_sat_omp = 0.25
-    CALL getin('gwd_rando_sat', gwd_rando_sat_omp)
-
-    gwd_front_ruwmax_omp = 2.50
-    CALL getin('gwd_front_ruwmax', gwd_front_ruwmax_omp)
-
-    gwd_front_sat_omp = 0.60
-    CALL getin('gwd_front_sat', gwd_front_sat_omp)
-
-
-    !Config  key = ok_qch4
-    !Config  Desc = activation de la parametrisation du methane
-    !Config  Def  = .FALSE.
-    !Config  Help = Clef controlant l'activation de la parametrisation
-    !               de l'humidite due a oxydation+photolyse du methane strato
-
-    ok_qch4_omp=.FALSE.
-    CALL getin('ok_qch4',ok_qch4_omp)
-
-    !Config Key  = OK_LES                                               
-    !Config Desc = Pour des sorties LES                                 
-    !Config Def  = .FALSE.                                              
-    !Config Help = Pour creer le fichier histLES contenant les sorties  
-    !              LES                                                  
-    !                                                                   
-    ok_LES_omp = .FALSE.                                              
-    CALL getin('OK_LES', ok_LES_omp)                                  
-
-    !Config Key  = callstats                                               
-    !Config Desc = Pour des sorties callstats                                 
-    !Config Def  = .FALSE.                                              
-    !Config Help = Pour creer le fichier stats contenant les sorties  
-    !              stats                                                  
-    !                                                                   
-    callstats_omp = .FALSE.                                              
-    CALL getin('callstats', callstats_omp)                                  
-    !
-    !Config Key  = ecrit_LES
-    !Config Desc = Frequence d'ecriture des resultats du LES en nombre de jours;
-    !              par defaut 1., i.e. 1 jour
-    !Config Def  = 1./8.
-    !Config Help = ... 
-    !
-    !
-    adjust_tropopause = .FALSE.
-    CALL getin('adjust_tropopause', adjust_tropopause_omp)
-    !
-    !Config Key  = adjust_tropopause
-    !Config Desc = Adjust the ozone field from the climoz file by stretching its
-    !              tropopause so that it matches the one of LMDZ.
-    !Config Def  = .FALSE.
-    !Config Help = Ensure tropospheric ozone column conservation.
-    !
-    !
-    ok_daily_climoz = .FALSE.
-    CALL getin('ok_daily_climoz', ok_daily_climoz_omp)
-    !
-    !Config Key  = ok_daily_climoz
-    !Config Desc = Interpolate in time the ozone forcings within ce0l.
-    !              .TRUE. if backward compatibility is needed.
-    !Config Def  = .TRUE.
-    !Config Help = .FALSE. ensure much fewer (no calendar dependency)
-    !  and lighter monthly climoz files, inetrpolated in time at gcm run time.
-    
-    ok_new_lscp_omp = .FALSE.
-    CALL getin('ok_new_lscp', ok_new_lscp_omp)
-    !
-    !Config Key  = ok_new_lscp_omp
-    !Config Desc = new cloud scheme ith ice and mixed phase (Etienne and JB)
-    !Config Def  = .FALSE.
-    !Config Help = ...
-
-
-
-    ok_icefra_lscp_omp = .FALSE.
-    CALL getin('ok_icefra_lscp', ok_icefra_lscp_omp)
-    !
-    !Config Key  = ok_icefra_lscp_omp
-    !Config Desc = ice fraction in radiation from lscp
-    !Config Def  = .FALSE.
-    !Config Help = ...
-
-
-
-    ok_bs_omp = .FALSE.
-    CALL getin('ok_bs', ok_bs_omp)
-    !
-    !Config Key  = ok_bs_omp
-    !Config Desc = include blowing snow
-    !Config Def  = .FALSE.
-    !Config Help = ...
-
-
-    ok_rad_bs_omp = .FALSE.
-    CALL getin('ok_rad_bs', ok_rad_bs_omp)
-    !
-    !Config Key  = ok_rad_bs_omp
-    !Config Desc = include blowing snow radiative effect
-    !Config Def  = .FALSE.
-    !Config Help = ...
-
-    ecrit_LES_omp = 1./8.
-    CALL getin('ecrit_LES', ecrit_LES_omp)
-    !
-    read_climoz = 0 ! default value
-    CALL getin('read_climoz', read_climoz)
-
-    carbon_cycle_tr_omp=.FALSE.
-    CALL getin('carbon_cycle_tr',carbon_cycle_tr_omp)
-
-    carbon_cycle_cpl_omp=.FALSE.
-    CALL getin('carbon_cycle_cpl',carbon_cycle_cpl_omp)
-
-    carbon_cycle_rad_omp=.FALSE.
-    CALL getin('carbon_cycle_rad',carbon_cycle_rad_omp)
-
-    read_fco2_ocean_cor_omp=.FALSE.
-    CALL getin('read_fco2_ocean_cor',read_fco2_ocean_cor_omp)
-
-    var_fco2_ocean_cor_omp=0. ! default value
-    CALL getin('var_fco2_ocean_cor',var_fco2_ocean_cor_omp)
-
-    read_fco2_land_cor_omp=.FALSE.
-    CALL getin('read_fco2_land_cor',read_fco2_land_cor_omp)
-
-    var_fco2_land_cor_omp=0. ! default value
-    CALL getin('var_fco2_land_cor',var_fco2_land_cor_omp)
-
-    ! level_coupling_esm : level of coupling of the biogeochemical fields between LMDZ, ORCHIDEE and NEMO
-    ! Definitions of level_coupling_esm in physiq.def
-    ! level_coupling_esm = 0  ! No field exchange between LMDZ and ORCHIDEE models
-    !                         ! No field exchange between LMDZ and NEMO
-    ! level_coupling_esm = 1  ! Field exchange between LMDZ and ORCHIDEE models
-    !                         ! No field exchange between LMDZ and NEMO models
-    ! level_coupling_esm = 2  ! No field exchange between LMDZ and ORCHIDEE models
-    !                         ! Field exchange between LMDZ and NEMO models
-    ! level_coupling_esm = 3  ! Field exchange between LMDZ and ORCHIDEE models
-    !                         ! Field exchange between LMDZ and NEMO models
-    level_coupling_esm_omp=0 ! default value
-    CALL getin('level_coupling_esm',level_coupling_esm_omp)
-
-
-    dms_cycle_cpl_omp=.FALSE.
-    CALL getin('transm_dms_oa',dms_cycle_cpl_omp)
-    !
-    !Config Key  = dms_cycle_cpl
-    !Config Desc = receive dms from pisces via oasis
-    !Config Def  = .FALSE.
-    !Config Help = can be activated only if lmdz use inca for the atmospheric chemistry 
-
-    n2o_cycle_cpl_omp=.FALSE.
-    CALL getin('transm_n2o_oa',n2o_cycle_cpl_omp)
-    !
-    !Config Key  = n2o_cycle_cpl
-    !Config Desc = receive n2o from pisces via oasis
-    !Config Def  = .FALSE.
-    !Config Help = can be activated only if lmdz use inca for the atmospheric chemistry 
-    
-    
-    !$OMP END MASTER
-    !$OMP BARRIER
-
-    R_ecc = R_ecc_omp
-    R_peri = R_peri_omp
-    R_incl = R_incl_omp
-    solaire = solaire_omp
-    ok_suntime_rrtm = ok_suntime_rrtm_omp
-    co2_ppm = co2_ppm_omp
-    co2_ppm0 = co2_ppm0_omp
-    RCO2 = RCO2_omp
-    CH4_ppb = CH4_ppb_omp
-    RCH4 = RCH4_omp
-    N2O_ppb = N2O_ppb_omp
-    RN2O = RN2O_omp
-    CFC11_ppt = CFC11_ppt_omp
-    RCFC11 = RCFC11_omp
-    CFC12_ppt = CFC12_ppt_omp
-    RCFC12 = RCFC12_omp
-    RCO2_act = RCO2
-    RCH4_act = RCH4
-    RN2O_act = RN2O
-    RCFC11_act = RCFC11
-    RCFC12_act = RCFC12
-    RCO2_per = RCO2_per_omp
-    RCH4_per = RCH4_per_omp
-    RN2O_per = RN2O_per_omp
-    RCFC11_per = RCFC11_per_omp
-    RCFC12_per = RCFC12_per_omp
-
-    iflag_cycle_diurne = iflag_cycle_diurne_omp
-    soil_model = soil_model_omp
-    new_oliq = new_oliq_omp
-    ok_orodr = ok_orodr_omp
-    ok_orolf = ok_orolf_omp
-    zrel_oro_t=zrel_oro_t_omp
-    zstd_orodr_t=zstd_orodr_t_omp
-    zpmm_orodr_t=zpmm_orodr_t_omp
-    zpmm_orolf_t=zpmm_orolf_t_omp
-    ok_limitvrai = ok_limitvrai_omp
-    nbapp_rad = nbapp_rad_omp
-    iflag_con = iflag_con_omp
-    nbapp_cv = nbapp_cv_omp
-    nbapp_wk = nbapp_wk_omp
-    iflag_ener_conserv = iflag_ener_conserv_omp
-    ok_conserv_q = ok_conserv_q_omp
-    epmax = epmax_omp
-    coef_epmax_cape = coef_epmax_cape_omp
-    ok_adj_ema = ok_adj_ema_omp
-    iflag_clw = iflag_clw_omp
-    solarlong0 = solarlong0_omp
-    qsol0 = qsol0_omp
-    evap0 = evap0_omp
-    albsno0 = albsno0_omp
-    iflag_sic = iflag_sic_omp
-    iflag_inertie = iflag_inertie_omp
-    inertie_sol = inertie_sol_omp
-    inertie_sic = inertie_sic_omp
-    inertie_lic = inertie_lic_omp
-    inertie_sno = inertie_sno_omp
-    ok_bs = ok_bs_omp
-    ok_rad_bs=ok_rad_bs_omp
-    rad_froid = rad_froid_omp
-    rad_chau1 = rad_chau1_omp
-    rad_chau2 = rad_chau2_omp
-    iflag_ice_thermo = iflag_ice_thermo_omp
-    ok_ice_supersat = ok_ice_supersat_omp
-    ok_plane_h2o = ok_plane_h2o_omp
-    ok_plane_contrail = ok_plane_contrail_omp
-    top_height = top_height_omp
-    overlap = overlap_omp
-    cdmmax = cdmmax_omp
-    cdhmax = cdhmax_omp
-    ksta = ksta_omp
-    ksta_ter = ksta_ter_omp
-    f_ri_cd_min = f_ri_cd_min_omp
-    ok_kzmin = ok_kzmin_omp
-    fmagic = fmagic_omp
-    pmagic = pmagic_omp
-    iflag_pbl = iflag_pbl_omp
-    iflag_physiq = iflag_physiq_omp
-    iflag_pbl_split = iflag_pbl_split_omp
-!FC
-    ifl_pbltree = ifl_pbltree_omp
-    Cd_frein    =Cd_frein_omp
-    iflag_order2_sollw = iflag_order2_sollw_omp
-    lev_histhf = lev_histhf_omp
-    lev_histday = lev_histday_omp
-    lev_histmth = lev_histmth_omp
-    lev_histins = lev_histins_omp
-    lev_histLES = lev_histLES_omp
-    lev_histdayNMC = lev_histdayNMC_omp
-    levout_histNMC = levout_histNMC_omp
-    ok_histNMC(:) = ok_histNMC_omp(:)
-    freq_outNMC(:) = freq_outNMC_omp(:)
-    freq_calNMC(:) = freq_calNMC_omp(:)
-
-    type_ocean = type_ocean_omp
-    version_ocean = version_ocean_omp
-    t_coupl = t_coupl_omp
-
-    ok_veget=.TRUE.
-    type_veget=type_veget_omp
-    IF (type_veget=='n' .or. type_veget=='bucket' .or. type_veget=='betaclim') THEN
-       ok_veget=.FALSE.
-    ENDIF
-    ! INLANDSIS
-    !=================================================
-    landice_opt = landice_opt_omp
-    iflag_tsurf_inlandsis = iflag_tsurf_inlandsis_omp
-    iflag_temp_inlandsis = iflag_temp_inlandsis_omp
-    iflag_albcalc = iflag_albcalc_omp
-    SnoMod=SnoMod_omp
-    BloMod=BloMod_omp
-    ok_outfor=ok_outfor_omp
-    is_ok_slush=is_ok_slush_omp
-    opt_runoff_ac=opt_runoff_ac_omp
-    is_ok_z0h_rn=is_ok_z0h_rn_omp
-    is_ok_density_kotlyakov=is_ok_density_kotlyakov_omp
-    prescribed_z0m_snow=prescribed_z0m_snow_omp
-    correc_alb=correc_alb_omp
-    iflag_z0m_snow=iflag_z0m_snow_omp
-    ok_zsn_ii=ok_zsn_ii_omp
-    discret_xf=discret_xf_omp
-    buf_sph_pol=buf_sph_pol_omp
-    buf_siz_pol=buf_siz_pol_omp
-    !=================================================
-    ok_all_xml = ok_all_xml_omp
-    ok_lwoff = ok_lwoff_omp
-    ok_newmicro = ok_newmicro_omp
-    ok_journe = ok_journe_omp
-    ok_hf = ok_hf_omp
-    ok_mensuel = ok_mensuel_omp
-    ok_instan = ok_instan_omp
-    freq_ISCCP = freq_ISCCP_omp
-    ecrit_ISCCP = ecrit_ISCCP_omp
-    freq_COSP = freq_COSP_omp
-    freq_AIRS = freq_AIRS_omp
-    ok_ade = ok_ade_omp
-    ok_aie = ok_aie_omp
-    ok_alw = ok_alw_omp
-    ok_cdnc = ok_cdnc_omp
-    ok_volcan = ok_volcan_omp
-    flag_volc_surfstrat = flag_volc_surfstrat_omp
-    aerosol_couple = aerosol_couple_omp
-    chemistry_couple = chemistry_couple_omp
-    flag_aerosol = flag_aerosol_omp
-    flag_aerosol_strat = flag_aerosol_strat_omp
-    flag_aer_feedback = flag_aer_feedback_omp
-    flag_bc_internal_mixture=flag_bc_internal_mixture_omp
-    aer_type = aer_type_omp
-    bl95_b0 = bl95_b0_omp
-    bl95_b1 = bl95_b1_omp
-    fact_cldcon = fact_cldcon_omp
-    facttemps = facttemps_omp
-    ratqsbas = ratqsbas_omp
-    ratqshaut = ratqshaut_omp
-    tau_ratqs = tau_ratqs_omp
-
-    iflag_radia = iflag_radia_omp
-    iflag_rrtm = iflag_rrtm_omp
-    iflag_albedo = iflag_albedo_omp
-    ok_chlorophyll = ok_chlorophyll_omp
-    NSW = NSW_omp
-    iflag_cld_th = iflag_cld_th_omp
-    iflag_cld_cv = iflag_cld_cv_omp
-    tau_cld_cv = tau_cld_cv_omp
-    coefw_cld_cv = coefw_cld_cv_omp
-    iflag_ratqs = iflag_ratqs_omp
-    ip_ebil_phy = ip_ebil_phy_omp
-    iflag_thermals = iflag_thermals_omp
-    nsplit_thermals = nsplit_thermals_omp
-    tau_thermals = tau_thermals_omp
-    alp_bl_k = alp_bl_k_omp
-    ! nrlmd le 10/04/2012
-    iflag_trig_bl = iflag_trig_bl_omp
-    iflag_strig = iflag_strig_omp
-    s_trig = s_trig_omp
-    h_trig = h_trig_omp
-    tau_trig_shallow = tau_trig_shallow_omp
-    tau_trig_deep = tau_trig_deep_omp
-    iflag_clos_bl = iflag_clos_bl_omp
-    ! fin nrlmd le 10/04/2012
-    iflag_coupl = iflag_coupl_omp
-    iflag_clos = iflag_clos_omp
-    iflag_wake = iflag_wake_omp
-    coef_clos_ls = coef_clos_ls_omp
-    alp_offset = alp_offset_omp
-    iflag_cvl_sigd = iflag_cvl_sigd_omp
-    type_run = type_run_omp
-    ok_cosp = ok_cosp_omp
-    ok_airs = ok_airs_omp
-
-    ok_mensuelCOSP = ok_mensuelCOSP_omp
-    ok_journeCOSP = ok_journeCOSP_omp
-    ok_hfCOSP = ok_hfCOSP_omp
-    seuil_inversion=seuil_inversion_omp
-    lonmin_ins = lonmin_ins_omp
-    lonmax_ins = lonmax_ins_omp
-    latmin_ins = latmin_ins_omp
-    latmax_ins = latmax_ins_omp
-    ecrit_hf   = ecrit_hf_omp
-    ecrit_ins   = ecrit_ins_omp
-    ecrit_day = ecrit_day_omp
-    ecrit_mth = ecrit_mth_omp
-    ecrit_tra = ecrit_tra_omp
-    ecrit_reg = ecrit_reg_omp
-    cvl_comp_threshold = cvl_comp_threshold_omp
-    cvl_sig2feed = cvl_sig2feed_omp
-    cvl_corr = cvl_corr_omp
-    ok_lic_melt = ok_lic_melt_omp
-    ok_lic_cond = ok_lic_cond_omp
-    f_cdrag_ter=f_cdrag_ter_omp
-    f_cdrag_oce=f_cdrag_oce_omp
-
-    f_gust_wk=f_gust_wk_omp
-    f_gust_bl=f_gust_bl_omp
-    f_qsat_oce=f_qsat_oce_omp
-    f_z0qh_oce=f_z0qh_oce_omp
-    min_wind_speed=min_wind_speed_omp
-    iflag_gusts=iflag_gusts_omp
-    iflag_z0_oce=iflag_z0_oce_omp
-
-    z0m_seaice=z0m_seaice_omp
-    z0h_seaice=z0h_seaice_omp
-    z0m_landice=z0m_landice_omp
-    z0h_landice=z0h_landice_omp
-
-    f_rugoro=f_rugoro_omp
-
-    z0min=z0min_omp
-    supcrit1 = supcrit1_omp
-    supcrit2 = supcrit2_omp
-    iflag_mix = iflag_mix_omp
-    iflag_mix_adiab = iflag_mix_adiab_omp
-    scut = scut_omp
-    qqa1 = qqa1_omp
-    qqa2 = qqa2_omp
-    gammas = gammas_omp
-    Fmax = Fmax_omp
-    tmax_fonte_cv = tmax_fonte_cv_omp
-    alphas = alphas_omp
-
-    gkdrag=sso_gkdrag_omp
-    grahilo=sso_grahil_omp
-    grcrit=sso_grcrit_omp
-    gfrcrit=sso_gfrcri_omp
-    gkwake=sso_gkwake_omp 
-    gklift=sso_gklift_omp 
-
-    ok_strato = ok_strato_omp
-    ok_hines = ok_hines_omp
-    ok_gwd_rando = ok_gwd_rando_omp
-    gwd_rando_ruwmax = gwd_rando_ruwmax_omp
-    gwd_rando_sat = gwd_rando_sat_omp
-    gwd_front_ruwmax = gwd_front_ruwmax_omp
-    gwd_front_sat = gwd_front_sat_omp
-    ok_qch4 = ok_qch4_omp
-    ok_LES = ok_LES_omp
-    callstats = callstats_omp
-    ecrit_LES = ecrit_LES_omp
-    adjust_tropopause = adjust_tropopause_omp
-    ok_daily_climoz = ok_daily_climoz_omp
-    carbon_cycle_tr = carbon_cycle_tr_omp
-    carbon_cycle_cpl = carbon_cycle_cpl_omp
-    carbon_cycle_rad = carbon_cycle_rad_omp
-    level_coupling_esm = level_coupling_esm_omp
-    ok_new_lscp = ok_new_lscp_omp
-    ok_icefra_lscp=ok_icefra_lscp_omp
-    read_fco2_ocean_cor = read_fco2_ocean_cor_omp
-    var_fco2_ocean_cor = var_fco2_ocean_cor_omp
-    read_fco2_land_cor = read_fco2_land_cor_omp
-    var_fco2_land_cor = var_fco2_land_cor_omp
-    dms_cycle_cpl = dms_cycle_cpl_omp
-    n2o_cycle_cpl = n2o_cycle_cpl_omp
-    !rajout Olivier Torres
-    kz0=kz0_omp
-    choix_bulk = choix_bulk_omp
-    nit_bulk = nit_bulk_omp
-
-    ! Test of coherence between type_ocean and version_ocean
-    IF (type_ocean=='couple' .AND. (version_ocean/='opa8' .AND. version_ocean/='nemo') ) THEN
-       WRITE(lunout,*)' ERROR version_ocean=',version_ocean,' not valid in coupled configuration'
-       CALL abort_physic('conf_phys','version_ocean not valid',1)
-    ENDIF
-
-    IF (type_ocean=='slab' .AND. version_ocean=='xxxxxx') THEN
-       version_ocean='sicOBS'
-    ELSE IF (type_ocean=='slab' .AND. version_ocean/='sicOBS' &
-         .AND. version_ocean/='sicINT' .AND. version_ocean/='sicNO') THEN
-       WRITE(lunout,*)' ERROR version_ocean=',version_ocean,' not valid with slab ocean'
-       CALL abort_physic('conf_phys','version_ocean not valid',1)
-    ENDIF
-
-    !--test on radiative scheme 
-    IF (iflag_rrtm .EQ. 0) THEN 
-      IF (NSW.NE.2) THEN 
-        WRITE(lunout,*) ' ERROR iflag_rrtm=0 and NSW<>2 not possible'
-        CALL abort_physic('conf_phys','choice NSW not valid',1)
-      ENDIF
-    ELSE IF (iflag_rrtm .EQ. 1) THEN
-      IF (NSW.NE.2.AND.NSW.NE.4.AND.NSW.NE.6) THEN
-        WRITE(lunout,*) ' ERROR iflag_rrtm=1 and NSW<>2,4,6 not possible'
-        CALL abort_physic('conf_phys','choice NSW not valid',1)
-      ENDIF
-   ELSE IF (iflag_rrtm .EQ. 2) THEN
-      IF (NSW.NE.2.AND.NSW.NE.4.AND.NSW.NE.6) THEN
-        WRITE(lunout,*) ' ERROR iflag_rrtm=1 and NSW<>2,4,6 not possible'
-        CALL abort_physic('conf_phys','choice NSW not valid',1)
-      ENDIF
-    ELSE 
-       WRITE(lunout,*) ' ERROR iflag_rrtm<>0,1'
-       CALL abort_physic('conf_phys','choice iflag_rrtm not valid',1)
-    ENDIF
-    !--here we test that solaire has not been changed if ok_suntime_rrtm is activated
-!    IF (ok_suntime_rrtm.AND.ABS(solaire-solaire_omp_init).GT.1.E-7) THEN 
-!       WRITE(lunout,*) ' ERROR ok_suntime_rrtm=y and solaire is provided in def file'
-!       CALL abort_physic('conf_phys','ok_suntime_rrtm=y and solaire is provided',1)
-!    ENDIF
-IF (CPPKEY_STRATAER) THEN
-    IF (iflag_rrtm .NE. 1) THEN
-       WRITE(lunout,*) ' ERROR iflag_rrtm<>1 but StratAer activated'
-       CALL abort_physic('conf_phys','iflag_rrtm not valid for StratAer',1)
-    ENDIF
-    IF (NSW .NE. 6) THEN
-       WRITE(lunout,*) ' ERROR NSW<>6 but StratAer activated'
-       CALL abort_physic('conf_phys','NSW not valid for StratAer',1)
-    ENDIF
-END IF
-
-    !--test on ocean surface albedo
-    IF (iflag_albedo.LT.0.OR.iflag_albedo.GT.2) THEN
-       WRITE(lunout,*) ' ERROR iflag_albedo<>0,1'
-       CALL abort_physic('conf_phys','choice iflag_albedo not valid',1)
-    ENDIF
-
-    ! Flag_aerosol cannot be set to zero if aerosol direct effect (ade) or aerosol indirect effect (aie) are activated
-    IF (ok_ade .OR. ok_aie) THEN 
-       IF ( flag_aerosol .EQ. 0 ) THEN
-          CALL abort_physic('conf_phys','flag_aerosol=0 not compatible avec ok_ade ou ok_aie=.TRUE.',1)
-       ENDIF
-    ENDIF
-
-    ! Flag_aerosol cannot be set to zero if we are in coupled mode for aerosol
-    IF (aerosol_couple .AND. flag_aerosol .EQ. 0 ) THEN
-       CALL abort_physic('conf_phys', 'flag_aerosol cannot be to zero if aerosol_couple=y ', 1)
-    ENDIF
-
-    ! Read_climoz needs to be set zero if we are in couple mode for chemistry 
-    IF (chemistry_couple .AND. read_climoz .ne. 0) THEN 
-       CALL abort_physic('conf_phys', 'read_climoz need to be to zero if chemistry_couple=y ', 1) 
-    ENDIF
-
-    ! flag_aerosol need to be different to zero if ok_cdnc is activated
-    IF (ok_cdnc .AND. flag_aerosol .EQ. 0) THEN
-       CALL abort_physic('conf_phys', 'flag_aerosol cannot be to zero if ok_cdnc is activated ', 1)
-    ENDIF
-
-    ! ok_cdnc must be set to y if ok_aie is activated
-    IF (ok_aie .AND. .NOT. ok_cdnc) THEN
-       CALL abort_physic('conf_phys', 'ok_cdnc must be set to y if ok_aie is activated',1)
-    ENDIF
-
-    ! flag_aerosol=7 => MACv2SP climatology 
-    IF (flag_aerosol.EQ.7.AND. iflag_rrtm.NE.1) THEN
-       CALL abort_physic('conf_phys', 'flag_aerosol=7 (MACv2SP) can only be activated with RRTM',1)
-    ENDIF
-    IF (flag_aerosol.EQ.7.AND. NSW.NE.6) THEN
-       CALL abort_physic('conf_phys', 'flag_aerosol=7 (MACv2SP) can only be activated with NSW=6',1)
-    ENDIF
-
-    ! BC internal mixture is only possible with RRTM & NSW=6 & flag_aerosol=6 or aerosol_couple
-    IF (flag_bc_internal_mixture .AND. NSW.NE.6) THEN 
-       CALL abort_physic('conf_phys', 'flag_bc_internal_mixture can only be activated with NSW=6',1)
-    ENDIF
-    IF (flag_bc_internal_mixture .AND. iflag_rrtm.NE.1) THEN 
-       CALL abort_physic('conf_phys', 'flag_bc_internal_mixture can only be activated with RRTM',1)
-    ENDIF
-    IF (flag_bc_internal_mixture .AND. flag_aerosol.NE.6) THEN 
-       CALL abort_physic('conf_phys', 'flag_bc_internal_mixture can only be activated with flag_aerosol=6',1)
-    ENDIF
-
-    ! test sur flag_volc_surfstrat
-    IF (flag_volc_surfstrat.LT.0.OR.flag_volc_surfstrat.GT.2) THEN
-       CALL abort_physic('conf_phys', 'flag_volc_surfstrat can only be 0 1 or 2',1)
-    ENDIF 
-    IF ((.NOT.ok_volcan.OR..NOT.ok_ade.OR..NOT.ok_aie).AND.flag_volc_surfstrat.GT.0) THEN
-       CALL abort_physic('conf_phys', 'ok_ade, ok_aie, ok_volcan need to be activated if flag_volc_surfstrat is 1 or 2',1)
-    ENDIF 
-
-    ! Test on carbon cycle
-    IF (carbon_cycle_tr .AND. .NOT. carbon_cycle_cpl) THEN
-       CALL abort_physic('conf_phys', 'carbon_cycle_cpl has to be TRUE if carbon_cycle_tr is on',1)
-    ENDIF
-    IF (carbon_cycle_rad .AND. .NOT. carbon_cycle_cpl) THEN
-       CALL abort_physic('conf_phys', 'carbon_cycle_cpl has to be TRUE if carbon_cycle_rad is on',1)
-    ENDIF
-
-
-    ! Test on chemistry cycle 
-    IF ((type_trac .ne. "inca" .AND. type_trac .ne. "inco") .AND. ( dms_cycle_cpl .OR. n2o_cycle_cpl)  ) THEN 
-       CALL abort_physic('conf_phys', 'dms_cycle_cpl or n2o_cycle_cpl has to be TRUE only with INCA coupling model',1)
-    ENDIF
-    
-    ! ORCHIDEE must be activated for ifl_pbltree=1
-    IF (.NOT. ok_veget .AND. ifl_pbltree==1) THEN
-       WRITE(lunout,*)'Warning: ORCHIDEE must be activated for ifl_pbltree=1'
-       WRITE(lunout,*)'ifl_pbltree is now changed to zero'
-       ifl_pbltree=0
-    ENDIF
-
-    !$OMP MASTER
-
-    WRITE(lunout,*) ' ##############################################'
-    WRITE(lunout,*) ' Configuration des parametres de la physique: '
-    WRITE(lunout,*) ' Type ocean = ', type_ocean
-    WRITE(lunout,*) ' Version ocean = ', version_ocean
-    WRITE(lunout,*) ' Config veget = ', ok_veget,type_veget
-    WRITE(lunout,*) ' Snow model landice : landice_opt = ', landice_opt
-    WRITE(lunout,*) ' Config xml pour XIOS : ok_all_xml = ', ok_all_xml
-    WRITE(lunout,*) ' Sortie journaliere = ', ok_journe
-    WRITE(lunout,*) ' Sortie haute frequence = ', ok_hf
-    WRITE(lunout,*) ' Sortie mensuelle = ', ok_mensuel
-    WRITE(lunout,*) ' Sortie instantanee = ', ok_instan
-    WRITE(lunout,*) ' Frequence appel simulateur ISCCP, freq_ISCCP =', freq_ISCCP
-    WRITE(lunout,*) ' Frequence appel simulateur ISCCP, ecrit_ISCCP =', ecrit_ISCCP
-    WRITE(lunout,*) ' Frequence appel simulateur COSP, freq_COSP =', freq_COSP
-    WRITE(lunout,*) ' Frequence appel simulateur AIRS, freq_AIRS =', freq_AIRS
-    WRITE(lunout,*) ' Sortie bilan d''energie, ip_ebil_phy =', ip_ebil_phy
-    WRITE(lunout,*) ' Excentricite = ',R_ecc
-    WRITE(lunout,*) ' Equinoxe = ',R_peri
-    WRITE(lunout,*) ' Inclinaison =',R_incl
-    WRITE(lunout,*) ' Constante solaire =',solaire
-    WRITE(lunout,*) ' ok_suntime_rrtm =',ok_suntime_rrtm
-    WRITE(lunout,*) ' co2_ppm =',co2_ppm
-    WRITE(lunout,*) ' co2_ppm0 =',co2_ppm0
-    WRITE(lunout,*) ' RCO2_act = ',RCO2_act
-    WRITE(lunout,*) ' CH4_ppb =',CH4_ppb,' RCH4_act = ',RCH4_act
-    WRITE(lunout,*) ' N2O_ppb =',N2O_ppb,' RN2O_act=  ',RN2O_act
-    WRITE(lunout,*) ' CFC11_ppt=',CFC11_ppt,' RCFC11_act=  ',RCFC11_act
-    WRITE(lunout,*) ' CFC12_ppt=',CFC12_ppt,' RCFC12_act=  ',RCFC12_act
-    WRITE(lunout,*) ' RCO2_per = ',RCO2_per,' RCH4_per = ', RCH4_per
-    WRITE(lunout,*) ' RN2O_per = ',RN2O_per,' RCFC11_per = ', RCFC11_per
-    WRITE(lunout,*) ' RCFC12_per = ',RCFC12_per
-    WRITE(lunout,*) ' cvl_comp_threshold=', cvl_comp_threshold
-    WRITE(lunout,*) ' cvl_sig2feed=', cvl_sig2feed
-    WRITE(lunout,*) ' cvl_corr=', cvl_corr
-    WRITE(lunout,*) ' ok_lic_melt=', ok_lic_melt
-    WRITE(lunout,*) ' ok_lic_cond=', ok_lic_cond
-    WRITE(lunout,*) ' iflag_cycle_diurne=',iflag_cycle_diurne
-    WRITE(lunout,*) ' soil_model=',soil_model
-    WRITE(lunout,*) ' new_oliq=',new_oliq
-    WRITE(lunout,*) ' ok_orodr=',ok_orodr
-    WRITE(lunout,*) ' ok_orolf=',ok_orolf
-    WRITE(lunout,*) ' zrel_oro_t=',zrel_oro_t
-    WRITE(lunout,*) ' zstd_orodr_t=',zstd_orodr_t
-    WRITE(lunout,*) ' zpmm_orodr_t=',zpmm_orodr_t
-    WRITE(lunout,*) ' zpmm_orolf_t=',zpmm_orolf_t
-    WRITE(lunout,*) ' ok_limitvrai=',ok_limitvrai
-    WRITE(lunout,*) ' nbapp_rad=',nbapp_rad
-    WRITE(lunout,*) ' iflag_con=',iflag_con
-    WRITE(lunout,*) ' nbapp_cv=',nbapp_cv
-    WRITE(lunout,*) ' nbapp_wk=',nbapp_wk
-    WRITE(lunout,*) ' iflag_ener_conserv=',iflag_ener_conserv
-    WRITE(lunout,*) ' ok_conserv_q=',ok_conserv_q
-    WRITE(lunout,*) ' epmax = ', epmax
-    WRITE(lunout,*) ' coef_epmax_cape = ', coef_epmax_cape
-    WRITE(lunout,*) ' ok_adj_ema = ', ok_adj_ema
-    WRITE(lunout,*) ' iflag_clw = ', iflag_clw
-    WRITE(lunout,*) ' iflag_cld_th = ', iflag_cld_th
-    WRITE(lunout,*) ' iflag_cld_cv = ', iflag_cld_cv
-    WRITE(lunout,*) ' tau_cld_cv = ', tau_cld_cv
-    WRITE(lunout,*) ' coefw_cld_cv = ', coefw_cld_cv
-    WRITE(lunout,*) ' iflag_radia = ', iflag_radia
-    WRITE(lunout,*) ' iflag_rrtm = ', iflag_rrtm
-    WRITE(lunout,*) ' NSW = ', NSW
-    WRITE(lunout,*) ' iflag_albedo = ', iflag_albedo !albedo SB
-    WRITE(lunout,*) ' ok_chlorophyll =',ok_chlorophyll ! albedo SB
-    WRITE(lunout,*) ' iflag_ratqs = ', iflag_ratqs
-    WRITE(lunout,*) ' seuil_inversion = ', seuil_inversion
-    WRITE(lunout,*) ' fact_cldcon = ', fact_cldcon
-    WRITE(lunout,*) ' facttemps = ', facttemps
-    WRITE(lunout,*) ' ok_newmicro = ',ok_newmicro 
-    WRITE(lunout,*) ' ratqsbas = ',ratqsbas 
-    WRITE(lunout,*) ' ratqshaut = ',ratqshaut 
-    WRITE(lunout,*) ' tau_ratqs = ',tau_ratqs 
-    WRITE(lunout,*) ' top_height = ',top_height 
-    WRITE(lunout,*) ' rad_froid = ',rad_froid
-    WRITE(lunout,*) ' rad_chau1 = ',rad_chau1
-    WRITE(lunout,*) ' rad_chau2 = ',rad_chau2
-    WRITE(lunout,*) ' iflag_ice_thermo = ',iflag_ice_thermo
-    WRITE(lunout,*) ' ok_ice_supersat = ',ok_ice_supersat
-    WRITE(lunout,*) ' ok_plane_h2o = ',ok_plane_h2o
-    WRITE(lunout,*) ' ok_plane_contrail = ',ok_plane_contrail
-    WRITE(lunout,*) ' overlap = ',overlap 
-    WRITE(lunout,*) ' cdmmax = ',cdmmax 
-    WRITE(lunout,*) ' cdhmax = ',cdhmax 
-    WRITE(lunout,*) ' ksta = ',ksta 
-    WRITE(lunout,*) ' ksta_ter = ',ksta_ter 
-    WRITE(lunout,*) ' f_ri_cd_min = ',f_ri_cd_min 
-    WRITE(lunout,*) ' ok_kzmin = ',ok_kzmin 
-    WRITE(lunout,*) ' fmagic = ',fmagic
-    WRITE(lunout,*) ' pmagic = ',pmagic
-    WRITE(lunout,*) ' ok_ade = ',ok_ade
-    WRITE(lunout,*) ' ok_volcan = ',ok_volcan
-    WRITE(lunout,*) ' flag_volc_surfstrat = ',flag_volc_surfstrat
-    WRITE(lunout,*) ' ok_aie = ',ok_aie
-    WRITE(lunout,*) ' ok_alw = ',ok_alw
-    WRITE(lunout,*) ' aerosol_couple = ', aerosol_couple
-    WRITE(lunout,*) ' chemistry_couple = ', chemistry_couple
-    WRITE(lunout,*) ' flag_aerosol = ', flag_aerosol
-    WRITE(lunout,*) ' flag_aerosol_strat= ', flag_aerosol_strat
-    WRITE(lunout,*) ' flag_aer_feedback= ', flag_aer_feedback
-    WRITE(lunout,*) ' aer_type = ',aer_type
-    WRITE(lunout,*) ' bl95_b0 = ',bl95_b0
-    WRITE(lunout,*) ' bl95_b1 = ',bl95_b1
-    WRITE(lunout,*) ' lev_histhf = ',lev_histhf 
-    WRITE(lunout,*) ' lev_histday = ',lev_histday 
-    WRITE(lunout,*) ' lev_histmth = ',lev_histmth 
-    WRITE(lunout,*) ' lev_histins = ',lev_histins
-    WRITE(lunout,*) ' lev_histLES = ',lev_histLES
-    WRITE(lunout,*) ' lev_histdayNMC = ',lev_histdayNMC
-    WRITE(lunout,*) ' levout_histNMC = ',levout_histNMC
-    WRITE(lunout,*) ' ok_histNMC = ',ok_histNMC
-    WRITE(lunout,*) ' freq_outNMC = ',freq_outNMC
-    WRITE(lunout,*) ' freq_calNMC = ',freq_calNMC
-    WRITE(lunout,*) ' iflag_pbl = ', iflag_pbl
-    WRITE(lunout,*) ' iflag_physiq = ', iflag_physiq
-!FC
-    WRITE(lunout,*) ' ifl_pbltree = ', ifl_pbltree
-    WRITE(lunout,*) ' Cd_frein = ', Cd_frein
-    WRITE(lunout,*) ' iflag_pbl_split = ', iflag_pbl_split
-    WRITE(lunout,*) ' iflag_order2_sollw = ', iflag_order2_sollw
-    WRITE(lunout,*) ' iflag_thermals = ', iflag_thermals
-    WRITE(lunout,*) ' iflag_clos = ', iflag_clos
-    WRITE(lunout,*) ' coef_clos_ls = ', coef_clos_ls
-    WRITE(lunout,*) ' type_run = ',type_run 
-    WRITE(lunout,*) ' ok_cosp = ',ok_cosp
-    WRITE(lunout,*) ' ok_airs = ',ok_airs
-
-    WRITE(lunout,*) ' ok_mensuelCOSP = ',ok_mensuelCOSP
-    WRITE(lunout,*) ' ok_journeCOSP = ',ok_journeCOSP
-    WRITE(lunout,*) ' ok_hfCOSP =',ok_hfCOSP
-    WRITE(lunout,*) ' solarlong0 = ', solarlong0
-    WRITE(lunout,*) ' qsol0 = ', qsol0
-    WRITE(lunout,*) ' evap0 = ', evap0
-    WRITE(lunout,*) ' albsno0 = ', albsno0
-    WRITE(lunout,*) ' iflag_sic = ', iflag_sic
-    WRITE(lunout,*) ' iflag_inertie = ', iflag_inertie
-    WRITE(lunout,*) ' inertie_sol = ', inertie_sol
-    WRITE(lunout,*) ' inertie_sic = ', inertie_sic
-    WRITE(lunout,*) ' inertie_lic = ', inertie_lic
-    WRITE(lunout,*) ' inertie_sno = ', inertie_sno
-    WRITE(lunout,*) ' ok_bs = ', ok_bs
-    WRITE(lunout,*) ' ok_rad_bs = ', ok_rad_bs
-    WRITE(lunout,*) ' f_cdrag_ter = ',f_cdrag_ter
-    WRITE(lunout,*) ' f_cdrag_oce = ',f_cdrag_oce
-    WRITE(lunout,*) ' f_rugoro = ',f_rugoro
-    WRITE(lunout,*) ' z0min = ',z0min
-    WRITE(lunout,*) ' supcrit1 = ', supcrit1
-    WRITE(lunout,*) ' supcrit2 = ', supcrit2
-    WRITE(lunout,*) ' iflag_mix = ', iflag_mix
-    WRITE(lunout,*) ' iflag_mix_adiab = ', iflag_mix_adiab
-    WRITE(lunout,*) ' scut = ', scut
-    WRITE(lunout,*) ' qqa1 = ', qqa1
-    WRITE(lunout,*) ' qqa2 = ', qqa2
-    WRITE(lunout,*) ' gammas = ', gammas
-    WRITE(lunout,*) ' Fmax = ', Fmax
-    WRITE(lunout,*) ' tmax_fonte_cv = ', tmax_fonte_cv
-    WRITE(lunout,*) ' alphas = ', alphas
-    WRITE(lunout,*) ' iflag_wake = ', iflag_wake
-    WRITE(lunout,*) ' alp_offset = ', alp_offset
-    ! nrlmd le 10/04/2012
-    WRITE(lunout,*) ' iflag_trig_bl = ', iflag_trig_bl
-    WRITE(lunout,*) ' iflag_strig = ', iflag_strig
-    WRITE(lunout,*) ' s_trig = ', s_trig
-    WRITE(lunout,*) ' h_trig = ', h_trig
-    WRITE(lunout,*) ' tau_trig_shallow = ', tau_trig_shallow
-    WRITE(lunout,*) ' tau_trig_deep = ', tau_trig_deep
-    WRITE(lunout,*) ' iflag_clos_bl = ', iflag_clos_bl
-    ! fin nrlmd le 10/04/2012
-
-    WRITE(lunout,*) ' lonmin lonmax latmin latmax bilKP_ins =',&
-         lonmin_ins, lonmax_ins, latmin_ins, latmax_ins
-    WRITE(lunout,*) ' ecrit_ hf, ins, day, mth, reg, tra, ISCCP, LES',&
-         ecrit_hf, ecrit_ins, ecrit_day, ecrit_mth, ecrit_reg, ecrit_tra, ecrit_ISCCP, ecrit_LES
-
-    WRITE(lunout,*) ' ok_strato = ', ok_strato
-    WRITE(lunout,*) ' ok_hines = ',  ok_hines
-    WRITE(lunout,*) ' ok_gwd_rando = ',  ok_gwd_rando
-    WRITE(lunout,*) ' ok_qch4 = ',  ok_qch4
-    WRITE(lunout,*) ' gwd_rando_ruwmax = ', gwd_rando_ruwmax
-    WRITE(lunout,*) ' gwd_rando_sat = ', gwd_rando_sat
-    WRITE(lunout,*) ' gwd_front_ruwmax = ', gwd_front_ruwmax
-    WRITE(lunout,*) ' gwd_front_sat = ', gwd_front_sat
-    WRITE(lunout,*) ' SSO gkdrag =',gkdrag
-    WRITE(lunout,*) ' SSO grahilo=',grahilo
-    WRITE(lunout,*) ' SSO grcrit=',grcrit
-    WRITE(lunout,*) ' SSO gfrcrit=',gfrcrit
-    WRITE(lunout,*) ' SSO gkwake=',gkwake
-    WRITE(lunout,*) ' SSO gklift=',gklift
-    WRITE(lunout,*) ' adjust_tropopause = ', adjust_tropopause
-    WRITE(lunout,*) ' ok_daily_climoz = ',ok_daily_climoz
-    WRITE(lunout,*) ' ok_new_lscp = ', ok_new_lscp
-    WRITE(lunout,*) ' ok_icefra_lscp = ', ok_icefra_lscp
-    WRITE(lunout,*) ' read_climoz = ', read_climoz
-    WRITE(lunout,*) ' carbon_cycle_tr = ', carbon_cycle_tr
-    WRITE(lunout,*) ' carbon_cycle_cpl = ', carbon_cycle_cpl
-    WRITE(lunout,*) ' carbon_cycle_rad = ', carbon_cycle_rad
-    WRITE(lunout,*) ' level_coupling_esm = ', level_coupling_esm
-    WRITE(lunout,*) ' read_fco2_ocean_cor = ', read_fco2_ocean_cor
-    WRITE(lunout,*) ' var_fco2_ocean_cor = ', var_fco2_ocean_cor
-    WRITE(lunout,*) ' read_fco2_land_cor = ', read_fco2_land_cor
-    WRITE(lunout,*) ' var_fco2_land_cor = ', var_fco2_land_cor
-    WRITE(lunout,*) ' dms_cycle_cpl = ', dms_cycle_cpl
-    WRITE(lunout,*) ' n2o_cycle_cpl = ', n2o_cycle_cpl
-    WRITE(lunout,*) ' iflag_tsurf_inlandsis = ', iflag_tsurf_inlandsis
-    WRITE(lunout,*) ' iflag_temp_inlandsis = ', iflag_temp_inlandsis
-    WRITE(lunout,*) ' iflag_albcalc = ', iflag_albcalc
-    WRITE(lunout,*) ' SnoMod = ', SnoMod
-    WRITE(lunout,*) ' BloMod = ', BloMod
-    WRITE(lunout,*) ' ok_outfor = ', ok_outfor
-    WRITE(lunout,*) ' is_ok_slush = ', is_ok_slush
-    WRITE(lunout,*) ' opt_runoff_ac = ', opt_runoff_ac
-    WRITE(lunout,*) ' is_ok_z0h_rn = ', is_ok_z0h_rn
-    WRITE(lunout,*) ' is_ok_density_kotlyakov = ', is_ok_density_kotlyakov
-    WRITE(lunout,*) ' prescribed_z0m_snow = ', prescribed_z0m_snow
-    WRITE(lunout,*) ' iflag_z0m_snow = ', iflag_z0m_snow
-    WRITE(lunout,*) ' ok_zsn_ii = ', ok_zsn_ii
-    WRITE(lunout,*) ' discret_xf = ', discret_xf
-    WRITE(lunout,*) ' correc_alb= ', correc_alb
-    WRITE(lunout,*) ' buf_sph_pol = ', buf_sph_pol
-    WRITE(lunout,*) ' buf_siz_pol= ', buf_siz_pol
-    !rajout Olivier Torres
-    write(lunout,*) 'choix_bulk = ', choix_bulk
-    write(lunout,*) 'nit_bulk = ', nit_bulk
-    write(lunout,*) 'kz0 = ', kz0
-
-    !$OMP END MASTER
-    call config_ocean_skin
-
-  END SUBROUTINE conf_phys
-
-END MODULE conf_phys_m
-!
-!#################################################################
-!
-
-SUBROUTINE conf_interface(tau_calv)
-
-  USE IOIPSL
-  USE print_control_mod, ONLY: lunout
-  IMPLICIT NONE
-  ! Configuration de l'interace atm/surf
-  !
-  ! tau_calv:    temps de relaxation pour la fonte des glaciers
-  !
-  REAL          :: tau_calv
-  REAL, SAVE    :: tau_calv_omp
-  !
-  !Config Key  = tau_calv
-  !Config Desc = temps de relaxation pour fonte des glaciers en jours
-  !Config Def  = 1 an 
-  !Config Help = 
-  !
-  tau_calv_omp = 360.*10.
-  !$OMP MASTER
-  CALL getin('tau_calv',tau_calv_omp)
-  !$OMP END MASTER
-  !$OMP BARRIER
-  !
-  tau_calv=tau_calv_omp
-  !
-  !$OMP MASTER
-  WRITE(lunout,*)' ##############################################'
-  WRITE(lunout,*)' Configuration de l''interface atm/surfaces  : '
-  WRITE(lunout,*)' tau_calv = ',tau_calv
-  !$OMP END MASTER
-  !
-  RETURN
-
-END SUBROUTINE conf_interface
Index: /LMDZ6/trunk/libf/phylmd/conf_phys_m.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/conf_phys_m.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/conf_phys_m.f90	(revision 5268)
@@ -0,0 +1,2963 @@
+!
+! $Id: conf_phys.F90 1668 2012-10-12 10:47:37Z idelkadi $
+!
+!
+!
+MODULE conf_phys_m
+
+  IMPLICIT NONE
+
+CONTAINS
+
+  SUBROUTINE conf_phys(ok_journe, ok_mensuel, ok_instan, ok_hf, &
+       ok_LES,&
+       callstats,&
+       solarlong0,seuil_inversion, &
+       fact_cldcon, facttemps,ok_newmicro,iflag_radia,&
+       iflag_cld_th, &
+       ratqsbas,ratqshaut,tau_ratqs, &
+       ok_ade, ok_aie, ok_alw, ok_cdnc, ok_volcan, flag_volc_surfstrat, aerosol_couple, & 
+       chemistry_couple, flag_aerosol, flag_aerosol_strat, flag_aer_feedback, &
+       flag_bc_internal_mixture, bl95_b0, bl95_b1,&
+       read_climoz, &
+       alp_offset)
+
+    USE IOIPSL
+    USE surface_data
+    USE phys_cal_mod
+    USE carbon_cycle_mod,  ONLY: carbon_cycle_tr, carbon_cycle_cpl, carbon_cycle_rad, level_coupling_esm
+    USE carbon_cycle_mod,  ONLY: read_fco2_ocean_cor,var_fco2_ocean_cor
+    USE carbon_cycle_mod,  ONLY: read_fco2_land_cor,var_fco2_land_cor
+    USE chemistry_cycle_mod, ONLY: dms_cycle_cpl, n2o_cycle_cpl
+    USE mod_grid_phy_lmdz, ONLY: klon_glo
+    USE print_control_mod, ONLY: lunout
+    use config_ocean_skin_m, only: config_ocean_skin
+    USE phys_state_var_mod, ONLY: phys_tstep
+    USE infotrac_phy, ONLY: type_trac
+    USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_STRATAER
+
+    INCLUDE "conema3.h"
+    INCLUDE "nuage.h"
+    INCLUDE "YOMCST.h"
+    INCLUDE "YOMCST2.h"
+    INCLUDE "alpale.h"
+
+    !IM : on inclut/initialise les taux de CH4, N2O, CFC11 et CFC12
+    INCLUDE "clesphys.h"
+    INCLUDE "compbl.h"
+    INCLUDE "comsoil.h"
+    INCLUDE "YOEGWD.h"
+    !
+    ! Configuration de la "physique" de LMDZ a l'aide de la fonction
+    ! GETIN de IOIPSL
+    !
+    ! LF 05/2001
+    !
+    ! type_ocean:      type d'ocean (force, slab, couple)
+    ! version_ocean:   version d'ocean (opa8/nemo pour type_ocean=couple ou 
+    !                                   sicOBS,sicINT,sicNO pour type_ocean=slab)
+    ! ok_veget:   type de modele de vegetation
+    ! ok_journe:  sorties journalieres
+    ! ok_hf:  sorties haute frequence
+    ! ok_mensuel: sorties mensuelles
+    ! ok_instan:  sorties instantanees
+    ! ok_ade, ok_aie: apply or not aerosol direct and indirect effects
+    ! ok_alw: activate aerosol LW effect
+    ! ok_cdnc, ok cloud droplet number concentration
+    ! flag_aerosol_strat : flag pour les aerosols stratos
+    ! flag_bc_internal_mixture : use BC internal mixture if true
+    ! bl95_b*: parameters in the formula to link CDNC to aerosol mass conc 
+    ! ok_volcan: activate volcanic diags (SW heat & LW cool rate, SW & LW flux)
+    ! flag_volc_surfstrat: VolMIP flag, activate forcing surface cooling rate (=1), strato heating rate (=2) or nothing (=0, default)
+    !
+
+    ! Sortie:
+    LOGICAL              :: ok_newmicro
+    INTEGER              :: iflag_radia
+    LOGICAL              :: ok_journe, ok_mensuel, ok_instan, ok_hf
+    LOGICAL              :: ok_LES
+    LOGICAL              :: callstats
+    LOGICAL              :: ok_ade, ok_aie, ok_alw, ok_cdnc, ok_volcan
+    LOGICAL              :: aerosol_couple, chemistry_couple
+    INTEGER              :: flag_aerosol
+    INTEGER              :: flag_aerosol_strat
+    INTEGER              :: flag_volc_surfstrat
+    LOGICAL              :: flag_aer_feedback
+    LOGICAL              :: flag_bc_internal_mixture
+    REAL                 :: bl95_b0, bl95_b1
+    REAL                 :: fact_cldcon, facttemps,ratqsbas,ratqshaut,tau_ratqs
+    INTEGER              :: iflag_cld_th
+     
+
+    CHARACTER (len = 6), SAVE  :: type_ocean_omp, version_ocean_omp, ocean_omp
+    CHARACTER (len = 10),SAVE  :: type_veget_omp
+    CHARACTER (len = 8), SAVE  :: aer_type_omp
+    INTEGER, SAVE       :: landice_opt_omp
+    INTEGER, SAVE       :: iflag_tsurf_inlandsis_omp,iflag_temp_inlandsis_omp
+    INTEGER, SAVE       :: iflag_albcalc_omp,iflag_z0m_snow_omp   
+    LOGICAL, SAVE       :: SnoMod_omp,BloMod_omp,ok_outfor_omp,ok_zsn_ii_omp
+    LOGICAL, SAVE       :: discret_xf_omp,opt_runoff_ac_omp  
+    LOGICAL, SAVE       :: is_ok_slush_omp,is_ok_z0h_rn_omp,is_ok_density_kotlyakov_omp
+    REAL, SAVE          :: prescribed_z0m_snow_omp,correc_alb_omp
+    REAL, SAVE          :: buf_sph_pol_omp,buf_siz_pol_omp
+    LOGICAL, SAVE       :: ok_newmicro_omp
+    LOGICAL, SAVE       :: ok_all_xml_omp
+    LOGICAL, SAVE       :: ok_lwoff_omp
+    LOGICAL, SAVE       :: ok_journe_omp, ok_mensuel_omp, ok_instan_omp, ok_hf_omp        
+    LOGICAL, SAVE       :: ok_LES_omp   
+    LOGICAL, SAVE       :: callstats_omp
+    LOGICAL, SAVE       :: ok_ade_omp, ok_aie_omp, ok_alw_omp, ok_cdnc_omp, ok_volcan_omp
+    LOGICAL, SAVE       :: aerosol_couple_omp, chemistry_couple_omp
+    INTEGER, SAVE       :: flag_aerosol_omp
+    INTEGER, SAVE       :: flag_aerosol_strat_omp
+    INTEGER, SAVE       :: flag_volc_surfstrat_omp
+    LOGICAL, SAVE       :: flag_aer_feedback_omp
+    LOGICAL, SAVE       :: flag_bc_internal_mixture_omp
+    REAL,SAVE           :: bl95_b0_omp, bl95_b1_omp
+    REAL,SAVE           :: freq_ISCCP_omp, ecrit_ISCCP_omp
+    REAL,SAVE           :: freq_COSP_omp, freq_AIRS_omp 
+    REAL,SAVE           :: fact_cldcon_omp, facttemps_omp,ratqsbas_omp
+    REAL,SAVE           :: tau_cld_cv_omp, coefw_cld_cv_omp
+    INTEGER, SAVE       :: iflag_cld_cv_omp
+
+    REAL, SAVE          :: ratqshaut_omp
+    REAL, SAVE          :: tau_ratqs_omp
+    REAL, SAVE          :: t_coupl_omp
+    INTEGER, SAVE       :: iflag_radia_omp
+    INTEGER, SAVE       :: iflag_rrtm_omp
+    INTEGER, SAVE       :: iflag_albedo_omp !albedo SB
+    LOGICAL, SAVE       :: ok_chlorophyll_omp ! albedo SB  
+    INTEGER, SAVE       :: NSW_omp
+    INTEGER, SAVE       :: iflag_cld_th_omp, ip_ebil_phy_omp
+    INTEGER, SAVE       :: iflag_ratqs_omp
+
+    REAL, SAVE          :: f_cdrag_ter_omp,f_cdrag_oce_omp
+    REAL, SAVE          :: f_rugoro_omp   , z0min_omp
+    REAL, SAVE          :: z0m_seaice_omp,z0h_seaice_omp
+    REAL, SAVE          :: z0m_landice_omp,z0h_landice_omp
+    REAL, SAVE          :: min_wind_speed_omp,f_gust_wk_omp,f_gust_bl_omp,f_qsat_oce_omp, f_z0qh_oce_omp
+    INTEGER, SAVE       :: iflag_gusts_omp,iflag_z0_oce_omp
+
+    REAL :: seuil_inversion
+    REAL,SAVE :: seuil_inversion_omp
+
+    INTEGER,SAVE :: iflag_thermals_omp,nsplit_thermals_omp
+    REAL,SAVE :: tau_thermals_omp,alp_bl_k_omp
+    ! nrlmd le 10/04/2012
+    INTEGER,SAVE :: iflag_trig_bl_omp,iflag_clos_bl_omp,iflag_strig_omp
+    INTEGER,SAVE :: tau_trig_shallow_omp,tau_trig_deep_omp
+    REAL,SAVE    :: s_trig_omp,h_trig_omp
+    ! fin nrlmd le 10/04/2012
+    REAL :: alp_offset
+    REAL, SAVE :: alp_offset_omp
+    INTEGER,SAVE :: iflag_coupl_omp,iflag_clos_omp,iflag_wake_omp
+    INTEGER,SAVE :: iflag_cvl_sigd_omp
+    REAL, SAVE :: coef_clos_ls_omp
+    REAL, SAVE :: supcrit1_omp, supcrit2_omp
+    INTEGER, SAVE :: iflag_mix_omp
+    INTEGER, SAVE :: iflag_mix_adiab_omp
+    REAL, SAVE :: scut_omp, qqa1_omp, qqa2_omp, gammas_omp, Fmax_omp, alphas_omp
+    REAL, SAVE :: tmax_fonte_cv_omp
+
+    REAL,SAVE :: R_ecc_omp,R_peri_omp,R_incl_omp,solaire_omp
+    REAL,SAVE :: solaire_omp_init
+    LOGICAL,SAVE :: ok_suntime_rrtm_omp
+    REAL,SAVE :: co2_ppm_omp, RCO2_omp, co2_ppm_per_omp, RCO2_per_omp
+    REAL,SAVE :: co2_ppm0_omp
+    REAL,SAVE :: CH4_ppb_omp, RCH4_omp, CH4_ppb_per_omp, RCH4_per_omp
+    REAL,SAVE :: N2O_ppb_omp, RN2O_omp, N2O_ppb_per_omp, RN2O_per_omp
+    REAL,SAVE :: CFC11_ppt_omp,RCFC11_omp,CFC11_ppt_per_omp,RCFC11_per_omp
+    REAL,SAVE :: CFC12_ppt_omp,RCFC12_omp,CFC12_ppt_per_omp,RCFC12_per_omp
+    REAL,SAVE :: epmax_omp
+    REAL,SAVE :: coef_epmax_cape_omp
+    LOGICAL,SAVE :: ok_adj_ema_omp
+    INTEGER,SAVE :: iflag_clw_omp
+    INTEGER,SAVE :: iflag_ice_thermo_omp
+    LOGICAL,SAVE :: ok_ice_supersat_omp
+    LOGICAL,SAVE :: ok_plane_h2o_omp, ok_plane_contrail_omp
+    REAL,SAVE :: rad_froid_omp, rad_chau1_omp, rad_chau2_omp
+    INTEGER,SAVE :: iflag_sic_omp, iflag_inertie_omp
+    REAL,SAVE :: inertie_sol_omp,inertie_sno_omp,inertie_sic_omp
+    REAL,SAVE :: inertie_lic_omp
+    REAL,SAVE :: qsol0_omp
+    REAL,SAVE :: evap0_omp
+    REAL,SAVE :: albsno0_omp
+    REAL      :: solarlong0
+    REAL,SAVE :: solarlong0_omp
+    INTEGER,SAVE :: top_height_omp,overlap_omp
+    REAL,SAVE :: cdmmax_omp,cdhmax_omp,ksta_omp,ksta_ter_omp,f_ri_cd_min_omp
+    LOGICAL,SAVE :: ok_kzmin_omp
+    REAL, SAVE ::  fmagic_omp, pmagic_omp
+    INTEGER,SAVE :: iflag_pbl_omp,lev_histhf_omp,lev_histday_omp,lev_histmth_omp
+    INTEGER,SAVE :: iflag_pbl_split_omp,iflag_physiq_omp
+!FC
+    INTEGER,SAVE :: ifl_pbltree_omp
+    REAL,SAVE :: Cd_frein_omp
+!FC
+    INTEGER,SAVE :: iflag_order2_sollw_omp
+    INTEGER, SAVE :: lev_histins_omp, lev_histLES_omp 
+    INTEGER, SAVE :: lev_histdayNMC_omp
+    INTEGER, SAVE :: levout_histNMC_omp(3)
+    LOGICAL, SAVE :: ok_histNMC_omp(3)
+    REAL, SAVE    :: freq_outNMC_omp(3), freq_calNMC_omp(3)
+    CHARACTER*4, SAVE :: type_run_omp
+    LOGICAL, SAVE :: ok_cosp_omp, ok_airs_omp
+    LOGICAL, SAVE :: ok_mensuelCOSP_omp,ok_journeCOSP_omp,ok_hfCOSP_omp
+    REAL, SAVE    :: lonmin_ins_omp, lonmax_ins_omp, latmin_ins_omp, latmax_ins_omp
+    REAL, SAVE    :: ecrit_hf_omp, ecrit_day_omp, ecrit_mth_omp, ecrit_reg_omp
+    REAL, SAVE    :: ecrit_ins_omp
+    REAL, SAVE    :: ecrit_LES_omp
+    REAL, SAVE    :: ecrit_tra_omp
+    REAL, SAVE    :: cvl_comp_threshold_omp
+    REAL, SAVE    :: cvl_sig2feed_omp
+    REAL, SAVE    :: cvl_corr_omp
+    LOGICAL, SAVE :: ok_lic_melt_omp
+    LOGICAL, SAVE :: ok_lic_cond_omp
+    !
+    REAL, SAVE    :: zrel_oro_t_omp, zstd_orodr_t_omp
+    REAL, SAVE    :: zpmm_orodr_t_omp, zpmm_orolf_t_omp
+    INTEGER, SAVE :: iflag_cycle_diurne_omp
+    LOGICAL, SAVE :: soil_model_omp,new_oliq_omp
+    LOGICAL, SAVE :: ok_orodr_omp, ok_orolf_omp, ok_limitvrai_omp
+    INTEGER, SAVE :: nbapp_rad_omp, iflag_con_omp
+    INTEGER, SAVE :: nbapp_cv_omp, nbapp_wk_omp
+    INTEGER, SAVE :: iflag_ener_conserv_omp
+    LOGICAL, SAVE :: ok_conserv_q_omp
+    LOGICAL,SAVE  :: ok_strato_omp
+    LOGICAL,SAVE  :: ok_hines_omp, ok_gwd_rando_omp
+    REAL, SAVE    :: gwd_rando_ruwmax_omp, gwd_rando_sat_omp
+    REAL, SAVE    :: gwd_front_ruwmax_omp, gwd_front_sat_omp
+    REAL, SAVE    :: sso_gkdrag_omp,sso_grahil_omp,sso_grcrit_omp
+    REAL, SAVE    :: sso_gfrcri_omp,sso_gkwake_omp,sso_gklift_omp
+    LOGICAL, SAVE :: ok_qch4_omp
+    LOGICAL, SAVE :: carbon_cycle_tr_omp
+    LOGICAL, SAVE :: carbon_cycle_cpl_omp
+    LOGICAL, SAVE :: carbon_cycle_rad_omp
+    LOGICAL, SAVE :: dms_cycle_cpl_omp, n2o_cycle_cpl_omp
+    INTEGER, SAVE :: level_coupling_esm_omp
+    LOGICAL, SAVE :: read_fco2_ocean_cor_omp
+    REAL, SAVE    :: var_fco2_ocean_cor_omp
+    LOGICAL, SAVE :: read_fco2_land_cor_omp
+    REAL, SAVE    :: var_fco2_land_cor_omp
+    LOGICAL, SAVE :: adjust_tropopause_omp
+    LOGICAL, SAVE :: ok_daily_climoz_omp
+    LOGICAL, SAVE :: ok_new_lscp_omp
+    LOGICAL, SAVE :: ok_icefra_lscp_omp
+    !rajout de choix_bulk et nit_bulk par Olivier Torres
+    INTEGER,SAVE  :: choix_bulk_omp
+    INTEGER,SAVE  :: nit_bulk_omp
+    INTEGER,SAVE  :: kz0_omp
+    LOGICAL, SAVE :: ok_bs_omp, ok_rad_bs_omp
+
+
+    INTEGER, INTENT(OUT):: read_climoz ! read ozone climatology, OpenMP shared
+    ! Allowed values are 0, 1 and 2
+    ! 0: do not read an ozone climatology
+    ! 1: read a single ozone climatology that will be used day and night
+    ! 2: read two ozone climatologies, the average day and night
+    ! climatology and the daylight climatology
+
+    !-----------------------------------------------------------------
+
+    print*,'CONFPHYS ENTREE'
+    !$OMP MASTER 
+    !Config Key  = type_ocean 
+    !Config Desc = Type d'ocean
+    !Config Def  = force
+    !Config Help = Type d'ocean utilise: force, slab,couple
+    !
+    type_ocean_omp = 'force '
+    CALL getin('type_ocean', type_ocean_omp)
+    !
+    !Config Key  = version_ocean 
+    !Config Desc = Version d'ocean
+    !Config Def  = xxxxxx
+    !Config Help = Version d'ocean utilise: opa8/nemo/sicOBS/xxxxxx
+    !
+    version_ocean_omp = 'xxxxxx'
+    CALL getin('version_ocean', version_ocean_omp)
+
+    !Config Key  = OCEAN
+    !Config Desc = Old parameter name for type_ocean
+    !Config Def  = yyyyyy
+    !Config Help = This is only for testing purpose
+    !
+    ocean_omp = 'yyyyyy'
+    CALL getin('OCEAN', ocean_omp)
+    IF (ocean_omp /= 'yyyyyy') THEN
+       WRITE(lunout,*)'ERROR! Old variable name OCEAN used in parmeter file.'
+       WRITE(lunout,*)'Variable OCEAN has been replaced by the variable type_ocean.'
+       WRITE(lunout,*)'You have to update your parameter file physiq.def to succed running'
+       CALL abort_physic('conf_phys','Variable OCEAN no longer existing, use variable name type_ocean',1)
+    ENDIF
+
+    !Config Key  = t_coupl
+    !Config Desc = Pas de temps du couplage atm/oce en sec.
+    !Config Def  = 86400
+    !Config Help = This is only for testing purpose
+    !
+    t_coupl_omp = 86400.
+    CALL getin('t_coupl', t_coupl_omp)
+    IF (t_coupl_omp == 0) THEN
+       WRITE(lunout,*)'ERROR! Timestep of coupling between atmosphere and ocean'
+       WRITE(lunout,*)'cannot be zero.'
+       CALL abort_physic('conf_phys','t_coupl = 0.',1)
+    ENDIF
+
+    !
+    !Config Key  = ok_all_xml 
+    !Config Desc = utiliser les xml pourles définitions des champs pour xios
+    !Config Def  = .FALSE.
+    !Config Help = 
+    !
+    ok_all_xml_omp = .FALSE.
+    CALL getin('ok_all_xml', ok_all_xml_omp)
+
+    !
+    !Config Key  = ok_lwoff
+    !Config Desc = inhiber l effet radiatif LW des nuages
+    !Config Def  = .FALSE.
+    !Config Help = 
+    !
+    ok_lwoff_omp = .FALSE.
+    CALL getin('ok_lwoff', ok_lwoff_omp)
+    !
+
+    !
+    !Config Key  = VEGET 
+    !Config Desc = Type de modele de vegetation
+    !Config Def  = .FALSE.
+    !Config Help = Type de modele de vegetation utilise
+    !
+    type_veget_omp ='orchidee'
+    CALL getin('VEGET', type_veget_omp)
+    !
+
+    ! INLANDSIS
+    !==================================================================
+    ! Martin et Etienne
+    !Config Key  = landice_opt
+    !Config Desc = which landice snow model (BULK, or INLANDSIS)
+    !Config Def  = 0
+    landice_opt_omp = 0
+    CALL getin('landice_opt', landice_opt_omp)
+    ! Martin et Etienne
+
+    !Etienne
+    !Config Key  = iflag_temp_inlandsis
+    !Config Desc = which method to calculate temp within the soil in INLANDSIS
+    !Config Def  = 0
+    iflag_temp_inlandsis_omp = 0
+    CALL getin('iflag_temp_inlandsis', iflag_temp_inlandsis_omp)
+
+    !Etienne
+    !Config Key  = iflag_tsurf_inlandsis
+    !Config Desc = which method to calculate tsurf in INLANDSIS
+    !Config Def  = 0
+    iflag_tsurf_inlandsis_omp = 1
+    CALL getin('iflag_tsurf_inlandsis', iflag_tsurf_inlandsis_omp)
+
+
+    !Etienne
+    !Config Key  = iflag_albcalc
+    !Config Desc = method to calculate snow albedo in INLANDSIS
+    !Config Def  = 0
+    iflag_albcalc_omp = 0
+    CALL getin('iflag_albcalc', iflag_albcalc_omp)
+
+
+    !Etienne
+    !Config Key  = SnoMod
+    !Config Desc = activation of snow modules in inlandsis
+    !Config Def  = .TRUE.
+    SnoMod_omp = .TRUE.
+    CALL getin('SnoMod', SnoMod_omp)
+
+    !Etienne
+    !Config Key  = BloMod
+    !Config Desc = activation of blowing snow in inlandsis
+    !Config Def  = .FALSE.
+    BloMod_omp = .FALSE.
+    CALL getin('BloMod', BloMod_omp)
+
+    !Etienne
+    !Config Key  = ok_outfor
+    !Config Desc = activation of output ascii file in inlandsis
+    !Config Def  = .FALSE.
+    ok_outfor_omp = .FALSE.
+    CALL getin('ok_outfor', ok_outfor_omp)
+
+
+    !Etienne
+    !Config Key  = ok_sn_ii
+    !Config Desc = activation of ice/snow detection
+    !Config Def  = .TRUE.
+    ok_zsn_ii_omp = .TRUE.
+    CALL getin('ok_zsn_ii', ok_zsn_ii_omp)
+
+
+    !Etienne
+    !Config Key  = discret_xf
+    !Config Desc = snow discretization following XF
+    !Config Def  = .TRUE.
+    discret_xf_omp = .TRUE.
+    CALL getin('discret_xf', discret_xf_omp)
+
+
+    !Etienne
+    !Config Key  = is_ok_slush
+    !Config Desc = activation of the slush option
+    !Config Def  = .TRUE.
+    is_ok_slush_omp = .TRUE.
+    CALL getin('is_ok_slush', is_ok_slush_omp)
+
+    !Etienne
+    !Config Key  = opt_runoff_ac
+    !Config Desc = option runoff AC
+    !Config Def  = .TRUE.
+    opt_runoff_ac_omp = .TRUE.
+    CALL getin('opt_runoff_ac', opt_runoff_ac_omp)
+
+    !Etienne
+    !Config Key  = is_ok_z0h_rn
+    !Config Desc = z0h calculation following RN method
+    !Config Def  = .TRUE.
+    is_ok_z0h_rn_omp = .TRUE.
+    CALL getin('is_ok_z0h_rn', is_ok_z0h_rn_omp)
+
+
+    !Etienne
+    !Config Key  = is_ok_density_kotlyakov
+    !Config Desc = snow density calculation following kotlyakov
+    !Config Def  = .FALSE.
+    is_ok_density_kotlyakov_omp = .FALSE.
+    CALL getin('is_ok_density_kotlyakov', is_ok_density_kotlyakov_omp)
+
+
+    !Etienne
+    !Config Key  = prescribed_z0m_snow
+    !Config Desc = prescribed snow z0m
+    !Config Def  = 0.005
+    prescribed_z0m_snow_omp = 0.005
+    CALL getin('prescribed_z0m_snow', prescribed_z0m_snow_omp)
+
+
+    !Etienne
+    !Config Key  = iflag_z0m_snow
+    !Config Desc = method to calculate snow z0m
+    !Config Def  = 0
+    iflag_z0m_snow_omp = 0
+    CALL getin('iflag_z0m_snow', iflag_z0m_snow_omp)
+
+
+    !Etienne
+    !Config Key  = correc_alb
+    !Config Desc = correction term for albedo
+    !Config Def  = 1.01
+    correc_alb_omp=1.01
+    CALL getin('correc_alb', correc_alb_omp)
+
+
+    !Etienne
+    !Config Key  = buf_sph_pol
+    !Config Desc = sphericity of buffer layer in polar regions
+    !Config Def  = 99.
+    buf_sph_pol_omp=99.
+    CALL getin('buf_sph_pol', buf_sph_pol_omp)
+
+    !Etienne
+    !Config Key  = buf_siz_pol
+    !Config Desc = grain size of buffer layer in polar regions in e-4m
+    !Config Def  = 4.
+    buf_siz_pol_omp=4.
+    CALL getin('buf_siz_pol', buf_siz_pol_omp)
+
+    !==================================================================
+    
+    !Config Key  = OK_journe
+    !Config Desc = Pour des sorties journalieres 
+    !Config Def  = .FALSE.
+    !Config Help = Pour creer le fichier histday contenant les sorties
+    !              journalieres 
+    !
+    ok_journe_omp = .FALSE.
+    CALL getin('OK_journe', ok_journe_omp)
+    !
+    !Config Key  = ok_hf
+    !Config Desc = Pour des sorties haute frequence
+    !Config Def  = .FALSE.
+    !Config Help = Pour creer le fichier histhf contenant les sorties
+    !              haute frequence ( 3h ou 6h)
+    !
+    ok_hf_omp = .FALSE.
+    CALL getin('ok_hf', ok_hf_omp)
+    !
+    !Config Key  = OK_mensuel
+    !Config Desc = Pour des sorties mensuelles 
+    !Config Def  = .TRUE.
+    !Config Help = Pour creer le fichier histmth contenant les sorties
+    !              mensuelles 
+    !
+    ok_mensuel_omp = .TRUE.
+    CALL getin('OK_mensuel', ok_mensuel_omp)
+    !
+    !Config Key  = OK_instan
+    !Config Desc = Pour des sorties instantanees 
+    !Config Def  = .FALSE.
+    !Config Help = Pour creer le fichier histins contenant les sorties
+    !              instantanees 
+    !
+    ok_instan_omp = .FALSE.
+    CALL getin('OK_instan', ok_instan_omp)
+    !
+    !Config Key  = ok_ade
+    !Config Desc = Aerosol direct effect or not?
+    !Config Def  = .FALSE.
+    !Config Help = Used in radlwsw.F
+    !
+    ok_ade_omp = .FALSE.
+    CALL getin('ok_ade', ok_ade_omp)
+
+    !Config Key  = ok_alw
+    !Config Desc = Aerosol longwave effect or not?
+    !Config Def  = .FALSE.
+    !Config Help = Used in radlwsw.F
+    !
+    ok_alw_omp = .FALSE.
+    CALL getin('ok_alw', ok_alw_omp)
+
+    !
+    !Config Key  = ok_aie
+    !Config Desc = Aerosol indirect effect or not?
+    !Config Def  = .FALSE.
+    !Config Help = Used in nuage.F and radlwsw.F
+    !
+    ok_aie_omp = .FALSE.
+    CALL getin('ok_aie', ok_aie_omp)
+
+    !
+    !Config Key  = ok_cdnc
+    !Config Desc = ok cloud droplet number concentration
+    !Config Def  = .FALSE.
+    !Config Help = Used in newmicro.F
+    !
+    ok_cdnc_omp = .FALSE.
+    CALL getin('ok_cdnc', ok_cdnc_omp)
+
+    !
+    !Config Key  = ok_volcan
+    !Config Desc = ok to generate volcanic diags
+    !Config Def  = .FALSE.
+    !Config Help = Used in radlwsw_m.F
+    !
+    ok_volcan_omp = .FALSE.
+    CALL getin('ok_volcan', ok_volcan_omp)
+
+    !
+    !Config Key  = flag_volc_surfstrat
+    !Config Desc = impose cooling rate at the surface (=1),
+    !              heating rate in the strato (=2), or nothing (=0)
+    !Config Def  = 0
+    !Config Help = Used in radlwsw_m.F
+    !
+    flag_volc_surfstrat_omp = 0 ! NL: SURFSTRAT
+    CALL getin('flag_volc_surfstrat', flag_volc_surfstrat_omp) 
+
+    !
+    !Config Key  = aerosol_couple
+    !Config Desc = read aerosol in file or calcul by inca
+    !Config Def  = .FALSE.
+    !Config Help = Used in physiq.F
+    !
+    aerosol_couple_omp = .FALSE.
+    CALL getin('aerosol_couple',aerosol_couple_omp)
+    !
+    !Config Key  = chemistry_couple
+    !Config Desc = read O3 chemistry in file or calcul by inca
+    !Config Def  = .FALSE.
+    !Config Help = Used in physiq.F
+    !
+    chemistry_couple_omp = .FALSE.
+    CALL getin('chemistry_couple',chemistry_couple_omp)
+    !
+    !Config Key  = flag_aerosol
+    !Config Desc = which aerosol is use for coupled model
+    !Config Def  = 1
+    !Config Help = Used in physiq.F
+    !
+    ! - flag_aerosol=0 => no aerosol
+    ! - flag_aerosol=1 => so4 only (defaut) 
+    ! - flag_aerosol=2 => bc  only 
+    ! - flag_aerosol=3 => pom only
+    ! - flag_aerosol=4 => seasalt only 
+    ! - flag_aerosol=5 => dust only
+    ! - flag_aerosol=6 => all aerosol
+    ! - flag_aerosol=7 => natural aerosol + MACv2SP
+    ! - (in this case aerosols.1980.nc should point to aerosols.nat.nc)
+
+    flag_aerosol_omp = 0
+    CALL getin('flag_aerosol',flag_aerosol_omp)
+
+    !
+    !Config Key  = flag_bc_internal_mixture
+    !Config Desc = state of mixture for BC aerosols
+    ! - n = external mixture
+    ! - y = internal mixture
+    !Config Def  = n
+    !Config Help = Used in physiq.F / aeropt
+    !
+    flag_bc_internal_mixture_omp = .FALSE.
+    CALL getin('flag_bc_internal_mixture',flag_bc_internal_mixture_omp)
+
+    ! 
+    !Config Key  = aer_type 
+    !Config Desc = Use a constant field for the aerosols 
+    !Config Def  = scenario 
+    !Config Help = Used in readaerosol.F90 
+    ! 
+    aer_type_omp = 'scenario' 
+    CALL getin('aer_type', aer_type_omp) 
+
+    !
+    !Config Key  = bl95_b0
+    !Config Desc = Parameter in CDNC-maer link (Boucher&Lohmann 1995)
+    !Config Def  = .FALSE.
+    !Config Help = Used in nuage.F
+    !
+    bl95_b0_omp = 2.
+    CALL getin('bl95_b0', bl95_b0_omp)
+
+    !Config Key  = bl95_b1
+    !Config Desc = Parameter in CDNC-maer link (Boucher&Lohmann 1995)
+    !Config Def  = .FALSE.
+    !Config Help = Used in nuage.F
+    !
+    bl95_b1_omp = 0.2
+    CALL getin('bl95_b1', bl95_b1_omp)
+
+    !Config Key  = freq_ISCCP
+    !Config Desc = Frequence d'appel du simulateur ISCCP en secondes;
+    !              par defaut 10800, i.e. 3 heures 
+    !Config Def  = 10800.
+    !Config Help = Used in ini_histISCCP.h
+    !
+    freq_ISCCP_omp = 10800.
+    CALL getin('freq_ISCCP', freq_ISCCP_omp)
+    !
+    !Config Key  = ecrit_ISCCP
+    !Config Desc = Frequence d'ecriture des resultats du simulateur ISCCP en nombre de jours;
+    !              par defaut 1., i.e. 1 jour
+    !Config Def  = 1.
+    !Config Help = Used in ini_histISCCP.h
+    !
+    !
+    ecrit_ISCCP_omp = 1.
+    CALL getin('ecrit_ISCCP', ecrit_ISCCP_omp)
+
+    !Config Key  = freq_COSP
+    !Config Desc = Frequence d'appel du simulateur COSP en secondes;
+    !              par defaut 10800, i.e. 3 heures
+    !Config Def  = 10800.
+    !Config Help = Used in ini_histdayCOSP.h
+    !
+    freq_COSP_omp = 10800.
+    CALL getin('freq_COSP', freq_COSP_omp)
+
+    !Config Key  = freq_AIRS
+    !Config Desc = Frequence d'appel du simulateur AIRS en secondes;
+    !              par defaut 10800, i.e. 3 heures
+    !Config Def  = 10800.
+    !Config Help = Used in ini_histdayAIRS.h
+    !
+    freq_AIRS_omp = 10800.
+    CALL getin('freq_AIRS', freq_AIRS_omp)
+
+    !
+    !Config Key  = ip_ebil_phy
+    !Config Desc = Niveau de sortie pour les diags bilan d'energie 
+    !Config Def  = 0
+    !Config Help = 
+    !               
+    ip_ebil_phy_omp = 0
+    CALL getin('ip_ebil_phy', ip_ebil_phy_omp)
+    IF (ip_ebil_phy_omp/=0) THEN
+       CALL abort_physic('conf_phys','ip_ebil_phy_omp doit etre 0 sur cette version',1)
+    ENDIF
+
+    !
+    !Config Key  = seuil_inversion
+    !Config Desc = Seuil ur dTh pour le choix entre les schemas de CL
+    !Config Def  = -0.1
+    !Config Help = 
+    !               
+    seuil_inversion_omp = -0.1
+    CALL getin('seuil_inversion', seuil_inversion_omp)
+
+    !
+    ! Constante solaire & Parametres orbitaux & taux gaz effet de serre BEG
+    !
+    !Config Key  = R_ecc
+    !Config Desc = Excentricite
+    !Config Def  = 0.016715
+    !Config Help = 
+    !               
+    !valeur AMIP II
+    R_ecc_omp = 0.016715
+    CALL getin('R_ecc', R_ecc_omp)
+    !
+    !Config Key  = R_peri
+    !Config Desc = Equinoxe
+    !Config Def  = 
+    !Config Help = 
+    !               
+    !
+    !valeur AMIP II
+    R_peri_omp = 102.7
+    CALL getin('R_peri', R_peri_omp)
+    !
+    !Config Key  = R_incl
+    !Config Desc = Inclinaison
+    !Config Def  = 
+    !Config Help = 
+    !               
+    !
+    !valeur AMIP II
+    R_incl_omp = 23.441
+    CALL getin('R_incl', R_incl_omp)
+    !
+    !Config Key  = solaire
+    !Config Desc = Constante solaire en W/m2
+    !Config Def  = 1365.
+    !Config Help = 
+    !               
+    !
+    !valeur AMIP II
+    solaire_omp = 1365.
+    solaire_omp_init = solaire_omp     !--we keep track of the default value
+    CALL getin('solaire', solaire_omp)
+    !
+    !Config Key  = co2_ppm
+    !Config Desc = concentration du CO2 en ppmv
+    !Config Def  = 348.
+    !Config Help = 
+    !               
+    !valeur AMIP II
+    co2_ppm_omp = 348.
+    CALL getin('co2_ppm', co2_ppm_omp)
+    !
+    !conversion en rapport de mélange massique
+    RCO2_omp = co2_ppm_omp * 1.0e-06 * RMCO2 / RMD
+
+    !
+    !Config Key  = co2_ppm0
+    !Config Desc = concentration initiale du CO2 en ppmv pour la version ESM avec CO2 interactif dans le cas 
+    !              où cette concentration de figure pas dans l'état de redémarrage de la physique
+    !Config Def  = 284.32
+    !Config Help = 
+    !               
+    co2_ppm0_omp = 284.32
+    CALL getin('co2_ppm0', co2_ppm0_omp)
+    !
+    !Config Key  = RCH4
+    !Config Desc = Concentration du CH4
+    !Config Def  = 1.65E-06* 16.043/28.97
+    !Config Help = 
+    !               
+    CH4_ppb_omp = 1650.
+    CALL getin('CH4_ppb', CH4_ppb_omp)
+    !conversion en rapport de mélange massique
+    RCH4_omp = CH4_ppb_omp * 1.0E-09 * RMCH4 / RMD
+    !
+    !Config Key  = RN2O
+    !Config Desc = Concentration du N2O
+    !Config Def  = 306.E-09* 44.013/28.97
+    !Config Help = 
+    !               
+    N2O_ppb_omp = 306.
+    CALL getin('N2O_ppb', N2O_ppb_omp)
+    !conversion en rapport de mélange massique
+    RN2O_omp = N2O_ppb_omp * 1.0E-09 * RMN2O / RMD
+    !
+    !Config Key  = RCFC11
+    !Config Desc = Concentration du CFC11
+    !Config Def  = 280.E-12* 137.3686/28.97
+    !Config Help = 
+    !               
+    CFC11_ppt_omp = 280.
+    CALL getin('CFC11_ppt',CFC11_ppt_omp)
+    !conversion en rapport de mélange massique
+    RCFC11_omp=CFC11_ppt_omp* 1.0E-12 * RMCFC11 / RMD
+    !
+    !Config Key  = RCFC12
+    !Config Desc = Concentration du CFC12
+    !Config Def  = 484.E-12* 120.9140/28.97
+    !Config Help = 
+    !               
+    CFC12_ppt_omp = 484.
+    CALL getin('CFC12_ppt',CFC12_ppt_omp)
+    !conversion en rapport de mélange massique
+    RCFC12_omp = CFC12_ppt_omp * 1.0E-12 * RMCFC12 / RMD
+
+    !
+    !Config Key  = co2_ppm_per
+    !Config Desc = concentration du CO2 perturbé en ppmv (CFMIP)
+    !Config Def  = 348.
+    !Config Help = 
+    !               
+    co2_ppm_per_omp = co2_ppm_omp
+    CALL getin('co2_ppm_per', co2_ppm_per_omp)
+    !conversion en rapport de mélange massique
+    RCO2_per_omp = co2_ppm_per_omp * 1.0e-06 * RMCO2 / RMD
+
+    !Config Key  = RCH4_per
+    !Config Desc = Concentration du CH4_per
+    !Config Def  = 1.65E-06* 16.043/28.97
+    !Config Help = 
+    !               
+    CH4_ppb_per_omp = CH4_ppb_omp
+    CALL getin('CH4_ppb_per', CH4_ppb_per_omp)
+    !conversion en rapport de mélange massique
+    RCH4_per_omp = CH4_ppb_per_omp * 1.0E-09 * RMCH4 / RMD
+    !
+    !Config Key  = RN2O_per
+    !Config Desc = Concentration du N2O_per
+    !Config Def  = 306.E-09* 44.013/28.97
+    !Config Help = 
+    !               
+    N2O_ppb_per_omp = N2O_ppb_omp
+    CALL getin('N2O_ppb_per', N2O_ppb_per_omp)
+    !conversion en rapport de mélange massique
+    RN2O_per_omp = N2O_ppb_per_omp * 1.0E-09 * RMN2O / RMD
+    !
+    !Config Key  = RCFC11_per
+    !Config Desc = Concentration du CFC11_per
+    !Config Def  = 280.E-12* 137.3686/28.97
+    !Config Help = 
+    !               
+    CFC11_ppt_per_omp = CFC11_ppt_omp
+    CALL getin('CFC11_ppt_per',CFC11_ppt_per_omp)
+    !conversion en rapport de mélange massique
+    RCFC11_per_omp=CFC11_ppt_per_omp* 1.0E-12 * RMCFC11 / RMD
+    !
+    !Config Key  = RCFC12_per
+    !Config Desc = Concentration du CFC12_per
+    !Config Def  = 484.E-12* 120.9140/28.97
+    !Config Help = 
+    !               
+    CFC12_ppt_per_omp = CFC12_ppt_omp
+    CALL getin('CFC12_ppt_per',CFC12_ppt_per_omp)
+    !conversion en rapport de mélange massique
+    RCFC12_per_omp = CFC12_ppt_per_omp * 1.0E-12 * RMCFC12 / RMD
+
+    !
+    ! FH 2008/05/09 On elimine toutes les clefs physiques dans la dynamique
+    ! Constantes precedemment dans dyn3d/conf_gcm
+
+    !Config  Key  = iflag_cycle_diurne
+    !Config  Desc = Cycle diurne
+    !Config  Def  = 1
+    !Config  Help = Cette option permet d'eteidre le cycle diurne.
+    !Config         Peut etre util pour accelerer le code !
+    iflag_cycle_diurne_omp = 1
+    CALL getin('iflag_cycle_diurne',iflag_cycle_diurne_omp)
+
+    !Config  Key  = soil_model
+    !Config  Desc = Modele de sol
+    !Config  Def  = y
+    !Config  Help = Choix du modele de sol (Thermique ?)
+    !Config         Option qui pourait un string afin de pouvoir
+    !Config         plus de choix ! Ou meme une liste d'options !
+    soil_model_omp = .TRUE.
+    CALL getin('soil_model',soil_model_omp)
+
+    !Config  Key  = new_oliq
+    !Config  Desc = Nouvelle eau liquide
+    !Config  Def  = y
+    !Config  Help = Permet de mettre en route la
+    !Config         nouvelle parametrisation de l'eau liquide !
+    new_oliq_omp = .TRUE.
+    CALL getin('new_oliq',new_oliq_omp)
+
+    !Config  Key  = ok_orodr
+    !Config  Desc = Orodr ???
+    !Config  Def  = y
+    !Config  Help = Y en a pas comprendre !
+    !Config         
+    ok_orodr_omp = .TRUE.
+    CALL getin('ok_orodr',ok_orodr_omp)
+
+    !Config  Key  =  ok_orolf
+    !Config  Desc = Orolf ??
+    !Config  Def  = y
+    !Config  Help = Connais pas !
+    ok_orolf_omp = .TRUE.
+    CALL getin('ok_orolf', ok_orolf_omp)
+
+
+    !Config  Key  =  zrel_oro_t
+    !Config  Desc = zrel_oro_t
+    !Config  Def  = 9999.
+    !Config  Help = Connais pas !
+    zrel_oro_t_omp = 9999.
+    CALL getin('zrel_oro_t', zrel_oro_t_omp)
+
+    !Config  Key  =  zstd_orodr_t
+    !Config  Desc = zstd_orodr_t
+    !Config  Def  = 0.
+    !Config  Help = Connais pas !
+    zstd_orodr_t_omp = 10.
+    CALL getin('zstd_orodr_t', zstd_orodr_t_omp)
+
+
+    !Config  Key  =  zpmm_orodr_t
+    !Config  Desc = zpmm_orodr_t
+    !Config  Def  = 0.
+    !Config  Help = Connais pas !
+    zpmm_orodr_t_omp = 100.
+    CALL getin('zpmm_orodr_t', zpmm_orodr_t_omp)
+
+
+    !Config  Key  =  zpmm_orolf_t
+    !Config  Desc = zpmm_orolf_t
+    !Config  Def  = 0.
+    !Config  Help = Connais pas !
+    zpmm_orolf_t_omp = 100.
+    CALL getin('zpmm_orolf_t', zpmm_orolf_t_omp)
+
+    !Config  Key  = ok_limitvrai
+    !Config  Desc = Force la lecture de la bonne annee
+    !Config  Def  = n
+    !Config  Help = On peut forcer le modele a lire le
+    !Config         fichier SST de la bonne annee. C'est une tres bonne
+    !Config         idee, pourquoi ne pas mettre toujours a y ???
+    ok_limitvrai_omp = .FALSE.
+    CALL getin('ok_limitvrai',ok_limitvrai_omp)
+
+    !Config  Key  = nbapp_rad
+    !Config  Desc = Frequence d'appel au rayonnement
+    !Config  Def  = 12
+    !Config  Help = Nombre  d'appels des routines de rayonnements
+    !Config         par jour.
+    nbapp_rad_omp = 12
+    CALL getin('nbapp_rad',nbapp_rad_omp)
+
+    !rajout Olivier Torres
+    !Config  Key  = choix_bulk
+    !Config  Desc = choix de la formulation bulk a prendre dans clcdrag au-dessus de l'ocean
+    !Config  Def  = 0
+    !Config         0 -> originale (lmdz/Louis 79)
+    !Config         1 -> COARE
+    !Config         2 -> CORE-"pure" (cf. Large)
+    !Config         3 -> CORE-"mixte" (avec z_0 et C_T^N donnees par Smith 88)
+    choix_bulk_omp = 0
+    CALL getin('choix_bulk',choix_bulk_omp)
+
+    !Config  Key  = nit_bulk
+    !Config  Desc = choix du nombre d'it de pt fixe dans la bulk
+    !Config  Def  = 5
+    nit_bulk_omp = 1
+    CALL getin('nit_bulk',nit_bulk_omp)
+
+    !Config  Key  = kz0
+    !Config  Desc = choix de la formulation z0 pour la bulk ECUME
+    !Config  Def  = 1
+    !Config         0 -> ARPEGE formulation
+    !Config         1 -> Smith Formulation
+    !Config         2 -> Direct computation using the stability functions
+    kz0_omp = 0
+    CALL getin('kz0',kz0_omp)
+
+
+    !Config  Key  = iflag_con
+    !Config  Desc = Flag de convection
+    !Config  Def  = 2
+    !Config  Help = Flag  pour la convection les options suivantes existent :
+    !Config         1 pour LMD,
+    !Config         2 pour Tiedtke,
+    !Config         3 pour CCM(NCAR)  
+    iflag_con_omp = 2
+    CALL getin('iflag_con',iflag_con_omp)
+
+    !Config  Key  = nbapp_cv
+    !Config  Desc = Frequence d'appel a la convection
+    !Config  Def  = 0
+    !Config  Help = Nombre  d'appels des routines de convection
+    !Config         par jour. Si =0, appel a chaque pas de temps physique.
+    nbapp_cv_omp = 0
+    CALL getin('nbapp_cv',nbapp_cv_omp)
+
+    !Config  Key  = nbapp_wk
+    !Config  Desc = Frequence d'appel aux wakes
+    !Config  Def  = 0
+    !Config  Help = Nombre  d'appels des routines de wakes
+    !Config         par jour. Si =0, appel a chaque pas de temps physique.
+    nbapp_wk_omp = 0
+    CALL getin('nbapp_wk',nbapp_wk_omp)
+
+    !Config  Key  = iflag_ener_conserv
+    !Config  Desc = Flag de convection
+    !Config  Def  = 1
+    !Config  Help = Flag  pour la convection les options suivantes existent :
+    !Config         -1 pour Kinetic energy correction
+    !Config         1  conservation kinetic and enthalpy
+    iflag_ener_conserv_omp = -1
+    CALL getin('iflag_ener_conserv',iflag_ener_conserv_omp)
+
+    !Config  Key  = ok_conserv_q
+    !Config  Desc = Switch des corrections de conservation de l'eau
+    !Config  Def  = y
+    !Config  Help = Switch des corrections de conservation de l'eau
+    !Config         y -> corrections activees
+    !Config         n -> conformite avec versions anterieures au 1/4/2014
+    ok_conserv_q_omp = .FALSE.
+    CALL getin('ok_conserv_q',ok_conserv_q_omp)
+
+    !
+    !
+    !
+    ! Constante solaire & Parametres orbitaux & taux gaz effet de serre END
+    !
+    ! KE
+    !
+
+    !Config key  = cvl_comp_threshold
+    !Config Desc = maximum fraction of convective points enabling compression
+    !Config Def  = 1.00
+    !Config Help = fields are compressed when less than a fraction cvl_comp_threshold
+    !Config Help = of the points is convective.
+    cvl_comp_threshold_omp = 1.00
+    CALL getin('cvl_comp_threshold', cvl_comp_threshold_omp)
+
+    !Config key  = cvl_sig2feed
+    !Config Desc = sigma coordinate at top of feeding layer
+    !Config Def  = 0.97
+    !Config Help = deep convection is fed by the layer extending from the surface (pressure ps)
+    !Config Help = and cvl_sig2feed*ps.
+    cvl_sig2feed_omp = 0.97
+    CALL getin('cvl_sig2feed', cvl_sig2feed_omp)
+
+    !Config key  = cvl_corr
+    !Config Desc = Facteur multiplication des precip convectives dans KE
+    !Config Def  = 1.00
+    !Config Help = 1.02 pour un moderne ou un pre-ind. A ajuster pour un glaciaire
+    cvl_corr_omp = 1.00
+    CALL getin('cvl_corr', cvl_corr_omp)
+
+
+    !Config Key  = epmax
+    !Config Desc = Efficacite precip
+    !Config Def  = 0.993
+    !Config Help = 
+    !
+    epmax_omp = .993
+    CALL getin('epmax', epmax_omp)
+
+    coef_epmax_cape_omp = 0.0   
+    CALL getin('coef_epmax_cape', coef_epmax_cape_omp)        
+    !
+    !Config Key  = ok_adj_ema
+    !Config Desc =  
+    !Config Def  = FALSE
+    !Config Help = 
+    !
+    ok_adj_ema_omp = .FALSE.
+    CALL getin('ok_adj_ema',ok_adj_ema_omp)
+    !
+    !Config Key  = iflag_clw
+    !Config Desc =  
+    !Config Def  = 0
+    !Config Help = 
+    !
+    iflag_clw_omp = 0
+    CALL getin('iflag_clw',iflag_clw_omp)
+    
+
+    !Config Key  = iflag_ratqs
+    !Config Desc =
+    !Config Def  = 1
+    !Config Help =
+    !
+    iflag_ratqs_omp = 1
+    CALL getin('iflag_ratqs',iflag_ratqs_omp)
+
+    !
+    !Config Key  = iflag_radia 
+    !Config Desc =  
+    !Config Def  = 1
+    !Config Help = 
+    !
+    iflag_radia_omp = 1
+    CALL getin('iflag_radia',iflag_radia_omp)
+
+    !
+    !Config Key  = iflag_rrtm 
+    !Config Desc =  
+    !Config Def  = 0
+    !Config Help = 
+    !
+    iflag_rrtm_omp = 0
+    CALL getin('iflag_rrtm',iflag_rrtm_omp)
+
+    !
+    !Config Key  = NSW 
+    !Config Desc =  
+    !Config Def  = 0
+    !Config Help = 
+    !
+    NSW_omp = 2
+    CALL getin('NSW',NSW_omp)
+    !albedo SB >>>
+    iflag_albedo_omp = 0
+    CALL getin('iflag_albedo',iflag_albedo_omp)
+
+    ok_chlorophyll_omp=.FALSE.
+    CALL getin('ok_chlorophyll',ok_chlorophyll_omp)
+    !albedo SB <<<
+    !
+    !Config Key  = ok_sun_time
+    !Config Desc = oui ou non variabilite solaire
+    !Config Def  = .FALSE.
+    !Config Help =
+    !
+    !
+    !valeur AMIP II
+    ok_suntime_rrtm_omp = .FALSE.
+    IF (iflag_rrtm_omp==1) THEN
+      CALL getin('ok_suntime_rrtm',ok_suntime_rrtm_omp)
+    ENDIF
+    
+    !Config Key  = flag_aerosol_strat
+    !Config Desc = use stratospheric aerosols 0, 1, 2
+    ! - 0 = no stratospheric aerosols 
+    ! - 1 = stratospheric aerosols scaled from 550 nm AOD 
+    ! - 2 = stratospheric aerosol properties from CMIP6
+    !Option 2 is only available with RRTM, this is tested later on 
+    !Config Def  = 0
+    !Config Help = Used in physiq.F
+    !
+    flag_aerosol_strat_omp = 0
+    CALL getin('flag_aerosol_strat',flag_aerosol_strat_omp)
+
+    !Config Key  = flag_aer_feedback
+    !Config Desc = (des)activate aerosol radiative feedback
+    ! - F = no aerosol radiative feedback
+    ! - T = aerosol radiative feedback
+    !Config Def  = T
+    !Config Help = Used in physiq.F
+    !
+    flag_aer_feedback_omp = .TRUE. 
+    IF (iflag_rrtm_omp==1) THEN
+       CALL getin('flag_aer_feedback',flag_aer_feedback_omp)
+    ENDIF
+
+    !Config Key  = iflag_cld_th 
+    !Config Desc =  
+    !Config Def  = 1
+    !Config Help = 
+    !
+    iflag_cld_th_omp = 1
+    ! On lit deux fois avec l'ancien et le nouveau nom 
+    ! pour assurer une retrocompatiblite.
+    ! A abandonner un jour
+    CALL getin('iflag_cldcon',iflag_cld_th_omp)
+    CALL getin('iflag_cld_th',iflag_cld_th_omp)
+    iflag_cld_cv_omp = 0 
+    CALL getin('iflag_cld_cv',iflag_cld_cv_omp)
+
+    !
+    !Config Key  = tau_cld_cv
+    !Config Desc =
+    !Config Def  = 10.
+    !Config Help =
+    !
+    tau_cld_cv_omp = 10.
+    CALL getin('tau_cld_cv',tau_cld_cv_omp)
+
+    !
+    !Config Key  = coefw_cld_cv
+    !Config Desc =
+    !Config Def  = 0.1
+    !Config Help =
+    !
+    coefw_cld_cv_omp = 0.1
+    CALL getin('coefw_cld_cv',coefw_cld_cv_omp)
+
+
+
+
+    !
+    !Config Key  = fact_cldcon
+    !Config Desc =  
+    !Config Def  = 0.375
+    !Config Help = 
+    !
+    fact_cldcon_omp = 0.375
+    CALL getin('fact_cldcon',fact_cldcon_omp)
+
+    !
+    !Config Key  = facttemps
+    !Config Desc =  
+    !Config Def  = 1.e-4
+    !Config Help = 
+    !
+    facttemps_omp = 1.e-4
+    CALL getin('facttemps',facttemps_omp)
+
+    !
+    !Config Key  = ok_newmicro
+    !Config Desc =  
+    !Config Def  = .TRUE.
+    !Config Help = 
+    !
+    ok_newmicro_omp = .TRUE.
+    CALL getin('ok_newmicro',ok_newmicro_omp)
+    !
+    !Config Key  = ratqsbas
+    !Config Desc =  
+    !Config Def  = 0.01
+    !Config Help = 
+    !
+    ratqsbas_omp = 0.01
+    CALL getin('ratqsbas',ratqsbas_omp)
+    !
+    !Config Key  = ratqshaut
+    !Config Desc =  
+    !Config Def  = 0.3
+    !Config Help = 
+    !
+    ratqshaut_omp = 0.3
+    CALL getin('ratqshaut',ratqshaut_omp)
+
+    !Config Key  = tau_ratqs
+    !Config Desc =  
+    !Config Def  = 1800.
+    !Config Help = 
+    !
+    tau_ratqs_omp = 1800.
+    CALL getin('tau_ratqs',tau_ratqs_omp)
+
+    !
+    !-----------------------------------------------------------------------
+    ! Longitude solaire pour le calcul de l'ensoleillement en degre
+    ! si on veut imposer la saison. Sinon, solarlong0=-999.999
+    !Config Key  = solarlong0
+    !Config Desc =  
+    !Config Def  = -999.999 
+    !Config Help = 
+    !
+    solarlong0_omp = -999.999
+    CALL getin('solarlong0',solarlong0_omp)
+    !
+    !-----------------------------------------------------------------------
+    !  Valeur imposee pour configuration idealisees
+    !Config Key  = qsol0 pour le bucket, evap0 pour aquaplanetes, albsno0
+    ! Default value -1 to activate the full computation
+    qsol0_omp = -1.
+    CALL getin('qsol0',qsol0_omp)
+    evap0_omp = -1.
+    CALL getin('evap0',evap0_omp)
+    albsno0_omp = -1.
+    CALL getin('albsno0',albsno0_omp)
+    !
+    !-----------------------------------------------------------------------
+    !
+    !Config Key  = iflag_sic
+    !Config Desc =  
+    !Config Def  = 0
+    !Config Help = 
+    !
+    iflag_sic_omp = 0
+    CALL getin('iflag_sic',iflag_sic_omp)
+    !
+    !Config Key  = iflag_inertie
+    !Config Desc =
+    !Config Def  = 0
+    !Config Help =
+    !
+    iflag_inertie_omp = 0
+    CALL getin('iflag_inertie',iflag_inertie_omp)
+    !
+    !Config Key  = inertie_sic
+    !Config Desc =  
+    !Config Def  = 2000.
+    !Config Help = 
+    !
+    inertie_sic_omp = 2000.
+    CALL getin('inertie_sic',inertie_sic_omp)
+    !
+    !Config Key  = inertie_lic
+    !Config Desc =  
+    !Config Def  = 2000.
+    !Config Help = 
+    !
+    inertie_lic_omp = 2000.
+    CALL getin('inertie_lic',inertie_lic_omp)
+    !
+    !Config Key  = inertie_sno
+    !Config Desc =  
+    !Config Def  = 2000.
+    !Config Help = 
+    !
+    inertie_sno_omp = 2000.
+    CALL getin('inertie_sno',inertie_sno_omp)
+    !
+    !Config Key  = inertie_sol
+    !Config Desc =  
+    !Config Def  = 2000.
+    !Config Help = 
+    !
+    inertie_sol_omp = 2000.
+    CALL getin('inertie_sol',inertie_sol_omp)
+
+    !
+    !Config Key  = rad_froid
+    !Config Desc =  
+    !Config Def  = 35.0
+    !Config Help = 
+    !
+    rad_froid_omp = 35.0
+    CALL getin('rad_froid',rad_froid_omp)
+
+    !
+    !Config Key  = rad_chau1
+    !Config Desc =  
+    !Config Def  = 13.0
+    !Config Help = 
+    !
+    rad_chau1_omp = 13.0
+    CALL getin('rad_chau1',rad_chau1_omp)
+
+    !
+    !Config Key  = rad_chau2
+    !Config Desc =  
+    !Config Def  = 9.0
+    !Config Help = 
+    !
+    rad_chau2_omp = 9.0
+    CALL getin('rad_chau2',rad_chau2_omp)
+
+
+    !
+    !Config Key  = iflag_ice_thermo
+    !Config Desc =  
+    !Config Def  = 0
+    !Config Help = 
+    !
+    iflag_ice_thermo_omp = 0
+    CALL getin('iflag_ice_thermo',iflag_ice_thermo_omp)
+
+    !
+    !Config Key  = ok_ice_supersat
+    !Config Desc = include ice supersaturation for cold clouds
+    !Config Def  = .FALSE.
+    !Config Help =
+    !
+    ok_ice_supersat_omp = .FALSE.
+    CALL getin('ok_ice_supersat',ok_ice_supersat_omp)
+
+    !Config Key  = ok_plane_h2o
+    !Config Desc = include H2O emissions from aviation
+    !Config Def  = .FALSE.
+    !Config Help =
+    !
+    ok_plane_h2o_omp = .FALSE.
+    CALL getin('ok_plane_h2o',ok_plane_h2o_omp)
+
+    !Config Key  = ok_plane_contrail
+    !Config Desc = include the formation of contrail cirrus clouds
+    !Config Def  = .FALSE.
+    !Config Help =
+    !
+    ok_plane_contrail_omp = .FALSE.
+    CALL getin('ok_plane_contrail',ok_plane_contrail_omp)
+
+    !
+    !Config Key  = top_height
+    !Config Desc =
+    !Config Def  = 3
+    !Config Help =
+    !
+    top_height_omp = 3
+    CALL getin('top_height',top_height_omp)
+
+    !
+    !Config Key  = overlap
+    !Config Desc =
+    !Config Def  = 3
+    !Config Help =
+    !
+    overlap_omp = 3
+    CALL getin('overlap',overlap_omp)
+
+    !
+    !Config Key  = cdmmax
+    !Config Desc =
+    !Config Def  = 1.3E-3
+    !Config Help =
+    !
+    cdmmax_omp = 1.3E-3
+    CALL getin('cdmmax',cdmmax_omp)
+
+    !
+    !Config Key  = cdhmax
+    !Config Desc =
+    !Config Def  = 1.1E-3
+    !Config Help =
+    !
+    cdhmax_omp = 1.1E-3
+    CALL getin('cdhmax',cdhmax_omp)
+
+    !261103
+    !
+    !Config Key  = ksta
+    !Config Desc =
+    !Config Def  = 1.0e-10
+    !Config Help =
+    !
+    ksta_omp = 1.0e-10
+    CALL getin('ksta',ksta_omp)
+
+    !
+    !Config Key  = ksta_ter
+    !Config Desc =
+    !Config Def  = 1.0e-10
+    !Config Help =
+    !
+    ksta_ter_omp = 1.0e-10
+    CALL getin('ksta_ter',ksta_ter_omp)
+
+    !Config Key  = f_ri_cd_min
+    !Config Desc =
+    !Config Def  = 0.1
+    !Config Help =
+    !
+    f_ri_cd_min_omp = 0.1
+    CALL getin('f_ri_cd_min',f_ri_cd_min_omp)
+
+    !
+    !Config Key  = ok_kzmin
+    !Config Desc =
+    !Config Def  = .TRUE.
+    !Config Help =
+    !
+    ok_kzmin_omp = .TRUE.
+    CALL getin('ok_kzmin',ok_kzmin_omp)
+
+    !
+    !Config Key  = fmagic
+    !Config Desc = additionnal multiplicator factor used for albedo
+    !Config Def  = 1.
+    !Config Help = additionnal multiplicator factor used in albedo.F
+    !
+    fmagic_omp = 1.
+    CALL getin('fmagic',fmagic_omp)
+
+    !
+    !Config Key  = pmagic
+    !Config Desc = additional factor used for albedo
+    !Config Def  = 0.
+    !Config Help = additional factor used in albedo.F
+    !
+    pmagic_omp = 0.
+    CALL getin('pmagic',pmagic_omp)
+
+
+    !Config Key = ok_lic_melt
+    !Config Desc = Prise en compte de la fonte de la calotte dans le bilan d'eau
+    !Config Def  = .FALSE.
+    !Config Help = mettre a .FALSE. pour assurer la conservation en eau
+    ok_lic_melt_omp = .FALSE.
+    CALL getin('ok_lic_melt', ok_lic_melt_omp)
+
+
+    !Config Key = ok_lic_cond
+    !Config Desc = Prise en compte depot de vapeur d'eau sur la calotte dans le bilan d'eau
+    !Config Def  = .FALSE.
+    !Config Help = mettre a .TRUE. pour assurer la conservation en eau
+    ok_lic_cond_omp = .FALSE.
+    CALL getin('ok_lic_cond', ok_lic_cond_omp)
+
+    !
+    ! PARAMETER FOR THE PLANETARY BOUNDARY LAYER
+    !
+
+    !Config Key  = iflag_pbl
+    !Config Desc =
+    !Config Def  = 1
+    !Config Help =
+    !
+    iflag_pbl_omp = 1
+    CALL getin('iflag_pbl',iflag_pbl_omp)
+
+    iflag_physiq_omp = 0 ! 0: std, 1: with physiqex output, 2: for physiqex
+    CALL getin('iflag_physiq',iflag_physiq_omp)
+
+!FC
+    !Config Key  = ifl_pbltree
+    !Config Desc = drag from trees 0 no activated
+    !Config Def  = 0
+    !Config Help =
+    !
+    ifl_pbltree_omp = 0
+    CALL getin('ifl_pbltree',ifl_pbltree_omp)
+!FC
+    !Config Key  = Cd_frein
+    !Config Desc = drag from trees 
+    !Config Def  = 7.5E-02 (valeur Masson mais fait planter avec des LAI eleves)
+    !Config Help =
+    !
+    Cd_frein_omp = 7.5E-02
+    CALL getin('Cd_frein',Cd_frein_omp)
+
+    !
+    !Config Key  = iflag_pbl_split
+    !Config Desc = decimal flag: least signif digit = split vdf; next digit = split thermals
+    !Config Def  = 0
+    !Config Help = 0-> no splitting; 1-> vdf splitting; 10-> thermals splitting; 11-> full splitting
+    !
+    iflag_pbl_split_omp = 0
+    call getin('iflag_pbl_split',iflag_pbl_split_omp)
+    !
+    !Config Key  = iflag_order2_sollw
+    !Config Desc =
+    !Config Def  = 0
+    !Config Help =
+    !
+    iflag_order2_sollw_omp = 0
+    CALL getin('iflag_order2_sollw',iflag_order2_sollw_omp)
+    !
+    !Config Key  = iflag_thermals
+    !Config Desc =
+    !Config Def  = 0
+    !Config Help =
+    !
+    iflag_thermals_omp = 0
+    CALL getin('iflag_thermals',iflag_thermals_omp)
+    !
+    !Config Key  = nsplit_thermals
+    !Config Desc =
+    !Config Def  = 0
+    !Config Help =
+    !
+    nsplit_thermals_omp = 1
+    CALL getin('nsplit_thermals',nsplit_thermals_omp)
+    !
+    !Config Key  = nsplit_thermals
+    !Config Desc =
+    !Config Def  = 0
+    !Config Help =
+    alp_bl_k_omp = 1.
+    CALL getin('alp_bl_k',alp_bl_k_omp)
+
+    ! nrlmd le 10/04/2012
+
+    !Config Key  = iflag_trig_bl
+    !Config Desc =  
+    !Config Def  = 0
+    !Config Help = 
+    !
+    iflag_trig_bl_omp = 0
+    CALL getin('iflag_trig_bl',iflag_trig_bl_omp)
+
+    !Config Key  = iflag_strig
+    !Config Desc =  
+    !Config Def  = 0
+    !Config Help = 
+    !
+    iflag_strig_omp = 0
+    CALL getin('iflag_strig',iflag_strig_omp)
+
+    !Config Key  = s_trig_bl
+    !Config Desc =  
+    !Config Def  = 0
+    !Config Help = 
+    !
+    s_trig_omp = 2e7
+    CALL getin('s_trig',s_trig_omp)
+
+    !Config Key  = h_trig
+    !Config Desc =  
+    !Config Def  = 0
+    !Config Help = 
+    !
+    h_trig_omp = 6000.
+    CALL getin('h_trig',h_trig_omp)
+
+    !Config Key  = tau_trig_shallow
+    !Config Desc =  
+    !Config Def  = 0
+    !Config Help = 
+    !
+    tau_trig_shallow_omp = 600
+    CALL getin('tau_trig_shallow',tau_trig_shallow_omp)
+
+    !Config Key  = tau_trig_deep
+    !Config Desc =  
+    !Config Def  = 0
+    !Config Help = 
+    !
+    tau_trig_deep_omp = 1800
+    CALL getin('tau_trig_deep',tau_trig_deep_omp)
+
+    !Config Key  = iflag_clos_bl
+    !Config Desc =  
+    !Config Def  = 0
+    !Config Help = 
+    !
+    iflag_clos_bl_omp = 0
+    CALL getin('iflag_clos_bl',iflag_clos_bl_omp)
+
+    ! fin nrlmd le 10/04/2012
+
+    !
+    !Config Key  = tau_thermals
+    !Config Desc =
+    !Config Def  = 0.
+    !Config Help =
+    !
+    tau_thermals_omp = 0.
+    CALL getin('tau_thermals',tau_thermals_omp)
+
+    !
+    !Config Key  = iflag_coupl
+    !Config Desc =
+    !Config Def  = 0
+    !Config Help =
+    !
+    iflag_coupl_omp = 0
+    CALL getin('iflag_coupl',iflag_coupl_omp)
+
+    !
+    !Config Key  = iflag_clos
+    !Config Desc =  
+    !Config Def  = 0
+    !Config Help = 
+    !
+    iflag_clos_omp = 1
+    CALL getin('iflag_clos',iflag_clos_omp)
+    !
+    !Config Key  = coef_clos_ls
+    !Config Desc =  
+    !Config Def  = 0
+    !Config Help = 
+    !
+    coef_clos_ls_omp = 0.
+    CALL getin('coef_clos_ls',coef_clos_ls_omp)
+
+    !
+    !Config Key  = iflag_cvl_sigd
+    !Config Desc =  
+    !Config Def  = 0
+    !Config Help = 
+    !
+    iflag_cvl_sigd_omp = 0
+    CALL getin('iflag_cvl_sigd',iflag_cvl_sigd_omp)
+
+    !Config Key  = iflag_wake
+    !Config Desc =  
+    !Config Def  = 0
+    !Config Help = 
+    !
+    iflag_wake_omp = 0
+    CALL getin('iflag_wake',iflag_wake_omp)
+
+    !Config Key  = alp_offset
+    !Config Desc =  
+    !Config Def  = 0
+    !Config Help = 
+    !
+    alp_offset_omp = 0.
+    CALL getin('alp_offset',alp_offset_omp)
+
+    !
+    !Config Key  = lev_histhf
+    !Config Desc =
+    !Config Def  = 1
+    !Config Help =
+    !
+    lev_histhf_omp = 1
+    CALL getin('lev_histhf',lev_histhf_omp)
+
+    !
+    !Config Key  = lev_histday
+    !Config Desc =
+    !Config Def  = 1
+    !Config Help =
+    !
+    lev_histday_omp = 1
+    CALL getin('lev_histday',lev_histday_omp)
+
+    !
+    !Config Key  = lev_histmth
+    !Config Desc =
+    !Config Def  = 2
+    !Config Help =
+    !
+    lev_histmth_omp = 2
+    CALL getin('lev_histmth',lev_histmth_omp)
+    !
+    !Config Key  = lev_histins
+    !Config Desc =
+    !Config Def  = 1
+    !Config Help =
+    !
+    lev_histins_omp = 1
+    CALL getin('lev_histins',lev_histins_omp)
+    !
+    !Config Key  = lev_histLES
+    !Config Desc =
+    !Config Def  = 1
+    !Config Help =
+    !
+    lev_histLES_omp = 1
+    CALL getin('lev_histLES',lev_histLES_omp)
+    ! 
+    !Config Key  = lev_histdayNMC
+    !Config Desc =
+    !Config Def  = 8
+    !Config Help =
+    !
+    lev_histdayNMC_omp = 8
+    CALL getin('lev_histdayNMC',lev_histdayNMC_omp)
+    !
+    !Config Key  = levout_histNMC
+    !Config Desc =
+    !Config Def  = 5
+    !Config Help =
+    !
+    levout_histNMC_omp(1) = 5
+    levout_histNMC_omp(2) = 5
+    levout_histNMC_omp(3) = 5
+    CALL getin('levout_histNMC',levout_histNMC_omp)
+    !
+    !histNMC BEG
+    !Config Key  = ok_histNMC
+    !Config Desc = ok_histNMC(1) = frequence de sortie fichiers histmthNMC
+    !Config Desc = ok_histNMC(2) = frequence de sortie fichiers histdayNMC
+    !Config Desc = ok_histNMC(3) = frequence de sortie fichiers histhfNMC
+    !Config Def  = n, n, n
+    !Config Help =
+    !
+    ok_histNMC_omp(1) = .FALSE.
+    ok_histNMC_omp(2) = .FALSE.
+    ok_histNMC_omp(3) = .FALSE.
+    CALL getin('ok_histNMC',ok_histNMC_omp)
+    !
+    !Config Key  = freq_outNMC
+    !Config Desc = freq_outNMC(1) = frequence de sortie fichiers histmthNMC
+    !Config Desc = freq_outNMC(2) = frequence de sortie fichiers histdayNMC
+    !Config Desc = freq_outNMC(3) = frequence de sortie fichiers histhfNMC
+    !Config Def  = 2592000., 86400., 21600. (1mois, 1jour, 6h) 
+    !Config Help =
+    !
+    freq_outNMC_omp(1) = mth_len
+    freq_outNMC_omp(2) = 1.
+    freq_outNMC_omp(3) = 1./4.
+    CALL getin('freq_outNMC',freq_outNMC_omp)
+    !
+    !Config Key  = freq_calNMC
+    !Config Desc = freq_calNMC(1) = frequence de calcul fichiers histmthNMC
+    !Config Desc = freq_calNMC(2) = frequence de calcul fichiers histdayNMC
+    !Config Desc = freq_calNMC(3) = frequence de calcul fichiers histhfNMC
+    !Config Def  = phys_tstep
+    !Config Help =
+    !
+    freq_calNMC_omp(1) = phys_tstep
+    freq_calNMC_omp(2) = phys_tstep
+    freq_calNMC_omp(3) = phys_tstep
+    CALL getin('freq_calNMC',freq_calNMC_omp)
+    !
+    !Config Key  = type_run
+    !Config Desc =
+    !Config Def  = 'AMIP'/'CFMIP'  ou 'CLIM'/'ENSP'
+    !Config Help =
+    !
+    type_run_omp = 'AMIP'
+    CALL getin('type_run',type_run_omp)
+
+    !
+    !Config Key  = ok_cosp
+    !Config Desc =
+    !Config Def  = .FALSE.
+    !Config Help =
+    !
+    ok_cosp_omp = .FALSE.
+    CALL getin('ok_cosp',ok_cosp_omp)
+
+    !
+    !Config Key  = ok_airs
+    !Config Desc =
+    !Config Def  = .FALSE.
+    !Config Help =
+    !
+    ok_airs_omp = .FALSE.
+    CALL getin('ok_airs',ok_airs_omp)
+
+    !
+    !Config Key  = ok_mensuelCOSP
+    !Config Desc =
+    !Config Def  = .TRUE.
+    !Config Help =
+    !
+    ok_mensuelCOSP_omp = .TRUE.
+    CALL getin('ok_mensuelCOSP',ok_mensuelCOSP_omp)
+
+    !
+    !Config Key  = ok_journeCOSP
+    !Config Desc =
+    !Config Def  = .TRUE.
+    !Config Help = 
+    !
+    ok_journeCOSP_omp = .TRUE.
+    CALL getin('ok_journeCOSP',ok_journeCOSP_omp)
+
+    !
+    !Config Key  = ok_hfCOSP
+    !Config Desc =
+    !Config Def  = .FALSE.
+    !Config Help =
+    !
+    ok_hfCOSP_omp = .FALSE.
+    CALL getin('ok_hfCOSP',ok_hfCOSP_omp)
+
+    !
+    ! coordonnees (lonmin_ins, lonmax_ins, latmin_ins, latmax_ins) pour la zone 
+    ! avec sorties instantannees tous les pas de temps de la physique => "histbilKP_ins.nc"
+    !
+    !Config Key  = lonmin_ins
+    !Config Desc = 100.  
+    !Config Def  = longitude minimale sorties "bilKP_ins"
+    !Config Help = 
+    !
+    lonmin_ins_omp = 100.
+    CALL getin('lonmin_ins',lonmin_ins_omp)
+    !
+    !Config Key  = lonmax_ins
+    !Config Desc = 130. 
+    !Config Def  = longitude maximale sorties "bilKP_ins"
+    !Config Help =
+    !
+    lonmax_ins_omp = 130.
+    CALL getin('lonmax_ins',lonmax_ins_omp)
+    !
+    !Config Key  = latmin_ins
+    !Config Desc = -20.  
+    !Config Def  = latitude minimale sorties "bilKP_ins"
+    !Config Help = 
+    !
+    latmin_ins_omp = -20.
+    CALL getin('latmin_ins',latmin_ins_omp)
+    !
+    !Config Key  = latmax_ins
+    !Config Desc = 20. 
+    !Config Def  = latitude maximale sorties "bilKP_ins"
+    !Config Help =
+    !
+    latmax_ins_omp = 20.
+    CALL getin('latmax_ins',latmax_ins_omp)
+    !
+    !Config Key  = ecrit_hf
+    !Config Desc =
+    !Config Def  = 1./8. !toutes les 3h
+    !Config Help =
+    !
+    ecrit_hf_omp = 1./8.
+    CALL getin('ecrit_hf',ecrit_hf_omp)
+    !
+    !Config Key  = ecrit_ins
+    !Config Desc =
+    !Config Def  = 1./48. ! toutes les 1/2 h
+    !Config Help =
+    !
+    ecrit_ins_omp = 1./48.
+    CALL getin('ecrit_ins',ecrit_ins_omp)
+    !
+    !Config Key  = ecrit_day
+    !Config Desc =
+    !Config Def  = 1.0 !tous les jours
+    !Config Help = nombre de jours pour ecriture fichier histday.nc
+    !
+    ecrit_day_omp = 1.0
+    CALL getin('ecrit_day',ecrit_day_omp)
+    !
+    !Config Key  = ecrit_mth
+    !Config Desc =
+    !Config Def  = 30. !tous les 30jours (1 fois par mois)
+    !Config Help =
+    !
+    ecrit_mth_omp = 30.
+    CALL getin('ecrit_mth',ecrit_mth_omp)
+    !
+    !Config Key  = ecrit_tra
+    !Config Desc =
+    !Config Def  = 30. !tous les 30jours (1 fois par mois)
+    !Config Help =
+    !
+    ecrit_tra_omp = 0.
+    CALL getin('ecrit_tra',ecrit_tra_omp)
+    !
+    !Config Key  = ecrit_reg
+    !Config Desc =
+    !Config Def  = 0.25  !4 fois par jour
+    !Config Help =
+    !
+    ecrit_reg_omp = 0.25   !4 fois par jour
+    CALL getin('ecrit_reg',ecrit_reg_omp)
+    !
+    !
+    print*,'CONFPHYS OOK avant drag_ter'
+    !
+    ! PARAMETRES CDRAG
+    !
+    f_cdrag_ter_omp = 0.8
+    CALL getin('f_cdrag_ter',f_cdrag_ter_omp)
+    !
+    f_cdrag_oce_omp = 0.8
+    CALL getin('f_cdrag_oce',f_cdrag_oce_omp)
+    !
+
+    ! Gustiness flags
+    f_z0qh_oce_omp = 1.
+    CALL getin('f_z0qh_oce',f_z0qh_oce_omp)
+    !
+    f_qsat_oce_omp = 1.
+    CALL getin('f_qsat_oce',f_qsat_oce_omp)
+    !
+    f_gust_bl_omp = 0.
+    CALL getin('f_gust_bl',f_gust_bl_omp)
+    !
+    f_gust_wk_omp = 0.
+    CALL getin('f_gust_wk',f_gust_wk_omp)
+    !
+    !Config Key  = iflag_z0_oce
+    !Config Desc = 0 (z0h=z0m), 1 (diff. equ. for z0h and z0m), -1 (z0m=z0h=z0min)
+    !Config Def  = 0   ! z0h = z0m
+    !Config Help =
+    !
+    iflag_z0_oce_omp=0
+    CALL getin('iflag_z0_oce',iflag_z0_oce_omp)
+    !
+    iflag_gusts_omp=0
+    CALL getin('iflag_gusts',iflag_gusts_omp)
+    !
+    min_wind_speed_omp = 1.
+    CALL getin('min_wind_speed',min_wind_speed_omp)
+
+    z0m_seaice_omp = 0.002 ; CALL getin('z0m_seaice',z0m_seaice_omp)
+    z0h_seaice_omp = 0.002 ; CALL getin('z0h_seaice',z0h_seaice_omp)
+
+
+    z0m_landice_omp = 0.001 ; CALL getin('z0m_landice',z0m_landice_omp)
+    z0h_landice_omp = 0.001 ; CALL getin('z0h_landice',z0h_landice_omp)
+
+    f_rugoro_omp = 0.
+    CALL getin('f_rugoro',f_rugoro_omp)
+
+    z0min_omp = 0.000015
+    CALL getin('z0min',z0min_omp)
+
+
+    ! PARAMETERS FOR CONVECTIVE INHIBITION BY TROPOS. DRYNESS
+    !
+    !Config Key  = supcrit1
+    !Config Desc =
+    !Config Def  = .540
+    !Config Help =
+    !
+    supcrit1_omp = .540
+    CALL getin('supcrit1',supcrit1_omp)
+
+    !
+    !Config Key  = supcrit2
+    !Config Desc =
+    !Config Def  = .600
+    !Config Help =
+    !
+    supcrit2_omp = .600
+    CALL getin('supcrit2',supcrit2_omp)
+
+    !
+    ! PARAMETERS FOR THE MIXING DISTRIBUTION
+    ! iflag_mix: 0=OLD, 
+    !            1=NEW (JYG),            
+    !            2=NEW + conv. depth inhib. by tropos. dryness
+    ! '2' is NOT operationnal and should not be used.
+    !
+    !Config Key  = iflag_mix
+    !Config Desc =
+    !Config Def  = 1
+    !Config Help =
+    !
+    iflag_mix_omp = 1
+    CALL getin('iflag_mix',iflag_mix_omp)
+
+!
+    ! PARAMETERS FOR THE EROSION OF THE ADIABATIC ASCENTS
+    ! iflag_mix_adiab: 0=OLD, 
+    !                  1=NEW (CR),            
+    !            
+    !
+    !Config Key  = iflag_mix_adiab
+    !Config Desc =
+    !Config Def  = 1
+    !Config Help =
+    !
+    iflag_mix_adiab_omp = 0
+    CALL getin('iflag_mix_adiab',iflag_mix_adiab_omp)
+
+    !
+    !Config Key  = scut
+    !Config Desc =
+    !Config Def  = 0.95
+    !Config Help =
+    !
+    scut_omp = 0.95
+    CALL getin('scut',scut_omp)
+
+    !
+    !Config Key  = qqa1
+    !Config Desc =
+    !Config Def  = 1.0
+    !Config Help =
+    !
+    qqa1_omp = 1.0
+    CALL getin('qqa1',qqa1_omp)
+
+    !
+    !Config Key  = qqa2
+    !Config Desc =
+    !Config Def  = 0.0
+    !Config Help =
+    !
+    qqa2_omp = 0.0
+    CALL getin('qqa2',qqa2_omp)
+
+    !
+    !Config Key  = gammas
+    !Config Desc =
+    !Config Def  = 0.05
+    !Config Help =
+    !
+    gammas_omp = 0.05
+    CALL getin('gammas',gammas_omp)
+
+    !
+    !Config Key  = Fmax
+    !Config Desc =
+    !Config Def  = 0.65
+    !Config Help =
+    !
+    Fmax_omp = 0.65
+    CALL getin('Fmax',Fmax_omp)
+
+    !
+    !Config Key  = tmax_fonte_cv
+    !Config Desc =
+    !Config Def  = 275.15
+    !Config Help =
+    !
+    tmax_fonte_cv_omp = 275.15
+    CALL getin('tmax_fonte_cv',tmax_fonte_cv_omp)
+
+    !
+    !Config Key  = alphas  
+    !Config Desc =
+    !Config Def  = -5.
+    !Config Help =
+    !
+    alphas_omp = -5.
+    CALL getin('alphas',alphas_omp)
+
+    !Config key = ok_strato
+    !Config  Desc = activation de la version strato
+    !Config  Def  = .FALSE.
+    !Config  Help = active la version stratosph\'erique de LMDZ de F. Lott
+    !               Et la sponge layer (Runs Stratospheriques)
+
+    ok_strato_omp=.FALSE.
+    CALL getin('ok_strato',ok_strato_omp)
+
+    !Config  key = ok_hines
+    !Config  Desc = activation de la parametrisation de hines
+    !Config  Def  = .FALSE.
+    !Config  Help = Clefs controlant la parametrization de Hines
+
+    ok_hines_omp=.FALSE.
+    CALL getin('ok_hines',ok_hines_omp)
+
+    !  Parametres pour les ondes de gravite
+    !  
+    !  Subgrid Scale Orography (Lott Miller (1997), Lott (1999))
+
+    sso_gkdrag_omp = merge(0.1875, 0.2, ok_strato_omp)
+    CALL getin('sso_gkdrag', sso_gkdrag_omp)
+
+    sso_grahil_omp=merge(0.1,1.,ok_strato_omp)
+    CALL getin('sso_grahil', sso_grahil_omp)
+
+    sso_grcrit_omp =merge(1.,0.01,ok_strato_omp)
+    CALL getin('sso_grcrit', sso_grcrit_omp)
+
+    sso_gfrcri_omp = 1.
+    CALL getin('sso_gfrcri', sso_gfrcri_omp)
+
+    sso_gkwake_omp = 0.50
+    CALL getin('sso_gkwake', sso_gkwake_omp)
+
+    sso_gklift_omp = merge(0.25,0.50,ok_strato_omp)
+    CALL getin('sso_gklift', sso_gklift_omp)
+
+    ! Random gravity waves:
+
+    ok_gwd_rando_omp = .FALSE.
+    IF ( klon_glo == 1 ) THEN
+       print*,'La parametrisation des ondes de gravites non orographiques'
+       print*,'ne fonctionne pas en 1D'
+    ELSE
+       CALL getin('ok_gwd_rando', ok_gwd_rando_omp)
+    ENDIF
+
+    gwd_rando_ruwmax_omp = 2.00
+    CALL getin('gwd_rando_ruwmax', gwd_rando_ruwmax_omp)
+
+    gwd_rando_sat_omp = 0.25
+    CALL getin('gwd_rando_sat', gwd_rando_sat_omp)
+
+    gwd_front_ruwmax_omp = 2.50
+    CALL getin('gwd_front_ruwmax', gwd_front_ruwmax_omp)
+
+    gwd_front_sat_omp = 0.60
+    CALL getin('gwd_front_sat', gwd_front_sat_omp)
+
+
+    !Config  key = ok_qch4
+    !Config  Desc = activation de la parametrisation du methane
+    !Config  Def  = .FALSE.
+    !Config  Help = Clef controlant l'activation de la parametrisation
+    !               de l'humidite due a oxydation+photolyse du methane strato
+
+    ok_qch4_omp=.FALSE.
+    CALL getin('ok_qch4',ok_qch4_omp)
+
+    !Config Key  = OK_LES                                               
+    !Config Desc = Pour des sorties LES                                 
+    !Config Def  = .FALSE.                                              
+    !Config Help = Pour creer le fichier histLES contenant les sorties  
+    !              LES                                                  
+    !                                                                   
+    ok_LES_omp = .FALSE.                                              
+    CALL getin('OK_LES', ok_LES_omp)                                  
+
+    !Config Key  = callstats                                               
+    !Config Desc = Pour des sorties callstats                                 
+    !Config Def  = .FALSE.                                              
+    !Config Help = Pour creer le fichier stats contenant les sorties  
+    !              stats                                                  
+    !                                                                   
+    callstats_omp = .FALSE.                                              
+    CALL getin('callstats', callstats_omp)                                  
+    !
+    !Config Key  = ecrit_LES
+    !Config Desc = Frequence d'ecriture des resultats du LES en nombre de jours;
+    !              par defaut 1., i.e. 1 jour
+    !Config Def  = 1./8.
+    !Config Help = ... 
+    !
+    !
+    adjust_tropopause = .FALSE.
+    CALL getin('adjust_tropopause', adjust_tropopause_omp)
+    !
+    !Config Key  = adjust_tropopause
+    !Config Desc = Adjust the ozone field from the climoz file by stretching its
+    !              tropopause so that it matches the one of LMDZ.
+    !Config Def  = .FALSE.
+    !Config Help = Ensure tropospheric ozone column conservation.
+    !
+    !
+    ok_daily_climoz = .FALSE.
+    CALL getin('ok_daily_climoz', ok_daily_climoz_omp)
+    !
+    !Config Key  = ok_daily_climoz
+    !Config Desc = Interpolate in time the ozone forcings within ce0l.
+    !              .TRUE. if backward compatibility is needed.
+    !Config Def  = .TRUE.
+    !Config Help = .FALSE. ensure much fewer (no calendar dependency)
+    !  and lighter monthly climoz files, inetrpolated in time at gcm run time.
+    
+    ok_new_lscp_omp = .FALSE.
+    CALL getin('ok_new_lscp', ok_new_lscp_omp)
+    !
+    !Config Key  = ok_new_lscp_omp
+    !Config Desc = new cloud scheme ith ice and mixed phase (Etienne and JB)
+    !Config Def  = .FALSE.
+    !Config Help = ...
+
+
+
+    ok_icefra_lscp_omp = .FALSE.
+    CALL getin('ok_icefra_lscp', ok_icefra_lscp_omp)
+    !
+    !Config Key  = ok_icefra_lscp_omp
+    !Config Desc = ice fraction in radiation from lscp
+    !Config Def  = .FALSE.
+    !Config Help = ...
+
+
+
+    ok_bs_omp = .FALSE.
+    CALL getin('ok_bs', ok_bs_omp)
+    !
+    !Config Key  = ok_bs_omp
+    !Config Desc = include blowing snow
+    !Config Def  = .FALSE.
+    !Config Help = ...
+
+
+    ok_rad_bs_omp = .FALSE.
+    CALL getin('ok_rad_bs', ok_rad_bs_omp)
+    !
+    !Config Key  = ok_rad_bs_omp
+    !Config Desc = include blowing snow radiative effect
+    !Config Def  = .FALSE.
+    !Config Help = ...
+
+    ecrit_LES_omp = 1./8.
+    CALL getin('ecrit_LES', ecrit_LES_omp)
+    !
+    read_climoz = 0 ! default value
+    CALL getin('read_climoz', read_climoz)
+
+    carbon_cycle_tr_omp=.FALSE.
+    CALL getin('carbon_cycle_tr',carbon_cycle_tr_omp)
+
+    carbon_cycle_cpl_omp=.FALSE.
+    CALL getin('carbon_cycle_cpl',carbon_cycle_cpl_omp)
+
+    carbon_cycle_rad_omp=.FALSE.
+    CALL getin('carbon_cycle_rad',carbon_cycle_rad_omp)
+
+    read_fco2_ocean_cor_omp=.FALSE.
+    CALL getin('read_fco2_ocean_cor',read_fco2_ocean_cor_omp)
+
+    var_fco2_ocean_cor_omp=0. ! default value
+    CALL getin('var_fco2_ocean_cor',var_fco2_ocean_cor_omp)
+
+    read_fco2_land_cor_omp=.FALSE.
+    CALL getin('read_fco2_land_cor',read_fco2_land_cor_omp)
+
+    var_fco2_land_cor_omp=0. ! default value
+    CALL getin('var_fco2_land_cor',var_fco2_land_cor_omp)
+
+    ! level_coupling_esm : level of coupling of the biogeochemical fields between LMDZ, ORCHIDEE and NEMO
+    ! Definitions of level_coupling_esm in physiq.def
+    ! level_coupling_esm = 0  ! No field exchange between LMDZ and ORCHIDEE models
+    !                         ! No field exchange between LMDZ and NEMO
+    ! level_coupling_esm = 1  ! Field exchange between LMDZ and ORCHIDEE models
+    !                         ! No field exchange between LMDZ and NEMO models
+    ! level_coupling_esm = 2  ! No field exchange between LMDZ and ORCHIDEE models
+    !                         ! Field exchange between LMDZ and NEMO models
+    ! level_coupling_esm = 3  ! Field exchange between LMDZ and ORCHIDEE models
+    !                         ! Field exchange between LMDZ and NEMO models
+    level_coupling_esm_omp=0 ! default value
+    CALL getin('level_coupling_esm',level_coupling_esm_omp)
+
+
+    dms_cycle_cpl_omp=.FALSE.
+    CALL getin('transm_dms_oa',dms_cycle_cpl_omp)
+    !
+    !Config Key  = dms_cycle_cpl
+    !Config Desc = receive dms from pisces via oasis
+    !Config Def  = .FALSE.
+    !Config Help = can be activated only if lmdz use inca for the atmospheric chemistry 
+
+    n2o_cycle_cpl_omp=.FALSE.
+    CALL getin('transm_n2o_oa',n2o_cycle_cpl_omp)
+    !
+    !Config Key  = n2o_cycle_cpl
+    !Config Desc = receive n2o from pisces via oasis
+    !Config Def  = .FALSE.
+    !Config Help = can be activated only if lmdz use inca for the atmospheric chemistry 
+    
+    
+    !$OMP END MASTER
+    !$OMP BARRIER
+
+    R_ecc = R_ecc_omp
+    R_peri = R_peri_omp
+    R_incl = R_incl_omp
+    solaire = solaire_omp
+    ok_suntime_rrtm = ok_suntime_rrtm_omp
+    co2_ppm = co2_ppm_omp
+    co2_ppm0 = co2_ppm0_omp
+    RCO2 = RCO2_omp
+    CH4_ppb = CH4_ppb_omp
+    RCH4 = RCH4_omp
+    N2O_ppb = N2O_ppb_omp
+    RN2O = RN2O_omp
+    CFC11_ppt = CFC11_ppt_omp
+    RCFC11 = RCFC11_omp
+    CFC12_ppt = CFC12_ppt_omp
+    RCFC12 = RCFC12_omp
+    RCO2_act = RCO2
+    RCH4_act = RCH4
+    RN2O_act = RN2O
+    RCFC11_act = RCFC11
+    RCFC12_act = RCFC12
+    RCO2_per = RCO2_per_omp
+    RCH4_per = RCH4_per_omp
+    RN2O_per = RN2O_per_omp
+    RCFC11_per = RCFC11_per_omp
+    RCFC12_per = RCFC12_per_omp
+
+    iflag_cycle_diurne = iflag_cycle_diurne_omp
+    soil_model = soil_model_omp
+    new_oliq = new_oliq_omp
+    ok_orodr = ok_orodr_omp
+    ok_orolf = ok_orolf_omp
+    zrel_oro_t=zrel_oro_t_omp
+    zstd_orodr_t=zstd_orodr_t_omp
+    zpmm_orodr_t=zpmm_orodr_t_omp
+    zpmm_orolf_t=zpmm_orolf_t_omp
+    ok_limitvrai = ok_limitvrai_omp
+    nbapp_rad = nbapp_rad_omp
+    iflag_con = iflag_con_omp
+    nbapp_cv = nbapp_cv_omp
+    nbapp_wk = nbapp_wk_omp
+    iflag_ener_conserv = iflag_ener_conserv_omp
+    ok_conserv_q = ok_conserv_q_omp
+    epmax = epmax_omp
+    coef_epmax_cape = coef_epmax_cape_omp
+    ok_adj_ema = ok_adj_ema_omp
+    iflag_clw = iflag_clw_omp
+    solarlong0 = solarlong0_omp
+    qsol0 = qsol0_omp
+    evap0 = evap0_omp
+    albsno0 = albsno0_omp
+    iflag_sic = iflag_sic_omp
+    iflag_inertie = iflag_inertie_omp
+    inertie_sol = inertie_sol_omp
+    inertie_sic = inertie_sic_omp
+    inertie_lic = inertie_lic_omp
+    inertie_sno = inertie_sno_omp
+    ok_bs = ok_bs_omp
+    ok_rad_bs=ok_rad_bs_omp
+    rad_froid = rad_froid_omp
+    rad_chau1 = rad_chau1_omp
+    rad_chau2 = rad_chau2_omp
+    iflag_ice_thermo = iflag_ice_thermo_omp
+    ok_ice_supersat = ok_ice_supersat_omp
+    ok_plane_h2o = ok_plane_h2o_omp
+    ok_plane_contrail = ok_plane_contrail_omp
+    top_height = top_height_omp
+    overlap = overlap_omp
+    cdmmax = cdmmax_omp
+    cdhmax = cdhmax_omp
+    ksta = ksta_omp
+    ksta_ter = ksta_ter_omp
+    f_ri_cd_min = f_ri_cd_min_omp
+    ok_kzmin = ok_kzmin_omp
+    fmagic = fmagic_omp
+    pmagic = pmagic_omp
+    iflag_pbl = iflag_pbl_omp
+    iflag_physiq = iflag_physiq_omp
+    iflag_pbl_split = iflag_pbl_split_omp
+!FC
+    ifl_pbltree = ifl_pbltree_omp
+    Cd_frein    =Cd_frein_omp
+    iflag_order2_sollw = iflag_order2_sollw_omp
+    lev_histhf = lev_histhf_omp
+    lev_histday = lev_histday_omp
+    lev_histmth = lev_histmth_omp
+    lev_histins = lev_histins_omp
+    lev_histLES = lev_histLES_omp
+    lev_histdayNMC = lev_histdayNMC_omp
+    levout_histNMC = levout_histNMC_omp
+    ok_histNMC(:) = ok_histNMC_omp(:)
+    freq_outNMC(:) = freq_outNMC_omp(:)
+    freq_calNMC(:) = freq_calNMC_omp(:)
+
+    type_ocean = type_ocean_omp
+    version_ocean = version_ocean_omp
+    t_coupl = t_coupl_omp
+
+    ok_veget=.TRUE.
+    type_veget=type_veget_omp
+    IF (type_veget=='n' .or. type_veget=='bucket' .or. type_veget=='betaclim') THEN
+       ok_veget=.FALSE.
+    ENDIF
+    ! INLANDSIS
+    !=================================================
+    landice_opt = landice_opt_omp
+    iflag_tsurf_inlandsis = iflag_tsurf_inlandsis_omp
+    iflag_temp_inlandsis = iflag_temp_inlandsis_omp
+    iflag_albcalc = iflag_albcalc_omp
+    SnoMod=SnoMod_omp
+    BloMod=BloMod_omp
+    ok_outfor=ok_outfor_omp
+    is_ok_slush=is_ok_slush_omp
+    opt_runoff_ac=opt_runoff_ac_omp
+    is_ok_z0h_rn=is_ok_z0h_rn_omp
+    is_ok_density_kotlyakov=is_ok_density_kotlyakov_omp
+    prescribed_z0m_snow=prescribed_z0m_snow_omp
+    correc_alb=correc_alb_omp
+    iflag_z0m_snow=iflag_z0m_snow_omp
+    ok_zsn_ii=ok_zsn_ii_omp
+    discret_xf=discret_xf_omp
+    buf_sph_pol=buf_sph_pol_omp
+    buf_siz_pol=buf_siz_pol_omp
+    !=================================================
+    ok_all_xml = ok_all_xml_omp
+    ok_lwoff = ok_lwoff_omp
+    ok_newmicro = ok_newmicro_omp
+    ok_journe = ok_journe_omp
+    ok_hf = ok_hf_omp
+    ok_mensuel = ok_mensuel_omp
+    ok_instan = ok_instan_omp
+    freq_ISCCP = freq_ISCCP_omp
+    ecrit_ISCCP = ecrit_ISCCP_omp
+    freq_COSP = freq_COSP_omp
+    freq_AIRS = freq_AIRS_omp
+    ok_ade = ok_ade_omp
+    ok_aie = ok_aie_omp
+    ok_alw = ok_alw_omp
+    ok_cdnc = ok_cdnc_omp
+    ok_volcan = ok_volcan_omp
+    flag_volc_surfstrat = flag_volc_surfstrat_omp
+    aerosol_couple = aerosol_couple_omp
+    chemistry_couple = chemistry_couple_omp
+    flag_aerosol = flag_aerosol_omp
+    flag_aerosol_strat = flag_aerosol_strat_omp
+    flag_aer_feedback = flag_aer_feedback_omp
+    flag_bc_internal_mixture=flag_bc_internal_mixture_omp
+    aer_type = aer_type_omp
+    bl95_b0 = bl95_b0_omp
+    bl95_b1 = bl95_b1_omp
+    fact_cldcon = fact_cldcon_omp
+    facttemps = facttemps_omp
+    ratqsbas = ratqsbas_omp
+    ratqshaut = ratqshaut_omp
+    tau_ratqs = tau_ratqs_omp
+
+    iflag_radia = iflag_radia_omp
+    iflag_rrtm = iflag_rrtm_omp
+    iflag_albedo = iflag_albedo_omp
+    ok_chlorophyll = ok_chlorophyll_omp
+    NSW = NSW_omp
+    iflag_cld_th = iflag_cld_th_omp
+    iflag_cld_cv = iflag_cld_cv_omp
+    tau_cld_cv = tau_cld_cv_omp
+    coefw_cld_cv = coefw_cld_cv_omp
+    iflag_ratqs = iflag_ratqs_omp
+    ip_ebil_phy = ip_ebil_phy_omp
+    iflag_thermals = iflag_thermals_omp
+    nsplit_thermals = nsplit_thermals_omp
+    tau_thermals = tau_thermals_omp
+    alp_bl_k = alp_bl_k_omp
+    ! nrlmd le 10/04/2012
+    iflag_trig_bl = iflag_trig_bl_omp
+    iflag_strig = iflag_strig_omp
+    s_trig = s_trig_omp
+    h_trig = h_trig_omp
+    tau_trig_shallow = tau_trig_shallow_omp
+    tau_trig_deep = tau_trig_deep_omp
+    iflag_clos_bl = iflag_clos_bl_omp
+    ! fin nrlmd le 10/04/2012
+    iflag_coupl = iflag_coupl_omp
+    iflag_clos = iflag_clos_omp
+    iflag_wake = iflag_wake_omp
+    coef_clos_ls = coef_clos_ls_omp
+    alp_offset = alp_offset_omp
+    iflag_cvl_sigd = iflag_cvl_sigd_omp
+    type_run = type_run_omp
+    ok_cosp = ok_cosp_omp
+    ok_airs = ok_airs_omp
+
+    ok_mensuelCOSP = ok_mensuelCOSP_omp
+    ok_journeCOSP = ok_journeCOSP_omp
+    ok_hfCOSP = ok_hfCOSP_omp
+    seuil_inversion=seuil_inversion_omp
+    lonmin_ins = lonmin_ins_omp
+    lonmax_ins = lonmax_ins_omp
+    latmin_ins = latmin_ins_omp
+    latmax_ins = latmax_ins_omp
+    ecrit_hf   = ecrit_hf_omp
+    ecrit_ins   = ecrit_ins_omp
+    ecrit_day = ecrit_day_omp
+    ecrit_mth = ecrit_mth_omp
+    ecrit_tra = ecrit_tra_omp
+    ecrit_reg = ecrit_reg_omp
+    cvl_comp_threshold = cvl_comp_threshold_omp
+    cvl_sig2feed = cvl_sig2feed_omp
+    cvl_corr = cvl_corr_omp
+    ok_lic_melt = ok_lic_melt_omp
+    ok_lic_cond = ok_lic_cond_omp
+    f_cdrag_ter=f_cdrag_ter_omp
+    f_cdrag_oce=f_cdrag_oce_omp
+
+    f_gust_wk=f_gust_wk_omp
+    f_gust_bl=f_gust_bl_omp
+    f_qsat_oce=f_qsat_oce_omp
+    f_z0qh_oce=f_z0qh_oce_omp
+    min_wind_speed=min_wind_speed_omp
+    iflag_gusts=iflag_gusts_omp
+    iflag_z0_oce=iflag_z0_oce_omp
+
+    z0m_seaice=z0m_seaice_omp
+    z0h_seaice=z0h_seaice_omp
+    z0m_landice=z0m_landice_omp
+    z0h_landice=z0h_landice_omp
+
+    f_rugoro=f_rugoro_omp
+
+    z0min=z0min_omp
+    supcrit1 = supcrit1_omp
+    supcrit2 = supcrit2_omp
+    iflag_mix = iflag_mix_omp
+    iflag_mix_adiab = iflag_mix_adiab_omp
+    scut = scut_omp
+    qqa1 = qqa1_omp
+    qqa2 = qqa2_omp
+    gammas = gammas_omp
+    Fmax = Fmax_omp
+    tmax_fonte_cv = tmax_fonte_cv_omp
+    alphas = alphas_omp
+
+    gkdrag=sso_gkdrag_omp
+    grahilo=sso_grahil_omp
+    grcrit=sso_grcrit_omp
+    gfrcrit=sso_gfrcri_omp
+    gkwake=sso_gkwake_omp 
+    gklift=sso_gklift_omp 
+
+    ok_strato = ok_strato_omp
+    ok_hines = ok_hines_omp
+    ok_gwd_rando = ok_gwd_rando_omp
+    gwd_rando_ruwmax = gwd_rando_ruwmax_omp
+    gwd_rando_sat = gwd_rando_sat_omp
+    gwd_front_ruwmax = gwd_front_ruwmax_omp
+    gwd_front_sat = gwd_front_sat_omp
+    ok_qch4 = ok_qch4_omp
+    ok_LES = ok_LES_omp
+    callstats = callstats_omp
+    ecrit_LES = ecrit_LES_omp
+    adjust_tropopause = adjust_tropopause_omp
+    ok_daily_climoz = ok_daily_climoz_omp
+    carbon_cycle_tr = carbon_cycle_tr_omp
+    carbon_cycle_cpl = carbon_cycle_cpl_omp
+    carbon_cycle_rad = carbon_cycle_rad_omp
+    level_coupling_esm = level_coupling_esm_omp
+    ok_new_lscp = ok_new_lscp_omp
+    ok_icefra_lscp=ok_icefra_lscp_omp
+    read_fco2_ocean_cor = read_fco2_ocean_cor_omp
+    var_fco2_ocean_cor = var_fco2_ocean_cor_omp
+    read_fco2_land_cor = read_fco2_land_cor_omp
+    var_fco2_land_cor = var_fco2_land_cor_omp
+    dms_cycle_cpl = dms_cycle_cpl_omp
+    n2o_cycle_cpl = n2o_cycle_cpl_omp
+    !rajout Olivier Torres
+    kz0=kz0_omp
+    choix_bulk = choix_bulk_omp
+    nit_bulk = nit_bulk_omp
+
+    ! Test of coherence between type_ocean and version_ocean
+    IF (type_ocean=='couple' .AND. (version_ocean/='opa8' .AND. version_ocean/='nemo') ) THEN
+       WRITE(lunout,*)' ERROR version_ocean=',version_ocean,' not valid in coupled configuration'
+       CALL abort_physic('conf_phys','version_ocean not valid',1)
+    ENDIF
+
+    IF (type_ocean=='slab' .AND. version_ocean=='xxxxxx') THEN
+       version_ocean='sicOBS'
+    ELSE IF (type_ocean=='slab' .AND. version_ocean/='sicOBS' &
+         .AND. version_ocean/='sicINT' .AND. version_ocean/='sicNO') THEN
+       WRITE(lunout,*)' ERROR version_ocean=',version_ocean,' not valid with slab ocean'
+       CALL abort_physic('conf_phys','version_ocean not valid',1)
+    ENDIF
+
+    !--test on radiative scheme 
+    IF (iflag_rrtm .EQ. 0) THEN 
+      IF (NSW.NE.2) THEN 
+        WRITE(lunout,*) ' ERROR iflag_rrtm=0 and NSW<>2 not possible'
+        CALL abort_physic('conf_phys','choice NSW not valid',1)
+      ENDIF
+    ELSE IF (iflag_rrtm .EQ. 1) THEN
+      IF (NSW.NE.2.AND.NSW.NE.4.AND.NSW.NE.6) THEN
+        WRITE(lunout,*) ' ERROR iflag_rrtm=1 and NSW<>2,4,6 not possible'
+        CALL abort_physic('conf_phys','choice NSW not valid',1)
+      ENDIF
+   ELSE IF (iflag_rrtm .EQ. 2) THEN
+      IF (NSW.NE.2.AND.NSW.NE.4.AND.NSW.NE.6) THEN
+        WRITE(lunout,*) ' ERROR iflag_rrtm=1 and NSW<>2,4,6 not possible'
+        CALL abort_physic('conf_phys','choice NSW not valid',1)
+      ENDIF
+    ELSE 
+       WRITE(lunout,*) ' ERROR iflag_rrtm<>0,1'
+       CALL abort_physic('conf_phys','choice iflag_rrtm not valid',1)
+    ENDIF
+    !--here we test that solaire has not been changed if ok_suntime_rrtm is activated
+!    IF (ok_suntime_rrtm.AND.ABS(solaire-solaire_omp_init).GT.1.E-7) THEN 
+!       WRITE(lunout,*) ' ERROR ok_suntime_rrtm=y and solaire is provided in def file'
+!       CALL abort_physic('conf_phys','ok_suntime_rrtm=y and solaire is provided',1)
+!    ENDIF
+IF (CPPKEY_STRATAER) THEN
+    IF (iflag_rrtm .NE. 1) THEN
+       WRITE(lunout,*) ' ERROR iflag_rrtm<>1 but StratAer activated'
+       CALL abort_physic('conf_phys','iflag_rrtm not valid for StratAer',1)
+    ENDIF
+    IF (NSW .NE. 6) THEN
+       WRITE(lunout,*) ' ERROR NSW<>6 but StratAer activated'
+       CALL abort_physic('conf_phys','NSW not valid for StratAer',1)
+    ENDIF
+END IF
+
+    !--test on ocean surface albedo
+    IF (iflag_albedo.LT.0.OR.iflag_albedo.GT.2) THEN
+       WRITE(lunout,*) ' ERROR iflag_albedo<>0,1'
+       CALL abort_physic('conf_phys','choice iflag_albedo not valid',1)
+    ENDIF
+
+    ! Flag_aerosol cannot be set to zero if aerosol direct effect (ade) or aerosol indirect effect (aie) are activated
+    IF (ok_ade .OR. ok_aie) THEN 
+       IF ( flag_aerosol .EQ. 0 ) THEN
+          CALL abort_physic('conf_phys','flag_aerosol=0 not compatible avec ok_ade ou ok_aie=.TRUE.',1)
+       ENDIF
+    ENDIF
+
+    ! Flag_aerosol cannot be set to zero if we are in coupled mode for aerosol
+    IF (aerosol_couple .AND. flag_aerosol .EQ. 0 ) THEN
+       CALL abort_physic('conf_phys', 'flag_aerosol cannot be to zero if aerosol_couple=y ', 1)
+    ENDIF
+
+    ! Read_climoz needs to be set zero if we are in couple mode for chemistry 
+    IF (chemistry_couple .AND. read_climoz .ne. 0) THEN 
+       CALL abort_physic('conf_phys', 'read_climoz need to be to zero if chemistry_couple=y ', 1) 
+    ENDIF
+
+    ! flag_aerosol need to be different to zero if ok_cdnc is activated
+    IF (ok_cdnc .AND. flag_aerosol .EQ. 0) THEN
+       CALL abort_physic('conf_phys', 'flag_aerosol cannot be to zero if ok_cdnc is activated ', 1)
+    ENDIF
+
+    ! ok_cdnc must be set to y if ok_aie is activated
+    IF (ok_aie .AND. .NOT. ok_cdnc) THEN
+       CALL abort_physic('conf_phys', 'ok_cdnc must be set to y if ok_aie is activated',1)
+    ENDIF
+
+    ! flag_aerosol=7 => MACv2SP climatology 
+    IF (flag_aerosol.EQ.7.AND. iflag_rrtm.NE.1) THEN
+       CALL abort_physic('conf_phys', 'flag_aerosol=7 (MACv2SP) can only be activated with RRTM',1)
+    ENDIF
+    IF (flag_aerosol.EQ.7.AND. NSW.NE.6) THEN
+       CALL abort_physic('conf_phys', 'flag_aerosol=7 (MACv2SP) can only be activated with NSW=6',1)
+    ENDIF
+
+    ! BC internal mixture is only possible with RRTM & NSW=6 & flag_aerosol=6 or aerosol_couple
+    IF (flag_bc_internal_mixture .AND. NSW.NE.6) THEN 
+       CALL abort_physic('conf_phys', 'flag_bc_internal_mixture can only be activated with NSW=6',1)
+    ENDIF
+    IF (flag_bc_internal_mixture .AND. iflag_rrtm.NE.1) THEN 
+       CALL abort_physic('conf_phys', 'flag_bc_internal_mixture can only be activated with RRTM',1)
+    ENDIF
+    IF (flag_bc_internal_mixture .AND. flag_aerosol.NE.6) THEN 
+       CALL abort_physic('conf_phys', 'flag_bc_internal_mixture can only be activated with flag_aerosol=6',1)
+    ENDIF
+
+    ! test sur flag_volc_surfstrat
+    IF (flag_volc_surfstrat.LT.0.OR.flag_volc_surfstrat.GT.2) THEN
+       CALL abort_physic('conf_phys', 'flag_volc_surfstrat can only be 0 1 or 2',1)
+    ENDIF 
+    IF ((.NOT.ok_volcan.OR..NOT.ok_ade.OR..NOT.ok_aie).AND.flag_volc_surfstrat.GT.0) THEN
+       CALL abort_physic('conf_phys', 'ok_ade, ok_aie, ok_volcan need to be activated if flag_volc_surfstrat is 1 or 2',1)
+    ENDIF 
+
+    ! Test on carbon cycle
+    IF (carbon_cycle_tr .AND. .NOT. carbon_cycle_cpl) THEN
+       CALL abort_physic('conf_phys', 'carbon_cycle_cpl has to be TRUE if carbon_cycle_tr is on',1)
+    ENDIF
+    IF (carbon_cycle_rad .AND. .NOT. carbon_cycle_cpl) THEN
+       CALL abort_physic('conf_phys', 'carbon_cycle_cpl has to be TRUE if carbon_cycle_rad is on',1)
+    ENDIF
+
+
+    ! Test on chemistry cycle 
+    IF ((type_trac .ne. "inca" .AND. type_trac .ne. "inco") .AND. ( dms_cycle_cpl .OR. n2o_cycle_cpl)  ) THEN 
+       CALL abort_physic('conf_phys', 'dms_cycle_cpl or n2o_cycle_cpl has to be TRUE only with INCA coupling model',1)
+    ENDIF
+    
+    ! ORCHIDEE must be activated for ifl_pbltree=1
+    IF (.NOT. ok_veget .AND. ifl_pbltree==1) THEN
+       WRITE(lunout,*)'Warning: ORCHIDEE must be activated for ifl_pbltree=1'
+       WRITE(lunout,*)'ifl_pbltree is now changed to zero'
+       ifl_pbltree=0
+    ENDIF
+
+    !$OMP MASTER
+
+    WRITE(lunout,*) ' ##############################################'
+    WRITE(lunout,*) ' Configuration des parametres de la physique: '
+    WRITE(lunout,*) ' Type ocean = ', type_ocean
+    WRITE(lunout,*) ' Version ocean = ', version_ocean
+    WRITE(lunout,*) ' Config veget = ', ok_veget,type_veget
+    WRITE(lunout,*) ' Snow model landice : landice_opt = ', landice_opt
+    WRITE(lunout,*) ' Config xml pour XIOS : ok_all_xml = ', ok_all_xml
+    WRITE(lunout,*) ' Sortie journaliere = ', ok_journe
+    WRITE(lunout,*) ' Sortie haute frequence = ', ok_hf
+    WRITE(lunout,*) ' Sortie mensuelle = ', ok_mensuel
+    WRITE(lunout,*) ' Sortie instantanee = ', ok_instan
+    WRITE(lunout,*) ' Frequence appel simulateur ISCCP, freq_ISCCP =', freq_ISCCP
+    WRITE(lunout,*) ' Frequence appel simulateur ISCCP, ecrit_ISCCP =', ecrit_ISCCP
+    WRITE(lunout,*) ' Frequence appel simulateur COSP, freq_COSP =', freq_COSP
+    WRITE(lunout,*) ' Frequence appel simulateur AIRS, freq_AIRS =', freq_AIRS
+    WRITE(lunout,*) ' Sortie bilan d''energie, ip_ebil_phy =', ip_ebil_phy
+    WRITE(lunout,*) ' Excentricite = ',R_ecc
+    WRITE(lunout,*) ' Equinoxe = ',R_peri
+    WRITE(lunout,*) ' Inclinaison =',R_incl
+    WRITE(lunout,*) ' Constante solaire =',solaire
+    WRITE(lunout,*) ' ok_suntime_rrtm =',ok_suntime_rrtm
+    WRITE(lunout,*) ' co2_ppm =',co2_ppm
+    WRITE(lunout,*) ' co2_ppm0 =',co2_ppm0
+    WRITE(lunout,*) ' RCO2_act = ',RCO2_act
+    WRITE(lunout,*) ' CH4_ppb =',CH4_ppb,' RCH4_act = ',RCH4_act
+    WRITE(lunout,*) ' N2O_ppb =',N2O_ppb,' RN2O_act=  ',RN2O_act
+    WRITE(lunout,*) ' CFC11_ppt=',CFC11_ppt,' RCFC11_act=  ',RCFC11_act
+    WRITE(lunout,*) ' CFC12_ppt=',CFC12_ppt,' RCFC12_act=  ',RCFC12_act
+    WRITE(lunout,*) ' RCO2_per = ',RCO2_per,' RCH4_per = ', RCH4_per
+    WRITE(lunout,*) ' RN2O_per = ',RN2O_per,' RCFC11_per = ', RCFC11_per
+    WRITE(lunout,*) ' RCFC12_per = ',RCFC12_per
+    WRITE(lunout,*) ' cvl_comp_threshold=', cvl_comp_threshold
+    WRITE(lunout,*) ' cvl_sig2feed=', cvl_sig2feed
+    WRITE(lunout,*) ' cvl_corr=', cvl_corr
+    WRITE(lunout,*) ' ok_lic_melt=', ok_lic_melt
+    WRITE(lunout,*) ' ok_lic_cond=', ok_lic_cond
+    WRITE(lunout,*) ' iflag_cycle_diurne=',iflag_cycle_diurne
+    WRITE(lunout,*) ' soil_model=',soil_model
+    WRITE(lunout,*) ' new_oliq=',new_oliq
+    WRITE(lunout,*) ' ok_orodr=',ok_orodr
+    WRITE(lunout,*) ' ok_orolf=',ok_orolf
+    WRITE(lunout,*) ' zrel_oro_t=',zrel_oro_t
+    WRITE(lunout,*) ' zstd_orodr_t=',zstd_orodr_t
+    WRITE(lunout,*) ' zpmm_orodr_t=',zpmm_orodr_t
+    WRITE(lunout,*) ' zpmm_orolf_t=',zpmm_orolf_t
+    WRITE(lunout,*) ' ok_limitvrai=',ok_limitvrai
+    WRITE(lunout,*) ' nbapp_rad=',nbapp_rad
+    WRITE(lunout,*) ' iflag_con=',iflag_con
+    WRITE(lunout,*) ' nbapp_cv=',nbapp_cv
+    WRITE(lunout,*) ' nbapp_wk=',nbapp_wk
+    WRITE(lunout,*) ' iflag_ener_conserv=',iflag_ener_conserv
+    WRITE(lunout,*) ' ok_conserv_q=',ok_conserv_q
+    WRITE(lunout,*) ' epmax = ', epmax
+    WRITE(lunout,*) ' coef_epmax_cape = ', coef_epmax_cape
+    WRITE(lunout,*) ' ok_adj_ema = ', ok_adj_ema
+    WRITE(lunout,*) ' iflag_clw = ', iflag_clw
+    WRITE(lunout,*) ' iflag_cld_th = ', iflag_cld_th
+    WRITE(lunout,*) ' iflag_cld_cv = ', iflag_cld_cv
+    WRITE(lunout,*) ' tau_cld_cv = ', tau_cld_cv
+    WRITE(lunout,*) ' coefw_cld_cv = ', coefw_cld_cv
+    WRITE(lunout,*) ' iflag_radia = ', iflag_radia
+    WRITE(lunout,*) ' iflag_rrtm = ', iflag_rrtm
+    WRITE(lunout,*) ' NSW = ', NSW
+    WRITE(lunout,*) ' iflag_albedo = ', iflag_albedo !albedo SB
+    WRITE(lunout,*) ' ok_chlorophyll =',ok_chlorophyll ! albedo SB
+    WRITE(lunout,*) ' iflag_ratqs = ', iflag_ratqs
+    WRITE(lunout,*) ' seuil_inversion = ', seuil_inversion
+    WRITE(lunout,*) ' fact_cldcon = ', fact_cldcon
+    WRITE(lunout,*) ' facttemps = ', facttemps
+    WRITE(lunout,*) ' ok_newmicro = ',ok_newmicro 
+    WRITE(lunout,*) ' ratqsbas = ',ratqsbas 
+    WRITE(lunout,*) ' ratqshaut = ',ratqshaut 
+    WRITE(lunout,*) ' tau_ratqs = ',tau_ratqs 
+    WRITE(lunout,*) ' top_height = ',top_height 
+    WRITE(lunout,*) ' rad_froid = ',rad_froid
+    WRITE(lunout,*) ' rad_chau1 = ',rad_chau1
+    WRITE(lunout,*) ' rad_chau2 = ',rad_chau2
+    WRITE(lunout,*) ' iflag_ice_thermo = ',iflag_ice_thermo
+    WRITE(lunout,*) ' ok_ice_supersat = ',ok_ice_supersat
+    WRITE(lunout,*) ' ok_plane_h2o = ',ok_plane_h2o
+    WRITE(lunout,*) ' ok_plane_contrail = ',ok_plane_contrail
+    WRITE(lunout,*) ' overlap = ',overlap 
+    WRITE(lunout,*) ' cdmmax = ',cdmmax 
+    WRITE(lunout,*) ' cdhmax = ',cdhmax 
+    WRITE(lunout,*) ' ksta = ',ksta 
+    WRITE(lunout,*) ' ksta_ter = ',ksta_ter 
+    WRITE(lunout,*) ' f_ri_cd_min = ',f_ri_cd_min 
+    WRITE(lunout,*) ' ok_kzmin = ',ok_kzmin 
+    WRITE(lunout,*) ' fmagic = ',fmagic
+    WRITE(lunout,*) ' pmagic = ',pmagic
+    WRITE(lunout,*) ' ok_ade = ',ok_ade
+    WRITE(lunout,*) ' ok_volcan = ',ok_volcan
+    WRITE(lunout,*) ' flag_volc_surfstrat = ',flag_volc_surfstrat
+    WRITE(lunout,*) ' ok_aie = ',ok_aie
+    WRITE(lunout,*) ' ok_alw = ',ok_alw
+    WRITE(lunout,*) ' aerosol_couple = ', aerosol_couple
+    WRITE(lunout,*) ' chemistry_couple = ', chemistry_couple
+    WRITE(lunout,*) ' flag_aerosol = ', flag_aerosol
+    WRITE(lunout,*) ' flag_aerosol_strat= ', flag_aerosol_strat
+    WRITE(lunout,*) ' flag_aer_feedback= ', flag_aer_feedback
+    WRITE(lunout,*) ' aer_type = ',aer_type
+    WRITE(lunout,*) ' bl95_b0 = ',bl95_b0
+    WRITE(lunout,*) ' bl95_b1 = ',bl95_b1
+    WRITE(lunout,*) ' lev_histhf = ',lev_histhf 
+    WRITE(lunout,*) ' lev_histday = ',lev_histday 
+    WRITE(lunout,*) ' lev_histmth = ',lev_histmth 
+    WRITE(lunout,*) ' lev_histins = ',lev_histins
+    WRITE(lunout,*) ' lev_histLES = ',lev_histLES
+    WRITE(lunout,*) ' lev_histdayNMC = ',lev_histdayNMC
+    WRITE(lunout,*) ' levout_histNMC = ',levout_histNMC
+    WRITE(lunout,*) ' ok_histNMC = ',ok_histNMC
+    WRITE(lunout,*) ' freq_outNMC = ',freq_outNMC
+    WRITE(lunout,*) ' freq_calNMC = ',freq_calNMC
+    WRITE(lunout,*) ' iflag_pbl = ', iflag_pbl
+    WRITE(lunout,*) ' iflag_physiq = ', iflag_physiq
+!FC
+    WRITE(lunout,*) ' ifl_pbltree = ', ifl_pbltree
+    WRITE(lunout,*) ' Cd_frein = ', Cd_frein
+    WRITE(lunout,*) ' iflag_pbl_split = ', iflag_pbl_split
+    WRITE(lunout,*) ' iflag_order2_sollw = ', iflag_order2_sollw
+    WRITE(lunout,*) ' iflag_thermals = ', iflag_thermals
+    WRITE(lunout,*) ' iflag_clos = ', iflag_clos
+    WRITE(lunout,*) ' coef_clos_ls = ', coef_clos_ls
+    WRITE(lunout,*) ' type_run = ',type_run 
+    WRITE(lunout,*) ' ok_cosp = ',ok_cosp
+    WRITE(lunout,*) ' ok_airs = ',ok_airs
+
+    WRITE(lunout,*) ' ok_mensuelCOSP = ',ok_mensuelCOSP
+    WRITE(lunout,*) ' ok_journeCOSP = ',ok_journeCOSP
+    WRITE(lunout,*) ' ok_hfCOSP =',ok_hfCOSP
+    WRITE(lunout,*) ' solarlong0 = ', solarlong0
+    WRITE(lunout,*) ' qsol0 = ', qsol0
+    WRITE(lunout,*) ' evap0 = ', evap0
+    WRITE(lunout,*) ' albsno0 = ', albsno0
+    WRITE(lunout,*) ' iflag_sic = ', iflag_sic
+    WRITE(lunout,*) ' iflag_inertie = ', iflag_inertie
+    WRITE(lunout,*) ' inertie_sol = ', inertie_sol
+    WRITE(lunout,*) ' inertie_sic = ', inertie_sic
+    WRITE(lunout,*) ' inertie_lic = ', inertie_lic
+    WRITE(lunout,*) ' inertie_sno = ', inertie_sno
+    WRITE(lunout,*) ' ok_bs = ', ok_bs
+    WRITE(lunout,*) ' ok_rad_bs = ', ok_rad_bs
+    WRITE(lunout,*) ' f_cdrag_ter = ',f_cdrag_ter
+    WRITE(lunout,*) ' f_cdrag_oce = ',f_cdrag_oce
+    WRITE(lunout,*) ' f_rugoro = ',f_rugoro
+    WRITE(lunout,*) ' z0min = ',z0min
+    WRITE(lunout,*) ' supcrit1 = ', supcrit1
+    WRITE(lunout,*) ' supcrit2 = ', supcrit2
+    WRITE(lunout,*) ' iflag_mix = ', iflag_mix
+    WRITE(lunout,*) ' iflag_mix_adiab = ', iflag_mix_adiab
+    WRITE(lunout,*) ' scut = ', scut
+    WRITE(lunout,*) ' qqa1 = ', qqa1
+    WRITE(lunout,*) ' qqa2 = ', qqa2
+    WRITE(lunout,*) ' gammas = ', gammas
+    WRITE(lunout,*) ' Fmax = ', Fmax
+    WRITE(lunout,*) ' tmax_fonte_cv = ', tmax_fonte_cv
+    WRITE(lunout,*) ' alphas = ', alphas
+    WRITE(lunout,*) ' iflag_wake = ', iflag_wake
+    WRITE(lunout,*) ' alp_offset = ', alp_offset
+    ! nrlmd le 10/04/2012
+    WRITE(lunout,*) ' iflag_trig_bl = ', iflag_trig_bl
+    WRITE(lunout,*) ' iflag_strig = ', iflag_strig
+    WRITE(lunout,*) ' s_trig = ', s_trig
+    WRITE(lunout,*) ' h_trig = ', h_trig
+    WRITE(lunout,*) ' tau_trig_shallow = ', tau_trig_shallow
+    WRITE(lunout,*) ' tau_trig_deep = ', tau_trig_deep
+    WRITE(lunout,*) ' iflag_clos_bl = ', iflag_clos_bl
+    ! fin nrlmd le 10/04/2012
+
+    WRITE(lunout,*) ' lonmin lonmax latmin latmax bilKP_ins =',&
+         lonmin_ins, lonmax_ins, latmin_ins, latmax_ins
+    WRITE(lunout,*) ' ecrit_ hf, ins, day, mth, reg, tra, ISCCP, LES',&
+         ecrit_hf, ecrit_ins, ecrit_day, ecrit_mth, ecrit_reg, ecrit_tra, ecrit_ISCCP, ecrit_LES
+
+    WRITE(lunout,*) ' ok_strato = ', ok_strato
+    WRITE(lunout,*) ' ok_hines = ',  ok_hines
+    WRITE(lunout,*) ' ok_gwd_rando = ',  ok_gwd_rando
+    WRITE(lunout,*) ' ok_qch4 = ',  ok_qch4
+    WRITE(lunout,*) ' gwd_rando_ruwmax = ', gwd_rando_ruwmax
+    WRITE(lunout,*) ' gwd_rando_sat = ', gwd_rando_sat
+    WRITE(lunout,*) ' gwd_front_ruwmax = ', gwd_front_ruwmax
+    WRITE(lunout,*) ' gwd_front_sat = ', gwd_front_sat
+    WRITE(lunout,*) ' SSO gkdrag =',gkdrag
+    WRITE(lunout,*) ' SSO grahilo=',grahilo
+    WRITE(lunout,*) ' SSO grcrit=',grcrit
+    WRITE(lunout,*) ' SSO gfrcrit=',gfrcrit
+    WRITE(lunout,*) ' SSO gkwake=',gkwake
+    WRITE(lunout,*) ' SSO gklift=',gklift
+    WRITE(lunout,*) ' adjust_tropopause = ', adjust_tropopause
+    WRITE(lunout,*) ' ok_daily_climoz = ',ok_daily_climoz
+    WRITE(lunout,*) ' ok_new_lscp = ', ok_new_lscp
+    WRITE(lunout,*) ' ok_icefra_lscp = ', ok_icefra_lscp
+    WRITE(lunout,*) ' read_climoz = ', read_climoz
+    WRITE(lunout,*) ' carbon_cycle_tr = ', carbon_cycle_tr
+    WRITE(lunout,*) ' carbon_cycle_cpl = ', carbon_cycle_cpl
+    WRITE(lunout,*) ' carbon_cycle_rad = ', carbon_cycle_rad
+    WRITE(lunout,*) ' level_coupling_esm = ', level_coupling_esm
+    WRITE(lunout,*) ' read_fco2_ocean_cor = ', read_fco2_ocean_cor
+    WRITE(lunout,*) ' var_fco2_ocean_cor = ', var_fco2_ocean_cor
+    WRITE(lunout,*) ' read_fco2_land_cor = ', read_fco2_land_cor
+    WRITE(lunout,*) ' var_fco2_land_cor = ', var_fco2_land_cor
+    WRITE(lunout,*) ' dms_cycle_cpl = ', dms_cycle_cpl
+    WRITE(lunout,*) ' n2o_cycle_cpl = ', n2o_cycle_cpl
+    WRITE(lunout,*) ' iflag_tsurf_inlandsis = ', iflag_tsurf_inlandsis
+    WRITE(lunout,*) ' iflag_temp_inlandsis = ', iflag_temp_inlandsis
+    WRITE(lunout,*) ' iflag_albcalc = ', iflag_albcalc
+    WRITE(lunout,*) ' SnoMod = ', SnoMod
+    WRITE(lunout,*) ' BloMod = ', BloMod
+    WRITE(lunout,*) ' ok_outfor = ', ok_outfor
+    WRITE(lunout,*) ' is_ok_slush = ', is_ok_slush
+    WRITE(lunout,*) ' opt_runoff_ac = ', opt_runoff_ac
+    WRITE(lunout,*) ' is_ok_z0h_rn = ', is_ok_z0h_rn
+    WRITE(lunout,*) ' is_ok_density_kotlyakov = ', is_ok_density_kotlyakov
+    WRITE(lunout,*) ' prescribed_z0m_snow = ', prescribed_z0m_snow
+    WRITE(lunout,*) ' iflag_z0m_snow = ', iflag_z0m_snow
+    WRITE(lunout,*) ' ok_zsn_ii = ', ok_zsn_ii
+    WRITE(lunout,*) ' discret_xf = ', discret_xf
+    WRITE(lunout,*) ' correc_alb= ', correc_alb
+    WRITE(lunout,*) ' buf_sph_pol = ', buf_sph_pol
+    WRITE(lunout,*) ' buf_siz_pol= ', buf_siz_pol
+    !rajout Olivier Torres
+    write(lunout,*) 'choix_bulk = ', choix_bulk
+    write(lunout,*) 'nit_bulk = ', nit_bulk
+    write(lunout,*) 'kz0 = ', kz0
+
+    !$OMP END MASTER
+    call config_ocean_skin
+
+  END SUBROUTINE conf_phys
+
+END MODULE conf_phys_m
+!
+!#################################################################
+!
+
+SUBROUTINE conf_interface(tau_calv)
+
+  USE IOIPSL
+  USE print_control_mod, ONLY: lunout
+  IMPLICIT NONE
+  ! Configuration de l'interace atm/surf
+  !
+  ! tau_calv:    temps de relaxation pour la fonte des glaciers
+  !
+  REAL          :: tau_calv
+  REAL, SAVE    :: tau_calv_omp
+  !
+  !Config Key  = tau_calv
+  !Config Desc = temps de relaxation pour fonte des glaciers en jours
+  !Config Def  = 1 an 
+  !Config Help = 
+  !
+  tau_calv_omp = 360.*10.
+  !$OMP MASTER
+  CALL getin('tau_calv',tau_calv_omp)
+  !$OMP END MASTER
+  !$OMP BARRIER
+  !
+  tau_calv=tau_calv_omp
+  !
+  !$OMP MASTER
+  WRITE(lunout,*)' ##############################################'
+  WRITE(lunout,*)' Configuration de l''interface atm/surfaces  : '
+  WRITE(lunout,*)' tau_calv = ',tau_calv
+  !$OMP END MASTER
+  !
+  RETURN
+
+END SUBROUTINE conf_interface
Index: DZ6/trunk/libf/phylmd/conflx.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/conflx.F90	(revision 5267)
+++ 	(revision )
@@ -1,1608 +1,0 @@
-
-! $Header$
-
-SUBROUTINE conflx(dtime, pres_h, pres_f, t, q, con_t, con_q, pqhfl, w, d_t, &
-    d_q, rain, snow, pmfu, pmfd, pen_u, pde_u, pen_d, pde_d, kcbot, kctop, &
-    kdtop, pmflxr, pmflxs)
-
-  USE dimphy
-  IMPLICIT NONE
-  ! ======================================================================
-  ! Auteur(s): Z.X. Li (LMD/CNRS) date: 19941014
-  ! Objet: Schema flux de masse pour la convection
-  ! (schema de Tiedtke avec qqs modifications mineures)
-  ! Dec.97: Prise en compte des modifications introduites par
-  ! Olivier Boucher et Alexandre Armengaud pour melange
-  ! et lessivage des traceurs passifs.
-  ! ======================================================================
-  include "YOMCST.h"
-  include "YOETHF.h"
-  ! Entree:
-  REAL dtime ! pas d'integration (s)
-  REAL pres_h(klon, klev+1) ! pression half-level (Pa)
-  REAL pres_f(klon, klev) ! pression full-level (Pa)
-  REAL t(klon, klev) ! temperature (K)
-  REAL q(klon, klev) ! humidite specifique (g/g)
-  REAL w(klon, klev) ! vitesse verticale (Pa/s)
-  REAL con_t(klon, klev) ! convergence de temperature (K/s)
-  REAL con_q(klon, klev) ! convergence de l'eau vapeur (g/g/s)
-  REAL pqhfl(klon) ! evaporation (negative vers haut) mm/s
-  ! Sortie:
-  REAL d_t(klon, klev) ! incrementation de temperature
-  REAL d_q(klon, klev) ! incrementation d'humidite
-  REAL pmfu(klon, klev) ! flux masse (kg/m2/s) panache ascendant
-  REAL pmfd(klon, klev) ! flux masse (kg/m2/s) panache descendant
-  REAL pen_u(klon, klev)
-  REAL pen_d(klon, klev)
-  REAL pde_u(klon, klev)
-  REAL pde_d(klon, klev)
-  REAL rain(klon) ! pluie (mm/s)
-  REAL snow(klon) ! neige (mm/s)
-  REAL pmflxr(klon, klev+1)
-  REAL pmflxs(klon, klev+1)
-  INTEGER kcbot(klon) ! niveau du bas de la convection
-  INTEGER kctop(klon) ! niveau du haut de la convection
-  INTEGER kdtop(klon) ! niveau du haut des downdrafts
-  ! Local:
-  REAL pt(klon, klev)
-  REAL pq(klon, klev)
-  REAL pqs(klon, klev)
-  REAL pvervel(klon, klev)
-  LOGICAL land(klon)
-
-  REAL d_t_bis(klon, klev)
-  REAL d_q_bis(klon, klev)
-  REAL paprs(klon, klev+1)
-  REAL paprsf(klon, klev)
-  REAL zgeom(klon, klev)
-  REAL zcvgq(klon, klev)
-  REAL zcvgt(klon, klev)
-  ! AA
-  REAL zmfu(klon, klev)
-  REAL zmfd(klon, klev)
-  REAL zen_u(klon, klev)
-  REAL zen_d(klon, klev)
-  REAL zde_u(klon, klev)
-  REAL zde_d(klon, klev)
-  REAL zmflxr(klon, klev+1)
-  REAL zmflxs(klon, klev+1)
-  ! AA
-
-
-  INTEGER i, k
-  REAL zdelta, zqsat
-
-  include "FCTTRE.h"
-
-  ! initialiser les variables de sortie (pour securite)
-  DO i = 1, klon
-    rain(i) = 0.0
-    snow(i) = 0.0
-    kcbot(i) = 0
-    kctop(i) = 0
-    kdtop(i) = 0
-  END DO
-  DO k = 1, klev
-    DO i = 1, klon
-      d_t(i, k) = 0.0
-      d_q(i, k) = 0.0
-      pmfu(i, k) = 0.0
-      pmfd(i, k) = 0.0
-      pen_u(i, k) = 0.0
-      pde_u(i, k) = 0.0
-      pen_d(i, k) = 0.0
-      pde_d(i, k) = 0.0
-      zmfu(i, k) = 0.0
-      zmfd(i, k) = 0.0
-      zen_u(i, k) = 0.0
-      zde_u(i, k) = 0.0
-      zen_d(i, k) = 0.0
-      zde_d(i, k) = 0.0
-    END DO
-  END DO
-  DO k = 1, klev + 1
-    DO i = 1, klon
-      zmflxr(i, k) = 0.0
-      zmflxs(i, k) = 0.0
-    END DO
-  END DO
-
-  ! calculer la nature du sol (pour l'instant, ocean partout)
-  DO i = 1, klon
-    land(i) = .FALSE.
-  END DO
-
-  ! preparer les variables d'entree (attention: l'ordre des niveaux
-  ! verticaux augmente du haut vers le bas)
-  DO k = 1, klev
-    DO i = 1, klon
-      pt(i, k) = t(i, klev-k+1)
-      pq(i, k) = q(i, klev-k+1)
-      paprsf(i, k) = pres_f(i, klev-k+1)
-      paprs(i, k) = pres_h(i, klev+1-k+1)
-      pvervel(i, k) = w(i, klev+1-k)
-      zcvgt(i, k) = con_t(i, klev-k+1)
-      zcvgq(i, k) = con_q(i, klev-k+1)
-
-      zdelta = max(0., sign(1.,rtt-pt(i,k)))
-      zqsat = r2es*foeew(pt(i,k), zdelta)/paprsf(i, k)
-      zqsat = min(0.5, zqsat)
-      zqsat = zqsat/(1.-retv*zqsat)
-      pqs(i, k) = zqsat
-    END DO
-  END DO
-  DO i = 1, klon
-    paprs(i, klev+1) = pres_h(i, 1)
-    zgeom(i, klev) = rd*pt(i, klev)/(0.5*(paprs(i,klev+1)+paprsf(i, &
-      klev)))*(paprs(i,klev+1)-paprsf(i,klev))
-  END DO
-  DO k = klev - 1, 1, -1
-    DO i = 1, klon
-      zgeom(i, k) = zgeom(i, k+1) + rd*0.5*(pt(i,k+1)+pt(i,k))/paprs(i, k+1)* &
-        (paprsf(i,k+1)-paprsf(i,k))
-    END DO
-  END DO
-
-  ! appeler la routine principale
-
-  CALL flxmain(dtime, pt, pq, pqs, pqhfl, paprsf, paprs, zgeom, land, zcvgt, &
-    zcvgq, pvervel, rain, snow, kcbot, kctop, kdtop, zmfu, zmfd, zen_u, &
-    zde_u, zen_d, zde_d, d_t_bis, d_q_bis, zmflxr, zmflxs)
-
-  ! AA--------------------------------------------------------
-  ! AA rem : De la meme facon que l'on effectue le reindicage
-  ! AA       pour la temperature t et le champ q
-  ! AA       on reindice les flux necessaires a la convection
-  ! AA       des traceurs
-  ! AA--------------------------------------------------------
-  DO k = 1, klev
-    DO i = 1, klon
-      d_q(i, klev+1-k) = dtime*d_q_bis(i, k)
-      d_t(i, klev+1-k) = dtime*d_t_bis(i, k)
-    END DO
-  END DO
-
-  DO i = 1, klon
-    pmfu(i, 1) = 0.
-    pmfd(i, 1) = 0.
-    pen_d(i, 1) = 0.
-    pde_d(i, 1) = 0.
-  END DO
-
-  DO k = 2, klev
-    DO i = 1, klon
-      pmfu(i, klev+2-k) = zmfu(i, k)
-      pmfd(i, klev+2-k) = zmfd(i, k)
-    END DO
-  END DO
-
-  DO k = 1, klev
-    DO i = 1, klon
-      pen_u(i, klev+1-k) = zen_u(i, k)
-      pde_u(i, klev+1-k) = zde_u(i, k)
-    END DO
-  END DO
-
-  DO k = 1, klev - 1
-    DO i = 1, klon
-      pen_d(i, klev+1-k) = -zen_d(i, k+1)
-      pde_d(i, klev+1-k) = -zde_d(i, k+1)
-    END DO
-  END DO
-
-  DO k = 1, klev + 1
-    DO i = 1, klon
-      pmflxr(i, klev+2-k) = zmflxr(i, k)
-      pmflxs(i, klev+2-k) = zmflxs(i, k)
-    END DO
-  END DO
-
-  RETURN
-END SUBROUTINE conflx
-! --------------------------------------------------------------------
-SUBROUTINE flxmain(pdtime, pten, pqen, pqsen, pqhfl, pap, paph, pgeo, ldland, &
-    ptte, pqte, pvervel, prsfc, pssfc, kcbot, kctop, kdtop, & ! *
-                                                              ! ldcum, ktype,
-    pmfu, pmfd, pen_u, pde_u, pen_d, pde_d, dt_con, dq_con, pmflxr, pmflxs)
-  USE dimphy
-  IMPLICIT NONE
-  ! ------------------------------------------------------------------
-  include "YOMCST.h"
-  include "YOETHF.h"
-  include "YOECUMF.h"
-  ! ----------------------------------------------------------------
-  REAL pten(klon, klev), pqen(klon, klev), pqsen(klon, klev)
-  REAL ptte(klon, klev)
-  REAL pqte(klon, klev)
-  REAL pvervel(klon, klev)
-  REAL pgeo(klon, klev), pap(klon, klev), paph(klon, klev+1)
-  REAL pqhfl(klon)
-
-  REAL ptu(klon, klev), pqu(klon, klev), plu(klon, klev)
-  REAL plude(klon, klev)
-  REAL pmfu(klon, klev)
-  REAL prsfc(klon), pssfc(klon)
-  INTEGER kcbot(klon), kctop(klon), ktype(klon)
-  LOGICAL ldland(klon), ldcum(klon)
-
-  REAL ztenh(klon, klev), zqenh(klon, klev), zqsenh(klon, klev)
-  REAL zgeoh(klon, klev)
-  REAL zmfub(klon), zmfub1(klon)
-  REAL zmfus(klon, klev), zmfuq(klon, klev), zmful(klon, klev)
-  REAL zdmfup(klon, klev), zdpmel(klon, klev)
-  REAL zentr(klon), zhcbase(klon)
-  REAL zdqpbl(klon), zdqcv(klon), zdhpbl(klon)
-  REAL zrfl(klon)
-  REAL pmflxr(klon, klev+1)
-  REAL pmflxs(klon, klev+1)
-  INTEGER ilab(klon, klev), ictop0(klon)
-  LOGICAL llo1
-  REAL dt_con(klon, klev), dq_con(klon, klev)
-  REAL zmfmax, zdh
-  REAL pdtime, zqumqe, zdqmin, zalvdcp, zhsat, zzz
-  REAL zhhat, zpbmpt, zgam, zeps, zfac
-  INTEGER i, k, ikb, itopm2, kcum
-
-  REAL pen_u(klon, klev), pde_u(klon, klev)
-  REAL pen_d(klon, klev), pde_d(klon, klev)
-
-  REAL ptd(klon, klev), pqd(klon, klev), pmfd(klon, klev)
-  REAL zmfds(klon, klev), zmfdq(klon, klev), zdmfdp(klon, klev)
-  INTEGER kdtop(klon)
-  LOGICAL lddraf(klon)
-  ! ---------------------------------------------------------------------
-  LOGICAL firstcal
-  SAVE firstcal
-  DATA firstcal/.TRUE./
-  !$OMP THREADPRIVATE(firstcal)
-  ! ---------------------------------------------------------------------
-  IF (firstcal) THEN
-    CALL flxsetup
-    firstcal = .FALSE.
-  END IF
-  ! ---------------------------------------------------------------------
-  DO i = 1, klon
-    ldcum(i) = .FALSE.
-  END DO
-  DO k = 1, klev
-    DO i = 1, klon
-      dt_con(i, k) = 0.0
-      dq_con(i, k) = 0.0
-    END DO
-  END DO
-  ! ----------------------------------------------------------------------
-  ! initialiser les variables et faire l'interpolation verticale
-  ! ----------------------------------------------------------------------
-  CALL flxini(pten, pqen, pqsen, pgeo, paph, zgeoh, ztenh, zqenh, zqsenh, &
-    ptu, pqu, ptd, pqd, pmfd, zmfds, zmfdq, zdmfdp, pmfu, zmfus, zmfuq, &
-    zdmfup, zdpmel, plu, plude, ilab, pen_u, pde_u, pen_d, pde_d)
-  ! ---------------------------------------------------------------------
-  ! determiner les valeurs au niveau de base de la tour convective
-  ! ---------------------------------------------------------------------
-  CALL flxbase(ztenh, zqenh, zgeoh, paph, ptu, pqu, plu, ldcum, kcbot, ilab)
-  ! ---------------------------------------------------------------------
-  ! calculer la convergence totale de l'humidite et celle en provenance
-  ! de la couche limite, plus precisement, la convergence integree entre
-  ! le sol et la base de la convection. Cette derniere convergence est
-  ! comparee avec l'evaporation obtenue dans la couche limite pour
-  ! determiner le type de la convection
-  ! ---------------------------------------------------------------------
-  k = 1
-  DO i = 1, klon
-    zdqcv(i) = pqte(i, k)*(paph(i,k+1)-paph(i,k))
-    zdhpbl(i) = 0.0
-    zdqpbl(i) = 0.0
-  END DO
-
-  DO k = 2, klev
-    DO i = 1, klon
-      zdqcv(i) = zdqcv(i) + pqte(i, k)*(paph(i,k+1)-paph(i,k))
-      IF (k>=kcbot(i)) THEN
-        zdqpbl(i) = zdqpbl(i) + pqte(i, k)*(paph(i,k+1)-paph(i,k))
-        zdhpbl(i) = zdhpbl(i) + (rcpd*ptte(i,k)+rlvtt*pqte(i,k))*(paph(i,k+1) &
-          -paph(i,k))
-      END IF
-    END DO
-  END DO
-
-  DO i = 1, klon
-    ktype(i) = 2
-    IF (zdqcv(i)>max(0.,-1.5*pqhfl(i)*rg)) ktype(i) = 1
-    ! cc         if (zdqcv(i).GT.MAX(0.,-1.1*pqhfl(i)*RG)) ktype(i) = 1
-  END DO
-
-  ! ---------------------------------------------------------------------
-  ! determiner le flux de masse entrant a travers la base.
-  ! on ignore, pour l'instant, l'effet du panache descendant
-  ! ---------------------------------------------------------------------
-  DO i = 1, klon
-    ikb = kcbot(i)
-    zqumqe = pqu(i, ikb) + plu(i, ikb) - zqenh(i, ikb)
-    zdqmin = max(0.01*zqenh(i,ikb), 1.E-10)
-    IF (zdqpbl(i)>0. .AND. zqumqe>zdqmin .AND. ldcum(i)) THEN
-      zmfub(i) = zdqpbl(i)/(rg*max(zqumqe,zdqmin))
-    ELSE
-      zmfub(i) = 0.01
-      ldcum(i) = .FALSE.
-    END IF
-    IF (ktype(i)==2) THEN
-      zdh = rcpd*(ptu(i,ikb)-ztenh(i,ikb)) + rlvtt*zqumqe
-      zdh = rg*max(zdh, 1.0E5*zdqmin)
-      IF (zdhpbl(i)>0. .AND. ldcum(i)) zmfub(i) = zdhpbl(i)/zdh
-    END IF
-    zmfmax = (paph(i,ikb)-paph(i,ikb-1))/(rg*pdtime)
-    zmfub(i) = min(zmfub(i), zmfmax)
-    zentr(i) = entrscv
-    IF (ktype(i)==1) zentr(i) = entrpen
-  END DO
-  ! -----------------------------------------------------------------------
-  ! DETERMINE CLOUD ASCENT FOR ENTRAINING PLUME
-  ! -----------------------------------------------------------------------
-  ! (A) calculer d'abord la hauteur "theorique" de la tour convective sans
-  ! considerer l'entrainement ni le detrainement du panache, sachant
-  ! ces derniers peuvent abaisser la hauteur theorique.
-
-  DO i = 1, klon
-    ikb = kcbot(i)
-    zhcbase(i) = rcpd*ptu(i, ikb) + zgeoh(i, ikb) + rlvtt*pqu(i, ikb)
-    ictop0(i) = kcbot(i) - 1
-  END DO
-
-  zalvdcp = rlvtt/rcpd
-  DO k = klev - 1, 3, -1
-    DO i = 1, klon
-      zhsat = rcpd*ztenh(i, k) + zgeoh(i, k) + rlvtt*zqsenh(i, k)
-      zgam = r5les*zalvdcp*zqsenh(i, k)/((1.-retv*zqsenh(i,k))*(ztenh(i, &
-        k)-r4les)**2)
-      zzz = rcpd*ztenh(i, k)*0.608
-      zhhat = zhsat - (zzz+zgam*zzz)/(1.+zgam*zzz/rlvtt)*max(zqsenh(i,k)- &
-        zqenh(i,k), 0.)
-      IF (k<ictop0(i) .AND. zhcbase(i)>zhhat) ictop0(i) = k
-    END DO
-  END DO
-
-  ! (B) calculer le panache ascendant
-
-  CALL flxasc(pdtime, ztenh, zqenh, pten, pqen, pqsen, pgeo, zgeoh, pap, &
-    paph, pqte, pvervel, ldland, ldcum, ktype, ilab, ptu, pqu, plu, pmfu, &
-    zmfub, zentr, zmfus, zmfuq, zmful, plude, zdmfup, kcbot, kctop, ictop0, &
-    kcum, pen_u, pde_u)
-  IF (kcum==0) GO TO 1000
-
-  ! verifier l'epaisseur de la convection et changer eventuellement
-  ! le taux d'entrainement/detrainement
-
-  DO i = 1, klon
-    zpbmpt = paph(i, kcbot(i)) - paph(i, kctop(i))
-    IF (ldcum(i) .AND. ktype(i)==1 .AND. zpbmpt<2.E4) ktype(i) = 2
-    IF (ldcum(i)) ictop0(i) = kctop(i)
-    IF (ktype(i)==2) zentr(i) = entrscv
-  END DO
-
-  IF (lmfdd) THEN ! si l'on considere le panache descendant
-
-    ! calculer la precipitation issue du panache ascendant pour
-    ! determiner l'existence du panache descendant dans la convection
-    DO i = 1, klon
-      zrfl(i) = zdmfup(i, 1)
-    END DO
-    DO k = 2, klev
-      DO i = 1, klon
-        zrfl(i) = zrfl(i) + zdmfup(i, k)
-      END DO
-    END DO
-
-    ! determiner le LFS (level of free sinking: niveau de plonge libre)
-    CALL flxdlfs(ztenh, zqenh, zgeoh, paph, ptu, pqu, ldcum, kcbot, kctop, &
-      zmfub, zrfl, ptd, pqd, pmfd, zmfds, zmfdq, zdmfdp, kdtop, lddraf)
-
-    ! calculer le panache descendant
-    CALL flxddraf(ztenh, zqenh, zgeoh, paph, zrfl, ptd, pqd, pmfd, zmfds, &
-      zmfdq, zdmfdp, lddraf, pen_d, pde_d)
-
-    ! calculer de nouveau le flux de masse entrant a travers la base
-    ! de la convection, sachant qu'il a ete modifie par le panache
-    ! descendant
-    DO i = 1, klon
-      IF (lddraf(i)) THEN
-        ikb = kcbot(i)
-        llo1 = pmfd(i, ikb) < 0.
-        zeps = 0.
-        IF (llo1) zeps = cmfdeps
-        zqumqe = pqu(i, ikb) + plu(i, ikb) - zeps*pqd(i, ikb) - &
-          (1.-zeps)*zqenh(i, ikb)
-        zdqmin = max(0.01*zqenh(i,ikb), 1.E-10)
-        zmfmax = (paph(i,ikb)-paph(i,ikb-1))/(rg*pdtime)
-        IF (zdqpbl(i)>0. .AND. zqumqe>zdqmin .AND. ldcum(i) .AND. &
-            zmfub(i)<zmfmax) THEN
-          zmfub1(i) = zdqpbl(i)/(rg*max(zqumqe,zdqmin))
-        ELSE
-          zmfub1(i) = zmfub(i)
-        END IF
-        IF (ktype(i)==2) THEN
-          zdh = rcpd*(ptu(i,ikb)-zeps*ptd(i,ikb)-(1.-zeps)*ztenh(i,ikb)) + &
-            rlvtt*zqumqe
-          zdh = rg*max(zdh, 1.0E5*zdqmin)
-          IF (zdhpbl(i)>0. .AND. ldcum(i)) zmfub1(i) = zdhpbl(i)/zdh
-        END IF
-        IF (.NOT. ((ktype(i)==1 .OR. ktype(i)==2) .AND. abs(zmfub1(i)-zmfub(i &
-          ))<0.2*zmfub(i))) zmfub1(i) = zmfub(i)
-      END IF
-    END DO
-    DO k = 1, klev
-      DO i = 1, klon
-        IF (lddraf(i)) THEN
-          zfac = zmfub1(i)/max(zmfub(i), 1.E-10)
-          pmfd(i, k) = pmfd(i, k)*zfac
-          zmfds(i, k) = zmfds(i, k)*zfac
-          zmfdq(i, k) = zmfdq(i, k)*zfac
-          zdmfdp(i, k) = zdmfdp(i, k)*zfac
-          pen_d(i, k) = pen_d(i, k)*zfac
-          pde_d(i, k) = pde_d(i, k)*zfac
-        END IF
-      END DO
-    END DO
-    DO i = 1, klon
-      IF (lddraf(i)) zmfub(i) = zmfub1(i)
-    END DO
-
-  END IF ! fin de test sur lmfdd
-
-  ! -----------------------------------------------------------------------
-  ! calculer de nouveau le panache ascendant
-  ! -----------------------------------------------------------------------
-  CALL flxasc(pdtime, ztenh, zqenh, pten, pqen, pqsen, pgeo, zgeoh, pap, &
-    paph, pqte, pvervel, ldland, ldcum, ktype, ilab, ptu, pqu, plu, pmfu, &
-    zmfub, zentr, zmfus, zmfuq, zmful, plude, zdmfup, kcbot, kctop, ictop0, &
-    kcum, pen_u, pde_u)
-
-  ! -----------------------------------------------------------------------
-  ! determiner les flux convectifs en forme finale, ainsi que
-  ! la quantite des precipitations
-  ! -----------------------------------------------------------------------
-  CALL flxflux(pdtime, pqen, pqsen, ztenh, zqenh, pap, paph, ldland, zgeoh, &
-    kcbot, kctop, lddraf, kdtop, ktype, ldcum, pmfu, pmfd, zmfus, zmfds, &
-    zmfuq, zmfdq, zmful, plude, zdmfup, zdmfdp, pten, prsfc, pssfc, zdpmel, &
-    itopm2, pmflxr, pmflxs)
-
-  ! ----------------------------------------------------------------------
-  ! calculer les tendances pour T et Q
-  ! ----------------------------------------------------------------------
-  CALL flxdtdq(pdtime, itopm2, paph, ldcum, pten, zmfus, zmfds, zmfuq, zmfdq, &
-    zmful, zdmfup, zdmfdp, zdpmel, dt_con, dq_con)
-
-1000 CONTINUE
-  RETURN
-END SUBROUTINE flxmain
-SUBROUTINE flxini(pten, pqen, pqsen, pgeo, paph, pgeoh, ptenh, pqenh, pqsenh, &
-    ptu, pqu, ptd, pqd, pmfd, pmfds, pmfdq, pdmfdp, pmfu, pmfus, pmfuq, &
-    pdmfup, pdpmel, plu, plude, klab, pen_u, pde_u, pen_d, pde_d)
-  USE dimphy
-  IMPLICIT NONE
-  ! ----------------------------------------------------------------------
-  ! THIS ROUTINE INTERPOLATES LARGE-SCALE FIELDS OF T,Q ETC.
-  ! TO HALF LEVELS (I.E. GRID FOR MASSFLUX SCHEME),
-  ! AND INITIALIZES VALUES FOR UPDRAFTS
-  ! ----------------------------------------------------------------------
-  include "YOMCST.h"
-  include "YOETHF.h"
-
-  REAL pten(klon, klev) ! temperature (environnement)
-  REAL pqen(klon, klev) ! humidite (environnement)
-  REAL pqsen(klon, klev) ! humidite saturante (environnement)
-  REAL pgeo(klon, klev) ! geopotentiel (g * metre)
-  REAL pgeoh(klon, klev) ! geopotentiel aux demi-niveaux
-  REAL paph(klon, klev+1) ! pression aux demi-niveaux
-  REAL ptenh(klon, klev) ! temperature aux demi-niveaux
-  REAL pqenh(klon, klev) ! humidite aux demi-niveaux
-  REAL pqsenh(klon, klev) ! humidite saturante aux demi-niveaux
-
-  REAL ptu(klon, klev) ! temperature du panache ascendant (p-a)
-  REAL pqu(klon, klev) ! humidite du p-a
-  REAL plu(klon, klev) ! eau liquide du p-a
-  REAL pmfu(klon, klev) ! flux de masse du p-a
-  REAL pmfus(klon, klev) ! flux de l'energie seche dans le p-a
-  REAL pmfuq(klon, klev) ! flux de l'humidite dans le p-a
-  REAL pdmfup(klon, klev) ! quantite de l'eau precipitee dans p-a
-  REAL plude(klon, klev) ! quantite de l'eau liquide jetee du
-  ! p-a a l'environnement
-  REAL pdpmel(klon, klev) ! quantite de neige fondue
-
-  REAL ptd(klon, klev) ! temperature du panache descendant (p-d)
-  REAL pqd(klon, klev) ! humidite du p-d
-  REAL pmfd(klon, klev) ! flux de masse du p-d
-  REAL pmfds(klon, klev) ! flux de l'energie seche dans le p-d
-  REAL pmfdq(klon, klev) ! flux de l'humidite dans le p-d
-  REAL pdmfdp(klon, klev) ! quantite de precipitation dans p-d
-
-  REAL pen_u(klon, klev) ! quantite de masse entrainee pour p-a
-  REAL pde_u(klon, klev) ! quantite de masse detrainee pour p-a
-  REAL pen_d(klon, klev) ! quantite de masse entrainee pour p-d
-  REAL pde_d(klon, klev) ! quantite de masse detrainee pour p-d
-
-  INTEGER klab(klon, klev)
-  LOGICAL llflag(klon)
-  INTEGER k, i, icall
-  REAL zzs
-  ! ----------------------------------------------------------------------
-  ! SPECIFY LARGE SCALE PARAMETERS AT HALF LEVELS
-  ! ADJUST TEMPERATURE FIELDS IF STATICLY UNSTABLE
-  ! ----------------------------------------------------------------------
-  DO k = 2, klev
-
-    DO i = 1, klon
-      pgeoh(i, k) = pgeo(i, k) + (pgeo(i,k-1)-pgeo(i,k))*0.5
-      ptenh(i, k) = (max(rcpd*pten(i,k-1)+pgeo(i,k-1),rcpd*pten(i,k)+pgeo(i, &
-        k))-pgeoh(i,k))/rcpd
-      pqsenh(i, k) = pqsen(i, k-1)
-      llflag(i) = .TRUE.
-    END DO
-
-    icall = 0
-    CALL flxadjtq(paph(1,k), ptenh(1,k), pqsenh(1,k), llflag, icall)
-
-    DO i = 1, klon
-      pqenh(i, k) = min(pqen(i,k-1), pqsen(i,k-1)) + &
-        (pqsenh(i,k)-pqsen(i,k-1))
-      pqenh(i, k) = max(pqenh(i,k), 0.)
-    END DO
-
-  END DO
-
-  DO i = 1, klon
-    ptenh(i, klev) = (rcpd*pten(i,klev)+pgeo(i,klev)-pgeoh(i,klev))/rcpd
-    pqenh(i, klev) = pqen(i, klev)
-    ptenh(i, 1) = pten(i, 1)
-    pqenh(i, 1) = pqen(i, 1)
-    pgeoh(i, 1) = pgeo(i, 1)
-  END DO
-
-  DO k = klev - 1, 2, -1
-    DO i = 1, klon
-      zzs = max(rcpd*ptenh(i,k)+pgeoh(i,k), rcpd*ptenh(i,k+1)+pgeoh(i,k+1))
-      ptenh(i, k) = (zzs-pgeoh(i,k))/rcpd
-    END DO
-  END DO
-
-  ! -----------------------------------------------------------------------
-  ! INITIALIZE VALUES FOR UPDRAFTS AND DOWNDRAFTS
-  ! -----------------------------------------------------------------------
-  DO k = 1, klev
-    DO i = 1, klon
-      ptu(i, k) = ptenh(i, k)
-      pqu(i, k) = pqenh(i, k)
-      plu(i, k) = 0.
-      pmfu(i, k) = 0.
-      pmfus(i, k) = 0.
-      pmfuq(i, k) = 0.
-      pdmfup(i, k) = 0.
-      pdpmel(i, k) = 0.
-      plude(i, k) = 0.
-
-      klab(i, k) = 0
-
-      ptd(i, k) = ptenh(i, k)
-      pqd(i, k) = pqenh(i, k)
-      pmfd(i, k) = 0.0
-      pmfds(i, k) = 0.0
-      pmfdq(i, k) = 0.0
-      pdmfdp(i, k) = 0.0
-
-      pen_u(i, k) = 0.0
-      pde_u(i, k) = 0.0
-      pen_d(i, k) = 0.0
-      pde_d(i, k) = 0.0
-    END DO
-  END DO
-
-  RETURN
-END SUBROUTINE flxini
-SUBROUTINE flxbase(ptenh, pqenh, pgeoh, paph, ptu, pqu, plu, ldcum, kcbot, &
-    klab)
-  USE dimphy
-  IMPLICIT NONE
-  ! ----------------------------------------------------------------------
-  ! THIS ROUTINE CALCULATES CLOUD BASE VALUES (T AND Q)
-
-  ! INPUT ARE ENVIRONM. VALUES OF T,Q,P,PHI AT HALF LEVELS.
-  ! IT RETURNS CLOUD BASE VALUES AND FLAGS AS FOLLOWS;
-  ! klab=1 FOR SUBCLOUD LEVELS
-  ! klab=2 FOR CONDENSATION LEVEL
-
-  ! LIFT SURFACE AIR DRY-ADIABATICALLY TO CLOUD BASE
-  ! (NON ENTRAINING PLUME,I.E.CONSTANT MASSFLUX)
-  ! ----------------------------------------------------------------------
-  include "YOMCST.h"
-  include "YOETHF.h"
-  ! ----------------------------------------------------------------
-  REAL ptenh(klon, klev), pqenh(klon, klev)
-  REAL pgeoh(klon, klev), paph(klon, klev+1)
-
-  REAL ptu(klon, klev), pqu(klon, klev), plu(klon, klev)
-  INTEGER klab(klon, klev), kcbot(klon)
-
-  LOGICAL llflag(klon), ldcum(klon)
-  INTEGER i, k, icall, is
-  REAL zbuo, zqold(klon)
-  ! ----------------------------------------------------------------------
-  ! INITIALIZE VALUES AT LIFTING LEVEL
-  ! ----------------------------------------------------------------------
-  DO i = 1, klon
-    klab(i, klev) = 1
-    kcbot(i) = klev - 1
-    ldcum(i) = .FALSE.
-  END DO
-  ! ----------------------------------------------------------------------
-  ! DO ASCENT IN SUBCLOUD LAYER,
-  ! CHECK FOR EXISTENCE OF CONDENSATION LEVEL,
-  ! ADJUST T,Q AND L ACCORDINGLY
-  ! CHECK FOR BUOYANCY AND SET FLAGS
-  ! ----------------------------------------------------------------------
-  DO k = klev - 1, 2, -1
-
-    is = 0
-    DO i = 1, klon
-      IF (klab(i,k+1)==1) is = is + 1
-      llflag(i) = .FALSE.
-      IF (klab(i,k+1)==1) llflag(i) = .TRUE.
-    END DO
-    IF (is==0) GO TO 290
-
-    DO i = 1, klon
-      IF (llflag(i)) THEN
-        pqu(i, k) = pqu(i, k+1)
-        ptu(i, k) = ptu(i, k+1) + (pgeoh(i,k+1)-pgeoh(i,k))/rcpd
-        zbuo = ptu(i, k)*(1.+retv*pqu(i,k)) - ptenh(i, k)*(1.+retv*pqenh(i,k) &
-          ) + 0.5
-        IF (zbuo>0.) klab(i, k) = 1
-        zqold(i) = pqu(i, k)
-      END IF
-    END DO
-
-    icall = 1
-    CALL flxadjtq(paph(1,k), ptu(1,k), pqu(1,k), llflag, icall)
-
-    DO i = 1, klon
-      IF (llflag(i) .AND. pqu(i,k)/=zqold(i)) THEN
-        klab(i, k) = 2
-        plu(i, k) = plu(i, k) + zqold(i) - pqu(i, k)
-        zbuo = ptu(i, k)*(1.+retv*pqu(i,k)) - ptenh(i, k)*(1.+retv*pqenh(i,k) &
-          ) + 0.5
-        IF (zbuo>0.) kcbot(i) = k
-        IF (zbuo>0.) ldcum(i) = .TRUE.
-      END IF
-    END DO
-
-290 END DO
-
-  RETURN
-END SUBROUTINE flxbase
-SUBROUTINE flxasc(pdtime, ptenh, pqenh, pten, pqen, pqsen, pgeo, pgeoh, pap, &
-    paph, pqte, pvervel, ldland, ldcum, ktype, klab, ptu, pqu, plu, pmfu, &
-    pmfub, pentr, pmfus, pmfuq, pmful, plude, pdmfup, kcbot, kctop, kctop0, &
-    kcum, pen_u, pde_u)
-  USE dimphy
-  IMPLICIT NONE
-  ! ----------------------------------------------------------------------
-  ! THIS ROUTINE DOES THE CALCULATIONS FOR CLOUD ASCENTS
-  ! FOR CUMULUS PARAMETERIZATION
-  ! ----------------------------------------------------------------------
-  include "YOMCST.h"
-  include "YOETHF.h"
-  include "YOECUMF.h"
-
-  REAL pdtime
-  REAL pten(klon, klev), ptenh(klon, klev)
-  REAL pqen(klon, klev), pqenh(klon, klev), pqsen(klon, klev)
-  REAL pgeo(klon, klev), pgeoh(klon, klev)
-  REAL pap(klon, klev), paph(klon, klev+1)
-  REAL pqte(klon, klev)
-  REAL pvervel(klon, klev) ! vitesse verticale en Pa/s
-
-  REAL pmfub(klon), pentr(klon)
-  REAL ptu(klon, klev), pqu(klon, klev), plu(klon, klev)
-  REAL plude(klon, klev)
-  REAL pmfu(klon, klev), pmfus(klon, klev)
-  REAL pmfuq(klon, klev), pmful(klon, klev)
-  REAL pdmfup(klon, klev)
-  INTEGER ktype(klon), klab(klon, klev), kcbot(klon), kctop(klon)
-  INTEGER kctop0(klon)
-  LOGICAL ldland(klon), ldcum(klon)
-
-  REAL pen_u(klon, klev), pde_u(klon, klev)
-  REAL zqold(klon)
-  REAL zdland(klon)
-  LOGICAL llflag(klon)
-  INTEGER k, i, is, icall, kcum
-  REAL ztglace, zdphi, zqeen, zseen, zscde, zqude
-  REAL zmfusk, zmfuqk, zmfulk, zbuo, zdnoprc, zprcon, zlnew
-
-  REAL zpbot(klon), zptop(klon), zrho(klon)
-  REAL zdprho, zentr, zpmid, zmftest, zmfmax
-  LOGICAL llo1, llo2
-
-  REAL zwmax(klon), zzzmb
-  INTEGER klwmin(klon) ! level of maximum vertical velocity
-  REAL fact
-  ! ----------------------------------------------------------------------
-  ztglace = rtt - 13.
-
-  ! Chercher le niveau ou la vitesse verticale est maximale:
-  DO i = 1, klon
-    klwmin(i) = klev
-    zwmax(i) = 0.0
-  END DO
-  DO k = klev, 3, -1
-    DO i = 1, klon
-      IF (pvervel(i,k)<zwmax(i)) THEN
-        zwmax(i) = pvervel(i, k)
-        klwmin(i) = k
-      END IF
-    END DO
-  END DO
-  ! ----------------------------------------------------------------------
-  ! SET DEFAULT VALUES
-  ! ----------------------------------------------------------------------
-  DO i = 1, klon
-    IF (.NOT. ldcum(i)) ktype(i) = 0
-  END DO
-
-  DO k = 1, klev
-    DO i = 1, klon
-      plu(i, k) = 0.
-      pmfu(i, k) = 0.
-      pmfus(i, k) = 0.
-      pmfuq(i, k) = 0.
-      pmful(i, k) = 0.
-      plude(i, k) = 0.
-      pdmfup(i, k) = 0.
-      IF (.NOT. ldcum(i) .OR. ktype(i)==3) klab(i, k) = 0
-      IF (.NOT. ldcum(i) .AND. paph(i,k)<4.E4) kctop0(i) = k
-    END DO
-  END DO
-
-  DO i = 1, klon
-    IF (ldland(i)) THEN
-      zdland(i) = 3.0E4
-      zdphi = pgeoh(i, kctop0(i)) - pgeoh(i, kcbot(i))
-      IF (ptu(i,kctop0(i))>=ztglace) zdland(i) = zdphi
-      zdland(i) = max(3.0E4, zdland(i))
-      zdland(i) = min(5.0E4, zdland(i))
-    END IF
-  END DO
-
-  ! Initialiser les valeurs au niveau d'ascendance
-
-  DO i = 1, klon
-    kctop(i) = klev - 1
-    IF (.NOT. ldcum(i)) THEN
-      kcbot(i) = klev - 1
-      pmfub(i) = 0.
-      pqu(i, klev) = 0.
-    END IF
-    pmfu(i, klev) = pmfub(i)
-    pmfus(i, klev) = pmfub(i)*(rcpd*ptu(i,klev)+pgeoh(i,klev))
-    pmfuq(i, klev) = pmfub(i)*pqu(i, klev)
-  END DO
-
-  DO i = 1, klon
-    ldcum(i) = .FALSE.
-  END DO
-  ! ----------------------------------------------------------------------
-  ! DO ASCENT: SUBCLOUD LAYER (klab=1) ,CLOUDS (klab=2)
-  ! BY DOING FIRST DRY-ADIABATIC ASCENT AND THEN
-  ! BY ADJUSTING T,Q AND L ACCORDINGLY IN *flxadjtq*,
-  ! THEN CHECK FOR BUOYANCY AND SET FLAGS ACCORDINGLY
-  ! ----------------------------------------------------------------------
-  DO k = klev - 1, 3, -1
-
-    IF (lmfmid .AND. k<klev-1) THEN
-      DO i = 1, klon
-        IF (.NOT. ldcum(i) .AND. klab(i,k+1)==0 .AND. &
-            pqen(i,k)>0.9*pqsen(i,k) .AND. pap(i,k)/paph(i,klev+1)>0.4) THEN
-          ptu(i, k+1) = pten(i, k) + (pgeo(i,k)-pgeoh(i,k+1))/rcpd
-          pqu(i, k+1) = pqen(i, k)
-          plu(i, k+1) = 0.0
-          zzzmb = max(cmfcmin, -pvervel(i,k)/rg)
-          zmfmax = (paph(i,k)-paph(i,k-1))/(rg*pdtime)
-          pmfub(i) = min(zzzmb, zmfmax)
-          pmfu(i, k+1) = pmfub(i)
-          pmfus(i, k+1) = pmfub(i)*(rcpd*ptu(i,k+1)+pgeoh(i,k+1))
-          pmfuq(i, k+1) = pmfub(i)*pqu(i, k+1)
-          pmful(i, k+1) = 0.0
-          pdmfup(i, k+1) = 0.0
-          kcbot(i) = k
-          klab(i, k+1) = 1
-          ktype(i) = 3
-          pentr(i) = entrmid
-        END IF
-      END DO
-    END IF
-
-    is = 0
-    DO i = 1, klon
-      is = is + klab(i, k+1)
-      IF (klab(i,k+1)==0) klab(i, k) = 0
-      llflag(i) = .FALSE.
-      IF (klab(i,k+1)>0) llflag(i) = .TRUE.
-    END DO
-    IF (is==0) GO TO 480
-
-    ! calculer le taux d'entrainement et de detrainement
-
-    DO i = 1, klon
-      pen_u(i, k) = 0.0
-      pde_u(i, k) = 0.0
-      zrho(i) = paph(i, k+1)/(rd*ptenh(i,k+1))
-      zpbot(i) = paph(i, kcbot(i))
-      zptop(i) = paph(i, kctop0(i))
-    END DO
-
-    DO i = 1, klon
-      IF (ldcum(i)) THEN
-        zdprho = (paph(i,k+1)-paph(i,k))/(rg*zrho(i))
-        zentr = pentr(i)*pmfu(i, k+1)*zdprho
-        llo1 = k < kcbot(i)
-        IF (llo1) pde_u(i, k) = zentr
-        zpmid = 0.5*(zpbot(i)+zptop(i))
-        llo2 = llo1 .AND. ktype(i) == 2 .AND. (zpbot(i)-paph(i,k)<0.2E5 .OR. &
-          paph(i,k)>zpmid)
-        IF (llo2) pen_u(i, k) = zentr
-        llo2 = llo1 .AND. (ktype(i)==1 .OR. ktype(i)==3) .AND. &
-          (k>=max(klwmin(i),kctop0(i)+2) .OR. pap(i,k)>zpmid)
-        IF (llo2) pen_u(i, k) = zentr
-        llo1 = pen_u(i, k) > 0. .AND. (ktype(i)==1 .OR. ktype(i)==2)
-        IF (llo1) THEN
-          fact = 1. + 3.*(1.-min(1.,(zpbot(i)-pap(i,k))/1.5E4))
-          zentr = zentr*fact
-          pen_u(i, k) = pen_u(i, k)*fact
-          pde_u(i, k) = pde_u(i, k)*fact
-        END IF
-        IF (llo2 .AND. pqenh(i,k+1)>1.E-5) pen_u(i, k) = zentr + &
-          max(pqte(i,k), 0.)/pqenh(i, k+1)*zrho(i)*zdprho
-      END IF
-    END DO
-
-    ! ----------------------------------------------------------------------
-    ! DO ADIABATIC ASCENT FOR ENTRAINING/DETRAINING PLUME
-    ! ----------------------------------------------------------------------
-
-    DO i = 1, klon
-      IF (llflag(i)) THEN
-        IF (k<kcbot(i)) THEN
-          zmftest = pmfu(i, k+1) + pen_u(i, k) - pde_u(i, k)
-          zmfmax = min(zmftest, (paph(i,k)-paph(i,k-1))/(rg*pdtime))
-          pen_u(i, k) = max(pen_u(i,k)-max(0.0,zmftest-zmfmax), 0.0)
-        END IF
-        pde_u(i, k) = min(pde_u(i,k), 0.75*pmfu(i,k+1))
-        ! calculer le flux de masse du niveau k a partir de celui du k+1
-        pmfu(i, k) = pmfu(i, k+1) + pen_u(i, k) - pde_u(i, k)
-        ! calculer les valeurs Su, Qu et l du niveau k dans le panache
-        ! montant
-        zqeen = pqenh(i, k+1)*pen_u(i, k)
-        zseen = (rcpd*ptenh(i,k+1)+pgeoh(i,k+1))*pen_u(i, k)
-        zscde = (rcpd*ptu(i,k+1)+pgeoh(i,k+1))*pde_u(i, k)
-        zqude = pqu(i, k+1)*pde_u(i, k)
-        plude(i, k) = plu(i, k+1)*pde_u(i, k)
-        zmfusk = pmfus(i, k+1) + zseen - zscde
-        zmfuqk = pmfuq(i, k+1) + zqeen - zqude
-        zmfulk = pmful(i, k+1) - plude(i, k)
-        plu(i, k) = zmfulk*(1./max(cmfcmin,pmfu(i,k)))
-        pqu(i, k) = zmfuqk*(1./max(cmfcmin,pmfu(i,k)))
-        ptu(i, k) = (zmfusk*(1./max(cmfcmin,pmfu(i,k)))-pgeoh(i,k))/rcpd
-        ptu(i, k) = max(100., ptu(i,k))
-        ptu(i, k) = min(400., ptu(i,k))
-        zqold(i) = pqu(i, k)
-      ELSE
-        zqold(i) = 0.0
-      END IF
-    END DO
-
-    ! ----------------------------------------------------------------------
-    ! DO CORRECTIONS FOR MOIST ASCENT BY ADJUSTING T,Q AND L
-    ! ----------------------------------------------------------------------
-
-    icall = 1
-    CALL flxadjtq(paph(1,k), ptu(1,k), pqu(1,k), llflag, icall)
-
-    DO i = 1, klon
-      IF (llflag(i) .AND. pqu(i,k)/=zqold(i)) THEN
-        klab(i, k) = 2
-        plu(i, k) = plu(i, k) + zqold(i) - pqu(i, k)
-        zbuo = ptu(i, k)*(1.+retv*pqu(i,k)) - ptenh(i, k)*(1.+retv*pqenh(i,k) &
-          )
-        IF (klab(i,k+1)==1) zbuo = zbuo + 0.5
-        IF (zbuo>0. .AND. pmfu(i,k)>=0.1*pmfub(i)) THEN
-          kctop(i) = k
-          ldcum(i) = .TRUE.
-          zdnoprc = 1.5E4
-          IF (ldland(i)) zdnoprc = zdland(i)
-          zprcon = cprcon
-          IF ((zpbot(i)-paph(i,k))<zdnoprc) zprcon = 0.0
-          zlnew = plu(i, k)/(1.+zprcon*(pgeoh(i,k)-pgeoh(i,k+1)))
-          pdmfup(i, k) = max(0., (plu(i,k)-zlnew)*pmfu(i,k))
-          plu(i, k) = zlnew
-        ELSE
-          klab(i, k) = 0
-          pmfu(i, k) = 0.
-        END IF
-      END IF
-    END DO
-    DO i = 1, klon
-      IF (llflag(i)) THEN
-        pmful(i, k) = plu(i, k)*pmfu(i, k)
-        pmfus(i, k) = (rcpd*ptu(i,k)+pgeoh(i,k))*pmfu(i, k)
-        pmfuq(i, k) = pqu(i, k)*pmfu(i, k)
-      END IF
-    END DO
-
-480 END DO
-  ! ----------------------------------------------------------------------
-  ! DETERMINE CONVECTIVE FLUXES ABOVE NON-BUOYANCY LEVEL
-  ! (NOTE: CLOUD VARIABLES LIKE T,Q AND L ARE NOT
-  ! AFFECTED BY DETRAINMENT AND ARE ALREADY KNOWN
-  ! FROM PREVIOUS CALCULATIONS ABOVE)
-  ! ----------------------------------------------------------------------
-  DO i = 1, klon
-    IF (kctop(i)==klev-1) ldcum(i) = .FALSE.
-    kcbot(i) = max(kcbot(i), kctop(i))
-  END DO
-
-  ldcum(1) = ldcum(1)
-
-  is = 0
-  DO i = 1, klon
-    IF (ldcum(i)) is = is + 1
-  END DO
-  kcum = is
-  IF (is==0) GO TO 800
-
-  DO i = 1, klon
-    IF (ldcum(i)) THEN
-      k = kctop(i) - 1
-      pde_u(i, k) = (1.-cmfctop)*pmfu(i, k+1)
-      plude(i, k) = pde_u(i, k)*plu(i, k+1)
-      pmfu(i, k) = pmfu(i, k+1) - pde_u(i, k)
-      zlnew = plu(i, k)
-      pdmfup(i, k) = max(0., (plu(i,k)-zlnew)*pmfu(i,k))
-      plu(i, k) = zlnew
-      pmfus(i, k) = (rcpd*ptu(i,k)+pgeoh(i,k))*pmfu(i, k)
-      pmfuq(i, k) = pqu(i, k)*pmfu(i, k)
-      pmful(i, k) = plu(i, k)*pmfu(i, k)
-      plude(i, k-1) = pmful(i, k)
-    END IF
-  END DO
-
-800 CONTINUE
-  RETURN
-END SUBROUTINE flxasc
-SUBROUTINE flxflux(pdtime, pqen, pqsen, ptenh, pqenh, pap, paph, ldland, &
-    pgeoh, kcbot, kctop, lddraf, kdtop, ktype, ldcum, pmfu, pmfd, pmfus, &
-    pmfds, pmfuq, pmfdq, pmful, plude, pdmfup, pdmfdp, pten, prfl, psfl, &
-    pdpmel, ktopm2, pmflxr, pmflxs)
-  USE dimphy
-  USE print_control_mod, ONLY: prt_level
-  IMPLICIT NONE
-  ! ----------------------------------------------------------------------
-  ! THIS ROUTINE DOES THE FINAL CALCULATION OF CONVECTIVE
-  ! FLUXES IN THE CLOUD LAYER AND IN THE SUBCLOUD LAYER
-  ! ----------------------------------------------------------------------
-  include "YOMCST.h"
-  include "YOETHF.h"
-  include "YOECUMF.h"
-
-  REAL cevapcu(klon, klev)
-  ! -----------------------------------------------------------------
-  REAL pqen(klon, klev), pqenh(klon, klev), pqsen(klon, klev)
-  REAL pten(klon, klev), ptenh(klon, klev)
-  REAL paph(klon, klev+1), pgeoh(klon, klev)
-
-  REAL pap(klon, klev)
-  REAL ztmsmlt, zdelta, zqsat
-
-  REAL pmfu(klon, klev), pmfus(klon, klev)
-  REAL pmfd(klon, klev), pmfds(klon, klev)
-  REAL pmfuq(klon, klev), pmful(klon, klev)
-  REAL pmfdq(klon, klev)
-  REAL plude(klon, klev)
-  REAL pdmfup(klon, klev), pdpmel(klon, klev)
-  ! jq The variable maxpdmfdp(klon) has been introduced by Olivier Boucher
-  ! jq 14/11/00 to fix the problem with the negative precipitation.
-  REAL pdmfdp(klon, klev), maxpdmfdp(klon, klev)
-  REAL prfl(klon), psfl(klon)
-  REAL pmflxr(klon, klev+1), pmflxs(klon, klev+1)
-  INTEGER kcbot(klon), kctop(klon), ktype(klon)
-  LOGICAL ldland(klon), ldcum(klon)
-  INTEGER k, kp, i
-  REAL zcons1, zcons2, zcucov, ztmelp2
-  REAL pdtime, zdp, zzp, zfac, zsnmlt, zrfl, zrnew
-  REAL zrmin, zrfln, zdrfl
-  REAL zpds, zpdr, zdenom
-  INTEGER ktopm2, itop, ikb
-
-  LOGICAL lddraf(klon)
-  INTEGER kdtop(klon)
-
-  include "FCTTRE.h"
-
-  DO k = 1, klev
-    DO i = 1, klon
-      cevapcu(i, k) = 1.93E-6*261.*sqrt(1.E3/(38.3*0.293)*sqrt(0.5*(paph(i,k) &
-        +paph(i,k+1))/paph(i,klev+1)))*0.5/rg
-    END DO
-  END DO
-
-  ! SPECIFY CONSTANTS
-
-  zcons1 = rcpd/(rlmlt*rg*pdtime)
-  zcons2 = 1./(rg*pdtime)
-  zcucov = 0.05
-  ztmelp2 = rtt + 2.
-
-  ! DETERMINE FINAL CONVECTIVE FLUXES
-
-  itop = klev
-  DO i = 1, klon
-    itop = min(itop, kctop(i))
-    IF (.NOT. ldcum(i) .OR. kdtop(i)<kctop(i)) lddraf(i) = .FALSE.
-    IF (.NOT. ldcum(i)) ktype(i) = 0
-  END DO
-
-  ktopm2 = itop - 2
-  DO k = ktopm2, klev
-    DO i = 1, klon
-      IF (ldcum(i) .AND. k>=kctop(i)-1) THEN
-        pmfus(i, k) = pmfus(i, k) - pmfu(i, k)*(rcpd*ptenh(i,k)+pgeoh(i,k))
-        pmfuq(i, k) = pmfuq(i, k) - pmfu(i, k)*pqenh(i, k)
-        zdp = 1.5E4
-        IF (ldland(i)) zdp = 3.E4
-
-        ! l'eau liquide detrainee est precipitee quand certaines
-        ! conditions sont reunies (sinon, elle est consideree
-        ! evaporee dans l'environnement)
-
-        IF (paph(i,kcbot(i))-paph(i,kctop(i))>=zdp .AND. pqen(i,k-1)>0.8* &
-          pqsen(i,k-1)) pdmfup(i, k-1) = pdmfup(i, k-1) + plude(i, k-1)
-
-        IF (lddraf(i) .AND. k>=kdtop(i)) THEN
-          pmfds(i, k) = pmfds(i, k) - pmfd(i, k)*(rcpd*ptenh(i,k)+pgeoh(i,k))
-          pmfdq(i, k) = pmfdq(i, k) - pmfd(i, k)*pqenh(i, k)
-        ELSE
-          pmfd(i, k) = 0.
-          pmfds(i, k) = 0.
-          pmfdq(i, k) = 0.
-          pdmfdp(i, k-1) = 0.
-        END IF
-      ELSE
-        pmfu(i, k) = 0.
-        pmfus(i, k) = 0.
-        pmfuq(i, k) = 0.
-        pmful(i, k) = 0.
-        pdmfup(i, k-1) = 0.
-        plude(i, k-1) = 0.
-        pmfd(i, k) = 0.
-        pmfds(i, k) = 0.
-        pmfdq(i, k) = 0.
-        pdmfdp(i, k-1) = 0.
-      END IF
-    END DO
-  END DO
-
-  DO k = ktopm2, klev
-    DO i = 1, klon
-      IF (ldcum(i) .AND. k>kcbot(i)) THEN
-        ikb = kcbot(i)
-        zzp = ((paph(i,klev+1)-paph(i,k))/(paph(i,klev+1)-paph(i,ikb)))
-        IF (ktype(i)==3) zzp = zzp**2
-        pmfu(i, k) = pmfu(i, ikb)*zzp
-        pmfus(i, k) = pmfus(i, ikb)*zzp
-        pmfuq(i, k) = pmfuq(i, ikb)*zzp
-        pmful(i, k) = pmful(i, ikb)*zzp
-      END IF
-    END DO
-  END DO
-
-  ! CALCULATE RAIN/SNOW FALL RATES
-  ! CALCULATE MELTING OF SNOW
-  ! CALCULATE EVAPORATION OF PRECIP
-
-  DO k = 1, klev + 1
-    DO i = 1, klon
-      pmflxr(i, k) = 0.0
-      pmflxs(i, k) = 0.0
-    END DO
-  END DO
-  DO k = ktopm2, klev
-    DO i = 1, klon
-      IF (ldcum(i)) THEN
-        IF (pmflxs(i,k)>0.0 .AND. pten(i,k)>ztmelp2) THEN
-          zfac = zcons1*(paph(i,k+1)-paph(i,k))
-          zsnmlt = min(pmflxs(i,k), zfac*(pten(i,k)-ztmelp2))
-          pdpmel(i, k) = zsnmlt
-          ztmsmlt = pten(i, k) - zsnmlt/zfac
-          zdelta = max(0., sign(1.,rtt-ztmsmlt))
-          zqsat = r2es*foeew(ztmsmlt, zdelta)/pap(i, k)
-          zqsat = min(0.5, zqsat)
-          zqsat = zqsat/(1.-retv*zqsat)
-          pqsen(i, k) = zqsat
-        END IF
-        IF (pten(i,k)>rtt) THEN
-          pmflxr(i, k+1) = pmflxr(i, k) + pdmfup(i, k) + pdmfdp(i, k) + &
-            pdpmel(i, k)
-          pmflxs(i, k+1) = pmflxs(i, k) - pdpmel(i, k)
-        ELSE
-          pmflxs(i, k+1) = pmflxs(i, k) + pdmfup(i, k) + pdmfdp(i, k)
-          pmflxr(i, k+1) = pmflxr(i, k)
-        END IF
-        ! si la precipitation est negative, on ajuste le plux du
-        ! panache descendant pour eliminer la negativite
-        IF ((pmflxr(i,k+1)+pmflxs(i,k+1))<0.0) THEN
-          pdmfdp(i, k) = -pmflxr(i, k) - pmflxs(i, k) - pdmfup(i, k)
-          pmflxr(i, k+1) = 0.0
-          pmflxs(i, k+1) = 0.0
-          pdpmel(i, k) = 0.0
-        END IF
-      END IF
-    END DO
-  END DO
-
-  ! jq The new variable is initialized here.
-  ! jq It contains the humidity which is fed to the downdraft
-  ! jq by evaporation of precipitation in the column below the base
-  ! jq of convection.
-  ! jq
-  ! jq In the former version, this term has been subtracted from precip
-  ! jq as well as the evaporation.
-  ! jq
-  DO k = 1, klev
-    DO i = 1, klon
-      maxpdmfdp(i, k) = 0.0
-    END DO
-  END DO
-  DO k = 1, klev
-    DO kp = k, klev
-      DO i = 1, klon
-        maxpdmfdp(i, k) = maxpdmfdp(i, k) + pdmfdp(i, kp)
-      END DO
-    END DO
-  END DO
-  ! jq End of initialization
-
-  DO k = ktopm2, klev
-    DO i = 1, klon
-      IF (ldcum(i) .AND. k>=kcbot(i)) THEN
-        zrfl = pmflxr(i, k) + pmflxs(i, k)
-        IF (zrfl>1.0E-20) THEN
-          zrnew = (max(0.,sqrt(zrfl/zcucov)-cevapcu(i, &
-            k)*(paph(i,k+1)-paph(i,k))*max(0.,pqsen(i,k)-pqen(i,k))))**2* &
-            zcucov
-          zrmin = zrfl - zcucov*max(0., 0.8*pqsen(i,k)-pqen(i,k))*zcons2*( &
-            paph(i,k+1)-paph(i,k))
-          zrnew = max(zrnew, zrmin)
-          zrfln = max(zrnew, 0.)
-          zdrfl = min(0., zrfln-zrfl)
-          ! jq At least the amount of precipiation needed to feed the
-          ! downdraft
-          ! jq with humidity below the base of convection has to be left and
-          ! can't
-          ! jq be evaporated (surely the evaporation can't be positive):
-          zdrfl = max(zdrfl, min(-pmflxr(i,k)-pmflxs(i,k)-maxpdmfdp(i, &
-            k),0.0))
-          ! jq End of insertion
-
-          zdenom = 1.0/max(1.0E-20, pmflxr(i,k)+pmflxs(i,k))
-          IF (pten(i,k)>rtt) THEN
-            zpdr = pdmfdp(i, k)
-            zpds = 0.0
-          ELSE
-            zpdr = 0.0
-            zpds = pdmfdp(i, k)
-          END IF
-          pmflxr(i, k+1) = pmflxr(i, k) + zpdr + pdpmel(i, k) + &
-            zdrfl*pmflxr(i, k)*zdenom
-          pmflxs(i, k+1) = pmflxs(i, k) + zpds - pdpmel(i, k) + &
-            zdrfl*pmflxs(i, k)*zdenom
-          pdmfup(i, k) = pdmfup(i, k) + zdrfl
-        ELSE
-          pmflxr(i, k+1) = 0.0
-          pmflxs(i, k+1) = 0.0
-          pdmfdp(i, k) = 0.0
-          pdpmel(i, k) = 0.0
-        END IF
-        IF (pmflxr(i,k)+pmflxs(i,k)<-1.E-26 .AND. prt_level>=1) WRITE (*, *) &
-          'precip. < 1e-16 ', pmflxr(i, k) + pmflxs(i, k)
-      END IF
-    END DO
-  END DO
-
-  DO i = 1, klon
-    prfl(i) = pmflxr(i, klev+1)
-    psfl(i) = pmflxs(i, klev+1)
-  END DO
-
-  RETURN
-END SUBROUTINE flxflux
-SUBROUTINE flxdtdq(pdtime, ktopm2, paph, ldcum, pten, pmfus, pmfds, pmfuq, &
-    pmfdq, pmful, pdmfup, pdmfdp, pdpmel, dt_con, dq_con)
-  USE dimphy
-  IMPLICIT NONE
-  ! ----------------------------------------------------------------------
-  ! calculer les tendances T et Q
-  ! ----------------------------------------------------------------------
-  include "YOMCST.h"
-  include "YOETHF.h"
-  include "YOECUMF.h"
-  ! -----------------------------------------------------------------
-  LOGICAL llo1
-
-  REAL pten(klon, klev), paph(klon, klev+1)
-  REAL pmfus(klon, klev), pmfuq(klon, klev), pmful(klon, klev)
-  REAL pmfds(klon, klev), pmfdq(klon, klev)
-  REAL pdmfup(klon, klev)
-  REAL pdmfdp(klon, klev)
-  REAL pdpmel(klon, klev)
-  LOGICAL ldcum(klon)
-  REAL dt_con(klon, klev), dq_con(klon, klev)
-
-  INTEGER ktopm2
-  REAL pdtime
-
-  INTEGER i, k
-  REAL zalv, zdtdt, zdqdt
-
-  DO k = ktopm2, klev - 1
-    DO i = 1, klon
-      IF (ldcum(i)) THEN
-        llo1 = (pten(i,k)-rtt) > 0.
-        zalv = rlstt
-        IF (llo1) zalv = rlvtt
-        zdtdt = rg/(paph(i,k+1)-paph(i,k))/rcpd*(pmfus(i,k+1)-pmfus(i,k)+ &
-          pmfds(i,k+1)-pmfds(i,k)-rlmlt*pdpmel(i,k)-zalv*(pmful(i, &
-          k+1)-pmful(i,k)-pdmfup(i,k)-pdmfdp(i,k)))
-        dt_con(i, k) = zdtdt
-        zdqdt = rg/(paph(i,k+1)-paph(i,k))*(pmfuq(i,k+1)-pmfuq(i,k)+pmfdq(i,k &
-          +1)-pmfdq(i,k)+pmful(i,k+1)-pmful(i,k)-pdmfup(i,k)-pdmfdp(i,k))
-        dq_con(i, k) = zdqdt
-      END IF
-    END DO
-  END DO
-
-  k = klev
-  DO i = 1, klon
-    IF (ldcum(i)) THEN
-      llo1 = (pten(i,k)-rtt) > 0.
-      zalv = rlstt
-      IF (llo1) zalv = rlvtt
-      zdtdt = -rg/(paph(i,k+1)-paph(i,k))/rcpd*(pmfus(i,k)+pmfds(i,k)+rlmlt* &
-        pdpmel(i,k)-zalv*(pmful(i,k)+pdmfup(i,k)+pdmfdp(i,k)))
-      dt_con(i, k) = zdtdt
-      zdqdt = -rg/(paph(i,k+1)-paph(i,k))*(pmfuq(i,k)+pmfdq(i,k)+pmful(i,k)+ &
-        pdmfup(i,k)+pdmfdp(i,k))
-      dq_con(i, k) = zdqdt
-    END IF
-  END DO
-
-  RETURN
-END SUBROUTINE flxdtdq
-SUBROUTINE flxdlfs(ptenh, pqenh, pgeoh, paph, ptu, pqu, ldcum, kcbot, kctop, &
-    pmfub, prfl, ptd, pqd, pmfd, pmfds, pmfdq, pdmfdp, kdtop, lddraf)
-  USE dimphy
-  IMPLICIT NONE
-
-  ! ----------------------------------------------------------------------
-  ! THIS ROUTINE CALCULATES LEVEL OF FREE SINKING FOR
-  ! CUMULUS DOWNDRAFTS AND SPECIFIES T,Q,U AND V VALUES
-
-  ! TO PRODUCE LFS-VALUES FOR CUMULUS DOWNDRAFTS
-  ! FOR MASSFLUX CUMULUS PARAMETERIZATION
-
-  ! INPUT ARE ENVIRONMENTAL VALUES OF T,Q,U,V,P,PHI
-  ! AND UPDRAFT VALUES T,Q,U AND V AND ALSO
-  ! CLOUD BASE MASSFLUX AND CU-PRECIPITATION RATE.
-  ! IT RETURNS T,Q,U AND V VALUES AND MASSFLUX AT LFS.
-
-  ! CHECK FOR NEGATIVE BUOYANCY OF AIR OF EQUAL PARTS OF
-  ! MOIST ENVIRONMENTAL AIR AND CLOUD AIR.
-  ! ----------------------------------------------------------------------
-  include "YOMCST.h"
-  include "YOETHF.h"
-  include "YOECUMF.h"
-
-  REAL ptenh(klon, klev)
-  REAL pqenh(klon, klev)
-  REAL pgeoh(klon, klev), paph(klon, klev+1)
-  REAL ptu(klon, klev), pqu(klon, klev)
-  REAL pmfub(klon)
-  REAL prfl(klon)
-
-  REAL ptd(klon, klev), pqd(klon, klev)
-  REAL pmfd(klon, klev), pmfds(klon, klev), pmfdq(klon, klev)
-  REAL pdmfdp(klon, klev)
-  INTEGER kcbot(klon), kctop(klon), kdtop(klon)
-  LOGICAL ldcum(klon), lddraf(klon)
-
-  REAL ztenwb(klon, klev), zqenwb(klon, klev), zcond(klon)
-  REAL zttest, zqtest, zbuo, zmftop
-  LOGICAL llo2(klon)
-  INTEGER i, k, is, icall
-  ! ----------------------------------------------------------------------
-  DO i = 1, klon
-    lddraf(i) = .FALSE.
-    kdtop(i) = klev + 1
-  END DO
-
-  ! ----------------------------------------------------------------------
-  ! DETERMINE LEVEL OF FREE SINKING BY
-  ! DOING A SCAN FROM TOP TO BASE OF CUMULUS CLOUDS
-
-  ! FOR EVERY POINT AND PROCEED AS FOLLOWS:
-  ! (1) DETEMINE WET BULB ENVIRONMENTAL T AND Q
-  ! (2) DO MIXING WITH CUMULUS CLOUD AIR
-  ! (3) CHECK FOR NEGATIVE BUOYANCY
-
-  ! THE ASSUMPTION IS THAT AIR OF DOWNDRAFTS IS MIXTURE
-  ! OF 50% CLOUD AIR + 50% ENVIRONMENTAL AIR AT WET BULB
-  ! TEMPERATURE (I.E. WHICH BECAME SATURATED DUE TO
-  ! EVAPORATION OF RAIN AND CLOUD WATER)
-  ! ----------------------------------------------------------------------
-
-  DO k = 3, klev - 3
-
-    is = 0
-    DO i = 1, klon
-      ztenwb(i, k) = ptenh(i, k)
-      zqenwb(i, k) = pqenh(i, k)
-      llo2(i) = ldcum(i) .AND. prfl(i) > 0. .AND. .NOT. lddraf(i) .AND. &
-        (k<kcbot(i) .AND. k>kctop(i))
-      IF (llo2(i)) is = is + 1
-    END DO
-    IF (is==0) GO TO 290
-
-    icall = 2
-    CALL flxadjtq(paph(1,k), ztenwb(1,k), zqenwb(1,k), llo2, icall)
-
-    ! ----------------------------------------------------------------------
-    ! DO MIXING OF CUMULUS AND ENVIRONMENTAL AIR
-    ! AND CHECK FOR NEGATIVE BUOYANCY.
-    ! THEN SET VALUES FOR DOWNDRAFT AT LFS.
-    ! ----------------------------------------------------------------------
-    DO i = 1, klon
-      IF (llo2(i)) THEN
-        zttest = 0.5*(ptu(i,k)+ztenwb(i,k))
-        zqtest = 0.5*(pqu(i,k)+zqenwb(i,k))
-        zbuo = zttest*(1.+retv*zqtest) - ptenh(i, k)*(1.+retv*pqenh(i,k))
-        zcond(i) = pqenh(i, k) - zqenwb(i, k)
-        zmftop = -cmfdeps*pmfub(i)
-        IF (zbuo<0. .AND. prfl(i)>10.*zmftop*zcond(i)) THEN
-          kdtop(i) = k
-          lddraf(i) = .TRUE.
-          ptd(i, k) = zttest
-          pqd(i, k) = zqtest
-          pmfd(i, k) = zmftop
-          pmfds(i, k) = pmfd(i, k)*(rcpd*ptd(i,k)+pgeoh(i,k))
-          pmfdq(i, k) = pmfd(i, k)*pqd(i, k)
-          pdmfdp(i, k-1) = -0.5*pmfd(i, k)*zcond(i)
-          prfl(i) = prfl(i) + pdmfdp(i, k-1)
-        END IF
-      END IF
-    END DO
-
-290 END DO
-
-  RETURN
-END SUBROUTINE flxdlfs
-SUBROUTINE flxddraf(ptenh, pqenh, pgeoh, paph, prfl, ptd, pqd, pmfd, pmfds, &
-    pmfdq, pdmfdp, lddraf, pen_d, pde_d)
-  USE dimphy
-  IMPLICIT NONE
-
-  ! ----------------------------------------------------------------------
-  ! THIS ROUTINE CALCULATES CUMULUS DOWNDRAFT DESCENT
-
-  ! TO PRODUCE THE VERTICAL PROFILES FOR CUMULUS DOWNDRAFTS
-  ! (I.E. T,Q,U AND V AND FLUXES)
-
-  ! INPUT IS T,Q,P,PHI,U,V AT HALF LEVELS.
-  ! IT RETURNS FLUXES OF S,Q AND EVAPORATION RATE
-  ! AND U,V AT LEVELS WHERE DOWNDRAFT OCCURS
-
-  ! CALCULATE MOIST DESCENT FOR ENTRAINING/DETRAINING PLUME BY
-  ! A) MOVING AIR DRY-ADIABATICALLY TO NEXT LEVEL BELOW AND
-  ! B) CORRECTING FOR EVAPORATION TO OBTAIN SATURATED STATE.
-
-  ! ----------------------------------------------------------------------
-  include "YOMCST.h"
-  include "YOETHF.h"
-  include "YOECUMF.h"
-
-  REAL ptenh(klon, klev), pqenh(klon, klev)
-  REAL pgeoh(klon, klev), paph(klon, klev+1)
-
-  REAL ptd(klon, klev), pqd(klon, klev)
-  REAL pmfd(klon, klev), pmfds(klon, klev), pmfdq(klon, klev)
-  REAL pdmfdp(klon, klev)
-  REAL prfl(klon)
-  LOGICAL lddraf(klon)
-
-  REAL pen_d(klon, klev), pde_d(klon, klev), zcond(klon)
-  LOGICAL llo2(klon), llo1
-  INTEGER i, k, is, icall, itopde
-  REAL zentr, zseen, zqeen, zsdde, zqdde, zmfdsk, zmfdqk, zdmfdp
-  REAL zbuo
-  ! ----------------------------------------------------------------------
-  ! CALCULATE MOIST DESCENT FOR CUMULUS DOWNDRAFT BY
-  ! (A) CALCULATING ENTRAINMENT RATES, ASSUMING
-  ! LINEAR DECREASE OF MASSFLUX IN PBL
-  ! (B) DOING MOIST DESCENT - EVAPORATIVE COOLING
-  ! AND MOISTENING IS CALCULATED IN *flxadjtq*
-  ! (C) CHECKING FOR NEGATIVE BUOYANCY AND
-  ! SPECIFYING FINAL T,Q,U,V AND DOWNWARD FLUXES
-
-  DO k = 3, klev
-
-    is = 0
-    DO i = 1, klon
-      llo2(i) = lddraf(i) .AND. pmfd(i, k-1) < 0.
-      IF (llo2(i)) is = is + 1
-    END DO
-    IF (is==0) GO TO 180
-
-    DO i = 1, klon
-      IF (llo2(i)) THEN
-        zentr = entrdd*pmfd(i, k-1)*rd*ptenh(i, k-1)/(rg*paph(i,k-1))* &
-          (paph(i,k)-paph(i,k-1))
-        pen_d(i, k) = zentr
-        pde_d(i, k) = zentr
-      END IF
-    END DO
-
-    itopde = klev - 2
-    IF (k>itopde) THEN
-      DO i = 1, klon
-        IF (llo2(i)) THEN
-          pen_d(i, k) = 0.
-          pde_d(i, k) = pmfd(i, itopde)*(paph(i,k)-paph(i,k-1))/ &
-            (paph(i,klev+1)-paph(i,itopde))
-        END IF
-      END DO
-    END IF
-
-    DO i = 1, klon
-      IF (llo2(i)) THEN
-        pmfd(i, k) = pmfd(i, k-1) + pen_d(i, k) - pde_d(i, k)
-        zseen = (rcpd*ptenh(i,k-1)+pgeoh(i,k-1))*pen_d(i, k)
-        zqeen = pqenh(i, k-1)*pen_d(i, k)
-        zsdde = (rcpd*ptd(i,k-1)+pgeoh(i,k-1))*pde_d(i, k)
-        zqdde = pqd(i, k-1)*pde_d(i, k)
-        zmfdsk = pmfds(i, k-1) + zseen - zsdde
-        zmfdqk = pmfdq(i, k-1) + zqeen - zqdde
-        pqd(i, k) = zmfdqk*(1./min(-cmfcmin,pmfd(i,k)))
-        ptd(i, k) = (zmfdsk*(1./min(-cmfcmin,pmfd(i,k)))-pgeoh(i,k))/rcpd
-        ptd(i, k) = min(400., ptd(i,k))
-        ptd(i, k) = max(100., ptd(i,k))
-        zcond(i) = pqd(i, k)
-      END IF
-    END DO
-
-    icall = 2
-    CALL flxadjtq(paph(1,k), ptd(1,k), pqd(1,k), llo2, icall)
-
-    DO i = 1, klon
-      IF (llo2(i)) THEN
-        zcond(i) = zcond(i) - pqd(i, k)
-        zbuo = ptd(i, k)*(1.+retv*pqd(i,k)) - ptenh(i, k)*(1.+retv*pqenh(i,k) &
-          )
-        llo1 = zbuo < 0. .AND. (prfl(i)-pmfd(i,k)*zcond(i)>0.)
-        IF (.NOT. llo1) pmfd(i, k) = 0.0
-        pmfds(i, k) = (rcpd*ptd(i,k)+pgeoh(i,k))*pmfd(i, k)
-        pmfdq(i, k) = pqd(i, k)*pmfd(i, k)
-        zdmfdp = -pmfd(i, k)*zcond(i)
-        pdmfdp(i, k-1) = zdmfdp
-        prfl(i) = prfl(i) + zdmfdp
-      END IF
-    END DO
-
-180 END DO
-  RETURN
-END SUBROUTINE flxddraf
-SUBROUTINE flxadjtq(pp, pt, pq, ldflag, kcall)
-  USE dimphy
-  IMPLICIT NONE
-  ! ======================================================================
-  ! Objet: ajustement entre T et Q
-  ! ======================================================================
-  ! NOTE: INPUT PARAMETER kcall DEFINES CALCULATION AS
-  ! kcall=0    ENV. T AND QS IN*CUINI*
-  ! kcall=1  CONDENSATION IN UPDRAFTS  (E.G. CUBASE, CUASC)
-  ! kcall=2  EVAPORATION IN DOWNDRAFTS (E.G. CUDLFS,CUDDRAF)
-
-  include "YOMCST.h"
-
-  REAL pt(klon), pq(klon), pp(klon)
-  LOGICAL ldflag(klon)
-  INTEGER kcall
-
-  REAL zcond(klon), zcond1
-  REAL z5alvcp, z5alscp, zalvdcp, zalsdcp
-  REAL zdelta, zcvm5, zldcp, zqsat, zcor
-  INTEGER is, i
-  include "YOETHF.h"
-  include "FCTTRE.h"
-
-  z5alvcp = r5les*rlvtt/rcpd
-  z5alscp = r5ies*rlstt/rcpd
-  zalvdcp = rlvtt/rcpd
-  zalsdcp = rlstt/rcpd
-
-
-  DO i = 1, klon
-    zcond(i) = 0.0
-  END DO
-
-  DO i = 1, klon
-    IF (ldflag(i)) THEN
-      zdelta = max(0., sign(1.,rtt-pt(i)))
-      zcvm5 = z5alvcp*(1.-zdelta) + zdelta*z5alscp
-      zldcp = zalvdcp*(1.-zdelta) + zdelta*zalsdcp
-      zqsat = r2es*foeew(pt(i), zdelta)/pp(i)
-      zqsat = min(0.5, zqsat)
-      zcor = 1./(1.-retv*zqsat)
-      zqsat = zqsat*zcor
-      zcond(i) = (pq(i)-zqsat)/(1.+foede(pt(i),zdelta,zcvm5,zqsat,zcor))
-      IF (kcall==1) zcond(i) = max(zcond(i), 0.)
-      IF (kcall==2) zcond(i) = min(zcond(i), 0.)
-      pt(i) = pt(i) + zldcp*zcond(i)
-      pq(i) = pq(i) - zcond(i)
-    END IF
-  END DO
-
-  is = 0
-  DO i = 1, klon
-    IF (zcond(i)/=0.) is = is + 1
-  END DO
-  IF (is==0) GO TO 230
-
-  DO i = 1, klon
-    IF (ldflag(i) .AND. zcond(i)/=0.) THEN
-      zdelta = max(0., sign(1.,rtt-pt(i)))
-      zcvm5 = z5alvcp*(1.-zdelta) + zdelta*z5alscp
-      zldcp = zalvdcp*(1.-zdelta) + zdelta*zalsdcp
-      zqsat = r2es*foeew(pt(i), zdelta)/pp(i)
-      zqsat = min(0.5, zqsat)
-      zcor = 1./(1.-retv*zqsat)
-      zqsat = zqsat*zcor
-      zcond1 = (pq(i)-zqsat)/(1.+foede(pt(i),zdelta,zcvm5,zqsat,zcor))
-      pt(i) = pt(i) + zldcp*zcond1
-      pq(i) = pq(i) - zcond1
-    END IF
-  END DO
-
-230 CONTINUE
-  RETURN
-END SUBROUTINE flxadjtq
-SUBROUTINE flxsetup
-  IMPLICIT NONE
-
-  ! THIS ROUTINE DEFINES DISPOSABLE PARAMETERS FOR MASSFLUX SCHEME
-
-  include "YOECUMF.h"
-
-  entrpen = 1.0E-4 ! ENTRAINMENT RATE FOR PENETRATIVE CONVECTION
-  entrscv = 3.0E-4 ! ENTRAINMENT RATE FOR SHALLOW CONVECTION
-  entrmid = 1.0E-4 ! ENTRAINMENT RATE FOR MIDLEVEL CONVECTION
-  entrdd = 2.0E-4 ! ENTRAINMENT RATE FOR DOWNDRAFTS
-  cmfctop = 0.33 ! RELATIVE CLOUD MASSFLUX AT LEVEL ABOVE NONBUO LEVEL
-  cmfcmax = 1.0 ! MAXIMUM MASSFLUX VALUE ALLOWED FOR UPDRAFTS ETC
-  cmfcmin = 1.E-10 ! MINIMUM MASSFLUX VALUE (FOR SAFETY)
-  cmfdeps = 0.3 ! FRACTIONAL MASSFLUX FOR DOWNDRAFTS AT LFS
-  cprcon = 2.0E-4 ! CONVERSION FROM CLOUD WATER TO RAIN
-  rhcdd = 1. ! RELATIVE SATURATION IN DOWNDRAFRS (NO LONGER USED)
-  ! (FORMULATION IMPLIES SATURATION)
-  lmfpen = .TRUE.
-  lmfscv = .TRUE.
-  lmfmid = .TRUE.
-  lmfdd = .TRUE.
-  lmfdudv = .TRUE.
-
-  RETURN
-END SUBROUTINE flxsetup
Index: /LMDZ6/trunk/libf/phylmd/conflx.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/conflx.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/conflx.f90	(revision 5268)
@@ -0,0 +1,1608 @@
+
+! $Header$
+
+SUBROUTINE conflx(dtime, pres_h, pres_f, t, q, con_t, con_q, pqhfl, w, d_t, &
+    d_q, rain, snow, pmfu, pmfd, pen_u, pde_u, pen_d, pde_d, kcbot, kctop, &
+    kdtop, pmflxr, pmflxs)
+
+  USE dimphy
+  IMPLICIT NONE
+  ! ======================================================================
+  ! Auteur(s): Z.X. Li (LMD/CNRS) date: 19941014
+  ! Objet: Schema flux de masse pour la convection
+  ! (schema de Tiedtke avec qqs modifications mineures)
+  ! Dec.97: Prise en compte des modifications introduites par
+  ! Olivier Boucher et Alexandre Armengaud pour melange
+  ! et lessivage des traceurs passifs.
+  ! ======================================================================
+  include "YOMCST.h"
+  include "YOETHF.h"
+  ! Entree:
+  REAL dtime ! pas d'integration (s)
+  REAL pres_h(klon, klev+1) ! pression half-level (Pa)
+  REAL pres_f(klon, klev) ! pression full-level (Pa)
+  REAL t(klon, klev) ! temperature (K)
+  REAL q(klon, klev) ! humidite specifique (g/g)
+  REAL w(klon, klev) ! vitesse verticale (Pa/s)
+  REAL con_t(klon, klev) ! convergence de temperature (K/s)
+  REAL con_q(klon, klev) ! convergence de l'eau vapeur (g/g/s)
+  REAL pqhfl(klon) ! evaporation (negative vers haut) mm/s
+  ! Sortie:
+  REAL d_t(klon, klev) ! incrementation de temperature
+  REAL d_q(klon, klev) ! incrementation d'humidite
+  REAL pmfu(klon, klev) ! flux masse (kg/m2/s) panache ascendant
+  REAL pmfd(klon, klev) ! flux masse (kg/m2/s) panache descendant
+  REAL pen_u(klon, klev)
+  REAL pen_d(klon, klev)
+  REAL pde_u(klon, klev)
+  REAL pde_d(klon, klev)
+  REAL rain(klon) ! pluie (mm/s)
+  REAL snow(klon) ! neige (mm/s)
+  REAL pmflxr(klon, klev+1)
+  REAL pmflxs(klon, klev+1)
+  INTEGER kcbot(klon) ! niveau du bas de la convection
+  INTEGER kctop(klon) ! niveau du haut de la convection
+  INTEGER kdtop(klon) ! niveau du haut des downdrafts
+  ! Local:
+  REAL pt(klon, klev)
+  REAL pq(klon, klev)
+  REAL pqs(klon, klev)
+  REAL pvervel(klon, klev)
+  LOGICAL land(klon)
+
+  REAL d_t_bis(klon, klev)
+  REAL d_q_bis(klon, klev)
+  REAL paprs(klon, klev+1)
+  REAL paprsf(klon, klev)
+  REAL zgeom(klon, klev)
+  REAL zcvgq(klon, klev)
+  REAL zcvgt(klon, klev)
+  ! AA
+  REAL zmfu(klon, klev)
+  REAL zmfd(klon, klev)
+  REAL zen_u(klon, klev)
+  REAL zen_d(klon, klev)
+  REAL zde_u(klon, klev)
+  REAL zde_d(klon, klev)
+  REAL zmflxr(klon, klev+1)
+  REAL zmflxs(klon, klev+1)
+  ! AA
+
+
+  INTEGER i, k
+  REAL zdelta, zqsat
+
+  include "FCTTRE.h"
+
+  ! initialiser les variables de sortie (pour securite)
+  DO i = 1, klon
+    rain(i) = 0.0
+    snow(i) = 0.0
+    kcbot(i) = 0
+    kctop(i) = 0
+    kdtop(i) = 0
+  END DO
+  DO k = 1, klev
+    DO i = 1, klon
+      d_t(i, k) = 0.0
+      d_q(i, k) = 0.0
+      pmfu(i, k) = 0.0
+      pmfd(i, k) = 0.0
+      pen_u(i, k) = 0.0
+      pde_u(i, k) = 0.0
+      pen_d(i, k) = 0.0
+      pde_d(i, k) = 0.0
+      zmfu(i, k) = 0.0
+      zmfd(i, k) = 0.0
+      zen_u(i, k) = 0.0
+      zde_u(i, k) = 0.0
+      zen_d(i, k) = 0.0
+      zde_d(i, k) = 0.0
+    END DO
+  END DO
+  DO k = 1, klev + 1
+    DO i = 1, klon
+      zmflxr(i, k) = 0.0
+      zmflxs(i, k) = 0.0
+    END DO
+  END DO
+
+  ! calculer la nature du sol (pour l'instant, ocean partout)
+  DO i = 1, klon
+    land(i) = .FALSE.
+  END DO
+
+  ! preparer les variables d'entree (attention: l'ordre des niveaux
+  ! verticaux augmente du haut vers le bas)
+  DO k = 1, klev
+    DO i = 1, klon
+      pt(i, k) = t(i, klev-k+1)
+      pq(i, k) = q(i, klev-k+1)
+      paprsf(i, k) = pres_f(i, klev-k+1)
+      paprs(i, k) = pres_h(i, klev+1-k+1)
+      pvervel(i, k) = w(i, klev+1-k)
+      zcvgt(i, k) = con_t(i, klev-k+1)
+      zcvgq(i, k) = con_q(i, klev-k+1)
+
+      zdelta = max(0., sign(1.,rtt-pt(i,k)))
+      zqsat = r2es*foeew(pt(i,k), zdelta)/paprsf(i, k)
+      zqsat = min(0.5, zqsat)
+      zqsat = zqsat/(1.-retv*zqsat)
+      pqs(i, k) = zqsat
+    END DO
+  END DO
+  DO i = 1, klon
+    paprs(i, klev+1) = pres_h(i, 1)
+    zgeom(i, klev) = rd*pt(i, klev)/(0.5*(paprs(i,klev+1)+paprsf(i, &
+      klev)))*(paprs(i,klev+1)-paprsf(i,klev))
+  END DO
+  DO k = klev - 1, 1, -1
+    DO i = 1, klon
+      zgeom(i, k) = zgeom(i, k+1) + rd*0.5*(pt(i,k+1)+pt(i,k))/paprs(i, k+1)* &
+        (paprsf(i,k+1)-paprsf(i,k))
+    END DO
+  END DO
+
+  ! appeler la routine principale
+
+  CALL flxmain(dtime, pt, pq, pqs, pqhfl, paprsf, paprs, zgeom, land, zcvgt, &
+    zcvgq, pvervel, rain, snow, kcbot, kctop, kdtop, zmfu, zmfd, zen_u, &
+    zde_u, zen_d, zde_d, d_t_bis, d_q_bis, zmflxr, zmflxs)
+
+  ! AA--------------------------------------------------------
+  ! AA rem : De la meme facon que l'on effectue le reindicage
+  ! AA       pour la temperature t et le champ q
+  ! AA       on reindice les flux necessaires a la convection
+  ! AA       des traceurs
+  ! AA--------------------------------------------------------
+  DO k = 1, klev
+    DO i = 1, klon
+      d_q(i, klev+1-k) = dtime*d_q_bis(i, k)
+      d_t(i, klev+1-k) = dtime*d_t_bis(i, k)
+    END DO
+  END DO
+
+  DO i = 1, klon
+    pmfu(i, 1) = 0.
+    pmfd(i, 1) = 0.
+    pen_d(i, 1) = 0.
+    pde_d(i, 1) = 0.
+  END DO
+
+  DO k = 2, klev
+    DO i = 1, klon
+      pmfu(i, klev+2-k) = zmfu(i, k)
+      pmfd(i, klev+2-k) = zmfd(i, k)
+    END DO
+  END DO
+
+  DO k = 1, klev
+    DO i = 1, klon
+      pen_u(i, klev+1-k) = zen_u(i, k)
+      pde_u(i, klev+1-k) = zde_u(i, k)
+    END DO
+  END DO
+
+  DO k = 1, klev - 1
+    DO i = 1, klon
+      pen_d(i, klev+1-k) = -zen_d(i, k+1)
+      pde_d(i, klev+1-k) = -zde_d(i, k+1)
+    END DO
+  END DO
+
+  DO k = 1, klev + 1
+    DO i = 1, klon
+      pmflxr(i, klev+2-k) = zmflxr(i, k)
+      pmflxs(i, klev+2-k) = zmflxs(i, k)
+    END DO
+  END DO
+
+  RETURN
+END SUBROUTINE conflx
+! --------------------------------------------------------------------
+SUBROUTINE flxmain(pdtime, pten, pqen, pqsen, pqhfl, pap, paph, pgeo, ldland, &
+    ptte, pqte, pvervel, prsfc, pssfc, kcbot, kctop, kdtop, & ! *
+                                                              ! ldcum, ktype,
+    pmfu, pmfd, pen_u, pde_u, pen_d, pde_d, dt_con, dq_con, pmflxr, pmflxs)
+  USE dimphy
+  IMPLICIT NONE
+  ! ------------------------------------------------------------------
+  include "YOMCST.h"
+  include "YOETHF.h"
+  include "YOECUMF.h"
+  ! ----------------------------------------------------------------
+  REAL pten(klon, klev), pqen(klon, klev), pqsen(klon, klev)
+  REAL ptte(klon, klev)
+  REAL pqte(klon, klev)
+  REAL pvervel(klon, klev)
+  REAL pgeo(klon, klev), pap(klon, klev), paph(klon, klev+1)
+  REAL pqhfl(klon)
+
+  REAL ptu(klon, klev), pqu(klon, klev), plu(klon, klev)
+  REAL plude(klon, klev)
+  REAL pmfu(klon, klev)
+  REAL prsfc(klon), pssfc(klon)
+  INTEGER kcbot(klon), kctop(klon), ktype(klon)
+  LOGICAL ldland(klon), ldcum(klon)
+
+  REAL ztenh(klon, klev), zqenh(klon, klev), zqsenh(klon, klev)
+  REAL zgeoh(klon, klev)
+  REAL zmfub(klon), zmfub1(klon)
+  REAL zmfus(klon, klev), zmfuq(klon, klev), zmful(klon, klev)
+  REAL zdmfup(klon, klev), zdpmel(klon, klev)
+  REAL zentr(klon), zhcbase(klon)
+  REAL zdqpbl(klon), zdqcv(klon), zdhpbl(klon)
+  REAL zrfl(klon)
+  REAL pmflxr(klon, klev+1)
+  REAL pmflxs(klon, klev+1)
+  INTEGER ilab(klon, klev), ictop0(klon)
+  LOGICAL llo1
+  REAL dt_con(klon, klev), dq_con(klon, klev)
+  REAL zmfmax, zdh
+  REAL pdtime, zqumqe, zdqmin, zalvdcp, zhsat, zzz
+  REAL zhhat, zpbmpt, zgam, zeps, zfac
+  INTEGER i, k, ikb, itopm2, kcum
+
+  REAL pen_u(klon, klev), pde_u(klon, klev)
+  REAL pen_d(klon, klev), pde_d(klon, klev)
+
+  REAL ptd(klon, klev), pqd(klon, klev), pmfd(klon, klev)
+  REAL zmfds(klon, klev), zmfdq(klon, klev), zdmfdp(klon, klev)
+  INTEGER kdtop(klon)
+  LOGICAL lddraf(klon)
+  ! ---------------------------------------------------------------------
+  LOGICAL firstcal
+  SAVE firstcal
+  DATA firstcal/.TRUE./
+  !$OMP THREADPRIVATE(firstcal)
+  ! ---------------------------------------------------------------------
+  IF (firstcal) THEN
+    CALL flxsetup
+    firstcal = .FALSE.
+  END IF
+  ! ---------------------------------------------------------------------
+  DO i = 1, klon
+    ldcum(i) = .FALSE.
+  END DO
+  DO k = 1, klev
+    DO i = 1, klon
+      dt_con(i, k) = 0.0
+      dq_con(i, k) = 0.0
+    END DO
+  END DO
+  ! ----------------------------------------------------------------------
+  ! initialiser les variables et faire l'interpolation verticale
+  ! ----------------------------------------------------------------------
+  CALL flxini(pten, pqen, pqsen, pgeo, paph, zgeoh, ztenh, zqenh, zqsenh, &
+    ptu, pqu, ptd, pqd, pmfd, zmfds, zmfdq, zdmfdp, pmfu, zmfus, zmfuq, &
+    zdmfup, zdpmel, plu, plude, ilab, pen_u, pde_u, pen_d, pde_d)
+  ! ---------------------------------------------------------------------
+  ! determiner les valeurs au niveau de base de la tour convective
+  ! ---------------------------------------------------------------------
+  CALL flxbase(ztenh, zqenh, zgeoh, paph, ptu, pqu, plu, ldcum, kcbot, ilab)
+  ! ---------------------------------------------------------------------
+  ! calculer la convergence totale de l'humidite et celle en provenance
+  ! de la couche limite, plus precisement, la convergence integree entre
+  ! le sol et la base de la convection. Cette derniere convergence est
+  ! comparee avec l'evaporation obtenue dans la couche limite pour
+  ! determiner le type de la convection
+  ! ---------------------------------------------------------------------
+  k = 1
+  DO i = 1, klon
+    zdqcv(i) = pqte(i, k)*(paph(i,k+1)-paph(i,k))
+    zdhpbl(i) = 0.0
+    zdqpbl(i) = 0.0
+  END DO
+
+  DO k = 2, klev
+    DO i = 1, klon
+      zdqcv(i) = zdqcv(i) + pqte(i, k)*(paph(i,k+1)-paph(i,k))
+      IF (k>=kcbot(i)) THEN
+        zdqpbl(i) = zdqpbl(i) + pqte(i, k)*(paph(i,k+1)-paph(i,k))
+        zdhpbl(i) = zdhpbl(i) + (rcpd*ptte(i,k)+rlvtt*pqte(i,k))*(paph(i,k+1) &
+          -paph(i,k))
+      END IF
+    END DO
+  END DO
+
+  DO i = 1, klon
+    ktype(i) = 2
+    IF (zdqcv(i)>max(0.,-1.5*pqhfl(i)*rg)) ktype(i) = 1
+    ! cc         if (zdqcv(i).GT.MAX(0.,-1.1*pqhfl(i)*RG)) ktype(i) = 1
+  END DO
+
+  ! ---------------------------------------------------------------------
+  ! determiner le flux de masse entrant a travers la base.
+  ! on ignore, pour l'instant, l'effet du panache descendant
+  ! ---------------------------------------------------------------------
+  DO i = 1, klon
+    ikb = kcbot(i)
+    zqumqe = pqu(i, ikb) + plu(i, ikb) - zqenh(i, ikb)
+    zdqmin = max(0.01*zqenh(i,ikb), 1.E-10)
+    IF (zdqpbl(i)>0. .AND. zqumqe>zdqmin .AND. ldcum(i)) THEN
+      zmfub(i) = zdqpbl(i)/(rg*max(zqumqe,zdqmin))
+    ELSE
+      zmfub(i) = 0.01
+      ldcum(i) = .FALSE.
+    END IF
+    IF (ktype(i)==2) THEN
+      zdh = rcpd*(ptu(i,ikb)-ztenh(i,ikb)) + rlvtt*zqumqe
+      zdh = rg*max(zdh, 1.0E5*zdqmin)
+      IF (zdhpbl(i)>0. .AND. ldcum(i)) zmfub(i) = zdhpbl(i)/zdh
+    END IF
+    zmfmax = (paph(i,ikb)-paph(i,ikb-1))/(rg*pdtime)
+    zmfub(i) = min(zmfub(i), zmfmax)
+    zentr(i) = entrscv
+    IF (ktype(i)==1) zentr(i) = entrpen
+  END DO
+  ! -----------------------------------------------------------------------
+  ! DETERMINE CLOUD ASCENT FOR ENTRAINING PLUME
+  ! -----------------------------------------------------------------------
+  ! (A) calculer d'abord la hauteur "theorique" de la tour convective sans
+  ! considerer l'entrainement ni le detrainement du panache, sachant
+  ! ces derniers peuvent abaisser la hauteur theorique.
+
+  DO i = 1, klon
+    ikb = kcbot(i)
+    zhcbase(i) = rcpd*ptu(i, ikb) + zgeoh(i, ikb) + rlvtt*pqu(i, ikb)
+    ictop0(i) = kcbot(i) - 1
+  END DO
+
+  zalvdcp = rlvtt/rcpd
+  DO k = klev - 1, 3, -1
+    DO i = 1, klon
+      zhsat = rcpd*ztenh(i, k) + zgeoh(i, k) + rlvtt*zqsenh(i, k)
+      zgam = r5les*zalvdcp*zqsenh(i, k)/((1.-retv*zqsenh(i,k))*(ztenh(i, &
+        k)-r4les)**2)
+      zzz = rcpd*ztenh(i, k)*0.608
+      zhhat = zhsat - (zzz+zgam*zzz)/(1.+zgam*zzz/rlvtt)*max(zqsenh(i,k)- &
+        zqenh(i,k), 0.)
+      IF (k<ictop0(i) .AND. zhcbase(i)>zhhat) ictop0(i) = k
+    END DO
+  END DO
+
+  ! (B) calculer le panache ascendant
+
+  CALL flxasc(pdtime, ztenh, zqenh, pten, pqen, pqsen, pgeo, zgeoh, pap, &
+    paph, pqte, pvervel, ldland, ldcum, ktype, ilab, ptu, pqu, plu, pmfu, &
+    zmfub, zentr, zmfus, zmfuq, zmful, plude, zdmfup, kcbot, kctop, ictop0, &
+    kcum, pen_u, pde_u)
+  IF (kcum==0) GO TO 1000
+
+  ! verifier l'epaisseur de la convection et changer eventuellement
+  ! le taux d'entrainement/detrainement
+
+  DO i = 1, klon
+    zpbmpt = paph(i, kcbot(i)) - paph(i, kctop(i))
+    IF (ldcum(i) .AND. ktype(i)==1 .AND. zpbmpt<2.E4) ktype(i) = 2
+    IF (ldcum(i)) ictop0(i) = kctop(i)
+    IF (ktype(i)==2) zentr(i) = entrscv
+  END DO
+
+  IF (lmfdd) THEN ! si l'on considere le panache descendant
+
+    ! calculer la precipitation issue du panache ascendant pour
+    ! determiner l'existence du panache descendant dans la convection
+    DO i = 1, klon
+      zrfl(i) = zdmfup(i, 1)
+    END DO
+    DO k = 2, klev
+      DO i = 1, klon
+        zrfl(i) = zrfl(i) + zdmfup(i, k)
+      END DO
+    END DO
+
+    ! determiner le LFS (level of free sinking: niveau de plonge libre)
+    CALL flxdlfs(ztenh, zqenh, zgeoh, paph, ptu, pqu, ldcum, kcbot, kctop, &
+      zmfub, zrfl, ptd, pqd, pmfd, zmfds, zmfdq, zdmfdp, kdtop, lddraf)
+
+    ! calculer le panache descendant
+    CALL flxddraf(ztenh, zqenh, zgeoh, paph, zrfl, ptd, pqd, pmfd, zmfds, &
+      zmfdq, zdmfdp, lddraf, pen_d, pde_d)
+
+    ! calculer de nouveau le flux de masse entrant a travers la base
+    ! de la convection, sachant qu'il a ete modifie par le panache
+    ! descendant
+    DO i = 1, klon
+      IF (lddraf(i)) THEN
+        ikb = kcbot(i)
+        llo1 = pmfd(i, ikb) < 0.
+        zeps = 0.
+        IF (llo1) zeps = cmfdeps
+        zqumqe = pqu(i, ikb) + plu(i, ikb) - zeps*pqd(i, ikb) - &
+          (1.-zeps)*zqenh(i, ikb)
+        zdqmin = max(0.01*zqenh(i,ikb), 1.E-10)
+        zmfmax = (paph(i,ikb)-paph(i,ikb-1))/(rg*pdtime)
+        IF (zdqpbl(i)>0. .AND. zqumqe>zdqmin .AND. ldcum(i) .AND. &
+            zmfub(i)<zmfmax) THEN
+          zmfub1(i) = zdqpbl(i)/(rg*max(zqumqe,zdqmin))
+        ELSE
+          zmfub1(i) = zmfub(i)
+        END IF
+        IF (ktype(i)==2) THEN
+          zdh = rcpd*(ptu(i,ikb)-zeps*ptd(i,ikb)-(1.-zeps)*ztenh(i,ikb)) + &
+            rlvtt*zqumqe
+          zdh = rg*max(zdh, 1.0E5*zdqmin)
+          IF (zdhpbl(i)>0. .AND. ldcum(i)) zmfub1(i) = zdhpbl(i)/zdh
+        END IF
+        IF (.NOT. ((ktype(i)==1 .OR. ktype(i)==2) .AND. abs(zmfub1(i)-zmfub(i &
+          ))<0.2*zmfub(i))) zmfub1(i) = zmfub(i)
+      END IF
+    END DO
+    DO k = 1, klev
+      DO i = 1, klon
+        IF (lddraf(i)) THEN
+          zfac = zmfub1(i)/max(zmfub(i), 1.E-10)
+          pmfd(i, k) = pmfd(i, k)*zfac
+          zmfds(i, k) = zmfds(i, k)*zfac
+          zmfdq(i, k) = zmfdq(i, k)*zfac
+          zdmfdp(i, k) = zdmfdp(i, k)*zfac
+          pen_d(i, k) = pen_d(i, k)*zfac
+          pde_d(i, k) = pde_d(i, k)*zfac
+        END IF
+      END DO
+    END DO
+    DO i = 1, klon
+      IF (lddraf(i)) zmfub(i) = zmfub1(i)
+    END DO
+
+  END IF ! fin de test sur lmfdd
+
+  ! -----------------------------------------------------------------------
+  ! calculer de nouveau le panache ascendant
+  ! -----------------------------------------------------------------------
+  CALL flxasc(pdtime, ztenh, zqenh, pten, pqen, pqsen, pgeo, zgeoh, pap, &
+    paph, pqte, pvervel, ldland, ldcum, ktype, ilab, ptu, pqu, plu, pmfu, &
+    zmfub, zentr, zmfus, zmfuq, zmful, plude, zdmfup, kcbot, kctop, ictop0, &
+    kcum, pen_u, pde_u)
+
+  ! -----------------------------------------------------------------------
+  ! determiner les flux convectifs en forme finale, ainsi que
+  ! la quantite des precipitations
+  ! -----------------------------------------------------------------------
+  CALL flxflux(pdtime, pqen, pqsen, ztenh, zqenh, pap, paph, ldland, zgeoh, &
+    kcbot, kctop, lddraf, kdtop, ktype, ldcum, pmfu, pmfd, zmfus, zmfds, &
+    zmfuq, zmfdq, zmful, plude, zdmfup, zdmfdp, pten, prsfc, pssfc, zdpmel, &
+    itopm2, pmflxr, pmflxs)
+
+  ! ----------------------------------------------------------------------
+  ! calculer les tendances pour T et Q
+  ! ----------------------------------------------------------------------
+  CALL flxdtdq(pdtime, itopm2, paph, ldcum, pten, zmfus, zmfds, zmfuq, zmfdq, &
+    zmful, zdmfup, zdmfdp, zdpmel, dt_con, dq_con)
+
+1000 CONTINUE
+  RETURN
+END SUBROUTINE flxmain
+SUBROUTINE flxini(pten, pqen, pqsen, pgeo, paph, pgeoh, ptenh, pqenh, pqsenh, &
+    ptu, pqu, ptd, pqd, pmfd, pmfds, pmfdq, pdmfdp, pmfu, pmfus, pmfuq, &
+    pdmfup, pdpmel, plu, plude, klab, pen_u, pde_u, pen_d, pde_d)
+  USE dimphy
+  IMPLICIT NONE
+  ! ----------------------------------------------------------------------
+  ! THIS ROUTINE INTERPOLATES LARGE-SCALE FIELDS OF T,Q ETC.
+  ! TO HALF LEVELS (I.E. GRID FOR MASSFLUX SCHEME),
+  ! AND INITIALIZES VALUES FOR UPDRAFTS
+  ! ----------------------------------------------------------------------
+  include "YOMCST.h"
+  include "YOETHF.h"
+
+  REAL pten(klon, klev) ! temperature (environnement)
+  REAL pqen(klon, klev) ! humidite (environnement)
+  REAL pqsen(klon, klev) ! humidite saturante (environnement)
+  REAL pgeo(klon, klev) ! geopotentiel (g * metre)
+  REAL pgeoh(klon, klev) ! geopotentiel aux demi-niveaux
+  REAL paph(klon, klev+1) ! pression aux demi-niveaux
+  REAL ptenh(klon, klev) ! temperature aux demi-niveaux
+  REAL pqenh(klon, klev) ! humidite aux demi-niveaux
+  REAL pqsenh(klon, klev) ! humidite saturante aux demi-niveaux
+
+  REAL ptu(klon, klev) ! temperature du panache ascendant (p-a)
+  REAL pqu(klon, klev) ! humidite du p-a
+  REAL plu(klon, klev) ! eau liquide du p-a
+  REAL pmfu(klon, klev) ! flux de masse du p-a
+  REAL pmfus(klon, klev) ! flux de l'energie seche dans le p-a
+  REAL pmfuq(klon, klev) ! flux de l'humidite dans le p-a
+  REAL pdmfup(klon, klev) ! quantite de l'eau precipitee dans p-a
+  REAL plude(klon, klev) ! quantite de l'eau liquide jetee du
+  ! p-a a l'environnement
+  REAL pdpmel(klon, klev) ! quantite de neige fondue
+
+  REAL ptd(klon, klev) ! temperature du panache descendant (p-d)
+  REAL pqd(klon, klev) ! humidite du p-d
+  REAL pmfd(klon, klev) ! flux de masse du p-d
+  REAL pmfds(klon, klev) ! flux de l'energie seche dans le p-d
+  REAL pmfdq(klon, klev) ! flux de l'humidite dans le p-d
+  REAL pdmfdp(klon, klev) ! quantite de precipitation dans p-d
+
+  REAL pen_u(klon, klev) ! quantite de masse entrainee pour p-a
+  REAL pde_u(klon, klev) ! quantite de masse detrainee pour p-a
+  REAL pen_d(klon, klev) ! quantite de masse entrainee pour p-d
+  REAL pde_d(klon, klev) ! quantite de masse detrainee pour p-d
+
+  INTEGER klab(klon, klev)
+  LOGICAL llflag(klon)
+  INTEGER k, i, icall
+  REAL zzs
+  ! ----------------------------------------------------------------------
+  ! SPECIFY LARGE SCALE PARAMETERS AT HALF LEVELS
+  ! ADJUST TEMPERATURE FIELDS IF STATICLY UNSTABLE
+  ! ----------------------------------------------------------------------
+  DO k = 2, klev
+
+    DO i = 1, klon
+      pgeoh(i, k) = pgeo(i, k) + (pgeo(i,k-1)-pgeo(i,k))*0.5
+      ptenh(i, k) = (max(rcpd*pten(i,k-1)+pgeo(i,k-1),rcpd*pten(i,k)+pgeo(i, &
+        k))-pgeoh(i,k))/rcpd
+      pqsenh(i, k) = pqsen(i, k-1)
+      llflag(i) = .TRUE.
+    END DO
+
+    icall = 0
+    CALL flxadjtq(paph(1,k), ptenh(1,k), pqsenh(1,k), llflag, icall)
+
+    DO i = 1, klon
+      pqenh(i, k) = min(pqen(i,k-1), pqsen(i,k-1)) + &
+        (pqsenh(i,k)-pqsen(i,k-1))
+      pqenh(i, k) = max(pqenh(i,k), 0.)
+    END DO
+
+  END DO
+
+  DO i = 1, klon
+    ptenh(i, klev) = (rcpd*pten(i,klev)+pgeo(i,klev)-pgeoh(i,klev))/rcpd
+    pqenh(i, klev) = pqen(i, klev)
+    ptenh(i, 1) = pten(i, 1)
+    pqenh(i, 1) = pqen(i, 1)
+    pgeoh(i, 1) = pgeo(i, 1)
+  END DO
+
+  DO k = klev - 1, 2, -1
+    DO i = 1, klon
+      zzs = max(rcpd*ptenh(i,k)+pgeoh(i,k), rcpd*ptenh(i,k+1)+pgeoh(i,k+1))
+      ptenh(i, k) = (zzs-pgeoh(i,k))/rcpd
+    END DO
+  END DO
+
+  ! -----------------------------------------------------------------------
+  ! INITIALIZE VALUES FOR UPDRAFTS AND DOWNDRAFTS
+  ! -----------------------------------------------------------------------
+  DO k = 1, klev
+    DO i = 1, klon
+      ptu(i, k) = ptenh(i, k)
+      pqu(i, k) = pqenh(i, k)
+      plu(i, k) = 0.
+      pmfu(i, k) = 0.
+      pmfus(i, k) = 0.
+      pmfuq(i, k) = 0.
+      pdmfup(i, k) = 0.
+      pdpmel(i, k) = 0.
+      plude(i, k) = 0.
+
+      klab(i, k) = 0
+
+      ptd(i, k) = ptenh(i, k)
+      pqd(i, k) = pqenh(i, k)
+      pmfd(i, k) = 0.0
+      pmfds(i, k) = 0.0
+      pmfdq(i, k) = 0.0
+      pdmfdp(i, k) = 0.0
+
+      pen_u(i, k) = 0.0
+      pde_u(i, k) = 0.0
+      pen_d(i, k) = 0.0
+      pde_d(i, k) = 0.0
+    END DO
+  END DO
+
+  RETURN
+END SUBROUTINE flxini
+SUBROUTINE flxbase(ptenh, pqenh, pgeoh, paph, ptu, pqu, plu, ldcum, kcbot, &
+    klab)
+  USE dimphy
+  IMPLICIT NONE
+  ! ----------------------------------------------------------------------
+  ! THIS ROUTINE CALCULATES CLOUD BASE VALUES (T AND Q)
+
+  ! INPUT ARE ENVIRONM. VALUES OF T,Q,P,PHI AT HALF LEVELS.
+  ! IT RETURNS CLOUD BASE VALUES AND FLAGS AS FOLLOWS;
+  ! klab=1 FOR SUBCLOUD LEVELS
+  ! klab=2 FOR CONDENSATION LEVEL
+
+  ! LIFT SURFACE AIR DRY-ADIABATICALLY TO CLOUD BASE
+  ! (NON ENTRAINING PLUME,I.E.CONSTANT MASSFLUX)
+  ! ----------------------------------------------------------------------
+  include "YOMCST.h"
+  include "YOETHF.h"
+  ! ----------------------------------------------------------------
+  REAL ptenh(klon, klev), pqenh(klon, klev)
+  REAL pgeoh(klon, klev), paph(klon, klev+1)
+
+  REAL ptu(klon, klev), pqu(klon, klev), plu(klon, klev)
+  INTEGER klab(klon, klev), kcbot(klon)
+
+  LOGICAL llflag(klon), ldcum(klon)
+  INTEGER i, k, icall, is
+  REAL zbuo, zqold(klon)
+  ! ----------------------------------------------------------------------
+  ! INITIALIZE VALUES AT LIFTING LEVEL
+  ! ----------------------------------------------------------------------
+  DO i = 1, klon
+    klab(i, klev) = 1
+    kcbot(i) = klev - 1
+    ldcum(i) = .FALSE.
+  END DO
+  ! ----------------------------------------------------------------------
+  ! DO ASCENT IN SUBCLOUD LAYER,
+  ! CHECK FOR EXISTENCE OF CONDENSATION LEVEL,
+  ! ADJUST T,Q AND L ACCORDINGLY
+  ! CHECK FOR BUOYANCY AND SET FLAGS
+  ! ----------------------------------------------------------------------
+  DO k = klev - 1, 2, -1
+
+    is = 0
+    DO i = 1, klon
+      IF (klab(i,k+1)==1) is = is + 1
+      llflag(i) = .FALSE.
+      IF (klab(i,k+1)==1) llflag(i) = .TRUE.
+    END DO
+    IF (is==0) GO TO 290
+
+    DO i = 1, klon
+      IF (llflag(i)) THEN
+        pqu(i, k) = pqu(i, k+1)
+        ptu(i, k) = ptu(i, k+1) + (pgeoh(i,k+1)-pgeoh(i,k))/rcpd
+        zbuo = ptu(i, k)*(1.+retv*pqu(i,k)) - ptenh(i, k)*(1.+retv*pqenh(i,k) &
+          ) + 0.5
+        IF (zbuo>0.) klab(i, k) = 1
+        zqold(i) = pqu(i, k)
+      END IF
+    END DO
+
+    icall = 1
+    CALL flxadjtq(paph(1,k), ptu(1,k), pqu(1,k), llflag, icall)
+
+    DO i = 1, klon
+      IF (llflag(i) .AND. pqu(i,k)/=zqold(i)) THEN
+        klab(i, k) = 2
+        plu(i, k) = plu(i, k) + zqold(i) - pqu(i, k)
+        zbuo = ptu(i, k)*(1.+retv*pqu(i,k)) - ptenh(i, k)*(1.+retv*pqenh(i,k) &
+          ) + 0.5
+        IF (zbuo>0.) kcbot(i) = k
+        IF (zbuo>0.) ldcum(i) = .TRUE.
+      END IF
+    END DO
+
+290 END DO
+
+  RETURN
+END SUBROUTINE flxbase
+SUBROUTINE flxasc(pdtime, ptenh, pqenh, pten, pqen, pqsen, pgeo, pgeoh, pap, &
+    paph, pqte, pvervel, ldland, ldcum, ktype, klab, ptu, pqu, plu, pmfu, &
+    pmfub, pentr, pmfus, pmfuq, pmful, plude, pdmfup, kcbot, kctop, kctop0, &
+    kcum, pen_u, pde_u)
+  USE dimphy
+  IMPLICIT NONE
+  ! ----------------------------------------------------------------------
+  ! THIS ROUTINE DOES THE CALCULATIONS FOR CLOUD ASCENTS
+  ! FOR CUMULUS PARAMETERIZATION
+  ! ----------------------------------------------------------------------
+  include "YOMCST.h"
+  include "YOETHF.h"
+  include "YOECUMF.h"
+
+  REAL pdtime
+  REAL pten(klon, klev), ptenh(klon, klev)
+  REAL pqen(klon, klev), pqenh(klon, klev), pqsen(klon, klev)
+  REAL pgeo(klon, klev), pgeoh(klon, klev)
+  REAL pap(klon, klev), paph(klon, klev+1)
+  REAL pqte(klon, klev)
+  REAL pvervel(klon, klev) ! vitesse verticale en Pa/s
+
+  REAL pmfub(klon), pentr(klon)
+  REAL ptu(klon, klev), pqu(klon, klev), plu(klon, klev)
+  REAL plude(klon, klev)
+  REAL pmfu(klon, klev), pmfus(klon, klev)
+  REAL pmfuq(klon, klev), pmful(klon, klev)
+  REAL pdmfup(klon, klev)
+  INTEGER ktype(klon), klab(klon, klev), kcbot(klon), kctop(klon)
+  INTEGER kctop0(klon)
+  LOGICAL ldland(klon), ldcum(klon)
+
+  REAL pen_u(klon, klev), pde_u(klon, klev)
+  REAL zqold(klon)
+  REAL zdland(klon)
+  LOGICAL llflag(klon)
+  INTEGER k, i, is, icall, kcum
+  REAL ztglace, zdphi, zqeen, zseen, zscde, zqude
+  REAL zmfusk, zmfuqk, zmfulk, zbuo, zdnoprc, zprcon, zlnew
+
+  REAL zpbot(klon), zptop(klon), zrho(klon)
+  REAL zdprho, zentr, zpmid, zmftest, zmfmax
+  LOGICAL llo1, llo2
+
+  REAL zwmax(klon), zzzmb
+  INTEGER klwmin(klon) ! level of maximum vertical velocity
+  REAL fact
+  ! ----------------------------------------------------------------------
+  ztglace = rtt - 13.
+
+  ! Chercher le niveau ou la vitesse verticale est maximale:
+  DO i = 1, klon
+    klwmin(i) = klev
+    zwmax(i) = 0.0
+  END DO
+  DO k = klev, 3, -1
+    DO i = 1, klon
+      IF (pvervel(i,k)<zwmax(i)) THEN
+        zwmax(i) = pvervel(i, k)
+        klwmin(i) = k
+      END IF
+    END DO
+  END DO
+  ! ----------------------------------------------------------------------
+  ! SET DEFAULT VALUES
+  ! ----------------------------------------------------------------------
+  DO i = 1, klon
+    IF (.NOT. ldcum(i)) ktype(i) = 0
+  END DO
+
+  DO k = 1, klev
+    DO i = 1, klon
+      plu(i, k) = 0.
+      pmfu(i, k) = 0.
+      pmfus(i, k) = 0.
+      pmfuq(i, k) = 0.
+      pmful(i, k) = 0.
+      plude(i, k) = 0.
+      pdmfup(i, k) = 0.
+      IF (.NOT. ldcum(i) .OR. ktype(i)==3) klab(i, k) = 0
+      IF (.NOT. ldcum(i) .AND. paph(i,k)<4.E4) kctop0(i) = k
+    END DO
+  END DO
+
+  DO i = 1, klon
+    IF (ldland(i)) THEN
+      zdland(i) = 3.0E4
+      zdphi = pgeoh(i, kctop0(i)) - pgeoh(i, kcbot(i))
+      IF (ptu(i,kctop0(i))>=ztglace) zdland(i) = zdphi
+      zdland(i) = max(3.0E4, zdland(i))
+      zdland(i) = min(5.0E4, zdland(i))
+    END IF
+  END DO
+
+  ! Initialiser les valeurs au niveau d'ascendance
+
+  DO i = 1, klon
+    kctop(i) = klev - 1
+    IF (.NOT. ldcum(i)) THEN
+      kcbot(i) = klev - 1
+      pmfub(i) = 0.
+      pqu(i, klev) = 0.
+    END IF
+    pmfu(i, klev) = pmfub(i)
+    pmfus(i, klev) = pmfub(i)*(rcpd*ptu(i,klev)+pgeoh(i,klev))
+    pmfuq(i, klev) = pmfub(i)*pqu(i, klev)
+  END DO
+
+  DO i = 1, klon
+    ldcum(i) = .FALSE.
+  END DO
+  ! ----------------------------------------------------------------------
+  ! DO ASCENT: SUBCLOUD LAYER (klab=1) ,CLOUDS (klab=2)
+  ! BY DOING FIRST DRY-ADIABATIC ASCENT AND THEN
+  ! BY ADJUSTING T,Q AND L ACCORDINGLY IN *flxadjtq*,
+  ! THEN CHECK FOR BUOYANCY AND SET FLAGS ACCORDINGLY
+  ! ----------------------------------------------------------------------
+  DO k = klev - 1, 3, -1
+
+    IF (lmfmid .AND. k<klev-1) THEN
+      DO i = 1, klon
+        IF (.NOT. ldcum(i) .AND. klab(i,k+1)==0 .AND. &
+            pqen(i,k)>0.9*pqsen(i,k) .AND. pap(i,k)/paph(i,klev+1)>0.4) THEN
+          ptu(i, k+1) = pten(i, k) + (pgeo(i,k)-pgeoh(i,k+1))/rcpd
+          pqu(i, k+1) = pqen(i, k)
+          plu(i, k+1) = 0.0
+          zzzmb = max(cmfcmin, -pvervel(i,k)/rg)
+          zmfmax = (paph(i,k)-paph(i,k-1))/(rg*pdtime)
+          pmfub(i) = min(zzzmb, zmfmax)
+          pmfu(i, k+1) = pmfub(i)
+          pmfus(i, k+1) = pmfub(i)*(rcpd*ptu(i,k+1)+pgeoh(i,k+1))
+          pmfuq(i, k+1) = pmfub(i)*pqu(i, k+1)
+          pmful(i, k+1) = 0.0
+          pdmfup(i, k+1) = 0.0
+          kcbot(i) = k
+          klab(i, k+1) = 1
+          ktype(i) = 3
+          pentr(i) = entrmid
+        END IF
+      END DO
+    END IF
+
+    is = 0
+    DO i = 1, klon
+      is = is + klab(i, k+1)
+      IF (klab(i,k+1)==0) klab(i, k) = 0
+      llflag(i) = .FALSE.
+      IF (klab(i,k+1)>0) llflag(i) = .TRUE.
+    END DO
+    IF (is==0) GO TO 480
+
+    ! calculer le taux d'entrainement et de detrainement
+
+    DO i = 1, klon
+      pen_u(i, k) = 0.0
+      pde_u(i, k) = 0.0
+      zrho(i) = paph(i, k+1)/(rd*ptenh(i,k+1))
+      zpbot(i) = paph(i, kcbot(i))
+      zptop(i) = paph(i, kctop0(i))
+    END DO
+
+    DO i = 1, klon
+      IF (ldcum(i)) THEN
+        zdprho = (paph(i,k+1)-paph(i,k))/(rg*zrho(i))
+        zentr = pentr(i)*pmfu(i, k+1)*zdprho
+        llo1 = k < kcbot(i)
+        IF (llo1) pde_u(i, k) = zentr
+        zpmid = 0.5*(zpbot(i)+zptop(i))
+        llo2 = llo1 .AND. ktype(i) == 2 .AND. (zpbot(i)-paph(i,k)<0.2E5 .OR. &
+          paph(i,k)>zpmid)
+        IF (llo2) pen_u(i, k) = zentr
+        llo2 = llo1 .AND. (ktype(i)==1 .OR. ktype(i)==3) .AND. &
+          (k>=max(klwmin(i),kctop0(i)+2) .OR. pap(i,k)>zpmid)
+        IF (llo2) pen_u(i, k) = zentr
+        llo1 = pen_u(i, k) > 0. .AND. (ktype(i)==1 .OR. ktype(i)==2)
+        IF (llo1) THEN
+          fact = 1. + 3.*(1.-min(1.,(zpbot(i)-pap(i,k))/1.5E4))
+          zentr = zentr*fact
+          pen_u(i, k) = pen_u(i, k)*fact
+          pde_u(i, k) = pde_u(i, k)*fact
+        END IF
+        IF (llo2 .AND. pqenh(i,k+1)>1.E-5) pen_u(i, k) = zentr + &
+          max(pqte(i,k), 0.)/pqenh(i, k+1)*zrho(i)*zdprho
+      END IF
+    END DO
+
+    ! ----------------------------------------------------------------------
+    ! DO ADIABATIC ASCENT FOR ENTRAINING/DETRAINING PLUME
+    ! ----------------------------------------------------------------------
+
+    DO i = 1, klon
+      IF (llflag(i)) THEN
+        IF (k<kcbot(i)) THEN
+          zmftest = pmfu(i, k+1) + pen_u(i, k) - pde_u(i, k)
+          zmfmax = min(zmftest, (paph(i,k)-paph(i,k-1))/(rg*pdtime))
+          pen_u(i, k) = max(pen_u(i,k)-max(0.0,zmftest-zmfmax), 0.0)
+        END IF
+        pde_u(i, k) = min(pde_u(i,k), 0.75*pmfu(i,k+1))
+        ! calculer le flux de masse du niveau k a partir de celui du k+1
+        pmfu(i, k) = pmfu(i, k+1) + pen_u(i, k) - pde_u(i, k)
+        ! calculer les valeurs Su, Qu et l du niveau k dans le panache
+        ! montant
+        zqeen = pqenh(i, k+1)*pen_u(i, k)
+        zseen = (rcpd*ptenh(i,k+1)+pgeoh(i,k+1))*pen_u(i, k)
+        zscde = (rcpd*ptu(i,k+1)+pgeoh(i,k+1))*pde_u(i, k)
+        zqude = pqu(i, k+1)*pde_u(i, k)
+        plude(i, k) = plu(i, k+1)*pde_u(i, k)
+        zmfusk = pmfus(i, k+1) + zseen - zscde
+        zmfuqk = pmfuq(i, k+1) + zqeen - zqude
+        zmfulk = pmful(i, k+1) - plude(i, k)
+        plu(i, k) = zmfulk*(1./max(cmfcmin,pmfu(i,k)))
+        pqu(i, k) = zmfuqk*(1./max(cmfcmin,pmfu(i,k)))
+        ptu(i, k) = (zmfusk*(1./max(cmfcmin,pmfu(i,k)))-pgeoh(i,k))/rcpd
+        ptu(i, k) = max(100., ptu(i,k))
+        ptu(i, k) = min(400., ptu(i,k))
+        zqold(i) = pqu(i, k)
+      ELSE
+        zqold(i) = 0.0
+      END IF
+    END DO
+
+    ! ----------------------------------------------------------------------
+    ! DO CORRECTIONS FOR MOIST ASCENT BY ADJUSTING T,Q AND L
+    ! ----------------------------------------------------------------------
+
+    icall = 1
+    CALL flxadjtq(paph(1,k), ptu(1,k), pqu(1,k), llflag, icall)
+
+    DO i = 1, klon
+      IF (llflag(i) .AND. pqu(i,k)/=zqold(i)) THEN
+        klab(i, k) = 2
+        plu(i, k) = plu(i, k) + zqold(i) - pqu(i, k)
+        zbuo = ptu(i, k)*(1.+retv*pqu(i,k)) - ptenh(i, k)*(1.+retv*pqenh(i,k) &
+          )
+        IF (klab(i,k+1)==1) zbuo = zbuo + 0.5
+        IF (zbuo>0. .AND. pmfu(i,k)>=0.1*pmfub(i)) THEN
+          kctop(i) = k
+          ldcum(i) = .TRUE.
+          zdnoprc = 1.5E4
+          IF (ldland(i)) zdnoprc = zdland(i)
+          zprcon = cprcon
+          IF ((zpbot(i)-paph(i,k))<zdnoprc) zprcon = 0.0
+          zlnew = plu(i, k)/(1.+zprcon*(pgeoh(i,k)-pgeoh(i,k+1)))
+          pdmfup(i, k) = max(0., (plu(i,k)-zlnew)*pmfu(i,k))
+          plu(i, k) = zlnew
+        ELSE
+          klab(i, k) = 0
+          pmfu(i, k) = 0.
+        END IF
+      END IF
+    END DO
+    DO i = 1, klon
+      IF (llflag(i)) THEN
+        pmful(i, k) = plu(i, k)*pmfu(i, k)
+        pmfus(i, k) = (rcpd*ptu(i,k)+pgeoh(i,k))*pmfu(i, k)
+        pmfuq(i, k) = pqu(i, k)*pmfu(i, k)
+      END IF
+    END DO
+
+480 END DO
+  ! ----------------------------------------------------------------------
+  ! DETERMINE CONVECTIVE FLUXES ABOVE NON-BUOYANCY LEVEL
+  ! (NOTE: CLOUD VARIABLES LIKE T,Q AND L ARE NOT
+  ! AFFECTED BY DETRAINMENT AND ARE ALREADY KNOWN
+  ! FROM PREVIOUS CALCULATIONS ABOVE)
+  ! ----------------------------------------------------------------------
+  DO i = 1, klon
+    IF (kctop(i)==klev-1) ldcum(i) = .FALSE.
+    kcbot(i) = max(kcbot(i), kctop(i))
+  END DO
+
+  ldcum(1) = ldcum(1)
+
+  is = 0
+  DO i = 1, klon
+    IF (ldcum(i)) is = is + 1
+  END DO
+  kcum = is
+  IF (is==0) GO TO 800
+
+  DO i = 1, klon
+    IF (ldcum(i)) THEN
+      k = kctop(i) - 1
+      pde_u(i, k) = (1.-cmfctop)*pmfu(i, k+1)
+      plude(i, k) = pde_u(i, k)*plu(i, k+1)
+      pmfu(i, k) = pmfu(i, k+1) - pde_u(i, k)
+      zlnew = plu(i, k)
+      pdmfup(i, k) = max(0., (plu(i,k)-zlnew)*pmfu(i,k))
+      plu(i, k) = zlnew
+      pmfus(i, k) = (rcpd*ptu(i,k)+pgeoh(i,k))*pmfu(i, k)
+      pmfuq(i, k) = pqu(i, k)*pmfu(i, k)
+      pmful(i, k) = plu(i, k)*pmfu(i, k)
+      plude(i, k-1) = pmful(i, k)
+    END IF
+  END DO
+
+800 CONTINUE
+  RETURN
+END SUBROUTINE flxasc
+SUBROUTINE flxflux(pdtime, pqen, pqsen, ptenh, pqenh, pap, paph, ldland, &
+    pgeoh, kcbot, kctop, lddraf, kdtop, ktype, ldcum, pmfu, pmfd, pmfus, &
+    pmfds, pmfuq, pmfdq, pmful, plude, pdmfup, pdmfdp, pten, prfl, psfl, &
+    pdpmel, ktopm2, pmflxr, pmflxs)
+  USE dimphy
+  USE print_control_mod, ONLY: prt_level
+  IMPLICIT NONE
+  ! ----------------------------------------------------------------------
+  ! THIS ROUTINE DOES THE FINAL CALCULATION OF CONVECTIVE
+  ! FLUXES IN THE CLOUD LAYER AND IN THE SUBCLOUD LAYER
+  ! ----------------------------------------------------------------------
+  include "YOMCST.h"
+  include "YOETHF.h"
+  include "YOECUMF.h"
+
+  REAL cevapcu(klon, klev)
+  ! -----------------------------------------------------------------
+  REAL pqen(klon, klev), pqenh(klon, klev), pqsen(klon, klev)
+  REAL pten(klon, klev), ptenh(klon, klev)
+  REAL paph(klon, klev+1), pgeoh(klon, klev)
+
+  REAL pap(klon, klev)
+  REAL ztmsmlt, zdelta, zqsat
+
+  REAL pmfu(klon, klev), pmfus(klon, klev)
+  REAL pmfd(klon, klev), pmfds(klon, klev)
+  REAL pmfuq(klon, klev), pmful(klon, klev)
+  REAL pmfdq(klon, klev)
+  REAL plude(klon, klev)
+  REAL pdmfup(klon, klev), pdpmel(klon, klev)
+  ! jq The variable maxpdmfdp(klon) has been introduced by Olivier Boucher
+  ! jq 14/11/00 to fix the problem with the negative precipitation.
+  REAL pdmfdp(klon, klev), maxpdmfdp(klon, klev)
+  REAL prfl(klon), psfl(klon)
+  REAL pmflxr(klon, klev+1), pmflxs(klon, klev+1)
+  INTEGER kcbot(klon), kctop(klon), ktype(klon)
+  LOGICAL ldland(klon), ldcum(klon)
+  INTEGER k, kp, i
+  REAL zcons1, zcons2, zcucov, ztmelp2
+  REAL pdtime, zdp, zzp, zfac, zsnmlt, zrfl, zrnew
+  REAL zrmin, zrfln, zdrfl
+  REAL zpds, zpdr, zdenom
+  INTEGER ktopm2, itop, ikb
+
+  LOGICAL lddraf(klon)
+  INTEGER kdtop(klon)
+
+  include "FCTTRE.h"
+
+  DO k = 1, klev
+    DO i = 1, klon
+      cevapcu(i, k) = 1.93E-6*261.*sqrt(1.E3/(38.3*0.293)*sqrt(0.5*(paph(i,k) &
+        +paph(i,k+1))/paph(i,klev+1)))*0.5/rg
+    END DO
+  END DO
+
+  ! SPECIFY CONSTANTS
+
+  zcons1 = rcpd/(rlmlt*rg*pdtime)
+  zcons2 = 1./(rg*pdtime)
+  zcucov = 0.05
+  ztmelp2 = rtt + 2.
+
+  ! DETERMINE FINAL CONVECTIVE FLUXES
+
+  itop = klev
+  DO i = 1, klon
+    itop = min(itop, kctop(i))
+    IF (.NOT. ldcum(i) .OR. kdtop(i)<kctop(i)) lddraf(i) = .FALSE.
+    IF (.NOT. ldcum(i)) ktype(i) = 0
+  END DO
+
+  ktopm2 = itop - 2
+  DO k = ktopm2, klev
+    DO i = 1, klon
+      IF (ldcum(i) .AND. k>=kctop(i)-1) THEN
+        pmfus(i, k) = pmfus(i, k) - pmfu(i, k)*(rcpd*ptenh(i,k)+pgeoh(i,k))
+        pmfuq(i, k) = pmfuq(i, k) - pmfu(i, k)*pqenh(i, k)
+        zdp = 1.5E4
+        IF (ldland(i)) zdp = 3.E4
+
+        ! l'eau liquide detrainee est precipitee quand certaines
+        ! conditions sont reunies (sinon, elle est consideree
+        ! evaporee dans l'environnement)
+
+        IF (paph(i,kcbot(i))-paph(i,kctop(i))>=zdp .AND. pqen(i,k-1)>0.8* &
+          pqsen(i,k-1)) pdmfup(i, k-1) = pdmfup(i, k-1) + plude(i, k-1)
+
+        IF (lddraf(i) .AND. k>=kdtop(i)) THEN
+          pmfds(i, k) = pmfds(i, k) - pmfd(i, k)*(rcpd*ptenh(i,k)+pgeoh(i,k))
+          pmfdq(i, k) = pmfdq(i, k) - pmfd(i, k)*pqenh(i, k)
+        ELSE
+          pmfd(i, k) = 0.
+          pmfds(i, k) = 0.
+          pmfdq(i, k) = 0.
+          pdmfdp(i, k-1) = 0.
+        END IF
+      ELSE
+        pmfu(i, k) = 0.
+        pmfus(i, k) = 0.
+        pmfuq(i, k) = 0.
+        pmful(i, k) = 0.
+        pdmfup(i, k-1) = 0.
+        plude(i, k-1) = 0.
+        pmfd(i, k) = 0.
+        pmfds(i, k) = 0.
+        pmfdq(i, k) = 0.
+        pdmfdp(i, k-1) = 0.
+      END IF
+    END DO
+  END DO
+
+  DO k = ktopm2, klev
+    DO i = 1, klon
+      IF (ldcum(i) .AND. k>kcbot(i)) THEN
+        ikb = kcbot(i)
+        zzp = ((paph(i,klev+1)-paph(i,k))/(paph(i,klev+1)-paph(i,ikb)))
+        IF (ktype(i)==3) zzp = zzp**2
+        pmfu(i, k) = pmfu(i, ikb)*zzp
+        pmfus(i, k) = pmfus(i, ikb)*zzp
+        pmfuq(i, k) = pmfuq(i, ikb)*zzp
+        pmful(i, k) = pmful(i, ikb)*zzp
+      END IF
+    END DO
+  END DO
+
+  ! CALCULATE RAIN/SNOW FALL RATES
+  ! CALCULATE MELTING OF SNOW
+  ! CALCULATE EVAPORATION OF PRECIP
+
+  DO k = 1, klev + 1
+    DO i = 1, klon
+      pmflxr(i, k) = 0.0
+      pmflxs(i, k) = 0.0
+    END DO
+  END DO
+  DO k = ktopm2, klev
+    DO i = 1, klon
+      IF (ldcum(i)) THEN
+        IF (pmflxs(i,k)>0.0 .AND. pten(i,k)>ztmelp2) THEN
+          zfac = zcons1*(paph(i,k+1)-paph(i,k))
+          zsnmlt = min(pmflxs(i,k), zfac*(pten(i,k)-ztmelp2))
+          pdpmel(i, k) = zsnmlt
+          ztmsmlt = pten(i, k) - zsnmlt/zfac
+          zdelta = max(0., sign(1.,rtt-ztmsmlt))
+          zqsat = r2es*foeew(ztmsmlt, zdelta)/pap(i, k)
+          zqsat = min(0.5, zqsat)
+          zqsat = zqsat/(1.-retv*zqsat)
+          pqsen(i, k) = zqsat
+        END IF
+        IF (pten(i,k)>rtt) THEN
+          pmflxr(i, k+1) = pmflxr(i, k) + pdmfup(i, k) + pdmfdp(i, k) + &
+            pdpmel(i, k)
+          pmflxs(i, k+1) = pmflxs(i, k) - pdpmel(i, k)
+        ELSE
+          pmflxs(i, k+1) = pmflxs(i, k) + pdmfup(i, k) + pdmfdp(i, k)
+          pmflxr(i, k+1) = pmflxr(i, k)
+        END IF
+        ! si la precipitation est negative, on ajuste le plux du
+        ! panache descendant pour eliminer la negativite
+        IF ((pmflxr(i,k+1)+pmflxs(i,k+1))<0.0) THEN
+          pdmfdp(i, k) = -pmflxr(i, k) - pmflxs(i, k) - pdmfup(i, k)
+          pmflxr(i, k+1) = 0.0
+          pmflxs(i, k+1) = 0.0
+          pdpmel(i, k) = 0.0
+        END IF
+      END IF
+    END DO
+  END DO
+
+  ! jq The new variable is initialized here.
+  ! jq It contains the humidity which is fed to the downdraft
+  ! jq by evaporation of precipitation in the column below the base
+  ! jq of convection.
+  ! jq
+  ! jq In the former version, this term has been subtracted from precip
+  ! jq as well as the evaporation.
+  ! jq
+  DO k = 1, klev
+    DO i = 1, klon
+      maxpdmfdp(i, k) = 0.0
+    END DO
+  END DO
+  DO k = 1, klev
+    DO kp = k, klev
+      DO i = 1, klon
+        maxpdmfdp(i, k) = maxpdmfdp(i, k) + pdmfdp(i, kp)
+      END DO
+    END DO
+  END DO
+  ! jq End of initialization
+
+  DO k = ktopm2, klev
+    DO i = 1, klon
+      IF (ldcum(i) .AND. k>=kcbot(i)) THEN
+        zrfl = pmflxr(i, k) + pmflxs(i, k)
+        IF (zrfl>1.0E-20) THEN
+          zrnew = (max(0.,sqrt(zrfl/zcucov)-cevapcu(i, &
+            k)*(paph(i,k+1)-paph(i,k))*max(0.,pqsen(i,k)-pqen(i,k))))**2* &
+            zcucov
+          zrmin = zrfl - zcucov*max(0., 0.8*pqsen(i,k)-pqen(i,k))*zcons2*( &
+            paph(i,k+1)-paph(i,k))
+          zrnew = max(zrnew, zrmin)
+          zrfln = max(zrnew, 0.)
+          zdrfl = min(0., zrfln-zrfl)
+          ! jq At least the amount of precipiation needed to feed the
+          ! downdraft
+          ! jq with humidity below the base of convection has to be left and
+          ! can't
+          ! jq be evaporated (surely the evaporation can't be positive):
+          zdrfl = max(zdrfl, min(-pmflxr(i,k)-pmflxs(i,k)-maxpdmfdp(i, &
+            k),0.0))
+          ! jq End of insertion
+
+          zdenom = 1.0/max(1.0E-20, pmflxr(i,k)+pmflxs(i,k))
+          IF (pten(i,k)>rtt) THEN
+            zpdr = pdmfdp(i, k)
+            zpds = 0.0
+          ELSE
+            zpdr = 0.0
+            zpds = pdmfdp(i, k)
+          END IF
+          pmflxr(i, k+1) = pmflxr(i, k) + zpdr + pdpmel(i, k) + &
+            zdrfl*pmflxr(i, k)*zdenom
+          pmflxs(i, k+1) = pmflxs(i, k) + zpds - pdpmel(i, k) + &
+            zdrfl*pmflxs(i, k)*zdenom
+          pdmfup(i, k) = pdmfup(i, k) + zdrfl
+        ELSE
+          pmflxr(i, k+1) = 0.0
+          pmflxs(i, k+1) = 0.0
+          pdmfdp(i, k) = 0.0
+          pdpmel(i, k) = 0.0
+        END IF
+        IF (pmflxr(i,k)+pmflxs(i,k)<-1.E-26 .AND. prt_level>=1) WRITE (*, *) &
+          'precip. < 1e-16 ', pmflxr(i, k) + pmflxs(i, k)
+      END IF
+    END DO
+  END DO
+
+  DO i = 1, klon
+    prfl(i) = pmflxr(i, klev+1)
+    psfl(i) = pmflxs(i, klev+1)
+  END DO
+
+  RETURN
+END SUBROUTINE flxflux
+SUBROUTINE flxdtdq(pdtime, ktopm2, paph, ldcum, pten, pmfus, pmfds, pmfuq, &
+    pmfdq, pmful, pdmfup, pdmfdp, pdpmel, dt_con, dq_con)
+  USE dimphy
+  IMPLICIT NONE
+  ! ----------------------------------------------------------------------
+  ! calculer les tendances T et Q
+  ! ----------------------------------------------------------------------
+  include "YOMCST.h"
+  include "YOETHF.h"
+  include "YOECUMF.h"
+  ! -----------------------------------------------------------------
+  LOGICAL llo1
+
+  REAL pten(klon, klev), paph(klon, klev+1)
+  REAL pmfus(klon, klev), pmfuq(klon, klev), pmful(klon, klev)
+  REAL pmfds(klon, klev), pmfdq(klon, klev)
+  REAL pdmfup(klon, klev)
+  REAL pdmfdp(klon, klev)
+  REAL pdpmel(klon, klev)
+  LOGICAL ldcum(klon)
+  REAL dt_con(klon, klev), dq_con(klon, klev)
+
+  INTEGER ktopm2
+  REAL pdtime
+
+  INTEGER i, k
+  REAL zalv, zdtdt, zdqdt
+
+  DO k = ktopm2, klev - 1
+    DO i = 1, klon
+      IF (ldcum(i)) THEN
+        llo1 = (pten(i,k)-rtt) > 0.
+        zalv = rlstt
+        IF (llo1) zalv = rlvtt
+        zdtdt = rg/(paph(i,k+1)-paph(i,k))/rcpd*(pmfus(i,k+1)-pmfus(i,k)+ &
+          pmfds(i,k+1)-pmfds(i,k)-rlmlt*pdpmel(i,k)-zalv*(pmful(i, &
+          k+1)-pmful(i,k)-pdmfup(i,k)-pdmfdp(i,k)))
+        dt_con(i, k) = zdtdt
+        zdqdt = rg/(paph(i,k+1)-paph(i,k))*(pmfuq(i,k+1)-pmfuq(i,k)+pmfdq(i,k &
+          +1)-pmfdq(i,k)+pmful(i,k+1)-pmful(i,k)-pdmfup(i,k)-pdmfdp(i,k))
+        dq_con(i, k) = zdqdt
+      END IF
+    END DO
+  END DO
+
+  k = klev
+  DO i = 1, klon
+    IF (ldcum(i)) THEN
+      llo1 = (pten(i,k)-rtt) > 0.
+      zalv = rlstt
+      IF (llo1) zalv = rlvtt
+      zdtdt = -rg/(paph(i,k+1)-paph(i,k))/rcpd*(pmfus(i,k)+pmfds(i,k)+rlmlt* &
+        pdpmel(i,k)-zalv*(pmful(i,k)+pdmfup(i,k)+pdmfdp(i,k)))
+      dt_con(i, k) = zdtdt
+      zdqdt = -rg/(paph(i,k+1)-paph(i,k))*(pmfuq(i,k)+pmfdq(i,k)+pmful(i,k)+ &
+        pdmfup(i,k)+pdmfdp(i,k))
+      dq_con(i, k) = zdqdt
+    END IF
+  END DO
+
+  RETURN
+END SUBROUTINE flxdtdq
+SUBROUTINE flxdlfs(ptenh, pqenh, pgeoh, paph, ptu, pqu, ldcum, kcbot, kctop, &
+    pmfub, prfl, ptd, pqd, pmfd, pmfds, pmfdq, pdmfdp, kdtop, lddraf)
+  USE dimphy
+  IMPLICIT NONE
+
+  ! ----------------------------------------------------------------------
+  ! THIS ROUTINE CALCULATES LEVEL OF FREE SINKING FOR
+  ! CUMULUS DOWNDRAFTS AND SPECIFIES T,Q,U AND V VALUES
+
+  ! TO PRODUCE LFS-VALUES FOR CUMULUS DOWNDRAFTS
+  ! FOR MASSFLUX CUMULUS PARAMETERIZATION
+
+  ! INPUT ARE ENVIRONMENTAL VALUES OF T,Q,U,V,P,PHI
+  ! AND UPDRAFT VALUES T,Q,U AND V AND ALSO
+  ! CLOUD BASE MASSFLUX AND CU-PRECIPITATION RATE.
+  ! IT RETURNS T,Q,U AND V VALUES AND MASSFLUX AT LFS.
+
+  ! CHECK FOR NEGATIVE BUOYANCY OF AIR OF EQUAL PARTS OF
+  ! MOIST ENVIRONMENTAL AIR AND CLOUD AIR.
+  ! ----------------------------------------------------------------------
+  include "YOMCST.h"
+  include "YOETHF.h"
+  include "YOECUMF.h"
+
+  REAL ptenh(klon, klev)
+  REAL pqenh(klon, klev)
+  REAL pgeoh(klon, klev), paph(klon, klev+1)
+  REAL ptu(klon, klev), pqu(klon, klev)
+  REAL pmfub(klon)
+  REAL prfl(klon)
+
+  REAL ptd(klon, klev), pqd(klon, klev)
+  REAL pmfd(klon, klev), pmfds(klon, klev), pmfdq(klon, klev)
+  REAL pdmfdp(klon, klev)
+  INTEGER kcbot(klon), kctop(klon), kdtop(klon)
+  LOGICAL ldcum(klon), lddraf(klon)
+
+  REAL ztenwb(klon, klev), zqenwb(klon, klev), zcond(klon)
+  REAL zttest, zqtest, zbuo, zmftop
+  LOGICAL llo2(klon)
+  INTEGER i, k, is, icall
+  ! ----------------------------------------------------------------------
+  DO i = 1, klon
+    lddraf(i) = .FALSE.
+    kdtop(i) = klev + 1
+  END DO
+
+  ! ----------------------------------------------------------------------
+  ! DETERMINE LEVEL OF FREE SINKING BY
+  ! DOING A SCAN FROM TOP TO BASE OF CUMULUS CLOUDS
+
+  ! FOR EVERY POINT AND PROCEED AS FOLLOWS:
+  ! (1) DETEMINE WET BULB ENVIRONMENTAL T AND Q
+  ! (2) DO MIXING WITH CUMULUS CLOUD AIR
+  ! (3) CHECK FOR NEGATIVE BUOYANCY
+
+  ! THE ASSUMPTION IS THAT AIR OF DOWNDRAFTS IS MIXTURE
+  ! OF 50% CLOUD AIR + 50% ENVIRONMENTAL AIR AT WET BULB
+  ! TEMPERATURE (I.E. WHICH BECAME SATURATED DUE TO
+  ! EVAPORATION OF RAIN AND CLOUD WATER)
+  ! ----------------------------------------------------------------------
+
+  DO k = 3, klev - 3
+
+    is = 0
+    DO i = 1, klon
+      ztenwb(i, k) = ptenh(i, k)
+      zqenwb(i, k) = pqenh(i, k)
+      llo2(i) = ldcum(i) .AND. prfl(i) > 0. .AND. .NOT. lddraf(i) .AND. &
+        (k<kcbot(i) .AND. k>kctop(i))
+      IF (llo2(i)) is = is + 1
+    END DO
+    IF (is==0) GO TO 290
+
+    icall = 2
+    CALL flxadjtq(paph(1,k), ztenwb(1,k), zqenwb(1,k), llo2, icall)
+
+    ! ----------------------------------------------------------------------
+    ! DO MIXING OF CUMULUS AND ENVIRONMENTAL AIR
+    ! AND CHECK FOR NEGATIVE BUOYANCY.
+    ! THEN SET VALUES FOR DOWNDRAFT AT LFS.
+    ! ----------------------------------------------------------------------
+    DO i = 1, klon
+      IF (llo2(i)) THEN
+        zttest = 0.5*(ptu(i,k)+ztenwb(i,k))
+        zqtest = 0.5*(pqu(i,k)+zqenwb(i,k))
+        zbuo = zttest*(1.+retv*zqtest) - ptenh(i, k)*(1.+retv*pqenh(i,k))
+        zcond(i) = pqenh(i, k) - zqenwb(i, k)
+        zmftop = -cmfdeps*pmfub(i)
+        IF (zbuo<0. .AND. prfl(i)>10.*zmftop*zcond(i)) THEN
+          kdtop(i) = k
+          lddraf(i) = .TRUE.
+          ptd(i, k) = zttest
+          pqd(i, k) = zqtest
+          pmfd(i, k) = zmftop
+          pmfds(i, k) = pmfd(i, k)*(rcpd*ptd(i,k)+pgeoh(i,k))
+          pmfdq(i, k) = pmfd(i, k)*pqd(i, k)
+          pdmfdp(i, k-1) = -0.5*pmfd(i, k)*zcond(i)
+          prfl(i) = prfl(i) + pdmfdp(i, k-1)
+        END IF
+      END IF
+    END DO
+
+290 END DO
+
+  RETURN
+END SUBROUTINE flxdlfs
+SUBROUTINE flxddraf(ptenh, pqenh, pgeoh, paph, prfl, ptd, pqd, pmfd, pmfds, &
+    pmfdq, pdmfdp, lddraf, pen_d, pde_d)
+  USE dimphy
+  IMPLICIT NONE
+
+  ! ----------------------------------------------------------------------
+  ! THIS ROUTINE CALCULATES CUMULUS DOWNDRAFT DESCENT
+
+  ! TO PRODUCE THE VERTICAL PROFILES FOR CUMULUS DOWNDRAFTS
+  ! (I.E. T,Q,U AND V AND FLUXES)
+
+  ! INPUT IS T,Q,P,PHI,U,V AT HALF LEVELS.
+  ! IT RETURNS FLUXES OF S,Q AND EVAPORATION RATE
+  ! AND U,V AT LEVELS WHERE DOWNDRAFT OCCURS
+
+  ! CALCULATE MOIST DESCENT FOR ENTRAINING/DETRAINING PLUME BY
+  ! A) MOVING AIR DRY-ADIABATICALLY TO NEXT LEVEL BELOW AND
+  ! B) CORRECTING FOR EVAPORATION TO OBTAIN SATURATED STATE.
+
+  ! ----------------------------------------------------------------------
+  include "YOMCST.h"
+  include "YOETHF.h"
+  include "YOECUMF.h"
+
+  REAL ptenh(klon, klev), pqenh(klon, klev)
+  REAL pgeoh(klon, klev), paph(klon, klev+1)
+
+  REAL ptd(klon, klev), pqd(klon, klev)
+  REAL pmfd(klon, klev), pmfds(klon, klev), pmfdq(klon, klev)
+  REAL pdmfdp(klon, klev)
+  REAL prfl(klon)
+  LOGICAL lddraf(klon)
+
+  REAL pen_d(klon, klev), pde_d(klon, klev), zcond(klon)
+  LOGICAL llo2(klon), llo1
+  INTEGER i, k, is, icall, itopde
+  REAL zentr, zseen, zqeen, zsdde, zqdde, zmfdsk, zmfdqk, zdmfdp
+  REAL zbuo
+  ! ----------------------------------------------------------------------
+  ! CALCULATE MOIST DESCENT FOR CUMULUS DOWNDRAFT BY
+  ! (A) CALCULATING ENTRAINMENT RATES, ASSUMING
+  ! LINEAR DECREASE OF MASSFLUX IN PBL
+  ! (B) DOING MOIST DESCENT - EVAPORATIVE COOLING
+  ! AND MOISTENING IS CALCULATED IN *flxadjtq*
+  ! (C) CHECKING FOR NEGATIVE BUOYANCY AND
+  ! SPECIFYING FINAL T,Q,U,V AND DOWNWARD FLUXES
+
+  DO k = 3, klev
+
+    is = 0
+    DO i = 1, klon
+      llo2(i) = lddraf(i) .AND. pmfd(i, k-1) < 0.
+      IF (llo2(i)) is = is + 1
+    END DO
+    IF (is==0) GO TO 180
+
+    DO i = 1, klon
+      IF (llo2(i)) THEN
+        zentr = entrdd*pmfd(i, k-1)*rd*ptenh(i, k-1)/(rg*paph(i,k-1))* &
+          (paph(i,k)-paph(i,k-1))
+        pen_d(i, k) = zentr
+        pde_d(i, k) = zentr
+      END IF
+    END DO
+
+    itopde = klev - 2
+    IF (k>itopde) THEN
+      DO i = 1, klon
+        IF (llo2(i)) THEN
+          pen_d(i, k) = 0.
+          pde_d(i, k) = pmfd(i, itopde)*(paph(i,k)-paph(i,k-1))/ &
+            (paph(i,klev+1)-paph(i,itopde))
+        END IF
+      END DO
+    END IF
+
+    DO i = 1, klon
+      IF (llo2(i)) THEN
+        pmfd(i, k) = pmfd(i, k-1) + pen_d(i, k) - pde_d(i, k)
+        zseen = (rcpd*ptenh(i,k-1)+pgeoh(i,k-1))*pen_d(i, k)
+        zqeen = pqenh(i, k-1)*pen_d(i, k)
+        zsdde = (rcpd*ptd(i,k-1)+pgeoh(i,k-1))*pde_d(i, k)
+        zqdde = pqd(i, k-1)*pde_d(i, k)
+        zmfdsk = pmfds(i, k-1) + zseen - zsdde
+        zmfdqk = pmfdq(i, k-1) + zqeen - zqdde
+        pqd(i, k) = zmfdqk*(1./min(-cmfcmin,pmfd(i,k)))
+        ptd(i, k) = (zmfdsk*(1./min(-cmfcmin,pmfd(i,k)))-pgeoh(i,k))/rcpd
+        ptd(i, k) = min(400., ptd(i,k))
+        ptd(i, k) = max(100., ptd(i,k))
+        zcond(i) = pqd(i, k)
+      END IF
+    END DO
+
+    icall = 2
+    CALL flxadjtq(paph(1,k), ptd(1,k), pqd(1,k), llo2, icall)
+
+    DO i = 1, klon
+      IF (llo2(i)) THEN
+        zcond(i) = zcond(i) - pqd(i, k)
+        zbuo = ptd(i, k)*(1.+retv*pqd(i,k)) - ptenh(i, k)*(1.+retv*pqenh(i,k) &
+          )
+        llo1 = zbuo < 0. .AND. (prfl(i)-pmfd(i,k)*zcond(i)>0.)
+        IF (.NOT. llo1) pmfd(i, k) = 0.0
+        pmfds(i, k) = (rcpd*ptd(i,k)+pgeoh(i,k))*pmfd(i, k)
+        pmfdq(i, k) = pqd(i, k)*pmfd(i, k)
+        zdmfdp = -pmfd(i, k)*zcond(i)
+        pdmfdp(i, k-1) = zdmfdp
+        prfl(i) = prfl(i) + zdmfdp
+      END IF
+    END DO
+
+180 END DO
+  RETURN
+END SUBROUTINE flxddraf
+SUBROUTINE flxadjtq(pp, pt, pq, ldflag, kcall)
+  USE dimphy
+  IMPLICIT NONE
+  ! ======================================================================
+  ! Objet: ajustement entre T et Q
+  ! ======================================================================
+  ! NOTE: INPUT PARAMETER kcall DEFINES CALCULATION AS
+  ! kcall=0    ENV. T AND QS IN*CUINI*
+  ! kcall=1  CONDENSATION IN UPDRAFTS  (E.G. CUBASE, CUASC)
+  ! kcall=2  EVAPORATION IN DOWNDRAFTS (E.G. CUDLFS,CUDDRAF)
+
+  include "YOMCST.h"
+
+  REAL pt(klon), pq(klon), pp(klon)
+  LOGICAL ldflag(klon)
+  INTEGER kcall
+
+  REAL zcond(klon), zcond1
+  REAL z5alvcp, z5alscp, zalvdcp, zalsdcp
+  REAL zdelta, zcvm5, zldcp, zqsat, zcor
+  INTEGER is, i
+  include "YOETHF.h"
+  include "FCTTRE.h"
+
+  z5alvcp = r5les*rlvtt/rcpd
+  z5alscp = r5ies*rlstt/rcpd
+  zalvdcp = rlvtt/rcpd
+  zalsdcp = rlstt/rcpd
+
+
+  DO i = 1, klon
+    zcond(i) = 0.0
+  END DO
+
+  DO i = 1, klon
+    IF (ldflag(i)) THEN
+      zdelta = max(0., sign(1.,rtt-pt(i)))
+      zcvm5 = z5alvcp*(1.-zdelta) + zdelta*z5alscp
+      zldcp = zalvdcp*(1.-zdelta) + zdelta*zalsdcp
+      zqsat = r2es*foeew(pt(i), zdelta)/pp(i)
+      zqsat = min(0.5, zqsat)
+      zcor = 1./(1.-retv*zqsat)
+      zqsat = zqsat*zcor
+      zcond(i) = (pq(i)-zqsat)/(1.+foede(pt(i),zdelta,zcvm5,zqsat,zcor))
+      IF (kcall==1) zcond(i) = max(zcond(i), 0.)
+      IF (kcall==2) zcond(i) = min(zcond(i), 0.)
+      pt(i) = pt(i) + zldcp*zcond(i)
+      pq(i) = pq(i) - zcond(i)
+    END IF
+  END DO
+
+  is = 0
+  DO i = 1, klon
+    IF (zcond(i)/=0.) is = is + 1
+  END DO
+  IF (is==0) GO TO 230
+
+  DO i = 1, klon
+    IF (ldflag(i) .AND. zcond(i)/=0.) THEN
+      zdelta = max(0., sign(1.,rtt-pt(i)))
+      zcvm5 = z5alvcp*(1.-zdelta) + zdelta*z5alscp
+      zldcp = zalvdcp*(1.-zdelta) + zdelta*zalsdcp
+      zqsat = r2es*foeew(pt(i), zdelta)/pp(i)
+      zqsat = min(0.5, zqsat)
+      zcor = 1./(1.-retv*zqsat)
+      zqsat = zqsat*zcor
+      zcond1 = (pq(i)-zqsat)/(1.+foede(pt(i),zdelta,zcvm5,zqsat,zcor))
+      pt(i) = pt(i) + zldcp*zcond1
+      pq(i) = pq(i) - zcond1
+    END IF
+  END DO
+
+230 CONTINUE
+  RETURN
+END SUBROUTINE flxadjtq
+SUBROUTINE flxsetup
+  IMPLICIT NONE
+
+  ! THIS ROUTINE DEFINES DISPOSABLE PARAMETERS FOR MASSFLUX SCHEME
+
+  include "YOECUMF.h"
+
+  entrpen = 1.0E-4 ! ENTRAINMENT RATE FOR PENETRATIVE CONVECTION
+  entrscv = 3.0E-4 ! ENTRAINMENT RATE FOR SHALLOW CONVECTION
+  entrmid = 1.0E-4 ! ENTRAINMENT RATE FOR MIDLEVEL CONVECTION
+  entrdd = 2.0E-4 ! ENTRAINMENT RATE FOR DOWNDRAFTS
+  cmfctop = 0.33 ! RELATIVE CLOUD MASSFLUX AT LEVEL ABOVE NONBUO LEVEL
+  cmfcmax = 1.0 ! MAXIMUM MASSFLUX VALUE ALLOWED FOR UPDRAFTS ETC
+  cmfcmin = 1.E-10 ! MINIMUM MASSFLUX VALUE (FOR SAFETY)
+  cmfdeps = 0.3 ! FRACTIONAL MASSFLUX FOR DOWNDRAFTS AT LFS
+  cprcon = 2.0E-4 ! CONVERSION FROM CLOUD WATER TO RAIN
+  rhcdd = 1. ! RELATIVE SATURATION IN DOWNDRAFRS (NO LONGER USED)
+  ! (FORMULATION IMPLIES SATURATION)
+  lmfpen = .TRUE.
+  lmfscv = .TRUE.
+  lmfmid = .TRUE.
+  lmfdd = .TRUE.
+  lmfdudv = .TRUE.
+
+  RETURN
+END SUBROUTINE flxsetup
Index: DZ6/trunk/libf/phylmd/conlmd.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/conlmd.F90	(revision 5267)
+++ 	(revision )
@@ -1,2250 +1,0 @@
-
-! $Header$
-
-SUBROUTINE conlmd(dtime, paprs, pplay, t, q, conv_q, d_t, d_q, rain, snow, &
-    ibas, itop)
-  USE dimphy
-  IMPLICIT NONE
-  ! ======================================================================
-  ! Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818
-  ! Objet: Schema de convection utilis'e dans le modele du LMD
-  ! Ajustement humide (Manabe) + Ajustement convectif (Kuo)
-  ! ======================================================================
-  include "YOMCST.h"
-  include "YOETHF.h"
-
-  ! Arguments:
-
-  REAL dtime ! pas d'integration (s)
-  REAL paprs(klon, klev+1) ! pression inter-couche (Pa)
-  REAL pplay(klon, klev) ! pression au milieu de couche (Pa)
-  REAL t(klon, klev) ! temperature (K)
-  REAL q(klon, klev) ! humidite specifique (kg/kg)
-  REAL conv_q(klon, klev) ! taux de convergence humidite (g/g/s)
-
-  REAL d_t(klon, klev) ! incrementation temperature
-  REAL d_q(klon, klev) ! incrementation humidite
-  REAL rain(klon) ! pluies (mm/s)
-  REAL snow(klon) ! neige (mm/s)
-  INTEGER ibas(klon) ! niveau du bas
-  INTEGER itop(klon) ! niveau du haut
-
-  LOGICAL usekuo ! utiliser convection profonde (schema Kuo)
-  PARAMETER (usekuo=.TRUE.)
-
-  REAL d_t_bis(klon, klev)
-  REAL d_q_bis(klon, klev)
-  REAL rain_bis(klon)
-  REAL snow_bis(klon)
-  INTEGER ibas_bis(klon)
-  INTEGER itop_bis(klon)
-  REAL d_ql(klon, klev), d_ql_bis(klon, klev)
-  REAL rneb(klon, klev), rneb_bis(klon, klev)
-
-  INTEGER i, k
-  REAL zlvdcp, zlsdcp, zdelta, zz, za, zb
-
-  ! cc      CALL fiajh ! ancienne version de Convection Manabe
-  CALL conman &                    ! nouvelle version de Convection
-                                   ! Manabe
-    (dtime, paprs, pplay, t, q, d_t, d_q, d_ql, rneb, rain, snow, ibas, itop)
-
-  IF (usekuo) THEN
-    ! cc      CALL fiajc ! ancienne version de Convection Kuo
-    CALL conkuo &                  ! nouvelle version de Convection
-                                   ! Kuo
-      (dtime, paprs, pplay, t, q, conv_q, d_t_bis, d_q_bis, d_ql_bis, &
-      rneb_bis, rain_bis, snow_bis, ibas_bis, itop_bis)
-    DO k = 1, klev
-      DO i = 1, klon
-        d_t(i, k) = d_t(i, k) + d_t_bis(i, k)
-        d_q(i, k) = d_q(i, k) + d_q_bis(i, k)
-        d_ql(i, k) = d_ql(i, k) + d_ql_bis(i, k)
-      END DO
-    END DO
-    DO i = 1, klon
-      rain(i) = rain(i) + rain_bis(i)
-      snow(i) = snow(i) + snow_bis(i)
-      ibas(i) = min(ibas(i), ibas_bis(i))
-      itop(i) = max(itop(i), itop_bis(i))
-    END DO
-  END IF
-
-  ! L'eau liquide convective est dispersee dans l'air:
-
-  DO k = 1, klev
-    DO i = 1, klon
-      zlvdcp = rlvtt/rcpd/(1.0+rvtmp2*q(i,k))
-      zlsdcp = rlstt/rcpd/(1.0+rvtmp2*q(i,k))
-      zdelta = max(0., sign(1.,rtt-t(i,k)))
-      zz = d_ql(i, k) ! re-evap. de l'eau liquide
-      zb = max(0.0, zz)
-      za = -max(0.0, zz)*(zlvdcp*(1.-zdelta)+zlsdcp*zdelta)
-      d_t(i, k) = d_t(i, k) + za
-      d_q(i, k) = d_q(i, k) + zb
-    END DO
-  END DO
-
-  RETURN
-END SUBROUTINE conlmd
-SUBROUTINE conman(dtime, paprs, pplay, t, q, d_t, d_q, d_ql, rneb, rain, &
-    snow, ibas, itop)
-  USE dimphy
-  IMPLICIT NONE
-  ! ======================================================================
-  ! Auteur(s): Z.X. Li (LMD/CNRS) date: 19970324
-  ! Objet: ajustement humide convectif avec la possibilite de faire
-  ! l'ajustement sur une fraction de la maille.
-  ! Methode: On impose une distribution uniforme pour la vapeur d'eau
-  ! au sein d'une maille. On applique la procedure d'ajustement
-  ! successivement a la totalite, 75%, 50%, 25% et 5% de la maille
-  ! jusqu'a ce que l'ajustement a lieu. J'espere que ceci augmente
-  ! les activites convectives et corrige le biais "trop froid et sec"
-  ! du modele.
-  ! ======================================================================
-  include "YOMCST.h"
-
-  REAL dtime ! pas d'integration (s)
-  REAL t(klon, klev) ! temperature (K)
-  REAL q(klon, klev) ! humidite specifique (kg/kg)
-  REAL paprs(klon, klev+1) ! pression inter-couche (Pa)
-  REAL pplay(klon, klev) ! pression au milieu de couche (Pa)
-
-  REAL d_t(klon, klev) ! incrementation temperature
-  REAL d_q(klon, klev) ! incrementation humidite
-  REAL d_ql(klon, klev) ! incrementation eau liquide
-  REAL rneb(klon, klev) ! nebulosite
-  REAL rain(klon) ! pluies (mm/s)
-  REAL snow(klon) ! neige (mm/s)
-  INTEGER ibas(klon) ! niveau du bas
-  INTEGER itop(klon) ! niveau du haut
-
-  LOGICAL afaire(klon) ! .TRUE. implique l'ajustement
-  LOGICAL accompli(klon) ! .TRUE. si l'ajustement est effectif
-
-  INTEGER nb ! nombre de sous-fractions a considere
-  PARAMETER (nb=1)
-  ! cc      PARAMETER (nb=3)
-
-  REAL ratqs ! largeur de la distribution pour vapeur d'eau
-  PARAMETER (ratqs=0.05)
-
-  REAL w_q(klon, klev)
-  REAL w_d_t(klon, klev), w_d_q(klon, klev), w_d_ql(klon, klev)
-  REAL w_rneb(klon, klev)
-  REAL w_rain(klon), w_snow(klon)
-  INTEGER w_ibas(klon), w_itop(klon)
-  REAL zq1, zq2
-  INTEGER i, k, n
-
-  REAL t_coup
-  PARAMETER (t_coup=234.0)
-  REAL zdp1, zdp2
-  REAL zqs1, zqs2, zdqs1, zdqs2
-  REAL zgamdz
-  REAL zflo ! flotabilite
-  REAL zsat ! sur-saturation
-  REAL zdelta, zcor, zcvm5
-  LOGICAL imprim
-
-  INTEGER ncpt
-  SAVE ncpt
-  !$OMP THREADPRIVATE(ncpt)
-  REAL frac(nb) ! valeur de la maille fractionnelle
-  SAVE frac
-  !$OMP THREADPRIVATE(frac)
-  INTEGER opt_cld(nb) ! option pour le modele nuageux
-  SAVE opt_cld
-  !$OMP THREADPRIVATE(opt_cld)
-  LOGICAL appel1er
-  SAVE appel1er
-  !$OMP THREADPRIVATE(appel1er)
-
-  ! Fonctions thermodynamiques:
-
-  include "YOETHF.h"
-  include "FCTTRE.h"
-
-  DATA frac/1.0/
-  DATA opt_cld/4/
-  ! cc      DATA frac    / 1.0, 0.50, 0.25/
-  ! cc      DATA opt_cld / 4,   4,    4/
-
-  DATA appel1er/.TRUE./
-  DATA ncpt/0/
-
-  IF (appel1er) THEN
-    PRINT *, 'conman, nb:', nb
-    PRINT *, 'conman, frac:', frac
-    PRINT *, 'conman, opt_cld:', opt_cld
-    appel1er = .FALSE.
-  END IF
-
-  ! Initialiser les sorties a zero:
-
-  DO k = 1, klev
-    DO i = 1, klon
-      d_t(i, k) = 0.0
-      d_q(i, k) = 0.0
-      d_ql(i, k) = 0.0
-      rneb(i, k) = 0.0
-    END DO
-  END DO
-  DO i = 1, klon
-    ibas(i) = klev
-    itop(i) = 1
-    rain(i) = 0.0
-    snow(i) = 0.0
-  END DO
-
-  ! S'il n'y a pas d'instabilite conditionnelle,
-  ! pas la penne de se fatiguer:
-
-  DO i = 1, klon
-    afaire(i) = .FALSE.
-  END DO
-  DO k = 1, klev - 1
-    DO i = 1, klon
-      IF (thermcep) THEN
-        zdelta = max(0., sign(1.,rtt-t(i,k)))
-        zcvm5 = r5les*rlvtt*(1.-zdelta) + zdelta*r5ies*rlstt
-        zcvm5 = zcvm5/rcpd/(1.0+rvtmp2*q(i,k))
-        zqs1 = r2es*foeew(t(i,k), zdelta)/pplay(i, k)
-        zqs1 = min(0.5, zqs1)
-        zcor = 1./(1.-retv*zqs1)
-        zqs1 = zqs1*zcor
-        zdqs1 = foede(t(i,k), zdelta, zcvm5, zqs1, zcor)
-
-        zdelta = max(0., sign(1.,rtt-t(i,k+1)))
-        zcvm5 = r5les*rlvtt*(1.-zdelta) + zdelta*r5ies*rlstt
-        zcvm5 = zcvm5/rcpd/(1.0+rvtmp2*q(i,k+1))
-        zqs2 = r2es*foeew(t(i,k+1), zdelta)/pplay(i, k+1)
-        zqs2 = min(0.5, zqs2)
-        zcor = 1./(1.-retv*zqs2)
-        zqs2 = zqs2*zcor
-        zdqs2 = foede(t(i,k+1), zdelta, zcvm5, zqs2, zcor)
-      ELSE
-        IF (t(i,k)<t_coup) THEN
-          zqs1 = qsats(t(i,k))/pplay(i, k)
-          zdqs1 = dqsats(t(i,k), zqs1)
-
-          zqs2 = qsats(t(i,k+1))/pplay(i, k+1)
-          zdqs2 = dqsats(t(i,k+1), zqs2)
-        ELSE
-          zqs1 = qsatl(t(i,k))/pplay(i, k)
-          zdqs1 = dqsatl(t(i,k), zqs1)
-
-          zqs2 = qsatl(t(i,k+1))/pplay(i, k+1)
-          zdqs2 = dqsatl(t(i,k+1), zqs2)
-        END IF
-      END IF
-      zdp1 = paprs(i, k) - paprs(i, k+1)
-      zdp2 = paprs(i, k+1) - paprs(i, k+2)
-      zgamdz = -(pplay(i,k)-pplay(i,k+1))/paprs(i, k+1)/rcpd*(rd*(t(i, &
-        k)*zdp1+t(i,k+1)*zdp2)/(zdp1+zdp2)+rlvtt*(zqs1*zdp1+zqs2*zdp2)/(zdp1+ &
-        zdp2))/(1.0+(zdqs1*zdp1+zdqs2*zdp2)/(zdp1+zdp2))
-      zflo = t(i, k) + zgamdz - t(i, k+1)
-      zsat = (q(i,k)-zqs1)*zdp1 + (q(i,k+1)-zqs2)*zdp2
-      IF (zflo>0.0) afaire(i) = .TRUE.
-      ! erreur         IF (zflo.GT.0.0 .AND. zsat.GT.0.0) afaire(i) = .TRUE.
-    END DO
-  END DO
-
-  imprim = mod(ncpt, 48) == 0
-  DO n = 1, nb
-
-    DO k = 1, klev
-      DO i = 1, klon
-        IF (afaire(i)) THEN
-          zq1 = q(i, k)*(1.0-ratqs)
-          zq2 = q(i, k)*(1.0+ratqs)
-          w_q(i, k) = zq2 - frac(n)/2.0*(zq2-zq1)
-        END IF
-      END DO
-    END DO
-
-    CALL conmanv(dtime, paprs, pplay, t, w_q, afaire, opt_cld(n), w_d_t, &
-      w_d_q, w_d_ql, w_rneb, w_rain, w_snow, w_ibas, w_itop, accompli, &
-      imprim)
-    DO k = 1, klev
-      DO i = 1, klon
-        IF (afaire(i) .AND. accompli(i)) THEN
-          d_t(i, k) = w_d_t(i, k)*frac(n)
-          d_q(i, k) = w_d_q(i, k)*frac(n)
-          d_ql(i, k) = w_d_ql(i, k)*frac(n)
-          IF (nint(w_rneb(i,k))==1) rneb(i, k) = frac(n)
-        END IF
-      END DO
-    END DO
-    DO i = 1, klon
-      IF (afaire(i) .AND. accompli(i)) THEN
-        rain(i) = w_rain(i)*frac(n)
-        snow(i) = w_snow(i)*frac(n)
-        ibas(i) = min(ibas(i), w_ibas(i))
-        itop(i) = max(itop(i), w_itop(i))
-      END IF
-    END DO
-    DO i = 1, klon
-      IF (afaire(i) .AND. accompli(i)) afaire(i) = .FALSE.
-    END DO
-
-  END DO
-
-  ncpt = ncpt + 1
-
-  RETURN
-END SUBROUTINE conman
-SUBROUTINE conmanv(dtime, paprs, pplay, t, q, afaire, opt_cld, d_t, d_q, &
-    d_ql, rneb, rain, snow, ibas, itop, accompli, imprim)
-  USE dimphy
-  IMPLICIT NONE
-  ! ======================================================================
-  ! Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818
-  ! Objet: ajustement humide (convection proposee par Manabe).
-  ! Pour une colonne verticale, il peut avoir plusieurs blocs
-  ! necessitant l'ajustement. ibas est le bas du plus bas bloc
-  ! et itop est le haut du plus haut bloc
-  ! ======================================================================
-  include "YOMCST.h"
-
-  ! Arguments:
-
-  REAL dtime ! pas d'integration (s)
-  REAL t(klon, klev) ! temperature (K)
-  REAL q(klon, klev) ! humidite specifique (kg/kg)
-  REAL paprs(klon, klev+1) ! pression inter-couche (Pa)
-  REAL pplay(klon, klev) ! pression au milieu de couche (Pa)
-  INTEGER opt_cld ! comment traiter l'eau liquide
-  LOGICAL afaire(klon) ! .TRUE. si le point est a faire (Input)
-  LOGICAL imprim ! .T. pour imprimer quelques diagnostiques
-
-  REAL d_t(klon, klev) ! incrementation temperature
-  REAL d_q(klon, klev) ! incrementation humidite
-  REAL d_ql(klon, klev) ! incrementation eau liquide
-  REAL rneb(klon, klev) ! nebulosite
-  REAL rain(klon) ! pluies (mm/s)
-  REAL snow(klon) ! neige (mm/s)
-  INTEGER ibas(klon) ! niveau du bas
-  INTEGER itop(klon) ! niveau du haut
-  LOGICAL accompli(klon) ! .TRUE. si l'ajustement a eu lieu (Output)
-
-  ! Quelques options:
-
-  LOGICAL new_top ! re-calculer sommet quand re-ajustement est fait
-  PARAMETER (new_top=.FALSE.)
-  LOGICAL evap_prec ! evaporation de pluie au-dessous de convection
-  PARAMETER (evap_prec=.TRUE.)
-  REAL coef_eva
-  PARAMETER (coef_eva=1.0E-05)
-  REAL t_coup
-  PARAMETER (t_coup=234.0)
-  REAL seuil_vap
-  PARAMETER (seuil_vap=1.0E-10)
-  LOGICAL old_tau ! implique precip nulle, si vrai.
-  PARAMETER (old_tau=.FALSE.)
-  REAL toliq(klon) ! rapport entre l'eau nuageuse et l'eau precipitante
-  REAL dpmin, tomax !Epaisseur faible, rapport eau liquide plus grande
-  PARAMETER (dpmin=0.15, tomax=0.97)
-  REAL dpmax, tomin !Epaisseur grande, rapport eau liquide plus faible
-  PARAMETER (dpmax=0.30, tomin=0.05)
-  REAL deep_sig, deep_to ! au dela de deep_sig, utiliser deep_to
-  PARAMETER (deep_sig=0.50, deep_to=0.05)
-  LOGICAL exigent ! implique un calcul supplementaire pour Qs
-  PARAMETER (exigent=.FALSE.)
-
-  INTEGER kbase
-  PARAMETER (kbase=0)
-
-  ! Variables locales:
-
-  INTEGER nexpo
-  INTEGER i, k, k1min, k1max, k2min, k2max, is
-  REAL zgamdz(klon, klev-1)
-  REAL zt(klon, klev), zq(klon, klev)
-  REAL zqs(klon, klev), zdqs(klon, klev)
-  REAL zqmqsdp(klon, klev)
-  REAL ztnew(klon, klev), zqnew(klon, klev)
-  REAL zcond(klon), zvapo(klon), zrapp(klon)
-  REAL zrfl(klon), zrfln, zqev, zqevt
-  REAL zsat(klon) ! sur-saturation
-  REAL zflo(klon) ! flotabilite
-  REAL za(klon), zb(klon), zc(klon)
-  INTEGER k1(klon), k2(klon)
-  REAL zdelta, zcor, zcvm5
-  REAL delp(klon, klev)
-  LOGICAL possible(klon), todo(klon), etendre(klon)
-  LOGICAL aller(klon), todobis(klon)
-  REAL zalfa
-  INTEGER nbtodo, nbdone
-
-  ! Fonctions thermodynamiques:
-
-  include "YOETHF.h"
-  include "FCTTRE.h"
-
-  DO k = 1, klev
-    DO i = 1, klon
-      delp(i, k) = paprs(i, k) - paprs(i, k+1)
-    END DO
-  END DO
-
-  ! Initialiser les sorties a zero
-
-  DO k = 1, klev
-    DO i = 1, klon
-      d_t(i, k) = 0.0
-      d_q(i, k) = 0.0
-      d_ql(i, k) = 0.0
-      rneb(i, k) = 0.0
-    END DO
-  END DO
-  DO i = 1, klon
-    ibas(i) = klev
-    itop(i) = 1
-    rain(i) = 0.0
-    snow(i) = 0.0
-    accompli(i) = .FALSE.
-  END DO
-
-  ! Preparations
-
-  DO k = 1, klev
-    DO i = 1, klon
-      IF (afaire(i)) THEN
-        zt(i, k) = t(i, k)
-        zq(i, k) = q(i, k)
-
-        ! Calculer Qs et L/Cp*dQs/dT
-
-        IF (thermcep) THEN
-          zdelta = max(0., sign(1.,rtt-zt(i,k)))
-          zcvm5 = r5les*rlvtt*(1.-zdelta) + zdelta*r5ies*rlstt
-          zcvm5 = zcvm5/rcpd/(1.0+rvtmp2*zq(i,k))
-          zqs(i, k) = r2es*foeew(zt(i,k), zdelta)/pplay(i, k)
-          zqs(i, k) = min(0.5, zqs(i,k))
-          zcor = 1./(1.-retv*zqs(i,k))
-          zqs(i, k) = zqs(i, k)*zcor
-          zdqs(i, k) = foede(zt(i,k), zdelta, zcvm5, zqs(i,k), zcor)
-        ELSE
-          IF (zt(i,k)<t_coup) THEN
-            zqs(i, k) = qsats(zt(i,k))/pplay(i, k)
-            zdqs(i, k) = dqsats(zt(i,k), zqs(i,k))
-          ELSE
-            zqs(i, k) = qsatl(zt(i,k))/pplay(i, k)
-            zdqs(i, k) = dqsatl(zt(i,k), zqs(i,k))
-          END IF
-        END IF
-
-        ! Calculer (q-qs)*dp
-        zqmqsdp(i, k) = (zq(i,k)-zqs(i,k))*delp(i, k)
-      END IF
-    END DO
-  END DO
-
-  ! -----zgama is the moist convective lapse rate (-dT/dz).
-  ! -----zgamdz(*,k) est la difference minimale autorisee des temperatures
-  ! -----entre deux couches (k et k+1), c.a.d. si T(k+1)-T(k) est inferieur
-  ! -----a zgamdz(*,k), alors ces 2 couches sont instables conditionnellement
-
-  DO k = 1, klev - 1
-    DO i = 1, klon
-      IF (afaire(i)) THEN
-        zgamdz(i, k) = -(pplay(i,k)-pplay(i,k+1))/paprs(i, k+1)/rcpd*(rd*(zt( &
-          i,k)*delp(i,k)+zt(i,k+1)*delp(i,k+1))/(delp(i,k)+delp(i, &
-          k+1))+rlvtt*(zqs(i,k)*delp(i,k)+zqs(i,k+1)*delp(i,k+1))/(delp(i, &
-          k)+delp(i,k+1)))/(1.0+(zdqs(i,k)*delp(i,k)+zdqs(i,k+1)*delp(i, &
-          k+1))/(delp(i,k)+delp(i,k+1)))
-      END IF
-    END DO
-  END DO
-
-  ! On cherche la presence simultanee d'instabilite conditionnelle
-  ! et de sur-saturation. Sinon, pas la penne de se fatiguer:
-
-  DO i = 1, klon
-    possible(i) = .FALSE.
-  END DO
-  DO k = 2, klev
-    DO i = 1, klon
-      IF (afaire(i)) THEN
-        zflo(i) = zt(i, k-1) + zgamdz(i, k-1) - zt(i, k)
-        zsat(i) = zqmqsdp(i, k) + zqmqsdp(i, k-1)
-        IF (zflo(i)>0.0 .AND. zsat(i)>0.0) possible(i) = .TRUE.
-      END IF
-    END DO
-  END DO
-
-  DO i = 1, klon
-    IF (possible(i)) THEN
-      k1(i) = kbase
-      k2(i) = k1(i) + 1
-    END IF
-  END DO
-
-810 CONTINUE ! chercher le bas de la colonne a ajuster
-
-  k2min = klev
-  DO i = 1, klon
-    todo(i) = .FALSE.
-    aller(i) = .TRUE.
-    IF (possible(i)) k2min = min(k2min, k2(i))
-  END DO
-  IF (k2min==klev) GO TO 860
-  DO k = k2min, klev - 1
-    DO i = 1, klon
-      IF (possible(i) .AND. k>=k2(i) .AND. aller(i)) THEN
-        zflo(i) = zt(i, k) + zgamdz(i, k) - zt(i, k+1)
-        zsat(i) = zqmqsdp(i, k) + zqmqsdp(i, k+1)
-        IF (zflo(i)>0.0 .AND. zsat(i)>0.0) THEN
-          k1(i) = k
-          k2(i) = k + 1
-          todo(i) = .TRUE.
-          aller(i) = .FALSE.
-        END IF
-      END IF
-    END DO
-  END DO
-  DO i = 1, klon
-    IF (possible(i) .AND. aller(i)) THEN
-      todo(i) = .FALSE.
-      k1(i) = klev
-      k2(i) = klev
-    END IF
-  END DO
-
-  ! CC      DO i = 1, klon
-  ! CC      IF (possible(i)) THEN
-  ! CC  811    k2(i) = k2(i) + 1
-  ! CC         IF (k2(i) .GT. klev) THEN
-  ! CC            todo(i) = .FALSE.
-  ! CC            GOTO 812
-  ! CC         ENDIF
-  ! CC         k = k2(i)
-  ! CC         zflo(i) = zt(i,k-1) + zgamdz(i,k-1) - zt(i,k)
-  ! CC         zsat(i) = zqmqsdp(i,k) + zqmqsdp(i,k-1)
-  ! CC         IF (zflo(i).LE.0.0 .OR. zsat(i).LE.0.0) GOTO 811
-  ! CC         k1(i) = k2(i) - 1
-  ! CC         todo(i) = .TRUE.
-  ! CC      ENDIF
-  ! CC  812 CONTINUE
-  ! CC      ENDDO
-
-820 CONTINUE ! chercher le haut de la colonne
-
-  k2min = klev
-  DO i = 1, klon
-    aller(i) = .TRUE.
-    IF (todo(i)) k2min = min(k2min, k2(i))
-  END DO
-  IF (k2min<klev) THEN
-    DO k = k2min, klev
-      DO i = 1, klon
-        IF (todo(i) .AND. k>k2(i) .AND. aller(i)) THEN
-          zsat(i) = zsat(i) + zqmqsdp(i, k)
-          zflo(i) = zt(i, k-1) + zgamdz(i, k-1) - zt(i, k)
-          IF (zflo(i)<=0.0 .OR. zsat(i)<=0.0) THEN
-            aller(i) = .FALSE.
-          ELSE
-            k2(i) = k
-          END IF
-        END IF
-      END DO
-    END DO
-    ! error      is = 0
-    ! error      DO i = 1, klon
-    ! error      IF(todo(i).AND.aller(i)) THEN
-    ! error         is = is + 1
-    ! error         todo(i) = .FALSE.
-    ! error         k2(i) = klev
-    ! error      ENDIF
-    ! error      ENDDO
-    ! error      IF (is.GT.0) THEN
-    ! error         PRINT*, "Bizard. je pourrais continuer mais j arrete"
-    ! error         CALL abort
-    ! error      ENDIF
-  END IF
-
-  ! CC      DO i = 1, klon
-  ! CC      IF (todo(i)) THEN
-  ! CC  821    CONTINUE
-  ! CC         IF (k2(i) .EQ. klev) GOTO 822
-  ! CC         k = k2(i) + 1
-  ! CC         zsat(i) = zsat(i) + zqmqsdp(i,k)
-  ! CC         zflo(i) = zt(i,k-1) + zgamdz(i,k-1) - zt(i,k)
-  ! CC         IF (zflo(i).LE.0.0 .OR. zsat(i).LE.0.0) GOTO 822
-  ! CC         k2(i) = k
-  ! CC         GOTO 821
-  ! CC      ENDIF
-  ! CC  822 CONTINUE
-  ! CC      ENDDO
-
-830 CONTINUE ! faire l'ajustement en sachant k1 et k2
-
-  is = 0
-  DO i = 1, klon
-    IF (todo(i)) THEN
-      IF (k2(i)<=k1(i)) is = is + 1
-    END IF
-  END DO
-  IF (is>0) THEN
-    PRINT *, 'Impossible: k1 trop grand ou k2 trop petit'
-    PRINT *, 'is=', is
-    CALL abort
-  END IF
-
-  k1min = klev
-  k1max = 1
-  k2max = 1
-  DO i = 1, klon
-    IF (todo(i)) THEN
-      k1min = min(k1min, k1(i))
-      k1max = max(k1max, k1(i))
-      k2max = max(k2max, k2(i))
-    END IF
-  END DO
-
-  DO i = 1, klon
-    IF (todo(i)) THEN
-      k = k1(i)
-      za(i) = 0.
-      zb(i) = (rcpd*(1.+zdqs(i,k))*(zt(i,k)-za(i))-rlvtt*(zqs(i,k)-zq(i, &
-        k)))*delp(i, k)
-      zc(i) = delp(i, k)*rcpd*(1.+zdqs(i,k))
-    END IF
-  END DO
-
-  DO k = k1min, k2max
-    DO i = 1, klon
-      IF (todo(i) .AND. k>=(k1(i)+1) .AND. k<=k2(i)) THEN
-        za(i) = za(i) + zgamdz(i, k-1)
-        zb(i) = zb(i) + (rcpd*(1.+zdqs(i,k))*(zt(i,k)-za(i))-rlvtt*(zqs(i, &
-          k)-zq(i,k)))*delp(i, k)
-        zc(i) = zc(i) + delp(i, k)*rcpd*(1.+zdqs(i,k))
-      END IF
-    END DO
-  END DO
-
-  DO i = 1, klon
-    IF (todo(i)) THEN
-      k = k1(i)
-      ztnew(i, k) = zb(i)/zc(i)
-      zqnew(i, k) = zqs(i, k) + (ztnew(i,k)-zt(i,k))*rcpd/rlvtt*zdqs(i, k)
-    END IF
-  END DO
-
-  DO k = k1min, k2max
-    DO i = 1, klon
-      IF (todo(i) .AND. k>=(k1(i)+1) .AND. k<=k2(i)) THEN
-        ztnew(i, k) = ztnew(i, k-1) + zgamdz(i, k-1)
-        zqnew(i, k) = zqs(i, k) + (ztnew(i,k)-zt(i,k))*rcpd/rlvtt*zdqs(i, k)
-      END IF
-    END DO
-  END DO
-
-  ! Quantite de condensation produite pendant l'ajustement:
-
-  DO i = 1, klon
-    zcond(i) = 0.0
-  END DO
-  DO k = k1min, k2max
-    DO i = 1, klon
-      IF (todo(i) .AND. k>=k1(i) .AND. k<=k2(i)) THEN
-        rneb(i, k) = 1.0
-        zcond(i) = zcond(i) + (zq(i,k)-zqnew(i,k))*delp(i, k)/rg
-      END IF
-    END DO
-  END DO
-
-  ! Si condensation negative, effort completement perdu:
-
-  DO i = 1, klon
-    IF (todo(i) .AND. zcond(i)<=0.) todo(i) = .FALSE.
-  END DO
-
-  ! L'ajustement a ete accompli, meme les calculs accessoires
-  ! ne sont pas encore faits:
-
-  DO i = 1, klon
-    IF (todo(i)) accompli(i) = .TRUE.
-  END DO
-
-  ! =====
-  ! Une fois que la condensation a lieu, on doit construire un
-  ! "modele nuageux" pour partager la condensation entre l'eau
-  ! liquide nuageuse et la precipitation (leur rapport toliq
-  ! est calcule selon l'epaisseur nuageuse). Je suppose que
-  ! toliq=tomax quand l'epaisseur nuageuse est inferieure a dpmin,
-  ! et que toliq=tomin quand l'epaisseur depasse dpmax (interpolation
-  ! lineaire entre dpmin et dpmax).
-  ! =====
-  DO i = 1, klon
-    IF (todo(i)) THEN
-      toliq(i) = tomax - ((paprs(i,k1(i))-paprs(i,k2(i)+1))/paprs(i,1)-dpmin) &
-        *(tomax-tomin)/(dpmax-dpmin)
-      toliq(i) = max(tomin, min(tomax,toliq(i)))
-      IF (pplay(i,k2(i))/paprs(i,1)<=deep_sig) toliq(i) = deep_to
-      IF (old_tau) toliq(i) = 1.0
-    END IF
-  END DO
-  ! =====
-  ! On doit aussi determiner la distribution verticale de
-  ! l'eau nuageuse. Plusieurs options sont proposees:
-
-  ! (0) La condensation precipite integralement (toliq ne sera
-  ! pas utilise).
-  ! (1) L'eau liquide est distribuee entre k1 et k2 et proportionnelle
-  ! a la vapeur d'eau locale.
-  ! (2) Elle est distribuee entre k1 et k2 avec une valeur constante.
-  ! (3) Elle est seulement distribuee aux couches ou la vapeur d'eau
-  ! est effectivement diminuee pendant le processus d'ajustement.
-  ! (4) Elle est en fonction (lineaire ou exponentielle) de la
-  ! distance (epaisseur en pression) avec le niveau k1 (la couche
-  ! k1 n'aura donc pas d'eau liquide).
-  ! =====
-
-  IF (opt_cld==0) THEN
-
-    DO i = 1, klon
-      IF (todo(i)) zrfl(i) = zcond(i)/dtime
-    END DO
-
-  ELSE IF (opt_cld==1) THEN
-
-    DO i = 1, klon
-      IF (todo(i)) zvapo(i) = 0.0 ! quantite integrale de vapeur d'eau
-    END DO
-    DO k = k1min, k2max
-      DO i = 1, klon
-        IF (todo(i) .AND. k>=k1(i) .AND. k<=k2(i)) zvapo(i) = zvapo(i) + &
-          zqnew(i, k)*delp(i, k)/rg
-      END DO
-    END DO
-    DO i = 1, klon
-      IF (todo(i)) THEN
-        zrapp(i) = toliq(i)*zcond(i)/zvapo(i)
-        zrapp(i) = max(0., min(1.,zrapp(i)))
-        zrfl(i) = (1.0-toliq(i))*zcond(i)/dtime
-      END IF
-    END DO
-    DO k = k1min, k2max
-      DO i = 1, klon
-        IF (todo(i) .AND. k>=k1(i) .AND. k<=k2(i)) THEN
-          d_ql(i, k) = d_ql(i, k) + zrapp(i)*zqnew(i, k)
-        END IF
-      END DO
-    END DO
-
-  ELSE IF (opt_cld==2) THEN
-
-    DO i = 1, klon
-      IF (todo(i)) zvapo(i) = 0.0 ! quantite integrale de masse
-    END DO
-    DO k = k1min, k2max
-      DO i = 1, klon
-        IF (todo(i) .AND. k>=k1(i) .AND. k<=k2(i)) zvapo(i) = zvapo(i) + &
-          delp(i, k)/rg
-      END DO
-    END DO
-    DO k = k1min, k2max
-      DO i = 1, klon
-        IF (todo(i) .AND. k>=k1(i) .AND. k<=k2(i)) THEN
-          d_ql(i, k) = d_ql(i, k) + toliq(i)*zcond(i)/zvapo(i)
-        END IF
-      END DO
-    END DO
-    DO i = 1, klon
-      IF (todo(i)) zrfl(i) = (1.0-toliq(i))*zcond(i)/dtime
-    END DO
-
-  ELSE IF (opt_cld==3) THEN
-
-    DO i = 1, klon
-      IF (todo(i)) zvapo(i) = 0.0 ! quantite de l'eau strictement condensee
-    END DO
-    DO k = k1min, k2max
-      DO i = 1, klon
-        IF (todo(i) .AND. k>=k1(i) .AND. k<=k2(i)) zvapo(i) = zvapo(i) + &
-          max(0.0, zq(i,k)-zqnew(i,k))*delp(i, k)/rg
-      END DO
-    END DO
-    DO k = k1min, k2max
-      DO i = 1, klon
-        IF (todo(i) .AND. k>=k1(i) .AND. k<=k2(i) .AND. zvapo(i)>0.0) d_ql(i, &
-          k) = d_ql(i, k) + toliq(i)*zcond(i)/zvapo(i)*max(0.0, zq(i,k)-zqnew &
-          (i,k))
-      END DO
-    END DO
-    DO i = 1, klon
-      IF (todo(i)) zrfl(i) = (1.0-toliq(i))*zcond(i)/dtime
-    END DO
-
-  ELSE IF (opt_cld==4) THEN
-
-    nexpo = 3
-    ! cc         nexpo = 1 ! distribution lineaire
-
-    DO i = 1, klon
-      IF (todo(i)) zvapo(i) = 0.0 ! quantite integrale de masse
-    END DO ! (avec ponderation)
-    DO k = k1min, k2max
-      DO i = 1, klon
-        IF (todo(i) .AND. k>=(k1(i)+1) .AND. k<=k2(i)) zvapo(i) = zvapo(i) + &
-          delp(i, k)/rg*(pplay(i,k1(i))-pplay(i,k))**nexpo
-      END DO
-    END DO
-    DO k = k1min, k2max
-      DO i = 1, klon
-        IF (todo(i) .AND. k>=(k1(i)+1) .AND. k<=k2(i)) d_ql(i, k) = d_ql(i, &
-          k) + toliq(i)*zcond(i)/zvapo(i)*(pplay(i,k1(i))-pplay(i,k))**nexpo
-      END DO
-    END DO
-    DO i = 1, klon
-      IF (todo(i)) zrfl(i) = (1.0-toliq(i))*zcond(i)/dtime
-    END DO
-
-  ELSE ! valeur non-prevue pour opt_cld
-
-    PRINT *, 'opt_cld est faux:', opt_cld
-    CALL abort
-
-  END IF ! fin de opt_cld
-
-  ! L'eau precipitante peut etre evaporee:
-
-  zalfa = 0.05
-  IF (evap_prec .AND. (k1max>=2)) THEN
-    DO k = k1max - 1, 1, -1
-      DO i = 1, klon
-        IF (todo(i) .AND. k<k1(i) .AND. zrfl(i)>0.0) THEN
-          zqev = max(0.0, (zqs(i,k)-zq(i,k))*zalfa)
-          zqevt = coef_eva*(1.0-zq(i,k)/zqs(i,k))*sqrt(zrfl(i))*delp(i, k)/ &
-            pplay(i, k)*zt(i, k)*rd/rg
-          zqevt = max(0.0, min(zqevt,zrfl(i)))*rg*dtime/delp(i, k)
-          zqev = min(zqev, zqevt)
-          zrfln = zrfl(i) - zqev*(delp(i,k))/rg/dtime
-          zq(i, k) = zq(i, k) - (zrfln-zrfl(i))*(rg/(delp(i,k)))*dtime
-          zt(i, k) = zt(i, k) + (zrfln-zrfl(i))*(rg/(delp(i, &
-            k)))*dtime*rlvtt/rcpd/(1.0+rvtmp2*zq(i,k))
-          zrfl(i) = zrfln
-        END IF
-      END DO
-    END DO
-  END IF
-
-  ! La temperature de la premiere couche determine la pluie ou la neige:
-
-  DO i = 1, klon
-    IF (todo(i)) THEN
-      IF (zt(i,1)>rtt) THEN
-        rain(i) = rain(i) + zrfl(i)
-      ELSE
-        snow(i) = snow(i) + zrfl(i)
-      END IF
-    END IF
-  END DO
-
-  ! Mise a jour de la temperature et de l'humidite
-
-  DO k = k1min, k2max
-    DO i = 1, klon
-      IF (todo(i) .AND. k>=k1(i) .AND. k<=k2(i)) THEN
-        zt(i, k) = ztnew(i, k)
-        zq(i, k) = zqnew(i, k)
-      END IF
-    END DO
-  END DO
-
-  ! Re-calculer certaines variables pour etendre et re-ajuster la colonne
-
-  IF (exigent) THEN
-    DO k = 1, klev
-      DO i = 1, klon
-        IF (todo(i)) THEN
-          IF (thermcep) THEN
-            zdelta = max(0., sign(1.,rtt-zt(i,k)))
-            zcvm5 = r5les*rlvtt*(1.-zdelta) + zdelta*r5ies*rlstt
-            zcvm5 = zcvm5/rcpd/(1.0+rvtmp2*zq(i,k))
-            zqs(i, k) = r2es*foeew(zt(i,k), zdelta)/pplay(i, k)
-            zqs(i, k) = min(0.5, zqs(i,k))
-            zcor = 1./(1.-retv*zqs(i,k))
-            zqs(i, k) = zqs(i, k)*zcor
-            zdqs(i, k) = foede(zt(i,k), zdelta, zcvm5, zqs(i,k), zcor)
-          ELSE
-            IF (zt(i,k)<t_coup) THEN
-              zqs(i, k) = qsats(zt(i,k))/pplay(i, k)
-              zdqs(i, k) = dqsats(zt(i,k), zqs(i,k))
-            ELSE
-              zqs(i, k) = qsatl(zt(i,k))/pplay(i, k)
-              zdqs(i, k) = dqsatl(zt(i,k), zqs(i,k))
-            END IF
-          END IF
-        END IF
-      END DO
-    END DO
-  END IF
-
-  IF (exigent) THEN
-    DO k = 1, klev - 1
-      DO i = 1, klon
-        IF (todo(i)) THEN
-          zgamdz(i, k) = -(pplay(i,k)-pplay(i,k+1))/paprs(i, k+1)/rcpd*(rd*( &
-            zt(i,k)*delp(i,k)+zt(i,k+1)*delp(i,k+1))/(delp(i,k)+delp(i, &
-            k+1))+rlvtt*(zqs(i,k)*delp(i,k)+zqs(i,k+1)*delp(i,k+1))/(delp(i, &
-            k)+delp(i,k+1)))/(1.0+(zdqs(i,k)*delp(i,k)+zdqs(i,k+1)*delp(i, &
-            k+1))/(delp(i,k)+delp(i,k+1)))
-        END IF
-      END DO
-    END DO
-  END IF
-
-  ! Puisque l'humidite a ete modifiee, on re-fait (q-qs)*dp
-
-  DO k = 1, klev
-    DO i = 1, klon
-      IF (todo(i)) THEN
-        zqmqsdp(i, k) = (zq(i,k)-zqs(i,k))*delp(i, k)
-      END IF
-    END DO
-  END DO
-
-  ! Verifier si l'on peut etendre le bas de la colonne
-
-  DO i = 1, klon
-    etendre(i) = .FALSE.
-  END DO
-
-  k1max = 1
-  DO i = 1, klon
-    IF (todo(i) .AND. k1(i)>(kbase+1)) THEN
-      k = k1(i)
-      zflo(i) = zt(i, k-1) + zgamdz(i, k-1) - zt(i, k)
-      zsat(i) = zqmqsdp(i, k) + zqmqsdp(i, k-1)
-      ! sc voici l'ancienne ligne:
-      ! sc         IF (zflo(i).LE.0.0 .OR. zsat(i).LE.0.0) THEN
-      ! sc sylvain: il faut RESPECTER les 2 criteres:
-      IF (zflo(i)>0.0 .AND. zsat(i)>0.0) THEN
-        etendre(i) = .TRUE.
-        k1(i) = k1(i) - 1
-        k1max = max(k1max, k1(i))
-        aller(i) = .TRUE.
-      END IF
-    END IF
-  END DO
-
-  IF (k1max>(kbase+1)) THEN
-    DO k = k1max, kbase + 1, -1
-      DO i = 1, klon
-        IF (etendre(i) .AND. k<k1(i) .AND. aller(i)) THEN
-          zsat(i) = zsat(i) + zqmqsdp(i, k)
-          zflo(i) = zt(i, k) + zgamdz(i, k) - zt(i, k+1)
-          IF (zsat(i)<=0.0 .OR. zflo(i)<=0.0) THEN
-            aller(i) = .FALSE.
-          ELSE
-            k1(i) = k
-          END IF
-        END IF
-      END DO
-    END DO
-    DO i = 1, klon
-      IF (etendre(i) .AND. aller(i)) THEN
-        k1(i) = 1
-      END IF
-    END DO
-  END IF
-
-  ! CC      DO i = 1, klon
-  ! CC      IF (etendre(i)) THEN
-  ! CC  840    k = k1(i)
-  ! CC         IF (k.GT.1) THEN
-  ! CC            zsat(i) = zsat(i) + zqmqsdp(i,k-1)
-  ! CC            zflo(i) = zt(i,k-1) + zgamdz(i,k-1) - zt(i,k)
-  ! CC            IF (zflo(i).GT.0.0 .AND. zsat(i).GT.0.0) THEN
-  ! CC               k1(i) = k - 1
-  ! CC               GOTO 840
-  ! CC            ENDIF
-  ! CC         ENDIF
-  ! CC      ENDIF
-  ! CC      ENDDO
-
-  DO i = 1, klon
-    todobis(i) = todo(i)
-    todo(i) = .FALSE.
-  END DO
-  is = 0
-  DO i = 1, klon
-    IF (etendre(i)) THEN
-      todo(i) = .TRUE.
-      is = is + 1
-    END IF
-  END DO
-  IF (is>0) THEN
-    IF (new_top) THEN
-      GO TO 820 ! chercher de nouveau le sommet k2
-    ELSE
-      GO TO 830 ! supposer que le sommet est celui deja trouve
-    END IF
-  END IF
-
-  DO i = 1, klon
-    possible(i) = .FALSE.
-  END DO
-  is = 0
-  DO i = 1, klon
-    IF (todobis(i) .AND. k2(i)<klev) THEN
-      is = is + 1
-      possible(i) = .TRUE.
-    END IF
-  END DO
-  IF (is>0) GO TO 810 !on cherche en haut d'autres blocks
-  ! a ajuster a partir du sommet de la colonne precedente
-
-860 CONTINUE ! Calculer les tendances et diagnostiques
-  ! cc      print*, "Apres 860"
-
-  DO k = 1, klev
-    DO i = 1, klon
-      IF (accompli(i)) THEN
-        d_t(i, k) = zt(i, k) - t(i, k)
-        zq(i, k) = max(zq(i,k), seuil_vap)
-        d_q(i, k) = zq(i, k) - q(i, k)
-      END IF
-    END DO
-  END DO
-
-  DO i = 1, klon
-    IF (accompli(i)) THEN
-      DO k = 1, klev
-        IF (rneb(i,k)>0.0) THEN
-          ibas(i) = k
-          GO TO 807
-        END IF
-      END DO
-807   CONTINUE
-      DO k = klev, 1, -1
-        IF (rneb(i,k)>0.0) THEN
-          itop(i) = k
-          GO TO 808
-        END IF
-      END DO
-808   CONTINUE
-    END IF
-  END DO
-
-  IF (imprim) THEN
-    nbtodo = 0
-    nbdone = 0
-    DO i = 1, klon
-      IF (afaire(i)) nbtodo = nbtodo + 1
-      IF (accompli(i)) nbdone = nbdone + 1
-    END DO
-    PRINT *, 'nbTodo, nbDone=', nbtodo, nbdone
-  END IF
-
-  RETURN
-END SUBROUTINE conmanv
-SUBROUTINE conkuo(dtime, paprs, pplay, t, q, conv_q, d_t, d_q, d_ql, rneb, &
-    rain, snow, ibas, itop)
-  USE dimphy
-  IMPLICIT NONE
-  ! ======================================================================
-  ! Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818
-  ! Objet: Schema de convection de type Kuo (1965).
-  ! Cette version du code peut calculer le niveau de depart
-  ! N.B. version vectorielle (le 6 oct. 1997)
-  ! ======================================================================
-  include "YOMCST.h"
-
-  ! Arguments:
-
-  REAL dtime ! intervalle du temps (s)
-  REAL paprs(klon, klev+1) ! pression a inter-couche (Pa)
-  REAL pplay(klon, klev) ! pression au milieu de couche (Pa)
-  REAL t(klon, klev) ! temperature (K)
-  REAL q(klon, klev) ! humidite specifique
-  REAL conv_q(klon, klev) ! taux de convergence humidite (g/g/s)
-
-  REAL d_t(klon, klev) ! incrementation temperature
-  REAL d_q(klon, klev) ! incrementation humidite
-  REAL d_ql(klon, klev) ! incrementation eau liquide
-  REAL rneb(klon, klev) ! nebulosite
-  REAL rain(klon) ! pluies (mm/s)
-  REAL snow(klon) ! neige (mm/s)
-  INTEGER itop(klon) ! niveau du sommet
-  INTEGER ibas(klon) ! niveau du bas
-
-  LOGICAL ldcum(klon) ! convection existe
-  LOGICAL todo(klon)
-
-  ! Quelsques options:
-
-  LOGICAL calcfcl ! calculer le niveau de convection libre
-  PARAMETER (calcfcl=.TRUE.)
-  INTEGER ldepar ! niveau fixe de convection libre
-  PARAMETER (ldepar=4)
-  INTEGER opt_cld ! comment traiter l'eau liquide
-  PARAMETER (opt_cld=4) ! valeur possible: 0, 1, 2, 3 ou 4
-  LOGICAL evap_prec ! evaporation de pluie au-dessous de convection
-  PARAMETER (evap_prec=.TRUE.)
-  REAL coef_eva
-  PARAMETER (coef_eva=1.0E-05)
-  LOGICAL new_deh ! nouvelle facon de calculer dH
-  PARAMETER (new_deh=.FALSE.)
-  REAL t_coup
-  PARAMETER (t_coup=234.0)
-  LOGICAL old_tau ! implique precipitation nulle
-  PARAMETER (old_tau=.FALSE.)
-  REAL toliq(klon) ! rapport entre l'eau nuageuse et l'eau precipitante
-  REAL dpmin, tomax !Epaisseur faible, rapport eau liquide plus grande
-  PARAMETER (dpmin=0.15, tomax=0.97)
-  REAL dpmax, tomin !Epaisseur grande, rapport eau liquide plus faible
-  PARAMETER (dpmax=0.30, tomin=0.05)
-  REAL deep_sig, deep_to ! au dela de deep_sig, utiliser deep_to
-  PARAMETER (deep_sig=0.50, deep_to=0.05)
-
-  ! Variables locales:
-
-  INTEGER nexpo
-  LOGICAL nuage(klon)
-  INTEGER i, k, kbmin, kbmax, khmax
-  REAL ztotal(klon, klev), zdeh(klon, klev)
-  REAL zgz(klon, klev)
-  REAL zqs(klon, klev)
-  REAL zdqs(klon, klev)
-  REAL ztemp(klon, klev)
-  REAL zpres(klon, klev)
-  REAL zconv(klon) ! convergence d'humidite
-  REAL zvirt(klon) ! convergence virtuelle d'humidite
-  REAL zfrac(klon) ! fraction convective
-  INTEGER kb(klon), kh(klon)
-
-  REAL zcond(klon), zvapo(klon), zrapp(klon)
-  REAL zrfl(klon), zrfln, zqev, zqevt
-  REAL zdelta, zcvm5, zcor
-  REAL zvar
-
-  LOGICAL appel1er
-  SAVE appel1er
-  !$OMP THREADPRIVATE(appel1er)
-
-  ! Fonctions thermodynamiques
-
-  include "YOETHF.h"
-  include "FCTTRE.h"
-
-  DATA appel1er/.TRUE./
-
-  IF (appel1er) THEN
-    PRINT *, 'conkuo, calcfcl:', calcfcl
-    IF (.NOT. calcfcl) PRINT *, 'conkuo, ldepar:', ldepar
-    PRINT *, 'conkuo, opt_cld:', opt_cld
-    PRINT *, 'conkuo, evap_prec:', evap_prec
-    PRINT *, 'conkuo, new_deh:', new_deh
-    appel1er = .FALSE.
-  END IF
-
-  ! Initialiser les sorties a zero
-
-  DO k = 1, klev
-    DO i = 1, klon
-      d_q(i, k) = 0.0
-      d_t(i, k) = 0.0
-      d_ql(i, k) = 0.0
-      rneb(i, k) = 0.0
-    END DO
-  END DO
-  DO i = 1, klon
-    rain(i) = 0.0
-    snow(i) = 0.0
-    ibas(i) = 0
-    itop(i) = 0
-  END DO
-
-  ! Calculer la vapeur d'eau saturante Qs et sa derive L/Cp * dQs/dT
-
-  DO k = 1, klev
-    DO i = 1, klon
-      IF (thermcep) THEN
-        zdelta = max(0., sign(1.,rtt-t(i,k)))
-        zcvm5 = r5les*rlvtt*(1.-zdelta) + zdelta*r5ies*rlstt
-        zcvm5 = zcvm5/rcpd/(1.0+rvtmp2*q(i,k))
-        zqs(i, k) = r2es*foeew(t(i,k), zdelta)/pplay(i, k)
-        zqs(i, k) = min(0.5, zqs(i,k))
-        zcor = 1./(1.-retv*zqs(i,k))
-        zqs(i, k) = zqs(i, k)*zcor
-        zdqs(i, k) = foede(t(i,k), zdelta, zcvm5, zqs(i,k), zcor)
-      ELSE
-        IF (t(i,k)<t_coup) THEN
-          zqs(i, k) = qsats(t(i,k))/pplay(i, k)
-          zdqs(i, k) = dqsats(t(i,k), zqs(i,k))
-        ELSE
-          zqs(i, k) = qsatl(t(i,k))/pplay(i, k)
-          zdqs(i, k) = dqsatl(t(i,k), zqs(i,k))
-        END IF
-      END IF
-    END DO
-  END DO
-
-  ! Calculer gz (energie potentielle)
-
-  DO i = 1, klon
-    zgz(i, 1) = rd*t(i, 1)/(0.5*(paprs(i,1)+pplay(i, &
-      1)))*(paprs(i,1)-pplay(i,1))
-  END DO
-  DO k = 2, klev
-    DO i = 1, klon
-      zgz(i, k) = zgz(i, k-1) + rd*0.5*(t(i,k-1)+t(i,k))/paprs(i, k)*(pplay(i &
-        ,k-1)-pplay(i,k))
-    END DO
-  END DO
-
-  ! Calculer l'energie statique humide saturee (Cp*T + gz + L*Qs)
-
-  DO k = 1, klev
-    DO i = 1, klon
-      ztotal(i, k) = rcpd*t(i, k) + rlvtt*zqs(i, k) + zgz(i, k)
-    END DO
-  END DO
-
-  ! Determiner le niveau de depart et calculer la difference de
-  ! l'energie statique humide saturee (ztotal) entre la couche
-  ! de depart et chaque couche au-dessus.
-
-  IF (calcfcl) THEN
-    DO k = 1, klev
-      DO i = 1, klon
-        zpres(i, k) = pplay(i, k)
-        ztemp(i, k) = t(i, k)
-      END DO
-    END DO
-    CALL kuofcl(ztemp, q, zgz, zpres, ldcum, kb)
-    DO i = 1, klon
-      IF (ldcum(i)) THEN
-        k = kb(i)
-        IF (new_deh) THEN
-          zdeh(i, k) = ztotal(i, k-1) - ztotal(i, k)
-        ELSE
-          zdeh(i, k) = rcpd*(t(i,k-1)-t(i,k)) - rd*0.5*(t(i,k-1)+t(i,k))/ &
-            paprs(i, k)*(pplay(i,k-1)-pplay(i,k)) + &
-            rlvtt*(zqs(i,k-1)-zqs(i,k))
-        END IF
-        zdeh(i, k) = zdeh(i, k)*0.5
-      END IF
-    END DO
-    DO k = 1, klev
-      DO i = 1, klon
-        IF (ldcum(i) .AND. k>=(kb(i)+1)) THEN
-          IF (new_deh) THEN
-            zdeh(i, k) = zdeh(i, k-1) + (ztotal(i,k-1)-ztotal(i,k))
-          ELSE
-            zdeh(i, k) = zdeh(i, k-1) + rcpd*(t(i,k-1)-t(i,k)) - &
-              rd*0.5*(t(i,k-1)+t(i,k))/paprs(i, k)* &
-              (pplay(i,k-1)-pplay(i,k)) + rlvtt*(zqs(i,k-1)-zqs(i,k))
-          END IF
-        END IF
-      END DO
-    END DO
-  ELSE
-    DO i = 1, klon
-      k = ldepar
-      kb(i) = ldepar
-      ldcum(i) = .TRUE.
-      IF (new_deh) THEN
-        zdeh(i, k) = ztotal(i, k-1) - ztotal(i, k)
-      ELSE
-        zdeh(i, k) = rcpd*(t(i,k-1)-t(i,k)) - rd*0.5*(t(i,k-1)+t(i,k))/paprs( &
-          i, k)*(pplay(i,k-1)-pplay(i,k)) + rlvtt*(zqs(i,k-1)-zqs(i,k))
-      END IF
-      zdeh(i, k) = zdeh(i, k)*0.5
-    END DO
-    DO k = ldepar + 1, klev
-      DO i = 1, klon
-        IF (new_deh) THEN
-          zdeh(i, k) = zdeh(i, k-1) + (ztotal(i,k-1)-ztotal(i,k))
-        ELSE
-          zdeh(i, k) = zdeh(i, k-1) + rcpd*(t(i,k-1)-t(i,k)) - &
-            rd*0.5*(t(i,k-1)+t(i,k))/paprs(i, k)*(pplay(i,k-1)-pplay(i,k)) + &
-            rlvtt*(zqs(i,k-1)-zqs(i,k))
-        END IF
-      END DO
-    END DO
-  END IF
-
-  ! -----Chercher le sommet du nuage
-  ! -----Calculer la convergence de l'humidite (en kg/m**2 a un facteur
-  ! -----psolpa/RG pres) du bas jusqu'au sommet du nuage.
-  ! -----Calculer la convergence virtuelle pour que toute la maille
-  ! -----deviennt nuageuse (du bas jusqu'au sommet du nuage)
-
-  DO i = 1, klon
-    nuage(i) = .TRUE.
-    zconv(i) = 0.0
-    zvirt(i) = 0.0
-    kh(i) = -999
-  END DO
-  DO k = 1, klev
-    DO i = 1, klon
-      IF (k>=kb(i) .AND. ldcum(i)) THEN
-        nuage(i) = nuage(i) .AND. zdeh(i, k) > 0.0
-        IF (nuage(i)) THEN
-          kh(i) = k
-          zconv(i) = zconv(i) + conv_q(i, k)*dtime*(paprs(i,k)-paprs(i,k+1))
-          zvirt(i) = zvirt(i) + (zdeh(i,k)/rlvtt+zqs(i,k)-q(i,k))*(paprs(i,k) &
-            -paprs(i,k+1))
-        END IF
-      END IF
-    END DO
-  END DO
-
-  DO i = 1, klon
-    todo(i) = ldcum(i) .AND. kh(i) > kb(i) .AND. zconv(i) > 0.0
-  END DO
-
-  kbmin = klev
-  kbmax = 0
-  khmax = 0
-  DO i = 1, klon
-    IF (todo(i)) THEN
-      kbmin = min(kbmin, kb(i))
-      kbmax = max(kbmax, kb(i))
-      khmax = max(khmax, kh(i))
-    END IF
-  END DO
-
-  ! -----Calculer la surface couverte par le nuage
-
-  DO i = 1, klon
-    IF (todo(i)) THEN
-      zfrac(i) = max(0.0, min(zconv(i)/zvirt(i),1.0))
-    END IF
-  END DO
-
-  ! -----Calculs essentiels:
-
-  DO i = 1, klon
-    IF (todo(i)) THEN
-      zcond(i) = 0.0
-    END IF
-  END DO
-  DO k = kbmin, khmax
-    DO i = 1, klon
-      IF (todo(i) .AND. k>=kb(i) .AND. k<=kh(i)) THEN
-        zvar = zdeh(i, k)/(1.+zdqs(i,k))
-        d_t(i, k) = zvar*zfrac(i)/rcpd
-        d_q(i, k) = (zvar*zdqs(i,k)/rlvtt+zqs(i,k)-q(i,k))*zfrac(i) - &
-          conv_q(i, k)*dtime
-        zcond(i) = zcond(i) - d_q(i, k)*(paprs(i,k)-paprs(i,k+1))/rg
-        rneb(i, k) = zfrac(i)
-      END IF
-    END DO
-  END DO
-
-  DO i = 1, klon
-    IF (todo(i) .AND. zcond(i)<0.0) THEN
-      PRINT *, 'WARNING: cond. negative (Kuo) ', i, kb(i), kh(i), zcond(i)
-      zcond(i) = 0.0
-      DO k = kb(i), kh(i)
-        d_t(i, k) = 0.0
-        d_q(i, k) = 0.0
-      END DO
-      todo(i) = .FALSE. ! effort totalement perdu
-    END IF
-  END DO
-
-  ! =====
-  ! Une fois que la condensation a lieu, on doit construire un
-  ! "modele nuageux" pour partager la condensation entre l'eau
-  ! liquide nuageuse et la precipitation (leur rapport toliq
-  ! est calcule selon l'epaisseur nuageuse). Je suppose que
-  ! toliq=tomax quand l'epaisseur nuageuse est inferieure a dpmin,
-  ! et que toliq=tomin quand l'epaisseur depasse dpmax (interpolation
-  ! lineaire entre dpmin et dpmax).
-  ! =====
-  DO i = 1, klon
-    IF (todo(i)) THEN
-      toliq(i) = tomax - ((paprs(i,kb(i))-paprs(i,kh(i)+1))/paprs(i,1)-dpmin) &
-        *(tomax-tomin)/(dpmax-dpmin)
-      toliq(i) = max(tomin, min(tomax,toliq(i)))
-      IF (pplay(i,kh(i))/paprs(i,1)<=deep_sig) toliq(i) = deep_to
-      IF (old_tau) toliq(i) = 1.0
-    END IF
-  END DO
-  ! =====
-  ! On doit aussi determiner la distribution verticale de
-  ! l'eau nuageuse. Plusieurs options sont proposees:
-
-  ! (0) La condensation precipite integralement (toliq ne sera
-  ! pas utilise).
-  ! (1) L'eau liquide est distribuee entre k1 et k2 et proportionnelle
-  ! a la vapeur d'eau locale.
-  ! (2) Elle est distribuee entre k1 et k2 avec une valeur constante.
-  ! (3) Elle est seulement distribuee aux couches ou la vapeur d'eau
-  ! est effectivement diminuee pendant le processus d'ajustement.
-  ! (4) Elle est en fonction (lineaire ou exponentielle) de la
-  ! distance (epaisseur en pression) avec le niveau k1 (la couche
-  ! k1 n'aura donc pas d'eau liquide).
-  ! =====
-
-  IF (opt_cld==0) THEN
-
-    DO i = 1, klon
-      IF (todo(i)) zrfl(i) = zcond(i)/dtime
-    END DO
-
-  ELSE IF (opt_cld==1) THEN
-
-    DO i = 1, klon
-      IF (todo(i)) zvapo(i) = 0.0 ! quantite integrale de vapeur d'eau
-    END DO
-    DO k = kbmin, khmax
-      DO i = 1, klon
-        IF (todo(i) .AND. k>=kb(i) .AND. k<=kh(i)) THEN
-          zvapo(i) = zvapo(i) + (q(i,k)+d_q(i,k))*(paprs(i,k)-paprs(i,k+1))/ &
-            rg
-        END IF
-      END DO
-    END DO
-    DO i = 1, klon
-      IF (todo(i)) THEN
-        zrapp(i) = toliq(i)*zcond(i)/zvapo(i)
-        zrapp(i) = max(0., min(1.,zrapp(i)))
-      END IF
-    END DO
-    DO k = kbmin, khmax
-      DO i = 1, klon
-        IF (todo(i) .AND. k>=kb(i) .AND. k<=kh(i)) THEN
-          d_ql(i, k) = zrapp(i)*(q(i,k)+d_q(i,k))
-        END IF
-      END DO
-    END DO
-    DO i = 1, klon
-      IF (todo(i)) THEN
-        zrfl(i) = (1.0-toliq(i))*zcond(i)/dtime
-      END IF
-    END DO
-
-  ELSE IF (opt_cld==2) THEN
-
-    DO i = 1, klon
-      IF (todo(i)) zvapo(i) = 0.0 ! quantite integrale de masse
-    END DO
-    DO k = kbmin, khmax
-      DO i = 1, klon
-        IF (todo(i) .AND. k>=kb(i) .AND. k<=kh(i)) THEN
-          zvapo(i) = zvapo(i) + (paprs(i,k)-paprs(i,k+1))/rg
-        END IF
-      END DO
-    END DO
-    DO k = kbmin, khmax
-      DO i = 1, klon
-        IF (todo(i) .AND. k>=kb(i) .AND. k<=kh(i)) THEN
-          d_ql(i, k) = toliq(i)*zcond(i)/zvapo(i)
-        END IF
-      END DO
-    END DO
-    DO i = 1, klon
-      IF (todo(i)) THEN
-        zrfl(i) = (1.0-toliq(i))*zcond(i)/dtime
-      END IF
-    END DO
-
-  ELSE IF (opt_cld==3) THEN
-
-    DO i = 1, klon
-      IF (todo(i)) THEN
-        zvapo(i) = 0.0 ! quantite de l'eau strictement condensee
-      END IF
-    END DO
-    DO k = kbmin, khmax
-      DO i = 1, klon
-        IF (todo(i) .AND. k>=kb(i) .AND. k<=kh(i)) THEN
-          zvapo(i) = zvapo(i) + max(0.0, -d_q(i,k))*(paprs(i,k)-paprs(i,k+1)) &
-            /rg
-        END IF
-      END DO
-    END DO
-    DO k = kbmin, khmax
-      DO i = 1, klon
-        IF (todo(i) .AND. k>=kb(i) .AND. k<=kh(i) .AND. zvapo(i)>0.0) THEN
-          d_ql(i, k) = d_ql(i, k) + toliq(i)*zcond(i)/zvapo(i)*max(0.0, -d_q( &
-            i,k))
-        END IF
-      END DO
-    END DO
-    DO i = 1, klon
-      IF (todo(i)) THEN
-        zrfl(i) = (1.0-toliq(i))*zcond(i)/dtime
-      END IF
-    END DO
-
-  ELSE IF (opt_cld==4) THEN
-
-    nexpo = 3
-    ! cc         nexpo = 1 ! distribution lineaire
-
-    DO i = 1, klon
-      IF (todo(i)) THEN
-        zvapo(i) = 0.0 ! quantite integrale de masse (avec ponderation)
-      END IF
-    END DO
-    DO k = kbmin, khmax
-      DO i = 1, klon
-        IF (todo(i) .AND. k>=(kb(i)+1) .AND. k<=kh(i)) THEN
-          zvapo(i) = zvapo(i) + (paprs(i,k)-paprs(i,k+1))/rg*(pplay(i,kb(i))- &
-            pplay(i,k))**nexpo
-        END IF
-      END DO
-    END DO
-    DO k = kbmin, khmax
-      DO i = 1, klon
-        IF (todo(i) .AND. k>=(kb(i)+1) .AND. k<=kh(i)) THEN
-          d_ql(i, k) = d_ql(i, k) + toliq(i)*zcond(i)/zvapo(i)*(pplay(i,kb(i) &
-            )-pplay(i,k))**nexpo
-        END IF
-      END DO
-    END DO
-    DO i = 1, klon
-      IF (todo(i)) THEN
-        zrfl(i) = (1.0-toliq(i))*zcond(i)/dtime
-      END IF
-    END DO
-
-  ELSE ! valeur non-prevue pour opt_cld
-
-    PRINT *, 'opt_cld est faux:', opt_cld
-    CALL abort
-
-  END IF ! fin de opt_cld
-
-  ! L'eau precipitante peut etre re-evaporee:
-
-  IF (evap_prec .AND. kbmax>=2) THEN
-    DO k = kbmax, 1, -1
-      DO i = 1, klon
-        IF (todo(i) .AND. k<=(kb(i)-1) .AND. zrfl(i)>0.0) THEN
-          zqev = max(0.0, (zqs(i,k)-q(i,k))*zfrac(i))
-          zqevt = coef_eva*(1.0-q(i,k)/zqs(i,k))*sqrt(zrfl(i))* &
-            (paprs(i,k)-paprs(i,k+1))/pplay(i, k)*t(i, k)*rd/rg
-          zqevt = max(0.0, min(zqevt,zrfl(i)))*rg*dtime/ &
-            (paprs(i,k)-paprs(i,k+1))
-          zqev = min(zqev, zqevt)
-          zrfln = zrfl(i) - zqev*(paprs(i,k)-paprs(i,k+1))/rg/dtime
-          d_q(i, k) = -(zrfln-zrfl(i))*(rg/(paprs(i,k)-paprs(i,k+1)))*dtime
-          d_t(i, k) = (zrfln-zrfl(i))*(rg/(paprs(i,k)-paprs(i, &
-            k+1)))*dtime*rlvtt/rcpd
-          zrfl(i) = zrfln
-        END IF
-      END DO
-    END DO
-  END IF
-
-  ! La temperature de la premiere couche determine la pluie ou la neige:
-
-  DO i = 1, klon
-    IF (todo(i)) THEN
-      IF (t(i,1)>rtt) THEN
-        rain(i) = rain(i) + zrfl(i)
-      ELSE
-        snow(i) = snow(i) + zrfl(i)
-      END IF
-    END IF
-  END DO
-
-  RETURN
-END SUBROUTINE conkuo
-SUBROUTINE kuofcl(pt, pq, pg, pp, ldcum, kcbot)
-  USE dimphy
-  IMPLICIT NONE
-  ! ======================================================================
-  ! Auteur(s): Z.X. Li (LMD/CNRS) date: 19940927
-  ! adaptation du code de Tiedtke du ECMWF
-  ! Objet: calculer le niveau de convection libre
-  ! (FCL: Free Convection Level)
-  ! ======================================================================
-  ! Arguments:
-  ! pt---input-R- temperature (K)
-  ! pq---input-R- vapeur d'eau (kg/kg)
-  ! pg---input-R- geopotentiel (g*z ou z est en metre)
-  ! pp---input-R- pression (Pa)
-
-  ! LDCUM---output-L- Y-t-il la convection
-  ! kcbot---output-I- Niveau du bas de la convection
-  ! ======================================================================
-  include "YOMCST.h"
-  include "YOETHF.h"
-
-  REAL pt(klon, klev), pq(klon, klev), pg(klon, klev), pp(klon, klev)
-  INTEGER kcbot(klon)
-  LOGICAL ldcum(klon)
-
-  REAL ztu(klon, klev), zqu(klon, klev), zlu(klon, klev)
-  REAL zqold(klon), zbuo
-  INTEGER is, i, k
-
-  ! klab=1: on est sous le nuage convectif
-  ! klab=2: le bas du nuage convectif
-  ! klab=0: autres couches
-  INTEGER klab(klon, klev)
-
-  ! quand lflag=.true., on est sous le nuage, il faut donc appliquer
-  ! le processus d'elevation.
-  LOGICAL lflag(klon)
-
-  DO k = 1, klev
-    DO i = 1, klon
-      ztu(i, k) = pt(i, k)
-      zqu(i, k) = pq(i, k)
-      zlu(i, k) = 0.0
-      klab(i, k) = 0
-    END DO
-  END DO
-  ! ----------------------------------------------------------------------
-  DO i = 1, klon
-    klab(i, 1) = 1
-    kcbot(i) = 2
-    ldcum(i) = .FALSE.
-  END DO
-
-  DO k = 2, klev - 1
-
-    is = 0
-    DO i = 1, klon
-      IF (klab(i,k-1)==1) is = is + 1
-      lflag(i) = .FALSE.
-      IF (klab(i,k-1)==1) lflag(i) = .TRUE.
-    END DO
-    IF (is==0) GO TO 290
-
-    ! on eleve le parcel d'air selon l'adiabatique sec
-
-    DO i = 1, klon
-      IF (lflag(i)) THEN
-        zqu(i, k) = zqu(i, k-1)
-        ztu(i, k) = ztu(i, k-1) + (pg(i,k-1)-pg(i,k))/rcpd
-        zbuo = ztu(i, k)*(1.+retv*zqu(i,k)) - pt(i, k)*(1.+retv*pq(i,k)) + &
-          0.5
-        IF (zbuo>0.) klab(i, k) = 1
-        zqold(i) = zqu(i, k)
-      END IF
-    END DO
-
-    ! on calcule la condensation eventuelle
-
-    CALL adjtq(pp(1,k), ztu(1,k), zqu(1,k), lflag, 1)
-
-    ! s'il y a la condensation et la "buoyancy" force est positive
-    ! c'est bien le bas de la tour de convection
-
-    DO i = 1, klon
-      IF (lflag(i) .AND. zqu(i,k)/=zqold(i)) THEN
-        klab(i, k) = 2
-        zlu(i, k) = zlu(i, k) + zqold(i) - zqu(i, k)
-        zbuo = ztu(i, k)*(1.+retv*zqu(i,k)) - pt(i, k)*(1.+retv*pq(i,k)) + &
-          0.5
-        IF (zbuo>0.) THEN
-          kcbot(i) = k
-          ldcum(i) = .TRUE.
-        END IF
-      END IF
-    END DO
-
-290 END DO
-
-  RETURN
-END SUBROUTINE kuofcl
-SUBROUTINE adjtq(pp, pt, pq, ldflag, kcall)
-  USE dimphy
-  IMPLICIT NONE
-  ! ======================================================================
-  ! Auteur(s): Z.X. Li (LMD/CNRS) date: 19940927
-  ! adaptation du code de Tiedtke du ECMWF
-  ! Objet: ajustement entre T et Q
-  ! ======================================================================
-  ! Arguments:
-  ! pp---input-R- pression (Pa)
-  ! pt---input/output-R- temperature (K)
-  ! pq---input/output-R- vapeur d'eau (kg/kg)
-  ! ======================================================================
-  ! TO PRODUCE T,Q AND L VALUES FOR CLOUD ASCENT
-
-  ! NOTE: INPUT PARAMETER KCALL DEFINES CALCULATION AS
-  ! KCALL=0    ENV. T AND QS IN*CUINI*
-  ! KCALL=1  CONDENSATION IN UPDRAFTS  (E.G. CUBASE, CUASC)
-  ! KCALL=2  EVAPORATION IN DOWNDRAFTS (E.G. CUDLFS,CUDDRAF)
-
-  include "YOMCST.h"
-
-  REAL pt(klon), pq(klon), pp(klon)
-  LOGICAL ldflag(klon)
-  INTEGER kcall
-
-  REAL t_coup
-  PARAMETER (t_coup=234.0)
-
-  REAL zcond(klon), zcond1
-  REAL zdelta, zcvm5, zldcp, zqsat, zcor, zdqsat
-  INTEGER is, i
-  include "YOETHF.h"
-  include "FCTTRE.h"
-
-  DO i = 1, klon
-    zcond(i) = 0.0
-  END DO
-
-  DO i = 1, klon
-    IF (ldflag(i)) THEN
-      zdelta = max(0., sign(1.,rtt-pt(i)))
-      zldcp = rlvtt*(1.-zdelta) + zdelta*rlstt
-      zldcp = zldcp/rcpd/(1.0+rvtmp2*pq(i))
-      IF (thermcep) THEN
-        zcvm5 = r5les*rlvtt*(1.-zdelta) + zdelta*r5ies*rlstt
-        zcvm5 = zcvm5/rcpd/(1.0+rvtmp2*pq(i))
-        zqsat = r2es*foeew(pt(i), zdelta)/pp(i)
-        zqsat = min(0.5, zqsat)
-        zcor = 1./(1.-retv*zqsat)
-        zqsat = zqsat*zcor
-        zdqsat = foede(pt(i), zdelta, zcvm5, zqsat, zcor)
-      ELSE
-        IF (pt(i)<t_coup) THEN
-          zqsat = qsats(pt(i))/pp(i)
-          zdqsat = dqsats(pt(i), zqsat)
-        ELSE
-          zqsat = qsatl(pt(i))/pp(i)
-          zdqsat = dqsatl(pt(i), zqsat)
-        END IF
-      END IF
-      zcond(i) = (pq(i)-zqsat)/(1.+zdqsat)
-      IF (kcall==1) zcond(i) = max(zcond(i), 0.)
-      IF (kcall==2) zcond(i) = min(zcond(i), 0.)
-      pt(i) = pt(i) + zldcp*zcond(i)
-      pq(i) = pq(i) - zcond(i)
-    END IF
-  END DO
-
-  is = 0
-  DO i = 1, klon
-    IF (zcond(i)/=0.) is = is + 1
-  END DO
-  IF (is==0) GO TO 230
-
-  DO i = 1, klon
-    IF (ldflag(i) .AND. zcond(i)/=0.) THEN
-      zdelta = max(0., sign(1.,rtt-pt(i)))
-      zldcp = rlvtt*(1.-zdelta) + zdelta*rlstt
-      zldcp = zldcp/rcpd/(1.0+rvtmp2*pq(i))
-      IF (thermcep) THEN
-        zcvm5 = r5les*rlvtt*(1.-zdelta) + zdelta*r5ies*rlstt
-        zcvm5 = zcvm5/rcpd/(1.0+rvtmp2*pq(i))
-        zqsat = r2es*foeew(pt(i), zdelta)/pp(i)
-        zqsat = min(0.5, zqsat)
-        zcor = 1./(1.-retv*zqsat)
-        zqsat = zqsat*zcor
-        zdqsat = foede(pt(i), zdelta, zcvm5, zqsat, zcor)
-      ELSE
-        IF (pt(i)<t_coup) THEN
-          zqsat = qsats(pt(i))/pp(i)
-          zdqsat = dqsats(pt(i), zqsat)
-        ELSE
-          zqsat = qsatl(pt(i))/pp(i)
-          zdqsat = dqsatl(pt(i), zqsat)
-        END IF
-      END IF
-      zcond1 = (pq(i)-zqsat)/(1.+zdqsat)
-      pt(i) = pt(i) + zldcp*zcond1
-      pq(i) = pq(i) - zcond1
-    END IF
-  END DO
-
-230 CONTINUE
-  RETURN
-END SUBROUTINE adjtq
-SUBROUTINE fiajh(dtime, paprs, pplay, t, q, d_t, d_q, d_ql, rneb, rain, snow, &
-    ibas, itop)
-  USE dimphy
-  IMPLICIT NONE
-
-  ! Ajustement humide (Schema de convection de Manabe)
-  ! .
-  include "YOMCST.h"
-
-  ! Arguments:
-
-  REAL dtime ! intervalle du temps (s)
-  REAL t(klon, klev) ! temperature (K)
-  REAL q(klon, klev) ! humidite specifique (kg/kg)
-  REAL paprs(klon, klev+1) ! pression a inter-couche (Pa)
-  REAL pplay(klon, klev) ! pression au milieu de couche (Pa)
-
-  REAL d_t(klon, klev) ! incrementation pour la temperature
-  REAL d_q(klon, klev) ! incrementation pour vapeur d'eau
-  REAL d_ql(klon, klev) ! incrementation pour l'eau liquide
-  REAL rneb(klon, klev) ! fraction nuageuse
-
-  REAL rain(klon) ! variable non utilisee
-  REAL snow(klon) ! variable non utilisee
-  INTEGER ibas(klon) ! variable non utilisee
-  INTEGER itop(klon) ! variable non utilisee
-
-  REAL t_coup
-  PARAMETER (t_coup=234.0)
-  REAL seuil_vap
-  PARAMETER (seuil_vap=1.0E-10)
-
-  ! Variables locales:
-
-  INTEGER i, k
-  INTEGER k1, k1p, k2, k2p
-  LOGICAL itest(klon)
-  REAL delta_q(klon, klev)
-  REAL cp_new_t(klev)
-  REAL cp_delta_t(klev)
-  REAL new_qb(klev)
-  REAL v_cptj(klev), v_cptjk1, v_ssig
-  REAL v_cptt(klon, klev), v_p, v_t
-  REAL v_qs(klon, klev), v_qsd(klon, klev)
-  REAL zq1(klon), zq2(klon)
-  REAL gamcpdz(klon, 2:klev)
-  REAL zdp, zdpm
-
-  REAL zsat ! sur-saturation
-  REAL zflo ! flotabilite
-
-  REAL local_q(klon, klev), local_t(klon, klev)
-
-  REAL zdelta, zcor, zcvm5
-
-  include "YOETHF.h"
-  include "FCTTRE.h"
-
-  DO k = 1, klev
-    DO i = 1, klon
-      local_q(i, k) = q(i, k)
-      local_t(i, k) = t(i, k)
-      rneb(i, k) = 0.0
-      d_ql(i, k) = 0.0
-      d_t(i, k) = 0.0
-      d_q(i, k) = 0.0
-    END DO
-  END DO
-  DO i = 1, klon
-    rain(i) = 0.0
-    snow(i) = 0.0
-    ibas(i) = 0
-    itop(i) = 0
-  END DO
-
-  ! Calculer v_qs et v_qsd:
-
-  DO k = 1, klev
-    DO i = 1, klon
-      v_cptt(i, k) = rcpd*local_t(i, k)
-      v_t = local_t(i, k)
-      v_p = pplay(i, k)
-
-      IF (thermcep) THEN
-        zdelta = max(0., sign(1.,rtt-v_t))
-        zcvm5 = r5les*rlvtt*(1.-zdelta) + zdelta*r5ies*rlstt
-        zcvm5 = zcvm5/rcpd/(1.0+rvtmp2*local_q(i,k))
-        v_qs(i, k) = r2es*foeew(v_t, zdelta)/v_p
-        v_qs(i, k) = min(0.5, v_qs(i,k))
-        zcor = 1./(1.-retv*v_qs(i,k))
-        v_qs(i, k) = v_qs(i, k)*zcor
-        v_qsd(i, k) = foede(v_t, zdelta, zcvm5, v_qs(i,k), zcor)
-      ELSE
-        IF (v_t<t_coup) THEN
-          v_qs(i, k) = qsats(v_t)/v_p
-          v_qsd(i, k) = dqsats(v_t, v_qs(i,k))
-        ELSE
-          v_qs(i, k) = qsatl(v_t)/v_p
-          v_qsd(i, k) = dqsatl(v_t, v_qs(i,k))
-        END IF
-      END IF
-    END DO
-  END DO
-
-  ! Calculer Gamma * Cp * dz: (gamm est le gradient critique)
-
-  DO k = 2, klev
-    DO i = 1, klon
-      zdp = paprs(i, k) - paprs(i, k+1)
-      zdpm = paprs(i, k-1) - paprs(i, k)
-      gamcpdz(i, k) = ((rd/rcpd/(zdpm+zdp)*(v_cptt(i,k-1)*zdpm+ &
-        v_cptt(i,k)*zdp)+rlvtt/(zdpm+zdp)*(v_qs(i,k-1)*zdpm+ &
-        v_qs(i,k)*zdp))*(pplay(i,k-1)-pplay(i,k))/paprs(i,k))/(1.0+(v_qsd(i, &
-        k-1)*zdpm+v_qsd(i,k)*zdp)/(zdpm+zdp))
-    END DO
-  END DO
-
-  ! ------------------------------------ modification des profils instables
-  DO i = 1, klon
-    itest(i) = .FALSE.
-
-    k1 = 0
-    k2 = 1
-
-810 CONTINUE ! chercher k1, le bas de la colonne
-    k2 = k2 + 1
-    IF (k2>klev) GO TO 9999
-    zflo = v_cptt(i, k2-1) - v_cptt(i, k2) - gamcpdz(i, k2)
-    zsat = (local_q(i,k2-1)-v_qs(i,k2-1))*(paprs(i,k2-1)-paprs(i,k2)) + &
-      (local_q(i,k2)-v_qs(i,k2))*(paprs(i,k2)-paprs(i,k2+1))
-    IF (zflo<=0.0 .OR. zsat<=0.0) GO TO 810
-    k1 = k2 - 1
-    itest(i) = .TRUE.
-
-820 CONTINUE ! chercher k2, le haut de la colonne
-    IF (k2==klev) GO TO 821
-    k2p = k2 + 1
-    zsat = zsat + (paprs(i,k2p)-paprs(i,k2p+1))*(local_q(i,k2p)-v_qs(i,k2p))
-    zflo = v_cptt(i, k2p-1) - v_cptt(i, k2p) - gamcpdz(i, k2p)
-    IF (zflo<=0.0 .OR. zsat<=0.0) GO TO 821
-    k2 = k2p
-    GO TO 820
-821 CONTINUE
-
-    ! ------------------------------------------------------ ajustement local
-830 CONTINUE ! ajustement proprement dit
-    v_cptj(k1) = 0.0
-    zdp = paprs(i, k1) - paprs(i, k1+1)
-    v_cptjk1 = ((1.0+v_qsd(i,k1))*(v_cptt(i,k1)+v_cptj(k1))+rlvtt*(local_q(i, &
-      k1)-v_qs(i,k1)))*zdp
-    v_ssig = zdp*(1.0+v_qsd(i,k1))
-
-    k1p = k1 + 1
-    DO k = k1p, k2
-      zdp = paprs(i, k) - paprs(i, k+1)
-      v_cptj(k) = v_cptj(k-1) + gamcpdz(i, k)
-      v_cptjk1 = v_cptjk1 + zdp*((1.0+v_qsd(i,k))*(v_cptt(i, &
-        k)+v_cptj(k))+rlvtt*(local_q(i,k)-v_qs(i,k)))
-      v_ssig = v_ssig + zdp*(1.0+v_qsd(i,k))
-    END DO
-
-    DO k = k1, k2
-      cp_new_t(k) = v_cptjk1/v_ssig - v_cptj(k)
-      cp_delta_t(k) = cp_new_t(k) - v_cptt(i, k)
-      new_qb(k) = v_qs(i, k) + v_qsd(i, k)*cp_delta_t(k)/rlvtt
-      local_q(i, k) = new_qb(k)
-      local_t(i, k) = cp_new_t(k)/rcpd
-    END DO
-
-    ! --------------------------------------------------- sondage vers le bas
-    ! -- on redefinit les variables prognostiques dans
-    ! -- la colonne qui vient d'etre ajustee
-
-    DO k = k1, k2
-      v_cptt(i, k) = rcpd*local_t(i, k)
-      v_t = local_t(i, k)
-      v_p = pplay(i, k)
-
-      IF (thermcep) THEN
-        zdelta = max(0., sign(1.,rtt-v_t))
-        zcvm5 = r5les*rlvtt*(1.-zdelta) + zdelta*r5ies*rlstt
-        zcvm5 = zcvm5/rcpd/(1.0+rvtmp2*local_q(i,k))
-        v_qs(i, k) = r2es*foeew(v_t, zdelta)/v_p
-        v_qs(i, k) = min(0.5, v_qs(i,k))
-        zcor = 1./(1.-retv*v_qs(i,k))
-        v_qs(i, k) = v_qs(i, k)*zcor
-        v_qsd(i, k) = foede(v_t, zdelta, zcvm5, v_qs(i,k), zcor)
-      ELSE
-        IF (v_t<t_coup) THEN
-          v_qs(i, k) = qsats(v_t)/v_p
-          v_qsd(i, k) = dqsats(v_t, v_qs(i,k))
-        ELSE
-          v_qs(i, k) = qsatl(v_t)/v_p
-          v_qsd(i, k) = dqsatl(v_t, v_qs(i,k))
-        END IF
-      END IF
-    END DO
-    DO k = 2, klev
-      zdpm = paprs(i, k-1) - paprs(i, k)
-      zdp = paprs(i, k) - paprs(i, k+1)
-      gamcpdz(i, k) = ((rd/rcpd/(zdpm+zdp)*(v_cptt(i,k-1)*zdpm+ &
-        v_cptt(i,k)*zdp)+rlvtt/(zdpm+zdp)*(v_qs(i,k-1)*zdpm+ &
-        v_qs(i,k)*zdp))*(pplay(i,k-1)-pplay(i,k))/paprs(i,k))/(1.0+(v_qsd(i, &
-        k-1)*zdpm+v_qsd(i,k)*zdp)/(zdpm+zdp))
-    END DO
-
-    ! Verifier si l'on peut etendre la colonne vers le bas
-
-    IF (k1==1) GO TO 841 ! extension echouee
-    zflo = v_cptt(i, k1-1) - v_cptt(i, k1) - gamcpdz(i, k1)
-    zsat = (local_q(i,k1-1)-v_qs(i,k1-1))*(paprs(i,k1-1)-paprs(i,k1)) + &
-      (local_q(i,k1)-v_qs(i,k1))*(paprs(i,k1)-paprs(i,k1+1))
-    IF (zflo<=0.0 .OR. zsat<=0.0) GO TO 841 ! extension echouee
-
-840 CONTINUE
-    k1 = k1 - 1
-    IF (k1==1) GO TO 830 ! GOTO 820 (a tester, Z.X.Li, mars 1995)
-    zsat = zsat + (local_q(i,k1-1)-v_qs(i,k1-1))*(paprs(i,k1-1)-paprs(i,k1))
-    zflo = v_cptt(i, k1-1) - v_cptt(i, k1) - gamcpdz(i, k1)
-    IF (zflo>0.0 .AND. zsat>0.0) THEN
-      GO TO 840
-    ELSE
-      GO TO 830 ! GOTO 820 (a tester, Z.X.Li, mars 1995)
-    END IF
-841 CONTINUE
-
-    GO TO 810 ! chercher d'autres blocks en haut
-
-9999 END DO ! boucle sur tous les points
-  ! -----------------------------------------------------------------------
-
-  ! Determiner la fraction nuageuse (hypothese: la nebulosite a lieu
-  ! a l'endroit ou la vapeur d'eau est diminuee par l'ajustement):
-
-  DO k = 1, klev
-    DO i = 1, klon
-      IF (itest(i)) THEN
-        delta_q(i, k) = local_q(i, k) - q(i, k)
-        IF (delta_q(i,k)<0.) rneb(i, k) = 1.0
-      END IF
-    END DO
-  END DO
-
-  ! Distribuer l'eau condensee en eau liquide nuageuse (hypothese:
-  ! l'eau liquide est distribuee aux endroits ou la vapeur d'eau
-  ! diminue et d'une maniere proportionnelle a cet diminution):
-
-  DO i = 1, klon
-    IF (itest(i)) THEN
-      zq1(i) = 0.0
-      zq2(i) = 0.0
-    END IF
-  END DO
-  DO k = 1, klev
-    DO i = 1, klon
-      IF (itest(i)) THEN
-        zdp = paprs(i, k) - paprs(i, k+1)
-        zq1(i) = zq1(i) - delta_q(i, k)*zdp
-        zq2(i) = zq2(i) - min(0.0, delta_q(i,k))*zdp
-      END IF
-    END DO
-  END DO
-  DO k = 1, klev
-    DO i = 1, klon
-      IF (itest(i)) THEN
-        IF (zq2(i)/=0.0) d_ql(i, k) = -min(0.0, delta_q(i,k))*zq1(i)/zq2(i)
-      END IF
-    END DO
-  END DO
-
-  DO k = 1, klev
-    DO i = 1, klon
-      local_q(i, k) = max(local_q(i,k), seuil_vap)
-    END DO
-  END DO
-
-  DO k = 1, klev
-    DO i = 1, klon
-      d_t(i, k) = local_t(i, k) - t(i, k)
-      d_q(i, k) = local_q(i, k) - q(i, k)
-    END DO
-  END DO
-
-  RETURN
-END SUBROUTINE fiajh
-SUBROUTINE fiajc(dtime, paprs, pplay, t, q, conv_q, d_t, d_q, d_ql, rneb, &
-    rain, snow, ibas, itop)
-  USE dimphy
-  IMPLICIT NONE
-
-  include "YOMCST.h"
-
-  ! Options:
-
-  INTEGER plb ! niveau de depart pour la convection
-  PARAMETER (plb=4)
-
-  ! Mystere: cette option n'est pas innocente pour les resultats !
-  ! Qui peut resoudre ce mystere ? (Z.X.Li mars 1995)
-  LOGICAL vector ! calcul vectorise
-  PARAMETER (vector=.FALSE.)
-
-  REAL t_coup
-  PARAMETER (t_coup=234.0)
-
-  ! Arguments:
-
-  REAL q(klon, klev) ! humidite specifique (kg/kg)
-  REAL t(klon, klev) ! temperature (K)
-  REAL paprs(klon, klev+1) ! pression a inter-couche (Pa)
-  REAL pplay(klon, klev) ! pression au milieu de couche (Pa)
-  REAL dtime ! intervalle du temps (s)
-  REAL conv_q(klon, klev) ! taux de convergence de l'humidite
-  REAL rneb(klon, klev) ! fraction nuageuse
-  REAL d_q(klon, klev) ! incrementaion pour la vapeur d'eau
-  REAL d_ql(klon, klev) ! incrementation pour l'eau liquide
-  REAL d_t(klon, klev) ! incrementation pour la temperature
-  REAL rain(klon) ! variable non-utilisee
-  REAL snow(klon) ! variable non-utilisee
-  INTEGER itop(klon) ! variable non-utilisee
-  INTEGER ibas(klon) ! variable non-utilisee
-
-  INTEGER kh(klon), i, k
-  LOGICAL nuage(klon), test(klon, klev)
-  REAL zconv(klon), zdeh(klon, klev), zvirt(klon)
-  REAL zdqs(klon, klev), zqs(klon, klev)
-  REAL ztt, zvar, zfrac(klon)
-  REAL zq1(klon), zq2(klon)
-  REAL zdelta, zcor, zcvm5
-
-  include "YOETHF.h"
-  include "FCTTRE.h"
-
-  ! Initialiser les sorties:
-
-  DO k = 1, klev
-    DO i = 1, klon
-      rneb(i, k) = 0.0
-      d_ql(i, k) = 0.0
-      d_t(i, k) = 0.0
-      d_q(i, k) = 0.0
-    END DO
-  END DO
-  DO i = 1, klon
-    itop(i) = 0
-    ibas(i) = 0
-    rain(i) = 0.0
-    snow(i) = 0.0
-  END DO
-
-  ! Calculer Qs et L/Cp * dQs/dT:
-
-  DO k = 1, klev
-    DO i = 1, klon
-      ztt = t(i, k)
-      IF (thermcep) THEN
-        zdelta = max(0., sign(1.,rtt-ztt))
-        zcvm5 = r5les*rlvtt*(1.-zdelta) + zdelta*r5ies*rlstt
-        zcvm5 = zcvm5/rcpd/(1.0+rvtmp2*q(i,k))
-        zqs(i, k) = r2es*foeew(ztt, zdelta)/pplay(i, k)
-        zqs(i, k) = min(0.5, zqs(i,k))
-        zcor = 1./(1.-retv*zqs(i,k))
-        zqs(i, k) = zqs(i, k)*zcor
-        zdqs(i, k) = foede(ztt, zdelta, zcvm5, zqs(i,k), zcor)
-      ELSE
-        IF (ztt<t_coup) THEN
-          zqs(i, k) = qsats(ztt)/pplay(i, k)
-          zdqs(i, k) = dqsats(ztt, zqs(i,k))
-        ELSE
-          zqs(i, k) = qsatl(ztt)/pplay(i, k)
-          zdqs(i, k) = dqsatl(ztt, zqs(i,k))
-        END IF
-      END IF
-    END DO
-  END DO
-
-  ! Determiner la difference de l'energie totale saturee:
-
-  DO i = 1, klon
-    k = plb
-    zdeh(i, k) = rcpd*(t(i,k-1)-t(i,k)) - rd*0.5*(t(i,k-1)+t(i,k))/paprs(i, k &
-      )*(pplay(i,k-1)-pplay(i,k)) + rlvtt*(zqs(i,k-1)-zqs(i,k))
-    zdeh(i, k) = zdeh(i, k)*0.5 ! on prend la moitie
-  END DO
-  DO k = plb + 1, klev
-    DO i = 1, klon
-      zdeh(i, k) = zdeh(i, k-1) + rcpd*(t(i,k-1)-t(i,k)) - &
-        rd*0.5*(t(i,k-1)+t(i,k))/paprs(i, k)*(pplay(i,k-1)-pplay(i,k)) + &
-        rlvtt*(zqs(i,k-1)-zqs(i,k))
-    END DO
-  END DO
-
-  ! Determiner le sommet du nuage selon l'instabilite
-  ! Calculer les convergences d'humidite (reelle et virtuelle)
-
-  DO i = 1, klon
-    nuage(i) = .TRUE.
-    zconv(i) = 0.0
-    zvirt(i) = 0.0
-    kh(i) = -999
-  END DO
-  DO k = plb, klev
-    DO i = 1, klon
-      nuage(i) = nuage(i) .AND. zdeh(i, k) > 0.0
-      IF (nuage(i)) THEN
-        kh(i) = k
-        zconv(i) = zconv(i) + conv_q(i, k)*dtime*(paprs(i,k)-paprs(i,k+1))
-        zvirt(i) = zvirt(i) + (zdeh(i,k)/rlvtt+zqs(i,k)-q(i,k))*(paprs(i,k)- &
-          paprs(i,k+1))
-      END IF
-    END DO
-  END DO
-
-  IF (vector) THEN
-
-
-    DO k = plb, klev
-      DO i = 1, klon
-        IF (k<=kh(i) .AND. kh(i)>plb .AND. zconv(i)>0.0) THEN
-          test(i, k) = .TRUE.
-          zfrac(i) = max(0.0, min(zconv(i)/zvirt(i),1.0))
-        ELSE
-          test(i, k) = .FALSE.
-        END IF
-      END DO
-    END DO
-
-    DO k = plb, klev
-      DO i = 1, klon
-        IF (test(i,k)) THEN
-          zvar = zdeh(i, k)/(1.0+zdqs(i,k))
-          d_q(i, k) = (zvar*zdqs(i,k)/rlvtt+zqs(i,k)-q(i,k))*zfrac(i) - &
-            conv_q(i, k)*dtime
-          d_t(i, k) = zvar*zfrac(i)/rcpd
-        END IF
-      END DO
-    END DO
-
-    DO i = 1, klon
-      zq1(i) = 0.0
-      zq2(i) = 0.0
-    END DO
-    DO k = plb, klev
-      DO i = 1, klon
-        IF (test(i,k)) THEN
-          IF (d_q(i,k)<0.0) rneb(i, k) = zfrac(i)
-          zq1(i) = zq1(i) - d_q(i, k)*(paprs(i,k)-paprs(i,k+1))
-          zq2(i) = zq2(i) - min(0.0, d_q(i,k))*(paprs(i,k)-paprs(i,k+1))
-        END IF
-      END DO
-    END DO
-
-    DO k = plb, klev
-      DO i = 1, klon
-        IF (test(i,k)) THEN
-          IF (zq2(i)/=0.) d_ql(i, k) = -min(0.0, d_q(i,k))*zq1(i)/zq2(i)
-        END IF
-      END DO
-    END DO
-
-  ELSE ! (.NOT. vector)
-
-    DO i = 1, klon
-      IF (kh(i)>plb .AND. zconv(i)>0.0) THEN
-        ! cc         IF (kh(i).LE.plb) GOTO 999 ! il n'y a pas d'instabilite
-        ! cc         IF (zconv(i).LE.0.0) GOTO 999 ! convergence insuffisante
-        zfrac(i) = max(0.0, min(zconv(i)/zvirt(i),1.0))
-        DO k = plb, kh(i)
-          zvar = zdeh(i, k)/(1.0+zdqs(i,k))
-          d_q(i, k) = (zvar*zdqs(i,k)/rlvtt+zqs(i,k)-q(i,k))*zfrac(i) - &
-            conv_q(i, k)*dtime
-          d_t(i, k) = zvar*zfrac(i)/rcpd
-        END DO
-
-        zq1(i) = 0.0
-        zq2(i) = 0.0
-        DO k = plb, kh(i)
-          IF (d_q(i,k)<0.0) rneb(i, k) = zfrac(i)
-          zq1(i) = zq1(i) - d_q(i, k)*(paprs(i,k)-paprs(i,k+1))
-          zq2(i) = zq2(i) - min(0.0, d_q(i,k))*(paprs(i,k)-paprs(i,k+1))
-        END DO
-        DO k = plb, kh(i)
-          IF (zq2(i)/=0.) d_ql(i, k) = -min(0.0, d_q(i,k))*zq1(i)/zq2(i)
-        END DO
-      END IF
-    END DO
-
-  END IF ! fin de teste sur vector
-
-  RETURN
-END SUBROUTINE fiajc
Index: /LMDZ6/trunk/libf/phylmd/conlmd.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/conlmd.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/conlmd.f90	(revision 5268)
@@ -0,0 +1,2250 @@
+
+! $Header$
+
+SUBROUTINE conlmd(dtime, paprs, pplay, t, q, conv_q, d_t, d_q, rain, snow, &
+    ibas, itop)
+  USE dimphy
+  IMPLICIT NONE
+  ! ======================================================================
+  ! Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818
+  ! Objet: Schema de convection utilis'e dans le modele du LMD
+  ! Ajustement humide (Manabe) + Ajustement convectif (Kuo)
+  ! ======================================================================
+  include "YOMCST.h"
+  include "YOETHF.h"
+
+  ! Arguments:
+
+  REAL dtime ! pas d'integration (s)
+  REAL paprs(klon, klev+1) ! pression inter-couche (Pa)
+  REAL pplay(klon, klev) ! pression au milieu de couche (Pa)
+  REAL t(klon, klev) ! temperature (K)
+  REAL q(klon, klev) ! humidite specifique (kg/kg)
+  REAL conv_q(klon, klev) ! taux de convergence humidite (g/g/s)
+
+  REAL d_t(klon, klev) ! incrementation temperature
+  REAL d_q(klon, klev) ! incrementation humidite
+  REAL rain(klon) ! pluies (mm/s)
+  REAL snow(klon) ! neige (mm/s)
+  INTEGER ibas(klon) ! niveau du bas
+  INTEGER itop(klon) ! niveau du haut
+
+  LOGICAL usekuo ! utiliser convection profonde (schema Kuo)
+  PARAMETER (usekuo=.TRUE.)
+
+  REAL d_t_bis(klon, klev)
+  REAL d_q_bis(klon, klev)
+  REAL rain_bis(klon)
+  REAL snow_bis(klon)
+  INTEGER ibas_bis(klon)
+  INTEGER itop_bis(klon)
+  REAL d_ql(klon, klev), d_ql_bis(klon, klev)
+  REAL rneb(klon, klev), rneb_bis(klon, klev)
+
+  INTEGER i, k
+  REAL zlvdcp, zlsdcp, zdelta, zz, za, zb
+
+  ! cc      CALL fiajh ! ancienne version de Convection Manabe
+  CALL conman &                    ! nouvelle version de Convection
+                                   ! Manabe
+    (dtime, paprs, pplay, t, q, d_t, d_q, d_ql, rneb, rain, snow, ibas, itop)
+
+  IF (usekuo) THEN
+    ! cc      CALL fiajc ! ancienne version de Convection Kuo
+    CALL conkuo &                  ! nouvelle version de Convection
+                                   ! Kuo
+      (dtime, paprs, pplay, t, q, conv_q, d_t_bis, d_q_bis, d_ql_bis, &
+      rneb_bis, rain_bis, snow_bis, ibas_bis, itop_bis)
+    DO k = 1, klev
+      DO i = 1, klon
+        d_t(i, k) = d_t(i, k) + d_t_bis(i, k)
+        d_q(i, k) = d_q(i, k) + d_q_bis(i, k)
+        d_ql(i, k) = d_ql(i, k) + d_ql_bis(i, k)
+      END DO
+    END DO
+    DO i = 1, klon
+      rain(i) = rain(i) + rain_bis(i)
+      snow(i) = snow(i) + snow_bis(i)
+      ibas(i) = min(ibas(i), ibas_bis(i))
+      itop(i) = max(itop(i), itop_bis(i))
+    END DO
+  END IF
+
+  ! L'eau liquide convective est dispersee dans l'air:
+
+  DO k = 1, klev
+    DO i = 1, klon
+      zlvdcp = rlvtt/rcpd/(1.0+rvtmp2*q(i,k))
+      zlsdcp = rlstt/rcpd/(1.0+rvtmp2*q(i,k))
+      zdelta = max(0., sign(1.,rtt-t(i,k)))
+      zz = d_ql(i, k) ! re-evap. de l'eau liquide
+      zb = max(0.0, zz)
+      za = -max(0.0, zz)*(zlvdcp*(1.-zdelta)+zlsdcp*zdelta)
+      d_t(i, k) = d_t(i, k) + za
+      d_q(i, k) = d_q(i, k) + zb
+    END DO
+  END DO
+
+  RETURN
+END SUBROUTINE conlmd
+SUBROUTINE conman(dtime, paprs, pplay, t, q, d_t, d_q, d_ql, rneb, rain, &
+    snow, ibas, itop)
+  USE dimphy
+  IMPLICIT NONE
+  ! ======================================================================
+  ! Auteur(s): Z.X. Li (LMD/CNRS) date: 19970324
+  ! Objet: ajustement humide convectif avec la possibilite de faire
+  ! l'ajustement sur une fraction de la maille.
+  ! Methode: On impose une distribution uniforme pour la vapeur d'eau
+  ! au sein d'une maille. On applique la procedure d'ajustement
+  ! successivement a la totalite, 75%, 50%, 25% et 5% de la maille
+  ! jusqu'a ce que l'ajustement a lieu. J'espere que ceci augmente
+  ! les activites convectives et corrige le biais "trop froid et sec"
+  ! du modele.
+  ! ======================================================================
+  include "YOMCST.h"
+
+  REAL dtime ! pas d'integration (s)
+  REAL t(klon, klev) ! temperature (K)
+  REAL q(klon, klev) ! humidite specifique (kg/kg)
+  REAL paprs(klon, klev+1) ! pression inter-couche (Pa)
+  REAL pplay(klon, klev) ! pression au milieu de couche (Pa)
+
+  REAL d_t(klon, klev) ! incrementation temperature
+  REAL d_q(klon, klev) ! incrementation humidite
+  REAL d_ql(klon, klev) ! incrementation eau liquide
+  REAL rneb(klon, klev) ! nebulosite
+  REAL rain(klon) ! pluies (mm/s)
+  REAL snow(klon) ! neige (mm/s)
+  INTEGER ibas(klon) ! niveau du bas
+  INTEGER itop(klon) ! niveau du haut
+
+  LOGICAL afaire(klon) ! .TRUE. implique l'ajustement
+  LOGICAL accompli(klon) ! .TRUE. si l'ajustement est effectif
+
+  INTEGER nb ! nombre de sous-fractions a considere
+  PARAMETER (nb=1)
+  ! cc      PARAMETER (nb=3)
+
+  REAL ratqs ! largeur de la distribution pour vapeur d'eau
+  PARAMETER (ratqs=0.05)
+
+  REAL w_q(klon, klev)
+  REAL w_d_t(klon, klev), w_d_q(klon, klev), w_d_ql(klon, klev)
+  REAL w_rneb(klon, klev)
+  REAL w_rain(klon), w_snow(klon)
+  INTEGER w_ibas(klon), w_itop(klon)
+  REAL zq1, zq2
+  INTEGER i, k, n
+
+  REAL t_coup
+  PARAMETER (t_coup=234.0)
+  REAL zdp1, zdp2
+  REAL zqs1, zqs2, zdqs1, zdqs2
+  REAL zgamdz
+  REAL zflo ! flotabilite
+  REAL zsat ! sur-saturation
+  REAL zdelta, zcor, zcvm5
+  LOGICAL imprim
+
+  INTEGER ncpt
+  SAVE ncpt
+  !$OMP THREADPRIVATE(ncpt)
+  REAL frac(nb) ! valeur de la maille fractionnelle
+  SAVE frac
+  !$OMP THREADPRIVATE(frac)
+  INTEGER opt_cld(nb) ! option pour le modele nuageux
+  SAVE opt_cld
+  !$OMP THREADPRIVATE(opt_cld)
+  LOGICAL appel1er
+  SAVE appel1er
+  !$OMP THREADPRIVATE(appel1er)
+
+  ! Fonctions thermodynamiques:
+
+  include "YOETHF.h"
+  include "FCTTRE.h"
+
+  DATA frac/1.0/
+  DATA opt_cld/4/
+  ! cc      DATA frac    / 1.0, 0.50, 0.25/
+  ! cc      DATA opt_cld / 4,   4,    4/
+
+  DATA appel1er/.TRUE./
+  DATA ncpt/0/
+
+  IF (appel1er) THEN
+    PRINT *, 'conman, nb:', nb
+    PRINT *, 'conman, frac:', frac
+    PRINT *, 'conman, opt_cld:', opt_cld
+    appel1er = .FALSE.
+  END IF
+
+  ! Initialiser les sorties a zero:
+
+  DO k = 1, klev
+    DO i = 1, klon
+      d_t(i, k) = 0.0
+      d_q(i, k) = 0.0
+      d_ql(i, k) = 0.0
+      rneb(i, k) = 0.0
+    END DO
+  END DO
+  DO i = 1, klon
+    ibas(i) = klev
+    itop(i) = 1
+    rain(i) = 0.0
+    snow(i) = 0.0
+  END DO
+
+  ! S'il n'y a pas d'instabilite conditionnelle,
+  ! pas la penne de se fatiguer:
+
+  DO i = 1, klon
+    afaire(i) = .FALSE.
+  END DO
+  DO k = 1, klev - 1
+    DO i = 1, klon
+      IF (thermcep) THEN
+        zdelta = max(0., sign(1.,rtt-t(i,k)))
+        zcvm5 = r5les*rlvtt*(1.-zdelta) + zdelta*r5ies*rlstt
+        zcvm5 = zcvm5/rcpd/(1.0+rvtmp2*q(i,k))
+        zqs1 = r2es*foeew(t(i,k), zdelta)/pplay(i, k)
+        zqs1 = min(0.5, zqs1)
+        zcor = 1./(1.-retv*zqs1)
+        zqs1 = zqs1*zcor
+        zdqs1 = foede(t(i,k), zdelta, zcvm5, zqs1, zcor)
+
+        zdelta = max(0., sign(1.,rtt-t(i,k+1)))
+        zcvm5 = r5les*rlvtt*(1.-zdelta) + zdelta*r5ies*rlstt
+        zcvm5 = zcvm5/rcpd/(1.0+rvtmp2*q(i,k+1))
+        zqs2 = r2es*foeew(t(i,k+1), zdelta)/pplay(i, k+1)
+        zqs2 = min(0.5, zqs2)
+        zcor = 1./(1.-retv*zqs2)
+        zqs2 = zqs2*zcor
+        zdqs2 = foede(t(i,k+1), zdelta, zcvm5, zqs2, zcor)
+      ELSE
+        IF (t(i,k)<t_coup) THEN
+          zqs1 = qsats(t(i,k))/pplay(i, k)
+          zdqs1 = dqsats(t(i,k), zqs1)
+
+          zqs2 = qsats(t(i,k+1))/pplay(i, k+1)
+          zdqs2 = dqsats(t(i,k+1), zqs2)
+        ELSE
+          zqs1 = qsatl(t(i,k))/pplay(i, k)
+          zdqs1 = dqsatl(t(i,k), zqs1)
+
+          zqs2 = qsatl(t(i,k+1))/pplay(i, k+1)
+          zdqs2 = dqsatl(t(i,k+1), zqs2)
+        END IF
+      END IF
+      zdp1 = paprs(i, k) - paprs(i, k+1)
+      zdp2 = paprs(i, k+1) - paprs(i, k+2)
+      zgamdz = -(pplay(i,k)-pplay(i,k+1))/paprs(i, k+1)/rcpd*(rd*(t(i, &
+        k)*zdp1+t(i,k+1)*zdp2)/(zdp1+zdp2)+rlvtt*(zqs1*zdp1+zqs2*zdp2)/(zdp1+ &
+        zdp2))/(1.0+(zdqs1*zdp1+zdqs2*zdp2)/(zdp1+zdp2))
+      zflo = t(i, k) + zgamdz - t(i, k+1)
+      zsat = (q(i,k)-zqs1)*zdp1 + (q(i,k+1)-zqs2)*zdp2
+      IF (zflo>0.0) afaire(i) = .TRUE.
+      ! erreur         IF (zflo.GT.0.0 .AND. zsat.GT.0.0) afaire(i) = .TRUE.
+    END DO
+  END DO
+
+  imprim = mod(ncpt, 48) == 0
+  DO n = 1, nb
+
+    DO k = 1, klev
+      DO i = 1, klon
+        IF (afaire(i)) THEN
+          zq1 = q(i, k)*(1.0-ratqs)
+          zq2 = q(i, k)*(1.0+ratqs)
+          w_q(i, k) = zq2 - frac(n)/2.0*(zq2-zq1)
+        END IF
+      END DO
+    END DO
+
+    CALL conmanv(dtime, paprs, pplay, t, w_q, afaire, opt_cld(n), w_d_t, &
+      w_d_q, w_d_ql, w_rneb, w_rain, w_snow, w_ibas, w_itop, accompli, &
+      imprim)
+    DO k = 1, klev
+      DO i = 1, klon
+        IF (afaire(i) .AND. accompli(i)) THEN
+          d_t(i, k) = w_d_t(i, k)*frac(n)
+          d_q(i, k) = w_d_q(i, k)*frac(n)
+          d_ql(i, k) = w_d_ql(i, k)*frac(n)
+          IF (nint(w_rneb(i,k))==1) rneb(i, k) = frac(n)
+        END IF
+      END DO
+    END DO
+    DO i = 1, klon
+      IF (afaire(i) .AND. accompli(i)) THEN
+        rain(i) = w_rain(i)*frac(n)
+        snow(i) = w_snow(i)*frac(n)
+        ibas(i) = min(ibas(i), w_ibas(i))
+        itop(i) = max(itop(i), w_itop(i))
+      END IF
+    END DO
+    DO i = 1, klon
+      IF (afaire(i) .AND. accompli(i)) afaire(i) = .FALSE.
+    END DO
+
+  END DO
+
+  ncpt = ncpt + 1
+
+  RETURN
+END SUBROUTINE conman
+SUBROUTINE conmanv(dtime, paprs, pplay, t, q, afaire, opt_cld, d_t, d_q, &
+    d_ql, rneb, rain, snow, ibas, itop, accompli, imprim)
+  USE dimphy
+  IMPLICIT NONE
+  ! ======================================================================
+  ! Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818
+  ! Objet: ajustement humide (convection proposee par Manabe).
+  ! Pour une colonne verticale, il peut avoir plusieurs blocs
+  ! necessitant l'ajustement. ibas est le bas du plus bas bloc
+  ! et itop est le haut du plus haut bloc
+  ! ======================================================================
+  include "YOMCST.h"
+
+  ! Arguments:
+
+  REAL dtime ! pas d'integration (s)
+  REAL t(klon, klev) ! temperature (K)
+  REAL q(klon, klev) ! humidite specifique (kg/kg)
+  REAL paprs(klon, klev+1) ! pression inter-couche (Pa)
+  REAL pplay(klon, klev) ! pression au milieu de couche (Pa)
+  INTEGER opt_cld ! comment traiter l'eau liquide
+  LOGICAL afaire(klon) ! .TRUE. si le point est a faire (Input)
+  LOGICAL imprim ! .T. pour imprimer quelques diagnostiques
+
+  REAL d_t(klon, klev) ! incrementation temperature
+  REAL d_q(klon, klev) ! incrementation humidite
+  REAL d_ql(klon, klev) ! incrementation eau liquide
+  REAL rneb(klon, klev) ! nebulosite
+  REAL rain(klon) ! pluies (mm/s)
+  REAL snow(klon) ! neige (mm/s)
+  INTEGER ibas(klon) ! niveau du bas
+  INTEGER itop(klon) ! niveau du haut
+  LOGICAL accompli(klon) ! .TRUE. si l'ajustement a eu lieu (Output)
+
+  ! Quelques options:
+
+  LOGICAL new_top ! re-calculer sommet quand re-ajustement est fait
+  PARAMETER (new_top=.FALSE.)
+  LOGICAL evap_prec ! evaporation de pluie au-dessous de convection
+  PARAMETER (evap_prec=.TRUE.)
+  REAL coef_eva
+  PARAMETER (coef_eva=1.0E-05)
+  REAL t_coup
+  PARAMETER (t_coup=234.0)
+  REAL seuil_vap
+  PARAMETER (seuil_vap=1.0E-10)
+  LOGICAL old_tau ! implique precip nulle, si vrai.
+  PARAMETER (old_tau=.FALSE.)
+  REAL toliq(klon) ! rapport entre l'eau nuageuse et l'eau precipitante
+  REAL dpmin, tomax !Epaisseur faible, rapport eau liquide plus grande
+  PARAMETER (dpmin=0.15, tomax=0.97)
+  REAL dpmax, tomin !Epaisseur grande, rapport eau liquide plus faible
+  PARAMETER (dpmax=0.30, tomin=0.05)
+  REAL deep_sig, deep_to ! au dela de deep_sig, utiliser deep_to
+  PARAMETER (deep_sig=0.50, deep_to=0.05)
+  LOGICAL exigent ! implique un calcul supplementaire pour Qs
+  PARAMETER (exigent=.FALSE.)
+
+  INTEGER kbase
+  PARAMETER (kbase=0)
+
+  ! Variables locales:
+
+  INTEGER nexpo
+  INTEGER i, k, k1min, k1max, k2min, k2max, is
+  REAL zgamdz(klon, klev-1)
+  REAL zt(klon, klev), zq(klon, klev)
+  REAL zqs(klon, klev), zdqs(klon, klev)
+  REAL zqmqsdp(klon, klev)
+  REAL ztnew(klon, klev), zqnew(klon, klev)
+  REAL zcond(klon), zvapo(klon), zrapp(klon)
+  REAL zrfl(klon), zrfln, zqev, zqevt
+  REAL zsat(klon) ! sur-saturation
+  REAL zflo(klon) ! flotabilite
+  REAL za(klon), zb(klon), zc(klon)
+  INTEGER k1(klon), k2(klon)
+  REAL zdelta, zcor, zcvm5
+  REAL delp(klon, klev)
+  LOGICAL possible(klon), todo(klon), etendre(klon)
+  LOGICAL aller(klon), todobis(klon)
+  REAL zalfa
+  INTEGER nbtodo, nbdone
+
+  ! Fonctions thermodynamiques:
+
+  include "YOETHF.h"
+  include "FCTTRE.h"
+
+  DO k = 1, klev
+    DO i = 1, klon
+      delp(i, k) = paprs(i, k) - paprs(i, k+1)
+    END DO
+  END DO
+
+  ! Initialiser les sorties a zero
+
+  DO k = 1, klev
+    DO i = 1, klon
+      d_t(i, k) = 0.0
+      d_q(i, k) = 0.0
+      d_ql(i, k) = 0.0
+      rneb(i, k) = 0.0
+    END DO
+  END DO
+  DO i = 1, klon
+    ibas(i) = klev
+    itop(i) = 1
+    rain(i) = 0.0
+    snow(i) = 0.0
+    accompli(i) = .FALSE.
+  END DO
+
+  ! Preparations
+
+  DO k = 1, klev
+    DO i = 1, klon
+      IF (afaire(i)) THEN
+        zt(i, k) = t(i, k)
+        zq(i, k) = q(i, k)
+
+        ! Calculer Qs et L/Cp*dQs/dT
+
+        IF (thermcep) THEN
+          zdelta = max(0., sign(1.,rtt-zt(i,k)))
+          zcvm5 = r5les*rlvtt*(1.-zdelta) + zdelta*r5ies*rlstt
+          zcvm5 = zcvm5/rcpd/(1.0+rvtmp2*zq(i,k))
+          zqs(i, k) = r2es*foeew(zt(i,k), zdelta)/pplay(i, k)
+          zqs(i, k) = min(0.5, zqs(i,k))
+          zcor = 1./(1.-retv*zqs(i,k))
+          zqs(i, k) = zqs(i, k)*zcor
+          zdqs(i, k) = foede(zt(i,k), zdelta, zcvm5, zqs(i,k), zcor)
+        ELSE
+          IF (zt(i,k)<t_coup) THEN
+            zqs(i, k) = qsats(zt(i,k))/pplay(i, k)
+            zdqs(i, k) = dqsats(zt(i,k), zqs(i,k))
+          ELSE
+            zqs(i, k) = qsatl(zt(i,k))/pplay(i, k)
+            zdqs(i, k) = dqsatl(zt(i,k), zqs(i,k))
+          END IF
+        END IF
+
+        ! Calculer (q-qs)*dp
+        zqmqsdp(i, k) = (zq(i,k)-zqs(i,k))*delp(i, k)
+      END IF
+    END DO
+  END DO
+
+  ! -----zgama is the moist convective lapse rate (-dT/dz).
+  ! -----zgamdz(*,k) est la difference minimale autorisee des temperatures
+  ! -----entre deux couches (k et k+1), c.a.d. si T(k+1)-T(k) est inferieur
+  ! -----a zgamdz(*,k), alors ces 2 couches sont instables conditionnellement
+
+  DO k = 1, klev - 1
+    DO i = 1, klon
+      IF (afaire(i)) THEN
+        zgamdz(i, k) = -(pplay(i,k)-pplay(i,k+1))/paprs(i, k+1)/rcpd*(rd*(zt( &
+          i,k)*delp(i,k)+zt(i,k+1)*delp(i,k+1))/(delp(i,k)+delp(i, &
+          k+1))+rlvtt*(zqs(i,k)*delp(i,k)+zqs(i,k+1)*delp(i,k+1))/(delp(i, &
+          k)+delp(i,k+1)))/(1.0+(zdqs(i,k)*delp(i,k)+zdqs(i,k+1)*delp(i, &
+          k+1))/(delp(i,k)+delp(i,k+1)))
+      END IF
+    END DO
+  END DO
+
+  ! On cherche la presence simultanee d'instabilite conditionnelle
+  ! et de sur-saturation. Sinon, pas la penne de se fatiguer:
+
+  DO i = 1, klon
+    possible(i) = .FALSE.
+  END DO
+  DO k = 2, klev
+    DO i = 1, klon
+      IF (afaire(i)) THEN
+        zflo(i) = zt(i, k-1) + zgamdz(i, k-1) - zt(i, k)
+        zsat(i) = zqmqsdp(i, k) + zqmqsdp(i, k-1)
+        IF (zflo(i)>0.0 .AND. zsat(i)>0.0) possible(i) = .TRUE.
+      END IF
+    END DO
+  END DO
+
+  DO i = 1, klon
+    IF (possible(i)) THEN
+      k1(i) = kbase
+      k2(i) = k1(i) + 1
+    END IF
+  END DO
+
+810 CONTINUE ! chercher le bas de la colonne a ajuster
+
+  k2min = klev
+  DO i = 1, klon
+    todo(i) = .FALSE.
+    aller(i) = .TRUE.
+    IF (possible(i)) k2min = min(k2min, k2(i))
+  END DO
+  IF (k2min==klev) GO TO 860
+  DO k = k2min, klev - 1
+    DO i = 1, klon
+      IF (possible(i) .AND. k>=k2(i) .AND. aller(i)) THEN
+        zflo(i) = zt(i, k) + zgamdz(i, k) - zt(i, k+1)
+        zsat(i) = zqmqsdp(i, k) + zqmqsdp(i, k+1)
+        IF (zflo(i)>0.0 .AND. zsat(i)>0.0) THEN
+          k1(i) = k
+          k2(i) = k + 1
+          todo(i) = .TRUE.
+          aller(i) = .FALSE.
+        END IF
+      END IF
+    END DO
+  END DO
+  DO i = 1, klon
+    IF (possible(i) .AND. aller(i)) THEN
+      todo(i) = .FALSE.
+      k1(i) = klev
+      k2(i) = klev
+    END IF
+  END DO
+
+  ! CC      DO i = 1, klon
+  ! CC      IF (possible(i)) THEN
+  ! CC  811    k2(i) = k2(i) + 1
+  ! CC         IF (k2(i) .GT. klev) THEN
+  ! CC            todo(i) = .FALSE.
+  ! CC            GOTO 812
+  ! CC         ENDIF
+  ! CC         k = k2(i)
+  ! CC         zflo(i) = zt(i,k-1) + zgamdz(i,k-1) - zt(i,k)
+  ! CC         zsat(i) = zqmqsdp(i,k) + zqmqsdp(i,k-1)
+  ! CC         IF (zflo(i).LE.0.0 .OR. zsat(i).LE.0.0) GOTO 811
+  ! CC         k1(i) = k2(i) - 1
+  ! CC         todo(i) = .TRUE.
+  ! CC      ENDIF
+  ! CC  812 CONTINUE
+  ! CC      ENDDO
+
+820 CONTINUE ! chercher le haut de la colonne
+
+  k2min = klev
+  DO i = 1, klon
+    aller(i) = .TRUE.
+    IF (todo(i)) k2min = min(k2min, k2(i))
+  END DO
+  IF (k2min<klev) THEN
+    DO k = k2min, klev
+      DO i = 1, klon
+        IF (todo(i) .AND. k>k2(i) .AND. aller(i)) THEN
+          zsat(i) = zsat(i) + zqmqsdp(i, k)
+          zflo(i) = zt(i, k-1) + zgamdz(i, k-1) - zt(i, k)
+          IF (zflo(i)<=0.0 .OR. zsat(i)<=0.0) THEN
+            aller(i) = .FALSE.
+          ELSE
+            k2(i) = k
+          END IF
+        END IF
+      END DO
+    END DO
+    ! error      is = 0
+    ! error      DO i = 1, klon
+    ! error      IF(todo(i).AND.aller(i)) THEN
+    ! error         is = is + 1
+    ! error         todo(i) = .FALSE.
+    ! error         k2(i) = klev
+    ! error      ENDIF
+    ! error      ENDDO
+    ! error      IF (is.GT.0) THEN
+    ! error         PRINT*, "Bizard. je pourrais continuer mais j arrete"
+    ! error         CALL abort
+    ! error      ENDIF
+  END IF
+
+  ! CC      DO i = 1, klon
+  ! CC      IF (todo(i)) THEN
+  ! CC  821    CONTINUE
+  ! CC         IF (k2(i) .EQ. klev) GOTO 822
+  ! CC         k = k2(i) + 1
+  ! CC         zsat(i) = zsat(i) + zqmqsdp(i,k)
+  ! CC         zflo(i) = zt(i,k-1) + zgamdz(i,k-1) - zt(i,k)
+  ! CC         IF (zflo(i).LE.0.0 .OR. zsat(i).LE.0.0) GOTO 822
+  ! CC         k2(i) = k
+  ! CC         GOTO 821
+  ! CC      ENDIF
+  ! CC  822 CONTINUE
+  ! CC      ENDDO
+
+830 CONTINUE ! faire l'ajustement en sachant k1 et k2
+
+  is = 0
+  DO i = 1, klon
+    IF (todo(i)) THEN
+      IF (k2(i)<=k1(i)) is = is + 1
+    END IF
+  END DO
+  IF (is>0) THEN
+    PRINT *, 'Impossible: k1 trop grand ou k2 trop petit'
+    PRINT *, 'is=', is
+    CALL abort
+  END IF
+
+  k1min = klev
+  k1max = 1
+  k2max = 1
+  DO i = 1, klon
+    IF (todo(i)) THEN
+      k1min = min(k1min, k1(i))
+      k1max = max(k1max, k1(i))
+      k2max = max(k2max, k2(i))
+    END IF
+  END DO
+
+  DO i = 1, klon
+    IF (todo(i)) THEN
+      k = k1(i)
+      za(i) = 0.
+      zb(i) = (rcpd*(1.+zdqs(i,k))*(zt(i,k)-za(i))-rlvtt*(zqs(i,k)-zq(i, &
+        k)))*delp(i, k)
+      zc(i) = delp(i, k)*rcpd*(1.+zdqs(i,k))
+    END IF
+  END DO
+
+  DO k = k1min, k2max
+    DO i = 1, klon
+      IF (todo(i) .AND. k>=(k1(i)+1) .AND. k<=k2(i)) THEN
+        za(i) = za(i) + zgamdz(i, k-1)
+        zb(i) = zb(i) + (rcpd*(1.+zdqs(i,k))*(zt(i,k)-za(i))-rlvtt*(zqs(i, &
+          k)-zq(i,k)))*delp(i, k)
+        zc(i) = zc(i) + delp(i, k)*rcpd*(1.+zdqs(i,k))
+      END IF
+    END DO
+  END DO
+
+  DO i = 1, klon
+    IF (todo(i)) THEN
+      k = k1(i)
+      ztnew(i, k) = zb(i)/zc(i)
+      zqnew(i, k) = zqs(i, k) + (ztnew(i,k)-zt(i,k))*rcpd/rlvtt*zdqs(i, k)
+    END IF
+  END DO
+
+  DO k = k1min, k2max
+    DO i = 1, klon
+      IF (todo(i) .AND. k>=(k1(i)+1) .AND. k<=k2(i)) THEN
+        ztnew(i, k) = ztnew(i, k-1) + zgamdz(i, k-1)
+        zqnew(i, k) = zqs(i, k) + (ztnew(i,k)-zt(i,k))*rcpd/rlvtt*zdqs(i, k)
+      END IF
+    END DO
+  END DO
+
+  ! Quantite de condensation produite pendant l'ajustement:
+
+  DO i = 1, klon
+    zcond(i) = 0.0
+  END DO
+  DO k = k1min, k2max
+    DO i = 1, klon
+      IF (todo(i) .AND. k>=k1(i) .AND. k<=k2(i)) THEN
+        rneb(i, k) = 1.0
+        zcond(i) = zcond(i) + (zq(i,k)-zqnew(i,k))*delp(i, k)/rg
+      END IF
+    END DO
+  END DO
+
+  ! Si condensation negative, effort completement perdu:
+
+  DO i = 1, klon
+    IF (todo(i) .AND. zcond(i)<=0.) todo(i) = .FALSE.
+  END DO
+
+  ! L'ajustement a ete accompli, meme les calculs accessoires
+  ! ne sont pas encore faits:
+
+  DO i = 1, klon
+    IF (todo(i)) accompli(i) = .TRUE.
+  END DO
+
+  ! =====
+  ! Une fois que la condensation a lieu, on doit construire un
+  ! "modele nuageux" pour partager la condensation entre l'eau
+  ! liquide nuageuse et la precipitation (leur rapport toliq
+  ! est calcule selon l'epaisseur nuageuse). Je suppose que
+  ! toliq=tomax quand l'epaisseur nuageuse est inferieure a dpmin,
+  ! et que toliq=tomin quand l'epaisseur depasse dpmax (interpolation
+  ! lineaire entre dpmin et dpmax).
+  ! =====
+  DO i = 1, klon
+    IF (todo(i)) THEN
+      toliq(i) = tomax - ((paprs(i,k1(i))-paprs(i,k2(i)+1))/paprs(i,1)-dpmin) &
+        *(tomax-tomin)/(dpmax-dpmin)
+      toliq(i) = max(tomin, min(tomax,toliq(i)))
+      IF (pplay(i,k2(i))/paprs(i,1)<=deep_sig) toliq(i) = deep_to
+      IF (old_tau) toliq(i) = 1.0
+    END IF
+  END DO
+  ! =====
+  ! On doit aussi determiner la distribution verticale de
+  ! l'eau nuageuse. Plusieurs options sont proposees:
+
+  ! (0) La condensation precipite integralement (toliq ne sera
+  ! pas utilise).
+  ! (1) L'eau liquide est distribuee entre k1 et k2 et proportionnelle
+  ! a la vapeur d'eau locale.
+  ! (2) Elle est distribuee entre k1 et k2 avec une valeur constante.
+  ! (3) Elle est seulement distribuee aux couches ou la vapeur d'eau
+  ! est effectivement diminuee pendant le processus d'ajustement.
+  ! (4) Elle est en fonction (lineaire ou exponentielle) de la
+  ! distance (epaisseur en pression) avec le niveau k1 (la couche
+  ! k1 n'aura donc pas d'eau liquide).
+  ! =====
+
+  IF (opt_cld==0) THEN
+
+    DO i = 1, klon
+      IF (todo(i)) zrfl(i) = zcond(i)/dtime
+    END DO
+
+  ELSE IF (opt_cld==1) THEN
+
+    DO i = 1, klon
+      IF (todo(i)) zvapo(i) = 0.0 ! quantite integrale de vapeur d'eau
+    END DO
+    DO k = k1min, k2max
+      DO i = 1, klon
+        IF (todo(i) .AND. k>=k1(i) .AND. k<=k2(i)) zvapo(i) = zvapo(i) + &
+          zqnew(i, k)*delp(i, k)/rg
+      END DO
+    END DO
+    DO i = 1, klon
+      IF (todo(i)) THEN
+        zrapp(i) = toliq(i)*zcond(i)/zvapo(i)
+        zrapp(i) = max(0., min(1.,zrapp(i)))
+        zrfl(i) = (1.0-toliq(i))*zcond(i)/dtime
+      END IF
+    END DO
+    DO k = k1min, k2max
+      DO i = 1, klon
+        IF (todo(i) .AND. k>=k1(i) .AND. k<=k2(i)) THEN
+          d_ql(i, k) = d_ql(i, k) + zrapp(i)*zqnew(i, k)
+        END IF
+      END DO
+    END DO
+
+  ELSE IF (opt_cld==2) THEN
+
+    DO i = 1, klon
+      IF (todo(i)) zvapo(i) = 0.0 ! quantite integrale de masse
+    END DO
+    DO k = k1min, k2max
+      DO i = 1, klon
+        IF (todo(i) .AND. k>=k1(i) .AND. k<=k2(i)) zvapo(i) = zvapo(i) + &
+          delp(i, k)/rg
+      END DO
+    END DO
+    DO k = k1min, k2max
+      DO i = 1, klon
+        IF (todo(i) .AND. k>=k1(i) .AND. k<=k2(i)) THEN
+          d_ql(i, k) = d_ql(i, k) + toliq(i)*zcond(i)/zvapo(i)
+        END IF
+      END DO
+    END DO
+    DO i = 1, klon
+      IF (todo(i)) zrfl(i) = (1.0-toliq(i))*zcond(i)/dtime
+    END DO
+
+  ELSE IF (opt_cld==3) THEN
+
+    DO i = 1, klon
+      IF (todo(i)) zvapo(i) = 0.0 ! quantite de l'eau strictement condensee
+    END DO
+    DO k = k1min, k2max
+      DO i = 1, klon
+        IF (todo(i) .AND. k>=k1(i) .AND. k<=k2(i)) zvapo(i) = zvapo(i) + &
+          max(0.0, zq(i,k)-zqnew(i,k))*delp(i, k)/rg
+      END DO
+    END DO
+    DO k = k1min, k2max
+      DO i = 1, klon
+        IF (todo(i) .AND. k>=k1(i) .AND. k<=k2(i) .AND. zvapo(i)>0.0) d_ql(i, &
+          k) = d_ql(i, k) + toliq(i)*zcond(i)/zvapo(i)*max(0.0, zq(i,k)-zqnew &
+          (i,k))
+      END DO
+    END DO
+    DO i = 1, klon
+      IF (todo(i)) zrfl(i) = (1.0-toliq(i))*zcond(i)/dtime
+    END DO
+
+  ELSE IF (opt_cld==4) THEN
+
+    nexpo = 3
+    ! cc         nexpo = 1 ! distribution lineaire
+
+    DO i = 1, klon
+      IF (todo(i)) zvapo(i) = 0.0 ! quantite integrale de masse
+    END DO ! (avec ponderation)
+    DO k = k1min, k2max
+      DO i = 1, klon
+        IF (todo(i) .AND. k>=(k1(i)+1) .AND. k<=k2(i)) zvapo(i) = zvapo(i) + &
+          delp(i, k)/rg*(pplay(i,k1(i))-pplay(i,k))**nexpo
+      END DO
+    END DO
+    DO k = k1min, k2max
+      DO i = 1, klon
+        IF (todo(i) .AND. k>=(k1(i)+1) .AND. k<=k2(i)) d_ql(i, k) = d_ql(i, &
+          k) + toliq(i)*zcond(i)/zvapo(i)*(pplay(i,k1(i))-pplay(i,k))**nexpo
+      END DO
+    END DO
+    DO i = 1, klon
+      IF (todo(i)) zrfl(i) = (1.0-toliq(i))*zcond(i)/dtime
+    END DO
+
+  ELSE ! valeur non-prevue pour opt_cld
+
+    PRINT *, 'opt_cld est faux:', opt_cld
+    CALL abort
+
+  END IF ! fin de opt_cld
+
+  ! L'eau precipitante peut etre evaporee:
+
+  zalfa = 0.05
+  IF (evap_prec .AND. (k1max>=2)) THEN
+    DO k = k1max - 1, 1, -1
+      DO i = 1, klon
+        IF (todo(i) .AND. k<k1(i) .AND. zrfl(i)>0.0) THEN
+          zqev = max(0.0, (zqs(i,k)-zq(i,k))*zalfa)
+          zqevt = coef_eva*(1.0-zq(i,k)/zqs(i,k))*sqrt(zrfl(i))*delp(i, k)/ &
+            pplay(i, k)*zt(i, k)*rd/rg
+          zqevt = max(0.0, min(zqevt,zrfl(i)))*rg*dtime/delp(i, k)
+          zqev = min(zqev, zqevt)
+          zrfln = zrfl(i) - zqev*(delp(i,k))/rg/dtime
+          zq(i, k) = zq(i, k) - (zrfln-zrfl(i))*(rg/(delp(i,k)))*dtime
+          zt(i, k) = zt(i, k) + (zrfln-zrfl(i))*(rg/(delp(i, &
+            k)))*dtime*rlvtt/rcpd/(1.0+rvtmp2*zq(i,k))
+          zrfl(i) = zrfln
+        END IF
+      END DO
+    END DO
+  END IF
+
+  ! La temperature de la premiere couche determine la pluie ou la neige:
+
+  DO i = 1, klon
+    IF (todo(i)) THEN
+      IF (zt(i,1)>rtt) THEN
+        rain(i) = rain(i) + zrfl(i)
+      ELSE
+        snow(i) = snow(i) + zrfl(i)
+      END IF
+    END IF
+  END DO
+
+  ! Mise a jour de la temperature et de l'humidite
+
+  DO k = k1min, k2max
+    DO i = 1, klon
+      IF (todo(i) .AND. k>=k1(i) .AND. k<=k2(i)) THEN
+        zt(i, k) = ztnew(i, k)
+        zq(i, k) = zqnew(i, k)
+      END IF
+    END DO
+  END DO
+
+  ! Re-calculer certaines variables pour etendre et re-ajuster la colonne
+
+  IF (exigent) THEN
+    DO k = 1, klev
+      DO i = 1, klon
+        IF (todo(i)) THEN
+          IF (thermcep) THEN
+            zdelta = max(0., sign(1.,rtt-zt(i,k)))
+            zcvm5 = r5les*rlvtt*(1.-zdelta) + zdelta*r5ies*rlstt
+            zcvm5 = zcvm5/rcpd/(1.0+rvtmp2*zq(i,k))
+            zqs(i, k) = r2es*foeew(zt(i,k), zdelta)/pplay(i, k)
+            zqs(i, k) = min(0.5, zqs(i,k))
+            zcor = 1./(1.-retv*zqs(i,k))
+            zqs(i, k) = zqs(i, k)*zcor
+            zdqs(i, k) = foede(zt(i,k), zdelta, zcvm5, zqs(i,k), zcor)
+          ELSE
+            IF (zt(i,k)<t_coup) THEN
+              zqs(i, k) = qsats(zt(i,k))/pplay(i, k)
+              zdqs(i, k) = dqsats(zt(i,k), zqs(i,k))
+            ELSE
+              zqs(i, k) = qsatl(zt(i,k))/pplay(i, k)
+              zdqs(i, k) = dqsatl(zt(i,k), zqs(i,k))
+            END IF
+          END IF
+        END IF
+      END DO
+    END DO
+  END IF
+
+  IF (exigent) THEN
+    DO k = 1, klev - 1
+      DO i = 1, klon
+        IF (todo(i)) THEN
+          zgamdz(i, k) = -(pplay(i,k)-pplay(i,k+1))/paprs(i, k+1)/rcpd*(rd*( &
+            zt(i,k)*delp(i,k)+zt(i,k+1)*delp(i,k+1))/(delp(i,k)+delp(i, &
+            k+1))+rlvtt*(zqs(i,k)*delp(i,k)+zqs(i,k+1)*delp(i,k+1))/(delp(i, &
+            k)+delp(i,k+1)))/(1.0+(zdqs(i,k)*delp(i,k)+zdqs(i,k+1)*delp(i, &
+            k+1))/(delp(i,k)+delp(i,k+1)))
+        END IF
+      END DO
+    END DO
+  END IF
+
+  ! Puisque l'humidite a ete modifiee, on re-fait (q-qs)*dp
+
+  DO k = 1, klev
+    DO i = 1, klon
+      IF (todo(i)) THEN
+        zqmqsdp(i, k) = (zq(i,k)-zqs(i,k))*delp(i, k)
+      END IF
+    END DO
+  END DO
+
+  ! Verifier si l'on peut etendre le bas de la colonne
+
+  DO i = 1, klon
+    etendre(i) = .FALSE.
+  END DO
+
+  k1max = 1
+  DO i = 1, klon
+    IF (todo(i) .AND. k1(i)>(kbase+1)) THEN
+      k = k1(i)
+      zflo(i) = zt(i, k-1) + zgamdz(i, k-1) - zt(i, k)
+      zsat(i) = zqmqsdp(i, k) + zqmqsdp(i, k-1)
+      ! sc voici l'ancienne ligne:
+      ! sc         IF (zflo(i).LE.0.0 .OR. zsat(i).LE.0.0) THEN
+      ! sc sylvain: il faut RESPECTER les 2 criteres:
+      IF (zflo(i)>0.0 .AND. zsat(i)>0.0) THEN
+        etendre(i) = .TRUE.
+        k1(i) = k1(i) - 1
+        k1max = max(k1max, k1(i))
+        aller(i) = .TRUE.
+      END IF
+    END IF
+  END DO
+
+  IF (k1max>(kbase+1)) THEN
+    DO k = k1max, kbase + 1, -1
+      DO i = 1, klon
+        IF (etendre(i) .AND. k<k1(i) .AND. aller(i)) THEN
+          zsat(i) = zsat(i) + zqmqsdp(i, k)
+          zflo(i) = zt(i, k) + zgamdz(i, k) - zt(i, k+1)
+          IF (zsat(i)<=0.0 .OR. zflo(i)<=0.0) THEN
+            aller(i) = .FALSE.
+          ELSE
+            k1(i) = k
+          END IF
+        END IF
+      END DO
+    END DO
+    DO i = 1, klon
+      IF (etendre(i) .AND. aller(i)) THEN
+        k1(i) = 1
+      END IF
+    END DO
+  END IF
+
+  ! CC      DO i = 1, klon
+  ! CC      IF (etendre(i)) THEN
+  ! CC  840    k = k1(i)
+  ! CC         IF (k.GT.1) THEN
+  ! CC            zsat(i) = zsat(i) + zqmqsdp(i,k-1)
+  ! CC            zflo(i) = zt(i,k-1) + zgamdz(i,k-1) - zt(i,k)
+  ! CC            IF (zflo(i).GT.0.0 .AND. zsat(i).GT.0.0) THEN
+  ! CC               k1(i) = k - 1
+  ! CC               GOTO 840
+  ! CC            ENDIF
+  ! CC         ENDIF
+  ! CC      ENDIF
+  ! CC      ENDDO
+
+  DO i = 1, klon
+    todobis(i) = todo(i)
+    todo(i) = .FALSE.
+  END DO
+  is = 0
+  DO i = 1, klon
+    IF (etendre(i)) THEN
+      todo(i) = .TRUE.
+      is = is + 1
+    END IF
+  END DO
+  IF (is>0) THEN
+    IF (new_top) THEN
+      GO TO 820 ! chercher de nouveau le sommet k2
+    ELSE
+      GO TO 830 ! supposer que le sommet est celui deja trouve
+    END IF
+  END IF
+
+  DO i = 1, klon
+    possible(i) = .FALSE.
+  END DO
+  is = 0
+  DO i = 1, klon
+    IF (todobis(i) .AND. k2(i)<klev) THEN
+      is = is + 1
+      possible(i) = .TRUE.
+    END IF
+  END DO
+  IF (is>0) GO TO 810 !on cherche en haut d'autres blocks
+  ! a ajuster a partir du sommet de la colonne precedente
+
+860 CONTINUE ! Calculer les tendances et diagnostiques
+  ! cc      print*, "Apres 860"
+
+  DO k = 1, klev
+    DO i = 1, klon
+      IF (accompli(i)) THEN
+        d_t(i, k) = zt(i, k) - t(i, k)
+        zq(i, k) = max(zq(i,k), seuil_vap)
+        d_q(i, k) = zq(i, k) - q(i, k)
+      END IF
+    END DO
+  END DO
+
+  DO i = 1, klon
+    IF (accompli(i)) THEN
+      DO k = 1, klev
+        IF (rneb(i,k)>0.0) THEN
+          ibas(i) = k
+          GO TO 807
+        END IF
+      END DO
+807   CONTINUE
+      DO k = klev, 1, -1
+        IF (rneb(i,k)>0.0) THEN
+          itop(i) = k
+          GO TO 808
+        END IF
+      END DO
+808   CONTINUE
+    END IF
+  END DO
+
+  IF (imprim) THEN
+    nbtodo = 0
+    nbdone = 0
+    DO i = 1, klon
+      IF (afaire(i)) nbtodo = nbtodo + 1
+      IF (accompli(i)) nbdone = nbdone + 1
+    END DO
+    PRINT *, 'nbTodo, nbDone=', nbtodo, nbdone
+  END IF
+
+  RETURN
+END SUBROUTINE conmanv
+SUBROUTINE conkuo(dtime, paprs, pplay, t, q, conv_q, d_t, d_q, d_ql, rneb, &
+    rain, snow, ibas, itop)
+  USE dimphy
+  IMPLICIT NONE
+  ! ======================================================================
+  ! Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818
+  ! Objet: Schema de convection de type Kuo (1965).
+  ! Cette version du code peut calculer le niveau de depart
+  ! N.B. version vectorielle (le 6 oct. 1997)
+  ! ======================================================================
+  include "YOMCST.h"
+
+  ! Arguments:
+
+  REAL dtime ! intervalle du temps (s)
+  REAL paprs(klon, klev+1) ! pression a inter-couche (Pa)
+  REAL pplay(klon, klev) ! pression au milieu de couche (Pa)
+  REAL t(klon, klev) ! temperature (K)
+  REAL q(klon, klev) ! humidite specifique
+  REAL conv_q(klon, klev) ! taux de convergence humidite (g/g/s)
+
+  REAL d_t(klon, klev) ! incrementation temperature
+  REAL d_q(klon, klev) ! incrementation humidite
+  REAL d_ql(klon, klev) ! incrementation eau liquide
+  REAL rneb(klon, klev) ! nebulosite
+  REAL rain(klon) ! pluies (mm/s)
+  REAL snow(klon) ! neige (mm/s)
+  INTEGER itop(klon) ! niveau du sommet
+  INTEGER ibas(klon) ! niveau du bas
+
+  LOGICAL ldcum(klon) ! convection existe
+  LOGICAL todo(klon)
+
+  ! Quelsques options:
+
+  LOGICAL calcfcl ! calculer le niveau de convection libre
+  PARAMETER (calcfcl=.TRUE.)
+  INTEGER ldepar ! niveau fixe de convection libre
+  PARAMETER (ldepar=4)
+  INTEGER opt_cld ! comment traiter l'eau liquide
+  PARAMETER (opt_cld=4) ! valeur possible: 0, 1, 2, 3 ou 4
+  LOGICAL evap_prec ! evaporation de pluie au-dessous de convection
+  PARAMETER (evap_prec=.TRUE.)
+  REAL coef_eva
+  PARAMETER (coef_eva=1.0E-05)
+  LOGICAL new_deh ! nouvelle facon de calculer dH
+  PARAMETER (new_deh=.FALSE.)
+  REAL t_coup
+  PARAMETER (t_coup=234.0)
+  LOGICAL old_tau ! implique precipitation nulle
+  PARAMETER (old_tau=.FALSE.)
+  REAL toliq(klon) ! rapport entre l'eau nuageuse et l'eau precipitante
+  REAL dpmin, tomax !Epaisseur faible, rapport eau liquide plus grande
+  PARAMETER (dpmin=0.15, tomax=0.97)
+  REAL dpmax, tomin !Epaisseur grande, rapport eau liquide plus faible
+  PARAMETER (dpmax=0.30, tomin=0.05)
+  REAL deep_sig, deep_to ! au dela de deep_sig, utiliser deep_to
+  PARAMETER (deep_sig=0.50, deep_to=0.05)
+
+  ! Variables locales:
+
+  INTEGER nexpo
+  LOGICAL nuage(klon)
+  INTEGER i, k, kbmin, kbmax, khmax
+  REAL ztotal(klon, klev), zdeh(klon, klev)
+  REAL zgz(klon, klev)
+  REAL zqs(klon, klev)
+  REAL zdqs(klon, klev)
+  REAL ztemp(klon, klev)
+  REAL zpres(klon, klev)
+  REAL zconv(klon) ! convergence d'humidite
+  REAL zvirt(klon) ! convergence virtuelle d'humidite
+  REAL zfrac(klon) ! fraction convective
+  INTEGER kb(klon), kh(klon)
+
+  REAL zcond(klon), zvapo(klon), zrapp(klon)
+  REAL zrfl(klon), zrfln, zqev, zqevt
+  REAL zdelta, zcvm5, zcor
+  REAL zvar
+
+  LOGICAL appel1er
+  SAVE appel1er
+  !$OMP THREADPRIVATE(appel1er)
+
+  ! Fonctions thermodynamiques
+
+  include "YOETHF.h"
+  include "FCTTRE.h"
+
+  DATA appel1er/.TRUE./
+
+  IF (appel1er) THEN
+    PRINT *, 'conkuo, calcfcl:', calcfcl
+    IF (.NOT. calcfcl) PRINT *, 'conkuo, ldepar:', ldepar
+    PRINT *, 'conkuo, opt_cld:', opt_cld
+    PRINT *, 'conkuo, evap_prec:', evap_prec
+    PRINT *, 'conkuo, new_deh:', new_deh
+    appel1er = .FALSE.
+  END IF
+
+  ! Initialiser les sorties a zero
+
+  DO k = 1, klev
+    DO i = 1, klon
+      d_q(i, k) = 0.0
+      d_t(i, k) = 0.0
+      d_ql(i, k) = 0.0
+      rneb(i, k) = 0.0
+    END DO
+  END DO
+  DO i = 1, klon
+    rain(i) = 0.0
+    snow(i) = 0.0
+    ibas(i) = 0
+    itop(i) = 0
+  END DO
+
+  ! Calculer la vapeur d'eau saturante Qs et sa derive L/Cp * dQs/dT
+
+  DO k = 1, klev
+    DO i = 1, klon
+      IF (thermcep) THEN
+        zdelta = max(0., sign(1.,rtt-t(i,k)))
+        zcvm5 = r5les*rlvtt*(1.-zdelta) + zdelta*r5ies*rlstt
+        zcvm5 = zcvm5/rcpd/(1.0+rvtmp2*q(i,k))
+        zqs(i, k) = r2es*foeew(t(i,k), zdelta)/pplay(i, k)
+        zqs(i, k) = min(0.5, zqs(i,k))
+        zcor = 1./(1.-retv*zqs(i,k))
+        zqs(i, k) = zqs(i, k)*zcor
+        zdqs(i, k) = foede(t(i,k), zdelta, zcvm5, zqs(i,k), zcor)
+      ELSE
+        IF (t(i,k)<t_coup) THEN
+          zqs(i, k) = qsats(t(i,k))/pplay(i, k)
+          zdqs(i, k) = dqsats(t(i,k), zqs(i,k))
+        ELSE
+          zqs(i, k) = qsatl(t(i,k))/pplay(i, k)
+          zdqs(i, k) = dqsatl(t(i,k), zqs(i,k))
+        END IF
+      END IF
+    END DO
+  END DO
+
+  ! Calculer gz (energie potentielle)
+
+  DO i = 1, klon
+    zgz(i, 1) = rd*t(i, 1)/(0.5*(paprs(i,1)+pplay(i, &
+      1)))*(paprs(i,1)-pplay(i,1))
+  END DO
+  DO k = 2, klev
+    DO i = 1, klon
+      zgz(i, k) = zgz(i, k-1) + rd*0.5*(t(i,k-1)+t(i,k))/paprs(i, k)*(pplay(i &
+        ,k-1)-pplay(i,k))
+    END DO
+  END DO
+
+  ! Calculer l'energie statique humide saturee (Cp*T + gz + L*Qs)
+
+  DO k = 1, klev
+    DO i = 1, klon
+      ztotal(i, k) = rcpd*t(i, k) + rlvtt*zqs(i, k) + zgz(i, k)
+    END DO
+  END DO
+
+  ! Determiner le niveau de depart et calculer la difference de
+  ! l'energie statique humide saturee (ztotal) entre la couche
+  ! de depart et chaque couche au-dessus.
+
+  IF (calcfcl) THEN
+    DO k = 1, klev
+      DO i = 1, klon
+        zpres(i, k) = pplay(i, k)
+        ztemp(i, k) = t(i, k)
+      END DO
+    END DO
+    CALL kuofcl(ztemp, q, zgz, zpres, ldcum, kb)
+    DO i = 1, klon
+      IF (ldcum(i)) THEN
+        k = kb(i)
+        IF (new_deh) THEN
+          zdeh(i, k) = ztotal(i, k-1) - ztotal(i, k)
+        ELSE
+          zdeh(i, k) = rcpd*(t(i,k-1)-t(i,k)) - rd*0.5*(t(i,k-1)+t(i,k))/ &
+            paprs(i, k)*(pplay(i,k-1)-pplay(i,k)) + &
+            rlvtt*(zqs(i,k-1)-zqs(i,k))
+        END IF
+        zdeh(i, k) = zdeh(i, k)*0.5
+      END IF
+    END DO
+    DO k = 1, klev
+      DO i = 1, klon
+        IF (ldcum(i) .AND. k>=(kb(i)+1)) THEN
+          IF (new_deh) THEN
+            zdeh(i, k) = zdeh(i, k-1) + (ztotal(i,k-1)-ztotal(i,k))
+          ELSE
+            zdeh(i, k) = zdeh(i, k-1) + rcpd*(t(i,k-1)-t(i,k)) - &
+              rd*0.5*(t(i,k-1)+t(i,k))/paprs(i, k)* &
+              (pplay(i,k-1)-pplay(i,k)) + rlvtt*(zqs(i,k-1)-zqs(i,k))
+          END IF
+        END IF
+      END DO
+    END DO
+  ELSE
+    DO i = 1, klon
+      k = ldepar
+      kb(i) = ldepar
+      ldcum(i) = .TRUE.
+      IF (new_deh) THEN
+        zdeh(i, k) = ztotal(i, k-1) - ztotal(i, k)
+      ELSE
+        zdeh(i, k) = rcpd*(t(i,k-1)-t(i,k)) - rd*0.5*(t(i,k-1)+t(i,k))/paprs( &
+          i, k)*(pplay(i,k-1)-pplay(i,k)) + rlvtt*(zqs(i,k-1)-zqs(i,k))
+      END IF
+      zdeh(i, k) = zdeh(i, k)*0.5
+    END DO
+    DO k = ldepar + 1, klev
+      DO i = 1, klon
+        IF (new_deh) THEN
+          zdeh(i, k) = zdeh(i, k-1) + (ztotal(i,k-1)-ztotal(i,k))
+        ELSE
+          zdeh(i, k) = zdeh(i, k-1) + rcpd*(t(i,k-1)-t(i,k)) - &
+            rd*0.5*(t(i,k-1)+t(i,k))/paprs(i, k)*(pplay(i,k-1)-pplay(i,k)) + &
+            rlvtt*(zqs(i,k-1)-zqs(i,k))
+        END IF
+      END DO
+    END DO
+  END IF
+
+  ! -----Chercher le sommet du nuage
+  ! -----Calculer la convergence de l'humidite (en kg/m**2 a un facteur
+  ! -----psolpa/RG pres) du bas jusqu'au sommet du nuage.
+  ! -----Calculer la convergence virtuelle pour que toute la maille
+  ! -----deviennt nuageuse (du bas jusqu'au sommet du nuage)
+
+  DO i = 1, klon
+    nuage(i) = .TRUE.
+    zconv(i) = 0.0
+    zvirt(i) = 0.0
+    kh(i) = -999
+  END DO
+  DO k = 1, klev
+    DO i = 1, klon
+      IF (k>=kb(i) .AND. ldcum(i)) THEN
+        nuage(i) = nuage(i) .AND. zdeh(i, k) > 0.0
+        IF (nuage(i)) THEN
+          kh(i) = k
+          zconv(i) = zconv(i) + conv_q(i, k)*dtime*(paprs(i,k)-paprs(i,k+1))
+          zvirt(i) = zvirt(i) + (zdeh(i,k)/rlvtt+zqs(i,k)-q(i,k))*(paprs(i,k) &
+            -paprs(i,k+1))
+        END IF
+      END IF
+    END DO
+  END DO
+
+  DO i = 1, klon
+    todo(i) = ldcum(i) .AND. kh(i) > kb(i) .AND. zconv(i) > 0.0
+  END DO
+
+  kbmin = klev
+  kbmax = 0
+  khmax = 0
+  DO i = 1, klon
+    IF (todo(i)) THEN
+      kbmin = min(kbmin, kb(i))
+      kbmax = max(kbmax, kb(i))
+      khmax = max(khmax, kh(i))
+    END IF
+  END DO
+
+  ! -----Calculer la surface couverte par le nuage
+
+  DO i = 1, klon
+    IF (todo(i)) THEN
+      zfrac(i) = max(0.0, min(zconv(i)/zvirt(i),1.0))
+    END IF
+  END DO
+
+  ! -----Calculs essentiels:
+
+  DO i = 1, klon
+    IF (todo(i)) THEN
+      zcond(i) = 0.0
+    END IF
+  END DO
+  DO k = kbmin, khmax
+    DO i = 1, klon
+      IF (todo(i) .AND. k>=kb(i) .AND. k<=kh(i)) THEN
+        zvar = zdeh(i, k)/(1.+zdqs(i,k))
+        d_t(i, k) = zvar*zfrac(i)/rcpd
+        d_q(i, k) = (zvar*zdqs(i,k)/rlvtt+zqs(i,k)-q(i,k))*zfrac(i) - &
+          conv_q(i, k)*dtime
+        zcond(i) = zcond(i) - d_q(i, k)*(paprs(i,k)-paprs(i,k+1))/rg
+        rneb(i, k) = zfrac(i)
+      END IF
+    END DO
+  END DO
+
+  DO i = 1, klon
+    IF (todo(i) .AND. zcond(i)<0.0) THEN
+      PRINT *, 'WARNING: cond. negative (Kuo) ', i, kb(i), kh(i), zcond(i)
+      zcond(i) = 0.0
+      DO k = kb(i), kh(i)
+        d_t(i, k) = 0.0
+        d_q(i, k) = 0.0
+      END DO
+      todo(i) = .FALSE. ! effort totalement perdu
+    END IF
+  END DO
+
+  ! =====
+  ! Une fois que la condensation a lieu, on doit construire un
+  ! "modele nuageux" pour partager la condensation entre l'eau
+  ! liquide nuageuse et la precipitation (leur rapport toliq
+  ! est calcule selon l'epaisseur nuageuse). Je suppose que
+  ! toliq=tomax quand l'epaisseur nuageuse est inferieure a dpmin,
+  ! et que toliq=tomin quand l'epaisseur depasse dpmax (interpolation
+  ! lineaire entre dpmin et dpmax).
+  ! =====
+  DO i = 1, klon
+    IF (todo(i)) THEN
+      toliq(i) = tomax - ((paprs(i,kb(i))-paprs(i,kh(i)+1))/paprs(i,1)-dpmin) &
+        *(tomax-tomin)/(dpmax-dpmin)
+      toliq(i) = max(tomin, min(tomax,toliq(i)))
+      IF (pplay(i,kh(i))/paprs(i,1)<=deep_sig) toliq(i) = deep_to
+      IF (old_tau) toliq(i) = 1.0
+    END IF
+  END DO
+  ! =====
+  ! On doit aussi determiner la distribution verticale de
+  ! l'eau nuageuse. Plusieurs options sont proposees:
+
+  ! (0) La condensation precipite integralement (toliq ne sera
+  ! pas utilise).
+  ! (1) L'eau liquide est distribuee entre k1 et k2 et proportionnelle
+  ! a la vapeur d'eau locale.
+  ! (2) Elle est distribuee entre k1 et k2 avec une valeur constante.
+  ! (3) Elle est seulement distribuee aux couches ou la vapeur d'eau
+  ! est effectivement diminuee pendant le processus d'ajustement.
+  ! (4) Elle est en fonction (lineaire ou exponentielle) de la
+  ! distance (epaisseur en pression) avec le niveau k1 (la couche
+  ! k1 n'aura donc pas d'eau liquide).
+  ! =====
+
+  IF (opt_cld==0) THEN
+
+    DO i = 1, klon
+      IF (todo(i)) zrfl(i) = zcond(i)/dtime
+    END DO
+
+  ELSE IF (opt_cld==1) THEN
+
+    DO i = 1, klon
+      IF (todo(i)) zvapo(i) = 0.0 ! quantite integrale de vapeur d'eau
+    END DO
+    DO k = kbmin, khmax
+      DO i = 1, klon
+        IF (todo(i) .AND. k>=kb(i) .AND. k<=kh(i)) THEN
+          zvapo(i) = zvapo(i) + (q(i,k)+d_q(i,k))*(paprs(i,k)-paprs(i,k+1))/ &
+            rg
+        END IF
+      END DO
+    END DO
+    DO i = 1, klon
+      IF (todo(i)) THEN
+        zrapp(i) = toliq(i)*zcond(i)/zvapo(i)
+        zrapp(i) = max(0., min(1.,zrapp(i)))
+      END IF
+    END DO
+    DO k = kbmin, khmax
+      DO i = 1, klon
+        IF (todo(i) .AND. k>=kb(i) .AND. k<=kh(i)) THEN
+          d_ql(i, k) = zrapp(i)*(q(i,k)+d_q(i,k))
+        END IF
+      END DO
+    END DO
+    DO i = 1, klon
+      IF (todo(i)) THEN
+        zrfl(i) = (1.0-toliq(i))*zcond(i)/dtime
+      END IF
+    END DO
+
+  ELSE IF (opt_cld==2) THEN
+
+    DO i = 1, klon
+      IF (todo(i)) zvapo(i) = 0.0 ! quantite integrale de masse
+    END DO
+    DO k = kbmin, khmax
+      DO i = 1, klon
+        IF (todo(i) .AND. k>=kb(i) .AND. k<=kh(i)) THEN
+          zvapo(i) = zvapo(i) + (paprs(i,k)-paprs(i,k+1))/rg
+        END IF
+      END DO
+    END DO
+    DO k = kbmin, khmax
+      DO i = 1, klon
+        IF (todo(i) .AND. k>=kb(i) .AND. k<=kh(i)) THEN
+          d_ql(i, k) = toliq(i)*zcond(i)/zvapo(i)
+        END IF
+      END DO
+    END DO
+    DO i = 1, klon
+      IF (todo(i)) THEN
+        zrfl(i) = (1.0-toliq(i))*zcond(i)/dtime
+      END IF
+    END DO
+
+  ELSE IF (opt_cld==3) THEN
+
+    DO i = 1, klon
+      IF (todo(i)) THEN
+        zvapo(i) = 0.0 ! quantite de l'eau strictement condensee
+      END IF
+    END DO
+    DO k = kbmin, khmax
+      DO i = 1, klon
+        IF (todo(i) .AND. k>=kb(i) .AND. k<=kh(i)) THEN
+          zvapo(i) = zvapo(i) + max(0.0, -d_q(i,k))*(paprs(i,k)-paprs(i,k+1)) &
+            /rg
+        END IF
+      END DO
+    END DO
+    DO k = kbmin, khmax
+      DO i = 1, klon
+        IF (todo(i) .AND. k>=kb(i) .AND. k<=kh(i) .AND. zvapo(i)>0.0) THEN
+          d_ql(i, k) = d_ql(i, k) + toliq(i)*zcond(i)/zvapo(i)*max(0.0, -d_q( &
+            i,k))
+        END IF
+      END DO
+    END DO
+    DO i = 1, klon
+      IF (todo(i)) THEN
+        zrfl(i) = (1.0-toliq(i))*zcond(i)/dtime
+      END IF
+    END DO
+
+  ELSE IF (opt_cld==4) THEN
+
+    nexpo = 3
+    ! cc         nexpo = 1 ! distribution lineaire
+
+    DO i = 1, klon
+      IF (todo(i)) THEN
+        zvapo(i) = 0.0 ! quantite integrale de masse (avec ponderation)
+      END IF
+    END DO
+    DO k = kbmin, khmax
+      DO i = 1, klon
+        IF (todo(i) .AND. k>=(kb(i)+1) .AND. k<=kh(i)) THEN
+          zvapo(i) = zvapo(i) + (paprs(i,k)-paprs(i,k+1))/rg*(pplay(i,kb(i))- &
+            pplay(i,k))**nexpo
+        END IF
+      END DO
+    END DO
+    DO k = kbmin, khmax
+      DO i = 1, klon
+        IF (todo(i) .AND. k>=(kb(i)+1) .AND. k<=kh(i)) THEN
+          d_ql(i, k) = d_ql(i, k) + toliq(i)*zcond(i)/zvapo(i)*(pplay(i,kb(i) &
+            )-pplay(i,k))**nexpo
+        END IF
+      END DO
+    END DO
+    DO i = 1, klon
+      IF (todo(i)) THEN
+        zrfl(i) = (1.0-toliq(i))*zcond(i)/dtime
+      END IF
+    END DO
+
+  ELSE ! valeur non-prevue pour opt_cld
+
+    PRINT *, 'opt_cld est faux:', opt_cld
+    CALL abort
+
+  END IF ! fin de opt_cld
+
+  ! L'eau precipitante peut etre re-evaporee:
+
+  IF (evap_prec .AND. kbmax>=2) THEN
+    DO k = kbmax, 1, -1
+      DO i = 1, klon
+        IF (todo(i) .AND. k<=(kb(i)-1) .AND. zrfl(i)>0.0) THEN
+          zqev = max(0.0, (zqs(i,k)-q(i,k))*zfrac(i))
+          zqevt = coef_eva*(1.0-q(i,k)/zqs(i,k))*sqrt(zrfl(i))* &
+            (paprs(i,k)-paprs(i,k+1))/pplay(i, k)*t(i, k)*rd/rg
+          zqevt = max(0.0, min(zqevt,zrfl(i)))*rg*dtime/ &
+            (paprs(i,k)-paprs(i,k+1))
+          zqev = min(zqev, zqevt)
+          zrfln = zrfl(i) - zqev*(paprs(i,k)-paprs(i,k+1))/rg/dtime
+          d_q(i, k) = -(zrfln-zrfl(i))*(rg/(paprs(i,k)-paprs(i,k+1)))*dtime
+          d_t(i, k) = (zrfln-zrfl(i))*(rg/(paprs(i,k)-paprs(i, &
+            k+1)))*dtime*rlvtt/rcpd
+          zrfl(i) = zrfln
+        END IF
+      END DO
+    END DO
+  END IF
+
+  ! La temperature de la premiere couche determine la pluie ou la neige:
+
+  DO i = 1, klon
+    IF (todo(i)) THEN
+      IF (t(i,1)>rtt) THEN
+        rain(i) = rain(i) + zrfl(i)
+      ELSE
+        snow(i) = snow(i) + zrfl(i)
+      END IF
+    END IF
+  END DO
+
+  RETURN
+END SUBROUTINE conkuo
+SUBROUTINE kuofcl(pt, pq, pg, pp, ldcum, kcbot)
+  USE dimphy
+  IMPLICIT NONE
+  ! ======================================================================
+  ! Auteur(s): Z.X. Li (LMD/CNRS) date: 19940927
+  ! adaptation du code de Tiedtke du ECMWF
+  ! Objet: calculer le niveau de convection libre
+  ! (FCL: Free Convection Level)
+  ! ======================================================================
+  ! Arguments:
+  ! pt---input-R- temperature (K)
+  ! pq---input-R- vapeur d'eau (kg/kg)
+  ! pg---input-R- geopotentiel (g*z ou z est en metre)
+  ! pp---input-R- pression (Pa)
+
+  ! LDCUM---output-L- Y-t-il la convection
+  ! kcbot---output-I- Niveau du bas de la convection
+  ! ======================================================================
+  include "YOMCST.h"
+  include "YOETHF.h"
+
+  REAL pt(klon, klev), pq(klon, klev), pg(klon, klev), pp(klon, klev)
+  INTEGER kcbot(klon)
+  LOGICAL ldcum(klon)
+
+  REAL ztu(klon, klev), zqu(klon, klev), zlu(klon, klev)
+  REAL zqold(klon), zbuo
+  INTEGER is, i, k
+
+  ! klab=1: on est sous le nuage convectif
+  ! klab=2: le bas du nuage convectif
+  ! klab=0: autres couches
+  INTEGER klab(klon, klev)
+
+  ! quand lflag=.true., on est sous le nuage, il faut donc appliquer
+  ! le processus d'elevation.
+  LOGICAL lflag(klon)
+
+  DO k = 1, klev
+    DO i = 1, klon
+      ztu(i, k) = pt(i, k)
+      zqu(i, k) = pq(i, k)
+      zlu(i, k) = 0.0
+      klab(i, k) = 0
+    END DO
+  END DO
+  ! ----------------------------------------------------------------------
+  DO i = 1, klon
+    klab(i, 1) = 1
+    kcbot(i) = 2
+    ldcum(i) = .FALSE.
+  END DO
+
+  DO k = 2, klev - 1
+
+    is = 0
+    DO i = 1, klon
+      IF (klab(i,k-1)==1) is = is + 1
+      lflag(i) = .FALSE.
+      IF (klab(i,k-1)==1) lflag(i) = .TRUE.
+    END DO
+    IF (is==0) GO TO 290
+
+    ! on eleve le parcel d'air selon l'adiabatique sec
+
+    DO i = 1, klon
+      IF (lflag(i)) THEN
+        zqu(i, k) = zqu(i, k-1)
+        ztu(i, k) = ztu(i, k-1) + (pg(i,k-1)-pg(i,k))/rcpd
+        zbuo = ztu(i, k)*(1.+retv*zqu(i,k)) - pt(i, k)*(1.+retv*pq(i,k)) + &
+          0.5
+        IF (zbuo>0.) klab(i, k) = 1
+        zqold(i) = zqu(i, k)
+      END IF
+    END DO
+
+    ! on calcule la condensation eventuelle
+
+    CALL adjtq(pp(1,k), ztu(1,k), zqu(1,k), lflag, 1)
+
+    ! s'il y a la condensation et la "buoyancy" force est positive
+    ! c'est bien le bas de la tour de convection
+
+    DO i = 1, klon
+      IF (lflag(i) .AND. zqu(i,k)/=zqold(i)) THEN
+        klab(i, k) = 2
+        zlu(i, k) = zlu(i, k) + zqold(i) - zqu(i, k)
+        zbuo = ztu(i, k)*(1.+retv*zqu(i,k)) - pt(i, k)*(1.+retv*pq(i,k)) + &
+          0.5
+        IF (zbuo>0.) THEN
+          kcbot(i) = k
+          ldcum(i) = .TRUE.
+        END IF
+      END IF
+    END DO
+
+290 END DO
+
+  RETURN
+END SUBROUTINE kuofcl
+SUBROUTINE adjtq(pp, pt, pq, ldflag, kcall)
+  USE dimphy
+  IMPLICIT NONE
+  ! ======================================================================
+  ! Auteur(s): Z.X. Li (LMD/CNRS) date: 19940927
+  ! adaptation du code de Tiedtke du ECMWF
+  ! Objet: ajustement entre T et Q
+  ! ======================================================================
+  ! Arguments:
+  ! pp---input-R- pression (Pa)
+  ! pt---input/output-R- temperature (K)
+  ! pq---input/output-R- vapeur d'eau (kg/kg)
+  ! ======================================================================
+  ! TO PRODUCE T,Q AND L VALUES FOR CLOUD ASCENT
+
+  ! NOTE: INPUT PARAMETER KCALL DEFINES CALCULATION AS
+  ! KCALL=0    ENV. T AND QS IN*CUINI*
+  ! KCALL=1  CONDENSATION IN UPDRAFTS  (E.G. CUBASE, CUASC)
+  ! KCALL=2  EVAPORATION IN DOWNDRAFTS (E.G. CUDLFS,CUDDRAF)
+
+  include "YOMCST.h"
+
+  REAL pt(klon), pq(klon), pp(klon)
+  LOGICAL ldflag(klon)
+  INTEGER kcall
+
+  REAL t_coup
+  PARAMETER (t_coup=234.0)
+
+  REAL zcond(klon), zcond1
+  REAL zdelta, zcvm5, zldcp, zqsat, zcor, zdqsat
+  INTEGER is, i
+  include "YOETHF.h"
+  include "FCTTRE.h"
+
+  DO i = 1, klon
+    zcond(i) = 0.0
+  END DO
+
+  DO i = 1, klon
+    IF (ldflag(i)) THEN
+      zdelta = max(0., sign(1.,rtt-pt(i)))
+      zldcp = rlvtt*(1.-zdelta) + zdelta*rlstt
+      zldcp = zldcp/rcpd/(1.0+rvtmp2*pq(i))
+      IF (thermcep) THEN
+        zcvm5 = r5les*rlvtt*(1.-zdelta) + zdelta*r5ies*rlstt
+        zcvm5 = zcvm5/rcpd/(1.0+rvtmp2*pq(i))
+        zqsat = r2es*foeew(pt(i), zdelta)/pp(i)
+        zqsat = min(0.5, zqsat)
+        zcor = 1./(1.-retv*zqsat)
+        zqsat = zqsat*zcor
+        zdqsat = foede(pt(i), zdelta, zcvm5, zqsat, zcor)
+      ELSE
+        IF (pt(i)<t_coup) THEN
+          zqsat = qsats(pt(i))/pp(i)
+          zdqsat = dqsats(pt(i), zqsat)
+        ELSE
+          zqsat = qsatl(pt(i))/pp(i)
+          zdqsat = dqsatl(pt(i), zqsat)
+        END IF
+      END IF
+      zcond(i) = (pq(i)-zqsat)/(1.+zdqsat)
+      IF (kcall==1) zcond(i) = max(zcond(i), 0.)
+      IF (kcall==2) zcond(i) = min(zcond(i), 0.)
+      pt(i) = pt(i) + zldcp*zcond(i)
+      pq(i) = pq(i) - zcond(i)
+    END IF
+  END DO
+
+  is = 0
+  DO i = 1, klon
+    IF (zcond(i)/=0.) is = is + 1
+  END DO
+  IF (is==0) GO TO 230
+
+  DO i = 1, klon
+    IF (ldflag(i) .AND. zcond(i)/=0.) THEN
+      zdelta = max(0., sign(1.,rtt-pt(i)))
+      zldcp = rlvtt*(1.-zdelta) + zdelta*rlstt
+      zldcp = zldcp/rcpd/(1.0+rvtmp2*pq(i))
+      IF (thermcep) THEN
+        zcvm5 = r5les*rlvtt*(1.-zdelta) + zdelta*r5ies*rlstt
+        zcvm5 = zcvm5/rcpd/(1.0+rvtmp2*pq(i))
+        zqsat = r2es*foeew(pt(i), zdelta)/pp(i)
+        zqsat = min(0.5, zqsat)
+        zcor = 1./(1.-retv*zqsat)
+        zqsat = zqsat*zcor
+        zdqsat = foede(pt(i), zdelta, zcvm5, zqsat, zcor)
+      ELSE
+        IF (pt(i)<t_coup) THEN
+          zqsat = qsats(pt(i))/pp(i)
+          zdqsat = dqsats(pt(i), zqsat)
+        ELSE
+          zqsat = qsatl(pt(i))/pp(i)
+          zdqsat = dqsatl(pt(i), zqsat)
+        END IF
+      END IF
+      zcond1 = (pq(i)-zqsat)/(1.+zdqsat)
+      pt(i) = pt(i) + zldcp*zcond1
+      pq(i) = pq(i) - zcond1
+    END IF
+  END DO
+
+230 CONTINUE
+  RETURN
+END SUBROUTINE adjtq
+SUBROUTINE fiajh(dtime, paprs, pplay, t, q, d_t, d_q, d_ql, rneb, rain, snow, &
+    ibas, itop)
+  USE dimphy
+  IMPLICIT NONE
+
+  ! Ajustement humide (Schema de convection de Manabe)
+  ! .
+  include "YOMCST.h"
+
+  ! Arguments:
+
+  REAL dtime ! intervalle du temps (s)
+  REAL t(klon, klev) ! temperature (K)
+  REAL q(klon, klev) ! humidite specifique (kg/kg)
+  REAL paprs(klon, klev+1) ! pression a inter-couche (Pa)
+  REAL pplay(klon, klev) ! pression au milieu de couche (Pa)
+
+  REAL d_t(klon, klev) ! incrementation pour la temperature
+  REAL d_q(klon, klev) ! incrementation pour vapeur d'eau
+  REAL d_ql(klon, klev) ! incrementation pour l'eau liquide
+  REAL rneb(klon, klev) ! fraction nuageuse
+
+  REAL rain(klon) ! variable non utilisee
+  REAL snow(klon) ! variable non utilisee
+  INTEGER ibas(klon) ! variable non utilisee
+  INTEGER itop(klon) ! variable non utilisee
+
+  REAL t_coup
+  PARAMETER (t_coup=234.0)
+  REAL seuil_vap
+  PARAMETER (seuil_vap=1.0E-10)
+
+  ! Variables locales:
+
+  INTEGER i, k
+  INTEGER k1, k1p, k2, k2p
+  LOGICAL itest(klon)
+  REAL delta_q(klon, klev)
+  REAL cp_new_t(klev)
+  REAL cp_delta_t(klev)
+  REAL new_qb(klev)
+  REAL v_cptj(klev), v_cptjk1, v_ssig
+  REAL v_cptt(klon, klev), v_p, v_t
+  REAL v_qs(klon, klev), v_qsd(klon, klev)
+  REAL zq1(klon), zq2(klon)
+  REAL gamcpdz(klon, 2:klev)
+  REAL zdp, zdpm
+
+  REAL zsat ! sur-saturation
+  REAL zflo ! flotabilite
+
+  REAL local_q(klon, klev), local_t(klon, klev)
+
+  REAL zdelta, zcor, zcvm5
+
+  include "YOETHF.h"
+  include "FCTTRE.h"
+
+  DO k = 1, klev
+    DO i = 1, klon
+      local_q(i, k) = q(i, k)
+      local_t(i, k) = t(i, k)
+      rneb(i, k) = 0.0
+      d_ql(i, k) = 0.0
+      d_t(i, k) = 0.0
+      d_q(i, k) = 0.0
+    END DO
+  END DO
+  DO i = 1, klon
+    rain(i) = 0.0
+    snow(i) = 0.0
+    ibas(i) = 0
+    itop(i) = 0
+  END DO
+
+  ! Calculer v_qs et v_qsd:
+
+  DO k = 1, klev
+    DO i = 1, klon
+      v_cptt(i, k) = rcpd*local_t(i, k)
+      v_t = local_t(i, k)
+      v_p = pplay(i, k)
+
+      IF (thermcep) THEN
+        zdelta = max(0., sign(1.,rtt-v_t))
+        zcvm5 = r5les*rlvtt*(1.-zdelta) + zdelta*r5ies*rlstt
+        zcvm5 = zcvm5/rcpd/(1.0+rvtmp2*local_q(i,k))
+        v_qs(i, k) = r2es*foeew(v_t, zdelta)/v_p
+        v_qs(i, k) = min(0.5, v_qs(i,k))
+        zcor = 1./(1.-retv*v_qs(i,k))
+        v_qs(i, k) = v_qs(i, k)*zcor
+        v_qsd(i, k) = foede(v_t, zdelta, zcvm5, v_qs(i,k), zcor)
+      ELSE
+        IF (v_t<t_coup) THEN
+          v_qs(i, k) = qsats(v_t)/v_p
+          v_qsd(i, k) = dqsats(v_t, v_qs(i,k))
+        ELSE
+          v_qs(i, k) = qsatl(v_t)/v_p
+          v_qsd(i, k) = dqsatl(v_t, v_qs(i,k))
+        END IF
+      END IF
+    END DO
+  END DO
+
+  ! Calculer Gamma * Cp * dz: (gamm est le gradient critique)
+
+  DO k = 2, klev
+    DO i = 1, klon
+      zdp = paprs(i, k) - paprs(i, k+1)
+      zdpm = paprs(i, k-1) - paprs(i, k)
+      gamcpdz(i, k) = ((rd/rcpd/(zdpm+zdp)*(v_cptt(i,k-1)*zdpm+ &
+        v_cptt(i,k)*zdp)+rlvtt/(zdpm+zdp)*(v_qs(i,k-1)*zdpm+ &
+        v_qs(i,k)*zdp))*(pplay(i,k-1)-pplay(i,k))/paprs(i,k))/(1.0+(v_qsd(i, &
+        k-1)*zdpm+v_qsd(i,k)*zdp)/(zdpm+zdp))
+    END DO
+  END DO
+
+  ! ------------------------------------ modification des profils instables
+  DO i = 1, klon
+    itest(i) = .FALSE.
+
+    k1 = 0
+    k2 = 1
+
+810 CONTINUE ! chercher k1, le bas de la colonne
+    k2 = k2 + 1
+    IF (k2>klev) GO TO 9999
+    zflo = v_cptt(i, k2-1) - v_cptt(i, k2) - gamcpdz(i, k2)
+    zsat = (local_q(i,k2-1)-v_qs(i,k2-1))*(paprs(i,k2-1)-paprs(i,k2)) + &
+      (local_q(i,k2)-v_qs(i,k2))*(paprs(i,k2)-paprs(i,k2+1))
+    IF (zflo<=0.0 .OR. zsat<=0.0) GO TO 810
+    k1 = k2 - 1
+    itest(i) = .TRUE.
+
+820 CONTINUE ! chercher k2, le haut de la colonne
+    IF (k2==klev) GO TO 821
+    k2p = k2 + 1
+    zsat = zsat + (paprs(i,k2p)-paprs(i,k2p+1))*(local_q(i,k2p)-v_qs(i,k2p))
+    zflo = v_cptt(i, k2p-1) - v_cptt(i, k2p) - gamcpdz(i, k2p)
+    IF (zflo<=0.0 .OR. zsat<=0.0) GO TO 821
+    k2 = k2p
+    GO TO 820
+821 CONTINUE
+
+    ! ------------------------------------------------------ ajustement local
+830 CONTINUE ! ajustement proprement dit
+    v_cptj(k1) = 0.0
+    zdp = paprs(i, k1) - paprs(i, k1+1)
+    v_cptjk1 = ((1.0+v_qsd(i,k1))*(v_cptt(i,k1)+v_cptj(k1))+rlvtt*(local_q(i, &
+      k1)-v_qs(i,k1)))*zdp
+    v_ssig = zdp*(1.0+v_qsd(i,k1))
+
+    k1p = k1 + 1
+    DO k = k1p, k2
+      zdp = paprs(i, k) - paprs(i, k+1)
+      v_cptj(k) = v_cptj(k-1) + gamcpdz(i, k)
+      v_cptjk1 = v_cptjk1 + zdp*((1.0+v_qsd(i,k))*(v_cptt(i, &
+        k)+v_cptj(k))+rlvtt*(local_q(i,k)-v_qs(i,k)))
+      v_ssig = v_ssig + zdp*(1.0+v_qsd(i,k))
+    END DO
+
+    DO k = k1, k2
+      cp_new_t(k) = v_cptjk1/v_ssig - v_cptj(k)
+      cp_delta_t(k) = cp_new_t(k) - v_cptt(i, k)
+      new_qb(k) = v_qs(i, k) + v_qsd(i, k)*cp_delta_t(k)/rlvtt
+      local_q(i, k) = new_qb(k)
+      local_t(i, k) = cp_new_t(k)/rcpd
+    END DO
+
+    ! --------------------------------------------------- sondage vers le bas
+    ! -- on redefinit les variables prognostiques dans
+    ! -- la colonne qui vient d'etre ajustee
+
+    DO k = k1, k2
+      v_cptt(i, k) = rcpd*local_t(i, k)
+      v_t = local_t(i, k)
+      v_p = pplay(i, k)
+
+      IF (thermcep) THEN
+        zdelta = max(0., sign(1.,rtt-v_t))
+        zcvm5 = r5les*rlvtt*(1.-zdelta) + zdelta*r5ies*rlstt
+        zcvm5 = zcvm5/rcpd/(1.0+rvtmp2*local_q(i,k))
+        v_qs(i, k) = r2es*foeew(v_t, zdelta)/v_p
+        v_qs(i, k) = min(0.5, v_qs(i,k))
+        zcor = 1./(1.-retv*v_qs(i,k))
+        v_qs(i, k) = v_qs(i, k)*zcor
+        v_qsd(i, k) = foede(v_t, zdelta, zcvm5, v_qs(i,k), zcor)
+      ELSE
+        IF (v_t<t_coup) THEN
+          v_qs(i, k) = qsats(v_t)/v_p
+          v_qsd(i, k) = dqsats(v_t, v_qs(i,k))
+        ELSE
+          v_qs(i, k) = qsatl(v_t)/v_p
+          v_qsd(i, k) = dqsatl(v_t, v_qs(i,k))
+        END IF
+      END IF
+    END DO
+    DO k = 2, klev
+      zdpm = paprs(i, k-1) - paprs(i, k)
+      zdp = paprs(i, k) - paprs(i, k+1)
+      gamcpdz(i, k) = ((rd/rcpd/(zdpm+zdp)*(v_cptt(i,k-1)*zdpm+ &
+        v_cptt(i,k)*zdp)+rlvtt/(zdpm+zdp)*(v_qs(i,k-1)*zdpm+ &
+        v_qs(i,k)*zdp))*(pplay(i,k-1)-pplay(i,k))/paprs(i,k))/(1.0+(v_qsd(i, &
+        k-1)*zdpm+v_qsd(i,k)*zdp)/(zdpm+zdp))
+    END DO
+
+    ! Verifier si l'on peut etendre la colonne vers le bas
+
+    IF (k1==1) GO TO 841 ! extension echouee
+    zflo = v_cptt(i, k1-1) - v_cptt(i, k1) - gamcpdz(i, k1)
+    zsat = (local_q(i,k1-1)-v_qs(i,k1-1))*(paprs(i,k1-1)-paprs(i,k1)) + &
+      (local_q(i,k1)-v_qs(i,k1))*(paprs(i,k1)-paprs(i,k1+1))
+    IF (zflo<=0.0 .OR. zsat<=0.0) GO TO 841 ! extension echouee
+
+840 CONTINUE
+    k1 = k1 - 1
+    IF (k1==1) GO TO 830 ! GOTO 820 (a tester, Z.X.Li, mars 1995)
+    zsat = zsat + (local_q(i,k1-1)-v_qs(i,k1-1))*(paprs(i,k1-1)-paprs(i,k1))
+    zflo = v_cptt(i, k1-1) - v_cptt(i, k1) - gamcpdz(i, k1)
+    IF (zflo>0.0 .AND. zsat>0.0) THEN
+      GO TO 840
+    ELSE
+      GO TO 830 ! GOTO 820 (a tester, Z.X.Li, mars 1995)
+    END IF
+841 CONTINUE
+
+    GO TO 810 ! chercher d'autres blocks en haut
+
+9999 END DO ! boucle sur tous les points
+  ! -----------------------------------------------------------------------
+
+  ! Determiner la fraction nuageuse (hypothese: la nebulosite a lieu
+  ! a l'endroit ou la vapeur d'eau est diminuee par l'ajustement):
+
+  DO k = 1, klev
+    DO i = 1, klon
+      IF (itest(i)) THEN
+        delta_q(i, k) = local_q(i, k) - q(i, k)
+        IF (delta_q(i,k)<0.) rneb(i, k) = 1.0
+      END IF
+    END DO
+  END DO
+
+  ! Distribuer l'eau condensee en eau liquide nuageuse (hypothese:
+  ! l'eau liquide est distribuee aux endroits ou la vapeur d'eau
+  ! diminue et d'une maniere proportionnelle a cet diminution):
+
+  DO i = 1, klon
+    IF (itest(i)) THEN
+      zq1(i) = 0.0
+      zq2(i) = 0.0
+    END IF
+  END DO
+  DO k = 1, klev
+    DO i = 1, klon
+      IF (itest(i)) THEN
+        zdp = paprs(i, k) - paprs(i, k+1)
+        zq1(i) = zq1(i) - delta_q(i, k)*zdp
+        zq2(i) = zq2(i) - min(0.0, delta_q(i,k))*zdp
+      END IF
+    END DO
+  END DO
+  DO k = 1, klev
+    DO i = 1, klon
+      IF (itest(i)) THEN
+        IF (zq2(i)/=0.0) d_ql(i, k) = -min(0.0, delta_q(i,k))*zq1(i)/zq2(i)
+      END IF
+    END DO
+  END DO
+
+  DO k = 1, klev
+    DO i = 1, klon
+      local_q(i, k) = max(local_q(i,k), seuil_vap)
+    END DO
+  END DO
+
+  DO k = 1, klev
+    DO i = 1, klon
+      d_t(i, k) = local_t(i, k) - t(i, k)
+      d_q(i, k) = local_q(i, k) - q(i, k)
+    END DO
+  END DO
+
+  RETURN
+END SUBROUTINE fiajh
+SUBROUTINE fiajc(dtime, paprs, pplay, t, q, conv_q, d_t, d_q, d_ql, rneb, &
+    rain, snow, ibas, itop)
+  USE dimphy
+  IMPLICIT NONE
+
+  include "YOMCST.h"
+
+  ! Options:
+
+  INTEGER plb ! niveau de depart pour la convection
+  PARAMETER (plb=4)
+
+  ! Mystere: cette option n'est pas innocente pour les resultats !
+  ! Qui peut resoudre ce mystere ? (Z.X.Li mars 1995)
+  LOGICAL vector ! calcul vectorise
+  PARAMETER (vector=.FALSE.)
+
+  REAL t_coup
+  PARAMETER (t_coup=234.0)
+
+  ! Arguments:
+
+  REAL q(klon, klev) ! humidite specifique (kg/kg)
+  REAL t(klon, klev) ! temperature (K)
+  REAL paprs(klon, klev+1) ! pression a inter-couche (Pa)
+  REAL pplay(klon, klev) ! pression au milieu de couche (Pa)
+  REAL dtime ! intervalle du temps (s)
+  REAL conv_q(klon, klev) ! taux de convergence de l'humidite
+  REAL rneb(klon, klev) ! fraction nuageuse
+  REAL d_q(klon, klev) ! incrementaion pour la vapeur d'eau
+  REAL d_ql(klon, klev) ! incrementation pour l'eau liquide
+  REAL d_t(klon, klev) ! incrementation pour la temperature
+  REAL rain(klon) ! variable non-utilisee
+  REAL snow(klon) ! variable non-utilisee
+  INTEGER itop(klon) ! variable non-utilisee
+  INTEGER ibas(klon) ! variable non-utilisee
+
+  INTEGER kh(klon), i, k
+  LOGICAL nuage(klon), test(klon, klev)
+  REAL zconv(klon), zdeh(klon, klev), zvirt(klon)
+  REAL zdqs(klon, klev), zqs(klon, klev)
+  REAL ztt, zvar, zfrac(klon)
+  REAL zq1(klon), zq2(klon)
+  REAL zdelta, zcor, zcvm5
+
+  include "YOETHF.h"
+  include "FCTTRE.h"
+
+  ! Initialiser les sorties:
+
+  DO k = 1, klev
+    DO i = 1, klon
+      rneb(i, k) = 0.0
+      d_ql(i, k) = 0.0
+      d_t(i, k) = 0.0
+      d_q(i, k) = 0.0
+    END DO
+  END DO
+  DO i = 1, klon
+    itop(i) = 0
+    ibas(i) = 0
+    rain(i) = 0.0
+    snow(i) = 0.0
+  END DO
+
+  ! Calculer Qs et L/Cp * dQs/dT:
+
+  DO k = 1, klev
+    DO i = 1, klon
+      ztt = t(i, k)
+      IF (thermcep) THEN
+        zdelta = max(0., sign(1.,rtt-ztt))
+        zcvm5 = r5les*rlvtt*(1.-zdelta) + zdelta*r5ies*rlstt
+        zcvm5 = zcvm5/rcpd/(1.0+rvtmp2*q(i,k))
+        zqs(i, k) = r2es*foeew(ztt, zdelta)/pplay(i, k)
+        zqs(i, k) = min(0.5, zqs(i,k))
+        zcor = 1./(1.-retv*zqs(i,k))
+        zqs(i, k) = zqs(i, k)*zcor
+        zdqs(i, k) = foede(ztt, zdelta, zcvm5, zqs(i,k), zcor)
+      ELSE
+        IF (ztt<t_coup) THEN
+          zqs(i, k) = qsats(ztt)/pplay(i, k)
+          zdqs(i, k) = dqsats(ztt, zqs(i,k))
+        ELSE
+          zqs(i, k) = qsatl(ztt)/pplay(i, k)
+          zdqs(i, k) = dqsatl(ztt, zqs(i,k))
+        END IF
+      END IF
+    END DO
+  END DO
+
+  ! Determiner la difference de l'energie totale saturee:
+
+  DO i = 1, klon
+    k = plb
+    zdeh(i, k) = rcpd*(t(i,k-1)-t(i,k)) - rd*0.5*(t(i,k-1)+t(i,k))/paprs(i, k &
+      )*(pplay(i,k-1)-pplay(i,k)) + rlvtt*(zqs(i,k-1)-zqs(i,k))
+    zdeh(i, k) = zdeh(i, k)*0.5 ! on prend la moitie
+  END DO
+  DO k = plb + 1, klev
+    DO i = 1, klon
+      zdeh(i, k) = zdeh(i, k-1) + rcpd*(t(i,k-1)-t(i,k)) - &
+        rd*0.5*(t(i,k-1)+t(i,k))/paprs(i, k)*(pplay(i,k-1)-pplay(i,k)) + &
+        rlvtt*(zqs(i,k-1)-zqs(i,k))
+    END DO
+  END DO
+
+  ! Determiner le sommet du nuage selon l'instabilite
+  ! Calculer les convergences d'humidite (reelle et virtuelle)
+
+  DO i = 1, klon
+    nuage(i) = .TRUE.
+    zconv(i) = 0.0
+    zvirt(i) = 0.0
+    kh(i) = -999
+  END DO
+  DO k = plb, klev
+    DO i = 1, klon
+      nuage(i) = nuage(i) .AND. zdeh(i, k) > 0.0
+      IF (nuage(i)) THEN
+        kh(i) = k
+        zconv(i) = zconv(i) + conv_q(i, k)*dtime*(paprs(i,k)-paprs(i,k+1))
+        zvirt(i) = zvirt(i) + (zdeh(i,k)/rlvtt+zqs(i,k)-q(i,k))*(paprs(i,k)- &
+          paprs(i,k+1))
+      END IF
+    END DO
+  END DO
+
+  IF (vector) THEN
+
+
+    DO k = plb, klev
+      DO i = 1, klon
+        IF (k<=kh(i) .AND. kh(i)>plb .AND. zconv(i)>0.0) THEN
+          test(i, k) = .TRUE.
+          zfrac(i) = max(0.0, min(zconv(i)/zvirt(i),1.0))
+        ELSE
+          test(i, k) = .FALSE.
+        END IF
+      END DO
+    END DO
+
+    DO k = plb, klev
+      DO i = 1, klon
+        IF (test(i,k)) THEN
+          zvar = zdeh(i, k)/(1.0+zdqs(i,k))
+          d_q(i, k) = (zvar*zdqs(i,k)/rlvtt+zqs(i,k)-q(i,k))*zfrac(i) - &
+            conv_q(i, k)*dtime
+          d_t(i, k) = zvar*zfrac(i)/rcpd
+        END IF
+      END DO
+    END DO
+
+    DO i = 1, klon
+      zq1(i) = 0.0
+      zq2(i) = 0.0
+    END DO
+    DO k = plb, klev
+      DO i = 1, klon
+        IF (test(i,k)) THEN
+          IF (d_q(i,k)<0.0) rneb(i, k) = zfrac(i)
+          zq1(i) = zq1(i) - d_q(i, k)*(paprs(i,k)-paprs(i,k+1))
+          zq2(i) = zq2(i) - min(0.0, d_q(i,k))*(paprs(i,k)-paprs(i,k+1))
+        END IF
+      END DO
+    END DO
+
+    DO k = plb, klev
+      DO i = 1, klon
+        IF (test(i,k)) THEN
+          IF (zq2(i)/=0.) d_ql(i, k) = -min(0.0, d_q(i,k))*zq1(i)/zq2(i)
+        END IF
+      END DO
+    END DO
+
+  ELSE ! (.NOT. vector)
+
+    DO i = 1, klon
+      IF (kh(i)>plb .AND. zconv(i)>0.0) THEN
+        ! cc         IF (kh(i).LE.plb) GOTO 999 ! il n'y a pas d'instabilite
+        ! cc         IF (zconv(i).LE.0.0) GOTO 999 ! convergence insuffisante
+        zfrac(i) = max(0.0, min(zconv(i)/zvirt(i),1.0))
+        DO k = plb, kh(i)
+          zvar = zdeh(i, k)/(1.0+zdqs(i,k))
+          d_q(i, k) = (zvar*zdqs(i,k)/rlvtt+zqs(i,k)-q(i,k))*zfrac(i) - &
+            conv_q(i, k)*dtime
+          d_t(i, k) = zvar*zfrac(i)/rcpd
+        END DO
+
+        zq1(i) = 0.0
+        zq2(i) = 0.0
+        DO k = plb, kh(i)
+          IF (d_q(i,k)<0.0) rneb(i, k) = zfrac(i)
+          zq1(i) = zq1(i) - d_q(i, k)*(paprs(i,k)-paprs(i,k+1))
+          zq2(i) = zq2(i) - min(0.0, d_q(i,k))*(paprs(i,k)-paprs(i,k+1))
+        END DO
+        DO k = plb, kh(i)
+          IF (zq2(i)/=0.) d_ql(i, k) = -min(0.0, d_q(i,k))*zq1(i)/zq2(i)
+        END DO
+      END IF
+    END DO
+
+  END IF ! fin de teste sur vector
+
+  RETURN
+END SUBROUTINE fiajc
Index: DZ6/trunk/libf/phylmd/convect1.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/convect1.F90	(revision 5267)
+++ 	(revision )
@@ -1,641 +1,0 @@
-
-! $Header$
-
-SUBROUTINE convect1(len, nd, ndp1, noff, minorig, t, q, qs, u, v, p, ph, &
-    iflag, ft, fq, fu, fv, precip, cbmf, delt, ma)
-  ! .............................START PROLOGUE............................
-
-  ! SCCS IDENTIFICATION:  @(#)convect1.f	1.1 04/21/00
-  ! 19:40:52 /h/cm/library/nogaps4/src/sub/fcst/convect1.f_v
-
-  ! CONFIGURATION IDENTIFICATION:  None
-
-  ! MODULE NAME:  convect1
-
-  ! DESCRIPTION:
-
-  ! convect1     The Emanuel Cumulus Convection Scheme
-
-  ! CONTRACT NUMBER AND TITLE:  None
-
-  ! REFERENCES: Programmers  K. Emanuel (MIT), Timothy F. Hogan, M. Peng
-  ! (NRL)
-
-  ! CLASSIFICATION:  Unclassified
-
-  ! RESTRICTIONS: None
-
-  ! COMPILER DEPENDENCIES: FORTRAN 77, FORTRAN 90
-
-  ! COMPILE OPTIONS: Fortran 77: -Zu -Wf"-ei -o aggress"
-  ! Fortran 90: -O vector3,scalar3,task1,aggress,overindex  -ei -r 2
-
-  ! LIBRARIES OF RESIDENCE: /a/ops/lib/libfcst159.a
-
-  ! USAGE: call convect1(len,nd,noff,minorig,
-  ! &                   t,q,qs,u,v,
-  ! &                   p,ph,iflag,ft,
-  ! &                   fq,fu,fv,precip,cbmf,delt)
-
-  ! PARAMETERS:
-  ! Name            Type         Usage            Description
-  ! ----------      ----------     -------  ----------------------------
-
-  ! len           Integer        Input        first (i) dimension
-  ! nd            Integer        Input        vertical (k) dimension
-  ! ndp1          Integer        Input        nd + 1
-  ! noff          Integer        Input        integer limit for convection
-  ! (nd-noff)
-  ! minorig       Integer        Input        First level of convection
-  ! t             Real           Input        temperature
-  ! q             Real           Input        specific hum
-  ! qs            Real           Input        sat specific hum
-  ! u             Real           Input        u-wind
-  ! v             Real           Input        v-wind
-  ! p             Real           Input        full level pressure
-  ! ph            Real           Input        half level pressure
-  ! iflag         Integer        Output       iflag on latitude strip
-  ! ft            Real           Output       temp tend
-  ! fq            Real           Output       spec hum tend
-  ! fu            Real           Output       u-wind tend
-  ! fv            Real           Output       v-wind tend
-  ! cbmf          Real           In/Out       cumulus mass flux
-  ! delt          Real           Input        time step
-  ! iflag         Integer        Output       integer flag for Emanuel
-  ! conditions
-
-  ! COMMON BLOCKS:
-  ! Block      Name     Type    Usage              Notes
-  ! --------  --------   ----    ------   ------------------------
-
-  ! FILES: None
-
-  ! DATA BASES: None
-
-  ! NON-FILE INPUT/OUTPUT: None
-
-  ! ERROR CONDITIONS: None
-
-  ! ADDITIONAL COMMENTS: None
-
-  ! .................MAINTENANCE SECTION................................
-
-  ! MODULES CALLED:
-  ! Name           Description
-  ! convect2        Emanuel cumulus convection tendency calculations
-  ! -------     ----------------------
-  ! LOCAL VARIABLES AND
-  ! STRUCTURES:
-  ! Name     Type    Description
-  ! -------  ------  -----------
-  ! See Comments Below
-
-  ! i        Integer loop index
-  ! k        Integer loop index
-
-  ! METHOD:
-
-  ! See Emanuel, K. and M. Zivkovic-Rothman, 2000: Development and evaluation
-  ! of a
-  ! convective scheme for use in climate models.
-
-  ! FILES: None
-
-  ! INCLUDE FILES: None
-
-  ! MAKEFILE: /a/ops/met/nogaps/src/sub/fcst/fcst159lib.mak
-
-  ! ..............................END PROLOGUE.............................
-
-
-  USE dimphy
-  IMPLICIT NONE
-
-  INTEGER len
-  INTEGER nd
-  INTEGER ndp1
-  INTEGER noff
-  REAL t(len, nd)
-  REAL q(len, nd)
-  REAL qs(len, nd)
-  REAL u(len, nd)
-  REAL v(len, nd)
-  REAL p(len, nd)
-  REAL ph(len, ndp1)
-  INTEGER iflag(len)
-  REAL ft(len, nd)
-  REAL fq(len, nd)
-  REAL fu(len, nd)
-  REAL fv(len, nd)
-  REAL precip(len)
-  REAL cbmf(len)
-  REAL ma(len, nd)
-  INTEGER minorig
-  REAL delt, cpd, cpv, cl, rv, rd, lv0, g
-  REAL sigs, sigd, elcrit, tlcrit, omtsnow, dtmax, damp
-  REAL alpha, entp, coeffs, coeffr, omtrain, cu
-
-  ! -------------------------------------------------------------------
-  ! --- ARGUMENTS
-  ! -------------------------------------------------------------------
-  ! --- On input:
-
-  ! t:   Array of absolute temperature (K) of dimension ND, with first
-  ! index corresponding to lowest model level. Note that this array
-  ! will be altered by the subroutine if dry convective adjustment
-  ! occurs and if IPBL is not equal to 0.
-
-  ! q:   Array of specific humidity (gm/gm) of dimension ND, with first
-  ! index corresponding to lowest model level. Must be defined
-  ! at same grid levels as T. Note that this array will be altered
-  ! if dry convective adjustment occurs and if IPBL is not equal to 0.
-
-  ! qs:  Array of saturation specific humidity of dimension ND, with first
-  ! index corresponding to lowest model level. Must be defined
-  ! at same grid levels as T. Note that this array will be altered
-  ! if dry convective adjustment occurs and if IPBL is not equal to 0.
-
-  ! u:   Array of zonal wind velocity (m/s) of dimension ND, witth first
-  ! index corresponding with the lowest model level. Defined at
-  ! same levels as T. Note that this array will be altered if
-  ! dry convective adjustment occurs and if IPBL is not equal to 0.
-
-  ! v:   Same as u but for meridional velocity.
-
-  ! tra: Array of passive tracer mixing ratio, of dimensions (ND,NTRA),
-  ! where NTRA is the number of different tracers. If no
-  ! convective tracer transport is needed, define a dummy
-  ! input array of dimension (ND,1). Tracers are defined at
-  ! same vertical levels as T. Note that this array will be altered
-  ! if dry convective adjustment occurs and if IPBL is not equal to 0.
-
-  ! p:   Array of pressure (mb) of dimension ND, with first
-  ! index corresponding to lowest model level. Must be defined
-  ! at same grid levels as T.
-
-  ! ph:  Array of pressure (mb) of dimension ND+1, with first index
-  ! corresponding to lowest level. These pressures are defined at
-  ! levels intermediate between those of P, T, Q and QS. The first
-  ! value of PH should be greater than (i.e. at a lower level than)
-  ! the first value of the array P.
-
-  ! nl:  The maximum number of levels to which convection can penetrate, plus
-  ! 1.
-  ! NL MUST be less than or equal to ND-1.
-
-  ! delt: The model time step (sec) between calls to CONVECT
-
-  ! ----------------------------------------------------------------------------
-  ! ---   On Output:
-
-  ! iflag: An output integer whose value denotes the following:
-  ! VALUE   INTERPRETATION
-  ! -----   --------------
-  ! 0     Moist convection occurs.
-  ! 1     Moist convection occurs, but a CFL condition
-  ! on the subsidence warming is violated. This
-  ! does not cause the scheme to terminate.
-  ! 2     Moist convection, but no precip because ep(inb) lt 0.0001
-  ! 3     No moist convection because new cbmf is 0 and old cbmf is 0.
-  ! 4     No moist convection; atmosphere is not
-  ! unstable
-  ! 6     No moist convection because ihmin le minorig.
-  ! 7     No moist convection because unreasonable
-  ! parcel level temperature or specific humidity.
-  ! 8     No moist convection: lifted condensation
-  ! level is above the 200 mb level.
-  ! 9     No moist convection: cloud base is higher
-  ! then the level NL-1.
-
-  ! ft:   Array of temperature tendency (K/s) of dimension ND, defined at
-  ! same
-  ! grid levels as T, Q, QS and P.
-
-  ! fq:   Array of specific humidity tendencies ((gm/gm)/s) of dimension ND,
-  ! defined at same grid levels as T, Q, QS and P.
-
-  ! fu:   Array of forcing of zonal velocity (m/s^2) of dimension ND,
-  ! defined at same grid levels as T.
-
-  ! fv:   Same as FU, but for forcing of meridional velocity.
-
-  ! ftra: Array of forcing of tracer content, in tracer mixing ratio per
-  ! second, defined at same levels as T. Dimensioned (ND,NTRA).
-
-  ! precip: Scalar convective precipitation rate (mm/day).
-
-  ! wd:   A convective downdraft velocity scale. For use in surface
-  ! flux parameterizations. See convect.ps file for details.
-
-  ! tprime: A convective downdraft temperature perturbation scale (K).
-  ! For use in surface flux parameterizations. See convect.ps
-  ! file for details.
-
-  ! qprime: A convective downdraft specific humidity
-  ! perturbation scale (gm/gm).
-  ! For use in surface flux parameterizations. See convect.ps
-  ! file for details.
-
-  ! cbmf: The cloud base mass flux ((kg/m**2)/s). THIS SCALAR VALUE MUST
-  ! BE STORED BY THE CALLING PROGRAM AND RETURNED TO CONVECT AT
-  ! ITS NEXT CALL. That is, the value of CBMF must be "remembered"
-  ! by the calling program between calls to CONVECT.
-
-  ! det:   Array of detrainment mass flux of dimension ND.
-
-  ! -------------------------------------------------------------------
-
-  ! Local arrays
-
-  INTEGER nl
-  INTEGER nlp
-  INTEGER nlm
-  INTEGER i, k, n
-  REAL delti
-  REAL rowl
-  REAL clmcpv
-  REAL clmcpd
-  REAL cpdmcp
-  REAL cpvmcpd
-  REAL eps
-  REAL epsi
-  REAL epsim1
-  REAL ginv
-  REAL hrd
-  REAL prccon1
-  INTEGER icbmax
-  REAL lv(klon, klev)
-  REAL cpn(klon, klev)
-  REAL cpx(klon, klev)
-  REAL tv(klon, klev)
-  REAL gz(klon, klev)
-  REAL hm(klon, klev)
-  REAL h(klon, klev)
-  REAL work(klon)
-  INTEGER ihmin(klon)
-  INTEGER nk(klon)
-  REAL rh(klon)
-  REAL chi(klon)
-  REAL plcl(klon)
-  INTEGER icb(klon)
-  REAL tnk(klon)
-  REAL qnk(klon)
-  REAL gznk(klon)
-  REAL pnk(klon)
-  REAL qsnk(klon)
-  REAL ticb(klon)
-  REAL gzicb(klon)
-  REAL tp(klon, klev)
-  REAL tvp(klon, klev)
-  REAL clw(klon, klev)
-
-  REAL ah0(klon), cpp(klon)
-  REAL tg, qg, s, alv, tc, ahg, denom, es, rg
-
-  INTEGER ncum
-  INTEGER idcum(klon)
-
-  cpd = 1005.7
-  cpv = 1870.0
-  cl = 4190.0
-  rv = 461.5
-  rd = 287.04
-  lv0 = 2.501E6
-  g = 9.8
-
-  ! *** ELCRIT IS THE AUTOCONVERSION THERSHOLD WATER CONTENT (gm/gm) ***
-  ! ***  TLCRIT IS CRITICAL TEMPERATURE BELOW WHICH THE AUTO-        ***
-  ! ***       CONVERSION THRESHOLD IS ASSUMED TO BE ZERO             ***
-  ! ***     (THE AUTOCONVERSION THRESHOLD VARIES LINEARLY            ***
-  ! ***               BETWEEN 0 C AND TLCRIT)                        ***
-  ! ***   ENTP IS THE COEFFICIENT OF MIXING IN THE ENTRAINMENT       ***
-  ! ***                       FORMULATION                            ***
-  ! ***  SIGD IS THE FRACTIONAL AREA COVERED BY UNSATURATED DNDRAFT  ***
-  ! ***  SIGS IS THE FRACTION OF PRECIPITATION FALLING OUTSIDE       ***
-  ! ***                        OF CLOUD                              ***
-  ! ***        OMTRAIN IS THE ASSUMED FALL SPEED (P/s) OF RAIN       ***
-  ! ***     OMTSNOW IS THE ASSUMED FALL SPEED (P/s) OF SNOW          ***
-  ! ***  COEFFR IS A COEFFICIENT GOVERNING THE RATE OF EVAPORATION   ***
-  ! ***                          OF RAIN                             ***
-  ! ***  COEFFS IS A COEFFICIENT GOVERNING THE RATE OF EVAPORATION   ***
-  ! ***                          OF SNOW                             ***
-  ! ***     CU IS THE COEFFICIENT GOVERNING CONVECTIVE MOMENTUM      ***
-  ! ***                         TRANSPORT                            ***
-  ! ***    DTMAX IS THE MAXIMUM NEGATIVE TEMPERATURE PERTURBATION    ***
-  ! ***        A LIFTED PARCEL IS ALLOWED TO HAVE BELOW ITS LFC      ***
-  ! ***    ALPHA AND DAMP ARE PARAMETERS THAT CONTROL THE RATE OF    ***
-  ! ***                 APPROACH TO QUASI-EQUILIBRIUM                ***
-  ! ***   (THEIR STANDARD VALUES ARE  0.20 AND 0.1, RESPECTIVELY)    ***
-  ! ***                   (DAMP MUST BE LESS THAN 1)                 ***
-
-  sigs = 0.12
-  sigd = 0.05
-  elcrit = 0.0011
-  tlcrit = -55.0
-  omtsnow = 5.5
-  dtmax = 0.9
-  damp = 0.1
-  alpha = 0.2
-  entp = 1.5
-  coeffs = 0.8
-  coeffr = 1.0
-  omtrain = 50.0
-
-  cu = 0.70
-  damp = 0.1
-
-
-  ! Define nl, nlp, nlm, and delti
-
-  nl = nd - noff
-  nlp = nl + 1
-  nlm = nl - 1
-  delti = 1.0/delt
-
-  ! -------------------------------------------------------------------
-  ! --- SET CONSTANTS
-  ! -------------------------------------------------------------------
-
-  rowl = 1000.0
-  clmcpv = cl - cpv
-  clmcpd = cl - cpd
-  cpdmcp = cpd - cpv
-  cpvmcpd = cpv - cpd
-  eps = rd/rv
-  epsi = 1.0/eps
-  epsim1 = epsi - 1.0
-  ginv = 1.0/g
-  hrd = 0.5*rd
-  prccon1 = 86400.0*1000.0/(rowl*g)
-
-  ! dtmax is the maximum negative temperature perturbation.
-
-  ! =====================================================================
-  ! --- INITIALIZE OUTPUT ARRAYS AND PARAMETERS
-  ! =====================================================================
-
-  DO k = 1, nd
-    DO i = 1, len
-      ft(i, k) = 0.0
-      fq(i, k) = 0.0
-      fu(i, k) = 0.0
-      fv(i, k) = 0.0
-      tvp(i, k) = 0.0
-      tp(i, k) = 0.0
-      clw(i, k) = 0.0
-      gz(i, k) = 0.
-    END DO
-  END DO
-  DO i = 1, len
-    precip(i) = 0.0
-    iflag(i) = 0
-  END DO
-
-  ! =====================================================================
-  ! --- CALCULATE ARRAYS OF GEOPOTENTIAL, HEAT CAPACITY & STATIC ENERGY
-  ! =====================================================================
-  DO k = 1, nl + 1
-    DO i = 1, len
-      lv(i, k) = lv0 - clmcpv*(t(i,k)-273.15)
-      cpn(i, k) = cpd*(1.0-q(i,k)) + cpv*q(i, k)
-      cpx(i, k) = cpd*(1.0-q(i,k)) + cl*q(i, k)
-      tv(i, k) = t(i, k)*(1.0+q(i,k)*epsim1)
-    END DO
-  END DO
-
-  ! gz = phi at the full levels (same as p).
-
-  DO i = 1, len
-    gz(i, 1) = 0.0
-  END DO
-  DO k = 2, nlp
-    DO i = 1, len
-      gz(i, k) = gz(i, k-1) + hrd*(tv(i,k-1)+tv(i,k))*(p(i,k-1)-p(i,k))/ph(i, &
-        k)
-    END DO
-  END DO
-
-  ! h  = phi + cpT (dry static energy).
-  ! hm = phi + cp(T-Tbase)+Lq
-
-  DO k = 1, nlp
-    DO i = 1, len
-      h(i, k) = gz(i, k) + cpn(i, k)*t(i, k)
-      hm(i, k) = gz(i, k) + cpx(i, k)*(t(i,k)-t(i,1)) + lv(i, k)*q(i, k)
-    END DO
-  END DO
-
-  ! -------------------------------------------------------------------
-  ! --- Find level of minimum moist static energy
-  ! --- If level of minimum moist static energy coincides with
-  ! --- or is lower than minimum allowable parcel origin level,
-  ! --- set iflag to 6.
-  ! -------------------------------------------------------------------
-  DO i = 1, len
-    work(i) = 1.0E12
-    ihmin(i) = nl
-  END DO
-  DO k = 2, nlp
-    DO i = 1, len
-      IF ((hm(i,k)<work(i)) .AND. (hm(i,k)<hm(i,k-1))) THEN
-        work(i) = hm(i, k)
-        ihmin(i) = k
-      END IF
-    END DO
-  END DO
-  DO i = 1, len
-    ihmin(i) = min(ihmin(i), nlm)
-    IF (ihmin(i)<=minorig) THEN
-      iflag(i) = 6
-    END IF
-  END DO
-
-  ! -------------------------------------------------------------------
-  ! --- Find that model level below the level of minimum moist static
-  ! --- energy that has the maximum value of moist static energy
-  ! -------------------------------------------------------------------
-
-  DO i = 1, len
-    work(i) = hm(i, minorig)
-    nk(i) = minorig
-  END DO
-  DO k = minorig + 1, nl
-    DO i = 1, len
-      IF ((hm(i,k)>work(i)) .AND. (k<=ihmin(i))) THEN
-        work(i) = hm(i, k)
-        nk(i) = k
-      END IF
-    END DO
-  END DO
-  ! -------------------------------------------------------------------
-  ! --- Check whether parcel level temperature and specific humidity
-  ! --- are reasonable
-  ! -------------------------------------------------------------------
-  DO i = 1, len
-    IF (((t(i,nk(i))<250.0) .OR. (q(i,nk(i))<=0.0) .OR. (p(i,ihmin(i))< &
-      400.0)) .AND. (iflag(i)==0)) iflag(i) = 7
-  END DO
-  ! -------------------------------------------------------------------
-  ! --- Calculate lifted condensation level of air at parcel origin level
-  ! --- (Within 0.2% of formula of Bolton, MON. WEA. REV.,1980)
-  ! -------------------------------------------------------------------
-  DO i = 1, len
-    tnk(i) = t(i, nk(i))
-    qnk(i) = q(i, nk(i))
-    gznk(i) = gz(i, nk(i))
-    pnk(i) = p(i, nk(i))
-    qsnk(i) = qs(i, nk(i))
-
-    rh(i) = qnk(i)/qsnk(i)
-    rh(i) = min(1.0, rh(i))
-    chi(i) = tnk(i)/(1669.0-122.0*rh(i)-tnk(i))
-    plcl(i) = pnk(i)*(rh(i)**chi(i))
-    IF (((plcl(i)<200.0) .OR. (plcl(i)>=2000.0)) .AND. (iflag(i)==0)) iflag(i &
-      ) = 8
-  END DO
-  ! -------------------------------------------------------------------
-  ! --- Calculate first level above lcl (=icb)
-  ! -------------------------------------------------------------------
-  DO i = 1, len
-    icb(i) = nlm
-  END DO
-
-  DO k = minorig, nl
-    DO i = 1, len
-      IF ((k>=(nk(i)+1)) .AND. (p(i,k)<plcl(i))) icb(i) = min(icb(i), k)
-    END DO
-  END DO
-
-  DO i = 1, len
-    IF ((icb(i)>=nlm) .AND. (iflag(i)==0)) iflag(i) = 9
-  END DO
-
-  ! Compute icbmax.
-
-  icbmax = 2
-  DO i = 1, len
-    icbmax = max(icbmax, icb(i))
-  END DO
-
-  ! -------------------------------------------------------------------
-  ! --- Calculates the lifted parcel virtual temperature at nk,
-  ! --- the actual temperature, and the adiabatic
-  ! --- liquid water content. The procedure is to solve the equation.
-  ! cp*tp+L*qp+phi=cp*tnk+L*qnk+gznk.
-  ! -------------------------------------------------------------------
-
-  DO i = 1, len
-    tnk(i) = t(i, nk(i))
-    qnk(i) = q(i, nk(i))
-    gznk(i) = gz(i, nk(i))
-    ticb(i) = t(i, icb(i))
-    gzicb(i) = gz(i, icb(i))
-  END DO
-
-  ! ***  Calculate certain parcel quantities, including static energy   ***
-
-  DO i = 1, len
-    ah0(i) = (cpd*(1.-qnk(i))+cl*qnk(i))*tnk(i) + qnk(i)*(lv0-clmcpv*(tnk(i)- &
-      273.15)) + gznk(i)
-    cpp(i) = cpd*(1.-qnk(i)) + qnk(i)*cpv
-  END DO
-
-  ! ***   Calculate lifted parcel quantities below cloud base   ***
-
-  DO k = minorig, icbmax - 1
-    DO i = 1, len
-      tp(i, k) = tnk(i) - (gz(i,k)-gznk(i))/cpp(i)
-      tvp(i, k) = tp(i, k)*(1.+qnk(i)*epsi)
-    END DO
-  END DO
-
-  ! ***  Find lifted parcel quantities above cloud base    ***
-
-  DO i = 1, len
-    tg = ticb(i)
-    qg = qs(i, icb(i))
-    alv = lv0 - clmcpv*(ticb(i)-273.15)
-
-    ! First iteration.
-
-    s = cpd + alv*alv*qg/(rv*ticb(i)*ticb(i))
-    s = 1./s
-    ahg = cpd*tg + (cl-cpd)*qnk(i)*ticb(i) + alv*qg + gzicb(i)
-    tg = tg + s*(ah0(i)-ahg)
-    tg = max(tg, 35.0)
-    tc = tg - 273.15
-    denom = 243.5 + tc
-    IF (tc>=0.0) THEN
-      es = 6.112*exp(17.67*tc/denom)
-    ELSE
-      es = exp(23.33086-6111.72784/tg+0.15215*log(tg))
-    END IF
-    qg = eps*es/(p(i,icb(i))-es*(1.-eps))
-
-    ! Second iteration.
-
-    s = cpd + alv*alv*qg/(rv*ticb(i)*ticb(i))
-    s = 1./s
-    ahg = cpd*tg + (cl-cpd)*qnk(i)*ticb(i) + alv*qg + gzicb(i)
-    tg = tg + s*(ah0(i)-ahg)
-    tg = max(tg, 35.0)
-    tc = tg - 273.15
-    denom = 243.5 + tc
-    IF (tc>=0.0) THEN
-      es = 6.112*exp(17.67*tc/denom)
-    ELSE
-      es = exp(23.33086-6111.72784/tg+0.15215*log(tg))
-    END IF
-    qg = eps*es/(p(i,icb(i))-es*(1.-eps))
-
-    alv = lv0 - clmcpv*(ticb(i)-273.15)
-    tp(i, icb(i)) = (ah0(i)-(cl-cpd)*qnk(i)*ticb(i)-gz(i,icb(i))-alv*qg)/cpd
-    clw(i, icb(i)) = qnk(i) - qg
-    clw(i, icb(i)) = max(0.0, clw(i,icb(i)))
-    rg = qg/(1.-qnk(i))
-    tvp(i, icb(i)) = tp(i, icb(i))*(1.+rg*epsi)
-  END DO
-
-  DO k = minorig, icbmax
-    DO i = 1, len
-      tvp(i, k) = tvp(i, k) - tp(i, k)*qnk(i)
-    END DO
-  END DO
-
-  ! -------------------------------------------------------------------
-  ! --- Test for instability.
-  ! --- If there was no convection at last time step and parcel
-  ! --- is stable at icb, then set iflag to 4.
-  ! -------------------------------------------------------------------
-
-  DO i = 1, len
-    IF ((cbmf(i)==0.0) .AND. (iflag(i)==0) .AND. (tvp(i, &
-      icb(i))<=(tv(i,icb(i))-dtmax))) iflag(i) = 4
-  END DO
-
-  ! =====================================================================
-  ! --- IF THIS POINT IS REACHED, MOIST CONVECTIVE ADJUSTMENT IS NECESSARY
-  ! =====================================================================
-
-  ncum = 0
-  DO i = 1, len
-    IF (iflag(i)==0) THEN
-      ncum = ncum + 1
-      idcum(ncum) = i
-    END IF
-  END DO
-
-  ! Call convect2, which compresses the points and computes the heating,
-  ! moistening, velocity mixing, and precipiation.
-
-  ! print*,'cpd avant convect2 ',cpd
-  IF (ncum>0) THEN
-    CALL convect2(ncum, idcum, len, nd, ndp1, nl, minorig, nk, icb, t, q, qs, &
-      u, v, gz, tv, tp, tvp, clw, h, lv, cpn, p, ph, ft, fq, fu, fv, tnk, &
-      qnk, gznk, plcl, precip, cbmf, iflag, delt, cpd, cpv, cl, rv, rd, lv0, &
-      g, sigs, sigd, elcrit, tlcrit, omtsnow, dtmax, damp, alpha, entp, &
-      coeffs, coeffr, omtrain, cu, ma)
-  END IF
-
-  RETURN
-END SUBROUTINE convect1
Index: /LMDZ6/trunk/libf/phylmd/convect1.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/convect1.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/convect1.f90	(revision 5268)
@@ -0,0 +1,641 @@
+
+! $Header$
+
+SUBROUTINE convect1(len, nd, ndp1, noff, minorig, t, q, qs, u, v, p, ph, &
+    iflag, ft, fq, fu, fv, precip, cbmf, delt, ma)
+  ! .............................START PROLOGUE............................
+
+  ! SCCS IDENTIFICATION:  @(#)convect1.f	1.1 04/21/00
+  ! 19:40:52 /h/cm/library/nogaps4/src/sub/fcst/convect1.f_v
+
+  ! CONFIGURATION IDENTIFICATION:  None
+
+  ! MODULE NAME:  convect1
+
+  ! DESCRIPTION:
+
+  ! convect1     The Emanuel Cumulus Convection Scheme
+
+  ! CONTRACT NUMBER AND TITLE:  None
+
+  ! REFERENCES: Programmers  K. Emanuel (MIT), Timothy F. Hogan, M. Peng
+  ! (NRL)
+
+  ! CLASSIFICATION:  Unclassified
+
+  ! RESTRICTIONS: None
+
+  ! COMPILER DEPENDENCIES: FORTRAN 77, FORTRAN 90
+
+  ! COMPILE OPTIONS: Fortran 77: -Zu -Wf"-ei -o aggress"
+  ! Fortran 90: -O vector3,scalar3,task1,aggress,overindex  -ei -r 2
+
+  ! LIBRARIES OF RESIDENCE: /a/ops/lib/libfcst159.a
+
+  ! USAGE: call convect1(len,nd,noff,minorig,
+  ! &                   t,q,qs,u,v,
+  ! &                   p,ph,iflag,ft,
+  ! &                   fq,fu,fv,precip,cbmf,delt)
+
+  ! PARAMETERS:
+  ! Name            Type         Usage            Description
+  ! ----------      ----------     -------  ----------------------------
+
+  ! len           Integer        Input        first (i) dimension
+  ! nd            Integer        Input        vertical (k) dimension
+  ! ndp1          Integer        Input        nd + 1
+  ! noff          Integer        Input        integer limit for convection
+  ! (nd-noff)
+  ! minorig       Integer        Input        First level of convection
+  ! t             Real           Input        temperature
+  ! q             Real           Input        specific hum
+  ! qs            Real           Input        sat specific hum
+  ! u             Real           Input        u-wind
+  ! v             Real           Input        v-wind
+  ! p             Real           Input        full level pressure
+  ! ph            Real           Input        half level pressure
+  ! iflag         Integer        Output       iflag on latitude strip
+  ! ft            Real           Output       temp tend
+  ! fq            Real           Output       spec hum tend
+  ! fu            Real           Output       u-wind tend
+  ! fv            Real           Output       v-wind tend
+  ! cbmf          Real           In/Out       cumulus mass flux
+  ! delt          Real           Input        time step
+  ! iflag         Integer        Output       integer flag for Emanuel
+  ! conditions
+
+  ! COMMON BLOCKS:
+  ! Block      Name     Type    Usage              Notes
+  ! --------  --------   ----    ------   ------------------------
+
+  ! FILES: None
+
+  ! DATA BASES: None
+
+  ! NON-FILE INPUT/OUTPUT: None
+
+  ! ERROR CONDITIONS: None
+
+  ! ADDITIONAL COMMENTS: None
+
+  ! .................MAINTENANCE SECTION................................
+
+  ! MODULES CALLED:
+  ! Name           Description
+  ! convect2        Emanuel cumulus convection tendency calculations
+  ! -------     ----------------------
+  ! LOCAL VARIABLES AND
+  ! STRUCTURES:
+  ! Name     Type    Description
+  ! -------  ------  -----------
+  ! See Comments Below
+
+  ! i        Integer loop index
+  ! k        Integer loop index
+
+  ! METHOD:
+
+  ! See Emanuel, K. and M. Zivkovic-Rothman, 2000: Development and evaluation
+  ! of a
+  ! convective scheme for use in climate models.
+
+  ! FILES: None
+
+  ! INCLUDE FILES: None
+
+  ! MAKEFILE: /a/ops/met/nogaps/src/sub/fcst/fcst159lib.mak
+
+  ! ..............................END PROLOGUE.............................
+
+
+  USE dimphy
+  IMPLICIT NONE
+
+  INTEGER len
+  INTEGER nd
+  INTEGER ndp1
+  INTEGER noff
+  REAL t(len, nd)
+  REAL q(len, nd)
+  REAL qs(len, nd)
+  REAL u(len, nd)
+  REAL v(len, nd)
+  REAL p(len, nd)
+  REAL ph(len, ndp1)
+  INTEGER iflag(len)
+  REAL ft(len, nd)
+  REAL fq(len, nd)
+  REAL fu(len, nd)
+  REAL fv(len, nd)
+  REAL precip(len)
+  REAL cbmf(len)
+  REAL ma(len, nd)
+  INTEGER minorig
+  REAL delt, cpd, cpv, cl, rv, rd, lv0, g
+  REAL sigs, sigd, elcrit, tlcrit, omtsnow, dtmax, damp
+  REAL alpha, entp, coeffs, coeffr, omtrain, cu
+
+  ! -------------------------------------------------------------------
+  ! --- ARGUMENTS
+  ! -------------------------------------------------------------------
+  ! --- On input:
+
+  ! t:   Array of absolute temperature (K) of dimension ND, with first
+  ! index corresponding to lowest model level. Note that this array
+  ! will be altered by the subroutine if dry convective adjustment
+  ! occurs and if IPBL is not equal to 0.
+
+  ! q:   Array of specific humidity (gm/gm) of dimension ND, with first
+  ! index corresponding to lowest model level. Must be defined
+  ! at same grid levels as T. Note that this array will be altered
+  ! if dry convective adjustment occurs and if IPBL is not equal to 0.
+
+  ! qs:  Array of saturation specific humidity of dimension ND, with first
+  ! index corresponding to lowest model level. Must be defined
+  ! at same grid levels as T. Note that this array will be altered
+  ! if dry convective adjustment occurs and if IPBL is not equal to 0.
+
+  ! u:   Array of zonal wind velocity (m/s) of dimension ND, witth first
+  ! index corresponding with the lowest model level. Defined at
+  ! same levels as T. Note that this array will be altered if
+  ! dry convective adjustment occurs and if IPBL is not equal to 0.
+
+  ! v:   Same as u but for meridional velocity.
+
+  ! tra: Array of passive tracer mixing ratio, of dimensions (ND,NTRA),
+  ! where NTRA is the number of different tracers. If no
+  ! convective tracer transport is needed, define a dummy
+  ! input array of dimension (ND,1). Tracers are defined at
+  ! same vertical levels as T. Note that this array will be altered
+  ! if dry convective adjustment occurs and if IPBL is not equal to 0.
+
+  ! p:   Array of pressure (mb) of dimension ND, with first
+  ! index corresponding to lowest model level. Must be defined
+  ! at same grid levels as T.
+
+  ! ph:  Array of pressure (mb) of dimension ND+1, with first index
+  ! corresponding to lowest level. These pressures are defined at
+  ! levels intermediate between those of P, T, Q and QS. The first
+  ! value of PH should be greater than (i.e. at a lower level than)
+  ! the first value of the array P.
+
+  ! nl:  The maximum number of levels to which convection can penetrate, plus
+  ! 1.
+  ! NL MUST be less than or equal to ND-1.
+
+  ! delt: The model time step (sec) between calls to CONVECT
+
+  ! ----------------------------------------------------------------------------
+  ! ---   On Output:
+
+  ! iflag: An output integer whose value denotes the following:
+  ! VALUE   INTERPRETATION
+  ! -----   --------------
+  ! 0     Moist convection occurs.
+  ! 1     Moist convection occurs, but a CFL condition
+  ! on the subsidence warming is violated. This
+  ! does not cause the scheme to terminate.
+  ! 2     Moist convection, but no precip because ep(inb) lt 0.0001
+  ! 3     No moist convection because new cbmf is 0 and old cbmf is 0.
+  ! 4     No moist convection; atmosphere is not
+  ! unstable
+  ! 6     No moist convection because ihmin le minorig.
+  ! 7     No moist convection because unreasonable
+  ! parcel level temperature or specific humidity.
+  ! 8     No moist convection: lifted condensation
+  ! level is above the 200 mb level.
+  ! 9     No moist convection: cloud base is higher
+  ! then the level NL-1.
+
+  ! ft:   Array of temperature tendency (K/s) of dimension ND, defined at
+  ! same
+  ! grid levels as T, Q, QS and P.
+
+  ! fq:   Array of specific humidity tendencies ((gm/gm)/s) of dimension ND,
+  ! defined at same grid levels as T, Q, QS and P.
+
+  ! fu:   Array of forcing of zonal velocity (m/s^2) of dimension ND,
+  ! defined at same grid levels as T.
+
+  ! fv:   Same as FU, but for forcing of meridional velocity.
+
+  ! ftra: Array of forcing of tracer content, in tracer mixing ratio per
+  ! second, defined at same levels as T. Dimensioned (ND,NTRA).
+
+  ! precip: Scalar convective precipitation rate (mm/day).
+
+  ! wd:   A convective downdraft velocity scale. For use in surface
+  ! flux parameterizations. See convect.ps file for details.
+
+  ! tprime: A convective downdraft temperature perturbation scale (K).
+  ! For use in surface flux parameterizations. See convect.ps
+  ! file for details.
+
+  ! qprime: A convective downdraft specific humidity
+  ! perturbation scale (gm/gm).
+  ! For use in surface flux parameterizations. See convect.ps
+  ! file for details.
+
+  ! cbmf: The cloud base mass flux ((kg/m**2)/s). THIS SCALAR VALUE MUST
+  ! BE STORED BY THE CALLING PROGRAM AND RETURNED TO CONVECT AT
+  ! ITS NEXT CALL. That is, the value of CBMF must be "remembered"
+  ! by the calling program between calls to CONVECT.
+
+  ! det:   Array of detrainment mass flux of dimension ND.
+
+  ! -------------------------------------------------------------------
+
+  ! Local arrays
+
+  INTEGER nl
+  INTEGER nlp
+  INTEGER nlm
+  INTEGER i, k, n
+  REAL delti
+  REAL rowl
+  REAL clmcpv
+  REAL clmcpd
+  REAL cpdmcp
+  REAL cpvmcpd
+  REAL eps
+  REAL epsi
+  REAL epsim1
+  REAL ginv
+  REAL hrd
+  REAL prccon1
+  INTEGER icbmax
+  REAL lv(klon, klev)
+  REAL cpn(klon, klev)
+  REAL cpx(klon, klev)
+  REAL tv(klon, klev)
+  REAL gz(klon, klev)
+  REAL hm(klon, klev)
+  REAL h(klon, klev)
+  REAL work(klon)
+  INTEGER ihmin(klon)
+  INTEGER nk(klon)
+  REAL rh(klon)
+  REAL chi(klon)
+  REAL plcl(klon)
+  INTEGER icb(klon)
+  REAL tnk(klon)
+  REAL qnk(klon)
+  REAL gznk(klon)
+  REAL pnk(klon)
+  REAL qsnk(klon)
+  REAL ticb(klon)
+  REAL gzicb(klon)
+  REAL tp(klon, klev)
+  REAL tvp(klon, klev)
+  REAL clw(klon, klev)
+
+  REAL ah0(klon), cpp(klon)
+  REAL tg, qg, s, alv, tc, ahg, denom, es, rg
+
+  INTEGER ncum
+  INTEGER idcum(klon)
+
+  cpd = 1005.7
+  cpv = 1870.0
+  cl = 4190.0
+  rv = 461.5
+  rd = 287.04
+  lv0 = 2.501E6
+  g = 9.8
+
+  ! *** ELCRIT IS THE AUTOCONVERSION THERSHOLD WATER CONTENT (gm/gm) ***
+  ! ***  TLCRIT IS CRITICAL TEMPERATURE BELOW WHICH THE AUTO-        ***
+  ! ***       CONVERSION THRESHOLD IS ASSUMED TO BE ZERO             ***
+  ! ***     (THE AUTOCONVERSION THRESHOLD VARIES LINEARLY            ***
+  ! ***               BETWEEN 0 C AND TLCRIT)                        ***
+  ! ***   ENTP IS THE COEFFICIENT OF MIXING IN THE ENTRAINMENT       ***
+  ! ***                       FORMULATION                            ***
+  ! ***  SIGD IS THE FRACTIONAL AREA COVERED BY UNSATURATED DNDRAFT  ***
+  ! ***  SIGS IS THE FRACTION OF PRECIPITATION FALLING OUTSIDE       ***
+  ! ***                        OF CLOUD                              ***
+  ! ***        OMTRAIN IS THE ASSUMED FALL SPEED (P/s) OF RAIN       ***
+  ! ***     OMTSNOW IS THE ASSUMED FALL SPEED (P/s) OF SNOW          ***
+  ! ***  COEFFR IS A COEFFICIENT GOVERNING THE RATE OF EVAPORATION   ***
+  ! ***                          OF RAIN                             ***
+  ! ***  COEFFS IS A COEFFICIENT GOVERNING THE RATE OF EVAPORATION   ***
+  ! ***                          OF SNOW                             ***
+  ! ***     CU IS THE COEFFICIENT GOVERNING CONVECTIVE MOMENTUM      ***
+  ! ***                         TRANSPORT                            ***
+  ! ***    DTMAX IS THE MAXIMUM NEGATIVE TEMPERATURE PERTURBATION    ***
+  ! ***        A LIFTED PARCEL IS ALLOWED TO HAVE BELOW ITS LFC      ***
+  ! ***    ALPHA AND DAMP ARE PARAMETERS THAT CONTROL THE RATE OF    ***
+  ! ***                 APPROACH TO QUASI-EQUILIBRIUM                ***
+  ! ***   (THEIR STANDARD VALUES ARE  0.20 AND 0.1, RESPECTIVELY)    ***
+  ! ***                   (DAMP MUST BE LESS THAN 1)                 ***
+
+  sigs = 0.12
+  sigd = 0.05
+  elcrit = 0.0011
+  tlcrit = -55.0
+  omtsnow = 5.5
+  dtmax = 0.9
+  damp = 0.1
+  alpha = 0.2
+  entp = 1.5
+  coeffs = 0.8
+  coeffr = 1.0
+  omtrain = 50.0
+
+  cu = 0.70
+  damp = 0.1
+
+
+  ! Define nl, nlp, nlm, and delti
+
+  nl = nd - noff
+  nlp = nl + 1
+  nlm = nl - 1
+  delti = 1.0/delt
+
+  ! -------------------------------------------------------------------
+  ! --- SET CONSTANTS
+  ! -------------------------------------------------------------------
+
+  rowl = 1000.0
+  clmcpv = cl - cpv
+  clmcpd = cl - cpd
+  cpdmcp = cpd - cpv
+  cpvmcpd = cpv - cpd
+  eps = rd/rv
+  epsi = 1.0/eps
+  epsim1 = epsi - 1.0
+  ginv = 1.0/g
+  hrd = 0.5*rd
+  prccon1 = 86400.0*1000.0/(rowl*g)
+
+  ! dtmax is the maximum negative temperature perturbation.
+
+  ! =====================================================================
+  ! --- INITIALIZE OUTPUT ARRAYS AND PARAMETERS
+  ! =====================================================================
+
+  DO k = 1, nd
+    DO i = 1, len
+      ft(i, k) = 0.0
+      fq(i, k) = 0.0
+      fu(i, k) = 0.0
+      fv(i, k) = 0.0
+      tvp(i, k) = 0.0
+      tp(i, k) = 0.0
+      clw(i, k) = 0.0
+      gz(i, k) = 0.
+    END DO
+  END DO
+  DO i = 1, len
+    precip(i) = 0.0
+    iflag(i) = 0
+  END DO
+
+  ! =====================================================================
+  ! --- CALCULATE ARRAYS OF GEOPOTENTIAL, HEAT CAPACITY & STATIC ENERGY
+  ! =====================================================================
+  DO k = 1, nl + 1
+    DO i = 1, len
+      lv(i, k) = lv0 - clmcpv*(t(i,k)-273.15)
+      cpn(i, k) = cpd*(1.0-q(i,k)) + cpv*q(i, k)
+      cpx(i, k) = cpd*(1.0-q(i,k)) + cl*q(i, k)
+      tv(i, k) = t(i, k)*(1.0+q(i,k)*epsim1)
+    END DO
+  END DO
+
+  ! gz = phi at the full levels (same as p).
+
+  DO i = 1, len
+    gz(i, 1) = 0.0
+  END DO
+  DO k = 2, nlp
+    DO i = 1, len
+      gz(i, k) = gz(i, k-1) + hrd*(tv(i,k-1)+tv(i,k))*(p(i,k-1)-p(i,k))/ph(i, &
+        k)
+    END DO
+  END DO
+
+  ! h  = phi + cpT (dry static energy).
+  ! hm = phi + cp(T-Tbase)+Lq
+
+  DO k = 1, nlp
+    DO i = 1, len
+      h(i, k) = gz(i, k) + cpn(i, k)*t(i, k)
+      hm(i, k) = gz(i, k) + cpx(i, k)*(t(i,k)-t(i,1)) + lv(i, k)*q(i, k)
+    END DO
+  END DO
+
+  ! -------------------------------------------------------------------
+  ! --- Find level of minimum moist static energy
+  ! --- If level of minimum moist static energy coincides with
+  ! --- or is lower than minimum allowable parcel origin level,
+  ! --- set iflag to 6.
+  ! -------------------------------------------------------------------
+  DO i = 1, len
+    work(i) = 1.0E12
+    ihmin(i) = nl
+  END DO
+  DO k = 2, nlp
+    DO i = 1, len
+      IF ((hm(i,k)<work(i)) .AND. (hm(i,k)<hm(i,k-1))) THEN
+        work(i) = hm(i, k)
+        ihmin(i) = k
+      END IF
+    END DO
+  END DO
+  DO i = 1, len
+    ihmin(i) = min(ihmin(i), nlm)
+    IF (ihmin(i)<=minorig) THEN
+      iflag(i) = 6
+    END IF
+  END DO
+
+  ! -------------------------------------------------------------------
+  ! --- Find that model level below the level of minimum moist static
+  ! --- energy that has the maximum value of moist static energy
+  ! -------------------------------------------------------------------
+
+  DO i = 1, len
+    work(i) = hm(i, minorig)
+    nk(i) = minorig
+  END DO
+  DO k = minorig + 1, nl
+    DO i = 1, len
+      IF ((hm(i,k)>work(i)) .AND. (k<=ihmin(i))) THEN
+        work(i) = hm(i, k)
+        nk(i) = k
+      END IF
+    END DO
+  END DO
+  ! -------------------------------------------------------------------
+  ! --- Check whether parcel level temperature and specific humidity
+  ! --- are reasonable
+  ! -------------------------------------------------------------------
+  DO i = 1, len
+    IF (((t(i,nk(i))<250.0) .OR. (q(i,nk(i))<=0.0) .OR. (p(i,ihmin(i))< &
+      400.0)) .AND. (iflag(i)==0)) iflag(i) = 7
+  END DO
+  ! -------------------------------------------------------------------
+  ! --- Calculate lifted condensation level of air at parcel origin level
+  ! --- (Within 0.2% of formula of Bolton, MON. WEA. REV.,1980)
+  ! -------------------------------------------------------------------
+  DO i = 1, len
+    tnk(i) = t(i, nk(i))
+    qnk(i) = q(i, nk(i))
+    gznk(i) = gz(i, nk(i))
+    pnk(i) = p(i, nk(i))
+    qsnk(i) = qs(i, nk(i))
+
+    rh(i) = qnk(i)/qsnk(i)
+    rh(i) = min(1.0, rh(i))
+    chi(i) = tnk(i)/(1669.0-122.0*rh(i)-tnk(i))
+    plcl(i) = pnk(i)*(rh(i)**chi(i))
+    IF (((plcl(i)<200.0) .OR. (plcl(i)>=2000.0)) .AND. (iflag(i)==0)) iflag(i &
+      ) = 8
+  END DO
+  ! -------------------------------------------------------------------
+  ! --- Calculate first level above lcl (=icb)
+  ! -------------------------------------------------------------------
+  DO i = 1, len
+    icb(i) = nlm
+  END DO
+
+  DO k = minorig, nl
+    DO i = 1, len
+      IF ((k>=(nk(i)+1)) .AND. (p(i,k)<plcl(i))) icb(i) = min(icb(i), k)
+    END DO
+  END DO
+
+  DO i = 1, len
+    IF ((icb(i)>=nlm) .AND. (iflag(i)==0)) iflag(i) = 9
+  END DO
+
+  ! Compute icbmax.
+
+  icbmax = 2
+  DO i = 1, len
+    icbmax = max(icbmax, icb(i))
+  END DO
+
+  ! -------------------------------------------------------------------
+  ! --- Calculates the lifted parcel virtual temperature at nk,
+  ! --- the actual temperature, and the adiabatic
+  ! --- liquid water content. The procedure is to solve the equation.
+  ! cp*tp+L*qp+phi=cp*tnk+L*qnk+gznk.
+  ! -------------------------------------------------------------------
+
+  DO i = 1, len
+    tnk(i) = t(i, nk(i))
+    qnk(i) = q(i, nk(i))
+    gznk(i) = gz(i, nk(i))
+    ticb(i) = t(i, icb(i))
+    gzicb(i) = gz(i, icb(i))
+  END DO
+
+  ! ***  Calculate certain parcel quantities, including static energy   ***
+
+  DO i = 1, len
+    ah0(i) = (cpd*(1.-qnk(i))+cl*qnk(i))*tnk(i) + qnk(i)*(lv0-clmcpv*(tnk(i)- &
+      273.15)) + gznk(i)
+    cpp(i) = cpd*(1.-qnk(i)) + qnk(i)*cpv
+  END DO
+
+  ! ***   Calculate lifted parcel quantities below cloud base   ***
+
+  DO k = minorig, icbmax - 1
+    DO i = 1, len
+      tp(i, k) = tnk(i) - (gz(i,k)-gznk(i))/cpp(i)
+      tvp(i, k) = tp(i, k)*(1.+qnk(i)*epsi)
+    END DO
+  END DO
+
+  ! ***  Find lifted parcel quantities above cloud base    ***
+
+  DO i = 1, len
+    tg = ticb(i)
+    qg = qs(i, icb(i))
+    alv = lv0 - clmcpv*(ticb(i)-273.15)
+
+    ! First iteration.
+
+    s = cpd + alv*alv*qg/(rv*ticb(i)*ticb(i))
+    s = 1./s
+    ahg = cpd*tg + (cl-cpd)*qnk(i)*ticb(i) + alv*qg + gzicb(i)
+    tg = tg + s*(ah0(i)-ahg)
+    tg = max(tg, 35.0)
+    tc = tg - 273.15
+    denom = 243.5 + tc
+    IF (tc>=0.0) THEN
+      es = 6.112*exp(17.67*tc/denom)
+    ELSE
+      es = exp(23.33086-6111.72784/tg+0.15215*log(tg))
+    END IF
+    qg = eps*es/(p(i,icb(i))-es*(1.-eps))
+
+    ! Second iteration.
+
+    s = cpd + alv*alv*qg/(rv*ticb(i)*ticb(i))
+    s = 1./s
+    ahg = cpd*tg + (cl-cpd)*qnk(i)*ticb(i) + alv*qg + gzicb(i)
+    tg = tg + s*(ah0(i)-ahg)
+    tg = max(tg, 35.0)
+    tc = tg - 273.15
+    denom = 243.5 + tc
+    IF (tc>=0.0) THEN
+      es = 6.112*exp(17.67*tc/denom)
+    ELSE
+      es = exp(23.33086-6111.72784/tg+0.15215*log(tg))
+    END IF
+    qg = eps*es/(p(i,icb(i))-es*(1.-eps))
+
+    alv = lv0 - clmcpv*(ticb(i)-273.15)
+    tp(i, icb(i)) = (ah0(i)-(cl-cpd)*qnk(i)*ticb(i)-gz(i,icb(i))-alv*qg)/cpd
+    clw(i, icb(i)) = qnk(i) - qg
+    clw(i, icb(i)) = max(0.0, clw(i,icb(i)))
+    rg = qg/(1.-qnk(i))
+    tvp(i, icb(i)) = tp(i, icb(i))*(1.+rg*epsi)
+  END DO
+
+  DO k = minorig, icbmax
+    DO i = 1, len
+      tvp(i, k) = tvp(i, k) - tp(i, k)*qnk(i)
+    END DO
+  END DO
+
+  ! -------------------------------------------------------------------
+  ! --- Test for instability.
+  ! --- If there was no convection at last time step and parcel
+  ! --- is stable at icb, then set iflag to 4.
+  ! -------------------------------------------------------------------
+
+  DO i = 1, len
+    IF ((cbmf(i)==0.0) .AND. (iflag(i)==0) .AND. (tvp(i, &
+      icb(i))<=(tv(i,icb(i))-dtmax))) iflag(i) = 4
+  END DO
+
+  ! =====================================================================
+  ! --- IF THIS POINT IS REACHED, MOIST CONVECTIVE ADJUSTMENT IS NECESSARY
+  ! =====================================================================
+
+  ncum = 0
+  DO i = 1, len
+    IF (iflag(i)==0) THEN
+      ncum = ncum + 1
+      idcum(ncum) = i
+    END IF
+  END DO
+
+  ! Call convect2, which compresses the points and computes the heating,
+  ! moistening, velocity mixing, and precipiation.
+
+  ! print*,'cpd avant convect2 ',cpd
+  IF (ncum>0) THEN
+    CALL convect2(ncum, idcum, len, nd, ndp1, nl, minorig, nk, icb, t, q, qs, &
+      u, v, gz, tv, tp, tvp, clw, h, lv, cpn, p, ph, ft, fq, fu, fv, tnk, &
+      qnk, gznk, plcl, precip, cbmf, iflag, delt, cpd, cpv, cl, rv, rd, lv0, &
+      g, sigs, sigd, elcrit, tlcrit, omtsnow, dtmax, damp, alpha, entp, &
+      coeffs, coeffr, omtrain, cu, ma)
+  END IF
+
+  RETURN
+END SUBROUTINE convect1
Index: DZ6/trunk/libf/phylmd/convect2.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/convect2.F90	(revision 5267)
+++ 	(revision )
@@ -1,1373 +1,0 @@
-
-! $Id$
-
-SUBROUTINE convect2(ncum, idcum, len, nd, ndp1, nl, minorig, nk1, icb1, t1, &
-    q1, qs1, u1, v1, gz1, tv1, tp1, tvp1, clw1, h1, lv1, cpn1, p1, ph1, ft1, &
-    fq1, fu1, fv1, tnk1, qnk1, gznk1, plcl1, precip1, cbmf1, iflag1, delt, &
-    cpd, cpv, cl, rv, rd, lv0, g, sigs, sigd, elcrit, tlcrit, omtsnow, dtmax, &
-    damp, alpha, entp, coeffs, coeffr, omtrain, cu, ma)
-  ! .............................START PROLOGUE............................
-
-  ! SCCS IDENTIFICATION:  @(#)convect2.f	1.2 05/18/00
-  ! 22:06:22 /h/cm/library/nogaps4/src/sub/fcst/convect2.f_v
-
-  ! CONFIGURATION IDENTIFICATION:  None
-
-  ! MODULE NAME:  convect2
-
-  ! DESCRIPTION:
-
-  ! convect1     The Emanuel Cumulus Convection Scheme - compute tendencies
-
-  ! CONTRACT NUMBER AND TITLE:  None
-
-  ! REFERENCES: Programmers  K. Emanuel (MIT), Timothy F. Hogan, M. Peng
-  ! (NRL)
-
-  ! CLASSIFICATION:  Unclassified
-
-  ! RESTRICTIONS: None
-
-  ! COMPILER DEPENDENCIES: FORTRAN 77, FORTRAN 90
-
-  ! COMPILE OPTIONS: Fortran 77: -Zu -Wf"-ei -o aggress"
-  ! Fortran 90: -O vector3,scalar3,task1,aggress,overindex  -ei -r 2
-
-  ! LIBRARIES OF RESIDENCE: /a/ops/lib/libfcst159.a
-
-  ! USAGE: call convect2(ncum,idcum,len,nd,nl,minorig,
-  ! &                 nk1,icb1,
-  ! &                 t1,q1,qs1,u1,v1,gz1,tv1,tp1,tvp1,clw1,h1,
-  ! &                 lv1,cpn1,p1,ph1,ft1,fq1,fu1,fv1,
-  ! &                 tnk1,qnk1,gznk1,plcl1,
-  ! &                 precip1,cbmf1,iflag1,
-  ! &                 delt,cpd,cpv,cl,rv,rd,lv0,g,
-  ! &                 sigs,sigd,elcrit,tlcrit,omtsnow,dtmax,damp,
-  ! &                 alpha,entp,coeffs,coeffr,omtrain,cu)
-
-  ! PARAMETERS:
-  ! Name            Type         Usage            Description
-  ! ----------      ----------     -------  ----------------------------
-
-  ! ncum          Integer        Input        number of cumulus points
-  ! idcum         Integer        Input        index of cumulus point
-  ! len           Integer        Input        first dimension
-  ! nd            Integer        Input        total vertical dimension
-  ! ndp1          Integer        Input        nd + 1
-  ! nl            Integer        Input        vertical dimension for
-  ! convection
-  ! minorig       Integer        Input        First level where convection is
-  ! allow to begin
-  ! nk1           Integer        Input        First level of convection
-  ! ncb1          Integer        Input        Level of free convection
-  ! t1            Real           Input        temperature
-  ! q1            Real           Input        specific hum
-  ! qs1           Real           Input        sat specific hum
-  ! u1            Real           Input        u-wind
-  ! v1            Real           Input        v-wind
-  ! gz1           Real           Inout        geop
-  ! tv1           Real           Input        virtual temp
-  ! tp1           Real           Input
-  ! clw1          Real           Inout        cloud liquid water
-  ! h1            Real           Inout
-  ! lv1           Real           Inout
-  ! cpn1          Real           Inout
-  ! p1            Real           Input        full level pressure
-  ! ph1           Real           Input        half level pressure
-  ! ft1           Real           Output       temp tend
-  ! fq1           Real           Output       spec hum tend
-  ! fu1           Real           Output       u-wind tend
-  ! fv1           Real           Output       v-wind tend
-  ! precip1       Real           Output       prec
-  ! cbmf1         Real           In/Out       cumulus mass flux
-  ! iflag1        Integer        Output       iflag on latitude strip
-  ! delt          Real           Input        time step
-  ! cpd           Integer        Input        See description below
-  ! cpv           Integer        Input        See description below
-  ! cl            Integer        Input        See description below
-  ! rv            Integer        Input        See description below
-  ! rd            Integer        Input        See description below
-  ! lv0           Integer        Input        See description below
-  ! g             Integer        Input        See description below
-  ! sigs          Integer        Input        See description below
-  ! sigd          Integer        Input        See description below
-  ! elcrit        Integer        Input        See description below
-  ! tlcrit        Integer        Input        See description below
-  ! omtsnow       Integer        Input        See description below
-  ! dtmax         Integer        Input        See description below
-  ! damp          Integer        Input        See description below
-  ! alpha         Integer        Input        See description below
-  ! ent           Integer        Input        See description below
-  ! coeffs        Integer        Input        See description below
-  ! coeffr        Integer        Input        See description below
-  ! omtrain       Integer        Input        See description below
-  ! cu            Integer        Input        See description below
-
-  ! COMMON BLOCKS:
-  ! Block      Name     Type    Usage              Notes
-  ! --------  --------   ----    ------   ------------------------
-
-  ! FILES: None
-
-  ! DATA BASES: None
-
-  ! NON-FILE INPUT/OUTPUT: None
-
-  ! ERROR CONDITIONS: None
-
-  ! ADDITIONAL COMMENTS: None
-
-  ! .................MAINTENANCE SECTION................................
-
-  ! MODULES CALLED:
-  ! Name           Description
-  ! zilch        Zero out an array
-  ! -------     ----------------------
-  ! LOCAL VARIABLES AND
-  ! STRUCTURES:
-  ! Name     Type    Description
-  ! -------  ------  -----------
-  ! See Comments Below
-
-  ! i        Integer loop index
-  ! k        Integer loop index
-
-  ! METHOD:
-
-  ! See Emanuel, K. and M. Zivkovic-Rothman, 2000: Development and evaluation
-  ! of a
-  ! convective scheme for use in climate models.
-
-  ! FILES: None
-
-  ! INCLUDE FILES: None
-
-  ! MAKEFILE: /a/ops/met/nogaps/src/sub/fcst/fcst159lib.mak
-
-  ! ..............................END PROLOGUE.............................
-
-
-  USE dimphy
-  IMPLICIT NONE
-
-  INTEGER kmax2, imax2, kmin2, imin2
-  REAL ftmax2, ftmin2
-  INTEGER kmax, imax, kmin, imin
-  REAL ftmax, ftmin
-
-  INTEGER ncum
-  INTEGER len
-  INTEGER idcum(len)
-  INTEGER nd
-  INTEGER ndp1
-  INTEGER nl
-  INTEGER minorig
-  INTEGER nk1(len)
-  INTEGER icb1(len)
-  REAL t1(len, nd)
-  REAL q1(len, nd)
-  REAL qs1(len, nd)
-  REAL u1(len, nd)
-  REAL v1(len, nd)
-  REAL gz1(len, nd)
-  REAL tv1(len, nd)
-  REAL tp1(len, nd)
-  REAL tvp1(len, nd)
-  REAL clw1(len, nd)
-  REAL h1(len, nd)
-  REAL lv1(len, nd)
-  REAL cpn1(len, nd)
-  REAL p1(len, nd)
-  REAL ph1(len, ndp1)
-  REAL ft1(len, nd)
-  REAL fq1(len, nd)
-  REAL fu1(len, nd)
-  REAL fv1(len, nd)
-  REAL tnk1(len)
-  REAL qnk1(len)
-  REAL gznk1(len)
-  REAL precip1(len)
-  REAL cbmf1(len)
-  REAL plcl1(len)
-  INTEGER iflag1(len)
-  REAL delt
-  REAL cpd
-  REAL cpv
-  REAL cl
-  REAL rv
-  REAL rd
-  REAL lv0
-  REAL g
-  REAL sigs ! SIGS IS THE FRACTION OF PRECIPITATION FALLING OUTSIDE
-  REAL sigd ! SIGD IS THE FRACTIONAL AREA COVERED BY UNSATURATED DNDRAFT
-  REAL elcrit ! ELCRIT IS THE AUTOCONVERSION THERSHOLD WATER CONTENT (gm/gm)
-  REAL tlcrit ! TLCRIT IS CRITICAL TEMPERATURE BELOW WHICH THE AUTO-
-  ! CONVERSION THRESHOLD IS ASSUMED TO BE ZERO
-  REAL omtsnow ! OMTSNOW IS THE ASSUMED FALL SPEED (P/s) OF SNOW
-  REAL dtmax ! DTMAX IS THE MAXIMUM NEGATIVE TEMPERATURE PERTURBATION
-  ! A LIFTED PARCEL IS ALLOWED TO HAVE BELOW ITS LFC.
-  REAL damp
-  REAL alpha
-  REAL entp ! ENTP IS THE COEFFICIENT OF MIXING IN THE ENTRAINMENT FORMULATION
-  REAL coeffs ! COEFFS IS A COEFFICIENT GOVERNING THE RATE OF EVAPORATION OF
-  ! SNOW
-  REAL coeffr ! COEFFR IS A COEFFICIENT GOVERNING THE RATE OF EVAPORATION OF
-  ! RAIN
-  REAL omtrain ! OMTRAIN IS THE ASSUMED FALL SPEED (P/s) OF RAIN
-  REAL cu ! CU IS THE COEFFICIENT GOVERNING CONVECTIVE MOMENTUM TRANSPORT
-
-  REAL ma(len, nd)
-
-
-  ! *** ELCRIT IS THE AUTOCONVERSION THERSHOLD WATER CONTENT (gm/gm) ***
-  ! ***  TLCRIT IS CRITICAL TEMPERATURE BELOW WHICH THE AUTO-        ***
-  ! ***       CONVERSION THRESHOLD IS ASSUMED TO BE ZERO             ***
-  ! ***     (THE AUTOCONVERSION THRESHOLD VARIES LINEARLY            ***
-  ! ***               BETWEEN 0 C AND TLCRIT)                        ***
-  ! ***   ENTP IS THE COEFFICIENT OF MIXING IN THE ENTRAINMENT       ***
-  ! ***                       FORMULATION                            ***
-  ! ***  SIGD IS THE FRACTIONAL AREA COVERED BY UNSATURATED DNDRAFT  ***
-  ! ***  SIGS IS THE FRACTION OF PRECIPITATION FALLING OUTSIDE       ***
-  ! ***                        OF CLOUD                              ***
-  ! ***        OMTRAIN IS THE ASSUMED FALL SPEED (P/s) OF RAIN       ***
-  ! ***     OMTSNOW IS THE ASSUMED FALL SPEED (P/s) OF SNOW          ***
-  ! ***  COEFFR IS A COEFFICIENT GOVERNING THE RATE OF EVAPORATION   ***
-  ! ***                          OF RAIN                             ***
-  ! ***  COEFFS IS A COEFFICIENT GOVERNING THE RATE OF EVAPORATION   ***
-  ! ***                          OF SNOW                             ***
-  ! ***     CU IS THE COEFFICIENT GOVERNING CONVECTIVE MOMENTUM      ***
-  ! ***                         TRANSPORT                            ***
-  ! ***    DTMAX IS THE MAXIMUM NEGATIVE TEMPERATURE PERTURBATION    ***
-  ! ***        A LIFTED PARCEL IS ALLOWED TO HAVE BELOW ITS LFC      ***
-  ! ***    ALPHA AND DAMP ARE PARAMETERS THAT CONTROL THE RATE OF    ***
-  ! ***                 APPROACH TO QUASI-EQUILIBRIUM                ***
-  ! ***   (THEIR STANDARD VALUES ARE  0.20 AND 0.1, RESPECTIVELY)    ***
-  ! ***                   (DAMP MUST BE LESS THAN 1)                 ***
-
-  ! Local arrays.
-
-  REAL work(ncum)
-  REAL t(ncum, klev)
-  REAL q(ncum, klev)
-  REAL qs(ncum, klev)
-  REAL u(ncum, klev)
-  REAL v(ncum, klev)
-  REAL gz(ncum, klev)
-  REAL h(ncum, klev)
-  REAL lv(ncum, klev)
-  REAL cpn(ncum, klev)
-  REAL p(ncum, klev)
-  REAL ph(ncum, klev)
-  REAL ft(ncum, klev)
-  REAL fq(ncum, klev)
-  REAL fu(ncum, klev)
-  REAL fv(ncum, klev)
-  REAL precip(ncum)
-  REAL cbmf(ncum)
-  REAL plcl(ncum)
-  REAL tnk(ncum)
-  REAL qnk(ncum)
-  REAL gznk(ncum)
-  REAL tv(ncum, klev)
-  REAL tp(ncum, klev)
-  REAL tvp(ncum, klev)
-  REAL clw(ncum, klev)
-  ! real det(ncum,klev)
-  REAL dph(ncum, klev)
-  ! real wd(ncum)
-  ! real tprime(ncum)
-  ! real qprime(ncum)
-  REAL ah0(ncum)
-  REAL ep(ncum, klev)
-  REAL sigp(ncum, klev)
-  INTEGER nent(ncum, klev)
-  REAL water(ncum, klev)
-  REAL evap(ncum, klev)
-  REAL mp(ncum, klev)
-  REAL m(ncum, klev)
-  REAL qti
-  REAL wt(ncum, klev)
-  REAL hp(ncum, klev)
-  REAL lvcp(ncum, klev)
-  REAL elij(ncum, klev, klev)
-  REAL ment(ncum, klev, klev)
-  REAL sij(ncum, klev, klev)
-  REAL qent(ncum, klev, klev)
-  REAL uent(ncum, klev, klev)
-  REAL vent(ncum, klev, klev)
-  REAL qp(ncum, klev)
-  REAL up(ncum, klev)
-  REAL vp(ncum, klev)
-  REAL cape(ncum)
-  REAL capem(ncum)
-  REAL frac(ncum)
-  REAL dtpbl(ncum)
-  REAL tvpplcl(ncum)
-  REAL tvaplcl(ncum)
-  REAL dtmin(ncum)
-  REAL w3d(ncum, klev)
-  REAL am(ncum)
-  REAL ents(ncum)
-  REAL uav(ncum)
-  REAL vav(ncum)
-
-  INTEGER iflag(ncum)
-  INTEGER nk(ncum)
-  INTEGER icb(ncum)
-  INTEGER inb(ncum)
-  INTEGER inb1(ncum)
-  INTEGER jtt(ncum)
-
-  INTEGER nn, i, k, n, icbmax, nlp, j
-  INTEGER ij
-  INTEGER nn2, nn3
-  REAL clmcpv
-  REAL clmcpd
-  REAL cpdmcp
-  REAL cpvmcpd
-  REAL eps
-  REAL epsi
-  REAL epsim1
-  REAL tg, qg, s, alv, tc, ahg, denom, es, rg, ginv, rowl
-  REAL delti
-  REAL tca, elacrit
-  REAL by, defrac
-  ! real byp
-  REAL byp(ncum)
-  LOGICAL lcape(ncum)
-  REAL dbo
-  REAL bf2, anum, dei, altem, cwat, stemp
-  REAL alt, qp1, smid, sjmax, sjmin
-  REAL delp, delm
-  REAL awat, coeff, afac, revap, dhdp, fac, qstm, rat
-  REAL qsm, sigt, b6, c6
-  REAL dpinv, cpinv
-  REAL fqold, ftold, fuold, fvold
-  REAL wdtrain(ncum), xxx
-  REAL bsum(ncum, klev)
-  REAL asij(ncum)
-  REAL smin(ncum)
-  REAL scrit(ncum)
-  ! real amp1,ad
-  REAL amp1(ncum), ad(ncum)
-  LOGICAL lwork(ncum)
-  INTEGER num1, num2
-
-  ! print*,'cpd en entree de convect2 ',cpd
-  nlp = nl + 1
-
-  rowl = 1000.0
-  ginv = 1.0/g
-  delti = 1.0/delt
-
-  ! Define some thermodynamic variables.
-
-  clmcpv = cl - cpv
-  clmcpd = cl - cpd
-  cpdmcp = cpd - cpv
-  cpvmcpd = cpv - cpd
-  eps = rd/rv
-  epsi = 1.0/eps
-  epsim1 = epsi - 1.0
-
-  ! Compress the fields.
-
-  DO k = 1, nl + 1
-    nn = 0
-    DO i = 1, len
-      IF (iflag1(i)==0) THEN
-        nn = nn + 1
-        t(nn, k) = t1(i, k)
-        q(nn, k) = q1(i, k)
-        qs(nn, k) = qs1(i, k)
-        u(nn, k) = u1(i, k)
-        v(nn, k) = v1(i, k)
-        gz(nn, k) = gz1(i, k)
-        h(nn, k) = h1(i, k)
-        lv(nn, k) = lv1(i, k)
-        cpn(nn, k) = cpn1(i, k)
-        p(nn, k) = p1(i, k)
-        ph(nn, k) = ph1(i, k)
-        tv(nn, k) = tv1(i, k)
-        tp(nn, k) = tp1(i, k)
-        tvp(nn, k) = tvp1(i, k)
-        clw(nn, k) = clw1(i, k)
-      END IF
-    END DO
-    ! print*,'100 ncum,nn',ncum,nn
-  END DO
-  nn = 0
-  DO i = 1, len
-    IF (iflag1(i)==0) THEN
-      nn = nn + 1
-      cbmf(nn) = cbmf1(i)
-      plcl(nn) = plcl1(i)
-      tnk(nn) = tnk1(i)
-      qnk(nn) = qnk1(i)
-      gznk(nn) = gznk1(i)
-      nk(nn) = nk1(i)
-      icb(nn) = icb1(i)
-      iflag(nn) = iflag1(i)
-    END IF
-  END DO
-  ! print*,'150 ncum,nn',ncum,nn
-
-  ! Initialize the tendencies, det, wd, tprime, qprime.
-
-  DO k = 1, nl
-    DO i = 1, ncum
-      ! det(i,k)=0.0
-      ft(i, k) = 0.0
-      fu(i, k) = 0.0
-      fv(i, k) = 0.0
-      fq(i, k) = 0.0
-      dph(i, k) = ph(i, k) - ph(i, k+1)
-      ep(i, k) = 0.0
-      sigp(i, k) = sigs
-    END DO
-  END DO
-  DO i = 1, ncum
-    ! wd(i)=0.0
-    ! tprime(i)=0.0
-    ! qprime(i)=0.0
-    precip(i) = 0.0
-    ft(i, nl+1) = 0.0
-    fu(i, nl+1) = 0.0
-    fv(i, nl+1) = 0.0
-    fq(i, nl+1) = 0.0
-  END DO
-
-  ! Compute icbmax.
-
-  icbmax = 2
-  DO i = 1, ncum
-    icbmax = max(icbmax, icb(i))
-  END DO
-
-
-  ! =====================================================================
-  ! --- FIND THE REST OF THE LIFTED PARCEL TEMPERATURES
-  ! =====================================================================
-
-  ! ---       The procedure is to solve the equation.
-  ! cp*tp+L*qp+phi=cp*tnk+L*qnk+gznk.
-
-  ! ***  Calculate certain parcel quantities, including static energy   ***
-
-
-  DO i = 1, ncum
-    ah0(i) = (cpd*(1.-qnk(i))+cl*qnk(i))*tnk(i) + qnk(i)*(lv0-clmcpv*(tnk(i)- &
-      273.15)) + gznk(i)
-  END DO
-
-
-  ! ***  Find lifted parcel quantities above cloud base    ***
-
-
-  DO k = minorig + 1, nl
-    DO i = 1, ncum
-      IF (k>=(icb(i)+1)) THEN
-        tg = t(i, k)
-        qg = qs(i, k)
-        alv = lv0 - clmcpv*(t(i,k)-273.15)
-
-        ! First iteration.
-
-        s = cpd + alv*alv*qg/(rv*t(i,k)*t(i,k))
-        s = 1./s
-        ahg = cpd*tg + (cl-cpd)*qnk(i)*t(i, k) + alv*qg + gz(i, k)
-        tg = tg + s*(ah0(i)-ahg)
-        tg = max(tg, 35.0)
-        tc = tg - 273.15
-        denom = 243.5 + tc
-        IF (tc>=0.0) THEN
-          es = 6.112*exp(17.67*tc/denom)
-        ELSE
-          es = exp(23.33086-6111.72784/tg+0.15215*log(tg))
-        END IF
-        qg = eps*es/(p(i,k)-es*(1.-eps))
-
-        ! Second iteration.
-
-        s = cpd + alv*alv*qg/(rv*t(i,k)*t(i,k))
-        s = 1./s
-        ahg = cpd*tg + (cl-cpd)*qnk(i)*t(i, k) + alv*qg + gz(i, k)
-        tg = tg + s*(ah0(i)-ahg)
-        tg = max(tg, 35.0)
-        tc = tg - 273.15
-        denom = 243.5 + tc
-        IF (tc>=0.0) THEN
-          es = 6.112*exp(17.67*tc/denom)
-        ELSE
-          es = exp(23.33086-6111.72784/tg+0.15215*log(tg))
-        END IF
-        qg = eps*es/(p(i,k)-es*(1.-eps))
-
-        alv = lv0 - clmcpv*(t(i,k)-273.15)
-        ! print*,'cpd dans convect2 ',cpd
-        ! print*,'tp(i,k),ah0(i),cl,cpd,qnk(i),t(i,k),gz(i,k),alv,qg,cpd'
-        ! print*,tp(i,k),ah0(i),cl,cpd,qnk(i),t(i,k),gz(i,k),alv,qg,cpd
-        tp(i, k) = (ah0(i)-(cl-cpd)*qnk(i)*t(i,k)-gz(i,k)-alv*qg)/cpd
-        ! if (.not.cpd.gt.1000.) then
-        ! print*,'CPD=',cpd
-        ! stop
-        ! endif
-        clw(i, k) = qnk(i) - qg
-        clw(i, k) = max(0.0, clw(i,k))
-        rg = qg/(1.-qnk(i))
-        tvp(i, k) = tp(i, k)*(1.+rg*epsi)
-      END IF
-    END DO
-  END DO
-
-  ! =====================================================================
-  ! --- SET THE PRECIPITATION EFFICIENCIES AND THE FRACTION OF
-  ! --- PRECIPITATION FALLING OUTSIDE OF CLOUD
-  ! --- THESE MAY BE FUNCTIONS OF TP(I), P(I) AND CLW(I)
-  ! =====================================================================
-
-  DO k = minorig + 1, nl
-    DO i = 1, ncum
-      IF (k>=(nk(i)+1)) THEN
-        tca = tp(i, k) - 273.15
-        IF (tca>=0.0) THEN
-          elacrit = elcrit
-        ELSE
-          elacrit = elcrit*(1.0-tca/tlcrit)
-        END IF
-        elacrit = max(elacrit, 0.0)
-        ep(i, k) = 1.0 - elacrit/max(clw(i,k), 1.0E-8)
-        ep(i, k) = max(ep(i,k), 0.0)
-        ep(i, k) = min(ep(i,k), 1.0)
-        sigp(i, k) = sigs
-      END IF
-    END DO
-  END DO
-
-  ! =====================================================================
-  ! --- CALCULATE VIRTUAL TEMPERATURE AND LIFTED PARCEL
-  ! --- VIRTUAL TEMPERATURE
-  ! =====================================================================
-
-  DO k = minorig + 1, nl
-    DO i = 1, ncum
-      IF (k>=(icb(i)+1)) THEN
-        tvp(i, k) = tvp(i, k)*(1.0-qnk(i)+ep(i,k)*clw(i,k))
-        ! print*,'i,k,tvp(i,k),qnk(i),ep(i,k),clw(i,k)'
-        ! print*, i,k,tvp(i,k),qnk(i),ep(i,k),clw(i,k)
-      END IF
-    END DO
-  END DO
-  DO i = 1, ncum
-    tvp(i, nlp) = tvp(i, nl) - (gz(i,nlp)-gz(i,nl))/cpd
-  END DO
-
-
-  ! =====================================================================
-  ! --- NOW INITIALIZE VARIOUS ARRAYS USED IN THE COMPUTATIONS
-  ! =====================================================================
-
-  DO i = 1, ncum*nlp
-    nent(i, 1) = 0
-    water(i, 1) = 0.0
-    evap(i, 1) = 0.0
-    mp(i, 1) = 0.0
-    m(i, 1) = 0.0
-    wt(i, 1) = omtsnow
-    hp(i, 1) = h(i, 1)
-    ! if(.not.cpn(i,1).gt.900.) then
-    ! print*,'i,lv(i,1),cpn(i,1)'
-    ! print*, i,lv(i,1),cpn(i,1)
-    ! k=(i-1)/ncum+1
-    ! print*,'i,k',mod(i,ncum),k,'  cpn',cpn(mod(i,ncum),k)
-    ! stop
-    ! endif
-    lvcp(i, 1) = lv(i, 1)/cpn(i, 1)
-  END DO
-
-  DO i = 1, ncum*nlp*nlp
-    elij(i, 1, 1) = 0.0
-    ment(i, 1, 1) = 0.0
-    sij(i, 1, 1) = 0.0
-  END DO
-
-  DO k = 1, nlp
-    DO j = 1, nlp
-      DO i = 1, ncum
-        qent(i, k, j) = q(i, j)
-        uent(i, k, j) = u(i, j)
-        vent(i, k, j) = v(i, j)
-      END DO
-    END DO
-  END DO
-
-  DO i = 1, ncum
-    qp(i, 1) = q(i, 1)
-    up(i, 1) = u(i, 1)
-    vp(i, 1) = v(i, 1)
-  END DO
-  DO k = 2, nlp
-    DO i = 1, ncum
-      qp(i, k) = q(i, k-1)
-      up(i, k) = u(i, k-1)
-      vp(i, k) = v(i, k-1)
-    END DO
-  END DO
-
-  ! =====================================================================
-  ! --- FIND THE FIRST MODEL LEVEL (INB1) ABOVE THE PARCEL'S
-  ! --- HIGHEST LEVEL OF NEUTRAL BUOYANCY
-  ! --- AND THE HIGHEST LEVEL OF POSITIVE CAPE (INB)
-  ! =====================================================================
-
-  DO i = 1, ncum
-    cape(i) = 0.0
-    capem(i) = 0.0
-    inb(i) = icb(i) + 1
-    inb1(i) = inb(i)
-  END DO
-
-  ! Originial Code
-
-  ! do 530 k=minorig+1,nl-1
-  ! do 520 i=1,ncum
-  ! if(k.ge.(icb(i)+1))then
-  ! by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k)
-  ! byp=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1)
-  ! cape(i)=cape(i)+by
-  ! if(by.ge.0.0)inb1(i)=k+1
-  ! if(cape(i).gt.0.0)then
-  ! inb(i)=k+1
-  ! capem(i)=cape(i)
-  ! endif
-  ! endif
-  ! 520    continue
-  ! 530  continue
-  ! do 540 i=1,ncum
-  ! byp=(tvp(i,nl)-tv(i,nl))*dph(i,nl)/p(i,nl)
-  ! cape(i)=capem(i)+byp
-  ! defrac=capem(i)-cape(i)
-  ! defrac=max(defrac,0.001)
-  ! frac(i)=-cape(i)/defrac
-  ! frac(i)=min(frac(i),1.0)
-  ! frac(i)=max(frac(i),0.0)
-  ! 540   continue
-
-  ! K Emanuel fix
-
-  ! call zilch(byp,ncum)
-  ! do 530 k=minorig+1,nl-1
-  ! do 520 i=1,ncum
-  ! if(k.ge.(icb(i)+1))then
-  ! by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k)
-  ! cape(i)=cape(i)+by
-  ! if(by.ge.0.0)inb1(i)=k+1
-  ! if(cape(i).gt.0.0)then
-  ! inb(i)=k+1
-  ! capem(i)=cape(i)
-  ! byp(i)=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1)
-  ! endif
-  ! endif
-  ! 520    continue
-  ! 530  continue
-  ! do 540 i=1,ncum
-  ! inb(i)=max(inb(i),inb1(i))
-  ! cape(i)=capem(i)+byp(i)
-  ! defrac=capem(i)-cape(i)
-  ! defrac=max(defrac,0.001)
-  ! frac(i)=-cape(i)/defrac
-  ! frac(i)=min(frac(i),1.0)
-  ! frac(i)=max(frac(i),0.0)
-  ! 540   continue
-
-  ! J Teixeira fix
-
-  CALL zilch(byp, ncum)
-  DO i = 1, ncum
-    lcape(i) = .TRUE.
-  END DO
-  DO k = minorig + 1, nl - 1
-    DO i = 1, ncum
-      IF (cape(i)<0.0) lcape(i) = .FALSE.
-      IF ((k>=(icb(i)+1)) .AND. lcape(i)) THEN
-        by = (tvp(i,k)-tv(i,k))*dph(i, k)/p(i, k)
-        byp(i) = (tvp(i,k+1)-tv(i,k+1))*dph(i, k+1)/p(i, k+1)
-        cape(i) = cape(i) + by
-        IF (by>=0.0) inb1(i) = k + 1
-        IF (cape(i)>0.0) THEN
-          inb(i) = k + 1
-          capem(i) = cape(i)
-        END IF
-      END IF
-    END DO
-  END DO
-  DO i = 1, ncum
-    cape(i) = capem(i) + byp(i)
-    defrac = capem(i) - cape(i)
-    defrac = max(defrac, 0.001)
-    frac(i) = -cape(i)/defrac
-    frac(i) = min(frac(i), 1.0)
-    frac(i) = max(frac(i), 0.0)
-  END DO
-
-  ! =====================================================================
-  ! ---   CALCULATE LIQUID WATER STATIC ENERGY OF LIFTED PARCEL
-  ! =====================================================================
-
-  DO k = minorig + 1, nl
-    DO i = 1, ncum
-      IF ((k>=icb(i)) .AND. (k<=inb(i))) THEN
-        hp(i, k) = h(i, nk(i)) + (lv(i,k)+(cpd-cpv)*t(i,k))*ep(i, k)*clw(i, k &
-          )
-      END IF
-    END DO
-  END DO
-
-  ! =====================================================================
-  ! ---  CALCULATE CLOUD BASE MASS FLUX AND RATES OF MIXING, M(I),
-  ! --- AT EACH MODEL LEVEL
-  ! =====================================================================
-
-  ! tvpplcl = parcel temperature lifted adiabatically from level
-  ! icb-1 to the LCL.
-  ! tvaplcl = virtual temperature at the LCL.
-
-  DO i = 1, ncum
-    dtpbl(i) = 0.0
-    tvpplcl(i) = tvp(i, icb(i)-1) - rd*tvp(i, icb(i)-1)*(p(i,icb(i)-1)-plcl(i &
-      ))/(cpn(i,icb(i)-1)*p(i,icb(i)-1))
-    tvaplcl(i) = tv(i, icb(i)) + (tvp(i,icb(i))-tvp(i,icb(i)+1))*(plcl(i)-p(i &
-      ,icb(i)))/(p(i,icb(i))-p(i,icb(i)+1))
-  END DO
-
-  ! -------------------------------------------------------------------
-  ! --- Interpolate difference between lifted parcel and
-  ! --- environmental temperatures to lifted condensation level
-  ! -------------------------------------------------------------------
-
-  ! dtpbl = average of tvp-tv in the PBL (k=nk to icb-1).
-
-  DO k = minorig, icbmax
-    DO i = 1, ncum
-      IF ((k>=nk(i)) .AND. (k<=(icb(i)-1))) THEN
-        dtpbl(i) = dtpbl(i) + (tvp(i,k)-tv(i,k))*dph(i, k)
-      END IF
-    END DO
-  END DO
-  DO i = 1, ncum
-    dtpbl(i) = dtpbl(i)/(ph(i,nk(i))-ph(i,icb(i)))
-    dtmin(i) = tvpplcl(i) - tvaplcl(i) + dtmax + dtpbl(i)
-  END DO
-
-  ! -------------------------------------------------------------------
-  ! --- Adjust cloud base mass flux
-  ! -------------------------------------------------------------------
-
-  DO i = 1, ncum
-    work(i) = cbmf(i)
-    cbmf(i) = max(0.0, (1.0-damp)*cbmf(i)+0.1*alpha*dtmin(i))
-    IF ((work(i)==0.0) .AND. (cbmf(i)==0.0)) THEN
-      iflag(i) = 3
-    END IF
-  END DO
-
-  ! -------------------------------------------------------------------
-  ! --- Calculate rates of mixing,  m(i)
-  ! -------------------------------------------------------------------
-
-  CALL zilch(work, ncum)
-
-  DO j = minorig + 1, nl
-    DO i = 1, ncum
-      IF ((j>=(icb(i)+1)) .AND. (j<=inb(i))) THEN
-        k = min(j, inb1(i))
-        dbo = abs(tv(i,k+1)-tvp(i,k+1)-tv(i,k-1)+tvp(i,k-1)) + &
-          entp*0.04*(ph(i,k)-ph(i,k+1))
-        work(i) = work(i) + dbo
-        m(i, j) = cbmf(i)*dbo
-      END IF
-    END DO
-  END DO
-  DO k = minorig + 1, nl
-    DO i = 1, ncum
-      IF ((k>=(icb(i)+1)) .AND. (k<=inb(i))) THEN
-        m(i, k) = m(i, k)/work(i)
-      END IF
-    END DO
-  END DO
-
-
-  ! =====================================================================
-  ! --- CALCULATE ENTRAINED AIR MASS FLUX (ment), TOTAL WATER MIXING
-  ! --- RATIO (QENT), TOTAL CONDENSED WATER (elij), AND MIXING
-  ! --- FRACTION (sij)
-  ! =====================================================================
-
-
-  DO i = minorig + 1, nl
-    DO j = minorig + 1, nl
-      DO ij = 1, ncum
-        IF ((i>=(icb(ij)+1)) .AND. (j>=icb(ij)) .AND. (i<=inb(ij)) .AND. (j<= &
-            inb(ij))) THEN
-          qti = qnk(ij) - ep(ij, i)*clw(ij, i)
-          bf2 = 1. + lv(ij, j)*lv(ij, j)*qs(ij, j)/(rv*t(ij,j)*t(ij,j)*cpd)
-          anum = h(ij, j) - hp(ij, i) + (cpv-cpd)*t(ij, j)*(qti-q(ij,j))
-          denom = h(ij, i) - hp(ij, i) + (cpd-cpv)*(q(ij,i)-qti)*t(ij, j)
-          dei = denom
-          IF (abs(dei)<0.01) dei = 0.01
-          sij(ij, i, j) = anum/dei
-          sij(ij, i, i) = 1.0
-          altem = sij(ij, i, j)*q(ij, i) + (1.-sij(ij,i,j))*qti - qs(ij, j)
-          altem = altem/bf2
-          cwat = clw(ij, j)*(1.-ep(ij,j))
-          stemp = sij(ij, i, j)
-          IF ((stemp<0.0 .OR. stemp>1.0 .OR. altem>cwat) .AND. j>i) THEN
-            anum = anum - lv(ij, j)*(qti-qs(ij,j)-cwat*bf2)
-            denom = denom + lv(ij, j)*(q(ij,i)-qti)
-            IF (abs(denom)<0.01) denom = 0.01
-            sij(ij, i, j) = anum/denom
-            altem = sij(ij, i, j)*q(ij, i) + (1.-sij(ij,i,j))*qti - qs(ij, j)
-            altem = altem - (bf2-1.)*cwat
-          END IF
-          IF (sij(ij,i,j)>0.0 .AND. sij(ij,i,j)<0.9) THEN
-            qent(ij, i, j) = sij(ij, i, j)*q(ij, i) + (1.-sij(ij,i,j))*qti
-            uent(ij, i, j) = sij(ij, i, j)*u(ij, i) + &
-              (1.-sij(ij,i,j))*u(ij, nk(ij))
-            vent(ij, i, j) = sij(ij, i, j)*v(ij, i) + &
-              (1.-sij(ij,i,j))*v(ij, nk(ij))
-            elij(ij, i, j) = altem
-            elij(ij, i, j) = max(0.0, elij(ij,i,j))
-            ment(ij, i, j) = m(ij, i)/(1.-sij(ij,i,j))
-            nent(ij, i) = nent(ij, i) + 1
-          END IF
-          sij(ij, i, j) = max(0.0, sij(ij,i,j))
-          sij(ij, i, j) = min(1.0, sij(ij,i,j))
-        END IF
-      END DO
-    END DO
-
-    ! ***   If no air can entrain at level i assume that updraft detrains
-    ! ***
-    ! ***   at that level and calculate detrained air flux and properties
-    ! ***
-
-    DO ij = 1, ncum
-      IF ((i>=(icb(ij)+1)) .AND. (i<=inb(ij)) .AND. (nent(ij,i)==0)) THEN
-        ment(ij, i, i) = m(ij, i)
-        qent(ij, i, i) = q(ij, nk(ij)) - ep(ij, i)*clw(ij, i)
-        uent(ij, i, i) = u(ij, nk(ij))
-        vent(ij, i, i) = v(ij, nk(ij))
-        elij(ij, i, i) = clw(ij, i)
-        sij(ij, i, i) = 1.0
-      END IF
-    END DO
-  END DO
-
-  DO i = 1, ncum
-    sij(i, inb(i), inb(i)) = 1.0
-  END DO
-
-  ! =====================================================================
-  ! ---  NORMALIZE ENTRAINED AIR MASS FLUXES
-  ! ---  TO REPRESENT EQUAL PROBABILITIES OF MIXING
-  ! =====================================================================
-
-
-  CALL zilch(bsum, ncum*nlp)
-  DO ij = 1, ncum
-    lwork(ij) = .FALSE.
-  END DO
-  DO i = minorig + 1, nl
-
-    num1 = 0
-    DO ij = 1, ncum
-      IF ((i>=icb(ij)+1) .AND. (i<=inb(ij))) num1 = num1 + 1
-    END DO
-    IF (num1<=0) GO TO 789
-
-    DO ij = 1, ncum
-      IF ((i>=icb(ij)+1) .AND. (i<=inb(ij))) THEN
-        lwork(ij) = (nent(ij,i)/=0)
-        qp1 = q(ij, nk(ij)) - ep(ij, i)*clw(ij, i)
-        anum = h(ij, i) - hp(ij, i) - lv(ij, i)*(qp1-qs(ij,i))
-        denom = h(ij, i) - hp(ij, i) + lv(ij, i)*(q(ij,i)-qp1)
-        IF (abs(denom)<0.01) denom = 0.01
-        scrit(ij) = anum/denom
-        alt = qp1 - qs(ij, i) + scrit(ij)*(q(ij,i)-qp1)
-        IF (scrit(ij)<0.0 .OR. alt<0.0) scrit(ij) = 1.0
-        asij(ij) = 0.0
-        smin(ij) = 1.0
-      END IF
-    END DO
-    DO j = minorig, nl
-
-      num2 = 0
-      DO ij = 1, ncum
-        IF ((i>=icb(ij)+1) .AND. (i<=inb(ij)) .AND. (j>=icb( &
-          ij)) .AND. (j<=inb(ij)) .AND. lwork(ij)) num2 = num2 + 1
-      END DO
-      IF (num2<=0) GO TO 783
-
-      DO ij = 1, ncum
-        IF ((i>=icb(ij)+1) .AND. (i<=inb(ij)) .AND. (j>=icb( &
-            ij)) .AND. (j<=inb(ij)) .AND. lwork(ij)) THEN
-          IF (sij(ij,i,j)>0.0 .AND. sij(ij,i,j)<0.9) THEN
-            IF (j>i) THEN
-              smid = min(sij(ij,i,j), scrit(ij))
-              sjmax = smid
-              sjmin = smid
-              IF (smid<smin(ij) .AND. sij(ij,i,j+1)<smid) THEN
-                smin(ij) = smid
-                sjmax = min(sij(ij,i,j+1), sij(ij,i,j), scrit(ij))
-                sjmin = max(sij(ij,i,j-1), sij(ij,i,j))
-                sjmin = min(sjmin, scrit(ij))
-              END IF
-            ELSE
-              sjmax = max(sij(ij,i,j+1), scrit(ij))
-              smid = max(sij(ij,i,j), scrit(ij))
-              sjmin = 0.0
-              IF (j>1) sjmin = sij(ij, i, j-1)
-              sjmin = max(sjmin, scrit(ij))
-            END IF
-            delp = abs(sjmax-smid)
-            delm = abs(sjmin-smid)
-            asij(ij) = asij(ij) + (delp+delm)*(ph(ij,j)-ph(ij,j+1))
-            ment(ij, i, j) = ment(ij, i, j)*(delp+delm)*(ph(ij,j)-ph(ij,j+1))
-          END IF
-        END IF
-      END DO
-783 END DO
-    DO ij = 1, ncum
-      IF ((i>=icb(ij)+1) .AND. (i<=inb(ij)) .AND. lwork(ij)) THEN
-        asij(ij) = max(1.0E-21, asij(ij))
-        asij(ij) = 1.0/asij(ij)
-        bsum(ij, i) = 0.0
-      END IF
-    END DO
-    DO j = minorig, nl + 1
-      DO ij = 1, ncum
-        IF ((i>=icb(ij)+1) .AND. (i<=inb(ij)) .AND. (j>=icb( &
-            ij)) .AND. (j<=inb(ij)) .AND. lwork(ij)) THEN
-          ment(ij, i, j) = ment(ij, i, j)*asij(ij)
-          bsum(ij, i) = bsum(ij, i) + ment(ij, i, j)
-        END IF
-      END DO
-    END DO
-    DO ij = 1, ncum
-      IF ((i>=icb(ij)+1) .AND. (i<=inb(ij)) .AND. (bsum(ij, &
-          i)<1.0E-18) .AND. lwork(ij)) THEN
-        nent(ij, i) = 0
-        ment(ij, i, i) = m(ij, i)
-        qent(ij, i, i) = q(ij, nk(ij)) - ep(ij, i)*clw(ij, i)
-        uent(ij, i, i) = u(ij, nk(ij))
-        vent(ij, i, i) = v(ij, nk(ij))
-        elij(ij, i, i) = clw(ij, i)
-        sij(ij, i, i) = 1.0
-      END IF
-    END DO
-789 END DO
-
-  ! =====================================================================
-  ! --- PRECIPITATING DOWNDRAFT CALCULATION
-  ! =====================================================================
-
-  ! ***  Check whether ep(inb)=0, if so, skip precipitating    ***
-  ! ***             downdraft calculation                      ***
-
-
-  ! ***  Integrate liquid water equation to find condensed water   ***
-  ! ***                and condensed water flux                    ***
-
-
-  DO i = 1, ncum
-    jtt(i) = 2
-    IF (ep(i,inb(i))<=0.0001) iflag(i) = 2
-    IF (iflag(i)==0) THEN
-      lwork(i) = .TRUE.
-    ELSE
-      lwork(i) = .FALSE.
-    END IF
-  END DO
-
-  ! ***                    Begin downdraft loop                    ***
-
-
-  CALL zilch(wdtrain, ncum)
-  DO i = nl + 1, 1, -1
-
-    num1 = 0
-    DO ij = 1, ncum
-      IF ((i<=inb(ij)) .AND. lwork(ij)) num1 = num1 + 1
-    END DO
-    IF (num1<=0) GO TO 899
-
-
-    ! ***        Calculate detrained precipitation             ***
-
-    DO ij = 1, ncum
-      IF ((i<=inb(ij)) .AND. (lwork(ij))) THEN
-        wdtrain(ij) = g*ep(ij, i)*m(ij, i)*clw(ij, i)
-      END IF
-    END DO
-
-    IF (i>1) THEN
-      DO j = 1, i - 1
-        DO ij = 1, ncum
-          IF ((i<=inb(ij)) .AND. (lwork(ij))) THEN
-            awat = elij(ij, j, i) - (1.-ep(ij,i))*clw(ij, i)
-            awat = max(0.0, awat)
-            wdtrain(ij) = wdtrain(ij) + g*awat*ment(ij, j, i)
-          END IF
-        END DO
-      END DO
-    END IF
-
-    ! ***    Find rain water and evaporation using provisional   ***
-    ! ***              estimates of qp(i)and qp(i-1)             ***
-
-
-    ! ***  Value of terminal velocity and coeffecient of evaporation for snow
-    ! ***
-
-    DO ij = 1, ncum
-      IF ((i<=inb(ij)) .AND. (lwork(ij))) THEN
-        coeff = coeffs
-        wt(ij, i) = omtsnow
-
-        ! ***  Value of terminal velocity and coeffecient of evaporation for
-        ! rain   ***
-
-        IF (t(ij,i)>273.0) THEN
-          coeff = coeffr
-          wt(ij, i) = omtrain
-        END IF
-        qsm = 0.5*(q(ij,i)+qp(ij,i+1))
-        afac = coeff*ph(ij, i)*(qs(ij,i)-qsm)/(1.0E4+2.0E3*ph(ij,i)*qs(ij,i))
-        afac = max(afac, 0.0)
-        sigt = sigp(ij, i)
-        sigt = max(0.0, sigt)
-        sigt = min(1.0, sigt)
-        b6 = 100.*(ph(ij,i)-ph(ij,i+1))*sigt*afac/wt(ij, i)
-        c6 = (water(ij,i+1)*wt(ij,i+1)+wdtrain(ij)/sigd)/wt(ij, i)
-        revap = 0.5*(-b6+sqrt(b6*b6+4.*c6))
-        evap(ij, i) = sigt*afac*revap
-        water(ij, i) = revap*revap
-
-        ! ***  Calculate precipitating downdraft mass flux under     ***
-        ! ***              hydrostatic approximation                 ***
-
-        IF (i>1) THEN
-          dhdp = (h(ij,i)-h(ij,i-1))/(p(ij,i-1)-p(ij,i))
-          dhdp = max(dhdp, 10.0)
-          mp(ij, i) = 100.*ginv*lv(ij, i)*sigd*evap(ij, i)/dhdp
-          mp(ij, i) = max(mp(ij,i), 0.0)
-
-          ! ***   Add small amount of inertia to downdraft              ***
-
-          fac = 20.0/(ph(ij,i-1)-ph(ij,i))
-          mp(ij, i) = (fac*mp(ij,i+1)+mp(ij,i))/(1.+fac)
-
-          ! ***      Force mp to decrease linearly to zero
-          ! ***
-          ! ***      between about 950 mb and the surface
-          ! ***
-
-          IF (p(ij,i)>(0.949*p(ij,1))) THEN
-            jtt(ij) = max(jtt(ij), i)
-            mp(ij, i) = mp(ij, jtt(ij))*(p(ij,1)-p(ij,i))/ &
-              (p(ij,1)-p(ij,jtt(ij)))
-          END IF
-        END IF
-
-        ! ***       Find mixing ratio of precipitating downdraft     ***
-
-        IF (i/=inb(ij)) THEN
-          IF (i==1) THEN
-            qstm = qs(ij, 1)
-          ELSE
-            qstm = qs(ij, i-1)
-          END IF
-          IF (mp(ij,i)>mp(ij,i+1)) THEN
-            rat = mp(ij, i+1)/mp(ij, i)
-            qp(ij, i) = qp(ij, i+1)*rat + q(ij, i)*(1.0-rat) + &
-              100.*ginv*sigd*(ph(ij,i)-ph(ij,i+1))*(evap(ij,i)/mp(ij,i))
-            up(ij, i) = up(ij, i+1)*rat + u(ij, i)*(1.-rat)
-            vp(ij, i) = vp(ij, i+1)*rat + v(ij, i)*(1.-rat)
-          ELSE
-            IF (mp(ij,i+1)>0.0) THEN
-              qp(ij, i) = (gz(ij,i+1)-gz(ij,i)+qp(ij,i+1)*(lv(ij,i+1)+t(ij, &
-                i+1)*(cl-cpd))+cpd*(t(ij,i+1)-t(ij, &
-                i)))/(lv(ij,i)+t(ij,i)*(cl-cpd))
-              up(ij, i) = up(ij, i+1)
-              vp(ij, i) = vp(ij, i+1)
-            END IF
-          END IF
-          qp(ij, i) = min(qp(ij,i), qstm)
-          qp(ij, i) = max(qp(ij,i), 0.0)
-        END IF
-      END IF
-    END DO
-899 END DO
-
-  ! ***  Calculate surface precipitation in mm/day     ***
-
-  DO i = 1, ncum
-    IF (iflag(i)<=1) THEN
-      ! c            precip(i)=precip(i)+wt(i,1)*sigd*water(i,1)*3600.*24000.
-      ! c     &                /(rowl*g)
-      ! c            precip(i)=precip(i)*delt/86400.
-      precip(i) = wt(i, 1)*sigd*water(i, 1)*86400/g
-    END IF
-  END DO
-
-
-  ! ***  Calculate downdraft velocity scale and surface temperature and  ***
-  ! ***                    water vapor fluctuations                      ***
-
-  ! wd=beta*abs(mp(icb))*0.01*rd*t(icb)/(sigd*p(icb))
-  ! qprime=0.5*(qp(1)-q(1))
-  ! tprime=lv0*qprime/cpd
-
-  ! ***  Calculate tendencies of lowest level potential temperature  ***
-  ! ***                      and mixing ratio                        ***
-
-  DO i = 1, ncum
-    work(i) = 0.01/(ph(i,1)-ph(i,2))
-    am(i) = 0.0
-  END DO
-  DO k = 2, nl
-    DO i = 1, ncum
-      IF ((nk(i)==1) .AND. (k<=inb(i)) .AND. (nk(i)==1)) THEN
-        am(i) = am(i) + m(i, k)
-      END IF
-    END DO
-  END DO
-  DO i = 1, ncum
-    IF ((g*work(i)*am(i))>=delti) iflag(i) = 1
-    ft(i, 1) = ft(i, 1) + g*work(i)*am(i)*(t(i,2)-t(i,1)+(gz(i,2)-gz(i, &
-      1))/cpn(i,1))
-    ft(i, 1) = ft(i, 1) - lvcp(i, 1)*sigd*evap(i, 1)
-    ft(i, 1) = ft(i, 1) + sigd*wt(i, 2)*(cl-cpd)*water(i, 2)*(t(i,2)-t(i,1))* &
-      work(i)/cpn(i, 1)
-    fq(i, 1) = fq(i, 1) + g*mp(i, 2)*(qp(i,2)-q(i,1))*work(i) + &
-      sigd*evap(i, 1)
-    fq(i, 1) = fq(i, 1) + g*am(i)*(q(i,2)-q(i,1))*work(i)
-    fu(i, 1) = fu(i, 1) + g*work(i)*(mp(i,2)*(up(i,2)-u(i,1))+am(i)*(u(i, &
-      2)-u(i,1)))
-    fv(i, 1) = fv(i, 1) + g*work(i)*(mp(i,2)*(vp(i,2)-v(i,1))+am(i)*(v(i, &
-      2)-v(i,1)))
-  END DO
-  DO j = 2, nl
-    DO i = 1, ncum
-      IF (j<=inb(i)) THEN
-        fq(i, 1) = fq(i, 1) + g*work(i)*ment(i, j, 1)*(qent(i,j,1)-q(i,1))
-        fu(i, 1) = fu(i, 1) + g*work(i)*ment(i, j, 1)*(uent(i,j,1)-u(i,1))
-        fv(i, 1) = fv(i, 1) + g*work(i)*ment(i, j, 1)*(vent(i,j,1)-v(i,1))
-      END IF
-    END DO
-  END DO
-
-  ! ***  Calculate tendencies of potential temperature and mixing ratio  ***
-  ! ***               at levels above the lowest level                   ***
-
-  ! ***  First find the net saturated updraft and downdraft mass fluxes  ***
-  ! ***                      through each level                          ***
-
-  DO i = 2, nl + 1
-
-    num1 = 0
-    DO ij = 1, ncum
-      IF (i<=inb(ij)) num1 = num1 + 1
-    END DO
-    IF (num1<=0) GO TO 1500
-
-    CALL zilch(amp1, ncum)
-    CALL zilch(ad, ncum)
-
-    DO k = i + 1, nl + 1
-      DO ij = 1, ncum
-        IF ((i>=nk(ij)) .AND. (i<=inb(ij)) .AND. (k<=(inb(ij)+1))) THEN
-          amp1(ij) = amp1(ij) + m(ij, k)
-        END IF
-      END DO
-    END DO
-
-    DO k = 1, i
-      DO j = i + 1, nl + 1
-        DO ij = 1, ncum
-          IF ((j<=(inb(ij)+1)) .AND. (i<=inb(ij))) THEN
-            amp1(ij) = amp1(ij) + ment(ij, k, j)
-          END IF
-        END DO
-      END DO
-    END DO
-    DO k = 1, i - 1
-      DO j = i, nl + 1
-        DO ij = 1, ncum
-          IF ((i<=inb(ij)) .AND. (j<=inb(ij))) THEN
-            ad(ij) = ad(ij) + ment(ij, j, k)
-          END IF
-        END DO
-      END DO
-    END DO
-
-    DO ij = 1, ncum
-      IF (i<=inb(ij)) THEN
-        dpinv = 0.01/(ph(ij,i)-ph(ij,i+1))
-        cpinv = 1.0/cpn(ij, i)
-
-        ft(ij, i) = ft(ij, i) + g*dpinv*(amp1(ij)*(t(ij,i+1)-t(ij, &
-          i)+(gz(ij,i+1)-gz(ij,i))*cpinv)-ad(ij)*(t(ij,i)-t(ij, &
-          i-1)+(gz(ij,i)-gz(ij,i-1))*cpinv)) - sigd*lvcp(ij, i)*evap(ij, i)
-        ft(ij, i) = ft(ij, i) + g*dpinv*ment(ij, i, i)*(hp(ij,i)-h(ij,i)+t(ij &
-          ,i)*(cpv-cpd)*(q(ij,i)-qent(ij,i,i)))*cpinv
-        ft(ij, i) = ft(ij, i) + sigd*wt(ij, i+1)*(cl-cpd)*water(ij, i+1)*(t( &
-          ij,i+1)-t(ij,i))*dpinv*cpinv
-        fq(ij, i) = fq(ij, i) + g*dpinv*(amp1(ij)*(q(ij,i+1)-q(ij, &
-          i))-ad(ij)*(q(ij,i)-q(ij,i-1)))
-        fu(ij, i) = fu(ij, i) + g*dpinv*(amp1(ij)*(u(ij,i+1)-u(ij, &
-          i))-ad(ij)*(u(ij,i)-u(ij,i-1)))
-        fv(ij, i) = fv(ij, i) + g*dpinv*(amp1(ij)*(v(ij,i+1)-v(ij, &
-          i))-ad(ij)*(v(ij,i)-v(ij,i-1)))
-      END IF
-    END DO
-    DO k = 1, i - 1
-      DO ij = 1, ncum
-        IF (i<=inb(ij)) THEN
-          awat = elij(ij, k, i) - (1.-ep(ij,i))*clw(ij, i)
-          awat = max(awat, 0.0)
-          fq(ij, i) = fq(ij, i) + g*dpinv*ment(ij, k, i)*(qent(ij,k,i)-awat-q &
-            (ij,i))
-          fu(ij, i) = fu(ij, i) + g*dpinv*ment(ij, k, i)*(uent(ij,k,i)-u(ij,i &
-            ))
-          fv(ij, i) = fv(ij, i) + g*dpinv*ment(ij, k, i)*(vent(ij,k,i)-v(ij,i &
-            ))
-        END IF
-      END DO
-    END DO
-    DO k = i, nl + 1
-      DO ij = 1, ncum
-        IF ((i<=inb(ij)) .AND. (k<=inb(ij))) THEN
-          fq(ij, i) = fq(ij, i) + g*dpinv*ment(ij, k, i)*(qent(ij,k,i)-q(ij,i &
-            ))
-          fu(ij, i) = fu(ij, i) + g*dpinv*ment(ij, k, i)*(uent(ij,k,i)-u(ij,i &
-            ))
-          fv(ij, i) = fv(ij, i) + g*dpinv*ment(ij, k, i)*(vent(ij,k,i)-v(ij,i &
-            ))
-        END IF
-      END DO
-    END DO
-    DO ij = 1, ncum
-      IF (i<=inb(ij)) THEN
-        fq(ij, i) = fq(ij, i) + sigd*evap(ij, i) + g*(mp(ij,i+1)*(qp(ij, &
-          i+1)-q(ij,i))-mp(ij,i)*(qp(ij,i)-q(ij,i-1)))*dpinv
-        fu(ij, i) = fu(ij, i) + g*(mp(ij,i+1)*(up(ij,i+1)-u(ij, &
-          i))-mp(ij,i)*(up(ij,i)-u(ij,i-1)))*dpinv
-        fv(ij, i) = fv(ij, i) + g*(mp(ij,i+1)*(vp(ij,i+1)-v(ij, &
-          i))-mp(ij,i)*(vp(ij,i)-v(ij,i-1)))*dpinv
-      END IF
-    END DO
-1500 END DO
-
-  ! *** Adjust tendencies at top of convection layer to reflect  ***
-  ! ***       actual position of the level zero cape             ***
-
-  DO ij = 1, ncum
-    fqold = fq(ij, inb(ij))
-    fq(ij, inb(ij)) = fq(ij, inb(ij))*(1.-frac(ij))
-    fq(ij, inb(ij)-1) = fq(ij, inb(ij)-1) + frac(ij)*fqold*((ph(ij, &
-      inb(ij))-ph(ij,inb(ij)+1))/(ph(ij,inb(ij)-1)-ph(ij, &
-      inb(ij))))*lv(ij, inb(ij))/lv(ij, inb(ij)-1)
-    ftold = ft(ij, inb(ij))
-    ft(ij, inb(ij)) = ft(ij, inb(ij))*(1.-frac(ij))
-    ft(ij, inb(ij)-1) = ft(ij, inb(ij)-1) + frac(ij)*ftold*((ph(ij, &
-      inb(ij))-ph(ij,inb(ij)+1))/(ph(ij,inb(ij)-1)-ph(ij, &
-      inb(ij))))*cpn(ij, inb(ij))/cpn(ij, inb(ij)-1)
-    fuold = fu(ij, inb(ij))
-    fu(ij, inb(ij)) = fu(ij, inb(ij))*(1.-frac(ij))
-    fu(ij, inb(ij)-1) = fu(ij, inb(ij)-1) + frac(ij)*fuold*((ph(ij, &
-      inb(ij))-ph(ij,inb(ij)+1))/(ph(ij,inb(ij)-1)-ph(ij,inb(ij))))
-    fvold = fv(ij, inb(ij))
-    fv(ij, inb(ij)) = fv(ij, inb(ij))*(1.-frac(ij))
-    fv(ij, inb(ij)-1) = fv(ij, inb(ij)-1) + frac(ij)*fvold*((ph(ij, &
-      inb(ij))-ph(ij,inb(ij)+1))/(ph(ij,inb(ij)-1)-ph(ij,inb(ij))))
-  END DO
-
-  ! ***   Very slightly adjust tendencies to force exact   ***
-  ! ***     enthalpy, momentum and tracer conservation     ***
-
-  DO ij = 1, ncum
-    ents(ij) = 0.0
-    uav(ij) = 0.0
-    vav(ij) = 0.0
-    DO i = 1, inb(ij)
-      ents(ij) = ents(ij) + (cpn(ij,i)*ft(ij,i)+lv(ij,i)*fq(ij,i))*(ph(ij,i)- &
-        ph(ij,i+1))
-      uav(ij) = uav(ij) + fu(ij, i)*(ph(ij,i)-ph(ij,i+1))
-      vav(ij) = vav(ij) + fv(ij, i)*(ph(ij,i)-ph(ij,i+1))
-    END DO
-  END DO
-  DO ij = 1, ncum
-    ents(ij) = ents(ij)/(ph(ij,1)-ph(ij,inb(ij)+1))
-    uav(ij) = uav(ij)/(ph(ij,1)-ph(ij,inb(ij)+1))
-    vav(ij) = vav(ij)/(ph(ij,1)-ph(ij,inb(ij)+1))
-  END DO
-  DO ij = 1, ncum
-    DO i = 1, inb(ij)
-      ft(ij, i) = ft(ij, i) - ents(ij)/cpn(ij, i)
-      fu(ij, i) = (1.-cu)*(fu(ij,i)-uav(ij))
-      fv(ij, i) = (1.-cu)*(fv(ij,i)-vav(ij))
-    END DO
-  END DO
-
-  DO k = 1, nl + 1
-    DO i = 1, ncum
-      IF ((q(i,k)+delt*fq(i,k))<0.0) iflag(i) = 10
-    END DO
-  END DO
-
-
-  DO i = 1, ncum
-    IF (iflag(i)>2) THEN
-      precip(i) = 0.0
-      cbmf(i) = 0.0
-    END IF
-  END DO
-  DO k = 1, nl
-    DO i = 1, ncum
-      IF (iflag(i)>2) THEN
-        ft(i, k) = 0.0
-        fq(i, k) = 0.0
-        fu(i, k) = 0.0
-        fv(i, k) = 0.0
-      END IF
-    END DO
-  END DO
-  DO i = 1, ncum
-    precip1(idcum(i)) = precip(i)
-    cbmf1(idcum(i)) = cbmf(i)
-    iflag1(idcum(i)) = iflag(i)
-  END DO
-  DO k = 1, nl
-    DO i = 1, ncum
-      ft1(idcum(i), k) = ft(i, k)
-      fq1(idcum(i), k) = fq(i, k)
-      fu1(idcum(i), k) = fu(i, k)
-      fv1(idcum(i), k) = fv(i, k)
-    END DO
-  END DO
-
-  DO k = 1, nd
-    DO i = 1, len
-      ma(i, k) = 0.
-    END DO
-  END DO
-  DO k = nl, 1, -1
-    DO i = 1, ncum
-      ma(i, k) = ma(i, k+1) + m(i, k)
-    END DO
-  END DO
-
-  RETURN
-END SUBROUTINE convect2
-
Index: /LMDZ6/trunk/libf/phylmd/convect2.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/convect2.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/convect2.f90	(revision 5268)
@@ -0,0 +1,1373 @@
+
+! $Id$
+
+SUBROUTINE convect2(ncum, idcum, len, nd, ndp1, nl, minorig, nk1, icb1, t1, &
+    q1, qs1, u1, v1, gz1, tv1, tp1, tvp1, clw1, h1, lv1, cpn1, p1, ph1, ft1, &
+    fq1, fu1, fv1, tnk1, qnk1, gznk1, plcl1, precip1, cbmf1, iflag1, delt, &
+    cpd, cpv, cl, rv, rd, lv0, g, sigs, sigd, elcrit, tlcrit, omtsnow, dtmax, &
+    damp, alpha, entp, coeffs, coeffr, omtrain, cu, ma)
+  ! .............................START PROLOGUE............................
+
+  ! SCCS IDENTIFICATION:  @(#)convect2.f	1.2 05/18/00
+  ! 22:06:22 /h/cm/library/nogaps4/src/sub/fcst/convect2.f_v
+
+  ! CONFIGURATION IDENTIFICATION:  None
+
+  ! MODULE NAME:  convect2
+
+  ! DESCRIPTION:
+
+  ! convect1     The Emanuel Cumulus Convection Scheme - compute tendencies
+
+  ! CONTRACT NUMBER AND TITLE:  None
+
+  ! REFERENCES: Programmers  K. Emanuel (MIT), Timothy F. Hogan, M. Peng
+  ! (NRL)
+
+  ! CLASSIFICATION:  Unclassified
+
+  ! RESTRICTIONS: None
+
+  ! COMPILER DEPENDENCIES: FORTRAN 77, FORTRAN 90
+
+  ! COMPILE OPTIONS: Fortran 77: -Zu -Wf"-ei -o aggress"
+  ! Fortran 90: -O vector3,scalar3,task1,aggress,overindex  -ei -r 2
+
+  ! LIBRARIES OF RESIDENCE: /a/ops/lib/libfcst159.a
+
+  ! USAGE: call convect2(ncum,idcum,len,nd,nl,minorig,
+  ! &                 nk1,icb1,
+  ! &                 t1,q1,qs1,u1,v1,gz1,tv1,tp1,tvp1,clw1,h1,
+  ! &                 lv1,cpn1,p1,ph1,ft1,fq1,fu1,fv1,
+  ! &                 tnk1,qnk1,gznk1,plcl1,
+  ! &                 precip1,cbmf1,iflag1,
+  ! &                 delt,cpd,cpv,cl,rv,rd,lv0,g,
+  ! &                 sigs,sigd,elcrit,tlcrit,omtsnow,dtmax,damp,
+  ! &                 alpha,entp,coeffs,coeffr,omtrain,cu)
+
+  ! PARAMETERS:
+  ! Name            Type         Usage            Description
+  ! ----------      ----------     -------  ----------------------------
+
+  ! ncum          Integer        Input        number of cumulus points
+  ! idcum         Integer        Input        index of cumulus point
+  ! len           Integer        Input        first dimension
+  ! nd            Integer        Input        total vertical dimension
+  ! ndp1          Integer        Input        nd + 1
+  ! nl            Integer        Input        vertical dimension for
+  ! convection
+  ! minorig       Integer        Input        First level where convection is
+  ! allow to begin
+  ! nk1           Integer        Input        First level of convection
+  ! ncb1          Integer        Input        Level of free convection
+  ! t1            Real           Input        temperature
+  ! q1            Real           Input        specific hum
+  ! qs1           Real           Input        sat specific hum
+  ! u1            Real           Input        u-wind
+  ! v1            Real           Input        v-wind
+  ! gz1           Real           Inout        geop
+  ! tv1           Real           Input        virtual temp
+  ! tp1           Real           Input
+  ! clw1          Real           Inout        cloud liquid water
+  ! h1            Real           Inout
+  ! lv1           Real           Inout
+  ! cpn1          Real           Inout
+  ! p1            Real           Input        full level pressure
+  ! ph1           Real           Input        half level pressure
+  ! ft1           Real           Output       temp tend
+  ! fq1           Real           Output       spec hum tend
+  ! fu1           Real           Output       u-wind tend
+  ! fv1           Real           Output       v-wind tend
+  ! precip1       Real           Output       prec
+  ! cbmf1         Real           In/Out       cumulus mass flux
+  ! iflag1        Integer        Output       iflag on latitude strip
+  ! delt          Real           Input        time step
+  ! cpd           Integer        Input        See description below
+  ! cpv           Integer        Input        See description below
+  ! cl            Integer        Input        See description below
+  ! rv            Integer        Input        See description below
+  ! rd            Integer        Input        See description below
+  ! lv0           Integer        Input        See description below
+  ! g             Integer        Input        See description below
+  ! sigs          Integer        Input        See description below
+  ! sigd          Integer        Input        See description below
+  ! elcrit        Integer        Input        See description below
+  ! tlcrit        Integer        Input        See description below
+  ! omtsnow       Integer        Input        See description below
+  ! dtmax         Integer        Input        See description below
+  ! damp          Integer        Input        See description below
+  ! alpha         Integer        Input        See description below
+  ! ent           Integer        Input        See description below
+  ! coeffs        Integer        Input        See description below
+  ! coeffr        Integer        Input        See description below
+  ! omtrain       Integer        Input        See description below
+  ! cu            Integer        Input        See description below
+
+  ! COMMON BLOCKS:
+  ! Block      Name     Type    Usage              Notes
+  ! --------  --------   ----    ------   ------------------------
+
+  ! FILES: None
+
+  ! DATA BASES: None
+
+  ! NON-FILE INPUT/OUTPUT: None
+
+  ! ERROR CONDITIONS: None
+
+  ! ADDITIONAL COMMENTS: None
+
+  ! .................MAINTENANCE SECTION................................
+
+  ! MODULES CALLED:
+  ! Name           Description
+  ! zilch        Zero out an array
+  ! -------     ----------------------
+  ! LOCAL VARIABLES AND
+  ! STRUCTURES:
+  ! Name     Type    Description
+  ! -------  ------  -----------
+  ! See Comments Below
+
+  ! i        Integer loop index
+  ! k        Integer loop index
+
+  ! METHOD:
+
+  ! See Emanuel, K. and M. Zivkovic-Rothman, 2000: Development and evaluation
+  ! of a
+  ! convective scheme for use in climate models.
+
+  ! FILES: None
+
+  ! INCLUDE FILES: None
+
+  ! MAKEFILE: /a/ops/met/nogaps/src/sub/fcst/fcst159lib.mak
+
+  ! ..............................END PROLOGUE.............................
+
+
+  USE dimphy
+  IMPLICIT NONE
+
+  INTEGER kmax2, imax2, kmin2, imin2
+  REAL ftmax2, ftmin2
+  INTEGER kmax, imax, kmin, imin
+  REAL ftmax, ftmin
+
+  INTEGER ncum
+  INTEGER len
+  INTEGER idcum(len)
+  INTEGER nd
+  INTEGER ndp1
+  INTEGER nl
+  INTEGER minorig
+  INTEGER nk1(len)
+  INTEGER icb1(len)
+  REAL t1(len, nd)
+  REAL q1(len, nd)
+  REAL qs1(len, nd)
+  REAL u1(len, nd)
+  REAL v1(len, nd)
+  REAL gz1(len, nd)
+  REAL tv1(len, nd)
+  REAL tp1(len, nd)
+  REAL tvp1(len, nd)
+  REAL clw1(len, nd)
+  REAL h1(len, nd)
+  REAL lv1(len, nd)
+  REAL cpn1(len, nd)
+  REAL p1(len, nd)
+  REAL ph1(len, ndp1)
+  REAL ft1(len, nd)
+  REAL fq1(len, nd)
+  REAL fu1(len, nd)
+  REAL fv1(len, nd)
+  REAL tnk1(len)
+  REAL qnk1(len)
+  REAL gznk1(len)
+  REAL precip1(len)
+  REAL cbmf1(len)
+  REAL plcl1(len)
+  INTEGER iflag1(len)
+  REAL delt
+  REAL cpd
+  REAL cpv
+  REAL cl
+  REAL rv
+  REAL rd
+  REAL lv0
+  REAL g
+  REAL sigs ! SIGS IS THE FRACTION OF PRECIPITATION FALLING OUTSIDE
+  REAL sigd ! SIGD IS THE FRACTIONAL AREA COVERED BY UNSATURATED DNDRAFT
+  REAL elcrit ! ELCRIT IS THE AUTOCONVERSION THERSHOLD WATER CONTENT (gm/gm)
+  REAL tlcrit ! TLCRIT IS CRITICAL TEMPERATURE BELOW WHICH THE AUTO-
+  ! CONVERSION THRESHOLD IS ASSUMED TO BE ZERO
+  REAL omtsnow ! OMTSNOW IS THE ASSUMED FALL SPEED (P/s) OF SNOW
+  REAL dtmax ! DTMAX IS THE MAXIMUM NEGATIVE TEMPERATURE PERTURBATION
+  ! A LIFTED PARCEL IS ALLOWED TO HAVE BELOW ITS LFC.
+  REAL damp
+  REAL alpha
+  REAL entp ! ENTP IS THE COEFFICIENT OF MIXING IN THE ENTRAINMENT FORMULATION
+  REAL coeffs ! COEFFS IS A COEFFICIENT GOVERNING THE RATE OF EVAPORATION OF
+  ! SNOW
+  REAL coeffr ! COEFFR IS A COEFFICIENT GOVERNING THE RATE OF EVAPORATION OF
+  ! RAIN
+  REAL omtrain ! OMTRAIN IS THE ASSUMED FALL SPEED (P/s) OF RAIN
+  REAL cu ! CU IS THE COEFFICIENT GOVERNING CONVECTIVE MOMENTUM TRANSPORT
+
+  REAL ma(len, nd)
+
+
+  ! *** ELCRIT IS THE AUTOCONVERSION THERSHOLD WATER CONTENT (gm/gm) ***
+  ! ***  TLCRIT IS CRITICAL TEMPERATURE BELOW WHICH THE AUTO-        ***
+  ! ***       CONVERSION THRESHOLD IS ASSUMED TO BE ZERO             ***
+  ! ***     (THE AUTOCONVERSION THRESHOLD VARIES LINEARLY            ***
+  ! ***               BETWEEN 0 C AND TLCRIT)                        ***
+  ! ***   ENTP IS THE COEFFICIENT OF MIXING IN THE ENTRAINMENT       ***
+  ! ***                       FORMULATION                            ***
+  ! ***  SIGD IS THE FRACTIONAL AREA COVERED BY UNSATURATED DNDRAFT  ***
+  ! ***  SIGS IS THE FRACTION OF PRECIPITATION FALLING OUTSIDE       ***
+  ! ***                        OF CLOUD                              ***
+  ! ***        OMTRAIN IS THE ASSUMED FALL SPEED (P/s) OF RAIN       ***
+  ! ***     OMTSNOW IS THE ASSUMED FALL SPEED (P/s) OF SNOW          ***
+  ! ***  COEFFR IS A COEFFICIENT GOVERNING THE RATE OF EVAPORATION   ***
+  ! ***                          OF RAIN                             ***
+  ! ***  COEFFS IS A COEFFICIENT GOVERNING THE RATE OF EVAPORATION   ***
+  ! ***                          OF SNOW                             ***
+  ! ***     CU IS THE COEFFICIENT GOVERNING CONVECTIVE MOMENTUM      ***
+  ! ***                         TRANSPORT                            ***
+  ! ***    DTMAX IS THE MAXIMUM NEGATIVE TEMPERATURE PERTURBATION    ***
+  ! ***        A LIFTED PARCEL IS ALLOWED TO HAVE BELOW ITS LFC      ***
+  ! ***    ALPHA AND DAMP ARE PARAMETERS THAT CONTROL THE RATE OF    ***
+  ! ***                 APPROACH TO QUASI-EQUILIBRIUM                ***
+  ! ***   (THEIR STANDARD VALUES ARE  0.20 AND 0.1, RESPECTIVELY)    ***
+  ! ***                   (DAMP MUST BE LESS THAN 1)                 ***
+
+  ! Local arrays.
+
+  REAL work(ncum)
+  REAL t(ncum, klev)
+  REAL q(ncum, klev)
+  REAL qs(ncum, klev)
+  REAL u(ncum, klev)
+  REAL v(ncum, klev)
+  REAL gz(ncum, klev)
+  REAL h(ncum, klev)
+  REAL lv(ncum, klev)
+  REAL cpn(ncum, klev)
+  REAL p(ncum, klev)
+  REAL ph(ncum, klev)
+  REAL ft(ncum, klev)
+  REAL fq(ncum, klev)
+  REAL fu(ncum, klev)
+  REAL fv(ncum, klev)
+  REAL precip(ncum)
+  REAL cbmf(ncum)
+  REAL plcl(ncum)
+  REAL tnk(ncum)
+  REAL qnk(ncum)
+  REAL gznk(ncum)
+  REAL tv(ncum, klev)
+  REAL tp(ncum, klev)
+  REAL tvp(ncum, klev)
+  REAL clw(ncum, klev)
+  ! real det(ncum,klev)
+  REAL dph(ncum, klev)
+  ! real wd(ncum)
+  ! real tprime(ncum)
+  ! real qprime(ncum)
+  REAL ah0(ncum)
+  REAL ep(ncum, klev)
+  REAL sigp(ncum, klev)
+  INTEGER nent(ncum, klev)
+  REAL water(ncum, klev)
+  REAL evap(ncum, klev)
+  REAL mp(ncum, klev)
+  REAL m(ncum, klev)
+  REAL qti
+  REAL wt(ncum, klev)
+  REAL hp(ncum, klev)
+  REAL lvcp(ncum, klev)
+  REAL elij(ncum, klev, klev)
+  REAL ment(ncum, klev, klev)
+  REAL sij(ncum, klev, klev)
+  REAL qent(ncum, klev, klev)
+  REAL uent(ncum, klev, klev)
+  REAL vent(ncum, klev, klev)
+  REAL qp(ncum, klev)
+  REAL up(ncum, klev)
+  REAL vp(ncum, klev)
+  REAL cape(ncum)
+  REAL capem(ncum)
+  REAL frac(ncum)
+  REAL dtpbl(ncum)
+  REAL tvpplcl(ncum)
+  REAL tvaplcl(ncum)
+  REAL dtmin(ncum)
+  REAL w3d(ncum, klev)
+  REAL am(ncum)
+  REAL ents(ncum)
+  REAL uav(ncum)
+  REAL vav(ncum)
+
+  INTEGER iflag(ncum)
+  INTEGER nk(ncum)
+  INTEGER icb(ncum)
+  INTEGER inb(ncum)
+  INTEGER inb1(ncum)
+  INTEGER jtt(ncum)
+
+  INTEGER nn, i, k, n, icbmax, nlp, j
+  INTEGER ij
+  INTEGER nn2, nn3
+  REAL clmcpv
+  REAL clmcpd
+  REAL cpdmcp
+  REAL cpvmcpd
+  REAL eps
+  REAL epsi
+  REAL epsim1
+  REAL tg, qg, s, alv, tc, ahg, denom, es, rg, ginv, rowl
+  REAL delti
+  REAL tca, elacrit
+  REAL by, defrac
+  ! real byp
+  REAL byp(ncum)
+  LOGICAL lcape(ncum)
+  REAL dbo
+  REAL bf2, anum, dei, altem, cwat, stemp
+  REAL alt, qp1, smid, sjmax, sjmin
+  REAL delp, delm
+  REAL awat, coeff, afac, revap, dhdp, fac, qstm, rat
+  REAL qsm, sigt, b6, c6
+  REAL dpinv, cpinv
+  REAL fqold, ftold, fuold, fvold
+  REAL wdtrain(ncum), xxx
+  REAL bsum(ncum, klev)
+  REAL asij(ncum)
+  REAL smin(ncum)
+  REAL scrit(ncum)
+  ! real amp1,ad
+  REAL amp1(ncum), ad(ncum)
+  LOGICAL lwork(ncum)
+  INTEGER num1, num2
+
+  ! print*,'cpd en entree de convect2 ',cpd
+  nlp = nl + 1
+
+  rowl = 1000.0
+  ginv = 1.0/g
+  delti = 1.0/delt
+
+  ! Define some thermodynamic variables.
+
+  clmcpv = cl - cpv
+  clmcpd = cl - cpd
+  cpdmcp = cpd - cpv
+  cpvmcpd = cpv - cpd
+  eps = rd/rv
+  epsi = 1.0/eps
+  epsim1 = epsi - 1.0
+
+  ! Compress the fields.
+
+  DO k = 1, nl + 1
+    nn = 0
+    DO i = 1, len
+      IF (iflag1(i)==0) THEN
+        nn = nn + 1
+        t(nn, k) = t1(i, k)
+        q(nn, k) = q1(i, k)
+        qs(nn, k) = qs1(i, k)
+        u(nn, k) = u1(i, k)
+        v(nn, k) = v1(i, k)
+        gz(nn, k) = gz1(i, k)
+        h(nn, k) = h1(i, k)
+        lv(nn, k) = lv1(i, k)
+        cpn(nn, k) = cpn1(i, k)
+        p(nn, k) = p1(i, k)
+        ph(nn, k) = ph1(i, k)
+        tv(nn, k) = tv1(i, k)
+        tp(nn, k) = tp1(i, k)
+        tvp(nn, k) = tvp1(i, k)
+        clw(nn, k) = clw1(i, k)
+      END IF
+    END DO
+    ! print*,'100 ncum,nn',ncum,nn
+  END DO
+  nn = 0
+  DO i = 1, len
+    IF (iflag1(i)==0) THEN
+      nn = nn + 1
+      cbmf(nn) = cbmf1(i)
+      plcl(nn) = plcl1(i)
+      tnk(nn) = tnk1(i)
+      qnk(nn) = qnk1(i)
+      gznk(nn) = gznk1(i)
+      nk(nn) = nk1(i)
+      icb(nn) = icb1(i)
+      iflag(nn) = iflag1(i)
+    END IF
+  END DO
+  ! print*,'150 ncum,nn',ncum,nn
+
+  ! Initialize the tendencies, det, wd, tprime, qprime.
+
+  DO k = 1, nl
+    DO i = 1, ncum
+      ! det(i,k)=0.0
+      ft(i, k) = 0.0
+      fu(i, k) = 0.0
+      fv(i, k) = 0.0
+      fq(i, k) = 0.0
+      dph(i, k) = ph(i, k) - ph(i, k+1)
+      ep(i, k) = 0.0
+      sigp(i, k) = sigs
+    END DO
+  END DO
+  DO i = 1, ncum
+    ! wd(i)=0.0
+    ! tprime(i)=0.0
+    ! qprime(i)=0.0
+    precip(i) = 0.0
+    ft(i, nl+1) = 0.0
+    fu(i, nl+1) = 0.0
+    fv(i, nl+1) = 0.0
+    fq(i, nl+1) = 0.0
+  END DO
+
+  ! Compute icbmax.
+
+  icbmax = 2
+  DO i = 1, ncum
+    icbmax = max(icbmax, icb(i))
+  END DO
+
+
+  ! =====================================================================
+  ! --- FIND THE REST OF THE LIFTED PARCEL TEMPERATURES
+  ! =====================================================================
+
+  ! ---       The procedure is to solve the equation.
+  ! cp*tp+L*qp+phi=cp*tnk+L*qnk+gznk.
+
+  ! ***  Calculate certain parcel quantities, including static energy   ***
+
+
+  DO i = 1, ncum
+    ah0(i) = (cpd*(1.-qnk(i))+cl*qnk(i))*tnk(i) + qnk(i)*(lv0-clmcpv*(tnk(i)- &
+      273.15)) + gznk(i)
+  END DO
+
+
+  ! ***  Find lifted parcel quantities above cloud base    ***
+
+
+  DO k = minorig + 1, nl
+    DO i = 1, ncum
+      IF (k>=(icb(i)+1)) THEN
+        tg = t(i, k)
+        qg = qs(i, k)
+        alv = lv0 - clmcpv*(t(i,k)-273.15)
+
+        ! First iteration.
+
+        s = cpd + alv*alv*qg/(rv*t(i,k)*t(i,k))
+        s = 1./s
+        ahg = cpd*tg + (cl-cpd)*qnk(i)*t(i, k) + alv*qg + gz(i, k)
+        tg = tg + s*(ah0(i)-ahg)
+        tg = max(tg, 35.0)
+        tc = tg - 273.15
+        denom = 243.5 + tc
+        IF (tc>=0.0) THEN
+          es = 6.112*exp(17.67*tc/denom)
+        ELSE
+          es = exp(23.33086-6111.72784/tg+0.15215*log(tg))
+        END IF
+        qg = eps*es/(p(i,k)-es*(1.-eps))
+
+        ! Second iteration.
+
+        s = cpd + alv*alv*qg/(rv*t(i,k)*t(i,k))
+        s = 1./s
+        ahg = cpd*tg + (cl-cpd)*qnk(i)*t(i, k) + alv*qg + gz(i, k)
+        tg = tg + s*(ah0(i)-ahg)
+        tg = max(tg, 35.0)
+        tc = tg - 273.15
+        denom = 243.5 + tc
+        IF (tc>=0.0) THEN
+          es = 6.112*exp(17.67*tc/denom)
+        ELSE
+          es = exp(23.33086-6111.72784/tg+0.15215*log(tg))
+        END IF
+        qg = eps*es/(p(i,k)-es*(1.-eps))
+
+        alv = lv0 - clmcpv*(t(i,k)-273.15)
+        ! print*,'cpd dans convect2 ',cpd
+        ! print*,'tp(i,k),ah0(i),cl,cpd,qnk(i),t(i,k),gz(i,k),alv,qg,cpd'
+        ! print*,tp(i,k),ah0(i),cl,cpd,qnk(i),t(i,k),gz(i,k),alv,qg,cpd
+        tp(i, k) = (ah0(i)-(cl-cpd)*qnk(i)*t(i,k)-gz(i,k)-alv*qg)/cpd
+        ! if (.not.cpd.gt.1000.) then
+        ! print*,'CPD=',cpd
+        ! stop
+        ! endif
+        clw(i, k) = qnk(i) - qg
+        clw(i, k) = max(0.0, clw(i,k))
+        rg = qg/(1.-qnk(i))
+        tvp(i, k) = tp(i, k)*(1.+rg*epsi)
+      END IF
+    END DO
+  END DO
+
+  ! =====================================================================
+  ! --- SET THE PRECIPITATION EFFICIENCIES AND THE FRACTION OF
+  ! --- PRECIPITATION FALLING OUTSIDE OF CLOUD
+  ! --- THESE MAY BE FUNCTIONS OF TP(I), P(I) AND CLW(I)
+  ! =====================================================================
+
+  DO k = minorig + 1, nl
+    DO i = 1, ncum
+      IF (k>=(nk(i)+1)) THEN
+        tca = tp(i, k) - 273.15
+        IF (tca>=0.0) THEN
+          elacrit = elcrit
+        ELSE
+          elacrit = elcrit*(1.0-tca/tlcrit)
+        END IF
+        elacrit = max(elacrit, 0.0)
+        ep(i, k) = 1.0 - elacrit/max(clw(i,k), 1.0E-8)
+        ep(i, k) = max(ep(i,k), 0.0)
+        ep(i, k) = min(ep(i,k), 1.0)
+        sigp(i, k) = sigs
+      END IF
+    END DO
+  END DO
+
+  ! =====================================================================
+  ! --- CALCULATE VIRTUAL TEMPERATURE AND LIFTED PARCEL
+  ! --- VIRTUAL TEMPERATURE
+  ! =====================================================================
+
+  DO k = minorig + 1, nl
+    DO i = 1, ncum
+      IF (k>=(icb(i)+1)) THEN
+        tvp(i, k) = tvp(i, k)*(1.0-qnk(i)+ep(i,k)*clw(i,k))
+        ! print*,'i,k,tvp(i,k),qnk(i),ep(i,k),clw(i,k)'
+        ! print*, i,k,tvp(i,k),qnk(i),ep(i,k),clw(i,k)
+      END IF
+    END DO
+  END DO
+  DO i = 1, ncum
+    tvp(i, nlp) = tvp(i, nl) - (gz(i,nlp)-gz(i,nl))/cpd
+  END DO
+
+
+  ! =====================================================================
+  ! --- NOW INITIALIZE VARIOUS ARRAYS USED IN THE COMPUTATIONS
+  ! =====================================================================
+
+  DO i = 1, ncum*nlp
+    nent(i, 1) = 0
+    water(i, 1) = 0.0
+    evap(i, 1) = 0.0
+    mp(i, 1) = 0.0
+    m(i, 1) = 0.0
+    wt(i, 1) = omtsnow
+    hp(i, 1) = h(i, 1)
+    ! if(.not.cpn(i,1).gt.900.) then
+    ! print*,'i,lv(i,1),cpn(i,1)'
+    ! print*, i,lv(i,1),cpn(i,1)
+    ! k=(i-1)/ncum+1
+    ! print*,'i,k',mod(i,ncum),k,'  cpn',cpn(mod(i,ncum),k)
+    ! stop
+    ! endif
+    lvcp(i, 1) = lv(i, 1)/cpn(i, 1)
+  END DO
+
+  DO i = 1, ncum*nlp*nlp
+    elij(i, 1, 1) = 0.0
+    ment(i, 1, 1) = 0.0
+    sij(i, 1, 1) = 0.0
+  END DO
+
+  DO k = 1, nlp
+    DO j = 1, nlp
+      DO i = 1, ncum
+        qent(i, k, j) = q(i, j)
+        uent(i, k, j) = u(i, j)
+        vent(i, k, j) = v(i, j)
+      END DO
+    END DO
+  END DO
+
+  DO i = 1, ncum
+    qp(i, 1) = q(i, 1)
+    up(i, 1) = u(i, 1)
+    vp(i, 1) = v(i, 1)
+  END DO
+  DO k = 2, nlp
+    DO i = 1, ncum
+      qp(i, k) = q(i, k-1)
+      up(i, k) = u(i, k-1)
+      vp(i, k) = v(i, k-1)
+    END DO
+  END DO
+
+  ! =====================================================================
+  ! --- FIND THE FIRST MODEL LEVEL (INB1) ABOVE THE PARCEL'S
+  ! --- HIGHEST LEVEL OF NEUTRAL BUOYANCY
+  ! --- AND THE HIGHEST LEVEL OF POSITIVE CAPE (INB)
+  ! =====================================================================
+
+  DO i = 1, ncum
+    cape(i) = 0.0
+    capem(i) = 0.0
+    inb(i) = icb(i) + 1
+    inb1(i) = inb(i)
+  END DO
+
+  ! Originial Code
+
+  ! do 530 k=minorig+1,nl-1
+  ! do 520 i=1,ncum
+  ! if(k.ge.(icb(i)+1))then
+  ! by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k)
+  ! byp=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1)
+  ! cape(i)=cape(i)+by
+  ! if(by.ge.0.0)inb1(i)=k+1
+  ! if(cape(i).gt.0.0)then
+  ! inb(i)=k+1
+  ! capem(i)=cape(i)
+  ! endif
+  ! endif
+  ! 520    continue
+  ! 530  continue
+  ! do 540 i=1,ncum
+  ! byp=(tvp(i,nl)-tv(i,nl))*dph(i,nl)/p(i,nl)
+  ! cape(i)=capem(i)+byp
+  ! defrac=capem(i)-cape(i)
+  ! defrac=max(defrac,0.001)
+  ! frac(i)=-cape(i)/defrac
+  ! frac(i)=min(frac(i),1.0)
+  ! frac(i)=max(frac(i),0.0)
+  ! 540   continue
+
+  ! K Emanuel fix
+
+  ! call zilch(byp,ncum)
+  ! do 530 k=minorig+1,nl-1
+  ! do 520 i=1,ncum
+  ! if(k.ge.(icb(i)+1))then
+  ! by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k)
+  ! cape(i)=cape(i)+by
+  ! if(by.ge.0.0)inb1(i)=k+1
+  ! if(cape(i).gt.0.0)then
+  ! inb(i)=k+1
+  ! capem(i)=cape(i)
+  ! byp(i)=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1)
+  ! endif
+  ! endif
+  ! 520    continue
+  ! 530  continue
+  ! do 540 i=1,ncum
+  ! inb(i)=max(inb(i),inb1(i))
+  ! cape(i)=capem(i)+byp(i)
+  ! defrac=capem(i)-cape(i)
+  ! defrac=max(defrac,0.001)
+  ! frac(i)=-cape(i)/defrac
+  ! frac(i)=min(frac(i),1.0)
+  ! frac(i)=max(frac(i),0.0)
+  ! 540   continue
+
+  ! J Teixeira fix
+
+  CALL zilch(byp, ncum)
+  DO i = 1, ncum
+    lcape(i) = .TRUE.
+  END DO
+  DO k = minorig + 1, nl - 1
+    DO i = 1, ncum
+      IF (cape(i)<0.0) lcape(i) = .FALSE.
+      IF ((k>=(icb(i)+1)) .AND. lcape(i)) THEN
+        by = (tvp(i,k)-tv(i,k))*dph(i, k)/p(i, k)
+        byp(i) = (tvp(i,k+1)-tv(i,k+1))*dph(i, k+1)/p(i, k+1)
+        cape(i) = cape(i) + by
+        IF (by>=0.0) inb1(i) = k + 1
+        IF (cape(i)>0.0) THEN
+          inb(i) = k + 1
+          capem(i) = cape(i)
+        END IF
+      END IF
+    END DO
+  END DO
+  DO i = 1, ncum
+    cape(i) = capem(i) + byp(i)
+    defrac = capem(i) - cape(i)
+    defrac = max(defrac, 0.001)
+    frac(i) = -cape(i)/defrac
+    frac(i) = min(frac(i), 1.0)
+    frac(i) = max(frac(i), 0.0)
+  END DO
+
+  ! =====================================================================
+  ! ---   CALCULATE LIQUID WATER STATIC ENERGY OF LIFTED PARCEL
+  ! =====================================================================
+
+  DO k = minorig + 1, nl
+    DO i = 1, ncum
+      IF ((k>=icb(i)) .AND. (k<=inb(i))) THEN
+        hp(i, k) = h(i, nk(i)) + (lv(i,k)+(cpd-cpv)*t(i,k))*ep(i, k)*clw(i, k &
+          )
+      END IF
+    END DO
+  END DO
+
+  ! =====================================================================
+  ! ---  CALCULATE CLOUD BASE MASS FLUX AND RATES OF MIXING, M(I),
+  ! --- AT EACH MODEL LEVEL
+  ! =====================================================================
+
+  ! tvpplcl = parcel temperature lifted adiabatically from level
+  ! icb-1 to the LCL.
+  ! tvaplcl = virtual temperature at the LCL.
+
+  DO i = 1, ncum
+    dtpbl(i) = 0.0
+    tvpplcl(i) = tvp(i, icb(i)-1) - rd*tvp(i, icb(i)-1)*(p(i,icb(i)-1)-plcl(i &
+      ))/(cpn(i,icb(i)-1)*p(i,icb(i)-1))
+    tvaplcl(i) = tv(i, icb(i)) + (tvp(i,icb(i))-tvp(i,icb(i)+1))*(plcl(i)-p(i &
+      ,icb(i)))/(p(i,icb(i))-p(i,icb(i)+1))
+  END DO
+
+  ! -------------------------------------------------------------------
+  ! --- Interpolate difference between lifted parcel and
+  ! --- environmental temperatures to lifted condensation level
+  ! -------------------------------------------------------------------
+
+  ! dtpbl = average of tvp-tv in the PBL (k=nk to icb-1).
+
+  DO k = minorig, icbmax
+    DO i = 1, ncum
+      IF ((k>=nk(i)) .AND. (k<=(icb(i)-1))) THEN
+        dtpbl(i) = dtpbl(i) + (tvp(i,k)-tv(i,k))*dph(i, k)
+      END IF
+    END DO
+  END DO
+  DO i = 1, ncum
+    dtpbl(i) = dtpbl(i)/(ph(i,nk(i))-ph(i,icb(i)))
+    dtmin(i) = tvpplcl(i) - tvaplcl(i) + dtmax + dtpbl(i)
+  END DO
+
+  ! -------------------------------------------------------------------
+  ! --- Adjust cloud base mass flux
+  ! -------------------------------------------------------------------
+
+  DO i = 1, ncum
+    work(i) = cbmf(i)
+    cbmf(i) = max(0.0, (1.0-damp)*cbmf(i)+0.1*alpha*dtmin(i))
+    IF ((work(i)==0.0) .AND. (cbmf(i)==0.0)) THEN
+      iflag(i) = 3
+    END IF
+  END DO
+
+  ! -------------------------------------------------------------------
+  ! --- Calculate rates of mixing,  m(i)
+  ! -------------------------------------------------------------------
+
+  CALL zilch(work, ncum)
+
+  DO j = minorig + 1, nl
+    DO i = 1, ncum
+      IF ((j>=(icb(i)+1)) .AND. (j<=inb(i))) THEN
+        k = min(j, inb1(i))
+        dbo = abs(tv(i,k+1)-tvp(i,k+1)-tv(i,k-1)+tvp(i,k-1)) + &
+          entp*0.04*(ph(i,k)-ph(i,k+1))
+        work(i) = work(i) + dbo
+        m(i, j) = cbmf(i)*dbo
+      END IF
+    END DO
+  END DO
+  DO k = minorig + 1, nl
+    DO i = 1, ncum
+      IF ((k>=(icb(i)+1)) .AND. (k<=inb(i))) THEN
+        m(i, k) = m(i, k)/work(i)
+      END IF
+    END DO
+  END DO
+
+
+  ! =====================================================================
+  ! --- CALCULATE ENTRAINED AIR MASS FLUX (ment), TOTAL WATER MIXING
+  ! --- RATIO (QENT), TOTAL CONDENSED WATER (elij), AND MIXING
+  ! --- FRACTION (sij)
+  ! =====================================================================
+
+
+  DO i = minorig + 1, nl
+    DO j = minorig + 1, nl
+      DO ij = 1, ncum
+        IF ((i>=(icb(ij)+1)) .AND. (j>=icb(ij)) .AND. (i<=inb(ij)) .AND. (j<= &
+            inb(ij))) THEN
+          qti = qnk(ij) - ep(ij, i)*clw(ij, i)
+          bf2 = 1. + lv(ij, j)*lv(ij, j)*qs(ij, j)/(rv*t(ij,j)*t(ij,j)*cpd)
+          anum = h(ij, j) - hp(ij, i) + (cpv-cpd)*t(ij, j)*(qti-q(ij,j))
+          denom = h(ij, i) - hp(ij, i) + (cpd-cpv)*(q(ij,i)-qti)*t(ij, j)
+          dei = denom
+          IF (abs(dei)<0.01) dei = 0.01
+          sij(ij, i, j) = anum/dei
+          sij(ij, i, i) = 1.0
+          altem = sij(ij, i, j)*q(ij, i) + (1.-sij(ij,i,j))*qti - qs(ij, j)
+          altem = altem/bf2
+          cwat = clw(ij, j)*(1.-ep(ij,j))
+          stemp = sij(ij, i, j)
+          IF ((stemp<0.0 .OR. stemp>1.0 .OR. altem>cwat) .AND. j>i) THEN
+            anum = anum - lv(ij, j)*(qti-qs(ij,j)-cwat*bf2)
+            denom = denom + lv(ij, j)*(q(ij,i)-qti)
+            IF (abs(denom)<0.01) denom = 0.01
+            sij(ij, i, j) = anum/denom
+            altem = sij(ij, i, j)*q(ij, i) + (1.-sij(ij,i,j))*qti - qs(ij, j)
+            altem = altem - (bf2-1.)*cwat
+          END IF
+          IF (sij(ij,i,j)>0.0 .AND. sij(ij,i,j)<0.9) THEN
+            qent(ij, i, j) = sij(ij, i, j)*q(ij, i) + (1.-sij(ij,i,j))*qti
+            uent(ij, i, j) = sij(ij, i, j)*u(ij, i) + &
+              (1.-sij(ij,i,j))*u(ij, nk(ij))
+            vent(ij, i, j) = sij(ij, i, j)*v(ij, i) + &
+              (1.-sij(ij,i,j))*v(ij, nk(ij))
+            elij(ij, i, j) = altem
+            elij(ij, i, j) = max(0.0, elij(ij,i,j))
+            ment(ij, i, j) = m(ij, i)/(1.-sij(ij,i,j))
+            nent(ij, i) = nent(ij, i) + 1
+          END IF
+          sij(ij, i, j) = max(0.0, sij(ij,i,j))
+          sij(ij, i, j) = min(1.0, sij(ij,i,j))
+        END IF
+      END DO
+    END DO
+
+    ! ***   If no air can entrain at level i assume that updraft detrains
+    ! ***
+    ! ***   at that level and calculate detrained air flux and properties
+    ! ***
+
+    DO ij = 1, ncum
+      IF ((i>=(icb(ij)+1)) .AND. (i<=inb(ij)) .AND. (nent(ij,i)==0)) THEN
+        ment(ij, i, i) = m(ij, i)
+        qent(ij, i, i) = q(ij, nk(ij)) - ep(ij, i)*clw(ij, i)
+        uent(ij, i, i) = u(ij, nk(ij))
+        vent(ij, i, i) = v(ij, nk(ij))
+        elij(ij, i, i) = clw(ij, i)
+        sij(ij, i, i) = 1.0
+      END IF
+    END DO
+  END DO
+
+  DO i = 1, ncum
+    sij(i, inb(i), inb(i)) = 1.0
+  END DO
+
+  ! =====================================================================
+  ! ---  NORMALIZE ENTRAINED AIR MASS FLUXES
+  ! ---  TO REPRESENT EQUAL PROBABILITIES OF MIXING
+  ! =====================================================================
+
+
+  CALL zilch(bsum, ncum*nlp)
+  DO ij = 1, ncum
+    lwork(ij) = .FALSE.
+  END DO
+  DO i = minorig + 1, nl
+
+    num1 = 0
+    DO ij = 1, ncum
+      IF ((i>=icb(ij)+1) .AND. (i<=inb(ij))) num1 = num1 + 1
+    END DO
+    IF (num1<=0) GO TO 789
+
+    DO ij = 1, ncum
+      IF ((i>=icb(ij)+1) .AND. (i<=inb(ij))) THEN
+        lwork(ij) = (nent(ij,i)/=0)
+        qp1 = q(ij, nk(ij)) - ep(ij, i)*clw(ij, i)
+        anum = h(ij, i) - hp(ij, i) - lv(ij, i)*(qp1-qs(ij,i))
+        denom = h(ij, i) - hp(ij, i) + lv(ij, i)*(q(ij,i)-qp1)
+        IF (abs(denom)<0.01) denom = 0.01
+        scrit(ij) = anum/denom
+        alt = qp1 - qs(ij, i) + scrit(ij)*(q(ij,i)-qp1)
+        IF (scrit(ij)<0.0 .OR. alt<0.0) scrit(ij) = 1.0
+        asij(ij) = 0.0
+        smin(ij) = 1.0
+      END IF
+    END DO
+    DO j = minorig, nl
+
+      num2 = 0
+      DO ij = 1, ncum
+        IF ((i>=icb(ij)+1) .AND. (i<=inb(ij)) .AND. (j>=icb( &
+          ij)) .AND. (j<=inb(ij)) .AND. lwork(ij)) num2 = num2 + 1
+      END DO
+      IF (num2<=0) GO TO 783
+
+      DO ij = 1, ncum
+        IF ((i>=icb(ij)+1) .AND. (i<=inb(ij)) .AND. (j>=icb( &
+            ij)) .AND. (j<=inb(ij)) .AND. lwork(ij)) THEN
+          IF (sij(ij,i,j)>0.0 .AND. sij(ij,i,j)<0.9) THEN
+            IF (j>i) THEN
+              smid = min(sij(ij,i,j), scrit(ij))
+              sjmax = smid
+              sjmin = smid
+              IF (smid<smin(ij) .AND. sij(ij,i,j+1)<smid) THEN
+                smin(ij) = smid
+                sjmax = min(sij(ij,i,j+1), sij(ij,i,j), scrit(ij))
+                sjmin = max(sij(ij,i,j-1), sij(ij,i,j))
+                sjmin = min(sjmin, scrit(ij))
+              END IF
+            ELSE
+              sjmax = max(sij(ij,i,j+1), scrit(ij))
+              smid = max(sij(ij,i,j), scrit(ij))
+              sjmin = 0.0
+              IF (j>1) sjmin = sij(ij, i, j-1)
+              sjmin = max(sjmin, scrit(ij))
+            END IF
+            delp = abs(sjmax-smid)
+            delm = abs(sjmin-smid)
+            asij(ij) = asij(ij) + (delp+delm)*(ph(ij,j)-ph(ij,j+1))
+            ment(ij, i, j) = ment(ij, i, j)*(delp+delm)*(ph(ij,j)-ph(ij,j+1))
+          END IF
+        END IF
+      END DO
+783 END DO
+    DO ij = 1, ncum
+      IF ((i>=icb(ij)+1) .AND. (i<=inb(ij)) .AND. lwork(ij)) THEN
+        asij(ij) = max(1.0E-21, asij(ij))
+        asij(ij) = 1.0/asij(ij)
+        bsum(ij, i) = 0.0
+      END IF
+    END DO
+    DO j = minorig, nl + 1
+      DO ij = 1, ncum
+        IF ((i>=icb(ij)+1) .AND. (i<=inb(ij)) .AND. (j>=icb( &
+            ij)) .AND. (j<=inb(ij)) .AND. lwork(ij)) THEN
+          ment(ij, i, j) = ment(ij, i, j)*asij(ij)
+          bsum(ij, i) = bsum(ij, i) + ment(ij, i, j)
+        END IF
+      END DO
+    END DO
+    DO ij = 1, ncum
+      IF ((i>=icb(ij)+1) .AND. (i<=inb(ij)) .AND. (bsum(ij, &
+          i)<1.0E-18) .AND. lwork(ij)) THEN
+        nent(ij, i) = 0
+        ment(ij, i, i) = m(ij, i)
+        qent(ij, i, i) = q(ij, nk(ij)) - ep(ij, i)*clw(ij, i)
+        uent(ij, i, i) = u(ij, nk(ij))
+        vent(ij, i, i) = v(ij, nk(ij))
+        elij(ij, i, i) = clw(ij, i)
+        sij(ij, i, i) = 1.0
+      END IF
+    END DO
+789 END DO
+
+  ! =====================================================================
+  ! --- PRECIPITATING DOWNDRAFT CALCULATION
+  ! =====================================================================
+
+  ! ***  Check whether ep(inb)=0, if so, skip precipitating    ***
+  ! ***             downdraft calculation                      ***
+
+
+  ! ***  Integrate liquid water equation to find condensed water   ***
+  ! ***                and condensed water flux                    ***
+
+
+  DO i = 1, ncum
+    jtt(i) = 2
+    IF (ep(i,inb(i))<=0.0001) iflag(i) = 2
+    IF (iflag(i)==0) THEN
+      lwork(i) = .TRUE.
+    ELSE
+      lwork(i) = .FALSE.
+    END IF
+  END DO
+
+  ! ***                    Begin downdraft loop                    ***
+
+
+  CALL zilch(wdtrain, ncum)
+  DO i = nl + 1, 1, -1
+
+    num1 = 0
+    DO ij = 1, ncum
+      IF ((i<=inb(ij)) .AND. lwork(ij)) num1 = num1 + 1
+    END DO
+    IF (num1<=0) GO TO 899
+
+
+    ! ***        Calculate detrained precipitation             ***
+
+    DO ij = 1, ncum
+      IF ((i<=inb(ij)) .AND. (lwork(ij))) THEN
+        wdtrain(ij) = g*ep(ij, i)*m(ij, i)*clw(ij, i)
+      END IF
+    END DO
+
+    IF (i>1) THEN
+      DO j = 1, i - 1
+        DO ij = 1, ncum
+          IF ((i<=inb(ij)) .AND. (lwork(ij))) THEN
+            awat = elij(ij, j, i) - (1.-ep(ij,i))*clw(ij, i)
+            awat = max(0.0, awat)
+            wdtrain(ij) = wdtrain(ij) + g*awat*ment(ij, j, i)
+          END IF
+        END DO
+      END DO
+    END IF
+
+    ! ***    Find rain water and evaporation using provisional   ***
+    ! ***              estimates of qp(i)and qp(i-1)             ***
+
+
+    ! ***  Value of terminal velocity and coeffecient of evaporation for snow
+    ! ***
+
+    DO ij = 1, ncum
+      IF ((i<=inb(ij)) .AND. (lwork(ij))) THEN
+        coeff = coeffs
+        wt(ij, i) = omtsnow
+
+        ! ***  Value of terminal velocity and coeffecient of evaporation for
+        ! rain   ***
+
+        IF (t(ij,i)>273.0) THEN
+          coeff = coeffr
+          wt(ij, i) = omtrain
+        END IF
+        qsm = 0.5*(q(ij,i)+qp(ij,i+1))
+        afac = coeff*ph(ij, i)*(qs(ij,i)-qsm)/(1.0E4+2.0E3*ph(ij,i)*qs(ij,i))
+        afac = max(afac, 0.0)
+        sigt = sigp(ij, i)
+        sigt = max(0.0, sigt)
+        sigt = min(1.0, sigt)
+        b6 = 100.*(ph(ij,i)-ph(ij,i+1))*sigt*afac/wt(ij, i)
+        c6 = (water(ij,i+1)*wt(ij,i+1)+wdtrain(ij)/sigd)/wt(ij, i)
+        revap = 0.5*(-b6+sqrt(b6*b6+4.*c6))
+        evap(ij, i) = sigt*afac*revap
+        water(ij, i) = revap*revap
+
+        ! ***  Calculate precipitating downdraft mass flux under     ***
+        ! ***              hydrostatic approximation                 ***
+
+        IF (i>1) THEN
+          dhdp = (h(ij,i)-h(ij,i-1))/(p(ij,i-1)-p(ij,i))
+          dhdp = max(dhdp, 10.0)
+          mp(ij, i) = 100.*ginv*lv(ij, i)*sigd*evap(ij, i)/dhdp
+          mp(ij, i) = max(mp(ij,i), 0.0)
+
+          ! ***   Add small amount of inertia to downdraft              ***
+
+          fac = 20.0/(ph(ij,i-1)-ph(ij,i))
+          mp(ij, i) = (fac*mp(ij,i+1)+mp(ij,i))/(1.+fac)
+
+          ! ***      Force mp to decrease linearly to zero
+          ! ***
+          ! ***      between about 950 mb and the surface
+          ! ***
+
+          IF (p(ij,i)>(0.949*p(ij,1))) THEN
+            jtt(ij) = max(jtt(ij), i)
+            mp(ij, i) = mp(ij, jtt(ij))*(p(ij,1)-p(ij,i))/ &
+              (p(ij,1)-p(ij,jtt(ij)))
+          END IF
+        END IF
+
+        ! ***       Find mixing ratio of precipitating downdraft     ***
+
+        IF (i/=inb(ij)) THEN
+          IF (i==1) THEN
+            qstm = qs(ij, 1)
+          ELSE
+            qstm = qs(ij, i-1)
+          END IF
+          IF (mp(ij,i)>mp(ij,i+1)) THEN
+            rat = mp(ij, i+1)/mp(ij, i)
+            qp(ij, i) = qp(ij, i+1)*rat + q(ij, i)*(1.0-rat) + &
+              100.*ginv*sigd*(ph(ij,i)-ph(ij,i+1))*(evap(ij,i)/mp(ij,i))
+            up(ij, i) = up(ij, i+1)*rat + u(ij, i)*(1.-rat)
+            vp(ij, i) = vp(ij, i+1)*rat + v(ij, i)*(1.-rat)
+          ELSE
+            IF (mp(ij,i+1)>0.0) THEN
+              qp(ij, i) = (gz(ij,i+1)-gz(ij,i)+qp(ij,i+1)*(lv(ij,i+1)+t(ij, &
+                i+1)*(cl-cpd))+cpd*(t(ij,i+1)-t(ij, &
+                i)))/(lv(ij,i)+t(ij,i)*(cl-cpd))
+              up(ij, i) = up(ij, i+1)
+              vp(ij, i) = vp(ij, i+1)
+            END IF
+          END IF
+          qp(ij, i) = min(qp(ij,i), qstm)
+          qp(ij, i) = max(qp(ij,i), 0.0)
+        END IF
+      END IF
+    END DO
+899 END DO
+
+  ! ***  Calculate surface precipitation in mm/day     ***
+
+  DO i = 1, ncum
+    IF (iflag(i)<=1) THEN
+      ! c            precip(i)=precip(i)+wt(i,1)*sigd*water(i,1)*3600.*24000.
+      ! c     &                /(rowl*g)
+      ! c            precip(i)=precip(i)*delt/86400.
+      precip(i) = wt(i, 1)*sigd*water(i, 1)*86400/g
+    END IF
+  END DO
+
+
+  ! ***  Calculate downdraft velocity scale and surface temperature and  ***
+  ! ***                    water vapor fluctuations                      ***
+
+  ! wd=beta*abs(mp(icb))*0.01*rd*t(icb)/(sigd*p(icb))
+  ! qprime=0.5*(qp(1)-q(1))
+  ! tprime=lv0*qprime/cpd
+
+  ! ***  Calculate tendencies of lowest level potential temperature  ***
+  ! ***                      and mixing ratio                        ***
+
+  DO i = 1, ncum
+    work(i) = 0.01/(ph(i,1)-ph(i,2))
+    am(i) = 0.0
+  END DO
+  DO k = 2, nl
+    DO i = 1, ncum
+      IF ((nk(i)==1) .AND. (k<=inb(i)) .AND. (nk(i)==1)) THEN
+        am(i) = am(i) + m(i, k)
+      END IF
+    END DO
+  END DO
+  DO i = 1, ncum
+    IF ((g*work(i)*am(i))>=delti) iflag(i) = 1
+    ft(i, 1) = ft(i, 1) + g*work(i)*am(i)*(t(i,2)-t(i,1)+(gz(i,2)-gz(i, &
+      1))/cpn(i,1))
+    ft(i, 1) = ft(i, 1) - lvcp(i, 1)*sigd*evap(i, 1)
+    ft(i, 1) = ft(i, 1) + sigd*wt(i, 2)*(cl-cpd)*water(i, 2)*(t(i,2)-t(i,1))* &
+      work(i)/cpn(i, 1)
+    fq(i, 1) = fq(i, 1) + g*mp(i, 2)*(qp(i,2)-q(i,1))*work(i) + &
+      sigd*evap(i, 1)
+    fq(i, 1) = fq(i, 1) + g*am(i)*(q(i,2)-q(i,1))*work(i)
+    fu(i, 1) = fu(i, 1) + g*work(i)*(mp(i,2)*(up(i,2)-u(i,1))+am(i)*(u(i, &
+      2)-u(i,1)))
+    fv(i, 1) = fv(i, 1) + g*work(i)*(mp(i,2)*(vp(i,2)-v(i,1))+am(i)*(v(i, &
+      2)-v(i,1)))
+  END DO
+  DO j = 2, nl
+    DO i = 1, ncum
+      IF (j<=inb(i)) THEN
+        fq(i, 1) = fq(i, 1) + g*work(i)*ment(i, j, 1)*(qent(i,j,1)-q(i,1))
+        fu(i, 1) = fu(i, 1) + g*work(i)*ment(i, j, 1)*(uent(i,j,1)-u(i,1))
+        fv(i, 1) = fv(i, 1) + g*work(i)*ment(i, j, 1)*(vent(i,j,1)-v(i,1))
+      END IF
+    END DO
+  END DO
+
+  ! ***  Calculate tendencies of potential temperature and mixing ratio  ***
+  ! ***               at levels above the lowest level                   ***
+
+  ! ***  First find the net saturated updraft and downdraft mass fluxes  ***
+  ! ***                      through each level                          ***
+
+  DO i = 2, nl + 1
+
+    num1 = 0
+    DO ij = 1, ncum
+      IF (i<=inb(ij)) num1 = num1 + 1
+    END DO
+    IF (num1<=0) GO TO 1500
+
+    CALL zilch(amp1, ncum)
+    CALL zilch(ad, ncum)
+
+    DO k = i + 1, nl + 1
+      DO ij = 1, ncum
+        IF ((i>=nk(ij)) .AND. (i<=inb(ij)) .AND. (k<=(inb(ij)+1))) THEN
+          amp1(ij) = amp1(ij) + m(ij, k)
+        END IF
+      END DO
+    END DO
+
+    DO k = 1, i
+      DO j = i + 1, nl + 1
+        DO ij = 1, ncum
+          IF ((j<=(inb(ij)+1)) .AND. (i<=inb(ij))) THEN
+            amp1(ij) = amp1(ij) + ment(ij, k, j)
+          END IF
+        END DO
+      END DO
+    END DO
+    DO k = 1, i - 1
+      DO j = i, nl + 1
+        DO ij = 1, ncum
+          IF ((i<=inb(ij)) .AND. (j<=inb(ij))) THEN
+            ad(ij) = ad(ij) + ment(ij, j, k)
+          END IF
+        END DO
+      END DO
+    END DO
+
+    DO ij = 1, ncum
+      IF (i<=inb(ij)) THEN
+        dpinv = 0.01/(ph(ij,i)-ph(ij,i+1))
+        cpinv = 1.0/cpn(ij, i)
+
+        ft(ij, i) = ft(ij, i) + g*dpinv*(amp1(ij)*(t(ij,i+1)-t(ij, &
+          i)+(gz(ij,i+1)-gz(ij,i))*cpinv)-ad(ij)*(t(ij,i)-t(ij, &
+          i-1)+(gz(ij,i)-gz(ij,i-1))*cpinv)) - sigd*lvcp(ij, i)*evap(ij, i)
+        ft(ij, i) = ft(ij, i) + g*dpinv*ment(ij, i, i)*(hp(ij,i)-h(ij,i)+t(ij &
+          ,i)*(cpv-cpd)*(q(ij,i)-qent(ij,i,i)))*cpinv
+        ft(ij, i) = ft(ij, i) + sigd*wt(ij, i+1)*(cl-cpd)*water(ij, i+1)*(t( &
+          ij,i+1)-t(ij,i))*dpinv*cpinv
+        fq(ij, i) = fq(ij, i) + g*dpinv*(amp1(ij)*(q(ij,i+1)-q(ij, &
+          i))-ad(ij)*(q(ij,i)-q(ij,i-1)))
+        fu(ij, i) = fu(ij, i) + g*dpinv*(amp1(ij)*(u(ij,i+1)-u(ij, &
+          i))-ad(ij)*(u(ij,i)-u(ij,i-1)))
+        fv(ij, i) = fv(ij, i) + g*dpinv*(amp1(ij)*(v(ij,i+1)-v(ij, &
+          i))-ad(ij)*(v(ij,i)-v(ij,i-1)))
+      END IF
+    END DO
+    DO k = 1, i - 1
+      DO ij = 1, ncum
+        IF (i<=inb(ij)) THEN
+          awat = elij(ij, k, i) - (1.-ep(ij,i))*clw(ij, i)
+          awat = max(awat, 0.0)
+          fq(ij, i) = fq(ij, i) + g*dpinv*ment(ij, k, i)*(qent(ij,k,i)-awat-q &
+            (ij,i))
+          fu(ij, i) = fu(ij, i) + g*dpinv*ment(ij, k, i)*(uent(ij,k,i)-u(ij,i &
+            ))
+          fv(ij, i) = fv(ij, i) + g*dpinv*ment(ij, k, i)*(vent(ij,k,i)-v(ij,i &
+            ))
+        END IF
+      END DO
+    END DO
+    DO k = i, nl + 1
+      DO ij = 1, ncum
+        IF ((i<=inb(ij)) .AND. (k<=inb(ij))) THEN
+          fq(ij, i) = fq(ij, i) + g*dpinv*ment(ij, k, i)*(qent(ij,k,i)-q(ij,i &
+            ))
+          fu(ij, i) = fu(ij, i) + g*dpinv*ment(ij, k, i)*(uent(ij,k,i)-u(ij,i &
+            ))
+          fv(ij, i) = fv(ij, i) + g*dpinv*ment(ij, k, i)*(vent(ij,k,i)-v(ij,i &
+            ))
+        END IF
+      END DO
+    END DO
+    DO ij = 1, ncum
+      IF (i<=inb(ij)) THEN
+        fq(ij, i) = fq(ij, i) + sigd*evap(ij, i) + g*(mp(ij,i+1)*(qp(ij, &
+          i+1)-q(ij,i))-mp(ij,i)*(qp(ij,i)-q(ij,i-1)))*dpinv
+        fu(ij, i) = fu(ij, i) + g*(mp(ij,i+1)*(up(ij,i+1)-u(ij, &
+          i))-mp(ij,i)*(up(ij,i)-u(ij,i-1)))*dpinv
+        fv(ij, i) = fv(ij, i) + g*(mp(ij,i+1)*(vp(ij,i+1)-v(ij, &
+          i))-mp(ij,i)*(vp(ij,i)-v(ij,i-1)))*dpinv
+      END IF
+    END DO
+1500 END DO
+
+  ! *** Adjust tendencies at top of convection layer to reflect  ***
+  ! ***       actual position of the level zero cape             ***
+
+  DO ij = 1, ncum
+    fqold = fq(ij, inb(ij))
+    fq(ij, inb(ij)) = fq(ij, inb(ij))*(1.-frac(ij))
+    fq(ij, inb(ij)-1) = fq(ij, inb(ij)-1) + frac(ij)*fqold*((ph(ij, &
+      inb(ij))-ph(ij,inb(ij)+1))/(ph(ij,inb(ij)-1)-ph(ij, &
+      inb(ij))))*lv(ij, inb(ij))/lv(ij, inb(ij)-1)
+    ftold = ft(ij, inb(ij))
+    ft(ij, inb(ij)) = ft(ij, inb(ij))*(1.-frac(ij))
+    ft(ij, inb(ij)-1) = ft(ij, inb(ij)-1) + frac(ij)*ftold*((ph(ij, &
+      inb(ij))-ph(ij,inb(ij)+1))/(ph(ij,inb(ij)-1)-ph(ij, &
+      inb(ij))))*cpn(ij, inb(ij))/cpn(ij, inb(ij)-1)
+    fuold = fu(ij, inb(ij))
+    fu(ij, inb(ij)) = fu(ij, inb(ij))*(1.-frac(ij))
+    fu(ij, inb(ij)-1) = fu(ij, inb(ij)-1) + frac(ij)*fuold*((ph(ij, &
+      inb(ij))-ph(ij,inb(ij)+1))/(ph(ij,inb(ij)-1)-ph(ij,inb(ij))))
+    fvold = fv(ij, inb(ij))
+    fv(ij, inb(ij)) = fv(ij, inb(ij))*(1.-frac(ij))
+    fv(ij, inb(ij)-1) = fv(ij, inb(ij)-1) + frac(ij)*fvold*((ph(ij, &
+      inb(ij))-ph(ij,inb(ij)+1))/(ph(ij,inb(ij)-1)-ph(ij,inb(ij))))
+  END DO
+
+  ! ***   Very slightly adjust tendencies to force exact   ***
+  ! ***     enthalpy, momentum and tracer conservation     ***
+
+  DO ij = 1, ncum
+    ents(ij) = 0.0
+    uav(ij) = 0.0
+    vav(ij) = 0.0
+    DO i = 1, inb(ij)
+      ents(ij) = ents(ij) + (cpn(ij,i)*ft(ij,i)+lv(ij,i)*fq(ij,i))*(ph(ij,i)- &
+        ph(ij,i+1))
+      uav(ij) = uav(ij) + fu(ij, i)*(ph(ij,i)-ph(ij,i+1))
+      vav(ij) = vav(ij) + fv(ij, i)*(ph(ij,i)-ph(ij,i+1))
+    END DO
+  END DO
+  DO ij = 1, ncum
+    ents(ij) = ents(ij)/(ph(ij,1)-ph(ij,inb(ij)+1))
+    uav(ij) = uav(ij)/(ph(ij,1)-ph(ij,inb(ij)+1))
+    vav(ij) = vav(ij)/(ph(ij,1)-ph(ij,inb(ij)+1))
+  END DO
+  DO ij = 1, ncum
+    DO i = 1, inb(ij)
+      ft(ij, i) = ft(ij, i) - ents(ij)/cpn(ij, i)
+      fu(ij, i) = (1.-cu)*(fu(ij,i)-uav(ij))
+      fv(ij, i) = (1.-cu)*(fv(ij,i)-vav(ij))
+    END DO
+  END DO
+
+  DO k = 1, nl + 1
+    DO i = 1, ncum
+      IF ((q(i,k)+delt*fq(i,k))<0.0) iflag(i) = 10
+    END DO
+  END DO
+
+
+  DO i = 1, ncum
+    IF (iflag(i)>2) THEN
+      precip(i) = 0.0
+      cbmf(i) = 0.0
+    END IF
+  END DO
+  DO k = 1, nl
+    DO i = 1, ncum
+      IF (iflag(i)>2) THEN
+        ft(i, k) = 0.0
+        fq(i, k) = 0.0
+        fu(i, k) = 0.0
+        fv(i, k) = 0.0
+      END IF
+    END DO
+  END DO
+  DO i = 1, ncum
+    precip1(idcum(i)) = precip(i)
+    cbmf1(idcum(i)) = cbmf(i)
+    iflag1(idcum(i)) = iflag(i)
+  END DO
+  DO k = 1, nl
+    DO i = 1, ncum
+      ft1(idcum(i), k) = ft(i, k)
+      fq1(idcum(i), k) = fq(i, k)
+      fu1(idcum(i), k) = fu(i, k)
+      fv1(idcum(i), k) = fv(i, k)
+    END DO
+  END DO
+
+  DO k = 1, nd
+    DO i = 1, len
+      ma(i, k) = 0.
+    END DO
+  END DO
+  DO k = nl, 1, -1
+    DO i = 1, ncum
+      ma(i, k) = ma(i, k+1) + m(i, k)
+    END DO
+  END DO
+
+  RETURN
+END SUBROUTINE convect2
+
Index: DZ6/trunk/libf/phylmd/convect3.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/convect3.F90	(revision 5267)
+++ 	(revision )
@@ -1,1407 +1,0 @@
-
-! $Header$
-
-SUBROUTINE convect3(dtime, epmax, ok_adj, t1, r1, rs, u, v, tra, p, ph, nd, &
-    ndp1, nl, ntra, delt, iflag, ft, fr, fu, fv, ftra, precip, icb, inb, &
-    upwd, dnwd, dnwd0, sig, w0, mike, mke, ma, ments, qents, tps, tls, sigij, &
-    cape, tvp, pbase, buoybase, &  ! ccc     *
-                                   ! DTVPDT1,DTVPDQ1,DPLCLDT,DPLCLDR)
-    dtvpdt1, dtvpdq1, dplcldt, dplcldr, & ! sbl
-    ft2, fr2, fu2, fv2, wd, qcond, qcondc) ! sbl
-
-  ! ***  THE PARAMETER NA SHOULD IN GENERAL EQUAL ND   ***
-
-  ! #################################################################
-  ! Fleur       Introduction des traceurs dans convect3 le 6 juin 200
-  ! #################################################################
-  USE dimphy
-  USE infotrac_phy, ONLY: nbtr
-  IMPLICIT NONE
-  INTEGER na
-  PARAMETER (na=60)
-
-  REAL deltac ! cld
-  PARAMETER (deltac=0.01) ! cld
-
-  INTEGER nent(na)
-  INTEGER nd, ndp1, nl, ntra, iflag, icb, inb
-  REAL dtime, epmax, delt, precip, cape
-  REAL dplcldt, dplcldr
-  REAL t1(nd), r1(nd), rs(nd), u(nd), v(nd), tra(nd, ntra)
-  REAL p(nd), ph(ndp1)
-  REAL ft(nd), fr(nd), fu(nd), fv(nd), ftra(nd, ntra)
-  REAL sig(nd), w0(nd)
-  REAL uent(na, na), vent(na, na), traent(na, na, nbtr), tratm(na)
-  REAL up(na), vp(na), trap(na, nbtr)
-  REAL m(na), mp(na), ment(na, na), qent(na, na), elij(na, na)
-  REAL sij(na, na), tvp(na), tv(na), water(na)
-  REAL rp(na), ep(na), th(na), wt(na), evap(na), clw(na)
-  REAL sigp(na), b(na), tp(na), cpn(na)
-  REAL lv(na), lvcp(na), h(na), hp(na), gz(na)
-  REAL t(na), rr(na)
-
-  REAL ft2(nd), fr2(nd), fu2(nd), fv2(nd) ! added sbl
-  REAL u1(nd), v1(nd) ! added sbl
-
-  REAL buoy(na) !  Lifted parcel buoyancy
-  REAL dtvpdt1(nd), dtvpdq1(nd) ! Derivatives of parcel virtual
-  ! temperature wrt T1 and Q1
-  REAL clw_new(na), qi(na)
-
-  REAL wd, betad ! for gust factor (sb)
-  REAL qcondc(nd) ! interface cld param (sb)
-  REAL qcond(nd), nqcond(na), wa(na), maa(na), siga(na), axc(na) ! cld
-
-  LOGICAL ice_conv, ok_adj
-  PARAMETER (ice_conv=.TRUE.)
-
-  ! ccccccccccccccccccccccccccccccccccccccccccccc
-  ! declaration des variables a sortir
-  ! cccccccccccccccccccccccccccccccccccccccccccc
-  REAL mke(nd)
-  REAL mike(nd)
-  REAL ma(nd)
-  REAL tps(nd) !temperature dans les ascendances non diluees
-  REAL tls(nd) !temperature potentielle
-  REAL ments(nd, nd)
-  REAL qents(nd, nd)
-  REAL sigij(klev, klev)
-  REAL pbase ! pressure at the cloud base level
-  REAL buoybase ! buoyancy at the cloud base level
-  ! ccccccccccccccccccccccccccccccccccccccccccccc
-
-
-  REAL :: cpv,cl,cpvmcl,eps,alv0,rdcp,pbcrit,ptcrit,sigd,spfac
-  REAL :: tau,beta,alpha,dtcrit,dtovsh,ahm,rm,um,vm,dphinv
-  REAL :: a2,x,tvx,tvy,plcl,pden,dpbase,tvpbase,tvbase,tdif
-  REAL :: ath1,ath,delti,deltap,dcape,dlnp,sigold,dtmin,fac,w
-  REAL :: amu,rti,cpd,bf2,anum,denom,dei,altem,cwat,stemp,qp
-  REAL :: scrit,alt,smax,asij,wgh,sjmax,sjmin,smid,delp,delm
-  REAL :: asum,bsum,csum,wflux,tinv,wdtrain,awat,afac,afac1,afac2
-  REAL :: bfac,pr1,pr2,sigt,b6,c6,revap,tevap,delth,amfac,amp2
-  REAL :: xf,tf,af,bf,fac2,ur,sru,d,ampmax,dpinv,am,amde,cpinv
-  REAL :: amp1,ad,rat,ax,bx,cx,dx,ex,dsum
-  INTEGER :: nk,i,j,nopt,jn,k,im,jm,n
-
-  REAL dnwd0(nd) !  precipitation driven unsaturated downdraft flux
-  REAL dnwd(nd), dn1 ! in-cloud saturated downdraft mass flux
-  REAL upwd(nd), up1 ! in-cloud saturated updraft mass flux
-
-  ! ***         ASSIGN VALUES OF THERMODYNAMIC CONSTANTS        ***
-  ! ***             THESE SHOULD BE CONSISTENT WITH             ***
-  ! ***              THOSE USED IN CALLING PROGRAM              ***
-  ! ***     NOTE: THESE ARE ALSO SPECIFIED IN SUBROUTINE TLIFT  ***
-
-  ! sb      CPD=1005.7
-  ! sb      CPV=1870.0
-  ! sb      CL=4190.0
-  ! sb      CPVMCL=CL-CPV
-  ! sb      RV=461.5
-  ! sb      RD=287.04
-  ! sb      EPS=RD/RV
-  ! sb      ALV0=2.501E6
-  ! cccccccccccccccccccccc
-  ! constantes coherentes avec le modele du Centre Europeen
-  ! sb      RD = 1000.0 * 1.380658E-23 * 6.0221367E+23 / 28.9644
-  ! sb      RV = 1000.0 * 1.380658E-23 * 6.0221367E+23 / 18.0153
-  ! sb      CPD = 3.5 * RD
-  ! sb      CPV = 4.0 * RV
-  ! sb      CL = 4218.0
-  ! sb      CPVMCL=CL-CPV
-  ! sb      EPS=RD/RV
-  ! sb      ALV0=2.5008E+06
-  ! ccccccccccccccccccccc
-  ! on utilise les constantes thermo du Centre Europeen: (SB)
-
-  include "YOMCST.h"
-
-  cpd = rcpd
-  cpv = rcpv
-  cl = rcw
-  cpvmcl = cl - cpv
-  eps = rd/rv
-  alv0 = rlvtt
-
-  nk = 1 ! origin level of the lifted parcel
-
-  ! ccccccccccccccccccccc
-
-  ! ***  INITIALIZE OUTPUT ARRAYS AND PARAMETERS  ***
-
-  DO i = 1, nd
-    ft(i) = 0.0
-    fr(i) = 0.0
-    fu(i) = 0.0
-    fv(i) = 0.0
-
-    ft2(i) = 0.0
-    fr2(i) = 0.0
-    fu2(i) = 0.0
-    fv2(i) = 0.0
-
-    DO j = 1, ntra
-      ftra(i, j) = 0.0
-    END DO
-
-    qcondc(i) = 0.0 ! cld
-    qcond(i) = 0.0 ! cld
-    nqcond(i) = 0.0 ! cld
-
-    t(i) = t1(i)
-    rr(i) = r1(i)
-    u1(i) = u(i) ! added sbl
-    v1(i) = v(i) ! added sbl
-  END DO
-  DO i = 1, nl
-    rdcp = (rd*(1.-rr(i))+rr(i)*rv)/(cpd*(1.-rr(i))+rr(i)*cpv)
-    th(i) = t(i)*(1000.0/p(i))**rdcp
-  END DO
-
-  ! ************************************************************
-  ! *    CALCUL DES TEMPERATURES POTENTIELLES A SORTIR
-  ! ************************************************************
-  DO i = 1, nd
-    rdcp = (rd*(1.-rr(i))+rr(i)*rv)/(cpd*(1.-rr(i))+rr(i)*cpv)
-
-    tls(i) = t(i)*(1000.0/p(i))**rdcp
-  END DO
-
-
-
-
-  ! ***********************************************************
-
-
-  precip = 0.0
-  wd = 0.0 ! sb
-  iflag = 1
-
-  ! ***                    SPECIFY PARAMETERS                        ***
-  ! ***  PBCRIT IS THE CRITICAL CLOUD DEPTH (MB) BENEATH WHICH THE   ***
-  ! ***       PRECIPITATION EFFICIENCY IS ASSUMED TO BE ZERO         ***
-  ! ***  PTCRIT IS THE CLOUD DEPTH (MB) ABOVE WHICH THE PRECIP.      ***
-  ! ***            EFFICIENCY IS ASSUMED TO BE UNITY                 ***
-  ! ***  SIGD IS THE FRACTIONAL AREA COVERED BY UNSATURATED DNDRAFT  ***
-  ! ***  SPFAC IS THE FRACTION OF PRECIPITATION FALLING OUTSIDE      ***
-  ! ***                        OF CLOUD                              ***
-  ! ***    ALPHA AND BETA ARE PARAMETERS THAT CONTROL THE RATE OF    ***
-  ! ***                 APPROACH TO QUASI-EQUILIBRIUM                ***
-  ! ***    (THEIR STANDARD VALUES ARE 1.0 AND 0.96, RESPECTIVELY)    ***
-  ! ***           (BETA MUST BE LESS THAN OR EQUAL TO 1)             ***
-  ! ***    DTCRIT IS THE CRITICAL BUOYANCY (K) USED TO ADJUST THE    ***
-  ! ***                 APPROACH TO QUASI-EQUILIBRIUM                ***
-  ! ***                     IT MUST BE LESS THAN 0                   ***
-
-  pbcrit = 150.0
-  ptcrit = 500.0
-  sigd = 0.01
-  spfac = 0.15
-  ! sb:
-  ! EPMAX=0.993 ! precip efficiency less than unity
-  ! EPMAX=1. ! precip efficiency less than unity
-
-  ! jyg
-  ! CC      BETA=0.96
-  ! Beta is now expressed as a function of the characteristic time
-  ! of the convective process.
-  ! CC        Old value : TAU = 15000.   !(for dtime = 600.s)
-  ! CC        Other value (inducing little change) :TAU = 8000.
-  tau = 8000.
-  beta = 1. - dtime/tau
-  ! jyg
-  ! CC      ALPHA=1.0
-  alpha = 1.5E-3*dtime/tau
-  ! Increase alpha in order to compensate W decrease
-  alpha = alpha*1.5
-
-  ! jyg (voir CONVECT 3)
-  ! CC      DTCRIT=-0.2
-  dtcrit = -2.
-  ! gf&jyg
-  ! CC     DT pour l'overshoot.
-  dtovsh = -0.2
-
-
-  ! ***        INCREMENT THE COUNTER       ***
-
-  sig(nd) = sig(nd) + 1.0
-  sig(nd) = amin1(sig(nd), 12.1)
-
-  ! ***    IF NOPT IS AN INTEGER OTHER THAN 0, CONVECT     ***
-  ! ***     RETURNS ARRAYS T AND R THAT MAY HAVE BEEN      ***
-  ! ***  ALTERED BY DRY ADIABATIC ADJUSTMENT; OTHERWISE    ***
-  ! ***        THE RETURNED ARRAYS ARE UNALTERED.          ***
-
-  nopt = 0
-  ! !      NOPT=1 ! sbl
-
-  ! ***            PERFORM DRY ADIABATIC ADJUSTMENT            ***
-
-  ! ***  DO NOT BYPASS THIS EVEN IF THE CALLING PROGRAM HAS A  ***
-  ! ***                BOUNDARY LAYER SCHEME !!!               ***
-
-  IF (ok_adj) THEN ! added sbl
-
-    DO i = nl - 1, 1, -1
-      jn = 0
-      DO j = i + 1, nl
-        IF (th(j)<th(i)) jn = j
-      END DO
-      IF (jn==0) GO TO 30
-      ahm = 0.0
-      rm = 0.0
-      um = 0.0
-      vm = 0.0
-      DO k = 1, ntra
-        tratm(k) = 0.0
-      END DO
-      DO j = i, jn
-        ahm = ahm + (cpd*(1.-rr(j))+rr(j)*cpv)*t(j)*(ph(j)-ph(j+1))
-        rm = rm + rr(j)*(ph(j)-ph(j+1))
-        um = um + u(j)*(ph(j)-ph(j+1))
-        vm = vm + v(j)*(ph(j)-ph(j+1))
-        DO k = 1, ntra
-          tratm(k) = tratm(k) + tra(j, k)*(ph(j)-ph(j+1))
-        END DO
-      END DO
-      dphinv = 1./(ph(i)-ph(jn+1))
-      rm = rm*dphinv
-      um = um*dphinv
-      vm = vm*dphinv
-      DO k = 1, ntra
-        tratm(k) = tratm(k)*dphinv
-      END DO
-      a2 = 0.0
-      DO j = i, jn
-        rr(j) = rm
-        u(j) = um
-        v(j) = vm
-        DO k = 1, ntra
-          tra(j, k) = tratm(k)
-        END DO
-        rdcp = (rd*(1.-rr(j))+rr(j)*rv)/(cpd*(1.-rr(j))+rr(j)*cpv)
-        x = (0.001*p(j))**rdcp
-        t(j) = x
-        a2 = a2 + (cpd*(1.-rr(j))+rr(j)*cpv)*x*(ph(j)-ph(j+1))
-      END DO
-      DO j = i, jn
-        th(j) = ahm/a2
-        t(j) = t(j)*th(j)
-      END DO
-30  END DO
-
-  END IF ! added sbl
-
-  ! ***   RESET INPUT ARRAYS IF ok_adj 0   ***
-
-  IF (ok_adj) THEN
-    DO i = 1, nd
-
-      ft2(i) = (t(i)-t1(i))/delt ! sbl
-      fr2(i) = (rr(i)-r1(i))/delt ! sbl
-      fu2(i) = (u(i)-u1(i))/delt ! sbl
-      fv2(i) = (v(i)-v1(i))/delt ! sbl
-
-      ! !            T1(I)=T(I)      ! commente sbl
-      ! !            R1(I)=RR(I)     ! commente sbl
-    END DO
-  END IF
-
-  ! *** CALCULATE ARRAYS OF GEOPOTENTIAL, HEAT CAPACITY AND STATIC ENERGY
-
-  gz(1) = 0.0
-  cpn(1) = cpd*(1.-rr(1)) + rr(1)*cpv
-  h(1) = t(1)*cpn(1)
-  DO i = 2, nl
-    tvx = t(i)*(1.+rr(i)/eps-rr(i))
-    tvy = t(i-1)*(1.+rr(i-1)/eps-rr(i-1))
-    gz(i) = gz(i-1) + 0.5*rd*(tvx+tvy)*(p(i-1)-p(i))/ph(i)
-    cpn(i) = cpd*(1.-rr(i)) + cpv*rr(i)
-    h(i) = t(i)*cpn(i) + gz(i)
-  END DO
-
-  ! ***  CALCULATE LIFTED CONDENSATION LEVEL OF AIR AT LOWEST MODEL LEVEL ***
-  ! ***       (WITHIN 0.2% OF FORMULA OF BOLTON, MON. WEA. REV.,1980)     ***
-
-  IF (t(1)<250.0 .OR. rr(1)<=0.0) THEN
-    iflag = 0
-    ! sb3d         print*,'je suis passe par 366'
-    RETURN
-  END IF
-
-  ! jyg1 Utilisation de la subroutine CLIFT
-  ! C      RH=RR(1)/RS(1)
-  ! C      CHI=T(1)/(1669.0-122.0*RH-T(1))
-  ! C      PLCL=P(1)*(RH**CHI)
-  CALL clift(p(1), t(1), rr(1), rs(1), plcl, dplcldt, dplcldr)
-  ! jyg2
-  ! sb3d      PRINT *,' em_plcl,p1,t1,r1,rs1,rh '
-  ! sb3d     $        ,PLCL,P(1),T(1),RR(1),RS(1),RH
-
-  IF (plcl<200.0 .OR. plcl>=2000.0) THEN
-    iflag = 2
-    RETURN
-  END IF
-  ! jyg1
-  ! Essais de modification de ICB
-
-  ! ***  CALCULATE FIRST LEVEL ABOVE LCL (=ICB)  ***
-
-  ! C      ICB=NL-1
-  ! C      DO 50 I=2,NL-1
-  ! C         IF(P(I).LT.PLCL)THEN
-  ! C            ICB=MIN(ICB,I)   ! ICB sup ou egal a 2
-  ! C         END IF
-  ! C   50 CONTINUE
-  ! C      IF(ICB.EQ.(NL-1))THEN
-  ! C         IFLAG=3
-  ! C         RETURN
-  ! C      END IF
-
-  ! *** CALCULATE LAYER CONTAINING LCL (=ICB)   ***
-
-  icb = nl - 1
-  ! sb      DO 50 I=2,NL-1
-  DO i = 3, nl - 1 ! modif sb pour que ICB soit sup/egal a 2
-    ! la modification consiste a comparer PLCL a PH et non a P:
-    ! ICB est defini par :  PH(ICB)<PLCL<PH(ICB-!)
-    IF (ph(i)<plcl) THEN
-      icb = min(icb, i)
-    END IF
-  END DO
-  IF (icb==(nl-1)) THEN
-    iflag = 3
-    RETURN
-  END IF
-  icb = icb - 1 ! ICB sup ou egal a 2
-  ! jyg2
-
-
-
-  ! *** SUBROUTINE TLIFT CALCULATES PART OF THE LIFTED PARCEL VIRTUAL
-  ! ***
-  ! ***  TEMPERATURE, THE ACTUAL TEMPERATURE AND THE ADIABATIC
-  ! ***
-  ! ***                   LIQUID WATER CONTENT
-  ! ***
-
-
-  ! jyg1
-  ! make sure that "Cloud base" seen by TLIFT is actually the
-  ! fisrt level where adiabatic ascent is saturated
-  IF (plcl>p(icb)) THEN
-    ! sb        CALL TLIFT(P,T,RR,RS,GZ,PLCL,ICB,TVP,TP,CLW,ND,NL)
-    CALL tlift(p, t, rr, rs, gz, plcl, icb, nk, tvp, tp, clw, nd, nl, &
-      dtvpdt1, dtvpdq1)
-  ELSE
-    ! sb        CALL TLIFT(P,T,RR,RS,GZ,PLCL,ICB+1,TVP,TP,CLW,ND,NL)
-    CALL tlift(p, t, rr, rs, gz, plcl, icb+1, nk, tvp, tp, clw, nd, nl, &
-      dtvpdt1, dtvpdq1)
-  END IF
-  ! jyg2
-
-  ! *****************************************************************************
-  ! ***     SORTIE DE LA TEMPERATURE DE L ASCENDANCE NON DILUE
-  ! *****************************************************************************
-  DO i = 1, nd
-    tps(i) = tp(i)
-  END DO
-
-
-  ! *****************************************************************************
-
-
-  ! ***  SET THE PRECIPITATION EFFICIENCIES AND THE FRACTION OF   ***
-  ! ***          PRECIPITATION FALLING OUTSIDE OF CLOUD           ***
-  ! ***      THESE MAY BE FUNCTIONS OF TP(I), P(I) AND CLW(I)     ***
-
-  DO i = 1, nl
-    pden = ptcrit - pbcrit
-
-    ! jyg
-    ! cc         EP(I)=(P(ICB)-P(I)-PBCRIT)/PDEN
-    ! sb         EP(I)=(PLCL-P(I)-PBCRIT)/PDEN
-    ep(i) = (plcl-p(i)-pbcrit)/pden*epmax ! sb
-
-    ep(i) = amax1(ep(i), 0.0)
-    ! sb         EP(I)=AMIN1(EP(I),1.0)
-    ep(i) = amin1(ep(i), epmax) ! sb
-    sigp(i) = spfac
-
-    ! ***       CALCULATE VIRTUAL TEMPERATURE AND LIFTED PARCEL     ***
-    ! ***                    VIRTUAL TEMPERATURE                    ***
-
-    tv(i) = t(i)*(1.+rr(i)/eps-rr(i))
-    ! cd1
-    ! . Keep all liquid water in lifted parcel (-> adiabatic CAPE)
-
-    ! cc    TVP(I)=TVP(I)-TP(I)*(RR(1)-EP(I)*CLW(I))
-    ! !!! sb         TVP(I)=TVP(I)-TP(I)*RR(1) ! calcule dans tlift
-    ! cd2
-
-    ! ***       Calculate first estimate of buoyancy
-
-    buoy(i) = tvp(i) - tv(i)
-  END DO
-
-  ! ***   Set Cloud Base Buoyancy at (Plcl+DPbase) level buoyancy
-
-  dpbase = -40. !That is 400m above LCL
-  pbase = plcl + dpbase
-  tvpbase = tvp(icb)*(pbase-p(icb+1))/(p(icb)-p(icb+1)) + &
-    tvp(icb+1)*(p(icb)-pbase)/(p(icb)-p(icb+1))
-  tvbase = tv(icb)*(pbase-p(icb+1))/(p(icb)-p(icb+1)) + &
-    tv(icb+1)*(p(icb)-pbase)/(p(icb)-p(icb+1))
-
-  ! test sb:
-  ! @      write(*,*) '++++++++++++++++++++++++++++++++++++++++'
-  ! @      write(*,*) 'plcl,dpbas,tvpbas,tvbas,tvp(icb),tvp(icb1)
-  ! @     :             ,tv(icb),tv(icb1)'
-  ! @      write(*,*) plcl,dpbase,tvpbase,tvbase,tvp(icb)
-  ! @     L          ,tvp(icb+1),tv(icb),tv(icb+1)
-  ! @      write(*,*) '++++++++++++++++++++++++++++++++++++++++'
-  ! fin test sb
-  buoybase = tvpbase - tvbase
-
-  ! C       Set buoyancy = BUOYBASE for all levels below BASE.
-  ! C       For safety, set : BUOY(ICB) = BUOYBASE
-  DO i = icb, nl
-    IF (p(i)>=pbase) THEN
-      buoy(i) = buoybase
-    END IF
-  END DO
-  buoy(icb) = buoybase
-
-  ! sb3d      print *,'buoybase,tvp_tv,tvpbase,tvbase,pbase,plcl'
-  ! sb3d     $,        buoybase,tvp(icb)-tv(icb),tvpbase,tvbase,pbase,plcl
-  ! sb3d      print *,'TVP ',(tvp(i),i=1,nl)
-  ! sb3d      print *,'TV ',(tv(i),i=1,nl)
-  ! sb3d      print *, 'P ',(p(i),i=1,nl)
-  ! sb3d      print *,'ICB ',icb
-  ! test sb:
-  ! @      write(*,*) '@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@'
-  ! @      write(*,*) 'icb,icbs,inb,buoybase:'
-  ! @      write(*,*) icb,icb+1,inb,buoybase
-  ! @      write(*,*) 'k,tvp,tv,tp,buoy,ep: '
-  ! @      do k=1,nl
-  ! @      write(*,*) k,tvp(k),tv(k),tp(k),buoy(k),ep(k)
-  ! @      enddo
-  ! @      write(*,*) '@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@'
-  ! fin test sb
-
-
-
-  ! ***   MAKE SURE THAT COLUMN IS DRY ADIABATIC BETWEEN THE SURFACE  ***
-  ! ***    AND CLOUD BASE, AND THAT LIFTED AIR IS POSITIVELY BUOYANT  ***
-  ! ***                         AT CLOUD BASE                         ***
-  ! ***       IF NOT, RETURN TO CALLING PROGRAM AFTER RESETTING       ***
-  ! ***                        SIG(I) AND W0(I)                       ***
-
-  ! jyg
-  ! CC      TDIF=TVP(ICB)-TV(ICB)
-  tdif = buoy(icb)
-  ath1 = th(1)
-  ! jyg
-  ! CC      ATH=TH(ICB-1)-1.0
-  ath = th(icb-1) - 5.0
-  ! ATH=0.                          ! ajout sb
-  ! IF (ICB.GT.1) ATH=TH(ICB-1)-5.0 ! modif sb
-  IF (tdif<dtcrit .OR. ath>ath1) THEN
-    DO i = 1, nl
-      sig(i) = beta*sig(i) - 2.*alpha*tdif*tdif
-      sig(i) = amax1(sig(i), 0.0)
-      w0(i) = beta*w0(i)
-    END DO
-    iflag = 0
-    RETURN
-  END IF
-
-
-
-  ! ***  IF THIS POINT IS REACHED, MOIST CONVECTIVE ADJUSTMENT IS NECESSARY
-  ! ***
-  ! ***        NOW INITIALIZE VARIOUS ARRAYS USED IN THE COMPUTATIONS
-  ! ***
-
-  DO i = 1, nl
-    hp(i) = h(i)
-    wt(i) = 0.001
-    rp(i) = rr(i)
-    up(i) = u(i)
-    vp(i) = v(i)
-    DO j = 1, ntra
-      trap(i, j) = tra(i, j)
-    END DO
-    nent(i) = 0
-    water(i) = 0.0
-    evap(i) = 0.0
-    b(i) = 0.0
-    mp(i) = 0.0
-    m(i) = 0.0
-    lv(i) = alv0 - cpvmcl*(t(i)-273.15)
-    lvcp(i) = lv(i)/cpn(i)
-    DO j = 1, nl
-      qent(i, j) = rr(j)
-      elij(i, j) = 0.0
-      ment(i, j) = 0.0
-      sij(i, j) = 0.0
-      uent(i, j) = u(j)
-      vent(i, j) = v(j)
-      DO k = 1, ntra
-        traent(i, j, k) = tra(j, k)
-      END DO
-    END DO
-  END DO
-
-  delti = 1.0/delt
-
-  ! ***  FIND THE FIRST MODEL LEVEL (INB) ABOVE THE PARCEL'S       ***
-  ! ***                LEVEL OF NEUTRAL BUOYANCY                   ***
-
-  inb = nl - 1
-  DO i = icb, nl - 1
-    ! jyg
-    ! CC         IF((TVP(I)-TV(I)).LT.DTCRIT)THEN
-    IF (buoy(i)<dtovsh) THEN
-      inb = min(inb, i)
-    END IF
-  END DO
-
-
-
-
-
-  ! ***          RESET SIG(I) AND W0(I) FOR I>INB AND I<ICB       ***
-
-  IF (inb<(nl-1)) THEN
-    DO i = inb + 1, nl - 1
-      ! jyg
-      ! CC            SIG(I)=BETA*SIG(I)-2.0E-4*ALPHA*(TV(INB)-TVP(INB))*
-      ! CC     1              ABS(TV(INB)-TVP(INB))
-      sig(i) = beta*sig(i) + 2.*alpha*buoy(inb)*abs(buoy(inb))
-      sig(i) = amax1(sig(i), 0.0)
-      w0(i) = beta*w0(i)
-    END DO
-  END IF
-  DO i = 1, icb
-    ! jyg
-    ! CC         SIG(I)=BETA*SIG(I)-2.0E-4*ALPHA*(TV(ICB)-TVP(ICB))*
-    ! CC     1           (TV(ICB)-TVP(ICB))
-    sig(i) = beta*sig(i) - 2.*alpha*buoy(icb)*buoy(icb)
-    sig(i) = amax1(sig(i), 0.0)
-    w0(i) = beta*w0(i)
-  END DO
-
-  ! ***    RESET FRACTIONAL AREAS OF UPDRAFTS AND W0 AT INITIAL TIME    ***
-  ! ***           AND AFTER 10 TIME STEPS OF NO CONVECTION              ***
-
-
-  IF (sig(nd)<1.5 .OR. sig(nd)>12.0) THEN
-    DO i = 1, nl - 1
-      sig(i) = 0.0
-      w0(i) = 0.0
-    END DO
-  END IF
-
-  ! ***   CALCULATE LIQUID WATER STATIC ENERGY OF LIFTED PARCEL   ***
-
-  DO i = icb, inb
-    hp(i) = h(1) + (lv(i)+(cpd-cpv)*t(i))*ep(i)*clw(i)
-  END DO
-
-  ! ***  CALCULATE CONVECTIVE AVAILABLE POTENTIAL ENERGY (CAPE),  ***
-  ! ***     VERTICAL VELOCITY (W), FRACTIONAL AREA COVERED BY     ***
-  ! ***     UNDILUTE UPDRAFT (SIG),  AND UPDRAFT MASS FLUX (M)    ***
-
-  cape = 0.0
-
-  DO i = icb + 1, inb
-    ! jyg1
-    ! CC         CAPE=CAPE+RD*(TVP(I-1)-TV(I-1))*(PH(I-1)-PH(I))/P(I-1)
-    ! CC         DCAPE=RD*BUOY(I-1)*(PH(I-1)-PH(I))/P(I-1)
-    ! CC         DLNP=(PH(I-1)-PH(I))/P(I-1)
-    ! The interval on which CAPE is computed starts at PBASE :
-    deltap = min(pbase, ph(i-1)) - min(pbase, ph(i))
-    cape = cape + rd*buoy(i-1)*deltap/p(i-1)
-    dcape = rd*buoy(i-1)*deltap/p(i-1)
-    dlnp = deltap/p(i-1)
-    ! jyg2
-    ! sb3d         print *,'buoy,dlnp,dcape,cape',buoy(i-1),dlnp,dcape,cape
-    ! test sb:
-    ! @       write(*,*) '############################################'
-    ! @         write(*,*) 'cape,rrd,buoy,deltap,p,pbase,ph:'
-    ! @     :     ,cape,rd,buoy(i-1),deltap,p(i-1),pbase,ph(i)
-    ! @       write(*,*) '############################################'
-
-    ! fin test sb
-    cape = amax1(0.0, cape)
-
-    sigold = sig(i)
-    dtmin = 100.0
-    DO j = icb, i - 1
-      ! jyg
-      ! CC            DTMIN=AMIN1(DTMIN,(TVP(J)-TV(J)))
-      dtmin = amin1(dtmin, buoy(j))
-    END DO
-    ! sb3d     print *, 'DTMIN, BETA, ALPHA, SIG = ',DTMIN,BETA,ALPHA,SIG(I)
-    sig(i) = beta*sig(i) + alpha*dtmin*abs(dtmin)
-    sig(i) = amax1(sig(i), 0.0)
-    sig(i) = amin1(sig(i), 0.01)
-    fac = amin1(((dtcrit-dtmin)/dtcrit), 1.0)
-    ! jyg
-    ! C    Essais de reduction de la vitesse
-    ! C         FAC = FAC*.5
-
-    w = (1.-beta)*fac*sqrt(cape) + beta*w0(i)
-    amu = 0.5*(sig(i)+sigold)*w
-    m(i) = amu*0.007*p(i)*(ph(i)-ph(i+1))/tv(i)
-
-    ! --------- test sb:
-    ! write(*,*) '############################################'
-    ! write(*,*) 'k,amu,buoy(k-1),deltap,w,beta,fac,cape,w0(k)'
-    ! write(*,*) i,amu,buoy(i-1),deltap
-    ! :           ,w,beta,fac,cape,w0(i)
-    ! write(*,*) '############################################'
-    ! ---------
-
-    w0(i) = w
-  END DO
-  w0(icb) = 0.5*w0(icb+1)
-  m(icb) = 0.5*m(icb+1)*(ph(icb)-ph(icb+1))/(ph(icb+1)-ph(icb+2))
-  sig(icb) = sig(icb+1)
-  sig(icb-1) = sig(icb)
-  ! jyg1
-  ! sb3d      print *, 'Cloud base, c. top, CAPE',ICB,INB,cape
-  ! sb3d      print *, 'SIG ',(sig(i),i=1,inb)
-  ! sb3d      print *, 'W ',(w0(i),i=1,inb)
-  ! sb3d      print *, 'M ',(m(i), i=1,inb)
-  ! sb3d      print *, 'Dt1 ',(tvp(i)-tv(i),i=1,inb)
-  ! sb3d      print *, 'Dt_vrai ',(buoy(i),i=1,inb)
-  ! jyg2
-
-  ! ***  CALCULATE ENTRAINED AIR MASS FLUX (MENT), TOTAL WATER MIXING  ***
-  ! ***     RATIO (QENT), TOTAL CONDENSED WATER (ELIJ), AND MIXING     ***
-  ! ***                        FRACTION (SIJ)                          ***
-
-
-
-  DO i = icb, inb
-    rti = rr(1) - ep(i)*clw(i)
-    DO j = icb - 1, inb
-      bf2 = 1. + lv(j)*lv(j)*rs(j)/(rv*t(j)*t(j)*cpd)
-      anum = h(j) - hp(i) + (cpv-cpd)*t(j)*(rti-rr(j))
-      denom = h(i) - hp(i) + (cpd-cpv)*(rr(i)-rti)*t(j)
-      dei = denom
-      IF (abs(dei)<0.01) dei = 0.01
-      sij(i, j) = anum/dei
-      sij(i, i) = 1.0
-      altem = sij(i, j)*rr(i) + (1.-sij(i,j))*rti - rs(j)
-      altem = altem/bf2
-      cwat = clw(j)*(1.-ep(j))
-      stemp = sij(i, j)
-      IF ((stemp<0.0 .OR. stemp>1.0 .OR. altem>cwat) .AND. j>i) THEN
-        anum = anum - lv(j)*(rti-rs(j)-cwat*bf2)
-        denom = denom + lv(j)*(rr(i)-rti)
-        IF (abs(denom)<0.01) denom = 0.01
-        sij(i, j) = anum/denom
-        altem = sij(i, j)*rr(i) + (1.-sij(i,j))*rti - rs(j)
-        altem = altem - (bf2-1.)*cwat
-      END IF
-
-
-      IF (sij(i,j)>0.0 .AND. sij(i,j)<0.95) THEN
-        qent(i, j) = sij(i, j)*rr(i) + (1.-sij(i,j))*rti
-        uent(i, j) = sij(i, j)*u(i) + (1.-sij(i,j))*u(nk)
-        vent(i, j) = sij(i, j)*v(i) + (1.-sij(i,j))*v(nk)
-        DO k = 1, ntra
-          traent(i, j, k) = sij(i, j)*tra(i, k) + (1.-sij(i,j))*tra(nk, k)
-        END DO
-        elij(i, j) = altem
-        elij(i, j) = amax1(0.0, elij(i,j))
-        ment(i, j) = m(i)/(1.-sij(i,j))
-        nent(i) = nent(i) + 1
-      END IF
-      sij(i, j) = amax1(0.0, sij(i,j))
-      sij(i, j) = amin1(1.0, sij(i,j))
-    END DO
-
-    ! ***   IF NO AIR CAN ENTRAIN AT LEVEL I ASSUME THAT UPDRAFT DETRAINS
-    ! ***
-    ! ***   AT THAT LEVEL AND CALCULATE DETRAINED AIR FLUX AND PROPERTIES
-    ! ***
-
-    IF (nent(i)==0) THEN
-      ment(i, i) = m(i)
-      qent(i, i) = rr(nk) - ep(i)*clw(i)
-      uent(i, i) = u(nk)
-      vent(i, i) = v(nk)
-      DO j = 1, ntra
-        traent(i, i, j) = tra(nk, j)
-      END DO
-      elij(i, i) = clw(i)
-      sij(i, i) = 1.0
-    END IF
-
-    DO j = icb - 1, inb
-      sigij(i, j) = sij(i, j)
-    END DO
-
-  END DO
-
-  ! ***  NORMALIZE ENTRAINED AIR MASS FLUXES TO REPRESENT EQUAL  ***
-  ! ***              PROBABILITIES OF MIXING                     ***
-
-
-  DO i = icb, inb
-    IF (nent(i)/=0) THEN
-      qp = rr(1) - ep(i)*clw(i)
-      anum = h(i) - hp(i) - lv(i)*(qp-rs(i)) + (cpv-cpd)*t(i)*(qp-rr(i))
-      denom = h(i) - hp(i) + lv(i)*(rr(i)-qp) + (cpd-cpv)*t(i)*(rr(i)-qp)
-      IF (abs(denom)<0.01) denom = 0.01
-      scrit = anum/denom
-      alt = qp - rs(i) + scrit*(rr(i)-qp)
-      IF (scrit<=0.0 .OR. alt<=0.0) scrit = 1.0
-      smax = 0.0
-      asij = 0.0
-      DO j = inb, icb - 1, -1
-        IF (sij(i,j)>1.0E-16 .AND. sij(i,j)<0.95) THEN
-          wgh = 1.0
-          IF (j>i) THEN
-            sjmax = amax1(sij(i,j+1), smax)
-            sjmax = amin1(sjmax, scrit)
-            smax = amax1(sij(i,j), smax)
-            sjmin = amax1(sij(i,j-1), smax)
-            sjmin = amin1(sjmin, scrit)
-            IF (sij(i,j)<(smax-1.0E-16)) wgh = 0.0
-            smid = amin1(sij(i,j), scrit)
-          ELSE
-            sjmax = amax1(sij(i,j+1), scrit)
-            smid = amax1(sij(i,j), scrit)
-            sjmin = 0.0
-            IF (j>1) sjmin = sij(i, j-1)
-            sjmin = amax1(sjmin, scrit)
-          END IF
-          delp = abs(sjmax-smid)
-          delm = abs(sjmin-smid)
-          asij = asij + wgh*(delp+delm)
-          ment(i, j) = ment(i, j)*(delp+delm)*wgh
-        END IF
-      END DO
-      asij = amax1(1.0E-16, asij)
-      asij = 1.0/asij
-      DO j = icb - 1, inb
-        ment(i, j) = ment(i, j)*asij
-      END DO
-      asum = 0.0
-      bsum = 0.0
-      DO j = icb - 1, inb
-        asum = asum + ment(i, j)
-        ment(i, j) = ment(i, j)*sig(j)
-        bsum = bsum + ment(i, j)
-      END DO
-      bsum = amax1(bsum, 1.0E-16)
-      bsum = 1.0/bsum
-      DO j = icb - 1, inb
-        ment(i, j) = ment(i, j)*asum*bsum
-      END DO
-      csum = 0.0
-      DO j = icb - 1, inb
-        csum = csum + ment(i, j)
-      END DO
-
-      IF (csum<m(i)) THEN
-        nent(i) = 0
-        ment(i, i) = m(i)
-        qent(i, i) = rr(1) - ep(i)*clw(i)
-        uent(i, i) = u(nk)
-        vent(i, i) = v(nk)
-        DO j = 1, ntra
-          traent(i, i, j) = tra(nk, j)
-        END DO
-        elij(i, i) = clw(i)
-        sij(i, i) = 1.0
-      END IF
-    END IF
-  END DO
-
-
-
-  ! **************************************************************
-  ! *       CALCUL DES MENTS(I,J) ET DES QENTS(I,J)
-  ! *************************************************************
-
-  DO im = 1, nd
-    DO jm = 1, nd
-
-      qents(im, jm) = qent(im, jm)
-      ments(im, jm) = ment(im, jm)
-    END DO
-  END DO
-
-  ! **********************************************************
-  ! --- test sb:
-  ! @       write(*,*) '^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^'
-  ! @       write(*,*) 'inb,m(inb),ment(inb,inb),sigij(inb,inb):'
-  ! @       write(*,*) inb,m(inb),ment(inb,inb),sigij(inb,inb)
-  ! @       write(*,*) '^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^'
-  ! ---
-
-
-
-
-
-  ! ***  CHECK WHETHER EP(INB)=0, IF SO, SKIP PRECIPITATING    ***
-  ! ***             DOWNDRAFT CALCULATION                      ***
-
-  IF (ep(inb)<0.0001) GO TO 405
-
-  ! ***  INTEGRATE LIQUID WATER EQUATION TO FIND CONDENSED WATER   ***
-  ! ***                AND CONDENSED WATER FLUX                    ***
-
-  wflux = 0.0
-  tinv = 1./3.
-
-  ! ***                    BEGIN DOWNDRAFT LOOP                    ***
-
-  DO i = inb, 1, -1
-
-    ! ***              CALCULATE DETRAINED PRECIPITATION             ***
-
-
-
-    wdtrain = 10.0*ep(i)*m(i)*clw(i)
-    IF (i>1) THEN
-      DO j = 1, i - 1
-        awat = elij(j, i) - (1.-ep(i))*clw(i)
-        awat = amax1(awat, 0.0)
-        wdtrain = wdtrain + 10.0*awat*ment(j, i)
-      END DO
-    END IF
-
-    ! ***    FIND RAIN WATER AND EVAPORATION USING PROVISIONAL   ***
-    ! ***              ESTIMATES OF RP(I)AND RP(I-1)             ***
-
-
-
-    wt(i) = 45.0
-    IF (i<inb) THEN
-      rp(i) = rp(i+1) + (cpd*(t(i+1)-t(i))+gz(i+1)-gz(i))/lv(i)
-      rp(i) = 0.5*(rp(i)+rr(i))
-    END IF
-    rp(i) = amax1(rp(i), 0.0)
-    rp(i) = amin1(rp(i), rs(i))
-    rp(inb) = rr(inb)
-    IF (i==1) THEN
-      afac = p(1)*(rs(1)-rp(1))/(1.0E4+2000.0*p(1)*rs(1))
-    ELSE
-      rp(i-1) = rp(i) + (cpd*(t(i)-t(i-1))+gz(i)-gz(i-1))/lv(i)
-      rp(i-1) = 0.5*(rp(i-1)+rr(i-1))
-      rp(i-1) = amin1(rp(i-1), rs(i-1))
-      rp(i-1) = amax1(rp(i-1), 0.0)
-      afac1 = p(i)*(rs(i)-rp(i))/(1.0E4+2000.0*p(i)*rs(i))
-      afac2 = p(i-1)*(rs(i-1)-rp(i-1))/(1.0E4+2000.0*p(i-1)*rs(i-1))
-      afac = 0.5*(afac1+afac2)
-    END IF
-    IF (i==inb) afac = 0.0
-    afac = amax1(afac, 0.0)
-    bfac = 1./(sigd*wt(i))
-
-    ! jyg1
-    ! CC        SIGT=1.0
-    ! CC        IF(I.GE.ICB)SIGT=SIGP(I)
-    ! Prise en compte de la variation progressive de SIGT dans
-    ! les couches ICB et ICB-1:
-    ! Pour PLCL<PH(I+1), PR1=0 & PR2=1
-    ! Pour PLCL>PH(I),   PR1=1 & PR2=0
-    ! Pour PH(I+1)<PLCL<PH(I), PR1 est la proportion a cheval
-    ! sur le nuage, et PR2 est la proportion sous la base du
-    ! nuage.
-    pr1 = (plcl-ph(i+1))/(ph(i)-ph(i+1))
-    pr1 = max(0., min(1.,pr1))
-    pr2 = (ph(i)-plcl)/(ph(i)-ph(i+1))
-    pr2 = max(0., min(1.,pr2))
-    sigt = sigp(i)*pr1 + pr2
-    ! sb3d         print *,'i,sigt,pr1,pr2', i,sigt,pr1,pr2
-    ! jyg2
-
-    b6 = bfac*50.*sigd*(ph(i)-ph(i+1))*sigt*afac
-    c6 = water(i+1) + bfac*wdtrain - 50.*sigd*bfac*(ph(i)-ph(i+1))*evap(i+1)
-    IF (c6>0.0) THEN
-      revap = 0.5*(-b6+sqrt(b6*b6+4.*c6))
-      evap(i) = sigt*afac*revap
-      water(i) = revap*revap
-    ELSE
-      evap(i) = -evap(i+1) + 0.02*(wdtrain+sigd*wt(i)*water(i+1))/(sigd*(ph(i &
-        )-ph(i+1)))
-    END IF
-
-
-
-    ! ***  CALCULATE PRECIPITATING DOWNDRAFT MASS FLUX UNDER     ***
-    ! ***              HYDROSTATIC APPROXIMATION                 ***
-
-    IF (i==1) GO TO 360
-    tevap = amax1(0.0, evap(i))
-    delth = amax1(0.001, (th(i)-th(i-1)))
-    mp(i) = 10.*lvcp(i)*sigd*tevap*(p(i-1)-p(i))/delth
-
-    ! ***           IF HYDROSTATIC ASSUMPTION FAILS,             ***
-    ! ***   SOLVE CUBIC DIFFERENCE EQUATION FOR DOWNDRAFT THETA  ***
-    ! ***  AND MASS FLUX FROM TWO SIMULTANEOUS DIFFERENTIAL EQNS ***
-
-    amfac = sigd*sigd*70.0*ph(i)*(p(i-1)-p(i))*(th(i)-th(i-1))/(tv(i)*th(i))
-    amp2 = abs(mp(i+1)*mp(i+1)-mp(i)*mp(i))
-    IF (amp2>(0.1*amfac)) THEN
-      xf = 100.0*sigd*sigd*sigd*(ph(i)-ph(i+1))
-      tf = b(i) - 5.0*(th(i)-th(i-1))*t(i)/(lvcp(i)*sigd*th(i))
-      af = xf*tf + mp(i+1)*mp(i+1)*tinv
-      bf = 2.*(tinv*mp(i+1))**3 + tinv*mp(i+1)*xf*tf + &
-        50.*(p(i-1)-p(i))*xf*tevap
-      fac2 = 1.0
-      IF (bf<0.0) fac2 = -1.0
-      bf = abs(bf)
-      ur = 0.25*bf*bf - af*af*af*tinv*tinv*tinv
-      IF (ur>=0.0) THEN
-        sru = sqrt(ur)
-        fac = 1.0
-        IF ((0.5*bf-sru)<0.0) fac = -1.0
-        mp(i) = mp(i+1)*tinv + (0.5*bf+sru)**tinv + &
-          fac*(abs(0.5*bf-sru))**tinv
-      ELSE
-        d = atan(2.*sqrt(-ur)/(bf+1.0E-28))
-        IF (fac2<0.0) d = 3.14159 - d
-        mp(i) = mp(i+1)*tinv + 2.*sqrt(af*tinv)*cos(d*tinv)
-      END IF
-      mp(i) = amax1(0.0, mp(i))
-      b(i-1) = b(i) + 100.0*(p(i-1)-p(i))*tevap/(mp(i)+sigd*0.1) - &
-        10.0*(th(i)-th(i-1))*t(i)/(lvcp(i)*sigd*th(i))
-      b(i-1) = amax1(b(i-1), 0.0)
-    END IF
-
-
-
-    ! ***         LIMIT MAGNITUDE OF MP(I) TO MEET CFL CONDITION      ***
-
-    ampmax = 2.0*(ph(i)-ph(i+1))*delti
-    amp2 = 2.0*(ph(i-1)-ph(i))*delti
-    ampmax = amin1(ampmax, amp2)
-    mp(i) = amin1(mp(i), ampmax)
-
-    ! ***      FORCE MP TO DECREASE LINEARLY TO ZERO                 ***
-    ! ***       BETWEEN CLOUD BASE AND THE SURFACE                   ***
-
-    IF (p(i)>p(icb)) THEN
-      mp(i) = mp(icb)*(p(1)-p(i))/(p(1)-p(icb))
-    END IF
-360 CONTINUE
-
-    ! ***       FIND MIXING RATIO OF PRECIPITATING DOWNDRAFT     ***
-
-    IF (i==inb) GO TO 400
-    rp(i) = rr(i)
-    IF (mp(i)>mp(i+1)) THEN
-      rp(i) = rp(i+1)*mp(i+1) + rr(i)*(mp(i)-mp(i+1)) + &
-        5.*sigd*(ph(i)-ph(i+1))*(evap(i+1)+evap(i))
-      rp(i) = rp(i)/mp(i)
-      up(i) = up(i+1)*mp(i+1) + u(i)*(mp(i)-mp(i+1))
-      up(i) = up(i)/mp(i)
-      vp(i) = vp(i+1)*mp(i+1) + v(i)*(mp(i)-mp(i+1))
-      vp(i) = vp(i)/mp(i)
-      DO j = 1, ntra
-        trap(i, j) = trap(i+1, j)*mp(i+1) + trap(i, j)*(mp(i)-mp(i+1))
-        trap(i, j) = trap(i, j)/mp(i)
-      END DO
-    ELSE
-      IF (mp(i+1)>1.0E-16) THEN
-        rp(i) = rp(i+1) + 5.0*sigd*(ph(i)-ph(i+1))*(evap(i+1)+evap(i))/mp(i+1 &
-          )
-        up(i) = up(i+1)
-        vp(i) = vp(i+1)
-        DO j = 1, ntra
-          trap(i, j) = trap(i+1, j)
-        END DO
-      END IF
-    END IF
-    rp(i) = amin1(rp(i), rs(i))
-    rp(i) = amax1(rp(i), 0.0)
-400 END DO
-
-  ! ***  CALCULATE SURFACE PRECIPITATION IN MM/DAY     ***
-
-  precip = wt(1)*sigd*water(1)*8640.0
-
-  ! sb  ***  Calculate downdraft velocity scale and surface temperature and
-  ! ***
-  ! sb  ***                    water vapor fluctuations
-  ! ***
-  ! sb		(inspire de convect 4.3)
-
-  ! BETAD=10.0
-  betad = 5.0
-  wd = betad*abs(mp(icb))*0.01*rd*t(icb)/(sigd*p(icb))
-
-405 CONTINUE
-
-  ! ***  CALCULATE TENDENCIES OF LOWEST LEVEL POTENTIAL TEMPERATURE  ***
-  ! ***                      AND MIXING RATIO                        ***
-
-  dpinv = 1.0/(ph(1)-ph(2))
-  am = 0.0
-  DO k = 2, inb
-    am = am + m(k)
-  END DO
-  IF ((0.1*dpinv*am)>=delti) iflag = 4
-  ft(1) = 0.1*dpinv*am*(t(2)-t(1)+(gz(2)-gz(1))/cpn(1))
-  ft(1) = ft(1) - 0.5*lvcp(1)*sigd*(evap(1)+evap(2))
-  ft(1) = ft(1) - 0.09*sigd*mp(2)*t(1)*b(1)*dpinv
-  ft(1) = ft(1) + 0.01*sigd*wt(1)*(cl-cpd)*water(2)*(t(2)-t(1))*dpinv/cpn(1)
-  fr(1) = 0.1*mp(2)*(rp(2)-rr(1))* & ! correction bug conservation eau
-  ! 1    DPINV+SIGD*0.5*(EVAP(1)+EVAP(2))
-    dpinv + sigd*0.5*(evap(1)+evap(2))
-  ! IM cf. SBL
-  ! 1    DPINV+SIGD*EVAP(1)
-  fr(1) = fr(1) + 0.1*am*(rr(2)-rr(1))*dpinv
-  fu(1) = fu(1) + 0.1*dpinv*(mp(2)*(up(2)-u(1))+am*(u(2)-u(1)))
-  fv(1) = fv(1) + 0.1*dpinv*(mp(2)*(vp(2)-v(1))+am*(v(2)-v(1)))
-  DO j = 1, ntra
-    ftra(1, j) = ftra(1, j) + 0.1*dpinv*(mp(2)*(trap(2,j)-tra(1, &
-      j))+am*(tra(2,j)-tra(1,j)))
-  END DO
-  amde = 0.0
-  DO j = 2, inb
-    fr(1) = fr(1) + 0.1*dpinv*ment(j, 1)*(qent(j,1)-rr(1))
-    fu(1) = fu(1) + 0.1*dpinv*ment(j, 1)*(uent(j,1)-u(1))
-    fv(1) = fv(1) + 0.1*dpinv*ment(j, 1)*(vent(j,1)-v(1))
-    DO k = 1, ntra
-      ftra(1, k) = ftra(1, k) + 0.1*dpinv*ment(j, 1)*(traent(j,1,k)-tra(1,k))
-    END DO
-  END DO
-
-  ! ***  CALCULATE TENDENCIES OF POTENTIAL TEMPERATURE AND MIXING RATIO  ***
-  ! ***               AT LEVELS ABOVE THE LOWEST LEVEL                   ***
-
-  ! ***  FIRST FIND THE NET SATURATED UPDRAFT AND DOWNDRAFT MASS FLUXES  ***
-  ! ***                      THROUGH EACH LEVEL                          ***
-
-
-
-  DO i = 2, inb
-    dpinv = 1.0/(ph(i)-ph(i+1))
-    cpinv = 1.0/cpn(i)
-    amp1 = 0.0
-    DO k = i + 1, inb + 1
-      amp1 = amp1 + m(k)
-    END DO
-    DO k = 1, i
-      DO j = i + 1, inb + 1
-        amp1 = amp1 + ment(k, j)
-      END DO
-    END DO
-    IF ((0.1*dpinv*amp1)>=delti) iflag = 4
-    ad = 0.0
-    DO k = 1, i - 1
-      DO j = i, inb
-        ad = ad + ment(j, k)
-      END DO
-    END DO
-    ft(i) = 0.1*dpinv*(amp1*(t(i+1)-t(i)+(gz(i+1)-gz(i))*cpinv)-ad*(t(i)-t(i- &
-      1)+(gz(i)-gz(i-1))*cpinv)) - 0.5*sigd*lvcp(i)*(evap(i)+evap(i+1))
-    rat = cpn(i-1)*cpinv
-    ft(i) = ft(i) - 0.09*sigd*(mp(i+1)*t(i)*b(i)-mp(i)*t(i-1)*rat*b(i-1))* &
-      dpinv
-    ft(i) = ft(i) + 0.1*dpinv*ment(i, i)*(hp(i)-h(i)+t(i)*(cpv-cpd)*(rr(i)- &
-      qent(i,i)))*cpinv
-    ft(i) = ft(i) + 0.01*sigd*wt(i)*(cl-cpd)*water(i+1)*(t(i+1)-t(i))*dpinv* &
-      cpinv
-    fr(i) = 0.1*dpinv*(amp1*(rr(i+1)-rr(i))-ad*(rr(i)-rr(i-1)))
-    fu(i) = fu(i) + 0.1*dpinv*(amp1*(u(i+1)-u(i))-ad*(u(i)-u(i-1)))
-    fv(i) = fv(i) + 0.1*dpinv*(amp1*(v(i+1)-v(i))-ad*(v(i)-v(i-1)))
-    DO k = 1, ntra
-      ftra(i, k) = ftra(i, k) + 0.1*dpinv*(amp1*(tra(i+1,k)-tra(i, &
-        k))-ad*(tra(i,k)-tra(i-1,k)))
-    END DO
-    DO k = 1, i - 1
-      awat = elij(k, i) - (1.-ep(i))*clw(i)
-      awat = amax1(awat, 0.0)
-      fr(i) = fr(i) + 0.1*dpinv*ment(k, i)*(qent(k,i)-awat-rr(i))
-      fu(i) = fu(i) + 0.1*dpinv*ment(k, i)*(uent(k,i)-u(i))
-      fv(i) = fv(i) + 0.1*dpinv*ment(k, i)*(vent(k,i)-v(i))
-      ! (saturated updrafts resulting from mixing)      ! cld
-      qcond(i) = qcond(i) + (elij(k,i)-awat) ! cld
-      nqcond(i) = nqcond(i) + 1. ! cld
-      DO j = 1, ntra
-        ftra(i, j) = ftra(i, j) + 0.1*dpinv*ment(k, i)*(traent(k,i,j)-tra(i,j &
-          ))
-      END DO
-    END DO
-    DO k = i, inb
-      fr(i) = fr(i) + 0.1*dpinv*ment(k, i)*(qent(k,i)-rr(i))
-      fu(i) = fu(i) + 0.1*dpinv*ment(k, i)*(uent(k,i)-u(i))
-      fv(i) = fv(i) + 0.1*dpinv*ment(k, i)*(vent(k,i)-v(i))
-      DO j = 1, ntra
-        ftra(i, j) = ftra(i, j) + 0.1*dpinv*ment(k, i)*(traent(k,i,j)-tra(i,j &
-          ))
-      END DO
-    END DO
-    fr(i) = fr(i) + 0.5*sigd*(evap(i)+evap(i+1)) + 0.1*(mp(i+1)*(rp(i+ &
-      1)-rr(i))-mp(i)*(rp(i)-rr(i-1)))*dpinv
-    fu(i) = fu(i) + 0.1*(mp(i+1)*(up(i+1)-u(i))-mp(i)*(up(i)-u(i-1)))*dpinv
-    fv(i) = fv(i) + 0.1*(mp(i+1)*(vp(i+1)-v(i))-mp(i)*(vp(i)-v(i-1)))*dpinv
-    DO j = 1, ntra
-      ftra(i, j) = ftra(i, j) + 0.1*dpinv*(mp(i+1)*(trap(i+1,j)-tra(i, &
-        j))-mp(i)*(trap(i,j)-trap(i-1,j)))
-    END DO
-    ! (saturated downdrafts resulting from mixing)    ! cld
-    DO k = i + 1, inb ! cld
-      qcond(i) = qcond(i) + elij(k, i) ! cld
-      nqcond(i) = nqcond(i) + 1. ! cld
-    END DO ! cld
-    ! (particular case: no detraining level is found) ! cld
-    IF (nent(i)==0) THEN ! cld
-      qcond(i) = qcond(i) + (1-ep(i))*clw(i) ! cld
-      nqcond(i) = nqcond(i) + 1. ! cld
-    END IF ! cld
-    IF (nqcond(i)/=0.) THEN ! cld
-      qcond(i) = qcond(i)/nqcond(i) ! cld
-    END IF ! cld
-  END DO
-
-
-
-
-  ! ***   MOVE THE DETRAINMENT AT LEVEL INB DOWN TO LEVEL INB-1   ***
-  ! ***        IN SUCH A WAY AS TO PRESERVE THE VERTICALLY        ***
-  ! ***          INTEGRATED ENTHALPY AND WATER TENDENCIES         ***
-
-  ! test sb:
-  ! @      write(*,*) '--------------------------------------------'
-  ! @      write(*,*) 'inb,ft,hp,h,t,rr,qent,ment,water,waterp,wt,mp,b'
-  ! @      write(*,*) inb,ft(inb),hp(inb),h(inb)
-  ! @     :   ,t(inb),rr(inb),qent(inb,inb)
-  ! @     :   ,ment(inb,inb),water(inb)
-  ! @     :   ,water(inb+1),wt(inb),mp(inb),b(inb)
-  ! @      write(*,*) '--------------------------------------------'
-  ! fin test sb:
-
-  ax = 0.1*ment(inb, inb)*(hp(inb)-h(inb)+t(inb)*(cpv-cpd)*(rr(inb)-qent(inb, &
-    inb)))/(cpn(inb)*(ph(inb)-ph(inb+1)))
-  ft(inb) = ft(inb) - ax
-  ft(inb-1) = ft(inb-1) + ax*cpn(inb)*(ph(inb)-ph(inb+1))/(cpn(inb-1)*(ph(inb &
-    -1)-ph(inb)))
-  bx = 0.1*ment(inb, inb)*(qent(inb,inb)-rr(inb))/(ph(inb)-ph(inb+1))
-  fr(inb) = fr(inb) - bx
-  fr(inb-1) = fr(inb-1) + bx*(ph(inb)-ph(inb+1))/(ph(inb-1)-ph(inb))
-  cx = 0.1*ment(inb, inb)*(uent(inb,inb)-u(inb))/(ph(inb)-ph(inb+1))
-  fu(inb) = fu(inb) - cx
-  fu(inb-1) = fu(inb-1) + cx*(ph(inb)-ph(inb+1))/(ph(inb-1)-ph(inb))
-  dx = 0.1*ment(inb, inb)*(vent(inb,inb)-v(inb))/(ph(inb)-ph(inb+1))
-  fv(inb) = fv(inb) - dx
-  fv(inb-1) = fv(inb-1) + dx*(ph(inb)-ph(inb+1))/(ph(inb-1)-ph(inb))
-  DO j = 1, ntra
-    ex = 0.1*ment(inb, inb)*(traent(inb,inb,j)-tra(inb,j))/ &
-      (ph(inb)-ph(inb+1))
-    ftra(inb, j) = ftra(inb, j) - ex
-    ftra(inb-1, j) = ftra(inb-1, j) + ex*(ph(inb)-ph(inb+1))/(ph(inb-1)-ph( &
-      inb))
-  END DO
-
-  ! ***    HOMOGINIZE TENDENCIES BELOW CLOUD BASE    ***
-
-  asum = 0.0
-  bsum = 0.0
-  csum = 0.0
-  dsum = 0.0
-  DO i = 1, icb - 1
-    asum = asum + ft(i)*(ph(i)-ph(i+1))
-    bsum = bsum + fr(i)*(lv(i)+(cl-cpd)*(t(i)-t(1)))*(ph(i)-ph(i+1))
-    csum = csum + (lv(i)+(cl-cpd)*(t(i)-t(1)))*(ph(i)-ph(i+1))
-    dsum = dsum + t(i)*(ph(i)-ph(i+1))/th(i)
-  END DO
-  DO i = 1, icb - 1
-    ft(i) = asum*t(i)/(th(i)*dsum)
-    fr(i) = bsum/csum
-  END DO
-
-  ! ***           RESET COUNTER AND RETURN           ***
-
-  sig(nd) = 2.0
-
-
-  DO i = 1, nd
-    upwd(i) = 0.0
-    dnwd(i) = 0.0
-    ! sb       dnwd0(i) = - mp(i)
-  END DO
-
-  DO i = 1, nl
-    dnwd0(i) = -mp(i)
-  END DO
-  DO i = nl + 1, nd
-    dnwd0(i) = 0.
-  END DO
-
-  DO i = icb, inb
-    upwd(i) = 0.0
-    dnwd(i) = 0.0
-
-    DO k = i, inb
-      up1 = 0.0
-      dn1 = 0.0
-      DO n = 1, i - 1
-        up1 = up1 + ment(n, k)
-        dn1 = dn1 - ment(k, n)
-      END DO
-      upwd(i) = upwd(i) + m(k) + up1
-      dnwd(i) = dnwd(i) + dn1
-    END DO
-  END DO
-
-  ! ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
-  ! DETERMINATION DE LA VARIATION DE FLUX ASCENDANT ENTRE
-  ! DEUX NIVEAU NON DILUE Mike
-  ! ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
-
-
-  ! sb      do i=1,ND
-  ! sb      Mike(i)=M(i)
-  ! sb      enddo
-
-  DO i = 1, nl
-    mike(i) = m(i)
-  END DO
-  DO i = nl + 1, nd
-    mike(i) = 0.
-  END DO
-
-  DO i = 1, nd
-    ma(i) = 0
-  END DO
-
-  ! sb      do i=1,nd
-  ! sb      do j=i,nd
-  ! sb      Ma(i)=Ma(i)+M(j)
-  ! sb      enddo
-  ! sb      enddo
-
-  DO i = 1, nl
-    DO j = i, nl
-      ma(i) = ma(i) + m(j)
-    END DO
-  END DO
-
-  DO i = nl + 1, nd
-    ma(i) = 0.
-  END DO
-
-  DO i = 1, icb - 1
-    ma(i) = 0
-  END DO
-
-
-
-  ! cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
-  ! ICB REPRESENTE DE NIVEAU OU SE TROUVE LA
-  ! BASE DU NUAGE , ET INB LE TOP DU NUAGE
-  ! ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
-
-
-  DO i = 1, nd
-    mke(i) = upwd(i) + dnwd(i)
-  END DO
-
-
-  ! *** Diagnose the in-cloud mixing ratio   ***              ! cld
-  ! ***           of condensed water         ***              ! cld
-  ! ! cld
-  DO i = 1, nd ! cld
-    maa(i) = 0.0 ! cld
-    wa(i) = 0.0 ! cld
-    siga(i) = 0.0 ! cld
-  END DO ! cld
-  DO i = nk, inb ! cld
-    DO k = i + 1, inb + 1 ! cld
-      maa(i) = maa(i) + m(k) ! cld
-    END DO ! cld
-  END DO ! cld
-  DO i = icb, inb - 1 ! cld
-    axc(i) = 0. ! cld
-    DO j = icb, i ! cld
-      axc(i) = axc(i) + rd*(tvp(j)-tv(j))*(ph(j)-ph(j+1))/p(j) ! cld
-    END DO ! cld
-    IF (axc(i)>0.0) THEN ! cld
-      wa(i) = sqrt(2.*axc(i)) ! cld
-    END IF ! cld
-  END DO ! cld
-  DO i = 1, nl ! cld
-    IF (wa(i)>0.0) &               ! cld
-      siga(i) = maa(i)/wa(i)*rd*tvp(i)/p(i)/100./deltac ! cld
-    siga(i) = min(siga(i), 1.0) ! cld
-    qcondc(i) = siga(i)*clw(i)*(1.-ep(i)) & ! cld
-      +(1.-siga(i))*qcond(i) ! cld
-  END DO ! cld
-
-
-  ! @$$cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
-  ! @$$         call writeg1d(1,klev,ma,'ma  ','ma  ')
-  ! @$$          call writeg1d(1,klev,upwd,'upwd  ','upwd  ')
-  ! @$$          call writeg1d(1,klev,dnwd,'dnwd  ','dnwd  ')
-  ! @$$          call writeg1d(1,klev,dnwd0,'dnwd0  ','dnwd0  ')
-  ! @$$          call writeg1d(1,klev,tvp,'tvp  ','tvp  ')
-  ! @$$          call writeg1d(1,klev,tra(1:klev,3),'tra3  ','tra3  ')
-  ! @$$          call writeg1d(1,klev,tra(1:klev,4),'tra4  ','tra4  ')
-  ! @$$          call writeg1d(1,klev,tra(1:klev,5),'tra5  ','tra5  ')
-  ! @$$          call writeg1d(1,klev,tra(1:klev,6),'tra6  ','tra6  ')
-  ! @$$          call writeg1d(1,klev,tra(1:klev,7),'tra7  ','tra7  ')
-  ! @$$          call writeg1d(1,klev,tra(1:klev,8),'tra8  ','tra8  ')
-  ! @$$          call writeg1d(1,klev,tra(1:klev,9),'tra9  ','tra9  ')
-  ! @$$          call writeg1d(1,klev,tra(1:klev,10),'tra10','tra10')
-  ! @$$          call writeg1d(1,klev,tra(1:klev,11),'tra11','tra11')
-  ! @$$          call writeg1d(1,klev,tra(1:klev,12),'tra12','tra12')
-  ! @$$          call writeg1d(1,klev,tra(1:klev,13),'tra13','tra13')
-  ! @$$          call writeg1d(1,klev,tra(1:klev,14),'tra14','tra14')
-  ! @$$          call writeg1d(1,klev,tra(1:klev,15),'tra15','tra15')
-  ! @$$          call writeg1d(1,klev,tra(1:klev,16),'tra16','tra16')
-  ! @$$          call writeg1d(1,klev,tra(1:klev,17),'tra17','tra17')
-  ! @$$          call writeg1d(1,klev,tra(1:klev,18),'tra18','tra18')
-  ! @$$          call writeg1d(1,klev,tra(1:klev,19),'tra19','tra19')
-  ! @$$          call writeg1d(1,klev,tra(1:klev,20),'tra20','tra20 ')
-  ! @$$          call writeg1d(1,klev,trap(1:klev,1),'trp1','trp1')
-  ! @$$          call writeg1d(1,klev,trap(1:klev,2),'trp2','trp2')
-  ! @$$          call writeg1d(1,klev,trap(1:klev,3),'trp3','trp3')
-  ! @$$          call writeg1d(1,klev,trap(1:klev,4),'trp4','trp4')
-  ! @$$          call writeg1d(1,klev,trap(1:klev,5),'trp5','trp5')
-  ! @$$          call writeg1d(1,klev,trap(1:klev,10),'trp10','trp10')
-  ! @$$          call writeg1d(1,klev,trap(1:klev,12),'trp12','trp12')
-  ! @$$          call writeg1d(1,klev,trap(1:klev,15),'trp15','trp15')
-  ! @$$          call writeg1d(1,klev,trap(1:klev,20),'trp20','trp20')
-  ! @$$          call writeg1d(1,klev,ftra(1:klev,1),'ftr1  ','ftr1  ')
-  ! @$$          call writeg1d(1,klev,ftra(1:klev,2),'ftr2  ','ftr2  ')
-  ! @$$          call writeg1d(1,klev,ftra(1:klev,3),'ftr3  ','ftr3  ')
-  ! @$$          call writeg1d(1,klev,ftra(1:klev,4),'ftr4  ','ftr4  ')
-  ! @$$          call writeg1d(1,klev,ftra(1:klev,5),'ftr5  ','ftr5  ')
-  ! @$$          call writeg1d(1,klev,ftra(1:klev,6),'ftr6  ','ftr6  ')
-  ! @$$          call writeg1d(1,klev,ftra(1:klev,7),'ftr7  ','ftr7  ')
-  ! @$$          call writeg1d(1,klev,ftra(1:klev,8),'ftr8  ','ftr8  ')
-  ! @$$          call writeg1d(1,klev,ftra(1:klev,9),'ftr9  ','ftr9  ')
-  ! @$$          call writeg1d(1,klev,ftra(1:klev,10),'ftr10','ftr10')
-  ! @$$          call writeg1d(1,klev,ftra(1:klev,11),'ftr11','ftr11')
-  ! @$$          call writeg1d(1,klev,ftra(1:klev,12),'ftr12','ftr12')
-  ! @$$          call writeg1d(1,klev,ftra(1:klev,13),'ftr13','ftr13')
-  ! @$$          call writeg1d(1,klev,ftra(1:klev,14),'ftr14','ftr14')
-  ! @$$          call writeg1d(1,klev,ftra(1:klev,15),'ftr15','ftr15')
-  ! @$$          call writeg1d(1,klev,ftra(1:klev,16),'ftr16','ftr16')
-  ! @$$          call writeg1d(1,klev,ftra(1:klev,17),'ftr17','ftr17')
-  ! @$$          call writeg1d(1,klev,ftra(1:klev,18),'ftr18','ftr18')
-  ! @$$          call writeg1d(1,klev,ftra(1:klev,19),'ftr19','ftr19')
-  ! @$$          call writeg1d(1,klev,ftra(1:klev,20),'ftr20','ftr20 ')
-  ! @$$          call writeg1d(1,klev,mp,'mp  ','mp ')
-  ! @$$          call writeg1d(1,klev,Mke,'Mke  ','Mke ')
-
-
-
-  ! cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
-
-
-  RETURN
-END SUBROUTINE convect3
-! ---------------------------------------------------------------------------
Index: /LMDZ6/trunk/libf/phylmd/convect3.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/convect3.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/convect3.f90	(revision 5268)
@@ -0,0 +1,1407 @@
+
+! $Header$
+
+SUBROUTINE convect3(dtime, epmax, ok_adj, t1, r1, rs, u, v, tra, p, ph, nd, &
+    ndp1, nl, ntra, delt, iflag, ft, fr, fu, fv, ftra, precip, icb, inb, &
+    upwd, dnwd, dnwd0, sig, w0, mike, mke, ma, ments, qents, tps, tls, sigij, &
+    cape, tvp, pbase, buoybase, &  ! ccc     *
+                                   ! DTVPDT1,DTVPDQ1,DPLCLDT,DPLCLDR)
+    dtvpdt1, dtvpdq1, dplcldt, dplcldr, & ! sbl
+    ft2, fr2, fu2, fv2, wd, qcond, qcondc) ! sbl
+
+  ! ***  THE PARAMETER NA SHOULD IN GENERAL EQUAL ND   ***
+
+  ! #################################################################
+  ! Fleur       Introduction des traceurs dans convect3 le 6 juin 200
+  ! #################################################################
+  USE dimphy
+  USE infotrac_phy, ONLY: nbtr
+  IMPLICIT NONE
+  INTEGER na
+  PARAMETER (na=60)
+
+  REAL deltac ! cld
+  PARAMETER (deltac=0.01) ! cld
+
+  INTEGER nent(na)
+  INTEGER nd, ndp1, nl, ntra, iflag, icb, inb
+  REAL dtime, epmax, delt, precip, cape
+  REAL dplcldt, dplcldr
+  REAL t1(nd), r1(nd), rs(nd), u(nd), v(nd), tra(nd, ntra)
+  REAL p(nd), ph(ndp1)
+  REAL ft(nd), fr(nd), fu(nd), fv(nd), ftra(nd, ntra)
+  REAL sig(nd), w0(nd)
+  REAL uent(na, na), vent(na, na), traent(na, na, nbtr), tratm(na)
+  REAL up(na), vp(na), trap(na, nbtr)
+  REAL m(na), mp(na), ment(na, na), qent(na, na), elij(na, na)
+  REAL sij(na, na), tvp(na), tv(na), water(na)
+  REAL rp(na), ep(na), th(na), wt(na), evap(na), clw(na)
+  REAL sigp(na), b(na), tp(na), cpn(na)
+  REAL lv(na), lvcp(na), h(na), hp(na), gz(na)
+  REAL t(na), rr(na)
+
+  REAL ft2(nd), fr2(nd), fu2(nd), fv2(nd) ! added sbl
+  REAL u1(nd), v1(nd) ! added sbl
+
+  REAL buoy(na) !  Lifted parcel buoyancy
+  REAL dtvpdt1(nd), dtvpdq1(nd) ! Derivatives of parcel virtual
+  ! temperature wrt T1 and Q1
+  REAL clw_new(na), qi(na)
+
+  REAL wd, betad ! for gust factor (sb)
+  REAL qcondc(nd) ! interface cld param (sb)
+  REAL qcond(nd), nqcond(na), wa(na), maa(na), siga(na), axc(na) ! cld
+
+  LOGICAL ice_conv, ok_adj
+  PARAMETER (ice_conv=.TRUE.)
+
+  ! ccccccccccccccccccccccccccccccccccccccccccccc
+  ! declaration des variables a sortir
+  ! cccccccccccccccccccccccccccccccccccccccccccc
+  REAL mke(nd)
+  REAL mike(nd)
+  REAL ma(nd)
+  REAL tps(nd) !temperature dans les ascendances non diluees
+  REAL tls(nd) !temperature potentielle
+  REAL ments(nd, nd)
+  REAL qents(nd, nd)
+  REAL sigij(klev, klev)
+  REAL pbase ! pressure at the cloud base level
+  REAL buoybase ! buoyancy at the cloud base level
+  ! ccccccccccccccccccccccccccccccccccccccccccccc
+
+
+  REAL :: cpv,cl,cpvmcl,eps,alv0,rdcp,pbcrit,ptcrit,sigd,spfac
+  REAL :: tau,beta,alpha,dtcrit,dtovsh,ahm,rm,um,vm,dphinv
+  REAL :: a2,x,tvx,tvy,plcl,pden,dpbase,tvpbase,tvbase,tdif
+  REAL :: ath1,ath,delti,deltap,dcape,dlnp,sigold,dtmin,fac,w
+  REAL :: amu,rti,cpd,bf2,anum,denom,dei,altem,cwat,stemp,qp
+  REAL :: scrit,alt,smax,asij,wgh,sjmax,sjmin,smid,delp,delm
+  REAL :: asum,bsum,csum,wflux,tinv,wdtrain,awat,afac,afac1,afac2
+  REAL :: bfac,pr1,pr2,sigt,b6,c6,revap,tevap,delth,amfac,amp2
+  REAL :: xf,tf,af,bf,fac2,ur,sru,d,ampmax,dpinv,am,amde,cpinv
+  REAL :: amp1,ad,rat,ax,bx,cx,dx,ex,dsum
+  INTEGER :: nk,i,j,nopt,jn,k,im,jm,n
+
+  REAL dnwd0(nd) !  precipitation driven unsaturated downdraft flux
+  REAL dnwd(nd), dn1 ! in-cloud saturated downdraft mass flux
+  REAL upwd(nd), up1 ! in-cloud saturated updraft mass flux
+
+  ! ***         ASSIGN VALUES OF THERMODYNAMIC CONSTANTS        ***
+  ! ***             THESE SHOULD BE CONSISTENT WITH             ***
+  ! ***              THOSE USED IN CALLING PROGRAM              ***
+  ! ***     NOTE: THESE ARE ALSO SPECIFIED IN SUBROUTINE TLIFT  ***
+
+  ! sb      CPD=1005.7
+  ! sb      CPV=1870.0
+  ! sb      CL=4190.0
+  ! sb      CPVMCL=CL-CPV
+  ! sb      RV=461.5
+  ! sb      RD=287.04
+  ! sb      EPS=RD/RV
+  ! sb      ALV0=2.501E6
+  ! cccccccccccccccccccccc
+  ! constantes coherentes avec le modele du Centre Europeen
+  ! sb      RD = 1000.0 * 1.380658E-23 * 6.0221367E+23 / 28.9644
+  ! sb      RV = 1000.0 * 1.380658E-23 * 6.0221367E+23 / 18.0153
+  ! sb      CPD = 3.5 * RD
+  ! sb      CPV = 4.0 * RV
+  ! sb      CL = 4218.0
+  ! sb      CPVMCL=CL-CPV
+  ! sb      EPS=RD/RV
+  ! sb      ALV0=2.5008E+06
+  ! ccccccccccccccccccccc
+  ! on utilise les constantes thermo du Centre Europeen: (SB)
+
+  include "YOMCST.h"
+
+  cpd = rcpd
+  cpv = rcpv
+  cl = rcw
+  cpvmcl = cl - cpv
+  eps = rd/rv
+  alv0 = rlvtt
+
+  nk = 1 ! origin level of the lifted parcel
+
+  ! ccccccccccccccccccccc
+
+  ! ***  INITIALIZE OUTPUT ARRAYS AND PARAMETERS  ***
+
+  DO i = 1, nd
+    ft(i) = 0.0
+    fr(i) = 0.0
+    fu(i) = 0.0
+    fv(i) = 0.0
+
+    ft2(i) = 0.0
+    fr2(i) = 0.0
+    fu2(i) = 0.0
+    fv2(i) = 0.0
+
+    DO j = 1, ntra
+      ftra(i, j) = 0.0
+    END DO
+
+    qcondc(i) = 0.0 ! cld
+    qcond(i) = 0.0 ! cld
+    nqcond(i) = 0.0 ! cld
+
+    t(i) = t1(i)
+    rr(i) = r1(i)
+    u1(i) = u(i) ! added sbl
+    v1(i) = v(i) ! added sbl
+  END DO
+  DO i = 1, nl
+    rdcp = (rd*(1.-rr(i))+rr(i)*rv)/(cpd*(1.-rr(i))+rr(i)*cpv)
+    th(i) = t(i)*(1000.0/p(i))**rdcp
+  END DO
+
+  ! ************************************************************
+  ! *    CALCUL DES TEMPERATURES POTENTIELLES A SORTIR
+  ! ************************************************************
+  DO i = 1, nd
+    rdcp = (rd*(1.-rr(i))+rr(i)*rv)/(cpd*(1.-rr(i))+rr(i)*cpv)
+
+    tls(i) = t(i)*(1000.0/p(i))**rdcp
+  END DO
+
+
+
+
+  ! ***********************************************************
+
+
+  precip = 0.0
+  wd = 0.0 ! sb
+  iflag = 1
+
+  ! ***                    SPECIFY PARAMETERS                        ***
+  ! ***  PBCRIT IS THE CRITICAL CLOUD DEPTH (MB) BENEATH WHICH THE   ***
+  ! ***       PRECIPITATION EFFICIENCY IS ASSUMED TO BE ZERO         ***
+  ! ***  PTCRIT IS THE CLOUD DEPTH (MB) ABOVE WHICH THE PRECIP.      ***
+  ! ***            EFFICIENCY IS ASSUMED TO BE UNITY                 ***
+  ! ***  SIGD IS THE FRACTIONAL AREA COVERED BY UNSATURATED DNDRAFT  ***
+  ! ***  SPFAC IS THE FRACTION OF PRECIPITATION FALLING OUTSIDE      ***
+  ! ***                        OF CLOUD                              ***
+  ! ***    ALPHA AND BETA ARE PARAMETERS THAT CONTROL THE RATE OF    ***
+  ! ***                 APPROACH TO QUASI-EQUILIBRIUM                ***
+  ! ***    (THEIR STANDARD VALUES ARE 1.0 AND 0.96, RESPECTIVELY)    ***
+  ! ***           (BETA MUST BE LESS THAN OR EQUAL TO 1)             ***
+  ! ***    DTCRIT IS THE CRITICAL BUOYANCY (K) USED TO ADJUST THE    ***
+  ! ***                 APPROACH TO QUASI-EQUILIBRIUM                ***
+  ! ***                     IT MUST BE LESS THAN 0                   ***
+
+  pbcrit = 150.0
+  ptcrit = 500.0
+  sigd = 0.01
+  spfac = 0.15
+  ! sb:
+  ! EPMAX=0.993 ! precip efficiency less than unity
+  ! EPMAX=1. ! precip efficiency less than unity
+
+  ! jyg
+  ! CC      BETA=0.96
+  ! Beta is now expressed as a function of the characteristic time
+  ! of the convective process.
+  ! CC        Old value : TAU = 15000.   !(for dtime = 600.s)
+  ! CC        Other value (inducing little change) :TAU = 8000.
+  tau = 8000.
+  beta = 1. - dtime/tau
+  ! jyg
+  ! CC      ALPHA=1.0
+  alpha = 1.5E-3*dtime/tau
+  ! Increase alpha in order to compensate W decrease
+  alpha = alpha*1.5
+
+  ! jyg (voir CONVECT 3)
+  ! CC      DTCRIT=-0.2
+  dtcrit = -2.
+  ! gf&jyg
+  ! CC     DT pour l'overshoot.
+  dtovsh = -0.2
+
+
+  ! ***        INCREMENT THE COUNTER       ***
+
+  sig(nd) = sig(nd) + 1.0
+  sig(nd) = amin1(sig(nd), 12.1)
+
+  ! ***    IF NOPT IS AN INTEGER OTHER THAN 0, CONVECT     ***
+  ! ***     RETURNS ARRAYS T AND R THAT MAY HAVE BEEN      ***
+  ! ***  ALTERED BY DRY ADIABATIC ADJUSTMENT; OTHERWISE    ***
+  ! ***        THE RETURNED ARRAYS ARE UNALTERED.          ***
+
+  nopt = 0
+  ! !      NOPT=1 ! sbl
+
+  ! ***            PERFORM DRY ADIABATIC ADJUSTMENT            ***
+
+  ! ***  DO NOT BYPASS THIS EVEN IF THE CALLING PROGRAM HAS A  ***
+  ! ***                BOUNDARY LAYER SCHEME !!!               ***
+
+  IF (ok_adj) THEN ! added sbl
+
+    DO i = nl - 1, 1, -1
+      jn = 0
+      DO j = i + 1, nl
+        IF (th(j)<th(i)) jn = j
+      END DO
+      IF (jn==0) GO TO 30
+      ahm = 0.0
+      rm = 0.0
+      um = 0.0
+      vm = 0.0
+      DO k = 1, ntra
+        tratm(k) = 0.0
+      END DO
+      DO j = i, jn
+        ahm = ahm + (cpd*(1.-rr(j))+rr(j)*cpv)*t(j)*(ph(j)-ph(j+1))
+        rm = rm + rr(j)*(ph(j)-ph(j+1))
+        um = um + u(j)*(ph(j)-ph(j+1))
+        vm = vm + v(j)*(ph(j)-ph(j+1))
+        DO k = 1, ntra
+          tratm(k) = tratm(k) + tra(j, k)*(ph(j)-ph(j+1))
+        END DO
+      END DO
+      dphinv = 1./(ph(i)-ph(jn+1))
+      rm = rm*dphinv
+      um = um*dphinv
+      vm = vm*dphinv
+      DO k = 1, ntra
+        tratm(k) = tratm(k)*dphinv
+      END DO
+      a2 = 0.0
+      DO j = i, jn
+        rr(j) = rm
+        u(j) = um
+        v(j) = vm
+        DO k = 1, ntra
+          tra(j, k) = tratm(k)
+        END DO
+        rdcp = (rd*(1.-rr(j))+rr(j)*rv)/(cpd*(1.-rr(j))+rr(j)*cpv)
+        x = (0.001*p(j))**rdcp
+        t(j) = x
+        a2 = a2 + (cpd*(1.-rr(j))+rr(j)*cpv)*x*(ph(j)-ph(j+1))
+      END DO
+      DO j = i, jn
+        th(j) = ahm/a2
+        t(j) = t(j)*th(j)
+      END DO
+30  END DO
+
+  END IF ! added sbl
+
+  ! ***   RESET INPUT ARRAYS IF ok_adj 0   ***
+
+  IF (ok_adj) THEN
+    DO i = 1, nd
+
+      ft2(i) = (t(i)-t1(i))/delt ! sbl
+      fr2(i) = (rr(i)-r1(i))/delt ! sbl
+      fu2(i) = (u(i)-u1(i))/delt ! sbl
+      fv2(i) = (v(i)-v1(i))/delt ! sbl
+
+      ! !            T1(I)=T(I)      ! commente sbl
+      ! !            R1(I)=RR(I)     ! commente sbl
+    END DO
+  END IF
+
+  ! *** CALCULATE ARRAYS OF GEOPOTENTIAL, HEAT CAPACITY AND STATIC ENERGY
+
+  gz(1) = 0.0
+  cpn(1) = cpd*(1.-rr(1)) + rr(1)*cpv
+  h(1) = t(1)*cpn(1)
+  DO i = 2, nl
+    tvx = t(i)*(1.+rr(i)/eps-rr(i))
+    tvy = t(i-1)*(1.+rr(i-1)/eps-rr(i-1))
+    gz(i) = gz(i-1) + 0.5*rd*(tvx+tvy)*(p(i-1)-p(i))/ph(i)
+    cpn(i) = cpd*(1.-rr(i)) + cpv*rr(i)
+    h(i) = t(i)*cpn(i) + gz(i)
+  END DO
+
+  ! ***  CALCULATE LIFTED CONDENSATION LEVEL OF AIR AT LOWEST MODEL LEVEL ***
+  ! ***       (WITHIN 0.2% OF FORMULA OF BOLTON, MON. WEA. REV.,1980)     ***
+
+  IF (t(1)<250.0 .OR. rr(1)<=0.0) THEN
+    iflag = 0
+    ! sb3d         print*,'je suis passe par 366'
+    RETURN
+  END IF
+
+  ! jyg1 Utilisation de la subroutine CLIFT
+  ! C      RH=RR(1)/RS(1)
+  ! C      CHI=T(1)/(1669.0-122.0*RH-T(1))
+  ! C      PLCL=P(1)*(RH**CHI)
+  CALL clift(p(1), t(1), rr(1), rs(1), plcl, dplcldt, dplcldr)
+  ! jyg2
+  ! sb3d      PRINT *,' em_plcl,p1,t1,r1,rs1,rh '
+  ! sb3d     $        ,PLCL,P(1),T(1),RR(1),RS(1),RH
+
+  IF (plcl<200.0 .OR. plcl>=2000.0) THEN
+    iflag = 2
+    RETURN
+  END IF
+  ! jyg1
+  ! Essais de modification de ICB
+
+  ! ***  CALCULATE FIRST LEVEL ABOVE LCL (=ICB)  ***
+
+  ! C      ICB=NL-1
+  ! C      DO 50 I=2,NL-1
+  ! C         IF(P(I).LT.PLCL)THEN
+  ! C            ICB=MIN(ICB,I)   ! ICB sup ou egal a 2
+  ! C         END IF
+  ! C   50 CONTINUE
+  ! C      IF(ICB.EQ.(NL-1))THEN
+  ! C         IFLAG=3
+  ! C         RETURN
+  ! C      END IF
+
+  ! *** CALCULATE LAYER CONTAINING LCL (=ICB)   ***
+
+  icb = nl - 1
+  ! sb      DO 50 I=2,NL-1
+  DO i = 3, nl - 1 ! modif sb pour que ICB soit sup/egal a 2
+    ! la modification consiste a comparer PLCL a PH et non a P:
+    ! ICB est defini par :  PH(ICB)<PLCL<PH(ICB-!)
+    IF (ph(i)<plcl) THEN
+      icb = min(icb, i)
+    END IF
+  END DO
+  IF (icb==(nl-1)) THEN
+    iflag = 3
+    RETURN
+  END IF
+  icb = icb - 1 ! ICB sup ou egal a 2
+  ! jyg2
+
+
+
+  ! *** SUBROUTINE TLIFT CALCULATES PART OF THE LIFTED PARCEL VIRTUAL
+  ! ***
+  ! ***  TEMPERATURE, THE ACTUAL TEMPERATURE AND THE ADIABATIC
+  ! ***
+  ! ***                   LIQUID WATER CONTENT
+  ! ***
+
+
+  ! jyg1
+  ! make sure that "Cloud base" seen by TLIFT is actually the
+  ! fisrt level where adiabatic ascent is saturated
+  IF (plcl>p(icb)) THEN
+    ! sb        CALL TLIFT(P,T,RR,RS,GZ,PLCL,ICB,TVP,TP,CLW,ND,NL)
+    CALL tlift(p, t, rr, rs, gz, plcl, icb, nk, tvp, tp, clw, nd, nl, &
+      dtvpdt1, dtvpdq1)
+  ELSE
+    ! sb        CALL TLIFT(P,T,RR,RS,GZ,PLCL,ICB+1,TVP,TP,CLW,ND,NL)
+    CALL tlift(p, t, rr, rs, gz, plcl, icb+1, nk, tvp, tp, clw, nd, nl, &
+      dtvpdt1, dtvpdq1)
+  END IF
+  ! jyg2
+
+  ! *****************************************************************************
+  ! ***     SORTIE DE LA TEMPERATURE DE L ASCENDANCE NON DILUE
+  ! *****************************************************************************
+  DO i = 1, nd
+    tps(i) = tp(i)
+  END DO
+
+
+  ! *****************************************************************************
+
+
+  ! ***  SET THE PRECIPITATION EFFICIENCIES AND THE FRACTION OF   ***
+  ! ***          PRECIPITATION FALLING OUTSIDE OF CLOUD           ***
+  ! ***      THESE MAY BE FUNCTIONS OF TP(I), P(I) AND CLW(I)     ***
+
+  DO i = 1, nl
+    pden = ptcrit - pbcrit
+
+    ! jyg
+    ! cc         EP(I)=(P(ICB)-P(I)-PBCRIT)/PDEN
+    ! sb         EP(I)=(PLCL-P(I)-PBCRIT)/PDEN
+    ep(i) = (plcl-p(i)-pbcrit)/pden*epmax ! sb
+
+    ep(i) = amax1(ep(i), 0.0)
+    ! sb         EP(I)=AMIN1(EP(I),1.0)
+    ep(i) = amin1(ep(i), epmax) ! sb
+    sigp(i) = spfac
+
+    ! ***       CALCULATE VIRTUAL TEMPERATURE AND LIFTED PARCEL     ***
+    ! ***                    VIRTUAL TEMPERATURE                    ***
+
+    tv(i) = t(i)*(1.+rr(i)/eps-rr(i))
+    ! cd1
+    ! . Keep all liquid water in lifted parcel (-> adiabatic CAPE)
+
+    ! cc    TVP(I)=TVP(I)-TP(I)*(RR(1)-EP(I)*CLW(I))
+    ! !!! sb         TVP(I)=TVP(I)-TP(I)*RR(1) ! calcule dans tlift
+    ! cd2
+
+    ! ***       Calculate first estimate of buoyancy
+
+    buoy(i) = tvp(i) - tv(i)
+  END DO
+
+  ! ***   Set Cloud Base Buoyancy at (Plcl+DPbase) level buoyancy
+
+  dpbase = -40. !That is 400m above LCL
+  pbase = plcl + dpbase
+  tvpbase = tvp(icb)*(pbase-p(icb+1))/(p(icb)-p(icb+1)) + &
+    tvp(icb+1)*(p(icb)-pbase)/(p(icb)-p(icb+1))
+  tvbase = tv(icb)*(pbase-p(icb+1))/(p(icb)-p(icb+1)) + &
+    tv(icb+1)*(p(icb)-pbase)/(p(icb)-p(icb+1))
+
+  ! test sb:
+  ! @      write(*,*) '++++++++++++++++++++++++++++++++++++++++'
+  ! @      write(*,*) 'plcl,dpbas,tvpbas,tvbas,tvp(icb),tvp(icb1)
+  ! @     :             ,tv(icb),tv(icb1)'
+  ! @      write(*,*) plcl,dpbase,tvpbase,tvbase,tvp(icb)
+  ! @     L          ,tvp(icb+1),tv(icb),tv(icb+1)
+  ! @      write(*,*) '++++++++++++++++++++++++++++++++++++++++'
+  ! fin test sb
+  buoybase = tvpbase - tvbase
+
+  ! C       Set buoyancy = BUOYBASE for all levels below BASE.
+  ! C       For safety, set : BUOY(ICB) = BUOYBASE
+  DO i = icb, nl
+    IF (p(i)>=pbase) THEN
+      buoy(i) = buoybase
+    END IF
+  END DO
+  buoy(icb) = buoybase
+
+  ! sb3d      print *,'buoybase,tvp_tv,tvpbase,tvbase,pbase,plcl'
+  ! sb3d     $,        buoybase,tvp(icb)-tv(icb),tvpbase,tvbase,pbase,plcl
+  ! sb3d      print *,'TVP ',(tvp(i),i=1,nl)
+  ! sb3d      print *,'TV ',(tv(i),i=1,nl)
+  ! sb3d      print *, 'P ',(p(i),i=1,nl)
+  ! sb3d      print *,'ICB ',icb
+  ! test sb:
+  ! @      write(*,*) '@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@'
+  ! @      write(*,*) 'icb,icbs,inb,buoybase:'
+  ! @      write(*,*) icb,icb+1,inb,buoybase
+  ! @      write(*,*) 'k,tvp,tv,tp,buoy,ep: '
+  ! @      do k=1,nl
+  ! @      write(*,*) k,tvp(k),tv(k),tp(k),buoy(k),ep(k)
+  ! @      enddo
+  ! @      write(*,*) '@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@'
+  ! fin test sb
+
+
+
+  ! ***   MAKE SURE THAT COLUMN IS DRY ADIABATIC BETWEEN THE SURFACE  ***
+  ! ***    AND CLOUD BASE, AND THAT LIFTED AIR IS POSITIVELY BUOYANT  ***
+  ! ***                         AT CLOUD BASE                         ***
+  ! ***       IF NOT, RETURN TO CALLING PROGRAM AFTER RESETTING       ***
+  ! ***                        SIG(I) AND W0(I)                       ***
+
+  ! jyg
+  ! CC      TDIF=TVP(ICB)-TV(ICB)
+  tdif = buoy(icb)
+  ath1 = th(1)
+  ! jyg
+  ! CC      ATH=TH(ICB-1)-1.0
+  ath = th(icb-1) - 5.0
+  ! ATH=0.                          ! ajout sb
+  ! IF (ICB.GT.1) ATH=TH(ICB-1)-5.0 ! modif sb
+  IF (tdif<dtcrit .OR. ath>ath1) THEN
+    DO i = 1, nl
+      sig(i) = beta*sig(i) - 2.*alpha*tdif*tdif
+      sig(i) = amax1(sig(i), 0.0)
+      w0(i) = beta*w0(i)
+    END DO
+    iflag = 0
+    RETURN
+  END IF
+
+
+
+  ! ***  IF THIS POINT IS REACHED, MOIST CONVECTIVE ADJUSTMENT IS NECESSARY
+  ! ***
+  ! ***        NOW INITIALIZE VARIOUS ARRAYS USED IN THE COMPUTATIONS
+  ! ***
+
+  DO i = 1, nl
+    hp(i) = h(i)
+    wt(i) = 0.001
+    rp(i) = rr(i)
+    up(i) = u(i)
+    vp(i) = v(i)
+    DO j = 1, ntra
+      trap(i, j) = tra(i, j)
+    END DO
+    nent(i) = 0
+    water(i) = 0.0
+    evap(i) = 0.0
+    b(i) = 0.0
+    mp(i) = 0.0
+    m(i) = 0.0
+    lv(i) = alv0 - cpvmcl*(t(i)-273.15)
+    lvcp(i) = lv(i)/cpn(i)
+    DO j = 1, nl
+      qent(i, j) = rr(j)
+      elij(i, j) = 0.0
+      ment(i, j) = 0.0
+      sij(i, j) = 0.0
+      uent(i, j) = u(j)
+      vent(i, j) = v(j)
+      DO k = 1, ntra
+        traent(i, j, k) = tra(j, k)
+      END DO
+    END DO
+  END DO
+
+  delti = 1.0/delt
+
+  ! ***  FIND THE FIRST MODEL LEVEL (INB) ABOVE THE PARCEL'S       ***
+  ! ***                LEVEL OF NEUTRAL BUOYANCY                   ***
+
+  inb = nl - 1
+  DO i = icb, nl - 1
+    ! jyg
+    ! CC         IF((TVP(I)-TV(I)).LT.DTCRIT)THEN
+    IF (buoy(i)<dtovsh) THEN
+      inb = min(inb, i)
+    END IF
+  END DO
+
+
+
+
+
+  ! ***          RESET SIG(I) AND W0(I) FOR I>INB AND I<ICB       ***
+
+  IF (inb<(nl-1)) THEN
+    DO i = inb + 1, nl - 1
+      ! jyg
+      ! CC            SIG(I)=BETA*SIG(I)-2.0E-4*ALPHA*(TV(INB)-TVP(INB))*
+      ! CC     1              ABS(TV(INB)-TVP(INB))
+      sig(i) = beta*sig(i) + 2.*alpha*buoy(inb)*abs(buoy(inb))
+      sig(i) = amax1(sig(i), 0.0)
+      w0(i) = beta*w0(i)
+    END DO
+  END IF
+  DO i = 1, icb
+    ! jyg
+    ! CC         SIG(I)=BETA*SIG(I)-2.0E-4*ALPHA*(TV(ICB)-TVP(ICB))*
+    ! CC     1           (TV(ICB)-TVP(ICB))
+    sig(i) = beta*sig(i) - 2.*alpha*buoy(icb)*buoy(icb)
+    sig(i) = amax1(sig(i), 0.0)
+    w0(i) = beta*w0(i)
+  END DO
+
+  ! ***    RESET FRACTIONAL AREAS OF UPDRAFTS AND W0 AT INITIAL TIME    ***
+  ! ***           AND AFTER 10 TIME STEPS OF NO CONVECTION              ***
+
+
+  IF (sig(nd)<1.5 .OR. sig(nd)>12.0) THEN
+    DO i = 1, nl - 1
+      sig(i) = 0.0
+      w0(i) = 0.0
+    END DO
+  END IF
+
+  ! ***   CALCULATE LIQUID WATER STATIC ENERGY OF LIFTED PARCEL   ***
+
+  DO i = icb, inb
+    hp(i) = h(1) + (lv(i)+(cpd-cpv)*t(i))*ep(i)*clw(i)
+  END DO
+
+  ! ***  CALCULATE CONVECTIVE AVAILABLE POTENTIAL ENERGY (CAPE),  ***
+  ! ***     VERTICAL VELOCITY (W), FRACTIONAL AREA COVERED BY     ***
+  ! ***     UNDILUTE UPDRAFT (SIG),  AND UPDRAFT MASS FLUX (M)    ***
+
+  cape = 0.0
+
+  DO i = icb + 1, inb
+    ! jyg1
+    ! CC         CAPE=CAPE+RD*(TVP(I-1)-TV(I-1))*(PH(I-1)-PH(I))/P(I-1)
+    ! CC         DCAPE=RD*BUOY(I-1)*(PH(I-1)-PH(I))/P(I-1)
+    ! CC         DLNP=(PH(I-1)-PH(I))/P(I-1)
+    ! The interval on which CAPE is computed starts at PBASE :
+    deltap = min(pbase, ph(i-1)) - min(pbase, ph(i))
+    cape = cape + rd*buoy(i-1)*deltap/p(i-1)
+    dcape = rd*buoy(i-1)*deltap/p(i-1)
+    dlnp = deltap/p(i-1)
+    ! jyg2
+    ! sb3d         print *,'buoy,dlnp,dcape,cape',buoy(i-1),dlnp,dcape,cape
+    ! test sb:
+    ! @       write(*,*) '############################################'
+    ! @         write(*,*) 'cape,rrd,buoy,deltap,p,pbase,ph:'
+    ! @     :     ,cape,rd,buoy(i-1),deltap,p(i-1),pbase,ph(i)
+    ! @       write(*,*) '############################################'
+
+    ! fin test sb
+    cape = amax1(0.0, cape)
+
+    sigold = sig(i)
+    dtmin = 100.0
+    DO j = icb, i - 1
+      ! jyg
+      ! CC            DTMIN=AMIN1(DTMIN,(TVP(J)-TV(J)))
+      dtmin = amin1(dtmin, buoy(j))
+    END DO
+    ! sb3d     print *, 'DTMIN, BETA, ALPHA, SIG = ',DTMIN,BETA,ALPHA,SIG(I)
+    sig(i) = beta*sig(i) + alpha*dtmin*abs(dtmin)
+    sig(i) = amax1(sig(i), 0.0)
+    sig(i) = amin1(sig(i), 0.01)
+    fac = amin1(((dtcrit-dtmin)/dtcrit), 1.0)
+    ! jyg
+    ! C    Essais de reduction de la vitesse
+    ! C         FAC = FAC*.5
+
+    w = (1.-beta)*fac*sqrt(cape) + beta*w0(i)
+    amu = 0.5*(sig(i)+sigold)*w
+    m(i) = amu*0.007*p(i)*(ph(i)-ph(i+1))/tv(i)
+
+    ! --------- test sb:
+    ! write(*,*) '############################################'
+    ! write(*,*) 'k,amu,buoy(k-1),deltap,w,beta,fac,cape,w0(k)'
+    ! write(*,*) i,amu,buoy(i-1),deltap
+    ! :           ,w,beta,fac,cape,w0(i)
+    ! write(*,*) '############################################'
+    ! ---------
+
+    w0(i) = w
+  END DO
+  w0(icb) = 0.5*w0(icb+1)
+  m(icb) = 0.5*m(icb+1)*(ph(icb)-ph(icb+1))/(ph(icb+1)-ph(icb+2))
+  sig(icb) = sig(icb+1)
+  sig(icb-1) = sig(icb)
+  ! jyg1
+  ! sb3d      print *, 'Cloud base, c. top, CAPE',ICB,INB,cape
+  ! sb3d      print *, 'SIG ',(sig(i),i=1,inb)
+  ! sb3d      print *, 'W ',(w0(i),i=1,inb)
+  ! sb3d      print *, 'M ',(m(i), i=1,inb)
+  ! sb3d      print *, 'Dt1 ',(tvp(i)-tv(i),i=1,inb)
+  ! sb3d      print *, 'Dt_vrai ',(buoy(i),i=1,inb)
+  ! jyg2
+
+  ! ***  CALCULATE ENTRAINED AIR MASS FLUX (MENT), TOTAL WATER MIXING  ***
+  ! ***     RATIO (QENT), TOTAL CONDENSED WATER (ELIJ), AND MIXING     ***
+  ! ***                        FRACTION (SIJ)                          ***
+
+
+
+  DO i = icb, inb
+    rti = rr(1) - ep(i)*clw(i)
+    DO j = icb - 1, inb
+      bf2 = 1. + lv(j)*lv(j)*rs(j)/(rv*t(j)*t(j)*cpd)
+      anum = h(j) - hp(i) + (cpv-cpd)*t(j)*(rti-rr(j))
+      denom = h(i) - hp(i) + (cpd-cpv)*(rr(i)-rti)*t(j)
+      dei = denom
+      IF (abs(dei)<0.01) dei = 0.01
+      sij(i, j) = anum/dei
+      sij(i, i) = 1.0
+      altem = sij(i, j)*rr(i) + (1.-sij(i,j))*rti - rs(j)
+      altem = altem/bf2
+      cwat = clw(j)*(1.-ep(j))
+      stemp = sij(i, j)
+      IF ((stemp<0.0 .OR. stemp>1.0 .OR. altem>cwat) .AND. j>i) THEN
+        anum = anum - lv(j)*(rti-rs(j)-cwat*bf2)
+        denom = denom + lv(j)*(rr(i)-rti)
+        IF (abs(denom)<0.01) denom = 0.01
+        sij(i, j) = anum/denom
+        altem = sij(i, j)*rr(i) + (1.-sij(i,j))*rti - rs(j)
+        altem = altem - (bf2-1.)*cwat
+      END IF
+
+
+      IF (sij(i,j)>0.0 .AND. sij(i,j)<0.95) THEN
+        qent(i, j) = sij(i, j)*rr(i) + (1.-sij(i,j))*rti
+        uent(i, j) = sij(i, j)*u(i) + (1.-sij(i,j))*u(nk)
+        vent(i, j) = sij(i, j)*v(i) + (1.-sij(i,j))*v(nk)
+        DO k = 1, ntra
+          traent(i, j, k) = sij(i, j)*tra(i, k) + (1.-sij(i,j))*tra(nk, k)
+        END DO
+        elij(i, j) = altem
+        elij(i, j) = amax1(0.0, elij(i,j))
+        ment(i, j) = m(i)/(1.-sij(i,j))
+        nent(i) = nent(i) + 1
+      END IF
+      sij(i, j) = amax1(0.0, sij(i,j))
+      sij(i, j) = amin1(1.0, sij(i,j))
+    END DO
+
+    ! ***   IF NO AIR CAN ENTRAIN AT LEVEL I ASSUME THAT UPDRAFT DETRAINS
+    ! ***
+    ! ***   AT THAT LEVEL AND CALCULATE DETRAINED AIR FLUX AND PROPERTIES
+    ! ***
+
+    IF (nent(i)==0) THEN
+      ment(i, i) = m(i)
+      qent(i, i) = rr(nk) - ep(i)*clw(i)
+      uent(i, i) = u(nk)
+      vent(i, i) = v(nk)
+      DO j = 1, ntra
+        traent(i, i, j) = tra(nk, j)
+      END DO
+      elij(i, i) = clw(i)
+      sij(i, i) = 1.0
+    END IF
+
+    DO j = icb - 1, inb
+      sigij(i, j) = sij(i, j)
+    END DO
+
+  END DO
+
+  ! ***  NORMALIZE ENTRAINED AIR MASS FLUXES TO REPRESENT EQUAL  ***
+  ! ***              PROBABILITIES OF MIXING                     ***
+
+
+  DO i = icb, inb
+    IF (nent(i)/=0) THEN
+      qp = rr(1) - ep(i)*clw(i)
+      anum = h(i) - hp(i) - lv(i)*(qp-rs(i)) + (cpv-cpd)*t(i)*(qp-rr(i))
+      denom = h(i) - hp(i) + lv(i)*(rr(i)-qp) + (cpd-cpv)*t(i)*(rr(i)-qp)
+      IF (abs(denom)<0.01) denom = 0.01
+      scrit = anum/denom
+      alt = qp - rs(i) + scrit*(rr(i)-qp)
+      IF (scrit<=0.0 .OR. alt<=0.0) scrit = 1.0
+      smax = 0.0
+      asij = 0.0
+      DO j = inb, icb - 1, -1
+        IF (sij(i,j)>1.0E-16 .AND. sij(i,j)<0.95) THEN
+          wgh = 1.0
+          IF (j>i) THEN
+            sjmax = amax1(sij(i,j+1), smax)
+            sjmax = amin1(sjmax, scrit)
+            smax = amax1(sij(i,j), smax)
+            sjmin = amax1(sij(i,j-1), smax)
+            sjmin = amin1(sjmin, scrit)
+            IF (sij(i,j)<(smax-1.0E-16)) wgh = 0.0
+            smid = amin1(sij(i,j), scrit)
+          ELSE
+            sjmax = amax1(sij(i,j+1), scrit)
+            smid = amax1(sij(i,j), scrit)
+            sjmin = 0.0
+            IF (j>1) sjmin = sij(i, j-1)
+            sjmin = amax1(sjmin, scrit)
+          END IF
+          delp = abs(sjmax-smid)
+          delm = abs(sjmin-smid)
+          asij = asij + wgh*(delp+delm)
+          ment(i, j) = ment(i, j)*(delp+delm)*wgh
+        END IF
+      END DO
+      asij = amax1(1.0E-16, asij)
+      asij = 1.0/asij
+      DO j = icb - 1, inb
+        ment(i, j) = ment(i, j)*asij
+      END DO
+      asum = 0.0
+      bsum = 0.0
+      DO j = icb - 1, inb
+        asum = asum + ment(i, j)
+        ment(i, j) = ment(i, j)*sig(j)
+        bsum = bsum + ment(i, j)
+      END DO
+      bsum = amax1(bsum, 1.0E-16)
+      bsum = 1.0/bsum
+      DO j = icb - 1, inb
+        ment(i, j) = ment(i, j)*asum*bsum
+      END DO
+      csum = 0.0
+      DO j = icb - 1, inb
+        csum = csum + ment(i, j)
+      END DO
+
+      IF (csum<m(i)) THEN
+        nent(i) = 0
+        ment(i, i) = m(i)
+        qent(i, i) = rr(1) - ep(i)*clw(i)
+        uent(i, i) = u(nk)
+        vent(i, i) = v(nk)
+        DO j = 1, ntra
+          traent(i, i, j) = tra(nk, j)
+        END DO
+        elij(i, i) = clw(i)
+        sij(i, i) = 1.0
+      END IF
+    END IF
+  END DO
+
+
+
+  ! **************************************************************
+  ! *       CALCUL DES MENTS(I,J) ET DES QENTS(I,J)
+  ! *************************************************************
+
+  DO im = 1, nd
+    DO jm = 1, nd
+
+      qents(im, jm) = qent(im, jm)
+      ments(im, jm) = ment(im, jm)
+    END DO
+  END DO
+
+  ! **********************************************************
+  ! --- test sb:
+  ! @       write(*,*) '^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^'
+  ! @       write(*,*) 'inb,m(inb),ment(inb,inb),sigij(inb,inb):'
+  ! @       write(*,*) inb,m(inb),ment(inb,inb),sigij(inb,inb)
+  ! @       write(*,*) '^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^'
+  ! ---
+
+
+
+
+
+  ! ***  CHECK WHETHER EP(INB)=0, IF SO, SKIP PRECIPITATING    ***
+  ! ***             DOWNDRAFT CALCULATION                      ***
+
+  IF (ep(inb)<0.0001) GO TO 405
+
+  ! ***  INTEGRATE LIQUID WATER EQUATION TO FIND CONDENSED WATER   ***
+  ! ***                AND CONDENSED WATER FLUX                    ***
+
+  wflux = 0.0
+  tinv = 1./3.
+
+  ! ***                    BEGIN DOWNDRAFT LOOP                    ***
+
+  DO i = inb, 1, -1
+
+    ! ***              CALCULATE DETRAINED PRECIPITATION             ***
+
+
+
+    wdtrain = 10.0*ep(i)*m(i)*clw(i)
+    IF (i>1) THEN
+      DO j = 1, i - 1
+        awat = elij(j, i) - (1.-ep(i))*clw(i)
+        awat = amax1(awat, 0.0)
+        wdtrain = wdtrain + 10.0*awat*ment(j, i)
+      END DO
+    END IF
+
+    ! ***    FIND RAIN WATER AND EVAPORATION USING PROVISIONAL   ***
+    ! ***              ESTIMATES OF RP(I)AND RP(I-1)             ***
+
+
+
+    wt(i) = 45.0
+    IF (i<inb) THEN
+      rp(i) = rp(i+1) + (cpd*(t(i+1)-t(i))+gz(i+1)-gz(i))/lv(i)
+      rp(i) = 0.5*(rp(i)+rr(i))
+    END IF
+    rp(i) = amax1(rp(i), 0.0)
+    rp(i) = amin1(rp(i), rs(i))
+    rp(inb) = rr(inb)
+    IF (i==1) THEN
+      afac = p(1)*(rs(1)-rp(1))/(1.0E4+2000.0*p(1)*rs(1))
+    ELSE
+      rp(i-1) = rp(i) + (cpd*(t(i)-t(i-1))+gz(i)-gz(i-1))/lv(i)
+      rp(i-1) = 0.5*(rp(i-1)+rr(i-1))
+      rp(i-1) = amin1(rp(i-1), rs(i-1))
+      rp(i-1) = amax1(rp(i-1), 0.0)
+      afac1 = p(i)*(rs(i)-rp(i))/(1.0E4+2000.0*p(i)*rs(i))
+      afac2 = p(i-1)*(rs(i-1)-rp(i-1))/(1.0E4+2000.0*p(i-1)*rs(i-1))
+      afac = 0.5*(afac1+afac2)
+    END IF
+    IF (i==inb) afac = 0.0
+    afac = amax1(afac, 0.0)
+    bfac = 1./(sigd*wt(i))
+
+    ! jyg1
+    ! CC        SIGT=1.0
+    ! CC        IF(I.GE.ICB)SIGT=SIGP(I)
+    ! Prise en compte de la variation progressive de SIGT dans
+    ! les couches ICB et ICB-1:
+    ! Pour PLCL<PH(I+1), PR1=0 & PR2=1
+    ! Pour PLCL>PH(I),   PR1=1 & PR2=0
+    ! Pour PH(I+1)<PLCL<PH(I), PR1 est la proportion a cheval
+    ! sur le nuage, et PR2 est la proportion sous la base du
+    ! nuage.
+    pr1 = (plcl-ph(i+1))/(ph(i)-ph(i+1))
+    pr1 = max(0., min(1.,pr1))
+    pr2 = (ph(i)-plcl)/(ph(i)-ph(i+1))
+    pr2 = max(0., min(1.,pr2))
+    sigt = sigp(i)*pr1 + pr2
+    ! sb3d         print *,'i,sigt,pr1,pr2', i,sigt,pr1,pr2
+    ! jyg2
+
+    b6 = bfac*50.*sigd*(ph(i)-ph(i+1))*sigt*afac
+    c6 = water(i+1) + bfac*wdtrain - 50.*sigd*bfac*(ph(i)-ph(i+1))*evap(i+1)
+    IF (c6>0.0) THEN
+      revap = 0.5*(-b6+sqrt(b6*b6+4.*c6))
+      evap(i) = sigt*afac*revap
+      water(i) = revap*revap
+    ELSE
+      evap(i) = -evap(i+1) + 0.02*(wdtrain+sigd*wt(i)*water(i+1))/(sigd*(ph(i &
+        )-ph(i+1)))
+    END IF
+
+
+
+    ! ***  CALCULATE PRECIPITATING DOWNDRAFT MASS FLUX UNDER     ***
+    ! ***              HYDROSTATIC APPROXIMATION                 ***
+
+    IF (i==1) GO TO 360
+    tevap = amax1(0.0, evap(i))
+    delth = amax1(0.001, (th(i)-th(i-1)))
+    mp(i) = 10.*lvcp(i)*sigd*tevap*(p(i-1)-p(i))/delth
+
+    ! ***           IF HYDROSTATIC ASSUMPTION FAILS,             ***
+    ! ***   SOLVE CUBIC DIFFERENCE EQUATION FOR DOWNDRAFT THETA  ***
+    ! ***  AND MASS FLUX FROM TWO SIMULTANEOUS DIFFERENTIAL EQNS ***
+
+    amfac = sigd*sigd*70.0*ph(i)*(p(i-1)-p(i))*(th(i)-th(i-1))/(tv(i)*th(i))
+    amp2 = abs(mp(i+1)*mp(i+1)-mp(i)*mp(i))
+    IF (amp2>(0.1*amfac)) THEN
+      xf = 100.0*sigd*sigd*sigd*(ph(i)-ph(i+1))
+      tf = b(i) - 5.0*(th(i)-th(i-1))*t(i)/(lvcp(i)*sigd*th(i))
+      af = xf*tf + mp(i+1)*mp(i+1)*tinv
+      bf = 2.*(tinv*mp(i+1))**3 + tinv*mp(i+1)*xf*tf + &
+        50.*(p(i-1)-p(i))*xf*tevap
+      fac2 = 1.0
+      IF (bf<0.0) fac2 = -1.0
+      bf = abs(bf)
+      ur = 0.25*bf*bf - af*af*af*tinv*tinv*tinv
+      IF (ur>=0.0) THEN
+        sru = sqrt(ur)
+        fac = 1.0
+        IF ((0.5*bf-sru)<0.0) fac = -1.0
+        mp(i) = mp(i+1)*tinv + (0.5*bf+sru)**tinv + &
+          fac*(abs(0.5*bf-sru))**tinv
+      ELSE
+        d = atan(2.*sqrt(-ur)/(bf+1.0E-28))
+        IF (fac2<0.0) d = 3.14159 - d
+        mp(i) = mp(i+1)*tinv + 2.*sqrt(af*tinv)*cos(d*tinv)
+      END IF
+      mp(i) = amax1(0.0, mp(i))
+      b(i-1) = b(i) + 100.0*(p(i-1)-p(i))*tevap/(mp(i)+sigd*0.1) - &
+        10.0*(th(i)-th(i-1))*t(i)/(lvcp(i)*sigd*th(i))
+      b(i-1) = amax1(b(i-1), 0.0)
+    END IF
+
+
+
+    ! ***         LIMIT MAGNITUDE OF MP(I) TO MEET CFL CONDITION      ***
+
+    ampmax = 2.0*(ph(i)-ph(i+1))*delti
+    amp2 = 2.0*(ph(i-1)-ph(i))*delti
+    ampmax = amin1(ampmax, amp2)
+    mp(i) = amin1(mp(i), ampmax)
+
+    ! ***      FORCE MP TO DECREASE LINEARLY TO ZERO                 ***
+    ! ***       BETWEEN CLOUD BASE AND THE SURFACE                   ***
+
+    IF (p(i)>p(icb)) THEN
+      mp(i) = mp(icb)*(p(1)-p(i))/(p(1)-p(icb))
+    END IF
+360 CONTINUE
+
+    ! ***       FIND MIXING RATIO OF PRECIPITATING DOWNDRAFT     ***
+
+    IF (i==inb) GO TO 400
+    rp(i) = rr(i)
+    IF (mp(i)>mp(i+1)) THEN
+      rp(i) = rp(i+1)*mp(i+1) + rr(i)*(mp(i)-mp(i+1)) + &
+        5.*sigd*(ph(i)-ph(i+1))*(evap(i+1)+evap(i))
+      rp(i) = rp(i)/mp(i)
+      up(i) = up(i+1)*mp(i+1) + u(i)*(mp(i)-mp(i+1))
+      up(i) = up(i)/mp(i)
+      vp(i) = vp(i+1)*mp(i+1) + v(i)*(mp(i)-mp(i+1))
+      vp(i) = vp(i)/mp(i)
+      DO j = 1, ntra
+        trap(i, j) = trap(i+1, j)*mp(i+1) + trap(i, j)*(mp(i)-mp(i+1))
+        trap(i, j) = trap(i, j)/mp(i)
+      END DO
+    ELSE
+      IF (mp(i+1)>1.0E-16) THEN
+        rp(i) = rp(i+1) + 5.0*sigd*(ph(i)-ph(i+1))*(evap(i+1)+evap(i))/mp(i+1 &
+          )
+        up(i) = up(i+1)
+        vp(i) = vp(i+1)
+        DO j = 1, ntra
+          trap(i, j) = trap(i+1, j)
+        END DO
+      END IF
+    END IF
+    rp(i) = amin1(rp(i), rs(i))
+    rp(i) = amax1(rp(i), 0.0)
+400 END DO
+
+  ! ***  CALCULATE SURFACE PRECIPITATION IN MM/DAY     ***
+
+  precip = wt(1)*sigd*water(1)*8640.0
+
+  ! sb  ***  Calculate downdraft velocity scale and surface temperature and
+  ! ***
+  ! sb  ***                    water vapor fluctuations
+  ! ***
+  ! sb		(inspire de convect 4.3)
+
+  ! BETAD=10.0
+  betad = 5.0
+  wd = betad*abs(mp(icb))*0.01*rd*t(icb)/(sigd*p(icb))
+
+405 CONTINUE
+
+  ! ***  CALCULATE TENDENCIES OF LOWEST LEVEL POTENTIAL TEMPERATURE  ***
+  ! ***                      AND MIXING RATIO                        ***
+
+  dpinv = 1.0/(ph(1)-ph(2))
+  am = 0.0
+  DO k = 2, inb
+    am = am + m(k)
+  END DO
+  IF ((0.1*dpinv*am)>=delti) iflag = 4
+  ft(1) = 0.1*dpinv*am*(t(2)-t(1)+(gz(2)-gz(1))/cpn(1))
+  ft(1) = ft(1) - 0.5*lvcp(1)*sigd*(evap(1)+evap(2))
+  ft(1) = ft(1) - 0.09*sigd*mp(2)*t(1)*b(1)*dpinv
+  ft(1) = ft(1) + 0.01*sigd*wt(1)*(cl-cpd)*water(2)*(t(2)-t(1))*dpinv/cpn(1)
+  fr(1) = 0.1*mp(2)*(rp(2)-rr(1))* & ! correction bug conservation eau
+  ! 1    DPINV+SIGD*0.5*(EVAP(1)+EVAP(2))
+    dpinv + sigd*0.5*(evap(1)+evap(2))
+  ! IM cf. SBL
+  ! 1    DPINV+SIGD*EVAP(1)
+  fr(1) = fr(1) + 0.1*am*(rr(2)-rr(1))*dpinv
+  fu(1) = fu(1) + 0.1*dpinv*(mp(2)*(up(2)-u(1))+am*(u(2)-u(1)))
+  fv(1) = fv(1) + 0.1*dpinv*(mp(2)*(vp(2)-v(1))+am*(v(2)-v(1)))
+  DO j = 1, ntra
+    ftra(1, j) = ftra(1, j) + 0.1*dpinv*(mp(2)*(trap(2,j)-tra(1, &
+      j))+am*(tra(2,j)-tra(1,j)))
+  END DO
+  amde = 0.0
+  DO j = 2, inb
+    fr(1) = fr(1) + 0.1*dpinv*ment(j, 1)*(qent(j,1)-rr(1))
+    fu(1) = fu(1) + 0.1*dpinv*ment(j, 1)*(uent(j,1)-u(1))
+    fv(1) = fv(1) + 0.1*dpinv*ment(j, 1)*(vent(j,1)-v(1))
+    DO k = 1, ntra
+      ftra(1, k) = ftra(1, k) + 0.1*dpinv*ment(j, 1)*(traent(j,1,k)-tra(1,k))
+    END DO
+  END DO
+
+  ! ***  CALCULATE TENDENCIES OF POTENTIAL TEMPERATURE AND MIXING RATIO  ***
+  ! ***               AT LEVELS ABOVE THE LOWEST LEVEL                   ***
+
+  ! ***  FIRST FIND THE NET SATURATED UPDRAFT AND DOWNDRAFT MASS FLUXES  ***
+  ! ***                      THROUGH EACH LEVEL                          ***
+
+
+
+  DO i = 2, inb
+    dpinv = 1.0/(ph(i)-ph(i+1))
+    cpinv = 1.0/cpn(i)
+    amp1 = 0.0
+    DO k = i + 1, inb + 1
+      amp1 = amp1 + m(k)
+    END DO
+    DO k = 1, i
+      DO j = i + 1, inb + 1
+        amp1 = amp1 + ment(k, j)
+      END DO
+    END DO
+    IF ((0.1*dpinv*amp1)>=delti) iflag = 4
+    ad = 0.0
+    DO k = 1, i - 1
+      DO j = i, inb
+        ad = ad + ment(j, k)
+      END DO
+    END DO
+    ft(i) = 0.1*dpinv*(amp1*(t(i+1)-t(i)+(gz(i+1)-gz(i))*cpinv)-ad*(t(i)-t(i- &
+      1)+(gz(i)-gz(i-1))*cpinv)) - 0.5*sigd*lvcp(i)*(evap(i)+evap(i+1))
+    rat = cpn(i-1)*cpinv
+    ft(i) = ft(i) - 0.09*sigd*(mp(i+1)*t(i)*b(i)-mp(i)*t(i-1)*rat*b(i-1))* &
+      dpinv
+    ft(i) = ft(i) + 0.1*dpinv*ment(i, i)*(hp(i)-h(i)+t(i)*(cpv-cpd)*(rr(i)- &
+      qent(i,i)))*cpinv
+    ft(i) = ft(i) + 0.01*sigd*wt(i)*(cl-cpd)*water(i+1)*(t(i+1)-t(i))*dpinv* &
+      cpinv
+    fr(i) = 0.1*dpinv*(amp1*(rr(i+1)-rr(i))-ad*(rr(i)-rr(i-1)))
+    fu(i) = fu(i) + 0.1*dpinv*(amp1*(u(i+1)-u(i))-ad*(u(i)-u(i-1)))
+    fv(i) = fv(i) + 0.1*dpinv*(amp1*(v(i+1)-v(i))-ad*(v(i)-v(i-1)))
+    DO k = 1, ntra
+      ftra(i, k) = ftra(i, k) + 0.1*dpinv*(amp1*(tra(i+1,k)-tra(i, &
+        k))-ad*(tra(i,k)-tra(i-1,k)))
+    END DO
+    DO k = 1, i - 1
+      awat = elij(k, i) - (1.-ep(i))*clw(i)
+      awat = amax1(awat, 0.0)
+      fr(i) = fr(i) + 0.1*dpinv*ment(k, i)*(qent(k,i)-awat-rr(i))
+      fu(i) = fu(i) + 0.1*dpinv*ment(k, i)*(uent(k,i)-u(i))
+      fv(i) = fv(i) + 0.1*dpinv*ment(k, i)*(vent(k,i)-v(i))
+      ! (saturated updrafts resulting from mixing)      ! cld
+      qcond(i) = qcond(i) + (elij(k,i)-awat) ! cld
+      nqcond(i) = nqcond(i) + 1. ! cld
+      DO j = 1, ntra
+        ftra(i, j) = ftra(i, j) + 0.1*dpinv*ment(k, i)*(traent(k,i,j)-tra(i,j &
+          ))
+      END DO
+    END DO
+    DO k = i, inb
+      fr(i) = fr(i) + 0.1*dpinv*ment(k, i)*(qent(k,i)-rr(i))
+      fu(i) = fu(i) + 0.1*dpinv*ment(k, i)*(uent(k,i)-u(i))
+      fv(i) = fv(i) + 0.1*dpinv*ment(k, i)*(vent(k,i)-v(i))
+      DO j = 1, ntra
+        ftra(i, j) = ftra(i, j) + 0.1*dpinv*ment(k, i)*(traent(k,i,j)-tra(i,j &
+          ))
+      END DO
+    END DO
+    fr(i) = fr(i) + 0.5*sigd*(evap(i)+evap(i+1)) + 0.1*(mp(i+1)*(rp(i+ &
+      1)-rr(i))-mp(i)*(rp(i)-rr(i-1)))*dpinv
+    fu(i) = fu(i) + 0.1*(mp(i+1)*(up(i+1)-u(i))-mp(i)*(up(i)-u(i-1)))*dpinv
+    fv(i) = fv(i) + 0.1*(mp(i+1)*(vp(i+1)-v(i))-mp(i)*(vp(i)-v(i-1)))*dpinv
+    DO j = 1, ntra
+      ftra(i, j) = ftra(i, j) + 0.1*dpinv*(mp(i+1)*(trap(i+1,j)-tra(i, &
+        j))-mp(i)*(trap(i,j)-trap(i-1,j)))
+    END DO
+    ! (saturated downdrafts resulting from mixing)    ! cld
+    DO k = i + 1, inb ! cld
+      qcond(i) = qcond(i) + elij(k, i) ! cld
+      nqcond(i) = nqcond(i) + 1. ! cld
+    END DO ! cld
+    ! (particular case: no detraining level is found) ! cld
+    IF (nent(i)==0) THEN ! cld
+      qcond(i) = qcond(i) + (1-ep(i))*clw(i) ! cld
+      nqcond(i) = nqcond(i) + 1. ! cld
+    END IF ! cld
+    IF (nqcond(i)/=0.) THEN ! cld
+      qcond(i) = qcond(i)/nqcond(i) ! cld
+    END IF ! cld
+  END DO
+
+
+
+
+  ! ***   MOVE THE DETRAINMENT AT LEVEL INB DOWN TO LEVEL INB-1   ***
+  ! ***        IN SUCH A WAY AS TO PRESERVE THE VERTICALLY        ***
+  ! ***          INTEGRATED ENTHALPY AND WATER TENDENCIES         ***
+
+  ! test sb:
+  ! @      write(*,*) '--------------------------------------------'
+  ! @      write(*,*) 'inb,ft,hp,h,t,rr,qent,ment,water,waterp,wt,mp,b'
+  ! @      write(*,*) inb,ft(inb),hp(inb),h(inb)
+  ! @     :   ,t(inb),rr(inb),qent(inb,inb)
+  ! @     :   ,ment(inb,inb),water(inb)
+  ! @     :   ,water(inb+1),wt(inb),mp(inb),b(inb)
+  ! @      write(*,*) '--------------------------------------------'
+  ! fin test sb:
+
+  ax = 0.1*ment(inb, inb)*(hp(inb)-h(inb)+t(inb)*(cpv-cpd)*(rr(inb)-qent(inb, &
+    inb)))/(cpn(inb)*(ph(inb)-ph(inb+1)))
+  ft(inb) = ft(inb) - ax
+  ft(inb-1) = ft(inb-1) + ax*cpn(inb)*(ph(inb)-ph(inb+1))/(cpn(inb-1)*(ph(inb &
+    -1)-ph(inb)))
+  bx = 0.1*ment(inb, inb)*(qent(inb,inb)-rr(inb))/(ph(inb)-ph(inb+1))
+  fr(inb) = fr(inb) - bx
+  fr(inb-1) = fr(inb-1) + bx*(ph(inb)-ph(inb+1))/(ph(inb-1)-ph(inb))
+  cx = 0.1*ment(inb, inb)*(uent(inb,inb)-u(inb))/(ph(inb)-ph(inb+1))
+  fu(inb) = fu(inb) - cx
+  fu(inb-1) = fu(inb-1) + cx*(ph(inb)-ph(inb+1))/(ph(inb-1)-ph(inb))
+  dx = 0.1*ment(inb, inb)*(vent(inb,inb)-v(inb))/(ph(inb)-ph(inb+1))
+  fv(inb) = fv(inb) - dx
+  fv(inb-1) = fv(inb-1) + dx*(ph(inb)-ph(inb+1))/(ph(inb-1)-ph(inb))
+  DO j = 1, ntra
+    ex = 0.1*ment(inb, inb)*(traent(inb,inb,j)-tra(inb,j))/ &
+      (ph(inb)-ph(inb+1))
+    ftra(inb, j) = ftra(inb, j) - ex
+    ftra(inb-1, j) = ftra(inb-1, j) + ex*(ph(inb)-ph(inb+1))/(ph(inb-1)-ph( &
+      inb))
+  END DO
+
+  ! ***    HOMOGINIZE TENDENCIES BELOW CLOUD BASE    ***
+
+  asum = 0.0
+  bsum = 0.0
+  csum = 0.0
+  dsum = 0.0
+  DO i = 1, icb - 1
+    asum = asum + ft(i)*(ph(i)-ph(i+1))
+    bsum = bsum + fr(i)*(lv(i)+(cl-cpd)*(t(i)-t(1)))*(ph(i)-ph(i+1))
+    csum = csum + (lv(i)+(cl-cpd)*(t(i)-t(1)))*(ph(i)-ph(i+1))
+    dsum = dsum + t(i)*(ph(i)-ph(i+1))/th(i)
+  END DO
+  DO i = 1, icb - 1
+    ft(i) = asum*t(i)/(th(i)*dsum)
+    fr(i) = bsum/csum
+  END DO
+
+  ! ***           RESET COUNTER AND RETURN           ***
+
+  sig(nd) = 2.0
+
+
+  DO i = 1, nd
+    upwd(i) = 0.0
+    dnwd(i) = 0.0
+    ! sb       dnwd0(i) = - mp(i)
+  END DO
+
+  DO i = 1, nl
+    dnwd0(i) = -mp(i)
+  END DO
+  DO i = nl + 1, nd
+    dnwd0(i) = 0.
+  END DO
+
+  DO i = icb, inb
+    upwd(i) = 0.0
+    dnwd(i) = 0.0
+
+    DO k = i, inb
+      up1 = 0.0
+      dn1 = 0.0
+      DO n = 1, i - 1
+        up1 = up1 + ment(n, k)
+        dn1 = dn1 - ment(k, n)
+      END DO
+      upwd(i) = upwd(i) + m(k) + up1
+      dnwd(i) = dnwd(i) + dn1
+    END DO
+  END DO
+
+  ! ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+  ! DETERMINATION DE LA VARIATION DE FLUX ASCENDANT ENTRE
+  ! DEUX NIVEAU NON DILUE Mike
+  ! ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+
+
+  ! sb      do i=1,ND
+  ! sb      Mike(i)=M(i)
+  ! sb      enddo
+
+  DO i = 1, nl
+    mike(i) = m(i)
+  END DO
+  DO i = nl + 1, nd
+    mike(i) = 0.
+  END DO
+
+  DO i = 1, nd
+    ma(i) = 0
+  END DO
+
+  ! sb      do i=1,nd
+  ! sb      do j=i,nd
+  ! sb      Ma(i)=Ma(i)+M(j)
+  ! sb      enddo
+  ! sb      enddo
+
+  DO i = 1, nl
+    DO j = i, nl
+      ma(i) = ma(i) + m(j)
+    END DO
+  END DO
+
+  DO i = nl + 1, nd
+    ma(i) = 0.
+  END DO
+
+  DO i = 1, icb - 1
+    ma(i) = 0
+  END DO
+
+
+
+  ! cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+  ! ICB REPRESENTE DE NIVEAU OU SE TROUVE LA
+  ! BASE DU NUAGE , ET INB LE TOP DU NUAGE
+  ! ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+
+
+  DO i = 1, nd
+    mke(i) = upwd(i) + dnwd(i)
+  END DO
+
+
+  ! *** Diagnose the in-cloud mixing ratio   ***              ! cld
+  ! ***           of condensed water         ***              ! cld
+  ! ! cld
+  DO i = 1, nd ! cld
+    maa(i) = 0.0 ! cld
+    wa(i) = 0.0 ! cld
+    siga(i) = 0.0 ! cld
+  END DO ! cld
+  DO i = nk, inb ! cld
+    DO k = i + 1, inb + 1 ! cld
+      maa(i) = maa(i) + m(k) ! cld
+    END DO ! cld
+  END DO ! cld
+  DO i = icb, inb - 1 ! cld
+    axc(i) = 0. ! cld
+    DO j = icb, i ! cld
+      axc(i) = axc(i) + rd*(tvp(j)-tv(j))*(ph(j)-ph(j+1))/p(j) ! cld
+    END DO ! cld
+    IF (axc(i)>0.0) THEN ! cld
+      wa(i) = sqrt(2.*axc(i)) ! cld
+    END IF ! cld
+  END DO ! cld
+  DO i = 1, nl ! cld
+    IF (wa(i)>0.0) &               ! cld
+      siga(i) = maa(i)/wa(i)*rd*tvp(i)/p(i)/100./deltac ! cld
+    siga(i) = min(siga(i), 1.0) ! cld
+    qcondc(i) = siga(i)*clw(i)*(1.-ep(i)) & ! cld
+      +(1.-siga(i))*qcond(i) ! cld
+  END DO ! cld
+
+
+  ! @$$cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+  ! @$$         call writeg1d(1,klev,ma,'ma  ','ma  ')
+  ! @$$          call writeg1d(1,klev,upwd,'upwd  ','upwd  ')
+  ! @$$          call writeg1d(1,klev,dnwd,'dnwd  ','dnwd  ')
+  ! @$$          call writeg1d(1,klev,dnwd0,'dnwd0  ','dnwd0  ')
+  ! @$$          call writeg1d(1,klev,tvp,'tvp  ','tvp  ')
+  ! @$$          call writeg1d(1,klev,tra(1:klev,3),'tra3  ','tra3  ')
+  ! @$$          call writeg1d(1,klev,tra(1:klev,4),'tra4  ','tra4  ')
+  ! @$$          call writeg1d(1,klev,tra(1:klev,5),'tra5  ','tra5  ')
+  ! @$$          call writeg1d(1,klev,tra(1:klev,6),'tra6  ','tra6  ')
+  ! @$$          call writeg1d(1,klev,tra(1:klev,7),'tra7  ','tra7  ')
+  ! @$$          call writeg1d(1,klev,tra(1:klev,8),'tra8  ','tra8  ')
+  ! @$$          call writeg1d(1,klev,tra(1:klev,9),'tra9  ','tra9  ')
+  ! @$$          call writeg1d(1,klev,tra(1:klev,10),'tra10','tra10')
+  ! @$$          call writeg1d(1,klev,tra(1:klev,11),'tra11','tra11')
+  ! @$$          call writeg1d(1,klev,tra(1:klev,12),'tra12','tra12')
+  ! @$$          call writeg1d(1,klev,tra(1:klev,13),'tra13','tra13')
+  ! @$$          call writeg1d(1,klev,tra(1:klev,14),'tra14','tra14')
+  ! @$$          call writeg1d(1,klev,tra(1:klev,15),'tra15','tra15')
+  ! @$$          call writeg1d(1,klev,tra(1:klev,16),'tra16','tra16')
+  ! @$$          call writeg1d(1,klev,tra(1:klev,17),'tra17','tra17')
+  ! @$$          call writeg1d(1,klev,tra(1:klev,18),'tra18','tra18')
+  ! @$$          call writeg1d(1,klev,tra(1:klev,19),'tra19','tra19')
+  ! @$$          call writeg1d(1,klev,tra(1:klev,20),'tra20','tra20 ')
+  ! @$$          call writeg1d(1,klev,trap(1:klev,1),'trp1','trp1')
+  ! @$$          call writeg1d(1,klev,trap(1:klev,2),'trp2','trp2')
+  ! @$$          call writeg1d(1,klev,trap(1:klev,3),'trp3','trp3')
+  ! @$$          call writeg1d(1,klev,trap(1:klev,4),'trp4','trp4')
+  ! @$$          call writeg1d(1,klev,trap(1:klev,5),'trp5','trp5')
+  ! @$$          call writeg1d(1,klev,trap(1:klev,10),'trp10','trp10')
+  ! @$$          call writeg1d(1,klev,trap(1:klev,12),'trp12','trp12')
+  ! @$$          call writeg1d(1,klev,trap(1:klev,15),'trp15','trp15')
+  ! @$$          call writeg1d(1,klev,trap(1:klev,20),'trp20','trp20')
+  ! @$$          call writeg1d(1,klev,ftra(1:klev,1),'ftr1  ','ftr1  ')
+  ! @$$          call writeg1d(1,klev,ftra(1:klev,2),'ftr2  ','ftr2  ')
+  ! @$$          call writeg1d(1,klev,ftra(1:klev,3),'ftr3  ','ftr3  ')
+  ! @$$          call writeg1d(1,klev,ftra(1:klev,4),'ftr4  ','ftr4  ')
+  ! @$$          call writeg1d(1,klev,ftra(1:klev,5),'ftr5  ','ftr5  ')
+  ! @$$          call writeg1d(1,klev,ftra(1:klev,6),'ftr6  ','ftr6  ')
+  ! @$$          call writeg1d(1,klev,ftra(1:klev,7),'ftr7  ','ftr7  ')
+  ! @$$          call writeg1d(1,klev,ftra(1:klev,8),'ftr8  ','ftr8  ')
+  ! @$$          call writeg1d(1,klev,ftra(1:klev,9),'ftr9  ','ftr9  ')
+  ! @$$          call writeg1d(1,klev,ftra(1:klev,10),'ftr10','ftr10')
+  ! @$$          call writeg1d(1,klev,ftra(1:klev,11),'ftr11','ftr11')
+  ! @$$          call writeg1d(1,klev,ftra(1:klev,12),'ftr12','ftr12')
+  ! @$$          call writeg1d(1,klev,ftra(1:klev,13),'ftr13','ftr13')
+  ! @$$          call writeg1d(1,klev,ftra(1:klev,14),'ftr14','ftr14')
+  ! @$$          call writeg1d(1,klev,ftra(1:klev,15),'ftr15','ftr15')
+  ! @$$          call writeg1d(1,klev,ftra(1:klev,16),'ftr16','ftr16')
+  ! @$$          call writeg1d(1,klev,ftra(1:klev,17),'ftr17','ftr17')
+  ! @$$          call writeg1d(1,klev,ftra(1:klev,18),'ftr18','ftr18')
+  ! @$$          call writeg1d(1,klev,ftra(1:klev,19),'ftr19','ftr19')
+  ! @$$          call writeg1d(1,klev,ftra(1:klev,20),'ftr20','ftr20 ')
+  ! @$$          call writeg1d(1,klev,mp,'mp  ','mp ')
+  ! @$$          call writeg1d(1,klev,Mke,'Mke  ','Mke ')
+
+
+
+  ! cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+
+
+  RETURN
+END SUBROUTINE convect3
+! ---------------------------------------------------------------------------
Index: DZ6/trunk/libf/phylmd/cosp/array_lib.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cosp/array_lib.F90	(revision 5267)
+++ 	(revision )
@@ -1,167 +1,0 @@
-! $Revision: 23 $, $Date: 2011-03-31 15:41:37 +0200 (jeu. 31 mars 2011) $
-! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/quickbeam/array_lib.f90 $
-! ARRAY_LIB: Array procedures for F90
-! Compiled/Modified:
-!   07/01/06  John Haynes (haynes@atmos.colostate.edu)
-!
-! infind (function)
-! lin_interpolate (function)
-  
-  module array_lib
-  implicit none
-
-  contains
-
-! ----------------------------------------------------------------------------
-! function INFIND
-! ----------------------------------------------------------------------------
-  function infind(list,val,sort,dist)
-  use m_mrgrnk
-  implicit none
-!
-! Purpose:
-!   Finds the index of an array that is closest to a value, plus the
-!   difference between the value found and the value specified
-!
-! Inputs:
-!   [list]   an array of sequential values
-!   [val]    a value to locate
-! Optional input:
-!   [sort]   set to 1 if [list] is in unknown/non-sequential order
-!
-! Returns:
-!   index of [list] that is closest to [val]
-!
-! Optional output:
-!   [dist]   set to variable containing [list([result])] - [val]
-!
-! Requires:
-!   mrgrnk library
-!
-! Created:
-!   10/16/03  John Haynes (haynes@atmos.colostate.edu)
-! Modified:
-!   01/31/06  IDL to Fortran 90
- 
-! ----- INPUTS -----
-  real*8, dimension(:), intent(in) :: list
-  real*8, intent(in) :: val  
-  integer, intent(in), optional :: sort
-  
-! ----- OUTPUTS -----
-  integer*4 :: infind
-  real*8, intent(out), optional :: dist
-
-! ----- INTERNAL -----
-  real*8, dimension(size(list)) :: lists
-  integer*4 :: nlist, result, tmp(1), sort_list
-  integer*4, dimension(size(list)) :: mask, idx
-
-  if (present(sort)) then
-    sort_list = sort
-  else
-    sort_list = 0
-  endif  
-
-  nlist = size(list)
-  if (sort_list == 1) then
-    call mrgrnk(list,idx)
-    lists = list(idx)
-  else
-    lists = list
-  endif
-
-  if (val >= lists(nlist)) then
-    result = nlist
-  else if (val <= lists(1)) then
-    result = 1
-  else
-    mask(:) = 0
-    where (lists < val) mask = 1
-      tmp = minloc(mask,1)
-      if (abs(lists(tmp(1)-1)-val) < abs(lists(tmp(1))-val)) then
-        result = tmp(1) - 1
-      else
-        result = tmp(1)
-      endif
-  endif
-  if (present(dist)) dist = lists(result)-val
-  if (sort_list == 1) then
-    infind = idx(result)
-  else
-    infind = result
-  endif
-
-  end function infind
-
-! ----------------------------------------------------------------------------
-! function LIN_INTERPOLATE
-! ----------------------------------------------------------------------------  
-  subroutine lin_interpolate(yarr,xarr,yyarr,xxarr,tol)
-  use m_mrgrnk
-  implicit none
-!
-! Purpose:
-!   linearly interpolate a set of y2 values given a set of y1,x1,x2
-!
-! Inputs:
-!   [yarr]    an array of y1 values
-!   [xarr]    an array of x1 values
-!   [xxarr]   an array of x2 values
-!   [tol]     maximum distance for a match
-!
-! Output:
-!   [yyarr]   interpolated array of y2 values
-!
-! Requires:
-!   mrgrnk library
-!
-! Created:
-!   06/07/06  John Haynes (haynes@atmos.colostate.edu)
-
-! ----- INPUTS -----
-  real*8, dimension(:), intent(in) :: yarr, xarr, xxarr
-  real*8, intent(in) :: tol
-
-! ----- OUTPUTS -----
-  real*8, dimension(size(xxarr)), intent(out) :: yyarr
-
-! ----- INTERNAL -----
-  real*8, dimension(size(xarr)) :: ysort, xsort
-  integer*4, dimension(size(xarr)) :: ist
-  integer*4 :: nx, nxx, i, iloc
-  real*8 :: d, m
-
-  nx = size(xarr)
-  nxx = size(xxarr)
-
-! // xsort, ysort are sorted versions of xarr, yarr  
-  call mrgrnk(xarr,ist)
-  ysort = yarr(ist)
-  xsort = xarr(ist)
-  
-  do i=1,nxx
-    iloc = infind(xsort,xxarr(i),dist=d)
-    if (d > tol) then
-      print *, 'interpolation error'
-      stop
-    endif
-    if (iloc == nx) then
-!     :: set to the last value
-      yyarr(i) = ysort(nx)
-    else
-!     :: is there another closeby value?
-      if (abs(xxarr(i)-xsort(iloc+1)) < 2*tol) then
-!       :: yes, do a linear interpolation      
-        m = (ysort(iloc+1)-ysort(iloc))/(xsort(iloc+1)-xsort(iloc))
-        yyarr(i) = ysort(iloc) + m*(xxarr(i)-xsort(iloc))
-      else
-!       :: no, set to the only nearby value
-        yyarr(i) = ysort(iloc)
-      endif
-    endif
-  enddo
-  
-  end subroutine lin_interpolate
-
-  end module array_lib
Index: /LMDZ6/trunk/libf/phylmd/cosp/array_lib.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cosp/array_lib.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/cosp/array_lib.f90	(revision 5268)
@@ -0,0 +1,167 @@
+! $Revision: 23 $, $Date: 2011-03-31 15:41:37 +0200 (jeu. 31 mars 2011) $
+! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/quickbeam/array_lib.f90 $
+! ARRAY_LIB: Array procedures for F90
+! Compiled/Modified:
+!   07/01/06  John Haynes (haynes@atmos.colostate.edu)
+!
+! infind (function)
+! lin_interpolate (function)
+  
+  module array_lib
+  implicit none
+
+  contains
+
+! ----------------------------------------------------------------------------
+! function INFIND
+! ----------------------------------------------------------------------------
+  function infind(list,val,sort,dist)
+  use m_mrgrnk
+  implicit none
+!
+! Purpose:
+!   Finds the index of an array that is closest to a value, plus the
+!   difference between the value found and the value specified
+!
+! Inputs:
+!   [list]   an array of sequential values
+!   [val]    a value to locate
+! Optional input:
+!   [sort]   set to 1 if [list] is in unknown/non-sequential order
+!
+! Returns:
+!   index of [list] that is closest to [val]
+!
+! Optional output:
+!   [dist]   set to variable containing [list([result])] - [val]
+!
+! Requires:
+!   mrgrnk library
+!
+! Created:
+!   10/16/03  John Haynes (haynes@atmos.colostate.edu)
+! Modified:
+!   01/31/06  IDL to Fortran 90
+ 
+! ----- INPUTS -----
+  real*8, dimension(:), intent(in) :: list
+  real*8, intent(in) :: val  
+  integer, intent(in), optional :: sort
+  
+! ----- OUTPUTS -----
+  integer*4 :: infind
+  real*8, intent(out), optional :: dist
+
+! ----- INTERNAL -----
+  real*8, dimension(size(list)) :: lists
+  integer*4 :: nlist, result, tmp(1), sort_list
+  integer*4, dimension(size(list)) :: mask, idx
+
+  if (present(sort)) then
+    sort_list = sort
+  else
+    sort_list = 0
+  endif  
+
+  nlist = size(list)
+  if (sort_list == 1) then
+    call mrgrnk(list,idx)
+    lists = list(idx)
+  else
+    lists = list
+  endif
+
+  if (val >= lists(nlist)) then
+    result = nlist
+  else if (val <= lists(1)) then
+    result = 1
+  else
+    mask(:) = 0
+    where (lists < val) mask = 1
+      tmp = minloc(mask,1)
+      if (abs(lists(tmp(1)-1)-val) < abs(lists(tmp(1))-val)) then
+        result = tmp(1) - 1
+      else
+        result = tmp(1)
+      endif
+  endif
+  if (present(dist)) dist = lists(result)-val
+  if (sort_list == 1) then
+    infind = idx(result)
+  else
+    infind = result
+  endif
+
+  end function infind
+
+! ----------------------------------------------------------------------------
+! function LIN_INTERPOLATE
+! ----------------------------------------------------------------------------  
+  subroutine lin_interpolate(yarr,xarr,yyarr,xxarr,tol)
+  use m_mrgrnk
+  implicit none
+!
+! Purpose:
+!   linearly interpolate a set of y2 values given a set of y1,x1,x2
+!
+! Inputs:
+!   [yarr]    an array of y1 values
+!   [xarr]    an array of x1 values
+!   [xxarr]   an array of x2 values
+!   [tol]     maximum distance for a match
+!
+! Output:
+!   [yyarr]   interpolated array of y2 values
+!
+! Requires:
+!   mrgrnk library
+!
+! Created:
+!   06/07/06  John Haynes (haynes@atmos.colostate.edu)
+
+! ----- INPUTS -----
+  real*8, dimension(:), intent(in) :: yarr, xarr, xxarr
+  real*8, intent(in) :: tol
+
+! ----- OUTPUTS -----
+  real*8, dimension(size(xxarr)), intent(out) :: yyarr
+
+! ----- INTERNAL -----
+  real*8, dimension(size(xarr)) :: ysort, xsort
+  integer*4, dimension(size(xarr)) :: ist
+  integer*4 :: nx, nxx, i, iloc
+  real*8 :: d, m
+
+  nx = size(xarr)
+  nxx = size(xxarr)
+
+! // xsort, ysort are sorted versions of xarr, yarr  
+  call mrgrnk(xarr,ist)
+  ysort = yarr(ist)
+  xsort = xarr(ist)
+  
+  do i=1,nxx
+    iloc = infind(xsort,xxarr(i),dist=d)
+    if (d > tol) then
+      print *, 'interpolation error'
+      stop
+    endif
+    if (iloc == nx) then
+!     :: set to the last value
+      yyarr(i) = ysort(nx)
+    else
+!     :: is there another closeby value?
+      if (abs(xxarr(i)-xsort(iloc+1)) < 2*tol) then
+!       :: yes, do a linear interpolation      
+        m = (ysort(iloc+1)-ysort(iloc))/(xsort(iloc+1)-xsort(iloc))
+        yyarr(i) = ysort(iloc) + m*(xxarr(i)-xsort(iloc))
+      else
+!       :: no, set to the only nearby value
+        yyarr(i) = ysort(iloc)
+      endif
+    endif
+  enddo
+  
+  end subroutine lin_interpolate
+
+  end module array_lib
Index: DZ6/trunk/libf/phylmd/cosp/atmos_lib.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cosp/atmos_lib.F90	(revision 5267)
+++ 	(revision )
@@ -1,137 +1,0 @@
-! $Revision: 23 $, $Date: 2011-03-31 15:41:37 +0200 (jeu. 31 mars 2011) $
-! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/quickbeam/atmos_lib.f90 $
-! ATMOS_LIB: Atmospheric science procedures for F90
-! Compiled/Modified:
-!   07/01/06  John Haynes (haynes@atmos.colostate.edu)
-!
-! mcclatchey (subroutine)
-  
-  module atmos_lib
-  implicit none
-  
-  contains
-  
-! ----------------------------------------------------------------------------
-! subroutine MCCLATCHEY
-! ----------------------------------------------------------------------------
-  subroutine mcclatchey(stype,hgt,prs,tk,rh)
-  implicit none
-!
-! Purpose:
-!   returns a standard atmospheric profile
-!
-! Input:
-!   [stype]   type of profile to return
-!             1 = mid-latitude summer
-!             2 = mid-latitude winter
-!             3 = tropical
-!
-! Outputs:
-!   [hgt]     height (m)
-!   [prs]     pressure (hPa)
-!   [tk]      temperature (K)
-!   [rh]      relative humidity (%)
-!
-! Created:
-!   06/01/2006  John Haynes (haynes@atmos.colostate.edu)
-
-! ----- INPUTS -----
-  integer, intent(in) :: &
-  stype
-
-  integer, parameter :: ndat = 33
-
-! ----- OUTPUTS -----
-  real*8, intent(out), dimension(ndat) :: &
-  hgt, &                        ! height (m)
-  prs, &                        ! pressure (hPa)
-  tk, &                         ! temperature (K)
-  rh                            ! relative humidity (%)
-  
-  hgt = (/0.00000,1000.00,2000.00,3000.00,4000.00,5000.00, &
-          6000.00,7000.00,8000.00,9000.00,10000.0,11000.0, &
-          12000.0,13000.0,14000.0,15000.0,16000.0,17000.0, &
-          18000.0,19000.0,20000.0,21000.0,22000.0,23000.0, &
-          24000.0,25000.0,30000.0,35000.0,40000.0,45000.0, &
-          50000.0,70000.0,100000./)
-
-  select case(stype)
-
-  case(1)
-!   // mid-latitide summer  
-    prs = (/1013.00, 902.000, 802.000, 710.000, 628.000, 554.000, &
-            487.000, 426.000, 372.000, 324.000, 281.000, 243.000, &
-            209.000, 179.000, 153.000, 130.000, 111.000, 95.0000, &
-            81.2000, 69.5000, 59.5000, 51.0000, 43.7000, 37.6000, &
-            32.2000, 27.7000, 13.2000, 6.52000, 3.33000, 1.76000, &
-            0.951000,0.0671000,0.000300000/)
-        
-    tk =  (/294.000, 290.000, 285.000, 279.000, 273.000, 267.000, &
-            261.000, 255.000, 248.000, 242.000, 235.000, 229.000, &
-            222.000, 216.000, 216.000, 216.000, 216.000, 216.000, &
-            216.000, 217.000, 218.000, 219.000, 220.000, 222.000, &
-            223.000, 224.000, 234.000, 245.000, 258.000, 270.000, &
-            276.000, 218.000, 210.000/)
-
-    rh =  (/74.8384, 63.4602, 55.0485, 45.4953, 39.3805, 31.7965, &
-            30.3958, 29.5966, 30.1626, 29.3624, 30.3334, 19.0768, &
-            11.0450, 6.61278, 3.67379, 2.79209, 2.35123, 2.05732, &
-            1.83690, 1.59930, 1.30655, 1.31890, 1.17620,0.994076, &
-            0.988566,0.989143,0.188288,0.0205613,0.00271164,0.000488798, &
-            0.000107066,0.000406489,7.68645e-06/)
-
-  case(2)
-!   // mid-latitude winter
-    prs = (/1018.00, 897.300, 789.700, 693.800, 608.100, 531.300, &
-            462.700, 401.600, 347.300, 299.200, 256.800, 219.900, &
-            188.200, 161.000, 137.800, 117.800, 100.700, 86.1000, &
-            73.5000, 62.8000, 53.7000, 45.8000, 39.1000, 33.4000, &
-            28.6000, 24.3000, 11.1000, 5.18000, 2.53000, 1.29000, &
-            0.682000,0.0467000,0.000300000/)
-
-    tk =  (/272.200, 268.700, 265.200, 261.700, 255.700, 249.700, &
-            243.700, 237.700, 231.700, 225.700, 219.700, 219.200, &
-            218.700, 218.200, 217.700, 217.200, 216.700, 216.200, &
-            215.700, 215.200, 215.200, 215.200, 215.200, 215.200, &
-            215.200, 215.200, 217.400, 227.800, 243.200, 258.500, &
-            265.700, 230.700, 210.200/)
-
-    rh =  (/76.6175, 70.1686, 65.2478, 56.6267, 49.8755, 47.1765, &
-            44.0477, 31.0565, 23.0244, 19.6510, 17.8987, 17.4376, &
-            16.0621, 5.10608, 3.00679, 2.42293, 2.16406, 2.00901, &
-            1.90374, 1.98072, 1.81902, 2.06155, 2.06154, 2.18280, &
-            2.42531,2.70824,1.12105,0.108119,0.00944200,0.00115201, &
-            0.000221094,0.000101946,7.49350e-06/)
-
-  case(3)
-!   // tropical
-    prs = (/1013.00, 904.000, 805.000, 715.000, 633.000, 559.000, &
-            492.000, 432.000, 378.000, 329.000, 286.000, 247.000, &
-            213.000, 182.000, 156.000, 132.000, 111.000, 93.7000, &
-            78.9000, 66.6000, 56.5000, 48.0000, 40.9000, 35.0000, &
-            30.0000, 25.7000, 12.2000, 6.00000, 3.05000, 1.59000, &
-            0.854000,0.0579000,0.000300000/)
-
-    tk =  (/300.000, 294.000, 288.000, 284.000, 277.000, 270.000, &
-            264.000, 257.000, 250.000, 244.000, 237.000, 230.000, &
-            224.000, 217.000, 210.000, 204.000, 197.000, 195.000, &
-            199.000, 203.000, 207.000, 211.000, 215.000, 217.000, &
-            219.000, 221.000, 232.000, 243.000, 254.000, 265.000, &
-            270.000, 219.000, 210.000/)
-
-    rh =  (/71.4334, 69.4097, 71.4488, 46.7724, 34.7129, 38.3820, &
-            33.7214, 32.0122, 30.2607, 24.5059, 19.5321, 13.2966, &
-            8.85795, 5.87496, 7.68644, 12.8879, 29.4976, 34.9351, &
-            17.1606, 9.53422, 5.10154, 3.45407, 2.11168, 1.76247, &
-            1.55162,1.37966,0.229799,0.0245943,0.00373686,0.000702138, &
-            0.000162076,0.000362055,7.68645e-06/)
-         
-  case default
-    print *, 'Must enter a profile type'
-    stop
-    
-  end select
-  
-  end subroutine mcclatchey
-  
-  end module atmos_lib
Index: /LMDZ6/trunk/libf/phylmd/cosp/atmos_lib.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cosp/atmos_lib.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/cosp/atmos_lib.f90	(revision 5268)
@@ -0,0 +1,137 @@
+! $Revision: 23 $, $Date: 2011-03-31 15:41:37 +0200 (jeu. 31 mars 2011) $
+! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/quickbeam/atmos_lib.f90 $
+! ATMOS_LIB: Atmospheric science procedures for F90
+! Compiled/Modified:
+!   07/01/06  John Haynes (haynes@atmos.colostate.edu)
+!
+! mcclatchey (subroutine)
+  
+  module atmos_lib
+  implicit none
+  
+  contains
+  
+! ----------------------------------------------------------------------------
+! subroutine MCCLATCHEY
+! ----------------------------------------------------------------------------
+  subroutine mcclatchey(stype,hgt,prs,tk,rh)
+  implicit none
+!
+! Purpose:
+!   returns a standard atmospheric profile
+!
+! Input:
+!   [stype]   type of profile to return
+!             1 = mid-latitude summer
+!             2 = mid-latitude winter
+!             3 = tropical
+!
+! Outputs:
+!   [hgt]     height (m)
+!   [prs]     pressure (hPa)
+!   [tk]      temperature (K)
+!   [rh]      relative humidity (%)
+!
+! Created:
+!   06/01/2006  John Haynes (haynes@atmos.colostate.edu)
+
+! ----- INPUTS -----
+  integer, intent(in) :: &
+  stype
+
+  integer, parameter :: ndat = 33
+
+! ----- OUTPUTS -----
+  real*8, intent(out), dimension(ndat) :: &
+  hgt, &                        ! height (m)
+  prs, &                        ! pressure (hPa)
+  tk, &                         ! temperature (K)
+  rh                            ! relative humidity (%)
+  
+  hgt = (/0.00000,1000.00,2000.00,3000.00,4000.00,5000.00, &
+          6000.00,7000.00,8000.00,9000.00,10000.0,11000.0, &
+          12000.0,13000.0,14000.0,15000.0,16000.0,17000.0, &
+          18000.0,19000.0,20000.0,21000.0,22000.0,23000.0, &
+          24000.0,25000.0,30000.0,35000.0,40000.0,45000.0, &
+          50000.0,70000.0,100000./)
+
+  select case(stype)
+
+  case(1)
+!   // mid-latitide summer  
+    prs = (/1013.00, 902.000, 802.000, 710.000, 628.000, 554.000, &
+            487.000, 426.000, 372.000, 324.000, 281.000, 243.000, &
+            209.000, 179.000, 153.000, 130.000, 111.000, 95.0000, &
+            81.2000, 69.5000, 59.5000, 51.0000, 43.7000, 37.6000, &
+            32.2000, 27.7000, 13.2000, 6.52000, 3.33000, 1.76000, &
+            0.951000,0.0671000,0.000300000/)
+        
+    tk =  (/294.000, 290.000, 285.000, 279.000, 273.000, 267.000, &
+            261.000, 255.000, 248.000, 242.000, 235.000, 229.000, &
+            222.000, 216.000, 216.000, 216.000, 216.000, 216.000, &
+            216.000, 217.000, 218.000, 219.000, 220.000, 222.000, &
+            223.000, 224.000, 234.000, 245.000, 258.000, 270.000, &
+            276.000, 218.000, 210.000/)
+
+    rh =  (/74.8384, 63.4602, 55.0485, 45.4953, 39.3805, 31.7965, &
+            30.3958, 29.5966, 30.1626, 29.3624, 30.3334, 19.0768, &
+            11.0450, 6.61278, 3.67379, 2.79209, 2.35123, 2.05732, &
+            1.83690, 1.59930, 1.30655, 1.31890, 1.17620,0.994076, &
+            0.988566,0.989143,0.188288,0.0205613,0.00271164,0.000488798, &
+            0.000107066,0.000406489,7.68645e-06/)
+
+  case(2)
+!   // mid-latitude winter
+    prs = (/1018.00, 897.300, 789.700, 693.800, 608.100, 531.300, &
+            462.700, 401.600, 347.300, 299.200, 256.800, 219.900, &
+            188.200, 161.000, 137.800, 117.800, 100.700, 86.1000, &
+            73.5000, 62.8000, 53.7000, 45.8000, 39.1000, 33.4000, &
+            28.6000, 24.3000, 11.1000, 5.18000, 2.53000, 1.29000, &
+            0.682000,0.0467000,0.000300000/)
+
+    tk =  (/272.200, 268.700, 265.200, 261.700, 255.700, 249.700, &
+            243.700, 237.700, 231.700, 225.700, 219.700, 219.200, &
+            218.700, 218.200, 217.700, 217.200, 216.700, 216.200, &
+            215.700, 215.200, 215.200, 215.200, 215.200, 215.200, &
+            215.200, 215.200, 217.400, 227.800, 243.200, 258.500, &
+            265.700, 230.700, 210.200/)
+
+    rh =  (/76.6175, 70.1686, 65.2478, 56.6267, 49.8755, 47.1765, &
+            44.0477, 31.0565, 23.0244, 19.6510, 17.8987, 17.4376, &
+            16.0621, 5.10608, 3.00679, 2.42293, 2.16406, 2.00901, &
+            1.90374, 1.98072, 1.81902, 2.06155, 2.06154, 2.18280, &
+            2.42531,2.70824,1.12105,0.108119,0.00944200,0.00115201, &
+            0.000221094,0.000101946,7.49350e-06/)
+
+  case(3)
+!   // tropical
+    prs = (/1013.00, 904.000, 805.000, 715.000, 633.000, 559.000, &
+            492.000, 432.000, 378.000, 329.000, 286.000, 247.000, &
+            213.000, 182.000, 156.000, 132.000, 111.000, 93.7000, &
+            78.9000, 66.6000, 56.5000, 48.0000, 40.9000, 35.0000, &
+            30.0000, 25.7000, 12.2000, 6.00000, 3.05000, 1.59000, &
+            0.854000,0.0579000,0.000300000/)
+
+    tk =  (/300.000, 294.000, 288.000, 284.000, 277.000, 270.000, &
+            264.000, 257.000, 250.000, 244.000, 237.000, 230.000, &
+            224.000, 217.000, 210.000, 204.000, 197.000, 195.000, &
+            199.000, 203.000, 207.000, 211.000, 215.000, 217.000, &
+            219.000, 221.000, 232.000, 243.000, 254.000, 265.000, &
+            270.000, 219.000, 210.000/)
+
+    rh =  (/71.4334, 69.4097, 71.4488, 46.7724, 34.7129, 38.3820, &
+            33.7214, 32.0122, 30.2607, 24.5059, 19.5321, 13.2966, &
+            8.85795, 5.87496, 7.68644, 12.8879, 29.4976, 34.9351, &
+            17.1606, 9.53422, 5.10154, 3.45407, 2.11168, 1.76247, &
+            1.55162,1.37966,0.229799,0.0245943,0.00373686,0.000702138, &
+            0.000162076,0.000362055,7.68645e-06/)
+         
+  case default
+    print *, 'Must enter a profile type'
+    stop
+    
+  end select
+  
+  end subroutine mcclatchey
+  
+  end module atmos_lib
Index: DZ6/trunk/libf/phylmd/cosp/calc_Re.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cosp/calc_Re.F90	(revision 5267)
+++ 	(revision )
@@ -1,262 +1,0 @@
-  subroutine calc_Re(Q,Np,rho_a, &
-             dtype,dmin,dmax,apm,bpm,rho_c,p1,p2,p3, &
-             Re)
-  use math_lib 
-  implicit none
-
-! Purpose:
-!   Calculates Effective Radius (1/2 distribution 3rd moment / 2nd moment). 
-!
-!   For some distribution types, the total number concentration (per kg), Np
-!   may be optionally specified.   Should be set to zero, otherwise.
-!
-!   Roj Marchand July 2010
-
-
-! Inputs:
-!
-!   [Q]        hydrometeor mixing ratio (g/kg)  ! not needed for some distribution types
-!   [Np]       Optional Total number concentration (per kg).  0 = use defaults (p1, p2, p3)
-!
-!   [rho_a]    ambient air density (kg m^-3)   
-!
-!   Distribution parameters as per quickbeam documentation.
-!   [dtype]    distribution type
-!   [dmin]     minimum size cutoff (um)
-!   [dmax]     maximum size cutoff (um)
-!   [apm]      a parameter for mass (kg m^[-bpm])
-!   [bmp]      b params for mass 
-!   [p1],[p2],[p3]  distribution parameters
-!
-!
-! Outputs:
-!   [Re]       Effective radius, 1/2 the 3rd moment/2nd moment (um)
-!
-! Created:
-!   July 2010  Roj Marchand
-!
-
- 
-! ----- INPUTS -----  
-  
-  real*8, intent(in) :: Q,Np,rho_a
- 
-  integer, intent(in):: dtype
-  real*8, intent(in) :: dmin,dmax,rho_c,p1,p2,p3
-    
-  real*8, intent(inout) :: apm,bpm  
-    
-! ----- OUTPUTS -----
-
-  real*8, intent(out) :: Re
-  
-! ----- INTERNAL -----
- 
-  integer :: local_dtype
-  real*8  :: local_p3,local_Np
-
-  real*8 :: pi, &
-  N0,D0,vu,dm,ld, &         ! gamma, exponential variables
-  rg,log_sigma_g
-  
-  real*8 :: tmp1,tmp2
-
-  pi = acos(-1.0)
-
-  ! // if density is constant, set equivalent values for apm and bpm
-  if ((rho_c > 0) .and. (apm < 0)) then
-    apm = (pi/6)*rho_c
-    bpm = 3.
-  endif
-
-  ! Exponential is same as modified gamma with vu =1
-  ! if Np is specified then we will just treat as modified gamma
-  if(dtype.eq.2 .and. Np>0) then
-    local_dtype=1;
-    local_p3=1;
-  else
-    local_dtype=dtype;
-    local_p3=p3;
-  endif
-  
-  select case(local_dtype)
-  
-! ---------------------------------------------------------!
-! // modified gamma                                        !
-! ---------------------------------------------------------!
-! :: Np = total number concentration (1/kg) = Nt / rho_a
-! :: D0 = characteristic diameter (um)
-! :: dm = mean diameter (um) - first moment over zeroth moment
-! :: vu = distribution width parameter 
-
-  case(1)  
-  
-    if( abs(local_p3+2) < 1E-8) then
-  
-    if(Np>1E-30) then
-        ! Morrison scheme with Martin 1994 shape parameter (NOTE: vu = pc +1)
-        ! fixed Roj. Dec. 2010 -- after comment by S. Mcfarlane
-        vu = (1/(0.2714 + 0.00057145*Np*rho_a*1E-6))**2 ! units of Nt = Np*rhoa = #/cm^3
-    else
-        print *, 'Error: Must specify a value for Np in each volume', &
-             ' with Morrison/Martin Scheme.'
-            stop    
-    endif
-    
-    elseif (abs(local_p3+1) > 1E-8) then
-
-      ! vu is fixed in hp structure  
-      vu = local_p3 
-
-    else
-
-      ! vu isn't specified
-      
-      print *, 'Error: Must specify a value for vu for Modified Gamma distribution'
-      stop    
-      
-    endif
-    
-
-    if( Np.eq.0 .and. p2+1 > 1E-8) then     ! use default value for MEAN diameter as first default
-      
-        dm = p2             ! by definition, should have units of microns
-    D0 = gamma(vu)/gamma(vu+1)*dm
-        
-    else   ! use value of Np
-        
-        if(Np.eq.0) then
-        
-            if( abs(p1+1) > 1E-8 ) then  !   use default number concentration 
-            
-                local_Np = p1 ! total number concentration / pa --- units kg^-1
-            else
-            print *, 'Error: Must specify Np or default value ', &
-                 '(p1=Dm [um] or p2=Np [1/kg]) for ', &
-                 'Modified Gamma distribution'
-                stop
-            endif
-        else
-            local_Np=Np;    
-    endif
-    
-    D0 = 1E6 * ( Q*1E-3*gamma(vu)/(apm*local_Np*gamma(vu+bpm)) )**(1/bpm)  ! units = microns
-
-    endif  
-      
-    Re = 0.5*D0*gamma(vu+3)/gamma(vu+2)
-    
-    
-! ---------------------------------------------------------!
-! // exponential                                           !
-! ---------------------------------------------------------!
-! :: N0 = intercept parameter (m^-4)
-! :: ld = slope parameter (um)
-
-  case(2)
-  
-    ! Np not specified (see if statement above) 
-  
-    if((abs(p1+1) > 1E-8) ) then   ! N0 has been specified, determine ld
-    
-        N0 = p1
-    tmp1 = 1./(1.+bpm)
-    ld = ((apm*gamma(1.+bpm)*N0)/(rho_a*Q*1E-3))**tmp1
-    ld = ld/1E6                     ! set units to microns^-1
-        
-    elseif (abs(p2+1) > 1E-8) then  ! lambda=ld has been specified as default
-
-        ld = p2     ! should have units of microns^-1 
-    
-    else
-    
-    print *, 'Error: Must specify Np or default value ', &
-         '(p1=No or p2=lambda) for Exponential distribution'
-        stop
-        
-    endif
-
-    Re = 1.5/ld ;
-  
-! ---------------------------------------------------------!
-! // power law                                             !
-! ---------------------------------------------------------!
-! :: ahp = Ar parameter (m^-4 mm^-bhp)
-! :: bhp = br parameter
-! :: dmin_mm = lower bound (mm)
-! :: dmax_mm = upper bound (mm)
-
-  case(3)
-
-    Re=0;  ! Not supporting LUT approach for power-law ...
-
-    if(Np>0) then
-    
-        print *, 'Variable Np not supported for ', &
-         'Power Law distribution'
-        stop
-    endif
-! ---------------------------------------------------------!
-! // monodisperse                                          !
-! ---------------------------------------------------------!
-! :: D0 = particle diameter (um) == Re
-
-  case(4)
-  
-        Re = p1
-    
-        if(Np>0) then
-        print *, 'Variable Np not supported for ', &
-         'Monodispersed distribution'
-        stop
-    endif
-    
-! ---------------------------------------------------------!
-! // lognormal                                             !
-! ---------------------------------------------------------!
-! :: N0 = total number concentration (m^-3)
-! :: np = fixed number concentration (kg^-1)
-! :: rg = mean radius (um)
-! :: log_sigma_g = ln(geometric standard deviation)
-
-  case(5)
-  
-        if( abs(local_p3+1) > 1E-8 ) then
-
-            !set natural log width
-            log_sigma_g = local_p3 
-        else
-            print *, 'Error: Must specify a value for sigma_g ', &
-             'when using a Log-Normal distribution'
-            stop
-        endif
-     
-    ! get rg ... 
-    if( Np.eq.0 .and. (abs(p2+1) > 1E-8) ) then ! use default value of rg
-    
-            rg = p2
-              
-        else
-            if(Np>0) then
-            
-                local_Np=Np;
-                
-            elseif(abs(p2+1) < 1E-8) then
-            
-                local_Np=p1
-            else
-                print *, 'Error: Must specify Np or default value ', &
-                 '(p2=Rg or p1=Np) for Log-Normal distribution'
-            endif
-           
-            log_sigma_g = p3
-            tmp1 = (Q*1E-3)/(2.**bpm*apm*local_Np)
-            tmp2 = exp(0.5*bpm**2.*(log_sigma_g))**2.      
-            rg = ((tmp1/tmp2)**(1/bpm))*1E6
-        endif
-                
-        Re = rg*exp(+2.5*(log_sigma_g**2)) 
-        
-  end select
-  
-  end subroutine calc_Re
Index: /LMDZ6/trunk/libf/phylmd/cosp/calc_Re.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cosp/calc_Re.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/cosp/calc_Re.f90	(revision 5268)
@@ -0,0 +1,262 @@
+  subroutine calc_Re(Q,Np,rho_a, &
+             dtype,dmin,dmax,apm,bpm,rho_c,p1,p2,p3, &
+             Re)
+  use math_lib 
+  implicit none
+
+! Purpose:
+!   Calculates Effective Radius (1/2 distribution 3rd moment / 2nd moment). 
+!
+!   For some distribution types, the total number concentration (per kg), Np
+!   may be optionally specified.   Should be set to zero, otherwise.
+!
+!   Roj Marchand July 2010
+
+
+! Inputs:
+!
+!   [Q]        hydrometeor mixing ratio (g/kg)  ! not needed for some distribution types
+!   [Np]       Optional Total number concentration (per kg).  0 = use defaults (p1, p2, p3)
+!
+!   [rho_a]    ambient air density (kg m^-3)   
+!
+!   Distribution parameters as per quickbeam documentation.
+!   [dtype]    distribution type
+!   [dmin]     minimum size cutoff (um)
+!   [dmax]     maximum size cutoff (um)
+!   [apm]      a parameter for mass (kg m^[-bpm])
+!   [bmp]      b params for mass 
+!   [p1],[p2],[p3]  distribution parameters
+!
+!
+! Outputs:
+!   [Re]       Effective radius, 1/2 the 3rd moment/2nd moment (um)
+!
+! Created:
+!   July 2010  Roj Marchand
+!
+
+ 
+! ----- INPUTS -----  
+  
+  real*8, intent(in) :: Q,Np,rho_a
+ 
+  integer, intent(in):: dtype
+  real*8, intent(in) :: dmin,dmax,rho_c,p1,p2,p3
+    
+  real*8, intent(inout) :: apm,bpm  
+    
+! ----- OUTPUTS -----
+
+  real*8, intent(out) :: Re
+  
+! ----- INTERNAL -----
+ 
+  integer :: local_dtype
+  real*8  :: local_p3,local_Np
+
+  real*8 :: pi, &
+  N0,D0,vu,dm,ld, &         ! gamma, exponential variables
+  rg,log_sigma_g
+  
+  real*8 :: tmp1,tmp2
+
+  pi = acos(-1.0)
+
+  ! // if density is constant, set equivalent values for apm and bpm
+  if ((rho_c > 0) .and. (apm < 0)) then
+    apm = (pi/6)*rho_c
+    bpm = 3.
+  endif
+
+  ! Exponential is same as modified gamma with vu =1
+  ! if Np is specified then we will just treat as modified gamma
+  if(dtype.eq.2 .and. Np>0) then
+    local_dtype=1;
+    local_p3=1;
+  else
+    local_dtype=dtype;
+    local_p3=p3;
+  endif
+  
+  select case(local_dtype)
+  
+! ---------------------------------------------------------!
+! // modified gamma                                        !
+! ---------------------------------------------------------!
+! :: Np = total number concentration (1/kg) = Nt / rho_a
+! :: D0 = characteristic diameter (um)
+! :: dm = mean diameter (um) - first moment over zeroth moment
+! :: vu = distribution width parameter 
+
+  case(1)  
+  
+    if( abs(local_p3+2) < 1E-8) then
+  
+    if(Np>1E-30) then
+        ! Morrison scheme with Martin 1994 shape parameter (NOTE: vu = pc +1)
+        ! fixed Roj. Dec. 2010 -- after comment by S. Mcfarlane
+        vu = (1/(0.2714 + 0.00057145*Np*rho_a*1E-6))**2 ! units of Nt = Np*rhoa = #/cm^3
+    else
+        print *, 'Error: Must specify a value for Np in each volume', &
+             ' with Morrison/Martin Scheme.'
+            stop    
+    endif
+    
+    elseif (abs(local_p3+1) > 1E-8) then
+
+      ! vu is fixed in hp structure  
+      vu = local_p3 
+
+    else
+
+      ! vu isn't specified
+      
+      print *, 'Error: Must specify a value for vu for Modified Gamma distribution'
+      stop    
+      
+    endif
+    
+
+    if( Np.eq.0 .and. p2+1 > 1E-8) then     ! use default value for MEAN diameter as first default
+      
+        dm = p2             ! by definition, should have units of microns
+    D0 = gamma(vu)/gamma(vu+1)*dm
+        
+    else   ! use value of Np
+        
+        if(Np.eq.0) then
+        
+            if( abs(p1+1) > 1E-8 ) then  !   use default number concentration 
+            
+                local_Np = p1 ! total number concentration / pa --- units kg^-1
+            else
+            print *, 'Error: Must specify Np or default value ', &
+                 '(p1=Dm [um] or p2=Np [1/kg]) for ', &
+                 'Modified Gamma distribution'
+                stop
+            endif
+        else
+            local_Np=Np;    
+    endif
+    
+    D0 = 1E6 * ( Q*1E-3*gamma(vu)/(apm*local_Np*gamma(vu+bpm)) )**(1/bpm)  ! units = microns
+
+    endif  
+      
+    Re = 0.5*D0*gamma(vu+3)/gamma(vu+2)
+    
+    
+! ---------------------------------------------------------!
+! // exponential                                           !
+! ---------------------------------------------------------!
+! :: N0 = intercept parameter (m^-4)
+! :: ld = slope parameter (um)
+
+  case(2)
+  
+    ! Np not specified (see if statement above) 
+  
+    if((abs(p1+1) > 1E-8) ) then   ! N0 has been specified, determine ld
+    
+        N0 = p1
+    tmp1 = 1./(1.+bpm)
+    ld = ((apm*gamma(1.+bpm)*N0)/(rho_a*Q*1E-3))**tmp1
+    ld = ld/1E6                     ! set units to microns^-1
+        
+    elseif (abs(p2+1) > 1E-8) then  ! lambda=ld has been specified as default
+
+        ld = p2     ! should have units of microns^-1 
+    
+    else
+    
+    print *, 'Error: Must specify Np or default value ', &
+         '(p1=No or p2=lambda) for Exponential distribution'
+        stop
+        
+    endif
+
+    Re = 1.5/ld ;
+  
+! ---------------------------------------------------------!
+! // power law                                             !
+! ---------------------------------------------------------!
+! :: ahp = Ar parameter (m^-4 mm^-bhp)
+! :: bhp = br parameter
+! :: dmin_mm = lower bound (mm)
+! :: dmax_mm = upper bound (mm)
+
+  case(3)
+
+    Re=0;  ! Not supporting LUT approach for power-law ...
+
+    if(Np>0) then
+    
+        print *, 'Variable Np not supported for ', &
+         'Power Law distribution'
+        stop
+    endif
+! ---------------------------------------------------------!
+! // monodisperse                                          !
+! ---------------------------------------------------------!
+! :: D0 = particle diameter (um) == Re
+
+  case(4)
+  
+        Re = p1
+    
+        if(Np>0) then
+        print *, 'Variable Np not supported for ', &
+         'Monodispersed distribution'
+        stop
+    endif
+    
+! ---------------------------------------------------------!
+! // lognormal                                             !
+! ---------------------------------------------------------!
+! :: N0 = total number concentration (m^-3)
+! :: np = fixed number concentration (kg^-1)
+! :: rg = mean radius (um)
+! :: log_sigma_g = ln(geometric standard deviation)
+
+  case(5)
+  
+        if( abs(local_p3+1) > 1E-8 ) then
+
+            !set natural log width
+            log_sigma_g = local_p3 
+        else
+            print *, 'Error: Must specify a value for sigma_g ', &
+             'when using a Log-Normal distribution'
+            stop
+        endif
+     
+    ! get rg ... 
+    if( Np.eq.0 .and. (abs(p2+1) > 1E-8) ) then ! use default value of rg
+    
+            rg = p2
+              
+        else
+            if(Np>0) then
+            
+                local_Np=Np;
+                
+            elseif(abs(p2+1) < 1E-8) then
+            
+                local_Np=p1
+            else
+                print *, 'Error: Must specify Np or default value ', &
+                 '(p2=Rg or p1=Np) for Log-Normal distribution'
+            endif
+           
+            log_sigma_g = p3
+            tmp1 = (Q*1E-3)/(2.**bpm*apm*local_Np)
+            tmp2 = exp(0.5*bpm**2.*(log_sigma_g))**2.      
+            rg = ((tmp1/tmp2)**(1/bpm))*1E6
+        endif
+                
+        Re = rg*exp(+2.5*(log_sigma_g**2)) 
+        
+  end select
+  
+  end subroutine calc_Re
Index: DZ6/trunk/libf/phylmd/cosp/cosp_read_otputkeys.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cosp/cosp_read_otputkeys.F90	(revision 5267)
+++ 	(revision )
@@ -1,1233 +1,0 @@
-!!!=============================================================================
-!!! AI mars 2018
-!!  Module permettant de controler les cles de sorties cosp
-!!  pour LMDZ
-!! 1. on initialise les cles au 1er passage a cosp itap de la physique = 1
-!! 2. on garde la routine de lecture du fichier namelist cosp_out...txt pour le
-!!    cas non XIOS (ioipsl)
-!! 3. on rajoutte une subroutine qui interoge XIOS si les champs sont demandes
-!!    dans les xml alors on les active et on active les simulateurs
-!!    correspondant 
-!!!=============================================================================
-
-module cosp_read_otputkeys
-
-  USE MOD_COSP_CONSTANTS
-  USE MOD_COSP_TYPES
-  USE mod_phys_lmdz_para
-
-CONTAINS
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-!--------------- SUBROUTINE READ_COSP_OUTPUT_NL -------------------------
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
- SUBROUTINE cosp_outputkeys_init(cfg)
-  implicit none
-  type(cosp_config),intent(out) :: cfg 
-  character(len=32) :: out_list(N_OUT_LIST)
-  integer :: i
-
-                
-   do i=1,N_OUT_LIST
-      cfg%out_list(i)=''
-   enddo
-
-   cfg%Llidar_sim=.false.
-   cfg%Lradar_sim=.false.
-   cfg%Lisccp_sim=.false.
-   cfg%Lmodis_sim=.false.
-   cfg%Lmisr_sim=.false.
-   cfg%Lrttov_sim=.false.
-   cfg%Lstats=.false.
-   cfg%Lwrite_output=.false.
-   cfg%Ltoffset=.false.
-   cfg%Lfracout=.false.
-
-  cfg%Lcllcalipso=.FALSE.
-  cfg%Lclmcalipso=.FALSE.
-  cfg%Lclhcalipso=.FALSE.
-  cfg%Lcltcalipso=.FALSE.
-  cfg%Lcllcalipsoice=.FALSE.
-  cfg%Lclmcalipsoice=.FALSE.
-  cfg%Lclhcalipsoice=.FALSE.
-  cfg%Lcltcalipsoice=.FALSE.
-  cfg%Lcllcalipsoliq=.FALSE.
-  cfg%Lclmcalipsoliq=.FALSE.
-  cfg%Lclhcalipsoliq=.FALSE.
-  cfg%Lcltcalipsoliq=.FALSE.
-  cfg%Lcllcalipsoun=.FALSE.
-  cfg%Lclmcalipsoun=.FALSE.
-  cfg%Lclhcalipsoun=.FALSE.
-  cfg%Lcltcalipsoun=.FALSE.
-  cfg%Lclcalipso=.FALSE.
-  cfg%Lclcalipsoice=.FALSE.
-  cfg%Lclcalipsoliq=.FALSE.
-  cfg%Lclcalipsoun=.FALSE.
-  cfg%Lclcalipsotmp=.FALSE.
-  cfg%Lclcalipsotmpice=.FALSE.
-  cfg%Lclcalipsotmpliq=.FALSE.
-  cfg%Lclcalipsotmpun=.FALSE.
-  cfg%LparasolRefl=.FALSE.
-  cfg%LcfadLidarsr532=.FALSE.
-  cfg%Latb532=.FALSE.
-  cfg%LlidarBetaMol532=.FALSE.
-  cfg%Lclopaquecalipso=.FALSE.
-  cfg%Lclthincalipso=.FALSE.
-  cfg%Lclzopaquecalipso=.FALSE.
-  cfg%Lclcalipsoopaque=.FALSE.
-  cfg%Lclcalipsothin=.FALSE.
-  cfg%Lclcalipsozopaque=.FALSE.
-  cfg%Lclcalipsoopacity=.FALSE.
-  cfg%Lproftemp=.FALSE.
-  cfg%LprofSR=.FALSE.
-
-  cfg%LcfadDbze94=.FALSE.
-  cfg%Ldbze94=.FALSE.
-  cfg%Lcltlidarradar=.FALSE.
-  cfg%Lclcalipso2=.FALSE.
-
-  cfg%Lclisccp=.FALSE.
-  cfg%Lboxtauisccp=.FALSE.
-  cfg%Lboxptopisccp=.FALSE.
-  cfg%Lcltisccp=.FALSE.
-  cfg%Lpctisccp=.FALSE.
-  cfg%Ltauisccp=.FALSE.
-  cfg%Lalbisccp=.FALSE.
-  cfg%Lmeantbisccp=.FALSE.
-  cfg%Lmeantbclrisccp=.FALSE.
-
-  cfg%LclMISR=.FALSE.
-
-  cfg%Lcllmodis=.FALSE.
-  cfg%Lclmmodis=.FALSE.
-  cfg%Lclhmodis=.FALSE.
-  cfg%Lcltmodis=.FALSE.
-  cfg%Lclwmodis=.FALSE.
-  cfg%Lclimodis=.FALSE.
-  cfg%Ltautmodis=.FALSE.
-  cfg%Ltauwmodis=.FALSE.
-  cfg%Ltauimodis=.FALSE.
-  cfg%Ltautlogmodis=.FALSE.
-  cfg%Ltauilogmodis=.FALSE.
-  cfg%Ltauwlogmodis=.FALSE.
-  cfg%Lreffclwmodis=.FALSE.
-  cfg%Lreffclimodis=.FALSE.
-  cfg%Lpctmodis=.FALSE.
-  cfg%Llwpmodis=.FALSE.
-  cfg%Liwpmodis=.FALSE.
-  cfg%Lclmodis=.FALSE.
-  cfg%Lcrimodis=.FALSE.
-  cfg%Lcrlmodis=.FALSE.
-
-  cfg%Ltbrttov=.FALSE.
-
- end subroutine cosp_outputkeys_init
-
- SUBROUTINE cosp_outputkeys_test(cfg)
-  implicit none
-  type(cosp_config),intent(out) :: cfg
-  character(len=32) :: out_list(N_OUT_LIST)
-  integer :: i
-
-
-   do i=1,N_OUT_LIST
-      cfg%out_list(i)=''
-   enddo
-
-   cfg%Llidar_sim=.true.
-   cfg%Lradar_sim=.false.
-   cfg%Lisccp_sim=.false.
-   cfg%Lmodis_sim=.false.
-   cfg%Lmisr_sim=.false.
-   cfg%Lrttov_sim=.false.
-   cfg%Lstats=.false.
-   cfg%Lwrite_output=.false.
-   cfg%Ltoffset=.false.
-   cfg%Lfracout=.false.
-
-  cfg%Lcllcalipso=.TRUE.
-  cfg%Lclmcalipso=.TRUE.
-  cfg%Lclhcalipso=.TRUE.
-  cfg%Lcltcalipso=.TRUE.
-  cfg%Lcllcalipsoice=.FALSE.
-  cfg%Lclmcalipsoice=.FALSE.
-  cfg%Lclhcalipsoice=.FALSE.
-  cfg%Lcltcalipsoice=.FALSE.
-  cfg%Lcllcalipsoliq=.FALSE.
-  cfg%Lclmcalipsoliq=.FALSE.
-  cfg%Lclhcalipsoliq=.FALSE.
-  cfg%Lcltcalipsoliq=.FALSE.
-  cfg%Lcllcalipsoun=.FALSE.
-  cfg%Lclmcalipsoun=.FALSE.
-  cfg%Lclhcalipsoun=.FALSE.
-  cfg%Lcltcalipsoun=.FALSE.
-  cfg%Lclcalipso=.FALSE.
-  cfg%Lclcalipsoice=.FALSE.
-  cfg%Lclcalipsoliq=.FALSE.
-  cfg%Lclcalipsoun=.FALSE.
-  cfg%Lclcalipsotmp=.FALSE.
-  cfg%Lclcalipsotmpice=.FALSE.
-  cfg%Lclcalipsotmpliq=.FALSE.
-  cfg%Lclcalipsotmpun=.FALSE.
-  cfg%LparasolRefl=.FALSE.
-  cfg%LcfadLidarsr532=.FALSE.
-  cfg%Latb532=.FALSE.
-  cfg%LlidarBetaMol532=.FALSE.
-  cfg%Lclopaquecalipso=.FALSE.
-  cfg%Lclthincalipso=.FALSE.
-  cfg%Lclzopaquecalipso=.FALSE.
-  cfg%Lclcalipsoopaque=.FALSE.
-  cfg%Lclcalipsothin=.FALSE.
-  cfg%Lclcalipsozopaque=.FALSE.
-  cfg%Lclcalipsoopacity=.FALSE.
-  cfg%Lproftemp=.FALSE.
-  cfg%LprofSR=.FALSE.
-
-  cfg%LcfadDbze94=.FALSE.
-  cfg%Ldbze94=.FALSE.
-  cfg%Lcltlidarradar=.FALSE.
-  cfg%Lclcalipso2=.FALSE.
-
-  cfg%Lclisccp=.FALSE.
-  cfg%Lboxtauisccp=.FALSE.
-  cfg%Lboxptopisccp=.FALSE.
-  cfg%Lcltisccp=.FALSE.
-  cfg%Lpctisccp=.FALSE.
-  cfg%Ltauisccp=.FALSE.
-  cfg%Lalbisccp=.FALSE.
-  cfg%Lmeantbisccp=.FALSE.
-  cfg%Lmeantbclrisccp=.FALSE.
-
-  cfg%LclMISR=.FALSE.
-
-  cfg%Lcllmodis=.FALSE.
-  cfg%Lclmmodis=.FALSE.
-  cfg%Lclhmodis=.FALSE.
-  cfg%Lcltmodis=.FALSE.
-  cfg%Lclwmodis=.FALSE.
-  cfg%Lclimodis=.FALSE.
-  cfg%Ltautmodis=.FALSE.
-  cfg%Ltauwmodis=.FALSE.
-  cfg%Ltauimodis=.FALSE.
-  cfg%Ltautlogmodis=.FALSE.
-  cfg%Ltauilogmodis=.FALSE.
-  cfg%Ltauwlogmodis=.FALSE.
-  cfg%Lreffclwmodis=.FALSE.
-  cfg%Lreffclimodis=.FALSE.
-  cfg%Lpctmodis=.FALSE.
-  cfg%Llwpmodis=.FALSE.
-  cfg%Liwpmodis=.FALSE.
-  cfg%Lclmodis=.FALSE.
-  cfg%Lcrimodis=.FALSE.
-  cfg%Lcrlmodis=.FALSE.
-
-  cfg%Ltbrttov=.FALSE.
-
- end subroutine cosp_outputkeys_test
-
- SUBROUTINE READ_COSP_OUTPUT_NL(itap,cosp_nl,cfg)
-    USE lmdz_xios, ONLY: xios_field_is_active, using_xios
-  implicit none
-  character(len=*),intent(in) :: cosp_nl
-  type(cosp_config),intent(out) :: cfg
-  ! Local variables
-  integer :: i, itap
-
- logical, save :: Lradar_sim,Llidar_sim,Lisccp_sim,Lmodis_sim,Lmisr_sim,Lrttov_sim, Lstats, &
-             Lalbisccp,Latb532,Lboxptopisccp,Lboxtauisccp,LcfadDbze94, &
-             LcfadLidarsr532,Lclcalipso2,Lclcalipso,Lclhcalipso,Lclisccp,Lcllcalipso, &
-             Lclmcalipso,Lcltcalipso,Lcltlidarradar,Lpctisccp,Ldbze94,Ltauisccp,Lcltisccp, &
-             Lclcalipsoliq,Lclcalipsoice,Lclcalipsoun, &
-             Lclcalipsotmp,Lclcalipsotmpliq,Lclcalipsotmpice,Lclcalipsotmpun, &
-             Lcltcalipsoliq,Lcltcalipsoice,Lcltcalipsoun, &
-             Lclhcalipsoliq,Lclhcalipsoice,Lclhcalipsoun, &
-             Lclmcalipsoliq,Lclmcalipsoice,Lclmcalipsoun, &
-             Lcllcalipsoliq,Lcllcalipsoice,Lcllcalipsoun, &
-             Ltoffset,LparasolRefl,LclMISR,Lmeantbisccp,Lmeantbclrisccp, &
-             Lfracout,LlidarBetaMol532,Ltbrttov, &
-             Lcltmodis,Lclwmodis,Lclimodis,Lclhmodis,Lclmmodis,Lcllmodis,Ltautmodis,Ltauwmodis,Ltauimodis,Ltautlogmodis, &
-             Ltauwlogmodis,Ltauilogmodis,Lreffclwmodis,Lreffclimodis,Lpctmodis,Llwpmodis, &
-             Liwpmodis,Lclmodis,Lcrimodis,Lcrlmodis,Lclopaquecalipso,Lclthincalipso,      &           !OPAQ (2)
-             Lclzopaquecalipso,Lclcalipsoopaque,Lclcalipsothin,Lclcalipsozopaque,Lclcalipsoopacity, & !OPAQ (5)
-             LprofSR,Lproftemp                                                                        !TIBO (2)
-
-  namelist/COSP_OUTPUT/Lradar_sim,Llidar_sim,Lisccp_sim,Lmodis_sim,Lmisr_sim,Lrttov_sim, &
-             Lalbisccp,Latb532,Lboxptopisccp,Lboxtauisccp,LcfadDbze94, &
-             LcfadLidarsr532,Lclcalipso2,Lclcalipso,Lclhcalipso,Lclisccp, &
-             Lcllcalipso,Lclmcalipso,Lcltcalipso,Lcltlidarradar,Lpctisccp,Ldbze94,Ltauisccp, &
-             Lclcalipsoliq,Lclcalipsoice,Lclcalipsoun, &
-             Lclcalipsotmp,Lclcalipsotmpliq,Lclcalipsotmpice,Lclcalipsotmpun, &
-             Lcltcalipsoliq,Lcltcalipsoice,Lcltcalipsoun, &
-             Lclhcalipsoliq,Lclhcalipsoice,Lclhcalipsoun, &
-             Lclmcalipsoliq,Lclmcalipsoice,Lclmcalipsoun, &
-             Lcllcalipsoliq,Lcllcalipsoice,Lcllcalipsoun, &
-             Lcltisccp,Ltoffset,LparasolRefl,LclMISR,Lmeantbisccp,Lmeantbclrisccp, &
-             Lfracout,LlidarBetaMol532,Ltbrttov, &
-             Lcltmodis,Lclwmodis,Lclimodis,Lclhmodis,Lclmmodis,Lcllmodis,Ltautmodis,Ltauwmodis,Ltauimodis,Ltautlogmodis, &
-             Ltauwlogmodis,Ltauilogmodis,Lreffclwmodis,Lreffclimodis,Lpctmodis,Llwpmodis, &
-             Liwpmodis,Lclmodis,Lcrimodis,Lcrlmodis,Lclopaquecalipso,Lclthincalipso,      &           !OPAQ (2)
-             Lclzopaquecalipso,Lclcalipsoopaque,Lclcalipsothin,Lclcalipsozopaque,Lclcalipsoopacity, & !OPAQ (5)
-             LprofSR,Lproftemp                                                                        !TIBO (2)
-   
-  do i=1,N_OUT_LIST
-    cfg%out_list(i)=''
-  enddo
-  
-! Lecture du fichier namelist
-  IF (is_master) THEN
-    open(10,file=cosp_nl,status='old')
-    read(10,nml=cosp_output)
-    close(10)
-  ENDIF
-!$OMP BARRIER
-  
-  CALL bcast(Lradar_sim)
-  CALL bcast(Llidar_sim)
-  CALL bcast(Lisccp_sim)
-  CALL bcast(Lmodis_sim)
-  CALL bcast(Lmisr_sim)
-  CALL bcast(Lrttov_sim)
-
-  CALL bcast(Lstats)
-
-  CALL bcast(Lalbisccp)
-  CALL bcast(Latb532)
-  CALL bcast(Lboxptopisccp)
-  CALL bcast(Lboxtauisccp)
-  CALL bcast(LcfadDbze94)
-  CALL bcast(LcfadLidarsr532)
-  CALL bcast(Lclcalipso2)
-  CALL bcast(Lclcalipso)
-  CALL bcast(Lclhcalipso)
-  CALL bcast(Lclcalipsoliq)
-  CALL bcast(Lclcalipsoice)
-  CALL bcast(Lclcalipsoun)
-  CALL bcast(Lclcalipsotmp)
-  CALL bcast(Lclcalipsotmpliq)
-  CALL bcast(Lclcalipsotmpice)
-  CALL bcast(Lclcalipsotmpun)
-  CALL bcast(Lcltcalipsoliq)
-  CALL bcast(Lcltcalipsoice)
-  CALL bcast(Lcltcalipsoun)
-  CALL bcast(Lclhcalipsoliq)
-  CALL bcast(Lclhcalipsoice)
-  CALL bcast(Lclhcalipsoun)
-  CALL bcast(Lclmcalipsoliq)
-  CALL bcast(Lclmcalipsoice)
-  CALL bcast(Lclmcalipsoun)
-  CALL bcast(Lcllcalipsoliq)
-  CALL bcast(Lcllcalipsoice) 
-  CALL bcast(Lcllcalipsoun)
-  CALL bcast(Lclisccp)
-  CALL bcast(Lcllcalipso)
-  CALL bcast(Lclmcalipso)
-  CALL bcast(Lcltcalipso)
-  CALL bcast(Lcltlidarradar)
-  CALL bcast(Lpctisccp)
-  CALL bcast(Ldbze94)
-  CALL bcast(Ltauisccp)
-  CALL bcast(Lcltisccp)
-  CALL bcast(LparasolRefl)
-  CALL bcast(LclMISR)
-  CALL bcast(Lmeantbisccp)
-  CALL bcast(Lmeantbclrisccp)
-  CALL bcast(Lfracout)
-  CALL bcast(LlidarBetaMol532)
-  CALL bcast(Lcltmodis)
-  CALL bcast(Lclwmodis)
-  CALL bcast(Lclimodis) 
-  CALL bcast(Lclhmodis)
-  CALL bcast(Lclmmodis)
-  CALL bcast(Lcllmodis)
-  CALL bcast(Ltautmodis)
-  CALL bcast(Ltauwmodis)
-  CALL bcast(Ltauimodis)
-  CALL bcast(Ltautlogmodis)
-  CALL bcast(Ltauwlogmodis)
-  CALL bcast(Ltauilogmodis)
-  CALL bcast(Lreffclwmodis)
-  CALL bcast(Lreffclimodis)
-  CALL bcast(Lpctmodis)
-  CALL bcast(Llwpmodis)
-  CALL bcast(Liwpmodis)
-  CALL bcast(Lclmodis)
-  CALL bcast(Ltbrttov)
-  CALL bcast(Lcrimodis)
-  CALL bcast(Lcrlmodis)
-  CALL bcast(Lclopaquecalipso)  !OPAQ
-  CALL bcast(Lclthincalipso)    !OPAQ
-  CALL bcast(Lclzopaquecalipso) !OPAQ
-  CALL bcast(Lclcalipsoopaque)  !OPAQ
-  CALL bcast(Lclcalipsothin)    !OPAQ
-  CALL bcast(Lclcalipsozopaque) !OPAQ
-  CALL bcast(Lclcalipsoopacity) !OPAQ
-  CALL bcast(LprofSR)           !TIBO
-  CALL bcast(Lproftemp)         !TIBO
-
-!  print*,' Cles sorties cosp :'
-!  print*,' Lradar_sim,Llidar_sim,Lisccp_sim,Lmisr_sim,Lrttov_sim', &
-!           Lradar_sim,Llidar_sim,Lisccp_sim,Lmisr_sim,Lrttov_sim
-
-
-  ! Deal with dependencies
-  if (.not.Lradar_sim) then
-    LcfadDbze94   = .false.
-    Lclcalipso2    = .false.
-    Lcltlidarradar = .false. ! Needs radar & lidar
-    Ldbze94        = .false.
-    Lclcalipso2    = .false. ! Needs radar & lidar
-  endif
-
-  if (.not.Llidar_sim) then
-    Latb532          = .false.
-    LcfadLidarsr532  = .false.
-    Lclcalipso2      = .false.
-    Lclcalipso       = .false.
-    Lclhcalipso      = .false.
-    Lcllcalipso      = .false.
-    Lclmcalipso      = .false.
-    Lcltcalipso      = .false.
-    Lcltlidarradar   = .false. ! Needs radar & lidar
-    LparasolRefl     = .false.
-    LlidarBetaMol532 = .false.
-!! AI
-    Lclcalipsoliq       = .false.
-    Lclcalipsoice       = .false.
-    Lclcalipsoun        = .false.
-    Lclcalipsotmp       = .false.
-    Lclcalipsotmpun     = .false.
-    Lclcalipsotmpliq    = .false.
-    Lclcalipsotmpice    = .false.
-    Lclhcalipsoliq      = .false.
-    Lcllcalipsoliq      = .false.
-    Lclmcalipsoliq      = .false.
-    Lcltcalipsoliq      = .false.
-    Lclhcalipsoice      = .false.
-    Lcllcalipsoice      = .false.
-    Lclmcalipsoice      = .false.
-    Lcltcalipsoice      = .false.
-    Lclhcalipsoun       = .false.
-    Lcllcalipsoun       = .false.
-    Lclmcalipsoun       = .false.
-    Lcltcalipsoun       = .false.
-    Lclopaquecalipso    = .false. !OPAQ
-    Lclthincalipso      = .false. !OPAQ
-    Lclzopaquecalipso   = .false. !OPAQ
-    Lclcalipsoopaque    = .false. !OPAQ
-    Lclcalipsothin      = .false. !OPAQ
-    Lclcalipsozopaque   = .false. !OPAQ
-    Lclcalipsoopacity   = .false. !OPAQ
-    LprofSR             = .false. !TIBO
-    Lproftemp           = .false. !TIBO
-  endif
-
-  if (.not.Lisccp_sim) then
-    Lalbisccp       = .false.
-    Lboxptopisccp   = .false.
-    Lboxtauisccp    = .false.
-    Lclisccp        = .false.
-    Lpctisccp       = .false.
-    Ltauisccp       = .false.
-    Lcltisccp       = .false.
-    Lmeantbisccp    = .false.
-    Lmeantbclrisccp = .false.
-  endif
-
-  if (.not.Lmisr_sim) then
-    LclMISR = .false.
-  endif
-  if (.not.Lrttov_sim) then
-    Ltbrttov = .false.
-  endif
-  if ((.not.Lradar_sim).and.(.not.Llidar_sim).and. &
-      (.not.Lisccp_sim).and.(.not.Lmisr_sim)) then
-    Lfracout = .false.
-    Lstats = .false.
-  endif
- if (.not.Lmodis_sim) then
-    Lcltmodis=.false.
-    Lclwmodis=.false.
-    Lclimodis=.false.
-    Lclhmodis=.false.
-    Lclmmodis=.false.
-    Lcllmodis=.false.
-    Ltautmodis=.false.
-    Ltauwmodis=.false.
-    Ltauimodis=.false.
-    Ltautlogmodis=.false.
-    Ltauwlogmodis=.false.
-    Ltauilogmodis=.false.
-    Lreffclwmodis=.false.
-    Lreffclimodis=.false.
-    Lpctmodis=.false.
-    Llwpmodis=.false.
-    Liwpmodis=.false.
-    Lclmodis=.false.
-    Lcrimodis=.false.
-    Lcrlmodis=.false.
-  endif
-  if (Lmodis_sim) Lisccp_sim = .true.
-
-  ! Diagnostics that use Radar and Lidar
-  if (((Lclcalipso2).or.(Lcltlidarradar)).and.((Lradar_sim).or.(Llidar_sim))) then
-    Lclcalipso2    = .true.
-    Lcltlidarradar = .true.
-    Llidar_sim     = .true.
-    Lradar_sim     = .true.
-  endif
-
-  if ((Lradar_sim).or.(Llidar_sim).or.(Lisccp_sim)) Lstats = .true.
-
-  ! Copy instrument flags to cfg structure
-  cfg%Lradar_sim = Lradar_sim
-  cfg%Llidar_sim = Llidar_sim
-  cfg%Lisccp_sim = Lisccp_sim
-  cfg%Lmodis_sim = Lmodis_sim
-  cfg%Lmisr_sim  = Lmisr_sim
-  cfg%Lrttov_sim = Lrttov_sim
-
-  cfg%Lstats = Lstats
-
-  ! Flag to control output to file
-  cfg%Lwrite_output = .false.
-  if (cfg%Lstats.or.cfg%Lmisr_sim.or.cfg%Lrttov_sim) then
-    cfg%Lwrite_output = .true.
-  endif
-
-  ! Output diagnostics
-  i = 1
-  if (Lalbisccp)        cfg%out_list(i) = 'albisccp'
-  i = i+1
-  if (Latb532)          cfg%out_list(i) = 'atb532'
-  i = i+1
-  if (Lboxptopisccp)    cfg%out_list(i) = 'boxptopisccp'
-  i = i+1
-  if (Lboxtauisccp)     cfg%out_list(i) = 'boxtauisccp'
-  i = i+1
-  if (LcfadDbze94)      cfg%out_list(i) = 'cfadDbze94'
-  i = i+1
-  if (LcfadLidarsr532)  cfg%out_list(i) = 'cfadLidarsr532'
-  i = i+1
-  if (Lclcalipso2)      cfg%out_list(i) = 'clcalipso2'
-  i = i+1
-  if (Lclcalipso)       cfg%out_list(i) = 'clcalipso'
-  i = i+1
-  if (Lclhcalipso)      cfg%out_list(i) = 'clhcalipso'
-  i = i+1
-  if (Lclisccp)         cfg%out_list(i) = 'clisccp'
-  i = i+1
-  if (Lcllcalipso)      cfg%out_list(i) = 'cllcalipso'
-  i = i+1
-  if (Lclmcalipso)      cfg%out_list(i) = 'clmcalipso'
-  i = i+1
-  if (Lcltcalipso)      cfg%out_list(i) = 'cltcalipso'
-  i = i+1
-
-  if (Lcllcalipsoice)      cfg%out_list(i) = 'cllcalipsoice'
-  i = i+1
-  if (Lclmcalipsoice)      cfg%out_list(i) = 'clmcalipsoice'
-  i = i+1
-  if (Lclhcalipsoice)      cfg%out_list(i) = 'clhcalipsoice'
-  i = i+1
-  if (Lcltcalipsoice)      cfg%out_list(i) = 'cltcalipsoice'
-  i = i+1
-  if (Lcllcalipsoliq)      cfg%out_list(i) = 'cllcalipsoliq'
-  i = i+1
-  if (Lclmcalipsoliq)      cfg%out_list(i) = 'clmcalipsoliq'
-  i = i+1
-  if (Lclhcalipsoliq)      cfg%out_list(i) = 'clhcalipsoliq'
-  i = i+1
-  if (Lcltcalipsoliq)      cfg%out_list(i) = 'cltcalipsoliq'
-  i = i+1
-  if (Lcllcalipsoun)      cfg%out_list(i) = 'cllcalipsoun'
-  i = i+1
-  if (Lclmcalipsoun)      cfg%out_list(i) = 'clmcalipsoun'
-  i = i+1
-  if (Lclhcalipsoun)      cfg%out_list(i) = 'clhcalipsoun'
-  i = i+1
-  if (Lcltcalipsoun)      cfg%out_list(i) = 'cltcalipsoun'
-  i = i+1
-
-  if (Lclcalipsoice)       cfg%out_list(i) = 'clcalipsoice'
-  i = i+1
-  if (Lclcalipsoliq)       cfg%out_list(i) = 'clcalipsoliq'
-  i = i+1
-  if (Lclcalipsoun)       cfg%out_list(i) = 'clcalipsoun'
-  i = i+1
-
-  if (Lclcalipsotmp)       cfg%out_list(i) = 'clcalipsotmp'
-  i = i+1
-  if (Lclcalipsotmpice)       cfg%out_list(i) = 'clcalipsotmpice'
-  i = i+1
-  if (Lclcalipsotmpliq)       cfg%out_list(i) = 'clcalipsotmpliq'
-  i = i+1
-  if (Lclcalipsotmpun)       cfg%out_list(i) = 'clcalipsotmpun'
-  i = i+1
-  if (Lcltlidarradar)   cfg%out_list(i) = 'cltlidarradar'
-  i = i+1
-  if (Lpctisccp)        cfg%out_list(i) = 'pctisccp'
-  i = i+1
-  if (Ldbze94)          cfg%out_list(i) = 'dbze94'
-  i = i+1
-  if (Ltauisccp)        cfg%out_list(i) = 'tauisccp'
-  i = i+1
-  if (Lcltisccp)        cfg%out_list(i) = 'cltisccp'
-  i = i+1
-  if (Ltoffset)         cfg%out_list(i) = 'toffset'
-  i = i+1
-  if (LparasolRefl)     cfg%out_list(i) = 'parasolRefl'
-  i = i+1
-  if (LclMISR)          cfg%out_list(i) = 'clMISR'
-  i = i+1
-  if (Lmeantbisccp)     cfg%out_list(i) = 'meantbisccp'
-  i = i+1
-  if (Lmeantbclrisccp)  cfg%out_list(i) = 'meantbclrisccp'
-  i = i+1
-  if (Lfracout)         cfg%out_list(i) = 'fracout'
-  i = i+1
-  if (LlidarBetaMol532) cfg%out_list(i) = 'lidarBetaMol532'
-  i = i+1
-  if (Ltbrttov)         cfg%out_list(i) = 'tbrttov'
-  i = i+1
-  if (Lcltmodis)        cfg%out_list(i) = 'cltmodis'
-  i = i+1
-  if (Lclwmodis)        cfg%out_list(i) = 'clwmodis'
-  i = i+1
-  if (Lclimodis)        cfg%out_list(i) = 'climodis'
-  i = i+1
-  if (Lclhmodis)        cfg%out_list(i) = 'clhmodis'
-  i = i+1
-  if (Lclmmodis)        cfg%out_list(i) = 'clmmodis'
-  i = i+1
-  if (Lcllmodis)        cfg%out_list(i) = 'cllmodis'
-  i = i+1
-  if (Ltautmodis)       cfg%out_list(i) = 'tautmodis'
-  i = i+1
-  if (Ltauwmodis)       cfg%out_list(i) = 'tauwmodis'
-  i = i+1
-  if (Ltauimodis)       cfg%out_list(i) = 'tauimodis'
-  i = i+1
-  if (Ltautlogmodis)    cfg%out_list(i) = 'tautlogmodis'
-  i = i+1
-  if (Ltauwlogmodis)    cfg%out_list(i) = 'tauwlogmodis'
-  i = i+1
-  if (Ltauilogmodis)    cfg%out_list(i) = 'tauilogmodis'
-  i = i+1
-  if (Lreffclwmodis)    cfg%out_list(i) = 'reffclwmodis'
-  i = i+1
-  if (Lreffclimodis)    cfg%out_list(i) = 'reffclimodis'
-  i = i+1
-  if (Lpctmodis)        cfg%out_list(i) = 'pctmodis'
-  i = i+1
-  if (Llwpmodis)        cfg%out_list(i) = 'lwpmodis'
-  i = i+1
-  if (Liwpmodis)        cfg%out_list(i) = 'iwpmodis'
-  i = i+1
-  if (Lclmodis)         cfg%out_list(i) = 'clmodis'
-  i = i+1
-  if (Lcrimodis)         cfg%out_list(i) = 'crimodis'
-  i = i+1
-  if (Lcrlmodis)         cfg%out_list(i) = 'crlmodis'
-
-  i = i+1                                                            !OPAQ
-  if (Lclopaquecalipso)         cfg%out_list(i) = 'clopaquecalipso'  !OPAQ
-  i = i+1                                                            !OPAQ
-  if (Lclthincalipso)           cfg%out_list(i) = 'clthincalipso'    !OPAQ
-  i = i+1                                                            !OPAQ
-  if (Lclzopaquecalipso)        cfg%out_list(i) = 'clzopaquecalipso' !OPAQ
-  i = i+1                                                            !OPAQ
-  if (Lclcalipsoopaque)         cfg%out_list(i) = 'clcalipsoopaque'  !OPAQ
-  i = i+1                                                            !OPAQ
-  if (Lclcalipsothin)           cfg%out_list(i) = 'clcalipsothin'    !OPAQ
-  i = i+1                                                            !OPAQ
-  if (Lclcalipsozopaque)        cfg%out_list(i) = 'clcalipsozopaque' !OPAQ
-  i = i+1                                                            !OPAQ
-  if (Lclcalipsoopacity)        cfg%out_list(i) = 'clcalipsoopacity' !OPAQ
-  i = i+1                                                            !TIBO
-  if (LprofSR)                  cfg%out_list(i) = 'profSR'           !TIBO
-  i = i+1                                                            !TIBO
-  if (Lproftemp)                cfg%out_list(i) = 'proftemp'         !TIBO
-    
-  if (i /= N_OUT_LIST) then
-     print *, 'COSP_IO: wrong number of output diagnostics'
-     print *, i,N_OUT_LIST
-     stop
-  endif
-
-  ! Copy diagnostic flags to cfg structure
-  ! ISCCP simulator  
-  cfg%Lalbisccp = Lalbisccp
-  cfg%Latb532 = Latb532
-  cfg%Lboxptopisccp = Lboxptopisccp
-  cfg%Lboxtauisccp = Lboxtauisccp
-  cfg%Lmeantbisccp = Lmeantbisccp
-  cfg%Lmeantbclrisccp = Lmeantbclrisccp
-  cfg%Lclisccp = Lclisccp
-  cfg%Lpctisccp = Lpctisccp
-  cfg%Ltauisccp = Ltauisccp
-  cfg%Lcltisccp = Lcltisccp
-  ! CloudSat simulator  
-  cfg%Ldbze94 = Ldbze94
-  cfg%LcfadDbze94 = LcfadDbze94
-  ! CALIPSO/PARASOL simulator  
-  cfg%LcfadLidarsr532 = LcfadLidarsr532
-  cfg%Lclcalipso2 = Lclcalipso2
-  cfg%Lclcalipso = Lclcalipso
-  cfg%Lclhcalipso = Lclhcalipso
-  cfg%Lcllcalipso = Lcllcalipso
-  cfg%Lclmcalipso = Lclmcalipso
-  cfg%Lcltcalipso = Lcltcalipso
-  cfg%Lclhcalipsoice = Lclhcalipsoice
-  cfg%Lcllcalipsoice = Lcllcalipsoice
-  cfg%Lclmcalipsoice = Lclmcalipsoice
-  cfg%Lcltcalipsoice = Lcltcalipsoice
-  cfg%Lclhcalipsoliq = Lclhcalipsoliq
-  cfg%Lcllcalipsoliq = Lcllcalipsoliq
-  cfg%Lclmcalipsoliq = Lclmcalipsoliq
-  cfg%Lcltcalipsoliq = Lcltcalipsoliq
-  cfg%Lclhcalipsoun = Lclhcalipsoun
-  cfg%Lcllcalipsoun = Lcllcalipsoun
-  cfg%Lclmcalipsoun = Lclmcalipsoun
-  cfg%Lcltcalipsoun = Lcltcalipsoun
-  cfg%Lclcalipsoice = Lclcalipsoice
-  cfg%Lclcalipsoliq = Lclcalipsoliq
-  cfg%Lclcalipsoun = Lclcalipsoun
-  cfg%Lclcalipsotmp = Lclcalipsotmp
-  cfg%Lclcalipsotmpice = Lclcalipsotmpice
-  cfg%Lclcalipsotmpliq = Lclcalipsotmpliq
-  cfg%Lclcalipsotmpun = Lclcalipsotmpun
-  cfg%Lcltlidarradar = Lcltlidarradar
-  cfg%LparasolRefl = LparasolRefl
-  cfg%Lclopaquecalipso  = Lclopaquecalipso  !OPAQ
-  cfg%Lclthincalipso    = Lclthincalipso    !OPAQ
-  cfg%Lclzopaquecalipso = Lclzopaquecalipso !OPAQ
-  cfg%Lclcalipsoopaque  = Lclcalipsoopaque  !OPAQ
-  cfg%Lclcalipsothin    = Lclcalipsothin    !OPAQ
-  cfg%Lclcalipsozopaque = Lclcalipsozopaque !OPAQ
-  cfg%Lclcalipsoopacity = Lclcalipsoopacity !OPAQ
-  cfg%LprofSR           = LprofSR           !TIBO
-  cfg%Lproftemp         = Lproftemp         !TIBO
-  ! MISR simulator  
-  cfg%LclMISR = LclMISR
-  ! Other
-  cfg%Ltoffset = Ltoffset
-  cfg%Lfracout = Lfracout
-  cfg%LlidarBetaMol532 = LlidarBetaMol532
-  ! RTTOV
-  cfg%Ltbrttov = Ltbrttov
-  ! MODIS simulator  
-  cfg%Lcltmodis=Lcltmodis
-  cfg%Lclwmodis=Lclwmodis
-  cfg%Lclimodis=Lclimodis
-  cfg%Lclhmodis=Lclhmodis
-  cfg%Lclmmodis=Lclmmodis
-  cfg%Lcllmodis=Lcllmodis
-  cfg%Ltautmodis=Ltautmodis
-  cfg%Ltauwmodis=Ltauwmodis
-  cfg%Ltauimodis=Ltauimodis
-  cfg%Ltautlogmodis=Ltautlogmodis
-  cfg%Ltauwlogmodis=Ltauwlogmodis
-  cfg%Ltauilogmodis=Ltauilogmodis
-  cfg%Lreffclwmodis=Lreffclwmodis
-  cfg%Lreffclimodis=Lreffclimodis
-  cfg%Lpctmodis=Lpctmodis
-  cfg%Llwpmodis=Llwpmodis
-  cfg%Liwpmodis=Liwpmodis
-  cfg%Lclmodis=Lclmodis
-  cfg%Lcrimodis=Lcrimodis
-  cfg%Lcrlmodis=Lcrlmodis
-  
- END SUBROUTINE READ_COSP_OUTPUT_NL
-
- SUBROUTINE read_xiosfieldactive(cfg)
-
-    USE MOD_COSP_CONSTANTS
-    USE MOD_COSP_TYPES
-    USE lmdz_xios, ONLY: xios_field_is_active,using_xios
-  implicit none
-  type(cosp_config),intent(out) :: cfg
-  integer :: i
-
- logical :: Lradar_sim,Llidar_sim,Lisccp_sim,Lmodis_sim,Lmisr_sim,Lrttov_sim, Lstats, &
-             Lalbisccp,Latb532,Lboxptopisccp,Lboxtauisccp,LcfadDbze94, &
-             LcfadLidarsr532,Lclcalipso2,Lclcalipso,Lclhcalipso,Lclisccp,Lcllcalipso, &
-             Lclmcalipso,Lcltcalipso,Lcltlidarradar,Lpctisccp,Ldbze94,Ltauisccp,Lcltisccp, & 
-             Lclcalipsoliq,Lclcalipsoice,Lclcalipsoun, &
-             Lclcalipsotmp,Lclcalipsotmpliq,Lclcalipsotmpice,Lclcalipsotmpun, &
-             Lcltcalipsoliq,Lcltcalipsoice,Lcltcalipsoun, &
-             Lclhcalipsoliq,Lclhcalipsoice,Lclhcalipsoun, &
-             Lclmcalipsoliq,Lclmcalipsoice,Lclmcalipsoun, &
-             Lcllcalipsoliq,Lcllcalipsoice,Lcllcalipsoun, &
-             Ltoffset,LparasolRefl,LclMISR,Lmeantbisccp,Lmeantbclrisccp, &
-             Lfracout,LlidarBetaMol532,Ltbrttov, &
-             Lcltmodis,Lclwmodis,Lclimodis,Lclhmodis,Lclmmodis,Lcllmodis, &
-             Ltautmodis,Ltauwmodis,Ltauimodis,Ltautlogmodis, &
-             Ltauwlogmodis,Ltauilogmodis,Lreffclwmodis,Lreffclimodis,Lpctmodis,Llwpmodis, & 
-             Liwpmodis,Lclmodis,Lcrimodis,Lcrlmodis,Lclopaquecalipso,Lclthincalipso, &
-             Lclzopaquecalipso,Lclcalipsoopaque,Lclcalipsothin,Lclcalipsozopaque,Lclcalipsoopacity, &
-             LprofSR,Lproftemp
-        
-  character(len=32) :: out_list(N_OUT_LIST)
-
-  IF (using_xios) THEN
-    
-    do i=1,N_OUT_LIST
-      cfg%out_list(i)=''
-    enddo
-
-    LcfadDbze94   = .false.
-    Lclcalipso2    = .false.
-    Lcltlidarradar = .false. ! Needs radar & lidar
-    Ldbze94        = .false.
-    Lclcalipso2    = .false. ! Needs radar & lidar
-
-    Latb532          = .false.
-    LcfadLidarsr532  = .false.
-    Lclcalipso       = .false.
-    Lclhcalipso      = .false.
-    Lcllcalipso      = .false.
-    Lclmcalipso      = .false.
-    Lcltcalipso      = .false.
-    LparasolRefl     = .false.
-    LlidarBetaMol532 = .false.
-    Lclcalipsoliq       = .false.
-    Lclcalipsoice       = .false.
-    Lclcalipsoun        = .false.
-    Lclcalipsotmp       = .false.
-    Lclcalipsotmpun     = .false.
-    Lclcalipsotmpliq    = .false.
-    Lclcalipsotmpice    = .false.
-    Lclhcalipsoliq      = .false.
-    Lcllcalipsoliq      = .false.
-    Lclmcalipsoliq      = .false.
-    Lcltcalipsoliq      = .false.
-    Lclhcalipsoice      = .false.
-    Lcllcalipsoice      = .false.
-    Lclmcalipsoice      = .false.
-    Lcltcalipsoice      = .false.
-    Lclhcalipsoun       = .false.
-    Lcllcalipsoun       = .false.
-    Lclmcalipsoun       = .false.
-    Lcltcalipsoun       = .false.
-    Lclopaquecalipso    = .false. !OPAQ
-    Lclthincalipso      = .false. !OPAQ
-    Lclzopaquecalipso   = .false. !OPAQ
-    Lclcalipsoopaque    = .false. !OPAQ
-    Lclcalipsothin      = .false. !OPAQ
-    Lclcalipsozopaque   = .false. !OPAQ
-    Lclcalipsoopacity   = .false. !OPAQ
-    LprofSR             = .false. !TIBO
-    Lproftemp           = .false. !TIBO
-
-    Lalbisccp       = .false.
-    Lboxptopisccp   = .false.
-    Lboxtauisccp    = .false.
-    Lclisccp        = .false.
-    Lpctisccp       = .false.
-    Ltauisccp       = .false.
-    Lcltisccp       = .false.
-    Lmeantbisccp    = .false.
-    Lmeantbclrisccp = .false.
-
-    LclMISR = .false.
-
-    Ltbrttov = .false.
-
-    Lcltmodis=.false.
-    Lclwmodis=.false.
-    Lclimodis=.false.
-    Lclhmodis=.false.
-    Lclmmodis=.false.
-    Lcllmodis=.false.
-    Ltautmodis=.false.
-    Ltauwmodis=.false.
-    Ltauimodis=.false.
-    Ltautlogmodis=.false.
-    Ltauwlogmodis=.false.
-    Ltauilogmodis=.false.
-    Lreffclwmodis=.false.
-    Lreffclimodis=.false.
-    Lpctmodis=.false.
-    Llwpmodis=.false.
-    Liwpmodis=.false.
-    Lclmodis=.false.
-    Lcrimodis=.false.
-    Lcrlmodis=.false.
-
-    Lradar_sim=.false.
-    Llidar_sim=.false.
-    Lisccp_sim=.false.
-    Lmodis_sim=.false.
-    Lmisr_sim=.false.
-    Lrttov_sim=.false.
-
-    Lstats=.false.
-!    Ltoffset=.false.
-!    Lfracout=.false.
-!    Lwrite_output=.false.
-
-  IF (is_master) THEN
-! VEREFIER LES CHAMPS DEMANDES DANS .XML
-! 2. Si champs active dans .xml alors mettre la cles de sortie en true
- IF (xios_field_is_active("cllcalipso")) Lcllcalipso=.TRUE.
- IF (xios_field_is_active("clmcalipso")) Lclmcalipso=.TRUE.
- IF (xios_field_is_active("clhcalipso")) Lclhcalipso=.TRUE.
- IF (xios_field_is_active("cltcalipso")) Lcltcalipso=.TRUE.
- IF (xios_field_is_active("cllcalipsoice")) Lcllcalipsoice=.TRUE.
- IF (xios_field_is_active("clmcalipsoice")) Lclmcalipsoice=.TRUE.
- IF (xios_field_is_active("clhcalipsoice")) Lclhcalipsoice=.TRUE.
- IF (xios_field_is_active("cltcalipsoice")) Lcltcalipsoice=.TRUE.
- IF (xios_field_is_active("cllcalipsoliq")) Lcllcalipsoliq=.TRUE.
- IF (xios_field_is_active("clmcalipsoliq")) Lclmcalipsoliq=.TRUE.
- IF (xios_field_is_active("clhcalipsoliq")) Lclhcalipsoliq=.TRUE.
- IF (xios_field_is_active("cltcalipsoliq")) Lcltcalipsoliq=.TRUE.
- IF (xios_field_is_active("cllcalipsoun")) Lcllcalipsoun=.TRUE.
- IF (xios_field_is_active("clmcalipsoun")) Lclmcalipsoun=.TRUE.
- IF (xios_field_is_active("clhcalipsoun")) Lclhcalipsoun=.TRUE.
- IF (xios_field_is_active("cltcalipsoun")) Lcltcalipsoun=.TRUE.
- IF (xios_field_is_active("clcalipso")) Lclcalipso=.TRUE.
- IF (xios_field_is_active("clcalipsoice")) Lclcalipsoice=.TRUE.
- IF (xios_field_is_active("clcalipsoliq")) Lclcalipsoliq=.TRUE.
- IF (xios_field_is_active("clcalipsoun")) Lclcalipsoun=.TRUE.
- IF (xios_field_is_active("clcalipsotmp")) Lclcalipsotmp=.TRUE.
- IF (xios_field_is_active("clcalipsotmpice")) Lclcalipsotmpice=.TRUE.
- IF (xios_field_is_active("clcalipsotmpliq")) Lclcalipsotmpliq=.TRUE.
- IF (xios_field_is_active("clcalipsotmpun")) Lclcalipsotmpun=.TRUE.
- IF (xios_field_is_active("parasol_refl")) LparasolRefl=.TRUE.
-! IF (xios_field_is_active("parasol_crefl")) cfg%LparasolRefl=.TRUE.
-! IF (xios_field_is_active("Ncrefl")) cfg%LparasolRefl=.TRUE.
- IF (xios_field_is_active("cfad_lidarsr532")) LcfadLidarsr532=.TRUE.
- IF (xios_field_is_active("atb532")) Latb532=.TRUE.
- IF (xios_field_is_active("beta_mol532")) LlidarBetaMol532=.TRUE.
- IF (xios_field_is_active("clopaquecalipso")) Lclopaquecalipso=.TRUE.
- IF (xios_field_is_active("clthincalipso")) Lclthincalipso=.TRUE.
- IF (xios_field_is_active("clzopaquecalipso")) Lclzopaquecalipso=.TRUE.
- IF (xios_field_is_active("clcalipsoopaque")) Lclcalipsoopaque=.TRUE.
- IF (xios_field_is_active("clcalipsothin")) Lclcalipsothin=.TRUE.
- IF (xios_field_is_active("clcalipsozopaque")) Lclcalipsozopaque=.TRUE.
- IF (xios_field_is_active("clcalipsoopacity")) Lclcalipsoopacity=.TRUE.
- IF (xios_field_is_active("proftemp")) Lproftemp=.TRUE.
- IF (xios_field_is_active("profSR")) LprofSR=.TRUE.
-!!!! 38 champ Calipso
-
- IF (xios_field_is_active("cfadDbze94")) LcfadDbze94=.TRUE.
- IF (xios_field_is_active("dbze94")) Ldbze94=.TRUE.
-!!! 2 champs CLOUDSAT
-
- IF (xios_field_is_active("cltlidarradar")) Lcltlidarradar=.TRUE.
- IF (xios_field_is_active("clcalipso2")) Lclcalipso2=.TRUE.
-!!! 2 champs CLOUDSAT et CALIPSO
-
- IF (xios_field_is_active("clisccp2")) Lclisccp=.TRUE.
- IF (xios_field_is_active("boxtauisccp")) Lboxtauisccp=.TRUE.
- IF (xios_field_is_active("boxptopisccp")) Lboxptopisccp=.TRUE.
- IF (xios_field_is_active("tclisccp")) Lcltisccp=.TRUE.
- IF (xios_field_is_active("ctpisccp")) Lpctisccp=.TRUE.
- IF (xios_field_is_active("tauisccp")) Ltauisccp=.TRUE.
- IF (xios_field_is_active("albisccp")) Lalbisccp=.TRUE.
- IF (xios_field_is_active("meantbisccp")) Lmeantbisccp=.TRUE.
- IF (xios_field_is_active("meantbclrisccp")) Lmeantbclrisccp=.TRUE.
-!!! 9 champs ISCCP
-
- IF (xios_field_is_active("clMISR")) LclMISR=.TRUE.
-!!! 1 champs MISR
-
- IF (xios_field_is_active("cllmodis")) Lcllmodis=.TRUE.
- IF (xios_field_is_active("clmmodis")) Lclmmodis=.TRUE.
- IF (xios_field_is_active("clhmodis")) Lclhmodis=.TRUE.
- IF (xios_field_is_active("cltmodis")) Lcltmodis=.TRUE.
- IF (xios_field_is_active("clwmodis")) Lclwmodis=.TRUE.
- IF (xios_field_is_active("climodis")) Lclimodis=.TRUE.
- IF (xios_field_is_active("tautmodis")) Ltautmodis=.TRUE.
- IF (xios_field_is_active("tauwmodis")) Ltauwmodis=.TRUE.
- IF (xios_field_is_active("tauimodis")) Ltauimodis=.TRUE.
- IF (xios_field_is_active("tautlogmodis")) Ltautlogmodis=.TRUE.
- IF (xios_field_is_active("tauilogmodis")) Ltauilogmodis=.TRUE.
- IF (xios_field_is_active("tauwlogmodis")) Ltauwlogmodis=.TRUE.
- IF (xios_field_is_active("reffclwmodis")) Lreffclwmodis=.TRUE.
- IF (xios_field_is_active("reffclimodis")) Lreffclimodis=.TRUE.
- IF (xios_field_is_active("pctmodis")) Lpctmodis=.TRUE.
- IF (xios_field_is_active("lwpmodis")) Llwpmodis=.TRUE.
- IF (xios_field_is_active("iwpmodis")) Liwpmodis=.TRUE.
- IF (xios_field_is_active("clmodis")) Lclmodis=.TRUE.
- IF (xios_field_is_active("crimodis")) Lcrimodis=.TRUE.
- IF (xios_field_is_active("crlmodis")) Lcrlmodis=.TRUE.
-!!! 20 champs MODIS
-! IF (xios_field_is_active("tbrttov")) cfg%Ltbrttov=.TRUE.
-
-! 2.  si champs demande alors activer le simulateur correspondant
-   IF (xios_field_is_active("cllcalipso").OR. &
-       xios_field_is_active("clmcalipso").OR. &
-       xios_field_is_active("clhcalipso").OR. &
-       xios_field_is_active("cltcalipso").OR. &
-       xios_field_is_active("cllcalipsoice").OR. &
-       xios_field_is_active("clmcalipsoice").OR. &
-       xios_field_is_active("clhcalipsoice").OR. &
-       xios_field_is_active("cltcalipsoice").OR. &
-       xios_field_is_active("cllcalipsoliq").OR. &
-       xios_field_is_active("clmcalipsoliq").OR. &
-       xios_field_is_active("clhcalipsoliq").OR. &
-       xios_field_is_active("cltcalipsoliq").OR. &
-       xios_field_is_active("cllcalipsoun").OR. &
-       xios_field_is_active("clmcalipsoun").OR. &
-       xios_field_is_active("clhcalipsoun").OR. &
-       xios_field_is_active("cltcalipsoun").OR. &
-       xios_field_is_active("clcalipso").OR. &
-       xios_field_is_active("clcalipsoice").OR. &
-       xios_field_is_active("clcalipsoliq").OR. &
-       xios_field_is_active("clcalipsoun").OR. &
-       xios_field_is_active("clcalipsotmp").OR. &
-       xios_field_is_active("clcalipsotmpice").OR. &
-       xios_field_is_active("clcalipsotmpliq").OR. &
-       xios_field_is_active("clcalipsotmpun").OR. &
-       xios_field_is_active("parasol_refl").OR. &
-       xios_field_is_active("cfad_lidarsr532").OR. &
-       xios_field_is_active("atb532").OR. &
-       xios_field_is_active("beta_mol532").OR. &
-       xios_field_is_active("clopaquecalipso").OR. &
-       xios_field_is_active("clthincalipso").OR. &
-       xios_field_is_active("clzopaquecalipso").OR. &
-       xios_field_is_active("clcalipsoopaque").OR. &
-       xios_field_is_active("clcalipsothin").OR. &
-       xios_field_is_active("clcalipsozopaque").OR. &
-       xios_field_is_active("clcalipsoopacity").OR. &
-       xios_field_is_active("proftemp").OR. &
-       xios_field_is_active("profSR")) Llidar_sim=.TRUE.
-
-    IF (xios_field_is_active("cfadDbze94").OR. &
-      xios_field_is_active("dbze94")) Lradar_sim=.TRUE.
-
-    IF (xios_field_is_active("cltlidarradar").OR. &
-      xios_field_is_active("clcalipso2")) THEN
-               Lradar_sim=.TRUE.
-               Llidar_sim=.TRUE.
-    ENDIF
-
-    IF (xios_field_is_active("clisccp2").OR. &
-       xios_field_is_active("boxtauisccp").OR. &
-       xios_field_is_active("boxptopisccp").OR. &
-       xios_field_is_active("tclisccp").OR. &
-       xios_field_is_active("ctpisccp").OR. &
-       xios_field_is_active("tauisccp").OR. &
-       xios_field_is_active("albisccp").OR. &
-       xios_field_is_active("meantbisccp").OR. &
-       xios_field_is_active("meantbclrisccp")) Lisccp_sim=.TRUE.
-
-    IF (xios_field_is_active("clMISR")) Lmisr_sim=.TRUE.
-
-    IF (xios_field_is_active("cllmodis").OR. &
-       xios_field_is_active("clmmodis").OR. &
-       xios_field_is_active("clhmodis").OR. &
-       xios_field_is_active("cltmodis").OR. &
-       xios_field_is_active("clwmodis").OR. &
-       xios_field_is_active("climodis").OR. &
-       xios_field_is_active("tautmodis").OR. &
-       xios_field_is_active("tauwmodis").OR. &
-       xios_field_is_active("tauimodis").OR. &
-       xios_field_is_active("tautlogmodis").OR. &
-       xios_field_is_active("tauilogmodis").OR. &
-       xios_field_is_active("tauwlogmodis").OR. &
-       xios_field_is_active("reffclwmodis").OR. &
-       xios_field_is_active("reffclimodis").OR. &
-       xios_field_is_active("pctmodis").OR. &
-       xios_field_is_active("lwpmodis").OR. &
-       xios_field_is_active("iwpmodis").OR. &
-       xios_field_is_active("clmodis").OR. &
-       xios_field_is_active("crimodis").OR. &
-       xios_field_is_active("crlmodis")) Lmodis_sim=.TRUE.
-
-  ENDIF !   (is_master) 
-!$OMP BARRIER
-
-  CALL bcast(Lradar_sim)
-  CALL bcast(Llidar_sim)
-  CALL bcast(Lisccp_sim)
-  CALL bcast(Lmodis_sim)
-  CALL bcast(Lmisr_sim)
-  CALL bcast(Lrttov_sim)
-
-  CALL bcast(Lstats)
-
-  CALL bcast(Lalbisccp)
-  CALL bcast(Latb532)
-  CALL bcast(Lboxptopisccp)
-  CALL bcast(Lboxtauisccp)
-  CALL bcast(LcfadDbze94)
-  CALL bcast(LcfadLidarsr532)
-  CALL bcast(Lclcalipso2)
-  CALL bcast(Lclcalipso)
-  CALL bcast(Lclhcalipso)
-  CALL bcast(Lclcalipsoliq)
-  CALL bcast(Lclcalipsoice)
-  CALL bcast(Lclcalipsoun)
-  CALL bcast(Lclcalipsotmp)
-  CALL bcast(Lclcalipsotmpliq)
-  CALL bcast(Lclcalipsotmpice)
-  CALL bcast(Lclcalipsotmpun)
-  CALL bcast(Lcltcalipsoliq)
-  CALL bcast(Lcltcalipsoice)
-  CALL bcast(Lcltcalipsoun)
-  CALL bcast(Lclhcalipsoliq)
-  CALL bcast(Lclhcalipsoice)
-  CALL bcast(Lclhcalipsoun)
-  CALL bcast(Lclmcalipsoliq)
-  CALL bcast(Lclmcalipsoice)
-  CALL bcast(Lclmcalipsoun)
-  CALL bcast(Lcllcalipsoliq)
-  CALL bcast(Lcllcalipsoice)
-  CALL bcast(Lcllcalipsoun)
-  CALL bcast(Lclisccp)
-  CALL bcast(Lcllcalipso)
-  CALL bcast(Lclmcalipso)
-  CALL bcast(Lcltcalipso)
-  CALL bcast(Lcltlidarradar)
-  CALL bcast(Lpctisccp)
-  CALL bcast(Ldbze94)
-  CALL bcast(Ltauisccp)
-  CALL bcast(Lcltisccp)
-  CALL bcast(LparasolRefl)
-  CALL bcast(LclMISR)
-  CALL bcast(Lmeantbisccp)
-  CALL bcast(Lmeantbclrisccp)
-  CALL bcast(Lfracout)
-  CALL bcast(LlidarBetaMol532)
-  CALL bcast(Lcltmodis)
-  CALL bcast(Lclwmodis)
-  CALL bcast(Lclimodis)
-  CALL bcast(Lclhmodis)
-  CALL bcast(Lclmmodis)
-  CALL bcast(Lcllmodis)
-  CALL bcast(Ltautmodis)
-  CALL bcast(Ltauwmodis)
-  CALL bcast(Ltauimodis)
-  CALL bcast(Ltautlogmodis)
-  CALL bcast(Ltauwlogmodis)
-  CALL bcast(Ltauilogmodis)
-  CALL bcast(Lreffclwmodis)
-  CALL bcast(Lreffclimodis)
-  CALL bcast(Lpctmodis)
-  CALL bcast(Llwpmodis)
-  CALL bcast(Liwpmodis)
-  CALL bcast(Lclmodis)
-  CALL bcast(Ltbrttov)
-  CALL bcast(Lcrimodis)
-  CALL bcast(Lcrlmodis)
-  CALL bcast(Lclopaquecalipso)  !OPAQ
-  CALL bcast(Lclthincalipso)    !OPAQ
-  CALL bcast(Lclzopaquecalipso) !OPAQ
-  CALL bcast(Lclcalipsoopaque)  !OPAQ
-  CALL bcast(Lclcalipsothin)    !OPAQ
-  CALL bcast(Lclcalipsozopaque) !OPAQ
-  CALL bcast(Lclcalipsoopacity) !OPAQ
-  CALL bcast(LprofSR)           !TIBO
-  CALL bcast(Lproftemp)         !TIBO
-
-    if (Lmodis_sim) Lisccp_sim = .true.
-    if ((Lradar_sim).or.(Llidar_sim).or.(Lisccp_sim)) Lstats = .true.
-!    IF (xios_field_is_active("tbrttov")) cfg%Lrttov_sim=.TRUE.
-
-  ! Copy diagnostic flags to cfg structure
-  ! ISCCP simulator  
-  cfg%Lalbisccp = Lalbisccp
-  cfg%Latb532 = Latb532
-  cfg%Lboxptopisccp = Lboxptopisccp
-  cfg%Lboxtauisccp = Lboxtauisccp
-  cfg%Lmeantbisccp = Lmeantbisccp
-  cfg%Lmeantbclrisccp = Lmeantbclrisccp
-  cfg%Lclisccp = Lclisccp
-  cfg%Lpctisccp = Lpctisccp
-  cfg%Ltauisccp = Ltauisccp
-  cfg%Lcltisccp = Lcltisccp
-
-! CloudSat simulator  
-  cfg%Ldbze94 = Ldbze94
-  cfg%LcfadDbze94 = LcfadDbze94
-
-! Cloudsat et Calipso
-  cfg%Lclcalipso2 = Lclcalipso2
-  cfg%Lcltlidarradar = Lcltlidarradar
-
-! CALIPSO/PARASOL simulator  
-  cfg%LcfadLidarsr532 = LcfadLidarsr532
-  cfg%Lclcalipso = Lclcalipso
-  cfg%Lclhcalipso = Lclhcalipso
-  cfg%Lcllcalipso = Lcllcalipso
-  cfg%Lclmcalipso = Lclmcalipso
-  cfg%Lcltcalipso = Lcltcalipso
-  cfg%Lclhcalipsoice = Lclhcalipsoice
-  cfg%Lcllcalipsoice = Lcllcalipsoice
-  cfg%Lclmcalipsoice = Lclmcalipsoice
-  cfg%Lcltcalipsoice = Lcltcalipsoice
-  cfg%Lclhcalipsoliq = Lclhcalipsoliq
-  cfg%Lcllcalipsoliq = Lcllcalipsoliq
-  cfg%Lclmcalipsoliq = Lclmcalipsoliq
-  cfg%Lcltcalipsoliq = Lcltcalipsoliq
-  cfg%Lclhcalipsoun = Lclhcalipsoun
-  cfg%Lcllcalipsoun = Lcllcalipsoun
-  cfg%Lclmcalipsoun = Lclmcalipsoun
-  cfg%Lcltcalipsoun = Lcltcalipsoun
-  cfg%Lclcalipsoice = Lclcalipsoice
-  cfg%Lclcalipsoliq = Lclcalipsoliq
-  cfg%Lclcalipsoun = Lclcalipsoun
-  cfg%Lclcalipsotmp = Lclcalipsotmp
-  cfg%Lclcalipsotmpice = Lclcalipsotmpice
-  cfg%Lclcalipsotmpliq = Lclcalipsotmpliq
-  cfg%Lclcalipsotmpun = Lclcalipsotmpun
-  cfg%LparasolRefl = LparasolRefl
-  cfg%Lclopaquecalipso  = Lclopaquecalipso  !OPAQ
-  cfg%Lclthincalipso    = Lclthincalipso    !OPAQ
-  cfg%Lclzopaquecalipso = Lclzopaquecalipso !OPAQ
-  cfg%Lclcalipsoopaque  = Lclcalipsoopaque  !OPAQ
-  cfg%Lclcalipsothin    = Lclcalipsothin    !OPAQ
-  cfg%Lclcalipsozopaque = Lclcalipsozopaque !OPAQ
-  cfg%Lclcalipsoopacity = Lclcalipsoopacity !OPAQ
-  cfg%LprofSR           = LprofSR           !TIBO
-  cfg%Lproftemp         = Lproftemp         !TIBO
-  cfg%LlidarBetaMol532 = LlidarBetaMol532
-
-! MISR simulator  
-  cfg%LclMISR = LclMISR
-
-! RTTOV
-  cfg%Ltbrttov = Ltbrttov
-
-! MODIS simulator  
-  cfg%Lcltmodis=Lcltmodis
-  cfg%Lclwmodis=Lclwmodis
-  cfg%Lclimodis=Lclimodis
-  cfg%Lclhmodis=Lclhmodis
-  cfg%Lclmmodis=Lclmmodis
-  cfg%Lcllmodis=Lcllmodis
-  cfg%Ltautmodis=Ltautmodis
-  cfg%Ltauwmodis=Ltauwmodis
-  cfg%Ltauimodis=Ltauimodis
-  cfg%Ltautlogmodis=Ltautlogmodis
-  cfg%Ltauwlogmodis=Ltauwlogmodis
-  cfg%Ltauilogmodis=Ltauilogmodis
-  cfg%Lreffclwmodis=Lreffclwmodis
-  cfg%Lreffclimodis=Lreffclimodis
-  cfg%Lpctmodis=Lpctmodis
-  cfg%Llwpmodis=Llwpmodis
-  cfg%Liwpmodis=Liwpmodis
-  cfg%Lclmodis=Lclmodis
-  cfg%Lcrimodis=Lcrimodis
-  cfg%Lcrlmodis=Lcrlmodis
-
-! Others
-!  cfg%Lwrite_output=Lwrite_output
-!  cfg%Ltoffset=Ltoffset
-!  cfg%Lfracout=Lfracout
-  cfg%Lstats = Lstats
-
-! Copy instrument flags to cfg structure
-  cfg%Lradar_sim = Lradar_sim
-  cfg%Llidar_sim = Llidar_sim
-  cfg%Lisccp_sim = Lisccp_sim
-  cfg%Lmodis_sim = Lmodis_sim
-  cfg%Lmisr_sim  = Lmisr_sim
-  cfg%Lrttov_sim = Lrttov_sim
-
- ENDIF ! using_xios
-
-  END SUBROUTINE read_xiosfieldactive
-
-END MODULE cosp_read_otputkeys
Index: /LMDZ6/trunk/libf/phylmd/cosp/cosp_read_otputkeys.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cosp/cosp_read_otputkeys.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/cosp/cosp_read_otputkeys.f90	(revision 5268)
@@ -0,0 +1,1233 @@
+!!!=============================================================================
+!!! AI mars 2018
+!!  Module permettant de controler les cles de sorties cosp
+!!  pour LMDZ
+!! 1. on initialise les cles au 1er passage a cosp itap de la physique = 1
+!! 2. on garde la routine de lecture du fichier namelist cosp_out...txt pour le
+!!    cas non XIOS (ioipsl)
+!! 3. on rajoutte une subroutine qui interoge XIOS si les champs sont demandes
+!!    dans les xml alors on les active et on active les simulateurs
+!!    correspondant 
+!!!=============================================================================
+
+module cosp_read_otputkeys
+
+  USE MOD_COSP_CONSTANTS
+  USE MOD_COSP_TYPES
+  USE mod_phys_lmdz_para
+
+CONTAINS
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+!--------------- SUBROUTINE READ_COSP_OUTPUT_NL -------------------------
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+ SUBROUTINE cosp_outputkeys_init(cfg)
+  implicit none
+  type(cosp_config),intent(out) :: cfg 
+  character(len=32) :: out_list(N_OUT_LIST)
+  integer :: i
+
+                
+   do i=1,N_OUT_LIST
+      cfg%out_list(i)=''
+   enddo
+
+   cfg%Llidar_sim=.false.
+   cfg%Lradar_sim=.false.
+   cfg%Lisccp_sim=.false.
+   cfg%Lmodis_sim=.false.
+   cfg%Lmisr_sim=.false.
+   cfg%Lrttov_sim=.false.
+   cfg%Lstats=.false.
+   cfg%Lwrite_output=.false.
+   cfg%Ltoffset=.false.
+   cfg%Lfracout=.false.
+
+  cfg%Lcllcalipso=.FALSE.
+  cfg%Lclmcalipso=.FALSE.
+  cfg%Lclhcalipso=.FALSE.
+  cfg%Lcltcalipso=.FALSE.
+  cfg%Lcllcalipsoice=.FALSE.
+  cfg%Lclmcalipsoice=.FALSE.
+  cfg%Lclhcalipsoice=.FALSE.
+  cfg%Lcltcalipsoice=.FALSE.
+  cfg%Lcllcalipsoliq=.FALSE.
+  cfg%Lclmcalipsoliq=.FALSE.
+  cfg%Lclhcalipsoliq=.FALSE.
+  cfg%Lcltcalipsoliq=.FALSE.
+  cfg%Lcllcalipsoun=.FALSE.
+  cfg%Lclmcalipsoun=.FALSE.
+  cfg%Lclhcalipsoun=.FALSE.
+  cfg%Lcltcalipsoun=.FALSE.
+  cfg%Lclcalipso=.FALSE.
+  cfg%Lclcalipsoice=.FALSE.
+  cfg%Lclcalipsoliq=.FALSE.
+  cfg%Lclcalipsoun=.FALSE.
+  cfg%Lclcalipsotmp=.FALSE.
+  cfg%Lclcalipsotmpice=.FALSE.
+  cfg%Lclcalipsotmpliq=.FALSE.
+  cfg%Lclcalipsotmpun=.FALSE.
+  cfg%LparasolRefl=.FALSE.
+  cfg%LcfadLidarsr532=.FALSE.
+  cfg%Latb532=.FALSE.
+  cfg%LlidarBetaMol532=.FALSE.
+  cfg%Lclopaquecalipso=.FALSE.
+  cfg%Lclthincalipso=.FALSE.
+  cfg%Lclzopaquecalipso=.FALSE.
+  cfg%Lclcalipsoopaque=.FALSE.
+  cfg%Lclcalipsothin=.FALSE.
+  cfg%Lclcalipsozopaque=.FALSE.
+  cfg%Lclcalipsoopacity=.FALSE.
+  cfg%Lproftemp=.FALSE.
+  cfg%LprofSR=.FALSE.
+
+  cfg%LcfadDbze94=.FALSE.
+  cfg%Ldbze94=.FALSE.
+  cfg%Lcltlidarradar=.FALSE.
+  cfg%Lclcalipso2=.FALSE.
+
+  cfg%Lclisccp=.FALSE.
+  cfg%Lboxtauisccp=.FALSE.
+  cfg%Lboxptopisccp=.FALSE.
+  cfg%Lcltisccp=.FALSE.
+  cfg%Lpctisccp=.FALSE.
+  cfg%Ltauisccp=.FALSE.
+  cfg%Lalbisccp=.FALSE.
+  cfg%Lmeantbisccp=.FALSE.
+  cfg%Lmeantbclrisccp=.FALSE.
+
+  cfg%LclMISR=.FALSE.
+
+  cfg%Lcllmodis=.FALSE.
+  cfg%Lclmmodis=.FALSE.
+  cfg%Lclhmodis=.FALSE.
+  cfg%Lcltmodis=.FALSE.
+  cfg%Lclwmodis=.FALSE.
+  cfg%Lclimodis=.FALSE.
+  cfg%Ltautmodis=.FALSE.
+  cfg%Ltauwmodis=.FALSE.
+  cfg%Ltauimodis=.FALSE.
+  cfg%Ltautlogmodis=.FALSE.
+  cfg%Ltauilogmodis=.FALSE.
+  cfg%Ltauwlogmodis=.FALSE.
+  cfg%Lreffclwmodis=.FALSE.
+  cfg%Lreffclimodis=.FALSE.
+  cfg%Lpctmodis=.FALSE.
+  cfg%Llwpmodis=.FALSE.
+  cfg%Liwpmodis=.FALSE.
+  cfg%Lclmodis=.FALSE.
+  cfg%Lcrimodis=.FALSE.
+  cfg%Lcrlmodis=.FALSE.
+
+  cfg%Ltbrttov=.FALSE.
+
+ end subroutine cosp_outputkeys_init
+
+ SUBROUTINE cosp_outputkeys_test(cfg)
+  implicit none
+  type(cosp_config),intent(out) :: cfg
+  character(len=32) :: out_list(N_OUT_LIST)
+  integer :: i
+
+
+   do i=1,N_OUT_LIST
+      cfg%out_list(i)=''
+   enddo
+
+   cfg%Llidar_sim=.true.
+   cfg%Lradar_sim=.false.
+   cfg%Lisccp_sim=.false.
+   cfg%Lmodis_sim=.false.
+   cfg%Lmisr_sim=.false.
+   cfg%Lrttov_sim=.false.
+   cfg%Lstats=.false.
+   cfg%Lwrite_output=.false.
+   cfg%Ltoffset=.false.
+   cfg%Lfracout=.false.
+
+  cfg%Lcllcalipso=.TRUE.
+  cfg%Lclmcalipso=.TRUE.
+  cfg%Lclhcalipso=.TRUE.
+  cfg%Lcltcalipso=.TRUE.
+  cfg%Lcllcalipsoice=.FALSE.
+  cfg%Lclmcalipsoice=.FALSE.
+  cfg%Lclhcalipsoice=.FALSE.
+  cfg%Lcltcalipsoice=.FALSE.
+  cfg%Lcllcalipsoliq=.FALSE.
+  cfg%Lclmcalipsoliq=.FALSE.
+  cfg%Lclhcalipsoliq=.FALSE.
+  cfg%Lcltcalipsoliq=.FALSE.
+  cfg%Lcllcalipsoun=.FALSE.
+  cfg%Lclmcalipsoun=.FALSE.
+  cfg%Lclhcalipsoun=.FALSE.
+  cfg%Lcltcalipsoun=.FALSE.
+  cfg%Lclcalipso=.FALSE.
+  cfg%Lclcalipsoice=.FALSE.
+  cfg%Lclcalipsoliq=.FALSE.
+  cfg%Lclcalipsoun=.FALSE.
+  cfg%Lclcalipsotmp=.FALSE.
+  cfg%Lclcalipsotmpice=.FALSE.
+  cfg%Lclcalipsotmpliq=.FALSE.
+  cfg%Lclcalipsotmpun=.FALSE.
+  cfg%LparasolRefl=.FALSE.
+  cfg%LcfadLidarsr532=.FALSE.
+  cfg%Latb532=.FALSE.
+  cfg%LlidarBetaMol532=.FALSE.
+  cfg%Lclopaquecalipso=.FALSE.
+  cfg%Lclthincalipso=.FALSE.
+  cfg%Lclzopaquecalipso=.FALSE.
+  cfg%Lclcalipsoopaque=.FALSE.
+  cfg%Lclcalipsothin=.FALSE.
+  cfg%Lclcalipsozopaque=.FALSE.
+  cfg%Lclcalipsoopacity=.FALSE.
+  cfg%Lproftemp=.FALSE.
+  cfg%LprofSR=.FALSE.
+
+  cfg%LcfadDbze94=.FALSE.
+  cfg%Ldbze94=.FALSE.
+  cfg%Lcltlidarradar=.FALSE.
+  cfg%Lclcalipso2=.FALSE.
+
+  cfg%Lclisccp=.FALSE.
+  cfg%Lboxtauisccp=.FALSE.
+  cfg%Lboxptopisccp=.FALSE.
+  cfg%Lcltisccp=.FALSE.
+  cfg%Lpctisccp=.FALSE.
+  cfg%Ltauisccp=.FALSE.
+  cfg%Lalbisccp=.FALSE.
+  cfg%Lmeantbisccp=.FALSE.
+  cfg%Lmeantbclrisccp=.FALSE.
+
+  cfg%LclMISR=.FALSE.
+
+  cfg%Lcllmodis=.FALSE.
+  cfg%Lclmmodis=.FALSE.
+  cfg%Lclhmodis=.FALSE.
+  cfg%Lcltmodis=.FALSE.
+  cfg%Lclwmodis=.FALSE.
+  cfg%Lclimodis=.FALSE.
+  cfg%Ltautmodis=.FALSE.
+  cfg%Ltauwmodis=.FALSE.
+  cfg%Ltauimodis=.FALSE.
+  cfg%Ltautlogmodis=.FALSE.
+  cfg%Ltauilogmodis=.FALSE.
+  cfg%Ltauwlogmodis=.FALSE.
+  cfg%Lreffclwmodis=.FALSE.
+  cfg%Lreffclimodis=.FALSE.
+  cfg%Lpctmodis=.FALSE.
+  cfg%Llwpmodis=.FALSE.
+  cfg%Liwpmodis=.FALSE.
+  cfg%Lclmodis=.FALSE.
+  cfg%Lcrimodis=.FALSE.
+  cfg%Lcrlmodis=.FALSE.
+
+  cfg%Ltbrttov=.FALSE.
+
+ end subroutine cosp_outputkeys_test
+
+ SUBROUTINE READ_COSP_OUTPUT_NL(itap,cosp_nl,cfg)
+    USE lmdz_xios, ONLY: xios_field_is_active, using_xios
+  implicit none
+  character(len=*),intent(in) :: cosp_nl
+  type(cosp_config),intent(out) :: cfg
+  ! Local variables
+  integer :: i, itap
+
+ logical, save :: Lradar_sim,Llidar_sim,Lisccp_sim,Lmodis_sim,Lmisr_sim,Lrttov_sim, Lstats, &
+             Lalbisccp,Latb532,Lboxptopisccp,Lboxtauisccp,LcfadDbze94, &
+             LcfadLidarsr532,Lclcalipso2,Lclcalipso,Lclhcalipso,Lclisccp,Lcllcalipso, &
+             Lclmcalipso,Lcltcalipso,Lcltlidarradar,Lpctisccp,Ldbze94,Ltauisccp,Lcltisccp, &
+             Lclcalipsoliq,Lclcalipsoice,Lclcalipsoun, &
+             Lclcalipsotmp,Lclcalipsotmpliq,Lclcalipsotmpice,Lclcalipsotmpun, &
+             Lcltcalipsoliq,Lcltcalipsoice,Lcltcalipsoun, &
+             Lclhcalipsoliq,Lclhcalipsoice,Lclhcalipsoun, &
+             Lclmcalipsoliq,Lclmcalipsoice,Lclmcalipsoun, &
+             Lcllcalipsoliq,Lcllcalipsoice,Lcllcalipsoun, &
+             Ltoffset,LparasolRefl,LclMISR,Lmeantbisccp,Lmeantbclrisccp, &
+             Lfracout,LlidarBetaMol532,Ltbrttov, &
+             Lcltmodis,Lclwmodis,Lclimodis,Lclhmodis,Lclmmodis,Lcllmodis,Ltautmodis,Ltauwmodis,Ltauimodis,Ltautlogmodis, &
+             Ltauwlogmodis,Ltauilogmodis,Lreffclwmodis,Lreffclimodis,Lpctmodis,Llwpmodis, &
+             Liwpmodis,Lclmodis,Lcrimodis,Lcrlmodis,Lclopaquecalipso,Lclthincalipso,      &           !OPAQ (2)
+             Lclzopaquecalipso,Lclcalipsoopaque,Lclcalipsothin,Lclcalipsozopaque,Lclcalipsoopacity, & !OPAQ (5)
+             LprofSR,Lproftemp                                                                        !TIBO (2)
+
+  namelist/COSP_OUTPUT/Lradar_sim,Llidar_sim,Lisccp_sim,Lmodis_sim,Lmisr_sim,Lrttov_sim, &
+             Lalbisccp,Latb532,Lboxptopisccp,Lboxtauisccp,LcfadDbze94, &
+             LcfadLidarsr532,Lclcalipso2,Lclcalipso,Lclhcalipso,Lclisccp, &
+             Lcllcalipso,Lclmcalipso,Lcltcalipso,Lcltlidarradar,Lpctisccp,Ldbze94,Ltauisccp, &
+             Lclcalipsoliq,Lclcalipsoice,Lclcalipsoun, &
+             Lclcalipsotmp,Lclcalipsotmpliq,Lclcalipsotmpice,Lclcalipsotmpun, &
+             Lcltcalipsoliq,Lcltcalipsoice,Lcltcalipsoun, &
+             Lclhcalipsoliq,Lclhcalipsoice,Lclhcalipsoun, &
+             Lclmcalipsoliq,Lclmcalipsoice,Lclmcalipsoun, &
+             Lcllcalipsoliq,Lcllcalipsoice,Lcllcalipsoun, &
+             Lcltisccp,Ltoffset,LparasolRefl,LclMISR,Lmeantbisccp,Lmeantbclrisccp, &
+             Lfracout,LlidarBetaMol532,Ltbrttov, &
+             Lcltmodis,Lclwmodis,Lclimodis,Lclhmodis,Lclmmodis,Lcllmodis,Ltautmodis,Ltauwmodis,Ltauimodis,Ltautlogmodis, &
+             Ltauwlogmodis,Ltauilogmodis,Lreffclwmodis,Lreffclimodis,Lpctmodis,Llwpmodis, &
+             Liwpmodis,Lclmodis,Lcrimodis,Lcrlmodis,Lclopaquecalipso,Lclthincalipso,      &           !OPAQ (2)
+             Lclzopaquecalipso,Lclcalipsoopaque,Lclcalipsothin,Lclcalipsozopaque,Lclcalipsoopacity, & !OPAQ (5)
+             LprofSR,Lproftemp                                                                        !TIBO (2)
+   
+  do i=1,N_OUT_LIST
+    cfg%out_list(i)=''
+  enddo
+  
+! Lecture du fichier namelist
+  IF (is_master) THEN
+    open(10,file=cosp_nl,status='old')
+    read(10,nml=cosp_output)
+    close(10)
+  ENDIF
+!$OMP BARRIER
+  
+  CALL bcast(Lradar_sim)
+  CALL bcast(Llidar_sim)
+  CALL bcast(Lisccp_sim)
+  CALL bcast(Lmodis_sim)
+  CALL bcast(Lmisr_sim)
+  CALL bcast(Lrttov_sim)
+
+  CALL bcast(Lstats)
+
+  CALL bcast(Lalbisccp)
+  CALL bcast(Latb532)
+  CALL bcast(Lboxptopisccp)
+  CALL bcast(Lboxtauisccp)
+  CALL bcast(LcfadDbze94)
+  CALL bcast(LcfadLidarsr532)
+  CALL bcast(Lclcalipso2)
+  CALL bcast(Lclcalipso)
+  CALL bcast(Lclhcalipso)
+  CALL bcast(Lclcalipsoliq)
+  CALL bcast(Lclcalipsoice)
+  CALL bcast(Lclcalipsoun)
+  CALL bcast(Lclcalipsotmp)
+  CALL bcast(Lclcalipsotmpliq)
+  CALL bcast(Lclcalipsotmpice)
+  CALL bcast(Lclcalipsotmpun)
+  CALL bcast(Lcltcalipsoliq)
+  CALL bcast(Lcltcalipsoice)
+  CALL bcast(Lcltcalipsoun)
+  CALL bcast(Lclhcalipsoliq)
+  CALL bcast(Lclhcalipsoice)
+  CALL bcast(Lclhcalipsoun)
+  CALL bcast(Lclmcalipsoliq)
+  CALL bcast(Lclmcalipsoice)
+  CALL bcast(Lclmcalipsoun)
+  CALL bcast(Lcllcalipsoliq)
+  CALL bcast(Lcllcalipsoice) 
+  CALL bcast(Lcllcalipsoun)
+  CALL bcast(Lclisccp)
+  CALL bcast(Lcllcalipso)
+  CALL bcast(Lclmcalipso)
+  CALL bcast(Lcltcalipso)
+  CALL bcast(Lcltlidarradar)
+  CALL bcast(Lpctisccp)
+  CALL bcast(Ldbze94)
+  CALL bcast(Ltauisccp)
+  CALL bcast(Lcltisccp)
+  CALL bcast(LparasolRefl)
+  CALL bcast(LclMISR)
+  CALL bcast(Lmeantbisccp)
+  CALL bcast(Lmeantbclrisccp)
+  CALL bcast(Lfracout)
+  CALL bcast(LlidarBetaMol532)
+  CALL bcast(Lcltmodis)
+  CALL bcast(Lclwmodis)
+  CALL bcast(Lclimodis) 
+  CALL bcast(Lclhmodis)
+  CALL bcast(Lclmmodis)
+  CALL bcast(Lcllmodis)
+  CALL bcast(Ltautmodis)
+  CALL bcast(Ltauwmodis)
+  CALL bcast(Ltauimodis)
+  CALL bcast(Ltautlogmodis)
+  CALL bcast(Ltauwlogmodis)
+  CALL bcast(Ltauilogmodis)
+  CALL bcast(Lreffclwmodis)
+  CALL bcast(Lreffclimodis)
+  CALL bcast(Lpctmodis)
+  CALL bcast(Llwpmodis)
+  CALL bcast(Liwpmodis)
+  CALL bcast(Lclmodis)
+  CALL bcast(Ltbrttov)
+  CALL bcast(Lcrimodis)
+  CALL bcast(Lcrlmodis)
+  CALL bcast(Lclopaquecalipso)  !OPAQ
+  CALL bcast(Lclthincalipso)    !OPAQ
+  CALL bcast(Lclzopaquecalipso) !OPAQ
+  CALL bcast(Lclcalipsoopaque)  !OPAQ
+  CALL bcast(Lclcalipsothin)    !OPAQ
+  CALL bcast(Lclcalipsozopaque) !OPAQ
+  CALL bcast(Lclcalipsoopacity) !OPAQ
+  CALL bcast(LprofSR)           !TIBO
+  CALL bcast(Lproftemp)         !TIBO
+
+!  print*,' Cles sorties cosp :'
+!  print*,' Lradar_sim,Llidar_sim,Lisccp_sim,Lmisr_sim,Lrttov_sim', &
+!           Lradar_sim,Llidar_sim,Lisccp_sim,Lmisr_sim,Lrttov_sim
+
+
+  ! Deal with dependencies
+  if (.not.Lradar_sim) then
+    LcfadDbze94   = .false.
+    Lclcalipso2    = .false.
+    Lcltlidarradar = .false. ! Needs radar & lidar
+    Ldbze94        = .false.
+    Lclcalipso2    = .false. ! Needs radar & lidar
+  endif
+
+  if (.not.Llidar_sim) then
+    Latb532          = .false.
+    LcfadLidarsr532  = .false.
+    Lclcalipso2      = .false.
+    Lclcalipso       = .false.
+    Lclhcalipso      = .false.
+    Lcllcalipso      = .false.
+    Lclmcalipso      = .false.
+    Lcltcalipso      = .false.
+    Lcltlidarradar   = .false. ! Needs radar & lidar
+    LparasolRefl     = .false.
+    LlidarBetaMol532 = .false.
+!! AI
+    Lclcalipsoliq       = .false.
+    Lclcalipsoice       = .false.
+    Lclcalipsoun        = .false.
+    Lclcalipsotmp       = .false.
+    Lclcalipsotmpun     = .false.
+    Lclcalipsotmpliq    = .false.
+    Lclcalipsotmpice    = .false.
+    Lclhcalipsoliq      = .false.
+    Lcllcalipsoliq      = .false.
+    Lclmcalipsoliq      = .false.
+    Lcltcalipsoliq      = .false.
+    Lclhcalipsoice      = .false.
+    Lcllcalipsoice      = .false.
+    Lclmcalipsoice      = .false.
+    Lcltcalipsoice      = .false.
+    Lclhcalipsoun       = .false.
+    Lcllcalipsoun       = .false.
+    Lclmcalipsoun       = .false.
+    Lcltcalipsoun       = .false.
+    Lclopaquecalipso    = .false. !OPAQ
+    Lclthincalipso      = .false. !OPAQ
+    Lclzopaquecalipso   = .false. !OPAQ
+    Lclcalipsoopaque    = .false. !OPAQ
+    Lclcalipsothin      = .false. !OPAQ
+    Lclcalipsozopaque   = .false. !OPAQ
+    Lclcalipsoopacity   = .false. !OPAQ
+    LprofSR             = .false. !TIBO
+    Lproftemp           = .false. !TIBO
+  endif
+
+  if (.not.Lisccp_sim) then
+    Lalbisccp       = .false.
+    Lboxptopisccp   = .false.
+    Lboxtauisccp    = .false.
+    Lclisccp        = .false.
+    Lpctisccp       = .false.
+    Ltauisccp       = .false.
+    Lcltisccp       = .false.
+    Lmeantbisccp    = .false.
+    Lmeantbclrisccp = .false.
+  endif
+
+  if (.not.Lmisr_sim) then
+    LclMISR = .false.
+  endif
+  if (.not.Lrttov_sim) then
+    Ltbrttov = .false.
+  endif
+  if ((.not.Lradar_sim).and.(.not.Llidar_sim).and. &
+      (.not.Lisccp_sim).and.(.not.Lmisr_sim)) then
+    Lfracout = .false.
+    Lstats = .false.
+  endif
+ if (.not.Lmodis_sim) then
+    Lcltmodis=.false.
+    Lclwmodis=.false.
+    Lclimodis=.false.
+    Lclhmodis=.false.
+    Lclmmodis=.false.
+    Lcllmodis=.false.
+    Ltautmodis=.false.
+    Ltauwmodis=.false.
+    Ltauimodis=.false.
+    Ltautlogmodis=.false.
+    Ltauwlogmodis=.false.
+    Ltauilogmodis=.false.
+    Lreffclwmodis=.false.
+    Lreffclimodis=.false.
+    Lpctmodis=.false.
+    Llwpmodis=.false.
+    Liwpmodis=.false.
+    Lclmodis=.false.
+    Lcrimodis=.false.
+    Lcrlmodis=.false.
+  endif
+  if (Lmodis_sim) Lisccp_sim = .true.
+
+  ! Diagnostics that use Radar and Lidar
+  if (((Lclcalipso2).or.(Lcltlidarradar)).and.((Lradar_sim).or.(Llidar_sim))) then
+    Lclcalipso2    = .true.
+    Lcltlidarradar = .true.
+    Llidar_sim     = .true.
+    Lradar_sim     = .true.
+  endif
+
+  if ((Lradar_sim).or.(Llidar_sim).or.(Lisccp_sim)) Lstats = .true.
+
+  ! Copy instrument flags to cfg structure
+  cfg%Lradar_sim = Lradar_sim
+  cfg%Llidar_sim = Llidar_sim
+  cfg%Lisccp_sim = Lisccp_sim
+  cfg%Lmodis_sim = Lmodis_sim
+  cfg%Lmisr_sim  = Lmisr_sim
+  cfg%Lrttov_sim = Lrttov_sim
+
+  cfg%Lstats = Lstats
+
+  ! Flag to control output to file
+  cfg%Lwrite_output = .false.
+  if (cfg%Lstats.or.cfg%Lmisr_sim.or.cfg%Lrttov_sim) then
+    cfg%Lwrite_output = .true.
+  endif
+
+  ! Output diagnostics
+  i = 1
+  if (Lalbisccp)        cfg%out_list(i) = 'albisccp'
+  i = i+1
+  if (Latb532)          cfg%out_list(i) = 'atb532'
+  i = i+1
+  if (Lboxptopisccp)    cfg%out_list(i) = 'boxptopisccp'
+  i = i+1
+  if (Lboxtauisccp)     cfg%out_list(i) = 'boxtauisccp'
+  i = i+1
+  if (LcfadDbze94)      cfg%out_list(i) = 'cfadDbze94'
+  i = i+1
+  if (LcfadLidarsr532)  cfg%out_list(i) = 'cfadLidarsr532'
+  i = i+1
+  if (Lclcalipso2)      cfg%out_list(i) = 'clcalipso2'
+  i = i+1
+  if (Lclcalipso)       cfg%out_list(i) = 'clcalipso'
+  i = i+1
+  if (Lclhcalipso)      cfg%out_list(i) = 'clhcalipso'
+  i = i+1
+  if (Lclisccp)         cfg%out_list(i) = 'clisccp'
+  i = i+1
+  if (Lcllcalipso)      cfg%out_list(i) = 'cllcalipso'
+  i = i+1
+  if (Lclmcalipso)      cfg%out_list(i) = 'clmcalipso'
+  i = i+1
+  if (Lcltcalipso)      cfg%out_list(i) = 'cltcalipso'
+  i = i+1
+
+  if (Lcllcalipsoice)      cfg%out_list(i) = 'cllcalipsoice'
+  i = i+1
+  if (Lclmcalipsoice)      cfg%out_list(i) = 'clmcalipsoice'
+  i = i+1
+  if (Lclhcalipsoice)      cfg%out_list(i) = 'clhcalipsoice'
+  i = i+1
+  if (Lcltcalipsoice)      cfg%out_list(i) = 'cltcalipsoice'
+  i = i+1
+  if (Lcllcalipsoliq)      cfg%out_list(i) = 'cllcalipsoliq'
+  i = i+1
+  if (Lclmcalipsoliq)      cfg%out_list(i) = 'clmcalipsoliq'
+  i = i+1
+  if (Lclhcalipsoliq)      cfg%out_list(i) = 'clhcalipsoliq'
+  i = i+1
+  if (Lcltcalipsoliq)      cfg%out_list(i) = 'cltcalipsoliq'
+  i = i+1
+  if (Lcllcalipsoun)      cfg%out_list(i) = 'cllcalipsoun'
+  i = i+1
+  if (Lclmcalipsoun)      cfg%out_list(i) = 'clmcalipsoun'
+  i = i+1
+  if (Lclhcalipsoun)      cfg%out_list(i) = 'clhcalipsoun'
+  i = i+1
+  if (Lcltcalipsoun)      cfg%out_list(i) = 'cltcalipsoun'
+  i = i+1
+
+  if (Lclcalipsoice)       cfg%out_list(i) = 'clcalipsoice'
+  i = i+1
+  if (Lclcalipsoliq)       cfg%out_list(i) = 'clcalipsoliq'
+  i = i+1
+  if (Lclcalipsoun)       cfg%out_list(i) = 'clcalipsoun'
+  i = i+1
+
+  if (Lclcalipsotmp)       cfg%out_list(i) = 'clcalipsotmp'
+  i = i+1
+  if (Lclcalipsotmpice)       cfg%out_list(i) = 'clcalipsotmpice'
+  i = i+1
+  if (Lclcalipsotmpliq)       cfg%out_list(i) = 'clcalipsotmpliq'
+  i = i+1
+  if (Lclcalipsotmpun)       cfg%out_list(i) = 'clcalipsotmpun'
+  i = i+1
+  if (Lcltlidarradar)   cfg%out_list(i) = 'cltlidarradar'
+  i = i+1
+  if (Lpctisccp)        cfg%out_list(i) = 'pctisccp'
+  i = i+1
+  if (Ldbze94)          cfg%out_list(i) = 'dbze94'
+  i = i+1
+  if (Ltauisccp)        cfg%out_list(i) = 'tauisccp'
+  i = i+1
+  if (Lcltisccp)        cfg%out_list(i) = 'cltisccp'
+  i = i+1
+  if (Ltoffset)         cfg%out_list(i) = 'toffset'
+  i = i+1
+  if (LparasolRefl)     cfg%out_list(i) = 'parasolRefl'
+  i = i+1
+  if (LclMISR)          cfg%out_list(i) = 'clMISR'
+  i = i+1
+  if (Lmeantbisccp)     cfg%out_list(i) = 'meantbisccp'
+  i = i+1
+  if (Lmeantbclrisccp)  cfg%out_list(i) = 'meantbclrisccp'
+  i = i+1
+  if (Lfracout)         cfg%out_list(i) = 'fracout'
+  i = i+1
+  if (LlidarBetaMol532) cfg%out_list(i) = 'lidarBetaMol532'
+  i = i+1
+  if (Ltbrttov)         cfg%out_list(i) = 'tbrttov'
+  i = i+1
+  if (Lcltmodis)        cfg%out_list(i) = 'cltmodis'
+  i = i+1
+  if (Lclwmodis)        cfg%out_list(i) = 'clwmodis'
+  i = i+1
+  if (Lclimodis)        cfg%out_list(i) = 'climodis'
+  i = i+1
+  if (Lclhmodis)        cfg%out_list(i) = 'clhmodis'
+  i = i+1
+  if (Lclmmodis)        cfg%out_list(i) = 'clmmodis'
+  i = i+1
+  if (Lcllmodis)        cfg%out_list(i) = 'cllmodis'
+  i = i+1
+  if (Ltautmodis)       cfg%out_list(i) = 'tautmodis'
+  i = i+1
+  if (Ltauwmodis)       cfg%out_list(i) = 'tauwmodis'
+  i = i+1
+  if (Ltauimodis)       cfg%out_list(i) = 'tauimodis'
+  i = i+1
+  if (Ltautlogmodis)    cfg%out_list(i) = 'tautlogmodis'
+  i = i+1
+  if (Ltauwlogmodis)    cfg%out_list(i) = 'tauwlogmodis'
+  i = i+1
+  if (Ltauilogmodis)    cfg%out_list(i) = 'tauilogmodis'
+  i = i+1
+  if (Lreffclwmodis)    cfg%out_list(i) = 'reffclwmodis'
+  i = i+1
+  if (Lreffclimodis)    cfg%out_list(i) = 'reffclimodis'
+  i = i+1
+  if (Lpctmodis)        cfg%out_list(i) = 'pctmodis'
+  i = i+1
+  if (Llwpmodis)        cfg%out_list(i) = 'lwpmodis'
+  i = i+1
+  if (Liwpmodis)        cfg%out_list(i) = 'iwpmodis'
+  i = i+1
+  if (Lclmodis)         cfg%out_list(i) = 'clmodis'
+  i = i+1
+  if (Lcrimodis)         cfg%out_list(i) = 'crimodis'
+  i = i+1
+  if (Lcrlmodis)         cfg%out_list(i) = 'crlmodis'
+
+  i = i+1                                                            !OPAQ
+  if (Lclopaquecalipso)         cfg%out_list(i) = 'clopaquecalipso'  !OPAQ
+  i = i+1                                                            !OPAQ
+  if (Lclthincalipso)           cfg%out_list(i) = 'clthincalipso'    !OPAQ
+  i = i+1                                                            !OPAQ
+  if (Lclzopaquecalipso)        cfg%out_list(i) = 'clzopaquecalipso' !OPAQ
+  i = i+1                                                            !OPAQ
+  if (Lclcalipsoopaque)         cfg%out_list(i) = 'clcalipsoopaque'  !OPAQ
+  i = i+1                                                            !OPAQ
+  if (Lclcalipsothin)           cfg%out_list(i) = 'clcalipsothin'    !OPAQ
+  i = i+1                                                            !OPAQ
+  if (Lclcalipsozopaque)        cfg%out_list(i) = 'clcalipsozopaque' !OPAQ
+  i = i+1                                                            !OPAQ
+  if (Lclcalipsoopacity)        cfg%out_list(i) = 'clcalipsoopacity' !OPAQ
+  i = i+1                                                            !TIBO
+  if (LprofSR)                  cfg%out_list(i) = 'profSR'           !TIBO
+  i = i+1                                                            !TIBO
+  if (Lproftemp)                cfg%out_list(i) = 'proftemp'         !TIBO
+    
+  if (i /= N_OUT_LIST) then
+     print *, 'COSP_IO: wrong number of output diagnostics'
+     print *, i,N_OUT_LIST
+     stop
+  endif
+
+  ! Copy diagnostic flags to cfg structure
+  ! ISCCP simulator  
+  cfg%Lalbisccp = Lalbisccp
+  cfg%Latb532 = Latb532
+  cfg%Lboxptopisccp = Lboxptopisccp
+  cfg%Lboxtauisccp = Lboxtauisccp
+  cfg%Lmeantbisccp = Lmeantbisccp
+  cfg%Lmeantbclrisccp = Lmeantbclrisccp
+  cfg%Lclisccp = Lclisccp
+  cfg%Lpctisccp = Lpctisccp
+  cfg%Ltauisccp = Ltauisccp
+  cfg%Lcltisccp = Lcltisccp
+  ! CloudSat simulator  
+  cfg%Ldbze94 = Ldbze94
+  cfg%LcfadDbze94 = LcfadDbze94
+  ! CALIPSO/PARASOL simulator  
+  cfg%LcfadLidarsr532 = LcfadLidarsr532
+  cfg%Lclcalipso2 = Lclcalipso2
+  cfg%Lclcalipso = Lclcalipso
+  cfg%Lclhcalipso = Lclhcalipso
+  cfg%Lcllcalipso = Lcllcalipso
+  cfg%Lclmcalipso = Lclmcalipso
+  cfg%Lcltcalipso = Lcltcalipso
+  cfg%Lclhcalipsoice = Lclhcalipsoice
+  cfg%Lcllcalipsoice = Lcllcalipsoice
+  cfg%Lclmcalipsoice = Lclmcalipsoice
+  cfg%Lcltcalipsoice = Lcltcalipsoice
+  cfg%Lclhcalipsoliq = Lclhcalipsoliq
+  cfg%Lcllcalipsoliq = Lcllcalipsoliq
+  cfg%Lclmcalipsoliq = Lclmcalipsoliq
+  cfg%Lcltcalipsoliq = Lcltcalipsoliq
+  cfg%Lclhcalipsoun = Lclhcalipsoun
+  cfg%Lcllcalipsoun = Lcllcalipsoun
+  cfg%Lclmcalipsoun = Lclmcalipsoun
+  cfg%Lcltcalipsoun = Lcltcalipsoun
+  cfg%Lclcalipsoice = Lclcalipsoice
+  cfg%Lclcalipsoliq = Lclcalipsoliq
+  cfg%Lclcalipsoun = Lclcalipsoun
+  cfg%Lclcalipsotmp = Lclcalipsotmp
+  cfg%Lclcalipsotmpice = Lclcalipsotmpice
+  cfg%Lclcalipsotmpliq = Lclcalipsotmpliq
+  cfg%Lclcalipsotmpun = Lclcalipsotmpun
+  cfg%Lcltlidarradar = Lcltlidarradar
+  cfg%LparasolRefl = LparasolRefl
+  cfg%Lclopaquecalipso  = Lclopaquecalipso  !OPAQ
+  cfg%Lclthincalipso    = Lclthincalipso    !OPAQ
+  cfg%Lclzopaquecalipso = Lclzopaquecalipso !OPAQ
+  cfg%Lclcalipsoopaque  = Lclcalipsoopaque  !OPAQ
+  cfg%Lclcalipsothin    = Lclcalipsothin    !OPAQ
+  cfg%Lclcalipsozopaque = Lclcalipsozopaque !OPAQ
+  cfg%Lclcalipsoopacity = Lclcalipsoopacity !OPAQ
+  cfg%LprofSR           = LprofSR           !TIBO
+  cfg%Lproftemp         = Lproftemp         !TIBO
+  ! MISR simulator  
+  cfg%LclMISR = LclMISR
+  ! Other
+  cfg%Ltoffset = Ltoffset
+  cfg%Lfracout = Lfracout
+  cfg%LlidarBetaMol532 = LlidarBetaMol532
+  ! RTTOV
+  cfg%Ltbrttov = Ltbrttov
+  ! MODIS simulator  
+  cfg%Lcltmodis=Lcltmodis
+  cfg%Lclwmodis=Lclwmodis
+  cfg%Lclimodis=Lclimodis
+  cfg%Lclhmodis=Lclhmodis
+  cfg%Lclmmodis=Lclmmodis
+  cfg%Lcllmodis=Lcllmodis
+  cfg%Ltautmodis=Ltautmodis
+  cfg%Ltauwmodis=Ltauwmodis
+  cfg%Ltauimodis=Ltauimodis
+  cfg%Ltautlogmodis=Ltautlogmodis
+  cfg%Ltauwlogmodis=Ltauwlogmodis
+  cfg%Ltauilogmodis=Ltauilogmodis
+  cfg%Lreffclwmodis=Lreffclwmodis
+  cfg%Lreffclimodis=Lreffclimodis
+  cfg%Lpctmodis=Lpctmodis
+  cfg%Llwpmodis=Llwpmodis
+  cfg%Liwpmodis=Liwpmodis
+  cfg%Lclmodis=Lclmodis
+  cfg%Lcrimodis=Lcrimodis
+  cfg%Lcrlmodis=Lcrlmodis
+  
+ END SUBROUTINE READ_COSP_OUTPUT_NL
+
+ SUBROUTINE read_xiosfieldactive(cfg)
+
+    USE MOD_COSP_CONSTANTS
+    USE MOD_COSP_TYPES
+    USE lmdz_xios, ONLY: xios_field_is_active,using_xios
+  implicit none
+  type(cosp_config),intent(out) :: cfg
+  integer :: i
+
+ logical :: Lradar_sim,Llidar_sim,Lisccp_sim,Lmodis_sim,Lmisr_sim,Lrttov_sim, Lstats, &
+             Lalbisccp,Latb532,Lboxptopisccp,Lboxtauisccp,LcfadDbze94, &
+             LcfadLidarsr532,Lclcalipso2,Lclcalipso,Lclhcalipso,Lclisccp,Lcllcalipso, &
+             Lclmcalipso,Lcltcalipso,Lcltlidarradar,Lpctisccp,Ldbze94,Ltauisccp,Lcltisccp, & 
+             Lclcalipsoliq,Lclcalipsoice,Lclcalipsoun, &
+             Lclcalipsotmp,Lclcalipsotmpliq,Lclcalipsotmpice,Lclcalipsotmpun, &
+             Lcltcalipsoliq,Lcltcalipsoice,Lcltcalipsoun, &
+             Lclhcalipsoliq,Lclhcalipsoice,Lclhcalipsoun, &
+             Lclmcalipsoliq,Lclmcalipsoice,Lclmcalipsoun, &
+             Lcllcalipsoliq,Lcllcalipsoice,Lcllcalipsoun, &
+             Ltoffset,LparasolRefl,LclMISR,Lmeantbisccp,Lmeantbclrisccp, &
+             Lfracout,LlidarBetaMol532,Ltbrttov, &
+             Lcltmodis,Lclwmodis,Lclimodis,Lclhmodis,Lclmmodis,Lcllmodis, &
+             Ltautmodis,Ltauwmodis,Ltauimodis,Ltautlogmodis, &
+             Ltauwlogmodis,Ltauilogmodis,Lreffclwmodis,Lreffclimodis,Lpctmodis,Llwpmodis, & 
+             Liwpmodis,Lclmodis,Lcrimodis,Lcrlmodis,Lclopaquecalipso,Lclthincalipso, &
+             Lclzopaquecalipso,Lclcalipsoopaque,Lclcalipsothin,Lclcalipsozopaque,Lclcalipsoopacity, &
+             LprofSR,Lproftemp
+        
+  character(len=32) :: out_list(N_OUT_LIST)
+
+  IF (using_xios) THEN
+    
+    do i=1,N_OUT_LIST
+      cfg%out_list(i)=''
+    enddo
+
+    LcfadDbze94   = .false.
+    Lclcalipso2    = .false.
+    Lcltlidarradar = .false. ! Needs radar & lidar
+    Ldbze94        = .false.
+    Lclcalipso2    = .false. ! Needs radar & lidar
+
+    Latb532          = .false.
+    LcfadLidarsr532  = .false.
+    Lclcalipso       = .false.
+    Lclhcalipso      = .false.
+    Lcllcalipso      = .false.
+    Lclmcalipso      = .false.
+    Lcltcalipso      = .false.
+    LparasolRefl     = .false.
+    LlidarBetaMol532 = .false.
+    Lclcalipsoliq       = .false.
+    Lclcalipsoice       = .false.
+    Lclcalipsoun        = .false.
+    Lclcalipsotmp       = .false.
+    Lclcalipsotmpun     = .false.
+    Lclcalipsotmpliq    = .false.
+    Lclcalipsotmpice    = .false.
+    Lclhcalipsoliq      = .false.
+    Lcllcalipsoliq      = .false.
+    Lclmcalipsoliq      = .false.
+    Lcltcalipsoliq      = .false.
+    Lclhcalipsoice      = .false.
+    Lcllcalipsoice      = .false.
+    Lclmcalipsoice      = .false.
+    Lcltcalipsoice      = .false.
+    Lclhcalipsoun       = .false.
+    Lcllcalipsoun       = .false.
+    Lclmcalipsoun       = .false.
+    Lcltcalipsoun       = .false.
+    Lclopaquecalipso    = .false. !OPAQ
+    Lclthincalipso      = .false. !OPAQ
+    Lclzopaquecalipso   = .false. !OPAQ
+    Lclcalipsoopaque    = .false. !OPAQ
+    Lclcalipsothin      = .false. !OPAQ
+    Lclcalipsozopaque   = .false. !OPAQ
+    Lclcalipsoopacity   = .false. !OPAQ
+    LprofSR             = .false. !TIBO
+    Lproftemp           = .false. !TIBO
+
+    Lalbisccp       = .false.
+    Lboxptopisccp   = .false.
+    Lboxtauisccp    = .false.
+    Lclisccp        = .false.
+    Lpctisccp       = .false.
+    Ltauisccp       = .false.
+    Lcltisccp       = .false.
+    Lmeantbisccp    = .false.
+    Lmeantbclrisccp = .false.
+
+    LclMISR = .false.
+
+    Ltbrttov = .false.
+
+    Lcltmodis=.false.
+    Lclwmodis=.false.
+    Lclimodis=.false.
+    Lclhmodis=.false.
+    Lclmmodis=.false.
+    Lcllmodis=.false.
+    Ltautmodis=.false.
+    Ltauwmodis=.false.
+    Ltauimodis=.false.
+    Ltautlogmodis=.false.
+    Ltauwlogmodis=.false.
+    Ltauilogmodis=.false.
+    Lreffclwmodis=.false.
+    Lreffclimodis=.false.
+    Lpctmodis=.false.
+    Llwpmodis=.false.
+    Liwpmodis=.false.
+    Lclmodis=.false.
+    Lcrimodis=.false.
+    Lcrlmodis=.false.
+
+    Lradar_sim=.false.
+    Llidar_sim=.false.
+    Lisccp_sim=.false.
+    Lmodis_sim=.false.
+    Lmisr_sim=.false.
+    Lrttov_sim=.false.
+
+    Lstats=.false.
+!    Ltoffset=.false.
+!    Lfracout=.false.
+!    Lwrite_output=.false.
+
+  IF (is_master) THEN
+! VEREFIER LES CHAMPS DEMANDES DANS .XML
+! 2. Si champs active dans .xml alors mettre la cles de sortie en true
+ IF (xios_field_is_active("cllcalipso")) Lcllcalipso=.TRUE.
+ IF (xios_field_is_active("clmcalipso")) Lclmcalipso=.TRUE.
+ IF (xios_field_is_active("clhcalipso")) Lclhcalipso=.TRUE.
+ IF (xios_field_is_active("cltcalipso")) Lcltcalipso=.TRUE.
+ IF (xios_field_is_active("cllcalipsoice")) Lcllcalipsoice=.TRUE.
+ IF (xios_field_is_active("clmcalipsoice")) Lclmcalipsoice=.TRUE.
+ IF (xios_field_is_active("clhcalipsoice")) Lclhcalipsoice=.TRUE.
+ IF (xios_field_is_active("cltcalipsoice")) Lcltcalipsoice=.TRUE.
+ IF (xios_field_is_active("cllcalipsoliq")) Lcllcalipsoliq=.TRUE.
+ IF (xios_field_is_active("clmcalipsoliq")) Lclmcalipsoliq=.TRUE.
+ IF (xios_field_is_active("clhcalipsoliq")) Lclhcalipsoliq=.TRUE.
+ IF (xios_field_is_active("cltcalipsoliq")) Lcltcalipsoliq=.TRUE.
+ IF (xios_field_is_active("cllcalipsoun")) Lcllcalipsoun=.TRUE.
+ IF (xios_field_is_active("clmcalipsoun")) Lclmcalipsoun=.TRUE.
+ IF (xios_field_is_active("clhcalipsoun")) Lclhcalipsoun=.TRUE.
+ IF (xios_field_is_active("cltcalipsoun")) Lcltcalipsoun=.TRUE.
+ IF (xios_field_is_active("clcalipso")) Lclcalipso=.TRUE.
+ IF (xios_field_is_active("clcalipsoice")) Lclcalipsoice=.TRUE.
+ IF (xios_field_is_active("clcalipsoliq")) Lclcalipsoliq=.TRUE.
+ IF (xios_field_is_active("clcalipsoun")) Lclcalipsoun=.TRUE.
+ IF (xios_field_is_active("clcalipsotmp")) Lclcalipsotmp=.TRUE.
+ IF (xios_field_is_active("clcalipsotmpice")) Lclcalipsotmpice=.TRUE.
+ IF (xios_field_is_active("clcalipsotmpliq")) Lclcalipsotmpliq=.TRUE.
+ IF (xios_field_is_active("clcalipsotmpun")) Lclcalipsotmpun=.TRUE.
+ IF (xios_field_is_active("parasol_refl")) LparasolRefl=.TRUE.
+! IF (xios_field_is_active("parasol_crefl")) cfg%LparasolRefl=.TRUE.
+! IF (xios_field_is_active("Ncrefl")) cfg%LparasolRefl=.TRUE.
+ IF (xios_field_is_active("cfad_lidarsr532")) LcfadLidarsr532=.TRUE.
+ IF (xios_field_is_active("atb532")) Latb532=.TRUE.
+ IF (xios_field_is_active("beta_mol532")) LlidarBetaMol532=.TRUE.
+ IF (xios_field_is_active("clopaquecalipso")) Lclopaquecalipso=.TRUE.
+ IF (xios_field_is_active("clthincalipso")) Lclthincalipso=.TRUE.
+ IF (xios_field_is_active("clzopaquecalipso")) Lclzopaquecalipso=.TRUE.
+ IF (xios_field_is_active("clcalipsoopaque")) Lclcalipsoopaque=.TRUE.
+ IF (xios_field_is_active("clcalipsothin")) Lclcalipsothin=.TRUE.
+ IF (xios_field_is_active("clcalipsozopaque")) Lclcalipsozopaque=.TRUE.
+ IF (xios_field_is_active("clcalipsoopacity")) Lclcalipsoopacity=.TRUE.
+ IF (xios_field_is_active("proftemp")) Lproftemp=.TRUE.
+ IF (xios_field_is_active("profSR")) LprofSR=.TRUE.
+!!!! 38 champ Calipso
+
+ IF (xios_field_is_active("cfadDbze94")) LcfadDbze94=.TRUE.
+ IF (xios_field_is_active("dbze94")) Ldbze94=.TRUE.
+!!! 2 champs CLOUDSAT
+
+ IF (xios_field_is_active("cltlidarradar")) Lcltlidarradar=.TRUE.
+ IF (xios_field_is_active("clcalipso2")) Lclcalipso2=.TRUE.
+!!! 2 champs CLOUDSAT et CALIPSO
+
+ IF (xios_field_is_active("clisccp2")) Lclisccp=.TRUE.
+ IF (xios_field_is_active("boxtauisccp")) Lboxtauisccp=.TRUE.
+ IF (xios_field_is_active("boxptopisccp")) Lboxptopisccp=.TRUE.
+ IF (xios_field_is_active("tclisccp")) Lcltisccp=.TRUE.
+ IF (xios_field_is_active("ctpisccp")) Lpctisccp=.TRUE.
+ IF (xios_field_is_active("tauisccp")) Ltauisccp=.TRUE.
+ IF (xios_field_is_active("albisccp")) Lalbisccp=.TRUE.
+ IF (xios_field_is_active("meantbisccp")) Lmeantbisccp=.TRUE.
+ IF (xios_field_is_active("meantbclrisccp")) Lmeantbclrisccp=.TRUE.
+!!! 9 champs ISCCP
+
+ IF (xios_field_is_active("clMISR")) LclMISR=.TRUE.
+!!! 1 champs MISR
+
+ IF (xios_field_is_active("cllmodis")) Lcllmodis=.TRUE.
+ IF (xios_field_is_active("clmmodis")) Lclmmodis=.TRUE.
+ IF (xios_field_is_active("clhmodis")) Lclhmodis=.TRUE.
+ IF (xios_field_is_active("cltmodis")) Lcltmodis=.TRUE.
+ IF (xios_field_is_active("clwmodis")) Lclwmodis=.TRUE.
+ IF (xios_field_is_active("climodis")) Lclimodis=.TRUE.
+ IF (xios_field_is_active("tautmodis")) Ltautmodis=.TRUE.
+ IF (xios_field_is_active("tauwmodis")) Ltauwmodis=.TRUE.
+ IF (xios_field_is_active("tauimodis")) Ltauimodis=.TRUE.
+ IF (xios_field_is_active("tautlogmodis")) Ltautlogmodis=.TRUE.
+ IF (xios_field_is_active("tauilogmodis")) Ltauilogmodis=.TRUE.
+ IF (xios_field_is_active("tauwlogmodis")) Ltauwlogmodis=.TRUE.
+ IF (xios_field_is_active("reffclwmodis")) Lreffclwmodis=.TRUE.
+ IF (xios_field_is_active("reffclimodis")) Lreffclimodis=.TRUE.
+ IF (xios_field_is_active("pctmodis")) Lpctmodis=.TRUE.
+ IF (xios_field_is_active("lwpmodis")) Llwpmodis=.TRUE.
+ IF (xios_field_is_active("iwpmodis")) Liwpmodis=.TRUE.
+ IF (xios_field_is_active("clmodis")) Lclmodis=.TRUE.
+ IF (xios_field_is_active("crimodis")) Lcrimodis=.TRUE.
+ IF (xios_field_is_active("crlmodis")) Lcrlmodis=.TRUE.
+!!! 20 champs MODIS
+! IF (xios_field_is_active("tbrttov")) cfg%Ltbrttov=.TRUE.
+
+! 2.  si champs demande alors activer le simulateur correspondant
+   IF (xios_field_is_active("cllcalipso").OR. &
+       xios_field_is_active("clmcalipso").OR. &
+       xios_field_is_active("clhcalipso").OR. &
+       xios_field_is_active("cltcalipso").OR. &
+       xios_field_is_active("cllcalipsoice").OR. &
+       xios_field_is_active("clmcalipsoice").OR. &
+       xios_field_is_active("clhcalipsoice").OR. &
+       xios_field_is_active("cltcalipsoice").OR. &
+       xios_field_is_active("cllcalipsoliq").OR. &
+       xios_field_is_active("clmcalipsoliq").OR. &
+       xios_field_is_active("clhcalipsoliq").OR. &
+       xios_field_is_active("cltcalipsoliq").OR. &
+       xios_field_is_active("cllcalipsoun").OR. &
+       xios_field_is_active("clmcalipsoun").OR. &
+       xios_field_is_active("clhcalipsoun").OR. &
+       xios_field_is_active("cltcalipsoun").OR. &
+       xios_field_is_active("clcalipso").OR. &
+       xios_field_is_active("clcalipsoice").OR. &
+       xios_field_is_active("clcalipsoliq").OR. &
+       xios_field_is_active("clcalipsoun").OR. &
+       xios_field_is_active("clcalipsotmp").OR. &
+       xios_field_is_active("clcalipsotmpice").OR. &
+       xios_field_is_active("clcalipsotmpliq").OR. &
+       xios_field_is_active("clcalipsotmpun").OR. &
+       xios_field_is_active("parasol_refl").OR. &
+       xios_field_is_active("cfad_lidarsr532").OR. &
+       xios_field_is_active("atb532").OR. &
+       xios_field_is_active("beta_mol532").OR. &
+       xios_field_is_active("clopaquecalipso").OR. &
+       xios_field_is_active("clthincalipso").OR. &
+       xios_field_is_active("clzopaquecalipso").OR. &
+       xios_field_is_active("clcalipsoopaque").OR. &
+       xios_field_is_active("clcalipsothin").OR. &
+       xios_field_is_active("clcalipsozopaque").OR. &
+       xios_field_is_active("clcalipsoopacity").OR. &
+       xios_field_is_active("proftemp").OR. &
+       xios_field_is_active("profSR")) Llidar_sim=.TRUE.
+
+    IF (xios_field_is_active("cfadDbze94").OR. &
+      xios_field_is_active("dbze94")) Lradar_sim=.TRUE.
+
+    IF (xios_field_is_active("cltlidarradar").OR. &
+      xios_field_is_active("clcalipso2")) THEN
+               Lradar_sim=.TRUE.
+               Llidar_sim=.TRUE.
+    ENDIF
+
+    IF (xios_field_is_active("clisccp2").OR. &
+       xios_field_is_active("boxtauisccp").OR. &
+       xios_field_is_active("boxptopisccp").OR. &
+       xios_field_is_active("tclisccp").OR. &
+       xios_field_is_active("ctpisccp").OR. &
+       xios_field_is_active("tauisccp").OR. &
+       xios_field_is_active("albisccp").OR. &
+       xios_field_is_active("meantbisccp").OR. &
+       xios_field_is_active("meantbclrisccp")) Lisccp_sim=.TRUE.
+
+    IF (xios_field_is_active("clMISR")) Lmisr_sim=.TRUE.
+
+    IF (xios_field_is_active("cllmodis").OR. &
+       xios_field_is_active("clmmodis").OR. &
+       xios_field_is_active("clhmodis").OR. &
+       xios_field_is_active("cltmodis").OR. &
+       xios_field_is_active("clwmodis").OR. &
+       xios_field_is_active("climodis").OR. &
+       xios_field_is_active("tautmodis").OR. &
+       xios_field_is_active("tauwmodis").OR. &
+       xios_field_is_active("tauimodis").OR. &
+       xios_field_is_active("tautlogmodis").OR. &
+       xios_field_is_active("tauilogmodis").OR. &
+       xios_field_is_active("tauwlogmodis").OR. &
+       xios_field_is_active("reffclwmodis").OR. &
+       xios_field_is_active("reffclimodis").OR. &
+       xios_field_is_active("pctmodis").OR. &
+       xios_field_is_active("lwpmodis").OR. &
+       xios_field_is_active("iwpmodis").OR. &
+       xios_field_is_active("clmodis").OR. &
+       xios_field_is_active("crimodis").OR. &
+       xios_field_is_active("crlmodis")) Lmodis_sim=.TRUE.
+
+  ENDIF !   (is_master) 
+!$OMP BARRIER
+
+  CALL bcast(Lradar_sim)
+  CALL bcast(Llidar_sim)
+  CALL bcast(Lisccp_sim)
+  CALL bcast(Lmodis_sim)
+  CALL bcast(Lmisr_sim)
+  CALL bcast(Lrttov_sim)
+
+  CALL bcast(Lstats)
+
+  CALL bcast(Lalbisccp)
+  CALL bcast(Latb532)
+  CALL bcast(Lboxptopisccp)
+  CALL bcast(Lboxtauisccp)
+  CALL bcast(LcfadDbze94)
+  CALL bcast(LcfadLidarsr532)
+  CALL bcast(Lclcalipso2)
+  CALL bcast(Lclcalipso)
+  CALL bcast(Lclhcalipso)
+  CALL bcast(Lclcalipsoliq)
+  CALL bcast(Lclcalipsoice)
+  CALL bcast(Lclcalipsoun)
+  CALL bcast(Lclcalipsotmp)
+  CALL bcast(Lclcalipsotmpliq)
+  CALL bcast(Lclcalipsotmpice)
+  CALL bcast(Lclcalipsotmpun)
+  CALL bcast(Lcltcalipsoliq)
+  CALL bcast(Lcltcalipsoice)
+  CALL bcast(Lcltcalipsoun)
+  CALL bcast(Lclhcalipsoliq)
+  CALL bcast(Lclhcalipsoice)
+  CALL bcast(Lclhcalipsoun)
+  CALL bcast(Lclmcalipsoliq)
+  CALL bcast(Lclmcalipsoice)
+  CALL bcast(Lclmcalipsoun)
+  CALL bcast(Lcllcalipsoliq)
+  CALL bcast(Lcllcalipsoice)
+  CALL bcast(Lcllcalipsoun)
+  CALL bcast(Lclisccp)
+  CALL bcast(Lcllcalipso)
+  CALL bcast(Lclmcalipso)
+  CALL bcast(Lcltcalipso)
+  CALL bcast(Lcltlidarradar)
+  CALL bcast(Lpctisccp)
+  CALL bcast(Ldbze94)
+  CALL bcast(Ltauisccp)
+  CALL bcast(Lcltisccp)
+  CALL bcast(LparasolRefl)
+  CALL bcast(LclMISR)
+  CALL bcast(Lmeantbisccp)
+  CALL bcast(Lmeantbclrisccp)
+  CALL bcast(Lfracout)
+  CALL bcast(LlidarBetaMol532)
+  CALL bcast(Lcltmodis)
+  CALL bcast(Lclwmodis)
+  CALL bcast(Lclimodis)
+  CALL bcast(Lclhmodis)
+  CALL bcast(Lclmmodis)
+  CALL bcast(Lcllmodis)
+  CALL bcast(Ltautmodis)
+  CALL bcast(Ltauwmodis)
+  CALL bcast(Ltauimodis)
+  CALL bcast(Ltautlogmodis)
+  CALL bcast(Ltauwlogmodis)
+  CALL bcast(Ltauilogmodis)
+  CALL bcast(Lreffclwmodis)
+  CALL bcast(Lreffclimodis)
+  CALL bcast(Lpctmodis)
+  CALL bcast(Llwpmodis)
+  CALL bcast(Liwpmodis)
+  CALL bcast(Lclmodis)
+  CALL bcast(Ltbrttov)
+  CALL bcast(Lcrimodis)
+  CALL bcast(Lcrlmodis)
+  CALL bcast(Lclopaquecalipso)  !OPAQ
+  CALL bcast(Lclthincalipso)    !OPAQ
+  CALL bcast(Lclzopaquecalipso) !OPAQ
+  CALL bcast(Lclcalipsoopaque)  !OPAQ
+  CALL bcast(Lclcalipsothin)    !OPAQ
+  CALL bcast(Lclcalipsozopaque) !OPAQ
+  CALL bcast(Lclcalipsoopacity) !OPAQ
+  CALL bcast(LprofSR)           !TIBO
+  CALL bcast(Lproftemp)         !TIBO
+
+    if (Lmodis_sim) Lisccp_sim = .true.
+    if ((Lradar_sim).or.(Llidar_sim).or.(Lisccp_sim)) Lstats = .true.
+!    IF (xios_field_is_active("tbrttov")) cfg%Lrttov_sim=.TRUE.
+
+  ! Copy diagnostic flags to cfg structure
+  ! ISCCP simulator  
+  cfg%Lalbisccp = Lalbisccp
+  cfg%Latb532 = Latb532
+  cfg%Lboxptopisccp = Lboxptopisccp
+  cfg%Lboxtauisccp = Lboxtauisccp
+  cfg%Lmeantbisccp = Lmeantbisccp
+  cfg%Lmeantbclrisccp = Lmeantbclrisccp
+  cfg%Lclisccp = Lclisccp
+  cfg%Lpctisccp = Lpctisccp
+  cfg%Ltauisccp = Ltauisccp
+  cfg%Lcltisccp = Lcltisccp
+
+! CloudSat simulator  
+  cfg%Ldbze94 = Ldbze94
+  cfg%LcfadDbze94 = LcfadDbze94
+
+! Cloudsat et Calipso
+  cfg%Lclcalipso2 = Lclcalipso2
+  cfg%Lcltlidarradar = Lcltlidarradar
+
+! CALIPSO/PARASOL simulator  
+  cfg%LcfadLidarsr532 = LcfadLidarsr532
+  cfg%Lclcalipso = Lclcalipso
+  cfg%Lclhcalipso = Lclhcalipso
+  cfg%Lcllcalipso = Lcllcalipso
+  cfg%Lclmcalipso = Lclmcalipso
+  cfg%Lcltcalipso = Lcltcalipso
+  cfg%Lclhcalipsoice = Lclhcalipsoice
+  cfg%Lcllcalipsoice = Lcllcalipsoice
+  cfg%Lclmcalipsoice = Lclmcalipsoice
+  cfg%Lcltcalipsoice = Lcltcalipsoice
+  cfg%Lclhcalipsoliq = Lclhcalipsoliq
+  cfg%Lcllcalipsoliq = Lcllcalipsoliq
+  cfg%Lclmcalipsoliq = Lclmcalipsoliq
+  cfg%Lcltcalipsoliq = Lcltcalipsoliq
+  cfg%Lclhcalipsoun = Lclhcalipsoun
+  cfg%Lcllcalipsoun = Lcllcalipsoun
+  cfg%Lclmcalipsoun = Lclmcalipsoun
+  cfg%Lcltcalipsoun = Lcltcalipsoun
+  cfg%Lclcalipsoice = Lclcalipsoice
+  cfg%Lclcalipsoliq = Lclcalipsoliq
+  cfg%Lclcalipsoun = Lclcalipsoun
+  cfg%Lclcalipsotmp = Lclcalipsotmp
+  cfg%Lclcalipsotmpice = Lclcalipsotmpice
+  cfg%Lclcalipsotmpliq = Lclcalipsotmpliq
+  cfg%Lclcalipsotmpun = Lclcalipsotmpun
+  cfg%LparasolRefl = LparasolRefl
+  cfg%Lclopaquecalipso  = Lclopaquecalipso  !OPAQ
+  cfg%Lclthincalipso    = Lclthincalipso    !OPAQ
+  cfg%Lclzopaquecalipso = Lclzopaquecalipso !OPAQ
+  cfg%Lclcalipsoopaque  = Lclcalipsoopaque  !OPAQ
+  cfg%Lclcalipsothin    = Lclcalipsothin    !OPAQ
+  cfg%Lclcalipsozopaque = Lclcalipsozopaque !OPAQ
+  cfg%Lclcalipsoopacity = Lclcalipsoopacity !OPAQ
+  cfg%LprofSR           = LprofSR           !TIBO
+  cfg%Lproftemp         = Lproftemp         !TIBO
+  cfg%LlidarBetaMol532 = LlidarBetaMol532
+
+! MISR simulator  
+  cfg%LclMISR = LclMISR
+
+! RTTOV
+  cfg%Ltbrttov = Ltbrttov
+
+! MODIS simulator  
+  cfg%Lcltmodis=Lcltmodis
+  cfg%Lclwmodis=Lclwmodis
+  cfg%Lclimodis=Lclimodis
+  cfg%Lclhmodis=Lclhmodis
+  cfg%Lclmmodis=Lclmmodis
+  cfg%Lcllmodis=Lcllmodis
+  cfg%Ltautmodis=Ltautmodis
+  cfg%Ltauwmodis=Ltauwmodis
+  cfg%Ltauimodis=Ltauimodis
+  cfg%Ltautlogmodis=Ltautlogmodis
+  cfg%Ltauwlogmodis=Ltauwlogmodis
+  cfg%Ltauilogmodis=Ltauilogmodis
+  cfg%Lreffclwmodis=Lreffclwmodis
+  cfg%Lreffclimodis=Lreffclimodis
+  cfg%Lpctmodis=Lpctmodis
+  cfg%Llwpmodis=Llwpmodis
+  cfg%Liwpmodis=Liwpmodis
+  cfg%Lclmodis=Lclmodis
+  cfg%Lcrimodis=Lcrimodis
+  cfg%Lcrlmodis=Lcrlmodis
+
+! Others
+!  cfg%Lwrite_output=Lwrite_output
+!  cfg%Ltoffset=Ltoffset
+!  cfg%Lfracout=Lfracout
+  cfg%Lstats = Lstats
+
+! Copy instrument flags to cfg structure
+  cfg%Lradar_sim = Lradar_sim
+  cfg%Llidar_sim = Llidar_sim
+  cfg%Lisccp_sim = Lisccp_sim
+  cfg%Lmodis_sim = Lmodis_sim
+  cfg%Lmisr_sim  = Lmisr_sim
+  cfg%Lrttov_sim = Lrttov_sim
+
+ ENDIF ! using_xios
+
+  END SUBROUTINE read_xiosfieldactive
+
+END MODULE cosp_read_otputkeys
Index: DZ6/trunk/libf/phylmd/cosp/dsd.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cosp/dsd.F90	(revision 5267)
+++ 	(revision )
@@ -1,397 +1,0 @@
-!
-! $Id$
-!
-  subroutine dsd(Q,Re_,Np,D,N,nsizes,dtype,rho_a,tk, &
-             dmin,dmax,apm,bpm,rho_c,p1,p2,p3)
-  use array_lib
-  use math_lib 
-  implicit none
-
-! Purpose:
-!   Create a discrete drop size distribution
-!
-!   Starting with Quickbeam V3, this routine now allows input of 
-!   both effective radius (Re) and total number concentration (Nt)
-!   Roj Marchand July 2010
-!
-!   The version in Quickbeam v.104 was modified to allow Re but not Nt 
-!   This is a significantly modified form for the version      
-!
-!   Originally Part of QuickBeam v1.03 by John Haynes
-!   http://reef.atmos.colostate.edu/haynes/radarsim
-!
-! Inputs:
-!
-!   [Q]        hydrometeor mixing ratio (g/kg)
-!   [Re]       Optional Effective Radius (microns).  0 = use defaults (p1, p2, p3)
-!
-!   [D]        array of discrete drop sizes (um) where we desire to know the number concentraiton n(D).
-!   [nsizes]   number of elements of [D]
-!
-!   [dtype]    distribution type
-!   [rho_a]    ambient air density (kg m^-3)
-!   [tk]       temperature (K)
-!   [dmin]     minimum size cutoff (um)
-!   [dmax]     maximum size cutoff (um)
-!   [rho_c]    alternate constant density (kg m^-3)
-!   [p1],[p2],[p3]  distribution parameters
-!
-! Input/Output:
-!   [apm]      a parameter for mass (kg m^[-bpm])
-!   [bmp]      b params for mass
-!
-! Outputs:
-!   [N]        discrete concentrations (cm^-3 um^-1)
-!              or, for monodisperse, a constant (1/cm^3)
-!
-! Requires:
-!   function infind
-!
-! Created:
-!   11/28/05  John Haynes (haynes@atmos.colostate.edu)
-! Modified:
-!   01/31/06  Port from IDL to Fortran 90
-!   07/07/06  Rewritten for variable DSD's
-!   10/02/06  Rewritten using scaling factors (Roger Marchand and JMH), Re added V1.04
-!   July 2020 "N Scale factors" (variable fc) removed (Roj Marchand).
- 
-! ----- INPUTS -----  
-  
-  integer, intent(in) :: nsizes
-  integer, intent(in) :: dtype
-  real*8, intent(in)  :: Q,Re_,Np,D(nsizes)
-  real*8, intent(in)  :: rho_a,tk,dmin,dmax,rho_c,p1,p2,p3
-    
-  real*8, intent(inout) :: apm,bpm  
-  
-! ----- OUTPUTS -----
-
-  real*8, intent(out) :: N(nsizes)
-  
-! ----- INTERNAL -----
- 
-   real*8 :: fc(nsizes)
-
-  real*8 :: &
-  N0,D0,vu,local_np,dm,ld, &            ! gamma, exponential variables
-  dmin_mm,dmax_mm,ahp,bhp, &        ! power law variables
-  rg,log_sigma_g, &         ! lognormal variables
-  rho_e                 ! particle density (kg m^-3)
-  
-  real*8 :: tmp1, tmp2
-  real*8 :: pi,rc,tc
-  real*8 :: Re
-
-  integer k,lidx,uidx
-
-  Re = Re_
-
-  tc = tk - 273.15
-  pi = acos(-1.0)
-  
-  ! // if density is constant, store equivalent values for apm and bpm
-  if ((rho_c > 0) .and. (apm < 0)) then
-    apm = (pi/6)*rho_c
-    bpm = 3.
-  endif
-  
-  ! will preferentially use Re input over Np.
-  ! if only Np given then calculate Re
-  ! if neigher than use other defaults (p1,p2,p3) following quickbeam documentation
-  if(Re==0 .and. Np>0) then
-    
-        call calc_Re(Q,Np,rho_a, &
-             dtype,dmin,dmax,apm,bpm,rho_c,p1,p2,p3, &
-             Re)
-  endif
- 
-  
-  select case(dtype)
-  
-! ---------------------------------------------------------!
-! // modified gamma                                        !
-! ---------------------------------------------------------!
-! :: np = total number concentration
-! :: D0 = characteristic diameter (um)
-! :: dm = mean diameter (um) - first moment over zeroth moment
-! :: vu = distribution width parameter
-
-  case(1)  
-  
-    if( abs(p3+2) < 1E-8) then
-  
-    if( Np>1E-30) then
-    
-        ! Morrison scheme with Martin 1994 shape parameter (NOTE: vu = pc +1)
-        ! fixed Roj. Dec. 2010 -- after comment by S. Mcfarlane
-        vu = (1/(0.2714 + 0.00057145*Np*rho_a*1E-6))**2.0 ! units of Nt = Np*rhoa = #/cm^3
-    else
-        print *, 'Error: Must specify a value for Np in each volume', &
-             ' with Morrison/Martin Scheme.'
-            stop    
-    endif
-    
-    elseif (abs(p3+1) > 1E-8) then
-
-      ! vu is fixed in hp structure  
-      vu = p3 
-
-    else
-
-      ! vu isn't specified
-      
-      print *, 'Error: Must specify a value for vu for Modified Gamma distribution'
-      stop    
-      
-    endif
-      
-      if(Re>0) then
-
-    D0 = 2.0*Re*gamma(vu+2)/gamma(vu+3)
-   
-        fc = ( &
-             ((D*1E-6)**(vu-1)*exp(-1*D/D0)) / &
-             (apm*((D0*1E-6)**(vu+bpm))*gamma(vu+bpm)) &
-         ) * 1E-12
-
-        N = fc*rho_a*(Q*1E-3)
-        
-      elseif( p2+1 > 1E-8) then     ! use default value for MEAN diameter
-      
-        dm = p2
-    D0 = gamma(vu)/gamma(vu+1)*dm
-
-        fc = ( &
-             ((D*1E-6)**(vu-1)*exp(-1*D/D0)) / &
-             (apm*((D0*1E-6)**(vu+bpm))*gamma(vu+bpm)) &
-         ) * 1E-12
-
-        N = fc*rho_a*(Q*1E-3)
-        
-      elseif(abs(p3+1) > 1E-8)  then! use default number concentration
-    
-        local_np = p1 ! total number concentration / pa check
-   
-    tmp1 = (Q*1E-3)**(1./bpm)
-      
-        fc = (D*1E-6 / (gamma(vu)/(apm*local_np*gamma(vu+bpm)))** &
-             (1./bpm))**vu
-         
-        N = ( &
-          (rho_a*local_np*fc*(D*1E-6)**(-1.))/(gamma(vu)*tmp1**vu) * &
-          exp(-1.*fc**(1./vu)/tmp1) &
-      ) * 1E-12
-
-      else
-      
-        print *, 'Error:  No default value for Dm or Np provided!  '
-        stop
-        
-      endif
-    
-    
-! ---------------------------------------------------------!
-! // exponential                                           !
-! ---------------------------------------------------------!
-! :: N0 = intercept parameter (m^-4)
-! :: ld = slope parameter (um)
-
-  case(2)
- 
-    if(Re>0) then
- 
-        ld = 1.5/Re   ! units 1/um
-        
-    fc = (ld*1E6)**(1.+bpm)/(apm*gamma(1+bpm))* &
-               exp(-1.*(ld*1E6)*(D*1E-6))*1E-12
-     
-        N = fc*rho_a*(Q*1E-3)
-        
-    elseif (abs(p1+1) > 1E-8) then
-
-    ! use N0 default value
-    
-        N0 = p1
-
-        tmp1 = 1./(1.+bpm)
-  
-        fc = ((apm*gamma(1.+bpm)*N0)**tmp1)*(D*1E-6)
-  
-        N = ( &
-            N0*exp(-1.*fc*(1./(rho_a*Q*1E-3))**tmp1) &
-    ) * 1E-12
-
-    elseif (abs(p2+1) > 1E-8) then
-
-    !     used default value for lambda 
-        ld = p2
-
-        fc = (ld*1E6)**(1.+bpm)/(apm*gamma(1+bpm))* &
-             exp(-1.*(ld*1E6)*(D*1E-6))*1E-12
-     
-        N = fc*rho_a*(Q*1E-3)
-
-    else
-
-      !  ld "parameterized" from temperature (carry over from original Quickbeam).
-      ld = 1220*10.**(-0.0245*tc)*1E-6
-      N0 = ((ld*1E6)**(1+bpm)*Q*1E-3*rho_a)/(apm*gamma(1+bpm))
-    
-      N = ( &
-          N0*exp(-1*ld*D) &
-          ) * 1E-12
-    
-    endif
-  
-! ---------------------------------------------------------!
-! // power law                                             !
-! ---------------------------------------------------------!
-! :: ahp = Ar parameter (m^-4 mm^-bhp)
-! :: bhp = br parameter
-! :: dmin_mm = lower bound (mm)
-! :: dmax_mm = upper bound (mm)
-
-  case(3)
-  
-    if(Re>0) then
-        print *, 'Variable Re not supported for ', &
-         'Power-Law distribution'
-    stop
-    elseif(Np>0) then
-        print *, 'Variable Np not supported for ', &
-         'Power-Law distribution'
-    stop
-    endif
-
-!   :: br parameter
-    if (abs(p1+2) < 1E-8) then
-!     :: if p1=-2, bhp is parameterized according to Ryan (2000),
-!     :: applicatable to cirrus clouds
-      if (tc < -30) then
-        bhp = -1.75+0.09*((tc+273)-243.16)
-      elseif ((tc >= -30) .and. (tc < -9)) then
-        bhp = -3.25-0.06*((tc+273)-265.66)
-      else
-        bhp = -2.15
-      endif
-    elseif (abs(p1+3) < 1E-8) then      
-!     :: if p1=-3, bhp is parameterized according to Ryan (2000),
-!     :: applicable to frontal clouds
-      if (tc < -35) then
-        bhp = -1.75+0.09*((tc+273)-243.16)
-      elseif ((tc >= -35) .and. (tc < -17.5)) then
-        bhp = -2.65+0.09*((tc+273)-255.66)
-      elseif ((tc >= -17.5) .and. (tc < -9)) then
-        bhp = -3.25-0.06*((tc+273)-265.66)
-      else
-        bhp = -2.15
-      endif    
-    else
-!     :: otherwise the specified value is used
-      bhp = p1
-    endif
-
-!   :: Ar parameter
-    dmin_mm = dmin*1E-3
-    dmax_mm = dmax*1E-3
-
-!   :: commented lines are original method with constant density
-      ! rc = 500.       ! (kg/m^3)
-      ! tmp1 = 6*rho_a*(bhp+4)
-      ! tmp2 = pi*rc*(dmax_mm**(bhp+4))*(1-(dmin_mm/dmax_mm)**(bhp+4))
-      ! ahp = (Q*1E-3)*1E12*tmp1/tmp2
-
-!   :: new method is more consistent with the rest of the distributions
-!   :: and allows density to vary with particle size
-      tmp1 = rho_a*(Q*1E-3)*(bhp+bpm+1)
-      tmp2 = apm*(dmax_mm**bhp*dmax**(bpm+1)-dmin_mm**bhp*dmin**(bpm+1))
-      ahp = tmp1/tmp2 * 1E24
-      ! ahp = tmp1/tmp2 
- 
-      lidx = infind(D,dmin)
-      uidx = infind(D,dmax)    
-      do k=lidx,uidx
- 
-        N(k) = ( &
-        ahp*(D(k)*1E-3)**bhp &
-    ) * 1E-12    
-
-      enddo
-
-    ! print *,'test=',ahp,bhp,ahp/(rho_a*Q),D(100),N(100),bpm,dmin_mm,dmax_mm
-
-! ---------------------------------------------------------!
-! // monodisperse                                          !
-! ---------------------------------------------------------!
-! :: D0 = particle diameter (um)
-
-  case(4)
-  
-    if (Re>0) then
-        D0 = Re
-    else
-        D0 = p1
-    endif
-    
-      rho_e = (6/pi)*apm*(D0*1E-6)**(bpm-3)
-      fc(1) = (6./(pi*D0**3*rho_e))*1E12
-      N(1) = fc(1)*rho_a*(Q*1E-3)
-    
-! ---------------------------------------------------------!
-! // lognormal                                             !
-! ---------------------------------------------------------!
-! :: N0 = total number concentration (m^-3)
-! :: np = fixed number concentration (kg^-1)
-! :: rg = mean radius (um)
-! :: log_sigma_g = ln(geometric standard deviation)
-
-  case(5)
-    if (abs(p1+1) < 1E-8 .or. Re>0 ) then
-
-!     // rg, log_sigma_g are given
-      log_sigma_g = p3
-      tmp2 = (bpm*log_sigma_g)**2.
-      if(Re.le.0) then 
-        rg = p2
-      else
-    rg =Re*exp(-2.5*(log_sigma_g**2))
-      endif
- 
-         fc = 0.5 * ( &
-         (1./((2.*rg*1E-6)**(bpm)*apm*(2.*pi)**(0.5) * &
-         log_sigma_g*D*0.5*1E-6)) * &
-         exp(-0.5*((log(0.5*D/rg)/log_sigma_g)**2.+tmp2)) &
-         ) * 1E-12
-                
-      N = fc*rho_a*(Q*1E-3)
-      
-    elseif (abs(p2+1) < 1E-8 .or. Np>0) then
-
-!     // Np, log_sigma_g are given    
-      if(Np>0) then
-        local_Np=Np
-      else
-        local_Np = p1
-      endif
-      
-      log_sigma_g = p3
-      N0 = local_np*rho_a
-      tmp1 = (rho_a*(Q*1E-3))/(2.**bpm*apm*N0)
-      tmp2 = exp(0.5*bpm**2.*(log_sigma_g))**2.      
-      rg = ((tmp1/tmp2)**(1/bpm))*1E6
-      
-      N = 0.5*( &
-        N0 / ((2.*pi)**(0.5)*log_sigma_g*D*0.5*1E-6) * &
-    exp((-0.5*(log(0.5*D/rg)/log_sigma_g)**2.)) &
-    ) * 1E-12      
-      
-    else
-
-      print *, 'Error: Must specify a value for sigma_g'
-      stop
-    
-    endif
-    
-  end select
-  
-  end subroutine dsd
Index: /LMDZ6/trunk/libf/phylmd/cosp/dsd.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cosp/dsd.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/cosp/dsd.f90	(revision 5268)
@@ -0,0 +1,397 @@
+!
+! $Id$
+!
+  subroutine dsd(Q,Re_,Np,D,N,nsizes,dtype,rho_a,tk, &
+             dmin,dmax,apm,bpm,rho_c,p1,p2,p3)
+  use array_lib
+  use math_lib 
+  implicit none
+
+! Purpose:
+!   Create a discrete drop size distribution
+!
+!   Starting with Quickbeam V3, this routine now allows input of 
+!   both effective radius (Re) and total number concentration (Nt)
+!   Roj Marchand July 2010
+!
+!   The version in Quickbeam v.104 was modified to allow Re but not Nt 
+!   This is a significantly modified form for the version      
+!
+!   Originally Part of QuickBeam v1.03 by John Haynes
+!   http://reef.atmos.colostate.edu/haynes/radarsim
+!
+! Inputs:
+!
+!   [Q]        hydrometeor mixing ratio (g/kg)
+!   [Re]       Optional Effective Radius (microns).  0 = use defaults (p1, p2, p3)
+!
+!   [D]        array of discrete drop sizes (um) where we desire to know the number concentraiton n(D).
+!   [nsizes]   number of elements of [D]
+!
+!   [dtype]    distribution type
+!   [rho_a]    ambient air density (kg m^-3)
+!   [tk]       temperature (K)
+!   [dmin]     minimum size cutoff (um)
+!   [dmax]     maximum size cutoff (um)
+!   [rho_c]    alternate constant density (kg m^-3)
+!   [p1],[p2],[p3]  distribution parameters
+!
+! Input/Output:
+!   [apm]      a parameter for mass (kg m^[-bpm])
+!   [bmp]      b params for mass
+!
+! Outputs:
+!   [N]        discrete concentrations (cm^-3 um^-1)
+!              or, for monodisperse, a constant (1/cm^3)
+!
+! Requires:
+!   function infind
+!
+! Created:
+!   11/28/05  John Haynes (haynes@atmos.colostate.edu)
+! Modified:
+!   01/31/06  Port from IDL to Fortran 90
+!   07/07/06  Rewritten for variable DSD's
+!   10/02/06  Rewritten using scaling factors (Roger Marchand and JMH), Re added V1.04
+!   July 2020 "N Scale factors" (variable fc) removed (Roj Marchand).
+ 
+! ----- INPUTS -----  
+  
+  integer, intent(in) :: nsizes
+  integer, intent(in) :: dtype
+  real*8, intent(in)  :: Q,Re_,Np,D(nsizes)
+  real*8, intent(in)  :: rho_a,tk,dmin,dmax,rho_c,p1,p2,p3
+    
+  real*8, intent(inout) :: apm,bpm  
+  
+! ----- OUTPUTS -----
+
+  real*8, intent(out) :: N(nsizes)
+  
+! ----- INTERNAL -----
+ 
+   real*8 :: fc(nsizes)
+
+  real*8 :: &
+  N0,D0,vu,local_np,dm,ld, &            ! gamma, exponential variables
+  dmin_mm,dmax_mm,ahp,bhp, &        ! power law variables
+  rg,log_sigma_g, &         ! lognormal variables
+  rho_e                 ! particle density (kg m^-3)
+  
+  real*8 :: tmp1, tmp2
+  real*8 :: pi,rc,tc
+  real*8 :: Re
+
+  integer k,lidx,uidx
+
+  Re = Re_
+
+  tc = tk - 273.15
+  pi = acos(-1.0)
+  
+  ! // if density is constant, store equivalent values for apm and bpm
+  if ((rho_c > 0) .and. (apm < 0)) then
+    apm = (pi/6)*rho_c
+    bpm = 3.
+  endif
+  
+  ! will preferentially use Re input over Np.
+  ! if only Np given then calculate Re
+  ! if neigher than use other defaults (p1,p2,p3) following quickbeam documentation
+  if(Re==0 .and. Np>0) then
+    
+        call calc_Re(Q,Np,rho_a, &
+             dtype,dmin,dmax,apm,bpm,rho_c,p1,p2,p3, &
+             Re)
+  endif
+ 
+  
+  select case(dtype)
+  
+! ---------------------------------------------------------!
+! // modified gamma                                        !
+! ---------------------------------------------------------!
+! :: np = total number concentration
+! :: D0 = characteristic diameter (um)
+! :: dm = mean diameter (um) - first moment over zeroth moment
+! :: vu = distribution width parameter
+
+  case(1)  
+  
+    if( abs(p3+2) < 1E-8) then
+  
+    if( Np>1E-30) then
+    
+        ! Morrison scheme with Martin 1994 shape parameter (NOTE: vu = pc +1)
+        ! fixed Roj. Dec. 2010 -- after comment by S. Mcfarlane
+        vu = (1/(0.2714 + 0.00057145*Np*rho_a*1E-6))**2.0 ! units of Nt = Np*rhoa = #/cm^3
+    else
+        print *, 'Error: Must specify a value for Np in each volume', &
+             ' with Morrison/Martin Scheme.'
+            stop    
+    endif
+    
+    elseif (abs(p3+1) > 1E-8) then
+
+      ! vu is fixed in hp structure  
+      vu = p3 
+
+    else
+
+      ! vu isn't specified
+      
+      print *, 'Error: Must specify a value for vu for Modified Gamma distribution'
+      stop    
+      
+    endif
+      
+      if(Re>0) then
+
+    D0 = 2.0*Re*gamma(vu+2)/gamma(vu+3)
+   
+        fc = ( &
+             ((D*1E-6)**(vu-1)*exp(-1*D/D0)) / &
+             (apm*((D0*1E-6)**(vu+bpm))*gamma(vu+bpm)) &
+         ) * 1E-12
+
+        N = fc*rho_a*(Q*1E-3)
+        
+      elseif( p2+1 > 1E-8) then     ! use default value for MEAN diameter
+      
+        dm = p2
+    D0 = gamma(vu)/gamma(vu+1)*dm
+
+        fc = ( &
+             ((D*1E-6)**(vu-1)*exp(-1*D/D0)) / &
+             (apm*((D0*1E-6)**(vu+bpm))*gamma(vu+bpm)) &
+         ) * 1E-12
+
+        N = fc*rho_a*(Q*1E-3)
+        
+      elseif(abs(p3+1) > 1E-8)  then! use default number concentration
+    
+        local_np = p1 ! total number concentration / pa check
+   
+    tmp1 = (Q*1E-3)**(1./bpm)
+      
+        fc = (D*1E-6 / (gamma(vu)/(apm*local_np*gamma(vu+bpm)))** &
+             (1./bpm))**vu
+         
+        N = ( &
+          (rho_a*local_np*fc*(D*1E-6)**(-1.))/(gamma(vu)*tmp1**vu) * &
+          exp(-1.*fc**(1./vu)/tmp1) &
+      ) * 1E-12
+
+      else
+      
+        print *, 'Error:  No default value for Dm or Np provided!  '
+        stop
+        
+      endif
+    
+    
+! ---------------------------------------------------------!
+! // exponential                                           !
+! ---------------------------------------------------------!
+! :: N0 = intercept parameter (m^-4)
+! :: ld = slope parameter (um)
+
+  case(2)
+ 
+    if(Re>0) then
+ 
+        ld = 1.5/Re   ! units 1/um
+        
+    fc = (ld*1E6)**(1.+bpm)/(apm*gamma(1+bpm))* &
+               exp(-1.*(ld*1E6)*(D*1E-6))*1E-12
+     
+        N = fc*rho_a*(Q*1E-3)
+        
+    elseif (abs(p1+1) > 1E-8) then
+
+    ! use N0 default value
+    
+        N0 = p1
+
+        tmp1 = 1./(1.+bpm)
+  
+        fc = ((apm*gamma(1.+bpm)*N0)**tmp1)*(D*1E-6)
+  
+        N = ( &
+            N0*exp(-1.*fc*(1./(rho_a*Q*1E-3))**tmp1) &
+    ) * 1E-12
+
+    elseif (abs(p2+1) > 1E-8) then
+
+    !     used default value for lambda 
+        ld = p2
+
+        fc = (ld*1E6)**(1.+bpm)/(apm*gamma(1+bpm))* &
+             exp(-1.*(ld*1E6)*(D*1E-6))*1E-12
+     
+        N = fc*rho_a*(Q*1E-3)
+
+    else
+
+      !  ld "parameterized" from temperature (carry over from original Quickbeam).
+      ld = 1220*10.**(-0.0245*tc)*1E-6
+      N0 = ((ld*1E6)**(1+bpm)*Q*1E-3*rho_a)/(apm*gamma(1+bpm))
+    
+      N = ( &
+          N0*exp(-1*ld*D) &
+          ) * 1E-12
+    
+    endif
+  
+! ---------------------------------------------------------!
+! // power law                                             !
+! ---------------------------------------------------------!
+! :: ahp = Ar parameter (m^-4 mm^-bhp)
+! :: bhp = br parameter
+! :: dmin_mm = lower bound (mm)
+! :: dmax_mm = upper bound (mm)
+
+  case(3)
+  
+    if(Re>0) then
+        print *, 'Variable Re not supported for ', &
+         'Power-Law distribution'
+    stop
+    elseif(Np>0) then
+        print *, 'Variable Np not supported for ', &
+         'Power-Law distribution'
+    stop
+    endif
+
+!   :: br parameter
+    if (abs(p1+2) < 1E-8) then
+!     :: if p1=-2, bhp is parameterized according to Ryan (2000),
+!     :: applicatable to cirrus clouds
+      if (tc < -30) then
+        bhp = -1.75+0.09*((tc+273)-243.16)
+      elseif ((tc >= -30) .and. (tc < -9)) then
+        bhp = -3.25-0.06*((tc+273)-265.66)
+      else
+        bhp = -2.15
+      endif
+    elseif (abs(p1+3) < 1E-8) then      
+!     :: if p1=-3, bhp is parameterized according to Ryan (2000),
+!     :: applicable to frontal clouds
+      if (tc < -35) then
+        bhp = -1.75+0.09*((tc+273)-243.16)
+      elseif ((tc >= -35) .and. (tc < -17.5)) then
+        bhp = -2.65+0.09*((tc+273)-255.66)
+      elseif ((tc >= -17.5) .and. (tc < -9)) then
+        bhp = -3.25-0.06*((tc+273)-265.66)
+      else
+        bhp = -2.15
+      endif    
+    else
+!     :: otherwise the specified value is used
+      bhp = p1
+    endif
+
+!   :: Ar parameter
+    dmin_mm = dmin*1E-3
+    dmax_mm = dmax*1E-3
+
+!   :: commented lines are original method with constant density
+      ! rc = 500.       ! (kg/m^3)
+      ! tmp1 = 6*rho_a*(bhp+4)
+      ! tmp2 = pi*rc*(dmax_mm**(bhp+4))*(1-(dmin_mm/dmax_mm)**(bhp+4))
+      ! ahp = (Q*1E-3)*1E12*tmp1/tmp2
+
+!   :: new method is more consistent with the rest of the distributions
+!   :: and allows density to vary with particle size
+      tmp1 = rho_a*(Q*1E-3)*(bhp+bpm+1)
+      tmp2 = apm*(dmax_mm**bhp*dmax**(bpm+1)-dmin_mm**bhp*dmin**(bpm+1))
+      ahp = tmp1/tmp2 * 1E24
+      ! ahp = tmp1/tmp2 
+ 
+      lidx = infind(D,dmin)
+      uidx = infind(D,dmax)    
+      do k=lidx,uidx
+ 
+        N(k) = ( &
+        ahp*(D(k)*1E-3)**bhp &
+    ) * 1E-12    
+
+      enddo
+
+    ! print *,'test=',ahp,bhp,ahp/(rho_a*Q),D(100),N(100),bpm,dmin_mm,dmax_mm
+
+! ---------------------------------------------------------!
+! // monodisperse                                          !
+! ---------------------------------------------------------!
+! :: D0 = particle diameter (um)
+
+  case(4)
+  
+    if (Re>0) then
+        D0 = Re
+    else
+        D0 = p1
+    endif
+    
+      rho_e = (6/pi)*apm*(D0*1E-6)**(bpm-3)
+      fc(1) = (6./(pi*D0**3*rho_e))*1E12
+      N(1) = fc(1)*rho_a*(Q*1E-3)
+    
+! ---------------------------------------------------------!
+! // lognormal                                             !
+! ---------------------------------------------------------!
+! :: N0 = total number concentration (m^-3)
+! :: np = fixed number concentration (kg^-1)
+! :: rg = mean radius (um)
+! :: log_sigma_g = ln(geometric standard deviation)
+
+  case(5)
+    if (abs(p1+1) < 1E-8 .or. Re>0 ) then
+
+!     // rg, log_sigma_g are given
+      log_sigma_g = p3
+      tmp2 = (bpm*log_sigma_g)**2.
+      if(Re.le.0) then 
+        rg = p2
+      else
+    rg =Re*exp(-2.5*(log_sigma_g**2))
+      endif
+ 
+         fc = 0.5 * ( &
+         (1./((2.*rg*1E-6)**(bpm)*apm*(2.*pi)**(0.5) * &
+         log_sigma_g*D*0.5*1E-6)) * &
+         exp(-0.5*((log(0.5*D/rg)/log_sigma_g)**2.+tmp2)) &
+         ) * 1E-12
+                
+      N = fc*rho_a*(Q*1E-3)
+      
+    elseif (abs(p2+1) < 1E-8 .or. Np>0) then
+
+!     // Np, log_sigma_g are given    
+      if(Np>0) then
+        local_Np=Np
+      else
+        local_Np = p1
+      endif
+      
+      log_sigma_g = p3
+      N0 = local_np*rho_a
+      tmp1 = (rho_a*(Q*1E-3))/(2.**bpm*apm*N0)
+      tmp2 = exp(0.5*bpm**2.*(log_sigma_g))**2.      
+      rg = ((tmp1/tmp2)**(1/bpm))*1E6
+      
+      N = 0.5*( &
+        N0 / ((2.*pi)**(0.5)*log_sigma_g*D*0.5*1E-6) * &
+    exp((-0.5*(log(0.5*D/rg)/log_sigma_g)**2.)) &
+    ) * 1E-12      
+      
+    else
+
+      print *, 'Error: Must specify a value for sigma_g'
+      stop
+    
+    endif
+    
+  end select
+  
+  end subroutine dsd
Index: DZ6/trunk/libf/phylmd/cosp/format_input.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cosp/format_input.F90	(revision 5267)
+++ 	(revision )
@@ -1,134 +1,0 @@
-! $Revision: 23 $, $Date: 2011-03-31 15:41:37 +0200 (jeu. 31 mars 2011) $
-! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/quickbeam/format_input.f90 $
-! FORMAT_INPUT: Procedures to prepare data for input to the simulator
-! Compiled/Modified:
-!   08/28/2006  John Haynes (haynes@atmos.colostate.edu)
-!
-! irreg_to_grid (subroutine)
-! order_data (subroutine)
-
-  module format_input
-
-  contains
-
-! ----------------------------------------------------------------------------
-! SUBROUTINE IRREG_TO_GRID
-! ----------------------------------------------------------------------------
-  subroutine irreg_to_grid(hgt_matrix,t_matrix,p_matrix,rh_matrix, &
-    env_hgt_matrix,env_t_matrix,env_p_matrix,env_rh_matrix)
-  use array_lib
-  implicit none
-
-! Purpose:
-!   Linearly interpolate sounding-level data to the hydrometeor-level
-!   resolution
-!
-! Inputs:
-!   [hgt_matrix]       hydrometeor-level heights
-!   [env_hgt_matrix]   sounding-level heights
-!   [env_t_matrix]     sounding-level temperatures
-!   [env_p_matrix]     sounding-level pressures
-!   [env_rh_matrix]    sounding-level relative humidities
-!
-! Outputs:
-!   [t_matrix]         hydrometeor-level temperatures
-!   [p_matrix]         hydrometeor-level pressures
-!   [rh_matrix]        hydrometeor-level relative humidities
-!
-! Created:
-!   08/28/2006  John Haynes (haynes@atmos.colostate.edu)
-
-! ----- INPUTS -----
-  real*8, dimension(:,:), intent(in) :: &
-    hgt_matrix,env_hgt_matrix,env_t_matrix,env_p_matrix,env_rh_matrix
-
-! ----- OUTPUTS -----
-  real*8, dimension(:,:), intent(out) :: &
-    t_matrix,p_matrix,rh_matrix
-
-! ----- INTERNAL -----
-  integer :: nprof, i
-  integer,parameter :: KR8 = selected_real_kind(15,300)
-
-  nprof = size(hgt_matrix,1)
-  do i=1,nprof
-    call lin_interpolate(env_t_matrix(i,:),env_hgt_matrix(i,:), &
-      t_matrix(i,:),hgt_matrix(i,:),1000._KR8)
-    call lin_interpolate(env_p_matrix(i,:),env_hgt_matrix(i,:), &
-      p_matrix(i,:),hgt_matrix(i,:),1000._KR8)
-    call lin_interpolate(env_rh_matrix(i,:),env_hgt_matrix(i,:), &
-      rh_matrix(i,:),hgt_matrix(i,:),1000._KR8)
-  enddo
-
-  end subroutine irreg_to_grid
-
-! ----------------------------------------------------------------------------
-! SUBROUTINE ORDER_DATA
-! ----------------------------------------------------------------------------
-  subroutine order_data(hgt_matrix,hm_matrix,p_matrix,t_matrix, &
-    rh_matrix,sfc_radar,hgt_reversed)
-  implicit none
-
-! Purpose:
-!   Ensure that input data is in top-down order/bottom-up order,
-!   for space-based/surface based radars, respectively
-!
-! Inputs:
-!   [hgt_matrix]   heights
-!   [hm_matrix]    mixing ratios
-!   [t_matrix]     temperatures
-!   [p_matrix]     pressures
-!   [rh_matrix]    relative humidities
-!   [sfc_radar]    1=surface radar, 0=spaceborne
-!
-! Outputs:
-!   [hgt_matrix],[hm_matrix],[p_matrix,[t_matrix],[rh_matrix] in proper
-!   order for input to the radar simulator routine
-!   [hgt_reversed]   T=heights were reordered,F=heights were not reordered
-!
-! Note:
-!   The order for all profiles is assumed to the same as the first profile.
-!
-! Created:
-!   08/28/2006  John Haynes (haynes@atmos.colostate.edu)
-
-! ----- INPUTS -----
-  integer, intent(in) :: sfc_radar
-
-! ----- OUTPUTS -----
-  real*8, dimension(:,:), intent(inout) :: &
-    hgt_matrix,p_matrix,t_matrix,rh_matrix
-  real*8, dimension(:,:,:), intent(inout) :: &
-    hm_matrix
-  logical, intent(out) :: hgt_reversed
-
-! ----- INTERNAL -----
-  integer :: ngate
-  logical :: hgt_descending
-  
-
-  ngate = size(hgt_matrix,2)
-  hgt_descending = hgt_matrix(1,1) > hgt_matrix(1,ngate)
-      
-! :: surface: heights must be ascending
-! :: space-based: heights must be descending
-  if ( &
-     (sfc_radar == 1 .and. hgt_descending) .or.  &
-     (sfc_radar == 0 .and. (.not. hgt_descending)) &
-     ) &
-  then
-
-    hgt_matrix(:,:) = hgt_matrix(:,ngate:1:-1)
-    hm_matrix(:,:,:) = hm_matrix(:,:,ngate:1:-1)
-    p_matrix(:,:) = p_matrix(:,ngate:1:-1)
-    t_matrix(:,:) = t_matrix(:,ngate:1:-1)
-    rh_matrix(:,:) = rh_matrix(:,ngate:1:-1) 
-
-    hgt_reversed = .true.
-  else
-    hgt_reversed = .false.
-  endif
-
-  end subroutine order_data
-
-  end module format_input
Index: /LMDZ6/trunk/libf/phylmd/cosp/format_input.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cosp/format_input.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/cosp/format_input.f90	(revision 5268)
@@ -0,0 +1,134 @@
+! $Revision: 23 $, $Date: 2011-03-31 15:41:37 +0200 (jeu. 31 mars 2011) $
+! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/quickbeam/format_input.f90 $
+! FORMAT_INPUT: Procedures to prepare data for input to the simulator
+! Compiled/Modified:
+!   08/28/2006  John Haynes (haynes@atmos.colostate.edu)
+!
+! irreg_to_grid (subroutine)
+! order_data (subroutine)
+
+  module format_input
+
+  contains
+
+! ----------------------------------------------------------------------------
+! SUBROUTINE IRREG_TO_GRID
+! ----------------------------------------------------------------------------
+  subroutine irreg_to_grid(hgt_matrix,t_matrix,p_matrix,rh_matrix, &
+    env_hgt_matrix,env_t_matrix,env_p_matrix,env_rh_matrix)
+  use array_lib
+  implicit none
+
+! Purpose:
+!   Linearly interpolate sounding-level data to the hydrometeor-level
+!   resolution
+!
+! Inputs:
+!   [hgt_matrix]       hydrometeor-level heights
+!   [env_hgt_matrix]   sounding-level heights
+!   [env_t_matrix]     sounding-level temperatures
+!   [env_p_matrix]     sounding-level pressures
+!   [env_rh_matrix]    sounding-level relative humidities
+!
+! Outputs:
+!   [t_matrix]         hydrometeor-level temperatures
+!   [p_matrix]         hydrometeor-level pressures
+!   [rh_matrix]        hydrometeor-level relative humidities
+!
+! Created:
+!   08/28/2006  John Haynes (haynes@atmos.colostate.edu)
+
+! ----- INPUTS -----
+  real*8, dimension(:,:), intent(in) :: &
+    hgt_matrix,env_hgt_matrix,env_t_matrix,env_p_matrix,env_rh_matrix
+
+! ----- OUTPUTS -----
+  real*8, dimension(:,:), intent(out) :: &
+    t_matrix,p_matrix,rh_matrix
+
+! ----- INTERNAL -----
+  integer :: nprof, i
+  integer,parameter :: KR8 = selected_real_kind(15,300)
+
+  nprof = size(hgt_matrix,1)
+  do i=1,nprof
+    call lin_interpolate(env_t_matrix(i,:),env_hgt_matrix(i,:), &
+      t_matrix(i,:),hgt_matrix(i,:),1000._KR8)
+    call lin_interpolate(env_p_matrix(i,:),env_hgt_matrix(i,:), &
+      p_matrix(i,:),hgt_matrix(i,:),1000._KR8)
+    call lin_interpolate(env_rh_matrix(i,:),env_hgt_matrix(i,:), &
+      rh_matrix(i,:),hgt_matrix(i,:),1000._KR8)
+  enddo
+
+  end subroutine irreg_to_grid
+
+! ----------------------------------------------------------------------------
+! SUBROUTINE ORDER_DATA
+! ----------------------------------------------------------------------------
+  subroutine order_data(hgt_matrix,hm_matrix,p_matrix,t_matrix, &
+    rh_matrix,sfc_radar,hgt_reversed)
+  implicit none
+
+! Purpose:
+!   Ensure that input data is in top-down order/bottom-up order,
+!   for space-based/surface based radars, respectively
+!
+! Inputs:
+!   [hgt_matrix]   heights
+!   [hm_matrix]    mixing ratios
+!   [t_matrix]     temperatures
+!   [p_matrix]     pressures
+!   [rh_matrix]    relative humidities
+!   [sfc_radar]    1=surface radar, 0=spaceborne
+!
+! Outputs:
+!   [hgt_matrix],[hm_matrix],[p_matrix,[t_matrix],[rh_matrix] in proper
+!   order for input to the radar simulator routine
+!   [hgt_reversed]   T=heights were reordered,F=heights were not reordered
+!
+! Note:
+!   The order for all profiles is assumed to the same as the first profile.
+!
+! Created:
+!   08/28/2006  John Haynes (haynes@atmos.colostate.edu)
+
+! ----- INPUTS -----
+  integer, intent(in) :: sfc_radar
+
+! ----- OUTPUTS -----
+  real*8, dimension(:,:), intent(inout) :: &
+    hgt_matrix,p_matrix,t_matrix,rh_matrix
+  real*8, dimension(:,:,:), intent(inout) :: &
+    hm_matrix
+  logical, intent(out) :: hgt_reversed
+
+! ----- INTERNAL -----
+  integer :: ngate
+  logical :: hgt_descending
+  
+
+  ngate = size(hgt_matrix,2)
+  hgt_descending = hgt_matrix(1,1) > hgt_matrix(1,ngate)
+      
+! :: surface: heights must be ascending
+! :: space-based: heights must be descending
+  if ( &
+     (sfc_radar == 1 .and. hgt_descending) .or.  &
+     (sfc_radar == 0 .and. (.not. hgt_descending)) &
+     ) &
+  then
+
+    hgt_matrix(:,:) = hgt_matrix(:,ngate:1:-1)
+    hm_matrix(:,:,:) = hm_matrix(:,:,ngate:1:-1)
+    p_matrix(:,:) = p_matrix(:,ngate:1:-1)
+    t_matrix(:,:) = t_matrix(:,ngate:1:-1)
+    rh_matrix(:,:) = rh_matrix(:,ngate:1:-1) 
+
+    hgt_reversed = .true.
+  else
+    hgt_reversed = .false.
+  endif
+
+  end subroutine order_data
+
+  end module format_input
Index: DZ6/trunk/libf/phylmd/cosp/gases.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cosp/gases.F90	(revision 5267)
+++ 	(revision )
@@ -1,177 +1,0 @@
-! $Revision: 88 $, $Date: 2013-11-13 15:08:38 +0100 (mer. 13 nov. 2013) $
-! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/quickbeam/gases.f90 $
-  function gases(PRES_mb,T,RH,f)
-  implicit none
-  
-! Purpose:
-!   Compute 2-way gaseous attenuation through a volume in microwave
-!
-! Inputs:
-!   [PRES_mb]   pressure (mb) (hPa)
-!   [T]         temperature (K)
-!   [RH]        relative humidity (%)
-!   [f]         frequency (GHz), < 300 GHz
-!
-! Returns:
-!   2-way gaseous attenuation (dB/km)
-!
-! Reference:
-!   Uses method of Liebe (1985)
-!
-! Created:
-!   12/09/05  John Haynes (haynes@atmos.colostate.edu)
-! Modified:
-!   01/31/06  Port from IDL to Fortran 90
-
-  integer, parameter :: &
-  nbands_o2 = 48 ,&
-  nbands_h2o = 30
-  real*8, intent(in) :: PRES_mb, T, RH, f
-  real*8 :: gases, th, e, p, sumo, gm0, a0, ap, term1, term2, term3, &
-            bf, be, term4, npp
-  real*8, dimension(nbands_o2) :: v0, a1, a2, a3, a4, a5, a6
-  real*8, dimension(nbands_h2o) :: v1, b1, b2, b3
-  real*8 :: e_th,one_th,pth3,eth35,aux1,aux2,aux3,aux4
-  real*8 :: gm,delt,x,y,gm2
-  real*8 :: fpp_o2,fpp_h2o,s_o2,s_h2o
-  integer :: i
-  
-! // table1 parameters  v0, a1, a2, a3, a4, a5, a6  
-  data v0/49.4523790,49.9622570,50.4742380,50.9877480,51.5033500, &
-  52.0214090,52.5423930,53.0669060,53.5957480,54.1299999,54.6711570, &
-  55.2213650,55.7838000,56.2647770,56.3378700,56.9681000,57.6124810, &
-  58.3238740,58.4465890,59.1642040,59.5909820,60.3060570,60.4347750, &
-  61.1505580,61.8001520,62.4112120,62.4862530,62.9979740,63.5685150, &
-  64.1277640,64.6789000,65.2240670,65.7647690,66.3020880,66.8368270, &
-  67.3695950,67.9008620,68.4310010,68.9603060,69.4890210,70.0173420, &
-  118.7503410,368.4983500,424.7631200,487.2493700,715.3931500, &
-  773.8387300, 834.1453300/
-  data a1/0.0000001,0.0000003,0.0000009,0.0000025,0.0000061,0.0000141, &
-  0.0000310,0.0000641,0.0001247,0.0002280,0.0003918,0.0006316,0.0009535, &
-  0.0005489,0.0013440,0.0017630,0.0000213,0.0000239,0.0000146,0.0000240, &
-  0.0000211,0.0000212,0.0000246,0.0000250,0.0000230,0.0000193,0.0000152, &
-  0.0000150,0.0000109,0.0007335,0.0004635,0.0002748,0.0001530,0.0000801, &
-  0.0000395,0.0000183,0.0000080,0.0000033,0.0000013,0.0000005,0.0000002, &
-  0.0000094,0.0000679,0.0006380,0.0002350,0.0000996,0.0006710,0.0001800/
-  data a2/11.8300000,10.7200000,9.6900000,8.8900000,7.7400000,6.8400000, &
-  6.0000000,5.2200000,4.4800000,3.8100000,3.1900000,2.6200000,2.1150000, &
-  0.0100000,1.6550000,1.2550000,0.9100000,0.6210000,0.0790000,0.3860000, &
-  0.2070000,0.2070000,0.3860000,0.6210000,0.9100000,1.2550000,0.0780000, &
-  1.6600000,2.1100000,2.6200000,3.1900000,3.8100000,4.4800000,5.2200000, &
-  6.0000000,6.8400000,7.7400000,8.6900000,9.6900000,10.7200000,11.8300000, &
-  0.0000000,0.0200000,0.0110000,0.0110000,0.0890000,0.0790000,0.0790000/
-  data a3/0.0083000,0.0085000,0.0086000,0.0087000,0.0089000,0.0092000, &
-  0.0094000,0.0097000,0.0100000,0.0102000,0.0105000,0.0107900,0.0111000, &
-  0.0164600,0.0114400,0.0118100,0.0122100,0.0126600,0.0144900,0.0131900, &
-  0.0136000,0.0138200,0.0129700,0.0124800,0.0120700,0.0117100,0.0146800, &
-  0.0113900,0.0110800,0.0107800,0.0105000,0.0102000,0.0100000,0.0097000, &
-  0.0094000,0.0092000,0.0089000,0.0087000,0.0086000,0.0085000,0.0084000, &
-  0.0159200,0.0192000,0.0191600,0.0192000,0.0181000,0.0181000,0.0181000/
-  data a4/0.0000000,0.0000000,0.0000000,0.0000000,0.0000000,0.0000000, &
-  0.0000000,0.0000000,0.0000000,0.0000000,0.0000000,0.0000000,0.0000000, &
-  0.0000000,0.0000000,0.0000000,0.0000000,0.0000000,0.0000000,0.0000000, &
-  0.0000000,0.0000000,0.0000000,0.0000000,0.0000000,0.0000000,0.0000000, &
-  0.0000000,0.0000000,0.0000000,0.0000000,0.0000000,0.0000000,0.0000000, &
-  0.0000000,0.0000000,0.0000000,0.0000000,0.0000000,0.0000000,0.0000000, &
-  0.0000000,0.6000000,0.6000000,0.6000000,0.6000000,0.6000000,0.6000000/
-  data a5/0.0056000,0.0056000,0.0056000,0.0055000,0.0056000,0.0055000, &
-  0.0057000,0.0053000,0.0054000,0.0048000,0.0048000,0.0041700,0.0037500, &
-  0.0077400,0.0029700,0.0021200,0.0009400,-0.0005500,0.0059700,-0.0024400, &
-  0.0034400,-0.0041300,0.0013200,-0.0003600,-0.0015900,-0.0026600, &
-  -0.0047700,-0.0033400,-0.0041700,-0.0044800,-0.0051000,-0.0051000, &
-  -0.0057000,-0.0055000,-0.0059000,-0.0056000,-0.0058000,-0.0057000, &
-  -0.0056000,-0.0056000,-0.0056000,-0.0004400,0.0000000,0.0000000, &
-  0.0000000,0.0000000,0.0000000,0.0000000/
-  data a6/1.7000000,1.7000000,1.7000000,1.7000000,1.8000000,1.8000000,&
-  1.8000000,1.9000000,1.8000000,2.0000000,1.9000000,2.1000000,2.1000000, &
-  0.9000000,2.3000000,2.5000000,3.7000000,-3.1000000,0.8000000,0.1000000, &
-  0.5000000,0.7000000,-1.0000000,5.8000000,2.9000000,2.3000000,0.9000000, &
-  2.2000000,2.0000000,2.0000000,1.8000000,1.9000000,1.8000000,1.8000000, &
-  1.7000000,1.8000000,1.7000000,1.7000000,1.7000000,1.7000000,1.7000000, &
-  0.9000000,1.0000000,1.0000000,1.0000000,1.0000000,1.0000000,1.0000000/
-
-! // table2 parameters  v1, b1, b2, b3
-  data v1/22.2350800,67.8139600,119.9959400,183.3101170,321.2256440, &
-  325.1529190,336.1870000,380.1973720,390.1345080,437.3466670,439.1508120, &
-  443.0182950,448.0010750,470.8889740,474.6891270,488.4911330,503.5685320, &
-  504.4826920,556.9360020,620.7008070,658.0065000,752.0332270,841.0735950, &
-  859.8650000,899.4070000,902.5550000,906.2055240,916.1715820,970.3150220, &
-  987.9267640/
-  data b1/0.1090000,0.0011000,0.0007000,2.3000000,0.0464000,1.5400000, &
-  0.0010000,11.9000000,0.0044000,0.0637000,0.9210000,0.1940000,10.6000000, &
-  0.3300000,1.2800000,0.2530000,0.0374000,0.0125000,510.0000000,5.0900000, &
-  0.2740000,250.0000000,0.0130000,0.1330000,0.0550000,0.0380000,0.1830000, &
-  8.5600000,9.1600000,138.0000000/
-  data b2/2.1430000,8.7300000,8.3470000,0.6530000,6.1560000,1.5150000, &
-  9.8020000,1.0180000,7.3180000,5.0150000,3.5610000,5.0150000,1.3700000, &
-  3.5610000,2.3420000,2.8140000,6.6930000,6.6930000,0.1140000,2.1500000, &
-  7.7670000,0.3360000,8.1130000,7.9890000,7.8450000,8.3600000,5.0390000, &
-  1.3690000,1.8420000,0.1780000/
-  data b3/0.0278400,0.0276000,0.0270000,0.0283500,0.0214000,0.0270000, &
-  0.0265000,0.0276000,0.0190000,0.0137000,0.0164000,0.0144000,0.0238000, &
-  0.0182000,0.0198000,0.0249000,0.0115000,0.0119000,0.0300000,0.0223000, &
-  0.0300000,0.0286000,0.0141000,0.0286000,0.0286000,0.0264000,0.0234000, &
-  0.0253000,0.0240000,0.0286000/
-  
-! // conversions
-  th = 300./T       ! unitless
-  e = (RH*th**5)/(41.45*10**(9.834*th-10))   ! kPa
-  p = PRES_mb/10.-e ! kPa
-  e_th = e*th
-  one_th = 1 - th
-  pth3 = p*th**(3)
-  eth35 = e*th**(3.5)
-
-! // term1
-  sumo = 0.
-  aux1 = 1.1*e_th
-  do i=1,nbands_o2
-    aux2 = f/v0(i)
-    aux3 = v0(i)-f
-    aux4 = v0(i)+f
-    gm = a3(i)*(p*th**(0.8-a4(i))+aux1)
-    gm2 = gm**2
-    delt = a5(i)*p*th**a6(i)
-    x = aux3**2+gm2
-    y = aux4**2+gm2
-    fpp_o2 = (((1./x)+(1./y))*(gm*aux2) - (delt*aux2)*((aux3/(x))-(aux4/(x))))
-    s_o2 = a1(i)*pth3*exp(a2(i)*one_th)
-    sumo = sumo + fpp_o2 * s_o2
-  enddo
-  term1 = sumo
-
-! // term2
-  gm0 = 5.6E-3*(p+1.1*e)*th**(0.8)
-  a0 = 3.07E-4
-  ap = 1.4*(1-1.2*f**(1.5)*1E-5)*1E-10
-  term2 = (2*a0*(gm0*(1+(f/gm0)**2)*(1+(f/60.)**2))**(-1) + ap*p*th**(2.5)) &
-          * f*p*th**2
-
-! // term3
-  sumo = 0.
-  aux1 = 4.8*e_th
-  do i=1,nbands_h2o
-    aux2 = f/v1(i)
-    aux3 = v1(i)-f
-    aux4 = v1(i)+f
-    gm = b3(i)*(p*th**(0.8)+aux1)
-    gm2 = gm**2
-    x = aux3**2+gm2
-    y = aux4**2+gm2
-    !delt = 0.
-    fpp_h2o = ((1./x)+(1./y))*(gm*aux2) ! - (delt*aux2)*((aux3/(x))-(aux4/(x)))
-    s_h2o = b1(i)*eth35*exp(b2(i)*one_th)
-    sumo = sumo + fpp_h2o * s_h2o
-  enddo
-  term3 = sumo
-
-! // term4
-  bf = 1.4E-6
-  be = 5.41E-5
-  term4 = (bf*p+be*e*th**3)*f*e*th**(2.5)
-
-! // summation and result
-  npp = term1 + term2 + term3 + term4
-  gases = 0.182*f*npp
-
-  end function gases
Index: /LMDZ6/trunk/libf/phylmd/cosp/gases.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cosp/gases.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/cosp/gases.f90	(revision 5268)
@@ -0,0 +1,177 @@
+! $Revision: 88 $, $Date: 2013-11-13 15:08:38 +0100 (mer. 13 nov. 2013) $
+! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/quickbeam/gases.f90 $
+  function gases(PRES_mb,T,RH,f)
+  implicit none
+  
+! Purpose:
+!   Compute 2-way gaseous attenuation through a volume in microwave
+!
+! Inputs:
+!   [PRES_mb]   pressure (mb) (hPa)
+!   [T]         temperature (K)
+!   [RH]        relative humidity (%)
+!   [f]         frequency (GHz), < 300 GHz
+!
+! Returns:
+!   2-way gaseous attenuation (dB/km)
+!
+! Reference:
+!   Uses method of Liebe (1985)
+!
+! Created:
+!   12/09/05  John Haynes (haynes@atmos.colostate.edu)
+! Modified:
+!   01/31/06  Port from IDL to Fortran 90
+
+  integer, parameter :: &
+  nbands_o2 = 48 ,&
+  nbands_h2o = 30
+  real*8, intent(in) :: PRES_mb, T, RH, f
+  real*8 :: gases, th, e, p, sumo, gm0, a0, ap, term1, term2, term3, &
+            bf, be, term4, npp
+  real*8, dimension(nbands_o2) :: v0, a1, a2, a3, a4, a5, a6
+  real*8, dimension(nbands_h2o) :: v1, b1, b2, b3
+  real*8 :: e_th,one_th,pth3,eth35,aux1,aux2,aux3,aux4
+  real*8 :: gm,delt,x,y,gm2
+  real*8 :: fpp_o2,fpp_h2o,s_o2,s_h2o
+  integer :: i
+  
+! // table1 parameters  v0, a1, a2, a3, a4, a5, a6  
+  data v0/49.4523790,49.9622570,50.4742380,50.9877480,51.5033500, &
+  52.0214090,52.5423930,53.0669060,53.5957480,54.1299999,54.6711570, &
+  55.2213650,55.7838000,56.2647770,56.3378700,56.9681000,57.6124810, &
+  58.3238740,58.4465890,59.1642040,59.5909820,60.3060570,60.4347750, &
+  61.1505580,61.8001520,62.4112120,62.4862530,62.9979740,63.5685150, &
+  64.1277640,64.6789000,65.2240670,65.7647690,66.3020880,66.8368270, &
+  67.3695950,67.9008620,68.4310010,68.9603060,69.4890210,70.0173420, &
+  118.7503410,368.4983500,424.7631200,487.2493700,715.3931500, &
+  773.8387300, 834.1453300/
+  data a1/0.0000001,0.0000003,0.0000009,0.0000025,0.0000061,0.0000141, &
+  0.0000310,0.0000641,0.0001247,0.0002280,0.0003918,0.0006316,0.0009535, &
+  0.0005489,0.0013440,0.0017630,0.0000213,0.0000239,0.0000146,0.0000240, &
+  0.0000211,0.0000212,0.0000246,0.0000250,0.0000230,0.0000193,0.0000152, &
+  0.0000150,0.0000109,0.0007335,0.0004635,0.0002748,0.0001530,0.0000801, &
+  0.0000395,0.0000183,0.0000080,0.0000033,0.0000013,0.0000005,0.0000002, &
+  0.0000094,0.0000679,0.0006380,0.0002350,0.0000996,0.0006710,0.0001800/
+  data a2/11.8300000,10.7200000,9.6900000,8.8900000,7.7400000,6.8400000, &
+  6.0000000,5.2200000,4.4800000,3.8100000,3.1900000,2.6200000,2.1150000, &
+  0.0100000,1.6550000,1.2550000,0.9100000,0.6210000,0.0790000,0.3860000, &
+  0.2070000,0.2070000,0.3860000,0.6210000,0.9100000,1.2550000,0.0780000, &
+  1.6600000,2.1100000,2.6200000,3.1900000,3.8100000,4.4800000,5.2200000, &
+  6.0000000,6.8400000,7.7400000,8.6900000,9.6900000,10.7200000,11.8300000, &
+  0.0000000,0.0200000,0.0110000,0.0110000,0.0890000,0.0790000,0.0790000/
+  data a3/0.0083000,0.0085000,0.0086000,0.0087000,0.0089000,0.0092000, &
+  0.0094000,0.0097000,0.0100000,0.0102000,0.0105000,0.0107900,0.0111000, &
+  0.0164600,0.0114400,0.0118100,0.0122100,0.0126600,0.0144900,0.0131900, &
+  0.0136000,0.0138200,0.0129700,0.0124800,0.0120700,0.0117100,0.0146800, &
+  0.0113900,0.0110800,0.0107800,0.0105000,0.0102000,0.0100000,0.0097000, &
+  0.0094000,0.0092000,0.0089000,0.0087000,0.0086000,0.0085000,0.0084000, &
+  0.0159200,0.0192000,0.0191600,0.0192000,0.0181000,0.0181000,0.0181000/
+  data a4/0.0000000,0.0000000,0.0000000,0.0000000,0.0000000,0.0000000, &
+  0.0000000,0.0000000,0.0000000,0.0000000,0.0000000,0.0000000,0.0000000, &
+  0.0000000,0.0000000,0.0000000,0.0000000,0.0000000,0.0000000,0.0000000, &
+  0.0000000,0.0000000,0.0000000,0.0000000,0.0000000,0.0000000,0.0000000, &
+  0.0000000,0.0000000,0.0000000,0.0000000,0.0000000,0.0000000,0.0000000, &
+  0.0000000,0.0000000,0.0000000,0.0000000,0.0000000,0.0000000,0.0000000, &
+  0.0000000,0.6000000,0.6000000,0.6000000,0.6000000,0.6000000,0.6000000/
+  data a5/0.0056000,0.0056000,0.0056000,0.0055000,0.0056000,0.0055000, &
+  0.0057000,0.0053000,0.0054000,0.0048000,0.0048000,0.0041700,0.0037500, &
+  0.0077400,0.0029700,0.0021200,0.0009400,-0.0005500,0.0059700,-0.0024400, &
+  0.0034400,-0.0041300,0.0013200,-0.0003600,-0.0015900,-0.0026600, &
+  -0.0047700,-0.0033400,-0.0041700,-0.0044800,-0.0051000,-0.0051000, &
+  -0.0057000,-0.0055000,-0.0059000,-0.0056000,-0.0058000,-0.0057000, &
+  -0.0056000,-0.0056000,-0.0056000,-0.0004400,0.0000000,0.0000000, &
+  0.0000000,0.0000000,0.0000000,0.0000000/
+  data a6/1.7000000,1.7000000,1.7000000,1.7000000,1.8000000,1.8000000,&
+  1.8000000,1.9000000,1.8000000,2.0000000,1.9000000,2.1000000,2.1000000, &
+  0.9000000,2.3000000,2.5000000,3.7000000,-3.1000000,0.8000000,0.1000000, &
+  0.5000000,0.7000000,-1.0000000,5.8000000,2.9000000,2.3000000,0.9000000, &
+  2.2000000,2.0000000,2.0000000,1.8000000,1.9000000,1.8000000,1.8000000, &
+  1.7000000,1.8000000,1.7000000,1.7000000,1.7000000,1.7000000,1.7000000, &
+  0.9000000,1.0000000,1.0000000,1.0000000,1.0000000,1.0000000,1.0000000/
+
+! // table2 parameters  v1, b1, b2, b3
+  data v1/22.2350800,67.8139600,119.9959400,183.3101170,321.2256440, &
+  325.1529190,336.1870000,380.1973720,390.1345080,437.3466670,439.1508120, &
+  443.0182950,448.0010750,470.8889740,474.6891270,488.4911330,503.5685320, &
+  504.4826920,556.9360020,620.7008070,658.0065000,752.0332270,841.0735950, &
+  859.8650000,899.4070000,902.5550000,906.2055240,916.1715820,970.3150220, &
+  987.9267640/
+  data b1/0.1090000,0.0011000,0.0007000,2.3000000,0.0464000,1.5400000, &
+  0.0010000,11.9000000,0.0044000,0.0637000,0.9210000,0.1940000,10.6000000, &
+  0.3300000,1.2800000,0.2530000,0.0374000,0.0125000,510.0000000,5.0900000, &
+  0.2740000,250.0000000,0.0130000,0.1330000,0.0550000,0.0380000,0.1830000, &
+  8.5600000,9.1600000,138.0000000/
+  data b2/2.1430000,8.7300000,8.3470000,0.6530000,6.1560000,1.5150000, &
+  9.8020000,1.0180000,7.3180000,5.0150000,3.5610000,5.0150000,1.3700000, &
+  3.5610000,2.3420000,2.8140000,6.6930000,6.6930000,0.1140000,2.1500000, &
+  7.7670000,0.3360000,8.1130000,7.9890000,7.8450000,8.3600000,5.0390000, &
+  1.3690000,1.8420000,0.1780000/
+  data b3/0.0278400,0.0276000,0.0270000,0.0283500,0.0214000,0.0270000, &
+  0.0265000,0.0276000,0.0190000,0.0137000,0.0164000,0.0144000,0.0238000, &
+  0.0182000,0.0198000,0.0249000,0.0115000,0.0119000,0.0300000,0.0223000, &
+  0.0300000,0.0286000,0.0141000,0.0286000,0.0286000,0.0264000,0.0234000, &
+  0.0253000,0.0240000,0.0286000/
+  
+! // conversions
+  th = 300./T       ! unitless
+  e = (RH*th**5)/(41.45*10**(9.834*th-10))   ! kPa
+  p = PRES_mb/10.-e ! kPa
+  e_th = e*th
+  one_th = 1 - th
+  pth3 = p*th**(3)
+  eth35 = e*th**(3.5)
+
+! // term1
+  sumo = 0.
+  aux1 = 1.1*e_th
+  do i=1,nbands_o2
+    aux2 = f/v0(i)
+    aux3 = v0(i)-f
+    aux4 = v0(i)+f
+    gm = a3(i)*(p*th**(0.8-a4(i))+aux1)
+    gm2 = gm**2
+    delt = a5(i)*p*th**a6(i)
+    x = aux3**2+gm2
+    y = aux4**2+gm2
+    fpp_o2 = (((1./x)+(1./y))*(gm*aux2) - (delt*aux2)*((aux3/(x))-(aux4/(x))))
+    s_o2 = a1(i)*pth3*exp(a2(i)*one_th)
+    sumo = sumo + fpp_o2 * s_o2
+  enddo
+  term1 = sumo
+
+! // term2
+  gm0 = 5.6E-3*(p+1.1*e)*th**(0.8)
+  a0 = 3.07E-4
+  ap = 1.4*(1-1.2*f**(1.5)*1E-5)*1E-10
+  term2 = (2*a0*(gm0*(1+(f/gm0)**2)*(1+(f/60.)**2))**(-1) + ap*p*th**(2.5)) &
+          * f*p*th**2
+
+! // term3
+  sumo = 0.
+  aux1 = 4.8*e_th
+  do i=1,nbands_h2o
+    aux2 = f/v1(i)
+    aux3 = v1(i)-f
+    aux4 = v1(i)+f
+    gm = b3(i)*(p*th**(0.8)+aux1)
+    gm2 = gm**2
+    x = aux3**2+gm2
+    y = aux4**2+gm2
+    !delt = 0.
+    fpp_h2o = ((1./x)+(1./y))*(gm*aux2) ! - (delt*aux2)*((aux3/(x))-(aux4/(x)))
+    s_h2o = b1(i)*eth35*exp(b2(i)*one_th)
+    sumo = sumo + fpp_h2o * s_h2o
+  enddo
+  term3 = sumo
+
+! // term4
+  bf = 1.4E-6
+  be = 5.41E-5
+  term4 = (bf*p+be*e*th**3)*f*e*th**(2.5)
+
+! // summation and result
+  npp = term1 + term2 + term3 + term4
+  gases = 0.182*f*npp
+
+  end function gases
Index: DZ6/trunk/libf/phylmd/cosp/lidar_simulator.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cosp/lidar_simulator.F90	(revision 5267)
+++ 	(revision )
@@ -1,750 +1,0 @@
-! Copyright (c) 2009, Centre National de la Recherche Scientifique
-! All rights reserved.
-! $Revision: 88 $, $Date: 2013-11-13 15:08:38 +0100 (mer. 13 nov. 2013) $
-! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/actsim/lidar_simulator.F90 $
-! 
-! Redistribution and use in source and binary forms, with or without modification, are permitted 
-! provided that the following conditions are met:
-! 
-!     * Redistributions of source code must retain the above copyright notice, this list 
-!       of conditions and the following disclaimer.
-!     * Redistributions in binary form must reproduce the above copyright notice, this list
-!       of conditions and the following disclaimer in the documentation and/or other materials 
-!       provided with the distribution.
-!     * Neither the name of the LMD/IPSL/CNRS/UPMC nor the names of its
-!       contributors may be used to endorse or promote products derived from this software without 
-!       specific prior written permission.
-! 
-! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR 
-! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND 
-! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR 
-! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 
-! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 
-! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER 
-! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT 
-! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-      
-      SUBROUTINE lidar_simulator(npoints,nlev,npart,nrefl &
-                , undef &
-                , pres, presf, temp &
-                , q_lsliq, q_lsice, q_cvliq, q_cvice &
-                , ls_radliq, ls_radice, cv_radliq, cv_radice &
-                , ice_type, pmol, pnorm, pnorm_perp_tot,tautot, refl )
-!
-!---------------------------------------------------------------------------------
-! Purpose: To compute lidar signal from model-simulated profiles of cloud water
-!          and cloud fraction in each sub-column of each model gridbox.
-!
-! References: 
-! Chepfer H., S. Bony, D. Winker, M. Chiriaco, J.-L. Dufresne, G. Seze (2008),
-! Use of CALIPSO lidar observations to evaluate the cloudiness simulated by a 
-! climate model, Geophys. Res. Lett., 35, L15704, doi:10.1029/2008GL034207.
-!
-! Previous references:
-! Chiriaco et al, MWR, 2006; Chepfer et al., MWR, 2007
-!
-! Contacts: Helene Chepfer (chepfer@lmd.polytechnique.fr), Sandrine Bony (bony@lmd.jussieu.fr)
-!
-! May 2007: ActSim code of M. Chiriaco and H. Chepfer rewritten by S. Bony
-!
-! May 2008, H. Chepfer:
-! - Units of pressure inputs: Pa 
-! - Non Spherical particles : LS Ice NS coefficients, CONV Ice NS coefficients
-! - New input: ice_type (0=ice-spheres ; 1=ice-non-spherical)
-!
-! June 2008, A. Bodas-Salcedo:
-! - Ported to Fortran 90 and optimisation changes
-!
-! August 2008, J-L Dufresne:
-! - Optimisation changes (sum instructions suppressed)
-!
-! October 2008, S. Bony,  H. Chepfer and J-L. Dufresne :  
-! - Interface with COSP v2.0:
-!      cloud fraction removed from inputs
-!      in-cloud condensed water now in input (instead of grid-averaged value)
-!      depolarisation diagnostic removed
-!      parasol (polder) reflectances (for 5 different solar zenith angles) added
-!
-! December 2008, S. Bony,  H. Chepfer and J-L. Dufresne : 
-! - Modification of the integration of the lidar equation.
-! - change the cloud detection threshold
-!
-! April 2008, A. Bodas-Salcedo:
-! - Bug fix in computation of pmol and pnorm of upper layer
-!
-! April 2008, J-L. Dufresne
-! - Bug fix in computation of pmol and pnorm, thanks to Masaki Satoh: a factor 2 
-! was missing. This affects the ATB values but not the cloud fraction. 
-!
-! January 2013, G. Cesana and H. Chepfer:
-! - Add the perpendicular component of the backscattered signal (pnorm_perp_tot) in the arguments
-! - Add the temperature for each levels (temp) in the arguments
-! - Add the computation of the perpendicular component of the backscattered lidar signal 
-! Reference: Cesana G. and H. Chepfer (2013): Evaluation of the cloud water phase
-! in a climate model using CALIPSO-GOCCP, J. Geophys. Res., doi: 10.1002/jgrd.50376
-!
-!---------------------------------------------------------------------------------
-!
-! Inputs:
-!  npoints  : number of horizontal points
-!  nlev : number of vertical levels
-!  npart: numberb of cloud meteors (stratiform_liq, stratiform_ice, conv_liq, conv_ice). 
-!        Currently npart must be 4
-!  nrefl: number of solar zenith angles for parasol reflectances
-!  pres : pressure in the middle of atmospheric layers (full levels): Pa
-!  presf: pressure in the interface of atmospheric layers (half levels): Pa
-!     presf(..,1) : surface pressure ; presf(..,nlev+1)= TOA pressure
-!  temp : temperature of atmospheric layers: K
-!  q_lsliq: LS sub-column liquid water mixing ratio (kg/kg)
-!  q_lsice: LS sub-column ice water mixing ratio (kg/kg)
-!  q_cvliq: CONV sub-column liquid water mixing ratio (kg/kg)
-!  q_cvice: CONV sub-column ice water mixing ratio (kg/kg)
-!  ls_radliq: effective radius of LS liquid particles (meters)
-!  ls_radice: effective radius of LS ice particles (meters)
-!  cv_radliq: effective radius of CONV liquid particles (meters)
-!  cv_radice: effective radius of CONV ice particles (meters)
-!  ice_type : ice particle shape hypothesis (ice_type=0 for spheres, ice_type=1 
-!             for non spherical particles)
-!
-! Outputs:
-!  pmol : molecular attenuated backscatter lidar signal power (m^-1.sr^-1)
-!  pnorm: total attenuated backscatter lidar signal power (m^-1.sr^-1)
-!  pnorm_perp_tot: perpendicular attenuated backscatter lidar signal power (m^-1.sr^-1)
-!  tautot: optical thickess integrated from top to level z
-!  refl : parasol(polder) reflectance
-!
-! Version 1.0 (June 2007)
-! Version 1.1 (May 2008)
-! Version 1.2 (June 2008)
-! Version 2.0 (October 2008)
-! Version 2.1 (December 2008)
-!---------------------------------------------------------------------------------
-
-      USE MOD_COSP_CONSTANTS, only : ok_debug_cosp
-      IMPLICIT NONE
-      REAL :: SRsat
-      PARAMETER (SRsat = 0.01) ! threshold full attenuation 
-
-      LOGICAL ok_parasol
-      PARAMETER (ok_parasol=.true.)  ! set to .true. if you want to activate parasol reflectances
-
-      INTEGER i, k
-      
-      INTEGER INDX_LSLIQ,INDX_LSICE,INDX_CVLIQ,INDX_CVICE
-      PARAMETER (INDX_LSLIQ=1,INDX_LSICE=2,INDX_CVLIQ=3,INDX_CVICE=4)
-! inputs:
-      INTEGER npoints,nlev,npart,ice_type
-      INTEGER nrefl
-      real undef                 ! undefined value
-      REAL pres(npoints,nlev)    ! pressure full levels
-      REAL presf(npoints,nlev+1) ! pressure half levels
-      REAL q_lsliq(npoints,nlev), q_lsice(npoints,nlev)
-      REAL q_cvliq(npoints,nlev), q_cvice(npoints,nlev)
-      REAL ls_radliq(npoints,nlev), ls_radice(npoints,nlev)
-      REAL cv_radliq(npoints,nlev), cv_radice(npoints,nlev)
-
-! outputs (for each subcolumn):
-
-      REAL pmol(npoints,nlev)  ! molecular backscatter signal power (m^-1.sr^-1)
-      REAL pnorm(npoints,nlev) ! total lidar backscatter signal power (m^-1.sr^-1)
-      REAL tautot(npoints,nlev)! optical thickess integrated from top
-      REAL refl(npoints,nrefl)! parasol reflectance ! parasol
-
-! actsim variables:
-
-      REAL km, rdiffm, Qscat, Cmol
-      PARAMETER (Cmol = 6.2446e-32) ! depends on wavelength
-      PARAMETER (km = 1.38e-23)     ! Boltzmann constant (J/K)
-
-      PARAMETER (rdiffm = 0.7)      ! multiple scattering correction parameter
-      PARAMETER (Qscat = 2.0)       ! particle scattering efficiency at 532 nm
-
-      REAL rholiq, rhoice
-      PARAMETER (rholiq=1.0e+03)     ! liquid water (kg/m3)
-      PARAMETER (rhoice=0.5e+03)     ! ice (kg/m3)
-
-      REAL pi, rhopart(npart)
-      REAL polpart(npart,5)  ! polynomial coefficients derived for spherical and non spherical
-                             ! particules
-
-!   grid-box variables:
-      REAL rad_part(npoints,nlev,npart)
-      REAL rhoair(npoints,nlev), zheight(npoints,nlev+1)
-      REAL beta_mol(npoints,nlev), alpha_mol(npoints,nlev)
-      REAL kp_part(npoints,nlev,npart)
-
-!   sub-column variables:
-      REAL qpart(npoints,nlev,npart) ! mixing ratio particles in each subcolumn
-      REAL alpha_part(npoints,nlev,npart)
-      REAL tau_mol_lay(npoints)  ! temporary variable, moL. opt. thickness of layer k
-      REAL tau_mol(npoints,nlev) ! optical thickness between TOA and bottom of layer k
-      REAL tau_part(npoints,nlev,npart)
-      REAL betatot(npoints,nlev)
-      REAL tautot_lay(npoints)   ! temporary variable, total opt. thickness of layer k
-!     Optical thickness from TOA to surface for Parasol
-     REAL tautot_S_liq(npoints),tautot_S_ice(npoints)     ! for liq and ice clouds
-
-
-! Local variables
-      REAL Alpha, Beta, Gamma  ! Polynomial coefficient for ATBperp computation
-      REAL temp(npoints,nlev)                   ! temperature of layer k
-      REAL betatot_ice(npoints,nlev)    ! backscatter coefficient for ice particles
-      REAL beta_perp_ice(npoints,nlev)  ! perpendicular backscatter coefficient for ice
-      REAL betatot_liq(npoints,nlev)    ! backscatter coefficient for liquid particles
-      REAL beta_perp_liq(npoints,nlev)  ! perpendicular backscatter coefficient for liq
-      REAL tautot_ice(npoints,nlev)     ! total optical thickness of ice
-      REAL tautot_liq(npoints,nlev)     ! total optical thickness of liq
-      REAL tautot_lay_ice(npoints)    ! total optical thickness of ice in the layer k
-      REAL tautot_lay_liq(npoints)    ! total optical thickness of liq in the layer k
-      REAL pnorm_liq(npoints,nlev)    ! lidar backscattered signal power for liquid
-      REAL pnorm_ice(npoints,nlev)    ! lidar backscattered signal power for ice
-      REAL pnorm_perp_ice(npoints,nlev) ! perpendicular lidar backscattered signal power for ice
-      REAL pnorm_perp_liq(npoints,nlev) ! perpendicular lidar backscattered signal power for liq
-
-      REAL :: seuil 
-
-! Output variable
-      REAL pnorm_perp_tot (npoints,nlev) ! perpendicular lidar backscattered signal power
-
-!------------------------------------------------------------
-!---- 0. Initialisation :
-!------------------------------------------------------------
-betatot_ice(:,:)=0
-betatot_liq(:,:)=0
-beta_perp_ice(:,:)=0
-beta_perp_liq(:,:)=0
-tautot_ice(:,:)=0
-tautot_liq(:,:)=0
-tautot_lay_ice(:)=0;
-tautot_lay_liq(:)=0;
-pnorm_liq(:,:)=0
-pnorm_ice(:,:)=0
-pnorm_perp_ice(:,:)=0
-pnorm_perp_liq(:,:)=0
-pnorm_perp_tot(:,:)=0
-
-
-! Polynomial coefficients (Alpha, Beta, Gamma) which allow to compute the ATBperpendicular
-! as a function of the ATB for ice or liquid cloud particles derived from CALIPSO-GOCCP
-! observations at 120m vertical grid (Cesana and Chepfer, JGR, 2013).
-!
-! Relationship between ATBice and ATBperp,ice for ice particles
-!  ATBperp,ice = Alpha*ATBice 
-         Alpha = 0.2904
-
-! Relationship between ATBice and ATBperp,ice for liquid particles
-!  ATBperp,ice = Beta*ATBice^2 + Gamma*ATBice
-         Beta = 0.4099
-         Gamma = 0.009
-
-  if (ok_debug_cosp) then
-     seuil=1.e-18
-  else
-     seuil=0.0
-  endif 
-!------------------------------------------------------------
-!---- 1. Preliminary definitions and calculations :
-!------------------------------------------------------------
-
-      if ( npart .ne. 4 ) then
-        print *,'Error in lidar_simulator, npart should be 4, not',npart
-        stop
-      endif
-
-      pi = dacos(-1.D0)
-
-! Polynomial coefficients for spherical liq/ice particles derived from Mie theory.
-! Polynomial coefficients for non spherical particles derived from a composite of
-! Ray-tracing theory for large particles (e.g. Noel et al., Appl. Opt., 2001)
-! and FDTD theory for very small particles (Yang et al., JQSRT, 2003).
-
-! We repeat the same coefficients for LS and CONV cloud to make code more readable
-!*     LS Liquid water coefficients:
-         polpart(INDX_LSLIQ,1) =  2.6980e-8
-         polpart(INDX_LSLIQ,2) = -3.7701e-6
-         polpart(INDX_LSLIQ,3) =  1.6594e-4
-         polpart(INDX_LSLIQ,4) = -0.0024
-         polpart(INDX_LSLIQ,5) =  0.0626
-!*     LS Ice coefficients: 
-      if (ice_type.eq.0) then     
-         polpart(INDX_LSICE,1) = -1.0176e-8
-         polpart(INDX_LSICE,2) =  1.7615e-6
-         polpart(INDX_LSICE,3) = -1.0480e-4
-         polpart(INDX_LSICE,4) =  0.0019
-         polpart(INDX_LSICE,5) =  0.0460
-      endif
-!*     LS Ice NS coefficients: 
-      if (ice_type.eq.1) then 
-         polpart(INDX_LSICE,1) = 1.3615e-8
-         polpart(INDX_LSICE,2) = -2.04206e-6
-         polpart(INDX_LSICE,3) = 7.51799e-5
-         polpart(INDX_LSICE,4) = 0.00078213
-         polpart(INDX_LSICE,5) = 0.0182131
-      endif
-!*     CONV Liquid water coefficients:
-         polpart(INDX_CVLIQ,1) =  2.6980e-8
-         polpart(INDX_CVLIQ,2) = -3.7701e-6
-         polpart(INDX_CVLIQ,3) =  1.6594e-4
-         polpart(INDX_CVLIQ,4) = -0.0024
-         polpart(INDX_CVLIQ,5) =  0.0626
-!*     CONV Ice coefficients: 
-      if (ice_type.eq.0) then 
-         polpart(INDX_CVICE,1) = -1.0176e-8
-         polpart(INDX_CVICE,2) =  1.7615e-6
-         polpart(INDX_CVICE,3) = -1.0480e-4
-         polpart(INDX_CVICE,4) =  0.0019
-         polpart(INDX_CVICE,5) =  0.0460
-      endif
-      if (ice_type.eq.1) then
-         polpart(INDX_CVICE,1) = 1.3615e-8
-         polpart(INDX_CVICE,2) = -2.04206e-6
-         polpart(INDX_CVICE,3) = 7.51799e-5
-         polpart(INDX_CVICE,4) = 0.00078213
-         polpart(INDX_CVICE,5) = 0.0182131
-      endif
-
-! density:
-!*    clear-sky air:
-      rhoair = pres/(287.04*temp)
-
-!*    liquid/ice particules:
-      rhopart(INDX_LSLIQ) = rholiq
-      rhopart(INDX_LSICE) = rhoice
-      rhopart(INDX_CVLIQ) = rholiq
-      rhopart(INDX_CVICE) = rhoice
-
-! effective radius particles:
-      rad_part(:,:,INDX_LSLIQ) = ls_radliq(:,:)
-      rad_part(:,:,INDX_LSICE) = ls_radice(:,:)
-      rad_part(:,:,INDX_CVLIQ) = cv_radliq(:,:)
-      rad_part(:,:,INDX_CVICE) = cv_radice(:,:)
-      rad_part(:,:,:)=MAX(rad_part(:,:,:),0.)
-      rad_part(:,:,:)=MIN(rad_part(:,:,:),70.0e-6)
-      
-! altitude at half pressure levels:
-      zheight(:,1) = 0.0
-      do k = 2, nlev+1
-        zheight(:,k) = zheight(:,k-1) &
-                  -(presf(:,k)-presf(:,k-1))/(rhoair(:,k-1)*9.81)
-      enddo
-
-!------------------------------------------------------------
-!---- 2. Molecular alpha and beta:
-!------------------------------------------------------------
-
-      beta_mol = pres/km/temp * Cmol
-      alpha_mol = 8.0*pi/3.0 * beta_mol
-
-!------------------------------------------------------------
-!---- 3. Particles alpha and beta:
-!------------------------------------------------------------
-
-! polynomes kp_lidar derived from Mie theory:
-      do i = 1, npart
-       where ( rad_part(:,:,i).gt.0.0)
-         kp_part(:,:,i) = &
-            polpart(i,1)*(rad_part(:,:,i)*1e6)**4 &
-          + polpart(i,2)*(rad_part(:,:,i)*1e6)**3 &
-          + polpart(i,3)*(rad_part(:,:,i)*1e6)**2 &
-          + polpart(i,4)*(rad_part(:,:,i)*1e6) &
-          + polpart(i,5)
-        elsewhere
-         kp_part(:,:,i) = 0.
-        endwhere
-      enddo
-      
-! mixing ratio particules in each subcolumn:
-          qpart(:,:,INDX_LSLIQ) = q_lsliq(:,:) ! oct08
-          qpart(:,:,INDX_LSICE) = q_lsice(:,:) ! oct08
-          qpart(:,:,INDX_CVLIQ) = q_cvliq(:,:) ! oct08
-          qpart(:,:,INDX_CVICE) = q_cvice(:,:) ! oct08
-
-! alpha of particles in each subcolumn:
-      do i = 1, npart
-        where ( rad_part(:,:,i).gt.0.0)
-          alpha_part(:,:,i) = 3.0/4.0 * Qscat &
-                 * rhoair(:,:) * qpart(:,:,i) &
-                 / (rhopart(i) * rad_part(:,:,i) )
-        elsewhere
-          alpha_part(:,:,i) = 0.
-        endwhere
-      enddo
-
-!------------------------------------------------------------
-!---- 4.1 Total Backscatter signal:
-!------------------------------------------------------------
-
-! optical thickness (molecular):
-!     opt. thick of each layer
-      tau_mol(:,1:nlev) = alpha_mol(:,1:nlev) &
-         & *(zheight(:,2:nlev+1)-zheight(:,1:nlev))
-!     opt. thick from TOA
-      DO k = nlev-1, 1, -1
-        tau_mol(:,k) = tau_mol(:,k) + tau_mol(:,k+1)
-      ENDDO
-
-! optical thickness (particles):
-
-      tau_part = rdiffm * alpha_part
-      DO i = 1, npart
-!       opt. thick of each layer
-        tau_part(:,:,i) = tau_part(:,:,i) &
-           & * (zheight(:,2:nlev+1)-zheight(:,1:nlev) )
-!       opt. thick from TOA
-        DO k = nlev-1, 1, -1 
-          tau_part(:,k,i) = tau_part(:,k,i) + tau_part(:,k+1,i)
-        ENDDO
-      ENDDO
-
-! molecular signal:
-!      Upper layer 
-       pmol(:,nlev) = beta_mol(:,nlev) / (2.*tau_mol(:,nlev)) &
-            & * (1.-exp(-2.0*tau_mol(:,nlev)))
-!      Other layers
-       DO k= nlev-1, 1, -1
-        tau_mol_lay(:) = tau_mol(:,k)-tau_mol(:,k+1) ! opt. thick. of layer k
-        WHERE (tau_mol_lay(:).GT.0.)
-          pmol(:,k) = beta_mol(:,k) * EXP(-2.0*tau_mol(:,k+1)) / (2.*tau_mol_lay(:)) &
-            & * (1.-exp(-2.0*tau_mol_lay(:)))
-        ELSEWHERE
-!         This must never happend, but just in case, to avoid div. by 0
-          pmol(:,k) = beta_mol(:,k) * EXP(-2.0*tau_mol(:,k+1))
-        END WHERE
-      END DO
-
-! Total signal (molecular + particules):
-!
-!
-! For performance reason on vector computers, the 2 following lines should not be used
-! and should be replace by the later one.
-!      betatot(:,:) = beta_mol(:,:) + sum(kp_part*alpha_part,dim=3)
-!      tautot(:,:)  = tau_mol(:,:)  + sum(tau_part,dim=3)
-      betatot(:,:) = beta_mol(:,:)
-      tautot(:,:)  = tau_mol(:,:)
-      DO i = 1, npart
-           betatot(:,:) = betatot(:,:) + kp_part(:,:,i)*alpha_part(:,:,i)
-           tautot(:,:) = tautot(:,:)  + tau_part(:,:,i)
-      ENDDO ! i
-!
-!     Upper layer 
-      pnorm(:,nlev) = betatot(:,nlev) / (2.*tautot(:,nlev)) &
-            & * (1.-exp(-2.0*tautot(:,nlev)))
-
-!     Other layers
-      DO k= nlev-1, 1, -1
-          tautot_lay(:) = tautot(:,k)-tautot(:,k+1) ! optical thickness of layer k
-        WHERE (tautot_lay(:).GT.0.)
-          pnorm(:,k) = betatot(:,k) * EXP(-2.0*tautot(:,k+1)) / (2.*tautot_lay(:)) &
-               & * (1.-EXP(-2.0*tautot_lay(:)))
-        ELSEWHERE
-!         This must never happend, but just in case, to avoid div. by 0
-          pnorm(:,k) = betatot(:,k) * EXP(-2.0*tautot(:,k+1))
-        END WHERE
-      END DO
-
-!------------------------------------------------------------
-!---- 4.2 Ice/Liq Backscatter signal:
-!------------------------------------------------------------
-
-! Contribution of the molecular to beta
-      betatot_ice(:,:) = beta_mol(:,:)
-      betatot_liq(:,:) = beta_mol(:,:)
-
-      tautot_ice(:,:) = tau_mol(:,:)
-      tautot_liq(:,:) = tau_mol(:,:)
-
-      DO i = 2, npart,2
-           betatot_ice(:,:) = betatot_ice(:,:)+ kp_part(:,:,i)*alpha_part(:,:,i)
-           tautot_ice(:,:) = tautot_ice(:,:)  + tau_part(:,:,i)
-      ENDDO ! i
-      DO i = 1, npart,2
-           betatot_liq(:,:) = betatot_liq(:,:)+ kp_part(:,:,i)*alpha_part(:,:,i)
-           tautot_liq(:,:) = tautot_liq(:,:)  + tau_part(:,:,i)
-      ENDDO ! i
-
-
-! Computation of the ice and liquid lidar backscattered signal (ATBice and ATBliq)
-!     Ice only
-!     Upper layer
-      pnorm_ice(:,nlev) = betatot_ice(:,nlev) / (2.*tautot_ice(:,nlev)) &
-            & * (1.-exp(-2.0*tautot_ice(:,nlev)))
-
-      DO k= nlev-1, 1, -1
-          tautot_lay_ice(:) = tautot_ice(:,k)-tautot_ice(:,k+1) 
-        WHERE (tautot_lay_ice(:).GT.0.)
-         pnorm_ice(:,k)=betatot_ice(:,k)*EXP(-2.0*tautot_ice(:,k+1))/(2.*tautot_lay_ice(:)) &
-               & * (1.-EXP(-2.0*tautot_lay_ice(:)))
-        ELSEWHERE
-         pnorm_ice(:,k)=betatot_ice(:,k)*EXP(-2.0*tautot_ice(:,k+1))
-        END WHERE
-      ENDDO
-
-!     Liquid only
-!     Upper layer
-      pnorm_liq(:,nlev) = betatot_liq(:,nlev) / (2.*tautot_liq(:,nlev)) &
-            & * (1.-exp(-2.0*tautot_liq(:,nlev)))
-
-      DO k= nlev-1, 1, -1
-          tautot_lay_liq(:) = tautot_liq(:,k)-tautot_liq(:,k+1) 
-        WHERE (tautot_lay_liq(:).GT.0.)
-          pnorm_liq(:,k)=betatot_liq(:,k)*EXP(-2.0*tautot_liq(:,k+1))/(2.*tautot_lay_liq(:)) &
-               & * (1.-EXP(-2.0*tautot_lay_liq(:)))
-        ELSEWHERE
-          pnorm_liq(:,k)=betatot_liq(:,k)*EXP(-2.0*tautot_liq(:,k+1))
-        END WHERE
-      ENDDO
-
-
-! Computation of ATBperp,ice/liq from ATBice/liq including the multiple scattering 
-! contribution (Cesana and Chepfer 2013, JGR)
-!  ATBperp,ice = Alpha*ATBice 
-!  ATBperp,liq = Beta*ATBliq^2 + Gamma*ATBliq
-
-      DO k= nlev, 1, -1
-         pnorm_perp_ice(:,k) = Alpha * pnorm_ice(:,k) ! Ice particles
-         pnorm_perp_liq(:,k) = 1000*Beta * pnorm_liq(:,k)**2 + Gamma * pnorm_liq(:,k) ! Liquid particles
-      ENDDO
-
-! Computation of beta_perp_ice/liq using the lidar equation
-!     Ice only
-!     Upper layer 
-      beta_perp_ice(:,nlev) = pnorm_perp_ice(:,nlev) * (2.*tautot_ice(:,nlev)) &
-            & / (1.-exp(-2.0*tautot_ice(:,nlev)))
-
-      DO k= nlev-1, 1, -1
-        tautot_lay_ice(:) = tautot_ice(:,k)-tautot_ice(:,k+1)
-        WHERE (tautot_lay_ice(:).GT.0.)
-         beta_perp_ice(:,k) = pnorm_perp_ice(:,k)/ EXP(-2.0*tautot_ice(:,k+1)) * (2.*tautot_lay_ice(:)) &
-            & / (1.-exp(-2.0*tautot_lay_ice(:)))
-
-        ELSEWHERE
-         beta_perp_ice(:,k)=pnorm_perp_ice(:,k)/EXP(-2.0*tautot_ice(:,k+1))
-        END WHERE
-      ENDDO
-
-!     Liquid only
-!     Upper layer 
-      beta_perp_liq(:,nlev) = pnorm_perp_liq(:,nlev) * (2.*tautot_liq(:,nlev)) &
-            & / (1.-exp(-2.0*tautot_liq(:,nlev)))
-
-      DO k= nlev-1, 1, -1
-          tautot_lay_liq(:) = tautot_liq(:,k)-tautot_liq(:,k+1) 
-        WHERE (tautot_lay_liq(:).GT.0.)
-         beta_perp_liq(:,k) = pnorm_perp_liq(:,k)/ max(seuil,EXP(-2.0*tautot_liq(:,k+1))) &
-            & * (2.*tautot_lay_liq(:)) / (1.-exp(-2.0*tautot_lay_liq(:)))
-
-        ELSEWHERE
-         beta_perp_liq(:,k)=pnorm_perp_liq(:,k)/EXP(-2.0*tautot_liq(:,k+1))
-        END WHERE
-      ENDDO
-
-
-
-!------------------------------------------------------------
-!---- 4.3 Perpendicular Backscatter signal:
-!------------------------------------------------------------
-
-! Computation of the total perpendicular lidar signal (ATBperp for liq+ice)
-!     Upper layer 
-    WHERE(tautot(:,nlev).GT.0)
-          pnorm_perp_tot(:,nlev) = &
-              (beta_perp_ice(:,nlev)+beta_perp_liq(:,nlev)-(beta_mol(:,nlev)/(1+1/0.0284))) / (2.*tautot(:,nlev)) &
-              & * (1.-exp(-2.0*tautot(:,nlev)))
-    ELSEWHERE
-    pnorm_perp_tot(:,nlev) = 0.
-    ENDWHERE
-
-!     Other layers
-      DO k= nlev-1, 1, -1
-          tautot_lay(:) = tautot(:,k)-tautot(:,k+1) ! optical thickness of layer k
-
-          ! The perpendicular component of the molecular backscattered signal (Betaperp) has been 
-          ! taken into account two times (once for liquid and once for ice). 
-          ! We remove one contribution using 
-          ! Betaperp=beta_mol(:,k)/(1+1/0.0284)) [bodhaine et al. 1999] in the following equations:
-            WHERE (pnorm(:,k).eq.0)
-                  pnorm_perp_tot(:,k)=0.
-                  ELSEWHERE
-                    WHERE (tautot_lay(:).GT.0.)
-                      pnorm_perp_tot(:,k) = &
-                          (beta_perp_ice(:,k)+beta_perp_liq(:,k)-(beta_mol(:,k)/(1+1/0.0284))) * &
-                          EXP(-2.0*tautot(:,k+1)) / (2.*tautot_lay(:)) &
-                          & * (1.-EXP(-2.0*tautot_lay(:)))
-                    ELSEWHERE
-          !         This must never happen, but just in case, to avoid div. by 0
-                      pnorm_perp_tot(:,k) = &
-                           (beta_perp_ice(:,k)+beta_perp_liq(:,k)-(beta_mol(:,k)/(1+1/0.0284))) * &
-                          EXP(-2.0*tautot(:,k+1))
-                    END WHERE
-            ENDWHERE
-
-      END DO
-
-!-------- End computation Lidar --------------------------
-
-!---------------------------------------------------------
-!  Parasol/Polder module
-!
-!  Purpose : Compute reflectance for one particular viewing direction
-!  and 5 solar zenith angles (calculation valid only over ocean)
-! ---------------------------------------------------------
-
-! initialization:
-    refl(:,:) = 0.0
-
-! activate parasol calculations:
-    if (ok_parasol) then
-
-!     Optical thickness from TOA to surface
-      tautot_S_liq = 0.
-      tautot_S_ice = 0.
-      tautot_S_liq(:) = tautot_S_liq(:) &
-         + tau_part(:,1,1) + tau_part(:,1,3)
-      tautot_S_ice(:) = tautot_S_ice(:) &
-         + tau_part(:,1,2) + tau_part(:,1,4)
-
-      call parasol(npoints,nrefl,undef  &
-                 ,tautot_S_liq,tautot_S_ice &
-                 ,refl)
-
-    endif ! ok_parasol
-
-  END SUBROUTINE lidar_simulator
-!
-!---------------------------------------------------------------------------------
-!
-  SUBROUTINE parasol(npoints,nrefl,undef  &
-                       ,tautot_S_liq,tautot_S_ice  &
-                       ,refl)
-!---------------------------------------------------------------------------------
-! Purpose: To compute Parasol reflectance signal from model-simulated profiles 
-!          of cloud water and cloud fraction in each sub-column of each model 
-!          gridbox.
-!
-!
-! December 2008, S. Bony,  H. Chepfer and J-L. Dufresne : 
-! - optimization for vectorization
-!
-! Version 2.0 (October 2008)
-! Version 2.1 (December 2008)
-!---------------------------------------------------------------------------------
-
-    IMPLICIT NONE
-
-! inputs
-    INTEGER npoints              ! Number of horizontal gridpoints
-    INTEGER nrefl                ! Number of angles for which the reflectance 
-                                 ! is computed. Can not be greater then ntetas
-    REAL undef                   ! Undefined value. Currently not used
-    REAL tautot_S_liq(npoints)   ! liquid water cloud optical thickness, 
-                                   ! integrated from TOA to surface
-    REAL tautot_S_ice(npoints)   ! same for ice water clouds only
-! outputs
-    REAL refl(npoints,nrefl)     ! Parasol reflectances
-!
-! Local variables
-    REAL tautot_S(npoints)       ! cloud optical thickness, from TOA to surface
-    REAL frac_taucol_liq(npoints), frac_taucol_ice(npoints)
-
-    REAL pi
-!   look up table variables:
-    INTEGER ny, it
-    INTEGER ntetas, nbtau        ! number of angle and of optical thickness
-                                   ! of the look-up table
-    PARAMETER (ntetas=5, nbtau=7)
-    REAL aa(ntetas,nbtau-1), ab(ntetas,nbtau-1)
-    REAL ba(ntetas,nbtau-1), bb(ntetas,nbtau-1)  
-    REAL tetas(ntetas),tau(nbtau)                        
-    REAL r_norm(ntetas)
-    REAL rlumA(ntetas,nbtau), rlumB(ntetas,nbtau)       
-    REAL rlumA_mod(npoints,5), rlumB_mod(npoints,5) 
-
-    DATA tau   /0., 1., 5., 10., 20., 50., 100./
-    DATA tetas /0., 20., 40., 60., 80./
-    
-! Look-up table for spherical liquid particles:
-    DATA (rlumA(1,ny),ny=1,nbtau) /0.03, 0.090886, 0.283965, &
-     0.480587, 0.695235, 0.908229, 1.0 /
-    DATA (rlumA(2,ny),ny=1,nbtau) /0.03, 0.072185, 0.252596, &
-      0.436401,  0.631352, 0.823924, 0.909013 /
-    DATA (rlumA(3,ny),ny=1,nbtau) /0.03, 0.058410, 0.224707, &
-      0.367451,  0.509180, 0.648152, 0.709554 /
-    DATA (rlumA(4,ny),ny=1,nbtau) /0.03, 0.052498, 0.175844, &
-      0.252916,  0.326551, 0.398581, 0.430405 /
-    DATA (rlumA(5,ny),ny=1,nbtau) /0.03, 0.034730, 0.064488, &
-      0.081667,  0.098215, 0.114411, 0.121567 /
-
-! Look-up table for ice particles:
-    DATA (rlumB(1,ny),ny=1,nbtau) /0.03, 0.092170, 0.311941, &
-       0.511298, 0.712079 , 0.898243 , 0.976646 /
-    DATA (rlumB(2,ny),ny=1,nbtau) /0.03, 0.087082, 0.304293, &
-       0.490879,  0.673565, 0.842026, 0.912966 /
-    DATA (rlumB(3,ny),ny=1,nbtau) /0.03, 0.083325, 0.285193, &
-      0.430266,  0.563747, 0.685773,  0.737154 /
-    DATA (rlumB(4,ny),ny=1,nbtau) /0.03, 0.084935, 0.233450, &
-      0.312280, 0.382376, 0.446371, 0.473317 /
-    DATA (rlumB(5,ny),ny=1,nbtau) /0.03, 0.054157, 0.089911, &
-      0.107854, 0.124127, 0.139004, 0.145269 /
-
-!--------------------------------------------------------------------------------
-! Lum_norm=f(tetaS,tau_cloud) derived from adding-doubling calculations
-!        valid ONLY ABOVE OCEAN (albedo_sfce=5%)
-!        valid only in one viewing direction (theta_v=30�, phi_s-phi_v=320�)
-!        based on adding-doubling radiative transfer computation
-!        for tau values (0 to 100) and for tetas values (0 to 80)
-!        for 2 scattering phase functions: liquid spherical, ice non spherical
-
-    IF ( nrefl.GT. ntetas ) THEN
-        PRINT *,'Error in lidar_simulator, nrefl should be less then ',ntetas,' not',nrefl
-        STOP
-    ENDIF
-
-    rlumA_mod=0
-    rlumB_mod=0
-!
-    pi = ACOS(-1.0)
-    r_norm(:)=1./ COS(pi/180.*tetas(:))
-!
-    tautot_S_liq(:)=MAX(tautot_S_liq(:),tau(1))
-    tautot_S_ice(:)=MAX(tautot_S_ice(:),tau(1))
-    tautot_S(:) = tautot_S_ice(:) + tautot_S_liq(:)
-!
-! relative fraction of the opt. thick due to liquid or ice clouds
-    WHERE (tautot_S(:) .GT. 0.)
-        frac_taucol_liq(:) = tautot_S_liq(:) / tautot_S(:)
-        frac_taucol_ice(:) = tautot_S_ice(:) / tautot_S(:)
-    ELSEWHERE
-        frac_taucol_liq(:) = 1.
-        frac_taucol_ice(:) = 0.
-    END WHERE
-    tautot_S(:)=MIN(tautot_S(:),tau(nbtau))
-!
-! Linear interpolation :
-
-    DO ny=1,nbtau-1
-! microphysics A (liquid clouds) 
-      aA(:,ny) = (rlumA(:,ny+1)-rlumA(:,ny))/(tau(ny+1)-tau(ny))
-      bA(:,ny) = rlumA(:,ny) - aA(:,ny)*tau(ny)
-! microphysics B (ice clouds)
-      aB(:,ny) = (rlumB(:,ny+1)-rlumB(:,ny))/(tau(ny+1)-tau(ny))
-      bB(:,ny) = rlumB(:,ny) - aB(:,ny)*tau(ny)
-    ENDDO
-!
-    DO it=1,ntetas
-      DO ny=1,nbtau-1
-        WHERE (tautot_S(:).GE.tau(ny).AND.tautot_S(:).LE.tau(ny+1))
-            rlumA_mod(:,it) = aA(it,ny)*tautot_S(:) + bA(it,ny)
-            rlumB_mod(:,it) = aB(it,ny)*tautot_S(:) + bB(it,ny)
-        END WHERE
-      END DO
-    END DO
-!
-    DO it=1,ntetas
-      refl(:,it) = frac_taucol_liq(:) * rlumA_mod(:,it) &
-         + frac_taucol_ice(:) * rlumB_mod(:,it)
-! normalized radiance -> reflectance: 
-      refl(:,it) = refl(:,it) * r_norm(it)
-    ENDDO
-
-    RETURN
-  END SUBROUTINE parasol
Index: /LMDZ6/trunk/libf/phylmd/cosp/lidar_simulator.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cosp/lidar_simulator.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/cosp/lidar_simulator.f90	(revision 5268)
@@ -0,0 +1,750 @@
+! Copyright (c) 2009, Centre National de la Recherche Scientifique
+! All rights reserved.
+! $Revision: 88 $, $Date: 2013-11-13 15:08:38 +0100 (mer. 13 nov. 2013) $
+! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/actsim/lidar_simulator.F90 $
+! 
+! Redistribution and use in source and binary forms, with or without modification, are permitted 
+! provided that the following conditions are met:
+! 
+!     * Redistributions of source code must retain the above copyright notice, this list 
+!       of conditions and the following disclaimer.
+!     * Redistributions in binary form must reproduce the above copyright notice, this list
+!       of conditions and the following disclaimer in the documentation and/or other materials 
+!       provided with the distribution.
+!     * Neither the name of the LMD/IPSL/CNRS/UPMC nor the names of its
+!       contributors may be used to endorse or promote products derived from this software without 
+!       specific prior written permission.
+! 
+! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR 
+! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND 
+! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR 
+! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 
+! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 
+! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER 
+! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT 
+! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+      
+      SUBROUTINE lidar_simulator(npoints,nlev,npart,nrefl &
+                , undef &
+                , pres, presf, temp &
+                , q_lsliq, q_lsice, q_cvliq, q_cvice &
+                , ls_radliq, ls_radice, cv_radliq, cv_radice &
+                , ice_type, pmol, pnorm, pnorm_perp_tot,tautot, refl )
+!
+!---------------------------------------------------------------------------------
+! Purpose: To compute lidar signal from model-simulated profiles of cloud water
+!          and cloud fraction in each sub-column of each model gridbox.
+!
+! References: 
+! Chepfer H., S. Bony, D. Winker, M. Chiriaco, J.-L. Dufresne, G. Seze (2008),
+! Use of CALIPSO lidar observations to evaluate the cloudiness simulated by a 
+! climate model, Geophys. Res. Lett., 35, L15704, doi:10.1029/2008GL034207.
+!
+! Previous references:
+! Chiriaco et al, MWR, 2006; Chepfer et al., MWR, 2007
+!
+! Contacts: Helene Chepfer (chepfer@lmd.polytechnique.fr), Sandrine Bony (bony@lmd.jussieu.fr)
+!
+! May 2007: ActSim code of M. Chiriaco and H. Chepfer rewritten by S. Bony
+!
+! May 2008, H. Chepfer:
+! - Units of pressure inputs: Pa 
+! - Non Spherical particles : LS Ice NS coefficients, CONV Ice NS coefficients
+! - New input: ice_type (0=ice-spheres ; 1=ice-non-spherical)
+!
+! June 2008, A. Bodas-Salcedo:
+! - Ported to Fortran 90 and optimisation changes
+!
+! August 2008, J-L Dufresne:
+! - Optimisation changes (sum instructions suppressed)
+!
+! October 2008, S. Bony,  H. Chepfer and J-L. Dufresne :  
+! - Interface with COSP v2.0:
+!      cloud fraction removed from inputs
+!      in-cloud condensed water now in input (instead of grid-averaged value)
+!      depolarisation diagnostic removed
+!      parasol (polder) reflectances (for 5 different solar zenith angles) added
+!
+! December 2008, S. Bony,  H. Chepfer and J-L. Dufresne : 
+! - Modification of the integration of the lidar equation.
+! - change the cloud detection threshold
+!
+! April 2008, A. Bodas-Salcedo:
+! - Bug fix in computation of pmol and pnorm of upper layer
+!
+! April 2008, J-L. Dufresne
+! - Bug fix in computation of pmol and pnorm, thanks to Masaki Satoh: a factor 2 
+! was missing. This affects the ATB values but not the cloud fraction. 
+!
+! January 2013, G. Cesana and H. Chepfer:
+! - Add the perpendicular component of the backscattered signal (pnorm_perp_tot) in the arguments
+! - Add the temperature for each levels (temp) in the arguments
+! - Add the computation of the perpendicular component of the backscattered lidar signal 
+! Reference: Cesana G. and H. Chepfer (2013): Evaluation of the cloud water phase
+! in a climate model using CALIPSO-GOCCP, J. Geophys. Res., doi: 10.1002/jgrd.50376
+!
+!---------------------------------------------------------------------------------
+!
+! Inputs:
+!  npoints  : number of horizontal points
+!  nlev : number of vertical levels
+!  npart: numberb of cloud meteors (stratiform_liq, stratiform_ice, conv_liq, conv_ice). 
+!        Currently npart must be 4
+!  nrefl: number of solar zenith angles for parasol reflectances
+!  pres : pressure in the middle of atmospheric layers (full levels): Pa
+!  presf: pressure in the interface of atmospheric layers (half levels): Pa
+!     presf(..,1) : surface pressure ; presf(..,nlev+1)= TOA pressure
+!  temp : temperature of atmospheric layers: K
+!  q_lsliq: LS sub-column liquid water mixing ratio (kg/kg)
+!  q_lsice: LS sub-column ice water mixing ratio (kg/kg)
+!  q_cvliq: CONV sub-column liquid water mixing ratio (kg/kg)
+!  q_cvice: CONV sub-column ice water mixing ratio (kg/kg)
+!  ls_radliq: effective radius of LS liquid particles (meters)
+!  ls_radice: effective radius of LS ice particles (meters)
+!  cv_radliq: effective radius of CONV liquid particles (meters)
+!  cv_radice: effective radius of CONV ice particles (meters)
+!  ice_type : ice particle shape hypothesis (ice_type=0 for spheres, ice_type=1 
+!             for non spherical particles)
+!
+! Outputs:
+!  pmol : molecular attenuated backscatter lidar signal power (m^-1.sr^-1)
+!  pnorm: total attenuated backscatter lidar signal power (m^-1.sr^-1)
+!  pnorm_perp_tot: perpendicular attenuated backscatter lidar signal power (m^-1.sr^-1)
+!  tautot: optical thickess integrated from top to level z
+!  refl : parasol(polder) reflectance
+!
+! Version 1.0 (June 2007)
+! Version 1.1 (May 2008)
+! Version 1.2 (June 2008)
+! Version 2.0 (October 2008)
+! Version 2.1 (December 2008)
+!---------------------------------------------------------------------------------
+
+      USE MOD_COSP_CONSTANTS, only : ok_debug_cosp
+      IMPLICIT NONE
+      REAL :: SRsat
+      PARAMETER (SRsat = 0.01) ! threshold full attenuation 
+
+      LOGICAL ok_parasol
+      PARAMETER (ok_parasol=.true.)  ! set to .true. if you want to activate parasol reflectances
+
+      INTEGER i, k
+      
+      INTEGER INDX_LSLIQ,INDX_LSICE,INDX_CVLIQ,INDX_CVICE
+      PARAMETER (INDX_LSLIQ=1,INDX_LSICE=2,INDX_CVLIQ=3,INDX_CVICE=4)
+! inputs:
+      INTEGER npoints,nlev,npart,ice_type
+      INTEGER nrefl
+      real undef                 ! undefined value
+      REAL pres(npoints,nlev)    ! pressure full levels
+      REAL presf(npoints,nlev+1) ! pressure half levels
+      REAL q_lsliq(npoints,nlev), q_lsice(npoints,nlev)
+      REAL q_cvliq(npoints,nlev), q_cvice(npoints,nlev)
+      REAL ls_radliq(npoints,nlev), ls_radice(npoints,nlev)
+      REAL cv_radliq(npoints,nlev), cv_radice(npoints,nlev)
+
+! outputs (for each subcolumn):
+
+      REAL pmol(npoints,nlev)  ! molecular backscatter signal power (m^-1.sr^-1)
+      REAL pnorm(npoints,nlev) ! total lidar backscatter signal power (m^-1.sr^-1)
+      REAL tautot(npoints,nlev)! optical thickess integrated from top
+      REAL refl(npoints,nrefl)! parasol reflectance ! parasol
+
+! actsim variables:
+
+      REAL km, rdiffm, Qscat, Cmol
+      PARAMETER (Cmol = 6.2446e-32) ! depends on wavelength
+      PARAMETER (km = 1.38e-23)     ! Boltzmann constant (J/K)
+
+      PARAMETER (rdiffm = 0.7)      ! multiple scattering correction parameter
+      PARAMETER (Qscat = 2.0)       ! particle scattering efficiency at 532 nm
+
+      REAL rholiq, rhoice
+      PARAMETER (rholiq=1.0e+03)     ! liquid water (kg/m3)
+      PARAMETER (rhoice=0.5e+03)     ! ice (kg/m3)
+
+      REAL pi, rhopart(npart)
+      REAL polpart(npart,5)  ! polynomial coefficients derived for spherical and non spherical
+                             ! particules
+
+!   grid-box variables:
+      REAL rad_part(npoints,nlev,npart)
+      REAL rhoair(npoints,nlev), zheight(npoints,nlev+1)
+      REAL beta_mol(npoints,nlev), alpha_mol(npoints,nlev)
+      REAL kp_part(npoints,nlev,npart)
+
+!   sub-column variables:
+      REAL qpart(npoints,nlev,npart) ! mixing ratio particles in each subcolumn
+      REAL alpha_part(npoints,nlev,npart)
+      REAL tau_mol_lay(npoints)  ! temporary variable, moL. opt. thickness of layer k
+      REAL tau_mol(npoints,nlev) ! optical thickness between TOA and bottom of layer k
+      REAL tau_part(npoints,nlev,npart)
+      REAL betatot(npoints,nlev)
+      REAL tautot_lay(npoints)   ! temporary variable, total opt. thickness of layer k
+!     Optical thickness from TOA to surface for Parasol
+     REAL tautot_S_liq(npoints),tautot_S_ice(npoints)     ! for liq and ice clouds
+
+
+! Local variables
+      REAL Alpha, Beta, Gamma  ! Polynomial coefficient for ATBperp computation
+      REAL temp(npoints,nlev)                   ! temperature of layer k
+      REAL betatot_ice(npoints,nlev)    ! backscatter coefficient for ice particles
+      REAL beta_perp_ice(npoints,nlev)  ! perpendicular backscatter coefficient for ice
+      REAL betatot_liq(npoints,nlev)    ! backscatter coefficient for liquid particles
+      REAL beta_perp_liq(npoints,nlev)  ! perpendicular backscatter coefficient for liq
+      REAL tautot_ice(npoints,nlev)     ! total optical thickness of ice
+      REAL tautot_liq(npoints,nlev)     ! total optical thickness of liq
+      REAL tautot_lay_ice(npoints)    ! total optical thickness of ice in the layer k
+      REAL tautot_lay_liq(npoints)    ! total optical thickness of liq in the layer k
+      REAL pnorm_liq(npoints,nlev)    ! lidar backscattered signal power for liquid
+      REAL pnorm_ice(npoints,nlev)    ! lidar backscattered signal power for ice
+      REAL pnorm_perp_ice(npoints,nlev) ! perpendicular lidar backscattered signal power for ice
+      REAL pnorm_perp_liq(npoints,nlev) ! perpendicular lidar backscattered signal power for liq
+
+      REAL :: seuil 
+
+! Output variable
+      REAL pnorm_perp_tot (npoints,nlev) ! perpendicular lidar backscattered signal power
+
+!------------------------------------------------------------
+!---- 0. Initialisation :
+!------------------------------------------------------------
+betatot_ice(:,:)=0
+betatot_liq(:,:)=0
+beta_perp_ice(:,:)=0
+beta_perp_liq(:,:)=0
+tautot_ice(:,:)=0
+tautot_liq(:,:)=0
+tautot_lay_ice(:)=0;
+tautot_lay_liq(:)=0;
+pnorm_liq(:,:)=0
+pnorm_ice(:,:)=0
+pnorm_perp_ice(:,:)=0
+pnorm_perp_liq(:,:)=0
+pnorm_perp_tot(:,:)=0
+
+
+! Polynomial coefficients (Alpha, Beta, Gamma) which allow to compute the ATBperpendicular
+! as a function of the ATB for ice or liquid cloud particles derived from CALIPSO-GOCCP
+! observations at 120m vertical grid (Cesana and Chepfer, JGR, 2013).
+!
+! Relationship between ATBice and ATBperp,ice for ice particles
+!  ATBperp,ice = Alpha*ATBice 
+         Alpha = 0.2904
+
+! Relationship between ATBice and ATBperp,ice for liquid particles
+!  ATBperp,ice = Beta*ATBice^2 + Gamma*ATBice
+         Beta = 0.4099
+         Gamma = 0.009
+
+  if (ok_debug_cosp) then
+     seuil=1.e-18
+  else
+     seuil=0.0
+  endif 
+!------------------------------------------------------------
+!---- 1. Preliminary definitions and calculations :
+!------------------------------------------------------------
+
+      if ( npart .ne. 4 ) then
+        print *,'Error in lidar_simulator, npart should be 4, not',npart
+        stop
+      endif
+
+      pi = dacos(-1.D0)
+
+! Polynomial coefficients for spherical liq/ice particles derived from Mie theory.
+! Polynomial coefficients for non spherical particles derived from a composite of
+! Ray-tracing theory for large particles (e.g. Noel et al., Appl. Opt., 2001)
+! and FDTD theory for very small particles (Yang et al., JQSRT, 2003).
+
+! We repeat the same coefficients for LS and CONV cloud to make code more readable
+!*     LS Liquid water coefficients:
+         polpart(INDX_LSLIQ,1) =  2.6980e-8
+         polpart(INDX_LSLIQ,2) = -3.7701e-6
+         polpart(INDX_LSLIQ,3) =  1.6594e-4
+         polpart(INDX_LSLIQ,4) = -0.0024
+         polpart(INDX_LSLIQ,5) =  0.0626
+!*     LS Ice coefficients: 
+      if (ice_type.eq.0) then     
+         polpart(INDX_LSICE,1) = -1.0176e-8
+         polpart(INDX_LSICE,2) =  1.7615e-6
+         polpart(INDX_LSICE,3) = -1.0480e-4
+         polpart(INDX_LSICE,4) =  0.0019
+         polpart(INDX_LSICE,5) =  0.0460
+      endif
+!*     LS Ice NS coefficients: 
+      if (ice_type.eq.1) then 
+         polpart(INDX_LSICE,1) = 1.3615e-8
+         polpart(INDX_LSICE,2) = -2.04206e-6
+         polpart(INDX_LSICE,3) = 7.51799e-5
+         polpart(INDX_LSICE,4) = 0.00078213
+         polpart(INDX_LSICE,5) = 0.0182131
+      endif
+!*     CONV Liquid water coefficients:
+         polpart(INDX_CVLIQ,1) =  2.6980e-8
+         polpart(INDX_CVLIQ,2) = -3.7701e-6
+         polpart(INDX_CVLIQ,3) =  1.6594e-4
+         polpart(INDX_CVLIQ,4) = -0.0024
+         polpart(INDX_CVLIQ,5) =  0.0626
+!*     CONV Ice coefficients: 
+      if (ice_type.eq.0) then 
+         polpart(INDX_CVICE,1) = -1.0176e-8
+         polpart(INDX_CVICE,2) =  1.7615e-6
+         polpart(INDX_CVICE,3) = -1.0480e-4
+         polpart(INDX_CVICE,4) =  0.0019
+         polpart(INDX_CVICE,5) =  0.0460
+      endif
+      if (ice_type.eq.1) then
+         polpart(INDX_CVICE,1) = 1.3615e-8
+         polpart(INDX_CVICE,2) = -2.04206e-6
+         polpart(INDX_CVICE,3) = 7.51799e-5
+         polpart(INDX_CVICE,4) = 0.00078213
+         polpart(INDX_CVICE,5) = 0.0182131
+      endif
+
+! density:
+!*    clear-sky air:
+      rhoair = pres/(287.04*temp)
+
+!*    liquid/ice particules:
+      rhopart(INDX_LSLIQ) = rholiq
+      rhopart(INDX_LSICE) = rhoice
+      rhopart(INDX_CVLIQ) = rholiq
+      rhopart(INDX_CVICE) = rhoice
+
+! effective radius particles:
+      rad_part(:,:,INDX_LSLIQ) = ls_radliq(:,:)
+      rad_part(:,:,INDX_LSICE) = ls_radice(:,:)
+      rad_part(:,:,INDX_CVLIQ) = cv_radliq(:,:)
+      rad_part(:,:,INDX_CVICE) = cv_radice(:,:)
+      rad_part(:,:,:)=MAX(rad_part(:,:,:),0.)
+      rad_part(:,:,:)=MIN(rad_part(:,:,:),70.0e-6)
+      
+! altitude at half pressure levels:
+      zheight(:,1) = 0.0
+      do k = 2, nlev+1
+        zheight(:,k) = zheight(:,k-1) &
+                  -(presf(:,k)-presf(:,k-1))/(rhoair(:,k-1)*9.81)
+      enddo
+
+!------------------------------------------------------------
+!---- 2. Molecular alpha and beta:
+!------------------------------------------------------------
+
+      beta_mol = pres/km/temp * Cmol
+      alpha_mol = 8.0*pi/3.0 * beta_mol
+
+!------------------------------------------------------------
+!---- 3. Particles alpha and beta:
+!------------------------------------------------------------
+
+! polynomes kp_lidar derived from Mie theory:
+      do i = 1, npart
+       where ( rad_part(:,:,i).gt.0.0)
+         kp_part(:,:,i) = &
+            polpart(i,1)*(rad_part(:,:,i)*1e6)**4 &
+          + polpart(i,2)*(rad_part(:,:,i)*1e6)**3 &
+          + polpart(i,3)*(rad_part(:,:,i)*1e6)**2 &
+          + polpart(i,4)*(rad_part(:,:,i)*1e6) &
+          + polpart(i,5)
+        elsewhere
+         kp_part(:,:,i) = 0.
+        endwhere
+      enddo
+      
+! mixing ratio particules in each subcolumn:
+          qpart(:,:,INDX_LSLIQ) = q_lsliq(:,:) ! oct08
+          qpart(:,:,INDX_LSICE) = q_lsice(:,:) ! oct08
+          qpart(:,:,INDX_CVLIQ) = q_cvliq(:,:) ! oct08
+          qpart(:,:,INDX_CVICE) = q_cvice(:,:) ! oct08
+
+! alpha of particles in each subcolumn:
+      do i = 1, npart
+        where ( rad_part(:,:,i).gt.0.0)
+          alpha_part(:,:,i) = 3.0/4.0 * Qscat &
+                 * rhoair(:,:) * qpart(:,:,i) &
+                 / (rhopart(i) * rad_part(:,:,i) )
+        elsewhere
+          alpha_part(:,:,i) = 0.
+        endwhere
+      enddo
+
+!------------------------------------------------------------
+!---- 4.1 Total Backscatter signal:
+!------------------------------------------------------------
+
+! optical thickness (molecular):
+!     opt. thick of each layer
+      tau_mol(:,1:nlev) = alpha_mol(:,1:nlev) &
+         & *(zheight(:,2:nlev+1)-zheight(:,1:nlev))
+!     opt. thick from TOA
+      DO k = nlev-1, 1, -1
+        tau_mol(:,k) = tau_mol(:,k) + tau_mol(:,k+1)
+      ENDDO
+
+! optical thickness (particles):
+
+      tau_part = rdiffm * alpha_part
+      DO i = 1, npart
+!       opt. thick of each layer
+        tau_part(:,:,i) = tau_part(:,:,i) &
+           & * (zheight(:,2:nlev+1)-zheight(:,1:nlev) )
+!       opt. thick from TOA
+        DO k = nlev-1, 1, -1 
+          tau_part(:,k,i) = tau_part(:,k,i) + tau_part(:,k+1,i)
+        ENDDO
+      ENDDO
+
+! molecular signal:
+!      Upper layer 
+       pmol(:,nlev) = beta_mol(:,nlev) / (2.*tau_mol(:,nlev)) &
+            & * (1.-exp(-2.0*tau_mol(:,nlev)))
+!      Other layers
+       DO k= nlev-1, 1, -1
+        tau_mol_lay(:) = tau_mol(:,k)-tau_mol(:,k+1) ! opt. thick. of layer k
+        WHERE (tau_mol_lay(:).GT.0.)
+          pmol(:,k) = beta_mol(:,k) * EXP(-2.0*tau_mol(:,k+1)) / (2.*tau_mol_lay(:)) &
+            & * (1.-exp(-2.0*tau_mol_lay(:)))
+        ELSEWHERE
+!         This must never happend, but just in case, to avoid div. by 0
+          pmol(:,k) = beta_mol(:,k) * EXP(-2.0*tau_mol(:,k+1))
+        END WHERE
+      END DO
+
+! Total signal (molecular + particules):
+!
+!
+! For performance reason on vector computers, the 2 following lines should not be used
+! and should be replace by the later one.
+!      betatot(:,:) = beta_mol(:,:) + sum(kp_part*alpha_part,dim=3)
+!      tautot(:,:)  = tau_mol(:,:)  + sum(tau_part,dim=3)
+      betatot(:,:) = beta_mol(:,:)
+      tautot(:,:)  = tau_mol(:,:)
+      DO i = 1, npart
+           betatot(:,:) = betatot(:,:) + kp_part(:,:,i)*alpha_part(:,:,i)
+           tautot(:,:) = tautot(:,:)  + tau_part(:,:,i)
+      ENDDO ! i
+!
+!     Upper layer 
+      pnorm(:,nlev) = betatot(:,nlev) / (2.*tautot(:,nlev)) &
+            & * (1.-exp(-2.0*tautot(:,nlev)))
+
+!     Other layers
+      DO k= nlev-1, 1, -1
+          tautot_lay(:) = tautot(:,k)-tautot(:,k+1) ! optical thickness of layer k
+        WHERE (tautot_lay(:).GT.0.)
+          pnorm(:,k) = betatot(:,k) * EXP(-2.0*tautot(:,k+1)) / (2.*tautot_lay(:)) &
+               & * (1.-EXP(-2.0*tautot_lay(:)))
+        ELSEWHERE
+!         This must never happend, but just in case, to avoid div. by 0
+          pnorm(:,k) = betatot(:,k) * EXP(-2.0*tautot(:,k+1))
+        END WHERE
+      END DO
+
+!------------------------------------------------------------
+!---- 4.2 Ice/Liq Backscatter signal:
+!------------------------------------------------------------
+
+! Contribution of the molecular to beta
+      betatot_ice(:,:) = beta_mol(:,:)
+      betatot_liq(:,:) = beta_mol(:,:)
+
+      tautot_ice(:,:) = tau_mol(:,:)
+      tautot_liq(:,:) = tau_mol(:,:)
+
+      DO i = 2, npart,2
+           betatot_ice(:,:) = betatot_ice(:,:)+ kp_part(:,:,i)*alpha_part(:,:,i)
+           tautot_ice(:,:) = tautot_ice(:,:)  + tau_part(:,:,i)
+      ENDDO ! i
+      DO i = 1, npart,2
+           betatot_liq(:,:) = betatot_liq(:,:)+ kp_part(:,:,i)*alpha_part(:,:,i)
+           tautot_liq(:,:) = tautot_liq(:,:)  + tau_part(:,:,i)
+      ENDDO ! i
+
+
+! Computation of the ice and liquid lidar backscattered signal (ATBice and ATBliq)
+!     Ice only
+!     Upper layer
+      pnorm_ice(:,nlev) = betatot_ice(:,nlev) / (2.*tautot_ice(:,nlev)) &
+            & * (1.-exp(-2.0*tautot_ice(:,nlev)))
+
+      DO k= nlev-1, 1, -1
+          tautot_lay_ice(:) = tautot_ice(:,k)-tautot_ice(:,k+1) 
+        WHERE (tautot_lay_ice(:).GT.0.)
+         pnorm_ice(:,k)=betatot_ice(:,k)*EXP(-2.0*tautot_ice(:,k+1))/(2.*tautot_lay_ice(:)) &
+               & * (1.-EXP(-2.0*tautot_lay_ice(:)))
+        ELSEWHERE
+         pnorm_ice(:,k)=betatot_ice(:,k)*EXP(-2.0*tautot_ice(:,k+1))
+        END WHERE
+      ENDDO
+
+!     Liquid only
+!     Upper layer
+      pnorm_liq(:,nlev) = betatot_liq(:,nlev) / (2.*tautot_liq(:,nlev)) &
+            & * (1.-exp(-2.0*tautot_liq(:,nlev)))
+
+      DO k= nlev-1, 1, -1
+          tautot_lay_liq(:) = tautot_liq(:,k)-tautot_liq(:,k+1) 
+        WHERE (tautot_lay_liq(:).GT.0.)
+          pnorm_liq(:,k)=betatot_liq(:,k)*EXP(-2.0*tautot_liq(:,k+1))/(2.*tautot_lay_liq(:)) &
+               & * (1.-EXP(-2.0*tautot_lay_liq(:)))
+        ELSEWHERE
+          pnorm_liq(:,k)=betatot_liq(:,k)*EXP(-2.0*tautot_liq(:,k+1))
+        END WHERE
+      ENDDO
+
+
+! Computation of ATBperp,ice/liq from ATBice/liq including the multiple scattering 
+! contribution (Cesana and Chepfer 2013, JGR)
+!  ATBperp,ice = Alpha*ATBice 
+!  ATBperp,liq = Beta*ATBliq^2 + Gamma*ATBliq
+
+      DO k= nlev, 1, -1
+         pnorm_perp_ice(:,k) = Alpha * pnorm_ice(:,k) ! Ice particles
+         pnorm_perp_liq(:,k) = 1000*Beta * pnorm_liq(:,k)**2 + Gamma * pnorm_liq(:,k) ! Liquid particles
+      ENDDO
+
+! Computation of beta_perp_ice/liq using the lidar equation
+!     Ice only
+!     Upper layer 
+      beta_perp_ice(:,nlev) = pnorm_perp_ice(:,nlev) * (2.*tautot_ice(:,nlev)) &
+            & / (1.-exp(-2.0*tautot_ice(:,nlev)))
+
+      DO k= nlev-1, 1, -1
+        tautot_lay_ice(:) = tautot_ice(:,k)-tautot_ice(:,k+1)
+        WHERE (tautot_lay_ice(:).GT.0.)
+         beta_perp_ice(:,k) = pnorm_perp_ice(:,k)/ EXP(-2.0*tautot_ice(:,k+1)) * (2.*tautot_lay_ice(:)) &
+            & / (1.-exp(-2.0*tautot_lay_ice(:)))
+
+        ELSEWHERE
+         beta_perp_ice(:,k)=pnorm_perp_ice(:,k)/EXP(-2.0*tautot_ice(:,k+1))
+        END WHERE
+      ENDDO
+
+!     Liquid only
+!     Upper layer 
+      beta_perp_liq(:,nlev) = pnorm_perp_liq(:,nlev) * (2.*tautot_liq(:,nlev)) &
+            & / (1.-exp(-2.0*tautot_liq(:,nlev)))
+
+      DO k= nlev-1, 1, -1
+          tautot_lay_liq(:) = tautot_liq(:,k)-tautot_liq(:,k+1) 
+        WHERE (tautot_lay_liq(:).GT.0.)
+         beta_perp_liq(:,k) = pnorm_perp_liq(:,k)/ max(seuil,EXP(-2.0*tautot_liq(:,k+1))) &
+            & * (2.*tautot_lay_liq(:)) / (1.-exp(-2.0*tautot_lay_liq(:)))
+
+        ELSEWHERE
+         beta_perp_liq(:,k)=pnorm_perp_liq(:,k)/EXP(-2.0*tautot_liq(:,k+1))
+        END WHERE
+      ENDDO
+
+
+
+!------------------------------------------------------------
+!---- 4.3 Perpendicular Backscatter signal:
+!------------------------------------------------------------
+
+! Computation of the total perpendicular lidar signal (ATBperp for liq+ice)
+!     Upper layer 
+    WHERE(tautot(:,nlev).GT.0)
+          pnorm_perp_tot(:,nlev) = &
+              (beta_perp_ice(:,nlev)+beta_perp_liq(:,nlev)-(beta_mol(:,nlev)/(1+1/0.0284))) / (2.*tautot(:,nlev)) &
+              & * (1.-exp(-2.0*tautot(:,nlev)))
+    ELSEWHERE
+    pnorm_perp_tot(:,nlev) = 0.
+    ENDWHERE
+
+!     Other layers
+      DO k= nlev-1, 1, -1
+          tautot_lay(:) = tautot(:,k)-tautot(:,k+1) ! optical thickness of layer k
+
+          ! The perpendicular component of the molecular backscattered signal (Betaperp) has been 
+          ! taken into account two times (once for liquid and once for ice). 
+          ! We remove one contribution using 
+          ! Betaperp=beta_mol(:,k)/(1+1/0.0284)) [bodhaine et al. 1999] in the following equations:
+            WHERE (pnorm(:,k).eq.0)
+                  pnorm_perp_tot(:,k)=0.
+                  ELSEWHERE
+                    WHERE (tautot_lay(:).GT.0.)
+                      pnorm_perp_tot(:,k) = &
+                          (beta_perp_ice(:,k)+beta_perp_liq(:,k)-(beta_mol(:,k)/(1+1/0.0284))) * &
+                          EXP(-2.0*tautot(:,k+1)) / (2.*tautot_lay(:)) &
+                          & * (1.-EXP(-2.0*tautot_lay(:)))
+                    ELSEWHERE
+          !         This must never happen, but just in case, to avoid div. by 0
+                      pnorm_perp_tot(:,k) = &
+                           (beta_perp_ice(:,k)+beta_perp_liq(:,k)-(beta_mol(:,k)/(1+1/0.0284))) * &
+                          EXP(-2.0*tautot(:,k+1))
+                    END WHERE
+            ENDWHERE
+
+      END DO
+
+!-------- End computation Lidar --------------------------
+
+!---------------------------------------------------------
+!  Parasol/Polder module
+!
+!  Purpose : Compute reflectance for one particular viewing direction
+!  and 5 solar zenith angles (calculation valid only over ocean)
+! ---------------------------------------------------------
+
+! initialization:
+    refl(:,:) = 0.0
+
+! activate parasol calculations:
+    if (ok_parasol) then
+
+!     Optical thickness from TOA to surface
+      tautot_S_liq = 0.
+      tautot_S_ice = 0.
+      tautot_S_liq(:) = tautot_S_liq(:) &
+         + tau_part(:,1,1) + tau_part(:,1,3)
+      tautot_S_ice(:) = tautot_S_ice(:) &
+         + tau_part(:,1,2) + tau_part(:,1,4)
+
+      call parasol(npoints,nrefl,undef  &
+                 ,tautot_S_liq,tautot_S_ice &
+                 ,refl)
+
+    endif ! ok_parasol
+
+  END SUBROUTINE lidar_simulator
+!
+!---------------------------------------------------------------------------------
+!
+  SUBROUTINE parasol(npoints,nrefl,undef  &
+                       ,tautot_S_liq,tautot_S_ice  &
+                       ,refl)
+!---------------------------------------------------------------------------------
+! Purpose: To compute Parasol reflectance signal from model-simulated profiles 
+!          of cloud water and cloud fraction in each sub-column of each model 
+!          gridbox.
+!
+!
+! December 2008, S. Bony,  H. Chepfer and J-L. Dufresne : 
+! - optimization for vectorization
+!
+! Version 2.0 (October 2008)
+! Version 2.1 (December 2008)
+!---------------------------------------------------------------------------------
+
+    IMPLICIT NONE
+
+! inputs
+    INTEGER npoints              ! Number of horizontal gridpoints
+    INTEGER nrefl                ! Number of angles for which the reflectance 
+                                 ! is computed. Can not be greater then ntetas
+    REAL undef                   ! Undefined value. Currently not used
+    REAL tautot_S_liq(npoints)   ! liquid water cloud optical thickness, 
+                                   ! integrated from TOA to surface
+    REAL tautot_S_ice(npoints)   ! same for ice water clouds only
+! outputs
+    REAL refl(npoints,nrefl)     ! Parasol reflectances
+!
+! Local variables
+    REAL tautot_S(npoints)       ! cloud optical thickness, from TOA to surface
+    REAL frac_taucol_liq(npoints), frac_taucol_ice(npoints)
+
+    REAL pi
+!   look up table variables:
+    INTEGER ny, it
+    INTEGER ntetas, nbtau        ! number of angle and of optical thickness
+                                   ! of the look-up table
+    PARAMETER (ntetas=5, nbtau=7)
+    REAL aa(ntetas,nbtau-1), ab(ntetas,nbtau-1)
+    REAL ba(ntetas,nbtau-1), bb(ntetas,nbtau-1)  
+    REAL tetas(ntetas),tau(nbtau)                        
+    REAL r_norm(ntetas)
+    REAL rlumA(ntetas,nbtau), rlumB(ntetas,nbtau)       
+    REAL rlumA_mod(npoints,5), rlumB_mod(npoints,5) 
+
+    DATA tau   /0., 1., 5., 10., 20., 50., 100./
+    DATA tetas /0., 20., 40., 60., 80./
+    
+! Look-up table for spherical liquid particles:
+    DATA (rlumA(1,ny),ny=1,nbtau) /0.03, 0.090886, 0.283965, &
+     0.480587, 0.695235, 0.908229, 1.0 /
+    DATA (rlumA(2,ny),ny=1,nbtau) /0.03, 0.072185, 0.252596, &
+      0.436401,  0.631352, 0.823924, 0.909013 /
+    DATA (rlumA(3,ny),ny=1,nbtau) /0.03, 0.058410, 0.224707, &
+      0.367451,  0.509180, 0.648152, 0.709554 /
+    DATA (rlumA(4,ny),ny=1,nbtau) /0.03, 0.052498, 0.175844, &
+      0.252916,  0.326551, 0.398581, 0.430405 /
+    DATA (rlumA(5,ny),ny=1,nbtau) /0.03, 0.034730, 0.064488, &
+      0.081667,  0.098215, 0.114411, 0.121567 /
+
+! Look-up table for ice particles:
+    DATA (rlumB(1,ny),ny=1,nbtau) /0.03, 0.092170, 0.311941, &
+       0.511298, 0.712079 , 0.898243 , 0.976646 /
+    DATA (rlumB(2,ny),ny=1,nbtau) /0.03, 0.087082, 0.304293, &
+       0.490879,  0.673565, 0.842026, 0.912966 /
+    DATA (rlumB(3,ny),ny=1,nbtau) /0.03, 0.083325, 0.285193, &
+      0.430266,  0.563747, 0.685773,  0.737154 /
+    DATA (rlumB(4,ny),ny=1,nbtau) /0.03, 0.084935, 0.233450, &
+      0.312280, 0.382376, 0.446371, 0.473317 /
+    DATA (rlumB(5,ny),ny=1,nbtau) /0.03, 0.054157, 0.089911, &
+      0.107854, 0.124127, 0.139004, 0.145269 /
+
+!--------------------------------------------------------------------------------
+! Lum_norm=f(tetaS,tau_cloud) derived from adding-doubling calculations
+!        valid ONLY ABOVE OCEAN (albedo_sfce=5%)
+!        valid only in one viewing direction (theta_v=30�, phi_s-phi_v=320�)
+!        based on adding-doubling radiative transfer computation
+!        for tau values (0 to 100) and for tetas values (0 to 80)
+!        for 2 scattering phase functions: liquid spherical, ice non spherical
+
+    IF ( nrefl.GT. ntetas ) THEN
+        PRINT *,'Error in lidar_simulator, nrefl should be less then ',ntetas,' not',nrefl
+        STOP
+    ENDIF
+
+    rlumA_mod=0
+    rlumB_mod=0
+!
+    pi = ACOS(-1.0)
+    r_norm(:)=1./ COS(pi/180.*tetas(:))
+!
+    tautot_S_liq(:)=MAX(tautot_S_liq(:),tau(1))
+    tautot_S_ice(:)=MAX(tautot_S_ice(:),tau(1))
+    tautot_S(:) = tautot_S_ice(:) + tautot_S_liq(:)
+!
+! relative fraction of the opt. thick due to liquid or ice clouds
+    WHERE (tautot_S(:) .GT. 0.)
+        frac_taucol_liq(:) = tautot_S_liq(:) / tautot_S(:)
+        frac_taucol_ice(:) = tautot_S_ice(:) / tautot_S(:)
+    ELSEWHERE
+        frac_taucol_liq(:) = 1.
+        frac_taucol_ice(:) = 0.
+    END WHERE
+    tautot_S(:)=MIN(tautot_S(:),tau(nbtau))
+!
+! Linear interpolation :
+
+    DO ny=1,nbtau-1
+! microphysics A (liquid clouds) 
+      aA(:,ny) = (rlumA(:,ny+1)-rlumA(:,ny))/(tau(ny+1)-tau(ny))
+      bA(:,ny) = rlumA(:,ny) - aA(:,ny)*tau(ny)
+! microphysics B (ice clouds)
+      aB(:,ny) = (rlumB(:,ny+1)-rlumB(:,ny))/(tau(ny+1)-tau(ny))
+      bB(:,ny) = rlumB(:,ny) - aB(:,ny)*tau(ny)
+    ENDDO
+!
+    DO it=1,ntetas
+      DO ny=1,nbtau-1
+        WHERE (tautot_S(:).GE.tau(ny).AND.tautot_S(:).LE.tau(ny+1))
+            rlumA_mod(:,it) = aA(it,ny)*tautot_S(:) + bA(it,ny)
+            rlumB_mod(:,it) = aB(it,ny)*tautot_S(:) + bB(it,ny)
+        END WHERE
+      END DO
+    END DO
+!
+    DO it=1,ntetas
+      refl(:,it) = frac_taucol_liq(:) * rlumA_mod(:,it) &
+         + frac_taucol_ice(:) * rlumB_mod(:,it)
+! normalized radiance -> reflectance: 
+      refl(:,it) = refl(:,it) * r_norm(it)
+    ENDDO
+
+    RETURN
+  END SUBROUTINE parasol
Index: DZ6/trunk/libf/phylmd/cosp/m_mrgrnk.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cosp/m_mrgrnk.F90	(revision 5267)
+++ 	(revision )
@@ -1,411 +1,0 @@
-Module m_mrgrnk
-IMPLICIT NONE
-Integer, Parameter :: kdp = selected_real_kind(15)
-public :: mrgrnk
-private :: kdp
-private :: I_mrgrnk, D_mrgrnk
-interface mrgrnk
-  module procedure D_mrgrnk, I_mrgrnk
-end interface mrgrnk
-contains
-
-Subroutine D_mrgrnk (XDONT, IRNGT)
-! __________________________________________________________
-!   MRGRNK = Merge-sort ranking of an array
-!   For performance reasons, the first 2 passes are taken
-!   out of the standard loop, and use dedicated coding.
-! __________________________________________________________
-! __________________________________________________________
-      Real (kind=kdp), Dimension (:), Intent (In) :: XDONT
-      Integer, Dimension (:), Intent (Out) :: IRNGT
-! __________________________________________________________
-      Real (kind=kdp) :: XVALA, XVALB
-!
-      Integer, Dimension (SIZE(IRNGT)) :: JWRKT
-      Integer :: LMTNA, LMTNC, IRNG1, IRNG2
-      Integer :: NVAL, IIND, IWRKD, IWRK, IWRKF, JINDA, IINDA, IINDB
-!
-      NVAL = Min (SIZE(XDONT), SIZE(IRNGT))
-      Select Case (NVAL)
-      Case (:0)
-         Return
-      Case (1)
-         IRNGT (1) = 1
-         Return
-      Case Default
-         Continue
-      End Select
-!
-!  Fill-in the index array, creating ordered couples
-!
-      Do IIND = 2, NVAL, 2
-         If (XDONT(IIND-1) <= XDONT(IIND)) Then
-            IRNGT (IIND-1) = IIND - 1
-            IRNGT (IIND) = IIND
-         Else
-            IRNGT (IIND-1) = IIND
-            IRNGT (IIND) = IIND - 1
-         End If
-      End Do
-      If (Modulo(NVAL, 2) /= 0) Then
-         IRNGT (NVAL) = NVAL
-      End If
-!
-!  We will now have ordered subsets A - B - A - B - ...
-!  and merge A and B couples into     C   -   C   - ...
-!
-      LMTNA = 2
-      LMTNC = 4
-!
-!  First iteration. The length of the ordered subsets goes from 2 to 4
-!
-      Do
-         If (NVAL <= 2) Exit
-!
-!   Loop on merges of A and B into C
-!
-         Do IWRKD = 0, NVAL - 1, 4
-            If ((IWRKD+4) > NVAL) Then
-               If ((IWRKD+2) >= NVAL) Exit
-!
-!   1 2 3
-!
-               If (XDONT(IRNGT(IWRKD+2)) <= XDONT(IRNGT(IWRKD+3))) Exit
-!
-!   1 3 2
-!
-               If (XDONT(IRNGT(IWRKD+1)) <= XDONT(IRNGT(IWRKD+3))) Then
-                  IRNG2 = IRNGT (IWRKD+2)
-                  IRNGT (IWRKD+2) = IRNGT (IWRKD+3)
-                  IRNGT (IWRKD+3) = IRNG2
-!
-!   3 1 2
-!
-               Else
-                  IRNG1 = IRNGT (IWRKD+1)
-                  IRNGT (IWRKD+1) = IRNGT (IWRKD+3)
-                  IRNGT (IWRKD+3) = IRNGT (IWRKD+2)
-                  IRNGT (IWRKD+2) = IRNG1
-               End If
-               Exit
-            End If
-!
-!   1 2 3 4
-!
-            If (XDONT(IRNGT(IWRKD+2)) <= XDONT(IRNGT(IWRKD+3))) Cycle
-!
-!   1 3 x x
-!
-            If (XDONT(IRNGT(IWRKD+1)) <= XDONT(IRNGT(IWRKD+3))) Then
-               IRNG2 = IRNGT (IWRKD+2)
-               IRNGT (IWRKD+2) = IRNGT (IWRKD+3)
-               If (XDONT(IRNG2) <= XDONT(IRNGT(IWRKD+4))) Then
-!   1 3 2 4
-                  IRNGT (IWRKD+3) = IRNG2
-               Else
-!   1 3 4 2
-                  IRNGT (IWRKD+3) = IRNGT (IWRKD+4)
-                  IRNGT (IWRKD+4) = IRNG2
-               End If
-!
-!   3 x x x
-!
-            Else
-               IRNG1 = IRNGT (IWRKD+1)
-               IRNG2 = IRNGT (IWRKD+2)
-               IRNGT (IWRKD+1) = IRNGT (IWRKD+3)
-               If (XDONT(IRNG1) <= XDONT(IRNGT(IWRKD+4))) Then
-                  IRNGT (IWRKD+2) = IRNG1
-                  If (XDONT(IRNG2) <= XDONT(IRNGT(IWRKD+4))) Then
-!   3 1 2 4
-                     IRNGT (IWRKD+3) = IRNG2
-                  Else
-!   3 1 4 2
-                     IRNGT (IWRKD+3) = IRNGT (IWRKD+4)
-                     IRNGT (IWRKD+4) = IRNG2
-                  End If
-               Else
-!   3 4 1 2
-                  IRNGT (IWRKD+2) = IRNGT (IWRKD+4)
-                  IRNGT (IWRKD+3) = IRNG1
-                  IRNGT (IWRKD+4) = IRNG2
-               End If
-            End If
-         End Do
-!
-!  The Cs become As and Bs
-!
-         LMTNA = 4
-         Exit
-      End Do
-!
-!  Iteration loop. Each time, the length of the ordered subsets
-!  is doubled.
-!
-      Do
-         If (LMTNA >= NVAL) Exit
-         IWRKF = 0
-         LMTNC = 2 * LMTNC
-!
-!   Loop on merges of A and B into C
-!
-         Do
-            IWRK = IWRKF
-            IWRKD = IWRKF + 1
-            JINDA = IWRKF + LMTNA
-            IWRKF = IWRKF + LMTNC
-            If (IWRKF >= NVAL) Then
-               If (JINDA >= NVAL) Exit
-               IWRKF = NVAL
-            End If
-            IINDA = 1
-            IINDB = JINDA + 1
-!
-!   Shortcut for the case when the max of A is smaller
-!   than the min of B. This line may be activated when the
-!   initial set is already close to sorted.
-!
-!          IF (XDONT(IRNGT(JINDA)) <= XDONT(IRNGT(IINDB))) CYCLE
-!
-!  One steps in the C subset, that we build in the final rank array
-!
-!  Make a copy of the rank array for the merge iteration
-!
-            JWRKT (1:LMTNA) = IRNGT (IWRKD:JINDA)
-!
-            XVALA = XDONT (JWRKT(IINDA))
-            XVALB = XDONT (IRNGT(IINDB))
-!
-            Do
-               IWRK = IWRK + 1
-!
-!  We still have unprocessed values in both A and B
-!
-               If (XVALA > XVALB) Then
-                  IRNGT (IWRK) = IRNGT (IINDB)
-                  IINDB = IINDB + 1
-                  If (IINDB > IWRKF) Then
-!  Only A still with unprocessed values
-                     IRNGT (IWRK+1:IWRKF) = JWRKT (IINDA:LMTNA)
-                     Exit
-                  End If
-                  XVALB = XDONT (IRNGT(IINDB))
-               Else
-                  IRNGT (IWRK) = JWRKT (IINDA)
-                  IINDA = IINDA + 1
-                  If (IINDA > LMTNA) Exit! Only B still with unprocessed values
-                  XVALA = XDONT (JWRKT(IINDA))
-               End If
-!
-            End Do
-         End Do
-!
-!  The Cs become As and Bs
-!
-         LMTNA = 2 * LMTNA
-      End Do
-!
-      Return
-!
-End Subroutine D_mrgrnk
-
-Subroutine I_mrgrnk (XDONT, IRNGT)
-! __________________________________________________________
-!   MRGRNK = Merge-sort ranking of an array
-!   For performance reasons, the first 2 passes are taken
-!   out of the standard loop, and use dedicated coding.
-! __________________________________________________________
-! __________________________________________________________
-      Integer, Dimension (:), Intent (In)  :: XDONT
-      Integer, Dimension (:), Intent (Out) :: IRNGT
-! __________________________________________________________
-      Integer :: XVALA, XVALB
-!
-      Integer, Dimension (SIZE(IRNGT)) :: JWRKT
-      Integer :: LMTNA, LMTNC, IRNG1, IRNG2
-      Integer :: NVAL, IIND, IWRKD, IWRK, IWRKF, JINDA, IINDA, IINDB
-!
-      NVAL = Min (SIZE(XDONT), SIZE(IRNGT))
-      Select Case (NVAL)
-      Case (:0)
-         Return
-      Case (1)
-         IRNGT (1) = 1
-         Return
-      Case Default
-         Continue
-      End Select
-!
-!  Fill-in the index array, creating ordered couples
-!
-      Do IIND = 2, NVAL, 2
-         If (XDONT(IIND-1) <= XDONT(IIND)) Then
-            IRNGT (IIND-1) = IIND - 1
-            IRNGT (IIND) = IIND
-         Else
-            IRNGT (IIND-1) = IIND
-            IRNGT (IIND) = IIND - 1
-         End If
-      End Do
-      If (Modulo(NVAL, 2) /= 0) Then
-         IRNGT (NVAL) = NVAL
-      End If
-!
-!  We will now have ordered subsets A - B - A - B - ...
-!  and merge A and B couples into     C   -   C   - ...
-!
-      LMTNA = 2
-      LMTNC = 4
-!
-!  First iteration. The length of the ordered subsets goes from 2 to 4
-!
-      Do
-         If (NVAL <= 2) Exit
-!
-!   Loop on merges of A and B into C
-!
-         Do IWRKD = 0, NVAL - 1, 4
-            If ((IWRKD+4) > NVAL) Then
-               If ((IWRKD+2) >= NVAL) Exit
-!
-!   1 2 3
-!
-               If (XDONT(IRNGT(IWRKD+2)) <= XDONT(IRNGT(IWRKD+3))) Exit
-!
-!   1 3 2
-!
-               If (XDONT(IRNGT(IWRKD+1)) <= XDONT(IRNGT(IWRKD+3))) Then
-                  IRNG2 = IRNGT (IWRKD+2)
-                  IRNGT (IWRKD+2) = IRNGT (IWRKD+3)
-                  IRNGT (IWRKD+3) = IRNG2
-!
-!   3 1 2
-!
-               Else
-                  IRNG1 = IRNGT (IWRKD+1)
-                  IRNGT (IWRKD+1) = IRNGT (IWRKD+3)
-                  IRNGT (IWRKD+3) = IRNGT (IWRKD+2)
-                  IRNGT (IWRKD+2) = IRNG1
-               End If
-               Exit
-            End If
-!
-!   1 2 3 4
-!
-            If (XDONT(IRNGT(IWRKD+2)) <= XDONT(IRNGT(IWRKD+3))) Cycle
-!
-!   1 3 x x
-!
-            If (XDONT(IRNGT(IWRKD+1)) <= XDONT(IRNGT(IWRKD+3))) Then
-               IRNG2 = IRNGT (IWRKD+2)
-               IRNGT (IWRKD+2) = IRNGT (IWRKD+3)
-               If (XDONT(IRNG2) <= XDONT(IRNGT(IWRKD+4))) Then
-!   1 3 2 4
-                  IRNGT (IWRKD+3) = IRNG2
-               Else
-!   1 3 4 2
-                  IRNGT (IWRKD+3) = IRNGT (IWRKD+4)
-                  IRNGT (IWRKD+4) = IRNG2
-               End If
-!
-!   3 x x x
-!
-            Else
-               IRNG1 = IRNGT (IWRKD+1)
-               IRNG2 = IRNGT (IWRKD+2)
-               IRNGT (IWRKD+1) = IRNGT (IWRKD+3)
-               If (XDONT(IRNG1) <= XDONT(IRNGT(IWRKD+4))) Then
-                  IRNGT (IWRKD+2) = IRNG1
-                  If (XDONT(IRNG2) <= XDONT(IRNGT(IWRKD+4))) Then
-!   3 1 2 4
-                     IRNGT (IWRKD+3) = IRNG2
-                  Else
-!   3 1 4 2
-                     IRNGT (IWRKD+3) = IRNGT (IWRKD+4)
-                     IRNGT (IWRKD+4) = IRNG2
-                  End If
-               Else
-!   3 4 1 2
-                  IRNGT (IWRKD+2) = IRNGT (IWRKD+4)
-                  IRNGT (IWRKD+3) = IRNG1
-                  IRNGT (IWRKD+4) = IRNG2
-               End If
-            End If
-         End Do
-!
-!  The Cs become As and Bs
-!
-         LMTNA = 4
-         Exit
-      End Do
-!
-!  Iteration loop. Each time, the length of the ordered subsets
-!  is doubled.
-!
-      Do
-         If (LMTNA >= NVAL) Exit
-         IWRKF = 0
-         LMTNC = 2 * LMTNC
-!
-!   Loop on merges of A and B into C
-!
-         Do
-            IWRK = IWRKF
-            IWRKD = IWRKF + 1
-            JINDA = IWRKF + LMTNA
-            IWRKF = IWRKF + LMTNC
-            If (IWRKF >= NVAL) Then
-               If (JINDA >= NVAL) Exit
-               IWRKF = NVAL
-            End If
-            IINDA = 1
-            IINDB = JINDA + 1
-!
-!   Shortcut for the case when the max of A is smaller
-!   than the min of B. This line may be activated when the
-!   initial set is already close to sorted.
-!
-!          IF (XDONT(IRNGT(JINDA)) <= XDONT(IRNGT(IINDB))) CYCLE
-!
-!  One steps in the C subset, that we build in the final rank array
-!
-!  Make a copy of the rank array for the merge iteration
-!
-            JWRKT (1:LMTNA) = IRNGT (IWRKD:JINDA)
-!
-            XVALA = XDONT (JWRKT(IINDA))
-            XVALB = XDONT (IRNGT(IINDB))
-!
-            Do
-               IWRK = IWRK + 1
-!
-!  We still have unprocessed values in both A and B
-!
-               If (XVALA > XVALB) Then
-                  IRNGT (IWRK) = IRNGT (IINDB)
-                  IINDB = IINDB + 1
-                  If (IINDB > IWRKF) Then
-!  Only A still with unprocessed values
-                     IRNGT (IWRK+1:IWRKF) = JWRKT (IINDA:LMTNA)
-                     Exit
-                  End If
-                  XVALB = XDONT (IRNGT(IINDB))
-               Else
-                  IRNGT (IWRK) = JWRKT (IINDA)
-                  IINDA = IINDA + 1
-                  If (IINDA > LMTNA) Exit! Only B still with unprocessed values
-                  XVALA = XDONT (JWRKT(IINDA))
-               End If
-!
-            End Do
-         End Do
-!
-!  The Cs become As and Bs
-!
-         LMTNA = 2 * LMTNA
-      End Do
-!
-      Return
-!
-End Subroutine I_mrgrnk
-end module m_mrgrnk
Index: /LMDZ6/trunk/libf/phylmd/cosp/m_mrgrnk.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cosp/m_mrgrnk.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/cosp/m_mrgrnk.f90	(revision 5268)
@@ -0,0 +1,411 @@
+Module m_mrgrnk
+IMPLICIT NONE
+Integer, Parameter :: kdp = selected_real_kind(15)
+public :: mrgrnk
+private :: kdp
+private :: I_mrgrnk, D_mrgrnk
+interface mrgrnk
+  module procedure D_mrgrnk, I_mrgrnk
+end interface mrgrnk
+contains
+
+Subroutine D_mrgrnk (XDONT, IRNGT)
+! __________________________________________________________
+!   MRGRNK = Merge-sort ranking of an array
+!   For performance reasons, the first 2 passes are taken
+!   out of the standard loop, and use dedicated coding.
+! __________________________________________________________
+! __________________________________________________________
+      Real (kind=kdp), Dimension (:), Intent (In) :: XDONT
+      Integer, Dimension (:), Intent (Out) :: IRNGT
+! __________________________________________________________
+      Real (kind=kdp) :: XVALA, XVALB
+!
+      Integer, Dimension (SIZE(IRNGT)) :: JWRKT
+      Integer :: LMTNA, LMTNC, IRNG1, IRNG2
+      Integer :: NVAL, IIND, IWRKD, IWRK, IWRKF, JINDA, IINDA, IINDB
+!
+      NVAL = Min (SIZE(XDONT), SIZE(IRNGT))
+      Select Case (NVAL)
+      Case (:0)
+         Return
+      Case (1)
+         IRNGT (1) = 1
+         Return
+      Case Default
+         Continue
+      End Select
+!
+!  Fill-in the index array, creating ordered couples
+!
+      Do IIND = 2, NVAL, 2
+         If (XDONT(IIND-1) <= XDONT(IIND)) Then
+            IRNGT (IIND-1) = IIND - 1
+            IRNGT (IIND) = IIND
+         Else
+            IRNGT (IIND-1) = IIND
+            IRNGT (IIND) = IIND - 1
+         End If
+      End Do
+      If (Modulo(NVAL, 2) /= 0) Then
+         IRNGT (NVAL) = NVAL
+      End If
+!
+!  We will now have ordered subsets A - B - A - B - ...
+!  and merge A and B couples into     C   -   C   - ...
+!
+      LMTNA = 2
+      LMTNC = 4
+!
+!  First iteration. The length of the ordered subsets goes from 2 to 4
+!
+      Do
+         If (NVAL <= 2) Exit
+!
+!   Loop on merges of A and B into C
+!
+         Do IWRKD = 0, NVAL - 1, 4
+            If ((IWRKD+4) > NVAL) Then
+               If ((IWRKD+2) >= NVAL) Exit
+!
+!   1 2 3
+!
+               If (XDONT(IRNGT(IWRKD+2)) <= XDONT(IRNGT(IWRKD+3))) Exit
+!
+!   1 3 2
+!
+               If (XDONT(IRNGT(IWRKD+1)) <= XDONT(IRNGT(IWRKD+3))) Then
+                  IRNG2 = IRNGT (IWRKD+2)
+                  IRNGT (IWRKD+2) = IRNGT (IWRKD+3)
+                  IRNGT (IWRKD+3) = IRNG2
+!
+!   3 1 2
+!
+               Else
+                  IRNG1 = IRNGT (IWRKD+1)
+                  IRNGT (IWRKD+1) = IRNGT (IWRKD+3)
+                  IRNGT (IWRKD+3) = IRNGT (IWRKD+2)
+                  IRNGT (IWRKD+2) = IRNG1
+               End If
+               Exit
+            End If
+!
+!   1 2 3 4
+!
+            If (XDONT(IRNGT(IWRKD+2)) <= XDONT(IRNGT(IWRKD+3))) Cycle
+!
+!   1 3 x x
+!
+            If (XDONT(IRNGT(IWRKD+1)) <= XDONT(IRNGT(IWRKD+3))) Then
+               IRNG2 = IRNGT (IWRKD+2)
+               IRNGT (IWRKD+2) = IRNGT (IWRKD+3)
+               If (XDONT(IRNG2) <= XDONT(IRNGT(IWRKD+4))) Then
+!   1 3 2 4
+                  IRNGT (IWRKD+3) = IRNG2
+               Else
+!   1 3 4 2
+                  IRNGT (IWRKD+3) = IRNGT (IWRKD+4)
+                  IRNGT (IWRKD+4) = IRNG2
+               End If
+!
+!   3 x x x
+!
+            Else
+               IRNG1 = IRNGT (IWRKD+1)
+               IRNG2 = IRNGT (IWRKD+2)
+               IRNGT (IWRKD+1) = IRNGT (IWRKD+3)
+               If (XDONT(IRNG1) <= XDONT(IRNGT(IWRKD+4))) Then
+                  IRNGT (IWRKD+2) = IRNG1
+                  If (XDONT(IRNG2) <= XDONT(IRNGT(IWRKD+4))) Then
+!   3 1 2 4
+                     IRNGT (IWRKD+3) = IRNG2
+                  Else
+!   3 1 4 2
+                     IRNGT (IWRKD+3) = IRNGT (IWRKD+4)
+                     IRNGT (IWRKD+4) = IRNG2
+                  End If
+               Else
+!   3 4 1 2
+                  IRNGT (IWRKD+2) = IRNGT (IWRKD+4)
+                  IRNGT (IWRKD+3) = IRNG1
+                  IRNGT (IWRKD+4) = IRNG2
+               End If
+            End If
+         End Do
+!
+!  The Cs become As and Bs
+!
+         LMTNA = 4
+         Exit
+      End Do
+!
+!  Iteration loop. Each time, the length of the ordered subsets
+!  is doubled.
+!
+      Do
+         If (LMTNA >= NVAL) Exit
+         IWRKF = 0
+         LMTNC = 2 * LMTNC
+!
+!   Loop on merges of A and B into C
+!
+         Do
+            IWRK = IWRKF
+            IWRKD = IWRKF + 1
+            JINDA = IWRKF + LMTNA
+            IWRKF = IWRKF + LMTNC
+            If (IWRKF >= NVAL) Then
+               If (JINDA >= NVAL) Exit
+               IWRKF = NVAL
+            End If
+            IINDA = 1
+            IINDB = JINDA + 1
+!
+!   Shortcut for the case when the max of A is smaller
+!   than the min of B. This line may be activated when the
+!   initial set is already close to sorted.
+!
+!          IF (XDONT(IRNGT(JINDA)) <= XDONT(IRNGT(IINDB))) CYCLE
+!
+!  One steps in the C subset, that we build in the final rank array
+!
+!  Make a copy of the rank array for the merge iteration
+!
+            JWRKT (1:LMTNA) = IRNGT (IWRKD:JINDA)
+!
+            XVALA = XDONT (JWRKT(IINDA))
+            XVALB = XDONT (IRNGT(IINDB))
+!
+            Do
+               IWRK = IWRK + 1
+!
+!  We still have unprocessed values in both A and B
+!
+               If (XVALA > XVALB) Then
+                  IRNGT (IWRK) = IRNGT (IINDB)
+                  IINDB = IINDB + 1
+                  If (IINDB > IWRKF) Then
+!  Only A still with unprocessed values
+                     IRNGT (IWRK+1:IWRKF) = JWRKT (IINDA:LMTNA)
+                     Exit
+                  End If
+                  XVALB = XDONT (IRNGT(IINDB))
+               Else
+                  IRNGT (IWRK) = JWRKT (IINDA)
+                  IINDA = IINDA + 1
+                  If (IINDA > LMTNA) Exit! Only B still with unprocessed values
+                  XVALA = XDONT (JWRKT(IINDA))
+               End If
+!
+            End Do
+         End Do
+!
+!  The Cs become As and Bs
+!
+         LMTNA = 2 * LMTNA
+      End Do
+!
+      Return
+!
+End Subroutine D_mrgrnk
+
+Subroutine I_mrgrnk (XDONT, IRNGT)
+! __________________________________________________________
+!   MRGRNK = Merge-sort ranking of an array
+!   For performance reasons, the first 2 passes are taken
+!   out of the standard loop, and use dedicated coding.
+! __________________________________________________________
+! __________________________________________________________
+      Integer, Dimension (:), Intent (In)  :: XDONT
+      Integer, Dimension (:), Intent (Out) :: IRNGT
+! __________________________________________________________
+      Integer :: XVALA, XVALB
+!
+      Integer, Dimension (SIZE(IRNGT)) :: JWRKT
+      Integer :: LMTNA, LMTNC, IRNG1, IRNG2
+      Integer :: NVAL, IIND, IWRKD, IWRK, IWRKF, JINDA, IINDA, IINDB
+!
+      NVAL = Min (SIZE(XDONT), SIZE(IRNGT))
+      Select Case (NVAL)
+      Case (:0)
+         Return
+      Case (1)
+         IRNGT (1) = 1
+         Return
+      Case Default
+         Continue
+      End Select
+!
+!  Fill-in the index array, creating ordered couples
+!
+      Do IIND = 2, NVAL, 2
+         If (XDONT(IIND-1) <= XDONT(IIND)) Then
+            IRNGT (IIND-1) = IIND - 1
+            IRNGT (IIND) = IIND
+         Else
+            IRNGT (IIND-1) = IIND
+            IRNGT (IIND) = IIND - 1
+         End If
+      End Do
+      If (Modulo(NVAL, 2) /= 0) Then
+         IRNGT (NVAL) = NVAL
+      End If
+!
+!  We will now have ordered subsets A - B - A - B - ...
+!  and merge A and B couples into     C   -   C   - ...
+!
+      LMTNA = 2
+      LMTNC = 4
+!
+!  First iteration. The length of the ordered subsets goes from 2 to 4
+!
+      Do
+         If (NVAL <= 2) Exit
+!
+!   Loop on merges of A and B into C
+!
+         Do IWRKD = 0, NVAL - 1, 4
+            If ((IWRKD+4) > NVAL) Then
+               If ((IWRKD+2) >= NVAL) Exit
+!
+!   1 2 3
+!
+               If (XDONT(IRNGT(IWRKD+2)) <= XDONT(IRNGT(IWRKD+3))) Exit
+!
+!   1 3 2
+!
+               If (XDONT(IRNGT(IWRKD+1)) <= XDONT(IRNGT(IWRKD+3))) Then
+                  IRNG2 = IRNGT (IWRKD+2)
+                  IRNGT (IWRKD+2) = IRNGT (IWRKD+3)
+                  IRNGT (IWRKD+3) = IRNG2
+!
+!   3 1 2
+!
+               Else
+                  IRNG1 = IRNGT (IWRKD+1)
+                  IRNGT (IWRKD+1) = IRNGT (IWRKD+3)
+                  IRNGT (IWRKD+3) = IRNGT (IWRKD+2)
+                  IRNGT (IWRKD+2) = IRNG1
+               End If
+               Exit
+            End If
+!
+!   1 2 3 4
+!
+            If (XDONT(IRNGT(IWRKD+2)) <= XDONT(IRNGT(IWRKD+3))) Cycle
+!
+!   1 3 x x
+!
+            If (XDONT(IRNGT(IWRKD+1)) <= XDONT(IRNGT(IWRKD+3))) Then
+               IRNG2 = IRNGT (IWRKD+2)
+               IRNGT (IWRKD+2) = IRNGT (IWRKD+3)
+               If (XDONT(IRNG2) <= XDONT(IRNGT(IWRKD+4))) Then
+!   1 3 2 4
+                  IRNGT (IWRKD+3) = IRNG2
+               Else
+!   1 3 4 2
+                  IRNGT (IWRKD+3) = IRNGT (IWRKD+4)
+                  IRNGT (IWRKD+4) = IRNG2
+               End If
+!
+!   3 x x x
+!
+            Else
+               IRNG1 = IRNGT (IWRKD+1)
+               IRNG2 = IRNGT (IWRKD+2)
+               IRNGT (IWRKD+1) = IRNGT (IWRKD+3)
+               If (XDONT(IRNG1) <= XDONT(IRNGT(IWRKD+4))) Then
+                  IRNGT (IWRKD+2) = IRNG1
+                  If (XDONT(IRNG2) <= XDONT(IRNGT(IWRKD+4))) Then
+!   3 1 2 4
+                     IRNGT (IWRKD+3) = IRNG2
+                  Else
+!   3 1 4 2
+                     IRNGT (IWRKD+3) = IRNGT (IWRKD+4)
+                     IRNGT (IWRKD+4) = IRNG2
+                  End If
+               Else
+!   3 4 1 2
+                  IRNGT (IWRKD+2) = IRNGT (IWRKD+4)
+                  IRNGT (IWRKD+3) = IRNG1
+                  IRNGT (IWRKD+4) = IRNG2
+               End If
+            End If
+         End Do
+!
+!  The Cs become As and Bs
+!
+         LMTNA = 4
+         Exit
+      End Do
+!
+!  Iteration loop. Each time, the length of the ordered subsets
+!  is doubled.
+!
+      Do
+         If (LMTNA >= NVAL) Exit
+         IWRKF = 0
+         LMTNC = 2 * LMTNC
+!
+!   Loop on merges of A and B into C
+!
+         Do
+            IWRK = IWRKF
+            IWRKD = IWRKF + 1
+            JINDA = IWRKF + LMTNA
+            IWRKF = IWRKF + LMTNC
+            If (IWRKF >= NVAL) Then
+               If (JINDA >= NVAL) Exit
+               IWRKF = NVAL
+            End If
+            IINDA = 1
+            IINDB = JINDA + 1
+!
+!   Shortcut for the case when the max of A is smaller
+!   than the min of B. This line may be activated when the
+!   initial set is already close to sorted.
+!
+!          IF (XDONT(IRNGT(JINDA)) <= XDONT(IRNGT(IINDB))) CYCLE
+!
+!  One steps in the C subset, that we build in the final rank array
+!
+!  Make a copy of the rank array for the merge iteration
+!
+            JWRKT (1:LMTNA) = IRNGT (IWRKD:JINDA)
+!
+            XVALA = XDONT (JWRKT(IINDA))
+            XVALB = XDONT (IRNGT(IINDB))
+!
+            Do
+               IWRK = IWRK + 1
+!
+!  We still have unprocessed values in both A and B
+!
+               If (XVALA > XVALB) Then
+                  IRNGT (IWRK) = IRNGT (IINDB)
+                  IINDB = IINDB + 1
+                  If (IINDB > IWRKF) Then
+!  Only A still with unprocessed values
+                     IRNGT (IWRK+1:IWRKF) = JWRKT (IINDA:LMTNA)
+                     Exit
+                  End If
+                  XVALB = XDONT (IRNGT(IINDB))
+               Else
+                  IRNGT (IWRK) = JWRKT (IINDA)
+                  IINDA = IINDA + 1
+                  If (IINDA > LMTNA) Exit! Only B still with unprocessed values
+                  XVALA = XDONT (JWRKT(IINDA))
+               End If
+!
+            End Do
+         End Do
+!
+!  The Cs become As and Bs
+!
+         LMTNA = 2 * LMTNA
+      End Do
+!
+      Return
+!
+End Subroutine I_mrgrnk
+end module m_mrgrnk
Index: DZ6/trunk/libf/phylmd/cosp/math_lib.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cosp/math_lib.F90	(revision 5267)
+++ 	(revision )
@@ -1,397 +1,0 @@
-! $Revision: 23 $, $Date: 2011-03-31 15:41:37 +0200 (jeu. 31 mars 2011) $
-! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/quickbeam/math_lib.f90 $
-! MATH_LIB: Mathematics procedures for F90
-! Compiled/Modified:
-!   07/01/06  John Haynes (haynes@atmos.colostate.edu)
-! 
-! gamma (function)
-! path_integral (function)
-! avint (subroutine)
-  
-  module math_lib
-  implicit none
-
-  contains
-
-! ----------------------------------------------------------------------------
-! function GAMMA
-! ----------------------------------------------------------------------------
-  function gamma(x)
-  implicit none
-!
-! Purpose:
-!   Returns the gamma function
-!
-! Input:
-!   [x]   value to compute gamma function of
-!
-! Returns:
-!   gamma(x)
-!
-! Coded:
-!   02/02/06  John Haynes (haynes@atmos.colostate.edu)
-!   (original code of unknown origin)
-
-! ----- INPUTS -----
-  real*8, intent(in) :: x
-  
-! ----- OUTPUTS -----
-  real*8 :: gamma
-
-! ----- INTERNAL -----  
-  real*8 :: pi,ga,z,r,gr
-  real*8 :: g(26)
-  integer :: k,m1,m
-       
-  pi = acos(-1.)    
-  if (x ==int(x)) then
-    if (x > 0.0) then
-      ga=1.0
-      m1=x-1
-      do k=2,m1
-        ga=ga*k
-      enddo
-    else
-      ga=1.0+300
-    endif
-  else
-    if (abs(x) > 1.0) then
-      z=abs(x)
-      m=int(z)
-      r=1.0
-      do k=1,m
-        r=r*(z-k)
-      enddo
-      z=z-m
-    else
-      z=x
-    endif
-    data g/1.0,0.5772156649015329, &
-           -0.6558780715202538, -0.420026350340952d-1, &
-           0.1665386113822915,-.421977345555443d-1, &
-           -.96219715278770d-2, .72189432466630d-2, &
-           -.11651675918591d-2, -.2152416741149d-3, &
-           .1280502823882d-3, -.201348547807d-4, &
-           -.12504934821d-5, .11330272320d-5, &
-           -.2056338417d-6, .61160950d-8, &
-           .50020075d-8, -.11812746d-8, &
-           .1043427d-9, .77823d-11, &
-          -.36968d-11, .51d-12, &
-          -.206d-13, -.54d-14, .14d-14, .1d-15/
-    gr=g(26)
-    do k=25,1,-1
-      gr=gr*z+g(k)
-    enddo 
-    ga=1.0/(gr*z)
-    if (abs(x) > 1.0) then
-      ga=ga*r
-      if (x < 0.0) ga=-pi/(x*ga*sin(pi*x))
-    endif
-  endif
-  gamma = ga
-  return
-  end function gamma
-  
-! ----------------------------------------------------------------------------
-! function PATH_INTEGRAL 
-! ----------------------------------------------------------------------------
-  function path_integral(f,s,i1,i2)
-  use m_mrgrnk
-  use array_lib
-  implicit none
-!
-! Purpose:
-!   evalues the integral (f ds) between f(index=i1) and f(index=i2)
-!   using the AVINT procedure
-!
-! Inputs:
-!   [f]    functional values
-!   [s]    abscissa values
-!   [i1]   index of lower limit
-!   [i2]   index of upper limit
-!
-! Returns:
-!   result of path integral
-!
-! Notes:
-!   [s] may be in forward or reverse numerical order
-!
-! Requires:
-!   mrgrnk package
-!
-! Created:
-!   02/02/06  John Haynes (haynes@atmos.colostate.edu)
-
-! ----- INPUTS -----  
-  real*8, intent(in), dimension(:) :: f,s  
-  integer, intent(in) :: i1, i2
-
-! ---- OUTPUTS -----
-  real*8 :: path_integral  
-  
-! ----- INTERNAL -----    
-  real*8 :: sumo, deltah, val
-  integer*4 :: nelm, j
-  integer*4, dimension(i2-i1+1) :: idx
-  real*8, dimension(i2-i1+1) :: f_rev, s_rev
-
-  nelm = i2-i1+1
-  if (nelm > 3) then
-    call mrgrnk(s(i1:i2),idx)
-    s_rev = s(idx)
-    f_rev = f(idx)
-    call avint(f_rev(i1:i2),s_rev(i1:i2),(i2-i1+1), &
-      s_rev(i1),s_rev(i2), val)
-    path_integral = val
-  else
-     sumo = 0.
-     do j=i1,i2
-       deltah = abs(s(i1+1)-s(i1))
-       sumo = sumo + f(j)*deltah
-    enddo
-    path_integral = sumo
-  endif 
-  ! print *, sumo
-
-  return
-  end function path_integral
-  
-! ----------------------------------------------------------------------------
-! subroutine AVINT
-! ----------------------------------------------------------------------------
-  subroutine avint ( ftab, xtab, ntab, a_in, b_in, result )
-  implicit none
-!
-! Purpose:
-!   estimate the integral of unevenly spaced data
-!
-! Inputs:
-!   [ftab]     functional values
-!   [xtab]     abscissa values
-!   [ntab]     number of elements of [ftab] and [xtab]
-!   [a]        lower limit of integration
-!   [b]        upper limit of integration
-!
-! Outputs:
-!   [result]   approximate value of integral
-!
-! Reference:
-!   From SLATEC libraries, in public domain
-!
-!***********************************************************************
-!
-!  AVINT estimates the integral of unevenly spaced data.
-!
-!  Discussion:
-!
-!    The method uses overlapping parabolas and smoothing.
-!
-!  Modified:
-!
-!    30 October 2000
-!    4 January 2008, A. Bodas-Salcedo. Error control for XTAB taken out of
-!                    loop to allow vectorization.
-!
-!  Reference:
-!
-!    Philip Davis and Philip Rabinowitz,
-!    Methods of Numerical Integration,
-!    Blaisdell Publishing, 1967.
-!
-!    P E Hennion,
-!    Algorithm 77,
-!    Interpolation, Differentiation and Integration,
-!    Communications of the Association for Computing Machinery,
-!    Volume 5, page 96, 1962.
-!
-!  Parameters:
-!
-!    Input, real ( kind = 8 ) FTAB(NTAB), the function values,
-!    FTAB(I) = F(XTAB(I)).
-!
-!    Input, real ( kind = 8 ) XTAB(NTAB), the abscissas at which the
-!    function values are given.  The XTAB's must be distinct
-!    and in ascending order.
-!
-!    Input, integer NTAB, the number of entries in FTAB and
-!    XTAB.  NTAB must be at least 3.
-!
-!    Input, real ( kind = 8 ) A, the lower limit of integration.  A should
-!    be, but need not be, near one endpoint of the interval
-!    (X(1), X(NTAB)).
-!
-!    Input, real ( kind = 8 ) B, the upper limit of integration.  B should
-!    be, but need not be, near one endpoint of the interval
-!    (X(1), X(NTAB)).
-!
-!    Output, real ( kind = 8 ) RESULT, the approximate value of the integral.
-
-  integer, intent(in) :: ntab
-
-  integer,parameter :: KR8 = selected_real_kind(15,300)
-  real ( kind = KR8 ), intent(in) :: a_in
-  real ( kind = KR8 ) a
-  real ( kind = KR8 ) atemp
-  real ( kind = KR8 ), intent(in) :: b_in
-  real ( kind = KR8 ) b
-  real ( kind = KR8 ) btemp
-  real ( kind = KR8 ) ca
-  real ( kind = KR8 ) cb
-  real ( kind = KR8 ) cc
-  real ( kind = KR8 ) ctemp
-  real ( kind = KR8 ), intent(in) :: ftab(ntab)
-  integer i
-  integer ihi
-  integer ilo
-  integer ind
-  real ( kind = KR8 ), intent(out) :: result
-  real ( kind = KR8 ) sum1
-  real ( kind = KR8 ) syl
-  real ( kind = KR8 ) term1
-  real ( kind = KR8 ) term2
-  real ( kind = KR8 ) term3
-  real ( kind = KR8 ) x1
-  real ( kind = KR8 ) x2
-  real ( kind = KR8 ) x3
-  real ( kind = KR8 ), intent(in) :: xtab(ntab)
-  logical lerror
-  
-  lerror = .false.
-  a = a_in
-  b = b_in  
-  
-  if ( ntab < 3 ) then
-    write ( *, '(a)' ) ' '
-    write ( *, '(a)' ) 'AVINT - Fatal error!'
-    write ( *, '(a,i6)' ) '  NTAB is less than 3.  NTAB = ', ntab
-    stop
-  end if
- 
-  do i = 2, ntab
-    if ( xtab(i) <= xtab(i-1) ) then
-       lerror = .true.
-       exit
-    end if
-  end do
-  
-  if (lerror) then
-      write ( *, '(a)' ) ' '
-      write ( *, '(a)' ) 'AVINT - Fatal error!'
-      write ( *, '(a)' ) '  XTAB(I) is not greater than XTAB(I-1).'
-      write ( *, '(a,i6)' ) '  Here, I = ', i
-      write ( *, '(a,g14.6)' ) '  XTAB(I-1) = ', xtab(i-1)
-      write ( *, '(a,g14.6)' ) '  XTAB(I) =   ', xtab(i)
-      stop  
-  end if
- 
-  result = 0.0D+00
- 
-  if ( a == b ) then
-    write ( *, '(a)' ) ' '
-    write ( *, '(a)' ) 'AVINT - Warning!'
-    write ( *, '(a)' ) '  A = B, integral=0.'
-    return
-  end if
-!
-!  If B < A, temporarily switch A and B, and store sign.
-!
-  if ( b < a ) then
-    syl = b
-    b = a
-    a = syl
-    ind = -1
-  else
-    syl = a
-    ind = 1
-  end if
-!
-!  Bracket A and B between XTAB(ILO) and XTAB(IHI).
-!
-  ilo = 1
-  ihi = ntab
-
-  do i = 1, ntab
-    if ( a <= xtab(i) ) then
-      exit
-    end if
-    ilo = ilo + 1
-  end do
-
-  ilo = max ( 2, ilo )
-  ilo = min ( ilo, ntab - 1 )
-
-  do i = 1, ntab
-    if ( xtab(i) <= b ) then
-      exit
-    end if
-    ihi = ihi - 1
-  end do
-  
-  ihi = min ( ihi, ntab - 1 )
-  ihi = max ( ilo, ihi - 1 )
-!
-!  Carry out approximate integration from XTAB(ILO) to XTAB(IHI).
-!
-  sum1 = 0.0D+00
- 
-  do i = ilo, ihi
- 
-    x1 = xtab(i-1)
-    x2 = xtab(i)
-    x3 = xtab(i+1)
-    
-    term1 = ftab(i-1) / ( ( x1 - x2 ) * ( x1 - x3 ) )
-    term2 = ftab(i)   / ( ( x2 - x1 ) * ( x2 - x3 ) )
-    term3 = ftab(i+1) / ( ( x3 - x1 ) * ( x3 - x2 ) )
- 
-    atemp = term1 + term2 + term3
-
-    btemp = - ( x2 + x3 ) * term1 &
-            - ( x1 + x3 ) * term2 &
-            - ( x1 + x2 ) * term3
-
-    ctemp = x2 * x3 * term1 + x1 * x3 * term2 + x1 * x2 * term3
- 
-    if ( i <= ilo ) then
-      ca = atemp
-      cb = btemp
-      cc = ctemp
-    else
-      ca = 0.5D+00 * ( atemp + ca )
-      cb = 0.5D+00 * ( btemp + cb )
-      cc = 0.5D+00 * ( ctemp + cc )
-    end if
- 
-    sum1 = sum1 &
-          + ca * ( x2**3 - syl**3 ) / 3.0D+00 &
-          + cb * 0.5D+00 * ( x2**2 - syl**2 ) &
-          + cc * ( x2 - syl )
- 
-    ca = atemp
-    cb = btemp
-    cc = ctemp
- 
-    syl = x2
- 
-  end do
- 
-  result = sum1 &
-        + ca * ( b**3 - syl**3 ) / 3.0D+00 &
-        + cb * 0.5D+00 * ( b**2 - syl**2 ) &
-        + cc * ( b - syl )
-!
-!  Restore original values of A and B, reverse sign of integral
-!  because of earlier switch.
-!
-  if ( ind /= 1 ) then
-    ind = 1
-    syl = b
-    b = a
-    a = syl
-    result = -result
-  end if
- 
-  return
-  end subroutine avint
-  
-  end module math_lib
Index: /LMDZ6/trunk/libf/phylmd/cosp/math_lib.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cosp/math_lib.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/cosp/math_lib.f90	(revision 5268)
@@ -0,0 +1,397 @@
+! $Revision: 23 $, $Date: 2011-03-31 15:41:37 +0200 (jeu. 31 mars 2011) $
+! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/quickbeam/math_lib.f90 $
+! MATH_LIB: Mathematics procedures for F90
+! Compiled/Modified:
+!   07/01/06  John Haynes (haynes@atmos.colostate.edu)
+! 
+! gamma (function)
+! path_integral (function)
+! avint (subroutine)
+  
+  module math_lib
+  implicit none
+
+  contains
+
+! ----------------------------------------------------------------------------
+! function GAMMA
+! ----------------------------------------------------------------------------
+  function gamma(x)
+  implicit none
+!
+! Purpose:
+!   Returns the gamma function
+!
+! Input:
+!   [x]   value to compute gamma function of
+!
+! Returns:
+!   gamma(x)
+!
+! Coded:
+!   02/02/06  John Haynes (haynes@atmos.colostate.edu)
+!   (original code of unknown origin)
+
+! ----- INPUTS -----
+  real*8, intent(in) :: x
+  
+! ----- OUTPUTS -----
+  real*8 :: gamma
+
+! ----- INTERNAL -----  
+  real*8 :: pi,ga,z,r,gr
+  real*8 :: g(26)
+  integer :: k,m1,m
+       
+  pi = acos(-1.)    
+  if (x ==int(x)) then
+    if (x > 0.0) then
+      ga=1.0
+      m1=x-1
+      do k=2,m1
+        ga=ga*k
+      enddo
+    else
+      ga=1.0+300
+    endif
+  else
+    if (abs(x) > 1.0) then
+      z=abs(x)
+      m=int(z)
+      r=1.0
+      do k=1,m
+        r=r*(z-k)
+      enddo
+      z=z-m
+    else
+      z=x
+    endif
+    data g/1.0,0.5772156649015329, &
+           -0.6558780715202538, -0.420026350340952d-1, &
+           0.1665386113822915,-.421977345555443d-1, &
+           -.96219715278770d-2, .72189432466630d-2, &
+           -.11651675918591d-2, -.2152416741149d-3, &
+           .1280502823882d-3, -.201348547807d-4, &
+           -.12504934821d-5, .11330272320d-5, &
+           -.2056338417d-6, .61160950d-8, &
+           .50020075d-8, -.11812746d-8, &
+           .1043427d-9, .77823d-11, &
+          -.36968d-11, .51d-12, &
+          -.206d-13, -.54d-14, .14d-14, .1d-15/
+    gr=g(26)
+    do k=25,1,-1
+      gr=gr*z+g(k)
+    enddo 
+    ga=1.0/(gr*z)
+    if (abs(x) > 1.0) then
+      ga=ga*r
+      if (x < 0.0) ga=-pi/(x*ga*sin(pi*x))
+    endif
+  endif
+  gamma = ga
+  return
+  end function gamma
+  
+! ----------------------------------------------------------------------------
+! function PATH_INTEGRAL 
+! ----------------------------------------------------------------------------
+  function path_integral(f,s,i1,i2)
+  use m_mrgrnk
+  use array_lib
+  implicit none
+!
+! Purpose:
+!   evalues the integral (f ds) between f(index=i1) and f(index=i2)
+!   using the AVINT procedure
+!
+! Inputs:
+!   [f]    functional values
+!   [s]    abscissa values
+!   [i1]   index of lower limit
+!   [i2]   index of upper limit
+!
+! Returns:
+!   result of path integral
+!
+! Notes:
+!   [s] may be in forward or reverse numerical order
+!
+! Requires:
+!   mrgrnk package
+!
+! Created:
+!   02/02/06  John Haynes (haynes@atmos.colostate.edu)
+
+! ----- INPUTS -----  
+  real*8, intent(in), dimension(:) :: f,s  
+  integer, intent(in) :: i1, i2
+
+! ---- OUTPUTS -----
+  real*8 :: path_integral  
+  
+! ----- INTERNAL -----    
+  real*8 :: sumo, deltah, val
+  integer*4 :: nelm, j
+  integer*4, dimension(i2-i1+1) :: idx
+  real*8, dimension(i2-i1+1) :: f_rev, s_rev
+
+  nelm = i2-i1+1
+  if (nelm > 3) then
+    call mrgrnk(s(i1:i2),idx)
+    s_rev = s(idx)
+    f_rev = f(idx)
+    call avint(f_rev(i1:i2),s_rev(i1:i2),(i2-i1+1), &
+      s_rev(i1),s_rev(i2), val)
+    path_integral = val
+  else
+     sumo = 0.
+     do j=i1,i2
+       deltah = abs(s(i1+1)-s(i1))
+       sumo = sumo + f(j)*deltah
+    enddo
+    path_integral = sumo
+  endif 
+  ! print *, sumo
+
+  return
+  end function path_integral
+  
+! ----------------------------------------------------------------------------
+! subroutine AVINT
+! ----------------------------------------------------------------------------
+  subroutine avint ( ftab, xtab, ntab, a_in, b_in, result )
+  implicit none
+!
+! Purpose:
+!   estimate the integral of unevenly spaced data
+!
+! Inputs:
+!   [ftab]     functional values
+!   [xtab]     abscissa values
+!   [ntab]     number of elements of [ftab] and [xtab]
+!   [a]        lower limit of integration
+!   [b]        upper limit of integration
+!
+! Outputs:
+!   [result]   approximate value of integral
+!
+! Reference:
+!   From SLATEC libraries, in public domain
+!
+!***********************************************************************
+!
+!  AVINT estimates the integral of unevenly spaced data.
+!
+!  Discussion:
+!
+!    The method uses overlapping parabolas and smoothing.
+!
+!  Modified:
+!
+!    30 October 2000
+!    4 January 2008, A. Bodas-Salcedo. Error control for XTAB taken out of
+!                    loop to allow vectorization.
+!
+!  Reference:
+!
+!    Philip Davis and Philip Rabinowitz,
+!    Methods of Numerical Integration,
+!    Blaisdell Publishing, 1967.
+!
+!    P E Hennion,
+!    Algorithm 77,
+!    Interpolation, Differentiation and Integration,
+!    Communications of the Association for Computing Machinery,
+!    Volume 5, page 96, 1962.
+!
+!  Parameters:
+!
+!    Input, real ( kind = 8 ) FTAB(NTAB), the function values,
+!    FTAB(I) = F(XTAB(I)).
+!
+!    Input, real ( kind = 8 ) XTAB(NTAB), the abscissas at which the
+!    function values are given.  The XTAB's must be distinct
+!    and in ascending order.
+!
+!    Input, integer NTAB, the number of entries in FTAB and
+!    XTAB.  NTAB must be at least 3.
+!
+!    Input, real ( kind = 8 ) A, the lower limit of integration.  A should
+!    be, but need not be, near one endpoint of the interval
+!    (X(1), X(NTAB)).
+!
+!    Input, real ( kind = 8 ) B, the upper limit of integration.  B should
+!    be, but need not be, near one endpoint of the interval
+!    (X(1), X(NTAB)).
+!
+!    Output, real ( kind = 8 ) RESULT, the approximate value of the integral.
+
+  integer, intent(in) :: ntab
+
+  integer,parameter :: KR8 = selected_real_kind(15,300)
+  real ( kind = KR8 ), intent(in) :: a_in
+  real ( kind = KR8 ) a
+  real ( kind = KR8 ) atemp
+  real ( kind = KR8 ), intent(in) :: b_in
+  real ( kind = KR8 ) b
+  real ( kind = KR8 ) btemp
+  real ( kind = KR8 ) ca
+  real ( kind = KR8 ) cb
+  real ( kind = KR8 ) cc
+  real ( kind = KR8 ) ctemp
+  real ( kind = KR8 ), intent(in) :: ftab(ntab)
+  integer i
+  integer ihi
+  integer ilo
+  integer ind
+  real ( kind = KR8 ), intent(out) :: result
+  real ( kind = KR8 ) sum1
+  real ( kind = KR8 ) syl
+  real ( kind = KR8 ) term1
+  real ( kind = KR8 ) term2
+  real ( kind = KR8 ) term3
+  real ( kind = KR8 ) x1
+  real ( kind = KR8 ) x2
+  real ( kind = KR8 ) x3
+  real ( kind = KR8 ), intent(in) :: xtab(ntab)
+  logical lerror
+  
+  lerror = .false.
+  a = a_in
+  b = b_in  
+  
+  if ( ntab < 3 ) then
+    write ( *, '(a)' ) ' '
+    write ( *, '(a)' ) 'AVINT - Fatal error!'
+    write ( *, '(a,i6)' ) '  NTAB is less than 3.  NTAB = ', ntab
+    stop
+  end if
+ 
+  do i = 2, ntab
+    if ( xtab(i) <= xtab(i-1) ) then
+       lerror = .true.
+       exit
+    end if
+  end do
+  
+  if (lerror) then
+      write ( *, '(a)' ) ' '
+      write ( *, '(a)' ) 'AVINT - Fatal error!'
+      write ( *, '(a)' ) '  XTAB(I) is not greater than XTAB(I-1).'
+      write ( *, '(a,i6)' ) '  Here, I = ', i
+      write ( *, '(a,g14.6)' ) '  XTAB(I-1) = ', xtab(i-1)
+      write ( *, '(a,g14.6)' ) '  XTAB(I) =   ', xtab(i)
+      stop  
+  end if
+ 
+  result = 0.0D+00
+ 
+  if ( a == b ) then
+    write ( *, '(a)' ) ' '
+    write ( *, '(a)' ) 'AVINT - Warning!'
+    write ( *, '(a)' ) '  A = B, integral=0.'
+    return
+  end if
+!
+!  If B < A, temporarily switch A and B, and store sign.
+!
+  if ( b < a ) then
+    syl = b
+    b = a
+    a = syl
+    ind = -1
+  else
+    syl = a
+    ind = 1
+  end if
+!
+!  Bracket A and B between XTAB(ILO) and XTAB(IHI).
+!
+  ilo = 1
+  ihi = ntab
+
+  do i = 1, ntab
+    if ( a <= xtab(i) ) then
+      exit
+    end if
+    ilo = ilo + 1
+  end do
+
+  ilo = max ( 2, ilo )
+  ilo = min ( ilo, ntab - 1 )
+
+  do i = 1, ntab
+    if ( xtab(i) <= b ) then
+      exit
+    end if
+    ihi = ihi - 1
+  end do
+  
+  ihi = min ( ihi, ntab - 1 )
+  ihi = max ( ilo, ihi - 1 )
+!
+!  Carry out approximate integration from XTAB(ILO) to XTAB(IHI).
+!
+  sum1 = 0.0D+00
+ 
+  do i = ilo, ihi
+ 
+    x1 = xtab(i-1)
+    x2 = xtab(i)
+    x3 = xtab(i+1)
+    
+    term1 = ftab(i-1) / ( ( x1 - x2 ) * ( x1 - x3 ) )
+    term2 = ftab(i)   / ( ( x2 - x1 ) * ( x2 - x3 ) )
+    term3 = ftab(i+1) / ( ( x3 - x1 ) * ( x3 - x2 ) )
+ 
+    atemp = term1 + term2 + term3
+
+    btemp = - ( x2 + x3 ) * term1 &
+            - ( x1 + x3 ) * term2 &
+            - ( x1 + x2 ) * term3
+
+    ctemp = x2 * x3 * term1 + x1 * x3 * term2 + x1 * x2 * term3
+ 
+    if ( i <= ilo ) then
+      ca = atemp
+      cb = btemp
+      cc = ctemp
+    else
+      ca = 0.5D+00 * ( atemp + ca )
+      cb = 0.5D+00 * ( btemp + cb )
+      cc = 0.5D+00 * ( ctemp + cc )
+    end if
+ 
+    sum1 = sum1 &
+          + ca * ( x2**3 - syl**3 ) / 3.0D+00 &
+          + cb * 0.5D+00 * ( x2**2 - syl**2 ) &
+          + cc * ( x2 - syl )
+ 
+    ca = atemp
+    cb = btemp
+    cc = ctemp
+ 
+    syl = x2
+ 
+  end do
+ 
+  result = sum1 &
+        + ca * ( b**3 - syl**3 ) / 3.0D+00 &
+        + cb * 0.5D+00 * ( b**2 - syl**2 ) &
+        + cc * ( b - syl )
+!
+!  Restore original values of A and B, reverse sign of integral
+!  because of earlier switch.
+!
+  if ( ind /= 1 ) then
+    ind = 1
+    syl = b
+    b = a
+    a = syl
+    result = -result
+  end if
+ 
+  return
+  end subroutine avint
+  
+  end module math_lib
Index: DZ6/trunk/libf/phylmd/cosp/mod_cosp_isccp_simulator.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cosp/mod_cosp_isccp_simulator.F90	(revision 5267)
+++ 	(revision )
@@ -1,96 +1,0 @@
-! (c) British Crown Copyright 2008, the Met Office.
-! All rights reserved.
-! $Revision: 23 $, $Date: 2011-03-31 15:41:37 +0200 (jeu. 31 mars 2011) $
-! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/cosp_isccp_simulator.F90 $
-! 
-! Redistribution and use in source and binary forms, with or without modification, are permitted 
-! provided that the following conditions are met:
-! 
-!     * Redistributions of source code must retain the above copyright notice, this list 
-!       of conditions and the following disclaimer.
-!     * Redistributions in binary form must reproduce the above copyright notice, this list
-!       of conditions and the following disclaimer in the documentation and/or other materials 
-!       provided with the distribution.
-!     * Neither the name of the Met Office nor the names of its contributors may be used 
-!       to endorse or promote products derived from this software without specific prior written 
-!       permission.
-! 
-! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR 
-! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND 
-! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR 
-! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 
-! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 
-! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER 
-! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT 
-! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-
-MODULE MOD_COSP_ISCCP_SIMULATOR
-  USE MOD_COSP_CONSTANTS
-  USE MOD_COSP_TYPES
-  IMPLICIT NONE
-
-CONTAINS
-
-
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-!-------------- SUBROUTINE COSP_ISCCP_SIMULATOR -----------------
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-SUBROUTINE COSP_ISCCP_SIMULATOR(gbx,sgx,y)
-  
-  ! Arguments
-  type(cosp_gridbox),intent(in) :: gbx  ! Gridbox info
-  type(cosp_subgrid),intent(in) :: sgx  ! Subgridbox info
-  type(cosp_isccp),intent(inout) :: y   ! ISCCP simulator output
-  
-  ! Local variables 
-  integer :: Nlevels,Npoints
-  real :: pfull(gbx%Npoints, gbx%Nlevels)
-  real :: phalf(gbx%Npoints, gbx%Nlevels + 1)
-  real :: qv(gbx%Npoints, gbx%Nlevels)
-  real :: cc(gbx%Npoints, gbx%Nlevels)
-  real :: conv(gbx%Npoints, gbx%Nlevels)
-  real :: dtau_s(gbx%Npoints, gbx%Nlevels)
-  real :: dtau_c(gbx%Npoints, gbx%Nlevels)
-  real :: at(gbx%Npoints, gbx%Nlevels)
-  real :: dem_s(gbx%Npoints, gbx%Nlevels)
-  real :: dem_c(gbx%Npoints, gbx%Nlevels)
-  real :: frac_out(gbx%Npoints, gbx%Ncolumns, gbx%Nlevels)
-  integer :: sunlit(gbx%Npoints)
-  
-  Nlevels = gbx%Nlevels
-  Npoints = gbx%Npoints
-  ! Flip inputs. Levels from TOA to surface
-  pfull  = gbx%p(:,Nlevels:1:-1) 
-  phalf(:,1)         = 0.0 ! Top level
-  phalf(:,2:Nlevels+1) = gbx%ph(:,Nlevels:1:-1)
-  qv     = gbx%sh(:,Nlevels:1:-1) 
-  cc     = 0.999999*gbx%tca(:,Nlevels:1:-1) 
-  conv   = 0.999999*gbx%cca(:,Nlevels:1:-1) 
-  dtau_s = gbx%dtau_s(:,Nlevels:1:-1) 
-  dtau_c = gbx%dtau_c(:,Nlevels:1:-1) 
-  at     = gbx%T(:,Nlevels:1:-1) 
-  dem_s  = gbx%dem_s(:,Nlevels:1:-1) 
-  dem_c  = gbx%dem_c(:,Nlevels:1:-1) 
-  frac_out(1:Npoints,:,1:Nlevels) = sgx%frac_out(1:Npoints,:,Nlevels:1:-1)
-  sunlit = int(gbx%sunlit)
-  call icarus(0,0,gbx%npoints,sunlit,gbx%nlevels,gbx%ncolumns, &
-            pfull,phalf,qv,cc,conv,dtau_s,dtau_c, &
-            gbx%isccp_top_height,gbx%isccp_top_height_direction, &
-            gbx%isccp_overlap,frac_out, &
-            gbx%skt,gbx%isccp_emsfc_lw,at,dem_s,dem_c,y%fq_isccp,y%totalcldarea, &
-            y%meanptop,y%meantaucld,y%meanalbedocld, &
-            y%meantb,y%meantbclr,y%boxtau,y%boxptop)
-
-  ! Flip outputs. Levels from surface to TOA
-  ! --- (npoints,tau=7,pressure=7)
-  y%fq_isccp(:,:,:) = y%fq_isccp(:,:,7:1:-1)
-     
- 
-  ! Check if there is any value slightly greater than 1
-  where ((y%totalcldarea > 1.0-1.e-5) .and. (y%totalcldarea < 1.0+1.e-5))
-    y%totalcldarea = 1.0
-  endwhere
-              
-END SUBROUTINE COSP_ISCCP_SIMULATOR
-
-END MODULE MOD_COSP_ISCCP_SIMULATOR
Index: /LMDZ6/trunk/libf/phylmd/cosp/mod_cosp_isccp_simulator.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cosp/mod_cosp_isccp_simulator.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/cosp/mod_cosp_isccp_simulator.f90	(revision 5268)
@@ -0,0 +1,96 @@
+! (c) British Crown Copyright 2008, the Met Office.
+! All rights reserved.
+! $Revision: 23 $, $Date: 2011-03-31 15:41:37 +0200 (jeu. 31 mars 2011) $
+! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/cosp_isccp_simulator.F90 $
+! 
+! Redistribution and use in source and binary forms, with or without modification, are permitted 
+! provided that the following conditions are met:
+! 
+!     * Redistributions of source code must retain the above copyright notice, this list 
+!       of conditions and the following disclaimer.
+!     * Redistributions in binary form must reproduce the above copyright notice, this list
+!       of conditions and the following disclaimer in the documentation and/or other materials 
+!       provided with the distribution.
+!     * Neither the name of the Met Office nor the names of its contributors may be used 
+!       to endorse or promote products derived from this software without specific prior written 
+!       permission.
+! 
+! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR 
+! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND 
+! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR 
+! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 
+! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 
+! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER 
+! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT 
+! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+MODULE MOD_COSP_ISCCP_SIMULATOR
+  USE MOD_COSP_CONSTANTS
+  USE MOD_COSP_TYPES
+  IMPLICIT NONE
+
+CONTAINS
+
+
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+!-------------- SUBROUTINE COSP_ISCCP_SIMULATOR -----------------
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+SUBROUTINE COSP_ISCCP_SIMULATOR(gbx,sgx,y)
+  
+  ! Arguments
+  type(cosp_gridbox),intent(in) :: gbx  ! Gridbox info
+  type(cosp_subgrid),intent(in) :: sgx  ! Subgridbox info
+  type(cosp_isccp),intent(inout) :: y   ! ISCCP simulator output
+  
+  ! Local variables 
+  integer :: Nlevels,Npoints
+  real :: pfull(gbx%Npoints, gbx%Nlevels)
+  real :: phalf(gbx%Npoints, gbx%Nlevels + 1)
+  real :: qv(gbx%Npoints, gbx%Nlevels)
+  real :: cc(gbx%Npoints, gbx%Nlevels)
+  real :: conv(gbx%Npoints, gbx%Nlevels)
+  real :: dtau_s(gbx%Npoints, gbx%Nlevels)
+  real :: dtau_c(gbx%Npoints, gbx%Nlevels)
+  real :: at(gbx%Npoints, gbx%Nlevels)
+  real :: dem_s(gbx%Npoints, gbx%Nlevels)
+  real :: dem_c(gbx%Npoints, gbx%Nlevels)
+  real :: frac_out(gbx%Npoints, gbx%Ncolumns, gbx%Nlevels)
+  integer :: sunlit(gbx%Npoints)
+  
+  Nlevels = gbx%Nlevels
+  Npoints = gbx%Npoints
+  ! Flip inputs. Levels from TOA to surface
+  pfull  = gbx%p(:,Nlevels:1:-1) 
+  phalf(:,1)         = 0.0 ! Top level
+  phalf(:,2:Nlevels+1) = gbx%ph(:,Nlevels:1:-1)
+  qv     = gbx%sh(:,Nlevels:1:-1) 
+  cc     = 0.999999*gbx%tca(:,Nlevels:1:-1) 
+  conv   = 0.999999*gbx%cca(:,Nlevels:1:-1) 
+  dtau_s = gbx%dtau_s(:,Nlevels:1:-1) 
+  dtau_c = gbx%dtau_c(:,Nlevels:1:-1) 
+  at     = gbx%T(:,Nlevels:1:-1) 
+  dem_s  = gbx%dem_s(:,Nlevels:1:-1) 
+  dem_c  = gbx%dem_c(:,Nlevels:1:-1) 
+  frac_out(1:Npoints,:,1:Nlevels) = sgx%frac_out(1:Npoints,:,Nlevels:1:-1)
+  sunlit = int(gbx%sunlit)
+  call icarus(0,0,gbx%npoints,sunlit,gbx%nlevels,gbx%ncolumns, &
+            pfull,phalf,qv,cc,conv,dtau_s,dtau_c, &
+            gbx%isccp_top_height,gbx%isccp_top_height_direction, &
+            gbx%isccp_overlap,frac_out, &
+            gbx%skt,gbx%isccp_emsfc_lw,at,dem_s,dem_c,y%fq_isccp,y%totalcldarea, &
+            y%meanptop,y%meantaucld,y%meanalbedocld, &
+            y%meantb,y%meantbclr,y%boxtau,y%boxptop)
+
+  ! Flip outputs. Levels from surface to TOA
+  ! --- (npoints,tau=7,pressure=7)
+  y%fq_isccp(:,:,:) = y%fq_isccp(:,:,7:1:-1)
+     
+ 
+  ! Check if there is any value slightly greater than 1
+  where ((y%totalcldarea > 1.0-1.e-5) .and. (y%totalcldarea < 1.0+1.e-5))
+    y%totalcldarea = 1.0
+  endwhere
+              
+END SUBROUTINE COSP_ISCCP_SIMULATOR
+
+END MODULE MOD_COSP_ISCCP_SIMULATOR
Index: DZ6/trunk/libf/phylmd/cosp/mod_cosp_lidar.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cosp/mod_cosp_lidar.F90	(revision 5267)
+++ 	(revision )
@@ -1,87 +1,0 @@
-! (c) British Crown Copyright 2008, the Met Office.
-! All rights reserved.
-! $Revision: 88 $, $Date: 2013-11-13 15:08:38 +0100 (mer. 13 nov. 2013) $
-! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/cosp_lidar.F90 $
-! 
-! Redistribution and use in source and binary forms, with or without modification, are permitted 
-! provided that the following conditions are met:
-! 
-!     * Redistributions of source code must retain the above copyright notice, this list 
-!       of conditions and the following disclaimer.
-!     * Redistributions in binary form must reproduce the above copyright notice, this list
-!       of conditions and the following disclaimer in the documentation and/or other materials 
-!       provided with the distribution.
-!     * Neither the name of the Met Office nor the names of its contributors may be used 
-!       to endorse or promote products derived from this software without specific prior written 
-!       permission.
-! 
-! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR 
-! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND 
-! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR 
-! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 
-! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 
-! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER 
-! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT 
-! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-
-!
-! History:
-! Jul 2007 - A. Bodas-Salcedo - Initial version
-! Oct 2008 - S. Bony          - Instructions "Call for large-scale cloud" removed  -> sgx%frac_out is used instead.
-!                               Call lidar_simulator changed (lsca, gbx%cca and depol removed; 
-!                               frac_out changed in sgx%frac_out)
-! Jun 2011 - G. Cesana        - Added betaperp_tot argument
-!
-! 
-MODULE MOD_COSP_LIDAR
-  USE MOD_COSP_CONSTANTS
-  USE MOD_COSP_TYPES
-  IMPLICIT NONE
-
-CONTAINS
-
-
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-!------------------- SUBROUTINE COSP_LIDAR ------------------------
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-SUBROUTINE COSP_LIDAR(gbx,sgx,sghydro,y)
-
-  ! Arguments
-  type(cosp_gridbox),intent(in) :: gbx  ! Gridbox info
-  type(cosp_subgrid),intent(in) :: sgx  ! Subgrid info
-  type(cosp_sghydro),intent(in) :: sghydro  ! Subgrid info for hydrometeors
-  type(cosp_sglidar),intent(inout) :: y ! Subgrid output
-
-  ! Local variables 
-  integer :: i
-  real :: presf(sgx%Npoints, sgx%Nlevels + 1)
-  real,dimension(sgx%Npoints, sgx%Nlevels) :: lsca,mr_ll,mr_li,mr_cl,mr_ci
-  real,dimension(sgx%Npoints, sgx%Nlevels) :: beta_tot,tau_tot
-  real,dimension(sgx%Npoints, sgx%Nlevels) :: betaperp_tot
-  real,dimension(sgx%Npoints, PARASOL_NREFL)  :: refle
-
-  presf(:,1:sgx%Nlevels) = gbx%ph
-  presf(:,sgx%Nlevels + 1) = 0.0
-  lsca = gbx%tca-gbx%cca
-  do i=1,sgx%Ncolumns
-      ! Temporary arrays for simulator call
-      mr_ll(:,:) = sghydro%mr_hydro(:,i,:,I_LSCLIQ)
-      mr_li(:,:) = sghydro%mr_hydro(:,i,:,I_LSCICE)
-      mr_cl(:,:) = sghydro%mr_hydro(:,i,:,I_CVCLIQ)
-      mr_ci(:,:) = sghydro%mr_hydro(:,i,:,I_CVCICE)
-      call lidar_simulator(sgx%Npoints, sgx%Nlevels, 4, PARASOL_NREFL, LIDAR_UNDEF  &
-                 , gbx%p, presf, gbx%T, mr_ll, mr_li, mr_cl, mr_ci &
-                 , gbx%Reff(:,:,I_LSCLIQ), gbx%Reff(:,:,I_LSCICE) &
-                 , gbx%Reff(:,:,I_CVCLIQ), gbx%Reff(:,:,I_CVCICE) &
-                 , gbx%lidar_ice_type, y%beta_mol, beta_tot &
-                 , betaperp_tot, tau_tot, refle )
-
-      y%betaperp_tot(:,i,:) = betaperp_tot(:,:)
-      y%beta_tot(:,i,:) = beta_tot(:,:)
-      y%tau_tot(:,i,:)  = tau_tot(:,:)
-      y%refl(:,i,:)     = refle(:,:)
-  enddo
-
-END SUBROUTINE COSP_LIDAR
-
-END MODULE MOD_COSP_LIDAR
Index: /LMDZ6/trunk/libf/phylmd/cosp/mod_cosp_lidar.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cosp/mod_cosp_lidar.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/cosp/mod_cosp_lidar.f90	(revision 5268)
@@ -0,0 +1,87 @@
+! (c) British Crown Copyright 2008, the Met Office.
+! All rights reserved.
+! $Revision: 88 $, $Date: 2013-11-13 15:08:38 +0100 (mer. 13 nov. 2013) $
+! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/cosp_lidar.F90 $
+! 
+! Redistribution and use in source and binary forms, with or without modification, are permitted 
+! provided that the following conditions are met:
+! 
+!     * Redistributions of source code must retain the above copyright notice, this list 
+!       of conditions and the following disclaimer.
+!     * Redistributions in binary form must reproduce the above copyright notice, this list
+!       of conditions and the following disclaimer in the documentation and/or other materials 
+!       provided with the distribution.
+!     * Neither the name of the Met Office nor the names of its contributors may be used 
+!       to endorse or promote products derived from this software without specific prior written 
+!       permission.
+! 
+! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR 
+! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND 
+! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR 
+! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 
+! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 
+! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER 
+! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT 
+! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+!
+! History:
+! Jul 2007 - A. Bodas-Salcedo - Initial version
+! Oct 2008 - S. Bony          - Instructions "Call for large-scale cloud" removed  -> sgx%frac_out is used instead.
+!                               Call lidar_simulator changed (lsca, gbx%cca and depol removed; 
+!                               frac_out changed in sgx%frac_out)
+! Jun 2011 - G. Cesana        - Added betaperp_tot argument
+!
+! 
+MODULE MOD_COSP_LIDAR
+  USE MOD_COSP_CONSTANTS
+  USE MOD_COSP_TYPES
+  IMPLICIT NONE
+
+CONTAINS
+
+
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+!------------------- SUBROUTINE COSP_LIDAR ------------------------
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+SUBROUTINE COSP_LIDAR(gbx,sgx,sghydro,y)
+
+  ! Arguments
+  type(cosp_gridbox),intent(in) :: gbx  ! Gridbox info
+  type(cosp_subgrid),intent(in) :: sgx  ! Subgrid info
+  type(cosp_sghydro),intent(in) :: sghydro  ! Subgrid info for hydrometeors
+  type(cosp_sglidar),intent(inout) :: y ! Subgrid output
+
+  ! Local variables 
+  integer :: i
+  real :: presf(sgx%Npoints, sgx%Nlevels + 1)
+  real,dimension(sgx%Npoints, sgx%Nlevels) :: lsca,mr_ll,mr_li,mr_cl,mr_ci
+  real,dimension(sgx%Npoints, sgx%Nlevels) :: beta_tot,tau_tot
+  real,dimension(sgx%Npoints, sgx%Nlevels) :: betaperp_tot
+  real,dimension(sgx%Npoints, PARASOL_NREFL)  :: refle
+
+  presf(:,1:sgx%Nlevels) = gbx%ph
+  presf(:,sgx%Nlevels + 1) = 0.0
+  lsca = gbx%tca-gbx%cca
+  do i=1,sgx%Ncolumns
+      ! Temporary arrays for simulator call
+      mr_ll(:,:) = sghydro%mr_hydro(:,i,:,I_LSCLIQ)
+      mr_li(:,:) = sghydro%mr_hydro(:,i,:,I_LSCICE)
+      mr_cl(:,:) = sghydro%mr_hydro(:,i,:,I_CVCLIQ)
+      mr_ci(:,:) = sghydro%mr_hydro(:,i,:,I_CVCICE)
+      call lidar_simulator(sgx%Npoints, sgx%Nlevels, 4, PARASOL_NREFL, LIDAR_UNDEF  &
+                 , gbx%p, presf, gbx%T, mr_ll, mr_li, mr_cl, mr_ci &
+                 , gbx%Reff(:,:,I_LSCLIQ), gbx%Reff(:,:,I_LSCICE) &
+                 , gbx%Reff(:,:,I_CVCLIQ), gbx%Reff(:,:,I_CVCICE) &
+                 , gbx%lidar_ice_type, y%beta_mol, beta_tot &
+                 , betaperp_tot, tau_tot, refle )
+
+      y%betaperp_tot(:,i,:) = betaperp_tot(:,:)
+      y%beta_tot(:,i,:) = beta_tot(:,:)
+      y%tau_tot(:,i,:)  = tau_tot(:,:)
+      y%refl(:,i,:)     = refle(:,:)
+  enddo
+
+END SUBROUTINE COSP_LIDAR
+
+END MODULE MOD_COSP_LIDAR
Index: DZ6/trunk/libf/phylmd/cosp/mod_cosp_misr_simulator.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cosp/mod_cosp_misr_simulator.F90	(revision 5267)
+++ 	(revision )
@@ -1,80 +1,0 @@
-! (c) British Crown Copyright 2008, the Met Office.
-! All rights reserved.
-! $Revision: 23 $, $Date: 2011-03-31 15:41:37 +0200 (jeu. 31 mars 2011) $
-! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/cosp_misr_simulator.F90 $
-! 
-! Redistribution and use in source and binary forms, with or without modification, are permitted 
-! provided that the following conditions are met:
-! 
-!     * Redistributions of source code must retain the above copyright notice, this list 
-!       of conditions and the following disclaimer.
-!     * Redistributions in binary form must reproduce the above copyright notice, this list
-!       of conditions and the following disclaimer in the documentation and/or other materials 
-!       provided with the distribution.
-!     * Neither the name of the Met Office nor the names of its contributors may be used 
-!       to endorse or promote products derived from this software without specific prior written 
-!       permission.
-! 
-! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR 
-! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND 
-! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR 
-! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 
-! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 
-! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER 
-! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT 
-! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-
-!
-! History:
-! Nov 2008 - A. Bodas-Salcedo - Initial version
-!
-!
-
-MODULE MOD_COSP_MISR_SIMULATOR
-  USE MOD_COSP_CONSTANTS
-  USE MOD_COSP_TYPES
-  IMPLICIT NONE
-
-CONTAINS
-
-
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-!-------------- SUBROUTINE COSP_MISR_SIMULATOR -----------------
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-SUBROUTINE COSP_MISR_SIMULATOR(gbx,sgx,y)
-  
-  ! Arguments
-  type(cosp_gridbox),intent(in) :: gbx  ! Gridbox info
-  type(cosp_subgrid),intent(in) :: sgx  ! Subgridbox info
-  type(cosp_misr),intent(inout) :: y    ! MISR simulator output
-  
-  ! Local variables 
-  integer :: Nlevels,Npoints
-  real :: dtau_s(gbx%Npoints, gbx%Nlevels)
-  real :: dtau_c(gbx%Npoints, gbx%Nlevels)
-  real :: at(gbx%Npoints, gbx%Nlevels)
-  real :: frac_out(gbx%Npoints, gbx%Ncolumns, gbx%Nlevels)
-  integer :: sunlit(gbx%Npoints)
-  
-  real :: zfull(gbx%Npoints, gbx%Nlevels) !  height (in meters) of full model levels (i.e. midpoints)
-                                          !  zfull(npoints,1)    is    top level of model
-                                          !  zfull(npoints,nlev) is bottom level of model
-     
-    
-  Nlevels = gbx%Nlevels
-  Npoints = gbx%Npoints
-  ! Levels from TOA to surface
-  zfull  = gbx%zlev(:,Nlevels:1:-1)
-  at     = gbx%T(:,Nlevels:1:-1) 
-  dtau_s = gbx%dtau_s(:,Nlevels:1:-1) 
-  dtau_c = gbx%dtau_c(:,Nlevels:1:-1) 
-  frac_out(1:Npoints,:,1:Nlevels) = sgx%frac_out(1:Npoints,:,Nlevels:1:-1)
-  sunlit = int(gbx%sunlit)
- 
-  call MISR_simulator(gbx%npoints,gbx%nlevels,gbx%ncolumns,&
-                     sunlit,zfull,at,dtau_s,dtau_c,frac_out, R_UNDEF, &
-                     y%fq_MISR,y%MISR_dist_model_layertops,y%MISR_meanztop,y%MISR_cldarea)
-            
-END SUBROUTINE COSP_MISR_SIMULATOR
-
-END MODULE MOD_COSP_MISR_SIMULATOR
Index: /LMDZ6/trunk/libf/phylmd/cosp/mod_cosp_misr_simulator.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cosp/mod_cosp_misr_simulator.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/cosp/mod_cosp_misr_simulator.f90	(revision 5268)
@@ -0,0 +1,80 @@
+! (c) British Crown Copyright 2008, the Met Office.
+! All rights reserved.
+! $Revision: 23 $, $Date: 2011-03-31 15:41:37 +0200 (jeu. 31 mars 2011) $
+! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/cosp_misr_simulator.F90 $
+! 
+! Redistribution and use in source and binary forms, with or without modification, are permitted 
+! provided that the following conditions are met:
+! 
+!     * Redistributions of source code must retain the above copyright notice, this list 
+!       of conditions and the following disclaimer.
+!     * Redistributions in binary form must reproduce the above copyright notice, this list
+!       of conditions and the following disclaimer in the documentation and/or other materials 
+!       provided with the distribution.
+!     * Neither the name of the Met Office nor the names of its contributors may be used 
+!       to endorse or promote products derived from this software without specific prior written 
+!       permission.
+! 
+! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR 
+! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND 
+! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR 
+! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 
+! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 
+! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER 
+! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT 
+! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+!
+! History:
+! Nov 2008 - A. Bodas-Salcedo - Initial version
+!
+!
+
+MODULE MOD_COSP_MISR_SIMULATOR
+  USE MOD_COSP_CONSTANTS
+  USE MOD_COSP_TYPES
+  IMPLICIT NONE
+
+CONTAINS
+
+
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+!-------------- SUBROUTINE COSP_MISR_SIMULATOR -----------------
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+SUBROUTINE COSP_MISR_SIMULATOR(gbx,sgx,y)
+  
+  ! Arguments
+  type(cosp_gridbox),intent(in) :: gbx  ! Gridbox info
+  type(cosp_subgrid),intent(in) :: sgx  ! Subgridbox info
+  type(cosp_misr),intent(inout) :: y    ! MISR simulator output
+  
+  ! Local variables 
+  integer :: Nlevels,Npoints
+  real :: dtau_s(gbx%Npoints, gbx%Nlevels)
+  real :: dtau_c(gbx%Npoints, gbx%Nlevels)
+  real :: at(gbx%Npoints, gbx%Nlevels)
+  real :: frac_out(gbx%Npoints, gbx%Ncolumns, gbx%Nlevels)
+  integer :: sunlit(gbx%Npoints)
+  
+  real :: zfull(gbx%Npoints, gbx%Nlevels) !  height (in meters) of full model levels (i.e. midpoints)
+                                          !  zfull(npoints,1)    is    top level of model
+                                          !  zfull(npoints,nlev) is bottom level of model
+     
+    
+  Nlevels = gbx%Nlevels
+  Npoints = gbx%Npoints
+  ! Levels from TOA to surface
+  zfull  = gbx%zlev(:,Nlevels:1:-1)
+  at     = gbx%T(:,Nlevels:1:-1) 
+  dtau_s = gbx%dtau_s(:,Nlevels:1:-1) 
+  dtau_c = gbx%dtau_c(:,Nlevels:1:-1) 
+  frac_out(1:Npoints,:,1:Nlevels) = sgx%frac_out(1:Npoints,:,Nlevels:1:-1)
+  sunlit = int(gbx%sunlit)
+ 
+  call MISR_simulator(gbx%npoints,gbx%nlevels,gbx%ncolumns,&
+                     sunlit,zfull,at,dtau_s,dtau_c,frac_out, R_UNDEF, &
+                     y%fq_MISR,y%MISR_dist_model_layertops,y%MISR_meanztop,y%MISR_cldarea)
+            
+END SUBROUTINE COSP_MISR_SIMULATOR
+
+END MODULE MOD_COSP_MISR_SIMULATOR
Index: DZ6/trunk/libf/phylmd/cosp/mod_cosp_modis_simulator.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cosp/mod_cosp_modis_simulator.F90	(revision 5267)
+++ 	(revision )
@@ -1,487 +1,0 @@
-! (c) 2009, Regents of the Unversity of Colorado
-!   Author: Robert Pincus, Cooperative Institute for Research in the Environmental Sciences
-! All rights reserved.
-! $Revision: 88 $, $Date: 2013-11-13 07:08:38 -0700 (Wed, 13 Nov 2013) $
-! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/cosp_modis_simulator.F90 $
-! 
-! Redistribution and use in source and binary forms, with or without modification, are permitted 
-! provided that the following conditions are met:
-! 
-!     * Redistributions of source code must retain the above copyright notice, this list 
-!       of conditions and the following disclaimer.
-!     * Redistributions in binary form must reproduce the above copyright notice, this list
-!       of conditions and the following disclaimer in the documentation and/or other materials 
-!       provided with the distribution.
-!     * Neither the name of the Met Office nor the names of its contributors may be used 
-!       to endorse or promote products derived from this software without specific prior written 
-!       permission.
-! 
-! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR 
-! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND 
-! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR 
-! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 
-! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 
-! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER 
-! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT 
-! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-!
-
-!
-! History:
-!   May 2009 - Robert Pincus - Initial version
-!   Dec 2009 - Robert Pincus - Tiny revisions
-!
-MODULE MOD_COSP_Modis_Simulator
-  USE MOD_COSP_CONSTANTS
-  USE MOD_COSP_TYPES
-  use mod_modis_sim, numModisTauBins      => numTauHistogramBins,      &
-                     numModisPressureBins => numPressureHistogramBins, &
-                     MODIS_TAU      => nominalTauHistogramCenters,     &
-                     MODIS_TAU_BNDS => nominalTauHistogramBoundaries,  &
-                     MODIS_PC       => nominalPressureHistogramCenters, &
-                     MODIS_PC_BNDS  => nominalPressureHistogramBoundaries                     
-  implicit none
-  !------------------------------------------------------------------------------------------------
-  ! Public type
-  !
-  ! Summary statistics from MODIS retrievals
-  type COSP_MODIS
-     ! Dimensions
-     integer :: Npoints   ! Number of gridpoints
-     
-     !
-     ! Grid means; dimension nPoints
-     ! 
-     real, dimension(:),       pointer :: & 
-       Cloud_Fraction_Total_Mean,       Cloud_Fraction_Water_Mean,       Cloud_Fraction_Ice_Mean,       &
-       Cloud_Fraction_High_Mean,        Cloud_Fraction_Mid_Mean,         Cloud_Fraction_Low_Mean,       &
-       Optical_Thickness_Total_Mean,    Optical_Thickness_Water_Mean,    Optical_Thickness_Ice_Mean,    &
-       Optical_Thickness_Total_LogMean, Optical_Thickness_Water_LogMean, Optical_Thickness_Ice_LogMean, &
-                                        Cloud_Particle_Size_Water_Mean,  Cloud_Particle_Size_Ice_Mean,  &
-       Cloud_Top_Pressure_Total_Mean,                                                                   &
-                                        Liquid_Water_Path_Mean,          Ice_Water_Path_Mean
-     !
-     ! Also need the ISCCP-type optical thickness/cloud top pressure histogram
-     !
-     real, dimension(:, :, :), pointer :: Optical_Thickness_vs_Cloud_Top_Pressure
-     real, dimension(:, :, :), pointer :: Optical_Thickness_vs_ReffICE
-     real, dimension(:, :, :), pointer :: Optical_Thickness_vs_ReffLIQ
-  end type COSP_MODIS 
-  
-contains
-  !------------------------------------------------------------------------------------------------
-  subroutine COSP_Modis_Simulator(gridBox, subCols, subcolHydro, isccpSim, modisSim)
-    ! Arguments
-    type(cosp_gridbox), intent(in   ) :: gridBox     ! Gridbox info
-    type(cosp_subgrid), intent(in   ) :: subCols     ! subCol indicators of convective/stratiform 
-    type(cosp_sghydro), intent(in   ) :: subcolHydro ! subcol hydrometeor contens
-    type(cosp_isccp),   intent(in   ) :: isccpSim    ! ISCCP simulator output
-    type(cosp_modis),   intent(  out) :: modisSim    ! MODIS simulator subcol output
-    
-    ! ------------------------------------------------------------
-    ! Local variables 
-    !   Leave space only for sunlit points
-    
-    integer :: nPoints, nSubCols, nLevels, nSunlit, i, j, k
-    
-    ! Grid-mean quanties;  dimensions nPoints, nLevels
-    real, &
-      dimension(count(gridBox%sunlit(:) > 0),                  gridBox%nLevels) :: &
-        temperature, pressureLayers
-    real, &
-      dimension(count(gridBox%sunlit(:) > 0),                  gridBox%nLevels + 1) :: &
-        pressureLevels
-    
-    ! Subcol quantities, dimension nPoints, nSubCols, nLevels 
-    real, &
-      dimension(count(gridBox%sunlit(:) > 0), subCols%nColumns, gridBox%nLevels) :: & 
-        opticalThickness, cloudWater, cloudIce, waterSize, iceSize
-    
-    ! Vertically-integrated subcol quantities; dimensions nPoints, nSubcols 
-    integer, &
-      dimension(count(gridBox%sunlit(:) > 0), subCols%nColumns) :: & 
-        retrievedPhase
-    real, &
-      dimension(count(gridBox%sunlit(:) > 0), subCols%nColumns) :: & 
-        isccpTau, isccpCloudTopPressure, retrievedCloudTopPressure, retrievedTau, retrievedSize  
-    
-    ! Vertically-integrated results
-    real, dimension(count(gridBox%sunlit(:) > 0)) :: & 
-        cfTotal, cfLiquid, cfIce,                &
-        cfHigh,  cfMid,    cfLow,                &
-        meanTauTotal, meanTauLiquid, meanTauIce, &
-        meanLogTauTotal, meanLogTauLiquid, meanLogTauIce , &
-        meanSizeLiquid, meanSizeIce,             &
-        meanCloudTopPressure,                    &
-        meanLiquidWaterPath, meanIceWaterPath
-        
-    real, dimension(count(gridBox%sunlit(:) > 0), numModisTauBins, numModisPressureBins) :: & 
-         jointHistogram
-    real, dimension(count(gridBox%sunlit(:) > 0), numModisTauBins, numMODISReffIceBins) :: & 
-         jointHistogram2
-    real, dimension(count(gridBox%sunlit(:) > 0), numModisTauBins, numMODISReffLiqBins) :: & 
-         jointHistogram3
-    
-    integer, dimension(count(gridBox%sunlit(:) >  0)) :: sunlit
-    integer, dimension(count(gridBox%sunlit(:) <= 0)) :: notSunlit
-    ! ------------------------------------------------------------
-    
-    !
-    ! Are there any sunlit points? 
-    !
-    nSunlit = count(gridBox%sunlit(:) > 0)
-    if(nSunlit > 0) then 
-      nLevels  = gridBox%Nlevels
-      nPoints  = gridBox%Npoints
-      nSubCols = subCols%Ncolumns
-      !
-      ! This is a vector index indicating which points are sunlit
-      !
-      sunlit(:)    = pack((/ (i, i = 1, nPoints ) /), mask =       gridBox%sunlit(:) > 0)
-      notSunlit(:) = pack((/ (i, i = 1, nPoints ) /), mask = .not. gridBox%sunlit(:) > 0)
-               
-      !
-      ! Copy needed quantities, reversing vertical order and removing points with no sunlight 
-      !
-      pressureLevels(:, 1) = 0.0 ! Top of model, following ISCCP sim
-      temperature(:, :)     = gridBox%T (sunlit(:), nLevels:1:-1) 
-      pressureLayers(:, :)  = gridBox%p (sunlit(:), nLevels:1:-1) 
-      pressureLevels(:, 2:) = gridBox%ph(sunlit(:), nLevels:1:-1) 
-      
-      !
-      ! Subcolumn properties - first stratiform cloud...
-      ! 
-      where(subCols%frac_out(sunlit(:), :, :) == I_LSC)
-        !opticalThickness(:, :, :) = & 
-        !               spread(gridBox%dtau_s      (sunlit(:),    :), dim = 2, nCopies = nSubCols)
-        cloudWater(:, :, :) = subcolHydro%mr_hydro(sunlit(:), :, :, I_LSCLIQ)
-        waterSize (:, :, :) = subcolHydro%reff    (sunlit(:), :, :, I_LSCLIQ)
-        cloudIce  (:, :, :) = subcolHydro%mr_hydro(sunlit(:), :, :, I_LSCICE)
-        iceSize   (:, :, :) = subcolHydro%reff    (sunlit(:), :, :, I_LSCICE)
-      elsewhere
-        opticalThickness(:, :, :) = 0.
-        cloudWater      (:, :, :) = 0.
-        cloudIce        (:, :, :) = 0.
-        waterSize       (:, :, :) = 0.
-        iceSize         (:, :, :) = 0.
-      end where 
-
-      ! Loop version of spread above - intrinsic doesn't work on certain platforms. 
-      do k = 1, nLevels
-        do j = 1, nSubCols
-          do i = 1, nSunlit
-            if(subCols%frac_out(sunlit(i), j, k) == I_LSC) then
-              opticalThickness(i, j, k) = gridBox%dtau_s(sunlit(i), k)
-            else
-              opticalThickness(i, j, k) = 0.   
-            end if 
-          end do 
-        end do
-      end do
-
-      !
-      ! .. then add convective cloud...
-      !
-      where(subCols%frac_out(sunlit(:), :, :) == I_CVC) 
-        !opticalThickness(:, :, :) = &
-        !               spread(gridBox%dtau_c(      sunlit(:),    :), dim = 2, nCopies = nSubCols)
-        cloudWater(:, :, :) = subcolHydro%mr_hydro(sunlit(:), :, :, I_CVCLIQ)
-        waterSize (:, :, :) = subcolHydro%reff    (sunlit(:), :, :, I_CVCLIQ)
-        cloudIce  (:, :, :) = subcolHydro%mr_hydro(sunlit(:), :, :, I_CVCICE)
-        iceSize   (:, :, :) = subcolHydro%reff    (sunlit(:), :, :, I_CVCICE)
-      end where
-
-      ! Loop version of spread above - intrinsic doesn't work on certain platforms. 
-      do k = 1, nLevels
-        do j = 1, nSubCols
-          do i = 1, nSunlit
-            if(subCols%frac_out(sunlit(i), j, k) == I_CVC) opticalThickness(i, j, k) = gridBox%dtau_c(sunlit(i), k)
-          end do 
-        end do
-      end do
-
-      !
-      ! Reverse vertical order 
-      !
-      opticalThickness(:, :, :)  = opticalThickness(:, :, nLevels:1:-1)
-      cloudWater      (:, :, :)  = cloudWater      (:, :, nLevels:1:-1)
-      waterSize       (:, :, :)  = waterSize       (:, :, nLevels:1:-1)
-      cloudIce        (:, :, :)  = cloudIce        (:, :, nLevels:1:-1)
-      iceSize         (:, :, :)  = iceSize         (:, :, nLevels:1:-1)
-      
-      isccpTau(:, :)              = isccpSim%boxtau (sunlit(:), :)
-      isccpCloudTopPressure(:, :) = isccpSim%boxptop(sunlit(:), :)
-      
-      do i = 1, nSunlit
-        call modis_L2_simulator(temperature(i, :), pressureLayers(i, :), pressureLevels(i, :),     &
-                                opticalThickness(i, :, :), cloudWater(i, :, :), cloudIce(i, :, :), &
-                                waterSize(i, :, :), iceSize(i, :, :),                       &
-                                isccpTau(i, :), isccpCloudTopPressure(i, :),                &
-                                retrievedPhase(i, :), retrievedCloudTopPressure(i, :),      & 
-                                retrievedTau(i, :), retrievedSize(i, :))
-     end do
-     
-      ! DJS2015: Call L3 modis simulator used by cospv2.0
-     ! call modis_L3_simulator(retrievedPhase,              &
-     !                         retrievedCloudTopPressure,   &
-     !                         retrievedTau, retrievedSize, &
-     !                         cfTotal,         cfLiquid,         cfIce,         &
-     !                         cfHigh,          cfMid,            cfLow,         &
-     !                         meanTauTotal,    meanTauLiquid,    meanTauIce,    &
-     !                         meanLogTauTotal, meanLogTauLiquid, meanLogTauIce, &
-     !                         meanSizeLiquid,   meanSizeIce,   &
-     !                         meanCloudTopPressure,                             &
-     !                         meanLiquidWaterPath, meanIceWaterPath, &
-     !                         jointHistogram)
-     call modis_column(nSunlit,nSubcols,retrievedPhase,retrievedCloudTopPressure,   &
-                        retrievedTau,retrievedSize,cfTotal,cfLiquid,cfIce,cfHigh,    &
-                        cfMid,cfLow,meanTauTotal,meanTauLiquid,meanTauIce,           &
-                        meanLogTauTotal,meanLogTauLiquid,meanLogTauIce,              &
-                        meanSizeLiquid,meanSizeIce,meanCloudTopPressure,             &
-                        meanLiquidWaterPath, meanIceWaterPath,                       &
-                        jointHistogram,jointHistogram2,jointHistogram3)
-      ! DJS2015: END
-      
-      !
-      ! Copy results into COSP structure
-      !
-      modisSim%Cloud_Fraction_Total_Mean(sunlit(:)) = cfTotal(:)
-      modisSim%Cloud_Fraction_Water_Mean(sunlit(:)) = cfLiquid
-      modisSim%Cloud_Fraction_Ice_Mean  (sunlit(:)) = cfIce
-  
-      modisSim%Cloud_Fraction_High_Mean(sunlit(:)) = cfHigh
-      modisSim%Cloud_Fraction_Mid_Mean (sunlit(:)) = cfMid
-      modisSim%Cloud_Fraction_Low_Mean (sunlit(:)) = cfLow
-  
-      modisSim%Optical_Thickness_Total_Mean(sunlit(:)) = meanTauTotal
-      modisSim%Optical_Thickness_Water_Mean(sunlit(:)) = meanTauLiquid
-      modisSim%Optical_Thickness_Ice_Mean  (sunlit(:)) = meanTauIce
-  
-      modisSim%Optical_Thickness_Total_LogMean(sunlit(:)) = meanLogTauTotal
-      modisSim%Optical_Thickness_Water_LogMean(sunlit(:)) = meanLogTauLiquid
-      modisSim%Optical_Thickness_Ice_LogMean  (sunlit(:)) = meanLogTauIce
-  
-      modisSim%Cloud_Particle_Size_Water_Mean(sunlit(:)) = meanSizeLiquid
-      modisSim%Cloud_Particle_Size_Ice_Mean  (sunlit(:)) = meanSizeIce
-  
-      modisSim%Cloud_Top_Pressure_Total_Mean(sunlit(:)) = meanCloudTopPressure
-  
-      modisSim%Liquid_Water_Path_Mean(sunlit(:)) = meanLiquidWaterPath
-      modisSim%Ice_Water_Path_Mean   (sunlit(:)) = meanIceWaterPath
-      
-      modisSim%Optical_Thickness_vs_Cloud_Top_Pressure(sunlit(:), 2:numModisTauBins+1, :) = jointHistogram(:, :, :)
-      modisSim%Optical_Thickness_vs_ReffICE(sunlit(:),2:numModisTauBins+1,:)              = jointHistogram2(:, :, :)
-      modisSim%Optical_Thickness_vs_ReffLIQ(sunlit(:),2:numModisTauBins+1,:)              = jointHistogram3(:, :, :)
-      ! 
-      ! Reorder pressure bins in joint histogram to go from surface to TOA 
-      !
-      modisSim%Optical_Thickness_vs_Cloud_Top_Pressure(:,:,:) = modisSim%Optical_Thickness_vs_Cloud_Top_Pressure(:, :, numModisPressureBins:1:-1)
-      if(nSunlit < nPoints) then 
-        !
-        ! Where it's night and we haven't done the retrievals the values are undefined
-        !
-        modisSim%Cloud_Fraction_Total_Mean(notSunlit(:)) = R_UNDEF
-        modisSim%Cloud_Fraction_Water_Mean(notSunlit(:)) = R_UNDEF
-        modisSim%Cloud_Fraction_Ice_Mean  (notSunlit(:)) = R_UNDEF
-    
-        modisSim%Cloud_Fraction_High_Mean(notSunlit(:)) = R_UNDEF
-        modisSim%Cloud_Fraction_Mid_Mean (notSunlit(:)) = R_UNDEF
-        modisSim%Cloud_Fraction_Low_Mean (notSunlit(:)) = R_UNDEF
-
-        modisSim%Optical_Thickness_Total_Mean(notSunlit(:)) = R_UNDEF
-        modisSim%Optical_Thickness_Water_Mean(notSunlit(:)) = R_UNDEF
-        modisSim%Optical_Thickness_Ice_Mean  (notSunlit(:)) = R_UNDEF
-    
-        modisSim%Optical_Thickness_Total_LogMean(notSunlit(:)) = R_UNDEF
-        modisSim%Optical_Thickness_Water_LogMean(notSunlit(:)) = R_UNDEF
-        modisSim%Optical_Thickness_Ice_LogMean  (notSunlit(:)) = R_UNDEF
-    
-        modisSim%Cloud_Particle_Size_Water_Mean(notSunlit(:)) = R_UNDEF
-        modisSim%Cloud_Particle_Size_Ice_Mean  (notSunlit(:)) = R_UNDEF
-    
-        modisSim%Cloud_Top_Pressure_Total_Mean(notSunlit(:)) = R_UNDEF
-    
-        modisSim%Liquid_Water_Path_Mean(notSunlit(:)) = R_UNDEF
-        modisSim%Ice_Water_Path_Mean   (notSunlit(:)) = R_UNDEF
-  
-        modisSim%Optical_Thickness_vs_Cloud_Top_Pressure(notSunlit(:), :, :) = R_UNDEF
-        modisSim%Optical_Thickness_vs_ReffICE(notSunlit(:), :, :) = R_UNDEF
-        modisSim%Optical_Thickness_vs_ReffLIQ(notSunlit(:), :, :) = R_UNDEF
-      end if 
-    else
-      !
-      ! It's nightime everywhere - everything is undefined
-      !
-      modisSim%Cloud_Fraction_Total_Mean(:) = R_UNDEF
-      modisSim%Cloud_Fraction_Water_Mean(:) = R_UNDEF
-      modisSim%Cloud_Fraction_Ice_Mean  (:) = R_UNDEF
-  
-      modisSim%Cloud_Fraction_High_Mean(:) = R_UNDEF
-      modisSim%Cloud_Fraction_Mid_Mean (:) = R_UNDEF
-      modisSim%Cloud_Fraction_Low_Mean (:) = R_UNDEF
-
-      modisSim%Optical_Thickness_Total_Mean(:) = R_UNDEF
-      modisSim%Optical_Thickness_Water_Mean(:) = R_UNDEF
-      modisSim%Optical_Thickness_Ice_Mean  (:) = R_UNDEF
-  
-      modisSim%Optical_Thickness_Total_LogMean(:) = R_UNDEF
-      modisSim%Optical_Thickness_Water_LogMean(:) = R_UNDEF
-      modisSim%Optical_Thickness_Ice_LogMean  (:) = R_UNDEF
-  
-      modisSim%Cloud_Particle_Size_Water_Mean(:) = R_UNDEF
-      modisSim%Cloud_Particle_Size_Ice_Mean  (:) = R_UNDEF
-  
-      modisSim%Cloud_Top_Pressure_Total_Mean(:) = R_UNDEF
-  
-      modisSim%Liquid_Water_Path_Mean(:) = R_UNDEF
-      modisSim%Ice_Water_Path_Mean   (:) = R_UNDEF
-  
-      modisSim%Optical_Thickness_vs_Cloud_Top_Pressure(:, :, :) = R_UNDEF
-      modisSim%Optical_Thickness_vs_ReffICE(:, :, :) = R_UNDEF
-      modisSim%Optical_Thickness_vs_ReffLIQ(:, :, :) = R_UNDEF
-    end if 
-
-  end subroutine COSP_Modis_Simulator
-  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-  !------------- SUBROUTINE CONSTRUCT_COSP_MODIS ------------------
-  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-  SUBROUTINE CONSTRUCT_COSP_MODIS(cfg, nPoints, x)
-    type(cosp_config), intent(in)  :: cfg ! Configuration options
-    integer,           intent(in)  :: Npoints  ! Number of sampled points
-    type(cosp_MODIS),  intent(out) :: x
-    !
-    ! Allocate minumum storage if simulator not used
-    !
-    if (cfg%LMODIS_sim) then
-      x%nPoints  = nPoints
-    else
-      x%Npoints  = 1
-    endif
-    
-    ! --- Allocate arrays ---
-    allocate(x%Cloud_Fraction_Total_Mean(x%nPoints)) 
-    allocate(x%Cloud_Fraction_Water_Mean(x%nPoints)) 
-    allocate(x%Cloud_Fraction_Ice_Mean(x%nPoints)) 
-    
-    allocate(x%Cloud_Fraction_High_Mean(x%nPoints)) 
-    allocate(x%Cloud_Fraction_Mid_Mean(x%nPoints)) 
-    allocate(x%Cloud_Fraction_Low_Mean(x%nPoints)) 
-    
-    allocate(x%Optical_Thickness_Total_Mean(x%nPoints)) 
-    allocate(x%Optical_Thickness_Water_Mean(x%nPoints)) 
-    allocate(x%Optical_Thickness_Ice_Mean(x%nPoints)) 
-    
-    allocate(x%Optical_Thickness_Total_LogMean(x%nPoints)) 
-    allocate(x%Optical_Thickness_Water_LogMean(x%nPoints)) 
-    allocate(x%Optical_Thickness_Ice_LogMean(x%nPoints)) 
-    
-    allocate(x%Cloud_Particle_Size_Water_Mean(x%nPoints)) 
-    allocate(x%Cloud_Particle_Size_Ice_Mean(x%nPoints)) 
-    
-    allocate(x%Cloud_Top_Pressure_Total_Mean(x%nPoints)) 
-    
-    allocate(x%Liquid_Water_Path_Mean(x%nPoints)) 
-    allocate(x%Ice_Water_Path_Mean(x%nPoints)) 
-      
-    allocate(x%Optical_Thickness_vs_Cloud_Top_Pressure(nPoints, numModisTauBins+1, numModisPressureBins))
-    allocate(x%Optical_Thickness_vs_ReffICE(nPoints, numModisTauBins+1, numModisReffIceBins))
-    allocate(x%Optical_Thickness_vs_ReffLIQ(nPoints, numModisTauBins+1, numModisReffLiqBins))
-    x%Optical_Thickness_vs_Cloud_Top_Pressure(:, :, :) = R_UNDEF
-    x%Optical_Thickness_vs_ReffLIQ(:, :, :) = R_UNDEF
-    x%Optical_Thickness_vs_ReffICE(:, :, :) = R_UNDEF
-
-  END SUBROUTINE CONSTRUCT_COSP_MODIS
-
-  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-  !------------- SUBROUTINE FREE_COSP_MODIS -----------------------
-  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-  SUBROUTINE FREE_COSP_MODIS(x)
-    type(cosp_MODIS),intent(inout) :: x
-    !
-    ! Free space used by cosp_modis variable. 
-    !
-    
-    if(associated(x%Cloud_Fraction_Total_Mean)) deallocate(x%Cloud_Fraction_Total_Mean) 
-    if(associated(x%Cloud_Fraction_Water_Mean)) deallocate(x%Cloud_Fraction_Water_Mean) 
-    if(associated(x%Cloud_Fraction_Ice_Mean  )) deallocate(x%Cloud_Fraction_Ice_Mean) 
-    
-    if(associated(x%Cloud_Fraction_High_Mean)) deallocate(x%Cloud_Fraction_High_Mean) 
-    if(associated(x%Cloud_Fraction_Mid_Mean )) deallocate(x%Cloud_Fraction_Mid_Mean) 
-    if(associated(x%Cloud_Fraction_Low_Mean )) deallocate(x%Cloud_Fraction_Low_Mean) 
-    
-    if(associated(x%Optical_Thickness_Total_Mean)) deallocate(x%Optical_Thickness_Total_Mean) 
-    if(associated(x%Optical_Thickness_Water_Mean)) deallocate(x%Optical_Thickness_Water_Mean) 
-    if(associated(x%Optical_Thickness_Ice_Mean  )) deallocate(x%Optical_Thickness_Ice_Mean) 
-    
-    if(associated(x%Optical_Thickness_Total_LogMean)) deallocate(x%Optical_Thickness_Total_LogMean) 
-    if(associated(x%Optical_Thickness_Water_LogMean)) deallocate(x%Optical_Thickness_Water_LogMean) 
-    if(associated(x%Optical_Thickness_Ice_LogMean  )) deallocate(x%Optical_Thickness_Ice_LogMean) 
-    
-    if(associated(x%Cloud_Particle_Size_Water_Mean)) deallocate(x%Cloud_Particle_Size_Water_Mean) 
-    if(associated(x%Cloud_Particle_Size_Ice_Mean  )) deallocate(x%Cloud_Particle_Size_Ice_Mean) 
-    
-    if(associated(x%Cloud_Top_Pressure_Total_Mean )) deallocate(x%Cloud_Top_Pressure_Total_Mean   ) 
-    
-    if(associated(x%Liquid_Water_Path_Mean)) deallocate(x%Liquid_Water_Path_Mean   ) 
-    if(associated(x%Ice_Water_Path_Mean   )) deallocate(x%Ice_Water_Path_Mean   ) 
-    
-    if(associated(x%Optical_Thickness_vs_Cloud_Top_Pressure)) deallocate(x%Optical_Thickness_vs_Cloud_Top_Pressure   ) 
-    if(associated(x%Optical_Thickness_vs_ReffIce)) deallocate(x%Optical_Thickness_vs_ReffIce) 
-    if(associated(x%Optical_Thickness_vs_ReffLiq)) deallocate(x%Optical_Thickness_vs_ReffLiq) 
-  END SUBROUTINE FREE_COSP_MODIS
-  ! -----------------------------------------------------
-
-  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-  !------------- SUBROUTINE COSP_MODIS_CPSECTION -----------------
-  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-  SUBROUTINE COSP_MODIS_CPSECTION(ix, iy, orig, copy)
-    integer, dimension(2), intent(in) :: ix, iy
-    type(cosp_modis),      intent(in   ) :: orig
-    type(cosp_modis),      intent(  out) :: copy
-    !
-    ! Copy a set of grid points from one cosp_modis variable to another.
-    !   Should test to be sure ix and iy refer to the same number of grid points 
-    !
-    integer :: orig_start, orig_end, copy_start, copy_end
-    
-    orig_start = ix(1); orig_end = ix(2)
-    copy_start = iy(1); copy_end = iy(2) 
-    
-    copy%Cloud_Fraction_Total_Mean(copy_start:copy_end) = orig%Cloud_Fraction_Total_Mean(orig_start:orig_end)
-    copy%Cloud_Fraction_Water_Mean(copy_start:copy_end) = orig%Cloud_Fraction_Water_Mean(orig_start:orig_end)
-    copy%Cloud_Fraction_Ice_Mean  (copy_start:copy_end) = orig%Cloud_Fraction_Ice_Mean  (orig_start:orig_end)
-    
-    copy%Cloud_Fraction_High_Mean(copy_start:copy_end) = orig%Cloud_Fraction_High_Mean(orig_start:orig_end)
-    copy%Cloud_Fraction_Mid_Mean (copy_start:copy_end) = orig%Cloud_Fraction_Mid_Mean (orig_start:orig_end)
-    copy%Cloud_Fraction_Low_Mean (copy_start:copy_end) = orig%Cloud_Fraction_Low_Mean (orig_start:orig_end)
-    
-    copy%Optical_Thickness_Total_Mean(copy_start:copy_end) = orig%Optical_Thickness_Total_Mean(orig_start:orig_end)
-    copy%Optical_Thickness_Water_Mean(copy_start:copy_end) = orig%Optical_Thickness_Water_Mean(orig_start:orig_end)
-    copy%Optical_Thickness_Ice_Mean  (copy_start:copy_end) = orig%Optical_Thickness_Ice_Mean  (orig_start:orig_end)
-    
-    copy%Optical_Thickness_Total_LogMean(copy_start:copy_end) = &
-                                                          orig%Optical_Thickness_Total_LogMean(orig_start:orig_end)
-    copy%Optical_Thickness_Water_LogMean(copy_start:copy_end) = &
-                                                          orig%Optical_Thickness_Water_LogMean(orig_start:orig_end)
-    copy%Optical_Thickness_Ice_LogMean  (copy_start:copy_end) = &
-                                                          orig%Optical_Thickness_Ice_LogMean  (orig_start:orig_end)
-
-    copy%Cloud_Particle_Size_Water_Mean(copy_start:copy_end) = orig%Cloud_Particle_Size_Water_Mean(orig_start:orig_end)
-    copy%Cloud_Particle_Size_Ice_Mean  (copy_start:copy_end) = orig%Cloud_Particle_Size_Ice_Mean  (orig_start:orig_end)
-
-    copy%Cloud_Top_Pressure_Total_Mean(copy_start:copy_end) = orig%Cloud_Top_Pressure_Total_Mean(orig_start:orig_end)
-    
-    copy%Liquid_Water_Path_Mean(copy_start:copy_end) = orig%Liquid_Water_Path_Mean(orig_start:orig_end)
-    copy%Ice_Water_Path_Mean   (copy_start:copy_end) = orig%Ice_Water_Path_Mean  (orig_start:orig_end)
-    
-    copy%Optical_Thickness_vs_Cloud_Top_Pressure(copy_start:copy_end, :, :) = &
-         orig%Optical_Thickness_vs_Cloud_Top_Pressure(orig_start:orig_end, :, :)
-    copy%Optical_Thickness_vs_ReffIce(copy_start:copy_end, :, :) = &
-         orig%Optical_Thickness_vs_ReffIce(orig_start:orig_end, :, :)
-    copy%Optical_Thickness_vs_ReffLiq(copy_start:copy_end, :, :) = &
-         orig%Optical_Thickness_vs_ReffLiq(orig_start:orig_end, :, :)
-
-  END SUBROUTINE COSP_MODIS_CPSECTION
-  ! -----------------------------------------------------
-
-END MODULE MOD_COSP_Modis_Simulator
Index: /LMDZ6/trunk/libf/phylmd/cosp/mod_cosp_modis_simulator.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cosp/mod_cosp_modis_simulator.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/cosp/mod_cosp_modis_simulator.f90	(revision 5268)
@@ -0,0 +1,487 @@
+! (c) 2009, Regents of the Unversity of Colorado
+!   Author: Robert Pincus, Cooperative Institute for Research in the Environmental Sciences
+! All rights reserved.
+! $Revision: 88 $, $Date: 2013-11-13 07:08:38 -0700 (Wed, 13 Nov 2013) $
+! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/cosp_modis_simulator.F90 $
+! 
+! Redistribution and use in source and binary forms, with or without modification, are permitted 
+! provided that the following conditions are met:
+! 
+!     * Redistributions of source code must retain the above copyright notice, this list 
+!       of conditions and the following disclaimer.
+!     * Redistributions in binary form must reproduce the above copyright notice, this list
+!       of conditions and the following disclaimer in the documentation and/or other materials 
+!       provided with the distribution.
+!     * Neither the name of the Met Office nor the names of its contributors may be used 
+!       to endorse or promote products derived from this software without specific prior written 
+!       permission.
+! 
+! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR 
+! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND 
+! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR 
+! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 
+! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 
+! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER 
+! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT 
+! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+!
+
+!
+! History:
+!   May 2009 - Robert Pincus - Initial version
+!   Dec 2009 - Robert Pincus - Tiny revisions
+!
+MODULE MOD_COSP_Modis_Simulator
+  USE MOD_COSP_CONSTANTS
+  USE MOD_COSP_TYPES
+  use mod_modis_sim, numModisTauBins      => numTauHistogramBins,      &
+                     numModisPressureBins => numPressureHistogramBins, &
+                     MODIS_TAU      => nominalTauHistogramCenters,     &
+                     MODIS_TAU_BNDS => nominalTauHistogramBoundaries,  &
+                     MODIS_PC       => nominalPressureHistogramCenters, &
+                     MODIS_PC_BNDS  => nominalPressureHistogramBoundaries                     
+  implicit none
+  !------------------------------------------------------------------------------------------------
+  ! Public type
+  !
+  ! Summary statistics from MODIS retrievals
+  type COSP_MODIS
+     ! Dimensions
+     integer :: Npoints   ! Number of gridpoints
+     
+     !
+     ! Grid means; dimension nPoints
+     ! 
+     real, dimension(:),       pointer :: & 
+       Cloud_Fraction_Total_Mean,       Cloud_Fraction_Water_Mean,       Cloud_Fraction_Ice_Mean,       &
+       Cloud_Fraction_High_Mean,        Cloud_Fraction_Mid_Mean,         Cloud_Fraction_Low_Mean,       &
+       Optical_Thickness_Total_Mean,    Optical_Thickness_Water_Mean,    Optical_Thickness_Ice_Mean,    &
+       Optical_Thickness_Total_LogMean, Optical_Thickness_Water_LogMean, Optical_Thickness_Ice_LogMean, &
+                                        Cloud_Particle_Size_Water_Mean,  Cloud_Particle_Size_Ice_Mean,  &
+       Cloud_Top_Pressure_Total_Mean,                                                                   &
+                                        Liquid_Water_Path_Mean,          Ice_Water_Path_Mean
+     !
+     ! Also need the ISCCP-type optical thickness/cloud top pressure histogram
+     !
+     real, dimension(:, :, :), pointer :: Optical_Thickness_vs_Cloud_Top_Pressure
+     real, dimension(:, :, :), pointer :: Optical_Thickness_vs_ReffICE
+     real, dimension(:, :, :), pointer :: Optical_Thickness_vs_ReffLIQ
+  end type COSP_MODIS 
+  
+contains
+  !------------------------------------------------------------------------------------------------
+  subroutine COSP_Modis_Simulator(gridBox, subCols, subcolHydro, isccpSim, modisSim)
+    ! Arguments
+    type(cosp_gridbox), intent(in   ) :: gridBox     ! Gridbox info
+    type(cosp_subgrid), intent(in   ) :: subCols     ! subCol indicators of convective/stratiform 
+    type(cosp_sghydro), intent(in   ) :: subcolHydro ! subcol hydrometeor contens
+    type(cosp_isccp),   intent(in   ) :: isccpSim    ! ISCCP simulator output
+    type(cosp_modis),   intent(  out) :: modisSim    ! MODIS simulator subcol output
+    
+    ! ------------------------------------------------------------
+    ! Local variables 
+    !   Leave space only for sunlit points
+    
+    integer :: nPoints, nSubCols, nLevels, nSunlit, i, j, k
+    
+    ! Grid-mean quanties;  dimensions nPoints, nLevels
+    real, &
+      dimension(count(gridBox%sunlit(:) > 0),                  gridBox%nLevels) :: &
+        temperature, pressureLayers
+    real, &
+      dimension(count(gridBox%sunlit(:) > 0),                  gridBox%nLevels + 1) :: &
+        pressureLevels
+    
+    ! Subcol quantities, dimension nPoints, nSubCols, nLevels 
+    real, &
+      dimension(count(gridBox%sunlit(:) > 0), subCols%nColumns, gridBox%nLevels) :: & 
+        opticalThickness, cloudWater, cloudIce, waterSize, iceSize
+    
+    ! Vertically-integrated subcol quantities; dimensions nPoints, nSubcols 
+    integer, &
+      dimension(count(gridBox%sunlit(:) > 0), subCols%nColumns) :: & 
+        retrievedPhase
+    real, &
+      dimension(count(gridBox%sunlit(:) > 0), subCols%nColumns) :: & 
+        isccpTau, isccpCloudTopPressure, retrievedCloudTopPressure, retrievedTau, retrievedSize  
+    
+    ! Vertically-integrated results
+    real, dimension(count(gridBox%sunlit(:) > 0)) :: & 
+        cfTotal, cfLiquid, cfIce,                &
+        cfHigh,  cfMid,    cfLow,                &
+        meanTauTotal, meanTauLiquid, meanTauIce, &
+        meanLogTauTotal, meanLogTauLiquid, meanLogTauIce , &
+        meanSizeLiquid, meanSizeIce,             &
+        meanCloudTopPressure,                    &
+        meanLiquidWaterPath, meanIceWaterPath
+        
+    real, dimension(count(gridBox%sunlit(:) > 0), numModisTauBins, numModisPressureBins) :: & 
+         jointHistogram
+    real, dimension(count(gridBox%sunlit(:) > 0), numModisTauBins, numMODISReffIceBins) :: & 
+         jointHistogram2
+    real, dimension(count(gridBox%sunlit(:) > 0), numModisTauBins, numMODISReffLiqBins) :: & 
+         jointHistogram3
+    
+    integer, dimension(count(gridBox%sunlit(:) >  0)) :: sunlit
+    integer, dimension(count(gridBox%sunlit(:) <= 0)) :: notSunlit
+    ! ------------------------------------------------------------
+    
+    !
+    ! Are there any sunlit points? 
+    !
+    nSunlit = count(gridBox%sunlit(:) > 0)
+    if(nSunlit > 0) then 
+      nLevels  = gridBox%Nlevels
+      nPoints  = gridBox%Npoints
+      nSubCols = subCols%Ncolumns
+      !
+      ! This is a vector index indicating which points are sunlit
+      !
+      sunlit(:)    = pack((/ (i, i = 1, nPoints ) /), mask =       gridBox%sunlit(:) > 0)
+      notSunlit(:) = pack((/ (i, i = 1, nPoints ) /), mask = .not. gridBox%sunlit(:) > 0)
+               
+      !
+      ! Copy needed quantities, reversing vertical order and removing points with no sunlight 
+      !
+      pressureLevels(:, 1) = 0.0 ! Top of model, following ISCCP sim
+      temperature(:, :)     = gridBox%T (sunlit(:), nLevels:1:-1) 
+      pressureLayers(:, :)  = gridBox%p (sunlit(:), nLevels:1:-1) 
+      pressureLevels(:, 2:) = gridBox%ph(sunlit(:), nLevels:1:-1) 
+      
+      !
+      ! Subcolumn properties - first stratiform cloud...
+      ! 
+      where(subCols%frac_out(sunlit(:), :, :) == I_LSC)
+        !opticalThickness(:, :, :) = & 
+        !               spread(gridBox%dtau_s      (sunlit(:),    :), dim = 2, nCopies = nSubCols)
+        cloudWater(:, :, :) = subcolHydro%mr_hydro(sunlit(:), :, :, I_LSCLIQ)
+        waterSize (:, :, :) = subcolHydro%reff    (sunlit(:), :, :, I_LSCLIQ)
+        cloudIce  (:, :, :) = subcolHydro%mr_hydro(sunlit(:), :, :, I_LSCICE)
+        iceSize   (:, :, :) = subcolHydro%reff    (sunlit(:), :, :, I_LSCICE)
+      elsewhere
+        opticalThickness(:, :, :) = 0.
+        cloudWater      (:, :, :) = 0.
+        cloudIce        (:, :, :) = 0.
+        waterSize       (:, :, :) = 0.
+        iceSize         (:, :, :) = 0.
+      end where 
+
+      ! Loop version of spread above - intrinsic doesn't work on certain platforms. 
+      do k = 1, nLevels
+        do j = 1, nSubCols
+          do i = 1, nSunlit
+            if(subCols%frac_out(sunlit(i), j, k) == I_LSC) then
+              opticalThickness(i, j, k) = gridBox%dtau_s(sunlit(i), k)
+            else
+              opticalThickness(i, j, k) = 0.   
+            end if 
+          end do 
+        end do
+      end do
+
+      !
+      ! .. then add convective cloud...
+      !
+      where(subCols%frac_out(sunlit(:), :, :) == I_CVC) 
+        !opticalThickness(:, :, :) = &
+        !               spread(gridBox%dtau_c(      sunlit(:),    :), dim = 2, nCopies = nSubCols)
+        cloudWater(:, :, :) = subcolHydro%mr_hydro(sunlit(:), :, :, I_CVCLIQ)
+        waterSize (:, :, :) = subcolHydro%reff    (sunlit(:), :, :, I_CVCLIQ)
+        cloudIce  (:, :, :) = subcolHydro%mr_hydro(sunlit(:), :, :, I_CVCICE)
+        iceSize   (:, :, :) = subcolHydro%reff    (sunlit(:), :, :, I_CVCICE)
+      end where
+
+      ! Loop version of spread above - intrinsic doesn't work on certain platforms. 
+      do k = 1, nLevels
+        do j = 1, nSubCols
+          do i = 1, nSunlit
+            if(subCols%frac_out(sunlit(i), j, k) == I_CVC) opticalThickness(i, j, k) = gridBox%dtau_c(sunlit(i), k)
+          end do 
+        end do
+      end do
+
+      !
+      ! Reverse vertical order 
+      !
+      opticalThickness(:, :, :)  = opticalThickness(:, :, nLevels:1:-1)
+      cloudWater      (:, :, :)  = cloudWater      (:, :, nLevels:1:-1)
+      waterSize       (:, :, :)  = waterSize       (:, :, nLevels:1:-1)
+      cloudIce        (:, :, :)  = cloudIce        (:, :, nLevels:1:-1)
+      iceSize         (:, :, :)  = iceSize         (:, :, nLevels:1:-1)
+      
+      isccpTau(:, :)              = isccpSim%boxtau (sunlit(:), :)
+      isccpCloudTopPressure(:, :) = isccpSim%boxptop(sunlit(:), :)
+      
+      do i = 1, nSunlit
+        call modis_L2_simulator(temperature(i, :), pressureLayers(i, :), pressureLevels(i, :),     &
+                                opticalThickness(i, :, :), cloudWater(i, :, :), cloudIce(i, :, :), &
+                                waterSize(i, :, :), iceSize(i, :, :),                       &
+                                isccpTau(i, :), isccpCloudTopPressure(i, :),                &
+                                retrievedPhase(i, :), retrievedCloudTopPressure(i, :),      & 
+                                retrievedTau(i, :), retrievedSize(i, :))
+     end do
+     
+      ! DJS2015: Call L3 modis simulator used by cospv2.0
+     ! call modis_L3_simulator(retrievedPhase,              &
+     !                         retrievedCloudTopPressure,   &
+     !                         retrievedTau, retrievedSize, &
+     !                         cfTotal,         cfLiquid,         cfIce,         &
+     !                         cfHigh,          cfMid,            cfLow,         &
+     !                         meanTauTotal,    meanTauLiquid,    meanTauIce,    &
+     !                         meanLogTauTotal, meanLogTauLiquid, meanLogTauIce, &
+     !                         meanSizeLiquid,   meanSizeIce,   &
+     !                         meanCloudTopPressure,                             &
+     !                         meanLiquidWaterPath, meanIceWaterPath, &
+     !                         jointHistogram)
+     call modis_column(nSunlit,nSubcols,retrievedPhase,retrievedCloudTopPressure,   &
+                        retrievedTau,retrievedSize,cfTotal,cfLiquid,cfIce,cfHigh,    &
+                        cfMid,cfLow,meanTauTotal,meanTauLiquid,meanTauIce,           &
+                        meanLogTauTotal,meanLogTauLiquid,meanLogTauIce,              &
+                        meanSizeLiquid,meanSizeIce,meanCloudTopPressure,             &
+                        meanLiquidWaterPath, meanIceWaterPath,                       &
+                        jointHistogram,jointHistogram2,jointHistogram3)
+      ! DJS2015: END
+      
+      !
+      ! Copy results into COSP structure
+      !
+      modisSim%Cloud_Fraction_Total_Mean(sunlit(:)) = cfTotal(:)
+      modisSim%Cloud_Fraction_Water_Mean(sunlit(:)) = cfLiquid
+      modisSim%Cloud_Fraction_Ice_Mean  (sunlit(:)) = cfIce
+  
+      modisSim%Cloud_Fraction_High_Mean(sunlit(:)) = cfHigh
+      modisSim%Cloud_Fraction_Mid_Mean (sunlit(:)) = cfMid
+      modisSim%Cloud_Fraction_Low_Mean (sunlit(:)) = cfLow
+  
+      modisSim%Optical_Thickness_Total_Mean(sunlit(:)) = meanTauTotal
+      modisSim%Optical_Thickness_Water_Mean(sunlit(:)) = meanTauLiquid
+      modisSim%Optical_Thickness_Ice_Mean  (sunlit(:)) = meanTauIce
+  
+      modisSim%Optical_Thickness_Total_LogMean(sunlit(:)) = meanLogTauTotal
+      modisSim%Optical_Thickness_Water_LogMean(sunlit(:)) = meanLogTauLiquid
+      modisSim%Optical_Thickness_Ice_LogMean  (sunlit(:)) = meanLogTauIce
+  
+      modisSim%Cloud_Particle_Size_Water_Mean(sunlit(:)) = meanSizeLiquid
+      modisSim%Cloud_Particle_Size_Ice_Mean  (sunlit(:)) = meanSizeIce
+  
+      modisSim%Cloud_Top_Pressure_Total_Mean(sunlit(:)) = meanCloudTopPressure
+  
+      modisSim%Liquid_Water_Path_Mean(sunlit(:)) = meanLiquidWaterPath
+      modisSim%Ice_Water_Path_Mean   (sunlit(:)) = meanIceWaterPath
+      
+      modisSim%Optical_Thickness_vs_Cloud_Top_Pressure(sunlit(:), 2:numModisTauBins+1, :) = jointHistogram(:, :, :)
+      modisSim%Optical_Thickness_vs_ReffICE(sunlit(:),2:numModisTauBins+1,:)              = jointHistogram2(:, :, :)
+      modisSim%Optical_Thickness_vs_ReffLIQ(sunlit(:),2:numModisTauBins+1,:)              = jointHistogram3(:, :, :)
+      ! 
+      ! Reorder pressure bins in joint histogram to go from surface to TOA 
+      !
+      modisSim%Optical_Thickness_vs_Cloud_Top_Pressure(:,:,:) = modisSim%Optical_Thickness_vs_Cloud_Top_Pressure(:, :, numModisPressureBins:1:-1)
+      if(nSunlit < nPoints) then 
+        !
+        ! Where it's night and we haven't done the retrievals the values are undefined
+        !
+        modisSim%Cloud_Fraction_Total_Mean(notSunlit(:)) = R_UNDEF
+        modisSim%Cloud_Fraction_Water_Mean(notSunlit(:)) = R_UNDEF
+        modisSim%Cloud_Fraction_Ice_Mean  (notSunlit(:)) = R_UNDEF
+    
+        modisSim%Cloud_Fraction_High_Mean(notSunlit(:)) = R_UNDEF
+        modisSim%Cloud_Fraction_Mid_Mean (notSunlit(:)) = R_UNDEF
+        modisSim%Cloud_Fraction_Low_Mean (notSunlit(:)) = R_UNDEF
+
+        modisSim%Optical_Thickness_Total_Mean(notSunlit(:)) = R_UNDEF
+        modisSim%Optical_Thickness_Water_Mean(notSunlit(:)) = R_UNDEF
+        modisSim%Optical_Thickness_Ice_Mean  (notSunlit(:)) = R_UNDEF
+    
+        modisSim%Optical_Thickness_Total_LogMean(notSunlit(:)) = R_UNDEF
+        modisSim%Optical_Thickness_Water_LogMean(notSunlit(:)) = R_UNDEF
+        modisSim%Optical_Thickness_Ice_LogMean  (notSunlit(:)) = R_UNDEF
+    
+        modisSim%Cloud_Particle_Size_Water_Mean(notSunlit(:)) = R_UNDEF
+        modisSim%Cloud_Particle_Size_Ice_Mean  (notSunlit(:)) = R_UNDEF
+    
+        modisSim%Cloud_Top_Pressure_Total_Mean(notSunlit(:)) = R_UNDEF
+    
+        modisSim%Liquid_Water_Path_Mean(notSunlit(:)) = R_UNDEF
+        modisSim%Ice_Water_Path_Mean   (notSunlit(:)) = R_UNDEF
+  
+        modisSim%Optical_Thickness_vs_Cloud_Top_Pressure(notSunlit(:), :, :) = R_UNDEF
+        modisSim%Optical_Thickness_vs_ReffICE(notSunlit(:), :, :) = R_UNDEF
+        modisSim%Optical_Thickness_vs_ReffLIQ(notSunlit(:), :, :) = R_UNDEF
+      end if 
+    else
+      !
+      ! It's nightime everywhere - everything is undefined
+      !
+      modisSim%Cloud_Fraction_Total_Mean(:) = R_UNDEF
+      modisSim%Cloud_Fraction_Water_Mean(:) = R_UNDEF
+      modisSim%Cloud_Fraction_Ice_Mean  (:) = R_UNDEF
+  
+      modisSim%Cloud_Fraction_High_Mean(:) = R_UNDEF
+      modisSim%Cloud_Fraction_Mid_Mean (:) = R_UNDEF
+      modisSim%Cloud_Fraction_Low_Mean (:) = R_UNDEF
+
+      modisSim%Optical_Thickness_Total_Mean(:) = R_UNDEF
+      modisSim%Optical_Thickness_Water_Mean(:) = R_UNDEF
+      modisSim%Optical_Thickness_Ice_Mean  (:) = R_UNDEF
+  
+      modisSim%Optical_Thickness_Total_LogMean(:) = R_UNDEF
+      modisSim%Optical_Thickness_Water_LogMean(:) = R_UNDEF
+      modisSim%Optical_Thickness_Ice_LogMean  (:) = R_UNDEF
+  
+      modisSim%Cloud_Particle_Size_Water_Mean(:) = R_UNDEF
+      modisSim%Cloud_Particle_Size_Ice_Mean  (:) = R_UNDEF
+  
+      modisSim%Cloud_Top_Pressure_Total_Mean(:) = R_UNDEF
+  
+      modisSim%Liquid_Water_Path_Mean(:) = R_UNDEF
+      modisSim%Ice_Water_Path_Mean   (:) = R_UNDEF
+  
+      modisSim%Optical_Thickness_vs_Cloud_Top_Pressure(:, :, :) = R_UNDEF
+      modisSim%Optical_Thickness_vs_ReffICE(:, :, :) = R_UNDEF
+      modisSim%Optical_Thickness_vs_ReffLIQ(:, :, :) = R_UNDEF
+    end if 
+
+  end subroutine COSP_Modis_Simulator
+  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  !------------- SUBROUTINE CONSTRUCT_COSP_MODIS ------------------
+  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  SUBROUTINE CONSTRUCT_COSP_MODIS(cfg, nPoints, x)
+    type(cosp_config), intent(in)  :: cfg ! Configuration options
+    integer,           intent(in)  :: Npoints  ! Number of sampled points
+    type(cosp_MODIS),  intent(out) :: x
+    !
+    ! Allocate minumum storage if simulator not used
+    !
+    if (cfg%LMODIS_sim) then
+      x%nPoints  = nPoints
+    else
+      x%Npoints  = 1
+    endif
+    
+    ! --- Allocate arrays ---
+    allocate(x%Cloud_Fraction_Total_Mean(x%nPoints)) 
+    allocate(x%Cloud_Fraction_Water_Mean(x%nPoints)) 
+    allocate(x%Cloud_Fraction_Ice_Mean(x%nPoints)) 
+    
+    allocate(x%Cloud_Fraction_High_Mean(x%nPoints)) 
+    allocate(x%Cloud_Fraction_Mid_Mean(x%nPoints)) 
+    allocate(x%Cloud_Fraction_Low_Mean(x%nPoints)) 
+    
+    allocate(x%Optical_Thickness_Total_Mean(x%nPoints)) 
+    allocate(x%Optical_Thickness_Water_Mean(x%nPoints)) 
+    allocate(x%Optical_Thickness_Ice_Mean(x%nPoints)) 
+    
+    allocate(x%Optical_Thickness_Total_LogMean(x%nPoints)) 
+    allocate(x%Optical_Thickness_Water_LogMean(x%nPoints)) 
+    allocate(x%Optical_Thickness_Ice_LogMean(x%nPoints)) 
+    
+    allocate(x%Cloud_Particle_Size_Water_Mean(x%nPoints)) 
+    allocate(x%Cloud_Particle_Size_Ice_Mean(x%nPoints)) 
+    
+    allocate(x%Cloud_Top_Pressure_Total_Mean(x%nPoints)) 
+    
+    allocate(x%Liquid_Water_Path_Mean(x%nPoints)) 
+    allocate(x%Ice_Water_Path_Mean(x%nPoints)) 
+      
+    allocate(x%Optical_Thickness_vs_Cloud_Top_Pressure(nPoints, numModisTauBins+1, numModisPressureBins))
+    allocate(x%Optical_Thickness_vs_ReffICE(nPoints, numModisTauBins+1, numModisReffIceBins))
+    allocate(x%Optical_Thickness_vs_ReffLIQ(nPoints, numModisTauBins+1, numModisReffLiqBins))
+    x%Optical_Thickness_vs_Cloud_Top_Pressure(:, :, :) = R_UNDEF
+    x%Optical_Thickness_vs_ReffLIQ(:, :, :) = R_UNDEF
+    x%Optical_Thickness_vs_ReffICE(:, :, :) = R_UNDEF
+
+  END SUBROUTINE CONSTRUCT_COSP_MODIS
+
+  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  !------------- SUBROUTINE FREE_COSP_MODIS -----------------------
+  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  SUBROUTINE FREE_COSP_MODIS(x)
+    type(cosp_MODIS),intent(inout) :: x
+    !
+    ! Free space used by cosp_modis variable. 
+    !
+    
+    if(associated(x%Cloud_Fraction_Total_Mean)) deallocate(x%Cloud_Fraction_Total_Mean) 
+    if(associated(x%Cloud_Fraction_Water_Mean)) deallocate(x%Cloud_Fraction_Water_Mean) 
+    if(associated(x%Cloud_Fraction_Ice_Mean  )) deallocate(x%Cloud_Fraction_Ice_Mean) 
+    
+    if(associated(x%Cloud_Fraction_High_Mean)) deallocate(x%Cloud_Fraction_High_Mean) 
+    if(associated(x%Cloud_Fraction_Mid_Mean )) deallocate(x%Cloud_Fraction_Mid_Mean) 
+    if(associated(x%Cloud_Fraction_Low_Mean )) deallocate(x%Cloud_Fraction_Low_Mean) 
+    
+    if(associated(x%Optical_Thickness_Total_Mean)) deallocate(x%Optical_Thickness_Total_Mean) 
+    if(associated(x%Optical_Thickness_Water_Mean)) deallocate(x%Optical_Thickness_Water_Mean) 
+    if(associated(x%Optical_Thickness_Ice_Mean  )) deallocate(x%Optical_Thickness_Ice_Mean) 
+    
+    if(associated(x%Optical_Thickness_Total_LogMean)) deallocate(x%Optical_Thickness_Total_LogMean) 
+    if(associated(x%Optical_Thickness_Water_LogMean)) deallocate(x%Optical_Thickness_Water_LogMean) 
+    if(associated(x%Optical_Thickness_Ice_LogMean  )) deallocate(x%Optical_Thickness_Ice_LogMean) 
+    
+    if(associated(x%Cloud_Particle_Size_Water_Mean)) deallocate(x%Cloud_Particle_Size_Water_Mean) 
+    if(associated(x%Cloud_Particle_Size_Ice_Mean  )) deallocate(x%Cloud_Particle_Size_Ice_Mean) 
+    
+    if(associated(x%Cloud_Top_Pressure_Total_Mean )) deallocate(x%Cloud_Top_Pressure_Total_Mean   ) 
+    
+    if(associated(x%Liquid_Water_Path_Mean)) deallocate(x%Liquid_Water_Path_Mean   ) 
+    if(associated(x%Ice_Water_Path_Mean   )) deallocate(x%Ice_Water_Path_Mean   ) 
+    
+    if(associated(x%Optical_Thickness_vs_Cloud_Top_Pressure)) deallocate(x%Optical_Thickness_vs_Cloud_Top_Pressure   ) 
+    if(associated(x%Optical_Thickness_vs_ReffIce)) deallocate(x%Optical_Thickness_vs_ReffIce) 
+    if(associated(x%Optical_Thickness_vs_ReffLiq)) deallocate(x%Optical_Thickness_vs_ReffLiq) 
+  END SUBROUTINE FREE_COSP_MODIS
+  ! -----------------------------------------------------
+
+  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  !------------- SUBROUTINE COSP_MODIS_CPSECTION -----------------
+  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  SUBROUTINE COSP_MODIS_CPSECTION(ix, iy, orig, copy)
+    integer, dimension(2), intent(in) :: ix, iy
+    type(cosp_modis),      intent(in   ) :: orig
+    type(cosp_modis),      intent(  out) :: copy
+    !
+    ! Copy a set of grid points from one cosp_modis variable to another.
+    !   Should test to be sure ix and iy refer to the same number of grid points 
+    !
+    integer :: orig_start, orig_end, copy_start, copy_end
+    
+    orig_start = ix(1); orig_end = ix(2)
+    copy_start = iy(1); copy_end = iy(2) 
+    
+    copy%Cloud_Fraction_Total_Mean(copy_start:copy_end) = orig%Cloud_Fraction_Total_Mean(orig_start:orig_end)
+    copy%Cloud_Fraction_Water_Mean(copy_start:copy_end) = orig%Cloud_Fraction_Water_Mean(orig_start:orig_end)
+    copy%Cloud_Fraction_Ice_Mean  (copy_start:copy_end) = orig%Cloud_Fraction_Ice_Mean  (orig_start:orig_end)
+    
+    copy%Cloud_Fraction_High_Mean(copy_start:copy_end) = orig%Cloud_Fraction_High_Mean(orig_start:orig_end)
+    copy%Cloud_Fraction_Mid_Mean (copy_start:copy_end) = orig%Cloud_Fraction_Mid_Mean (orig_start:orig_end)
+    copy%Cloud_Fraction_Low_Mean (copy_start:copy_end) = orig%Cloud_Fraction_Low_Mean (orig_start:orig_end)
+    
+    copy%Optical_Thickness_Total_Mean(copy_start:copy_end) = orig%Optical_Thickness_Total_Mean(orig_start:orig_end)
+    copy%Optical_Thickness_Water_Mean(copy_start:copy_end) = orig%Optical_Thickness_Water_Mean(orig_start:orig_end)
+    copy%Optical_Thickness_Ice_Mean  (copy_start:copy_end) = orig%Optical_Thickness_Ice_Mean  (orig_start:orig_end)
+    
+    copy%Optical_Thickness_Total_LogMean(copy_start:copy_end) = &
+                                                          orig%Optical_Thickness_Total_LogMean(orig_start:orig_end)
+    copy%Optical_Thickness_Water_LogMean(copy_start:copy_end) = &
+                                                          orig%Optical_Thickness_Water_LogMean(orig_start:orig_end)
+    copy%Optical_Thickness_Ice_LogMean  (copy_start:copy_end) = &
+                                                          orig%Optical_Thickness_Ice_LogMean  (orig_start:orig_end)
+
+    copy%Cloud_Particle_Size_Water_Mean(copy_start:copy_end) = orig%Cloud_Particle_Size_Water_Mean(orig_start:orig_end)
+    copy%Cloud_Particle_Size_Ice_Mean  (copy_start:copy_end) = orig%Cloud_Particle_Size_Ice_Mean  (orig_start:orig_end)
+
+    copy%Cloud_Top_Pressure_Total_Mean(copy_start:copy_end) = orig%Cloud_Top_Pressure_Total_Mean(orig_start:orig_end)
+    
+    copy%Liquid_Water_Path_Mean(copy_start:copy_end) = orig%Liquid_Water_Path_Mean(orig_start:orig_end)
+    copy%Ice_Water_Path_Mean   (copy_start:copy_end) = orig%Ice_Water_Path_Mean  (orig_start:orig_end)
+    
+    copy%Optical_Thickness_vs_Cloud_Top_Pressure(copy_start:copy_end, :, :) = &
+         orig%Optical_Thickness_vs_Cloud_Top_Pressure(orig_start:orig_end, :, :)
+    copy%Optical_Thickness_vs_ReffIce(copy_start:copy_end, :, :) = &
+         orig%Optical_Thickness_vs_ReffIce(orig_start:orig_end, :, :)
+    copy%Optical_Thickness_vs_ReffLiq(copy_start:copy_end, :, :) = &
+         orig%Optical_Thickness_vs_ReffLiq(orig_start:orig_end, :, :)
+
+  END SUBROUTINE COSP_MODIS_CPSECTION
+  ! -----------------------------------------------------
+
+END MODULE MOD_COSP_Modis_Simulator
Index: DZ6/trunk/libf/phylmd/cosp/mod_cosp_radar.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cosp/mod_cosp_radar.F90	(revision 5267)
+++ 	(revision )
@@ -1,193 +1,0 @@
-! (c) British Crown Copyright 2008, the Met Office.
-! All rights reserved.
-! 
-! Redistribution and use in source and binary forms, with or without modification, are permitted 
-! provided that the following conditions are met:
-! 
-!     * Redistributions of source code must retain the above copyright notice, this list 
-!       of conditions and the following disclaimer.
-!     * Redistributions in binary form must reproduce the above copyright notice, this list
-!       of conditions and the following disclaimer in the documentation and/or other materials 
-!       provided with the distribution.
-!     * Neither the name of the Met Office nor the names of its contributors may be used 
-!       to endorse or promote products derived from this software without specific prior written 
-!       permission.
-! 
-! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR 
-! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND 
-! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR 
-! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 
-! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 
-! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER 
-! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT 
-! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-
-MODULE MOD_COSP_RADAR
-  USE MOD_COSP_CONSTANTS
-  USE MOD_COSP_TYPES
-  USE MOD_COSP_UTILS
-  use radar_simulator_types
-  use array_lib
-  use atmos_lib
-  use format_input
-  IMPLICIT NONE
-
-  INTERFACE
-    subroutine radar_simulator(hp,nprof,ngate,undef, &
-        hgt_matrix,hm_matrix,re_matrix,Np_matrix, &
-        p_matrix,t_matrix,rh_matrix, &
-        Ze_non,Ze_ray,g_to_vol,a_to_vol,dBZe, &
-        g_to_vol_in,g_to_vol_out)
-
-        use m_mrgrnk
-        use array_lib
-        use math_lib
-        use optics_lib
-        use radar_simulator_types
-        implicit none
-
-        ! ----- INPUTS -----  
-        type(class_param) :: hp
-
-        integer, intent(in) :: nprof,ngate
-
-        real undef
-        real*8, dimension(nprof,ngate), intent(in) :: hgt_matrix, p_matrix, &
-            t_matrix,rh_matrix
-        real*8, dimension(hp%nhclass,nprof,ngate), intent(in) :: hm_matrix
-        real*8, dimension(hp%nhclass,nprof,ngate), intent(inout) :: re_matrix
-        real*8, dimension(hp%nhclass,nprof,ngate), intent(inout) :: Np_matrix
-
-        ! ----- OUTPUTS -----
-        real*8, dimension(nprof,ngate), intent(out) :: Ze_non,Ze_ray, &
-            g_to_vol,dBZe,a_to_vol
-        ! ----- OPTIONAL -----
-        real*8, optional, dimension(nprof,ngate) :: &
-            g_to_vol_in,g_to_vol_out
-     end subroutine radar_simulator
-  END INTERFACE
-
-CONTAINS
-
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-!------------------- SUBROUTINE COSP_RADAR ------------------------
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-SUBROUTINE COSP_RADAR(gbx,sgx,sghydro,z)
-  IMPLICIT NONE
-
-  ! Arguments
-  type(cosp_gridbox),intent(inout) :: gbx  ! Gridbox info
-  type(cosp_subgrid),intent(in) :: sgx  ! Subgrid info
-  type(cosp_sghydro),intent(in) :: sghydro  ! Subgrid info for hydrometeors
-  type(cosp_sgradar),intent(inout) :: z ! Output from simulator, subgrid
-
-  ! Local variables 
-  integer :: & 
-  nsizes            ! num of discrete drop sizes
-
-  real*8, dimension(:,:), allocatable :: &
-  g_to_vol ! integrated atten due to gases, r>v (dB)
-
-  real*8, dimension(:,:), allocatable :: &
-  Ze_non, &         ! radar reflectivity withOUT attenuation (dBZ)
-  Ze_ray, &         ! Rayleigh reflectivity (dBZ)
-  h_atten_to_vol, &     ! attenuation by hydromets, radar to vol (dB)
-  g_atten_to_vol, &     ! gaseous atteunation, radar to vol (dB)
-  dBZe, &           ! effective radar reflectivity factor (dBZ)
-  hgt_matrix, &         ! height of hydrometeors (km)
-  t_matrix, &                   !temperature (k)
-  p_matrix, &                   !pressure (hPa)
-  rh_matrix                     !relative humidity (%)
-
-  real*8, dimension(:,:,:), allocatable :: &
-  hm_matrix, &          ! hydrometeor mixing ratio (g kg^-1)
-  re_matrix, &          ! effective radius (microns).   Optional. 0 ==> use Np_matrix or defaults
-  Np_matrix         ! total number concentration (kg^-1).   Optional 0==> use defaults 
-
-  integer, parameter :: one = 1
-  ! logical :: hgt_reversed
-  logical :: hgt_descending
-  integer :: pr,i,j,k,unt,ngate
-
-! ----- main program settings ------
-
-  ! Inputs to Quickbeam
-  allocate(hgt_matrix(gbx%Npoints,gbx%Nlevels),p_matrix(gbx%Npoints,gbx%Nlevels), &
-           t_matrix(gbx%Npoints,gbx%Nlevels),rh_matrix(gbx%Npoints,gbx%Nlevels))
-  allocate(hm_matrix(gbx%Nhydro,gbx%Npoints,gbx%Nlevels))
-  allocate(re_matrix(gbx%Nhydro,gbx%Npoints,gbx%Nlevels))
-  allocate(Np_matrix(gbx%Nhydro,gbx%Npoints,gbx%Nlevels))
-
-  ! Outputs from Quickbeam
-  allocate(Ze_non(gbx%Npoints,gbx%Nlevels))
-  allocate(Ze_ray(gbx%Npoints,gbx%Nlevels))
-  allocate(h_atten_to_vol(gbx%Npoints,gbx%Nlevels))
-  allocate(g_atten_to_vol(gbx%Npoints,gbx%Nlevels))
-  allocate(dBZe(gbx%Npoints,gbx%Nlevels))
-
-  ! Optional argument. It is computed and returned in the first call to
-  ! radar_simulator, and passed as input in the rest
-  allocate(g_to_vol(gbx%Npoints,gbx%Nlevels))
-
-  ! Even if there is no unit conversion, they are needed for type conversion
-  p_matrix   = gbx%p/100.0     ! From Pa to hPa
-  hgt_matrix = gbx%zlev/1000.0 ! From m to km
-  t_matrix   = gbx%T
-  rh_matrix  = gbx%q
-  re_matrix  = 0.0
-
-
-  ! set flag denoting position of radar relative to hgt_matrix orientation
-	  ngate = size(hgt_matrix,2)
-
-	  hgt_descending = hgt_matrix(1,1) > hgt_matrix(1,ngate)
-
-	  if ( &
-	     (gbx%surface_radar == 1 .and. hgt_descending) .or.  &
-	     (gbx%surface_radar == 0 .and. (.not. hgt_descending)) &
-	     ) &
-	  then
-	    gbx%hp%radar_at_layer_one = .false.
-	  else
-	    gbx%hp%radar_at_layer_one = .true.
-	  endif
-
-  ! ----- loop over subcolumns -----
-  do pr=1,sgx%Ncolumns
-
-      !  NOTE:
-      !  atmospheric profiles are the same within the same gridbox
-      !  only hydrometeor profiles will be different for each subgridbox
-
-         do i=1,gbx%Nhydro
-            hm_matrix(i,:,:) = sghydro%mr_hydro(:,pr,:,i)*1000.0 ! Units from kg/kg to g/kg
-            if (gbx%use_reff) then
-              re_matrix(i,:,:) = sghydro%Reff(:,pr,:,i)*1.e6       ! Units from m to micron
-              Np_matrix(i,:,:) = sghydro%Np(:,pr,:,i)              ! Units [#/kg]
-            endif
-         enddo
-
-      !   ----- call radar simulator -----
-      if (pr == 1) then ! Compute gaseous attenuation for all profiles
-         call radar_simulator(gbx%hp,gbx%Npoints,gbx%Nlevels,R_UNDEF, &
-           hgt_matrix,hm_matrix,re_matrix,Np_matrix, &
-           p_matrix,t_matrix,rh_matrix, &
-           Ze_non,Ze_ray,h_atten_to_vol,g_atten_to_vol,dBZe,g_to_vol_out=g_to_vol)
-      else ! Use gaseous atteunuation for pr = 1
-         call radar_simulator(gbx%hp,gbx%Npoints,gbx%Nlevels,R_UNDEF, &
-           hgt_matrix,hm_matrix,re_matrix,Np_matrix, &
-           p_matrix,t_matrix,rh_matrix, &
-           Ze_non,Ze_ray,h_atten_to_vol,g_atten_to_vol,dBZe,g_to_vol_in=g_to_vol)
-      endif
-
-      ! store caluculated dBZe values for later output/processing
-      z%Ze_tot(:,pr,:)=dBZe(:,:)
-  enddo !pr
-
-  deallocate(hgt_matrix,p_matrix,t_matrix,rh_matrix)
-  deallocate(hm_matrix,re_matrix, &
-      Ze_non,Ze_ray,h_atten_to_vol,g_atten_to_vol,dBZe)
-  deallocate(g_to_vol)
-END SUBROUTINE COSP_RADAR
-
-END MODULE MOD_COSP_RADAR
Index: /LMDZ6/trunk/libf/phylmd/cosp/mod_cosp_radar.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cosp/mod_cosp_radar.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/cosp/mod_cosp_radar.f90	(revision 5268)
@@ -0,0 +1,193 @@
+! (c) British Crown Copyright 2008, the Met Office.
+! All rights reserved.
+! 
+! Redistribution and use in source and binary forms, with or without modification, are permitted 
+! provided that the following conditions are met:
+! 
+!     * Redistributions of source code must retain the above copyright notice, this list 
+!       of conditions and the following disclaimer.
+!     * Redistributions in binary form must reproduce the above copyright notice, this list
+!       of conditions and the following disclaimer in the documentation and/or other materials 
+!       provided with the distribution.
+!     * Neither the name of the Met Office nor the names of its contributors may be used 
+!       to endorse or promote products derived from this software without specific prior written 
+!       permission.
+! 
+! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR 
+! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND 
+! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR 
+! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 
+! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 
+! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER 
+! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT 
+! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+MODULE MOD_COSP_RADAR
+  USE MOD_COSP_CONSTANTS
+  USE MOD_COSP_TYPES
+  USE MOD_COSP_UTILS
+  use radar_simulator_types
+  use array_lib
+  use atmos_lib
+  use format_input
+  IMPLICIT NONE
+
+  INTERFACE
+    subroutine radar_simulator(hp,nprof,ngate,undef, &
+        hgt_matrix,hm_matrix,re_matrix,Np_matrix, &
+        p_matrix,t_matrix,rh_matrix, &
+        Ze_non,Ze_ray,g_to_vol,a_to_vol,dBZe, &
+        g_to_vol_in,g_to_vol_out)
+
+        use m_mrgrnk
+        use array_lib
+        use math_lib
+        use optics_lib
+        use radar_simulator_types
+        implicit none
+
+        ! ----- INPUTS -----  
+        type(class_param) :: hp
+
+        integer, intent(in) :: nprof,ngate
+
+        real undef
+        real*8, dimension(nprof,ngate), intent(in) :: hgt_matrix, p_matrix, &
+            t_matrix,rh_matrix
+        real*8, dimension(hp%nhclass,nprof,ngate), intent(in) :: hm_matrix
+        real*8, dimension(hp%nhclass,nprof,ngate), intent(inout) :: re_matrix
+        real*8, dimension(hp%nhclass,nprof,ngate), intent(inout) :: Np_matrix
+
+        ! ----- OUTPUTS -----
+        real*8, dimension(nprof,ngate), intent(out) :: Ze_non,Ze_ray, &
+            g_to_vol,dBZe,a_to_vol
+        ! ----- OPTIONAL -----
+        real*8, optional, dimension(nprof,ngate) :: &
+            g_to_vol_in,g_to_vol_out
+     end subroutine radar_simulator
+  END INTERFACE
+
+CONTAINS
+
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+!------------------- SUBROUTINE COSP_RADAR ------------------------
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+SUBROUTINE COSP_RADAR(gbx,sgx,sghydro,z)
+  IMPLICIT NONE
+
+  ! Arguments
+  type(cosp_gridbox),intent(inout) :: gbx  ! Gridbox info
+  type(cosp_subgrid),intent(in) :: sgx  ! Subgrid info
+  type(cosp_sghydro),intent(in) :: sghydro  ! Subgrid info for hydrometeors
+  type(cosp_sgradar),intent(inout) :: z ! Output from simulator, subgrid
+
+  ! Local variables 
+  integer :: & 
+  nsizes            ! num of discrete drop sizes
+
+  real*8, dimension(:,:), allocatable :: &
+  g_to_vol ! integrated atten due to gases, r>v (dB)
+
+  real*8, dimension(:,:), allocatable :: &
+  Ze_non, &         ! radar reflectivity withOUT attenuation (dBZ)
+  Ze_ray, &         ! Rayleigh reflectivity (dBZ)
+  h_atten_to_vol, &     ! attenuation by hydromets, radar to vol (dB)
+  g_atten_to_vol, &     ! gaseous atteunation, radar to vol (dB)
+  dBZe, &           ! effective radar reflectivity factor (dBZ)
+  hgt_matrix, &         ! height of hydrometeors (km)
+  t_matrix, &                   !temperature (k)
+  p_matrix, &                   !pressure (hPa)
+  rh_matrix                     !relative humidity (%)
+
+  real*8, dimension(:,:,:), allocatable :: &
+  hm_matrix, &          ! hydrometeor mixing ratio (g kg^-1)
+  re_matrix, &          ! effective radius (microns).   Optional. 0 ==> use Np_matrix or defaults
+  Np_matrix         ! total number concentration (kg^-1).   Optional 0==> use defaults 
+
+  integer, parameter :: one = 1
+  ! logical :: hgt_reversed
+  logical :: hgt_descending
+  integer :: pr,i,j,k,unt,ngate
+
+! ----- main program settings ------
+
+  ! Inputs to Quickbeam
+  allocate(hgt_matrix(gbx%Npoints,gbx%Nlevels),p_matrix(gbx%Npoints,gbx%Nlevels), &
+           t_matrix(gbx%Npoints,gbx%Nlevels),rh_matrix(gbx%Npoints,gbx%Nlevels))
+  allocate(hm_matrix(gbx%Nhydro,gbx%Npoints,gbx%Nlevels))
+  allocate(re_matrix(gbx%Nhydro,gbx%Npoints,gbx%Nlevels))
+  allocate(Np_matrix(gbx%Nhydro,gbx%Npoints,gbx%Nlevels))
+
+  ! Outputs from Quickbeam
+  allocate(Ze_non(gbx%Npoints,gbx%Nlevels))
+  allocate(Ze_ray(gbx%Npoints,gbx%Nlevels))
+  allocate(h_atten_to_vol(gbx%Npoints,gbx%Nlevels))
+  allocate(g_atten_to_vol(gbx%Npoints,gbx%Nlevels))
+  allocate(dBZe(gbx%Npoints,gbx%Nlevels))
+
+  ! Optional argument. It is computed and returned in the first call to
+  ! radar_simulator, and passed as input in the rest
+  allocate(g_to_vol(gbx%Npoints,gbx%Nlevels))
+
+  ! Even if there is no unit conversion, they are needed for type conversion
+  p_matrix   = gbx%p/100.0     ! From Pa to hPa
+  hgt_matrix = gbx%zlev/1000.0 ! From m to km
+  t_matrix   = gbx%T
+  rh_matrix  = gbx%q
+  re_matrix  = 0.0
+
+
+  ! set flag denoting position of radar relative to hgt_matrix orientation
+	  ngate = size(hgt_matrix,2)
+
+	  hgt_descending = hgt_matrix(1,1) > hgt_matrix(1,ngate)
+
+	  if ( &
+	     (gbx%surface_radar == 1 .and. hgt_descending) .or.  &
+	     (gbx%surface_radar == 0 .and. (.not. hgt_descending)) &
+	     ) &
+	  then
+	    gbx%hp%radar_at_layer_one = .false.
+	  else
+	    gbx%hp%radar_at_layer_one = .true.
+	  endif
+
+  ! ----- loop over subcolumns -----
+  do pr=1,sgx%Ncolumns
+
+      !  NOTE:
+      !  atmospheric profiles are the same within the same gridbox
+      !  only hydrometeor profiles will be different for each subgridbox
+
+         do i=1,gbx%Nhydro
+            hm_matrix(i,:,:) = sghydro%mr_hydro(:,pr,:,i)*1000.0 ! Units from kg/kg to g/kg
+            if (gbx%use_reff) then
+              re_matrix(i,:,:) = sghydro%Reff(:,pr,:,i)*1.e6       ! Units from m to micron
+              Np_matrix(i,:,:) = sghydro%Np(:,pr,:,i)              ! Units [#/kg]
+            endif
+         enddo
+
+      !   ----- call radar simulator -----
+      if (pr == 1) then ! Compute gaseous attenuation for all profiles
+         call radar_simulator(gbx%hp,gbx%Npoints,gbx%Nlevels,R_UNDEF, &
+           hgt_matrix,hm_matrix,re_matrix,Np_matrix, &
+           p_matrix,t_matrix,rh_matrix, &
+           Ze_non,Ze_ray,h_atten_to_vol,g_atten_to_vol,dBZe,g_to_vol_out=g_to_vol)
+      else ! Use gaseous atteunuation for pr = 1
+         call radar_simulator(gbx%hp,gbx%Npoints,gbx%Nlevels,R_UNDEF, &
+           hgt_matrix,hm_matrix,re_matrix,Np_matrix, &
+           p_matrix,t_matrix,rh_matrix, &
+           Ze_non,Ze_ray,h_atten_to_vol,g_atten_to_vol,dBZe,g_to_vol_in=g_to_vol)
+      endif
+
+      ! store caluculated dBZe values for later output/processing
+      z%Ze_tot(:,pr,:)=dBZe(:,:)
+  enddo !pr
+
+  deallocate(hgt_matrix,p_matrix,t_matrix,rh_matrix)
+  deallocate(hm_matrix,re_matrix, &
+      Ze_non,Ze_ray,h_atten_to_vol,g_atten_to_vol,dBZe)
+  deallocate(g_to_vol)
+END SUBROUTINE COSP_RADAR
+
+END MODULE MOD_COSP_RADAR
Index: DZ6/trunk/libf/phylmd/cosp/mod_cosp_types.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cosp/mod_cosp_types.F90	(revision 5267)
+++ 	(revision )
@@ -1,1676 +1,0 @@
-! (c) British Crown Copyright 2008, the Met Office.
-! All rights reserved.
-! 
-! Redistribution and use in source and binary forms, with or without modification, are permitted 
-! provided that the following conditions are met:
-! 
-!     * Redistributions of source code must retain the above copyright notice, this list 
-!       of conditions and the following disclaimer.
-!     * Redistributions in binary form must reproduce the above copyright notice, this list
-!       of conditions and the following disclaimer in the documentation and/or other materials 
-!       provided with the distribution.
-!     * Neither the name of the Met Office nor the names of its contributors may be used 
-!       to endorse or promote products derived from this software without specific prior written 
-!       permission.
-! 
-! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR 
-! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND 
-! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR 
-! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 
-! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 
-! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER 
-! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT 
-! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-
-MODULE MOD_COSP_TYPES
-    USE MOD_COSP_CONSTANTS
-    USE MOD_COSP_UTILS
-
-    use radar_simulator_types, only: class_param, nd, mt_nd, dmax, dmin
-
-    IMPLICIT NONE
-
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-!----------------------- DERIVED TYPES ----------------------------    
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-
-  ! Configuration choices (simulators, variables)
-  TYPE COSP_CONFIG
-     logical :: Lradar_sim,Llidar_sim,Lisccp_sim,Lmodis_sim,Lmisr_sim,Lrttov_sim,Lstats,Lwrite_output, &
-                Lalbisccp,Latb532,Lboxptopisccp,Lboxtauisccp,LcfadDbze94, &
-                LcfadLidarsr532,Lclcalipso2,Lclcalipso,Lclhcalipso,Lclisccp,Lcllcalipso, &
-                Lclmcalipso,Lcltcalipso,Lcltlidarradar,Lpctisccp,Ldbze94,Ltauisccp,Lcltisccp, &
-                Ltoffset,LparasolRefl,LclMISR,Lmeantbisccp,Lmeantbclrisccp, &
-                Lclcalipsoliq,Lclcalipsoice,Lclcalipsoun, &
-                Lclcalipsotmp,Lclcalipsotmpliq,Lclcalipsotmpice,Lclcalipsotmpun, &
-	              Lcltcalipsoliq,Lcltcalipsoice,Lcltcalipsoun, &
-                Lclhcalipsoliq,Lclhcalipsoice,Lclhcalipsoun, &
-                Lclmcalipsoliq,Lclmcalipsoice,Lclmcalipsoun, &
-                Lcllcalipsoliq,Lcllcalipsoice,Lcllcalipsoun, &
-                Lfracout,LlidarBetaMol532,Ltbrttov, &
-                Lcltmodis,Lclwmodis,Lclimodis,Lclhmodis,Lclmmodis,Lcllmodis,Ltautmodis,Ltauwmodis,Ltauimodis,Ltautlogmodis, &
-                Ltauwlogmodis,Ltauilogmodis,Lreffclwmodis,Lreffclimodis,Lpctmodis,Llwpmodis, &
-                Liwpmodis,Lclmodis,Lcrimodis,Lcrlmodis,Lclopaquecalipso,Lclthincalipso, & !OPAQ (2)
-                Lclzopaquecalipso,Lclcalipsoopaque,Lclcalipsothin,Lclcalipsozopaque,    & !OPAQ (4)
-                Lclcalipsoopacity,LprofSR,Lproftemp                                       !OPAQ (1) !TIBO (2)
-
-     character(len=32) :: out_list(N_OUT_LIST)
-  END TYPE COSP_CONFIG
-  
-  ! Outputs from RTTOV
-  TYPE COSP_RTTOV
-     ! Dimensions
-     integer :: Npoints   ! Number of gridpoints
-     integer :: Nchan     ! Number of channels
-     
-     ! Brightness temperatures (Npoints,Nchan)
-     real,pointer :: tbs(:,:)
-     
-  END TYPE COSP_RTTOV
-  
-  ! Outputs from MISR simulator
-  TYPE COSP_MISR
-     ! Dimensions
-     integer :: Npoints   ! Number of gridpoints
-     integer :: Ntau      ! Number of tau intervals
-     integer :: Nlevels   ! Number of cth levels
-
-     ! --- (npoints,ntau,nlevels)
-     !  the fraction of the model grid box covered by each of the MISR cloud types
-     real,pointer :: fq_MISR(:,:,:)  
-     
-     ! --- (npoints)
-     real,pointer :: MISR_meanztop(:), MISR_cldarea(:)
-     ! --- (npoints,nlevels)
-     real,pointer :: MISR_dist_model_layertops(:,:)
-  END TYPE COSP_MISR
-
-  ! Outputs from ISCCP simulator
-  TYPE COSP_ISCCP
-     ! Dimensions
-     integer :: Npoints   ! Number of gridpoints
-     integer :: Ncolumns  ! Number of columns
-     integer :: Nlevels   ! Number of levels
-
-    
-     ! --- (npoints,tau=7,pressure=7)
-     !  the fraction of the model grid box covered by each of the 49 ISCCP D level cloud types
-     real,pointer :: fq_isccp(:,:,:)
-     
-     ! --- (npoints) ---
-     ! The fraction of model grid box columns with cloud somewhere in them.
-     ! This should equal the sum over all entries of fq_isccp
-     real,pointer :: totalcldarea(:)
-     ! mean all-sky 10.5 micron brightness temperature
-     real,pointer ::  meantb(:)
-     ! mean clear-sky 10.5 micron brightness temperature
-     real,pointer ::  meantbclr(:)
-     
-     ! The following three means are averages over the cloudy areas only.  If no
-     ! clouds are in grid box all three quantities should equal zero.
-     
-     !  mean cloud top pressure (mb) - linear averaging in cloud top pressure.
-     real,pointer :: meanptop(:)
-     !  mean optical thickness linear averaging in albedo performed.
-     real,pointer :: meantaucld(:)
-     ! mean cloud albedo. linear averaging in albedo performed 
-     real,pointer :: meanalbedocld(:)  
-     
-     !--- (npoints,ncol) ---
-     !  optical thickness in each column     
-     real,pointer :: boxtau(:,:)
-     !  cloud top pressure (mb) in each column
-     real,pointer :: boxptop(:,:)        
-  END TYPE COSP_ISCCP
-  
-  ! Summary statistics from radar
-  TYPE COSP_VGRID
-    logical :: use_vgrid ! Logical flag that indicates change of grid
-    logical :: csat_vgrid ! Flag for Cloudsat grid
-    integer :: Npoints   ! Number of sampled points
-    integer :: Ncolumns  ! Number of subgrid columns
-    integer :: Nlevels   ! Number of model levels
-    integer :: Nlvgrid   ! Number of levels of new grid
-    ! Array with dimensions (Nlvgrid)
-    real, dimension(:), pointer :: z,zl,zu ! Height and lower and upper boundaries of new levels
-    ! Array with dimensions (Nlevels)
-    real, dimension(:), pointer :: mz,mzl,mzu ! Height and lower and upper boundaries of model levels
-  END TYPE COSP_VGRID
-  
-  ! Output data from lidar code
-  TYPE COSP_SGLIDAR
-    ! Dimensions
-    integer :: Npoints   ! Number of gridpoints
-    integer :: Ncolumns  ! Number of columns
-    integer :: Nlevels   ! Number of levels
-    integer :: Nhydro    ! Number of hydrometeors    
-    integer :: Nrefl     ! Number of parasol reflectances
-    ! Arrays with dimensions (Npoints,Nlevels)
-    real,dimension(:,:),pointer :: beta_mol   ! Molecular backscatter
-    real,dimension(:,:),pointer :: temp_tot
-    ! Arrays with dimensions (Npoints,Ncolumns,Nlevels)
-    real,dimension(:,:,:),pointer :: betaperp_tot   ! Total backscattered signal
-    real,dimension(:,:,:),pointer :: beta_tot   ! Total backscattered signal
-    real,dimension(:,:,:),pointer :: tau_tot    ! Optical thickness integrated from top to level z
-    ! Arrays with dimensions (Npoints,Ncolumns,Nrefl)
-    real,dimension(:,:,:),pointer :: refl       ! parasol reflectances
-  END TYPE COSP_SGLIDAR
-  
-  ! Output data from radar code
-  TYPE COSP_SGRADAR
-    ! Dimensions
-    integer :: Npoints   ! Number of gridpoints
-    integer :: Ncolumns  ! Number of columns
-    integer :: Nlevels   ! Number of levels
-    integer :: Nhydro    ! Number of hydrometeors
-    ! output vertical levels: spaceborne radar -> from TOA to SURFACE
-    ! Arrays with dimensions (Npoints,Nlevels)
-    real,dimension(:,:),pointer :: att_gas ! 2-way attenuation by gases [dBZ]
-    ! Arrays with dimensions (Npoints,Ncolumns,Nlevels)
-    real,dimension(:,:,:),pointer :: Ze_tot ! Effective reflectivity factor [dBZ]
- 
-  END TYPE COSP_SGRADAR
-
-  
-  ! Summary statistics from radar
-  TYPE COSP_RADARSTATS
-    integer :: Npoints  ! Number of sampled points
-    integer :: Ncolumns ! Number of subgrid columns
-    integer :: Nlevels  ! Number of model levels
-    integer :: Nhydro   ! Number of hydrometeors
-    ! Array with dimensions (Npoints,dBZe_bins,Nlevels)
-    real, dimension(:,:,:), pointer :: cfad_ze ! Ze CFAD
-    ! Array with dimensions (Npoints)
-    real,dimension(:),pointer :: radar_lidar_tcc ! Radar&lidar total cloud amount, grid-box scale
-    ! Arrays with dimensions (Npoints,Nlevels)
-    real, dimension(:,:),pointer :: lidar_only_freq_cloud
-  END TYPE COSP_RADARSTATS
-
-  ! Summary statistics from lidar
-  TYPE COSP_LIDARSTATS
-    integer :: Npoints  ! Number of sampled points
-    integer :: Ncolumns ! Number of subgrid columns
-    integer :: Nlevels  ! Number of model levels
-    integer :: Nhydro   ! Number of hydrometeors
-    integer :: Nrefl    ! Number of parasol reflectances
-    
-    ! Arrays with dimensions (SR_BINS)
-    real, dimension(:),pointer :: srbval ! SR bins in cfad_sr
-    ! Arrays with dimensions (Npoints,SR_BINS,Nlevels)
-    real, dimension(:,:,:),pointer :: cfad_sr   ! CFAD of scattering ratio
-    ! Arrays with dimensions (Npoints,Nlevels)
-    real, dimension(:,:),pointer :: lidarcld    ! 3D "lidar" cloud fraction 
-    real, dimension(:,:),pointer :: proftemp    ! Temperature profiles 40 levs !TIBO 
-    ! Arrays with dimensions (Npoints,LIDAR_NCAT)
-    real, dimension(:,:),pointer :: cldlayer      ! low, mid, high-level, total lidar cloud cover
-    ! Arrays with dimensions (Npoints,LIDAR_NTYPE)                                               !OPAQ
-    real, dimension(:,:),pointer :: cldtype       ! opaque and thin cloud covers, z_opaque       !OPAQ
-    ! Arrays with dimensions (Npoints,Nlevels,Nphase)
-    real, dimension(:,:,:),pointer :: lidarcldphase    ! 3D "lidar" phase cloud fraction 
-    ! Arrays with dimensions (Npoints,Nlevels,LIDAR_NTYPE+1)                                     !OPAQ
-    real, dimension(:,:,:),pointer :: lidarcldtype     ! 3D "lidar" OPAQ type fraction + opacity !OPAQ 
-    ! Arrays with dimensions (Npoints,LIDAR_NCAT,Nphase)
-    real, dimension(:,:,:),pointer :: cldlayerphase      ! low, mid, high-level lidar phase cloud cover
-    ! Arrays with dimensions (Npoints,Ntemps,Nphase)
-    real, dimension(:,:,:),pointer :: lidarcldtmp    ! 3D "lidar" phase cloud temperature
-    ! Arrays with dimensions (Npoints,PARASOL_NREFL)
-    real, dimension(:,:),pointer :: parasolrefl   ! mean parasol reflectance
-!    ! Arrays with dimensions (Npoints,Ncolumns,Nlevels)                     !TIBO
-!    real, dimension(:,:,:),pointer :: profSR      ! subcolumns for each day !TIBO 
-    ! Arrays with dimensions (Npoints,Nlevels,Ncolumns)                     !TIBO2
-    real, dimension(:,:,:),pointer :: profSR      ! subcolumns for each day !TIBO2 
-
-  END TYPE COSP_LIDARSTATS
-
-    
-  ! Input data for simulator. Subgrid scale.
-  ! Input data from SURFACE to TOA
-  TYPE COSP_SUBGRID
-    ! Dimensions
-    integer :: Npoints   ! Number of gridpoints
-    integer :: Ncolumns  ! Number of columns
-    integer :: Nlevels   ! Number of levels
-    integer :: Nhydro    ! Number of hydrometeors
-    
-    real,dimension(:,:,:),pointer :: prec_frac  ! Subgrid precip array. Dimensions (Npoints,Ncolumns,Nlevels)
-    real,dimension(:,:,:),pointer :: frac_out  ! Subgrid cloud array. Dimensions (Npoints,Ncolumns,Nlevels)
-  END TYPE COSP_SUBGRID
-
-  ! Input data for simulator at Subgrid scale.
-  ! Used on a reduced number of points
-  TYPE COSP_SGHYDRO
-    ! Dimensions
-    integer :: Npoints   ! Number of gridpoints
-    integer :: Ncolumns  ! Number of columns
-    integer :: Nlevels   ! Number of levels
-    integer :: Nhydro    ! Number of hydrometeors
-    real,dimension(:,:,:,:),pointer :: mr_hydro ! Mixing ratio of each hydrometeor 
-                                                ! (Npoints,Ncolumns,Nlevels,Nhydro) [kg/kg]
-    real,dimension(:,:,:,:),pointer :: Reff     ! Effective Radius of each hydrometeor
-                                                ! (Reff==0 means use default size)   
-                                                ! (Npoints,Ncolumns,Nlevels,Nhydro) [m]
-    real,dimension(:,:,:,:),pointer :: Np       ! Total # concentration each hydrometeor 
-                                                ! (Optional, ignored if Reff > 0).
-                                                ! (Npoints,Ncolumns,Nlevels,Nhydro) [#/kg]
-                                                ! Np = Ntot / rho_a  = [#/m^3] / [kg/m^3) 
-                                                ! added by Roj with Quickbeam V3
-  END TYPE COSP_SGHYDRO
-  
-  ! Input data for simulator. Gridbox scale.
-  TYPE COSP_GRIDBOX
-    ! Scalars and dimensions
-    integer :: Npoints   ! Number of gridpoints
-    integer :: Nlevels   ! Number of levels
-    integer :: Ncolumns  ! Number of columns
-    integer :: Nhydro    ! Number of hydrometeors
-    integer :: Nprmts_max_hydro    ! Max number of parameters for hydrometeor size distributions
-    integer :: Naero    ! Number of aerosol species
-    integer :: Nprmts_max_aero    ! Max number of parameters for aerosol size distributions
-    integer :: Npoints_it   ! Max number of gridpoints to be processed in one iteration
-    
-    ! Time [days]
-    double precision :: time
-    double precision :: time_bnds(2)
-    
-    ! Radar ancillary info
-    real :: radar_freq, & ! Radar frequency [GHz]
-            k2 ! |K|^2, -1=use frequency dependent default
-    integer :: surface_radar, & ! surface=1, spaceborne=0
-           use_mie_tables, & ! use a precomputed loopup table? yes=1,no=0
-           use_gas_abs, & ! include gaseous absorption? yes=1,no=0
-           do_ray, & ! calculate/output Rayleigh refl=1, not=0
-           melt_lay ! melting layer model off=0, on=1
- 
-    ! structures used by radar simulator that need to be set only ONCE per radar configuration (e.g. freq, pointing direction) ... added by roj Feb 2008
-    type(class_param) ::  hp    ! structure used by radar simulator to store Ze and N scaling constants and other information
-    integer :: nsizes       ! number of discrete drop sizes (um) used to represent the distribution
-    
-    ! Lidar
-    integer :: lidar_ice_type !ice particle shape hypothesis in lidar calculations 
-                              !(ice_type=0 for spheres, ice_type=1 for non spherical particles)
-    
-    ! Radar
-    logical ::  use_precipitation_fluxes  ! True if precipitation fluxes are input to the algorithm 
-    logical ::  use_reff          ! True if Reff is to be used by radar (memory not allocated
-    
-    
-    ! Geolocation (Npoints)
-    real,dimension(:),pointer :: toffset   ! Time offset of esch point from the value in time
-    real,dimension(:),pointer :: longitude ! longitude [degrees East]
-    real,dimension(:),pointer :: latitude  ! latitude [deg North]
-    ! Gridbox information (Npoints,Nlevels)
-    real,dimension(:,:),pointer :: zlev ! Height of model levels [m]
-    real,dimension(:,:),pointer :: zlev_half ! Height at half model levels [m] (Bottom of model layer)
-    real,dimension(:,:),pointer :: dlev ! Depth of model levels  [m]
-    real,dimension(:,:),pointer :: p  ! Pressure at full model levels [Pa]
-    real,dimension(:,:),pointer :: ph ! Pressure at half model levels [Pa]
-    real,dimension(:,:),pointer :: T ! Temperature at model levels [K]
-    real,dimension(:,:),pointer :: q  ! Relative humidity to water (%)
-    real,dimension(:,:),pointer :: sh ! Specific humidity to water [kg/kg]
-    real,dimension(:,:),pointer :: dtau_s ! mean 0.67 micron optical depth of stratiform
-                                          !  clouds in each model level
-                                          !  NOTE:  this the cloud optical depth of only the
-                                          !  cloudy part of the grid box, it is not weighted
-                                          !  with the 0 cloud optical depth of the clear
-                                          !         part of the grid box
-    real,dimension(:,:),pointer :: dtau_c !  mean 0.67 micron optical depth of convective
-                                          !  clouds in each model level.  Same note applies as in dtau_s.
-    real,dimension(:,:),pointer :: dem_s  !  10.5 micron longwave emissivity of stratiform
-                                          !  clouds in each model level.  Same note applies as in dtau_s.
-    real,dimension(:,:),pointer :: dem_c  !  10.5 micron longwave emissivity of convective
-                                          !  clouds in each model level.  Same note applies as in dtau_s.
-    real,dimension(:,:),pointer :: mr_ozone !  Ozone mass mixing ratio [kg/kg]
-
-    ! Point information (Npoints)
-    real,dimension(:),pointer :: land !Landmask [0 - Ocean, 1 - Land]
-    real,dimension(:),pointer :: psfc !Surface pressure [Pa]
-    real,dimension(:),pointer :: sunlit ! (npoints) 1 for day points, 0 for nightime
-    real,dimension(:),pointer :: skt  ! Skin temperature (K)
-    real,dimension(:),pointer :: u_wind  ! eastward wind [m s-1]
-    real,dimension(:),pointer :: v_wind  ! northward wind [m s-1]
-
-    ! TOTAL and CONV cloud fraction for SCOPS
-    real,dimension(:,:),pointer :: tca ! Total cloud fraction
-    real,dimension(:,:),pointer :: cca ! Convective cloud fraction
-    ! Precipitation fluxes on model levels
-    real,dimension(:,:),pointer :: rain_ls ! large-scale precipitation flux of rain [kg/m2.s]
-    real,dimension(:,:),pointer :: rain_cv ! convective precipitation flux of rain [kg/m2.s]
-    real,dimension(:,:),pointer :: snow_ls ! large-scale precipitation flux of snow [kg/m2.s]
-    real,dimension(:,:),pointer :: snow_cv ! convective precipitation flux of snow [kg/m2.s]
-    real,dimension(:,:),pointer :: grpl_ls ! large-scale precipitation flux of graupel [kg/m2.s]
-    ! Hydrometeors concentration and distribution parameters
-!     real,dimension(:,:,:),pointer :: fr_hydro ! Fraction of the gridbox occupied by each hydrometeor (Npoints,Nlevels,Nhydro)
-    real,dimension(:,:,:),pointer :: mr_hydro ! Mixing ratio of each hydrometeor (Npoints,Nlevels,Nhydro) [kg/kg]
-    real,dimension(:,:),pointer   :: dist_prmts_hydro !Distributional parameters for hydrometeors (Nprmts_max_hydro,Nhydro)
-
-    ! Effective radius [m]. (Npoints,Nlevels,Nhydro) -- OPTIONAL, value of 0 mean use fixed default
-    real,dimension(:,:,:),pointer :: Reff
-
-    ! Total Number Concentration [#/kg]. (Npoints,Nlevels,Nhydro) -- OPTIONAL, value of 0 mean use fixed default
-    real,dimension(:,:,:),pointer :: Np ! added by Roj with Quickbeam V3
- 
-    ! Aerosols concentration and distribution parameters
-    real,dimension(:,:,:),pointer :: conc_aero ! Aerosol concentration for each species (Npoints,Nlevels,Naero)
-    integer,dimension(:),pointer :: dist_type_aero ! Particle size distribution type for each aerosol species (Naero)
-    real,dimension(:,:,:,:),pointer :: dist_prmts_aero ! Distributional parameters for aerosols 
-                                                       ! (Npoints,Nlevels,Nprmts_max_aero,Naero)
-    ! ISCCP simulator inputs
-    integer :: isccp_top_height !  1 = adjust top height using both a computed
-                                !  infrared brightness temperature and the visible
-                                !  optical depth to adjust cloud top pressure. Note
-                                !  that this calculation is most appropriate to compare
-                                !  to ISCCP data during sunlit hours.
-                                !  2 = do not adjust top height, that is cloud top
-                                !  pressure is the actual cloud top pressure
-                                !  in the model
-                                !  3 = adjust top height using only the computed
-                                !  infrared brightness temperature. Note that this
-                                !  calculation is most appropriate to compare to ISCCP
-                                !  IR only algortihm (i.e. you can compare to nighttime
-                                !  ISCCP data with this option)
-    integer :: isccp_top_height_direction ! direction for finding atmosphere pressure level
-                                 ! with interpolated temperature equal to the radiance
-                                 ! determined cloud-top temperature
-                                 ! 1 = find the *lowest* altitude (highest pressure) level
-                                 ! with interpolated temperature equal to the radiance
-                                 ! determined cloud-top temperature
-                                 ! 2 = find the *highest* altitude (lowest pressure) level
-                                 ! with interpolated temperature equal to the radiance 
-                                 ! determined cloud-top temperature
-                                 ! ONLY APPLICABLE IF top_height EQUALS 1 or 3
-                                 ! 1 = default setting, and matches all versions of 
-                                 ! ISCCP simulator with versions numbers 3.5.1 and lower
-                                 ! 2 = experimental setting  
-    integer :: isccp_overlap !  overlap type (1=max, 2=rand, 3=max/rand)
-    real :: isccp_emsfc_lw      ! 10.5 micron emissivity of surface (fraction)
-  
-    ! RTTOV inputs/options
-    integer :: plat      ! satellite platform
-    integer :: sat       ! satellite
-    integer :: inst      ! instrument
-    integer :: Nchan     ! Number of channels to be computed
-    integer, dimension(:), pointer :: Ichan   ! Channel numbers
-    real,    dimension(:), pointer :: Surfem  ! Surface emissivity
-    real    :: ZenAng ! Satellite Zenith Angles
-    real :: co2,ch4,n2o,co ! Mixing ratios of trace gases
-
-  END TYPE COSP_GRIDBOX
- 
-CONTAINS
-
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-!------------- SUBROUTINE CONSTRUCT_COSP_RTTOV -------------------
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-  SUBROUTINE CONSTRUCT_COSP_RTTOV(cfg,Npoints,Nchan,x)
-    type(cosp_config),intent(in) :: cfg ! Configuration options
-    integer,intent(in) :: Npoints  ! Number of sampled points
-    integer,intent(in) :: Nchan ! Number of channels
-    type(cosp_rttov),intent(out) :: x
-    ! Local variables
-    integer :: i,j
-    
-    ! Allocate minumum storage if simulator not used
-    if (cfg%Lrttov_sim) then
-      i = Npoints
-      j = Nchan
-    else
-      i = 1
-      j = 1
-    endif
-    x%Npoints  = i
-    x%Nchan    = j
-      
-    ! --- Allocate arrays ---
-    allocate(x%tbs(i, j))
-    ! --- Initialise to zero ---
-    x%tbs     = 0.0
-  END SUBROUTINE CONSTRUCT_COSP_RTTOV
-
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-!------------- SUBROUTINE FREE_COSP_RTTOV ------------------------
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-  SUBROUTINE FREE_COSP_RTTOV(x)
-    type(cosp_rttov),intent(inout) :: x
-    
-    ! --- Deallocate arrays ---
-    deallocate(x%tbs)
-  END SUBROUTINE FREE_COSP_RTTOV
-  
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-!------------- SUBROUTINE CONSTRUCT_COSP_MISR ------------------
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-  SUBROUTINE CONSTRUCT_COSP_MISR(cfg,Npoints,x)
-    type(cosp_config),intent(in) :: cfg ! Configuration options
-    integer,intent(in) :: Npoints   ! Number of gridpoints
-    type(cosp_misr),intent(out) :: x
-    ! Local variables
-    integer :: i,j,k
-    
-   
-    ! Allocate minumum storage if simulator not used
-    if (cfg%Lmisr_sim) then
-      i = Npoints
-      j = 7
-      k = MISR_N_CTH
-    else
-      i = 1
-      j = 1
-      k = 1
-    endif
-    
-    ! Dimensions
-    x%Npoints = i
-    x%Ntau    = j
-    x%Nlevels = k
-    
-    ! allocate space for MISR simulator outputs ...
-    allocate(x%fq_MISR(i,j,k), x%MISR_meanztop(i),x%MISR_cldarea(i), x%MISR_dist_model_layertops(i,k))
-    x%fq_MISR = 0.0
-    x%MISR_meanztop = 0.0
-    x%MISR_cldarea = 0.0
-    x%MISR_dist_model_layertops = 0.0
-    
-  END SUBROUTINE CONSTRUCT_COSP_MISR
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-!------------- SUBROUTINE FREE_COSP_MISR ------------------
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-  SUBROUTINE FREE_COSP_MISR(x)
-    type(cosp_misr),intent(inout) :: x
-    deallocate(x%fq_MISR, x%MISR_meanztop,x%MISR_cldarea, x%MISR_dist_model_layertops)
-    
-  END SUBROUTINE FREE_COSP_MISR
-
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-!------------- SUBROUTINE CONSTRUCT_COSP_ISCCP ------------------
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-  SUBROUTINE CONSTRUCT_COSP_ISCCP(cfg,Npoints,Ncolumns,Nlevels,x)
-    type(cosp_config),intent(in) :: cfg ! Configuration options
-    integer,intent(in) :: Npoints  ! Number of sampled points
-    integer,intent(in) :: Ncolumns ! Number of subgrid columns
-    integer,intent(in) :: Nlevels  ! Number of model levels
-    type(cosp_isccp),intent(out) :: x
-    ! Local variables
-    integer :: i,j,k
-    
-    ! Allocate minumum storage if simulator not used
-    if (cfg%Lisccp_sim) then
-      i = Npoints
-      j = Ncolumns
-      k = Nlevels
-    else
-      i = 1
-      j = 1
-      k = 1
-    endif
-    
-    ! Dimensions
-    x%Npoints  = i
-    x%Ncolumns = j
-    x%Nlevels  = k
-    
-    ! --- Allocate arrays ---
-    allocate(x%fq_isccp(i,7,7), x%totalcldarea(i), &
-         x%meanptop(i), x%meantaucld(i), &
-         x%meantb(i), x%meantbclr(i), &
-         x%boxtau(i,j), x%boxptop(i,j), &
-         x%meanalbedocld(i))
-    ! --- Initialise to zero ---
-    x%fq_isccp     = 0.0
-    x%totalcldarea = 0.0
-    x%meanptop     = 0.0
-    x%meantaucld   = 0.0
-    x%meantb       = 0.0
-    x%meantbclr    = 0.0
-    x%boxtau       = 0.0
-    x%boxptop      = 0.0
-    x%meanalbedocld= 0.0
-  END SUBROUTINE CONSTRUCT_COSP_ISCCP
-
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-!------------- SUBROUTINE FREE_COSP_ISCCP -----------------------
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-  SUBROUTINE FREE_COSP_ISCCP(x)
-    type(cosp_isccp),intent(inout) :: x
-    
-    deallocate(x%fq_isccp, x%totalcldarea, &
-         x%meanptop, x%meantaucld, x%meantb, x%meantbclr, &
-         x%boxtau, x%boxptop, x%meanalbedocld)
-  END SUBROUTINE FREE_COSP_ISCCP
-  
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-!------------- SUBROUTINE CONSTRUCT_COSP_VGRID ------------------
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-  SUBROUTINE CONSTRUCT_COSP_VGRID(gbx,Nlvgrid,use_vgrid,cloudsat,x)
-    type(cosp_gridbox),intent(in) :: gbx ! Gridbox information
-    integer,intent(in) :: Nlvgrid  ! Number of new levels    
-    logical,intent(in) :: use_vgrid! Logical flag that controls the output on a different grid
-    logical,intent(in) :: cloudsat ! TRUE if a CloudSat like grid (480m) is requested
-    type(cosp_vgrid),intent(out) :: x
-    
-    ! Local variables
-    integer :: i
-    real :: zstep
-    
-    x%use_vgrid  = use_vgrid
-    x%csat_vgrid = cloudsat
-    
-    ! Dimensions
-    x%Npoints  = gbx%Npoints
-    x%Ncolumns = gbx%Ncolumns
-    x%Nlevels  = gbx%Nlevels
-    
-    ! --- Allocate arrays ---
-    if (use_vgrid) then
-      x%Nlvgrid = Nlvgrid
-    else 
-      x%Nlvgrid = gbx%Nlevels
-    endif
-    allocate(x%z(x%Nlvgrid),x%zl(x%Nlvgrid),x%zu(x%Nlvgrid))
-    allocate(x%mz(x%Nlevels),x%mzl(x%Nlevels),x%mzu(x%Nlevels))
-    
-    ! --- Model vertical levels ---
-    ! Use height levels of first model gridbox
-    x%mz  = gbx%zlev(1,:)
-    x%mzl = gbx%zlev_half(1,:)
-    x%mzu(1:x%Nlevels-1) = gbx%zlev_half(1,2:x%Nlevels)
-    x%mzu(x%Nlevels) = gbx%zlev(1,x%Nlevels) + (gbx%zlev(1,x%Nlevels) - x%mzl(x%Nlevels))
-    
-    if (use_vgrid) then
-      ! --- Initialise to zero ---
-      x%z  = 0.0
-      x%zl = 0.0
-      x%zu = 0.0
-      if (cloudsat) then ! --- CloudSat grid requested ---
-         zstep = 480.0
-      else
-         ! Other grid requested. Constant vertical spacing with top at 20 km
-         zstep = 20000.0/x%Nlvgrid
-      endif
-      do i=1,x%Nlvgrid
-         x%zl(i) = (i-1)*zstep
-         x%zu(i) = i*zstep
-      enddo
-      x%z = (x%zl + x%zu)/2.0
-    else
-      x%z  = x%mz
-      x%zl = x%mzl
-      x%zu = x%mzu
-    endif
-    
-  END SUBROUTINE CONSTRUCT_COSP_VGRID
-
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-!------------------ SUBROUTINE FREE_COSP_VGRID ------------------
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-  SUBROUTINE FREE_COSP_VGRID(x)
-    type(cosp_vgrid),intent(inout) :: x
-
-    deallocate(x%z, x%zl, x%zu, x%mz, x%mzl, x%mzu)
-  END SUBROUTINE FREE_COSP_VGRID
-
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-!------------- SUBROUTINE CONSTRUCT_COSP_SGLIDAR ------------------
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-  SUBROUTINE CONSTRUCT_COSP_SGLIDAR(cfg,Npoints,Ncolumns,Nlevels,Nhydro,Nrefl,x)
-    type(cosp_config),intent(in) :: cfg ! Configuration options
-    integer,intent(in) :: Npoints  ! Number of sampled points
-    integer,intent(in) :: Ncolumns ! Number of subgrid columns
-    integer,intent(in) :: Nlevels  ! Number of model levels
-    integer,intent(in) :: Nhydro   ! Number of hydrometeors
-    integer,intent(in) :: Nrefl    ! Number of parasol reflectances ! parasol
-    type(cosp_sglidar),intent(out) :: x
-    ! Local variables
-    integer :: i,j,k,l,m
-    
-    ! Allocate minumum storage if simulator not used
-    if (cfg%Llidar_sim) then
-      i = Npoints
-      j = Ncolumns
-      k = Nlevels
-      l = Nhydro
-      m = Nrefl
-    else
-      i = 1
-      j = 1
-      k = 1
-      l = 1
-      m = 1
-    endif
-    
-    ! Dimensions
-    x%Npoints  = i
-    x%Ncolumns = j
-    x%Nlevels  = k
-    x%Nhydro   = l
-    x%Nrefl    = m
-    
-    ! --- Allocate arrays ---
-    allocate(x%beta_mol(i,k), x%beta_tot(i,j,k), &
-             x%tau_tot(i,j,k),x%refl(i,j,m), &
-             x%temp_tot(i,k),x%betaperp_tot(i,j,k))
-    ! --- Initialise to zero ---
-    x%beta_mol   = 0.0
-    x%beta_tot   = 0.0
-    x%tau_tot    = 0.0
-    x%refl       = 0.0 ! parasol
-    x%temp_tot   	= 0.0
-    x%betaperp_tot 	= 0.0	
-  END SUBROUTINE CONSTRUCT_COSP_SGLIDAR
-
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-!------------------ SUBROUTINE FREE_COSP_SGLIDAR ------------------
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-  SUBROUTINE FREE_COSP_SGLIDAR(x)
-    type(cosp_sglidar),intent(inout) :: x
-
-    deallocate(x%beta_mol, x%beta_tot, x%tau_tot, x%refl, &
-               x%temp_tot, x%betaperp_tot)
-
-  END SUBROUTINE FREE_COSP_SGLIDAR
-
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-!------------- SUBROUTINE CONSTRUCT_COSP_SGRADAR ------------------
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-  SUBROUTINE CONSTRUCT_COSP_SGRADAR(cfg,Npoints,Ncolumns,Nlevels,Nhydro,x)
-    type(cosp_config),intent(in) :: cfg ! Configuration options
-    integer,intent(in) :: Npoints  ! Number of sampled points
-    integer,intent(in) :: Ncolumns ! Number of subgrid columns
-    integer,intent(in) :: Nlevels  ! Number of model levels
-    integer,intent(in) :: Nhydro   ! Number of hydrometeors
-    type(cosp_sgradar),intent(out) :: x
-    ! Local variables
-    integer :: i,j,k,l
-    
-    if (cfg%Lradar_sim) then
-      i = Npoints
-      j = Ncolumns
-      k = Nlevels
-      l = Nhydro
-    else ! Allocate minumum storage if simulator not used
-      i = 1
-      j = 1
-      k = 1
-      l = 1
-    endif
-    
-    ! Dimensions
-    x%Npoints  = i
-    x%Ncolumns = j
-    x%Nlevels  = k
-    x%Nhydro   = l
-    
-    ! --- Allocate arrays ---
-    allocate(x%att_gas(i,k), x%Ze_tot(i,j,k))
-    ! --- Initialise to zero ---
-    x%att_gas   = 0.0
-    x%Ze_tot    = 0.0
-    ! The following line give a compilation error on the Met Office NEC
-!     call zero_real(x%Z_hydro, x%att_hydro)
-!     f90: error(666): cosp_types.f90, line nnn:
-!                                        Actual argument corresponding to dummy
-!                                        argument of ELEMENTAL subroutine
-!                                        "zero_real" with INTENET(OUT) attribute
-!                                        is not array.
-  END SUBROUTINE CONSTRUCT_COSP_SGRADAR
-
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-!------------------ SUBROUTINE FREE_COSP_SGRADAR ----------------
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-  SUBROUTINE FREE_COSP_SGRADAR(x)
-    type(cosp_sgradar),intent(inout) :: x
-
-    deallocate(x%att_gas, x%Ze_tot)
-  END SUBROUTINE FREE_COSP_SGRADAR
-
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-!----------- SUBROUTINE CONSTRUCT_COSP_RADARSTATS ---------------
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-  SUBROUTINE CONSTRUCT_COSP_RADARSTATS(cfg,Npoints,Ncolumns,Nlevels,Nhydro,x)
-    type(cosp_config),intent(in) :: cfg ! Configuration options
-    integer,intent(in) :: Npoints  ! Number of sampled points
-    integer,intent(in) :: Ncolumns ! Number of subgrid columns
-    integer,intent(in) :: Nlevels  ! Number of model levels
-    integer,intent(in) :: Nhydro   ! Number of hydrometeors
-    type(cosp_radarstats),intent(out) :: x    
-    ! Local variables
-    integer :: i,j,k,l
-    
-    ! Allocate minumum storage if simulator not used
-    if (cfg%Lradar_sim) then
-      i = Npoints
-      j = Ncolumns
-      k = Nlevels
-      l = Nhydro
-    else
-      i = 1
-      j = 1
-      k = 1
-      l = 1
-    endif
-    
-    ! Dimensions
-    x%Npoints  = i
-    x%Ncolumns = j
-    x%Nlevels  = k
-    x%Nhydro   = l
-    
-    ! --- Allocate arrays ---
-    allocate(x%cfad_ze(i,DBZE_BINS,k),x%lidar_only_freq_cloud(i,k))
-    allocate(x%radar_lidar_tcc(i))
-    ! --- Initialise to zero ---
-    x%cfad_ze = 0.0
-    x%lidar_only_freq_cloud = 0.0
-    x%radar_lidar_tcc = 0.0
-  END SUBROUTINE CONSTRUCT_COSP_RADARSTATS
-
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-!------------------ SUBROUTINE FREE_COSP_RADARSTATS -------------
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-  SUBROUTINE FREE_COSP_RADARSTATS(x)
-    type(cosp_radarstats),intent(inout) :: x
-
-    deallocate(x%cfad_ze,x%lidar_only_freq_cloud,x%radar_lidar_tcc)
-  END SUBROUTINE FREE_COSP_RADARSTATS
-
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-!----------- SUBROUTINE CONSTRUCT_COSP_LIDARSTATS ---------------
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-  SUBROUTINE CONSTRUCT_COSP_LIDARSTATS(cfg,Npoints,Ncolumns,Nlevels,Nhydro,Nrefl,x)
-    type(cosp_config),intent(in) :: cfg ! Configuration options
-    integer,intent(in) :: Npoints  ! Number of sampled points
-    integer,intent(in) :: Ncolumns ! Number of subgrid columns
-    integer,intent(in) :: Nlevels  ! Number of model levels
-    integer,intent(in) :: Nhydro   ! Number of hydrometeors
-    integer,intent(in) :: Nrefl    ! Number of parasol reflectance
-    type(cosp_lidarstats),intent(out) :: x
-    ! Local variables
-    integer :: i,j,k,l,m
-    
-    ! Allocate minumum storage if simulator not used
-    if (cfg%Llidar_sim) then
-      i = Npoints
-      j = Ncolumns
-      k = Nlevels
-      l = Nhydro
-      m = Nrefl
-    else
-      i = 1
-      j = 1
-      k = 1
-      l = 1
-      m = 1
-    endif
-    
-    ! Dimensions
-    x%Npoints  = i
-    x%Ncolumns = j
-    x%Nlevels  = k
-    x%Nhydro   = l
-    x%Nrefl    = m
-    
-    ! --- Allocate arrays ---
-    allocate(x%srbval(SR_BINS),x%cfad_sr(i,SR_BINS,k), &
-             x%lidarcld(i,k), x%cldlayer(i,LIDAR_NCAT), x%parasolrefl(i,m))
-    allocate(x%lidarcldphase(i,k,6),x%lidarcldtmp(i,LIDAR_NTEMP,5),&
-             x%cldlayerphase(i,LIDAR_NCAT,6))
-    allocate(x%lidarcldtype(i,k,LIDAR_NTYPE+1),x%cldtype(i,LIDAR_NTYPE)) !OPAQ
-!    allocate(x%profSR(i,j,k),x%proftemp(i,k))                            !TIBO
-    allocate(x%profSR(i,k,j),x%proftemp(i,k))                            !TIBO2
-    ! --- Initialise to zero ---
-    x%srbval    = 0.0
-    x%cfad_sr   = 0.0
-    x%lidarcld  = 0.0
-    x%cldlayer  = 0.0
-    x%parasolrefl  = 0.0
-    x%lidarcldphase  = 0.0
-    x%cldlayerphase  = 0.0
-    x%lidarcldtmp  = 0.0
-    x%lidarcldtype  = 0.0 !OPAQ
-    x%cldtype  = 0.0      !OPAQ
-    x%profSR   = 0.0      !TIBO
-    x%proftemp = 0.0      !TIBO
-
-   END SUBROUTINE CONSTRUCT_COSP_LIDARSTATS
-
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-!------------------ SUBROUTINE FREE_COSP_LIDARSTATS -------------
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-  SUBROUTINE FREE_COSP_LIDARSTATS(x)
-    type(cosp_lidarstats),intent(inout) :: x
-
-    deallocate(x%srbval, x%cfad_sr, x%lidarcld, x%cldlayer, x%parasolrefl)
-    deallocate(x%cldlayerphase, x%lidarcldtmp, x%lidarcldphase)
-    deallocate(x%lidarcldtype, x%cldtype) !OPAQ
-    deallocate(x%profSR, x%proftemp)      !TIBO
-  END SUBROUTINE FREE_COSP_LIDARSTATS
-
-
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-!------------- SUBROUTINE CONSTRUCT_COSP_SUBGRID ------------------
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-  SUBROUTINE CONSTRUCT_COSP_SUBGRID(Npoints,Ncolumns,Nlevels,y)
-    integer,intent(in) :: Npoints, & ! Number of gridpoints
-                                        Ncolumns, & ! Number of columns
-                                        Nlevels   ! Number of levels
-    type(cosp_subgrid),intent(out) :: y
-    
-    ! Dimensions
-    y%Npoints  = Npoints
-    y%Ncolumns = Ncolumns
-    y%Nlevels  = Nlevels
-
-    ! --- Allocate arrays ---
-    allocate(y%frac_out(Npoints,Ncolumns,Nlevels))
-    if (Ncolumns > 1) then
-      allocate(y%prec_frac(Npoints,Ncolumns,Nlevels))
-    else ! CRM mode, not needed
-      allocate(y%prec_frac(1,1,1))
-    endif
-    ! --- Initialise to zero ---
-    y%prec_frac = 0.0
-    y%frac_out  = 0.0
-    ! The following line gives a compilation error on the Met Office NEC
-!     call zero_real(y%mr_hydro)
-!     f90: error(666): cosp_types.f90, line nnn:
-!                                        Actual argument corresponding to dummy
-!                                        argument of ELEMENTAL subroutine
-!                                        "zero_real" with INTENET(OUT) attribute
-!                                        is not array.
-
-  END SUBROUTINE CONSTRUCT_COSP_SUBGRID
-
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-!------------- SUBROUTINE FREE_COSP_SUBGRID -----------------------
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-  SUBROUTINE FREE_COSP_SUBGRID(y)
-    type(cosp_subgrid),intent(inout) :: y
-    
-    ! --- Deallocate arrays ---
-    deallocate(y%prec_frac, y%frac_out)
-        
-  END SUBROUTINE FREE_COSP_SUBGRID
-
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-!------------- SUBROUTINE CONSTRUCT_COSP_SGHYDRO -----------------
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-  SUBROUTINE CONSTRUCT_COSP_SGHYDRO(Npoints,Ncolumns,Nlevels,Nhydro,y)
-    integer,intent(in) :: Npoints, & ! Number of gridpoints
-                                        Ncolumns, & ! Number of columns
-                                        Nhydro, & ! Number of hydrometeors
-                                        Nlevels   ! Number of levels
-    type(cosp_sghydro),intent(out) :: y
-    
-    ! Dimensions
-    y%Npoints  = Npoints
-    y%Ncolumns = Ncolumns
-    y%Nlevels  = Nlevels
-    y%Nhydro   = Nhydro
-
-    ! --- Allocate arrays ---
-    allocate(y%mr_hydro(Npoints,Ncolumns,Nlevels,Nhydro), &
-             y%Reff(Npoints,Ncolumns,Nlevels,Nhydro), &
-             y%Np(Npoints,Ncolumns,Nlevels,Nhydro)) ! added by roj with Quickbeam V3
-             
-    ! --- Initialise to zero ---
-    y%mr_hydro = 0.0
-    y%Reff     = 0.0
-    y%Np       = 0.0                    ! added by roj with Quickbeam V3
-
-  END SUBROUTINE CONSTRUCT_COSP_SGHYDRO
-
- !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-!------------- SUBROUTINE FREE_COSP_SGHYDRO -----------------------
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-  SUBROUTINE FREE_COSP_SGHYDRO(y)
-    type(cosp_sghydro),intent(inout) :: y
-    
-    ! --- Deallocate arrays ---
-    deallocate(y%mr_hydro, y%Reff, y%Np)        ! added by Roj with Quickbeam V3
-        
-  END SUBROUTINE FREE_COSP_SGHYDRO
- 
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-!------------- SUBROUTINE CONSTRUCT_COSP_GRIDBOX ------------------
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-  SUBROUTINE CONSTRUCT_COSP_GRIDBOX(time,time_bnds,radar_freq,surface_radar,use_mie_tables,use_gas_abs,do_ray,melt_lay,k2, &
-                                   Npoints,Nlevels,Ncolumns,Nhydro,Nprmts_max_hydro,Naero,Nprmts_max_aero,Npoints_it, &
-                                   lidar_ice_type,isccp_top_height,isccp_top_height_direction,isccp_overlap,isccp_emsfc_lw, &
-                                   use_precipitation_fluxes,use_reff, &
-                                   ! RTTOV inputs
-                                   Plat,Sat,Inst,Nchan,ZenAng,Ichan,SurfEm,co2,ch4,n2o,co,&
-                                   y,load_LUT)
-    double precision,intent(in) :: time ! Time since start of run [days] 
-    double precision,intent(in) :: time_bnds(2) ! Time boundaries
-    real,intent(in)    :: radar_freq, & ! Radar frequency [GHz]
-                          k2            ! |K|^2, -1=use frequency dependent default
-    integer,intent(in) :: &
-        surface_radar, &  ! surface=1,spaceborne=0
-        use_mie_tables, & ! use a precomputed lookup table? yes=1,no=0,2=use first column everywhere
-        use_gas_abs, &    ! include gaseous absorption? yes=1,no=0
-        do_ray, &         ! calculate/output Rayleigh refl=1, not=0
-        melt_lay          ! melting layer model off=0, on=1
-    integer,intent(in) :: Npoints   ! Number of gridpoints
-    integer,intent(in) :: Nlevels   ! Number of levels
-    integer,intent(in) :: Ncolumns  ! Number of columns
-    integer,intent(in) :: Nhydro    ! Number of hydrometeors
-    integer,intent(in) :: Nprmts_max_hydro    ! Max number of parameters for hydrometeor size distributions
-    integer,intent(in) :: Naero    ! Number of aerosol species
-    integer,intent(in) :: Nprmts_max_aero    ! Max number of parameters for aerosol size distributions
-    integer,intent(in) :: Npoints_it   ! Number of gridpoints processed in one iteration
-    integer,intent(in) :: lidar_ice_type ! Ice particle shape in lidar calculations (0=ice-spheres ; 1=ice-non-spherical)
-    integer,intent(in) :: isccp_top_height
-    integer,intent(in) :: isccp_top_height_direction
-    integer,intent(in) :: isccp_overlap
-    real,intent(in)    :: isccp_emsfc_lw
-    logical,intent(in) :: use_precipitation_fluxes,use_reff
-    integer,intent(in) :: Plat
-    integer,intent(in) :: Sat
-    integer,intent(in) :: Inst
-    integer,intent(in) :: Nchan
-    integer,intent(in) :: Ichan(Nchan)
-    real,intent(in)    :: SurfEm(Nchan)
-    real,intent(in)    :: ZenAng
-    real,intent(in)    :: co2,ch4,n2o,co
-    type(cosp_gridbox),intent(out) :: y
-    logical,intent(in),optional :: load_LUT
-
-
-    ! local variables
-    character*240 :: LUT_file_name
-    logical :: local_load_LUT
-
-    if (present(load_LUT)) then
-      local_load_LUT = load_LUT
-    else
-      local_load_LUT = RADAR_SIM_LOAD_scale_LUTs_flag
-    endif
-
-    ! Dimensions and scalars
-    y%radar_freq       = radar_freq
-    y%surface_radar    = surface_radar
-    y%use_mie_tables   = use_mie_tables
-    y%use_gas_abs      = use_gas_abs
-    y%do_ray           = do_ray
-    y%melt_lay         = melt_lay
-    y%k2               = k2
-    y%Npoints          = Npoints
-    y%Nlevels          = Nlevels
-    y%Ncolumns         = Ncolumns
-    y%Nhydro           = Nhydro
-    y%Nprmts_max_hydro = Nprmts_max_hydro
-    y%Naero            = Naero
-    y%Nprmts_max_aero  = Nprmts_max_aero
-    y%Npoints_it       = Npoints_it
-    y%lidar_ice_type   = lidar_ice_type
-    y%isccp_top_height = isccp_top_height
-    y%isccp_top_height_direction = isccp_top_height_direction
-    y%isccp_overlap    = isccp_overlap
-    y%isccp_emsfc_lw   = isccp_emsfc_lw
-    y%use_precipitation_fluxes = use_precipitation_fluxes
-    y%use_reff = use_reff
-    
-    y%time      = time
-    y%time_bnds = time_bnds
-    
-    ! RTTOV parameters
-    y%Plat   = Plat
-    y%Sat    = Sat
-    y%Inst   = Inst
-    y%Nchan  = Nchan
-    y%ZenAng = ZenAng
-    y%co2    = co2
-    y%ch4    = ch4
-    y%n2o    = n2o
-    y%co     = co
-
-    ! --- Allocate arrays ---
-    ! Gridbox information (Npoints,Nlevels)
-    allocate(y%zlev(Npoints,Nlevels), y%zlev_half(Npoints,Nlevels), y%dlev(Npoints,Nlevels), &
-             y%p(Npoints,Nlevels), y%ph(Npoints,Nlevels), y%T(Npoints,Nlevels), &
-             y%q(Npoints,Nlevels), y%sh(Npoints,Nlevels), &
-             y%dtau_s(Npoints,Nlevels), y%dtau_c(Npoints,Nlevels), &
-             y%dem_s(Npoints,Nlevels), y%dem_c(Npoints,Nlevels), &
-             y%tca(Npoints,Nlevels), y%cca(Npoints,Nlevels), &
-             y%rain_ls(Npoints,Nlevels), y%rain_cv(Npoints,Nlevels), y%grpl_ls(Npoints,Nlevels), &
-             y%snow_ls(Npoints,Nlevels), y%snow_cv(Npoints,Nlevels),y%mr_ozone(Npoints,Nlevels))
-             
-             
-    ! Surface information and geolocation (Npoints)
-    allocate(y%toffset(Npoints), y%longitude(Npoints),y%latitude(Npoints),y%psfc(Npoints), y%land(Npoints), &
-             y%sunlit(Npoints),y%skt(Npoints),y%u_wind(Npoints),y%v_wind(Npoints))
-    ! Hydrometeors concentration and distribution parameters
-    allocate(y%mr_hydro(Npoints,Nlevels,Nhydro), &
-             y%dist_prmts_hydro(Nprmts_max_hydro,Nhydro), &
-             y%Reff(Npoints,Nlevels,Nhydro), &
-             y%Np(Npoints,Nlevels,Nhydro))      ! added by Roj with Quickbeam V3
-    ! Aerosols concentration and distribution parameters
-    allocate(y%conc_aero(Npoints,Nlevels,Naero), y%dist_type_aero(Naero), &
-             y%dist_prmts_aero(Npoints,Nlevels,Nprmts_max_aero,Naero))
-    
-    ! RTTOV channels and sfc. emissivity
-    allocate(y%ichan(Nchan),y%surfem(Nchan))
-    
-    ! RTTOV parameters
-    y%ichan   =  ichan
-    y%surfem  =  surfem
-    
-    ! --- Initialise to zero ---
-    y%zlev      = 0.0
-    y%zlev_half = 0.0
-    y%dlev      = 0.0
-    y%p         = 0.0
-    y%ph        = 0.0
-    y%T         = 0.0
-    y%q         = 0.0
-    y%sh        = 0.0
-    y%dtau_s    = 0.0
-    y%dtau_c    = 0.0
-    y%dem_s     = 0.0
-    y%dem_c     = 0.0
-    y%tca       = 0.0
-    y%cca       = 0.0
-    y%rain_ls   = 0.0
-    y%rain_cv   = 0.0
-    y%grpl_ls   = 0.0
-    y%snow_ls   = 0.0
-    y%snow_cv   = 0.0
-    y%Reff      = 0.0
-    y%Np        = 0.0 ! added by Roj with Quickbeam V3
-    y%mr_ozone  = 0.0
-    y%u_wind    = 0.0
-    y%v_wind    = 0.0
-
-    
-    ! (Npoints)
-    y%toffset = 0.0
-    y%longitude = 0.0
-    y%latitude = 0.0
-    y%psfc = 0.0
-    y%land = 0.0
-    y%sunlit = 0.0
-    y%skt = 0.0
-    ! (Npoints,Nlevels,Nhydro)
-!     y%fr_hydro = 0.0
-    y%mr_hydro = 0.0
-    ! Others
-    y%dist_prmts_hydro = 0.0 ! (Nprmts_max_hydro,Nhydro)
-    y%conc_aero        = 0.0 ! (Npoints,Nlevels,Naero)
-    y%dist_type_aero   = 0   ! (Naero)
-    y%dist_prmts_aero  = 0.0 ! (Npoints,Nlevels,Nprmts_max_aero,Naero)
-
-
-    ! NOTE: This location use to contain initialization of some radar simulator variables
-    ! this initialization (including use of the variable "dist_prmts_hydro" - now obselete) 
-    ! has been unified in the quickbeam v3 subroutine "radar_simulator_init".   Roj, June 2010
-
-    ! --- Initialize the distributional parameters for hydrometeors in radar simulator
-
-!    write(*,*) 'RADAR_SIM microphysics scheme is set to: ', &
-!            trim(RADAR_SIM_MICROPHYSICS_SCHEME_NAME)
-
-
-    if(y%Nhydro.ne.N_HYDRO) then
-
-        write(*,*) 'Number of hydrometeor input to subroutine', &
-               ' CONSTRUCT_COSP_GRIDBOX does not match value', &
-               ' specified in cosp_constants.f90!'
-        write(*,*) 
-    endif
-
-    ! NOTE: SAVE_scale_LUTs_flag is hard codded as .false. here 
-    ! so that radar simulator will NOT update LUT each time it 
-    ! is called, but rather will update when "Free_COSP_GRIDBOX" is called!
-    ! Roj, June 2010
-
-    LUT_file_name = trim(RADAR_SIM_LUT_DIRECTORY) // &
-                trim(RADAR_SIM_MICROPHYSICS_SCHEME_NAME)
-
-    call radar_simulator_init(radar_freq,k2, &
-                      use_gas_abs,do_ray,R_UNDEF, &
-                      y%Nhydro, &
-                      HCLASS_TYPE,HCLASS_PHASE, &
-                      HCLASS_DMIN,HCLASS_DMAX, &
-                      HCLASS_APM,HCLASS_BPM,HCLASS_RHO, &
-                      HCLASS_P1,HCLASS_P2,HCLASS_P3, &
-                      local_load_LUT,    &
-                      .false., &
-                      LUT_file_name, &
-                      y%hp)
-
-END SUBROUTINE CONSTRUCT_COSP_GRIDBOX
-
-
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-!------------- SUBROUTINE FREE_COSP_GRIDBOX -----------------------
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-  SUBROUTINE FREE_COSP_GRIDBOX(y,dglobal,save_LUT)
-
-    use scale_LUTs_io
-
-    type(cosp_gridbox),intent(inout) :: y
-    logical,intent(in),optional :: dglobal
-    logical,intent(in),optional :: save_LUT
-
-    logical :: local_save_LUT
-
-    if (present(save_LUT)) then
-      local_save_LUT = save_LUT
-    else
-      local_save_LUT = RADAR_SIM_UPDATE_scale_LUTs_flag
-    endif
-
-    ! save any updates to radar simulator LUT
-    if (local_save_LUT) call save_scale_LUTs(y%hp)
-
-    deallocate(y%zlev, y%zlev_half, y%dlev, y%p, y%ph, y%T, y%q, &
-               y%sh, y%dtau_s, y%dtau_c, y%dem_s, y%dem_c, &
-               y%toffset, y%longitude,y%latitude,y%psfc, y%land, y%tca, y%cca, &
-               y%mr_hydro, y%dist_prmts_hydro, &
-               y%conc_aero, y%dist_type_aero, y%dist_prmts_aero, &
-               y%rain_ls, y%rain_cv, y%snow_ls, y%snow_cv, y%grpl_ls, &
-               y%sunlit, y%skt, y%Reff,y%Np, &
-               y%ichan,y%surfem, &
-               y%mr_ozone,y%u_wind,y%v_wind)
-
-  END SUBROUTINE FREE_COSP_GRIDBOX
-
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-!------------- SUBROUTINE COSP_GRIDBOX_CPHP ----------------------
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-SUBROUTINE COSP_GRIDBOX_CPHP(x,y)
-    type(cosp_gridbox),intent(in) :: x
-    type(cosp_gridbox),intent(inout) :: y
-
-    integer :: i,j,k,sz(3)
-    double precision :: tny
-
-    tny = tiny(tny)
-    y%hp%p1      = x%hp%p1
-    y%hp%p2      = x%hp%p2
-    y%hp%p3      = x%hp%p3
-    y%hp%dmin    = x%hp%dmin
-    y%hp%dmax    = x%hp%dmax
-    y%hp%apm     = x%hp%apm
-    y%hp%bpm     = x%hp%bpm
-    y%hp%rho     = x%hp%rho
-    y%hp%dtype   = x%hp%dtype
-    y%hp%col     = x%hp%col
-    y%hp%cp      = x%hp%cp
-    y%hp%phase   = x%hp%phase
-
-    y%hp%fc      = x%hp%fc
-    y%hp%rho_eff = x%hp%rho_eff
-    ! y%hp%ifc     = x%hp%ifc       obsolete, Roj, June 2010
-    ! y%hp%idd     = x%hp%idd
-    sz = shape(x%hp%Z_scale_flag)
-    do k=1,sz(3)
-      do j=1,sz(2)
-        do i=1,sz(1)
-           if (x%hp%N_scale_flag(i,k))   y%hp%N_scale_flag(i,k)      = .true.
-           if (x%hp%Z_scale_flag(i,j,k)) y%hp%Z_scale_flag(i,j,k)    = .true.
-           if (abs(x%hp%Ze_scaled(i,j,k)) > tny) y%hp%Ze_scaled(i,j,k) = x%hp%Ze_scaled(i,j,k)
-           if (abs(x%hp%Zr_scaled(i,j,k)) > tny) y%hp%Zr_scaled(i,j,k) = x%hp%Zr_scaled(i,j,k)
-           if (abs(x%hp%kr_scaled(i,j,k)) > tny) y%hp%kr_scaled(i,j,k) = x%hp%kr_scaled(i,j,k)
-        enddo
-      enddo
-    enddo
-    
-END SUBROUTINE COSP_GRIDBOX_CPHP
-
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-!------------- SUBROUTINE COSP_GRIDBOX_CPSECTION -----------------
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-SUBROUTINE COSP_GRIDBOX_CPSECTION(ix,iy,x,y)
-    integer,intent(in),dimension(2) :: ix,iy
-    type(cosp_gridbox),intent(in) :: x
-    type(cosp_gridbox),intent(inout) :: y
-    
-    ! --- Copy arrays without Npoints as dimension ---
-    y%dist_prmts_hydro = x%dist_prmts_hydro
-    y%dist_type_aero   = x%dist_type_aero
-  
-    
-!     call cosp_gridbox_cphp(x,y)    
-    
-    ! 1D
-    y%longitude(iy(1):iy(2))  = x%longitude(ix(1):ix(2))
-    y%latitude(iy(1):iy(2))   = x%latitude(ix(1):ix(2))
-    y%psfc(iy(1):iy(2))       = x%psfc(ix(1):ix(2))
-    y%land(iy(1):iy(2))       = x%land(ix(1):ix(2))
-    y%sunlit(iy(1):iy(2))     = x%sunlit(ix(1):ix(2))
-    y%skt(iy(1):iy(2))        = x%skt(ix(1):ix(2))
-    y%u_wind(iy(1):iy(2))     = x%u_wind(ix(1):ix(2))
-    y%v_wind(iy(1):iy(2))     = x%v_wind(ix(1):ix(2))
-    ! 2D
-    y%zlev(iy(1):iy(2),:)      = x%zlev(ix(1):ix(2),:)
-    y%zlev_half(iy(1):iy(2),:) = x%zlev_half(ix(1):ix(2),:)
-    y%dlev(iy(1):iy(2),:)      = x%dlev(ix(1):ix(2),:)
-    y%p(iy(1):iy(2),:)         = x%p(ix(1):ix(2),:)
-    y%ph(iy(1):iy(2),:)        = x%ph(ix(1):ix(2),:)
-    y%T(iy(1):iy(2),:)         = x%T(ix(1):ix(2),:)
-    y%q(iy(1):iy(2),:)         = x%q(ix(1):ix(2),:)
-    y%sh(iy(1):iy(2),:)        = x%sh(ix(1):ix(2),:)
-    y%dtau_s(iy(1):iy(2),:)    = x%dtau_s(ix(1):ix(2),:)
-    y%dtau_c(iy(1):iy(2),:)    = x%dtau_c(ix(1):ix(2),:)
-    y%dem_s(iy(1):iy(2),:)     = x%dem_s(ix(1):ix(2),:)
-    y%dem_c(iy(1):iy(2),:)     = x%dem_c(ix(1):ix(2),:)
-    y%tca(iy(1):iy(2),:)       = x%tca(ix(1):ix(2),:)
-    y%cca(iy(1):iy(2),:)       = x%cca(ix(1):ix(2),:)
-    y%rain_ls(iy(1):iy(2),:)   = x%rain_ls(ix(1):ix(2),:)
-    y%rain_cv(iy(1):iy(2),:)   = x%rain_cv(ix(1):ix(2),:)
-    y%grpl_ls(iy(1):iy(2),:)   = x%grpl_ls(ix(1):ix(2),:)
-    y%snow_ls(iy(1):iy(2),:)   = x%snow_ls(ix(1):ix(2),:)
-    y%snow_cv(iy(1):iy(2),:)   = x%snow_cv(ix(1):ix(2),:)
-    y%mr_ozone(iy(1):iy(2),:)  = x%mr_ozone(ix(1):ix(2),:)
-    ! 3D
-    y%Reff(iy(1):iy(2),:,:)      = x%Reff(ix(1):ix(2),:,:)
-    y%Np(iy(1):iy(2),:,:)      = x%Np(ix(1):ix(2),:,:)   ! added by Roj with Quickbeam V3
-    y%conc_aero(iy(1):iy(2),:,:) = x%conc_aero(ix(1):ix(2),:,:)
-    y%mr_hydro(iy(1):iy(2),:,:)  = x%mr_hydro(ix(1):ix(2),:,:)
-    ! 4D
-    y%dist_prmts_aero(iy(1):iy(2),:,:,:) = x%dist_prmts_aero(ix(1):ix(2),:,:,:)
-
-END SUBROUTINE COSP_GRIDBOX_CPSECTION
- 
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-!------------- SUBROUTINE COSP_SUBGRID_CPSECTION -----------------
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-SUBROUTINE COSP_SUBGRID_CPSECTION(ix,iy,x,y)
-    integer,intent(in),dimension(2) :: ix,iy
-    type(cosp_subgrid),intent(in) :: x
-    type(cosp_subgrid),intent(inout) :: y
-    
-    y%prec_frac(iy(1):iy(2),:,:)  = x%prec_frac(ix(1):ix(2),:,:)
-    y%frac_out(iy(1):iy(2),:,:)   = x%frac_out(ix(1):ix(2),:,:)
-END SUBROUTINE COSP_SUBGRID_CPSECTION
-
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-!------------- SUBROUTINE COSP_SGRADAR_CPSECTION -----------------
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-SUBROUTINE COSP_SGRADAR_CPSECTION(ix,iy,x,y)
-    integer,intent(in),dimension(2) :: ix,iy
-    type(cosp_sgradar),intent(in) :: x
-    type(cosp_sgradar),intent(inout) :: y
-    
-    y%att_gas(iy(1):iy(2),:)  = x%att_gas(ix(1):ix(2),:)
-    y%Ze_tot(iy(1):iy(2),:,:) = x%Ze_tot(ix(1):ix(2),:,:)
-END SUBROUTINE COSP_SGRADAR_CPSECTION
-
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-!------------- SUBROUTINE COSP_SGLIDAR_CPSECTION -----------------
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-SUBROUTINE COSP_SGLIDAR_CPSECTION(ix,iy,x,y)
-    integer,intent(in),dimension(2) :: ix,iy
-    type(cosp_sglidar),intent(in) :: x
-    type(cosp_sglidar),intent(inout) :: y
-
-    y%temp_tot(iy(1):iy(2),:)       = x%temp_tot(ix(1):ix(2),:)
-    y%betaperp_tot(iy(1):iy(2),:,:) = x%betaperp_tot(ix(1):ix(2),:,:)
-    y%beta_mol(iy(1):iy(2),:)       = x%beta_mol(ix(1):ix(2),:)
-    y%beta_tot(iy(1):iy(2),:,:)     = x%beta_tot(ix(1):ix(2),:,:)
-    y%tau_tot(iy(1):iy(2),:,:)      = x%tau_tot(ix(1):ix(2),:,:)
-    y%refl(iy(1):iy(2),:,:)         = x%refl(ix(1):ix(2),:,:)
-END SUBROUTINE COSP_SGLIDAR_CPSECTION
-
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-!------------- SUBROUTINE COSP_ISCCP_CPSECTION -----------------
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-SUBROUTINE COSP_ISCCP_CPSECTION(ix,iy,x,y)
-    integer,intent(in),dimension(2) :: ix,iy
-    type(cosp_isccp),intent(in) :: x
-    type(cosp_isccp),intent(inout) :: y
-
-    y%fq_isccp(iy(1):iy(2),:,:)  = x%fq_isccp(ix(1):ix(2),:,:)
-    y%totalcldarea(iy(1):iy(2))  = x%totalcldarea(ix(1):ix(2))
-    y%meantb(iy(1):iy(2))        = x%meantb(ix(1):ix(2))
-    y%meantbclr(iy(1):iy(2))     = x%meantbclr(ix(1):ix(2))
-    y%meanptop(iy(1):iy(2))      = x%meanptop(ix(1):ix(2))
-    y%meantaucld(iy(1):iy(2))    = x%meantaucld(ix(1):ix(2))
-    y%meanalbedocld(iy(1):iy(2)) = x%meanalbedocld(ix(1):ix(2))
-    y%boxtau(iy(1):iy(2),:)      = x%boxtau(ix(1):ix(2),:)
-    y%boxptop(iy(1):iy(2),:)     = x%boxptop(ix(1):ix(2),:)
-END SUBROUTINE COSP_ISCCP_CPSECTION
-
-
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-!------------- SUBROUTINE COSP_MISR_CPSECTION -----------------
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-SUBROUTINE COSP_MISR_CPSECTION(ix,iy,x,y)
-    integer,intent(in),dimension(2) :: ix,iy
-    type(cosp_misr),intent(in) :: x
-    type(cosp_misr),intent(inout) :: y
-            
-    y%fq_MISR(iy(1):iy(2),:,:)                 = x%fq_MISR(ix(1):ix(2),:,:)
-    y%MISR_meanztop(iy(1):iy(2))               = x%MISR_meanztop(ix(1):ix(2))
-    y%MISR_cldarea(iy(1):iy(2))                = x%MISR_cldarea(ix(1):ix(2))
-    y%MISR_dist_model_layertops(iy(1):iy(2),:) = x%MISR_dist_model_layertops(ix(1):ix(2),:)
-END SUBROUTINE COSP_MISR_CPSECTION
-
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-!------------- SUBROUTINE COSP_RTTOV_CPSECTION -------------------
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-SUBROUTINE COSP_RTTOV_CPSECTION(ix,iy,x,y)
-    integer,intent(in),dimension(2) :: ix,iy
-    type(cosp_rttov),intent(in) :: x
-    type(cosp_rttov),intent(inout) :: y
-            
-    y%tbs(iy(1):iy(2),:) = x%tbs(ix(1):ix(2),:)
-END SUBROUTINE COSP_RTTOV_CPSECTION
-
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-!------------- SUBROUTINE COSP_RADARSTATS_CPSECTION --------------
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-SUBROUTINE COSP_RADARSTATS_CPSECTION(ix,iy,x,y)
-    integer,intent(in),dimension(2) :: ix,iy
-    type(cosp_radarstats),intent(in) :: x
-    type(cosp_radarstats),intent(inout) :: y
-            
-    y%cfad_ze(iy(1):iy(2),:,:)             = x%cfad_ze(ix(1):ix(2),:,:)
-    y%radar_lidar_tcc(iy(1):iy(2))         = x%radar_lidar_tcc(ix(1):ix(2))
-    y%lidar_only_freq_cloud(iy(1):iy(2),:) = x%lidar_only_freq_cloud(ix(1):ix(2),:)
-END SUBROUTINE COSP_RADARSTATS_CPSECTION
-
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-!------------- SUBROUTINE COSP_LIDARSTATS_CPSECTION --------------
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-SUBROUTINE COSP_LIDARSTATS_CPSECTION(ix,iy,x,y)
-    integer,intent(in),dimension(2) :: ix,iy
-    type(cosp_lidarstats),intent(in) :: x
-    type(cosp_lidarstats),intent(inout) :: y
-            
-    y%srbval                     = x%srbval
-    y%cfad_sr(iy(1):iy(2),:,:)   = x%cfad_sr(ix(1):ix(2),:,:)
-    y%lidarcld(iy(1):iy(2),:)    = x%lidarcld(ix(1):ix(2),:)
-    y%cldlayer(iy(1):iy(2),:)    = x%cldlayer(ix(1):ix(2),:)
-    y%parasolrefl(iy(1):iy(2),:) = x%parasolrefl(ix(1):ix(2),:)
-    y%lidarcldphase(iy(1):iy(2),:,:)  = x%lidarcldphase(ix(1):ix(2),:,:)
-    y%cldlayerphase(iy(1):iy(2),:,:)  = x%cldlayerphase(ix(1):ix(2),:,:)
-    y%lidarcldtmp(iy(1):iy(2),:,:)    = x%lidarcldtmp(ix(1):ix(2),:,:)
-    y%lidarcldtype(iy(1):iy(2),:,:)    = x%lidarcldtype(ix(1):ix(2),:,:) !OPAQ
-    y%cldtype(iy(1):iy(2),:)           = x%cldtype(ix(1):ix(2),:)        !OPAQ
-    y%profSR(iy(1):iy(2),:,:)          = x%profSR(ix(1):ix(2),:,:)       !TIBO
-    y%proftemp(iy(1):iy(2),:)          = x%proftemp(ix(1):ix(2),:)       !TIBO
-END SUBROUTINE COSP_LIDARSTATS_CPSECTION
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-!------------- PRINT SUBROUTINES --------------
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-SUBROUTINE COSP_GRIDBOX_PRINT(x)
-    type(cosp_gridbox),intent(in) :: x
-
-    print *, '%%%%----- Information on COSP_GRIDBOX ------'
-    ! Scalars and dimensions
-    print *,  x%Npoints
-    print *,  x%Nlevels
-    print *,  x%Ncolumns
-    print *,  x%Nhydro
-    print *,  x%Nprmts_max_hydro
-    print *,  x%Naero
-    print *,  x%Nprmts_max_aero
-    print *,  x%Npoints_it
-    
-    ! Time [days]
-    print *,  x%time
-    
-    ! Radar ancillary info
-    print *,  x%radar_freq, &
-            x%k2
-    print *,  x%surface_radar, &
-              x%use_mie_tables, &
-              x%use_gas_abs, &
-              x%do_ray, &
-              x%melt_lay
-
-!               print *,  'shape(x%): ',shape(x%)
- 
-!     type(class_param) ::  hp  ! structure used by radar simulator to store Ze and N scaling constants and other information
-!     type(mie)::  mt           ! structure used by radar simulator to store mie LUT information
-    print *,  x%nsizes
-    
-    ! Lidar
-    print *,  x%lidar_ice_type
-    
-    ! Radar
-    print *,  x%use_precipitation_fluxes
-    print *,  x%use_reff
-    
-    ! Geolocation (Npoints)
-    print *,  'shape(x%longitude): ',shape(x%longitude)
-    print *,  'shape(x%latitude): ',shape(x%latitude)
-    ! Gridbox information (Npoints,Nlevels)
-    print *,  'shape(x%zlev): ',shape(x%zlev)
-    print *,  'shape(x%zlev_half): ',shape(x%zlev_half)
-    print *,  'shape(x%dlev): ',shape(x%dlev)
-    print *,  'shape(x%p): ',shape(x%p)
-    print *,  'shape(x%ph): ',shape(x%ph)
-    print *,  'shape(x%T): ',shape(x%T)
-    print *,  'shape(x%q): ',shape(x%q)
-    print *,  'shape(x%sh): ',shape(x%sh)
-    print *,  'shape(x%dtau_s): ',shape(x%dtau_s)
-    print *,  'shape(x%dtau_c): ',shape(x%dtau_c)
-    print *,  'shape(x%dem_s): ',shape(x%dem_s)
-    print *,  'shape(x%dem_c): ',shape(x%dem_c)
-    print *,  'shape(x%mr_ozone): ',shape(x%mr_ozone)
-
-    ! Point information (Npoints)
-    print *,  'shape(x%land): ',shape(x%land)
-    print *,  'shape(x%psfc): ',shape(x%psfc)
-    print *,  'shape(x%sunlit): ',shape(x%sunlit)
-    print *,  'shape(x%skt): ',shape(x%skt)
-    print *,  'shape(x%u_wind): ',shape(x%u_wind)
-    print *,  'shape(x%v_wind): ',shape(x%v_wind)
-
-    ! TOTAL and CONV cloud fraction for SCOPS
-    print *,  'shape(x%tca): ',shape(x%tca)
-    print *,  'shape(x%cca): ',shape(x%cca)
-    ! Precipitation fluxes on model levels
-    print *,  'shape(x%rain_ls): ',shape(x%rain_ls)
-    print *,  'shape(x%rain_cv): ',shape(x%rain_cv)
-    print *,  'shape(x%snow_ls): ',shape(x%snow_ls)
-    print *,  'shape(x%snow_cv): ',shape(x%snow_cv)
-    print *,  'shape(x%grpl_ls): ',shape(x%grpl_ls)
-    ! Hydrometeors concentration and distribution parameters
-    print *,  'shape(x%mr_hydro): ',shape(x%mr_hydro)
-    print *,  'shape(x%dist_prmts_hydro): ',shape(x%dist_prmts_hydro)
-    ! Effective radius [m]. (Npoints,Nlevels,Nhydro)
-    print *,  'shape(x%Reff): ',shape(x%Reff)
-    print *,  'shape(x%Np): ',shape(x%Np)       ! added by roj with Quickbeam V3
-    ! Aerosols concentration and distribution parameters
-    print *,  'shape(x%conc_aero): ',shape(x%conc_aero)
-    print *,  'shape(x%dist_type_aero): ',shape(x%dist_type_aero)
-    print *,  'shape(x%dist_prmts_aero): ',shape(x%dist_prmts_aero)
-    ! ISCCP simulator inputs
-    print *, x%isccp_top_height
-    print *, x%isccp_top_height_direction
-    print *, x%isccp_overlap
-    print *, x%isccp_emsfc_lw
-  
-    ! RTTOV inputs/options
-    print *, x%plat
-    print *, x%sat
-    print *, x%inst
-    print *, x%Nchan
-    print *,  'shape(x%Ichan): ',x%Ichan
-    print *,  'shape(x%Surfem): ',x%Surfem
-    print *, x%ZenAng
-    print *, x%co2,x%ch4,x%n2o,x%co
-                
-END SUBROUTINE COSP_GRIDBOX_PRINT
-
-SUBROUTINE COSP_MISR_PRINT(x)
-    type(cosp_misr),intent(in) :: x
-
-    print *, '%%%%----- Information on COSP_MISR ------'
-                
-     ! Dimensions
-    print *, x%Npoints
-    print *, x%Ntau
-    print *, x%Nlevels
-
-     ! --- (npoints,ntau,nlevels)
-     !  the fraction of the model grid box covered by each of the MISR cloud types
-     print *,  'shape(x%fq_MISR): ',shape(x%fq_MISR)
-     
-     ! --- (npoints)
-     print *,  'shape(x%MISR_meanztop): ',shape(x%MISR_meanztop)
-     print *,  'shape(x%MISR_cldarea): ',shape(x%MISR_cldarea)
-     ! --- (npoints,nlevels)
-     print *,  'shape(x%MISR_dist_model_layertops): ',shape(x%MISR_dist_model_layertops)
-    
-END SUBROUTINE COSP_MISR_PRINT
-
-SUBROUTINE COSP_ISCCP_PRINT(x)
-    type(cosp_isccp),intent(in) :: x
-            
-    print *, x%Npoints
-    print *, x%Ncolumns
-    print *, x%Nlevels
-
-    print *, '%%%%----- Information on COSP_ISCCP ------'
-    
-     print *, 'shape(x%fq_isccp): ',shape(x%fq_isccp)
-     print *, 'shape(x%totalcldarea): ',shape(x%totalcldarea)
-     print *, 'shape(x%meantb): ',shape(x%meantb)
-     print *, 'shape(x%meantbclr): ',shape(x%meantbclr)
-     
-     print *, 'shape(x%meanptop): ',shape(x%meanptop)
-     print *, 'shape(x%meantaucld): ',shape(x%meantaucld)
-     print *, 'shape(x%meanalbedocld): ',shape(x%meanalbedocld)
-     print *, 'shape(x%boxtau): ',shape(x%boxtau)
-     print *, 'shape(x%boxptop): ',shape(x%boxptop)
-END SUBROUTINE COSP_ISCCP_PRINT
-
-SUBROUTINE COSP_VGRID_PRINT(x)
-    type(cosp_vgrid),intent(in) :: x
-            
-    print *, '%%%%----- Information on COSP_VGRID ------'
-    print *, x%use_vgrid
-    print *, x%csat_vgrid
-    print *, x%Npoints
-    print *, x%Ncolumns
-    print *, x%Nlevels
-    print *, x%Nlvgrid
-    ! Array with dimensions (Nlvgrid)
-    print *, 'shape(x%z): ',shape(x%z)
-    print *, 'shape(x%zl): ',shape(x%zl)
-    print *, 'shape(x%zu): ',shape(x%zu)
-    ! Array with dimensions (Nlevels)
-    print *, 'shape(x%mz): ',shape(x%mz)
-    print *, 'shape(x%mzl): ',shape(x%mzl)
-    print *, 'shape(x%mzu): ',shape(x%mzu)
-END SUBROUTINE COSP_VGRID_PRINT
-
-SUBROUTINE COSP_SGLIDAR_PRINT(x)
-    type(cosp_sglidar),intent(in) :: x
-            
-    print *, '%%%%----- Information on COSP_SGLIDAR ------'
-    ! Dimensions
-    print *, x%Npoints
-    print *, x%Ncolumns
-    print *, x%Nlevels
-    print *, x%Nhydro
-    print *, x%Nrefl
-    ! Arrays with dimensions (Npoints,Nlevels)
-    print *, 'shape(x%beta_mol): ',shape(x%beta_mol)
-    ! Arrays with dimensions (Npoints,Ncolumns,Nlevels)
-    print *, 'shape(x%beta_tot): ',shape(x%beta_tot)
-    print *, 'shape(x%tau_tot): ',shape(x%tau_tot)
-    ! Arrays with dimensions (Npoints,Ncolumns,Nrefl)
-    print *, 'shape(x%refl): ',shape(x%refl)
-END SUBROUTINE COSP_SGLIDAR_PRINT
-
-SUBROUTINE COSP_SGRADAR_PRINT(x)
-    type(cosp_sgradar),intent(in) :: x
-            
-    print *, '%%%%----- Information on COSP_SGRADAR ------'
-    print *, x%Npoints
-    print *, x%Ncolumns
-    print *, x%Nlevels
-    print *, x%Nhydro
-    ! output vertical levels: spaceborne radar -> from TOA to SURFACE
-    ! Arrays with dimensions (Npoints,Nlevels)
-    print *, 'shape(x%att_gas): ', shape(x%att_gas)
-    ! Arrays with dimensions (Npoints,Ncolumns,Nlevels)
-    print *, 'shape(x%Ze_tot): ', shape(x%Ze_tot)
-END SUBROUTINE COSP_SGRADAR_PRINT
-
-SUBROUTINE COSP_RADARSTATS_PRINT(x)
-    type(cosp_radarstats),intent(in) :: x
-            
-    print *, '%%%%----- Information on COSP_SGRADAR ------'
-    print *, x%Npoints
-    print *, x%Ncolumns
-    print *, x%Nlevels
-    print *, x%Nhydro
-    print *, 'shape(x%cfad_ze): ',shape(x%cfad_ze)
-    print *, 'shape(x%radar_lidar_tcc): ',shape(x%radar_lidar_tcc)
-    print *, 'shape(x%lidar_only_freq_cloud): ',shape(x%lidar_only_freq_cloud)
-END SUBROUTINE COSP_RADARSTATS_PRINT
-
-SUBROUTINE COSP_LIDARSTATS_PRINT(x)
-    type(cosp_lidarstats),intent(in) :: x
-            
-    print *, '%%%%----- Information on COSP_SGLIDAR ------'
-    print *, x%Npoints
-    print *, x%Ncolumns
-    print *, x%Nlevels
-    print *, x%Nhydro
-    print *, x%Nrefl
-    
-    ! Arrays with dimensions (SR_BINS)
-    print *, 'shape(x%srbval): ',shape(x%srbval)
-    ! Arrays with dimensions (Npoints,SR_BINS,Nlevels)
-    print *, 'shape(x%cfad_sr): ',shape(x%cfad_sr)
-!    ! Arrays with dimensions (Npoints,Ncolumns,Nlevels) !TIBO
-!    print *, 'shape(x%profSR): ',shape(x%profSR)        !TIBO
-    ! Arrays with dimensions (Npoints,Nlevels,Ncolumns) !TIBO2
-    print *, 'shape(x%profSR): ',shape(x%profSR)        !TIBO2
-    ! Arrays with dimensions (Npoints,Nlevels)
-    print *, 'shape(x%lidarcld): ',shape(x%lidarcld)
-    print *, 'shape(x%proftemp): ',shape(x%proftemp)    !TIBO
-    ! Arrays with dimensions (Npoints,LIDAR_NCAT)
-    print *, 'shape(x%cldlayer): ',shape(x%cldlayer)
-    ! Arrays with dimensions (Npoints,LIDAR_NTYPE)            !OPAQ
-    print *, 'shape(x%cldtype): ',shape(x%cldtype)            !OPAQ
-    ! Arrays with dimensions (Npoints,PARASOL_NREFL)
-    print *, 'shape(x%parasolrefl): ',shape(x%parasolrefl)
-     ! Arrays with dimensions (Npoints,Nlevels,Nphase)
-    print *, 'shape(x%lidarcldphase): ',shape(x%lidarcldphase)
-     ! Arrays with dimensions (Npoints,Nlevels,LIDAR_NTYPE+1) !OPAQ
-    print *, 'shape(x%lidarcldtype): ',shape(x%lidarcldtype)  !OPAQ
-     ! Arrays with dimensions (Npoints,LIDAR_NCAT,Nphase)
-    print *, 'shape(x%cldlayerphase): ',shape(x%cldlayerphase)
-     ! Arrays with dimensions (Npoints,Ntemps,Nphase)
-    print *, 'shape(x%lidarcldphase): ',shape(x%lidarcldtmp)
-
-END SUBROUTINE COSP_LIDARSTATS_PRINT
-
-SUBROUTINE COSP_SUBGRID_PRINT(x)
-    type(cosp_subgrid),intent(in) :: x
-            
-    print *, '%%%%----- Information on COSP_SUBGRID ------'
-    print *, x%Npoints
-    print *, x%Ncolumns
-    print *, x%Nlevels
-    print *, x%Nhydro
-    
-    print *, 'shape(x%prec_frac): ',shape(x%prec_frac)
-    print *, 'shape(x%frac_out): ',shape(x%frac_out)
-END SUBROUTINE COSP_SUBGRID_PRINT
-
-SUBROUTINE COSP_SGHYDRO_PRINT(x)
-    type(cosp_sghydro),intent(in) :: x
-            
-    print *, '%%%%----- Information on COSP_SGHYDRO ------'
-    print *, x%Npoints
-    print *, x%Ncolumns
-    print *, x%Nlevels
-    print *, x%Nhydro
-    
-    print *, 'shape(x%mr_hydro): ',shape(x%mr_hydro)
-    print *, 'shape(x%Reff): ',shape(x%Reff)
-    print *, 'shape(x%Np): ',shape(x%Np)         ! added by roj with Quickbeam V3
-END SUBROUTINE COSP_SGHYDRO_PRINT
-
-END MODULE MOD_COSP_TYPES
Index: /LMDZ6/trunk/libf/phylmd/cosp/mod_cosp_types.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cosp/mod_cosp_types.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/cosp/mod_cosp_types.f90	(revision 5268)
@@ -0,0 +1,1676 @@
+! (c) British Crown Copyright 2008, the Met Office.
+! All rights reserved.
+! 
+! Redistribution and use in source and binary forms, with or without modification, are permitted 
+! provided that the following conditions are met:
+! 
+!     * Redistributions of source code must retain the above copyright notice, this list 
+!       of conditions and the following disclaimer.
+!     * Redistributions in binary form must reproduce the above copyright notice, this list
+!       of conditions and the following disclaimer in the documentation and/or other materials 
+!       provided with the distribution.
+!     * Neither the name of the Met Office nor the names of its contributors may be used 
+!       to endorse or promote products derived from this software without specific prior written 
+!       permission.
+! 
+! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR 
+! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND 
+! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR 
+! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 
+! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 
+! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER 
+! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT 
+! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+MODULE MOD_COSP_TYPES
+    USE MOD_COSP_CONSTANTS
+    USE MOD_COSP_UTILS
+
+    use radar_simulator_types, only: class_param, nd, mt_nd, dmax, dmin
+
+    IMPLICIT NONE
+
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+!----------------------- DERIVED TYPES ----------------------------    
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+  ! Configuration choices (simulators, variables)
+  TYPE COSP_CONFIG
+     logical :: Lradar_sim,Llidar_sim,Lisccp_sim,Lmodis_sim,Lmisr_sim,Lrttov_sim,Lstats,Lwrite_output, &
+                Lalbisccp,Latb532,Lboxptopisccp,Lboxtauisccp,LcfadDbze94, &
+                LcfadLidarsr532,Lclcalipso2,Lclcalipso,Lclhcalipso,Lclisccp,Lcllcalipso, &
+                Lclmcalipso,Lcltcalipso,Lcltlidarradar,Lpctisccp,Ldbze94,Ltauisccp,Lcltisccp, &
+                Ltoffset,LparasolRefl,LclMISR,Lmeantbisccp,Lmeantbclrisccp, &
+                Lclcalipsoliq,Lclcalipsoice,Lclcalipsoun, &
+                Lclcalipsotmp,Lclcalipsotmpliq,Lclcalipsotmpice,Lclcalipsotmpun, &
+	              Lcltcalipsoliq,Lcltcalipsoice,Lcltcalipsoun, &
+                Lclhcalipsoliq,Lclhcalipsoice,Lclhcalipsoun, &
+                Lclmcalipsoliq,Lclmcalipsoice,Lclmcalipsoun, &
+                Lcllcalipsoliq,Lcllcalipsoice,Lcllcalipsoun, &
+                Lfracout,LlidarBetaMol532,Ltbrttov, &
+                Lcltmodis,Lclwmodis,Lclimodis,Lclhmodis,Lclmmodis,Lcllmodis,Ltautmodis,Ltauwmodis,Ltauimodis,Ltautlogmodis, &
+                Ltauwlogmodis,Ltauilogmodis,Lreffclwmodis,Lreffclimodis,Lpctmodis,Llwpmodis, &
+                Liwpmodis,Lclmodis,Lcrimodis,Lcrlmodis,Lclopaquecalipso,Lclthincalipso, & !OPAQ (2)
+                Lclzopaquecalipso,Lclcalipsoopaque,Lclcalipsothin,Lclcalipsozopaque,    & !OPAQ (4)
+                Lclcalipsoopacity,LprofSR,Lproftemp                                       !OPAQ (1) !TIBO (2)
+
+     character(len=32) :: out_list(N_OUT_LIST)
+  END TYPE COSP_CONFIG
+  
+  ! Outputs from RTTOV
+  TYPE COSP_RTTOV
+     ! Dimensions
+     integer :: Npoints   ! Number of gridpoints
+     integer :: Nchan     ! Number of channels
+     
+     ! Brightness temperatures (Npoints,Nchan)
+     real,pointer :: tbs(:,:)
+     
+  END TYPE COSP_RTTOV
+  
+  ! Outputs from MISR simulator
+  TYPE COSP_MISR
+     ! Dimensions
+     integer :: Npoints   ! Number of gridpoints
+     integer :: Ntau      ! Number of tau intervals
+     integer :: Nlevels   ! Number of cth levels
+
+     ! --- (npoints,ntau,nlevels)
+     !  the fraction of the model grid box covered by each of the MISR cloud types
+     real,pointer :: fq_MISR(:,:,:)  
+     
+     ! --- (npoints)
+     real,pointer :: MISR_meanztop(:), MISR_cldarea(:)
+     ! --- (npoints,nlevels)
+     real,pointer :: MISR_dist_model_layertops(:,:)
+  END TYPE COSP_MISR
+
+  ! Outputs from ISCCP simulator
+  TYPE COSP_ISCCP
+     ! Dimensions
+     integer :: Npoints   ! Number of gridpoints
+     integer :: Ncolumns  ! Number of columns
+     integer :: Nlevels   ! Number of levels
+
+    
+     ! --- (npoints,tau=7,pressure=7)
+     !  the fraction of the model grid box covered by each of the 49 ISCCP D level cloud types
+     real,pointer :: fq_isccp(:,:,:)
+     
+     ! --- (npoints) ---
+     ! The fraction of model grid box columns with cloud somewhere in them.
+     ! This should equal the sum over all entries of fq_isccp
+     real,pointer :: totalcldarea(:)
+     ! mean all-sky 10.5 micron brightness temperature
+     real,pointer ::  meantb(:)
+     ! mean clear-sky 10.5 micron brightness temperature
+     real,pointer ::  meantbclr(:)
+     
+     ! The following three means are averages over the cloudy areas only.  If no
+     ! clouds are in grid box all three quantities should equal zero.
+     
+     !  mean cloud top pressure (mb) - linear averaging in cloud top pressure.
+     real,pointer :: meanptop(:)
+     !  mean optical thickness linear averaging in albedo performed.
+     real,pointer :: meantaucld(:)
+     ! mean cloud albedo. linear averaging in albedo performed 
+     real,pointer :: meanalbedocld(:)  
+     
+     !--- (npoints,ncol) ---
+     !  optical thickness in each column     
+     real,pointer :: boxtau(:,:)
+     !  cloud top pressure (mb) in each column
+     real,pointer :: boxptop(:,:)        
+  END TYPE COSP_ISCCP
+  
+  ! Summary statistics from radar
+  TYPE COSP_VGRID
+    logical :: use_vgrid ! Logical flag that indicates change of grid
+    logical :: csat_vgrid ! Flag for Cloudsat grid
+    integer :: Npoints   ! Number of sampled points
+    integer :: Ncolumns  ! Number of subgrid columns
+    integer :: Nlevels   ! Number of model levels
+    integer :: Nlvgrid   ! Number of levels of new grid
+    ! Array with dimensions (Nlvgrid)
+    real, dimension(:), pointer :: z,zl,zu ! Height and lower and upper boundaries of new levels
+    ! Array with dimensions (Nlevels)
+    real, dimension(:), pointer :: mz,mzl,mzu ! Height and lower and upper boundaries of model levels
+  END TYPE COSP_VGRID
+  
+  ! Output data from lidar code
+  TYPE COSP_SGLIDAR
+    ! Dimensions
+    integer :: Npoints   ! Number of gridpoints
+    integer :: Ncolumns  ! Number of columns
+    integer :: Nlevels   ! Number of levels
+    integer :: Nhydro    ! Number of hydrometeors    
+    integer :: Nrefl     ! Number of parasol reflectances
+    ! Arrays with dimensions (Npoints,Nlevels)
+    real,dimension(:,:),pointer :: beta_mol   ! Molecular backscatter
+    real,dimension(:,:),pointer :: temp_tot
+    ! Arrays with dimensions (Npoints,Ncolumns,Nlevels)
+    real,dimension(:,:,:),pointer :: betaperp_tot   ! Total backscattered signal
+    real,dimension(:,:,:),pointer :: beta_tot   ! Total backscattered signal
+    real,dimension(:,:,:),pointer :: tau_tot    ! Optical thickness integrated from top to level z
+    ! Arrays with dimensions (Npoints,Ncolumns,Nrefl)
+    real,dimension(:,:,:),pointer :: refl       ! parasol reflectances
+  END TYPE COSP_SGLIDAR
+  
+  ! Output data from radar code
+  TYPE COSP_SGRADAR
+    ! Dimensions
+    integer :: Npoints   ! Number of gridpoints
+    integer :: Ncolumns  ! Number of columns
+    integer :: Nlevels   ! Number of levels
+    integer :: Nhydro    ! Number of hydrometeors
+    ! output vertical levels: spaceborne radar -> from TOA to SURFACE
+    ! Arrays with dimensions (Npoints,Nlevels)
+    real,dimension(:,:),pointer :: att_gas ! 2-way attenuation by gases [dBZ]
+    ! Arrays with dimensions (Npoints,Ncolumns,Nlevels)
+    real,dimension(:,:,:),pointer :: Ze_tot ! Effective reflectivity factor [dBZ]
+ 
+  END TYPE COSP_SGRADAR
+
+  
+  ! Summary statistics from radar
+  TYPE COSP_RADARSTATS
+    integer :: Npoints  ! Number of sampled points
+    integer :: Ncolumns ! Number of subgrid columns
+    integer :: Nlevels  ! Number of model levels
+    integer :: Nhydro   ! Number of hydrometeors
+    ! Array with dimensions (Npoints,dBZe_bins,Nlevels)
+    real, dimension(:,:,:), pointer :: cfad_ze ! Ze CFAD
+    ! Array with dimensions (Npoints)
+    real,dimension(:),pointer :: radar_lidar_tcc ! Radar&lidar total cloud amount, grid-box scale
+    ! Arrays with dimensions (Npoints,Nlevels)
+    real, dimension(:,:),pointer :: lidar_only_freq_cloud
+  END TYPE COSP_RADARSTATS
+
+  ! Summary statistics from lidar
+  TYPE COSP_LIDARSTATS
+    integer :: Npoints  ! Number of sampled points
+    integer :: Ncolumns ! Number of subgrid columns
+    integer :: Nlevels  ! Number of model levels
+    integer :: Nhydro   ! Number of hydrometeors
+    integer :: Nrefl    ! Number of parasol reflectances
+    
+    ! Arrays with dimensions (SR_BINS)
+    real, dimension(:),pointer :: srbval ! SR bins in cfad_sr
+    ! Arrays with dimensions (Npoints,SR_BINS,Nlevels)
+    real, dimension(:,:,:),pointer :: cfad_sr   ! CFAD of scattering ratio
+    ! Arrays with dimensions (Npoints,Nlevels)
+    real, dimension(:,:),pointer :: lidarcld    ! 3D "lidar" cloud fraction 
+    real, dimension(:,:),pointer :: proftemp    ! Temperature profiles 40 levs !TIBO 
+    ! Arrays with dimensions (Npoints,LIDAR_NCAT)
+    real, dimension(:,:),pointer :: cldlayer      ! low, mid, high-level, total lidar cloud cover
+    ! Arrays with dimensions (Npoints,LIDAR_NTYPE)                                               !OPAQ
+    real, dimension(:,:),pointer :: cldtype       ! opaque and thin cloud covers, z_opaque       !OPAQ
+    ! Arrays with dimensions (Npoints,Nlevels,Nphase)
+    real, dimension(:,:,:),pointer :: lidarcldphase    ! 3D "lidar" phase cloud fraction 
+    ! Arrays with dimensions (Npoints,Nlevels,LIDAR_NTYPE+1)                                     !OPAQ
+    real, dimension(:,:,:),pointer :: lidarcldtype     ! 3D "lidar" OPAQ type fraction + opacity !OPAQ 
+    ! Arrays with dimensions (Npoints,LIDAR_NCAT,Nphase)
+    real, dimension(:,:,:),pointer :: cldlayerphase      ! low, mid, high-level lidar phase cloud cover
+    ! Arrays with dimensions (Npoints,Ntemps,Nphase)
+    real, dimension(:,:,:),pointer :: lidarcldtmp    ! 3D "lidar" phase cloud temperature
+    ! Arrays with dimensions (Npoints,PARASOL_NREFL)
+    real, dimension(:,:),pointer :: parasolrefl   ! mean parasol reflectance
+!    ! Arrays with dimensions (Npoints,Ncolumns,Nlevels)                     !TIBO
+!    real, dimension(:,:,:),pointer :: profSR      ! subcolumns for each day !TIBO 
+    ! Arrays with dimensions (Npoints,Nlevels,Ncolumns)                     !TIBO2
+    real, dimension(:,:,:),pointer :: profSR      ! subcolumns for each day !TIBO2 
+
+  END TYPE COSP_LIDARSTATS
+
+    
+  ! Input data for simulator. Subgrid scale.
+  ! Input data from SURFACE to TOA
+  TYPE COSP_SUBGRID
+    ! Dimensions
+    integer :: Npoints   ! Number of gridpoints
+    integer :: Ncolumns  ! Number of columns
+    integer :: Nlevels   ! Number of levels
+    integer :: Nhydro    ! Number of hydrometeors
+    
+    real,dimension(:,:,:),pointer :: prec_frac  ! Subgrid precip array. Dimensions (Npoints,Ncolumns,Nlevels)
+    real,dimension(:,:,:),pointer :: frac_out  ! Subgrid cloud array. Dimensions (Npoints,Ncolumns,Nlevels)
+  END TYPE COSP_SUBGRID
+
+  ! Input data for simulator at Subgrid scale.
+  ! Used on a reduced number of points
+  TYPE COSP_SGHYDRO
+    ! Dimensions
+    integer :: Npoints   ! Number of gridpoints
+    integer :: Ncolumns  ! Number of columns
+    integer :: Nlevels   ! Number of levels
+    integer :: Nhydro    ! Number of hydrometeors
+    real,dimension(:,:,:,:),pointer :: mr_hydro ! Mixing ratio of each hydrometeor 
+                                                ! (Npoints,Ncolumns,Nlevels,Nhydro) [kg/kg]
+    real,dimension(:,:,:,:),pointer :: Reff     ! Effective Radius of each hydrometeor
+                                                ! (Reff==0 means use default size)   
+                                                ! (Npoints,Ncolumns,Nlevels,Nhydro) [m]
+    real,dimension(:,:,:,:),pointer :: Np       ! Total # concentration each hydrometeor 
+                                                ! (Optional, ignored if Reff > 0).
+                                                ! (Npoints,Ncolumns,Nlevels,Nhydro) [#/kg]
+                                                ! Np = Ntot / rho_a  = [#/m^3] / [kg/m^3) 
+                                                ! added by Roj with Quickbeam V3
+  END TYPE COSP_SGHYDRO
+  
+  ! Input data for simulator. Gridbox scale.
+  TYPE COSP_GRIDBOX
+    ! Scalars and dimensions
+    integer :: Npoints   ! Number of gridpoints
+    integer :: Nlevels   ! Number of levels
+    integer :: Ncolumns  ! Number of columns
+    integer :: Nhydro    ! Number of hydrometeors
+    integer :: Nprmts_max_hydro    ! Max number of parameters for hydrometeor size distributions
+    integer :: Naero    ! Number of aerosol species
+    integer :: Nprmts_max_aero    ! Max number of parameters for aerosol size distributions
+    integer :: Npoints_it   ! Max number of gridpoints to be processed in one iteration
+    
+    ! Time [days]
+    double precision :: time
+    double precision :: time_bnds(2)
+    
+    ! Radar ancillary info
+    real :: radar_freq, & ! Radar frequency [GHz]
+            k2 ! |K|^2, -1=use frequency dependent default
+    integer :: surface_radar, & ! surface=1, spaceborne=0
+           use_mie_tables, & ! use a precomputed loopup table? yes=1,no=0
+           use_gas_abs, & ! include gaseous absorption? yes=1,no=0
+           do_ray, & ! calculate/output Rayleigh refl=1, not=0
+           melt_lay ! melting layer model off=0, on=1
+ 
+    ! structures used by radar simulator that need to be set only ONCE per radar configuration (e.g. freq, pointing direction) ... added by roj Feb 2008
+    type(class_param) ::  hp    ! structure used by radar simulator to store Ze and N scaling constants and other information
+    integer :: nsizes       ! number of discrete drop sizes (um) used to represent the distribution
+    
+    ! Lidar
+    integer :: lidar_ice_type !ice particle shape hypothesis in lidar calculations 
+                              !(ice_type=0 for spheres, ice_type=1 for non spherical particles)
+    
+    ! Radar
+    logical ::  use_precipitation_fluxes  ! True if precipitation fluxes are input to the algorithm 
+    logical ::  use_reff          ! True if Reff is to be used by radar (memory not allocated
+    
+    
+    ! Geolocation (Npoints)
+    real,dimension(:),pointer :: toffset   ! Time offset of esch point from the value in time
+    real,dimension(:),pointer :: longitude ! longitude [degrees East]
+    real,dimension(:),pointer :: latitude  ! latitude [deg North]
+    ! Gridbox information (Npoints,Nlevels)
+    real,dimension(:,:),pointer :: zlev ! Height of model levels [m]
+    real,dimension(:,:),pointer :: zlev_half ! Height at half model levels [m] (Bottom of model layer)
+    real,dimension(:,:),pointer :: dlev ! Depth of model levels  [m]
+    real,dimension(:,:),pointer :: p  ! Pressure at full model levels [Pa]
+    real,dimension(:,:),pointer :: ph ! Pressure at half model levels [Pa]
+    real,dimension(:,:),pointer :: T ! Temperature at model levels [K]
+    real,dimension(:,:),pointer :: q  ! Relative humidity to water (%)
+    real,dimension(:,:),pointer :: sh ! Specific humidity to water [kg/kg]
+    real,dimension(:,:),pointer :: dtau_s ! mean 0.67 micron optical depth of stratiform
+                                          !  clouds in each model level
+                                          !  NOTE:  this the cloud optical depth of only the
+                                          !  cloudy part of the grid box, it is not weighted
+                                          !  with the 0 cloud optical depth of the clear
+                                          !         part of the grid box
+    real,dimension(:,:),pointer :: dtau_c !  mean 0.67 micron optical depth of convective
+                                          !  clouds in each model level.  Same note applies as in dtau_s.
+    real,dimension(:,:),pointer :: dem_s  !  10.5 micron longwave emissivity of stratiform
+                                          !  clouds in each model level.  Same note applies as in dtau_s.
+    real,dimension(:,:),pointer :: dem_c  !  10.5 micron longwave emissivity of convective
+                                          !  clouds in each model level.  Same note applies as in dtau_s.
+    real,dimension(:,:),pointer :: mr_ozone !  Ozone mass mixing ratio [kg/kg]
+
+    ! Point information (Npoints)
+    real,dimension(:),pointer :: land !Landmask [0 - Ocean, 1 - Land]
+    real,dimension(:),pointer :: psfc !Surface pressure [Pa]
+    real,dimension(:),pointer :: sunlit ! (npoints) 1 for day points, 0 for nightime
+    real,dimension(:),pointer :: skt  ! Skin temperature (K)
+    real,dimension(:),pointer :: u_wind  ! eastward wind [m s-1]
+    real,dimension(:),pointer :: v_wind  ! northward wind [m s-1]
+
+    ! TOTAL and CONV cloud fraction for SCOPS
+    real,dimension(:,:),pointer :: tca ! Total cloud fraction
+    real,dimension(:,:),pointer :: cca ! Convective cloud fraction
+    ! Precipitation fluxes on model levels
+    real,dimension(:,:),pointer :: rain_ls ! large-scale precipitation flux of rain [kg/m2.s]
+    real,dimension(:,:),pointer :: rain_cv ! convective precipitation flux of rain [kg/m2.s]
+    real,dimension(:,:),pointer :: snow_ls ! large-scale precipitation flux of snow [kg/m2.s]
+    real,dimension(:,:),pointer :: snow_cv ! convective precipitation flux of snow [kg/m2.s]
+    real,dimension(:,:),pointer :: grpl_ls ! large-scale precipitation flux of graupel [kg/m2.s]
+    ! Hydrometeors concentration and distribution parameters
+!     real,dimension(:,:,:),pointer :: fr_hydro ! Fraction of the gridbox occupied by each hydrometeor (Npoints,Nlevels,Nhydro)
+    real,dimension(:,:,:),pointer :: mr_hydro ! Mixing ratio of each hydrometeor (Npoints,Nlevels,Nhydro) [kg/kg]
+    real,dimension(:,:),pointer   :: dist_prmts_hydro !Distributional parameters for hydrometeors (Nprmts_max_hydro,Nhydro)
+
+    ! Effective radius [m]. (Npoints,Nlevels,Nhydro) -- OPTIONAL, value of 0 mean use fixed default
+    real,dimension(:,:,:),pointer :: Reff
+
+    ! Total Number Concentration [#/kg]. (Npoints,Nlevels,Nhydro) -- OPTIONAL, value of 0 mean use fixed default
+    real,dimension(:,:,:),pointer :: Np ! added by Roj with Quickbeam V3
+ 
+    ! Aerosols concentration and distribution parameters
+    real,dimension(:,:,:),pointer :: conc_aero ! Aerosol concentration for each species (Npoints,Nlevels,Naero)
+    integer,dimension(:),pointer :: dist_type_aero ! Particle size distribution type for each aerosol species (Naero)
+    real,dimension(:,:,:,:),pointer :: dist_prmts_aero ! Distributional parameters for aerosols 
+                                                       ! (Npoints,Nlevels,Nprmts_max_aero,Naero)
+    ! ISCCP simulator inputs
+    integer :: isccp_top_height !  1 = adjust top height using both a computed
+                                !  infrared brightness temperature and the visible
+                                !  optical depth to adjust cloud top pressure. Note
+                                !  that this calculation is most appropriate to compare
+                                !  to ISCCP data during sunlit hours.
+                                !  2 = do not adjust top height, that is cloud top
+                                !  pressure is the actual cloud top pressure
+                                !  in the model
+                                !  3 = adjust top height using only the computed
+                                !  infrared brightness temperature. Note that this
+                                !  calculation is most appropriate to compare to ISCCP
+                                !  IR only algortihm (i.e. you can compare to nighttime
+                                !  ISCCP data with this option)
+    integer :: isccp_top_height_direction ! direction for finding atmosphere pressure level
+                                 ! with interpolated temperature equal to the radiance
+                                 ! determined cloud-top temperature
+                                 ! 1 = find the *lowest* altitude (highest pressure) level
+                                 ! with interpolated temperature equal to the radiance
+                                 ! determined cloud-top temperature
+                                 ! 2 = find the *highest* altitude (lowest pressure) level
+                                 ! with interpolated temperature equal to the radiance 
+                                 ! determined cloud-top temperature
+                                 ! ONLY APPLICABLE IF top_height EQUALS 1 or 3
+                                 ! 1 = default setting, and matches all versions of 
+                                 ! ISCCP simulator with versions numbers 3.5.1 and lower
+                                 ! 2 = experimental setting  
+    integer :: isccp_overlap !  overlap type (1=max, 2=rand, 3=max/rand)
+    real :: isccp_emsfc_lw      ! 10.5 micron emissivity of surface (fraction)
+  
+    ! RTTOV inputs/options
+    integer :: plat      ! satellite platform
+    integer :: sat       ! satellite
+    integer :: inst      ! instrument
+    integer :: Nchan     ! Number of channels to be computed
+    integer, dimension(:), pointer :: Ichan   ! Channel numbers
+    real,    dimension(:), pointer :: Surfem  ! Surface emissivity
+    real    :: ZenAng ! Satellite Zenith Angles
+    real :: co2,ch4,n2o,co ! Mixing ratios of trace gases
+
+  END TYPE COSP_GRIDBOX
+ 
+CONTAINS
+
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+!------------- SUBROUTINE CONSTRUCT_COSP_RTTOV -------------------
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  SUBROUTINE CONSTRUCT_COSP_RTTOV(cfg,Npoints,Nchan,x)
+    type(cosp_config),intent(in) :: cfg ! Configuration options
+    integer,intent(in) :: Npoints  ! Number of sampled points
+    integer,intent(in) :: Nchan ! Number of channels
+    type(cosp_rttov),intent(out) :: x
+    ! Local variables
+    integer :: i,j
+    
+    ! Allocate minumum storage if simulator not used
+    if (cfg%Lrttov_sim) then
+      i = Npoints
+      j = Nchan
+    else
+      i = 1
+      j = 1
+    endif
+    x%Npoints  = i
+    x%Nchan    = j
+      
+    ! --- Allocate arrays ---
+    allocate(x%tbs(i, j))
+    ! --- Initialise to zero ---
+    x%tbs     = 0.0
+  END SUBROUTINE CONSTRUCT_COSP_RTTOV
+
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+!------------- SUBROUTINE FREE_COSP_RTTOV ------------------------
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  SUBROUTINE FREE_COSP_RTTOV(x)
+    type(cosp_rttov),intent(inout) :: x
+    
+    ! --- Deallocate arrays ---
+    deallocate(x%tbs)
+  END SUBROUTINE FREE_COSP_RTTOV
+  
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+!------------- SUBROUTINE CONSTRUCT_COSP_MISR ------------------
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  SUBROUTINE CONSTRUCT_COSP_MISR(cfg,Npoints,x)
+    type(cosp_config),intent(in) :: cfg ! Configuration options
+    integer,intent(in) :: Npoints   ! Number of gridpoints
+    type(cosp_misr),intent(out) :: x
+    ! Local variables
+    integer :: i,j,k
+    
+   
+    ! Allocate minumum storage if simulator not used
+    if (cfg%Lmisr_sim) then
+      i = Npoints
+      j = 7
+      k = MISR_N_CTH
+    else
+      i = 1
+      j = 1
+      k = 1
+    endif
+    
+    ! Dimensions
+    x%Npoints = i
+    x%Ntau    = j
+    x%Nlevels = k
+    
+    ! allocate space for MISR simulator outputs ...
+    allocate(x%fq_MISR(i,j,k), x%MISR_meanztop(i),x%MISR_cldarea(i), x%MISR_dist_model_layertops(i,k))
+    x%fq_MISR = 0.0
+    x%MISR_meanztop = 0.0
+    x%MISR_cldarea = 0.0
+    x%MISR_dist_model_layertops = 0.0
+    
+  END SUBROUTINE CONSTRUCT_COSP_MISR
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+!------------- SUBROUTINE FREE_COSP_MISR ------------------
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  SUBROUTINE FREE_COSP_MISR(x)
+    type(cosp_misr),intent(inout) :: x
+    deallocate(x%fq_MISR, x%MISR_meanztop,x%MISR_cldarea, x%MISR_dist_model_layertops)
+    
+  END SUBROUTINE FREE_COSP_MISR
+
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+!------------- SUBROUTINE CONSTRUCT_COSP_ISCCP ------------------
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  SUBROUTINE CONSTRUCT_COSP_ISCCP(cfg,Npoints,Ncolumns,Nlevels,x)
+    type(cosp_config),intent(in) :: cfg ! Configuration options
+    integer,intent(in) :: Npoints  ! Number of sampled points
+    integer,intent(in) :: Ncolumns ! Number of subgrid columns
+    integer,intent(in) :: Nlevels  ! Number of model levels
+    type(cosp_isccp),intent(out) :: x
+    ! Local variables
+    integer :: i,j,k
+    
+    ! Allocate minumum storage if simulator not used
+    if (cfg%Lisccp_sim) then
+      i = Npoints
+      j = Ncolumns
+      k = Nlevels
+    else
+      i = 1
+      j = 1
+      k = 1
+    endif
+    
+    ! Dimensions
+    x%Npoints  = i
+    x%Ncolumns = j
+    x%Nlevels  = k
+    
+    ! --- Allocate arrays ---
+    allocate(x%fq_isccp(i,7,7), x%totalcldarea(i), &
+         x%meanptop(i), x%meantaucld(i), &
+         x%meantb(i), x%meantbclr(i), &
+         x%boxtau(i,j), x%boxptop(i,j), &
+         x%meanalbedocld(i))
+    ! --- Initialise to zero ---
+    x%fq_isccp     = 0.0
+    x%totalcldarea = 0.0
+    x%meanptop     = 0.0
+    x%meantaucld   = 0.0
+    x%meantb       = 0.0
+    x%meantbclr    = 0.0
+    x%boxtau       = 0.0
+    x%boxptop      = 0.0
+    x%meanalbedocld= 0.0
+  END SUBROUTINE CONSTRUCT_COSP_ISCCP
+
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+!------------- SUBROUTINE FREE_COSP_ISCCP -----------------------
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  SUBROUTINE FREE_COSP_ISCCP(x)
+    type(cosp_isccp),intent(inout) :: x
+    
+    deallocate(x%fq_isccp, x%totalcldarea, &
+         x%meanptop, x%meantaucld, x%meantb, x%meantbclr, &
+         x%boxtau, x%boxptop, x%meanalbedocld)
+  END SUBROUTINE FREE_COSP_ISCCP
+  
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+!------------- SUBROUTINE CONSTRUCT_COSP_VGRID ------------------
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  SUBROUTINE CONSTRUCT_COSP_VGRID(gbx,Nlvgrid,use_vgrid,cloudsat,x)
+    type(cosp_gridbox),intent(in) :: gbx ! Gridbox information
+    integer,intent(in) :: Nlvgrid  ! Number of new levels    
+    logical,intent(in) :: use_vgrid! Logical flag that controls the output on a different grid
+    logical,intent(in) :: cloudsat ! TRUE if a CloudSat like grid (480m) is requested
+    type(cosp_vgrid),intent(out) :: x
+    
+    ! Local variables
+    integer :: i
+    real :: zstep
+    
+    x%use_vgrid  = use_vgrid
+    x%csat_vgrid = cloudsat
+    
+    ! Dimensions
+    x%Npoints  = gbx%Npoints
+    x%Ncolumns = gbx%Ncolumns
+    x%Nlevels  = gbx%Nlevels
+    
+    ! --- Allocate arrays ---
+    if (use_vgrid) then
+      x%Nlvgrid = Nlvgrid
+    else 
+      x%Nlvgrid = gbx%Nlevels
+    endif
+    allocate(x%z(x%Nlvgrid),x%zl(x%Nlvgrid),x%zu(x%Nlvgrid))
+    allocate(x%mz(x%Nlevels),x%mzl(x%Nlevels),x%mzu(x%Nlevels))
+    
+    ! --- Model vertical levels ---
+    ! Use height levels of first model gridbox
+    x%mz  = gbx%zlev(1,:)
+    x%mzl = gbx%zlev_half(1,:)
+    x%mzu(1:x%Nlevels-1) = gbx%zlev_half(1,2:x%Nlevels)
+    x%mzu(x%Nlevels) = gbx%zlev(1,x%Nlevels) + (gbx%zlev(1,x%Nlevels) - x%mzl(x%Nlevels))
+    
+    if (use_vgrid) then
+      ! --- Initialise to zero ---
+      x%z  = 0.0
+      x%zl = 0.0
+      x%zu = 0.0
+      if (cloudsat) then ! --- CloudSat grid requested ---
+         zstep = 480.0
+      else
+         ! Other grid requested. Constant vertical spacing with top at 20 km
+         zstep = 20000.0/x%Nlvgrid
+      endif
+      do i=1,x%Nlvgrid
+         x%zl(i) = (i-1)*zstep
+         x%zu(i) = i*zstep
+      enddo
+      x%z = (x%zl + x%zu)/2.0
+    else
+      x%z  = x%mz
+      x%zl = x%mzl
+      x%zu = x%mzu
+    endif
+    
+  END SUBROUTINE CONSTRUCT_COSP_VGRID
+
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+!------------------ SUBROUTINE FREE_COSP_VGRID ------------------
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  SUBROUTINE FREE_COSP_VGRID(x)
+    type(cosp_vgrid),intent(inout) :: x
+
+    deallocate(x%z, x%zl, x%zu, x%mz, x%mzl, x%mzu)
+  END SUBROUTINE FREE_COSP_VGRID
+
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+!------------- SUBROUTINE CONSTRUCT_COSP_SGLIDAR ------------------
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  SUBROUTINE CONSTRUCT_COSP_SGLIDAR(cfg,Npoints,Ncolumns,Nlevels,Nhydro,Nrefl,x)
+    type(cosp_config),intent(in) :: cfg ! Configuration options
+    integer,intent(in) :: Npoints  ! Number of sampled points
+    integer,intent(in) :: Ncolumns ! Number of subgrid columns
+    integer,intent(in) :: Nlevels  ! Number of model levels
+    integer,intent(in) :: Nhydro   ! Number of hydrometeors
+    integer,intent(in) :: Nrefl    ! Number of parasol reflectances ! parasol
+    type(cosp_sglidar),intent(out) :: x
+    ! Local variables
+    integer :: i,j,k,l,m
+    
+    ! Allocate minumum storage if simulator not used
+    if (cfg%Llidar_sim) then
+      i = Npoints
+      j = Ncolumns
+      k = Nlevels
+      l = Nhydro
+      m = Nrefl
+    else
+      i = 1
+      j = 1
+      k = 1
+      l = 1
+      m = 1
+    endif
+    
+    ! Dimensions
+    x%Npoints  = i
+    x%Ncolumns = j
+    x%Nlevels  = k
+    x%Nhydro   = l
+    x%Nrefl    = m
+    
+    ! --- Allocate arrays ---
+    allocate(x%beta_mol(i,k), x%beta_tot(i,j,k), &
+             x%tau_tot(i,j,k),x%refl(i,j,m), &
+             x%temp_tot(i,k),x%betaperp_tot(i,j,k))
+    ! --- Initialise to zero ---
+    x%beta_mol   = 0.0
+    x%beta_tot   = 0.0
+    x%tau_tot    = 0.0
+    x%refl       = 0.0 ! parasol
+    x%temp_tot   	= 0.0
+    x%betaperp_tot 	= 0.0	
+  END SUBROUTINE CONSTRUCT_COSP_SGLIDAR
+
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+!------------------ SUBROUTINE FREE_COSP_SGLIDAR ------------------
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  SUBROUTINE FREE_COSP_SGLIDAR(x)
+    type(cosp_sglidar),intent(inout) :: x
+
+    deallocate(x%beta_mol, x%beta_tot, x%tau_tot, x%refl, &
+               x%temp_tot, x%betaperp_tot)
+
+  END SUBROUTINE FREE_COSP_SGLIDAR
+
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+!------------- SUBROUTINE CONSTRUCT_COSP_SGRADAR ------------------
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  SUBROUTINE CONSTRUCT_COSP_SGRADAR(cfg,Npoints,Ncolumns,Nlevels,Nhydro,x)
+    type(cosp_config),intent(in) :: cfg ! Configuration options
+    integer,intent(in) :: Npoints  ! Number of sampled points
+    integer,intent(in) :: Ncolumns ! Number of subgrid columns
+    integer,intent(in) :: Nlevels  ! Number of model levels
+    integer,intent(in) :: Nhydro   ! Number of hydrometeors
+    type(cosp_sgradar),intent(out) :: x
+    ! Local variables
+    integer :: i,j,k,l
+    
+    if (cfg%Lradar_sim) then
+      i = Npoints
+      j = Ncolumns
+      k = Nlevels
+      l = Nhydro
+    else ! Allocate minumum storage if simulator not used
+      i = 1
+      j = 1
+      k = 1
+      l = 1
+    endif
+    
+    ! Dimensions
+    x%Npoints  = i
+    x%Ncolumns = j
+    x%Nlevels  = k
+    x%Nhydro   = l
+    
+    ! --- Allocate arrays ---
+    allocate(x%att_gas(i,k), x%Ze_tot(i,j,k))
+    ! --- Initialise to zero ---
+    x%att_gas   = 0.0
+    x%Ze_tot    = 0.0
+    ! The following line give a compilation error on the Met Office NEC
+!     call zero_real(x%Z_hydro, x%att_hydro)
+!     f90: error(666): cosp_types.f90, line nnn:
+!                                        Actual argument corresponding to dummy
+!                                        argument of ELEMENTAL subroutine
+!                                        "zero_real" with INTENET(OUT) attribute
+!                                        is not array.
+  END SUBROUTINE CONSTRUCT_COSP_SGRADAR
+
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+!------------------ SUBROUTINE FREE_COSP_SGRADAR ----------------
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  SUBROUTINE FREE_COSP_SGRADAR(x)
+    type(cosp_sgradar),intent(inout) :: x
+
+    deallocate(x%att_gas, x%Ze_tot)
+  END SUBROUTINE FREE_COSP_SGRADAR
+
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+!----------- SUBROUTINE CONSTRUCT_COSP_RADARSTATS ---------------
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  SUBROUTINE CONSTRUCT_COSP_RADARSTATS(cfg,Npoints,Ncolumns,Nlevels,Nhydro,x)
+    type(cosp_config),intent(in) :: cfg ! Configuration options
+    integer,intent(in) :: Npoints  ! Number of sampled points
+    integer,intent(in) :: Ncolumns ! Number of subgrid columns
+    integer,intent(in) :: Nlevels  ! Number of model levels
+    integer,intent(in) :: Nhydro   ! Number of hydrometeors
+    type(cosp_radarstats),intent(out) :: x    
+    ! Local variables
+    integer :: i,j,k,l
+    
+    ! Allocate minumum storage if simulator not used
+    if (cfg%Lradar_sim) then
+      i = Npoints
+      j = Ncolumns
+      k = Nlevels
+      l = Nhydro
+    else
+      i = 1
+      j = 1
+      k = 1
+      l = 1
+    endif
+    
+    ! Dimensions
+    x%Npoints  = i
+    x%Ncolumns = j
+    x%Nlevels  = k
+    x%Nhydro   = l
+    
+    ! --- Allocate arrays ---
+    allocate(x%cfad_ze(i,DBZE_BINS,k),x%lidar_only_freq_cloud(i,k))
+    allocate(x%radar_lidar_tcc(i))
+    ! --- Initialise to zero ---
+    x%cfad_ze = 0.0
+    x%lidar_only_freq_cloud = 0.0
+    x%radar_lidar_tcc = 0.0
+  END SUBROUTINE CONSTRUCT_COSP_RADARSTATS
+
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+!------------------ SUBROUTINE FREE_COSP_RADARSTATS -------------
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  SUBROUTINE FREE_COSP_RADARSTATS(x)
+    type(cosp_radarstats),intent(inout) :: x
+
+    deallocate(x%cfad_ze,x%lidar_only_freq_cloud,x%radar_lidar_tcc)
+  END SUBROUTINE FREE_COSP_RADARSTATS
+
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+!----------- SUBROUTINE CONSTRUCT_COSP_LIDARSTATS ---------------
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  SUBROUTINE CONSTRUCT_COSP_LIDARSTATS(cfg,Npoints,Ncolumns,Nlevels,Nhydro,Nrefl,x)
+    type(cosp_config),intent(in) :: cfg ! Configuration options
+    integer,intent(in) :: Npoints  ! Number of sampled points
+    integer,intent(in) :: Ncolumns ! Number of subgrid columns
+    integer,intent(in) :: Nlevels  ! Number of model levels
+    integer,intent(in) :: Nhydro   ! Number of hydrometeors
+    integer,intent(in) :: Nrefl    ! Number of parasol reflectance
+    type(cosp_lidarstats),intent(out) :: x
+    ! Local variables
+    integer :: i,j,k,l,m
+    
+    ! Allocate minumum storage if simulator not used
+    if (cfg%Llidar_sim) then
+      i = Npoints
+      j = Ncolumns
+      k = Nlevels
+      l = Nhydro
+      m = Nrefl
+    else
+      i = 1
+      j = 1
+      k = 1
+      l = 1
+      m = 1
+    endif
+    
+    ! Dimensions
+    x%Npoints  = i
+    x%Ncolumns = j
+    x%Nlevels  = k
+    x%Nhydro   = l
+    x%Nrefl    = m
+    
+    ! --- Allocate arrays ---
+    allocate(x%srbval(SR_BINS),x%cfad_sr(i,SR_BINS,k), &
+             x%lidarcld(i,k), x%cldlayer(i,LIDAR_NCAT), x%parasolrefl(i,m))
+    allocate(x%lidarcldphase(i,k,6),x%lidarcldtmp(i,LIDAR_NTEMP,5),&
+             x%cldlayerphase(i,LIDAR_NCAT,6))
+    allocate(x%lidarcldtype(i,k,LIDAR_NTYPE+1),x%cldtype(i,LIDAR_NTYPE)) !OPAQ
+!    allocate(x%profSR(i,j,k),x%proftemp(i,k))                            !TIBO
+    allocate(x%profSR(i,k,j),x%proftemp(i,k))                            !TIBO2
+    ! --- Initialise to zero ---
+    x%srbval    = 0.0
+    x%cfad_sr   = 0.0
+    x%lidarcld  = 0.0
+    x%cldlayer  = 0.0
+    x%parasolrefl  = 0.0
+    x%lidarcldphase  = 0.0
+    x%cldlayerphase  = 0.0
+    x%lidarcldtmp  = 0.0
+    x%lidarcldtype  = 0.0 !OPAQ
+    x%cldtype  = 0.0      !OPAQ
+    x%profSR   = 0.0      !TIBO
+    x%proftemp = 0.0      !TIBO
+
+   END SUBROUTINE CONSTRUCT_COSP_LIDARSTATS
+
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+!------------------ SUBROUTINE FREE_COSP_LIDARSTATS -------------
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  SUBROUTINE FREE_COSP_LIDARSTATS(x)
+    type(cosp_lidarstats),intent(inout) :: x
+
+    deallocate(x%srbval, x%cfad_sr, x%lidarcld, x%cldlayer, x%parasolrefl)
+    deallocate(x%cldlayerphase, x%lidarcldtmp, x%lidarcldphase)
+    deallocate(x%lidarcldtype, x%cldtype) !OPAQ
+    deallocate(x%profSR, x%proftemp)      !TIBO
+  END SUBROUTINE FREE_COSP_LIDARSTATS
+
+
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+!------------- SUBROUTINE CONSTRUCT_COSP_SUBGRID ------------------
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  SUBROUTINE CONSTRUCT_COSP_SUBGRID(Npoints,Ncolumns,Nlevels,y)
+    integer,intent(in) :: Npoints, & ! Number of gridpoints
+                                        Ncolumns, & ! Number of columns
+                                        Nlevels   ! Number of levels
+    type(cosp_subgrid),intent(out) :: y
+    
+    ! Dimensions
+    y%Npoints  = Npoints
+    y%Ncolumns = Ncolumns
+    y%Nlevels  = Nlevels
+
+    ! --- Allocate arrays ---
+    allocate(y%frac_out(Npoints,Ncolumns,Nlevels))
+    if (Ncolumns > 1) then
+      allocate(y%prec_frac(Npoints,Ncolumns,Nlevels))
+    else ! CRM mode, not needed
+      allocate(y%prec_frac(1,1,1))
+    endif
+    ! --- Initialise to zero ---
+    y%prec_frac = 0.0
+    y%frac_out  = 0.0
+    ! The following line gives a compilation error on the Met Office NEC
+!     call zero_real(y%mr_hydro)
+!     f90: error(666): cosp_types.f90, line nnn:
+!                                        Actual argument corresponding to dummy
+!                                        argument of ELEMENTAL subroutine
+!                                        "zero_real" with INTENET(OUT) attribute
+!                                        is not array.
+
+  END SUBROUTINE CONSTRUCT_COSP_SUBGRID
+
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+!------------- SUBROUTINE FREE_COSP_SUBGRID -----------------------
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  SUBROUTINE FREE_COSP_SUBGRID(y)
+    type(cosp_subgrid),intent(inout) :: y
+    
+    ! --- Deallocate arrays ---
+    deallocate(y%prec_frac, y%frac_out)
+        
+  END SUBROUTINE FREE_COSP_SUBGRID
+
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+!------------- SUBROUTINE CONSTRUCT_COSP_SGHYDRO -----------------
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  SUBROUTINE CONSTRUCT_COSP_SGHYDRO(Npoints,Ncolumns,Nlevels,Nhydro,y)
+    integer,intent(in) :: Npoints, & ! Number of gridpoints
+                                        Ncolumns, & ! Number of columns
+                                        Nhydro, & ! Number of hydrometeors
+                                        Nlevels   ! Number of levels
+    type(cosp_sghydro),intent(out) :: y
+    
+    ! Dimensions
+    y%Npoints  = Npoints
+    y%Ncolumns = Ncolumns
+    y%Nlevels  = Nlevels
+    y%Nhydro   = Nhydro
+
+    ! --- Allocate arrays ---
+    allocate(y%mr_hydro(Npoints,Ncolumns,Nlevels,Nhydro), &
+             y%Reff(Npoints,Ncolumns,Nlevels,Nhydro), &
+             y%Np(Npoints,Ncolumns,Nlevels,Nhydro)) ! added by roj with Quickbeam V3
+             
+    ! --- Initialise to zero ---
+    y%mr_hydro = 0.0
+    y%Reff     = 0.0
+    y%Np       = 0.0                    ! added by roj with Quickbeam V3
+
+  END SUBROUTINE CONSTRUCT_COSP_SGHYDRO
+
+ !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+!------------- SUBROUTINE FREE_COSP_SGHYDRO -----------------------
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  SUBROUTINE FREE_COSP_SGHYDRO(y)
+    type(cosp_sghydro),intent(inout) :: y
+    
+    ! --- Deallocate arrays ---
+    deallocate(y%mr_hydro, y%Reff, y%Np)        ! added by Roj with Quickbeam V3
+        
+  END SUBROUTINE FREE_COSP_SGHYDRO
+ 
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+!------------- SUBROUTINE CONSTRUCT_COSP_GRIDBOX ------------------
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  SUBROUTINE CONSTRUCT_COSP_GRIDBOX(time,time_bnds,radar_freq,surface_radar,use_mie_tables,use_gas_abs,do_ray,melt_lay,k2, &
+                                   Npoints,Nlevels,Ncolumns,Nhydro,Nprmts_max_hydro,Naero,Nprmts_max_aero,Npoints_it, &
+                                   lidar_ice_type,isccp_top_height,isccp_top_height_direction,isccp_overlap,isccp_emsfc_lw, &
+                                   use_precipitation_fluxes,use_reff, &
+                                   ! RTTOV inputs
+                                   Plat,Sat,Inst,Nchan,ZenAng,Ichan,SurfEm,co2,ch4,n2o,co,&
+                                   y,load_LUT)
+    double precision,intent(in) :: time ! Time since start of run [days] 
+    double precision,intent(in) :: time_bnds(2) ! Time boundaries
+    real,intent(in)    :: radar_freq, & ! Radar frequency [GHz]
+                          k2            ! |K|^2, -1=use frequency dependent default
+    integer,intent(in) :: &
+        surface_radar, &  ! surface=1,spaceborne=0
+        use_mie_tables, & ! use a precomputed lookup table? yes=1,no=0,2=use first column everywhere
+        use_gas_abs, &    ! include gaseous absorption? yes=1,no=0
+        do_ray, &         ! calculate/output Rayleigh refl=1, not=0
+        melt_lay          ! melting layer model off=0, on=1
+    integer,intent(in) :: Npoints   ! Number of gridpoints
+    integer,intent(in) :: Nlevels   ! Number of levels
+    integer,intent(in) :: Ncolumns  ! Number of columns
+    integer,intent(in) :: Nhydro    ! Number of hydrometeors
+    integer,intent(in) :: Nprmts_max_hydro    ! Max number of parameters for hydrometeor size distributions
+    integer,intent(in) :: Naero    ! Number of aerosol species
+    integer,intent(in) :: Nprmts_max_aero    ! Max number of parameters for aerosol size distributions
+    integer,intent(in) :: Npoints_it   ! Number of gridpoints processed in one iteration
+    integer,intent(in) :: lidar_ice_type ! Ice particle shape in lidar calculations (0=ice-spheres ; 1=ice-non-spherical)
+    integer,intent(in) :: isccp_top_height
+    integer,intent(in) :: isccp_top_height_direction
+    integer,intent(in) :: isccp_overlap
+    real,intent(in)    :: isccp_emsfc_lw
+    logical,intent(in) :: use_precipitation_fluxes,use_reff
+    integer,intent(in) :: Plat
+    integer,intent(in) :: Sat
+    integer,intent(in) :: Inst
+    integer,intent(in) :: Nchan
+    integer,intent(in) :: Ichan(Nchan)
+    real,intent(in)    :: SurfEm(Nchan)
+    real,intent(in)    :: ZenAng
+    real,intent(in)    :: co2,ch4,n2o,co
+    type(cosp_gridbox),intent(out) :: y
+    logical,intent(in),optional :: load_LUT
+
+
+    ! local variables
+    character*240 :: LUT_file_name
+    logical :: local_load_LUT
+
+    if (present(load_LUT)) then
+      local_load_LUT = load_LUT
+    else
+      local_load_LUT = RADAR_SIM_LOAD_scale_LUTs_flag
+    endif
+
+    ! Dimensions and scalars
+    y%radar_freq       = radar_freq
+    y%surface_radar    = surface_radar
+    y%use_mie_tables   = use_mie_tables
+    y%use_gas_abs      = use_gas_abs
+    y%do_ray           = do_ray
+    y%melt_lay         = melt_lay
+    y%k2               = k2
+    y%Npoints          = Npoints
+    y%Nlevels          = Nlevels
+    y%Ncolumns         = Ncolumns
+    y%Nhydro           = Nhydro
+    y%Nprmts_max_hydro = Nprmts_max_hydro
+    y%Naero            = Naero
+    y%Nprmts_max_aero  = Nprmts_max_aero
+    y%Npoints_it       = Npoints_it
+    y%lidar_ice_type   = lidar_ice_type
+    y%isccp_top_height = isccp_top_height
+    y%isccp_top_height_direction = isccp_top_height_direction
+    y%isccp_overlap    = isccp_overlap
+    y%isccp_emsfc_lw   = isccp_emsfc_lw
+    y%use_precipitation_fluxes = use_precipitation_fluxes
+    y%use_reff = use_reff
+    
+    y%time      = time
+    y%time_bnds = time_bnds
+    
+    ! RTTOV parameters
+    y%Plat   = Plat
+    y%Sat    = Sat
+    y%Inst   = Inst
+    y%Nchan  = Nchan
+    y%ZenAng = ZenAng
+    y%co2    = co2
+    y%ch4    = ch4
+    y%n2o    = n2o
+    y%co     = co
+
+    ! --- Allocate arrays ---
+    ! Gridbox information (Npoints,Nlevels)
+    allocate(y%zlev(Npoints,Nlevels), y%zlev_half(Npoints,Nlevels), y%dlev(Npoints,Nlevels), &
+             y%p(Npoints,Nlevels), y%ph(Npoints,Nlevels), y%T(Npoints,Nlevels), &
+             y%q(Npoints,Nlevels), y%sh(Npoints,Nlevels), &
+             y%dtau_s(Npoints,Nlevels), y%dtau_c(Npoints,Nlevels), &
+             y%dem_s(Npoints,Nlevels), y%dem_c(Npoints,Nlevels), &
+             y%tca(Npoints,Nlevels), y%cca(Npoints,Nlevels), &
+             y%rain_ls(Npoints,Nlevels), y%rain_cv(Npoints,Nlevels), y%grpl_ls(Npoints,Nlevels), &
+             y%snow_ls(Npoints,Nlevels), y%snow_cv(Npoints,Nlevels),y%mr_ozone(Npoints,Nlevels))
+             
+             
+    ! Surface information and geolocation (Npoints)
+    allocate(y%toffset(Npoints), y%longitude(Npoints),y%latitude(Npoints),y%psfc(Npoints), y%land(Npoints), &
+             y%sunlit(Npoints),y%skt(Npoints),y%u_wind(Npoints),y%v_wind(Npoints))
+    ! Hydrometeors concentration and distribution parameters
+    allocate(y%mr_hydro(Npoints,Nlevels,Nhydro), &
+             y%dist_prmts_hydro(Nprmts_max_hydro,Nhydro), &
+             y%Reff(Npoints,Nlevels,Nhydro), &
+             y%Np(Npoints,Nlevels,Nhydro))      ! added by Roj with Quickbeam V3
+    ! Aerosols concentration and distribution parameters
+    allocate(y%conc_aero(Npoints,Nlevels,Naero), y%dist_type_aero(Naero), &
+             y%dist_prmts_aero(Npoints,Nlevels,Nprmts_max_aero,Naero))
+    
+    ! RTTOV channels and sfc. emissivity
+    allocate(y%ichan(Nchan),y%surfem(Nchan))
+    
+    ! RTTOV parameters
+    y%ichan   =  ichan
+    y%surfem  =  surfem
+    
+    ! --- Initialise to zero ---
+    y%zlev      = 0.0
+    y%zlev_half = 0.0
+    y%dlev      = 0.0
+    y%p         = 0.0
+    y%ph        = 0.0
+    y%T         = 0.0
+    y%q         = 0.0
+    y%sh        = 0.0
+    y%dtau_s    = 0.0
+    y%dtau_c    = 0.0
+    y%dem_s     = 0.0
+    y%dem_c     = 0.0
+    y%tca       = 0.0
+    y%cca       = 0.0
+    y%rain_ls   = 0.0
+    y%rain_cv   = 0.0
+    y%grpl_ls   = 0.0
+    y%snow_ls   = 0.0
+    y%snow_cv   = 0.0
+    y%Reff      = 0.0
+    y%Np        = 0.0 ! added by Roj with Quickbeam V3
+    y%mr_ozone  = 0.0
+    y%u_wind    = 0.0
+    y%v_wind    = 0.0
+
+    
+    ! (Npoints)
+    y%toffset = 0.0
+    y%longitude = 0.0
+    y%latitude = 0.0
+    y%psfc = 0.0
+    y%land = 0.0
+    y%sunlit = 0.0
+    y%skt = 0.0
+    ! (Npoints,Nlevels,Nhydro)
+!     y%fr_hydro = 0.0
+    y%mr_hydro = 0.0
+    ! Others
+    y%dist_prmts_hydro = 0.0 ! (Nprmts_max_hydro,Nhydro)
+    y%conc_aero        = 0.0 ! (Npoints,Nlevels,Naero)
+    y%dist_type_aero   = 0   ! (Naero)
+    y%dist_prmts_aero  = 0.0 ! (Npoints,Nlevels,Nprmts_max_aero,Naero)
+
+
+    ! NOTE: This location use to contain initialization of some radar simulator variables
+    ! this initialization (including use of the variable "dist_prmts_hydro" - now obselete) 
+    ! has been unified in the quickbeam v3 subroutine "radar_simulator_init".   Roj, June 2010
+
+    ! --- Initialize the distributional parameters for hydrometeors in radar simulator
+
+!    write(*,*) 'RADAR_SIM microphysics scheme is set to: ', &
+!            trim(RADAR_SIM_MICROPHYSICS_SCHEME_NAME)
+
+
+    if(y%Nhydro.ne.N_HYDRO) then
+
+        write(*,*) 'Number of hydrometeor input to subroutine', &
+               ' CONSTRUCT_COSP_GRIDBOX does not match value', &
+               ' specified in cosp_constants.f90!'
+        write(*,*) 
+    endif
+
+    ! NOTE: SAVE_scale_LUTs_flag is hard codded as .false. here 
+    ! so that radar simulator will NOT update LUT each time it 
+    ! is called, but rather will update when "Free_COSP_GRIDBOX" is called!
+    ! Roj, June 2010
+
+    LUT_file_name = trim(RADAR_SIM_LUT_DIRECTORY) // &
+                trim(RADAR_SIM_MICROPHYSICS_SCHEME_NAME)
+
+    call radar_simulator_init(radar_freq,k2, &
+                      use_gas_abs,do_ray,R_UNDEF, &
+                      y%Nhydro, &
+                      HCLASS_TYPE,HCLASS_PHASE, &
+                      HCLASS_DMIN,HCLASS_DMAX, &
+                      HCLASS_APM,HCLASS_BPM,HCLASS_RHO, &
+                      HCLASS_P1,HCLASS_P2,HCLASS_P3, &
+                      local_load_LUT,    &
+                      .false., &
+                      LUT_file_name, &
+                      y%hp)
+
+END SUBROUTINE CONSTRUCT_COSP_GRIDBOX
+
+
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+!------------- SUBROUTINE FREE_COSP_GRIDBOX -----------------------
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  SUBROUTINE FREE_COSP_GRIDBOX(y,dglobal,save_LUT)
+
+    use scale_LUTs_io
+
+    type(cosp_gridbox),intent(inout) :: y
+    logical,intent(in),optional :: dglobal
+    logical,intent(in),optional :: save_LUT
+
+    logical :: local_save_LUT
+
+    if (present(save_LUT)) then
+      local_save_LUT = save_LUT
+    else
+      local_save_LUT = RADAR_SIM_UPDATE_scale_LUTs_flag
+    endif
+
+    ! save any updates to radar simulator LUT
+    if (local_save_LUT) call save_scale_LUTs(y%hp)
+
+    deallocate(y%zlev, y%zlev_half, y%dlev, y%p, y%ph, y%T, y%q, &
+               y%sh, y%dtau_s, y%dtau_c, y%dem_s, y%dem_c, &
+               y%toffset, y%longitude,y%latitude,y%psfc, y%land, y%tca, y%cca, &
+               y%mr_hydro, y%dist_prmts_hydro, &
+               y%conc_aero, y%dist_type_aero, y%dist_prmts_aero, &
+               y%rain_ls, y%rain_cv, y%snow_ls, y%snow_cv, y%grpl_ls, &
+               y%sunlit, y%skt, y%Reff,y%Np, &
+               y%ichan,y%surfem, &
+               y%mr_ozone,y%u_wind,y%v_wind)
+
+  END SUBROUTINE FREE_COSP_GRIDBOX
+
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+!------------- SUBROUTINE COSP_GRIDBOX_CPHP ----------------------
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+SUBROUTINE COSP_GRIDBOX_CPHP(x,y)
+    type(cosp_gridbox),intent(in) :: x
+    type(cosp_gridbox),intent(inout) :: y
+
+    integer :: i,j,k,sz(3)
+    double precision :: tny
+
+    tny = tiny(tny)
+    y%hp%p1      = x%hp%p1
+    y%hp%p2      = x%hp%p2
+    y%hp%p3      = x%hp%p3
+    y%hp%dmin    = x%hp%dmin
+    y%hp%dmax    = x%hp%dmax
+    y%hp%apm     = x%hp%apm
+    y%hp%bpm     = x%hp%bpm
+    y%hp%rho     = x%hp%rho
+    y%hp%dtype   = x%hp%dtype
+    y%hp%col     = x%hp%col
+    y%hp%cp      = x%hp%cp
+    y%hp%phase   = x%hp%phase
+
+    y%hp%fc      = x%hp%fc
+    y%hp%rho_eff = x%hp%rho_eff
+    ! y%hp%ifc     = x%hp%ifc       obsolete, Roj, June 2010
+    ! y%hp%idd     = x%hp%idd
+    sz = shape(x%hp%Z_scale_flag)
+    do k=1,sz(3)
+      do j=1,sz(2)
+        do i=1,sz(1)
+           if (x%hp%N_scale_flag(i,k))   y%hp%N_scale_flag(i,k)      = .true.
+           if (x%hp%Z_scale_flag(i,j,k)) y%hp%Z_scale_flag(i,j,k)    = .true.
+           if (abs(x%hp%Ze_scaled(i,j,k)) > tny) y%hp%Ze_scaled(i,j,k) = x%hp%Ze_scaled(i,j,k)
+           if (abs(x%hp%Zr_scaled(i,j,k)) > tny) y%hp%Zr_scaled(i,j,k) = x%hp%Zr_scaled(i,j,k)
+           if (abs(x%hp%kr_scaled(i,j,k)) > tny) y%hp%kr_scaled(i,j,k) = x%hp%kr_scaled(i,j,k)
+        enddo
+      enddo
+    enddo
+    
+END SUBROUTINE COSP_GRIDBOX_CPHP
+
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+!------------- SUBROUTINE COSP_GRIDBOX_CPSECTION -----------------
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+SUBROUTINE COSP_GRIDBOX_CPSECTION(ix,iy,x,y)
+    integer,intent(in),dimension(2) :: ix,iy
+    type(cosp_gridbox),intent(in) :: x
+    type(cosp_gridbox),intent(inout) :: y
+    
+    ! --- Copy arrays without Npoints as dimension ---
+    y%dist_prmts_hydro = x%dist_prmts_hydro
+    y%dist_type_aero   = x%dist_type_aero
+  
+    
+!     call cosp_gridbox_cphp(x,y)    
+    
+    ! 1D
+    y%longitude(iy(1):iy(2))  = x%longitude(ix(1):ix(2))
+    y%latitude(iy(1):iy(2))   = x%latitude(ix(1):ix(2))
+    y%psfc(iy(1):iy(2))       = x%psfc(ix(1):ix(2))
+    y%land(iy(1):iy(2))       = x%land(ix(1):ix(2))
+    y%sunlit(iy(1):iy(2))     = x%sunlit(ix(1):ix(2))
+    y%skt(iy(1):iy(2))        = x%skt(ix(1):ix(2))
+    y%u_wind(iy(1):iy(2))     = x%u_wind(ix(1):ix(2))
+    y%v_wind(iy(1):iy(2))     = x%v_wind(ix(1):ix(2))
+    ! 2D
+    y%zlev(iy(1):iy(2),:)      = x%zlev(ix(1):ix(2),:)
+    y%zlev_half(iy(1):iy(2),:) = x%zlev_half(ix(1):ix(2),:)
+    y%dlev(iy(1):iy(2),:)      = x%dlev(ix(1):ix(2),:)
+    y%p(iy(1):iy(2),:)         = x%p(ix(1):ix(2),:)
+    y%ph(iy(1):iy(2),:)        = x%ph(ix(1):ix(2),:)
+    y%T(iy(1):iy(2),:)         = x%T(ix(1):ix(2),:)
+    y%q(iy(1):iy(2),:)         = x%q(ix(1):ix(2),:)
+    y%sh(iy(1):iy(2),:)        = x%sh(ix(1):ix(2),:)
+    y%dtau_s(iy(1):iy(2),:)    = x%dtau_s(ix(1):ix(2),:)
+    y%dtau_c(iy(1):iy(2),:)    = x%dtau_c(ix(1):ix(2),:)
+    y%dem_s(iy(1):iy(2),:)     = x%dem_s(ix(1):ix(2),:)
+    y%dem_c(iy(1):iy(2),:)     = x%dem_c(ix(1):ix(2),:)
+    y%tca(iy(1):iy(2),:)       = x%tca(ix(1):ix(2),:)
+    y%cca(iy(1):iy(2),:)       = x%cca(ix(1):ix(2),:)
+    y%rain_ls(iy(1):iy(2),:)   = x%rain_ls(ix(1):ix(2),:)
+    y%rain_cv(iy(1):iy(2),:)   = x%rain_cv(ix(1):ix(2),:)
+    y%grpl_ls(iy(1):iy(2),:)   = x%grpl_ls(ix(1):ix(2),:)
+    y%snow_ls(iy(1):iy(2),:)   = x%snow_ls(ix(1):ix(2),:)
+    y%snow_cv(iy(1):iy(2),:)   = x%snow_cv(ix(1):ix(2),:)
+    y%mr_ozone(iy(1):iy(2),:)  = x%mr_ozone(ix(1):ix(2),:)
+    ! 3D
+    y%Reff(iy(1):iy(2),:,:)      = x%Reff(ix(1):ix(2),:,:)
+    y%Np(iy(1):iy(2),:,:)      = x%Np(ix(1):ix(2),:,:)   ! added by Roj with Quickbeam V3
+    y%conc_aero(iy(1):iy(2),:,:) = x%conc_aero(ix(1):ix(2),:,:)
+    y%mr_hydro(iy(1):iy(2),:,:)  = x%mr_hydro(ix(1):ix(2),:,:)
+    ! 4D
+    y%dist_prmts_aero(iy(1):iy(2),:,:,:) = x%dist_prmts_aero(ix(1):ix(2),:,:,:)
+
+END SUBROUTINE COSP_GRIDBOX_CPSECTION
+ 
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+!------------- SUBROUTINE COSP_SUBGRID_CPSECTION -----------------
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+SUBROUTINE COSP_SUBGRID_CPSECTION(ix,iy,x,y)
+    integer,intent(in),dimension(2) :: ix,iy
+    type(cosp_subgrid),intent(in) :: x
+    type(cosp_subgrid),intent(inout) :: y
+    
+    y%prec_frac(iy(1):iy(2),:,:)  = x%prec_frac(ix(1):ix(2),:,:)
+    y%frac_out(iy(1):iy(2),:,:)   = x%frac_out(ix(1):ix(2),:,:)
+END SUBROUTINE COSP_SUBGRID_CPSECTION
+
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+!------------- SUBROUTINE COSP_SGRADAR_CPSECTION -----------------
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+SUBROUTINE COSP_SGRADAR_CPSECTION(ix,iy,x,y)
+    integer,intent(in),dimension(2) :: ix,iy
+    type(cosp_sgradar),intent(in) :: x
+    type(cosp_sgradar),intent(inout) :: y
+    
+    y%att_gas(iy(1):iy(2),:)  = x%att_gas(ix(1):ix(2),:)
+    y%Ze_tot(iy(1):iy(2),:,:) = x%Ze_tot(ix(1):ix(2),:,:)
+END SUBROUTINE COSP_SGRADAR_CPSECTION
+
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+!------------- SUBROUTINE COSP_SGLIDAR_CPSECTION -----------------
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+SUBROUTINE COSP_SGLIDAR_CPSECTION(ix,iy,x,y)
+    integer,intent(in),dimension(2) :: ix,iy
+    type(cosp_sglidar),intent(in) :: x
+    type(cosp_sglidar),intent(inout) :: y
+
+    y%temp_tot(iy(1):iy(2),:)       = x%temp_tot(ix(1):ix(2),:)
+    y%betaperp_tot(iy(1):iy(2),:,:) = x%betaperp_tot(ix(1):ix(2),:,:)
+    y%beta_mol(iy(1):iy(2),:)       = x%beta_mol(ix(1):ix(2),:)
+    y%beta_tot(iy(1):iy(2),:,:)     = x%beta_tot(ix(1):ix(2),:,:)
+    y%tau_tot(iy(1):iy(2),:,:)      = x%tau_tot(ix(1):ix(2),:,:)
+    y%refl(iy(1):iy(2),:,:)         = x%refl(ix(1):ix(2),:,:)
+END SUBROUTINE COSP_SGLIDAR_CPSECTION
+
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+!------------- SUBROUTINE COSP_ISCCP_CPSECTION -----------------
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+SUBROUTINE COSP_ISCCP_CPSECTION(ix,iy,x,y)
+    integer,intent(in),dimension(2) :: ix,iy
+    type(cosp_isccp),intent(in) :: x
+    type(cosp_isccp),intent(inout) :: y
+
+    y%fq_isccp(iy(1):iy(2),:,:)  = x%fq_isccp(ix(1):ix(2),:,:)
+    y%totalcldarea(iy(1):iy(2))  = x%totalcldarea(ix(1):ix(2))
+    y%meantb(iy(1):iy(2))        = x%meantb(ix(1):ix(2))
+    y%meantbclr(iy(1):iy(2))     = x%meantbclr(ix(1):ix(2))
+    y%meanptop(iy(1):iy(2))      = x%meanptop(ix(1):ix(2))
+    y%meantaucld(iy(1):iy(2))    = x%meantaucld(ix(1):ix(2))
+    y%meanalbedocld(iy(1):iy(2)) = x%meanalbedocld(ix(1):ix(2))
+    y%boxtau(iy(1):iy(2),:)      = x%boxtau(ix(1):ix(2),:)
+    y%boxptop(iy(1):iy(2),:)     = x%boxptop(ix(1):ix(2),:)
+END SUBROUTINE COSP_ISCCP_CPSECTION
+
+
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+!------------- SUBROUTINE COSP_MISR_CPSECTION -----------------
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+SUBROUTINE COSP_MISR_CPSECTION(ix,iy,x,y)
+    integer,intent(in),dimension(2) :: ix,iy
+    type(cosp_misr),intent(in) :: x
+    type(cosp_misr),intent(inout) :: y
+            
+    y%fq_MISR(iy(1):iy(2),:,:)                 = x%fq_MISR(ix(1):ix(2),:,:)
+    y%MISR_meanztop(iy(1):iy(2))               = x%MISR_meanztop(ix(1):ix(2))
+    y%MISR_cldarea(iy(1):iy(2))                = x%MISR_cldarea(ix(1):ix(2))
+    y%MISR_dist_model_layertops(iy(1):iy(2),:) = x%MISR_dist_model_layertops(ix(1):ix(2),:)
+END SUBROUTINE COSP_MISR_CPSECTION
+
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+!------------- SUBROUTINE COSP_RTTOV_CPSECTION -------------------
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+SUBROUTINE COSP_RTTOV_CPSECTION(ix,iy,x,y)
+    integer,intent(in),dimension(2) :: ix,iy
+    type(cosp_rttov),intent(in) :: x
+    type(cosp_rttov),intent(inout) :: y
+            
+    y%tbs(iy(1):iy(2),:) = x%tbs(ix(1):ix(2),:)
+END SUBROUTINE COSP_RTTOV_CPSECTION
+
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+!------------- SUBROUTINE COSP_RADARSTATS_CPSECTION --------------
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+SUBROUTINE COSP_RADARSTATS_CPSECTION(ix,iy,x,y)
+    integer,intent(in),dimension(2) :: ix,iy
+    type(cosp_radarstats),intent(in) :: x
+    type(cosp_radarstats),intent(inout) :: y
+            
+    y%cfad_ze(iy(1):iy(2),:,:)             = x%cfad_ze(ix(1):ix(2),:,:)
+    y%radar_lidar_tcc(iy(1):iy(2))         = x%radar_lidar_tcc(ix(1):ix(2))
+    y%lidar_only_freq_cloud(iy(1):iy(2),:) = x%lidar_only_freq_cloud(ix(1):ix(2),:)
+END SUBROUTINE COSP_RADARSTATS_CPSECTION
+
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+!------------- SUBROUTINE COSP_LIDARSTATS_CPSECTION --------------
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+SUBROUTINE COSP_LIDARSTATS_CPSECTION(ix,iy,x,y)
+    integer,intent(in),dimension(2) :: ix,iy
+    type(cosp_lidarstats),intent(in) :: x
+    type(cosp_lidarstats),intent(inout) :: y
+            
+    y%srbval                     = x%srbval
+    y%cfad_sr(iy(1):iy(2),:,:)   = x%cfad_sr(ix(1):ix(2),:,:)
+    y%lidarcld(iy(1):iy(2),:)    = x%lidarcld(ix(1):ix(2),:)
+    y%cldlayer(iy(1):iy(2),:)    = x%cldlayer(ix(1):ix(2),:)
+    y%parasolrefl(iy(1):iy(2),:) = x%parasolrefl(ix(1):ix(2),:)
+    y%lidarcldphase(iy(1):iy(2),:,:)  = x%lidarcldphase(ix(1):ix(2),:,:)
+    y%cldlayerphase(iy(1):iy(2),:,:)  = x%cldlayerphase(ix(1):ix(2),:,:)
+    y%lidarcldtmp(iy(1):iy(2),:,:)    = x%lidarcldtmp(ix(1):ix(2),:,:)
+    y%lidarcldtype(iy(1):iy(2),:,:)    = x%lidarcldtype(ix(1):ix(2),:,:) !OPAQ
+    y%cldtype(iy(1):iy(2),:)           = x%cldtype(ix(1):ix(2),:)        !OPAQ
+    y%profSR(iy(1):iy(2),:,:)          = x%profSR(ix(1):ix(2),:,:)       !TIBO
+    y%proftemp(iy(1):iy(2),:)          = x%proftemp(ix(1):ix(2),:)       !TIBO
+END SUBROUTINE COSP_LIDARSTATS_CPSECTION
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+!------------- PRINT SUBROUTINES --------------
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+SUBROUTINE COSP_GRIDBOX_PRINT(x)
+    type(cosp_gridbox),intent(in) :: x
+
+    print *, '%%%%----- Information on COSP_GRIDBOX ------'
+    ! Scalars and dimensions
+    print *,  x%Npoints
+    print *,  x%Nlevels
+    print *,  x%Ncolumns
+    print *,  x%Nhydro
+    print *,  x%Nprmts_max_hydro
+    print *,  x%Naero
+    print *,  x%Nprmts_max_aero
+    print *,  x%Npoints_it
+    
+    ! Time [days]
+    print *,  x%time
+    
+    ! Radar ancillary info
+    print *,  x%radar_freq, &
+            x%k2
+    print *,  x%surface_radar, &
+              x%use_mie_tables, &
+              x%use_gas_abs, &
+              x%do_ray, &
+              x%melt_lay
+
+!               print *,  'shape(x%): ',shape(x%)
+ 
+!     type(class_param) ::  hp  ! structure used by radar simulator to store Ze and N scaling constants and other information
+!     type(mie)::  mt           ! structure used by radar simulator to store mie LUT information
+    print *,  x%nsizes
+    
+    ! Lidar
+    print *,  x%lidar_ice_type
+    
+    ! Radar
+    print *,  x%use_precipitation_fluxes
+    print *,  x%use_reff
+    
+    ! Geolocation (Npoints)
+    print *,  'shape(x%longitude): ',shape(x%longitude)
+    print *,  'shape(x%latitude): ',shape(x%latitude)
+    ! Gridbox information (Npoints,Nlevels)
+    print *,  'shape(x%zlev): ',shape(x%zlev)
+    print *,  'shape(x%zlev_half): ',shape(x%zlev_half)
+    print *,  'shape(x%dlev): ',shape(x%dlev)
+    print *,  'shape(x%p): ',shape(x%p)
+    print *,  'shape(x%ph): ',shape(x%ph)
+    print *,  'shape(x%T): ',shape(x%T)
+    print *,  'shape(x%q): ',shape(x%q)
+    print *,  'shape(x%sh): ',shape(x%sh)
+    print *,  'shape(x%dtau_s): ',shape(x%dtau_s)
+    print *,  'shape(x%dtau_c): ',shape(x%dtau_c)
+    print *,  'shape(x%dem_s): ',shape(x%dem_s)
+    print *,  'shape(x%dem_c): ',shape(x%dem_c)
+    print *,  'shape(x%mr_ozone): ',shape(x%mr_ozone)
+
+    ! Point information (Npoints)
+    print *,  'shape(x%land): ',shape(x%land)
+    print *,  'shape(x%psfc): ',shape(x%psfc)
+    print *,  'shape(x%sunlit): ',shape(x%sunlit)
+    print *,  'shape(x%skt): ',shape(x%skt)
+    print *,  'shape(x%u_wind): ',shape(x%u_wind)
+    print *,  'shape(x%v_wind): ',shape(x%v_wind)
+
+    ! TOTAL and CONV cloud fraction for SCOPS
+    print *,  'shape(x%tca): ',shape(x%tca)
+    print *,  'shape(x%cca): ',shape(x%cca)
+    ! Precipitation fluxes on model levels
+    print *,  'shape(x%rain_ls): ',shape(x%rain_ls)
+    print *,  'shape(x%rain_cv): ',shape(x%rain_cv)
+    print *,  'shape(x%snow_ls): ',shape(x%snow_ls)
+    print *,  'shape(x%snow_cv): ',shape(x%snow_cv)
+    print *,  'shape(x%grpl_ls): ',shape(x%grpl_ls)
+    ! Hydrometeors concentration and distribution parameters
+    print *,  'shape(x%mr_hydro): ',shape(x%mr_hydro)
+    print *,  'shape(x%dist_prmts_hydro): ',shape(x%dist_prmts_hydro)
+    ! Effective radius [m]. (Npoints,Nlevels,Nhydro)
+    print *,  'shape(x%Reff): ',shape(x%Reff)
+    print *,  'shape(x%Np): ',shape(x%Np)       ! added by roj with Quickbeam V3
+    ! Aerosols concentration and distribution parameters
+    print *,  'shape(x%conc_aero): ',shape(x%conc_aero)
+    print *,  'shape(x%dist_type_aero): ',shape(x%dist_type_aero)
+    print *,  'shape(x%dist_prmts_aero): ',shape(x%dist_prmts_aero)
+    ! ISCCP simulator inputs
+    print *, x%isccp_top_height
+    print *, x%isccp_top_height_direction
+    print *, x%isccp_overlap
+    print *, x%isccp_emsfc_lw
+  
+    ! RTTOV inputs/options
+    print *, x%plat
+    print *, x%sat
+    print *, x%inst
+    print *, x%Nchan
+    print *,  'shape(x%Ichan): ',x%Ichan
+    print *,  'shape(x%Surfem): ',x%Surfem
+    print *, x%ZenAng
+    print *, x%co2,x%ch4,x%n2o,x%co
+                
+END SUBROUTINE COSP_GRIDBOX_PRINT
+
+SUBROUTINE COSP_MISR_PRINT(x)
+    type(cosp_misr),intent(in) :: x
+
+    print *, '%%%%----- Information on COSP_MISR ------'
+                
+     ! Dimensions
+    print *, x%Npoints
+    print *, x%Ntau
+    print *, x%Nlevels
+
+     ! --- (npoints,ntau,nlevels)
+     !  the fraction of the model grid box covered by each of the MISR cloud types
+     print *,  'shape(x%fq_MISR): ',shape(x%fq_MISR)
+     
+     ! --- (npoints)
+     print *,  'shape(x%MISR_meanztop): ',shape(x%MISR_meanztop)
+     print *,  'shape(x%MISR_cldarea): ',shape(x%MISR_cldarea)
+     ! --- (npoints,nlevels)
+     print *,  'shape(x%MISR_dist_model_layertops): ',shape(x%MISR_dist_model_layertops)
+    
+END SUBROUTINE COSP_MISR_PRINT
+
+SUBROUTINE COSP_ISCCP_PRINT(x)
+    type(cosp_isccp),intent(in) :: x
+            
+    print *, x%Npoints
+    print *, x%Ncolumns
+    print *, x%Nlevels
+
+    print *, '%%%%----- Information on COSP_ISCCP ------'
+    
+     print *, 'shape(x%fq_isccp): ',shape(x%fq_isccp)
+     print *, 'shape(x%totalcldarea): ',shape(x%totalcldarea)
+     print *, 'shape(x%meantb): ',shape(x%meantb)
+     print *, 'shape(x%meantbclr): ',shape(x%meantbclr)
+     
+     print *, 'shape(x%meanptop): ',shape(x%meanptop)
+     print *, 'shape(x%meantaucld): ',shape(x%meantaucld)
+     print *, 'shape(x%meanalbedocld): ',shape(x%meanalbedocld)
+     print *, 'shape(x%boxtau): ',shape(x%boxtau)
+     print *, 'shape(x%boxptop): ',shape(x%boxptop)
+END SUBROUTINE COSP_ISCCP_PRINT
+
+SUBROUTINE COSP_VGRID_PRINT(x)
+    type(cosp_vgrid),intent(in) :: x
+            
+    print *, '%%%%----- Information on COSP_VGRID ------'
+    print *, x%use_vgrid
+    print *, x%csat_vgrid
+    print *, x%Npoints
+    print *, x%Ncolumns
+    print *, x%Nlevels
+    print *, x%Nlvgrid
+    ! Array with dimensions (Nlvgrid)
+    print *, 'shape(x%z): ',shape(x%z)
+    print *, 'shape(x%zl): ',shape(x%zl)
+    print *, 'shape(x%zu): ',shape(x%zu)
+    ! Array with dimensions (Nlevels)
+    print *, 'shape(x%mz): ',shape(x%mz)
+    print *, 'shape(x%mzl): ',shape(x%mzl)
+    print *, 'shape(x%mzu): ',shape(x%mzu)
+END SUBROUTINE COSP_VGRID_PRINT
+
+SUBROUTINE COSP_SGLIDAR_PRINT(x)
+    type(cosp_sglidar),intent(in) :: x
+            
+    print *, '%%%%----- Information on COSP_SGLIDAR ------'
+    ! Dimensions
+    print *, x%Npoints
+    print *, x%Ncolumns
+    print *, x%Nlevels
+    print *, x%Nhydro
+    print *, x%Nrefl
+    ! Arrays with dimensions (Npoints,Nlevels)
+    print *, 'shape(x%beta_mol): ',shape(x%beta_mol)
+    ! Arrays with dimensions (Npoints,Ncolumns,Nlevels)
+    print *, 'shape(x%beta_tot): ',shape(x%beta_tot)
+    print *, 'shape(x%tau_tot): ',shape(x%tau_tot)
+    ! Arrays with dimensions (Npoints,Ncolumns,Nrefl)
+    print *, 'shape(x%refl): ',shape(x%refl)
+END SUBROUTINE COSP_SGLIDAR_PRINT
+
+SUBROUTINE COSP_SGRADAR_PRINT(x)
+    type(cosp_sgradar),intent(in) :: x
+            
+    print *, '%%%%----- Information on COSP_SGRADAR ------'
+    print *, x%Npoints
+    print *, x%Ncolumns
+    print *, x%Nlevels
+    print *, x%Nhydro
+    ! output vertical levels: spaceborne radar -> from TOA to SURFACE
+    ! Arrays with dimensions (Npoints,Nlevels)
+    print *, 'shape(x%att_gas): ', shape(x%att_gas)
+    ! Arrays with dimensions (Npoints,Ncolumns,Nlevels)
+    print *, 'shape(x%Ze_tot): ', shape(x%Ze_tot)
+END SUBROUTINE COSP_SGRADAR_PRINT
+
+SUBROUTINE COSP_RADARSTATS_PRINT(x)
+    type(cosp_radarstats),intent(in) :: x
+            
+    print *, '%%%%----- Information on COSP_SGRADAR ------'
+    print *, x%Npoints
+    print *, x%Ncolumns
+    print *, x%Nlevels
+    print *, x%Nhydro
+    print *, 'shape(x%cfad_ze): ',shape(x%cfad_ze)
+    print *, 'shape(x%radar_lidar_tcc): ',shape(x%radar_lidar_tcc)
+    print *, 'shape(x%lidar_only_freq_cloud): ',shape(x%lidar_only_freq_cloud)
+END SUBROUTINE COSP_RADARSTATS_PRINT
+
+SUBROUTINE COSP_LIDARSTATS_PRINT(x)
+    type(cosp_lidarstats),intent(in) :: x
+            
+    print *, '%%%%----- Information on COSP_SGLIDAR ------'
+    print *, x%Npoints
+    print *, x%Ncolumns
+    print *, x%Nlevels
+    print *, x%Nhydro
+    print *, x%Nrefl
+    
+    ! Arrays with dimensions (SR_BINS)
+    print *, 'shape(x%srbval): ',shape(x%srbval)
+    ! Arrays with dimensions (Npoints,SR_BINS,Nlevels)
+    print *, 'shape(x%cfad_sr): ',shape(x%cfad_sr)
+!    ! Arrays with dimensions (Npoints,Ncolumns,Nlevels) !TIBO
+!    print *, 'shape(x%profSR): ',shape(x%profSR)        !TIBO
+    ! Arrays with dimensions (Npoints,Nlevels,Ncolumns) !TIBO2
+    print *, 'shape(x%profSR): ',shape(x%profSR)        !TIBO2
+    ! Arrays with dimensions (Npoints,Nlevels)
+    print *, 'shape(x%lidarcld): ',shape(x%lidarcld)
+    print *, 'shape(x%proftemp): ',shape(x%proftemp)    !TIBO
+    ! Arrays with dimensions (Npoints,LIDAR_NCAT)
+    print *, 'shape(x%cldlayer): ',shape(x%cldlayer)
+    ! Arrays with dimensions (Npoints,LIDAR_NTYPE)            !OPAQ
+    print *, 'shape(x%cldtype): ',shape(x%cldtype)            !OPAQ
+    ! Arrays with dimensions (Npoints,PARASOL_NREFL)
+    print *, 'shape(x%parasolrefl): ',shape(x%parasolrefl)
+     ! Arrays with dimensions (Npoints,Nlevels,Nphase)
+    print *, 'shape(x%lidarcldphase): ',shape(x%lidarcldphase)
+     ! Arrays with dimensions (Npoints,Nlevels,LIDAR_NTYPE+1) !OPAQ
+    print *, 'shape(x%lidarcldtype): ',shape(x%lidarcldtype)  !OPAQ
+     ! Arrays with dimensions (Npoints,LIDAR_NCAT,Nphase)
+    print *, 'shape(x%cldlayerphase): ',shape(x%cldlayerphase)
+     ! Arrays with dimensions (Npoints,Ntemps,Nphase)
+    print *, 'shape(x%lidarcldphase): ',shape(x%lidarcldtmp)
+
+END SUBROUTINE COSP_LIDARSTATS_PRINT
+
+SUBROUTINE COSP_SUBGRID_PRINT(x)
+    type(cosp_subgrid),intent(in) :: x
+            
+    print *, '%%%%----- Information on COSP_SUBGRID ------'
+    print *, x%Npoints
+    print *, x%Ncolumns
+    print *, x%Nlevels
+    print *, x%Nhydro
+    
+    print *, 'shape(x%prec_frac): ',shape(x%prec_frac)
+    print *, 'shape(x%frac_out): ',shape(x%frac_out)
+END SUBROUTINE COSP_SUBGRID_PRINT
+
+SUBROUTINE COSP_SGHYDRO_PRINT(x)
+    type(cosp_sghydro),intent(in) :: x
+            
+    print *, '%%%%----- Information on COSP_SGHYDRO ------'
+    print *, x%Npoints
+    print *, x%Ncolumns
+    print *, x%Nlevels
+    print *, x%Nhydro
+    
+    print *, 'shape(x%mr_hydro): ',shape(x%mr_hydro)
+    print *, 'shape(x%Reff): ',shape(x%Reff)
+    print *, 'shape(x%Np): ',shape(x%Np)         ! added by roj with Quickbeam V3
+END SUBROUTINE COSP_SGHYDRO_PRINT
+
+END MODULE MOD_COSP_TYPES
Index: DZ6/trunk/libf/phylmd/cosp/mod_cosp_utils.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cosp/mod_cosp_utils.F90	(revision 5267)
+++ 	(revision )
@@ -1,352 +1,0 @@
-! (c) British Crown Copyright 2008, the Met Office.
-! All rights reserved.
-! $Revision: 23 $, $Date: 2011-03-31 15:41:37 +0200 (jeu. 31 mars 2011) $
-! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/cosp_utils.F90 $
-! 
-! Redistribution and use in source and binary forms, with or without modification, are permitted 
-! provided that the following conditions are met:
-! 
-!     * Redistributions of source code must retain the above copyright notice, this list 
-!       of conditions and the following disclaimer.
-!     * Redistributions in binary form must reproduce the above copyright notice, this list
-!       of conditions and the following disclaimer in the documentation and/or other materials 
-!       provided with the distribution.
-!     * Neither the name of the Met Office nor the names of its contributors may be used 
-!       to endorse or promote products derived from this software without specific prior written 
-!       permission.
-! 
-! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR 
-! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND 
-! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR 
-! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 
-! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 
-! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER 
-! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT 
-! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-
-!
-! History:
-! Jul 2007 - A. Bodas-Salcedo - Initial version
-!
-
-MODULE MOD_COSP_UTILS
-  USE MOD_COSP_CONSTANTS
-  IMPLICIT NONE
-
-  INTERFACE Z_TO_DBZ
-    MODULE PROCEDURE Z_TO_DBZ_2D,Z_TO_DBZ_3D,Z_TO_DBZ_4D
-  END INTERFACE
-
-  INTERFACE COSP_CHECK_INPUT
-    MODULE PROCEDURE COSP_CHECK_INPUT_1D,COSP_CHECK_INPUT_2D,COSP_CHECK_INPUT_3D
-  END INTERFACE
-CONTAINS
-
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-!------------------- SUBROUTINE COSP_PRECIP_MXRATIO --------------
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-SUBROUTINE COSP_PRECIP_MXRATIO(Npoints,Nlevels,Ncolumns,p,T,prec_frac,prec_type, &
-                          n_ax,n_bx,alpha_x,c_x,d_x,g_x,a_x,b_x,gamma1,gamma2,gamma3,gamma4, &
-                          flux,mxratio,reff)
-
-    ! Input arguments, (IN)
-    integer,intent(in) :: Npoints,Nlevels,Ncolumns
-    real,intent(in),dimension(Npoints,Nlevels) :: p,T,flux
-    real,intent(in),dimension(Npoints,Ncolumns,Nlevels) :: prec_frac
-    real,intent(in) :: n_ax,n_bx,alpha_x,c_x,d_x,g_x,a_x,b_x,gamma1,gamma2,gamma3,gamma4,prec_type
-    ! Input arguments, (OUT)
-    real,intent(out),dimension(Npoints,Ncolumns,Nlevels) :: mxratio
-    real,intent(inout),dimension(Npoints,Ncolumns,Nlevels) :: reff
-    ! Local variables
-    integer :: i,j,k
-    real :: sigma,one_over_xip1,xi,rho0,rho,lambda_x,gamma_4_3_2,delta
-    real :: seuil 
-
-    if (ok_debug_cosp) then
-       seuil=1.e-15
-    else
-       seuil=0.0
-    endif
-
-    mxratio = 0.0
-
-    if (n_ax >= 0.0) then ! N_ax is used to control which hydrometeors need to be computed
-        xi      = d_x/(alpha_x + b_x - n_bx + 1.0)
-        rho0    = 1.29
-        sigma   = (gamma2/(gamma1*c_x))*(n_ax*a_x*gamma2)**xi
-        one_over_xip1 = 1.0/(xi + 1.0)
-        gamma_4_3_2 = 0.5*gamma4/gamma3
-        delta = (alpha_x + b_x + d_x - n_bx + 1.0)
-        
-        do k=1,Nlevels
-            do j=1,Ncolumns
-                do i=1,Npoints
-                    if ((prec_frac(i,j,k)==prec_type).or.(prec_frac(i,j,k)==3.)) then
-                        rho = p(i,k)/(287.05*T(i,k))
-                        mxratio(i,j,k)=(flux(i,k)*((rho/rho0)**g_x)*sigma)**one_over_xip1
-                        mxratio(i,j,k)=mxratio(i,j,k)/rho
-                        ! Compute effective radius
-!                        if ((reff(i,j,k) <= 0.0).and.(flux(i,k) /= 0.0)) then
-                        if ((reff(i,j,k) <= 0.0).and.(flux(i,k) > seuil)) then
-                           lambda_x = (a_x*c_x*((rho0/rho)**g_x)*n_ax*gamma1/flux(i,k))**(1./delta)
-                           reff(i,j,k) = gamma_4_3_2/lambda_x
-                        endif
-                    endif
-                enddo
-            enddo
-        enddo
-    endif
-END SUBROUTINE COSP_PRECIP_MXRATIO
-
-
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-!------------------- SUBROUTINE ZERO_INT -------------------------
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-ELEMENTAL SUBROUTINE ZERO_INT(x,y01,y02,y03,y04,y05,y06,y07,y08,y09,y10, &
-                                 y11,y12,y13,y14,y15,y16,y17,y18,y19,y20, &
-                                 y21,y22,y23,y24,y25,y26,y27,y28,y29,y30)
-
-  integer,intent(inout) :: x
-  integer,intent(inout),optional :: y01,y02,y03,y04,y05,y06,y07,y08,y09,y10, &
-                                    y11,y12,y13,y14,y15,y16,y17,y18,y19,y20, &
-                                    y21,y22,y23,y24,y25,y26,y27,y28,y29,y30
-  x = 0
-  if (present(y01)) y01 = 0
-  if (present(y02)) y02 = 0
-  if (present(y03)) y03 = 0
-  if (present(y04)) y04 = 0
-  if (present(y05)) y05 = 0
-  if (present(y06)) y06 = 0
-  if (present(y07)) y07 = 0
-  if (present(y08)) y08 = 0
-  if (present(y09)) y09 = 0
-  if (present(y10)) y10 = 0
-  if (present(y11)) y11 = 0
-  if (present(y12)) y12 = 0
-  if (present(y13)) y13 = 0
-  if (present(y14)) y14 = 0
-  if (present(y15)) y15 = 0
-  if (present(y16)) y16 = 0
-  if (present(y17)) y17 = 0
-  if (present(y18)) y18 = 0
-  if (present(y19)) y19 = 0
-  if (present(y20)) y20 = 0
-  if (present(y21)) y21 = 0
-  if (present(y22)) y22 = 0
-  if (present(y23)) y23 = 0
-  if (present(y24)) y24 = 0
-  if (present(y25)) y25 = 0
-  if (present(y26)) y26 = 0
-  if (present(y27)) y27 = 0
-  if (present(y28)) y28 = 0
-  if (present(y29)) y29 = 0
-  if (present(y30)) y30 = 0
-END SUBROUTINE  ZERO_INT
-
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-!------------------- SUBROUTINE ZERO_REAL ------------------------
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-ELEMENTAL SUBROUTINE ZERO_REAL(x,y01,y02,y03,y04,y05,y06,y07,y08,y09,y10, &
-                                 y11,y12,y13,y14,y15,y16,y17,y18,y19,y20, &
-                                 y21,y22,y23,y24,y25,y26,y27,y28,y29,y30)
-
-  real,intent(inout) :: x
-  real,intent(inout),optional :: y01,y02,y03,y04,y05,y06,y07,y08,y09,y10, &
-                                 y11,y12,y13,y14,y15,y16,y17,y18,y19,y20, &
-                                 y21,y22,y23,y24,y25,y26,y27,y28,y29,y30
-  x = 0.0
-  if (present(y01)) y01 = 0.0
-  if (present(y02)) y02 = 0.0
-  if (present(y03)) y03 = 0.0
-  if (present(y04)) y04 = 0.0
-  if (present(y05)) y05 = 0.0
-  if (present(y06)) y06 = 0.0
-  if (present(y07)) y07 = 0.0
-  if (present(y08)) y08 = 0.0
-  if (present(y09)) y09 = 0.0
-  if (present(y10)) y10 = 0.0
-  if (present(y11)) y11 = 0.0
-  if (present(y12)) y12 = 0.0
-  if (present(y13)) y13 = 0.0
-  if (present(y14)) y14 = 0.0
-  if (present(y15)) y15 = 0.0
-  if (present(y16)) y16 = 0.0
-  if (present(y17)) y17 = 0.0
-  if (present(y18)) y18 = 0.0
-  if (present(y19)) y19 = 0.0
-  if (present(y20)) y20 = 0.0
-  if (present(y21)) y21 = 0.0
-  if (present(y22)) y22 = 0.0
-  if (present(y23)) y23 = 0.0
-  if (present(y24)) y24 = 0.0
-  if (present(y25)) y25 = 0.0
-  if (present(y26)) y26 = 0.0
-  if (present(y27)) y27 = 0.0
-  if (present(y28)) y28 = 0.0
-  if (present(y29)) y29 = 0.0
-  if (present(y30)) y30 = 0.0
-END SUBROUTINE  ZERO_REAL
-
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-!--------------------- SUBROUTINE Z_TO_DBZ_2D --------------------
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-  SUBROUTINE Z_TO_DBZ_2D(mdi,z)
-    real,intent(in) :: mdi
-    real,dimension(:,:),intent(inout) :: z
-    ! Reflectivity Z:
-    ! Input in [m3]
-    ! Output in dBZ, with Z in [mm6 m-3]
-    
-    ! 1.e18 to convert from [m3] to [mm6 m-3]
-    z = 1.e18*z
-    where (z > 1.0e-6) ! Limit to -60 dBZ
-      z = 10.0*log10(z)
-    elsewhere
-      z = mdi
-    end where  
-  END SUBROUTINE Z_TO_DBZ_2D
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-!--------------------- SUBROUTINE Z_TO_DBZ_3D --------------------
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-  SUBROUTINE Z_TO_DBZ_3D(mdi,z)
-    real,intent(in) :: mdi
-    real,dimension(:,:,:),intent(inout) :: z
-    ! Reflectivity Z:
-    ! Input in [m3]
-    ! Output in dBZ, with Z in [mm6 m-3]
-    
-    ! 1.e18 to convert from [m3] to [mm6 m-3]
-    z = 1.e18*z
-    where (z > 1.0e-6) ! Limit to -60 dBZ
-      z = 10.0*log10(z)
-    elsewhere
-      z = mdi
-    end where  
-  END SUBROUTINE Z_TO_DBZ_3D
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-!--------------------- SUBROUTINE Z_TO_DBZ_4D --------------------
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-  SUBROUTINE Z_TO_DBZ_4D(mdi,z)
-    real,intent(in) :: mdi
-    real,dimension(:,:,:,:),intent(inout) :: z
-    ! Reflectivity Z:
-    ! Input in [m3]
-    ! Output in dBZ, with Z in [mm6 m-3]
-    
-    ! 1.e18 to convert from [m3] to [mm6 m-3]
-    z = 1.e18*z
-    where (z > 1.0e-6) ! Limit to -60 dBZ
-      z = 10.0*log10(z)
-    elsewhere
-      z = mdi
-    end where  
-  END SUBROUTINE Z_TO_DBZ_4D
-
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-!----------------- SUBROUTINES COSP_CHECK_INPUT_1D ---------------
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-  SUBROUTINE COSP_CHECK_INPUT_1D(vname,x,min_val,max_val)
-    character(len=*) :: vname
-    real,intent(inout) :: x(:)
-    real,intent(in),optional :: min_val,max_val
-    logical :: l_min,l_max
-    character(len=128) :: pro_name='COSP_CHECK_INPUT_1D'
-    
-    l_min=.false.
-    l_max=.false.
-    
-    if (present(min_val)) then
-!       if (x < min_val) x = min_val
-      if (any(x < min_val)) then 
-      l_min = .true.
-        where (x < min_val)
-          x = min_val
-        end where
-      endif
-    endif    
-    if (present(max_val)) then
-!       if (x > max_val) x = max_val
-      if (any(x > max_val)) then 
-        l_max = .true.
-        where (x > max_val)
-          x = max_val
-        end where  
-      endif    
-    endif    
-    
-    if (l_min) print *,'----- WARNING: '//trim(pro_name)//': minimum value of '//trim(vname)//' set to: ',min_val
-    if (l_max) print *,'----- WARNING: '//trim(pro_name)//': maximum value of '//trim(vname)//' set to: ',max_val
-  END SUBROUTINE COSP_CHECK_INPUT_1D
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-!----------------- SUBROUTINES COSP_CHECK_INPUT_2D ---------------
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-  SUBROUTINE COSP_CHECK_INPUT_2D(vname,x,min_val,max_val)
-    character(len=*) :: vname
-    real,intent(inout) :: x(:,:)
-    real,intent(in),optional :: min_val,max_val
-    logical :: l_min,l_max
-    character(len=128) :: pro_name='COSP_CHECK_INPUT_2D'
-    
-    l_min=.false.
-    l_max=.false.
-    
-    if (present(min_val)) then
-!       if (x < min_val) x = min_val
-      if (any(x < min_val)) then 
-      l_min = .true.
-        where (x < min_val)
-          x = min_val
-        end where
-      endif
-    endif    
-    if (present(max_val)) then
-!       if (x > max_val) x = max_val
-      if (any(x > max_val)) then 
-        l_max = .true.
-        where (x > max_val)
-          x = max_val
-        end where  
-      endif    
-    endif    
-    
-    if (l_min) print *,'----- WARNING: '//trim(pro_name)//': minimum value of '//trim(vname)//' set to: ',min_val
-    if (l_max) print *,'----- WARNING: '//trim(pro_name)//': maximum value of '//trim(vname)//' set to: ',max_val
-  END SUBROUTINE COSP_CHECK_INPUT_2D
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-!----------------- SUBROUTINES COSP_CHECK_INPUT_3D ---------------
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-  SUBROUTINE COSP_CHECK_INPUT_3D(vname,x,min_val,max_val)
-    character(len=*) :: vname
-    real,intent(inout) :: x(:,:,:)
-    real,intent(in),optional :: min_val,max_val
-    logical :: l_min,l_max
-    character(len=128) :: pro_name='COSP_CHECK_INPUT_3D'
-    
-    l_min=.false.
-    l_max=.false.
-    
-    if (present(min_val)) then
-!       if (x < min_val) x = min_val
-      if (any(x < min_val)) then 
-      l_min = .true.
-        where (x < min_val)
-          x = min_val
-        end where
-      endif
-    endif    
-    if (present(max_val)) then
-!       if (x > max_val) x = max_val
-      if (any(x > max_val)) then 
-        l_max = .true.
-        where (x > max_val)
-          x = max_val
-        end where  
-      endif    
-    endif    
-    
-    if (l_min) print *,'----- WARNING: '//trim(pro_name)//': minimum value of '//trim(vname)//' set to: ',min_val
-    if (l_max) print *,'----- WARNING: '//trim(pro_name)//': maximum value of '//trim(vname)//' set to: ',max_val
-  END SUBROUTINE COSP_CHECK_INPUT_3D
-
-
-END MODULE MOD_COSP_UTILS
Index: /LMDZ6/trunk/libf/phylmd/cosp/mod_cosp_utils.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cosp/mod_cosp_utils.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/cosp/mod_cosp_utils.f90	(revision 5268)
@@ -0,0 +1,352 @@
+! (c) British Crown Copyright 2008, the Met Office.
+! All rights reserved.
+! $Revision: 23 $, $Date: 2011-03-31 15:41:37 +0200 (jeu. 31 mars 2011) $
+! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/cosp_utils.F90 $
+! 
+! Redistribution and use in source and binary forms, with or without modification, are permitted 
+! provided that the following conditions are met:
+! 
+!     * Redistributions of source code must retain the above copyright notice, this list 
+!       of conditions and the following disclaimer.
+!     * Redistributions in binary form must reproduce the above copyright notice, this list
+!       of conditions and the following disclaimer in the documentation and/or other materials 
+!       provided with the distribution.
+!     * Neither the name of the Met Office nor the names of its contributors may be used 
+!       to endorse or promote products derived from this software without specific prior written 
+!       permission.
+! 
+! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR 
+! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND 
+! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR 
+! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 
+! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 
+! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER 
+! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT 
+! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+!
+! History:
+! Jul 2007 - A. Bodas-Salcedo - Initial version
+!
+
+MODULE MOD_COSP_UTILS
+  USE MOD_COSP_CONSTANTS
+  IMPLICIT NONE
+
+  INTERFACE Z_TO_DBZ
+    MODULE PROCEDURE Z_TO_DBZ_2D,Z_TO_DBZ_3D,Z_TO_DBZ_4D
+  END INTERFACE
+
+  INTERFACE COSP_CHECK_INPUT
+    MODULE PROCEDURE COSP_CHECK_INPUT_1D,COSP_CHECK_INPUT_2D,COSP_CHECK_INPUT_3D
+  END INTERFACE
+CONTAINS
+
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+!------------------- SUBROUTINE COSP_PRECIP_MXRATIO --------------
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+SUBROUTINE COSP_PRECIP_MXRATIO(Npoints,Nlevels,Ncolumns,p,T,prec_frac,prec_type, &
+                          n_ax,n_bx,alpha_x,c_x,d_x,g_x,a_x,b_x,gamma1,gamma2,gamma3,gamma4, &
+                          flux,mxratio,reff)
+
+    ! Input arguments, (IN)
+    integer,intent(in) :: Npoints,Nlevels,Ncolumns
+    real,intent(in),dimension(Npoints,Nlevels) :: p,T,flux
+    real,intent(in),dimension(Npoints,Ncolumns,Nlevels) :: prec_frac
+    real,intent(in) :: n_ax,n_bx,alpha_x,c_x,d_x,g_x,a_x,b_x,gamma1,gamma2,gamma3,gamma4,prec_type
+    ! Input arguments, (OUT)
+    real,intent(out),dimension(Npoints,Ncolumns,Nlevels) :: mxratio
+    real,intent(inout),dimension(Npoints,Ncolumns,Nlevels) :: reff
+    ! Local variables
+    integer :: i,j,k
+    real :: sigma,one_over_xip1,xi,rho0,rho,lambda_x,gamma_4_3_2,delta
+    real :: seuil 
+
+    if (ok_debug_cosp) then
+       seuil=1.e-15
+    else
+       seuil=0.0
+    endif
+
+    mxratio = 0.0
+
+    if (n_ax >= 0.0) then ! N_ax is used to control which hydrometeors need to be computed
+        xi      = d_x/(alpha_x + b_x - n_bx + 1.0)
+        rho0    = 1.29
+        sigma   = (gamma2/(gamma1*c_x))*(n_ax*a_x*gamma2)**xi
+        one_over_xip1 = 1.0/(xi + 1.0)
+        gamma_4_3_2 = 0.5*gamma4/gamma3
+        delta = (alpha_x + b_x + d_x - n_bx + 1.0)
+        
+        do k=1,Nlevels
+            do j=1,Ncolumns
+                do i=1,Npoints
+                    if ((prec_frac(i,j,k)==prec_type).or.(prec_frac(i,j,k)==3.)) then
+                        rho = p(i,k)/(287.05*T(i,k))
+                        mxratio(i,j,k)=(flux(i,k)*((rho/rho0)**g_x)*sigma)**one_over_xip1
+                        mxratio(i,j,k)=mxratio(i,j,k)/rho
+                        ! Compute effective radius
+!                        if ((reff(i,j,k) <= 0.0).and.(flux(i,k) /= 0.0)) then
+                        if ((reff(i,j,k) <= 0.0).and.(flux(i,k) > seuil)) then
+                           lambda_x = (a_x*c_x*((rho0/rho)**g_x)*n_ax*gamma1/flux(i,k))**(1./delta)
+                           reff(i,j,k) = gamma_4_3_2/lambda_x
+                        endif
+                    endif
+                enddo
+            enddo
+        enddo
+    endif
+END SUBROUTINE COSP_PRECIP_MXRATIO
+
+
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+!------------------- SUBROUTINE ZERO_INT -------------------------
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+ELEMENTAL SUBROUTINE ZERO_INT(x,y01,y02,y03,y04,y05,y06,y07,y08,y09,y10, &
+                                 y11,y12,y13,y14,y15,y16,y17,y18,y19,y20, &
+                                 y21,y22,y23,y24,y25,y26,y27,y28,y29,y30)
+
+  integer,intent(inout) :: x
+  integer,intent(inout),optional :: y01,y02,y03,y04,y05,y06,y07,y08,y09,y10, &
+                                    y11,y12,y13,y14,y15,y16,y17,y18,y19,y20, &
+                                    y21,y22,y23,y24,y25,y26,y27,y28,y29,y30
+  x = 0
+  if (present(y01)) y01 = 0
+  if (present(y02)) y02 = 0
+  if (present(y03)) y03 = 0
+  if (present(y04)) y04 = 0
+  if (present(y05)) y05 = 0
+  if (present(y06)) y06 = 0
+  if (present(y07)) y07 = 0
+  if (present(y08)) y08 = 0
+  if (present(y09)) y09 = 0
+  if (present(y10)) y10 = 0
+  if (present(y11)) y11 = 0
+  if (present(y12)) y12 = 0
+  if (present(y13)) y13 = 0
+  if (present(y14)) y14 = 0
+  if (present(y15)) y15 = 0
+  if (present(y16)) y16 = 0
+  if (present(y17)) y17 = 0
+  if (present(y18)) y18 = 0
+  if (present(y19)) y19 = 0
+  if (present(y20)) y20 = 0
+  if (present(y21)) y21 = 0
+  if (present(y22)) y22 = 0
+  if (present(y23)) y23 = 0
+  if (present(y24)) y24 = 0
+  if (present(y25)) y25 = 0
+  if (present(y26)) y26 = 0
+  if (present(y27)) y27 = 0
+  if (present(y28)) y28 = 0
+  if (present(y29)) y29 = 0
+  if (present(y30)) y30 = 0
+END SUBROUTINE  ZERO_INT
+
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+!------------------- SUBROUTINE ZERO_REAL ------------------------
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+ELEMENTAL SUBROUTINE ZERO_REAL(x,y01,y02,y03,y04,y05,y06,y07,y08,y09,y10, &
+                                 y11,y12,y13,y14,y15,y16,y17,y18,y19,y20, &
+                                 y21,y22,y23,y24,y25,y26,y27,y28,y29,y30)
+
+  real,intent(inout) :: x
+  real,intent(inout),optional :: y01,y02,y03,y04,y05,y06,y07,y08,y09,y10, &
+                                 y11,y12,y13,y14,y15,y16,y17,y18,y19,y20, &
+                                 y21,y22,y23,y24,y25,y26,y27,y28,y29,y30
+  x = 0.0
+  if (present(y01)) y01 = 0.0
+  if (present(y02)) y02 = 0.0
+  if (present(y03)) y03 = 0.0
+  if (present(y04)) y04 = 0.0
+  if (present(y05)) y05 = 0.0
+  if (present(y06)) y06 = 0.0
+  if (present(y07)) y07 = 0.0
+  if (present(y08)) y08 = 0.0
+  if (present(y09)) y09 = 0.0
+  if (present(y10)) y10 = 0.0
+  if (present(y11)) y11 = 0.0
+  if (present(y12)) y12 = 0.0
+  if (present(y13)) y13 = 0.0
+  if (present(y14)) y14 = 0.0
+  if (present(y15)) y15 = 0.0
+  if (present(y16)) y16 = 0.0
+  if (present(y17)) y17 = 0.0
+  if (present(y18)) y18 = 0.0
+  if (present(y19)) y19 = 0.0
+  if (present(y20)) y20 = 0.0
+  if (present(y21)) y21 = 0.0
+  if (present(y22)) y22 = 0.0
+  if (present(y23)) y23 = 0.0
+  if (present(y24)) y24 = 0.0
+  if (present(y25)) y25 = 0.0
+  if (present(y26)) y26 = 0.0
+  if (present(y27)) y27 = 0.0
+  if (present(y28)) y28 = 0.0
+  if (present(y29)) y29 = 0.0
+  if (present(y30)) y30 = 0.0
+END SUBROUTINE  ZERO_REAL
+
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+!--------------------- SUBROUTINE Z_TO_DBZ_2D --------------------
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  SUBROUTINE Z_TO_DBZ_2D(mdi,z)
+    real,intent(in) :: mdi
+    real,dimension(:,:),intent(inout) :: z
+    ! Reflectivity Z:
+    ! Input in [m3]
+    ! Output in dBZ, with Z in [mm6 m-3]
+    
+    ! 1.e18 to convert from [m3] to [mm6 m-3]
+    z = 1.e18*z
+    where (z > 1.0e-6) ! Limit to -60 dBZ
+      z = 10.0*log10(z)
+    elsewhere
+      z = mdi
+    end where  
+  END SUBROUTINE Z_TO_DBZ_2D
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+!--------------------- SUBROUTINE Z_TO_DBZ_3D --------------------
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  SUBROUTINE Z_TO_DBZ_3D(mdi,z)
+    real,intent(in) :: mdi
+    real,dimension(:,:,:),intent(inout) :: z
+    ! Reflectivity Z:
+    ! Input in [m3]
+    ! Output in dBZ, with Z in [mm6 m-3]
+    
+    ! 1.e18 to convert from [m3] to [mm6 m-3]
+    z = 1.e18*z
+    where (z > 1.0e-6) ! Limit to -60 dBZ
+      z = 10.0*log10(z)
+    elsewhere
+      z = mdi
+    end where  
+  END SUBROUTINE Z_TO_DBZ_3D
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+!--------------------- SUBROUTINE Z_TO_DBZ_4D --------------------
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  SUBROUTINE Z_TO_DBZ_4D(mdi,z)
+    real,intent(in) :: mdi
+    real,dimension(:,:,:,:),intent(inout) :: z
+    ! Reflectivity Z:
+    ! Input in [m3]
+    ! Output in dBZ, with Z in [mm6 m-3]
+    
+    ! 1.e18 to convert from [m3] to [mm6 m-3]
+    z = 1.e18*z
+    where (z > 1.0e-6) ! Limit to -60 dBZ
+      z = 10.0*log10(z)
+    elsewhere
+      z = mdi
+    end where  
+  END SUBROUTINE Z_TO_DBZ_4D
+
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+!----------------- SUBROUTINES COSP_CHECK_INPUT_1D ---------------
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  SUBROUTINE COSP_CHECK_INPUT_1D(vname,x,min_val,max_val)
+    character(len=*) :: vname
+    real,intent(inout) :: x(:)
+    real,intent(in),optional :: min_val,max_val
+    logical :: l_min,l_max
+    character(len=128) :: pro_name='COSP_CHECK_INPUT_1D'
+    
+    l_min=.false.
+    l_max=.false.
+    
+    if (present(min_val)) then
+!       if (x < min_val) x = min_val
+      if (any(x < min_val)) then 
+      l_min = .true.
+        where (x < min_val)
+          x = min_val
+        end where
+      endif
+    endif    
+    if (present(max_val)) then
+!       if (x > max_val) x = max_val
+      if (any(x > max_val)) then 
+        l_max = .true.
+        where (x > max_val)
+          x = max_val
+        end where  
+      endif    
+    endif    
+    
+    if (l_min) print *,'----- WARNING: '//trim(pro_name)//': minimum value of '//trim(vname)//' set to: ',min_val
+    if (l_max) print *,'----- WARNING: '//trim(pro_name)//': maximum value of '//trim(vname)//' set to: ',max_val
+  END SUBROUTINE COSP_CHECK_INPUT_1D
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+!----------------- SUBROUTINES COSP_CHECK_INPUT_2D ---------------
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  SUBROUTINE COSP_CHECK_INPUT_2D(vname,x,min_val,max_val)
+    character(len=*) :: vname
+    real,intent(inout) :: x(:,:)
+    real,intent(in),optional :: min_val,max_val
+    logical :: l_min,l_max
+    character(len=128) :: pro_name='COSP_CHECK_INPUT_2D'
+    
+    l_min=.false.
+    l_max=.false.
+    
+    if (present(min_val)) then
+!       if (x < min_val) x = min_val
+      if (any(x < min_val)) then 
+      l_min = .true.
+        where (x < min_val)
+          x = min_val
+        end where
+      endif
+    endif    
+    if (present(max_val)) then
+!       if (x > max_val) x = max_val
+      if (any(x > max_val)) then 
+        l_max = .true.
+        where (x > max_val)
+          x = max_val
+        end where  
+      endif    
+    endif    
+    
+    if (l_min) print *,'----- WARNING: '//trim(pro_name)//': minimum value of '//trim(vname)//' set to: ',min_val
+    if (l_max) print *,'----- WARNING: '//trim(pro_name)//': maximum value of '//trim(vname)//' set to: ',max_val
+  END SUBROUTINE COSP_CHECK_INPUT_2D
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+!----------------- SUBROUTINES COSP_CHECK_INPUT_3D ---------------
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  SUBROUTINE COSP_CHECK_INPUT_3D(vname,x,min_val,max_val)
+    character(len=*) :: vname
+    real,intent(inout) :: x(:,:,:)
+    real,intent(in),optional :: min_val,max_val
+    logical :: l_min,l_max
+    character(len=128) :: pro_name='COSP_CHECK_INPUT_3D'
+    
+    l_min=.false.
+    l_max=.false.
+    
+    if (present(min_val)) then
+!       if (x < min_val) x = min_val
+      if (any(x < min_val)) then 
+      l_min = .true.
+        where (x < min_val)
+          x = min_val
+        end where
+      endif
+    endif    
+    if (present(max_val)) then
+!       if (x > max_val) x = max_val
+      if (any(x > max_val)) then 
+        l_max = .true.
+        where (x > max_val)
+          x = max_val
+        end where  
+      endif    
+    endif    
+    
+    if (l_min) print *,'----- WARNING: '//trim(pro_name)//': minimum value of '//trim(vname)//' set to: ',min_val
+    if (l_max) print *,'----- WARNING: '//trim(pro_name)//': maximum value of '//trim(vname)//' set to: ',max_val
+  END SUBROUTINE COSP_CHECK_INPUT_3D
+
+
+END MODULE MOD_COSP_UTILS
Index: DZ6/trunk/libf/phylmd/cosp/mod_llnl_stats.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cosp/mod_llnl_stats.F90	(revision 5267)
+++ 	(revision )
@@ -1,138 +1,0 @@
-! (c) 2008, Lawrence Livermore National Security Limited Liability Corporation.
-! All rights reserved.
-! $Revision: 88 $, $Date: 2013-11-13 15:08:38 +0100 (mer. 13 nov. 2013) $
-! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/llnl/llnl_stats.F90 $
-! 
-! Redistribution and use in source and binary forms, with or without modification, are permitted 
-! provided that the following conditions are met:
-! 
-!     * Redistributions of source code must retain the above copyright notice, this list 
-!       of conditions and the following disclaimer.
-!     * Redistributions in binary form must reproduce the above copyright notice, this list 
-!       of conditions and the following disclaimer in the documentation and/or other materials 
-!       provided with the distribution.
-!     * Neither the name of the Lawrence Livermore National Security Limited Liability Corporation 
-!       nor the names of its contributors may be used to endorse or promote products derived from 
-!       this software without specific prior written permission.
-! 
-! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR 
-! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND 
-! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR 
-! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 
-! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 
-! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER 
-! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT 
-! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-!
-! History
-!
-! Jan 2013 - G. Cesana        - Added betaperp_tot and temp_tot arguments 
-!
-
-
-MODULE MOD_LLNL_STATS
-  USE MOD_COSP_CONSTANTS
-  IMPLICIT NONE
-
-CONTAINS
-
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-!-------------------- FUNCTION COSP_CFAD ------------------------
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-FUNCTION COSP_CFAD(Npoints,Ncolumns,Nlevels,Nbins,x,xmin,xmax,bmin,bwidth)
-   ! Input arguments
-   integer,intent(in) :: Npoints,Ncolumns,Nlevels,Nbins
-   real,dimension(Npoints,Ncolumns,Nlevels),intent(in) :: x
-   real,intent(in) :: xmin,xmax 
-   real,intent(in) :: bmin,bwidth
-   
-   real,dimension(Npoints,Nbins,Nlevels) :: cosp_cfad
-   ! Local variables
-   integer :: i, j, k
-   integer :: ibin
-   
-   !--- Input arguments
-   ! Npoints: Number of horizontal points
-   ! Ncolumns: Number of subcolumns
-   ! Nlevels: Number of levels
-   ! Nbins: Number of x axis bins
-   ! x: variable to process (Npoints,Ncolumns,Nlevels)
-   ! xmin: minimum value allowed for x
-   ! xmax: minimum value allowed for x
-   ! bmin: mimumum value of first bin
-   ! bwidth: bin width
-   !
-   ! Output: 2D histogram on each horizontal point (Npoints,Nbins,Nlevels)
-   
-   cosp_cfad = 0.0
-   ! bwidth intervals in the range [bmin,bmax=bmin+Nbins*hwidth]
-   ! Valid x values smaller than bmin and larger than bmax are set 
-   ! into the smallest bin and largest bin, respectively.
-   do j = 1, Nlevels, 1
-      do k = 1, Ncolumns, 1
-         do i = 1, Npoints, 1
-            if (x(i,k,j) == R_GROUND) then
-               cosp_cfad(i,:,j) = R_UNDEF
-            elseif ((x(i,k,j) >= xmin) .and. (x(i,k,j) <= xmax)) then 
-               ibin = ceiling((x(i,k,j) - bmin)/bwidth)
-               if (ibin > Nbins) ibin = Nbins
-               if (ibin < 1)     ibin = 1
-               cosp_cfad(i,ibin,j) = cosp_cfad(i,ibin,j) + 1.0 
-            end if
-         enddo  !i
-      enddo  !k
-   enddo  !j
-   where ((cosp_cfad /= R_UNDEF).and.(cosp_cfad /= 0.0)) cosp_cfad = cosp_cfad / Ncolumns
-END FUNCTION COSP_CFAD
-
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-!------------- SUBROUTINE COSP_LIDAR_ONLY_CLOUD -----------------
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-SUBROUTINE COSP_LIDAR_ONLY_CLOUD(Npoints,Ncolumns,Nlevels,temp_tot,beta_tot, &
-                   betaperp_tot,beta_mol,Ze_tot,lidar_only_freq_cloud,tcc)
-   ! Input arguments
-   integer,intent(in) :: Npoints,Ncolumns,Nlevels
-   real,dimension(Npoints,Nlevels),intent(in) :: beta_mol   ! Molecular backscatter
-   real,dimension(Npoints,Ncolumns,Nlevels),intent(in) :: beta_tot   ! Total backscattered signal
-   real,dimension(Npoints,Ncolumns,Nlevels),intent(in) :: temp_tot   ! Total backscattered signal
-   real,dimension(Npoints,Ncolumns,Nlevels),intent(in) :: betaperp_tot   ! perpendicular Total backscattered signal
-   real,dimension(Npoints,Ncolumns,Nlevels),intent(in) :: Ze_tot     ! Radar reflectivity
-   ! Output arguments
-   real,dimension(Npoints,Nlevels),intent(out) :: lidar_only_freq_cloud
-   real,dimension(Npoints),intent(out) :: tcc
-
-   ! local variables
-   real :: sc_ratio
-   real :: s_cld, s_att
-   parameter (S_cld = 5.0)
-   parameter (s_att = 0.01)
-   integer :: flag_sat !first saturated level encountered from top
-   integer :: flag_cld !cloudy column
-   integer :: pr,i,j
-
-   lidar_only_freq_cloud = 0.0
-   tcc = 0.0
-   do pr=1,Npoints
-     do i=1,Ncolumns
-       flag_sat = 0
-       flag_cld = 0
-       do j=Nlevels,1,-1 !top->surf
-        sc_ratio = beta_tot(pr,i,j)/beta_mol(pr,j)
-        if ((sc_ratio .le. s_att) .and. (flag_sat .eq. 0)) flag_sat = j
-        if (Ze_tot(pr,i,j) .lt. -30.) then  !radar can't detect cloud
-         if ( (sc_ratio .gt. s_cld) .or. (flag_sat .eq. j) ) then  !lidar sense cloud
-            lidar_only_freq_cloud(pr,j)=lidar_only_freq_cloud(pr,j)+1. !top->surf
-            flag_cld=1
-         endif
-        else  !radar sense cloud (z%Ze_tot(pr,i,j) .ge. -30.)
-           flag_cld=1
-        endif
-       enddo !levels
-       if (flag_cld .eq. 1) tcc(pr)=tcc(pr)+1.
-     enddo !columns
-   enddo !points
-   lidar_only_freq_cloud=lidar_only_freq_cloud/Ncolumns
-   tcc=tcc/Ncolumns
-
-END SUBROUTINE COSP_LIDAR_ONLY_CLOUD
-END MODULE MOD_LLNL_STATS
Index: /LMDZ6/trunk/libf/phylmd/cosp/mod_llnl_stats.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cosp/mod_llnl_stats.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/cosp/mod_llnl_stats.f90	(revision 5268)
@@ -0,0 +1,138 @@
+! (c) 2008, Lawrence Livermore National Security Limited Liability Corporation.
+! All rights reserved.
+! $Revision: 88 $, $Date: 2013-11-13 15:08:38 +0100 (mer. 13 nov. 2013) $
+! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/llnl/llnl_stats.F90 $
+! 
+! Redistribution and use in source and binary forms, with or without modification, are permitted 
+! provided that the following conditions are met:
+! 
+!     * Redistributions of source code must retain the above copyright notice, this list 
+!       of conditions and the following disclaimer.
+!     * Redistributions in binary form must reproduce the above copyright notice, this list 
+!       of conditions and the following disclaimer in the documentation and/or other materials 
+!       provided with the distribution.
+!     * Neither the name of the Lawrence Livermore National Security Limited Liability Corporation 
+!       nor the names of its contributors may be used to endorse or promote products derived from 
+!       this software without specific prior written permission.
+! 
+! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR 
+! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND 
+! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR 
+! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 
+! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 
+! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER 
+! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT 
+! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+!
+! History
+!
+! Jan 2013 - G. Cesana        - Added betaperp_tot and temp_tot arguments 
+!
+
+
+MODULE MOD_LLNL_STATS
+  USE MOD_COSP_CONSTANTS
+  IMPLICIT NONE
+
+CONTAINS
+
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+!-------------------- FUNCTION COSP_CFAD ------------------------
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+FUNCTION COSP_CFAD(Npoints,Ncolumns,Nlevels,Nbins,x,xmin,xmax,bmin,bwidth)
+   ! Input arguments
+   integer,intent(in) :: Npoints,Ncolumns,Nlevels,Nbins
+   real,dimension(Npoints,Ncolumns,Nlevels),intent(in) :: x
+   real,intent(in) :: xmin,xmax 
+   real,intent(in) :: bmin,bwidth
+   
+   real,dimension(Npoints,Nbins,Nlevels) :: cosp_cfad
+   ! Local variables
+   integer :: i, j, k
+   integer :: ibin
+   
+   !--- Input arguments
+   ! Npoints: Number of horizontal points
+   ! Ncolumns: Number of subcolumns
+   ! Nlevels: Number of levels
+   ! Nbins: Number of x axis bins
+   ! x: variable to process (Npoints,Ncolumns,Nlevels)
+   ! xmin: minimum value allowed for x
+   ! xmax: minimum value allowed for x
+   ! bmin: mimumum value of first bin
+   ! bwidth: bin width
+   !
+   ! Output: 2D histogram on each horizontal point (Npoints,Nbins,Nlevels)
+   
+   cosp_cfad = 0.0
+   ! bwidth intervals in the range [bmin,bmax=bmin+Nbins*hwidth]
+   ! Valid x values smaller than bmin and larger than bmax are set 
+   ! into the smallest bin and largest bin, respectively.
+   do j = 1, Nlevels, 1
+      do k = 1, Ncolumns, 1
+         do i = 1, Npoints, 1
+            if (x(i,k,j) == R_GROUND) then
+               cosp_cfad(i,:,j) = R_UNDEF
+            elseif ((x(i,k,j) >= xmin) .and. (x(i,k,j) <= xmax)) then 
+               ibin = ceiling((x(i,k,j) - bmin)/bwidth)
+               if (ibin > Nbins) ibin = Nbins
+               if (ibin < 1)     ibin = 1
+               cosp_cfad(i,ibin,j) = cosp_cfad(i,ibin,j) + 1.0 
+            end if
+         enddo  !i
+      enddo  !k
+   enddo  !j
+   where ((cosp_cfad /= R_UNDEF).and.(cosp_cfad /= 0.0)) cosp_cfad = cosp_cfad / Ncolumns
+END FUNCTION COSP_CFAD
+
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+!------------- SUBROUTINE COSP_LIDAR_ONLY_CLOUD -----------------
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+SUBROUTINE COSP_LIDAR_ONLY_CLOUD(Npoints,Ncolumns,Nlevels,temp_tot,beta_tot, &
+                   betaperp_tot,beta_mol,Ze_tot,lidar_only_freq_cloud,tcc)
+   ! Input arguments
+   integer,intent(in) :: Npoints,Ncolumns,Nlevels
+   real,dimension(Npoints,Nlevels),intent(in) :: beta_mol   ! Molecular backscatter
+   real,dimension(Npoints,Ncolumns,Nlevels),intent(in) :: beta_tot   ! Total backscattered signal
+   real,dimension(Npoints,Ncolumns,Nlevels),intent(in) :: temp_tot   ! Total backscattered signal
+   real,dimension(Npoints,Ncolumns,Nlevels),intent(in) :: betaperp_tot   ! perpendicular Total backscattered signal
+   real,dimension(Npoints,Ncolumns,Nlevels),intent(in) :: Ze_tot     ! Radar reflectivity
+   ! Output arguments
+   real,dimension(Npoints,Nlevels),intent(out) :: lidar_only_freq_cloud
+   real,dimension(Npoints),intent(out) :: tcc
+
+   ! local variables
+   real :: sc_ratio
+   real :: s_cld, s_att
+   parameter (S_cld = 5.0)
+   parameter (s_att = 0.01)
+   integer :: flag_sat !first saturated level encountered from top
+   integer :: flag_cld !cloudy column
+   integer :: pr,i,j
+
+   lidar_only_freq_cloud = 0.0
+   tcc = 0.0
+   do pr=1,Npoints
+     do i=1,Ncolumns
+       flag_sat = 0
+       flag_cld = 0
+       do j=Nlevels,1,-1 !top->surf
+        sc_ratio = beta_tot(pr,i,j)/beta_mol(pr,j)
+        if ((sc_ratio .le. s_att) .and. (flag_sat .eq. 0)) flag_sat = j
+        if (Ze_tot(pr,i,j) .lt. -30.) then  !radar can't detect cloud
+         if ( (sc_ratio .gt. s_cld) .or. (flag_sat .eq. j) ) then  !lidar sense cloud
+            lidar_only_freq_cloud(pr,j)=lidar_only_freq_cloud(pr,j)+1. !top->surf
+            flag_cld=1
+         endif
+        else  !radar sense cloud (z%Ze_tot(pr,i,j) .ge. -30.)
+           flag_cld=1
+        endif
+       enddo !levels
+       if (flag_cld .eq. 1) tcc(pr)=tcc(pr)+1.
+     enddo !columns
+   enddo !points
+   lidar_only_freq_cloud=lidar_only_freq_cloud/Ncolumns
+   tcc=tcc/Ncolumns
+
+END SUBROUTINE COSP_LIDAR_ONLY_CLOUD
+END MODULE MOD_LLNL_STATS
Index: DZ6/trunk/libf/phylmd/cosp/mod_modis_sim.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cosp/mod_modis_sim.F90	(revision 5267)
+++ 	(revision )
@@ -1,1309 +1,0 @@
-! (c) 2009-2010, Regents of the Unversity of Colorado
-!   Author: Robert Pincus, Cooperative Institute for Research in the Environmental Sciences
-! All rights reserved.
-! $Revision: 88 $, $Date: 2013-11-13 07:08:38 -0700 (Wed, 13 Nov 2013) $
-! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/MODIS_simulator/modis_simulator.F90 $
-! 
-! Redistribution and use in source and binary forms, with or without modification, are permitted 
-! provided that the following conditions are met:
-! 
-!     * Redistributions of source code must retain the above copyright notice, this list 
-!       of conditions and the following disclaimer.
-!     * Redistributions in binary form must reproduce the above copyright notice, this list
-!       of conditions and the following disclaimer in the documentation and/or other materials 
-!       provided with the distribution.
-!     * Neither the name of the Met Office nor the names of its contributors may be used 
-!       to endorse or promote products derived from this software without specific prior written 
-!       permission.
-! 
-! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR 
-! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND 
-! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR 
-! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 
-! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 
-! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER 
-! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT 
-! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-!
-
-!
-! History:
-!   May 2009 - Robert Pincus - Initial version
-!   June 2009 - Steve Platnick and Robert Pincus - Simple radiative transfer for size retrievals
-!   August 2009 - Robert Pincus - Consistency and bug fixes suggested by Rick Hemler (GFDL) 
-!   November 2009 - Robert Pincus - Bux fixes and speed-ups after experience with Rick Hemler using AM2 (GFDL) 
-!   January 2010 - Robert Pincus - Added high, middle, low cloud fractions 
-!
-
-!
-! Notes on using the MODIS simulator: 
-!  *) You may provide either layer-by-layer values of optical thickness at 0.67 and 2.1 microns, or 
-!     optical thickness at 0.67 microns and ice- and liquid-water contents (in consistent units of 
-!     your choosing)
-!  *) Required input also includes the optical thickness and cloud top pressure 
-!     derived from the ISCCP simulator run with parameter top_height = 1. 
-!  *) Cloud particle sizes are specified as radii, measured in meters, though within the module we 
-!     use units of microns. Where particle sizes are outside the bounds used in the MODIS retrieval
-!     libraries (parameters re_water_min, re_ice_min, etc.) the simulator returns missing values (re_fill)
-
-!
-! When error conditions are encountered this code calls the function complain_and_die, supplied at the 
-!   bottom of this module. Users probably want to replace this with something more graceful. 
-!
-module mod_modis_sim
-  USE MOD_COSP_TYPES, only: R_UNDEF, ok_debug_cosp
-  implicit none
-  ! ------------------------------
-  ! Algorithmic parameters
-  !
- 
-  real, parameter :: ice_density          = 0.93               ! liquid density is 1.  
-  !
-  ! Retrieval parameters
-  !
-  real, parameter :: min_OpticalThickness = 0.3,             & ! Minimum detectable optical thickness
-                     CO2Slicing_PressureLimit = 700. * 100., & ! Cloud with higher pressures use thermal methods, units Pa
-                     CO2Slicing_TauLimit = 1.,               & ! How deep into the cloud does CO2 slicing see? 
-                     phase_TauLimit      = 1.,               & ! How deep into the cloud does the phase detection see?
-                     size_TauLimit       = 2.,               & ! Depth of the re retreivals
-                     phaseDiscrimination_Threshold = 0.7       ! What fraction of total extincton needs to be 
-                                                               !  in a single category to make phase discrim. work? 
-  real,    parameter :: re_fill= -999.
-  integer, parameter :: phaseIsNone = 0, phaseIsLiquid = 1, phaseIsIce = 2, phaseIsUndetermined = 3
-  
-  logical, parameter :: useSimpleReScheme = .false. 
-  !
-  ! These are the limits of the libraries for the MODIS collection 5 algorithms 
-  !   They are also the limits used in the fits for g and w0
-  !
-  real,    parameter :: re_water_min= 4., re_water_max= 30., re_ice_min= 5., re_ice_max= 90.
-  integer, parameter :: num_trial_res = 15             ! increase to make the linear pseudo-retrieval of size more accurate
-! DJS2015: Remove unused parameter
-!  logical, parameter :: use_two_re_iterations = .false. ! do two retrieval iterations? 
-! DJS2015 END  
-  !
-  ! Precompute near-IR optical params vs size for retrieval scheme
-  !
-  integer, private :: i 
-  real, dimension(num_trial_res), parameter :: & 
-        trial_re_w = re_water_min + (re_water_max - re_water_min)/(num_trial_res-1) * (/ (i - 1, i = 1, num_trial_res) /), &
-        trial_re_i = re_ice_min   + (re_ice_max -   re_ice_min)  /(num_trial_res-1) * (/ (i - 1, i = 1, num_trial_res) /)
-  
-  ! Can't initialze these during compilation, but do in before looping columns in retrievals
-  real, dimension(num_trial_res) ::  g_w, g_i, w0_w, w0_i
-  ! ------------------------------
-  ! Bin boundaries for the joint optical thickness/cloud top pressure histogram
-  !
-  integer, parameter :: numTauHistogramBins = 6, numPressureHistogramBins = 7
-
-  real, private :: dummy_real 
-  real, dimension(numTauHistogramBins + 1),      parameter :: &
-    tauHistogramBoundaries = (/ min_OpticalThickness, 1.3, 3.6, 9.4, 23., 60., 10000. /) 
-  real, dimension(numPressureHistogramBins + 1), parameter :: & ! Units Pa 
-    pressureHistogramBoundaries = (/ 0., 18000., 31000., 44000., 56000., 68000., 80000., 1000000. /) 
-  real, parameter :: highCloudPressureLimit = 440. * 100., lowCloudPressureLimit = 680. * 100.
-  !
-  ! For output - nominal bin centers and  bin boundaries. On output pressure bins are highest to lowest. 
-  !
-  integer, private :: k, l
-  real, parameter, dimension(2, numTauHistogramBins) ::   &
-    nominalTauHistogramBoundaries =                       &
-        reshape(source = (/ tauHistogramBoundaries(1),    &
-                            ((tauHistogramBoundaries(k), l = 1, 2), k = 2, numTauHistogramBins), &
-                            100000. /),                    &
-                shape = (/2,  numTauHistogramBins /) )
-  real, parameter, dimension(numTauHistogramBins) ::                    &
-    nominalTauHistogramCenters = (nominalTauHistogramBoundaries(1, :) + &
-                                  nominalTauHistogramBoundaries(2, :) ) / 2.
-  
-  real, parameter, dimension(2, numPressureHistogramBins) :: &
-    nominalPressureHistogramBoundaries =                     &
-        reshape(source = (/ 100000.,                         &
-                            ((pressureHistogramBoundaries(k), l = 1, 2), k = numPressureHistogramBins, 2, -1), &
-                            0.  /), &
-                shape = (/2,  numPressureHistogramBins /) )
-  real, parameter, dimension(numPressureHistogramBins) ::                         &
-    nominalPressureHistogramCenters = (nominalPressureHistogramBoundaries(1, :) + &
-                                       nominalPressureHistogramBoundaries(2, :) ) / 2.
-  ! DJS2015 START: Add bin descriptions for joint-histograms of partice-sizes and optical depth. This is
-  !                identical to what is done in COSPv.2.0.0 for histogram bin initialization. 
-  integer :: j
-  integer,parameter :: &
-       numMODISReffLiqBins = 6, & ! Number of bins for tau/ReffLiq joint-histogram
-       numMODISReffIceBins = 6    ! Number of bins for tau/ReffICE joint-histogram
-  real,parameter,dimension(numMODISReffLiqBins+1) :: &
-       reffLIQ_binBounds = (/0., 8e-6, 1.0e-5, 1.3e-5, 1.5e-5, 2.0e-5, 3.0e-5/)
-  real,parameter,dimension(numMODISReffIceBins+1) :: &
-       reffICE_binBounds = (/0., 1.0e-5, 2.0e-5, 3.0e-5, 4.0e-5, 6.0e-5, 9.0e-5/)
-  real,parameter,dimension(2,numMODISReffIceBins) :: &
-       reffICE_binEdges = reshape(source=(/reffICE_binBounds(1),((reffICE_binBounds(k),  &
-                                  l=1,2),k=2,numMODISReffIceBins),reffICE_binBounds(numMODISReffIceBins+1)/),  &
-                                  shape = (/2,numMODISReffIceBins/)) 
-  real,parameter,dimension(2,numMODISReffLiqBins) :: &
-       reffLIQ_binEdges = reshape(source=(/reffLIQ_binBounds(1),((reffLIQ_binBounds(k),  &
-                                  l=1,2),k=2,numMODISReffLiqBins),reffLIQ_binBounds(numMODISReffIceBins+1)/),  &
-                                  shape = (/2,numMODISReffLiqBins/))             
-  real,parameter,dimension(numMODISReffIceBins) :: &
-       reffICE_binCenters = (reffICE_binEdges(1,:)+reffICE_binEdges(2,:))/2.
-  real,parameter,dimension(numMODISReffLiqBins) :: &
-       reffLIQ_binCenters = (reffLIQ_binEdges(1,:)+reffLIQ_binEdges(2,:))/2.
-  ! DJS2015 END
-
-  ! ------------------------------
-  ! There are two ways to call the MODIS simulator: 
-  !  1) Provide total optical thickness and liquid/ice water content and we'll partition tau in 
-  !     subroutine modis_L2_simulator_oneTau, or 
-  !  2) Provide ice and liquid optical depths in each layer
-  !
-  interface modis_L2_simulator
-    module procedure modis_L2_simulator_oneTau, modis_L2_simulator_twoTaus
-  end interface 
-contains
-  !------------------------------------------------------------------------------------------------
-  ! MODIS simulator using specified liquid and ice optical thickness in each layer 
-  !
-  !   Note: this simulator operates on all points; to match MODIS itself night-time 
-  !     points should be excluded
-  !
-  !   Note: the simulator requires as input the optical thickness and cloud top pressure 
-  !     derived from the ISCCP simulator run with parameter top_height = 1. 
-  !     If cloud top pressure is higher than about 700 mb, MODIS can't use CO2 slicing 
-  !     and reverts to a thermal algorithm much like ISCCP's. Rather than replicate that 
-  !     alogrithm in this simulator we simply report the values from the ISCCP simulator. 
-  !
-  subroutine modis_L2_simulator_twoTaus(                                       &
-                                temp, pressureLayers, pressureLevels,          &
-                                liquid_opticalThickness, ice_opticalThickness, &
-                                waterSize, iceSize,                            & 
-                                isccpTau, isccpCloudTopPressure,               &
-                                retrievedPhase, retrievedCloudTopPressure, retrievedTau, retrievedSize)
-
-    ! Grid-mean quantities at layer centers, starting at the model top
-    !   dimension nLayers
-    real, dimension(:),    intent(in ) :: temp,           & ! Temperature, K
-                                          pressureLayers, & ! Pressure, Pa
-                                          pressureLevels    ! Pressure at layer edges, Pa (dimension nLayers + 1) 
-    ! Sub-column quantities
-    !   dimension  nSubcols, nLayers
-    real, dimension(:, :), intent(in ) :: liquid_opticalThickness, & ! Layer optical thickness @ 0.67 microns due to liquid
-                                          ice_opticalThickness       ! ditto, due to ice
-    real, dimension(:, :), intent(in ) :: waterSize,        & ! Cloud drop effective radius, microns
-                                          iceSize             ! Cloud ice effective radius, microns
-                                          
-    ! Cloud properties retrieved from ISCCP using top_height = 1
-    !    dimension nSubcols
-    real, dimension(:),    intent(in ) :: isccpTau, &           ! Column-integrated optical thickness 
-                                          isccpCloudTopPressure ! ISCCP-retrieved cloud top pressure (Pa) 
-
-    ! Properties retrieved by MODIS
-    !   dimension nSubcols
-    integer, dimension(:), intent(out) :: retrievedPhase               ! liquid/ice/other - integer, defined in module header
-    real,    dimension(:), intent(out) :: retrievedCloudTopPressure, & ! units of pressureLayers
-                                          retrievedTau,              & ! unitless
-                                          retrievedSize                ! microns 
-    ! ---------------------------------------------------
-    ! Local variables
-    logical, dimension(size(retrievedTau))                     :: cloudMask
-    real,    dimension(size(waterSize, 1), size(waterSize, 2)) :: tauLiquidFraction, tauTotal
-    real    :: integratedLiquidFraction
-    integer :: i, nSubcols, nLevels
-
-    ! ---------------------------------------------------
-    nSubcols = size(liquid_opticalThickness, 1)
-    nLevels  = size(liquid_opticalThickness, 2) 
- 
-    !
-    ! Initial error checks 
-    !   
-    if(any((/ size(ice_opticalThickness, 1), size(waterSize, 1), size(iceSize, 1), &
-              size(isccpTau), size(isccpCloudTopPressure),              &
-              size(retrievedPhase), size(retrievedCloudTopPressure),    &
-              size(retrievedTau), size(retrievedSize) /) /= nSubcols )) &
-       call complain_and_die("Differing number of subcolumns in one or more arrays") 
-    
-    if(any((/ size(ice_opticalThickness, 2), size(waterSize, 2), size(iceSize, 2),      &
-              size(temp), size(pressureLayers), size(pressureLevels)-1 /) /= nLevels )) &
-       call complain_and_die("Differing number of levels in one or more arrays") 
-       
-       
-    if(any( (/ any(temp <= 0.), any(pressureLayers <= 0.),  &
-               any(liquid_opticalThickness < 0.),           &
-               any(ice_opticalThickness < 0.),              &
-               any(waterSize < 0.), any(iceSize < 0.) /) )) &
-       call complain_and_die("Input values out of bounds") 
-             
-    ! ---------------------------------------------------
-    !
-    ! Compute the total optical thickness and the proportion due to liquid in each cell
-    !
-    where(liquid_opticalThickness(:, :) + ice_opticalThickness(:, :) > 0.) 
-      tauLiquidFraction(:, :) = liquid_opticalThickness(:, :)/(liquid_opticalThickness(:, :) + ice_opticalThickness(:, :))
-    elsewhere
-      tauLiquidFraction(:, :) = 0. 
-    end  where 
-    tauTotal(:, :) = liquid_opticalThickness(:, :) + ice_opticalThickness(:, :) 
-    
-    !
-    ! Optical depth retrieval 
-    !   This is simply a sum over the optical thickness in each layer 
-    !   It should agree with the ISCCP values after min values have been excluded 
-    !
-    retrievedTau(:) = sum(tauTotal(:, :), dim = 2)
-
-    !
-    ! Cloud detection - does optical thickness exceed detection threshold? 
-    !
-    cloudMask = retrievedTau(:) >= min_OpticalThickness
-    
-    !
-    ! Initialize initial estimates for size retrievals
-    !
-    if(any(cloudMask) .and. .not. useSimpleReScheme) then 
-      g_w(:)  = get_g_nir(  phaseIsLiquid, trial_re_w(:))
-      w0_w(:) = get_ssa_nir(phaseIsLiquid, trial_re_w(:))
-      g_i(:)  = get_g_nir(  phaseIsIce,    trial_re_i(:))
-      w0_i(:) = get_ssa_nir(phaseIsIce,    trial_re_i(:))
-    end if 
-    
-    do i = 1, nSubCols
-      if(cloudMask(i)) then 
-        !
-        ! Cloud top pressure determination 
-        !   MODIS uses CO2 slicing for clouds with tops above about 700 mb and thermal methods for clouds
-        !   lower than that. 
-        !  For CO2 slicing we report the optical-depth weighted pressure, integrating to a specified 
-        !    optical depth
-        ! This assumes linear variation in p between levels. Linear in ln(p) is probably better, 
-        !   though we'd need to deal with the lowest pressure gracefully. 
-        !
-        retrievedCloudTopPressure(i) = cloud_top_pressure((/ 0., tauTotal(i, :) /), &
-                                                          pressureLevels,           &
-                                                          CO2Slicing_TauLimit)  
-        
-        
-        !
-        ! Phase determination - determine fraction of total tau that's liquid 
-        ! When ice and water contribute about equally to the extinction we can't tell 
-        !   what the phase is 
-        !
-        integratedLiquidFraction = weight_by_extinction(tauTotal(i, :),          &
-                                                        tauLiquidFraction(i, :), &
-                                                        phase_TauLimit)
-        if(integratedLiquidFraction >= phaseDiscrimination_Threshold) then 
-          retrievedPhase(i) = phaseIsLiquid
-        else if (integratedLiquidFraction <= 1.- phaseDiscrimination_Threshold) then 
-          retrievedPhase(i) = phaseIsIce
-        else 
-          retrievedPhase(i) = phaseIsUndetermined
-        end if 
-        
-        !
-        ! Size determination 
-        !
-        if(useSimpleReScheme) then 
-          !   This is the extinction-weighted size considering only the phase we've chosen 
-          !
-          if(retrievedPhase(i) == phaseIsIce) then 
-            retrievedSize(i) = weight_by_extinction(ice_opticalThickness(i, :),  &
-                                                    iceSize(i, :), &
-                                                    (1. - integratedLiquidFraction) * size_TauLimit)
-  
-          else if(retrievedPhase(i) == phaseIsLiquid) then 
-            retrievedSize(i) = weight_by_extinction(liquid_opticalThickness(i, :), &
-                                                    waterSize(i, :), &
-                                                    integratedLiquidFraction * size_TauLimit)
-  
-          else
-            retrievedSize(i) = 0. 
-          end if 
-        else
-          retrievedSize(i) = 1.0e-06*retrieve_re(retrievedPhase(i), retrievedTau(i), &
-                         obs_Refl_nir = compute_nir_reflectance(liquid_opticalThickness(i, :), waterSize(i, :)*1.0e6, & 
-                         ice_opticalThickness(i, :),      iceSize(i, :)*1.0e6))
-        end if 
-      else 
-        !
-        ! Values when we don't think there's a cloud. 
-        !
-        retrievedCloudTopPressure(i) = R_UNDEF 
-        retrievedPhase(i) = phaseIsNone
-        retrievedSize(i) = R_UNDEF 
-        retrievedTau(i) = R_UNDEF 
-      end if
-    end do
-    where((retrievedSize(:) < 0.).and.(retrievedSize(:) /= R_UNDEF)) retrievedSize(:) = 1.0e-06*re_fill
-
-    ! We use the ISCCP-derived CTP for low clouds, since the ISCCP simulator ICARUS 
-    !   mimics what MODIS does to first order. 
-    !   Of course, ISCCP cloud top pressures are in mb. 
-    !   
-    where(cloudMask(:) .and. retrievedCloudTopPressure(:) > CO2Slicing_PressureLimit) &
-      retrievedCloudTopPressure(:) = isccpCloudTopPressure * 100. 
-    
-  end subroutine modis_L2_simulator_twoTaus
-  !------------------------------------------------------------------------------------------------
-  !
-  ! MODIS simulator: provide a single optical thickness and the cloud ice and liquid contents; 
-  !   we'll partition this into ice and liquid optical thickness and call the full MODIS simulator 
-  ! 
-  subroutine modis_L2_simulator_oneTau(                                         &
-                                temp, pressureLayers, pressureLevels,           &
-                                opticalThickness, cloudWater, cloudIce,         &
-                                waterSize, iceSize,                             & 
-                                isccpTau, isccpCloudTopPressure,                &
-                                retrievedPhase, retrievedCloudTopPressure, retrievedTau, retrievedSize)
-    ! Grid-mean quantities at layer centers, 
-    !   dimension nLayers
-    real, dimension(:),    intent(in ) :: temp,           & ! Temperature, K
-                                          pressureLayers, & ! Pressure, Pa
-                                          pressureLevels    ! Pressure at layer edges, Pa (dimension nLayers + 1) 
-    ! Sub-column quantities
-    !   dimension nLayers, nSubcols
-    real, dimension(:, :), intent(in ) :: opticalThickness, & ! Layer optical thickness @ 0.67 microns
-                                          cloudWater,       & ! Cloud water content, arbitrary units
-                                          cloudIce            ! Cloud water content, same units as cloudWater
-    real, dimension(:, :), intent(in ) :: waterSize,        & ! Cloud drop effective radius, microns
-                                          iceSize             ! Cloud ice effective radius, microns
-
-    ! Cloud properties retrieved from ISCCP using top_height = 1
-    !    dimension nSubcols
-    
-    real, dimension(:),    intent(in ) :: isccpTau, &           ! Column-integrated optical thickness 
-                                          isccpCloudTopPressure ! ISCCP-retrieved cloud top pressure (Pa) 
-
-    ! Properties retrieved by MODIS
-    !   dimension nSubcols
-    integer, dimension(:), intent(out) :: retrievedPhase               ! liquid/ice/other - integer
-    real,    dimension(:), intent(out) :: retrievedCloudTopPressure, & ! units of pressureLayers
-                                          retrievedTau,              & ! unitless
-                                          retrievedSize                ! microns (or whatever units 
-                                                                       !   waterSize and iceSize are supplied in)
-    ! ---------------------------------------------------
-    ! Local variables
-    real, dimension(size(opticalThickness, 1), size(opticalThickness, 2)) :: & 
-           liquid_opticalThickness, ice_opticalThickness, tauLiquidFraction
-    
-    real :: seuil
-    ! ---------------------------------------------------
-    
-    if (ok_debug_cosp) then
-       seuil=1.e-9
-    else
-       seuil=0.0
-    endif
-
-    where(cloudIce(:, :) <= 0.) 
-      tauLiquidFraction(:, :) = 1. 
-    elsewhere
-      where (cloudWater(:, :) <= 0.) 
-        tauLiquidFraction(:, :) = 0. 
-      elsewhere 
-        ! 
-        ! Geometic optics limit - tau as LWP/re  (proportional to LWC/re) 
-        !
-! Modif AI 02 2018 
-        tauLiquidFraction(:, :) = (cloudWater(:, :)/max(waterSize(:, :), seuil) ) / &
-                                  (cloudWater(:, :)/max(waterSize(:, :), seuil) + & 
-                                   cloudIce(:, :)/(ice_density * max(iceSize(:, :), seuil)) ) 
-      end where
-    end where
-    liquid_opticalThickness(:, :) = tauLiquidFraction(:, :) * opticalThickness(:, :) 
-    ice_opticalThickness   (:, :) = opticalThickness(:, :) - liquid_opticalThickness(:, :)
-    
-    call modis_L2_simulator_twoTaus(temp, pressureLayers, pressureLevels,          &
-                                    liquid_opticalThickness, ice_opticalThickness, &
-                                    waterSize, iceSize,                            & 
-                                    isccpTau, isccpCloudTopPressure,               &
-                                    retrievedPhase, retrievedCloudTopPressure, retrievedTau, retrievedSize)
-                                
-  end subroutine modis_L2_simulator_oneTau
-
-  ! ########################################################################################
-  subroutine modis_column(nPoints,nSubCols,phase, cloud_top_pressure, optical_thickness, particle_size,      &
-       Cloud_Fraction_Total_Mean,         Cloud_Fraction_Water_Mean,         Cloud_Fraction_Ice_Mean,        &
-       Cloud_Fraction_High_Mean,          Cloud_Fraction_Mid_Mean,           Cloud_Fraction_Low_Mean,        &
-       Optical_Thickness_Total_Mean,      Optical_Thickness_Water_Mean,      Optical_Thickness_Ice_Mean,     &
-       Optical_Thickness_Total_MeanLog10, Optical_Thickness_Water_MeanLog10, Optical_Thickness_Ice_MeanLog10,&
-       Cloud_Particle_Size_Water_Mean,    Cloud_Particle_Size_Ice_Mean,      Cloud_Top_Pressure_Total_Mean,  &
-       Liquid_Water_Path_Mean,            Ice_Water_Path_Mean,                                               &    
-       Optical_Thickness_vs_Cloud_Top_Pressure,Optical_Thickness_vs_ReffIce,Optical_Thickness_vs_ReffLiq)
-    
-    ! INPUTS
-    integer,intent(in) :: &
-         nPoints,                           & ! Number of horizontal gridpoints
-         nSubCols                             ! Number of subcolumns
-    integer,intent(in), dimension(:,:) ::  &
-!ds    integer,intent(in), dimension(nPoints, nSubCols) ::  &
-         phase                             
-    real,intent(in),dimension(:,:) ::  &
-!ds    real,intent(in),dimension(nPoints, nSubCols) ::  &
-         cloud_top_pressure,                &
-         optical_thickness,                 &
-         particle_size
- 
-    ! OUTPUTS 
-    real,intent(inout),dimension(:)  ::   & !
-!ds    real,intent(inout),dimension(nPoints)  ::   & !
-         Cloud_Fraction_Total_Mean,         & !
-         Cloud_Fraction_Water_Mean,         & !
-         Cloud_Fraction_Ice_Mean,           & !
-         Cloud_Fraction_High_Mean,          & !
-         Cloud_Fraction_Mid_Mean,           & !
-         Cloud_Fraction_Low_Mean,           & !
-         Optical_Thickness_Total_Mean,      & !
-         Optical_Thickness_Water_Mean,      & !
-         Optical_Thickness_Ice_Mean,        & !
-         Optical_Thickness_Total_MeanLog10, & !
-         Optical_Thickness_Water_MeanLog10, & !
-         Optical_Thickness_Ice_MeanLog10,   & !
-         Cloud_Particle_Size_Water_Mean,    & !
-         Cloud_Particle_Size_Ice_Mean,      & !
-         Cloud_Top_Pressure_Total_Mean,     & !
-         Liquid_Water_Path_Mean,            & !
-         Ice_Water_Path_Mean                  !
-    real,intent(inout),dimension(:,:,:) :: &
-!ds    real,intent(inout),dimension(nPoints,numTauHistogramBins,numPressureHistogramBins) :: &
-         Optical_Thickness_vs_Cloud_Top_Pressure
-    real,intent(inout),dimension(:,:,:) :: &    
-!ds    real,intent(inout),dimension(nPoints,numTauHistogramBins,numMODISReffIceBins) :: &    
-         Optical_Thickness_vs_ReffIce
-    real,intent(inout),dimension(:,:,:) :: &    
-!ds    real,intent(inout),dimension(nPoints,numTauHistogramBins,numMODISReffLiqBins) :: &    
-         Optical_Thickness_vs_ReffLiq         
-
-    ! LOCAL VARIABLES
-    real, parameter :: &
-         LWP_conversion = 2./3. * 1000. ! MKS units  
-    integer :: i, j
-    logical, dimension(nPoints,nSubCols) :: &
-         cloudMask,      &
-         waterCloudMask, &
-         iceCloudMask,   &
-         validRetrievalMask
-    real,dimension(nPoints,nSubCols) :: &
-         tauWRK,ctpWRK,reffIceWRK,reffLiqWRK
-    
-    ! ########################################################################################
-    ! Include only those pixels with successful retrievals in the statistics 
-    ! ########################################################################################
-    validRetrievalMask(1:nPoints,1:nSubCols) = particle_size(1:nPoints,1:nSubCols) > 0.
-    cloudMask(1:nPoints,1:nSubCols) = phase(1:nPoints,1:nSubCols) /= phaseIsNone .and.       &
-         validRetrievalMask(1:nPoints,1:nSubCols)
-    waterCloudMask(1:nPoints,1:nSubCols) = phase(1:nPoints,1:nSubCols) == phaseIsLiquid .and. &
-         validRetrievalMask(1:nPoints,1:nSubCols)
-    iceCloudMask(1:nPoints,1:nSubCols)   = phase(1:nPoints,1:nSubCols) == phaseIsIce .and.    &
-         validRetrievalMask(1:nPoints,1:nSubCols)
-
-    ! ########################################################################################
-    ! Use these as pixel counts at first 
-    ! ########################################################################################
-    Cloud_Fraction_Total_Mean(1:nPoints) = real(count(cloudMask,      dim = 2))
-    Cloud_Fraction_Water_Mean(1:nPoints) = real(count(waterCloudMask, dim = 2))
-    Cloud_Fraction_Ice_Mean(1:nPoints)   = real(count(iceCloudMask,   dim = 2))
-    Cloud_Fraction_High_Mean(1:nPoints)  = real(count(cloudMask .and. cloud_top_pressure <=          &
-                                           highCloudPressureLimit, dim = 2)) 
-    Cloud_Fraction_Low_Mean(1:nPoints)   = real(count(cloudMask .and. cloud_top_pressure >           &
-                                           lowCloudPressureLimit,  dim = 2)) 
-    Cloud_Fraction_Mid_Mean(1:nPoints)   = Cloud_Fraction_Total_Mean(1:nPoints) - Cloud_Fraction_High_Mean(1:nPoints)&
-                                           - Cloud_Fraction_Low_Mean(1:nPoints)
-
-    ! ########################################################################################
-    ! Compute mean optical thickness.
-    ! ########################################################################################
-    where (Cloud_Fraction_Total_Mean == 0)
-       Optical_Thickness_Total_Mean      = R_UNDEF
-    elsewhere
-       Optical_Thickness_Total_Mean(1:nPoints) = sum(optical_thickness, mask = cloudMask,      dim = 2) / &
-                                                 Cloud_Fraction_Total_Mean(1:nPoints) 
-    endwhere
-    where (Cloud_Fraction_Water_Mean == 0)
-       Optical_Thickness_Water_Mean      = R_UNDEF
-    elsewhere
-       Optical_Thickness_Water_Mean(1:nPoints) = sum(optical_thickness, mask = waterCloudMask, dim = 2) / &
-                                                 Cloud_Fraction_Water_Mean(1:nPoints)
-    endwhere
-    where (Cloud_Fraction_Ice_Mean == 0)
-       Optical_Thickness_Ice_Mean        = R_UNDEF
-    elsewhere
-       Optical_Thickness_Ice_Mean(1:nPoints)   = sum(optical_thickness, mask = iceCloudMask,   dim = 2) / &
-                                                 Cloud_Fraction_Ice_Mean(1:nPoints)
-    endwhere
-   
-    ! ########################################################################################
-    ! We take the absolute value of optical thickness here to satisfy compilers that complains 
-    ! when we evaluate the logarithm of a negative number, even though it's not included in 
-    ! the sum. 
-    ! ########################################################################################
-    where (Cloud_Fraction_Total_Mean == 0)
-       Optical_Thickness_Total_MeanLog10 = R_UNDEF
-    elsewhere
-       Optical_Thickness_Total_MeanLog10(1:nPoints) = sum(log10(abs(optical_thickness)), mask = cloudMask, &
-           dim = 2) / Cloud_Fraction_Total_Mean(1:nPoints)
-    endwhere
-    where (Cloud_Fraction_Water_Mean == 0)
-       Optical_Thickness_Water_MeanLog10 = R_UNDEF
-    elsewhere
-       Optical_Thickness_Water_MeanLog10(1:nPoints) = sum(log10(abs(optical_thickness)), mask = waterCloudMask,&
-            dim = 2) / Cloud_Fraction_Water_Mean(1:nPoints)
-    endwhere
-    where (Cloud_Fraction_Ice_Mean == 0)
-       Optical_Thickness_Ice_MeanLog10   = R_UNDEF
-    elsewhere 
-       Optical_Thickness_Ice_MeanLog10(1:nPoints) = sum(log10(abs(optical_thickness)), mask = iceCloudMask,&
-            dim = 2) / Cloud_Fraction_Ice_Mean(1:nPoints)
-    endwhere
-    where (Cloud_Fraction_Water_Mean == 0)
-       Cloud_Particle_Size_Water_Mean    = R_UNDEF
-    elsewhere
-       Cloud_Particle_Size_Water_Mean(1:nPoints) = sum(particle_size, mask = waterCloudMask, dim = 2) / &
-            Cloud_Fraction_Water_Mean(1:nPoints)
-    endwhere
-    where (Cloud_Fraction_Ice_Mean == 0)
-       Cloud_Particle_Size_Ice_Mean      = R_UNDEF  
-    elsewhere
-       Cloud_Particle_Size_Ice_Mean(1:nPoints) = sum(particle_size, mask = iceCloudMask,   dim = 2) / &
-            Cloud_Fraction_Ice_Mean(1:nPoints)
-    endwhere
-    where (Cloud_Fraction_Total_Mean == 0)
-       Cloud_Top_Pressure_Total_Mean     = R_UNDEF
-    elsewhere
-       Cloud_Top_Pressure_Total_Mean(1:nPoints) = sum(cloud_top_pressure, mask = cloudMask, dim = 2) / &
-            max(1, count(cloudMask, dim = 2))
-    endwhere
-    where (Cloud_Fraction_Water_Mean == 0)
-       Liquid_Water_Path_Mean            = R_UNDEF
-    elsewhere
-       Liquid_Water_Path_Mean(1:nPoints) = LWP_conversion*sum(particle_size*optical_thickness, &
-            mask=waterCloudMask,dim=2)/Cloud_Fraction_Water_Mean(1:nPoints)
-    endwhere
-    where (Cloud_Fraction_Ice_Mean == 0)
-       Ice_Water_Path_Mean               = R_UNDEF
-    elsewhere
-       Ice_Water_Path_Mean(1:nPoints) = LWP_conversion * ice_density*sum(particle_size*optical_thickness,&
-             mask=iceCloudMask,dim = 2) /Cloud_Fraction_Ice_Mean(1:nPoints)
-    endwhere
-    ! ########################################################################################
-    ! Normalize pixel counts to fraction.
-    ! ########################################################################################
-    Cloud_Fraction_High_Mean(1:nPoints)  = Cloud_Fraction_High_Mean(1:nPoints)  /nSubcols
-    Cloud_Fraction_Mid_Mean(1:nPoints)   = Cloud_Fraction_Mid_Mean(1:nPoints)   /nSubcols
-    Cloud_Fraction_Low_Mean(1:nPoints)   = Cloud_Fraction_Low_Mean(1:nPoints)   /nSubcols
-    Cloud_Fraction_Total_Mean(1:nPoints) = Cloud_Fraction_Total_Mean(1:nPoints) /nSubcols
-    Cloud_Fraction_Ice_Mean(1:nPoints)   = Cloud_Fraction_Ice_Mean(1:nPoints)   /nSubcols
-    Cloud_Fraction_Water_Mean(1:nPoints) = Cloud_Fraction_Water_Mean(1:nPoints) /nSubcols
-    
-    ! ########################################################################################
-    ! Set clear-scenes to undefined
-    ! ########################################################################################
-!    where (Cloud_Fraction_High_Mean == 0)  Cloud_Fraction_High_Mean = R_UNDEF
-!    where (Cloud_Fraction_Mid_Mean == 0)   Cloud_Fraction_Mid_Mean = R_UNDEF
-!    where (Cloud_Fraction_Low_Mean == 0)   Cloud_Fraction_Low_Mean = R_UNDEF
-
-    ! ########################################################################################
-    ! Joint histogram  
-    ! ########################################################################################
-
-    ! Loop over all points
-    tauWRK(1:nPoints,1:nSubCols)     = optical_thickness(1:nPoints,1:nSubCols)
-    ctpWRK(1:nPoints,1:nSubCols)     = cloud_top_pressure(1:nPoints,1:nSubCols)
-    reffIceWRK(1:nPoints,1:nSubCols) = merge(particle_size,R_UNDEF,iceCloudMask)
-    reffLiqWRK(1:nPoints,1:nSubCols) = merge(particle_size,R_UNDEF,waterCloudMask)
-    do j=1,nPoints
-
-       ! Fill clear and optically thin subcolumns with fill
-       where(.not. cloudMask(j,1:nSubCols)) 
-          tauWRK(j,1:nSubCols) = -999.
-          ctpWRK(j,1:nSubCols) = -999.
-       endwhere
-       ! Joint histogram of tau/CTP
-       call hist2D(tauWRK(j,1:nSubCols),ctpWRK(j,1:nSubCols),nSubCols,&
-                   tauHistogramBoundaries,numTauHistogramBins,&
-                   pressureHistogramBoundaries,numPressureHistogramBins,&
-                   Optical_Thickness_vs_Cloud_Top_Pressure(j,1:numTauHistogramBins,1:numPressureHistogramBins))
-       ! Joint histogram of tau/ReffICE
-       call hist2D(tauWRK(j,1:nSubCols),reffIceWrk(j,1:nSubCols),nSubCols,               &
-                   tauHistogramBoundaries,numTauHistogramBins,reffICE_binBounds,         &
-                   numMODISReffIceBins, Optical_Thickness_vs_ReffIce(j,1:numTauHistogramBins,1:numMODISReffIceBins))
-       ! Joint histogram of tau/ReffLIQ
-       call hist2D(tauWRK(j,1:nSubCols),reffLiqWrk(j,1:nSubCols),nSubCols,               &
-                   tauHistogramBoundaries,numTauHistogramBins,reffLIQ_binBounds,         &
-                   numMODISReffLiqBins, Optical_Thickness_vs_ReffLiq(j,1:numTauHistogramBins,1:numMODISReffLiqBins))                   
-
-    enddo   
-    Optical_Thickness_vs_Cloud_Top_Pressure(1:nPoints,1:numTauHistogramBins,1:numPressureHistogramBins) = &
-         Optical_Thickness_vs_Cloud_Top_Pressure(1:nPoints,1:numTauHistogramBins,1:numPressureHistogramBins)/nSubCols
-    Optical_Thickness_vs_ReffIce(1:nPoints,1:numTauHistogramBins,1:numMODISReffIceBins) = &
-         Optical_Thickness_vs_ReffIce(1:nPoints,1:numTauHistogramBins,1:numMODISReffIceBins)/nSubCols
-    Optical_Thickness_vs_ReffLiq(1:nPoints,1:numTauHistogramBins,1:numMODISReffLiqBins) = &
-         Optical_Thickness_vs_ReffLiq(1:nPoints,1:numTauHistogramBins,1:numMODISReffLiqBins)/nSubCols 
-
-  end subroutine modis_column
-  ! ######################################################################################
-  ! SUBROUTINE hist2D
-  ! ######################################################################################
-  subroutine hist2D(var1,var2,npts,bin1,nbin1,bin2,nbin2,jointHist)
-    implicit none
-    
-    ! INPUTS
-    integer, intent(in) :: &
-         npts,  & ! Number of data points to be sorted
-         nbin1, & ! Number of bins in histogram direction 1 
-         nbin2    ! Number of bins in histogram direction 2
-    real,intent(in),dimension(npts) :: &
-         var1,  & ! Variable 1 to be sorted into bins
-         var2     ! variable 2 to be sorted into bins
-    real,intent(in),dimension(nbin1+1) :: &
-         bin1     ! Histogram bin 1 boundaries
-    real,intent(in),dimension(nbin2+1) :: &
-         bin2     ! Histogram bin 2 boundaries
-    ! OUTPUTS
-    real,intent(out),dimension(nbin1,nbin2) :: &
-         jointHist
-    
-    ! LOCAL VARIABLES
-    integer :: ij,ik
-    
-    do ij=2,nbin1+1
-       do ik=2,nbin2+1
-          jointHist(ij-1,ik-1)=count(var1 .ge. bin1(ij-1) .and. var1 .lt. bin1(ij) .and. &
-               var2 .ge. bin2(ik-1) .and. var2 .lt. bin2(ik))        
-       enddo
-    enddo
-  end subroutine hist2D
-  
-  !------------------------------------------------------------------------------------------------
-  subroutine modis_L3_simulator(phase, cloud_top_pressure, optical_thickness, particle_size,            &
-       Cloud_Fraction_Total_Mean,       Cloud_Fraction_Water_Mean,       Cloud_Fraction_Ice_Mean,       &
-       Cloud_Fraction_High_Mean,        Cloud_Fraction_Mid_Mean,         Cloud_Fraction_Low_Mean,       &
-       Optical_Thickness_Total_Mean,    Optical_Thickness_Water_Mean,    Optical_Thickness_Ice_Mean,    &
-       Optical_Thickness_Total_MeanLog10, Optical_Thickness_Water_MeanLog10, Optical_Thickness_Ice_MeanLog10, &
-                                        Cloud_Particle_Size_Water_Mean,  Cloud_Particle_Size_Ice_Mean,  &
-       Cloud_Top_Pressure_Total_Mean,                                                                   &
-                                        Liquid_Water_Path_Mean,          Ice_Water_Path_Mean,           &    
-       Optical_Thickness_vs_Cloud_Top_Pressure)
-    !
-    ! Inputs; dimension nPoints, nSubcols
-    !
-    integer, dimension(:, :),   intent(in)  :: phase
-    real,    dimension(:, :),   intent(in)  :: cloud_top_pressure, optical_thickness, particle_size
-    !
-    ! Outputs; dimension nPoints
-    !
-    real,    dimension(:),      intent(out) :: &
-       Cloud_Fraction_Total_Mean,       Cloud_Fraction_Water_Mean,       Cloud_Fraction_Ice_Mean,       &
-       Cloud_Fraction_High_Mean,        Cloud_Fraction_Mid_Mean,         Cloud_Fraction_Low_Mean,       &
-       Optical_Thickness_Total_Mean,    Optical_Thickness_Water_Mean,    Optical_Thickness_Ice_Mean,    &
-       Optical_Thickness_Total_MeanLog10, Optical_Thickness_Water_MeanLog10, Optical_Thickness_Ice_MeanLog10, &
-                                        Cloud_Particle_Size_Water_Mean,  Cloud_Particle_Size_Ice_Mean,  &
-       Cloud_Top_Pressure_Total_Mean,                                                                   &
-                                        Liquid_Water_Path_Mean,          Ice_Water_Path_Mean
-    ! tau/ctp histogram; dimensions nPoints, numTauHistogramBins , numPressureHistogramBins 
-    real,    dimension(:, :, :), intent(out) :: Optical_Thickness_vs_Cloud_Top_Pressure
-    ! ---------------------------
-    ! Local variables
-    !
-    real, parameter :: LWP_conversion = 2./3. * 1000. ! MKS units  
-    integer :: i, j
-    integer :: nPoints, nSubcols 
-    logical, dimension(size(phase, 1), size(phase, 2)) :: &
-      cloudMask, waterCloudMask, iceCloudMask, validRetrievalMask
-    logical, dimension(size(phase, 1), size(phase, 2), numTauHistogramBins     ) :: tauMask
-    logical, dimension(size(phase, 1), size(phase, 2), numPressureHistogramBins) :: pressureMask
-    ! ---------------------------
-    
-    nPoints  = size(phase, 1) 
-    nSubcols = size(phase, 2) 
-    !
-    ! Array conformance checks
-    !
-    if(any( (/ size(cloud_top_pressure, 1), size(optical_thickness, 1), size(particle_size, 1),                                &
-               size(Cloud_Fraction_Total_Mean),       size(Cloud_Fraction_Water_Mean),       size(Cloud_Fraction_Ice_Mean),    &
-               size(Cloud_Fraction_High_Mean),        size(Cloud_Fraction_Mid_Mean),         size(Cloud_Fraction_Low_Mean),    &
-               size(Optical_Thickness_Total_Mean),    size(Optical_Thickness_Water_Mean),    size(Optical_Thickness_Ice_Mean), &
-               size(Optical_Thickness_Total_MeanLog10), size(Optical_Thickness_Water_MeanLog10), &
-               size(Optical_Thickness_Ice_MeanLog10),   size(Cloud_Particle_Size_Water_Mean),    &
-               size(Cloud_Particle_Size_Ice_Mean),      size(Cloud_Top_Pressure_Total_Mean),     &
-               size(Liquid_Water_Path_Mean),          size(Ice_Water_Path_Mean) /) /= nPoints))  &
-      call complain_and_die("Some L3 arrays have wrong number of grid points") 
-    if(any( (/ size(cloud_top_pressure, 2), size(optical_thickness, 2), size(particle_size, 2) /)  /= nSubcols)) &
-      call complain_and_die("Some L3 arrays have wrong number of subcolumns") 
-    
-    
-    !
-    ! Include only those pixels with successful retrievals in the statistics 
-    !
-    validRetrievalMask(:, :) = particle_size(:, :) > 0.
-    cloudMask      = phase(:, :) /= phaseIsNone   .and. validRetrievalMask(:, :)
-    waterCloudMask = phase(:, :) == phaseIsLiquid .and. validRetrievalMask(:, :)
-    iceCloudMask   = phase(:, :) == phaseIsIce    .and. validRetrievalMask(:, :)
-    !
-    ! Use these as pixel counts at first 
-    !
-    Cloud_Fraction_Total_Mean(:) = real(count(cloudMask,      dim = 2))
-    Cloud_Fraction_Water_Mean(:) = real(count(waterCloudMask, dim = 2))
-    Cloud_Fraction_Ice_Mean(:)   = real(count(iceCloudMask,   dim = 2))
-    
-    Cloud_Fraction_High_Mean(:) = real(count(cloudMask .and. cloud_top_pressure <= highCloudPressureLimit, dim = 2)) 
-    Cloud_Fraction_Low_Mean(:)  = real(count(cloudMask .and. cloud_top_pressure >  lowCloudPressureLimit,  dim = 2)) 
-    Cloud_Fraction_Mid_Mean(:)  = Cloud_Fraction_Total_Mean(:) - Cloud_Fraction_High_Mean(:) - Cloud_Fraction_Low_Mean(:)
-    
-    !
-    ! Don't want to divide by 0, even though the sums will be 0 where the pixel counts are 0. 
-    !
-    where (Cloud_Fraction_Total_Mean == 0) Cloud_Fraction_Total_Mean = -1. 
-    where (Cloud_Fraction_Water_Mean == 0) Cloud_Fraction_Water_Mean = -1.
-    where (Cloud_Fraction_Ice_Mean   == 0) Cloud_Fraction_Ice_Mean   = -1.
-    
-    Optical_Thickness_Total_Mean = sum(optical_thickness, mask = cloudMask,      dim = 2) / Cloud_Fraction_Total_Mean(:) 
-    Optical_Thickness_Water_Mean = sum(optical_thickness, mask = waterCloudMask, dim = 2) / Cloud_Fraction_Water_Mean(:)
-    Optical_Thickness_Ice_Mean   = sum(optical_thickness, mask = iceCloudMask,   dim = 2) / Cloud_Fraction_Ice_Mean(:)
-   
-    ! We take the absolute value of optical thickness here to satisfy compilers that complains when we 
-    !   evaluate the logarithm of a negative number, even though it's not included in the sum. 
-    Optical_Thickness_Total_MeanLog10 = sum(log10(abs(optical_thickness)), mask = cloudMask,      dim = 2) / &
-                                        Cloud_Fraction_Total_Mean(:)
-    Optical_Thickness_Water_MeanLog10 = sum(log10(abs(optical_thickness)), mask = waterCloudMask, dim = 2) / &
-                                        Cloud_Fraction_Water_Mean(:)
-    Optical_Thickness_Ice_MeanLog10   = sum(log10(abs(optical_thickness)), mask = iceCloudMask,   dim = 2) / &
-                                        Cloud_Fraction_Ice_Mean(:)
-   
-    Cloud_Particle_Size_Water_Mean = sum(particle_size, mask = waterCloudMask, dim = 2) / Cloud_Fraction_Water_Mean(:)
-    Cloud_Particle_Size_Ice_Mean   = sum(particle_size, mask = iceCloudMask,   dim = 2) / Cloud_Fraction_Ice_Mean(:)
-    
-    Cloud_Top_Pressure_Total_Mean = sum(cloud_top_pressure, mask = cloudMask, dim = 2) / max(1, count(cloudMask, dim = 2))
-    
-    Liquid_Water_Path_Mean = LWP_conversion &
-                             * sum(particle_size * optical_thickness, mask = waterCloudMask, dim = 2) &
-                             / Cloud_Fraction_Water_Mean(:)
-    Ice_Water_Path_Mean    = LWP_conversion * ice_density &
-                             * sum(particle_size * optical_thickness, mask = iceCloudMask,   dim = 2) &
-                             / Cloud_Fraction_Ice_Mean(:)
-
-    !
-    ! Normalize pixel counts to fraction
-    !   The first three cloud fractions have been set to -1 in cloud-free areas, so set those places to 0.
-    ! 
-    Cloud_Fraction_Total_Mean(:) = max(0., Cloud_Fraction_Total_Mean(:)/nSubcols)
-    Cloud_Fraction_Water_Mean(:) = max(0., Cloud_Fraction_Water_Mean(:)/nSubcols)
-    Cloud_Fraction_Ice_Mean(:)   = max(0., Cloud_Fraction_Ice_Mean(:)  /nSubcols)
-    
-    Cloud_Fraction_High_Mean(:)  = Cloud_Fraction_High_Mean(:) /nSubcols
-    Cloud_Fraction_Mid_Mean(:)   = Cloud_Fraction_Mid_Mean(:)  /nSubcols
-    Cloud_Fraction_Low_Mean(:)   = Cloud_Fraction_Low_Mean(:)  /nSubcols
-    
-    ! ----
-    ! Joint histogram 
-    ! 
-    do i = 1, numTauHistogramBins 
-      where(cloudMask(:, :)) 
-        tauMask(:, :, i) = optical_thickness(:, :) >= tauHistogramBoundaries(i) .and. &
-                           optical_thickness(:, :) <  tauHistogramBoundaries(i+1)
-      elsewhere
-        tauMask(:, :, i) = .false.
-      end where
-    end do 
-
-    do i = 1, numPressureHistogramBins 
-      where(cloudMask(:, :)) 
-        pressureMask(:, :, i) = cloud_top_pressure(:, :) >= pressureHistogramBoundaries(i) .and. &
-                                cloud_top_pressure(:, :) <  pressureHistogramBoundaries(i+1)
-      elsewhere
-        pressureMask(:, :, i) = .false.
-      end where
-    end do 
-    
-    do i = 1, numPressureHistogramBins
-      do j = 1, numTauHistogramBins
-        Optical_Thickness_vs_Cloud_Top_Pressure(:, j, i) = & 
-          real(count(tauMask(:, :, j) .and. pressureMask(:, :, i), dim = 2)) / real(nSubcols)
-      end do 
-    end do 
-    
-  end subroutine modis_L3_simulator
-  !------------------------------------------------------------------------------------------------
-  function cloud_top_pressure(tauIncrement, pressure, tauLimit) 
-    real, dimension(:), intent(in) :: tauIncrement, pressure
-    real,               intent(in) :: tauLimit
-    real                           :: cloud_top_pressure
-    !
-    ! Find the extinction-weighted pressure. Assume that pressure varies linearly between 
-    !   layers and use the trapezoidal rule.
-    !
-    
-    real :: deltaX, totalTau, totalProduct
-    integer :: i 
-    
-    totalTau = 0.; totalProduct = 0. 
-    do i = 2, size(tauIncrement)
-      if(totalTau + tauIncrement(i) > tauLimit) then 
-        deltaX = tauLimit - totalTau
-        totalTau = totalTau + deltaX
-        !
-        ! Result for trapezoidal rule when you take less than a full step
-        !   tauIncrement is a layer-integrated value
-        !
-        totalProduct = totalProduct           &
-                     + pressure(i-1) * deltaX &
-                     + (pressure(i) - pressure(i-1)) * deltaX**2/(2. * tauIncrement(i)) 
-      else
-        totalTau =     totalTau     + tauIncrement(i) 
-        totalProduct = totalProduct + tauIncrement(i) * (pressure(i) + pressure(i-1)) / 2.
-      end if 
-      if(totalTau >= tauLimit) exit
-    end do 
-    cloud_top_pressure = totalProduct/totalTau
-  end function cloud_top_pressure
-  !------------------------------------------------------------------------------------------------
-  function weight_by_extinction(tauIncrement, f, tauLimit) 
-    real, dimension(:), intent(in) :: tauIncrement, f
-    real,               intent(in) :: tauLimit
-    real                           :: weight_by_extinction
-    !
-    ! Find the extinction-weighted value of f(tau), assuming constant f within each layer
-    !
-    
-    real    :: deltaX, totalTau, totalProduct
-    integer :: i 
-    
-    totalTau = 0.; totalProduct = 0. 
-    do i = 1, size(tauIncrement)
-      if(totalTau + tauIncrement(i) > tauLimit) then 
-        deltaX       = tauLimit - totalTau
-        totalTau     = totalTau     + deltaX
-        totalProduct = totalProduct + deltaX * f(i) 
-      else
-        totalTau     = totalTau     + tauIncrement(i) 
-        totalProduct = totalProduct + tauIncrement(i) * f(i) 
-      end if 
-      if(totalTau >= tauLimit) exit
-    end do 
-    weight_by_extinction = totalProduct/totalTau
-  end function weight_by_extinction
-  !------------------------------------------------------------------------------------------------
-  pure function compute_nir_reflectance(water_tau, water_size, ice_tau, ice_size) 
-    real, dimension(:), intent(in) :: water_tau, water_size, ice_tau, ice_size
-    real                           :: compute_nir_reflectance
-    
-    real, dimension(size(water_tau)) :: water_g, water_w0, ice_g, ice_w0, &
-                                        tau, g, w0
-    !----------------------------------------
-    water_g(:)  = get_g_nir(  phaseIsLiquid, water_size) 
-    water_w0(:) = get_ssa_nir(phaseIsLiquid, water_size) 
-    ice_g(:)    = get_g_nir(  phaseIsIce,    ice_size) 
-    ice_w0(:)   = get_ssa_nir(phaseIsIce,    ice_size) 
-    !
-    ! Combine ice and water optical properties
-    !
-    g(:) = 0; w0(:) = 0. 
-    tau(:) = ice_tau(:) + water_tau(:) 
-    where (tau(:) > 0) 
-      w0(:) = (water_tau(:) * water_w0(:)  + ice_tau(:) * ice_w0(:)) / &
-              tau(:)
-      g(:) = (water_tau(:) * water_g(:) * water_w0(:)  + ice_tau(:) * ice_g(:) * ice_w0(:)) / &
-             (w0(:) * tau(:))
-    end where
-    
-    compute_nir_reflectance = compute_toa_reflectace(tau, g, w0)
-  end function compute_nir_reflectance
-  !------------------------------------------------------------------------------------------------
-  ! Retreivals
-  !------------------------------------------------------------------------------------------------
-  elemental function retrieve_re (phase, tau, obs_Refl_nir)
-      integer, intent(in) :: phase
-      real,    intent(in) :: tau, obs_Refl_nir
-      real                :: retrieve_re
-      !
-      ! Finds the re that produces the minimum mis-match between predicted and observed reflectance in 
-      !   MODIS band 7 (near IR)
-      ! Uses 
-      !  fits for asymmetry parameter g(re) and single scattering albedo w0(re) based on MODIS tables 
-      !  two-stream for layer reflectance and transmittance as a function of optical thickness tau, g, and w0
-      !  adding-doubling for total reflectance 
-      !  
-      !
-      !
-      ! Local variables
-      !
-      real, parameter :: min_distance_to_boundary = 0.01
-      real    :: re_min, re_max, delta_re
-      integer :: i 
-      
-      real, dimension(num_trial_res) :: trial_re, g, w0, predicted_Refl_nir
-      ! --------------------------
-    
-    if(any(phase == (/ phaseIsLiquid, phaseIsUndetermined, phaseIsIce /))) then 
-      if (phase == phaseIsLiquid .OR. phase == phaseIsUndetermined) then
-        re_min = re_water_min
-        re_max = re_water_max
-        trial_re(:) = trial_re_w
-        g(:)   = g_w(:) 
-        w0(:)  = w0_w(:)
-      else
-        re_min = re_ice_min
-        re_max = re_ice_max
-        trial_re(:) = trial_re_i
-        g(:)   = g_i(:) 
-        w0(:)  = w0_i(:)
-      end if
-      !
-      ! 1st attempt at index: w/coarse re resolution
-      !
-      predicted_Refl_nir(:) = two_stream_reflectance(tau, g(:), w0(:))
-      retrieve_re = interpolate_to_min(trial_re(:), predicted_Refl_nir(:), obs_Refl_nir) 
-      !
-      ! If first retrieval works, can try 2nd iteration using greater re resolution 
-      !
-! DJS2015: Remove unused piece of code      
-!      if(use_two_re_iterations .and. retrieve_re > 0.) then
-!        re_min = retrieve_re - delta_re
-!        re_max = retrieve_re + delta_re
-!        delta_re = (re_max - re_min)/real(num_trial_res-1)
-!  
-!        trial_re(:) = re_min + delta_re * (/ (i - 1, i = 1, num_trial_res) /) 
-!        g(:)  = get_g_nir(  phase, trial_re(:))
-!        w0(:) = get_ssa_nir(phase, trial_re(:))
-!        predicted_Refl_nir(:) = two_stream_reflectance(tau, g(:), w0(:))
-!        retrieve_re = interpolate_to_min(trial_re(:), predicted_Refl_nir(:), obs_Refl_nir) 
-!      end if
-! DJS2015 END
-    else 
-      retrieve_re = re_fill
-    end if 
-    
-  end function retrieve_re
-  ! --------------------------------------------
-  pure function interpolate_to_min(x, y, yobs)
-    real, dimension(:), intent(in) :: x, y 
-    real,               intent(in) :: yobs
-    real                           :: interpolate_to_min
-    ! 
-    ! Given a set of values of y as y(x), find the value of x that minimizes abs(y - yobs)
-    !   y must be monotonic in x
-    !
-    real, dimension(size(x)) :: diff
-    integer                  :: nPoints, minDiffLoc, lowerBound, upperBound
-    ! ---------------------------------
-    nPoints = size(y)
-    diff(:) = y(:) - yobs
-    minDiffLoc = minloc(abs(diff), dim = 1) 
-    
-    if(minDiffLoc == 1) then 
-      lowerBound = minDiffLoc
-      upperBound = minDiffLoc + 1
-    else if(minDiffLoc == nPoints) then
-      lowerBound = minDiffLoc - 1
-      upperBound = minDiffLoc
-    else
-      if(diff(minDiffLoc-1) * diff(minDiffLoc) < 0) then
-        lowerBound = minDiffLoc-1
-        upperBound = minDiffLoc
-      else 
-        lowerBound = minDiffLoc
-        upperBound = minDiffLoc + 1
-      end if 
-    end if 
-    
-    if(diff(lowerBound) * diff(upperBound) < 0) then     
-      !
-      ! Interpolate the root position linearly if we bracket the root
-      !
-      interpolate_to_min = x(upperBound) - & 
-                           diff(upperBound) * (x(upperBound) - x(lowerBound)) / (diff(upperBound) - diff(lowerBound))
-    else 
-      interpolate_to_min = re_fill
-    end if 
-    
-
-  end function interpolate_to_min
-  ! --------------------------------------------
-  ! Optical properties
-  ! --------------------------------------------
-  elemental function get_g_nir (phase, re)
-    !
-    ! Polynomial fit for asummetry parameter g in MODIS band 7 (near IR) as a function 
-    !   of size for ice and water
-    ! Fits from Steve Platnick
-    !
-
-    integer, intent(in) :: phase
-    real,    intent(in) :: re
-    real :: get_g_nir 
-
-    real, dimension(3), parameter :: ice_coefficients         = (/ 0.7490, 6.5153e-3, -5.4136e-5 /), &
-                                     small_water_coefficients = (/ 1.0364, -8.8800e-2, 7.0000e-3 /)
-    real, dimension(4), parameter :: big_water_coefficients   = (/ 0.6035, 2.8993e-2, -1.1051e-3, 1.5134e-5 /)
-
-    ! approx. fits from MODIS Collection 6 LUT scattering calculations for 3.7 µm channel size retrievals
-    if(phase == phaseIsLiquid) then 
-       if(re < 7.) then
-          get_g_nir = fit_to_quadratic(re, small_water_coefficients)
-          if(re < re_water_min) get_g_nir = fit_to_quadratic(re_water_min, small_water_coefficients)
-       else
-          get_g_nir = fit_to_cubic(re, big_water_coefficients)
-          if(re > re_water_max) get_g_nir = fit_to_cubic(re_water_max, big_water_coefficients)
-       end if
-    else
-       get_g_nir = fit_to_quadratic(re, ice_coefficients)
-      if(re < re_ice_min) get_g_nir = fit_to_quadratic(re_ice_min, ice_coefficients)
-      if(re > re_ice_max) get_g_nir = fit_to_quadratic(re_ice_max, ice_coefficients)
-    end if 
-    
-  end function get_g_nir
-
-  ! --------------------------------------------
-    elemental function get_ssa_nir (phase, re)
-        integer, intent(in) :: phase
-        real,    intent(in) :: re
-        real                :: get_ssa_nir
-        !
-        ! Polynomial fit for single scattering albedo in MODIS band 7 (near IR) as a function 
-        !   of size for ice and water
-        ! Fits from Steve Platnick
-        !
-        real, dimension(4), parameter :: ice_coefficients   = (/ 0.9625, -1.8069e-2, 3.3281e-4,-2.2865e-6/)
-        real, dimension(3), parameter :: water_coefficients = (/ 1.0044, -1.1397e-2, 1.3300e-4 /)
-        
-        ! approx. fits from MODIS Collection 6 LUT scattering calculations
-        if(phase == phaseIsLiquid) then
-          get_ssa_nir = fit_to_quadratic(re, water_coefficients)
-          if(re < re_water_min) get_ssa_nir = fit_to_quadratic(re_water_min, water_coefficients)
-          if(re > re_water_max) get_ssa_nir = fit_to_quadratic(re_water_max, water_coefficients)
-        else
-          get_ssa_nir = fit_to_cubic(re, ice_coefficients)
-          if(re < re_ice_min) get_ssa_nir = fit_to_cubic(re_ice_min, ice_coefficients)
-          if(re > re_ice_max) get_ssa_nir = fit_to_cubic(re_ice_max, ice_coefficients)
-        end if 
-
-    end function get_ssa_nir
-   ! --------------------------------------------
-  pure function fit_to_cubic(x, coefficients) 
-    real,               intent(in) :: x
-    real, dimension(:), intent(in) :: coefficients
-    real                           :: fit_to_cubic
-    
-    
-    fit_to_cubic = coefficients(1) + x * (coefficients(2) + x * (coefficients(3) + x * coefficients(4)))
- end function fit_to_cubic
-   ! --------------------------------------------
-  pure function fit_to_quadratic(x, coefficients) 
-    real,               intent(in) :: x
-    real, dimension(:), intent(in) :: coefficients
-    real                           :: fit_to_quadratic
-    
-    
-    fit_to_quadratic = coefficients(1) + x * (coefficients(2) + x * (coefficients(3)))
- end function fit_to_quadratic
-  ! --------------------------------------------
-  ! Radiative transfer
-  ! --------------------------------------------
-  pure function compute_toa_reflectace(tau, g, w0)
-    real, dimension(:), intent(in) :: tau, g, w0
-    real                           :: compute_toa_reflectace
-    
-    logical, dimension(size(tau))         :: cloudMask
-    integer, dimension(count(tau(:) > 0)) :: cloudIndicies
-    real,    dimension(count(tau(:) > 0)) :: Refl,     Trans
-    real                                  :: Refl_tot, Trans_tot
-    integer                               :: i
-    ! ---------------------------------------
-    !
-    ! This wrapper reports reflectance only and strips out non-cloudy elements from the calculation
-    !
-    cloudMask = tau(:) > 0. 
-    cloudIndicies = pack((/ (i, i = 1, size(tau)) /), mask = cloudMask) 
-    do i = 1, size(cloudIndicies)
-      call two_stream(tau(cloudIndicies(i)), g(cloudIndicies(i)), w0(cloudIndicies(i)), Refl(i), Trans(i))
-    end do 
-                    
-    call adding_doubling(Refl(:), Trans(:), Refl_tot, Trans_tot)  
-    
-    compute_toa_reflectace = Refl_tot
-    
-  end function compute_toa_reflectace
-  ! --------------------------------------------
-  pure subroutine two_stream(tauint, gint, w0int, ref, tra) 
-    real, intent(in)  :: tauint, gint, w0int
-    real, intent(out) :: ref, tra
-    !
-    ! Compute reflectance in a single layer using the two stream approximation 
-    !   The code itself is from Lazaros Oreopoulos via Steve Platnick 
-    !
-    ! ------------------------
-    ! Local variables 
-    !   for delta Eddington code
-    !   xmu, gamma3, and gamma4 only used for collimated beam approximation (i.e., beam=1)
-    integer, parameter :: beam = 2
-    real,    parameter :: xmu = 0.866, minConservativeW0 = 0.9999999
-    real :: tau, w0, g, f, gamma1, gamma2, gamma3, gamma4, &
-            rh, a1, a2, rk, r1, r2, r3, r4, r5, t1, t2, t3, t4, t5, beta, e1, e2, ef1, ef2, den, th
-    !
-    ! Compute reflectance and transmittance in a single layer using the two stream approximation 
-    !   The code itself is from Lazaros Oreopoulos via Steve Platnick 
-    !
-    f   = gint**2
-    tau = (1 - w0int * f) * tauint
-    w0  = (1 - f) * w0int / (1 - w0int * f)
-    g   = (gint - f) / (1 - f)
-
-    ! delta-Eddington (Joseph et al. 1976)
-    gamma1 =  (7 - w0* (4 + 3 * g)) / 4.0
-    gamma2 = -(1 - w0* (4 - 3 * g)) / 4.0
-    gamma3 =  (2 - 3*g*xmu) / 4.0
-    gamma4 =   1 - gamma3
-
-    if (w0int > minConservativeW0) then
-      ! Conservative scattering
-      if (beam == 1) then
-          rh = (gamma1*tau+(gamma3-gamma1*xmu)*(1-exp(-tau/xmu)))
-          ref = rh / (1 + gamma1 * tau)
-          tra = 1 - ref       
-      else if(beam == 2) then
-          ref = gamma1*tau/(1 + gamma1*tau)
-          tra = 1 - ref
-      endif
-    else
-      ! Non-conservative scattering
-      a1 = gamma1 * gamma4 + gamma2 * gamma3
-      a2 = gamma1 * gamma3 + gamma2 * gamma4
-
-      rk = sqrt(gamma1**2 - gamma2**2)
-      
-      r1 = (1 - rk * xmu) * (a2 + rk * gamma3)
-      r2 = (1 + rk * xmu) * (a2 - rk * gamma3)
-      r3 = 2 * rk *(gamma3 - a2 * xmu)
-      r4 = (1 - (rk * xmu)**2) * (rk + gamma1)
-      r5 = (1 - (rk * xmu)**2) * (rk - gamma1)
-      
-      t1 = (1 + rk * xmu) * (a1 + rk * gamma4)
-      t2 = (1 - rk * xmu) * (a1 - rk * gamma4)
-      t3 = 2 * rk * (gamma4 + a1 * xmu)
-      t4 = r4
-      t5 = r5
-
-      beta = -r5 / r4         
-      
-      e1 = min(rk * tau, 500.) 
-      e2 = min(tau / xmu, 500.) 
-      
-      if (beam == 1) then
-         den = r4 * exp(e1) + r5 * exp(-e1)
-         ref  = w0*(r1*exp(e1)-r2*exp(-e1)-r3*exp(-e2))/den
-         den = t4 * exp(e1) + t5 * exp(-e1)
-         th  = exp(-e2)
-         tra = th-th*w0*(t1*exp(e1)-t2*exp(-e1)-t3*exp(e2))/den
-      elseif (beam == 2) then
-         ef1 = exp(-e1)
-         ef2 = exp(-2*e1)
-         ref = (gamma2*(1-ef2))/((rk+gamma1)*(1-beta*ef2))
-         tra = (2*rk*ef1)/((rk+gamma1)*(1-beta*ef2))
-      endif
-    end if
-  end subroutine two_stream
-  ! --------------------------------------------------
-  elemental function two_stream_reflectance(tauint, gint, w0int) 
-    real, intent(in) :: tauint, gint, w0int
-    real             :: two_stream_reflectance
-    !
-    ! Compute reflectance in a single layer using the two stream approximation 
-    !   The code itself is from Lazaros Oreopoulos via Steve Platnick 
-    !
-    ! ------------------------
-    ! Local variables 
-    !   for delta Eddington code
-    !   xmu, gamma3, and gamma4 only used for collimated beam approximation (i.e., beam=1)
-    integer, parameter :: beam = 2
-    real,    parameter :: xmu = 0.866, minConservativeW0 = 0.9999999
-    real :: tau, w0, g, f, gamma1, gamma2, gamma3, gamma4, &
-            rh, a1, a2, rk, r1, r2, r3, r4, r5, t1, t2, t3, t4, t5, beta, e1, e2, ef1, ef2, den
-    ! ------------------------
-
-
-    f   = gint**2
-    tau = (1 - w0int * f) * tauint
-    w0  = (1 - f) * w0int / (1 - w0int * f)
-    g   = (gint - f) / (1 - f)
-
-    ! delta-Eddington (Joseph et al. 1976)
-    gamma1 =  (7 - w0* (4 + 3 * g)) / 4.0
-    gamma2 = -(1 - w0* (4 - 3 * g)) / 4.0
-    gamma3 =  (2 - 3*g*xmu) / 4.0
-    gamma4 =   1 - gamma3
-
-    if (w0int > minConservativeW0) then
-      ! Conservative scattering
-      if (beam == 1) then
-          rh = (gamma1*tau+(gamma3-gamma1*xmu)*(1-exp(-tau/xmu)))
-          two_stream_reflectance = rh / (1 + gamma1 * tau)
-      elseif (beam == 2) then
-          two_stream_reflectance = gamma1*tau/(1 + gamma1*tau)
-      endif
-        
-    else    !
-
-        ! Non-conservative scattering
-         a1 = gamma1 * gamma4 + gamma2 * gamma3
-         a2 = gamma1 * gamma3 + gamma2 * gamma4
-
-         rk = sqrt(gamma1**2 - gamma2**2)
-         
-         r1 = (1 - rk * xmu) * (a2 + rk * gamma3)
-         r2 = (1 + rk * xmu) * (a2 - rk * gamma3)
-         r3 = 2 * rk *(gamma3 - a2 * xmu)
-         r4 = (1 - (rk * xmu)**2) * (rk + gamma1)
-         r5 = (1 - (rk * xmu)**2) * (rk - gamma1)
-         
-         t1 = (1 + rk * xmu) * (a1 + rk * gamma4)
-         t2 = (1 - rk * xmu) * (a1 - rk * gamma4)
-         t3 = 2 * rk * (gamma4 + a1 * xmu)
-         t4 = r4
-         t5 = r5
-
-         beta = -r5 / r4         
-         
-         e1 = min(rk * tau, 500.) 
-         e2 = min(tau / xmu, 500.) 
-         
-         if (beam == 1) then
-           den = r4 * exp(e1) + r5 * exp(-e1)
-           two_stream_reflectance  = w0*(r1*exp(e1)-r2*exp(-e1)-r3*exp(-e2))/den
-         elseif (beam == 2) then
-           ef1 = exp(-e1)
-           ef2 = exp(-2*e1)
-           two_stream_reflectance = (gamma2*(1-ef2))/((rk+gamma1)*(1-beta*ef2))
-         endif
-           
-      end if
-  end function two_stream_reflectance 
-  ! --------------------------------------------
-    pure subroutine adding_doubling (Refl, Tran, Refl_tot, Tran_tot)      
-      real,    dimension(:), intent(in)  :: Refl,     Tran
-      real,                  intent(out) :: Refl_tot, Tran_tot
-      !
-      ! Use adding/doubling formulas to compute total reflectance and transmittance from layer values
-      !
-      
-      integer :: i
-      real, dimension(size(Refl)) :: Refl_cumulative, Tran_cumulative
-      
-      Refl_cumulative(1) = Refl(1); Tran_cumulative(1) = Tran(1)    
-      
-      do i=2, size(Refl)
-          ! place (add) previous combined layer(s) reflectance on top of layer i, w/black surface (or ignoring surface):
-          Refl_cumulative(i) = Refl_cumulative(i-1) + Refl(i)*(Tran_cumulative(i-1)**2)/(1 - Refl_cumulative(i-1) * Refl(i))
-          Tran_cumulative(i) = (Tran_cumulative(i-1)*Tran(i)) / (1 - Refl_cumulative(i-1) * Refl(i))
-      end do
-      
-      Refl_tot = Refl_cumulative(size(Refl))
-      Tran_tot = Tran_cumulative(size(Refl))
-
-    end subroutine adding_doubling
-  ! --------------------------------------------------
-  subroutine complain_and_die(message) 
-    character(len = *), intent(in) :: message
-    
-    write(6, *) "Failure in MODIS simulator" 
-    write(6, *)  trim(message) 
-    stop
-  end subroutine complain_and_die
-  !------------------------------------------------------------------------------------------------
-end module mod_modis_sim
Index: /LMDZ6/trunk/libf/phylmd/cosp/mod_modis_sim.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cosp/mod_modis_sim.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/cosp/mod_modis_sim.f90	(revision 5268)
@@ -0,0 +1,1309 @@
+! (c) 2009-2010, Regents of the Unversity of Colorado
+!   Author: Robert Pincus, Cooperative Institute for Research in the Environmental Sciences
+! All rights reserved.
+! $Revision: 88 $, $Date: 2013-11-13 07:08:38 -0700 (Wed, 13 Nov 2013) $
+! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/MODIS_simulator/modis_simulator.F90 $
+! 
+! Redistribution and use in source and binary forms, with or without modification, are permitted 
+! provided that the following conditions are met:
+! 
+!     * Redistributions of source code must retain the above copyright notice, this list 
+!       of conditions and the following disclaimer.
+!     * Redistributions in binary form must reproduce the above copyright notice, this list
+!       of conditions and the following disclaimer in the documentation and/or other materials 
+!       provided with the distribution.
+!     * Neither the name of the Met Office nor the names of its contributors may be used 
+!       to endorse or promote products derived from this software without specific prior written 
+!       permission.
+! 
+! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR 
+! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND 
+! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR 
+! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 
+! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 
+! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER 
+! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT 
+! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+!
+
+!
+! History:
+!   May 2009 - Robert Pincus - Initial version
+!   June 2009 - Steve Platnick and Robert Pincus - Simple radiative transfer for size retrievals
+!   August 2009 - Robert Pincus - Consistency and bug fixes suggested by Rick Hemler (GFDL) 
+!   November 2009 - Robert Pincus - Bux fixes and speed-ups after experience with Rick Hemler using AM2 (GFDL) 
+!   January 2010 - Robert Pincus - Added high, middle, low cloud fractions 
+!
+
+!
+! Notes on using the MODIS simulator: 
+!  *) You may provide either layer-by-layer values of optical thickness at 0.67 and 2.1 microns, or 
+!     optical thickness at 0.67 microns and ice- and liquid-water contents (in consistent units of 
+!     your choosing)
+!  *) Required input also includes the optical thickness and cloud top pressure 
+!     derived from the ISCCP simulator run with parameter top_height = 1. 
+!  *) Cloud particle sizes are specified as radii, measured in meters, though within the module we 
+!     use units of microns. Where particle sizes are outside the bounds used in the MODIS retrieval
+!     libraries (parameters re_water_min, re_ice_min, etc.) the simulator returns missing values (re_fill)
+
+!
+! When error conditions are encountered this code calls the function complain_and_die, supplied at the 
+!   bottom of this module. Users probably want to replace this with something more graceful. 
+!
+module mod_modis_sim
+  USE MOD_COSP_TYPES, only: R_UNDEF, ok_debug_cosp
+  implicit none
+  ! ------------------------------
+  ! Algorithmic parameters
+  !
+ 
+  real, parameter :: ice_density          = 0.93               ! liquid density is 1.  
+  !
+  ! Retrieval parameters
+  !
+  real, parameter :: min_OpticalThickness = 0.3,             & ! Minimum detectable optical thickness
+                     CO2Slicing_PressureLimit = 700. * 100., & ! Cloud with higher pressures use thermal methods, units Pa
+                     CO2Slicing_TauLimit = 1.,               & ! How deep into the cloud does CO2 slicing see? 
+                     phase_TauLimit      = 1.,               & ! How deep into the cloud does the phase detection see?
+                     size_TauLimit       = 2.,               & ! Depth of the re retreivals
+                     phaseDiscrimination_Threshold = 0.7       ! What fraction of total extincton needs to be 
+                                                               !  in a single category to make phase discrim. work? 
+  real,    parameter :: re_fill= -999.
+  integer, parameter :: phaseIsNone = 0, phaseIsLiquid = 1, phaseIsIce = 2, phaseIsUndetermined = 3
+  
+  logical, parameter :: useSimpleReScheme = .false. 
+  !
+  ! These are the limits of the libraries for the MODIS collection 5 algorithms 
+  !   They are also the limits used in the fits for g and w0
+  !
+  real,    parameter :: re_water_min= 4., re_water_max= 30., re_ice_min= 5., re_ice_max= 90.
+  integer, parameter :: num_trial_res = 15             ! increase to make the linear pseudo-retrieval of size more accurate
+! DJS2015: Remove unused parameter
+!  logical, parameter :: use_two_re_iterations = .false. ! do two retrieval iterations? 
+! DJS2015 END  
+  !
+  ! Precompute near-IR optical params vs size for retrieval scheme
+  !
+  integer, private :: i 
+  real, dimension(num_trial_res), parameter :: & 
+        trial_re_w = re_water_min + (re_water_max - re_water_min)/(num_trial_res-1) * (/ (i - 1, i = 1, num_trial_res) /), &
+        trial_re_i = re_ice_min   + (re_ice_max -   re_ice_min)  /(num_trial_res-1) * (/ (i - 1, i = 1, num_trial_res) /)
+  
+  ! Can't initialze these during compilation, but do in before looping columns in retrievals
+  real, dimension(num_trial_res) ::  g_w, g_i, w0_w, w0_i
+  ! ------------------------------
+  ! Bin boundaries for the joint optical thickness/cloud top pressure histogram
+  !
+  integer, parameter :: numTauHistogramBins = 6, numPressureHistogramBins = 7
+
+  real, private :: dummy_real 
+  real, dimension(numTauHistogramBins + 1),      parameter :: &
+    tauHistogramBoundaries = (/ min_OpticalThickness, 1.3, 3.6, 9.4, 23., 60., 10000. /) 
+  real, dimension(numPressureHistogramBins + 1), parameter :: & ! Units Pa 
+    pressureHistogramBoundaries = (/ 0., 18000., 31000., 44000., 56000., 68000., 80000., 1000000. /) 
+  real, parameter :: highCloudPressureLimit = 440. * 100., lowCloudPressureLimit = 680. * 100.
+  !
+  ! For output - nominal bin centers and  bin boundaries. On output pressure bins are highest to lowest. 
+  !
+  integer, private :: k, l
+  real, parameter, dimension(2, numTauHistogramBins) ::   &
+    nominalTauHistogramBoundaries =                       &
+        reshape(source = (/ tauHistogramBoundaries(1),    &
+                            ((tauHistogramBoundaries(k), l = 1, 2), k = 2, numTauHistogramBins), &
+                            100000. /),                    &
+                shape = (/2,  numTauHistogramBins /) )
+  real, parameter, dimension(numTauHistogramBins) ::                    &
+    nominalTauHistogramCenters = (nominalTauHistogramBoundaries(1, :) + &
+                                  nominalTauHistogramBoundaries(2, :) ) / 2.
+  
+  real, parameter, dimension(2, numPressureHistogramBins) :: &
+    nominalPressureHistogramBoundaries =                     &
+        reshape(source = (/ 100000.,                         &
+                            ((pressureHistogramBoundaries(k), l = 1, 2), k = numPressureHistogramBins, 2, -1), &
+                            0.  /), &
+                shape = (/2,  numPressureHistogramBins /) )
+  real, parameter, dimension(numPressureHistogramBins) ::                         &
+    nominalPressureHistogramCenters = (nominalPressureHistogramBoundaries(1, :) + &
+                                       nominalPressureHistogramBoundaries(2, :) ) / 2.
+  ! DJS2015 START: Add bin descriptions for joint-histograms of partice-sizes and optical depth. This is
+  !                identical to what is done in COSPv.2.0.0 for histogram bin initialization. 
+  integer :: j
+  integer,parameter :: &
+       numMODISReffLiqBins = 6, & ! Number of bins for tau/ReffLiq joint-histogram
+       numMODISReffIceBins = 6    ! Number of bins for tau/ReffICE joint-histogram
+  real,parameter,dimension(numMODISReffLiqBins+1) :: &
+       reffLIQ_binBounds = (/0., 8e-6, 1.0e-5, 1.3e-5, 1.5e-5, 2.0e-5, 3.0e-5/)
+  real,parameter,dimension(numMODISReffIceBins+1) :: &
+       reffICE_binBounds = (/0., 1.0e-5, 2.0e-5, 3.0e-5, 4.0e-5, 6.0e-5, 9.0e-5/)
+  real,parameter,dimension(2,numMODISReffIceBins) :: &
+       reffICE_binEdges = reshape(source=(/reffICE_binBounds(1),((reffICE_binBounds(k),  &
+                                  l=1,2),k=2,numMODISReffIceBins),reffICE_binBounds(numMODISReffIceBins+1)/),  &
+                                  shape = (/2,numMODISReffIceBins/)) 
+  real,parameter,dimension(2,numMODISReffLiqBins) :: &
+       reffLIQ_binEdges = reshape(source=(/reffLIQ_binBounds(1),((reffLIQ_binBounds(k),  &
+                                  l=1,2),k=2,numMODISReffLiqBins),reffLIQ_binBounds(numMODISReffIceBins+1)/),  &
+                                  shape = (/2,numMODISReffLiqBins/))             
+  real,parameter,dimension(numMODISReffIceBins) :: &
+       reffICE_binCenters = (reffICE_binEdges(1,:)+reffICE_binEdges(2,:))/2.
+  real,parameter,dimension(numMODISReffLiqBins) :: &
+       reffLIQ_binCenters = (reffLIQ_binEdges(1,:)+reffLIQ_binEdges(2,:))/2.
+  ! DJS2015 END
+
+  ! ------------------------------
+  ! There are two ways to call the MODIS simulator: 
+  !  1) Provide total optical thickness and liquid/ice water content and we'll partition tau in 
+  !     subroutine modis_L2_simulator_oneTau, or 
+  !  2) Provide ice and liquid optical depths in each layer
+  !
+  interface modis_L2_simulator
+    module procedure modis_L2_simulator_oneTau, modis_L2_simulator_twoTaus
+  end interface 
+contains
+  !------------------------------------------------------------------------------------------------
+  ! MODIS simulator using specified liquid and ice optical thickness in each layer 
+  !
+  !   Note: this simulator operates on all points; to match MODIS itself night-time 
+  !     points should be excluded
+  !
+  !   Note: the simulator requires as input the optical thickness and cloud top pressure 
+  !     derived from the ISCCP simulator run with parameter top_height = 1. 
+  !     If cloud top pressure is higher than about 700 mb, MODIS can't use CO2 slicing 
+  !     and reverts to a thermal algorithm much like ISCCP's. Rather than replicate that 
+  !     alogrithm in this simulator we simply report the values from the ISCCP simulator. 
+  !
+  subroutine modis_L2_simulator_twoTaus(                                       &
+                                temp, pressureLayers, pressureLevels,          &
+                                liquid_opticalThickness, ice_opticalThickness, &
+                                waterSize, iceSize,                            & 
+                                isccpTau, isccpCloudTopPressure,               &
+                                retrievedPhase, retrievedCloudTopPressure, retrievedTau, retrievedSize)
+
+    ! Grid-mean quantities at layer centers, starting at the model top
+    !   dimension nLayers
+    real, dimension(:),    intent(in ) :: temp,           & ! Temperature, K
+                                          pressureLayers, & ! Pressure, Pa
+                                          pressureLevels    ! Pressure at layer edges, Pa (dimension nLayers + 1) 
+    ! Sub-column quantities
+    !   dimension  nSubcols, nLayers
+    real, dimension(:, :), intent(in ) :: liquid_opticalThickness, & ! Layer optical thickness @ 0.67 microns due to liquid
+                                          ice_opticalThickness       ! ditto, due to ice
+    real, dimension(:, :), intent(in ) :: waterSize,        & ! Cloud drop effective radius, microns
+                                          iceSize             ! Cloud ice effective radius, microns
+                                          
+    ! Cloud properties retrieved from ISCCP using top_height = 1
+    !    dimension nSubcols
+    real, dimension(:),    intent(in ) :: isccpTau, &           ! Column-integrated optical thickness 
+                                          isccpCloudTopPressure ! ISCCP-retrieved cloud top pressure (Pa) 
+
+    ! Properties retrieved by MODIS
+    !   dimension nSubcols
+    integer, dimension(:), intent(out) :: retrievedPhase               ! liquid/ice/other - integer, defined in module header
+    real,    dimension(:), intent(out) :: retrievedCloudTopPressure, & ! units of pressureLayers
+                                          retrievedTau,              & ! unitless
+                                          retrievedSize                ! microns 
+    ! ---------------------------------------------------
+    ! Local variables
+    logical, dimension(size(retrievedTau))                     :: cloudMask
+    real,    dimension(size(waterSize, 1), size(waterSize, 2)) :: tauLiquidFraction, tauTotal
+    real    :: integratedLiquidFraction
+    integer :: i, nSubcols, nLevels
+
+    ! ---------------------------------------------------
+    nSubcols = size(liquid_opticalThickness, 1)
+    nLevels  = size(liquid_opticalThickness, 2) 
+ 
+    !
+    ! Initial error checks 
+    !   
+    if(any((/ size(ice_opticalThickness, 1), size(waterSize, 1), size(iceSize, 1), &
+              size(isccpTau), size(isccpCloudTopPressure),              &
+              size(retrievedPhase), size(retrievedCloudTopPressure),    &
+              size(retrievedTau), size(retrievedSize) /) /= nSubcols )) &
+       call complain_and_die("Differing number of subcolumns in one or more arrays") 
+    
+    if(any((/ size(ice_opticalThickness, 2), size(waterSize, 2), size(iceSize, 2),      &
+              size(temp), size(pressureLayers), size(pressureLevels)-1 /) /= nLevels )) &
+       call complain_and_die("Differing number of levels in one or more arrays") 
+       
+       
+    if(any( (/ any(temp <= 0.), any(pressureLayers <= 0.),  &
+               any(liquid_opticalThickness < 0.),           &
+               any(ice_opticalThickness < 0.),              &
+               any(waterSize < 0.), any(iceSize < 0.) /) )) &
+       call complain_and_die("Input values out of bounds") 
+             
+    ! ---------------------------------------------------
+    !
+    ! Compute the total optical thickness and the proportion due to liquid in each cell
+    !
+    where(liquid_opticalThickness(:, :) + ice_opticalThickness(:, :) > 0.) 
+      tauLiquidFraction(:, :) = liquid_opticalThickness(:, :)/(liquid_opticalThickness(:, :) + ice_opticalThickness(:, :))
+    elsewhere
+      tauLiquidFraction(:, :) = 0. 
+    end  where 
+    tauTotal(:, :) = liquid_opticalThickness(:, :) + ice_opticalThickness(:, :) 
+    
+    !
+    ! Optical depth retrieval 
+    !   This is simply a sum over the optical thickness in each layer 
+    !   It should agree with the ISCCP values after min values have been excluded 
+    !
+    retrievedTau(:) = sum(tauTotal(:, :), dim = 2)
+
+    !
+    ! Cloud detection - does optical thickness exceed detection threshold? 
+    !
+    cloudMask = retrievedTau(:) >= min_OpticalThickness
+    
+    !
+    ! Initialize initial estimates for size retrievals
+    !
+    if(any(cloudMask) .and. .not. useSimpleReScheme) then 
+      g_w(:)  = get_g_nir(  phaseIsLiquid, trial_re_w(:))
+      w0_w(:) = get_ssa_nir(phaseIsLiquid, trial_re_w(:))
+      g_i(:)  = get_g_nir(  phaseIsIce,    trial_re_i(:))
+      w0_i(:) = get_ssa_nir(phaseIsIce,    trial_re_i(:))
+    end if 
+    
+    do i = 1, nSubCols
+      if(cloudMask(i)) then 
+        !
+        ! Cloud top pressure determination 
+        !   MODIS uses CO2 slicing for clouds with tops above about 700 mb and thermal methods for clouds
+        !   lower than that. 
+        !  For CO2 slicing we report the optical-depth weighted pressure, integrating to a specified 
+        !    optical depth
+        ! This assumes linear variation in p between levels. Linear in ln(p) is probably better, 
+        !   though we'd need to deal with the lowest pressure gracefully. 
+        !
+        retrievedCloudTopPressure(i) = cloud_top_pressure((/ 0., tauTotal(i, :) /), &
+                                                          pressureLevels,           &
+                                                          CO2Slicing_TauLimit)  
+        
+        
+        !
+        ! Phase determination - determine fraction of total tau that's liquid 
+        ! When ice and water contribute about equally to the extinction we can't tell 
+        !   what the phase is 
+        !
+        integratedLiquidFraction = weight_by_extinction(tauTotal(i, :),          &
+                                                        tauLiquidFraction(i, :), &
+                                                        phase_TauLimit)
+        if(integratedLiquidFraction >= phaseDiscrimination_Threshold) then 
+          retrievedPhase(i) = phaseIsLiquid
+        else if (integratedLiquidFraction <= 1.- phaseDiscrimination_Threshold) then 
+          retrievedPhase(i) = phaseIsIce
+        else 
+          retrievedPhase(i) = phaseIsUndetermined
+        end if 
+        
+        !
+        ! Size determination 
+        !
+        if(useSimpleReScheme) then 
+          !   This is the extinction-weighted size considering only the phase we've chosen 
+          !
+          if(retrievedPhase(i) == phaseIsIce) then 
+            retrievedSize(i) = weight_by_extinction(ice_opticalThickness(i, :),  &
+                                                    iceSize(i, :), &
+                                                    (1. - integratedLiquidFraction) * size_TauLimit)
+  
+          else if(retrievedPhase(i) == phaseIsLiquid) then 
+            retrievedSize(i) = weight_by_extinction(liquid_opticalThickness(i, :), &
+                                                    waterSize(i, :), &
+                                                    integratedLiquidFraction * size_TauLimit)
+  
+          else
+            retrievedSize(i) = 0. 
+          end if 
+        else
+          retrievedSize(i) = 1.0e-06*retrieve_re(retrievedPhase(i), retrievedTau(i), &
+                         obs_Refl_nir = compute_nir_reflectance(liquid_opticalThickness(i, :), waterSize(i, :)*1.0e6, & 
+                         ice_opticalThickness(i, :),      iceSize(i, :)*1.0e6))
+        end if 
+      else 
+        !
+        ! Values when we don't think there's a cloud. 
+        !
+        retrievedCloudTopPressure(i) = R_UNDEF 
+        retrievedPhase(i) = phaseIsNone
+        retrievedSize(i) = R_UNDEF 
+        retrievedTau(i) = R_UNDEF 
+      end if
+    end do
+    where((retrievedSize(:) < 0.).and.(retrievedSize(:) /= R_UNDEF)) retrievedSize(:) = 1.0e-06*re_fill
+
+    ! We use the ISCCP-derived CTP for low clouds, since the ISCCP simulator ICARUS 
+    !   mimics what MODIS does to first order. 
+    !   Of course, ISCCP cloud top pressures are in mb. 
+    !   
+    where(cloudMask(:) .and. retrievedCloudTopPressure(:) > CO2Slicing_PressureLimit) &
+      retrievedCloudTopPressure(:) = isccpCloudTopPressure * 100. 
+    
+  end subroutine modis_L2_simulator_twoTaus
+  !------------------------------------------------------------------------------------------------
+  !
+  ! MODIS simulator: provide a single optical thickness and the cloud ice and liquid contents; 
+  !   we'll partition this into ice and liquid optical thickness and call the full MODIS simulator 
+  ! 
+  subroutine modis_L2_simulator_oneTau(                                         &
+                                temp, pressureLayers, pressureLevels,           &
+                                opticalThickness, cloudWater, cloudIce,         &
+                                waterSize, iceSize,                             & 
+                                isccpTau, isccpCloudTopPressure,                &
+                                retrievedPhase, retrievedCloudTopPressure, retrievedTau, retrievedSize)
+    ! Grid-mean quantities at layer centers, 
+    !   dimension nLayers
+    real, dimension(:),    intent(in ) :: temp,           & ! Temperature, K
+                                          pressureLayers, & ! Pressure, Pa
+                                          pressureLevels    ! Pressure at layer edges, Pa (dimension nLayers + 1) 
+    ! Sub-column quantities
+    !   dimension nLayers, nSubcols
+    real, dimension(:, :), intent(in ) :: opticalThickness, & ! Layer optical thickness @ 0.67 microns
+                                          cloudWater,       & ! Cloud water content, arbitrary units
+                                          cloudIce            ! Cloud water content, same units as cloudWater
+    real, dimension(:, :), intent(in ) :: waterSize,        & ! Cloud drop effective radius, microns
+                                          iceSize             ! Cloud ice effective radius, microns
+
+    ! Cloud properties retrieved from ISCCP using top_height = 1
+    !    dimension nSubcols
+    
+    real, dimension(:),    intent(in ) :: isccpTau, &           ! Column-integrated optical thickness 
+                                          isccpCloudTopPressure ! ISCCP-retrieved cloud top pressure (Pa) 
+
+    ! Properties retrieved by MODIS
+    !   dimension nSubcols
+    integer, dimension(:), intent(out) :: retrievedPhase               ! liquid/ice/other - integer
+    real,    dimension(:), intent(out) :: retrievedCloudTopPressure, & ! units of pressureLayers
+                                          retrievedTau,              & ! unitless
+                                          retrievedSize                ! microns (or whatever units 
+                                                                       !   waterSize and iceSize are supplied in)
+    ! ---------------------------------------------------
+    ! Local variables
+    real, dimension(size(opticalThickness, 1), size(opticalThickness, 2)) :: & 
+           liquid_opticalThickness, ice_opticalThickness, tauLiquidFraction
+    
+    real :: seuil
+    ! ---------------------------------------------------
+    
+    if (ok_debug_cosp) then
+       seuil=1.e-9
+    else
+       seuil=0.0
+    endif
+
+    where(cloudIce(:, :) <= 0.) 
+      tauLiquidFraction(:, :) = 1. 
+    elsewhere
+      where (cloudWater(:, :) <= 0.) 
+        tauLiquidFraction(:, :) = 0. 
+      elsewhere 
+        ! 
+        ! Geometic optics limit - tau as LWP/re  (proportional to LWC/re) 
+        !
+! Modif AI 02 2018 
+        tauLiquidFraction(:, :) = (cloudWater(:, :)/max(waterSize(:, :), seuil) ) / &
+                                  (cloudWater(:, :)/max(waterSize(:, :), seuil) + & 
+                                   cloudIce(:, :)/(ice_density * max(iceSize(:, :), seuil)) ) 
+      end where
+    end where
+    liquid_opticalThickness(:, :) = tauLiquidFraction(:, :) * opticalThickness(:, :) 
+    ice_opticalThickness   (:, :) = opticalThickness(:, :) - liquid_opticalThickness(:, :)
+    
+    call modis_L2_simulator_twoTaus(temp, pressureLayers, pressureLevels,          &
+                                    liquid_opticalThickness, ice_opticalThickness, &
+                                    waterSize, iceSize,                            & 
+                                    isccpTau, isccpCloudTopPressure,               &
+                                    retrievedPhase, retrievedCloudTopPressure, retrievedTau, retrievedSize)
+                                
+  end subroutine modis_L2_simulator_oneTau
+
+  ! ########################################################################################
+  subroutine modis_column(nPoints,nSubCols,phase, cloud_top_pressure, optical_thickness, particle_size,      &
+       Cloud_Fraction_Total_Mean,         Cloud_Fraction_Water_Mean,         Cloud_Fraction_Ice_Mean,        &
+       Cloud_Fraction_High_Mean,          Cloud_Fraction_Mid_Mean,           Cloud_Fraction_Low_Mean,        &
+       Optical_Thickness_Total_Mean,      Optical_Thickness_Water_Mean,      Optical_Thickness_Ice_Mean,     &
+       Optical_Thickness_Total_MeanLog10, Optical_Thickness_Water_MeanLog10, Optical_Thickness_Ice_MeanLog10,&
+       Cloud_Particle_Size_Water_Mean,    Cloud_Particle_Size_Ice_Mean,      Cloud_Top_Pressure_Total_Mean,  &
+       Liquid_Water_Path_Mean,            Ice_Water_Path_Mean,                                               &    
+       Optical_Thickness_vs_Cloud_Top_Pressure,Optical_Thickness_vs_ReffIce,Optical_Thickness_vs_ReffLiq)
+    
+    ! INPUTS
+    integer,intent(in) :: &
+         nPoints,                           & ! Number of horizontal gridpoints
+         nSubCols                             ! Number of subcolumns
+    integer,intent(in), dimension(:,:) ::  &
+!ds    integer,intent(in), dimension(nPoints, nSubCols) ::  &
+         phase                             
+    real,intent(in),dimension(:,:) ::  &
+!ds    real,intent(in),dimension(nPoints, nSubCols) ::  &
+         cloud_top_pressure,                &
+         optical_thickness,                 &
+         particle_size
+ 
+    ! OUTPUTS 
+    real,intent(inout),dimension(:)  ::   & !
+!ds    real,intent(inout),dimension(nPoints)  ::   & !
+         Cloud_Fraction_Total_Mean,         & !
+         Cloud_Fraction_Water_Mean,         & !
+         Cloud_Fraction_Ice_Mean,           & !
+         Cloud_Fraction_High_Mean,          & !
+         Cloud_Fraction_Mid_Mean,           & !
+         Cloud_Fraction_Low_Mean,           & !
+         Optical_Thickness_Total_Mean,      & !
+         Optical_Thickness_Water_Mean,      & !
+         Optical_Thickness_Ice_Mean,        & !
+         Optical_Thickness_Total_MeanLog10, & !
+         Optical_Thickness_Water_MeanLog10, & !
+         Optical_Thickness_Ice_MeanLog10,   & !
+         Cloud_Particle_Size_Water_Mean,    & !
+         Cloud_Particle_Size_Ice_Mean,      & !
+         Cloud_Top_Pressure_Total_Mean,     & !
+         Liquid_Water_Path_Mean,            & !
+         Ice_Water_Path_Mean                  !
+    real,intent(inout),dimension(:,:,:) :: &
+!ds    real,intent(inout),dimension(nPoints,numTauHistogramBins,numPressureHistogramBins) :: &
+         Optical_Thickness_vs_Cloud_Top_Pressure
+    real,intent(inout),dimension(:,:,:) :: &    
+!ds    real,intent(inout),dimension(nPoints,numTauHistogramBins,numMODISReffIceBins) :: &    
+         Optical_Thickness_vs_ReffIce
+    real,intent(inout),dimension(:,:,:) :: &    
+!ds    real,intent(inout),dimension(nPoints,numTauHistogramBins,numMODISReffLiqBins) :: &    
+         Optical_Thickness_vs_ReffLiq         
+
+    ! LOCAL VARIABLES
+    real, parameter :: &
+         LWP_conversion = 2./3. * 1000. ! MKS units  
+    integer :: i, j
+    logical, dimension(nPoints,nSubCols) :: &
+         cloudMask,      &
+         waterCloudMask, &
+         iceCloudMask,   &
+         validRetrievalMask
+    real,dimension(nPoints,nSubCols) :: &
+         tauWRK,ctpWRK,reffIceWRK,reffLiqWRK
+    
+    ! ########################################################################################
+    ! Include only those pixels with successful retrievals in the statistics 
+    ! ########################################################################################
+    validRetrievalMask(1:nPoints,1:nSubCols) = particle_size(1:nPoints,1:nSubCols) > 0.
+    cloudMask(1:nPoints,1:nSubCols) = phase(1:nPoints,1:nSubCols) /= phaseIsNone .and.       &
+         validRetrievalMask(1:nPoints,1:nSubCols)
+    waterCloudMask(1:nPoints,1:nSubCols) = phase(1:nPoints,1:nSubCols) == phaseIsLiquid .and. &
+         validRetrievalMask(1:nPoints,1:nSubCols)
+    iceCloudMask(1:nPoints,1:nSubCols)   = phase(1:nPoints,1:nSubCols) == phaseIsIce .and.    &
+         validRetrievalMask(1:nPoints,1:nSubCols)
+
+    ! ########################################################################################
+    ! Use these as pixel counts at first 
+    ! ########################################################################################
+    Cloud_Fraction_Total_Mean(1:nPoints) = real(count(cloudMask,      dim = 2))
+    Cloud_Fraction_Water_Mean(1:nPoints) = real(count(waterCloudMask, dim = 2))
+    Cloud_Fraction_Ice_Mean(1:nPoints)   = real(count(iceCloudMask,   dim = 2))
+    Cloud_Fraction_High_Mean(1:nPoints)  = real(count(cloudMask .and. cloud_top_pressure <=          &
+                                           highCloudPressureLimit, dim = 2)) 
+    Cloud_Fraction_Low_Mean(1:nPoints)   = real(count(cloudMask .and. cloud_top_pressure >           &
+                                           lowCloudPressureLimit,  dim = 2)) 
+    Cloud_Fraction_Mid_Mean(1:nPoints)   = Cloud_Fraction_Total_Mean(1:nPoints) - Cloud_Fraction_High_Mean(1:nPoints)&
+                                           - Cloud_Fraction_Low_Mean(1:nPoints)
+
+    ! ########################################################################################
+    ! Compute mean optical thickness.
+    ! ########################################################################################
+    where (Cloud_Fraction_Total_Mean == 0)
+       Optical_Thickness_Total_Mean      = R_UNDEF
+    elsewhere
+       Optical_Thickness_Total_Mean(1:nPoints) = sum(optical_thickness, mask = cloudMask,      dim = 2) / &
+                                                 Cloud_Fraction_Total_Mean(1:nPoints) 
+    endwhere
+    where (Cloud_Fraction_Water_Mean == 0)
+       Optical_Thickness_Water_Mean      = R_UNDEF
+    elsewhere
+       Optical_Thickness_Water_Mean(1:nPoints) = sum(optical_thickness, mask = waterCloudMask, dim = 2) / &
+                                                 Cloud_Fraction_Water_Mean(1:nPoints)
+    endwhere
+    where (Cloud_Fraction_Ice_Mean == 0)
+       Optical_Thickness_Ice_Mean        = R_UNDEF
+    elsewhere
+       Optical_Thickness_Ice_Mean(1:nPoints)   = sum(optical_thickness, mask = iceCloudMask,   dim = 2) / &
+                                                 Cloud_Fraction_Ice_Mean(1:nPoints)
+    endwhere
+   
+    ! ########################################################################################
+    ! We take the absolute value of optical thickness here to satisfy compilers that complains 
+    ! when we evaluate the logarithm of a negative number, even though it's not included in 
+    ! the sum. 
+    ! ########################################################################################
+    where (Cloud_Fraction_Total_Mean == 0)
+       Optical_Thickness_Total_MeanLog10 = R_UNDEF
+    elsewhere
+       Optical_Thickness_Total_MeanLog10(1:nPoints) = sum(log10(abs(optical_thickness)), mask = cloudMask, &
+           dim = 2) / Cloud_Fraction_Total_Mean(1:nPoints)
+    endwhere
+    where (Cloud_Fraction_Water_Mean == 0)
+       Optical_Thickness_Water_MeanLog10 = R_UNDEF
+    elsewhere
+       Optical_Thickness_Water_MeanLog10(1:nPoints) = sum(log10(abs(optical_thickness)), mask = waterCloudMask,&
+            dim = 2) / Cloud_Fraction_Water_Mean(1:nPoints)
+    endwhere
+    where (Cloud_Fraction_Ice_Mean == 0)
+       Optical_Thickness_Ice_MeanLog10   = R_UNDEF
+    elsewhere 
+       Optical_Thickness_Ice_MeanLog10(1:nPoints) = sum(log10(abs(optical_thickness)), mask = iceCloudMask,&
+            dim = 2) / Cloud_Fraction_Ice_Mean(1:nPoints)
+    endwhere
+    where (Cloud_Fraction_Water_Mean == 0)
+       Cloud_Particle_Size_Water_Mean    = R_UNDEF
+    elsewhere
+       Cloud_Particle_Size_Water_Mean(1:nPoints) = sum(particle_size, mask = waterCloudMask, dim = 2) / &
+            Cloud_Fraction_Water_Mean(1:nPoints)
+    endwhere
+    where (Cloud_Fraction_Ice_Mean == 0)
+       Cloud_Particle_Size_Ice_Mean      = R_UNDEF  
+    elsewhere
+       Cloud_Particle_Size_Ice_Mean(1:nPoints) = sum(particle_size, mask = iceCloudMask,   dim = 2) / &
+            Cloud_Fraction_Ice_Mean(1:nPoints)
+    endwhere
+    where (Cloud_Fraction_Total_Mean == 0)
+       Cloud_Top_Pressure_Total_Mean     = R_UNDEF
+    elsewhere
+       Cloud_Top_Pressure_Total_Mean(1:nPoints) = sum(cloud_top_pressure, mask = cloudMask, dim = 2) / &
+            max(1, count(cloudMask, dim = 2))
+    endwhere
+    where (Cloud_Fraction_Water_Mean == 0)
+       Liquid_Water_Path_Mean            = R_UNDEF
+    elsewhere
+       Liquid_Water_Path_Mean(1:nPoints) = LWP_conversion*sum(particle_size*optical_thickness, &
+            mask=waterCloudMask,dim=2)/Cloud_Fraction_Water_Mean(1:nPoints)
+    endwhere
+    where (Cloud_Fraction_Ice_Mean == 0)
+       Ice_Water_Path_Mean               = R_UNDEF
+    elsewhere
+       Ice_Water_Path_Mean(1:nPoints) = LWP_conversion * ice_density*sum(particle_size*optical_thickness,&
+             mask=iceCloudMask,dim = 2) /Cloud_Fraction_Ice_Mean(1:nPoints)
+    endwhere
+    ! ########################################################################################
+    ! Normalize pixel counts to fraction.
+    ! ########################################################################################
+    Cloud_Fraction_High_Mean(1:nPoints)  = Cloud_Fraction_High_Mean(1:nPoints)  /nSubcols
+    Cloud_Fraction_Mid_Mean(1:nPoints)   = Cloud_Fraction_Mid_Mean(1:nPoints)   /nSubcols
+    Cloud_Fraction_Low_Mean(1:nPoints)   = Cloud_Fraction_Low_Mean(1:nPoints)   /nSubcols
+    Cloud_Fraction_Total_Mean(1:nPoints) = Cloud_Fraction_Total_Mean(1:nPoints) /nSubcols
+    Cloud_Fraction_Ice_Mean(1:nPoints)   = Cloud_Fraction_Ice_Mean(1:nPoints)   /nSubcols
+    Cloud_Fraction_Water_Mean(1:nPoints) = Cloud_Fraction_Water_Mean(1:nPoints) /nSubcols
+    
+    ! ########################################################################################
+    ! Set clear-scenes to undefined
+    ! ########################################################################################
+!    where (Cloud_Fraction_High_Mean == 0)  Cloud_Fraction_High_Mean = R_UNDEF
+!    where (Cloud_Fraction_Mid_Mean == 0)   Cloud_Fraction_Mid_Mean = R_UNDEF
+!    where (Cloud_Fraction_Low_Mean == 0)   Cloud_Fraction_Low_Mean = R_UNDEF
+
+    ! ########################################################################################
+    ! Joint histogram  
+    ! ########################################################################################
+
+    ! Loop over all points
+    tauWRK(1:nPoints,1:nSubCols)     = optical_thickness(1:nPoints,1:nSubCols)
+    ctpWRK(1:nPoints,1:nSubCols)     = cloud_top_pressure(1:nPoints,1:nSubCols)
+    reffIceWRK(1:nPoints,1:nSubCols) = merge(particle_size,R_UNDEF,iceCloudMask)
+    reffLiqWRK(1:nPoints,1:nSubCols) = merge(particle_size,R_UNDEF,waterCloudMask)
+    do j=1,nPoints
+
+       ! Fill clear and optically thin subcolumns with fill
+       where(.not. cloudMask(j,1:nSubCols)) 
+          tauWRK(j,1:nSubCols) = -999.
+          ctpWRK(j,1:nSubCols) = -999.
+       endwhere
+       ! Joint histogram of tau/CTP
+       call hist2D(tauWRK(j,1:nSubCols),ctpWRK(j,1:nSubCols),nSubCols,&
+                   tauHistogramBoundaries,numTauHistogramBins,&
+                   pressureHistogramBoundaries,numPressureHistogramBins,&
+                   Optical_Thickness_vs_Cloud_Top_Pressure(j,1:numTauHistogramBins,1:numPressureHistogramBins))
+       ! Joint histogram of tau/ReffICE
+       call hist2D(tauWRK(j,1:nSubCols),reffIceWrk(j,1:nSubCols),nSubCols,               &
+                   tauHistogramBoundaries,numTauHistogramBins,reffICE_binBounds,         &
+                   numMODISReffIceBins, Optical_Thickness_vs_ReffIce(j,1:numTauHistogramBins,1:numMODISReffIceBins))
+       ! Joint histogram of tau/ReffLIQ
+       call hist2D(tauWRK(j,1:nSubCols),reffLiqWrk(j,1:nSubCols),nSubCols,               &
+                   tauHistogramBoundaries,numTauHistogramBins,reffLIQ_binBounds,         &
+                   numMODISReffLiqBins, Optical_Thickness_vs_ReffLiq(j,1:numTauHistogramBins,1:numMODISReffLiqBins))                   
+
+    enddo   
+    Optical_Thickness_vs_Cloud_Top_Pressure(1:nPoints,1:numTauHistogramBins,1:numPressureHistogramBins) = &
+         Optical_Thickness_vs_Cloud_Top_Pressure(1:nPoints,1:numTauHistogramBins,1:numPressureHistogramBins)/nSubCols
+    Optical_Thickness_vs_ReffIce(1:nPoints,1:numTauHistogramBins,1:numMODISReffIceBins) = &
+         Optical_Thickness_vs_ReffIce(1:nPoints,1:numTauHistogramBins,1:numMODISReffIceBins)/nSubCols
+    Optical_Thickness_vs_ReffLiq(1:nPoints,1:numTauHistogramBins,1:numMODISReffLiqBins) = &
+         Optical_Thickness_vs_ReffLiq(1:nPoints,1:numTauHistogramBins,1:numMODISReffLiqBins)/nSubCols 
+
+  end subroutine modis_column
+  ! ######################################################################################
+  ! SUBROUTINE hist2D
+  ! ######################################################################################
+  subroutine hist2D(var1,var2,npts,bin1,nbin1,bin2,nbin2,jointHist)
+    implicit none
+    
+    ! INPUTS
+    integer, intent(in) :: &
+         npts,  & ! Number of data points to be sorted
+         nbin1, & ! Number of bins in histogram direction 1 
+         nbin2    ! Number of bins in histogram direction 2
+    real,intent(in),dimension(npts) :: &
+         var1,  & ! Variable 1 to be sorted into bins
+         var2     ! variable 2 to be sorted into bins
+    real,intent(in),dimension(nbin1+1) :: &
+         bin1     ! Histogram bin 1 boundaries
+    real,intent(in),dimension(nbin2+1) :: &
+         bin2     ! Histogram bin 2 boundaries
+    ! OUTPUTS
+    real,intent(out),dimension(nbin1,nbin2) :: &
+         jointHist
+    
+    ! LOCAL VARIABLES
+    integer :: ij,ik
+    
+    do ij=2,nbin1+1
+       do ik=2,nbin2+1
+          jointHist(ij-1,ik-1)=count(var1 .ge. bin1(ij-1) .and. var1 .lt. bin1(ij) .and. &
+               var2 .ge. bin2(ik-1) .and. var2 .lt. bin2(ik))        
+       enddo
+    enddo
+  end subroutine hist2D
+  
+  !------------------------------------------------------------------------------------------------
+  subroutine modis_L3_simulator(phase, cloud_top_pressure, optical_thickness, particle_size,            &
+       Cloud_Fraction_Total_Mean,       Cloud_Fraction_Water_Mean,       Cloud_Fraction_Ice_Mean,       &
+       Cloud_Fraction_High_Mean,        Cloud_Fraction_Mid_Mean,         Cloud_Fraction_Low_Mean,       &
+       Optical_Thickness_Total_Mean,    Optical_Thickness_Water_Mean,    Optical_Thickness_Ice_Mean,    &
+       Optical_Thickness_Total_MeanLog10, Optical_Thickness_Water_MeanLog10, Optical_Thickness_Ice_MeanLog10, &
+                                        Cloud_Particle_Size_Water_Mean,  Cloud_Particle_Size_Ice_Mean,  &
+       Cloud_Top_Pressure_Total_Mean,                                                                   &
+                                        Liquid_Water_Path_Mean,          Ice_Water_Path_Mean,           &    
+       Optical_Thickness_vs_Cloud_Top_Pressure)
+    !
+    ! Inputs; dimension nPoints, nSubcols
+    !
+    integer, dimension(:, :),   intent(in)  :: phase
+    real,    dimension(:, :),   intent(in)  :: cloud_top_pressure, optical_thickness, particle_size
+    !
+    ! Outputs; dimension nPoints
+    !
+    real,    dimension(:),      intent(out) :: &
+       Cloud_Fraction_Total_Mean,       Cloud_Fraction_Water_Mean,       Cloud_Fraction_Ice_Mean,       &
+       Cloud_Fraction_High_Mean,        Cloud_Fraction_Mid_Mean,         Cloud_Fraction_Low_Mean,       &
+       Optical_Thickness_Total_Mean,    Optical_Thickness_Water_Mean,    Optical_Thickness_Ice_Mean,    &
+       Optical_Thickness_Total_MeanLog10, Optical_Thickness_Water_MeanLog10, Optical_Thickness_Ice_MeanLog10, &
+                                        Cloud_Particle_Size_Water_Mean,  Cloud_Particle_Size_Ice_Mean,  &
+       Cloud_Top_Pressure_Total_Mean,                                                                   &
+                                        Liquid_Water_Path_Mean,          Ice_Water_Path_Mean
+    ! tau/ctp histogram; dimensions nPoints, numTauHistogramBins , numPressureHistogramBins 
+    real,    dimension(:, :, :), intent(out) :: Optical_Thickness_vs_Cloud_Top_Pressure
+    ! ---------------------------
+    ! Local variables
+    !
+    real, parameter :: LWP_conversion = 2./3. * 1000. ! MKS units  
+    integer :: i, j
+    integer :: nPoints, nSubcols 
+    logical, dimension(size(phase, 1), size(phase, 2)) :: &
+      cloudMask, waterCloudMask, iceCloudMask, validRetrievalMask
+    logical, dimension(size(phase, 1), size(phase, 2), numTauHistogramBins     ) :: tauMask
+    logical, dimension(size(phase, 1), size(phase, 2), numPressureHistogramBins) :: pressureMask
+    ! ---------------------------
+    
+    nPoints  = size(phase, 1) 
+    nSubcols = size(phase, 2) 
+    !
+    ! Array conformance checks
+    !
+    if(any( (/ size(cloud_top_pressure, 1), size(optical_thickness, 1), size(particle_size, 1),                                &
+               size(Cloud_Fraction_Total_Mean),       size(Cloud_Fraction_Water_Mean),       size(Cloud_Fraction_Ice_Mean),    &
+               size(Cloud_Fraction_High_Mean),        size(Cloud_Fraction_Mid_Mean),         size(Cloud_Fraction_Low_Mean),    &
+               size(Optical_Thickness_Total_Mean),    size(Optical_Thickness_Water_Mean),    size(Optical_Thickness_Ice_Mean), &
+               size(Optical_Thickness_Total_MeanLog10), size(Optical_Thickness_Water_MeanLog10), &
+               size(Optical_Thickness_Ice_MeanLog10),   size(Cloud_Particle_Size_Water_Mean),    &
+               size(Cloud_Particle_Size_Ice_Mean),      size(Cloud_Top_Pressure_Total_Mean),     &
+               size(Liquid_Water_Path_Mean),          size(Ice_Water_Path_Mean) /) /= nPoints))  &
+      call complain_and_die("Some L3 arrays have wrong number of grid points") 
+    if(any( (/ size(cloud_top_pressure, 2), size(optical_thickness, 2), size(particle_size, 2) /)  /= nSubcols)) &
+      call complain_and_die("Some L3 arrays have wrong number of subcolumns") 
+    
+    
+    !
+    ! Include only those pixels with successful retrievals in the statistics 
+    !
+    validRetrievalMask(:, :) = particle_size(:, :) > 0.
+    cloudMask      = phase(:, :) /= phaseIsNone   .and. validRetrievalMask(:, :)
+    waterCloudMask = phase(:, :) == phaseIsLiquid .and. validRetrievalMask(:, :)
+    iceCloudMask   = phase(:, :) == phaseIsIce    .and. validRetrievalMask(:, :)
+    !
+    ! Use these as pixel counts at first 
+    !
+    Cloud_Fraction_Total_Mean(:) = real(count(cloudMask,      dim = 2))
+    Cloud_Fraction_Water_Mean(:) = real(count(waterCloudMask, dim = 2))
+    Cloud_Fraction_Ice_Mean(:)   = real(count(iceCloudMask,   dim = 2))
+    
+    Cloud_Fraction_High_Mean(:) = real(count(cloudMask .and. cloud_top_pressure <= highCloudPressureLimit, dim = 2)) 
+    Cloud_Fraction_Low_Mean(:)  = real(count(cloudMask .and. cloud_top_pressure >  lowCloudPressureLimit,  dim = 2)) 
+    Cloud_Fraction_Mid_Mean(:)  = Cloud_Fraction_Total_Mean(:) - Cloud_Fraction_High_Mean(:) - Cloud_Fraction_Low_Mean(:)
+    
+    !
+    ! Don't want to divide by 0, even though the sums will be 0 where the pixel counts are 0. 
+    !
+    where (Cloud_Fraction_Total_Mean == 0) Cloud_Fraction_Total_Mean = -1. 
+    where (Cloud_Fraction_Water_Mean == 0) Cloud_Fraction_Water_Mean = -1.
+    where (Cloud_Fraction_Ice_Mean   == 0) Cloud_Fraction_Ice_Mean   = -1.
+    
+    Optical_Thickness_Total_Mean = sum(optical_thickness, mask = cloudMask,      dim = 2) / Cloud_Fraction_Total_Mean(:) 
+    Optical_Thickness_Water_Mean = sum(optical_thickness, mask = waterCloudMask, dim = 2) / Cloud_Fraction_Water_Mean(:)
+    Optical_Thickness_Ice_Mean   = sum(optical_thickness, mask = iceCloudMask,   dim = 2) / Cloud_Fraction_Ice_Mean(:)
+   
+    ! We take the absolute value of optical thickness here to satisfy compilers that complains when we 
+    !   evaluate the logarithm of a negative number, even though it's not included in the sum. 
+    Optical_Thickness_Total_MeanLog10 = sum(log10(abs(optical_thickness)), mask = cloudMask,      dim = 2) / &
+                                        Cloud_Fraction_Total_Mean(:)
+    Optical_Thickness_Water_MeanLog10 = sum(log10(abs(optical_thickness)), mask = waterCloudMask, dim = 2) / &
+                                        Cloud_Fraction_Water_Mean(:)
+    Optical_Thickness_Ice_MeanLog10   = sum(log10(abs(optical_thickness)), mask = iceCloudMask,   dim = 2) / &
+                                        Cloud_Fraction_Ice_Mean(:)
+   
+    Cloud_Particle_Size_Water_Mean = sum(particle_size, mask = waterCloudMask, dim = 2) / Cloud_Fraction_Water_Mean(:)
+    Cloud_Particle_Size_Ice_Mean   = sum(particle_size, mask = iceCloudMask,   dim = 2) / Cloud_Fraction_Ice_Mean(:)
+    
+    Cloud_Top_Pressure_Total_Mean = sum(cloud_top_pressure, mask = cloudMask, dim = 2) / max(1, count(cloudMask, dim = 2))
+    
+    Liquid_Water_Path_Mean = LWP_conversion &
+                             * sum(particle_size * optical_thickness, mask = waterCloudMask, dim = 2) &
+                             / Cloud_Fraction_Water_Mean(:)
+    Ice_Water_Path_Mean    = LWP_conversion * ice_density &
+                             * sum(particle_size * optical_thickness, mask = iceCloudMask,   dim = 2) &
+                             / Cloud_Fraction_Ice_Mean(:)
+
+    !
+    ! Normalize pixel counts to fraction
+    !   The first three cloud fractions have been set to -1 in cloud-free areas, so set those places to 0.
+    ! 
+    Cloud_Fraction_Total_Mean(:) = max(0., Cloud_Fraction_Total_Mean(:)/nSubcols)
+    Cloud_Fraction_Water_Mean(:) = max(0., Cloud_Fraction_Water_Mean(:)/nSubcols)
+    Cloud_Fraction_Ice_Mean(:)   = max(0., Cloud_Fraction_Ice_Mean(:)  /nSubcols)
+    
+    Cloud_Fraction_High_Mean(:)  = Cloud_Fraction_High_Mean(:) /nSubcols
+    Cloud_Fraction_Mid_Mean(:)   = Cloud_Fraction_Mid_Mean(:)  /nSubcols
+    Cloud_Fraction_Low_Mean(:)   = Cloud_Fraction_Low_Mean(:)  /nSubcols
+    
+    ! ----
+    ! Joint histogram 
+    ! 
+    do i = 1, numTauHistogramBins 
+      where(cloudMask(:, :)) 
+        tauMask(:, :, i) = optical_thickness(:, :) >= tauHistogramBoundaries(i) .and. &
+                           optical_thickness(:, :) <  tauHistogramBoundaries(i+1)
+      elsewhere
+        tauMask(:, :, i) = .false.
+      end where
+    end do 
+
+    do i = 1, numPressureHistogramBins 
+      where(cloudMask(:, :)) 
+        pressureMask(:, :, i) = cloud_top_pressure(:, :) >= pressureHistogramBoundaries(i) .and. &
+                                cloud_top_pressure(:, :) <  pressureHistogramBoundaries(i+1)
+      elsewhere
+        pressureMask(:, :, i) = .false.
+      end where
+    end do 
+    
+    do i = 1, numPressureHistogramBins
+      do j = 1, numTauHistogramBins
+        Optical_Thickness_vs_Cloud_Top_Pressure(:, j, i) = & 
+          real(count(tauMask(:, :, j) .and. pressureMask(:, :, i), dim = 2)) / real(nSubcols)
+      end do 
+    end do 
+    
+  end subroutine modis_L3_simulator
+  !------------------------------------------------------------------------------------------------
+  function cloud_top_pressure(tauIncrement, pressure, tauLimit) 
+    real, dimension(:), intent(in) :: tauIncrement, pressure
+    real,               intent(in) :: tauLimit
+    real                           :: cloud_top_pressure
+    !
+    ! Find the extinction-weighted pressure. Assume that pressure varies linearly between 
+    !   layers and use the trapezoidal rule.
+    !
+    
+    real :: deltaX, totalTau, totalProduct
+    integer :: i 
+    
+    totalTau = 0.; totalProduct = 0. 
+    do i = 2, size(tauIncrement)
+      if(totalTau + tauIncrement(i) > tauLimit) then 
+        deltaX = tauLimit - totalTau
+        totalTau = totalTau + deltaX
+        !
+        ! Result for trapezoidal rule when you take less than a full step
+        !   tauIncrement is a layer-integrated value
+        !
+        totalProduct = totalProduct           &
+                     + pressure(i-1) * deltaX &
+                     + (pressure(i) - pressure(i-1)) * deltaX**2/(2. * tauIncrement(i)) 
+      else
+        totalTau =     totalTau     + tauIncrement(i) 
+        totalProduct = totalProduct + tauIncrement(i) * (pressure(i) + pressure(i-1)) / 2.
+      end if 
+      if(totalTau >= tauLimit) exit
+    end do 
+    cloud_top_pressure = totalProduct/totalTau
+  end function cloud_top_pressure
+  !------------------------------------------------------------------------------------------------
+  function weight_by_extinction(tauIncrement, f, tauLimit) 
+    real, dimension(:), intent(in) :: tauIncrement, f
+    real,               intent(in) :: tauLimit
+    real                           :: weight_by_extinction
+    !
+    ! Find the extinction-weighted value of f(tau), assuming constant f within each layer
+    !
+    
+    real    :: deltaX, totalTau, totalProduct
+    integer :: i 
+    
+    totalTau = 0.; totalProduct = 0. 
+    do i = 1, size(tauIncrement)
+      if(totalTau + tauIncrement(i) > tauLimit) then 
+        deltaX       = tauLimit - totalTau
+        totalTau     = totalTau     + deltaX
+        totalProduct = totalProduct + deltaX * f(i) 
+      else
+        totalTau     = totalTau     + tauIncrement(i) 
+        totalProduct = totalProduct + tauIncrement(i) * f(i) 
+      end if 
+      if(totalTau >= tauLimit) exit
+    end do 
+    weight_by_extinction = totalProduct/totalTau
+  end function weight_by_extinction
+  !------------------------------------------------------------------------------------------------
+  pure function compute_nir_reflectance(water_tau, water_size, ice_tau, ice_size) 
+    real, dimension(:), intent(in) :: water_tau, water_size, ice_tau, ice_size
+    real                           :: compute_nir_reflectance
+    
+    real, dimension(size(water_tau)) :: water_g, water_w0, ice_g, ice_w0, &
+                                        tau, g, w0
+    !----------------------------------------
+    water_g(:)  = get_g_nir(  phaseIsLiquid, water_size) 
+    water_w0(:) = get_ssa_nir(phaseIsLiquid, water_size) 
+    ice_g(:)    = get_g_nir(  phaseIsIce,    ice_size) 
+    ice_w0(:)   = get_ssa_nir(phaseIsIce,    ice_size) 
+    !
+    ! Combine ice and water optical properties
+    !
+    g(:) = 0; w0(:) = 0. 
+    tau(:) = ice_tau(:) + water_tau(:) 
+    where (tau(:) > 0) 
+      w0(:) = (water_tau(:) * water_w0(:)  + ice_tau(:) * ice_w0(:)) / &
+              tau(:)
+      g(:) = (water_tau(:) * water_g(:) * water_w0(:)  + ice_tau(:) * ice_g(:) * ice_w0(:)) / &
+             (w0(:) * tau(:))
+    end where
+    
+    compute_nir_reflectance = compute_toa_reflectace(tau, g, w0)
+  end function compute_nir_reflectance
+  !------------------------------------------------------------------------------------------------
+  ! Retreivals
+  !------------------------------------------------------------------------------------------------
+  elemental function retrieve_re (phase, tau, obs_Refl_nir)
+      integer, intent(in) :: phase
+      real,    intent(in) :: tau, obs_Refl_nir
+      real                :: retrieve_re
+      !
+      ! Finds the re that produces the minimum mis-match between predicted and observed reflectance in 
+      !   MODIS band 7 (near IR)
+      ! Uses 
+      !  fits for asymmetry parameter g(re) and single scattering albedo w0(re) based on MODIS tables 
+      !  two-stream for layer reflectance and transmittance as a function of optical thickness tau, g, and w0
+      !  adding-doubling for total reflectance 
+      !  
+      !
+      !
+      ! Local variables
+      !
+      real, parameter :: min_distance_to_boundary = 0.01
+      real    :: re_min, re_max, delta_re
+      integer :: i 
+      
+      real, dimension(num_trial_res) :: trial_re, g, w0, predicted_Refl_nir
+      ! --------------------------
+    
+    if(any(phase == (/ phaseIsLiquid, phaseIsUndetermined, phaseIsIce /))) then 
+      if (phase == phaseIsLiquid .OR. phase == phaseIsUndetermined) then
+        re_min = re_water_min
+        re_max = re_water_max
+        trial_re(:) = trial_re_w
+        g(:)   = g_w(:) 
+        w0(:)  = w0_w(:)
+      else
+        re_min = re_ice_min
+        re_max = re_ice_max
+        trial_re(:) = trial_re_i
+        g(:)   = g_i(:) 
+        w0(:)  = w0_i(:)
+      end if
+      !
+      ! 1st attempt at index: w/coarse re resolution
+      !
+      predicted_Refl_nir(:) = two_stream_reflectance(tau, g(:), w0(:))
+      retrieve_re = interpolate_to_min(trial_re(:), predicted_Refl_nir(:), obs_Refl_nir) 
+      !
+      ! If first retrieval works, can try 2nd iteration using greater re resolution 
+      !
+! DJS2015: Remove unused piece of code      
+!      if(use_two_re_iterations .and. retrieve_re > 0.) then
+!        re_min = retrieve_re - delta_re
+!        re_max = retrieve_re + delta_re
+!        delta_re = (re_max - re_min)/real(num_trial_res-1)
+!  
+!        trial_re(:) = re_min + delta_re * (/ (i - 1, i = 1, num_trial_res) /) 
+!        g(:)  = get_g_nir(  phase, trial_re(:))
+!        w0(:) = get_ssa_nir(phase, trial_re(:))
+!        predicted_Refl_nir(:) = two_stream_reflectance(tau, g(:), w0(:))
+!        retrieve_re = interpolate_to_min(trial_re(:), predicted_Refl_nir(:), obs_Refl_nir) 
+!      end if
+! DJS2015 END
+    else 
+      retrieve_re = re_fill
+    end if 
+    
+  end function retrieve_re
+  ! --------------------------------------------
+  pure function interpolate_to_min(x, y, yobs)
+    real, dimension(:), intent(in) :: x, y 
+    real,               intent(in) :: yobs
+    real                           :: interpolate_to_min
+    ! 
+    ! Given a set of values of y as y(x), find the value of x that minimizes abs(y - yobs)
+    !   y must be monotonic in x
+    !
+    real, dimension(size(x)) :: diff
+    integer                  :: nPoints, minDiffLoc, lowerBound, upperBound
+    ! ---------------------------------
+    nPoints = size(y)
+    diff(:) = y(:) - yobs
+    minDiffLoc = minloc(abs(diff), dim = 1) 
+    
+    if(minDiffLoc == 1) then 
+      lowerBound = minDiffLoc
+      upperBound = minDiffLoc + 1
+    else if(minDiffLoc == nPoints) then
+      lowerBound = minDiffLoc - 1
+      upperBound = minDiffLoc
+    else
+      if(diff(minDiffLoc-1) * diff(minDiffLoc) < 0) then
+        lowerBound = minDiffLoc-1
+        upperBound = minDiffLoc
+      else 
+        lowerBound = minDiffLoc
+        upperBound = minDiffLoc + 1
+      end if 
+    end if 
+    
+    if(diff(lowerBound) * diff(upperBound) < 0) then     
+      !
+      ! Interpolate the root position linearly if we bracket the root
+      !
+      interpolate_to_min = x(upperBound) - & 
+                           diff(upperBound) * (x(upperBound) - x(lowerBound)) / (diff(upperBound) - diff(lowerBound))
+    else 
+      interpolate_to_min = re_fill
+    end if 
+    
+
+  end function interpolate_to_min
+  ! --------------------------------------------
+  ! Optical properties
+  ! --------------------------------------------
+  elemental function get_g_nir (phase, re)
+    !
+    ! Polynomial fit for asummetry parameter g in MODIS band 7 (near IR) as a function 
+    !   of size for ice and water
+    ! Fits from Steve Platnick
+    !
+
+    integer, intent(in) :: phase
+    real,    intent(in) :: re
+    real :: get_g_nir 
+
+    real, dimension(3), parameter :: ice_coefficients         = (/ 0.7490, 6.5153e-3, -5.4136e-5 /), &
+                                     small_water_coefficients = (/ 1.0364, -8.8800e-2, 7.0000e-3 /)
+    real, dimension(4), parameter :: big_water_coefficients   = (/ 0.6035, 2.8993e-2, -1.1051e-3, 1.5134e-5 /)
+
+    ! approx. fits from MODIS Collection 6 LUT scattering calculations for 3.7 µm channel size retrievals
+    if(phase == phaseIsLiquid) then 
+       if(re < 7.) then
+          get_g_nir = fit_to_quadratic(re, small_water_coefficients)
+          if(re < re_water_min) get_g_nir = fit_to_quadratic(re_water_min, small_water_coefficients)
+       else
+          get_g_nir = fit_to_cubic(re, big_water_coefficients)
+          if(re > re_water_max) get_g_nir = fit_to_cubic(re_water_max, big_water_coefficients)
+       end if
+    else
+       get_g_nir = fit_to_quadratic(re, ice_coefficients)
+      if(re < re_ice_min) get_g_nir = fit_to_quadratic(re_ice_min, ice_coefficients)
+      if(re > re_ice_max) get_g_nir = fit_to_quadratic(re_ice_max, ice_coefficients)
+    end if 
+    
+  end function get_g_nir
+
+  ! --------------------------------------------
+    elemental function get_ssa_nir (phase, re)
+        integer, intent(in) :: phase
+        real,    intent(in) :: re
+        real                :: get_ssa_nir
+        !
+        ! Polynomial fit for single scattering albedo in MODIS band 7 (near IR) as a function 
+        !   of size for ice and water
+        ! Fits from Steve Platnick
+        !
+        real, dimension(4), parameter :: ice_coefficients   = (/ 0.9625, -1.8069e-2, 3.3281e-4,-2.2865e-6/)
+        real, dimension(3), parameter :: water_coefficients = (/ 1.0044, -1.1397e-2, 1.3300e-4 /)
+        
+        ! approx. fits from MODIS Collection 6 LUT scattering calculations
+        if(phase == phaseIsLiquid) then
+          get_ssa_nir = fit_to_quadratic(re, water_coefficients)
+          if(re < re_water_min) get_ssa_nir = fit_to_quadratic(re_water_min, water_coefficients)
+          if(re > re_water_max) get_ssa_nir = fit_to_quadratic(re_water_max, water_coefficients)
+        else
+          get_ssa_nir = fit_to_cubic(re, ice_coefficients)
+          if(re < re_ice_min) get_ssa_nir = fit_to_cubic(re_ice_min, ice_coefficients)
+          if(re > re_ice_max) get_ssa_nir = fit_to_cubic(re_ice_max, ice_coefficients)
+        end if 
+
+    end function get_ssa_nir
+   ! --------------------------------------------
+  pure function fit_to_cubic(x, coefficients) 
+    real,               intent(in) :: x
+    real, dimension(:), intent(in) :: coefficients
+    real                           :: fit_to_cubic
+    
+    
+    fit_to_cubic = coefficients(1) + x * (coefficients(2) + x * (coefficients(3) + x * coefficients(4)))
+ end function fit_to_cubic
+   ! --------------------------------------------
+  pure function fit_to_quadratic(x, coefficients) 
+    real,               intent(in) :: x
+    real, dimension(:), intent(in) :: coefficients
+    real                           :: fit_to_quadratic
+    
+    
+    fit_to_quadratic = coefficients(1) + x * (coefficients(2) + x * (coefficients(3)))
+ end function fit_to_quadratic
+  ! --------------------------------------------
+  ! Radiative transfer
+  ! --------------------------------------------
+  pure function compute_toa_reflectace(tau, g, w0)
+    real, dimension(:), intent(in) :: tau, g, w0
+    real                           :: compute_toa_reflectace
+    
+    logical, dimension(size(tau))         :: cloudMask
+    integer, dimension(count(tau(:) > 0)) :: cloudIndicies
+    real,    dimension(count(tau(:) > 0)) :: Refl,     Trans
+    real                                  :: Refl_tot, Trans_tot
+    integer                               :: i
+    ! ---------------------------------------
+    !
+    ! This wrapper reports reflectance only and strips out non-cloudy elements from the calculation
+    !
+    cloudMask = tau(:) > 0. 
+    cloudIndicies = pack((/ (i, i = 1, size(tau)) /), mask = cloudMask) 
+    do i = 1, size(cloudIndicies)
+      call two_stream(tau(cloudIndicies(i)), g(cloudIndicies(i)), w0(cloudIndicies(i)), Refl(i), Trans(i))
+    end do 
+                    
+    call adding_doubling(Refl(:), Trans(:), Refl_tot, Trans_tot)  
+    
+    compute_toa_reflectace = Refl_tot
+    
+  end function compute_toa_reflectace
+  ! --------------------------------------------
+  pure subroutine two_stream(tauint, gint, w0int, ref, tra) 
+    real, intent(in)  :: tauint, gint, w0int
+    real, intent(out) :: ref, tra
+    !
+    ! Compute reflectance in a single layer using the two stream approximation 
+    !   The code itself is from Lazaros Oreopoulos via Steve Platnick 
+    !
+    ! ------------------------
+    ! Local variables 
+    !   for delta Eddington code
+    !   xmu, gamma3, and gamma4 only used for collimated beam approximation (i.e., beam=1)
+    integer, parameter :: beam = 2
+    real,    parameter :: xmu = 0.866, minConservativeW0 = 0.9999999
+    real :: tau, w0, g, f, gamma1, gamma2, gamma3, gamma4, &
+            rh, a1, a2, rk, r1, r2, r3, r4, r5, t1, t2, t3, t4, t5, beta, e1, e2, ef1, ef2, den, th
+    !
+    ! Compute reflectance and transmittance in a single layer using the two stream approximation 
+    !   The code itself is from Lazaros Oreopoulos via Steve Platnick 
+    !
+    f   = gint**2
+    tau = (1 - w0int * f) * tauint
+    w0  = (1 - f) * w0int / (1 - w0int * f)
+    g   = (gint - f) / (1 - f)
+
+    ! delta-Eddington (Joseph et al. 1976)
+    gamma1 =  (7 - w0* (4 + 3 * g)) / 4.0
+    gamma2 = -(1 - w0* (4 - 3 * g)) / 4.0
+    gamma3 =  (2 - 3*g*xmu) / 4.0
+    gamma4 =   1 - gamma3
+
+    if (w0int > minConservativeW0) then
+      ! Conservative scattering
+      if (beam == 1) then
+          rh = (gamma1*tau+(gamma3-gamma1*xmu)*(1-exp(-tau/xmu)))
+          ref = rh / (1 + gamma1 * tau)
+          tra = 1 - ref       
+      else if(beam == 2) then
+          ref = gamma1*tau/(1 + gamma1*tau)
+          tra = 1 - ref
+      endif
+    else
+      ! Non-conservative scattering
+      a1 = gamma1 * gamma4 + gamma2 * gamma3
+      a2 = gamma1 * gamma3 + gamma2 * gamma4
+
+      rk = sqrt(gamma1**2 - gamma2**2)
+      
+      r1 = (1 - rk * xmu) * (a2 + rk * gamma3)
+      r2 = (1 + rk * xmu) * (a2 - rk * gamma3)
+      r3 = 2 * rk *(gamma3 - a2 * xmu)
+      r4 = (1 - (rk * xmu)**2) * (rk + gamma1)
+      r5 = (1 - (rk * xmu)**2) * (rk - gamma1)
+      
+      t1 = (1 + rk * xmu) * (a1 + rk * gamma4)
+      t2 = (1 - rk * xmu) * (a1 - rk * gamma4)
+      t3 = 2 * rk * (gamma4 + a1 * xmu)
+      t4 = r4
+      t5 = r5
+
+      beta = -r5 / r4         
+      
+      e1 = min(rk * tau, 500.) 
+      e2 = min(tau / xmu, 500.) 
+      
+      if (beam == 1) then
+         den = r4 * exp(e1) + r5 * exp(-e1)
+         ref  = w0*(r1*exp(e1)-r2*exp(-e1)-r3*exp(-e2))/den
+         den = t4 * exp(e1) + t5 * exp(-e1)
+         th  = exp(-e2)
+         tra = th-th*w0*(t1*exp(e1)-t2*exp(-e1)-t3*exp(e2))/den
+      elseif (beam == 2) then
+         ef1 = exp(-e1)
+         ef2 = exp(-2*e1)
+         ref = (gamma2*(1-ef2))/((rk+gamma1)*(1-beta*ef2))
+         tra = (2*rk*ef1)/((rk+gamma1)*(1-beta*ef2))
+      endif
+    end if
+  end subroutine two_stream
+  ! --------------------------------------------------
+  elemental function two_stream_reflectance(tauint, gint, w0int) 
+    real, intent(in) :: tauint, gint, w0int
+    real             :: two_stream_reflectance
+    !
+    ! Compute reflectance in a single layer using the two stream approximation 
+    !   The code itself is from Lazaros Oreopoulos via Steve Platnick 
+    !
+    ! ------------------------
+    ! Local variables 
+    !   for delta Eddington code
+    !   xmu, gamma3, and gamma4 only used for collimated beam approximation (i.e., beam=1)
+    integer, parameter :: beam = 2
+    real,    parameter :: xmu = 0.866, minConservativeW0 = 0.9999999
+    real :: tau, w0, g, f, gamma1, gamma2, gamma3, gamma4, &
+            rh, a1, a2, rk, r1, r2, r3, r4, r5, t1, t2, t3, t4, t5, beta, e1, e2, ef1, ef2, den
+    ! ------------------------
+
+
+    f   = gint**2
+    tau = (1 - w0int * f) * tauint
+    w0  = (1 - f) * w0int / (1 - w0int * f)
+    g   = (gint - f) / (1 - f)
+
+    ! delta-Eddington (Joseph et al. 1976)
+    gamma1 =  (7 - w0* (4 + 3 * g)) / 4.0
+    gamma2 = -(1 - w0* (4 - 3 * g)) / 4.0
+    gamma3 =  (2 - 3*g*xmu) / 4.0
+    gamma4 =   1 - gamma3
+
+    if (w0int > minConservativeW0) then
+      ! Conservative scattering
+      if (beam == 1) then
+          rh = (gamma1*tau+(gamma3-gamma1*xmu)*(1-exp(-tau/xmu)))
+          two_stream_reflectance = rh / (1 + gamma1 * tau)
+      elseif (beam == 2) then
+          two_stream_reflectance = gamma1*tau/(1 + gamma1*tau)
+      endif
+        
+    else    !
+
+        ! Non-conservative scattering
+         a1 = gamma1 * gamma4 + gamma2 * gamma3
+         a2 = gamma1 * gamma3 + gamma2 * gamma4
+
+         rk = sqrt(gamma1**2 - gamma2**2)
+         
+         r1 = (1 - rk * xmu) * (a2 + rk * gamma3)
+         r2 = (1 + rk * xmu) * (a2 - rk * gamma3)
+         r3 = 2 * rk *(gamma3 - a2 * xmu)
+         r4 = (1 - (rk * xmu)**2) * (rk + gamma1)
+         r5 = (1 - (rk * xmu)**2) * (rk - gamma1)
+         
+         t1 = (1 + rk * xmu) * (a1 + rk * gamma4)
+         t2 = (1 - rk * xmu) * (a1 - rk * gamma4)
+         t3 = 2 * rk * (gamma4 + a1 * xmu)
+         t4 = r4
+         t5 = r5
+
+         beta = -r5 / r4         
+         
+         e1 = min(rk * tau, 500.) 
+         e2 = min(tau / xmu, 500.) 
+         
+         if (beam == 1) then
+           den = r4 * exp(e1) + r5 * exp(-e1)
+           two_stream_reflectance  = w0*(r1*exp(e1)-r2*exp(-e1)-r3*exp(-e2))/den
+         elseif (beam == 2) then
+           ef1 = exp(-e1)
+           ef2 = exp(-2*e1)
+           two_stream_reflectance = (gamma2*(1-ef2))/((rk+gamma1)*(1-beta*ef2))
+         endif
+           
+      end if
+  end function two_stream_reflectance 
+  ! --------------------------------------------
+    pure subroutine adding_doubling (Refl, Tran, Refl_tot, Tran_tot)      
+      real,    dimension(:), intent(in)  :: Refl,     Tran
+      real,                  intent(out) :: Refl_tot, Tran_tot
+      !
+      ! Use adding/doubling formulas to compute total reflectance and transmittance from layer values
+      !
+      
+      integer :: i
+      real, dimension(size(Refl)) :: Refl_cumulative, Tran_cumulative
+      
+      Refl_cumulative(1) = Refl(1); Tran_cumulative(1) = Tran(1)    
+      
+      do i=2, size(Refl)
+          ! place (add) previous combined layer(s) reflectance on top of layer i, w/black surface (or ignoring surface):
+          Refl_cumulative(i) = Refl_cumulative(i-1) + Refl(i)*(Tran_cumulative(i-1)**2)/(1 - Refl_cumulative(i-1) * Refl(i))
+          Tran_cumulative(i) = (Tran_cumulative(i-1)*Tran(i)) / (1 - Refl_cumulative(i-1) * Refl(i))
+      end do
+      
+      Refl_tot = Refl_cumulative(size(Refl))
+      Tran_tot = Tran_cumulative(size(Refl))
+
+    end subroutine adding_doubling
+  ! --------------------------------------------------
+  subroutine complain_and_die(message) 
+    character(len = *), intent(in) :: message
+    
+    write(6, *) "Failure in MODIS simulator" 
+    write(6, *)  trim(message) 
+    stop
+  end subroutine complain_and_die
+  !------------------------------------------------------------------------------------------------
+end module mod_modis_sim
Index: DZ6/trunk/libf/phylmd/cosp/optics_lib.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cosp/optics_lib.F90	(revision 5267)
+++ 	(revision )
@@ -1,751 +1,0 @@
-! $Revision: 88 $, $Date: 2013-11-13 15:08:38 +0100 (mer. 13 nov. 2013) $
-! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/quickbeam/optics_lib.f90 $
-! OPTICS_LIB: Optical proecures for for F90
-! Compiled/Modified:
-!   07/01/06  John Haynes (haynes@atmos.colostate.edu)
-!
-! m_wat (subroutine)
-! m_ice (subroutine)
-! mie_int (subroutine)
-  
-  module optics_lib
-  implicit none
-
-  contains
-
-! ----------------------------------------------------------------------------
-! subroutine M_WAT
-! ----------------------------------------------------------------------------
-  subroutine m_wat(freq, tk, n_r, n_i)
-  implicit none
-!  
-! Purpose:
-!   compute complex index of refraction of liquid water
-!
-! Inputs:
-!   [freq]    frequency (GHz)
-!   [tk]       temperature (K)
-!
-! Outputs:
-!   [n_r]     real part index of refraction
-!   [n_i]     imaginary part index of refraction
-!
-! Reference:
-!   Based on the work of Ray (1972)
-!
-! Coded:
-!   03/22/05  John Haynes (haynes@atmos.colostate.edu)
-  
-! ----- INPUTS -----
-  real*8, intent(in) :: freq,tk
-  
-! ----- OUTPUTS -----
-  real*8, intent(out) :: n_r, n_i
-
-! ----- INTERNAL -----    
-  real*8 ld,es,ei,a,ls,sg,tm1,cos1,sin1
-  real*8 e_r,e_i
-  real*8 pi
-  real*8 tc
-  complex*16 e_comp, sq
-
-  tc = tk - 273.15
-
-  ld = 100.*2.99792458E8/(freq*1E9)
-  es = 78.54*(1-(4.579E-3*(tc-25.)+1.19E-5*(tc-25.)**2 &
-       -2.8E-8*(tc-25.)**3))
-  ei = 5.27137+0.021647*tc-0.00131198*tc**2
-  a = -(16.8129/(tc+273.))+0.0609265
-  ls = 0.00033836*exp(2513.98/(tc+273.))
-  sg = 12.5664E8
-
-  tm1 = (ls/ld)**(1-a)
-  pi = acos(-1.D0)
-  cos1 = cos(0.5*a*pi)
-  sin1 = sin(0.5*a*pi)
-
-  e_r = ei + (((es-ei)*(1.+tm1*sin1))/(1.+2*tm1*sin1+tm1**2))
-  e_i = (((es-ei)*tm1*cos1)/(1.+2*tm1*sin1+tm1**2)) &
-        +((sg*ld)/1.885E11)
-
-  e_comp = dcmplx(e_r,e_i)
-  sq = sqrt(e_comp)
-  
-  n_r = real(sq)
-  n_i = aimag(sq)      
-  
-  return
-  end subroutine m_wat
-
-! ----------------------------------------------------------------------------
-! subroutine M_ICE
-! ----------------------------------------------------------------------------
-  subroutine m_ice(freq,t,n_r,n_i)
-  implicit none
-!
-! Purpose:
-!   compute complex index of refraction of ice
-!
-! Inputs:
-!   [freq]    frequency (GHz)
-!   [t]       temperature (K)
-!
-! Outputs:
-!   [n_r]     real part index of refraction
-!   [n_i]     imaginary part index of refraction
-!
-! Reference:
-!    Fortran 90 port from IDL of REFICE by Stephen G. Warren
-!
-! Modified:
-!   05/31/05  John Haynes (haynes@atmos.colostate.edu)
-
-! ----- INPUTS -----
-  real*8, intent(in) :: freq, t
-  
-! ----- OUTPUTS -----  
-  real*8, intent(out) :: n_r,n_i
-
-! Parameters:
-  integer*2 :: i,lt1,lt2,nwl,nwlt
-  parameter(nwl=468,nwlt=62)
-
-  real*8 :: alam,cutice,pi,t1,t2,wlmax,wlmin, &
-            x,x1,x2,y,y1,y2,ylo,yhi,tk
-
-  real*8 :: &
-       tabim(nwl),tabimt(nwlt,4),tabre(nwl),tabret(nwlt,4),temref(4), &
-       wl(nwl),wlt(nwlt)
-
-! Defines wavelength dependent complex index of refraction for ice.
-! Allowable wavelength range extends from 0.045 microns to 8.6 meter
-! temperature dependence only considered beyond 167 microns.
-! 
-! interpolation is done     n_r  vs. log(xlam)
-!                           n_r  vs.        t
-!                       log(n_i) vs. log(xlam)
-!                       log(n_i) vs.        t
-!
-! Stephen G. Warren - 1983
-! Dept. of Atmospheric Sciences
-! University of Washington
-! Seattle, Wa  98195
-!
-! Based on
-!
-!    Warren,S.G.,1984.
-!    Optical constants of ice from the ultraviolet to the microwave.
-!    Applied Optics,23,1206-1225
-!
-! Reference temperatures are -1.0,-5.0,-20.0, and -60.0 deg C
- 
-      data temref/272.16,268.16,253.16,213.16/
- 
-      data wlmin,wlmax/0.045,8.6e6/
-      data cutice/167.0/
- 
-      data (wl(i),i=1,114)/ &
-      0.4430e-01,0.4510e-01,0.4590e-01,0.4680e-01,0.4770e-01,0.4860e-01, &
-      0.4960e-01,0.5060e-01,0.5170e-01,0.5280e-01,0.5390e-01,0.5510e-01, &
-      0.5640e-01,0.5770e-01,0.5900e-01,0.6050e-01,0.6200e-01,0.6360e-01, &
-      0.6530e-01,0.6700e-01,0.6890e-01,0.7080e-01,0.7290e-01,0.7380e-01, &
-      0.7510e-01,0.7750e-01,0.8000e-01,0.8270e-01,0.8550e-01,0.8860e-01, &
-      0.9180e-01,0.9300e-01,0.9540e-01,0.9920e-01,0.1033e+00,0.1078e+00, &
-      0.1100e+00,0.1127e+00,0.1140e+00,0.1181e+00,0.1210e+00,0.1240e+00, &
-      0.1272e+00,0.1295e+00,0.1305e+00,0.1319e+00,0.1333e+00,0.1348e+00, &
-      0.1362e+00,0.1370e+00,0.1378e+00,0.1387e+00,0.1393e+00,0.1409e+00, &
-      0.1425e+00,0.1435e+00,0.1442e+00,0.1450e+00,0.1459e+00,0.1468e+00, &
-      0.1476e+00,0.1480e+00,0.1485e+00,0.1494e+00,0.1512e+00,0.1531e+00, &
-      0.1540e+00,0.1550e+00,0.1569e+00,0.1580e+00,0.1589e+00,0.1610e+00, &
-      0.1625e+00,0.1648e+00,0.1669e+00,0.1692e+00,0.1713e+00,0.1737e+00, &
-      0.1757e+00,0.1779e+00,0.1802e+00,0.1809e+00,0.1821e+00,0.1833e+00, &
-      0.1843e+00,0.1850e+00,0.1860e+00,0.1870e+00,0.1880e+00,0.1890e+00, &
-      0.1900e+00,0.1910e+00,0.1930e+00,0.1950e+00,0.2100e+00,0.2500e+00, &
-      0.3000e+00,0.3500e+00,0.4000e+00,0.4100e+00,0.4200e+00,0.4300e+00, &
-      0.4400e+00,0.4500e+00,0.4600e+00,0.4700e+00,0.4800e+00,0.4900e+00, &
-      0.5000e+00,0.5100e+00,0.5200e+00,0.5300e+00,0.5400e+00,0.5500e+00/
-      data (wl(i),i=115,228)/ &
-      0.5600e+00,0.5700e+00,0.5800e+00,0.5900e+00,0.6000e+00,0.6100e+00, &
-      0.6200e+00,0.6300e+00,0.6400e+00,0.6500e+00,0.6600e+00,0.6700e+00, &
-      0.6800e+00,0.6900e+00,0.7000e+00,0.7100e+00,0.7200e+00,0.7300e+00, &
-      0.7400e+00,0.7500e+00,0.7600e+00,0.7700e+00,0.7800e+00,0.7900e+00, &
-      0.8000e+00,0.8100e+00,0.8200e+00,0.8300e+00,0.8400e+00,0.8500e+00, &
-      0.8600e+00,0.8700e+00,0.8800e+00,0.8900e+00,0.9000e+00,0.9100e+00, &
-      0.9200e+00,0.9300e+00,0.9400e+00,0.9500e+00,0.9600e+00,0.9700e+00, &
-      0.9800e+00,0.9900e+00,0.1000e+01,0.1010e+01,0.1020e+01,0.1030e+01, &
-      0.1040e+01,0.1050e+01,0.1060e+01,0.1070e+01,0.1080e+01,0.1090e+01, &
-      0.1100e+01,0.1110e+01,0.1120e+01,0.1130e+01,0.1140e+01,0.1150e+01, &
-      0.1160e+01,0.1170e+01,0.1180e+01,0.1190e+01,0.1200e+01,0.1210e+01, &
-      0.1220e+01,0.1230e+01,0.1240e+01,0.1250e+01,0.1260e+01,0.1270e+01, &
-      0.1280e+01,0.1290e+01,0.1300e+01,0.1310e+01,0.1320e+01,0.1330e+01, &
-      0.1340e+01,0.1350e+01,0.1360e+01,0.1370e+01,0.1380e+01,0.1390e+01, &
-      0.1400e+01,0.1410e+01,0.1420e+01,0.1430e+01,0.1440e+01,0.1449e+01, &
-      0.1460e+01,0.1471e+01,0.1481e+01,0.1493e+01,0.1504e+01,0.1515e+01, &
-      0.1527e+01,0.1538e+01,0.1563e+01,0.1587e+01,0.1613e+01,0.1650e+01, &
-      0.1680e+01,0.1700e+01,0.1730e+01,0.1760e+01,0.1800e+01,0.1830e+01, &
-      0.1840e+01,0.1850e+01,0.1855e+01,0.1860e+01,0.1870e+01,0.1890e+01/
-      data (wl(i),i=229,342)/ &
-      0.1905e+01,0.1923e+01,0.1942e+01,0.1961e+01,0.1980e+01,0.2000e+01, &
-      0.2020e+01,0.2041e+01,0.2062e+01,0.2083e+01,0.2105e+01,0.2130e+01, &
-      0.2150e+01,0.2170e+01,0.2190e+01,0.2220e+01,0.2240e+01,0.2245e+01, &
-      0.2250e+01,0.2260e+01,0.2270e+01,0.2290e+01,0.2310e+01,0.2330e+01, &
-      0.2350e+01,0.2370e+01,0.2390e+01,0.2410e+01,0.2430e+01,0.2460e+01, &
-      0.2500e+01,0.2520e+01,0.2550e+01,0.2565e+01,0.2580e+01,0.2590e+01, &
-      0.2600e+01,0.2620e+01,0.2675e+01,0.2725e+01,0.2778e+01,0.2817e+01, &
-      0.2833e+01,0.2849e+01,0.2865e+01,0.2882e+01,0.2899e+01,0.2915e+01, &
-      0.2933e+01,0.2950e+01,0.2967e+01,0.2985e+01,0.3003e+01,0.3021e+01, &
-      0.3040e+01,0.3058e+01,0.3077e+01,0.3096e+01,0.3115e+01,0.3135e+01, &
-      0.3155e+01,0.3175e+01,0.3195e+01,0.3215e+01,0.3236e+01,0.3257e+01, &
-      0.3279e+01,0.3300e+01,0.3322e+01,0.3345e+01,0.3367e+01,0.3390e+01, &
-      0.3413e+01,0.3436e+01,0.3460e+01,0.3484e+01,0.3509e+01,0.3534e+01, &
-      0.3559e+01,0.3624e+01,0.3732e+01,0.3775e+01,0.3847e+01,0.3969e+01, &
-      0.4099e+01,0.4239e+01,0.4348e+01,0.4387e+01,0.4444e+01,0.4505e+01, &
-      0.4547e+01,0.4560e+01,0.4580e+01,0.4719e+01,0.4904e+01,0.5000e+01, &
-      0.5100e+01,0.5200e+01,0.5263e+01,0.5400e+01,0.5556e+01,0.5714e+01, &
-      0.5747e+01,0.5780e+01,0.5814e+01,0.5848e+01,0.5882e+01,0.6061e+01, &
-      0.6135e+01,0.6250e+01,0.6289e+01,0.6329e+01,0.6369e+01,0.6410e+01/
-      data (wl(i),i=343,456)/ &
-      0.6452e+01,0.6494e+01,0.6579e+01,0.6667e+01,0.6757e+01,0.6897e+01, &
-      0.7042e+01,0.7143e+01,0.7246e+01,0.7353e+01,0.7463e+01,0.7576e+01, &
-      0.7692e+01,0.7812e+01,0.7937e+01,0.8065e+01,0.8197e+01,0.8333e+01, &
-      0.8475e+01,0.8696e+01,0.8929e+01,0.9091e+01,0.9259e+01,0.9524e+01, &
-      0.9804e+01,0.1000e+02,0.1020e+02,0.1031e+02,0.1042e+02,0.1053e+02, &
-      0.1064e+02,0.1075e+02,0.1087e+02,0.1100e+02,0.1111e+02,0.1136e+02, &
-      0.1163e+02,0.1190e+02,0.1220e+02,0.1250e+02,0.1282e+02,0.1299e+02, &
-      0.1316e+02,0.1333e+02,0.1351e+02,0.1370e+02,0.1389e+02,0.1408e+02, &
-      0.1429e+02,0.1471e+02,0.1515e+02,0.1538e+02,0.1563e+02,0.1613e+02, &
-      0.1639e+02,0.1667e+02,0.1695e+02,0.1724e+02,0.1818e+02,0.1887e+02, &
-      0.1923e+02,0.1961e+02,0.2000e+02,0.2041e+02,0.2083e+02,0.2222e+02, &
-      0.2260e+02,0.2305e+02,0.2360e+02,0.2460e+02,0.2500e+02,0.2600e+02, &
-      0.2857e+02,0.3100e+02,0.3333e+02,0.3448e+02,0.3564e+02,0.3700e+02, &
-      0.3824e+02,0.3960e+02,0.4114e+02,0.4276e+02,0.4358e+02,0.4458e+02, &
-      0.4550e+02,0.4615e+02,0.4671e+02,0.4736e+02,0.4800e+02,0.4878e+02, &
-      0.5003e+02,0.5128e+02,0.5275e+02,0.5350e+02,0.5424e+02,0.5500e+02, &
-      0.5574e+02,0.5640e+02,0.5700e+02,0.5746e+02,0.5840e+02,0.5929e+02, &
-      0.6000e+02,0.6100e+02,0.6125e+02,0.6250e+02,0.6378e+02,0.6467e+02, &
-      0.6558e+02,0.6655e+02,0.6760e+02,0.6900e+02,0.7053e+02,0.7300e+02/
-      data (wl(i),i=457,468)/ &
-      0.7500e+02,0.7629e+02,0.8000e+02,0.8297e+02,0.8500e+02,0.8680e+02, &
-      0.9080e+02,0.9517e+02,0.1000e+03,0.1200e+03,0.1500e+03,0.1670e+03/
-      data  wlt/ &
-                                       0.1670e+03,0.1778e+03,0.1884e+03, &
-      0.1995e+03,0.2113e+03,0.2239e+03,0.2371e+03,0.2512e+03,0.2661e+03, &
-      0.2818e+03,0.2985e+03,0.3162e+03,0.3548e+03,0.3981e+03,0.4467e+03, &
-      0.5012e+03,0.5623e+03,0.6310e+03,0.7943e+03,0.1000e+04,0.1259e+04, &
-      0.2500e+04,0.5000e+04,0.1000e+05,0.2000e+05,0.3200e+05,0.3500e+05, &
-      0.4000e+05,0.4500e+05,0.5000e+05,0.6000e+05,0.7000e+05,0.9000e+05, &
-      0.1110e+06,0.1200e+06,0.1300e+06,0.1400e+06,0.1500e+06,0.1600e+06, &
-      0.1700e+06,0.1800e+06,0.2000e+06,0.2500e+06,0.2900e+06,0.3200e+06, &
-      0.3500e+06,0.3800e+06,0.4000e+06,0.4500e+06,0.5000e+06,0.6000e+06, &
-      0.6400e+06,0.6800e+06,0.7200e+06,0.7600e+06,0.8000e+06,0.8400e+06, &
-      0.9000e+06,0.1000e+07,0.2000e+07,0.5000e+07,0.8600e+07/
-      data (tabre(i),i=1,114)/ &
-         0.83441,   0.83676,   0.83729,   0.83771,   0.83827,   0.84038, &
-         0.84719,   0.85522,   0.86047,   0.86248,   0.86157,   0.86093, &
-         0.86419,   0.86916,   0.87764,   0.89296,   0.91041,   0.93089, &
-         0.95373,   0.98188,   1.02334,   1.06735,   1.11197,   1.13134, &
-         1.15747,   1.20045,   1.23840,   1.27325,   1.32157,   1.38958, &
-         1.41644,   1.40906,   1.40063,   1.40169,   1.40934,   1.40221, &
-         1.39240,   1.38424,   1.38075,   1.38186,   1.39634,   1.40918, &
-         1.40256,   1.38013,   1.36303,   1.34144,   1.32377,   1.30605, &
-         1.29054,   1.28890,   1.28931,   1.30190,   1.32025,   1.36302, &
-         1.41872,   1.45834,   1.49028,   1.52128,   1.55376,   1.57782, &
-         1.59636,   1.60652,   1.61172,   1.61919,   1.62522,   1.63404, &
-         1.63689,   1.63833,   1.63720,   1.63233,   1.62222,   1.58269, &
-         1.55635,   1.52453,   1.50320,   1.48498,   1.47226,   1.45991, &
-         1.45115,   1.44272,   1.43498,   1.43280,   1.42924,   1.42602, &
-         1.42323,   1.42143,   1.41897,   1.41660,   1.41434,   1.41216, &
-         1.41006,   1.40805,   1.40423,   1.40067,   1.38004,   1.35085, &
-         1.33394,   1.32492,   1.31940,   1.31854,   1.31775,   1.31702, &
-         1.31633,   1.31569,   1.31509,   1.31452,   1.31399,   1.31349, &
-         1.31302,   1.31257,   1.31215,   1.31175,   1.31136,   1.31099/
-      data (tabre(i),i=115,228)/ &
-         1.31064,   1.31031,   1.30999,   1.30968,   1.30938,   1.30909, &
-         1.30882,   1.30855,   1.30829,   1.30804,   1.30780,   1.30756, &
-         1.30733,   1.30710,   1.30688,   1.30667,   1.30646,   1.30625, &
-         1.30605,   1.30585,   1.30566,   1.30547,   1.30528,   1.30509, &
-         1.30491,   1.30473,   1.30455,   1.30437,   1.30419,   1.30402, &
-         1.30385,   1.30367,   1.30350,   1.30333,   1.30316,   1.30299, &
-         1.30283,   1.30266,   1.30249,   1.30232,   1.30216,   1.30199, &
-         1.30182,   1.30166,   1.30149,   1.30132,   1.30116,   1.30099, &
-         1.30082,   1.30065,   1.30048,   1.30031,   1.30014,   1.29997, &
-         1.29979,   1.29962,   1.29945,   1.29927,   1.29909,   1.29891, &
-         1.29873,   1.29855,   1.29837,   1.29818,   1.29800,   1.29781, &
-         1.29762,   1.29743,   1.29724,   1.29705,   1.29686,   1.29666, &
-         1.29646,   1.29626,   1.29605,   1.29584,   1.29563,   1.29542, &
-         1.29521,   1.29499,   1.29476,   1.29453,   1.29430,   1.29406, &
-         1.29381,   1.29355,   1.29327,   1.29299,   1.29272,   1.29252, &
-         1.29228,   1.29205,   1.29186,   1.29167,   1.29150,   1.29130, &
-         1.29106,   1.29083,   1.29025,   1.28962,   1.28891,   1.28784, &
-         1.28689,   1.28623,   1.28521,   1.28413,   1.28261,   1.28137, &
-         1.28093,   1.28047,   1.28022,   1.27998,   1.27948,   1.27849/
-      data (tabre(i),i=229,342)/ &
-         1.27774,   1.27691,   1.27610,   1.27535,   1.27471,   1.27404, &
-         1.27329,   1.27240,   1.27139,   1.27029,   1.26901,   1.26736, &
-         1.26591,   1.26441,   1.26284,   1.26036,   1.25860,   1.25815, &
-         1.25768,   1.25675,   1.25579,   1.25383,   1.25179,   1.24967, &
-         1.24745,   1.24512,   1.24266,   1.24004,   1.23725,   1.23270, &
-         1.22583,   1.22198,   1.21548,   1.21184,   1.20790,   1.20507, &
-         1.20209,   1.19566,   1.17411,   1.14734,   1.10766,   1.06739, &
-         1.04762,   1.02650,   1.00357,   0.98197,   0.96503,   0.95962, &
-         0.97269,   0.99172,   1.00668,   1.02186,   1.04270,   1.07597, &
-         1.12954,   1.21267,   1.32509,   1.42599,   1.49656,   1.55095, &
-         1.59988,   1.63631,   1.65024,   1.64278,   1.62691,   1.61284, &
-         1.59245,   1.57329,   1.55770,   1.54129,   1.52654,   1.51139, &
-         1.49725,   1.48453,   1.47209,   1.46125,   1.45132,   1.44215, &
-         1.43366,   1.41553,   1.39417,   1.38732,   1.37735,   1.36448, &
-         1.35414,   1.34456,   1.33882,   1.33807,   1.33847,   1.34053, &
-         1.34287,   1.34418,   1.34634,   1.34422,   1.33453,   1.32897, &
-         1.32333,   1.31800,   1.31432,   1.30623,   1.29722,   1.28898, &
-         1.28730,   1.28603,   1.28509,   1.28535,   1.28813,   1.30156, &
-         1.30901,   1.31720,   1.31893,   1.32039,   1.32201,   1.32239/
-      data (tabre(i),i=343,456)/ &
-         1.32149,   1.32036,   1.31814,   1.31705,   1.31807,   1.31953, &
-         1.31933,   1.31896,   1.31909,   1.31796,   1.31631,   1.31542, &
-         1.31540,   1.31552,   1.31455,   1.31193,   1.30677,   1.29934, &
-         1.29253,   1.28389,   1.27401,   1.26724,   1.25990,   1.24510, &
-         1.22241,   1.19913,   1.17150,   1.15528,   1.13700,   1.11808, &
-         1.10134,   1.09083,   1.08734,   1.09254,   1.10654,   1.14779, &
-         1.20202,   1.25825,   1.32305,   1.38574,   1.44478,   1.47170, &
-         1.49619,   1.51652,   1.53328,   1.54900,   1.56276,   1.57317, &
-         1.58028,   1.57918,   1.56672,   1.55869,   1.55081,   1.53807, &
-         1.53296,   1.53220,   1.53340,   1.53289,   1.51705,   1.50097, &
-         1.49681,   1.49928,   1.50153,   1.49856,   1.49053,   1.46070, &
-         1.45182,   1.44223,   1.43158,   1.41385,   1.40676,   1.38955, &
-         1.34894,   1.31039,   1.26420,   1.23656,   1.21663,   1.20233, &
-         1.19640,   1.19969,   1.20860,   1.22173,   1.24166,   1.28175, &
-         1.32784,   1.38657,   1.46486,   1.55323,   1.60379,   1.61877, &
-         1.62963,   1.65712,   1.69810,   1.72065,   1.74865,   1.76736, &
-         1.76476,   1.75011,   1.72327,   1.68490,   1.62398,   1.59596, &
-         1.58514,   1.59917,   1.61405,   1.66625,   1.70663,   1.73713, &
-         1.76860,   1.80343,   1.83296,   1.85682,   1.87411,   1.89110/
-      data (tabre(i),i=457,468)/ &
-         1.89918,   1.90432,   1.90329,   1.88744,   1.87499,   1.86702, &
-         1.85361,   1.84250,   1.83225,   1.81914,   1.82268,   1.82961/
-      data (tabret(i,1),i=1,nwlt)/ &
-                                          1.82961,   1.83258,   1.83149, &
-         1.82748,   1.82224,   1.81718,   1.81204,   1.80704,   1.80250, &
-         1.79834,   1.79482,   1.79214,   1.78843,   1.78601,   1.78434, &
-         1.78322,   1.78248,   1.78201,   1.78170,   1.78160,   1.78190, &
-         1.78300,   1.78430,   1.78520,   1.78620,   1.78660,   1.78680, &
-         1.78690,   1.78700,   1.78700,   1.78710,   1.78710,   1.78720, &
-         1.78720,   1.78720,   1.78720,   1.78720,   1.78720,   1.78720, &
-         1.78720,   1.78720,   1.78720,   1.78720,   1.78720,   1.78720, &
-         1.78720,   1.78720,   1.78720,   1.78720,   1.78720,   1.78720, &
-         1.78720,   1.78720,   1.78720,   1.78720,   1.78720,   1.78720, &
-         1.78720,   1.78720,   1.78720,   1.78720,   1.78800/
-      data (tabret(i,2),i=1,nwlt)/ &
-                               1.82961,   1.83258,   1.83149,   1.82748, &
-         1.82224,   1.81718,   1.81204,   1.80704,   1.80250,   1.79834, &
-         1.79482,   1.79214,   1.78843,   1.78601,   1.78434,   1.78322, &
-         1.78248,   1.78201,   1.78170,   1.78160,   1.78190,   1.78300, &
-         1.78430,   1.78520,   1.78610,   1.78630,   1.78640,   1.78650, &
-         1.78650,   1.78650,   1.78650,   1.78650,   1.78650,   1.78650, &
-         1.78650,   1.78650,   1.78650,   1.78650,   1.78650,   1.78650, &
-         1.78650,   1.78650,   1.78650,   1.78650,   1.78650,   1.78650, &
-         1.78650,   1.78650,   1.78650,   1.78650,   1.78650,   1.78650, &
-         1.78650,   1.78650,   1.78650,   1.78650,   1.78650,   1.78650, &
-         1.78650,   1.78650,   1.78650,   1.78720/
-      data(tabret(i,3),i=1,nwlt)/ &
-                    1.82961,   1.83258,   1.83149,   1.82748,   1.82224, &
-         1.81718,   1.81204,   1.80704,   1.80250,   1.79834,   1.79482, &
-         1.79214,   1.78843,   1.78601,   1.78434,   1.78322,   1.78248, &
-         1.78201,   1.78160,   1.78140,   1.78160,   1.78220,   1.78310, &
-         1.78380,   1.78390,   1.78400,   1.78400,   1.78400,   1.78400, &
-         1.78400,   1.78390,   1.78380,   1.78370,   1.78370,   1.78370, &
-         1.78370,   1.78370,   1.78370,   1.78370,   1.78370,   1.78370, &
-         1.78370,   1.78370,   1.78370,   1.78370,   1.78370,   1.78370, &
-         1.78370,   1.78370,   1.78370,   1.78370,   1.78370,   1.78370, &
-         1.78370,   1.78370,   1.78370,   1.78370,   1.78370,   1.78370, &
-         1.78370,   1.78400,   1.78450/
-      data (tabret(i,4),i=1,nwlt)/ &
-         1.82961,   1.83258,   1.83149,   1.82748,   1.82224,   1.81718, &
-         1.81204,   1.80704,   1.80250,   1.79834,   1.79482,   1.79214, &
-         1.78843,   1.78601,   1.78434,   1.78322,   1.78248,   1.78201, &
-         1.78150,   1.78070,   1.78010,   1.77890,   1.77790,   1.77730, &
-         1.77720,   1.77720,   1.77720,   1.77720,   1.77720,   1.77720, &
-         1.77720,   1.77720,   1.77720,   1.77720,   1.77720,   1.77720, &
-         1.77720,   1.77720,   1.77720,   1.77720,   1.77720,   1.77720, &
-         1.77720,   1.77720,   1.77720,   1.77720,   1.77720,   1.77720, &
-         1.77720,   1.77720,   1.77720,   1.77720,   1.77720,   1.77720, &
-         1.77720,   1.77720,   1.77720,   1.77720,   1.77720,   1.77720, &
-         1.77720,   1.77800/
-      data(tabim(i),i=1,114)/ &
-      0.1640e+00,0.1730e+00,0.1830e+00,0.1950e+00,0.2080e+00,0.2230e+00, &
-      0.2400e+00,0.2500e+00,0.2590e+00,0.2680e+00,0.2790e+00,0.2970e+00, &
-      0.3190e+00,0.3400e+00,0.3660e+00,0.3920e+00,0.4160e+00,0.4400e+00, &
-      0.4640e+00,0.4920e+00,0.5170e+00,0.5280e+00,0.5330e+00,0.5340e+00, &
-      0.5310e+00,0.5240e+00,0.5100e+00,0.5000e+00,0.4990e+00,0.4680e+00, &
-      0.3800e+00,0.3600e+00,0.3390e+00,0.3180e+00,0.2910e+00,0.2510e+00, &
-      0.2440e+00,0.2390e+00,0.2390e+00,0.2440e+00,0.2470e+00,0.2240e+00, &
-      0.1950e+00,0.1740e+00,0.1720e+00,0.1800e+00,0.1940e+00,0.2130e+00, &
-      0.2430e+00,0.2710e+00,0.2890e+00,0.3340e+00,0.3440e+00,0.3820e+00, &
-      0.4010e+00,0.4065e+00,0.4050e+00,0.3890e+00,0.3770e+00,0.3450e+00, &
-      0.3320e+00,0.3150e+00,0.2980e+00,0.2740e+00,0.2280e+00,0.1980e+00, &
-      0.1720e+00,0.1560e+00,0.1100e+00,0.8300e-01,0.5800e-01,0.2200e-01, &
-      0.1000e-01,0.3000e-02,0.1000e-02,0.3000e-03,0.1000e-03,0.3000e-04, &
-      0.1000e-04,0.3000e-05,0.1000e-05,0.7000e-06,0.4000e-06,0.2000e-06, &
-      0.1000e-06,0.6377e-07,0.3750e-07,0.2800e-07,0.2400e-07,0.2200e-07, &
-      0.1900e-07,0.1750e-07,0.1640e-07,0.1590e-07,0.1325e-07,0.8623e-08, &
-      0.5504e-08,0.3765e-08,0.2710e-08,0.2510e-08,0.2260e-08,0.2080e-08, &
-      0.1910e-08,0.1540e-08,0.1530e-08,0.1550e-08,0.1640e-08,0.1780e-08, &
-      0.1910e-08,0.2140e-08,0.2260e-08,0.2540e-08,0.2930e-08,0.3110e-08/
-      data(tabim(i),i=115,228)/ &
-      0.3290e-08,0.3520e-08,0.4040e-08,0.4880e-08,0.5730e-08,0.6890e-08, &
-      0.8580e-08,0.1040e-07,0.1220e-07,0.1430e-07,0.1660e-07,0.1890e-07, &
-      0.2090e-07,0.2400e-07,0.2900e-07,0.3440e-07,0.4030e-07,0.4300e-07, &
-      0.4920e-07,0.5870e-07,0.7080e-07,0.8580e-07,0.1020e-06,0.1180e-06, &
-      0.1340e-06,0.1400e-06,0.1430e-06,0.1450e-06,0.1510e-06,0.1830e-06, &
-      0.2150e-06,0.2650e-06,0.3350e-06,0.3920e-06,0.4200e-06,0.4440e-06, &
-      0.4740e-06,0.5110e-06,0.5530e-06,0.6020e-06,0.7550e-06,0.9260e-06, &
-      0.1120e-05,0.1330e-05,0.1620e-05,0.2000e-05,0.2250e-05,0.2330e-05, &
-      0.2330e-05,0.2170e-05,0.1960e-05,0.1810e-05,0.1740e-05,0.1730e-05, &
-      0.1700e-05,0.1760e-05,0.1820e-05,0.2040e-05,0.2250e-05,0.2290e-05, &
-      0.3040e-05,0.3840e-05,0.4770e-05,0.5760e-05,0.6710e-05,0.8660e-05, &
-      0.1020e-04,0.1130e-04,0.1220e-04,0.1290e-04,0.1320e-04,0.1350e-04, &
-      0.1330e-04,0.1320e-04,0.1320e-04,0.1310e-04,0.1320e-04,0.1320e-04, &
-      0.1340e-04,0.1390e-04,0.1420e-04,0.1480e-04,0.1580e-04,0.1740e-04, &
-      0.1980e-04,0.2500e-04,0.5400e-04,0.1040e-03,0.2030e-03,0.2708e-03, &
-      0.3511e-03,0.4299e-03,0.5181e-03,0.5855e-03,0.5899e-03,0.5635e-03, &
-      0.5480e-03,0.5266e-03,0.4394e-03,0.3701e-03,0.3372e-03,0.2410e-03, &
-      0.1890e-03,0.1660e-03,0.1450e-03,0.1280e-03,0.1030e-03,0.8600e-04, &
-      0.8220e-04,0.8030e-04,0.8500e-04,0.9900e-04,0.1500e-03,0.2950e-03/
-      data(tabim(i),i=229,342)/ &
-      0.4687e-03,0.7615e-03,0.1010e-02,0.1313e-02,0.1539e-02,0.1588e-02, &
-      0.1540e-02,0.1412e-02,0.1244e-02,0.1068e-02,0.8414e-03,0.5650e-03, &
-      0.4320e-03,0.3500e-03,0.2870e-03,0.2210e-03,0.2030e-03,0.2010e-03, &
-      0.2030e-03,0.2140e-03,0.2320e-03,0.2890e-03,0.3810e-03,0.4620e-03, &
-      0.5480e-03,0.6180e-03,0.6800e-03,0.7300e-03,0.7820e-03,0.8480e-03, &
-      0.9250e-03,0.9200e-03,0.8920e-03,0.8700e-03,0.8900e-03,0.9300e-03, &
-      0.1010e-02,0.1350e-02,0.3420e-02,0.7920e-02,0.2000e-01,0.3800e-01, &
-      0.5200e-01,0.6800e-01,0.9230e-01,0.1270e+00,0.1690e+00,0.2210e+00, &
-      0.2760e+00,0.3120e+00,0.3470e+00,0.3880e+00,0.4380e+00,0.4930e+00, &
-      0.5540e+00,0.6120e+00,0.6250e+00,0.5930e+00,0.5390e+00,0.4910e+00, &
-      0.4380e+00,0.3720e+00,0.3000e+00,0.2380e+00,0.1930e+00,0.1580e+00, &
-      0.1210e+00,0.1030e+00,0.8360e-01,0.6680e-01,0.5400e-01,0.4220e-01, &
-      0.3420e-01,0.2740e-01,0.2200e-01,0.1860e-01,0.1520e-01,0.1260e-01, &
-      0.1060e-01,0.8020e-02,0.6850e-02,0.6600e-02,0.6960e-02,0.9160e-02, &
-      0.1110e-01,0.1450e-01,0.2000e-01,0.2300e-01,0.2600e-01,0.2900e-01, &
-      0.2930e-01,0.3000e-01,0.2850e-01,0.1730e-01,0.1290e-01,0.1200e-01, &
-      0.1250e-01,0.1340e-01,0.1400e-01,0.1750e-01,0.2400e-01,0.3500e-01, &
-      0.3800e-01,0.4200e-01,0.4600e-01,0.5200e-01,0.5700e-01,0.6900e-01, &
-      0.7000e-01,0.6700e-01,0.6500e-01,0.6400e-01,0.6200e-01,0.5900e-01/
-      data(tabim(i),i=343,456)/ &
-      0.5700e-01,0.5600e-01,0.5500e-01,0.5700e-01,0.5800e-01,0.5700e-01, &
-      0.5500e-01,0.5500e-01,0.5400e-01,0.5200e-01,0.5200e-01,0.5200e-01, &
-      0.5200e-01,0.5000e-01,0.4700e-01,0.4300e-01,0.3900e-01,0.3700e-01, &
-      0.3900e-01,0.4000e-01,0.4200e-01,0.4400e-01,0.4500e-01,0.4600e-01, &
-      0.4700e-01,0.5100e-01,0.6500e-01,0.7500e-01,0.8800e-01,0.1080e+00, &
-      0.1340e+00,0.1680e+00,0.2040e+00,0.2480e+00,0.2800e+00,0.3410e+00, &
-      0.3790e+00,0.4090e+00,0.4220e+00,0.4220e+00,0.4030e+00,0.3890e+00, &
-      0.3740e+00,0.3540e+00,0.3350e+00,0.3150e+00,0.2940e+00,0.2710e+00, &
-      0.2460e+00,0.1980e+00,0.1640e+00,0.1520e+00,0.1420e+00,0.1280e+00, &
-      0.1250e+00,0.1230e+00,0.1160e+00,0.1070e+00,0.7900e-01,0.7200e-01, &
-      0.7600e-01,0.7500e-01,0.6700e-01,0.5500e-01,0.4500e-01,0.2900e-01, &
-      0.2750e-01,0.2700e-01,0.2730e-01,0.2890e-01,0.3000e-01,0.3400e-01, &
-      0.5300e-01,0.7550e-01,0.1060e+00,0.1350e+00,0.1761e+00,0.2229e+00, &
-      0.2746e+00,0.3280e+00,0.3906e+00,0.4642e+00,0.5247e+00,0.5731e+00, &
-      0.6362e+00,0.6839e+00,0.7091e+00,0.6790e+00,0.6250e+00,0.5654e+00, &
-      0.5433e+00,0.5292e+00,0.5070e+00,0.4883e+00,0.4707e+00,0.4203e+00, &
-      0.3771e+00,0.3376e+00,0.3056e+00,0.2835e+00,0.3170e+00,0.3517e+00, &
-      0.3902e+00,0.4509e+00,0.4671e+00,0.4779e+00,0.4890e+00,0.4899e+00, &
-      0.4873e+00,0.4766e+00,0.4508e+00,0.4193e+00,0.3880e+00,0.3433e+00/
-      data(tabim(i),i=457,468)/ &
-      0.3118e+00,0.2935e+00,0.2350e+00,0.1981e+00,0.1865e+00,0.1771e+00, &
-      0.1620e+00,0.1490e+00,0.1390e+00,0.1200e+00,0.9620e-01,0.8300e-01/
-      data(tabimt(i,1),i=1,nwlt)/ &
-                                       0.8300e-01,0.6900e-01,0.5700e-01, &
-      0.4560e-01,0.3790e-01,0.3140e-01,0.2620e-01,0.2240e-01,0.1960e-01, &
-      0.1760e-01,0.1665e-01,0.1620e-01,0.1550e-01,0.1470e-01,0.1390e-01, &
-      0.1320e-01,0.1250e-01,0.1180e-01,0.1060e-01,0.9540e-02,0.8560e-02, &
-      0.6210e-02,0.4490e-02,0.3240e-02,0.2340e-02,0.1880e-02,0.1740e-02, &
-      0.1500e-02,0.1320e-02,0.1160e-02,0.8800e-03,0.6950e-03,0.4640e-03, &
-      0.3400e-03,0.3110e-03,0.2940e-03,0.2790e-03,0.2700e-03,0.2640e-03, &
-      0.2580e-03,0.2520e-03,0.2490e-03,0.2540e-03,0.2640e-03,0.2740e-03, &
-      0.2890e-03,0.3050e-03,0.3150e-03,0.3460e-03,0.3820e-03,0.4620e-03, &
-      0.5000e-03,0.5500e-03,0.5950e-03,0.6470e-03,0.6920e-03,0.7420e-03, &
-      0.8200e-03,0.9700e-03,0.1950e-02,0.5780e-02,0.9700e-02/
-      data(tabimt(i,2),i=1,nwlt)/ &
-                            0.8300e-01,0.6900e-01,0.5700e-01,0.4560e-01, &
-      0.3790e-01,0.3140e-01,0.2620e-01,0.2240e-01,0.1960e-01,0.1760e-01, &
-      0.1665e-01,0.1600e-01,0.1500e-01,0.1400e-01,0.1310e-01,0.1230e-01, &
-      0.1150e-01,0.1080e-01,0.9460e-02,0.8290e-02,0.7270e-02,0.4910e-02, &
-      0.3300e-02,0.2220e-02,0.1490e-02,0.1140e-02,0.1060e-02,0.9480e-03, &
-      0.8500e-03,0.7660e-03,0.6300e-03,0.5200e-03,0.3840e-03,0.2960e-03, &
-      0.2700e-03,0.2520e-03,0.2440e-03,0.2360e-03,0.2300e-03,0.2280e-03, &
-      0.2250e-03,0.2200e-03,0.2160e-03,0.2170e-03,0.2200e-03,0.2250e-03, &
-      0.2320e-03,0.2390e-03,0.2600e-03,0.2860e-03,0.3560e-03,0.3830e-03, &
-      0.4150e-03,0.4450e-03,0.4760e-03,0.5080e-03,0.5400e-03,0.5860e-03, &
-      0.6780e-03,0.1280e-02,0.3550e-02,0.5600e-02/
-      data(tabimt(i,3),i=1,nwlt)/ &
-                 0.8300e-01,0.6900e-01,0.5700e-01,0.4560e-01,0.3790e-01, &
-      0.3140e-01,0.2620e-01,0.2190e-01,0.1880e-01,0.1660e-01,0.1540e-01, &
-      0.1470e-01,0.1350e-01,0.1250e-01,0.1150e-01,0.1060e-01,0.9770e-02, &
-      0.9010e-02,0.7660e-02,0.6520e-02,0.5540e-02,0.3420e-02,0.2100e-02, &
-      0.1290e-02,0.7930e-03,0.5700e-03,0.5350e-03,0.4820e-03,0.4380e-03, &
-      0.4080e-03,0.3500e-03,0.3200e-03,0.2550e-03,0.2120e-03,0.2000e-03, &
-      0.1860e-03,0.1750e-03,0.1660e-03,0.1560e-03,0.1490e-03,0.1440e-03, &
-      0.1350e-03,0.1210e-03,0.1160e-03,0.1160e-03,0.1170e-03,0.1200e-03, &
-      0.1230e-03,0.1320e-03,0.1440e-03,0.1680e-03,0.1800e-03,0.1900e-03, &
-      0.2090e-03,0.2160e-03,0.2290e-03,0.2400e-03,0.2600e-03,0.2920e-03, &
-      0.6100e-03,0.1020e-02,0.1810e-02/
-      data(tabimt(i,4),i=1,nwlt)/ &
-      0.8300e-01,0.6900e-01,0.5700e-01,0.4450e-01,0.3550e-01,0.2910e-01, &
-      0.2440e-01,0.1970e-01,0.1670e-01,0.1400e-01,0.1235e-01,0.1080e-01, &
-      0.8900e-02,0.7340e-02,0.6400e-02,0.5600e-02,0.5000e-02,0.4520e-02, &
-      0.3680e-02,0.2990e-02,0.2490e-02,0.1550e-02,0.9610e-03,0.5950e-03, &
-      0.3690e-03,0.2670e-03,0.2510e-03,0.2290e-03,0.2110e-03,0.1960e-03, &
-      0.1730e-03,0.1550e-03,0.1310e-03,0.1130e-03,0.1060e-03,0.9900e-04, &
-      0.9300e-04,0.8730e-04,0.8300e-04,0.7870e-04,0.7500e-04,0.6830e-04, &
-      0.5600e-04,0.4960e-04,0.4550e-04,0.4210e-04,0.3910e-04,0.3760e-04, &
-      0.3400e-04,0.3100e-04,0.2640e-04,0.2510e-04,0.2430e-04,0.2390e-04, &
-      0.2370e-04,0.2380e-04,0.2400e-04,0.2460e-04,0.2660e-04,0.4450e-04, &
-      0.8700e-04,0.1320e-03/
- 
-  pi = acos(-1.0)
-  n_r=0.0
-  n_i=0.0
-
-  tk = t
-
-! // convert frequency to wavelength (um)
-  alam=3E5/freq
-  if((alam < wlmin) .or. (alam > wlmax)) then
-    print *, 'm_ice: wavelength out of bounds'
-    stop
-  endif
-
-  if (alam < cutice) then
-
-!   // region from 0.045 microns to 167.0 microns - no temperature depend
-    do i=2,nwl
-      if(alam < wl(i)) continue
-    enddo
-    x1=log(wl(i-1))
-    x2=log(wl(i))
-    y1=tabre(i-1)
-    y2=tabre(i)
-    x=log(alam)
-    y=((x-x1)*(y2-y1)/(x2-x1))+y1
-    n_r=y
-    y1=log(abs(tabim(i-1)))
-    y2=log(abs(tabim(i)))
-    y=((x-x1)*(y2-y1)/(x2-x1))+y1
-    n_i=exp(y)
-
-  else
-
-!   // region from 167.0 microns to 8.6 meters - temperature dependence
-    if(tk > temref(1)) tk=temref(1)
-    if(tk < temref(4)) tk=temref(4)
-    do 11 i=2,4
-      if(tk.ge.temref(i)) go to 12
-    11 continue
-    12 lt1=i
-    lt2=i-1
-    do 13 i=2,nwlt
-      if(alam.le.wlt(i)) go to 14
-    13 continue
-    14 x1=log(wlt(i-1))
-    x2=log(wlt(i))
-    y1=tabret(i-1,lt1)
-    y2=tabret(i,lt1)
-    x=log(alam)
-    ylo=((x-x1)*(y2-y1)/(x2-x1))+y1
-    y1=tabret(i-1,lt2)
-    y2=tabret(i,lt2)
-    yhi=((x-x1)*(y2-y1)/(x2-x1))+y1
-    t1=temref(lt1)
-    t2=temref(lt2)
-    y=((tk-t1)*(yhi-ylo)/(t2-t1))+ylo
-    n_r=y
-    y1=log(abs(tabimt(i-1,lt1)))
-    y2=log(abs(tabimt(i,lt1)))
-    ylo=((x-x1)*(y2-y1)/(x2-x1))+y1
-    y1=log(abs(tabimt(i-1,lt2)))
-    y2=log(abs(tabimt(i,lt2)))
-    yhi=((x-x1)*(y2-y1)/(x2-x1))+y1
-    y=((tk-t1)*(yhi-ylo)/(t2-t1))+ylo
-    n_i=exp(y)
-
-  endif
-
-  end subroutine m_ice
-
-! ----------------------------------------------------------------------------
-! subroutine MIEINT
-! ----------------------------------------------------------------------------
-!
-!     General purpose Mie scattering routine for single particles
-!     Author: R Grainger 1990
-!     History:
-!     G Thomas, March 2005: Added calculation of Phase function and
-!     code to ensure correct calculation of backscatter coeficient
-!     Options/Extend_Source
-!
-      Subroutine MieInt(Dx, SCm, Inp, Dqv, Dqxt, Dqsc, Dbsc, Dg, Xs1, Xs2, DPh, Error)
-
-      Integer * 2  Imaxx
-      Parameter (Imaxx = 12000)
-      Real * 4     RIMax          ! largest real part of refractive index
-      Parameter (RIMax = 2.5)
-      Real * 4     IRIMax         ! largest imaginary part of refractive index
-      Parameter (IRIMax = -2)
-      Integer * 2  Itermax
-      Parameter (Itermax = 12000 * 2.5)
-                                ! must be large enough to cope with the
-                                ! largest possible nmx = x * abs(scm) + 15
-                                ! or nmx =  Dx + 4.05*Dx**(1./3.) + 2.0
-      Integer * 2  Imaxnp
-      Parameter (Imaxnp = 10000)  ! Change this as required
-!     INPUT
-      Real * 8     Dx
-      Complex * 16  SCm
-      Integer * 4  Inp
-      Real * 8     Dqv(Inp)
-!     OUTPUT
-      Complex * 16  Xs1(InP)
-      Complex * 16  Xs2(InP)
-      Real * 8     Dqxt
-      Real * 8     Dqsc
-      Real * 8     Dg
-      Real * 8     Dbsc
-      Real * 8     DPh(InP)
-      Integer * 4  Error
-!     LOCAL
-      Integer * 2  I
-      Integer * 2  NStop
-      Integer * 2  NmX
-      Integer * 4  N    ! N*N > 32767 ie N > 181
-      Integer * 4  Inp2
-      Real * 8     Chi,Chi0,Chi1
-      Real * 8     APsi,APsi0,APsi1
-      Real * 8     Pi0(Imaxnp)
-      Real * 8     Pi1(Imaxnp)
-      Real * 8     Taun(Imaxnp)
-      Real * 8     Psi,Psi0,Psi1
-      Complex * 8  Ir
-      Complex * 16 Cm
-      Complex * 16 A,ANM1,APB
-      Complex * 16 B,BNM1,AMB
-      Complex * 16 D(Itermax)
-      Complex * 16 Sp(Imaxnp)
-      Complex * 16 Sm(Imaxnp)
-      Complex * 16 Xi,Xi0,Xi1
-      Complex * 16 Y
-!     ACCELERATOR VARIABLES
-      Integer * 2  Tnp1
-      Integer * 2  Tnm1
-      Real * 8     Dn
-      Real * 8     Rnx
-      Real * 8     S(Imaxnp)
-      Real * 8     T(Imaxnp)
-      Real * 8     Turbo
-      Real * 8     A2
-      Complex * 16 A1
-      
-      If ((Dx.Gt.Imaxx) .Or. (InP.Gt.ImaxNP)) Then
-        Error = 1
-        Return
-      EndIf
-      Cm = SCm
-      Ir = 1 / Cm
-      Y =  Dx * Cm
-      If (Dx.Lt.0.02) Then
-         NStop = 2
-      Else
-         If (Dx.Le.8.0) Then
-            NStop = Dx + 4.00*Dx**(1./3.) + 2.0
-         Else
-            If (Dx.Lt. 4200.0) Then
-               NStop = Dx + 4.05*Dx**(1./3.) + 2.0
-            Else
-               NStop = Dx + 4.00*Dx**(1./3.) + 2.0
-            End If
-         End If
-      End If
-      NmX = Max(Real(NStop),Real(Abs(Y))) + 15.
-      If (Nmx .gt. Itermax) then
-          Error = 1
-          Return
-      End If
-      Inp2 = Inp+1
-      D(NmX) = Dcmplx(0,0)
-      Do N = Nmx-1,1,-1
-         A1 = (N+1) / Y
-         D(N) = A1 - 1/(A1+D(N+1))
-      End Do
-      Do I =1,Inp2
-         Sm(I) = Dcmplx(0,0)
-         Sp(I) = Dcmplx(0,0)
-         Pi0(I) = 0
-         Pi1(I) = 1
-      End Do
-      Psi0 = Cos(Dx)
-      Psi1 = Sin(Dx)
-      Chi0 =-Sin(Dx)
-      Chi1 = Cos(Dx)
-      APsi0 = Psi0
-      APsi1 = Psi1
-      Xi0 = Dcmplx(APsi0,Chi0)
-      Xi1 = Dcmplx(APsi1,Chi1)
-      Dg = 0
-      Dqsc = 0
-      Dqxt = 0
-      Tnp1 = 1
-      Do N = 1,Nstop
-         DN = N
-         Tnp1 = Tnp1 + 2
-         Tnm1 = Tnp1 - 2
-         A2 = Tnp1 / (DN*(DN+1D0))
-         Turbo = (DN+1D0) / DN
-         Rnx = DN/Dx
-         Psi = Dble(Tnm1)*Psi1/Dx - Psi0
-         APsi = Psi
-         Chi = Tnm1*Chi1/Dx       - Chi0
-         Xi = Dcmplx(APsi,Chi)
-         A = ((D(N)*Ir+Rnx)*APsi-APsi1) / ((D(N)*Ir+Rnx)*  Xi-  Xi1)
-         B = ((D(N)*Cm+Rnx)*APsi-APsi1) / ((D(N)*Cm+Rnx)*  Xi-  Xi1)
-         Dqxt = Tnp1 *      Dble(A + B)          + Dqxt
-         Dqsc = Tnp1 * (A*Conjg(A) + B*Conjg(B)) + Dqsc
-         If (N.Gt.1) then
-         Dg = Dg + (dN*dN - 1) * Dble(ANM1*Conjg(A) + BNM1 * Conjg(B)) / dN + TNM1 * Dble(ANM1*Conjg(BNM1)) / (dN*dN - dN)
-         End If
-         Anm1 = A
-         Bnm1 = B
-         APB = A2 * (A + B)
-         AMB = A2 * (A - B)
-         Do I = 1,Inp2
-            If (I.GT.Inp) Then
-               S(I) = -Pi1(I)
-            Else
-               S(I) = Dqv(I) * Pi1(I)
-            End If
-            T(I) = S(I) - Pi0(I)
-            Taun(I) = N*T(I) - Pi0(I)
-            Sp(I) = APB * (Pi1(I) + Taun(I)) + Sp(I)
-            Sm(I) = AMB * (Pi1(I) - Taun(I)) + Sm(I)
-            Pi0(I) = Pi1(I)
-            Pi1(I) = S(I) + T(I)*Turbo
-         End Do
-         Psi0 = Psi1
-         Psi1 = Psi
-         Apsi1 = Psi1
-         Chi0 = Chi1
-         Chi1 = Chi
-         Xi1 = Dcmplx(APsi1,Chi1)
-      End Do
-      If (Dg .GT.0) Dg = 2 * Dg / Dqsc
-      Dqsc =  2 * Dqsc / Dx**2
-      Dqxt =  2 * Dqxt / Dx**2
-      Do I = 1,Inp
-         Xs1(I) = (Sp(I)+Sm(I)) / 2
-         Xs2(I) = (Sp(I)-Sm(I)) / 2
-         Dph(I) = 2 * Dble(Xs1(I)*Conjg(Xs1(I)) + Xs2(I)*Conjg(Xs2(I))) / (Dx**2 * Dqsc)
-      End Do
-      Dbsc = 4 * Abs(( (Sp(Inp2)+Sm(Inp2))/2 )**2) / Dx**2
-      Error = 0
-      Return
-      End subroutine MieInt
-
-  end module optics_lib
Index: /LMDZ6/trunk/libf/phylmd/cosp/optics_lib.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cosp/optics_lib.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/cosp/optics_lib.f90	(revision 5268)
@@ -0,0 +1,751 @@
+! $Revision: 88 $, $Date: 2013-11-13 15:08:38 +0100 (mer. 13 nov. 2013) $
+! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/quickbeam/optics_lib.f90 $
+! OPTICS_LIB: Optical proecures for for F90
+! Compiled/Modified:
+!   07/01/06  John Haynes (haynes@atmos.colostate.edu)
+!
+! m_wat (subroutine)
+! m_ice (subroutine)
+! mie_int (subroutine)
+  
+  module optics_lib
+  implicit none
+
+  contains
+
+! ----------------------------------------------------------------------------
+! subroutine M_WAT
+! ----------------------------------------------------------------------------
+  subroutine m_wat(freq, tk, n_r, n_i)
+  implicit none
+!  
+! Purpose:
+!   compute complex index of refraction of liquid water
+!
+! Inputs:
+!   [freq]    frequency (GHz)
+!   [tk]       temperature (K)
+!
+! Outputs:
+!   [n_r]     real part index of refraction
+!   [n_i]     imaginary part index of refraction
+!
+! Reference:
+!   Based on the work of Ray (1972)
+!
+! Coded:
+!   03/22/05  John Haynes (haynes@atmos.colostate.edu)
+  
+! ----- INPUTS -----
+  real*8, intent(in) :: freq,tk
+  
+! ----- OUTPUTS -----
+  real*8, intent(out) :: n_r, n_i
+
+! ----- INTERNAL -----    
+  real*8 ld,es,ei,a,ls,sg,tm1,cos1,sin1
+  real*8 e_r,e_i
+  real*8 pi
+  real*8 tc
+  complex*16 e_comp, sq
+
+  tc = tk - 273.15
+
+  ld = 100.*2.99792458E8/(freq*1E9)
+  es = 78.54*(1-(4.579E-3*(tc-25.)+1.19E-5*(tc-25.)**2 &
+       -2.8E-8*(tc-25.)**3))
+  ei = 5.27137+0.021647*tc-0.00131198*tc**2
+  a = -(16.8129/(tc+273.))+0.0609265
+  ls = 0.00033836*exp(2513.98/(tc+273.))
+  sg = 12.5664E8
+
+  tm1 = (ls/ld)**(1-a)
+  pi = acos(-1.D0)
+  cos1 = cos(0.5*a*pi)
+  sin1 = sin(0.5*a*pi)
+
+  e_r = ei + (((es-ei)*(1.+tm1*sin1))/(1.+2*tm1*sin1+tm1**2))
+  e_i = (((es-ei)*tm1*cos1)/(1.+2*tm1*sin1+tm1**2)) &
+        +((sg*ld)/1.885E11)
+
+  e_comp = dcmplx(e_r,e_i)
+  sq = sqrt(e_comp)
+  
+  n_r = real(sq)
+  n_i = aimag(sq)      
+  
+  return
+  end subroutine m_wat
+
+! ----------------------------------------------------------------------------
+! subroutine M_ICE
+! ----------------------------------------------------------------------------
+  subroutine m_ice(freq,t,n_r,n_i)
+  implicit none
+!
+! Purpose:
+!   compute complex index of refraction of ice
+!
+! Inputs:
+!   [freq]    frequency (GHz)
+!   [t]       temperature (K)
+!
+! Outputs:
+!   [n_r]     real part index of refraction
+!   [n_i]     imaginary part index of refraction
+!
+! Reference:
+!    Fortran 90 port from IDL of REFICE by Stephen G. Warren
+!
+! Modified:
+!   05/31/05  John Haynes (haynes@atmos.colostate.edu)
+
+! ----- INPUTS -----
+  real*8, intent(in) :: freq, t
+  
+! ----- OUTPUTS -----  
+  real*8, intent(out) :: n_r,n_i
+
+! Parameters:
+  integer*2 :: i,lt1,lt2,nwl,nwlt
+  parameter(nwl=468,nwlt=62)
+
+  real*8 :: alam,cutice,pi,t1,t2,wlmax,wlmin, &
+            x,x1,x2,y,y1,y2,ylo,yhi,tk
+
+  real*8 :: &
+       tabim(nwl),tabimt(nwlt,4),tabre(nwl),tabret(nwlt,4),temref(4), &
+       wl(nwl),wlt(nwlt)
+
+! Defines wavelength dependent complex index of refraction for ice.
+! Allowable wavelength range extends from 0.045 microns to 8.6 meter
+! temperature dependence only considered beyond 167 microns.
+! 
+! interpolation is done     n_r  vs. log(xlam)
+!                           n_r  vs.        t
+!                       log(n_i) vs. log(xlam)
+!                       log(n_i) vs.        t
+!
+! Stephen G. Warren - 1983
+! Dept. of Atmospheric Sciences
+! University of Washington
+! Seattle, Wa  98195
+!
+! Based on
+!
+!    Warren,S.G.,1984.
+!    Optical constants of ice from the ultraviolet to the microwave.
+!    Applied Optics,23,1206-1225
+!
+! Reference temperatures are -1.0,-5.0,-20.0, and -60.0 deg C
+ 
+      data temref/272.16,268.16,253.16,213.16/
+ 
+      data wlmin,wlmax/0.045,8.6e6/
+      data cutice/167.0/
+ 
+      data (wl(i),i=1,114)/ &
+      0.4430e-01,0.4510e-01,0.4590e-01,0.4680e-01,0.4770e-01,0.4860e-01, &
+      0.4960e-01,0.5060e-01,0.5170e-01,0.5280e-01,0.5390e-01,0.5510e-01, &
+      0.5640e-01,0.5770e-01,0.5900e-01,0.6050e-01,0.6200e-01,0.6360e-01, &
+      0.6530e-01,0.6700e-01,0.6890e-01,0.7080e-01,0.7290e-01,0.7380e-01, &
+      0.7510e-01,0.7750e-01,0.8000e-01,0.8270e-01,0.8550e-01,0.8860e-01, &
+      0.9180e-01,0.9300e-01,0.9540e-01,0.9920e-01,0.1033e+00,0.1078e+00, &
+      0.1100e+00,0.1127e+00,0.1140e+00,0.1181e+00,0.1210e+00,0.1240e+00, &
+      0.1272e+00,0.1295e+00,0.1305e+00,0.1319e+00,0.1333e+00,0.1348e+00, &
+      0.1362e+00,0.1370e+00,0.1378e+00,0.1387e+00,0.1393e+00,0.1409e+00, &
+      0.1425e+00,0.1435e+00,0.1442e+00,0.1450e+00,0.1459e+00,0.1468e+00, &
+      0.1476e+00,0.1480e+00,0.1485e+00,0.1494e+00,0.1512e+00,0.1531e+00, &
+      0.1540e+00,0.1550e+00,0.1569e+00,0.1580e+00,0.1589e+00,0.1610e+00, &
+      0.1625e+00,0.1648e+00,0.1669e+00,0.1692e+00,0.1713e+00,0.1737e+00, &
+      0.1757e+00,0.1779e+00,0.1802e+00,0.1809e+00,0.1821e+00,0.1833e+00, &
+      0.1843e+00,0.1850e+00,0.1860e+00,0.1870e+00,0.1880e+00,0.1890e+00, &
+      0.1900e+00,0.1910e+00,0.1930e+00,0.1950e+00,0.2100e+00,0.2500e+00, &
+      0.3000e+00,0.3500e+00,0.4000e+00,0.4100e+00,0.4200e+00,0.4300e+00, &
+      0.4400e+00,0.4500e+00,0.4600e+00,0.4700e+00,0.4800e+00,0.4900e+00, &
+      0.5000e+00,0.5100e+00,0.5200e+00,0.5300e+00,0.5400e+00,0.5500e+00/
+      data (wl(i),i=115,228)/ &
+      0.5600e+00,0.5700e+00,0.5800e+00,0.5900e+00,0.6000e+00,0.6100e+00, &
+      0.6200e+00,0.6300e+00,0.6400e+00,0.6500e+00,0.6600e+00,0.6700e+00, &
+      0.6800e+00,0.6900e+00,0.7000e+00,0.7100e+00,0.7200e+00,0.7300e+00, &
+      0.7400e+00,0.7500e+00,0.7600e+00,0.7700e+00,0.7800e+00,0.7900e+00, &
+      0.8000e+00,0.8100e+00,0.8200e+00,0.8300e+00,0.8400e+00,0.8500e+00, &
+      0.8600e+00,0.8700e+00,0.8800e+00,0.8900e+00,0.9000e+00,0.9100e+00, &
+      0.9200e+00,0.9300e+00,0.9400e+00,0.9500e+00,0.9600e+00,0.9700e+00, &
+      0.9800e+00,0.9900e+00,0.1000e+01,0.1010e+01,0.1020e+01,0.1030e+01, &
+      0.1040e+01,0.1050e+01,0.1060e+01,0.1070e+01,0.1080e+01,0.1090e+01, &
+      0.1100e+01,0.1110e+01,0.1120e+01,0.1130e+01,0.1140e+01,0.1150e+01, &
+      0.1160e+01,0.1170e+01,0.1180e+01,0.1190e+01,0.1200e+01,0.1210e+01, &
+      0.1220e+01,0.1230e+01,0.1240e+01,0.1250e+01,0.1260e+01,0.1270e+01, &
+      0.1280e+01,0.1290e+01,0.1300e+01,0.1310e+01,0.1320e+01,0.1330e+01, &
+      0.1340e+01,0.1350e+01,0.1360e+01,0.1370e+01,0.1380e+01,0.1390e+01, &
+      0.1400e+01,0.1410e+01,0.1420e+01,0.1430e+01,0.1440e+01,0.1449e+01, &
+      0.1460e+01,0.1471e+01,0.1481e+01,0.1493e+01,0.1504e+01,0.1515e+01, &
+      0.1527e+01,0.1538e+01,0.1563e+01,0.1587e+01,0.1613e+01,0.1650e+01, &
+      0.1680e+01,0.1700e+01,0.1730e+01,0.1760e+01,0.1800e+01,0.1830e+01, &
+      0.1840e+01,0.1850e+01,0.1855e+01,0.1860e+01,0.1870e+01,0.1890e+01/
+      data (wl(i),i=229,342)/ &
+      0.1905e+01,0.1923e+01,0.1942e+01,0.1961e+01,0.1980e+01,0.2000e+01, &
+      0.2020e+01,0.2041e+01,0.2062e+01,0.2083e+01,0.2105e+01,0.2130e+01, &
+      0.2150e+01,0.2170e+01,0.2190e+01,0.2220e+01,0.2240e+01,0.2245e+01, &
+      0.2250e+01,0.2260e+01,0.2270e+01,0.2290e+01,0.2310e+01,0.2330e+01, &
+      0.2350e+01,0.2370e+01,0.2390e+01,0.2410e+01,0.2430e+01,0.2460e+01, &
+      0.2500e+01,0.2520e+01,0.2550e+01,0.2565e+01,0.2580e+01,0.2590e+01, &
+      0.2600e+01,0.2620e+01,0.2675e+01,0.2725e+01,0.2778e+01,0.2817e+01, &
+      0.2833e+01,0.2849e+01,0.2865e+01,0.2882e+01,0.2899e+01,0.2915e+01, &
+      0.2933e+01,0.2950e+01,0.2967e+01,0.2985e+01,0.3003e+01,0.3021e+01, &
+      0.3040e+01,0.3058e+01,0.3077e+01,0.3096e+01,0.3115e+01,0.3135e+01, &
+      0.3155e+01,0.3175e+01,0.3195e+01,0.3215e+01,0.3236e+01,0.3257e+01, &
+      0.3279e+01,0.3300e+01,0.3322e+01,0.3345e+01,0.3367e+01,0.3390e+01, &
+      0.3413e+01,0.3436e+01,0.3460e+01,0.3484e+01,0.3509e+01,0.3534e+01, &
+      0.3559e+01,0.3624e+01,0.3732e+01,0.3775e+01,0.3847e+01,0.3969e+01, &
+      0.4099e+01,0.4239e+01,0.4348e+01,0.4387e+01,0.4444e+01,0.4505e+01, &
+      0.4547e+01,0.4560e+01,0.4580e+01,0.4719e+01,0.4904e+01,0.5000e+01, &
+      0.5100e+01,0.5200e+01,0.5263e+01,0.5400e+01,0.5556e+01,0.5714e+01, &
+      0.5747e+01,0.5780e+01,0.5814e+01,0.5848e+01,0.5882e+01,0.6061e+01, &
+      0.6135e+01,0.6250e+01,0.6289e+01,0.6329e+01,0.6369e+01,0.6410e+01/
+      data (wl(i),i=343,456)/ &
+      0.6452e+01,0.6494e+01,0.6579e+01,0.6667e+01,0.6757e+01,0.6897e+01, &
+      0.7042e+01,0.7143e+01,0.7246e+01,0.7353e+01,0.7463e+01,0.7576e+01, &
+      0.7692e+01,0.7812e+01,0.7937e+01,0.8065e+01,0.8197e+01,0.8333e+01, &
+      0.8475e+01,0.8696e+01,0.8929e+01,0.9091e+01,0.9259e+01,0.9524e+01, &
+      0.9804e+01,0.1000e+02,0.1020e+02,0.1031e+02,0.1042e+02,0.1053e+02, &
+      0.1064e+02,0.1075e+02,0.1087e+02,0.1100e+02,0.1111e+02,0.1136e+02, &
+      0.1163e+02,0.1190e+02,0.1220e+02,0.1250e+02,0.1282e+02,0.1299e+02, &
+      0.1316e+02,0.1333e+02,0.1351e+02,0.1370e+02,0.1389e+02,0.1408e+02, &
+      0.1429e+02,0.1471e+02,0.1515e+02,0.1538e+02,0.1563e+02,0.1613e+02, &
+      0.1639e+02,0.1667e+02,0.1695e+02,0.1724e+02,0.1818e+02,0.1887e+02, &
+      0.1923e+02,0.1961e+02,0.2000e+02,0.2041e+02,0.2083e+02,0.2222e+02, &
+      0.2260e+02,0.2305e+02,0.2360e+02,0.2460e+02,0.2500e+02,0.2600e+02, &
+      0.2857e+02,0.3100e+02,0.3333e+02,0.3448e+02,0.3564e+02,0.3700e+02, &
+      0.3824e+02,0.3960e+02,0.4114e+02,0.4276e+02,0.4358e+02,0.4458e+02, &
+      0.4550e+02,0.4615e+02,0.4671e+02,0.4736e+02,0.4800e+02,0.4878e+02, &
+      0.5003e+02,0.5128e+02,0.5275e+02,0.5350e+02,0.5424e+02,0.5500e+02, &
+      0.5574e+02,0.5640e+02,0.5700e+02,0.5746e+02,0.5840e+02,0.5929e+02, &
+      0.6000e+02,0.6100e+02,0.6125e+02,0.6250e+02,0.6378e+02,0.6467e+02, &
+      0.6558e+02,0.6655e+02,0.6760e+02,0.6900e+02,0.7053e+02,0.7300e+02/
+      data (wl(i),i=457,468)/ &
+      0.7500e+02,0.7629e+02,0.8000e+02,0.8297e+02,0.8500e+02,0.8680e+02, &
+      0.9080e+02,0.9517e+02,0.1000e+03,0.1200e+03,0.1500e+03,0.1670e+03/
+      data  wlt/ &
+                                       0.1670e+03,0.1778e+03,0.1884e+03, &
+      0.1995e+03,0.2113e+03,0.2239e+03,0.2371e+03,0.2512e+03,0.2661e+03, &
+      0.2818e+03,0.2985e+03,0.3162e+03,0.3548e+03,0.3981e+03,0.4467e+03, &
+      0.5012e+03,0.5623e+03,0.6310e+03,0.7943e+03,0.1000e+04,0.1259e+04, &
+      0.2500e+04,0.5000e+04,0.1000e+05,0.2000e+05,0.3200e+05,0.3500e+05, &
+      0.4000e+05,0.4500e+05,0.5000e+05,0.6000e+05,0.7000e+05,0.9000e+05, &
+      0.1110e+06,0.1200e+06,0.1300e+06,0.1400e+06,0.1500e+06,0.1600e+06, &
+      0.1700e+06,0.1800e+06,0.2000e+06,0.2500e+06,0.2900e+06,0.3200e+06, &
+      0.3500e+06,0.3800e+06,0.4000e+06,0.4500e+06,0.5000e+06,0.6000e+06, &
+      0.6400e+06,0.6800e+06,0.7200e+06,0.7600e+06,0.8000e+06,0.8400e+06, &
+      0.9000e+06,0.1000e+07,0.2000e+07,0.5000e+07,0.8600e+07/
+      data (tabre(i),i=1,114)/ &
+         0.83441,   0.83676,   0.83729,   0.83771,   0.83827,   0.84038, &
+         0.84719,   0.85522,   0.86047,   0.86248,   0.86157,   0.86093, &
+         0.86419,   0.86916,   0.87764,   0.89296,   0.91041,   0.93089, &
+         0.95373,   0.98188,   1.02334,   1.06735,   1.11197,   1.13134, &
+         1.15747,   1.20045,   1.23840,   1.27325,   1.32157,   1.38958, &
+         1.41644,   1.40906,   1.40063,   1.40169,   1.40934,   1.40221, &
+         1.39240,   1.38424,   1.38075,   1.38186,   1.39634,   1.40918, &
+         1.40256,   1.38013,   1.36303,   1.34144,   1.32377,   1.30605, &
+         1.29054,   1.28890,   1.28931,   1.30190,   1.32025,   1.36302, &
+         1.41872,   1.45834,   1.49028,   1.52128,   1.55376,   1.57782, &
+         1.59636,   1.60652,   1.61172,   1.61919,   1.62522,   1.63404, &
+         1.63689,   1.63833,   1.63720,   1.63233,   1.62222,   1.58269, &
+         1.55635,   1.52453,   1.50320,   1.48498,   1.47226,   1.45991, &
+         1.45115,   1.44272,   1.43498,   1.43280,   1.42924,   1.42602, &
+         1.42323,   1.42143,   1.41897,   1.41660,   1.41434,   1.41216, &
+         1.41006,   1.40805,   1.40423,   1.40067,   1.38004,   1.35085, &
+         1.33394,   1.32492,   1.31940,   1.31854,   1.31775,   1.31702, &
+         1.31633,   1.31569,   1.31509,   1.31452,   1.31399,   1.31349, &
+         1.31302,   1.31257,   1.31215,   1.31175,   1.31136,   1.31099/
+      data (tabre(i),i=115,228)/ &
+         1.31064,   1.31031,   1.30999,   1.30968,   1.30938,   1.30909, &
+         1.30882,   1.30855,   1.30829,   1.30804,   1.30780,   1.30756, &
+         1.30733,   1.30710,   1.30688,   1.30667,   1.30646,   1.30625, &
+         1.30605,   1.30585,   1.30566,   1.30547,   1.30528,   1.30509, &
+         1.30491,   1.30473,   1.30455,   1.30437,   1.30419,   1.30402, &
+         1.30385,   1.30367,   1.30350,   1.30333,   1.30316,   1.30299, &
+         1.30283,   1.30266,   1.30249,   1.30232,   1.30216,   1.30199, &
+         1.30182,   1.30166,   1.30149,   1.30132,   1.30116,   1.30099, &
+         1.30082,   1.30065,   1.30048,   1.30031,   1.30014,   1.29997, &
+         1.29979,   1.29962,   1.29945,   1.29927,   1.29909,   1.29891, &
+         1.29873,   1.29855,   1.29837,   1.29818,   1.29800,   1.29781, &
+         1.29762,   1.29743,   1.29724,   1.29705,   1.29686,   1.29666, &
+         1.29646,   1.29626,   1.29605,   1.29584,   1.29563,   1.29542, &
+         1.29521,   1.29499,   1.29476,   1.29453,   1.29430,   1.29406, &
+         1.29381,   1.29355,   1.29327,   1.29299,   1.29272,   1.29252, &
+         1.29228,   1.29205,   1.29186,   1.29167,   1.29150,   1.29130, &
+         1.29106,   1.29083,   1.29025,   1.28962,   1.28891,   1.28784, &
+         1.28689,   1.28623,   1.28521,   1.28413,   1.28261,   1.28137, &
+         1.28093,   1.28047,   1.28022,   1.27998,   1.27948,   1.27849/
+      data (tabre(i),i=229,342)/ &
+         1.27774,   1.27691,   1.27610,   1.27535,   1.27471,   1.27404, &
+         1.27329,   1.27240,   1.27139,   1.27029,   1.26901,   1.26736, &
+         1.26591,   1.26441,   1.26284,   1.26036,   1.25860,   1.25815, &
+         1.25768,   1.25675,   1.25579,   1.25383,   1.25179,   1.24967, &
+         1.24745,   1.24512,   1.24266,   1.24004,   1.23725,   1.23270, &
+         1.22583,   1.22198,   1.21548,   1.21184,   1.20790,   1.20507, &
+         1.20209,   1.19566,   1.17411,   1.14734,   1.10766,   1.06739, &
+         1.04762,   1.02650,   1.00357,   0.98197,   0.96503,   0.95962, &
+         0.97269,   0.99172,   1.00668,   1.02186,   1.04270,   1.07597, &
+         1.12954,   1.21267,   1.32509,   1.42599,   1.49656,   1.55095, &
+         1.59988,   1.63631,   1.65024,   1.64278,   1.62691,   1.61284, &
+         1.59245,   1.57329,   1.55770,   1.54129,   1.52654,   1.51139, &
+         1.49725,   1.48453,   1.47209,   1.46125,   1.45132,   1.44215, &
+         1.43366,   1.41553,   1.39417,   1.38732,   1.37735,   1.36448, &
+         1.35414,   1.34456,   1.33882,   1.33807,   1.33847,   1.34053, &
+         1.34287,   1.34418,   1.34634,   1.34422,   1.33453,   1.32897, &
+         1.32333,   1.31800,   1.31432,   1.30623,   1.29722,   1.28898, &
+         1.28730,   1.28603,   1.28509,   1.28535,   1.28813,   1.30156, &
+         1.30901,   1.31720,   1.31893,   1.32039,   1.32201,   1.32239/
+      data (tabre(i),i=343,456)/ &
+         1.32149,   1.32036,   1.31814,   1.31705,   1.31807,   1.31953, &
+         1.31933,   1.31896,   1.31909,   1.31796,   1.31631,   1.31542, &
+         1.31540,   1.31552,   1.31455,   1.31193,   1.30677,   1.29934, &
+         1.29253,   1.28389,   1.27401,   1.26724,   1.25990,   1.24510, &
+         1.22241,   1.19913,   1.17150,   1.15528,   1.13700,   1.11808, &
+         1.10134,   1.09083,   1.08734,   1.09254,   1.10654,   1.14779, &
+         1.20202,   1.25825,   1.32305,   1.38574,   1.44478,   1.47170, &
+         1.49619,   1.51652,   1.53328,   1.54900,   1.56276,   1.57317, &
+         1.58028,   1.57918,   1.56672,   1.55869,   1.55081,   1.53807, &
+         1.53296,   1.53220,   1.53340,   1.53289,   1.51705,   1.50097, &
+         1.49681,   1.49928,   1.50153,   1.49856,   1.49053,   1.46070, &
+         1.45182,   1.44223,   1.43158,   1.41385,   1.40676,   1.38955, &
+         1.34894,   1.31039,   1.26420,   1.23656,   1.21663,   1.20233, &
+         1.19640,   1.19969,   1.20860,   1.22173,   1.24166,   1.28175, &
+         1.32784,   1.38657,   1.46486,   1.55323,   1.60379,   1.61877, &
+         1.62963,   1.65712,   1.69810,   1.72065,   1.74865,   1.76736, &
+         1.76476,   1.75011,   1.72327,   1.68490,   1.62398,   1.59596, &
+         1.58514,   1.59917,   1.61405,   1.66625,   1.70663,   1.73713, &
+         1.76860,   1.80343,   1.83296,   1.85682,   1.87411,   1.89110/
+      data (tabre(i),i=457,468)/ &
+         1.89918,   1.90432,   1.90329,   1.88744,   1.87499,   1.86702, &
+         1.85361,   1.84250,   1.83225,   1.81914,   1.82268,   1.82961/
+      data (tabret(i,1),i=1,nwlt)/ &
+                                          1.82961,   1.83258,   1.83149, &
+         1.82748,   1.82224,   1.81718,   1.81204,   1.80704,   1.80250, &
+         1.79834,   1.79482,   1.79214,   1.78843,   1.78601,   1.78434, &
+         1.78322,   1.78248,   1.78201,   1.78170,   1.78160,   1.78190, &
+         1.78300,   1.78430,   1.78520,   1.78620,   1.78660,   1.78680, &
+         1.78690,   1.78700,   1.78700,   1.78710,   1.78710,   1.78720, &
+         1.78720,   1.78720,   1.78720,   1.78720,   1.78720,   1.78720, &
+         1.78720,   1.78720,   1.78720,   1.78720,   1.78720,   1.78720, &
+         1.78720,   1.78720,   1.78720,   1.78720,   1.78720,   1.78720, &
+         1.78720,   1.78720,   1.78720,   1.78720,   1.78720,   1.78720, &
+         1.78720,   1.78720,   1.78720,   1.78720,   1.78800/
+      data (tabret(i,2),i=1,nwlt)/ &
+                               1.82961,   1.83258,   1.83149,   1.82748, &
+         1.82224,   1.81718,   1.81204,   1.80704,   1.80250,   1.79834, &
+         1.79482,   1.79214,   1.78843,   1.78601,   1.78434,   1.78322, &
+         1.78248,   1.78201,   1.78170,   1.78160,   1.78190,   1.78300, &
+         1.78430,   1.78520,   1.78610,   1.78630,   1.78640,   1.78650, &
+         1.78650,   1.78650,   1.78650,   1.78650,   1.78650,   1.78650, &
+         1.78650,   1.78650,   1.78650,   1.78650,   1.78650,   1.78650, &
+         1.78650,   1.78650,   1.78650,   1.78650,   1.78650,   1.78650, &
+         1.78650,   1.78650,   1.78650,   1.78650,   1.78650,   1.78650, &
+         1.78650,   1.78650,   1.78650,   1.78650,   1.78650,   1.78650, &
+         1.78650,   1.78650,   1.78650,   1.78720/
+      data(tabret(i,3),i=1,nwlt)/ &
+                    1.82961,   1.83258,   1.83149,   1.82748,   1.82224, &
+         1.81718,   1.81204,   1.80704,   1.80250,   1.79834,   1.79482, &
+         1.79214,   1.78843,   1.78601,   1.78434,   1.78322,   1.78248, &
+         1.78201,   1.78160,   1.78140,   1.78160,   1.78220,   1.78310, &
+         1.78380,   1.78390,   1.78400,   1.78400,   1.78400,   1.78400, &
+         1.78400,   1.78390,   1.78380,   1.78370,   1.78370,   1.78370, &
+         1.78370,   1.78370,   1.78370,   1.78370,   1.78370,   1.78370, &
+         1.78370,   1.78370,   1.78370,   1.78370,   1.78370,   1.78370, &
+         1.78370,   1.78370,   1.78370,   1.78370,   1.78370,   1.78370, &
+         1.78370,   1.78370,   1.78370,   1.78370,   1.78370,   1.78370, &
+         1.78370,   1.78400,   1.78450/
+      data (tabret(i,4),i=1,nwlt)/ &
+         1.82961,   1.83258,   1.83149,   1.82748,   1.82224,   1.81718, &
+         1.81204,   1.80704,   1.80250,   1.79834,   1.79482,   1.79214, &
+         1.78843,   1.78601,   1.78434,   1.78322,   1.78248,   1.78201, &
+         1.78150,   1.78070,   1.78010,   1.77890,   1.77790,   1.77730, &
+         1.77720,   1.77720,   1.77720,   1.77720,   1.77720,   1.77720, &
+         1.77720,   1.77720,   1.77720,   1.77720,   1.77720,   1.77720, &
+         1.77720,   1.77720,   1.77720,   1.77720,   1.77720,   1.77720, &
+         1.77720,   1.77720,   1.77720,   1.77720,   1.77720,   1.77720, &
+         1.77720,   1.77720,   1.77720,   1.77720,   1.77720,   1.77720, &
+         1.77720,   1.77720,   1.77720,   1.77720,   1.77720,   1.77720, &
+         1.77720,   1.77800/
+      data(tabim(i),i=1,114)/ &
+      0.1640e+00,0.1730e+00,0.1830e+00,0.1950e+00,0.2080e+00,0.2230e+00, &
+      0.2400e+00,0.2500e+00,0.2590e+00,0.2680e+00,0.2790e+00,0.2970e+00, &
+      0.3190e+00,0.3400e+00,0.3660e+00,0.3920e+00,0.4160e+00,0.4400e+00, &
+      0.4640e+00,0.4920e+00,0.5170e+00,0.5280e+00,0.5330e+00,0.5340e+00, &
+      0.5310e+00,0.5240e+00,0.5100e+00,0.5000e+00,0.4990e+00,0.4680e+00, &
+      0.3800e+00,0.3600e+00,0.3390e+00,0.3180e+00,0.2910e+00,0.2510e+00, &
+      0.2440e+00,0.2390e+00,0.2390e+00,0.2440e+00,0.2470e+00,0.2240e+00, &
+      0.1950e+00,0.1740e+00,0.1720e+00,0.1800e+00,0.1940e+00,0.2130e+00, &
+      0.2430e+00,0.2710e+00,0.2890e+00,0.3340e+00,0.3440e+00,0.3820e+00, &
+      0.4010e+00,0.4065e+00,0.4050e+00,0.3890e+00,0.3770e+00,0.3450e+00, &
+      0.3320e+00,0.3150e+00,0.2980e+00,0.2740e+00,0.2280e+00,0.1980e+00, &
+      0.1720e+00,0.1560e+00,0.1100e+00,0.8300e-01,0.5800e-01,0.2200e-01, &
+      0.1000e-01,0.3000e-02,0.1000e-02,0.3000e-03,0.1000e-03,0.3000e-04, &
+      0.1000e-04,0.3000e-05,0.1000e-05,0.7000e-06,0.4000e-06,0.2000e-06, &
+      0.1000e-06,0.6377e-07,0.3750e-07,0.2800e-07,0.2400e-07,0.2200e-07, &
+      0.1900e-07,0.1750e-07,0.1640e-07,0.1590e-07,0.1325e-07,0.8623e-08, &
+      0.5504e-08,0.3765e-08,0.2710e-08,0.2510e-08,0.2260e-08,0.2080e-08, &
+      0.1910e-08,0.1540e-08,0.1530e-08,0.1550e-08,0.1640e-08,0.1780e-08, &
+      0.1910e-08,0.2140e-08,0.2260e-08,0.2540e-08,0.2930e-08,0.3110e-08/
+      data(tabim(i),i=115,228)/ &
+      0.3290e-08,0.3520e-08,0.4040e-08,0.4880e-08,0.5730e-08,0.6890e-08, &
+      0.8580e-08,0.1040e-07,0.1220e-07,0.1430e-07,0.1660e-07,0.1890e-07, &
+      0.2090e-07,0.2400e-07,0.2900e-07,0.3440e-07,0.4030e-07,0.4300e-07, &
+      0.4920e-07,0.5870e-07,0.7080e-07,0.8580e-07,0.1020e-06,0.1180e-06, &
+      0.1340e-06,0.1400e-06,0.1430e-06,0.1450e-06,0.1510e-06,0.1830e-06, &
+      0.2150e-06,0.2650e-06,0.3350e-06,0.3920e-06,0.4200e-06,0.4440e-06, &
+      0.4740e-06,0.5110e-06,0.5530e-06,0.6020e-06,0.7550e-06,0.9260e-06, &
+      0.1120e-05,0.1330e-05,0.1620e-05,0.2000e-05,0.2250e-05,0.2330e-05, &
+      0.2330e-05,0.2170e-05,0.1960e-05,0.1810e-05,0.1740e-05,0.1730e-05, &
+      0.1700e-05,0.1760e-05,0.1820e-05,0.2040e-05,0.2250e-05,0.2290e-05, &
+      0.3040e-05,0.3840e-05,0.4770e-05,0.5760e-05,0.6710e-05,0.8660e-05, &
+      0.1020e-04,0.1130e-04,0.1220e-04,0.1290e-04,0.1320e-04,0.1350e-04, &
+      0.1330e-04,0.1320e-04,0.1320e-04,0.1310e-04,0.1320e-04,0.1320e-04, &
+      0.1340e-04,0.1390e-04,0.1420e-04,0.1480e-04,0.1580e-04,0.1740e-04, &
+      0.1980e-04,0.2500e-04,0.5400e-04,0.1040e-03,0.2030e-03,0.2708e-03, &
+      0.3511e-03,0.4299e-03,0.5181e-03,0.5855e-03,0.5899e-03,0.5635e-03, &
+      0.5480e-03,0.5266e-03,0.4394e-03,0.3701e-03,0.3372e-03,0.2410e-03, &
+      0.1890e-03,0.1660e-03,0.1450e-03,0.1280e-03,0.1030e-03,0.8600e-04, &
+      0.8220e-04,0.8030e-04,0.8500e-04,0.9900e-04,0.1500e-03,0.2950e-03/
+      data(tabim(i),i=229,342)/ &
+      0.4687e-03,0.7615e-03,0.1010e-02,0.1313e-02,0.1539e-02,0.1588e-02, &
+      0.1540e-02,0.1412e-02,0.1244e-02,0.1068e-02,0.8414e-03,0.5650e-03, &
+      0.4320e-03,0.3500e-03,0.2870e-03,0.2210e-03,0.2030e-03,0.2010e-03, &
+      0.2030e-03,0.2140e-03,0.2320e-03,0.2890e-03,0.3810e-03,0.4620e-03, &
+      0.5480e-03,0.6180e-03,0.6800e-03,0.7300e-03,0.7820e-03,0.8480e-03, &
+      0.9250e-03,0.9200e-03,0.8920e-03,0.8700e-03,0.8900e-03,0.9300e-03, &
+      0.1010e-02,0.1350e-02,0.3420e-02,0.7920e-02,0.2000e-01,0.3800e-01, &
+      0.5200e-01,0.6800e-01,0.9230e-01,0.1270e+00,0.1690e+00,0.2210e+00, &
+      0.2760e+00,0.3120e+00,0.3470e+00,0.3880e+00,0.4380e+00,0.4930e+00, &
+      0.5540e+00,0.6120e+00,0.6250e+00,0.5930e+00,0.5390e+00,0.4910e+00, &
+      0.4380e+00,0.3720e+00,0.3000e+00,0.2380e+00,0.1930e+00,0.1580e+00, &
+      0.1210e+00,0.1030e+00,0.8360e-01,0.6680e-01,0.5400e-01,0.4220e-01, &
+      0.3420e-01,0.2740e-01,0.2200e-01,0.1860e-01,0.1520e-01,0.1260e-01, &
+      0.1060e-01,0.8020e-02,0.6850e-02,0.6600e-02,0.6960e-02,0.9160e-02, &
+      0.1110e-01,0.1450e-01,0.2000e-01,0.2300e-01,0.2600e-01,0.2900e-01, &
+      0.2930e-01,0.3000e-01,0.2850e-01,0.1730e-01,0.1290e-01,0.1200e-01, &
+      0.1250e-01,0.1340e-01,0.1400e-01,0.1750e-01,0.2400e-01,0.3500e-01, &
+      0.3800e-01,0.4200e-01,0.4600e-01,0.5200e-01,0.5700e-01,0.6900e-01, &
+      0.7000e-01,0.6700e-01,0.6500e-01,0.6400e-01,0.6200e-01,0.5900e-01/
+      data(tabim(i),i=343,456)/ &
+      0.5700e-01,0.5600e-01,0.5500e-01,0.5700e-01,0.5800e-01,0.5700e-01, &
+      0.5500e-01,0.5500e-01,0.5400e-01,0.5200e-01,0.5200e-01,0.5200e-01, &
+      0.5200e-01,0.5000e-01,0.4700e-01,0.4300e-01,0.3900e-01,0.3700e-01, &
+      0.3900e-01,0.4000e-01,0.4200e-01,0.4400e-01,0.4500e-01,0.4600e-01, &
+      0.4700e-01,0.5100e-01,0.6500e-01,0.7500e-01,0.8800e-01,0.1080e+00, &
+      0.1340e+00,0.1680e+00,0.2040e+00,0.2480e+00,0.2800e+00,0.3410e+00, &
+      0.3790e+00,0.4090e+00,0.4220e+00,0.4220e+00,0.4030e+00,0.3890e+00, &
+      0.3740e+00,0.3540e+00,0.3350e+00,0.3150e+00,0.2940e+00,0.2710e+00, &
+      0.2460e+00,0.1980e+00,0.1640e+00,0.1520e+00,0.1420e+00,0.1280e+00, &
+      0.1250e+00,0.1230e+00,0.1160e+00,0.1070e+00,0.7900e-01,0.7200e-01, &
+      0.7600e-01,0.7500e-01,0.6700e-01,0.5500e-01,0.4500e-01,0.2900e-01, &
+      0.2750e-01,0.2700e-01,0.2730e-01,0.2890e-01,0.3000e-01,0.3400e-01, &
+      0.5300e-01,0.7550e-01,0.1060e+00,0.1350e+00,0.1761e+00,0.2229e+00, &
+      0.2746e+00,0.3280e+00,0.3906e+00,0.4642e+00,0.5247e+00,0.5731e+00, &
+      0.6362e+00,0.6839e+00,0.7091e+00,0.6790e+00,0.6250e+00,0.5654e+00, &
+      0.5433e+00,0.5292e+00,0.5070e+00,0.4883e+00,0.4707e+00,0.4203e+00, &
+      0.3771e+00,0.3376e+00,0.3056e+00,0.2835e+00,0.3170e+00,0.3517e+00, &
+      0.3902e+00,0.4509e+00,0.4671e+00,0.4779e+00,0.4890e+00,0.4899e+00, &
+      0.4873e+00,0.4766e+00,0.4508e+00,0.4193e+00,0.3880e+00,0.3433e+00/
+      data(tabim(i),i=457,468)/ &
+      0.3118e+00,0.2935e+00,0.2350e+00,0.1981e+00,0.1865e+00,0.1771e+00, &
+      0.1620e+00,0.1490e+00,0.1390e+00,0.1200e+00,0.9620e-01,0.8300e-01/
+      data(tabimt(i,1),i=1,nwlt)/ &
+                                       0.8300e-01,0.6900e-01,0.5700e-01, &
+      0.4560e-01,0.3790e-01,0.3140e-01,0.2620e-01,0.2240e-01,0.1960e-01, &
+      0.1760e-01,0.1665e-01,0.1620e-01,0.1550e-01,0.1470e-01,0.1390e-01, &
+      0.1320e-01,0.1250e-01,0.1180e-01,0.1060e-01,0.9540e-02,0.8560e-02, &
+      0.6210e-02,0.4490e-02,0.3240e-02,0.2340e-02,0.1880e-02,0.1740e-02, &
+      0.1500e-02,0.1320e-02,0.1160e-02,0.8800e-03,0.6950e-03,0.4640e-03, &
+      0.3400e-03,0.3110e-03,0.2940e-03,0.2790e-03,0.2700e-03,0.2640e-03, &
+      0.2580e-03,0.2520e-03,0.2490e-03,0.2540e-03,0.2640e-03,0.2740e-03, &
+      0.2890e-03,0.3050e-03,0.3150e-03,0.3460e-03,0.3820e-03,0.4620e-03, &
+      0.5000e-03,0.5500e-03,0.5950e-03,0.6470e-03,0.6920e-03,0.7420e-03, &
+      0.8200e-03,0.9700e-03,0.1950e-02,0.5780e-02,0.9700e-02/
+      data(tabimt(i,2),i=1,nwlt)/ &
+                            0.8300e-01,0.6900e-01,0.5700e-01,0.4560e-01, &
+      0.3790e-01,0.3140e-01,0.2620e-01,0.2240e-01,0.1960e-01,0.1760e-01, &
+      0.1665e-01,0.1600e-01,0.1500e-01,0.1400e-01,0.1310e-01,0.1230e-01, &
+      0.1150e-01,0.1080e-01,0.9460e-02,0.8290e-02,0.7270e-02,0.4910e-02, &
+      0.3300e-02,0.2220e-02,0.1490e-02,0.1140e-02,0.1060e-02,0.9480e-03, &
+      0.8500e-03,0.7660e-03,0.6300e-03,0.5200e-03,0.3840e-03,0.2960e-03, &
+      0.2700e-03,0.2520e-03,0.2440e-03,0.2360e-03,0.2300e-03,0.2280e-03, &
+      0.2250e-03,0.2200e-03,0.2160e-03,0.2170e-03,0.2200e-03,0.2250e-03, &
+      0.2320e-03,0.2390e-03,0.2600e-03,0.2860e-03,0.3560e-03,0.3830e-03, &
+      0.4150e-03,0.4450e-03,0.4760e-03,0.5080e-03,0.5400e-03,0.5860e-03, &
+      0.6780e-03,0.1280e-02,0.3550e-02,0.5600e-02/
+      data(tabimt(i,3),i=1,nwlt)/ &
+                 0.8300e-01,0.6900e-01,0.5700e-01,0.4560e-01,0.3790e-01, &
+      0.3140e-01,0.2620e-01,0.2190e-01,0.1880e-01,0.1660e-01,0.1540e-01, &
+      0.1470e-01,0.1350e-01,0.1250e-01,0.1150e-01,0.1060e-01,0.9770e-02, &
+      0.9010e-02,0.7660e-02,0.6520e-02,0.5540e-02,0.3420e-02,0.2100e-02, &
+      0.1290e-02,0.7930e-03,0.5700e-03,0.5350e-03,0.4820e-03,0.4380e-03, &
+      0.4080e-03,0.3500e-03,0.3200e-03,0.2550e-03,0.2120e-03,0.2000e-03, &
+      0.1860e-03,0.1750e-03,0.1660e-03,0.1560e-03,0.1490e-03,0.1440e-03, &
+      0.1350e-03,0.1210e-03,0.1160e-03,0.1160e-03,0.1170e-03,0.1200e-03, &
+      0.1230e-03,0.1320e-03,0.1440e-03,0.1680e-03,0.1800e-03,0.1900e-03, &
+      0.2090e-03,0.2160e-03,0.2290e-03,0.2400e-03,0.2600e-03,0.2920e-03, &
+      0.6100e-03,0.1020e-02,0.1810e-02/
+      data(tabimt(i,4),i=1,nwlt)/ &
+      0.8300e-01,0.6900e-01,0.5700e-01,0.4450e-01,0.3550e-01,0.2910e-01, &
+      0.2440e-01,0.1970e-01,0.1670e-01,0.1400e-01,0.1235e-01,0.1080e-01, &
+      0.8900e-02,0.7340e-02,0.6400e-02,0.5600e-02,0.5000e-02,0.4520e-02, &
+      0.3680e-02,0.2990e-02,0.2490e-02,0.1550e-02,0.9610e-03,0.5950e-03, &
+      0.3690e-03,0.2670e-03,0.2510e-03,0.2290e-03,0.2110e-03,0.1960e-03, &
+      0.1730e-03,0.1550e-03,0.1310e-03,0.1130e-03,0.1060e-03,0.9900e-04, &
+      0.9300e-04,0.8730e-04,0.8300e-04,0.7870e-04,0.7500e-04,0.6830e-04, &
+      0.5600e-04,0.4960e-04,0.4550e-04,0.4210e-04,0.3910e-04,0.3760e-04, &
+      0.3400e-04,0.3100e-04,0.2640e-04,0.2510e-04,0.2430e-04,0.2390e-04, &
+      0.2370e-04,0.2380e-04,0.2400e-04,0.2460e-04,0.2660e-04,0.4450e-04, &
+      0.8700e-04,0.1320e-03/
+ 
+  pi = acos(-1.0)
+  n_r=0.0
+  n_i=0.0
+
+  tk = t
+
+! // convert frequency to wavelength (um)
+  alam=3E5/freq
+  if((alam < wlmin) .or. (alam > wlmax)) then
+    print *, 'm_ice: wavelength out of bounds'
+    stop
+  endif
+
+  if (alam < cutice) then
+
+!   // region from 0.045 microns to 167.0 microns - no temperature depend
+    do i=2,nwl
+      if(alam < wl(i)) continue
+    enddo
+    x1=log(wl(i-1))
+    x2=log(wl(i))
+    y1=tabre(i-1)
+    y2=tabre(i)
+    x=log(alam)
+    y=((x-x1)*(y2-y1)/(x2-x1))+y1
+    n_r=y
+    y1=log(abs(tabim(i-1)))
+    y2=log(abs(tabim(i)))
+    y=((x-x1)*(y2-y1)/(x2-x1))+y1
+    n_i=exp(y)
+
+  else
+
+!   // region from 167.0 microns to 8.6 meters - temperature dependence
+    if(tk > temref(1)) tk=temref(1)
+    if(tk < temref(4)) tk=temref(4)
+    do 11 i=2,4
+      if(tk.ge.temref(i)) go to 12
+    11 continue
+    12 lt1=i
+    lt2=i-1
+    do 13 i=2,nwlt
+      if(alam.le.wlt(i)) go to 14
+    13 continue
+    14 x1=log(wlt(i-1))
+    x2=log(wlt(i))
+    y1=tabret(i-1,lt1)
+    y2=tabret(i,lt1)
+    x=log(alam)
+    ylo=((x-x1)*(y2-y1)/(x2-x1))+y1
+    y1=tabret(i-1,lt2)
+    y2=tabret(i,lt2)
+    yhi=((x-x1)*(y2-y1)/(x2-x1))+y1
+    t1=temref(lt1)
+    t2=temref(lt2)
+    y=((tk-t1)*(yhi-ylo)/(t2-t1))+ylo
+    n_r=y
+    y1=log(abs(tabimt(i-1,lt1)))
+    y2=log(abs(tabimt(i,lt1)))
+    ylo=((x-x1)*(y2-y1)/(x2-x1))+y1
+    y1=log(abs(tabimt(i-1,lt2)))
+    y2=log(abs(tabimt(i,lt2)))
+    yhi=((x-x1)*(y2-y1)/(x2-x1))+y1
+    y=((tk-t1)*(yhi-ylo)/(t2-t1))+ylo
+    n_i=exp(y)
+
+  endif
+
+  end subroutine m_ice
+
+! ----------------------------------------------------------------------------
+! subroutine MIEINT
+! ----------------------------------------------------------------------------
+!
+!     General purpose Mie scattering routine for single particles
+!     Author: R Grainger 1990
+!     History:
+!     G Thomas, March 2005: Added calculation of Phase function and
+!     code to ensure correct calculation of backscatter coeficient
+!     Options/Extend_Source
+!
+      Subroutine MieInt(Dx, SCm, Inp, Dqv, Dqxt, Dqsc, Dbsc, Dg, Xs1, Xs2, DPh, Error)
+
+      Integer * 2  Imaxx
+      Parameter (Imaxx = 12000)
+      Real * 4     RIMax          ! largest real part of refractive index
+      Parameter (RIMax = 2.5)
+      Real * 4     IRIMax         ! largest imaginary part of refractive index
+      Parameter (IRIMax = -2)
+      Integer * 2  Itermax
+      Parameter (Itermax = 12000 * 2.5)
+                                ! must be large enough to cope with the
+                                ! largest possible nmx = x * abs(scm) + 15
+                                ! or nmx =  Dx + 4.05*Dx**(1./3.) + 2.0
+      Integer * 2  Imaxnp
+      Parameter (Imaxnp = 10000)  ! Change this as required
+!     INPUT
+      Real * 8     Dx
+      Complex * 16  SCm
+      Integer * 4  Inp
+      Real * 8     Dqv(Inp)
+!     OUTPUT
+      Complex * 16  Xs1(InP)
+      Complex * 16  Xs2(InP)
+      Real * 8     Dqxt
+      Real * 8     Dqsc
+      Real * 8     Dg
+      Real * 8     Dbsc
+      Real * 8     DPh(InP)
+      Integer * 4  Error
+!     LOCAL
+      Integer * 2  I
+      Integer * 2  NStop
+      Integer * 2  NmX
+      Integer * 4  N    ! N*N > 32767 ie N > 181
+      Integer * 4  Inp2
+      Real * 8     Chi,Chi0,Chi1
+      Real * 8     APsi,APsi0,APsi1
+      Real * 8     Pi0(Imaxnp)
+      Real * 8     Pi1(Imaxnp)
+      Real * 8     Taun(Imaxnp)
+      Real * 8     Psi,Psi0,Psi1
+      Complex * 8  Ir
+      Complex * 16 Cm
+      Complex * 16 A,ANM1,APB
+      Complex * 16 B,BNM1,AMB
+      Complex * 16 D(Itermax)
+      Complex * 16 Sp(Imaxnp)
+      Complex * 16 Sm(Imaxnp)
+      Complex * 16 Xi,Xi0,Xi1
+      Complex * 16 Y
+!     ACCELERATOR VARIABLES
+      Integer * 2  Tnp1
+      Integer * 2  Tnm1
+      Real * 8     Dn
+      Real * 8     Rnx
+      Real * 8     S(Imaxnp)
+      Real * 8     T(Imaxnp)
+      Real * 8     Turbo
+      Real * 8     A2
+      Complex * 16 A1
+      
+      If ((Dx.Gt.Imaxx) .Or. (InP.Gt.ImaxNP)) Then
+        Error = 1
+        Return
+      EndIf
+      Cm = SCm
+      Ir = 1 / Cm
+      Y =  Dx * Cm
+      If (Dx.Lt.0.02) Then
+         NStop = 2
+      Else
+         If (Dx.Le.8.0) Then
+            NStop = Dx + 4.00*Dx**(1./3.) + 2.0
+         Else
+            If (Dx.Lt. 4200.0) Then
+               NStop = Dx + 4.05*Dx**(1./3.) + 2.0
+            Else
+               NStop = Dx + 4.00*Dx**(1./3.) + 2.0
+            End If
+         End If
+      End If
+      NmX = Max(Real(NStop),Real(Abs(Y))) + 15.
+      If (Nmx .gt. Itermax) then
+          Error = 1
+          Return
+      End If
+      Inp2 = Inp+1
+      D(NmX) = Dcmplx(0,0)
+      Do N = Nmx-1,1,-1
+         A1 = (N+1) / Y
+         D(N) = A1 - 1/(A1+D(N+1))
+      End Do
+      Do I =1,Inp2
+         Sm(I) = Dcmplx(0,0)
+         Sp(I) = Dcmplx(0,0)
+         Pi0(I) = 0
+         Pi1(I) = 1
+      End Do
+      Psi0 = Cos(Dx)
+      Psi1 = Sin(Dx)
+      Chi0 =-Sin(Dx)
+      Chi1 = Cos(Dx)
+      APsi0 = Psi0
+      APsi1 = Psi1
+      Xi0 = Dcmplx(APsi0,Chi0)
+      Xi1 = Dcmplx(APsi1,Chi1)
+      Dg = 0
+      Dqsc = 0
+      Dqxt = 0
+      Tnp1 = 1
+      Do N = 1,Nstop
+         DN = N
+         Tnp1 = Tnp1 + 2
+         Tnm1 = Tnp1 - 2
+         A2 = Tnp1 / (DN*(DN+1D0))
+         Turbo = (DN+1D0) / DN
+         Rnx = DN/Dx
+         Psi = Dble(Tnm1)*Psi1/Dx - Psi0
+         APsi = Psi
+         Chi = Tnm1*Chi1/Dx       - Chi0
+         Xi = Dcmplx(APsi,Chi)
+         A = ((D(N)*Ir+Rnx)*APsi-APsi1) / ((D(N)*Ir+Rnx)*  Xi-  Xi1)
+         B = ((D(N)*Cm+Rnx)*APsi-APsi1) / ((D(N)*Cm+Rnx)*  Xi-  Xi1)
+         Dqxt = Tnp1 *      Dble(A + B)          + Dqxt
+         Dqsc = Tnp1 * (A*Conjg(A) + B*Conjg(B)) + Dqsc
+         If (N.Gt.1) then
+         Dg = Dg + (dN*dN - 1) * Dble(ANM1*Conjg(A) + BNM1 * Conjg(B)) / dN + TNM1 * Dble(ANM1*Conjg(BNM1)) / (dN*dN - dN)
+         End If
+         Anm1 = A
+         Bnm1 = B
+         APB = A2 * (A + B)
+         AMB = A2 * (A - B)
+         Do I = 1,Inp2
+            If (I.GT.Inp) Then
+               S(I) = -Pi1(I)
+            Else
+               S(I) = Dqv(I) * Pi1(I)
+            End If
+            T(I) = S(I) - Pi0(I)
+            Taun(I) = N*T(I) - Pi0(I)
+            Sp(I) = APB * (Pi1(I) + Taun(I)) + Sp(I)
+            Sm(I) = AMB * (Pi1(I) - Taun(I)) + Sm(I)
+            Pi0(I) = Pi1(I)
+            Pi1(I) = S(I) + T(I)*Turbo
+         End Do
+         Psi0 = Psi1
+         Psi1 = Psi
+         Apsi1 = Psi1
+         Chi0 = Chi1
+         Chi1 = Chi
+         Xi1 = Dcmplx(APsi1,Chi1)
+      End Do
+      If (Dg .GT.0) Dg = 2 * Dg / Dqsc
+      Dqsc =  2 * Dqsc / Dx**2
+      Dqxt =  2 * Dqxt / Dx**2
+      Do I = 1,Inp
+         Xs1(I) = (Sp(I)+Sm(I)) / 2
+         Xs2(I) = (Sp(I)-Sm(I)) / 2
+         Dph(I) = 2 * Dble(Xs1(I)*Conjg(Xs1(I)) + Xs2(I)*Conjg(Xs2(I))) / (Dx**2 * Dqsc)
+      End Do
+      Dbsc = 4 * Abs(( (Sp(Inp2)+Sm(Inp2))/2 )**2) / Dx**2
+      Error = 0
+      Return
+      End subroutine MieInt
+
+  end module optics_lib
Index: DZ6/trunk/libf/phylmd/cosp/predict_mom07.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cosp/predict_mom07.F90	(revision 5267)
+++ 	(revision )
@@ -1,41 +1,0 @@
-! $Revision: 88 $, $Date: 2013-11-13 15:08:38 +0100 (mer. 13 nov. 2013) $
-! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/predict_mom07.F90 $
-        subroutine predict_mom07(m2,tc,n,m)
-        
-        ! subroutine to predict nth moment m given m2, tc, n
-        ! if m2=-9999 then the routine will predict m2 given m,n,tc
-            implicit none
-        
-            real*8 :: a1,a2,a3,b1,b2,b3,c1,c2,c3
-            real*8 :: m2,tc,n,m,a_,b_,c_,A,B,C,n2
-        
-            a1=      13.6078
-            a2=     -7.76062
-            a3=     0.478694
-            b1=   -0.0360722
-            b2=    0.0150830
-            b3=   0.00149453
-            c1=     0.806856
-            c2=   0.00581022
-            c3=    0.0456723
-        
-            n2=n*n
-            a_=a1+a2*n+a3*n2
-            b_=b1+b2*n+b3*n2
-            c_=c1+c2*n+c3*n2
-        
-            A=exp(a_)
-            B=b_
-            C=c_
-            
-        ! predict m from m2 and tc
-                if(m2.ne.-9999) then 
-                m=A*exp(B*tc)*m2**C
-                endif
-        ! get m2 if mass-dimension relationship not proportional to D**2
-                if(m2.eq.-9999) then 
-                m2=(m/(A*exp(B*tc)))**(1.0/C)    
-                endif
-        
-                return
-        end subroutine predict_mom07
Index: /LMDZ6/trunk/libf/phylmd/cosp/predict_mom07.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cosp/predict_mom07.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/cosp/predict_mom07.f90	(revision 5268)
@@ -0,0 +1,41 @@
+! $Revision: 88 $, $Date: 2013-11-13 15:08:38 +0100 (mer. 13 nov. 2013) $
+! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/predict_mom07.F90 $
+        subroutine predict_mom07(m2,tc,n,m)
+        
+        ! subroutine to predict nth moment m given m2, tc, n
+        ! if m2=-9999 then the routine will predict m2 given m,n,tc
+            implicit none
+        
+            real*8 :: a1,a2,a3,b1,b2,b3,c1,c2,c3
+            real*8 :: m2,tc,n,m,a_,b_,c_,A,B,C,n2
+        
+            a1=      13.6078
+            a2=     -7.76062
+            a3=     0.478694
+            b1=   -0.0360722
+            b2=    0.0150830
+            b3=   0.00149453
+            c1=     0.806856
+            c2=   0.00581022
+            c3=    0.0456723
+        
+            n2=n*n
+            a_=a1+a2*n+a3*n2
+            b_=b1+b2*n+b3*n2
+            c_=c1+c2*n+c3*n2
+        
+            A=exp(a_)
+            B=b_
+            C=c_
+            
+        ! predict m from m2 and tc
+                if(m2.ne.-9999) then 
+                m=A*exp(B*tc)*m2**C
+                endif
+        ! get m2 if mass-dimension relationship not proportional to D**2
+                if(m2.eq.-9999) then 
+                m2=(m/(A*exp(B*tc)))**(1.0/C)    
+                endif
+        
+                return
+        end subroutine predict_mom07
Index: DZ6/trunk/libf/phylmd/cosp/radar_simulator.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cosp/radar_simulator.F90	(revision 5267)
+++ 	(revision )
@@ -1,454 +1,0 @@
-  subroutine radar_simulator( &
-    hp, &
-    nprof,ngate, &
-    undef, &
-    hgt_matrix,hm_matrix,re_matrix,Np_matrix, &
-    p_matrix,t_matrix,rh_matrix, &
-    Ze_non,Ze_ray,a_to_vol,g_to_vol,dBZe, &
-    g_to_vol_in,g_to_vol_out)
- 
-  use m_mrgrnk 
-  use array_lib
-  use math_lib
-  use optics_lib
-  use radar_simulator_types
-  use scale_LUTs_io
-  implicit none
-  
-! Purpose:
-!
-!   Simulates a vertical profile of radar reflectivity
-!   Originally Part of QuickBeam v1.04 by John Haynes & Roger Marchand.
-!   but has been substantially modified since that time by
-!   Laura Fowler and Roger Marchand (see modifications below).
-!
-! Inputs:
-!
-!   [hp]              structure that defines hydrometeor types and other radar properties
-!
-!   [nprof]           number of hydrometeor profiles
-!   [ngate]           number of vertical layers
-!
-!   [undef]           missing data value
-!   (The following 5 arrays must be in order from closest to the radar
-!    to farthest...)
-!
-!   [hgt_matrix]      height of hydrometeors (km)
-!   [p_matrix]        pressure profile (hPa)
-!   [t_matrix]        temperature profile (K)
-!   [rh_matrix]       relative humidity profile (%) -- only needed if gaseous aborption calculated.
-!
-!   [hm_matrix]       table of hydrometeor mixing rations (g/kg)
-!   [re_matrix]       table of hydrometeor effective radii.  0 ==> use defaults. (units=microns)    
-!   [Np_matrix]	      table of hydrometeor number concentration.  0 ==> use defaults. (units = 1/kg)
-!
-! Outputs:
-!
-!   [Ze_non]          radar reflectivity without attenuation (dBZ)
-!   [Ze_ray]          Rayleigh reflectivity (dBZ)
-!   [h_atten_to_vol]  attenuation by hydromets, radar to vol (dB)
-!   [g_atten_to_vol]  gaseous atteunation, radar to vol (dB)
-!   [dBZe]            effective radar reflectivity factor (dBZ)
-!
-! Optional:
-!   [g_to_vol_in]     integrated atten due to gases, r>v (dB).
-!                     If present then is used as gaseous absorption, independently of the
-!                     value in use_gas_abs
-!   [g_to_vol_out]    integrated atten due to gases, r>v (dB).
-!                     If present then gaseous absorption for each profile is returned here.
-!
-! Created:
-!   11/28/2005  John Haynes (haynes@atmos.colostate.edu)
-!
-! Modified:
-!   09/2006  placed into subroutine form (Roger Marchand,JMH)
-!   08/2007  added equivalent volume spheres, Z and N scalling most distrubtion types (Roger Marchand)
-!   01/2008  'Do while' to determine if hydrometeor(s) present in volume
-!             changed for vectorization purposes (A. Bodas-Salcedo)
-!
-!   07/2010  V3.0 ... Modified to load or save scale factors to disk as a Look-Up Table (LUT)
-!  ... All hydrometeor and radar simulator properties now included in hp structure
-!  ... hp structure should be initialized by call to radar_simulator_init prior 
-!  ... to calling this subroutine.  
-!     Also ... Support of Morrison 2-moment style microphyscis (Np_matrix) added 
-!  ... Changes implement by Roj Marchand following work by Laura Fowler
-!
-!   10/2011  Modified ngate loop to go in either direction depending on flag 
-!     hp%radar_at_layer_one.  This affects the direction in which attenuation is summed.
-!
-!     Also removed called to AVINT for gas and hydrometeor attenuation and replaced with simple
-!     summation. (Roger Marchand)
-!
-!
-! ----- INPUTS -----  
- 
-  logical, parameter  ::  DO_LUT_TEST = .false. 
-  logical, parameter  ::  DO_NP_TEST = .false. 
-
-  type(class_param), intent(inout) :: hp
-
-  integer, intent(in) ::  nprof,ngate
-
-  real undef
-  real*8, dimension(nprof,ngate), intent(in) :: &
-    hgt_matrix, p_matrix,t_matrix,rh_matrix
-
-  real*8, dimension(hp%nhclass,nprof,ngate), intent(in) :: hm_matrix
-  real*8, dimension(hp%nhclass,nprof,ngate), intent(inout) :: re_matrix
-  real*8, dimension(hp%nhclass,nprof,ngate), intent(inout)    :: Np_matrix
-
-! ----- OUTPUTS -----
-  real*8, dimension(nprof,ngate), intent(out) :: Ze_non,Ze_ray, &
-       g_to_vol,dBZe,a_to_vol
-
-! ----- OPTIONAL -----
-  real*8, optional, dimension(nprof,ngate) :: &
-  g_to_vol_in,g_to_vol_out ! integrated atten due to gases, r>v (dB). This allows to output and then input
-                           ! the same gaseous absorption in different calls. Optional to allow compatibility
-                           ! with original version. A. Bodas April 2008.
-!  real*8, dimension(nprof,ngate) :: kr_matrix 
-
-! ----- INTERNAL -----
-
-  real, parameter :: one_third = 1.0/3.0
-  real*8 :: t_kelvin
-  integer :: &
-  phase, & ! 0=liquid, 1=ice
-  ns       ! number of discrete drop sizes
-
-  logical :: hydro	! true=hydrometeor in vol, false=none
-  real*8 :: &
-  rho_a, &   ! air density (kg m^-3)
-  gases      ! function: 2-way gas atten (dB/km)
-
-  real*8, dimension(:), allocatable :: &
-  Di, Deq, &   ! discrete drop sizes (um)
-  Ni, &        ! discrete concentrations (cm^-3 um^-1)
-  rhoi         ! discrete densities (kg m^-3)
-
-  real*8, dimension(nprof, ngate) :: &
-  z_vol, &      ! effective reflectivity factor (mm^6/m^3)
-  z_ray, &                      ! reflectivity factor, Rayleigh only (mm^6/m^3)
-  kr_vol, &     ! attenuation coefficient hydro (dB/km)
-  g_vol         ! attenuation coefficient gases (dB/km)
-
-
-  integer,parameter :: KR8 = selected_real_kind(15,300)
-  real*8, parameter :: xx = -1.0_KR8
-  real*8,  dimension(:), allocatable :: xxa
-  real*8 :: kr, ze, zr, pi, scale_factor, tc, Re, ld, tmp1, ze2, kr2, apm, bpm
-  real*8 :: half_a_atten_current,half_a_atten_above
-  real*8 :: half_g_atten_current,half_g_atten_above
-  integer*4 :: tp, i, j, k, pr, itt, iff
-
-  real*8    step,base, Np
-  integer*4 iRe_type,n,max_bin
-
-  integer   start_gate,end_gate,d_gate
-
-  logical :: g_to_vol_in_present, g_to_vol_out_present
-
-  ! Logicals to avoid calling present within the loops
-  g_to_vol_in_present  = present(g_to_vol_in)
-  g_to_vol_out_present = present(g_to_vol_out)
-
-  !
-  ! load scaling matricies from disk -- but only the first time this subroutine is called
-  !
-  if(hp%load_scale_LUTs) then
-    call load_scale_LUTs(hp)
-    hp%load_scale_LUTs=.false.
-    hp%Z_scale_added_flag = .false. ! will be set true if scaling Look Up Tables are modified during run
-  endif
-
-  pi = acos(-1.0)
-
-!   ----- Initialisation -----
-  g_to_vol = 0.0
-  a_to_vol = 0.0
-  z_vol    = 0.0
-  z_ray    = 0.0
-  kr_vol   = 0.0
-
-!   // loop over each range gate (ngate) ... starting with layer closest to the radar !
-  if(hp%radar_at_layer_one) then
-    start_gate=1
-    end_gate=ngate
-    d_gate=1
-  else
-    start_gate=ngate
-    end_gate=1
-    d_gate=-1
-  endif
-  do k=start_gate,end_gate,d_gate
-  ! // loop over each profile (nprof)
-    do pr=1,nprof
-      t_kelvin = t_matrix(pr,k)
-!     :: determine if hydrometeor(s) present in volume
-      hydro = .false.
-      do j=1,hp%nhclass
-        if ((hm_matrix(j,pr,k) > 1E-12) .and. (hp%dtype(j) > 0)) then
-          hydro = .true.
-          exit
-        endif
-      enddo
-
-!     :: if there is hydrometeor in the volume
-      if (hydro) then
-
-        rho_a = (p_matrix(pr,k)*100.)/(287.0*(t_kelvin))
-!       :: loop over hydrometeor type
-        do tp=1,hp%nhclass
-          if (hm_matrix(tp,pr,k) <= 1E-12) cycle
-          phase = hp%phase(tp)
-          if (phase==0) then
-            itt = infind(hp%mt_ttl,t_kelvin)
-          else
-            itt = infind(hp%mt_tti,t_kelvin)
-          endif
-          if (re_matrix(tp,pr,k).eq.0) then
-            call calc_Re(hm_matrix(tp,pr,k),Np_matrix(tp,pr,k),rho_a, &
-              hp%dtype(tp),hp%dmin(tp),hp%dmax(tp),hp%apm(tp),hp%bpm(tp), &
-              hp%rho(tp),hp%p1(tp),hp%p2(tp),hp%p3(tp),Re)
-            re_matrix(tp,pr,k)=Re
-          else
-            if (Np_matrix(tp,pr,k)>0) then
-               print *, 'Warning: Re and Np set for the same ', &
-                        'volume & hydrometeor type.  Np is being ignored.'
-            endif
-            Re = re_matrix(tp,pr,k)
-          endif
-
-          iRe_type=1
-          if(Re.gt.0) then
-            ! determine index in to scale LUT
-            !
-            ! distance between Re points (defined by "base" and "step") for
-            ! each interval of size Re_BIN_LENGTH
-            ! Integer asignment, avoids calling floor intrinsic
-            n=Re/Re_BIN_LENGTH
-            if (n>=Re_MAX_BIN) n=Re_MAX_BIN-1
-            step=hp%step_list(n+1)
-            base=hp%base_list(n+1)
-            iRe_type=Re/step
-            if (iRe_type.lt.1) iRe_type=1
-
-            Re=step*(iRe_type+0.5)	! set value of Re to closest value allowed in LUT.
-            iRe_type=iRe_type+base-int(n*Re_BIN_LENGTH/step)
-
-            ! make sure iRe_type is within bounds
-            if (iRe_type.ge.nRe_types) then
-!               write(*,*) 'Warning: size of Re exceed value permitted ', &
-!                    'in Look-Up Table (LUT).  Will calculate. '
-               ! no scaling allowed
-               iRe_type=nRe_types
-               hp%Z_scale_flag(tp,itt,iRe_type)=.false.
-            else
-               ! set value in re_matrix to closest values in LUT
-              if (.not. DO_LUT_TEST) re_matrix(tp,pr,k)=Re
-            endif
-          endif
-          ! use Ze_scaled, Zr_scaled, and kr_scaled ... if know them
-          ! if not we will calculate Ze, Zr, and Kr from the distribution parameters
-          if( (.not. hp%Z_scale_flag(tp,itt,iRe_type)) .or. DO_LUT_TEST)  then
-            ! :: create a distribution of hydrometeors within volume
-            select case(hp%dtype(tp))
-              case(4)
-                ns = 1
-                allocate(Di(ns),Ni(ns),rhoi(ns),xxa(ns),Deq(ns))
-                Di = hp%p1(tp)
-                Ni = 0.
-              case default
-                ns = nd   ! constant defined in radar_simulator_types.f90
-                allocate(Di(ns),Ni(ns),rhoi(ns),xxa(ns),Deq(ns))
-                Di = hp%D
-                Ni = 0.
-            end select
-            call dsd(hm_matrix(tp,pr,k),re_matrix(tp,pr,k),Np_matrix(tp,pr,k), &
-                     Di,Ni,ns,hp%dtype(tp),rho_a,t_kelvin, &
-                     hp%dmin(tp),hp%dmax(tp),hp%apm(tp),hp%bpm(tp), &
-                     hp%rho(tp),hp%p1(tp),hp%p2(tp),hp%p3(tp))
-
-            ! calculate particle density
-            if (phase == 1) then
-              if (hp%rho(tp) < 0) then
-                ! Use equivalent volume spheres.
-                hp%rho_eff(tp,1:ns,iRe_type) = 917  				! solid ice == equivalent volume approach
-                Deq = ( ( 6/pi*hp%apm(tp)/917 ) ** (1.0/3.0) ) * ( (Di*1E-6) ** (hp%bpm(tp)/3.0) )  * 1E6
-                ! alternative is to comment out above two lines and use the following block
-                ! MG Mie approach - adjust density of sphere with D = D_characteristic to match particle density
-                !
-                ! hp%rho_eff(tp,1:ns,iRe_type) = (6/pi)*hp%apm(tp)*(Di*1E-6)**(hp%bpm(tp)-3)   !MG Mie approach
-
-                ! as the particle size gets small it is possible that the mass to size relationship of 
-                ! (given by power law in hclass.data) can produce impossible results 
-                ! where the mass is larger than a solid sphere of ice.  
-                ! This loop ensures that no ice particle can have more mass/density larger than an ice sphere.
-                ! do i=1,ns
-                ! if(hp%rho_eff(tp,i,iRe_type) > 917 ) then
-                ! hp%rho_eff(tp,i,iRe_type) = 917
-                ! endif
-                ! enddo
-              else
-                ! Equivalent volume sphere (solid ice rho_ice=917 kg/m^3).
-                hp%rho_eff(tp,1:ns,iRe_type) = 917
-                Deq=Di * ((hp%rho(tp)/917)**(1.0/3.0))
-                ! alternative ... coment out above two lines and use the following for MG-Mie
-                ! hp%rho_eff(tp,1:ns,iRe_type) = hp%rho(tp)   !MG Mie approach
-              endif
-            else
-              ! I assume here that water phase droplets are spheres.
-              ! hp%rho should be ~ 1000  or hp%apm=524 .and. hp%bpm=3
-              Deq = Di
-            endif
-
-            ! calculate effective reflectivity factor of volume
-            xxa = -9.9
-            rhoi = hp%rho_eff(tp,1:ns,iRe_type)
-            call zeff(hp%freq,Deq,Ni,ns,hp%k2,t_kelvin,phase,hp%do_ray, &
-                      ze,zr,kr,xxa,xxa,rhoi)
-
-            ! test code ... compare Np value input to routine with sum of DSD
-            ! NOTE: if .not. DO_LUT_TEST, then you are checking the LUT approximation 
-            ! not just the DSD representation given by Ni
-            if(Np_matrix(tp,pr,k)>0 .and. DO_NP_TEST ) then
-              Np = path_integral(Ni,Di,1,ns-1)/rho_a*1E6
-              ! Note: Representation is not great or small Re < 2 
-              if( (Np_matrix(tp,pr,k)-Np)/Np_matrix(tp,pr,k)>0.1 ) then
-                write(*,*) 'Error: Np input does not match sum(N)'
-                write(*,*) tp,pr,k,Re,Ni(1),Ni(ns),10*log10(ze)
-                write(*,*) Np_matrix(tp,pr,k),Np,(Np_matrix(tp,pr,k)-Np)/Np_matrix(tp,pr,k)
-                write(*,*)
-              endif
-            endif
-
-            deallocate(Di,Ni,rhoi,xxa,Deq)
-
-            ! LUT test code
-            ! This segment of code compares full calculation to scaling result
-            if ( hp%Z_scale_flag(tp,itt,iRe_type) .and. DO_LUT_TEST )  then
-              scale_factor=rho_a*hm_matrix(tp,pr,k)
-              ! if more than 2 dBZe difference print error message/parameters.
-              if ( abs(10*log10(ze) - 10*log10(hp%Ze_scaled(tp,itt,iRe_type) * &
-                   scale_factor)) > 2 ) then
-                write(*,*) 'Roj Error: ',tp,itt,iRe_type,hp%Z_scale_flag(tp,itt,iRe_type),n,step,base
-                write(*,*) 10*log10(ze),10*log10(hp%Ze_scaled(tp,itt,iRe_type) * scale_factor)
-                write(*,*) hp%Ze_scaled(tp,itt,iRe_type),scale_factor
-                write(*,*) re_matrix(tp,pr,k),Re
-                write(*,*)
-              endif
-            endif
-
-          else ! can use z scaling
-            scale_factor=rho_a*hm_matrix(tp,pr,k)
-            zr = hp%Zr_scaled(tp,itt,iRe_type) * scale_factor
-            ze = hp%Ze_scaled(tp,itt,iRe_type) * scale_factor
-            kr = hp%kr_scaled(tp,itt,iRe_type) * scale_factor
-          endif  ! end z_scaling
-
-          kr_vol(pr,k) = kr_vol(pr,k) + kr
-          z_vol(pr,k)  = z_vol(pr,k)  + ze
-          z_ray(pr,k)  = z_ray(pr,k)  + zr
-
-          ! construct Ze_scaled, Zr_scaled, and kr_scaled ... if we can
-          if ( .not. hp%Z_scale_flag(tp,itt,iRe_type) ) then
-            if (iRe_type>1) then
-              scale_factor=rho_a*hm_matrix(tp,pr,k)
-              hp%Ze_scaled(tp,itt,iRe_type) = ze/ scale_factor
-              hp%Zr_scaled(tp,itt,iRe_type) = zr/ scale_factor
-              hp%kr_scaled(tp,itt,iRe_type) = kr/ scale_factor
-              hp%Z_scale_flag(tp,itt,iRe_type) = .true.
-              hp%Z_scale_added_flag(tp,itt,iRe_type)=.true.
-            endif
-          endif
-
-        enddo	! end loop of tp (hydrometeor type)
-
-      else
-!     :: volume is hydrometeor-free	
-        kr_vol(pr,k) = 0
-        z_vol(pr,k)  = undef
-        z_ray(pr,k)  = undef
-      endif
-
-      !     :: attenuation due to hydrometeors between radar and volume
-      !
-      ! NOTE old scheme integrates attenuation only for the layers ABOVE
-      ! the current layer ... i.e. 1 to k-1 rather than 1 to k ...
-      ! which may be a problem.   ROJ
-      ! in the new scheme I assign half the attenuation to the current layer
-      if(d_gate==1) then
-        ! dheight calcuations assumes hgt_matrix points are the cell mid-points.
-        if (k>2) then
-          ! add to previous value to half of above layer + half of current layer
-          a_to_vol(pr,k)=  a_to_vol(pr,k-1) + &
-             (kr_vol(pr,k-1)+kr_vol(pr,k))*(hgt_matrix(pr,k-1)-hgt_matrix(pr,k))
-        else
-          a_to_vol(pr,k)=  kr_vol(pr,k)*(hgt_matrix(pr,k)-hgt_matrix(pr,k+1))
-        endif
-      else   ! d_gate==-1
-        if(k<ngate) then
-          ! add to previous value half of above layer + half of current layer
-          a_to_vol(pr,k) = a_to_vol(pr,k+1) + &
-              (kr_vol(pr,k+1)+kr_vol(pr,k))*(hgt_matrix(pr,k+1)-hgt_matrix(pr,k))
-        else
-          a_to_vol(pr,k)= kr_vol(pr,k)*(hgt_matrix(pr,k)-hgt_matrix(pr,k-1))
-        endif
-      endif
-
-      !     :: attenuation due to gaseous absorption between radar and volume
-      if (g_to_vol_in_present) then
-        g_to_vol(pr,k) = g_to_vol_in(pr,k)
-      else
-        if ( (hp%use_gas_abs == 1) .or. ((hp%use_gas_abs == 2) .and. (pr == 1)) ) then
-          g_vol(pr,k) = gases(p_matrix(pr,k),t_kelvin,rh_matrix(pr,k),hp%freq)
-          if (d_gate==1) then
-            if (k>1) then
-              ! add to previous value to half of above layer + half of current layer
-              g_to_vol(pr,k) =  g_to_vol(pr,k-1) + &
-                  0.5*(g_vol(pr,k-1)+g_vol(pr,k))*(hgt_matrix(pr,k-1)-hgt_matrix(pr,k))
-            else
-              g_to_vol(pr,k)=  0.5*g_vol(pr,k)*(hgt_matrix(pr,k)-hgt_matrix(pr,k+1))
-            endif
-          else   ! d_gate==-1
-            if (k<ngate) then
-              ! add to previous value to half of above layer + half of current layer
-              g_to_vol(pr,k) = g_to_vol(pr,k+1) + &
-                 0.5*(g_vol(pr,k+1)+g_vol(pr,k))*(hgt_matrix(pr,k+1)-hgt_matrix(pr,k))
-            else
-              g_to_vol(pr,k)= 0.5*g_vol(pr,k)*(hgt_matrix(pr,k)-hgt_matrix(pr,k-1))
-            endif
-          endif
-        elseif(hp%use_gas_abs == 2) then
-          ! using value calculated for the first column
-          g_to_vol(pr,k) = g_to_vol(1,k)
-        elseif (hp%use_gas_abs == 0) then
-          g_to_vol(pr,k) = 0
-        endif
-      endif
-
-      ! Compute Rayleigh reflectivity, and full, attenuated reflectivity
-      if ((hp%do_ray == 1) .and. (z_ray(pr,k) > 0)) then
-        Ze_ray(pr,k) = 10*log10(z_ray(pr,k))
-      else
-        Ze_ray(pr,k) = undef
-      endif
-      if (z_vol(pr,k) > 0) then
-        Ze_non(pr,k) = 10*log10(z_vol(pr,k))
-        dBZe(pr,k) = Ze_non(pr,k)-a_to_vol(pr,k)-g_to_vol(pr,k)
-      else
-        dBZe(pr,k) = undef
-        Ze_non(pr,k) = undef
-      endif
-
-    enddo   ! end loop over pr (profile)
-
-  enddo ! end loop of k (range gate)
-
-  ! Output array with gaseous absorption
-  if (g_to_vol_out_present) g_to_vol_out = g_to_vol
-
-  ! save any updates made 
-  if (hp%update_scale_LUTs) call save_scale_LUTs(hp)
-
-  end subroutine radar_simulator
Index: /LMDZ6/trunk/libf/phylmd/cosp/radar_simulator.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cosp/radar_simulator.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/cosp/radar_simulator.f90	(revision 5268)
@@ -0,0 +1,454 @@
+  subroutine radar_simulator( &
+    hp, &
+    nprof,ngate, &
+    undef, &
+    hgt_matrix,hm_matrix,re_matrix,Np_matrix, &
+    p_matrix,t_matrix,rh_matrix, &
+    Ze_non,Ze_ray,a_to_vol,g_to_vol,dBZe, &
+    g_to_vol_in,g_to_vol_out)
+ 
+  use m_mrgrnk 
+  use array_lib
+  use math_lib
+  use optics_lib
+  use radar_simulator_types
+  use scale_LUTs_io
+  implicit none
+  
+! Purpose:
+!
+!   Simulates a vertical profile of radar reflectivity
+!   Originally Part of QuickBeam v1.04 by John Haynes & Roger Marchand.
+!   but has been substantially modified since that time by
+!   Laura Fowler and Roger Marchand (see modifications below).
+!
+! Inputs:
+!
+!   [hp]              structure that defines hydrometeor types and other radar properties
+!
+!   [nprof]           number of hydrometeor profiles
+!   [ngate]           number of vertical layers
+!
+!   [undef]           missing data value
+!   (The following 5 arrays must be in order from closest to the radar
+!    to farthest...)
+!
+!   [hgt_matrix]      height of hydrometeors (km)
+!   [p_matrix]        pressure profile (hPa)
+!   [t_matrix]        temperature profile (K)
+!   [rh_matrix]       relative humidity profile (%) -- only needed if gaseous aborption calculated.
+!
+!   [hm_matrix]       table of hydrometeor mixing rations (g/kg)
+!   [re_matrix]       table of hydrometeor effective radii.  0 ==> use defaults. (units=microns)    
+!   [Np_matrix]	      table of hydrometeor number concentration.  0 ==> use defaults. (units = 1/kg)
+!
+! Outputs:
+!
+!   [Ze_non]          radar reflectivity without attenuation (dBZ)
+!   [Ze_ray]          Rayleigh reflectivity (dBZ)
+!   [h_atten_to_vol]  attenuation by hydromets, radar to vol (dB)
+!   [g_atten_to_vol]  gaseous atteunation, radar to vol (dB)
+!   [dBZe]            effective radar reflectivity factor (dBZ)
+!
+! Optional:
+!   [g_to_vol_in]     integrated atten due to gases, r>v (dB).
+!                     If present then is used as gaseous absorption, independently of the
+!                     value in use_gas_abs
+!   [g_to_vol_out]    integrated atten due to gases, r>v (dB).
+!                     If present then gaseous absorption for each profile is returned here.
+!
+! Created:
+!   11/28/2005  John Haynes (haynes@atmos.colostate.edu)
+!
+! Modified:
+!   09/2006  placed into subroutine form (Roger Marchand,JMH)
+!   08/2007  added equivalent volume spheres, Z and N scalling most distrubtion types (Roger Marchand)
+!   01/2008  'Do while' to determine if hydrometeor(s) present in volume
+!             changed for vectorization purposes (A. Bodas-Salcedo)
+!
+!   07/2010  V3.0 ... Modified to load or save scale factors to disk as a Look-Up Table (LUT)
+!  ... All hydrometeor and radar simulator properties now included in hp structure
+!  ... hp structure should be initialized by call to radar_simulator_init prior 
+!  ... to calling this subroutine.  
+!     Also ... Support of Morrison 2-moment style microphyscis (Np_matrix) added 
+!  ... Changes implement by Roj Marchand following work by Laura Fowler
+!
+!   10/2011  Modified ngate loop to go in either direction depending on flag 
+!     hp%radar_at_layer_one.  This affects the direction in which attenuation is summed.
+!
+!     Also removed called to AVINT for gas and hydrometeor attenuation and replaced with simple
+!     summation. (Roger Marchand)
+!
+!
+! ----- INPUTS -----  
+ 
+  logical, parameter  ::  DO_LUT_TEST = .false. 
+  logical, parameter  ::  DO_NP_TEST = .false. 
+
+  type(class_param), intent(inout) :: hp
+
+  integer, intent(in) ::  nprof,ngate
+
+  real undef
+  real*8, dimension(nprof,ngate), intent(in) :: &
+    hgt_matrix, p_matrix,t_matrix,rh_matrix
+
+  real*8, dimension(hp%nhclass,nprof,ngate), intent(in) :: hm_matrix
+  real*8, dimension(hp%nhclass,nprof,ngate), intent(inout) :: re_matrix
+  real*8, dimension(hp%nhclass,nprof,ngate), intent(inout)    :: Np_matrix
+
+! ----- OUTPUTS -----
+  real*8, dimension(nprof,ngate), intent(out) :: Ze_non,Ze_ray, &
+       g_to_vol,dBZe,a_to_vol
+
+! ----- OPTIONAL -----
+  real*8, optional, dimension(nprof,ngate) :: &
+  g_to_vol_in,g_to_vol_out ! integrated atten due to gases, r>v (dB). This allows to output and then input
+                           ! the same gaseous absorption in different calls. Optional to allow compatibility
+                           ! with original version. A. Bodas April 2008.
+!  real*8, dimension(nprof,ngate) :: kr_matrix 
+
+! ----- INTERNAL -----
+
+  real, parameter :: one_third = 1.0/3.0
+  real*8 :: t_kelvin
+  integer :: &
+  phase, & ! 0=liquid, 1=ice
+  ns       ! number of discrete drop sizes
+
+  logical :: hydro	! true=hydrometeor in vol, false=none
+  real*8 :: &
+  rho_a, &   ! air density (kg m^-3)
+  gases      ! function: 2-way gas atten (dB/km)
+
+  real*8, dimension(:), allocatable :: &
+  Di, Deq, &   ! discrete drop sizes (um)
+  Ni, &        ! discrete concentrations (cm^-3 um^-1)
+  rhoi         ! discrete densities (kg m^-3)
+
+  real*8, dimension(nprof, ngate) :: &
+  z_vol, &      ! effective reflectivity factor (mm^6/m^3)
+  z_ray, &                      ! reflectivity factor, Rayleigh only (mm^6/m^3)
+  kr_vol, &     ! attenuation coefficient hydro (dB/km)
+  g_vol         ! attenuation coefficient gases (dB/km)
+
+
+  integer,parameter :: KR8 = selected_real_kind(15,300)
+  real*8, parameter :: xx = -1.0_KR8
+  real*8,  dimension(:), allocatable :: xxa
+  real*8 :: kr, ze, zr, pi, scale_factor, tc, Re, ld, tmp1, ze2, kr2, apm, bpm
+  real*8 :: half_a_atten_current,half_a_atten_above
+  real*8 :: half_g_atten_current,half_g_atten_above
+  integer*4 :: tp, i, j, k, pr, itt, iff
+
+  real*8    step,base, Np
+  integer*4 iRe_type,n,max_bin
+
+  integer   start_gate,end_gate,d_gate
+
+  logical :: g_to_vol_in_present, g_to_vol_out_present
+
+  ! Logicals to avoid calling present within the loops
+  g_to_vol_in_present  = present(g_to_vol_in)
+  g_to_vol_out_present = present(g_to_vol_out)
+
+  !
+  ! load scaling matricies from disk -- but only the first time this subroutine is called
+  !
+  if(hp%load_scale_LUTs) then
+    call load_scale_LUTs(hp)
+    hp%load_scale_LUTs=.false.
+    hp%Z_scale_added_flag = .false. ! will be set true if scaling Look Up Tables are modified during run
+  endif
+
+  pi = acos(-1.0)
+
+!   ----- Initialisation -----
+  g_to_vol = 0.0
+  a_to_vol = 0.0
+  z_vol    = 0.0
+  z_ray    = 0.0
+  kr_vol   = 0.0
+
+!   // loop over each range gate (ngate) ... starting with layer closest to the radar !
+  if(hp%radar_at_layer_one) then
+    start_gate=1
+    end_gate=ngate
+    d_gate=1
+  else
+    start_gate=ngate
+    end_gate=1
+    d_gate=-1
+  endif
+  do k=start_gate,end_gate,d_gate
+  ! // loop over each profile (nprof)
+    do pr=1,nprof
+      t_kelvin = t_matrix(pr,k)
+!     :: determine if hydrometeor(s) present in volume
+      hydro = .false.
+      do j=1,hp%nhclass
+        if ((hm_matrix(j,pr,k) > 1E-12) .and. (hp%dtype(j) > 0)) then
+          hydro = .true.
+          exit
+        endif
+      enddo
+
+!     :: if there is hydrometeor in the volume
+      if (hydro) then
+
+        rho_a = (p_matrix(pr,k)*100.)/(287.0*(t_kelvin))
+!       :: loop over hydrometeor type
+        do tp=1,hp%nhclass
+          if (hm_matrix(tp,pr,k) <= 1E-12) cycle
+          phase = hp%phase(tp)
+          if (phase==0) then
+            itt = infind(hp%mt_ttl,t_kelvin)
+          else
+            itt = infind(hp%mt_tti,t_kelvin)
+          endif
+          if (re_matrix(tp,pr,k).eq.0) then
+            call calc_Re(hm_matrix(tp,pr,k),Np_matrix(tp,pr,k),rho_a, &
+              hp%dtype(tp),hp%dmin(tp),hp%dmax(tp),hp%apm(tp),hp%bpm(tp), &
+              hp%rho(tp),hp%p1(tp),hp%p2(tp),hp%p3(tp),Re)
+            re_matrix(tp,pr,k)=Re
+          else
+            if (Np_matrix(tp,pr,k)>0) then
+               print *, 'Warning: Re and Np set for the same ', &
+                        'volume & hydrometeor type.  Np is being ignored.'
+            endif
+            Re = re_matrix(tp,pr,k)
+          endif
+
+          iRe_type=1
+          if(Re.gt.0) then
+            ! determine index in to scale LUT
+            !
+            ! distance between Re points (defined by "base" and "step") for
+            ! each interval of size Re_BIN_LENGTH
+            ! Integer asignment, avoids calling floor intrinsic
+            n=Re/Re_BIN_LENGTH
+            if (n>=Re_MAX_BIN) n=Re_MAX_BIN-1
+            step=hp%step_list(n+1)
+            base=hp%base_list(n+1)
+            iRe_type=Re/step
+            if (iRe_type.lt.1) iRe_type=1
+
+            Re=step*(iRe_type+0.5)	! set value of Re to closest value allowed in LUT.
+            iRe_type=iRe_type+base-int(n*Re_BIN_LENGTH/step)
+
+            ! make sure iRe_type is within bounds
+            if (iRe_type.ge.nRe_types) then
+!               write(*,*) 'Warning: size of Re exceed value permitted ', &
+!                    'in Look-Up Table (LUT).  Will calculate. '
+               ! no scaling allowed
+               iRe_type=nRe_types
+               hp%Z_scale_flag(tp,itt,iRe_type)=.false.
+            else
+               ! set value in re_matrix to closest values in LUT
+              if (.not. DO_LUT_TEST) re_matrix(tp,pr,k)=Re
+            endif
+          endif
+          ! use Ze_scaled, Zr_scaled, and kr_scaled ... if know them
+          ! if not we will calculate Ze, Zr, and Kr from the distribution parameters
+          if( (.not. hp%Z_scale_flag(tp,itt,iRe_type)) .or. DO_LUT_TEST)  then
+            ! :: create a distribution of hydrometeors within volume
+            select case(hp%dtype(tp))
+              case(4)
+                ns = 1
+                allocate(Di(ns),Ni(ns),rhoi(ns),xxa(ns),Deq(ns))
+                Di = hp%p1(tp)
+                Ni = 0.
+              case default
+                ns = nd   ! constant defined in radar_simulator_types.f90
+                allocate(Di(ns),Ni(ns),rhoi(ns),xxa(ns),Deq(ns))
+                Di = hp%D
+                Ni = 0.
+            end select
+            call dsd(hm_matrix(tp,pr,k),re_matrix(tp,pr,k),Np_matrix(tp,pr,k), &
+                     Di,Ni,ns,hp%dtype(tp),rho_a,t_kelvin, &
+                     hp%dmin(tp),hp%dmax(tp),hp%apm(tp),hp%bpm(tp), &
+                     hp%rho(tp),hp%p1(tp),hp%p2(tp),hp%p3(tp))
+
+            ! calculate particle density
+            if (phase == 1) then
+              if (hp%rho(tp) < 0) then
+                ! Use equivalent volume spheres.
+                hp%rho_eff(tp,1:ns,iRe_type) = 917  				! solid ice == equivalent volume approach
+                Deq = ( ( 6/pi*hp%apm(tp)/917 ) ** (1.0/3.0) ) * ( (Di*1E-6) ** (hp%bpm(tp)/3.0) )  * 1E6
+                ! alternative is to comment out above two lines and use the following block
+                ! MG Mie approach - adjust density of sphere with D = D_characteristic to match particle density
+                !
+                ! hp%rho_eff(tp,1:ns,iRe_type) = (6/pi)*hp%apm(tp)*(Di*1E-6)**(hp%bpm(tp)-3)   !MG Mie approach
+
+                ! as the particle size gets small it is possible that the mass to size relationship of 
+                ! (given by power law in hclass.data) can produce impossible results 
+                ! where the mass is larger than a solid sphere of ice.  
+                ! This loop ensures that no ice particle can have more mass/density larger than an ice sphere.
+                ! do i=1,ns
+                ! if(hp%rho_eff(tp,i,iRe_type) > 917 ) then
+                ! hp%rho_eff(tp,i,iRe_type) = 917
+                ! endif
+                ! enddo
+              else
+                ! Equivalent volume sphere (solid ice rho_ice=917 kg/m^3).
+                hp%rho_eff(tp,1:ns,iRe_type) = 917
+                Deq=Di * ((hp%rho(tp)/917)**(1.0/3.0))
+                ! alternative ... coment out above two lines and use the following for MG-Mie
+                ! hp%rho_eff(tp,1:ns,iRe_type) = hp%rho(tp)   !MG Mie approach
+              endif
+            else
+              ! I assume here that water phase droplets are spheres.
+              ! hp%rho should be ~ 1000  or hp%apm=524 .and. hp%bpm=3
+              Deq = Di
+            endif
+
+            ! calculate effective reflectivity factor of volume
+            xxa = -9.9
+            rhoi = hp%rho_eff(tp,1:ns,iRe_type)
+            call zeff(hp%freq,Deq,Ni,ns,hp%k2,t_kelvin,phase,hp%do_ray, &
+                      ze,zr,kr,xxa,xxa,rhoi)
+
+            ! test code ... compare Np value input to routine with sum of DSD
+            ! NOTE: if .not. DO_LUT_TEST, then you are checking the LUT approximation 
+            ! not just the DSD representation given by Ni
+            if(Np_matrix(tp,pr,k)>0 .and. DO_NP_TEST ) then
+              Np = path_integral(Ni,Di,1,ns-1)/rho_a*1E6
+              ! Note: Representation is not great or small Re < 2 
+              if( (Np_matrix(tp,pr,k)-Np)/Np_matrix(tp,pr,k)>0.1 ) then
+                write(*,*) 'Error: Np input does not match sum(N)'
+                write(*,*) tp,pr,k,Re,Ni(1),Ni(ns),10*log10(ze)
+                write(*,*) Np_matrix(tp,pr,k),Np,(Np_matrix(tp,pr,k)-Np)/Np_matrix(tp,pr,k)
+                write(*,*)
+              endif
+            endif
+
+            deallocate(Di,Ni,rhoi,xxa,Deq)
+
+            ! LUT test code
+            ! This segment of code compares full calculation to scaling result
+            if ( hp%Z_scale_flag(tp,itt,iRe_type) .and. DO_LUT_TEST )  then
+              scale_factor=rho_a*hm_matrix(tp,pr,k)
+              ! if more than 2 dBZe difference print error message/parameters.
+              if ( abs(10*log10(ze) - 10*log10(hp%Ze_scaled(tp,itt,iRe_type) * &
+                   scale_factor)) > 2 ) then
+                write(*,*) 'Roj Error: ',tp,itt,iRe_type,hp%Z_scale_flag(tp,itt,iRe_type),n,step,base
+                write(*,*) 10*log10(ze),10*log10(hp%Ze_scaled(tp,itt,iRe_type) * scale_factor)
+                write(*,*) hp%Ze_scaled(tp,itt,iRe_type),scale_factor
+                write(*,*) re_matrix(tp,pr,k),Re
+                write(*,*)
+              endif
+            endif
+
+          else ! can use z scaling
+            scale_factor=rho_a*hm_matrix(tp,pr,k)
+            zr = hp%Zr_scaled(tp,itt,iRe_type) * scale_factor
+            ze = hp%Ze_scaled(tp,itt,iRe_type) * scale_factor
+            kr = hp%kr_scaled(tp,itt,iRe_type) * scale_factor
+          endif  ! end z_scaling
+
+          kr_vol(pr,k) = kr_vol(pr,k) + kr
+          z_vol(pr,k)  = z_vol(pr,k)  + ze
+          z_ray(pr,k)  = z_ray(pr,k)  + zr
+
+          ! construct Ze_scaled, Zr_scaled, and kr_scaled ... if we can
+          if ( .not. hp%Z_scale_flag(tp,itt,iRe_type) ) then
+            if (iRe_type>1) then
+              scale_factor=rho_a*hm_matrix(tp,pr,k)
+              hp%Ze_scaled(tp,itt,iRe_type) = ze/ scale_factor
+              hp%Zr_scaled(tp,itt,iRe_type) = zr/ scale_factor
+              hp%kr_scaled(tp,itt,iRe_type) = kr/ scale_factor
+              hp%Z_scale_flag(tp,itt,iRe_type) = .true.
+              hp%Z_scale_added_flag(tp,itt,iRe_type)=.true.
+            endif
+          endif
+
+        enddo	! end loop of tp (hydrometeor type)
+
+      else
+!     :: volume is hydrometeor-free	
+        kr_vol(pr,k) = 0
+        z_vol(pr,k)  = undef
+        z_ray(pr,k)  = undef
+      endif
+
+      !     :: attenuation due to hydrometeors between radar and volume
+      !
+      ! NOTE old scheme integrates attenuation only for the layers ABOVE
+      ! the current layer ... i.e. 1 to k-1 rather than 1 to k ...
+      ! which may be a problem.   ROJ
+      ! in the new scheme I assign half the attenuation to the current layer
+      if(d_gate==1) then
+        ! dheight calcuations assumes hgt_matrix points are the cell mid-points.
+        if (k>2) then
+          ! add to previous value to half of above layer + half of current layer
+          a_to_vol(pr,k)=  a_to_vol(pr,k-1) + &
+             (kr_vol(pr,k-1)+kr_vol(pr,k))*(hgt_matrix(pr,k-1)-hgt_matrix(pr,k))
+        else
+          a_to_vol(pr,k)=  kr_vol(pr,k)*(hgt_matrix(pr,k)-hgt_matrix(pr,k+1))
+        endif
+      else   ! d_gate==-1
+        if(k<ngate) then
+          ! add to previous value half of above layer + half of current layer
+          a_to_vol(pr,k) = a_to_vol(pr,k+1) + &
+              (kr_vol(pr,k+1)+kr_vol(pr,k))*(hgt_matrix(pr,k+1)-hgt_matrix(pr,k))
+        else
+          a_to_vol(pr,k)= kr_vol(pr,k)*(hgt_matrix(pr,k)-hgt_matrix(pr,k-1))
+        endif
+      endif
+
+      !     :: attenuation due to gaseous absorption between radar and volume
+      if (g_to_vol_in_present) then
+        g_to_vol(pr,k) = g_to_vol_in(pr,k)
+      else
+        if ( (hp%use_gas_abs == 1) .or. ((hp%use_gas_abs == 2) .and. (pr == 1)) ) then
+          g_vol(pr,k) = gases(p_matrix(pr,k),t_kelvin,rh_matrix(pr,k),hp%freq)
+          if (d_gate==1) then
+            if (k>1) then
+              ! add to previous value to half of above layer + half of current layer
+              g_to_vol(pr,k) =  g_to_vol(pr,k-1) + &
+                  0.5*(g_vol(pr,k-1)+g_vol(pr,k))*(hgt_matrix(pr,k-1)-hgt_matrix(pr,k))
+            else
+              g_to_vol(pr,k)=  0.5*g_vol(pr,k)*(hgt_matrix(pr,k)-hgt_matrix(pr,k+1))
+            endif
+          else   ! d_gate==-1
+            if (k<ngate) then
+              ! add to previous value to half of above layer + half of current layer
+              g_to_vol(pr,k) = g_to_vol(pr,k+1) + &
+                 0.5*(g_vol(pr,k+1)+g_vol(pr,k))*(hgt_matrix(pr,k+1)-hgt_matrix(pr,k))
+            else
+              g_to_vol(pr,k)= 0.5*g_vol(pr,k)*(hgt_matrix(pr,k)-hgt_matrix(pr,k-1))
+            endif
+          endif
+        elseif(hp%use_gas_abs == 2) then
+          ! using value calculated for the first column
+          g_to_vol(pr,k) = g_to_vol(1,k)
+        elseif (hp%use_gas_abs == 0) then
+          g_to_vol(pr,k) = 0
+        endif
+      endif
+
+      ! Compute Rayleigh reflectivity, and full, attenuated reflectivity
+      if ((hp%do_ray == 1) .and. (z_ray(pr,k) > 0)) then
+        Ze_ray(pr,k) = 10*log10(z_ray(pr,k))
+      else
+        Ze_ray(pr,k) = undef
+      endif
+      if (z_vol(pr,k) > 0) then
+        Ze_non(pr,k) = 10*log10(z_vol(pr,k))
+        dBZe(pr,k) = Ze_non(pr,k)-a_to_vol(pr,k)-g_to_vol(pr,k)
+      else
+        dBZe(pr,k) = undef
+        Ze_non(pr,k) = undef
+      endif
+
+    enddo   ! end loop over pr (profile)
+
+  enddo ! end loop of k (range gate)
+
+  ! Output array with gaseous absorption
+  if (g_to_vol_out_present) g_to_vol_out = g_to_vol
+
+  ! save any updates made 
+  if (hp%update_scale_LUTs) call save_scale_LUTs(hp)
+
+  end subroutine radar_simulator
Index: DZ6/trunk/libf/phylmd/cosp/radar_simulator_init.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cosp/radar_simulator_init.F90	(revision 5267)
+++ 	(revision )
@@ -1,156 +1,0 @@
-  subroutine radar_simulator_init(freq,k2,use_gas_abs,do_ray,undef, &
-                  nhclass, &
-                  hclass_type,hclass_phase, &
-                      hclass_dmin,hclass_dmax, &
-                          hclass_apm,hclass_bpm,hclass_rho, &
-                          hclass_p1,hclass_p2,hclass_p3, &
-                          load_scale_LUTs_flag,update_scale_LUTs_flag,LUT_file_name, &
-                  hp &      ! output
-                  )
-  use radar_simulator_types
-  implicit none
-  
-! Purpose:
-!
-!   Initialize variables used by the radar simulator.
-!   Part of QuickBeam v3.0 by John Haynes and Roj Marchand
-!   
-!
-! Inputs:  
-!   []   from data in hydrometeor class input 
-! 
-!   [freq]            radar frequency (GHz)
-!
-!   [k2]              |K|^2, the dielectric constant, set to -1 to use the
-!                     frequency dependent default
-!
-!   [use_gas_abs]     1=do gaseous abs calcs, 0=no gasesous absorbtion calculated,
-!                     2=calculate (and use) absorption for first profile on all profiles
-!
-!   [undef]           mising data value
-!   [nhclass]         number of hydrometeor types
-!
-!   For each hydrometero type:
-!       hclass_type     Type of distribution (see quickbeam documentation)
-!       hclass_phase            1==ice, 0=liquid
-!
-!       hclass_dmin         minimum diameter allowed is drop size distribution N(D<Dmin)=0
-!       hclass_dmax         maximum diameter allowed is drop size distribution N(D>Dmax)=0
-!
-!   hclass_apm,hclass_bpm   Density of partical apm*D^bpm or constant = rho
-!   hclass_rho, 
-!   
-!       hclass_p1,hclass_p2,    Default values of DSD parameters (see quickbeam documentation)
-!   hclass_p3, 
-!
-!   load_scale_LUTs_flag    Flag, load scale factors Look Up Table from file at start of run
-!   update_scale_LUTs_flag  Flag, save new scale factors calculated during this run to LUT
-!   LUT_file_name       Name of file containing LUT
-!
-! Outputs:
-!   [hp]            structure that define hydrometeor types
-!
-! Modified:
-!   08/23/2006  placed into subroutine form (Roger Marchand)
-!   June 2010   New interface to support "radar_simulator_params" structure
-   
-! ----- INPUT -----
-
-   real, intent(in)    :: freq,k2
-   integer, intent(in) :: nhclass       ! number of hydrometeor classes in use
-   integer, intent(in) :: use_gas_abs,do_ray
-   real :: undef
-   real,dimension(nhclass),intent(in)     ::    hclass_dmin,hclass_dmax, &
-                                hclass_apm,hclass_bpm,hclass_rho, &
-                                hclass_p1,hclass_p2,hclass_p3 
-   integer,dimension(nhclass),intent(in)  ::    hclass_type,hclass_phase
-  
-   logical, intent(in)       :: load_scale_LUTs_flag,update_scale_LUTs_flag
-   character*240, intent(in) :: LUT_file_name
-
-! ----- OUTPUTS -----  
-  type(class_param), intent(out) :: hp
-
-! ----- INTERNAL -----  
-  integer :: i,j
-  real*8  :: delt, deltp
-        
-    !
-    ! set radar simulation properites
-    !
-    hp%freq=freq
-    hp%k2=k2
-    hp%use_gas_abs=use_gas_abs
-    hp%do_ray=do_ray
-    hp%nhclass=nhclass
-    
-    hp%load_scale_LUTs=load_scale_LUTs_flag
-    hp%update_scale_LUTs=update_scale_LUTs_flag
-    hp%scale_LUT_file_name=LUT_file_name
-    
-    ! 
-        ! Store settings for hydrometeor types in hp (class_parameter) structure.   
-        !
-        do i = 1,nhclass
-        hp%dtype(i) = hclass_type(i)
-        hp%phase(i) = hclass_phase(i)
-        hp%dmin(i)  = hclass_dmin(i)
-        hp%dmax(i)  = hclass_dmax(i)
-        hp%apm(i)   = hclass_apm(i)
-        hp%bpm(i)   = hclass_bpm(i)
-        hp%rho(i)   = hclass_rho(i)
-        hp%p1(i)    = hclass_p1(i)
-        hp%p2(i)    = hclass_p2(i)
-        hp%p3(i)    = hclass_p3(i)
-        enddo
-   
-        ! 
-        ! initialize scaling array
-        !
-        hp%N_scale_flag = .false.
-        hp%fc = undef
-        hp%rho_eff = undef
-    
-        hp%Z_scale_flag = .false.
-        hp%Ze_scaled = 0.0
-        hp%Zr_scaled = 0.0
-        hp%kr_scaled = 0.0
-  
-        !
-    ! set up Re bin "structure" for z_scaling
-        !
-    hp%base_list(1)=0;
-    do j=1,Re_MAX_BIN
-        hp%step_list(j)=0.1+0.1*((j-1)**1.5);
-        if(hp%step_list(j)>Re_BIN_LENGTH) then
-            hp%step_list(j)=Re_BIN_LENGTH;
-        endif
-        if(j>1) then
-            hp%base_list(j)=hp%base_list(j-1)+floor(Re_BIN_LENGTH/hp%step_list(j-1));
-        endif
-    enddo
-
-    !
-    ! set up Temperature bin structure used for z scaling
-    !
-    do i=1,cnt_ice
-        hp%mt_tti(i)=(i-1)*5-90 + 273.15
-    enddo
-    
-    do i=1,cnt_liq
-        hp%mt_ttl(i)=(i-1)*5-60 + 273.15
-    enddo 
-  
-    !
-        ! define array discrete diameters used in mie calculations
-        !
-        delt = (log(dmax)-log(dmin))/(nd-1)
-        deltp = exp(delt)
-
-        hp%D(1) = dmin
-        do i=2,nd
-          hp%D(i) = hp%D(i-1)*deltp
-        enddo   
- 
-  
-  end subroutine radar_simulator_init
Index: /LMDZ6/trunk/libf/phylmd/cosp/radar_simulator_init.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cosp/radar_simulator_init.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/cosp/radar_simulator_init.f90	(revision 5268)
@@ -0,0 +1,156 @@
+  subroutine radar_simulator_init(freq,k2,use_gas_abs,do_ray,undef, &
+                  nhclass, &
+                  hclass_type,hclass_phase, &
+                      hclass_dmin,hclass_dmax, &
+                          hclass_apm,hclass_bpm,hclass_rho, &
+                          hclass_p1,hclass_p2,hclass_p3, &
+                          load_scale_LUTs_flag,update_scale_LUTs_flag,LUT_file_name, &
+                  hp &      ! output
+                  )
+  use radar_simulator_types
+  implicit none
+  
+! Purpose:
+!
+!   Initialize variables used by the radar simulator.
+!   Part of QuickBeam v3.0 by John Haynes and Roj Marchand
+!   
+!
+! Inputs:  
+!   []   from data in hydrometeor class input 
+! 
+!   [freq]            radar frequency (GHz)
+!
+!   [k2]              |K|^2, the dielectric constant, set to -1 to use the
+!                     frequency dependent default
+!
+!   [use_gas_abs]     1=do gaseous abs calcs, 0=no gasesous absorbtion calculated,
+!                     2=calculate (and use) absorption for first profile on all profiles
+!
+!   [undef]           mising data value
+!   [nhclass]         number of hydrometeor types
+!
+!   For each hydrometero type:
+!       hclass_type     Type of distribution (see quickbeam documentation)
+!       hclass_phase            1==ice, 0=liquid
+!
+!       hclass_dmin         minimum diameter allowed is drop size distribution N(D<Dmin)=0
+!       hclass_dmax         maximum diameter allowed is drop size distribution N(D>Dmax)=0
+!
+!   hclass_apm,hclass_bpm   Density of partical apm*D^bpm or constant = rho
+!   hclass_rho, 
+!   
+!       hclass_p1,hclass_p2,    Default values of DSD parameters (see quickbeam documentation)
+!   hclass_p3, 
+!
+!   load_scale_LUTs_flag    Flag, load scale factors Look Up Table from file at start of run
+!   update_scale_LUTs_flag  Flag, save new scale factors calculated during this run to LUT
+!   LUT_file_name       Name of file containing LUT
+!
+! Outputs:
+!   [hp]            structure that define hydrometeor types
+!
+! Modified:
+!   08/23/2006  placed into subroutine form (Roger Marchand)
+!   June 2010   New interface to support "radar_simulator_params" structure
+   
+! ----- INPUT -----
+
+   real, intent(in)    :: freq,k2
+   integer, intent(in) :: nhclass       ! number of hydrometeor classes in use
+   integer, intent(in) :: use_gas_abs,do_ray
+   real :: undef
+   real,dimension(nhclass),intent(in)     ::    hclass_dmin,hclass_dmax, &
+                                hclass_apm,hclass_bpm,hclass_rho, &
+                                hclass_p1,hclass_p2,hclass_p3 
+   integer,dimension(nhclass),intent(in)  ::    hclass_type,hclass_phase
+  
+   logical, intent(in)       :: load_scale_LUTs_flag,update_scale_LUTs_flag
+   character*240, intent(in) :: LUT_file_name
+
+! ----- OUTPUTS -----  
+  type(class_param), intent(out) :: hp
+
+! ----- INTERNAL -----  
+  integer :: i,j
+  real*8  :: delt, deltp
+        
+    !
+    ! set radar simulation properites
+    !
+    hp%freq=freq
+    hp%k2=k2
+    hp%use_gas_abs=use_gas_abs
+    hp%do_ray=do_ray
+    hp%nhclass=nhclass
+    
+    hp%load_scale_LUTs=load_scale_LUTs_flag
+    hp%update_scale_LUTs=update_scale_LUTs_flag
+    hp%scale_LUT_file_name=LUT_file_name
+    
+    ! 
+        ! Store settings for hydrometeor types in hp (class_parameter) structure.   
+        !
+        do i = 1,nhclass
+        hp%dtype(i) = hclass_type(i)
+        hp%phase(i) = hclass_phase(i)
+        hp%dmin(i)  = hclass_dmin(i)
+        hp%dmax(i)  = hclass_dmax(i)
+        hp%apm(i)   = hclass_apm(i)
+        hp%bpm(i)   = hclass_bpm(i)
+        hp%rho(i)   = hclass_rho(i)
+        hp%p1(i)    = hclass_p1(i)
+        hp%p2(i)    = hclass_p2(i)
+        hp%p3(i)    = hclass_p3(i)
+        enddo
+   
+        ! 
+        ! initialize scaling array
+        !
+        hp%N_scale_flag = .false.
+        hp%fc = undef
+        hp%rho_eff = undef
+    
+        hp%Z_scale_flag = .false.
+        hp%Ze_scaled = 0.0
+        hp%Zr_scaled = 0.0
+        hp%kr_scaled = 0.0
+  
+        !
+    ! set up Re bin "structure" for z_scaling
+        !
+    hp%base_list(1)=0;
+    do j=1,Re_MAX_BIN
+        hp%step_list(j)=0.1+0.1*((j-1)**1.5);
+        if(hp%step_list(j)>Re_BIN_LENGTH) then
+            hp%step_list(j)=Re_BIN_LENGTH;
+        endif
+        if(j>1) then
+            hp%base_list(j)=hp%base_list(j-1)+floor(Re_BIN_LENGTH/hp%step_list(j-1));
+        endif
+    enddo
+
+    !
+    ! set up Temperature bin structure used for z scaling
+    !
+    do i=1,cnt_ice
+        hp%mt_tti(i)=(i-1)*5-90 + 273.15
+    enddo
+    
+    do i=1,cnt_liq
+        hp%mt_ttl(i)=(i-1)*5-60 + 273.15
+    enddo 
+  
+    !
+        ! define array discrete diameters used in mie calculations
+        !
+        delt = (log(dmax)-log(dmin))/(nd-1)
+        deltp = exp(delt)
+
+        hp%D(1) = dmin
+        do i=2,nd
+          hp%D(i) = hp%D(i-1)*deltp
+        enddo   
+ 
+  
+  end subroutine radar_simulator_init
Index: DZ6/trunk/libf/phylmd/cosp/radar_simulator_types.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cosp/radar_simulator_types.F90	(revision 5267)
+++ 	(revision )
@@ -1,74 +1,0 @@
-  module radar_simulator_types
-
-! Collection of common variables and types
-! Part of QuickBeam v1.03 by John Haynes
-! Updated by Roj Marchand June 2010 
-  implicit none
-  integer, parameter ::       &
-  maxhclass = 20         ,& ! max number of hydrometeor classes
-  nRe_types = 550       ! max number or Re size bins allowed in N and Z_scaled look up table
-
-  ! These variables define discrete diameters used to represent the DSDs.
-  integer, parameter ::       &
-  nd = 85               ! number of discrete particles used in construction DSDs
-  real*8, parameter ::        &
-  dmin = 0.1                 ,& ! min size of discrete particle
-  dmax = 10000.                 ! max size of discrete particle
-   
-  integer, parameter :: &   ! These parameters used to define temperature intervals in mie LUTs
-  mt_nfreq = 5              , &
-  mt_ntt = 39               , & ! num temperatures in table
-  mt_nf = 14            , & ! number of ice fractions in table  
-  mt_nd = 85                    ! num discrete mode-p drop sizes in table
-
-  integer, parameter :: &   ! These parameters used to defines Re intervals in scale LUTs
-  Re_BIN_LENGTH=10, &        
-  Re_MAX_BIN=250
-
-  integer, parameter :: &   ! These parameters used to define Temperature invervals in scale LUTs
-  cnt_liq = 19, &       ! liquid temperature count
-  cnt_ice = 20          ! ice temperature count
-
-
-! ---- hydrometeor class type -----  
-  
-  type class_param
-  
-    ! variables used to store hydrometeor "default" properties
-    real*8,  dimension(maxhclass) :: p1,p2,p3,dmin,dmax,apm,bpm,rho
-    integer, dimension(maxhclass) :: dtype,col,cp,phase
-  
-    ! Radar properties
-    real*8  :: freq,k2
-    integer :: nhclass      ! number of hydrometeor classes in use
-    integer :: use_gas_abs, do_ray
-    
-    ! defines location of radar relative to hgt_matrix.   
-    logical :: radar_at_layer_one	! if true radar is assume to be at the edge 
-    					! of the first layer, if the first layer is the
-    					! surface than a ground-based radar.   If the
-    					! first layer is the top-of-atmosphere, then
-    					! a space borne radar. 
-    
-    ! variables used to store Z scale factors
-    character*240 :: scale_LUT_file_name
-    logical :: load_scale_LUTs, update_scale_LUTs
-    logical, dimension(maxhclass,nRe_types) :: N_scale_flag
-    logical, dimension(maxhclass,mt_ntt,nRe_types) :: Z_scale_flag,Z_scale_added_flag
-    real*8,  dimension(maxhclass,mt_ntt,nRe_types) :: Ze_scaled,Zr_scaled,kr_scaled
-    real*8,  dimension(maxhclass,nd,nRe_types) :: fc, rho_eff
-
-    ! used to determine Re index
-    real*8  :: step_list(Re_MAX_BIN),base_list(Re_MAX_BIN)
-  
-    ! used to determine temperature index
-    real*8 :: &
-        mt_ttl(cnt_liq), &  ! liquid temperatures (K)
-        mt_tti(cnt_ice)     ! ice temperatures (K)
-
-    real*8 :: D(nd) ! set of discrete diameters used to represent DSDs
-
-  end type class_param
-  
-   
-  end module radar_simulator_types
Index: /LMDZ6/trunk/libf/phylmd/cosp/radar_simulator_types.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cosp/radar_simulator_types.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/cosp/radar_simulator_types.f90	(revision 5268)
@@ -0,0 +1,74 @@
+  module radar_simulator_types
+
+! Collection of common variables and types
+! Part of QuickBeam v1.03 by John Haynes
+! Updated by Roj Marchand June 2010 
+  implicit none
+  integer, parameter ::       &
+  maxhclass = 20         ,& ! max number of hydrometeor classes
+  nRe_types = 550       ! max number or Re size bins allowed in N and Z_scaled look up table
+
+  ! These variables define discrete diameters used to represent the DSDs.
+  integer, parameter ::       &
+  nd = 85               ! number of discrete particles used in construction DSDs
+  real*8, parameter ::        &
+  dmin = 0.1                 ,& ! min size of discrete particle
+  dmax = 10000.                 ! max size of discrete particle
+   
+  integer, parameter :: &   ! These parameters used to define temperature intervals in mie LUTs
+  mt_nfreq = 5              , &
+  mt_ntt = 39               , & ! num temperatures in table
+  mt_nf = 14            , & ! number of ice fractions in table  
+  mt_nd = 85                    ! num discrete mode-p drop sizes in table
+
+  integer, parameter :: &   ! These parameters used to defines Re intervals in scale LUTs
+  Re_BIN_LENGTH=10, &        
+  Re_MAX_BIN=250
+
+  integer, parameter :: &   ! These parameters used to define Temperature invervals in scale LUTs
+  cnt_liq = 19, &       ! liquid temperature count
+  cnt_ice = 20          ! ice temperature count
+
+
+! ---- hydrometeor class type -----  
+  
+  type class_param
+  
+    ! variables used to store hydrometeor "default" properties
+    real*8,  dimension(maxhclass) :: p1,p2,p3,dmin,dmax,apm,bpm,rho
+    integer, dimension(maxhclass) :: dtype,col,cp,phase
+  
+    ! Radar properties
+    real*8  :: freq,k2
+    integer :: nhclass      ! number of hydrometeor classes in use
+    integer :: use_gas_abs, do_ray
+    
+    ! defines location of radar relative to hgt_matrix.   
+    logical :: radar_at_layer_one	! if true radar is assume to be at the edge 
+    					! of the first layer, if the first layer is the
+    					! surface than a ground-based radar.   If the
+    					! first layer is the top-of-atmosphere, then
+    					! a space borne radar. 
+    
+    ! variables used to store Z scale factors
+    character*240 :: scale_LUT_file_name
+    logical :: load_scale_LUTs, update_scale_LUTs
+    logical, dimension(maxhclass,nRe_types) :: N_scale_flag
+    logical, dimension(maxhclass,mt_ntt,nRe_types) :: Z_scale_flag,Z_scale_added_flag
+    real*8,  dimension(maxhclass,mt_ntt,nRe_types) :: Ze_scaled,Zr_scaled,kr_scaled
+    real*8,  dimension(maxhclass,nd,nRe_types) :: fc, rho_eff
+
+    ! used to determine Re index
+    real*8  :: step_list(Re_MAX_BIN),base_list(Re_MAX_BIN)
+  
+    ! used to determine temperature index
+    real*8 :: &
+        mt_ttl(cnt_liq), &  ! liquid temperatures (K)
+        mt_tti(cnt_ice)     ! ice temperatures (K)
+
+    real*8 :: D(nd) ! set of discrete diameters used to represent DSDs
+
+  end type class_param
+  
+   
+  end module radar_simulator_types
Index: DZ6/trunk/libf/phylmd/cosp/scale_luts_io.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cosp/scale_luts_io.F90	(revision 5267)
+++ 	(revision )
@@ -1,137 +1,0 @@
-  ! scale_LUT_io:  Contains subroutines to load and save scaling Look Up Tables (LUTs) to a file
-  ! 
-  ! June 2010   Written by Roj Marchand
-  
-  module scale_LUTs_io
-  implicit none
-
-  contains
-
-  subroutine load_scale_LUTs(hp)
-  
-    use radar_simulator_types
-
-    type(class_param), intent(inout) :: hp
-
-    logical :: LUT_file_exists
-    integer :: i,j,k,ind
-    
-    !
-    ! load scale LUT from file 
-    !
-    inquire(file=trim(hp%scale_LUT_file_name) // '_radar_Z_scale_LUT.dat', &
-        exist=LUT_file_exists)
-
-    if(.not.LUT_file_exists) then
-    
-        write(*,*) '*************************************************'
-        write(*,*) 'Warning: Could NOT FIND radar LUT file: ', &
-        trim(hp%scale_LUT_file_name) // '_radar_Z_scale_LUT.dat'        
-        write(*,*) 'Will calculated LUT values as needed'
-        write(*,*) '*************************************************'
-        
-        return
-    else
-
-        OPEN(unit=12,file=trim(hp%scale_LUT_file_name) // '_radar_Z_scale_LUT.dat',&
-        form='unformatted', &
-        err= 89, &
-            access='DIRECT',&
-            recl=28)
-         
-            write(*,*) 'Loading radar LUT file: ', &
-        trim(hp%scale_LUT_file_name) // '_radar_Z_scale_LUT.dat'
-    
-            do i=1,maxhclass
-            do j=1,mt_ntt
-            do k=1,nRe_types
-        
-            ind = i+(j-1)*maxhclass+(k-1)*(nRe_types*mt_ntt)
-            
-            read(12,rec=ind) hp%Z_scale_flag(i,j,k), &
-                    hp%Ze_scaled(i,j,k), &
-                    hp%Zr_scaled(i,j,k), &
-                    hp%kr_scaled(i,j,k)
-                                                    
-                ! if(ind==1482329) then
-                !   write (*,*) ind, hp%Z_scale_flag(i,j,k), &
-                !   hp%Ze_scaled(i,j,k), &
-                !   hp%Zr_scaled(i,j,k), &
-                !   hp%kr_scaled(i,j,k)
-                !endif
-     
-            enddo
-            enddo
-            enddo
-        
-            close(unit=12)
-        return 
-    endif
-    
-  89    write(*,*) 'Error: Found but could NOT READ radar LUT file: ', &
-        trim(hp%scale_LUT_file_name) // '_radar_Z_scale_LUT.dat'
-    stop
-    
-  end subroutine load_scale_LUTs
-  
-  subroutine save_scale_LUTs(hp)
-
-    use radar_simulator_types
-  
-    type(class_param), intent(inout) :: hp
-    
-    logical :: LUT_file_exists
-    integer :: i,j,k,ind
-    
-    inquire(file=trim(hp%scale_LUT_file_name) // '_radar_Z_scale_LUT.dat', &
-        exist=LUT_file_exists)
-
-    OPEN(unit=12,file=trim(hp%scale_LUT_file_name) // '_radar_Z_scale_LUT.dat',&
-        form='unformatted', &
-        err= 99, &
-            access='DIRECT',&
-            recl=28)
-         
-        write(*,*) 'Creating or Updating radar LUT file: ', &
-        trim(hp%scale_LUT_file_name) // '_radar_Z_scale_LUT.dat'
-    
-        do i=1,maxhclass
-        do j=1,mt_ntt
-        do k=1,nRe_types
-        
-            ind = i+(j-1)*maxhclass+(k-1)*(nRe_types*mt_ntt)
-            
-            if(.not.LUT_file_exists .or. hp%Z_scale_added_flag(i,j,k)) then
-            
-                hp%Z_scale_added_flag(i,j,k)=.false.
-            
-                write(12,rec=ind) hp%Z_scale_flag(i,j,k), &
-                    hp%Ze_scaled(i,j,k), &
-                    hp%Zr_scaled(i,j,k), &
-                    hp%kr_scaled(i,j,k)
-                     
-                !  1482329 T  0.170626345026495        0.00000000000000       1.827402935860823E-003
-            
-                !if(ind==1482329) then
-                !   write (*,*) ind, hp%Z_scale_flag(i,j,k), &
-                !   hp%Ze_scaled(i,j,k), &
-                !   hp%Zr_scaled(i,j,k), &
-                !   hp%kr_scaled(i,j,k)
-                !endif
-            endif
-        enddo
-        enddo
-        enddo
-        
-        close(unit=12)
-    return 
-    
-  99    write(*,*) 'Error: Unable to create/update radar LUT file: ', &
-        trim(hp%scale_LUT_file_name) // '_radar_Z_scale_LUT.dat'
-    return  
-    
-  end subroutine save_scale_LUTs
-
-
-  end module scale_LUTs_io
-  
Index: /LMDZ6/trunk/libf/phylmd/cosp/scale_luts_io.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cosp/scale_luts_io.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/cosp/scale_luts_io.f90	(revision 5268)
@@ -0,0 +1,137 @@
+  ! scale_LUT_io:  Contains subroutines to load and save scaling Look Up Tables (LUTs) to a file
+  ! 
+  ! June 2010   Written by Roj Marchand
+  
+  module scale_LUTs_io
+  implicit none
+
+  contains
+
+  subroutine load_scale_LUTs(hp)
+  
+    use radar_simulator_types
+
+    type(class_param), intent(inout) :: hp
+
+    logical :: LUT_file_exists
+    integer :: i,j,k,ind
+    
+    !
+    ! load scale LUT from file 
+    !
+    inquire(file=trim(hp%scale_LUT_file_name) // '_radar_Z_scale_LUT.dat', &
+        exist=LUT_file_exists)
+
+    if(.not.LUT_file_exists) then
+    
+        write(*,*) '*************************************************'
+        write(*,*) 'Warning: Could NOT FIND radar LUT file: ', &
+        trim(hp%scale_LUT_file_name) // '_radar_Z_scale_LUT.dat'        
+        write(*,*) 'Will calculated LUT values as needed'
+        write(*,*) '*************************************************'
+        
+        return
+    else
+
+        OPEN(unit=12,file=trim(hp%scale_LUT_file_name) // '_radar_Z_scale_LUT.dat',&
+        form='unformatted', &
+        err= 89, &
+            access='DIRECT',&
+            recl=28)
+         
+            write(*,*) 'Loading radar LUT file: ', &
+        trim(hp%scale_LUT_file_name) // '_radar_Z_scale_LUT.dat'
+    
+            do i=1,maxhclass
+            do j=1,mt_ntt
+            do k=1,nRe_types
+        
+            ind = i+(j-1)*maxhclass+(k-1)*(nRe_types*mt_ntt)
+            
+            read(12,rec=ind) hp%Z_scale_flag(i,j,k), &
+                    hp%Ze_scaled(i,j,k), &
+                    hp%Zr_scaled(i,j,k), &
+                    hp%kr_scaled(i,j,k)
+                                                    
+                ! if(ind==1482329) then
+                !   write (*,*) ind, hp%Z_scale_flag(i,j,k), &
+                !   hp%Ze_scaled(i,j,k), &
+                !   hp%Zr_scaled(i,j,k), &
+                !   hp%kr_scaled(i,j,k)
+                !endif
+     
+            enddo
+            enddo
+            enddo
+        
+            close(unit=12)
+        return 
+    endif
+    
+  89    write(*,*) 'Error: Found but could NOT READ radar LUT file: ', &
+        trim(hp%scale_LUT_file_name) // '_radar_Z_scale_LUT.dat'
+    stop
+    
+  end subroutine load_scale_LUTs
+  
+  subroutine save_scale_LUTs(hp)
+
+    use radar_simulator_types
+  
+    type(class_param), intent(inout) :: hp
+    
+    logical :: LUT_file_exists
+    integer :: i,j,k,ind
+    
+    inquire(file=trim(hp%scale_LUT_file_name) // '_radar_Z_scale_LUT.dat', &
+        exist=LUT_file_exists)
+
+    OPEN(unit=12,file=trim(hp%scale_LUT_file_name) // '_radar_Z_scale_LUT.dat',&
+        form='unformatted', &
+        err= 99, &
+            access='DIRECT',&
+            recl=28)
+         
+        write(*,*) 'Creating or Updating radar LUT file: ', &
+        trim(hp%scale_LUT_file_name) // '_radar_Z_scale_LUT.dat'
+    
+        do i=1,maxhclass
+        do j=1,mt_ntt
+        do k=1,nRe_types
+        
+            ind = i+(j-1)*maxhclass+(k-1)*(nRe_types*mt_ntt)
+            
+            if(.not.LUT_file_exists .or. hp%Z_scale_added_flag(i,j,k)) then
+            
+                hp%Z_scale_added_flag(i,j,k)=.false.
+            
+                write(12,rec=ind) hp%Z_scale_flag(i,j,k), &
+                    hp%Ze_scaled(i,j,k), &
+                    hp%Zr_scaled(i,j,k), &
+                    hp%kr_scaled(i,j,k)
+                     
+                !  1482329 T  0.170626345026495        0.00000000000000       1.827402935860823E-003
+            
+                !if(ind==1482329) then
+                !   write (*,*) ind, hp%Z_scale_flag(i,j,k), &
+                !   hp%Ze_scaled(i,j,k), &
+                !   hp%Zr_scaled(i,j,k), &
+                !   hp%kr_scaled(i,j,k)
+                !endif
+            endif
+        enddo
+        enddo
+        enddo
+        
+        close(unit=12)
+    return 
+    
+  99    write(*,*) 'Error: Unable to create/update radar LUT file: ', &
+        trim(hp%scale_LUT_file_name) // '_radar_Z_scale_LUT.dat'
+    return  
+    
+  end subroutine save_scale_LUTs
+
+
+  end module scale_LUTs_io
+  
Index: DZ6/trunk/libf/phylmd/cosp/zeff.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cosp/zeff.F90	(revision 5267)
+++ 	(revision )
@@ -1,167 +1,0 @@
-! $Revision: 88 $, $Date: 2013-11-13 15:08:38 +0100 (mer. 13 nov. 2013) $
-! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/quickbeam/zeff.f90 $
-  subroutine zeff(freq,D,N,nsizes,k2,tt,ice,xr,z_eff,z_ray,kr,qe,qs,rho_e)
-  use math_lib
-  use optics_lib
-  implicit none
-  
-! Purpose:
-!   Simulates radar return of a volume given DSD of spheres
-!   Part of QuickBeam v1.03 by John Haynes
-!   http://reef.atmos.colostate.edu/haynes/radarsim
-!
-! Inputs:
-!   [freq]      radar frequency (GHz)
-!   [D]         discrete drop sizes (um)
-!   [N]         discrete concentrations (cm^-3 um^-1)
-!   [nsizes]    number of discrete drop sizes
-!   [k2]        |K|^2, -1=use frequency dependent default 
-!   [tt]        hydrometeor temperature (K)
-!   [ice]       indicates volume consists of ice
-!   [xr]        perform Rayleigh calculations?
-!   [qe]        if using a mie table, these contain ext/sca ...
-!   [qs]        ... efficiencies; otherwise set to -1
-!   [rho_e]     medium effective density (kg m^-3) (-1 = pure)
-!
-! Outputs:
-!   [z_eff]     unattenuated effective reflectivity factor (mm^6/m^3)
-!   [z_ray]     reflectivity factor, Rayleigh only (mm^6/m^3)
-!   [kr]        attenuation coefficient (db km^-1)
-!
-! Created:
-!   11/28/05  John Haynes (haynes@atmos.colostate.edu)
-
-! ----- INPUTS -----  
-  integer, intent(in) :: ice, xr
-  integer, intent(in) :: nsizes
-  real*8, intent(in) :: freq,D(nsizes),N(nsizes),tt,qe(nsizes), &
-    qs(nsizes), rho_e(nsizes)
-  real*8, intent(inout) :: k2
-  
-! ----- OUTPUTS -----
-  real*8, intent(out) :: z_eff,z_ray,kr
-    
-! ----- INTERNAL -----
-  integer :: &
-  correct_for_rho        ! correct for density flag
-  real*8, dimension(nsizes) :: &
-  D0, &                  ! D in (m)
-  N0, &                  ! N in m^-3 m^-1
-  sizep, &               ! size parameter
-  qext, &           ! extinction efficiency
-  qbsca, &               ! backscatter efficiency
-  rho_ice, &             ! bulk density ice (kg m^-3)
-  f                 ! ice fraction
-  real*8, dimension(nsizes) :: xtemp
-  real*8 :: &
-  wl, &                  ! wavelength (m)
-  cr                            ! kr(dB/km) = cr * kr(1/km)
-  complex*16 :: &
-  m                 ! complex index of refraction of bulk form
-  complex*16, dimension(nsizes) :: &
-  m0                ! complex index of refraction
-  
-  integer*4 :: i,one
-  real*8 :: pi
-  real*8 :: eta_sum, eta_mie, const, z0_eff, z0_ray, k_sum, &
-            n_r, n_i, dqv(1), dqsc, dg, dph(1)
-  integer*4 :: err
-  complex*16 :: Xs1(1), Xs2(1)
-
-  one=1
-  pi = acos(-1.0)
-  rho_ice(:) = 917
-  z0_ray = 0.0
-
-! // conversions
-  D0 = d*1E-6            ! m
-  N0 = n*1E12            ! 1/(m^3 m)
-  wl = 2.99792458/(freq*10)   ! m
-  
-! // dielectric constant |k^2| defaults
-  if (k2 < 0) then
-    k2 = 0.933
-    if (abs(94.-freq) < 3.) k2=0.75
-    if (abs(35.-freq) < 3.) k2=0.88
-    if (abs(13.8-freq) < 3.) k2=0.925
-  endif  
-  
-  if (qe(1) < -9) then
-
-!   // get the refractive index of the bulk hydrometeors
-    if (ice == 0) then
-      call m_wat(freq,tt,n_r,n_i)
-    else
-      call m_ice(freq,tt,n_r,n_i)
-    endif
-    m = cmplx(n_r,-n_i)
-    m0(:) = m
-    
-    correct_for_rho = 0
-    if ((ice == 1) .and. (minval(rho_e) >= 0)) correct_for_rho = 1
-    
-!   :: correct refractive index for ice density if needed
-    if (correct_for_rho == 1) then
-      f = rho_e/rho_ice
-      m0 = ((2+m0**2+2*f*(m0**2-1))/(2+m0**2+f*(1-m0**2)))**(0.5)
-    endif       
-    
-!   :: Mie calculations
-    sizep = (pi*D0)/wl
-    dqv(1) = 0.
-    do i=1,nsizes
-      call mieint(sizep(i), m0(i), one, dqv, qext(i), dqsc, qbsca(i), &
-        dg, xs1, xs2, dph, err)
-    end do
-    
-  else
-!   // Mie table used
-    
-    qext = qe
-    qbsca = qs
-    
-  endif
-  
-! // eta_mie = 0.25*sum[qbsca*pi*D^2*N(D)*deltaD]
-!                   <--------- eta_sum --------->
-! // z0_eff = (wl^4/!pi^5)*(1./k2)*eta_mie
-  eta_sum = 0.
-  if (size(D0) == 1) then
-    eta_sum = qbsca(1)*(n(1)*1E6)*D0(1)**2
-  else
-    xtemp = qbsca*N0*D0**2
-    call avint(xtemp,D0,nsizes,D0(1),D0(size(D0,1)),eta_sum)
-  endif
- 
-  eta_mie = eta_sum*0.25*pi
-  const = (wl**4/pi**5)*(1./k2)
-  z0_eff = const*eta_mie
-
-! // kr = 0.25*cr*sum[qext*pi*D^2*N(D)*deltaD]
-!                 <---------- k_sum --------->  
-  k_sum = 0.
-  if (size(D0) == 1) then
-    k_sum = qext(1)*(n(1)*1E6)*D0(1)**2
-  else
-    xtemp = qext*N0*D0**2
-    call avint(xtemp,D0,nsizes,D0(1),D0(size(D0,1)),k_sum)
-  endif
-  cr = 10./log(10.)
-  kr = k_sum*0.25*pi*(1000.*cr)
-     
-! // z_ray = sum[D^6*N(D)*deltaD]
-  if (xr == 1) then
-    z0_ray = 0.
-    if (size(D0) == 1) then
-      z0_ray = (n(1)*1E6)*D0(1)**6
-    else
-      xtemp = N0*D0**6
-      call avint(xtemp,D0,nsizes,D0(1),D0(size(D0)),z0_ray)
-    endif
-  endif
-  
-! // convert to mm^6/m^3
-  z_eff = z0_eff*1E18 !  10.*alog10(z0_eff*1E18)
-  z_ray = z0_ray*1E18 !  10.*alog10(z0_ray*1E18)
-  
-  end subroutine zeff
Index: /LMDZ6/trunk/libf/phylmd/cosp/zeff.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cosp/zeff.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/cosp/zeff.f90	(revision 5268)
@@ -0,0 +1,167 @@
+! $Revision: 88 $, $Date: 2013-11-13 15:08:38 +0100 (mer. 13 nov. 2013) $
+! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/quickbeam/zeff.f90 $
+  subroutine zeff(freq,D,N,nsizes,k2,tt,ice,xr,z_eff,z_ray,kr,qe,qs,rho_e)
+  use math_lib
+  use optics_lib
+  implicit none
+  
+! Purpose:
+!   Simulates radar return of a volume given DSD of spheres
+!   Part of QuickBeam v1.03 by John Haynes
+!   http://reef.atmos.colostate.edu/haynes/radarsim
+!
+! Inputs:
+!   [freq]      radar frequency (GHz)
+!   [D]         discrete drop sizes (um)
+!   [N]         discrete concentrations (cm^-3 um^-1)
+!   [nsizes]    number of discrete drop sizes
+!   [k2]        |K|^2, -1=use frequency dependent default 
+!   [tt]        hydrometeor temperature (K)
+!   [ice]       indicates volume consists of ice
+!   [xr]        perform Rayleigh calculations?
+!   [qe]        if using a mie table, these contain ext/sca ...
+!   [qs]        ... efficiencies; otherwise set to -1
+!   [rho_e]     medium effective density (kg m^-3) (-1 = pure)
+!
+! Outputs:
+!   [z_eff]     unattenuated effective reflectivity factor (mm^6/m^3)
+!   [z_ray]     reflectivity factor, Rayleigh only (mm^6/m^3)
+!   [kr]        attenuation coefficient (db km^-1)
+!
+! Created:
+!   11/28/05  John Haynes (haynes@atmos.colostate.edu)
+
+! ----- INPUTS -----  
+  integer, intent(in) :: ice, xr
+  integer, intent(in) :: nsizes
+  real*8, intent(in) :: freq,D(nsizes),N(nsizes),tt,qe(nsizes), &
+    qs(nsizes), rho_e(nsizes)
+  real*8, intent(inout) :: k2
+  
+! ----- OUTPUTS -----
+  real*8, intent(out) :: z_eff,z_ray,kr
+    
+! ----- INTERNAL -----
+  integer :: &
+  correct_for_rho        ! correct for density flag
+  real*8, dimension(nsizes) :: &
+  D0, &                  ! D in (m)
+  N0, &                  ! N in m^-3 m^-1
+  sizep, &               ! size parameter
+  qext, &           ! extinction efficiency
+  qbsca, &               ! backscatter efficiency
+  rho_ice, &             ! bulk density ice (kg m^-3)
+  f                 ! ice fraction
+  real*8, dimension(nsizes) :: xtemp
+  real*8 :: &
+  wl, &                  ! wavelength (m)
+  cr                            ! kr(dB/km) = cr * kr(1/km)
+  complex*16 :: &
+  m                 ! complex index of refraction of bulk form
+  complex*16, dimension(nsizes) :: &
+  m0                ! complex index of refraction
+  
+  integer*4 :: i,one
+  real*8 :: pi
+  real*8 :: eta_sum, eta_mie, const, z0_eff, z0_ray, k_sum, &
+            n_r, n_i, dqv(1), dqsc, dg, dph(1)
+  integer*4 :: err
+  complex*16 :: Xs1(1), Xs2(1)
+
+  one=1
+  pi = acos(-1.0)
+  rho_ice(:) = 917
+  z0_ray = 0.0
+
+! // conversions
+  D0 = d*1E-6            ! m
+  N0 = n*1E12            ! 1/(m^3 m)
+  wl = 2.99792458/(freq*10)   ! m
+  
+! // dielectric constant |k^2| defaults
+  if (k2 < 0) then
+    k2 = 0.933
+    if (abs(94.-freq) < 3.) k2=0.75
+    if (abs(35.-freq) < 3.) k2=0.88
+    if (abs(13.8-freq) < 3.) k2=0.925
+  endif  
+  
+  if (qe(1) < -9) then
+
+!   // get the refractive index of the bulk hydrometeors
+    if (ice == 0) then
+      call m_wat(freq,tt,n_r,n_i)
+    else
+      call m_ice(freq,tt,n_r,n_i)
+    endif
+    m = cmplx(n_r,-n_i)
+    m0(:) = m
+    
+    correct_for_rho = 0
+    if ((ice == 1) .and. (minval(rho_e) >= 0)) correct_for_rho = 1
+    
+!   :: correct refractive index for ice density if needed
+    if (correct_for_rho == 1) then
+      f = rho_e/rho_ice
+      m0 = ((2+m0**2+2*f*(m0**2-1))/(2+m0**2+f*(1-m0**2)))**(0.5)
+    endif       
+    
+!   :: Mie calculations
+    sizep = (pi*D0)/wl
+    dqv(1) = 0.
+    do i=1,nsizes
+      call mieint(sizep(i), m0(i), one, dqv, qext(i), dqsc, qbsca(i), &
+        dg, xs1, xs2, dph, err)
+    end do
+    
+  else
+!   // Mie table used
+    
+    qext = qe
+    qbsca = qs
+    
+  endif
+  
+! // eta_mie = 0.25*sum[qbsca*pi*D^2*N(D)*deltaD]
+!                   <--------- eta_sum --------->
+! // z0_eff = (wl^4/!pi^5)*(1./k2)*eta_mie
+  eta_sum = 0.
+  if (size(D0) == 1) then
+    eta_sum = qbsca(1)*(n(1)*1E6)*D0(1)**2
+  else
+    xtemp = qbsca*N0*D0**2
+    call avint(xtemp,D0,nsizes,D0(1),D0(size(D0,1)),eta_sum)
+  endif
+ 
+  eta_mie = eta_sum*0.25*pi
+  const = (wl**4/pi**5)*(1./k2)
+  z0_eff = const*eta_mie
+
+! // kr = 0.25*cr*sum[qext*pi*D^2*N(D)*deltaD]
+!                 <---------- k_sum --------->  
+  k_sum = 0.
+  if (size(D0) == 1) then
+    k_sum = qext(1)*(n(1)*1E6)*D0(1)**2
+  else
+    xtemp = qext*N0*D0**2
+    call avint(xtemp,D0,nsizes,D0(1),D0(size(D0,1)),k_sum)
+  endif
+  cr = 10./log(10.)
+  kr = k_sum*0.25*pi*(1000.*cr)
+     
+! // z_ray = sum[D^6*N(D)*deltaD]
+  if (xr == 1) then
+    z0_ray = 0.
+    if (size(D0) == 1) then
+      z0_ray = (n(1)*1E6)*D0(1)**6
+    else
+      xtemp = N0*D0**6
+      call avint(xtemp,D0,nsizes,D0(1),D0(size(D0)),z0_ray)
+    endif
+  endif
+  
+! // convert to mm^6/m^3
+  z_eff = z0_eff*1E18 !  10.*alog10(z0_eff*1E18)
+  z_ray = z0_ray*1E18 !  10.*alog10(z0_ray*1E18)
+  
+  end subroutine zeff
Index: DZ6/trunk/libf/phylmd/cospv2/MISR_simulator.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cospv2/MISR_simulator.F90	(revision 5267)
+++ 	(revision )
@@ -1,292 +1,0 @@
-! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-! Copyright (c) 2009, Roger Marchand, version 1.2
-! All rights reserved.
-!
-! Redistribution and use in source and binary forms, with or without modification, are 
-! permitted provided that the following conditions are met:
-!
-! 1. Redistributions of source code must retain the above copyright notice, this list of 
-!    conditions and the following disclaimer.
-!
-! 2. Redistributions in binary form must reproduce the above copyright notice, this list
-!    of conditions and the following disclaimer in the documentation and/or other 
-!    materials provided with the distribution.
-!
-! 3. Neither the name of the copyright holder nor the names of its contributors may be 
-!    used to endorse or promote products derived from this software without specific prior
-!    written permission.
-!
-! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY 
-! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 
-! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL 
-! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 
-! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT 
-! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 
-! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
-! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-!
-! History
-! May 2015 - D. Swales - Modified for COSPv2.0
-! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-MODULE MOD_MISR_SIMULATOR
-  use cosp_kinds,      only: wp
-  use MOD_COSP_STATS,  ONLY: hist2D
-  use mod_cosp_config, ONLY: R_UNDEF,numMISRHgtBins,numMISRTauBins,misr_histHgt,  &
-                             misr_histTau
-  implicit none 
-
-  ! Parameters
-  real(wp),parameter :: &
-       misr_taumin = 0.3_wp,            & ! Minimum optical depth for joint-histogram
-       tauchk      = -1.*log(0.9999999)   ! Lower limit on optical depth
-
-contains
-
-  ! ######################################################################################
-  ! SUBROUTINE misr_subcolumn
-  ! ######################################################################################
-  SUBROUTINE MISR_SUBCOLUMN(npoints,ncol,nlev,dtau,zfull,at,sunlit,tauOUT,               &
-                        dist_model_layertops,box_MISR_ztop)
-    ! INPUTS
-    INTEGER, intent(in) :: &
-         npoints,    & ! Number of horizontal gridpoints
-         ncol,       & ! Number of subcolumns
-         nlev          ! Number of vertical layers
-    INTEGER, intent(in),dimension(npoints) :: &
-         sunlit        ! 1 for day points, 0 for night time
-    REAL(WP),intent(in),dimension(npoints,ncol,nlev) :: &
-         dtau          ! Optical thickness
-    REAL(WP),intent(in),dimension(npoints,nlev) :: &
-         zfull,      & ! Height of full model levels (i.e. midpoints), [nlev] is bottom
-         at            ! Temperature (K)
-
-    ! OUTPUTS
-    REAL(WP),intent(out),dimension(npoints,ncol) :: &
-         box_MISR_ztop,     & ! Cloud-top height in each column
-         tauOUT               ! Optical depth in each column
-    REAL(WP),intent(out),dimension(npoints,numMISRHgtBins) :: &
-         dist_model_layertops ! 
-
-    ! INTERNAL VARIABLES
-    INTEGER :: ilev,j,loop,ibox,thres_crossed_MISR
-    INTEGER :: iMISR_ztop
-    REAL(WP) :: cloud_dtau,MISR_penetration_height,ztest
-
-    ! ############################################################################
-    ! Initialize
-    box_MISR_ztop(1:npoints,1:ncol) = 0._wp  
-
-    do j=1,npoints
-
-       ! Estimate distribution of Model layer tops
-       dist_model_layertops(j,:)=0
-       do ilev=1,nlev
-          ! Define location of "layer top"
-          if(ilev.eq.1 .or. ilev.eq.nlev) then
-             ztest=zfull(j,ilev)
-          else
-             ztest=0.5_wp*(zfull(j,ilev)+zfull(j,ilev-1))
-          endif
-
-          ! Find MISR layer that contains this level
-          ! *NOTE* the first MISR level is "no height" level
-          iMISR_ztop=2
-          do loop=2,numMISRHgtBins
-             if ( ztest .gt. 1000*misr_histHgt(loop+1) ) then
-                iMISR_ztop=loop+1
-             endif
-          enddo
-          
-          dist_model_layertops(j,iMISR_ztop) = dist_model_layertops(j,iMISR_ztop)+1
-       enddo
-
-       ! For each GCM cell or horizontal model grid point   
-       do ibox=1,ncol
-          ! Compute optical depth as a cummulative distribution in the vertical (nlev).
-          tauOUT(j,ibox)=sum(dtau(j,ibox,1:nlev))
-
-          thres_crossed_MISR=0
-          do ilev=1,nlev
-             ! If there a cloud, start the counter and store this height
-             if(thres_crossed_MISR .eq. 0 .and. dtau(j,ibox,ilev) .gt. 0.) then
-                ! First encountered a "cloud"
-                thres_crossed_MISR = 1  
-                cloud_dtau         = 0            
-             endif
-
-             if( thres_crossed_MISR .lt. 99 .and. thres_crossed_MISR .gt. 0 ) then
-                if( dtau(j,ibox,ilev) .eq. 0.) then
-                   ! We have come to the end of the current cloud layer without yet 
-                   ! selecting a CTH boundary. Restart cloud tau counter 
-                   cloud_dtau=0
-                else
-                   ! Add current optical depth to count for the current cloud layer
-                   cloud_dtau=cloud_dtau+dtau(j,ibox,ilev)
-                endif
-                
-                ! If the cloud is continuous but optically thin (< 1) from above the 
-                ! current layer cloud top to the current level then MISR will like 
-                ! see a top below the top of the current layer.
-                if( dtau(j,ibox,ilev).gt.0 .and. (cloud_dtau-dtau(j,ibox,ilev)) .lt. 1) then
-                   if(dtau(j,ibox,ilev) .lt. 1 .or. ilev.eq.1 .or. ilev.eq.nlev) then
-                      ! MISR will likely penetrate to some point within this layer ... the middle
-                      MISR_penetration_height=zfull(j,ilev)
-                   else
-                      ! Take the OD = 1.0 level into this layer
-                      MISR_penetration_height=0.5_wp*(zfull(j,ilev)+zfull(j,ilev-1)) - &
-                           0.5_wp*(zfull(j,ilev-1)-zfull(j,ilev+1))/dtau(j,ibox,ilev) 
-                   endif
-                   box_MISR_ztop(j,ibox)=MISR_penetration_height
-                endif
-                
-                ! Check for a distinctive water layer
-                if(dtau(j,ibox,ilev) .gt. 1 .and. at(j,ilev) .gt. 273 ) then
-                   ! Must be a water cloud, take this as CTH level
-                   thres_crossed_MISR=99
-                endif
-                
-                ! If the total column optical depth is "large" than MISR can't see
-                ! anything else. Set current point as CTH level
-                if(sum(dtau(j,ibox,1:ilev)) .gt. 5) then
-                   thres_crossed_MISR=99           
-                endif
-             endif
-          enddo  
-          
-          ! Check to see if there was a cloud for which we didn't 
-          ! set a MISR cloud top boundary
-          if( thres_crossed_MISR .eq. 1) then
-             ! If the cloud has a total optical depth of greater
-             ! than ~ 0.5 MISR will still likely pick up this cloud
-             ! with a height near the true cloud top
-             ! otherwise there should be no CTH
-             if(sum(dtau(j,ibox,1:nlev)) .gt. 0.5) then
-                ! keep MISR detected CTH
-             elseif(sum(dtau(j,ibox,1:nlev)) .gt. 0.2) then
-                ! MISR may detect but wont likley have a good height
-                box_MISR_ztop(j,ibox)=-1
-             else
-                ! MISR not likely to even detect.
-                ! so set as not cloudy
-                box_MISR_ztop(j,ibox)=0
-             endif
-          endif
-       enddo  ! loop of subcolumns
-       
-    enddo    ! loop of gridpoints
-    
-    ! Modify MISR CTH for satellite spatial / pattern matcher effects
-    ! Code in this region added by roj 5/2006 to account
-    ! for spatial effect of the MISR pattern matcher.
-    ! Basically, if a column is found between two neighbors
-    ! at the same CTH, and that column has no hieght or
-    ! a lower CTH, THEN misr will tend to but place the
-    ! odd column at the same height as it neighbors.
-    
-    ! This setup assumes the columns represent a about a 1 to 4 km scale
-    ! it will need to be modified significantly, otherwise
-!	! DS2015: Add loop over gridpoints and index accordingly.
-!    if(ncol.eq.1) then
-!       ! Adjust based on neightboring points.
-!       do j=2,npoints-1   
-!          if(box_MISR_ztop(j-1,1) .gt. 0                             .and. &
-!             box_MISR_ztop(j+1,1) .gt. 0                             .and. &
-!             abs(box_MISR_ztop(j-1,1)-box_MISR_ztop(j+1,1)) .lt. 500 .and. &
-!             box_MISR_ztop(j,1) .lt. box_MISR_ztop(j+1,1)) then
-!             box_MISR_ztop(j,1) = box_MISR_ztop(j+1,1)    
-!          endif
-!       enddo
-!    else
-!       ! Adjust based on neighboring subcolumns.
-!       do j=1,npoints
-!          do ibox=2,ncol-1  
-!                 if(box_MISR_ztop(j,ibox-1) .gt. 0                                .and. &
-!                 box_MISR_ztop(j,ibox+1) .gt. 0                                .and. &
-!                 abs(box_MISR_ztop(j,ibox-1)-box_MISR_ztop(j,ibox+1)) .lt. 500 .and. &
-!                 box_MISR_ztop(j,ibox) .lt. box_MISR_ztop(j,ibox+1)) then
-!                 box_MISR_ztop(j,ibox) = box_MISR_ztop(j,ibox+1)    
-!               endif
-!          enddo
-!       enddo
-!    endif
-!    ! DS2015 END
-     
-    ! Fill dark scenes 
-    do j=1,numMISRHgtBins
-       where(sunlit .ne. 1) dist_model_layertops(1:npoints,j) = R_UNDEF
-    enddo
-
-  end SUBROUTINE MISR_SUBCOLUMN
-
-  ! ######################################################################################
-  ! SUBROUTINE misr_column
-  ! ######################################################################################
-  SUBROUTINE MISR_COLUMN(npoints,ncol,box_MISR_ztop,sunlit,tau,MISR_cldarea,MISR_mean_ztop,fq_MISR_TAU_v_CTH)
-
-    ! INPUTS
-    INTEGER, intent(in) :: &
-         npoints,        & ! Number of horizontal gridpoints
-         ncol              ! Number of subcolumns
-    INTEGER, intent(in),dimension(npoints) :: &
-         sunlit            ! 1 for day points, 0 for night time
-    REAL(WP),intent(in),dimension(npoints,ncol) :: &
-         box_MISR_ztop,  & ! Cloud-top height in each column
-         tau               ! Column optical thickness
-
-    ! OUTPUTS
-    REAL(WP),intent(inout),dimension(npoints) :: &
-         MISR_cldarea,   & ! Fraction area covered by clouds
-         MISR_mean_ztop    ! Mean cloud top height MISR would observe
-    REAL(WP),intent(inout),dimension(npoints,7,numMISRHgtBins) :: &
-         fq_MISR_TAU_v_CTH ! Joint histogram of cloud-cover and tau
-
-    ! INTERNAL VARIABLES
-    INTEGER :: j
-    LOGICAL,dimension(ncol) :: box_cloudy 
-    real(wp),dimension(npoints,ncol) :: tauWRK,box_MISR_ztopWRK
-    ! ############################################################################
-
-    ! Compute column quantities and joint-histogram
-    MISR_cldarea(1:npoints)                       = 0._wp
-    MISR_mean_ztop(1:npoints)                     = 0._wp
-    fq_MISR_TAU_v_CTH(1:npoints,1:7,1:numMISRHgtBins) = 0._wp
-    tauWRK(1:npoints,1:ncol)                      = tau(1:npoints,1:ncol)
-    box_MISR_ztopWRK(1:npoints,1:ncol)            = box_MISR_ztop(1:npoints,1:ncol)
-    do j=1,npoints
-
-       ! Subcolumns that are cloudy(true) and not(false)
-       box_cloudy(1:ncol) = merge(.true.,.false.,tau(j,1:ncol) .gt. tauchk)
-
-       ! Fill optically thin clouds with fill value
-       where(.not. box_cloudy(1:ncol)) tauWRK(j,1:ncol)  = -999._wp
-       where(box_MISR_ztopWRK(j,1:ncol) .eq. 0) box_MISR_ztopWRK(j,1:ncol)=-999._wp
-
-       ! Compute joint histogram and column quantities for points that are sunlit and cloudy
-       if (sunlit(j) .eq. 1) then 
-          ! Joint histogram
-          call hist2D(tauWRK(j,1:ncol),box_MISR_ztopWRK(j,1:ncol),ncol,misr_histTau,numMISRTauBins,&
-               1000*misr_histHgt,numMISRHgtBins,fq_MISR_TAU_v_CTH(j,1:numMISRTauBins,1:numMISRHgtBins))
-          fq_MISR_TAU_v_CTH(j,1:numMISRTauBins,1:numMISRHgtBins) =                       &
-             100._wp*fq_MISR_TAU_v_CTH(j,1:numMISRTauBins,1:numMISRHgtBins)/ncol
-
-          ! Column cloud area
-          MISR_cldarea(j)=real(count(box_MISR_ztopWRK(j,1:ncol) .ne. -999.))/ncol
-
-          ! Column cloud-top height
-          if ( count(box_MISR_ztopWRK(j,1:ncol) .ne. -999.) .ne. 0 ) then
-             MISR_mean_ztop(j) = sum(box_MISR_ztopWRK(j,1:ncol),box_MISR_ztopWRK(j,1:ncol) .ne. -999.)/ &
-                  count(box_MISR_ztopWRK(j,1:ncol) .ne. -999.)
-          else
-             MISR_mean_ztop(j) = R_UNDEF
-          endif
-
-       else
-          MISR_cldarea(j)         = R_UNDEF
-          MISR_mean_ztop(npoints) = R_UNDEF
-       endif
-    enddo
-
-  end SUBROUTINE MISR_COLUMN
-
-end MODULE MOD_MISR_SIMULATOR
Index: /LMDZ6/trunk/libf/phylmd/cospv2/MISR_simulator.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cospv2/MISR_simulator.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/cospv2/MISR_simulator.f90	(revision 5268)
@@ -0,0 +1,292 @@
+! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+! Copyright (c) 2009, Roger Marchand, version 1.2
+! All rights reserved.
+!
+! Redistribution and use in source and binary forms, with or without modification, are 
+! permitted provided that the following conditions are met:
+!
+! 1. Redistributions of source code must retain the above copyright notice, this list of 
+!    conditions and the following disclaimer.
+!
+! 2. Redistributions in binary form must reproduce the above copyright notice, this list
+!    of conditions and the following disclaimer in the documentation and/or other 
+!    materials provided with the distribution.
+!
+! 3. Neither the name of the copyright holder nor the names of its contributors may be 
+!    used to endorse or promote products derived from this software without specific prior
+!    written permission.
+!
+! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY 
+! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 
+! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL 
+! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 
+! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT 
+! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 
+! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+!
+! History
+! May 2015 - D. Swales - Modified for COSPv2.0
+! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+MODULE MOD_MISR_SIMULATOR
+  use cosp_kinds,      only: wp
+  use MOD_COSP_STATS,  ONLY: hist2D
+  use mod_cosp_config, ONLY: R_UNDEF,numMISRHgtBins,numMISRTauBins,misr_histHgt,  &
+                             misr_histTau
+  implicit none 
+
+  ! Parameters
+  real(wp),parameter :: &
+       misr_taumin = 0.3_wp,            & ! Minimum optical depth for joint-histogram
+       tauchk      = -1.*log(0.9999999)   ! Lower limit on optical depth
+
+contains
+
+  ! ######################################################################################
+  ! SUBROUTINE misr_subcolumn
+  ! ######################################################################################
+  SUBROUTINE MISR_SUBCOLUMN(npoints,ncol,nlev,dtau,zfull,at,sunlit,tauOUT,               &
+                        dist_model_layertops,box_MISR_ztop)
+    ! INPUTS
+    INTEGER, intent(in) :: &
+         npoints,    & ! Number of horizontal gridpoints
+         ncol,       & ! Number of subcolumns
+         nlev          ! Number of vertical layers
+    INTEGER, intent(in),dimension(npoints) :: &
+         sunlit        ! 1 for day points, 0 for night time
+    REAL(WP),intent(in),dimension(npoints,ncol,nlev) :: &
+         dtau          ! Optical thickness
+    REAL(WP),intent(in),dimension(npoints,nlev) :: &
+         zfull,      & ! Height of full model levels (i.e. midpoints), [nlev] is bottom
+         at            ! Temperature (K)
+
+    ! OUTPUTS
+    REAL(WP),intent(out),dimension(npoints,ncol) :: &
+         box_MISR_ztop,     & ! Cloud-top height in each column
+         tauOUT               ! Optical depth in each column
+    REAL(WP),intent(out),dimension(npoints,numMISRHgtBins) :: &
+         dist_model_layertops ! 
+
+    ! INTERNAL VARIABLES
+    INTEGER :: ilev,j,loop,ibox,thres_crossed_MISR
+    INTEGER :: iMISR_ztop
+    REAL(WP) :: cloud_dtau,MISR_penetration_height,ztest
+
+    ! ############################################################################
+    ! Initialize
+    box_MISR_ztop(1:npoints,1:ncol) = 0._wp  
+
+    do j=1,npoints
+
+       ! Estimate distribution of Model layer tops
+       dist_model_layertops(j,:)=0
+       do ilev=1,nlev
+          ! Define location of "layer top"
+          if(ilev.eq.1 .or. ilev.eq.nlev) then
+             ztest=zfull(j,ilev)
+          else
+             ztest=0.5_wp*(zfull(j,ilev)+zfull(j,ilev-1))
+          endif
+
+          ! Find MISR layer that contains this level
+          ! *NOTE* the first MISR level is "no height" level
+          iMISR_ztop=2
+          do loop=2,numMISRHgtBins
+             if ( ztest .gt. 1000*misr_histHgt(loop+1) ) then
+                iMISR_ztop=loop+1
+             endif
+          enddo
+          
+          dist_model_layertops(j,iMISR_ztop) = dist_model_layertops(j,iMISR_ztop)+1
+       enddo
+
+       ! For each GCM cell or horizontal model grid point   
+       do ibox=1,ncol
+          ! Compute optical depth as a cummulative distribution in the vertical (nlev).
+          tauOUT(j,ibox)=sum(dtau(j,ibox,1:nlev))
+
+          thres_crossed_MISR=0
+          do ilev=1,nlev
+             ! If there a cloud, start the counter and store this height
+             if(thres_crossed_MISR .eq. 0 .and. dtau(j,ibox,ilev) .gt. 0.) then
+                ! First encountered a "cloud"
+                thres_crossed_MISR = 1  
+                cloud_dtau         = 0            
+             endif
+
+             if( thres_crossed_MISR .lt. 99 .and. thres_crossed_MISR .gt. 0 ) then
+                if( dtau(j,ibox,ilev) .eq. 0.) then
+                   ! We have come to the end of the current cloud layer without yet 
+                   ! selecting a CTH boundary. Restart cloud tau counter 
+                   cloud_dtau=0
+                else
+                   ! Add current optical depth to count for the current cloud layer
+                   cloud_dtau=cloud_dtau+dtau(j,ibox,ilev)
+                endif
+                
+                ! If the cloud is continuous but optically thin (< 1) from above the 
+                ! current layer cloud top to the current level then MISR will like 
+                ! see a top below the top of the current layer.
+                if( dtau(j,ibox,ilev).gt.0 .and. (cloud_dtau-dtau(j,ibox,ilev)) .lt. 1) then
+                   if(dtau(j,ibox,ilev) .lt. 1 .or. ilev.eq.1 .or. ilev.eq.nlev) then
+                      ! MISR will likely penetrate to some point within this layer ... the middle
+                      MISR_penetration_height=zfull(j,ilev)
+                   else
+                      ! Take the OD = 1.0 level into this layer
+                      MISR_penetration_height=0.5_wp*(zfull(j,ilev)+zfull(j,ilev-1)) - &
+                           0.5_wp*(zfull(j,ilev-1)-zfull(j,ilev+1))/dtau(j,ibox,ilev) 
+                   endif
+                   box_MISR_ztop(j,ibox)=MISR_penetration_height
+                endif
+                
+                ! Check for a distinctive water layer
+                if(dtau(j,ibox,ilev) .gt. 1 .and. at(j,ilev) .gt. 273 ) then
+                   ! Must be a water cloud, take this as CTH level
+                   thres_crossed_MISR=99
+                endif
+                
+                ! If the total column optical depth is "large" than MISR can't see
+                ! anything else. Set current point as CTH level
+                if(sum(dtau(j,ibox,1:ilev)) .gt. 5) then
+                   thres_crossed_MISR=99           
+                endif
+             endif
+          enddo  
+          
+          ! Check to see if there was a cloud for which we didn't 
+          ! set a MISR cloud top boundary
+          if( thres_crossed_MISR .eq. 1) then
+             ! If the cloud has a total optical depth of greater
+             ! than ~ 0.5 MISR will still likely pick up this cloud
+             ! with a height near the true cloud top
+             ! otherwise there should be no CTH
+             if(sum(dtau(j,ibox,1:nlev)) .gt. 0.5) then
+                ! keep MISR detected CTH
+             elseif(sum(dtau(j,ibox,1:nlev)) .gt. 0.2) then
+                ! MISR may detect but wont likley have a good height
+                box_MISR_ztop(j,ibox)=-1
+             else
+                ! MISR not likely to even detect.
+                ! so set as not cloudy
+                box_MISR_ztop(j,ibox)=0
+             endif
+          endif
+       enddo  ! loop of subcolumns
+       
+    enddo    ! loop of gridpoints
+    
+    ! Modify MISR CTH for satellite spatial / pattern matcher effects
+    ! Code in this region added by roj 5/2006 to account
+    ! for spatial effect of the MISR pattern matcher.
+    ! Basically, if a column is found between two neighbors
+    ! at the same CTH, and that column has no hieght or
+    ! a lower CTH, THEN misr will tend to but place the
+    ! odd column at the same height as it neighbors.
+    
+    ! This setup assumes the columns represent a about a 1 to 4 km scale
+    ! it will need to be modified significantly, otherwise
+!	! DS2015: Add loop over gridpoints and index accordingly.
+!    if(ncol.eq.1) then
+!       ! Adjust based on neightboring points.
+!       do j=2,npoints-1   
+!          if(box_MISR_ztop(j-1,1) .gt. 0                             .and. &
+!             box_MISR_ztop(j+1,1) .gt. 0                             .and. &
+!             abs(box_MISR_ztop(j-1,1)-box_MISR_ztop(j+1,1)) .lt. 500 .and. &
+!             box_MISR_ztop(j,1) .lt. box_MISR_ztop(j+1,1)) then
+!             box_MISR_ztop(j,1) = box_MISR_ztop(j+1,1)    
+!          endif
+!       enddo
+!    else
+!       ! Adjust based on neighboring subcolumns.
+!       do j=1,npoints
+!          do ibox=2,ncol-1  
+!                 if(box_MISR_ztop(j,ibox-1) .gt. 0                                .and. &
+!                 box_MISR_ztop(j,ibox+1) .gt. 0                                .and. &
+!                 abs(box_MISR_ztop(j,ibox-1)-box_MISR_ztop(j,ibox+1)) .lt. 500 .and. &
+!                 box_MISR_ztop(j,ibox) .lt. box_MISR_ztop(j,ibox+1)) then
+!                 box_MISR_ztop(j,ibox) = box_MISR_ztop(j,ibox+1)    
+!               endif
+!          enddo
+!       enddo
+!    endif
+!    ! DS2015 END
+     
+    ! Fill dark scenes 
+    do j=1,numMISRHgtBins
+       where(sunlit .ne. 1) dist_model_layertops(1:npoints,j) = R_UNDEF
+    enddo
+
+  end SUBROUTINE MISR_SUBCOLUMN
+
+  ! ######################################################################################
+  ! SUBROUTINE misr_column
+  ! ######################################################################################
+  SUBROUTINE MISR_COLUMN(npoints,ncol,box_MISR_ztop,sunlit,tau,MISR_cldarea,MISR_mean_ztop,fq_MISR_TAU_v_CTH)
+
+    ! INPUTS
+    INTEGER, intent(in) :: &
+         npoints,        & ! Number of horizontal gridpoints
+         ncol              ! Number of subcolumns
+    INTEGER, intent(in),dimension(npoints) :: &
+         sunlit            ! 1 for day points, 0 for night time
+    REAL(WP),intent(in),dimension(npoints,ncol) :: &
+         box_MISR_ztop,  & ! Cloud-top height in each column
+         tau               ! Column optical thickness
+
+    ! OUTPUTS
+    REAL(WP),intent(inout),dimension(npoints) :: &
+         MISR_cldarea,   & ! Fraction area covered by clouds
+         MISR_mean_ztop    ! Mean cloud top height MISR would observe
+    REAL(WP),intent(inout),dimension(npoints,7,numMISRHgtBins) :: &
+         fq_MISR_TAU_v_CTH ! Joint histogram of cloud-cover and tau
+
+    ! INTERNAL VARIABLES
+    INTEGER :: j
+    LOGICAL,dimension(ncol) :: box_cloudy 
+    real(wp),dimension(npoints,ncol) :: tauWRK,box_MISR_ztopWRK
+    ! ############################################################################
+
+    ! Compute column quantities and joint-histogram
+    MISR_cldarea(1:npoints)                       = 0._wp
+    MISR_mean_ztop(1:npoints)                     = 0._wp
+    fq_MISR_TAU_v_CTH(1:npoints,1:7,1:numMISRHgtBins) = 0._wp
+    tauWRK(1:npoints,1:ncol)                      = tau(1:npoints,1:ncol)
+    box_MISR_ztopWRK(1:npoints,1:ncol)            = box_MISR_ztop(1:npoints,1:ncol)
+    do j=1,npoints
+
+       ! Subcolumns that are cloudy(true) and not(false)
+       box_cloudy(1:ncol) = merge(.true.,.false.,tau(j,1:ncol) .gt. tauchk)
+
+       ! Fill optically thin clouds with fill value
+       where(.not. box_cloudy(1:ncol)) tauWRK(j,1:ncol)  = -999._wp
+       where(box_MISR_ztopWRK(j,1:ncol) .eq. 0) box_MISR_ztopWRK(j,1:ncol)=-999._wp
+
+       ! Compute joint histogram and column quantities for points that are sunlit and cloudy
+       if (sunlit(j) .eq. 1) then 
+          ! Joint histogram
+          call hist2D(tauWRK(j,1:ncol),box_MISR_ztopWRK(j,1:ncol),ncol,misr_histTau,numMISRTauBins,&
+               1000*misr_histHgt,numMISRHgtBins,fq_MISR_TAU_v_CTH(j,1:numMISRTauBins,1:numMISRHgtBins))
+          fq_MISR_TAU_v_CTH(j,1:numMISRTauBins,1:numMISRHgtBins) =                       &
+             100._wp*fq_MISR_TAU_v_CTH(j,1:numMISRTauBins,1:numMISRHgtBins)/ncol
+
+          ! Column cloud area
+          MISR_cldarea(j)=real(count(box_MISR_ztopWRK(j,1:ncol) .ne. -999.))/ncol
+
+          ! Column cloud-top height
+          if ( count(box_MISR_ztopWRK(j,1:ncol) .ne. -999.) .ne. 0 ) then
+             MISR_mean_ztop(j) = sum(box_MISR_ztopWRK(j,1:ncol),box_MISR_ztopWRK(j,1:ncol) .ne. -999.)/ &
+                  count(box_MISR_ztopWRK(j,1:ncol) .ne. -999.)
+          else
+             MISR_mean_ztop(j) = R_UNDEF
+          endif
+
+       else
+          MISR_cldarea(j)         = R_UNDEF
+          MISR_mean_ztop(npoints) = R_UNDEF
+       endif
+    enddo
+
+  end SUBROUTINE MISR_COLUMN
+
+end MODULE MOD_MISR_SIMULATOR
Index: DZ6/trunk/libf/phylmd/cospv2/array_lib.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cospv2/array_lib.F90	(revision 5267)
+++ 	(revision )
@@ -1,103 +1,0 @@
-! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-! Copyright (c) 2015, Regents of the University of Colorado
-! All rights reserved.
-!
-! Redistribution and use in source and binary forms, with or without modification, are 
-! permitted provided that the following conditions are met:
-!
-! 1. Redistributions of source code must retain the above copyright notice, this list of 
-!    conditions and the following disclaimer.
-!
-! 2. Redistributions in binary form must reproduce the above copyright notice, this list
-!    of conditions and the following disclaimer in the documentation and/or other 
-!    materials provided with the distribution.
-!
-! 3. Neither the name of the copyright holder nor the names of its contributors may be 
-!    used to endorse or promote products derived from this software without specific prior
-!    written permission.
-!
-! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY 
-! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 
-! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL 
-! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 
-! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT 
-! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 
-! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
-! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-!
-! History:
-! 10/16/03  John Haynes   - Original version (haynes@atmos.colostate.edu)
-! 01/31/06  John Haynes   - IDL to Fortran 90
-! 01/01/15  Dustin Swales - Modified for COSPv2.0
-! 
-! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-module array_lib
-  USE COSP_KINDS, ONLY: wp
-  implicit none
-contains
-
-  ! ############################################################################
-  !                               function INFIND
-  ! ############################################################################
-  function infind(list,val)
-    implicit none
-    ! ##########################################################################
-    ! Purpose:
-    !   Finds the index of an array that is closest to a value, plus the
-    !   difference between the value found and the value specified
-    !
-    ! Inputs:
-    !   [list]   an array of sequential values
-    !   [val]    a value to locate
-    ! Optional input:
-    !   [sort]   set to 1 if [list] is in unknown/non-sequential order
-    !
-    ! Returns:
-    !   index of [list] that is closest to [val]
-    !
-    ! Optional output:
-    !   [dist]   set to variable containing [list([result])] - [val]
-    !
-    ! Requires:
-    !   mrgrnk library
-    !
-    ! ##########################################################################
-
-    ! INPUTS
-    real(wp), dimension(:), intent(in) :: &
-         list   ! An array of sequential values
-    real(wp), intent(in) :: &
-         val    ! A value to locate
-    ! OUTPUTS
-    integer :: &
-         infind ! Index of [list] that is closest to [val]
-
-    ! Internal Variables
-    real(wp), dimension(size(list)) :: lists
-    integer :: nlist, result, tmp(1), sort_list
-    integer, dimension(size(list)) :: mask
-    
-    sort_list = 0
-    
-    nlist = size(list)
-    lists = list
-    
-    if (val >= lists(nlist)) then
-       result = nlist
-    else if (val <= lists(1)) then
-       result = 1
-    else
-       mask(:) = 0
-       where (lists < val) mask = 1
-       tmp = minloc(mask,1)
-       if (abs(lists(tmp(1)-1)-val) < abs(lists(tmp(1))-val)) then
-          result = tmp(1) - 1
-      else
-         result = tmp(1)
-      endif
-   endif
-   infind = result
- end function infind
-
-end module array_lib
Index: /LMDZ6/trunk/libf/phylmd/cospv2/array_lib.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cospv2/array_lib.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/cospv2/array_lib.f90	(revision 5268)
@@ -0,0 +1,103 @@
+! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+! Copyright (c) 2015, Regents of the University of Colorado
+! All rights reserved.
+!
+! Redistribution and use in source and binary forms, with or without modification, are 
+! permitted provided that the following conditions are met:
+!
+! 1. Redistributions of source code must retain the above copyright notice, this list of 
+!    conditions and the following disclaimer.
+!
+! 2. Redistributions in binary form must reproduce the above copyright notice, this list
+!    of conditions and the following disclaimer in the documentation and/or other 
+!    materials provided with the distribution.
+!
+! 3. Neither the name of the copyright holder nor the names of its contributors may be 
+!    used to endorse or promote products derived from this software without specific prior
+!    written permission.
+!
+! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY 
+! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 
+! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL 
+! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 
+! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT 
+! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 
+! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+!
+! History:
+! 10/16/03  John Haynes   - Original version (haynes@atmos.colostate.edu)
+! 01/31/06  John Haynes   - IDL to Fortran 90
+! 01/01/15  Dustin Swales - Modified for COSPv2.0
+! 
+! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+module array_lib
+  USE COSP_KINDS, ONLY: wp
+  implicit none
+contains
+
+  ! ############################################################################
+  !                               function INFIND
+  ! ############################################################################
+  function infind(list,val)
+    implicit none
+    ! ##########################################################################
+    ! Purpose:
+    !   Finds the index of an array that is closest to a value, plus the
+    !   difference between the value found and the value specified
+    !
+    ! Inputs:
+    !   [list]   an array of sequential values
+    !   [val]    a value to locate
+    ! Optional input:
+    !   [sort]   set to 1 if [list] is in unknown/non-sequential order
+    !
+    ! Returns:
+    !   index of [list] that is closest to [val]
+    !
+    ! Optional output:
+    !   [dist]   set to variable containing [list([result])] - [val]
+    !
+    ! Requires:
+    !   mrgrnk library
+    !
+    ! ##########################################################################
+
+    ! INPUTS
+    real(wp), dimension(:), intent(in) :: &
+         list   ! An array of sequential values
+    real(wp), intent(in) :: &
+         val    ! A value to locate
+    ! OUTPUTS
+    integer :: &
+         infind ! Index of [list] that is closest to [val]
+
+    ! Internal Variables
+    real(wp), dimension(size(list)) :: lists
+    integer :: nlist, result, tmp(1), sort_list
+    integer, dimension(size(list)) :: mask
+    
+    sort_list = 0
+    
+    nlist = size(list)
+    lists = list
+    
+    if (val >= lists(nlist)) then
+       result = nlist
+    else if (val <= lists(1)) then
+       result = 1
+    else
+       mask(:) = 0
+       where (lists < val) mask = 1
+       tmp = minloc(mask,1)
+       if (abs(lists(tmp(1)-1)-val) < abs(lists(tmp(1))-val)) then
+          result = tmp(1) - 1
+      else
+         result = tmp(1)
+      endif
+   endif
+   infind = result
+ end function infind
+
+end module array_lib
Index: DZ6/trunk/libf/phylmd/cospv2/cosp.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cospv2/cosp.F90	(revision 5267)
+++ 	(revision )
@@ -1,3665 +1,0 @@
-! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-! Copyright (c) 2015, Regents of the University of Colorado
-! All rights reserved.
-!
-! Redistribution and use in source and binary forms, with or without modification, are
-! permitted provided that the following conditions are met:
-!
-! 1. Redistributions of source code must retain the above copyright notice, this list of
-!    conditions and the following disclaimer.
-!
-! 2. Redistributions in binary form must reproduce the above copyright notice, this list
-!    of conditions and the following disclaimer in the documentation and/or other
-!    materials provided with the distribution.
-!
-! 3. Neither the name of the copyright holder nor the names of its contributors may be
-!    used to endorse or promote products derived from this software without specific prior
-!    written permission.
-!
-! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY
-! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
-! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL
-! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT
-! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
-! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
-! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-!
-! History:
-! May 2015- D. Swales - Original version
-! Mar 2018- R. Guzman - Added OPAQ diagnostics and GLID simulator
-! Apr 2018- R. Guzman - Added ATLID simulator
-!
-! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-
-
-MODULE MOD_COSP
-  USE COSP_KINDS,                  ONLY: wp
-  USE MOD_COSP_CONFIG,             ONLY: R_UNDEF,PARASOL_NREFL,LIDAR_NCAT,LIDAR_NTYPE, SR_BINS,&
-                                         N_HYDRO,RTTOV_MAX_CHANNELS,numMISRHgtBins,      &
-                                         cloudsat_DBZE_BINS,LIDAR_NTEMP,calipso_histBsct,&
-                                         use_vgrid,Nlvgrid,vgrid_zu,vgrid_zl,vgrid_z,    &
-                                         numMODISTauBins,numMODISPresBins,               &
-                                         numMODISReffIceBins,numMODISReffLiqBins,        &
-                                         numISCCPTauBins,numISCCPPresBins,numMISRTauBins,&
-                                         ntau,modis_histTau,tau_binBounds,               &
-                                         modis_histTauEdges,tau_binEdges,nCloudsatPrecipClass,&
-                                         modis_histTauCenters,tau_binCenters,            &
-!                                         cloudsat_preclvl,grLidar532_histBsct,atlid_histBsct !PREC_BUG
-                                         grLidar532_histBsct,atlid_histBsct                                
-  USE MOD_COSP_MODIS_INTERFACE,      ONLY: cosp_modis_init,       modis_IN
-!  USE MOD_COSP_RTTOV_INTERFACE,      ONLY: cosp_rttov_init,       rttov_IN
-  USE MOD_COSP_MISR_INTERFACE,       ONLY: cosp_misr_init,        misr_IN
-  USE MOD_COSP_ISCCP_INTERFACE,      ONLY: cosp_isccp_init,       isccp_IN
-  USE MOD_COSP_CALIPSO_INTERFACE,    ONLY: cosp_calipso_init,     calipso_IN
-  USE MOD_COSP_ATLID_INTERFACE,      ONLY: cosp_atlid_init,       atlid_IN 
-  USE MOD_COSP_GRLIDAR532_INTERFACE, ONLY: cosp_grLidar532_init, grLidar532_IN
-  USE MOD_COSP_PARASOL_INTERFACE,    ONLY: cosp_parasol_init,     parasol_in
-  USE MOD_COSP_CLOUDSAT_INTERFACE,   ONLY: cosp_cloudsat_init,    cloudsat_IN
-  USE quickbeam,                     ONLY: quickbeam_subcolumn,   quickbeam_column, radar_cfg
-  USE MOD_ICARUS,                    ONLY: icarus_subcolumn,      icarus_column
-  USE MOD_MISR_SIMULATOR,            ONLY: misr_subcolumn,        misr_column
-  USE MOD_LIDAR_SIMULATOR,           ONLY: lidar_subcolumn,       lidar_column
-  USE MOD_MODIS_SIM,                 ONLY: modis_subcolumn,       modis_column
-  USE MOD_PARASOL,                   ONLY: parasol_subcolumn,     parasol_column
-!  use mod_cosp_rttov,                ONLY: rttov_column
-  USE MOD_COSP_STATS,                ONLY: COSP_LIDAR_ONLY_CLOUD,COSP_CHANGE_VERTICAL_GRID
-
-  IMPLICIT NONE
-
-  logical :: linitialization ! Initialization flag
-
-  ! ######################################################################################
-  ! TYPE cosp_column_inputs
-  ! ######################################################################################
-  type cosp_column_inputs
-     integer :: &
-          Npoints,             & ! Number of gridpoints.
-          Ncolumns,            & ! Number of columns.
-          Nlevels                ! Number of levels.
-
-     integer,allocatable,dimension(:) :: &
-          sunlit                 ! Sunlit flag                            (0-1)
-
-     real(wp),allocatable,dimension(:,:) :: &
-          at,                  & ! Temperature                            (K)
-          pfull,               & ! Pressure                               (Pa)
-          phalf,               & ! Pressure at half-levels                (Pa)
-          qv,                  & ! Specific humidity                      (kg/kg)
-          hgt_matrix,          & ! Height of hydrometeors                 (km)
-          hgt_matrix_half        ! Height of hydrometeors at half levels  (km)
-
-     real(wp),allocatable,dimension(:) :: &
-          land,                & ! Land/Sea mask                          (0-1)
-          skt,                 & ! Surface temperature                    (K)
-          surfelev               ! Surface Elevation                      (m)
-     ! Fields used ONLY by RTTOV
-     integer :: &
-          month                  ! Month for surface emissivty atlas      (1-12)
-     real(wp) :: &
-          zenang,              & ! Satellite zenith angle for RTTOV       (deg)
-          co2,                 & ! CO2                                    (kg/kg)
-          ch4,                 & ! Methane                                (kg/kg)
-          n2o,                 & ! N2O                                    (kg/kg)
-          co                     ! CO                                     (kg/kg)
-     real(wp),allocatable,dimension(:) :: &
-          emis_sfc,            & ! Surface emissivity                     (1)
-          u_sfc,               & ! Surface u-wind                         (m/s)
-          v_sfc,               & ! Surface v-wind                         (m/s)
-          seaice,              & ! Sea-ice fraction                       (0-1)
-          lat,                 & ! Latitude                              (deg)
-          lon                    ! Longitude                              (deg)
-     real(wp),allocatable,dimension(:,:) :: &
-          o3,                  & ! Ozone                                  (kg/kg)
-          tca,                 & ! Total column cloud fraction            (0-1)
-          cloudIce,            & ! Cloud ice water mixing ratio           (kg/kg)
-          cloudLiq,            & ! Cloud liquid water mixing ratio        (kg/kg)
-          fl_rain,             & ! Precipitation (rain) flux              (kg/m2/s)
-          fl_snow                ! Precipitation (snow) flux              (kg/m2/s)
-  end type cosp_column_inputs
-
-  ! ######################################################################################
-  ! TYPE cosp_optical_inputs
-  ! ######################################################################################
-  type cosp_optical_inputs
-     integer :: &
-          Npoints,             & ! Number of gridpoints.
-          Ncolumns,            & ! Number of columns.
-          Nlevels,             & ! Number of levels.
-          Npart,               & ! Number of cloud meteors for LIDAR simulators.
-          Nrefl                  ! Number of reflectances for PARASOL simulator
-     real(wp) :: &
-          emsfc_lw               ! Surface emissivity @ 11micron
-     real(wp),allocatable,dimension(:,:,:) :: &
-          frac_out,            & ! Cloud fraction
-          tau_067,             & ! Optical depth @ 0.67micron
-          emiss_11,            & ! Emissivity @ 11 micron
-          fracLiq,             & ! Fraction of optical-depth due to liquid (MODIS)
-          asym,                & ! Assymetry parameter @ 3.7micron (MODIS)
-          ss_alb,              & ! Single-scattering albedo @ 3.7micron (MODIS)
-          betatot_calipso,     & ! Lidar backscatter coefficient (calipso @ 532nm)
-          betatot_grLidar532,  & ! Lidar backscatter coefficient (ground-lidar @ 532nm)
-          betatot_atlid,       & ! Lidar backscatter coefficient (atlid @ 355nm)
-          betatot_ice_calipso, & ! Lidar backscatter coefficient ICE (calipso @ 532nm)
-          betatot_liq_calipso, & ! Lidar backscatter coefficient LIQUID (calipso @ 532nm)
-          tautot_calipso,      & ! Lidar Optical thickness (calipso @ 532nm)
-          tautot_grLidar532,   & ! Lidar Optical thickness (ground-lidar @ 532nm)  
-          tautot_atlid,        & ! Lidar Optical thickness (atlid @ 355nm)
-          tautot_ice_calipso,  & ! Lidar Ice Optical thickness (calipso @ 532nm)
-          tautot_liq_calipso,  & ! Lidar Liquid Optical thickness (calipso @ 532nm)
-          z_vol_cloudsat,      & ! Effective reflectivity factor (mm^6/m^3)
-          kr_vol_cloudsat,     & ! Attenuation coefficient hydro (dB/km) 
-          g_vol_cloudsat         ! Attenuation coefficient gases (dB/km)
-     real(wp),allocatable,dimension(:,:) :: &
-          beta_mol_calipso,    & ! Lidar molecular backscatter coefficient (calipso @ 532nm)
-          beta_mol_grLidar532, & ! Lidar molecular backscatter coefficient (ground-lidar @ 532nm) 
-          beta_mol_atlid,      & ! Lidar molecular backscatter coefficient (atlid @ 355nm)
-          tau_mol_calipso,     & ! Lidar molecular optical depth (calipso @ 532nm)
-          tau_mol_grLidar532,  & ! Lidar molecular optical depth (ground-lidar @ 532nm) 
-          tau_mol_atlid,       & ! Lidar molecular optical depth (atlid @ 355nm)
-          tautot_S_liq,        & ! Parasol Liquid water optical thickness, from TOA to SFC
-          tautot_S_ice,        & ! Parasol Ice water optical thickness, from TOA to SFC
-          fracPrecipIce          ! Fraction of precipitation which is frozen (1).
-     type(radar_cfg) :: &
-          rcfg_cloudsat          ! Radar configuration information (CLOUDSAT)
-  end type cosp_optical_inputs
-
-  ! ######################################################################################
-  ! TYPE cosp_outputs
-  ! ######################################################################################
-  type cosp_outputs
-
-     ! CALIPSO outputs
-     real(wp),dimension(:,:,:),pointer :: &
-          calipso_betaperp_tot => null(),  & ! Total backscattered signal
-          calipso_beta_tot => null(),      & ! Total backscattered signal
-          calipso_tau_tot => null(),       & ! Optical thickness integrated from top to level z
-          calipso_lidarcldphase => null(), & ! 3D "lidar" phase cloud fraction
-          calipso_lidarcldtype => null(),  & ! 3D "lidar" OPAQ type fraction
-          calipso_cldlayerphase => null(), & ! low, mid, high-level lidar phase cloud cover
-          calipso_lidarcldtmp => null(),   & ! 3D "lidar" phase cloud temperature
-          calipso_cfad_sr => null()          ! CFAD of scattering ratio
-     real(wp), dimension(:,:),pointer :: &
-          calipso_lidarcld => null(),      & ! 3D "lidar" cloud fraction 
-          calipso_cldlayer => null(),      & ! low, mid, high-level, total lidar cloud cover
-          calipso_cldtype => null(),       & ! opaque and thin lidar cloud cover + z_opaque altitude
-          calipso_cldtypetemp => null(),   & ! opaque and thin cloud temperature  
-          calipso_cldtypemeanz => null(),  & ! opaque and thin cloud altitude 
-          calipso_cldtypemeanzse => null(),& ! same as just above with respect to SE
-          calipso_beta_mol => null(),      & ! Molecular backscatter
-          calipso_temp_tot => null()
-     real(wp), dimension(:),pointer :: &
-          calipso_cldthinemis => null(),   & ! thin cloud emissivity 
-          calipso_srbval => null()           ! SR bins in cfad_sr
-
-     ! GROUND LIDAR outputs
-     real(wp),dimension(:,:,:),pointer :: &  
-          grLidar532_beta_tot => null(),   & ! Total GROUND LIDAR backscattered signal 
-          grLidar532_cfad_sr => null()       ! CFAD of GROUND LIDAR scattering ratio 
-     real(wp), dimension(:,:),pointer :: &  
-          grLidar532_lidarcld => null(),   & ! 3D GROUND "lidar" cloud fraction  
-          grLidar532_cldlayer => null(),   & ! low, mid, high-level, total GROUND lidar cloud cover
-          grLidar532_beta_mol => null()      ! GROUND LIDAR Molecular backscatter 
-     real(wp), dimension(:),pointer :: &  
-          grLidar532_srbval => null()        ! SR bins in cfad_sr
-
-     ! ATLID outputs
-     real(wp),dimension(:,:,:),pointer :: & 
-          atlid_beta_tot => null(),   & ! Total ATLID backscattered signal 
-          atlid_cfad_sr => null()       ! CFAD of ATLID scattering ratio 
-     real(wp), dimension(:,:),pointer :: & 
-          atlid_lidarcld => null(),   & ! 3D ATLID cloud fraction
-          atlid_cldlayer => null(),   & ! low, mid, high-level, total ATLID cloud cover 
-          atlid_beta_mol => null()      ! ATLID Molecular backscatter 
-     real(wp), dimension(:),pointer :: & 
-          atlid_srbval => null()        ! SR bins in cfad_sr
-
-
-     ! PARASOL outputs
-     real(wp),dimension(:,:,:),pointer :: &
-          parasolPix_refl => null()            ! PARASOL reflectances (subcolumn)
-     real(wp),dimension(:,:),pointer :: &
-          parasolGrid_refl => null()           ! PARASOOL reflectances (column)
-
-     ! CLOUDSAT outputs
-     real(wp),dimension(:,:,:),pointer :: &
-          cloudsat_Ze_tot => null(),         & ! Effective reflectivity factor (Npoints,Ncolumns,Nlevels)
-          cloudsat_cfad_ze => null()           ! Ze CFAD(Npoints,dBZe_bins,Nlevels)
-     real(wp), dimension(:,:),pointer :: &
-          lidar_only_freq_cloud => null(),   & ! (Npoints,Nlevels)
-          cloudsat_precip_cover => null()      ! Radar total cloud amount by CloudSat precip flag (Npoints,dBZe_bins)
-     real(wp),dimension(:),pointer :: &
-          cloudsat_tcc => null(),             &
-          cloudsat_tcc2 => null(),            &          
-          radar_lidar_tcc => null(),         & ! Radar&lidar total cloud amount, grid-box scale (Npoints)
-          cloudsat_pia => null()               ! Radar path integrated attenuation (Npoints)
-          
-     ! ISCCP outputs       
-     real(wp),dimension(:),pointer :: &
-          isccp_totalcldarea => null(), & ! The fraction of model grid box columns with cloud
-           		                  ! somewhere in them. (%)
-          isccp_meantb => null(),       & ! Mean all-sky 10.5 micron brightness temperature. (K)
-          isccp_meantbclr => null(),    & ! Mean clear-sky 10.5 micron brightness temperature. (K)
-          isccp_meanptop => null(),     & ! Mean cloud top pressure (mb).
-          isccp_meantaucld => null(),   & ! Mean optical thickness. (1)
-          isccp_meanalbedocld => null()   ! Mean cloud albedo. (1)
-     real(wp),dimension(:,:),pointer ::&
-          isccp_boxtau => null(),       & ! Optical thickness in each column. (1)
-          isccp_boxptop => null()         ! Cloud top pressure in each column. (mb)
-     real(wp),dimension(:,:,:),pointer :: &
-          isccp_fq  => null()             ! The fraction of the model grid box covered by each of
-                                          ! the 49 ISCCP D level cloud types. (%)
-
-     ! MISR outptus
-     real(wp),dimension(:,:,:),pointer ::   & !
-          misr_fq => null()          ! Fraction of the model grid box covered by each of the MISR
-                           ! cloud types
-     real(wp),dimension(:,:),pointer ::   & !
-          misr_dist_model_layertops => null() !
-     real(wp),dimension(:),pointer ::   & !
-          misr_meanztop => null(), & ! Mean MISR cloud top height
-          misr_cldarea => null()     ! Mean MISR cloud cover area
-
-     ! MODIS outptus
-     real(wp),pointer,dimension(:) ::      & !
-          modis_Cloud_Fraction_Total_Mean => null(),       & ! L3 MODIS retrieved cloud fraction (total)
-          modis_Cloud_Fraction_Water_Mean => null(),       & ! L3 MODIS retrieved cloud fraction (liq)
-          modis_Cloud_Fraction_Ice_Mean => null(),         & ! L3 MODIS retrieved cloud fraction (ice)
-          modis_Cloud_Fraction_High_Mean => null(),        & ! L3 MODIS retrieved cloud fraction (high)
-          modis_Cloud_Fraction_Mid_Mean => null(),         & ! L3 MODIS retrieved cloud fraction (middle)
-          modis_Cloud_Fraction_Low_Mean => null(),         & ! L3 MODIS retrieved cloud fraction (low )
-          modis_Optical_Thickness_Total_Mean => null(),    & ! L3 MODIS retrieved optical thickness (tot)
-          modis_Optical_Thickness_Water_Mean => null(),    & ! L3 MODIS retrieved optical thickness (liq)
-          modis_Optical_Thickness_Ice_Mean => null(),      & ! L3 MODIS retrieved optical thickness (ice)
-          modis_Optical_Thickness_Total_LogMean => null(), & ! L3 MODIS retrieved log10 optical thickness
-          modis_Optical_Thickness_Water_LogMean => null(), & ! L3 MODIS retrieved log10 optical thickness
-          modis_Optical_Thickness_Ice_LogMean => null(),   & ! L3 MODIS retrieved log10 optical thickness
-          modis_Cloud_Particle_Size_Water_Mean => null(),  & ! L3 MODIS retrieved particle size (liquid)
-          modis_Cloud_Particle_Size_Ice_Mean => null(),    & ! L3 MODIS retrieved particle size (ice)
-          modis_Cloud_Top_Pressure_Total_Mean => null(),   & ! L3 MODIS retrieved cloud top pressure
-          modis_Liquid_Water_Path_Mean => null(),          & ! L3 MODIS retrieved liquid water path
-          modis_Ice_Water_Path_Mean => null()                ! L3 MODIS retrieved ice water path
-     real(wp),pointer,dimension(:,:,:) ::  &
-          modis_Optical_Thickness_vs_Cloud_Top_Pressure => null(), & ! Tau/Pressure joint histogram
-          modis_Optical_Thickness_vs_ReffICE => null(),            & ! Tau/ReffICE joint histogram
-          modis_Optical_Thickness_vs_ReffLIQ => null()               ! Tau/ReffLIQ joint histogram
-
-     ! RTTOV outputs
-     real(wp),pointer :: &
-          rttov_tbs(:,:) => null() ! Brightness Temperature
-
-  end type cosp_outputs
-
-CONTAINS
-  ! ######################################################################################
-  ! FUNCTION cosp_simulator
-  ! ######################################################################################
-  function COSP_SIMULATOR(cospIN,cospgridIN,cospOUT,start_idx,stop_idx,debug)
-    type(cosp_optical_inputs),intent(in),target :: cospIN     ! Optical inputs to COSP simulator
-    type(cosp_column_inputs), intent(in),target :: cospgridIN ! Host model inputs to COSP
-
-    ! Inputs into the simulators
-    type(isccp_IN)    :: isccpIN    ! Input to the ISCCP simulator
-    type(misr_IN)     :: misrIN     ! Input to the LIDAR simulator
-    type(calipso_IN)  :: calipsoIN  ! Input to the LIDAR simulator
-    type(grLidar532_IN) :: grLidar532IN ! Input to the GROUND LIDAR simulator
-    type(atlid_IN)    :: atlidIN    ! Input to the ATLID simulator 
-    type(parasol_IN)  :: parasolIN  ! Input to the PARASOL simulator
-    type(cloudsat_IN) :: cloudsatIN ! Input to the CLOUDSAT radar simulator
-    type(modis_IN)    :: modisIN    ! Input to the MODIS simulator
-!    type(rttov_IN)    :: rttovIN    ! Input to the RTTOV simulator
-    integer,optional  :: start_idx,stop_idx
-    logical,optional  :: debug
-
-    ! Outputs from the simulators (nested simulator output structure)
-    type(cosp_outputs), intent(inout) :: cospOUT
-    character(len=256),dimension(100) :: cosp_simulator
-
-    ! Local variables
-    integer :: &
-         i,icol,ij,ik,nError
-    integer,target :: &
-         Npoints
-    logical :: &
-         Lisccp_subcolumn,     & ! On/Off switch for subcolumn ISCCP simulator
-         Lmisr_subcolumn,      & ! On/Off switch for subcolumn MISR simulator
-         Lcalipso_subcolumn,   & ! On/Off switch for subcolumn CALIPSO simulator
-         LgrLidar532_subcolumn,& ! On/Off switch for subcolumn GROUND LIDAR simulator
-         Latlid_subcolumn,     & ! On/Off switch for subcolumn ATLID simulator
-         Lparasol_subcolumn,   & ! On/Off switch for subcolumn PARASOL simulator
-         Lcloudsat_subcolumn,  & ! On/Off switch for subcolumn CLOUDSAT simulator
-         Lmodis_subcolumn,     & ! On/Off switch for subcolumn MODIS simulator
-         Lrttov_subcolumn,     & ! On/Off switch for subcolumn RTTOV simulator
-         Lisccp_column,        & ! On/Off switch for column ISCCP simulator
-         Lmisr_column,         & ! On/Off switch for column MISR simulator
-         Lcalipso_column,      & ! On/Off switch for column CALIPSO simulator
-         LgrLidar532_column,   & ! On/Off switch for column GROUND LIDAR simulator
-         Latlid_column,        & ! On/Off switch for column ATLID simulator
-         Lparasol_column,      & ! On/Off switch for column PARASOL simulator
-         Lcloudsat_column,     & ! On/Off switch for column CLOUDSAT simulator
-         Lmodis_column,        & ! On/Off switch for column MODIS simulator
-         Lrttov_column,        & ! On/Off switch for column RTTOV simulator (not used)
-         Lradar_lidar_tcc,     & ! On/Off switch from joint Calipso/Cloudsat product
-         Lcloudsat_tcc,       & !
-         Lcloudsat_tcc2,      & !         
-         Llidar_only_freq_cloud  ! On/Off switch from joint Calipso/Cloudsat product
-    logical :: &
-         ok_lidar_cfad    = .false., &
-         ok_lidar_cfad_grLidar532 = .false., & 
-         ok_lidar_cfad_atlid = .false., &
-         lrttov_cleanUp   = .false.
-    
-    integer, dimension(:,:),allocatable  :: &
-         modisRetrievedPhase,isccpLEVMATCH
-    real(wp), dimension(:),  allocatable  :: &
-         modisCfTotal,modisCfLiquid,modisMeanIceWaterPath, isccp_meantbclr,     &
-         modisCfIce, modisCfHigh, modisCfMid, modisCfLow,modisMeanTauTotal,     &
-         modisMeanTauLiquid, modisMeanTauIce, modisMeanLogTauTotal,             &
-         modisMeanLogTauLiquid, modisMeanLogTauIce, modisMeanSizeLiquid,        &
-         modisMeanSizeIce, modisMeanCloudTopPressure, modisMeanLiquidWaterPath, &
-         radar_lidar_tcc, cloudsat_tcc, cloudsat_tcc2
-    REAL(WP), dimension(:,:),allocatable  :: &
-         modisRetrievedCloudTopPressure,modisRetrievedTau,modisRetrievedSize,   &
-         misr_boxtau,misr_boxztop,misr_dist_model_layertops,isccp_boxtau,       &
-         isccp_boxttop,isccp_boxptop,calipso_beta_mol,lidar_only_freq_cloud,    &
-         grLidar532_beta_mol,atlid_beta_mol 
-    REAL(WP), dimension(:,:,:),allocatable :: &
-         modisJointHistogram,modisJointHistogramIce,modisJointHistogramLiq,     &
-         calipso_beta_tot,calipso_betaperp_tot, cloudsatDBZe,parasolPix_refl,   &
-         grLidar532_beta_tot,atlid_beta_tot,cloudsatZe_non
-    real(wp),dimension(:),allocatable,target :: &
-         out1D_1,out1D_2,out1D_3,out1D_4,out1D_5,out1D_6,out1D_7,out1D_8,       &
-         out1D_9,out1D_10,out1D_11,out1D_12 
-    real(wp),dimension(:,:,:),allocatable :: &
-       betamol_in,betamoli,pnormi,ze_toti,ze_noni
-
-    ! Initialize error reporting for output
-    cosp_simulator(:)=''
-
-    !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-    ! 1) Determine if using full inputs or subset
-    !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-    if (present(start_idx) .and. present(stop_idx)) then
-       ij=start_idx
-       ik=stop_idx
-    else
-       ij=1
-       ik=cospIN%Npoints
-    endif
-    Npoints = ik-ij+1
-
-    !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-    ! 2a) Determine which simulators to run and which statistics to compute
-    !    - If any of the subcolumn fields are allocated, then run the subcolumn simulators.
-    !    - If any of the column fields are allocated, then compute the statistics for that
-    !      simulator, but only save the requested fields.
-    !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-    ! Start with all simulators and joint-diagnostics off
-    Lisccp_subcolumn    = .false.
-    Lmisr_subcolumn     = .false.
-    Lcalipso_subcolumn  = .false.
-    LgrLidar532_subcolumn = .false.
-    Latlid_subcolumn    = .false. 
-    Lparasol_subcolumn  = .false.
-    Lcloudsat_subcolumn = .false.
-    Lmodis_subcolumn    = .false.
-    Lrttov_subcolumn    = .false.
-    Lisccp_column       = .false.
-    Lmisr_column        = .false.
-    Lcalipso_column     = .false.
-    LgrLidar532_column = .false.
-    Latlid_column       = .false.
-    Lparasol_column     = .false.
-    Lcloudsat_column    = .false.
-    Lmodis_column       = .false.
-    Lrttov_column       = .false.
-    Lradar_lidar_tcc    = .false.
-    Llidar_only_freq_cloud = .false.
-    Lcloudsat_tcc       = .false.
-    Lcloudsat_tcc2      = .false.
-
-    ! CLOUDSAT subcolumn
-    if (associated(cospOUT%cloudsat_Ze_tot)) Lcloudsat_subcolumn = .true.
-
-    ! MODIS subcolumn
-    if (associated(cospOUT%modis_Cloud_Fraction_Water_Mean)                .or.          &
-        associated(cospOUT%modis_Cloud_Fraction_Total_Mean)                .or.          &
-        associated(cospOUT%modis_Cloud_Fraction_Ice_Mean)                  .or.          &
-        associated(cospOUT%modis_Cloud_Fraction_High_Mean)                 .or.          &
-        associated(cospOUT%modis_Cloud_Fraction_Mid_Mean)                  .or.          &
-        associated(cospOUT%modis_Cloud_Fraction_Low_Mean)                  .or.          &
-        associated(cospOUT%modis_Optical_Thickness_Total_Mean)             .or.          &
-        associated(cospOUT%modis_Optical_Thickness_Water_Mean)             .or.          &
-        associated(cospOUT%modis_Optical_Thickness_Ice_Mean)               .or.          &
-        associated(cospOUT%modis_Optical_Thickness_Total_LogMean)          .or.          &
-        associated(cospOUT%modis_Optical_Thickness_Water_LogMean)          .or.          &
-        associated(cospOUT%modis_Optical_Thickness_Ice_LogMean)            .or.          &
-        associated(cospOUT%modis_Cloud_Particle_Size_Water_Mean)           .or.          &
-        associated(cospOUT%modis_Cloud_Particle_Size_Ice_Mean)             .or.          &
-        associated(cospOUT%modis_Cloud_Top_Pressure_Total_Mean)            .or.          &
-        associated(cospOUT%modis_Liquid_Water_Path_Mean)                   .or.          &
-        associated(cospOUT%modis_Ice_Water_Path_Mean)                      .or.          &
-        associated(cospOUT%modis_Optical_Thickness_vs_Cloud_Top_Pressure))               &
-       Lmodis_subcolumn    = .true.
-
-    ! ISCCP subcolumn
-    if (associated(cospOUT%isccp_boxtau)                                   .or.          &
-        associated(cospOUT%isccp_boxptop))                                               &
-       Lisccp_subcolumn    = .true.
-
-    ! MISR subcolumn
-    if (associated(cospOUT%misr_dist_model_layertops))                                   &
-       Lmisr_subcolumn     = .true.
-
-    ! CALIPOSO subcolumn
-    if (associated(cospOUT%calipso_tau_tot)                                .or.          &
-        associated(cospOUT%calipso_beta_mol)                               .or.          &
-        associated(cospOUT%calipso_temp_tot)                               .or.          &
-        associated(cospOUT%calipso_betaperp_tot)                           .or.          &
-        associated(cospOUT%calipso_beta_tot))                                            &
-       Lcalipso_subcolumn  = .true.
-
-    ! GROUND LIDAR subcolumn 
-    if (associated(cospOUT%grLidar532_beta_mol)                           .or.          &
-        associated(cospOUT%grLidar532_beta_tot))                                        &
-       LgrLidar532_subcolumn  = .true. 
-
-    ! ATLID subcolumn
-    if (associated(cospOUT%atlid_beta_mol)                                 .or.          & 
-        associated(cospOUT%atlid_beta_tot))                                              &
-       Latlid_subcolumn  = .true.  
-
-    ! PARASOL subcolumn
-    if (associated(cospOUT%parasolPix_refl))                                             &
-       Lparasol_subcolumn  = .true.
-
-    ! RTTOV column
-    if (associated(cospOUT%rttov_tbs))                                                   &
-       Lrttov_column    = .true.
-
-    ! Set flag to deallocate rttov types (only done on final call to simulator)
-    if (size(cospOUT%isccp_meantb) .eq. stop_idx) lrttov_cleanUp = .true.
-
-    ! ISCCP column
-    if (associated(cospOUT%isccp_fq)                                       .or.          &
-        associated(cospOUT%isccp_meanalbedocld)                            .or.          &
-        associated(cospOUT%isccp_meanptop)                                 .or.          &
-        associated(cospOUT%isccp_meantaucld)                               .or.          &
-        associated(cospOUT%isccp_totalcldarea)                             .or.          &
-        associated(cospOUT%isccp_meantb)) then
-       Lisccp_column    = .true.
-       Lisccp_subcolumn = .true.
-    endif
-
-    ! MISR column
-    if (associated(cospOUT%misr_cldarea)                                   .or.          &
-        associated(cospOUT%misr_meanztop)                                  .or.          &
-        associated(cospOUT%misr_fq)) then
-       Lmisr_column    = .true.
-       Lmisr_subcolumn = .true.
-    endif
-
-    ! CALIPSO column
-    if (associated(cospOUT%calipso_cfad_sr)                                .or.          &
-        associated(cospOUT%calipso_lidarcld)                               .or.          &
-        associated(cospOUT%calipso_lidarcldphase)                          .or.          &
-        associated(cospOUT%calipso_lidarcldtype)                           .or.          &
-        associated(cospOUT%calipso_cldlayer)                               .or.          &
-        associated(cospOUT%calipso_cldtype)                                .or.          & 
-        associated(cospOUT%calipso_cldtypetemp)                            .or.          & 
-        associated(cospOUT%calipso_cldtypemeanz)                           .or.          & 
-        associated(cospOUT%calipso_cldtypemeanzse)                         .or.          & 
-        associated(cospOUT%calipso_cldthinemis)                            .or.          &
-        associated(cospOUT%calipso_cldlayerphase)                          .or.          &
-        associated(cospOUT%calipso_lidarcldtmp)) then
-       Lcalipso_column    = .true.
-       Lcalipso_subcolumn = .true.
-    endif
-
-    ! GROUND LIDAR column 
-    if (associated(cospOUT%grLidar532_cfad_sr)                            .or.          & 
-        associated(cospOUT%grLidar532_lidarcld)                           .or.          & 
-        associated(cospOUT%grLidar532_cldlayer)) then 
-       LgrLidar532_column    = .true. 
-       LgrLidar532_subcolumn = .true. 
-    endif
-
-    ! ATLID column 
-    if (associated(cospOUT%atlid_cfad_sr)                                  .or.          & 
-        associated(cospOUT%atlid_lidarcld)                                 .or.          & 
-        associated(cospOUT%atlid_cldlayer)) then  
-       Latlid_column    = .true. 
-       Latlid_subcolumn = .true.
-    endif
-
-    ! PARASOL column
-    if (associated(cospOUT%parasolGrid_refl)) then
-       Lparasol_column    = .true.
-       Lparasol_subcolumn = .true.
-    endif
-
-    ! CLOUDSAT column
-    if (associated(cospOUT%cloudsat_cfad_ze)) then
-       Lcloudsat_column    = .true.
-       Lcloudsat_subcolumn = .true.
-    endif
-
-    ! MODIS column
-    if (associated(cospOUT%modis_Cloud_Fraction_Total_Mean)                .or.          &
-        associated(cospOUT%modis_Cloud_Fraction_Water_Mean)                .or.          &
-        associated(cospOUT%modis_Cloud_Fraction_Ice_Mean)                  .or.          &
-        associated(cospOUT%modis_Cloud_Fraction_High_Mean)                 .or.          &
-        associated(cospOUT%modis_Cloud_Fraction_Mid_Mean)                  .or.          &
-        associated(cospOUT%modis_Cloud_Fraction_Low_Mean)                  .or.          &
-        associated(cospOUT%modis_Optical_Thickness_Total_Mean)             .or.          &
-        associated(cospOUT%modis_Optical_Thickness_Water_Mean)             .or.          &
-        associated(cospOUT%modis_Optical_Thickness_Ice_Mean)               .or.          &
-        associated(cospOUT%modis_Optical_Thickness_Total_LogMean)          .or.          &
-        associated(cospOUT%modis_Optical_Thickness_Water_LogMean)          .or.          &
-        associated(cospOUT%modis_Optical_Thickness_Ice_LogMean)            .or.          &
-        associated(cospOUT%modis_Cloud_Particle_Size_Water_Mean)           .or.          &
-        associated(cospOUT%modis_Cloud_Particle_Size_Ice_Mean)             .or.          &
-        associated(cospOUT%modis_Cloud_Top_Pressure_Total_Mean)            .or.          &
-        associated(cospOUT%modis_Liquid_Water_Path_Mean)                   .or.          &
-        associated(cospOUT%modis_Ice_Water_Path_Mean)                      .or.          &
-        associated(cospOUT%modis_Optical_Thickness_vs_Cloud_Top_Pressure)) then
-       Lmodis_column    = .true.
-       Lmodis_subcolumn = .true.
-    endif
-
-    ! Joint simulator products
-    if (associated(cospOUT%lidar_only_freq_cloud) .or. associated(cospOUT%radar_lidar_tcc) .or. &
-        associated(cospOUT%cloudsat_tcc) .or. associated(cospOUT%cloudsat_tcc2)) then
-       Lcalipso_column     = .true.
-       Lcalipso_subcolumn  = .true.
-       Lcloudsat_column    = .true.
-       Lcloudsat_subcolumn = .true.
-       Lradar_lidar_tcc    = .true.
-       Llidar_only_freq_cloud = .true.
-       Lcloudsat_tcc       = .true.
-       Lcloudsat_tcc2      = .true.
-    endif
-
-    !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-    ! 2b) Error Checking
-    !     Enforce bounds on input fields. If input field is out-of-bounds, report error
-    !     and turn off simulator
-    !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-    call cosp_errorCheck(cospgridIN, cospIN, Lisccp_subcolumn, Lisccp_column,            &
-         Lmisr_subcolumn, Lmisr_column, Lmodis_subcolumn, Lmodis_column,                 &
-         Lcloudsat_subcolumn, Lcloudsat_column, Lcalipso_subcolumn, Lcalipso_column,     &
-         Latlid_subcolumn, Latlid_column, LgrLidar532_subcolumn, LgrLidar532_column,     &
-         Lrttov_subcolumn, Lrttov_column, Lparasol_subcolumn, Lparasol_column,           &
-         Lradar_lidar_tcc, Llidar_only_freq_cloud, Lcloudsat_tcc,Lcloudsat_tcc2, cospOUT,&
-         cosp_simulator, nError)
-
-    !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-    ! 3) Populate instrument simulator inputs
-    !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-    if (Lisccp_subcolumn .or. Lmodis_subcolumn) then
-       isccpIN%Npoints  => Npoints
-       isccpIN%Ncolumns => cospIN%Ncolumns
-       isccpIN%Nlevels  => cospIN%Nlevels
-       isccpIN%emsfc_lw => cospIN%emsfc_lw
-       isccpIN%skt      => cospgridIN%skt
-       isccpIN%qv       => cospgridIN%qv
-       isccpIN%at       => cospgridIN%at
-       isccpIN%frac_out => cospIN%frac_out
-       isccpIN%dtau     => cospIN%tau_067
-       isccpIN%dem      => cospIN%emiss_11
-       isccpIN%phalf    => cospgridIN%phalf
-       isccpIN%sunlit   => cospgridIN%sunlit
-       isccpIN%pfull    => cospgridIN%pfull
-    endif
-
-    if (Lmisr_subcolumn) then
-       misrIN%Npoints  => Npoints
-       misrIN%Ncolumns => cospIN%Ncolumns
-       misrIN%Nlevels  => cospIN%Nlevels
-       misrIN%dtau     => cospIN%tau_067
-       misrIN%sunlit   => cospgridIN%sunlit
-       misrIN%zfull    => cospgridIN%hgt_matrix
-       misrIN%at       => cospgridIN%at
-    endif
-
-    if (Lcalipso_subcolumn) then
-       calipsoIN%Npoints     => Npoints
-       calipsoIN%Ncolumns    => cospIN%Ncolumns
-       calipsoIN%Nlevels     => cospIN%Nlevels
-       calipsoIN%beta_mol    => cospIN%beta_mol_calipso
-       calipsoIN%betatot     => cospIN%betatot_calipso
-       calipsoIN%betatot_liq => cospIN%betatot_liq_calipso
-       calipsoIN%betatot_ice => cospIN%betatot_ice_calipso
-       calipsoIN%tau_mol     => cospIN%tau_mol_calipso
-       calipsoIN%tautot      => cospIN%tautot_calipso
-       calipsoIN%tautot_liq  => cospIN%tautot_liq_calipso
-       calipsoIN%tautot_ice  => cospIN%tautot_ice_calipso
-    endif
-
-    if (LgrLidar532_subcolumn) then 
-       grLidar532IN%Npoints  => Npoints
-       grLidar532IN%Ncolumns => cospIN%Ncolumns 
-       grLidar532IN%Nlevels  => cospIN%Nlevels
-       grLidar532IN%beta_mol => cospIN%beta_mol_grLidar532 
-       grLidar532IN%betatot  => cospIN%betatot_grLidar532 
-       grLidar532IN%tau_mol  => cospIN%tau_mol_grLidar532 
-       grLidar532IN%tautot   => cospIN%tautot_grLidar532  
-    endif
-    
-    if (Latlid_subcolumn) then 
-       atlidIN%Npoints        => Npoints 
-       atlidIN%Ncolumns       => cospIN%Ncolumns 
-       atlidIN%Nlevels        => cospIN%Nlevels 
-       atlidIN%beta_mol_atlid => cospIN%beta_mol_atlid
-       atlidIN%betatot_atlid  => cospIN%betatot_atlid 
-       atlidIN%tau_mol_atlid  => cospIN%tau_mol_atlid 
-       atlidIN%tautot_atlid   => cospIN%tautot_atlid 
-    endif 
-    
-    if (Lparasol_subcolumn) then
-       parasolIN%Npoints      => Npoints
-       parasolIN%Nlevels      => cospIN%Nlevels
-       parasolIN%Ncolumns     => cospIN%Ncolumns
-       parasolIN%Nrefl        => cospIN%Nrefl
-       parasolIN%tautot_S_liq => cospIN%tautot_S_liq
-       parasolIN%tautot_S_ice => cospIN%tautot_S_ice
-    endif
-
-    if (Lcloudsat_subcolumn) then
-       cloudsatIN%Npoints    => Npoints
-       cloudsatIN%Nlevels    => cospIN%Nlevels
-       cloudsatIN%Ncolumns   => cospIN%Ncolumns
-       cloudsatIN%z_vol      => cospIN%z_vol_cloudsat
-       cloudsatIN%kr_vol     => cospIN%kr_vol_cloudsat
-       cloudsatIN%g_vol      => cospIN%g_vol_cloudsat
-       cloudsatIN%rcfg       => cospIN%rcfg_cloudsat
-       cloudsatIN%hgt_matrix => cospgridIN%hgt_matrix
-    endif
-
-    if (Lmodis_subcolumn) then
-       modisIN%Ncolumns  => cospIN%Ncolumns
-       modisIN%Nlevels   => cospIN%Nlevels
-       modisIN%Npoints   => Npoints
-       modisIN%liqFrac   => cospIN%fracLiq
-       modisIN%tau       => cospIN%tau_067
-       modisIN%g         => cospIN%asym
-       modisIN%w0        => cospIN%ss_alb
-       modisIN%Nsunlit   = count(cospgridIN%sunlit > 0)
-       if (modisIN%Nsunlit .gt. 0) then
-          allocate(modisIN%sunlit(modisIN%Nsunlit),modisIN%pres(modisIN%Nsunlit,cospIN%Nlevels+1))
-          modisIN%sunlit    = pack((/ (i, i = 1, Npoints ) /),mask = cospgridIN%sunlit > 0)
-          modisIN%pres      = cospgridIN%phalf(int(modisIN%sunlit(:)),:)
-       endif
-       if (count(cospgridIN%sunlit <= 0) .gt. 0) then
-          allocate(modisIN%notSunlit(count(cospgridIN%sunlit <= 0)))
-          modisIN%notSunlit = pack((/ (i, i = 1, Npoints ) /),mask = .not. cospgridIN%sunlit > 0)
-       endif
-    endif
-
-!    if (Lrttov_column) then
-!       rttovIN%nPoints    => Npoints
-!       rttovIN%nLevels    => cospIN%nLevels
-!       rttovIN%nSubCols   => cospIN%nColumns
-!       rttovIN%zenang     => cospgridIN%zenang
-!       rttovIN%co2        => cospgridIN%co2
-!       rttovIN%ch4        => cospgridIN%ch4
-!       rttovIN%n2o        => cospgridIN%n2o
-!       rttovIN%co         => cospgridIN%co
-!       rttovIN%surfem     => cospgridIN%emis_sfc
-!       rttovIN%h_surf     => cospgridIN%hgt_matrix_half(:,cospIN%Nlevels+1)
-!       rttovIN%u_surf     => cospgridIN%u_sfc
-!       rttovIN%v_surf     => cospgridIN%v_sfc
-!       rttovIN%t_skin     => cospgridIN%skt
-!       rttovIN%p_surf     => cospgridIN%phalf(:,cospIN%Nlevels+1)
-!       rttovIN%q2m        => cospgridIN%qv(:,cospIN%Nlevels)
-!       rttovIN%t2m        => cospgridIN%at(:,cospIN%Nlevels)
-!       rttovIN%lsmask     => cospgridIN%land
-!       rttovIN%latitude   => cospgridIN%lat
-!       rttovIN%longitude  => cospgridIN%lon
-!       rttovIN%seaice     => cospgridIN%seaice
-!       rttovIN%p          => cospgridIN%pfull
-!       rttovIN%ph         => cospgridIN%phalf
-!       rttovIN%t          => cospgridIN%at
-!       rttovIN%q          => cospgridIN%qv
-!       rttovIN%o3         => cospgridIN%o3
-       ! Below only needed for all-sky RTTOV calculation
-!       rttovIN%month      => cospgridIN%month
-!       rttovIN%tca        => cospgridIN%tca
-!       rttovIN%cldIce     => cospgridIN%cloudIce
-!       rttovIN%cldLiq     => cospgridIN%cloudLiq
-!       rttovIN%fl_rain    => cospgridIN%fl_rain
-!       rttovIN%fl_snow    => cospgridIN%fl_snow
-!    endif
-
-    !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-    ! 4) Call subcolumn simulators
-    !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-
-    ! ISCCP (icarus) subcolumn simulator
-    if (Lisccp_subcolumn .or. Lmodis_subcolumn) then
-       ! Allocate space for local variables
-       allocate(isccpLEVMATCH(Npoints,isccpIN%Ncolumns),                                 &
-                isccp_boxttop(Npoints,isccpIN%Ncolumns),                                 &
-                isccp_boxptop(Npoints,isccpIN%Ncolumns),                                 &
-                isccp_boxtau(Npoints,isccpIN%Ncolumns), isccp_meantbclr(Npoints))
-       ! Call simulator
-       call icarus_subcolumn(isccpIN%npoints,isccpIN%ncolumns,isccpIN%nlevels,           &
-                             isccpIN%sunlit,isccpIN%dtau,isccpIN%dem,isccpIN%skt,        &
-                             isccpIN%emsfc_lw,isccpIN%qv,isccpIN%at,isccpIN%pfull,       &
-                             isccpIN%phalf,isccpIN%frac_out,isccpLEVMATCH,               &
-                             isccp_boxtau(:,:),isccp_boxptop(:,:),                       &
-                             isccp_boxttop(:,:),isccp_meantbclr(:))
-       ! Store output (if requested)
-       if (associated(cospOUT%isccp_boxtau)) then
-          cospOUT%isccp_boxtau(ij:ik,:)  = isccp_boxtau
-       endif
-       if (associated(cospOUT%isccp_boxptop)) then
-          cospOUT%isccp_boxptop(ij:ik,:) = isccp_boxptop
-       endif
-       if (associated(cospOUT%isccp_meantbclr)) then
-          cospOUT%isccp_meantbclr(ij:ik) = isccp_meantbclr
-       endif
-   endif
-
-   ! MISR subcolumn simulator
-    if (Lmisr_subcolumn) then
-       ! Allocate space for local variables
-       allocate(misr_boxztop(Npoints,misrIN%Ncolumns),                                   &
-                misr_boxtau(Npoints,misrIN%Ncolumns),                                    &
-                misr_dist_model_layertops(Npoints,numMISRHgtBins))
-       ! Call simulator
-       call misr_subcolumn(misrIN%Npoints,misrIN%Ncolumns,misrIN%Nlevels,misrIN%dtau,    &
-                           misrIN%zfull,misrIN%at,misrIN%sunlit,misr_boxtau,             &
-                           misr_dist_model_layertops,misr_boxztop)
-       ! Store output (if requested)
-       if (associated(cospOUT%misr_dist_model_layertops)) then
-          cospOUT%misr_dist_model_layertops(ij:ik,:) = misr_dist_model_layertops
-       endif
-    endif
-
-    ! Calipso subcolumn simulator
-    if (Lcalipso_subcolumn) then
-       ! Allocate space for local variables
-       allocate(calipso_beta_mol(calipsoIN%Npoints,calipsoIN%Nlevels),                   &
-                calipso_beta_tot(calipsoIN%Npoints,calipsoIN%Ncolumns,calipsoIN%Nlevels),&
-                calipso_betaperp_tot(calipsoIN%Npoints,calipsoIN%Ncolumns,calipsoIN%Nlevels))
-       ! Call simulator
-       call lidar_subcolumn(calipsoIN%npoints, calipsoIN%ncolumns, calipsoIN%nlevels, .false., &
-            calipsoIN%beta_mol, calipsoIN%tau_mol, calipsoIN%betatot, calipsoIN%tautot,  &
-            calipso_beta_mol(:,:), calipso_beta_tot(:,:,:), calipsoIN%betatot_ice,       &
-            calipsoIN%tautot_ice, calipsoIN%betatot_liq, calipsoIN%tautot_liq,           &
-            calipso_betaperp_tot(:,:,:))
-       ! Store output (if requested)
-       if (associated(cospOUT%calipso_beta_mol))                                         &
-            cospOUT%calipso_beta_mol(ij:ik,calipsoIN%Nlevels:1:-1) = calipso_beta_mol
-       if (associated(cospOUT%calipso_beta_tot))                                         &
-            cospOUT%calipso_beta_tot(ij:ik,:,calipsoIN%Nlevels:1:-1) = calipso_beta_tot
-       if (associated(cospOUT%calipso_betaperp_tot))                                     &
-            cospOUT%calipso_betaperp_tot(ij:ik,:,:) = calipso_betaperp_tot
-    endif
-
-    ! GROUND LIDAR subcolumn simulator 
-    if (LgrLidar532_subcolumn) then  
-       ! Allocate space for local variables  
-       allocate(grLidar532_beta_mol(grLidar532IN%Npoints,grLidar532IN%Nlevels),       &  
-                grLidar532_beta_tot(grLidar532IN%Npoints,grLidar532IN%Ncolumns,grLidar532IN%Nlevels))
-       ! Call simulator  
-       call lidar_subcolumn(grLidar532IN%npoints, grLidar532IN%ncolumns, grLidar532IN%nlevels,&
-            .true., grLidar532IN%beta_mol, grLidar532IN%tau_mol, grLidar532IN%betatot,&
-            grLidar532IN%tautot, grLidar532_beta_mol(:,:), grLidar532_beta_tot(:,:,:))
-       ! Store output (if requested) 
-       if (associated(cospOUT%grLidar532_beta_mol))                                      & 
-            cospOUT%grLidar532_beta_mol(ij:ik,grLidar532IN%Nlevels:1:-1) = grLidar532_beta_mol 
-       if (associated(cospOUT%grLidar532_beta_tot))                                         & 
-            cospOUT%grLidar532_beta_tot(ij:ik,:,grLidar532IN%Nlevels:1:-1) = grLidar532_beta_tot 
-    endif 
-
-    ! ATLID subcolumn simulator
-    if (Latlid_subcolumn) then
-       ! Allocate space for local variables
-       allocate(atlid_beta_mol(atlidIN%Npoints,atlidIN%Nlevels),                      & 
-                atlid_beta_tot(atlidIN%Npoints,atlidIN%Ncolumns,atlidIN%Nlevels)) 
-       ! Call simulator 
-       call lidar_subcolumn(atlidIN%npoints, atlidIN%ncolumns, atlidIN%nlevels,&
-            .false., atlidIN%beta_mol_atlid, atlidIN%tau_mol_atlid, atlidIN%betatot_atlid,&
-            atlidIN%tautot_atlid, atlid_beta_mol(:,:), atlid_beta_tot(:,:,:))
-       ! Store output (if requested)
-       if (associated(cospOUT%atlid_beta_mol))                                        & 
-            cospOUT%atlid_beta_mol(ij:ik,atlidIN%Nlevels:1:-1) = atlid_beta_mol 
-       if (associated(cospOUT%atlid_beta_tot))                                        &
-            cospOUT%atlid_beta_tot(ij:ik,:,atlidIN%Nlevels:1:-1) = atlid_beta_tot   
-    endif
-
-    ! PARASOL subcolumn simulator
-    if (Lparasol_subcolumn) then
-       ! Allocate space for local variables
-       allocate(parasolPix_refl(parasolIN%Npoints,parasolIN%Ncolumns,PARASOL_NREFL))
-       ! Call simulator
-       do icol=1,parasolIN%Ncolumns
-          call parasol_subcolumn(parasolIN%npoints, PARASOL_NREFL,                       &
-                                 parasolIN%tautot_S_liq(1:parasolIN%Npoints,icol),       &
-                                 parasolIN%tautot_S_ice(1:parasolIN%Npoints,icol),       &
-                                 parasolPix_refl(:,icol,1:PARASOL_NREFL))
-          ! Store output (if requested)
-          if (associated(cospOUT%parasolPix_refl)) then
-             cospOUT%parasolPix_refl(ij:ik,icol,1:PARASOL_NREFL) =                          &
-                  parasolPix_refl(:,icol,1:PARASOL_NREFL)
-          endif
-       enddo
-    endif
-
-    ! Cloudsat (quickbeam) subcolumn simulator
-    if (Lcloudsat_subcolumn) then
-       ! Allocate space for local variables
-       allocate(cloudsatDBZe(cloudsatIN%Npoints,cloudsatIN%Ncolumns,cloudsatIN%Nlevels), &
-                cloudsatZe_non(cloudsatIN%Npoints,cloudsatIN%Ncolumns,cloudsatIN%Nlevels))
-       do icol=1,cloudsatIN%ncolumns
-          call quickbeam_subcolumn(cloudsatIN%rcfg,cloudsatIN%Npoints,cloudsatIN%Nlevels,&
-                                   cloudsatIN%hgt_matrix/1000._wp,                       &
-                                   cloudsatIN%z_vol(:,icol,:),                           &
-                                   cloudsatIN%kr_vol(:,icol,:),                          &
-                                   cloudsatIN%g_vol(:,1,:),cloudsatDBze(:,icol,:),cloudsatZe_non(:,icol,:))
-       enddo
-       ! Store output (if requested)
-       if (associated(cospOUT%cloudsat_Ze_tot)) then
-          cospOUT%cloudsat_Ze_tot(ij:ik,:,:) = cloudsatDBZe(:,:,1:cloudsatIN%Nlevels)
-       endif
-    endif
-
-    if (Lmodis_subcolumn) then
-       if(modisiN%nSunlit > 0) then
-          ! Allocate space for local variables
-          allocate(modisRetrievedTau(modisIN%nSunlit,modisIN%nColumns),                  &
-                   modisRetrievedSize(modisIN%nSunlit,modisIN%nColumns),                 &
-                   modisRetrievedPhase(modisIN%nSunlit,modisIN%nColumns),                &
-                   modisRetrievedCloudTopPressure(modisIN%nSunlit,modisIN%nColumns))
-          ! Call simulator
-          do i = 1, modisIN%nSunlit
-             call modis_subcolumn(modisIN%Ncolumns,modisIN%Nlevels,modisIN%pres(i,:),    &
-                                  modisIN%tau(int(modisIN%sunlit(i)),:,:),               &
-                                  modisIN%liqFrac(int(modisIN%sunlit(i)),:,:),           &
-                                  modisIN%g(int(modisIN%sunlit(i)),:,:),                 &
-                                  modisIN%w0(int(modisIN%sunlit(i)),:,:),                &
-                                  isccp_boxptop(int(modisIN%sunlit(i)),:),               &
-                                  modisRetrievedPhase(i,:),                              &
-                                  modisRetrievedCloudTopPressure(i,:),                   &
-                                  modisRetrievedTau(i,:),modisRetrievedSize(i,:))
-          end do
-       endif
-    endif
-
-    !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-    ! 5) Call column simulators
-    !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-
-    ! ISCCP
-    if (Lisccp_column) then
-       ! Check to see which outputs are requested. If not requested, use a local dummy array
-       if(.not. associated(cospOUT%isccp_meanalbedocld)) then
-          allocate(out1D_1(Npoints))
-          cospOUT%isccp_meanalbedocld(ij:ik) => out1D_1
-       endif
-       if(.not. associated(cospOUT%isccp_meanptop)) then
-          allocate(out1D_2(Npoints))
-          cospOUT%isccp_meanptop(ij:ik) => out1D_2
-       endif
-       if(.not. associated(cospOUT%isccp_meantaucld)) then
-          allocate(out1D_3(Npoints))
-          cospOUT%isccp_meantaucld(ij:ik) => out1D_3
-       endif
-       if(.not. associated(cospOUT%isccp_totalcldarea)) then
-          allocate(out1D_4(Npoints))
-          cospOUT%isccp_totalcldarea(ij:ik) => out1D_4
-       endif
-       if(.not. associated(cospOUT%isccp_meantb)) then
-          allocate(out1D_5(Npoints))
-          cospOUT%isccp_meantb(ij:ik) => out1D_5
-       endif
-       if(.not. associated(cospOUT%isccp_fq)) then
-          allocate(out1D_6(Npoints*numISCCPTauBins*numISCCPPresBins))
-          cospOUT%isccp_fq(ij:ik,1:numISCCPTauBins,1:numISCCPPresBins) => out1D_6
-       endif
-
-       ! Call simulator
-       call icarus_column(isccpIN%npoints, isccpIN%ncolumns,isccp_boxtau(:,:),           &
-                          isccp_boxptop(:,:)/100._wp, isccpIN%sunlit,isccp_boxttop,      &
-                          cospOUT%isccp_fq(ij:ik,:,:),                                   &
-                          cospOUT%isccp_meanalbedocld(ij:ik),                            &
-                          cospOUT%isccp_meanptop(ij:ik),cospOUT%isccp_meantaucld(ij:ik), &
-                          cospOUT%isccp_totalcldarea(ij:ik),cospOUT%isccp_meantb(ij:ik))
-       cospOUT%isccp_fq(ij:ik,:,:) = cospOUT%isccp_fq(ij:ik,:,7:1:-1)
-
-       ! Check if there is any value slightly greater than 1
-       where ((cospOUT%isccp_totalcldarea > 1.0-1.e-5) .and.                             &
-              (cospOUT%isccp_totalcldarea < 1.0+1.e-5))
-              cospOUT%isccp_totalcldarea = 1.0
-       endwhere
-
-       ! Clear up memory (if necessary)
-       if (allocated(isccp_boxttop))   deallocate(isccp_boxttop)
-       if (allocated(isccp_boxptop))   deallocate(isccp_boxptop)
-       if (allocated(isccp_boxtau))    deallocate(isccp_boxtau)
-       if (allocated(isccp_meantbclr)) deallocate(isccp_meantbclr)
-       if (allocated(isccpLEVMATCH))   deallocate(isccpLEVMATCH)
-       if (allocated(out1D_1)) then
-          deallocate(out1D_1)
-          nullify(cospOUT%isccp_meanalbedocld)
-       endif
-       if (allocated(out1D_2)) then
-          deallocate(out1D_2)
-          nullify(cospOUT%isccp_meanptop)
-       endif
-       if (allocated(out1D_3)) then
-          deallocate(out1D_3)
-          nullify(cospOUT%isccp_meantaucld)
-       endif
-       if (allocated(out1D_4)) then
-          deallocate(out1D_4)
-          nullify(cospOUT%isccp_totalcldarea)
-       endif
-       if (allocated(out1D_5)) then
-          deallocate(out1D_5)
-          nullify(cospOUT%isccp_meantb)
-       endif
-       if (allocated(out1D_6)) then
-          deallocate(out1D_6)
-          nullify(cospOUT%isccp_fq)
-       endif
-    endif
-
-    ! MISR
-    if (Lmisr_column) then
-       ! Check to see which outputs are requested. If not requested, use a local dummy array
-       if (.not. associated(cospOUT%misr_cldarea)) then
-          allocate(out1D_1(Npoints))
-          cospOUT%misr_cldarea(ij:ik) => out1D_1
-       endif
-       if (.not. associated(cospOUT%misr_meanztop)) then
-          allocate(out1D_2(Npoints))
-          cospOUT%misr_meanztop(ij:ik) => out1D_2
-       endif
-       if (.not. associated(cospOUT%misr_fq)) then
-          allocate(out1D_3(Npoints*numMISRTauBins*numMISRHgtBins))
-          cospOUT%misr_fq(ij:ik,1:numMISRTauBins,1:numMISRHgtBins) => out1D_3
-        endif
-
-       ! Call simulator
-        call misr_column(misrIN%Npoints,misrIN%Ncolumns,misr_boxztop,misrIN%sunlit,&
-                         misr_boxtau,cospOUT%misr_cldarea(ij:ik),                  &
-                         cospOUT%misr_meanztop(ij:ik),cospOUT%misr_fq(ij:ik,:,:))
-
-       ! Clear up memory
-       if (allocated(misr_boxtau))               deallocate(misr_boxtau)
-       if (allocated(misr_boxztop))              deallocate(misr_boxztop)
-       if (allocated(misr_dist_model_layertops)) deallocate(misr_dist_model_layertops)
-       if (allocated(out1D_1)) then
-          deallocate(out1D_1)
-          nullify(cospOUT%misr_cldarea)
-       endif
-       if (allocated(out1D_2)) then
-          deallocate(out1D_2)
-          nullify(cospOUT%misr_meanztop)
-       endif
-       if (allocated(out1D_3)) then
-          deallocate(out1D_3)
-          nullify(cospOUT%misr_fq)
-       endif
-    endif
-
-    ! CALIPSO LIDAR Simulator
-    if (Lcalipso_column) then
-       ! Check to see which outputs are requested. If not requested, use a local dummy array
-       if (.not. associated(cospOUT%calipso_cfad_sr)) then
-          allocate(out1D_1(Npoints*SR_BINS*Nlvgrid))
-          cospOUT%calipso_cfad_sr(ij:ik,1:SR_BINS,1:Nlvgrid) => out1D_1
-       endif
-       if (.not. associated(cospOUT%calipso_lidarcld)) then
-          allocate(out1D_2(Npoints*Nlvgrid))
-          cospOUT%calipso_lidarcld(ij:ik,1:Nlvgrid) => out1D_2
-       endif
-       if (.not. associated(cospOUT%calipso_lidarcldphase)) then
-          allocate(out1D_3(Npoints*Nlvgrid*6))
-          cospOUT%calipso_lidarcldphase(ij:ik,1:Nlvgrid,1:6) => out1D_3
-       endif
-       if (.not. associated(cospOUT%calipso_cldlayer)) then
-          allocate(out1D_4(Npoints*LIDAR_NCAT))
-          cospOUT%calipso_cldlayer(ij:ik,1:LIDAR_NCAT) => out1D_4
-       endif
-       if (.not. associated(cospOUT%calipso_cldlayerphase)) then
-          allocate(out1D_5(Npoints*LIDAR_NCAT*6))
-          cospOUT%calipso_cldlayerphase(ij:ik,1:LIDAR_NCAT,1:6) => out1D_5
-       endif
-       if (.not. associated(cospOUT%calipso_lidarcldtmp)) then
-          allocate(out1D_6(Npoints*40*5))
-          cospOUT%calipso_lidarcldtmp(ij:ik,1:40,1:5) => out1D_6
-       endif   
-       if (.not. associated(cospOUT%calipso_lidarcldtype)) then
-          allocate(out1D_7(Npoints*Nlvgrid*4))
-          cospOUT%calipso_lidarcldtype(ij:ik,1:Nlvgrid,1:4) => out1D_7
-       endif
-       if (.not. associated(cospOUT%calipso_cldtype)) then 
-          allocate(out1D_8(Npoints*LIDAR_NTYPE)) 
-          cospOUT%calipso_cldtype(ij:ik,1:LIDAR_NTYPE) => out1D_8  
-       endif 
-       if (.not. associated(cospOUT%calipso_cldtypetemp)) then 
-          allocate(out1D_9(Npoints*LIDAR_NTYPE))  
-          cospOUT%calipso_cldtypetemp(ij:ik,1:LIDAR_NTYPE) => out1D_9 
-       endif 
-       if (.not. associated(cospOUT%calipso_cldtypemeanz)) then 
-          allocate(out1D_10(Npoints*2))
-          cospOUT%calipso_cldtypemeanz(ij:ik,1:2) => out1D_10 
-       endif 
-       if (.not. associated(cospOUT%calipso_cldtypemeanzse)) then
-          allocate(out1D_12(Npoints*3)) 
-          cospOUT%calipso_cldtypemeanzse(ij:ik,1:3) => out1D_12
-       endif
-       if (.not. associated(cospOUT%calipso_cldthinemis)) then
-          allocate(out1D_11(Npoints)) 
-          cospOUT%calipso_cldthinemis(ij:ik) => out1D_11 
-       endif
-       
-       ! Call simulator
-       ok_lidar_cfad=.true.
-       call lidar_column(calipsoIN%Npoints, calipsoIN%Ncolumns, calipsoIN%Nlevels,       &
-            Nlvgrid, SR_BINS, LIDAR_NTYPE, 'calipso',calipso_beta_tot(:,:,:), calipso_beta_mol(:,:),&
-            cospgridIN%phalf(:,2:calipsoIN%Nlevels),cospgridIN%hgt_matrix,               &
-            cospgridIN%hgt_matrix_half, vgrid_z(:), ok_lidar_cfad, LIDAR_NCAT,           &
-            cospOUT%calipso_cfad_sr(ij:ik,:,:), cospOUT%calipso_lidarcld(ij:ik,:),       &
-            cospOUT%calipso_cldlayer(ij:ik,:),                                           &
-            cospgridIN%at(:,:), calipso_betaperp_tot(:,:,:), cospgridIN%surfelev,        & 
-            cospOUT%calipso_lidarcldphase(ij:ik,:,:),                       &
-            cospOUT%calipso_lidarcldtype(ij:ik,:,:),  cospOUT%calipso_cldtype(ij:ik,:),  &
-            cospOUT%calipso_cldtypetemp(ij:ik,:), cospOUT%calipso_cldtypemeanz(ij:ik,:), & 
-            cospOUT%calipso_cldtypemeanzse(ij:ik,:), cospOUT%calipso_cldthinemis(ij:ik), &
-            cospOUT%calipso_cldlayerphase(ij:ik,:,:), cospOUT%calipso_lidarcldtmp(ij:ik,:,:))
-
-         if (associated(cospOUT%calipso_srbval)) cospOUT%calipso_srbval = calipso_histBsct
-
-       ! Free up memory (if necessary)
-       if (allocated(out1D_1)) then
-          deallocate(out1D_1)
-          nullify(cospOUT%calipso_cfad_sr)
-       endif
-       if (allocated(out1D_2)) then
-          deallocate(out1D_2)
-          nullify(cospOUT%calipso_lidarcld)
-       endif
-       if (allocated(out1D_3)) then
-          deallocate(out1D_3)
-          nullify(cospOUT%calipso_lidarcldphase)
-       endif
-       if (allocated(out1D_4)) then
-          deallocate(out1D_4)
-          nullify(cospOUT%calipso_cldlayer)
-       endif
-       if (allocated(out1D_5)) then
-          deallocate(out1D_5)
-          nullify(cospOUT%calipso_cldlayerphase)
-       endif
-       if (allocated(out1D_6)) then
-          deallocate(out1D_6)
-          nullify(cospOUT%calipso_lidarcldtmp)
-       endif
-       if (allocated(out1D_7)) then
-          deallocate(out1D_7)  
-          nullify(cospOUT%calipso_lidarcldtype)
-       endif  
-       if (allocated(out1D_8)) then
-          deallocate(out1D_8)
-          nullify(cospOUT%calipso_cldtype)
-       endif 
-       if (allocated(out1D_9)) then 
-          deallocate(out1D_9) 
-          nullify(cospOUT%calipso_cldtypetemp)
-       endif 
-       if (allocated(out1D_10)) then 
-          deallocate(out1D_10)
-          nullify(cospOUT%calipso_cldtypemeanz)
-       endif 
-       if (allocated(out1D_12)) then 
-          deallocate(out1D_12) 
-          nullify(cospOUT%calipso_cldtypemeanzse)
-       endif 
-       if (allocated(out1D_11)) then 
-          deallocate(out1D_11) 
-          nullify(cospOUT%calipso_cldthinemis)
-       endif
-
-    endif
-
-    ! GROUND LIDAR Simulator
-    if (LgrLidar532_column) then
-       ! Check to see which outputs are requested. If not requested, use a local dummy array
-       if (.not. associated(cospOUT%grLidar532_cfad_sr)) then
-          allocate(out1D_1(Npoints*SR_BINS*Nlvgrid)) 
-          cospOUT%grLidar532_cfad_sr(ij:ik,1:SR_BINS,1:Nlvgrid) => out1D_1
-       endif 
-       if (.not. associated(cospOUT%grLidar532_lidarcld)) then
-          allocate(out1D_2(Npoints*Nlvgrid)) 
-          cospOUT%grLidar532_lidarcld(ij:ik,1:Nlvgrid) => out1D_2
-       endif
-       if (.not. associated(cospOUT%grLidar532_cldlayer)) then
-          allocate(out1D_3(Npoints*LIDAR_NCAT))
-          cospOUT%grLidar532_cldlayer(ij:ik,1:LIDAR_NCAT) => out1D_3
-       endif
-       
-       ! Call simulator 
-       ok_lidar_cfad_grLidar532=.true.
-       call lidar_column(grLidar532IN%Npoints, grLidar532IN%Ncolumns, grLidar532IN%Nlevels,       &
-            Nlvgrid, SR_BINS, LIDAR_NTYPE, 'grlidar532',grLidar532_beta_tot(:,:,:), grLidar532_beta_mol(:,:),&
-            cospgridIN%phalf(:,2:grLidar532IN%Nlevels),cospgridIN%hgt_matrix,               &
-            cospgridIN%hgt_matrix_half, vgrid_z(:), ok_lidar_cfad_grLidar532, LIDAR_NCAT,      &
-            cospOUT%grLidar532_cfad_sr(ij:ik,:,:), cospOUT%grLidar532_lidarcld(ij:ik,:),       &
-            cospOUT%grLidar532_cldlayer(ij:ik,:))
-
-       if (associated(cospOUT%grLidar532_srbval)) cospOUT%grLidar532_srbval = grLidar532_histBsct
-
-       ! Free up memory (if necessary) 
-       if (allocated(out1D_1)) then
-          deallocate(out1D_1)
-          nullify(cospOUT%grLidar532_cfad_sr)
-       endif 
-       if (allocated(out1D_2)) then
-          deallocate(out1D_2)
-          nullify(cospOUT%grLidar532_lidarcld)
-       endif 
-       if (allocated(out1D_3)) then
-          deallocate(out1D_3)
-          nullify(cospOUT%grLidar532_cldlayer)
-       endif
-
-    endif
-
-    ! ATLID Simulator
-    if (Latlid_column) then
-       ! Check to see which outputs are requested. If not requested, use a local dummy array
-       if (.not. associated(cospOUT%atlid_cfad_sr)) then
-          allocate(out1D_1(Npoints*SR_BINS*Nlvgrid))
-          cospOUT%atlid_cfad_sr(ij:ik,1:SR_BINS,1:Nlvgrid) => out1D_1
-       endif                                    
-       if (.not. associated(cospOUT%atlid_lidarcld)) then 
-          allocate(out1D_2(Npoints*Nlvgrid))                 
-          cospOUT%atlid_lidarcld(ij:ik,1:Nlvgrid) => out1D_2 
-       endif                                                   
-       if (.not. associated(cospOUT%atlid_cldlayer)) then   
-          allocate(out1D_3(Npoints*LIDAR_NCAT))                 
-          cospOUT%atlid_cldlayer(ij:ik,1:LIDAR_NCAT) => out1D_3 
-       endif                                                      
-       
-       ! Call simulator                                                             
-       ok_lidar_cfad_atlid=.true.
-       call lidar_column(atlidIN%Npoints, atlidIN%Ncolumns, atlidIN%Nlevels,       &
-            Nlvgrid, SR_BINS, LIDAR_NTYPE, 'atlid',atlid_beta_tot(:,:,:),     &
-            atlid_beta_mol(:,:), cospgridIN%phalf(:,2:atlidIN%Nlevels),            &
-            cospgridIN%hgt_matrix, cospgridIN%hgt_matrix_half, vgrid_z(:),         &
-            ok_lidar_cfad_atlid, LIDAR_NCAT, cospOUT%atlid_cfad_sr(ij:ik,:,:),     &
-            cospOUT%atlid_lidarcld(ij:ik,:), cospOUT%atlid_cldlayer(ij:ik,:))
-       
-       if (associated(cospOUT%atlid_srbval)) cospOUT%atlid_srbval = atlid_histBsct 
-
-       ! Free up memory (if necessary)        
-       if (allocated(out1D_1)) then           
-          deallocate(out1D_1)                 
-          nullify(cospOUT%atlid_cfad_sr)
-       endif                                  
-       if (allocated(out1D_2)) then          
-          deallocate(out1D_2)                
-          nullify(cospOUT%atlid_lidarcld)
-       endif                                  
-       if (allocated(out1D_3)) then          
-          deallocate(out1D_3)
-          nullify(cospOUT%atlid_cldlayer)
-       endif          
-
-    endif
-
-    ! PARASOL
-    if (Lparasol_column) then
-       call parasol_column(parasolIN%Npoints,PARASOL_NREFL,parasolIN%Ncolumns,           &
-                            cospgridIN%land(:),parasolPix_refl(:,:,:),                   &
-                            cospOUT%parasolGrid_refl(ij:ik,:))
-       if (allocated(parasolPix_refl)) deallocate(parasolPix_refl)
-    endif
-
-    ! CLOUDSAT
-    if (Lcloudsat_column) then
-       ! Check to see which outputs are requested. If not requested, use a local dummy array
-       if (.not. associated(cospOUT%cloudsat_cfad_ze)) then
-          allocate(out1D_1(Npoints*cloudsat_DBZE_BINS*Nlvgrid))
-          cospOUT%cloudsat_cfad_ze(ij:ik,1:cloudsat_DBZE_BINS,1:Nlvgrid) => out1D_1
-       endif
-
-       if (.not. associated(cospOUT%cloudsat_pia)) then
-          allocate(out1D_2(Npoints))
-          cospOUT%cloudsat_pia(ij:ik) => out1D_2
-       endif
-       if (.not. associated(cospOUT%cloudsat_precip_cover)) then
-          allocate(out1D_3(Npoints*nCloudsatPrecipClass))
-          cospOUT%cloudsat_precip_cover(ij:ik,1:nCloudsatPrecipClass) => out1D_3
-       endif
-          
-       ! Call simulator
-       call quickbeam_column(cloudsatIN%Npoints, cloudsatIN%Ncolumns, cloudsatIN%Nlevels,&
-            Nlvgrid, cloudsat_DBZE_BINS, 'cloudsat', cloudsatDBZe, cloudsatZe_non,       &
-!            cospgridIN%land(:), cospgridIN%at(:,cospIN%Nlevels), cospIN%fracPrecipIce,   & !PREC_BUG
-!            cospgridIN%hgt_matrix, cospgridIN%hgt_matrix_half,                           & !PREC_BUG
-            cospgridIN%land(:), cospgridIN%surfelev(:), cospgridIN%at(:,cospIN%Nlevels), & !PREC_BUG
-	    cospIN%fracPrecipIce, cospgridIN%hgt_matrix, cospgridIN%hgt_matrix_half,     & !PREC_BUG
-            cospOUT%cloudsat_cfad_ze(ij:ik,:,:), cospOUT%cloudsat_precip_cover,          &
-            cospOUT%cloudsat_pia)
-       ! Free up memory  (if necessary)
-       if (allocated(out1D_1)) then
-          deallocate(out1D_1)
-          nullify(cospOUT%cloudsat_cfad_ze)
-       endif
-       if (allocated(out1D_2)) then
-          deallocate(out1D_2)
-          nullify(cospOUT%cloudsat_pia)
-       endif
-       if (allocated(out1D_3)) then
-          deallocate(out1D_3)
-          nullify(cospOUT%cloudsat_precip_cover)
-       endif
-    endif
-
-    ! MODIS
-    if (Lmodis_column) then
-       if(modisiN%nSunlit > 0) then
-          ! Allocate space for local variables
-          allocate(modisCftotal(modisIN%nSunlit), modisCfLiquid(modisIN%nSunlit),        &
-                   modisCfIce(modisIN%nSunlit),modisCfHigh(modisIN%nSunlit),             &
-                   modisCfMid(modisIN%nSunlit),modisCfLow(modisIN%nSunlit),              &
-                   modisMeanTauTotal(modisIN%nSunlit),                                   &
-                   modisMeanTauLiquid(modisIN%nSunlit),modisMeanTauIce(modisIN%nSunlit), &
-                   modisMeanLogTauTotal(modisIN%nSunlit),                                &
-                   modisMeanLogTauLiquid(modisIN%nSunlit),                               &
-                   modisMeanLogTauIce(modisIN%nSunlit),                                  &
-                   modisMeanSizeLiquid(modisIN%nSunlit),                                 &
-                   modisMeanSizeIce(modisIN%nSunlit),                                    &
-                   modisMeanCloudTopPressure(modisIN%nSunlit),                           &
-                   modisMeanLiquidWaterPath(modisIN%nSunlit),                            &
-                   modisMeanIceWaterPath(modisIN%nSunlit),                               &
-                   modisJointHistogram(modisIN%nSunlit,numMODISTauBins,numMODISPresBins),&
-                   modisJointHistogramIce(modisIN%nSunlit,numModisTauBins,numMODISReffIceBins),&
-                   modisJointHistogramLiq(modisIN%nSunlit,numModisTauBins,numMODISReffLiqBins))
-          ! Call simulator
-          call modis_column(modisIN%nSunlit, modisIN%Ncolumns,modisRetrievedPhase,       &
-                             modisRetrievedCloudTopPressure,modisRetrievedTau,           &
-                             modisRetrievedSize, modisCfTotal, modisCfLiquid, modisCfIce,&
-                             modisCfHigh, modisCfMid, modisCfLow, modisMeanTauTotal,     &
-                             modisMeanTauLiquid, modisMeanTauIce, modisMeanLogTauTotal,  &
-                             modisMeanLogTauLiquid, modisMeanLogTauIce,                  &
-                             modisMeanSizeLiquid, modisMeanSizeIce,                      &
-                             modisMeanCloudTopPressure, modisMeanLiquidWaterPath,        &
-                             modisMeanIceWaterPath, modisJointHistogram,                 &
-                             modisJointHistogramIce,modisJointHistogramLiq)
-          ! Store data (if requested)
-          if (associated(cospOUT%modis_Cloud_Fraction_Total_Mean)) then
-             cospOUT%modis_Cloud_Fraction_Total_Mean(ij+int(modisIN%sunlit(:))-1)   =    &
-                  modisCfTotal
-          endif
-          if (associated(cospOUT%modis_Cloud_Fraction_Water_Mean)) then
-             cospOUT%modis_Cloud_Fraction_Water_Mean(ij+int(modisIN%sunlit(:))-1)   =    &
-                  modisCfLiquid
-          endif
-          if (associated(cospOUT%modis_Cloud_Fraction_Ice_Mean)) then
-             cospOUT%modis_Cloud_Fraction_Ice_Mean(ij+int(modisIN%sunlit(:))-1)     =    &
-                  modisCfIce
-          endif
-          if (associated(cospOUT%modis_Cloud_Fraction_High_Mean)) then
-             cospOUT%modis_Cloud_Fraction_High_Mean(ij+int(modisIN%sunlit(:))-1)    =    &
-                  modisCfHigh
-          endif
-          if (associated(cospOUT%modis_Cloud_Fraction_Mid_Mean)) then
-             cospOUT%modis_Cloud_Fraction_Mid_Mean(ij+int(modisIN%sunlit(:))-1)     =    &
-                  modisCfMid
-          endif
-          if (associated(cospOUT%modis_Cloud_Fraction_Low_Mean)) then
-             cospOUT%modis_Cloud_Fraction_Low_Mean(ij+int(modisIN%sunlit(:))-1)     =    &
-                  modisCfLow
-          endif
-          if (associated(cospOUT%modis_Optical_Thickness_Total_Mean)) then
-             cospOUT%modis_Optical_Thickness_Total_Mean(ij+int(modisIN%sunlit(:))-1) =   &
-                  modisMeanTauTotal
-          endif
-          if (associated(cospOUT%modis_Optical_Thickness_Water_Mean)) then
-             cospOUT%modis_Optical_Thickness_Water_Mean(ij+int(modisIN%sunlit(:))-1) =   &
-                  modisMeanTauLiquid
-          endif
-          if (associated(cospOUT%modis_Optical_Thickness_Ice_Mean)) then
-             cospOUT%modis_Optical_Thickness_Ice_Mean(ij+int(modisIN%sunlit(:))-1)  =    &
-                  modisMeanTauIce
-          endif
-          if (associated(cospOUT%modis_Optical_Thickness_Total_LogMean)) then
-             cospOUT%modis_Optical_Thickness_Total_LogMean(ij+int(modisIN%sunlit(:))-1)= &
-                  modisMeanLogTauTotal
-          endif
-          if (associated(cospOUT%modis_Optical_Thickness_Water_LogMean)) then
-             cospOUT%modis_Optical_Thickness_Water_LogMean(ij+int(modisIN%sunlit(:))-1) = &
-                  modisMeanLogTauLiquid
-          endif
-          if (associated(cospOUT%modis_Optical_Thickness_Ice_LogMean)) then
-             cospOUT%modis_Optical_Thickness_Ice_LogMean(ij+int(modisIN%sunlit(:))-1) =  &
-                  modisMeanLogTauIce
-          endif
-          if (associated(cospOUT%modis_Cloud_Particle_Size_Water_Mean)) then
-             cospOUT%modis_Cloud_Particle_Size_Water_Mean(ij+int(modisIN%sunlit(:))-1) = &
-                  modisMeanSizeLiquid
-          endif
-          if (associated(cospOUT%modis_Cloud_Particle_Size_Ice_Mean)) then
-             cospOUT%modis_Cloud_Particle_Size_Ice_Mean(ij+int(modisIN%sunlit(:))-1) =   &
-                  modisMeanSizeIce
-          endif
-          if (associated(cospOUT%modis_Cloud_Top_Pressure_Total_Mean)) then
-             cospOUT%modis_Cloud_Top_Pressure_Total_Mean(ij+int(modisIN%sunlit(:))-1) =  &
-                  modisMeanCloudTopPressure
-          endif
-          if (associated(cospOUT%modis_Liquid_Water_Path_Mean)) then
-             cospOUT%modis_Liquid_Water_Path_Mean(ij+int(modisIN%sunlit(:))-1)      =    &
-                  modisMeanLiquidWaterPath
-          endif
-          if (associated(cospOUT%modis_Ice_Water_Path_Mean)) then
-              cospOUT%modis_Ice_Water_Path_Mean(ij+int(modisIN%sunlit(:))-1)         =   &
-                  modisMeanIceWaterPath
-          endif
-          if (associated(cospOUT%modis_Optical_Thickness_vs_Cloud_Top_Pressure)) then
-             cospOUT%modis_Optical_Thickness_vs_Cloud_Top_Pressure(ij+            &
-                  int(modisIN%sunlit(:))-1, 1:numModisTauBins, :) = modisJointHistogram(:, :, :)
-             ! Reorder pressure bins in joint histogram to go from surface to TOA
-             cospOUT%modis_Optical_Thickness_vs_Cloud_Top_Pressure(ij:ik,:,:) = &
-                  cospOUT%modis_Optical_Thickness_vs_Cloud_Top_Pressure(ij:ik,:,numMODISPresBins:1:-1)
-          endif
-          if (associated(cospOUT%modis_Optical_Thickness_vs_ReffIce)) then
-             cospOUT%modis_Optical_Thickness_vs_ReffIce(ij+int(modisIN%sunlit(:))-1, 1:numMODISTauBins,:) = &
-                modisJointHistogramIce(:,:,:)
-          endif
-          if (associated(cospOUT%modis_Optical_Thickness_vs_ReffLiq)) then
-             cospOUT%modis_Optical_Thickness_vs_ReffLiq(ij+int(modisIN%sunlit(:))-1, 1:numMODISTauBins,:) = &
-                modisJointHistogramLiq(:,:,:)
-          endif
-
-          if(modisIN%nSunlit < modisIN%Npoints) then
-             ! Where it's night and we haven't done the retrievals the values are undefined
-             if (associated(cospOUT%modis_Cloud_Fraction_Total_Mean))                    &
-                cospOUT%modis_Cloud_Fraction_Total_Mean(ij+int(modisIN%notSunlit(:))-1) = R_UNDEF
-             if (associated(cospOUT%modis_Cloud_Fraction_Water_Mean))                    &
-                cospOUT%modis_Cloud_Fraction_Water_Mean(ij+int(modisIN%notSunlit(:))-1) = R_UNDEF
-             if (associated(cospOUT%modis_Cloud_Fraction_Ice_Mean))                      &
-                cospOUT%modis_Cloud_Fraction_Ice_Mean(ij+int(modisIN%notSunlit(:))-1) = R_UNDEF
-             if (associated(cospOUT%modis_Cloud_Fraction_High_Mean))                     &
-                cospOUT%modis_Cloud_Fraction_High_Mean(ij+int(modisIN%notSunlit(:))-1) = R_UNDEF
-             if (associated(cospOUT%modis_Cloud_Fraction_Mid_Mean))                      &
-                cospOUT%modis_Cloud_Fraction_Mid_Mean(ij+int(modisIN%notSunlit(:))-1) = R_UNDEF
-             if (associated(cospOUT%modis_Cloud_Fraction_Low_Mean))                      &
-                cospOUT%modis_Cloud_Fraction_Low_Mean(ij+int(modisIN%notSunlit(:))-1) = R_UNDEF
-             if (associated(cospOUT%modis_Optical_Thickness_Total_Mean))                 &
-                cospOUT%modis_Optical_Thickness_Total_Mean(ij+int(modisIN%notSunlit(:))-1) = R_UNDEF
-             if (associated(cospOUT%modis_Optical_Thickness_Water_Mean))                 &
-                cospOUT%modis_Optical_Thickness_Water_Mean(ij+int(modisIN%notSunlit(:))-1) = R_UNDEF
-             if (associated(cospOUT%modis_Optical_Thickness_Ice_Mean))                   &
-                cospOUT%modis_Optical_Thickness_Ice_Mean(ij+int(modisIN%notSunlit(:))-1) = R_UNDEF
-             if (associated(cospOUT%modis_Optical_Thickness_Total_LogMean))              &
-                cospOUT%modis_Optical_Thickness_Total_LogMean(ij+int(modisIN%notSunlit(:))-1) = R_UNDEF
-             if (associated(cospOUT%modis_Optical_Thickness_Water_LogMean))              &
-                cospOUT%modis_Optical_Thickness_Water_LogMean(ij+int(modisIN%notSunlit(:))-1) = R_UNDEF
-             if (associated(cospOUT%modis_Optical_Thickness_Ice_LogMean))                &
-                cospOUT%modis_Optical_Thickness_Ice_LogMean(ij+int(modisIN%notSunlit(:))-1) = R_UNDEF
-             if (associated(cospOUT%modis_Cloud_Particle_Size_Water_Mean))               &
-                cospOUT%modis_Cloud_Particle_Size_Water_Mean(ij+int(modisIN%notSunlit(:))-1) = R_UNDEF
-             if (associated(cospOUT%modis_Cloud_Particle_Size_Ice_Mean))                 &
-                cospOUT%modis_Cloud_Particle_Size_Ice_Mean(ij+int(modisIN%notSunlit(:))-1) = R_UNDEF
-             if (associated(cospOUT%modis_Cloud_Top_Pressure_Total_Mean))                &
-                cospOUT%modis_Cloud_Top_Pressure_Total_Mean(ij+int(modisIN%notSunlit(:))-1) = R_UNDEF
-             if (associated(cospOUT%modis_Liquid_Water_Path_Mean))                       &
-                cospOUT%modis_Liquid_Water_Path_Mean(ij+int(modisIN%notSunlit(:))-1) = R_UNDEF
-             if (associated(cospOUT%modis_Ice_Water_Path_Mean))                          &
-                cospOUT%modis_Ice_Water_Path_Mean(ij+int(modisIN%notSunlit(:))-1) = R_UNDEF
-             if (associated(cospOUT%modis_Optical_Thickness_vs_Cloud_Top_Pressure))      &
-                cospOUT%modis_Optical_Thickness_vs_Cloud_Top_Pressure(ij+int(modisIN%notSunlit(:))-1, :, :) = R_UNDEF
-          end if
-       else
-          ! It's nightime everywhere - everything is undefined
-          if (associated(cospOUT%modis_Cloud_Fraction_Total_Mean))                       &
-             cospOUT%modis_Cloud_Fraction_Total_Mean(ij:ik) = R_UNDEF
-          if (associated(cospOUT%modis_Cloud_Fraction_Water_Mean))                       &
-             cospOUT%modis_Cloud_Fraction_Water_Mean(ij:ik) = R_UNDEF
-          if (associated(cospOUT%modis_Cloud_Fraction_Ice_Mean))                         &
-             cospOUT%modis_Cloud_Fraction_Ice_Mean(ij:ik) = R_UNDEF
-          if (associated(cospOUT%modis_Cloud_Fraction_High_Mean))                        &
-             cospOUT%modis_Cloud_Fraction_High_Mean(ij:ik) = R_UNDEF
-          if (associated(cospOUT%modis_Cloud_Fraction_Mid_Mean))                         &
-             cospOUT%modis_Cloud_Fraction_Mid_Mean(ij:ik) = R_UNDEF
-          if (associated(cospOUT%modis_Cloud_Fraction_Low_Mean))                         &
-             cospOUT%modis_Cloud_Fraction_Low_Mean(ij:ik) = R_UNDEF
-          if (associated(cospOUT%modis_Optical_Thickness_Total_Mean))                    &
-             cospOUT%modis_Optical_Thickness_Total_Mean(ij:ik) = R_UNDEF
-          if (associated(cospOUT%modis_Optical_Thickness_Water_Mean))                    &
-             cospOUT%modis_Optical_Thickness_Water_Mean(ij:ik) = R_UNDEF
-          if (associated(cospOUT%modis_Optical_Thickness_Ice_Mean))                      &
-             cospOUT%modis_Optical_Thickness_Ice_Mean(ij:ik) = R_UNDEF
-          if (associated(cospOUT%modis_Optical_Thickness_Total_LogMean))                 &
-             cospOUT%modis_Optical_Thickness_Total_LogMean(ij:ik) = R_UNDEF
-          if (associated(cospOUT%modis_Optical_Thickness_Water_LogMean))                 &
-             cospOUT%modis_Optical_Thickness_Water_LogMean(ij:ik) = R_UNDEF
-          if (associated(cospOUT%modis_Optical_Thickness_Ice_LogMean))                   &
-             cospOUT%modis_Optical_Thickness_Ice_LogMean(ij:ik) = R_UNDEF
-          if (associated(cospOUT%modis_Cloud_Particle_Size_Water_Mean))                  &
-             cospOUT%modis_Cloud_Particle_Size_Water_Mean(ij:ik) = R_UNDEF
-          if (associated(cospOUT%modis_Cloud_Particle_Size_Ice_Mean))                    &
-              cospOUT%modis_Cloud_Particle_Size_Ice_Mean(ij:ik) = R_UNDEF
-          if (associated(cospOUT%modis_Cloud_Top_Pressure_Total_Mean))                   &
-             cospOUT%modis_Cloud_Top_Pressure_Total_Mean(ij:ik) = R_UNDEF
-          if (associated(cospOUT%modis_Liquid_Water_Path_Mean))                          &
-             cospOUT%modis_Liquid_Water_Path_Mean(ij:ik) = R_UNDEF
-          if (associated(cospOUT%modis_Ice_Water_Path_Mean))                             &
-             cospOUT%modis_Ice_Water_Path_Mean(ij:ik) = R_UNDEF
-          if (associated(cospOUT%modis_Optical_Thickness_vs_Cloud_Top_Pressure))         &
-             cospOUT%modis_Optical_Thickness_vs_Cloud_Top_Pressure(ij:ik, :, :) = R_UNDEF
-       endif
-       ! Free up memory (if necessary)
-       if (allocated(modisRetrievedTau))               deallocate(modisRetrievedTau)
-       if (allocated(modisRetrievedSize))              deallocate(modisRetrievedSize)
-       if (allocated(modisRetrievedPhase))             deallocate(modisRetrievedPhase)
-       if (allocated(modisRetrievedCloudTopPressure))  deallocate(modisRetrievedCloudTopPressure)
-       if (allocated(modisCftotal))                    deallocate(modisCftotal)
-       if (allocated(modisCfLiquid))                   deallocate(modisCfLiquid)
-       if (allocated(modisCfIce))                      deallocate(modisCfIce)
-       if (allocated(modisCfHigh))                     deallocate(modisCfHigh)
-       if (allocated(modisCfMid))                      deallocate(modisCfMid)
-       if (allocated(modisCfLow))                      deallocate(modisCfLow)
-       if (allocated(modisMeanTauTotal))               deallocate(modisMeanTauTotal)
-       if (allocated(modisMeanTauLiquid))              deallocate(modisMeanTauLiquid)
-       if (allocated(modisMeanTauIce))                 deallocate(modisMeanTauIce)
-       if (allocated(modisMeanLogTauTotal))            deallocate(modisMeanLogTauTotal)
-       if (allocated(modisMeanLogTauLiquid))           deallocate(modisMeanLogTauLiquid)
-       if (allocated(modisMeanLogTauIce))              deallocate(modisMeanLogTauIce)
-       if (allocated(modisMeanSizeLiquid))             deallocate(modisMeanSizeLiquid)
-       if (allocated(modisMeanSizeIce))                deallocate(modisMeanSizeIce)
-       if (allocated(modisMeanCloudTopPressure))       deallocate(modisMeanCloudTopPressure)
-       if (allocated(modisMeanLiquidWaterPath))        deallocate(modisMeanLiquidWaterPath)
-       if (allocated(modisMeanIceWaterPath))           deallocate(modisMeanIceWaterPath)
-       if (allocated(modisJointHistogram))             deallocate(modisJointHistogram)
-       if (allocated(modisJointHistogramIce))          deallocate(modisJointHistogramIce)
-       if (allocated(modisJointHistogramLiq))          deallocate(modisJointHistogramLiq)
-       if (allocated(isccp_boxttop))                   deallocate(isccp_boxttop)
-       if (allocated(isccp_boxptop))                   deallocate(isccp_boxptop)
-       if (allocated(isccp_boxtau))                    deallocate(isccp_boxtau)
-       if (allocated(isccp_meantbclr))                 deallocate(isccp_meantbclr)
-       if (allocated(isccpLEVMATCH))                   deallocate(isccpLEVMATCH)
-    endif
-
-    ! RTTOV
-!    if (lrttov_column) then
-!       call rttov_column(rttovIN%nPoints,rttovIN%nLevels,rttovIN%nSubCols,rttovIN%q,    &
-!                         rttovIN%p,rttovIN%t,rttovIN%o3,rttovIN%ph,rttovIN%h_surf,      &
-!                         rttovIN%u_surf,rttovIN%v_surf,rttovIN%p_surf,rttovIN%t_skin,   &
-!                         rttovIN%t2m,rttovIN%q2m,rttovIN%lsmask,rttovIN%longitude,      &
-!                         rttovIN%latitude,rttovIN%seaice,rttovIN%co2,rttovIN%ch4,       &
-!                         rttovIN%n2o,rttovIN%co,rttovIN%zenang,lrttov_cleanUp,          &
-!                         cospOUT%rttov_tbs(ij:ik,:),cosp_simulator(nError+1),           &
-!                         ! Optional arguments for surface emissivity calculation
-!                         month=rttovIN%month)
-!                         ! Optional arguments to rttov for all-sky calculation
-!                         ! rttovIN%month, rttovIN%tca,rttovIN%cldIce,rttovIN%cldLiq,     &
-!                         ! rttovIN%fl_rain,rttovIN%fl_snow)
-!    endif
-
-    !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-    ! 6) Compute multi-instrument products
-    !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-
-    ! CLOUDSAT/CALIPSO products
-    if (Lradar_lidar_tcc .or. Llidar_only_freq_cloud .or. Lcloudsat_tcc .or. Lcloudsat_tcc2) then
-
-       if (use_vgrid) then
-          allocate(lidar_only_freq_cloud(cloudsatIN%Npoints,Nlvgrid),                    &
-               radar_lidar_tcc(cloudsatIN%Npoints), cloudsat_tcc(cloudsatIN%Npoints),    &
-               cloudsat_tcc2(cloudsatIN%Npoints))
-          allocate(betamol_in(cloudsatIN%Npoints,1,cloudsatIN%Nlevels),                  &
-                   betamoli(cloudsatIN%Npoints,1,Nlvgrid),                               &
-                   pnormI(cloudsatIN%Npoints,cloudsatIN%Ncolumns,Nlvgrid),               &
-                   Ze_totI(cloudsatIN%Npoints,cloudsatIN%Ncolumns,Nlvgrid))
-
-          ! Regrid in the vertical (*NOTE* This routine requires SFC-2-TOA ordering, so flip
-          ! inputs and outputs to maintain TOA-2-SFC ordering convention in COSP2.)
-          betamol_in(:,1,:) = calipso_beta_mol(:,cloudsatIN%Nlevels:1:-1)
-          call cosp_change_vertical_grid(cloudsatIN%Npoints,1,cloudsatIN%Nlevels,        &
-               cospgridIN%hgt_matrix(:,cloudsatIN%Nlevels:1:-1),                         &
-               cospgridIN%hgt_matrix_half(:,cloudsatIN%Nlevels:1:-1),betamol_in,         &
-               Nlvgrid,vgrid_zl(Nlvgrid:1:-1),vgrid_zu(Nlvgrid:1:-1),                    &
-               betamolI(:,1,Nlvgrid:1:-1))
-
-          call cosp_change_vertical_grid(cloudsatIN%Npoints,cloudsatIN%Ncolumns,         &
-               cloudsatIN%Nlevels,cospgridIN%hgt_matrix(:,cloudsatIN%Nlevels:1:-1),      &
-               cospgridIN%hgt_matrix_half(:,cloudsatIN%Nlevels:1:-1),                    &
-               calipso_beta_tot(:,:,cloudsatIN%Nlevels:1:-1),Nlvgrid,                    &
-               vgrid_zl(Nlvgrid:1:-1),vgrid_zu(Nlvgrid:1:-1),pnormI(:,:,Nlvgrid:1:-1))
-
-          call cosp_change_vertical_grid(cloudsatIN%Npoints,cloudsatIN%Ncolumns,         &
-               cloudsatIN%Nlevels,cospgridIN%hgt_matrix(:,cloudsatIN%Nlevels:1:-1),      &
-               cospgridIN%hgt_matrix_half(:,cloudsatIN%Nlevels:1:-1),                    &
-               cloudsatDBZe(:,:,cloudsatIN%Nlevels:1:-1),Nlvgrid,vgrid_zl(Nlvgrid:1:-1), &
-               vgrid_zu(Nlvgrid:1:-1),Ze_totI(:,:,Nlvgrid:1:-1),log_units=.true.)
-
-          call cosp_lidar_only_cloud(cloudsatIN%Npoints, cloudsatIN%Ncolumns, Nlvgrid,   &
-             pnormI, betamolI, Ze_totI, lidar_only_freq_cloud, radar_lidar_tcc,          &
-             cloudsat_tcc, cloudsat_tcc2)
-
-          deallocate(betamol_in,betamolI,pnormI,ze_totI)
-       else
-          allocate(lidar_only_freq_cloud(cloudsatIN%Npoints,cloudsatIN%Nlevels),         &
-               radar_lidar_tcc(cloudsatIN%Npoints), cloudsat_tcc(cloudsatIN%Npoints),    &
-               cloudsat_tcc2(cloudsatIN%Npoints))
-          call cosp_lidar_only_cloud(cloudsatIN%Npoints,cloudsatIN%Ncolumns,             &
-               cospIN%Nlevels,calipso_beta_tot(:,:,cloudsatIN%Nlevels:1:-1),             &
-               calipso_beta_mol(:,cloudsatIN%Nlevels:1:-1),                              &
-               cloudsatDBZe(:,:,cloudsatIN%Nlevels:1:-1),lidar_only_freq_cloud,          &
-               radar_lidar_tcc, cloudsat_tcc, cloudsat_tcc2)
-       endif
-
-       ! Store, when necessary
-       if (associated(cospOUT%lidar_only_freq_cloud)) then
-          cospOUT%lidar_only_freq_cloud(ij:ik,:) = lidar_only_freq_cloud
-       endif
-       if (associated(cospOUT%radar_lidar_tcc)) then
-          cospOUT%radar_lidar_tcc(ij:ik) = radar_lidar_tcc
-       endif
-       if (associated(cospOUT%cloudsat_tcc)) then
-          cospOUT%cloudsat_tcc(ij:ik) = cloudsat_tcc
-       endif
-       if (associated(cospOUT%cloudsat_tcc2)) then
-          cospOUT%cloudsat_tcc2(ij:ik) = cloudsat_tcc2
-       endif
-    endif
-
-    !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-    ! 7) Cleanup
-    !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-    if (Lisccp_subcolumn .or. Lmodis_subcolumn) then
-       nullify(isccpIN%Npoints,isccpIN%Ncolumns,isccpIN%Nlevels,isccpIN%emsfc_lw,        &
-               isccpIN%skt,isccpIN%qv,isccpIN%at,isccpIN%frac_out,isccpIN%dtau,          &
-               isccpIN%dem,isccpIN%phalf,isccpIN%sunlit,isccpIN%pfull)
-    endif
-
-    if (Lmisr_subcolumn) then
-       nullify(misrIN%Npoints,misrIN%Ncolumns,misrIN%Nlevels,misrIN%dtau,misrIN%sunlit,  &
-               misrIN%zfull,misrIN%at)
-    endif
-
-    if (Lcalipso_subcolumn) then
-       nullify(calipsoIN%Npoints,calipsoIN%Ncolumns,calipsoIN%Nlevels,calipsoIN%beta_mol,&
-               calipsoIN%betatot,calipsoIN%betatot_liq,calipsoIN%betatot_ice,            &
-               calipsoIN%tau_mol,calipsoIN%tautot,calipsoIN%tautot_liq,calipsoIN%tautot_ice)
-    endif
-
-    if (LgrLidar532_subcolumn) then 
-       nullify(grLidar532IN%Npoints,grLidar532IN%Ncolumns,grLidar532IN%Nlevels,grLidar532IN%beta_mol, &
-               grLidar532IN%betatot,grLidar532IN%tau_mol,grLidar532IN%tautot) 
-    endif 
-
-    if (Latlid_subcolumn) then
-       nullify(atlidIN%Npoints,atlidIN%Ncolumns,atlidIN%Nlevels,atlidIN%beta_mol_atlid, &
-               atlidIN%betatot_atlid,atlidIN%tau_mol_atlid,atlidIN%tautot_atlid)
-    endif 
-
-    if (Lparasol_subcolumn) then
-       nullify(parasolIN%Npoints,parasolIN%Nlevels,parasolIN%Ncolumns,parasolIN%Nrefl,   &
-            parasolIN%tautot_S_liq,parasolIN%tautot_S_ice)
-    endif
-
-
-    if (Lcloudsat_subcolumn) then
-       nullify(cloudsatIN%Npoints,cloudsatIN%Nlevels,cloudsatIN%Ncolumns,cloudsatIN%rcfg,&
-               cloudsatIN%kr_vol,cloudsatIN%g_vol,cloudsatIN%z_vol,cloudsatIN%hgt_matrix)
-    endif
-
-    if (Lmodis_subcolumn) then
-       nullify(modisIN%Npoints,modisIN%Ncolumns,modisIN%Nlevels,modisIN%tau,modisIN%g,   &
-               modisIN%liqFrac,modisIN%w0)
-       if (allocated(modisIN%sunlit))    deallocate(modisIN%sunlit)
-       if (allocated(modisIN%notSunlit)) deallocate(modisIN%notSunlit)
-       if (allocated(modisIN%pres))      deallocate(modisIN%pres)
-    endif
-
-    if (allocated(calipso_beta_tot))      deallocate(calipso_beta_tot)
-    if (allocated(grLidar532_beta_tot))  deallocate(grLidar532_beta_tot)
-    if (allocated(atlid_beta_tot))        deallocate(atlid_beta_tot) 
-    if (allocated(calipso_beta_mol))      deallocate(calipso_beta_mol)
-    if (allocated(grLidar532_beta_mol))  deallocate(grLidar532_beta_mol)
-    if (allocated(atlid_beta_mol))        deallocate(atlid_beta_mol)
-    if (allocated(calipso_betaperp_tot))  deallocate(calipso_betaperp_tot)
-    if (allocated(cloudsatDBZe))          deallocate(cloudsatDBZe)
-    if (allocated(lidar_only_freq_cloud)) deallocate(lidar_only_freq_cloud)
-    if (allocated(radar_lidar_tcc))       deallocate(radar_lidar_tcc)
-    if (allocated(cloudsat_tcc))          deallocate(cloudsat_tcc)
-    if (allocated(cloudsat_tcc2))         deallocate(cloudsat_tcc2)
-
-  end function COSP_SIMULATOR
-  ! ######################################################################################
-  ! SUBROUTINE cosp_init
-  ! ######################################################################################
-  SUBROUTINE COSP_INIT(Lisccp, Lmodis, Lmisr, Lcloudsat, Lcalipso, LgrLidar532, Latlid, Lparasol, Lrttov,     &
-       cloudsat_radar_freq, cloudsat_k2, cloudsat_use_gas_abs, cloudsat_do_ray,          &
-       isccp_top_height, isccp_top_height_direction, surface_radar, rcfg, lusevgrid,     &
-       luseCSATvgrid, Nvgrid, Nlevels, cloudsat_micro_scheme)
-
-    ! INPUTS
-    logical,intent(in) :: Lisccp,Lmodis,Lmisr,Lcloudsat,Lcalipso,LgrLidar532,Latlid,Lparasol,Lrttov
-    integer,intent(in)  :: &
-         cloudsat_use_gas_abs,       & !
-         cloudsat_do_ray,            & !
-         isccp_top_height,           & !
-         isccp_top_height_direction, & !
-         Nlevels,                    & !
-         Nvgrid,                     & ! Number of levels for new L3 grid
-         surface_radar                 !
-    real(wp),intent(in) :: &
-         cloudsat_radar_freq,        & !
-         cloudsat_k2                   !
-    logical,intent(in) :: &
-         lusevgrid,                  & ! Switch to use different vertical grid
-         luseCSATvgrid                 ! Switch to use CLOUDSAT grid spacing for new
-                                       ! vertical grid
-    character(len=64),intent(in) :: &
-       cloudsat_micro_scheme           ! Microphysical scheme used by CLOUDSAT
-
-    ! OUTPUTS
-    type(radar_cfg) :: rcfg
-
-    ! Local variables
-    integer  :: i
-    real(wp) :: zstep
-
-    ! Initialize MODIS optical-depth bin boundaries for joint-histogram. (defined in cosp_config.F90)
-    if (.not. allocated(modis_histTau)) then
-       allocate(modis_histTau(ntau+1),modis_histTauEdges(2,ntau),modis_histTauCenters(ntau))
-       numMODISTauBins      = ntau
-       modis_histTau        = tau_binBounds
-       modis_histTauEdges   = tau_binEdges
-       modis_histTauCenters = tau_binCenters
-    endif
-
-    ! Set up vertical grid used by CALIPSO and CLOUDSAT L3
-    use_vgrid = lusevgrid
-
-    if (use_vgrid) then
-      Nlvgrid  = Nvgrid
-       allocate(vgrid_zl(Nlvgrid),vgrid_zu(Nlvgrid),vgrid_z(Nlvgrid))
-       ! CloudSat grid requested
-       if (luseCSATvgrid)       zstep = 480._wp
-       ! Other grid requested. Constant vertical spacing with top at 20 km
-       if (.not. luseCSATvgrid) zstep = 20000._wp/Nvgrid
-       do i=1,Nvgrid
-          vgrid_zl(Nlvgrid-i+1) = (i-1)*zstep
-          vgrid_zu(Nlvgrid-i+1) = i*zstep
-       enddo
-       vgrid_z = (vgrid_zl+vgrid_zu)/2._wp
-    else
-       Nlvgrid = Nlevels
-       allocate(vgrid_zl(Nlvgrid),vgrid_zu(Nlvgrid),vgrid_z(Nlvgrid))
-    endif
-
-    ! Initialize simulators
-    if (Lisccp) call cosp_isccp_init(isccp_top_height,isccp_top_height_direction)
-    if (Lmodis) call cosp_modis_init()
-    if (Lmisr)  call cosp_misr_init()
-!    if (Lrttov) call cosp_rttov_init()
-    if (Lcloudsat) call cosp_cloudsat_init(cloudsat_radar_freq,cloudsat_k2,              &
-         cloudsat_use_gas_abs,cloudsat_do_ray,R_UNDEF,N_HYDRO, surface_radar,            &
-         rcfg,cloudsat_micro_scheme)
-    if (Lcalipso) call cosp_calipso_init()
-    if (LgrLidar532) call cosp_grLidar532_init()
-    if (Latlid) call cosp_atlid_init()
-    if (Lparasol) call cosp_parasol_init()
-
-    linitialization = .FALSE.
-  END SUBROUTINE COSP_INIT
-
-  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-  ! SUBROUTINE cosp_cleanUp
-  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-  subroutine cosp_cleanUp()
-    deallocate(vgrid_zl,vgrid_zu,vgrid_z)
-  end subroutine cosp_cleanUp
-
-  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-  ! SUBROUTINE cosp_errorCheck
-  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-  subroutine cosp_errorCheck(cospgridIN, cospIN, Lisccp_subcolumn, Lisccp_column,           &
-       Lmisr_subcolumn, Lmisr_column, Lmodis_subcolumn, Lmodis_column, Lcloudsat_subcolumn, &
-       Lcloudsat_column, Lcalipso_subcolumn, Lcalipso_column, Latlid_subcolumn,             &
-       Latlid_column, LgrLidar532_subcolumn, LgrLidar532_column, Lrttov_subcolumn,        &
-       Lrttov_column, Lparasol_subcolumn, Lparasol_column, Lradar_lidar_tcc,                &
-       Llidar_only_freq_cloud, Lcloudsat_tcc, Lcloudsat_tcc2, cospOUT, errorMessage, nError)
-    
-    ! Inputs
-    type(cosp_column_inputs),intent(in) :: &
-         cospgridIN       ! Model grid inputs to COSP
-    type(cosp_optical_inputs),intent(in) :: &
-         cospIN           ! Derived (optical) input to COSP
-    
-    ! Outputs
-    logical,intent(inout) :: &
-         Lisccp_subcolumn,    & ! ISCCP subcolumn simulator on/off switch
-         Lisccp_column,       & ! ISCCP column simulator on/off switch
-         Lmisr_subcolumn,     & ! MISR subcolumn simulator on/off switch
-         Lmisr_column,        & ! MISR column simulator on/off switch
-         Lmodis_subcolumn,    & ! MODIS subcolumn simulator on/off switch
-         Lmodis_column,       & ! MODIS column simulator on/off switch
-         Lcloudsat_subcolumn, & ! CLOUDSAT subcolumn simulator on/off switch
-         Lcloudsat_column,    & ! CLOUDSAT column simulator on/off switch
-         Lcalipso_subcolumn,  & ! CALIPSO subcolumn simulator on/off switch
-         Lcalipso_column,     & ! CALIPSO column simulator on/off switch
-         Latlid_subcolumn,    & ! EarthCare subcolumn simulator on/off switch
-         Latlid_column,       & ! EarthCare column simulator on/off switch
-         LgrLidar532_subcolumn, & ! Ground Lidar subcolumn simulator on/off switch
-         LgrLidar532_column, & ! Ground Lidar column simulator on/off switch
-         Lparasol_subcolumn,  & ! PARASOL subcolumn simulator on/off switch
-         Lparasol_column,     & ! PARASOL column simulator on/off switch
-         Lrttov_subcolumn,    & ! RTTOV subcolumn simulator on/off switch
-         Lrttov_column,       & ! RTTOV column simulator on/off switch
-         Lcloudsat_tcc,       & !
-         Lcloudsat_tcc2,      & !
-         Lradar_lidar_tcc,    & ! On/Off switch for joint Calipso/Cloudsat product
-         Llidar_only_freq_cloud ! On/Off switch for joint Calipso/Cloudsat product
-    type(cosp_outputs),intent(inout) :: &
-         cospOUT                ! COSP Outputs
-    character(len=256),dimension(100) :: errorMessage
-    integer,intent(out) :: nError
-    
-    ! Local variables
-    character(len=100) :: parasolErrorMessage
-    logical :: alloc_status
-    
-    nError = 0
-    !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-    ! PART 0: Ensure that the inputs needed by the requested simulators are allocated.
-    !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-    ! ISCCP simulator
-    if (Lisccp_subcolumn .or. Lisccp_column) then
-       alloc_status = .true.
-       if (.not. allocated(cospgridIN%skt)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable (ISSCP simulator): cospgridIN%skt has not been allocated'
-          alloc_status = .false.
-       endif
-       if (.not. allocated(cospgridIN%qv)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable (ISSCP simulator): cospgridIN%qv has not been allocated'
-          alloc_status = .false.
-       endif
-       if (.not. allocated(cospgridIN%at)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable (ISSCP simulator): cospgridIN%at has not been allocated'
-          alloc_status = .false.
-       endif
-       if (.not. allocated(cospIN%frac_out)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable (ISSCP simulator): cospIN%frac_out has not been allocated'
-          alloc_status = .false.
-       endif
-       if (.not. allocated(cospIN%tau_067)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable (ISSCP simulator): cospIN%tau_067 has not been allocated'
-          alloc_status = .false.
-       endif
-       if (.not. allocated(cospIN%emiss_11)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable (ISSCP simulator): cospIN%emiss_11 has not been allocated'
-          alloc_status = .false.
-       endif
-       if (.not. allocated(cospgridIN%phalf)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable (ISSCP simulator): cospgridIN%phalf has not been allocated'
-          alloc_status = .false.
-       endif
-       if (.not. allocated(cospgridIN%sunlit)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable (ISSCP simulator): cospgridIN%sunlit has not been allocated'
-          alloc_status = .false.
-       endif
-       if (.not. allocated(cospgridIN%pfull)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable (ISSCP simulator): cospgridIN%pfull has not been allocated'
-          alloc_status = .false.
-       endif
-       if (.not. alloc_status) then
-          Lisccp_subcolumn = .false.
-          Lisccp_column    = .false.
-          if (associated(cospOUT%isccp_totalcldarea))  cospOUT%isccp_totalcldarea(:)  = R_UNDEF
-          if (associated(cospOUT%isccp_meantb))        cospOUT%isccp_meantb(:)        = R_UNDEF
-          if (associated(cospOUT%isccp_meantbclr))     cospOUT%isccp_meantbclr(:)     = R_UNDEF
-          if (associated(cospOUT%isccp_meanptop))      cospOUT%isccp_meanptop(:)      = R_UNDEF
-          if (associated(cospOUT%isccp_meantaucld))    cospOUT%isccp_meantaucld(:)    = R_UNDEF
-          if (associated(cospOUT%isccp_meanalbedocld)) cospOUT%isccp_meanalbedocld(:) = R_UNDEF
-          if (associated(cospOUT%isccp_boxtau))        cospOUT%isccp_boxtau(:,:)      = R_UNDEF
-          if (associated(cospOUT%isccp_boxptop))       cospOUT%isccp_boxptop(:,:)     = R_UNDEF
-          if (associated(cospOUT%isccp_fq))            cospOUT%isccp_fq(:,:,:)        = R_UNDEF
-       endif
-    endif
-    
-    ! MISR simulator
-    if (Lmisr_subcolumn .or. Lmisr_column) then
-       alloc_status = .true.
-       if (.not. allocated(cospIN%tau_067)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable (MISR simulator): cospIN%tau_067 has not been allocated'
-          alloc_status = .false.
-       endif
-       if (.not. allocated(cospgridIN%sunlit)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable (MISR simulator): cospgridIN%sunlit has not been allocated'
-          alloc_status = .false.
-       endif
-       if (.not. allocated(cospgridIN%hgt_matrix)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable (MISR simulator): cospgridIN%hgt_matrix has not been allocated'
-          alloc_status = .false.
-       endif
-       if (.not. allocated(cospgridIN%at)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable (MISR simulator): cospgridIN%at has not been allocated'
-          alloc_status = .false.
-       endif
-       if (.not. alloc_status) then
-          Lmisr_subcolumn = .false.
-          Lmisr_column    = .false.
-          if (associated(cospOUT%misr_fq))                   cospOUT%misr_fq(:,:,:)                 = R_UNDEF
-          if (associated(cospOUT%misr_dist_model_layertops)) cospOUT%misr_dist_model_layertops(:,:) = R_UNDEF
-          if (associated(cospOUT%misr_meanztop))             cospOUT%misr_meanztop(:)               = R_UNDEF
-          if (associated(cospOUT%misr_cldarea))              cospOUT%misr_cldarea(:)                = R_UNDEF          
-       endif
-    endif
-
-    ! EarthCare Lidar simulator.
-    if (Latlid_subcolumn .or. Latlid_column) then
-       alloc_status = .true.
-       if (.not. allocated(cospIN%beta_mol_atlid)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable (EarthCare Lidar simulator): cospIN%beta_mol_atlid has not been allocated'
-          alloc_status = .false.
-       endif
-       if (.not. allocated(cospIN%betatot_atlid)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable (EarthCare Lidar simulator): cospIN%betatot_atlid has not been allocated'
-          alloc_status = .false.
-       endif
-       if (.not. allocated(cospIN%tau_mol_atlid)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable (EarthCare Lidar simulator): cospIN%tau_mol_atlid has not been allocated'
-          alloc_status = .false.
-       endif
-       if (.not. allocated(cospIN%tautot_atlid)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable (EarthCare Lidar simulator): cospIN%tautot_atlid has not been allocated'
-          alloc_status = .false.
-       endif
-       if (.not. alloc_status) then
-          Latlid_subcolumn = .false.
-          Latlid_column    = .false.
-          if (associated(cospOUT%atlid_cfad_sr))  cospOUT%atlid_cfad_sr(:,:,:)  = R_UNDEF
-          if (associated(cospOUT%atlid_lidarcld)) cospOUT%atlid_lidarcld(:,:)   = R_UNDEF
-          if (associated(cospOUT%atlid_cldlayer)) cospOUT%atlid_cldlayer(:,:)   = R_UNDEF
-          if (associated(cospOUT%atlid_beta_mol)) cospOUT%atlid_beta_mol(:,:)   = R_UNDEF
-          if (associated(cospOUT%atlid_beta_tot)) cospOUT%atlid_beta_tot(:,:,:) = R_UNDEF
-       endif
-       
-       ! EarthCare column simulator requires additional inputs not required by the subcolumn simulator.
-       alloc_status = .true.
-       if (.not. allocated(cospgridIN%hgt_matrix)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable (EarthCare Lidar simulator): cospgridIN%hgt_matrix has not been allocated'
-          alloc_status = .false.
-       endif
-       if (.not. allocated(cospgridIN%hgt_matrix_half)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable (EarthCare Lidar simulator): cospgridIN%hgt_matrix_half has not been allocated'
-          alloc_status = .false.
-       endif
-       if (.not. allocated(cospgridIN%phalf)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable (EarthCare Lidar simulator): cospgridIN%phalf has not been allocated'
-          alloc_status = .false.
-       endif
-       if (.not. alloc_status) then
-          Latlid_column  = .false.
-          if (associated(cospOUT%atlid_cfad_sr)) cospOUT%atlid_cfad_sr(:,:,:) = R_UNDEF
-       endif
-    endif
-
-    ! Ground Lidar simulator.
-    if (LgrLidar532_subcolumn .or. LgrLidar532_column) then
-       alloc_status = .true.
-       if (.not. allocated(cospIN%beta_mol_grLidar532)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable (Ground Lidar simulator): cospIN%beta_mol_grLidar532 has not been allocated'
-          alloc_status = .false.
-       endif
-       if (.not. allocated(cospIN%betatot_grLidar532)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable (Ground Lidar simulator): cospIN%betatot_grLidar532 has not been allocated'
-          alloc_status = .false.
-       endif
-       if (.not. allocated(cospIN%tau_mol_grLidar532)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable (Ground Lidar simulator): cospIN%tau_mol_grLidar532 has not been allocated'
-          alloc_status = .false.
-       endif
-       if (.not. allocated(cospIN%tautot_grLidar532)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable (Ground Lidar simulator): cospIN%tautot_grLidar532 has not been allocated'
-          alloc_status = .false.
-       endif
-       if (.not. alloc_status) then
-          LgrLidar532_subcolumn = .false.
-          LgrLidar532_column    = .false.
-          if (associated(cospOUT%grLidar532_cfad_sr))  cospOUT%grLidar532_cfad_sr(:,:,:)  = R_UNDEF
-          if (associated(cospOUT%grLidar532_lidarcld)) cospOUT%grLidar532_lidarcld(:,:)   = R_UNDEF
-          if (associated(cospOUT%grLidar532_cldlayer)) cospOUT%grLidar532_cldlayer(:,:)   = R_UNDEF
-          if (associated(cospOUT%grLidar532_beta_mol)) cospOUT%grLidar532_beta_mol(:,:)   = R_UNDEF
-          if (associated(cospOUT%grLidar532_beta_tot)) cospOUT%grLidar532_beta_tot(:,:,:) = R_UNDEF
-       endif
-       
-       ! Ground Lidar column simulator requires additional inputs not required by the subcolumn simulator.
-       alloc_status = .true.
-       if (.not. allocated(cospgridIN%hgt_matrix)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable (Ground Lidar simulator): cospgridIN%hgt_matrix has not been allocated'
-          alloc_status = .false.
-       endif
-       if (.not. allocated(cospgridIN%hgt_matrix_half)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable (Ground Lidar simulator): cospgridIN%hgt_matrix_half has not been allocated'
-          alloc_status = .false.
-       endif
-       if (.not. allocated(cospgridIN%phalf)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable (Ground Lidar simulator): cospgridIN%phalf has not been allocated'
-          alloc_status = .false.
-       endif
-       if (.not. alloc_status) then
-          LgrLidar532_column  = .false.
-          if (associated(cospOUT%grLidar532_cfad_sr)) cospOUT%grLidar532_cfad_sr(:,:,:) = R_UNDEF
-       endif
-    endif
-    
-    ! Calipso Lidar simulator
-    if (Lcalipso_subcolumn .or. Lcalipso_column) then
-       alloc_status = .true.
-       if (.not. allocated(cospIN%beta_mol_calipso)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable (Calipso Lidar simulator): cospIN%beta_mol_calipso has not been allocated'
-          alloc_status = .false.
-       endif
-       if (.not. allocated(cospIN%betatot_calipso)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable (Calipso Lidar simulator): cospIN%betatot_calipso has not been allocated'
-          alloc_status = .false.
-       endif
-       if (.not. allocated(cospIN%betatot_liq_calipso)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable (Calipso Lidar simulator):'//&
-               ' cospIN%betatot_liq_calipso has not been allocated'
-          alloc_status = .false.
-       endif
-       if (.not. allocated(cospIN%betatot_ice_calipso)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable (Calipso Lidar simulator):'//&
-               ' cospIN%betatot_ice_calipso has not been allocated'
-          alloc_status = .false.
-       endif
-       if (.not. allocated(cospIN%tau_mol_calipso)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable (Calipso Lidar simulator): cospIN%tau_mol_calipso has not been allocated'
-          alloc_status = .false.
-       endif
-       if (.not. allocated(cospIN%tautot_calipso)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable (Calipso Lidar simulator): cospIN%tautot_calipso has not been allocated'
-          alloc_status = .false.
-       endif
-       if (.not. allocated(cospIN%tautot_liq_calipso)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable (Calipso Lidar simulator):'//&
-               ' cospIN%tautot_liq has not been allocated'
-          alloc_status = .false.
-       endif
-       if (.not. allocated(cospIN%tautot_ice_calipso)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable (Calipso Lidar simulator):'//&
-               ' cospIN%tautot_ice has not been allocated'
-          alloc_status = .false.
-       endif
-       if (.not. alloc_status) then
-          Lcalipso_subcolumn = .false.
-          Lcalipso_column    = .false.
-          if (associated(cospOUT%calipso_cfad_sr))       cospOUT%calipso_cfad_sr(:,:,:)       = R_UNDEF
-          if (associated(cospOUT%calipso_lidarcld))      cospOUT%calipso_lidarcld(:,:)        = R_UNDEF
-          if (associated(cospOUT%calipso_lidarcldphase)) cospOUT%calipso_lidarcldphase(:,:,:) = R_UNDEF
-          if (associated(cospOUT%calipso_cldlayer))      cospOUT%calipso_cldlayer(:,:)        = R_UNDEF
-          if (associated(cospOUT%calipso_cldlayerphase)) cospOUT%calipso_cldlayerphase(:,:,:) = R_UNDEF
-          if (associated(cospOUT%calipso_lidarcldtmp))   cospOUT%calipso_lidarcldtmp(:,:,:)   = R_UNDEF
-          if (associated(cospOUT%calipso_beta_mol))      cospOUT%calipso_beta_mol(:,:)        = R_UNDEF
-          if (associated(cospOUT%calipso_beta_tot))      cospOUT%calipso_beta_tot(:,:,:)      = R_UNDEF
-          if (associated(cospOUT%calipso_betaperp_tot))  cospOUT%calipso_betaperp_tot(:,:,:)  = R_UNDEF
-          ! Also, turn-off joint-products 
-          if (Lradar_lidar_tcc) then
-             Lradar_lidar_tcc = .false.
-             if (associated(cospOUT%radar_lidar_tcc)) cospOUT%radar_lidar_tcc(:) = R_UNDEF
-          endif
-          if (Lcloudsat_tcc) then
-             Lcloudsat_tcc = .false.
-             if (associated(cospOUT%cloudsat_tcc)) cospOUT%cloudsat_tcc(:) = R_UNDEF
-          endif
-          if (Lcloudsat_tcc2) then
-             Lcloudsat_tcc2 = .false.
-             if (associated(cospOUT%cloudsat_tcc2)) cospOUT%cloudsat_tcc2(:) = R_UNDEF
-          endif
-          if (Llidar_only_freq_cloud) then
-             Llidar_only_freq_cloud = .false.
-             if (associated(cospOUT%lidar_only_freq_cloud)) cospOUT%lidar_only_freq_cloud(:,:) = R_UNDEF
-          endif
-       endif
-       
-       ! Calipso column simulator requires additional inputs not required by the subcolumn simulator.
-       alloc_status = .true.
-       if (.not. allocated(cospgridIN%hgt_matrix)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable (Calipso Lidar simulator):'//&
-               ' cospgridIN%hgt_matrix has not been allocated'
-          alloc_status = .false.
-       endif
-       if (.not. allocated(cospgridIN%hgt_matrix_half)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable (Calipso Lidar simulator):'//&
-               ' cospgridIN%hgt_matrix_half has not been allocated'
-          alloc_status = .false.
-       endif
-       if (.not. allocated(cospgridIN%at)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable (Calipso Lidar simulator): cospgridIN%at has not been allocated'
-          alloc_status = .false.
-       endif
-       if (.not. allocated(cospgridIN%phalf)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable (Calipso Lidar simulator): cospgridIN%phalf has not been allocated'
-          alloc_status = .false.
-       endif
-       if (.not. alloc_status) then
-          Lcalipso_column  = .false.
-          if (associated(cospOUT%calipso_cfad_sr))       cospOUT%calipso_cfad_sr(:,:,:)       = R_UNDEF
-          if (associated(cospOUT%calipso_lidarcld))      cospOUT%calipso_lidarcld(:,:)        = R_UNDEF
-          if (associated(cospOUT%calipso_lidarcldphase)) cospOUT%calipso_lidarcldphase(:,:,:) = R_UNDEF
-          if (associated(cospOUT%calipso_cldlayer))      cospOUT%calipso_cldlayer(:,:)        = R_UNDEF
-          if (associated(cospOUT%calipso_cldlayerphase)) cospOUT%calipso_cldlayerphase(:,:,:) = R_UNDEF
-          if (associated(cospOUT%calipso_lidarcldtmp))   cospOUT%calipso_lidarcldtmp(:,:,:)   = R_UNDEF
-          if (Lcloudsat_tcc) then
-             Lcloudsat_tcc = .false.
-             if (associated(cospOUT%cloudsat_tcc)) cospOUT%cloudsat_tcc(:) = R_UNDEF
-          endif
-          if (Lcloudsat_tcc2) then
-             Lcloudsat_tcc2 = .false.
-             if (associated(cospOUT%cloudsat_tcc2)) cospOUT%cloudsat_tcc2(:) = R_UNDEF
-          endif
-          ! Also, turn-off joint-products 
-          if (Lradar_lidar_tcc) then
-             Lradar_lidar_tcc = .false.
-             if (associated(cospOUT%radar_lidar_tcc)) cospOUT%radar_lidar_tcc(:) = R_UNDEF
-          endif
-          if (Llidar_only_freq_cloud) then
-             Llidar_only_freq_cloud = .false.
-             if (associated(cospOUT%lidar_only_freq_cloud)) cospOUT%lidar_only_freq_cloud(:,:) = R_UNDEF
-          endif
-       endif
-    endif
-    
-    ! PARASOL simulator
-    if (Lparasol_subcolumn .or. Lparasol_column) then
-       alloc_status = .true.
-       if (.not. allocated(cospIN%tautot_S_liq)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable (PARASOL simulator): cospIN%tautot_S_liq has not been allocated'
-          alloc_status = .false.
-       endif
-       if (.not. allocated(cospIN%tautot_S_ice)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable (PARASOL simulator): cospIN%tautot_S_ice has not been allocated'
-          alloc_status = .false.
-       endif
-       if (.not. alloc_status) then
-          Lparasol_subcolumn  = .false.
-          Lparasol_column     = .false.
-          if (associated(cospOUT%parasolPix_refl))  cospOUT%parasolPix_refl(:,:,:) = R_UNDEF
-          if (associated(cospOUT%parasolGrid_refl)) cospOUT%parasolGrid_refl(:,:)  = R_UNDEF
-       endif
-       
-       ! PARASOL column simulator requires additional inputs not required by the subcolumn simulator.
-       alloc_status = .true.
-       if (.not. allocated(cospgridIN%land)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable (PARASOL simulator): cospgridIN%land has not been allocated'
-          alloc_status = .false.
-       endif
-       if (.not. alloc_status) then
-          Lparasol_column  = .false.
-          if (associated(cospOUT%parasolGrid_refl)) cospOUT%parasolGrid_refl(:,:)  = R_UNDEF
-       endif
-    endif
-    
-    ! Cloudsat radar simulator
-    if (Lcloudsat_subcolumn .or. Lcloudsat_column) then
-       alloc_status = .true.
-       if (.not. allocated(cospIN%z_vol_cloudsat)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable (Cloudsat radar simulator):'//&
-               ' cospIN%z_vol_cloudsat has not been allocated'
-          alloc_status = .false.
-       endif
-       if (.not. allocated(cospIN%kr_vol_cloudsat)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable (Cloudsat radar simulator):'//&
-               ' cospIN%kr_vol_cloudsat has not been allocated'
-          alloc_status = .false.
-       endif
-       if (.not. allocated(cospIN%g_vol_cloudsat)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable (Cloudsat radar simulator):'//&
-               ' cospIN%g_vol_cloudsat has not been allocated'
-          alloc_status = .false.
-       endif
-       if (.not. allocated(cospgridIN%hgt_matrix)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable (Cloudsat radar simulator):'//&
-               ' cospgridIN%hgt_matrix has not been allocated'
-          alloc_status = .false.
-       endif
-       if (.not. alloc_status) then
-          Lcloudsat_subcolumn  = .false.
-          Lcloudsat_column     = .false.
-          if (associated(cospOUT%cloudsat_cfad_ze)) cospOUT%cloudsat_cfad_ze(:,:,:) = R_UNDEF
-          if (associated(cospOUT%cloudsat_Ze_tot))  cospOUT%cloudsat_Ze_tot(:,:,:)  = R_UNDEF
-          if (Lcloudsat_tcc) then
-             Lcloudsat_tcc = .false.
-             if (associated(cospOUT%cloudsat_tcc)) cospOUT%cloudsat_tcc(:) = R_UNDEF
-          endif
-          if (Lcloudsat_tcc2) then
-             Lcloudsat_tcc2 = .false.
-             if (associated(cospOUT%cloudsat_tcc2)) cospOUT%cloudsat_tcc2(:) = R_UNDEF
-          endif
-          ! Also, turn-off joint-products 
-          if (Lradar_lidar_tcc) then
-             Lradar_lidar_tcc = .false.
-             if (associated(cospOUT%radar_lidar_tcc)) cospOUT%radar_lidar_tcc(:) = R_UNDEF
-          endif
-          if (Llidar_only_freq_cloud) then
-             Llidar_only_freq_cloud = .false.
-             if (associated(cospOUT%lidar_only_freq_cloud)) cospOUT%lidar_only_freq_cloud(:,:) = R_UNDEF
-          endif
-       endif
-       
-       ! Cloudsat column simulator requires additional inputs not required by the subcolumn simulator.
-       alloc_status = .true.
-       if (.not. allocated(cospgridIN%hgt_matrix_half)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable (Cloudsat radar simulator):'//&
-               ' cospgridIN%hgt_matrix_half has not been allocated'
-          alloc_status = .false.
-       endif
-       if (.not. alloc_status) then
-          Lcloudsat_column  = .false.
-          if (associated(cospOUT%cloudsat_cfad_ze))      cospOUT%cloudsat_cfad_ze(:,:,:)    = R_UNDEF
-          if (Lcloudsat_tcc) then
-             Lcloudsat_tcc = .false.
-             if (associated(cospOUT%cloudsat_tcc)) cospOUT%cloudsat_tcc(:) = R_UNDEF
-          endif
-          if (Lcloudsat_tcc2) then
-             Lcloudsat_tcc2 = .false.
-             if (associated(cospOUT%cloudsat_tcc2)) cospOUT%cloudsat_tcc2(:) = R_UNDEF
-          endif
-          ! Also, turn-off joint-products 
-          if (Lradar_lidar_tcc) then
-             Lradar_lidar_tcc = .false.
-             if (associated(cospOUT%radar_lidar_tcc)) cospOUT%radar_lidar_tcc(:) = R_UNDEF
-          endif
-          if (Llidar_only_freq_cloud) then
-             Llidar_only_freq_cloud = .false.
-             if (associated(cospOUT%lidar_only_freq_cloud)) cospOUT%lidar_only_freq_cloud(:,:) = R_UNDEF
-          endif
-       endif
-    endif
-    
-    ! MODIS simulator
-    if (Lmodis_subcolumn .or. Lmodis_column) then
-       alloc_status = .true.
-       if (.not. allocated(cospIN%fracLiq)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable (MODIS simulator): cospIN%fracLiq has not been allocated'
-          alloc_status = .false.
-       endif
-       if (.not. allocated(cospIN%tau_067)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable (MODIS simulator): cospIN%tau_067 has not been allocated'
-          alloc_status = .false.
-       endif
-       if (.not. allocated(cospIN%asym)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable (MODIS simulator): cospIN%asym has not been allocated'
-          alloc_status = .false.
-       endif
-       if (.not. allocated(cospIN%ss_alb)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable (MODIS simulator): cospIN%ss_alb has not been allocated'
-          alloc_status = .false.
-       endif
-       if (.not. allocated(cospgridIN%sunlit)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable (MODIS simulator): cospgridIN%sunlit has not been allocated'
-          alloc_status = .false.
-       endif
-       if (.not. alloc_status) then
-          Lmodis_subcolumn  = .false.
-          Lmodis_column     = .false.
-          if (associated(cospOUT%modis_Cloud_Fraction_Total_Mean))                          &
-               cospOUT%modis_Cloud_Fraction_Total_Mean(:)                   = R_UNDEF
-          if (associated(cospOUT%modis_Cloud_Fraction_Water_Mean))                          &
-               cospOUT%modis_Cloud_Fraction_Water_Mean(:)                   = R_UNDEF
-          if (associated(cospOUT%modis_Cloud_Fraction_Ice_Mean))                            &
-               cospOUT%modis_Cloud_Fraction_Ice_Mean(:)                     = R_UNDEF
-          if (associated(cospOUT%modis_Cloud_Fraction_High_Mean))                           &
-               cospOUT%modis_Cloud_Fraction_High_Mean(:)                    = R_UNDEF
-          if (associated(cospOUT%modis_Cloud_Fraction_Mid_Mean))                            &
-               cospOUT%modis_Cloud_Fraction_Mid_Mean(:)                     = R_UNDEF
-          if (associated(cospOUT%modis_Cloud_Fraction_Low_Mean))                            &
-               cospOUT%modis_Cloud_Fraction_Low_Mean(:)                     = R_UNDEF
-          if (associated(cospOUT%modis_Optical_Thickness_Total_Mean))                       &
-               cospOUT%modis_Optical_Thickness_Total_Mean(:)                = R_UNDEF
-          if (associated(cospOUT%modis_Optical_Thickness_Water_Mean))                       &
-               cospOUT%modis_Optical_Thickness_Water_Mean(:)                = R_UNDEF
-          if (associated(cospOUT%modis_Optical_Thickness_Ice_Mean))                         &
-               cospOUT%modis_Optical_Thickness_Ice_Mean(:)                  = R_UNDEF
-          if (associated(cospOUT%modis_Optical_Thickness_Total_LogMean))                    &
-               cospOUT%modis_Optical_Thickness_Total_LogMean(:)             = R_UNDEF
-          if (associated(cospOUT%modis_Optical_Thickness_Water_LogMean))                    &
-               cospOUT%modis_Optical_Thickness_Water_LogMean(:)             = R_UNDEF
-          if (associated(cospOUT%modis_Optical_Thickness_Ice_LogMean))                      &
-               cospOUT%modis_Optical_Thickness_Ice_LogMean(:)               = R_UNDEF
-          if (associated(cospOUT%modis_Cloud_Particle_Size_Water_Mean))                     &
-               cospOUT%modis_Cloud_Particle_Size_Water_Mean(:)              = R_UNDEF
-          if (associated(cospOUT%modis_Cloud_Particle_Size_Ice_Mean))                       &
-               cospOUT%modis_Cloud_Particle_Size_Ice_Mean(:)                = R_UNDEF
-          if (associated(cospOUT%modis_Cloud_Top_Pressure_Total_Mean))                      &
-               cospOUT%modis_Cloud_Top_Pressure_Total_Mean(:)               = R_UNDEF
-          if (associated(cospOUT%modis_Liquid_Water_Path_Mean))                             &
-               cospOUT%modis_Liquid_Water_Path_Mean(:)                      = R_UNDEF
-          if (associated(cospOUT%modis_Ice_Water_Path_Mean))                                &
-               cospOUT%modis_Ice_Water_Path_Mean(:)                         = R_UNDEF
-          if (associated(cospOUT%modis_Optical_Thickness_vs_Cloud_Top_Pressure))            &
-               cospOUT%modis_Optical_Thickness_vs_Cloud_Top_Pressure(:,:,:) = R_UNDEF
-          if (associated(cospOUT%modis_Optical_Thickness_vs_ReffICE))                       &
-               cospOUT%modis_Optical_Thickness_vs_ReffICE(:,:,:)            = R_UNDEF
-          if (associated(cospOUT%modis_Optical_Thickness_vs_ReffLIQ))                       &
-               cospOUT%modis_Optical_Thickness_vs_ReffLIQ(:,:,:)            = R_UNDEF          
-       endif
-    endif
-    
-    ! RTTOV
-    if (Lrttov_column) then
-       alloc_status = .true.
-       if (.not. allocated(cospgridIN%emis_sfc)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable (RTTOV): cospgridIN%emis_sfc has not been allocated'
-          alloc_status = .false.
-       endif
-       if (.not. allocated(cospgridIN%hgt_matrix_half)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable (RTTOV): cospgridIN%emis_sfc has not been allocated'
-          alloc_status = .false.
-       endif
-       if (.not. allocated(cospgridIN%u_sfc)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable (RTTOV): cospgridIN%u_sfc has not been allocated'
-          alloc_status = .false.
-       endif
-       if (.not. allocated(cospgridIN%v_sfc)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable (RTTOV): cospgridIN%v_sfc has not been allocated'
-          alloc_status = .false.
-       endif
-       if (.not. allocated(cospgridIN%skt)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable (RTTOV): cospgridIN%skt has not been allocated'
-          alloc_status = .false.
-       endif
-       if (.not. allocated(cospgridIN%phalf)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable (RTTOV): cospgridIN%phalf has not been allocated'
-          alloc_status = .false.
-       endif
-       if (.not. allocated(cospgridIN%qv)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable (RTTOV): cospgridIN%qv has not been allocated'
-          alloc_status = .false.
-       endif
-       if (.not. allocated(cospgridIN%at)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable (RTTOV): cospgridIN%at has not been allocated'
-          alloc_status = .false.
-       endif
-       if (.not. allocated(cospgridIN%land)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable (RTTOV): cospgridIN%land has not been allocated'
-          alloc_status = .false.
-       endif
-       if (.not. allocated(cospgridIN%lat)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable (RTTOV): cospgridIN%lat has not been allocated'
-          alloc_status = .false.
-       endif
-       if (.not. allocated(cospgridIN%lon)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable (RTTOV): cospgridIN%lon has not been allocated'
-          alloc_status = .false.
-       endif
-       if (.not. allocated(cospgridIN%seaice)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable (RTTOV): cospgridIN%seaice has not been allocated'
-          alloc_status = .false.
-       endif
-       if (.not. allocated(cospgridIN%pfull)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable (RTTOV): cospgridIN%pfull has not been allocated'
-          alloc_status = .false.
-       endif
-       if (.not. allocated(cospgridIN%phalf)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable (RTTOV): cospgridIN%phalf has not been allocated'
-          alloc_status = .false.
-       endif
-       if (.not. allocated(cospgridIN%at)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable (RTTOV): cospgridIN%at has not been allocated'
-          alloc_status = .false.
-       endif
-       if (.not. allocated(cospgridIN%qv)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable (RTTOV): cospgridIN%qv has not been allocated'
-          alloc_status = .false.
-       endif
-       if (.not. allocated(cospgridIN%o3)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable (RTTOV): cospgridIN%o3 has not been allocated'
-          alloc_status = .false.
-       endif
-       if (.not. allocated(cospgridIN%tca)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable (RTTOV): cospgridIN%tca has not been allocated'
-          alloc_status = .false.
-       endif
-       if (.not. allocated(cospgridIN%cloudIce)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable (RTTOV): cospgridIN%cloudIce has not been allocated'
-          alloc_status = .false.
-       endif
-       if (.not. allocated(cospgridIN%cloudLiq)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable (RTTOV): cospgridIN%cloudLiq has not been allocated'
-          alloc_status = .false.
-       endif
-       if (.not. allocated(cospgridIN%fl_rain)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable (RTTOV): cospgridIN%fl_rain has not been allocated'
-          alloc_status = .false.
-       endif
-       if (.not. allocated(cospgridIN%fl_snow)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable (RTTOV): cospgridIN%fl_snow has not been allocated'
-          alloc_status = .false.
-       endif
-       if (.not. alloc_status) then
-          Lrttov_column     = .false.
-          if (associated(cospOUT%rttov_tbs)) cospOUT%rttov_tbs(:,:)         = R_UNDEF          
-       endif
-    endif
-    
-    !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-    ! PART 1: Check input array values for out-of-bounds values. When an out-of-bound value
-    !         is encountered, COSP outputs that are dependent on that input are filled with
-    !         an undefined value (set in cosp_config.f90) and if necessary, that simulator
-    !         is turned off.
-    !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-    if (any([Lisccp_subcolumn, Lisccp_column, Lmisr_subcolumn, Lmisr_column, Lmodis_subcolumn, Lmodis_column])) then
-       if (any(cospgridIN%sunlit .lt. 0)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable: cospgridIN%sunlit contains values out of range (0 or 1)'
-          Lisccp_subcolumn = .false.
-          Lisccp_column    = .false.
-          Lmisr_subcolumn  = .false.
-          Lmisr_column     = .false.
-          Lmodis_subcolumn = .false.
-          Lmodis_column    = .false.
-          if (associated(cospOUT%isccp_totalcldarea))  cospOUT%isccp_totalcldarea(:)  = R_UNDEF
-          if (associated(cospOUT%isccp_meantb))        cospOUT%isccp_meantb(:)        = R_UNDEF
-          if (associated(cospOUT%isccp_meantbclr))     cospOUT%isccp_meantbclr(:)     = R_UNDEF
-          if (associated(cospOUT%isccp_meanptop))      cospOUT%isccp_meanptop(:)      = R_UNDEF
-          if (associated(cospOUT%isccp_meantaucld))    cospOUT%isccp_meantaucld(:)    = R_UNDEF
-          if (associated(cospOUT%isccp_meanalbedocld)) cospOUT%isccp_meanalbedocld(:) = R_UNDEF
-          if (associated(cospOUT%isccp_boxtau))        cospOUT%isccp_boxtau(:,:)      = R_UNDEF
-          if (associated(cospOUT%isccp_boxptop))       cospOUT%isccp_boxptop(:,:)     = R_UNDEF
-          if (associated(cospOUT%isccp_fq))            cospOUT%isccp_fq(:,:,:)        = R_UNDEF
-          if (associated(cospOUT%misr_fq))                   cospOUT%misr_fq(:,:,:)                 = R_UNDEF
-          if (associated(cospOUT%misr_dist_model_layertops)) cospOUT%misr_dist_model_layertops(:,:) = R_UNDEF
-          if (associated(cospOUT%misr_meanztop))             cospOUT%misr_meanztop(:)               = R_UNDEF
-          if (associated(cospOUT%misr_cldarea))              cospOUT%misr_cldarea(:)                = R_UNDEF
-          if (associated(cospOUT%modis_Cloud_Fraction_Total_Mean))                          &
-               cospOUT%modis_Cloud_Fraction_Total_Mean(:)                   = R_UNDEF
-          if (associated(cospOUT%modis_Cloud_Fraction_Water_Mean))                          &
-               cospOUT%modis_Cloud_Fraction_Water_Mean(:)                   = R_UNDEF
-          if (associated(cospOUT%modis_Cloud_Fraction_Ice_Mean))                            &
-               cospOUT%modis_Cloud_Fraction_Ice_Mean(:)                     = R_UNDEF
-          if (associated(cospOUT%modis_Cloud_Fraction_High_Mean))                           &
-               cospOUT%modis_Cloud_Fraction_High_Mean(:)                    = R_UNDEF
-          if (associated(cospOUT%modis_Cloud_Fraction_Mid_Mean))                            &
-               cospOUT%modis_Cloud_Fraction_Mid_Mean(:)                     = R_UNDEF
-          if (associated(cospOUT%modis_Cloud_Fraction_Low_Mean))                            &
-               cospOUT%modis_Cloud_Fraction_Low_Mean(:)                     = R_UNDEF
-          if (associated(cospOUT%modis_Optical_Thickness_Total_Mean))                       &
-               cospOUT%modis_Optical_Thickness_Total_Mean(:)                = R_UNDEF
-          if (associated(cospOUT%modis_Optical_Thickness_Water_Mean))                       &
-               cospOUT%modis_Optical_Thickness_Water_Mean(:)                = R_UNDEF
-          if (associated(cospOUT%modis_Optical_Thickness_Ice_Mean))                         &
-               cospOUT%modis_Optical_Thickness_Ice_Mean(:)                  = R_UNDEF
-          if (associated(cospOUT%modis_Optical_Thickness_Total_LogMean))                    &
-               cospOUT%modis_Optical_Thickness_Total_LogMean(:)             = R_UNDEF
-          if (associated(cospOUT%modis_Optical_Thickness_Water_LogMean))                    &
-               cospOUT%modis_Optical_Thickness_Water_LogMean(:)             = R_UNDEF
-          if (associated(cospOUT%modis_Optical_Thickness_Ice_LogMean))                      &
-               cospOUT%modis_Optical_Thickness_Ice_LogMean(:)               = R_UNDEF
-          if (associated(cospOUT%modis_Cloud_Particle_Size_Water_Mean))                     &
-               cospOUT%modis_Cloud_Particle_Size_Water_Mean(:)              = R_UNDEF
-          if (associated(cospOUT%modis_Cloud_Particle_Size_Ice_Mean))                       &
-               cospOUT%modis_Cloud_Particle_Size_Ice_Mean(:)                = R_UNDEF
-          if (associated(cospOUT%modis_Cloud_Top_Pressure_Total_Mean))                      &
-               cospOUT%modis_Cloud_Top_Pressure_Total_Mean(:)               = R_UNDEF
-          if (associated(cospOUT%modis_Liquid_Water_Path_Mean))                             &
-               cospOUT%modis_Liquid_Water_Path_Mean(:)                      = R_UNDEF
-          if (associated(cospOUT%modis_Ice_Water_Path_Mean))                                &
-               cospOUT%modis_Ice_Water_Path_Mean(:)                         = R_UNDEF
-          if (associated(cospOUT%modis_Optical_Thickness_vs_Cloud_Top_Pressure))            &
-               cospOUT%modis_Optical_Thickness_vs_Cloud_Top_Pressure(:,:,:) = R_UNDEF
-          if (associated(cospOUT%modis_Optical_Thickness_vs_ReffICE))                       &
-               cospOUT%modis_Optical_Thickness_vs_ReffICE(:,:,:)            = R_UNDEF
-          if (associated(cospOUT%modis_Optical_Thickness_vs_ReffLIQ))                       &
-               cospOUT%modis_Optical_Thickness_vs_ReffLIQ(:,:,:)            = R_UNDEF
-       endif
-    endif
-
-    if (any([Lisccp_subcolumn, Lisccp_column, Lmisr_subcolumn, Lmisr_column, Lrttov_column,&
-         Lcalipso_column, Lcloudsat_column, Lradar_lidar_tcc,Llidar_only_freq_cloud, &
-         Lcloudsat_tcc, Lcloudsat_tcc2])) then
-       if (any(cospgridIN%at .lt. 0)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable: cospgridIN%at contains values out of range (at<0), expected units (K)'
-          Lisccp_subcolumn = .false.
-          Lisccp_column    = .false.
-          Lmisr_subcolumn  = .false.
-          Lmisr_column     = .false.
-          Lrttov_column    = .false.
-          Lcalipso_column  = .false.
-          Lcloudsat_column = .false.
-          Lradar_lidar_tcc = .false.
-          Llidar_only_freq_cloud = .false.
-          Lcloudsat_tcc    = .false.
-          Lcloudsat_tcc2   = .false.
-          if (associated(cospOUT%rttov_tbs)) cospOUT%rttov_tbs(:,:)         = R_UNDEF
-          if (associated(cospOUT%isccp_totalcldarea))  cospOUT%isccp_totalcldarea(:)  = R_UNDEF
-          if (associated(cospOUT%isccp_meantb))        cospOUT%isccp_meantb(:)        = R_UNDEF
-          if (associated(cospOUT%isccp_meantbclr))     cospOUT%isccp_meantbclr(:)     = R_UNDEF
-          if (associated(cospOUT%isccp_meanptop))      cospOUT%isccp_meanptop(:)      = R_UNDEF
-          if (associated(cospOUT%isccp_meantaucld))    cospOUT%isccp_meantaucld(:)    = R_UNDEF
-          if (associated(cospOUT%isccp_meanalbedocld)) cospOUT%isccp_meanalbedocld(:) = R_UNDEF
-          if (associated(cospOUT%isccp_boxtau))        cospOUT%isccp_boxtau(:,:)      = R_UNDEF
-          if (associated(cospOUT%isccp_boxptop))       cospOUT%isccp_boxptop(:,:)     = R_UNDEF
-          if (associated(cospOUT%isccp_fq))            cospOUT%isccp_fq(:,:,:)        = R_UNDEF
-          if (associated(cospOUT%misr_fq))                   cospOUT%misr_fq(:,:,:)                 = R_UNDEF
-          if (associated(cospOUT%misr_dist_model_layertops)) cospOUT%misr_dist_model_layertops(:,:) = R_UNDEF
-          if (associated(cospOUT%misr_meanztop))             cospOUT%misr_meanztop(:)               = R_UNDEF
-          if (associated(cospOUT%misr_cldarea))              cospOUT%misr_cldarea(:)                = R_UNDEF
-          if (associated(cospOUT%calipso_cfad_sr))       cospOUT%calipso_cfad_sr(:,:,:)       = R_UNDEF
-          if (associated(cospOUT%calipso_lidarcld))      cospOUT%calipso_lidarcld(:,:)        = R_UNDEF
-          if (associated(cospOUT%calipso_lidarcldphase)) cospOUT%calipso_lidarcldphase(:,:,:) = R_UNDEF
-          if (associated(cospOUT%calipso_cldlayer))      cospOUT%calipso_cldlayer(:,:)        = R_UNDEF
-          if (associated(cospOUT%calipso_cldlayerphase)) cospOUT%calipso_cldlayerphase(:,:,:) = R_UNDEF
-          if (associated(cospOUT%calipso_lidarcldtmp))   cospOUT%calipso_lidarcldtmp(:,:,:)   = R_UNDEF
-          if (associated(cospOUT%calipso_lidarcldtype))  cospOUT%calipso_lidarcldtype(:,:,:)  = R_UNDEF
-          if (associated(cospOUT%calipso_cldtype))       cospOUT%calipso_cldtype(:,:)         = R_UNDEF 
-          if (associated(cospOUT%calipso_cldtypetemp))   cospOUT%calipso_cldtypetemp(:,:)     = R_UNDEF 
-          if (associated(cospOUT%calipso_cldtypemeanz))  cospOUT%calipso_cldtypemeanz(:,:)    = R_UNDEF 
-          if (associated(cospOUT%calipso_cldtypemeanzse)) cospOUT%calipso_cldtypemeanzse(:,:) = R_UNDEF 
-          if (associated(cospOUT%calipso_cldthinemis))   cospOUT%calipso_cldthinemis(:)       = R_UNDEF
-          if (associated(cospOUT%cloudsat_cfad_ze))      cospOUT%cloudsat_cfad_ze(:,:,:)      = R_UNDEF
-          if (associated(cospOUT%lidar_only_freq_cloud)) cospOUT%lidar_only_freq_cloud(:,:)   = R_UNDEF
-          if (associated(cospOUT%radar_lidar_tcc))       cospOUT%radar_lidar_tcc(:)           = R_UNDEF
-          if (associated(cospOUT%cloudsat_tcc)) cospOUT%cloudsat_tcc(:) = R_UNDEF
-          if (associated(cospOUT%cloudsat_tcc2)) cospOUT%cloudsat_tcc2(:) = R_UNDEF
-       endif
-    endif
-    if (any([Lisccp_subcolumn, Lisccp_column, Lrttov_column])) then
-       if (any(cospgridIN%pfull .lt. 0)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable: cospgridIN%pfull contains values out of range'
-          Lisccp_subcolumn = .false.
-          Lisccp_column    = .false.
-          Lrttov_column    = .false.
-          if (associated(cospOUT%rttov_tbs))           cospOUT%rttov_tbs(:,:)         = R_UNDEF
-          if (associated(cospOUT%isccp_totalcldarea))  cospOUT%isccp_totalcldarea(:)  = R_UNDEF
-          if (associated(cospOUT%isccp_meantb))        cospOUT%isccp_meantb(:)        = R_UNDEF
-          if (associated(cospOUT%isccp_meantbclr))     cospOUT%isccp_meantbclr(:)     = R_UNDEF
-          if (associated(cospOUT%isccp_meanptop))      cospOUT%isccp_meanptop(:)      = R_UNDEF
-          if (associated(cospOUT%isccp_meantaucld))    cospOUT%isccp_meantaucld(:)    = R_UNDEF
-          if (associated(cospOUT%isccp_meanalbedocld)) cospOUT%isccp_meanalbedocld(:) = R_UNDEF
-          if (associated(cospOUT%isccp_boxtau))        cospOUT%isccp_boxtau(:,:)      = R_UNDEF
-          if (associated(cospOUT%isccp_boxptop))       cospOUT%isccp_boxptop(:,:)     = R_UNDEF
-          if (associated(cospOUT%isccp_fq))            cospOUT%isccp_fq(:,:,:)        = R_UNDEF
-       endif
-    endif
-    if (any([Lisccp_subcolumn,Lisccp_column,Lmodis_subcolumn,Lmodis_column,Lcalipso_column,Lrttov_column,&
-             LgrLidar532_column,Latlid_column])) then
-       if (any(cospgridIN%phalf .lt. 0)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable: cospgridIN%phalf contains values out of range'
-          Lisccp_subcolumn = .false.
-          Lisccp_column    = .false.
-          Lmodis_subcolumn = .false.
-          Lmodis_column    = .false.
-          Lcalipso_column  = .false.
-          Lrttov_column    = .false.
-          Latlid_column    = .false.
-          LgrLidar532_column = .false.
-          if (associated(cospOUT%rttov_tbs))           cospOUT%rttov_tbs(:,:)         = R_UNDEF
-          if (associated(cospOUT%isccp_totalcldarea))  cospOUT%isccp_totalcldarea(:)  = R_UNDEF
-          if (associated(cospOUT%isccp_meantb))        cospOUT%isccp_meantb(:)        = R_UNDEF
-          if (associated(cospOUT%isccp_meantbclr))     cospOUT%isccp_meantbclr(:)     = R_UNDEF
-          if (associated(cospOUT%isccp_meanptop))      cospOUT%isccp_meanptop(:)      = R_UNDEF
-          if (associated(cospOUT%isccp_meantaucld))    cospOUT%isccp_meantaucld(:)    = R_UNDEF
-          if (associated(cospOUT%isccp_meanalbedocld)) cospOUT%isccp_meanalbedocld(:) = R_UNDEF
-          if (associated(cospOUT%isccp_boxtau))        cospOUT%isccp_boxtau(:,:)      = R_UNDEF
-          if (associated(cospOUT%isccp_boxptop))       cospOUT%isccp_boxptop(:,:)     = R_UNDEF
-          if (associated(cospOUT%isccp_fq))            cospOUT%isccp_fq(:,:,:)        = R_UNDEF
-          if (associated(cospOUT%modis_Cloud_Fraction_Total_Mean))                          &
-               cospOUT%modis_Cloud_Fraction_Total_Mean(:)                   = R_UNDEF
-          if (associated(cospOUT%modis_Cloud_Fraction_Water_Mean))                          &
-               cospOUT%modis_Cloud_Fraction_Water_Mean(:)                   = R_UNDEF
-          if (associated(cospOUT%modis_Cloud_Fraction_Ice_Mean))                            &
-               cospOUT%modis_Cloud_Fraction_Ice_Mean(:)                     = R_UNDEF
-          if (associated(cospOUT%modis_Cloud_Fraction_High_Mean))                           &
-               cospOUT%modis_Cloud_Fraction_High_Mean(:)                    = R_UNDEF
-          if (associated(cospOUT%modis_Cloud_Fraction_Mid_Mean))                            &
-               cospOUT%modis_Cloud_Fraction_Mid_Mean(:)                     = R_UNDEF
-          if (associated(cospOUT%modis_Cloud_Fraction_Low_Mean))                            &
-               cospOUT%modis_Cloud_Fraction_Low_Mean(:)                     = R_UNDEF
-          if (associated(cospOUT%modis_Optical_Thickness_Total_Mean))                       &
-               cospOUT%modis_Optical_Thickness_Total_Mean(:)                = R_UNDEF
-          if (associated(cospOUT%modis_Optical_Thickness_Water_Mean))                       &
-               cospOUT%modis_Optical_Thickness_Water_Mean(:)                = R_UNDEF
-          if (associated(cospOUT%modis_Optical_Thickness_Ice_Mean))                         &
-               cospOUT%modis_Optical_Thickness_Ice_Mean(:)                  = R_UNDEF
-          if (associated(cospOUT%modis_Optical_Thickness_Total_LogMean))                    &
-               cospOUT%modis_Optical_Thickness_Total_LogMean(:)             = R_UNDEF
-          if (associated(cospOUT%modis_Optical_Thickness_Water_LogMean))                    &
-               cospOUT%modis_Optical_Thickness_Water_LogMean(:)             = R_UNDEF
-          if (associated(cospOUT%modis_Optical_Thickness_Ice_LogMean))                      &
-               cospOUT%modis_Optical_Thickness_Ice_LogMean(:)               = R_UNDEF
-          if (associated(cospOUT%modis_Cloud_Particle_Size_Water_Mean))                     &
-               cospOUT%modis_Cloud_Particle_Size_Water_Mean(:)              = R_UNDEF
-          if (associated(cospOUT%modis_Cloud_Particle_Size_Ice_Mean))                       &
-               cospOUT%modis_Cloud_Particle_Size_Ice_Mean(:)                = R_UNDEF
-          if (associated(cospOUT%modis_Cloud_Top_Pressure_Total_Mean))                      &
-               cospOUT%modis_Cloud_Top_Pressure_Total_Mean(:)               = R_UNDEF
-          if (associated(cospOUT%modis_Liquid_Water_Path_Mean))                             &
-               cospOUT%modis_Liquid_Water_Path_Mean(:)                      = R_UNDEF
-          if (associated(cospOUT%modis_Ice_Water_Path_Mean))                                &
-               cospOUT%modis_Ice_Water_Path_Mean(:)                         = R_UNDEF
-          if (associated(cospOUT%modis_Optical_Thickness_vs_Cloud_Top_Pressure))            &
-               cospOUT%modis_Optical_Thickness_vs_Cloud_Top_Pressure(:,:,:) = R_UNDEF
-          if (associated(cospOUT%modis_Optical_Thickness_vs_ReffICE))                       &
-               cospOUT%modis_Optical_Thickness_vs_ReffICE(:,:,:)            = R_UNDEF
-          if (associated(cospOUT%modis_Optical_Thickness_vs_ReffLIQ))                       &
-               cospOUT%modis_Optical_Thickness_vs_ReffLIQ(:,:,:)            = R_UNDEF
-          if (associated(cospOUT%calipso_cfad_sr))       cospOUT%calipso_cfad_sr(:,:,:)       = R_UNDEF
-          if (associated(cospOUT%calipso_lidarcld))      cospOUT%calipso_lidarcld(:,:)        = R_UNDEF
-          if (associated(cospOUT%calipso_lidarcldphase)) cospOUT%calipso_lidarcldphase(:,:,:) = R_UNDEF
-          if (associated(cospOUT%calipso_cldlayer))      cospOUT%calipso_cldlayer(:,:)        = R_UNDEF
-          if (associated(cospOUT%calipso_cldlayerphase)) cospOUT%calipso_cldlayerphase(:,:,:) = R_UNDEF
-          if (associated(cospOUT%calipso_lidarcldtmp))   cospOUT%calipso_lidarcldtmp(:,:,:)   = R_UNDEF
-          if (associated(cospOUT%atlid_cfad_sr))         cospOUT%atlid_cfad_sr(:,:,:)         = R_UNDEF
-          if (associated(cospOUT%atlid_lidarcld))        cospOUT%atlid_lidarcld(:,:)          = R_UNDEF
-          if (associated(cospOUT%atlid_cldlayer))        cospOUT%atlid_cldlayer(:,:)          = R_UNDEF
-          if (associated(cospOUT%grLidar532_cfad_sr))   cospOUT%grLidar532_cfad_sr(:,:,:)   = R_UNDEF
-          if (associated(cospOUT%grLidar532_lidarcld))  cospOUT%grLidar532_lidarcld(:,:)    = R_UNDEF
-          if (associated(cospOUT%grLidar532_cldlayer))  cospOUT%grLidar532_cldlayer(:,:)    = R_UNDEF
-          if (associated(cospOUT%calipso_lidarcldtype))  cospOUT%calipso_lidarcldtype(:,:,:)  = R_UNDEF 
-          if (associated(cospOUT%calipso_cldtype))       cospOUT%calipso_cldtype(:,:)         = R_UNDEF 
-          if (associated(cospOUT%calipso_cldtypetemp))   cospOUT%calipso_cldtypetemp(:,:)     = R_UNDEF
-          if (associated(cospOUT%calipso_cldtypemeanz))  cospOUT%calipso_cldtypemeanz(:,:)    = R_UNDEF
-          if (associated(cospOUT%calipso_cldtypemeanzse)) cospOUT%calipso_cldtypemeanzse(:,:) = R_UNDEF
-          if (associated(cospOUT%calipso_cldthinemis))   cospOUT%calipso_cldthinemis(:)       = R_UNDEF
-       endif
-    endif
-    if (any([Lisccp_subcolumn,Lisccp_column,Lrttov_column])) then
-       if (any(cospgridIN%qv .lt. 0)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable: cospgridIN%qv contains values out of range'
-          Lisccp_subcolumn = .false.
-          Lisccp_column    = .false.
-          Lrttov_column    = .false.
-          if (associated(cospOUT%rttov_tbs))           cospOUT%rttov_tbs(:,:)         = R_UNDEF
-          if (associated(cospOUT%isccp_totalcldarea))  cospOUT%isccp_totalcldarea(:)  = R_UNDEF
-          if (associated(cospOUT%isccp_meantb))        cospOUT%isccp_meantb(:)        = R_UNDEF
-          if (associated(cospOUT%isccp_meantbclr))     cospOUT%isccp_meantbclr(:)     = R_UNDEF
-          if (associated(cospOUT%isccp_meanptop))      cospOUT%isccp_meanptop(:)      = R_UNDEF
-          if (associated(cospOUT%isccp_meantaucld))    cospOUT%isccp_meantaucld(:)    = R_UNDEF
-          if (associated(cospOUT%isccp_meanalbedocld)) cospOUT%isccp_meanalbedocld(:) = R_UNDEF
-          if (associated(cospOUT%isccp_boxtau))        cospOUT%isccp_boxtau(:,:)      = R_UNDEF
-          if (associated(cospOUT%isccp_boxptop))       cospOUT%isccp_boxptop(:,:)     = R_UNDEF
-          if (associated(cospOUT%isccp_fq))            cospOUT%isccp_fq(:,:,:)        = R_UNDEF
-       endif
-    endif
-    if (any([Lmisr_subcolumn,Lmisr_column,Lcloudsat_subcolumn,Lcloudsat_column,Lcalipso_column,Lradar_lidar_tcc,&
-         Llidar_only_freq_cloud,LgrLidar532_column,Latlid_column,Lcloudsat_tcc, Lcloudsat_tcc2])) then
-       if (any(cospgridIN%hgt_matrix .lt. -300)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable: cospgridIN%hgt_matrix contains values out of range'
-          Lmisr_subcolumn     = .false.
-          Lmisr_column        = .false.
-          Lcloudsat_subcolumn = .false.
-          Lcloudsat_column    = .false.
-          Lcalipso_column     = .false.
-          Lradar_lidar_tcc    = .false.
-          Llidar_only_freq_cloud = .false.
-          Lcloudsat_tcc       = .false.
-          Lcloudsat_tcc2      = .false.
-          Latlid_column       = .false.
-          LgrLidar532_column  = .false.
-          if (associated(cospOUT%misr_fq))                   cospOUT%misr_fq(:,:,:)                 = R_UNDEF
-          if (associated(cospOUT%misr_dist_model_layertops)) cospOUT%misr_dist_model_layertops(:,:) = R_UNDEF
-          if (associated(cospOUT%misr_meanztop))             cospOUT%misr_meanztop(:)               = R_UNDEF
-          if (associated(cospOUT%misr_cldarea))              cospOUT%misr_cldarea(:)                = R_UNDEF
-          if (associated(cospOUT%calipso_cfad_sr))           cospOUT%calipso_cfad_sr(:,:,:)         = R_UNDEF
-          if (associated(cospOUT%calipso_lidarcld))          cospOUT%calipso_lidarcld(:,:)          = R_UNDEF
-          if (associated(cospOUT%calipso_lidarcldphase))     cospOUT%calipso_lidarcldphase(:,:,:)   = R_UNDEF
-          if (associated(cospOUT%calipso_cldlayer))          cospOUT%calipso_cldlayer(:,:)          = R_UNDEF
-          if (associated(cospOUT%calipso_cldlayerphase))     cospOUT%calipso_cldlayerphase(:,:,:)   = R_UNDEF
-          if (associated(cospOUT%calipso_lidarcldtmp))       cospOUT%calipso_lidarcldtmp(:,:,:)     = R_UNDEF
-          if (associated(cospOUT%cloudsat_cfad_ze))          cospOUT%cloudsat_cfad_ze(:,:,:)        = R_UNDEF
-          if (associated(cospOUT%cloudsat_Ze_tot))           cospOUT%cloudsat_Ze_tot(:,:,:)         = R_UNDEF
-          if (associated(cospOUT%lidar_only_freq_cloud))     cospOUT%lidar_only_freq_cloud(:,:)     = R_UNDEF
-          if (associated(cospOUT%radar_lidar_tcc))           cospOUT%radar_lidar_tcc(:)             = R_UNDEF
-          if (associated(cospOUT%cloudsat_tcc))              cospOUT%cloudsat_tcc(:)                = R_UNDEF
-          if (associated(cospOUT%cloudsat_tcc2))             cospOUT%cloudsat_tcc2(:)               = R_UNDEF
-          if (associated(cospOUT%atlid_cfad_sr))             cospOUT%atlid_cfad_sr(:,:,:)           = R_UNDEF
-          if (associated(cospOUT%atlid_lidarcld))            cospOUT%atlid_lidarcld(:,:)            = R_UNDEF
-          if (associated(cospOUT%atlid_cldlayer))            cospOUT%atlid_cldlayer(:,:)            = R_UNDEF
-          if (associated(cospOUT%grLidar532_cfad_sr))        cospOUT%grLidar532_cfad_sr(:,:,:)      = R_UNDEF
-          if (associated(cospOUT%grLidar532_lidarcld))       cospOUT%grLidar532_lidarcld(:,:)       = R_UNDEF
-          if (associated(cospOUT%grLidar532_cldlayer))       cospOUT%grLidar532_cldlayer(:,:)       = R_UNDEF
-          if (associated(cospOUT%calipso_lidarcldtype))      cospOUT%calipso_lidarcldtype(:,:,:)    = R_UNDEF
-          if (associated(cospOUT%calipso_cldtype))           cospOUT%calipso_cldtype(:,:)           = R_UNDEF 
-          if (associated(cospOUT%calipso_cldtypetemp))       cospOUT%calipso_cldtypetemp(:,:)       = R_UNDEF 
-          if (associated(cospOUT%calipso_cldtypemeanz))      cospOUT%calipso_cldtypemeanz(:,:)      = R_UNDEF 
-          if (associated(cospOUT%calipso_cldtypemeanzse))    cospOUT%calipso_cldtypemeanzse(:,:)    = R_UNDEF
-          if (associated(cospOUT%calipso_cldthinemis))       cospOUT%calipso_cldthinemis(:)         = R_UNDEF
-       endif
-    endif
-    if (any([Lrttov_column,Lcloudsat_column,Lcalipso_column,Lradar_lidar_tcc,Llidar_only_freq_cloud, &
-             LgrLidar532_column, Latlid_column, Lcloudsat_tcc, Lcloudsat_tcc2])) then
-       if (any(cospgridIN%hgt_matrix_half .lt. -300)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable: cospgridIN%hgt_matrix_half contains values out of range'
-          Lrttov_column    = .false.
-          Lcloudsat_column = .false.
-          Lcalipso_column  = .false.
-          Lradar_lidar_tcc = .false.
-          Llidar_only_freq_cloud = .false.
-          Lcloudsat_tcc    = .false.
-          Lcloudsat_tcc2   = .false.
-          Latlid_column       = .false.
-          LgrLidar532_column = .false.
-          if (associated(cospOUT%rttov_tbs))              cospOUT%rttov_tbs(:,:)               = R_UNDEF
-          if (associated(cospOUT%calipso_cfad_sr))        cospOUT%calipso_cfad_sr(:,:,:)       = R_UNDEF
-          if (associated(cospOUT%calipso_lidarcld))       cospOUT%calipso_lidarcld(:,:)        = R_UNDEF
-          if (associated(cospOUT%calipso_lidarcldphase))  cospOUT%calipso_lidarcldphase(:,:,:) = R_UNDEF
-          if (associated(cospOUT%calipso_cldlayer))       cospOUT%calipso_cldlayer(:,:)        = R_UNDEF
-          if (associated(cospOUT%calipso_cldlayerphase))  cospOUT%calipso_cldlayerphase(:,:,:) = R_UNDEF
-          if (associated(cospOUT%calipso_lidarcldtmp))    cospOUT%calipso_lidarcldtmp(:,:,:)   = R_UNDEF
-          if (associated(cospOUT%cloudsat_cfad_ze))       cospOUT%cloudsat_cfad_ze(:,:,:)      = R_UNDEF
-          if (associated(cospOUT%lidar_only_freq_cloud))  cospOUT%lidar_only_freq_cloud(:,:)   = R_UNDEF
-          if (associated(cospOUT%radar_lidar_tcc))        cospOUT%radar_lidar_tcc(:)           = R_UNDEF
-          if (associated(cospOUT%cloudsat_tcc))           cospOUT%cloudsat_tcc(:)              = R_UNDEF
-          if (associated(cospOUT%cloudsat_tcc2))          cospOUT%cloudsat_tcc2(:)             = R_UNDEF          
-          if (associated(cospOUT%atlid_cfad_sr))          cospOUT%atlid_cfad_sr(:,:,:)         = R_UNDEF
-          if (associated(cospOUT%atlid_lidarcld))         cospOUT%atlid_lidarcld(:,:)          = R_UNDEF
-          if (associated(cospOUT%atlid_cldlayer))         cospOUT%atlid_cldlayer(:,:)          = R_UNDEF
-          if (associated(cospOUT%grLidar532_cfad_sr))     cospOUT%grLidar532_cfad_sr(:,:,:)    = R_UNDEF
-          if (associated(cospOUT%grLidar532_lidarcld))    cospOUT%grLidar532_lidarcld(:,:)     = R_UNDEF
-          if (associated(cospOUT%grLidar532_cldlayer))    cospOUT%grLidar532_cldlayer(:,:)     = R_UNDEF
-          if (associated(cospOUT%calipso_lidarcldtype))   cospOUT%calipso_lidarcldtype(:,:,:)  = R_UNDEF
-          if (associated(cospOUT%calipso_cldtype))        cospOUT%calipso_cldtype(:,:)         = R_UNDEF 
-          if (associated(cospOUT%calipso_cldtypetemp))    cospOUT%calipso_cldtypetemp(:,:)     = R_UNDEF 
-          if (associated(cospOUT%calipso_cldtypemeanz))   cospOUT%calipso_cldtypemeanz(:,:)    = R_UNDEF 
-          if (associated(cospOUT%calipso_cldtypemeanzse)) cospOUT%calipso_cldtypemeanzse(:,:)  = R_UNDEF 
-          if (associated(cospOUT%calipso_cldthinemis))    cospOUT%calipso_cldthinemis(:)       = R_UNDEF
-       endif
-    endif
-    if (any([Lrttov_column,Lcalipso_column,Lparasol_column])) then
-       if (any(cospgridIN%land .lt. 0)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable: cospgridIN%land contains values out of range'
-          Lrttov_column    = .false.
-          Lcalipso_column  = .false.
-          Lparasol_column  = .false.
-          if (associated(cospOUT%rttov_tbs))             cospOUT%rttov_tbs(:,:)               = R_UNDEF
-          if (associated(cospOUT%calipso_cfad_sr))       cospOUT%calipso_cfad_sr(:,:,:)       = R_UNDEF
-          if (associated(cospOUT%calipso_lidarcld))      cospOUT%calipso_lidarcld(:,:)        = R_UNDEF
-          if (associated(cospOUT%calipso_lidarcldphase)) cospOUT%calipso_lidarcldphase(:,:,:) = R_UNDEF
-          if (associated(cospOUT%calipso_cldlayer))      cospOUT%calipso_cldlayer(:,:)        = R_UNDEF
-          if (associated(cospOUT%calipso_cldlayerphase)) cospOUT%calipso_cldlayerphase(:,:,:) = R_UNDEF
-          if (associated(cospOUT%calipso_lidarcldtmp))   cospOUT%calipso_lidarcldtmp(:,:,:)   = R_UNDEF
-          if (associated(cospOUT%calipso_lidarcldtype))  cospOUT%calipso_lidarcldtype(:,:,:)  = R_UNDEF
-          if (associated(cospOUT%calipso_cldtype))       cospOUT%calipso_cldtype(:,:)         = R_UNDEF 
-          if (associated(cospOUT%calipso_cldtypetemp))   cospOUT%calipso_cldtypetemp(:,:)     = R_UNDEF 
-          if (associated(cospOUT%calipso_cldtypemeanz))  cospOUT%calipso_cldtypemeanz(:,:)    = R_UNDEF
-          if (associated(cospOUT%calipso_cldtypemeanzse)) cospOUT%calipso_cldtypemeanzse(:,:) = R_UNDEF
-          if (associated(cospOUT%calipso_cldthinemis))   cospOUT%calipso_cldthinemis(:)       = R_UNDEF
-          if (associated(cospOUT%parasolGrid_refl))      cospOUT%parasolGrid_refl(:,:)        = R_UNDEF
-       endif
-    endif
-    if (any([Lisccp_subcolumn,Lisccp_column,Lrttov_column])) then
-       if (any(cospgridIN%skt .lt. 0)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable: cospgridIN%skt contains values out of range'
-          Lisccp_subcolumn = .false.
-          Lisccp_column    = .false.
-          Lrttov_column    = .false.
-          if (associated(cospOUT%rttov_tbs))           cospOUT%rttov_tbs(:,:)         = R_UNDEF
-          if (associated(cospOUT%isccp_totalcldarea))  cospOUT%isccp_totalcldarea(:)  = R_UNDEF
-          if (associated(cospOUT%isccp_meantb))        cospOUT%isccp_meantb(:)        = R_UNDEF
-          if (associated(cospOUT%isccp_meantbclr))     cospOUT%isccp_meantbclr(:)     = R_UNDEF
-          if (associated(cospOUT%isccp_meanptop))      cospOUT%isccp_meanptop(:)      = R_UNDEF
-          if (associated(cospOUT%isccp_meantaucld))    cospOUT%isccp_meantaucld(:)    = R_UNDEF
-          if (associated(cospOUT%isccp_meanalbedocld)) cospOUT%isccp_meanalbedocld(:) = R_UNDEF
-          if (associated(cospOUT%isccp_boxtau))        cospOUT%isccp_boxtau(:,:)      = R_UNDEF
-          if (associated(cospOUT%isccp_boxptop))       cospOUT%isccp_boxptop(:,:)     = R_UNDEF
-          if (associated(cospOUT%isccp_fq))            cospOUT%isccp_fq(:,:,:)        = R_UNDEF
-       endif
-    endif
-    
-    ! RTTOV Inputs
-    if (Lrttov_column) then
-       if (cospgridIN%zenang .lt. -90. .OR. cospgridIN%zenang .gt. 90) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable: cospgridIN%zenang contains values out of range'
-          Lrttov_column = .false.
-          if (associated(cospOUT%rttov_tbs)) cospOUT%rttov_tbs(:,:) = R_UNDEF
-       endif
-       if (cospgridIN%co2 .lt. 0) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable: cospgridIN%co2 contains values out of range'
-          Lrttov_column = .false.
-          if (associated(cospOUT%rttov_tbs)) cospOUT%rttov_tbs(:,:) = R_UNDEF
-       endif
-       if (cospgridIN%ch4 .lt. 0) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable: cospgridIN%ch4 contains values out of range'
-          Lrttov_column = .false.
-          if (associated(cospOUT%rttov_tbs)) cospOUT%rttov_tbs(:,:) = R_UNDEF
-       endif
-       if (cospgridIN%n2o .lt. 0) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable: cospgridIN%n2o contains values out of range'
-          Lrttov_column = .false.
-          if (associated(cospOUT%rttov_tbs)) cospOUT%rttov_tbs(:,:) = R_UNDEF
-       endif
-       if (cospgridIN%co.lt. 0) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable: cospgridIN%co contains values out of range'
-          Lrttov_column = .false.
-          if (associated(cospOUT%rttov_tbs)) cospOUT%rttov_tbs(:,:) = R_UNDEF
-       endif
-       if (any(cospgridIN%o3 .lt. 0)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable: cospgridIN%o3 contains values out of range'
-          Lrttov_column = .false.
-          if (associated(cospOUT%rttov_tbs)) cospOUT%rttov_tbs(:,:) = R_UNDEF
-       endif
-       if (any(cospgridIN%emis_sfc .lt. 0. .OR. cospgridIN%emis_sfc .gt. 1)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable: cospgridIN%emis_sfc contains values out of range'
-          Lrttov_column = .false.
-          if (associated(cospOUT%rttov_tbs)) cospOUT%rttov_tbs(:,:) = R_UNDEF
-       endif
-       if (any(cospgridIN%u_sfc .lt. -100. .OR. cospgridIN%u_sfc .gt. 100.)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable: cospIN%u_sfc contains values out of range'
-          if (associated(cospOUT%rttov_tbs)) cospOUT%rttov_tbs(:,:) = R_UNDEF
-          Lrttov_column = .false.
-       endif
-       if (any(cospgridIN%v_sfc .lt. -100. .OR. cospgridIN%v_sfc .gt. 100.)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable: cospIN%v_sfc contains values out of range'
-          Lrttov_column = .false.
-          if (associated(cospOUT%rttov_tbs)) cospOUT%rttov_tbs(:,:) = R_UNDEF
-       endif
-       if (any(cospgridIN%lat .lt. -90 .OR. cospgridIN%lat .gt. 90)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable: cospIN%lat contains values out of range'
-          Lrttov_column = .false.
-          if (associated(cospOUT%rttov_tbs)) cospOUT%rttov_tbs(:,:) = R_UNDEF
-       endif
-    endif
-    
-    ! COSP_INPUTS
-    if (any([Lisccp_subcolumn,Lisccp_column])) then
-       if (cospIN%emsfc_lw .lt. 0. .OR. cospIN%emsfc_lw .gt. 1.) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable: cospIN%emsfc_lw contains values out of range'
-          Lisccp_subcolumn = .false.
-          Lisccp_column    = .false.
-          if (associated(cospOUT%isccp_totalcldarea))  cospOUT%isccp_totalcldarea(:)  = R_UNDEF
-          if (associated(cospOUT%isccp_meantb))        cospOUT%isccp_meantb(:)        = R_UNDEF
-          if (associated(cospOUT%isccp_meantbclr))     cospOUT%isccp_meantbclr(:)     = R_UNDEF
-          if (associated(cospOUT%isccp_meanptop))      cospOUT%isccp_meanptop(:)      = R_UNDEF
-          if (associated(cospOUT%isccp_meantaucld))    cospOUT%isccp_meantaucld(:)    = R_UNDEF
-          if (associated(cospOUT%isccp_meanalbedocld)) cospOUT%isccp_meanalbedocld(:) = R_UNDEF
-          if (associated(cospOUT%isccp_boxtau))        cospOUT%isccp_boxtau(:,:)      = R_UNDEF
-          if (associated(cospOUT%isccp_boxptop))       cospOUT%isccp_boxptop(:,:)     = R_UNDEF
-          if (associated(cospOUT%isccp_fq))            cospOUT%isccp_fq(:,:,:)        = R_UNDEF
-       endif
-    endif
-    if (any([Lisccp_subcolumn,Lisccp_column,Lmisr_subcolumn,Lmisr_column,Lmodis_subcolumn,Lmodis_column])) then
-       if (any(cospIN%tau_067 .lt. 0)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable: cospIN%tau_067 contains values out of range'
-          Lisccp_subcolumn = .false.
-          Lisccp_column    = .false.
-          Lmisr_subcolumn  = .false.
-          Lmisr_column     = .false.
-          Lmodis_subcolumn = .false.
-          Lmodis_column    = .false.
-          if (associated(cospOUT%isccp_totalcldarea))  cospOUT%isccp_totalcldarea(:)  = R_UNDEF
-          if (associated(cospOUT%isccp_meantb))        cospOUT%isccp_meantb(:)        = R_UNDEF
-          if (associated(cospOUT%isccp_meantbclr))     cospOUT%isccp_meantbclr(:)     = R_UNDEF
-          if (associated(cospOUT%isccp_meanptop))      cospOUT%isccp_meanptop(:)      = R_UNDEF
-          if (associated(cospOUT%isccp_meantaucld))    cospOUT%isccp_meantaucld(:)    = R_UNDEF
-          if (associated(cospOUT%isccp_meanalbedocld)) cospOUT%isccp_meanalbedocld(:) = R_UNDEF
-          if (associated(cospOUT%isccp_boxtau))        cospOUT%isccp_boxtau(:,:)      = R_UNDEF
-          if (associated(cospOUT%isccp_boxptop))       cospOUT%isccp_boxptop(:,:)     = R_UNDEF
-          if (associated(cospOUT%isccp_fq))            cospOUT%isccp_fq(:,:,:)        = R_UNDEF
-          if (associated(cospOUT%misr_fq))                   cospOUT%misr_fq(:,:,:)                 = R_UNDEF
-          if (associated(cospOUT%misr_dist_model_layertops)) cospOUT%misr_dist_model_layertops(:,:) = R_UNDEF
-          if (associated(cospOUT%misr_meanztop))             cospOUT%misr_meanztop(:)               = R_UNDEF
-          if (associated(cospOUT%misr_cldarea))              cospOUT%misr_cldarea(:)                = R_UNDEF
-          if (associated(cospOUT%modis_Cloud_Fraction_Total_Mean))                          &
-               cospOUT%modis_Cloud_Fraction_Total_Mean(:)                   = R_UNDEF
-          if (associated(cospOUT%modis_Cloud_Fraction_Water_Mean))                          &
-               cospOUT%modis_Cloud_Fraction_Water_Mean(:)                   = R_UNDEF
-          if (associated(cospOUT%modis_Cloud_Fraction_Ice_Mean))                            &
-               cospOUT%modis_Cloud_Fraction_Ice_Mean(:)                     = R_UNDEF
-          if (associated(cospOUT%modis_Cloud_Fraction_High_Mean))                           &
-               cospOUT%modis_Cloud_Fraction_High_Mean(:)                    = R_UNDEF
-          if (associated(cospOUT%modis_Cloud_Fraction_Mid_Mean))                            &
-               cospOUT%modis_Cloud_Fraction_Mid_Mean(:)                     = R_UNDEF
-          if (associated(cospOUT%modis_Cloud_Fraction_Low_Mean))                            &
-               cospOUT%modis_Cloud_Fraction_Low_Mean(:)                     = R_UNDEF
-          if (associated(cospOUT%modis_Optical_Thickness_Total_Mean))                       &
-               cospOUT%modis_Optical_Thickness_Total_Mean(:)                = R_UNDEF
-          if (associated(cospOUT%modis_Optical_Thickness_Water_Mean))                       &
-               cospOUT%modis_Optical_Thickness_Water_Mean(:)                = R_UNDEF
-          if (associated(cospOUT%modis_Optical_Thickness_Ice_Mean))                         &
-               cospOUT%modis_Optical_Thickness_Ice_Mean(:)                  = R_UNDEF
-          if (associated(cospOUT%modis_Optical_Thickness_Total_LogMean))                    &
-               cospOUT%modis_Optical_Thickness_Total_LogMean(:)             = R_UNDEF
-          if (associated(cospOUT%modis_Optical_Thickness_Water_LogMean))                    &
-               cospOUT%modis_Optical_Thickness_Water_LogMean(:)             = R_UNDEF
-          if (associated(cospOUT%modis_Optical_Thickness_Ice_LogMean))                      &
-               cospOUT%modis_Optical_Thickness_Ice_LogMean(:)               = R_UNDEF
-          if (associated(cospOUT%modis_Cloud_Particle_Size_Water_Mean))                     &
-               cospOUT%modis_Cloud_Particle_Size_Water_Mean(:)              = R_UNDEF
-          if (associated(cospOUT%modis_Cloud_Particle_Size_Ice_Mean))                       &
-               cospOUT%modis_Cloud_Particle_Size_Ice_Mean(:)                = R_UNDEF
-          if (associated(cospOUT%modis_Cloud_Top_Pressure_Total_Mean))                      &
-               cospOUT%modis_Cloud_Top_Pressure_Total_Mean(:)               = R_UNDEF
-          if (associated(cospOUT%modis_Liquid_Water_Path_Mean))                             &
-               cospOUT%modis_Liquid_Water_Path_Mean(:)                      = R_UNDEF
-          if (associated(cospOUT%modis_Ice_Water_Path_Mean))                                &
-               cospOUT%modis_Ice_Water_Path_Mean(:)                         = R_UNDEF
-          if (associated(cospOUT%modis_Optical_Thickness_vs_Cloud_Top_Pressure))            &
-               cospOUT%modis_Optical_Thickness_vs_Cloud_Top_Pressure(:,:,:) = R_UNDEF
-          if (associated(cospOUT%modis_Optical_Thickness_vs_ReffICE))                       &
-               cospOUT%modis_Optical_Thickness_vs_ReffICE(:,:,:)            = R_UNDEF
-          if (associated(cospOUT%modis_Optical_Thickness_vs_ReffLIQ))                       &
-               cospOUT%modis_Optical_Thickness_vs_ReffLIQ(:,:,:)            = R_UNDEF
-       endif
-    endif
-    if (any([Lisccp_subcolumn,Lisccp_column])) then
-       if (any(cospIN%emiss_11 .lt. 0. .OR. cospIN%emiss_11 .gt. 1)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable: cospIN%emiss_11 contains values out of range'
-          Lisccp_subcolumn = .false.
-          Lisccp_column    = .false.
-          if (associated(cospOUT%isccp_totalcldarea))  cospOUT%isccp_totalcldarea(:)  = R_UNDEF
-          if (associated(cospOUT%isccp_meantb))        cospOUT%isccp_meantb(:)        = R_UNDEF
-          if (associated(cospOUT%isccp_meantbclr))     cospOUT%isccp_meantbclr(:)     = R_UNDEF
-          if (associated(cospOUT%isccp_meanptop))      cospOUT%isccp_meanptop(:)      = R_UNDEF
-          if (associated(cospOUT%isccp_meantaucld))    cospOUT%isccp_meantaucld(:)    = R_UNDEF
-          if (associated(cospOUT%isccp_meanalbedocld)) cospOUT%isccp_meanalbedocld(:) = R_UNDEF
-          if (associated(cospOUT%isccp_boxtau))        cospOUT%isccp_boxtau(:,:)      = R_UNDEF
-          if (associated(cospOUT%isccp_boxptop))       cospOUT%isccp_boxptop(:,:)     = R_UNDEF
-          if (associated(cospOUT%isccp_fq))            cospOUT%isccp_fq(:,:,:)        = R_UNDEF
-       endif
-    endif
-    if (any([Lmodis_subcolumn,Lmodis_column])) then
-       if (any(cospIN%asym .lt. -1. .OR. cospIN%asym .gt. 1)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable: cospIN%asym contains values out of range'
-          Lmodis_subcolumn = .false.
-          Lmodis_column    = .false.
-          if (associated(cospOUT%modis_Cloud_Fraction_Total_Mean))                          &
-               cospOUT%modis_Cloud_Fraction_Total_Mean(:)                   = R_UNDEF
-          if (associated(cospOUT%modis_Cloud_Fraction_Water_Mean))                          &
-               cospOUT%modis_Cloud_Fraction_Water_Mean(:)                   = R_UNDEF
-          if (associated(cospOUT%modis_Cloud_Fraction_Ice_Mean))                            &
-               cospOUT%modis_Cloud_Fraction_Ice_Mean(:)                     = R_UNDEF
-          if (associated(cospOUT%modis_Cloud_Fraction_High_Mean))                           &
-               cospOUT%modis_Cloud_Fraction_High_Mean(:)                    = R_UNDEF
-          if (associated(cospOUT%modis_Cloud_Fraction_Mid_Mean))                            &
-               cospOUT%modis_Cloud_Fraction_Mid_Mean(:)                     = R_UNDEF
-          if (associated(cospOUT%modis_Cloud_Fraction_Low_Mean))                            &
-               cospOUT%modis_Cloud_Fraction_Low_Mean(:)                     = R_UNDEF
-          if (associated(cospOUT%modis_Optical_Thickness_Total_Mean))                       &
-               cospOUT%modis_Optical_Thickness_Total_Mean(:)                = R_UNDEF
-          if (associated(cospOUT%modis_Optical_Thickness_Water_Mean))                       &
-               cospOUT%modis_Optical_Thickness_Water_Mean(:)                = R_UNDEF
-          if (associated(cospOUT%modis_Optical_Thickness_Ice_Mean))                         &
-               cospOUT%modis_Optical_Thickness_Ice_Mean(:)                  = R_UNDEF
-          if (associated(cospOUT%modis_Optical_Thickness_Total_LogMean))                    &
-               cospOUT%modis_Optical_Thickness_Total_LogMean(:)             = R_UNDEF
-          if (associated(cospOUT%modis_Optical_Thickness_Water_LogMean))                    &
-               cospOUT%modis_Optical_Thickness_Water_LogMean(:)             = R_UNDEF
-          if (associated(cospOUT%modis_Optical_Thickness_Ice_LogMean))                      &
-               cospOUT%modis_Optical_Thickness_Ice_LogMean(:)               = R_UNDEF
-          if (associated(cospOUT%modis_Cloud_Particle_Size_Water_Mean))                     &
-               cospOUT%modis_Cloud_Particle_Size_Water_Mean(:)              = R_UNDEF
-          if (associated(cospOUT%modis_Cloud_Particle_Size_Ice_Mean))                       &
-               cospOUT%modis_Cloud_Particle_Size_Ice_Mean(:)                = R_UNDEF
-          if (associated(cospOUT%modis_Cloud_Top_Pressure_Total_Mean))                      &
-               cospOUT%modis_Cloud_Top_Pressure_Total_Mean(:)               = R_UNDEF
-          if (associated(cospOUT%modis_Liquid_Water_Path_Mean))                             &
-               cospOUT%modis_Liquid_Water_Path_Mean(:)                      = R_UNDEF
-          if (associated(cospOUT%modis_Ice_Water_Path_Mean))                                &
-               cospOUT%modis_Ice_Water_Path_Mean(:)                         = R_UNDEF
-          if (associated(cospOUT%modis_Optical_Thickness_vs_Cloud_Top_Pressure))            &
-               cospOUT%modis_Optical_Thickness_vs_Cloud_Top_Pressure(:,:,:) = R_UNDEF
-          if (associated(cospOUT%modis_Optical_Thickness_vs_ReffICE))                       &
-               cospOUT%modis_Optical_Thickness_vs_ReffICE(:,:,:)            = R_UNDEF
-          if (associated(cospOUT%modis_Optical_Thickness_vs_ReffLIQ))                       &
-               cospOUT%modis_Optical_Thickness_vs_ReffLIQ(:,:,:)            = R_UNDEF
-       endif
-       if (any(cospIN%ss_alb .lt. 0 .OR. cospIN%ss_alb .gt. 1)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable: cospIN%ss_alb contains values out of range'
-          Lmodis_subcolumn = .false.
-          Lmodis_column    = .false.
-          if (associated(cospOUT%modis_Cloud_Fraction_Total_Mean))                          &
-               cospOUT%modis_Cloud_Fraction_Total_Mean(:)                   = R_UNDEF
-          if (associated(cospOUT%modis_Cloud_Fraction_Water_Mean))                          &
-               cospOUT%modis_Cloud_Fraction_Water_Mean(:)                   = R_UNDEF
-          if (associated(cospOUT%modis_Cloud_Fraction_Ice_Mean))                            &
-               cospOUT%modis_Cloud_Fraction_Ice_Mean(:)                     = R_UNDEF
-          if (associated(cospOUT%modis_Cloud_Fraction_High_Mean))                           &
-               cospOUT%modis_Cloud_Fraction_High_Mean(:)                    = R_UNDEF
-          if (associated(cospOUT%modis_Cloud_Fraction_Mid_Mean))                            &
-               cospOUT%modis_Cloud_Fraction_Mid_Mean(:)                     = R_UNDEF
-          if (associated(cospOUT%modis_Cloud_Fraction_Low_Mean))                            &
-               cospOUT%modis_Cloud_Fraction_Low_Mean(:)                     = R_UNDEF
-          if (associated(cospOUT%modis_Optical_Thickness_Total_Mean))                       &
-               cospOUT%modis_Optical_Thickness_Total_Mean(:)                = R_UNDEF
-          if (associated(cospOUT%modis_Optical_Thickness_Water_Mean))                       &
-               cospOUT%modis_Optical_Thickness_Water_Mean(:)                = R_UNDEF
-          if (associated(cospOUT%modis_Optical_Thickness_Ice_Mean))                         &
-               cospOUT%modis_Optical_Thickness_Ice_Mean(:)                  = R_UNDEF
-          if (associated(cospOUT%modis_Optical_Thickness_Total_LogMean))                    &
-               cospOUT%modis_Optical_Thickness_Total_LogMean(:)             = R_UNDEF
-          if (associated(cospOUT%modis_Optical_Thickness_Water_LogMean))                    &
-               cospOUT%modis_Optical_Thickness_Water_LogMean(:)             = R_UNDEF
-          if (associated(cospOUT%modis_Optical_Thickness_Ice_LogMean))                      &
-               cospOUT%modis_Optical_Thickness_Ice_LogMean(:)               = R_UNDEF
-          if (associated(cospOUT%modis_Cloud_Particle_Size_Water_Mean))                     &
-               cospOUT%modis_Cloud_Particle_Size_Water_Mean(:)              = R_UNDEF
-          if (associated(cospOUT%modis_Cloud_Particle_Size_Ice_Mean))                       &
-               cospOUT%modis_Cloud_Particle_Size_Ice_Mean(:)                = R_UNDEF
-          if (associated(cospOUT%modis_Cloud_Top_Pressure_Total_Mean))                      &
-               cospOUT%modis_Cloud_Top_Pressure_Total_Mean(:)               = R_UNDEF
-          if (associated(cospOUT%modis_Liquid_Water_Path_Mean))                             &
-               cospOUT%modis_Liquid_Water_Path_Mean(:)                      = R_UNDEF
-          if (associated(cospOUT%modis_Ice_Water_Path_Mean))                                &
-               cospOUT%modis_Ice_Water_Path_Mean(:)                         = R_UNDEF
-          if (associated(cospOUT%modis_Optical_Thickness_vs_Cloud_Top_Pressure))            &
-               cospOUT%modis_Optical_Thickness_vs_Cloud_Top_Pressure(:,:,:) = R_UNDEF
-          if (associated(cospOUT%modis_Optical_Thickness_vs_ReffICE))                       &
-               cospOUT%modis_Optical_Thickness_vs_ReffICE(:,:,:)            = R_UNDEF
-          if (associated(cospOUT%modis_Optical_Thickness_vs_ReffLIQ))                       &
-               cospOUT%modis_Optical_Thickness_vs_ReffLIQ(:,:,:)            = R_UNDEF
-       endif
-    endif
-    if (any([Latlid_subcolumn,Latlid_column])) then
-       if (any(cospIN%betatot_atlid .lt. 0)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable: cospIN%betatot_atlid contains values out of range'
-          Latlid_subcolumn = .false.
-          Latlid_column    = .false.
-          if (associated(cospOUT%atlid_cfad_sr))       cospOUT%atlid_cfad_sr(:,:,:)  = R_UNDEF
-          if (associated(cospOUT%atlid_lidarcld))      cospOUT%atlid_lidarcld(:,:)   = R_UNDEF
-          if (associated(cospOUT%atlid_cldlayer))      cospOUT%atlid_cldlayer(:,:)   = R_UNDEF
-          if (associated(cospOUT%atlid_beta_tot))      cospOUT%atlid_beta_tot(:,:,:) = R_UNDEF
-          if (associated(cospOUT%atlid_beta_mol))      cospOUT%atlid_beta_mol(:,:)   = R_UNDEF
-       endif
-       if (any(cospIN%beta_mol_atlid .lt. 0)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable: cospIN%beta_mol_atlid contains values out of range'
-          Latlid_subcolumn = .false.
-          Latlid_column    = .false.
-          if (associated(cospOUT%atlid_cfad_sr))       cospOUT%atlid_cfad_sr(:,:,:)  = R_UNDEF
-          if (associated(cospOUT%atlid_lidarcld))      cospOUT%atlid_lidarcld(:,:)   = R_UNDEF
-          if (associated(cospOUT%atlid_cldlayer))      cospOUT%atlid_cldlayer(:,:)   = R_UNDEF
-          if (associated(cospOUT%atlid_beta_tot))      cospOUT%atlid_beta_tot(:,:,:) = R_UNDEF
-          if (associated(cospOUT%atlid_beta_mol))      cospOUT%atlid_beta_mol(:,:)   = R_UNDEF
-       endif
-       if (any(cospIN%tautot_atlid .lt. 0)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable: cospIN%tautot_atlid contains values out of range'
-          Latlid_subcolumn = .false.
-          Latlid_column    = .false.
-          if (associated(cospOUT%atlid_cfad_sr))       cospOUT%atlid_cfad_sr(:,:,:)  = R_UNDEF
-          if (associated(cospOUT%atlid_lidarcld))      cospOUT%atlid_lidarcld(:,:)   = R_UNDEF
-          if (associated(cospOUT%atlid_cldlayer))      cospOUT%atlid_cldlayer(:,:)   = R_UNDEF
-          if (associated(cospOUT%atlid_beta_tot))      cospOUT%atlid_beta_tot(:,:,:) = R_UNDEF
-          if (associated(cospOUT%atlid_beta_mol))      cospOUT%atlid_beta_mol(:,:)   = R_UNDEF
-       endif
-       if (any(cospIN%tau_mol_atlid .lt. 0)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable: cospIN%tau_mol_atlid contains values out of range'
-          Latlid_subcolumn = .false.
-          Latlid_column    = .false.
-          if (associated(cospOUT%atlid_cfad_sr))       cospOUT%atlid_cfad_sr(:,:,:)  = R_UNDEF
-          if (associated(cospOUT%atlid_lidarcld))      cospOUT%atlid_lidarcld(:,:)   = R_UNDEF
-          if (associated(cospOUT%atlid_cldlayer))      cospOUT%atlid_cldlayer(:,:)   = R_UNDEF
-          if (associated(cospOUT%atlid_beta_tot))      cospOUT%atlid_beta_tot(:,:,:) = R_UNDEF
-          if (associated(cospOUT%atlid_beta_mol))      cospOUT%atlid_beta_mol(:,:)   = R_UNDEF
-       endif
-    endif
-    
-    if (any([LgrLidar532_subcolumn,LgrLidar532_column])) then
-       if (any(cospIN%betatot_grLidar532 .lt. 0)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable: cospIN%betatot_grLidar532 contains values out of range'
-          LgrLidar532_subcolumn = .false.
-          LgrLidar532_column    = .false.
-          if (associated(cospOUT%grLidar532_cfad_sr))       cospOUT%grLidar532_cfad_sr(:,:,:)  = R_UNDEF
-          if (associated(cospOUT%grLidar532_lidarcld))      cospOUT%grLidar532_lidarcld(:,:)   = R_UNDEF
-          if (associated(cospOUT%grLidar532_cldlayer))      cospOUT%grLidar532_cldlayer(:,:)   = R_UNDEF
-          if (associated(cospOUT%grLidar532_beta_tot))      cospOUT%grLidar532_beta_tot(:,:,:) = R_UNDEF
-          if (associated(cospOUT%grLidar532_beta_mol))      cospOUT%grLidar532_beta_mol(:,:)   = R_UNDEF
-       endif
-       if (any(cospIN%beta_mol_grLidar532 .lt. 0)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable: cospIN%beta_mol_grLidar532 contains values out of range'
-          LgrLidar532_subcolumn = .false.
-          LgrLidar532_column    = .false.
-          if (associated(cospOUT%grLidar532_cfad_sr))       cospOUT%grLidar532_cfad_sr(:,:,:)  = R_UNDEF
-          if (associated(cospOUT%grLidar532_lidarcld))      cospOUT%grLidar532_lidarcld(:,:)   = R_UNDEF
-          if (associated(cospOUT%grLidar532_cldlayer))      cospOUT%grLidar532_cldlayer(:,:)   = R_UNDEF
-          if (associated(cospOUT%grLidar532_beta_tot))      cospOUT%grLidar532_beta_tot(:,:,:) = R_UNDEF
-          if (associated(cospOUT%grLidar532_beta_mol))      cospOUT%grLidar532_beta_mol(:,:)   = R_UNDEF
-       endif
-       if (any(cospIN%tautot_grLidar532 .lt. 0)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable: cospIN%tautot_grLidar532 contains values out of range'
-          LgrLidar532_subcolumn = .false.
-          LgrLidar532_column    = .false.
-          if (associated(cospOUT%grLidar532_cfad_sr))       cospOUT%grLidar532_cfad_sr(:,:,:)  = R_UNDEF
-          if (associated(cospOUT%grLidar532_lidarcld))      cospOUT%grLidar532_lidarcld(:,:)   = R_UNDEF
-          if (associated(cospOUT%grLidar532_cldlayer))      cospOUT%grLidar532_cldlayer(:,:)   = R_UNDEF
-          if (associated(cospOUT%grLidar532_beta_tot))      cospOUT%grLidar532_beta_tot(:,:,:) = R_UNDEF
-          if (associated(cospOUT%grLidar532_beta_mol))      cospOUT%grLidar532_beta_mol(:,:)   = R_UNDEF
-       endif
-       if (any(cospIN%tau_mol_grLidar532 .lt. 0)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable: cospIN%tau_mol_grLidar532 contains values out of range'
-          LgrLidar532_subcolumn = .false.
-          LgrLidar532_column    = .false.
-          if (associated(cospOUT%grLidar532_cfad_sr))       cospOUT%grLidar532_cfad_sr(:,:,:)  = R_UNDEF
-          if (associated(cospOUT%grLidar532_lidarcld))      cospOUT%grLidar532_lidarcld(:,:)   = R_UNDEF
-          if (associated(cospOUT%grLidar532_cldlayer))      cospOUT%grLidar532_cldlayer(:,:)   = R_UNDEF
-          if (associated(cospOUT%grLidar532_beta_tot))      cospOUT%grLidar532_beta_tot(:,:,:) = R_UNDEF
-          if (associated(cospOUT%grLidar532_beta_mol))      cospOUT%grLidar532_beta_mol(:,:)   = R_UNDEF
-       endif
-    endif
-
-    if (any([Lcalipso_subcolumn,Lcalipso_column])) then
-       if (any(cospIN%betatot_calipso .lt. 0)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable: cospIN%betatot_calipso contains values out of range'
-          Lcalipso_subcolumn = .false.
-          Lcalipso_column    = .false.
-          if (associated(cospOUT%calipso_cfad_sr))       cospOUT%calipso_cfad_sr(:,:,:)       = R_UNDEF
-          if (associated(cospOUT%calipso_lidarcld))      cospOUT%calipso_lidarcld(:,:)        = R_UNDEF
-          if (associated(cospOUT%calipso_lidarcldphase)) cospOUT%calipso_lidarcldphase(:,:,:) = R_UNDEF
-          if (associated(cospOUT%calipso_cldlayer))      cospOUT%calipso_cldlayer(:,:)        = R_UNDEF
-          if (associated(cospOUT%calipso_cldlayerphase)) cospOUT%calipso_cldlayerphase(:,:,:) = R_UNDEF
-          if (associated(cospOUT%calipso_lidarcldtmp))   cospOUT%calipso_lidarcldtmp(:,:,:)   = R_UNDEF
-          if (associated(cospOUT%calipso_srbval))        cospOUT%calipso_srbval(:)            = R_UNDEF
-          if (associated(cospOUT%calipso_lidarcldtype))  cospOUT%calipso_lidarcldtype(:,:,:)  = R_UNDEF 
-          if (associated(cospOUT%calipso_cldtype))       cospOUT%calipso_cldtype(:,:)         = R_UNDEF 
-          if (associated(cospOUT%calipso_cldtypetemp))   cospOUT%calipso_cldtypetemp(:,:)     = R_UNDEF 
-          if (associated(cospOUT%calipso_cldtypemeanz))  cospOUT%calipso_cldtypemeanz(:,:)    = R_UNDEF 
-          if (associated(cospOUT%calipso_cldtypemeanzse)) cospOUT%calipso_cldtypemeanzse(:,:) = R_UNDEF 
-          if (associated(cospOUT%calipso_cldthinemis))   cospOUT%calipso_cldthinemis(:)       = R_UNDEF
-       endif
-       if (any(cospIN%betatot_liq_calipso .lt. 0)) then
-          nError=nError+1
-          errorMessage(nError) = ('ERROR: COSP input variable: cospIN%betatot_liq_calipso contains values out of range')
-          Lcalipso_subcolumn = .false.
-          Lcalipso_column    = .false.
-          if (associated(cospOUT%calipso_cfad_sr))       cospOUT%calipso_cfad_sr(:,:,:)       = R_UNDEF
-          if (associated(cospOUT%calipso_lidarcld))      cospOUT%calipso_lidarcld(:,:)        = R_UNDEF
-          if (associated(cospOUT%calipso_lidarcldphase)) cospOUT%calipso_lidarcldphase(:,:,:) = R_UNDEF
-          if (associated(cospOUT%calipso_cldlayer))      cospOUT%calipso_cldlayer(:,:)        = R_UNDEF
-          if (associated(cospOUT%calipso_cldlayerphase)) cospOUT%calipso_cldlayerphase(:,:,:) = R_UNDEF
-          if (associated(cospOUT%calipso_lidarcldtmp))   cospOUT%calipso_lidarcldtmp(:,:,:)   = R_UNDEF
-          if (associated(cospOUT%calipso_srbval))        cospOUT%calipso_srbval(:)            = R_UNDEF
-          if (associated(cospOUT%calipso_lidarcldtype))  cospOUT%calipso_lidarcldtype(:,:,:)  = R_UNDEF
-          if (associated(cospOUT%calipso_cldtype))       cospOUT%calipso_cldtype(:,:)         = R_UNDEF
-          if (associated(cospOUT%calipso_cldtypetemp))   cospOUT%calipso_cldtypetemp(:,:)     = R_UNDEF 
-          if (associated(cospOUT%calipso_cldtypemeanz))  cospOUT%calipso_cldtypemeanz(:,:)    = R_UNDEF 
-          if (associated(cospOUT%calipso_cldtypemeanzse)) cospOUT%calipso_cldtypemeanzse(:,:) = R_UNDEF
-          if (associated(cospOUT%calipso_cldthinemis))   cospOUT%calipso_cldthinemis(:)       = R_UNDEF
-       endif
-       if (any(cospIN%betatot_ice_calipso .lt. 0)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable: cospIN%betatot_ice_calipso contains values out of range'
-          Lcalipso_subcolumn = .false.
-          Lcalipso_column    = .false.
-          if (associated(cospOUT%calipso_cfad_sr))       cospOUT%calipso_cfad_sr(:,:,:)       = R_UNDEF
-          if (associated(cospOUT%calipso_lidarcld))      cospOUT%calipso_lidarcld(:,:)        = R_UNDEF
-          if (associated(cospOUT%calipso_lidarcldphase)) cospOUT%calipso_lidarcldphase(:,:,:) = R_UNDEF
-          if (associated(cospOUT%calipso_cldlayer))      cospOUT%calipso_cldlayer(:,:)        = R_UNDEF
-          if (associated(cospOUT%calipso_cldlayerphase)) cospOUT%calipso_cldlayerphase(:,:,:) = R_UNDEF
-          if (associated(cospOUT%calipso_lidarcldtmp))   cospOUT%calipso_lidarcldtmp(:,:,:)   = R_UNDEF
-          if (associated(cospOUT%calipso_srbval))        cospOUT%calipso_srbval(:)            = R_UNDEF
-          if (associated(cospOUT%calipso_lidarcldtype))  cospOUT%calipso_lidarcldtype(:,:,:)  = R_UNDEF
-          if (associated(cospOUT%calipso_cldtype))       cospOUT%calipso_cldtype(:,:)         = R_UNDEF 
-          if (associated(cospOUT%calipso_cldtypetemp))   cospOUT%calipso_cldtypetemp(:,:)     = R_UNDEF 
-          if (associated(cospOUT%calipso_cldtypemeanz))  cospOUT%calipso_cldtypemeanz(:,:)    = R_UNDEF 
-          if (associated(cospOUT%calipso_cldtypemeanzse)) cospOUT%calipso_cldtypemeanzse(:,:) = R_UNDEF
-          if (associated(cospOUT%calipso_cldthinemis))   cospOUT%calipso_cldthinemis(:)       = R_UNDEF
-       endif
-       if (any(cospIN%tautot_calipso .lt. 0)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable: cospIN%tautot_calipso contains values out of range'
-          Lcalipso_subcolumn = .false.
-          Lcalipso_column    = .false.
-          if (associated(cospOUT%calipso_cfad_sr))       cospOUT%calipso_cfad_sr(:,:,:)       = R_UNDEF
-          if (associated(cospOUT%calipso_lidarcld))      cospOUT%calipso_lidarcld(:,:)        = R_UNDEF
-          if (associated(cospOUT%calipso_lidarcldphase)) cospOUT%calipso_lidarcldphase(:,:,:) = R_UNDEF
-          if (associated(cospOUT%calipso_cldlayer))      cospOUT%calipso_cldlayer(:,:)        = R_UNDEF
-          if (associated(cospOUT%calipso_cldlayerphase)) cospOUT%calipso_cldlayerphase(:,:,:) = R_UNDEF
-          if (associated(cospOUT%calipso_lidarcldtmp))   cospOUT%calipso_lidarcldtmp(:,:,:)   = R_UNDEF
-          if (associated(cospOUT%calipso_srbval))        cospOUT%calipso_srbval(:)            = R_UNDEF
-          if (associated(cospOUT%calipso_lidarcldtype))  cospOUT%calipso_lidarcldtype(:,:,:)  = R_UNDEF
-          if (associated(cospOUT%calipso_cldtype))       cospOUT%calipso_cldtype(:,:)         = R_UNDEF 
-          if (associated(cospOUT%calipso_cldtypetemp))   cospOUT%calipso_cldtypetemp(:,:)     = R_UNDEF 
-          if (associated(cospOUT%calipso_cldtypemeanz))  cospOUT%calipso_cldtypemeanz(:,:)    = R_UNDEF 
-          if (associated(cospOUT%calipso_cldtypemeanzse)) cospOUT%calipso_cldtypemeanzse(:,:) = R_UNDEF
-          if (associated(cospOUT%calipso_cldthinemis))   cospOUT%calipso_cldthinemis(:)       = R_UNDEF
-       endif
-       if (any(cospIN%tautot_liq_calipso .lt. 0)) then
-          nError=nError+1
-          errorMessage(nError) = ('ERROR: COSP input variable: cospIN%tautot_liq_calipso contains values out of range')
-          Lcalipso_subcolumn = .false.
-          Lcalipso_column    = .false.
-          if (associated(cospOUT%calipso_cfad_sr))       cospOUT%calipso_cfad_sr(:,:,:)       = R_UNDEF
-          if (associated(cospOUT%calipso_lidarcld))      cospOUT%calipso_lidarcld(:,:)        = R_UNDEF
-          if (associated(cospOUT%calipso_lidarcldphase)) cospOUT%calipso_lidarcldphase(:,:,:) = R_UNDEF
-          if (associated(cospOUT%calipso_cldlayer))      cospOUT%calipso_cldlayer(:,:)        = R_UNDEF
-          if (associated(cospOUT%calipso_cldlayerphase)) cospOUT%calipso_cldlayerphase(:,:,:) = R_UNDEF
-          if (associated(cospOUT%calipso_lidarcldtmp))   cospOUT%calipso_lidarcldtmp(:,:,:)   = R_UNDEF
-          if (associated(cospOUT%calipso_srbval))        cospOUT%calipso_srbval(:)            = R_UNDEF
-          if (associated(cospOUT%calipso_lidarcldtype))  cospOUT%calipso_lidarcldtype(:,:,:)  = R_UNDEF
-          if (associated(cospOUT%calipso_cldtype))       cospOUT%calipso_cldtype(:,:)         = R_UNDEF
-          if (associated(cospOUT%calipso_cldtypetemp))   cospOUT%calipso_cldtypetemp(:,:)     = R_UNDEF
-          if (associated(cospOUT%calipso_cldtypemeanz))  cospOUT%calipso_cldtypemeanz(:,:)    = R_UNDEF
-          if (associated(cospOUT%calipso_cldtypemeanzse)) cospOUT%calipso_cldtypemeanzse(:,:) = R_UNDEF
-          if (associated(cospOUT%calipso_cldthinemis))   cospOUT%calipso_cldthinemis(:)       = R_UNDEF
-       endif
-       if (any(cospIN%tautot_ice_calipso .lt. 0)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable: cospIN%tautot_ice_calipso contains values out of range'
-          Lcalipso_subcolumn = .false.
-          Lcalipso_column    = .false.
-          if (associated(cospOUT%calipso_cfad_sr))       cospOUT%calipso_cfad_sr(:,:,:)       = R_UNDEF
-          if (associated(cospOUT%calipso_lidarcld))      cospOUT%calipso_lidarcld(:,:)        = R_UNDEF
-          if (associated(cospOUT%calipso_lidarcldphase)) cospOUT%calipso_lidarcldphase(:,:,:) = R_UNDEF
-          if (associated(cospOUT%calipso_cldlayer))      cospOUT%calipso_cldlayer(:,:)        = R_UNDEF
-          if (associated(cospOUT%calipso_cldlayerphase)) cospOUT%calipso_cldlayerphase(:,:,:) = R_UNDEF
-          if (associated(cospOUT%calipso_lidarcldtmp))   cospOUT%calipso_lidarcldtmp(:,:,:)   = R_UNDEF
-          if (associated(cospOUT%calipso_srbval))        cospOUT%calipso_srbval(:)            = R_UNDEF
-          if (associated(cospOUT%calipso_lidarcldtype))  cospOUT%calipso_lidarcldtype(:,:,:)  = R_UNDEF
-          if (associated(cospOUT%calipso_cldtype))       cospOUT%calipso_cldtype(:,:)         = R_UNDEF
-          if (associated(cospOUT%calipso_cldtypetemp))   cospOUT%calipso_cldtypetemp(:,:)     = R_UNDEF
-          if (associated(cospOUT%calipso_cldtypemeanz))  cospOUT%calipso_cldtypemeanz(:,:)    = R_UNDEF
-          if (associated(cospOUT%calipso_cldtypemeanzse)) cospOUT%calipso_cldtypemeanzse(:,:) = R_UNDEF
-          if (associated(cospOUT%calipso_cldthinemis))   cospOUT%calipso_cldthinemis(:)       = R_UNDEF
-       endif
-       if (any(cospIN%tau_mol_calipso .lt. 0)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable: cospIN%tau_mol_calipso contains values out of range'
-          Lcalipso_subcolumn = .false.
-          Lcalipso_column    = .false.
-          if (associated(cospOUT%calipso_cfad_sr))       cospOUT%calipso_cfad_sr(:,:,:)       = R_UNDEF
-          if (associated(cospOUT%calipso_lidarcld))      cospOUT%calipso_lidarcld(:,:)        = R_UNDEF
-          if (associated(cospOUT%calipso_lidarcldphase)) cospOUT%calipso_lidarcldphase(:,:,:) = R_UNDEF
-          if (associated(cospOUT%calipso_cldlayer))      cospOUT%calipso_cldlayer(:,:)        = R_UNDEF
-          if (associated(cospOUT%calipso_cldlayerphase)) cospOUT%calipso_cldlayerphase(:,:,:) = R_UNDEF
-          if (associated(cospOUT%calipso_lidarcldtmp))   cospOUT%calipso_lidarcldtmp(:,:,:)   = R_UNDEF
-          if (associated(cospOUT%calipso_srbval))        cospOUT%calipso_srbval(:)            = R_UNDEF
-          if (associated(cospOUT%calipso_lidarcldtype))  cospOUT%calipso_lidarcldtype(:,:,:)  = R_UNDEF 
-          if (associated(cospOUT%calipso_cldtype))       cospOUT%calipso_cldtype(:,:)         = R_UNDEF 
-          if (associated(cospOUT%calipso_cldtypetemp))   cospOUT%calipso_cldtypetemp(:,:)     = R_UNDEF
-          if (associated(cospOUT%calipso_cldtypemeanz))  cospOUT%calipso_cldtypemeanz(:,:)    = R_UNDEF
-          if (associated(cospOUT%calipso_cldtypemeanzse)) cospOUT%calipso_cldtypemeanzse(:,:) = R_UNDEF
-          if (associated(cospOUT%calipso_cldthinemis))   cospOUT%calipso_cldthinemis(:)       = R_UNDEF
-       endif
-    endif
-    if (any([Lcalipso_subcolumn,Lcalipso_column,Lcloudsat_column,Lradar_lidar_tcc,       &
-        Llidar_only_freq_cloud, Lcloudsat_tcc, Lcloudsat_tcc2])) then
-       if (any(cospIN%beta_mol_calipso .lt. 0)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable: cospIN%beta_mol_calipso contains values out of range'
-          Lcalipso_subcolumn = .false.
-          Lcalipso_column    = .false.
-          Lcloudsat_column   = .false.
-          Lradar_lidar_tcc   = .false.
-          Llidar_only_freq_cloud = .false.
-          Lcloudsat_tcc      = .false.
-          Lcloudsat_tcc2     = .false.
-          if (associated(cospOUT%calipso_cfad_sr))        cospOUT%calipso_cfad_sr(:,:,:)       = R_UNDEF
-          if (associated(cospOUT%calipso_lidarcld))       cospOUT%calipso_lidarcld(:,:)        = R_UNDEF
-          if (associated(cospOUT%calipso_lidarcldphase))  cospOUT%calipso_lidarcldphase(:,:,:) = R_UNDEF
-          if (associated(cospOUT%calipso_cldlayer))       cospOUT%calipso_cldlayer(:,:)        = R_UNDEF
-          if (associated(cospOUT%calipso_cldlayerphase))  cospOUT%calipso_cldlayerphase(:,:,:) = R_UNDEF
-          if (associated(cospOUT%calipso_lidarcldtmp))    cospOUT%calipso_lidarcldtmp(:,:,:)   = R_UNDEF
-          if (associated(cospOUT%calipso_srbval))         cospOUT%calipso_srbval(:)            = R_UNDEF
-          if (associated(cospOUT%cloudsat_cfad_ze))       cospOUT%cloudsat_cfad_ze(:,:,:)      = R_UNDEF
-          if (associated(cospOUT%lidar_only_freq_cloud))  cospOUT%lidar_only_freq_cloud(:,:)   = R_UNDEF
-          if (associated(cospOUT%radar_lidar_tcc))        cospOUT%radar_lidar_tcc(:)           = R_UNDEF
-          if (associated(cospOUT%cloudsat_tcc))           cospOUT%cloudsat_tcc(:)              = R_UNDEF
-          if (associated(cospOUT%cloudsat_tcc2))          cospOUT%cloudsat_tcc2(:)             = R_UNDEF
-          if (associated(cospOUT%calipso_lidarcldtype))   cospOUT%calipso_lidarcldtype(:,:,:)  = R_UNDEF
-          if (associated(cospOUT%calipso_cldtype))        cospOUT%calipso_cldtype(:,:)         = R_UNDEF
-          if (associated(cospOUT%calipso_cldtypetemp))    cospOUT%calipso_cldtypetemp(:,:)     = R_UNDEF
-          if (associated(cospOUT%calipso_cldtypemeanz))   cospOUT%calipso_cldtypemeanz(:,:)    = R_UNDEF
-          if (associated(cospOUT%calipso_cldtypemeanzse)) cospOUT%calipso_cldtypemeanzse(:,:)  = R_UNDEF
-          if (associated(cospOUT%calipso_cldthinemis))    cospOUT%calipso_cldthinemis(:)       = R_UNDEF
-       endif
-    endif
-    if (any([Lparasol_subcolumn,Lparasol_column])) then
-       if (any(cospIN%tautot_S_liq .lt. 0)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable: cospIN%tautot_S_liq contains values out of range'
-          Lparasol_subcolumn = .false.
-          Lparasol_column    = .false.
-          if (associated(cospOUT%parasolPix_refl))  cospOUT%parasolPix_refl(:,:,:) = R_UNDEF
-          if (associated(cospOUT%parasolGrid_refl)) cospOUT%parasolGrid_refl(:,:)  = R_UNDEF
-       endif
-       if (any(cospIN%tautot_S_ice .lt. 0)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable: cospIN%tautot_S_ice contains values out of range'
-          Lparasol_subcolumn = .false.
-          Lparasol_column    = .false.
-          if (associated(cospOUT%parasolPix_refl))  cospOUT%parasolPix_refl(:,:,:) = R_UNDEF
-          if (associated(cospOUT%parasolGrid_refl)) cospOUT%parasolGrid_refl(:,:)  = R_UNDEF
-       endif
-    endif
-    if (any([Lcloudsat_subcolumn,Lcloudsat_column,Lradar_lidar_tcc,Llidar_only_freq_cloud, &
-        Lcloudsat_tcc, Lcloudsat_tcc2])) then
-       if (any(cospIN%z_vol_cloudsat .lt. 0)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable: cospIN%z_vol_cloudsat contains values out of range'
-          Lcloudsat_subcolumn = .false.
-          Lcloudsat_column    = .false.
-          Lradar_lidar_tcc    = .false.
-          Llidar_only_freq_cloud = .false.
-          Lcloudsat_tcc       = .false.
-          Lcloudsat_tcc2      = .false.
-          if (associated(cospOUT%cloudsat_cfad_ze))          cospOUT%cloudsat_cfad_ze(:,:,:)        = R_UNDEF
-          if (associated(cospOUT%cloudsat_Ze_tot))           cospOUT%cloudsat_Ze_tot(:,:,:)         = R_UNDEF
-          if (associated(cospOUT%lidar_only_freq_cloud))     cospOUT%lidar_only_freq_cloud(:,:)     = R_UNDEF
-          if (associated(cospOUT%radar_lidar_tcc))           cospOUT%radar_lidar_tcc(:)             = R_UNDEF
-          if (associated(cospOUT%cloudsat_tcc)) cospOUT%cloudsat_tcc(:) = R_UNDEF
-          if (associated(cospOUT%cloudsat_tcc2)) cospOUT%cloudsat_tcc2(:) = R_UNDEF
-       endif
-       if (any(cospIN%kr_vol_cloudsat .lt. 0)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable: cospIN%kr_vol_cloudsat contains values out of range'
-          Lcloudsat_subcolumn = .false.
-          Lcloudsat_column    = .false.
-          Lradar_lidar_tcc    = .false.
-          Llidar_only_freq_cloud = .false.
-          Lcloudsat_tcc       = .false.
-          Lcloudsat_tcc2      = .false.
-          if (associated(cospOUT%cloudsat_cfad_ze))          cospOUT%cloudsat_cfad_ze(:,:,:)        = R_UNDEF
-          if (associated(cospOUT%cloudsat_Ze_tot))           cospOUT%cloudsat_Ze_tot(:,:,:)         = R_UNDEF
-          if (associated(cospOUT%lidar_only_freq_cloud))     cospOUT%lidar_only_freq_cloud(:,:)     = R_UNDEF
-          if (associated(cospOUT%radar_lidar_tcc))           cospOUT%radar_lidar_tcc(:)             = R_UNDEF
-          if (associated(cospOUT%cloudsat_tcc)) cospOUT%cloudsat_tcc(:) = R_UNDEF
-          if (associated(cospOUT%cloudsat_tcc2)) cospOUT%cloudsat_tcc2(:) = R_UNDEF
-       endif
-       if (any(cospIN%g_vol_cloudsat .lt. 0)) then
-          nError=nError+1
-          errorMessage(nError) = 'ERROR: COSP input variable: cospIN%g_vol_cloudsat contains values out of range'
-          Lcloudsat_subcolumn = .false.
-          Lcloudsat_column    = .false.
-          Lradar_lidar_tcc    = .false.
-          Llidar_only_freq_cloud = .false.
-          Lcloudsat_tcc       = .false.
-          Lcloudsat_tcc2      = .false.          
-          if (associated(cospOUT%cloudsat_cfad_ze))          cospOUT%cloudsat_cfad_ze(:,:,:)        = R_UNDEF
-          if (associated(cospOUT%cloudsat_Ze_tot))           cospOUT%cloudsat_Ze_tot(:,:,:)         = R_UNDEF
-          if (associated(cospOUT%lidar_only_freq_cloud))     cospOUT%lidar_only_freq_cloud(:,:)     = R_UNDEF
-          if (associated(cospOUT%radar_lidar_tcc))           cospOUT%radar_lidar_tcc(:)             = R_UNDEF
-          if (associated(cospOUT%cloudsat_tcc)) cospOUT%cloudsat_tcc(:) = R_UNDEF
-          if (associated(cospOUT%cloudsat_tcc2)) cospOUT%cloudsat_tcc2(:) = R_UNDEF          
-       endif
-    endif
-    !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-    ! Part 2: Check input fields array size for consistency. This needs to be done for each
-    !         simulator
-    !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-    ! ISCCP
-    if (Lisccp_subcolumn .or. Lisccp_column) then
-       if (size(cospIN%frac_out,1)  .ne. cospIN%Npoints .OR. &
-           size(cospIN%tau_067,1)   .ne. cospIN%Npoints .OR. &
-           size(cospIN%emiss_11,1)  .ne. cospIN%Npoints .OR. &
-           size(cospgridIN%skt)     .ne. cospIN%Npoints .OR. &
-           size(cospgridIN%qv,1)    .ne. cospIN%Npoints .OR. &
-           size(cospgridIN%at,1)    .ne. cospIN%Npoints .OR. &
-           size(cospgridIN%phalf,1) .ne. cospIN%Npoints .OR. &
-           size(cospgridIN%sunlit)  .ne. cospIN%Npoints .OR. &
-           size(cospgridIN%pfull,1) .ne. cospIN%Npoints) then
-          Lisccp_subcolumn = .false.
-          Lisccp_column    = .false.
-          nError=nError+1
-          errorMessage(nError) = 'ERROR(isccp_simulator): The number of points in the input fields are inconsistent'
-       endif
-       if (size(cospIN%frac_out,2) .ne. cospIN%Ncolumns .OR. &
-           size(cospIN%tau_067,2)  .ne. cospIN%Ncolumns .OR. &
-           size(cospIN%emiss_11,2) .ne. cospIN%Ncolumns) then
-          Lisccp_subcolumn = .false.
-          Lisccp_column    = .false.
-          nError=nError+1
-          errorMessage(nError) = 'ERROR(isccp_simulator): The number of sub-columns in the input fields are inconsistent'
-       endif
-       if (size(cospIN%frac_out,3)  .ne. cospIN%Nlevels .OR. &
-           size(cospIN%tau_067,3)   .ne. cospIN%Nlevels .OR. &
-           size(cospIN%emiss_11,3)  .ne. cospIN%Nlevels .OR. &
-           size(cospgridIN%qv,2)    .ne. cospIN%Nlevels .OR. &
-           size(cospgridIN%at,2)    .ne. cospIN%Nlevels .OR. &
-           size(cospgridIN%pfull,2) .ne. cospIN%Nlevels .OR. &
-           size(cospgridIN%phalf,2) .ne. cospIN%Nlevels+1) then
-          Lisccp_subcolumn = .false.
-          Lisccp_column    = .false.
-          nError=nError+1
-          errorMessage(nError) = 'ERROR(isccp_simulator): The number of levels in the input fields are inconsistent'
-       endif
-    endif
-    
-    ! MISR
-    if (Lmisr_subcolumn .or. Lmisr_column) then
-       if (size(cospIN%tau_067,1)        .ne. cospIN%Npoints .OR. &
-           size(cospgridIN%sunlit)       .ne. cospIN%Npoints .OR. &
-           size(cospgridIN%hgt_matrix,1) .ne. cospIN%Npoints .OR. &
-           size(cospgridIN%at,1)         .ne. cospIN%Npoints) then
-          Lmisr_subcolumn = .false.
-          Lmisr_column    = .false.
-          nError=nError+1
-          errorMessage(nError) = 'ERROR(misr_simulator): The number of points in the input fields are inconsistent'
-       endif
-       if (size(cospIN%tau_067,2) .ne. cospIN%Ncolumns) then
-          Lmisr_subcolumn = .false.
-          Lmisr_column    = .false.
-          nError=nError+1
-          errorMessage(nError) = 'ERROR(misr_simulator): The number of sub-columns in the input fields are inconsistent'
-       endif
-       if (size(cospIN%tau_067,3)        .ne. cospIN%Nlevels .OR. &
-           size(cospgridIN%hgt_matrix,2) .ne. cospIN%Nlevels .OR. &
-           size(cospgridIN%at,2)         .ne. cospIN%Nlevels) then
-          Lmisr_subcolumn = .false.
-          Lmisr_column    = .false.
-          nError=nError+1
-          errorMessage(nError) = 'ERROR(misr_simulator): The number of levels in the input fields are inconsistent'
-       endif
-    endif
-    
-    ! MODIS
-    if (Lmodis_subcolumn .or. Lmodis_column) then
-       if (size(cospIN%fracLiq,1) .ne. cospIN%Npoints .OR. &
-           size(cospIN%tau_067,1) .ne. cospIN%Npoints .OR. &
-           size(cospIN%asym,1)    .ne. cospIN%Npoints .OR. &
-           size(cospIN%ss_alb,1)  .ne. cospIN%Npoints) then
-          Lmodis_subcolumn = .false.
-          Lmodis_column    = .false.
-          nError=nError+1
-          errorMessage(nError) = 'ERROR(modis_simulator): The number of points in the input fields are inconsistent'
-       endif
-       if (size(cospIN%fracLiq,2) .ne. cospIN%Ncolumns .OR. &
-           size(cospIN%tau_067,2) .ne. cospIN%Ncolumns .OR. &
-           size(cospIN%asym,2)    .ne. cospIN%Ncolumns .OR. &
-           size(cospIN%ss_alb,2)  .ne. cospIN%Ncolumns) then
-          Lmodis_subcolumn = .false.
-          Lmodis_column    = .false.
-          nError=nError+1
-          errorMessage(nError) = 'ERROR(modis_simulator): The number of sub-columns in the input fields are inconsistent'
-       endif
-       if (size(cospIN%fracLiq,3) .ne. cospIN%Nlevels .OR. &
-           size(cospIN%tau_067,3) .ne. cospIN%Nlevels .OR. &
-           size(cospIN%asym,3)    .ne. cospIN%Nlevels .OR. &
-           size(cospIN%ss_alb,3)  .ne. cospIN%Nlevels) then
-          Lmodis_subcolumn = .false.
-          Lmodis_column    = .false.
-          nError=nError+1
-          errorMessage(nError) = 'ERROR(modis_simulator): The number of levels in the input fields are inconsistent'
-       endif
-    endif
-    
-    ! CLOUDSAT
-    if (Lcloudsat_subcolumn .or. Lcloudsat_column) then
-       if (size(cospIN%z_vol_cloudsat,1)   .ne. cospIN%Npoints .OR. &
-           size(cospIN%kr_vol_cloudsat,1)  .ne. cospIN%Npoints .OR. &
-           size(cospIN%g_vol_cloudsat,1)   .ne. cospIN%Npoints .OR. &
-           size(cospgridIN%hgt_matrix,1)   .ne. cospIN%Npoints) then
-          Lcloudsat_subcolumn = .false.
-          Lcloudsat_column    = .false.
-          nError=nError+1
-          errorMessage(nError) = 'ERROR(cloudsat_simulator): The number of points in the input fields are inconsistent'
-       endif
-       if (size(cospIN%z_vol_cloudsat,2)  .ne. cospIN%Ncolumns .OR. &
-           size(cospIN%kr_vol_cloudsat,2) .ne. cospIN%Ncolumns .OR. &
-           size(cospIN%g_vol_cloudsat,2)  .ne. cospIN%Ncolumns) then
-          Lcloudsat_subcolumn = .false.
-          Lcloudsat_column    = .false.
-          nError=nError+1
-          errorMessage(nError) = 'ERROR(cloudsat_simulator): The number of sub-columns in the input fields are inconsistent'
-       endif
-       if (size(cospIN%z_vol_cloudsat,3)  .ne. cospIN%Nlevels .OR. &
-           size(cospIN%kr_vol_cloudsat,3) .ne. cospIN%Nlevels .OR. &
-           size(cospIN%g_vol_cloudsat,3)  .ne. cospIN%Nlevels .OR. &
-           size(cospgridIN%hgt_matrix,2)  .ne. cospIN%Nlevels) then
-          Lcloudsat_subcolumn = .false.
-          Lcloudsat_column    = .false.
-          nError=nError+1
-          errorMessage(nError) = 'ERROR(cloudsat_simulator): The number of levels in the input fields are inconsistent'
-       endif
-    endif
-
-    ! GROUND LIDAR @ 532nm
-    if (LgrLidar532_subcolumn .or. LgrLidar532_column) then
-       if (size(cospIN%beta_mol_grLidar532,1)    .ne. cospIN%Npoints .OR. & 
-           size(cospIN%betatot_grLidar532,1)     .ne. cospIN%Npoints .OR. &
-           size(cospIN%tau_mol_grLidar532,1)     .ne. cospIN%Npoints .OR. &
-           size(cospIN%tautot_grLidar532,1)      .ne. cospIN%Npoints) then
-          LgrLidar532_subcolumn = .false.
-          LgrLidar532_column    = .false.
-          nError=nError+1
-          errorMessage(nError) = 'ERROR(grLidar532_simulator): The number of points in the input fields are inconsistent'
-       endif
-       if (size(cospIN%betatot_grLidar532,2)    .ne. cospIN%Ncolumns .OR. & 
-           size(cospIN%tautot_grLidar532,2)     .ne. cospIN%Ncolumns) then 
-          LgrLidar532_subcolumn = .false. 
-          LgrLidar532_column    = .false. 
-          nError=nError+1
-          errorMessage(nError) = 'ERROR(grLidar532_simulator): The number of sub-columns in the input fields are inconsistent'
-       endif
-       if (size(cospIN%beta_mol_grLidar532,2)    .ne. cospIN%Nlevels .OR. &
-           size(cospIN%betatot_grLidar532,3)     .ne. cospIN%Nlevels .OR. &
-           size(cospIN%tau_mol_grLidar532,2)     .ne. cospIN%Nlevels .OR. &
-           size(cospIN%tautot_grLidar532,3)      .ne. cospIN%Nlevels) then
-          LgrLidar532_subcolumn = .false. 
-          LgrLidar532_column    = .false. 
-          nError=nError+1
-          errorMessage(nError) = 'ERROR(grLidar532_simulator): The number of levels in the input fields are inconsistent' 
-       endif
-    endif
-    
-    ! ATLID
-    if (Latlid_subcolumn .or. Latlid_column) then
-       if (size(cospIN%beta_mol_atlid,1)    .ne. cospIN%Npoints .OR. &
-           size(cospIN%betatot_atlid,1)     .ne. cospIN%Npoints .OR. &
-           size(cospIN%tau_mol_atlid,1)     .ne. cospIN%Npoints .OR. & 
-           size(cospIN%tautot_atlid,1)      .ne. cospIN%Npoints) then 
-          Latlid_subcolumn = .false. 
-          Latlid_column    = .false. 
-          nError=nError+1             
-          errorMessage(nError) = 'ERROR(atlid_simulator): The number of points in the input fields are inconsistent'
-       endif
-       if (size(cospIN%betatot_atlid,2)    .ne. cospIN%Ncolumns .OR. &
-           size(cospIN%tautot_atlid,2)     .ne. cospIN%Ncolumns) then 
-          Latlid_subcolumn = .false.
-          Latlid_column    = .false.
-          nError=nError+1              
-          errorMessage(nError) = 'ERROR(atlid_simulator): The number of sub-columns in the input fields are inconsistent'
-       endif
-       if (size(cospIN%beta_mol_atlid,2)    .ne. cospIN%Nlevels .OR. &
-           size(cospIN%betatot_atlid,3)     .ne. cospIN%Nlevels .OR. & 
-           size(cospIN%tau_mol_atlid,2)     .ne. cospIN%Nlevels .OR. &
-           size(cospIN%tautot_atlid,3)      .ne. cospIN%Nlevels) then 
-          Latlid_subcolumn = .false.
-          Latlid_column    = .false. 
-          nError=nError+1 
-          errorMessage(nError) = 'ERROR(atlid_simulator): The number of levels in the input fields are inconsistent'
-       endif
-    endif
-
-    ! CALIPSO
-    if (Lcalipso_subcolumn .or. Lcalipso_column) then
-       if (size(cospIN%beta_mol_calipso,1)    .ne. cospIN%Npoints .OR. &
-           size(cospIN%betatot_calipso,1)     .ne. cospIN%Npoints .OR. &
-           size(cospIN%betatot_liq_calipso,1) .ne. cospIN%Npoints .OR. &
-           size(cospIN%betatot_ice_calipso,1) .ne. cospIN%Npoints .OR. &
-           size(cospIN%tau_mol_calipso,1)     .ne. cospIN%Npoints .OR. &
-           size(cospIN%tautot_calipso,1)      .ne. cospIN%Npoints .OR. &
-           size(cospIN%tautot_liq_calipso,1)  .ne. cospIN%Npoints .OR. &
-           size(cospIN%tautot_ice_calipso,1)  .ne. cospIN%Npoints) then
-          Lcalipso_subcolumn = .false.
-          Lcalipso_column    = .false.
-          nError=nError+1
-          errorMessage(nError) = 'ERROR(calipso_simulator): The number of points in the input fields are inconsistent'
-       endif
-       if (size(cospIN%betatot_calipso,2)     .ne. cospIN%Ncolumns .OR. &
-           size(cospIN%betatot_liq_calipso,2) .ne. cospIN%Ncolumns .OR. &
-           size(cospIN%betatot_ice_calipso,2) .ne. cospIN%Ncolumns .OR. &
-           size(cospIN%tautot_calipso,2)      .ne. cospIN%Ncolumns .OR. &
-           size(cospIN%tautot_liq_calipso,2)  .ne. cospIN%Ncolumns .OR. &
-           size(cospIN%tautot_ice_calipso,2)  .ne. cospIN%Ncolumns) then
-          Lcalipso_subcolumn = .false.
-          Lcalipso_column    = .false.
-          nError=nError+1
-          errorMessage(nError) = 'ERROR(calipso_simulator): The number of sub-columns in the input fields are inconsistent'
-       endif
-       if (size(cospIN%beta_mol_calipso,2)    .ne. cospIN%Nlevels .OR. &
-           size(cospIN%betatot_calipso,3)     .ne. cospIN%Nlevels .OR. &
-           size(cospIN%betatot_liq_calipso,3) .ne. cospIN%Nlevels .OR. &
-           size(cospIN%betatot_ice_calipso,3) .ne. cospIN%Nlevels .OR. &
-           size(cospIN%tau_mol_calipso,2)     .ne. cospIN%Nlevels .OR. &
-           size(cospIN%tautot_calipso,3)      .ne. cospIN%Nlevels .OR. &
-           size(cospIN%tautot_liq_calipso,3)  .ne. cospIN%Nlevels .OR. &
-           size(cospIN%tautot_ice_calipso,3)  .ne. cospIN%Nlevels) then
-          Lcalipso_subcolumn = .false.
-          Lcalipso_column    = .false.
-          nError=nError+1
-          errorMessage(nError) = 'ERROR(calipso_simulator): The number of levels in the input fields are inconsistent'
-       endif
-    endif
-    
-    ! PARASOL
-    if (Lparasol_subcolumn .or. Lparasol_column) then
-       if (size(cospIN%tautot_S_liq,1) .ne. cospIN%Npoints .OR. &
-           size(cospIN%tautot_S_ice,1) .ne. cospIN%Npoints) then
-          Lparasol_subcolumn = .false.
-          Lparasol_column    = .false.
-          nError=nError+1
-          errorMessage(nError) = 'ERROR(parasol_simulator): The number of points in the input fields are inconsistent'
-       endif
-       if (size(cospIN%tautot_S_liq,2) .ne. cospIN%Ncolumns .OR. &
-           size(cospIN%tautot_S_ice,2) .ne. cospIN%Ncolumns) then
-          Lparasol_subcolumn = .false.
-          Lparasol_column    = .false.
-          nError=nError+1
-          errorMessage(nError) = 'ERROR(parasol_simulator): The number of levels in the input fields are inconsistent'
-       endif
-    endif
-
-    ! RTTOV
-    if (Lrttov_column) then
-       if (size(cospgridIN%pfull,1)           .ne. cospIN%Npoints .OR. &
-           size(cospgridIN%at,1)              .ne. cospIN%Npoints .OR. &
-           size(cospgridIN%qv,1)              .ne. cospIN%Npoints .OR. &
-           size(cospgridIN%hgt_matrix_half,1) .ne. cospIN%Npoints .OR. &
-           size(cospgridIN%u_sfc)             .ne. cospIN%Npoints .OR. &
-           size(cospgridIN%v_sfc)             .ne. cospIN%Npoints .OR. &
-           size(cospgridIN%skt)               .ne. cospIN%Npoints .OR. &
-           size(cospgridIN%phalf,1)           .ne. cospIN%Npoints .OR. &
-           size(cospgridIN%qv,1)              .ne. cospIN%Npoints .OR. &
-           size(cospgridIN%land)              .ne. cospIN%Npoints .OR. &
-           size(cospgridIN%lat)               .ne. cospIN%Npoints) then
-          Lrttov_column    = .false.
-          nError=nError+1
-          errorMessage(nError) = 'ERROR(rttov_simulator): The number of points in the input fields are inconsistent'
-       endif
-       if (size(cospgridIN%pfull,2)           .ne. cospIN%Nlevels   .OR. &
-           size(cospgridIN%at,2)              .ne. cospIN%Nlevels   .OR. &
-           size(cospgridIN%qv,2)              .ne. cospIN%Nlevels   .OR. &
-           size(cospgridIN%hgt_matrix_half,2) .ne. cospIN%Nlevels+1 .OR. &
-           size(cospgridIN%phalf,2)           .ne. cospIN%Nlevels+1 .OR. &
-           size(cospgridIN%qv,2)              .ne. cospIN%Nlevels) then
-          Lrttov_column    = .false.
-          nError=nError+1
-          errorMessage(nError) = 'ERROR(rttov_simulator): The number of levels in the input fields are inconsistent'
-       endif
-    endif
-  end subroutine cosp_errorCheck
-
-  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-  ! END MODULE
-  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-END MODULE MOD_COSP
Index: /LMDZ6/trunk/libf/phylmd/cospv2/cosp.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cospv2/cosp.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/cospv2/cosp.f90	(revision 5268)
@@ -0,0 +1,3665 @@
+! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+! Copyright (c) 2015, Regents of the University of Colorado
+! All rights reserved.
+!
+! Redistribution and use in source and binary forms, with or without modification, are
+! permitted provided that the following conditions are met:
+!
+! 1. Redistributions of source code must retain the above copyright notice, this list of
+!    conditions and the following disclaimer.
+!
+! 2. Redistributions in binary form must reproduce the above copyright notice, this list
+!    of conditions and the following disclaimer in the documentation and/or other
+!    materials provided with the distribution.
+!
+! 3. Neither the name of the copyright holder nor the names of its contributors may be
+!    used to endorse or promote products derived from this software without specific prior
+!    written permission.
+!
+! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY
+! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
+! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL
+! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT
+! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+!
+! History:
+! May 2015- D. Swales - Original version
+! Mar 2018- R. Guzman - Added OPAQ diagnostics and GLID simulator
+! Apr 2018- R. Guzman - Added ATLID simulator
+!
+! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+
+MODULE MOD_COSP
+  USE COSP_KINDS,                  ONLY: wp
+  USE MOD_COSP_CONFIG,             ONLY: R_UNDEF,PARASOL_NREFL,LIDAR_NCAT,LIDAR_NTYPE, SR_BINS,&
+                                         N_HYDRO,RTTOV_MAX_CHANNELS,numMISRHgtBins,      &
+                                         cloudsat_DBZE_BINS,LIDAR_NTEMP,calipso_histBsct,&
+                                         use_vgrid,Nlvgrid,vgrid_zu,vgrid_zl,vgrid_z,    &
+                                         numMODISTauBins,numMODISPresBins,               &
+                                         numMODISReffIceBins,numMODISReffLiqBins,        &
+                                         numISCCPTauBins,numISCCPPresBins,numMISRTauBins,&
+                                         ntau,modis_histTau,tau_binBounds,               &
+                                         modis_histTauEdges,tau_binEdges,nCloudsatPrecipClass,&
+                                         modis_histTauCenters,tau_binCenters,            &
+!                                         cloudsat_preclvl,grLidar532_histBsct,atlid_histBsct !PREC_BUG
+                                         grLidar532_histBsct,atlid_histBsct                                
+  USE MOD_COSP_MODIS_INTERFACE,      ONLY: cosp_modis_init,       modis_IN
+!  USE MOD_COSP_RTTOV_INTERFACE,      ONLY: cosp_rttov_init,       rttov_IN
+  USE MOD_COSP_MISR_INTERFACE,       ONLY: cosp_misr_init,        misr_IN
+  USE MOD_COSP_ISCCP_INTERFACE,      ONLY: cosp_isccp_init,       isccp_IN
+  USE MOD_COSP_CALIPSO_INTERFACE,    ONLY: cosp_calipso_init,     calipso_IN
+  USE MOD_COSP_ATLID_INTERFACE,      ONLY: cosp_atlid_init,       atlid_IN 
+  USE MOD_COSP_GRLIDAR532_INTERFACE, ONLY: cosp_grLidar532_init, grLidar532_IN
+  USE MOD_COSP_PARASOL_INTERFACE,    ONLY: cosp_parasol_init,     parasol_in
+  USE MOD_COSP_CLOUDSAT_INTERFACE,   ONLY: cosp_cloudsat_init,    cloudsat_IN
+  USE quickbeam,                     ONLY: quickbeam_subcolumn,   quickbeam_column, radar_cfg
+  USE MOD_ICARUS,                    ONLY: icarus_subcolumn,      icarus_column
+  USE MOD_MISR_SIMULATOR,            ONLY: misr_subcolumn,        misr_column
+  USE MOD_LIDAR_SIMULATOR,           ONLY: lidar_subcolumn,       lidar_column
+  USE MOD_MODIS_SIM,                 ONLY: modis_subcolumn,       modis_column
+  USE MOD_PARASOL,                   ONLY: parasol_subcolumn,     parasol_column
+!  use mod_cosp_rttov,                ONLY: rttov_column
+  USE MOD_COSP_STATS,                ONLY: COSP_LIDAR_ONLY_CLOUD,COSP_CHANGE_VERTICAL_GRID
+
+  IMPLICIT NONE
+
+  logical :: linitialization ! Initialization flag
+
+  ! ######################################################################################
+  ! TYPE cosp_column_inputs
+  ! ######################################################################################
+  type cosp_column_inputs
+     integer :: &
+          Npoints,             & ! Number of gridpoints.
+          Ncolumns,            & ! Number of columns.
+          Nlevels                ! Number of levels.
+
+     integer,allocatable,dimension(:) :: &
+          sunlit                 ! Sunlit flag                            (0-1)
+
+     real(wp),allocatable,dimension(:,:) :: &
+          at,                  & ! Temperature                            (K)
+          pfull,               & ! Pressure                               (Pa)
+          phalf,               & ! Pressure at half-levels                (Pa)
+          qv,                  & ! Specific humidity                      (kg/kg)
+          hgt_matrix,          & ! Height of hydrometeors                 (km)
+          hgt_matrix_half        ! Height of hydrometeors at half levels  (km)
+
+     real(wp),allocatable,dimension(:) :: &
+          land,                & ! Land/Sea mask                          (0-1)
+          skt,                 & ! Surface temperature                    (K)
+          surfelev               ! Surface Elevation                      (m)
+     ! Fields used ONLY by RTTOV
+     integer :: &
+          month                  ! Month for surface emissivty atlas      (1-12)
+     real(wp) :: &
+          zenang,              & ! Satellite zenith angle for RTTOV       (deg)
+          co2,                 & ! CO2                                    (kg/kg)
+          ch4,                 & ! Methane                                (kg/kg)
+          n2o,                 & ! N2O                                    (kg/kg)
+          co                     ! CO                                     (kg/kg)
+     real(wp),allocatable,dimension(:) :: &
+          emis_sfc,            & ! Surface emissivity                     (1)
+          u_sfc,               & ! Surface u-wind                         (m/s)
+          v_sfc,               & ! Surface v-wind                         (m/s)
+          seaice,              & ! Sea-ice fraction                       (0-1)
+          lat,                 & ! Latitude                              (deg)
+          lon                    ! Longitude                              (deg)
+     real(wp),allocatable,dimension(:,:) :: &
+          o3,                  & ! Ozone                                  (kg/kg)
+          tca,                 & ! Total column cloud fraction            (0-1)
+          cloudIce,            & ! Cloud ice water mixing ratio           (kg/kg)
+          cloudLiq,            & ! Cloud liquid water mixing ratio        (kg/kg)
+          fl_rain,             & ! Precipitation (rain) flux              (kg/m2/s)
+          fl_snow                ! Precipitation (snow) flux              (kg/m2/s)
+  end type cosp_column_inputs
+
+  ! ######################################################################################
+  ! TYPE cosp_optical_inputs
+  ! ######################################################################################
+  type cosp_optical_inputs
+     integer :: &
+          Npoints,             & ! Number of gridpoints.
+          Ncolumns,            & ! Number of columns.
+          Nlevels,             & ! Number of levels.
+          Npart,               & ! Number of cloud meteors for LIDAR simulators.
+          Nrefl                  ! Number of reflectances for PARASOL simulator
+     real(wp) :: &
+          emsfc_lw               ! Surface emissivity @ 11micron
+     real(wp),allocatable,dimension(:,:,:) :: &
+          frac_out,            & ! Cloud fraction
+          tau_067,             & ! Optical depth @ 0.67micron
+          emiss_11,            & ! Emissivity @ 11 micron
+          fracLiq,             & ! Fraction of optical-depth due to liquid (MODIS)
+          asym,                & ! Assymetry parameter @ 3.7micron (MODIS)
+          ss_alb,              & ! Single-scattering albedo @ 3.7micron (MODIS)
+          betatot_calipso,     & ! Lidar backscatter coefficient (calipso @ 532nm)
+          betatot_grLidar532,  & ! Lidar backscatter coefficient (ground-lidar @ 532nm)
+          betatot_atlid,       & ! Lidar backscatter coefficient (atlid @ 355nm)
+          betatot_ice_calipso, & ! Lidar backscatter coefficient ICE (calipso @ 532nm)
+          betatot_liq_calipso, & ! Lidar backscatter coefficient LIQUID (calipso @ 532nm)
+          tautot_calipso,      & ! Lidar Optical thickness (calipso @ 532nm)
+          tautot_grLidar532,   & ! Lidar Optical thickness (ground-lidar @ 532nm)  
+          tautot_atlid,        & ! Lidar Optical thickness (atlid @ 355nm)
+          tautot_ice_calipso,  & ! Lidar Ice Optical thickness (calipso @ 532nm)
+          tautot_liq_calipso,  & ! Lidar Liquid Optical thickness (calipso @ 532nm)
+          z_vol_cloudsat,      & ! Effective reflectivity factor (mm^6/m^3)
+          kr_vol_cloudsat,     & ! Attenuation coefficient hydro (dB/km) 
+          g_vol_cloudsat         ! Attenuation coefficient gases (dB/km)
+     real(wp),allocatable,dimension(:,:) :: &
+          beta_mol_calipso,    & ! Lidar molecular backscatter coefficient (calipso @ 532nm)
+          beta_mol_grLidar532, & ! Lidar molecular backscatter coefficient (ground-lidar @ 532nm) 
+          beta_mol_atlid,      & ! Lidar molecular backscatter coefficient (atlid @ 355nm)
+          tau_mol_calipso,     & ! Lidar molecular optical depth (calipso @ 532nm)
+          tau_mol_grLidar532,  & ! Lidar molecular optical depth (ground-lidar @ 532nm) 
+          tau_mol_atlid,       & ! Lidar molecular optical depth (atlid @ 355nm)
+          tautot_S_liq,        & ! Parasol Liquid water optical thickness, from TOA to SFC
+          tautot_S_ice,        & ! Parasol Ice water optical thickness, from TOA to SFC
+          fracPrecipIce          ! Fraction of precipitation which is frozen (1).
+     type(radar_cfg) :: &
+          rcfg_cloudsat          ! Radar configuration information (CLOUDSAT)
+  end type cosp_optical_inputs
+
+  ! ######################################################################################
+  ! TYPE cosp_outputs
+  ! ######################################################################################
+  type cosp_outputs
+
+     ! CALIPSO outputs
+     real(wp),dimension(:,:,:),pointer :: &
+          calipso_betaperp_tot => null(),  & ! Total backscattered signal
+          calipso_beta_tot => null(),      & ! Total backscattered signal
+          calipso_tau_tot => null(),       & ! Optical thickness integrated from top to level z
+          calipso_lidarcldphase => null(), & ! 3D "lidar" phase cloud fraction
+          calipso_lidarcldtype => null(),  & ! 3D "lidar" OPAQ type fraction
+          calipso_cldlayerphase => null(), & ! low, mid, high-level lidar phase cloud cover
+          calipso_lidarcldtmp => null(),   & ! 3D "lidar" phase cloud temperature
+          calipso_cfad_sr => null()          ! CFAD of scattering ratio
+     real(wp), dimension(:,:),pointer :: &
+          calipso_lidarcld => null(),      & ! 3D "lidar" cloud fraction 
+          calipso_cldlayer => null(),      & ! low, mid, high-level, total lidar cloud cover
+          calipso_cldtype => null(),       & ! opaque and thin lidar cloud cover + z_opaque altitude
+          calipso_cldtypetemp => null(),   & ! opaque and thin cloud temperature  
+          calipso_cldtypemeanz => null(),  & ! opaque and thin cloud altitude 
+          calipso_cldtypemeanzse => null(),& ! same as just above with respect to SE
+          calipso_beta_mol => null(),      & ! Molecular backscatter
+          calipso_temp_tot => null()
+     real(wp), dimension(:),pointer :: &
+          calipso_cldthinemis => null(),   & ! thin cloud emissivity 
+          calipso_srbval => null()           ! SR bins in cfad_sr
+
+     ! GROUND LIDAR outputs
+     real(wp),dimension(:,:,:),pointer :: &  
+          grLidar532_beta_tot => null(),   & ! Total GROUND LIDAR backscattered signal 
+          grLidar532_cfad_sr => null()       ! CFAD of GROUND LIDAR scattering ratio 
+     real(wp), dimension(:,:),pointer :: &  
+          grLidar532_lidarcld => null(),   & ! 3D GROUND "lidar" cloud fraction  
+          grLidar532_cldlayer => null(),   & ! low, mid, high-level, total GROUND lidar cloud cover
+          grLidar532_beta_mol => null()      ! GROUND LIDAR Molecular backscatter 
+     real(wp), dimension(:),pointer :: &  
+          grLidar532_srbval => null()        ! SR bins in cfad_sr
+
+     ! ATLID outputs
+     real(wp),dimension(:,:,:),pointer :: & 
+          atlid_beta_tot => null(),   & ! Total ATLID backscattered signal 
+          atlid_cfad_sr => null()       ! CFAD of ATLID scattering ratio 
+     real(wp), dimension(:,:),pointer :: & 
+          atlid_lidarcld => null(),   & ! 3D ATLID cloud fraction
+          atlid_cldlayer => null(),   & ! low, mid, high-level, total ATLID cloud cover 
+          atlid_beta_mol => null()      ! ATLID Molecular backscatter 
+     real(wp), dimension(:),pointer :: & 
+          atlid_srbval => null()        ! SR bins in cfad_sr
+
+
+     ! PARASOL outputs
+     real(wp),dimension(:,:,:),pointer :: &
+          parasolPix_refl => null()            ! PARASOL reflectances (subcolumn)
+     real(wp),dimension(:,:),pointer :: &
+          parasolGrid_refl => null()           ! PARASOOL reflectances (column)
+
+     ! CLOUDSAT outputs
+     real(wp),dimension(:,:,:),pointer :: &
+          cloudsat_Ze_tot => null(),         & ! Effective reflectivity factor (Npoints,Ncolumns,Nlevels)
+          cloudsat_cfad_ze => null()           ! Ze CFAD(Npoints,dBZe_bins,Nlevels)
+     real(wp), dimension(:,:),pointer :: &
+          lidar_only_freq_cloud => null(),   & ! (Npoints,Nlevels)
+          cloudsat_precip_cover => null()      ! Radar total cloud amount by CloudSat precip flag (Npoints,dBZe_bins)
+     real(wp),dimension(:),pointer :: &
+          cloudsat_tcc => null(),             &
+          cloudsat_tcc2 => null(),            &          
+          radar_lidar_tcc => null(),         & ! Radar&lidar total cloud amount, grid-box scale (Npoints)
+          cloudsat_pia => null()               ! Radar path integrated attenuation (Npoints)
+          
+     ! ISCCP outputs       
+     real(wp),dimension(:),pointer :: &
+          isccp_totalcldarea => null(), & ! The fraction of model grid box columns with cloud
+           		                  ! somewhere in them. (%)
+          isccp_meantb => null(),       & ! Mean all-sky 10.5 micron brightness temperature. (K)
+          isccp_meantbclr => null(),    & ! Mean clear-sky 10.5 micron brightness temperature. (K)
+          isccp_meanptop => null(),     & ! Mean cloud top pressure (mb).
+          isccp_meantaucld => null(),   & ! Mean optical thickness. (1)
+          isccp_meanalbedocld => null()   ! Mean cloud albedo. (1)
+     real(wp),dimension(:,:),pointer ::&
+          isccp_boxtau => null(),       & ! Optical thickness in each column. (1)
+          isccp_boxptop => null()         ! Cloud top pressure in each column. (mb)
+     real(wp),dimension(:,:,:),pointer :: &
+          isccp_fq  => null()             ! The fraction of the model grid box covered by each of
+                                          ! the 49 ISCCP D level cloud types. (%)
+
+     ! MISR outptus
+     real(wp),dimension(:,:,:),pointer ::   & !
+          misr_fq => null()          ! Fraction of the model grid box covered by each of the MISR
+                           ! cloud types
+     real(wp),dimension(:,:),pointer ::   & !
+          misr_dist_model_layertops => null() !
+     real(wp),dimension(:),pointer ::   & !
+          misr_meanztop => null(), & ! Mean MISR cloud top height
+          misr_cldarea => null()     ! Mean MISR cloud cover area
+
+     ! MODIS outptus
+     real(wp),pointer,dimension(:) ::      & !
+          modis_Cloud_Fraction_Total_Mean => null(),       & ! L3 MODIS retrieved cloud fraction (total)
+          modis_Cloud_Fraction_Water_Mean => null(),       & ! L3 MODIS retrieved cloud fraction (liq)
+          modis_Cloud_Fraction_Ice_Mean => null(),         & ! L3 MODIS retrieved cloud fraction (ice)
+          modis_Cloud_Fraction_High_Mean => null(),        & ! L3 MODIS retrieved cloud fraction (high)
+          modis_Cloud_Fraction_Mid_Mean => null(),         & ! L3 MODIS retrieved cloud fraction (middle)
+          modis_Cloud_Fraction_Low_Mean => null(),         & ! L3 MODIS retrieved cloud fraction (low )
+          modis_Optical_Thickness_Total_Mean => null(),    & ! L3 MODIS retrieved optical thickness (tot)
+          modis_Optical_Thickness_Water_Mean => null(),    & ! L3 MODIS retrieved optical thickness (liq)
+          modis_Optical_Thickness_Ice_Mean => null(),      & ! L3 MODIS retrieved optical thickness (ice)
+          modis_Optical_Thickness_Total_LogMean => null(), & ! L3 MODIS retrieved log10 optical thickness
+          modis_Optical_Thickness_Water_LogMean => null(), & ! L3 MODIS retrieved log10 optical thickness
+          modis_Optical_Thickness_Ice_LogMean => null(),   & ! L3 MODIS retrieved log10 optical thickness
+          modis_Cloud_Particle_Size_Water_Mean => null(),  & ! L3 MODIS retrieved particle size (liquid)
+          modis_Cloud_Particle_Size_Ice_Mean => null(),    & ! L3 MODIS retrieved particle size (ice)
+          modis_Cloud_Top_Pressure_Total_Mean => null(),   & ! L3 MODIS retrieved cloud top pressure
+          modis_Liquid_Water_Path_Mean => null(),          & ! L3 MODIS retrieved liquid water path
+          modis_Ice_Water_Path_Mean => null()                ! L3 MODIS retrieved ice water path
+     real(wp),pointer,dimension(:,:,:) ::  &
+          modis_Optical_Thickness_vs_Cloud_Top_Pressure => null(), & ! Tau/Pressure joint histogram
+          modis_Optical_Thickness_vs_ReffICE => null(),            & ! Tau/ReffICE joint histogram
+          modis_Optical_Thickness_vs_ReffLIQ => null()               ! Tau/ReffLIQ joint histogram
+
+     ! RTTOV outputs
+     real(wp),pointer :: &
+          rttov_tbs(:,:) => null() ! Brightness Temperature
+
+  end type cosp_outputs
+
+CONTAINS
+  ! ######################################################################################
+  ! FUNCTION cosp_simulator
+  ! ######################################################################################
+  function COSP_SIMULATOR(cospIN,cospgridIN,cospOUT,start_idx,stop_idx,debug)
+    type(cosp_optical_inputs),intent(in),target :: cospIN     ! Optical inputs to COSP simulator
+    type(cosp_column_inputs), intent(in),target :: cospgridIN ! Host model inputs to COSP
+
+    ! Inputs into the simulators
+    type(isccp_IN)    :: isccpIN    ! Input to the ISCCP simulator
+    type(misr_IN)     :: misrIN     ! Input to the LIDAR simulator
+    type(calipso_IN)  :: calipsoIN  ! Input to the LIDAR simulator
+    type(grLidar532_IN) :: grLidar532IN ! Input to the GROUND LIDAR simulator
+    type(atlid_IN)    :: atlidIN    ! Input to the ATLID simulator 
+    type(parasol_IN)  :: parasolIN  ! Input to the PARASOL simulator
+    type(cloudsat_IN) :: cloudsatIN ! Input to the CLOUDSAT radar simulator
+    type(modis_IN)    :: modisIN    ! Input to the MODIS simulator
+!    type(rttov_IN)    :: rttovIN    ! Input to the RTTOV simulator
+    integer,optional  :: start_idx,stop_idx
+    logical,optional  :: debug
+
+    ! Outputs from the simulators (nested simulator output structure)
+    type(cosp_outputs), intent(inout) :: cospOUT
+    character(len=256),dimension(100) :: cosp_simulator
+
+    ! Local variables
+    integer :: &
+         i,icol,ij,ik,nError
+    integer,target :: &
+         Npoints
+    logical :: &
+         Lisccp_subcolumn,     & ! On/Off switch for subcolumn ISCCP simulator
+         Lmisr_subcolumn,      & ! On/Off switch for subcolumn MISR simulator
+         Lcalipso_subcolumn,   & ! On/Off switch for subcolumn CALIPSO simulator
+         LgrLidar532_subcolumn,& ! On/Off switch for subcolumn GROUND LIDAR simulator
+         Latlid_subcolumn,     & ! On/Off switch for subcolumn ATLID simulator
+         Lparasol_subcolumn,   & ! On/Off switch for subcolumn PARASOL simulator
+         Lcloudsat_subcolumn,  & ! On/Off switch for subcolumn CLOUDSAT simulator
+         Lmodis_subcolumn,     & ! On/Off switch for subcolumn MODIS simulator
+         Lrttov_subcolumn,     & ! On/Off switch for subcolumn RTTOV simulator
+         Lisccp_column,        & ! On/Off switch for column ISCCP simulator
+         Lmisr_column,         & ! On/Off switch for column MISR simulator
+         Lcalipso_column,      & ! On/Off switch for column CALIPSO simulator
+         LgrLidar532_column,   & ! On/Off switch for column GROUND LIDAR simulator
+         Latlid_column,        & ! On/Off switch for column ATLID simulator
+         Lparasol_column,      & ! On/Off switch for column PARASOL simulator
+         Lcloudsat_column,     & ! On/Off switch for column CLOUDSAT simulator
+         Lmodis_column,        & ! On/Off switch for column MODIS simulator
+         Lrttov_column,        & ! On/Off switch for column RTTOV simulator (not used)
+         Lradar_lidar_tcc,     & ! On/Off switch from joint Calipso/Cloudsat product
+         Lcloudsat_tcc,       & !
+         Lcloudsat_tcc2,      & !         
+         Llidar_only_freq_cloud  ! On/Off switch from joint Calipso/Cloudsat product
+    logical :: &
+         ok_lidar_cfad    = .false., &
+         ok_lidar_cfad_grLidar532 = .false., & 
+         ok_lidar_cfad_atlid = .false., &
+         lrttov_cleanUp   = .false.
+    
+    integer, dimension(:,:),allocatable  :: &
+         modisRetrievedPhase,isccpLEVMATCH
+    real(wp), dimension(:),  allocatable  :: &
+         modisCfTotal,modisCfLiquid,modisMeanIceWaterPath, isccp_meantbclr,     &
+         modisCfIce, modisCfHigh, modisCfMid, modisCfLow,modisMeanTauTotal,     &
+         modisMeanTauLiquid, modisMeanTauIce, modisMeanLogTauTotal,             &
+         modisMeanLogTauLiquid, modisMeanLogTauIce, modisMeanSizeLiquid,        &
+         modisMeanSizeIce, modisMeanCloudTopPressure, modisMeanLiquidWaterPath, &
+         radar_lidar_tcc, cloudsat_tcc, cloudsat_tcc2
+    REAL(WP), dimension(:,:),allocatable  :: &
+         modisRetrievedCloudTopPressure,modisRetrievedTau,modisRetrievedSize,   &
+         misr_boxtau,misr_boxztop,misr_dist_model_layertops,isccp_boxtau,       &
+         isccp_boxttop,isccp_boxptop,calipso_beta_mol,lidar_only_freq_cloud,    &
+         grLidar532_beta_mol,atlid_beta_mol 
+    REAL(WP), dimension(:,:,:),allocatable :: &
+         modisJointHistogram,modisJointHistogramIce,modisJointHistogramLiq,     &
+         calipso_beta_tot,calipso_betaperp_tot, cloudsatDBZe,parasolPix_refl,   &
+         grLidar532_beta_tot,atlid_beta_tot,cloudsatZe_non
+    real(wp),dimension(:),allocatable,target :: &
+         out1D_1,out1D_2,out1D_3,out1D_4,out1D_5,out1D_6,out1D_7,out1D_8,       &
+         out1D_9,out1D_10,out1D_11,out1D_12 
+    real(wp),dimension(:,:,:),allocatable :: &
+       betamol_in,betamoli,pnormi,ze_toti,ze_noni
+
+    ! Initialize error reporting for output
+    cosp_simulator(:)=''
+
+    !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+    ! 1) Determine if using full inputs or subset
+    !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+    if (present(start_idx) .and. present(stop_idx)) then
+       ij=start_idx
+       ik=stop_idx
+    else
+       ij=1
+       ik=cospIN%Npoints
+    endif
+    Npoints = ik-ij+1
+
+    !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+    ! 2a) Determine which simulators to run and which statistics to compute
+    !    - If any of the subcolumn fields are allocated, then run the subcolumn simulators.
+    !    - If any of the column fields are allocated, then compute the statistics for that
+    !      simulator, but only save the requested fields.
+    !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+    ! Start with all simulators and joint-diagnostics off
+    Lisccp_subcolumn    = .false.
+    Lmisr_subcolumn     = .false.
+    Lcalipso_subcolumn  = .false.
+    LgrLidar532_subcolumn = .false.
+    Latlid_subcolumn    = .false. 
+    Lparasol_subcolumn  = .false.
+    Lcloudsat_subcolumn = .false.
+    Lmodis_subcolumn    = .false.
+    Lrttov_subcolumn    = .false.
+    Lisccp_column       = .false.
+    Lmisr_column        = .false.
+    Lcalipso_column     = .false.
+    LgrLidar532_column = .false.
+    Latlid_column       = .false.
+    Lparasol_column     = .false.
+    Lcloudsat_column    = .false.
+    Lmodis_column       = .false.
+    Lrttov_column       = .false.
+    Lradar_lidar_tcc    = .false.
+    Llidar_only_freq_cloud = .false.
+    Lcloudsat_tcc       = .false.
+    Lcloudsat_tcc2      = .false.
+
+    ! CLOUDSAT subcolumn
+    if (associated(cospOUT%cloudsat_Ze_tot)) Lcloudsat_subcolumn = .true.
+
+    ! MODIS subcolumn
+    if (associated(cospOUT%modis_Cloud_Fraction_Water_Mean)                .or.          &
+        associated(cospOUT%modis_Cloud_Fraction_Total_Mean)                .or.          &
+        associated(cospOUT%modis_Cloud_Fraction_Ice_Mean)                  .or.          &
+        associated(cospOUT%modis_Cloud_Fraction_High_Mean)                 .or.          &
+        associated(cospOUT%modis_Cloud_Fraction_Mid_Mean)                  .or.          &
+        associated(cospOUT%modis_Cloud_Fraction_Low_Mean)                  .or.          &
+        associated(cospOUT%modis_Optical_Thickness_Total_Mean)             .or.          &
+        associated(cospOUT%modis_Optical_Thickness_Water_Mean)             .or.          &
+        associated(cospOUT%modis_Optical_Thickness_Ice_Mean)               .or.          &
+        associated(cospOUT%modis_Optical_Thickness_Total_LogMean)          .or.          &
+        associated(cospOUT%modis_Optical_Thickness_Water_LogMean)          .or.          &
+        associated(cospOUT%modis_Optical_Thickness_Ice_LogMean)            .or.          &
+        associated(cospOUT%modis_Cloud_Particle_Size_Water_Mean)           .or.          &
+        associated(cospOUT%modis_Cloud_Particle_Size_Ice_Mean)             .or.          &
+        associated(cospOUT%modis_Cloud_Top_Pressure_Total_Mean)            .or.          &
+        associated(cospOUT%modis_Liquid_Water_Path_Mean)                   .or.          &
+        associated(cospOUT%modis_Ice_Water_Path_Mean)                      .or.          &
+        associated(cospOUT%modis_Optical_Thickness_vs_Cloud_Top_Pressure))               &
+       Lmodis_subcolumn    = .true.
+
+    ! ISCCP subcolumn
+    if (associated(cospOUT%isccp_boxtau)                                   .or.          &
+        associated(cospOUT%isccp_boxptop))                                               &
+       Lisccp_subcolumn    = .true.
+
+    ! MISR subcolumn
+    if (associated(cospOUT%misr_dist_model_layertops))                                   &
+       Lmisr_subcolumn     = .true.
+
+    ! CALIPOSO subcolumn
+    if (associated(cospOUT%calipso_tau_tot)                                .or.          &
+        associated(cospOUT%calipso_beta_mol)                               .or.          &
+        associated(cospOUT%calipso_temp_tot)                               .or.          &
+        associated(cospOUT%calipso_betaperp_tot)                           .or.          &
+        associated(cospOUT%calipso_beta_tot))                                            &
+       Lcalipso_subcolumn  = .true.
+
+    ! GROUND LIDAR subcolumn 
+    if (associated(cospOUT%grLidar532_beta_mol)                           .or.          &
+        associated(cospOUT%grLidar532_beta_tot))                                        &
+       LgrLidar532_subcolumn  = .true. 
+
+    ! ATLID subcolumn
+    if (associated(cospOUT%atlid_beta_mol)                                 .or.          & 
+        associated(cospOUT%atlid_beta_tot))                                              &
+       Latlid_subcolumn  = .true.  
+
+    ! PARASOL subcolumn
+    if (associated(cospOUT%parasolPix_refl))                                             &
+       Lparasol_subcolumn  = .true.
+
+    ! RTTOV column
+    if (associated(cospOUT%rttov_tbs))                                                   &
+       Lrttov_column    = .true.
+
+    ! Set flag to deallocate rttov types (only done on final call to simulator)
+    if (size(cospOUT%isccp_meantb) .eq. stop_idx) lrttov_cleanUp = .true.
+
+    ! ISCCP column
+    if (associated(cospOUT%isccp_fq)                                       .or.          &
+        associated(cospOUT%isccp_meanalbedocld)                            .or.          &
+        associated(cospOUT%isccp_meanptop)                                 .or.          &
+        associated(cospOUT%isccp_meantaucld)                               .or.          &
+        associated(cospOUT%isccp_totalcldarea)                             .or.          &
+        associated(cospOUT%isccp_meantb)) then
+       Lisccp_column    = .true.
+       Lisccp_subcolumn = .true.
+    endif
+
+    ! MISR column
+    if (associated(cospOUT%misr_cldarea)                                   .or.          &
+        associated(cospOUT%misr_meanztop)                                  .or.          &
+        associated(cospOUT%misr_fq)) then
+       Lmisr_column    = .true.
+       Lmisr_subcolumn = .true.
+    endif
+
+    ! CALIPSO column
+    if (associated(cospOUT%calipso_cfad_sr)                                .or.          &
+        associated(cospOUT%calipso_lidarcld)                               .or.          &
+        associated(cospOUT%calipso_lidarcldphase)                          .or.          &
+        associated(cospOUT%calipso_lidarcldtype)                           .or.          &
+        associated(cospOUT%calipso_cldlayer)                               .or.          &
+        associated(cospOUT%calipso_cldtype)                                .or.          & 
+        associated(cospOUT%calipso_cldtypetemp)                            .or.          & 
+        associated(cospOUT%calipso_cldtypemeanz)                           .or.          & 
+        associated(cospOUT%calipso_cldtypemeanzse)                         .or.          & 
+        associated(cospOUT%calipso_cldthinemis)                            .or.          &
+        associated(cospOUT%calipso_cldlayerphase)                          .or.          &
+        associated(cospOUT%calipso_lidarcldtmp)) then
+       Lcalipso_column    = .true.
+       Lcalipso_subcolumn = .true.
+    endif
+
+    ! GROUND LIDAR column 
+    if (associated(cospOUT%grLidar532_cfad_sr)                            .or.          & 
+        associated(cospOUT%grLidar532_lidarcld)                           .or.          & 
+        associated(cospOUT%grLidar532_cldlayer)) then 
+       LgrLidar532_column    = .true. 
+       LgrLidar532_subcolumn = .true. 
+    endif
+
+    ! ATLID column 
+    if (associated(cospOUT%atlid_cfad_sr)                                  .or.          & 
+        associated(cospOUT%atlid_lidarcld)                                 .or.          & 
+        associated(cospOUT%atlid_cldlayer)) then  
+       Latlid_column    = .true. 
+       Latlid_subcolumn = .true.
+    endif
+
+    ! PARASOL column
+    if (associated(cospOUT%parasolGrid_refl)) then
+       Lparasol_column    = .true.
+       Lparasol_subcolumn = .true.
+    endif
+
+    ! CLOUDSAT column
+    if (associated(cospOUT%cloudsat_cfad_ze)) then
+       Lcloudsat_column    = .true.
+       Lcloudsat_subcolumn = .true.
+    endif
+
+    ! MODIS column
+    if (associated(cospOUT%modis_Cloud_Fraction_Total_Mean)                .or.          &
+        associated(cospOUT%modis_Cloud_Fraction_Water_Mean)                .or.          &
+        associated(cospOUT%modis_Cloud_Fraction_Ice_Mean)                  .or.          &
+        associated(cospOUT%modis_Cloud_Fraction_High_Mean)                 .or.          &
+        associated(cospOUT%modis_Cloud_Fraction_Mid_Mean)                  .or.          &
+        associated(cospOUT%modis_Cloud_Fraction_Low_Mean)                  .or.          &
+        associated(cospOUT%modis_Optical_Thickness_Total_Mean)             .or.          &
+        associated(cospOUT%modis_Optical_Thickness_Water_Mean)             .or.          &
+        associated(cospOUT%modis_Optical_Thickness_Ice_Mean)               .or.          &
+        associated(cospOUT%modis_Optical_Thickness_Total_LogMean)          .or.          &
+        associated(cospOUT%modis_Optical_Thickness_Water_LogMean)          .or.          &
+        associated(cospOUT%modis_Optical_Thickness_Ice_LogMean)            .or.          &
+        associated(cospOUT%modis_Cloud_Particle_Size_Water_Mean)           .or.          &
+        associated(cospOUT%modis_Cloud_Particle_Size_Ice_Mean)             .or.          &
+        associated(cospOUT%modis_Cloud_Top_Pressure_Total_Mean)            .or.          &
+        associated(cospOUT%modis_Liquid_Water_Path_Mean)                   .or.          &
+        associated(cospOUT%modis_Ice_Water_Path_Mean)                      .or.          &
+        associated(cospOUT%modis_Optical_Thickness_vs_Cloud_Top_Pressure)) then
+       Lmodis_column    = .true.
+       Lmodis_subcolumn = .true.
+    endif
+
+    ! Joint simulator products
+    if (associated(cospOUT%lidar_only_freq_cloud) .or. associated(cospOUT%radar_lidar_tcc) .or. &
+        associated(cospOUT%cloudsat_tcc) .or. associated(cospOUT%cloudsat_tcc2)) then
+       Lcalipso_column     = .true.
+       Lcalipso_subcolumn  = .true.
+       Lcloudsat_column    = .true.
+       Lcloudsat_subcolumn = .true.
+       Lradar_lidar_tcc    = .true.
+       Llidar_only_freq_cloud = .true.
+       Lcloudsat_tcc       = .true.
+       Lcloudsat_tcc2      = .true.
+    endif
+
+    !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+    ! 2b) Error Checking
+    !     Enforce bounds on input fields. If input field is out-of-bounds, report error
+    !     and turn off simulator
+    !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+    call cosp_errorCheck(cospgridIN, cospIN, Lisccp_subcolumn, Lisccp_column,            &
+         Lmisr_subcolumn, Lmisr_column, Lmodis_subcolumn, Lmodis_column,                 &
+         Lcloudsat_subcolumn, Lcloudsat_column, Lcalipso_subcolumn, Lcalipso_column,     &
+         Latlid_subcolumn, Latlid_column, LgrLidar532_subcolumn, LgrLidar532_column,     &
+         Lrttov_subcolumn, Lrttov_column, Lparasol_subcolumn, Lparasol_column,           &
+         Lradar_lidar_tcc, Llidar_only_freq_cloud, Lcloudsat_tcc,Lcloudsat_tcc2, cospOUT,&
+         cosp_simulator, nError)
+
+    !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+    ! 3) Populate instrument simulator inputs
+    !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+    if (Lisccp_subcolumn .or. Lmodis_subcolumn) then
+       isccpIN%Npoints  => Npoints
+       isccpIN%Ncolumns => cospIN%Ncolumns
+       isccpIN%Nlevels  => cospIN%Nlevels
+       isccpIN%emsfc_lw => cospIN%emsfc_lw
+       isccpIN%skt      => cospgridIN%skt
+       isccpIN%qv       => cospgridIN%qv
+       isccpIN%at       => cospgridIN%at
+       isccpIN%frac_out => cospIN%frac_out
+       isccpIN%dtau     => cospIN%tau_067
+       isccpIN%dem      => cospIN%emiss_11
+       isccpIN%phalf    => cospgridIN%phalf
+       isccpIN%sunlit   => cospgridIN%sunlit
+       isccpIN%pfull    => cospgridIN%pfull
+    endif
+
+    if (Lmisr_subcolumn) then
+       misrIN%Npoints  => Npoints
+       misrIN%Ncolumns => cospIN%Ncolumns
+       misrIN%Nlevels  => cospIN%Nlevels
+       misrIN%dtau     => cospIN%tau_067
+       misrIN%sunlit   => cospgridIN%sunlit
+       misrIN%zfull    => cospgridIN%hgt_matrix
+       misrIN%at       => cospgridIN%at
+    endif
+
+    if (Lcalipso_subcolumn) then
+       calipsoIN%Npoints     => Npoints
+       calipsoIN%Ncolumns    => cospIN%Ncolumns
+       calipsoIN%Nlevels     => cospIN%Nlevels
+       calipsoIN%beta_mol    => cospIN%beta_mol_calipso
+       calipsoIN%betatot     => cospIN%betatot_calipso
+       calipsoIN%betatot_liq => cospIN%betatot_liq_calipso
+       calipsoIN%betatot_ice => cospIN%betatot_ice_calipso
+       calipsoIN%tau_mol     => cospIN%tau_mol_calipso
+       calipsoIN%tautot      => cospIN%tautot_calipso
+       calipsoIN%tautot_liq  => cospIN%tautot_liq_calipso
+       calipsoIN%tautot_ice  => cospIN%tautot_ice_calipso
+    endif
+
+    if (LgrLidar532_subcolumn) then 
+       grLidar532IN%Npoints  => Npoints
+       grLidar532IN%Ncolumns => cospIN%Ncolumns 
+       grLidar532IN%Nlevels  => cospIN%Nlevels
+       grLidar532IN%beta_mol => cospIN%beta_mol_grLidar532 
+       grLidar532IN%betatot  => cospIN%betatot_grLidar532 
+       grLidar532IN%tau_mol  => cospIN%tau_mol_grLidar532 
+       grLidar532IN%tautot   => cospIN%tautot_grLidar532  
+    endif
+    
+    if (Latlid_subcolumn) then 
+       atlidIN%Npoints        => Npoints 
+       atlidIN%Ncolumns       => cospIN%Ncolumns 
+       atlidIN%Nlevels        => cospIN%Nlevels 
+       atlidIN%beta_mol_atlid => cospIN%beta_mol_atlid
+       atlidIN%betatot_atlid  => cospIN%betatot_atlid 
+       atlidIN%tau_mol_atlid  => cospIN%tau_mol_atlid 
+       atlidIN%tautot_atlid   => cospIN%tautot_atlid 
+    endif 
+    
+    if (Lparasol_subcolumn) then
+       parasolIN%Npoints      => Npoints
+       parasolIN%Nlevels      => cospIN%Nlevels
+       parasolIN%Ncolumns     => cospIN%Ncolumns
+       parasolIN%Nrefl        => cospIN%Nrefl
+       parasolIN%tautot_S_liq => cospIN%tautot_S_liq
+       parasolIN%tautot_S_ice => cospIN%tautot_S_ice
+    endif
+
+    if (Lcloudsat_subcolumn) then
+       cloudsatIN%Npoints    => Npoints
+       cloudsatIN%Nlevels    => cospIN%Nlevels
+       cloudsatIN%Ncolumns   => cospIN%Ncolumns
+       cloudsatIN%z_vol      => cospIN%z_vol_cloudsat
+       cloudsatIN%kr_vol     => cospIN%kr_vol_cloudsat
+       cloudsatIN%g_vol      => cospIN%g_vol_cloudsat
+       cloudsatIN%rcfg       => cospIN%rcfg_cloudsat
+       cloudsatIN%hgt_matrix => cospgridIN%hgt_matrix
+    endif
+
+    if (Lmodis_subcolumn) then
+       modisIN%Ncolumns  => cospIN%Ncolumns
+       modisIN%Nlevels   => cospIN%Nlevels
+       modisIN%Npoints   => Npoints
+       modisIN%liqFrac   => cospIN%fracLiq
+       modisIN%tau       => cospIN%tau_067
+       modisIN%g         => cospIN%asym
+       modisIN%w0        => cospIN%ss_alb
+       modisIN%Nsunlit   = count(cospgridIN%sunlit > 0)
+       if (modisIN%Nsunlit .gt. 0) then
+          allocate(modisIN%sunlit(modisIN%Nsunlit),modisIN%pres(modisIN%Nsunlit,cospIN%Nlevels+1))
+          modisIN%sunlit    = pack((/ (i, i = 1, Npoints ) /),mask = cospgridIN%sunlit > 0)
+          modisIN%pres      = cospgridIN%phalf(int(modisIN%sunlit(:)),:)
+       endif
+       if (count(cospgridIN%sunlit <= 0) .gt. 0) then
+          allocate(modisIN%notSunlit(count(cospgridIN%sunlit <= 0)))
+          modisIN%notSunlit = pack((/ (i, i = 1, Npoints ) /),mask = .not. cospgridIN%sunlit > 0)
+       endif
+    endif
+
+!    if (Lrttov_column) then
+!       rttovIN%nPoints    => Npoints
+!       rttovIN%nLevels    => cospIN%nLevels
+!       rttovIN%nSubCols   => cospIN%nColumns
+!       rttovIN%zenang     => cospgridIN%zenang
+!       rttovIN%co2        => cospgridIN%co2
+!       rttovIN%ch4        => cospgridIN%ch4
+!       rttovIN%n2o        => cospgridIN%n2o
+!       rttovIN%co         => cospgridIN%co
+!       rttovIN%surfem     => cospgridIN%emis_sfc
+!       rttovIN%h_surf     => cospgridIN%hgt_matrix_half(:,cospIN%Nlevels+1)
+!       rttovIN%u_surf     => cospgridIN%u_sfc
+!       rttovIN%v_surf     => cospgridIN%v_sfc
+!       rttovIN%t_skin     => cospgridIN%skt
+!       rttovIN%p_surf     => cospgridIN%phalf(:,cospIN%Nlevels+1)
+!       rttovIN%q2m        => cospgridIN%qv(:,cospIN%Nlevels)
+!       rttovIN%t2m        => cospgridIN%at(:,cospIN%Nlevels)
+!       rttovIN%lsmask     => cospgridIN%land
+!       rttovIN%latitude   => cospgridIN%lat
+!       rttovIN%longitude  => cospgridIN%lon
+!       rttovIN%seaice     => cospgridIN%seaice
+!       rttovIN%p          => cospgridIN%pfull
+!       rttovIN%ph         => cospgridIN%phalf
+!       rttovIN%t          => cospgridIN%at
+!       rttovIN%q          => cospgridIN%qv
+!       rttovIN%o3         => cospgridIN%o3
+       ! Below only needed for all-sky RTTOV calculation
+!       rttovIN%month      => cospgridIN%month
+!       rttovIN%tca        => cospgridIN%tca
+!       rttovIN%cldIce     => cospgridIN%cloudIce
+!       rttovIN%cldLiq     => cospgridIN%cloudLiq
+!       rttovIN%fl_rain    => cospgridIN%fl_rain
+!       rttovIN%fl_snow    => cospgridIN%fl_snow
+!    endif
+
+    !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+    ! 4) Call subcolumn simulators
+    !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+    ! ISCCP (icarus) subcolumn simulator
+    if (Lisccp_subcolumn .or. Lmodis_subcolumn) then
+       ! Allocate space for local variables
+       allocate(isccpLEVMATCH(Npoints,isccpIN%Ncolumns),                                 &
+                isccp_boxttop(Npoints,isccpIN%Ncolumns),                                 &
+                isccp_boxptop(Npoints,isccpIN%Ncolumns),                                 &
+                isccp_boxtau(Npoints,isccpIN%Ncolumns), isccp_meantbclr(Npoints))
+       ! Call simulator
+       call icarus_subcolumn(isccpIN%npoints,isccpIN%ncolumns,isccpIN%nlevels,           &
+                             isccpIN%sunlit,isccpIN%dtau,isccpIN%dem,isccpIN%skt,        &
+                             isccpIN%emsfc_lw,isccpIN%qv,isccpIN%at,isccpIN%pfull,       &
+                             isccpIN%phalf,isccpIN%frac_out,isccpLEVMATCH,               &
+                             isccp_boxtau(:,:),isccp_boxptop(:,:),                       &
+                             isccp_boxttop(:,:),isccp_meantbclr(:))
+       ! Store output (if requested)
+       if (associated(cospOUT%isccp_boxtau)) then
+          cospOUT%isccp_boxtau(ij:ik,:)  = isccp_boxtau
+       endif
+       if (associated(cospOUT%isccp_boxptop)) then
+          cospOUT%isccp_boxptop(ij:ik,:) = isccp_boxptop
+       endif
+       if (associated(cospOUT%isccp_meantbclr)) then
+          cospOUT%isccp_meantbclr(ij:ik) = isccp_meantbclr
+       endif
+   endif
+
+   ! MISR subcolumn simulator
+    if (Lmisr_subcolumn) then
+       ! Allocate space for local variables
+       allocate(misr_boxztop(Npoints,misrIN%Ncolumns),                                   &
+                misr_boxtau(Npoints,misrIN%Ncolumns),                                    &
+                misr_dist_model_layertops(Npoints,numMISRHgtBins))
+       ! Call simulator
+       call misr_subcolumn(misrIN%Npoints,misrIN%Ncolumns,misrIN%Nlevels,misrIN%dtau,    &
+                           misrIN%zfull,misrIN%at,misrIN%sunlit,misr_boxtau,             &
+                           misr_dist_model_layertops,misr_boxztop)
+       ! Store output (if requested)
+       if (associated(cospOUT%misr_dist_model_layertops)) then
+          cospOUT%misr_dist_model_layertops(ij:ik,:) = misr_dist_model_layertops
+       endif
+    endif
+
+    ! Calipso subcolumn simulator
+    if (Lcalipso_subcolumn) then
+       ! Allocate space for local variables
+       allocate(calipso_beta_mol(calipsoIN%Npoints,calipsoIN%Nlevels),                   &
+                calipso_beta_tot(calipsoIN%Npoints,calipsoIN%Ncolumns,calipsoIN%Nlevels),&
+                calipso_betaperp_tot(calipsoIN%Npoints,calipsoIN%Ncolumns,calipsoIN%Nlevels))
+       ! Call simulator
+       call lidar_subcolumn(calipsoIN%npoints, calipsoIN%ncolumns, calipsoIN%nlevels, .false., &
+            calipsoIN%beta_mol, calipsoIN%tau_mol, calipsoIN%betatot, calipsoIN%tautot,  &
+            calipso_beta_mol(:,:), calipso_beta_tot(:,:,:), calipsoIN%betatot_ice,       &
+            calipsoIN%tautot_ice, calipsoIN%betatot_liq, calipsoIN%tautot_liq,           &
+            calipso_betaperp_tot(:,:,:))
+       ! Store output (if requested)
+       if (associated(cospOUT%calipso_beta_mol))                                         &
+            cospOUT%calipso_beta_mol(ij:ik,calipsoIN%Nlevels:1:-1) = calipso_beta_mol
+       if (associated(cospOUT%calipso_beta_tot))                                         &
+            cospOUT%calipso_beta_tot(ij:ik,:,calipsoIN%Nlevels:1:-1) = calipso_beta_tot
+       if (associated(cospOUT%calipso_betaperp_tot))                                     &
+            cospOUT%calipso_betaperp_tot(ij:ik,:,:) = calipso_betaperp_tot
+    endif
+
+    ! GROUND LIDAR subcolumn simulator 
+    if (LgrLidar532_subcolumn) then  
+       ! Allocate space for local variables  
+       allocate(grLidar532_beta_mol(grLidar532IN%Npoints,grLidar532IN%Nlevels),       &  
+                grLidar532_beta_tot(grLidar532IN%Npoints,grLidar532IN%Ncolumns,grLidar532IN%Nlevels))
+       ! Call simulator  
+       call lidar_subcolumn(grLidar532IN%npoints, grLidar532IN%ncolumns, grLidar532IN%nlevels,&
+            .true., grLidar532IN%beta_mol, grLidar532IN%tau_mol, grLidar532IN%betatot,&
+            grLidar532IN%tautot, grLidar532_beta_mol(:,:), grLidar532_beta_tot(:,:,:))
+       ! Store output (if requested) 
+       if (associated(cospOUT%grLidar532_beta_mol))                                      & 
+            cospOUT%grLidar532_beta_mol(ij:ik,grLidar532IN%Nlevels:1:-1) = grLidar532_beta_mol 
+       if (associated(cospOUT%grLidar532_beta_tot))                                         & 
+            cospOUT%grLidar532_beta_tot(ij:ik,:,grLidar532IN%Nlevels:1:-1) = grLidar532_beta_tot 
+    endif 
+
+    ! ATLID subcolumn simulator
+    if (Latlid_subcolumn) then
+       ! Allocate space for local variables
+       allocate(atlid_beta_mol(atlidIN%Npoints,atlidIN%Nlevels),                      & 
+                atlid_beta_tot(atlidIN%Npoints,atlidIN%Ncolumns,atlidIN%Nlevels)) 
+       ! Call simulator 
+       call lidar_subcolumn(atlidIN%npoints, atlidIN%ncolumns, atlidIN%nlevels,&
+            .false., atlidIN%beta_mol_atlid, atlidIN%tau_mol_atlid, atlidIN%betatot_atlid,&
+            atlidIN%tautot_atlid, atlid_beta_mol(:,:), atlid_beta_tot(:,:,:))
+       ! Store output (if requested)
+       if (associated(cospOUT%atlid_beta_mol))                                        & 
+            cospOUT%atlid_beta_mol(ij:ik,atlidIN%Nlevels:1:-1) = atlid_beta_mol 
+       if (associated(cospOUT%atlid_beta_tot))                                        &
+            cospOUT%atlid_beta_tot(ij:ik,:,atlidIN%Nlevels:1:-1) = atlid_beta_tot   
+    endif
+
+    ! PARASOL subcolumn simulator
+    if (Lparasol_subcolumn) then
+       ! Allocate space for local variables
+       allocate(parasolPix_refl(parasolIN%Npoints,parasolIN%Ncolumns,PARASOL_NREFL))
+       ! Call simulator
+       do icol=1,parasolIN%Ncolumns
+          call parasol_subcolumn(parasolIN%npoints, PARASOL_NREFL,                       &
+                                 parasolIN%tautot_S_liq(1:parasolIN%Npoints,icol),       &
+                                 parasolIN%tautot_S_ice(1:parasolIN%Npoints,icol),       &
+                                 parasolPix_refl(:,icol,1:PARASOL_NREFL))
+          ! Store output (if requested)
+          if (associated(cospOUT%parasolPix_refl)) then
+             cospOUT%parasolPix_refl(ij:ik,icol,1:PARASOL_NREFL) =                          &
+                  parasolPix_refl(:,icol,1:PARASOL_NREFL)
+          endif
+       enddo
+    endif
+
+    ! Cloudsat (quickbeam) subcolumn simulator
+    if (Lcloudsat_subcolumn) then
+       ! Allocate space for local variables
+       allocate(cloudsatDBZe(cloudsatIN%Npoints,cloudsatIN%Ncolumns,cloudsatIN%Nlevels), &
+                cloudsatZe_non(cloudsatIN%Npoints,cloudsatIN%Ncolumns,cloudsatIN%Nlevels))
+       do icol=1,cloudsatIN%ncolumns
+          call quickbeam_subcolumn(cloudsatIN%rcfg,cloudsatIN%Npoints,cloudsatIN%Nlevels,&
+                                   cloudsatIN%hgt_matrix/1000._wp,                       &
+                                   cloudsatIN%z_vol(:,icol,:),                           &
+                                   cloudsatIN%kr_vol(:,icol,:),                          &
+                                   cloudsatIN%g_vol(:,1,:),cloudsatDBze(:,icol,:),cloudsatZe_non(:,icol,:))
+       enddo
+       ! Store output (if requested)
+       if (associated(cospOUT%cloudsat_Ze_tot)) then
+          cospOUT%cloudsat_Ze_tot(ij:ik,:,:) = cloudsatDBZe(:,:,1:cloudsatIN%Nlevels)
+       endif
+    endif
+
+    if (Lmodis_subcolumn) then
+       if(modisiN%nSunlit > 0) then
+          ! Allocate space for local variables
+          allocate(modisRetrievedTau(modisIN%nSunlit,modisIN%nColumns),                  &
+                   modisRetrievedSize(modisIN%nSunlit,modisIN%nColumns),                 &
+                   modisRetrievedPhase(modisIN%nSunlit,modisIN%nColumns),                &
+                   modisRetrievedCloudTopPressure(modisIN%nSunlit,modisIN%nColumns))
+          ! Call simulator
+          do i = 1, modisIN%nSunlit
+             call modis_subcolumn(modisIN%Ncolumns,modisIN%Nlevels,modisIN%pres(i,:),    &
+                                  modisIN%tau(int(modisIN%sunlit(i)),:,:),               &
+                                  modisIN%liqFrac(int(modisIN%sunlit(i)),:,:),           &
+                                  modisIN%g(int(modisIN%sunlit(i)),:,:),                 &
+                                  modisIN%w0(int(modisIN%sunlit(i)),:,:),                &
+                                  isccp_boxptop(int(modisIN%sunlit(i)),:),               &
+                                  modisRetrievedPhase(i,:),                              &
+                                  modisRetrievedCloudTopPressure(i,:),                   &
+                                  modisRetrievedTau(i,:),modisRetrievedSize(i,:))
+          end do
+       endif
+    endif
+
+    !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+    ! 5) Call column simulators
+    !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+    ! ISCCP
+    if (Lisccp_column) then
+       ! Check to see which outputs are requested. If not requested, use a local dummy array
+       if(.not. associated(cospOUT%isccp_meanalbedocld)) then
+          allocate(out1D_1(Npoints))
+          cospOUT%isccp_meanalbedocld(ij:ik) => out1D_1
+       endif
+       if(.not. associated(cospOUT%isccp_meanptop)) then
+          allocate(out1D_2(Npoints))
+          cospOUT%isccp_meanptop(ij:ik) => out1D_2
+       endif
+       if(.not. associated(cospOUT%isccp_meantaucld)) then
+          allocate(out1D_3(Npoints))
+          cospOUT%isccp_meantaucld(ij:ik) => out1D_3
+       endif
+       if(.not. associated(cospOUT%isccp_totalcldarea)) then
+          allocate(out1D_4(Npoints))
+          cospOUT%isccp_totalcldarea(ij:ik) => out1D_4
+       endif
+       if(.not. associated(cospOUT%isccp_meantb)) then
+          allocate(out1D_5(Npoints))
+          cospOUT%isccp_meantb(ij:ik) => out1D_5
+       endif
+       if(.not. associated(cospOUT%isccp_fq)) then
+          allocate(out1D_6(Npoints*numISCCPTauBins*numISCCPPresBins))
+          cospOUT%isccp_fq(ij:ik,1:numISCCPTauBins,1:numISCCPPresBins) => out1D_6
+       endif
+
+       ! Call simulator
+       call icarus_column(isccpIN%npoints, isccpIN%ncolumns,isccp_boxtau(:,:),           &
+                          isccp_boxptop(:,:)/100._wp, isccpIN%sunlit,isccp_boxttop,      &
+                          cospOUT%isccp_fq(ij:ik,:,:),                                   &
+                          cospOUT%isccp_meanalbedocld(ij:ik),                            &
+                          cospOUT%isccp_meanptop(ij:ik),cospOUT%isccp_meantaucld(ij:ik), &
+                          cospOUT%isccp_totalcldarea(ij:ik),cospOUT%isccp_meantb(ij:ik))
+       cospOUT%isccp_fq(ij:ik,:,:) = cospOUT%isccp_fq(ij:ik,:,7:1:-1)
+
+       ! Check if there is any value slightly greater than 1
+       where ((cospOUT%isccp_totalcldarea > 1.0-1.e-5) .and.                             &
+              (cospOUT%isccp_totalcldarea < 1.0+1.e-5))
+              cospOUT%isccp_totalcldarea = 1.0
+       endwhere
+
+       ! Clear up memory (if necessary)
+       if (allocated(isccp_boxttop))   deallocate(isccp_boxttop)
+       if (allocated(isccp_boxptop))   deallocate(isccp_boxptop)
+       if (allocated(isccp_boxtau))    deallocate(isccp_boxtau)
+       if (allocated(isccp_meantbclr)) deallocate(isccp_meantbclr)
+       if (allocated(isccpLEVMATCH))   deallocate(isccpLEVMATCH)
+       if (allocated(out1D_1)) then
+          deallocate(out1D_1)
+          nullify(cospOUT%isccp_meanalbedocld)
+       endif
+       if (allocated(out1D_2)) then
+          deallocate(out1D_2)
+          nullify(cospOUT%isccp_meanptop)
+       endif
+       if (allocated(out1D_3)) then
+          deallocate(out1D_3)
+          nullify(cospOUT%isccp_meantaucld)
+       endif
+       if (allocated(out1D_4)) then
+          deallocate(out1D_4)
+          nullify(cospOUT%isccp_totalcldarea)
+       endif
+       if (allocated(out1D_5)) then
+          deallocate(out1D_5)
+          nullify(cospOUT%isccp_meantb)
+       endif
+       if (allocated(out1D_6)) then
+          deallocate(out1D_6)
+          nullify(cospOUT%isccp_fq)
+       endif
+    endif
+
+    ! MISR
+    if (Lmisr_column) then
+       ! Check to see which outputs are requested. If not requested, use a local dummy array
+       if (.not. associated(cospOUT%misr_cldarea)) then
+          allocate(out1D_1(Npoints))
+          cospOUT%misr_cldarea(ij:ik) => out1D_1
+       endif
+       if (.not. associated(cospOUT%misr_meanztop)) then
+          allocate(out1D_2(Npoints))
+          cospOUT%misr_meanztop(ij:ik) => out1D_2
+       endif
+       if (.not. associated(cospOUT%misr_fq)) then
+          allocate(out1D_3(Npoints*numMISRTauBins*numMISRHgtBins))
+          cospOUT%misr_fq(ij:ik,1:numMISRTauBins,1:numMISRHgtBins) => out1D_3
+        endif
+
+       ! Call simulator
+        call misr_column(misrIN%Npoints,misrIN%Ncolumns,misr_boxztop,misrIN%sunlit,&
+                         misr_boxtau,cospOUT%misr_cldarea(ij:ik),                  &
+                         cospOUT%misr_meanztop(ij:ik),cospOUT%misr_fq(ij:ik,:,:))
+
+       ! Clear up memory
+       if (allocated(misr_boxtau))               deallocate(misr_boxtau)
+       if (allocated(misr_boxztop))              deallocate(misr_boxztop)
+       if (allocated(misr_dist_model_layertops)) deallocate(misr_dist_model_layertops)
+       if (allocated(out1D_1)) then
+          deallocate(out1D_1)
+          nullify(cospOUT%misr_cldarea)
+       endif
+       if (allocated(out1D_2)) then
+          deallocate(out1D_2)
+          nullify(cospOUT%misr_meanztop)
+       endif
+       if (allocated(out1D_3)) then
+          deallocate(out1D_3)
+          nullify(cospOUT%misr_fq)
+       endif
+    endif
+
+    ! CALIPSO LIDAR Simulator
+    if (Lcalipso_column) then
+       ! Check to see which outputs are requested. If not requested, use a local dummy array
+       if (.not. associated(cospOUT%calipso_cfad_sr)) then
+          allocate(out1D_1(Npoints*SR_BINS*Nlvgrid))
+          cospOUT%calipso_cfad_sr(ij:ik,1:SR_BINS,1:Nlvgrid) => out1D_1
+       endif
+       if (.not. associated(cospOUT%calipso_lidarcld)) then
+          allocate(out1D_2(Npoints*Nlvgrid))
+          cospOUT%calipso_lidarcld(ij:ik,1:Nlvgrid) => out1D_2
+       endif
+       if (.not. associated(cospOUT%calipso_lidarcldphase)) then
+          allocate(out1D_3(Npoints*Nlvgrid*6))
+          cospOUT%calipso_lidarcldphase(ij:ik,1:Nlvgrid,1:6) => out1D_3
+       endif
+       if (.not. associated(cospOUT%calipso_cldlayer)) then
+          allocate(out1D_4(Npoints*LIDAR_NCAT))
+          cospOUT%calipso_cldlayer(ij:ik,1:LIDAR_NCAT) => out1D_4
+       endif
+       if (.not. associated(cospOUT%calipso_cldlayerphase)) then
+          allocate(out1D_5(Npoints*LIDAR_NCAT*6))
+          cospOUT%calipso_cldlayerphase(ij:ik,1:LIDAR_NCAT,1:6) => out1D_5
+       endif
+       if (.not. associated(cospOUT%calipso_lidarcldtmp)) then
+          allocate(out1D_6(Npoints*40*5))
+          cospOUT%calipso_lidarcldtmp(ij:ik,1:40,1:5) => out1D_6
+       endif   
+       if (.not. associated(cospOUT%calipso_lidarcldtype)) then
+          allocate(out1D_7(Npoints*Nlvgrid*4))
+          cospOUT%calipso_lidarcldtype(ij:ik,1:Nlvgrid,1:4) => out1D_7
+       endif
+       if (.not. associated(cospOUT%calipso_cldtype)) then 
+          allocate(out1D_8(Npoints*LIDAR_NTYPE)) 
+          cospOUT%calipso_cldtype(ij:ik,1:LIDAR_NTYPE) => out1D_8  
+       endif 
+       if (.not. associated(cospOUT%calipso_cldtypetemp)) then 
+          allocate(out1D_9(Npoints*LIDAR_NTYPE))  
+          cospOUT%calipso_cldtypetemp(ij:ik,1:LIDAR_NTYPE) => out1D_9 
+       endif 
+       if (.not. associated(cospOUT%calipso_cldtypemeanz)) then 
+          allocate(out1D_10(Npoints*2))
+          cospOUT%calipso_cldtypemeanz(ij:ik,1:2) => out1D_10 
+       endif 
+       if (.not. associated(cospOUT%calipso_cldtypemeanzse)) then
+          allocate(out1D_12(Npoints*3)) 
+          cospOUT%calipso_cldtypemeanzse(ij:ik,1:3) => out1D_12
+       endif
+       if (.not. associated(cospOUT%calipso_cldthinemis)) then
+          allocate(out1D_11(Npoints)) 
+          cospOUT%calipso_cldthinemis(ij:ik) => out1D_11 
+       endif
+       
+       ! Call simulator
+       ok_lidar_cfad=.true.
+       call lidar_column(calipsoIN%Npoints, calipsoIN%Ncolumns, calipsoIN%Nlevels,       &
+            Nlvgrid, SR_BINS, LIDAR_NTYPE, 'calipso',calipso_beta_tot(:,:,:), calipso_beta_mol(:,:),&
+            cospgridIN%phalf(:,2:calipsoIN%Nlevels),cospgridIN%hgt_matrix,               &
+            cospgridIN%hgt_matrix_half, vgrid_z(:), ok_lidar_cfad, LIDAR_NCAT,           &
+            cospOUT%calipso_cfad_sr(ij:ik,:,:), cospOUT%calipso_lidarcld(ij:ik,:),       &
+            cospOUT%calipso_cldlayer(ij:ik,:),                                           &
+            cospgridIN%at(:,:), calipso_betaperp_tot(:,:,:), cospgridIN%surfelev,        & 
+            cospOUT%calipso_lidarcldphase(ij:ik,:,:),                       &
+            cospOUT%calipso_lidarcldtype(ij:ik,:,:),  cospOUT%calipso_cldtype(ij:ik,:),  &
+            cospOUT%calipso_cldtypetemp(ij:ik,:), cospOUT%calipso_cldtypemeanz(ij:ik,:), & 
+            cospOUT%calipso_cldtypemeanzse(ij:ik,:), cospOUT%calipso_cldthinemis(ij:ik), &
+            cospOUT%calipso_cldlayerphase(ij:ik,:,:), cospOUT%calipso_lidarcldtmp(ij:ik,:,:))
+
+         if (associated(cospOUT%calipso_srbval)) cospOUT%calipso_srbval = calipso_histBsct
+
+       ! Free up memory (if necessary)
+       if (allocated(out1D_1)) then
+          deallocate(out1D_1)
+          nullify(cospOUT%calipso_cfad_sr)
+       endif
+       if (allocated(out1D_2)) then
+          deallocate(out1D_2)
+          nullify(cospOUT%calipso_lidarcld)
+       endif
+       if (allocated(out1D_3)) then
+          deallocate(out1D_3)
+          nullify(cospOUT%calipso_lidarcldphase)
+       endif
+       if (allocated(out1D_4)) then
+          deallocate(out1D_4)
+          nullify(cospOUT%calipso_cldlayer)
+       endif
+       if (allocated(out1D_5)) then
+          deallocate(out1D_5)
+          nullify(cospOUT%calipso_cldlayerphase)
+       endif
+       if (allocated(out1D_6)) then
+          deallocate(out1D_6)
+          nullify(cospOUT%calipso_lidarcldtmp)
+       endif
+       if (allocated(out1D_7)) then
+          deallocate(out1D_7)  
+          nullify(cospOUT%calipso_lidarcldtype)
+       endif  
+       if (allocated(out1D_8)) then
+          deallocate(out1D_8)
+          nullify(cospOUT%calipso_cldtype)
+       endif 
+       if (allocated(out1D_9)) then 
+          deallocate(out1D_9) 
+          nullify(cospOUT%calipso_cldtypetemp)
+       endif 
+       if (allocated(out1D_10)) then 
+          deallocate(out1D_10)
+          nullify(cospOUT%calipso_cldtypemeanz)
+       endif 
+       if (allocated(out1D_12)) then 
+          deallocate(out1D_12) 
+          nullify(cospOUT%calipso_cldtypemeanzse)
+       endif 
+       if (allocated(out1D_11)) then 
+          deallocate(out1D_11) 
+          nullify(cospOUT%calipso_cldthinemis)
+       endif
+
+    endif
+
+    ! GROUND LIDAR Simulator
+    if (LgrLidar532_column) then
+       ! Check to see which outputs are requested. If not requested, use a local dummy array
+       if (.not. associated(cospOUT%grLidar532_cfad_sr)) then
+          allocate(out1D_1(Npoints*SR_BINS*Nlvgrid)) 
+          cospOUT%grLidar532_cfad_sr(ij:ik,1:SR_BINS,1:Nlvgrid) => out1D_1
+       endif 
+       if (.not. associated(cospOUT%grLidar532_lidarcld)) then
+          allocate(out1D_2(Npoints*Nlvgrid)) 
+          cospOUT%grLidar532_lidarcld(ij:ik,1:Nlvgrid) => out1D_2
+       endif
+       if (.not. associated(cospOUT%grLidar532_cldlayer)) then
+          allocate(out1D_3(Npoints*LIDAR_NCAT))
+          cospOUT%grLidar532_cldlayer(ij:ik,1:LIDAR_NCAT) => out1D_3
+       endif
+       
+       ! Call simulator 
+       ok_lidar_cfad_grLidar532=.true.
+       call lidar_column(grLidar532IN%Npoints, grLidar532IN%Ncolumns, grLidar532IN%Nlevels,       &
+            Nlvgrid, SR_BINS, LIDAR_NTYPE, 'grlidar532',grLidar532_beta_tot(:,:,:), grLidar532_beta_mol(:,:),&
+            cospgridIN%phalf(:,2:grLidar532IN%Nlevels),cospgridIN%hgt_matrix,               &
+            cospgridIN%hgt_matrix_half, vgrid_z(:), ok_lidar_cfad_grLidar532, LIDAR_NCAT,      &
+            cospOUT%grLidar532_cfad_sr(ij:ik,:,:), cospOUT%grLidar532_lidarcld(ij:ik,:),       &
+            cospOUT%grLidar532_cldlayer(ij:ik,:))
+
+       if (associated(cospOUT%grLidar532_srbval)) cospOUT%grLidar532_srbval = grLidar532_histBsct
+
+       ! Free up memory (if necessary) 
+       if (allocated(out1D_1)) then
+          deallocate(out1D_1)
+          nullify(cospOUT%grLidar532_cfad_sr)
+       endif 
+       if (allocated(out1D_2)) then
+          deallocate(out1D_2)
+          nullify(cospOUT%grLidar532_lidarcld)
+       endif 
+       if (allocated(out1D_3)) then
+          deallocate(out1D_3)
+          nullify(cospOUT%grLidar532_cldlayer)
+       endif
+
+    endif
+
+    ! ATLID Simulator
+    if (Latlid_column) then
+       ! Check to see which outputs are requested. If not requested, use a local dummy array
+       if (.not. associated(cospOUT%atlid_cfad_sr)) then
+          allocate(out1D_1(Npoints*SR_BINS*Nlvgrid))
+          cospOUT%atlid_cfad_sr(ij:ik,1:SR_BINS,1:Nlvgrid) => out1D_1
+       endif                                    
+       if (.not. associated(cospOUT%atlid_lidarcld)) then 
+          allocate(out1D_2(Npoints*Nlvgrid))                 
+          cospOUT%atlid_lidarcld(ij:ik,1:Nlvgrid) => out1D_2 
+       endif                                                   
+       if (.not. associated(cospOUT%atlid_cldlayer)) then   
+          allocate(out1D_3(Npoints*LIDAR_NCAT))                 
+          cospOUT%atlid_cldlayer(ij:ik,1:LIDAR_NCAT) => out1D_3 
+       endif                                                      
+       
+       ! Call simulator                                                             
+       ok_lidar_cfad_atlid=.true.
+       call lidar_column(atlidIN%Npoints, atlidIN%Ncolumns, atlidIN%Nlevels,       &
+            Nlvgrid, SR_BINS, LIDAR_NTYPE, 'atlid',atlid_beta_tot(:,:,:),     &
+            atlid_beta_mol(:,:), cospgridIN%phalf(:,2:atlidIN%Nlevels),            &
+            cospgridIN%hgt_matrix, cospgridIN%hgt_matrix_half, vgrid_z(:),         &
+            ok_lidar_cfad_atlid, LIDAR_NCAT, cospOUT%atlid_cfad_sr(ij:ik,:,:),     &
+            cospOUT%atlid_lidarcld(ij:ik,:), cospOUT%atlid_cldlayer(ij:ik,:))
+       
+       if (associated(cospOUT%atlid_srbval)) cospOUT%atlid_srbval = atlid_histBsct 
+
+       ! Free up memory (if necessary)        
+       if (allocated(out1D_1)) then           
+          deallocate(out1D_1)                 
+          nullify(cospOUT%atlid_cfad_sr)
+       endif                                  
+       if (allocated(out1D_2)) then          
+          deallocate(out1D_2)                
+          nullify(cospOUT%atlid_lidarcld)
+       endif                                  
+       if (allocated(out1D_3)) then          
+          deallocate(out1D_3)
+          nullify(cospOUT%atlid_cldlayer)
+       endif          
+
+    endif
+
+    ! PARASOL
+    if (Lparasol_column) then
+       call parasol_column(parasolIN%Npoints,PARASOL_NREFL,parasolIN%Ncolumns,           &
+                            cospgridIN%land(:),parasolPix_refl(:,:,:),                   &
+                            cospOUT%parasolGrid_refl(ij:ik,:))
+       if (allocated(parasolPix_refl)) deallocate(parasolPix_refl)
+    endif
+
+    ! CLOUDSAT
+    if (Lcloudsat_column) then
+       ! Check to see which outputs are requested. If not requested, use a local dummy array
+       if (.not. associated(cospOUT%cloudsat_cfad_ze)) then
+          allocate(out1D_1(Npoints*cloudsat_DBZE_BINS*Nlvgrid))
+          cospOUT%cloudsat_cfad_ze(ij:ik,1:cloudsat_DBZE_BINS,1:Nlvgrid) => out1D_1
+       endif
+
+       if (.not. associated(cospOUT%cloudsat_pia)) then
+          allocate(out1D_2(Npoints))
+          cospOUT%cloudsat_pia(ij:ik) => out1D_2
+       endif
+       if (.not. associated(cospOUT%cloudsat_precip_cover)) then
+          allocate(out1D_3(Npoints*nCloudsatPrecipClass))
+          cospOUT%cloudsat_precip_cover(ij:ik,1:nCloudsatPrecipClass) => out1D_3
+       endif
+          
+       ! Call simulator
+       call quickbeam_column(cloudsatIN%Npoints, cloudsatIN%Ncolumns, cloudsatIN%Nlevels,&
+            Nlvgrid, cloudsat_DBZE_BINS, 'cloudsat', cloudsatDBZe, cloudsatZe_non,       &
+!            cospgridIN%land(:), cospgridIN%at(:,cospIN%Nlevels), cospIN%fracPrecipIce,   & !PREC_BUG
+!            cospgridIN%hgt_matrix, cospgridIN%hgt_matrix_half,                           & !PREC_BUG
+            cospgridIN%land(:), cospgridIN%surfelev(:), cospgridIN%at(:,cospIN%Nlevels), & !PREC_BUG
+	    cospIN%fracPrecipIce, cospgridIN%hgt_matrix, cospgridIN%hgt_matrix_half,     & !PREC_BUG
+            cospOUT%cloudsat_cfad_ze(ij:ik,:,:), cospOUT%cloudsat_precip_cover,          &
+            cospOUT%cloudsat_pia)
+       ! Free up memory  (if necessary)
+       if (allocated(out1D_1)) then
+          deallocate(out1D_1)
+          nullify(cospOUT%cloudsat_cfad_ze)
+       endif
+       if (allocated(out1D_2)) then
+          deallocate(out1D_2)
+          nullify(cospOUT%cloudsat_pia)
+       endif
+       if (allocated(out1D_3)) then
+          deallocate(out1D_3)
+          nullify(cospOUT%cloudsat_precip_cover)
+       endif
+    endif
+
+    ! MODIS
+    if (Lmodis_column) then
+       if(modisiN%nSunlit > 0) then
+          ! Allocate space for local variables
+          allocate(modisCftotal(modisIN%nSunlit), modisCfLiquid(modisIN%nSunlit),        &
+                   modisCfIce(modisIN%nSunlit),modisCfHigh(modisIN%nSunlit),             &
+                   modisCfMid(modisIN%nSunlit),modisCfLow(modisIN%nSunlit),              &
+                   modisMeanTauTotal(modisIN%nSunlit),                                   &
+                   modisMeanTauLiquid(modisIN%nSunlit),modisMeanTauIce(modisIN%nSunlit), &
+                   modisMeanLogTauTotal(modisIN%nSunlit),                                &
+                   modisMeanLogTauLiquid(modisIN%nSunlit),                               &
+                   modisMeanLogTauIce(modisIN%nSunlit),                                  &
+                   modisMeanSizeLiquid(modisIN%nSunlit),                                 &
+                   modisMeanSizeIce(modisIN%nSunlit),                                    &
+                   modisMeanCloudTopPressure(modisIN%nSunlit),                           &
+                   modisMeanLiquidWaterPath(modisIN%nSunlit),                            &
+                   modisMeanIceWaterPath(modisIN%nSunlit),                               &
+                   modisJointHistogram(modisIN%nSunlit,numMODISTauBins,numMODISPresBins),&
+                   modisJointHistogramIce(modisIN%nSunlit,numModisTauBins,numMODISReffIceBins),&
+                   modisJointHistogramLiq(modisIN%nSunlit,numModisTauBins,numMODISReffLiqBins))
+          ! Call simulator
+          call modis_column(modisIN%nSunlit, modisIN%Ncolumns,modisRetrievedPhase,       &
+                             modisRetrievedCloudTopPressure,modisRetrievedTau,           &
+                             modisRetrievedSize, modisCfTotal, modisCfLiquid, modisCfIce,&
+                             modisCfHigh, modisCfMid, modisCfLow, modisMeanTauTotal,     &
+                             modisMeanTauLiquid, modisMeanTauIce, modisMeanLogTauTotal,  &
+                             modisMeanLogTauLiquid, modisMeanLogTauIce,                  &
+                             modisMeanSizeLiquid, modisMeanSizeIce,                      &
+                             modisMeanCloudTopPressure, modisMeanLiquidWaterPath,        &
+                             modisMeanIceWaterPath, modisJointHistogram,                 &
+                             modisJointHistogramIce,modisJointHistogramLiq)
+          ! Store data (if requested)
+          if (associated(cospOUT%modis_Cloud_Fraction_Total_Mean)) then
+             cospOUT%modis_Cloud_Fraction_Total_Mean(ij+int(modisIN%sunlit(:))-1)   =    &
+                  modisCfTotal
+          endif
+          if (associated(cospOUT%modis_Cloud_Fraction_Water_Mean)) then
+             cospOUT%modis_Cloud_Fraction_Water_Mean(ij+int(modisIN%sunlit(:))-1)   =    &
+                  modisCfLiquid
+          endif
+          if (associated(cospOUT%modis_Cloud_Fraction_Ice_Mean)) then
+             cospOUT%modis_Cloud_Fraction_Ice_Mean(ij+int(modisIN%sunlit(:))-1)     =    &
+                  modisCfIce
+          endif
+          if (associated(cospOUT%modis_Cloud_Fraction_High_Mean)) then
+             cospOUT%modis_Cloud_Fraction_High_Mean(ij+int(modisIN%sunlit(:))-1)    =    &
+                  modisCfHigh
+          endif
+          if (associated(cospOUT%modis_Cloud_Fraction_Mid_Mean)) then
+             cospOUT%modis_Cloud_Fraction_Mid_Mean(ij+int(modisIN%sunlit(:))-1)     =    &
+                  modisCfMid
+          endif
+          if (associated(cospOUT%modis_Cloud_Fraction_Low_Mean)) then
+             cospOUT%modis_Cloud_Fraction_Low_Mean(ij+int(modisIN%sunlit(:))-1)     =    &
+                  modisCfLow
+          endif
+          if (associated(cospOUT%modis_Optical_Thickness_Total_Mean)) then
+             cospOUT%modis_Optical_Thickness_Total_Mean(ij+int(modisIN%sunlit(:))-1) =   &
+                  modisMeanTauTotal
+          endif
+          if (associated(cospOUT%modis_Optical_Thickness_Water_Mean)) then
+             cospOUT%modis_Optical_Thickness_Water_Mean(ij+int(modisIN%sunlit(:))-1) =   &
+                  modisMeanTauLiquid
+          endif
+          if (associated(cospOUT%modis_Optical_Thickness_Ice_Mean)) then
+             cospOUT%modis_Optical_Thickness_Ice_Mean(ij+int(modisIN%sunlit(:))-1)  =    &
+                  modisMeanTauIce
+          endif
+          if (associated(cospOUT%modis_Optical_Thickness_Total_LogMean)) then
+             cospOUT%modis_Optical_Thickness_Total_LogMean(ij+int(modisIN%sunlit(:))-1)= &
+                  modisMeanLogTauTotal
+          endif
+          if (associated(cospOUT%modis_Optical_Thickness_Water_LogMean)) then
+             cospOUT%modis_Optical_Thickness_Water_LogMean(ij+int(modisIN%sunlit(:))-1) = &
+                  modisMeanLogTauLiquid
+          endif
+          if (associated(cospOUT%modis_Optical_Thickness_Ice_LogMean)) then
+             cospOUT%modis_Optical_Thickness_Ice_LogMean(ij+int(modisIN%sunlit(:))-1) =  &
+                  modisMeanLogTauIce
+          endif
+          if (associated(cospOUT%modis_Cloud_Particle_Size_Water_Mean)) then
+             cospOUT%modis_Cloud_Particle_Size_Water_Mean(ij+int(modisIN%sunlit(:))-1) = &
+                  modisMeanSizeLiquid
+          endif
+          if (associated(cospOUT%modis_Cloud_Particle_Size_Ice_Mean)) then
+             cospOUT%modis_Cloud_Particle_Size_Ice_Mean(ij+int(modisIN%sunlit(:))-1) =   &
+                  modisMeanSizeIce
+          endif
+          if (associated(cospOUT%modis_Cloud_Top_Pressure_Total_Mean)) then
+             cospOUT%modis_Cloud_Top_Pressure_Total_Mean(ij+int(modisIN%sunlit(:))-1) =  &
+                  modisMeanCloudTopPressure
+          endif
+          if (associated(cospOUT%modis_Liquid_Water_Path_Mean)) then
+             cospOUT%modis_Liquid_Water_Path_Mean(ij+int(modisIN%sunlit(:))-1)      =    &
+                  modisMeanLiquidWaterPath
+          endif
+          if (associated(cospOUT%modis_Ice_Water_Path_Mean)) then
+              cospOUT%modis_Ice_Water_Path_Mean(ij+int(modisIN%sunlit(:))-1)         =   &
+                  modisMeanIceWaterPath
+          endif
+          if (associated(cospOUT%modis_Optical_Thickness_vs_Cloud_Top_Pressure)) then
+             cospOUT%modis_Optical_Thickness_vs_Cloud_Top_Pressure(ij+            &
+                  int(modisIN%sunlit(:))-1, 1:numModisTauBins, :) = modisJointHistogram(:, :, :)
+             ! Reorder pressure bins in joint histogram to go from surface to TOA
+             cospOUT%modis_Optical_Thickness_vs_Cloud_Top_Pressure(ij:ik,:,:) = &
+                  cospOUT%modis_Optical_Thickness_vs_Cloud_Top_Pressure(ij:ik,:,numMODISPresBins:1:-1)
+          endif
+          if (associated(cospOUT%modis_Optical_Thickness_vs_ReffIce)) then
+             cospOUT%modis_Optical_Thickness_vs_ReffIce(ij+int(modisIN%sunlit(:))-1, 1:numMODISTauBins,:) = &
+                modisJointHistogramIce(:,:,:)
+          endif
+          if (associated(cospOUT%modis_Optical_Thickness_vs_ReffLiq)) then
+             cospOUT%modis_Optical_Thickness_vs_ReffLiq(ij+int(modisIN%sunlit(:))-1, 1:numMODISTauBins,:) = &
+                modisJointHistogramLiq(:,:,:)
+          endif
+
+          if(modisIN%nSunlit < modisIN%Npoints) then
+             ! Where it's night and we haven't done the retrievals the values are undefined
+             if (associated(cospOUT%modis_Cloud_Fraction_Total_Mean))                    &
+                cospOUT%modis_Cloud_Fraction_Total_Mean(ij+int(modisIN%notSunlit(:))-1) = R_UNDEF
+             if (associated(cospOUT%modis_Cloud_Fraction_Water_Mean))                    &
+                cospOUT%modis_Cloud_Fraction_Water_Mean(ij+int(modisIN%notSunlit(:))-1) = R_UNDEF
+             if (associated(cospOUT%modis_Cloud_Fraction_Ice_Mean))                      &
+                cospOUT%modis_Cloud_Fraction_Ice_Mean(ij+int(modisIN%notSunlit(:))-1) = R_UNDEF
+             if (associated(cospOUT%modis_Cloud_Fraction_High_Mean))                     &
+                cospOUT%modis_Cloud_Fraction_High_Mean(ij+int(modisIN%notSunlit(:))-1) = R_UNDEF
+             if (associated(cospOUT%modis_Cloud_Fraction_Mid_Mean))                      &
+                cospOUT%modis_Cloud_Fraction_Mid_Mean(ij+int(modisIN%notSunlit(:))-1) = R_UNDEF
+             if (associated(cospOUT%modis_Cloud_Fraction_Low_Mean))                      &
+                cospOUT%modis_Cloud_Fraction_Low_Mean(ij+int(modisIN%notSunlit(:))-1) = R_UNDEF
+             if (associated(cospOUT%modis_Optical_Thickness_Total_Mean))                 &
+                cospOUT%modis_Optical_Thickness_Total_Mean(ij+int(modisIN%notSunlit(:))-1) = R_UNDEF
+             if (associated(cospOUT%modis_Optical_Thickness_Water_Mean))                 &
+                cospOUT%modis_Optical_Thickness_Water_Mean(ij+int(modisIN%notSunlit(:))-1) = R_UNDEF
+             if (associated(cospOUT%modis_Optical_Thickness_Ice_Mean))                   &
+                cospOUT%modis_Optical_Thickness_Ice_Mean(ij+int(modisIN%notSunlit(:))-1) = R_UNDEF
+             if (associated(cospOUT%modis_Optical_Thickness_Total_LogMean))              &
+                cospOUT%modis_Optical_Thickness_Total_LogMean(ij+int(modisIN%notSunlit(:))-1) = R_UNDEF
+             if (associated(cospOUT%modis_Optical_Thickness_Water_LogMean))              &
+                cospOUT%modis_Optical_Thickness_Water_LogMean(ij+int(modisIN%notSunlit(:))-1) = R_UNDEF
+             if (associated(cospOUT%modis_Optical_Thickness_Ice_LogMean))                &
+                cospOUT%modis_Optical_Thickness_Ice_LogMean(ij+int(modisIN%notSunlit(:))-1) = R_UNDEF
+             if (associated(cospOUT%modis_Cloud_Particle_Size_Water_Mean))               &
+                cospOUT%modis_Cloud_Particle_Size_Water_Mean(ij+int(modisIN%notSunlit(:))-1) = R_UNDEF
+             if (associated(cospOUT%modis_Cloud_Particle_Size_Ice_Mean))                 &
+                cospOUT%modis_Cloud_Particle_Size_Ice_Mean(ij+int(modisIN%notSunlit(:))-1) = R_UNDEF
+             if (associated(cospOUT%modis_Cloud_Top_Pressure_Total_Mean))                &
+                cospOUT%modis_Cloud_Top_Pressure_Total_Mean(ij+int(modisIN%notSunlit(:))-1) = R_UNDEF
+             if (associated(cospOUT%modis_Liquid_Water_Path_Mean))                       &
+                cospOUT%modis_Liquid_Water_Path_Mean(ij+int(modisIN%notSunlit(:))-1) = R_UNDEF
+             if (associated(cospOUT%modis_Ice_Water_Path_Mean))                          &
+                cospOUT%modis_Ice_Water_Path_Mean(ij+int(modisIN%notSunlit(:))-1) = R_UNDEF
+             if (associated(cospOUT%modis_Optical_Thickness_vs_Cloud_Top_Pressure))      &
+                cospOUT%modis_Optical_Thickness_vs_Cloud_Top_Pressure(ij+int(modisIN%notSunlit(:))-1, :, :) = R_UNDEF
+          end if
+       else
+          ! It's nightime everywhere - everything is undefined
+          if (associated(cospOUT%modis_Cloud_Fraction_Total_Mean))                       &
+             cospOUT%modis_Cloud_Fraction_Total_Mean(ij:ik) = R_UNDEF
+          if (associated(cospOUT%modis_Cloud_Fraction_Water_Mean))                       &
+             cospOUT%modis_Cloud_Fraction_Water_Mean(ij:ik) = R_UNDEF
+          if (associated(cospOUT%modis_Cloud_Fraction_Ice_Mean))                         &
+             cospOUT%modis_Cloud_Fraction_Ice_Mean(ij:ik) = R_UNDEF
+          if (associated(cospOUT%modis_Cloud_Fraction_High_Mean))                        &
+             cospOUT%modis_Cloud_Fraction_High_Mean(ij:ik) = R_UNDEF
+          if (associated(cospOUT%modis_Cloud_Fraction_Mid_Mean))                         &
+             cospOUT%modis_Cloud_Fraction_Mid_Mean(ij:ik) = R_UNDEF
+          if (associated(cospOUT%modis_Cloud_Fraction_Low_Mean))                         &
+             cospOUT%modis_Cloud_Fraction_Low_Mean(ij:ik) = R_UNDEF
+          if (associated(cospOUT%modis_Optical_Thickness_Total_Mean))                    &
+             cospOUT%modis_Optical_Thickness_Total_Mean(ij:ik) = R_UNDEF
+          if (associated(cospOUT%modis_Optical_Thickness_Water_Mean))                    &
+             cospOUT%modis_Optical_Thickness_Water_Mean(ij:ik) = R_UNDEF
+          if (associated(cospOUT%modis_Optical_Thickness_Ice_Mean))                      &
+             cospOUT%modis_Optical_Thickness_Ice_Mean(ij:ik) = R_UNDEF
+          if (associated(cospOUT%modis_Optical_Thickness_Total_LogMean))                 &
+             cospOUT%modis_Optical_Thickness_Total_LogMean(ij:ik) = R_UNDEF
+          if (associated(cospOUT%modis_Optical_Thickness_Water_LogMean))                 &
+             cospOUT%modis_Optical_Thickness_Water_LogMean(ij:ik) = R_UNDEF
+          if (associated(cospOUT%modis_Optical_Thickness_Ice_LogMean))                   &
+             cospOUT%modis_Optical_Thickness_Ice_LogMean(ij:ik) = R_UNDEF
+          if (associated(cospOUT%modis_Cloud_Particle_Size_Water_Mean))                  &
+             cospOUT%modis_Cloud_Particle_Size_Water_Mean(ij:ik) = R_UNDEF
+          if (associated(cospOUT%modis_Cloud_Particle_Size_Ice_Mean))                    &
+              cospOUT%modis_Cloud_Particle_Size_Ice_Mean(ij:ik) = R_UNDEF
+          if (associated(cospOUT%modis_Cloud_Top_Pressure_Total_Mean))                   &
+             cospOUT%modis_Cloud_Top_Pressure_Total_Mean(ij:ik) = R_UNDEF
+          if (associated(cospOUT%modis_Liquid_Water_Path_Mean))                          &
+             cospOUT%modis_Liquid_Water_Path_Mean(ij:ik) = R_UNDEF
+          if (associated(cospOUT%modis_Ice_Water_Path_Mean))                             &
+             cospOUT%modis_Ice_Water_Path_Mean(ij:ik) = R_UNDEF
+          if (associated(cospOUT%modis_Optical_Thickness_vs_Cloud_Top_Pressure))         &
+             cospOUT%modis_Optical_Thickness_vs_Cloud_Top_Pressure(ij:ik, :, :) = R_UNDEF
+       endif
+       ! Free up memory (if necessary)
+       if (allocated(modisRetrievedTau))               deallocate(modisRetrievedTau)
+       if (allocated(modisRetrievedSize))              deallocate(modisRetrievedSize)
+       if (allocated(modisRetrievedPhase))             deallocate(modisRetrievedPhase)
+       if (allocated(modisRetrievedCloudTopPressure))  deallocate(modisRetrievedCloudTopPressure)
+       if (allocated(modisCftotal))                    deallocate(modisCftotal)
+       if (allocated(modisCfLiquid))                   deallocate(modisCfLiquid)
+       if (allocated(modisCfIce))                      deallocate(modisCfIce)
+       if (allocated(modisCfHigh))                     deallocate(modisCfHigh)
+       if (allocated(modisCfMid))                      deallocate(modisCfMid)
+       if (allocated(modisCfLow))                      deallocate(modisCfLow)
+       if (allocated(modisMeanTauTotal))               deallocate(modisMeanTauTotal)
+       if (allocated(modisMeanTauLiquid))              deallocate(modisMeanTauLiquid)
+       if (allocated(modisMeanTauIce))                 deallocate(modisMeanTauIce)
+       if (allocated(modisMeanLogTauTotal))            deallocate(modisMeanLogTauTotal)
+       if (allocated(modisMeanLogTauLiquid))           deallocate(modisMeanLogTauLiquid)
+       if (allocated(modisMeanLogTauIce))              deallocate(modisMeanLogTauIce)
+       if (allocated(modisMeanSizeLiquid))             deallocate(modisMeanSizeLiquid)
+       if (allocated(modisMeanSizeIce))                deallocate(modisMeanSizeIce)
+       if (allocated(modisMeanCloudTopPressure))       deallocate(modisMeanCloudTopPressure)
+       if (allocated(modisMeanLiquidWaterPath))        deallocate(modisMeanLiquidWaterPath)
+       if (allocated(modisMeanIceWaterPath))           deallocate(modisMeanIceWaterPath)
+       if (allocated(modisJointHistogram))             deallocate(modisJointHistogram)
+       if (allocated(modisJointHistogramIce))          deallocate(modisJointHistogramIce)
+       if (allocated(modisJointHistogramLiq))          deallocate(modisJointHistogramLiq)
+       if (allocated(isccp_boxttop))                   deallocate(isccp_boxttop)
+       if (allocated(isccp_boxptop))                   deallocate(isccp_boxptop)
+       if (allocated(isccp_boxtau))                    deallocate(isccp_boxtau)
+       if (allocated(isccp_meantbclr))                 deallocate(isccp_meantbclr)
+       if (allocated(isccpLEVMATCH))                   deallocate(isccpLEVMATCH)
+    endif
+
+    ! RTTOV
+!    if (lrttov_column) then
+!       call rttov_column(rttovIN%nPoints,rttovIN%nLevels,rttovIN%nSubCols,rttovIN%q,    &
+!                         rttovIN%p,rttovIN%t,rttovIN%o3,rttovIN%ph,rttovIN%h_surf,      &
+!                         rttovIN%u_surf,rttovIN%v_surf,rttovIN%p_surf,rttovIN%t_skin,   &
+!                         rttovIN%t2m,rttovIN%q2m,rttovIN%lsmask,rttovIN%longitude,      &
+!                         rttovIN%latitude,rttovIN%seaice,rttovIN%co2,rttovIN%ch4,       &
+!                         rttovIN%n2o,rttovIN%co,rttovIN%zenang,lrttov_cleanUp,          &
+!                         cospOUT%rttov_tbs(ij:ik,:),cosp_simulator(nError+1),           &
+!                         ! Optional arguments for surface emissivity calculation
+!                         month=rttovIN%month)
+!                         ! Optional arguments to rttov for all-sky calculation
+!                         ! rttovIN%month, rttovIN%tca,rttovIN%cldIce,rttovIN%cldLiq,     &
+!                         ! rttovIN%fl_rain,rttovIN%fl_snow)
+!    endif
+
+    !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+    ! 6) Compute multi-instrument products
+    !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+    ! CLOUDSAT/CALIPSO products
+    if (Lradar_lidar_tcc .or. Llidar_only_freq_cloud .or. Lcloudsat_tcc .or. Lcloudsat_tcc2) then
+
+       if (use_vgrid) then
+          allocate(lidar_only_freq_cloud(cloudsatIN%Npoints,Nlvgrid),                    &
+               radar_lidar_tcc(cloudsatIN%Npoints), cloudsat_tcc(cloudsatIN%Npoints),    &
+               cloudsat_tcc2(cloudsatIN%Npoints))
+          allocate(betamol_in(cloudsatIN%Npoints,1,cloudsatIN%Nlevels),                  &
+                   betamoli(cloudsatIN%Npoints,1,Nlvgrid),                               &
+                   pnormI(cloudsatIN%Npoints,cloudsatIN%Ncolumns,Nlvgrid),               &
+                   Ze_totI(cloudsatIN%Npoints,cloudsatIN%Ncolumns,Nlvgrid))
+
+          ! Regrid in the vertical (*NOTE* This routine requires SFC-2-TOA ordering, so flip
+          ! inputs and outputs to maintain TOA-2-SFC ordering convention in COSP2.)
+          betamol_in(:,1,:) = calipso_beta_mol(:,cloudsatIN%Nlevels:1:-1)
+          call cosp_change_vertical_grid(cloudsatIN%Npoints,1,cloudsatIN%Nlevels,        &
+               cospgridIN%hgt_matrix(:,cloudsatIN%Nlevels:1:-1),                         &
+               cospgridIN%hgt_matrix_half(:,cloudsatIN%Nlevels:1:-1),betamol_in,         &
+               Nlvgrid,vgrid_zl(Nlvgrid:1:-1),vgrid_zu(Nlvgrid:1:-1),                    &
+               betamolI(:,1,Nlvgrid:1:-1))
+
+          call cosp_change_vertical_grid(cloudsatIN%Npoints,cloudsatIN%Ncolumns,         &
+               cloudsatIN%Nlevels,cospgridIN%hgt_matrix(:,cloudsatIN%Nlevels:1:-1),      &
+               cospgridIN%hgt_matrix_half(:,cloudsatIN%Nlevels:1:-1),                    &
+               calipso_beta_tot(:,:,cloudsatIN%Nlevels:1:-1),Nlvgrid,                    &
+               vgrid_zl(Nlvgrid:1:-1),vgrid_zu(Nlvgrid:1:-1),pnormI(:,:,Nlvgrid:1:-1))
+
+          call cosp_change_vertical_grid(cloudsatIN%Npoints,cloudsatIN%Ncolumns,         &
+               cloudsatIN%Nlevels,cospgridIN%hgt_matrix(:,cloudsatIN%Nlevels:1:-1),      &
+               cospgridIN%hgt_matrix_half(:,cloudsatIN%Nlevels:1:-1),                    &
+               cloudsatDBZe(:,:,cloudsatIN%Nlevels:1:-1),Nlvgrid,vgrid_zl(Nlvgrid:1:-1), &
+               vgrid_zu(Nlvgrid:1:-1),Ze_totI(:,:,Nlvgrid:1:-1),log_units=.true.)
+
+          call cosp_lidar_only_cloud(cloudsatIN%Npoints, cloudsatIN%Ncolumns, Nlvgrid,   &
+             pnormI, betamolI, Ze_totI, lidar_only_freq_cloud, radar_lidar_tcc,          &
+             cloudsat_tcc, cloudsat_tcc2)
+
+          deallocate(betamol_in,betamolI,pnormI,ze_totI)
+       else
+          allocate(lidar_only_freq_cloud(cloudsatIN%Npoints,cloudsatIN%Nlevels),         &
+               radar_lidar_tcc(cloudsatIN%Npoints), cloudsat_tcc(cloudsatIN%Npoints),    &
+               cloudsat_tcc2(cloudsatIN%Npoints))
+          call cosp_lidar_only_cloud(cloudsatIN%Npoints,cloudsatIN%Ncolumns,             &
+               cospIN%Nlevels,calipso_beta_tot(:,:,cloudsatIN%Nlevels:1:-1),             &
+               calipso_beta_mol(:,cloudsatIN%Nlevels:1:-1),                              &
+               cloudsatDBZe(:,:,cloudsatIN%Nlevels:1:-1),lidar_only_freq_cloud,          &
+               radar_lidar_tcc, cloudsat_tcc, cloudsat_tcc2)
+       endif
+
+       ! Store, when necessary
+       if (associated(cospOUT%lidar_only_freq_cloud)) then
+          cospOUT%lidar_only_freq_cloud(ij:ik,:) = lidar_only_freq_cloud
+       endif
+       if (associated(cospOUT%radar_lidar_tcc)) then
+          cospOUT%radar_lidar_tcc(ij:ik) = radar_lidar_tcc
+       endif
+       if (associated(cospOUT%cloudsat_tcc)) then
+          cospOUT%cloudsat_tcc(ij:ik) = cloudsat_tcc
+       endif
+       if (associated(cospOUT%cloudsat_tcc2)) then
+          cospOUT%cloudsat_tcc2(ij:ik) = cloudsat_tcc2
+       endif
+    endif
+
+    !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+    ! 7) Cleanup
+    !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+    if (Lisccp_subcolumn .or. Lmodis_subcolumn) then
+       nullify(isccpIN%Npoints,isccpIN%Ncolumns,isccpIN%Nlevels,isccpIN%emsfc_lw,        &
+               isccpIN%skt,isccpIN%qv,isccpIN%at,isccpIN%frac_out,isccpIN%dtau,          &
+               isccpIN%dem,isccpIN%phalf,isccpIN%sunlit,isccpIN%pfull)
+    endif
+
+    if (Lmisr_subcolumn) then
+       nullify(misrIN%Npoints,misrIN%Ncolumns,misrIN%Nlevels,misrIN%dtau,misrIN%sunlit,  &
+               misrIN%zfull,misrIN%at)
+    endif
+
+    if (Lcalipso_subcolumn) then
+       nullify(calipsoIN%Npoints,calipsoIN%Ncolumns,calipsoIN%Nlevels,calipsoIN%beta_mol,&
+               calipsoIN%betatot,calipsoIN%betatot_liq,calipsoIN%betatot_ice,            &
+               calipsoIN%tau_mol,calipsoIN%tautot,calipsoIN%tautot_liq,calipsoIN%tautot_ice)
+    endif
+
+    if (LgrLidar532_subcolumn) then 
+       nullify(grLidar532IN%Npoints,grLidar532IN%Ncolumns,grLidar532IN%Nlevels,grLidar532IN%beta_mol, &
+               grLidar532IN%betatot,grLidar532IN%tau_mol,grLidar532IN%tautot) 
+    endif 
+
+    if (Latlid_subcolumn) then
+       nullify(atlidIN%Npoints,atlidIN%Ncolumns,atlidIN%Nlevels,atlidIN%beta_mol_atlid, &
+               atlidIN%betatot_atlid,atlidIN%tau_mol_atlid,atlidIN%tautot_atlid)
+    endif 
+
+    if (Lparasol_subcolumn) then
+       nullify(parasolIN%Npoints,parasolIN%Nlevels,parasolIN%Ncolumns,parasolIN%Nrefl,   &
+            parasolIN%tautot_S_liq,parasolIN%tautot_S_ice)
+    endif
+
+
+    if (Lcloudsat_subcolumn) then
+       nullify(cloudsatIN%Npoints,cloudsatIN%Nlevels,cloudsatIN%Ncolumns,cloudsatIN%rcfg,&
+               cloudsatIN%kr_vol,cloudsatIN%g_vol,cloudsatIN%z_vol,cloudsatIN%hgt_matrix)
+    endif
+
+    if (Lmodis_subcolumn) then
+       nullify(modisIN%Npoints,modisIN%Ncolumns,modisIN%Nlevels,modisIN%tau,modisIN%g,   &
+               modisIN%liqFrac,modisIN%w0)
+       if (allocated(modisIN%sunlit))    deallocate(modisIN%sunlit)
+       if (allocated(modisIN%notSunlit)) deallocate(modisIN%notSunlit)
+       if (allocated(modisIN%pres))      deallocate(modisIN%pres)
+    endif
+
+    if (allocated(calipso_beta_tot))      deallocate(calipso_beta_tot)
+    if (allocated(grLidar532_beta_tot))  deallocate(grLidar532_beta_tot)
+    if (allocated(atlid_beta_tot))        deallocate(atlid_beta_tot) 
+    if (allocated(calipso_beta_mol))      deallocate(calipso_beta_mol)
+    if (allocated(grLidar532_beta_mol))  deallocate(grLidar532_beta_mol)
+    if (allocated(atlid_beta_mol))        deallocate(atlid_beta_mol)
+    if (allocated(calipso_betaperp_tot))  deallocate(calipso_betaperp_tot)
+    if (allocated(cloudsatDBZe))          deallocate(cloudsatDBZe)
+    if (allocated(lidar_only_freq_cloud)) deallocate(lidar_only_freq_cloud)
+    if (allocated(radar_lidar_tcc))       deallocate(radar_lidar_tcc)
+    if (allocated(cloudsat_tcc))          deallocate(cloudsat_tcc)
+    if (allocated(cloudsat_tcc2))         deallocate(cloudsat_tcc2)
+
+  end function COSP_SIMULATOR
+  ! ######################################################################################
+  ! SUBROUTINE cosp_init
+  ! ######################################################################################
+  SUBROUTINE COSP_INIT(Lisccp, Lmodis, Lmisr, Lcloudsat, Lcalipso, LgrLidar532, Latlid, Lparasol, Lrttov,     &
+       cloudsat_radar_freq, cloudsat_k2, cloudsat_use_gas_abs, cloudsat_do_ray,          &
+       isccp_top_height, isccp_top_height_direction, surface_radar, rcfg, lusevgrid,     &
+       luseCSATvgrid, Nvgrid, Nlevels, cloudsat_micro_scheme)
+
+    ! INPUTS
+    logical,intent(in) :: Lisccp,Lmodis,Lmisr,Lcloudsat,Lcalipso,LgrLidar532,Latlid,Lparasol,Lrttov
+    integer,intent(in)  :: &
+         cloudsat_use_gas_abs,       & !
+         cloudsat_do_ray,            & !
+         isccp_top_height,           & !
+         isccp_top_height_direction, & !
+         Nlevels,                    & !
+         Nvgrid,                     & ! Number of levels for new L3 grid
+         surface_radar                 !
+    real(wp),intent(in) :: &
+         cloudsat_radar_freq,        & !
+         cloudsat_k2                   !
+    logical,intent(in) :: &
+         lusevgrid,                  & ! Switch to use different vertical grid
+         luseCSATvgrid                 ! Switch to use CLOUDSAT grid spacing for new
+                                       ! vertical grid
+    character(len=64),intent(in) :: &
+       cloudsat_micro_scheme           ! Microphysical scheme used by CLOUDSAT
+
+    ! OUTPUTS
+    type(radar_cfg) :: rcfg
+
+    ! Local variables
+    integer  :: i
+    real(wp) :: zstep
+
+    ! Initialize MODIS optical-depth bin boundaries for joint-histogram. (defined in cosp_config.F90)
+    if (.not. allocated(modis_histTau)) then
+       allocate(modis_histTau(ntau+1),modis_histTauEdges(2,ntau),modis_histTauCenters(ntau))
+       numMODISTauBins      = ntau
+       modis_histTau        = tau_binBounds
+       modis_histTauEdges   = tau_binEdges
+       modis_histTauCenters = tau_binCenters
+    endif
+
+    ! Set up vertical grid used by CALIPSO and CLOUDSAT L3
+    use_vgrid = lusevgrid
+
+    if (use_vgrid) then
+      Nlvgrid  = Nvgrid
+       allocate(vgrid_zl(Nlvgrid),vgrid_zu(Nlvgrid),vgrid_z(Nlvgrid))
+       ! CloudSat grid requested
+       if (luseCSATvgrid)       zstep = 480._wp
+       ! Other grid requested. Constant vertical spacing with top at 20 km
+       if (.not. luseCSATvgrid) zstep = 20000._wp/Nvgrid
+       do i=1,Nvgrid
+          vgrid_zl(Nlvgrid-i+1) = (i-1)*zstep
+          vgrid_zu(Nlvgrid-i+1) = i*zstep
+       enddo
+       vgrid_z = (vgrid_zl+vgrid_zu)/2._wp
+    else
+       Nlvgrid = Nlevels
+       allocate(vgrid_zl(Nlvgrid),vgrid_zu(Nlvgrid),vgrid_z(Nlvgrid))
+    endif
+
+    ! Initialize simulators
+    if (Lisccp) call cosp_isccp_init(isccp_top_height,isccp_top_height_direction)
+    if (Lmodis) call cosp_modis_init()
+    if (Lmisr)  call cosp_misr_init()
+!    if (Lrttov) call cosp_rttov_init()
+    if (Lcloudsat) call cosp_cloudsat_init(cloudsat_radar_freq,cloudsat_k2,              &
+         cloudsat_use_gas_abs,cloudsat_do_ray,R_UNDEF,N_HYDRO, surface_radar,            &
+         rcfg,cloudsat_micro_scheme)
+    if (Lcalipso) call cosp_calipso_init()
+    if (LgrLidar532) call cosp_grLidar532_init()
+    if (Latlid) call cosp_atlid_init()
+    if (Lparasol) call cosp_parasol_init()
+
+    linitialization = .FALSE.
+  END SUBROUTINE COSP_INIT
+
+  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  ! SUBROUTINE cosp_cleanUp
+  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  subroutine cosp_cleanUp()
+    deallocate(vgrid_zl,vgrid_zu,vgrid_z)
+  end subroutine cosp_cleanUp
+
+  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  ! SUBROUTINE cosp_errorCheck
+  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  subroutine cosp_errorCheck(cospgridIN, cospIN, Lisccp_subcolumn, Lisccp_column,           &
+       Lmisr_subcolumn, Lmisr_column, Lmodis_subcolumn, Lmodis_column, Lcloudsat_subcolumn, &
+       Lcloudsat_column, Lcalipso_subcolumn, Lcalipso_column, Latlid_subcolumn,             &
+       Latlid_column, LgrLidar532_subcolumn, LgrLidar532_column, Lrttov_subcolumn,        &
+       Lrttov_column, Lparasol_subcolumn, Lparasol_column, Lradar_lidar_tcc,                &
+       Llidar_only_freq_cloud, Lcloudsat_tcc, Lcloudsat_tcc2, cospOUT, errorMessage, nError)
+    
+    ! Inputs
+    type(cosp_column_inputs),intent(in) :: &
+         cospgridIN       ! Model grid inputs to COSP
+    type(cosp_optical_inputs),intent(in) :: &
+         cospIN           ! Derived (optical) input to COSP
+    
+    ! Outputs
+    logical,intent(inout) :: &
+         Lisccp_subcolumn,    & ! ISCCP subcolumn simulator on/off switch
+         Lisccp_column,       & ! ISCCP column simulator on/off switch
+         Lmisr_subcolumn,     & ! MISR subcolumn simulator on/off switch
+         Lmisr_column,        & ! MISR column simulator on/off switch
+         Lmodis_subcolumn,    & ! MODIS subcolumn simulator on/off switch
+         Lmodis_column,       & ! MODIS column simulator on/off switch
+         Lcloudsat_subcolumn, & ! CLOUDSAT subcolumn simulator on/off switch
+         Lcloudsat_column,    & ! CLOUDSAT column simulator on/off switch
+         Lcalipso_subcolumn,  & ! CALIPSO subcolumn simulator on/off switch
+         Lcalipso_column,     & ! CALIPSO column simulator on/off switch
+         Latlid_subcolumn,    & ! EarthCare subcolumn simulator on/off switch
+         Latlid_column,       & ! EarthCare column simulator on/off switch
+         LgrLidar532_subcolumn, & ! Ground Lidar subcolumn simulator on/off switch
+         LgrLidar532_column, & ! Ground Lidar column simulator on/off switch
+         Lparasol_subcolumn,  & ! PARASOL subcolumn simulator on/off switch
+         Lparasol_column,     & ! PARASOL column simulator on/off switch
+         Lrttov_subcolumn,    & ! RTTOV subcolumn simulator on/off switch
+         Lrttov_column,       & ! RTTOV column simulator on/off switch
+         Lcloudsat_tcc,       & !
+         Lcloudsat_tcc2,      & !
+         Lradar_lidar_tcc,    & ! On/Off switch for joint Calipso/Cloudsat product
+         Llidar_only_freq_cloud ! On/Off switch for joint Calipso/Cloudsat product
+    type(cosp_outputs),intent(inout) :: &
+         cospOUT                ! COSP Outputs
+    character(len=256),dimension(100) :: errorMessage
+    integer,intent(out) :: nError
+    
+    ! Local variables
+    character(len=100) :: parasolErrorMessage
+    logical :: alloc_status
+    
+    nError = 0
+    !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+    ! PART 0: Ensure that the inputs needed by the requested simulators are allocated.
+    !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+    ! ISCCP simulator
+    if (Lisccp_subcolumn .or. Lisccp_column) then
+       alloc_status = .true.
+       if (.not. allocated(cospgridIN%skt)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable (ISSCP simulator): cospgridIN%skt has not been allocated'
+          alloc_status = .false.
+       endif
+       if (.not. allocated(cospgridIN%qv)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable (ISSCP simulator): cospgridIN%qv has not been allocated'
+          alloc_status = .false.
+       endif
+       if (.not. allocated(cospgridIN%at)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable (ISSCP simulator): cospgridIN%at has not been allocated'
+          alloc_status = .false.
+       endif
+       if (.not. allocated(cospIN%frac_out)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable (ISSCP simulator): cospIN%frac_out has not been allocated'
+          alloc_status = .false.
+       endif
+       if (.not. allocated(cospIN%tau_067)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable (ISSCP simulator): cospIN%tau_067 has not been allocated'
+          alloc_status = .false.
+       endif
+       if (.not. allocated(cospIN%emiss_11)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable (ISSCP simulator): cospIN%emiss_11 has not been allocated'
+          alloc_status = .false.
+       endif
+       if (.not. allocated(cospgridIN%phalf)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable (ISSCP simulator): cospgridIN%phalf has not been allocated'
+          alloc_status = .false.
+       endif
+       if (.not. allocated(cospgridIN%sunlit)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable (ISSCP simulator): cospgridIN%sunlit has not been allocated'
+          alloc_status = .false.
+       endif
+       if (.not. allocated(cospgridIN%pfull)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable (ISSCP simulator): cospgridIN%pfull has not been allocated'
+          alloc_status = .false.
+       endif
+       if (.not. alloc_status) then
+          Lisccp_subcolumn = .false.
+          Lisccp_column    = .false.
+          if (associated(cospOUT%isccp_totalcldarea))  cospOUT%isccp_totalcldarea(:)  = R_UNDEF
+          if (associated(cospOUT%isccp_meantb))        cospOUT%isccp_meantb(:)        = R_UNDEF
+          if (associated(cospOUT%isccp_meantbclr))     cospOUT%isccp_meantbclr(:)     = R_UNDEF
+          if (associated(cospOUT%isccp_meanptop))      cospOUT%isccp_meanptop(:)      = R_UNDEF
+          if (associated(cospOUT%isccp_meantaucld))    cospOUT%isccp_meantaucld(:)    = R_UNDEF
+          if (associated(cospOUT%isccp_meanalbedocld)) cospOUT%isccp_meanalbedocld(:) = R_UNDEF
+          if (associated(cospOUT%isccp_boxtau))        cospOUT%isccp_boxtau(:,:)      = R_UNDEF
+          if (associated(cospOUT%isccp_boxptop))       cospOUT%isccp_boxptop(:,:)     = R_UNDEF
+          if (associated(cospOUT%isccp_fq))            cospOUT%isccp_fq(:,:,:)        = R_UNDEF
+       endif
+    endif
+    
+    ! MISR simulator
+    if (Lmisr_subcolumn .or. Lmisr_column) then
+       alloc_status = .true.
+       if (.not. allocated(cospIN%tau_067)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable (MISR simulator): cospIN%tau_067 has not been allocated'
+          alloc_status = .false.
+       endif
+       if (.not. allocated(cospgridIN%sunlit)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable (MISR simulator): cospgridIN%sunlit has not been allocated'
+          alloc_status = .false.
+       endif
+       if (.not. allocated(cospgridIN%hgt_matrix)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable (MISR simulator): cospgridIN%hgt_matrix has not been allocated'
+          alloc_status = .false.
+       endif
+       if (.not. allocated(cospgridIN%at)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable (MISR simulator): cospgridIN%at has not been allocated'
+          alloc_status = .false.
+       endif
+       if (.not. alloc_status) then
+          Lmisr_subcolumn = .false.
+          Lmisr_column    = .false.
+          if (associated(cospOUT%misr_fq))                   cospOUT%misr_fq(:,:,:)                 = R_UNDEF
+          if (associated(cospOUT%misr_dist_model_layertops)) cospOUT%misr_dist_model_layertops(:,:) = R_UNDEF
+          if (associated(cospOUT%misr_meanztop))             cospOUT%misr_meanztop(:)               = R_UNDEF
+          if (associated(cospOUT%misr_cldarea))              cospOUT%misr_cldarea(:)                = R_UNDEF          
+       endif
+    endif
+
+    ! EarthCare Lidar simulator.
+    if (Latlid_subcolumn .or. Latlid_column) then
+       alloc_status = .true.
+       if (.not. allocated(cospIN%beta_mol_atlid)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable (EarthCare Lidar simulator): cospIN%beta_mol_atlid has not been allocated'
+          alloc_status = .false.
+       endif
+       if (.not. allocated(cospIN%betatot_atlid)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable (EarthCare Lidar simulator): cospIN%betatot_atlid has not been allocated'
+          alloc_status = .false.
+       endif
+       if (.not. allocated(cospIN%tau_mol_atlid)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable (EarthCare Lidar simulator): cospIN%tau_mol_atlid has not been allocated'
+          alloc_status = .false.
+       endif
+       if (.not. allocated(cospIN%tautot_atlid)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable (EarthCare Lidar simulator): cospIN%tautot_atlid has not been allocated'
+          alloc_status = .false.
+       endif
+       if (.not. alloc_status) then
+          Latlid_subcolumn = .false.
+          Latlid_column    = .false.
+          if (associated(cospOUT%atlid_cfad_sr))  cospOUT%atlid_cfad_sr(:,:,:)  = R_UNDEF
+          if (associated(cospOUT%atlid_lidarcld)) cospOUT%atlid_lidarcld(:,:)   = R_UNDEF
+          if (associated(cospOUT%atlid_cldlayer)) cospOUT%atlid_cldlayer(:,:)   = R_UNDEF
+          if (associated(cospOUT%atlid_beta_mol)) cospOUT%atlid_beta_mol(:,:)   = R_UNDEF
+          if (associated(cospOUT%atlid_beta_tot)) cospOUT%atlid_beta_tot(:,:,:) = R_UNDEF
+       endif
+       
+       ! EarthCare column simulator requires additional inputs not required by the subcolumn simulator.
+       alloc_status = .true.
+       if (.not. allocated(cospgridIN%hgt_matrix)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable (EarthCare Lidar simulator): cospgridIN%hgt_matrix has not been allocated'
+          alloc_status = .false.
+       endif
+       if (.not. allocated(cospgridIN%hgt_matrix_half)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable (EarthCare Lidar simulator): cospgridIN%hgt_matrix_half has not been allocated'
+          alloc_status = .false.
+       endif
+       if (.not. allocated(cospgridIN%phalf)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable (EarthCare Lidar simulator): cospgridIN%phalf has not been allocated'
+          alloc_status = .false.
+       endif
+       if (.not. alloc_status) then
+          Latlid_column  = .false.
+          if (associated(cospOUT%atlid_cfad_sr)) cospOUT%atlid_cfad_sr(:,:,:) = R_UNDEF
+       endif
+    endif
+
+    ! Ground Lidar simulator.
+    if (LgrLidar532_subcolumn .or. LgrLidar532_column) then
+       alloc_status = .true.
+       if (.not. allocated(cospIN%beta_mol_grLidar532)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable (Ground Lidar simulator): cospIN%beta_mol_grLidar532 has not been allocated'
+          alloc_status = .false.
+       endif
+       if (.not. allocated(cospIN%betatot_grLidar532)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable (Ground Lidar simulator): cospIN%betatot_grLidar532 has not been allocated'
+          alloc_status = .false.
+       endif
+       if (.not. allocated(cospIN%tau_mol_grLidar532)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable (Ground Lidar simulator): cospIN%tau_mol_grLidar532 has not been allocated'
+          alloc_status = .false.
+       endif
+       if (.not. allocated(cospIN%tautot_grLidar532)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable (Ground Lidar simulator): cospIN%tautot_grLidar532 has not been allocated'
+          alloc_status = .false.
+       endif
+       if (.not. alloc_status) then
+          LgrLidar532_subcolumn = .false.
+          LgrLidar532_column    = .false.
+          if (associated(cospOUT%grLidar532_cfad_sr))  cospOUT%grLidar532_cfad_sr(:,:,:)  = R_UNDEF
+          if (associated(cospOUT%grLidar532_lidarcld)) cospOUT%grLidar532_lidarcld(:,:)   = R_UNDEF
+          if (associated(cospOUT%grLidar532_cldlayer)) cospOUT%grLidar532_cldlayer(:,:)   = R_UNDEF
+          if (associated(cospOUT%grLidar532_beta_mol)) cospOUT%grLidar532_beta_mol(:,:)   = R_UNDEF
+          if (associated(cospOUT%grLidar532_beta_tot)) cospOUT%grLidar532_beta_tot(:,:,:) = R_UNDEF
+       endif
+       
+       ! Ground Lidar column simulator requires additional inputs not required by the subcolumn simulator.
+       alloc_status = .true.
+       if (.not. allocated(cospgridIN%hgt_matrix)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable (Ground Lidar simulator): cospgridIN%hgt_matrix has not been allocated'
+          alloc_status = .false.
+       endif
+       if (.not. allocated(cospgridIN%hgt_matrix_half)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable (Ground Lidar simulator): cospgridIN%hgt_matrix_half has not been allocated'
+          alloc_status = .false.
+       endif
+       if (.not. allocated(cospgridIN%phalf)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable (Ground Lidar simulator): cospgridIN%phalf has not been allocated'
+          alloc_status = .false.
+       endif
+       if (.not. alloc_status) then
+          LgrLidar532_column  = .false.
+          if (associated(cospOUT%grLidar532_cfad_sr)) cospOUT%grLidar532_cfad_sr(:,:,:) = R_UNDEF
+       endif
+    endif
+    
+    ! Calipso Lidar simulator
+    if (Lcalipso_subcolumn .or. Lcalipso_column) then
+       alloc_status = .true.
+       if (.not. allocated(cospIN%beta_mol_calipso)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable (Calipso Lidar simulator): cospIN%beta_mol_calipso has not been allocated'
+          alloc_status = .false.
+       endif
+       if (.not. allocated(cospIN%betatot_calipso)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable (Calipso Lidar simulator): cospIN%betatot_calipso has not been allocated'
+          alloc_status = .false.
+       endif
+       if (.not. allocated(cospIN%betatot_liq_calipso)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable (Calipso Lidar simulator):'//&
+               ' cospIN%betatot_liq_calipso has not been allocated'
+          alloc_status = .false.
+       endif
+       if (.not. allocated(cospIN%betatot_ice_calipso)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable (Calipso Lidar simulator):'//&
+               ' cospIN%betatot_ice_calipso has not been allocated'
+          alloc_status = .false.
+       endif
+       if (.not. allocated(cospIN%tau_mol_calipso)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable (Calipso Lidar simulator): cospIN%tau_mol_calipso has not been allocated'
+          alloc_status = .false.
+       endif
+       if (.not. allocated(cospIN%tautot_calipso)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable (Calipso Lidar simulator): cospIN%tautot_calipso has not been allocated'
+          alloc_status = .false.
+       endif
+       if (.not. allocated(cospIN%tautot_liq_calipso)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable (Calipso Lidar simulator):'//&
+               ' cospIN%tautot_liq has not been allocated'
+          alloc_status = .false.
+       endif
+       if (.not. allocated(cospIN%tautot_ice_calipso)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable (Calipso Lidar simulator):'//&
+               ' cospIN%tautot_ice has not been allocated'
+          alloc_status = .false.
+       endif
+       if (.not. alloc_status) then
+          Lcalipso_subcolumn = .false.
+          Lcalipso_column    = .false.
+          if (associated(cospOUT%calipso_cfad_sr))       cospOUT%calipso_cfad_sr(:,:,:)       = R_UNDEF
+          if (associated(cospOUT%calipso_lidarcld))      cospOUT%calipso_lidarcld(:,:)        = R_UNDEF
+          if (associated(cospOUT%calipso_lidarcldphase)) cospOUT%calipso_lidarcldphase(:,:,:) = R_UNDEF
+          if (associated(cospOUT%calipso_cldlayer))      cospOUT%calipso_cldlayer(:,:)        = R_UNDEF
+          if (associated(cospOUT%calipso_cldlayerphase)) cospOUT%calipso_cldlayerphase(:,:,:) = R_UNDEF
+          if (associated(cospOUT%calipso_lidarcldtmp))   cospOUT%calipso_lidarcldtmp(:,:,:)   = R_UNDEF
+          if (associated(cospOUT%calipso_beta_mol))      cospOUT%calipso_beta_mol(:,:)        = R_UNDEF
+          if (associated(cospOUT%calipso_beta_tot))      cospOUT%calipso_beta_tot(:,:,:)      = R_UNDEF
+          if (associated(cospOUT%calipso_betaperp_tot))  cospOUT%calipso_betaperp_tot(:,:,:)  = R_UNDEF
+          ! Also, turn-off joint-products 
+          if (Lradar_lidar_tcc) then
+             Lradar_lidar_tcc = .false.
+             if (associated(cospOUT%radar_lidar_tcc)) cospOUT%radar_lidar_tcc(:) = R_UNDEF
+          endif
+          if (Lcloudsat_tcc) then
+             Lcloudsat_tcc = .false.
+             if (associated(cospOUT%cloudsat_tcc)) cospOUT%cloudsat_tcc(:) = R_UNDEF
+          endif
+          if (Lcloudsat_tcc2) then
+             Lcloudsat_tcc2 = .false.
+             if (associated(cospOUT%cloudsat_tcc2)) cospOUT%cloudsat_tcc2(:) = R_UNDEF
+          endif
+          if (Llidar_only_freq_cloud) then
+             Llidar_only_freq_cloud = .false.
+             if (associated(cospOUT%lidar_only_freq_cloud)) cospOUT%lidar_only_freq_cloud(:,:) = R_UNDEF
+          endif
+       endif
+       
+       ! Calipso column simulator requires additional inputs not required by the subcolumn simulator.
+       alloc_status = .true.
+       if (.not. allocated(cospgridIN%hgt_matrix)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable (Calipso Lidar simulator):'//&
+               ' cospgridIN%hgt_matrix has not been allocated'
+          alloc_status = .false.
+       endif
+       if (.not. allocated(cospgridIN%hgt_matrix_half)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable (Calipso Lidar simulator):'//&
+               ' cospgridIN%hgt_matrix_half has not been allocated'
+          alloc_status = .false.
+       endif
+       if (.not. allocated(cospgridIN%at)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable (Calipso Lidar simulator): cospgridIN%at has not been allocated'
+          alloc_status = .false.
+       endif
+       if (.not. allocated(cospgridIN%phalf)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable (Calipso Lidar simulator): cospgridIN%phalf has not been allocated'
+          alloc_status = .false.
+       endif
+       if (.not. alloc_status) then
+          Lcalipso_column  = .false.
+          if (associated(cospOUT%calipso_cfad_sr))       cospOUT%calipso_cfad_sr(:,:,:)       = R_UNDEF
+          if (associated(cospOUT%calipso_lidarcld))      cospOUT%calipso_lidarcld(:,:)        = R_UNDEF
+          if (associated(cospOUT%calipso_lidarcldphase)) cospOUT%calipso_lidarcldphase(:,:,:) = R_UNDEF
+          if (associated(cospOUT%calipso_cldlayer))      cospOUT%calipso_cldlayer(:,:)        = R_UNDEF
+          if (associated(cospOUT%calipso_cldlayerphase)) cospOUT%calipso_cldlayerphase(:,:,:) = R_UNDEF
+          if (associated(cospOUT%calipso_lidarcldtmp))   cospOUT%calipso_lidarcldtmp(:,:,:)   = R_UNDEF
+          if (Lcloudsat_tcc) then
+             Lcloudsat_tcc = .false.
+             if (associated(cospOUT%cloudsat_tcc)) cospOUT%cloudsat_tcc(:) = R_UNDEF
+          endif
+          if (Lcloudsat_tcc2) then
+             Lcloudsat_tcc2 = .false.
+             if (associated(cospOUT%cloudsat_tcc2)) cospOUT%cloudsat_tcc2(:) = R_UNDEF
+          endif
+          ! Also, turn-off joint-products 
+          if (Lradar_lidar_tcc) then
+             Lradar_lidar_tcc = .false.
+             if (associated(cospOUT%radar_lidar_tcc)) cospOUT%radar_lidar_tcc(:) = R_UNDEF
+          endif
+          if (Llidar_only_freq_cloud) then
+             Llidar_only_freq_cloud = .false.
+             if (associated(cospOUT%lidar_only_freq_cloud)) cospOUT%lidar_only_freq_cloud(:,:) = R_UNDEF
+          endif
+       endif
+    endif
+    
+    ! PARASOL simulator
+    if (Lparasol_subcolumn .or. Lparasol_column) then
+       alloc_status = .true.
+       if (.not. allocated(cospIN%tautot_S_liq)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable (PARASOL simulator): cospIN%tautot_S_liq has not been allocated'
+          alloc_status = .false.
+       endif
+       if (.not. allocated(cospIN%tautot_S_ice)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable (PARASOL simulator): cospIN%tautot_S_ice has not been allocated'
+          alloc_status = .false.
+       endif
+       if (.not. alloc_status) then
+          Lparasol_subcolumn  = .false.
+          Lparasol_column     = .false.
+          if (associated(cospOUT%parasolPix_refl))  cospOUT%parasolPix_refl(:,:,:) = R_UNDEF
+          if (associated(cospOUT%parasolGrid_refl)) cospOUT%parasolGrid_refl(:,:)  = R_UNDEF
+       endif
+       
+       ! PARASOL column simulator requires additional inputs not required by the subcolumn simulator.
+       alloc_status = .true.
+       if (.not. allocated(cospgridIN%land)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable (PARASOL simulator): cospgridIN%land has not been allocated'
+          alloc_status = .false.
+       endif
+       if (.not. alloc_status) then
+          Lparasol_column  = .false.
+          if (associated(cospOUT%parasolGrid_refl)) cospOUT%parasolGrid_refl(:,:)  = R_UNDEF
+       endif
+    endif
+    
+    ! Cloudsat radar simulator
+    if (Lcloudsat_subcolumn .or. Lcloudsat_column) then
+       alloc_status = .true.
+       if (.not. allocated(cospIN%z_vol_cloudsat)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable (Cloudsat radar simulator):'//&
+               ' cospIN%z_vol_cloudsat has not been allocated'
+          alloc_status = .false.
+       endif
+       if (.not. allocated(cospIN%kr_vol_cloudsat)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable (Cloudsat radar simulator):'//&
+               ' cospIN%kr_vol_cloudsat has not been allocated'
+          alloc_status = .false.
+       endif
+       if (.not. allocated(cospIN%g_vol_cloudsat)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable (Cloudsat radar simulator):'//&
+               ' cospIN%g_vol_cloudsat has not been allocated'
+          alloc_status = .false.
+       endif
+       if (.not. allocated(cospgridIN%hgt_matrix)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable (Cloudsat radar simulator):'//&
+               ' cospgridIN%hgt_matrix has not been allocated'
+          alloc_status = .false.
+       endif
+       if (.not. alloc_status) then
+          Lcloudsat_subcolumn  = .false.
+          Lcloudsat_column     = .false.
+          if (associated(cospOUT%cloudsat_cfad_ze)) cospOUT%cloudsat_cfad_ze(:,:,:) = R_UNDEF
+          if (associated(cospOUT%cloudsat_Ze_tot))  cospOUT%cloudsat_Ze_tot(:,:,:)  = R_UNDEF
+          if (Lcloudsat_tcc) then
+             Lcloudsat_tcc = .false.
+             if (associated(cospOUT%cloudsat_tcc)) cospOUT%cloudsat_tcc(:) = R_UNDEF
+          endif
+          if (Lcloudsat_tcc2) then
+             Lcloudsat_tcc2 = .false.
+             if (associated(cospOUT%cloudsat_tcc2)) cospOUT%cloudsat_tcc2(:) = R_UNDEF
+          endif
+          ! Also, turn-off joint-products 
+          if (Lradar_lidar_tcc) then
+             Lradar_lidar_tcc = .false.
+             if (associated(cospOUT%radar_lidar_tcc)) cospOUT%radar_lidar_tcc(:) = R_UNDEF
+          endif
+          if (Llidar_only_freq_cloud) then
+             Llidar_only_freq_cloud = .false.
+             if (associated(cospOUT%lidar_only_freq_cloud)) cospOUT%lidar_only_freq_cloud(:,:) = R_UNDEF
+          endif
+       endif
+       
+       ! Cloudsat column simulator requires additional inputs not required by the subcolumn simulator.
+       alloc_status = .true.
+       if (.not. allocated(cospgridIN%hgt_matrix_half)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable (Cloudsat radar simulator):'//&
+               ' cospgridIN%hgt_matrix_half has not been allocated'
+          alloc_status = .false.
+       endif
+       if (.not. alloc_status) then
+          Lcloudsat_column  = .false.
+          if (associated(cospOUT%cloudsat_cfad_ze))      cospOUT%cloudsat_cfad_ze(:,:,:)    = R_UNDEF
+          if (Lcloudsat_tcc) then
+             Lcloudsat_tcc = .false.
+             if (associated(cospOUT%cloudsat_tcc)) cospOUT%cloudsat_tcc(:) = R_UNDEF
+          endif
+          if (Lcloudsat_tcc2) then
+             Lcloudsat_tcc2 = .false.
+             if (associated(cospOUT%cloudsat_tcc2)) cospOUT%cloudsat_tcc2(:) = R_UNDEF
+          endif
+          ! Also, turn-off joint-products 
+          if (Lradar_lidar_tcc) then
+             Lradar_lidar_tcc = .false.
+             if (associated(cospOUT%radar_lidar_tcc)) cospOUT%radar_lidar_tcc(:) = R_UNDEF
+          endif
+          if (Llidar_only_freq_cloud) then
+             Llidar_only_freq_cloud = .false.
+             if (associated(cospOUT%lidar_only_freq_cloud)) cospOUT%lidar_only_freq_cloud(:,:) = R_UNDEF
+          endif
+       endif
+    endif
+    
+    ! MODIS simulator
+    if (Lmodis_subcolumn .or. Lmodis_column) then
+       alloc_status = .true.
+       if (.not. allocated(cospIN%fracLiq)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable (MODIS simulator): cospIN%fracLiq has not been allocated'
+          alloc_status = .false.
+       endif
+       if (.not. allocated(cospIN%tau_067)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable (MODIS simulator): cospIN%tau_067 has not been allocated'
+          alloc_status = .false.
+       endif
+       if (.not. allocated(cospIN%asym)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable (MODIS simulator): cospIN%asym has not been allocated'
+          alloc_status = .false.
+       endif
+       if (.not. allocated(cospIN%ss_alb)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable (MODIS simulator): cospIN%ss_alb has not been allocated'
+          alloc_status = .false.
+       endif
+       if (.not. allocated(cospgridIN%sunlit)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable (MODIS simulator): cospgridIN%sunlit has not been allocated'
+          alloc_status = .false.
+       endif
+       if (.not. alloc_status) then
+          Lmodis_subcolumn  = .false.
+          Lmodis_column     = .false.
+          if (associated(cospOUT%modis_Cloud_Fraction_Total_Mean))                          &
+               cospOUT%modis_Cloud_Fraction_Total_Mean(:)                   = R_UNDEF
+          if (associated(cospOUT%modis_Cloud_Fraction_Water_Mean))                          &
+               cospOUT%modis_Cloud_Fraction_Water_Mean(:)                   = R_UNDEF
+          if (associated(cospOUT%modis_Cloud_Fraction_Ice_Mean))                            &
+               cospOUT%modis_Cloud_Fraction_Ice_Mean(:)                     = R_UNDEF
+          if (associated(cospOUT%modis_Cloud_Fraction_High_Mean))                           &
+               cospOUT%modis_Cloud_Fraction_High_Mean(:)                    = R_UNDEF
+          if (associated(cospOUT%modis_Cloud_Fraction_Mid_Mean))                            &
+               cospOUT%modis_Cloud_Fraction_Mid_Mean(:)                     = R_UNDEF
+          if (associated(cospOUT%modis_Cloud_Fraction_Low_Mean))                            &
+               cospOUT%modis_Cloud_Fraction_Low_Mean(:)                     = R_UNDEF
+          if (associated(cospOUT%modis_Optical_Thickness_Total_Mean))                       &
+               cospOUT%modis_Optical_Thickness_Total_Mean(:)                = R_UNDEF
+          if (associated(cospOUT%modis_Optical_Thickness_Water_Mean))                       &
+               cospOUT%modis_Optical_Thickness_Water_Mean(:)                = R_UNDEF
+          if (associated(cospOUT%modis_Optical_Thickness_Ice_Mean))                         &
+               cospOUT%modis_Optical_Thickness_Ice_Mean(:)                  = R_UNDEF
+          if (associated(cospOUT%modis_Optical_Thickness_Total_LogMean))                    &
+               cospOUT%modis_Optical_Thickness_Total_LogMean(:)             = R_UNDEF
+          if (associated(cospOUT%modis_Optical_Thickness_Water_LogMean))                    &
+               cospOUT%modis_Optical_Thickness_Water_LogMean(:)             = R_UNDEF
+          if (associated(cospOUT%modis_Optical_Thickness_Ice_LogMean))                      &
+               cospOUT%modis_Optical_Thickness_Ice_LogMean(:)               = R_UNDEF
+          if (associated(cospOUT%modis_Cloud_Particle_Size_Water_Mean))                     &
+               cospOUT%modis_Cloud_Particle_Size_Water_Mean(:)              = R_UNDEF
+          if (associated(cospOUT%modis_Cloud_Particle_Size_Ice_Mean))                       &
+               cospOUT%modis_Cloud_Particle_Size_Ice_Mean(:)                = R_UNDEF
+          if (associated(cospOUT%modis_Cloud_Top_Pressure_Total_Mean))                      &
+               cospOUT%modis_Cloud_Top_Pressure_Total_Mean(:)               = R_UNDEF
+          if (associated(cospOUT%modis_Liquid_Water_Path_Mean))                             &
+               cospOUT%modis_Liquid_Water_Path_Mean(:)                      = R_UNDEF
+          if (associated(cospOUT%modis_Ice_Water_Path_Mean))                                &
+               cospOUT%modis_Ice_Water_Path_Mean(:)                         = R_UNDEF
+          if (associated(cospOUT%modis_Optical_Thickness_vs_Cloud_Top_Pressure))            &
+               cospOUT%modis_Optical_Thickness_vs_Cloud_Top_Pressure(:,:,:) = R_UNDEF
+          if (associated(cospOUT%modis_Optical_Thickness_vs_ReffICE))                       &
+               cospOUT%modis_Optical_Thickness_vs_ReffICE(:,:,:)            = R_UNDEF
+          if (associated(cospOUT%modis_Optical_Thickness_vs_ReffLIQ))                       &
+               cospOUT%modis_Optical_Thickness_vs_ReffLIQ(:,:,:)            = R_UNDEF          
+       endif
+    endif
+    
+    ! RTTOV
+    if (Lrttov_column) then
+       alloc_status = .true.
+       if (.not. allocated(cospgridIN%emis_sfc)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable (RTTOV): cospgridIN%emis_sfc has not been allocated'
+          alloc_status = .false.
+       endif
+       if (.not. allocated(cospgridIN%hgt_matrix_half)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable (RTTOV): cospgridIN%emis_sfc has not been allocated'
+          alloc_status = .false.
+       endif
+       if (.not. allocated(cospgridIN%u_sfc)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable (RTTOV): cospgridIN%u_sfc has not been allocated'
+          alloc_status = .false.
+       endif
+       if (.not. allocated(cospgridIN%v_sfc)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable (RTTOV): cospgridIN%v_sfc has not been allocated'
+          alloc_status = .false.
+       endif
+       if (.not. allocated(cospgridIN%skt)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable (RTTOV): cospgridIN%skt has not been allocated'
+          alloc_status = .false.
+       endif
+       if (.not. allocated(cospgridIN%phalf)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable (RTTOV): cospgridIN%phalf has not been allocated'
+          alloc_status = .false.
+       endif
+       if (.not. allocated(cospgridIN%qv)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable (RTTOV): cospgridIN%qv has not been allocated'
+          alloc_status = .false.
+       endif
+       if (.not. allocated(cospgridIN%at)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable (RTTOV): cospgridIN%at has not been allocated'
+          alloc_status = .false.
+       endif
+       if (.not. allocated(cospgridIN%land)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable (RTTOV): cospgridIN%land has not been allocated'
+          alloc_status = .false.
+       endif
+       if (.not. allocated(cospgridIN%lat)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable (RTTOV): cospgridIN%lat has not been allocated'
+          alloc_status = .false.
+       endif
+       if (.not. allocated(cospgridIN%lon)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable (RTTOV): cospgridIN%lon has not been allocated'
+          alloc_status = .false.
+       endif
+       if (.not. allocated(cospgridIN%seaice)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable (RTTOV): cospgridIN%seaice has not been allocated'
+          alloc_status = .false.
+       endif
+       if (.not. allocated(cospgridIN%pfull)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable (RTTOV): cospgridIN%pfull has not been allocated'
+          alloc_status = .false.
+       endif
+       if (.not. allocated(cospgridIN%phalf)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable (RTTOV): cospgridIN%phalf has not been allocated'
+          alloc_status = .false.
+       endif
+       if (.not. allocated(cospgridIN%at)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable (RTTOV): cospgridIN%at has not been allocated'
+          alloc_status = .false.
+       endif
+       if (.not. allocated(cospgridIN%qv)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable (RTTOV): cospgridIN%qv has not been allocated'
+          alloc_status = .false.
+       endif
+       if (.not. allocated(cospgridIN%o3)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable (RTTOV): cospgridIN%o3 has not been allocated'
+          alloc_status = .false.
+       endif
+       if (.not. allocated(cospgridIN%tca)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable (RTTOV): cospgridIN%tca has not been allocated'
+          alloc_status = .false.
+       endif
+       if (.not. allocated(cospgridIN%cloudIce)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable (RTTOV): cospgridIN%cloudIce has not been allocated'
+          alloc_status = .false.
+       endif
+       if (.not. allocated(cospgridIN%cloudLiq)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable (RTTOV): cospgridIN%cloudLiq has not been allocated'
+          alloc_status = .false.
+       endif
+       if (.not. allocated(cospgridIN%fl_rain)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable (RTTOV): cospgridIN%fl_rain has not been allocated'
+          alloc_status = .false.
+       endif
+       if (.not. allocated(cospgridIN%fl_snow)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable (RTTOV): cospgridIN%fl_snow has not been allocated'
+          alloc_status = .false.
+       endif
+       if (.not. alloc_status) then
+          Lrttov_column     = .false.
+          if (associated(cospOUT%rttov_tbs)) cospOUT%rttov_tbs(:,:)         = R_UNDEF          
+       endif
+    endif
+    
+    !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+    ! PART 1: Check input array values for out-of-bounds values. When an out-of-bound value
+    !         is encountered, COSP outputs that are dependent on that input are filled with
+    !         an undefined value (set in cosp_config.f90) and if necessary, that simulator
+    !         is turned off.
+    !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+    if (any([Lisccp_subcolumn, Lisccp_column, Lmisr_subcolumn, Lmisr_column, Lmodis_subcolumn, Lmodis_column])) then
+       if (any(cospgridIN%sunlit .lt. 0)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable: cospgridIN%sunlit contains values out of range (0 or 1)'
+          Lisccp_subcolumn = .false.
+          Lisccp_column    = .false.
+          Lmisr_subcolumn  = .false.
+          Lmisr_column     = .false.
+          Lmodis_subcolumn = .false.
+          Lmodis_column    = .false.
+          if (associated(cospOUT%isccp_totalcldarea))  cospOUT%isccp_totalcldarea(:)  = R_UNDEF
+          if (associated(cospOUT%isccp_meantb))        cospOUT%isccp_meantb(:)        = R_UNDEF
+          if (associated(cospOUT%isccp_meantbclr))     cospOUT%isccp_meantbclr(:)     = R_UNDEF
+          if (associated(cospOUT%isccp_meanptop))      cospOUT%isccp_meanptop(:)      = R_UNDEF
+          if (associated(cospOUT%isccp_meantaucld))    cospOUT%isccp_meantaucld(:)    = R_UNDEF
+          if (associated(cospOUT%isccp_meanalbedocld)) cospOUT%isccp_meanalbedocld(:) = R_UNDEF
+          if (associated(cospOUT%isccp_boxtau))        cospOUT%isccp_boxtau(:,:)      = R_UNDEF
+          if (associated(cospOUT%isccp_boxptop))       cospOUT%isccp_boxptop(:,:)     = R_UNDEF
+          if (associated(cospOUT%isccp_fq))            cospOUT%isccp_fq(:,:,:)        = R_UNDEF
+          if (associated(cospOUT%misr_fq))                   cospOUT%misr_fq(:,:,:)                 = R_UNDEF
+          if (associated(cospOUT%misr_dist_model_layertops)) cospOUT%misr_dist_model_layertops(:,:) = R_UNDEF
+          if (associated(cospOUT%misr_meanztop))             cospOUT%misr_meanztop(:)               = R_UNDEF
+          if (associated(cospOUT%misr_cldarea))              cospOUT%misr_cldarea(:)                = R_UNDEF
+          if (associated(cospOUT%modis_Cloud_Fraction_Total_Mean))                          &
+               cospOUT%modis_Cloud_Fraction_Total_Mean(:)                   = R_UNDEF
+          if (associated(cospOUT%modis_Cloud_Fraction_Water_Mean))                          &
+               cospOUT%modis_Cloud_Fraction_Water_Mean(:)                   = R_UNDEF
+          if (associated(cospOUT%modis_Cloud_Fraction_Ice_Mean))                            &
+               cospOUT%modis_Cloud_Fraction_Ice_Mean(:)                     = R_UNDEF
+          if (associated(cospOUT%modis_Cloud_Fraction_High_Mean))                           &
+               cospOUT%modis_Cloud_Fraction_High_Mean(:)                    = R_UNDEF
+          if (associated(cospOUT%modis_Cloud_Fraction_Mid_Mean))                            &
+               cospOUT%modis_Cloud_Fraction_Mid_Mean(:)                     = R_UNDEF
+          if (associated(cospOUT%modis_Cloud_Fraction_Low_Mean))                            &
+               cospOUT%modis_Cloud_Fraction_Low_Mean(:)                     = R_UNDEF
+          if (associated(cospOUT%modis_Optical_Thickness_Total_Mean))                       &
+               cospOUT%modis_Optical_Thickness_Total_Mean(:)                = R_UNDEF
+          if (associated(cospOUT%modis_Optical_Thickness_Water_Mean))                       &
+               cospOUT%modis_Optical_Thickness_Water_Mean(:)                = R_UNDEF
+          if (associated(cospOUT%modis_Optical_Thickness_Ice_Mean))                         &
+               cospOUT%modis_Optical_Thickness_Ice_Mean(:)                  = R_UNDEF
+          if (associated(cospOUT%modis_Optical_Thickness_Total_LogMean))                    &
+               cospOUT%modis_Optical_Thickness_Total_LogMean(:)             = R_UNDEF
+          if (associated(cospOUT%modis_Optical_Thickness_Water_LogMean))                    &
+               cospOUT%modis_Optical_Thickness_Water_LogMean(:)             = R_UNDEF
+          if (associated(cospOUT%modis_Optical_Thickness_Ice_LogMean))                      &
+               cospOUT%modis_Optical_Thickness_Ice_LogMean(:)               = R_UNDEF
+          if (associated(cospOUT%modis_Cloud_Particle_Size_Water_Mean))                     &
+               cospOUT%modis_Cloud_Particle_Size_Water_Mean(:)              = R_UNDEF
+          if (associated(cospOUT%modis_Cloud_Particle_Size_Ice_Mean))                       &
+               cospOUT%modis_Cloud_Particle_Size_Ice_Mean(:)                = R_UNDEF
+          if (associated(cospOUT%modis_Cloud_Top_Pressure_Total_Mean))                      &
+               cospOUT%modis_Cloud_Top_Pressure_Total_Mean(:)               = R_UNDEF
+          if (associated(cospOUT%modis_Liquid_Water_Path_Mean))                             &
+               cospOUT%modis_Liquid_Water_Path_Mean(:)                      = R_UNDEF
+          if (associated(cospOUT%modis_Ice_Water_Path_Mean))                                &
+               cospOUT%modis_Ice_Water_Path_Mean(:)                         = R_UNDEF
+          if (associated(cospOUT%modis_Optical_Thickness_vs_Cloud_Top_Pressure))            &
+               cospOUT%modis_Optical_Thickness_vs_Cloud_Top_Pressure(:,:,:) = R_UNDEF
+          if (associated(cospOUT%modis_Optical_Thickness_vs_ReffICE))                       &
+               cospOUT%modis_Optical_Thickness_vs_ReffICE(:,:,:)            = R_UNDEF
+          if (associated(cospOUT%modis_Optical_Thickness_vs_ReffLIQ))                       &
+               cospOUT%modis_Optical_Thickness_vs_ReffLIQ(:,:,:)            = R_UNDEF
+       endif
+    endif
+
+    if (any([Lisccp_subcolumn, Lisccp_column, Lmisr_subcolumn, Lmisr_column, Lrttov_column,&
+         Lcalipso_column, Lcloudsat_column, Lradar_lidar_tcc,Llidar_only_freq_cloud, &
+         Lcloudsat_tcc, Lcloudsat_tcc2])) then
+       if (any(cospgridIN%at .lt. 0)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable: cospgridIN%at contains values out of range (at<0), expected units (K)'
+          Lisccp_subcolumn = .false.
+          Lisccp_column    = .false.
+          Lmisr_subcolumn  = .false.
+          Lmisr_column     = .false.
+          Lrttov_column    = .false.
+          Lcalipso_column  = .false.
+          Lcloudsat_column = .false.
+          Lradar_lidar_tcc = .false.
+          Llidar_only_freq_cloud = .false.
+          Lcloudsat_tcc    = .false.
+          Lcloudsat_tcc2   = .false.
+          if (associated(cospOUT%rttov_tbs)) cospOUT%rttov_tbs(:,:)         = R_UNDEF
+          if (associated(cospOUT%isccp_totalcldarea))  cospOUT%isccp_totalcldarea(:)  = R_UNDEF
+          if (associated(cospOUT%isccp_meantb))        cospOUT%isccp_meantb(:)        = R_UNDEF
+          if (associated(cospOUT%isccp_meantbclr))     cospOUT%isccp_meantbclr(:)     = R_UNDEF
+          if (associated(cospOUT%isccp_meanptop))      cospOUT%isccp_meanptop(:)      = R_UNDEF
+          if (associated(cospOUT%isccp_meantaucld))    cospOUT%isccp_meantaucld(:)    = R_UNDEF
+          if (associated(cospOUT%isccp_meanalbedocld)) cospOUT%isccp_meanalbedocld(:) = R_UNDEF
+          if (associated(cospOUT%isccp_boxtau))        cospOUT%isccp_boxtau(:,:)      = R_UNDEF
+          if (associated(cospOUT%isccp_boxptop))       cospOUT%isccp_boxptop(:,:)     = R_UNDEF
+          if (associated(cospOUT%isccp_fq))            cospOUT%isccp_fq(:,:,:)        = R_UNDEF
+          if (associated(cospOUT%misr_fq))                   cospOUT%misr_fq(:,:,:)                 = R_UNDEF
+          if (associated(cospOUT%misr_dist_model_layertops)) cospOUT%misr_dist_model_layertops(:,:) = R_UNDEF
+          if (associated(cospOUT%misr_meanztop))             cospOUT%misr_meanztop(:)               = R_UNDEF
+          if (associated(cospOUT%misr_cldarea))              cospOUT%misr_cldarea(:)                = R_UNDEF
+          if (associated(cospOUT%calipso_cfad_sr))       cospOUT%calipso_cfad_sr(:,:,:)       = R_UNDEF
+          if (associated(cospOUT%calipso_lidarcld))      cospOUT%calipso_lidarcld(:,:)        = R_UNDEF
+          if (associated(cospOUT%calipso_lidarcldphase)) cospOUT%calipso_lidarcldphase(:,:,:) = R_UNDEF
+          if (associated(cospOUT%calipso_cldlayer))      cospOUT%calipso_cldlayer(:,:)        = R_UNDEF
+          if (associated(cospOUT%calipso_cldlayerphase)) cospOUT%calipso_cldlayerphase(:,:,:) = R_UNDEF
+          if (associated(cospOUT%calipso_lidarcldtmp))   cospOUT%calipso_lidarcldtmp(:,:,:)   = R_UNDEF
+          if (associated(cospOUT%calipso_lidarcldtype))  cospOUT%calipso_lidarcldtype(:,:,:)  = R_UNDEF
+          if (associated(cospOUT%calipso_cldtype))       cospOUT%calipso_cldtype(:,:)         = R_UNDEF 
+          if (associated(cospOUT%calipso_cldtypetemp))   cospOUT%calipso_cldtypetemp(:,:)     = R_UNDEF 
+          if (associated(cospOUT%calipso_cldtypemeanz))  cospOUT%calipso_cldtypemeanz(:,:)    = R_UNDEF 
+          if (associated(cospOUT%calipso_cldtypemeanzse)) cospOUT%calipso_cldtypemeanzse(:,:) = R_UNDEF 
+          if (associated(cospOUT%calipso_cldthinemis))   cospOUT%calipso_cldthinemis(:)       = R_UNDEF
+          if (associated(cospOUT%cloudsat_cfad_ze))      cospOUT%cloudsat_cfad_ze(:,:,:)      = R_UNDEF
+          if (associated(cospOUT%lidar_only_freq_cloud)) cospOUT%lidar_only_freq_cloud(:,:)   = R_UNDEF
+          if (associated(cospOUT%radar_lidar_tcc))       cospOUT%radar_lidar_tcc(:)           = R_UNDEF
+          if (associated(cospOUT%cloudsat_tcc)) cospOUT%cloudsat_tcc(:) = R_UNDEF
+          if (associated(cospOUT%cloudsat_tcc2)) cospOUT%cloudsat_tcc2(:) = R_UNDEF
+       endif
+    endif
+    if (any([Lisccp_subcolumn, Lisccp_column, Lrttov_column])) then
+       if (any(cospgridIN%pfull .lt. 0)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable: cospgridIN%pfull contains values out of range'
+          Lisccp_subcolumn = .false.
+          Lisccp_column    = .false.
+          Lrttov_column    = .false.
+          if (associated(cospOUT%rttov_tbs))           cospOUT%rttov_tbs(:,:)         = R_UNDEF
+          if (associated(cospOUT%isccp_totalcldarea))  cospOUT%isccp_totalcldarea(:)  = R_UNDEF
+          if (associated(cospOUT%isccp_meantb))        cospOUT%isccp_meantb(:)        = R_UNDEF
+          if (associated(cospOUT%isccp_meantbclr))     cospOUT%isccp_meantbclr(:)     = R_UNDEF
+          if (associated(cospOUT%isccp_meanptop))      cospOUT%isccp_meanptop(:)      = R_UNDEF
+          if (associated(cospOUT%isccp_meantaucld))    cospOUT%isccp_meantaucld(:)    = R_UNDEF
+          if (associated(cospOUT%isccp_meanalbedocld)) cospOUT%isccp_meanalbedocld(:) = R_UNDEF
+          if (associated(cospOUT%isccp_boxtau))        cospOUT%isccp_boxtau(:,:)      = R_UNDEF
+          if (associated(cospOUT%isccp_boxptop))       cospOUT%isccp_boxptop(:,:)     = R_UNDEF
+          if (associated(cospOUT%isccp_fq))            cospOUT%isccp_fq(:,:,:)        = R_UNDEF
+       endif
+    endif
+    if (any([Lisccp_subcolumn,Lisccp_column,Lmodis_subcolumn,Lmodis_column,Lcalipso_column,Lrttov_column,&
+             LgrLidar532_column,Latlid_column])) then
+       if (any(cospgridIN%phalf .lt. 0)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable: cospgridIN%phalf contains values out of range'
+          Lisccp_subcolumn = .false.
+          Lisccp_column    = .false.
+          Lmodis_subcolumn = .false.
+          Lmodis_column    = .false.
+          Lcalipso_column  = .false.
+          Lrttov_column    = .false.
+          Latlid_column    = .false.
+          LgrLidar532_column = .false.
+          if (associated(cospOUT%rttov_tbs))           cospOUT%rttov_tbs(:,:)         = R_UNDEF
+          if (associated(cospOUT%isccp_totalcldarea))  cospOUT%isccp_totalcldarea(:)  = R_UNDEF
+          if (associated(cospOUT%isccp_meantb))        cospOUT%isccp_meantb(:)        = R_UNDEF
+          if (associated(cospOUT%isccp_meantbclr))     cospOUT%isccp_meantbclr(:)     = R_UNDEF
+          if (associated(cospOUT%isccp_meanptop))      cospOUT%isccp_meanptop(:)      = R_UNDEF
+          if (associated(cospOUT%isccp_meantaucld))    cospOUT%isccp_meantaucld(:)    = R_UNDEF
+          if (associated(cospOUT%isccp_meanalbedocld)) cospOUT%isccp_meanalbedocld(:) = R_UNDEF
+          if (associated(cospOUT%isccp_boxtau))        cospOUT%isccp_boxtau(:,:)      = R_UNDEF
+          if (associated(cospOUT%isccp_boxptop))       cospOUT%isccp_boxptop(:,:)     = R_UNDEF
+          if (associated(cospOUT%isccp_fq))            cospOUT%isccp_fq(:,:,:)        = R_UNDEF
+          if (associated(cospOUT%modis_Cloud_Fraction_Total_Mean))                          &
+               cospOUT%modis_Cloud_Fraction_Total_Mean(:)                   = R_UNDEF
+          if (associated(cospOUT%modis_Cloud_Fraction_Water_Mean))                          &
+               cospOUT%modis_Cloud_Fraction_Water_Mean(:)                   = R_UNDEF
+          if (associated(cospOUT%modis_Cloud_Fraction_Ice_Mean))                            &
+               cospOUT%modis_Cloud_Fraction_Ice_Mean(:)                     = R_UNDEF
+          if (associated(cospOUT%modis_Cloud_Fraction_High_Mean))                           &
+               cospOUT%modis_Cloud_Fraction_High_Mean(:)                    = R_UNDEF
+          if (associated(cospOUT%modis_Cloud_Fraction_Mid_Mean))                            &
+               cospOUT%modis_Cloud_Fraction_Mid_Mean(:)                     = R_UNDEF
+          if (associated(cospOUT%modis_Cloud_Fraction_Low_Mean))                            &
+               cospOUT%modis_Cloud_Fraction_Low_Mean(:)                     = R_UNDEF
+          if (associated(cospOUT%modis_Optical_Thickness_Total_Mean))                       &
+               cospOUT%modis_Optical_Thickness_Total_Mean(:)                = R_UNDEF
+          if (associated(cospOUT%modis_Optical_Thickness_Water_Mean))                       &
+               cospOUT%modis_Optical_Thickness_Water_Mean(:)                = R_UNDEF
+          if (associated(cospOUT%modis_Optical_Thickness_Ice_Mean))                         &
+               cospOUT%modis_Optical_Thickness_Ice_Mean(:)                  = R_UNDEF
+          if (associated(cospOUT%modis_Optical_Thickness_Total_LogMean))                    &
+               cospOUT%modis_Optical_Thickness_Total_LogMean(:)             = R_UNDEF
+          if (associated(cospOUT%modis_Optical_Thickness_Water_LogMean))                    &
+               cospOUT%modis_Optical_Thickness_Water_LogMean(:)             = R_UNDEF
+          if (associated(cospOUT%modis_Optical_Thickness_Ice_LogMean))                      &
+               cospOUT%modis_Optical_Thickness_Ice_LogMean(:)               = R_UNDEF
+          if (associated(cospOUT%modis_Cloud_Particle_Size_Water_Mean))                     &
+               cospOUT%modis_Cloud_Particle_Size_Water_Mean(:)              = R_UNDEF
+          if (associated(cospOUT%modis_Cloud_Particle_Size_Ice_Mean))                       &
+               cospOUT%modis_Cloud_Particle_Size_Ice_Mean(:)                = R_UNDEF
+          if (associated(cospOUT%modis_Cloud_Top_Pressure_Total_Mean))                      &
+               cospOUT%modis_Cloud_Top_Pressure_Total_Mean(:)               = R_UNDEF
+          if (associated(cospOUT%modis_Liquid_Water_Path_Mean))                             &
+               cospOUT%modis_Liquid_Water_Path_Mean(:)                      = R_UNDEF
+          if (associated(cospOUT%modis_Ice_Water_Path_Mean))                                &
+               cospOUT%modis_Ice_Water_Path_Mean(:)                         = R_UNDEF
+          if (associated(cospOUT%modis_Optical_Thickness_vs_Cloud_Top_Pressure))            &
+               cospOUT%modis_Optical_Thickness_vs_Cloud_Top_Pressure(:,:,:) = R_UNDEF
+          if (associated(cospOUT%modis_Optical_Thickness_vs_ReffICE))                       &
+               cospOUT%modis_Optical_Thickness_vs_ReffICE(:,:,:)            = R_UNDEF
+          if (associated(cospOUT%modis_Optical_Thickness_vs_ReffLIQ))                       &
+               cospOUT%modis_Optical_Thickness_vs_ReffLIQ(:,:,:)            = R_UNDEF
+          if (associated(cospOUT%calipso_cfad_sr))       cospOUT%calipso_cfad_sr(:,:,:)       = R_UNDEF
+          if (associated(cospOUT%calipso_lidarcld))      cospOUT%calipso_lidarcld(:,:)        = R_UNDEF
+          if (associated(cospOUT%calipso_lidarcldphase)) cospOUT%calipso_lidarcldphase(:,:,:) = R_UNDEF
+          if (associated(cospOUT%calipso_cldlayer))      cospOUT%calipso_cldlayer(:,:)        = R_UNDEF
+          if (associated(cospOUT%calipso_cldlayerphase)) cospOUT%calipso_cldlayerphase(:,:,:) = R_UNDEF
+          if (associated(cospOUT%calipso_lidarcldtmp))   cospOUT%calipso_lidarcldtmp(:,:,:)   = R_UNDEF
+          if (associated(cospOUT%atlid_cfad_sr))         cospOUT%atlid_cfad_sr(:,:,:)         = R_UNDEF
+          if (associated(cospOUT%atlid_lidarcld))        cospOUT%atlid_lidarcld(:,:)          = R_UNDEF
+          if (associated(cospOUT%atlid_cldlayer))        cospOUT%atlid_cldlayer(:,:)          = R_UNDEF
+          if (associated(cospOUT%grLidar532_cfad_sr))   cospOUT%grLidar532_cfad_sr(:,:,:)   = R_UNDEF
+          if (associated(cospOUT%grLidar532_lidarcld))  cospOUT%grLidar532_lidarcld(:,:)    = R_UNDEF
+          if (associated(cospOUT%grLidar532_cldlayer))  cospOUT%grLidar532_cldlayer(:,:)    = R_UNDEF
+          if (associated(cospOUT%calipso_lidarcldtype))  cospOUT%calipso_lidarcldtype(:,:,:)  = R_UNDEF 
+          if (associated(cospOUT%calipso_cldtype))       cospOUT%calipso_cldtype(:,:)         = R_UNDEF 
+          if (associated(cospOUT%calipso_cldtypetemp))   cospOUT%calipso_cldtypetemp(:,:)     = R_UNDEF
+          if (associated(cospOUT%calipso_cldtypemeanz))  cospOUT%calipso_cldtypemeanz(:,:)    = R_UNDEF
+          if (associated(cospOUT%calipso_cldtypemeanzse)) cospOUT%calipso_cldtypemeanzse(:,:) = R_UNDEF
+          if (associated(cospOUT%calipso_cldthinemis))   cospOUT%calipso_cldthinemis(:)       = R_UNDEF
+       endif
+    endif
+    if (any([Lisccp_subcolumn,Lisccp_column,Lrttov_column])) then
+       if (any(cospgridIN%qv .lt. 0)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable: cospgridIN%qv contains values out of range'
+          Lisccp_subcolumn = .false.
+          Lisccp_column    = .false.
+          Lrttov_column    = .false.
+          if (associated(cospOUT%rttov_tbs))           cospOUT%rttov_tbs(:,:)         = R_UNDEF
+          if (associated(cospOUT%isccp_totalcldarea))  cospOUT%isccp_totalcldarea(:)  = R_UNDEF
+          if (associated(cospOUT%isccp_meantb))        cospOUT%isccp_meantb(:)        = R_UNDEF
+          if (associated(cospOUT%isccp_meantbclr))     cospOUT%isccp_meantbclr(:)     = R_UNDEF
+          if (associated(cospOUT%isccp_meanptop))      cospOUT%isccp_meanptop(:)      = R_UNDEF
+          if (associated(cospOUT%isccp_meantaucld))    cospOUT%isccp_meantaucld(:)    = R_UNDEF
+          if (associated(cospOUT%isccp_meanalbedocld)) cospOUT%isccp_meanalbedocld(:) = R_UNDEF
+          if (associated(cospOUT%isccp_boxtau))        cospOUT%isccp_boxtau(:,:)      = R_UNDEF
+          if (associated(cospOUT%isccp_boxptop))       cospOUT%isccp_boxptop(:,:)     = R_UNDEF
+          if (associated(cospOUT%isccp_fq))            cospOUT%isccp_fq(:,:,:)        = R_UNDEF
+       endif
+    endif
+    if (any([Lmisr_subcolumn,Lmisr_column,Lcloudsat_subcolumn,Lcloudsat_column,Lcalipso_column,Lradar_lidar_tcc,&
+         Llidar_only_freq_cloud,LgrLidar532_column,Latlid_column,Lcloudsat_tcc, Lcloudsat_tcc2])) then
+       if (any(cospgridIN%hgt_matrix .lt. -300)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable: cospgridIN%hgt_matrix contains values out of range'
+          Lmisr_subcolumn     = .false.
+          Lmisr_column        = .false.
+          Lcloudsat_subcolumn = .false.
+          Lcloudsat_column    = .false.
+          Lcalipso_column     = .false.
+          Lradar_lidar_tcc    = .false.
+          Llidar_only_freq_cloud = .false.
+          Lcloudsat_tcc       = .false.
+          Lcloudsat_tcc2      = .false.
+          Latlid_column       = .false.
+          LgrLidar532_column  = .false.
+          if (associated(cospOUT%misr_fq))                   cospOUT%misr_fq(:,:,:)                 = R_UNDEF
+          if (associated(cospOUT%misr_dist_model_layertops)) cospOUT%misr_dist_model_layertops(:,:) = R_UNDEF
+          if (associated(cospOUT%misr_meanztop))             cospOUT%misr_meanztop(:)               = R_UNDEF
+          if (associated(cospOUT%misr_cldarea))              cospOUT%misr_cldarea(:)                = R_UNDEF
+          if (associated(cospOUT%calipso_cfad_sr))           cospOUT%calipso_cfad_sr(:,:,:)         = R_UNDEF
+          if (associated(cospOUT%calipso_lidarcld))          cospOUT%calipso_lidarcld(:,:)          = R_UNDEF
+          if (associated(cospOUT%calipso_lidarcldphase))     cospOUT%calipso_lidarcldphase(:,:,:)   = R_UNDEF
+          if (associated(cospOUT%calipso_cldlayer))          cospOUT%calipso_cldlayer(:,:)          = R_UNDEF
+          if (associated(cospOUT%calipso_cldlayerphase))     cospOUT%calipso_cldlayerphase(:,:,:)   = R_UNDEF
+          if (associated(cospOUT%calipso_lidarcldtmp))       cospOUT%calipso_lidarcldtmp(:,:,:)     = R_UNDEF
+          if (associated(cospOUT%cloudsat_cfad_ze))          cospOUT%cloudsat_cfad_ze(:,:,:)        = R_UNDEF
+          if (associated(cospOUT%cloudsat_Ze_tot))           cospOUT%cloudsat_Ze_tot(:,:,:)         = R_UNDEF
+          if (associated(cospOUT%lidar_only_freq_cloud))     cospOUT%lidar_only_freq_cloud(:,:)     = R_UNDEF
+          if (associated(cospOUT%radar_lidar_tcc))           cospOUT%radar_lidar_tcc(:)             = R_UNDEF
+          if (associated(cospOUT%cloudsat_tcc))              cospOUT%cloudsat_tcc(:)                = R_UNDEF
+          if (associated(cospOUT%cloudsat_tcc2))             cospOUT%cloudsat_tcc2(:)               = R_UNDEF
+          if (associated(cospOUT%atlid_cfad_sr))             cospOUT%atlid_cfad_sr(:,:,:)           = R_UNDEF
+          if (associated(cospOUT%atlid_lidarcld))            cospOUT%atlid_lidarcld(:,:)            = R_UNDEF
+          if (associated(cospOUT%atlid_cldlayer))            cospOUT%atlid_cldlayer(:,:)            = R_UNDEF
+          if (associated(cospOUT%grLidar532_cfad_sr))        cospOUT%grLidar532_cfad_sr(:,:,:)      = R_UNDEF
+          if (associated(cospOUT%grLidar532_lidarcld))       cospOUT%grLidar532_lidarcld(:,:)       = R_UNDEF
+          if (associated(cospOUT%grLidar532_cldlayer))       cospOUT%grLidar532_cldlayer(:,:)       = R_UNDEF
+          if (associated(cospOUT%calipso_lidarcldtype))      cospOUT%calipso_lidarcldtype(:,:,:)    = R_UNDEF
+          if (associated(cospOUT%calipso_cldtype))           cospOUT%calipso_cldtype(:,:)           = R_UNDEF 
+          if (associated(cospOUT%calipso_cldtypetemp))       cospOUT%calipso_cldtypetemp(:,:)       = R_UNDEF 
+          if (associated(cospOUT%calipso_cldtypemeanz))      cospOUT%calipso_cldtypemeanz(:,:)      = R_UNDEF 
+          if (associated(cospOUT%calipso_cldtypemeanzse))    cospOUT%calipso_cldtypemeanzse(:,:)    = R_UNDEF
+          if (associated(cospOUT%calipso_cldthinemis))       cospOUT%calipso_cldthinemis(:)         = R_UNDEF
+       endif
+    endif
+    if (any([Lrttov_column,Lcloudsat_column,Lcalipso_column,Lradar_lidar_tcc,Llidar_only_freq_cloud, &
+             LgrLidar532_column, Latlid_column, Lcloudsat_tcc, Lcloudsat_tcc2])) then
+       if (any(cospgridIN%hgt_matrix_half .lt. -300)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable: cospgridIN%hgt_matrix_half contains values out of range'
+          Lrttov_column    = .false.
+          Lcloudsat_column = .false.
+          Lcalipso_column  = .false.
+          Lradar_lidar_tcc = .false.
+          Llidar_only_freq_cloud = .false.
+          Lcloudsat_tcc    = .false.
+          Lcloudsat_tcc2   = .false.
+          Latlid_column       = .false.
+          LgrLidar532_column = .false.
+          if (associated(cospOUT%rttov_tbs))              cospOUT%rttov_tbs(:,:)               = R_UNDEF
+          if (associated(cospOUT%calipso_cfad_sr))        cospOUT%calipso_cfad_sr(:,:,:)       = R_UNDEF
+          if (associated(cospOUT%calipso_lidarcld))       cospOUT%calipso_lidarcld(:,:)        = R_UNDEF
+          if (associated(cospOUT%calipso_lidarcldphase))  cospOUT%calipso_lidarcldphase(:,:,:) = R_UNDEF
+          if (associated(cospOUT%calipso_cldlayer))       cospOUT%calipso_cldlayer(:,:)        = R_UNDEF
+          if (associated(cospOUT%calipso_cldlayerphase))  cospOUT%calipso_cldlayerphase(:,:,:) = R_UNDEF
+          if (associated(cospOUT%calipso_lidarcldtmp))    cospOUT%calipso_lidarcldtmp(:,:,:)   = R_UNDEF
+          if (associated(cospOUT%cloudsat_cfad_ze))       cospOUT%cloudsat_cfad_ze(:,:,:)      = R_UNDEF
+          if (associated(cospOUT%lidar_only_freq_cloud))  cospOUT%lidar_only_freq_cloud(:,:)   = R_UNDEF
+          if (associated(cospOUT%radar_lidar_tcc))        cospOUT%radar_lidar_tcc(:)           = R_UNDEF
+          if (associated(cospOUT%cloudsat_tcc))           cospOUT%cloudsat_tcc(:)              = R_UNDEF
+          if (associated(cospOUT%cloudsat_tcc2))          cospOUT%cloudsat_tcc2(:)             = R_UNDEF          
+          if (associated(cospOUT%atlid_cfad_sr))          cospOUT%atlid_cfad_sr(:,:,:)         = R_UNDEF
+          if (associated(cospOUT%atlid_lidarcld))         cospOUT%atlid_lidarcld(:,:)          = R_UNDEF
+          if (associated(cospOUT%atlid_cldlayer))         cospOUT%atlid_cldlayer(:,:)          = R_UNDEF
+          if (associated(cospOUT%grLidar532_cfad_sr))     cospOUT%grLidar532_cfad_sr(:,:,:)    = R_UNDEF
+          if (associated(cospOUT%grLidar532_lidarcld))    cospOUT%grLidar532_lidarcld(:,:)     = R_UNDEF
+          if (associated(cospOUT%grLidar532_cldlayer))    cospOUT%grLidar532_cldlayer(:,:)     = R_UNDEF
+          if (associated(cospOUT%calipso_lidarcldtype))   cospOUT%calipso_lidarcldtype(:,:,:)  = R_UNDEF
+          if (associated(cospOUT%calipso_cldtype))        cospOUT%calipso_cldtype(:,:)         = R_UNDEF 
+          if (associated(cospOUT%calipso_cldtypetemp))    cospOUT%calipso_cldtypetemp(:,:)     = R_UNDEF 
+          if (associated(cospOUT%calipso_cldtypemeanz))   cospOUT%calipso_cldtypemeanz(:,:)    = R_UNDEF 
+          if (associated(cospOUT%calipso_cldtypemeanzse)) cospOUT%calipso_cldtypemeanzse(:,:)  = R_UNDEF 
+          if (associated(cospOUT%calipso_cldthinemis))    cospOUT%calipso_cldthinemis(:)       = R_UNDEF
+       endif
+    endif
+    if (any([Lrttov_column,Lcalipso_column,Lparasol_column])) then
+       if (any(cospgridIN%land .lt. 0)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable: cospgridIN%land contains values out of range'
+          Lrttov_column    = .false.
+          Lcalipso_column  = .false.
+          Lparasol_column  = .false.
+          if (associated(cospOUT%rttov_tbs))             cospOUT%rttov_tbs(:,:)               = R_UNDEF
+          if (associated(cospOUT%calipso_cfad_sr))       cospOUT%calipso_cfad_sr(:,:,:)       = R_UNDEF
+          if (associated(cospOUT%calipso_lidarcld))      cospOUT%calipso_lidarcld(:,:)        = R_UNDEF
+          if (associated(cospOUT%calipso_lidarcldphase)) cospOUT%calipso_lidarcldphase(:,:,:) = R_UNDEF
+          if (associated(cospOUT%calipso_cldlayer))      cospOUT%calipso_cldlayer(:,:)        = R_UNDEF
+          if (associated(cospOUT%calipso_cldlayerphase)) cospOUT%calipso_cldlayerphase(:,:,:) = R_UNDEF
+          if (associated(cospOUT%calipso_lidarcldtmp))   cospOUT%calipso_lidarcldtmp(:,:,:)   = R_UNDEF
+          if (associated(cospOUT%calipso_lidarcldtype))  cospOUT%calipso_lidarcldtype(:,:,:)  = R_UNDEF
+          if (associated(cospOUT%calipso_cldtype))       cospOUT%calipso_cldtype(:,:)         = R_UNDEF 
+          if (associated(cospOUT%calipso_cldtypetemp))   cospOUT%calipso_cldtypetemp(:,:)     = R_UNDEF 
+          if (associated(cospOUT%calipso_cldtypemeanz))  cospOUT%calipso_cldtypemeanz(:,:)    = R_UNDEF
+          if (associated(cospOUT%calipso_cldtypemeanzse)) cospOUT%calipso_cldtypemeanzse(:,:) = R_UNDEF
+          if (associated(cospOUT%calipso_cldthinemis))   cospOUT%calipso_cldthinemis(:)       = R_UNDEF
+          if (associated(cospOUT%parasolGrid_refl))      cospOUT%parasolGrid_refl(:,:)        = R_UNDEF
+       endif
+    endif
+    if (any([Lisccp_subcolumn,Lisccp_column,Lrttov_column])) then
+       if (any(cospgridIN%skt .lt. 0)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable: cospgridIN%skt contains values out of range'
+          Lisccp_subcolumn = .false.
+          Lisccp_column    = .false.
+          Lrttov_column    = .false.
+          if (associated(cospOUT%rttov_tbs))           cospOUT%rttov_tbs(:,:)         = R_UNDEF
+          if (associated(cospOUT%isccp_totalcldarea))  cospOUT%isccp_totalcldarea(:)  = R_UNDEF
+          if (associated(cospOUT%isccp_meantb))        cospOUT%isccp_meantb(:)        = R_UNDEF
+          if (associated(cospOUT%isccp_meantbclr))     cospOUT%isccp_meantbclr(:)     = R_UNDEF
+          if (associated(cospOUT%isccp_meanptop))      cospOUT%isccp_meanptop(:)      = R_UNDEF
+          if (associated(cospOUT%isccp_meantaucld))    cospOUT%isccp_meantaucld(:)    = R_UNDEF
+          if (associated(cospOUT%isccp_meanalbedocld)) cospOUT%isccp_meanalbedocld(:) = R_UNDEF
+          if (associated(cospOUT%isccp_boxtau))        cospOUT%isccp_boxtau(:,:)      = R_UNDEF
+          if (associated(cospOUT%isccp_boxptop))       cospOUT%isccp_boxptop(:,:)     = R_UNDEF
+          if (associated(cospOUT%isccp_fq))            cospOUT%isccp_fq(:,:,:)        = R_UNDEF
+       endif
+    endif
+    
+    ! RTTOV Inputs
+    if (Lrttov_column) then
+       if (cospgridIN%zenang .lt. -90. .OR. cospgridIN%zenang .gt. 90) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable: cospgridIN%zenang contains values out of range'
+          Lrttov_column = .false.
+          if (associated(cospOUT%rttov_tbs)) cospOUT%rttov_tbs(:,:) = R_UNDEF
+       endif
+       if (cospgridIN%co2 .lt. 0) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable: cospgridIN%co2 contains values out of range'
+          Lrttov_column = .false.
+          if (associated(cospOUT%rttov_tbs)) cospOUT%rttov_tbs(:,:) = R_UNDEF
+       endif
+       if (cospgridIN%ch4 .lt. 0) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable: cospgridIN%ch4 contains values out of range'
+          Lrttov_column = .false.
+          if (associated(cospOUT%rttov_tbs)) cospOUT%rttov_tbs(:,:) = R_UNDEF
+       endif
+       if (cospgridIN%n2o .lt. 0) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable: cospgridIN%n2o contains values out of range'
+          Lrttov_column = .false.
+          if (associated(cospOUT%rttov_tbs)) cospOUT%rttov_tbs(:,:) = R_UNDEF
+       endif
+       if (cospgridIN%co.lt. 0) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable: cospgridIN%co contains values out of range'
+          Lrttov_column = .false.
+          if (associated(cospOUT%rttov_tbs)) cospOUT%rttov_tbs(:,:) = R_UNDEF
+       endif
+       if (any(cospgridIN%o3 .lt. 0)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable: cospgridIN%o3 contains values out of range'
+          Lrttov_column = .false.
+          if (associated(cospOUT%rttov_tbs)) cospOUT%rttov_tbs(:,:) = R_UNDEF
+       endif
+       if (any(cospgridIN%emis_sfc .lt. 0. .OR. cospgridIN%emis_sfc .gt. 1)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable: cospgridIN%emis_sfc contains values out of range'
+          Lrttov_column = .false.
+          if (associated(cospOUT%rttov_tbs)) cospOUT%rttov_tbs(:,:) = R_UNDEF
+       endif
+       if (any(cospgridIN%u_sfc .lt. -100. .OR. cospgridIN%u_sfc .gt. 100.)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable: cospIN%u_sfc contains values out of range'
+          if (associated(cospOUT%rttov_tbs)) cospOUT%rttov_tbs(:,:) = R_UNDEF
+          Lrttov_column = .false.
+       endif
+       if (any(cospgridIN%v_sfc .lt. -100. .OR. cospgridIN%v_sfc .gt. 100.)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable: cospIN%v_sfc contains values out of range'
+          Lrttov_column = .false.
+          if (associated(cospOUT%rttov_tbs)) cospOUT%rttov_tbs(:,:) = R_UNDEF
+       endif
+       if (any(cospgridIN%lat .lt. -90 .OR. cospgridIN%lat .gt. 90)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable: cospIN%lat contains values out of range'
+          Lrttov_column = .false.
+          if (associated(cospOUT%rttov_tbs)) cospOUT%rttov_tbs(:,:) = R_UNDEF
+       endif
+    endif
+    
+    ! COSP_INPUTS
+    if (any([Lisccp_subcolumn,Lisccp_column])) then
+       if (cospIN%emsfc_lw .lt. 0. .OR. cospIN%emsfc_lw .gt. 1.) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable: cospIN%emsfc_lw contains values out of range'
+          Lisccp_subcolumn = .false.
+          Lisccp_column    = .false.
+          if (associated(cospOUT%isccp_totalcldarea))  cospOUT%isccp_totalcldarea(:)  = R_UNDEF
+          if (associated(cospOUT%isccp_meantb))        cospOUT%isccp_meantb(:)        = R_UNDEF
+          if (associated(cospOUT%isccp_meantbclr))     cospOUT%isccp_meantbclr(:)     = R_UNDEF
+          if (associated(cospOUT%isccp_meanptop))      cospOUT%isccp_meanptop(:)      = R_UNDEF
+          if (associated(cospOUT%isccp_meantaucld))    cospOUT%isccp_meantaucld(:)    = R_UNDEF
+          if (associated(cospOUT%isccp_meanalbedocld)) cospOUT%isccp_meanalbedocld(:) = R_UNDEF
+          if (associated(cospOUT%isccp_boxtau))        cospOUT%isccp_boxtau(:,:)      = R_UNDEF
+          if (associated(cospOUT%isccp_boxptop))       cospOUT%isccp_boxptop(:,:)     = R_UNDEF
+          if (associated(cospOUT%isccp_fq))            cospOUT%isccp_fq(:,:,:)        = R_UNDEF
+       endif
+    endif
+    if (any([Lisccp_subcolumn,Lisccp_column,Lmisr_subcolumn,Lmisr_column,Lmodis_subcolumn,Lmodis_column])) then
+       if (any(cospIN%tau_067 .lt. 0)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable: cospIN%tau_067 contains values out of range'
+          Lisccp_subcolumn = .false.
+          Lisccp_column    = .false.
+          Lmisr_subcolumn  = .false.
+          Lmisr_column     = .false.
+          Lmodis_subcolumn = .false.
+          Lmodis_column    = .false.
+          if (associated(cospOUT%isccp_totalcldarea))  cospOUT%isccp_totalcldarea(:)  = R_UNDEF
+          if (associated(cospOUT%isccp_meantb))        cospOUT%isccp_meantb(:)        = R_UNDEF
+          if (associated(cospOUT%isccp_meantbclr))     cospOUT%isccp_meantbclr(:)     = R_UNDEF
+          if (associated(cospOUT%isccp_meanptop))      cospOUT%isccp_meanptop(:)      = R_UNDEF
+          if (associated(cospOUT%isccp_meantaucld))    cospOUT%isccp_meantaucld(:)    = R_UNDEF
+          if (associated(cospOUT%isccp_meanalbedocld)) cospOUT%isccp_meanalbedocld(:) = R_UNDEF
+          if (associated(cospOUT%isccp_boxtau))        cospOUT%isccp_boxtau(:,:)      = R_UNDEF
+          if (associated(cospOUT%isccp_boxptop))       cospOUT%isccp_boxptop(:,:)     = R_UNDEF
+          if (associated(cospOUT%isccp_fq))            cospOUT%isccp_fq(:,:,:)        = R_UNDEF
+          if (associated(cospOUT%misr_fq))                   cospOUT%misr_fq(:,:,:)                 = R_UNDEF
+          if (associated(cospOUT%misr_dist_model_layertops)) cospOUT%misr_dist_model_layertops(:,:) = R_UNDEF
+          if (associated(cospOUT%misr_meanztop))             cospOUT%misr_meanztop(:)               = R_UNDEF
+          if (associated(cospOUT%misr_cldarea))              cospOUT%misr_cldarea(:)                = R_UNDEF
+          if (associated(cospOUT%modis_Cloud_Fraction_Total_Mean))                          &
+               cospOUT%modis_Cloud_Fraction_Total_Mean(:)                   = R_UNDEF
+          if (associated(cospOUT%modis_Cloud_Fraction_Water_Mean))                          &
+               cospOUT%modis_Cloud_Fraction_Water_Mean(:)                   = R_UNDEF
+          if (associated(cospOUT%modis_Cloud_Fraction_Ice_Mean))                            &
+               cospOUT%modis_Cloud_Fraction_Ice_Mean(:)                     = R_UNDEF
+          if (associated(cospOUT%modis_Cloud_Fraction_High_Mean))                           &
+               cospOUT%modis_Cloud_Fraction_High_Mean(:)                    = R_UNDEF
+          if (associated(cospOUT%modis_Cloud_Fraction_Mid_Mean))                            &
+               cospOUT%modis_Cloud_Fraction_Mid_Mean(:)                     = R_UNDEF
+          if (associated(cospOUT%modis_Cloud_Fraction_Low_Mean))                            &
+               cospOUT%modis_Cloud_Fraction_Low_Mean(:)                     = R_UNDEF
+          if (associated(cospOUT%modis_Optical_Thickness_Total_Mean))                       &
+               cospOUT%modis_Optical_Thickness_Total_Mean(:)                = R_UNDEF
+          if (associated(cospOUT%modis_Optical_Thickness_Water_Mean))                       &
+               cospOUT%modis_Optical_Thickness_Water_Mean(:)                = R_UNDEF
+          if (associated(cospOUT%modis_Optical_Thickness_Ice_Mean))                         &
+               cospOUT%modis_Optical_Thickness_Ice_Mean(:)                  = R_UNDEF
+          if (associated(cospOUT%modis_Optical_Thickness_Total_LogMean))                    &
+               cospOUT%modis_Optical_Thickness_Total_LogMean(:)             = R_UNDEF
+          if (associated(cospOUT%modis_Optical_Thickness_Water_LogMean))                    &
+               cospOUT%modis_Optical_Thickness_Water_LogMean(:)             = R_UNDEF
+          if (associated(cospOUT%modis_Optical_Thickness_Ice_LogMean))                      &
+               cospOUT%modis_Optical_Thickness_Ice_LogMean(:)               = R_UNDEF
+          if (associated(cospOUT%modis_Cloud_Particle_Size_Water_Mean))                     &
+               cospOUT%modis_Cloud_Particle_Size_Water_Mean(:)              = R_UNDEF
+          if (associated(cospOUT%modis_Cloud_Particle_Size_Ice_Mean))                       &
+               cospOUT%modis_Cloud_Particle_Size_Ice_Mean(:)                = R_UNDEF
+          if (associated(cospOUT%modis_Cloud_Top_Pressure_Total_Mean))                      &
+               cospOUT%modis_Cloud_Top_Pressure_Total_Mean(:)               = R_UNDEF
+          if (associated(cospOUT%modis_Liquid_Water_Path_Mean))                             &
+               cospOUT%modis_Liquid_Water_Path_Mean(:)                      = R_UNDEF
+          if (associated(cospOUT%modis_Ice_Water_Path_Mean))                                &
+               cospOUT%modis_Ice_Water_Path_Mean(:)                         = R_UNDEF
+          if (associated(cospOUT%modis_Optical_Thickness_vs_Cloud_Top_Pressure))            &
+               cospOUT%modis_Optical_Thickness_vs_Cloud_Top_Pressure(:,:,:) = R_UNDEF
+          if (associated(cospOUT%modis_Optical_Thickness_vs_ReffICE))                       &
+               cospOUT%modis_Optical_Thickness_vs_ReffICE(:,:,:)            = R_UNDEF
+          if (associated(cospOUT%modis_Optical_Thickness_vs_ReffLIQ))                       &
+               cospOUT%modis_Optical_Thickness_vs_ReffLIQ(:,:,:)            = R_UNDEF
+       endif
+    endif
+    if (any([Lisccp_subcolumn,Lisccp_column])) then
+       if (any(cospIN%emiss_11 .lt. 0. .OR. cospIN%emiss_11 .gt. 1)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable: cospIN%emiss_11 contains values out of range'
+          Lisccp_subcolumn = .false.
+          Lisccp_column    = .false.
+          if (associated(cospOUT%isccp_totalcldarea))  cospOUT%isccp_totalcldarea(:)  = R_UNDEF
+          if (associated(cospOUT%isccp_meantb))        cospOUT%isccp_meantb(:)        = R_UNDEF
+          if (associated(cospOUT%isccp_meantbclr))     cospOUT%isccp_meantbclr(:)     = R_UNDEF
+          if (associated(cospOUT%isccp_meanptop))      cospOUT%isccp_meanptop(:)      = R_UNDEF
+          if (associated(cospOUT%isccp_meantaucld))    cospOUT%isccp_meantaucld(:)    = R_UNDEF
+          if (associated(cospOUT%isccp_meanalbedocld)) cospOUT%isccp_meanalbedocld(:) = R_UNDEF
+          if (associated(cospOUT%isccp_boxtau))        cospOUT%isccp_boxtau(:,:)      = R_UNDEF
+          if (associated(cospOUT%isccp_boxptop))       cospOUT%isccp_boxptop(:,:)     = R_UNDEF
+          if (associated(cospOUT%isccp_fq))            cospOUT%isccp_fq(:,:,:)        = R_UNDEF
+       endif
+    endif
+    if (any([Lmodis_subcolumn,Lmodis_column])) then
+       if (any(cospIN%asym .lt. -1. .OR. cospIN%asym .gt. 1)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable: cospIN%asym contains values out of range'
+          Lmodis_subcolumn = .false.
+          Lmodis_column    = .false.
+          if (associated(cospOUT%modis_Cloud_Fraction_Total_Mean))                          &
+               cospOUT%modis_Cloud_Fraction_Total_Mean(:)                   = R_UNDEF
+          if (associated(cospOUT%modis_Cloud_Fraction_Water_Mean))                          &
+               cospOUT%modis_Cloud_Fraction_Water_Mean(:)                   = R_UNDEF
+          if (associated(cospOUT%modis_Cloud_Fraction_Ice_Mean))                            &
+               cospOUT%modis_Cloud_Fraction_Ice_Mean(:)                     = R_UNDEF
+          if (associated(cospOUT%modis_Cloud_Fraction_High_Mean))                           &
+               cospOUT%modis_Cloud_Fraction_High_Mean(:)                    = R_UNDEF
+          if (associated(cospOUT%modis_Cloud_Fraction_Mid_Mean))                            &
+               cospOUT%modis_Cloud_Fraction_Mid_Mean(:)                     = R_UNDEF
+          if (associated(cospOUT%modis_Cloud_Fraction_Low_Mean))                            &
+               cospOUT%modis_Cloud_Fraction_Low_Mean(:)                     = R_UNDEF
+          if (associated(cospOUT%modis_Optical_Thickness_Total_Mean))                       &
+               cospOUT%modis_Optical_Thickness_Total_Mean(:)                = R_UNDEF
+          if (associated(cospOUT%modis_Optical_Thickness_Water_Mean))                       &
+               cospOUT%modis_Optical_Thickness_Water_Mean(:)                = R_UNDEF
+          if (associated(cospOUT%modis_Optical_Thickness_Ice_Mean))                         &
+               cospOUT%modis_Optical_Thickness_Ice_Mean(:)                  = R_UNDEF
+          if (associated(cospOUT%modis_Optical_Thickness_Total_LogMean))                    &
+               cospOUT%modis_Optical_Thickness_Total_LogMean(:)             = R_UNDEF
+          if (associated(cospOUT%modis_Optical_Thickness_Water_LogMean))                    &
+               cospOUT%modis_Optical_Thickness_Water_LogMean(:)             = R_UNDEF
+          if (associated(cospOUT%modis_Optical_Thickness_Ice_LogMean))                      &
+               cospOUT%modis_Optical_Thickness_Ice_LogMean(:)               = R_UNDEF
+          if (associated(cospOUT%modis_Cloud_Particle_Size_Water_Mean))                     &
+               cospOUT%modis_Cloud_Particle_Size_Water_Mean(:)              = R_UNDEF
+          if (associated(cospOUT%modis_Cloud_Particle_Size_Ice_Mean))                       &
+               cospOUT%modis_Cloud_Particle_Size_Ice_Mean(:)                = R_UNDEF
+          if (associated(cospOUT%modis_Cloud_Top_Pressure_Total_Mean))                      &
+               cospOUT%modis_Cloud_Top_Pressure_Total_Mean(:)               = R_UNDEF
+          if (associated(cospOUT%modis_Liquid_Water_Path_Mean))                             &
+               cospOUT%modis_Liquid_Water_Path_Mean(:)                      = R_UNDEF
+          if (associated(cospOUT%modis_Ice_Water_Path_Mean))                                &
+               cospOUT%modis_Ice_Water_Path_Mean(:)                         = R_UNDEF
+          if (associated(cospOUT%modis_Optical_Thickness_vs_Cloud_Top_Pressure))            &
+               cospOUT%modis_Optical_Thickness_vs_Cloud_Top_Pressure(:,:,:) = R_UNDEF
+          if (associated(cospOUT%modis_Optical_Thickness_vs_ReffICE))                       &
+               cospOUT%modis_Optical_Thickness_vs_ReffICE(:,:,:)            = R_UNDEF
+          if (associated(cospOUT%modis_Optical_Thickness_vs_ReffLIQ))                       &
+               cospOUT%modis_Optical_Thickness_vs_ReffLIQ(:,:,:)            = R_UNDEF
+       endif
+       if (any(cospIN%ss_alb .lt. 0 .OR. cospIN%ss_alb .gt. 1)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable: cospIN%ss_alb contains values out of range'
+          Lmodis_subcolumn = .false.
+          Lmodis_column    = .false.
+          if (associated(cospOUT%modis_Cloud_Fraction_Total_Mean))                          &
+               cospOUT%modis_Cloud_Fraction_Total_Mean(:)                   = R_UNDEF
+          if (associated(cospOUT%modis_Cloud_Fraction_Water_Mean))                          &
+               cospOUT%modis_Cloud_Fraction_Water_Mean(:)                   = R_UNDEF
+          if (associated(cospOUT%modis_Cloud_Fraction_Ice_Mean))                            &
+               cospOUT%modis_Cloud_Fraction_Ice_Mean(:)                     = R_UNDEF
+          if (associated(cospOUT%modis_Cloud_Fraction_High_Mean))                           &
+               cospOUT%modis_Cloud_Fraction_High_Mean(:)                    = R_UNDEF
+          if (associated(cospOUT%modis_Cloud_Fraction_Mid_Mean))                            &
+               cospOUT%modis_Cloud_Fraction_Mid_Mean(:)                     = R_UNDEF
+          if (associated(cospOUT%modis_Cloud_Fraction_Low_Mean))                            &
+               cospOUT%modis_Cloud_Fraction_Low_Mean(:)                     = R_UNDEF
+          if (associated(cospOUT%modis_Optical_Thickness_Total_Mean))                       &
+               cospOUT%modis_Optical_Thickness_Total_Mean(:)                = R_UNDEF
+          if (associated(cospOUT%modis_Optical_Thickness_Water_Mean))                       &
+               cospOUT%modis_Optical_Thickness_Water_Mean(:)                = R_UNDEF
+          if (associated(cospOUT%modis_Optical_Thickness_Ice_Mean))                         &
+               cospOUT%modis_Optical_Thickness_Ice_Mean(:)                  = R_UNDEF
+          if (associated(cospOUT%modis_Optical_Thickness_Total_LogMean))                    &
+               cospOUT%modis_Optical_Thickness_Total_LogMean(:)             = R_UNDEF
+          if (associated(cospOUT%modis_Optical_Thickness_Water_LogMean))                    &
+               cospOUT%modis_Optical_Thickness_Water_LogMean(:)             = R_UNDEF
+          if (associated(cospOUT%modis_Optical_Thickness_Ice_LogMean))                      &
+               cospOUT%modis_Optical_Thickness_Ice_LogMean(:)               = R_UNDEF
+          if (associated(cospOUT%modis_Cloud_Particle_Size_Water_Mean))                     &
+               cospOUT%modis_Cloud_Particle_Size_Water_Mean(:)              = R_UNDEF
+          if (associated(cospOUT%modis_Cloud_Particle_Size_Ice_Mean))                       &
+               cospOUT%modis_Cloud_Particle_Size_Ice_Mean(:)                = R_UNDEF
+          if (associated(cospOUT%modis_Cloud_Top_Pressure_Total_Mean))                      &
+               cospOUT%modis_Cloud_Top_Pressure_Total_Mean(:)               = R_UNDEF
+          if (associated(cospOUT%modis_Liquid_Water_Path_Mean))                             &
+               cospOUT%modis_Liquid_Water_Path_Mean(:)                      = R_UNDEF
+          if (associated(cospOUT%modis_Ice_Water_Path_Mean))                                &
+               cospOUT%modis_Ice_Water_Path_Mean(:)                         = R_UNDEF
+          if (associated(cospOUT%modis_Optical_Thickness_vs_Cloud_Top_Pressure))            &
+               cospOUT%modis_Optical_Thickness_vs_Cloud_Top_Pressure(:,:,:) = R_UNDEF
+          if (associated(cospOUT%modis_Optical_Thickness_vs_ReffICE))                       &
+               cospOUT%modis_Optical_Thickness_vs_ReffICE(:,:,:)            = R_UNDEF
+          if (associated(cospOUT%modis_Optical_Thickness_vs_ReffLIQ))                       &
+               cospOUT%modis_Optical_Thickness_vs_ReffLIQ(:,:,:)            = R_UNDEF
+       endif
+    endif
+    if (any([Latlid_subcolumn,Latlid_column])) then
+       if (any(cospIN%betatot_atlid .lt. 0)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable: cospIN%betatot_atlid contains values out of range'
+          Latlid_subcolumn = .false.
+          Latlid_column    = .false.
+          if (associated(cospOUT%atlid_cfad_sr))       cospOUT%atlid_cfad_sr(:,:,:)  = R_UNDEF
+          if (associated(cospOUT%atlid_lidarcld))      cospOUT%atlid_lidarcld(:,:)   = R_UNDEF
+          if (associated(cospOUT%atlid_cldlayer))      cospOUT%atlid_cldlayer(:,:)   = R_UNDEF
+          if (associated(cospOUT%atlid_beta_tot))      cospOUT%atlid_beta_tot(:,:,:) = R_UNDEF
+          if (associated(cospOUT%atlid_beta_mol))      cospOUT%atlid_beta_mol(:,:)   = R_UNDEF
+       endif
+       if (any(cospIN%beta_mol_atlid .lt. 0)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable: cospIN%beta_mol_atlid contains values out of range'
+          Latlid_subcolumn = .false.
+          Latlid_column    = .false.
+          if (associated(cospOUT%atlid_cfad_sr))       cospOUT%atlid_cfad_sr(:,:,:)  = R_UNDEF
+          if (associated(cospOUT%atlid_lidarcld))      cospOUT%atlid_lidarcld(:,:)   = R_UNDEF
+          if (associated(cospOUT%atlid_cldlayer))      cospOUT%atlid_cldlayer(:,:)   = R_UNDEF
+          if (associated(cospOUT%atlid_beta_tot))      cospOUT%atlid_beta_tot(:,:,:) = R_UNDEF
+          if (associated(cospOUT%atlid_beta_mol))      cospOUT%atlid_beta_mol(:,:)   = R_UNDEF
+       endif
+       if (any(cospIN%tautot_atlid .lt. 0)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable: cospIN%tautot_atlid contains values out of range'
+          Latlid_subcolumn = .false.
+          Latlid_column    = .false.
+          if (associated(cospOUT%atlid_cfad_sr))       cospOUT%atlid_cfad_sr(:,:,:)  = R_UNDEF
+          if (associated(cospOUT%atlid_lidarcld))      cospOUT%atlid_lidarcld(:,:)   = R_UNDEF
+          if (associated(cospOUT%atlid_cldlayer))      cospOUT%atlid_cldlayer(:,:)   = R_UNDEF
+          if (associated(cospOUT%atlid_beta_tot))      cospOUT%atlid_beta_tot(:,:,:) = R_UNDEF
+          if (associated(cospOUT%atlid_beta_mol))      cospOUT%atlid_beta_mol(:,:)   = R_UNDEF
+       endif
+       if (any(cospIN%tau_mol_atlid .lt. 0)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable: cospIN%tau_mol_atlid contains values out of range'
+          Latlid_subcolumn = .false.
+          Latlid_column    = .false.
+          if (associated(cospOUT%atlid_cfad_sr))       cospOUT%atlid_cfad_sr(:,:,:)  = R_UNDEF
+          if (associated(cospOUT%atlid_lidarcld))      cospOUT%atlid_lidarcld(:,:)   = R_UNDEF
+          if (associated(cospOUT%atlid_cldlayer))      cospOUT%atlid_cldlayer(:,:)   = R_UNDEF
+          if (associated(cospOUT%atlid_beta_tot))      cospOUT%atlid_beta_tot(:,:,:) = R_UNDEF
+          if (associated(cospOUT%atlid_beta_mol))      cospOUT%atlid_beta_mol(:,:)   = R_UNDEF
+       endif
+    endif
+    
+    if (any([LgrLidar532_subcolumn,LgrLidar532_column])) then
+       if (any(cospIN%betatot_grLidar532 .lt. 0)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable: cospIN%betatot_grLidar532 contains values out of range'
+          LgrLidar532_subcolumn = .false.
+          LgrLidar532_column    = .false.
+          if (associated(cospOUT%grLidar532_cfad_sr))       cospOUT%grLidar532_cfad_sr(:,:,:)  = R_UNDEF
+          if (associated(cospOUT%grLidar532_lidarcld))      cospOUT%grLidar532_lidarcld(:,:)   = R_UNDEF
+          if (associated(cospOUT%grLidar532_cldlayer))      cospOUT%grLidar532_cldlayer(:,:)   = R_UNDEF
+          if (associated(cospOUT%grLidar532_beta_tot))      cospOUT%grLidar532_beta_tot(:,:,:) = R_UNDEF
+          if (associated(cospOUT%grLidar532_beta_mol))      cospOUT%grLidar532_beta_mol(:,:)   = R_UNDEF
+       endif
+       if (any(cospIN%beta_mol_grLidar532 .lt. 0)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable: cospIN%beta_mol_grLidar532 contains values out of range'
+          LgrLidar532_subcolumn = .false.
+          LgrLidar532_column    = .false.
+          if (associated(cospOUT%grLidar532_cfad_sr))       cospOUT%grLidar532_cfad_sr(:,:,:)  = R_UNDEF
+          if (associated(cospOUT%grLidar532_lidarcld))      cospOUT%grLidar532_lidarcld(:,:)   = R_UNDEF
+          if (associated(cospOUT%grLidar532_cldlayer))      cospOUT%grLidar532_cldlayer(:,:)   = R_UNDEF
+          if (associated(cospOUT%grLidar532_beta_tot))      cospOUT%grLidar532_beta_tot(:,:,:) = R_UNDEF
+          if (associated(cospOUT%grLidar532_beta_mol))      cospOUT%grLidar532_beta_mol(:,:)   = R_UNDEF
+       endif
+       if (any(cospIN%tautot_grLidar532 .lt. 0)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable: cospIN%tautot_grLidar532 contains values out of range'
+          LgrLidar532_subcolumn = .false.
+          LgrLidar532_column    = .false.
+          if (associated(cospOUT%grLidar532_cfad_sr))       cospOUT%grLidar532_cfad_sr(:,:,:)  = R_UNDEF
+          if (associated(cospOUT%grLidar532_lidarcld))      cospOUT%grLidar532_lidarcld(:,:)   = R_UNDEF
+          if (associated(cospOUT%grLidar532_cldlayer))      cospOUT%grLidar532_cldlayer(:,:)   = R_UNDEF
+          if (associated(cospOUT%grLidar532_beta_tot))      cospOUT%grLidar532_beta_tot(:,:,:) = R_UNDEF
+          if (associated(cospOUT%grLidar532_beta_mol))      cospOUT%grLidar532_beta_mol(:,:)   = R_UNDEF
+       endif
+       if (any(cospIN%tau_mol_grLidar532 .lt. 0)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable: cospIN%tau_mol_grLidar532 contains values out of range'
+          LgrLidar532_subcolumn = .false.
+          LgrLidar532_column    = .false.
+          if (associated(cospOUT%grLidar532_cfad_sr))       cospOUT%grLidar532_cfad_sr(:,:,:)  = R_UNDEF
+          if (associated(cospOUT%grLidar532_lidarcld))      cospOUT%grLidar532_lidarcld(:,:)   = R_UNDEF
+          if (associated(cospOUT%grLidar532_cldlayer))      cospOUT%grLidar532_cldlayer(:,:)   = R_UNDEF
+          if (associated(cospOUT%grLidar532_beta_tot))      cospOUT%grLidar532_beta_tot(:,:,:) = R_UNDEF
+          if (associated(cospOUT%grLidar532_beta_mol))      cospOUT%grLidar532_beta_mol(:,:)   = R_UNDEF
+       endif
+    endif
+
+    if (any([Lcalipso_subcolumn,Lcalipso_column])) then
+       if (any(cospIN%betatot_calipso .lt. 0)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable: cospIN%betatot_calipso contains values out of range'
+          Lcalipso_subcolumn = .false.
+          Lcalipso_column    = .false.
+          if (associated(cospOUT%calipso_cfad_sr))       cospOUT%calipso_cfad_sr(:,:,:)       = R_UNDEF
+          if (associated(cospOUT%calipso_lidarcld))      cospOUT%calipso_lidarcld(:,:)        = R_UNDEF
+          if (associated(cospOUT%calipso_lidarcldphase)) cospOUT%calipso_lidarcldphase(:,:,:) = R_UNDEF
+          if (associated(cospOUT%calipso_cldlayer))      cospOUT%calipso_cldlayer(:,:)        = R_UNDEF
+          if (associated(cospOUT%calipso_cldlayerphase)) cospOUT%calipso_cldlayerphase(:,:,:) = R_UNDEF
+          if (associated(cospOUT%calipso_lidarcldtmp))   cospOUT%calipso_lidarcldtmp(:,:,:)   = R_UNDEF
+          if (associated(cospOUT%calipso_srbval))        cospOUT%calipso_srbval(:)            = R_UNDEF
+          if (associated(cospOUT%calipso_lidarcldtype))  cospOUT%calipso_lidarcldtype(:,:,:)  = R_UNDEF 
+          if (associated(cospOUT%calipso_cldtype))       cospOUT%calipso_cldtype(:,:)         = R_UNDEF 
+          if (associated(cospOUT%calipso_cldtypetemp))   cospOUT%calipso_cldtypetemp(:,:)     = R_UNDEF 
+          if (associated(cospOUT%calipso_cldtypemeanz))  cospOUT%calipso_cldtypemeanz(:,:)    = R_UNDEF 
+          if (associated(cospOUT%calipso_cldtypemeanzse)) cospOUT%calipso_cldtypemeanzse(:,:) = R_UNDEF 
+          if (associated(cospOUT%calipso_cldthinemis))   cospOUT%calipso_cldthinemis(:)       = R_UNDEF
+       endif
+       if (any(cospIN%betatot_liq_calipso .lt. 0)) then
+          nError=nError+1
+          errorMessage(nError) = ('ERROR: COSP input variable: cospIN%betatot_liq_calipso contains values out of range')
+          Lcalipso_subcolumn = .false.
+          Lcalipso_column    = .false.
+          if (associated(cospOUT%calipso_cfad_sr))       cospOUT%calipso_cfad_sr(:,:,:)       = R_UNDEF
+          if (associated(cospOUT%calipso_lidarcld))      cospOUT%calipso_lidarcld(:,:)        = R_UNDEF
+          if (associated(cospOUT%calipso_lidarcldphase)) cospOUT%calipso_lidarcldphase(:,:,:) = R_UNDEF
+          if (associated(cospOUT%calipso_cldlayer))      cospOUT%calipso_cldlayer(:,:)        = R_UNDEF
+          if (associated(cospOUT%calipso_cldlayerphase)) cospOUT%calipso_cldlayerphase(:,:,:) = R_UNDEF
+          if (associated(cospOUT%calipso_lidarcldtmp))   cospOUT%calipso_lidarcldtmp(:,:,:)   = R_UNDEF
+          if (associated(cospOUT%calipso_srbval))        cospOUT%calipso_srbval(:)            = R_UNDEF
+          if (associated(cospOUT%calipso_lidarcldtype))  cospOUT%calipso_lidarcldtype(:,:,:)  = R_UNDEF
+          if (associated(cospOUT%calipso_cldtype))       cospOUT%calipso_cldtype(:,:)         = R_UNDEF
+          if (associated(cospOUT%calipso_cldtypetemp))   cospOUT%calipso_cldtypetemp(:,:)     = R_UNDEF 
+          if (associated(cospOUT%calipso_cldtypemeanz))  cospOUT%calipso_cldtypemeanz(:,:)    = R_UNDEF 
+          if (associated(cospOUT%calipso_cldtypemeanzse)) cospOUT%calipso_cldtypemeanzse(:,:) = R_UNDEF
+          if (associated(cospOUT%calipso_cldthinemis))   cospOUT%calipso_cldthinemis(:)       = R_UNDEF
+       endif
+       if (any(cospIN%betatot_ice_calipso .lt. 0)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable: cospIN%betatot_ice_calipso contains values out of range'
+          Lcalipso_subcolumn = .false.
+          Lcalipso_column    = .false.
+          if (associated(cospOUT%calipso_cfad_sr))       cospOUT%calipso_cfad_sr(:,:,:)       = R_UNDEF
+          if (associated(cospOUT%calipso_lidarcld))      cospOUT%calipso_lidarcld(:,:)        = R_UNDEF
+          if (associated(cospOUT%calipso_lidarcldphase)) cospOUT%calipso_lidarcldphase(:,:,:) = R_UNDEF
+          if (associated(cospOUT%calipso_cldlayer))      cospOUT%calipso_cldlayer(:,:)        = R_UNDEF
+          if (associated(cospOUT%calipso_cldlayerphase)) cospOUT%calipso_cldlayerphase(:,:,:) = R_UNDEF
+          if (associated(cospOUT%calipso_lidarcldtmp))   cospOUT%calipso_lidarcldtmp(:,:,:)   = R_UNDEF
+          if (associated(cospOUT%calipso_srbval))        cospOUT%calipso_srbval(:)            = R_UNDEF
+          if (associated(cospOUT%calipso_lidarcldtype))  cospOUT%calipso_lidarcldtype(:,:,:)  = R_UNDEF
+          if (associated(cospOUT%calipso_cldtype))       cospOUT%calipso_cldtype(:,:)         = R_UNDEF 
+          if (associated(cospOUT%calipso_cldtypetemp))   cospOUT%calipso_cldtypetemp(:,:)     = R_UNDEF 
+          if (associated(cospOUT%calipso_cldtypemeanz))  cospOUT%calipso_cldtypemeanz(:,:)    = R_UNDEF 
+          if (associated(cospOUT%calipso_cldtypemeanzse)) cospOUT%calipso_cldtypemeanzse(:,:) = R_UNDEF
+          if (associated(cospOUT%calipso_cldthinemis))   cospOUT%calipso_cldthinemis(:)       = R_UNDEF
+       endif
+       if (any(cospIN%tautot_calipso .lt. 0)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable: cospIN%tautot_calipso contains values out of range'
+          Lcalipso_subcolumn = .false.
+          Lcalipso_column    = .false.
+          if (associated(cospOUT%calipso_cfad_sr))       cospOUT%calipso_cfad_sr(:,:,:)       = R_UNDEF
+          if (associated(cospOUT%calipso_lidarcld))      cospOUT%calipso_lidarcld(:,:)        = R_UNDEF
+          if (associated(cospOUT%calipso_lidarcldphase)) cospOUT%calipso_lidarcldphase(:,:,:) = R_UNDEF
+          if (associated(cospOUT%calipso_cldlayer))      cospOUT%calipso_cldlayer(:,:)        = R_UNDEF
+          if (associated(cospOUT%calipso_cldlayerphase)) cospOUT%calipso_cldlayerphase(:,:,:) = R_UNDEF
+          if (associated(cospOUT%calipso_lidarcldtmp))   cospOUT%calipso_lidarcldtmp(:,:,:)   = R_UNDEF
+          if (associated(cospOUT%calipso_srbval))        cospOUT%calipso_srbval(:)            = R_UNDEF
+          if (associated(cospOUT%calipso_lidarcldtype))  cospOUT%calipso_lidarcldtype(:,:,:)  = R_UNDEF
+          if (associated(cospOUT%calipso_cldtype))       cospOUT%calipso_cldtype(:,:)         = R_UNDEF 
+          if (associated(cospOUT%calipso_cldtypetemp))   cospOUT%calipso_cldtypetemp(:,:)     = R_UNDEF 
+          if (associated(cospOUT%calipso_cldtypemeanz))  cospOUT%calipso_cldtypemeanz(:,:)    = R_UNDEF 
+          if (associated(cospOUT%calipso_cldtypemeanzse)) cospOUT%calipso_cldtypemeanzse(:,:) = R_UNDEF
+          if (associated(cospOUT%calipso_cldthinemis))   cospOUT%calipso_cldthinemis(:)       = R_UNDEF
+       endif
+       if (any(cospIN%tautot_liq_calipso .lt. 0)) then
+          nError=nError+1
+          errorMessage(nError) = ('ERROR: COSP input variable: cospIN%tautot_liq_calipso contains values out of range')
+          Lcalipso_subcolumn = .false.
+          Lcalipso_column    = .false.
+          if (associated(cospOUT%calipso_cfad_sr))       cospOUT%calipso_cfad_sr(:,:,:)       = R_UNDEF
+          if (associated(cospOUT%calipso_lidarcld))      cospOUT%calipso_lidarcld(:,:)        = R_UNDEF
+          if (associated(cospOUT%calipso_lidarcldphase)) cospOUT%calipso_lidarcldphase(:,:,:) = R_UNDEF
+          if (associated(cospOUT%calipso_cldlayer))      cospOUT%calipso_cldlayer(:,:)        = R_UNDEF
+          if (associated(cospOUT%calipso_cldlayerphase)) cospOUT%calipso_cldlayerphase(:,:,:) = R_UNDEF
+          if (associated(cospOUT%calipso_lidarcldtmp))   cospOUT%calipso_lidarcldtmp(:,:,:)   = R_UNDEF
+          if (associated(cospOUT%calipso_srbval))        cospOUT%calipso_srbval(:)            = R_UNDEF
+          if (associated(cospOUT%calipso_lidarcldtype))  cospOUT%calipso_lidarcldtype(:,:,:)  = R_UNDEF
+          if (associated(cospOUT%calipso_cldtype))       cospOUT%calipso_cldtype(:,:)         = R_UNDEF
+          if (associated(cospOUT%calipso_cldtypetemp))   cospOUT%calipso_cldtypetemp(:,:)     = R_UNDEF
+          if (associated(cospOUT%calipso_cldtypemeanz))  cospOUT%calipso_cldtypemeanz(:,:)    = R_UNDEF
+          if (associated(cospOUT%calipso_cldtypemeanzse)) cospOUT%calipso_cldtypemeanzse(:,:) = R_UNDEF
+          if (associated(cospOUT%calipso_cldthinemis))   cospOUT%calipso_cldthinemis(:)       = R_UNDEF
+       endif
+       if (any(cospIN%tautot_ice_calipso .lt. 0)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable: cospIN%tautot_ice_calipso contains values out of range'
+          Lcalipso_subcolumn = .false.
+          Lcalipso_column    = .false.
+          if (associated(cospOUT%calipso_cfad_sr))       cospOUT%calipso_cfad_sr(:,:,:)       = R_UNDEF
+          if (associated(cospOUT%calipso_lidarcld))      cospOUT%calipso_lidarcld(:,:)        = R_UNDEF
+          if (associated(cospOUT%calipso_lidarcldphase)) cospOUT%calipso_lidarcldphase(:,:,:) = R_UNDEF
+          if (associated(cospOUT%calipso_cldlayer))      cospOUT%calipso_cldlayer(:,:)        = R_UNDEF
+          if (associated(cospOUT%calipso_cldlayerphase)) cospOUT%calipso_cldlayerphase(:,:,:) = R_UNDEF
+          if (associated(cospOUT%calipso_lidarcldtmp))   cospOUT%calipso_lidarcldtmp(:,:,:)   = R_UNDEF
+          if (associated(cospOUT%calipso_srbval))        cospOUT%calipso_srbval(:)            = R_UNDEF
+          if (associated(cospOUT%calipso_lidarcldtype))  cospOUT%calipso_lidarcldtype(:,:,:)  = R_UNDEF
+          if (associated(cospOUT%calipso_cldtype))       cospOUT%calipso_cldtype(:,:)         = R_UNDEF
+          if (associated(cospOUT%calipso_cldtypetemp))   cospOUT%calipso_cldtypetemp(:,:)     = R_UNDEF
+          if (associated(cospOUT%calipso_cldtypemeanz))  cospOUT%calipso_cldtypemeanz(:,:)    = R_UNDEF
+          if (associated(cospOUT%calipso_cldtypemeanzse)) cospOUT%calipso_cldtypemeanzse(:,:) = R_UNDEF
+          if (associated(cospOUT%calipso_cldthinemis))   cospOUT%calipso_cldthinemis(:)       = R_UNDEF
+       endif
+       if (any(cospIN%tau_mol_calipso .lt. 0)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable: cospIN%tau_mol_calipso contains values out of range'
+          Lcalipso_subcolumn = .false.
+          Lcalipso_column    = .false.
+          if (associated(cospOUT%calipso_cfad_sr))       cospOUT%calipso_cfad_sr(:,:,:)       = R_UNDEF
+          if (associated(cospOUT%calipso_lidarcld))      cospOUT%calipso_lidarcld(:,:)        = R_UNDEF
+          if (associated(cospOUT%calipso_lidarcldphase)) cospOUT%calipso_lidarcldphase(:,:,:) = R_UNDEF
+          if (associated(cospOUT%calipso_cldlayer))      cospOUT%calipso_cldlayer(:,:)        = R_UNDEF
+          if (associated(cospOUT%calipso_cldlayerphase)) cospOUT%calipso_cldlayerphase(:,:,:) = R_UNDEF
+          if (associated(cospOUT%calipso_lidarcldtmp))   cospOUT%calipso_lidarcldtmp(:,:,:)   = R_UNDEF
+          if (associated(cospOUT%calipso_srbval))        cospOUT%calipso_srbval(:)            = R_UNDEF
+          if (associated(cospOUT%calipso_lidarcldtype))  cospOUT%calipso_lidarcldtype(:,:,:)  = R_UNDEF 
+          if (associated(cospOUT%calipso_cldtype))       cospOUT%calipso_cldtype(:,:)         = R_UNDEF 
+          if (associated(cospOUT%calipso_cldtypetemp))   cospOUT%calipso_cldtypetemp(:,:)     = R_UNDEF
+          if (associated(cospOUT%calipso_cldtypemeanz))  cospOUT%calipso_cldtypemeanz(:,:)    = R_UNDEF
+          if (associated(cospOUT%calipso_cldtypemeanzse)) cospOUT%calipso_cldtypemeanzse(:,:) = R_UNDEF
+          if (associated(cospOUT%calipso_cldthinemis))   cospOUT%calipso_cldthinemis(:)       = R_UNDEF
+       endif
+    endif
+    if (any([Lcalipso_subcolumn,Lcalipso_column,Lcloudsat_column,Lradar_lidar_tcc,       &
+        Llidar_only_freq_cloud, Lcloudsat_tcc, Lcloudsat_tcc2])) then
+       if (any(cospIN%beta_mol_calipso .lt. 0)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable: cospIN%beta_mol_calipso contains values out of range'
+          Lcalipso_subcolumn = .false.
+          Lcalipso_column    = .false.
+          Lcloudsat_column   = .false.
+          Lradar_lidar_tcc   = .false.
+          Llidar_only_freq_cloud = .false.
+          Lcloudsat_tcc      = .false.
+          Lcloudsat_tcc2     = .false.
+          if (associated(cospOUT%calipso_cfad_sr))        cospOUT%calipso_cfad_sr(:,:,:)       = R_UNDEF
+          if (associated(cospOUT%calipso_lidarcld))       cospOUT%calipso_lidarcld(:,:)        = R_UNDEF
+          if (associated(cospOUT%calipso_lidarcldphase))  cospOUT%calipso_lidarcldphase(:,:,:) = R_UNDEF
+          if (associated(cospOUT%calipso_cldlayer))       cospOUT%calipso_cldlayer(:,:)        = R_UNDEF
+          if (associated(cospOUT%calipso_cldlayerphase))  cospOUT%calipso_cldlayerphase(:,:,:) = R_UNDEF
+          if (associated(cospOUT%calipso_lidarcldtmp))    cospOUT%calipso_lidarcldtmp(:,:,:)   = R_UNDEF
+          if (associated(cospOUT%calipso_srbval))         cospOUT%calipso_srbval(:)            = R_UNDEF
+          if (associated(cospOUT%cloudsat_cfad_ze))       cospOUT%cloudsat_cfad_ze(:,:,:)      = R_UNDEF
+          if (associated(cospOUT%lidar_only_freq_cloud))  cospOUT%lidar_only_freq_cloud(:,:)   = R_UNDEF
+          if (associated(cospOUT%radar_lidar_tcc))        cospOUT%radar_lidar_tcc(:)           = R_UNDEF
+          if (associated(cospOUT%cloudsat_tcc))           cospOUT%cloudsat_tcc(:)              = R_UNDEF
+          if (associated(cospOUT%cloudsat_tcc2))          cospOUT%cloudsat_tcc2(:)             = R_UNDEF
+          if (associated(cospOUT%calipso_lidarcldtype))   cospOUT%calipso_lidarcldtype(:,:,:)  = R_UNDEF
+          if (associated(cospOUT%calipso_cldtype))        cospOUT%calipso_cldtype(:,:)         = R_UNDEF
+          if (associated(cospOUT%calipso_cldtypetemp))    cospOUT%calipso_cldtypetemp(:,:)     = R_UNDEF
+          if (associated(cospOUT%calipso_cldtypemeanz))   cospOUT%calipso_cldtypemeanz(:,:)    = R_UNDEF
+          if (associated(cospOUT%calipso_cldtypemeanzse)) cospOUT%calipso_cldtypemeanzse(:,:)  = R_UNDEF
+          if (associated(cospOUT%calipso_cldthinemis))    cospOUT%calipso_cldthinemis(:)       = R_UNDEF
+       endif
+    endif
+    if (any([Lparasol_subcolumn,Lparasol_column])) then
+       if (any(cospIN%tautot_S_liq .lt. 0)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable: cospIN%tautot_S_liq contains values out of range'
+          Lparasol_subcolumn = .false.
+          Lparasol_column    = .false.
+          if (associated(cospOUT%parasolPix_refl))  cospOUT%parasolPix_refl(:,:,:) = R_UNDEF
+          if (associated(cospOUT%parasolGrid_refl)) cospOUT%parasolGrid_refl(:,:)  = R_UNDEF
+       endif
+       if (any(cospIN%tautot_S_ice .lt. 0)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable: cospIN%tautot_S_ice contains values out of range'
+          Lparasol_subcolumn = .false.
+          Lparasol_column    = .false.
+          if (associated(cospOUT%parasolPix_refl))  cospOUT%parasolPix_refl(:,:,:) = R_UNDEF
+          if (associated(cospOUT%parasolGrid_refl)) cospOUT%parasolGrid_refl(:,:)  = R_UNDEF
+       endif
+    endif
+    if (any([Lcloudsat_subcolumn,Lcloudsat_column,Lradar_lidar_tcc,Llidar_only_freq_cloud, &
+        Lcloudsat_tcc, Lcloudsat_tcc2])) then
+       if (any(cospIN%z_vol_cloudsat .lt. 0)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable: cospIN%z_vol_cloudsat contains values out of range'
+          Lcloudsat_subcolumn = .false.
+          Lcloudsat_column    = .false.
+          Lradar_lidar_tcc    = .false.
+          Llidar_only_freq_cloud = .false.
+          Lcloudsat_tcc       = .false.
+          Lcloudsat_tcc2      = .false.
+          if (associated(cospOUT%cloudsat_cfad_ze))          cospOUT%cloudsat_cfad_ze(:,:,:)        = R_UNDEF
+          if (associated(cospOUT%cloudsat_Ze_tot))           cospOUT%cloudsat_Ze_tot(:,:,:)         = R_UNDEF
+          if (associated(cospOUT%lidar_only_freq_cloud))     cospOUT%lidar_only_freq_cloud(:,:)     = R_UNDEF
+          if (associated(cospOUT%radar_lidar_tcc))           cospOUT%radar_lidar_tcc(:)             = R_UNDEF
+          if (associated(cospOUT%cloudsat_tcc)) cospOUT%cloudsat_tcc(:) = R_UNDEF
+          if (associated(cospOUT%cloudsat_tcc2)) cospOUT%cloudsat_tcc2(:) = R_UNDEF
+       endif
+       if (any(cospIN%kr_vol_cloudsat .lt. 0)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable: cospIN%kr_vol_cloudsat contains values out of range'
+          Lcloudsat_subcolumn = .false.
+          Lcloudsat_column    = .false.
+          Lradar_lidar_tcc    = .false.
+          Llidar_only_freq_cloud = .false.
+          Lcloudsat_tcc       = .false.
+          Lcloudsat_tcc2      = .false.
+          if (associated(cospOUT%cloudsat_cfad_ze))          cospOUT%cloudsat_cfad_ze(:,:,:)        = R_UNDEF
+          if (associated(cospOUT%cloudsat_Ze_tot))           cospOUT%cloudsat_Ze_tot(:,:,:)         = R_UNDEF
+          if (associated(cospOUT%lidar_only_freq_cloud))     cospOUT%lidar_only_freq_cloud(:,:)     = R_UNDEF
+          if (associated(cospOUT%radar_lidar_tcc))           cospOUT%radar_lidar_tcc(:)             = R_UNDEF
+          if (associated(cospOUT%cloudsat_tcc)) cospOUT%cloudsat_tcc(:) = R_UNDEF
+          if (associated(cospOUT%cloudsat_tcc2)) cospOUT%cloudsat_tcc2(:) = R_UNDEF
+       endif
+       if (any(cospIN%g_vol_cloudsat .lt. 0)) then
+          nError=nError+1
+          errorMessage(nError) = 'ERROR: COSP input variable: cospIN%g_vol_cloudsat contains values out of range'
+          Lcloudsat_subcolumn = .false.
+          Lcloudsat_column    = .false.
+          Lradar_lidar_tcc    = .false.
+          Llidar_only_freq_cloud = .false.
+          Lcloudsat_tcc       = .false.
+          Lcloudsat_tcc2      = .false.          
+          if (associated(cospOUT%cloudsat_cfad_ze))          cospOUT%cloudsat_cfad_ze(:,:,:)        = R_UNDEF
+          if (associated(cospOUT%cloudsat_Ze_tot))           cospOUT%cloudsat_Ze_tot(:,:,:)         = R_UNDEF
+          if (associated(cospOUT%lidar_only_freq_cloud))     cospOUT%lidar_only_freq_cloud(:,:)     = R_UNDEF
+          if (associated(cospOUT%radar_lidar_tcc))           cospOUT%radar_lidar_tcc(:)             = R_UNDEF
+          if (associated(cospOUT%cloudsat_tcc)) cospOUT%cloudsat_tcc(:) = R_UNDEF
+          if (associated(cospOUT%cloudsat_tcc2)) cospOUT%cloudsat_tcc2(:) = R_UNDEF          
+       endif
+    endif
+    !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+    ! Part 2: Check input fields array size for consistency. This needs to be done for each
+    !         simulator
+    !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+    ! ISCCP
+    if (Lisccp_subcolumn .or. Lisccp_column) then
+       if (size(cospIN%frac_out,1)  .ne. cospIN%Npoints .OR. &
+           size(cospIN%tau_067,1)   .ne. cospIN%Npoints .OR. &
+           size(cospIN%emiss_11,1)  .ne. cospIN%Npoints .OR. &
+           size(cospgridIN%skt)     .ne. cospIN%Npoints .OR. &
+           size(cospgridIN%qv,1)    .ne. cospIN%Npoints .OR. &
+           size(cospgridIN%at,1)    .ne. cospIN%Npoints .OR. &
+           size(cospgridIN%phalf,1) .ne. cospIN%Npoints .OR. &
+           size(cospgridIN%sunlit)  .ne. cospIN%Npoints .OR. &
+           size(cospgridIN%pfull,1) .ne. cospIN%Npoints) then
+          Lisccp_subcolumn = .false.
+          Lisccp_column    = .false.
+          nError=nError+1
+          errorMessage(nError) = 'ERROR(isccp_simulator): The number of points in the input fields are inconsistent'
+       endif
+       if (size(cospIN%frac_out,2) .ne. cospIN%Ncolumns .OR. &
+           size(cospIN%tau_067,2)  .ne. cospIN%Ncolumns .OR. &
+           size(cospIN%emiss_11,2) .ne. cospIN%Ncolumns) then
+          Lisccp_subcolumn = .false.
+          Lisccp_column    = .false.
+          nError=nError+1
+          errorMessage(nError) = 'ERROR(isccp_simulator): The number of sub-columns in the input fields are inconsistent'
+       endif
+       if (size(cospIN%frac_out,3)  .ne. cospIN%Nlevels .OR. &
+           size(cospIN%tau_067,3)   .ne. cospIN%Nlevels .OR. &
+           size(cospIN%emiss_11,3)  .ne. cospIN%Nlevels .OR. &
+           size(cospgridIN%qv,2)    .ne. cospIN%Nlevels .OR. &
+           size(cospgridIN%at,2)    .ne. cospIN%Nlevels .OR. &
+           size(cospgridIN%pfull,2) .ne. cospIN%Nlevels .OR. &
+           size(cospgridIN%phalf,2) .ne. cospIN%Nlevels+1) then
+          Lisccp_subcolumn = .false.
+          Lisccp_column    = .false.
+          nError=nError+1
+          errorMessage(nError) = 'ERROR(isccp_simulator): The number of levels in the input fields are inconsistent'
+       endif
+    endif
+    
+    ! MISR
+    if (Lmisr_subcolumn .or. Lmisr_column) then
+       if (size(cospIN%tau_067,1)        .ne. cospIN%Npoints .OR. &
+           size(cospgridIN%sunlit)       .ne. cospIN%Npoints .OR. &
+           size(cospgridIN%hgt_matrix,1) .ne. cospIN%Npoints .OR. &
+           size(cospgridIN%at,1)         .ne. cospIN%Npoints) then
+          Lmisr_subcolumn = .false.
+          Lmisr_column    = .false.
+          nError=nError+1
+          errorMessage(nError) = 'ERROR(misr_simulator): The number of points in the input fields are inconsistent'
+       endif
+       if (size(cospIN%tau_067,2) .ne. cospIN%Ncolumns) then
+          Lmisr_subcolumn = .false.
+          Lmisr_column    = .false.
+          nError=nError+1
+          errorMessage(nError) = 'ERROR(misr_simulator): The number of sub-columns in the input fields are inconsistent'
+       endif
+       if (size(cospIN%tau_067,3)        .ne. cospIN%Nlevels .OR. &
+           size(cospgridIN%hgt_matrix,2) .ne. cospIN%Nlevels .OR. &
+           size(cospgridIN%at,2)         .ne. cospIN%Nlevels) then
+          Lmisr_subcolumn = .false.
+          Lmisr_column    = .false.
+          nError=nError+1
+          errorMessage(nError) = 'ERROR(misr_simulator): The number of levels in the input fields are inconsistent'
+       endif
+    endif
+    
+    ! MODIS
+    if (Lmodis_subcolumn .or. Lmodis_column) then
+       if (size(cospIN%fracLiq,1) .ne. cospIN%Npoints .OR. &
+           size(cospIN%tau_067,1) .ne. cospIN%Npoints .OR. &
+           size(cospIN%asym,1)    .ne. cospIN%Npoints .OR. &
+           size(cospIN%ss_alb,1)  .ne. cospIN%Npoints) then
+          Lmodis_subcolumn = .false.
+          Lmodis_column    = .false.
+          nError=nError+1
+          errorMessage(nError) = 'ERROR(modis_simulator): The number of points in the input fields are inconsistent'
+       endif
+       if (size(cospIN%fracLiq,2) .ne. cospIN%Ncolumns .OR. &
+           size(cospIN%tau_067,2) .ne. cospIN%Ncolumns .OR. &
+           size(cospIN%asym,2)    .ne. cospIN%Ncolumns .OR. &
+           size(cospIN%ss_alb,2)  .ne. cospIN%Ncolumns) then
+          Lmodis_subcolumn = .false.
+          Lmodis_column    = .false.
+          nError=nError+1
+          errorMessage(nError) = 'ERROR(modis_simulator): The number of sub-columns in the input fields are inconsistent'
+       endif
+       if (size(cospIN%fracLiq,3) .ne. cospIN%Nlevels .OR. &
+           size(cospIN%tau_067,3) .ne. cospIN%Nlevels .OR. &
+           size(cospIN%asym,3)    .ne. cospIN%Nlevels .OR. &
+           size(cospIN%ss_alb,3)  .ne. cospIN%Nlevels) then
+          Lmodis_subcolumn = .false.
+          Lmodis_column    = .false.
+          nError=nError+1
+          errorMessage(nError) = 'ERROR(modis_simulator): The number of levels in the input fields are inconsistent'
+       endif
+    endif
+    
+    ! CLOUDSAT
+    if (Lcloudsat_subcolumn .or. Lcloudsat_column) then
+       if (size(cospIN%z_vol_cloudsat,1)   .ne. cospIN%Npoints .OR. &
+           size(cospIN%kr_vol_cloudsat,1)  .ne. cospIN%Npoints .OR. &
+           size(cospIN%g_vol_cloudsat,1)   .ne. cospIN%Npoints .OR. &
+           size(cospgridIN%hgt_matrix,1)   .ne. cospIN%Npoints) then
+          Lcloudsat_subcolumn = .false.
+          Lcloudsat_column    = .false.
+          nError=nError+1
+          errorMessage(nError) = 'ERROR(cloudsat_simulator): The number of points in the input fields are inconsistent'
+       endif
+       if (size(cospIN%z_vol_cloudsat,2)  .ne. cospIN%Ncolumns .OR. &
+           size(cospIN%kr_vol_cloudsat,2) .ne. cospIN%Ncolumns .OR. &
+           size(cospIN%g_vol_cloudsat,2)  .ne. cospIN%Ncolumns) then
+          Lcloudsat_subcolumn = .false.
+          Lcloudsat_column    = .false.
+          nError=nError+1
+          errorMessage(nError) = 'ERROR(cloudsat_simulator): The number of sub-columns in the input fields are inconsistent'
+       endif
+       if (size(cospIN%z_vol_cloudsat,3)  .ne. cospIN%Nlevels .OR. &
+           size(cospIN%kr_vol_cloudsat,3) .ne. cospIN%Nlevels .OR. &
+           size(cospIN%g_vol_cloudsat,3)  .ne. cospIN%Nlevels .OR. &
+           size(cospgridIN%hgt_matrix,2)  .ne. cospIN%Nlevels) then
+          Lcloudsat_subcolumn = .false.
+          Lcloudsat_column    = .false.
+          nError=nError+1
+          errorMessage(nError) = 'ERROR(cloudsat_simulator): The number of levels in the input fields are inconsistent'
+       endif
+    endif
+
+    ! GROUND LIDAR @ 532nm
+    if (LgrLidar532_subcolumn .or. LgrLidar532_column) then
+       if (size(cospIN%beta_mol_grLidar532,1)    .ne. cospIN%Npoints .OR. & 
+           size(cospIN%betatot_grLidar532,1)     .ne. cospIN%Npoints .OR. &
+           size(cospIN%tau_mol_grLidar532,1)     .ne. cospIN%Npoints .OR. &
+           size(cospIN%tautot_grLidar532,1)      .ne. cospIN%Npoints) then
+          LgrLidar532_subcolumn = .false.
+          LgrLidar532_column    = .false.
+          nError=nError+1
+          errorMessage(nError) = 'ERROR(grLidar532_simulator): The number of points in the input fields are inconsistent'
+       endif
+       if (size(cospIN%betatot_grLidar532,2)    .ne. cospIN%Ncolumns .OR. & 
+           size(cospIN%tautot_grLidar532,2)     .ne. cospIN%Ncolumns) then 
+          LgrLidar532_subcolumn = .false. 
+          LgrLidar532_column    = .false. 
+          nError=nError+1
+          errorMessage(nError) = 'ERROR(grLidar532_simulator): The number of sub-columns in the input fields are inconsistent'
+       endif
+       if (size(cospIN%beta_mol_grLidar532,2)    .ne. cospIN%Nlevels .OR. &
+           size(cospIN%betatot_grLidar532,3)     .ne. cospIN%Nlevels .OR. &
+           size(cospIN%tau_mol_grLidar532,2)     .ne. cospIN%Nlevels .OR. &
+           size(cospIN%tautot_grLidar532,3)      .ne. cospIN%Nlevels) then
+          LgrLidar532_subcolumn = .false. 
+          LgrLidar532_column    = .false. 
+          nError=nError+1
+          errorMessage(nError) = 'ERROR(grLidar532_simulator): The number of levels in the input fields are inconsistent' 
+       endif
+    endif
+    
+    ! ATLID
+    if (Latlid_subcolumn .or. Latlid_column) then
+       if (size(cospIN%beta_mol_atlid,1)    .ne. cospIN%Npoints .OR. &
+           size(cospIN%betatot_atlid,1)     .ne. cospIN%Npoints .OR. &
+           size(cospIN%tau_mol_atlid,1)     .ne. cospIN%Npoints .OR. & 
+           size(cospIN%tautot_atlid,1)      .ne. cospIN%Npoints) then 
+          Latlid_subcolumn = .false. 
+          Latlid_column    = .false. 
+          nError=nError+1             
+          errorMessage(nError) = 'ERROR(atlid_simulator): The number of points in the input fields are inconsistent'
+       endif
+       if (size(cospIN%betatot_atlid,2)    .ne. cospIN%Ncolumns .OR. &
+           size(cospIN%tautot_atlid,2)     .ne. cospIN%Ncolumns) then 
+          Latlid_subcolumn = .false.
+          Latlid_column    = .false.
+          nError=nError+1              
+          errorMessage(nError) = 'ERROR(atlid_simulator): The number of sub-columns in the input fields are inconsistent'
+       endif
+       if (size(cospIN%beta_mol_atlid,2)    .ne. cospIN%Nlevels .OR. &
+           size(cospIN%betatot_atlid,3)     .ne. cospIN%Nlevels .OR. & 
+           size(cospIN%tau_mol_atlid,2)     .ne. cospIN%Nlevels .OR. &
+           size(cospIN%tautot_atlid,3)      .ne. cospIN%Nlevels) then 
+          Latlid_subcolumn = .false.
+          Latlid_column    = .false. 
+          nError=nError+1 
+          errorMessage(nError) = 'ERROR(atlid_simulator): The number of levels in the input fields are inconsistent'
+       endif
+    endif
+
+    ! CALIPSO
+    if (Lcalipso_subcolumn .or. Lcalipso_column) then
+       if (size(cospIN%beta_mol_calipso,1)    .ne. cospIN%Npoints .OR. &
+           size(cospIN%betatot_calipso,1)     .ne. cospIN%Npoints .OR. &
+           size(cospIN%betatot_liq_calipso,1) .ne. cospIN%Npoints .OR. &
+           size(cospIN%betatot_ice_calipso,1) .ne. cospIN%Npoints .OR. &
+           size(cospIN%tau_mol_calipso,1)     .ne. cospIN%Npoints .OR. &
+           size(cospIN%tautot_calipso,1)      .ne. cospIN%Npoints .OR. &
+           size(cospIN%tautot_liq_calipso,1)  .ne. cospIN%Npoints .OR. &
+           size(cospIN%tautot_ice_calipso,1)  .ne. cospIN%Npoints) then
+          Lcalipso_subcolumn = .false.
+          Lcalipso_column    = .false.
+          nError=nError+1
+          errorMessage(nError) = 'ERROR(calipso_simulator): The number of points in the input fields are inconsistent'
+       endif
+       if (size(cospIN%betatot_calipso,2)     .ne. cospIN%Ncolumns .OR. &
+           size(cospIN%betatot_liq_calipso,2) .ne. cospIN%Ncolumns .OR. &
+           size(cospIN%betatot_ice_calipso,2) .ne. cospIN%Ncolumns .OR. &
+           size(cospIN%tautot_calipso,2)      .ne. cospIN%Ncolumns .OR. &
+           size(cospIN%tautot_liq_calipso,2)  .ne. cospIN%Ncolumns .OR. &
+           size(cospIN%tautot_ice_calipso,2)  .ne. cospIN%Ncolumns) then
+          Lcalipso_subcolumn = .false.
+          Lcalipso_column    = .false.
+          nError=nError+1
+          errorMessage(nError) = 'ERROR(calipso_simulator): The number of sub-columns in the input fields are inconsistent'
+       endif
+       if (size(cospIN%beta_mol_calipso,2)    .ne. cospIN%Nlevels .OR. &
+           size(cospIN%betatot_calipso,3)     .ne. cospIN%Nlevels .OR. &
+           size(cospIN%betatot_liq_calipso,3) .ne. cospIN%Nlevels .OR. &
+           size(cospIN%betatot_ice_calipso,3) .ne. cospIN%Nlevels .OR. &
+           size(cospIN%tau_mol_calipso,2)     .ne. cospIN%Nlevels .OR. &
+           size(cospIN%tautot_calipso,3)      .ne. cospIN%Nlevels .OR. &
+           size(cospIN%tautot_liq_calipso,3)  .ne. cospIN%Nlevels .OR. &
+           size(cospIN%tautot_ice_calipso,3)  .ne. cospIN%Nlevels) then
+          Lcalipso_subcolumn = .false.
+          Lcalipso_column    = .false.
+          nError=nError+1
+          errorMessage(nError) = 'ERROR(calipso_simulator): The number of levels in the input fields are inconsistent'
+       endif
+    endif
+    
+    ! PARASOL
+    if (Lparasol_subcolumn .or. Lparasol_column) then
+       if (size(cospIN%tautot_S_liq,1) .ne. cospIN%Npoints .OR. &
+           size(cospIN%tautot_S_ice,1) .ne. cospIN%Npoints) then
+          Lparasol_subcolumn = .false.
+          Lparasol_column    = .false.
+          nError=nError+1
+          errorMessage(nError) = 'ERROR(parasol_simulator): The number of points in the input fields are inconsistent'
+       endif
+       if (size(cospIN%tautot_S_liq,2) .ne. cospIN%Ncolumns .OR. &
+           size(cospIN%tautot_S_ice,2) .ne. cospIN%Ncolumns) then
+          Lparasol_subcolumn = .false.
+          Lparasol_column    = .false.
+          nError=nError+1
+          errorMessage(nError) = 'ERROR(parasol_simulator): The number of levels in the input fields are inconsistent'
+       endif
+    endif
+
+    ! RTTOV
+    if (Lrttov_column) then
+       if (size(cospgridIN%pfull,1)           .ne. cospIN%Npoints .OR. &
+           size(cospgridIN%at,1)              .ne. cospIN%Npoints .OR. &
+           size(cospgridIN%qv,1)              .ne. cospIN%Npoints .OR. &
+           size(cospgridIN%hgt_matrix_half,1) .ne. cospIN%Npoints .OR. &
+           size(cospgridIN%u_sfc)             .ne. cospIN%Npoints .OR. &
+           size(cospgridIN%v_sfc)             .ne. cospIN%Npoints .OR. &
+           size(cospgridIN%skt)               .ne. cospIN%Npoints .OR. &
+           size(cospgridIN%phalf,1)           .ne. cospIN%Npoints .OR. &
+           size(cospgridIN%qv,1)              .ne. cospIN%Npoints .OR. &
+           size(cospgridIN%land)              .ne. cospIN%Npoints .OR. &
+           size(cospgridIN%lat)               .ne. cospIN%Npoints) then
+          Lrttov_column    = .false.
+          nError=nError+1
+          errorMessage(nError) = 'ERROR(rttov_simulator): The number of points in the input fields are inconsistent'
+       endif
+       if (size(cospgridIN%pfull,2)           .ne. cospIN%Nlevels   .OR. &
+           size(cospgridIN%at,2)              .ne. cospIN%Nlevels   .OR. &
+           size(cospgridIN%qv,2)              .ne. cospIN%Nlevels   .OR. &
+           size(cospgridIN%hgt_matrix_half,2) .ne. cospIN%Nlevels+1 .OR. &
+           size(cospgridIN%phalf,2)           .ne. cospIN%Nlevels+1 .OR. &
+           size(cospgridIN%qv,2)              .ne. cospIN%Nlevels) then
+          Lrttov_column    = .false.
+          nError=nError+1
+          errorMessage(nError) = 'ERROR(rttov_simulator): The number of levels in the input fields are inconsistent'
+       endif
+    endif
+  end subroutine cosp_errorCheck
+
+  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  ! END MODULE
+  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+END MODULE MOD_COSP
Index: DZ6/trunk/libf/phylmd/cospv2/cosp_atlid_interface.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cospv2/cosp_atlid_interface.F90	(revision 5267)
+++ 	(revision )
@@ -1,66 +1,0 @@
-! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-! Copyright (c) 2015, Regents of the University of Colorado
-! All rights reserved.
-!
-! Redistribution and use in source and binary forms, with or without modification, are 
-! permitted provided that the following conditions are met:
-!
-! 1. Redistributions of source code must retain the above copyright notice, this list of 
-!    conditions and the following disclaimer.
-!
-! 2. Redistributions in binary form must reproduce the above copyright notice, this list
-!    of conditions and the following disclaimer in the documentation and/or other 
-!    materials provided with the distribution.
-!
-! 3. Neither the name of the copyright holder nor the names of its contributors may be 
-!    used to endorse or promote products derived from this software without specific prior
-!    written permission.
-!
-! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY 
-! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 
-! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL 
-! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 
-! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT 
-! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 
-! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
-! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-!
-! History
-! Apr 2018 - R. Guzman - Original version
-! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-MODULE MOD_COSP_ATLID_INTERFACE
-  USE COSP_KINDS,              ONLY: wp
-  IMPLICIT NONE
-
-  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-  ! TYPE atlid_in
-  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 
-  type atlid_IN
-     integer,pointer ::       &
-          Npoints,      & ! Number of gridpoints.
-          Ncolumns,     & ! Number of columns.
-          Nlevels         ! Number of levels.
-
-     real(wp),dimension(:,:),pointer :: &
-          beta_mol_atlid,     & ! Molecular backscatter coefficient
-          tau_mol_atlid         ! Molecular optical depth
-     real(wp),dimension(:,:,:),pointer :: &
-          betatot_atlid,      & ! 
-          tautot_atlid          ! Optical thickess integrated from top
-     real(wp),dimension(:,:,:,:),pointer :: &
-          taupart_atlid
-  end type atlid_IN
-
-CONTAINS
-  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-  ! SUBROUTINE cosp_atlid_init
-  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-  subroutine cosp_atlid_init() 
-
-  end subroutine cosp_atlid_init
-
-  ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-  !	END MODULE
-  ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-END MODULE MOD_COSP_ATLID_INTERFACE
Index: /LMDZ6/trunk/libf/phylmd/cospv2/cosp_atlid_interface.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cospv2/cosp_atlid_interface.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/cospv2/cosp_atlid_interface.f90	(revision 5268)
@@ -0,0 +1,66 @@
+! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+! Copyright (c) 2015, Regents of the University of Colorado
+! All rights reserved.
+!
+! Redistribution and use in source and binary forms, with or without modification, are 
+! permitted provided that the following conditions are met:
+!
+! 1. Redistributions of source code must retain the above copyright notice, this list of 
+!    conditions and the following disclaimer.
+!
+! 2. Redistributions in binary form must reproduce the above copyright notice, this list
+!    of conditions and the following disclaimer in the documentation and/or other 
+!    materials provided with the distribution.
+!
+! 3. Neither the name of the copyright holder nor the names of its contributors may be 
+!    used to endorse or promote products derived from this software without specific prior
+!    written permission.
+!
+! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY 
+! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 
+! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL 
+! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 
+! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT 
+! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 
+! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+!
+! History
+! Apr 2018 - R. Guzman - Original version
+! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+MODULE MOD_COSP_ATLID_INTERFACE
+  USE COSP_KINDS,              ONLY: wp
+  IMPLICIT NONE
+
+  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  ! TYPE atlid_in
+  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 
+  type atlid_IN
+     integer,pointer ::       &
+          Npoints,      & ! Number of gridpoints.
+          Ncolumns,     & ! Number of columns.
+          Nlevels         ! Number of levels.
+
+     real(wp),dimension(:,:),pointer :: &
+          beta_mol_atlid,     & ! Molecular backscatter coefficient
+          tau_mol_atlid         ! Molecular optical depth
+     real(wp),dimension(:,:,:),pointer :: &
+          betatot_atlid,      & ! 
+          tautot_atlid          ! Optical thickess integrated from top
+     real(wp),dimension(:,:,:,:),pointer :: &
+          taupart_atlid
+  end type atlid_IN
+
+CONTAINS
+  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  ! SUBROUTINE cosp_atlid_init
+  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  subroutine cosp_atlid_init() 
+
+  end subroutine cosp_atlid_init
+
+  ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  !	END MODULE
+  ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+END MODULE MOD_COSP_ATLID_INTERFACE
Index: DZ6/trunk/libf/phylmd/cospv2/cosp_calipso_interface.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cospv2/cosp_calipso_interface.F90	(revision 5267)
+++ 	(revision )
@@ -1,85 +1,0 @@
-! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-! Copyright (c) 2015, Regents of the University of Colorado
-! All rights reserved.
-!
-! Redistribution and use in source and binary forms, with or without modification, are 
-! permitted provided that the following conditions are met:
-!
-! 1. Redistributions of source code must retain the above copyright notice, this list of 
-!    conditions and the following disclaimer.
-!
-! 2. Redistributions in binary form must reproduce the above copyright notice, this list
-!    of conditions and the following disclaimer in the documentation and/or other 
-!    materials provided with the distribution.
-!
-! 3. Neither the name of the copyright holder nor the names of its contributors may be 
-!    used to endorse or promote products derived from this software without specific prior
-!    written permission.
-!
-! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY 
-! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 
-! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL 
-! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 
-! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT 
-! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 
-! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
-! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-!
-! History
-! May 2015 - D. Swales - Original version
-! Jul 2017 - R. Guzman - Added Ground LIDar variables (GLID)
-! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-MODULE MOD_COSP_CALIPSO_INTERFACE
-  USE COSP_KINDS,              ONLY: wp
-  USE MOD_LIDAR_SIMULATOR,     ONLY: alpha,beta,gamma
-  IMPLICIT NONE
-  
-  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-  ! TYPE calipso_in
-  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 
-  type calipso_IN
-     integer,pointer ::       &
-          Npoints,      & ! Number of gridpoints.
-          Ncolumns,     & ! Number of columns.
-          Nlevels         ! Number of levels.
-
-     real(wp),dimension(:,:),pointer :: &
-          beta_mol,     & ! Molecular backscatter coefficient
-          tau_mol         ! Molecular optical depth
-     real(wp),dimension(:,:,:),pointer :: &
-          betatot,      & ! 
-          tautot,       & ! Optical thickess integrated from top
-          betatot_ice,  & ! Backscatter coefficient for ice particles
-          betatot_liq,  & ! Backscatter coefficient for liquid particles
-          tautot_ice,   & ! Total optical thickness of ice
-          tautot_liq      ! Total optical thickness of liq
-     real(wp),dimension(:,:,:,:),pointer :: &
-          taupart
-  end type calipso_IN
-
-CONTAINS
-  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-  ! SUBROUTINE cosp_calipso_init
-  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-  subroutine cosp_calipso_init() 
-    
-    ! Polynomial coefficients (Alpha, Beta, Gamma) which allow to compute the 
-    ! ATBperpendicular as a function of the ATB for ice or liquid cloud particles 
-    ! derived from CALIPSO-GOCCP observations at 120m vertical grid 
-    ! (Cesana and Chepfer, JGR, 2013).
-    !
-    ! Relationship between ATBice and ATBperp,ice for ice particles:
-    !                ATBperp,ice = Alpha*ATBice 
-    ! Relationship between ATBice and ATBperp,ice for liquid particles:
-    !          ATBperp,ice = Beta*ATBice^2 + Gamma*ATBice
-    Alpha = 0.2904_wp
-    Beta  = 0.4099_wp
-    Gamma = 0.009_wp    
-    
-  end subroutine cosp_calipso_init
-
-  ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-  !	END MODULE
-  ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-END MODULE MOD_COSP_CALIPSO_INTERFACE
Index: /LMDZ6/trunk/libf/phylmd/cospv2/cosp_calipso_interface.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cospv2/cosp_calipso_interface.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/cospv2/cosp_calipso_interface.f90	(revision 5268)
@@ -0,0 +1,85 @@
+! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+! Copyright (c) 2015, Regents of the University of Colorado
+! All rights reserved.
+!
+! Redistribution and use in source and binary forms, with or without modification, are 
+! permitted provided that the following conditions are met:
+!
+! 1. Redistributions of source code must retain the above copyright notice, this list of 
+!    conditions and the following disclaimer.
+!
+! 2. Redistributions in binary form must reproduce the above copyright notice, this list
+!    of conditions and the following disclaimer in the documentation and/or other 
+!    materials provided with the distribution.
+!
+! 3. Neither the name of the copyright holder nor the names of its contributors may be 
+!    used to endorse or promote products derived from this software without specific prior
+!    written permission.
+!
+! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY 
+! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 
+! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL 
+! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 
+! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT 
+! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 
+! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+!
+! History
+! May 2015 - D. Swales - Original version
+! Jul 2017 - R. Guzman - Added Ground LIDar variables (GLID)
+! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+MODULE MOD_COSP_CALIPSO_INTERFACE
+  USE COSP_KINDS,              ONLY: wp
+  USE MOD_LIDAR_SIMULATOR,     ONLY: alpha,beta,gamma
+  IMPLICIT NONE
+  
+  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  ! TYPE calipso_in
+  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 
+  type calipso_IN
+     integer,pointer ::       &
+          Npoints,      & ! Number of gridpoints.
+          Ncolumns,     & ! Number of columns.
+          Nlevels         ! Number of levels.
+
+     real(wp),dimension(:,:),pointer :: &
+          beta_mol,     & ! Molecular backscatter coefficient
+          tau_mol         ! Molecular optical depth
+     real(wp),dimension(:,:,:),pointer :: &
+          betatot,      & ! 
+          tautot,       & ! Optical thickess integrated from top
+          betatot_ice,  & ! Backscatter coefficient for ice particles
+          betatot_liq,  & ! Backscatter coefficient for liquid particles
+          tautot_ice,   & ! Total optical thickness of ice
+          tautot_liq      ! Total optical thickness of liq
+     real(wp),dimension(:,:,:,:),pointer :: &
+          taupart
+  end type calipso_IN
+
+CONTAINS
+  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  ! SUBROUTINE cosp_calipso_init
+  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  subroutine cosp_calipso_init() 
+    
+    ! Polynomial coefficients (Alpha, Beta, Gamma) which allow to compute the 
+    ! ATBperpendicular as a function of the ATB for ice or liquid cloud particles 
+    ! derived from CALIPSO-GOCCP observations at 120m vertical grid 
+    ! (Cesana and Chepfer, JGR, 2013).
+    !
+    ! Relationship between ATBice and ATBperp,ice for ice particles:
+    !                ATBperp,ice = Alpha*ATBice 
+    ! Relationship between ATBice and ATBperp,ice for liquid particles:
+    !          ATBperp,ice = Beta*ATBice^2 + Gamma*ATBice
+    Alpha = 0.2904_wp
+    Beta  = 0.4099_wp
+    Gamma = 0.009_wp    
+    
+  end subroutine cosp_calipso_init
+
+  ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  !	END MODULE
+  ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+END MODULE MOD_COSP_CALIPSO_INTERFACE
Index: DZ6/trunk/libf/phylmd/cospv2/cosp_cloudsat_interface.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cospv2/cosp_cloudsat_interface.F90	(revision 5267)
+++ 	(revision )
@@ -1,142 +1,0 @@
-! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-! Copyright (c) 2015, Regents of the University of Colorado
-! All rights reserved.
-!
-! Redistribution and use in source and binary forms, with or without modification, are
-! permitted provided that the following conditions are met:
-!
-! 1. Redistributions of source code must retain the above copyright notice, this list of
-!    conditions and the following disclaimer.
-!
-! 2. Redistributions in binary form must reproduce the above copyright notice, this list
-!    of conditions and the following disclaimer in the documentation and/or other
-!    materials provided with the distribution.
-!
-! 3. Neither the name of the copyright holder nor the names of its contributors may be
-!    used to endorse or promote products derived from this software without specific prior
-!    written permission.
-!
-! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY
-! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
-! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL
-! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT
-! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
-! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
-! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-!
-! History
-! May 2015 - D. Swales - Original version
-! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-MODULE MOD_COSP_CLOUDSAT_INTERFACE
-  USE COSP_KINDS,      ONLY: wp
-  USE quickbeam,       ONLY: quickbeam_init,radar_cfg,Re_MAX_BIN,Re_BIN_LENGTH
-  IMPLICIT NONE
-
-  ! Directory where LUTs will be stored
-  character(len=120) :: RADAR_SIM_LUT_DIRECTORY = './'
-  logical :: RADAR_SIM_LOAD_scale_LUTs_flag   = .false.
-  logical :: RADAR_SIM_UPDATE_scale_LUTs_flag = .false.
-  
-  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-  ! TYPE cloudsat_IN
-  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-  type cloudsat_IN
-     integer,pointer ::            &
-          Npoints,         & ! Number of horizontal grid-points
-          Nlevels,         & ! Number of vertical levels
-          Ncolumns           ! Number of subcolumns
-     real(wp),pointer ::   &
-          hgt_matrix(:,:),   & ! Height of hydrometeors (km)
-          z_vol(:,:,:),      & ! Effective reflectivity factor (mm^6/m^3)
-          kr_vol(:,:,:),     & ! Attenuation coefficient hydro (dB/km)
-          g_vol(:,:,:),      & ! Attenuation coefficient gases (dB/km)
-          g_to_vol_in(:,:)     ! Gaseous atteunation, radar to vol (dB)
-     type(radar_cfg),pointer :: rcfg   ! Radar simulator configuration
-  end type cloudsat_IN
-
-CONTAINS
-
-  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-  !                              SUBROUTINE cosp_cloudsat_in
-  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-  SUBROUTINE COSP_CLOUDSAT_INIT(radar_freq,k2,use_gas_abs,do_ray,undef,nhydro,   &
-                                surface_radar,rcfg,cloudsat_micro_scheme,load_LUT)
-    ! INPUTS
-    real(wp),intent(in) :: &
-         radar_freq,  & ! Radar frequency (GHz)
-         k2,          & ! |K|^2, the dielectric constant
-         undef          ! Undefined
-    integer,intent(in) :: &
-         use_gas_abs, & ! 1 = do gaseous abs calcs, 0=no gasesous absorbtion calculated,
-                        ! 2 = calculate absorption for first profile on all profiles
-         do_ray,      & !
-         nhydro,      & !
-         surface_radar
-    logical,intent(in),optional :: &
-         load_LUT
-    character(len=64),intent(in) :: &
-       cloudsat_micro_scheme
-
-    ! OUTPUTS
-    type(radar_cfg) :: &
-         rcfg           !
-
-    ! LOCAL VARIABLES
-    character(len=240) :: LUT_file_name
-    logical       :: local_load_LUT
-    integer       :: j
-
-    if (present(load_LUT)) then
-       local_load_LUT = load_LUT
-    else
-       local_load_LUT = RADAR_SIM_LOAD_scale_LUTs_flag
-    endif
-    
-    ! LUT file name
-    LUT_file_name = trim(RADAR_SIM_LUT_DIRECTORY) // &
-         trim(cloudsat_micro_scheme)
-
-    ! Initialize for NEW radar-configurarion derived type (radar_cfg)
-    rcfg%freq                = radar_freq
-    rcfg%k2                  = k2
-    rcfg%use_gas_abs         = use_gas_abs
-    rcfg%do_ray              = do_ray
-    rcfg%nhclass             = nhydro
-    rcfg%load_scale_LUTs     = local_load_LUT
-    rcfg%update_scale_LUTs   = .false.
-    rcfg%scale_LUT_file_name = LUT_file_name
-    rcfg%N_scale_flag        = .false.
-    rcfg%fc                  = undef
-    rcfg%rho_eff             = undef
-    rcfg%Z_scale_flag        = .false.
-    rcfg%Ze_scaled           = 0._wp
-    rcfg%Zr_scaled           = 0._wp
-    rcfg%kr_scaled           = 0._wp
-
-    ! Set up Re bin "structure" for z_scaling
-    rcfg%base_list(1)=0
-    do j=1,Re_MAX_BIN
-       rcfg%step_list(j)=0.1_wp+0.1_wp*((j-1)**1.5)
-       if(rcfg%step_list(j)>Re_BIN_LENGTH) then
-          rcfg%step_list(j)=Re_BIN_LENGTH
-       endif
-       if(j>1) then
-          rcfg%base_list(j)=rcfg%base_list(j-1)+floor(Re_BIN_LENGTH/rcfg%step_list(j-1))
-       endif
-    enddo
-
-    ! Set flag denoting position of radar
-    if (surface_radar == 1) then
-       rcfg%radar_at_layer_one = .false.
-    else
-       rcfg%radar_at_layer_one = .true.
-    endif
-
-  END SUBROUTINE COSP_CLOUDSAT_INIT
-
-  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-  !                              	  END MODULE
-  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-END MODULE MOD_COSP_CLOUDSAT_INTERFACE
Index: /LMDZ6/trunk/libf/phylmd/cospv2/cosp_cloudsat_interface.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cospv2/cosp_cloudsat_interface.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/cospv2/cosp_cloudsat_interface.f90	(revision 5268)
@@ -0,0 +1,142 @@
+! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+! Copyright (c) 2015, Regents of the University of Colorado
+! All rights reserved.
+!
+! Redistribution and use in source and binary forms, with or without modification, are
+! permitted provided that the following conditions are met:
+!
+! 1. Redistributions of source code must retain the above copyright notice, this list of
+!    conditions and the following disclaimer.
+!
+! 2. Redistributions in binary form must reproduce the above copyright notice, this list
+!    of conditions and the following disclaimer in the documentation and/or other
+!    materials provided with the distribution.
+!
+! 3. Neither the name of the copyright holder nor the names of its contributors may be
+!    used to endorse or promote products derived from this software without specific prior
+!    written permission.
+!
+! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY
+! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
+! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL
+! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT
+! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+!
+! History
+! May 2015 - D. Swales - Original version
+! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+MODULE MOD_COSP_CLOUDSAT_INTERFACE
+  USE COSP_KINDS,      ONLY: wp
+  USE quickbeam,       ONLY: quickbeam_init,radar_cfg,Re_MAX_BIN,Re_BIN_LENGTH
+  IMPLICIT NONE
+
+  ! Directory where LUTs will be stored
+  character(len=120) :: RADAR_SIM_LUT_DIRECTORY = './'
+  logical :: RADAR_SIM_LOAD_scale_LUTs_flag   = .false.
+  logical :: RADAR_SIM_UPDATE_scale_LUTs_flag = .false.
+  
+  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  ! TYPE cloudsat_IN
+  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  type cloudsat_IN
+     integer,pointer ::            &
+          Npoints,         & ! Number of horizontal grid-points
+          Nlevels,         & ! Number of vertical levels
+          Ncolumns           ! Number of subcolumns
+     real(wp),pointer ::   &
+          hgt_matrix(:,:),   & ! Height of hydrometeors (km)
+          z_vol(:,:,:),      & ! Effective reflectivity factor (mm^6/m^3)
+          kr_vol(:,:,:),     & ! Attenuation coefficient hydro (dB/km)
+          g_vol(:,:,:),      & ! Attenuation coefficient gases (dB/km)
+          g_to_vol_in(:,:)     ! Gaseous atteunation, radar to vol (dB)
+     type(radar_cfg),pointer :: rcfg   ! Radar simulator configuration
+  end type cloudsat_IN
+
+CONTAINS
+
+  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  !                              SUBROUTINE cosp_cloudsat_in
+  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  SUBROUTINE COSP_CLOUDSAT_INIT(radar_freq,k2,use_gas_abs,do_ray,undef,nhydro,   &
+                                surface_radar,rcfg,cloudsat_micro_scheme,load_LUT)
+    ! INPUTS
+    real(wp),intent(in) :: &
+         radar_freq,  & ! Radar frequency (GHz)
+         k2,          & ! |K|^2, the dielectric constant
+         undef          ! Undefined
+    integer,intent(in) :: &
+         use_gas_abs, & ! 1 = do gaseous abs calcs, 0=no gasesous absorbtion calculated,
+                        ! 2 = calculate absorption for first profile on all profiles
+         do_ray,      & !
+         nhydro,      & !
+         surface_radar
+    logical,intent(in),optional :: &
+         load_LUT
+    character(len=64),intent(in) :: &
+       cloudsat_micro_scheme
+
+    ! OUTPUTS
+    type(radar_cfg) :: &
+         rcfg           !
+
+    ! LOCAL VARIABLES
+    character(len=240) :: LUT_file_name
+    logical       :: local_load_LUT
+    integer       :: j
+
+    if (present(load_LUT)) then
+       local_load_LUT = load_LUT
+    else
+       local_load_LUT = RADAR_SIM_LOAD_scale_LUTs_flag
+    endif
+    
+    ! LUT file name
+    LUT_file_name = trim(RADAR_SIM_LUT_DIRECTORY) // &
+         trim(cloudsat_micro_scheme)
+
+    ! Initialize for NEW radar-configurarion derived type (radar_cfg)
+    rcfg%freq                = radar_freq
+    rcfg%k2                  = k2
+    rcfg%use_gas_abs         = use_gas_abs
+    rcfg%do_ray              = do_ray
+    rcfg%nhclass             = nhydro
+    rcfg%load_scale_LUTs     = local_load_LUT
+    rcfg%update_scale_LUTs   = .false.
+    rcfg%scale_LUT_file_name = LUT_file_name
+    rcfg%N_scale_flag        = .false.
+    rcfg%fc                  = undef
+    rcfg%rho_eff             = undef
+    rcfg%Z_scale_flag        = .false.
+    rcfg%Ze_scaled           = 0._wp
+    rcfg%Zr_scaled           = 0._wp
+    rcfg%kr_scaled           = 0._wp
+
+    ! Set up Re bin "structure" for z_scaling
+    rcfg%base_list(1)=0
+    do j=1,Re_MAX_BIN
+       rcfg%step_list(j)=0.1_wp+0.1_wp*((j-1)**1.5)
+       if(rcfg%step_list(j)>Re_BIN_LENGTH) then
+          rcfg%step_list(j)=Re_BIN_LENGTH
+       endif
+       if(j>1) then
+          rcfg%base_list(j)=rcfg%base_list(j-1)+floor(Re_BIN_LENGTH/rcfg%step_list(j-1))
+       endif
+    enddo
+
+    ! Set flag denoting position of radar
+    if (surface_radar == 1) then
+       rcfg%radar_at_layer_one = .false.
+    else
+       rcfg%radar_at_layer_one = .true.
+    endif
+
+  END SUBROUTINE COSP_CLOUDSAT_INIT
+
+  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  !                              	  END MODULE
+  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+END MODULE MOD_COSP_CLOUDSAT_INTERFACE
Index: DZ6/trunk/libf/phylmd/cospv2/cosp_config.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cospv2/cosp_config.F90	(revision 5267)
+++ 	(revision )
@@ -1,429 +1,0 @@
-! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-! Copyright (c) 2015, Regents of the University of Colorado
-! All rights reserved.
-!
-! Redistribution and use in source and binary forms, with or without modification, are 
-! permitted provided that the following conditions are met:
-!
-! 1. Redistributions of source code must retain the above copyright notice, this list of 
-!    conditions and the following disclaimer.
-!
-! 2. Redistributions in binary form must reproduce the above copyright notice, this list
-!    of conditions and the following disclaimer in the documentation and/or other 
-!    materials provided with the distribution.
-!
-! 3. Neither the name of the copyright holder nor the names of its contributors may be 
-!    used to endorse or promote products derived from this software without specific prior
-!    written permission.
-!
-! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY 
-! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 
-! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL 
-! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 
-! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT 
-! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 
-! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
-! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-!
-! History:
-! Jul 2007 - A. Bodas-Salcedo - Initial version
-! Jul 2008 - A. Bodas-Salcedo - Added definitions of ISCCP axes
-! Oct 2008 - H. Chepfer       - Added PARASOL_NREFL
-! Jun 2010 - R. Marchand      - Modified to support quickbeam V3, added ifdef for  
-!                               hydrometeor definitions
-! May 2015 - D. Swales        - Tidied up. Set up appropriate fields during initialization. 
-! June 2015- D. Swales        - Moved hydrometeor class variables to hydro_class_init in
-!                               the module quickbeam_optics.
-! Mar 2016 - D. Swales        - Added scops_ccfrac. Was previously hardcoded in prec_scops.f90.  
-! Mar 2018 - R. Guzman        - Added LIDAR_NTYPE for the OPAQ diagnostics
-! Apr 2018 - R. Guzman        - Added parameters for GROUND LIDAR and ATLID simulators
-!
-! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-
-MODULE MOD_COSP_CONFIG
-    USE COSP_KINDS, ONLY: wp,dp
-    IMPLICIT NONE
-
-   ! #####################################################################################
-   ! Common COSP information
-   ! #####################################################################################
-    character(len=32) ::   &
-         COSP_VERSION              ! COSP Version ID (set in cosp_interface_init)
-    real(wp),parameter ::  &
-         R_UNDEF      = -1.0E30, & ! Missing value
-         R_GROUND     = -1.0E20, & ! Flag for below ground results
-         scops_ccfrac = 0.05       ! Fraction of column (or subcolumn) covered with convective
-                                   ! precipitation (default is 5%). *NOTE* This quantity may vary
-                                   ! between modeling centers.
-    logical :: &
-         use_vgrid                 ! True=Use new grid for L3 CLOUDAT and CALIPSO
-    integer,parameter ::   &
-         SR_BINS = 15,           & ! Number of bins (backscattering coefficient) in CALOPSO LIDAR simulator.
-         N_HYDRO = 9               ! Number of hydrometeor classes used by quickbeam radar simulator.
-
-    ! Mode debug ou prod (AI 0302018)
-    logical :: ok_debug_cosp = .true.
-    ! ####################################################################################  
-    ! Joint histogram bin-boundaries
-    ! tau is used by ISCCP and MISR
-    ! pres is used by ISCCP
-    ! hgt is used by MISR
-    ! ReffLiq is used by MODIS
-    ! ReffIce is used by MODIS
-    ! *NOTE* ALL JOINT-HISTOGRAM BIN BOUNDARIES ARE DECLARED AND DEFINED HERE IN
-    !        COSP_CONFIG, WITH THE EXCEPTION OF THE TAU AXIS USED BY THE MODIS SIMULATOR,
-    !        WHICH IS SET DURING INITIALIZATION IN COSP_INTERFACE_INIT.
-    ! ####################################################################################
-    ! Optical depth bin axis
-    integer,parameter :: &
-         ntau=7  
-    real(wp),parameter,dimension(ntau+1) :: &
-       tau_binBounds = (/0.0, 0.3, 1.3, 3.6, 9.4, 23., 60., 10000./)
-    real(wp),parameter,dimension(ntau) :: &
-         tau_binCenters = (/0.15, 0.80, 2.45, 6.5, 16.2, 41.5, 100.0/)
-    real(wp),parameter,dimension(2,ntau) :: &
-         tau_binEdges = reshape(source=(/0.0, 0.3,  0.3,  1.3,  1.3,  3.6,      3.6,     &
-                                         9.4, 9.4, 23.0, 23.0, 60.0, 60.0, 100000.0/),   &
-                                         shape=(/2,ntau/)) 
-
-    ! Optical depth bin axes (ONLY USED BY MODIS SIMULATOR IN v1.4)
-    integer :: l,k
-    integer,parameter :: &
-         ntauV1p4 = 6
-    real(wp),parameter,dimension(ntauV1p4+1) :: &
-         tau_binBoundsV1p4 = (/0.3, 1.3, 3.6, 9.4, 23., 60., 10000./)
-    real(wp),parameter,dimension(2,ntauV1p4) :: &
-         tau_binEdgesV1p4 = reshape(source =(/tau_binBoundsV1p4(1),((tau_binBoundsV1p4(k),l=1,2),   &
-                                             k=2,ntauV1p4),100000._wp/),shape = (/2,ntauV1p4/)) 
-    real(wp),parameter,dimension(ntauV1p4) :: &
-         tau_binCentersV1p4 = (tau_binEdgesV1p4(1,:)+tau_binEdgesV1p4(2,:))/2._wp  
-    
-    ! Cloud-top height pressure bin axis
-    integer,parameter :: &
-         npres = 7     
-    real(wp),parameter,dimension(npres+1) :: &
-         pres_binBounds = (/0., 180., 310., 440., 560., 680., 800., 10000./)
-    real(wp),parameter,dimension(npres) :: &
-         pres_binCenters = (/90000., 74000., 62000., 50000., 37500., 24500., 9000./)   
-    real(wp),parameter,dimension(2,npres) :: &
-         pres_binEdges = reshape(source=(/100000.0, 80000.0, 80000.0, 68000.0, 68000.0,    &
-                                           56000.0, 56000.0, 44000.0, 44000.0, 31000.0,    &
-                                           31000.0, 18000.0, 18000.0,     0.0/),           &
-                                           shape=(/2,npres/))
-
-    ! Cloud-top height bin axis #1
-    integer,parameter :: &
-         nhgt = 16
-    real(wp),parameter,dimension(nhgt+1) :: &
-         hgt_binBounds = (/-.99,0.,0.5,1.,1.5,2.,2.5,3.,4.,5.,7.,9.,11.,13.,15.,17.,99./)
-    real(wp),parameter,dimension(nhgt) :: &
-         hgt_binCenters = 1000*(/0.,0.25,0.75,1.25,1.75,2.25,2.75,3.5,4.5,6.,8.,10.,12.,   &
-         14.5,16.,18./)  
-    real(wp),parameter,dimension(2,nhgt) :: &
-         hgt_binEdges = 1000.0*reshape(source=(/-99.0, 0.0, 0.0, 0.5, 0.5, 1.0, 1.0, 1.5,  &
-                                                  1.5, 2.0, 2.0, 2.5, 2.5, 3.0, 3.0, 4.0,  &
-                                                  4.0, 5.0, 5.0, 7.0, 7.0, 9.0, 9.0,11.0,  &
-                                                  11.0,13.0,13.0,15.0,15.0,17.0,17.0,99.0/),&
-                                                  shape=(/2,nhgt/))    
-
-    ! Liquid and Ice particle bins for MODIS joint histogram of optical-depth and particle
-    ! size
-    integer :: i,j
-    integer,parameter :: &
-         nReffLiq = 6, & ! Number of bins for tau/ReffLiq joint-histogram
-         nReffIce = 6    ! Number of bins for tau/ReffICE joint-histogram
-    real(wp),parameter,dimension(nReffLiq+1) :: &
-         reffLIQ_binBounds = (/0., 8e-6, 1.0e-5, 1.3e-5, 1.5e-5, 2.0e-5, 3.0e-5/)
-    real(wp),parameter,dimension(nReffIce+1) :: &
-         reffICE_binBounds = (/0., 1.0e-5, 2.0e-5, 3.0e-5, 4.0e-5, 6.0e-5, 9.0e-5/)
-    real(wp),parameter,dimension(2,nReffICE) :: &
-         reffICE_binEdges = reshape(source=(/reffICE_binBounds(1),((reffICE_binBounds(k),  &
-                                    l=1,2),k=2,nReffICE),reffICE_binBounds(nReffICE+1)/),  &
-                                    shape = (/2,nReffICE/)) 
-    real(wp),parameter,dimension(2,nReffLIQ) :: &
-         reffLIQ_binEdges = reshape(source=(/reffLIQ_binBounds(1),((reffLIQ_binBounds(k),  &
-                                    l=1,2),k=2,nReffLIQ),reffLIQ_binBounds(nReffICE+1)/),  &
-                                    shape = (/2,nReffLIQ/))             
-    real(wp),parameter,dimension(nReffICE) :: &
-         reffICE_binCenters = (reffICE_binEdges(1,:)+reffICE_binEdges(2,:))/2._wp
-    real(wp),parameter,dimension(nReffLIQ) :: &
-         reffLIQ_binCenters = (reffLIQ_binEdges(1,:)+reffLIQ_binEdges(2,:))/2._wp
-
-    ! ####################################################################################  
-    ! Constants used by RTTOV.
-    ! ####################################################################################  
-    integer,parameter :: &
-         RTTOV_MAX_CHANNELS = 20
-    character(len=256),parameter :: &
-         rttovDir = '/homedata/rguzman/CALIPSO/RTTOV/rttov_11.3/'
-    ! ####################################################################################  
-    ! Constants used by the PARASOL simulator.
-    ! ####################################################################################  
-    integer,parameter :: &
-         PARASOL_NREFL = 5,  & ! Number of angles in LUT
-         PARASOL_NTAU  = 7     ! Number of optical depths in LUT
-    real(wp),parameter,dimension(PARASOL_NREFL) :: &
-         PARASOL_SZA = (/0.0, 20.0, 40.0, 60.0, 80.0/)
-    REAL(WP),parameter,dimension(PARASOL_NTAU) :: &
-         PARASOL_TAU = (/0., 1., 5., 10., 20., 50., 100./)
-    
-    ! LUTs
-    REAL(WP),parameter,dimension(PARASOL_NREFL,PARASOL_NTAU) :: &
-         ! LUT for liquid particles
-         rlumA = reshape(source=(/ 0.03,     0.03,     0.03,     0.03,     0.03,         &
-                                   0.090886, 0.072185, 0.058410, 0.052498, 0.034730,     &
-                                   0.283965, 0.252596, 0.224707, 0.175844, 0.064488,     &
-                                   0.480587, 0.436401, 0.367451, 0.252916, 0.081667,     &
-                                   0.695235, 0.631352, 0.509180, 0.326551, 0.098215,     &
-                                   0.908229, 0.823924, 0.648152, 0.398581, 0.114411,     &
-                                   1.0,      0.909013, 0.709554, 0.430405, 0.121567/),   &
-                                   shape=(/PARASOL_NREFL,PARASOL_NTAU/)),                & 
-         ! LUT for ice particles         			     
-         rlumB = reshape(source=(/ 0.03,     0.03,     0.03,     0.03,     0.03,         &
-                                   0.092170, 0.087082, 0.083325, 0.084935, 0.054157,     &
-                                   0.311941, 0.304293, 0.285193, 0.233450, 0.089911,     &
-                                   0.511298, 0.490879, 0.430266, 0.312280, 0.107854,     &
-                                   0.712079, 0.673565, 0.563747, 0.382376, 0.124127,     &
-                                   0.898243, 0.842026, 0.685773, 0.446371, 0.139004,     &
-                                   0.976646, 0.912966, 0.737154, 0.473317, 0.145269/),   &
-                                   shape=(/PARASOL_NREFL,PARASOL_NTAU/))  
-
-    ! ####################################################################################
-    ! ISCCP simulator tau/CTP joint histogram information
-    ! ####################################################################################
-    integer,parameter :: &
-         numISCCPTauBins  = ntau, &              ! Number of optical depth bins
-         numISCCPPresBins = npres                ! Number of pressure bins     
-    real(wp),parameter,dimension(ntau+1) :: &
-         isccp_histTau = tau_binBounds           ! Joint-histogram boundaries (optical depth)
-    real(wp),parameter,dimension(npres+1) :: &
-         isccp_histPres = pres_binBounds         ! Joint-histogram boundaries (cloud pressure)
-    real(wp),parameter,dimension(ntau) :: &
-         isccp_histTauCenters = tau_binCenters   ! Joint histogram bin centers (optical depth)
-    real(wp),parameter,dimension(npres) :: &   
-         isccp_histPresCenters = pres_binCenters ! Joint histogram bin centers (cloud pressure) 
-    real(wp),parameter,dimension(2,ntau) :: &
-         isccp_histTauEdges = tau_binEdges       ! Joint histogram bin edges (optical depth)
-    real(wp),parameter,dimension(2,npres) :: &    
-         isccp_histPresEdges = pres_binEdges     ! Joint histogram bin edges (cloud pressure)   
-    
-    ! ####################################################################################
-    ! MISR simulator tau/CTH joint histogram information 
-    ! ####################################################################################
-    integer,parameter ::  &
-         numMISRHgtBins = nhgt, &             ! Number of cloud-top height bins
-         numMISRTauBins = ntau                ! Number of optical depth bins
-    ! Joint histogram boundaries
-    real(wp),parameter,dimension(numMISRHgtBins+1) :: &
-         misr_histHgt = hgt_binBounds         ! Joint-histogram boundaries (cloud height)
-    real(wp),parameter,dimension(numMISRTauBins+1) :: &
-         misr_histTau = tau_binBounds         ! Joint-histogram boundaries (optical-depth)
-    real(wp),parameter,dimension(numMISRHgtBins) :: &
-         misr_histHgtCenters = hgt_binCenters ! Joint-histogram bin centers (cloud height)
-    real(wp),parameter,dimension(2,numMISRHgtBins) :: &
-         misr_histHgtEdges = hgt_BinEdges     ! Joint-histogram bin edges (cloud height)
- 
-    ! ####################################################################################
-    ! MODIS simulator tau/CTP joint histogram information 
-    ! ####################################################################################
-    integer,parameter :: &
-         numMODISPresBins = npres                    ! Number of pressure bins for joint-histogram    
-    real(wp),parameter,dimension(numMODISPresBins + 1) :: & 
-         modis_histPres = 100*pres_binBounds         ! Joint-histogram boundaries (cloud pressure)
-    real(wp),parameter,dimension(2, numMODISPresBins) :: &
-         modis_histPresEdges = 100*pres_binEdges     ! Joint-histogram bin edges (cloud pressure)
-    real(wp),parameter,dimension(numMODISPresBins) :: &
-         modis_histPresCenters = 100*pres_binCenters ! Joint-histogram bin centers (cloud pressure)
-
-    ! For the MODIS simulator we want to preserve the ability for cospV1.4.0 to use the
-    ! old histogram bin boundaries for optical depth, so these are set up in initialization.
-    integer :: &
-         numMODISTauBins          ! Number of tau bins for joint-histogram
-    real(wp),save,allocatable,dimension(:) :: &
-         modis_histTau            ! Joint-histogram boundaries (optical depth)
-    !$OMP THREADPRIVATE(modis_histTau)
-    real(wp),save,allocatable,dimension(:,:) :: &
-         modis_histTauEdges       ! Joint-histogram bin edges (optical depth)
-    !$OMP THREADPRIVATE(modis_histTauEdges)
-    real(wp),save,allocatable,dimension(:) :: &
-         modis_histTauCenters     ! Joint-histogram bin centers (optical depth)
-    !$OMP THREADPRIVATE(modis_histTauCenters)
-    
-    ! ####################################################################################
-    ! MODIS simulator tau/ReffICE and tau/ReffLIQ joint-histogram information
-    ! ####################################################################################
-    ! Ice
-    integer,parameter :: &
-         numMODISReffIceBins = nReffIce                ! Number of bins for joint-histogram
-    real(wp),parameter,dimension(nReffIce+1) :: &
-         modis_histReffIce = reffICE_binBounds         ! Effective radius bin boundaries
-    real(wp),parameter,dimension(nReffIce) :: &
-         modis_histReffIceCenters = reffICE_binCenters ! Effective radius bin centers
-    real(wp),parameter,dimension(2,nReffICE) :: &
-         modis_histReffIceEdges = reffICE_binEdges     ! Effective radius bin edges
-       
-    ! Liquid
-    integer,parameter :: &
-         numMODISReffLiqBins = nReffLiq                ! Number of bins for joint-histogram
-    real(wp),parameter,dimension(nReffLiq+1) :: &
-         modis_histReffLiq = reffLIQ_binBounds         ! Effective radius bin boundaries 
-    real(wp),parameter,dimension(nReffLiq) :: &
-         modis_histReffLiqCenters = reffICE_binCenters ! Effective radius bin centers
-    real(wp),parameter,dimension(2,nReffICE) :: &
-         modis_histReffLiqEdges = reffLIQ_binEdges     ! Effective radius bin edges
-
-    ! ####################################################################################
-    ! CLOUDSAT reflectivity histogram information 
-    ! ####################################################################################
-    integer,parameter :: &
-       CLOUDSAT_DBZE_BINS     =   15, & ! Number of dBZe bins in histogram (cfad)
-       CLOUDSAT_DBZE_MIN      = -100, & ! Minimum value for radar reflectivity
-       CLOUDSAT_DBZE_MAX      =   80, & ! Maximum value for radar reflectivity
-       CLOUDSAT_CFAD_ZE_MIN   =  -50, & ! Lower value of the first CFAD Ze bin
-       CLOUDSAT_CFAD_ZE_WIDTH =    5    ! Bin width (dBZe)
-
-    real(wp),parameter,dimension(CLOUDSAT_DBZE_BINS+1) :: &
-         cloudsat_histRef = (/CLOUDSAT_DBZE_MIN,(/(i, i=int(CLOUDSAT_CFAD_ZE_MIN+CLOUDSAT_CFAD_ZE_WIDTH),&
-                             int(CLOUDSAT_CFAD_ZE_MIN+(CLOUDSAT_DBZE_BINS-1)*CLOUDSAT_CFAD_ZE_WIDTH),    &
-                             int(CLOUDSAT_CFAD_ZE_WIDTH))/),CLOUDSAT_DBZE_MAX/)
-    real(wp),parameter,dimension(2,CLOUDSAT_DBZE_BINS) :: &
-         cloudsat_binEdges = reshape(source=(/cloudsat_histRef(1),((cloudsat_histRef(k), &
-                                   l=1,2),k=2,CLOUDSAT_DBZE_BINS),cloudsat_histRef(CLOUDSAT_DBZE_BINS+1)/),&
-                                   shape = (/2,CLOUDSAT_DBZE_BINS/))     
-    real(wp),parameter,dimension(CLOUDSAT_DBZE_BINS) :: &
-         cloudsat_binCenters = (cloudsat_binEdges(1,:)+cloudsat_binEdges(2,:))/2._wp
-    
-    ! Parameters for Cloudsat near-surface precipitation diagnostics.
-    ! Precipitation classes.
-    integer, parameter :: &
-         nCloudsatPrecipClass = 10
-    integer, parameter :: &
-         pClass_noPrecip      = 0, & ! No precipitation
-         pClass_Rain1         = 1, & ! Rain possible
-         pClass_Rain2         = 2, & ! Rain probable
-         pClass_Rain3         = 3, & ! Rain certain
-         pClass_Snow1         = 4, & ! Snow possible
-         pClass_Snow2         = 5, & ! Snow certain
-         pClass_Mixed1        = 6, & ! Mixed-precipitation possible
-         pClass_Mixed2        = 7, & ! Mixed-precipitation certain
-         pClass_Rain4         = 8, & ! Heavy rain
-         pClass_default       = 9    ! Default
-    ! Reflectivity bin boundaries, used by decision tree to classify precipitation type.
-    real(wp), dimension(4),parameter :: &
-         Zenonbinval =(/0._wp, -5._wp, -7.5_wp, -15._wp/)
-    real(wp), dimension(6),parameter :: &
-         Zbinvallnd = (/10._wp, 5._wp, 2.5_wp, -2.5_wp, -5._wp, -15._wp/)
-    ! Vertical level index(Nlvgrid) for Cloudsat precipitation occurence/frequency diagnostics.
-    ! Level 39 of Nlvgrid(40) is 480-960m.
-!    integer, parameter :: &    !PREC_BUG
-!         cloudsat_preclvl = 39 !PREC_BUG
-    
-    ! ####################################################################################
-    ! Parameters used by the CALIPSO LIDAR simulator
-    ! #################################################################################### 
-    ! CALISPO backscatter histogram bins 
-    real(wp),parameter ::     &
-       S_cld       = 5.0,     & ! Threshold for cloud detection
-       S_att       = 0.01,    & !
-       S_cld_att   = 30.        ! Threshold for undefined cloud phase detection
-    real(wp),parameter,dimension(SR_BINS+1) :: &
-         calipso_histBsct = (/-1.,0.01,1.2,3.0,5.0,7.0,10.0,15.0,20.0,25.0,30.0,40.0,50.0,   &
-                              60.0,80.0,999./)         ! Backscatter histogram bins
-    real(wp),parameter,dimension(2,SR_BINS) :: &
-         calipso_binEdges = reshape(source=(/calipso_histBsct(1),((calipso_histBsct(k),  &
-                                    l=1,2),k=2,SR_BINS),calipso_histBsct(SR_BINS+1)/),   &
-                                    shape = (/2,SR_BINS/))     
-    real(wp),parameter,dimension(SR_BINS) :: &
-         calipso_binCenters = (calipso_binEdges(1,:)+calipso_binEdges(2,:))/2._wp  
-
-    integer,parameter  ::     &
-       LIDAR_NTEMP = 40, & 
-       LIDAR_NCAT  = 4,  & ! Number of categories for cloudtop heights (high/mid/low/tot)
-       LIDAR_NTYPE = 3     ! Number of categories for OPAQ (opaque/thin cloud + z_opaque)
-    real(wp),parameter,dimension(LIDAR_NTEMP) :: &
-       LIDAR_PHASE_TEMP=                                                                 &
-       (/-91.5,-88.5,-85.5,-82.5,-79.5,-76.5,-73.5,-70.5,-67.5,-64.5,                    &
-         -61.5,-58.5,-55.5,-52.5,-49.5,-46.5,-43.5,-40.5,-37.5,-34.5,                    &
-         -31.5,-28.5,-25.5,-22.5,-19.5,-16.5,-13.5,-10.5, -7.5, -4.5,                    &
-          -1.5,  1.5,  4.5,  7.5, 10.5, 13.5, 16.5, 19.5, 22.5, 25.5/)
-    real(wp),parameter,dimension(2,LIDAR_NTEMP) :: &
-       LIDAR_PHASE_TEMP_BNDS=reshape(source=                                             &
-          (/-273.15, -90., -90., -87., -87., -84., -84., -81., -81., -78.,               &
-             -78.,   -75., -75., -72., -72., -69., -69., -66., -66., -63.,               &
-             -63.,   -60., -60., -57., -57., -54., -54., -51., -51., -48.,               &
-             -48.,   -45., -45., -42., -42., -39., -39., -36., -36., -33.,               &
-             -33.,   -30., -30., -27., -27., -24., -24., -21., -21., -18.,               &
-             -18.,   -15., -15., -12., -12.,  -9.,  -9.,  -6.,  -6.,  -3.,               &
-              -3.,     0.,   0.,   3.,   3.,   6.,   6.,   9.,   9.,  12.,               &
-              12.,    15.,  15.,  18.,  18.,  21.,  21.,  24.,  24., 100. /),            &
-              shape=(/2,40/))        
-
-    ! ####################################################################################
-    ! Parameters used by the GROUND LIDAR simulator
-    ! #################################################################################### 
-    ! GROUND LIDAR backscatter histogram bins 
-!    real(wp),parameter ::     &
-!       S_cld       = 5.0,     & ! Threshold for cloud detection
-!       S_att       = 0.01,    & !
-!       S_cld_att   = 30.        ! Threshold for undefined cloud phase detection
-    real(wp),parameter,dimension(SR_BINS+1) :: &
-         grLidar532_histBsct = (/-1.,0.01,1.2,3.0,5.0,7.0,10.0,15.0,20.0,25.0,30.0,40.0,50.0,  &
-                                 60.0,80.0,999./)         ! Backscatter histogram bins
-    real(wp),parameter,dimension(2,SR_BINS) :: &
-         grLidar532_binEdges = reshape(source=(/grLidar532_histBsct(1),((grLidar532_histBsct(k),  &
-                                    l=1,2),k=2,SR_BINS),grLidar532_histBsct(SR_BINS+1)/),   &
-                                    shape = (/2,SR_BINS/))     
-    real(wp),parameter,dimension(SR_BINS) :: &
-         grLidar532_binCenters = (grLidar532_binEdges(1,:)+grLidar532_binEdges(2,:))/2._wp  
-
-!    integer,parameter  ::     &
-!       LIDAR_NCAT  = 4       ! Number of categories for cloudtop heights (high/mid/low/tot)
-
-    ! ####################################################################################
-    ! Parameters used by the ATLID LIDAR simulator
-    ! #################################################################################### 
-    ! ATLID LIDAR backscatter histogram bins 
-    real(wp),parameter ::     &
-       S_cld_atlid       = 1.74,    & ! Threshold for cloud detection
-       S_att_atlid       = 0.01,    & !
-       S_cld_att_atlid   = 6.67        ! Threshold for undefined cloud phase detection
-    real(wp),parameter,dimension(SR_BINS+1) :: &
-         atlid_histBsct = (/-1.,0.01,1.03,1.38,1.74,2.07,2.62,3.65,4.63,5.63,6.67,8.8,11.25,  &
-                                 13.2,17.2,999./)         ! Backscatter histogram bins
-    real(wp),parameter,dimension(2,SR_BINS) :: &
-         atlid_binEdges = reshape(source=(/atlid_histBsct(1),((atlid_histBsct(k),  &
-                                    l=1,2),k=2,SR_BINS),atlid_histBsct(SR_BINS+1)/),   &
-                                    shape = (/2,SR_BINS/))     
-    real(wp),parameter,dimension(SR_BINS) :: &
-         atlid_binCenters = (atlid_binEdges(1,:)+atlid_binEdges(2,:))/2._wp  
-
-!    integer,parameter  ::     &
-!       LIDAR_NCAT  = 4       ! Number of categories for cloudtop heights (high/mid/low/tot)
-
-    ! ####################################################################################
-    ! New vertical grid used by CALIPSO and CLOUDSAT L3 (set up during initialization)
-    ! ####################################################################################
-    integer :: &
-         Nlvgrid      ! Number of levels in New grid
-    real(wp),dimension(:), save, allocatable :: &
-       vgrid_zl,  & ! New grid bottoms
-       vgrid_zu,  & ! New grid tops
-       vgrid_z      ! New grid center
-    !$OMP THREADPRIVATE(vgrid_zl,vgrid_zu,vgrid_z)
-
-    ! ####################################################################################
-    ! Vertical grid used by CALIPSO and CLOUDSAT L3 (LMDZ parameter)
-    ! ####################################################################################
-
-    integer, parameter :: &
-         niv_sorties = 40
-    real(wp),parameter,dimension(niv_sorties) :: &
-         vgrid_z_in = (/240.0, 720.0, 1200.0, 1680.0, 2160.0, 2640.0, 3120.0, 3600.0, &
-                        4080.0, 4560.0, 5040.0, 5520.0, 6000.0, 6480.0, 6960.0, 7440.0, &
-			7920.0, 8400.0, 8880.0, 9360.0, 9840.0, 10320.0, 10800.0, &
-			11280.0, 11760.0, 12240.0, 12720.0, 13200.0, 13680.0, 14160.0, &
-			14640.0, 15120.0, 15600.0, 16080.0, 16560.0, 17040.0, 17520.0, &
-			18000.0, 18480.0, 18960.0/)
-
-END MODULE MOD_COSP_CONFIG
Index: /LMDZ6/trunk/libf/phylmd/cospv2/cosp_config.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cospv2/cosp_config.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/cospv2/cosp_config.f90	(revision 5268)
@@ -0,0 +1,429 @@
+! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+! Copyright (c) 2015, Regents of the University of Colorado
+! All rights reserved.
+!
+! Redistribution and use in source and binary forms, with or without modification, are 
+! permitted provided that the following conditions are met:
+!
+! 1. Redistributions of source code must retain the above copyright notice, this list of 
+!    conditions and the following disclaimer.
+!
+! 2. Redistributions in binary form must reproduce the above copyright notice, this list
+!    of conditions and the following disclaimer in the documentation and/or other 
+!    materials provided with the distribution.
+!
+! 3. Neither the name of the copyright holder nor the names of its contributors may be 
+!    used to endorse or promote products derived from this software without specific prior
+!    written permission.
+!
+! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY 
+! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 
+! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL 
+! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 
+! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT 
+! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 
+! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+!
+! History:
+! Jul 2007 - A. Bodas-Salcedo - Initial version
+! Jul 2008 - A. Bodas-Salcedo - Added definitions of ISCCP axes
+! Oct 2008 - H. Chepfer       - Added PARASOL_NREFL
+! Jun 2010 - R. Marchand      - Modified to support quickbeam V3, added ifdef for  
+!                               hydrometeor definitions
+! May 2015 - D. Swales        - Tidied up. Set up appropriate fields during initialization. 
+! June 2015- D. Swales        - Moved hydrometeor class variables to hydro_class_init in
+!                               the module quickbeam_optics.
+! Mar 2016 - D. Swales        - Added scops_ccfrac. Was previously hardcoded in prec_scops.f90.  
+! Mar 2018 - R. Guzman        - Added LIDAR_NTYPE for the OPAQ diagnostics
+! Apr 2018 - R. Guzman        - Added parameters for GROUND LIDAR and ATLID simulators
+!
+! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+MODULE MOD_COSP_CONFIG
+    USE COSP_KINDS, ONLY: wp,dp
+    IMPLICIT NONE
+
+   ! #####################################################################################
+   ! Common COSP information
+   ! #####################################################################################
+    character(len=32) ::   &
+         COSP_VERSION              ! COSP Version ID (set in cosp_interface_init)
+    real(wp),parameter ::  &
+         R_UNDEF      = -1.0E30, & ! Missing value
+         R_GROUND     = -1.0E20, & ! Flag for below ground results
+         scops_ccfrac = 0.05       ! Fraction of column (or subcolumn) covered with convective
+                                   ! precipitation (default is 5%). *NOTE* This quantity may vary
+                                   ! between modeling centers.
+    logical :: &
+         use_vgrid                 ! True=Use new grid for L3 CLOUDAT and CALIPSO
+    integer,parameter ::   &
+         SR_BINS = 15,           & ! Number of bins (backscattering coefficient) in CALOPSO LIDAR simulator.
+         N_HYDRO = 9               ! Number of hydrometeor classes used by quickbeam radar simulator.
+
+    ! Mode debug ou prod (AI 0302018)
+    logical :: ok_debug_cosp = .true.
+    ! ####################################################################################  
+    ! Joint histogram bin-boundaries
+    ! tau is used by ISCCP and MISR
+    ! pres is used by ISCCP
+    ! hgt is used by MISR
+    ! ReffLiq is used by MODIS
+    ! ReffIce is used by MODIS
+    ! *NOTE* ALL JOINT-HISTOGRAM BIN BOUNDARIES ARE DECLARED AND DEFINED HERE IN
+    !        COSP_CONFIG, WITH THE EXCEPTION OF THE TAU AXIS USED BY THE MODIS SIMULATOR,
+    !        WHICH IS SET DURING INITIALIZATION IN COSP_INTERFACE_INIT.
+    ! ####################################################################################
+    ! Optical depth bin axis
+    integer,parameter :: &
+         ntau=7  
+    real(wp),parameter,dimension(ntau+1) :: &
+       tau_binBounds = (/0.0, 0.3, 1.3, 3.6, 9.4, 23., 60., 10000./)
+    real(wp),parameter,dimension(ntau) :: &
+         tau_binCenters = (/0.15, 0.80, 2.45, 6.5, 16.2, 41.5, 100.0/)
+    real(wp),parameter,dimension(2,ntau) :: &
+         tau_binEdges = reshape(source=(/0.0, 0.3,  0.3,  1.3,  1.3,  3.6,      3.6,     &
+                                         9.4, 9.4, 23.0, 23.0, 60.0, 60.0, 100000.0/),   &
+                                         shape=(/2,ntau/)) 
+
+    ! Optical depth bin axes (ONLY USED BY MODIS SIMULATOR IN v1.4)
+    integer :: l,k
+    integer,parameter :: &
+         ntauV1p4 = 6
+    real(wp),parameter,dimension(ntauV1p4+1) :: &
+         tau_binBoundsV1p4 = (/0.3, 1.3, 3.6, 9.4, 23., 60., 10000./)
+    real(wp),parameter,dimension(2,ntauV1p4) :: &
+         tau_binEdgesV1p4 = reshape(source =(/tau_binBoundsV1p4(1),((tau_binBoundsV1p4(k),l=1,2),   &
+                                             k=2,ntauV1p4),100000._wp/),shape = (/2,ntauV1p4/)) 
+    real(wp),parameter,dimension(ntauV1p4) :: &
+         tau_binCentersV1p4 = (tau_binEdgesV1p4(1,:)+tau_binEdgesV1p4(2,:))/2._wp  
+    
+    ! Cloud-top height pressure bin axis
+    integer,parameter :: &
+         npres = 7     
+    real(wp),parameter,dimension(npres+1) :: &
+         pres_binBounds = (/0., 180., 310., 440., 560., 680., 800., 10000./)
+    real(wp),parameter,dimension(npres) :: &
+         pres_binCenters = (/90000., 74000., 62000., 50000., 37500., 24500., 9000./)   
+    real(wp),parameter,dimension(2,npres) :: &
+         pres_binEdges = reshape(source=(/100000.0, 80000.0, 80000.0, 68000.0, 68000.0,    &
+                                           56000.0, 56000.0, 44000.0, 44000.0, 31000.0,    &
+                                           31000.0, 18000.0, 18000.0,     0.0/),           &
+                                           shape=(/2,npres/))
+
+    ! Cloud-top height bin axis #1
+    integer,parameter :: &
+         nhgt = 16
+    real(wp),parameter,dimension(nhgt+1) :: &
+         hgt_binBounds = (/-.99,0.,0.5,1.,1.5,2.,2.5,3.,4.,5.,7.,9.,11.,13.,15.,17.,99./)
+    real(wp),parameter,dimension(nhgt) :: &
+         hgt_binCenters = 1000*(/0.,0.25,0.75,1.25,1.75,2.25,2.75,3.5,4.5,6.,8.,10.,12.,   &
+         14.5,16.,18./)  
+    real(wp),parameter,dimension(2,nhgt) :: &
+         hgt_binEdges = 1000.0*reshape(source=(/-99.0, 0.0, 0.0, 0.5, 0.5, 1.0, 1.0, 1.5,  &
+                                                  1.5, 2.0, 2.0, 2.5, 2.5, 3.0, 3.0, 4.0,  &
+                                                  4.0, 5.0, 5.0, 7.0, 7.0, 9.0, 9.0,11.0,  &
+                                                  11.0,13.0,13.0,15.0,15.0,17.0,17.0,99.0/),&
+                                                  shape=(/2,nhgt/))    
+
+    ! Liquid and Ice particle bins for MODIS joint histogram of optical-depth and particle
+    ! size
+    integer :: i,j
+    integer,parameter :: &
+         nReffLiq = 6, & ! Number of bins for tau/ReffLiq joint-histogram
+         nReffIce = 6    ! Number of bins for tau/ReffICE joint-histogram
+    real(wp),parameter,dimension(nReffLiq+1) :: &
+         reffLIQ_binBounds = (/0., 8e-6, 1.0e-5, 1.3e-5, 1.5e-5, 2.0e-5, 3.0e-5/)
+    real(wp),parameter,dimension(nReffIce+1) :: &
+         reffICE_binBounds = (/0., 1.0e-5, 2.0e-5, 3.0e-5, 4.0e-5, 6.0e-5, 9.0e-5/)
+    real(wp),parameter,dimension(2,nReffICE) :: &
+         reffICE_binEdges = reshape(source=(/reffICE_binBounds(1),((reffICE_binBounds(k),  &
+                                    l=1,2),k=2,nReffICE),reffICE_binBounds(nReffICE+1)/),  &
+                                    shape = (/2,nReffICE/)) 
+    real(wp),parameter,dimension(2,nReffLIQ) :: &
+         reffLIQ_binEdges = reshape(source=(/reffLIQ_binBounds(1),((reffLIQ_binBounds(k),  &
+                                    l=1,2),k=2,nReffLIQ),reffLIQ_binBounds(nReffICE+1)/),  &
+                                    shape = (/2,nReffLIQ/))             
+    real(wp),parameter,dimension(nReffICE) :: &
+         reffICE_binCenters = (reffICE_binEdges(1,:)+reffICE_binEdges(2,:))/2._wp
+    real(wp),parameter,dimension(nReffLIQ) :: &
+         reffLIQ_binCenters = (reffLIQ_binEdges(1,:)+reffLIQ_binEdges(2,:))/2._wp
+
+    ! ####################################################################################  
+    ! Constants used by RTTOV.
+    ! ####################################################################################  
+    integer,parameter :: &
+         RTTOV_MAX_CHANNELS = 20
+    character(len=256),parameter :: &
+         rttovDir = '/homedata/rguzman/CALIPSO/RTTOV/rttov_11.3/'
+    ! ####################################################################################  
+    ! Constants used by the PARASOL simulator.
+    ! ####################################################################################  
+    integer,parameter :: &
+         PARASOL_NREFL = 5,  & ! Number of angles in LUT
+         PARASOL_NTAU  = 7     ! Number of optical depths in LUT
+    real(wp),parameter,dimension(PARASOL_NREFL) :: &
+         PARASOL_SZA = (/0.0, 20.0, 40.0, 60.0, 80.0/)
+    REAL(WP),parameter,dimension(PARASOL_NTAU) :: &
+         PARASOL_TAU = (/0., 1., 5., 10., 20., 50., 100./)
+    
+    ! LUTs
+    REAL(WP),parameter,dimension(PARASOL_NREFL,PARASOL_NTAU) :: &
+         ! LUT for liquid particles
+         rlumA = reshape(source=(/ 0.03,     0.03,     0.03,     0.03,     0.03,         &
+                                   0.090886, 0.072185, 0.058410, 0.052498, 0.034730,     &
+                                   0.283965, 0.252596, 0.224707, 0.175844, 0.064488,     &
+                                   0.480587, 0.436401, 0.367451, 0.252916, 0.081667,     &
+                                   0.695235, 0.631352, 0.509180, 0.326551, 0.098215,     &
+                                   0.908229, 0.823924, 0.648152, 0.398581, 0.114411,     &
+                                   1.0,      0.909013, 0.709554, 0.430405, 0.121567/),   &
+                                   shape=(/PARASOL_NREFL,PARASOL_NTAU/)),                & 
+         ! LUT for ice particles         			     
+         rlumB = reshape(source=(/ 0.03,     0.03,     0.03,     0.03,     0.03,         &
+                                   0.092170, 0.087082, 0.083325, 0.084935, 0.054157,     &
+                                   0.311941, 0.304293, 0.285193, 0.233450, 0.089911,     &
+                                   0.511298, 0.490879, 0.430266, 0.312280, 0.107854,     &
+                                   0.712079, 0.673565, 0.563747, 0.382376, 0.124127,     &
+                                   0.898243, 0.842026, 0.685773, 0.446371, 0.139004,     &
+                                   0.976646, 0.912966, 0.737154, 0.473317, 0.145269/),   &
+                                   shape=(/PARASOL_NREFL,PARASOL_NTAU/))  
+
+    ! ####################################################################################
+    ! ISCCP simulator tau/CTP joint histogram information
+    ! ####################################################################################
+    integer,parameter :: &
+         numISCCPTauBins  = ntau, &              ! Number of optical depth bins
+         numISCCPPresBins = npres                ! Number of pressure bins     
+    real(wp),parameter,dimension(ntau+1) :: &
+         isccp_histTau = tau_binBounds           ! Joint-histogram boundaries (optical depth)
+    real(wp),parameter,dimension(npres+1) :: &
+         isccp_histPres = pres_binBounds         ! Joint-histogram boundaries (cloud pressure)
+    real(wp),parameter,dimension(ntau) :: &
+         isccp_histTauCenters = tau_binCenters   ! Joint histogram bin centers (optical depth)
+    real(wp),parameter,dimension(npres) :: &   
+         isccp_histPresCenters = pres_binCenters ! Joint histogram bin centers (cloud pressure) 
+    real(wp),parameter,dimension(2,ntau) :: &
+         isccp_histTauEdges = tau_binEdges       ! Joint histogram bin edges (optical depth)
+    real(wp),parameter,dimension(2,npres) :: &    
+         isccp_histPresEdges = pres_binEdges     ! Joint histogram bin edges (cloud pressure)   
+    
+    ! ####################################################################################
+    ! MISR simulator tau/CTH joint histogram information 
+    ! ####################################################################################
+    integer,parameter ::  &
+         numMISRHgtBins = nhgt, &             ! Number of cloud-top height bins
+         numMISRTauBins = ntau                ! Number of optical depth bins
+    ! Joint histogram boundaries
+    real(wp),parameter,dimension(numMISRHgtBins+1) :: &
+         misr_histHgt = hgt_binBounds         ! Joint-histogram boundaries (cloud height)
+    real(wp),parameter,dimension(numMISRTauBins+1) :: &
+         misr_histTau = tau_binBounds         ! Joint-histogram boundaries (optical-depth)
+    real(wp),parameter,dimension(numMISRHgtBins) :: &
+         misr_histHgtCenters = hgt_binCenters ! Joint-histogram bin centers (cloud height)
+    real(wp),parameter,dimension(2,numMISRHgtBins) :: &
+         misr_histHgtEdges = hgt_BinEdges     ! Joint-histogram bin edges (cloud height)
+ 
+    ! ####################################################################################
+    ! MODIS simulator tau/CTP joint histogram information 
+    ! ####################################################################################
+    integer,parameter :: &
+         numMODISPresBins = npres                    ! Number of pressure bins for joint-histogram    
+    real(wp),parameter,dimension(numMODISPresBins + 1) :: & 
+         modis_histPres = 100*pres_binBounds         ! Joint-histogram boundaries (cloud pressure)
+    real(wp),parameter,dimension(2, numMODISPresBins) :: &
+         modis_histPresEdges = 100*pres_binEdges     ! Joint-histogram bin edges (cloud pressure)
+    real(wp),parameter,dimension(numMODISPresBins) :: &
+         modis_histPresCenters = 100*pres_binCenters ! Joint-histogram bin centers (cloud pressure)
+
+    ! For the MODIS simulator we want to preserve the ability for cospV1.4.0 to use the
+    ! old histogram bin boundaries for optical depth, so these are set up in initialization.
+    integer :: &
+         numMODISTauBins          ! Number of tau bins for joint-histogram
+    real(wp),save,allocatable,dimension(:) :: &
+         modis_histTau            ! Joint-histogram boundaries (optical depth)
+    !$OMP THREADPRIVATE(modis_histTau)
+    real(wp),save,allocatable,dimension(:,:) :: &
+         modis_histTauEdges       ! Joint-histogram bin edges (optical depth)
+    !$OMP THREADPRIVATE(modis_histTauEdges)
+    real(wp),save,allocatable,dimension(:) :: &
+         modis_histTauCenters     ! Joint-histogram bin centers (optical depth)
+    !$OMP THREADPRIVATE(modis_histTauCenters)
+    
+    ! ####################################################################################
+    ! MODIS simulator tau/ReffICE and tau/ReffLIQ joint-histogram information
+    ! ####################################################################################
+    ! Ice
+    integer,parameter :: &
+         numMODISReffIceBins = nReffIce                ! Number of bins for joint-histogram
+    real(wp),parameter,dimension(nReffIce+1) :: &
+         modis_histReffIce = reffICE_binBounds         ! Effective radius bin boundaries
+    real(wp),parameter,dimension(nReffIce) :: &
+         modis_histReffIceCenters = reffICE_binCenters ! Effective radius bin centers
+    real(wp),parameter,dimension(2,nReffICE) :: &
+         modis_histReffIceEdges = reffICE_binEdges     ! Effective radius bin edges
+       
+    ! Liquid
+    integer,parameter :: &
+         numMODISReffLiqBins = nReffLiq                ! Number of bins for joint-histogram
+    real(wp),parameter,dimension(nReffLiq+1) :: &
+         modis_histReffLiq = reffLIQ_binBounds         ! Effective radius bin boundaries 
+    real(wp),parameter,dimension(nReffLiq) :: &
+         modis_histReffLiqCenters = reffICE_binCenters ! Effective radius bin centers
+    real(wp),parameter,dimension(2,nReffICE) :: &
+         modis_histReffLiqEdges = reffLIQ_binEdges     ! Effective radius bin edges
+
+    ! ####################################################################################
+    ! CLOUDSAT reflectivity histogram information 
+    ! ####################################################################################
+    integer,parameter :: &
+       CLOUDSAT_DBZE_BINS     =   15, & ! Number of dBZe bins in histogram (cfad)
+       CLOUDSAT_DBZE_MIN      = -100, & ! Minimum value for radar reflectivity
+       CLOUDSAT_DBZE_MAX      =   80, & ! Maximum value for radar reflectivity
+       CLOUDSAT_CFAD_ZE_MIN   =  -50, & ! Lower value of the first CFAD Ze bin
+       CLOUDSAT_CFAD_ZE_WIDTH =    5    ! Bin width (dBZe)
+
+    real(wp),parameter,dimension(CLOUDSAT_DBZE_BINS+1) :: &
+         cloudsat_histRef = (/CLOUDSAT_DBZE_MIN,(/(i, i=int(CLOUDSAT_CFAD_ZE_MIN+CLOUDSAT_CFAD_ZE_WIDTH),&
+                             int(CLOUDSAT_CFAD_ZE_MIN+(CLOUDSAT_DBZE_BINS-1)*CLOUDSAT_CFAD_ZE_WIDTH),    &
+                             int(CLOUDSAT_CFAD_ZE_WIDTH))/),CLOUDSAT_DBZE_MAX/)
+    real(wp),parameter,dimension(2,CLOUDSAT_DBZE_BINS) :: &
+         cloudsat_binEdges = reshape(source=(/cloudsat_histRef(1),((cloudsat_histRef(k), &
+                                   l=1,2),k=2,CLOUDSAT_DBZE_BINS),cloudsat_histRef(CLOUDSAT_DBZE_BINS+1)/),&
+                                   shape = (/2,CLOUDSAT_DBZE_BINS/))     
+    real(wp),parameter,dimension(CLOUDSAT_DBZE_BINS) :: &
+         cloudsat_binCenters = (cloudsat_binEdges(1,:)+cloudsat_binEdges(2,:))/2._wp
+    
+    ! Parameters for Cloudsat near-surface precipitation diagnostics.
+    ! Precipitation classes.
+    integer, parameter :: &
+         nCloudsatPrecipClass = 10
+    integer, parameter :: &
+         pClass_noPrecip      = 0, & ! No precipitation
+         pClass_Rain1         = 1, & ! Rain possible
+         pClass_Rain2         = 2, & ! Rain probable
+         pClass_Rain3         = 3, & ! Rain certain
+         pClass_Snow1         = 4, & ! Snow possible
+         pClass_Snow2         = 5, & ! Snow certain
+         pClass_Mixed1        = 6, & ! Mixed-precipitation possible
+         pClass_Mixed2        = 7, & ! Mixed-precipitation certain
+         pClass_Rain4         = 8, & ! Heavy rain
+         pClass_default       = 9    ! Default
+    ! Reflectivity bin boundaries, used by decision tree to classify precipitation type.
+    real(wp), dimension(4),parameter :: &
+         Zenonbinval =(/0._wp, -5._wp, -7.5_wp, -15._wp/)
+    real(wp), dimension(6),parameter :: &
+         Zbinvallnd = (/10._wp, 5._wp, 2.5_wp, -2.5_wp, -5._wp, -15._wp/)
+    ! Vertical level index(Nlvgrid) for Cloudsat precipitation occurence/frequency diagnostics.
+    ! Level 39 of Nlvgrid(40) is 480-960m.
+!    integer, parameter :: &    !PREC_BUG
+!         cloudsat_preclvl = 39 !PREC_BUG
+    
+    ! ####################################################################################
+    ! Parameters used by the CALIPSO LIDAR simulator
+    ! #################################################################################### 
+    ! CALISPO backscatter histogram bins 
+    real(wp),parameter ::     &
+       S_cld       = 5.0,     & ! Threshold for cloud detection
+       S_att       = 0.01,    & !
+       S_cld_att   = 30.        ! Threshold for undefined cloud phase detection
+    real(wp),parameter,dimension(SR_BINS+1) :: &
+         calipso_histBsct = (/-1.,0.01,1.2,3.0,5.0,7.0,10.0,15.0,20.0,25.0,30.0,40.0,50.0,   &
+                              60.0,80.0,999./)         ! Backscatter histogram bins
+    real(wp),parameter,dimension(2,SR_BINS) :: &
+         calipso_binEdges = reshape(source=(/calipso_histBsct(1),((calipso_histBsct(k),  &
+                                    l=1,2),k=2,SR_BINS),calipso_histBsct(SR_BINS+1)/),   &
+                                    shape = (/2,SR_BINS/))     
+    real(wp),parameter,dimension(SR_BINS) :: &
+         calipso_binCenters = (calipso_binEdges(1,:)+calipso_binEdges(2,:))/2._wp  
+
+    integer,parameter  ::     &
+       LIDAR_NTEMP = 40, & 
+       LIDAR_NCAT  = 4,  & ! Number of categories for cloudtop heights (high/mid/low/tot)
+       LIDAR_NTYPE = 3     ! Number of categories for OPAQ (opaque/thin cloud + z_opaque)
+    real(wp),parameter,dimension(LIDAR_NTEMP) :: &
+       LIDAR_PHASE_TEMP=                                                                 &
+       (/-91.5,-88.5,-85.5,-82.5,-79.5,-76.5,-73.5,-70.5,-67.5,-64.5,                    &
+         -61.5,-58.5,-55.5,-52.5,-49.5,-46.5,-43.5,-40.5,-37.5,-34.5,                    &
+         -31.5,-28.5,-25.5,-22.5,-19.5,-16.5,-13.5,-10.5, -7.5, -4.5,                    &
+          -1.5,  1.5,  4.5,  7.5, 10.5, 13.5, 16.5, 19.5, 22.5, 25.5/)
+    real(wp),parameter,dimension(2,LIDAR_NTEMP) :: &
+       LIDAR_PHASE_TEMP_BNDS=reshape(source=                                             &
+          (/-273.15, -90., -90., -87., -87., -84., -84., -81., -81., -78.,               &
+             -78.,   -75., -75., -72., -72., -69., -69., -66., -66., -63.,               &
+             -63.,   -60., -60., -57., -57., -54., -54., -51., -51., -48.,               &
+             -48.,   -45., -45., -42., -42., -39., -39., -36., -36., -33.,               &
+             -33.,   -30., -30., -27., -27., -24., -24., -21., -21., -18.,               &
+             -18.,   -15., -15., -12., -12.,  -9.,  -9.,  -6.,  -6.,  -3.,               &
+              -3.,     0.,   0.,   3.,   3.,   6.,   6.,   9.,   9.,  12.,               &
+              12.,    15.,  15.,  18.,  18.,  21.,  21.,  24.,  24., 100. /),            &
+              shape=(/2,40/))        
+
+    ! ####################################################################################
+    ! Parameters used by the GROUND LIDAR simulator
+    ! #################################################################################### 
+    ! GROUND LIDAR backscatter histogram bins 
+!    real(wp),parameter ::     &
+!       S_cld       = 5.0,     & ! Threshold for cloud detection
+!       S_att       = 0.01,    & !
+!       S_cld_att   = 30.        ! Threshold for undefined cloud phase detection
+    real(wp),parameter,dimension(SR_BINS+1) :: &
+         grLidar532_histBsct = (/-1.,0.01,1.2,3.0,5.0,7.0,10.0,15.0,20.0,25.0,30.0,40.0,50.0,  &
+                                 60.0,80.0,999./)         ! Backscatter histogram bins
+    real(wp),parameter,dimension(2,SR_BINS) :: &
+         grLidar532_binEdges = reshape(source=(/grLidar532_histBsct(1),((grLidar532_histBsct(k),  &
+                                    l=1,2),k=2,SR_BINS),grLidar532_histBsct(SR_BINS+1)/),   &
+                                    shape = (/2,SR_BINS/))     
+    real(wp),parameter,dimension(SR_BINS) :: &
+         grLidar532_binCenters = (grLidar532_binEdges(1,:)+grLidar532_binEdges(2,:))/2._wp  
+
+!    integer,parameter  ::     &
+!       LIDAR_NCAT  = 4       ! Number of categories for cloudtop heights (high/mid/low/tot)
+
+    ! ####################################################################################
+    ! Parameters used by the ATLID LIDAR simulator
+    ! #################################################################################### 
+    ! ATLID LIDAR backscatter histogram bins 
+    real(wp),parameter ::     &
+       S_cld_atlid       = 1.74,    & ! Threshold for cloud detection
+       S_att_atlid       = 0.01,    & !
+       S_cld_att_atlid   = 6.67        ! Threshold for undefined cloud phase detection
+    real(wp),parameter,dimension(SR_BINS+1) :: &
+         atlid_histBsct = (/-1.,0.01,1.03,1.38,1.74,2.07,2.62,3.65,4.63,5.63,6.67,8.8,11.25,  &
+                                 13.2,17.2,999./)         ! Backscatter histogram bins
+    real(wp),parameter,dimension(2,SR_BINS) :: &
+         atlid_binEdges = reshape(source=(/atlid_histBsct(1),((atlid_histBsct(k),  &
+                                    l=1,2),k=2,SR_BINS),atlid_histBsct(SR_BINS+1)/),   &
+                                    shape = (/2,SR_BINS/))     
+    real(wp),parameter,dimension(SR_BINS) :: &
+         atlid_binCenters = (atlid_binEdges(1,:)+atlid_binEdges(2,:))/2._wp  
+
+!    integer,parameter  ::     &
+!       LIDAR_NCAT  = 4       ! Number of categories for cloudtop heights (high/mid/low/tot)
+
+    ! ####################################################################################
+    ! New vertical grid used by CALIPSO and CLOUDSAT L3 (set up during initialization)
+    ! ####################################################################################
+    integer :: &
+         Nlvgrid      ! Number of levels in New grid
+    real(wp),dimension(:), save, allocatable :: &
+       vgrid_zl,  & ! New grid bottoms
+       vgrid_zu,  & ! New grid tops
+       vgrid_z      ! New grid center
+    !$OMP THREADPRIVATE(vgrid_zl,vgrid_zu,vgrid_z)
+
+    ! ####################################################################################
+    ! Vertical grid used by CALIPSO and CLOUDSAT L3 (LMDZ parameter)
+    ! ####################################################################################
+
+    integer, parameter :: &
+         niv_sorties = 40
+    real(wp),parameter,dimension(niv_sorties) :: &
+         vgrid_z_in = (/240.0, 720.0, 1200.0, 1680.0, 2160.0, 2640.0, 3120.0, 3600.0, &
+                        4080.0, 4560.0, 5040.0, 5520.0, 6000.0, 6480.0, 6960.0, 7440.0, &
+			7920.0, 8400.0, 8880.0, 9360.0, 9840.0, 10320.0, 10800.0, &
+			11280.0, 11760.0, 12240.0, 12720.0, 13200.0, 13680.0, 14160.0, &
+			14640.0, 15120.0, 15600.0, 16080.0, 16560.0, 17040.0, 17520.0, &
+			18000.0, 18480.0, 18960.0/)
+
+END MODULE MOD_COSP_CONFIG
Index: DZ6/trunk/libf/phylmd/cospv2/cosp_errorHandling.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cospv2/cosp_errorHandling.F90	(revision 5267)
+++ 	(revision )
@@ -1,50 +1,0 @@
-! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-! Copyright (c) 2015, Regents of the University of Colorado
-! All rights reserved.
-!
-! Redistribution and use in source and binary forms, with or without modification, are 
-! permitted provided that the following conditions are met:
-!
-! 1. Redistributions of source code must retain the above copyright notice, this list of 
-!    conditions and the following disclaimer.
-!
-! 2. Redistributions in binary form must reproduce the above copyright notice, this list
-!    of conditions and the following disclaimer in the documentation and/or other 
-!    materials provided with the distribution.
-!
-! 3. Neither the name of the copyright holder nor the names of its contributors may be 
-!    used to endorse or promote products derived from this software without specific prior
-!    written permission.
-!
-! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY 
-! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 
-! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL 
-! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 
-! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT 
-! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 
-! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
-! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-!
-! History:
-! May 2015- D. Swales - Original version
-! 
-! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-
-module mod_cosp_error
-  use cosp_kinds, ONLY: wp
-contains
-  ! ######################################################################################
-  ! Subroutine errorMessage_print
-  ! ######################################################################################
-  subroutine errorMessage(message)
-    ! Inputs
-    character(len=*),intent(in) :: message
-
-    print*,message
-  end subroutine errorMessage
-  
-  ! ######################################################################################
-  ! END MODULE
-  ! ######################################################################################
-end module mod_cosp_error
Index: /LMDZ6/trunk/libf/phylmd/cospv2/cosp_errorHandling.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cospv2/cosp_errorHandling.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/cospv2/cosp_errorHandling.f90	(revision 5268)
@@ -0,0 +1,50 @@
+! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+! Copyright (c) 2015, Regents of the University of Colorado
+! All rights reserved.
+!
+! Redistribution and use in source and binary forms, with or without modification, are 
+! permitted provided that the following conditions are met:
+!
+! 1. Redistributions of source code must retain the above copyright notice, this list of 
+!    conditions and the following disclaimer.
+!
+! 2. Redistributions in binary form must reproduce the above copyright notice, this list
+!    of conditions and the following disclaimer in the documentation and/or other 
+!    materials provided with the distribution.
+!
+! 3. Neither the name of the copyright holder nor the names of its contributors may be 
+!    used to endorse or promote products derived from this software without specific prior
+!    written permission.
+!
+! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY 
+! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 
+! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL 
+! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 
+! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT 
+! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 
+! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+!
+! History:
+! May 2015- D. Swales - Original version
+! 
+! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+module mod_cosp_error
+  use cosp_kinds, ONLY: wp
+contains
+  ! ######################################################################################
+  ! Subroutine errorMessage_print
+  ! ######################################################################################
+  subroutine errorMessage(message)
+    ! Inputs
+    character(len=*),intent(in) :: message
+
+    print*,message
+  end subroutine errorMessage
+  
+  ! ######################################################################################
+  ! END MODULE
+  ! ######################################################################################
+end module mod_cosp_error
Index: DZ6/trunk/libf/phylmd/cospv2/cosp_grLidar532_interface.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cospv2/cosp_grLidar532_interface.F90	(revision 5267)
+++ 	(revision )
@@ -1,62 +1,0 @@
-! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-! Copyright (c) 2015, Regents of the University of Colorado
-! All rights reserved.
-!
-! Redistribution and use in source and binary forms, with or without modification, are 
-! permitted provided that the following conditions are met:
-!
-! 1. Redistributions of source code must retain the above copyright notice, this list of 
-!    conditions and the following disclaimer.
-!
-! 2. Redistributions in binary form must reproduce the above copyright notice, this list
-!    of conditions and the following disclaimer in the documentation and/or other 
-!    materials provided with the distribution.
-!
-! 3. Neither the name of the copyright holder nor the names of its contributors may be 
-!    used to endorse or promote products derived from this software without specific prior
-!    written permission.
-!
-! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY 
-! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 
-! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL 
-! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 
-! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT 
-! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 
-! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
-! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-!
-! History
-! Apr 2018 - R. Guzman - Original version
-! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-MODULE MOD_COSP_GRLIDAR532_INTERFACE
-  USE COSP_KINDS,              ONLY: wp
-  IMPLICIT NONE
-  
-  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-  ! TYPE grLidar532_in
-  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 
-  type grLidar532_IN
-     integer,pointer ::       &
-          Npoints,      & ! Number of gridpoints.
-          Ncolumns,     & ! Number of columns.
-          Nlevels         ! Number of levels.
-     real(wp),dimension(:,:),pointer :: &
-          beta_mol,  &
-          tau_mol 
-     real(wp),dimension(:,:,:),pointer :: &
-          betatot,   & 
-          tautot  
-  end type grLidar532_IN
-contains
-  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-  ! SUBROUTINE cosp_grLidar532_init
-  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-  subroutine cosp_grLidar532_init() 
-        
-  end subroutine cosp_grLidar532_init
-  
-  ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-  !	END MODULE
-  ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-END MODULE MOD_COSP_GRLIDAR532_INTERFACE
Index: /LMDZ6/trunk/libf/phylmd/cospv2/cosp_grLidar532_interface.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cospv2/cosp_grLidar532_interface.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/cospv2/cosp_grLidar532_interface.f90	(revision 5268)
@@ -0,0 +1,62 @@
+! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+! Copyright (c) 2015, Regents of the University of Colorado
+! All rights reserved.
+!
+! Redistribution and use in source and binary forms, with or without modification, are 
+! permitted provided that the following conditions are met:
+!
+! 1. Redistributions of source code must retain the above copyright notice, this list of 
+!    conditions and the following disclaimer.
+!
+! 2. Redistributions in binary form must reproduce the above copyright notice, this list
+!    of conditions and the following disclaimer in the documentation and/or other 
+!    materials provided with the distribution.
+!
+! 3. Neither the name of the copyright holder nor the names of its contributors may be 
+!    used to endorse or promote products derived from this software without specific prior
+!    written permission.
+!
+! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY 
+! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 
+! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL 
+! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 
+! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT 
+! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 
+! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+!
+! History
+! Apr 2018 - R. Guzman - Original version
+! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+MODULE MOD_COSP_GRLIDAR532_INTERFACE
+  USE COSP_KINDS,              ONLY: wp
+  IMPLICIT NONE
+  
+  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  ! TYPE grLidar532_in
+  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 
+  type grLidar532_IN
+     integer,pointer ::       &
+          Npoints,      & ! Number of gridpoints.
+          Ncolumns,     & ! Number of columns.
+          Nlevels         ! Number of levels.
+     real(wp),dimension(:,:),pointer :: &
+          beta_mol,  &
+          tau_mol 
+     real(wp),dimension(:,:,:),pointer :: &
+          betatot,   & 
+          tautot  
+  end type grLidar532_IN
+contains
+  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  ! SUBROUTINE cosp_grLidar532_init
+  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  subroutine cosp_grLidar532_init() 
+        
+  end subroutine cosp_grLidar532_init
+  
+  ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  !	END MODULE
+  ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+END MODULE MOD_COSP_GRLIDAR532_INTERFACE
Index: DZ6/trunk/libf/phylmd/cospv2/cosp_isccp_interface.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cospv2/cosp_isccp_interface.F90	(revision 5267)
+++ 	(revision )
@@ -1,85 +1,0 @@
-! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-! Copyright (c) 2015, Regents of the University of Colorado
-! All rights reserved.
-!
-! Redistribution and use in source and binary forms, with or without modification, are 
-! permitted provided that the following conditions are met:
-!
-! 1. Redistributions of source code must retain the above copyright notice, this list of 
-!    conditions and the following disclaimer.
-!
-! 2. Redistributions in binary form must reproduce the above copyright notice, this list
-!    of conditions and the following disclaimer in the documentation and/or other 
-!    materials provided with the distribution.
-!
-! 3. Neither the name of the copyright holder nor the names of its contributors may be 
-!    used to endorse or promote products derived from this software without specific prior
-!    written permission.
-!
-! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY 
-! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 
-! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL 
-! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 
-! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT 
-! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 
-! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
-! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-!
-! History
-! May 2015 - D. Swales - Original version
-! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-MODULE MOD_COSP_ISCCP_INTERFACE
-  USE COSP_KINDS,      ONLY: wp
-  USE mod_icarus,      ONLY: isccp_top_height,isccp_top_height_direction
-  IMPLICIT NONE
-  
-  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-  !                                  TYPE isccp_in
-  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-  ! Derived input type for ISCCP simulator
-  type isccp_IN
-     integer,pointer  ::       &
-          Npoints,             & ! Number of gridpoints.
-          Ncolumns,            & ! Number of columns.
-          Nlevels,             & ! Number of levels.
-          top_height,          & !
-          top_height_direction   !
-     integer,pointer ::        &
-          sunlit(:)              ! Sunlit points (npoints)
-     real(wp),pointer ::       &
-          emsfc_lw
-     real(wp),pointer ::       &
-          skt(:)                 ! Surface temperature (npoints)
-     real(wp),pointer ::       &
-          at(:,:),             & ! Temperature (npoint,nlev)
-          pfull(:,:),          & ! Pressure (npoints,nlev)
-          qv(:,:)                ! Specific humidity (npoints,nlev)
-     real(wp),pointer  ::       &          
-          phalf(:,:)             ! Pressure at half levels (npoints,nlev+1)
-     real(wp),pointer ::       &
-          frac_out(:,:,:),     & ! Cloud fraction (npoints,ncolumns,nlevels)
-          dtau(:,:,:),         & ! Optical depth (npoints,ncolumns,nlevels)
-          dem(:,:,:)             ! Emissivity (npoints,ncolumns,nlevels)
-  end type isccp_IN
-
-CONTAINS
-
-  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-  !  							SUBROUTINE cosp_isccp_init
-  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-  SUBROUTINE COSP_ISCCP_INIT(top_height,top_height_direction)
-     integer,intent(in) :: &
-         top_height, &
-         top_height_direction
-
-    ! Cloud-top height determination
-    isccp_top_height           = top_height
-    isccp_top_height_direction = top_height_direction
-
-  END SUBROUTINE COSP_ISCCP_INIT
-
-  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-  !                                    END MODULE
-  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-END MODULE MOD_COSP_ISCCP_INTERFACE
Index: /LMDZ6/trunk/libf/phylmd/cospv2/cosp_isccp_interface.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cospv2/cosp_isccp_interface.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/cospv2/cosp_isccp_interface.f90	(revision 5268)
@@ -0,0 +1,85 @@
+! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+! Copyright (c) 2015, Regents of the University of Colorado
+! All rights reserved.
+!
+! Redistribution and use in source and binary forms, with or without modification, are 
+! permitted provided that the following conditions are met:
+!
+! 1. Redistributions of source code must retain the above copyright notice, this list of 
+!    conditions and the following disclaimer.
+!
+! 2. Redistributions in binary form must reproduce the above copyright notice, this list
+!    of conditions and the following disclaimer in the documentation and/or other 
+!    materials provided with the distribution.
+!
+! 3. Neither the name of the copyright holder nor the names of its contributors may be 
+!    used to endorse or promote products derived from this software without specific prior
+!    written permission.
+!
+! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY 
+! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 
+! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL 
+! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 
+! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT 
+! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 
+! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+!
+! History
+! May 2015 - D. Swales - Original version
+! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+MODULE MOD_COSP_ISCCP_INTERFACE
+  USE COSP_KINDS,      ONLY: wp
+  USE mod_icarus,      ONLY: isccp_top_height,isccp_top_height_direction
+  IMPLICIT NONE
+  
+  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  !                                  TYPE isccp_in
+  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  ! Derived input type for ISCCP simulator
+  type isccp_IN
+     integer,pointer  ::       &
+          Npoints,             & ! Number of gridpoints.
+          Ncolumns,            & ! Number of columns.
+          Nlevels,             & ! Number of levels.
+          top_height,          & !
+          top_height_direction   !
+     integer,pointer ::        &
+          sunlit(:)              ! Sunlit points (npoints)
+     real(wp),pointer ::       &
+          emsfc_lw
+     real(wp),pointer ::       &
+          skt(:)                 ! Surface temperature (npoints)
+     real(wp),pointer ::       &
+          at(:,:),             & ! Temperature (npoint,nlev)
+          pfull(:,:),          & ! Pressure (npoints,nlev)
+          qv(:,:)                ! Specific humidity (npoints,nlev)
+     real(wp),pointer  ::       &          
+          phalf(:,:)             ! Pressure at half levels (npoints,nlev+1)
+     real(wp),pointer ::       &
+          frac_out(:,:,:),     & ! Cloud fraction (npoints,ncolumns,nlevels)
+          dtau(:,:,:),         & ! Optical depth (npoints,ncolumns,nlevels)
+          dem(:,:,:)             ! Emissivity (npoints,ncolumns,nlevels)
+  end type isccp_IN
+
+CONTAINS
+
+  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  !  							SUBROUTINE cosp_isccp_init
+  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  SUBROUTINE COSP_ISCCP_INIT(top_height,top_height_direction)
+     integer,intent(in) :: &
+         top_height, &
+         top_height_direction
+
+    ! Cloud-top height determination
+    isccp_top_height           = top_height
+    isccp_top_height_direction = top_height_direction
+
+  END SUBROUTINE COSP_ISCCP_INIT
+
+  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  !                                    END MODULE
+  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+END MODULE MOD_COSP_ISCCP_INTERFACE
Index: DZ6/trunk/libf/phylmd/cospv2/cosp_kinds.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cospv2/cosp_kinds.F90	(revision 5267)
+++ 	(revision )
@@ -1,39 +1,0 @@
-! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-! Copyright (c) 2015, Regents of the University of Colorado
-! All rights reserved.
-!
-! Redistribution and use in source and binary forms, with or without modification, are
-! permitted provided that the following conditions are met:
-!
-! 1. Redistributions of source code must retain the above copyright notice, this list of
-!    conditions and the following disclaimer.
-!
-! 2. Redistributions in binary form must reproduce the above copyright notice, this list
-!    of conditions and the following disclaimer in the documentation and/or other
-!    materials provided with the distribution.
-!
-! 3. Neither the name of the copyright holder nor the names of its contributors may be
-!    used to endorse or promote products derived from this software without specific prior
-!    written permission.
-!
-! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY
-! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
-! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL
-! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT
-! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
-! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
-! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-!
-! History:
-! May 2015- D. Swales - Original version
-!
-! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-MODULE cosp_kinds
-  implicit none
-  INTEGER, PARAMETER :: sp = SELECTED_REAL_KIND( 6, 37)
-  INTEGER, PARAMETER :: dp = SELECTED_REAL_KIND(12,307)
-  INTEGER, PARAMETER :: wp = dp
-
-END MODULE cosp_kinds
Index: /LMDZ6/trunk/libf/phylmd/cospv2/cosp_kinds.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cospv2/cosp_kinds.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/cospv2/cosp_kinds.f90	(revision 5268)
@@ -0,0 +1,39 @@
+! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+! Copyright (c) 2015, Regents of the University of Colorado
+! All rights reserved.
+!
+! Redistribution and use in source and binary forms, with or without modification, are
+! permitted provided that the following conditions are met:
+!
+! 1. Redistributions of source code must retain the above copyright notice, this list of
+!    conditions and the following disclaimer.
+!
+! 2. Redistributions in binary form must reproduce the above copyright notice, this list
+!    of conditions and the following disclaimer in the documentation and/or other
+!    materials provided with the distribution.
+!
+! 3. Neither the name of the copyright holder nor the names of its contributors may be
+!    used to endorse or promote products derived from this software without specific prior
+!    written permission.
+!
+! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY
+! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
+! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL
+! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT
+! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+!
+! History:
+! May 2015- D. Swales - Original version
+!
+! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+MODULE cosp_kinds
+  implicit none
+  INTEGER, PARAMETER :: sp = SELECTED_REAL_KIND( 6, 37)
+  INTEGER, PARAMETER :: dp = SELECTED_REAL_KIND(12,307)
+  INTEGER, PARAMETER :: wp = dp
+
+END MODULE cosp_kinds
Index: DZ6/trunk/libf/phylmd/cospv2/cosp_math_constants.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cospv2/cosp_math_constants.F90	(revision 5267)
+++ 	(revision )
@@ -1,6 +1,0 @@
-MODULE cosp_math_constants
-  USE cosp_kinds, only: wp
-  IMPLICIT NONE
-  REAL(wp), PARAMETER :: pi =  acos(-1.0_wp)
-
-END MODULE cosp_math_constants
Index: /LMDZ6/trunk/libf/phylmd/cospv2/cosp_math_constants.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cospv2/cosp_math_constants.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/cospv2/cosp_math_constants.f90	(revision 5268)
@@ -0,0 +1,6 @@
+MODULE cosp_math_constants
+  USE cosp_kinds, only: wp
+  IMPLICIT NONE
+  REAL(wp), PARAMETER :: pi =  acos(-1.0_wp)
+
+END MODULE cosp_math_constants
Index: DZ6/trunk/libf/phylmd/cospv2/cosp_misr_interface.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cospv2/cosp_misr_interface.F90	(revision 5267)
+++ 	(revision )
@@ -1,67 +1,0 @@
-! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-! Copyright (c) 2015, Regents of the University of Colorado
-! All rights reserved.
-!
-! Redistribution and use in source and binary forms, with or without modification, are 
-! permitted provided that the following conditions are met:
-!
-! 1. Redistributions of source code must retain the above copyright notice, this list of 
-!    conditions and the following disclaimer.
-!
-! 2. Redistributions in binary form must reproduce the above copyright notice, this list
-!    of conditions and the following disclaimer in the documentation and/or other 
-!    materials provided with the distribution.
-!
-! 3. Neither the name of the copyright holder nor the names of its contributors may be 
-!    used to endorse or promote products derived from this software without specific prior
-!    written permission.
-!
-! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY 
-! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 
-! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL 
-! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 
-! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT 
-! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 
-! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
-! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-!
-! History
-! May 2015 - D. Swales - Original version
-! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-MODULE MOD_COSP_MISR_INTERFACE
-  USE COSP_KINDS,  ONLY: wp
- 
-  IMPLICIT NONE
-
-  ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-  ! 								TYPE misr_in
-  ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-  type misr_IN
-     integer,pointer  ::  &
-          Npoints,        & ! Number of gridpoints.
-          Ncolumns,       & ! Number of columns.
-          Nlevels           ! Number of levels.
-     integer,pointer ::   &
-          sunlit(:)         ! Sunlit points (npoints).
-     real(wp),pointer ::  &
-          zfull(:,:),     & ! Height of full model levels (i.e. midpoints). (npoints,nlev)
-          at(:,:)           ! Temperature. (npoints,nlev)
-     real(wp),pointer ::  &                           
-          dtau(:,:,:)       ! Optical depth. (npoints,ncolumns,nlev)
-          
-  end type misr_IN
-
-CONTAINS
-
-  ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-  !  							SUBROUTINE cosp_misr_init
-  ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-  SUBROUTINE COSP_MISR_INIT()
-
-  END SUBROUTINE COSP_MISR_INIT
-
-  ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-  ! 							    	END MODULE
-  ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-END MODULE MOD_COSP_MISR_INTERFACE
Index: /LMDZ6/trunk/libf/phylmd/cospv2/cosp_misr_interface.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cospv2/cosp_misr_interface.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/cospv2/cosp_misr_interface.f90	(revision 5268)
@@ -0,0 +1,67 @@
+! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+! Copyright (c) 2015, Regents of the University of Colorado
+! All rights reserved.
+!
+! Redistribution and use in source and binary forms, with or without modification, are 
+! permitted provided that the following conditions are met:
+!
+! 1. Redistributions of source code must retain the above copyright notice, this list of 
+!    conditions and the following disclaimer.
+!
+! 2. Redistributions in binary form must reproduce the above copyright notice, this list
+!    of conditions and the following disclaimer in the documentation and/or other 
+!    materials provided with the distribution.
+!
+! 3. Neither the name of the copyright holder nor the names of its contributors may be 
+!    used to endorse or promote products derived from this software without specific prior
+!    written permission.
+!
+! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY 
+! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 
+! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL 
+! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 
+! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT 
+! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 
+! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+!
+! History
+! May 2015 - D. Swales - Original version
+! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+MODULE MOD_COSP_MISR_INTERFACE
+  USE COSP_KINDS,  ONLY: wp
+ 
+  IMPLICIT NONE
+
+  ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  ! 								TYPE misr_in
+  ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  type misr_IN
+     integer,pointer  ::  &
+          Npoints,        & ! Number of gridpoints.
+          Ncolumns,       & ! Number of columns.
+          Nlevels           ! Number of levels.
+     integer,pointer ::   &
+          sunlit(:)         ! Sunlit points (npoints).
+     real(wp),pointer ::  &
+          zfull(:,:),     & ! Height of full model levels (i.e. midpoints). (npoints,nlev)
+          at(:,:)           ! Temperature. (npoints,nlev)
+     real(wp),pointer ::  &                           
+          dtau(:,:,:)       ! Optical depth. (npoints,ncolumns,nlev)
+          
+  end type misr_IN
+
+CONTAINS
+
+  ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  !  							SUBROUTINE cosp_misr_init
+  ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  SUBROUTINE COSP_MISR_INIT()
+
+  END SUBROUTINE COSP_MISR_INIT
+
+  ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  ! 							    	END MODULE
+  ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+END MODULE MOD_COSP_MISR_INTERFACE
Index: DZ6/trunk/libf/phylmd/cospv2/cosp_modis_interface.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cospv2/cosp_modis_interface.F90	(revision 5267)
+++ 	(revision )
@@ -1,113 +1,0 @@
-! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-! Copyright (c) 2015, Regents of the University of Colorado
-! All rights reserved.
-!
-! Redistribution and use in source and binary forms, with or without modification, are 
-! permitted provided that the following conditions are met:
-!
-! 1. Redistributions of source code must retain the above copyright notice, this list of 
-!    conditions and the following disclaimer.
-!
-! 2. Redistributions in binary form must reproduce the above copyright notice, this list
-!    of conditions and the following disclaimer in the documentation and/or other 
-!    materials provided with the distribution.
-!
-! 3. Neither the name of the copyright holder nor the names of its contributors may be 
-!    used to endorse or promote products derived from this software without specific prior
-!    written permission.
-!
-! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY 
-! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 
-! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL 
-! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 
-! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT 
-! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 
-! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
-! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-!
-! History
-! May 2015 - D. Swales - Original version
-! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-MODULE MOD_COSP_Modis_INTERFACE
-  USE COSP_KINDS,      ONLY: wp
-  USE MOD_COSP_CONFIG, ONLY: R_UNDEF
-  use mod_modis_sim,   ONLY: num_trial_res,min_OpticalThickness,CO2Slicing_PressureLimit,&
-                             CO2Slicing_TauLimit,phase_TauLimit,size_TauLimit,re_fill,   &
-                             phaseDiscrimination_Threshold,re_water_min,     &
-                             re_water_max,re_ice_min,re_ice_max,               &
-                             highCloudPressureLimit,lowCloudPressureLimit,phaseIsNone,   &
-                             phaseIsLiquid,phaseIsIce,phaseIsUndetermined,trial_re_w,    &
-                             trial_re_i,g_w,g_i,w0_w,w0_i, get_g_nir,get_ssa_nir
-  implicit none
-
-  ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-  !  TYPE modis_in
-  ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 
-  type modis_IN
-     integer,pointer :: &
-          Npoints,        & ! Number of horizontal gridpoints
-          Ncolumns,       & ! Number of subcolumns
-          Nlevels           ! Number of vertical levels
-     integer :: &
-          Nsunlit           ! Number of sunlit lit pixels
-     real(wp),allocatable,dimension(:) :: &
-          sunlit,         & ! Sunlit scenes
-          notSunlit         ! Dark scenes
-     real(wp),allocatable,dimension(:,:) :: &
-          pres              ! Gridmean pressure at layer edges (Pa) 
-     real(wp),pointer ::  &
-          tau(:,:,:),     & ! Subcolumn optical thickness @ 0.67 microns.
-          liqFrac(:,:,:), & ! Liquid water fraction
-          g(:,:,:),       & ! Subcolumn assymetry parameter  
-          w0(:,:,:)         ! Subcolumn single-scattering albedo
-  end type modis_IN
-contains
-  ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-  ! SUBROTUINE cosp_modis_init
-  ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-  SUBROUTINE COSP_MODIS_INIT()
-    integer :: i 
-    
-    ! Retrieval parameters
-    min_OpticalThickness          = 0.3_wp     ! Minimum detectable optical thickness
-    CO2Slicing_PressureLimit      = 70000._wp  ! Cloud with higher pressures use thermal 
-                                               ! methods, units Pa
-    CO2Slicing_TauLimit           = 1._wp      ! How deep into the cloud does CO2 slicing 
-                                               ! see? 
-    phase_TauLimit                = 1._wp      ! How deep into the cloud does the phase 
-                                               ! detection see?
-    size_TauLimit                 = 2._wp      ! Depth of the re retreivals
-    phaseDiscrimination_Threshold = 0.7_wp     ! What fraction of total extincton needs to 
-                                               ! be in a single category to make phase 
-                                               ! discrim. work? 
-    re_fill                       = -999._wp   ! Fill value
-    re_water_min                  = 4._wp      ! Minimum effective radius (liquid)
-    re_water_max                  = 30._wp     ! Maximum effective radius (liquid)
-    re_ice_min                    = 5._wp      ! Minimum effective radius (ice)
-    re_ice_max                    = 90._wp     ! Minimum effective radius (ice)
-    highCloudPressureLimit        = 44000._wp  ! High cloud pressure limit (Pa)
-    lowCloudPressureLimit         = 68000._wp  ! Low cloud pressure limit (Pa)
-    phaseIsNone                   = 0          ! No cloud
-    phaseIsLiquid                 = 1          ! Liquid cloud
-    phaseIsIce                    = 2          ! Ice cloud
-    phaseIsUndetermined           = 3          ! Undetermined cloud
-
-    ! Precompute near-IR optical params vs size for retrieval scheme    
-    trial_re_w(1:num_trial_res) = re_water_min + (re_water_max - re_water_min) /         &
-         (num_trial_res-1) * (/(i, i=0, num_trial_res-1)/)
-    trial_re_i(1:num_trial_res) = re_ice_min   + (re_ice_max -   re_ice_min) /           &
-         (num_trial_res-1) * (/(i, i=0, num_trial_res-1)/)
-
-    ! Initialize estimates for size retrieval
-    g_w(1:num_trial_res)  = get_g_nir(phaseIsLiquid,trial_re_w(1:num_trial_res))
-    w0_w(1:num_trial_res) = get_ssa_nir(phaseIsLiquid,trial_re_w(1:num_trial_res))
-    g_i(1:num_trial_res)  = get_g_nir(phaseIsIce,trial_re_i(1:num_trial_res))
-    w0_i(1:num_trial_res) = get_ssa_nir(phaseIsIce,trial_re_i(1:num_trial_res))
-
-  END SUBROUTINE COSP_MODIS_INIT
-  
-  ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-  ! END MODULE MOD_COSP_Modis_INTERFACE
-  ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-END MODULE MOD_COSP_Modis_INTERFACE
Index: /LMDZ6/trunk/libf/phylmd/cospv2/cosp_modis_interface.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cospv2/cosp_modis_interface.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/cospv2/cosp_modis_interface.f90	(revision 5268)
@@ -0,0 +1,113 @@
+! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+! Copyright (c) 2015, Regents of the University of Colorado
+! All rights reserved.
+!
+! Redistribution and use in source and binary forms, with or without modification, are 
+! permitted provided that the following conditions are met:
+!
+! 1. Redistributions of source code must retain the above copyright notice, this list of 
+!    conditions and the following disclaimer.
+!
+! 2. Redistributions in binary form must reproduce the above copyright notice, this list
+!    of conditions and the following disclaimer in the documentation and/or other 
+!    materials provided with the distribution.
+!
+! 3. Neither the name of the copyright holder nor the names of its contributors may be 
+!    used to endorse or promote products derived from this software without specific prior
+!    written permission.
+!
+! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY 
+! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 
+! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL 
+! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 
+! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT 
+! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 
+! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+!
+! History
+! May 2015 - D. Swales - Original version
+! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+MODULE MOD_COSP_Modis_INTERFACE
+  USE COSP_KINDS,      ONLY: wp
+  USE MOD_COSP_CONFIG, ONLY: R_UNDEF
+  use mod_modis_sim,   ONLY: num_trial_res,min_OpticalThickness,CO2Slicing_PressureLimit,&
+                             CO2Slicing_TauLimit,phase_TauLimit,size_TauLimit,re_fill,   &
+                             phaseDiscrimination_Threshold,re_water_min,     &
+                             re_water_max,re_ice_min,re_ice_max,               &
+                             highCloudPressureLimit,lowCloudPressureLimit,phaseIsNone,   &
+                             phaseIsLiquid,phaseIsIce,phaseIsUndetermined,trial_re_w,    &
+                             trial_re_i,g_w,g_i,w0_w,w0_i, get_g_nir,get_ssa_nir
+  implicit none
+
+  ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  !  TYPE modis_in
+  ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 
+  type modis_IN
+     integer,pointer :: &
+          Npoints,        & ! Number of horizontal gridpoints
+          Ncolumns,       & ! Number of subcolumns
+          Nlevels           ! Number of vertical levels
+     integer :: &
+          Nsunlit           ! Number of sunlit lit pixels
+     real(wp),allocatable,dimension(:) :: &
+          sunlit,         & ! Sunlit scenes
+          notSunlit         ! Dark scenes
+     real(wp),allocatable,dimension(:,:) :: &
+          pres              ! Gridmean pressure at layer edges (Pa) 
+     real(wp),pointer ::  &
+          tau(:,:,:),     & ! Subcolumn optical thickness @ 0.67 microns.
+          liqFrac(:,:,:), & ! Liquid water fraction
+          g(:,:,:),       & ! Subcolumn assymetry parameter  
+          w0(:,:,:)         ! Subcolumn single-scattering albedo
+  end type modis_IN
+contains
+  ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  ! SUBROTUINE cosp_modis_init
+  ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  SUBROUTINE COSP_MODIS_INIT()
+    integer :: i 
+    
+    ! Retrieval parameters
+    min_OpticalThickness          = 0.3_wp     ! Minimum detectable optical thickness
+    CO2Slicing_PressureLimit      = 70000._wp  ! Cloud with higher pressures use thermal 
+                                               ! methods, units Pa
+    CO2Slicing_TauLimit           = 1._wp      ! How deep into the cloud does CO2 slicing 
+                                               ! see? 
+    phase_TauLimit                = 1._wp      ! How deep into the cloud does the phase 
+                                               ! detection see?
+    size_TauLimit                 = 2._wp      ! Depth of the re retreivals
+    phaseDiscrimination_Threshold = 0.7_wp     ! What fraction of total extincton needs to 
+                                               ! be in a single category to make phase 
+                                               ! discrim. work? 
+    re_fill                       = -999._wp   ! Fill value
+    re_water_min                  = 4._wp      ! Minimum effective radius (liquid)
+    re_water_max                  = 30._wp     ! Maximum effective radius (liquid)
+    re_ice_min                    = 5._wp      ! Minimum effective radius (ice)
+    re_ice_max                    = 90._wp     ! Minimum effective radius (ice)
+    highCloudPressureLimit        = 44000._wp  ! High cloud pressure limit (Pa)
+    lowCloudPressureLimit         = 68000._wp  ! Low cloud pressure limit (Pa)
+    phaseIsNone                   = 0          ! No cloud
+    phaseIsLiquid                 = 1          ! Liquid cloud
+    phaseIsIce                    = 2          ! Ice cloud
+    phaseIsUndetermined           = 3          ! Undetermined cloud
+
+    ! Precompute near-IR optical params vs size for retrieval scheme    
+    trial_re_w(1:num_trial_res) = re_water_min + (re_water_max - re_water_min) /         &
+         (num_trial_res-1) * (/(i, i=0, num_trial_res-1)/)
+    trial_re_i(1:num_trial_res) = re_ice_min   + (re_ice_max -   re_ice_min) /           &
+         (num_trial_res-1) * (/(i, i=0, num_trial_res-1)/)
+
+    ! Initialize estimates for size retrieval
+    g_w(1:num_trial_res)  = get_g_nir(phaseIsLiquid,trial_re_w(1:num_trial_res))
+    w0_w(1:num_trial_res) = get_ssa_nir(phaseIsLiquid,trial_re_w(1:num_trial_res))
+    g_i(1:num_trial_res)  = get_g_nir(phaseIsIce,trial_re_i(1:num_trial_res))
+    w0_i(1:num_trial_res) = get_ssa_nir(phaseIsIce,trial_re_i(1:num_trial_res))
+
+  END SUBROUTINE COSP_MODIS_INIT
+  
+  ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  ! END MODULE MOD_COSP_Modis_INTERFACE
+  ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+END MODULE MOD_COSP_Modis_INTERFACE
Index: DZ6/trunk/libf/phylmd/cospv2/cosp_optics.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cospv2/cosp_optics.F90	(revision 5267)
+++ 	(revision )
@@ -1,492 +1,0 @@
-! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-! Copyright (c) 2015, Regents of the University of Colorado
-! All rights reserved.
-!
-! Redistribution and use in source and binary forms, with or without modification, are 
-! permitted provided that the following conditions are met:
-!
-! 1. Redistributions of source code must retain the above copyright notice, this list of 
-!    conditions and the following disclaimer.
-!
-! 2. Redistributions in binary form must reproduce the above copyright notice, this list
-!    of conditions and the following disclaimer in the documentation and/or other 
-!    materials provided with the distribution.
-!
-! 3. Neither the name of the copyright holder nor the names of its contributors may be 
-!    used to endorse or promote products derived from this software without specific prior
-!    written permission.
-!
-! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY 
-! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 
-! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL 
-! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 
-! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT 
-! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 
-! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
-! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-!
-! History:
-! 05/01/15  Dustin Swales - Original version
-! 04/04/18  Rodrigo Guzman- Added CALIOP-like Ground LIDar routines (GLID)
-! 10/04/18  Rodrigo Guzman- Added ATLID-like (EarthCare) lidar routines (ATLID)
-! 
-! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-module cosp_optics
-  USE COSP_KINDS, ONLY: wp,dp
-  USE COSP_MATH_CONSTANTS,  ONLY: pi
-  USE COSP_PHYS_CONSTANTS,  ONLY: rholiq,km,rd,grav
-  USE MOD_MODIS_SIM,        ONLY: get_g_nir,get_ssa_nir,phaseIsLiquid,phaseIsIce
-  implicit none
-  
-  real(wp),parameter ::        & !
-       ice_density   = 0.93_wp   ! Ice density used in MODIS phase partitioning
-
-  interface cosp_simulator_optics
-     module procedure cosp_simulator_optics2D, cosp_simulator_optics3D
-  end interface cosp_simulator_optics
-  
-contains
-  ! ##########################################################################
-  !                          COSP_SIMULATOR_OPTICS
-  !
-  ! Used by: ISCCP, MISR and MODIS simulators
-  ! ##########################################################################
-  subroutine cosp_simulator_optics2D(dim1,dim2,dim3,flag,varIN1,varIN2,varOUT)
-    ! INPUTS
-    integer,intent(in) :: &
-         dim1,   & ! Dimension 1 extent (Horizontal)
-         dim2,   & ! Dimension 2 extent (Subcolumn)
-         dim3      ! Dimension 3 extent (Vertical)
-    real(wp),intent(in),dimension(dim1,dim2,dim3) :: &
-         flag      ! Logical to determine the of merge var1IN and var2IN
-    real(wp),intent(in),dimension(dim1,     dim3) :: &
-         varIN1, & ! Input field 1
-         varIN2    ! Input field 2
-    ! OUTPUTS
-    real(wp),intent(out),dimension(dim1,dim2,dim3) :: &
-         varOUT    ! Merged output field
-    ! LOCAL VARIABLES
-    integer :: j
-    
-    varOUT(1:dim1,1:dim2,1:dim3) = 0._wp
-    do j=1,dim2
-       where(flag(:,j,:) .eq. 1)
-          varOUT(:,j,:) = varIN2
-       endwhere
-       where(flag(:,j,:) .eq. 2)
-          varOUT(:,j,:) = varIN1
-       endwhere
-    enddo
-  end subroutine cosp_simulator_optics2D
-  subroutine cosp_simulator_optics3D(dim1,dim2,dim3,flag,varIN1,varIN2,varOUT)
-    ! INPUTS
-    integer,intent(in) :: &
-         dim1,   & ! Dimension 1 extent (Horizontal)
-         dim2,   & ! Dimension 2 extent (Subcolumn)
-         dim3      ! Dimension 3 extent (Vertical)
-    real(wp),intent(in),dimension(dim1,dim2,dim3) :: &
-         flag      ! Logical to determine the of merge var1IN and var2IN
-    real(wp),intent(in),dimension(dim1,dim2,dim3) :: &
-         varIN1, & ! Input field 1
-         varIN2    ! Input field 2
-    ! OUTPUTS
-    real(wp),intent(out),dimension(dim1,dim2,dim3) :: &
-         varOUT    ! Merged output field
-    
-    varOUT(1:dim1,1:dim2,1:dim3) = 0._wp
-   where(flag(:,:,:) .eq. 1)
-       varOUT(:,:,:) = varIN2
-    endwhere
-    where(flag(:,:,:) .eq. 2)
-       varOUT(:,:,:) = varIN1
-    endwhere
-    
-  end subroutine cosp_simulator_optics3D
-  
-  ! ##############################################################################
-  !                           MODIS_OPTICS_PARTITION
-  !
-  ! For the MODIS simulator, there are times when only a sinlge optical depth
-  ! profile, cloud-ice and cloud-water are provided. In this case, the optical
-  ! depth is partitioned by phase.
-  ! ##############################################################################
-  subroutine MODIS_OPTICS_PARTITION(npoints,nlev,ncolumns,cloudWater,cloudIce,waterSize, &
-                                    iceSize,tau,tauL,tauI)
-    ! INPUTS
-    INTEGER,intent(in) :: &
-         npoints,   & ! Number of horizontal gridpoints
-         nlev,      & ! Number of levels
-         ncolumns     ! Number of subcolumns
-    REAL(wp),intent(in),dimension(npoints,nlev,ncolumns) :: &
-         cloudWater, & ! Subcolumn cloud water content
-         cloudIce,   & ! Subcolumn cloud ice content
-         waterSize,  & ! Subcolumn cloud water effective radius
-         iceSize,    & ! Subcolumn cloud ice effective radius
-         tau           ! Optical thickness
-    
-    ! OUTPUTS
-    real(wp),intent(out),dimension(npoints,nlev,ncolumns) :: &
-         tauL,       & ! Partitioned liquid optical thickness.
-         tauI          ! Partitioned ice optical thickness.
-    ! LOCAL VARIABLES
-    real(wp),dimension(nlev,ncolumns) :: fracL
-    integer                           :: i
-    
-    
-    do i=1,npoints
-       where(cloudIce(i,:, :) <= 0.) 
-          fracL(:, :) = 1._wp
-       elsewhere
-          where (cloudWater(i,:, :) <= 0.) 
-             fracL(:, :) = 0._wp
-          elsewhere 
-             ! Geometic optics limit - tau as LWP/re  (proportional to LWC/re) 
-             fracL(:, :) = (cloudWater(i,:, :)/waterSize(i,:, :)) / &
-                  (cloudWater(i,:, :)/waterSize(i,:, :) + cloudIce(i,:, :)/(ice_density * iceSize(i,:, :)) ) 
-          end where
-       end where
-       tauL(i,:, :) = fracL(:, :) * tau(i,:, :) 
-       tauI(i,:, :) = tau(i,:, :) - tauL(i,:, :)
-    enddo
-    
-  end subroutine MODIS_OPTICS_PARTITION
-  ! ########################################################################################
-  !                                   MODIS_OPTICS
-  ! 
-  ! ########################################################################################
-  subroutine modis_optics(nPoints,nLevels,nSubCols,tauLIQ,sizeLIQ,tauICE,sizeICE,fracLIQ, g, w0)
-    ! INPUTS
-    integer, intent(in)                                      :: nPoints,nLevels,nSubCols
-    real(wp),intent(in),dimension(nPoints,nSubCols,nLevels)  :: tauLIQ, sizeLIQ, tauICE, sizeICE
-    ! OUTPUTS
-    real(wp),intent(out),dimension(nPoints,nSubCols,nLevels) :: g,w0,fracLIQ
-    ! LOCAL VARIABLES
-    real(wp), dimension(nLevels)            :: water_g, water_w0, ice_g, ice_w0,tau
-    integer :: i,j
-    
-    ! Initialize
-    g(1:nPoints,1:nSubCols,1:nLevels)  = 0._wp
-    w0(1:nPoints,1:nSubCols,1:nLevels) = 0._wp
-    
-    do j =1,nPoints
-       do i=1,nSubCols
-          water_g(1:nLevels)  = get_g_nir(  phaseIsLiquid, sizeLIQ(j,i,1:nLevels)) 
-          water_w0(1:nLevels) = get_ssa_nir(phaseIsLiquid, sizeLIQ(j,i,1:nLevels))
-          ice_g(1:nLevels)    = get_g_nir(  phaseIsIce,    sizeICE(j,i,1:nLevels))
-          ice_w0(1:nLevels)   = get_ssa_nir(phaseIsIce,    sizeICE(j,i,1:nLevels))
-          
-          ! Combine ice and water optical properties
-          tau(1:nLevels) = tauICE(j,i,1:nLevels) + tauLIQ(j,i,1:nLevels) 
-          where (tau(1:nLevels) > 0) 
-             w0(j,i,1:nLevels) = (tauLIQ(j,i,1:nLevels)*water_w0(1:nLevels) + tauICE(j,i,1:nLevels) *ice_w0(1:nLevels)) / &
-                                  (tau(1:nLevels))
-             g(j,i,1:nLevels) = (tauLIQ(j,i,1:nLevels)*water_g(1:nLevels)*water_w0(1:nLevels) + tauICE(j,i,1:nLevels) * &
-                  ice_g(1:nLevels) * ice_w0(1:nLevels)) / (w0(j,i,1:nLevels) * tau(1:nLevels))
-          end where
-       enddo
-    enddo
-    
-    ! Compute the total optical thickness and the proportion due to liquid in each cell
-    do i=1,npoints
-       where(tauLIQ(i,1:nSubCols,1:nLevels) + tauICE(i,1:nSubCols,1:nLevels) > 0.) 
-          fracLIQ(i,1:nSubCols,1:nLevels) = tauLIQ(i,1:nSubCols,1:nLevels)/ &
-               (tauLIQ(i,1:nSubCols,1:nLevels) + tauICE(i,1:nSubCols,1:nLevels))
-       elsewhere
-          fracLIQ(i,1:nSubCols,1:nLevels) = 0._wp
-       end  where
-    enddo
-    
-  end subroutine modis_optics
-  
-  ! ######################################################################################
-  ! SUBROUTINE lidar_optics
-  ! ######################################################################################
-  subroutine lidar_optics(npoints, ncolumns, nlev, npart, ice_type, lidar_freq, lground, &
-       q_lsliq, q_lsice, q_cvliq, q_cvice, ls_radliq, ls_radice, cv_radliq, cv_radice,   &
-       pres, presf, temp, beta_mol, betatot, tau_mol, tautot, tautot_S_liq, tautot_S_ice,&
-       betatot_ice, betatot_liq, tautot_ice, tautot_liq)
-
-    ! ####################################################################################
-    ! NOTE: Using "grav" from cosp_constants.f90, instead of grav=9.81, introduces
-    ! changes of up to 2% in atb532 adn 0.003% in parasolRefl and lidarBetaMol532. 
-    ! This also results in  small changes in the joint-histogram, cfadLidarsr532.
-    ! ####################################################################################
-    
-    ! INPUTS
-    INTEGER,intent(in) :: & 
-         npoints,      & ! Number of gridpoints
-         ncolumns,     & ! Number of subcolumns
-         nlev,         & ! Number of levels
-         npart,        & ! Number of cloud meteors (stratiform_liq, stratiform_ice, conv_liq, conv_ice). 
-         ice_type,     & ! Ice particle shape hypothesis (0 for spheres, 1 for non-spherical)
-         lidar_freq      ! Lidar frequency (nm). Use to change between lidar platforms
-    logical,intent(in) :: &
-         lground         ! True for ground-based lidar
-    REAL(WP),intent(in),dimension(npoints,nlev) :: &
-         temp,         & ! Temperature of layer k
-         pres,         & ! Pressure at full levels
-         ls_radliq,    & ! Effective radius of LS liquid particles (meters)
-         ls_radice,    & ! Effective radius of LS ice particles (meters)
-         cv_radliq,    & ! Effective radius of CONV liquid particles (meters)
-         cv_radice       ! Effective radius of CONV ice particles (meters)
-    REAL(WP),intent(in),dimension(npoints,ncolumns,nlev) :: &
-         q_lsliq,      & ! LS sub-column liquid water mixing ratio (kg/kg)
-         q_lsice,      & ! LS sub-column ice water mixing ratio (kg/kg)
-         q_cvliq,      & ! CONV sub-column liquid water mixing ratio (kg/kg)
-         q_cvice         ! CONV sub-column ice water mixing ratio (kg/kg)
-    REAL(WP),intent(in),dimension(npoints,nlev+1) :: &
-         presf           ! Pressure at half levels
-    
-    ! OUTPUTS
-    REAL(WP),intent(out),dimension(npoints,ncolumns,nlev)       :: &
-         betatot,        & ! 
-         tautot            ! Optical thickess integrated from top
-    REAL(WP),intent(out),dimension(npoints,nlev) :: &
-         beta_mol,       & ! Molecular backscatter coefficient
-         tau_mol           ! Molecular optical depth
-    ! OUTPUTS (optional)
-    REAL(WP),optional,intent(out),dimension(npoints,ncolumns) :: &
-         tautot_S_liq,   & ! TOA optical depth for liquid
-         tautot_S_ice      ! TOA optical depth for ice
-    REAL(WP),optional,intent(out),dimension(npoints,ncolumns,nlev)       :: &
-         betatot_ice,    & ! Backscatter coefficient for ice particles
-         betatot_liq,    & ! Backscatter coefficient for liquid particles
-         tautot_ice,     & ! Total optical thickness of ice
-         tautot_liq        ! Total optical thickness of liq
-    
-    ! LOCAL VARIABLES
-    REAL(WP),dimension(npart)              :: rhopart
-    REAL(WP),dimension(npart,5)            :: polpart 
-    REAL(WP),dimension(npoints,nlev)       :: rhoair,alpha_mol
-    REAL(WP),dimension(npoints,nlev+1)     :: zheight          
-    REAL(WP),dimension(npoints,nlev,npart) :: rad_part,kp_part,qpart,alpha_part,tau_part
-    real(wp)                               :: Cmol,rdiffm
-    logical                                :: lparasol,lphaseoptics
-    INTEGER                                :: i,k,icol,zi,zf,zinc,zoffset
-    
-    ! Local data
-    REAL(WP),PARAMETER :: rhoice     = 0.5e+03    ! Density of ice (kg/m3) 
-    REAL(WP),PARAMETER :: Cmol_532nm = 6.2446e-32 ! Wavelength dependent
-    REAL(WP),PARAMETER :: Cmol_355nm = 3.2662e-31! Wavelength dependent
-    REAL(WP),PARAMETER :: rdiffm_532nm = 0.7_wp     ! Multiple scattering correction parameter
-    REAL(WP),PARAMETER :: rdiffm_355nm = 0.6_wp     ! Multiple scattering correction parameter
-    REAL(WP),PARAMETER :: Qscat      = 2.0_wp     ! Particle scattering efficiency at 532 nm
-    ! Local indicies for large-scale and convective ice and liquid 
-    INTEGER,PARAMETER  :: INDX_LSLIQ  = 1
-    INTEGER,PARAMETER  :: INDX_LSICE  = 2
-    INTEGER,PARAMETER  :: INDX_CVLIQ  = 3
-    INTEGER,PARAMETER  :: INDX_CVICE  = 4
-    
-    ! Polarized optics parameterization
-    ! Polynomial coefficients for spherical liq/ice particles derived from Mie theory.
-    ! Polynomial coefficients for non spherical particles derived from a composite of
-    ! Ray-tracing theory for large particles (e.g. Noel et al., Appl. Opt., 2001)
-    ! and FDTD theory for very small particles (Yang et al., JQSRT, 2003).
-    ! We repeat the same coefficients for LS and CONV cloud to make code more readable
-    REAL(WP),PARAMETER,dimension(5) :: &
-         polpartCVLIQ  = (/ 2.6980e-8_wp,  -3.7701e-6_wp,  1.6594e-4_wp,    -0.0024_wp,    0.0626_wp/), &
-         polpartLSLIQ  = (/ 2.6980e-8_wp,  -3.7701e-6_wp,  1.6594e-4_wp,    -0.0024_wp,    0.0626_wp/), &
-         polpartCVICE0 = (/-1.0176e-8_wp,   1.7615e-6_wp, -1.0480e-4_wp,     0.0019_wp,    0.0460_wp/), &
-         polpartLSICE0 = (/-1.0176e-8_wp,   1.7615e-6_wp, -1.0480e-4_wp,     0.0019_wp,    0.0460_wp/), &
-         polpartCVICE1 = (/ 1.3615e-8_wp, -2.04206e-6_wp, 7.51799e-5_wp, 0.00078213_wp, 0.0182131_wp/), &
-         polpartLSICE1 = (/ 1.3615e-8_wp, -2.04206e-6_wp, 7.51799e-5_wp, 0.00078213_wp, 0.0182131_wp/)
-    ! ##############################################################################
-
-    ! Which LIDAR frequency are we using?
-    if (lidar_freq .eq. 355) then
-       Cmol   = Cmol_355nm
-       rdiffm = rdiffm_355nm
-    endif
-    if (lidar_freq .eq. 532) then
-       Cmol   = Cmol_532nm
-       rdiffm = rdiffm_532nm
-    endif
-    
-    ! Do we need to generate optical inputs for Parasol simulator?
-    lparasol = .false.
-    if (present(tautot_S_liq) .and. present(tautot_S_ice)) lparasol = .true.
-    
-    ! Are optical-depths and backscatter coefficients for ice and liquid requested?
-    lphaseoptics=.false.
-    if (present(betatot_ice) .and. present(betatot_liq) .and. present(tautot_liq) .and. &
-         present(tautot_ice)) lphaseoptics=.true.
-
-    ! Is this lidar spaceborne (default) or ground-based (lground=.true.)?
-    zi   = 2
-    zf   = nlev
-    zinc = 1
-    zoffset = -1
-    if (lground) then
-       zi   = nlev-1
-       zf   = 1
-       zinc = -1
-       zoffset = 1
-    endif
-    
-    ! Liquid/ice particles
-    rhopart(INDX_LSLIQ)  = rholiq
-    rhopart(INDX_LSICE)  = rhoice
-    rhopart(INDX_CVLIQ)  = rholiq
-    rhopart(INDX_CVICE)  = rhoice
-    
-    ! LS and CONV Liquid water coefficients
-    polpart(INDX_LSLIQ,1:5)  = polpartLSLIQ
-    polpart(INDX_CVLIQ,1:5)  = polpartCVLIQ
-    
-    ! LS and CONV Ice water coefficients
-    if (ice_type .eq. 0) then
-       polpart(INDX_LSICE,1:5) = polpartLSICE0
-       polpart(INDX_CVICE,1:5) = polpartCVICE0
-    endif
-    if (ice_type .eq. 1) then
-       polpart(INDX_LSICE,1:5) = polpartLSICE1
-       polpart(INDX_CVICE,1:5) = polpartCVICE1
-    endif
-    
-    ! Effective radius particles:
-    rad_part(1:npoints,1:nlev,INDX_LSLIQ)  = ls_radliq(1:npoints,1:nlev)
-    rad_part(1:npoints,1:nlev,INDX_LSICE)  = ls_radice(1:npoints,1:nlev)
-    rad_part(1:npoints,1:nlev,INDX_CVLIQ)  = cv_radliq(1:npoints,1:nlev)
-    rad_part(1:npoints,1:nlev,INDX_CVICE)  = cv_radice(1:npoints,1:nlev)    
-    rad_part(1:npoints,1:nlev,1:npart)     = MAX(rad_part(1:npoints,1:nlev,1:npart),0._wp)
-    rad_part(1:npoints,1:nlev,1:npart)     = MIN(rad_part(1:npoints,1:nlev,1:npart),70.0e-6_wp)
-    
-    ! Density (clear-sky air)
-    rhoair(1:npoints,1:nlev) = pres(1:npoints,1:nlev)/(rd*temp(1:npoints,1:nlev))
-    
-    ! Altitude at half pressure levels:
-    zheight(1:npoints,nlev+1) = 0._wp
-    do k=nlev,1,-1
-       zheight(1:npoints,k) = zheight(1:npoints,k+1) &
-            -(presf(1:npoints,k)-presf(1:npoints,k+1))/(rhoair(1:npoints,k)*grav)
-    enddo
-    
-    ! ##############################################################################
-    ! *) Molecular alpha, beta and optical thickness
-    ! ##############################################################################
-    
-    beta_mol(1:npoints,1:nlev)  = pres(1:npoints,1:nlev)/km/temp(1:npoints,1:nlev)*Cmol
-    alpha_mol(1:npoints,1:nlev) = 8._wp*pi/3._wp * beta_mol(1:npoints,1:nlev)
-    
-    ! Optical thickness of each layer (molecular)  
-    tau_mol(1:npoints,1:nlev) = alpha_mol(1:npoints,1:nlev)*(zheight(1:npoints,1:nlev)-&
-         zheight(1:npoints,2:nlev+1))
-             
-    ! Optical thickness from TOA to layer k (molecular)
-    DO k = zi,zf,zinc
-       tau_mol(1:npoints,k) = tau_mol(1:npoints,k) + tau_mol(1:npoints,k+zoffset)
-    ENDDO    
-
-    betatot    (1:npoints,1:ncolumns,1:nlev) = spread(beta_mol(1:npoints,1:nlev), dim=2, NCOPIES=ncolumns)
-    tautot     (1:npoints,1:ncolumns,1:nlev) = spread(tau_mol (1:npoints,1:nlev), dim=2, NCOPIES=ncolumns)
-    if (lphaseoptics) then
-       betatot_liq(1:npoints,1:ncolumns,1:nlev) = betatot(1:npoints,1:ncolumns,1:nlev)
-       betatot_ice(1:npoints,1:ncolumns,1:nlev) = betatot(1:npoints,1:ncolumns,1:nlev)
-       tautot_liq (1:npoints,1:ncolumns,1:nlev) = tautot(1:npoints,1:ncolumns,1:nlev)
-       tautot_ice (1:npoints,1:ncolumns,1:nlev) = tautot(1:npoints,1:ncolumns,1:nlev)      
-    endif
-
-    ! ##############################################################################
-    ! *) Particles alpha, beta and optical thickness
-    ! ##############################################################################
-    ! Polynomials kp_lidar derived from Mie theory
-    do i = 1, npart
-       where (rad_part(1:npoints,1:nlev,i) .gt. 0.0)
-          kp_part(1:npoints,1:nlev,i) = &
-               polpart(i,1)*(rad_part(1:npoints,1:nlev,i)*1e6)**4 &
-               + polpart(i,2)*(rad_part(1:npoints,1:nlev,i)*1e6)**3 &
-               + polpart(i,3)*(rad_part(1:npoints,1:nlev,i)*1e6)**2 &
-               + polpart(i,4)*(rad_part(1:npoints,1:nlev,i)*1e6) &
-               + polpart(i,5)
-       elsewhere
-          kp_part(1:npoints,1:nlev,i) = 0._wp
-       endwhere
-    enddo    
-
-    ! Initialize (if necessary)
-    if (lparasol) then
-       tautot_S_liq(1:npoints,1:ncolumns) = 0._wp
-       tautot_S_ice(1:npoints,1:ncolumns) = 0._wp
-    endif
-
-    ! Loop over all subcolumns
-    do icol=1,ncolumns
-       ! ##############################################################################
-       ! Mixing ratio particles in each subcolum
-       ! ##############################################################################
-       qpart(1:npoints,1:nlev,INDX_LSLIQ) =  q_lsliq(1:npoints,icol,1:nlev)
-       qpart(1:npoints,1:nlev,INDX_LSICE)  = q_lsice(1:npoints,icol,1:nlev)
-       qpart(1:npoints,1:nlev,INDX_CVLIQ)  = q_cvliq(1:npoints,icol,1:nlev)
-       qpart(1:npoints,1:nlev,INDX_CVICE)  = q_cvice(1:npoints,icol,1:nlev)
-
-       ! ##############################################################################
-       ! Alpha and optical thickness (particles)
-       ! ##############################################################################
-       ! Alpha of particles in each subcolumn:
-       do i = 1, npart
-          where (rad_part(1:npoints,1:nlev,i) .gt. 0.0)
-             alpha_part(1:npoints,1:nlev,i) = 3._wp/4._wp * Qscat &
-                  * rhoair(1:npoints,1:nlev) * qpart(1:npoints,1:nlev,i) &
-                  / (rhopart(i) * rad_part(1:npoints,1:nlev,i) )
-          elsewhere
-             alpha_part(1:npoints,1:nlev,i) = 0._wp
-          endwhere
-       enddo
-       
-       ! Optical thicknes
-       tau_part(1:npoints,1:nlev,1:npart) = rdiffm * alpha_part(1:npoints,1:nlev,1:npart)
-       do i = 1, npart
-          ! Optical thickness of each layer (particles)
-          tau_part(1:npoints,1:nlev,i) = tau_part(1:npoints,1:nlev,i) &
-               & * (zheight(1:npoints,1:nlev)-zheight(1:npoints,2:nlev+1) )
-          ! Optical thickness from TOA to layer k (particles)
-          do k=zi,zf,zinc
-             tau_part(1:npoints,k,i) = tau_part(1:npoints,k,i) + tau_part(1:npoints,k+zoffset,i)
-          enddo
-       enddo
- 
-       ! ##############################################################################
-       ! Beta and optical thickness (total=molecular + particules)
-       ! ##############################################################################
-       
-       DO i = 1, npart
-          betatot(1:npoints,icol,1:nlev) = betatot(1:npoints,icol,1:nlev) + &
-               kp_part(1:npoints,1:nlev,i)*alpha_part(1:npoints,1:nlev,i)
-          tautot(1:npoints,icol,1:nlev) = tautot(1:npoints,icol,1:nlev)  + &
-              tau_part(1:npoints,1:nlev,i)
-       ENDDO
-       
-       ! ##############################################################################
-       ! Beta and optical thickness (liquid/ice)
-       ! ##############################################################################
-       if (lphaseoptics) then
-          ! Ice
-          betatot_ice(1:npoints,icol,1:nlev) = betatot_ice(1:npoints,icol,1:nlev)+ &
-               kp_part(1:npoints,1:nlev,INDX_LSICE)*alpha_part(1:npoints,1:nlev,INDX_LSICE)+ &
-               kp_part(1:npoints,1:nlev,INDX_CVICE)*alpha_part(1:npoints,1:nlev,INDX_CVICE)
-          tautot_ice(1:npoints,icol,1:nlev) = tautot_ice(1:npoints,icol,1:nlev)  + &
-               tau_part(1:npoints,1:nlev,INDX_LSICE) + &
-               tau_part(1:npoints,1:nlev,INDX_CVICE)
-          
-          ! Liquid
-          betatot_liq(1:npoints,icol,1:nlev) = betatot_liq(1:npoints,icol,1:nlev)+ &
-               kp_part(1:npoints,1:nlev,INDX_LSLIQ)*alpha_part(1:npoints,1:nlev,INDX_LSLIQ)+ &
-               kp_part(1:npoints,1:nlev,INDX_CVLIQ)*alpha_part(1:npoints,1:nlev,INDX_CVLIQ)
-          tautot_liq(1:npoints,icol,1:nlev) = tautot_liq(1:npoints,icol,1:nlev)  + &
-               tau_part(1:npoints,1:nlev,INDX_LSLIQ) + &
-               tau_part(1:npoints,1:nlev,INDX_CVLIQ)
-       endif
-
-       ! ##############################################################################    
-       ! Optical depths used by the PARASOL simulator
-       ! ##############################################################################             
-       if (lparasol) then
-          tautot_S_liq(:,icol) = tau_part(:,nlev,1)+tau_part(:,nlev,3)
-          tautot_S_ice(:,icol) = tau_part(:,nlev,2)+tau_part(:,nlev,4)              
-       endif
-    enddo
-    
-  end subroutine lidar_optics
-
-end module cosp_optics
Index: /LMDZ6/trunk/libf/phylmd/cospv2/cosp_optics.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cospv2/cosp_optics.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/cospv2/cosp_optics.f90	(revision 5268)
@@ -0,0 +1,492 @@
+! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+! Copyright (c) 2015, Regents of the University of Colorado
+! All rights reserved.
+!
+! Redistribution and use in source and binary forms, with or without modification, are 
+! permitted provided that the following conditions are met:
+!
+! 1. Redistributions of source code must retain the above copyright notice, this list of 
+!    conditions and the following disclaimer.
+!
+! 2. Redistributions in binary form must reproduce the above copyright notice, this list
+!    of conditions and the following disclaimer in the documentation and/or other 
+!    materials provided with the distribution.
+!
+! 3. Neither the name of the copyright holder nor the names of its contributors may be 
+!    used to endorse or promote products derived from this software without specific prior
+!    written permission.
+!
+! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY 
+! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 
+! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL 
+! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 
+! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT 
+! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 
+! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+!
+! History:
+! 05/01/15  Dustin Swales - Original version
+! 04/04/18  Rodrigo Guzman- Added CALIOP-like Ground LIDar routines (GLID)
+! 10/04/18  Rodrigo Guzman- Added ATLID-like (EarthCare) lidar routines (ATLID)
+! 
+! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+module cosp_optics
+  USE COSP_KINDS, ONLY: wp,dp
+  USE COSP_MATH_CONSTANTS,  ONLY: pi
+  USE COSP_PHYS_CONSTANTS,  ONLY: rholiq,km,rd,grav
+  USE MOD_MODIS_SIM,        ONLY: get_g_nir,get_ssa_nir,phaseIsLiquid,phaseIsIce
+  implicit none
+  
+  real(wp),parameter ::        & !
+       ice_density   = 0.93_wp   ! Ice density used in MODIS phase partitioning
+
+  interface cosp_simulator_optics
+     module procedure cosp_simulator_optics2D, cosp_simulator_optics3D
+  end interface cosp_simulator_optics
+  
+contains
+  ! ##########################################################################
+  !                          COSP_SIMULATOR_OPTICS
+  !
+  ! Used by: ISCCP, MISR and MODIS simulators
+  ! ##########################################################################
+  subroutine cosp_simulator_optics2D(dim1,dim2,dim3,flag,varIN1,varIN2,varOUT)
+    ! INPUTS
+    integer,intent(in) :: &
+         dim1,   & ! Dimension 1 extent (Horizontal)
+         dim2,   & ! Dimension 2 extent (Subcolumn)
+         dim3      ! Dimension 3 extent (Vertical)
+    real(wp),intent(in),dimension(dim1,dim2,dim3) :: &
+         flag      ! Logical to determine the of merge var1IN and var2IN
+    real(wp),intent(in),dimension(dim1,     dim3) :: &
+         varIN1, & ! Input field 1
+         varIN2    ! Input field 2
+    ! OUTPUTS
+    real(wp),intent(out),dimension(dim1,dim2,dim3) :: &
+         varOUT    ! Merged output field
+    ! LOCAL VARIABLES
+    integer :: j
+    
+    varOUT(1:dim1,1:dim2,1:dim3) = 0._wp
+    do j=1,dim2
+       where(flag(:,j,:) .eq. 1)
+          varOUT(:,j,:) = varIN2
+       endwhere
+       where(flag(:,j,:) .eq. 2)
+          varOUT(:,j,:) = varIN1
+       endwhere
+    enddo
+  end subroutine cosp_simulator_optics2D
+  subroutine cosp_simulator_optics3D(dim1,dim2,dim3,flag,varIN1,varIN2,varOUT)
+    ! INPUTS
+    integer,intent(in) :: &
+         dim1,   & ! Dimension 1 extent (Horizontal)
+         dim2,   & ! Dimension 2 extent (Subcolumn)
+         dim3      ! Dimension 3 extent (Vertical)
+    real(wp),intent(in),dimension(dim1,dim2,dim3) :: &
+         flag      ! Logical to determine the of merge var1IN and var2IN
+    real(wp),intent(in),dimension(dim1,dim2,dim3) :: &
+         varIN1, & ! Input field 1
+         varIN2    ! Input field 2
+    ! OUTPUTS
+    real(wp),intent(out),dimension(dim1,dim2,dim3) :: &
+         varOUT    ! Merged output field
+    
+    varOUT(1:dim1,1:dim2,1:dim3) = 0._wp
+   where(flag(:,:,:) .eq. 1)
+       varOUT(:,:,:) = varIN2
+    endwhere
+    where(flag(:,:,:) .eq. 2)
+       varOUT(:,:,:) = varIN1
+    endwhere
+    
+  end subroutine cosp_simulator_optics3D
+  
+  ! ##############################################################################
+  !                           MODIS_OPTICS_PARTITION
+  !
+  ! For the MODIS simulator, there are times when only a sinlge optical depth
+  ! profile, cloud-ice and cloud-water are provided. In this case, the optical
+  ! depth is partitioned by phase.
+  ! ##############################################################################
+  subroutine MODIS_OPTICS_PARTITION(npoints,nlev,ncolumns,cloudWater,cloudIce,waterSize, &
+                                    iceSize,tau,tauL,tauI)
+    ! INPUTS
+    INTEGER,intent(in) :: &
+         npoints,   & ! Number of horizontal gridpoints
+         nlev,      & ! Number of levels
+         ncolumns     ! Number of subcolumns
+    REAL(wp),intent(in),dimension(npoints,nlev,ncolumns) :: &
+         cloudWater, & ! Subcolumn cloud water content
+         cloudIce,   & ! Subcolumn cloud ice content
+         waterSize,  & ! Subcolumn cloud water effective radius
+         iceSize,    & ! Subcolumn cloud ice effective radius
+         tau           ! Optical thickness
+    
+    ! OUTPUTS
+    real(wp),intent(out),dimension(npoints,nlev,ncolumns) :: &
+         tauL,       & ! Partitioned liquid optical thickness.
+         tauI          ! Partitioned ice optical thickness.
+    ! LOCAL VARIABLES
+    real(wp),dimension(nlev,ncolumns) :: fracL
+    integer                           :: i
+    
+    
+    do i=1,npoints
+       where(cloudIce(i,:, :) <= 0.) 
+          fracL(:, :) = 1._wp
+       elsewhere
+          where (cloudWater(i,:, :) <= 0.) 
+             fracL(:, :) = 0._wp
+          elsewhere 
+             ! Geometic optics limit - tau as LWP/re  (proportional to LWC/re) 
+             fracL(:, :) = (cloudWater(i,:, :)/waterSize(i,:, :)) / &
+                  (cloudWater(i,:, :)/waterSize(i,:, :) + cloudIce(i,:, :)/(ice_density * iceSize(i,:, :)) ) 
+          end where
+       end where
+       tauL(i,:, :) = fracL(:, :) * tau(i,:, :) 
+       tauI(i,:, :) = tau(i,:, :) - tauL(i,:, :)
+    enddo
+    
+  end subroutine MODIS_OPTICS_PARTITION
+  ! ########################################################################################
+  !                                   MODIS_OPTICS
+  ! 
+  ! ########################################################################################
+  subroutine modis_optics(nPoints,nLevels,nSubCols,tauLIQ,sizeLIQ,tauICE,sizeICE,fracLIQ, g, w0)
+    ! INPUTS
+    integer, intent(in)                                      :: nPoints,nLevels,nSubCols
+    real(wp),intent(in),dimension(nPoints,nSubCols,nLevels)  :: tauLIQ, sizeLIQ, tauICE, sizeICE
+    ! OUTPUTS
+    real(wp),intent(out),dimension(nPoints,nSubCols,nLevels) :: g,w0,fracLIQ
+    ! LOCAL VARIABLES
+    real(wp), dimension(nLevels)            :: water_g, water_w0, ice_g, ice_w0,tau
+    integer :: i,j
+    
+    ! Initialize
+    g(1:nPoints,1:nSubCols,1:nLevels)  = 0._wp
+    w0(1:nPoints,1:nSubCols,1:nLevels) = 0._wp
+    
+    do j =1,nPoints
+       do i=1,nSubCols
+          water_g(1:nLevels)  = get_g_nir(  phaseIsLiquid, sizeLIQ(j,i,1:nLevels)) 
+          water_w0(1:nLevels) = get_ssa_nir(phaseIsLiquid, sizeLIQ(j,i,1:nLevels))
+          ice_g(1:nLevels)    = get_g_nir(  phaseIsIce,    sizeICE(j,i,1:nLevels))
+          ice_w0(1:nLevels)   = get_ssa_nir(phaseIsIce,    sizeICE(j,i,1:nLevels))
+          
+          ! Combine ice and water optical properties
+          tau(1:nLevels) = tauICE(j,i,1:nLevels) + tauLIQ(j,i,1:nLevels) 
+          where (tau(1:nLevels) > 0) 
+             w0(j,i,1:nLevels) = (tauLIQ(j,i,1:nLevels)*water_w0(1:nLevels) + tauICE(j,i,1:nLevels) *ice_w0(1:nLevels)) / &
+                                  (tau(1:nLevels))
+             g(j,i,1:nLevels) = (tauLIQ(j,i,1:nLevels)*water_g(1:nLevels)*water_w0(1:nLevels) + tauICE(j,i,1:nLevels) * &
+                  ice_g(1:nLevels) * ice_w0(1:nLevels)) / (w0(j,i,1:nLevels) * tau(1:nLevels))
+          end where
+       enddo
+    enddo
+    
+    ! Compute the total optical thickness and the proportion due to liquid in each cell
+    do i=1,npoints
+       where(tauLIQ(i,1:nSubCols,1:nLevels) + tauICE(i,1:nSubCols,1:nLevels) > 0.) 
+          fracLIQ(i,1:nSubCols,1:nLevels) = tauLIQ(i,1:nSubCols,1:nLevels)/ &
+               (tauLIQ(i,1:nSubCols,1:nLevels) + tauICE(i,1:nSubCols,1:nLevels))
+       elsewhere
+          fracLIQ(i,1:nSubCols,1:nLevels) = 0._wp
+       end  where
+    enddo
+    
+  end subroutine modis_optics
+  
+  ! ######################################################################################
+  ! SUBROUTINE lidar_optics
+  ! ######################################################################################
+  subroutine lidar_optics(npoints, ncolumns, nlev, npart, ice_type, lidar_freq, lground, &
+       q_lsliq, q_lsice, q_cvliq, q_cvice, ls_radliq, ls_radice, cv_radliq, cv_radice,   &
+       pres, presf, temp, beta_mol, betatot, tau_mol, tautot, tautot_S_liq, tautot_S_ice,&
+       betatot_ice, betatot_liq, tautot_ice, tautot_liq)
+
+    ! ####################################################################################
+    ! NOTE: Using "grav" from cosp_constants.f90, instead of grav=9.81, introduces
+    ! changes of up to 2% in atb532 adn 0.003% in parasolRefl and lidarBetaMol532. 
+    ! This also results in  small changes in the joint-histogram, cfadLidarsr532.
+    ! ####################################################################################
+    
+    ! INPUTS
+    INTEGER,intent(in) :: & 
+         npoints,      & ! Number of gridpoints
+         ncolumns,     & ! Number of subcolumns
+         nlev,         & ! Number of levels
+         npart,        & ! Number of cloud meteors (stratiform_liq, stratiform_ice, conv_liq, conv_ice). 
+         ice_type,     & ! Ice particle shape hypothesis (0 for spheres, 1 for non-spherical)
+         lidar_freq      ! Lidar frequency (nm). Use to change between lidar platforms
+    logical,intent(in) :: &
+         lground         ! True for ground-based lidar
+    REAL(WP),intent(in),dimension(npoints,nlev) :: &
+         temp,         & ! Temperature of layer k
+         pres,         & ! Pressure at full levels
+         ls_radliq,    & ! Effective radius of LS liquid particles (meters)
+         ls_radice,    & ! Effective radius of LS ice particles (meters)
+         cv_radliq,    & ! Effective radius of CONV liquid particles (meters)
+         cv_radice       ! Effective radius of CONV ice particles (meters)
+    REAL(WP),intent(in),dimension(npoints,ncolumns,nlev) :: &
+         q_lsliq,      & ! LS sub-column liquid water mixing ratio (kg/kg)
+         q_lsice,      & ! LS sub-column ice water mixing ratio (kg/kg)
+         q_cvliq,      & ! CONV sub-column liquid water mixing ratio (kg/kg)
+         q_cvice         ! CONV sub-column ice water mixing ratio (kg/kg)
+    REAL(WP),intent(in),dimension(npoints,nlev+1) :: &
+         presf           ! Pressure at half levels
+    
+    ! OUTPUTS
+    REAL(WP),intent(out),dimension(npoints,ncolumns,nlev)       :: &
+         betatot,        & ! 
+         tautot            ! Optical thickess integrated from top
+    REAL(WP),intent(out),dimension(npoints,nlev) :: &
+         beta_mol,       & ! Molecular backscatter coefficient
+         tau_mol           ! Molecular optical depth
+    ! OUTPUTS (optional)
+    REAL(WP),optional,intent(out),dimension(npoints,ncolumns) :: &
+         tautot_S_liq,   & ! TOA optical depth for liquid
+         tautot_S_ice      ! TOA optical depth for ice
+    REAL(WP),optional,intent(out),dimension(npoints,ncolumns,nlev)       :: &
+         betatot_ice,    & ! Backscatter coefficient for ice particles
+         betatot_liq,    & ! Backscatter coefficient for liquid particles
+         tautot_ice,     & ! Total optical thickness of ice
+         tautot_liq        ! Total optical thickness of liq
+    
+    ! LOCAL VARIABLES
+    REAL(WP),dimension(npart)              :: rhopart
+    REAL(WP),dimension(npart,5)            :: polpart 
+    REAL(WP),dimension(npoints,nlev)       :: rhoair,alpha_mol
+    REAL(WP),dimension(npoints,nlev+1)     :: zheight          
+    REAL(WP),dimension(npoints,nlev,npart) :: rad_part,kp_part,qpart,alpha_part,tau_part
+    real(wp)                               :: Cmol,rdiffm
+    logical                                :: lparasol,lphaseoptics
+    INTEGER                                :: i,k,icol,zi,zf,zinc,zoffset
+    
+    ! Local data
+    REAL(WP),PARAMETER :: rhoice     = 0.5e+03    ! Density of ice (kg/m3) 
+    REAL(WP),PARAMETER :: Cmol_532nm = 6.2446e-32 ! Wavelength dependent
+    REAL(WP),PARAMETER :: Cmol_355nm = 3.2662e-31! Wavelength dependent
+    REAL(WP),PARAMETER :: rdiffm_532nm = 0.7_wp     ! Multiple scattering correction parameter
+    REAL(WP),PARAMETER :: rdiffm_355nm = 0.6_wp     ! Multiple scattering correction parameter
+    REAL(WP),PARAMETER :: Qscat      = 2.0_wp     ! Particle scattering efficiency at 532 nm
+    ! Local indicies for large-scale and convective ice and liquid 
+    INTEGER,PARAMETER  :: INDX_LSLIQ  = 1
+    INTEGER,PARAMETER  :: INDX_LSICE  = 2
+    INTEGER,PARAMETER  :: INDX_CVLIQ  = 3
+    INTEGER,PARAMETER  :: INDX_CVICE  = 4
+    
+    ! Polarized optics parameterization
+    ! Polynomial coefficients for spherical liq/ice particles derived from Mie theory.
+    ! Polynomial coefficients for non spherical particles derived from a composite of
+    ! Ray-tracing theory for large particles (e.g. Noel et al., Appl. Opt., 2001)
+    ! and FDTD theory for very small particles (Yang et al., JQSRT, 2003).
+    ! We repeat the same coefficients for LS and CONV cloud to make code more readable
+    REAL(WP),PARAMETER,dimension(5) :: &
+         polpartCVLIQ  = (/ 2.6980e-8_wp,  -3.7701e-6_wp,  1.6594e-4_wp,    -0.0024_wp,    0.0626_wp/), &
+         polpartLSLIQ  = (/ 2.6980e-8_wp,  -3.7701e-6_wp,  1.6594e-4_wp,    -0.0024_wp,    0.0626_wp/), &
+         polpartCVICE0 = (/-1.0176e-8_wp,   1.7615e-6_wp, -1.0480e-4_wp,     0.0019_wp,    0.0460_wp/), &
+         polpartLSICE0 = (/-1.0176e-8_wp,   1.7615e-6_wp, -1.0480e-4_wp,     0.0019_wp,    0.0460_wp/), &
+         polpartCVICE1 = (/ 1.3615e-8_wp, -2.04206e-6_wp, 7.51799e-5_wp, 0.00078213_wp, 0.0182131_wp/), &
+         polpartLSICE1 = (/ 1.3615e-8_wp, -2.04206e-6_wp, 7.51799e-5_wp, 0.00078213_wp, 0.0182131_wp/)
+    ! ##############################################################################
+
+    ! Which LIDAR frequency are we using?
+    if (lidar_freq .eq. 355) then
+       Cmol   = Cmol_355nm
+       rdiffm = rdiffm_355nm
+    endif
+    if (lidar_freq .eq. 532) then
+       Cmol   = Cmol_532nm
+       rdiffm = rdiffm_532nm
+    endif
+    
+    ! Do we need to generate optical inputs for Parasol simulator?
+    lparasol = .false.
+    if (present(tautot_S_liq) .and. present(tautot_S_ice)) lparasol = .true.
+    
+    ! Are optical-depths and backscatter coefficients for ice and liquid requested?
+    lphaseoptics=.false.
+    if (present(betatot_ice) .and. present(betatot_liq) .and. present(tautot_liq) .and. &
+         present(tautot_ice)) lphaseoptics=.true.
+
+    ! Is this lidar spaceborne (default) or ground-based (lground=.true.)?
+    zi   = 2
+    zf   = nlev
+    zinc = 1
+    zoffset = -1
+    if (lground) then
+       zi   = nlev-1
+       zf   = 1
+       zinc = -1
+       zoffset = 1
+    endif
+    
+    ! Liquid/ice particles
+    rhopart(INDX_LSLIQ)  = rholiq
+    rhopart(INDX_LSICE)  = rhoice
+    rhopart(INDX_CVLIQ)  = rholiq
+    rhopart(INDX_CVICE)  = rhoice
+    
+    ! LS and CONV Liquid water coefficients
+    polpart(INDX_LSLIQ,1:5)  = polpartLSLIQ
+    polpart(INDX_CVLIQ,1:5)  = polpartCVLIQ
+    
+    ! LS and CONV Ice water coefficients
+    if (ice_type .eq. 0) then
+       polpart(INDX_LSICE,1:5) = polpartLSICE0
+       polpart(INDX_CVICE,1:5) = polpartCVICE0
+    endif
+    if (ice_type .eq. 1) then
+       polpart(INDX_LSICE,1:5) = polpartLSICE1
+       polpart(INDX_CVICE,1:5) = polpartCVICE1
+    endif
+    
+    ! Effective radius particles:
+    rad_part(1:npoints,1:nlev,INDX_LSLIQ)  = ls_radliq(1:npoints,1:nlev)
+    rad_part(1:npoints,1:nlev,INDX_LSICE)  = ls_radice(1:npoints,1:nlev)
+    rad_part(1:npoints,1:nlev,INDX_CVLIQ)  = cv_radliq(1:npoints,1:nlev)
+    rad_part(1:npoints,1:nlev,INDX_CVICE)  = cv_radice(1:npoints,1:nlev)    
+    rad_part(1:npoints,1:nlev,1:npart)     = MAX(rad_part(1:npoints,1:nlev,1:npart),0._wp)
+    rad_part(1:npoints,1:nlev,1:npart)     = MIN(rad_part(1:npoints,1:nlev,1:npart),70.0e-6_wp)
+    
+    ! Density (clear-sky air)
+    rhoair(1:npoints,1:nlev) = pres(1:npoints,1:nlev)/(rd*temp(1:npoints,1:nlev))
+    
+    ! Altitude at half pressure levels:
+    zheight(1:npoints,nlev+1) = 0._wp
+    do k=nlev,1,-1
+       zheight(1:npoints,k) = zheight(1:npoints,k+1) &
+            -(presf(1:npoints,k)-presf(1:npoints,k+1))/(rhoair(1:npoints,k)*grav)
+    enddo
+    
+    ! ##############################################################################
+    ! *) Molecular alpha, beta and optical thickness
+    ! ##############################################################################
+    
+    beta_mol(1:npoints,1:nlev)  = pres(1:npoints,1:nlev)/km/temp(1:npoints,1:nlev)*Cmol
+    alpha_mol(1:npoints,1:nlev) = 8._wp*pi/3._wp * beta_mol(1:npoints,1:nlev)
+    
+    ! Optical thickness of each layer (molecular)  
+    tau_mol(1:npoints,1:nlev) = alpha_mol(1:npoints,1:nlev)*(zheight(1:npoints,1:nlev)-&
+         zheight(1:npoints,2:nlev+1))
+             
+    ! Optical thickness from TOA to layer k (molecular)
+    DO k = zi,zf,zinc
+       tau_mol(1:npoints,k) = tau_mol(1:npoints,k) + tau_mol(1:npoints,k+zoffset)
+    ENDDO    
+
+    betatot    (1:npoints,1:ncolumns,1:nlev) = spread(beta_mol(1:npoints,1:nlev), dim=2, NCOPIES=ncolumns)
+    tautot     (1:npoints,1:ncolumns,1:nlev) = spread(tau_mol (1:npoints,1:nlev), dim=2, NCOPIES=ncolumns)
+    if (lphaseoptics) then
+       betatot_liq(1:npoints,1:ncolumns,1:nlev) = betatot(1:npoints,1:ncolumns,1:nlev)
+       betatot_ice(1:npoints,1:ncolumns,1:nlev) = betatot(1:npoints,1:ncolumns,1:nlev)
+       tautot_liq (1:npoints,1:ncolumns,1:nlev) = tautot(1:npoints,1:ncolumns,1:nlev)
+       tautot_ice (1:npoints,1:ncolumns,1:nlev) = tautot(1:npoints,1:ncolumns,1:nlev)      
+    endif
+
+    ! ##############################################################################
+    ! *) Particles alpha, beta and optical thickness
+    ! ##############################################################################
+    ! Polynomials kp_lidar derived from Mie theory
+    do i = 1, npart
+       where (rad_part(1:npoints,1:nlev,i) .gt. 0.0)
+          kp_part(1:npoints,1:nlev,i) = &
+               polpart(i,1)*(rad_part(1:npoints,1:nlev,i)*1e6)**4 &
+               + polpart(i,2)*(rad_part(1:npoints,1:nlev,i)*1e6)**3 &
+               + polpart(i,3)*(rad_part(1:npoints,1:nlev,i)*1e6)**2 &
+               + polpart(i,4)*(rad_part(1:npoints,1:nlev,i)*1e6) &
+               + polpart(i,5)
+       elsewhere
+          kp_part(1:npoints,1:nlev,i) = 0._wp
+       endwhere
+    enddo    
+
+    ! Initialize (if necessary)
+    if (lparasol) then
+       tautot_S_liq(1:npoints,1:ncolumns) = 0._wp
+       tautot_S_ice(1:npoints,1:ncolumns) = 0._wp
+    endif
+
+    ! Loop over all subcolumns
+    do icol=1,ncolumns
+       ! ##############################################################################
+       ! Mixing ratio particles in each subcolum
+       ! ##############################################################################
+       qpart(1:npoints,1:nlev,INDX_LSLIQ) =  q_lsliq(1:npoints,icol,1:nlev)
+       qpart(1:npoints,1:nlev,INDX_LSICE)  = q_lsice(1:npoints,icol,1:nlev)
+       qpart(1:npoints,1:nlev,INDX_CVLIQ)  = q_cvliq(1:npoints,icol,1:nlev)
+       qpart(1:npoints,1:nlev,INDX_CVICE)  = q_cvice(1:npoints,icol,1:nlev)
+
+       ! ##############################################################################
+       ! Alpha and optical thickness (particles)
+       ! ##############################################################################
+       ! Alpha of particles in each subcolumn:
+       do i = 1, npart
+          where (rad_part(1:npoints,1:nlev,i) .gt. 0.0)
+             alpha_part(1:npoints,1:nlev,i) = 3._wp/4._wp * Qscat &
+                  * rhoair(1:npoints,1:nlev) * qpart(1:npoints,1:nlev,i) &
+                  / (rhopart(i) * rad_part(1:npoints,1:nlev,i) )
+          elsewhere
+             alpha_part(1:npoints,1:nlev,i) = 0._wp
+          endwhere
+       enddo
+       
+       ! Optical thicknes
+       tau_part(1:npoints,1:nlev,1:npart) = rdiffm * alpha_part(1:npoints,1:nlev,1:npart)
+       do i = 1, npart
+          ! Optical thickness of each layer (particles)
+          tau_part(1:npoints,1:nlev,i) = tau_part(1:npoints,1:nlev,i) &
+               & * (zheight(1:npoints,1:nlev)-zheight(1:npoints,2:nlev+1) )
+          ! Optical thickness from TOA to layer k (particles)
+          do k=zi,zf,zinc
+             tau_part(1:npoints,k,i) = tau_part(1:npoints,k,i) + tau_part(1:npoints,k+zoffset,i)
+          enddo
+       enddo
+ 
+       ! ##############################################################################
+       ! Beta and optical thickness (total=molecular + particules)
+       ! ##############################################################################
+       
+       DO i = 1, npart
+          betatot(1:npoints,icol,1:nlev) = betatot(1:npoints,icol,1:nlev) + &
+               kp_part(1:npoints,1:nlev,i)*alpha_part(1:npoints,1:nlev,i)
+          tautot(1:npoints,icol,1:nlev) = tautot(1:npoints,icol,1:nlev)  + &
+              tau_part(1:npoints,1:nlev,i)
+       ENDDO
+       
+       ! ##############################################################################
+       ! Beta and optical thickness (liquid/ice)
+       ! ##############################################################################
+       if (lphaseoptics) then
+          ! Ice
+          betatot_ice(1:npoints,icol,1:nlev) = betatot_ice(1:npoints,icol,1:nlev)+ &
+               kp_part(1:npoints,1:nlev,INDX_LSICE)*alpha_part(1:npoints,1:nlev,INDX_LSICE)+ &
+               kp_part(1:npoints,1:nlev,INDX_CVICE)*alpha_part(1:npoints,1:nlev,INDX_CVICE)
+          tautot_ice(1:npoints,icol,1:nlev) = tautot_ice(1:npoints,icol,1:nlev)  + &
+               tau_part(1:npoints,1:nlev,INDX_LSICE) + &
+               tau_part(1:npoints,1:nlev,INDX_CVICE)
+          
+          ! Liquid
+          betatot_liq(1:npoints,icol,1:nlev) = betatot_liq(1:npoints,icol,1:nlev)+ &
+               kp_part(1:npoints,1:nlev,INDX_LSLIQ)*alpha_part(1:npoints,1:nlev,INDX_LSLIQ)+ &
+               kp_part(1:npoints,1:nlev,INDX_CVLIQ)*alpha_part(1:npoints,1:nlev,INDX_CVLIQ)
+          tautot_liq(1:npoints,icol,1:nlev) = tautot_liq(1:npoints,icol,1:nlev)  + &
+               tau_part(1:npoints,1:nlev,INDX_LSLIQ) + &
+               tau_part(1:npoints,1:nlev,INDX_CVLIQ)
+       endif
+
+       ! ##############################################################################    
+       ! Optical depths used by the PARASOL simulator
+       ! ##############################################################################             
+       if (lparasol) then
+          tautot_S_liq(:,icol) = tau_part(:,nlev,1)+tau_part(:,nlev,3)
+          tautot_S_ice(:,icol) = tau_part(:,nlev,2)+tau_part(:,nlev,4)              
+       endif
+    enddo
+    
+  end subroutine lidar_optics
+
+end module cosp_optics
Index: DZ6/trunk/libf/phylmd/cospv2/cosp_parasol_interface.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cospv2/cosp_parasol_interface.F90	(revision 5267)
+++ 	(revision )
@@ -1,90 +1,0 @@
-! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-! Copyright (c) 2015, Regents of the University of Colorado
-! All rights reserved.
-!
-! Redistribution and use in source and binary forms, with or without modification, are 
-! permitted provided that the following conditions are met:
-!
-! 1. Redistributions of source code must retain the above copyright notice, this list of 
-!    conditions and the following disclaimer.
-!
-! 2. Redistributions in binary form must reproduce the above copyright notice, this list
-!    of conditions and the following disclaimer in the documentation and/or other 
-!    materials provided with the distribution.
-!
-! 3. Neither the name of the copyright holder nor the names of its contributors may be 
-!    used to endorse or promote products derived from this software without specific prior
-!    written permission.
-!
-! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY 
-! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 
-! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL 
-! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 
-! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT 
-! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 
-! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
-! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-!
-! History
-! May 2015 - D. Swales - Original version
-! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-MODULE MOD_COSP_PARASOL_INTERFACE
-  USE COSP_KINDS,  ONLY: WP
-  implicit none
-
-  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-  !									TYPE cosp_parasol
-  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-  TYPE PARASOL_SGX
-     ! Dimensions
-     integer :: &
-          Npoints,  & ! Number of gridpoints
-          Ncolumns, & ! Number of columns
-          Nrefl       ! Number of parasol reflectances
-     
-     ! Arrays with dimensions (Npoints,Ncolumns,Nrefl)
-     real(wp),dimension(:,:,:),pointer :: &
-          refl        ! parasol reflectances
-
-  END TYPE PARASOL_SGX
-  TYPE PARASOL_GBX
-     integer :: &
-          Npoints,  & ! Number of gridpoints
-          Ncolumns, & ! Number of columns
-          Nrefl       ! Number of parasol reflectances
-     real(wp), dimension(:,:),pointer :: &
-          parasolrefl ! Mean parasol reflectance
-
-  END TYPE PARASOL_GBX
-  TYPE COSP_PARASOL 
-     type(PARASOL_SGX) :: PARASOL_SGX
-     type(PARASOL_GBX) :: PARASOL_GBX
-  END TYPE COSP_PARASOL
-  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-  !										TYPE parasol_in
-  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-  TYPE parasol_IN
-     integer,pointer :: &
-        Npoints,       & ! Number of horizontal gridpoints
-        Nlevels,       & ! Number of vertical levels
-        Ncolumns,      & ! Number of columns
-        Nrefl            ! Number of angles for which the reflectance is computed
-     real(wp),dimension(:,:),pointer ::   &
-        tautot_S_liq,  & ! Liquid water optical thickness, from TOA to SFC
-        tautot_S_ice     ! Ice water optical thickness, from TOA to SFC
-  END TYPE parasol_IN
-  
-contains
-
-  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-  !                           SUBROUTINE cosp_parasol_init
-  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-  SUBROUTINE COSP_PARASOL_INIT()
-    
-  end subroutine COSP_PARASOL_INIT
-
-  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-  ! 								    END MODULE
-  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-end module MOD_COSP_PARASOL_INTERFACE
Index: /LMDZ6/trunk/libf/phylmd/cospv2/cosp_parasol_interface.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cospv2/cosp_parasol_interface.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/cospv2/cosp_parasol_interface.f90	(revision 5268)
@@ -0,0 +1,90 @@
+! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+! Copyright (c) 2015, Regents of the University of Colorado
+! All rights reserved.
+!
+! Redistribution and use in source and binary forms, with or without modification, are 
+! permitted provided that the following conditions are met:
+!
+! 1. Redistributions of source code must retain the above copyright notice, this list of 
+!    conditions and the following disclaimer.
+!
+! 2. Redistributions in binary form must reproduce the above copyright notice, this list
+!    of conditions and the following disclaimer in the documentation and/or other 
+!    materials provided with the distribution.
+!
+! 3. Neither the name of the copyright holder nor the names of its contributors may be 
+!    used to endorse or promote products derived from this software without specific prior
+!    written permission.
+!
+! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY 
+! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 
+! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL 
+! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 
+! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT 
+! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 
+! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+!
+! History
+! May 2015 - D. Swales - Original version
+! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+MODULE MOD_COSP_PARASOL_INTERFACE
+  USE COSP_KINDS,  ONLY: WP
+  implicit none
+
+  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  !									TYPE cosp_parasol
+  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  TYPE PARASOL_SGX
+     ! Dimensions
+     integer :: &
+          Npoints,  & ! Number of gridpoints
+          Ncolumns, & ! Number of columns
+          Nrefl       ! Number of parasol reflectances
+     
+     ! Arrays with dimensions (Npoints,Ncolumns,Nrefl)
+     real(wp),dimension(:,:,:),pointer :: &
+          refl        ! parasol reflectances
+
+  END TYPE PARASOL_SGX
+  TYPE PARASOL_GBX
+     integer :: &
+          Npoints,  & ! Number of gridpoints
+          Ncolumns, & ! Number of columns
+          Nrefl       ! Number of parasol reflectances
+     real(wp), dimension(:,:),pointer :: &
+          parasolrefl ! Mean parasol reflectance
+
+  END TYPE PARASOL_GBX
+  TYPE COSP_PARASOL 
+     type(PARASOL_SGX) :: PARASOL_SGX
+     type(PARASOL_GBX) :: PARASOL_GBX
+  END TYPE COSP_PARASOL
+  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  !										TYPE parasol_in
+  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  TYPE parasol_IN
+     integer,pointer :: &
+        Npoints,       & ! Number of horizontal gridpoints
+        Nlevels,       & ! Number of vertical levels
+        Ncolumns,      & ! Number of columns
+        Nrefl            ! Number of angles for which the reflectance is computed
+     real(wp),dimension(:,:),pointer ::   &
+        tautot_S_liq,  & ! Liquid water optical thickness, from TOA to SFC
+        tautot_S_ice     ! Ice water optical thickness, from TOA to SFC
+  END TYPE parasol_IN
+  
+contains
+
+  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  !                           SUBROUTINE cosp_parasol_init
+  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  SUBROUTINE COSP_PARASOL_INIT()
+    
+  end subroutine COSP_PARASOL_INIT
+
+  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  ! 								    END MODULE
+  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+end module MOD_COSP_PARASOL_INTERFACE
Index: DZ6/trunk/libf/phylmd/cospv2/cosp_phys_constants.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cospv2/cosp_phys_constants.F90	(revision 5267)
+++ 	(revision )
@@ -1,65 +1,0 @@
-! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-! Copyright (c) 2015, Regents of the University of Colorado
-! All rights reserved.
-!
-! Redistribution and use in source and binary forms, with or without modification, are
-! permitted provided that the following conditions are met:
-!
-! 1. Redistributions of source code must retain the above copyright notice, this list of
-!    conditions and the following disclaimer.
-!
-! 2. Redistributions in binary form must reproduce the above copyright notice, this list
-!    of conditions and the following disclaimer in the documentation and/or other
-!    materials provided with the distribution.
-!
-! 3. Neither the name of the copyright holder nor the names of its contributors may be
-!    used to endorse or promote products derived from this software without specific prior
-!    written permission.
-!
-! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY
-! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
-! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL
-! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT
-! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
-! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
-! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-!
-! History:
-! May 2015- D. Swales - Original version
-!
-! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-MODULE cosp_phys_constants
-  USE cosp_kinds, only: wp
-  IMPLICIT NONE
-
-  REAL(wp), PARAMETER :: &
-       tmelt  = 273.15_wp,      & ! Melting temperature of ice/snow [K]
-       rhoice = 917._wp,        & ! Density of ice [kg/m3]
-       rholiq = 1000._wp          ! Density of liquid water [kg/m3]
-
-  ! Molecular weights
-  REAL(wp), PARAMETER :: &
-       amw   = 18.01534_wp,     & ! Water   [g/mol]
-       amd   = 28.9644_wp,      & ! Dry air [g/mol]
-       amO3  = 47.9983_wp,      & ! Ozone   [g/mol]
-       amCO2 = 44.0096_wp,      & ! CO2     [g/mol]
-       amCH4 = 16.0426_wp,      & ! Methane [g/mol]
-       amN2O = 44.0129_wp,      & ! N2O     [g/mol]
-       amCO  = 28.0102_wp         ! CO      [g/mol]
-
-  ! WMO/SI value
-  REAL(wp), PARAMETER :: &
-       avo   = 6.023E23_wp,     & ! Avogadro constant used by ISCCP simulator [1/mol]
-       grav  = 9.806650_wp        ! Av. gravitational acceleration used by ISCCP simulator [m/s2]
-
-  ! Thermodynamic constants for the dry and moist atmosphere
-  REAL(wp), PARAMETER :: &
-       rd  = 287.04_wp,         & ! Gas constant for dry air [J/K/Kg]
-       cpd = 1004.64_wp,        & ! Specific heat at constant pressure for dry air [J/K/Kg]
-       rv  = 461.51_wp,         & ! Gas constant for water vapor [J/K/Kg]
-       cpv = 1869.46_wp,        & ! Specific heat at constant pressure for water vapor [J/K/Kg]
-       km  = 1.38e-23_wp          ! Boltzmann constant [J/K]
-
-END MODULE cosp_phys_constants
Index: /LMDZ6/trunk/libf/phylmd/cospv2/cosp_phys_constants.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cospv2/cosp_phys_constants.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/cospv2/cosp_phys_constants.f90	(revision 5268)
@@ -0,0 +1,65 @@
+! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+! Copyright (c) 2015, Regents of the University of Colorado
+! All rights reserved.
+!
+! Redistribution and use in source and binary forms, with or without modification, are
+! permitted provided that the following conditions are met:
+!
+! 1. Redistributions of source code must retain the above copyright notice, this list of
+!    conditions and the following disclaimer.
+!
+! 2. Redistributions in binary form must reproduce the above copyright notice, this list
+!    of conditions and the following disclaimer in the documentation and/or other
+!    materials provided with the distribution.
+!
+! 3. Neither the name of the copyright holder nor the names of its contributors may be
+!    used to endorse or promote products derived from this software without specific prior
+!    written permission.
+!
+! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY
+! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
+! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL
+! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT
+! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+!
+! History:
+! May 2015- D. Swales - Original version
+!
+! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+MODULE cosp_phys_constants
+  USE cosp_kinds, only: wp
+  IMPLICIT NONE
+
+  REAL(wp), PARAMETER :: &
+       tmelt  = 273.15_wp,      & ! Melting temperature of ice/snow [K]
+       rhoice = 917._wp,        & ! Density of ice [kg/m3]
+       rholiq = 1000._wp          ! Density of liquid water [kg/m3]
+
+  ! Molecular weights
+  REAL(wp), PARAMETER :: &
+       amw   = 18.01534_wp,     & ! Water   [g/mol]
+       amd   = 28.9644_wp,      & ! Dry air [g/mol]
+       amO3  = 47.9983_wp,      & ! Ozone   [g/mol]
+       amCO2 = 44.0096_wp,      & ! CO2     [g/mol]
+       amCH4 = 16.0426_wp,      & ! Methane [g/mol]
+       amN2O = 44.0129_wp,      & ! N2O     [g/mol]
+       amCO  = 28.0102_wp         ! CO      [g/mol]
+
+  ! WMO/SI value
+  REAL(wp), PARAMETER :: &
+       avo   = 6.023E23_wp,     & ! Avogadro constant used by ISCCP simulator [1/mol]
+       grav  = 9.806650_wp        ! Av. gravitational acceleration used by ISCCP simulator [m/s2]
+
+  ! Thermodynamic constants for the dry and moist atmosphere
+  REAL(wp), PARAMETER :: &
+       rd  = 287.04_wp,         & ! Gas constant for dry air [J/K/Kg]
+       cpd = 1004.64_wp,        & ! Specific heat at constant pressure for dry air [J/K/Kg]
+       rv  = 461.51_wp,         & ! Gas constant for water vapor [J/K/Kg]
+       cpv = 1869.46_wp,        & ! Specific heat at constant pressure for water vapor [J/K/Kg]
+       km  = 1.38e-23_wp          ! Boltzmann constant [J/K]
+
+END MODULE cosp_phys_constants
Index: DZ6/trunk/libf/phylmd/cospv2/cosp_stats.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cospv2/cosp_stats.F90	(revision 5267)
+++ 	(revision )
@@ -1,307 +1,0 @@
-! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-! Copyright (c) 2015, Regents of the University of Colorado
-! All rights reserved.
-!
-! Redistribution and use in source and binary forms, with or without modification, are 
-! permitted provided that the following conditions are met:
-!
-! 1. Redistributions of source code must retain the above copyright notice, this list of 
-!    conditions and the following disclaimer.
-!
-! 2. Redistributions in binary form must reproduce the above copyright notice, this list
-!    of conditions and the following disclaimer in the documentation and/or other 
-!    materials provided with the distribution.
-!
-! 3. Neither the name of the copyright holder nor the names of its contributors may be 
-!    used to endorse or promote products derived from this software without specific prior
-!    written permission.
-!
-! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY 
-! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 
-! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL 
-! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 
-! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT 
-! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 
-! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
-! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-!
-! History:
-! Jul 2007 - A. Bodas-Salcedo - Initial version
-! Jul 2008 - A. Bodas-Salcedo - Added capability of producing outputs in standard grid
-! Oct 2008 - J.-L. Dufresne   - Bug fixed. Assignment of Npoints,Nlevels,Nhydro,Ncolumns 
-!                               in COSP_STATS
-! Oct 2008 - H. Chepfer       - Added PARASOL reflectance arguments
-! Jun 2010 - T. Yokohata, T. Nishimura and K. Ogochi - Added NEC SXs optimisations
-! Jan 2013 - G. Cesana        - Added betaperp and temperature arguments 
-!                             - Added phase 3D/3Dtemperature/Map output variables in diag_lidar 
-! May 2015 - D. Swales        - Modified for cosp2.0 
-! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-MODULE MOD_COSP_STATS
-  USE COSP_KINDS, ONLY: wp
-  USE MOD_COSP_CONFIG, ONLY: R_UNDEF,R_GROUND
-
-  IMPLICIT NONE
-CONTAINS
-
-  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-  !---------- SUBROUTINE COSP_CHANGE_VERTICAL_GRID ----------------
-  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-SUBROUTINE COSP_CHANGE_VERTICAL_GRID(Npoints,Ncolumns,Nlevels,zfull,zhalf,y,Nglevels,newgrid_bot,newgrid_top,r,log_units)
-   implicit none
-   ! Input arguments
-   integer,intent(in) :: Npoints  !# of grid points
-   integer,intent(in) :: Nlevels  !# of levels
-   integer,intent(in) :: Ncolumns !# of columns
-   real(wp),dimension(Npoints,Nlevels),intent(in) :: zfull ! Height at model levels [m] (Bottom of model layer)
-   real(wp),dimension(Npoints,Nlevels),intent(in) :: zhalf ! Height at half model levels [m] (Bottom of model layer)
-   real(wp),dimension(Npoints,Ncolumns,Nlevels),intent(in) :: y     ! Variable to be changed to a different grid
-   integer,intent(in) :: Nglevels  !# levels in the new grid
-   real(wp),dimension(Nglevels),intent(in) :: newgrid_bot ! Lower boundary of new levels  [m]
-   real(wp),dimension(Nglevels),intent(in) :: newgrid_top ! Upper boundary of new levels  [m]
-   logical,optional,intent(in) :: log_units ! log units, need to convert to linear units
-   ! Output
-   real(wp),dimension(Npoints,Ncolumns,Nglevels),intent(out) :: r ! Variable on new grid
-
-   ! Local variables
-   integer :: i,j,k
-   logical :: lunits
-   integer :: l
-   real(wp) :: w ! Weight
-   real(wp) :: dbb, dtb, dbt, dtt ! Distances between edges of both grids
-   integer :: Nw  ! Number of weights
-   real(wp) :: wt  ! Sum of weights
-   real(wp),dimension(Nlevels) :: oldgrid_bot,oldgrid_top ! Lower and upper boundaries of model grid
-   real(wp) :: yp ! Local copy of y at a particular point.
-              ! This allows for change of units.
-
-   lunits=.false.
-   if (present(log_units)) lunits=log_units
-
-   r = 0._wp
-
-   do i=1,Npoints
-     ! Calculate tops and bottoms of new and old grids
-     oldgrid_bot = zhalf(i,:)
-     oldgrid_top(1:Nlevels-1) = oldgrid_bot(2:Nlevels)
-     oldgrid_top(Nlevels) = zfull(i,Nlevels) +  zfull(i,Nlevels) - zhalf(i,Nlevels) ! Top level symmetric
-     l = 0 ! Index of level in the old grid
-     ! Loop over levels in the new grid
-     do k = 1,Nglevels
-       Nw = 0 ! Number of weigths
-       wt = 0._wp ! Sum of weights
-       ! Loop over levels in the old grid and accumulate total for weighted average
-       do
-         l = l + 1
-         w = 0.0 ! Initialise weight to 0
-         ! Distances between edges of both grids
-         dbb = oldgrid_bot(l) - newgrid_bot(k)
-         dtb = oldgrid_top(l) - newgrid_bot(k)
-         dbt = oldgrid_bot(l) - newgrid_top(k)
-         dtt = oldgrid_top(l) - newgrid_top(k)
-         if (dbt >= 0.0) exit ! Do next level in the new grid
-         if (dtb > 0.0) then
-           if (dbb <= 0.0) then
-             if (dtt <= 0) then
-               w = dtb
-             else
-               w = newgrid_top(k) - newgrid_bot(k)
-             endif
-           else
-             if (dtt <= 0) then
-               w = oldgrid_top(l) - oldgrid_bot(l)
-             else
-               w = -dbt
-             endif
-           endif
-           ! If layers overlap (w/=0), then accumulate
-           if (w /= 0.0) then
-             Nw = Nw + 1
-             wt = wt + w
-             do j=1,Ncolumns
-               if (lunits) then
-                 if (y(i,j,l) /= R_UNDEF) then
-                   yp = 10._wp**(y(i,j,l)/10._wp)
-                 else
-                   yp = 0._wp
-                 endif
-               else
-                 yp = y(i,j,l)
-               endif
-               r(i,j,k) = r(i,j,k) + w*yp
-             enddo
-           endif
-         endif
-       enddo
-       l = l - 2
-       if (l < 1) l = 0
-       ! Calculate average in new grid
-       if (Nw > 0) then
-         do j=1,Ncolumns
-           r(i,j,k) = r(i,j,k)/wt
-         enddo
-       endif
-     enddo
-   enddo
-
-   ! Set points under surface to R_UNDEF, and change to dBZ if necessary
-   do k=1,Nglevels
-     do j=1,Ncolumns
-       do i=1,Npoints
-         if (newgrid_top(k) > zhalf(i,1)) then ! Level above model bottom level
-           if (lunits) then
-             if (r(i,j,k) <= 0.0) then
-               r(i,j,k) = R_UNDEF
-             else
-               r(i,j,k) = 10._wp*log10(r(i,j,k))
-             endif
-           endif
-         else ! Level below surface
-           r(i,j,k) = R_GROUND
-         endif
-       enddo
-     enddo
-   enddo
-
-END SUBROUTINE COSP_CHANGE_VERTICAL_GRID
-
-  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-  !------------- SUBROUTINE COSP_LIDAR_ONLY_CLOUD -----------------
-  ! (c) 2008, Lawrence Livermore National Security Limited Liability Corporation.
-  ! All rights reserved.
-  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-  SUBROUTINE COSP_LIDAR_ONLY_CLOUD(Npoints, Ncolumns, Nlevels, beta_tot, beta_mol,       &
-     Ze_tot, lidar_only_freq_cloud, tcc, radar_tcc, radar_tcc2)
-    ! Inputs
-    integer,intent(in) :: &
-         Npoints,       & ! Number of horizontal gridpoints
-         Ncolumns,      & ! Number of subcolumns
-         Nlevels          ! Number of vertical layers
-    real(wp),dimension(Npoints,Nlevels),intent(in) :: &
-         beta_mol         ! Molecular backscatter
-    real(wp),dimension(Npoints,Ncolumns,Nlevels),intent(in) :: &
-         beta_tot,      & ! Total backscattered signal
-         Ze_tot           ! Radar reflectivity
-    ! Outputs
-    real(wp),dimension(Npoints,Nlevels),intent(out) :: &
-         lidar_only_freq_cloud
-    real(wp),dimension(Npoints),intent(out) ::&
-         tcc,       & !
-         radar_tcc, & !
-         radar_tcc2   !
-    
-    ! local variables
-    real(wp) :: sc_ratio
-    real(wp),parameter :: &
-         s_cld=5.0, &
-         s_att=0.01
-    integer :: flag_sat,flag_cld,pr,i,j,flag_radarcld,flag_radarcld_no1km,j_1km
-    
-    lidar_only_freq_cloud = 0._wp
-    tcc = 0._wp
-    radar_tcc = 0._wp
-    radar_tcc2 = 0._wp
-    do pr=1,Npoints
-       do i=1,Ncolumns
-          flag_sat = 0
-          flag_cld = 0
-          flag_radarcld = 0 !+JEK
-          flag_radarcld_no1km=0 !+JEK
-          ! look for j_1km from bottom to top
-          j = 1
-          do while (Ze_tot(pr,i,j) .eq. R_GROUND)
-             j = j+1
-          enddo
-          j_1km = j+1  !this is the vertical index of 1km above surface  
-          
-          do j=1,Nlevels
-             sc_ratio = beta_tot(pr,i,j)/beta_mol(pr,j)
-             if ((sc_ratio .le. s_att) .and. (flag_sat .eq. 0)) flag_sat = j
-             if (Ze_tot(pr,i,j) .lt. -30.) then  !radar can't detect cloud
-                if ( (sc_ratio .gt. s_cld) .or. (flag_sat .eq. j) ) then  !lidar sense cloud
-                   lidar_only_freq_cloud(pr,j)=lidar_only_freq_cloud(pr,j)+1. !top->surf
-                   flag_cld=1
-                endif
-             else  !radar sense cloud (z%Ze_tot(pr,i,j) .ge. -30.)
-                flag_cld=1
-                flag_radarcld=1
-                if (j .gt. j_1km) flag_radarcld_no1km=1              
-             endif
-          enddo !levels
-          if (flag_cld .eq. 1) tcc(pr)=tcc(pr)+1._wp
-          if (flag_radarcld .eq. 1) radar_tcc(pr)=radar_tcc(pr)+1.
-          if (flag_radarcld_no1km .eq. 1) radar_tcc2(pr)=radar_tcc2(pr)+1.        
-       enddo !columns
-    enddo !points
-    lidar_only_freq_cloud=lidar_only_freq_cloud/Ncolumns
-    tcc=tcc/Ncolumns
-    radar_tcc=radar_tcc/Ncolumns
-    radar_tcc2=radar_tcc2/Ncolumns
-    
-    ! Unit conversion
-    where(lidar_only_freq_cloud /= R_UNDEF) &
-            lidar_only_freq_cloud = lidar_only_freq_cloud*100._wp
-    where(tcc /= R_UNDEF) tcc = tcc*100._wp
-    where(radar_tcc /= R_UNDEF) radar_tcc = radar_tcc*100._wp
-    where(radar_tcc2 /= R_UNDEF) radar_tcc2 = radar_tcc2*100._wp
-    
-  END SUBROUTINE COSP_LIDAR_ONLY_CLOUD
-  
-  ! ######################################################################################
-  ! FUNCTION hist1D
-  ! ######################################################################################
-  function hist1d(Npoints,var,nbins,bins)
-    ! Inputs
-    integer,intent(in) :: &
-         Npoints, & ! Number of points in input array
-         Nbins      ! Number of bins for sorting
-    real(wp),intent(in),dimension(Npoints) :: &
-         var        ! Input variable to be sorted
-    real(wp),intent(in),dimension(Nbins+1) :: &
-         bins       ! Histogram bins [lowest,binTops]  
-    ! Outputs
-    real(wp),dimension(Nbins) :: &
-         hist1d     ! Output histogram      
-    ! Local variables
-    integer :: ij
-    
-    do ij=2,Nbins+1  
-       hist1D(ij-1) = count(var .ge. bins(ij-1) .and. var .lt. bins(ij))
-       if (count(var .eq. R_GROUND) .ge. 1) hist1D(ij-1)=R_UNDEF
-    enddo
-    
-  end function hist1D
-  
-  ! ######################################################################################
-  ! SUBROUTINE hist2D
-  ! ######################################################################################
-  subroutine hist2D(var1,var2,npts,bin1,nbin1,bin2,nbin2,jointHist)
-    implicit none
-    
-    ! INPUTS
-    integer, intent(in) :: &
-         npts,  & ! Number of data points to be sorted
-         nbin1, & ! Number of bins in histogram direction 1 
-         nbin2    ! Number of bins in histogram direction 2
-    real(wp),intent(in),dimension(npts) :: &
-         var1,  & ! Variable 1 to be sorted into bins
-         var2     ! variable 2 to be sorted into bins
-    real(wp),intent(in),dimension(nbin1+1) :: &
-         bin1     ! Histogram bin 1 boundaries
-    real(wp),intent(in),dimension(nbin2+1) :: &
-         bin2     ! Histogram bin 2 boundaries
-    ! OUTPUTS
-    real(wp),intent(out),dimension(nbin1,nbin2) :: &
-         jointHist
-    
-    ! LOCAL VARIABLES
-    integer :: ij,ik
-    
-    do ij=2,nbin1+1
-       do ik=2,nbin2+1
-          jointHist(ij-1,ik-1)=count(var1 .ge. bin1(ij-1) .and. var1 .lt. bin1(ij) .and. &
-               var2 .ge. bin2(ik-1) .and. var2 .lt. bin2(ik))        
-       enddo
-    enddo
-  end subroutine hist2D
-END MODULE MOD_COSP_STATS
Index: /LMDZ6/trunk/libf/phylmd/cospv2/cosp_stats.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cospv2/cosp_stats.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/cospv2/cosp_stats.f90	(revision 5268)
@@ -0,0 +1,307 @@
+! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+! Copyright (c) 2015, Regents of the University of Colorado
+! All rights reserved.
+!
+! Redistribution and use in source and binary forms, with or without modification, are 
+! permitted provided that the following conditions are met:
+!
+! 1. Redistributions of source code must retain the above copyright notice, this list of 
+!    conditions and the following disclaimer.
+!
+! 2. Redistributions in binary form must reproduce the above copyright notice, this list
+!    of conditions and the following disclaimer in the documentation and/or other 
+!    materials provided with the distribution.
+!
+! 3. Neither the name of the copyright holder nor the names of its contributors may be 
+!    used to endorse or promote products derived from this software without specific prior
+!    written permission.
+!
+! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY 
+! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 
+! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL 
+! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 
+! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT 
+! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 
+! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+!
+! History:
+! Jul 2007 - A. Bodas-Salcedo - Initial version
+! Jul 2008 - A. Bodas-Salcedo - Added capability of producing outputs in standard grid
+! Oct 2008 - J.-L. Dufresne   - Bug fixed. Assignment of Npoints,Nlevels,Nhydro,Ncolumns 
+!                               in COSP_STATS
+! Oct 2008 - H. Chepfer       - Added PARASOL reflectance arguments
+! Jun 2010 - T. Yokohata, T. Nishimura and K. Ogochi - Added NEC SXs optimisations
+! Jan 2013 - G. Cesana        - Added betaperp and temperature arguments 
+!                             - Added phase 3D/3Dtemperature/Map output variables in diag_lidar 
+! May 2015 - D. Swales        - Modified for cosp2.0 
+! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+MODULE MOD_COSP_STATS
+  USE COSP_KINDS, ONLY: wp
+  USE MOD_COSP_CONFIG, ONLY: R_UNDEF,R_GROUND
+
+  IMPLICIT NONE
+CONTAINS
+
+  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  !---------- SUBROUTINE COSP_CHANGE_VERTICAL_GRID ----------------
+  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+SUBROUTINE COSP_CHANGE_VERTICAL_GRID(Npoints,Ncolumns,Nlevels,zfull,zhalf,y,Nglevels,newgrid_bot,newgrid_top,r,log_units)
+   implicit none
+   ! Input arguments
+   integer,intent(in) :: Npoints  !# of grid points
+   integer,intent(in) :: Nlevels  !# of levels
+   integer,intent(in) :: Ncolumns !# of columns
+   real(wp),dimension(Npoints,Nlevels),intent(in) :: zfull ! Height at model levels [m] (Bottom of model layer)
+   real(wp),dimension(Npoints,Nlevels),intent(in) :: zhalf ! Height at half model levels [m] (Bottom of model layer)
+   real(wp),dimension(Npoints,Ncolumns,Nlevels),intent(in) :: y     ! Variable to be changed to a different grid
+   integer,intent(in) :: Nglevels  !# levels in the new grid
+   real(wp),dimension(Nglevels),intent(in) :: newgrid_bot ! Lower boundary of new levels  [m]
+   real(wp),dimension(Nglevels),intent(in) :: newgrid_top ! Upper boundary of new levels  [m]
+   logical,optional,intent(in) :: log_units ! log units, need to convert to linear units
+   ! Output
+   real(wp),dimension(Npoints,Ncolumns,Nglevels),intent(out) :: r ! Variable on new grid
+
+   ! Local variables
+   integer :: i,j,k
+   logical :: lunits
+   integer :: l
+   real(wp) :: w ! Weight
+   real(wp) :: dbb, dtb, dbt, dtt ! Distances between edges of both grids
+   integer :: Nw  ! Number of weights
+   real(wp) :: wt  ! Sum of weights
+   real(wp),dimension(Nlevels) :: oldgrid_bot,oldgrid_top ! Lower and upper boundaries of model grid
+   real(wp) :: yp ! Local copy of y at a particular point.
+              ! This allows for change of units.
+
+   lunits=.false.
+   if (present(log_units)) lunits=log_units
+
+   r = 0._wp
+
+   do i=1,Npoints
+     ! Calculate tops and bottoms of new and old grids
+     oldgrid_bot = zhalf(i,:)
+     oldgrid_top(1:Nlevels-1) = oldgrid_bot(2:Nlevels)
+     oldgrid_top(Nlevels) = zfull(i,Nlevels) +  zfull(i,Nlevels) - zhalf(i,Nlevels) ! Top level symmetric
+     l = 0 ! Index of level in the old grid
+     ! Loop over levels in the new grid
+     do k = 1,Nglevels
+       Nw = 0 ! Number of weigths
+       wt = 0._wp ! Sum of weights
+       ! Loop over levels in the old grid and accumulate total for weighted average
+       do
+         l = l + 1
+         w = 0.0 ! Initialise weight to 0
+         ! Distances between edges of both grids
+         dbb = oldgrid_bot(l) - newgrid_bot(k)
+         dtb = oldgrid_top(l) - newgrid_bot(k)
+         dbt = oldgrid_bot(l) - newgrid_top(k)
+         dtt = oldgrid_top(l) - newgrid_top(k)
+         if (dbt >= 0.0) exit ! Do next level in the new grid
+         if (dtb > 0.0) then
+           if (dbb <= 0.0) then
+             if (dtt <= 0) then
+               w = dtb
+             else
+               w = newgrid_top(k) - newgrid_bot(k)
+             endif
+           else
+             if (dtt <= 0) then
+               w = oldgrid_top(l) - oldgrid_bot(l)
+             else
+               w = -dbt
+             endif
+           endif
+           ! If layers overlap (w/=0), then accumulate
+           if (w /= 0.0) then
+             Nw = Nw + 1
+             wt = wt + w
+             do j=1,Ncolumns
+               if (lunits) then
+                 if (y(i,j,l) /= R_UNDEF) then
+                   yp = 10._wp**(y(i,j,l)/10._wp)
+                 else
+                   yp = 0._wp
+                 endif
+               else
+                 yp = y(i,j,l)
+               endif
+               r(i,j,k) = r(i,j,k) + w*yp
+             enddo
+           endif
+         endif
+       enddo
+       l = l - 2
+       if (l < 1) l = 0
+       ! Calculate average in new grid
+       if (Nw > 0) then
+         do j=1,Ncolumns
+           r(i,j,k) = r(i,j,k)/wt
+         enddo
+       endif
+     enddo
+   enddo
+
+   ! Set points under surface to R_UNDEF, and change to dBZ if necessary
+   do k=1,Nglevels
+     do j=1,Ncolumns
+       do i=1,Npoints
+         if (newgrid_top(k) > zhalf(i,1)) then ! Level above model bottom level
+           if (lunits) then
+             if (r(i,j,k) <= 0.0) then
+               r(i,j,k) = R_UNDEF
+             else
+               r(i,j,k) = 10._wp*log10(r(i,j,k))
+             endif
+           endif
+         else ! Level below surface
+           r(i,j,k) = R_GROUND
+         endif
+       enddo
+     enddo
+   enddo
+
+END SUBROUTINE COSP_CHANGE_VERTICAL_GRID
+
+  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  !------------- SUBROUTINE COSP_LIDAR_ONLY_CLOUD -----------------
+  ! (c) 2008, Lawrence Livermore National Security Limited Liability Corporation.
+  ! All rights reserved.
+  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  SUBROUTINE COSP_LIDAR_ONLY_CLOUD(Npoints, Ncolumns, Nlevels, beta_tot, beta_mol,       &
+     Ze_tot, lidar_only_freq_cloud, tcc, radar_tcc, radar_tcc2)
+    ! Inputs
+    integer,intent(in) :: &
+         Npoints,       & ! Number of horizontal gridpoints
+         Ncolumns,      & ! Number of subcolumns
+         Nlevels          ! Number of vertical layers
+    real(wp),dimension(Npoints,Nlevels),intent(in) :: &
+         beta_mol         ! Molecular backscatter
+    real(wp),dimension(Npoints,Ncolumns,Nlevels),intent(in) :: &
+         beta_tot,      & ! Total backscattered signal
+         Ze_tot           ! Radar reflectivity
+    ! Outputs
+    real(wp),dimension(Npoints,Nlevels),intent(out) :: &
+         lidar_only_freq_cloud
+    real(wp),dimension(Npoints),intent(out) ::&
+         tcc,       & !
+         radar_tcc, & !
+         radar_tcc2   !
+    
+    ! local variables
+    real(wp) :: sc_ratio
+    real(wp),parameter :: &
+         s_cld=5.0, &
+         s_att=0.01
+    integer :: flag_sat,flag_cld,pr,i,j,flag_radarcld,flag_radarcld_no1km,j_1km
+    
+    lidar_only_freq_cloud = 0._wp
+    tcc = 0._wp
+    radar_tcc = 0._wp
+    radar_tcc2 = 0._wp
+    do pr=1,Npoints
+       do i=1,Ncolumns
+          flag_sat = 0
+          flag_cld = 0
+          flag_radarcld = 0 !+JEK
+          flag_radarcld_no1km=0 !+JEK
+          ! look for j_1km from bottom to top
+          j = 1
+          do while (Ze_tot(pr,i,j) .eq. R_GROUND)
+             j = j+1
+          enddo
+          j_1km = j+1  !this is the vertical index of 1km above surface  
+          
+          do j=1,Nlevels
+             sc_ratio = beta_tot(pr,i,j)/beta_mol(pr,j)
+             if ((sc_ratio .le. s_att) .and. (flag_sat .eq. 0)) flag_sat = j
+             if (Ze_tot(pr,i,j) .lt. -30.) then  !radar can't detect cloud
+                if ( (sc_ratio .gt. s_cld) .or. (flag_sat .eq. j) ) then  !lidar sense cloud
+                   lidar_only_freq_cloud(pr,j)=lidar_only_freq_cloud(pr,j)+1. !top->surf
+                   flag_cld=1
+                endif
+             else  !radar sense cloud (z%Ze_tot(pr,i,j) .ge. -30.)
+                flag_cld=1
+                flag_radarcld=1
+                if (j .gt. j_1km) flag_radarcld_no1km=1              
+             endif
+          enddo !levels
+          if (flag_cld .eq. 1) tcc(pr)=tcc(pr)+1._wp
+          if (flag_radarcld .eq. 1) radar_tcc(pr)=radar_tcc(pr)+1.
+          if (flag_radarcld_no1km .eq. 1) radar_tcc2(pr)=radar_tcc2(pr)+1.        
+       enddo !columns
+    enddo !points
+    lidar_only_freq_cloud=lidar_only_freq_cloud/Ncolumns
+    tcc=tcc/Ncolumns
+    radar_tcc=radar_tcc/Ncolumns
+    radar_tcc2=radar_tcc2/Ncolumns
+    
+    ! Unit conversion
+    where(lidar_only_freq_cloud /= R_UNDEF) &
+            lidar_only_freq_cloud = lidar_only_freq_cloud*100._wp
+    where(tcc /= R_UNDEF) tcc = tcc*100._wp
+    where(radar_tcc /= R_UNDEF) radar_tcc = radar_tcc*100._wp
+    where(radar_tcc2 /= R_UNDEF) radar_tcc2 = radar_tcc2*100._wp
+    
+  END SUBROUTINE COSP_LIDAR_ONLY_CLOUD
+  
+  ! ######################################################################################
+  ! FUNCTION hist1D
+  ! ######################################################################################
+  function hist1d(Npoints,var,nbins,bins)
+    ! Inputs
+    integer,intent(in) :: &
+         Npoints, & ! Number of points in input array
+         Nbins      ! Number of bins for sorting
+    real(wp),intent(in),dimension(Npoints) :: &
+         var        ! Input variable to be sorted
+    real(wp),intent(in),dimension(Nbins+1) :: &
+         bins       ! Histogram bins [lowest,binTops]  
+    ! Outputs
+    real(wp),dimension(Nbins) :: &
+         hist1d     ! Output histogram      
+    ! Local variables
+    integer :: ij
+    
+    do ij=2,Nbins+1  
+       hist1D(ij-1) = count(var .ge. bins(ij-1) .and. var .lt. bins(ij))
+       if (count(var .eq. R_GROUND) .ge. 1) hist1D(ij-1)=R_UNDEF
+    enddo
+    
+  end function hist1D
+  
+  ! ######################################################################################
+  ! SUBROUTINE hist2D
+  ! ######################################################################################
+  subroutine hist2D(var1,var2,npts,bin1,nbin1,bin2,nbin2,jointHist)
+    implicit none
+    
+    ! INPUTS
+    integer, intent(in) :: &
+         npts,  & ! Number of data points to be sorted
+         nbin1, & ! Number of bins in histogram direction 1 
+         nbin2    ! Number of bins in histogram direction 2
+    real(wp),intent(in),dimension(npts) :: &
+         var1,  & ! Variable 1 to be sorted into bins
+         var2     ! variable 2 to be sorted into bins
+    real(wp),intent(in),dimension(nbin1+1) :: &
+         bin1     ! Histogram bin 1 boundaries
+    real(wp),intent(in),dimension(nbin2+1) :: &
+         bin2     ! Histogram bin 2 boundaries
+    ! OUTPUTS
+    real(wp),intent(out),dimension(nbin1,nbin2) :: &
+         jointHist
+    
+    ! LOCAL VARIABLES
+    integer :: ij,ik
+    
+    do ij=2,nbin1+1
+       do ik=2,nbin2+1
+          jointHist(ij-1,ik-1)=count(var1 .ge. bin1(ij-1) .and. var1 .lt. bin1(ij) .and. &
+               var2 .ge. bin2(ik-1) .and. var2 .lt. bin2(ik))        
+       enddo
+    enddo
+  end subroutine hist2D
+END MODULE MOD_COSP_STATS
Index: DZ6/trunk/libf/phylmd/cospv2/cosp_utils.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cospv2/cosp_utils.F90	(revision 5267)
+++ 	(revision )
@@ -1,105 +1,0 @@
-! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-! Copyright (c) 2015, Regents of the University of Colorado
-! All rights reserved.
-!
-! Redistribution and use in source and binary forms, with or without modification, are 
-! permitted provided that the following conditions are met:
-!
-! 1. Redistributions of source code must retain the above copyright notice, this list of 
-!    conditions and the following disclaimer.
-!
-! 2. Redistributions in binary form must reproduce the above copyright notice, this list
-!    of conditions and the following disclaimer in the documentation and/or other 
-!    materials provided with the distribution.
-!
-! 3. Neither the name of the copyright holder nor the names of its contributors may be 
-!    used to endorse or promote products derived from this software without specific prior
-!    written permission.
-!
-! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY 
-! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 
-! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL 
-! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 
-! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT 
-! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 
-! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
-! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-!
-! History:
-! Jul 2007 - A. Bodas-Salcedo - Initial version
-! May 2015 - Dustin Swales    - Modified for COSPv2.0
-! 
-! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-MODULE MOD_COSP_UTILS
-  USE COSP_KINDS, ONLY: wp
-  USE MOD_COSP_CONFIG
-  IMPLICIT NONE
-
-CONTAINS
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-!------------------- SUBROUTINE COSP_PRECIP_MXRATIO --------------
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-SUBROUTINE COSP_PRECIP_MXRATIO(Npoints,Nlevels,Ncolumns,p,T,prec_frac,prec_type, &
-                          n_ax,n_bx,alpha_x,c_x,d_x,g_x,a_x,b_x,gamma1,gamma2,gamma3,gamma4, &
-                          flux,mxratio,reff)
-
-    ! Input arguments, (IN)
-    integer,intent(in) :: Npoints,Nlevels,Ncolumns
-    real(wp),intent(in),dimension(Npoints,Nlevels) :: p,T,flux
-    real(wp),intent(in),dimension(Npoints,Ncolumns,Nlevels) :: prec_frac
-    real(wp),intent(in) :: n_ax,n_bx,alpha_x,c_x,d_x,g_x,a_x,b_x,gamma1,gamma2,gamma3,gamma4,prec_type
-    ! Input arguments, (OUT)
-    real(wp),intent(out),dimension(Npoints,Ncolumns,Nlevels) :: mxratio
-    real(wp),intent(inout),dimension(Npoints,Ncolumns,Nlevels) :: reff
-    ! Local variables
-    integer :: i,j,k
-    real(wp) :: sigma,one_over_xip1,xi,rho0,rho,lambda_x,gamma_4_3_2,delta
-
-    real(wp) :: seuil
-
-    if (ok_debug_cosp) then
-       seuil=1.e-15
-    else
-       seuil=0.0
-    endif
-
-
-    
-    mxratio = 0.0
-
-    if (n_ax >= 0.0) then ! N_ax is used to control which hydrometeors need to be computed
-        xi      = d_x/(alpha_x + b_x - n_bx + 1._wp)
-        rho0    = 1.29_wp
-        sigma   = (gamma2/(gamma1*c_x))*(n_ax*a_x*gamma2)**xi
-        one_over_xip1 = 1._wp/(xi + 1._wp)
-        gamma_4_3_2 = 0.5_wp*gamma4/gamma3
-        delta = (alpha_x + b_x + d_x - n_bx + 1._wp)
-        
-        do k=1,Nlevels
-            do j=1,Ncolumns
-                do i=1,Npoints
-                    if ((prec_frac(i,j,k)==prec_type).or.(prec_frac(i,j,k)==3.)) then
-                        rho = p(i,k)/(287.05_wp*T(i,k))
-                        mxratio(i,j,k)=(flux(i,k)*((rho/rho0)**g_x)*sigma)**one_over_xip1
-                        mxratio(i,j,k)=mxratio(i,j,k)/rho
-                        ! Compute effective radius
-!                        if ((reff(i,j,k) <= 0._wp).and.(flux(i,k) /= 0._wp)) then
-                         if ((reff(i,j,k) <= 0._wp).and.(flux(i,k) > seuil)) then
-                           lambda_x = (a_x*c_x*((rho0/rho)**g_x)*n_ax*gamma1/flux(i,k))**(1._wp/delta)
-                           reff(i,j,k) = gamma_4_3_2/lambda_x
-                        endif
-                    endif
-
-!Test Artem MxRatio
-!print '(a8, i5, i8, i8, f10.2, f10.2, f10.2, f10.2, f10.2)',&
-!'MxRatio ', k, j, i, rho, p(i,k), T(i,k), flux(i,k), mxratio(i,j,k)
-
-                enddo
-            enddo
-        enddo
-    endif
-END SUBROUTINE COSP_PRECIP_MXRATIO
-
-
-END MODULE MOD_COSP_UTILS
Index: /LMDZ6/trunk/libf/phylmd/cospv2/cosp_utils.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cospv2/cosp_utils.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/cospv2/cosp_utils.f90	(revision 5268)
@@ -0,0 +1,105 @@
+! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+! Copyright (c) 2015, Regents of the University of Colorado
+! All rights reserved.
+!
+! Redistribution and use in source and binary forms, with or without modification, are 
+! permitted provided that the following conditions are met:
+!
+! 1. Redistributions of source code must retain the above copyright notice, this list of 
+!    conditions and the following disclaimer.
+!
+! 2. Redistributions in binary form must reproduce the above copyright notice, this list
+!    of conditions and the following disclaimer in the documentation and/or other 
+!    materials provided with the distribution.
+!
+! 3. Neither the name of the copyright holder nor the names of its contributors may be 
+!    used to endorse or promote products derived from this software without specific prior
+!    written permission.
+!
+! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY 
+! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 
+! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL 
+! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 
+! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT 
+! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 
+! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+!
+! History:
+! Jul 2007 - A. Bodas-Salcedo - Initial version
+! May 2015 - Dustin Swales    - Modified for COSPv2.0
+! 
+! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+MODULE MOD_COSP_UTILS
+  USE COSP_KINDS, ONLY: wp
+  USE MOD_COSP_CONFIG
+  IMPLICIT NONE
+
+CONTAINS
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+!------------------- SUBROUTINE COSP_PRECIP_MXRATIO --------------
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+SUBROUTINE COSP_PRECIP_MXRATIO(Npoints,Nlevels,Ncolumns,p,T,prec_frac,prec_type, &
+                          n_ax,n_bx,alpha_x,c_x,d_x,g_x,a_x,b_x,gamma1,gamma2,gamma3,gamma4, &
+                          flux,mxratio,reff)
+
+    ! Input arguments, (IN)
+    integer,intent(in) :: Npoints,Nlevels,Ncolumns
+    real(wp),intent(in),dimension(Npoints,Nlevels) :: p,T,flux
+    real(wp),intent(in),dimension(Npoints,Ncolumns,Nlevels) :: prec_frac
+    real(wp),intent(in) :: n_ax,n_bx,alpha_x,c_x,d_x,g_x,a_x,b_x,gamma1,gamma2,gamma3,gamma4,prec_type
+    ! Input arguments, (OUT)
+    real(wp),intent(out),dimension(Npoints,Ncolumns,Nlevels) :: mxratio
+    real(wp),intent(inout),dimension(Npoints,Ncolumns,Nlevels) :: reff
+    ! Local variables
+    integer :: i,j,k
+    real(wp) :: sigma,one_over_xip1,xi,rho0,rho,lambda_x,gamma_4_3_2,delta
+
+    real(wp) :: seuil
+
+    if (ok_debug_cosp) then
+       seuil=1.e-15
+    else
+       seuil=0.0
+    endif
+
+
+    
+    mxratio = 0.0
+
+    if (n_ax >= 0.0) then ! N_ax is used to control which hydrometeors need to be computed
+        xi      = d_x/(alpha_x + b_x - n_bx + 1._wp)
+        rho0    = 1.29_wp
+        sigma   = (gamma2/(gamma1*c_x))*(n_ax*a_x*gamma2)**xi
+        one_over_xip1 = 1._wp/(xi + 1._wp)
+        gamma_4_3_2 = 0.5_wp*gamma4/gamma3
+        delta = (alpha_x + b_x + d_x - n_bx + 1._wp)
+        
+        do k=1,Nlevels
+            do j=1,Ncolumns
+                do i=1,Npoints
+                    if ((prec_frac(i,j,k)==prec_type).or.(prec_frac(i,j,k)==3.)) then
+                        rho = p(i,k)/(287.05_wp*T(i,k))
+                        mxratio(i,j,k)=(flux(i,k)*((rho/rho0)**g_x)*sigma)**one_over_xip1
+                        mxratio(i,j,k)=mxratio(i,j,k)/rho
+                        ! Compute effective radius
+!                        if ((reff(i,j,k) <= 0._wp).and.(flux(i,k) /= 0._wp)) then
+                         if ((reff(i,j,k) <= 0._wp).and.(flux(i,k) > seuil)) then
+                           lambda_x = (a_x*c_x*((rho0/rho)**g_x)*n_ax*gamma1/flux(i,k))**(1._wp/delta)
+                           reff(i,j,k) = gamma_4_3_2/lambda_x
+                        endif
+                    endif
+
+!Test Artem MxRatio
+!print '(a8, i5, i8, i8, f10.2, f10.2, f10.2, f10.2, f10.2)',&
+!'MxRatio ', k, j, i, rho, p(i,k), T(i,k), flux(i,k), mxratio(i,j,k)
+
+                enddo
+            enddo
+        enddo
+    endif
+END SUBROUTINE COSP_PRECIP_MXRATIO
+
+
+END MODULE MOD_COSP_UTILS
Index: DZ6/trunk/libf/phylmd/cospv2/icarus.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cospv2/icarus.F90	(revision 5267)
+++ 	(revision )
@@ -1,645 +1,0 @@
-! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-! Copyright (c) 2009, Lawrence Livemore National Security Limited Liability
-! All rights reserved.
-!
-! Redistribution and use in source and binary forms, with or without modification, are 
-! permitted provided that the following conditions are met:
-!
-! 1. Redistributions of source code must retain the above copyright notice, this list of 
-!    conditions and the following disclaimer.
-!
-! 2. Redistributions in binary form must reproduce the above copyright notice, this list
-!    of conditions and the following disclaimer in the documentation and/or other 
-!    materials provided with the distribution.
-!
-! 3. Neither the name of the copyright holder nor the names of its contributors may be 
-!    used to endorse or promote products derived from this software without specific prior
-!    written permission.
-!
-! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY 
-! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 
-! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL 
-! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 
-! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT 
-! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 
-! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
-! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-!
-! History
-! May 2015 - D. Swales - Modified for COSPv2.0
-! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-MODULE MOD_ICARUS
-  USE COSP_KINDS,          ONLY: wp
-  USE COSP_PHYS_CONSTANTS, ONLY: amd,amw,avo,grav
-  use MOD_COSP_STATS,      ONLY: hist2D
-  USE MOD_COSP_CONFIG,     ONLY: R_UNDEF,numISCCPTauBins,numISCCPPresBins,isccp_histTau, &
-                                 isccp_histPres
-  implicit none
-  
-  ! Shared Parameters                   
-  integer,parameter :: &
-       ncolprint = 0 ! Flag for debug printing (set as parameter to increase performance)
-
-  ! Cloud-top height determination
-  integer :: &
-       isccp_top_height,          & ! Top height adjustment method
-       isccp_top_height_direction   ! Direction for finding atmosphere pressure level
-
-  ! Parameters used by icarus
-  real(wp),parameter :: &
-       tauchk = -1._wp*log(0.9999999_wp), & ! Lower limit on optical depth
-       isccp_taumin = 0.3_wp,             & ! Minimum optical depth for joint-hostogram
-       pstd = 1013250._wp,                & ! Mean sea-level pressure (Pa)
-       isccp_t0 = 296._wp,                & ! Mean surface temperature (K)
-       output_missing_value = -1.E+30       ! Missing values
-
-contains
-  ! ##########################################################################
-  ! ##########################################################################
-  SUBROUTINE ICARUS(debug,debugcol,npoints,sunlit,nlev,ncol,pfull,          &
-                    phalf,qv,cc,conv,dtau_s,dtau_c,th,thd,frac_out,skt,emsfc_lw,at,&
-                    dem_s,dem_c,fq_isccp,totalcldarea, meanptop,meantaucld, &
-                    meanalbedocld, meantb,meantbclr,boxtau,boxptop,levmatch)
-        
-    ! INPUTS 
-    INTEGER,intent(in) ::      & !
-         npoints,              & ! Number of model points in the horizontal
-         nlev,                 & ! Number of model levels in column
-         ncol,                 & ! Number of subcolumns
-         debug,                & ! Debug flag
-         debugcol                ! Debug column flag
-    INTEGER,intent(in),dimension(npoints) :: & !
-         sunlit                  ! 1 for day points, 0 for night time 
-    REAL(WP),intent(in) ::     & !
-         emsfc_lw                ! 10.5 micron emissivity of surface (fraction)  
-    REAL(WP),intent(in),dimension(npoints) :: & !
-         skt                     ! Skin Temperature (K)
-    REAL(WP),intent(in),dimension(npoints,ncol,nlev) :: & !
-         frac_out                ! Boxes gridbox divided up into subcolumns
-    REAL(WP),intent(in),dimension(npoints,nlev) :: & !
-         pfull,                & ! Pressure of full model levels (Pascals)
-         qv,                   & ! Water vapor specific humidity (kg vapor/ kg air)
-         cc,                   & ! Cloud cover in each model level (fraction)
-         conv,                 & ! Convective cloud cover in each model
-         at,                   & ! Temperature in each model level (K) 
-         dem_c,                & ! Emissivity for convective clouds
-         dem_s,                & ! Emissivity for stratiform clouds
-         dtau_c,               & ! Optical depth for convective clouds
-         dtau_s                  ! Optical depth for stratiform clouds 
-    REAL(WP),intent(in),dimension(npoints,nlev+1) :: & !
-         phalf                   ! Pressure of half model levels (Pascals)!
-    integer,intent(in) :: th,thd
-
-    ! OUTPUTS 
-    REAL(WP),intent(out),dimension(npoints,7,7) :: & 
-         fq_isccp                ! The fraction of the model grid box covered by clouds
-    REAL(WP),intent(out),dimension(npoints) :: & 
-         totalcldarea,         & ! The fraction of model grid box columns with cloud present
-         meanptop,             & ! Mean cloud top pressure (mb) - linear averaging
-         meantaucld,           & ! Mean optical thickness
-         meanalbedocld,        & ! Mean cloud albedo  
-         meantb,               & ! Mean all-sky 10.5 micron brightness temperature
-         meantbclr               ! Mean clear-sky 10.5 micron brightness temperature
-    REAL(WP),intent(out),dimension(npoints,ncol) :: & 
-         boxtau,               & ! Optical thickness in each column
-         boxptop                 ! Cloud top pressure (mb) in each column
-    INTEGER,intent(out),dimension(npoints,ncol) :: &
-         levmatch                ! Used for icarus unit testing only
-
-
-    ! INTERNAL VARIABLES
-    CHARACTER(len=10)                     :: ftn09
-    REAL(WP),dimension(npoints,ncol)      :: boxttop
-    REAL(WP),dimension(npoints,ncol,nlev) :: dtau,demIN
-    INTEGER                               :: j,ilev,ibox
-    INTEGER,dimension(nlev,ncol   )       :: acc
-
-    ! PARAMETERS
-    character ,parameter, dimension(6) :: cchar=(/' ','-','1','+','I','+'/)
-    character(len=1),parameter,dimension(6) :: cchar_realtops=(/ ' ',' ','1','1','I','I'/)
-    ! ##########################################################################
-    
-    call cosp_simulator_optics(npoints,ncol,nlev,frac_out,dem_c,dem_s,demIN)
-    call cosp_simulator_optics(npoints,ncol,nlev,frac_out,dtau_c,dtau_s,dtau)
-
-    call ICARUS_SUBCOLUMN(npoints,ncol,nlev,sunlit,dtau,demIN,skt,emsfc_lw,qv,at,        &
-                      pfull,phalf,frac_out,levmatch,boxtau,boxptop,boxttop,meantbclr)
-
-    call ICARUS_COLUMN(npoints,ncol,boxtau,boxptop/100._wp,sunlit,boxttop,&
-                       fq_isccp,meanalbedocld,meanptop,meantaucld,totalcldarea,meantb)
-
-    ! ##########################################################################
-    ! OPTIONAL PRINTOUT OF DATA TO CHECK PROGRAM
-    ! ##########################################################################
-    
-    if (debugcol.ne.0) then
-       do j=1,npoints,debugcol
-          
-          ! Produce character output
-          do ilev=1,nlev
-             acc(ilev,1:ncol)=frac_out(j,1:ncol,ilev)*2
-             where(levmatch(j,1:ncol) .eq. ilev) acc(ilev,1:ncol)=acc(ilev,1:ncol)+1
-          enddo
-          
-          write(ftn09,11) j
-11        format('ftn09.',i4.4)
-          open(9, FILE=ftn09, FORM='FORMATTED')
-          
-          write(9,'(a1)') ' '
-          write(9,'(10i5)') (ilev,ilev=5,nlev,5)
-          write(9,'(a1)') ' '
-          
-          do ibox=1,ncol
-             write(9,'(40(a1),1x,40(a1))') &
-                  (cchar_realtops(acc(ilev,ibox)+1),ilev=1,nlev),&
-                  (cchar(acc(ilev,ibox)+1),ilev=1,nlev) 
-          end do
-          close(9)
-
-       enddo       
-    end if
-    
-    return
-  end SUBROUTINE ICARUS
-  
-  ! ############################################################################
-  ! ############################################################################
-  ! ############################################################################
-  SUBROUTINE ICARUS_SUBCOLUMN(npoints,ncol,nlev,sunlit,dtau,demiN,skt,emsfc_lw,qv,at,        &
-                          pfull,phalf,frac_out,levmatch,boxtau,boxptop,boxttop,meantbclr)
-    ! Inputs
-    INTEGER, intent(in) ::   &
-         ncol,               & ! Number of subcolumns
-         npoints,            & ! Number of horizontal gridpoints
-         nlev                  ! Number of vertical levels
-    INTEGER, intent(in), dimension(npoints) :: &
-         sunlit                ! 1=day 0=night
-    REAL(WP),intent(in) :: &
-         emsfc_lw              ! 10.5 micron emissivity of surface (fraction) 
-    REAL(WP),intent(in), dimension(npoints) ::  &
-         skt                   ! Skin temperature
-    REAL(WP),intent(in), dimension(npoints,nlev) ::  &
-         at,                 & ! Temperature 
-         pfull,              & ! Presure
-         qv                    ! Specific humidity
-    REAL(WP),intent(in), dimension(npoints,ncol,nlev) :: &
-         frac_out,           & ! Subcolumn cloud cover
-         dtau,               & ! Subcolumn optical thickness
-         demIN                 ! Subcolumn emissivity
-    REAL(WP),intent(in), dimension(npoints,nlev+1) :: &
-         phalf                 ! Pressure at model half levels
-
-    ! Outputs
-    REAL(WP),intent(inout),dimension(npoints) :: &
-         meantbclr             ! Mean clear-sky 10.5 micron brightness temperature
-    REAL(WP),intent(inout),dimension(npoints,ncol) :: &
-         boxtau,             & ! Optical thickness in each column
-         boxptop,            & ! Cloud top pressure (mb) in each column
-         boxttop               ! Cloud top temperature in each column
-    INTEGER, intent(inout),dimension(npoints,ncol)      :: levmatch
-
-    ! Local Variables
-    INTEGER :: &
-       j,ibox,ilev,k1,k2,icycle
-    INTEGER,dimension(npoints) :: &
-       nmatch,itrop
-    INTEGER,dimension(npoints,nlev-1) :: &
-       match
-    REAL(WP) :: &
-       logp,logp1,logp2,atd
-    REAL(WP),dimension(npoints) :: &
-       bb,attropmin,attrop,ptrop,atmax,btcmin,transmax,tauir,taumin,fluxtopinit,press,   &
-       dpress,atmden,rvh20,rhoave,rh20s,rfrgn,tmpexp,tauwv,wk,trans_layers_above_clrsky, &
-       fluxtop_clrsky
-    REAL(WP),dimension(npoints,nlev) :: &
-       dem_wv
-    REAL(WP),dimension(npoints,ncol) :: &
-       trans_layers_above,dem,tb,emcld,fluxtop,tau,ptop
-
-    ! ####################################################################################
-    ! Compute cloud optical depth for each column by summing up subcolumns
-    tau(1:npoints,1:ncol) = 0._wp
-    tau(1:npoints,1:ncol) = sum(dtau,dim=3)
-
-    ! Set tropopause values
-    if (isccp_top_height .eq. 1 .or. isccp_top_height .eq. 3) then 
-       ptrop(1:npoints)     = 5000._wp
-       attropmin(1:npoints) = 400._wp
-       atmax(1:npoints)     = 0._wp
-       attrop(1:npoints)    = 120._wp
-       itrop(1:npoints)     = 1
-
-       do ilev=1,nlev
-          where(pfull(1:npoints,ilev) .lt. 40000. .and. &
-                pfull(1:npoints,ilev) .gt.  5000. .and. &
-                at(1:npoints,ilev)    .lt. attropmin(1:npoints))
-             ptrop(1:npoints)     = pfull(1:npoints,ilev)
-             attropmin(1:npoints) = at(1:npoints,ilev)
-             attrop(1:npoints)    = attropmin(1:npoints)
-             itrop     = ilev
-          endwhere
-       enddo
-
-       do ilev=1,nlev
-          atmax(1:npoints) = merge(at(1:npoints,ilev),atmax(1:npoints),&
-               at(1:npoints,ilev) .gt. atmax(1:npoints) .and. ilev  .ge. itrop(1:npoints))
-       enddo
-    end if
-  
-    if (isccp_top_height .eq. 1 .or. isccp_top_height .eq. 3) then
-       ! ############################################################################
-       !                        Clear-sky radiance calculation
-       !       
-       ! Compute water vapor continuum emissivity this treatment follows Schwarkzopf 
-       ! and Ramasamy JGR 1999,vol 104, pages 9467-9499. The emissivity is calculated
-       ! at a wavenumber of 955 cm-1, or 10.47 microns 
-       ! ############################################################################
-       do ilev=1,nlev
-          press(1:npoints)  = pfull(1:npoints,ilev)*10._wp
-          dpress(1:npoints) = (phalf(1:npoints,ilev+1)-phalf(1:npoints,ilev))*10
-          atmden(1:npoints) = dpress(1:npoints)/(grav*100._wp)
-          rvh20(1:npoints)  = qv(1:npoints,ilev)*amd/amw
-          wk(1:npoints)     = rvh20(1:npoints)*avo*atmden/amd
-          rhoave(1:npoints) = (press(1:npoints)/pstd)*(isccp_t0/at(1:npoints,ilev))
-          rh20s(1:npoints)  = rvh20(1:npoints)*rhoave(1:npoints)
-          rfrgn(1:npoints)  = rhoave(1:npoints)-rh20s(1:npoints)
-          tmpexp(1:npoints) = exp(-0.02_wp*(at(1:npoints,ilev)-isccp_t0))
-          tauwv(1:npoints)  = wk(1:npoints)*1.e-20*((0.0224697_wp*rh20s(1:npoints)*      &
-                              tmpexp(1:npoints))+(3.41817e-7*rfrgn(1:npoints)))*0.98_wp
-          dem_wv(1:npoints,ilev) = 1._wp - exp( -1._wp * tauwv(1:npoints))
-       enddo
-
-       fluxtop_clrsky(1:npoints)            = 0._wp
-       trans_layers_above_clrsky(1:npoints) = 1._wp
-       do ilev=1,nlev
-          ! Black body emission at temperature of the layer
-          bb(1:npoints) = 1._wp / ( exp(1307.27_wp/at(1:npoints,ilev)) - 1._wp )
-          
-          ! Increase TOA flux by flux emitted from layer times total transmittance in layers above
-          fluxtop_clrsky(1:npoints) = fluxtop_clrsky(1:npoints) + &
-               dem_wv(1:npoints,ilev)*bb(1:npoints)*trans_layers_above_clrsky(1:npoints)
-          
-          ! Update trans_layers_above with transmissivity from this layer for next time around loop
-          trans_layers_above_clrsky(1:npoints) = trans_layers_above_clrsky(1:npoints)*&
-              (1.-dem_wv(1:npoints,ilev))                
-       enddo
-
-       ! Add in surface emission
-       bb(1:npoints) = 1._wp/( exp(1307.27_wp/skt(1:npoints)) - 1._wp )
-       fluxtop_clrsky(1:npoints) = fluxtop_clrsky(1:npoints) + &
-           emsfc_lw * bb(1:npoints)*trans_layers_above_clrsky(1:npoints)
-
-       ! Clear Sky brightness temperature
-       meantbclr(1:npoints) = 1307.27_wp/(log(1._wp+(1._wp/fluxtop_clrsky(1:npoints))))
-       
-       ! #################################################################################
-       !                        All-sky radiance calculation
-       ! #################################################################################
-       
-       fluxtop(1:npoints,1:ncol)            = 0._wp
-       trans_layers_above(1:npoints,1:ncol) = 1._wp
-       do ilev=1,nlev
-          ! Black body emission at temperature of the layer
-          bb=1._wp/(exp(1307.27_wp/at(1:npoints,ilev)) - 1._wp)
-          
-          do ibox=1,ncol
-             ! Emissivity
-             dem(1:npoints,ibox) = merge(dem_wv(1:npoints,ilev), &
-                                         1._wp-(1._wp-demIN(1:npoints,ibox,ilev))*(1._wp-dem_wv(1:npoints,ilev)), &
-                                         demIN(1:npoints,ibox,ilev) .eq. 0)
-
-             ! Increase TOA flux emitted from layer
-             fluxtop(1:npoints,ibox) = fluxtop(1:npoints,ibox) + dem(1:npoints,ibox)*bb*trans_layers_above(1:npoints,ibox) 
-             
-             ! Update trans_layer by emitted layer from above
-             trans_layers_above(1:npoints,ibox) = trans_layers_above(1:npoints,ibox)*(1._wp-dem(1:npoints,ibox))
-          enddo
-       enddo
-
-       ! Add in surface emission
-       bb(1:npoints)=1._wp/( exp(1307.27_wp/skt(1:npoints)) - 1._wp )
-       do ibox=1,ncol
-          fluxtop(1:npoints,ibox) = fluxtop(1:npoints,ibox) + emsfc_lw*bb(1:npoints)*trans_layers_above(1:npoints,ibox) 
-       end do
-
-       ! All Sky brightness temperature
-       boxttop(1:npoints,1:ncol) = 1307.27_wp/(log(1._wp+(1._wp/fluxtop(1:npoints,1:ncol))))
-
-       ! #################################################################################  
-       !                            Cloud-Top Temperature
-       !
-       ! Now that you have the top of atmosphere radiance, account for ISCCP 
-       ! procedures to determine cloud top temperature account for partially
-       ! transmitting cloud recompute flux ISCCP would see assuming a single layer
-       ! cloud. *NOTE* choice here of 2.13, as it is primarily ice clouds which have 
-       ! partial emissivity and need the adjustment performed in this section. If it
-       ! turns out that the cloud brightness temperature is greater than 260K, then 
-       ! the liquid cloud conversion factor of 2.56 is used. *NOTE* that this is 
-       ! discussed on pages 85-87 of the ISCCP D level documentation 
-       ! (Rossow et al. 1996)
-       ! #################################################################################
-
-       ! Compute minimum brightness temperature and optical depth
-       btcmin(1:npoints) = 1._wp /  ( exp(1307.27_wp/(attrop(1:npoints)-5._wp)) - 1._wp ) 
-
-       do ibox=1,ncol
-          transmax(1:npoints) = (fluxtop(1:npoints,ibox)-btcmin) /(fluxtop_clrsky(1:npoints)-btcmin(1:npoints))
-          tauir(1:npoints)    = tau(1:npoints,ibox)/2.13_wp
-          taumin(1:npoints)   = -log(max(min(transmax(1:npoints),0.9999999_wp),0.001_wp))
-          if (isccp_top_height .eq. 1) then
-             do j=1,npoints  
-                if (transmax(j) .gt. 0.001 .and.  transmax(j) .le. 0.9999999) then
-                   fluxtopinit(j) = fluxtop(j,ibox)
-                   tauir(j) = tau(j,ibox)/2.13_wp
-                endif
-             enddo
-             do icycle=1,2
-                do j=1,npoints  
-                   if (tau(j,ibox) .gt. (tauchk)) then 
-                      if (transmax(j) .gt. 0.001 .and.  transmax(j) .le. 0.9999999) then
-                         emcld(j,ibox) = 1._wp - exp(-1._wp * tauir(j)  )
-                         fluxtop(j,ibox) = fluxtopinit(j) - ((1.-emcld(j,ibox))*fluxtop_clrsky(j))
-                         fluxtop(j,ibox)=max(1.E-06_wp,(fluxtop(j,ibox)/emcld(j,ibox)))
-                         tb(j,ibox)= 1307.27_wp / (log(1._wp + (1._wp/fluxtop(j,ibox))))
-                         if (tb(j,ibox) .gt. 260.) then
-                            tauir(j) = tau(j,ibox) / 2.56_wp
-                         end if
-                      end if
-                   end if
-                enddo
-            enddo
-          endif
-
-          ! Cloud-top temperature
-          where(tau(1:npoints,ibox) .gt. tauchk)
-             tb(1:npoints,ibox)= 1307.27_wp/ (log(1. + (1._wp/fluxtop(1:npoints,ibox))))
-             where (isccp_top_height .eq. 1 .and. tauir(1:npoints) .lt. taumin(1:npoints))
-                tb(1:npoints,ibox) = attrop(1:npoints) - 5._wp 
-                tau(1:npoints,ibox) = 2.13_wp*taumin(1:npoints)
-             endwhere
-          endwhere
-          
-          ! Clear-sky brightness temperature
-          where(tau(1:npoints,ibox) .le. tauchk) 
-             tb(1:npoints,ibox) = meantbclr(1:npoints)
-          endwhere
-       enddo
-    else
-       meantbclr(1:npoints) = output_missing_value
-    end if
-
-    ! ####################################################################################
-    !                           Cloud-Top Pressure
-    !
-    ! The 2 methods differ according to whether or not you use the physical cloud
-    ! top pressure (isccp_top_height = 2) or the radiatively determined cloud top
-    ! pressure (isccp_top_height = 1 or 3)
-    ! ####################################################################################
-    do ibox=1,ncol
-       !segregate according to optical thickness
-       if (isccp_top_height .eq. 1 .or. isccp_top_height .eq. 3) then  
-          
-          ! Find level whose temperature most closely matches brightness temperature
-          nmatch(1:npoints)=0
-          do k1=1,nlev-1
-             ilev = merge(nlev-k1,k1,isccp_top_height_direction .eq. 2)        
-             do j=1,npoints 
-                if (ilev           .ge. itrop(j)     .and. &
-                     ((at(j,ilev)  .ge. tb(j,ibox)   .and. &  
-                      at(j,ilev+1) .le. tb(j,ibox))  .or.  &
-                      (at(j,ilev)  .le. tb(j,ibox)   .and. &
-                      at(j,ilev+1) .ge. tb(j,ibox)))) then 
-                   nmatch(j)=nmatch(j)+1
-                   match(j,nmatch(j))=ilev
-                endif
-             enddo
-          enddo
-
-          do j=1,npoints 
-             if (nmatch(j) .ge. 1) then
-                k1 = match(j,nmatch(j))
-                k2 = k1 + 1
-                logp1 = log(pfull(j,k1))
-                logp2 = log(pfull(j,k2))
-                atd = max(tauchk,abs(at(j,k2) - at(j,k1)))
-                logp=logp1+(logp2-logp1)*abs(tb(j,ibox)-at(j,k1))/atd
-                ptop(j,ibox) = exp(logp)
-                levmatch(j,ibox) = merge(k1,k2,abs(pfull(j,k1)-ptop(j,ibox)) .lt. abs(pfull(j,k2)-ptop(j,ibox)))
-             else
-                if (tb(j,ibox) .le. attrop(j)) then
-                   ptop(j,ibox)=ptrop(j)
-                   levmatch(j,ibox)=itrop(j)
-                end if
-                if (tb(j,ibox) .ge. atmax(j)) then
-                   ptop(j,ibox)=pfull(j,nlev)
-                   levmatch(j,ibox)=nlev
-                end if
-             end if
-          enddo
-       else
-          ptop(1:npoints,ibox)=0.
-          do ilev=1,nlev
-             where((ptop(1:npoints,ibox) .eq. 0. ) .and.(frac_out(1:npoints,ibox,ilev) .ne. 0))
-                ptop(1:npoints,ibox)=phalf(1:npoints,ilev)
-                levmatch(1:npoints,ibox)=ilev
-             endwhere
-          end do
-       end if
-       where(tau(1:npoints,ibox) .le. tauchk)
-          ptop(1:npoints,ibox)=0._wp
-          levmatch(1:npoints,ibox)=0._wp
-       endwhere
-    enddo
-
-    ! ####################################################################################
-    !                Compute subcolumn pressure and optical depth
-    ! ####################################################################################
-    boxtau(1:npoints,1:ncol)  = output_missing_value
-    boxptop(1:npoints,1:ncol) = output_missing_value
-    do ibox=1,ncol
-       do j=1,npoints 
-          if (tau(j,ibox) .gt. (tauchk) .and. ptop(j,ibox) .gt. 0.) then
-             if (sunlit(j).eq.1 .or. isccp_top_height .eq. 3) then
-                boxtau(j,ibox) = tau(j,ibox)
-                boxptop(j,ibox) = ptop(j,ibox)!/100._wp
-             endif
-          endif
-       enddo
-    enddo
-
-  end SUBROUTINE ICARUS_SUBCOLUMN
-
-  ! ######################################################################################
-  ! SUBROUTINE icarus_column
-  ! ######################################################################################
-  SUBROUTINE ICARUS_column(npoints,ncol,boxtau,boxptop,sunlit,boxttop,fq_isccp,     &
-                           meanalbedocld,meanptop,meantaucld,totalcldarea,meantb)
-    ! Inputs
-    INTEGER, intent(in) :: &
-         ncol,    & ! Number of subcolumns
-         npoints    ! Number of horizontal gridpoints
-    INTEGER, intent(in),dimension(npoints) :: &
-         sunlit     ! day=1 night=0 
-    REAL(WP),intent(in),dimension(npoints,ncol) ::  &
-         boxttop,  & ! Subcolumn top temperature
-         boxptop,  & ! Subcolumn cloud top pressure
-         boxtau      ! Subcolumn optical depth
-
-    ! Outputs
-    REAL(WP),intent(inout),dimension(npoints) :: &
-         meanalbedocld, & ! Gridmean cloud albedo
-         meanptop,      & ! Gridmean cloud top pressure (mb) - linear averaging
-         meantaucld,    & ! Gridmean optical thickness
-         totalcldarea,  & ! The fraction of model grid box columns with cloud present
-         meantb           ! Gridmean all-sky 10.5 micron brightness temperature 
-    REAL(WP),intent(inout),dimension(npoints,7,7) :: &
-         fq_isccp         ! The fraction of the model grid box covered by clouds
-
-    ! Local Variables
-    INTEGER :: j,ilev,ilev2
-    REAL(WP),dimension(npoints,ncol) :: albedocld
-    LOGICAL, dimension(npoints,ncol) :: box_cloudy
-
-    ! Variables for new joint-histogram implementation
-    logical,dimension(ncol) :: box_cloudy2
-
-    ! ####################################################################################
-    !                           Brightness Temperature
-    ! ####################################################################################
-    if (isccp_top_height .eq. 1 .or. isccp_top_height .eq. 3) then
-       meantb(1:npoints)=sum(boxttop,2)/ncol
-    else
-       meantb(1:npoints) = output_missing_value
-    endif
-
-    ! ####################################################################################
-    !                 Determines ISCCP cloud type frequencies
-    !
-    ! Now that boxptop and boxtau have been determined, determine amount of each of the 
-    ! 49 ISCCP cloud types. Also compute grid box mean cloud top pressure and 
-    ! optical thickness.  The mean cloud top pressure and optical thickness are 
-    ! averages over the cloudy area only. The mean cloud top pressure is a linear
-    ! average of the cloud top pressures. The mean cloud optical thickness is 
-    ! computed by converting optical thickness to an albedo, averaging in albedo 
-    ! units, then converting the average albedo back to a mean optical thickness.  
-    ! ####################################################################################
-
-    ! Initialize
-    albedocld(1:npoints,1:ncol)  = 0._wp
-    box_cloudy(1:npoints,1:ncol) = .false.
-    
-    ! Reset frequencies
-    !fq_isccp = spread(spread(merge(0._wp,output_missing_value,sunlit .eq. 1 .or. isccp_top_height .eq. 3),2,7),2,7)
-    do ilev=1,7
-       do ilev2=1,7
-          do j=1,npoints ! 
-             if (sunlit(j).eq.1 .or. isccp_top_height .eq. 3) then 
-                fq_isccp(j,ilev,ilev2)= 0.
-	     else 
-                fq_isccp(j,ilev,ilev2)= output_missing_value
-             end if
-          enddo
-       enddo
-    enddo
-
-    
-    ! Reset variables need for averaging cloud properties
-    where(sunlit .eq. 1 .or. isccp_top_height .eq. 3)
-       totalcldarea(1:npoints)  = 0._wp
-       meanalbedocld(1:npoints) = 0._wp
-       meanptop(1:npoints)      = 0._wp
-       meantaucld(1:npoints)    = 0._wp
-    elsewhere
-       totalcldarea(1:npoints)  = output_missing_value
-       meanalbedocld(1:npoints) = output_missing_value
-       meanptop(1:npoints)      = output_missing_value
-       meantaucld(1:npoints)    = output_missing_value
-    endwhere
-    
-    ! Compute column quantities and joint-histogram
-    do j=1,npoints 
-       ! Subcolumns that are cloudy(true) and not(false)
-       box_cloudy2(1:ncol) = merge(.true.,.false.,boxtau(j,1:ncol) .gt. tauchk .and. boxptop(j,1:ncol) .gt. 0.)
-
-       ! Compute joint histogram and column quantities for points that are sunlit and cloudy
-       if (sunlit(j) .eq.1 .or. isccp_top_height .eq. 3) then 
-          ! Joint-histogram
-          call hist2D(boxtau(j,1:ncol),boxptop(j,1:ncol),ncol,isccp_histTau,numISCCPTauBins, &
-               isccp_histPres,numISCCPPresBins,fq_isccp(j,1:numISCCPTauBins,1:numISCCPPresBins))
-          fq_isccp(j,1:numISCCPTauBins,1:numISCCPPresBins) = &
-               fq_isccp(j,1:numISCCPTauBins,1:numISCCPPresBins)/ncol
-          
-          ! Column cloud area
-          totalcldarea(j) = real(count(box_cloudy2(1:ncol) .and. boxtau(j,1:ncol) .gt. isccp_taumin))/ncol
-             
-          ! Subcolumn cloud albedo
-          !albedocld(j,1:ncol) = merge((boxtau(j,1:ncol)**0.895_wp)/((boxtau(j,1:ncol)**0.895_wp)+6.82_wp),&
-          !     0._wp,box_cloudy2(1:ncol) .and. boxtau(j,1:ncol) .gt. isccp_taumin)
-          where(box_cloudy2(1:ncol) .and. boxtau(j,1:ncol) .gt. isccp_taumin)
-             albedocld(j,1:ncol) = (boxtau(j,1:ncol)**0.895_wp)/((boxtau(j,1:ncol)**0.895_wp)+6.82_wp)
-          elsewhere
-             albedocld(j,1:ncol) = 0._wp
-          endwhere
-          
-          ! Column cloud albedo
-          meanalbedocld(j) = sum(albedocld(j,1:ncol))/ncol
-          
-          ! Column cloud top pressure
-          meanptop(j) = sum(boxptop(j,1:ncol),box_cloudy2(1:ncol) .and. boxtau(j,1:ncol) .gt. isccp_taumin)/ncol
-       endif
-    enddo
-    
-    ! Compute mean cloud properties. Set to mssing value in the event that totalcldarea=0
-    where(totalcldarea(1:npoints) .gt. 0)
-       meanptop(1:npoints)      = 100._wp*meanptop(1:npoints)/totalcldarea(1:npoints)
-       meanalbedocld(1:npoints) = meanalbedocld(1:npoints)/totalcldarea(1:npoints)
-       meantaucld(1:npoints)    = (6.82_wp/((1._wp/meanalbedocld(1:npoints))-1.))**(1._wp/0.895_wp)
-    elsewhere
-       meanptop(1:nPoints)      = output_missing_value
-       meanalbedocld(1:nPoints) = output_missing_value
-       meantaucld(1:nPoints)    = output_missing_value
-    endwhere
-    !meanptop(1:npoints)      = merge(100._wp*meanptop(1:npoints)/totalcldarea(1:npoints),&
-    !                                 output_missing_value,totalcldarea(1:npoints) .gt. 0)
-    !meanalbedocld(1:npoints) = merge(meanalbedocld(1:npoints)/totalcldarea(1:npoints), &
-    !                                 output_missing_value,totalcldarea(1:npoints) .gt. 0)
-    !meantaucld(1:npoints)    = merge((6.82_wp/((1._wp/meanalbedocld(1:npoints))-1.))**(1._wp/0.895_wp), &
-    !                                 output_missing_value,totalcldarea(1:npoints) .gt. 0)
-
-    ! Represent in percent
-    where(totalcldarea .ne. output_missing_value) totalcldarea = totalcldarea*100._wp
-    where(fq_isccp     .ne. output_missing_value) fq_isccp     = fq_isccp*100._wp
-    
-    
-  end SUBROUTINE ICARUS_column
-  
-  subroutine cosp_simulator_optics(dim1,dim2,dim3,flag,varIN1,varIN2,varOUT)
-    ! INPUTS
-    integer,intent(in) :: &
-         dim1,   & ! Dimension 1 extent (Horizontal)
-         dim2,   & ! Dimension 2 extent (Subcolumn)
-         dim3      ! Dimension 3 extent (Vertical)
-    real(wp),intent(in),dimension(dim1,dim2,dim3) :: &
-         flag      ! Logical to determine the of merge var1IN and var2IN
-    real(wp),intent(in),dimension(dim1,     dim3) :: &
-         varIN1, & ! Input field 1
-         varIN2    ! Input field 2
-    ! OUTPUTS
-    real(wp),intent(out),dimension(dim1,dim2,dim3) :: &
-         varOUT    ! Merged output field
-    ! LOCAL VARIABLES
-    integer :: j
-    
-    varOUT(1:dim1,1:dim2,1:dim3) = 0._wp
-    do j=1,dim2
-       where(flag(:,j,:) .eq. 1)
-          varOUT(:,j,:) = varIN2
-       endwhere
-       where(flag(:,j,:) .eq. 2)
-          varOUT(:,j,:) = varIN1
-       endwhere
-    enddo
-  end subroutine cosp_simulator_optics
-end module MOD_ICARUS
-
Index: /LMDZ6/trunk/libf/phylmd/cospv2/icarus.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cospv2/icarus.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/cospv2/icarus.f90	(revision 5268)
@@ -0,0 +1,645 @@
+! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+! Copyright (c) 2009, Lawrence Livemore National Security Limited Liability
+! All rights reserved.
+!
+! Redistribution and use in source and binary forms, with or without modification, are 
+! permitted provided that the following conditions are met:
+!
+! 1. Redistributions of source code must retain the above copyright notice, this list of 
+!    conditions and the following disclaimer.
+!
+! 2. Redistributions in binary form must reproduce the above copyright notice, this list
+!    of conditions and the following disclaimer in the documentation and/or other 
+!    materials provided with the distribution.
+!
+! 3. Neither the name of the copyright holder nor the names of its contributors may be 
+!    used to endorse or promote products derived from this software without specific prior
+!    written permission.
+!
+! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY 
+! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 
+! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL 
+! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 
+! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT 
+! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 
+! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+!
+! History
+! May 2015 - D. Swales - Modified for COSPv2.0
+! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+MODULE MOD_ICARUS
+  USE COSP_KINDS,          ONLY: wp
+  USE COSP_PHYS_CONSTANTS, ONLY: amd,amw,avo,grav
+  use MOD_COSP_STATS,      ONLY: hist2D
+  USE MOD_COSP_CONFIG,     ONLY: R_UNDEF,numISCCPTauBins,numISCCPPresBins,isccp_histTau, &
+                                 isccp_histPres
+  implicit none
+  
+  ! Shared Parameters                   
+  integer,parameter :: &
+       ncolprint = 0 ! Flag for debug printing (set as parameter to increase performance)
+
+  ! Cloud-top height determination
+  integer :: &
+       isccp_top_height,          & ! Top height adjustment method
+       isccp_top_height_direction   ! Direction for finding atmosphere pressure level
+
+  ! Parameters used by icarus
+  real(wp),parameter :: &
+       tauchk = -1._wp*log(0.9999999_wp), & ! Lower limit on optical depth
+       isccp_taumin = 0.3_wp,             & ! Minimum optical depth for joint-hostogram
+       pstd = 1013250._wp,                & ! Mean sea-level pressure (Pa)
+       isccp_t0 = 296._wp,                & ! Mean surface temperature (K)
+       output_missing_value = -1.E+30       ! Missing values
+
+contains
+  ! ##########################################################################
+  ! ##########################################################################
+  SUBROUTINE ICARUS(debug,debugcol,npoints,sunlit,nlev,ncol,pfull,          &
+                    phalf,qv,cc,conv,dtau_s,dtau_c,th,thd,frac_out,skt,emsfc_lw,at,&
+                    dem_s,dem_c,fq_isccp,totalcldarea, meanptop,meantaucld, &
+                    meanalbedocld, meantb,meantbclr,boxtau,boxptop,levmatch)
+        
+    ! INPUTS 
+    INTEGER,intent(in) ::      & !
+         npoints,              & ! Number of model points in the horizontal
+         nlev,                 & ! Number of model levels in column
+         ncol,                 & ! Number of subcolumns
+         debug,                & ! Debug flag
+         debugcol                ! Debug column flag
+    INTEGER,intent(in),dimension(npoints) :: & !
+         sunlit                  ! 1 for day points, 0 for night time 
+    REAL(WP),intent(in) ::     & !
+         emsfc_lw                ! 10.5 micron emissivity of surface (fraction)  
+    REAL(WP),intent(in),dimension(npoints) :: & !
+         skt                     ! Skin Temperature (K)
+    REAL(WP),intent(in),dimension(npoints,ncol,nlev) :: & !
+         frac_out                ! Boxes gridbox divided up into subcolumns
+    REAL(WP),intent(in),dimension(npoints,nlev) :: & !
+         pfull,                & ! Pressure of full model levels (Pascals)
+         qv,                   & ! Water vapor specific humidity (kg vapor/ kg air)
+         cc,                   & ! Cloud cover in each model level (fraction)
+         conv,                 & ! Convective cloud cover in each model
+         at,                   & ! Temperature in each model level (K) 
+         dem_c,                & ! Emissivity for convective clouds
+         dem_s,                & ! Emissivity for stratiform clouds
+         dtau_c,               & ! Optical depth for convective clouds
+         dtau_s                  ! Optical depth for stratiform clouds 
+    REAL(WP),intent(in),dimension(npoints,nlev+1) :: & !
+         phalf                   ! Pressure of half model levels (Pascals)!
+    integer,intent(in) :: th,thd
+
+    ! OUTPUTS 
+    REAL(WP),intent(out),dimension(npoints,7,7) :: & 
+         fq_isccp                ! The fraction of the model grid box covered by clouds
+    REAL(WP),intent(out),dimension(npoints) :: & 
+         totalcldarea,         & ! The fraction of model grid box columns with cloud present
+         meanptop,             & ! Mean cloud top pressure (mb) - linear averaging
+         meantaucld,           & ! Mean optical thickness
+         meanalbedocld,        & ! Mean cloud albedo  
+         meantb,               & ! Mean all-sky 10.5 micron brightness temperature
+         meantbclr               ! Mean clear-sky 10.5 micron brightness temperature
+    REAL(WP),intent(out),dimension(npoints,ncol) :: & 
+         boxtau,               & ! Optical thickness in each column
+         boxptop                 ! Cloud top pressure (mb) in each column
+    INTEGER,intent(out),dimension(npoints,ncol) :: &
+         levmatch                ! Used for icarus unit testing only
+
+
+    ! INTERNAL VARIABLES
+    CHARACTER(len=10)                     :: ftn09
+    REAL(WP),dimension(npoints,ncol)      :: boxttop
+    REAL(WP),dimension(npoints,ncol,nlev) :: dtau,demIN
+    INTEGER                               :: j,ilev,ibox
+    INTEGER,dimension(nlev,ncol   )       :: acc
+
+    ! PARAMETERS
+    character ,parameter, dimension(6) :: cchar=(/' ','-','1','+','I','+'/)
+    character(len=1),parameter,dimension(6) :: cchar_realtops=(/ ' ',' ','1','1','I','I'/)
+    ! ##########################################################################
+    
+    call cosp_simulator_optics(npoints,ncol,nlev,frac_out,dem_c,dem_s,demIN)
+    call cosp_simulator_optics(npoints,ncol,nlev,frac_out,dtau_c,dtau_s,dtau)
+
+    call ICARUS_SUBCOLUMN(npoints,ncol,nlev,sunlit,dtau,demIN,skt,emsfc_lw,qv,at,        &
+                      pfull,phalf,frac_out,levmatch,boxtau,boxptop,boxttop,meantbclr)
+
+    call ICARUS_COLUMN(npoints,ncol,boxtau,boxptop/100._wp,sunlit,boxttop,&
+                       fq_isccp,meanalbedocld,meanptop,meantaucld,totalcldarea,meantb)
+
+    ! ##########################################################################
+    ! OPTIONAL PRINTOUT OF DATA TO CHECK PROGRAM
+    ! ##########################################################################
+    
+    if (debugcol.ne.0) then
+       do j=1,npoints,debugcol
+          
+          ! Produce character output
+          do ilev=1,nlev
+             acc(ilev,1:ncol)=frac_out(j,1:ncol,ilev)*2
+             where(levmatch(j,1:ncol) .eq. ilev) acc(ilev,1:ncol)=acc(ilev,1:ncol)+1
+          enddo
+          
+          write(ftn09,11) j
+11        format('ftn09.',i4.4)
+          open(9, FILE=ftn09, FORM='FORMATTED')
+          
+          write(9,'(a1)') ' '
+          write(9,'(10i5)') (ilev,ilev=5,nlev,5)
+          write(9,'(a1)') ' '
+          
+          do ibox=1,ncol
+             write(9,'(40(a1),1x,40(a1))') &
+                  (cchar_realtops(acc(ilev,ibox)+1),ilev=1,nlev),&
+                  (cchar(acc(ilev,ibox)+1),ilev=1,nlev) 
+          end do
+          close(9)
+
+       enddo       
+    end if
+    
+    return
+  end SUBROUTINE ICARUS
+  
+  ! ############################################################################
+  ! ############################################################################
+  ! ############################################################################
+  SUBROUTINE ICARUS_SUBCOLUMN(npoints,ncol,nlev,sunlit,dtau,demiN,skt,emsfc_lw,qv,at,        &
+                          pfull,phalf,frac_out,levmatch,boxtau,boxptop,boxttop,meantbclr)
+    ! Inputs
+    INTEGER, intent(in) ::   &
+         ncol,               & ! Number of subcolumns
+         npoints,            & ! Number of horizontal gridpoints
+         nlev                  ! Number of vertical levels
+    INTEGER, intent(in), dimension(npoints) :: &
+         sunlit                ! 1=day 0=night
+    REAL(WP),intent(in) :: &
+         emsfc_lw              ! 10.5 micron emissivity of surface (fraction) 
+    REAL(WP),intent(in), dimension(npoints) ::  &
+         skt                   ! Skin temperature
+    REAL(WP),intent(in), dimension(npoints,nlev) ::  &
+         at,                 & ! Temperature 
+         pfull,              & ! Presure
+         qv                    ! Specific humidity
+    REAL(WP),intent(in), dimension(npoints,ncol,nlev) :: &
+         frac_out,           & ! Subcolumn cloud cover
+         dtau,               & ! Subcolumn optical thickness
+         demIN                 ! Subcolumn emissivity
+    REAL(WP),intent(in), dimension(npoints,nlev+1) :: &
+         phalf                 ! Pressure at model half levels
+
+    ! Outputs
+    REAL(WP),intent(inout),dimension(npoints) :: &
+         meantbclr             ! Mean clear-sky 10.5 micron brightness temperature
+    REAL(WP),intent(inout),dimension(npoints,ncol) :: &
+         boxtau,             & ! Optical thickness in each column
+         boxptop,            & ! Cloud top pressure (mb) in each column
+         boxttop               ! Cloud top temperature in each column
+    INTEGER, intent(inout),dimension(npoints,ncol)      :: levmatch
+
+    ! Local Variables
+    INTEGER :: &
+       j,ibox,ilev,k1,k2,icycle
+    INTEGER,dimension(npoints) :: &
+       nmatch,itrop
+    INTEGER,dimension(npoints,nlev-1) :: &
+       match
+    REAL(WP) :: &
+       logp,logp1,logp2,atd
+    REAL(WP),dimension(npoints) :: &
+       bb,attropmin,attrop,ptrop,atmax,btcmin,transmax,tauir,taumin,fluxtopinit,press,   &
+       dpress,atmden,rvh20,rhoave,rh20s,rfrgn,tmpexp,tauwv,wk,trans_layers_above_clrsky, &
+       fluxtop_clrsky
+    REAL(WP),dimension(npoints,nlev) :: &
+       dem_wv
+    REAL(WP),dimension(npoints,ncol) :: &
+       trans_layers_above,dem,tb,emcld,fluxtop,tau,ptop
+
+    ! ####################################################################################
+    ! Compute cloud optical depth for each column by summing up subcolumns
+    tau(1:npoints,1:ncol) = 0._wp
+    tau(1:npoints,1:ncol) = sum(dtau,dim=3)
+
+    ! Set tropopause values
+    if (isccp_top_height .eq. 1 .or. isccp_top_height .eq. 3) then 
+       ptrop(1:npoints)     = 5000._wp
+       attropmin(1:npoints) = 400._wp
+       atmax(1:npoints)     = 0._wp
+       attrop(1:npoints)    = 120._wp
+       itrop(1:npoints)     = 1
+
+       do ilev=1,nlev
+          where(pfull(1:npoints,ilev) .lt. 40000. .and. &
+                pfull(1:npoints,ilev) .gt.  5000. .and. &
+                at(1:npoints,ilev)    .lt. attropmin(1:npoints))
+             ptrop(1:npoints)     = pfull(1:npoints,ilev)
+             attropmin(1:npoints) = at(1:npoints,ilev)
+             attrop(1:npoints)    = attropmin(1:npoints)
+             itrop     = ilev
+          endwhere
+       enddo
+
+       do ilev=1,nlev
+          atmax(1:npoints) = merge(at(1:npoints,ilev),atmax(1:npoints),&
+               at(1:npoints,ilev) .gt. atmax(1:npoints) .and. ilev  .ge. itrop(1:npoints))
+       enddo
+    end if
+  
+    if (isccp_top_height .eq. 1 .or. isccp_top_height .eq. 3) then
+       ! ############################################################################
+       !                        Clear-sky radiance calculation
+       !       
+       ! Compute water vapor continuum emissivity this treatment follows Schwarkzopf 
+       ! and Ramasamy JGR 1999,vol 104, pages 9467-9499. The emissivity is calculated
+       ! at a wavenumber of 955 cm-1, or 10.47 microns 
+       ! ############################################################################
+       do ilev=1,nlev
+          press(1:npoints)  = pfull(1:npoints,ilev)*10._wp
+          dpress(1:npoints) = (phalf(1:npoints,ilev+1)-phalf(1:npoints,ilev))*10
+          atmden(1:npoints) = dpress(1:npoints)/(grav*100._wp)
+          rvh20(1:npoints)  = qv(1:npoints,ilev)*amd/amw
+          wk(1:npoints)     = rvh20(1:npoints)*avo*atmden/amd
+          rhoave(1:npoints) = (press(1:npoints)/pstd)*(isccp_t0/at(1:npoints,ilev))
+          rh20s(1:npoints)  = rvh20(1:npoints)*rhoave(1:npoints)
+          rfrgn(1:npoints)  = rhoave(1:npoints)-rh20s(1:npoints)
+          tmpexp(1:npoints) = exp(-0.02_wp*(at(1:npoints,ilev)-isccp_t0))
+          tauwv(1:npoints)  = wk(1:npoints)*1.e-20*((0.0224697_wp*rh20s(1:npoints)*      &
+                              tmpexp(1:npoints))+(3.41817e-7*rfrgn(1:npoints)))*0.98_wp
+          dem_wv(1:npoints,ilev) = 1._wp - exp( -1._wp * tauwv(1:npoints))
+       enddo
+
+       fluxtop_clrsky(1:npoints)            = 0._wp
+       trans_layers_above_clrsky(1:npoints) = 1._wp
+       do ilev=1,nlev
+          ! Black body emission at temperature of the layer
+          bb(1:npoints) = 1._wp / ( exp(1307.27_wp/at(1:npoints,ilev)) - 1._wp )
+          
+          ! Increase TOA flux by flux emitted from layer times total transmittance in layers above
+          fluxtop_clrsky(1:npoints) = fluxtop_clrsky(1:npoints) + &
+               dem_wv(1:npoints,ilev)*bb(1:npoints)*trans_layers_above_clrsky(1:npoints)
+          
+          ! Update trans_layers_above with transmissivity from this layer for next time around loop
+          trans_layers_above_clrsky(1:npoints) = trans_layers_above_clrsky(1:npoints)*&
+              (1.-dem_wv(1:npoints,ilev))                
+       enddo
+
+       ! Add in surface emission
+       bb(1:npoints) = 1._wp/( exp(1307.27_wp/skt(1:npoints)) - 1._wp )
+       fluxtop_clrsky(1:npoints) = fluxtop_clrsky(1:npoints) + &
+           emsfc_lw * bb(1:npoints)*trans_layers_above_clrsky(1:npoints)
+
+       ! Clear Sky brightness temperature
+       meantbclr(1:npoints) = 1307.27_wp/(log(1._wp+(1._wp/fluxtop_clrsky(1:npoints))))
+       
+       ! #################################################################################
+       !                        All-sky radiance calculation
+       ! #################################################################################
+       
+       fluxtop(1:npoints,1:ncol)            = 0._wp
+       trans_layers_above(1:npoints,1:ncol) = 1._wp
+       do ilev=1,nlev
+          ! Black body emission at temperature of the layer
+          bb=1._wp/(exp(1307.27_wp/at(1:npoints,ilev)) - 1._wp)
+          
+          do ibox=1,ncol
+             ! Emissivity
+             dem(1:npoints,ibox) = merge(dem_wv(1:npoints,ilev), &
+                                         1._wp-(1._wp-demIN(1:npoints,ibox,ilev))*(1._wp-dem_wv(1:npoints,ilev)), &
+                                         demIN(1:npoints,ibox,ilev) .eq. 0)
+
+             ! Increase TOA flux emitted from layer
+             fluxtop(1:npoints,ibox) = fluxtop(1:npoints,ibox) + dem(1:npoints,ibox)*bb*trans_layers_above(1:npoints,ibox) 
+             
+             ! Update trans_layer by emitted layer from above
+             trans_layers_above(1:npoints,ibox) = trans_layers_above(1:npoints,ibox)*(1._wp-dem(1:npoints,ibox))
+          enddo
+       enddo
+
+       ! Add in surface emission
+       bb(1:npoints)=1._wp/( exp(1307.27_wp/skt(1:npoints)) - 1._wp )
+       do ibox=1,ncol
+          fluxtop(1:npoints,ibox) = fluxtop(1:npoints,ibox) + emsfc_lw*bb(1:npoints)*trans_layers_above(1:npoints,ibox) 
+       end do
+
+       ! All Sky brightness temperature
+       boxttop(1:npoints,1:ncol) = 1307.27_wp/(log(1._wp+(1._wp/fluxtop(1:npoints,1:ncol))))
+
+       ! #################################################################################  
+       !                            Cloud-Top Temperature
+       !
+       ! Now that you have the top of atmosphere radiance, account for ISCCP 
+       ! procedures to determine cloud top temperature account for partially
+       ! transmitting cloud recompute flux ISCCP would see assuming a single layer
+       ! cloud. *NOTE* choice here of 2.13, as it is primarily ice clouds which have 
+       ! partial emissivity and need the adjustment performed in this section. If it
+       ! turns out that the cloud brightness temperature is greater than 260K, then 
+       ! the liquid cloud conversion factor of 2.56 is used. *NOTE* that this is 
+       ! discussed on pages 85-87 of the ISCCP D level documentation 
+       ! (Rossow et al. 1996)
+       ! #################################################################################
+
+       ! Compute minimum brightness temperature and optical depth
+       btcmin(1:npoints) = 1._wp /  ( exp(1307.27_wp/(attrop(1:npoints)-5._wp)) - 1._wp ) 
+
+       do ibox=1,ncol
+          transmax(1:npoints) = (fluxtop(1:npoints,ibox)-btcmin) /(fluxtop_clrsky(1:npoints)-btcmin(1:npoints))
+          tauir(1:npoints)    = tau(1:npoints,ibox)/2.13_wp
+          taumin(1:npoints)   = -log(max(min(transmax(1:npoints),0.9999999_wp),0.001_wp))
+          if (isccp_top_height .eq. 1) then
+             do j=1,npoints  
+                if (transmax(j) .gt. 0.001 .and.  transmax(j) .le. 0.9999999) then
+                   fluxtopinit(j) = fluxtop(j,ibox)
+                   tauir(j) = tau(j,ibox)/2.13_wp
+                endif
+             enddo
+             do icycle=1,2
+                do j=1,npoints  
+                   if (tau(j,ibox) .gt. (tauchk)) then 
+                      if (transmax(j) .gt. 0.001 .and.  transmax(j) .le. 0.9999999) then
+                         emcld(j,ibox) = 1._wp - exp(-1._wp * tauir(j)  )
+                         fluxtop(j,ibox) = fluxtopinit(j) - ((1.-emcld(j,ibox))*fluxtop_clrsky(j))
+                         fluxtop(j,ibox)=max(1.E-06_wp,(fluxtop(j,ibox)/emcld(j,ibox)))
+                         tb(j,ibox)= 1307.27_wp / (log(1._wp + (1._wp/fluxtop(j,ibox))))
+                         if (tb(j,ibox) .gt. 260.) then
+                            tauir(j) = tau(j,ibox) / 2.56_wp
+                         end if
+                      end if
+                   end if
+                enddo
+            enddo
+          endif
+
+          ! Cloud-top temperature
+          where(tau(1:npoints,ibox) .gt. tauchk)
+             tb(1:npoints,ibox)= 1307.27_wp/ (log(1. + (1._wp/fluxtop(1:npoints,ibox))))
+             where (isccp_top_height .eq. 1 .and. tauir(1:npoints) .lt. taumin(1:npoints))
+                tb(1:npoints,ibox) = attrop(1:npoints) - 5._wp 
+                tau(1:npoints,ibox) = 2.13_wp*taumin(1:npoints)
+             endwhere
+          endwhere
+          
+          ! Clear-sky brightness temperature
+          where(tau(1:npoints,ibox) .le. tauchk) 
+             tb(1:npoints,ibox) = meantbclr(1:npoints)
+          endwhere
+       enddo
+    else
+       meantbclr(1:npoints) = output_missing_value
+    end if
+
+    ! ####################################################################################
+    !                           Cloud-Top Pressure
+    !
+    ! The 2 methods differ according to whether or not you use the physical cloud
+    ! top pressure (isccp_top_height = 2) or the radiatively determined cloud top
+    ! pressure (isccp_top_height = 1 or 3)
+    ! ####################################################################################
+    do ibox=1,ncol
+       !segregate according to optical thickness
+       if (isccp_top_height .eq. 1 .or. isccp_top_height .eq. 3) then  
+          
+          ! Find level whose temperature most closely matches brightness temperature
+          nmatch(1:npoints)=0
+          do k1=1,nlev-1
+             ilev = merge(nlev-k1,k1,isccp_top_height_direction .eq. 2)        
+             do j=1,npoints 
+                if (ilev           .ge. itrop(j)     .and. &
+                     ((at(j,ilev)  .ge. tb(j,ibox)   .and. &  
+                      at(j,ilev+1) .le. tb(j,ibox))  .or.  &
+                      (at(j,ilev)  .le. tb(j,ibox)   .and. &
+                      at(j,ilev+1) .ge. tb(j,ibox)))) then 
+                   nmatch(j)=nmatch(j)+1
+                   match(j,nmatch(j))=ilev
+                endif
+             enddo
+          enddo
+
+          do j=1,npoints 
+             if (nmatch(j) .ge. 1) then
+                k1 = match(j,nmatch(j))
+                k2 = k1 + 1
+                logp1 = log(pfull(j,k1))
+                logp2 = log(pfull(j,k2))
+                atd = max(tauchk,abs(at(j,k2) - at(j,k1)))
+                logp=logp1+(logp2-logp1)*abs(tb(j,ibox)-at(j,k1))/atd
+                ptop(j,ibox) = exp(logp)
+                levmatch(j,ibox) = merge(k1,k2,abs(pfull(j,k1)-ptop(j,ibox)) .lt. abs(pfull(j,k2)-ptop(j,ibox)))
+             else
+                if (tb(j,ibox) .le. attrop(j)) then
+                   ptop(j,ibox)=ptrop(j)
+                   levmatch(j,ibox)=itrop(j)
+                end if
+                if (tb(j,ibox) .ge. atmax(j)) then
+                   ptop(j,ibox)=pfull(j,nlev)
+                   levmatch(j,ibox)=nlev
+                end if
+             end if
+          enddo
+       else
+          ptop(1:npoints,ibox)=0.
+          do ilev=1,nlev
+             where((ptop(1:npoints,ibox) .eq. 0. ) .and.(frac_out(1:npoints,ibox,ilev) .ne. 0))
+                ptop(1:npoints,ibox)=phalf(1:npoints,ilev)
+                levmatch(1:npoints,ibox)=ilev
+             endwhere
+          end do
+       end if
+       where(tau(1:npoints,ibox) .le. tauchk)
+          ptop(1:npoints,ibox)=0._wp
+          levmatch(1:npoints,ibox)=0._wp
+       endwhere
+    enddo
+
+    ! ####################################################################################
+    !                Compute subcolumn pressure and optical depth
+    ! ####################################################################################
+    boxtau(1:npoints,1:ncol)  = output_missing_value
+    boxptop(1:npoints,1:ncol) = output_missing_value
+    do ibox=1,ncol
+       do j=1,npoints 
+          if (tau(j,ibox) .gt. (tauchk) .and. ptop(j,ibox) .gt. 0.) then
+             if (sunlit(j).eq.1 .or. isccp_top_height .eq. 3) then
+                boxtau(j,ibox) = tau(j,ibox)
+                boxptop(j,ibox) = ptop(j,ibox)!/100._wp
+             endif
+          endif
+       enddo
+    enddo
+
+  end SUBROUTINE ICARUS_SUBCOLUMN
+
+  ! ######################################################################################
+  ! SUBROUTINE icarus_column
+  ! ######################################################################################
+  SUBROUTINE ICARUS_column(npoints,ncol,boxtau,boxptop,sunlit,boxttop,fq_isccp,     &
+                           meanalbedocld,meanptop,meantaucld,totalcldarea,meantb)
+    ! Inputs
+    INTEGER, intent(in) :: &
+         ncol,    & ! Number of subcolumns
+         npoints    ! Number of horizontal gridpoints
+    INTEGER, intent(in),dimension(npoints) :: &
+         sunlit     ! day=1 night=0 
+    REAL(WP),intent(in),dimension(npoints,ncol) ::  &
+         boxttop,  & ! Subcolumn top temperature
+         boxptop,  & ! Subcolumn cloud top pressure
+         boxtau      ! Subcolumn optical depth
+
+    ! Outputs
+    REAL(WP),intent(inout),dimension(npoints) :: &
+         meanalbedocld, & ! Gridmean cloud albedo
+         meanptop,      & ! Gridmean cloud top pressure (mb) - linear averaging
+         meantaucld,    & ! Gridmean optical thickness
+         totalcldarea,  & ! The fraction of model grid box columns with cloud present
+         meantb           ! Gridmean all-sky 10.5 micron brightness temperature 
+    REAL(WP),intent(inout),dimension(npoints,7,7) :: &
+         fq_isccp         ! The fraction of the model grid box covered by clouds
+
+    ! Local Variables
+    INTEGER :: j,ilev,ilev2
+    REAL(WP),dimension(npoints,ncol) :: albedocld
+    LOGICAL, dimension(npoints,ncol) :: box_cloudy
+
+    ! Variables for new joint-histogram implementation
+    logical,dimension(ncol) :: box_cloudy2
+
+    ! ####################################################################################
+    !                           Brightness Temperature
+    ! ####################################################################################
+    if (isccp_top_height .eq. 1 .or. isccp_top_height .eq. 3) then
+       meantb(1:npoints)=sum(boxttop,2)/ncol
+    else
+       meantb(1:npoints) = output_missing_value
+    endif
+
+    ! ####################################################################################
+    !                 Determines ISCCP cloud type frequencies
+    !
+    ! Now that boxptop and boxtau have been determined, determine amount of each of the 
+    ! 49 ISCCP cloud types. Also compute grid box mean cloud top pressure and 
+    ! optical thickness.  The mean cloud top pressure and optical thickness are 
+    ! averages over the cloudy area only. The mean cloud top pressure is a linear
+    ! average of the cloud top pressures. The mean cloud optical thickness is 
+    ! computed by converting optical thickness to an albedo, averaging in albedo 
+    ! units, then converting the average albedo back to a mean optical thickness.  
+    ! ####################################################################################
+
+    ! Initialize
+    albedocld(1:npoints,1:ncol)  = 0._wp
+    box_cloudy(1:npoints,1:ncol) = .false.
+    
+    ! Reset frequencies
+    !fq_isccp = spread(spread(merge(0._wp,output_missing_value,sunlit .eq. 1 .or. isccp_top_height .eq. 3),2,7),2,7)
+    do ilev=1,7
+       do ilev2=1,7
+          do j=1,npoints ! 
+             if (sunlit(j).eq.1 .or. isccp_top_height .eq. 3) then 
+                fq_isccp(j,ilev,ilev2)= 0.
+	     else 
+                fq_isccp(j,ilev,ilev2)= output_missing_value
+             end if
+          enddo
+       enddo
+    enddo
+
+    
+    ! Reset variables need for averaging cloud properties
+    where(sunlit .eq. 1 .or. isccp_top_height .eq. 3)
+       totalcldarea(1:npoints)  = 0._wp
+       meanalbedocld(1:npoints) = 0._wp
+       meanptop(1:npoints)      = 0._wp
+       meantaucld(1:npoints)    = 0._wp
+    elsewhere
+       totalcldarea(1:npoints)  = output_missing_value
+       meanalbedocld(1:npoints) = output_missing_value
+       meanptop(1:npoints)      = output_missing_value
+       meantaucld(1:npoints)    = output_missing_value
+    endwhere
+    
+    ! Compute column quantities and joint-histogram
+    do j=1,npoints 
+       ! Subcolumns that are cloudy(true) and not(false)
+       box_cloudy2(1:ncol) = merge(.true.,.false.,boxtau(j,1:ncol) .gt. tauchk .and. boxptop(j,1:ncol) .gt. 0.)
+
+       ! Compute joint histogram and column quantities for points that are sunlit and cloudy
+       if (sunlit(j) .eq.1 .or. isccp_top_height .eq. 3) then 
+          ! Joint-histogram
+          call hist2D(boxtau(j,1:ncol),boxptop(j,1:ncol),ncol,isccp_histTau,numISCCPTauBins, &
+               isccp_histPres,numISCCPPresBins,fq_isccp(j,1:numISCCPTauBins,1:numISCCPPresBins))
+          fq_isccp(j,1:numISCCPTauBins,1:numISCCPPresBins) = &
+               fq_isccp(j,1:numISCCPTauBins,1:numISCCPPresBins)/ncol
+          
+          ! Column cloud area
+          totalcldarea(j) = real(count(box_cloudy2(1:ncol) .and. boxtau(j,1:ncol) .gt. isccp_taumin))/ncol
+             
+          ! Subcolumn cloud albedo
+          !albedocld(j,1:ncol) = merge((boxtau(j,1:ncol)**0.895_wp)/((boxtau(j,1:ncol)**0.895_wp)+6.82_wp),&
+          !     0._wp,box_cloudy2(1:ncol) .and. boxtau(j,1:ncol) .gt. isccp_taumin)
+          where(box_cloudy2(1:ncol) .and. boxtau(j,1:ncol) .gt. isccp_taumin)
+             albedocld(j,1:ncol) = (boxtau(j,1:ncol)**0.895_wp)/((boxtau(j,1:ncol)**0.895_wp)+6.82_wp)
+          elsewhere
+             albedocld(j,1:ncol) = 0._wp
+          endwhere
+          
+          ! Column cloud albedo
+          meanalbedocld(j) = sum(albedocld(j,1:ncol))/ncol
+          
+          ! Column cloud top pressure
+          meanptop(j) = sum(boxptop(j,1:ncol),box_cloudy2(1:ncol) .and. boxtau(j,1:ncol) .gt. isccp_taumin)/ncol
+       endif
+    enddo
+    
+    ! Compute mean cloud properties. Set to mssing value in the event that totalcldarea=0
+    where(totalcldarea(1:npoints) .gt. 0)
+       meanptop(1:npoints)      = 100._wp*meanptop(1:npoints)/totalcldarea(1:npoints)
+       meanalbedocld(1:npoints) = meanalbedocld(1:npoints)/totalcldarea(1:npoints)
+       meantaucld(1:npoints)    = (6.82_wp/((1._wp/meanalbedocld(1:npoints))-1.))**(1._wp/0.895_wp)
+    elsewhere
+       meanptop(1:nPoints)      = output_missing_value
+       meanalbedocld(1:nPoints) = output_missing_value
+       meantaucld(1:nPoints)    = output_missing_value
+    endwhere
+    !meanptop(1:npoints)      = merge(100._wp*meanptop(1:npoints)/totalcldarea(1:npoints),&
+    !                                 output_missing_value,totalcldarea(1:npoints) .gt. 0)
+    !meanalbedocld(1:npoints) = merge(meanalbedocld(1:npoints)/totalcldarea(1:npoints), &
+    !                                 output_missing_value,totalcldarea(1:npoints) .gt. 0)
+    !meantaucld(1:npoints)    = merge((6.82_wp/((1._wp/meanalbedocld(1:npoints))-1.))**(1._wp/0.895_wp), &
+    !                                 output_missing_value,totalcldarea(1:npoints) .gt. 0)
+
+    ! Represent in percent
+    where(totalcldarea .ne. output_missing_value) totalcldarea = totalcldarea*100._wp
+    where(fq_isccp     .ne. output_missing_value) fq_isccp     = fq_isccp*100._wp
+    
+    
+  end SUBROUTINE ICARUS_column
+  
+  subroutine cosp_simulator_optics(dim1,dim2,dim3,flag,varIN1,varIN2,varOUT)
+    ! INPUTS
+    integer,intent(in) :: &
+         dim1,   & ! Dimension 1 extent (Horizontal)
+         dim2,   & ! Dimension 2 extent (Subcolumn)
+         dim3      ! Dimension 3 extent (Vertical)
+    real(wp),intent(in),dimension(dim1,dim2,dim3) :: &
+         flag      ! Logical to determine the of merge var1IN and var2IN
+    real(wp),intent(in),dimension(dim1,     dim3) :: &
+         varIN1, & ! Input field 1
+         varIN2    ! Input field 2
+    ! OUTPUTS
+    real(wp),intent(out),dimension(dim1,dim2,dim3) :: &
+         varOUT    ! Merged output field
+    ! LOCAL VARIABLES
+    integer :: j
+    
+    varOUT(1:dim1,1:dim2,1:dim3) = 0._wp
+    do j=1,dim2
+       where(flag(:,j,:) .eq. 1)
+          varOUT(:,j,:) = varIN2
+       endwhere
+       where(flag(:,j,:) .eq. 2)
+          varOUT(:,j,:) = varIN1
+       endwhere
+    enddo
+  end subroutine cosp_simulator_optics
+end module MOD_ICARUS
+
Index: DZ6/trunk/libf/phylmd/cospv2/lidar_simulator.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cospv2/lidar_simulator.F90	(revision 5267)
+++ 	(revision )
@@ -1,1561 +1,0 @@
-! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-! Copyright (c) 2009, Centre National de la Recherche Scientifique
-! All rights reserved.
-!
-! Redistribution and use in source and binary forms, with or without modification, are 
-! permitted provided that the following conditions are met:
-!
-! 1. Redistributions of source code must retain the above copyright notice, this list of 
-!    conditions and the following disclaimer.
-!
-! 2. Redistributions in binary form must reproduce the above copyright notice, this list
-!    of conditions and the following disclaimer in the documentation and/or other 
-!    materials provided with the distribution.
-!
-! 3. Neither the name of the copyright holder nor the names of its contributors may be 
-!    used to endorse or promote products derived from this software without specific prior
-!    written permission.
-!
-! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY 
-! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 
-! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL 
-! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 
-! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT 
-! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 
-! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
-! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-!
-! History
-! May 2007: ActSim code of M. Chiriaco and H. Chepfer rewritten by S. Bony
-!
-! May 2008, H. Chepfer:
-! - Units of pressure inputs: Pa 
-! - Non Spherical particles : LS Ice NS coefficients, CONV Ice NS coefficients
-! - New input: ice_type (0=ice-spheres ; 1=ice-non-spherical)
-!
-! June 2008, A. Bodas-Salcedo:
-! - Ported to Fortran 90 and optimisation changes
-!
-! August 2008, J-L Dufresne:
-! - Optimisation changes (sum instructions suppressed)
-!
-! October 2008, S. Bony,  H. Chepfer and J-L. Dufresne :  
-! - Interface with COSP v2.0:
-!      cloud fraction removed from inputs
-!      in-cloud condensed water now in input (instead of grid-averaged value)
-!      depolarisation diagnostic removed
-!      parasol (polder) reflectances (for 5 different solar zenith angles) added
-!
-! December 2008, S. Bony,  H. Chepfer and J-L. Dufresne : 
-! - Modification of the integration of the lidar equation.
-! - change the cloud detection threshold
-!
-! April 2008, A. Bodas-Salcedo:
-! - Bug fix in computation of pmol and pnorm of upper layer
-!
-! April 2008, J-L. Dufresne
-! - Bug fix in computation of pmol and pnorm, thanks to Masaki Satoh: a factor 2 
-! was missing. This affects the ATB values but not the cloud fraction. 
-!
-! January 2013, G. Cesana and H. Chepfer:
-! - Add the perpendicular component of the backscattered signal (pnorm_perp_tot) in the arguments
-! - Add the temperature for each levels (temp) in the arguments
-! - Add the computation of the perpendicular component of the backscattered lidar signal 
-! Reference: Cesana G. and H. Chepfer (2013): Evaluation of the cloud water phase
-! in a climate model using CALIPSO-GOCCP, J. Geophys. Res., doi: 10.1002/jgrd.50376
-!
-! May 2015 - D. Swales - Modified for COSPv2.0
-!
-! Mar 2018 - R. Guzman - Added OPAQ subroutines
-! References OPAQ:
-!
-!       Guzman et al. (2017): Direct atmosphere opacity observations from CALIPSO provide 
-! new constraints on cloud-radiation interactions. JGR-Atmospheres, DOI: 10.1002/2016JD025946
-!       Vaillant de Guelis et al. (2017a): The link between outgoing longwave radiation and
-! the altitude at which a spaceborne lidar beam is fully attenuated. AMT, 10, 4659-4685,
-! https://doi.org/10.5194/amt-10-4659-2017
-!
-! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-module mod_lidar_simulator
-  USE COSP_KINDS,         ONLY: wp
-  USE MOD_COSP_CONFIG,    ONLY: SR_BINS,S_CLD,S_ATT,S_CLD_ATT,R_UNDEF,calipso_histBsct,  &
-                                use_vgrid,vgrid_zl,vgrid_zu,vgrid_z,atlid_histBsct,      &
-                                grLidar532_histBsct,S_CLD_ATLID,S_ATT_ATLID,S_CLD_ATT_ATLID
-  USE MOD_COSP_STATS,     ONLY: COSP_CHANGE_VERTICAL_GRID,hist1d
-  implicit none
-  
-  ! Polynomial coefficients (Alpha, Beta, Gamma) which allow to compute the 
-  ! ATBperpendicular as a function of the ATB for ice or liquid cloud particles 
-  ! derived from CALIPSO-GOCCP observations at 120m vertical grid 
-  ! (Cesana and Chepfer, JGR, 2013).
-  !
-  ! Relationship between ATBice and ATBperp,ice for ice particles:
-  !                ATBperp,ice = Alpha*ATBice 
-  ! Relationship between ATBice and ATBperp,ice for liquid particles:
-  !          ATBperp,ice = Beta*ATBice^2 + Gamma*ATBice
-  real(wp) :: &
-       alpha,beta,gamma    
-
-contains
-  ! ######################################################################################
-  ! SUBROUTINE lidar_subcolumn
-  ! Inputs with a vertical dimensions (nlev) should ordered in along the vertical 
-  ! dimension from TOA-2-SFC, for example: varIN(nlev) is varIN @ SFC. 
-  ! ######################################################################################
-  subroutine lidar_subcolumn(npoints, ncolumns, nlev, lground, beta_mol, tau_mol,        &
-       betatot, tautot, pmol, pnorm, betatot_ice, tautot_ice, betatot_liq, tautot_liq,   &
-       pnorm_perp_tot)
-
-    ! INPUTS
-    INTEGER,intent(in) :: & 
-         npoints,      & ! Number of gridpoints
-         ncolumns,     & ! Number of subcolumns
-         nlev            ! Number of levels
-    logical,intent(in) :: &
-         lground         ! True for ground-based lidar simulator
-    REAL(WP),intent(in),dimension(npoints,nlev) :: &
-         beta_mol,     & ! Molecular backscatter coefficient
-         tau_mol         ! Molecular optical depth
-    REAL(WP),intent(in),dimension(npoints,ncolumns,nlev)       :: &
-         betatot,      & ! 
-         tautot          ! Optical thickess integrated from top
-    ! Optional Inputs
-    REAL(WP),intent(in),dimension(npoints,ncolumns,nlev),optional       :: &         
-         betatot_ice,  & ! Backscatter coefficient for ice particles
-         betatot_liq,  & ! Backscatter coefficient for liquid particles
-         tautot_ice,   & ! Total optical thickness of ice
-         tautot_liq      ! Total optical thickness of liq
-
-    ! OUTPUTS
-    REAL(WP),intent(out),dimension(npoints,nlev) :: &
-         pmol            ! Molecular attenuated backscatter lidar signal power(m^-1.sr^-1)
-    REAL(WP),intent(out),dimension(npoints,ncolumns,nlev) :: &
-         pnorm           ! Molecular backscatter signal power (m^-1.sr^-1)
-    ! Optional outputs
-    REAL(WP),intent(out),dimension(npoints,ncolumns,nlev),optional :: &
-         pnorm_perp_tot  ! Perpendicular lidar backscattered signal power
-
-    ! LOCAL VARIABLES
-    INTEGER :: k,icol,zi,zf,zinc
-    logical :: lphaseoptics
-    REAL(WP),dimension(npoints) :: &
-         tautot_lay        !
-    REAL(WP),dimension(npoints,ncolumns,nlev) :: &
-         pnorm_liq,      & ! Lidar backscattered signal power for liquid
-         pnorm_ice,      & ! Lidar backscattered signal power for ice
-         pnorm_perp_ice, & ! Perpendicular lidar backscattered signal power for ice
-         pnorm_perp_liq, & ! Perpendicular lidar backscattered signal power for liq
-         beta_perp_ice,  & ! Perpendicular backscatter coefficient for ice
-         beta_perp_liq     ! Perpendicular backscatter coefficient for liquid
-
-    ! Phase optics?
-    lphaseoptics=.false.
-    if (present(betatot_ice) .and. present(betatot_liq) .and. present(tautot_liq) .and. &
-         present(tautot_ice)) lphaseoptics=.true.
-    
-    ! Is this lidar spaceborne (default) or ground-based?
-    if (lground) then
-       zi   = nlev
-       zf   = 1
-       zinc = -1
-    else
-       zi   = 1
-       zf   = nlev
-       zinc = 1
-    endif    
-
-    ! ####################################################################################
-    ! *) Molecular signal
-    ! ####################################################################################
-    call cmp_backsignal(nlev,npoints,beta_mol(1:npoints,zi:zf:zinc),&
-                        tau_mol(1:npoints,zi:zf:zinc),pmol(1:npoints,zi:zf:zinc))
-                        
-    ! ####################################################################################
-    ! PLANE PARRALLEL FIELDS
-    ! ####################################################################################
-    do icol=1,ncolumns
-       ! #################################################################################
-       ! *) Total Backscatter signal
-       ! #################################################################################
-       call cmp_backsignal(nlev,npoints,betatot(1:npoints,icol,zi:zf:zinc),&
-            tautot(1:npoints,icol,zi:zf:zinc),pnorm(1:npoints,icol,zi:zf:zinc))
-       
-       ! #################################################################################
-       ! *) Ice/Liq Backscatter signal
-       ! #################################################################################
-       if (lphaseoptics) then
-          ! Computation of the ice and liquid lidar backscattered signal (ATBice and ATBliq)
-          ! Ice only
-          call cmp_backsignal(nlev,npoints,betatot_ice(1:npoints,icol,zi:zf:zinc),&
-               tautot_ice(1:npoints,icol,zi:zf:zinc), pnorm_ice(1:npoints,icol,zi:zf:zinc))
-          ! Liquid only
-          call cmp_backsignal(nlev,npoints,betatot_liq(1:npoints,icol,zi:zf:zinc),&
-               tautot_liq(1:npoints,icol,zi:zf:zinc), pnorm_liq(1:npoints,icol,zi:zf:zinc))
-       endif
-    enddo
-
-    ! ####################################################################################
-    ! PERDENDICULAR FIELDS (Only needed if distinguishing by phase (ice/liquid))
-    ! ####################################################################################
-    if (lphaseoptics) then
-       do icol=1,ncolumns
-          ! #################################################################################
-          ! *) Ice/Liq Perpendicular Backscatter signal
-          ! #################################################################################
-          ! Computation of ATBperp,ice/liq from ATBice/liq including the multiple scattering 
-          ! contribution (Cesana and Chepfer 2013, JGR)
-          do k=1,nlev
-             ! Ice particles
-             pnorm_perp_ice(1:npoints,icol,k) = Alpha * pnorm_ice(1:npoints,icol,k)
-             
-             ! Liquid particles
-             pnorm_perp_liq(1:npoints,icol,k) = 1000._wp*Beta*pnorm_liq(1:npoints,icol,k)**2+&
-                  Gamma*pnorm_liq(1:npoints,icol,k) 
-          enddo
-          
-          ! #################################################################################
-          ! *) Computation of beta_perp_ice/liq using the lidar equation
-          ! #################################################################################
-          ! Ice only
-          call cmp_beta(nlev,npoints,pnorm_perp_ice(1:npoints,icol,zi:zf:zinc),&
-               tautot_ice(1:npoints,icol,zi:zf:zinc),beta_perp_ice(1:npoints,icol,zi:zf:zinc))        
-          
-          ! Liquid only
-          call cmp_beta(nlev,npoints,pnorm_perp_liq(1:npoints,icol,zi:zf:zinc),&
-               tautot_liq(1:npoints,icol,zi:zf:zinc),beta_perp_liq(1:npoints,icol,zi:zf:zinc))
-          
-          ! #################################################################################
-          ! *) Perpendicular Backscatter signal
-          ! #################################################################################
-          ! Computation of the total perpendicular lidar signal (ATBperp for liq+ice)
-          ! Upper layer
-          WHERE(tautot(1:npoints,icol,1) .gt. 0)
-             pnorm_perp_tot(1:npoints,icol,1) = (beta_perp_ice(1:npoints,icol,1)+           &
-                  beta_perp_liq(1:npoints,icol,1)-                                          &
-                  (beta_mol(1:npoints,1)/(1._wp+1._wp/0.0284_wp))) /                        &
-                  (2._wp*tautot(1:npoints,icol,1))*                                         &
-                  (1._wp-exp(-2._wp*tautot(1:npoints,icol,1)))
-          ELSEWHERE
-             pnorm_perp_tot(1:npoints,icol,1) = 0._wp
-          ENDWHERE
-          
-          ! Other layers
-          do k=2,nlev
-             ! Optical thickness of layer k
-             tautot_lay(1:npoints) = tautot(1:npoints,icol,k)-tautot(1:npoints,icol,k-1) 
-             
-             ! The perpendicular component of the molecular backscattered signal (Betaperp) 
-             ! has been taken into account two times (once for liquid and once for ice). 
-             ! We remove one contribution using 
-             ! Betaperp=beta_mol(:,k)/(1+1/0.0284)) [bodhaine et al. 1999] in the following 
-             ! equations:
-             WHERE (pnorm(1:npoints,icol,k) .eq. 0)
-                pnorm_perp_tot(1:npoints,icol,k)=0._wp
-             ELSEWHERE
-                where(tautot_lay(1:npoints) .gt. 0.)
-                   pnorm_perp_tot(1:npoints,icol,k) = (beta_perp_ice(1:npoints,icol,k)+     &
-                        beta_perp_liq(1:npoints,icol,k)-(beta_mol(1:npoints,k)/(1._wp+1._wp/  &
-                        0.0284_wp)))*EXP(-2._wp*tautot(1:npoints,icol,k-1))/                  &
-                        (2._wp*tautot_lay(1:npoints))* (1._wp-EXP(-2._wp*tautot_lay(1:npoints)))
-                elsewhere
-                   pnorm_perp_tot(1:npoints,icol,k) = (beta_perp_ice(1:npoints,icol,k)+     &
-                        beta_perp_liq(1:npoints,icol,k)-(beta_mol(1:npoints,k)/(1._wp+1._wp/  &
-                        0.0284_wp)))*EXP(-2._wp*tautot(1:npoints,icol,k-1))
-                endwhere
-             ENDWHERE
-          END DO
-       enddo
-    end if
-  end subroutine lidar_subcolumn
-
-  ! ######################################################################################
-  ! SUBROUTINE lidar_column
-  ! ######################################################################################
-  subroutine lidar_column(npoints, ncol, nlevels, llm, max_bin, ntype, platform, pnorm, pmol,             &
-       pplay, zlev, zlev_half, vgrid_z, ok_lidar_cfad, ncat, cfad2, lidarcld, cldlayer,  &
-       ! Optional stuff below
-       tmp, pnorm_perp, surfelev,  lidarcldphase, lidarcldtype, cldtype, cldtypetemp, &
-       cldtypemeanz, cldtypemeanzse, cldthinemis, cldlayerphase, lidarcldtmp)
-
-    integer,parameter :: &
-         nphase = 6 ! Number of cloud layer phase types
-
-    ! Inputs
-    integer,intent(in) :: &
-         npoints, & ! Number of horizontal grid points
-         ncol,    & ! Number of subcolumns
-         nlevels, & ! Number of vertical layers (OLD grid)
-         llm,     & ! Number of vertical layers (NEW grid)
-         max_bin, & ! Number of bins for SR CFADs
-         ncat,    & ! Number of cloud layer types (low,mid,high,total) 
-         ntype      ! Number of OPAQ products (opaque/thin cloud + z_opaque)
-    character(len=*),intent(in) :: &
-         platform   ! Name of platform (e.g. calipso,atlid,grLidar532)
-    real(wp),intent(in),dimension(npoints,ncol,Nlevels) :: &
-         pnorm      ! Lidar ATB
-    real(wp),intent(in),dimension(npoints,Nlevels) :: &
-         pmol,    & ! Molecular ATB
-         pplay      ! Pressure on model levels (Pa)
-    logical,intent(in) :: &
-         ok_lidar_cfad ! True if lidar CFAD diagnostics need to be computed
-    real(wp),intent(in),dimension(npoints,nlevels) :: &
-         zlev        ! Model full levels
-    real(wp),intent(in),dimension(npoints,nlevels+1) :: &
-         zlev_half   ! Model half levels
-    real(wp),intent(in),dimension(llm) :: & 
-         vgrid_z     ! mid-level altitude of the output vertical grid
-    ! Optional Inputs
-    real(wp),intent(in),dimension(npoints,ncol,Nlevels),optional :: &
-         pnorm_perp ! Lidar perpendicular ATB
-    real(wp),intent(in),dimension(npoints),optional :: &
-         surfelev   ! Surface Elevation (m)
-    real(wp),intent(in),dimension(npoints,Nlevels),optional :: &
-         tmp        ! Temperature at each levels
-    
-    ! Outputs
-    real(wp),intent(inout),dimension(npoints,llm) :: &
-         lidarcld      ! 3D "lidar" cloud fraction
-    real(wp),intent(inout),dimension(npoints,ncat) :: &
-         cldlayer      ! "lidar" cloud layer fraction (low, mid, high, total)
-    real(wp),intent(inout),dimension(npoints,max_bin,llm) :: &
-         cfad2         ! CFADs of SR
-    ! Optional Outputs
-    real(wp),intent(out),dimension(npoints,ntype),optional :: & 
-         cldtype,    & ! "lidar" OPAQ type covers (opaque/thin cloud + z_opaque)
-         cldtypetemp   ! Opaque and thin clouds + z_opaque temperature
-    real(wp),intent(out),dimension(npoints,2),optional :: &  
-         cldtypemeanz  ! Opaque and thin clouds altitude 
-    real(wp),intent(out),dimension(npoints,3),optional :: &  
-         cldtypemeanzse ! Opaque, thin clouds and z_opaque altitude with respect to SE
-    real(wp),intent(out),dimension(npoints),optional :: &   
-         cldthinemis   ! Thin clouds emissivity computed from SR
-    real(wp),intent(out),dimension(npoints,llm,nphase),optional :: &
-         lidarcldphase ! 3D "lidar" phase cloud fraction
-    real(wp),intent(out),dimension(npoints,llm,ntype+1),optional :: & 
-         lidarcldtype ! 3D "lidar" OPAQ type fraction 
-    real(wp),intent(out),dimension(npoints,40,5),optional :: &
-         lidarcldtmp   ! 3D "lidar" phase cloud fraction as a function of temp
-    real(wp),intent(out),dimension(npoints,ncat,nphase),optional :: &
-         cldlayerphase ! "lidar" phase low mid high cloud fraction
-
-    ! Local Variables
-    integer :: ic,i,j
-    logical :: lcalipso,latlid,lgrlidar532
-    real(wp),dimension(npoints,ncol,llm) :: &
-         x3d
-    real(wp),dimension(npoints,llm) :: &
-         x3d_c,pnorm_c
-    real(wp)  :: &
-         xmax
-    real(wp),dimension(npoints,1,Nlevels) :: t_in,ph_in,betamol_in
-    real(wp),dimension(npoints,ncol,llm)  :: pnormFlip,pnorm_perpFlip
-    real(wp),dimension(npoints,1,llm)     :: tmpFlip,pplayFlip,betamolFlip
-    real(wp),dimension(SR_BINS+1)         :: histBsct
-    
-    ! Which lidar platform?
-    lcalipso = .false.
-    latlid = .false.
-    lgrlidar532 = .false.
-    if (platform .eq. 'calipso') lcalipso=.true.
-    if (platform .eq. 'atlid') latlid=.true.
-    if (platform .eq. 'grlidar532') lgrlidar532=.true.
-        
-    ! Vertically regrid input data
-    if (use_vgrid) then 
-       ph_in(:,1,:) = pplay(:,nlevels:1:-1)
-       call cosp_change_vertical_grid(Npoints,1,Nlevels,zlev(:,nlevels:1:-1),zlev_half(:,nlevels:1:-1),&
-            ph_in,llm,vgrid_zl(llm:1:-1),vgrid_zu(llm:1:-1),pplayFlip(:,1,llm:1:-1))
-       betamol_in(:,1,:) = pmol(:,nlevels:1:-1)
-       call cosp_change_vertical_grid(Npoints,1,Nlevels,zlev(:,nlevels:1:-1),zlev_half(:,nlevels:1:-1),&
-            betamol_in,llm,vgrid_zl(llm:1:-1),vgrid_zu(llm:1:-1),betamolFlip(:,1,llm:1:-1))
-       call cosp_change_vertical_grid(Npoints,Ncol,Nlevels,zlev(:,nlevels:1:-1),zlev_half(:,nlevels:1:-1),&
-            pnorm(:,:,nlevels:1:-1),llm,vgrid_zl(llm:1:-1),vgrid_zu(llm:1:-1),pnormFlip(:,:,llm:1:-1))
-       if (lcalipso) then
-          t_in(:,1,:)=tmp(:,nlevels:1:-1)
-          call cosp_change_vertical_grid(Npoints,1,Nlevels,zlev(:,nlevels:1:-1),zlev_half(:,nlevels:1:-1),&
-               t_in,llm,vgrid_zl(llm:1:-1),vgrid_zu(llm:1:-1),tmpFlip(:,1,llm:1:-1))
-          call cosp_change_vertical_grid(Npoints,Ncol,Nlevels,zlev(:,nlevels:1:-1),zlev_half(:,nlevels:1:-1),&
-               pnorm_perp(:,:,nlevels:1:-1),llm,vgrid_zl(llm:1:-1),vgrid_zu(llm:1:-1),pnorm_perpFlip(:,:,llm:1:-1))
-       endif
-    endif
-
-    ! Initialization (The histogram bins, are set up during initialization and the
-    ! maximum value is used as the upper bounds.)
-    if (lcalipso)    then
-       xmax = maxval(calipso_histBsct)
-       histBsct = calipso_histBsct
-    endif
-    if (latlid)      then
-       xmax = maxval(atlid_histBsct)
-       histBsct = atlid_histBsct
-    endif
-    if (lgrlidar532) then
-       xmax = maxval(grLidar532_histBsct)
-       histBsct = grLidar532_histBsct
-    endif
-       
-    ! Compute LIDAR scattering ratio
-    if (use_vgrid) then
-       do ic = 1, ncol
-          pnorm_c = pnormFlip(:,ic,:)
-          where ((pnorm_c .lt. xmax) .and. (betamolFlip(:,1,:) .lt. xmax) .and.          &
-                (betamolFlip(:,1,:) .gt. 0.0 ))
-             x3d_c = pnorm_c/betamolFlip(:,1,:)
-          elsewhere
-             x3d_c = R_UNDEF
-          end where
-          x3d(:,ic,:) = x3d_c
-       enddo
-       if (lcalipso) then
-          ! Diagnose cloud fractions for subcolumn lidar scattering ratios
-          CALL COSP_CLDFRAC(npoints,ncol,llm,ncat,nphase,tmpFlip,x3d,pnormFlip,pnorm_perpFlip,&
-               pplayFlip,S_att,S_cld,S_cld_att,R_UNDEF,lidarcld,cldlayer,lidarcldphase,&
-               cldlayerphase,lidarcldtmp)                         
-
-          ! Calipso opaque cloud diagnostics
-          CALL COSP_OPAQ(npoints,ncol,llm,ntype,tmpFlip,x3d,S_att,S_cld,R_UNDEF,lidarcldtype, &
-               cldtype,cldtypetemp,cldtypemeanz,cldtypemeanzse,cldthinemis,vgrid_z,surfelev)
-       endif
-       if (latlid) then
-          CALL COSP_CLDFRAC_NOPHASE(npoints,ncol,llm,ncat,x3d,pnormFlip,pplayFlip,  &
-               S_att_atlid,S_cld_atlid,S_cld_att_atlid,R_UNDEF,lidarcld,cldlayer)   
-       endif
-       if (lgrLidar532) then
-          CALL COSP_CLDFRAC_NOPHASE(npoints,ncol,llm,ncat,x3d,pnormFlip,pplayFlip,  &
-               S_att,S_cld,S_cld_att,R_UNDEF,lidarcld,cldlayer)
-       endif
-    else
-       do ic = 1, ncol
-          pnorm_c = pnorm(:,ic,:)
-          where ((pnorm_c.lt.xmax) .and. (pmol.lt.xmax) .and. (pmol.gt. 0.0 ))
-             x3d_c = pnorm_c/pmol
-          elsewhere
-             x3d_c = R_UNDEF
-          end where
-          x3d(:,ic,:) = x3d_c
-       enddo
-       if (lcalipso) then
-          ! Diagnose cloud fractions for subcolumn lidar scattering ratios
-          CALL COSP_CLDFRAC(npoints,ncol,nlevels,ncat,nphase,tmp,x3d,pnorm,pnorm_perp,pplay,&
-               S_att,S_cld,S_cld_att,R_UNDEF,lidarcld,cldlayer,lidarcldphase,  &
-               cldlayerphase,lidarcldtmp)
-          ! Calipso opaque cloud diagnostics
-          CALL COSP_OPAQ(npoints,ncol,nlevels,ntype,tmp,x3d,S_att,S_cld,R_UNDEF,lidarcldtype, &
-               cldtype,cldtypetemp,cldtypemeanz,cldtypemeanzse,cldthinemis,vgrid_z,surfelev)
-       endif
-       if (latlid) then
-          CALL COSP_CLDFRAC_NOPHASE(npoints,ncol,nlevels,ncat,x3d,pnorm,pplay,  &
-               S_att_atlid,S_cld_atlid,S_cld_att_atlid, R_UNDEF,lidarcld,cldlayer)
-       endif
-       if (lgrlidar532) then
-          CALL COSP_CLDFRAC_NOPHASE(npoints,ncol,nlevels,ncat,x3d,pnorm,pplay,      &
-               S_att,S_cld,S_cld_att,R_UNDEF,lidarcld,cldlayer)
-       endif
-    endif
-
-    ! CFADs
-    if (ok_lidar_cfad) then
-       ! CFADs of subgrid-scale lidar scattering ratios
-       do i=1,Npoints
-          do j=1,llm
-             cfad2(i,:,j) = hist1D(ncol,x3d(i,:,j),SR_BINS,histBsct)
-          enddo
-       enddo
-       where(cfad2 .ne. R_UNDEF) cfad2=cfad2/ncol
-    endif 
-    
-    ! Unit conversions
-    where(lidarcld /= R_UNDEF)      lidarcld      = lidarcld*100._wp
-    where(cldlayer /= R_UNDEF)      cldlayer      = cldlayer*100._wp
-    if (lcalipso) then
-       where(cldtype(:,1) /= R_UNDEF)  cldtype(:,1)  = cldtype(:,1)*100._wp
-       where(cldtype(:,2) /= R_UNDEF)  cldtype(:,2)  = cldtype(:,2)*100._wp
-       where(cldlayerphase /= R_UNDEF) cldlayerphase = cldlayerphase*100._wp
-       where(lidarcldphase /= R_UNDEF) lidarcldphase = lidarcldphase*100._wp
-       where(lidarcldtype /= R_UNDEF)  lidarcldtype  = lidarcldtype*100._wp
-       where(lidarcldtmp /= R_UNDEF)   lidarcldtmp   = lidarcldtmp*100._wp
-    endif
-  end subroutine lidar_column
-
-  ! ######################################################################################
-  ! The subroutines below compute the attenuated backscatter signal and the lidar 
-  ! backscatter coefficients using eq (1) from doi:0094-8276/08/2008GL034207
-  ! ######################################################################################
-  subroutine cmp_backsignal(nlev,npoints,beta,tau,pnorm)
-    ! INPUTS
-    integer, intent(in) :: nlev,npoints
-    real(wp),intent(in),dimension(npoints,nlev) :: beta,tau
-
-    ! OUTPUTS
-    real(wp),intent(out),dimension(npoints,nlev) :: pnorm
-
-    ! Internal Variables
-    real(wp), dimension(npoints) :: tautot_lay
-    integer :: k
-
-    ! Uppermost layer 
-    pnorm(:,1) = beta(:,1) / (2._wp*tau(:,1)) * (1._wp-exp(-2._wp*tau(:,1)))
-
-    ! Other layers
-    do k=2,nlev
-       tautot_lay(:) = tau(:,k)-tau(:,k-1) 
-       WHERE (tautot_lay(:) .gt. 0.)
-          pnorm(:,k) = beta(:,k)*EXP(-2._wp*tau(:,k-1)) /&
-               (2._wp*tautot_lay(:))*(1._wp-EXP(-2._wp*tautot_lay(:)))
-       ELSEWHERE
-          ! This must never happen, but just in case, to avoid div. by 0
-          pnorm(:,k) = beta(:,k) * EXP(-2._wp*tau(:,k-1))
-       END WHERE
-
-    END DO
-  end subroutine cmp_backsignal
-
-  subroutine cmp_beta(nlev,npoints,pnorm,tau,beta)
-    ! INPUTS
-    integer, intent(in) :: nlev,npoints
-    real(wp),intent(in),dimension(npoints,nlev) :: pnorm,tau
-
-    ! OUTPUTS
-    real(wp),intent(out),dimension(npoints,nlev) :: beta
-
-    ! Internal Variables
-    real(wp), dimension(npoints) :: tautot_lay
-    integer :: k
-    real(wp) :: epsrealwp
-
-    epsrealwp = epsilon(1._wp)
-    beta(:,1) = pnorm(:,1) * (2._wp*tau(:,1))/(1._wp-exp(-2._wp*tau(:,1)))
-    do k=2,nlev
-       tautot_lay(:) = tau(:,k)-tau(:,k-1)       
-       WHERE ( EXP(-2._wp*tau(:,k-1)) .gt. epsrealwp )
-          WHERE (tautot_lay(:) .gt. 0.)
-             beta(:,k) = pnorm(:,k)/ EXP(-2._wp*tau(:,k-1))* &
-                  (2._wp*tautot_lay(:))/(1._wp-exp(-2._wp*tautot_lay(:)))
-          ELSEWHERE
-             beta(:,k)=pnorm(:,k)/EXP(-2._wp*tau(:,k-1))
-          END WHERE
-       ELSEWHERE
-          beta(:,k)=pnorm(:,k)/epsrealwp
-       END WHERE
-    ENDDO
-
-  end subroutine cmp_beta
-    ! ####################################################################################
-    ! SUBROUTINE cosp_cldfrac
-    ! Conventions: Ncat must be equal to 4
-    ! ####################################################################################
-    SUBROUTINE COSP_CLDFRAC(Npoints,Ncolumns,Nlevels,Ncat,Nphase,tmp,x,ATB,ATBperp,      &
-                               pplay,S_att,S_cld,S_cld_att,undef,lidarcld,cldlayer,      &
-                               lidarcldphase,cldlayerphase,lidarcldtemp)
-    ! Parameters
-    integer,parameter :: Ntemp=40 ! indice of the temperature vector
-    real(wp),parameter,dimension(Ntemp+1) :: &
-       tempmod = [0.0,   183.15,186.15,189.15,192.15,195.15,198.15,201.15,204.15,207.15, &
-                  210.15,213.15,216.15,219.15,222.15,225.15,228.15,231.15,234.15,237.15, &
-                  240.15,243.15,246.15,249.15,252.15,255.15,258.15,261.15,264.15,267.15, &
-                  270.15,273.15,276.15,279.15,282.15,285.15,288.15,291.15,294.15,297.15, &
-                  473.15]
-         
-    ! Polynomial coefficient of the phase discrimination line used to separate liquid from ice
-    ! (Cesana and Chepfer, JGR, 2013)
-    ! ATBperp = ATB^5*alpha50 + ATB^4*beta50 + ATB^3*gamma50 + ATB^2*delta50 + ATB*epsilon50 + zeta50
-    real(wp),parameter :: &
-       alpha50   = 9.0322e+15_wp,  & !
-       beta50    = -2.1358e+12_wp, & !
-       gamma50   = 173.3963e06_wp, & !
-       delta50   = -3.9514e03_wp,  & !
-       epsilon50 = 0.2559_wp,      & !
-       zeta50    = -9.4776e-07_wp    ! 
-       
-	! Inputs
-    integer,intent(in) :: &
-       Npoints,  & ! Number of gridpoints
-       Ncolumns, & ! Number of subcolumns
-       Nlevels,  & ! Number of vertical levels
-       Ncat,     & ! Number of cloud layer types
-       Nphase      ! Number of cloud layer phase types
-	               ! [ice,liquid,undefined,false ice,false liquid,Percent of ice]
-    real(wp),intent(in) :: &
-       S_att,    & !
-       S_cld,    & !
-       S_cld_att,& ! New threshold for undefine cloud phase detection
-       undef       ! Undefined value
-    real(wp),intent(in),dimension(Npoints,Ncolumns,Nlevels) :: &
-       x,        & ! 
-       ATB,      & ! 3D attenuated backscatter
-       ATBperp     ! 3D attenuated backscatter (perpendicular)
-    real(wp),intent(in),dimension(Npoints,Nlevels) :: &
-       tmp,      & ! Temperature   
-       pplay       ! Pressure
-
-	! Outputs
-    real(wp),intent(out),dimension(Npoints,Ntemp,5) :: &
-       lidarcldtemp  ! 3D Temperature 1=tot,2=ice,3=liq,4=undef,5=ice/ice+liq
-    real(wp),intent(out),dimension(Npoints,Nlevels,Nphase) :: &
-       lidarcldphase ! 3D cloud phase fraction
-    real(wp),intent(out),dimension(Npoints,Nlevels) :: &
-       lidarcld      ! 3D cloud fraction
-    real(wp),intent(out),dimension(Npoints,Ncat) :: &
-       cldlayer      ! Low, middle, high, total cloud fractions
-    real(wp),intent(out),dimension(Npoints,Ncat,Nphase) :: &
-       cldlayerphase ! Low, middle, high, total cloud fractions for ice liquid and undefine phase    
-    
-    ! Local variables
-    integer  :: &
-       ip, k, iz, ic, ncol, nlev, i, itemp, toplvlsat 
-    real(wp) :: &
-       p1,checktemp, ATBperp_tmp,checkcldlayerphase, checkcldlayerphase2
-    real(wp),dimension(Npoints,Nlevels) :: &
-       nsub,lidarcldphasetmp   
-    real(wp),dimension(Npoints,Ntemp) :: &
-       sumlidarcldtemp,lidarcldtempind
-    real(wp),dimension(Npoints,Ncolumns,Ncat) :: &
-       cldlay,nsublay   
-    real(wp),dimension(Npoints,Ncat) :: &
-       nsublayer,cldlayerphasetmp,cldlayerphasesum
-    real(wp),dimension(Npoints,Ncolumns,Nlevels) :: &   
-       tmpi, & ! Temperature of ice cld
-       tmpl, & ! Temperature of liquid cld
-       tmpu, & ! Temperature of undef cld
-       cldy, & ! 
-       srok    !
-    real(wp),dimension(Npoints,Ncolumns,Ncat,Nphase) :: &
-       cldlayphase ! subgrided low mid high phase cloud fraction
-             
-    ! ####################################################################################
-	! 1) Initialize    
-    ! ####################################################################################
-    lidarcld              = 0._wp
-    nsub                  = 0._wp
-    cldlay                = 0._wp
-    nsublay               = 0._wp
-    ATBperp_tmp           = 0._wp
-    lidarcldphase(:,:,:)  = 0._wp
-    cldlayphase(:,:,:,:)  = 0._wp
-    cldlayerphase(:,:,:)  = 0._wp
-    tmpi(:,:,:)           = 0._wp
-    tmpl(:,:,:)           = 0._wp
-    tmpu(:,:,:)           = 0._wp
-    cldlayerphasesum(:,:) = 0._wp
-    lidarcldtemp(:,:,:)   = 0._wp
-    lidarcldtempind(:,:)  = 0._wp
-    sumlidarcldtemp(:,:)  = 0._wp
-    lidarcldphasetmp(:,:) = 0._wp
-    toplvlsat             = 0
-
-    ! ####################################################################################
-    ! 2) Cloud detection
-    ! ####################################################################################
-    do k=1,Nlevels
-       ! Cloud detection at subgrid-scale:
-       where ((x(:,:,k) .gt. S_cld) .and. (x(:,:,k) .ne. undef) )
-          cldy(:,:,k)=1._wp
-       elsewhere
-          cldy(:,:,k)=0._wp
-       endwhere
-       
-       ! Number of usefull sub-columns:
-       where ((x(:,:,k) .gt. S_att) .and. (x(:,:,k) .ne. undef) )
-          srok(:,:,k)=1._wp
-       elsewhere
-          srok(:,:,k)=0._wp
-       endwhere
-    enddo    
-    
-    ! ####################################################################################
-    ! 3) Grid-box 3D cloud fraction and layered cloud fractions(ISCCP pressure categories)
-    ! ####################################################################################
-    lidarcld = 0._wp
-    nsub     = 0._wp
-    cldlay   = 0._wp
-    nsublay  = 0._wp
-    do k=1,Nlevels
-       do ic = 1, Ncolumns
-          do ip = 1, Npoints
-          
-             ! Computation of the cloud fraction as a function of the temperature instead
-             ! of height, for ice,liquid and all clouds
-             if(srok(ip,ic,k).gt.0.)then
-                do itemp=1,Ntemp
-                   if( (tmp(ip,k).ge.tempmod(itemp)).and.(tmp(ip,k).lt.tempmod(itemp+1)) )then
-                      lidarcldtempind(ip,itemp)=lidarcldtempind(ip,itemp)+1._wp
-                   endif
-                enddo
-             endif
-             
-             if(cldy(ip,ic,k).eq.1.)then
-                do itemp=1,Ntemp 
-                   if( (tmp(ip,k) .ge. tempmod(itemp)).and.(tmp(ip,k) .lt. tempmod(itemp+1)) )then
-                      lidarcldtemp(ip,itemp,1)=lidarcldtemp(ip,itemp,1)+1._wp
-                   endif
-                enddo
-             endif
-
-             iz=1
-             p1 = pplay(ip,k)
-             if ( p1.gt.0. .and. p1.lt.(440._wp*100._wp)) then ! high clouds
-                iz=3
-             else if(p1.ge.(440._wp*100._wp) .and. p1.lt.(680._wp*100._wp)) then ! mid clouds
-                iz=2
-             endif
-             
-             cldlay(ip,ic,iz) = MAX(cldlay(ip,ic,iz),cldy(ip,ic,k))
-             cldlay(ip,ic,4)  = MAX(cldlay(ip,ic,4),cldy(ip,ic,k))
-             lidarcld(ip,k)   = lidarcld(ip,k) + cldy(ip,ic,k)
-             
-             nsublay(ip,ic,iz) = MAX(nsublay(ip,ic,iz),srok(ip,ic,k))
-             nsublay(ip,ic,4)  = MAX(nsublay(ip,ic,4),srok(ip,ic,k))
-             nsub(ip,k)        = nsub(ip,k) + srok(ip,ic,k)
-             
-          enddo
-       enddo
-    enddo   
-    
-    ! Grid-box 3D cloud fraction
-    where ( nsub(:,:).gt.0.0 )
-       lidarcld(:,:) = lidarcld(:,:)/nsub(:,:)
-    elsewhere
-       lidarcld(:,:) = undef
-    endwhere
-    
-    ! Layered cloud fractions
-    cldlayer  = 0._wp
-    nsublayer = 0._wp
-    do iz = 1, Ncat
-       do ic = 1, Ncolumns
-          cldlayer(:,iz)  = cldlayer(:,iz)  + cldlay(:,ic,iz)
-          nsublayer(:,iz) = nsublayer(:,iz) + nsublay(:,ic,iz)
-       enddo
-    enddo
-    where (nsublayer(:,:) .gt. 0.0)
-       cldlayer(:,:) = cldlayer(:,:)/nsublayer(:,:)
-    elsewhere
-       cldlayer(:,:) = undef
-    endwhere
-              
-    ! ####################################################################################
-    ! 4) Grid-box 3D cloud Phase
-    ! ####################################################################################
-    
-    ! ####################################################################################
-    ! 4.1) For Cloudy pixels with 8.16km < z < 19.2km
-    ! ####################################################################################
-    do ncol=1,Ncolumns
-       do i=1,Npoints          
-          do nlev=1,23 ! from 19.2km until 8.16km
-               p1 = pplay(1,nlev)
-
-             ! Avoid zero values
-             if( (cldy(i,ncol,nlev).eq.1.) .and. (ATBperp(i,ncol,nlev).gt.0.) )then
-                ! Computation of the ATBperp along the phase discrimination line
-                ATBperp_tmp = (ATB(i,ncol,nlev)**5)*alpha50 + (ATB(i,ncol,nlev)**4)*beta50 + &
-                     (ATB(i,ncol,nlev)**3)*gamma50 + (ATB(i,ncol,nlev)**2)*delta50 + &
-                     ATB(i,ncol,nlev)*epsilon50 + zeta50     
-                ! ########################################################################
-                ! 4.1.a) Ice: ATBperp above the phase discrimination line
-                ! ########################################################################
-                if((ATBperp(i,ncol,nlev)-ATBperp_tmp) .ge. 0.)then ! Ice clouds
-
-                   ! ICE with temperature above 273,15°K = Liquid (false ice)
-                   if(tmp(i,nlev) .gt. 273.15) then ! Temperature above 273,15 K
-                     ! Liquid: False ice corrected by the temperature to Liquid
-                      lidarcldphase(i,nlev,2) = lidarcldphase(i,nlev,2)+1._wp ! False ice detection ==> added to Liquid
-                                    
-                      tmpl(i,ncol,nlev)       = tmp(i,nlev)
-                      lidarcldphase(i,nlev,5) = lidarcldphase(i,nlev,5)+1._wp ! Keep the information "temperature criterium used"                      
-                                                                              ! to classify the phase cloud
-                      cldlayphase(i,ncol,4,2) = 1. ! tot cloud
-                      if (p1 .gt. 0. .and. p1.lt.(440._wp*100._wp)) then ! high cloud
-                         cldlayphase(i,ncol,3,2) = 1._wp
-                      else if(p1 .ge. (440._wp*100._wp) .and. p1 .lt. (680._wp*100._wp)) then ! mid cloud
-                         cldlayphase(i,ncol,2,2) = 1._wp
-                      else ! low cloud
-                         cldlayphase(i,ncol,1,2) = 1._wp
-                      endif
-                      cldlayphase(i,ncol,4,5) = 1._wp ! tot cloud
-                      ! High cloud
-                      if (p1 .gt. 0. .and. p1 .lt. (440._wp*100._wp)) then 
-                         cldlayphase(i,ncol,3,5) = 1._wp
-                      ! Middle cloud
-                      else if(p1 .ge. (440._wp*100._wp) .and. p1 .lt. (680._wp*100._wp)) then
-                         cldlayphase(i,ncol,2,5) = 1._wp
-                      ! Low cloud
-                      else 
-                         cldlayphase(i,ncol,1,5) = 1._wp
-                      endif
-                   else
-                      ! ICE with temperature below 273,15°K
-                      lidarcldphase(i,nlev,1) = lidarcldphase(i,nlev,1)+1._wp
-                      tmpi(i,ncol,nlev)       = tmp(i,nlev)
-                      cldlayphase(i,ncol,4,1) = 1._wp ! tot cloud 
-                      ! High cloud
-                      if (p1 .gt. 0. .and. p1 .lt. (440._wp*100._wp)) then 
-                         cldlayphase(i,ncol,3,1) = 1._wp
-                      ! Middle cloud   
-                      else if(p1 .ge. (440._wp*100._wp) .and. p1 .lt. (680._wp*100._wp)) then 
-                         cldlayphase(i,ncol,2,1) = 1._wp
-                      ! Low cloud
-                      else
-                         cldlayphase(i,ncol,1,1) = 1._wp
-                      endif
-                   endif
-                ! ########################################################################
-                ! 4.1.b) Liquid: ATBperp below the phase discrimination line
-                ! ########################################################################
-                else
-                   ! Liquid with temperature above 231,15°K
-                   if(tmp(i,nlev) .gt. 231.15_wp) then
-                      lidarcldphase(i,nlev,2) = lidarcldphase(i,nlev,2)+1._wp
-                      tmpl(i,ncol,nlev)       = tmp(i,nlev)
-                      cldlayphase(i,ncol,4,2) = 1._wp ! tot cloud
-                      ! High cloud
-                      if (p1 .gt. 0. .and. p1 .lt. (440._wp*100._wp)) then
-                         cldlayphase(i,ncol,3,2) = 1._wp
-                      ! Middle cloud   
-                      else if(p1 .ge. (440._wp*100._wp) .and. p1 .lt. (680._wp*100._wp)) then
-                         cldlayphase(i,ncol,2,2) = 1._wp
-                      ! Low cloud   
-                      else
-                         cldlayphase(i,ncol,1,2) = 1._wp
-                      endif
-                   else
-                      ! Liquid with temperature below 231,15°K = Ice (false liquid)
-                      tmpi(i,ncol,nlev)       = tmp(i,nlev)
-                      lidarcldphase(i,nlev,1) = lidarcldphase(i,nlev,1)+1._wp ! false liquid detection ==> added to ice
-                      lidarcldphase(i,nlev,4) = lidarcldphase(i,nlev,4)+1._wp
-                      cldlayphase(i,ncol,4,4) = 1._wp ! tot cloud
-                      ! High cloud
-                      if (p1 .gt. 0. .and. p1 .lt. (440._wp*100._wp)) then
-                         cldlayphase(i,ncol,3,4) = 1._wp
-                      ! Middle cloud   
-                      else if(p1 .ge. (440._wp*100._wp) .and. p1 .lt. (680._wp*100._wp)) then
-                         cldlayphase(i,ncol,2,4) = 1._wp
-                      ! Low cloud
-                      else
-                         cldlayphase(i,ncol,1,4) = 1._wp
-                      endif
-                      cldlayphase(i,ncol,4,1) = 1._wp ! tot cloud
-                      ! High cloud
-                      if (p1 .gt. 0. .and. p1 .lt. (440._wp*100._wp)) then
-                         cldlayphase(i,ncol,3,1) = 1._wp
-                      ! Middle cloud   
-                      else if(p1 .ge. (440._wp*100._wp) .and. p1 .lt. (680._wp*100._wp)) then
-                         cldlayphase(i,ncol,2,1) = 1._wp
-                      ! Low cloud   
-                      else
-                         cldlayphase(i,ncol,1,1) = 1._wp
-                      endif
-                   endif
-                endif ! end of discrimination condition
-             endif ! end of cloud condition
-          enddo ! end of altitude loop
-
-          ! ##############################################################################
-          ! 4.2) For Cloudy pixels with 0km < z < 8.16km
-          ! ##############################################################################
-          toplvlsat = 0
-          do nlev=24,Nlevels! from 8.16km until 0km
-             p1 = pplay(i,nlev)
-
-             if((cldy(i,ncol,nlev) .eq. 1.) .and. (ATBperp(i,ncol,nlev) .gt. 0.) )then
-                ! Computation of the ATBperp of the phase discrimination line
-                ATBperp_tmp = (ATB(i,ncol,nlev)**5)*alpha50 + (ATB(i,ncol,nlev)**4)*beta50 + &
-                     (ATB(i,ncol,nlev)**3)*gamma50 + (ATB(i,ncol,nlev)**2)*delta50 + &
-                     ATB(i,ncol,nlev)*epsilon50 + zeta50
-                ! ########################################################################
-                ! 4.2.a) Ice: ATBperp above the phase discrimination line
-                ! ########################################################################
-                ! ICE with temperature above 273,15°K = Liquid (false ice)
-                if((ATBperp(i,ncol,nlev)-ATBperp_tmp) .ge. 0.)then ! Ice clouds
-                   if(tmp(i,nlev) .gt. 273.15)then
-                      lidarcldphase(i,nlev,2) = lidarcldphase(i,nlev,2)+1._wp ! false ice ==> liq
-                      tmpl(i,ncol,nlev)       = tmp(i,nlev)
-                      lidarcldphase(i,nlev,5) = lidarcldphase(i,nlev,5)+1._wp
-                      cldlayphase(i,ncol,4,2) = 1._wp ! tot cloud
-                      ! High cloud
-                      if (p1 .gt. 0. .and. p1 .lt. (440._wp*100._wp)) then 
-                         cldlayphase(i,ncol,3,2) = 1._wp
-                      ! Middle cloud   
-                      else if(p1 .ge. (440._wp*100._wp) .and. p1 .lt. (680._wp*100._wp)) then 
-                         cldlayphase(i,ncol,2,2) = 1._wp
-                      ! Low cloud
-                      else 
-                         cldlayphase(i,ncol,1,2) = 1._wp
-                      endif
-                      
-                      cldlayphase(i,ncol,4,5) = 1. ! tot cloud
-                      ! High cloud
-                      if (p1 .gt. 0. .and. p1 .lt. (440._wp*100._wp)) then
-                         cldlayphase(i,ncol,3,5) = 1._wp
-                      ! Middle cloud   
-                      else if(p1 .ge. (440._wp*100._wp) .and. p1 .lt. (680._wp*100._wp)) then
-                         cldlayphase(i,ncol,2,5) = 1._wp
-                      ! Low cloud   
-                      else
-                         cldlayphase(i,ncol,1,5) = 1._wp
-                      endif
-                   else
-                      ! ICE with temperature below 273,15°K
-                      lidarcldphase(i,nlev,1) = lidarcldphase(i,nlev,1)+1._wp
-                     tmpi(i,ncol,nlev)       = tmp(i,nlev)
-                      cldlayphase(i,ncol,4,1) = 1._wp ! tot cloud
-                      ! High cloud
-                      if (p1 .gt. 0. .and. p1 .lt. (440._wp*100._wp)) then
-                         cldlayphase(i,ncol,3,1) = 1._wp
-                      ! Middle cloud   
-                      else if(p1 .ge. (440._wp*100._wp) .and. p1 .lt.(680._wp*100._wp)) then
-                         cldlayphase(i,ncol,2,1) = 1._wp
-                      ! Low cloud   
-                      else
-                         cldlayphase(i,ncol,1,1) = 1._wp
-                      endif
-                   endif
-                   
-                ! ########################################################################
-                ! 4.2.b) Liquid: ATBperp below the phase discrimination line
-                ! ########################################################################
-                else
-                   ! Liquid with temperature above 231,15°K
-                   if(tmp(i,nlev) .gt. 231.15)then
-                      lidarcldphase(i,nlev,2) = lidarcldphase(i,nlev,2)+1._wp
-                      tmpl(i,ncol,nlev)       = tmp(i,nlev)
-                      cldlayphase(i,ncol,4,2) = 1._wp ! tot cloud
-                      ! High cloud
-                      if (p1 .gt. 0. .and. p1 .lt. (440._wp*100._wp)) then
-                         cldlayphase(i,ncol,3,2) = 1._wp
-                      ! Middle cloud   
-                      else if(p1 .ge. (440._wp*100._wp) .and. p1 .lt. (680._wp*100._wp)) then
-                         cldlayphase(i,ncol,2,2) = 1._wp
-                      ! Low cloud   
-                      else
-                         cldlayphase(i,ncol,1,2) = 1._wp
-                      endif
-                   else
-                      ! Liquid with temperature below 231,15°K = Ice (false liquid)
-                      tmpi(i,ncol,nlev)       = tmp(i,nlev)
-                      lidarcldphase(i,nlev,1) = lidarcldphase(i,nlev,1)+1._wp ! false liq ==> ice
-                      lidarcldphase(i,nlev,4) = lidarcldphase(i,nlev,4)+1._wp ! false liq ==> ice
-                      cldlayphase(i,ncol,4,4) = 1._wp ! tot cloud
-                      ! High cloud
-                      if (p1 .gt. 0. .and. p1 .lt. (440._wp*100._wp)) then
-                         cldlayphase(i,ncol,3,4) = 1._wp
-                      ! Middle   
-                      else if(p1 .ge. (440._wp*100._wp) .and. p1 .lt. (680._wp*100._wp)) then
-                         cldlayphase(i,ncol,2,4) = 1._wp
-                      ! Low cloud   
-                      else
-                         cldlayphase(i,ncol,1,4) = 1._wp
-                      endif
-                      
-                      cldlayphase(i,ncol,4,1) = 1._wp ! tot cloud
-                      ! High cloud
-                      if (p1 .gt. 0. .and. p1 .lt. (440._wp*100._wp)) then
-                         cldlayphase(i,ncol,3,1) = 1._wp
-                      ! Middle cloud   
-                      else if(p1 .ge. (440._wp*100._wp) .and. p1 .lt. (680._wp*100._wp)) then
-                         cldlayphase(i,ncol,2,1) = 1._wp
-                      ! Low cloud   
-                      else
-                         cldlayphase(i,ncol,1,1) = 1._wp
-                      endif
-                   endif
-                endif ! end of discrimination condition
-                
-                toplvlsat=0
-                
-                ! Find the level of the highest cloud with SR>30
-                if(x(i,ncol,nlev) .gt. S_cld_att) then ! SR > 30.
-                    toplvlsat = nlev+1
-                    goto 99
-                endif
-             endif ! end of cloud condition
-          enddo ! end of altitude loop
-99        continue
-          
-          ! ##############################################################################
-          ! Undefined phase: For a cloud located below another cloud with SR>30
-          ! see Cesana and Chepfer 2013 Sect.III.2
-          ! ##############################################################################
-          if(toplvlsat.ne.0) then
-             do nlev = toplvlsat,Nlevels
-                p1 = pplay(i,nlev)
-                if(cldy(i,ncol,nlev).eq.1.)then
-                   lidarcldphase(i,nlev,3) = lidarcldphase(i,nlev,3)+1._wp
-                   tmpu(i,ncol,nlev)       = tmp(i,nlev)
-                   cldlayphase(i,ncol,4,3) = 1._wp ! tot cloud
-                   ! High cloud
-                   if (p1 .gt. 0. .and. p1 .lt. (440._wp*100._wp)) then
-                      cldlayphase(i,ncol,3,3) = 1._wp
-                   ! Middle cloud   
-                   else if(p1 .ge. (440._wp*100._wp) .and. p1 .lt. (680._wp*100._wp)) then
-                      cldlayphase(i,ncol,2,3) = 1._wp
-                   ! Low cloud   
-                   else
-                      cldlayphase(i,ncol,1,3) = 1._wp
-                   endif
-                endif
-             enddo
-          endif
-          toplvlsat=0
-       enddo
-    enddo
-     
-    ! ####################################################################################
-    ! Computation of final cloud phase diagnosis
-    ! ####################################################################################
-
-    ! Compute the Ice percentage in cloud = ice/(ice+liq) as a function of the occurrences
-    lidarcldphasetmp(:,:) = lidarcldphase(:,:,1)+lidarcldphase(:,:,2);
-    WHERE (lidarcldphasetmp(:,:) .gt. 0.)
-       lidarcldphase(:,:,6)=lidarcldphase(:,:,1)/lidarcldphasetmp(:,:)
-    ELSEWHERE
-       lidarcldphase(:,:,6) = undef
-    ENDWHERE
-    
-    ! Compute Phase 3D Cloud Fraction
-    !WHERE (nsub(:,Nlevels:1:-1) .gt. 0.0 )
-    WHERE (nsub(:,:) .gt. 0.0 )  
-       lidarcldphase(:,:,1)=lidarcldphase(:,:,1)/nsub(:,:)
-       lidarcldphase(:,:,2)=lidarcldphase(:,:,2)/nsub(:,:)
-       lidarcldphase(:,:,3)=lidarcldphase(:,:,3)/nsub(:,:)
-       lidarcldphase(:,:,4)=lidarcldphase(:,:,4)/nsub(:,:)
-       lidarcldphase(:,:,5)=lidarcldphase(:,:,5)/nsub(:,:)
-    ELSEWHERE
-       lidarcldphase(:,:,1) = undef
-       lidarcldphase(:,:,2) = undef
-       lidarcldphase(:,:,3) = undef
-       lidarcldphase(:,:,4) = undef
-       lidarcldphase(:,:,5) = undef
-    ENDWHERE
-
-    ! Compute Phase low mid high cloud fractions
-    do iz = 1, Ncat
-       do i=1,Nphase-3
-          do ic = 1, Ncolumns
-             cldlayerphase(:,iz,i)  = cldlayerphase(:,iz,i)  + cldlayphase(:,ic,iz,i)
-             cldlayerphasesum(:,iz) = cldlayerphasesum(:,iz) + cldlayphase(:,ic,iz,i)
-          enddo
-       enddo
-    enddo
-    do iz = 1, Ncat
-       do i=4,5
-          do ic = 1, Ncolumns
-             cldlayerphase(:,iz,i) = cldlayerphase(:,iz,i) + cldlayphase(:,ic,iz,i)
-          enddo
-       enddo
-    enddo
-    
-    ! Compute the Ice percentage in cloud = ice/(ice+liq)
-    cldlayerphasetmp(:,:)=cldlayerphase(:,:,1)+cldlayerphase(:,:,2)
-    WHERE (cldlayerphasetmp(:,:).gt. 0.)
-       cldlayerphase(:,:,6)=cldlayerphase(:,:,1)/cldlayerphasetmp(:,:)
-    ELSEWHERE
-       cldlayerphase(:,:,6) = undef
-    ENDWHERE
-    
-    do i=1,Nphase-1
-       WHERE ( cldlayerphasesum(:,:).gt.0.0 )
-          cldlayerphase(:,:,i) = (cldlayerphase(:,:,i)/cldlayerphasesum(:,:)) * cldlayer(:,:)
-       ENDWHERE
-    enddo
-    
-    do i=1,Npoints
-       do iz=1,Ncat
-          checkcldlayerphase=0.
-          checkcldlayerphase2=0.
-          if (cldlayerphasesum(i,iz) .gt. 0.0 )then
-             do ic=1,Nphase-3
-                checkcldlayerphase = checkcldlayerphase+cldlayerphase(i,iz,ic)
-             enddo
-             checkcldlayerphase2 = cldlayer(i,iz)-checkcldlayerphase
-             if((checkcldlayerphase2 .gt. 0.01) .or. (checkcldlayerphase2 .lt. -0.01) ) print *, checkcldlayerphase,cldlayer(i,iz)
-          endif
-       enddo
-    enddo
-    
-    do i=1,Nphase-1
-       WHERE (nsublayer(:,:) .eq. 0.0)
-          cldlayerphase(:,:,i) = undef
-       ENDWHERE
-    enddo
- 
-    ! Compute Phase 3D as a function of temperature
-    do nlev=1,Nlevels
-       do ncol=1,Ncolumns
-          do i=1,Npoints
-             do itemp=1,Ntemp
-                if(tmpi(i,ncol,nlev).gt.0.)then
-                   if((tmpi(i,ncol,nlev) .ge. tempmod(itemp)) .and. (tmpi(i,ncol,nlev) .lt. tempmod(itemp+1)) )then
-                      lidarcldtemp(i,itemp,2)=lidarcldtemp(i,itemp,2)+1._wp
-                   endif
-                elseif(tmpl(i,ncol,nlev) .gt. 0.)then
-                   if((tmpl(i,ncol,nlev) .ge. tempmod(itemp)) .and. (tmpl(i,ncol,nlev) .lt. tempmod(itemp+1)) )then
-                      lidarcldtemp(i,itemp,3)=lidarcldtemp(i,itemp,3)+1._wp
-                   endif
-                elseif(tmpu(i,ncol,nlev) .gt. 0.)then
-                   if((tmpu(i,ncol,nlev) .ge. tempmod(itemp)) .and. (tmpu(i,ncol,nlev) .lt. tempmod(itemp+1)) )then
-                      lidarcldtemp(i,itemp,4)=lidarcldtemp(i,itemp,4)+1._wp
-                   endif
-                endif
-             enddo
-          enddo
-       enddo
-    enddo
-    
-    ! Check temperature cloud fraction
-    do i=1,Npoints
-       do itemp=1,Ntemp
-          checktemp=lidarcldtemp(i,itemp,2)+lidarcldtemp(i,itemp,3)+lidarcldtemp(i,itemp,4)
-          !if(checktemp .NE. lidarcldtemp(i,itemp,1))then
-          !   print *, i,itemp
-          !   print *, lidarcldtemp(i,itemp,1:4)
-          !endif
-          
-       enddo
-    enddo
-    
-    ! Compute the Ice percentage in cloud = ice/(ice+liq)
-    sumlidarcldtemp(:,:)=lidarcldtemp(:,:,2)+lidarcldtemp(:,:,3)    
-    WHERE(sumlidarcldtemp(:,:) .gt. 0.)
-       lidarcldtemp(:,:,5)=lidarcldtemp(:,:,2)/sumlidarcldtemp(:,:)
-    ELSEWHERE
-       lidarcldtemp(:,:,5)=undef
-    ENDWHERE
-    
-    do i=1,4
-       WHERE(lidarcldtempind(:,:) .gt. 0.)
-          lidarcldtemp(:,:,i) = lidarcldtemp(:,:,i)/lidarcldtempind(:,:)
-       ELSEWHERE
-          lidarcldtemp(:,:,i) = undef
-       ENDWHERE
-    enddo
-    
-    RETURN
-  END SUBROUTINE COSP_CLDFRAC
-  
-  ! ####################################################################################
-  ! SUBROUTINE cosp_cldfrac_nophase
-  ! Conventions: Ncat must be equal to 4
-  ! ####################################################################################
-  SUBROUTINE COSP_CLDFRAC_NOPHASE(Npoints,Ncolumns,Nlevels,Ncat,x,ATB,pplay,      &
-       S_att,S_cld,S_cld_att,undef,lidarcld,cldlayer)
-    
-    ! Inputs
-    integer,intent(in) :: &
-         Npoints,  & ! Number of gridpoints
-         Ncolumns, & ! Number of subcolumns
-         Nlevels,  & ! Number of vertical levels
-         Ncat        ! Number of cloud layer types
-    real(wp),intent(in) :: &
-         S_att,    & !
-         S_cld,    & !
-         S_cld_att,& ! New threshold for undefine cloud phase detection
-         undef       ! Undefined value
-    real(wp),intent(in),dimension(Npoints,Ncolumns,Nlevels) :: &
-         x,        & ! 
-         ATB         ! 3D attenuated backscatter
-    real(wp),intent(in),dimension(Npoints,Nlevels) :: &
-         pplay       ! Pressure
-    
-    ! Outputs
-    real(wp),intent(out),dimension(Npoints,Nlevels) :: &
-         lidarcld      ! 3D cloud fraction
-    real(wp),intent(out),dimension(Npoints,Ncat) :: &
-         cldlayer      ! Low, middle, high, total cloud fractions
-    
-    ! Local variables
-    integer  :: &
-         ip, k, iz, ic, ncol, nlev, i
-    real(wp) :: &
-         p1
-    real(wp),dimension(Npoints,Nlevels) :: &
-         nsub
-    real(wp),dimension(Npoints,Ncolumns,Ncat) :: &
-         cldlay,nsublay   
-    real(wp),dimension(Npoints,Ncat) :: &
-         nsublayer
-    real(wp),dimension(Npoints,Ncolumns,Nlevels) :: &   
-         cldy, & ! 
-         srok    !
-    
-    ! ####################################################################################
-    ! 1) Initialize    
-    ! ####################################################################################
-    lidarcld           = 0._wp
-    nsub               = 0._wp
-    cldlay             = 0._wp
-    nsublay            = 0._wp
-    
-    ! ####################################################################################
-    ! 2) Cloud detection
-    ! ####################################################################################
-    do k=1,Nlevels
-       ! Cloud detection at subgrid-scale:
-       where ((x(:,:,k) .gt. S_cld) .and. (x(:,:,k) .ne. undef) )
-          cldy(:,:,k)=1._wp
-       elsewhere
-          cldy(:,:,k)=0._wp
-       endwhere
-       
-       ! Number of usefull sub-columns:
-       where ((x(:,:,k) .gt. S_att) .and. (x(:,:,k) .ne. undef) )
-          srok(:,:,k)=1._wp
-       elsewhere
-          srok(:,:,k)=0._wp
-       endwhere
-    enddo    
-
-    ! ####################################################################################
-    ! 3) Grid-box 3D cloud fraction and layered cloud fractions(ISCCP pressure categories)
-    ! ####################################################################################
-    do k=1,Nlevels
-       do ic = 1, Ncolumns
-          do ip = 1, Npoints
-
-             iz=1
-             p1 = pplay(ip,k)
-             if ( p1.gt.0. .and. p1.lt.(440._wp*100._wp)) then ! high clouds
-                iz=3
-             else if(p1.ge.(440._wp*100._wp) .and. p1.lt.(680._wp*100._wp)) then ! mid clouds
-                iz=2
-             endif
-             
-             cldlay(ip,ic,iz) = MAX(cldlay(ip,ic,iz),cldy(ip,ic,k))
-             cldlay(ip,ic,4)  = MAX(cldlay(ip,ic,4),cldy(ip,ic,k))
-             lidarcld(ip,k)   = lidarcld(ip,k) + cldy(ip,ic,k)
-             
-             nsublay(ip,ic,iz) = MAX(nsublay(ip,ic,iz),srok(ip,ic,k))
-             nsublay(ip,ic,4)  = MAX(nsublay(ip,ic,4),srok(ip,ic,k))
-             nsub(ip,k)        = nsub(ip,k) + srok(ip,ic,k)
-             
-          enddo
-       enddo
-    enddo   
-    
-    ! Grid-box 3D cloud fraction
-    where ( nsub(:,:).gt.0.0 )
-       lidarcld(:,:) = lidarcld(:,:)/nsub(:,:)
-    elsewhere
-       lidarcld(:,:) = undef
-    endwhere
-    
-    ! Layered cloud fractions
-    cldlayer  = 0._wp
-    nsublayer = 0._wp
-    do iz = 1, Ncat
-       do ic = 1, Ncolumns
-          cldlayer(:,iz)  = cldlayer(:,iz)  + cldlay(:,ic,iz)
-          nsublayer(:,iz) = nsublayer(:,iz) + nsublay(:,ic,iz)
-       enddo
-    enddo
-    where (nsublayer(:,:) .gt. 0.0)
-       cldlayer(:,:) = cldlayer(:,:)/nsublayer(:,:)
-    elsewhere
-       cldlayer(:,:) = undef
-    endwhere
-
-    RETURN
-  END SUBROUTINE COSP_CLDFRAC_NOPHASE
-
-    ! ####################################################################################
-    ! SUBROUTINE cosp_opaq
-    ! Conventions: Ntype must be equal to 3
-    ! ####################################################################################
-    SUBROUTINE COSP_OPAQ(Npoints,Ncolumns,Nlevels,Ntype,tmp,x,S_att,S_cld,undef,lidarcldtype,   &
-                         cldtype,cldtypetemp,cldtypemeanz,cldtypemeanzse,cldthinemis,vgrid_z,   &
-                         surfelev)
-
-    ! Local parameter
-    real(wp),parameter  :: &
-       S_att_opaq = 0.06_wp, & ! Fully Attenuated threshold (Guzman et al. 2017, JGR-Atmospheres)
-       eta = 0.6_wp            ! Multiple-scattering factor (Vaillant de Guelis et al. 2017a, AMT)
-
-	! Inputs
-    integer,intent(in) :: &
-       Npoints,  & ! Number of gridpoints
-       Ncolumns, & ! Number of subcolumns
-       Nlevels,  & ! Number of vertical levels
-       Ntype       ! Number of OPAQ cloud types (opaque, thin clouds and z_opaque)
-    real(wp),intent(in) :: &
-       S_att,    & ! Fully Attenuated legacy threshold
-       S_cld,    & ! Cloud detection threshold
-       undef       ! Undefined value
-    real(wp),intent(in),dimension(Nlevels) :: &
-       vgrid_z     ! mid-level vertical profile altitude (subcolumns)
-    real(wp),intent(in),dimension(Npoints,Ncolumns,Nlevels) :: &
-       x           ! SR profiles (subcolumns)
-    real(wp),intent(in),dimension(Npoints,Nlevels) :: &
-       tmp         ! Temperature profiles
-    real(wp),intent(in),dimension(Npoints) :: &
-       surfelev    ! Surface Elevation (SE)
-
-	! Outputs
-    real(wp),intent(out),dimension(Npoints,Nlevels,Ntype+1) :: &
-       lidarcldtype   ! 3D OPAQ product fraction (opaque clouds, thin clouds, z_opaque, opacity)
-    real(wp),intent(out),dimension(Npoints,Ntype) :: &
-       cldtype,     & ! Opaque/thin cloud covers + z_opaque altitude
-       cldtypetemp    ! Opaque and thin clouds + z_opaque temperature
-    real(wp),intent(out),dimension(Npoints,2) :: &
-       cldtypemeanz   ! Opaque and thin clouds altitude
-    real(wp),intent(out),dimension(Npoints,3) :: & 
-       cldtypemeanzse ! Opaque, thin clouds and z_opaque altitude with respect to SE
-    real(wp),intent(out),dimension(Npoints) :: &
-       cldthinemis    ! Thin clouds emissivity
-   
-    ! Local variables
-    integer  :: &
-       ip, k, zopac, ic, iz, z_top, z_base, topcloud
-    real(wp)  :: &
-       srmean, srcount, trans2, tau_app, tau_vis, tau_ir, cloudemis
-    real(wp),dimension(Npoints) :: &
-       count_emis
-    real(wp),dimension(Npoints,Nlevels) :: &
-       nsub, nsubopaq 
-    real(wp),dimension(Npoints,Ncolumns,Ntype+1) :: & ! Opaque, thin, z_opaque and all cloud cover
-       cldlay, nsublay   
-    real(wp),dimension(Npoints,Ntype) :: &
-       nsublayer
-    real(wp),dimension(Npoints,Ncolumns,Nlevels) :: &   
-       cldy,     & ! 
-       cldyopaq, & ! 
-       srok,     & !
-       srokopaq    !
-
-    ! ####################################################################################
-	! 1) Initialize    
-    ! ####################################################################################
-    cldtype(:,:)          = 0._wp
-    cldtypetemp(:,:)      = 0._wp
-    cldtypemeanz(:,:)     = 0._wp
-    cldtypemeanzse(:,:)   = 0._wp
-    cldthinemis(:)        = 0._wp
-    count_emis(:)         = 0._wp
-    lidarcldtype(:,:,:)   = 0._wp
-    nsub                  = 0._wp
-    nsubopaq              = 0._wp
-    cldlay                = 0._wp
-    nsublay               = 0._wp
-    nsublayer             = 0._wp
-
-    ! ####################################################################################
-    ! 2) Cloud detection and Fully attenuated layer detection
-    ! ####################################################################################
-    do k=1,Nlevels
-       ! Cloud detection at subgrid-scale:
-       where ( (x(:,:,k) .gt. S_cld) .and. (x(:,:,k) .ne. undef) )
-          cldy(:,:,k)=1._wp
-       elsewhere
-          cldy(:,:,k)=0._wp
-       endwhere
-       ! Fully attenuated layer detection at subgrid-scale:
-       where ( (x(:,:,k) .lt. S_att_opaq) .and. (x(:,:,k) .ge. 0.) .and. (x(:,:,k) .ne. undef) ) !DEBUG
-          cldyopaq(:,:,k)=1._wp
-       elsewhere
-          cldyopaq(:,:,k)=0._wp
-       endwhere
-
-
-       ! Number of usefull sub-column layers:
-       where ( (x(:,:,k) .gt. S_att) .and. (x(:,:,k) .ne. undef) )
-          srok(:,:,k)=1._wp
-       elsewhere
-          srok(:,:,k)=0._wp
-       endwhere
-       ! Number of usefull sub-columns layers for z_opaque 3D fraction:
-       where ( (x(:,:,k) .ge. 0.) .and. (x(:,:,k) .ne. undef) ) !DEBUG
-          srokopaq(:,:,k)=1._wp
-       elsewhere
-          srokopaq(:,:,k)=0._wp
-       endwhere
-    enddo
-
-    ! ####################################################################################
-    ! 3) Grid-box 3D OPAQ product fraction and cloud type cover (opaque/thin) + mean z_opaque
-    ! ####################################################################################
-
-    do k=1,Nlevels
-       do ic = 1, Ncolumns
-          do ip = 1, Npoints
-
-             cldlay(ip,ic,1)   = MAX(cldlay(ip,ic,1),cldyopaq(ip,ic,k)) ! Opaque cloud
-             cldlay(ip,ic,4)   = MAX(cldlay(ip,ic,4),cldy(ip,ic,k))     ! All cloud
-
-             nsublay(ip,ic,1)  = MAX(nsublay(ip,ic,1),srok(ip,ic,k))
-             nsublay(ip,ic,2)  = MAX(nsublay(ip,ic,2),srok(ip,ic,k))
-!             nsublay(ip,ic,4)  = MAX(nsublay(ip,ic,4),srok(ip,ic,k))
-             nsub(ip,k)        = nsub(ip,k) + srok(ip,ic,k)
-             nsubopaq(ip,k)    = nsubopaq(ip,k) + srokopaq(ip,ic,k)
-
-          enddo
-       enddo
-    enddo   
-
-! OPAQ variables
-     do ic = 1, Ncolumns
-        do ip = 1, Npoints
-
-     ! Declaring non-opaque cloudy profiles as thin cloud profiles
-	   if ( cldlay(ip,ic,4).gt. 0. .and. cldlay(ip,ic,1) .eq. 0. ) then
-	      cldlay(ip,ic,2)  =  1._wp
- 	   endif
-
-     ! Filling in 3D and 2D variables
-
-     ! Opaque cloud profiles
-	   if ( cldlay(ip,ic,1) .eq. 1. ) then
-	      zopac = 0._wp
-	      z_top = 0._wp
-	      do k=1,Nlevels-1
-     ! Declaring z_opaque altitude and opaque cloud fraction for 3D and 2D variables
-     ! From SFC-2-TOA ( actually from vgrid_z(SFC+1) = vgrid_z(Nlevels-1) )
-	         if ( cldy(ip,ic,Nlevels-k) .eq. 1. .and. zopac .eq. 0. ) then
-		    lidarcldtype(ip,Nlevels-k + 1,3) = lidarcldtype(ip,Nlevels-k + 1,3) + 1._wp
-		    cldlay(ip,ic,3)                  = vgrid_z(Nlevels-k+1)      ! z_opaque altitude
-		    nsublay(ip,ic,3)                 = 1._wp
-		    zopac = Nlevels-k+1                        ! z_opaque vertical index on vgrid_z
-		 endif
-	         if ( cldy(ip,ic,Nlevels-k) .eq. 1. ) then
-		    lidarcldtype(ip,Nlevels-k ,1)    = lidarcldtype(ip,Nlevels-k ,1) + 1._wp
-		    z_top = Nlevels-k    ! top cloud layer vertical index on vgrid_z
-                 endif
-	      enddo
-     ! Summing opaque cloud mean temperatures and altitudes
-     ! as defined in Vaillant de Guelis et al. 2017a, AMT
-              if (zopac .ne. 0) then 
-                 cldtypetemp(ip,1) = cldtypetemp(ip,1) + ( tmp(ip,zopac) + tmp(ip,z_top) )/2.
-                 cldtypetemp(ip,3) = cldtypetemp(ip,3) + tmp(ip,zopac)                 ! z_opaque
-                 cldtypemeanz(ip,1) = cldtypemeanz(ip,1) + ( vgrid_z(zopac) + vgrid_z(z_top) )/2.
-                 cldtypemeanzse(ip,1) = cldtypemeanzse(ip,1) + (( vgrid_z(zopac) + vgrid_z(z_top) )/2.) - surfelev(ip)
-                 cldtypemeanzse(ip,3) = cldtypemeanzse(ip,3) + ( vgrid_z(zopac) - surfelev(ip) )
-              else
-                 cldlay(ip,ic,1) = 0
-              endif
-	   endif
-
-     ! Thin cloud profiles
-	   if ( cldlay(ip,ic,2) .eq. 1. ) then
-	      topcloud = 0._wp
-	      z_top = 0._wp
-	      z_base = 0._wp
-	      do k=1,Nlevels
-     ! Declaring thin cloud fraction for 3D variable
-     ! From TOA-2-SFC
-                 if ( cldy(ip,ic,k) .eq. 1. .and. topcloud .eq. 1. ) then
-                    lidarcldtype(ip,k,2) = lidarcldtype(ip,k,2) + 1._wp
-		    z_base = k ! bottom cloud layer
-                 endif
-	         if ( cldy(ip,ic,k) .eq. 1. .and. topcloud .eq. 0. ) then
-                    lidarcldtype(ip,k,2) = lidarcldtype(ip,k,2) + 1._wp
-		    z_top = k  ! top cloud layer
-		    z_base = k ! bottom cloud layer
-                    topcloud = 1._wp
-		 endif
-	      enddo
-     ! Computing mean emissivity using layers below the bottom cloud layer to the surface
-     	      srmean = 0._wp
-	      srcount = 0._wp
-	      cloudemis = 0._wp
-     	      do k=z_base+1,Nlevels
-	         if (  (x(ip,ic,k) .gt. S_att_opaq) .and. (x(ip,ic,k) .lt. 1.0) .and. (x(ip,ic,k) .ne. undef)  ) then
-		    srmean = srmean + x(ip,ic,k)
-		    srcount = srcount + 1.
-                 endif
-	      enddo
-	      ! If clear sky layers exist below bottom cloud layer
-	      if ( srcount .gt. 0. ) then
-	      	 trans2 = srmean/srcount              ! thin cloud transmittance**2
-	      	 tau_app = -(log(trans2))/2.          ! apparent cloud optical depth
-	      	 tau_vis = tau_app/eta                ! cloud visible optical depth (multiple scat.)
-	      	 tau_ir = tau_vis/2.                  ! approx. relation between visible and IR ODs
-	      	 cloudemis = 1. - exp(-tau_ir)        ! no diffusion in IR considered : emis = 1-T
-		 count_emis(ip) = count_emis(ip) + 1.
-	      endif
-     ! Summing thin cloud mean temperatures and altitudes
-     ! as defined in Vaillant de Guelis et al. 2017a, AMT
-              cldtypetemp(ip,2) = cldtypetemp(ip,2) + ( tmp(ip,z_base) + tmp(ip,z_top) )/2.
-              cldtypemeanz(ip,2) = cldtypemeanz(ip,2) + ( vgrid_z(z_base) + vgrid_z(z_top) )/2.
-              cldtypemeanzse(ip,2) = cldtypemeanzse(ip,2) + (( vgrid_z(z_base) + vgrid_z(z_top) )/2.) - surfelev(ip)
-              cldthinemis(ip) = cldthinemis(ip) + cloudemis
-           endif
-
-       enddo
-    enddo   
-
-    ! 3D cloud types fraction (opaque=1 and thin=2 clouds)
-    where ( nsub(:,:) .gt. 0. )
-       lidarcldtype(:,:,1) = lidarcldtype(:,:,1)/nsub(:,:)
-       lidarcldtype(:,:,2) = lidarcldtype(:,:,2)/nsub(:,:)
-    elsewhere
-       lidarcldtype(:,:,1) = undef
-       lidarcldtype(:,:,2) = undef
-    endwhere
-    ! 3D z_opaque fraction (=3)
-    where ( nsubopaq(:,:) .gt. 0. )
-       lidarcldtype(:,:,3) = lidarcldtype(:,:,3)/nsubopaq(:,:)
-    elsewhere
-       lidarcldtype(:,:,3) = undef
-       lidarcldtype(:,:,4) = undef !declaring undef for opacity as well
-    endwhere
-    ! 3D opacity fraction (=4) !Summing z_opaque fraction from TOA(k=1) to SFC(k=Nlevels)
-       lidarcldtype(:,1,4) = lidarcldtype(:,1,3) !top layer equal to 3D z_opaque fraction
-    do ip = 1, Npoints
-     	do k = 2, Nlevels
-            if ( (lidarcldtype(ip,k,3) .ne. undef) .and. (lidarcldtype(ip,k-1,4) .ne. undef) ) then
-	        lidarcldtype(ip,k,4) = lidarcldtype(ip,k,3) + lidarcldtype(ip,k-1,4)
-	    else
-	        lidarcldtype(ip,k,4) = undef
-	    endif
-	enddo
-    enddo
-
-    ! Layered cloud types (opaque, thin and z_opaque 2D variables)
-
-    do iz = 1, Ntype
-       do ic = 1, Ncolumns
-          cldtype(:,iz)  = cldtype(:,iz)  + cldlay(:,ic,iz)
-          nsublayer(:,iz) = nsublayer(:,iz) + nsublay(:,ic,iz)
-       enddo
-    enddo
-
-    ! Mean temperature and altitude
-    where (cldtype(:,1) .gt. 0.)
-       cldtypetemp(:,1) = cldtypetemp(:,1)/cldtype(:,1) ! opaque cloud temp
-       cldtypetemp(:,3) = cldtypetemp(:,3)/cldtype(:,1) ! z_opaque
-       cldtypemeanz(:,1) = cldtypemeanz(:,1)/cldtype(:,1) ! opaque cloud alt
-       cldtypemeanzse(:,1) = cldtypemeanzse(:,1)/cldtype(:,1) ! opaque cloud alt - SE 
-       cldtypemeanzse(:,3) = cldtypemeanzse(:,3)/cldtype(:,1) ! z_opaque - SE 
-    elsewhere
-       cldtypetemp(:,1) = undef
-       cldtypetemp(:,3) = undef
-       cldtypemeanz(:,1) = undef
-       cldtypemeanzse(:,1) = undef
-       cldtypemeanzse(:,3) = undef
-    endwhere
-
-    where (cldtype(:,2) .gt. 0.) ! thin cloud
-       cldtypetemp(:,2) = cldtypetemp(:,2)/cldtype(:,2)
-       cldtypemeanz(:,2) = cldtypemeanz(:,2)/cldtype(:,2)
-       cldtypemeanzse(:,2) = cldtypemeanzse(:,2)/cldtype(:,2)
-    elsewhere
-       cldtypetemp(:,2) = undef
-       cldtypemeanz(:,2) = undef
-       cldtypemeanzse(:,2) = undef
-    endwhere
-
-    ! Mean thin cloud emissivity
-    where (count_emis(:) .gt. 0.) ! thin cloud
-       cldthinemis(:) = cldthinemis(:)/count_emis(:)
-    elsewhere
-       cldthinemis(:) = undef
-    endwhere
-
-    where (nsublayer(:,:) .gt. 0.)
-       cldtype(:,:) = cldtype(:,:)/nsublayer(:,:)
-    elsewhere
-       cldtype(:,:) = undef
-    endwhere
-
-  END SUBROUTINE COSP_OPAQ
-
-end module mod_lidar_simulator
Index: /LMDZ6/trunk/libf/phylmd/cospv2/lidar_simulator.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cospv2/lidar_simulator.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/cospv2/lidar_simulator.f90	(revision 5268)
@@ -0,0 +1,1561 @@
+! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+! Copyright (c) 2009, Centre National de la Recherche Scientifique
+! All rights reserved.
+!
+! Redistribution and use in source and binary forms, with or without modification, are 
+! permitted provided that the following conditions are met:
+!
+! 1. Redistributions of source code must retain the above copyright notice, this list of 
+!    conditions and the following disclaimer.
+!
+! 2. Redistributions in binary form must reproduce the above copyright notice, this list
+!    of conditions and the following disclaimer in the documentation and/or other 
+!    materials provided with the distribution.
+!
+! 3. Neither the name of the copyright holder nor the names of its contributors may be 
+!    used to endorse or promote products derived from this software without specific prior
+!    written permission.
+!
+! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY 
+! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 
+! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL 
+! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 
+! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT 
+! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 
+! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+!
+! History
+! May 2007: ActSim code of M. Chiriaco and H. Chepfer rewritten by S. Bony
+!
+! May 2008, H. Chepfer:
+! - Units of pressure inputs: Pa 
+! - Non Spherical particles : LS Ice NS coefficients, CONV Ice NS coefficients
+! - New input: ice_type (0=ice-spheres ; 1=ice-non-spherical)
+!
+! June 2008, A. Bodas-Salcedo:
+! - Ported to Fortran 90 and optimisation changes
+!
+! August 2008, J-L Dufresne:
+! - Optimisation changes (sum instructions suppressed)
+!
+! October 2008, S. Bony,  H. Chepfer and J-L. Dufresne :  
+! - Interface with COSP v2.0:
+!      cloud fraction removed from inputs
+!      in-cloud condensed water now in input (instead of grid-averaged value)
+!      depolarisation diagnostic removed
+!      parasol (polder) reflectances (for 5 different solar zenith angles) added
+!
+! December 2008, S. Bony,  H. Chepfer and J-L. Dufresne : 
+! - Modification of the integration of the lidar equation.
+! - change the cloud detection threshold
+!
+! April 2008, A. Bodas-Salcedo:
+! - Bug fix in computation of pmol and pnorm of upper layer
+!
+! April 2008, J-L. Dufresne
+! - Bug fix in computation of pmol and pnorm, thanks to Masaki Satoh: a factor 2 
+! was missing. This affects the ATB values but not the cloud fraction. 
+!
+! January 2013, G. Cesana and H. Chepfer:
+! - Add the perpendicular component of the backscattered signal (pnorm_perp_tot) in the arguments
+! - Add the temperature for each levels (temp) in the arguments
+! - Add the computation of the perpendicular component of the backscattered lidar signal 
+! Reference: Cesana G. and H. Chepfer (2013): Evaluation of the cloud water phase
+! in a climate model using CALIPSO-GOCCP, J. Geophys. Res., doi: 10.1002/jgrd.50376
+!
+! May 2015 - D. Swales - Modified for COSPv2.0
+!
+! Mar 2018 - R. Guzman - Added OPAQ subroutines
+! References OPAQ:
+!
+!       Guzman et al. (2017): Direct atmosphere opacity observations from CALIPSO provide 
+! new constraints on cloud-radiation interactions. JGR-Atmospheres, DOI: 10.1002/2016JD025946
+!       Vaillant de Guelis et al. (2017a): The link between outgoing longwave radiation and
+! the altitude at which a spaceborne lidar beam is fully attenuated. AMT, 10, 4659-4685,
+! https://doi.org/10.5194/amt-10-4659-2017
+!
+! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+module mod_lidar_simulator
+  USE COSP_KINDS,         ONLY: wp
+  USE MOD_COSP_CONFIG,    ONLY: SR_BINS,S_CLD,S_ATT,S_CLD_ATT,R_UNDEF,calipso_histBsct,  &
+                                use_vgrid,vgrid_zl,vgrid_zu,vgrid_z,atlid_histBsct,      &
+                                grLidar532_histBsct,S_CLD_ATLID,S_ATT_ATLID,S_CLD_ATT_ATLID
+  USE MOD_COSP_STATS,     ONLY: COSP_CHANGE_VERTICAL_GRID,hist1d
+  implicit none
+  
+  ! Polynomial coefficients (Alpha, Beta, Gamma) which allow to compute the 
+  ! ATBperpendicular as a function of the ATB for ice or liquid cloud particles 
+  ! derived from CALIPSO-GOCCP observations at 120m vertical grid 
+  ! (Cesana and Chepfer, JGR, 2013).
+  !
+  ! Relationship between ATBice and ATBperp,ice for ice particles:
+  !                ATBperp,ice = Alpha*ATBice 
+  ! Relationship between ATBice and ATBperp,ice for liquid particles:
+  !          ATBperp,ice = Beta*ATBice^2 + Gamma*ATBice
+  real(wp) :: &
+       alpha,beta,gamma    
+
+contains
+  ! ######################################################################################
+  ! SUBROUTINE lidar_subcolumn
+  ! Inputs with a vertical dimensions (nlev) should ordered in along the vertical 
+  ! dimension from TOA-2-SFC, for example: varIN(nlev) is varIN @ SFC. 
+  ! ######################################################################################
+  subroutine lidar_subcolumn(npoints, ncolumns, nlev, lground, beta_mol, tau_mol,        &
+       betatot, tautot, pmol, pnorm, betatot_ice, tautot_ice, betatot_liq, tautot_liq,   &
+       pnorm_perp_tot)
+
+    ! INPUTS
+    INTEGER,intent(in) :: & 
+         npoints,      & ! Number of gridpoints
+         ncolumns,     & ! Number of subcolumns
+         nlev            ! Number of levels
+    logical,intent(in) :: &
+         lground         ! True for ground-based lidar simulator
+    REAL(WP),intent(in),dimension(npoints,nlev) :: &
+         beta_mol,     & ! Molecular backscatter coefficient
+         tau_mol         ! Molecular optical depth
+    REAL(WP),intent(in),dimension(npoints,ncolumns,nlev)       :: &
+         betatot,      & ! 
+         tautot          ! Optical thickess integrated from top
+    ! Optional Inputs
+    REAL(WP),intent(in),dimension(npoints,ncolumns,nlev),optional       :: &         
+         betatot_ice,  & ! Backscatter coefficient for ice particles
+         betatot_liq,  & ! Backscatter coefficient for liquid particles
+         tautot_ice,   & ! Total optical thickness of ice
+         tautot_liq      ! Total optical thickness of liq
+
+    ! OUTPUTS
+    REAL(WP),intent(out),dimension(npoints,nlev) :: &
+         pmol            ! Molecular attenuated backscatter lidar signal power(m^-1.sr^-1)
+    REAL(WP),intent(out),dimension(npoints,ncolumns,nlev) :: &
+         pnorm           ! Molecular backscatter signal power (m^-1.sr^-1)
+    ! Optional outputs
+    REAL(WP),intent(out),dimension(npoints,ncolumns,nlev),optional :: &
+         pnorm_perp_tot  ! Perpendicular lidar backscattered signal power
+
+    ! LOCAL VARIABLES
+    INTEGER :: k,icol,zi,zf,zinc
+    logical :: lphaseoptics
+    REAL(WP),dimension(npoints) :: &
+         tautot_lay        !
+    REAL(WP),dimension(npoints,ncolumns,nlev) :: &
+         pnorm_liq,      & ! Lidar backscattered signal power for liquid
+         pnorm_ice,      & ! Lidar backscattered signal power for ice
+         pnorm_perp_ice, & ! Perpendicular lidar backscattered signal power for ice
+         pnorm_perp_liq, & ! Perpendicular lidar backscattered signal power for liq
+         beta_perp_ice,  & ! Perpendicular backscatter coefficient for ice
+         beta_perp_liq     ! Perpendicular backscatter coefficient for liquid
+
+    ! Phase optics?
+    lphaseoptics=.false.
+    if (present(betatot_ice) .and. present(betatot_liq) .and. present(tautot_liq) .and. &
+         present(tautot_ice)) lphaseoptics=.true.
+    
+    ! Is this lidar spaceborne (default) or ground-based?
+    if (lground) then
+       zi   = nlev
+       zf   = 1
+       zinc = -1
+    else
+       zi   = 1
+       zf   = nlev
+       zinc = 1
+    endif    
+
+    ! ####################################################################################
+    ! *) Molecular signal
+    ! ####################################################################################
+    call cmp_backsignal(nlev,npoints,beta_mol(1:npoints,zi:zf:zinc),&
+                        tau_mol(1:npoints,zi:zf:zinc),pmol(1:npoints,zi:zf:zinc))
+                        
+    ! ####################################################################################
+    ! PLANE PARRALLEL FIELDS
+    ! ####################################################################################
+    do icol=1,ncolumns
+       ! #################################################################################
+       ! *) Total Backscatter signal
+       ! #################################################################################
+       call cmp_backsignal(nlev,npoints,betatot(1:npoints,icol,zi:zf:zinc),&
+            tautot(1:npoints,icol,zi:zf:zinc),pnorm(1:npoints,icol,zi:zf:zinc))
+       
+       ! #################################################################################
+       ! *) Ice/Liq Backscatter signal
+       ! #################################################################################
+       if (lphaseoptics) then
+          ! Computation of the ice and liquid lidar backscattered signal (ATBice and ATBliq)
+          ! Ice only
+          call cmp_backsignal(nlev,npoints,betatot_ice(1:npoints,icol,zi:zf:zinc),&
+               tautot_ice(1:npoints,icol,zi:zf:zinc), pnorm_ice(1:npoints,icol,zi:zf:zinc))
+          ! Liquid only
+          call cmp_backsignal(nlev,npoints,betatot_liq(1:npoints,icol,zi:zf:zinc),&
+               tautot_liq(1:npoints,icol,zi:zf:zinc), pnorm_liq(1:npoints,icol,zi:zf:zinc))
+       endif
+    enddo
+
+    ! ####################################################################################
+    ! PERDENDICULAR FIELDS (Only needed if distinguishing by phase (ice/liquid))
+    ! ####################################################################################
+    if (lphaseoptics) then
+       do icol=1,ncolumns
+          ! #################################################################################
+          ! *) Ice/Liq Perpendicular Backscatter signal
+          ! #################################################################################
+          ! Computation of ATBperp,ice/liq from ATBice/liq including the multiple scattering 
+          ! contribution (Cesana and Chepfer 2013, JGR)
+          do k=1,nlev
+             ! Ice particles
+             pnorm_perp_ice(1:npoints,icol,k) = Alpha * pnorm_ice(1:npoints,icol,k)
+             
+             ! Liquid particles
+             pnorm_perp_liq(1:npoints,icol,k) = 1000._wp*Beta*pnorm_liq(1:npoints,icol,k)**2+&
+                  Gamma*pnorm_liq(1:npoints,icol,k) 
+          enddo
+          
+          ! #################################################################################
+          ! *) Computation of beta_perp_ice/liq using the lidar equation
+          ! #################################################################################
+          ! Ice only
+          call cmp_beta(nlev,npoints,pnorm_perp_ice(1:npoints,icol,zi:zf:zinc),&
+               tautot_ice(1:npoints,icol,zi:zf:zinc),beta_perp_ice(1:npoints,icol,zi:zf:zinc))        
+          
+          ! Liquid only
+          call cmp_beta(nlev,npoints,pnorm_perp_liq(1:npoints,icol,zi:zf:zinc),&
+               tautot_liq(1:npoints,icol,zi:zf:zinc),beta_perp_liq(1:npoints,icol,zi:zf:zinc))
+          
+          ! #################################################################################
+          ! *) Perpendicular Backscatter signal
+          ! #################################################################################
+          ! Computation of the total perpendicular lidar signal (ATBperp for liq+ice)
+          ! Upper layer
+          WHERE(tautot(1:npoints,icol,1) .gt. 0)
+             pnorm_perp_tot(1:npoints,icol,1) = (beta_perp_ice(1:npoints,icol,1)+           &
+                  beta_perp_liq(1:npoints,icol,1)-                                          &
+                  (beta_mol(1:npoints,1)/(1._wp+1._wp/0.0284_wp))) /                        &
+                  (2._wp*tautot(1:npoints,icol,1))*                                         &
+                  (1._wp-exp(-2._wp*tautot(1:npoints,icol,1)))
+          ELSEWHERE
+             pnorm_perp_tot(1:npoints,icol,1) = 0._wp
+          ENDWHERE
+          
+          ! Other layers
+          do k=2,nlev
+             ! Optical thickness of layer k
+             tautot_lay(1:npoints) = tautot(1:npoints,icol,k)-tautot(1:npoints,icol,k-1) 
+             
+             ! The perpendicular component of the molecular backscattered signal (Betaperp) 
+             ! has been taken into account two times (once for liquid and once for ice). 
+             ! We remove one contribution using 
+             ! Betaperp=beta_mol(:,k)/(1+1/0.0284)) [bodhaine et al. 1999] in the following 
+             ! equations:
+             WHERE (pnorm(1:npoints,icol,k) .eq. 0)
+                pnorm_perp_tot(1:npoints,icol,k)=0._wp
+             ELSEWHERE
+                where(tautot_lay(1:npoints) .gt. 0.)
+                   pnorm_perp_tot(1:npoints,icol,k) = (beta_perp_ice(1:npoints,icol,k)+     &
+                        beta_perp_liq(1:npoints,icol,k)-(beta_mol(1:npoints,k)/(1._wp+1._wp/  &
+                        0.0284_wp)))*EXP(-2._wp*tautot(1:npoints,icol,k-1))/                  &
+                        (2._wp*tautot_lay(1:npoints))* (1._wp-EXP(-2._wp*tautot_lay(1:npoints)))
+                elsewhere
+                   pnorm_perp_tot(1:npoints,icol,k) = (beta_perp_ice(1:npoints,icol,k)+     &
+                        beta_perp_liq(1:npoints,icol,k)-(beta_mol(1:npoints,k)/(1._wp+1._wp/  &
+                        0.0284_wp)))*EXP(-2._wp*tautot(1:npoints,icol,k-1))
+                endwhere
+             ENDWHERE
+          END DO
+       enddo
+    end if
+  end subroutine lidar_subcolumn
+
+  ! ######################################################################################
+  ! SUBROUTINE lidar_column
+  ! ######################################################################################
+  subroutine lidar_column(npoints, ncol, nlevels, llm, max_bin, ntype, platform, pnorm, pmol,             &
+       pplay, zlev, zlev_half, vgrid_z, ok_lidar_cfad, ncat, cfad2, lidarcld, cldlayer,  &
+       ! Optional stuff below
+       tmp, pnorm_perp, surfelev,  lidarcldphase, lidarcldtype, cldtype, cldtypetemp, &
+       cldtypemeanz, cldtypemeanzse, cldthinemis, cldlayerphase, lidarcldtmp)
+
+    integer,parameter :: &
+         nphase = 6 ! Number of cloud layer phase types
+
+    ! Inputs
+    integer,intent(in) :: &
+         npoints, & ! Number of horizontal grid points
+         ncol,    & ! Number of subcolumns
+         nlevels, & ! Number of vertical layers (OLD grid)
+         llm,     & ! Number of vertical layers (NEW grid)
+         max_bin, & ! Number of bins for SR CFADs
+         ncat,    & ! Number of cloud layer types (low,mid,high,total) 
+         ntype      ! Number of OPAQ products (opaque/thin cloud + z_opaque)
+    character(len=*),intent(in) :: &
+         platform   ! Name of platform (e.g. calipso,atlid,grLidar532)
+    real(wp),intent(in),dimension(npoints,ncol,Nlevels) :: &
+         pnorm      ! Lidar ATB
+    real(wp),intent(in),dimension(npoints,Nlevels) :: &
+         pmol,    & ! Molecular ATB
+         pplay      ! Pressure on model levels (Pa)
+    logical,intent(in) :: &
+         ok_lidar_cfad ! True if lidar CFAD diagnostics need to be computed
+    real(wp),intent(in),dimension(npoints,nlevels) :: &
+         zlev        ! Model full levels
+    real(wp),intent(in),dimension(npoints,nlevels+1) :: &
+         zlev_half   ! Model half levels
+    real(wp),intent(in),dimension(llm) :: & 
+         vgrid_z     ! mid-level altitude of the output vertical grid
+    ! Optional Inputs
+    real(wp),intent(in),dimension(npoints,ncol,Nlevels),optional :: &
+         pnorm_perp ! Lidar perpendicular ATB
+    real(wp),intent(in),dimension(npoints),optional :: &
+         surfelev   ! Surface Elevation (m)
+    real(wp),intent(in),dimension(npoints,Nlevels),optional :: &
+         tmp        ! Temperature at each levels
+    
+    ! Outputs
+    real(wp),intent(inout),dimension(npoints,llm) :: &
+         lidarcld      ! 3D "lidar" cloud fraction
+    real(wp),intent(inout),dimension(npoints,ncat) :: &
+         cldlayer      ! "lidar" cloud layer fraction (low, mid, high, total)
+    real(wp),intent(inout),dimension(npoints,max_bin,llm) :: &
+         cfad2         ! CFADs of SR
+    ! Optional Outputs
+    real(wp),intent(out),dimension(npoints,ntype),optional :: & 
+         cldtype,    & ! "lidar" OPAQ type covers (opaque/thin cloud + z_opaque)
+         cldtypetemp   ! Opaque and thin clouds + z_opaque temperature
+    real(wp),intent(out),dimension(npoints,2),optional :: &  
+         cldtypemeanz  ! Opaque and thin clouds altitude 
+    real(wp),intent(out),dimension(npoints,3),optional :: &  
+         cldtypemeanzse ! Opaque, thin clouds and z_opaque altitude with respect to SE
+    real(wp),intent(out),dimension(npoints),optional :: &   
+         cldthinemis   ! Thin clouds emissivity computed from SR
+    real(wp),intent(out),dimension(npoints,llm,nphase),optional :: &
+         lidarcldphase ! 3D "lidar" phase cloud fraction
+    real(wp),intent(out),dimension(npoints,llm,ntype+1),optional :: & 
+         lidarcldtype ! 3D "lidar" OPAQ type fraction 
+    real(wp),intent(out),dimension(npoints,40,5),optional :: &
+         lidarcldtmp   ! 3D "lidar" phase cloud fraction as a function of temp
+    real(wp),intent(out),dimension(npoints,ncat,nphase),optional :: &
+         cldlayerphase ! "lidar" phase low mid high cloud fraction
+
+    ! Local Variables
+    integer :: ic,i,j
+    logical :: lcalipso,latlid,lgrlidar532
+    real(wp),dimension(npoints,ncol,llm) :: &
+         x3d
+    real(wp),dimension(npoints,llm) :: &
+         x3d_c,pnorm_c
+    real(wp)  :: &
+         xmax
+    real(wp),dimension(npoints,1,Nlevels) :: t_in,ph_in,betamol_in
+    real(wp),dimension(npoints,ncol,llm)  :: pnormFlip,pnorm_perpFlip
+    real(wp),dimension(npoints,1,llm)     :: tmpFlip,pplayFlip,betamolFlip
+    real(wp),dimension(SR_BINS+1)         :: histBsct
+    
+    ! Which lidar platform?
+    lcalipso = .false.
+    latlid = .false.
+    lgrlidar532 = .false.
+    if (platform .eq. 'calipso') lcalipso=.true.
+    if (platform .eq. 'atlid') latlid=.true.
+    if (platform .eq. 'grlidar532') lgrlidar532=.true.
+        
+    ! Vertically regrid input data
+    if (use_vgrid) then 
+       ph_in(:,1,:) = pplay(:,nlevels:1:-1)
+       call cosp_change_vertical_grid(Npoints,1,Nlevels,zlev(:,nlevels:1:-1),zlev_half(:,nlevels:1:-1),&
+            ph_in,llm,vgrid_zl(llm:1:-1),vgrid_zu(llm:1:-1),pplayFlip(:,1,llm:1:-1))
+       betamol_in(:,1,:) = pmol(:,nlevels:1:-1)
+       call cosp_change_vertical_grid(Npoints,1,Nlevels,zlev(:,nlevels:1:-1),zlev_half(:,nlevels:1:-1),&
+            betamol_in,llm,vgrid_zl(llm:1:-1),vgrid_zu(llm:1:-1),betamolFlip(:,1,llm:1:-1))
+       call cosp_change_vertical_grid(Npoints,Ncol,Nlevels,zlev(:,nlevels:1:-1),zlev_half(:,nlevels:1:-1),&
+            pnorm(:,:,nlevels:1:-1),llm,vgrid_zl(llm:1:-1),vgrid_zu(llm:1:-1),pnormFlip(:,:,llm:1:-1))
+       if (lcalipso) then
+          t_in(:,1,:)=tmp(:,nlevels:1:-1)
+          call cosp_change_vertical_grid(Npoints,1,Nlevels,zlev(:,nlevels:1:-1),zlev_half(:,nlevels:1:-1),&
+               t_in,llm,vgrid_zl(llm:1:-1),vgrid_zu(llm:1:-1),tmpFlip(:,1,llm:1:-1))
+          call cosp_change_vertical_grid(Npoints,Ncol,Nlevels,zlev(:,nlevels:1:-1),zlev_half(:,nlevels:1:-1),&
+               pnorm_perp(:,:,nlevels:1:-1),llm,vgrid_zl(llm:1:-1),vgrid_zu(llm:1:-1),pnorm_perpFlip(:,:,llm:1:-1))
+       endif
+    endif
+
+    ! Initialization (The histogram bins, are set up during initialization and the
+    ! maximum value is used as the upper bounds.)
+    if (lcalipso)    then
+       xmax = maxval(calipso_histBsct)
+       histBsct = calipso_histBsct
+    endif
+    if (latlid)      then
+       xmax = maxval(atlid_histBsct)
+       histBsct = atlid_histBsct
+    endif
+    if (lgrlidar532) then
+       xmax = maxval(grLidar532_histBsct)
+       histBsct = grLidar532_histBsct
+    endif
+       
+    ! Compute LIDAR scattering ratio
+    if (use_vgrid) then
+       do ic = 1, ncol
+          pnorm_c = pnormFlip(:,ic,:)
+          where ((pnorm_c .lt. xmax) .and. (betamolFlip(:,1,:) .lt. xmax) .and.          &
+                (betamolFlip(:,1,:) .gt. 0.0 ))
+             x3d_c = pnorm_c/betamolFlip(:,1,:)
+          elsewhere
+             x3d_c = R_UNDEF
+          end where
+          x3d(:,ic,:) = x3d_c
+       enddo
+       if (lcalipso) then
+          ! Diagnose cloud fractions for subcolumn lidar scattering ratios
+          CALL COSP_CLDFRAC(npoints,ncol,llm,ncat,nphase,tmpFlip,x3d,pnormFlip,pnorm_perpFlip,&
+               pplayFlip,S_att,S_cld,S_cld_att,R_UNDEF,lidarcld,cldlayer,lidarcldphase,&
+               cldlayerphase,lidarcldtmp)                         
+
+          ! Calipso opaque cloud diagnostics
+          CALL COSP_OPAQ(npoints,ncol,llm,ntype,tmpFlip,x3d,S_att,S_cld,R_UNDEF,lidarcldtype, &
+               cldtype,cldtypetemp,cldtypemeanz,cldtypemeanzse,cldthinemis,vgrid_z,surfelev)
+       endif
+       if (latlid) then
+          CALL COSP_CLDFRAC_NOPHASE(npoints,ncol,llm,ncat,x3d,pnormFlip,pplayFlip,  &
+               S_att_atlid,S_cld_atlid,S_cld_att_atlid,R_UNDEF,lidarcld,cldlayer)   
+       endif
+       if (lgrLidar532) then
+          CALL COSP_CLDFRAC_NOPHASE(npoints,ncol,llm,ncat,x3d,pnormFlip,pplayFlip,  &
+               S_att,S_cld,S_cld_att,R_UNDEF,lidarcld,cldlayer)
+       endif
+    else
+       do ic = 1, ncol
+          pnorm_c = pnorm(:,ic,:)
+          where ((pnorm_c.lt.xmax) .and. (pmol.lt.xmax) .and. (pmol.gt. 0.0 ))
+             x3d_c = pnorm_c/pmol
+          elsewhere
+             x3d_c = R_UNDEF
+          end where
+          x3d(:,ic,:) = x3d_c
+       enddo
+       if (lcalipso) then
+          ! Diagnose cloud fractions for subcolumn lidar scattering ratios
+          CALL COSP_CLDFRAC(npoints,ncol,nlevels,ncat,nphase,tmp,x3d,pnorm,pnorm_perp,pplay,&
+               S_att,S_cld,S_cld_att,R_UNDEF,lidarcld,cldlayer,lidarcldphase,  &
+               cldlayerphase,lidarcldtmp)
+          ! Calipso opaque cloud diagnostics
+          CALL COSP_OPAQ(npoints,ncol,nlevels,ntype,tmp,x3d,S_att,S_cld,R_UNDEF,lidarcldtype, &
+               cldtype,cldtypetemp,cldtypemeanz,cldtypemeanzse,cldthinemis,vgrid_z,surfelev)
+       endif
+       if (latlid) then
+          CALL COSP_CLDFRAC_NOPHASE(npoints,ncol,nlevels,ncat,x3d,pnorm,pplay,  &
+               S_att_atlid,S_cld_atlid,S_cld_att_atlid, R_UNDEF,lidarcld,cldlayer)
+       endif
+       if (lgrlidar532) then
+          CALL COSP_CLDFRAC_NOPHASE(npoints,ncol,nlevels,ncat,x3d,pnorm,pplay,      &
+               S_att,S_cld,S_cld_att,R_UNDEF,lidarcld,cldlayer)
+       endif
+    endif
+
+    ! CFADs
+    if (ok_lidar_cfad) then
+       ! CFADs of subgrid-scale lidar scattering ratios
+       do i=1,Npoints
+          do j=1,llm
+             cfad2(i,:,j) = hist1D(ncol,x3d(i,:,j),SR_BINS,histBsct)
+          enddo
+       enddo
+       where(cfad2 .ne. R_UNDEF) cfad2=cfad2/ncol
+    endif 
+    
+    ! Unit conversions
+    where(lidarcld /= R_UNDEF)      lidarcld      = lidarcld*100._wp
+    where(cldlayer /= R_UNDEF)      cldlayer      = cldlayer*100._wp
+    if (lcalipso) then
+       where(cldtype(:,1) /= R_UNDEF)  cldtype(:,1)  = cldtype(:,1)*100._wp
+       where(cldtype(:,2) /= R_UNDEF)  cldtype(:,2)  = cldtype(:,2)*100._wp
+       where(cldlayerphase /= R_UNDEF) cldlayerphase = cldlayerphase*100._wp
+       where(lidarcldphase /= R_UNDEF) lidarcldphase = lidarcldphase*100._wp
+       where(lidarcldtype /= R_UNDEF)  lidarcldtype  = lidarcldtype*100._wp
+       where(lidarcldtmp /= R_UNDEF)   lidarcldtmp   = lidarcldtmp*100._wp
+    endif
+  end subroutine lidar_column
+
+  ! ######################################################################################
+  ! The subroutines below compute the attenuated backscatter signal and the lidar 
+  ! backscatter coefficients using eq (1) from doi:0094-8276/08/2008GL034207
+  ! ######################################################################################
+  subroutine cmp_backsignal(nlev,npoints,beta,tau,pnorm)
+    ! INPUTS
+    integer, intent(in) :: nlev,npoints
+    real(wp),intent(in),dimension(npoints,nlev) :: beta,tau
+
+    ! OUTPUTS
+    real(wp),intent(out),dimension(npoints,nlev) :: pnorm
+
+    ! Internal Variables
+    real(wp), dimension(npoints) :: tautot_lay
+    integer :: k
+
+    ! Uppermost layer 
+    pnorm(:,1) = beta(:,1) / (2._wp*tau(:,1)) * (1._wp-exp(-2._wp*tau(:,1)))
+
+    ! Other layers
+    do k=2,nlev
+       tautot_lay(:) = tau(:,k)-tau(:,k-1) 
+       WHERE (tautot_lay(:) .gt. 0.)
+          pnorm(:,k) = beta(:,k)*EXP(-2._wp*tau(:,k-1)) /&
+               (2._wp*tautot_lay(:))*(1._wp-EXP(-2._wp*tautot_lay(:)))
+       ELSEWHERE
+          ! This must never happen, but just in case, to avoid div. by 0
+          pnorm(:,k) = beta(:,k) * EXP(-2._wp*tau(:,k-1))
+       END WHERE
+
+    END DO
+  end subroutine cmp_backsignal
+
+  subroutine cmp_beta(nlev,npoints,pnorm,tau,beta)
+    ! INPUTS
+    integer, intent(in) :: nlev,npoints
+    real(wp),intent(in),dimension(npoints,nlev) :: pnorm,tau
+
+    ! OUTPUTS
+    real(wp),intent(out),dimension(npoints,nlev) :: beta
+
+    ! Internal Variables
+    real(wp), dimension(npoints) :: tautot_lay
+    integer :: k
+    real(wp) :: epsrealwp
+
+    epsrealwp = epsilon(1._wp)
+    beta(:,1) = pnorm(:,1) * (2._wp*tau(:,1))/(1._wp-exp(-2._wp*tau(:,1)))
+    do k=2,nlev
+       tautot_lay(:) = tau(:,k)-tau(:,k-1)       
+       WHERE ( EXP(-2._wp*tau(:,k-1)) .gt. epsrealwp )
+          WHERE (tautot_lay(:) .gt. 0.)
+             beta(:,k) = pnorm(:,k)/ EXP(-2._wp*tau(:,k-1))* &
+                  (2._wp*tautot_lay(:))/(1._wp-exp(-2._wp*tautot_lay(:)))
+          ELSEWHERE
+             beta(:,k)=pnorm(:,k)/EXP(-2._wp*tau(:,k-1))
+          END WHERE
+       ELSEWHERE
+          beta(:,k)=pnorm(:,k)/epsrealwp
+       END WHERE
+    ENDDO
+
+  end subroutine cmp_beta
+    ! ####################################################################################
+    ! SUBROUTINE cosp_cldfrac
+    ! Conventions: Ncat must be equal to 4
+    ! ####################################################################################
+    SUBROUTINE COSP_CLDFRAC(Npoints,Ncolumns,Nlevels,Ncat,Nphase,tmp,x,ATB,ATBperp,      &
+                               pplay,S_att,S_cld,S_cld_att,undef,lidarcld,cldlayer,      &
+                               lidarcldphase,cldlayerphase,lidarcldtemp)
+    ! Parameters
+    integer,parameter :: Ntemp=40 ! indice of the temperature vector
+    real(wp),parameter,dimension(Ntemp+1) :: &
+       tempmod = [0.0,   183.15,186.15,189.15,192.15,195.15,198.15,201.15,204.15,207.15, &
+                  210.15,213.15,216.15,219.15,222.15,225.15,228.15,231.15,234.15,237.15, &
+                  240.15,243.15,246.15,249.15,252.15,255.15,258.15,261.15,264.15,267.15, &
+                  270.15,273.15,276.15,279.15,282.15,285.15,288.15,291.15,294.15,297.15, &
+                  473.15]
+         
+    ! Polynomial coefficient of the phase discrimination line used to separate liquid from ice
+    ! (Cesana and Chepfer, JGR, 2013)
+    ! ATBperp = ATB^5*alpha50 + ATB^4*beta50 + ATB^3*gamma50 + ATB^2*delta50 + ATB*epsilon50 + zeta50
+    real(wp),parameter :: &
+       alpha50   = 9.0322e+15_wp,  & !
+       beta50    = -2.1358e+12_wp, & !
+       gamma50   = 173.3963e06_wp, & !
+       delta50   = -3.9514e03_wp,  & !
+       epsilon50 = 0.2559_wp,      & !
+       zeta50    = -9.4776e-07_wp    ! 
+       
+	! Inputs
+    integer,intent(in) :: &
+       Npoints,  & ! Number of gridpoints
+       Ncolumns, & ! Number of subcolumns
+       Nlevels,  & ! Number of vertical levels
+       Ncat,     & ! Number of cloud layer types
+       Nphase      ! Number of cloud layer phase types
+	               ! [ice,liquid,undefined,false ice,false liquid,Percent of ice]
+    real(wp),intent(in) :: &
+       S_att,    & !
+       S_cld,    & !
+       S_cld_att,& ! New threshold for undefine cloud phase detection
+       undef       ! Undefined value
+    real(wp),intent(in),dimension(Npoints,Ncolumns,Nlevels) :: &
+       x,        & ! 
+       ATB,      & ! 3D attenuated backscatter
+       ATBperp     ! 3D attenuated backscatter (perpendicular)
+    real(wp),intent(in),dimension(Npoints,Nlevels) :: &
+       tmp,      & ! Temperature   
+       pplay       ! Pressure
+
+	! Outputs
+    real(wp),intent(out),dimension(Npoints,Ntemp,5) :: &
+       lidarcldtemp  ! 3D Temperature 1=tot,2=ice,3=liq,4=undef,5=ice/ice+liq
+    real(wp),intent(out),dimension(Npoints,Nlevels,Nphase) :: &
+       lidarcldphase ! 3D cloud phase fraction
+    real(wp),intent(out),dimension(Npoints,Nlevels) :: &
+       lidarcld      ! 3D cloud fraction
+    real(wp),intent(out),dimension(Npoints,Ncat) :: &
+       cldlayer      ! Low, middle, high, total cloud fractions
+    real(wp),intent(out),dimension(Npoints,Ncat,Nphase) :: &
+       cldlayerphase ! Low, middle, high, total cloud fractions for ice liquid and undefine phase    
+    
+    ! Local variables
+    integer  :: &
+       ip, k, iz, ic, ncol, nlev, i, itemp, toplvlsat 
+    real(wp) :: &
+       p1,checktemp, ATBperp_tmp,checkcldlayerphase, checkcldlayerphase2
+    real(wp),dimension(Npoints,Nlevels) :: &
+       nsub,lidarcldphasetmp   
+    real(wp),dimension(Npoints,Ntemp) :: &
+       sumlidarcldtemp,lidarcldtempind
+    real(wp),dimension(Npoints,Ncolumns,Ncat) :: &
+       cldlay,nsublay   
+    real(wp),dimension(Npoints,Ncat) :: &
+       nsublayer,cldlayerphasetmp,cldlayerphasesum
+    real(wp),dimension(Npoints,Ncolumns,Nlevels) :: &   
+       tmpi, & ! Temperature of ice cld
+       tmpl, & ! Temperature of liquid cld
+       tmpu, & ! Temperature of undef cld
+       cldy, & ! 
+       srok    !
+    real(wp),dimension(Npoints,Ncolumns,Ncat,Nphase) :: &
+       cldlayphase ! subgrided low mid high phase cloud fraction
+             
+    ! ####################################################################################
+	! 1) Initialize    
+    ! ####################################################################################
+    lidarcld              = 0._wp
+    nsub                  = 0._wp
+    cldlay                = 0._wp
+    nsublay               = 0._wp
+    ATBperp_tmp           = 0._wp
+    lidarcldphase(:,:,:)  = 0._wp
+    cldlayphase(:,:,:,:)  = 0._wp
+    cldlayerphase(:,:,:)  = 0._wp
+    tmpi(:,:,:)           = 0._wp
+    tmpl(:,:,:)           = 0._wp
+    tmpu(:,:,:)           = 0._wp
+    cldlayerphasesum(:,:) = 0._wp
+    lidarcldtemp(:,:,:)   = 0._wp
+    lidarcldtempind(:,:)  = 0._wp
+    sumlidarcldtemp(:,:)  = 0._wp
+    lidarcldphasetmp(:,:) = 0._wp
+    toplvlsat             = 0
+
+    ! ####################################################################################
+    ! 2) Cloud detection
+    ! ####################################################################################
+    do k=1,Nlevels
+       ! Cloud detection at subgrid-scale:
+       where ((x(:,:,k) .gt. S_cld) .and. (x(:,:,k) .ne. undef) )
+          cldy(:,:,k)=1._wp
+       elsewhere
+          cldy(:,:,k)=0._wp
+       endwhere
+       
+       ! Number of usefull sub-columns:
+       where ((x(:,:,k) .gt. S_att) .and. (x(:,:,k) .ne. undef) )
+          srok(:,:,k)=1._wp
+       elsewhere
+          srok(:,:,k)=0._wp
+       endwhere
+    enddo    
+    
+    ! ####################################################################################
+    ! 3) Grid-box 3D cloud fraction and layered cloud fractions(ISCCP pressure categories)
+    ! ####################################################################################
+    lidarcld = 0._wp
+    nsub     = 0._wp
+    cldlay   = 0._wp
+    nsublay  = 0._wp
+    do k=1,Nlevels
+       do ic = 1, Ncolumns
+          do ip = 1, Npoints
+          
+             ! Computation of the cloud fraction as a function of the temperature instead
+             ! of height, for ice,liquid and all clouds
+             if(srok(ip,ic,k).gt.0.)then
+                do itemp=1,Ntemp
+                   if( (tmp(ip,k).ge.tempmod(itemp)).and.(tmp(ip,k).lt.tempmod(itemp+1)) )then
+                      lidarcldtempind(ip,itemp)=lidarcldtempind(ip,itemp)+1._wp
+                   endif
+                enddo
+             endif
+             
+             if(cldy(ip,ic,k).eq.1.)then
+                do itemp=1,Ntemp 
+                   if( (tmp(ip,k) .ge. tempmod(itemp)).and.(tmp(ip,k) .lt. tempmod(itemp+1)) )then
+                      lidarcldtemp(ip,itemp,1)=lidarcldtemp(ip,itemp,1)+1._wp
+                   endif
+                enddo
+             endif
+
+             iz=1
+             p1 = pplay(ip,k)
+             if ( p1.gt.0. .and. p1.lt.(440._wp*100._wp)) then ! high clouds
+                iz=3
+             else if(p1.ge.(440._wp*100._wp) .and. p1.lt.(680._wp*100._wp)) then ! mid clouds
+                iz=2
+             endif
+             
+             cldlay(ip,ic,iz) = MAX(cldlay(ip,ic,iz),cldy(ip,ic,k))
+             cldlay(ip,ic,4)  = MAX(cldlay(ip,ic,4),cldy(ip,ic,k))
+             lidarcld(ip,k)   = lidarcld(ip,k) + cldy(ip,ic,k)
+             
+             nsublay(ip,ic,iz) = MAX(nsublay(ip,ic,iz),srok(ip,ic,k))
+             nsublay(ip,ic,4)  = MAX(nsublay(ip,ic,4),srok(ip,ic,k))
+             nsub(ip,k)        = nsub(ip,k) + srok(ip,ic,k)
+             
+          enddo
+       enddo
+    enddo   
+    
+    ! Grid-box 3D cloud fraction
+    where ( nsub(:,:).gt.0.0 )
+       lidarcld(:,:) = lidarcld(:,:)/nsub(:,:)
+    elsewhere
+       lidarcld(:,:) = undef
+    endwhere
+    
+    ! Layered cloud fractions
+    cldlayer  = 0._wp
+    nsublayer = 0._wp
+    do iz = 1, Ncat
+       do ic = 1, Ncolumns
+          cldlayer(:,iz)  = cldlayer(:,iz)  + cldlay(:,ic,iz)
+          nsublayer(:,iz) = nsublayer(:,iz) + nsublay(:,ic,iz)
+       enddo
+    enddo
+    where (nsublayer(:,:) .gt. 0.0)
+       cldlayer(:,:) = cldlayer(:,:)/nsublayer(:,:)
+    elsewhere
+       cldlayer(:,:) = undef
+    endwhere
+              
+    ! ####################################################################################
+    ! 4) Grid-box 3D cloud Phase
+    ! ####################################################################################
+    
+    ! ####################################################################################
+    ! 4.1) For Cloudy pixels with 8.16km < z < 19.2km
+    ! ####################################################################################
+    do ncol=1,Ncolumns
+       do i=1,Npoints          
+          do nlev=1,23 ! from 19.2km until 8.16km
+               p1 = pplay(1,nlev)
+
+             ! Avoid zero values
+             if( (cldy(i,ncol,nlev).eq.1.) .and. (ATBperp(i,ncol,nlev).gt.0.) )then
+                ! Computation of the ATBperp along the phase discrimination line
+                ATBperp_tmp = (ATB(i,ncol,nlev)**5)*alpha50 + (ATB(i,ncol,nlev)**4)*beta50 + &
+                     (ATB(i,ncol,nlev)**3)*gamma50 + (ATB(i,ncol,nlev)**2)*delta50 + &
+                     ATB(i,ncol,nlev)*epsilon50 + zeta50     
+                ! ########################################################################
+                ! 4.1.a) Ice: ATBperp above the phase discrimination line
+                ! ########################################################################
+                if((ATBperp(i,ncol,nlev)-ATBperp_tmp) .ge. 0.)then ! Ice clouds
+
+                   ! ICE with temperature above 273,15°K = Liquid (false ice)
+                   if(tmp(i,nlev) .gt. 273.15) then ! Temperature above 273,15 K
+                     ! Liquid: False ice corrected by the temperature to Liquid
+                      lidarcldphase(i,nlev,2) = lidarcldphase(i,nlev,2)+1._wp ! False ice detection ==> added to Liquid
+                                    
+                      tmpl(i,ncol,nlev)       = tmp(i,nlev)
+                      lidarcldphase(i,nlev,5) = lidarcldphase(i,nlev,5)+1._wp ! Keep the information "temperature criterium used"                      
+                                                                              ! to classify the phase cloud
+                      cldlayphase(i,ncol,4,2) = 1. ! tot cloud
+                      if (p1 .gt. 0. .and. p1.lt.(440._wp*100._wp)) then ! high cloud
+                         cldlayphase(i,ncol,3,2) = 1._wp
+                      else if(p1 .ge. (440._wp*100._wp) .and. p1 .lt. (680._wp*100._wp)) then ! mid cloud
+                         cldlayphase(i,ncol,2,2) = 1._wp
+                      else ! low cloud
+                         cldlayphase(i,ncol,1,2) = 1._wp
+                      endif
+                      cldlayphase(i,ncol,4,5) = 1._wp ! tot cloud
+                      ! High cloud
+                      if (p1 .gt. 0. .and. p1 .lt. (440._wp*100._wp)) then 
+                         cldlayphase(i,ncol,3,5) = 1._wp
+                      ! Middle cloud
+                      else if(p1 .ge. (440._wp*100._wp) .and. p1 .lt. (680._wp*100._wp)) then
+                         cldlayphase(i,ncol,2,5) = 1._wp
+                      ! Low cloud
+                      else 
+                         cldlayphase(i,ncol,1,5) = 1._wp
+                      endif
+                   else
+                      ! ICE with temperature below 273,15°K
+                      lidarcldphase(i,nlev,1) = lidarcldphase(i,nlev,1)+1._wp
+                      tmpi(i,ncol,nlev)       = tmp(i,nlev)
+                      cldlayphase(i,ncol,4,1) = 1._wp ! tot cloud 
+                      ! High cloud
+                      if (p1 .gt. 0. .and. p1 .lt. (440._wp*100._wp)) then 
+                         cldlayphase(i,ncol,3,1) = 1._wp
+                      ! Middle cloud   
+                      else if(p1 .ge. (440._wp*100._wp) .and. p1 .lt. (680._wp*100._wp)) then 
+                         cldlayphase(i,ncol,2,1) = 1._wp
+                      ! Low cloud
+                      else
+                         cldlayphase(i,ncol,1,1) = 1._wp
+                      endif
+                   endif
+                ! ########################################################################
+                ! 4.1.b) Liquid: ATBperp below the phase discrimination line
+                ! ########################################################################
+                else
+                   ! Liquid with temperature above 231,15°K
+                   if(tmp(i,nlev) .gt. 231.15_wp) then
+                      lidarcldphase(i,nlev,2) = lidarcldphase(i,nlev,2)+1._wp
+                      tmpl(i,ncol,nlev)       = tmp(i,nlev)
+                      cldlayphase(i,ncol,4,2) = 1._wp ! tot cloud
+                      ! High cloud
+                      if (p1 .gt. 0. .and. p1 .lt. (440._wp*100._wp)) then
+                         cldlayphase(i,ncol,3,2) = 1._wp
+                      ! Middle cloud   
+                      else if(p1 .ge. (440._wp*100._wp) .and. p1 .lt. (680._wp*100._wp)) then
+                         cldlayphase(i,ncol,2,2) = 1._wp
+                      ! Low cloud   
+                      else
+                         cldlayphase(i,ncol,1,2) = 1._wp
+                      endif
+                   else
+                      ! Liquid with temperature below 231,15°K = Ice (false liquid)
+                      tmpi(i,ncol,nlev)       = tmp(i,nlev)
+                      lidarcldphase(i,nlev,1) = lidarcldphase(i,nlev,1)+1._wp ! false liquid detection ==> added to ice
+                      lidarcldphase(i,nlev,4) = lidarcldphase(i,nlev,4)+1._wp
+                      cldlayphase(i,ncol,4,4) = 1._wp ! tot cloud
+                      ! High cloud
+                      if (p1 .gt. 0. .and. p1 .lt. (440._wp*100._wp)) then
+                         cldlayphase(i,ncol,3,4) = 1._wp
+                      ! Middle cloud   
+                      else if(p1 .ge. (440._wp*100._wp) .and. p1 .lt. (680._wp*100._wp)) then
+                         cldlayphase(i,ncol,2,4) = 1._wp
+                      ! Low cloud
+                      else
+                         cldlayphase(i,ncol,1,4) = 1._wp
+                      endif
+                      cldlayphase(i,ncol,4,1) = 1._wp ! tot cloud
+                      ! High cloud
+                      if (p1 .gt. 0. .and. p1 .lt. (440._wp*100._wp)) then
+                         cldlayphase(i,ncol,3,1) = 1._wp
+                      ! Middle cloud   
+                      else if(p1 .ge. (440._wp*100._wp) .and. p1 .lt. (680._wp*100._wp)) then
+                         cldlayphase(i,ncol,2,1) = 1._wp
+                      ! Low cloud   
+                      else
+                         cldlayphase(i,ncol,1,1) = 1._wp
+                      endif
+                   endif
+                endif ! end of discrimination condition
+             endif ! end of cloud condition
+          enddo ! end of altitude loop
+
+          ! ##############################################################################
+          ! 4.2) For Cloudy pixels with 0km < z < 8.16km
+          ! ##############################################################################
+          toplvlsat = 0
+          do nlev=24,Nlevels! from 8.16km until 0km
+             p1 = pplay(i,nlev)
+
+             if((cldy(i,ncol,nlev) .eq. 1.) .and. (ATBperp(i,ncol,nlev) .gt. 0.) )then
+                ! Computation of the ATBperp of the phase discrimination line
+                ATBperp_tmp = (ATB(i,ncol,nlev)**5)*alpha50 + (ATB(i,ncol,nlev)**4)*beta50 + &
+                     (ATB(i,ncol,nlev)**3)*gamma50 + (ATB(i,ncol,nlev)**2)*delta50 + &
+                     ATB(i,ncol,nlev)*epsilon50 + zeta50
+                ! ########################################################################
+                ! 4.2.a) Ice: ATBperp above the phase discrimination line
+                ! ########################################################################
+                ! ICE with temperature above 273,15°K = Liquid (false ice)
+                if((ATBperp(i,ncol,nlev)-ATBperp_tmp) .ge. 0.)then ! Ice clouds
+                   if(tmp(i,nlev) .gt. 273.15)then
+                      lidarcldphase(i,nlev,2) = lidarcldphase(i,nlev,2)+1._wp ! false ice ==> liq
+                      tmpl(i,ncol,nlev)       = tmp(i,nlev)
+                      lidarcldphase(i,nlev,5) = lidarcldphase(i,nlev,5)+1._wp
+                      cldlayphase(i,ncol,4,2) = 1._wp ! tot cloud
+                      ! High cloud
+                      if (p1 .gt. 0. .and. p1 .lt. (440._wp*100._wp)) then 
+                         cldlayphase(i,ncol,3,2) = 1._wp
+                      ! Middle cloud   
+                      else if(p1 .ge. (440._wp*100._wp) .and. p1 .lt. (680._wp*100._wp)) then 
+                         cldlayphase(i,ncol,2,2) = 1._wp
+                      ! Low cloud
+                      else 
+                         cldlayphase(i,ncol,1,2) = 1._wp
+                      endif
+                      
+                      cldlayphase(i,ncol,4,5) = 1. ! tot cloud
+                      ! High cloud
+                      if (p1 .gt. 0. .and. p1 .lt. (440._wp*100._wp)) then
+                         cldlayphase(i,ncol,3,5) = 1._wp
+                      ! Middle cloud   
+                      else if(p1 .ge. (440._wp*100._wp) .and. p1 .lt. (680._wp*100._wp)) then
+                         cldlayphase(i,ncol,2,5) = 1._wp
+                      ! Low cloud   
+                      else
+                         cldlayphase(i,ncol,1,5) = 1._wp
+                      endif
+                   else
+                      ! ICE with temperature below 273,15°K
+                      lidarcldphase(i,nlev,1) = lidarcldphase(i,nlev,1)+1._wp
+                     tmpi(i,ncol,nlev)       = tmp(i,nlev)
+                      cldlayphase(i,ncol,4,1) = 1._wp ! tot cloud
+                      ! High cloud
+                      if (p1 .gt. 0. .and. p1 .lt. (440._wp*100._wp)) then
+                         cldlayphase(i,ncol,3,1) = 1._wp
+                      ! Middle cloud   
+                      else if(p1 .ge. (440._wp*100._wp) .and. p1 .lt.(680._wp*100._wp)) then
+                         cldlayphase(i,ncol,2,1) = 1._wp
+                      ! Low cloud   
+                      else
+                         cldlayphase(i,ncol,1,1) = 1._wp
+                      endif
+                   endif
+                   
+                ! ########################################################################
+                ! 4.2.b) Liquid: ATBperp below the phase discrimination line
+                ! ########################################################################
+                else
+                   ! Liquid with temperature above 231,15°K
+                   if(tmp(i,nlev) .gt. 231.15)then
+                      lidarcldphase(i,nlev,2) = lidarcldphase(i,nlev,2)+1._wp
+                      tmpl(i,ncol,nlev)       = tmp(i,nlev)
+                      cldlayphase(i,ncol,4,2) = 1._wp ! tot cloud
+                      ! High cloud
+                      if (p1 .gt. 0. .and. p1 .lt. (440._wp*100._wp)) then
+                         cldlayphase(i,ncol,3,2) = 1._wp
+                      ! Middle cloud   
+                      else if(p1 .ge. (440._wp*100._wp) .and. p1 .lt. (680._wp*100._wp)) then
+                         cldlayphase(i,ncol,2,2) = 1._wp
+                      ! Low cloud   
+                      else
+                         cldlayphase(i,ncol,1,2) = 1._wp
+                      endif
+                   else
+                      ! Liquid with temperature below 231,15°K = Ice (false liquid)
+                      tmpi(i,ncol,nlev)       = tmp(i,nlev)
+                      lidarcldphase(i,nlev,1) = lidarcldphase(i,nlev,1)+1._wp ! false liq ==> ice
+                      lidarcldphase(i,nlev,4) = lidarcldphase(i,nlev,4)+1._wp ! false liq ==> ice
+                      cldlayphase(i,ncol,4,4) = 1._wp ! tot cloud
+                      ! High cloud
+                      if (p1 .gt. 0. .and. p1 .lt. (440._wp*100._wp)) then
+                         cldlayphase(i,ncol,3,4) = 1._wp
+                      ! Middle   
+                      else if(p1 .ge. (440._wp*100._wp) .and. p1 .lt. (680._wp*100._wp)) then
+                         cldlayphase(i,ncol,2,4) = 1._wp
+                      ! Low cloud   
+                      else
+                         cldlayphase(i,ncol,1,4) = 1._wp
+                      endif
+                      
+                      cldlayphase(i,ncol,4,1) = 1._wp ! tot cloud
+                      ! High cloud
+                      if (p1 .gt. 0. .and. p1 .lt. (440._wp*100._wp)) then
+                         cldlayphase(i,ncol,3,1) = 1._wp
+                      ! Middle cloud   
+                      else if(p1 .ge. (440._wp*100._wp) .and. p1 .lt. (680._wp*100._wp)) then
+                         cldlayphase(i,ncol,2,1) = 1._wp
+                      ! Low cloud   
+                      else
+                         cldlayphase(i,ncol,1,1) = 1._wp
+                      endif
+                   endif
+                endif ! end of discrimination condition
+                
+                toplvlsat=0
+                
+                ! Find the level of the highest cloud with SR>30
+                if(x(i,ncol,nlev) .gt. S_cld_att) then ! SR > 30.
+                    toplvlsat = nlev+1
+                    goto 99
+                endif
+             endif ! end of cloud condition
+          enddo ! end of altitude loop
+99        continue
+          
+          ! ##############################################################################
+          ! Undefined phase: For a cloud located below another cloud with SR>30
+          ! see Cesana and Chepfer 2013 Sect.III.2
+          ! ##############################################################################
+          if(toplvlsat.ne.0) then
+             do nlev = toplvlsat,Nlevels
+                p1 = pplay(i,nlev)
+                if(cldy(i,ncol,nlev).eq.1.)then
+                   lidarcldphase(i,nlev,3) = lidarcldphase(i,nlev,3)+1._wp
+                   tmpu(i,ncol,nlev)       = tmp(i,nlev)
+                   cldlayphase(i,ncol,4,3) = 1._wp ! tot cloud
+                   ! High cloud
+                   if (p1 .gt. 0. .and. p1 .lt. (440._wp*100._wp)) then
+                      cldlayphase(i,ncol,3,3) = 1._wp
+                   ! Middle cloud   
+                   else if(p1 .ge. (440._wp*100._wp) .and. p1 .lt. (680._wp*100._wp)) then
+                      cldlayphase(i,ncol,2,3) = 1._wp
+                   ! Low cloud   
+                   else
+                      cldlayphase(i,ncol,1,3) = 1._wp
+                   endif
+                endif
+             enddo
+          endif
+          toplvlsat=0
+       enddo
+    enddo
+     
+    ! ####################################################################################
+    ! Computation of final cloud phase diagnosis
+    ! ####################################################################################
+
+    ! Compute the Ice percentage in cloud = ice/(ice+liq) as a function of the occurrences
+    lidarcldphasetmp(:,:) = lidarcldphase(:,:,1)+lidarcldphase(:,:,2);
+    WHERE (lidarcldphasetmp(:,:) .gt. 0.)
+       lidarcldphase(:,:,6)=lidarcldphase(:,:,1)/lidarcldphasetmp(:,:)
+    ELSEWHERE
+       lidarcldphase(:,:,6) = undef
+    ENDWHERE
+    
+    ! Compute Phase 3D Cloud Fraction
+    !WHERE (nsub(:,Nlevels:1:-1) .gt. 0.0 )
+    WHERE (nsub(:,:) .gt. 0.0 )  
+       lidarcldphase(:,:,1)=lidarcldphase(:,:,1)/nsub(:,:)
+       lidarcldphase(:,:,2)=lidarcldphase(:,:,2)/nsub(:,:)
+       lidarcldphase(:,:,3)=lidarcldphase(:,:,3)/nsub(:,:)
+       lidarcldphase(:,:,4)=lidarcldphase(:,:,4)/nsub(:,:)
+       lidarcldphase(:,:,5)=lidarcldphase(:,:,5)/nsub(:,:)
+    ELSEWHERE
+       lidarcldphase(:,:,1) = undef
+       lidarcldphase(:,:,2) = undef
+       lidarcldphase(:,:,3) = undef
+       lidarcldphase(:,:,4) = undef
+       lidarcldphase(:,:,5) = undef
+    ENDWHERE
+
+    ! Compute Phase low mid high cloud fractions
+    do iz = 1, Ncat
+       do i=1,Nphase-3
+          do ic = 1, Ncolumns
+             cldlayerphase(:,iz,i)  = cldlayerphase(:,iz,i)  + cldlayphase(:,ic,iz,i)
+             cldlayerphasesum(:,iz) = cldlayerphasesum(:,iz) + cldlayphase(:,ic,iz,i)
+          enddo
+       enddo
+    enddo
+    do iz = 1, Ncat
+       do i=4,5
+          do ic = 1, Ncolumns
+             cldlayerphase(:,iz,i) = cldlayerphase(:,iz,i) + cldlayphase(:,ic,iz,i)
+          enddo
+       enddo
+    enddo
+    
+    ! Compute the Ice percentage in cloud = ice/(ice+liq)
+    cldlayerphasetmp(:,:)=cldlayerphase(:,:,1)+cldlayerphase(:,:,2)
+    WHERE (cldlayerphasetmp(:,:).gt. 0.)
+       cldlayerphase(:,:,6)=cldlayerphase(:,:,1)/cldlayerphasetmp(:,:)
+    ELSEWHERE
+       cldlayerphase(:,:,6) = undef
+    ENDWHERE
+    
+    do i=1,Nphase-1
+       WHERE ( cldlayerphasesum(:,:).gt.0.0 )
+          cldlayerphase(:,:,i) = (cldlayerphase(:,:,i)/cldlayerphasesum(:,:)) * cldlayer(:,:)
+       ENDWHERE
+    enddo
+    
+    do i=1,Npoints
+       do iz=1,Ncat
+          checkcldlayerphase=0.
+          checkcldlayerphase2=0.
+          if (cldlayerphasesum(i,iz) .gt. 0.0 )then
+             do ic=1,Nphase-3
+                checkcldlayerphase = checkcldlayerphase+cldlayerphase(i,iz,ic)
+             enddo
+             checkcldlayerphase2 = cldlayer(i,iz)-checkcldlayerphase
+             if((checkcldlayerphase2 .gt. 0.01) .or. (checkcldlayerphase2 .lt. -0.01) ) print *, checkcldlayerphase,cldlayer(i,iz)
+          endif
+       enddo
+    enddo
+    
+    do i=1,Nphase-1
+       WHERE (nsublayer(:,:) .eq. 0.0)
+          cldlayerphase(:,:,i) = undef
+       ENDWHERE
+    enddo
+ 
+    ! Compute Phase 3D as a function of temperature
+    do nlev=1,Nlevels
+       do ncol=1,Ncolumns
+          do i=1,Npoints
+             do itemp=1,Ntemp
+                if(tmpi(i,ncol,nlev).gt.0.)then
+                   if((tmpi(i,ncol,nlev) .ge. tempmod(itemp)) .and. (tmpi(i,ncol,nlev) .lt. tempmod(itemp+1)) )then
+                      lidarcldtemp(i,itemp,2)=lidarcldtemp(i,itemp,2)+1._wp
+                   endif
+                elseif(tmpl(i,ncol,nlev) .gt. 0.)then
+                   if((tmpl(i,ncol,nlev) .ge. tempmod(itemp)) .and. (tmpl(i,ncol,nlev) .lt. tempmod(itemp+1)) )then
+                      lidarcldtemp(i,itemp,3)=lidarcldtemp(i,itemp,3)+1._wp
+                   endif
+                elseif(tmpu(i,ncol,nlev) .gt. 0.)then
+                   if((tmpu(i,ncol,nlev) .ge. tempmod(itemp)) .and. (tmpu(i,ncol,nlev) .lt. tempmod(itemp+1)) )then
+                      lidarcldtemp(i,itemp,4)=lidarcldtemp(i,itemp,4)+1._wp
+                   endif
+                endif
+             enddo
+          enddo
+       enddo
+    enddo
+    
+    ! Check temperature cloud fraction
+    do i=1,Npoints
+       do itemp=1,Ntemp
+          checktemp=lidarcldtemp(i,itemp,2)+lidarcldtemp(i,itemp,3)+lidarcldtemp(i,itemp,4)
+          !if(checktemp .NE. lidarcldtemp(i,itemp,1))then
+          !   print *, i,itemp
+          !   print *, lidarcldtemp(i,itemp,1:4)
+          !endif
+          
+       enddo
+    enddo
+    
+    ! Compute the Ice percentage in cloud = ice/(ice+liq)
+    sumlidarcldtemp(:,:)=lidarcldtemp(:,:,2)+lidarcldtemp(:,:,3)    
+    WHERE(sumlidarcldtemp(:,:) .gt. 0.)
+       lidarcldtemp(:,:,5)=lidarcldtemp(:,:,2)/sumlidarcldtemp(:,:)
+    ELSEWHERE
+       lidarcldtemp(:,:,5)=undef
+    ENDWHERE
+    
+    do i=1,4
+       WHERE(lidarcldtempind(:,:) .gt. 0.)
+          lidarcldtemp(:,:,i) = lidarcldtemp(:,:,i)/lidarcldtempind(:,:)
+       ELSEWHERE
+          lidarcldtemp(:,:,i) = undef
+       ENDWHERE
+    enddo
+    
+    RETURN
+  END SUBROUTINE COSP_CLDFRAC
+  
+  ! ####################################################################################
+  ! SUBROUTINE cosp_cldfrac_nophase
+  ! Conventions: Ncat must be equal to 4
+  ! ####################################################################################
+  SUBROUTINE COSP_CLDFRAC_NOPHASE(Npoints,Ncolumns,Nlevels,Ncat,x,ATB,pplay,      &
+       S_att,S_cld,S_cld_att,undef,lidarcld,cldlayer)
+    
+    ! Inputs
+    integer,intent(in) :: &
+         Npoints,  & ! Number of gridpoints
+         Ncolumns, & ! Number of subcolumns
+         Nlevels,  & ! Number of vertical levels
+         Ncat        ! Number of cloud layer types
+    real(wp),intent(in) :: &
+         S_att,    & !
+         S_cld,    & !
+         S_cld_att,& ! New threshold for undefine cloud phase detection
+         undef       ! Undefined value
+    real(wp),intent(in),dimension(Npoints,Ncolumns,Nlevels) :: &
+         x,        & ! 
+         ATB         ! 3D attenuated backscatter
+    real(wp),intent(in),dimension(Npoints,Nlevels) :: &
+         pplay       ! Pressure
+    
+    ! Outputs
+    real(wp),intent(out),dimension(Npoints,Nlevels) :: &
+         lidarcld      ! 3D cloud fraction
+    real(wp),intent(out),dimension(Npoints,Ncat) :: &
+         cldlayer      ! Low, middle, high, total cloud fractions
+    
+    ! Local variables
+    integer  :: &
+         ip, k, iz, ic, ncol, nlev, i
+    real(wp) :: &
+         p1
+    real(wp),dimension(Npoints,Nlevels) :: &
+         nsub
+    real(wp),dimension(Npoints,Ncolumns,Ncat) :: &
+         cldlay,nsublay   
+    real(wp),dimension(Npoints,Ncat) :: &
+         nsublayer
+    real(wp),dimension(Npoints,Ncolumns,Nlevels) :: &   
+         cldy, & ! 
+         srok    !
+    
+    ! ####################################################################################
+    ! 1) Initialize    
+    ! ####################################################################################
+    lidarcld           = 0._wp
+    nsub               = 0._wp
+    cldlay             = 0._wp
+    nsublay            = 0._wp
+    
+    ! ####################################################################################
+    ! 2) Cloud detection
+    ! ####################################################################################
+    do k=1,Nlevels
+       ! Cloud detection at subgrid-scale:
+       where ((x(:,:,k) .gt. S_cld) .and. (x(:,:,k) .ne. undef) )
+          cldy(:,:,k)=1._wp
+       elsewhere
+          cldy(:,:,k)=0._wp
+       endwhere
+       
+       ! Number of usefull sub-columns:
+       where ((x(:,:,k) .gt. S_att) .and. (x(:,:,k) .ne. undef) )
+          srok(:,:,k)=1._wp
+       elsewhere
+          srok(:,:,k)=0._wp
+       endwhere
+    enddo    
+
+    ! ####################################################################################
+    ! 3) Grid-box 3D cloud fraction and layered cloud fractions(ISCCP pressure categories)
+    ! ####################################################################################
+    do k=1,Nlevels
+       do ic = 1, Ncolumns
+          do ip = 1, Npoints
+
+             iz=1
+             p1 = pplay(ip,k)
+             if ( p1.gt.0. .and. p1.lt.(440._wp*100._wp)) then ! high clouds
+                iz=3
+             else if(p1.ge.(440._wp*100._wp) .and. p1.lt.(680._wp*100._wp)) then ! mid clouds
+                iz=2
+             endif
+             
+             cldlay(ip,ic,iz) = MAX(cldlay(ip,ic,iz),cldy(ip,ic,k))
+             cldlay(ip,ic,4)  = MAX(cldlay(ip,ic,4),cldy(ip,ic,k))
+             lidarcld(ip,k)   = lidarcld(ip,k) + cldy(ip,ic,k)
+             
+             nsublay(ip,ic,iz) = MAX(nsublay(ip,ic,iz),srok(ip,ic,k))
+             nsublay(ip,ic,4)  = MAX(nsublay(ip,ic,4),srok(ip,ic,k))
+             nsub(ip,k)        = nsub(ip,k) + srok(ip,ic,k)
+             
+          enddo
+       enddo
+    enddo   
+    
+    ! Grid-box 3D cloud fraction
+    where ( nsub(:,:).gt.0.0 )
+       lidarcld(:,:) = lidarcld(:,:)/nsub(:,:)
+    elsewhere
+       lidarcld(:,:) = undef
+    endwhere
+    
+    ! Layered cloud fractions
+    cldlayer  = 0._wp
+    nsublayer = 0._wp
+    do iz = 1, Ncat
+       do ic = 1, Ncolumns
+          cldlayer(:,iz)  = cldlayer(:,iz)  + cldlay(:,ic,iz)
+          nsublayer(:,iz) = nsublayer(:,iz) + nsublay(:,ic,iz)
+       enddo
+    enddo
+    where (nsublayer(:,:) .gt. 0.0)
+       cldlayer(:,:) = cldlayer(:,:)/nsublayer(:,:)
+    elsewhere
+       cldlayer(:,:) = undef
+    endwhere
+
+    RETURN
+  END SUBROUTINE COSP_CLDFRAC_NOPHASE
+
+    ! ####################################################################################
+    ! SUBROUTINE cosp_opaq
+    ! Conventions: Ntype must be equal to 3
+    ! ####################################################################################
+    SUBROUTINE COSP_OPAQ(Npoints,Ncolumns,Nlevels,Ntype,tmp,x,S_att,S_cld,undef,lidarcldtype,   &
+                         cldtype,cldtypetemp,cldtypemeanz,cldtypemeanzse,cldthinemis,vgrid_z,   &
+                         surfelev)
+
+    ! Local parameter
+    real(wp),parameter  :: &
+       S_att_opaq = 0.06_wp, & ! Fully Attenuated threshold (Guzman et al. 2017, JGR-Atmospheres)
+       eta = 0.6_wp            ! Multiple-scattering factor (Vaillant de Guelis et al. 2017a, AMT)
+
+	! Inputs
+    integer,intent(in) :: &
+       Npoints,  & ! Number of gridpoints
+       Ncolumns, & ! Number of subcolumns
+       Nlevels,  & ! Number of vertical levels
+       Ntype       ! Number of OPAQ cloud types (opaque, thin clouds and z_opaque)
+    real(wp),intent(in) :: &
+       S_att,    & ! Fully Attenuated legacy threshold
+       S_cld,    & ! Cloud detection threshold
+       undef       ! Undefined value
+    real(wp),intent(in),dimension(Nlevels) :: &
+       vgrid_z     ! mid-level vertical profile altitude (subcolumns)
+    real(wp),intent(in),dimension(Npoints,Ncolumns,Nlevels) :: &
+       x           ! SR profiles (subcolumns)
+    real(wp),intent(in),dimension(Npoints,Nlevels) :: &
+       tmp         ! Temperature profiles
+    real(wp),intent(in),dimension(Npoints) :: &
+       surfelev    ! Surface Elevation (SE)
+
+	! Outputs
+    real(wp),intent(out),dimension(Npoints,Nlevels,Ntype+1) :: &
+       lidarcldtype   ! 3D OPAQ product fraction (opaque clouds, thin clouds, z_opaque, opacity)
+    real(wp),intent(out),dimension(Npoints,Ntype) :: &
+       cldtype,     & ! Opaque/thin cloud covers + z_opaque altitude
+       cldtypetemp    ! Opaque and thin clouds + z_opaque temperature
+    real(wp),intent(out),dimension(Npoints,2) :: &
+       cldtypemeanz   ! Opaque and thin clouds altitude
+    real(wp),intent(out),dimension(Npoints,3) :: & 
+       cldtypemeanzse ! Opaque, thin clouds and z_opaque altitude with respect to SE
+    real(wp),intent(out),dimension(Npoints) :: &
+       cldthinemis    ! Thin clouds emissivity
+   
+    ! Local variables
+    integer  :: &
+       ip, k, zopac, ic, iz, z_top, z_base, topcloud
+    real(wp)  :: &
+       srmean, srcount, trans2, tau_app, tau_vis, tau_ir, cloudemis
+    real(wp),dimension(Npoints) :: &
+       count_emis
+    real(wp),dimension(Npoints,Nlevels) :: &
+       nsub, nsubopaq 
+    real(wp),dimension(Npoints,Ncolumns,Ntype+1) :: & ! Opaque, thin, z_opaque and all cloud cover
+       cldlay, nsublay   
+    real(wp),dimension(Npoints,Ntype) :: &
+       nsublayer
+    real(wp),dimension(Npoints,Ncolumns,Nlevels) :: &   
+       cldy,     & ! 
+       cldyopaq, & ! 
+       srok,     & !
+       srokopaq    !
+
+    ! ####################################################################################
+	! 1) Initialize    
+    ! ####################################################################################
+    cldtype(:,:)          = 0._wp
+    cldtypetemp(:,:)      = 0._wp
+    cldtypemeanz(:,:)     = 0._wp
+    cldtypemeanzse(:,:)   = 0._wp
+    cldthinemis(:)        = 0._wp
+    count_emis(:)         = 0._wp
+    lidarcldtype(:,:,:)   = 0._wp
+    nsub                  = 0._wp
+    nsubopaq              = 0._wp
+    cldlay                = 0._wp
+    nsublay               = 0._wp
+    nsublayer             = 0._wp
+
+    ! ####################################################################################
+    ! 2) Cloud detection and Fully attenuated layer detection
+    ! ####################################################################################
+    do k=1,Nlevels
+       ! Cloud detection at subgrid-scale:
+       where ( (x(:,:,k) .gt. S_cld) .and. (x(:,:,k) .ne. undef) )
+          cldy(:,:,k)=1._wp
+       elsewhere
+          cldy(:,:,k)=0._wp
+       endwhere
+       ! Fully attenuated layer detection at subgrid-scale:
+       where ( (x(:,:,k) .lt. S_att_opaq) .and. (x(:,:,k) .ge. 0.) .and. (x(:,:,k) .ne. undef) ) !DEBUG
+          cldyopaq(:,:,k)=1._wp
+       elsewhere
+          cldyopaq(:,:,k)=0._wp
+       endwhere
+
+
+       ! Number of usefull sub-column layers:
+       where ( (x(:,:,k) .gt. S_att) .and. (x(:,:,k) .ne. undef) )
+          srok(:,:,k)=1._wp
+       elsewhere
+          srok(:,:,k)=0._wp
+       endwhere
+       ! Number of usefull sub-columns layers for z_opaque 3D fraction:
+       where ( (x(:,:,k) .ge. 0.) .and. (x(:,:,k) .ne. undef) ) !DEBUG
+          srokopaq(:,:,k)=1._wp
+       elsewhere
+          srokopaq(:,:,k)=0._wp
+       endwhere
+    enddo
+
+    ! ####################################################################################
+    ! 3) Grid-box 3D OPAQ product fraction and cloud type cover (opaque/thin) + mean z_opaque
+    ! ####################################################################################
+
+    do k=1,Nlevels
+       do ic = 1, Ncolumns
+          do ip = 1, Npoints
+
+             cldlay(ip,ic,1)   = MAX(cldlay(ip,ic,1),cldyopaq(ip,ic,k)) ! Opaque cloud
+             cldlay(ip,ic,4)   = MAX(cldlay(ip,ic,4),cldy(ip,ic,k))     ! All cloud
+
+             nsublay(ip,ic,1)  = MAX(nsublay(ip,ic,1),srok(ip,ic,k))
+             nsublay(ip,ic,2)  = MAX(nsublay(ip,ic,2),srok(ip,ic,k))
+!             nsublay(ip,ic,4)  = MAX(nsublay(ip,ic,4),srok(ip,ic,k))
+             nsub(ip,k)        = nsub(ip,k) + srok(ip,ic,k)
+             nsubopaq(ip,k)    = nsubopaq(ip,k) + srokopaq(ip,ic,k)
+
+          enddo
+       enddo
+    enddo   
+
+! OPAQ variables
+     do ic = 1, Ncolumns
+        do ip = 1, Npoints
+
+     ! Declaring non-opaque cloudy profiles as thin cloud profiles
+	   if ( cldlay(ip,ic,4).gt. 0. .and. cldlay(ip,ic,1) .eq. 0. ) then
+	      cldlay(ip,ic,2)  =  1._wp
+ 	   endif
+
+     ! Filling in 3D and 2D variables
+
+     ! Opaque cloud profiles
+	   if ( cldlay(ip,ic,1) .eq. 1. ) then
+	      zopac = 0._wp
+	      z_top = 0._wp
+	      do k=1,Nlevels-1
+     ! Declaring z_opaque altitude and opaque cloud fraction for 3D and 2D variables
+     ! From SFC-2-TOA ( actually from vgrid_z(SFC+1) = vgrid_z(Nlevels-1) )
+	         if ( cldy(ip,ic,Nlevels-k) .eq. 1. .and. zopac .eq. 0. ) then
+		    lidarcldtype(ip,Nlevels-k + 1,3) = lidarcldtype(ip,Nlevels-k + 1,3) + 1._wp
+		    cldlay(ip,ic,3)                  = vgrid_z(Nlevels-k+1)      ! z_opaque altitude
+		    nsublay(ip,ic,3)                 = 1._wp
+		    zopac = Nlevels-k+1                        ! z_opaque vertical index on vgrid_z
+		 endif
+	         if ( cldy(ip,ic,Nlevels-k) .eq. 1. ) then
+		    lidarcldtype(ip,Nlevels-k ,1)    = lidarcldtype(ip,Nlevels-k ,1) + 1._wp
+		    z_top = Nlevels-k    ! top cloud layer vertical index on vgrid_z
+                 endif
+	      enddo
+     ! Summing opaque cloud mean temperatures and altitudes
+     ! as defined in Vaillant de Guelis et al. 2017a, AMT
+              if (zopac .ne. 0) then 
+                 cldtypetemp(ip,1) = cldtypetemp(ip,1) + ( tmp(ip,zopac) + tmp(ip,z_top) )/2.
+                 cldtypetemp(ip,3) = cldtypetemp(ip,3) + tmp(ip,zopac)                 ! z_opaque
+                 cldtypemeanz(ip,1) = cldtypemeanz(ip,1) + ( vgrid_z(zopac) + vgrid_z(z_top) )/2.
+                 cldtypemeanzse(ip,1) = cldtypemeanzse(ip,1) + (( vgrid_z(zopac) + vgrid_z(z_top) )/2.) - surfelev(ip)
+                 cldtypemeanzse(ip,3) = cldtypemeanzse(ip,3) + ( vgrid_z(zopac) - surfelev(ip) )
+              else
+                 cldlay(ip,ic,1) = 0
+              endif
+	   endif
+
+     ! Thin cloud profiles
+	   if ( cldlay(ip,ic,2) .eq. 1. ) then
+	      topcloud = 0._wp
+	      z_top = 0._wp
+	      z_base = 0._wp
+	      do k=1,Nlevels
+     ! Declaring thin cloud fraction for 3D variable
+     ! From TOA-2-SFC
+                 if ( cldy(ip,ic,k) .eq. 1. .and. topcloud .eq. 1. ) then
+                    lidarcldtype(ip,k,2) = lidarcldtype(ip,k,2) + 1._wp
+		    z_base = k ! bottom cloud layer
+                 endif
+	         if ( cldy(ip,ic,k) .eq. 1. .and. topcloud .eq. 0. ) then
+                    lidarcldtype(ip,k,2) = lidarcldtype(ip,k,2) + 1._wp
+		    z_top = k  ! top cloud layer
+		    z_base = k ! bottom cloud layer
+                    topcloud = 1._wp
+		 endif
+	      enddo
+     ! Computing mean emissivity using layers below the bottom cloud layer to the surface
+     	      srmean = 0._wp
+	      srcount = 0._wp
+	      cloudemis = 0._wp
+     	      do k=z_base+1,Nlevels
+	         if (  (x(ip,ic,k) .gt. S_att_opaq) .and. (x(ip,ic,k) .lt. 1.0) .and. (x(ip,ic,k) .ne. undef)  ) then
+		    srmean = srmean + x(ip,ic,k)
+		    srcount = srcount + 1.
+                 endif
+	      enddo
+	      ! If clear sky layers exist below bottom cloud layer
+	      if ( srcount .gt. 0. ) then
+	      	 trans2 = srmean/srcount              ! thin cloud transmittance**2
+	      	 tau_app = -(log(trans2))/2.          ! apparent cloud optical depth
+	      	 tau_vis = tau_app/eta                ! cloud visible optical depth (multiple scat.)
+	      	 tau_ir = tau_vis/2.                  ! approx. relation between visible and IR ODs
+	      	 cloudemis = 1. - exp(-tau_ir)        ! no diffusion in IR considered : emis = 1-T
+		 count_emis(ip) = count_emis(ip) + 1.
+	      endif
+     ! Summing thin cloud mean temperatures and altitudes
+     ! as defined in Vaillant de Guelis et al. 2017a, AMT
+              cldtypetemp(ip,2) = cldtypetemp(ip,2) + ( tmp(ip,z_base) + tmp(ip,z_top) )/2.
+              cldtypemeanz(ip,2) = cldtypemeanz(ip,2) + ( vgrid_z(z_base) + vgrid_z(z_top) )/2.
+              cldtypemeanzse(ip,2) = cldtypemeanzse(ip,2) + (( vgrid_z(z_base) + vgrid_z(z_top) )/2.) - surfelev(ip)
+              cldthinemis(ip) = cldthinemis(ip) + cloudemis
+           endif
+
+       enddo
+    enddo   
+
+    ! 3D cloud types fraction (opaque=1 and thin=2 clouds)
+    where ( nsub(:,:) .gt. 0. )
+       lidarcldtype(:,:,1) = lidarcldtype(:,:,1)/nsub(:,:)
+       lidarcldtype(:,:,2) = lidarcldtype(:,:,2)/nsub(:,:)
+    elsewhere
+       lidarcldtype(:,:,1) = undef
+       lidarcldtype(:,:,2) = undef
+    endwhere
+    ! 3D z_opaque fraction (=3)
+    where ( nsubopaq(:,:) .gt. 0. )
+       lidarcldtype(:,:,3) = lidarcldtype(:,:,3)/nsubopaq(:,:)
+    elsewhere
+       lidarcldtype(:,:,3) = undef
+       lidarcldtype(:,:,4) = undef !declaring undef for opacity as well
+    endwhere
+    ! 3D opacity fraction (=4) !Summing z_opaque fraction from TOA(k=1) to SFC(k=Nlevels)
+       lidarcldtype(:,1,4) = lidarcldtype(:,1,3) !top layer equal to 3D z_opaque fraction
+    do ip = 1, Npoints
+     	do k = 2, Nlevels
+            if ( (lidarcldtype(ip,k,3) .ne. undef) .and. (lidarcldtype(ip,k-1,4) .ne. undef) ) then
+	        lidarcldtype(ip,k,4) = lidarcldtype(ip,k,3) + lidarcldtype(ip,k-1,4)
+	    else
+	        lidarcldtype(ip,k,4) = undef
+	    endif
+	enddo
+    enddo
+
+    ! Layered cloud types (opaque, thin and z_opaque 2D variables)
+
+    do iz = 1, Ntype
+       do ic = 1, Ncolumns
+          cldtype(:,iz)  = cldtype(:,iz)  + cldlay(:,ic,iz)
+          nsublayer(:,iz) = nsublayer(:,iz) + nsublay(:,ic,iz)
+       enddo
+    enddo
+
+    ! Mean temperature and altitude
+    where (cldtype(:,1) .gt. 0.)
+       cldtypetemp(:,1) = cldtypetemp(:,1)/cldtype(:,1) ! opaque cloud temp
+       cldtypetemp(:,3) = cldtypetemp(:,3)/cldtype(:,1) ! z_opaque
+       cldtypemeanz(:,1) = cldtypemeanz(:,1)/cldtype(:,1) ! opaque cloud alt
+       cldtypemeanzse(:,1) = cldtypemeanzse(:,1)/cldtype(:,1) ! opaque cloud alt - SE 
+       cldtypemeanzse(:,3) = cldtypemeanzse(:,3)/cldtype(:,1) ! z_opaque - SE 
+    elsewhere
+       cldtypetemp(:,1) = undef
+       cldtypetemp(:,3) = undef
+       cldtypemeanz(:,1) = undef
+       cldtypemeanzse(:,1) = undef
+       cldtypemeanzse(:,3) = undef
+    endwhere
+
+    where (cldtype(:,2) .gt. 0.) ! thin cloud
+       cldtypetemp(:,2) = cldtypetemp(:,2)/cldtype(:,2)
+       cldtypemeanz(:,2) = cldtypemeanz(:,2)/cldtype(:,2)
+       cldtypemeanzse(:,2) = cldtypemeanzse(:,2)/cldtype(:,2)
+    elsewhere
+       cldtypetemp(:,2) = undef
+       cldtypemeanz(:,2) = undef
+       cldtypemeanzse(:,2) = undef
+    endwhere
+
+    ! Mean thin cloud emissivity
+    where (count_emis(:) .gt. 0.) ! thin cloud
+       cldthinemis(:) = cldthinemis(:)/count_emis(:)
+    elsewhere
+       cldthinemis(:) = undef
+    endwhere
+
+    where (nsublayer(:,:) .gt. 0.)
+       cldtype(:,:) = cldtype(:,:)/nsublayer(:,:)
+    elsewhere
+       cldtype(:,:) = undef
+    endwhere
+
+  END SUBROUTINE COSP_OPAQ
+
+end module mod_lidar_simulator
Index: DZ6/trunk/libf/phylmd/cospv2/lmdz_cosp_construct_destroy_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cospv2/lmdz_cosp_construct_destroy_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,675 +1,0 @@
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-!
-! Module pour construir et detruire les variables "cospIN", "cospstateIN" et "cospOUT"
-!
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-
-MODULE LMDZ_COSP_CONSTRUCT_DESTROY_MOD
-
-use cosp_kinds, only: wp
-use mod_cosp,   only: cosp_optical_inputs,cosp_column_inputs,cosp_outputs
-use lmdz_cosp_read_outputkeys, only: cosp_config
-
-   USE mod_cosp_config, only : R_UNDEF, CLOUDSAT_DBZE_BINS, SR_BINS, PARASOL_NREFL, & 
-                              LIDAR_NTEMP, LIDAR_NCAT, LIDAR_NTYPE, & 
-                              numMODISReffIceBins,reffICE_binCenters, &
-                              numMODISReffLiqBins, reffLIQ_binCenters, &
-			      numISCCPTauBins,numISCCPPresBins, &
-			      numMISRTauBins,numMISRHgtBins, &
-			      numModisTauBins,numMODISPresBins
-
-  implicit none
-
-contains
-
-
-  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-  ! SUBROUTINE construct_cospIN
-  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-  subroutine construct_cospIN(cfg,npoints,ncolumns,nlevels,y)
-    ! Inputs
-    integer,intent(in) :: &
-         npoints,  & ! Number of horizontal gridpoints
-         ncolumns, & ! Number of subcolumns
-         nlevels     ! Number of vertical levels
-
-     type(cosp_config),intent(in) :: &
-          cfg         ! COSP output config (logical keys)
-
-    ! Outputs 
-    type(cosp_optical_inputs),intent(out) :: y
-    
-    ! Dimensions
-    y%Npoints  = Npoints
-    y%Ncolumns = Ncolumns
-    y%Nlevels  = Nlevels
-    y%Npart    = 4
-    y%Nrefl    = PARASOL_NREFL
-    allocate(y%frac_out(npoints,       ncolumns,nlevels))
-
-    if (cfg%Lmodis .or. cfg%Lmisr .or. cfg%Lisccp) then
-       allocate(y%tau_067(npoints,        ncolumns,nlevels),&
-                y%emiss_11(npoints,       ncolumns,nlevels))
-    endif
-    if (cfg%Lcalipso) then
-       allocate(y%betatot_calipso(npoints,        ncolumns,nlevels),&
-                y%betatot_ice_calipso(npoints,    ncolumns,nlevels),&
-                y%betatot_liq_calipso(npoints,    ncolumns,nlevels),&
-                y%tautot_calipso(npoints,         ncolumns,nlevels),&
-                y%tautot_ice_calipso(npoints,     ncolumns,nlevels),&
-                y%tautot_liq_calipso(npoints,     ncolumns,nlevels),&
-                y%beta_mol_calipso(npoints,                nlevels),&
-                y%tau_mol_calipso(npoints,                 nlevels),&
-                y%tautot_S_ice(npoints,   ncolumns        ),&
-                y%tautot_S_liq(npoints,   ncolumns        ))
-    endif
-
-    if (cfg%LgrLidar532) then
-       allocate(y%beta_mol_grLidar532(npoints,          nlevels),& 
-                y%betatot_grLidar532(npoints,  ncolumns,nlevels),& 
-                y%tau_mol_grLidar532(npoints,           nlevels),& 
-                y%tautot_grLidar532(npoints,   ncolumns,nlevels)) 
-    endif
-
-    if (cfg%Latlid) then
-       allocate(y%beta_mol_atlid(npoints,             nlevels),& 
-                y%betatot_atlid(npoints,     ncolumns,nlevels),& 
-                y%tau_mol_atlid(npoints,              nlevels),& 
-                y%tautot_atlid(npoints,      ncolumns,nlevels))
-    endif 
-
-    if (cfg%Lcloudsat) then
-       allocate(y%z_vol_cloudsat(npoints,  ncolumns,nlevels),&
-                y%kr_vol_cloudsat(npoints, ncolumns,nlevels),&
-                y%g_vol_cloudsat(npoints,  ncolumns,nlevels),&
-                y%fracPrecipIce(npoints,   ncolumns))
-    endif
-    if (cfg%Lmodis) then
-       allocate(y%fracLiq(npoints,        ncolumns,nlevels),&
-                y%asym(npoints,           ncolumns,nlevels),&
-                y%ss_alb(npoints,         ncolumns,nlevels))
-    endif
-    
-
-  end subroutine construct_cospIN  
-  
-  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-  ! SUBROUTINE construct_cospstateIN
-  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%     
-  subroutine construct_cospstateIN(npoints,nlevels,nchan,y)
-    ! Inputs
-    integer,intent(in) :: &
-         npoints, & ! Number of horizontal gridpoints
-         nlevels, & ! Number of vertical levels
-         nchan      ! Number of channels
-    ! Outputs
-    type(cosp_column_inputs),intent(out) :: y         
-    
-    allocate(y%sunlit(npoints),y%skt(npoints),y%land(npoints),y%at(npoints,nlevels),     &
-             y%pfull(npoints,nlevels),y%phalf(npoints,nlevels+1),y%qv(npoints,nlevels),  &
-             y%o3(npoints,nlevels),y%hgt_matrix(npoints,nlevels),y%u_sfc(npoints),       &
-             y%v_sfc(npoints),y%lat(npoints),y%lon(nPoints),y%emis_sfc(nchan),           &
-             y%cloudIce(nPoints,nLevels),y%cloudLiq(nPoints,nLevels),y%surfelev(npoints),&
-             y%fl_snow(nPoints,nLevels),y%fl_rain(nPoints,nLevels),y%seaice(npoints),    &
-             y%tca(nPoints,nLevels),y%hgt_matrix_half(npoints,nlevels+1))
-
-  end subroutine construct_cospstateIN
-
-  ! ######################################################################################
-  ! SUBROUTINE construct_cosp_outputs
-  !
-  ! This subroutine allocates output fields based on input logical flag switches.
-  ! ######################################################################################  
-  subroutine construct_cosp_outputs(cfg,Npoints,Ncolumns,Nlevels,Nlvgrid,Nchan,x)
-     ! Inputs        
-     integer,intent(in) :: &
-          Npoints,         & ! Number of sampled points
-          Ncolumns,        & ! Number of subgrid columns
-          Nlevels,         & ! Number of model levels
-          Nlvgrid,         & ! Number of levels in L3 stats computation
-          Nchan              ! Number of RTTOV channels            
-     type(cosp_config),intent(in) :: &
-          cfg         ! COSP output config (logical keys)
-
-     ! Outputs
-     type(cosp_outputs),intent(out) :: &
-          x           ! COSP output structure  
-   
-     ! ISCCP simulator outputs
-    if (cfg%Lboxtauisccp)    allocate(x%isccp_boxtau(Npoints,Ncolumns)) 
-    if (cfg%Lboxptopisccp)   allocate(x%isccp_boxptop(Npoints,Ncolumns))
-    if (cfg%Lclisccp)        allocate(x%isccp_fq(Npoints,numISCCPTauBins,numISCCPPresBins))
-    if (cfg%Lcltisccp)       allocate(x%isccp_totalcldarea(Npoints))
-    if (cfg%Lpctisccp)       allocate(x%isccp_meanptop(Npoints))
-    if (cfg%Ltauisccp)       allocate(x%isccp_meantaucld(Npoints))
-    if (cfg%Lmeantbisccp)    allocate(x%isccp_meantb(Npoints))
-    if (cfg%Lmeantbclrisccp) allocate(x%isccp_meantbclr(Npoints))
-    if (cfg%Lalbisccp)       allocate(x%isccp_meanalbedocld(Npoints))
-    
-    ! MISR simulator
-    if (cfg%LclMISR) then 
-       allocate(x%misr_fq(Npoints,numMISRTauBins,numMISRHgtBins))
-       ! *NOTE* These 3 fields are not output, but were part of the v1.4.0 cosp_misr, so
-       !        they are still computed. Should probably have a logical to control these
-       !        outputs.
-       allocate(x%misr_dist_model_layertops(Npoints,numMISRHgtBins))
-       allocate(x%misr_meanztop(Npoints))
-       allocate(x%misr_cldarea(Npoints))    
-    endif
-    
-    ! MODIS simulator
-    if (cfg%Lcltmodis)     allocate(x%modis_Cloud_Fraction_Total_Mean(Npoints))
-    if (cfg%Lclwmodis)     allocate(x%modis_Cloud_Fraction_Water_Mean(Npoints))
-    if (cfg%Lclimodis)     allocate(x%modis_Cloud_Fraction_Ice_Mean(Npoints))
-    if (cfg%Lclhmodis)     allocate(x%modis_Cloud_Fraction_High_Mean(Npoints))
-    if (cfg%Lclmmodis)     allocate(x%modis_Cloud_Fraction_Mid_Mean(Npoints))
-    if (cfg%Lcllmodis)     allocate(x%modis_Cloud_Fraction_Low_Mean(Npoints))
-    if (cfg%Ltautmodis)    allocate(x%modis_Optical_Thickness_Total_Mean(Npoints))
-    if (cfg%Ltauwmodis)    allocate(x%modis_Optical_Thickness_Water_Mean(Npoints))
-    if (cfg%Ltauimodis)    allocate(x%modis_Optical_Thickness_Ice_Mean(Npoints))
-    if (cfg%Ltautlogmodis) allocate(x%modis_Optical_Thickness_Total_LogMean(Npoints))
-    if (cfg%Ltauwlogmodis) allocate(x%modis_Optical_Thickness_Water_LogMean(Npoints))
-    if (cfg%Ltauilogmodis) allocate(x%modis_Optical_Thickness_Ice_LogMean(Npoints))
-    if (cfg%Lreffclwmodis) allocate(x%modis_Cloud_Particle_Size_Water_Mean(Npoints))
-    if (cfg%Lreffclimodis) allocate(x%modis_Cloud_Particle_Size_Ice_Mean(Npoints))
-    if (cfg%Lpctmodis)     allocate(x%modis_Cloud_Top_Pressure_Total_Mean(Npoints))
-    if (cfg%Llwpmodis)     allocate(x%modis_Liquid_Water_Path_Mean(Npoints))
-    if (cfg%Liwpmodis)     allocate(x%modis_Ice_Water_Path_Mean(Npoints))
-    if (cfg%Lclmodis) then
-        allocate(x%modis_Optical_Thickness_vs_Cloud_Top_Pressure(nPoints,numModisTauBins,numMODISPresBins))
-        allocate(x%modis_Optical_thickness_vs_ReffLIQ(nPoints,numMODISTauBins,numMODISReffLiqBins))   
-        allocate(x%modis_Optical_Thickness_vs_ReffICE(nPoints,numMODISTauBins,numMODISReffIceBins))
-    endif
-    
-    ! LIDAR simulator
-    if (cfg%LlidarBetaMol532) allocate(x%calipso_beta_mol(Npoints,Nlevels))
-    if (cfg%Latb532)          allocate(x%calipso_beta_tot(Npoints,Ncolumns,Nlevels))
-    if (cfg%LcfadLidarsr532)  then
-        allocate(x%calipso_srbval(SR_BINS+1))
-        allocate(x%calipso_cfad_sr(Npoints,SR_BINS,Nlvgrid))
-        allocate(x%calipso_betaperp_tot(Npoints,Ncolumns,Nlevels))  
-    endif
-    if (cfg%Lclcalipso)       allocate(x%calipso_lidarcld(Npoints,Nlvgrid))
-    if (cfg%Lclhcalipso .or. cfg%Lclmcalipso .or. cfg%Lcllcalipso .or. cfg%Lcltcalipso) then
-        allocate(x%calipso_cldlayer(Npoints,LIDAR_NCAT))
-    endif   
-    if (cfg%Lclcalipsoice .or. cfg%Lclcalipsoliq .or. cfg%Lclcalipsoun) then
-        allocate(x%calipso_lidarcldphase(Npoints,Nlvgrid,6))
-    endif
-    if (cfg%Lclcalipsotmp .or. cfg%Lclcalipsotmpliq .or. cfg%Lclcalipsoice .or. &
-                          cfg%Lclcalipsotmpun .or. cfg%Lclcalipsotmpice) then
-        allocate(x%calipso_lidarcldtmp(Npoints,LIDAR_NTEMP,5))
-    endif
-    if (cfg%Lcllcalipsoice .or. cfg%Lclmcalipsoice .or. cfg%Lclhcalipsoice .or.             &
-        cfg%Lcltcalipsoice .or. cfg%Lcllcalipsoliq .or. cfg%Lclmcalipsoliq .or.             &
-        cfg%Lclhcalipsoliq .or. cfg%Lcltcalipsoliq .or. cfg%Lcllcalipsoun  .or.             &
-        cfg%Lclmcalipsoun  .or. cfg%Lclhcalipsoun  .or. cfg%Lcltcalipsoun) then
-        allocate(x%calipso_cldlayerphase(Npoints,LIDAR_NCAT,6))     
-    endif
-    if (cfg%Lclopaquecalipso .or. cfg%Lclthincalipso .or. cfg%Lclzopaquecalipso) then
-        allocate(x%calipso_cldtype(Npoints,LIDAR_NTYPE))
-    endif 
-    if (cfg%Lclopaquetemp .or. cfg%Lclthintemp .or. cfg%Lclzopaquetemp) then 
-        allocate(x%calipso_cldtypetemp(Npoints,LIDAR_NTYPE))  
-    endif
-    if (cfg%Lclopaquemeanz .or. cfg%Lclthinmeanz) then 
-        allocate(x%calipso_cldtypemeanz(Npoints,2))
-    endif 
-    if (cfg%Lclopaquemeanzse .or. cfg%Lclthinmeanzse .or. cfg%Lclzopaquecalipsose) then 
-        allocate(x%calipso_cldtypemeanzse(Npoints,3)) 
-    endif 
-    if (cfg%Lclthinemis) then 
-        allocate(x%calipso_cldthinemis(Npoints))
-    endif
-    if (cfg%Lclcalipsoopaque .or. cfg%Lclcalipsothin .or. cfg%Lclcalipsozopaque .or. &
-             cfg%Lclcalipsoopacity) then 
-        allocate(x%calipso_lidarcldtype(Npoints,Nlvgrid,LIDAR_NTYPE+1))
-    endif
-    ! These 2 outputs are part of the calipso output type, but are not controlled by an 
-    ! logical switch in the output namelist, so if all other fields are on, then allocate
-    if (cfg%LlidarBetaMol532 .or. cfg%Latb532        .or. cfg%LcfadLidarsr532 .or. cfg%Lclcalipso  .or.  &
-        cfg%Lclcalipsoice    .or. cfg%Lclcalipsoliq  .or. cfg%Lclcalipsoun    .or. cfg%Lclcalipso2 .or.  &
-        cfg%Lclhcalipso      .or. cfg%Lclmcalipso    .or. cfg%Lcllcalipso     .or. cfg%Lcltcalipso .or.  &
-        cfg%Lclcalipsotmp    .or. cfg%Lclcalipsoice  .or. cfg%Lclcalipsotmpun .or.                       &
-        cfg%Lclcalipsotmpliq .or. cfg%Lcllcalipsoice .or. cfg%Lclmcalipsoice  .or.                       &
-        cfg%Lclhcalipsoice   .or. cfg%Lcltcalipsoice .or. cfg%Lcllcalipsoliq  .or.                       &
-        cfg%Lclmcalipsoliq   .or. cfg%Lclhcalipsoliq .or. cfg%Lcltcalipsoliq  .or.                       &
-        cfg%Lcllcalipsoun    .or. cfg%Lclmcalipsoun  .or. cfg%Lclhcalipsoun   .or. cfg%Lcltcalipsoun) then
-       allocate(x%calipso_tau_tot(Npoints,Ncolumns,Nlevels))       
-       allocate(x%calipso_temp_tot(Npoints,Nlevels))               
-    endif
-
-    ! GROUND LIDAR @ 532NM simulator
-    if (cfg%LlidarBetaMol532gr) allocate(x%grLidar532_beta_mol(Npoints,Nlevels))
-    if (cfg%Latb532gr)          allocate(x%grLidar532_beta_tot(Npoints,Ncolumns,Nlevels))
-    if (cfg%LcfadLidarsr532gr) then 
-        allocate(x%grLidar532_srbval(SR_BINS+1)) 
-        allocate(x%grLidar532_cfad_sr(Npoints,SR_BINS,Nlvgrid))
-    endif
-    if (cfg%LclgrLidar532)     allocate(x%grLidar532_lidarcld(Npoints,Nlvgrid)) 
-    if (cfg%LclhgrLidar532 .or. cfg%LclmgrLidar532 .or. cfg%LcllgrLidar532 .or. cfg%LcltgrLidar532) then
-        allocate(x%grLidar532_cldlayer(Npoints,LIDAR_NCAT))  
-    endif
-      
-    ! ATLID simulator
-    if (cfg%LlidarBetaMol355) allocate(x%atlid_beta_mol(Npoints,Nlevels))
-    if (cfg%Latb355)          allocate(x%atlid_beta_tot(Npoints,Ncolumns,Nlevels))
-    if (cfg%LcfadLidarsr355) then
-        allocate(x%atlid_srbval(SR_BINS+1)) 
-        allocate(x%atlid_cfad_sr(Npoints,SR_BINS,Nlvgrid))
-    endif 
-    if (cfg%Lclatlid)     allocate(x%atlid_lidarcld(Npoints,Nlvgrid)) 
-    if (cfg%Lclhatlid .or. cfg%Lclmatlid .or. cfg%Lcllatlid .or. cfg%Lcltatlid) then
-        allocate(x%atlid_cldlayer(Npoints,LIDAR_NCAT)) 
-    endif
-      
-    ! PARASOL
-    if (cfg%Lparasolrefl) then
-        allocate(x%parasolPix_refl(Npoints,Ncolumns,PARASOL_NREFL))
-        allocate(x%parasolGrid_refl(Npoints,PARASOL_NREFL))
-    endif 
-
-    ! Cloudsat simulator
-    if (cfg%Ldbze94)        allocate(x%cloudsat_Ze_tot(Npoints,Ncolumns,Nlevels))
-    if (cfg%LcfadDbze94)    allocate(x%cloudsat_cfad_ze(Npoints,cloudsat_DBZE_BINS,Nlvgrid))
-    if (cfg%Lptradarflag0 .or. cfg%Lptradarflag1 .or. cfg%Lptradarflag2 .or. cfg%Lptradarflag3 .or. &
-        cfg%Lptradarflag4 .or. cfg%Lptradarflag5 .or. cfg%Lptradarflag6 .or. cfg%Lptradarflag7 .or. &
-        cfg%Lptradarflag8 .or. cfg%Lptradarflag9) then
-       allocate(x%cloudsat_precip_cover(Npoints,cloudsat_DBZE_BINS))
-    endif
-    if (cfg%Lradarpia) allocate(x%cloudsat_pia(Npoints))
-
-    ! Combined CALIPSO/CLOUDSAT fields
-    if (cfg%Lclcalipso2)    allocate(x%lidar_only_freq_cloud(Npoints,Nlvgrid))
-    if (cfg%Lcltlidarradar) allocate(x%radar_lidar_tcc(Npoints))
-    if (cfg%Lcloudsat_tcc)  allocate(x%cloudsat_tcc(Npoints))
-    if (cfg%Lcloudsat_tcc2) allocate(x%cloudsat_tcc2(Npoints))
-            
-    ! RTTOV
-    if (cfg%Ltbrttov) allocate(x%rttov_tbs(Npoints,Nchan))
- 
-  end subroutine construct_cosp_outputs
-
-  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-  ! SUBROUTINE destroy_cospIN     
-  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-  subroutine destroy_cospIN(y)
-    type(cosp_optical_inputs),intent(inout) :: y
-
-    if (allocated(y%tau_067))       	  deallocate(y%tau_067)
-    if (allocated(y%emiss_11))      	  deallocate(y%emiss_11)
-    if (allocated(y%frac_out))    	  deallocate(y%frac_out)
-    if (allocated(y%beta_mol_calipso))    deallocate(y%beta_mol_calipso)
-    if (allocated(y%tau_mol_calipso))     deallocate(y%tau_mol_calipso)
-    if (allocated(y%betatot_calipso))     deallocate(y%betatot_calipso)
-    if (allocated(y%betatot_ice_calipso)) deallocate(y%betatot_ice_calipso)
-    if (allocated(y%betatot_liq_calipso)) deallocate(y%betatot_liq_calipso)
-    if (allocated(y%tautot_calipso))      deallocate(y%tautot_calipso)
-    if (allocated(y%tautot_ice_calipso))  deallocate(y%tautot_ice_calipso)
-    if (allocated(y%tautot_liq_calipso))  deallocate(y%tautot_liq_calipso)
-    if (allocated(y%tautot_S_liq))	  deallocate(y%tautot_S_liq)
-    if (allocated(y%tautot_S_ice))    	  deallocate(y%tautot_S_ice)
-    if (allocated(y%z_vol_cloudsat))  	  deallocate(y%z_vol_cloudsat)
-    if (allocated(y%kr_vol_cloudsat)) 	  deallocate(y%kr_vol_cloudsat)
-    if (allocated(y%g_vol_cloudsat)) 	  deallocate(y%g_vol_cloudsat)
-    if (allocated(y%asym))            	  deallocate(y%asym)
-    if (allocated(y%ss_alb))         	  deallocate(y%ss_alb)
-    if (allocated(y%fracLiq))       	  deallocate(y%fracLiq)
-    if (allocated(y%beta_mol_grLidar532)) deallocate(y%beta_mol_grLidar532)
-    if (allocated(y%betatot_grLidar532))  deallocate(y%betatot_grLidar532)
-    if (allocated(y%tau_mol_grLidar532))  deallocate(y%tau_mol_grLidar532)
-    if (allocated(y%tautot_grLidar532))   deallocate(y%tautot_grLidar532)
-    if (allocated(y%beta_mol_atlid))      deallocate(y%beta_mol_atlid) 
-    if (allocated(y%betatot_atlid))       deallocate(y%betatot_atlid) 
-    if (allocated(y%tau_mol_atlid))       deallocate(y%tau_mol_atlid) 
-    if (allocated(y%tautot_atlid))        deallocate(y%tautot_atlid)
-    if (allocated(y%fracPrecipIce))       deallocate(y%fracPrecipIce)
-
-  end subroutine destroy_cospIN
-  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-  ! SUBROUTINE destroy_cospstateIN     
-  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%  
-  subroutine destroy_cospstateIN(y)
-    type(cosp_column_inputs),intent(inout) :: y
-
-    if (allocated(y%sunlit))          deallocate(y%sunlit)
-    if (allocated(y%skt))             deallocate(y%skt)
-    if (allocated(y%land))            deallocate(y%land)
-    if (allocated(y%at))              deallocate(y%at)
-    if (allocated(y%pfull))           deallocate(y%pfull)
-    if (allocated(y%phalf))           deallocate(y%phalf)
-    if (allocated(y%qv))              deallocate(y%qv)
-    if (allocated(y%o3))              deallocate(y%o3)
-    if (allocated(y%hgt_matrix))      deallocate(y%hgt_matrix)
-    if (allocated(y%u_sfc))           deallocate(y%u_sfc)
-    if (allocated(y%v_sfc))           deallocate(y%v_sfc)
-    if (allocated(y%lat))             deallocate(y%lat)
-    if (allocated(y%lon))             deallocate(y%lon)
-    if (allocated(y%emis_sfc))        deallocate(y%emis_sfc)
-    if (allocated(y%cloudIce))        deallocate(y%cloudIce)
-    if (allocated(y%cloudLiq))        deallocate(y%cloudLiq)
-    if (allocated(y%seaice))          deallocate(y%seaice)
-    if (allocated(y%fl_rain))         deallocate(y%fl_rain)
-    if (allocated(y%fl_snow))         deallocate(y%fl_snow)
-    if (allocated(y%tca))             deallocate(y%tca)
-    if (allocated(y%hgt_matrix_half)) deallocate(y%hgt_matrix_half)    
-    if (allocated(y%surfelev))        deallocate(y%surfelev)
-    
-  end subroutine destroy_cospstateIN
-  
-  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-  ! SUBROUTINE destroy_cosp_outputs
-  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%  
-  subroutine destroy_cosp_outputs(y)
-     type(cosp_outputs),intent(inout) :: y
-
-     ! Deallocate and nullify
-     if (associated(y%calipso_beta_mol))          then
-        deallocate(y%calipso_beta_mol)
-        nullify(y%calipso_beta_mol)
-     endif
-     if (associated(y%calipso_temp_tot))          then
-        deallocate(y%calipso_temp_tot)
-        nullify(y%calipso_temp_tot)     
-     endif
-     if (associated(y%calipso_betaperp_tot))      then
-        deallocate(y%calipso_betaperp_tot)
-        nullify(y%calipso_betaperp_tot)     
-     endif
-     if (associated(y%calipso_beta_tot))          then
-        deallocate(y%calipso_beta_tot)    
-        nullify(y%calipso_beta_tot)     
-     endif
-     if (associated(y%calipso_tau_tot))           then
-        deallocate(y%calipso_tau_tot) 
-        nullify(y%calipso_tau_tot)     
-     endif
-     if (associated(y%calipso_lidarcldphase))     then
-        deallocate(y%calipso_lidarcldphase)
-        nullify(y%calipso_lidarcldphase)     
-     endif
-     if (associated(y%calipso_lidarcldtype))     then
-        deallocate(y%calipso_lidarcldtype) 
-        nullify(y%calipso_lidarcldtype) 
-     endif
-     if (associated(y%calipso_cldlayerphase))     then
-        deallocate(y%calipso_cldlayerphase)
-        nullify(y%calipso_cldlayerphase)     
-     endif
-     if (associated(y%calipso_lidarcldtmp))       then
-        deallocate(y%calipso_lidarcldtmp)
-        nullify(y%calipso_lidarcldtmp)     
-     endif
-     if (associated(y%calipso_cldlayer))          then
-        deallocate(y%calipso_cldlayer)
-        nullify(y%calipso_cldlayer)     
-     endif
-     if (associated(y%calipso_cldtype))          then
-        deallocate(y%calipso_cldtype)
-        nullify(y%calipso_cldtype)  
-     endif  
-     if (associated(y%calipso_cldtypetemp))      then
-        deallocate(y%calipso_cldtypetemp) 
-        nullify(y%calipso_cldtypetemp) 
-     endif 
-     if (associated(y%calipso_cldtypemeanz))     then
-        deallocate(y%calipso_cldtypemeanz)
-        nullify(y%calipso_cldtypemeanz)  
-     endif  
-     if (associated(y%calipso_cldtypemeanzse))   then 
-        deallocate(y%calipso_cldtypemeanzse) 
-        nullify(y%calipso_cldtypemeanzse)  
-     endif 
-     if (associated(y%calipso_cldthinemis))      then
-        deallocate(y%calipso_cldthinemis)
-        nullify(y%calipso_cldthinemis)
-     endif 
-     if (associated(y%calipso_lidarcld))         then
-        deallocate(y%calipso_lidarcld)
-        nullify(y%calipso_lidarcld)     
-     endif
-     if (associated(y%calipso_srbval))            then
-        deallocate(y%calipso_srbval)
-        nullify(y%calipso_srbval)     
-     endif
-     if (associated(y%calipso_cfad_sr))          then
-        deallocate(y%calipso_cfad_sr)
-        nullify(y%calipso_cfad_sr)     
-     endif
-     if (associated(y%grLidar532_beta_mol))     then
-        deallocate(y%grLidar532_beta_mol)
-        nullify(y%grLidar532_beta_mol)  
-     endif
-     if (associated(y%grLidar532_beta_tot))     then 
-        deallocate(y%grLidar532_beta_tot) 
-        nullify(y%grLidar532_beta_tot)
-     endif 
-     if (associated(y%grLidar532_cldlayer))     then 
-        deallocate(y%grLidar532_cldlayer) 
-        nullify(y%grLidar532_cldlayer) 
-     endif 
-     if (associated(y%grLidar532_lidarcld))     then 
-        deallocate(y%grLidar532_lidarcld) 
-        nullify(y%grLidar532_lidarcld) 
-     endif 
-     if (associated(y%grLidar532_cfad_sr))      then 
-        deallocate(y%grLidar532_cfad_sr)  
-        nullify(y%grLidar532_cfad_sr) 
-     endif 
-     if (associated(y%grLidar532_srbval))       then
-        deallocate(y%grLidar532_srbval) 
-        nullify(y%grLidar532_srbval) 
-     endif  
-     if (associated(y%atlid_beta_mol))           then
-        deallocate(y%atlid_beta_mol) 
-        nullify(y%atlid_beta_mol) 
-     endif 
-     if (associated(y%atlid_beta_tot))           then
-        deallocate(y%atlid_beta_tot) 
-        nullify(y%atlid_beta_tot) 
-     endif
-     if (associated(y%atlid_cldlayer))           then 
-        deallocate(y%atlid_cldlayer)  
-        nullify(y%atlid_cldlayer) 
-     endif 
-     if (associated(y%atlid_lidarcld))           then 
-        deallocate(y%atlid_lidarcld)  
-        nullify(y%atlid_lidarcld) 
-     endif  
-     if (associated(y%atlid_cfad_sr))            then
-        deallocate(y%atlid_cfad_sr) 
-        nullify(y%atlid_cfad_sr) 
-     endif
-     if (associated(y%atlid_srbval))             then 
-        deallocate(y%atlid_srbval) 
-        nullify(y%atlid_srbval) 
-     endif
-     if (associated(y%parasolPix_refl))           then
-        deallocate(y%parasolPix_refl)
-        nullify(y%parasolPix_refl)     
-     endif
-     if (associated(y%parasolGrid_refl))          then
-        deallocate(y%parasolGrid_refl) 
-        nullify(y%parasolGrid_refl)     
-     endif
-     if (associated(y%cloudsat_Ze_tot))           then
-        deallocate(y%cloudsat_Ze_tot) 
-        nullify(y%cloudsat_Ze_tot)  
-     endif
-     if (associated(y%cloudsat_cfad_ze))          then
-        deallocate(y%cloudsat_cfad_ze)
-        nullify(y%cloudsat_cfad_ze)     
-     endif
-     if (associated(y%cloudsat_precip_cover))     then
-        deallocate(y%cloudsat_precip_cover)
-        nullify(y%cloudsat_precip_cover)
-     endif
-     if (associated(y%cloudsat_pia))              then
-        deallocate(y%cloudsat_pia)
-        nullify(y%cloudsat_pia)
-     endif
-     if (associated(y%cloudsat_tcc))           then
-        deallocate(y%cloudsat_tcc) 
-        nullify(y%cloudsat_tcc)  
-     endif
-     if (associated(y%cloudsat_tcc2))           then
-        deallocate(y%cloudsat_tcc2) 
-        nullify(y%cloudsat_tcc2)  
-     endif
-     if (associated(y%radar_lidar_tcc))           then
-        deallocate(y%radar_lidar_tcc) 
-        nullify(y%radar_lidar_tcc)  
-     endif
-     if (associated(y%cloudsat_tcc))           then
-        deallocate(y%cloudsat_tcc) 
-        nullify(y%cloudsat_tcc)  
-     endif
-     if (associated(y%cloudsat_tcc2))           then
-        deallocate(y%cloudsat_tcc2) 
-        nullify(y%cloudsat_tcc2)  
-     endif
-     if (associated(y%lidar_only_freq_cloud))     then
-        deallocate(y%lidar_only_freq_cloud)
-        nullify(y%lidar_only_freq_cloud)     
-     endif
-     if (associated(y%isccp_totalcldarea))        then
-        deallocate(y%isccp_totalcldarea) 
-        nullify(y%isccp_totalcldarea)  
-     endif
-     if (associated(y%isccp_meantb))              then
-        deallocate(y%isccp_meantb) 
-        nullify(y%isccp_meantb)     
-     endif
-     if (associated(y%isccp_meantbclr))           then
-        deallocate(y%isccp_meantbclr)
-        nullify(y%isccp_meantbclr)  
-     endif
-     if (associated(y%isccp_meanptop))            then
-        deallocate(y%isccp_meanptop)
-        nullify(y%isccp_meanptop)     
-     endif
-     if (associated(y%isccp_meantaucld))          then
-        deallocate(y%isccp_meantaucld) 
-        nullify(y%isccp_meantaucld)       
-     endif
-     if (associated(y%isccp_meanalbedocld))       then
-        deallocate(y%isccp_meanalbedocld)
-        nullify(y%isccp_meanalbedocld)     
-     endif
-     if (associated(y%isccp_boxtau))              then
-        deallocate(y%isccp_boxtau)
-        nullify(y%isccp_boxtau)       
-     endif
-     if (associated(y%isccp_boxptop))             then
-        deallocate(y%isccp_boxptop)
-        nullify(y%isccp_boxptop)     
-     endif
-     if (associated(y%isccp_fq))                  then
-        deallocate(y%isccp_fq)
-        nullify(y%isccp_fq)       
-     endif
-     if (associated(y%misr_fq))                   then
-        deallocate(y%misr_fq) 
-        nullify(y%misr_fq)     
-     endif
-     if (associated(y%misr_dist_model_layertops)) then
-        deallocate(y%misr_dist_model_layertops)
-        nullify(y%misr_dist_model_layertops)       
-     endif
-     if (associated(y%misr_meanztop))             then
-        deallocate(y%misr_meanztop)
-        nullify(y%misr_meanztop)     
-     endif
-     if (associated(y%misr_cldarea))              then
-        deallocate(y%misr_cldarea)
-        nullify(y%misr_cldarea)      
-     endif
-     if (associated(y%rttov_tbs))                 then
-        deallocate(y%rttov_tbs)
-        nullify(y%rttov_tbs)     
-     endif
-     if (associated(y%modis_Cloud_Fraction_Total_Mean))                      then
-        deallocate(y%modis_Cloud_Fraction_Total_Mean)       
-        nullify(y%modis_Cloud_Fraction_Total_Mean)       
-     endif
-     if (associated(y%modis_Cloud_Fraction_Ice_Mean))                        then
-        deallocate(y%modis_Cloud_Fraction_Ice_Mean)     
-        nullify(y%modis_Cloud_Fraction_Ice_Mean)     
-     endif
-     if (associated(y%modis_Cloud_Fraction_Water_Mean))                      then
-        deallocate(y%modis_Cloud_Fraction_Water_Mean)           
-        nullify(y%modis_Cloud_Fraction_Water_Mean)           
-     endif
-     if (associated(y%modis_Cloud_Fraction_High_Mean))                       then
-        deallocate(y%modis_Cloud_Fraction_High_Mean)     
-        nullify(y%modis_Cloud_Fraction_High_Mean)     
-     endif
-     if (associated(y%modis_Cloud_Fraction_Mid_Mean))                        then
-        deallocate(y%modis_Cloud_Fraction_Mid_Mean)       
-        nullify(y%modis_Cloud_Fraction_Mid_Mean)       
-     endif
-     if (associated(y%modis_Cloud_Fraction_Low_Mean))                        then
-        deallocate(y%modis_Cloud_Fraction_Low_Mean)     
-        nullify(y%modis_Cloud_Fraction_Low_Mean)     
-     endif
-     if (associated(y%modis_Optical_Thickness_Total_Mean))                   then
-        deallocate(y%modis_Optical_Thickness_Total_Mean)  
-        nullify(y%modis_Optical_Thickness_Total_Mean)  
-     endif
-     if (associated(y%modis_Optical_Thickness_Water_Mean))                   then
-        deallocate(y%modis_Optical_Thickness_Water_Mean)     
-        nullify(y%modis_Optical_Thickness_Water_Mean)     
-     endif
-     if (associated(y%modis_Optical_Thickness_Ice_Mean))                     then
-        deallocate(y%modis_Optical_Thickness_Ice_Mean)       
-        nullify(y%modis_Optical_Thickness_Ice_Mean)       
-     endif
-     if (associated(y%modis_Optical_Thickness_Total_LogMean))                then
-        deallocate(y%modis_Optical_Thickness_Total_LogMean)    
-        nullify(y%modis_Optical_Thickness_Total_LogMean)    
-     endif
-     if (associated(y%modis_Optical_Thickness_Water_LogMean))                then
-        deallocate(y%modis_Optical_Thickness_Water_LogMean)     
-        nullify(y%modis_Optical_Thickness_Water_LogMean)     
-     endif
-     if (associated(y%modis_Optical_Thickness_Ice_LogMean))                  then
-        deallocate(y%modis_Optical_Thickness_Ice_LogMean)     
-        nullify(y%modis_Optical_Thickness_Ice_LogMean)     
-     endif
-     if (associated(y%modis_Cloud_Particle_Size_Water_Mean))                 then
-        deallocate(y%modis_Cloud_Particle_Size_Water_Mean)       
-        nullify(y%modis_Cloud_Particle_Size_Water_Mean)       
-     endif
-     if (associated(y%modis_Cloud_Particle_Size_Ice_Mean))                   then
-        deallocate(y%modis_Cloud_Particle_Size_Ice_Mean)     
-        nullify(y%modis_Cloud_Particle_Size_Ice_Mean)     
-     endif
-     if (associated(y%modis_Cloud_Top_Pressure_Total_Mean))                  then
-        deallocate(y%modis_Cloud_Top_Pressure_Total_Mean)           
-        nullify(y%modis_Cloud_Top_Pressure_Total_Mean)           
-     endif
-     if (associated(y%modis_Liquid_Water_Path_Mean))                         then
-        deallocate(y%modis_Liquid_Water_Path_Mean)     
-        nullify(y%modis_Liquid_Water_Path_Mean)     
-     endif
-     if (associated(y%modis_Ice_Water_Path_Mean))                            then
-        deallocate(y%modis_Ice_Water_Path_Mean)       
-        nullify(y%modis_Ice_Water_Path_Mean)       
-     endif
-     if (associated(y%modis_Optical_Thickness_vs_Cloud_Top_Pressure))        then
-        deallocate(y%modis_Optical_Thickness_vs_Cloud_Top_Pressure)     
-        nullify(y%modis_Optical_Thickness_vs_Cloud_Top_Pressure)     
-     endif
-     if (associated(y%modis_Optical_thickness_vs_ReffLIQ))                   then
-        deallocate(y%modis_Optical_thickness_vs_ReffLIQ)
-        nullify(y%modis_Optical_thickness_vs_ReffLIQ)
-     endif
-     if (associated(y%modis_Optical_thickness_vs_ReffICE))                   then
-        deallocate(y%modis_Optical_thickness_vs_ReffICE)
-        nullify(y%modis_Optical_thickness_vs_ReffICE)
-     endif
-        
-   end subroutine destroy_cosp_outputs
-
-END MODULE LMDZ_COSP_CONSTRUCT_DESTROY_MOD
-
Index: /LMDZ6/trunk/libf/phylmd/cospv2/lmdz_cosp_construct_destroy_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cospv2/lmdz_cosp_construct_destroy_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/cospv2/lmdz_cosp_construct_destroy_mod.f90	(revision 5268)
@@ -0,0 +1,675 @@
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+!
+! Module pour construir et detruire les variables "cospIN", "cospstateIN" et "cospOUT"
+!
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+MODULE LMDZ_COSP_CONSTRUCT_DESTROY_MOD
+
+use cosp_kinds, only: wp
+use mod_cosp,   only: cosp_optical_inputs,cosp_column_inputs,cosp_outputs
+use lmdz_cosp_read_outputkeys, only: cosp_config
+
+   USE mod_cosp_config, only : R_UNDEF, CLOUDSAT_DBZE_BINS, SR_BINS, PARASOL_NREFL, & 
+                              LIDAR_NTEMP, LIDAR_NCAT, LIDAR_NTYPE, & 
+                              numMODISReffIceBins,reffICE_binCenters, &
+                              numMODISReffLiqBins, reffLIQ_binCenters, &
+			      numISCCPTauBins,numISCCPPresBins, &
+			      numMISRTauBins,numMISRHgtBins, &
+			      numModisTauBins,numMODISPresBins
+
+  implicit none
+
+contains
+
+
+  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  ! SUBROUTINE construct_cospIN
+  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  subroutine construct_cospIN(cfg,npoints,ncolumns,nlevels,y)
+    ! Inputs
+    integer,intent(in) :: &
+         npoints,  & ! Number of horizontal gridpoints
+         ncolumns, & ! Number of subcolumns
+         nlevels     ! Number of vertical levels
+
+     type(cosp_config),intent(in) :: &
+          cfg         ! COSP output config (logical keys)
+
+    ! Outputs 
+    type(cosp_optical_inputs),intent(out) :: y
+    
+    ! Dimensions
+    y%Npoints  = Npoints
+    y%Ncolumns = Ncolumns
+    y%Nlevels  = Nlevels
+    y%Npart    = 4
+    y%Nrefl    = PARASOL_NREFL
+    allocate(y%frac_out(npoints,       ncolumns,nlevels))
+
+    if (cfg%Lmodis .or. cfg%Lmisr .or. cfg%Lisccp) then
+       allocate(y%tau_067(npoints,        ncolumns,nlevels),&
+                y%emiss_11(npoints,       ncolumns,nlevels))
+    endif
+    if (cfg%Lcalipso) then
+       allocate(y%betatot_calipso(npoints,        ncolumns,nlevels),&
+                y%betatot_ice_calipso(npoints,    ncolumns,nlevels),&
+                y%betatot_liq_calipso(npoints,    ncolumns,nlevels),&
+                y%tautot_calipso(npoints,         ncolumns,nlevels),&
+                y%tautot_ice_calipso(npoints,     ncolumns,nlevels),&
+                y%tautot_liq_calipso(npoints,     ncolumns,nlevels),&
+                y%beta_mol_calipso(npoints,                nlevels),&
+                y%tau_mol_calipso(npoints,                 nlevels),&
+                y%tautot_S_ice(npoints,   ncolumns        ),&
+                y%tautot_S_liq(npoints,   ncolumns        ))
+    endif
+
+    if (cfg%LgrLidar532) then
+       allocate(y%beta_mol_grLidar532(npoints,          nlevels),& 
+                y%betatot_grLidar532(npoints,  ncolumns,nlevels),& 
+                y%tau_mol_grLidar532(npoints,           nlevels),& 
+                y%tautot_grLidar532(npoints,   ncolumns,nlevels)) 
+    endif
+
+    if (cfg%Latlid) then
+       allocate(y%beta_mol_atlid(npoints,             nlevels),& 
+                y%betatot_atlid(npoints,     ncolumns,nlevels),& 
+                y%tau_mol_atlid(npoints,              nlevels),& 
+                y%tautot_atlid(npoints,      ncolumns,nlevels))
+    endif 
+
+    if (cfg%Lcloudsat) then
+       allocate(y%z_vol_cloudsat(npoints,  ncolumns,nlevels),&
+                y%kr_vol_cloudsat(npoints, ncolumns,nlevels),&
+                y%g_vol_cloudsat(npoints,  ncolumns,nlevels),&
+                y%fracPrecipIce(npoints,   ncolumns))
+    endif
+    if (cfg%Lmodis) then
+       allocate(y%fracLiq(npoints,        ncolumns,nlevels),&
+                y%asym(npoints,           ncolumns,nlevels),&
+                y%ss_alb(npoints,         ncolumns,nlevels))
+    endif
+    
+
+  end subroutine construct_cospIN  
+  
+  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  ! SUBROUTINE construct_cospstateIN
+  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%     
+  subroutine construct_cospstateIN(npoints,nlevels,nchan,y)
+    ! Inputs
+    integer,intent(in) :: &
+         npoints, & ! Number of horizontal gridpoints
+         nlevels, & ! Number of vertical levels
+         nchan      ! Number of channels
+    ! Outputs
+    type(cosp_column_inputs),intent(out) :: y         
+    
+    allocate(y%sunlit(npoints),y%skt(npoints),y%land(npoints),y%at(npoints,nlevels),     &
+             y%pfull(npoints,nlevels),y%phalf(npoints,nlevels+1),y%qv(npoints,nlevels),  &
+             y%o3(npoints,nlevels),y%hgt_matrix(npoints,nlevels),y%u_sfc(npoints),       &
+             y%v_sfc(npoints),y%lat(npoints),y%lon(nPoints),y%emis_sfc(nchan),           &
+             y%cloudIce(nPoints,nLevels),y%cloudLiq(nPoints,nLevels),y%surfelev(npoints),&
+             y%fl_snow(nPoints,nLevels),y%fl_rain(nPoints,nLevels),y%seaice(npoints),    &
+             y%tca(nPoints,nLevels),y%hgt_matrix_half(npoints,nlevels+1))
+
+  end subroutine construct_cospstateIN
+
+  ! ######################################################################################
+  ! SUBROUTINE construct_cosp_outputs
+  !
+  ! This subroutine allocates output fields based on input logical flag switches.
+  ! ######################################################################################  
+  subroutine construct_cosp_outputs(cfg,Npoints,Ncolumns,Nlevels,Nlvgrid,Nchan,x)
+     ! Inputs        
+     integer,intent(in) :: &
+          Npoints,         & ! Number of sampled points
+          Ncolumns,        & ! Number of subgrid columns
+          Nlevels,         & ! Number of model levels
+          Nlvgrid,         & ! Number of levels in L3 stats computation
+          Nchan              ! Number of RTTOV channels            
+     type(cosp_config),intent(in) :: &
+          cfg         ! COSP output config (logical keys)
+
+     ! Outputs
+     type(cosp_outputs),intent(out) :: &
+          x           ! COSP output structure  
+   
+     ! ISCCP simulator outputs
+    if (cfg%Lboxtauisccp)    allocate(x%isccp_boxtau(Npoints,Ncolumns)) 
+    if (cfg%Lboxptopisccp)   allocate(x%isccp_boxptop(Npoints,Ncolumns))
+    if (cfg%Lclisccp)        allocate(x%isccp_fq(Npoints,numISCCPTauBins,numISCCPPresBins))
+    if (cfg%Lcltisccp)       allocate(x%isccp_totalcldarea(Npoints))
+    if (cfg%Lpctisccp)       allocate(x%isccp_meanptop(Npoints))
+    if (cfg%Ltauisccp)       allocate(x%isccp_meantaucld(Npoints))
+    if (cfg%Lmeantbisccp)    allocate(x%isccp_meantb(Npoints))
+    if (cfg%Lmeantbclrisccp) allocate(x%isccp_meantbclr(Npoints))
+    if (cfg%Lalbisccp)       allocate(x%isccp_meanalbedocld(Npoints))
+    
+    ! MISR simulator
+    if (cfg%LclMISR) then 
+       allocate(x%misr_fq(Npoints,numMISRTauBins,numMISRHgtBins))
+       ! *NOTE* These 3 fields are not output, but were part of the v1.4.0 cosp_misr, so
+       !        they are still computed. Should probably have a logical to control these
+       !        outputs.
+       allocate(x%misr_dist_model_layertops(Npoints,numMISRHgtBins))
+       allocate(x%misr_meanztop(Npoints))
+       allocate(x%misr_cldarea(Npoints))    
+    endif
+    
+    ! MODIS simulator
+    if (cfg%Lcltmodis)     allocate(x%modis_Cloud_Fraction_Total_Mean(Npoints))
+    if (cfg%Lclwmodis)     allocate(x%modis_Cloud_Fraction_Water_Mean(Npoints))
+    if (cfg%Lclimodis)     allocate(x%modis_Cloud_Fraction_Ice_Mean(Npoints))
+    if (cfg%Lclhmodis)     allocate(x%modis_Cloud_Fraction_High_Mean(Npoints))
+    if (cfg%Lclmmodis)     allocate(x%modis_Cloud_Fraction_Mid_Mean(Npoints))
+    if (cfg%Lcllmodis)     allocate(x%modis_Cloud_Fraction_Low_Mean(Npoints))
+    if (cfg%Ltautmodis)    allocate(x%modis_Optical_Thickness_Total_Mean(Npoints))
+    if (cfg%Ltauwmodis)    allocate(x%modis_Optical_Thickness_Water_Mean(Npoints))
+    if (cfg%Ltauimodis)    allocate(x%modis_Optical_Thickness_Ice_Mean(Npoints))
+    if (cfg%Ltautlogmodis) allocate(x%modis_Optical_Thickness_Total_LogMean(Npoints))
+    if (cfg%Ltauwlogmodis) allocate(x%modis_Optical_Thickness_Water_LogMean(Npoints))
+    if (cfg%Ltauilogmodis) allocate(x%modis_Optical_Thickness_Ice_LogMean(Npoints))
+    if (cfg%Lreffclwmodis) allocate(x%modis_Cloud_Particle_Size_Water_Mean(Npoints))
+    if (cfg%Lreffclimodis) allocate(x%modis_Cloud_Particle_Size_Ice_Mean(Npoints))
+    if (cfg%Lpctmodis)     allocate(x%modis_Cloud_Top_Pressure_Total_Mean(Npoints))
+    if (cfg%Llwpmodis)     allocate(x%modis_Liquid_Water_Path_Mean(Npoints))
+    if (cfg%Liwpmodis)     allocate(x%modis_Ice_Water_Path_Mean(Npoints))
+    if (cfg%Lclmodis) then
+        allocate(x%modis_Optical_Thickness_vs_Cloud_Top_Pressure(nPoints,numModisTauBins,numMODISPresBins))
+        allocate(x%modis_Optical_thickness_vs_ReffLIQ(nPoints,numMODISTauBins,numMODISReffLiqBins))   
+        allocate(x%modis_Optical_Thickness_vs_ReffICE(nPoints,numMODISTauBins,numMODISReffIceBins))
+    endif
+    
+    ! LIDAR simulator
+    if (cfg%LlidarBetaMol532) allocate(x%calipso_beta_mol(Npoints,Nlevels))
+    if (cfg%Latb532)          allocate(x%calipso_beta_tot(Npoints,Ncolumns,Nlevels))
+    if (cfg%LcfadLidarsr532)  then
+        allocate(x%calipso_srbval(SR_BINS+1))
+        allocate(x%calipso_cfad_sr(Npoints,SR_BINS,Nlvgrid))
+        allocate(x%calipso_betaperp_tot(Npoints,Ncolumns,Nlevels))  
+    endif
+    if (cfg%Lclcalipso)       allocate(x%calipso_lidarcld(Npoints,Nlvgrid))
+    if (cfg%Lclhcalipso .or. cfg%Lclmcalipso .or. cfg%Lcllcalipso .or. cfg%Lcltcalipso) then
+        allocate(x%calipso_cldlayer(Npoints,LIDAR_NCAT))
+    endif   
+    if (cfg%Lclcalipsoice .or. cfg%Lclcalipsoliq .or. cfg%Lclcalipsoun) then
+        allocate(x%calipso_lidarcldphase(Npoints,Nlvgrid,6))
+    endif
+    if (cfg%Lclcalipsotmp .or. cfg%Lclcalipsotmpliq .or. cfg%Lclcalipsoice .or. &
+                          cfg%Lclcalipsotmpun .or. cfg%Lclcalipsotmpice) then
+        allocate(x%calipso_lidarcldtmp(Npoints,LIDAR_NTEMP,5))
+    endif
+    if (cfg%Lcllcalipsoice .or. cfg%Lclmcalipsoice .or. cfg%Lclhcalipsoice .or.             &
+        cfg%Lcltcalipsoice .or. cfg%Lcllcalipsoliq .or. cfg%Lclmcalipsoliq .or.             &
+        cfg%Lclhcalipsoliq .or. cfg%Lcltcalipsoliq .or. cfg%Lcllcalipsoun  .or.             &
+        cfg%Lclmcalipsoun  .or. cfg%Lclhcalipsoun  .or. cfg%Lcltcalipsoun) then
+        allocate(x%calipso_cldlayerphase(Npoints,LIDAR_NCAT,6))     
+    endif
+    if (cfg%Lclopaquecalipso .or. cfg%Lclthincalipso .or. cfg%Lclzopaquecalipso) then
+        allocate(x%calipso_cldtype(Npoints,LIDAR_NTYPE))
+    endif 
+    if (cfg%Lclopaquetemp .or. cfg%Lclthintemp .or. cfg%Lclzopaquetemp) then 
+        allocate(x%calipso_cldtypetemp(Npoints,LIDAR_NTYPE))  
+    endif
+    if (cfg%Lclopaquemeanz .or. cfg%Lclthinmeanz) then 
+        allocate(x%calipso_cldtypemeanz(Npoints,2))
+    endif 
+    if (cfg%Lclopaquemeanzse .or. cfg%Lclthinmeanzse .or. cfg%Lclzopaquecalipsose) then 
+        allocate(x%calipso_cldtypemeanzse(Npoints,3)) 
+    endif 
+    if (cfg%Lclthinemis) then 
+        allocate(x%calipso_cldthinemis(Npoints))
+    endif
+    if (cfg%Lclcalipsoopaque .or. cfg%Lclcalipsothin .or. cfg%Lclcalipsozopaque .or. &
+             cfg%Lclcalipsoopacity) then 
+        allocate(x%calipso_lidarcldtype(Npoints,Nlvgrid,LIDAR_NTYPE+1))
+    endif
+    ! These 2 outputs are part of the calipso output type, but are not controlled by an 
+    ! logical switch in the output namelist, so if all other fields are on, then allocate
+    if (cfg%LlidarBetaMol532 .or. cfg%Latb532        .or. cfg%LcfadLidarsr532 .or. cfg%Lclcalipso  .or.  &
+        cfg%Lclcalipsoice    .or. cfg%Lclcalipsoliq  .or. cfg%Lclcalipsoun    .or. cfg%Lclcalipso2 .or.  &
+        cfg%Lclhcalipso      .or. cfg%Lclmcalipso    .or. cfg%Lcllcalipso     .or. cfg%Lcltcalipso .or.  &
+        cfg%Lclcalipsotmp    .or. cfg%Lclcalipsoice  .or. cfg%Lclcalipsotmpun .or.                       &
+        cfg%Lclcalipsotmpliq .or. cfg%Lcllcalipsoice .or. cfg%Lclmcalipsoice  .or.                       &
+        cfg%Lclhcalipsoice   .or. cfg%Lcltcalipsoice .or. cfg%Lcllcalipsoliq  .or.                       &
+        cfg%Lclmcalipsoliq   .or. cfg%Lclhcalipsoliq .or. cfg%Lcltcalipsoliq  .or.                       &
+        cfg%Lcllcalipsoun    .or. cfg%Lclmcalipsoun  .or. cfg%Lclhcalipsoun   .or. cfg%Lcltcalipsoun) then
+       allocate(x%calipso_tau_tot(Npoints,Ncolumns,Nlevels))       
+       allocate(x%calipso_temp_tot(Npoints,Nlevels))               
+    endif
+
+    ! GROUND LIDAR @ 532NM simulator
+    if (cfg%LlidarBetaMol532gr) allocate(x%grLidar532_beta_mol(Npoints,Nlevels))
+    if (cfg%Latb532gr)          allocate(x%grLidar532_beta_tot(Npoints,Ncolumns,Nlevels))
+    if (cfg%LcfadLidarsr532gr) then 
+        allocate(x%grLidar532_srbval(SR_BINS+1)) 
+        allocate(x%grLidar532_cfad_sr(Npoints,SR_BINS,Nlvgrid))
+    endif
+    if (cfg%LclgrLidar532)     allocate(x%grLidar532_lidarcld(Npoints,Nlvgrid)) 
+    if (cfg%LclhgrLidar532 .or. cfg%LclmgrLidar532 .or. cfg%LcllgrLidar532 .or. cfg%LcltgrLidar532) then
+        allocate(x%grLidar532_cldlayer(Npoints,LIDAR_NCAT))  
+    endif
+      
+    ! ATLID simulator
+    if (cfg%LlidarBetaMol355) allocate(x%atlid_beta_mol(Npoints,Nlevels))
+    if (cfg%Latb355)          allocate(x%atlid_beta_tot(Npoints,Ncolumns,Nlevels))
+    if (cfg%LcfadLidarsr355) then
+        allocate(x%atlid_srbval(SR_BINS+1)) 
+        allocate(x%atlid_cfad_sr(Npoints,SR_BINS,Nlvgrid))
+    endif 
+    if (cfg%Lclatlid)     allocate(x%atlid_lidarcld(Npoints,Nlvgrid)) 
+    if (cfg%Lclhatlid .or. cfg%Lclmatlid .or. cfg%Lcllatlid .or. cfg%Lcltatlid) then
+        allocate(x%atlid_cldlayer(Npoints,LIDAR_NCAT)) 
+    endif
+      
+    ! PARASOL
+    if (cfg%Lparasolrefl) then
+        allocate(x%parasolPix_refl(Npoints,Ncolumns,PARASOL_NREFL))
+        allocate(x%parasolGrid_refl(Npoints,PARASOL_NREFL))
+    endif 
+
+    ! Cloudsat simulator
+    if (cfg%Ldbze94)        allocate(x%cloudsat_Ze_tot(Npoints,Ncolumns,Nlevels))
+    if (cfg%LcfadDbze94)    allocate(x%cloudsat_cfad_ze(Npoints,cloudsat_DBZE_BINS,Nlvgrid))
+    if (cfg%Lptradarflag0 .or. cfg%Lptradarflag1 .or. cfg%Lptradarflag2 .or. cfg%Lptradarflag3 .or. &
+        cfg%Lptradarflag4 .or. cfg%Lptradarflag5 .or. cfg%Lptradarflag6 .or. cfg%Lptradarflag7 .or. &
+        cfg%Lptradarflag8 .or. cfg%Lptradarflag9) then
+       allocate(x%cloudsat_precip_cover(Npoints,cloudsat_DBZE_BINS))
+    endif
+    if (cfg%Lradarpia) allocate(x%cloudsat_pia(Npoints))
+
+    ! Combined CALIPSO/CLOUDSAT fields
+    if (cfg%Lclcalipso2)    allocate(x%lidar_only_freq_cloud(Npoints,Nlvgrid))
+    if (cfg%Lcltlidarradar) allocate(x%radar_lidar_tcc(Npoints))
+    if (cfg%Lcloudsat_tcc)  allocate(x%cloudsat_tcc(Npoints))
+    if (cfg%Lcloudsat_tcc2) allocate(x%cloudsat_tcc2(Npoints))
+            
+    ! RTTOV
+    if (cfg%Ltbrttov) allocate(x%rttov_tbs(Npoints,Nchan))
+ 
+  end subroutine construct_cosp_outputs
+
+  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  ! SUBROUTINE destroy_cospIN     
+  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  subroutine destroy_cospIN(y)
+    type(cosp_optical_inputs),intent(inout) :: y
+
+    if (allocated(y%tau_067))       	  deallocate(y%tau_067)
+    if (allocated(y%emiss_11))      	  deallocate(y%emiss_11)
+    if (allocated(y%frac_out))    	  deallocate(y%frac_out)
+    if (allocated(y%beta_mol_calipso))    deallocate(y%beta_mol_calipso)
+    if (allocated(y%tau_mol_calipso))     deallocate(y%tau_mol_calipso)
+    if (allocated(y%betatot_calipso))     deallocate(y%betatot_calipso)
+    if (allocated(y%betatot_ice_calipso)) deallocate(y%betatot_ice_calipso)
+    if (allocated(y%betatot_liq_calipso)) deallocate(y%betatot_liq_calipso)
+    if (allocated(y%tautot_calipso))      deallocate(y%tautot_calipso)
+    if (allocated(y%tautot_ice_calipso))  deallocate(y%tautot_ice_calipso)
+    if (allocated(y%tautot_liq_calipso))  deallocate(y%tautot_liq_calipso)
+    if (allocated(y%tautot_S_liq))	  deallocate(y%tautot_S_liq)
+    if (allocated(y%tautot_S_ice))    	  deallocate(y%tautot_S_ice)
+    if (allocated(y%z_vol_cloudsat))  	  deallocate(y%z_vol_cloudsat)
+    if (allocated(y%kr_vol_cloudsat)) 	  deallocate(y%kr_vol_cloudsat)
+    if (allocated(y%g_vol_cloudsat)) 	  deallocate(y%g_vol_cloudsat)
+    if (allocated(y%asym))            	  deallocate(y%asym)
+    if (allocated(y%ss_alb))         	  deallocate(y%ss_alb)
+    if (allocated(y%fracLiq))       	  deallocate(y%fracLiq)
+    if (allocated(y%beta_mol_grLidar532)) deallocate(y%beta_mol_grLidar532)
+    if (allocated(y%betatot_grLidar532))  deallocate(y%betatot_grLidar532)
+    if (allocated(y%tau_mol_grLidar532))  deallocate(y%tau_mol_grLidar532)
+    if (allocated(y%tautot_grLidar532))   deallocate(y%tautot_grLidar532)
+    if (allocated(y%beta_mol_atlid))      deallocate(y%beta_mol_atlid) 
+    if (allocated(y%betatot_atlid))       deallocate(y%betatot_atlid) 
+    if (allocated(y%tau_mol_atlid))       deallocate(y%tau_mol_atlid) 
+    if (allocated(y%tautot_atlid))        deallocate(y%tautot_atlid)
+    if (allocated(y%fracPrecipIce))       deallocate(y%fracPrecipIce)
+
+  end subroutine destroy_cospIN
+  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  ! SUBROUTINE destroy_cospstateIN     
+  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%  
+  subroutine destroy_cospstateIN(y)
+    type(cosp_column_inputs),intent(inout) :: y
+
+    if (allocated(y%sunlit))          deallocate(y%sunlit)
+    if (allocated(y%skt))             deallocate(y%skt)
+    if (allocated(y%land))            deallocate(y%land)
+    if (allocated(y%at))              deallocate(y%at)
+    if (allocated(y%pfull))           deallocate(y%pfull)
+    if (allocated(y%phalf))           deallocate(y%phalf)
+    if (allocated(y%qv))              deallocate(y%qv)
+    if (allocated(y%o3))              deallocate(y%o3)
+    if (allocated(y%hgt_matrix))      deallocate(y%hgt_matrix)
+    if (allocated(y%u_sfc))           deallocate(y%u_sfc)
+    if (allocated(y%v_sfc))           deallocate(y%v_sfc)
+    if (allocated(y%lat))             deallocate(y%lat)
+    if (allocated(y%lon))             deallocate(y%lon)
+    if (allocated(y%emis_sfc))        deallocate(y%emis_sfc)
+    if (allocated(y%cloudIce))        deallocate(y%cloudIce)
+    if (allocated(y%cloudLiq))        deallocate(y%cloudLiq)
+    if (allocated(y%seaice))          deallocate(y%seaice)
+    if (allocated(y%fl_rain))         deallocate(y%fl_rain)
+    if (allocated(y%fl_snow))         deallocate(y%fl_snow)
+    if (allocated(y%tca))             deallocate(y%tca)
+    if (allocated(y%hgt_matrix_half)) deallocate(y%hgt_matrix_half)    
+    if (allocated(y%surfelev))        deallocate(y%surfelev)
+    
+  end subroutine destroy_cospstateIN
+  
+  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  ! SUBROUTINE destroy_cosp_outputs
+  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%  
+  subroutine destroy_cosp_outputs(y)
+     type(cosp_outputs),intent(inout) :: y
+
+     ! Deallocate and nullify
+     if (associated(y%calipso_beta_mol))          then
+        deallocate(y%calipso_beta_mol)
+        nullify(y%calipso_beta_mol)
+     endif
+     if (associated(y%calipso_temp_tot))          then
+        deallocate(y%calipso_temp_tot)
+        nullify(y%calipso_temp_tot)     
+     endif
+     if (associated(y%calipso_betaperp_tot))      then
+        deallocate(y%calipso_betaperp_tot)
+        nullify(y%calipso_betaperp_tot)     
+     endif
+     if (associated(y%calipso_beta_tot))          then
+        deallocate(y%calipso_beta_tot)    
+        nullify(y%calipso_beta_tot)     
+     endif
+     if (associated(y%calipso_tau_tot))           then
+        deallocate(y%calipso_tau_tot) 
+        nullify(y%calipso_tau_tot)     
+     endif
+     if (associated(y%calipso_lidarcldphase))     then
+        deallocate(y%calipso_lidarcldphase)
+        nullify(y%calipso_lidarcldphase)     
+     endif
+     if (associated(y%calipso_lidarcldtype))     then
+        deallocate(y%calipso_lidarcldtype) 
+        nullify(y%calipso_lidarcldtype) 
+     endif
+     if (associated(y%calipso_cldlayerphase))     then
+        deallocate(y%calipso_cldlayerphase)
+        nullify(y%calipso_cldlayerphase)     
+     endif
+     if (associated(y%calipso_lidarcldtmp))       then
+        deallocate(y%calipso_lidarcldtmp)
+        nullify(y%calipso_lidarcldtmp)     
+     endif
+     if (associated(y%calipso_cldlayer))          then
+        deallocate(y%calipso_cldlayer)
+        nullify(y%calipso_cldlayer)     
+     endif
+     if (associated(y%calipso_cldtype))          then
+        deallocate(y%calipso_cldtype)
+        nullify(y%calipso_cldtype)  
+     endif  
+     if (associated(y%calipso_cldtypetemp))      then
+        deallocate(y%calipso_cldtypetemp) 
+        nullify(y%calipso_cldtypetemp) 
+     endif 
+     if (associated(y%calipso_cldtypemeanz))     then
+        deallocate(y%calipso_cldtypemeanz)
+        nullify(y%calipso_cldtypemeanz)  
+     endif  
+     if (associated(y%calipso_cldtypemeanzse))   then 
+        deallocate(y%calipso_cldtypemeanzse) 
+        nullify(y%calipso_cldtypemeanzse)  
+     endif 
+     if (associated(y%calipso_cldthinemis))      then
+        deallocate(y%calipso_cldthinemis)
+        nullify(y%calipso_cldthinemis)
+     endif 
+     if (associated(y%calipso_lidarcld))         then
+        deallocate(y%calipso_lidarcld)
+        nullify(y%calipso_lidarcld)     
+     endif
+     if (associated(y%calipso_srbval))            then
+        deallocate(y%calipso_srbval)
+        nullify(y%calipso_srbval)     
+     endif
+     if (associated(y%calipso_cfad_sr))          then
+        deallocate(y%calipso_cfad_sr)
+        nullify(y%calipso_cfad_sr)     
+     endif
+     if (associated(y%grLidar532_beta_mol))     then
+        deallocate(y%grLidar532_beta_mol)
+        nullify(y%grLidar532_beta_mol)  
+     endif
+     if (associated(y%grLidar532_beta_tot))     then 
+        deallocate(y%grLidar532_beta_tot) 
+        nullify(y%grLidar532_beta_tot)
+     endif 
+     if (associated(y%grLidar532_cldlayer))     then 
+        deallocate(y%grLidar532_cldlayer) 
+        nullify(y%grLidar532_cldlayer) 
+     endif 
+     if (associated(y%grLidar532_lidarcld))     then 
+        deallocate(y%grLidar532_lidarcld) 
+        nullify(y%grLidar532_lidarcld) 
+     endif 
+     if (associated(y%grLidar532_cfad_sr))      then 
+        deallocate(y%grLidar532_cfad_sr)  
+        nullify(y%grLidar532_cfad_sr) 
+     endif 
+     if (associated(y%grLidar532_srbval))       then
+        deallocate(y%grLidar532_srbval) 
+        nullify(y%grLidar532_srbval) 
+     endif  
+     if (associated(y%atlid_beta_mol))           then
+        deallocate(y%atlid_beta_mol) 
+        nullify(y%atlid_beta_mol) 
+     endif 
+     if (associated(y%atlid_beta_tot))           then
+        deallocate(y%atlid_beta_tot) 
+        nullify(y%atlid_beta_tot) 
+     endif
+     if (associated(y%atlid_cldlayer))           then 
+        deallocate(y%atlid_cldlayer)  
+        nullify(y%atlid_cldlayer) 
+     endif 
+     if (associated(y%atlid_lidarcld))           then 
+        deallocate(y%atlid_lidarcld)  
+        nullify(y%atlid_lidarcld) 
+     endif  
+     if (associated(y%atlid_cfad_sr))            then
+        deallocate(y%atlid_cfad_sr) 
+        nullify(y%atlid_cfad_sr) 
+     endif
+     if (associated(y%atlid_srbval))             then 
+        deallocate(y%atlid_srbval) 
+        nullify(y%atlid_srbval) 
+     endif
+     if (associated(y%parasolPix_refl))           then
+        deallocate(y%parasolPix_refl)
+        nullify(y%parasolPix_refl)     
+     endif
+     if (associated(y%parasolGrid_refl))          then
+        deallocate(y%parasolGrid_refl) 
+        nullify(y%parasolGrid_refl)     
+     endif
+     if (associated(y%cloudsat_Ze_tot))           then
+        deallocate(y%cloudsat_Ze_tot) 
+        nullify(y%cloudsat_Ze_tot)  
+     endif
+     if (associated(y%cloudsat_cfad_ze))          then
+        deallocate(y%cloudsat_cfad_ze)
+        nullify(y%cloudsat_cfad_ze)     
+     endif
+     if (associated(y%cloudsat_precip_cover))     then
+        deallocate(y%cloudsat_precip_cover)
+        nullify(y%cloudsat_precip_cover)
+     endif
+     if (associated(y%cloudsat_pia))              then
+        deallocate(y%cloudsat_pia)
+        nullify(y%cloudsat_pia)
+     endif
+     if (associated(y%cloudsat_tcc))           then
+        deallocate(y%cloudsat_tcc) 
+        nullify(y%cloudsat_tcc)  
+     endif
+     if (associated(y%cloudsat_tcc2))           then
+        deallocate(y%cloudsat_tcc2) 
+        nullify(y%cloudsat_tcc2)  
+     endif
+     if (associated(y%radar_lidar_tcc))           then
+        deallocate(y%radar_lidar_tcc) 
+        nullify(y%radar_lidar_tcc)  
+     endif
+     if (associated(y%cloudsat_tcc))           then
+        deallocate(y%cloudsat_tcc) 
+        nullify(y%cloudsat_tcc)  
+     endif
+     if (associated(y%cloudsat_tcc2))           then
+        deallocate(y%cloudsat_tcc2) 
+        nullify(y%cloudsat_tcc2)  
+     endif
+     if (associated(y%lidar_only_freq_cloud))     then
+        deallocate(y%lidar_only_freq_cloud)
+        nullify(y%lidar_only_freq_cloud)     
+     endif
+     if (associated(y%isccp_totalcldarea))        then
+        deallocate(y%isccp_totalcldarea) 
+        nullify(y%isccp_totalcldarea)  
+     endif
+     if (associated(y%isccp_meantb))              then
+        deallocate(y%isccp_meantb) 
+        nullify(y%isccp_meantb)     
+     endif
+     if (associated(y%isccp_meantbclr))           then
+        deallocate(y%isccp_meantbclr)
+        nullify(y%isccp_meantbclr)  
+     endif
+     if (associated(y%isccp_meanptop))            then
+        deallocate(y%isccp_meanptop)
+        nullify(y%isccp_meanptop)     
+     endif
+     if (associated(y%isccp_meantaucld))          then
+        deallocate(y%isccp_meantaucld) 
+        nullify(y%isccp_meantaucld)       
+     endif
+     if (associated(y%isccp_meanalbedocld))       then
+        deallocate(y%isccp_meanalbedocld)
+        nullify(y%isccp_meanalbedocld)     
+     endif
+     if (associated(y%isccp_boxtau))              then
+        deallocate(y%isccp_boxtau)
+        nullify(y%isccp_boxtau)       
+     endif
+     if (associated(y%isccp_boxptop))             then
+        deallocate(y%isccp_boxptop)
+        nullify(y%isccp_boxptop)     
+     endif
+     if (associated(y%isccp_fq))                  then
+        deallocate(y%isccp_fq)
+        nullify(y%isccp_fq)       
+     endif
+     if (associated(y%misr_fq))                   then
+        deallocate(y%misr_fq) 
+        nullify(y%misr_fq)     
+     endif
+     if (associated(y%misr_dist_model_layertops)) then
+        deallocate(y%misr_dist_model_layertops)
+        nullify(y%misr_dist_model_layertops)       
+     endif
+     if (associated(y%misr_meanztop))             then
+        deallocate(y%misr_meanztop)
+        nullify(y%misr_meanztop)     
+     endif
+     if (associated(y%misr_cldarea))              then
+        deallocate(y%misr_cldarea)
+        nullify(y%misr_cldarea)      
+     endif
+     if (associated(y%rttov_tbs))                 then
+        deallocate(y%rttov_tbs)
+        nullify(y%rttov_tbs)     
+     endif
+     if (associated(y%modis_Cloud_Fraction_Total_Mean))                      then
+        deallocate(y%modis_Cloud_Fraction_Total_Mean)       
+        nullify(y%modis_Cloud_Fraction_Total_Mean)       
+     endif
+     if (associated(y%modis_Cloud_Fraction_Ice_Mean))                        then
+        deallocate(y%modis_Cloud_Fraction_Ice_Mean)     
+        nullify(y%modis_Cloud_Fraction_Ice_Mean)     
+     endif
+     if (associated(y%modis_Cloud_Fraction_Water_Mean))                      then
+        deallocate(y%modis_Cloud_Fraction_Water_Mean)           
+        nullify(y%modis_Cloud_Fraction_Water_Mean)           
+     endif
+     if (associated(y%modis_Cloud_Fraction_High_Mean))                       then
+        deallocate(y%modis_Cloud_Fraction_High_Mean)     
+        nullify(y%modis_Cloud_Fraction_High_Mean)     
+     endif
+     if (associated(y%modis_Cloud_Fraction_Mid_Mean))                        then
+        deallocate(y%modis_Cloud_Fraction_Mid_Mean)       
+        nullify(y%modis_Cloud_Fraction_Mid_Mean)       
+     endif
+     if (associated(y%modis_Cloud_Fraction_Low_Mean))                        then
+        deallocate(y%modis_Cloud_Fraction_Low_Mean)     
+        nullify(y%modis_Cloud_Fraction_Low_Mean)     
+     endif
+     if (associated(y%modis_Optical_Thickness_Total_Mean))                   then
+        deallocate(y%modis_Optical_Thickness_Total_Mean)  
+        nullify(y%modis_Optical_Thickness_Total_Mean)  
+     endif
+     if (associated(y%modis_Optical_Thickness_Water_Mean))                   then
+        deallocate(y%modis_Optical_Thickness_Water_Mean)     
+        nullify(y%modis_Optical_Thickness_Water_Mean)     
+     endif
+     if (associated(y%modis_Optical_Thickness_Ice_Mean))                     then
+        deallocate(y%modis_Optical_Thickness_Ice_Mean)       
+        nullify(y%modis_Optical_Thickness_Ice_Mean)       
+     endif
+     if (associated(y%modis_Optical_Thickness_Total_LogMean))                then
+        deallocate(y%modis_Optical_Thickness_Total_LogMean)    
+        nullify(y%modis_Optical_Thickness_Total_LogMean)    
+     endif
+     if (associated(y%modis_Optical_Thickness_Water_LogMean))                then
+        deallocate(y%modis_Optical_Thickness_Water_LogMean)     
+        nullify(y%modis_Optical_Thickness_Water_LogMean)     
+     endif
+     if (associated(y%modis_Optical_Thickness_Ice_LogMean))                  then
+        deallocate(y%modis_Optical_Thickness_Ice_LogMean)     
+        nullify(y%modis_Optical_Thickness_Ice_LogMean)     
+     endif
+     if (associated(y%modis_Cloud_Particle_Size_Water_Mean))                 then
+        deallocate(y%modis_Cloud_Particle_Size_Water_Mean)       
+        nullify(y%modis_Cloud_Particle_Size_Water_Mean)       
+     endif
+     if (associated(y%modis_Cloud_Particle_Size_Ice_Mean))                   then
+        deallocate(y%modis_Cloud_Particle_Size_Ice_Mean)     
+        nullify(y%modis_Cloud_Particle_Size_Ice_Mean)     
+     endif
+     if (associated(y%modis_Cloud_Top_Pressure_Total_Mean))                  then
+        deallocate(y%modis_Cloud_Top_Pressure_Total_Mean)           
+        nullify(y%modis_Cloud_Top_Pressure_Total_Mean)           
+     endif
+     if (associated(y%modis_Liquid_Water_Path_Mean))                         then
+        deallocate(y%modis_Liquid_Water_Path_Mean)     
+        nullify(y%modis_Liquid_Water_Path_Mean)     
+     endif
+     if (associated(y%modis_Ice_Water_Path_Mean))                            then
+        deallocate(y%modis_Ice_Water_Path_Mean)       
+        nullify(y%modis_Ice_Water_Path_Mean)       
+     endif
+     if (associated(y%modis_Optical_Thickness_vs_Cloud_Top_Pressure))        then
+        deallocate(y%modis_Optical_Thickness_vs_Cloud_Top_Pressure)     
+        nullify(y%modis_Optical_Thickness_vs_Cloud_Top_Pressure)     
+     endif
+     if (associated(y%modis_Optical_thickness_vs_ReffLIQ))                   then
+        deallocate(y%modis_Optical_thickness_vs_ReffLIQ)
+        nullify(y%modis_Optical_thickness_vs_ReffLIQ)
+     endif
+     if (associated(y%modis_Optical_thickness_vs_ReffICE))                   then
+        deallocate(y%modis_Optical_thickness_vs_ReffICE)
+        nullify(y%modis_Optical_thickness_vs_ReffICE)
+     endif
+        
+   end subroutine destroy_cosp_outputs
+
+END MODULE LMDZ_COSP_CONSTRUCT_DESTROY_MOD
+
Index: DZ6/trunk/libf/phylmd/cospv2/lmdz_cosp_interface.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cospv2/lmdz_cosp_interface.F90	(revision 5267)
+++ 	(revision )
@@ -1,571 +1,0 @@
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-!
-! Nouveau code d'interface entre LMDZ et COSPv2 (version 2)
-! L'ancienne interface s'appelait "phys_cosp2" et avait ete concue pour COSPv1.4.
-! Dans cette nouvelle version de COSP, le code a ete restructure pour optimiser les calculs
-! des differents simulateurs et pour proposer de nouvelles fonctionnalites (par exemple,
-! intervenir sur les profils sous-maille, ou subcolumns, donnes en entre a COSP afin que
-! leur definition soit coherente avec les parametrisations du modele hote).
-! Cette version de COSP propose aussi de nombreux nouveaux diagnostics, notamment pour
-! le simulateur lidar (diagnostics CALIPSO-OPAQ, lidar sol 532nm et lidar ATLID 355nm).
-!
-! Interface reecrite par R.Guzman (01/2019), a partir de l'interface initiale concue
-! et ecrite par A.Idelkadi 
-!
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-!  subroutine phys_cosp2( itap,dtime,freq_cosp, &
-  subroutine lmdz_cosp_interface(itap, dtime, freq_cosp, ok_mensuelCOSP, ok_journeCOSP,   &
-                         ok_hfCOSP, ecrit_mth, ecrit_day, ecrit_hf, ok_all_xml,   &
-                         missing_val, Nptslmdz, Nlevlmdz, lon, lat, presnivs,     &
-                         overlaplmdz, sunlit, ref_liq, ref_ice, fracTerLic,       &
-                         u_wind, v_wind, phis, phi, ph, p, skt, t, sh, rh,        &
-                         tca, cca, mr_lsliq, mr_lsice, fl_lsrainI, fl_lssnowI,    &
-                         fl_ccrainI, fl_ccsnowI, mr_ozone, dtau_s, dem_s)
-
-!--------------  Inputs  ---------------
-! itap,                                 !Increment de la physiq
-! dtime,                                !Pas de temps physiq
-! overlaplmdz,                          !Type Overlap venant de LMDZ
-! Npoints,                              !Nb de points de la grille physiq
-! Nlevels,                              !Nb de niveaux verticaux
-! Ncolumns,                             !Number of subcolumns
-! lon,lat,                              !Longitudes et latitudes de la grille LMDZ
-! ref_liq, ref_ice,                     !Rayons effectifs des particules liq et ice (en micron)
-! fracTerLic,                           !Fraction terre a convertir en masque
-! u_wind, v_wind,                       !Vents a 10m ???
-! phi,                                  !Geopotentiel
-! phis,                                 !Geopotentiel sol
-! ph,                                   !pression pour chaque inter-couche
-! p,                                    !Pression aux milieux des couches
-! skt, t,                               !Temp au sol et temp 3D
-! sh,                                   !Humidite specifique
-! rh,                                   !Humidite relative
-! tca,                                  !Fraction nuageuse
-! cca                                   !Fraction nuageuse convective
-! mr_lsliq,                             !Liq Cloud water content
-! mr_lsice,                             !Ice Cloud water content
-! mr_ccliq,                             !Convective Cloud Liquid water content  
-! mr_ccice,                             !Cloud ice water content
-! fl_lsrain,                            !Large scale precipitation lic
-! fl_lssnow,                            !Large scale precipitation ice
-! fl_ccrain,                            !Convective precipitation lic
-! fl_ccsnow,                            !Convective precipitation ice
-! mr_ozone,                             !Concentration ozone (Kg/Kg)
-! dem_s                                 !Cloud optical emissivity
-! dtau_s               			!Cloud optical thickness
-! emsfc_lw = 1.        			!Surface emissivity dans radlwsw.F90
-
-
-!--------------  Outputs  --------------
-! La liste complete des diagnostics de sortie (observables simulees) que l'on peut
-! avoir avec COSPv2 se trouve au debut du fichier : cosp_read_otputkeys.F90
-
-
-!!! Modules specifiques a l'interface LMDZ-COSP
-  use mod_phys_lmdz_para
-  use mod_grid_phy_lmdz
-  use ioipsl
-  use iophy
-  use lmdz_xios, ONLY : using_xios
-  use lmdz_cosp_output_mod
-  use lmdz_cosp_output_write_mod
-  use lmdz_cosp_read_outputkeys
-  use lmdz_cosp_subsample_and_optics_mod, only : subsample_and_optics
-  use lmdz_cosp_construct_destroy_mod
-
-!!! Modules faisant partie du code source de COSPv2
-  use cosp_kinds,  only: wp                         
-  use MOD_COSP_CONFIG,       only: N_HYDRO,RTTOV_MAX_CHANNELS, &
-                                    niv_sorties, vgrid_z_in
-  use mod_quickbeam_optics,  only: size_distribution,hydro_class_init, &
-                                   quickbeam_optics_init
-  use quickbeam,            only: radar_cfg
-  use mod_cosp,             only: cosp_init,cosp_optical_inputs, &
-                                  cosp_column_inputs,cosp_outputs, &
-                                  cosp_simulator
-
-
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-!
-! Declaration des variables 
-!
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-
-  IMPLICIT NONE
-
-  ! Local variables
-  character(len=64),PARAMETER	:: cosp_input_nl  = 'cospv2_input_nl.txt'
-  character(len=64),PARAMETER  	:: cosp_output_nl = 'cospv2_output_nl.txt'
-
-  integer, save 	       	:: isccp_topheight, isccp_topheight_direction, overlap
-  integer, save  	       	:: Ncolumns    	    	! Number of subcolumns in SCOPS
-  integer, save 	       	:: Npoints            	! Number of gridpoints
-!$OMP THREADPRIVATE(Npoints)
-  integer, save			:: Nlevels		! Number of model vertical levels
-  integer  			:: Nptslmdz, Nlevlmdz  	! Nb de points issus de physiq.F
-  integer, save 		:: Npoints_it   	! Max number of gridpoints to be 
-  	   			   			! processed in one iteration
-  type(cosp_config), save 	:: cfg          	! Variable qui contient les cles
-  		     		   			! logiques des simulateurs et des
-							! diagnostics, definie dans:
-							! lmdz_cosp_construct_destroy_mod
-!$OMP THREADPRIVATE(cfg)
-
-  integer			:: t0, t1, count_rate, count_max
-  real(wp), save 		:: cloudsat_radar_freq, cloudsat_k2, rttov_ZenAng, co2, &
-  	    			   ch4, n2o, co, emsfc_lw
-!$OMP THREADPRIVATE(emsfc_lw)
-
-  integer, dimension(RTTOV_MAX_CHANNELS), save	 :: rttov_Channels
-  real(wp), dimension(RTTOV_MAX_CHANNELS), save  :: rttov_Surfem
-  integer, save 			   	 :: surface_radar, use_mie_tables, &
-  	   					    cloudsat_use_gas_abs, cloudsat_do_ray, &
-						    melt_lay
-  integer, save 				 :: lidar_ice_type
-  integer, save 				 :: rttov_platform, rttov_satellite, &
-  	   					    rttov_Instrument, rttov_Nchannels
-  logical, save 				 :: use_vgrid_in, csat_vgrid_in, &
-  	   					    use_precipitation_fluxes
-
-! Declaration necessaires pour les sorties IOIPSL
-  real        	:: ecrit_day, ecrit_hf, ecrit_mth, missing_val
-  logical 	:: ok_mensuelCOSP, ok_journeCOSP, ok_hfCOSP, ok_all_xml
-  logical, save :: debut_cosp=.true.
-!$OMP THREADPRIVATE(debut_cosp)
-
-  logical, save :: first_write=.true.
-!$OMP THREADPRIVATE(first_write)
-
-  integer, save :: cosp_init_flag = 0
-!$OMP THREADPRIVATE(cosp_init_flag)
-
-
-!-----------------------------  Input variables from LMDZ-GCM  -------------------------------
-  integer                             	     :: overlaplmdz   ! overlap type: 1=max, 
-  					       		      ! 2=rand, 3=max/rand
-  real, dimension(Nptslmdz,Nlevlmdz) 	     :: phi, p, ph, T, sh, rh, tca, cca, mr_lsliq,   &
-  					        mr_lsice, mr_ccliq, mr_ccice, fl_lsrain,     & 
-                                       	        fl_lssnow, fl_ccrain, fl_ccsnow, fl_lsgrpl,  &
-                                       	        zlev, zlev_half, mr_ozone, radliq, radice,   &
-					        dtau_s, dem_s, dtau_c, dem_c, ref_liq, ref_ice
-  real, dimension(Nptslmdz,Nlevlmdz) 	     :: fl_lsrainI, fl_lssnowI, fl_ccrainI, fl_ccsnowI
-  real, dimension(Nptslmdz)        	     :: lon, lat, skt, fracTerLic, u_wind, v_wind, &
-  					        phis, sunlit
-  real, dimension(Nptslmdz)        	     :: land ! variables intermediaire pour masque TerLic
-  real, dimension(Nlevlmdz)        	     :: presnivs
-  integer                         	     :: itap, k, ip
-  real                            	     :: dtime, freq_cosp
-  real, dimension(2)               	     :: time_bnds
-
-  double precision                           :: d_dtime
-  double precision, dimension(2)             :: d_time_bnds
-
-
-  ! ######################################################################################
-  ! Declarations specific to COSP2
-  ! ######################################################################################
-
-  ! Local variables
-  logical :: &
-       Lsingle     = .true.,  & ! True if using MMF_v3_single_moment CLOUDSAT
-       		     	      	! microphysical scheme (default)
-       Ldouble     = .false.    ! True if using MMF_v3.5_two_moment CLOUDSAT 
-       		     		! microphysical scheme
-  type(size_distribution), save   	     :: sd            ! Hydrometeor description
-!$OMP THREADPRIVATE(sd)
-  type(radar_cfg), save			     :: rcfg_cloudsat ! Radar configuration
-!$OMP THREADPRIVATE(rcfg_cloudsat)
-  real, dimension(Nptslmdz,Nlevlmdz,N_HYDRO) :: Reff	      ! Liquid and Ice particles
-  					     		      ! effective radius
-  type(cosp_outputs)			     :: cospOUT       ! COSP simulator outputs
-  type(cosp_optical_inputs) 		     :: cospIN        ! COSP optical (or derived?)
-  					     		      ! fields needed by simulators
-  type(cosp_column_inputs) 		     :: cospstateIN   ! COSP model fields needed
-  					     		      ! by simulators
-  character(len=256), dimension(100)	     :: cosp_status
-  character(len=64), save      		     :: cloudsat_micro_scheme
-
-  ! Indices to address arrays of LS and CONV hydrometeors
-  integer,parameter :: &
-       I_LSCLIQ = 1, & ! Large-scale (stratiform) liquid
-       I_LSCICE = 2, & ! Large-scale (stratiform) ice
-       I_LSRAIN = 3, & ! Large-scale (stratiform) rain
-       I_LSSNOW = 4, & ! Large-scale (stratiform) snow
-       I_CVCLIQ = 5, & ! Convective liquid
-       I_CVCICE = 6, & ! Convective ice
-       I_CVRAIN = 7, & ! Convective rain
-       I_CVSNOW = 8, & ! Convective snow
-       I_LSGRPL = 9    ! Large-scale (stratiform) groupel
-
-! Parametres qui sont lus a partir du fichier "cosp_input_nl.txt"
-   namelist/COSP_INPUT/overlap, isccp_topheight, isccp_topheight_direction,  &
-              npoints_it, ncolumns, use_vgrid_in, csat_vgrid_in,  &
-              cloudsat_radar_freq, surface_radar, use_mie_tables,  &
-              cloudsat_use_gas_abs, cloudsat_do_ray, melt_lay, cloudsat_k2,  &
-              cloudsat_micro_scheme, lidar_ice_type, use_precipitation_fluxes,   &
-              rttov_platform, rttov_satellite, rttov_Instrument, rttov_Nchannels, &
-              rttov_Channels, rttov_Surfem, rttov_ZenAng, co2, ch4, n2o, co
-
-!------------------------   Fin declaration des variables   ------------------------
-
-
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-!
-! 1) Lecture du fichier "cosp_input_nl.txt", parametres d'entree pour COSP
-!
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-
-print*,'Entree lmdz_cosp_interface' !phys_cosp2'
-if (debut_cosp) then
-  NPoints=Nptslmdz
-  Nlevels=Nlevlmdz
-! Surface emissivity
-        emsfc_lw = 1.
-  
-! Lecture du namelist input 
-!  CALL read_cosp_input
-   IF (is_master) THEN
-      OPEN(10,file=cosp_input_nl,status='old')
-      READ(10,nml=cosp_input)
-      CLOSE(10)
-   ENDIF
-
-
-!$OMP BARRIER 
-    CALL bcast(overlap)
-    CALL bcast(isccp_topheight)
-    CALL bcast(isccp_topheight_direction)
-    CALL bcast(npoints_it)
-    CALL bcast(ncolumns)
-    CALL bcast(use_vgrid_in)
-    CALL bcast(csat_vgrid_in)
-    CALL bcast(cloudsat_radar_freq)
-    CALL bcast(surface_radar)
-    CALL bcast(cloudsat_use_gas_abs)
-    CALL bcast(cloudsat_do_ray)
-    CALL bcast(cloudsat_k2)
-    CALL bcast(lidar_ice_type)
-    CALL bcast(use_precipitation_fluxes)
-    CALL bcast(rttov_platform)
-    CALL bcast(rttov_satellite)
-    CALL bcast(rttov_Instrument)
-    CALL bcast(rttov_Nchannels)
-    CALL bcast(rttov_Channels)
-    CALL bcast(rttov_Surfem)
-    CALL bcast(rttov_ZenAng)
-    CALL bcast(co2)
-    CALL bcast(ch4)
-    CALL bcast(n2o)
-    CALL bcast(co)
-    CALL bcast(cloudsat_micro_scheme)
-
-    print*,'ok read  cosp_input_nl'
-
-! Clefs Outputs initialisation
- IF (using_xios) THEN
-   call cosp_outputkeys_init(cfg)
- ELSE
-   call read_cosp_output_nl(itap,cosp_output_nl,cfg)
- ENDIF
-
-  print*,' Cles des differents simulateurs cosp a itap :',itap
-  print*,'cfg%Lcloudsat, cfg%Lcalipso, cfg%LgrLidar532, cfg%Latlid, cfg%Lparasol, &
-	cfg%Lisccp, cfg%Lmisr, cfg%Lmodis, cfg%Lrttov', &
-        cfg%Lcloudsat, cfg%Lcalipso, cfg%LgrLidar532, cfg%Latlid, cfg%Lparasol, &
-        cfg%Lisccp, cfg%Lmisr, cfg%Lmodis, cfg%Lrttov
-
-    if (overlaplmdz.ne.overlap) then
-       print*,'Attention overlaplmdz different de overlap lu dans namelist '
-    endif
-
- IF (using_xios) THEN
-   print*,'On passe par using_xios'
- ELSE
-   if (cosp_init_flag .eq. 0) then
-
-      ! Initialize the distributional parameters for hydrometeors in radar simulator.
-      ! In COSPv1.4, this was declared in cosp_defs.f.
-      if (cloudsat_micro_scheme == 'MMF_v3.5_two_moment')  then
-         ldouble = .true. 
-         lsingle = .false.
-      endif
-      call hydro_class_init(lsingle,ldouble,sd)
-      call quickbeam_optics_init()
-
-      print*,' just before call COSP_INIT, cosp_init_flag =', cosp_init_flag
-      call COSP_INIT(cfg%Lisccp, cfg%Lmodis, cfg%Lmisr, cfg%Lcloudsat, cfg%Lcalipso, &
-         cfg%LgrLidar532, cfg%Latlid, cfg%Lparasol, cfg%Lrttov,          &
-         cloudsat_radar_freq, cloudsat_k2, cloudsat_use_gas_abs,         &
-         cloudsat_do_ray, isccp_topheight, isccp_topheight_direction,    &
-         surface_radar, rcfg_cloudsat, use_vgrid_in, csat_vgrid_in,      &
-         niv_sorties, Nlevels, cloudsat_micro_scheme)
-      cosp_init_flag = 1
-      print*,' just after call COSP_INIT, cosp_init_flag =', cosp_init_flag
-    endif
-  ENDIF
-
-  print*,'Fin lecture Namelists, debut_cosp =',debut_cosp
-
-  endif ! debut_cosp
-
-
-!!! Ici on modifie les cles logiques pour les outputs selon les champs actives dans les .xml
-  if ((itap.ge.1).and.(first_write))then
-    IF (using_xios) call read_xiosfieldactive(cfg)
-    first_write=.false.
-
-if (cosp_init_flag .eq. 0) then
-
-    ! Initialize the distributional parameters for hydrometeors in radar simulator.
-    ! In COSPv1.4, this was declared in cosp_defs.f.
-    if (cloudsat_micro_scheme == 'MMF_v3.5_two_moment')  then
-       ldouble = .true. 
-       lsingle = .false.
-    endif
-    call hydro_class_init(lsingle,ldouble,sd)
-    call quickbeam_optics_init()
-
-  print*,' just before call COSP_INIT, cosp_init_flag =', cosp_init_flag
-  call COSP_INIT(cfg%Lisccp, cfg%Lmodis, cfg%Lmisr, cfg%Lcloudsat, cfg%Lcalipso, &
-        cfg%LgrLidar532, cfg%Latlid, cfg%Lparasol, cfg%Lrttov,          &
-        cloudsat_radar_freq, cloudsat_k2, cloudsat_use_gas_abs,         &
-        cloudsat_do_ray, isccp_topheight, isccp_topheight_direction,    &
-        surface_radar, rcfg_cloudsat, use_vgrid_in, csat_vgrid_in,      &
-        niv_sorties, Nlevels, cloudsat_micro_scheme)
-  cosp_init_flag = 1
- print*,' just after call COSP_INIT, cosp_init_flag =', cosp_init_flag
-endif ! cosp_init_flag
-
-
-print*,' Cles des differents simulateurs cosp a itap :',itap
-print*,'cfg%Lcloudsat, cfg%Lcalipso, cfg%LgrLidar532, cfg%Latlid, cfg%Lparasol, &
-	cfg%Lisccp, cfg%Lmisr, cfg%Lmodis, cfg%Lrttov', &
-        cfg%Lcloudsat, cfg%Lcalipso, cfg%LgrLidar532, cfg%Latlid, cfg%Lparasol, &
-	cfg%Lisccp, cfg%Lmisr, cfg%Lmodis, cfg%Lrttov
-
-  endif !(itap.gt.1).and.(first_write)
-
-  time_bnds(1) = dtime-dtime/2.
-  time_bnds(2) = dtime+dtime/2.
-
-  d_time_bnds=time_bnds
-  d_dtime=dtime
-
-!-------------------------   Fin initialisation de COSP   --------------------------
-
-
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-!
-! 3) Calculs des champs d'entree COSP a partir des variables LMDZ
-!
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-
-    ! 0) Create ptop/ztop for gbx%pf and gbx%zlev are for the the interface, 
-    !    also reverse CAM height/pressure values for input into CSOP
-    !    CAM state%pint from top to surface, COSP wants surface to top.
-
-! 0) Altitudes du modele calculees a partir de la variable geopotentiel phi et phis    
-        zlev = phi/9.81
-
-        zlev_half(:,1) = phis(:)/9.81
-        do k = 2, Nlevels
-          do ip = 1, Npoints
-           zlev_half(ip,k) = phi(ip,k)/9.81 + &
-               (phi(ip,k)-phi(ip,k-1))/9.81 * (ph(ip,k)-p(ip,k)) / (p(ip,k)-p(ip,k-1))
-          enddo
-        enddo
-
-! 1) Quantite de nuages (couverture?), convectif (=0) et total
-        cca = 0._wp ! convective_cloud_amount (1)
-        tca = tca   ! total_cloud_amount (1)
-
-! 2) Humidite relative est donnee tel quel (variable rh)
-
-! 3) Masque terre/mer a partir de la variable fracTerLic
-        do ip = 1, Npoints
-          if (fracTerLic(ip).ge.0.5) then
-             land(ip) = 1.
-          else
-             land(ip) = 0.
-          endif
-        enddo
-
-
-! A voir l equivalent LMDZ
-  mr_ccliq = 0.0
-  mr_ccice = 0.0
-!!!        gbx%mr_hydro(:,:,I_LSCLIQ) = mr_lsliq !mixing_ratio_large_scale_cloud_liquid (kg/kg)
-!!!        gbx%mr_hydro(:,:,I_LSCICE) = mr_lsice !mixing_ratio_large_scale_cloud_ic
-!!!        gbx%mr_hydro(:,:,I_CVCLIQ) = mr_ccliq !mixing_ratio_convective_cloud_liquid
-!!!        gbx%mr_hydro(:,:,I_CVCICE) = mr_ccice !mixing_ratio_convective_cloud_ice
-! A revoir
-        fl_lsrain = fl_lsrainI + fl_ccrainI
-        fl_lssnow = fl_lssnowI + fl_ccsnowI
-!!!        gbx%rain_ls = fl_lsrain !flux_large_scale_cloud_rain (kg m^-2 s^-1)
-!!!        gbx%snow_ls = fl_lssnow !flux_large_scale_cloud_snow
-!  A voir l equivalent LMDZ
-        fl_lsgrpl = 0.
-        fl_ccsnow = 0.
-        fl_ccrain = 0.
-!!!        gbx%grpl_ls = fl_lsgrpl  !flux_large_scale_cloud_graupel
-!!!        gbx%rain_cv = fl_ccrain  !flux_convective_cloud_rain
-!!!        gbx%snow_cv = fl_ccsnow  !flux_convective_cloud_snow
-
-        ! ISCCP simulator
-        dtau_c  = 0.
-        dem_c   = 0.
-
-! note: reff_cosp dimensions should be same as cosp (reff_cosp has 9 hydrometeor dimension)
-     Reff(1:Npoints,1:Nlevels,1:N_HYDRO) = 0.
-     Reff(:,:,I_LSCLIQ) = ref_liq*1e-6
-     Reff(:,:,I_LSCICE) = ref_ice*1e-6
-     Reff(:,:,I_CVCLIQ) = ref_liq*1e-6
-     Reff(:,:,I_CVCICE) = ref_ice*1e-6
-
-
-if (cosp_init_flag .eq. 1) then      ! cosp_init_flag = 1
-
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-!
-! 4a) On construit la variable cospOUT qui contient tous les diagnostics de sortie.
-! Elle sera remplie lors de l'appel du simulateur COSP
-!
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-
-    call construct_cosp_outputs(cfg,Npoints,Ncolumns,Nlevels,niv_sorties,0,cospOUT)
-
-
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-!
-! 4b) On construit la variable cospstateIN que l'on va remplir avec les champs LMDZ
-! Les champ verticaux doivent etre donnes a l'envers, c-a-d : (Nlevels:1) = (TOA:SFC)
-!
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-
-    call construct_cospstateIN(Npoints,Nlevels,0,cospstateIN)
-
-    cospstateIN%lat                 		        = lat(1:Npoints)
-    cospstateIN%lon                     		= lon(1:Npoints) 
-    cospstateIN%at              	      		= t(1:Npoints,Nlevels:1:-1) 
-    cospstateIN%qv              	     		= sh(1:Npoints,Nlevels:1:-1)
-    cospstateIN%o3              	      		= mr_ozone(1:Npoints,Nlevels:1:-1)  
-    cospstateIN%sunlit          	      		= sunlit(1:Npoints)
-    cospstateIN%skt             	       		= skt(1:Npoints)
-    cospstateIN%land            	     		= land(1:Npoints)
-    cospstateIN%surfelev            	     		= zlev_half(1:Npoints,1)
-    cospstateIN%pfull           	      		= p(1:Npoints,Nlevels:1:-1)
-    cospstateIN%phalf(1:Npoints,1)	                = 0._wp
-    cospstateIN%phalf(1:Npoints,2:Nlevels+1)	        = ph(1:Npoints,Nlevels:1:-1)  
-    cospstateIN%hgt_matrix                  		= zlev(1:Npoints,Nlevels:1:-1) 
-    cospstateIN%hgt_matrix_half(1:Npoints,Nlevels+1) 	= 0._wp
-    cospstateIN%hgt_matrix_half(1:Npoints,1:Nlevels) 	= zlev_half(1:Npoints,Nlevels:1:-1) 
-
-
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-!
-! 4c) On construit la variable cospIN qui contient les proprietes optiques subcolumn
-! pour COSP. Elle sera essentiellement remplie dans la subroutine subsample_and_optics
-! ou sont appeles SCOPS, PREC_SCOPS et les subroutines qui calculent les signaux
-! simules pour chaque simulateur actif.
-!
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-
-    call construct_cospIN(cfg,Npoints,Ncolumns,Nlevels,cospIN)
-    cospIN%emsfc_lw  = emsfc_lw
-    if (cfg%Lcloudsat) cospIN%rcfg_cloudsat = rcfg_cloudsat
-
-
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-!
-! 5) Appel de subsample_and_optics : Les champs verticaux doivent etre donnes a
-! l'envers comme pour le remplissage de cospstateIN, c-a-d : (Nlevels:1) = (TOA:SFC)
-!
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-
-    call subsample_and_optics(cfg, Npoints, Nlevels, Ncolumns, N_HYDRO,overlap,	&
-        		      use_precipitation_fluxes, lidar_ice_type, sd, &
-			      tca(1:Npoints,Nlevels:1:-1), cca(1:Npoints,Nlevels:1:-1), &
-           		      fl_lsrain(1:Npoints,Nlevels:1:-1), &
-			      fl_lssnow(1:Npoints,Nlevels:1:-1), &
-			      fl_lsgrpl(1:Npoints,Nlevels:1:-1), &
-			      fl_ccrain(1:Npoints,Nlevels:1:-1), &
-          		      fl_ccsnow(1:Npoints,Nlevels:1:-1), &
-			      mr_lsliq(1:Npoints,Nlevels:1:-1), &
-			      mr_lsice(1:Npoints,Nlevels:1:-1), &
-			      mr_ccliq(1:Npoints,Nlevels:1:-1), &
-			      mr_ccice(1:Npoints,Nlevels:1:-1), &
-             		      Reff(1:Npoints,Nlevels:1:-1,:), &
-			      dtau_c(1:Npoints,Nlevels:1:-1), &
-			      dtau_s(1:Npoints,Nlevels:1:-1), &
-			      dem_c(1:Npoints,Nlevels:1:-1), &
-			      dem_s(1:Npoints,Nlevels:1:-1), cospstateIN, cospIN)
-
-
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-!
-! 6) On appelle le simulateur COSPv2 
-!
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-
-      print*,'call simulateur'
-
-cosp_status = COSP_SIMULATOR(cospIN, cospstateIN, cospOUT, 1, Npoints, debug=.false.)
-
-endif ! cosp_init_flag = 1
-
-
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-!
-! 7a) Ecriture des sorties 1: on cree d'abord les fichiers NCDF pour ecrire les sorties
-! en appelant lmdz_cosp_output_open (lors du premier appel de cette interface pour les
-! 2 options d'ecriture), ou sont definis les axes et les caracteristiques
-! des fichiers de sortie avec les diagnostics.
-!
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-
-    if (debut_cosp) then
-      !$OMP MASTER
-
-        print *, ' Open outpts files and define axis'
-        call lmdz_cosp_output_open(Nlevlmdz, Ncolumns, presnivs, dtime, freq_cosp,       &
-                                   ok_mensuelCOSP, ok_journeCOSP, ok_hfCOSP, ok_all_xml, &
-                                   ecrit_mth, ecrit_day, ecrit_hf, use_vgrid_in,         &
-			           niv_sorties, vgrid_z_in, zlev(1,:))
-
-      !$OMP END MASTER
-      !$OMP BARRIER
-       debut_cosp=.false.
-      endif ! debut_cosp
-
-if (cosp_init_flag .eq. 1) then
-
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-!
-! 7b) Ecriture des sorties 2: le remplissage des fichiers de sortie se fait a chaque
-! appel de cette interface avec une difference entre les 2 options d'ecriture:
-!
-! AVEC xios, on commence a remplir les fichiers de sortie a partir du DEUXIEME
-! appel de cette interface (lorsque cosp_init_flag = 1).
-!
-! SANS xios, on commence a remplir les fichiers de sortie a partir du PREMIER
-! appel de cette interface (lorsque cosp_init_flag = 1).
-!
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-
-       print *, 'Calling write output'
-        call lmdz_cosp_output_write(Nlevlmdz, Npoints, Ncolumns, itap, dtime, freq_COSP, &
-                                    missing_val, cfg, niv_sorties, cospOUT)
-
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-!
-! 8) On libere la memoire allouee lors de cet appel a l'interface
-!
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-
-    call destroy_cospIN(cospIN)
-    call destroy_cospstateIN(cospstateIN)
-    call destroy_cosp_outputs(cospOUT) 
-
-endif ! cosp_init_flag = 1
- 
-end subroutine lmdz_cosp_interface
Index: /LMDZ6/trunk/libf/phylmd/cospv2/lmdz_cosp_interface.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cospv2/lmdz_cosp_interface.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/cospv2/lmdz_cosp_interface.f90	(revision 5268)
@@ -0,0 +1,571 @@
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+!
+! Nouveau code d'interface entre LMDZ et COSPv2 (version 2)
+! L'ancienne interface s'appelait "phys_cosp2" et avait ete concue pour COSPv1.4.
+! Dans cette nouvelle version de COSP, le code a ete restructure pour optimiser les calculs
+! des differents simulateurs et pour proposer de nouvelles fonctionnalites (par exemple,
+! intervenir sur les profils sous-maille, ou subcolumns, donnes en entre a COSP afin que
+! leur definition soit coherente avec les parametrisations du modele hote).
+! Cette version de COSP propose aussi de nombreux nouveaux diagnostics, notamment pour
+! le simulateur lidar (diagnostics CALIPSO-OPAQ, lidar sol 532nm et lidar ATLID 355nm).
+!
+! Interface reecrite par R.Guzman (01/2019), a partir de l'interface initiale concue
+! et ecrite par A.Idelkadi 
+!
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+!  subroutine phys_cosp2( itap,dtime,freq_cosp, &
+  subroutine lmdz_cosp_interface(itap, dtime, freq_cosp, ok_mensuelCOSP, ok_journeCOSP,   &
+                         ok_hfCOSP, ecrit_mth, ecrit_day, ecrit_hf, ok_all_xml,   &
+                         missing_val, Nptslmdz, Nlevlmdz, lon, lat, presnivs,     &
+                         overlaplmdz, sunlit, ref_liq, ref_ice, fracTerLic,       &
+                         u_wind, v_wind, phis, phi, ph, p, skt, t, sh, rh,        &
+                         tca, cca, mr_lsliq, mr_lsice, fl_lsrainI, fl_lssnowI,    &
+                         fl_ccrainI, fl_ccsnowI, mr_ozone, dtau_s, dem_s)
+
+!--------------  Inputs  ---------------
+! itap,                                 !Increment de la physiq
+! dtime,                                !Pas de temps physiq
+! overlaplmdz,                          !Type Overlap venant de LMDZ
+! Npoints,                              !Nb de points de la grille physiq
+! Nlevels,                              !Nb de niveaux verticaux
+! Ncolumns,                             !Number of subcolumns
+! lon,lat,                              !Longitudes et latitudes de la grille LMDZ
+! ref_liq, ref_ice,                     !Rayons effectifs des particules liq et ice (en micron)
+! fracTerLic,                           !Fraction terre a convertir en masque
+! u_wind, v_wind,                       !Vents a 10m ???
+! phi,                                  !Geopotentiel
+! phis,                                 !Geopotentiel sol
+! ph,                                   !pression pour chaque inter-couche
+! p,                                    !Pression aux milieux des couches
+! skt, t,                               !Temp au sol et temp 3D
+! sh,                                   !Humidite specifique
+! rh,                                   !Humidite relative
+! tca,                                  !Fraction nuageuse
+! cca                                   !Fraction nuageuse convective
+! mr_lsliq,                             !Liq Cloud water content
+! mr_lsice,                             !Ice Cloud water content
+! mr_ccliq,                             !Convective Cloud Liquid water content  
+! mr_ccice,                             !Cloud ice water content
+! fl_lsrain,                            !Large scale precipitation lic
+! fl_lssnow,                            !Large scale precipitation ice
+! fl_ccrain,                            !Convective precipitation lic
+! fl_ccsnow,                            !Convective precipitation ice
+! mr_ozone,                             !Concentration ozone (Kg/Kg)
+! dem_s                                 !Cloud optical emissivity
+! dtau_s               			!Cloud optical thickness
+! emsfc_lw = 1.        			!Surface emissivity dans radlwsw.F90
+
+
+!--------------  Outputs  --------------
+! La liste complete des diagnostics de sortie (observables simulees) que l'on peut
+! avoir avec COSPv2 se trouve au debut du fichier : cosp_read_otputkeys.F90
+
+
+!!! Modules specifiques a l'interface LMDZ-COSP
+  use mod_phys_lmdz_para
+  use mod_grid_phy_lmdz
+  use ioipsl
+  use iophy
+  use lmdz_xios, ONLY : using_xios
+  use lmdz_cosp_output_mod
+  use lmdz_cosp_output_write_mod
+  use lmdz_cosp_read_outputkeys
+  use lmdz_cosp_subsample_and_optics_mod, only : subsample_and_optics
+  use lmdz_cosp_construct_destroy_mod
+
+!!! Modules faisant partie du code source de COSPv2
+  use cosp_kinds,  only: wp                         
+  use MOD_COSP_CONFIG,       only: N_HYDRO,RTTOV_MAX_CHANNELS, &
+                                    niv_sorties, vgrid_z_in
+  use mod_quickbeam_optics,  only: size_distribution,hydro_class_init, &
+                                   quickbeam_optics_init
+  use quickbeam,            only: radar_cfg
+  use mod_cosp,             only: cosp_init,cosp_optical_inputs, &
+                                  cosp_column_inputs,cosp_outputs, &
+                                  cosp_simulator
+
+
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+!
+! Declaration des variables 
+!
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+  IMPLICIT NONE
+
+  ! Local variables
+  character(len=64),PARAMETER	:: cosp_input_nl  = 'cospv2_input_nl.txt'
+  character(len=64),PARAMETER  	:: cosp_output_nl = 'cospv2_output_nl.txt'
+
+  integer, save 	       	:: isccp_topheight, isccp_topheight_direction, overlap
+  integer, save  	       	:: Ncolumns    	    	! Number of subcolumns in SCOPS
+  integer, save 	       	:: Npoints            	! Number of gridpoints
+!$OMP THREADPRIVATE(Npoints)
+  integer, save			:: Nlevels		! Number of model vertical levels
+  integer  			:: Nptslmdz, Nlevlmdz  	! Nb de points issus de physiq.F
+  integer, save 		:: Npoints_it   	! Max number of gridpoints to be 
+  	   			   			! processed in one iteration
+  type(cosp_config), save 	:: cfg          	! Variable qui contient les cles
+  		     		   			! logiques des simulateurs et des
+							! diagnostics, definie dans:
+							! lmdz_cosp_construct_destroy_mod
+!$OMP THREADPRIVATE(cfg)
+
+  integer			:: t0, t1, count_rate, count_max
+  real(wp), save 		:: cloudsat_radar_freq, cloudsat_k2, rttov_ZenAng, co2, &
+  	    			   ch4, n2o, co, emsfc_lw
+!$OMP THREADPRIVATE(emsfc_lw)
+
+  integer, dimension(RTTOV_MAX_CHANNELS), save	 :: rttov_Channels
+  real(wp), dimension(RTTOV_MAX_CHANNELS), save  :: rttov_Surfem
+  integer, save 			   	 :: surface_radar, use_mie_tables, &
+  	   					    cloudsat_use_gas_abs, cloudsat_do_ray, &
+						    melt_lay
+  integer, save 				 :: lidar_ice_type
+  integer, save 				 :: rttov_platform, rttov_satellite, &
+  	   					    rttov_Instrument, rttov_Nchannels
+  logical, save 				 :: use_vgrid_in, csat_vgrid_in, &
+  	   					    use_precipitation_fluxes
+
+! Declaration necessaires pour les sorties IOIPSL
+  real        	:: ecrit_day, ecrit_hf, ecrit_mth, missing_val
+  logical 	:: ok_mensuelCOSP, ok_journeCOSP, ok_hfCOSP, ok_all_xml
+  logical, save :: debut_cosp=.true.
+!$OMP THREADPRIVATE(debut_cosp)
+
+  logical, save :: first_write=.true.
+!$OMP THREADPRIVATE(first_write)
+
+  integer, save :: cosp_init_flag = 0
+!$OMP THREADPRIVATE(cosp_init_flag)
+
+
+!-----------------------------  Input variables from LMDZ-GCM  -------------------------------
+  integer                             	     :: overlaplmdz   ! overlap type: 1=max, 
+  					       		      ! 2=rand, 3=max/rand
+  real, dimension(Nptslmdz,Nlevlmdz) 	     :: phi, p, ph, T, sh, rh, tca, cca, mr_lsliq,   &
+  					        mr_lsice, mr_ccliq, mr_ccice, fl_lsrain,     & 
+                                       	        fl_lssnow, fl_ccrain, fl_ccsnow, fl_lsgrpl,  &
+                                       	        zlev, zlev_half, mr_ozone, radliq, radice,   &
+					        dtau_s, dem_s, dtau_c, dem_c, ref_liq, ref_ice
+  real, dimension(Nptslmdz,Nlevlmdz) 	     :: fl_lsrainI, fl_lssnowI, fl_ccrainI, fl_ccsnowI
+  real, dimension(Nptslmdz)        	     :: lon, lat, skt, fracTerLic, u_wind, v_wind, &
+  					        phis, sunlit
+  real, dimension(Nptslmdz)        	     :: land ! variables intermediaire pour masque TerLic
+  real, dimension(Nlevlmdz)        	     :: presnivs
+  integer                         	     :: itap, k, ip
+  real                            	     :: dtime, freq_cosp
+  real, dimension(2)               	     :: time_bnds
+
+  double precision                           :: d_dtime
+  double precision, dimension(2)             :: d_time_bnds
+
+
+  ! ######################################################################################
+  ! Declarations specific to COSP2
+  ! ######################################################################################
+
+  ! Local variables
+  logical :: &
+       Lsingle     = .true.,  & ! True if using MMF_v3_single_moment CLOUDSAT
+       		     	      	! microphysical scheme (default)
+       Ldouble     = .false.    ! True if using MMF_v3.5_two_moment CLOUDSAT 
+       		     		! microphysical scheme
+  type(size_distribution), save   	     :: sd            ! Hydrometeor description
+!$OMP THREADPRIVATE(sd)
+  type(radar_cfg), save			     :: rcfg_cloudsat ! Radar configuration
+!$OMP THREADPRIVATE(rcfg_cloudsat)
+  real, dimension(Nptslmdz,Nlevlmdz,N_HYDRO) :: Reff	      ! Liquid and Ice particles
+  					     		      ! effective radius
+  type(cosp_outputs)			     :: cospOUT       ! COSP simulator outputs
+  type(cosp_optical_inputs) 		     :: cospIN        ! COSP optical (or derived?)
+  					     		      ! fields needed by simulators
+  type(cosp_column_inputs) 		     :: cospstateIN   ! COSP model fields needed
+  					     		      ! by simulators
+  character(len=256), dimension(100)	     :: cosp_status
+  character(len=64), save      		     :: cloudsat_micro_scheme
+
+  ! Indices to address arrays of LS and CONV hydrometeors
+  integer,parameter :: &
+       I_LSCLIQ = 1, & ! Large-scale (stratiform) liquid
+       I_LSCICE = 2, & ! Large-scale (stratiform) ice
+       I_LSRAIN = 3, & ! Large-scale (stratiform) rain
+       I_LSSNOW = 4, & ! Large-scale (stratiform) snow
+       I_CVCLIQ = 5, & ! Convective liquid
+       I_CVCICE = 6, & ! Convective ice
+       I_CVRAIN = 7, & ! Convective rain
+       I_CVSNOW = 8, & ! Convective snow
+       I_LSGRPL = 9    ! Large-scale (stratiform) groupel
+
+! Parametres qui sont lus a partir du fichier "cosp_input_nl.txt"
+   namelist/COSP_INPUT/overlap, isccp_topheight, isccp_topheight_direction,  &
+              npoints_it, ncolumns, use_vgrid_in, csat_vgrid_in,  &
+              cloudsat_radar_freq, surface_radar, use_mie_tables,  &
+              cloudsat_use_gas_abs, cloudsat_do_ray, melt_lay, cloudsat_k2,  &
+              cloudsat_micro_scheme, lidar_ice_type, use_precipitation_fluxes,   &
+              rttov_platform, rttov_satellite, rttov_Instrument, rttov_Nchannels, &
+              rttov_Channels, rttov_Surfem, rttov_ZenAng, co2, ch4, n2o, co
+
+!------------------------   Fin declaration des variables   ------------------------
+
+
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+!
+! 1) Lecture du fichier "cosp_input_nl.txt", parametres d'entree pour COSP
+!
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+print*,'Entree lmdz_cosp_interface' !phys_cosp2'
+if (debut_cosp) then
+  NPoints=Nptslmdz
+  Nlevels=Nlevlmdz
+! Surface emissivity
+        emsfc_lw = 1.
+  
+! Lecture du namelist input 
+!  CALL read_cosp_input
+   IF (is_master) THEN
+      OPEN(10,file=cosp_input_nl,status='old')
+      READ(10,nml=cosp_input)
+      CLOSE(10)
+   ENDIF
+
+
+!$OMP BARRIER 
+    CALL bcast(overlap)
+    CALL bcast(isccp_topheight)
+    CALL bcast(isccp_topheight_direction)
+    CALL bcast(npoints_it)
+    CALL bcast(ncolumns)
+    CALL bcast(use_vgrid_in)
+    CALL bcast(csat_vgrid_in)
+    CALL bcast(cloudsat_radar_freq)
+    CALL bcast(surface_radar)
+    CALL bcast(cloudsat_use_gas_abs)
+    CALL bcast(cloudsat_do_ray)
+    CALL bcast(cloudsat_k2)
+    CALL bcast(lidar_ice_type)
+    CALL bcast(use_precipitation_fluxes)
+    CALL bcast(rttov_platform)
+    CALL bcast(rttov_satellite)
+    CALL bcast(rttov_Instrument)
+    CALL bcast(rttov_Nchannels)
+    CALL bcast(rttov_Channels)
+    CALL bcast(rttov_Surfem)
+    CALL bcast(rttov_ZenAng)
+    CALL bcast(co2)
+    CALL bcast(ch4)
+    CALL bcast(n2o)
+    CALL bcast(co)
+    CALL bcast(cloudsat_micro_scheme)
+
+    print*,'ok read  cosp_input_nl'
+
+! Clefs Outputs initialisation
+ IF (using_xios) THEN
+   call cosp_outputkeys_init(cfg)
+ ELSE
+   call read_cosp_output_nl(itap,cosp_output_nl,cfg)
+ ENDIF
+
+  print*,' Cles des differents simulateurs cosp a itap :',itap
+  print*,'cfg%Lcloudsat, cfg%Lcalipso, cfg%LgrLidar532, cfg%Latlid, cfg%Lparasol, &
+	cfg%Lisccp, cfg%Lmisr, cfg%Lmodis, cfg%Lrttov', &
+        cfg%Lcloudsat, cfg%Lcalipso, cfg%LgrLidar532, cfg%Latlid, cfg%Lparasol, &
+        cfg%Lisccp, cfg%Lmisr, cfg%Lmodis, cfg%Lrttov
+
+    if (overlaplmdz.ne.overlap) then
+       print*,'Attention overlaplmdz different de overlap lu dans namelist '
+    endif
+
+ IF (using_xios) THEN
+   print*,'On passe par using_xios'
+ ELSE
+   if (cosp_init_flag .eq. 0) then
+
+      ! Initialize the distributional parameters for hydrometeors in radar simulator.
+      ! In COSPv1.4, this was declared in cosp_defs.f.
+      if (cloudsat_micro_scheme == 'MMF_v3.5_two_moment')  then
+         ldouble = .true. 
+         lsingle = .false.
+      endif
+      call hydro_class_init(lsingle,ldouble,sd)
+      call quickbeam_optics_init()
+
+      print*,' just before call COSP_INIT, cosp_init_flag =', cosp_init_flag
+      call COSP_INIT(cfg%Lisccp, cfg%Lmodis, cfg%Lmisr, cfg%Lcloudsat, cfg%Lcalipso, &
+         cfg%LgrLidar532, cfg%Latlid, cfg%Lparasol, cfg%Lrttov,          &
+         cloudsat_radar_freq, cloudsat_k2, cloudsat_use_gas_abs,         &
+         cloudsat_do_ray, isccp_topheight, isccp_topheight_direction,    &
+         surface_radar, rcfg_cloudsat, use_vgrid_in, csat_vgrid_in,      &
+         niv_sorties, Nlevels, cloudsat_micro_scheme)
+      cosp_init_flag = 1
+      print*,' just after call COSP_INIT, cosp_init_flag =', cosp_init_flag
+    endif
+  ENDIF
+
+  print*,'Fin lecture Namelists, debut_cosp =',debut_cosp
+
+  endif ! debut_cosp
+
+
+!!! Ici on modifie les cles logiques pour les outputs selon les champs actives dans les .xml
+  if ((itap.ge.1).and.(first_write))then
+    IF (using_xios) call read_xiosfieldactive(cfg)
+    first_write=.false.
+
+if (cosp_init_flag .eq. 0) then
+
+    ! Initialize the distributional parameters for hydrometeors in radar simulator.
+    ! In COSPv1.4, this was declared in cosp_defs.f.
+    if (cloudsat_micro_scheme == 'MMF_v3.5_two_moment')  then
+       ldouble = .true. 
+       lsingle = .false.
+    endif
+    call hydro_class_init(lsingle,ldouble,sd)
+    call quickbeam_optics_init()
+
+  print*,' just before call COSP_INIT, cosp_init_flag =', cosp_init_flag
+  call COSP_INIT(cfg%Lisccp, cfg%Lmodis, cfg%Lmisr, cfg%Lcloudsat, cfg%Lcalipso, &
+        cfg%LgrLidar532, cfg%Latlid, cfg%Lparasol, cfg%Lrttov,          &
+        cloudsat_radar_freq, cloudsat_k2, cloudsat_use_gas_abs,         &
+        cloudsat_do_ray, isccp_topheight, isccp_topheight_direction,    &
+        surface_radar, rcfg_cloudsat, use_vgrid_in, csat_vgrid_in,      &
+        niv_sorties, Nlevels, cloudsat_micro_scheme)
+  cosp_init_flag = 1
+ print*,' just after call COSP_INIT, cosp_init_flag =', cosp_init_flag
+endif ! cosp_init_flag
+
+
+print*,' Cles des differents simulateurs cosp a itap :',itap
+print*,'cfg%Lcloudsat, cfg%Lcalipso, cfg%LgrLidar532, cfg%Latlid, cfg%Lparasol, &
+	cfg%Lisccp, cfg%Lmisr, cfg%Lmodis, cfg%Lrttov', &
+        cfg%Lcloudsat, cfg%Lcalipso, cfg%LgrLidar532, cfg%Latlid, cfg%Lparasol, &
+	cfg%Lisccp, cfg%Lmisr, cfg%Lmodis, cfg%Lrttov
+
+  endif !(itap.gt.1).and.(first_write)
+
+  time_bnds(1) = dtime-dtime/2.
+  time_bnds(2) = dtime+dtime/2.
+
+  d_time_bnds=time_bnds
+  d_dtime=dtime
+
+!-------------------------   Fin initialisation de COSP   --------------------------
+
+
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+!
+! 3) Calculs des champs d'entree COSP a partir des variables LMDZ
+!
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+    ! 0) Create ptop/ztop for gbx%pf and gbx%zlev are for the the interface, 
+    !    also reverse CAM height/pressure values for input into CSOP
+    !    CAM state%pint from top to surface, COSP wants surface to top.
+
+! 0) Altitudes du modele calculees a partir de la variable geopotentiel phi et phis    
+        zlev = phi/9.81
+
+        zlev_half(:,1) = phis(:)/9.81
+        do k = 2, Nlevels
+          do ip = 1, Npoints
+           zlev_half(ip,k) = phi(ip,k)/9.81 + &
+               (phi(ip,k)-phi(ip,k-1))/9.81 * (ph(ip,k)-p(ip,k)) / (p(ip,k)-p(ip,k-1))
+          enddo
+        enddo
+
+! 1) Quantite de nuages (couverture?), convectif (=0) et total
+        cca = 0._wp ! convective_cloud_amount (1)
+        tca = tca   ! total_cloud_amount (1)
+
+! 2) Humidite relative est donnee tel quel (variable rh)
+
+! 3) Masque terre/mer a partir de la variable fracTerLic
+        do ip = 1, Npoints
+          if (fracTerLic(ip).ge.0.5) then
+             land(ip) = 1.
+          else
+             land(ip) = 0.
+          endif
+        enddo
+
+
+! A voir l equivalent LMDZ
+  mr_ccliq = 0.0
+  mr_ccice = 0.0
+!!!        gbx%mr_hydro(:,:,I_LSCLIQ) = mr_lsliq !mixing_ratio_large_scale_cloud_liquid (kg/kg)
+!!!        gbx%mr_hydro(:,:,I_LSCICE) = mr_lsice !mixing_ratio_large_scale_cloud_ic
+!!!        gbx%mr_hydro(:,:,I_CVCLIQ) = mr_ccliq !mixing_ratio_convective_cloud_liquid
+!!!        gbx%mr_hydro(:,:,I_CVCICE) = mr_ccice !mixing_ratio_convective_cloud_ice
+! A revoir
+        fl_lsrain = fl_lsrainI + fl_ccrainI
+        fl_lssnow = fl_lssnowI + fl_ccsnowI
+!!!        gbx%rain_ls = fl_lsrain !flux_large_scale_cloud_rain (kg m^-2 s^-1)
+!!!        gbx%snow_ls = fl_lssnow !flux_large_scale_cloud_snow
+!  A voir l equivalent LMDZ
+        fl_lsgrpl = 0.
+        fl_ccsnow = 0.
+        fl_ccrain = 0.
+!!!        gbx%grpl_ls = fl_lsgrpl  !flux_large_scale_cloud_graupel
+!!!        gbx%rain_cv = fl_ccrain  !flux_convective_cloud_rain
+!!!        gbx%snow_cv = fl_ccsnow  !flux_convective_cloud_snow
+
+        ! ISCCP simulator
+        dtau_c  = 0.
+        dem_c   = 0.
+
+! note: reff_cosp dimensions should be same as cosp (reff_cosp has 9 hydrometeor dimension)
+     Reff(1:Npoints,1:Nlevels,1:N_HYDRO) = 0.
+     Reff(:,:,I_LSCLIQ) = ref_liq*1e-6
+     Reff(:,:,I_LSCICE) = ref_ice*1e-6
+     Reff(:,:,I_CVCLIQ) = ref_liq*1e-6
+     Reff(:,:,I_CVCICE) = ref_ice*1e-6
+
+
+if (cosp_init_flag .eq. 1) then      ! cosp_init_flag = 1
+
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+!
+! 4a) On construit la variable cospOUT qui contient tous les diagnostics de sortie.
+! Elle sera remplie lors de l'appel du simulateur COSP
+!
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+    call construct_cosp_outputs(cfg,Npoints,Ncolumns,Nlevels,niv_sorties,0,cospOUT)
+
+
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+!
+! 4b) On construit la variable cospstateIN que l'on va remplir avec les champs LMDZ
+! Les champ verticaux doivent etre donnes a l'envers, c-a-d : (Nlevels:1) = (TOA:SFC)
+!
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+    call construct_cospstateIN(Npoints,Nlevels,0,cospstateIN)
+
+    cospstateIN%lat                 		        = lat(1:Npoints)
+    cospstateIN%lon                     		= lon(1:Npoints) 
+    cospstateIN%at              	      		= t(1:Npoints,Nlevels:1:-1) 
+    cospstateIN%qv              	     		= sh(1:Npoints,Nlevels:1:-1)
+    cospstateIN%o3              	      		= mr_ozone(1:Npoints,Nlevels:1:-1)  
+    cospstateIN%sunlit          	      		= sunlit(1:Npoints)
+    cospstateIN%skt             	       		= skt(1:Npoints)
+    cospstateIN%land            	     		= land(1:Npoints)
+    cospstateIN%surfelev            	     		= zlev_half(1:Npoints,1)
+    cospstateIN%pfull           	      		= p(1:Npoints,Nlevels:1:-1)
+    cospstateIN%phalf(1:Npoints,1)	                = 0._wp
+    cospstateIN%phalf(1:Npoints,2:Nlevels+1)	        = ph(1:Npoints,Nlevels:1:-1)  
+    cospstateIN%hgt_matrix                  		= zlev(1:Npoints,Nlevels:1:-1) 
+    cospstateIN%hgt_matrix_half(1:Npoints,Nlevels+1) 	= 0._wp
+    cospstateIN%hgt_matrix_half(1:Npoints,1:Nlevels) 	= zlev_half(1:Npoints,Nlevels:1:-1) 
+
+
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+!
+! 4c) On construit la variable cospIN qui contient les proprietes optiques subcolumn
+! pour COSP. Elle sera essentiellement remplie dans la subroutine subsample_and_optics
+! ou sont appeles SCOPS, PREC_SCOPS et les subroutines qui calculent les signaux
+! simules pour chaque simulateur actif.
+!
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+    call construct_cospIN(cfg,Npoints,Ncolumns,Nlevels,cospIN)
+    cospIN%emsfc_lw  = emsfc_lw
+    if (cfg%Lcloudsat) cospIN%rcfg_cloudsat = rcfg_cloudsat
+
+
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+!
+! 5) Appel de subsample_and_optics : Les champs verticaux doivent etre donnes a
+! l'envers comme pour le remplissage de cospstateIN, c-a-d : (Nlevels:1) = (TOA:SFC)
+!
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+    call subsample_and_optics(cfg, Npoints, Nlevels, Ncolumns, N_HYDRO,overlap,	&
+        		      use_precipitation_fluxes, lidar_ice_type, sd, &
+			      tca(1:Npoints,Nlevels:1:-1), cca(1:Npoints,Nlevels:1:-1), &
+           		      fl_lsrain(1:Npoints,Nlevels:1:-1), &
+			      fl_lssnow(1:Npoints,Nlevels:1:-1), &
+			      fl_lsgrpl(1:Npoints,Nlevels:1:-1), &
+			      fl_ccrain(1:Npoints,Nlevels:1:-1), &
+          		      fl_ccsnow(1:Npoints,Nlevels:1:-1), &
+			      mr_lsliq(1:Npoints,Nlevels:1:-1), &
+			      mr_lsice(1:Npoints,Nlevels:1:-1), &
+			      mr_ccliq(1:Npoints,Nlevels:1:-1), &
+			      mr_ccice(1:Npoints,Nlevels:1:-1), &
+             		      Reff(1:Npoints,Nlevels:1:-1,:), &
+			      dtau_c(1:Npoints,Nlevels:1:-1), &
+			      dtau_s(1:Npoints,Nlevels:1:-1), &
+			      dem_c(1:Npoints,Nlevels:1:-1), &
+			      dem_s(1:Npoints,Nlevels:1:-1), cospstateIN, cospIN)
+
+
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+!
+! 6) On appelle le simulateur COSPv2 
+!
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+      print*,'call simulateur'
+
+cosp_status = COSP_SIMULATOR(cospIN, cospstateIN, cospOUT, 1, Npoints, debug=.false.)
+
+endif ! cosp_init_flag = 1
+
+
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+!
+! 7a) Ecriture des sorties 1: on cree d'abord les fichiers NCDF pour ecrire les sorties
+! en appelant lmdz_cosp_output_open (lors du premier appel de cette interface pour les
+! 2 options d'ecriture), ou sont definis les axes et les caracteristiques
+! des fichiers de sortie avec les diagnostics.
+!
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+    if (debut_cosp) then
+      !$OMP MASTER
+
+        print *, ' Open outpts files and define axis'
+        call lmdz_cosp_output_open(Nlevlmdz, Ncolumns, presnivs, dtime, freq_cosp,       &
+                                   ok_mensuelCOSP, ok_journeCOSP, ok_hfCOSP, ok_all_xml, &
+                                   ecrit_mth, ecrit_day, ecrit_hf, use_vgrid_in,         &
+			           niv_sorties, vgrid_z_in, zlev(1,:))
+
+      !$OMP END MASTER
+      !$OMP BARRIER
+       debut_cosp=.false.
+      endif ! debut_cosp
+
+if (cosp_init_flag .eq. 1) then
+
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+!
+! 7b) Ecriture des sorties 2: le remplissage des fichiers de sortie se fait a chaque
+! appel de cette interface avec une difference entre les 2 options d'ecriture:
+!
+! AVEC xios, on commence a remplir les fichiers de sortie a partir du DEUXIEME
+! appel de cette interface (lorsque cosp_init_flag = 1).
+!
+! SANS xios, on commence a remplir les fichiers de sortie a partir du PREMIER
+! appel de cette interface (lorsque cosp_init_flag = 1).
+!
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+       print *, 'Calling write output'
+        call lmdz_cosp_output_write(Nlevlmdz, Npoints, Ncolumns, itap, dtime, freq_COSP, &
+                                    missing_val, cfg, niv_sorties, cospOUT)
+
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+!
+! 8) On libere la memoire allouee lors de cet appel a l'interface
+!
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+    call destroy_cospIN(cospIN)
+    call destroy_cospstateIN(cospstateIN)
+    call destroy_cosp_outputs(cospOUT) 
+
+endif ! cosp_init_flag = 1
+ 
+end subroutine lmdz_cosp_interface
Index: DZ6/trunk/libf/phylmd/cospv2/lmdz_cosp_output_write_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cospv2/lmdz_cosp_output_write_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,1040 +1,0 @@
-!!!! Abderrahmane Idelkadi aout 2013 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! Module pour definir (au 1er appel) et ecrire les variables dans les fichiers de sortie cosp
-!
-! R.Guzman jan 2019 (mise a jour pour COSPv2)
-! On change le nom du module a "lmdz_cosp_output_write_mod" et celui de la routine a "lmdz_cosp_output_write"
-! pour qu on sache qu il s agit d un module specifique a l implementation de COSP dans LMDZ
-!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-   MODULE lmdz_cosp_output_write_mod
-
-   USE lmdz_cosp_output_mod
-   USE mod_cosp_config, only : R_UNDEF, CLOUDSAT_DBZE_BINS, SR_BINS, PARASOL_NREFL, & 
-                              isccp_histPresCenters,tau_binCenters, LIDAR_NTEMP, & 
-                              LIDAR_PHASE_TEMP,misr_histHgtCenters,numMISRHgtBins, & 
-                              numMODISReffIceBins,reffICE_binCenters, &
-                              numMODISReffLiqBins, reffLIQ_binCenters
-
-   IMPLICIT NONE
-
-   INTEGER, SAVE  :: itau_iocosp
-!$OMP THREADPRIVATE(itau_iocosp)
-   INTEGER, save        :: Nlevout, Ncolout
-!$OMP THREADPRIVATE(Nlevout, Ncolout)
-
-!  INTERFACE histwrite_cosp
-!    MODULE PROCEDURE histwrite2d_cosp,histwrite3d_cosp
-!  END INTERFACE
-
-   CONTAINS
-
-  SUBROUTINE lmdz_cosp_output_write(Nlevlmdz, Npoints, Ncolumns, itap, dtime, freq_COSP, missing_cosp, &
-                                    cfg, Nlvgrid, cospOUT)
-
-
-    USE ioipsl
-    USE time_phylmdz_mod, ONLY: itau_phy, start_time, day_step_phy
-    USE print_control_mod, ONLY: lunout,prt_level
-    USE lmdz_cosp_read_outputkeys, only: cosp_config
-!COSPv2
-  use cosp_kinds, only: wp
-  use mod_cosp,   only: cosp_outputs
-
-    USE wxios, only: wxios_closedef
-    USE lmdz_xios, only: xios_update_calendar, xios_field_is_active
-  IMPLICIT NONE  
-!!! Variables d'entree
-  integer               :: itap, Nlevlmdz, Ncolumns, Npoints, Nlvgrid
-  real                  :: freq_COSP, dtime, missing_val, missing_cosp
-  type(cosp_config)     :: cfg     ! Control outputs
-  type(cosp_outputs)    :: &
-       cospOUT           ! COSP simulator outputs
-
-
-!!! Variables locales
-  integer               :: icl,k,ip
-  logical               :: ok_sync
-  integer               :: itau_wcosp, iff
-  real, dimension(Npoints,PARASOL_NREFL) :: parasolcrefl, Ncref
-
-! Variables locals intermidiaires pour inverser les axes des champs 4D
-! Compatibilite avec sorties CMIP
-  real, dimension(Npoints,Nlvgrid,SR_BINS) :: tmp_fi4da_cfadL, tmp_fi4da_cfadLgr, tmp_fi4da_cfadLatlid
-  real, dimension(Npoints,Nlvgrid,CLOUDSAT_DBZE_BINS) :: tmp_fi4da_cfadR
-  real, dimension(Npoints,numMISRHgtBins,7) :: tmp_fi4da_misr
-
-  missing_val=missing_cosp
-
-  Nlevout = Nlvgrid
-  Ncolout = Ncolumns
-
-! A refaire
-       itau_wcosp = itau_phy + itap + start_time * day_step_phy
-        if (prt_level >= 10) then
-             WRITE(lunout,*)'itau_wcosp, itap, start_time, day_step_phy =', & 
-                             itau_wcosp, itap, start_time, day_step_phy
-        endif
-
-! On le donne a  cosp_output_write_mod pour que les histwrite y aient acces:
-       CALL set_itau_iocosp(itau_wcosp)
-        if (prt_level >= 10) then
-              WRITE(lunout,*)'itau_iocosp =',itau_iocosp
-        endif
-
-    ok_sync = .TRUE.
-    
-!!!! Sorties Calipso
- if (cfg%Lcalipso) then
-
-!   print*,'Appel histwrite2d_cosp'
-   if (cfg%Lcllcalipso) then 
-      where(cospOUT%calipso_cldlayer(:,1) == R_UNDEF) cospOUT%calipso_cldlayer(:,1) = missing_val
-      CALL histwrite2d_cosp(o_cllcalipso,cospOUT%calipso_cldlayer(:,1))
-   endif
-   if (cfg%Lclhcalipso) then 
-      where(cospOUT%calipso_cldlayer(:,3) == R_UNDEF) cospOUT%calipso_cldlayer(:,3) = missing_val
-      CALL histwrite2d_cosp(o_clhcalipso,cospOUT%calipso_cldlayer(:,3))
-   endif
-   if (cfg%Lclmcalipso) then
-      where(cospOUT%calipso_cldlayer(:,2) == R_UNDEF) cospOUT%calipso_cldlayer(:,2) = missing_val
-      CALL histwrite2d_cosp(o_clmcalipso,cospOUT%calipso_cldlayer(:,2)) 
-   endif
-   if (cfg%Lcltcalipso) then
-      where(cospOUT%calipso_cldlayer(:,4) == R_UNDEF) cospOUT%calipso_cldlayer(:,4) = missing_val
-      CALL histwrite2d_cosp(o_cltcalipso,cospOUT%calipso_cldlayer(:,4))
-   endif
-   if (cfg%Lclcalipso) then 
-      where(cospOUT%calipso_lidarcld == R_UNDEF)    cospOUT%calipso_lidarcld = missing_val
-      CALL histwrite3d_cosp(o_clcalipso,cospOUT%calipso_lidarcld,nvert)
-   endif
-   if (cfg%Lclcalipsotmp) then
-      where(cospOUT%calipso_lidarcldtmp(:,:,1) == R_UNDEF) cospOUT%calipso_lidarcldtmp(:,:,1) = missing_val
-      CALL histwrite3d_cosp(o_clcalipsotmp,cospOUT%calipso_lidarcldtmp(:,:,1),nverttemp)
-   endif
-
-   if (cfg%Lcllcalipsoice) then
-      where(cospOUT%calipso_cldlayerphase(:,1,1) == R_UNDEF) cospOUT%calipso_cldlayerphase(:,1,1) = missing_val
-      CALL histwrite2d_cosp(o_cllcalipsoice,cospOUT%calipso_cldlayerphase(:,1,1))
-   endif
-   if (cfg%Lclhcalipsoice) then
-      where(cospOUT%calipso_cldlayerphase(:,3,1) == R_UNDEF) cospOUT%calipso_cldlayerphase(:,3,1) = missing_val 
-      CALL histwrite2d_cosp(o_clhcalipsoice,cospOUT%calipso_cldlayerphase(:,3,1))
-   endif
-   if (cfg%Lclmcalipsoice) then
-      where(cospOUT%calipso_cldlayerphase(:,2,1) == R_UNDEF) cospOUT%calipso_cldlayerphase(:,2,1) = missing_val
-      CALL histwrite2d_cosp(o_clmcalipsoice,cospOUT%calipso_cldlayerphase(:,2,1))
-   endif
-   if (cfg%Lcltcalipsoice) then
-      where(cospOUT%calipso_cldlayerphase(:,4,1) == R_UNDEF) cospOUT%calipso_cldlayerphase(:,4,1) = missing_val
-      CALL histwrite2d_cosp(o_cltcalipsoice,cospOUT%calipso_cldlayerphase(:,4,1))
-   endif
-   if (cfg%Lclcalipsoice) then 
-      where(cospOUT%calipso_lidarcldphase(:,:,1) == R_UNDEF) cospOUT%calipso_lidarcldphase(:,:,1) = missing_val
-      CALL histwrite3d_cosp(o_clcalipsoice,cospOUT%calipso_lidarcldphase(:,:,1),nvert)
-   endif
-   if (cfg%Lclcalipsotmpice) then
-      where(cospOUT%calipso_lidarcldtmp(:,:,2) == R_UNDEF) cospOUT%calipso_lidarcldtmp(:,:,2) = missing_val
-      CALL histwrite3d_cosp(o_clcalipsotmpice,cospOUT%calipso_lidarcldtmp(:,:,2),nverttemp)
-   endif
-
-   if (cfg%Lcllcalipsoliq) then
-      where(cospOUT%calipso_cldlayerphase(:,1,2) == R_UNDEF) cospOUT%calipso_cldlayerphase(:,1,2) = missing_val
-      CALL histwrite2d_cosp(o_cllcalipsoliq,cospOUT%calipso_cldlayerphase(:,1,2))
-   endif
-   if (cfg%Lclhcalipsoliq) then 
-      where(cospOUT%calipso_cldlayerphase(:,3,2) == R_UNDEF) cospOUT%calipso_cldlayerphase(:,3,2) = missing_val
-      CALL histwrite2d_cosp(o_clhcalipsoliq,cospOUT%calipso_cldlayerphase(:,3,2))
-   endif
-   if (cfg%Lclmcalipsoliq) then 
-      where(cospOUT%calipso_cldlayerphase(:,2,2) == R_UNDEF) cospOUT%calipso_cldlayerphase(:,2,2) = missing_val
-      CALL histwrite2d_cosp(o_clmcalipsoliq,cospOUT%calipso_cldlayerphase(:,2,2))
-   endif
-   if (cfg%Lcltcalipsoliq) then
-      where(cospOUT%calipso_cldlayerphase(:,4,2) == R_UNDEF) cospOUT%calipso_cldlayerphase(:,4,2) = missing_val
-      CALL histwrite2d_cosp(o_cltcalipsoliq,cospOUT%calipso_cldlayerphase(:,4,2))
-   endif
-   if (cfg%Lclcalipsoliq) then
-      where(cospOUT%calipso_lidarcldphase(:,:,2) == R_UNDEF) cospOUT%calipso_lidarcldphase(:,:,2) = missing_val
-      CALL histwrite3d_cosp(o_clcalipsoliq,cospOUT%calipso_lidarcldphase(:,:,2),nvert)
-   endif
-   if (cfg%Lclcalipsotmpliq) then
-      where(cospOUT%calipso_lidarcldtmp(:,:,3) == R_UNDEF) cospOUT%calipso_lidarcldtmp(:,:,3) = missing_val
-      CALL histwrite3d_cosp(o_clcalipsotmpliq,cospOUT%calipso_lidarcldtmp(:,:,3),nverttemp)
-   endif
-   if (cfg%Lcllcalipsoun) then
-      where(cospOUT%calipso_cldlayerphase(:,1,3) == R_UNDEF) cospOUT%calipso_cldlayerphase(:,1,3) = missing_val
-      CALL histwrite2d_cosp(o_cllcalipsoun,cospOUT%calipso_cldlayerphase(:,1,3))
-   endif 
-   if (cfg%Lclhcalipsoun) then
-      where(cospOUT%calipso_cldlayerphase(:,3,3) == R_UNDEF) cospOUT%calipso_cldlayerphase(:,3,3) = missing_val
-      CALL histwrite2d_cosp(o_clhcalipsoun,cospOUT%calipso_cldlayerphase(:,3,3))
-   endif
-   if (cfg%Lclmcalipsoun) then 
-      where(cospOUT%calipso_cldlayerphase(:,2,3) == R_UNDEF) cospOUT%calipso_cldlayerphase(:,2,3) = missing_val
-      CALL histwrite2d_cosp(o_clmcalipsoun,cospOUT%calipso_cldlayerphase(:,2,3))
-   endif
-   if (cfg%Lcltcalipsoun) then
-      where(cospOUT%calipso_cldlayerphase(:,4,3) == R_UNDEF) cospOUT%calipso_cldlayerphase(:,4,3) = missing_val
-      CALL histwrite2d_cosp(o_cltcalipsoun,cospOUT%calipso_cldlayerphase(:,4,3))
-   endif
-   if (cfg%Lclcalipsoun) then 
-      where(cospOUT%calipso_lidarcldphase(:,:,3) == R_UNDEF) cospOUT%calipso_lidarcldphase(:,:,3) = missing_val
-      CALL histwrite3d_cosp(o_clcalipsoun,cospOUT%calipso_lidarcldphase(:,:,3),nvert)
-   endif
-   if (cfg%Lclcalipsotmpun) then
-      where(cospOUT%calipso_lidarcldtmp(:,:,4) == R_UNDEF) cospOUT%calipso_lidarcldtmp(:,:,4) = missing_val
-      CALL histwrite3d_cosp(o_clcalipsotmpun,cospOUT%calipso_lidarcldtmp(:,:,4),nverttemp)
-   endif
-
-   if (cfg%Lclopaquecalipso) then 
-      where(cospOUT%calipso_cldtype(:,1) == R_UNDEF) cospOUT%calipso_cldtype(:,1) = missing_val
-      CALL histwrite2d_cosp(o_clopaquecalipso,cospOUT%calipso_cldtype(:,1))
-   endif
-   if (cfg%Lclthincalipso) then
-      where(cospOUT%calipso_cldtype(:,2) == R_UNDEF) cospOUT%calipso_cldtype(:,2) = missing_val
-      CALL histwrite2d_cosp(o_clthincalipso,cospOUT%calipso_cldtype(:,2))   
-   endif
-   if (cfg%Lclzopaquecalipso) then
-      where(cospOUT%calipso_cldtype(:,3) == R_UNDEF) cospOUT%calipso_cldtype(:,3) = missing_val      
-      CALL histwrite2d_cosp(o_clzopaquecalipso,cospOUT%calipso_cldtype(:,3))
-   endif
-   if (cfg%Lclcalipsoopaque) then
-      where(cospOUT%calipso_lidarcldtype(:,:,1) == R_UNDEF) cospOUT%calipso_lidarcldtype(:,:,1) = missing_val      
-      CALL histwrite3d_cosp(o_clcalipsoopaque,cospOUT%calipso_lidarcldtype(:,:,1),nvert)
-   endif
-   if (cfg%Lclcalipsothin) then
-      where(cospOUT%calipso_lidarcldtype(:,:,2) == R_UNDEF) cospOUT%calipso_lidarcldtype(:,:,2) = missing_val
-      CALL histwrite3d_cosp(o_clcalipsothin,cospOUT%calipso_lidarcldtype(:,:,2),nvert)  
-   endif
-   if (cfg%Lclcalipsozopaque) then
-      where(cospOUT%calipso_lidarcldtype(:,:,3) == R_UNDEF) cospOUT%calipso_lidarcldtype(:,:,3) = missing_val
-      CALL histwrite3d_cosp(o_clcalipsozopaque,cospOUT%calipso_lidarcldtype(:,:,3),nvert)
-   endif
-   if (cfg%Lclcalipsoopacity) then
-      where(cospOUT%calipso_lidarcldtype(:,:,4) == R_UNDEF) cospOUT%calipso_lidarcldtype(:,:,4) = missing_val
-      CALL histwrite3d_cosp(o_clcalipsoopacity,cospOUT%calipso_lidarcldtype(:,:,4),nvert)
-   endif
-
-   if (cfg%Lclopaquetemp) then 
-      where(cospOUT%calipso_cldtypetemp(:,1) == R_UNDEF) cospOUT%calipso_cldtypetemp(:,1) = missing_val
-      CALL histwrite2d_cosp(o_clopaquetemp,cospOUT%calipso_cldtypetemp(:,1))
-   endif
-   if (cfg%Lclthintemp) then 
-      where(cospOUT%calipso_cldtypetemp(:,2) == R_UNDEF) cospOUT%calipso_cldtypetemp(:,2) = missing_val
-      CALL histwrite2d_cosp(o_clthintemp,cospOUT%calipso_cldtypetemp(:,2))
-   endif 
-   if (cfg%Lclzopaquetemp) then
-      where(cospOUT%calipso_cldtypetemp(:,3) == R_UNDEF) cospOUT%calipso_cldtypetemp(:,3) = missing_val
-      CALL histwrite2d_cosp(o_clzopaquetemp,cospOUT%calipso_cldtypetemp(:,3))
-   endif
-   if (cfg%Lclopaquemeanz) then
-      where(cospOUT%calipso_cldtypemeanz(:,1) == R_UNDEF) cospOUT%calipso_cldtypemeanz(:,1) = missing_val
-      CALL histwrite2d_cosp(o_clopaquemeanz,cospOUT%calipso_cldtypemeanz(:,1))
-   endif
-   if (cfg%Lclthinmeanz) then
-      where(cospOUT%calipso_cldtypemeanz(:,2) == R_UNDEF) cospOUT%calipso_cldtypemeanz(:,2) = missing_val
-      CALL histwrite2d_cosp(o_clthinmeanz,cospOUT%calipso_cldtypemeanz(:,2))
-   endif
-   if (cfg%Lclthinemis) then 
-      where(cospOUT%calipso_cldthinemis == R_UNDEF) cospOUT%calipso_cldthinemis = missing_val
-      CALL histwrite2d_cosp(o_clthinemis,cospOUT%calipso_cldthinemis)
-   endif
-   if (cfg%Lclopaquemeanzse) then
-      where(cospOUT%calipso_cldtypemeanzse(:,1) == R_UNDEF) cospOUT%calipso_cldtypemeanzse(:,1) = missing_val
-      CALL histwrite2d_cosp(o_clopaquemeanzse,cospOUT%calipso_cldtypemeanzse(:,1))
-   endif
-   if (cfg%Lclthinmeanzse) then
-      where(cospOUT%calipso_cldtypemeanzse(:,2) == R_UNDEF) cospOUT%calipso_cldtypemeanzse(:,2) = missing_val
-      CALL histwrite2d_cosp(o_clthinmeanzse,cospOUT%calipso_cldtypemeanzse(:,2))
-   endif
-   if (cfg%Lclzopaquecalipsose) then 
-      where(cospOUT%calipso_cldtypemeanzse(:,3) == R_UNDEF) cospOUT%calipso_cldtypemeanzse(:,3) = missing_val
-      CALL histwrite2d_cosp(o_clzopaquecalipsose,cospOUT%calipso_cldtypemeanzse(:,3))
-   endif
-
-
-   if (cfg%LcfadLidarsr532) then 
-     where(cospOUT%calipso_cfad_sr == R_UNDEF) cospOUT%calipso_cfad_sr = missing_val
-    
-     do icl=1,SR_BINS
-      do k=1,Nlvgrid
-       do ip=1,Npoints
-        tmp_fi4da_cfadL(ip,k,icl)=cospOUT%calipso_cfad_sr(ip,icl,k)
-       enddo
-      enddo
-     enddo
-!   if (cfg%LcfadLidarsr532) CALL histwrite4d_cosp(o_cfad_lidarsr532,stlidar%cfad_sr)
-    CALL histwrite4d_cosp(o_cfadLidarsr532,tmp_fi4da_cfadL)   !!! "_" enleve
-   endif
-
-   if (cfg%Latb532) then  
-     where(cospOUT%calipso_beta_tot == R_UNDEF) cospOUT%calipso_beta_tot = missing_val
-     CALL histwrite4d_cosp(o_atb532,cospOUT%calipso_beta_tot)
-   endif
-   if (cfg%LlidarBetaMol532) then 
-     where(cospOUT%calipso_beta_mol == R_UNDEF) cospOUT%calipso_beta_mol = missing_val
-     CALL histwrite3d_cosp(o_lidarBetaMol532,cospOUT%calipso_beta_mol,nvertmcosp) 
-   endif
-
- endif !Calipso
-
-
-!!!! Sorties Ground Lidar
- if (cfg%LgrLidar532) then
-! AI juin 2020 Voir a quoi correspond ce champs
-!   where(cospOUT%grLidar532_srbval == R_UNDEF) cospOUT%grLidar532_srbval = missing_val
-
-   if (cfg%LcllgrLidar532) then
-      where(cospOUT%grLidar532_cldlayer(:,1) == R_UNDEF) cospOUT%grLidar532_cldlayer(:,1) = missing_val
-      CALL histwrite2d_cosp(o_cllgrLidar532,cospOUT%grLidar532_cldlayer(:,1))
-   endif
-   if (cfg%LclmgrLidar532) then
-      where(cospOUT%grLidar532_cldlayer(:,2) == R_UNDEF) cospOUT%grLidar532_cldlayer(:,2) = missing_val
-      CALL histwrite2d_cosp(o_clmgrLidar532,cospOUT%grLidar532_cldlayer(:,2))
-   endif
-   if (cfg%LclhgrLidar532) then
-      where(cospOUT%grLidar532_cldlayer(:,3) == R_UNDEF) cospOUT%grLidar532_cldlayer(:,3) = missing_val
-      CALL histwrite2d_cosp(o_clhgrLidar532,cospOUT%grLidar532_cldlayer(:,3))
-   endif
-   if (cfg%LcltgrLidar532) then
-      where(cospOUT%grLidar532_cldlayer(:,4) == R_UNDEF) cospOUT%grLidar532_cldlayer(:,4) = missing_val
-      CALL histwrite2d_cosp(o_cltgrLidar532,cospOUT%grLidar532_cldlayer(:,4))
-   endif
-
-   if (cfg%LclgrLidar532) then
-       where(cospOUT%grLidar532_lidarcld == R_UNDEF) cospOUT%grLidar532_lidarcld = missing_val
-      CALL histwrite3d_cosp(o_clgrLidar532,cospOUT%grLidar532_lidarcld,nvert)
-   endif
-   if (cfg%LlidarBetaMol532gr) then
-      where(cospOUT%grLidar532_beta_mol == R_UNDEF) cospOUT%grLidar532_beta_mol = missing_val
-      CALL histwrite3d_cosp(o_lidarBetaMol532gr,cospOUT%grLidar532_beta_mol,nvertmcosp) 
-   endif
-   if (cfg%LcfadLidarsr532gr) then
-     where(cospOUT%grLidar532_cfad_sr == R_UNDEF) cospOUT%grLidar532_cfad_sr = missing_val
-     do icl=1,SR_BINS
-      do k=1,Nlvgrid
-       do ip=1,Npoints
-         tmp_fi4da_cfadLgr(ip,k,icl)=cospOUT%grLidar532_cfad_sr(ip,icl,k)
-       enddo
-      enddo
-     enddo
-     CALL histwrite4d_cosp(o_cfadLidarsr532gr,tmp_fi4da_cfadLgr)
-   endif
-
-   if (cfg%Latb532gr) then
-      where(cospOUT%grLidar532_beta_tot == R_UNDEF) cospOUT%grLidar532_beta_tot = missing_val
-      CALL histwrite4d_cosp(o_atb532gr,cospOUT%grLidar532_beta_tot)
-   endif
-endif ! Ground Lidar 532 nm
-
-
-!!!! Sorties Atlid
- if (cfg%Latlid) then
-! AI juin 2020 Voir a quoi correspond ce champs
-!   where(cospOUT%atlid_srbval == R_UNDEF) cospOUT%atlid_srbval = missing_val
-
-   if (cfg%Lcllatlid) then 
-      where(cospOUT%atlid_cldlayer(:,1) == R_UNDEF) cospOUT%atlid_cldlayer(:,1) = missing_val
-      CALL histwrite2d_cosp(o_cllatlid,cospOUT%atlid_cldlayer(:,1))
-   endif
-   if (cfg%Lclmatlid) then
-      where(cospOUT%atlid_cldlayer(:,2) == R_UNDEF) cospOUT%atlid_cldlayer(:,2) = missing_val
-      CALL histwrite2d_cosp(o_clmatlid,cospOUT%atlid_cldlayer(:,2))
-   endif
-   if (cfg%Lclhatlid) then
-      where(cospOUT%atlid_cldlayer(:,3) == R_UNDEF) cospOUT%atlid_cldlayer(:,3) = missing_val
-      CALL histwrite2d_cosp(o_clhatlid,cospOUT%atlid_cldlayer(:,3))
-   endif
-   if (cfg%Lcltatlid) then
-      where(cospOUT%atlid_cldlayer(:,4) == R_UNDEF) cospOUT%atlid_cldlayer(:,4) = missing_val
-      CALL histwrite2d_cosp(o_cltatlid,cospOUT%atlid_cldlayer(:,4))
-   endif
-   if (cfg%Lclatlid) then
-      where(cospOUT%atlid_lidarcld == R_UNDEF) cospOUT%atlid_lidarcld = missing_val
-      CALL histwrite3d_cosp(o_clatlid,cospOUT%atlid_lidarcld,nvert)
-   endif
-   if (cfg%LlidarBetaMol355) then
-      where(cospOUT%atlid_beta_mol == R_UNDEF) cospOUT%atlid_beta_mol = missing_val
-      CALL histwrite3d_cosp(o_lidarBetaMol355,cospOUT%atlid_beta_mol,nvertmcosp) 
-   endif
-   if (cfg%LcfadLidarsr355) then
-     where(cospOUT%atlid_cfad_sr == R_UNDEF) cospOUT%atlid_cfad_sr = missing_val
-     do icl=1,SR_BINS
-      do k=1,Nlvgrid
-       do ip=1,Npoints
-          tmp_fi4da_cfadLatlid(ip,k,icl)=cospOUT%atlid_cfad_sr(ip,icl,k)
-       enddo
-      enddo
-     enddo
-     CALL histwrite4d_cosp(o_cfadlidarsr355,tmp_fi4da_cfadLatlid)
-   endif
-
-   if (cfg%Latb355) then
-      where(cospOUT%atlid_beta_tot == R_UNDEF) cospOUT%atlid_beta_tot = missing_val 
-      CALL histwrite4d_cosp(o_atb355,cospOUT%atlid_beta_tot)
-   endif
-endif ! Atlid
-
-
- if (cfg%Lparasol) then
-   if (cfg%LparasolRefl) then
-     where(cospOUT%parasolGrid_refl == R_UNDEF) cospOUT%parasolGrid_refl = missing_val
-     where(cospOUT%parasolPix_refl == R_UNDEF) cospOUT%parasolPix_refl = missing_val
-     CALL histwrite3d_cosp(o_parasolGrid_refl,cospOUT%parasolGrid_refl,nvertp)
-     CALL histwrite4d_cosp(o_parasolPix_refl,cospOUT%parasolPix_refl)
-   endif ! LparasolRefl
- endif ! Parasol
-
-!  if (cfg%LparasolRefl) then 
-!    do k=1,PARASOL_NREFL
-!     do ip=1, Npoints
-!      if (stlidar%cldlayer(ip,4).gt.1.and.stlidar%parasolrefl(ip,k).ne.missing_val) then
-!        parasolcrefl(ip,k)=(stlidar%parasolrefl(ip,k)-0.03*(1.-stlidar%cldlayer(ip,4)/100.))/ &
-!                             (stlidar%cldlayer(ip,4)/100.)
-!         Ncref(ip,k) = 1.
-!      else
-!         parasolcrefl(ip,k)=missing_val
-!         Ncref(ip,k) = 0.
-!      endif
-!     enddo
-!    enddo
-!    CALL histwrite3d_cosp(o_Ncrefl,Ncref,nvertp)
-!    CALL histwrite3d_cosp(o_parasol_crefl,parasolcrefl,nvertp)
-!  endif
-
-
-!!! Sorties CloudSat
- if (cfg%Lcloudsat) then
-! AI juin 2020 voir a quoi correspond ce champs
-!   where(cospOUT%cloudsat_pia == R_UNDEF) cospOUT%cloudsat_pia = missing_val
-
-   if (cfg%Lptradarflag0) then
-     where(cospOUT%cloudsat_precip_cover(:,1) == R_UNDEF) cospOUT%cloudsat_precip_cover(:,1) = missing_val
-     CALL histwrite2d_cosp(o_ptradarflag0,cospOUT%cloudsat_precip_cover(:,1))
-   endif
-   if (cfg%Lptradarflag1) then
-     where(cospOUT%cloudsat_precip_cover(:,2) == R_UNDEF) cospOUT%cloudsat_precip_cover(:,2) = missing_val
-     CALL histwrite2d_cosp(o_ptradarflag1,cospOUT%cloudsat_precip_cover(:,2))
-   endif
-   if (cfg%Lptradarflag2) then
-      where(cospOUT%cloudsat_precip_cover(:,3) == R_UNDEF) cospOUT%cloudsat_precip_cover(:,3) = missing_val
-      CALL histwrite2d_cosp(o_ptradarflag2,cospOUT%cloudsat_precip_cover(:,3))
-   endif
-   if (cfg%Lptradarflag3) then
-      where(cospOUT%cloudsat_precip_cover(:,4) == R_UNDEF) cospOUT%cloudsat_precip_cover(:,4) = missing_val
-      CALL histwrite2d_cosp(o_ptradarflag3,cospOUT%cloudsat_precip_cover(:,4))
-   endif
-   if (cfg%Lptradarflag4) then
-      where(cospOUT%cloudsat_precip_cover(:,5) == R_UNDEF) cospOUT%cloudsat_precip_cover(:,5) = missing_val
-      CALL histwrite2d_cosp(o_ptradarflag3,cospOUT%cloudsat_precip_cover(:,5))
-   endif
-   if (cfg%Lptradarflag5) then
-      where(cospOUT%cloudsat_precip_cover(:,6) == R_UNDEF) cospOUT%cloudsat_precip_cover(:,6) = missing_val
-      CALL histwrite2d_cosp(o_ptradarflag3,cospOUT%cloudsat_precip_cover(:,6))
-   endif
-   if (cfg%Lptradarflag6) then
-      where(cospOUT%cloudsat_precip_cover(:,7) == R_UNDEF) cospOUT%cloudsat_precip_cover(:,7) = missing_val
-      CALL histwrite2d_cosp(o_ptradarflag3,cospOUT%cloudsat_precip_cover(:,7))
-   endif
-   if (cfg%Lptradarflag7) then
-      where(cospOUT%cloudsat_precip_cover(:,8) == R_UNDEF) cospOUT%cloudsat_precip_cover(:,8) = missing_val
-      CALL histwrite2d_cosp(o_ptradarflag3,cospOUT%cloudsat_precip_cover(:,8))
-   endif
-   if (cfg%Lptradarflag8) then
-      where(cospOUT%cloudsat_precip_cover(:,9) == R_UNDEF) cospOUT%cloudsat_precip_cover(:,9) = missing_val
-      CALL histwrite2d_cosp(o_ptradarflag3,cospOUT%cloudsat_precip_cover(:,9))
-   endif
-   if (cfg%Lptradarflag9) then
-      where(cospOUT%cloudsat_precip_cover(:,10) == R_UNDEF) cospOUT%cloudsat_precip_cover(:,10) = missing_val
-      CALL histwrite2d_cosp(o_ptradarflag3,cospOUT%cloudsat_precip_cover(:,10))
-   endif
-
-   if (cfg%Ldbze94) then
-     where(cospOUT%cloudsat_Ze_tot == R_UNDEF) cospOUT%cloudsat_Ze_tot = missing_val 
-     CALL histwrite4d_cosp(o_dbze94,cospOUT%cloudsat_Ze_tot)
-   endif
-   if (cfg%LcfadDbze94)  then
-     where(cospOUT%cloudsat_cfad_ze == R_UNDEF) cospOUT%cloudsat_cfad_ze = missing_val  
-     do icl=1,CLOUDSAT_DBZE_BINS
-      do k=1,Nlvgrid
-       do ip=1,Npoints
-         tmp_fi4da_cfadR(ip,k,icl)=cospOUT%cloudsat_cfad_ze(ip,icl,k)
-       enddo
-      enddo
-     enddo
-     CALL histwrite4d_cosp(o_cfadDbze94,tmp_fi4da_cfadR)
-  endif
- endif
-! endif pour CloudSat
-
-
-!!! Sorties combinees Cloudsat et Calipso
- if (cfg%Lcalipso .and. cfg%Lcloudsat) then
-
-   if (cfg%Lclcalipso2) then
-     where(cospOUT%lidar_only_freq_cloud == R_UNDEF) &
-                           cospOUT%lidar_only_freq_cloud = missing_val
-     CALL histwrite3d_cosp(o_clcalipso2,cospOUT%lidar_only_freq_cloud,nvert)
-   endif
-   if (cfg%Lcloudsat_tcc) then
-     where(cospOUT%cloudsat_tcc == R_UNDEF) &
-                           cospOUT%cloudsat_tcc = missing_val
-     CALL histwrite2d_cosp(o_cloudsat_tcc,cospOUT%cloudsat_tcc)
-   endif
-   if (cfg%Lcloudsat_tcc2) then
-     where(cospOUT%cloudsat_tcc2 == R_UNDEF) &
-                           cospOUT%cloudsat_tcc2 = missing_val
-     CALL histwrite2d_cosp(o_cloudsat_tcc2,cospOUT%cloudsat_tcc2)
-   endif
-   if (cfg%Lcltlidarradar) then
-     where(cospOUT%radar_lidar_tcc == R_UNDEF) &
-                           cospOUT%radar_lidar_tcc = missing_val     
-     CALL histwrite2d_cosp(o_cltlidarradar,cospOUT%radar_lidar_tcc)
-   endif
- endif
-
-
-!!! Sorties Isccp
- if (cfg%Lisccp) then
-  where(cospOUT%isccp_totalcldarea == R_UNDEF) cospOUT%isccp_totalcldarea = missing_val
-  where(cospOUT%isccp_meanptop == R_UNDEF) cospOUT%isccp_meanptop = missing_val
-  where(cospOUT%isccp_meantaucld == R_UNDEF) cospOUT%isccp_meantaucld = missing_val
-  where(cospOUT%isccp_meanalbedocld == R_UNDEF) cospOUT%isccp_meanalbedocld = missing_val
-  where(cospOUT%isccp_meantb == R_UNDEF) cospOUT%isccp_meantb = missing_val
-  where(cospOUT%isccp_meantbclr == R_UNDEF) cospOUT%isccp_meantbclr = missing_val
-  where(cospOUT%isccp_fq == R_UNDEF) cospOUT%isccp_fq = missing_val
-  where(cospOUT%isccp_boxtau == R_UNDEF) cospOUT%isccp_boxtau = missing_val
-  where(cospOUT%isccp_boxptop == R_UNDEF) cospOUT%isccp_boxptop = missing_val 
-
-!   CALL histwrite2d_cosp(o_sunlit,gbx%sunlit)
-  if (cfg%Lclisccp) CALL histwrite4d_cosp(o_clisccp,cospOUT%isccp_fq)
-
-   if (cfg%Lboxtauisccp) CALL histwrite3d_cosp(o_boxtauisccp,cospOUT%isccp_boxtau,nvertcol)
-   if (cfg%Lboxptopisccp) CALL histwrite3d_cosp(o_boxptopisccp,cospOUT%isccp_boxptop,nvertcol) 
-   if (cfg%Lcltisccp) CALL histwrite2d_cosp(o_cltisccp,cospOUT%isccp_totalcldarea) 
-   if (cfg%Lpctisccp) CALL histwrite2d_cosp(o_pctisccp,cospOUT%isccp_meanptop) 
-   if (cfg%Ltauisccp) CALL histwrite2d_cosp(o_tauisccp,cospOUT%isccp_meantaucld) 
-   if (cfg%Lalbisccp) CALL histwrite2d_cosp(o_albisccp,cospOUT%isccp_meanalbedocld) 
-   if (cfg%Lmeantbisccp) CALL histwrite2d_cosp(o_meantbisccp,cospOUT%isccp_meantb) 
-   if (cfg%Lmeantbclrisccp) CALL histwrite2d_cosp(o_meantbclrisccp,cospOUT%isccp_meantbclr)
- endif ! Isccp
-
-
-!!! MISR simulator
- if (cfg%Lmisr) then
-
-   if (cfg%LclMISR) then
-! Ces 3 diagnostics sont controles par la clef logique "LclMISR"
-   where(cospOUT%misr_fq == R_UNDEF) cospOUT%misr_fq = missing_val
-!   where(cospOUT%misr_dist_model_layertops == R_UNDEF) cospOUT%misr_dist_model_layertops = missing_val
-   where(cospOUT%misr_meanztop == R_UNDEF) cospOUT%misr_meanztop = missing_val
-   where(cospOUT%misr_cldarea == R_UNDEF) cospOUT%misr_cldarea = missing_val
-
-   do icl=1,numMISRHgtBins
-      do k=1,Nlvgrid
-       do ip=1,Npoints    
-      tmp_fi4da_misr(ip,icl,k)=cospOUT%misr_fq(ip,k,icl)
-       enddo
-      enddo
-   enddo
-!   if (cfg%LclMISR) CALL histwrite4d_cosp(o_clMISR,misr%fq_MISR)
-!   if (cfg%LclMISR) CALL histwrite4d_cosp(o_clMISR,tmp_fi4da_misr)
-   CALL histwrite4d_cosp(o_misr_fq,tmp_fi4da_misr)
-
-   CALL histwrite2d_cosp(o_misr_meanztop,cospOUT%misr_meanztop) 
-   CALL histwrite2d_cosp(o_misr_cldarea,cospOUT%misr_cldarea) 
-  endif ! LclMISR
-
- endif ! Misr
-
-
-!!! Modis simulator
- if (cfg%Lmodis) then
-  where(cospOUT%modis_Cloud_Fraction_Low_Mean == R_UNDEF) &
-        cospOUT%modis_Cloud_Fraction_Low_Mean = missing_val
-  where(cospOUT%modis_Cloud_Fraction_High_Mean == R_UNDEF) &
-        cospOUT%modis_Cloud_Fraction_High_Mean = missing_val
-  where(cospOUT%modis_Cloud_Fraction_Mid_Mean == R_UNDEF) &
-        cospOUT%modis_Cloud_Fraction_Mid_Mean = missing_val
-  where(cospOUT%modis_Cloud_Fraction_Total_Mean == R_UNDEF) &
-        cospOUT%modis_Cloud_Fraction_Total_Mean = missing_val
-  where(cospOUT%modis_Cloud_Fraction_Water_Mean == R_UNDEF) &
-        cospOUT%modis_Cloud_Fraction_Water_Mean = missing_val
-  where(cospOUT%modis_Cloud_Fraction_Ice_Mean == R_UNDEF) &
-        cospOUT%modis_Cloud_Fraction_Ice_Mean = missing_val
-  where(cospOUT%modis_Optical_Thickness_Total_Mean == R_UNDEF) &
-        cospOUT%modis_Optical_Thickness_Total_Mean = missing_val
-  where(cospOUT%modis_Optical_Thickness_Water_Mean == R_UNDEF) &
-        cospOUT%modis_Optical_Thickness_Water_Mean = missing_val
-  where(cospOUT%modis_Optical_Thickness_Ice_Mean == R_UNDEF) &
-        cospOUT%modis_Optical_Thickness_Ice_Mean = missing_val
-  where(cospOUT%modis_Cloud_Particle_Size_Water_Mean == R_UNDEF) &
-        cospOUT%modis_Cloud_Particle_Size_Water_Mean = missing_val
-  where(cospOUT%modis_Cloud_Particle_Size_Ice_Mean == R_UNDEF) &
-        cospOUT%modis_Cloud_Particle_Size_Ice_Mean = missing_val
-  where(cospOUT%modis_Cloud_Top_Pressure_Total_Mean == R_UNDEF) &
-        cospOUT%modis_Cloud_Top_Pressure_Total_Mean = missing_val
-  where(cospOUT%modis_Liquid_Water_Path_Mean == R_UNDEF) &
-        cospOUT%modis_Liquid_Water_Path_Mean = missing_val 
-  where(cospOUT%modis_Ice_Water_Path_Mean == R_UNDEF) &
-        cospOUT%modis_Ice_Water_Path_Mean = missing_val
-  where(cospOUT%modis_Optical_Thickness_Total_LogMean == R_UNDEF) &
-          cospOUT%modis_Optical_Thickness_Total_LogMean = missing_val
-  where(cospOUT%modis_Optical_Thickness_Water_LogMean == R_UNDEF) &
-          cospOUT%modis_Optical_Thickness_Water_LogMean = missing_val
-  where(cospOUT%modis_Optical_Thickness_Ice_LogMean == R_UNDEF) &
-          cospOUT%modis_Optical_Thickness_Ice_LogMean = missing_val
-    
-  if (cfg%Lcllmodis) CALL histwrite2d_cosp(o_cllmodis,cospOUT%modis_Cloud_Fraction_Low_Mean)
-  if (cfg%Lclhmodis) CALL histwrite2d_cosp(o_clhmodis,cospOUT%modis_Cloud_Fraction_High_Mean)
-  if (cfg%Lclmmodis) CALL histwrite2d_cosp(o_clmmodis,cospOUT%modis_Cloud_Fraction_Mid_Mean)
-  if (cfg%Lcltmodis) CALL histwrite2d_cosp(o_cltmodis,cospOUT%modis_Cloud_Fraction_Total_Mean)
-  if (cfg%Lclwmodis) CALL histwrite2d_cosp(o_clwmodis,cospOUT%modis_Cloud_Fraction_Water_Mean)
-  if (cfg%Lclimodis) CALL histwrite2d_cosp(o_climodis,cospOUT%modis_Cloud_Fraction_Ice_Mean)
-  if (cfg%Ltautmodis) CALL histwrite2d_cosp(o_tautmodis,cospOUT%modis_Optical_Thickness_Total_Mean)
-  if (cfg%Ltauwmodis) CALL histwrite2d_cosp(o_tauwmodis,cospOUT%modis_Optical_Thickness_Water_Mean)
-  if (cfg%Ltauimodis) CALL histwrite2d_cosp(o_tauimodis,cospOUT%modis_Optical_Thickness_Ice_Mean)
-  if (cfg%Ltautlogmodis) CALL histwrite2d_cosp(o_tautlogmodis,cospOUT%modis_Optical_Thickness_Total_LogMean)  
-  if (cfg%Ltauwlogmodis) CALL histwrite2d_cosp(o_tauwlogmodis,cospOUT%modis_Optical_Thickness_Water_LogMean)
-  if (cfg%Ltauilogmodis) CALL histwrite2d_cosp(o_tauilogmodis,cospOUT%modis_Optical_Thickness_Ice_LogMean)
-  if (cfg%Lreffclwmodis) CALL histwrite2d_cosp(o_reffclwmodis,cospOUT%modis_Cloud_Particle_Size_Water_Mean)
-  if (cfg%Lreffclimodis) CALL histwrite2d_cosp(o_reffclimodis,cospOUT%modis_Cloud_Particle_Size_Ice_Mean)
-  if (cfg%Lpctmodis) CALL histwrite2d_cosp(o_pctmodis,cospOUT%modis_Cloud_Top_Pressure_Total_Mean)
-  if (cfg%Llwpmodis) CALL histwrite2d_cosp(o_lwpmodis,cospOUT%modis_Liquid_Water_Path_Mean)
-  if (cfg%Liwpmodis) CALL histwrite2d_cosp(o_iwpmodis,cospOUT%modis_Ice_Water_Path_Mean)
-
-  if (cfg%Lclmodis) then
-! Ces 3 diagnostics sont controles par la clef logique "Lclmodis"
-    where(cospOUT%modis_Optical_Thickness_vs_Cloud_Top_Pressure == R_UNDEF) &
-          cospOUT%modis_Optical_Thickness_vs_Cloud_Top_Pressure = missing_val
-    where(cospOUT%modis_Optical_Thickness_vs_ReffICE == R_UNDEF) &
-          cospOUT%modis_Optical_Thickness_vs_ReffICE = missing_val
-    where(cospOUT%modis_Optical_thickness_vs_ReffLIQ == R_UNDEF) &
-          cospOUT%modis_Optical_thickness_vs_ReffLIQ = missing_val
-
-    CALL histwrite4d_cosp(o_modis_ot_vs_ctp,cospOUT%modis_Optical_Thickness_vs_Cloud_Top_Pressure)
-    CALL histwrite4d_cosp(o_modis_ot_vs_reffice,cospOUT%modis_Optical_Thickness_vs_ReffICE)
-    CALL histwrite4d_cosp(o_modis_ot_vs_reffliq,cospOUT%modis_Optical_thickness_vs_ReffLIQ)
-
-  endif ! Lclmodis
-
- endif !modis
-
-
- IF(.NOT.cosp_varsdefined) THEN
-!$OMP MASTER
-! Fermeture dans phys_output_write
-!#ifdef 1
-            !On finalise l'initialisation:
-            !CALL wxios_closedef()
-!#endif
-
-!$OMP END MASTER
-!$OMP BARRIER
-            cosp_varsdefined = .TRUE.
- END IF
-
-    IF(cosp_varsdefined) THEN
-! On synchronise les fichiers pour IOIPSL
-    ENDIF  !cosp_varsdefined
-
-    END SUBROUTINE lmdz_cosp_output_write
-
-
-! ug Routine pour definir itau_iocosp depuis cosp_output_write_mod:
-  SUBROUTINE set_itau_iocosp(ito)
-      IMPLICIT NONE
-      INTEGER, INTENT(IN) :: ito
-      itau_iocosp = ito
-  END SUBROUTINE
-
-  SUBROUTINE histdef2d_cosp (iff,var)
-
-    USE ioipsl
-    USE dimphy
-    use iophy
-    USE mod_phys_lmdz_para
-    USE mod_grid_phy_lmdz, ONLY: nbp_lon
-    USE print_control_mod, ONLY: lunout,prt_level
-  USE wxios
-
-    IMPLICIT NONE
-
-    INCLUDE "clesphys.h"
-
-    INTEGER                          :: iff
-    TYPE(ctrl_outcosp)               :: var
-
-    REAL zstophym
-    CHARACTER(LEN=20) :: typeecrit
-
-    ! ug On rÃ©cupÃ¨re le type Ã©crit de la structure:
-    !       Assez moche, Ã|  refaire si meilleure mÃ©thode...
-    IF (INDEX(var%cosp_typeecrit(iff), "once") > 0) THEN
-       typeecrit = 'once'
-    ELSE IF(INDEX(var%cosp_typeecrit(iff), "t_min") > 0) THEN
-       typeecrit = 't_min(X)'
-    ELSE IF(INDEX(var%cosp_typeecrit(iff), "t_max") > 0) THEN
-       typeecrit = 't_max(X)'
-    ELSE IF(INDEX(var%cosp_typeecrit(iff), "inst") > 0) THEN
-       typeecrit = 'inst(X)'
-    ELSE
-       typeecrit = cosp_outfiletypes(iff)
-    ENDIF
-
-    IF (typeecrit=='inst(X)'.OR.typeecrit=='once') THEN
-       zstophym=zoutm_cosp(iff)
-    ELSE
-       zstophym=zdtimemoy_cosp
-    ENDIF
-
-     IF (.not. ok_all_xml) then
-       IF ( var%cles(iff) ) THEN
-         if (prt_level >= 10) then
-              WRITE(lunout,*)'Appel wxios_add_field_to_file var%name =',var%name 
-         endif
-        CALL wxios_add_field_to_file(var%name, 2, cosp_nidfiles(iff), cosp_outfilenames(iff), &
-                                     var%description, var%unit, 1, typeecrit)
-       ENDIF
-     ENDIF
-
-
-  END SUBROUTINE histdef2d_cosp
-
-
- SUBROUTINE histdef3d_cosp (iff,var,nvertsave,ncols)
-    USE ioipsl
-    USE dimphy
-    use iophy
-    USE mod_phys_lmdz_para
-    USE mod_grid_phy_lmdz, ONLY: nbp_lon
-    USE print_control_mod, ONLY: lunout,prt_level
-
-  USE wxios
-
-
-    IMPLICIT NONE
-
-    INCLUDE "clesphys.h"
-
-    INTEGER                        :: iff, klevs
-    INTEGER, INTENT(IN), OPTIONAL  :: ncols ! ug RUSTINE POUR LES variables 4D
-    INTEGER, INTENT(IN)           :: nvertsave
-    TYPE(ctrl_outcosp)             :: var
-
-    REAL zstophym
-    CHARACTER(LEN=20) :: typeecrit, nomi
-    CHARACTER(LEN=20) :: nom
-    character(len=2) :: str2
-    CHARACTER(len=20) :: nam_axvert
-
-! Axe vertical
-      IF (nvertsave.eq.nvertp(iff)) THEN
-          klevs=PARASOL_NREFL
-          nam_axvert="sza"
-      ELSE IF (nvertsave.eq.nvertisccp(iff)) THEN
-          klevs=7
-          nam_axvert="pressure2"
-      ELSE IF (nvertsave.eq.nvertcol(iff)) THEN
-          klevs=Ncolout
-          nam_axvert="column"
-      ELSE IF (nvertsave.eq.nverttemp(iff)) THEN
-          klevs=LIDAR_NTEMP
-          nam_axvert="temp"
-      ELSE IF (nvertsave.eq.nvertmisr(iff)) THEN
-          klevs=numMISRHgtBins
-          nam_axvert="cth16"
-      ELSE IF (nvertsave.eq.nvertReffIce(iff)) THEN
-          klevs= numMODISReffIceBins
-          nam_axvert="ReffIce"
-      ELSE IF (nvertsave.eq.nvertReffLiq(iff)) THEN
-          klevs= numMODISReffLiqBins
-          nam_axvert="ReffLiq"
-      ELSE
-           klevs=Nlevout
-           nam_axvert="presnivs"
-      ENDIF
-
-! ug RUSTINE POUR LES Champs 4D
-      IF (PRESENT(ncols)) THEN
-               write(str2,'(i2.2)')ncols
-               nomi=var%name
-               nom="c"//str2//"_"//nomi
-      ELSE
-               nom=var%name
-      END IF
-
-    ! ug On rÃ©cupÃ¨re le type Ã©crit de la structure:
-    !       Assez moche, Ã|  refaire si meilleure mÃ©thode...
-    IF (INDEX(var%cosp_typeecrit(iff), "once") > 0) THEN
-       typeecrit = 'once'
-    ELSE IF(INDEX(var%cosp_typeecrit(iff), "t_min") > 0) THEN
-       typeecrit = 't_min(X)'
-    ELSE IF(INDEX(var%cosp_typeecrit(iff), "t_max") > 0) THEN
-       typeecrit = 't_max(X)'
-    ELSE IF(INDEX(var%cosp_typeecrit(iff), "inst") > 0) THEN
-       typeecrit = 'inst(X)'
-    ELSE
-       typeecrit = cosp_outfiletypes(iff)
-    ENDIF
-
-    IF (typeecrit=='inst(X)'.OR.typeecrit=='once') THEN
-       zstophym=zoutm_cosp(iff)
-    ELSE
-       zstophym=zdtimemoy_cosp
-    ENDIF
-
-      IF (.not. ok_all_xml) then
-        IF ( var%cles(iff) ) THEN
-          if (prt_level >= 10) then
-              WRITE(lunout,*)'Appel wxios_add_field_to_file 3d nom variable nam_axvert = ',nom, nam_axvert 
-          endif
-          CALL wxios_add_field_to_file(nom, 3, cosp_nidfiles(iff), cosp_outfilenames(iff), &
-                                       var%description, var%unit, 1, typeecrit, nam_axvert)
-        ENDIF
-      ENDIF
-
-
-  END SUBROUTINE histdef3d_cosp
-
-
- SUBROUTINE histwrite2d_cosp(var,field)
-  USE dimphy
-  USE mod_phys_lmdz_para
-  USE ioipsl
-  use iophy
-  USE mod_grid_phy_lmdz, ONLY: nbp_lon
-  USE print_control_mod, ONLY: lunout,prt_level
-
-  USE lmdz_xios, only: xios_send_field
-
-  IMPLICIT NONE
-  INCLUDE 'clesphys.h'
-
-    TYPE(ctrl_outcosp), INTENT(IN) :: var
-    REAL, DIMENSION(:), INTENT(IN) :: field
-
-    INTEGER :: iff
-
-    REAL,DIMENSION(klon_mpi) :: buffer_omp
-    INTEGER, allocatable, DIMENSION(:) :: index2d
-    REAL :: Field2d(nbp_lon,jj_nb)
-    CHARACTER(LEN=20) ::  nomi, nom
-    character(len=2) :: str2
-    LOGICAL, SAVE  :: firstx
-!$OMP THREADPRIVATE(firstx)
-
-    IF (prt_level >= 9) WRITE(lunout,*)'Begin histrwrite2d ',var%name
-
-  ! On regarde si on est dans la phase de dÃ©finition ou d'Ã©criture:
-  IF(.NOT.cosp_varsdefined) THEN
-!$OMP MASTER
-      print*,'var, cosp_varsdefined dans cosp_varsdefined ',var%name, cosp_varsdefined
-      !Si phase de dÃ©finition.... on dÃ©finit
-      CALL conf_cospoutputs(var%name,var%cles)
-      DO iff=1, 3
-         IF (cosp_outfilekeys(iff)) THEN
-            CALL histdef2d_cosp(iff, var)
-         ENDIF
-      ENDDO
-!$OMP END MASTER
-  ELSE
-    !Et sinon on.... Ã©crit
-    IF (SIZE(field)/=klon) &
-  CALL abort_physic('iophy::histwrite2d_cosp','Field first DIMENSION not equal to klon',1) 
-
-    CALL Gather_omp(field,buffer_omp)
-!$OMP MASTER
-    CALL grid1Dto2D_mpi(buffer_omp,Field2d)
-
-! La boucle sur les fichiers:
-      firstx=.true.
-      DO iff=1, 3
-           IF (var%cles(iff) .AND. cosp_outfilekeys(iff)) THEN
-                ALLOCATE(index2d(nbp_lon*jj_nb))
-                deallocate(index2d)
-              IF (.not. ok_all_xml) then
-                 if (firstx) then
-                  if (prt_level >= 10) then
-                    WRITE(lunout,*)'xios_send_field variable ',var%name
-                  endif
-                  CALL xios_send_field(var%name, Field2d)
-                   firstx=.false.
-                 endif
-              ENDIF
-           ENDIF
-      ENDDO 
-
-      IF (ok_all_xml) THEN
-        if (prt_level >= 1) then
-              WRITE(lunout,*)'xios_send_field variable ',var%name
-        endif
-       CALL xios_send_field(var%name, Field2d)
-      ENDIF
-
-!$OMP END MASTER   
-  ENDIF ! vars_defined
-  IF (prt_level >= 9) WRITE(lunout,*)'End histrwrite2d_cosp ',var%name
-  END SUBROUTINE histwrite2d_cosp
-
-
-! ug NOUVELLE VERSION DES WRITE AVEC LA BOUCLE DO RENTREE
-! AI sept 2013
-  SUBROUTINE histwrite3d_cosp(var, field, nverts, ncols)
-  USE dimphy
-  USE mod_phys_lmdz_para
-  USE ioipsl
-  use iophy
-  USE mod_grid_phy_lmdz, ONLY: nbp_lon
-  USE print_control_mod, ONLY: lunout,prt_level
-
-  USE lmdz_xios, only: xios_send_field
-
-
-  IMPLICIT NONE
-  INCLUDE 'clesphys.h'
-
-    TYPE(ctrl_outcosp), INTENT(IN)    :: var
-    REAL, DIMENSION(:,:), INTENT(IN)  :: field ! --> field(klon,:)
-    INTEGER, INTENT(IN), OPTIONAL     :: ncols ! ug RUSTINE POUR LES Champs 4D.....
-    INTEGER, DIMENSION(3), INTENT(IN) :: nverts
-
-    INTEGER :: iff, k
-
-    REAL,DIMENSION(klon_mpi,SIZE(field,2)) :: buffer_omp
-    REAL :: Field3d(nbp_lon,jj_nb,SIZE(field,2))
-    INTEGER :: ip, n, nlev
-    INTEGER, ALLOCATABLE, DIMENSION(:) :: index3d
-    CHARACTER(LEN=20) ::  nomi, nom
-    character(len=2) :: str2
-    LOGICAL, SAVE  :: firstx
-!$OMP THREADPRIVATE(firstx)
-
-  IF (prt_level >= 9) write(lunout,*)'Begin histrwrite3d ',var%name
-
-! ug RUSTINE POUR LES STD LEVS.....
-      IF (PRESENT(ncols)) THEN
-              write(str2,'(i2.2)')ncols
-              nomi=var%name
-              nom="c"//str2//"_"//nomi
-      ELSE
-               nom=var%name
-      END IF
-  ! On regarde si on est dans la phase de dÃ©finition ou d'Ã©criture:
-  IF(.NOT.cosp_varsdefined) THEN
-      !Si phase de dÃ©finition.... on dÃ©finit
-!$OMP MASTER
-      CALL conf_cospoutputs(var%name,var%cles)
-      DO iff=1, 3
-        IF (cosp_outfilekeys(iff)) THEN
-          CALL histdef3d_cosp(iff, var, nverts(iff), ncols)
-        ENDIF
-      ENDDO
-!$OMP END MASTER
-  ELSE
-    !Et sinon on.... Ã©crit
-    IF (SIZE(field,1)/=klon) &
-   CALL abort_physic('iophy::histwrite3d','Field first DIMENSION not equal to klon',1)                                  
-    nlev=SIZE(field,2)
-
-
-    CALL Gather_omp(field,buffer_omp)
-!$OMP MASTER
-    CALL grid1Dto2D_mpi(buffer_omp,field3d)
-
-! BOUCLE SUR LES FICHIERS
-     firstx=.true.
-     DO iff=1, 3
-        IF (var%cles(iff) .AND. cosp_outfilekeys(iff)) THEN
-           ALLOCATE(index3d(nbp_lon*jj_nb*nlev))
-
-          IF (.not. ok_all_xml) then
-           IF (firstx) THEN
-               CALL xios_send_field(nom, Field3d(:,:,1:nlev))
-               IF (prt_level >= 9) WRITE(lunout,*)'xios_send_field ',var%name
-               firstx=.FALSE.
-           ENDIF
-          ENDIF
-         deallocate(index3d)
-        ENDIF
-      ENDDO
-    IF (ok_all_xml) THEN
-     CALL xios_send_field(nom, Field3d(:,:,1:nlev))
-     IF (prt_level >= 1) WRITE(lunout,*)'xios_send_field ',var%name
-    ENDIF
-
-!$OMP END MASTER   
-  ENDIF ! vars_defined
-  IF (prt_level >= 9) write(lunout,*)'End histrwrite3d_cosp ',nom
-  END SUBROUTINE histwrite3d_cosp
-
-
-! ug NOUVELLE VERSION DES WRITE AVEC LA BOUCLE DO RENTREE
-! AI sept 2013
-  SUBROUTINE histwrite4d_cosp(var, field)
-  USE dimphy
-  USE mod_phys_lmdz_para
-  USE ioipsl
-  use iophy
-  USE mod_grid_phy_lmdz, ONLY: nbp_lon
-  USE print_control_mod, ONLY: lunout,prt_level
-
-  USE lmdz_xios, only: xios_send_field
-
-
-  IMPLICIT NONE
-  INCLUDE 'clesphys.h'
-
-    TYPE(ctrl_outcosp), INTENT(IN)    :: var
-    REAL, DIMENSION(:,:,:), INTENT(IN)  :: field ! --> field(klon,:)
-
-    INTEGER :: iff, k
-
-    REAL,DIMENSION(klon_mpi,SIZE(field,2),SIZE(field,3)) :: buffer_omp
-    REAL :: field4d(nbp_lon,jj_nb,SIZE(field,2),SIZE(field,3))
-    INTEGER :: ip, n, nlev, nlev2
-    INTEGER, ALLOCATABLE, DIMENSION(:) :: index4d
-    CHARACTER(LEN=20) ::  nomi, nom
-
-  IF (prt_level >= 9) write(lunout,*)'Begin histrwrite4d ',var%name
-
-  IF(cosp_varsdefined) THEN
-    !Et sinon on.... Ã©crit
-    IF (SIZE(field,1)/=klon) &
-   CALL abort_physic('iophy::histwrite3d','Field first DIMENSION not equal to klon',1)            
-
-    nlev=SIZE(field,2)
-    nlev2=SIZE(field,3)
-    CALL Gather_omp(field,buffer_omp)
-!$OMP MASTER
-    CALL grid1Dto2D_mpi(buffer_omp,field4d)
-
-!    IF (ok_all_xml) THEN
-     CALL xios_send_field(var%name, Field4d(:,:,1:nlev,1:nlev2))
-     IF (prt_level >= 1) WRITE(lunout,*)'xios_send_field ',var%name
-!    ENDIF
-
-!$OMP END MASTER   
-  ENDIF ! vars_defined
-  IF (prt_level >= 9) write(lunout,*)'End histrwrite4d_cosp ',nom
-  END SUBROUTINE histwrite4d_cosp
-
-  SUBROUTINE conf_cospoutputs(nam_var,cles_var)
-!!! Lecture des noms et cles de sortie des variables dans config.def
-    !   en utilisant les routines getin de IOIPSL  
-    use ioipsl
-    USE print_control_mod, ONLY: lunout,prt_level
-
-    IMPLICIT NONE
-
-   CHARACTER(LEN=20)               :: nam_var, nnam_var
-   LOGICAL, DIMENSION(3)           :: cles_var
-
-! Lecture dans config.def ou output.def de cles_var et name_var
-    CALL getin('cles_'//nam_var,cles_var)
-    CALL getin('name_'//nam_var,nam_var)
-    IF(prt_level>10) WRITE(lunout,*)'nam_var cles_var ',nam_var,cles_var(:)
-
-  END SUBROUTINE conf_cospoutputs
-
- END MODULE lmdz_cosp_output_write_mod
Index: /LMDZ6/trunk/libf/phylmd/cospv2/lmdz_cosp_output_write_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cospv2/lmdz_cosp_output_write_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/cospv2/lmdz_cosp_output_write_mod.f90	(revision 5268)
@@ -0,0 +1,1040 @@
+!!!! Abderrahmane Idelkadi aout 2013 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! Module pour definir (au 1er appel) et ecrire les variables dans les fichiers de sortie cosp
+!
+! R.Guzman jan 2019 (mise a jour pour COSPv2)
+! On change le nom du module a "lmdz_cosp_output_write_mod" et celui de la routine a "lmdz_cosp_output_write"
+! pour qu on sache qu il s agit d un module specifique a l implementation de COSP dans LMDZ
+!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+   MODULE lmdz_cosp_output_write_mod
+
+   USE lmdz_cosp_output_mod
+   USE mod_cosp_config, only : R_UNDEF, CLOUDSAT_DBZE_BINS, SR_BINS, PARASOL_NREFL, & 
+                              isccp_histPresCenters,tau_binCenters, LIDAR_NTEMP, & 
+                              LIDAR_PHASE_TEMP,misr_histHgtCenters,numMISRHgtBins, & 
+                              numMODISReffIceBins,reffICE_binCenters, &
+                              numMODISReffLiqBins, reffLIQ_binCenters
+
+   IMPLICIT NONE
+
+   INTEGER, SAVE  :: itau_iocosp
+!$OMP THREADPRIVATE(itau_iocosp)
+   INTEGER, save        :: Nlevout, Ncolout
+!$OMP THREADPRIVATE(Nlevout, Ncolout)
+
+!  INTERFACE histwrite_cosp
+!    MODULE PROCEDURE histwrite2d_cosp,histwrite3d_cosp
+!  END INTERFACE
+
+   CONTAINS
+
+  SUBROUTINE lmdz_cosp_output_write(Nlevlmdz, Npoints, Ncolumns, itap, dtime, freq_COSP, missing_cosp, &
+                                    cfg, Nlvgrid, cospOUT)
+
+
+    USE ioipsl
+    USE time_phylmdz_mod, ONLY: itau_phy, start_time, day_step_phy
+    USE print_control_mod, ONLY: lunout,prt_level
+    USE lmdz_cosp_read_outputkeys, only: cosp_config
+!COSPv2
+  use cosp_kinds, only: wp
+  use mod_cosp,   only: cosp_outputs
+
+    USE wxios, only: wxios_closedef
+    USE lmdz_xios, only: xios_update_calendar, xios_field_is_active
+  IMPLICIT NONE  
+!!! Variables d'entree
+  integer               :: itap, Nlevlmdz, Ncolumns, Npoints, Nlvgrid
+  real                  :: freq_COSP, dtime, missing_val, missing_cosp
+  type(cosp_config)     :: cfg     ! Control outputs
+  type(cosp_outputs)    :: &
+       cospOUT           ! COSP simulator outputs
+
+
+!!! Variables locales
+  integer               :: icl,k,ip
+  logical               :: ok_sync
+  integer               :: itau_wcosp, iff
+  real, dimension(Npoints,PARASOL_NREFL) :: parasolcrefl, Ncref
+
+! Variables locals intermidiaires pour inverser les axes des champs 4D
+! Compatibilite avec sorties CMIP
+  real, dimension(Npoints,Nlvgrid,SR_BINS) :: tmp_fi4da_cfadL, tmp_fi4da_cfadLgr, tmp_fi4da_cfadLatlid
+  real, dimension(Npoints,Nlvgrid,CLOUDSAT_DBZE_BINS) :: tmp_fi4da_cfadR
+  real, dimension(Npoints,numMISRHgtBins,7) :: tmp_fi4da_misr
+
+  missing_val=missing_cosp
+
+  Nlevout = Nlvgrid
+  Ncolout = Ncolumns
+
+! A refaire
+       itau_wcosp = itau_phy + itap + start_time * day_step_phy
+        if (prt_level >= 10) then
+             WRITE(lunout,*)'itau_wcosp, itap, start_time, day_step_phy =', & 
+                             itau_wcosp, itap, start_time, day_step_phy
+        endif
+
+! On le donne a  cosp_output_write_mod pour que les histwrite y aient acces:
+       CALL set_itau_iocosp(itau_wcosp)
+        if (prt_level >= 10) then
+              WRITE(lunout,*)'itau_iocosp =',itau_iocosp
+        endif
+
+    ok_sync = .TRUE.
+    
+!!!! Sorties Calipso
+ if (cfg%Lcalipso) then
+
+!   print*,'Appel histwrite2d_cosp'
+   if (cfg%Lcllcalipso) then 
+      where(cospOUT%calipso_cldlayer(:,1) == R_UNDEF) cospOUT%calipso_cldlayer(:,1) = missing_val
+      CALL histwrite2d_cosp(o_cllcalipso,cospOUT%calipso_cldlayer(:,1))
+   endif
+   if (cfg%Lclhcalipso) then 
+      where(cospOUT%calipso_cldlayer(:,3) == R_UNDEF) cospOUT%calipso_cldlayer(:,3) = missing_val
+      CALL histwrite2d_cosp(o_clhcalipso,cospOUT%calipso_cldlayer(:,3))
+   endif
+   if (cfg%Lclmcalipso) then
+      where(cospOUT%calipso_cldlayer(:,2) == R_UNDEF) cospOUT%calipso_cldlayer(:,2) = missing_val
+      CALL histwrite2d_cosp(o_clmcalipso,cospOUT%calipso_cldlayer(:,2)) 
+   endif
+   if (cfg%Lcltcalipso) then
+      where(cospOUT%calipso_cldlayer(:,4) == R_UNDEF) cospOUT%calipso_cldlayer(:,4) = missing_val
+      CALL histwrite2d_cosp(o_cltcalipso,cospOUT%calipso_cldlayer(:,4))
+   endif
+   if (cfg%Lclcalipso) then 
+      where(cospOUT%calipso_lidarcld == R_UNDEF)    cospOUT%calipso_lidarcld = missing_val
+      CALL histwrite3d_cosp(o_clcalipso,cospOUT%calipso_lidarcld,nvert)
+   endif
+   if (cfg%Lclcalipsotmp) then
+      where(cospOUT%calipso_lidarcldtmp(:,:,1) == R_UNDEF) cospOUT%calipso_lidarcldtmp(:,:,1) = missing_val
+      CALL histwrite3d_cosp(o_clcalipsotmp,cospOUT%calipso_lidarcldtmp(:,:,1),nverttemp)
+   endif
+
+   if (cfg%Lcllcalipsoice) then
+      where(cospOUT%calipso_cldlayerphase(:,1,1) == R_UNDEF) cospOUT%calipso_cldlayerphase(:,1,1) = missing_val
+      CALL histwrite2d_cosp(o_cllcalipsoice,cospOUT%calipso_cldlayerphase(:,1,1))
+   endif
+   if (cfg%Lclhcalipsoice) then
+      where(cospOUT%calipso_cldlayerphase(:,3,1) == R_UNDEF) cospOUT%calipso_cldlayerphase(:,3,1) = missing_val 
+      CALL histwrite2d_cosp(o_clhcalipsoice,cospOUT%calipso_cldlayerphase(:,3,1))
+   endif
+   if (cfg%Lclmcalipsoice) then
+      where(cospOUT%calipso_cldlayerphase(:,2,1) == R_UNDEF) cospOUT%calipso_cldlayerphase(:,2,1) = missing_val
+      CALL histwrite2d_cosp(o_clmcalipsoice,cospOUT%calipso_cldlayerphase(:,2,1))
+   endif
+   if (cfg%Lcltcalipsoice) then
+      where(cospOUT%calipso_cldlayerphase(:,4,1) == R_UNDEF) cospOUT%calipso_cldlayerphase(:,4,1) = missing_val
+      CALL histwrite2d_cosp(o_cltcalipsoice,cospOUT%calipso_cldlayerphase(:,4,1))
+   endif
+   if (cfg%Lclcalipsoice) then 
+      where(cospOUT%calipso_lidarcldphase(:,:,1) == R_UNDEF) cospOUT%calipso_lidarcldphase(:,:,1) = missing_val
+      CALL histwrite3d_cosp(o_clcalipsoice,cospOUT%calipso_lidarcldphase(:,:,1),nvert)
+   endif
+   if (cfg%Lclcalipsotmpice) then
+      where(cospOUT%calipso_lidarcldtmp(:,:,2) == R_UNDEF) cospOUT%calipso_lidarcldtmp(:,:,2) = missing_val
+      CALL histwrite3d_cosp(o_clcalipsotmpice,cospOUT%calipso_lidarcldtmp(:,:,2),nverttemp)
+   endif
+
+   if (cfg%Lcllcalipsoliq) then
+      where(cospOUT%calipso_cldlayerphase(:,1,2) == R_UNDEF) cospOUT%calipso_cldlayerphase(:,1,2) = missing_val
+      CALL histwrite2d_cosp(o_cllcalipsoliq,cospOUT%calipso_cldlayerphase(:,1,2))
+   endif
+   if (cfg%Lclhcalipsoliq) then 
+      where(cospOUT%calipso_cldlayerphase(:,3,2) == R_UNDEF) cospOUT%calipso_cldlayerphase(:,3,2) = missing_val
+      CALL histwrite2d_cosp(o_clhcalipsoliq,cospOUT%calipso_cldlayerphase(:,3,2))
+   endif
+   if (cfg%Lclmcalipsoliq) then 
+      where(cospOUT%calipso_cldlayerphase(:,2,2) == R_UNDEF) cospOUT%calipso_cldlayerphase(:,2,2) = missing_val
+      CALL histwrite2d_cosp(o_clmcalipsoliq,cospOUT%calipso_cldlayerphase(:,2,2))
+   endif
+   if (cfg%Lcltcalipsoliq) then
+      where(cospOUT%calipso_cldlayerphase(:,4,2) == R_UNDEF) cospOUT%calipso_cldlayerphase(:,4,2) = missing_val
+      CALL histwrite2d_cosp(o_cltcalipsoliq,cospOUT%calipso_cldlayerphase(:,4,2))
+   endif
+   if (cfg%Lclcalipsoliq) then
+      where(cospOUT%calipso_lidarcldphase(:,:,2) == R_UNDEF) cospOUT%calipso_lidarcldphase(:,:,2) = missing_val
+      CALL histwrite3d_cosp(o_clcalipsoliq,cospOUT%calipso_lidarcldphase(:,:,2),nvert)
+   endif
+   if (cfg%Lclcalipsotmpliq) then
+      where(cospOUT%calipso_lidarcldtmp(:,:,3) == R_UNDEF) cospOUT%calipso_lidarcldtmp(:,:,3) = missing_val
+      CALL histwrite3d_cosp(o_clcalipsotmpliq,cospOUT%calipso_lidarcldtmp(:,:,3),nverttemp)
+   endif
+   if (cfg%Lcllcalipsoun) then
+      where(cospOUT%calipso_cldlayerphase(:,1,3) == R_UNDEF) cospOUT%calipso_cldlayerphase(:,1,3) = missing_val
+      CALL histwrite2d_cosp(o_cllcalipsoun,cospOUT%calipso_cldlayerphase(:,1,3))
+   endif 
+   if (cfg%Lclhcalipsoun) then
+      where(cospOUT%calipso_cldlayerphase(:,3,3) == R_UNDEF) cospOUT%calipso_cldlayerphase(:,3,3) = missing_val
+      CALL histwrite2d_cosp(o_clhcalipsoun,cospOUT%calipso_cldlayerphase(:,3,3))
+   endif
+   if (cfg%Lclmcalipsoun) then 
+      where(cospOUT%calipso_cldlayerphase(:,2,3) == R_UNDEF) cospOUT%calipso_cldlayerphase(:,2,3) = missing_val
+      CALL histwrite2d_cosp(o_clmcalipsoun,cospOUT%calipso_cldlayerphase(:,2,3))
+   endif
+   if (cfg%Lcltcalipsoun) then
+      where(cospOUT%calipso_cldlayerphase(:,4,3) == R_UNDEF) cospOUT%calipso_cldlayerphase(:,4,3) = missing_val
+      CALL histwrite2d_cosp(o_cltcalipsoun,cospOUT%calipso_cldlayerphase(:,4,3))
+   endif
+   if (cfg%Lclcalipsoun) then 
+      where(cospOUT%calipso_lidarcldphase(:,:,3) == R_UNDEF) cospOUT%calipso_lidarcldphase(:,:,3) = missing_val
+      CALL histwrite3d_cosp(o_clcalipsoun,cospOUT%calipso_lidarcldphase(:,:,3),nvert)
+   endif
+   if (cfg%Lclcalipsotmpun) then
+      where(cospOUT%calipso_lidarcldtmp(:,:,4) == R_UNDEF) cospOUT%calipso_lidarcldtmp(:,:,4) = missing_val
+      CALL histwrite3d_cosp(o_clcalipsotmpun,cospOUT%calipso_lidarcldtmp(:,:,4),nverttemp)
+   endif
+
+   if (cfg%Lclopaquecalipso) then 
+      where(cospOUT%calipso_cldtype(:,1) == R_UNDEF) cospOUT%calipso_cldtype(:,1) = missing_val
+      CALL histwrite2d_cosp(o_clopaquecalipso,cospOUT%calipso_cldtype(:,1))
+   endif
+   if (cfg%Lclthincalipso) then
+      where(cospOUT%calipso_cldtype(:,2) == R_UNDEF) cospOUT%calipso_cldtype(:,2) = missing_val
+      CALL histwrite2d_cosp(o_clthincalipso,cospOUT%calipso_cldtype(:,2))   
+   endif
+   if (cfg%Lclzopaquecalipso) then
+      where(cospOUT%calipso_cldtype(:,3) == R_UNDEF) cospOUT%calipso_cldtype(:,3) = missing_val      
+      CALL histwrite2d_cosp(o_clzopaquecalipso,cospOUT%calipso_cldtype(:,3))
+   endif
+   if (cfg%Lclcalipsoopaque) then
+      where(cospOUT%calipso_lidarcldtype(:,:,1) == R_UNDEF) cospOUT%calipso_lidarcldtype(:,:,1) = missing_val      
+      CALL histwrite3d_cosp(o_clcalipsoopaque,cospOUT%calipso_lidarcldtype(:,:,1),nvert)
+   endif
+   if (cfg%Lclcalipsothin) then
+      where(cospOUT%calipso_lidarcldtype(:,:,2) == R_UNDEF) cospOUT%calipso_lidarcldtype(:,:,2) = missing_val
+      CALL histwrite3d_cosp(o_clcalipsothin,cospOUT%calipso_lidarcldtype(:,:,2),nvert)  
+   endif
+   if (cfg%Lclcalipsozopaque) then
+      where(cospOUT%calipso_lidarcldtype(:,:,3) == R_UNDEF) cospOUT%calipso_lidarcldtype(:,:,3) = missing_val
+      CALL histwrite3d_cosp(o_clcalipsozopaque,cospOUT%calipso_lidarcldtype(:,:,3),nvert)
+   endif
+   if (cfg%Lclcalipsoopacity) then
+      where(cospOUT%calipso_lidarcldtype(:,:,4) == R_UNDEF) cospOUT%calipso_lidarcldtype(:,:,4) = missing_val
+      CALL histwrite3d_cosp(o_clcalipsoopacity,cospOUT%calipso_lidarcldtype(:,:,4),nvert)
+   endif
+
+   if (cfg%Lclopaquetemp) then 
+      where(cospOUT%calipso_cldtypetemp(:,1) == R_UNDEF) cospOUT%calipso_cldtypetemp(:,1) = missing_val
+      CALL histwrite2d_cosp(o_clopaquetemp,cospOUT%calipso_cldtypetemp(:,1))
+   endif
+   if (cfg%Lclthintemp) then 
+      where(cospOUT%calipso_cldtypetemp(:,2) == R_UNDEF) cospOUT%calipso_cldtypetemp(:,2) = missing_val
+      CALL histwrite2d_cosp(o_clthintemp,cospOUT%calipso_cldtypetemp(:,2))
+   endif 
+   if (cfg%Lclzopaquetemp) then
+      where(cospOUT%calipso_cldtypetemp(:,3) == R_UNDEF) cospOUT%calipso_cldtypetemp(:,3) = missing_val
+      CALL histwrite2d_cosp(o_clzopaquetemp,cospOUT%calipso_cldtypetemp(:,3))
+   endif
+   if (cfg%Lclopaquemeanz) then
+      where(cospOUT%calipso_cldtypemeanz(:,1) == R_UNDEF) cospOUT%calipso_cldtypemeanz(:,1) = missing_val
+      CALL histwrite2d_cosp(o_clopaquemeanz,cospOUT%calipso_cldtypemeanz(:,1))
+   endif
+   if (cfg%Lclthinmeanz) then
+      where(cospOUT%calipso_cldtypemeanz(:,2) == R_UNDEF) cospOUT%calipso_cldtypemeanz(:,2) = missing_val
+      CALL histwrite2d_cosp(o_clthinmeanz,cospOUT%calipso_cldtypemeanz(:,2))
+   endif
+   if (cfg%Lclthinemis) then 
+      where(cospOUT%calipso_cldthinemis == R_UNDEF) cospOUT%calipso_cldthinemis = missing_val
+      CALL histwrite2d_cosp(o_clthinemis,cospOUT%calipso_cldthinemis)
+   endif
+   if (cfg%Lclopaquemeanzse) then
+      where(cospOUT%calipso_cldtypemeanzse(:,1) == R_UNDEF) cospOUT%calipso_cldtypemeanzse(:,1) = missing_val
+      CALL histwrite2d_cosp(o_clopaquemeanzse,cospOUT%calipso_cldtypemeanzse(:,1))
+   endif
+   if (cfg%Lclthinmeanzse) then
+      where(cospOUT%calipso_cldtypemeanzse(:,2) == R_UNDEF) cospOUT%calipso_cldtypemeanzse(:,2) = missing_val
+      CALL histwrite2d_cosp(o_clthinmeanzse,cospOUT%calipso_cldtypemeanzse(:,2))
+   endif
+   if (cfg%Lclzopaquecalipsose) then 
+      where(cospOUT%calipso_cldtypemeanzse(:,3) == R_UNDEF) cospOUT%calipso_cldtypemeanzse(:,3) = missing_val
+      CALL histwrite2d_cosp(o_clzopaquecalipsose,cospOUT%calipso_cldtypemeanzse(:,3))
+   endif
+
+
+   if (cfg%LcfadLidarsr532) then 
+     where(cospOUT%calipso_cfad_sr == R_UNDEF) cospOUT%calipso_cfad_sr = missing_val
+    
+     do icl=1,SR_BINS
+      do k=1,Nlvgrid
+       do ip=1,Npoints
+        tmp_fi4da_cfadL(ip,k,icl)=cospOUT%calipso_cfad_sr(ip,icl,k)
+       enddo
+      enddo
+     enddo
+!   if (cfg%LcfadLidarsr532) CALL histwrite4d_cosp(o_cfad_lidarsr532,stlidar%cfad_sr)
+    CALL histwrite4d_cosp(o_cfadLidarsr532,tmp_fi4da_cfadL)   !!! "_" enleve
+   endif
+
+   if (cfg%Latb532) then  
+     where(cospOUT%calipso_beta_tot == R_UNDEF) cospOUT%calipso_beta_tot = missing_val
+     CALL histwrite4d_cosp(o_atb532,cospOUT%calipso_beta_tot)
+   endif
+   if (cfg%LlidarBetaMol532) then 
+     where(cospOUT%calipso_beta_mol == R_UNDEF) cospOUT%calipso_beta_mol = missing_val
+     CALL histwrite3d_cosp(o_lidarBetaMol532,cospOUT%calipso_beta_mol,nvertmcosp) 
+   endif
+
+ endif !Calipso
+
+
+!!!! Sorties Ground Lidar
+ if (cfg%LgrLidar532) then
+! AI juin 2020 Voir a quoi correspond ce champs
+!   where(cospOUT%grLidar532_srbval == R_UNDEF) cospOUT%grLidar532_srbval = missing_val
+
+   if (cfg%LcllgrLidar532) then
+      where(cospOUT%grLidar532_cldlayer(:,1) == R_UNDEF) cospOUT%grLidar532_cldlayer(:,1) = missing_val
+      CALL histwrite2d_cosp(o_cllgrLidar532,cospOUT%grLidar532_cldlayer(:,1))
+   endif
+   if (cfg%LclmgrLidar532) then
+      where(cospOUT%grLidar532_cldlayer(:,2) == R_UNDEF) cospOUT%grLidar532_cldlayer(:,2) = missing_val
+      CALL histwrite2d_cosp(o_clmgrLidar532,cospOUT%grLidar532_cldlayer(:,2))
+   endif
+   if (cfg%LclhgrLidar532) then
+      where(cospOUT%grLidar532_cldlayer(:,3) == R_UNDEF) cospOUT%grLidar532_cldlayer(:,3) = missing_val
+      CALL histwrite2d_cosp(o_clhgrLidar532,cospOUT%grLidar532_cldlayer(:,3))
+   endif
+   if (cfg%LcltgrLidar532) then
+      where(cospOUT%grLidar532_cldlayer(:,4) == R_UNDEF) cospOUT%grLidar532_cldlayer(:,4) = missing_val
+      CALL histwrite2d_cosp(o_cltgrLidar532,cospOUT%grLidar532_cldlayer(:,4))
+   endif
+
+   if (cfg%LclgrLidar532) then
+       where(cospOUT%grLidar532_lidarcld == R_UNDEF) cospOUT%grLidar532_lidarcld = missing_val
+      CALL histwrite3d_cosp(o_clgrLidar532,cospOUT%grLidar532_lidarcld,nvert)
+   endif
+   if (cfg%LlidarBetaMol532gr) then
+      where(cospOUT%grLidar532_beta_mol == R_UNDEF) cospOUT%grLidar532_beta_mol = missing_val
+      CALL histwrite3d_cosp(o_lidarBetaMol532gr,cospOUT%grLidar532_beta_mol,nvertmcosp) 
+   endif
+   if (cfg%LcfadLidarsr532gr) then
+     where(cospOUT%grLidar532_cfad_sr == R_UNDEF) cospOUT%grLidar532_cfad_sr = missing_val
+     do icl=1,SR_BINS
+      do k=1,Nlvgrid
+       do ip=1,Npoints
+         tmp_fi4da_cfadLgr(ip,k,icl)=cospOUT%grLidar532_cfad_sr(ip,icl,k)
+       enddo
+      enddo
+     enddo
+     CALL histwrite4d_cosp(o_cfadLidarsr532gr,tmp_fi4da_cfadLgr)
+   endif
+
+   if (cfg%Latb532gr) then
+      where(cospOUT%grLidar532_beta_tot == R_UNDEF) cospOUT%grLidar532_beta_tot = missing_val
+      CALL histwrite4d_cosp(o_atb532gr,cospOUT%grLidar532_beta_tot)
+   endif
+endif ! Ground Lidar 532 nm
+
+
+!!!! Sorties Atlid
+ if (cfg%Latlid) then
+! AI juin 2020 Voir a quoi correspond ce champs
+!   where(cospOUT%atlid_srbval == R_UNDEF) cospOUT%atlid_srbval = missing_val
+
+   if (cfg%Lcllatlid) then 
+      where(cospOUT%atlid_cldlayer(:,1) == R_UNDEF) cospOUT%atlid_cldlayer(:,1) = missing_val
+      CALL histwrite2d_cosp(o_cllatlid,cospOUT%atlid_cldlayer(:,1))
+   endif
+   if (cfg%Lclmatlid) then
+      where(cospOUT%atlid_cldlayer(:,2) == R_UNDEF) cospOUT%atlid_cldlayer(:,2) = missing_val
+      CALL histwrite2d_cosp(o_clmatlid,cospOUT%atlid_cldlayer(:,2))
+   endif
+   if (cfg%Lclhatlid) then
+      where(cospOUT%atlid_cldlayer(:,3) == R_UNDEF) cospOUT%atlid_cldlayer(:,3) = missing_val
+      CALL histwrite2d_cosp(o_clhatlid,cospOUT%atlid_cldlayer(:,3))
+   endif
+   if (cfg%Lcltatlid) then
+      where(cospOUT%atlid_cldlayer(:,4) == R_UNDEF) cospOUT%atlid_cldlayer(:,4) = missing_val
+      CALL histwrite2d_cosp(o_cltatlid,cospOUT%atlid_cldlayer(:,4))
+   endif
+   if (cfg%Lclatlid) then
+      where(cospOUT%atlid_lidarcld == R_UNDEF) cospOUT%atlid_lidarcld = missing_val
+      CALL histwrite3d_cosp(o_clatlid,cospOUT%atlid_lidarcld,nvert)
+   endif
+   if (cfg%LlidarBetaMol355) then
+      where(cospOUT%atlid_beta_mol == R_UNDEF) cospOUT%atlid_beta_mol = missing_val
+      CALL histwrite3d_cosp(o_lidarBetaMol355,cospOUT%atlid_beta_mol,nvertmcosp) 
+   endif
+   if (cfg%LcfadLidarsr355) then
+     where(cospOUT%atlid_cfad_sr == R_UNDEF) cospOUT%atlid_cfad_sr = missing_val
+     do icl=1,SR_BINS
+      do k=1,Nlvgrid
+       do ip=1,Npoints
+          tmp_fi4da_cfadLatlid(ip,k,icl)=cospOUT%atlid_cfad_sr(ip,icl,k)
+       enddo
+      enddo
+     enddo
+     CALL histwrite4d_cosp(o_cfadlidarsr355,tmp_fi4da_cfadLatlid)
+   endif
+
+   if (cfg%Latb355) then
+      where(cospOUT%atlid_beta_tot == R_UNDEF) cospOUT%atlid_beta_tot = missing_val 
+      CALL histwrite4d_cosp(o_atb355,cospOUT%atlid_beta_tot)
+   endif
+endif ! Atlid
+
+
+ if (cfg%Lparasol) then
+   if (cfg%LparasolRefl) then
+     where(cospOUT%parasolGrid_refl == R_UNDEF) cospOUT%parasolGrid_refl = missing_val
+     where(cospOUT%parasolPix_refl == R_UNDEF) cospOUT%parasolPix_refl = missing_val
+     CALL histwrite3d_cosp(o_parasolGrid_refl,cospOUT%parasolGrid_refl,nvertp)
+     CALL histwrite4d_cosp(o_parasolPix_refl,cospOUT%parasolPix_refl)
+   endif ! LparasolRefl
+ endif ! Parasol
+
+!  if (cfg%LparasolRefl) then 
+!    do k=1,PARASOL_NREFL
+!     do ip=1, Npoints
+!      if (stlidar%cldlayer(ip,4).gt.1.and.stlidar%parasolrefl(ip,k).ne.missing_val) then
+!        parasolcrefl(ip,k)=(stlidar%parasolrefl(ip,k)-0.03*(1.-stlidar%cldlayer(ip,4)/100.))/ &
+!                             (stlidar%cldlayer(ip,4)/100.)
+!         Ncref(ip,k) = 1.
+!      else
+!         parasolcrefl(ip,k)=missing_val
+!         Ncref(ip,k) = 0.
+!      endif
+!     enddo
+!    enddo
+!    CALL histwrite3d_cosp(o_Ncrefl,Ncref,nvertp)
+!    CALL histwrite3d_cosp(o_parasol_crefl,parasolcrefl,nvertp)
+!  endif
+
+
+!!! Sorties CloudSat
+ if (cfg%Lcloudsat) then
+! AI juin 2020 voir a quoi correspond ce champs
+!   where(cospOUT%cloudsat_pia == R_UNDEF) cospOUT%cloudsat_pia = missing_val
+
+   if (cfg%Lptradarflag0) then
+     where(cospOUT%cloudsat_precip_cover(:,1) == R_UNDEF) cospOUT%cloudsat_precip_cover(:,1) = missing_val
+     CALL histwrite2d_cosp(o_ptradarflag0,cospOUT%cloudsat_precip_cover(:,1))
+   endif
+   if (cfg%Lptradarflag1) then
+     where(cospOUT%cloudsat_precip_cover(:,2) == R_UNDEF) cospOUT%cloudsat_precip_cover(:,2) = missing_val
+     CALL histwrite2d_cosp(o_ptradarflag1,cospOUT%cloudsat_precip_cover(:,2))
+   endif
+   if (cfg%Lptradarflag2) then
+      where(cospOUT%cloudsat_precip_cover(:,3) == R_UNDEF) cospOUT%cloudsat_precip_cover(:,3) = missing_val
+      CALL histwrite2d_cosp(o_ptradarflag2,cospOUT%cloudsat_precip_cover(:,3))
+   endif
+   if (cfg%Lptradarflag3) then
+      where(cospOUT%cloudsat_precip_cover(:,4) == R_UNDEF) cospOUT%cloudsat_precip_cover(:,4) = missing_val
+      CALL histwrite2d_cosp(o_ptradarflag3,cospOUT%cloudsat_precip_cover(:,4))
+   endif
+   if (cfg%Lptradarflag4) then
+      where(cospOUT%cloudsat_precip_cover(:,5) == R_UNDEF) cospOUT%cloudsat_precip_cover(:,5) = missing_val
+      CALL histwrite2d_cosp(o_ptradarflag3,cospOUT%cloudsat_precip_cover(:,5))
+   endif
+   if (cfg%Lptradarflag5) then
+      where(cospOUT%cloudsat_precip_cover(:,6) == R_UNDEF) cospOUT%cloudsat_precip_cover(:,6) = missing_val
+      CALL histwrite2d_cosp(o_ptradarflag3,cospOUT%cloudsat_precip_cover(:,6))
+   endif
+   if (cfg%Lptradarflag6) then
+      where(cospOUT%cloudsat_precip_cover(:,7) == R_UNDEF) cospOUT%cloudsat_precip_cover(:,7) = missing_val
+      CALL histwrite2d_cosp(o_ptradarflag3,cospOUT%cloudsat_precip_cover(:,7))
+   endif
+   if (cfg%Lptradarflag7) then
+      where(cospOUT%cloudsat_precip_cover(:,8) == R_UNDEF) cospOUT%cloudsat_precip_cover(:,8) = missing_val
+      CALL histwrite2d_cosp(o_ptradarflag3,cospOUT%cloudsat_precip_cover(:,8))
+   endif
+   if (cfg%Lptradarflag8) then
+      where(cospOUT%cloudsat_precip_cover(:,9) == R_UNDEF) cospOUT%cloudsat_precip_cover(:,9) = missing_val
+      CALL histwrite2d_cosp(o_ptradarflag3,cospOUT%cloudsat_precip_cover(:,9))
+   endif
+   if (cfg%Lptradarflag9) then
+      where(cospOUT%cloudsat_precip_cover(:,10) == R_UNDEF) cospOUT%cloudsat_precip_cover(:,10) = missing_val
+      CALL histwrite2d_cosp(o_ptradarflag3,cospOUT%cloudsat_precip_cover(:,10))
+   endif
+
+   if (cfg%Ldbze94) then
+     where(cospOUT%cloudsat_Ze_tot == R_UNDEF) cospOUT%cloudsat_Ze_tot = missing_val 
+     CALL histwrite4d_cosp(o_dbze94,cospOUT%cloudsat_Ze_tot)
+   endif
+   if (cfg%LcfadDbze94)  then
+     where(cospOUT%cloudsat_cfad_ze == R_UNDEF) cospOUT%cloudsat_cfad_ze = missing_val  
+     do icl=1,CLOUDSAT_DBZE_BINS
+      do k=1,Nlvgrid
+       do ip=1,Npoints
+         tmp_fi4da_cfadR(ip,k,icl)=cospOUT%cloudsat_cfad_ze(ip,icl,k)
+       enddo
+      enddo
+     enddo
+     CALL histwrite4d_cosp(o_cfadDbze94,tmp_fi4da_cfadR)
+  endif
+ endif
+! endif pour CloudSat
+
+
+!!! Sorties combinees Cloudsat et Calipso
+ if (cfg%Lcalipso .and. cfg%Lcloudsat) then
+
+   if (cfg%Lclcalipso2) then
+     where(cospOUT%lidar_only_freq_cloud == R_UNDEF) &
+                           cospOUT%lidar_only_freq_cloud = missing_val
+     CALL histwrite3d_cosp(o_clcalipso2,cospOUT%lidar_only_freq_cloud,nvert)
+   endif
+   if (cfg%Lcloudsat_tcc) then
+     where(cospOUT%cloudsat_tcc == R_UNDEF) &
+                           cospOUT%cloudsat_tcc = missing_val
+     CALL histwrite2d_cosp(o_cloudsat_tcc,cospOUT%cloudsat_tcc)
+   endif
+   if (cfg%Lcloudsat_tcc2) then
+     where(cospOUT%cloudsat_tcc2 == R_UNDEF) &
+                           cospOUT%cloudsat_tcc2 = missing_val
+     CALL histwrite2d_cosp(o_cloudsat_tcc2,cospOUT%cloudsat_tcc2)
+   endif
+   if (cfg%Lcltlidarradar) then
+     where(cospOUT%radar_lidar_tcc == R_UNDEF) &
+                           cospOUT%radar_lidar_tcc = missing_val     
+     CALL histwrite2d_cosp(o_cltlidarradar,cospOUT%radar_lidar_tcc)
+   endif
+ endif
+
+
+!!! Sorties Isccp
+ if (cfg%Lisccp) then
+  where(cospOUT%isccp_totalcldarea == R_UNDEF) cospOUT%isccp_totalcldarea = missing_val
+  where(cospOUT%isccp_meanptop == R_UNDEF) cospOUT%isccp_meanptop = missing_val
+  where(cospOUT%isccp_meantaucld == R_UNDEF) cospOUT%isccp_meantaucld = missing_val
+  where(cospOUT%isccp_meanalbedocld == R_UNDEF) cospOUT%isccp_meanalbedocld = missing_val
+  where(cospOUT%isccp_meantb == R_UNDEF) cospOUT%isccp_meantb = missing_val
+  where(cospOUT%isccp_meantbclr == R_UNDEF) cospOUT%isccp_meantbclr = missing_val
+  where(cospOUT%isccp_fq == R_UNDEF) cospOUT%isccp_fq = missing_val
+  where(cospOUT%isccp_boxtau == R_UNDEF) cospOUT%isccp_boxtau = missing_val
+  where(cospOUT%isccp_boxptop == R_UNDEF) cospOUT%isccp_boxptop = missing_val 
+
+!   CALL histwrite2d_cosp(o_sunlit,gbx%sunlit)
+  if (cfg%Lclisccp) CALL histwrite4d_cosp(o_clisccp,cospOUT%isccp_fq)
+
+   if (cfg%Lboxtauisccp) CALL histwrite3d_cosp(o_boxtauisccp,cospOUT%isccp_boxtau,nvertcol)
+   if (cfg%Lboxptopisccp) CALL histwrite3d_cosp(o_boxptopisccp,cospOUT%isccp_boxptop,nvertcol) 
+   if (cfg%Lcltisccp) CALL histwrite2d_cosp(o_cltisccp,cospOUT%isccp_totalcldarea) 
+   if (cfg%Lpctisccp) CALL histwrite2d_cosp(o_pctisccp,cospOUT%isccp_meanptop) 
+   if (cfg%Ltauisccp) CALL histwrite2d_cosp(o_tauisccp,cospOUT%isccp_meantaucld) 
+   if (cfg%Lalbisccp) CALL histwrite2d_cosp(o_albisccp,cospOUT%isccp_meanalbedocld) 
+   if (cfg%Lmeantbisccp) CALL histwrite2d_cosp(o_meantbisccp,cospOUT%isccp_meantb) 
+   if (cfg%Lmeantbclrisccp) CALL histwrite2d_cosp(o_meantbclrisccp,cospOUT%isccp_meantbclr)
+ endif ! Isccp
+
+
+!!! MISR simulator
+ if (cfg%Lmisr) then
+
+   if (cfg%LclMISR) then
+! Ces 3 diagnostics sont controles par la clef logique "LclMISR"
+   where(cospOUT%misr_fq == R_UNDEF) cospOUT%misr_fq = missing_val
+!   where(cospOUT%misr_dist_model_layertops == R_UNDEF) cospOUT%misr_dist_model_layertops = missing_val
+   where(cospOUT%misr_meanztop == R_UNDEF) cospOUT%misr_meanztop = missing_val
+   where(cospOUT%misr_cldarea == R_UNDEF) cospOUT%misr_cldarea = missing_val
+
+   do icl=1,numMISRHgtBins
+      do k=1,Nlvgrid
+       do ip=1,Npoints    
+      tmp_fi4da_misr(ip,icl,k)=cospOUT%misr_fq(ip,k,icl)
+       enddo
+      enddo
+   enddo
+!   if (cfg%LclMISR) CALL histwrite4d_cosp(o_clMISR,misr%fq_MISR)
+!   if (cfg%LclMISR) CALL histwrite4d_cosp(o_clMISR,tmp_fi4da_misr)
+   CALL histwrite4d_cosp(o_misr_fq,tmp_fi4da_misr)
+
+   CALL histwrite2d_cosp(o_misr_meanztop,cospOUT%misr_meanztop) 
+   CALL histwrite2d_cosp(o_misr_cldarea,cospOUT%misr_cldarea) 
+  endif ! LclMISR
+
+ endif ! Misr
+
+
+!!! Modis simulator
+ if (cfg%Lmodis) then
+  where(cospOUT%modis_Cloud_Fraction_Low_Mean == R_UNDEF) &
+        cospOUT%modis_Cloud_Fraction_Low_Mean = missing_val
+  where(cospOUT%modis_Cloud_Fraction_High_Mean == R_UNDEF) &
+        cospOUT%modis_Cloud_Fraction_High_Mean = missing_val
+  where(cospOUT%modis_Cloud_Fraction_Mid_Mean == R_UNDEF) &
+        cospOUT%modis_Cloud_Fraction_Mid_Mean = missing_val
+  where(cospOUT%modis_Cloud_Fraction_Total_Mean == R_UNDEF) &
+        cospOUT%modis_Cloud_Fraction_Total_Mean = missing_val
+  where(cospOUT%modis_Cloud_Fraction_Water_Mean == R_UNDEF) &
+        cospOUT%modis_Cloud_Fraction_Water_Mean = missing_val
+  where(cospOUT%modis_Cloud_Fraction_Ice_Mean == R_UNDEF) &
+        cospOUT%modis_Cloud_Fraction_Ice_Mean = missing_val
+  where(cospOUT%modis_Optical_Thickness_Total_Mean == R_UNDEF) &
+        cospOUT%modis_Optical_Thickness_Total_Mean = missing_val
+  where(cospOUT%modis_Optical_Thickness_Water_Mean == R_UNDEF) &
+        cospOUT%modis_Optical_Thickness_Water_Mean = missing_val
+  where(cospOUT%modis_Optical_Thickness_Ice_Mean == R_UNDEF) &
+        cospOUT%modis_Optical_Thickness_Ice_Mean = missing_val
+  where(cospOUT%modis_Cloud_Particle_Size_Water_Mean == R_UNDEF) &
+        cospOUT%modis_Cloud_Particle_Size_Water_Mean = missing_val
+  where(cospOUT%modis_Cloud_Particle_Size_Ice_Mean == R_UNDEF) &
+        cospOUT%modis_Cloud_Particle_Size_Ice_Mean = missing_val
+  where(cospOUT%modis_Cloud_Top_Pressure_Total_Mean == R_UNDEF) &
+        cospOUT%modis_Cloud_Top_Pressure_Total_Mean = missing_val
+  where(cospOUT%modis_Liquid_Water_Path_Mean == R_UNDEF) &
+        cospOUT%modis_Liquid_Water_Path_Mean = missing_val 
+  where(cospOUT%modis_Ice_Water_Path_Mean == R_UNDEF) &
+        cospOUT%modis_Ice_Water_Path_Mean = missing_val
+  where(cospOUT%modis_Optical_Thickness_Total_LogMean == R_UNDEF) &
+          cospOUT%modis_Optical_Thickness_Total_LogMean = missing_val
+  where(cospOUT%modis_Optical_Thickness_Water_LogMean == R_UNDEF) &
+          cospOUT%modis_Optical_Thickness_Water_LogMean = missing_val
+  where(cospOUT%modis_Optical_Thickness_Ice_LogMean == R_UNDEF) &
+          cospOUT%modis_Optical_Thickness_Ice_LogMean = missing_val
+    
+  if (cfg%Lcllmodis) CALL histwrite2d_cosp(o_cllmodis,cospOUT%modis_Cloud_Fraction_Low_Mean)
+  if (cfg%Lclhmodis) CALL histwrite2d_cosp(o_clhmodis,cospOUT%modis_Cloud_Fraction_High_Mean)
+  if (cfg%Lclmmodis) CALL histwrite2d_cosp(o_clmmodis,cospOUT%modis_Cloud_Fraction_Mid_Mean)
+  if (cfg%Lcltmodis) CALL histwrite2d_cosp(o_cltmodis,cospOUT%modis_Cloud_Fraction_Total_Mean)
+  if (cfg%Lclwmodis) CALL histwrite2d_cosp(o_clwmodis,cospOUT%modis_Cloud_Fraction_Water_Mean)
+  if (cfg%Lclimodis) CALL histwrite2d_cosp(o_climodis,cospOUT%modis_Cloud_Fraction_Ice_Mean)
+  if (cfg%Ltautmodis) CALL histwrite2d_cosp(o_tautmodis,cospOUT%modis_Optical_Thickness_Total_Mean)
+  if (cfg%Ltauwmodis) CALL histwrite2d_cosp(o_tauwmodis,cospOUT%modis_Optical_Thickness_Water_Mean)
+  if (cfg%Ltauimodis) CALL histwrite2d_cosp(o_tauimodis,cospOUT%modis_Optical_Thickness_Ice_Mean)
+  if (cfg%Ltautlogmodis) CALL histwrite2d_cosp(o_tautlogmodis,cospOUT%modis_Optical_Thickness_Total_LogMean)  
+  if (cfg%Ltauwlogmodis) CALL histwrite2d_cosp(o_tauwlogmodis,cospOUT%modis_Optical_Thickness_Water_LogMean)
+  if (cfg%Ltauilogmodis) CALL histwrite2d_cosp(o_tauilogmodis,cospOUT%modis_Optical_Thickness_Ice_LogMean)
+  if (cfg%Lreffclwmodis) CALL histwrite2d_cosp(o_reffclwmodis,cospOUT%modis_Cloud_Particle_Size_Water_Mean)
+  if (cfg%Lreffclimodis) CALL histwrite2d_cosp(o_reffclimodis,cospOUT%modis_Cloud_Particle_Size_Ice_Mean)
+  if (cfg%Lpctmodis) CALL histwrite2d_cosp(o_pctmodis,cospOUT%modis_Cloud_Top_Pressure_Total_Mean)
+  if (cfg%Llwpmodis) CALL histwrite2d_cosp(o_lwpmodis,cospOUT%modis_Liquid_Water_Path_Mean)
+  if (cfg%Liwpmodis) CALL histwrite2d_cosp(o_iwpmodis,cospOUT%modis_Ice_Water_Path_Mean)
+
+  if (cfg%Lclmodis) then
+! Ces 3 diagnostics sont controles par la clef logique "Lclmodis"
+    where(cospOUT%modis_Optical_Thickness_vs_Cloud_Top_Pressure == R_UNDEF) &
+          cospOUT%modis_Optical_Thickness_vs_Cloud_Top_Pressure = missing_val
+    where(cospOUT%modis_Optical_Thickness_vs_ReffICE == R_UNDEF) &
+          cospOUT%modis_Optical_Thickness_vs_ReffICE = missing_val
+    where(cospOUT%modis_Optical_thickness_vs_ReffLIQ == R_UNDEF) &
+          cospOUT%modis_Optical_thickness_vs_ReffLIQ = missing_val
+
+    CALL histwrite4d_cosp(o_modis_ot_vs_ctp,cospOUT%modis_Optical_Thickness_vs_Cloud_Top_Pressure)
+    CALL histwrite4d_cosp(o_modis_ot_vs_reffice,cospOUT%modis_Optical_Thickness_vs_ReffICE)
+    CALL histwrite4d_cosp(o_modis_ot_vs_reffliq,cospOUT%modis_Optical_thickness_vs_ReffLIQ)
+
+  endif ! Lclmodis
+
+ endif !modis
+
+
+ IF(.NOT.cosp_varsdefined) THEN
+!$OMP MASTER
+! Fermeture dans phys_output_write
+!#ifdef 1
+            !On finalise l'initialisation:
+            !CALL wxios_closedef()
+!#endif
+
+!$OMP END MASTER
+!$OMP BARRIER
+            cosp_varsdefined = .TRUE.
+ END IF
+
+    IF(cosp_varsdefined) THEN
+! On synchronise les fichiers pour IOIPSL
+    ENDIF  !cosp_varsdefined
+
+    END SUBROUTINE lmdz_cosp_output_write
+
+
+! ug Routine pour definir itau_iocosp depuis cosp_output_write_mod:
+  SUBROUTINE set_itau_iocosp(ito)
+      IMPLICIT NONE
+      INTEGER, INTENT(IN) :: ito
+      itau_iocosp = ito
+  END SUBROUTINE
+
+  SUBROUTINE histdef2d_cosp (iff,var)
+
+    USE ioipsl
+    USE dimphy
+    use iophy
+    USE mod_phys_lmdz_para
+    USE mod_grid_phy_lmdz, ONLY: nbp_lon
+    USE print_control_mod, ONLY: lunout,prt_level
+  USE wxios
+
+    IMPLICIT NONE
+
+    INCLUDE "clesphys.h"
+
+    INTEGER                          :: iff
+    TYPE(ctrl_outcosp)               :: var
+
+    REAL zstophym
+    CHARACTER(LEN=20) :: typeecrit
+
+    ! ug On rÃ©cupÃ¨re le type Ã©crit de la structure:
+    !       Assez moche, Ã|  refaire si meilleure mÃ©thode...
+    IF (INDEX(var%cosp_typeecrit(iff), "once") > 0) THEN
+       typeecrit = 'once'
+    ELSE IF(INDEX(var%cosp_typeecrit(iff), "t_min") > 0) THEN
+       typeecrit = 't_min(X)'
+    ELSE IF(INDEX(var%cosp_typeecrit(iff), "t_max") > 0) THEN
+       typeecrit = 't_max(X)'
+    ELSE IF(INDEX(var%cosp_typeecrit(iff), "inst") > 0) THEN
+       typeecrit = 'inst(X)'
+    ELSE
+       typeecrit = cosp_outfiletypes(iff)
+    ENDIF
+
+    IF (typeecrit=='inst(X)'.OR.typeecrit=='once') THEN
+       zstophym=zoutm_cosp(iff)
+    ELSE
+       zstophym=zdtimemoy_cosp
+    ENDIF
+
+     IF (.not. ok_all_xml) then
+       IF ( var%cles(iff) ) THEN
+         if (prt_level >= 10) then
+              WRITE(lunout,*)'Appel wxios_add_field_to_file var%name =',var%name 
+         endif
+        CALL wxios_add_field_to_file(var%name, 2, cosp_nidfiles(iff), cosp_outfilenames(iff), &
+                                     var%description, var%unit, 1, typeecrit)
+       ENDIF
+     ENDIF
+
+
+  END SUBROUTINE histdef2d_cosp
+
+
+ SUBROUTINE histdef3d_cosp (iff,var,nvertsave,ncols)
+    USE ioipsl
+    USE dimphy
+    use iophy
+    USE mod_phys_lmdz_para
+    USE mod_grid_phy_lmdz, ONLY: nbp_lon
+    USE print_control_mod, ONLY: lunout,prt_level
+
+  USE wxios
+
+
+    IMPLICIT NONE
+
+    INCLUDE "clesphys.h"
+
+    INTEGER                        :: iff, klevs
+    INTEGER, INTENT(IN), OPTIONAL  :: ncols ! ug RUSTINE POUR LES variables 4D
+    INTEGER, INTENT(IN)           :: nvertsave
+    TYPE(ctrl_outcosp)             :: var
+
+    REAL zstophym
+    CHARACTER(LEN=20) :: typeecrit, nomi
+    CHARACTER(LEN=20) :: nom
+    character(len=2) :: str2
+    CHARACTER(len=20) :: nam_axvert
+
+! Axe vertical
+      IF (nvertsave.eq.nvertp(iff)) THEN
+          klevs=PARASOL_NREFL
+          nam_axvert="sza"
+      ELSE IF (nvertsave.eq.nvertisccp(iff)) THEN
+          klevs=7
+          nam_axvert="pressure2"
+      ELSE IF (nvertsave.eq.nvertcol(iff)) THEN
+          klevs=Ncolout
+          nam_axvert="column"
+      ELSE IF (nvertsave.eq.nverttemp(iff)) THEN
+          klevs=LIDAR_NTEMP
+          nam_axvert="temp"
+      ELSE IF (nvertsave.eq.nvertmisr(iff)) THEN
+          klevs=numMISRHgtBins
+          nam_axvert="cth16"
+      ELSE IF (nvertsave.eq.nvertReffIce(iff)) THEN
+          klevs= numMODISReffIceBins
+          nam_axvert="ReffIce"
+      ELSE IF (nvertsave.eq.nvertReffLiq(iff)) THEN
+          klevs= numMODISReffLiqBins
+          nam_axvert="ReffLiq"
+      ELSE
+           klevs=Nlevout
+           nam_axvert="presnivs"
+      ENDIF
+
+! ug RUSTINE POUR LES Champs 4D
+      IF (PRESENT(ncols)) THEN
+               write(str2,'(i2.2)')ncols
+               nomi=var%name
+               nom="c"//str2//"_"//nomi
+      ELSE
+               nom=var%name
+      END IF
+
+    ! ug On rÃ©cupÃ¨re le type Ã©crit de la structure:
+    !       Assez moche, Ã|  refaire si meilleure mÃ©thode...
+    IF (INDEX(var%cosp_typeecrit(iff), "once") > 0) THEN
+       typeecrit = 'once'
+    ELSE IF(INDEX(var%cosp_typeecrit(iff), "t_min") > 0) THEN
+       typeecrit = 't_min(X)'
+    ELSE IF(INDEX(var%cosp_typeecrit(iff), "t_max") > 0) THEN
+       typeecrit = 't_max(X)'
+    ELSE IF(INDEX(var%cosp_typeecrit(iff), "inst") > 0) THEN
+       typeecrit = 'inst(X)'
+    ELSE
+       typeecrit = cosp_outfiletypes(iff)
+    ENDIF
+
+    IF (typeecrit=='inst(X)'.OR.typeecrit=='once') THEN
+       zstophym=zoutm_cosp(iff)
+    ELSE
+       zstophym=zdtimemoy_cosp
+    ENDIF
+
+      IF (.not. ok_all_xml) then
+        IF ( var%cles(iff) ) THEN
+          if (prt_level >= 10) then
+              WRITE(lunout,*)'Appel wxios_add_field_to_file 3d nom variable nam_axvert = ',nom, nam_axvert 
+          endif
+          CALL wxios_add_field_to_file(nom, 3, cosp_nidfiles(iff), cosp_outfilenames(iff), &
+                                       var%description, var%unit, 1, typeecrit, nam_axvert)
+        ENDIF
+      ENDIF
+
+
+  END SUBROUTINE histdef3d_cosp
+
+
+ SUBROUTINE histwrite2d_cosp(var,field)
+  USE dimphy
+  USE mod_phys_lmdz_para
+  USE ioipsl
+  use iophy
+  USE mod_grid_phy_lmdz, ONLY: nbp_lon
+  USE print_control_mod, ONLY: lunout,prt_level
+
+  USE lmdz_xios, only: xios_send_field
+
+  IMPLICIT NONE
+  INCLUDE 'clesphys.h'
+
+    TYPE(ctrl_outcosp), INTENT(IN) :: var
+    REAL, DIMENSION(:), INTENT(IN) :: field
+
+    INTEGER :: iff
+
+    REAL,DIMENSION(klon_mpi) :: buffer_omp
+    INTEGER, allocatable, DIMENSION(:) :: index2d
+    REAL :: Field2d(nbp_lon,jj_nb)
+    CHARACTER(LEN=20) ::  nomi, nom
+    character(len=2) :: str2
+    LOGICAL, SAVE  :: firstx
+!$OMP THREADPRIVATE(firstx)
+
+    IF (prt_level >= 9) WRITE(lunout,*)'Begin histrwrite2d ',var%name
+
+  ! On regarde si on est dans la phase de dÃ©finition ou d'Ã©criture:
+  IF(.NOT.cosp_varsdefined) THEN
+!$OMP MASTER
+      print*,'var, cosp_varsdefined dans cosp_varsdefined ',var%name, cosp_varsdefined
+      !Si phase de dÃ©finition.... on dÃ©finit
+      CALL conf_cospoutputs(var%name,var%cles)
+      DO iff=1, 3
+         IF (cosp_outfilekeys(iff)) THEN
+            CALL histdef2d_cosp(iff, var)
+         ENDIF
+      ENDDO
+!$OMP END MASTER
+  ELSE
+    !Et sinon on.... Ã©crit
+    IF (SIZE(field)/=klon) &
+  CALL abort_physic('iophy::histwrite2d_cosp','Field first DIMENSION not equal to klon',1) 
+
+    CALL Gather_omp(field,buffer_omp)
+!$OMP MASTER
+    CALL grid1Dto2D_mpi(buffer_omp,Field2d)
+
+! La boucle sur les fichiers:
+      firstx=.true.
+      DO iff=1, 3
+           IF (var%cles(iff) .AND. cosp_outfilekeys(iff)) THEN
+                ALLOCATE(index2d(nbp_lon*jj_nb))
+                deallocate(index2d)
+              IF (.not. ok_all_xml) then
+                 if (firstx) then
+                  if (prt_level >= 10) then
+                    WRITE(lunout,*)'xios_send_field variable ',var%name
+                  endif
+                  CALL xios_send_field(var%name, Field2d)
+                   firstx=.false.
+                 endif
+              ENDIF
+           ENDIF
+      ENDDO 
+
+      IF (ok_all_xml) THEN
+        if (prt_level >= 1) then
+              WRITE(lunout,*)'xios_send_field variable ',var%name
+        endif
+       CALL xios_send_field(var%name, Field2d)
+      ENDIF
+
+!$OMP END MASTER   
+  ENDIF ! vars_defined
+  IF (prt_level >= 9) WRITE(lunout,*)'End histrwrite2d_cosp ',var%name
+  END SUBROUTINE histwrite2d_cosp
+
+
+! ug NOUVELLE VERSION DES WRITE AVEC LA BOUCLE DO RENTREE
+! AI sept 2013
+  SUBROUTINE histwrite3d_cosp(var, field, nverts, ncols)
+  USE dimphy
+  USE mod_phys_lmdz_para
+  USE ioipsl
+  use iophy
+  USE mod_grid_phy_lmdz, ONLY: nbp_lon
+  USE print_control_mod, ONLY: lunout,prt_level
+
+  USE lmdz_xios, only: xios_send_field
+
+
+  IMPLICIT NONE
+  INCLUDE 'clesphys.h'
+
+    TYPE(ctrl_outcosp), INTENT(IN)    :: var
+    REAL, DIMENSION(:,:), INTENT(IN)  :: field ! --> field(klon,:)
+    INTEGER, INTENT(IN), OPTIONAL     :: ncols ! ug RUSTINE POUR LES Champs 4D.....
+    INTEGER, DIMENSION(3), INTENT(IN) :: nverts
+
+    INTEGER :: iff, k
+
+    REAL,DIMENSION(klon_mpi,SIZE(field,2)) :: buffer_omp
+    REAL :: Field3d(nbp_lon,jj_nb,SIZE(field,2))
+    INTEGER :: ip, n, nlev
+    INTEGER, ALLOCATABLE, DIMENSION(:) :: index3d
+    CHARACTER(LEN=20) ::  nomi, nom
+    character(len=2) :: str2
+    LOGICAL, SAVE  :: firstx
+!$OMP THREADPRIVATE(firstx)
+
+  IF (prt_level >= 9) write(lunout,*)'Begin histrwrite3d ',var%name
+
+! ug RUSTINE POUR LES STD LEVS.....
+      IF (PRESENT(ncols)) THEN
+              write(str2,'(i2.2)')ncols
+              nomi=var%name
+              nom="c"//str2//"_"//nomi
+      ELSE
+               nom=var%name
+      END IF
+  ! On regarde si on est dans la phase de dÃ©finition ou d'Ã©criture:
+  IF(.NOT.cosp_varsdefined) THEN
+      !Si phase de dÃ©finition.... on dÃ©finit
+!$OMP MASTER
+      CALL conf_cospoutputs(var%name,var%cles)
+      DO iff=1, 3
+        IF (cosp_outfilekeys(iff)) THEN
+          CALL histdef3d_cosp(iff, var, nverts(iff), ncols)
+        ENDIF
+      ENDDO
+!$OMP END MASTER
+  ELSE
+    !Et sinon on.... Ã©crit
+    IF (SIZE(field,1)/=klon) &
+   CALL abort_physic('iophy::histwrite3d','Field first DIMENSION not equal to klon',1)                                  
+    nlev=SIZE(field,2)
+
+
+    CALL Gather_omp(field,buffer_omp)
+!$OMP MASTER
+    CALL grid1Dto2D_mpi(buffer_omp,field3d)
+
+! BOUCLE SUR LES FICHIERS
+     firstx=.true.
+     DO iff=1, 3
+        IF (var%cles(iff) .AND. cosp_outfilekeys(iff)) THEN
+           ALLOCATE(index3d(nbp_lon*jj_nb*nlev))
+
+          IF (.not. ok_all_xml) then
+           IF (firstx) THEN
+               CALL xios_send_field(nom, Field3d(:,:,1:nlev))
+               IF (prt_level >= 9) WRITE(lunout,*)'xios_send_field ',var%name
+               firstx=.FALSE.
+           ENDIF
+          ENDIF
+         deallocate(index3d)
+        ENDIF
+      ENDDO
+    IF (ok_all_xml) THEN
+     CALL xios_send_field(nom, Field3d(:,:,1:nlev))
+     IF (prt_level >= 1) WRITE(lunout,*)'xios_send_field ',var%name
+    ENDIF
+
+!$OMP END MASTER   
+  ENDIF ! vars_defined
+  IF (prt_level >= 9) write(lunout,*)'End histrwrite3d_cosp ',nom
+  END SUBROUTINE histwrite3d_cosp
+
+
+! ug NOUVELLE VERSION DES WRITE AVEC LA BOUCLE DO RENTREE
+! AI sept 2013
+  SUBROUTINE histwrite4d_cosp(var, field)
+  USE dimphy
+  USE mod_phys_lmdz_para
+  USE ioipsl
+  use iophy
+  USE mod_grid_phy_lmdz, ONLY: nbp_lon
+  USE print_control_mod, ONLY: lunout,prt_level
+
+  USE lmdz_xios, only: xios_send_field
+
+
+  IMPLICIT NONE
+  INCLUDE 'clesphys.h'
+
+    TYPE(ctrl_outcosp), INTENT(IN)    :: var
+    REAL, DIMENSION(:,:,:), INTENT(IN)  :: field ! --> field(klon,:)
+
+    INTEGER :: iff, k
+
+    REAL,DIMENSION(klon_mpi,SIZE(field,2),SIZE(field,3)) :: buffer_omp
+    REAL :: field4d(nbp_lon,jj_nb,SIZE(field,2),SIZE(field,3))
+    INTEGER :: ip, n, nlev, nlev2
+    INTEGER, ALLOCATABLE, DIMENSION(:) :: index4d
+    CHARACTER(LEN=20) ::  nomi, nom
+
+  IF (prt_level >= 9) write(lunout,*)'Begin histrwrite4d ',var%name
+
+  IF(cosp_varsdefined) THEN
+    !Et sinon on.... Ã©crit
+    IF (SIZE(field,1)/=klon) &
+   CALL abort_physic('iophy::histwrite3d','Field first DIMENSION not equal to klon',1)            
+
+    nlev=SIZE(field,2)
+    nlev2=SIZE(field,3)
+    CALL Gather_omp(field,buffer_omp)
+!$OMP MASTER
+    CALL grid1Dto2D_mpi(buffer_omp,field4d)
+
+!    IF (ok_all_xml) THEN
+     CALL xios_send_field(var%name, Field4d(:,:,1:nlev,1:nlev2))
+     IF (prt_level >= 1) WRITE(lunout,*)'xios_send_field ',var%name
+!    ENDIF
+
+!$OMP END MASTER   
+  ENDIF ! vars_defined
+  IF (prt_level >= 9) write(lunout,*)'End histrwrite4d_cosp ',nom
+  END SUBROUTINE histwrite4d_cosp
+
+  SUBROUTINE conf_cospoutputs(nam_var,cles_var)
+!!! Lecture des noms et cles de sortie des variables dans config.def
+    !   en utilisant les routines getin de IOIPSL  
+    use ioipsl
+    USE print_control_mod, ONLY: lunout,prt_level
+
+    IMPLICIT NONE
+
+   CHARACTER(LEN=20)               :: nam_var, nnam_var
+   LOGICAL, DIMENSION(3)           :: cles_var
+
+! Lecture dans config.def ou output.def de cles_var et name_var
+    CALL getin('cles_'//nam_var,cles_var)
+    CALL getin('name_'//nam_var,nam_var)
+    IF(prt_level>10) WRITE(lunout,*)'nam_var cles_var ',nam_var,cles_var(:)
+
+  END SUBROUTINE conf_cospoutputs
+
+ END MODULE lmdz_cosp_output_write_mod
Index: DZ6/trunk/libf/phylmd/cospv2/lmdz_cosp_read_outputkeys.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cospv2/lmdz_cosp_read_outputkeys.F90	(revision 5267)
+++ 	(revision )
@@ -1,1717 +1,0 @@
-!!!=============================================================================
-!!! AI mars 2018
-!!  Module permettant de controler les cles de sorties cosp
-!!  pour LMDZ
-!! 1. on initialise les cles au 1er passage a cosp itap de la physique = 1
-!! 2. on garde la routine de lecture du fichier namelist cosp_out...txt pour le
-!!    cas non XIOS (ioipsl)
-!! 3. on rajoutte une subroutine qui interoge XIOS si les champs sont demandes
-!!    dans les xml alors on les active et on active les simulateurs
-!!    correspondant 
-!!
-!!! RG janvier 2019
-!!  Mise a jour pour avoir toutes les sorties de COSPv2
-!!  Changement de nom a "lmdz_cosp_read_outputkeys"
-!!!=============================================================================
-
-module lmdz_cosp_read_outputkeys
-
-  USE mod_phys_lmdz_para
-
-  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-  ! TYPE COSP_CONFIG
-  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-  TYPE COSP_CONFIG
-     logical :: &
-         Lwrite_output,    & ! Control for output file
-         Lfracout,         & ! Control SCOPS cloud fraction out ?
-! simulators
-         Lcloudsat,        & ! CLOUDSAT simulator on/off switch 
-         Lcalipso,         & ! CALIPSO simulator on/off switch 
-	 LgrLidar532,      & ! GROUND LIDAR simulator on/off switch
-         Latlid,           & ! ATLID simulator on/off switch
-         Lisccp,           & ! ISCCP simulator on/off switch
-         Lmodis,           & ! MODIS simulatoe on/off switch
-         Lmisr,            & ! MISR simulator on/off switch 
-         Lrttov,           & ! RTTOV simulator on/off switch 
-         Lparasol,         & ! PARASOL simulator on/off switch
-
-! diagnostics 
-         Lpctisccp,        & ! ISCCP mean cloud top pressure
-         Lclisccp,         & ! ISCCP cloud area fraction
-         Lboxptopisccp,    & ! ISCCP CTP in each column
-         Lboxtauisccp,     & ! ISCCP optical epth in each column
-         Ltauisccp,        & ! ISCCP mean optical depth
-         Lcltisccp,        & ! ISCCP total cloud fraction
-         Lmeantbisccp,     & ! ISCCP mean all-sky 10.5micron brightness temperature
-         Lmeantbclrisccp,  & ! ISCCP mean clear-sky 10.5micron brightness temperature
-         Lalbisccp,        & ! ISCCP mean cloud albedo         
-         LclMISR,          & ! MISR cloud fraction
-         Lcltmodis,        & ! MODIS total cloud fraction
-         Lclwmodis,        & ! MODIS liquid cloud fraction
-         Lclimodis,        & ! MODIS ice cloud fraction
-         Lclhmodis,        & ! MODIS high-level cloud fraction
-         Lclmmodis,        & ! MODIS mid-level cloud fraction
-         Lcllmodis,        & ! MODIS low-level cloud fraction
-         Ltautmodis,       & ! MODIS total cloud optical thicknes
-         Ltauwmodis,       & ! MODIS liquid optical thickness
-         Ltauimodis,       & ! MODIS ice optical thickness
-         Ltautlogmodis,    & ! MODIS total cloud optical thickness (log10 mean)
-         Ltauwlogmodis,    & ! MODIS liquid optical thickness (log10 mean)
-         Ltauilogmodis,    & ! MODIS ice optical thickness (log10 mean)
-         Lreffclwmodis,    & ! MODIS liquid cloud particle size
-         Lreffclimodis,    & ! MODIS ice particle size
-         Lpctmodis,        & ! MODIS cloud top pressure
-         Llwpmodis,        & ! MODIS cloud liquid water path
-         Liwpmodis,        & ! MODIS cloud ice water path
-         Lclmodis,         & ! MODIS cloud area fraction
-         Latb532,          & ! CALIPSO attenuated total backscatter (532nm)
-         Latb532gr,        & ! GROUND LIDAR @ 532NM attenuated total backscatter (532nm)
-         Latb355,          & ! ATLID attenuated total backscatter (355nm)
-         LlidarBetaMol532, & ! CALIPSO molecular backscatter (532nm)         
-         LlidarBetaMol532gr,&! GROUND LIDAR @ 532NM molecular backscatter (532nm)
-         LlidarBetaMol355, & ! ATLID molecular backscatter (355nm) 
-         LcfadLidarsr532,  & ! CALIPSO scattering ratio CFAD
-         LcfadLidarsr532gr,& ! GROUND LIDAR @ 532NM scattering ratio CFAD  
-         LcfadLidarsr355,  & ! ATLID scattering ratio CFAD 
-         Lclcalipso2,      & ! CALIPSO cloud fraction undetected by cloudsat
-         Lclcalipso,       & ! CALIPSO cloud area fraction
-         LclgrLidar532,   & ! GROUND LIDAR @ 532NM cloud area fraction 
-         Lclatlid,         & ! ATLID cloud area fraction 
-         Lclhcalipso,      & ! CALIPSO high-level cloud fraction
-         Lcllcalipso,      & ! CALIPSO low-level cloud fraction
-         Lclmcalipso,      & ! CALIPSO mid-level cloud fraction
-         Lcltcalipso,      & ! CALIPSO total cloud fraction
-         LclhgrLidar532,  & ! GROUND LIDAR @ 532NM high-level cloud fraction 
-         LcllgrLidar532,  & ! GROUND LIDAR @ 532NM low-level cloud fraction 
-         LclmgrLidar532,  & ! GROUND LIDAR @ 532NM mid-level cloud fraction
-         LcltgrLidar532,  & ! GROUND LIDAR @ 532NM total cloud fraction
-         Lclhatlid,        & ! ATLID high-level cloud fraction
-         Lcllatlid,        & ! ATLID low-level cloud fraction  
-         Lclmatlid,        & ! ATLID mid-level cloud fraction 
-         Lcltatlid,        & ! ATLID total cloud fraction
-         Lcltlidarradar,   & ! CALIPSO-CLOUDSAT total cloud fraction
-         Lcloudsat_tcc,    & !
-         Lcloudsat_tcc2,   & !
-         Lclcalipsoliq,    & ! CALIPSO liquid cloud area fraction
-         Lclcalipsoice,    & ! CALIPSO ice cloud area fraction 
-         Lclcalipsoun,     & ! CALIPSO undetected cloud area fraction
-         Lclcalipsotmp,    & ! CALIPSO undetected cloud area fraction
-         Lclcalipsotmpliq, & ! CALIPSO liquid cloud area fraction
-         Lclcalipsotmpice, & ! CALIPSO ice cloud area fraction
-         Lclcalipsotmpun,  & ! CALIPSO undetected cloud area fraction
-         Lcltcalipsoliq,   & ! CALIPSO liquid total cloud fraction
-         Lcltcalipsoice,   & ! CALIPSO ice total cloud fraction
-         Lcltcalipsoun,    & ! CALIPSO undetected total cloud fraction
-         Lclhcalipsoliq,   & ! CALIPSO high-level liquid cloud fraction
-         Lclhcalipsoice,   & ! CALIPSO high-level ice cloud fraction
-         Lclhcalipsoun,    & ! CALIPSO high-level undetected cloud fraction
-         Lclmcalipsoliq,   & ! CALIPSO mid-level liquid cloud fraction
-         Lclmcalipsoice,   & ! CALIPSO mid-level ice cloud fraction
-         Lclmcalipsoun,    & ! CALIPSO mid-level undetected cloud fraction
-         Lcllcalipsoliq,   & ! CALIPSO low-level liquid cloud fraction
-         Lcllcalipsoice,   & ! CALIPSO low-level ice cloud fraction
-         Lcllcalipsoun,    & ! CALIPSO low-level undetected cloud fraction
-         Lclopaquecalipso, & ! CALIPSO opaque cloud cover (2D Map)
-         Lclthincalipso,   & ! CALIPSO thin cloud cover (2D Map)
-         Lclzopaquecalipso,& ! CALIPSO z_opaque altitude (opaque clouds only, 2D Map)
-         Lclcalipsoopaque, & ! CALIPSO opaque cloud profiles 3D fraction 
-         Lclcalipsothin,   & ! CALIPSO thin cloud profiles 3D fraction 
-         Lclcalipsozopaque,& ! CALIPSO z_opaque 3D fraction 
-         Lclcalipsoopacity,& ! CALIPSO opacity 3D fraction 
-         Lclopaquetemp,    & ! CALIPSO opaque cloud temperature 
-         Lclthintemp,      & ! CALIPSO thin cloud temperature
-         Lclzopaquetemp,   & ! CALIPSO z_opaque temperature  
-         Lclopaquemeanz,   & ! CALIPSO opaque cloud altitude  
-         Lclthinmeanz,     & ! CALIPSO thin cloud altitude 
-         Lclthinemis,      & ! CALIPSO thin cloud emissivity
-         Lclopaquemeanzse,   & ! CALIPSO opaque cloud altitude with respect to SE 
-         Lclthinmeanzse,     & ! CALIPSO thin cloud altitude with respect to SE
-         Lclzopaquecalipsose,& ! CALIPSO z_opaque altitude with respect to SE
-         LcfadDbze94,      & ! CLOUDSAT radar reflectivity CFAD
-         Ldbze94,          & ! CLOUDSAT radar reflectivity
-         LparasolRefl,     & ! PARASOL reflectance
-         Ltbrttov,         & ! RTTOV mean clear-sky brightness temperature
-         Lptradarflag0,    & ! CLOUDSAT no precipitation flag
-         Lptradarflag1,    & ! CLOUDSAT rain possible flag
-         Lptradarflag2,    & ! CLOUDSAT rain probable flag
-         Lptradarflag3,    & ! CLOUDSAT rain certain flag
-         Lptradarflag4,    & ! CLOUDSAT snow possible flag
-         Lptradarflag5,    & ! CLOUDSAT snow certain flag
-         Lptradarflag6,    & ! CLOUDSAT mixed-precipitation possible flag
-         Lptradarflag7,    & ! CLOUDSAT mixed-precipitation certain flag
-         Lptradarflag8,    & ! CLOUDSAT heavy rain flag
-         Lptradarflag9,    & ! CLOUDSAT default flag
-         Lradarpia           ! CLOUDSAT PIA
-
-
-!     character(len=32),dimension(:),allocatable :: out_list
-      character(len=32) :: out_list(107)
-  END TYPE COSP_CONFIG       
-
-
-CONTAINS
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-!--------------- SUBROUTINE READ_COSP_OUTPUT_NL -------------------------
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
- SUBROUTINE cosp_outputkeys_init(cfg)
-  implicit none
-  type(cosp_config),intent(inout) :: cfg 
-  character(len=32) :: out_list(107)
-  integer :: i
-                
-   do i=1,107
-      cfg%out_list(i)=''
-   enddo
-
-
-   cfg%Lcloudsat=.false.
-   cfg%Lcalipso=.false.
-   cfg%LgrLidar532=.false.
-   cfg%Latlid=.false.
-   cfg%Lisccp=.false.
-   cfg%Lmodis=.false.
-   cfg%Lmisr=.false.
-   cfg%Lrttov=.false.
-   cfg%Lparasol=.false.
-   cfg%Lwrite_output=.false.
-   cfg%Lfracout=.false.
-
-
-   cfg%Lpctisccp=.false.
-   cfg%Lclisccp=.false.
-   cfg%Lboxptopisccp=.false.
-   cfg%Lboxtauisccp=.false.
-   cfg%Ltauisccp=.false.
-   cfg%Lcltisccp=.false.
-   cfg%Lmeantbisccp=.false.
-   cfg%Lmeantbclrisccp=.false.
-   cfg%Lalbisccp=.false.
-   cfg%LclMISR=.false.
-   cfg%Lcltmodis=.false.
-   cfg%Lclwmodis=.false.
-   cfg%Lclimodis=.false.
-   cfg%Lclhmodis=.false.
-   cfg%Lclmmodis=.false.
-   cfg%Lcllmodis=.false.
-   cfg%Ltautmodis=.false.
-   cfg%Ltauwmodis=.false.
-   cfg%Ltauimodis=.false.
-   cfg%Ltautlogmodis=.false.
-   cfg%Ltauwlogmodis=.false.
-   cfg%Ltauilogmodis=.false.
-   cfg%Lreffclwmodis=.false.
-   cfg%Lreffclimodis=.false.
-   cfg%Lpctmodis=.false.
-   cfg%Llwpmodis=.false.
-   cfg%Liwpmodis=.false.
-   cfg%Lclmodis=.false.
-   cfg%Latb532=.false.
-   cfg%Latb532gr=.false.
-   cfg%Latb355=.false.
-   cfg%LlidarBetaMol532=.false.
-   cfg%LlidarBetaMol532gr=.false.
-   cfg%LlidarBetaMol355=.false.
-   cfg%LcfadLidarsr532=.false.
-   cfg%LcfadLidarsr532gr=.false.
-   cfg%LcfadLidarsr355 =.false.
-   cfg%Lclcalipso2=.false.
-   cfg%Lclcalipso=.false.
-   cfg%LclgrLidar532=.false.
-   cfg%Lclatlid=.false.
-   cfg%Lclhcalipso=.false.
-   cfg%Lcllcalipso=.false.
-   cfg%Lclmcalipso=.false.
-   cfg%Lcltcalipso=.false.
-   cfg%LclhgrLidar532=.false.
-   cfg%LcllgrLidar532=.false.
-   cfg%LclmgrLidar532 =.false.
-   cfg%LcltgrLidar532=.false.
-   cfg%Lclhatlid=.false.
-   cfg%Lcllatlid=.false.
-   cfg%Lclmatlid=.false.
-   cfg%Lcltatlid=.false.
-   cfg%Lcltlidarradar=.false.
-   cfg%Lcloudsat_tcc=.false.
-   cfg%Lcloudsat_tcc2=.false.
-   cfg%Lclcalipsoliq=.false.
-   cfg%Lclcalipsoice=.false.
-   cfg%Lclcalipsoun=.false.
-   cfg%Lclcalipsotmp=.false.
-   cfg%Lclcalipsotmpliq=.false.
-   cfg%Lclcalipsotmpice=.false.
-   cfg%Lclcalipsotmpun=.false.
-   cfg%Lcltcalipsoliq=.false.
-   cfg%Lcltcalipsoice=.false.
-   cfg%Lcltcalipsoun=.false.
-   cfg%Lclhcalipsoliq=.false.
-   cfg%Lclhcalipsoice=.false.
-   cfg%Lclhcalipsoun=.false.
-   cfg%Lclmcalipsoliq=.false.
-   cfg%Lclmcalipsoice=.false.
-   cfg%Lclmcalipsoun=.false.
-   cfg%Lcllcalipsoliq=.false.
-   cfg%Lcllcalipsoice=.false.
-   cfg%Lcllcalipsoun =.false.
-   cfg%Lclopaquecalipso=.false.
-   cfg%Lclthincalipso=.false.
-   cfg%Lclzopaquecalipso=.false.
-   cfg%Lclcalipsoopaque=.false.
-   cfg%Lclcalipsothin=.false.
-   cfg%Lclcalipsozopaque=.false.
-   cfg%Lclcalipsoopacity=.false.
-   cfg%Lclopaquetemp=.false.
-   cfg%Lclthintemp=.false.
-   cfg%Lclzopaquetemp=.false.
-   cfg%Lclopaquemeanz=.false.
-   cfg%Lclthinmeanz=.false.
-   cfg%Lclthinemis=.false.
-   cfg%Lclopaquemeanzse=.false.
-   cfg%Lclthinmeanzse=.false.
-   cfg%Lclzopaquecalipsose=.false.
-   cfg%LcfadDbze94=.false.
-   cfg%Ldbze94=.false.
-   cfg%Lparasolrefl=.false.
-   cfg%Ltbrttov=.false.
-   cfg%Lptradarflag0=.false.
-   cfg%Lptradarflag1=.false.
-   cfg%Lptradarflag2=.false.
-   cfg%Lptradarflag3=.false.
-   cfg%Lptradarflag4=.false.
-   cfg%Lptradarflag5=.false.
-   cfg%Lptradarflag6=.false.
-   cfg%Lptradarflag7=.false.
-   cfg%Lptradarflag8=.false.
-   cfg%Lptradarflag9=.false.
-   cfg%Lradarpia=.false.
-
- end subroutine cosp_outputkeys_init
-
-
- SUBROUTINE cosp_outputkeys_test(cfg)
-  implicit none
-  type(cosp_config),intent(out) :: cfg
-  character(len=32) :: out_list(107)
-  integer :: i
-
-   do i=1,107
-      cfg%out_list(i)=''
-   enddo
-
-   cfg%Lcloudsat=.false.
-   cfg%Lcalipso=.true.
-   cfg%LgrLidar532=.false.
-   cfg%Latlid=.false.
-   cfg%Lisccp=.false.
-   cfg%Lmodis=.false.
-   cfg%Lmisr=.false.
-   cfg%Lrttov=.false.
-   cfg%Lparasol=.false.
-   cfg%Lwrite_output=.false.
-!   cfg%Lfracout=.false.
-
-   cfg%Lpctisccp=.false.
-   cfg%Lclisccp=.false.
-   cfg%Lboxptopisccp=.false.
-   cfg%Lboxtauisccp=.false.
-   cfg%Ltauisccp=.false.
-   cfg%Lcltisccp=.false.
-   cfg%Lmeantbisccp=.false.
-   cfg%Lmeantbclrisccp=.false.
-   cfg%Lalbisccp=.false.
-   cfg%LclMISR=.false.
-   cfg%Lcltmodis=.false.
-   cfg%Lclwmodis=.false.
-   cfg%Lclimodis=.false.
-   cfg%Lclhmodis=.false.
-   cfg%Lclmmodis=.false.
-   cfg%Lcllmodis=.false.
-   cfg%Ltautmodis=.false.
-   cfg%Ltauwmodis=.false.
-   cfg%Ltauimodis=.false.
-   cfg%Ltautlogmodis=.false.
-   cfg%Ltauwlogmodis=.false.
-   cfg%Ltauilogmodis=.false.
-   cfg%Lreffclwmodis=.false.
-   cfg%Lreffclimodis=.false.
-   cfg%Lpctmodis=.false.
-   cfg%Llwpmodis=.false.
-   cfg%Liwpmodis=.false.
-   cfg%Lclmodis=.false.
-   cfg%Latb532=.false.
-   cfg%Latb532gr=.false.
-   cfg%Latb355=.false.
-   cfg%LlidarBetaMol532=.false.
-   cfg%LlidarBetaMol532gr=.false.
-   cfg%LlidarBetaMol355=.false.
-   cfg%LcfadLidarsr532=.false.
-   cfg%LcfadLidarsr532gr=.false.
-   cfg%LcfadLidarsr355 =.false.
-   cfg%Lclcalipso2=.false.
-   cfg%Lclcalipso=.false.
-   cfg%LclgrLidar532=.false.
-   cfg%Lclatlid=.false.
-   cfg%Lclhcalipso=.true.
-   cfg%Lcllcalipso=.true.
-   cfg%Lclmcalipso=.true.
-   cfg%Lcltcalipso=.true.
-   cfg%LclhgrLidar532=.false.
-   cfg%LcllgrLidar532=.false.
-   cfg%LclmgrLidar532 =.false.
-   cfg%LcltgrLidar532=.false.
-   cfg%Lclhatlid=.false.
-   cfg%Lcllatlid=.false.
-   cfg%Lclmatlid=.false.
-   cfg%Lcltatlid=.false.
-   cfg%Lcltlidarradar=.false.
-   cfg%Lcloudsat_tcc=.false.
-   cfg%Lcloudsat_tcc2=.false.
-   cfg%Lclcalipsoliq=.false.
-   cfg%Lclcalipsoice=.false.
-   cfg%Lclcalipsoun=.false.
-   cfg%Lclcalipsotmp=.false.
-   cfg%Lclcalipsotmpliq=.false.
-   cfg%Lclcalipsotmpice=.false.
-   cfg%Lclcalipsotmpun=.false.
-   cfg%Lcltcalipsoliq=.false.
-   cfg%Lcltcalipsoice=.false.
-   cfg%Lcltcalipsoun=.false.
-   cfg%Lclhcalipsoliq=.false.
-   cfg%Lclhcalipsoice=.false.
-   cfg%Lclhcalipsoun=.false.
-   cfg%Lclmcalipsoliq=.false.
-   cfg%Lclmcalipsoice=.false.
-   cfg%Lclmcalipsoun=.false.
-   cfg%Lcllcalipsoliq=.false.
-   cfg%Lcllcalipsoice=.false.
-   cfg%Lcllcalipsoun =.false.
-   cfg%Lclopaquecalipso=.false.
-   cfg%Lclthincalipso=.false.
-   cfg%Lclzopaquecalipso=.false.
-   cfg%Lclcalipsoopaque=.false.
-   cfg%Lclcalipsothin=.false.
-   cfg%Lclcalipsozopaque=.false.
-   cfg%Lclcalipsoopacity=.false.
-   cfg%Lclopaquetemp=.false.
-   cfg%Lclthintemp=.false.
-   cfg%Lclzopaquetemp=.false.
-   cfg%Lclopaquemeanz=.false.
-   cfg%Lclthinmeanz=.false.
-   cfg%Lclthinemis=.false.
-   cfg%Lclopaquemeanzse=.false.
-   cfg%Lclthinmeanzse=.false.
-   cfg%Lclzopaquecalipsose=.false.
-   cfg%LcfadDbze94=.false.
-   cfg%Ldbze94=.false.
-   cfg%Lparasolrefl=.false.
-   cfg%Ltbrttov=.false.
-   cfg%Lptradarflag0=.false.
-   cfg%Lptradarflag1=.false.
-   cfg%Lptradarflag2=.false.
-   cfg%Lptradarflag3=.false.
-   cfg%Lptradarflag4=.false.
-   cfg%Lptradarflag5=.false.
-   cfg%Lptradarflag6=.false.
-   cfg%Lptradarflag7=.false.
-   cfg%Lptradarflag8=.false.
-   cfg%Lptradarflag9=.false.
-   cfg%Lradarpia=.false.
-
- end subroutine cosp_outputkeys_test
-
-
- SUBROUTINE READ_COSP_OUTPUT_NL(itap,cosp_nl,cfg)
-  USE lmdz_xios, ONLY: xios_field_is_active, using_xios
-  implicit none
-  character(len=*),intent(in) :: cosp_nl
-  type(cosp_config),intent(inout) :: cfg
-  ! Local variables
-  integer :: i, itap
-
-!COSPv2
-  logical, save :: &
-       Lisccp      = .false. ,& ! Local on/off switch for simulators
-       Lmodis      = .false., & !
-       Lmisr       = .false., & !
-       Lcalipso    = .false., & !
-       LgrLidar532 = .false., & !
-       Latlid      = .false., & !
-       Lcloudsat   = .false., & !
-       Lrttov      = .false., & !
-       Lparasol    = .false.    !
-
-
- logical, save :: Lcfaddbze94,Ldbze94,Latb532,LcfadLidarsr532,Lclcalipso,Lclhcalipso,    &
-             Lcllcalipso,Lclmcalipso,Lcltcalipso,LparasolRefl,Lclcalipsoliq,             &
-             Lclcalipsoice,Lclcalipsoun,Lclcalipsotmp,Lclcalipsotmpliq,Lclcalipsotmpice, &
-             Lclcalipsotmpun,Lclhcalipsoliq,Lcllcalipsoliq,Lclmcalipsoliq,Lcltcalipsoliq,& 
-             Lclhcalipsoice,Lcllcalipsoice,Lclmcalipsoice,Lcltcalipsoice,Lclhcalipsoun,  & 
-             Lcllcalipsoun,Lclmcalipsoun,Lcltcalipsoun,Lclopaquecalipso,Lclthincalipso,  & 
-             Lclzopaquecalipso,Lclcalipsoopaque,Lclcalipsothin,Lclcalipsozopaque,        & 
-             Lclcalipsoopacity,Lclopaquetemp,Lclthintemp,Lclzopaquetemp,Lclopaquemeanz,  &
-             Lclthinmeanz,Lclthinemis,Lclopaquemeanzse,Lclthinmeanzse,Lclzopaquecalipsose,&
-             LlidarBetaMol532gr,LcfadLidarsr532gr,Latb532gr,LclgrLidar532,LclhgrLidar532,&
-             LcllgrLidar532,LclmgrLidar532,LcltgrLidar532,LlidarBetaMol355,              &
-             LcfadLidarsr355,Latb355,Lclatlid,Lclhatlid,Lcllatlid,Lclmatlid,Lcltatlid,   &
-             Lalbisccp,Lboxptopisccp,Lboxtauisccp,Lpctisccp,Lclisccp,Ltauisccp,Lcltisccp,&
-             Lmeantbisccp,Lmeantbclrisccp,LclMISR,Lclcalipso2,Lcltlidarradar,            &
-             Lcloudsat_tcc, Lcloudsat_tcc2,Lfracout,   &
-             LlidarBetaMol532,Lcltmodis,Lclwmodis,Lclimodis,Lclhmodis,Lclmmodis,         &
-             Lcllmodis,Ltautmodis,Ltauwmodis,Ltauimodis,Ltautlogmodis,Ltauwlogmodis,     &
-             Ltauilogmodis,Lreffclwmodis,Lreffclimodis,Lpctmodis,Llwpmodis,Liwpmodis,    &
-             Lclmodis,Ltbrttov,Lptradarflag0,Lptradarflag1,Lptradarflag2,Lptradarflag3,  &
-             Lptradarflag4,Lptradarflag5,Lptradarflag6,Lptradarflag7,Lptradarflag8,      &
-             Lptradarflag9,Lradarpia
-
-  namelist/COSP_OUTPUT/Lcfaddbze94,Ldbze94,Latb532,LcfadLidarsr532,Lclcalipso,           &
-                       Lclhcalipso,Lcllcalipso,Lclmcalipso,Lcltcalipso,LparasolRefl,     &
-                       Lclcalipsoliq,Lclcalipsoice,Lclcalipsoun,Lclcalipsotmp,           &
-                       Lclcalipsotmpliq,Lclcalipsotmpice,Lclcalipsotmpun,Lclhcalipsoliq, &
-                       Lcllcalipsoliq,Lclmcalipsoliq,Lcltcalipsoliq,Lclhcalipsoice,      &
-                       Lcllcalipsoice,Lclmcalipsoice,Lcltcalipsoice,Lclhcalipsoun,       &
-                       Lcllcalipsoun,Lclmcalipsoun,Lcltcalipsoun,Lclopaquecalipso,       &
-                       Lclthincalipso,Lclzopaquecalipso,Lclcalipsoopaque,Lclcalipsothin, &
-                       Lclcalipsozopaque,Lclcalipsoopacity,Lclopaquetemp,Lclthintemp,    &
-                       Lclzopaquetemp,Lclopaquemeanz,Lclthinmeanz,Lclthinemis,           &
-                       Lclopaquemeanzse,Lclthinmeanzse,Lclzopaquecalipsose,              &
-                       LlidarBetaMol532gr,LcfadLidarsr532gr,Latb532gr,LclgrLidar532,     &
-                       LclhgrLidar532,LcllgrLidar532,LclmgrLidar532,LcltgrLidar532,      &
-                       LlidarBetaMol355,LcfadLidarsr355,Latb355,Lclatlid,                &
-                       Lclhatlid,Lcllatlid,Lclmatlid,Lcltatlid,Lalbisccp,Lboxptopisccp,  &
-                       Lboxtauisccp,Lpctisccp,Lclisccp,Ltauisccp,Lcltisccp,Lmeantbisccp, &
-                       Lmeantbclrisccp,LclMISR,Lclcalipso2,Lcltlidarradar,               &
-                       Lcloudsat_tcc, Lcloudsat_tcc2, Lfracout,                          &
-                       LlidarBetaMol532,Lcltmodis,Lclwmodis,Lclimodis,Lclhmodis,         &
-                       Lclmmodis,Lcllmodis,Ltautmodis,Ltauwmodis,Ltauimodis,             &
-                       Ltautlogmodis,Ltauwlogmodis,Ltauilogmodis,Lreffclwmodis,          &
-                       Lreffclimodis,Lpctmodis,Llwpmodis,Liwpmodis,Lclmodis,Ltbrttov,    &
-                       Lptradarflag0,Lptradarflag1,Lptradarflag2,Lptradarflag3,          &
-                       Lptradarflag4,Lptradarflag5,Lptradarflag6,Lptradarflag7,          &
-                       Lptradarflag8,Lptradarflag9,Lradarpia
-
-  do i=1,107
-    cfg%out_list(i)=''
-  enddo
-  
-! Lecture du fichier namelist
-  IF (is_master) THEN
-    open(10,file=cosp_nl,status='old')
-    read(10,nml=cosp_output)
-    close(10)
-  ENDIF
-
-  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-  ! Which simulators need to be run? Look at which outputs are requested.
-  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-  if (Lpctisccp .or. Lclisccp .or. Lboxptopisccp .or.  Lboxtauisccp .or. Ltauisccp .or. &
-       Lcltisccp .or. Lmeantbisccp .or. Lmeantbclrisccp .or. Lalbisccp) Lisccp = .true.
-  if (LclMISR) Lmisr = .true.
-  if (Lcltmodis .or. Lclwmodis .or. Lclimodis .or. Lclhmodis .or. Lclmmodis .or.         &
-       Lcllmodis .or. Ltautmodis .or. Ltauwmodis .or. Ltauimodis .or. Ltautlogmodis .or. &
-       Ltauwlogmodis .or. Ltauilogmodis .or. Lreffclwmodis .or. Lreffclimodis .or.       &
-       Lpctmodis .or. Llwpmodis .or. Liwpmodis .or. Lclmodis) Lmodis = .true.
-  if (Lclcalipso2 .or. Lclcalipso .or.  Lclhcalipso .or. Lcllcalipso .or. Lclmcalipso    &
-       .or. Lcltcalipso .or. Lcltlidarradar .or. Lclcalipsoliq .or. Lclcalipsoice .or.   &
-       Lclcalipsoun .or. Lclcalipsotmp .or. Lclcalipsotmpliq .or. Lclcalipsotmpice .or.  &
-       Lclcalipsotmpun .or. Lcltcalipsoliq .or. Lcltcalipsoice .or. Lcltcalipsoun .or.   &
-       Lclhcalipsoliq .or. Lclhcalipsoice .or. Lclhcalipsoun .or. Lclmcalipsoliq .or.    &
-       Lclmcalipsoice .or. Lclmcalipsoun .or. Lcllcalipsoliq .or. Lcllcalipsoice .or.    &
-       Lcllcalipsoun .or. LlidarBetaMol532 .or. LcfadLidarsr532 .or. Lcltlidarradar .or. &
-       Lcltlidarradar .or. Lclopaquecalipso .or. Lclthincalipso .or. Lclzopaquecalipso   &
-       .or. Lclcalipsoopaque .or. Lclcalipsothin .or. Lclcalipsozopaque .or.             &
-       Lclcalipsoopacity .or. Lclopaquetemp .or. Lclthintemp .or. Lclzopaquetemp .or.    &
-       Lclopaquemeanz .or. Lclthinmeanz .or. Lclthinemis .or. Lclopaquemeanzse .or.      & 
-       Lclthinmeanzse .or. Lclzopaquecalipsose) Lcalipso = .true. 
-
-  if (LlidarBetaMol532gr .or. LcfadLidarsr532gr .or. Latb532gr .or. LclgrLidar532 .or.  & 
-       LclhgrLidar532 .or. LcllgrLidar532 .or. LclmgrLidar532 .or. LcltgrLidar532)   & 
-       LgrLidar532 = .true.
-
-  if (LlidarBetaMol355 .or. LcfadLidarsr355 .or. Latb355 .or. Lclatlid .or.              & 
-       Lclhatlid .or. Lcllatlid .or. Lclmatlid .or. Lcltatlid)                           & 
-       Latlid = .true. 
-
-  if (LcfadDbze94 .or. Ldbze94 .or. Lcltlidarradar .or. Lptradarflag0 .or. Lptradarflag1 &
-       .or. Lptradarflag2 .or. Lptradarflag3 .or. Lptradarflag4 .or. Lptradarflag5 .or.  &
-       Lptradarflag6 .or. Lptradarflag7 .or. Lptradarflag8 .or. Lptradarflag9 .or.       &
-       Lradarpia) Lcloudsat = .true.
-  if (Lparasolrefl) Lparasol = .true.
-  if (Ltbrttov) Lrttov = .true.
-
-  CALL bcast(Lcloudsat)
-  CALL bcast(Lcalipso)
-  CALL bcast(LgrLidar532)
-  CALL bcast(Latlid)
-  CALL bcast(Lparasol)
-  CALL bcast(Lisccp)
-  CALL bcast(Lmodis)
-  CALL bcast(Lmisr)
-  CALL bcast(Lrttov)
-
-  CALL bcast(Lcfaddbze94)
-  CALL bcast(Ldbze94)
-  CALL bcast(Latb532)
-  CALL bcast(LcfadLidarsr532)
-  CALL bcast(Lclcalipso)
-  CALL bcast(Lclhcalipso)
-  CALL bcast(Lcllcalipso)
-  CALL bcast(Lclmcalipso)
-  CALL bcast(Lcltcalipso)
-  CALL bcast(LparasolRefl)
-  CALL bcast(Lclcalipsoliq)
-  CALL bcast(Lclcalipsoice)
-  CALL bcast(Lclcalipsoun)
-  CALL bcast(Lclcalipsotmp)
-  CALL bcast(Lclcalipsotmpliq)
-  CALL bcast(Lclcalipsotmpice)
-  CALL bcast(Lclcalipsotmpun)
-  CALL bcast(Lclhcalipsoliq)
-  CALL bcast(Lcllcalipsoliq)
-  CALL bcast(Lclmcalipsoliq)
-  CALL bcast(Lcltcalipsoliq)
-  CALL bcast(Lclhcalipsoice)
-  CALL bcast(Lcllcalipsoice)
-  CALL bcast(Lclmcalipsoice)
-  CALL bcast(Lcltcalipsoice)
-  CALL bcast(Lclhcalipsoun)
-  CALL bcast(Lcllcalipsoun)
-  CALL bcast(Lclmcalipsoun)
-  CALL bcast(Lcltcalipsoun)
-  CALL bcast(Lclopaquecalipso)
-  CALL bcast(Lclthincalipso)
-  CALL bcast(Lclzopaquecalipso)
-  CALL bcast(Lclcalipsoopaque)
-  CALL bcast(Lclcalipsothin)
-  CALL bcast(Lclcalipsozopaque)
-  CALL bcast(Lclcalipsoopacity)
-  CALL bcast(Lclopaquetemp)
-  CALL bcast(Lclthintemp)
-  CALL bcast(Lclzopaquetemp)
-  CALL bcast(Lclopaquemeanz)
-  CALL bcast(Lclthinmeanz)
-  CALL bcast(Lclthinemis)
-  CALL bcast(Lclopaquemeanzse)
-  CALL bcast(Lclthinmeanzse)
-  CALL bcast(Lclzopaquecalipsose)
-  CALL bcast(LlidarBetaMol532gr)
-  CALL bcast(LcfadLidarsr532gr)
-  CALL bcast(Latb532gr)
-  CALL bcast(LclgrLidar532)
-  CALL bcast(LclhgrLidar532)
-  CALL bcast(LcllgrLidar532)
-  CALL bcast(LclmgrLidar532)
-  CALL bcast(LcltgrLidar532)
-  CALL bcast(LlidarBetaMol355)
-  CALL bcast(LcfadLidarsr355)
-  CALL bcast(Latb355)
-  CALL bcast(Lclatlid)
-  CALL bcast(Lclhatlid)
-  CALL bcast(Lcllatlid)
-  CALL bcast(Lclmatlid)
-  CALL bcast(Lcltatlid)
-  CALL bcast(Lalbisccp)
-  CALL bcast(Lboxptopisccp)
-  CALL bcast(Lboxtauisccp)
-  CALL bcast(Lpctisccp)
-  CALL bcast(Lclisccp)
-  CALL bcast(Ltauisccp)
-  CALL bcast(Lcltisccp)
-  CALL bcast(Lmeantbisccp)
-  CALL bcast(Lmeantbclrisccp)
-  CALL bcast(LclMISR)
-  CALL bcast(Lclcalipso2)
-  CALL bcast(Lcltlidarradar)
-  CALL bcast(Lcloudsat_tcc)
-  CALL bcast(Lcloudsat_tcc2)
-  CALL bcast(Lfracout)
-  CALL bcast(LlidarBetaMol532)
-  CALL bcast(Lcltmodis)
-  CALL bcast(Lclwmodis)
-  CALL bcast(Lclimodis)
-  CALL bcast(Lclhmodis)
-  CALL bcast(Lclmmodis)
-  CALL bcast(Lcllmodis)
-  CALL bcast(Ltautmodis)
-  CALL bcast(Ltauwmodis)
-  CALL bcast(Ltauimodis)
-  CALL bcast(Ltautlogmodis)
-  CALL bcast(Ltauwlogmodis)
-  CALL bcast(Ltauilogmodis)
-  CALL bcast(Lreffclwmodis)
-  CALL bcast(Lreffclimodis)
-  CALL bcast(Lpctmodis)
-  CALL bcast(Llwpmodis)
-  CALL bcast(Liwpmodis)
-  CALL bcast(Lclmodis)
-  CALL bcast(Ltbrttov)
-  CALL bcast(Lptradarflag0)
-  CALL bcast(Lptradarflag1)
-  CALL bcast(Lptradarflag2)
-  CALL bcast(Lptradarflag3)
-  CALL bcast(Lptradarflag4)
-  CALL bcast(Lptradarflag5)
-  CALL bcast(Lptradarflag6)
-  CALL bcast(Lptradarflag7)
-  CALL bcast(Lptradarflag8)
-  CALL bcast(Lptradarflag9)
-  CALL bcast(Lradarpia)
-
-!$OMP BARRIER
-
-  ! Copy instrument flags to cfg structure
-  cfg%Lcloudsat = Lcloudsat
-  cfg%Lcalipso = Lcalipso
-  cfg%LgrLidar532 = LgrLidar532
-  cfg%Latlid = Latlid
-  cfg%Lisccp = Lisccp
-  cfg%Lmodis = Lmodis
-  cfg%Lmisr = Lmisr
-  cfg%Lrttov = Lrttov
-  cfg%Lparasol = Lparasol
-
-    print*,' cfg%Lcloudsat = ',cfg%Lcloudsat
-
-  ! Flag to control output to file
-  cfg%Lwrite_output = .false.
-  if (cfg%Lcloudsat .or. cfg%Lcalipso .or. cfg%LgrLidar532 .or. cfg%Latlid .or. cfg%Lisccp .or. cfg%Lmodis .or. cfg%Lmisr .or. cfg%Lrttov .or. cfg%Lparasol .or. Lfracout) then
-    cfg%Lwrite_output = .true.
-  endif
-
-  ! Output diagnostics
-  i = 1
-
-  if (Lcfaddbze94)        cfg%out_list(i) = 'cfaddbze94'
-  i = i+1
-  if (Ldbze94)        cfg%out_list(i) = 'dbze94'
-  i = i+1
-  if (Latb532)        cfg%out_list(i) = 'atb532'
-  i = i+1
-  if (LcfadLidarsr532)        cfg%out_list(i) = 'cfadLidarsr532'
-  i = i+1
-  if (Lclcalipso)        cfg%out_list(i) = 'clcalipso'
-  i = i+1
-  if (Lclhcalipso)        cfg%out_list(i) = 'clhcalipso'
-  i = i+1
-  if (Lcllcalipso)        cfg%out_list(i) = 'cllcalipso'
-  i = i+1
-  if (Lclmcalipso)        cfg%out_list(i) = 'clmcalipso'
-  i = i+1
-  if (Lcltcalipso)        cfg%out_list(i) = 'cltcalipso'
-  i = i+1
-  if (LparasolRefl)        cfg%out_list(i) = 'parasolRefl'
-  i = i+1
-  if (Lclcalipsoliq)        cfg%out_list(i) = 'clcalipsoliq'
-  i = i+1
-  if (Lclcalipsoice)        cfg%out_list(i) = 'clcalipsoice'
-  i = i+1
-  if (Lclcalipsoun)        cfg%out_list(i) = 'clcalipsoun'
-  i = i+1
-  if (Lclcalipsotmp)        cfg%out_list(i) = 'clcalipsotmp'
-  i = i+1
-  if (Lclcalipsotmpliq)        cfg%out_list(i) = 'clcalipsotmpliq'
-  i = i+1
-  if (Lclcalipsotmpice)        cfg%out_list(i) = 'clcalipsotmpice'
-  i = i+1
-  if (Lclcalipsotmpun)        cfg%out_list(i) = 'clcalipsotmpun'
-  i = i+1
-  if (Lclhcalipsoliq)        cfg%out_list(i) = 'clhcalipsoliq'
-  i = i+1
-  if (Lcllcalipsoliq)        cfg%out_list(i) = 'cllcalipsoliq'
-  i = i+1
-  if (Lclmcalipsoliq)        cfg%out_list(i) = 'clmcalipsoliq'
-  i = i+1
-  if (Lcltcalipsoliq)        cfg%out_list(i) = 'cltcalipsoliq'
-  i = i+1
-  if (Lclhcalipsoice)        cfg%out_list(i) = 'clhcalipsoice'
-  i = i+1
-  if (Lcllcalipsoice)        cfg%out_list(i) = 'cllcalipsoice'
-  i = i+1
-  if (Lclmcalipsoice)        cfg%out_list(i) = 'clmcalipsoice'
-  i = i+1
-  if (Lcltcalipsoice)        cfg%out_list(i) = 'cltcalipsoice'
-  i = i+1
-  if (Lclhcalipsoun)        cfg%out_list(i) = 'clhcalipsoun'
-  i = i+1
-  if (Lcllcalipsoun)        cfg%out_list(i) = 'cllcalipsoun'
-  i = i+1
-  if (Lclmcalipsoun)        cfg%out_list(i) = 'clmcalipsoun'
-  i = i+1
-  if (Lcltcalipsoun)        cfg%out_list(i) = 'cltcalipsoun'
-  i = i+1
-  if (Lclopaquecalipso)        cfg%out_list(i) = 'clopaquecalipso'
-  i = i+1
-  if (Lclthincalipso)        cfg%out_list(i) = 'clthincalipso'
-  i = i+1
-  if (Lclzopaquecalipso)        cfg%out_list(i) = 'clzopaquecalipso'
-  i = i+1
-  if (Lclcalipsoopaque)        cfg%out_list(i) = 'clcalipsoopaque'
-  i = i+1
-  if (Lclcalipsothin)        cfg%out_list(i) = 'clcalipsothin'
-  i = i+1
-  if (Lclcalipsozopaque)        cfg%out_list(i) = 'clcalipsozopaque'
-  i = i+1
-  if (Lclcalipsoopacity)        cfg%out_list(i) = 'clcalipsoopacity'
-  i = i+1
-  if (Lclopaquetemp)        cfg%out_list(i) = 'clopaquetemp'
-  i = i+1
-  if (Lclthintemp)        cfg%out_list(i) = 'clthintemp'
-  i = i+1
-  if (Lclzopaquetemp)        cfg%out_list(i) = 'clzopaquetemp'
-  i = i+1
-  if (Lclopaquemeanz)        cfg%out_list(i) = 'clopaquemeanz'
-  i = i+1
-  if (Lclthinmeanz)        cfg%out_list(i) = 'clthinmeanz'
-  i = i+1
-  if (Lclthinemis)        cfg%out_list(i) = 'clthinemis'
-  i = i+1
-  if (Lclopaquemeanzse)        cfg%out_list(i) = 'clopaquemeanzse'
-  i = i+1
-  if (Lclthinmeanzse)        cfg%out_list(i) = 'clthinmeanzse'
-  i = i+1
-  if (Lclzopaquecalipsose)        cfg%out_list(i) = 'clzopaquecalipsose'
-  i = i+1
-  if (LlidarBetaMol532gr)        cfg%out_list(i) = 'lidarBetaMol532gr'
-  i = i+1
-  if (LcfadLidarsr532gr)        cfg%out_list(i) = 'cfadLidarsr532gr'
-  i = i+1
-  if (Latb532gr)        cfg%out_list(i) = 'atb532gr'
-  i = i+1
-  if (LclgrLidar532)        cfg%out_list(i) = 'clgrLidar532'
-  i = i+1
-  if (LclhgrLidar532)        cfg%out_list(i) = 'clhgrLidar532'
-  i = i+1
-  if (LcllgrLidar532)        cfg%out_list(i) = 'cllgrLidar532'
-  i = i+1
-  if (LclmgrLidar532)        cfg%out_list(i) = 'clmgrLidar532'
-  i = i+1
-  if (LcltgrLidar532)        cfg%out_list(i) = 'cltgrLidar532'
-  i = i+1
-  if (LlidarBetaMol355)        cfg%out_list(i) = 'lidarBetaMol355'
-  i = i+1
-  if (LcfadLidarsr355)        cfg%out_list(i) = 'cfadLidarsr355'
-  i = i+1
-  if (Latb355)        cfg%out_list(i) = 'atb355'
-  i = i+1
-  if (Lclatlid)        cfg%out_list(i) = 'clatlid'
-  i = i+1
-  if (Lclhatlid)        cfg%out_list(i) = 'clhatlid'
-  i = i+1
-  if (Lcllatlid)        cfg%out_list(i) = 'cllatlid'
-  i = i+1
-  if (Lclmatlid)        cfg%out_list(i) = 'clmatlid'
-  i = i+1
-  if (Lcltatlid)        cfg%out_list(i) = 'cltatlid'
-  i = i+1
-  if (Lalbisccp)        cfg%out_list(i) = 'albisccp'
-  i = i+1
-  if (Lboxptopisccp)        cfg%out_list(i) = 'boxptopisccp'
-  i = i+1
-  if (Lboxtauisccp)        cfg%out_list(i) = 'boxtauisccp'
-  i = i+1
-  if (Lpctisccp)        cfg%out_list(i) = 'pctisccp'
-  i = i+1
-  if (Lclisccp)        cfg%out_list(i) = 'clisccp'
-  i = i+1
-  if (Ltauisccp)        cfg%out_list(i) = 'tauisccp'
-  i = i+1
-  if (Lcltisccp)        cfg%out_list(i) = 'cltisccp'
-  i = i+1
-  if (Lmeantbisccp)        cfg%out_list(i) = 'meantbisccp'
-  i = i+1
-  if (Lmeantbclrisccp)        cfg%out_list(i) = 'meantbclrisccp'
-  i = i+1
-  if (LclMISR)        cfg%out_list(i) = 'clMISR'
-  i = i+1
-  if (Lclcalipso2)        cfg%out_list(i) = 'clcalipso2'
-  i = i+1
-  if (Lcltlidarradar)        cfg%out_list(i) = 'cltlidarradar'
-  i = i+1
-  if (Lcloudsat_tcc)        cfg%out_list(i) = 'cloudsat_tcc'
-  i = i+1
-  if (Lcloudsat_tcc2)        cfg%out_list(i) = 'cloudsat_tcc2'
-  i = i+1
-  if (Lfracout)        cfg%out_list(i) = 'fracout'
-  i = i+1
-  if (LlidarBetaMol532)        cfg%out_list(i) = 'lidarBetaMol532'
-  i = i+1
-  if (Lcltmodis)        cfg%out_list(i) = 'cltmodis'
-  i = i+1
-  if (Lclwmodis)        cfg%out_list(i) = 'clwmodis'
-  i = i+1
-  if (Lclimodis)        cfg%out_list(i) = 'climodis'
-  i = i+1
-  if (Lclhmodis)        cfg%out_list(i) = 'clhmodis'
-  i = i+1
-  if (Lclmmodis)        cfg%out_list(i) = 'clmmodis'
-  i = i+1
-  if (Lcllmodis)        cfg%out_list(i) = 'cllmodis'
-  i = i+1
-  if (Ltautmodis)        cfg%out_list(i) = 'tautmodis'
-  i = i+1
-  if (Ltauwmodis)        cfg%out_list(i) = 'tauwmodis'
-  i = i+1
-  if (Ltauimodis)        cfg%out_list(i) = 'tauimodis'
-  i = i+1
-  if (Ltautlogmodis)        cfg%out_list(i) = 'tautlogmodis'
-  i = i+1
-  if (Ltauwlogmodis)        cfg%out_list(i) = 'tauwlogmodis'
-  i = i+1
-  if (Ltauilogmodis)        cfg%out_list(i) = 'tauilogmodis'
-  i = i+1
-  if (Lreffclwmodis)        cfg%out_list(i) = 'reffclwmodis'
-  i = i+1
-  if (Lreffclimodis)        cfg%out_list(i) = 'reffclimodis'
-  i = i+1
-  if (Lpctmodis)        cfg%out_list(i) = 'pctmodis'
-  i = i+1
-  if (Llwpmodis)        cfg%out_list(i) = 'lwpmodis'
-  i = i+1
-  if (Liwpmodis)        cfg%out_list(i) = 'iwpmodis'
-  i = i+1
-  if (Lclmodis)        cfg%out_list(i) = 'clmodis'
-  i = i+1
-  if (Ltbrttov)        cfg%out_list(i) = 'tbrttov'
-  i = i+1
-  if (Lptradarflag0)        cfg%out_list(i) = 'ptradarflag0'
-  i = i+1
-  if (Lptradarflag1)        cfg%out_list(i) = 'ptradarflag1'
-  i = i+1
-  if (Lptradarflag2)        cfg%out_list(i) = 'ptradarflag2'
-  i = i+1
-  if (Lptradarflag3)        cfg%out_list(i) = 'ptradarflag3'
-  i = i+1
-  if (Lptradarflag4)        cfg%out_list(i) = 'ptradarflag4'
-  i = i+1
-  if (Lptradarflag5)        cfg%out_list(i) = 'ptradarflag5'
-  i = i+1
-  if (Lptradarflag6)        cfg%out_list(i) = 'ptradarflag6'
-  i = i+1
-  if (Lptradarflag7)        cfg%out_list(i) = 'ptradarflag7'
-  i = i+1
-  if (Lptradarflag8)        cfg%out_list(i) = 'ptradarflag8'
-  i = i+1
-  if (Lptradarflag9)        cfg%out_list(i) = 'ptradarflag9'
-  i = i+1
-  if (Lradarpia)        cfg%out_list(i) = 'radarpia'
-!  i = i+1 !si on laisse, 108 au lieu de 107
-
-  if (i.gt.107) then
-     print *, 'COSP_IO: wrong number of output diagnostics'
-     print *, i,107
-     stop
-  endif
-
-
-  ! Copy diagnostic flags to cfg structure
-
-   cfg%Lpctisccp = Lpctisccp
-   cfg%Lclisccp = Lclisccp
-   cfg%Lboxptopisccp = Lboxptopisccp
-   cfg%Lboxtauisccp = Lboxtauisccp
-   cfg%Ltauisccp = Ltauisccp
-   cfg%Lcltisccp = Lcltisccp
-   cfg%Lmeantbisccp = Lmeantbisccp
-   cfg%Lmeantbclrisccp = Lmeantbclrisccp
-   cfg%Lalbisccp = Lalbisccp
-   cfg%LclMISR = LclMISR
-   cfg%Lcltmodis = Lcltmodis
-   cfg%Lclwmodis = Lclwmodis
-   cfg%Lclimodis = Lclimodis
-   cfg%Lclhmodis = Lclhmodis
-   cfg%Lclmmodis = Lclmmodis
-   cfg%Lcllmodis = Lcllmodis
-   cfg%Ltautmodis = Ltautmodis
-   cfg%Ltauwmodis = Ltauwmodis
-   cfg%Ltauimodis = Ltauimodis
-   cfg%Ltautlogmodis = Ltautlogmodis
-   cfg%Ltauwlogmodis = Ltauwlogmodis
-   cfg%Ltauilogmodis = Ltauilogmodis
-   cfg%Lreffclwmodis = Lreffclwmodis
-   cfg%Lreffclimodis = Lreffclimodis
-   cfg%Lpctmodis = Lpctmodis
-   cfg%Llwpmodis = Llwpmodis
-   cfg%Liwpmodis = Liwpmodis
-   cfg%Lclmodis = Lclmodis
-   cfg%Latb532 = Latb532
-   cfg%Latb532gr = Latb532gr
-   cfg%Latb355 = Latb355
-   cfg%LlidarBetaMol532 = LlidarBetaMol532
-   cfg%LlidarBetaMol532gr = LlidarBetaMol532gr
-   cfg%LlidarBetaMol355 = LlidarBetaMol355
-   cfg%LcfadLidarsr532 = LcfadLidarsr532
-   cfg%LcfadLidarsr532gr = LcfadLidarsr532gr
-   cfg%LcfadLidarsr355 = LcfadLidarsr355
-   cfg%Lclcalipso2 = Lclcalipso2
-   cfg%Lclcalipso = Lclcalipso
-   cfg%LclgrLidar532 = LclgrLidar532
-   cfg%Lclatlid = Lclatlid
-   cfg%Lclhcalipso = Lclhcalipso
-   cfg%Lcllcalipso = Lcllcalipso
-   cfg%Lclmcalipso = Lclmcalipso
-   cfg%Lcltcalipso = Lcltcalipso
-   cfg%LclhgrLidar532 = LclhgrLidar532
-   cfg%LcllgrLidar532 = LcllgrLidar532
-   cfg%LclmgrLidar532 = LclmgrLidar532
-   cfg%LcltgrLidar532 = LcltgrLidar532
-   cfg%Lclhatlid = Lclhatlid
-   cfg%Lcllatlid = Lcllatlid
-   cfg%Lclmatlid = Lclmatlid
-   cfg%Lcltatlid = Lcltatlid
-   cfg%Lcltlidarradar = Lcltlidarradar
-   cfg%Lcloudsat_tcc = Lcloudsat_tcc
-   cfg%Lcloudsat_tcc2 = Lcloudsat_tcc2
-   cfg%Lclcalipsoliq = Lclcalipsoliq
-   cfg%Lclcalipsoice = Lclcalipsoice
-   cfg%Lclcalipsoun = Lclcalipsoun
-   cfg%Lclcalipsotmp = Lclcalipsotmp
-   cfg%Lclcalipsotmpliq = Lclcalipsotmpliq
-   cfg%Lclcalipsotmpice = Lclcalipsotmpice
-   cfg%Lclcalipsotmpun = Lclcalipsotmpun
-   cfg%Lcltcalipsoliq = Lcltcalipsoliq
-   cfg%Lcltcalipsoice = Lcltcalipsoice
-   cfg%Lcltcalipsoun = Lcltcalipsoun
-   cfg%Lclhcalipsoliq = Lclhcalipsoliq
-   cfg%Lclhcalipsoice = Lclhcalipsoice
-   cfg%Lclhcalipsoun = Lclhcalipsoun
-   cfg%Lclmcalipsoliq = Lclmcalipsoliq
-   cfg%Lclmcalipsoice = Lclmcalipsoice
-   cfg%Lclmcalipsoun = Lclmcalipsoun
-   cfg%Lcllcalipsoliq = Lcllcalipsoliq
-   cfg%Lcllcalipsoice = Lcllcalipsoice
-   cfg%Lcllcalipsoun = Lcllcalipsoun
-   cfg%Lclopaquecalipso = Lclopaquecalipso
-   cfg%Lclthincalipso = Lclthincalipso
-   cfg%Lclzopaquecalipso = Lclzopaquecalipso
-   cfg%Lclcalipsoopaque = Lclcalipsoopaque
-   cfg%Lclcalipsothin = Lclcalipsothin
-   cfg%Lclcalipsozopaque = Lclcalipsozopaque
-   cfg%Lclcalipsoopacity = Lclcalipsoopacity
-   cfg%Lclopaquetemp = Lclopaquetemp
-   cfg%Lclthintemp = Lclthintemp
-   cfg%Lclzopaquetemp = Lclzopaquetemp
-   cfg%Lclopaquemeanz = Lclopaquemeanz
-   cfg%Lclthinmeanz = Lclthinmeanz
-   cfg%Lclthinemis = Lclthinemis
-   cfg%Lclopaquemeanzse = Lclopaquemeanzse
-   cfg%Lclthinmeanzse = Lclthinmeanzse
-   cfg%Lclzopaquecalipsose = Lclzopaquecalipsose
-   cfg%LcfadDbze94 = LcfadDbze94
-   cfg%Ldbze94 = Ldbze94
-   cfg%Lparasolrefl = Lparasolrefl
-   cfg%Ltbrttov = Ltbrttov
-   cfg%Lptradarflag0 = Lptradarflag0
-   cfg%Lptradarflag1 = Lptradarflag1
-   cfg%Lptradarflag2 = Lptradarflag2
-   cfg%Lptradarflag3 = Lptradarflag3
-   cfg%Lptradarflag4 = Lptradarflag4
-   cfg%Lptradarflag5 = Lptradarflag5
-   cfg%Lptradarflag6 = Lptradarflag6
-   cfg%Lptradarflag7 = Lptradarflag7
-   cfg%Lptradarflag8 = Lptradarflag8
-   cfg%Lptradarflag9 = Lptradarflag9
-   cfg%Lradarpia = Lradarpia
-   cfg%Lfracout = Lfracout
-  
- END SUBROUTINE READ_COSP_OUTPUT_NL
-
-
- SUBROUTINE read_xiosfieldactive(cfg)
-  USE lmdz_xios, ONLY: xios_field_is_active, using_xios
-  implicit none
-  type(cosp_config),intent(inout) :: cfg
-  integer :: i
-
-!COSPv2 local variables
-  logical :: &
-       Lisccp      = .false., & ! Local on/off switch for simulators
-       Lmodis      = .false., & !
-       Lmisr       = .false., & !
-       Lcalipso    = .false., & !
-       LgrLidar532 = .false., & !
-       Latlid      = .false., & !
-       Lcloudsat   = .false., & !
-       Lrttov      = .false., & !
-       Lparasol    = .false., & !
-       Lwrite_output=.false.    ! ecrire un fichier de sortie COSP ! RG voir si on garde
-
-  logical :: Lcfaddbze94,Ldbze94,Latb532,LcfadLidarsr532,Lclcalipso,Lclhcalipso,         &
-             Lcllcalipso,Lclmcalipso,Lcltcalipso,LparasolRefl,Lclcalipsoliq,             &
-             Lclcalipsoice,Lclcalipsoun,Lclcalipsotmp,Lclcalipsotmpliq,Lclcalipsotmpice, &
-             Lclcalipsotmpun,Lclhcalipsoliq,Lcllcalipsoliq,Lclmcalipsoliq,Lcltcalipsoliq,& 
-             Lclhcalipsoice,Lcllcalipsoice,Lclmcalipsoice,Lcltcalipsoice,Lclhcalipsoun,  & 
-             Lcllcalipsoun,Lclmcalipsoun,Lcltcalipsoun,Lclopaquecalipso,Lclthincalipso,  & 
-             Lclzopaquecalipso,Lclcalipsoopaque,Lclcalipsothin,Lclcalipsozopaque,        & 
-             Lclcalipsoopacity,Lclopaquetemp,Lclthintemp,Lclzopaquetemp,Lclopaquemeanz,  &
-             Lclthinmeanz,Lclthinemis,Lclopaquemeanzse,Lclthinmeanzse,Lclzopaquecalipsose,&
-             LlidarBetaMol532gr,LcfadLidarsr532gr,Latb532gr,LclgrLidar532,LclhgrLidar532,&
-             LcllgrLidar532,LclmgrLidar532,LcltgrLidar532,LlidarBetaMol355,              &
-             LcfadLidarsr355,Latb355,Lclatlid,Lclhatlid,Lcllatlid,Lclmatlid,Lcltatlid,   &
-             Lalbisccp,Lboxptopisccp,Lboxtauisccp,Lpctisccp,Lclisccp,Ltauisccp,Lcltisccp,&
-             Lmeantbisccp,Lmeantbclrisccp,LclMISR,Lclcalipso2,Lcltlidarradar,            &
-             Lcloudsat_tcc, Lcloudsat_tcc2,Lfracout,   &
-             LlidarBetaMol532,Lcltmodis,Lclwmodis,Lclimodis,Lclhmodis,Lclmmodis,         &
-             Lcllmodis,Ltautmodis,Ltauwmodis,Ltauimodis,Ltautlogmodis,Ltauwlogmodis,     &
-             Ltauilogmodis,Lreffclwmodis,Lreffclimodis,Lpctmodis,Llwpmodis,Liwpmodis,    &
-             Lclmodis,Ltbrttov,Lptradarflag0,Lptradarflag1,Lptradarflag2,Lptradarflag3,  &
-             Lptradarflag4,Lptradarflag5,Lptradarflag6,Lptradarflag7,Lptradarflag8,      &
-             Lptradarflag9,Lradarpia
-
-        
-  character(len=32) :: out_list(107)
-
- IF (using_xios) THEN
-
-  do i=1,107
-    cfg%out_list(i)=''
-  enddo
-
-! diagnostics
-   Lpctisccp=.false.
-   Lclisccp=.false.
-   Lboxptopisccp=.false.
-   Lboxtauisccp=.false.
-   Ltauisccp=.false.
-   Lcltisccp=.false.
-   Lmeantbisccp=.false.
-   Lmeantbclrisccp=.false.
-   Lalbisccp=.false.
-   LclMISR=.false.
-   Lcltmodis=.false.
-   Lclwmodis=.false.
-   Lclimodis=.false.
-   Lclhmodis=.false.
-   Lclmmodis=.false.
-   Lcllmodis=.false.
-   Ltautmodis=.false.
-   Ltauwmodis=.false.
-   Ltauimodis=.false.
-   Ltautlogmodis=.false.
-   Ltauwlogmodis=.false.
-   Ltauilogmodis=.false.
-   Lreffclwmodis=.false.
-   Lreffclimodis=.false.
-   Lpctmodis=.false.
-   Llwpmodis=.false.
-   Liwpmodis=.false.
-   Lclmodis=.false.
-   Latb532=.false.
-   Latb532gr=.false.
-   Latb355=.false.
-   LlidarBetaMol532=.false.
-   LlidarBetaMol532gr=.false.
-   LlidarBetaMol355=.false.
-   LcfadLidarsr532=.false.
-   LcfadLidarsr532gr=.false.
-   LcfadLidarsr355 =.false.
-   Lclcalipso2=.false.
-   Lclcalipso=.false.
-   LclgrLidar532=.false.
-   Lclatlid=.false.
-   Lclhcalipso=.false.
-   Lcllcalipso=.false.
-   Lclmcalipso=.false.
-   Lcltcalipso=.false.
-   LclhgrLidar532=.false.
-   LcllgrLidar532=.false.
-   LclmgrLidar532 =.false.
-   LcltgrLidar532=.false.
-   Lclhatlid=.false.
-   Lcllatlid=.false.
-   Lclmatlid=.false.
-   Lcltatlid=.false.
-   Lcltlidarradar=.false.
-   Lcloudsat_tcc=.false.
-   Lcloudsat_tcc2=.false.
-   Lclcalipsoliq=.false.
-   Lclcalipsoice=.false.
-   Lclcalipsoun=.false.
-   Lclcalipsotmp=.false.
-   Lclcalipsotmpliq=.false.
-   Lclcalipsotmpice=.false.
-   Lclcalipsotmpun=.false.
-   Lcltcalipsoliq=.false.
-   Lcltcalipsoice=.false.
-   Lcltcalipsoun=.false.
-   Lclhcalipsoliq=.false.
-   Lclhcalipsoice=.false.
-   Lclhcalipsoun=.false.
-   Lclmcalipsoliq=.false.
-   Lclmcalipsoice=.false.
-   Lclmcalipsoun=.false.
-   Lcllcalipsoliq=.false.
-   Lcllcalipsoice=.false.
-   Lcllcalipsoun =.false.
-   Lclopaquecalipso=.false.
-   Lclthincalipso=.false.
-   Lclzopaquecalipso=.false.
-   Lclcalipsoopaque=.false.
-   Lclcalipsothin=.false.
-   Lclcalipsozopaque=.false.
-   Lclcalipsoopacity=.false.
-   Lclopaquetemp=.false.
-   Lclthintemp=.false.
-   Lclzopaquetemp=.false.
-   Lclopaquemeanz=.false.
-   Lclthinmeanz=.false.
-   Lclthinemis=.false.
-   Lclopaquemeanzse=.false.
-   Lclthinmeanzse=.false.
-   Lclzopaquecalipsose=.false.
-   LcfadDbze94=.false.
-   Ldbze94=.false.
-   Lparasolrefl=.false.
-   Ltbrttov=.false.
-   Lptradarflag0=.false.
-   Lptradarflag1=.false.
-   Lptradarflag2=.false.
-   Lptradarflag3=.false.
-   Lptradarflag4=.false.
-   Lptradarflag5=.false.
-   Lptradarflag6=.false.
-   Lptradarflag7=.false.
-   Lptradarflag8=.false.
-   Lptradarflag9=.false.
-   Lradarpia=.false.
-   Lfracout=.false.
-
-
-  IF (is_master) THEN
-! VEREFIER LES CHAMPS DEMANDES DANS .XML
-! 2. Si champs active dans .xml alors mettre la cles de sortie en true
- IF (xios_field_is_active("cllcalipso")) Lcllcalipso=.TRUE.
- IF (xios_field_is_active("clmcalipso")) Lclmcalipso=.TRUE.
- IF (xios_field_is_active("clhcalipso")) Lclhcalipso=.TRUE.
- IF (xios_field_is_active("cltcalipso")) Lcltcalipso=.TRUE.
- IF (xios_field_is_active("cllcalipsoice")) Lcllcalipsoice=.TRUE.
- IF (xios_field_is_active("clmcalipsoice")) Lclmcalipsoice=.TRUE.
- IF (xios_field_is_active("clhcalipsoice")) Lclhcalipsoice=.TRUE.
- IF (xios_field_is_active("cltcalipsoice")) Lcltcalipsoice=.TRUE.
- IF (xios_field_is_active("cllcalipsoliq")) Lcllcalipsoliq=.TRUE.
- IF (xios_field_is_active("clmcalipsoliq")) Lclmcalipsoliq=.TRUE.
- IF (xios_field_is_active("clhcalipsoliq")) Lclhcalipsoliq=.TRUE.
- IF (xios_field_is_active("cltcalipsoliq")) Lcltcalipsoliq=.TRUE.
- IF (xios_field_is_active("cllcalipsoun")) Lcllcalipsoun=.TRUE.
- IF (xios_field_is_active("clmcalipsoun")) Lclmcalipsoun=.TRUE.
- IF (xios_field_is_active("clhcalipsoun")) Lclhcalipsoun=.TRUE.
- IF (xios_field_is_active("cltcalipsoun")) Lcltcalipsoun=.TRUE.
- IF (xios_field_is_active("clcalipso")) Lclcalipso=.TRUE.
- IF (xios_field_is_active("clcalipsoice")) Lclcalipsoice=.TRUE.
- IF (xios_field_is_active("clcalipsoliq")) Lclcalipsoliq=.TRUE.
- IF (xios_field_is_active("clcalipsoun")) Lclcalipsoun=.TRUE.
- IF (xios_field_is_active("clcalipsotmp")) Lclcalipsotmp=.TRUE.
- IF (xios_field_is_active("clcalipsotmpice")) Lclcalipsotmpice=.TRUE.
- IF (xios_field_is_active("clcalipsotmpliq")) Lclcalipsotmpliq=.TRUE.
- IF (xios_field_is_active("clcalipsotmpun")) Lclcalipsotmpun=.TRUE.
-! IF (xios_field_is_active("parasol_crefl")) cfg%LparasolRefl=.TRUE.
-! IF (xios_field_is_active("Ncrefl")) cfg%LparasolRefl=.TRUE.
- IF (xios_field_is_active("cfadLidarsr532")) LcfadLidarsr532=.TRUE.
- IF (xios_field_is_active("atb532")) Latb532=.TRUE.
- IF (xios_field_is_active("lidarBetaMol532")) LlidarBetaMol532=.TRUE.
- IF (xios_field_is_active("clopaquecalipso")) Lclopaquecalipso=.TRUE.
- IF (xios_field_is_active("clthincalipso")) Lclthincalipso=.TRUE.
- IF (xios_field_is_active("clzopaquecalipso")) Lclzopaquecalipso=.TRUE.
- IF (xios_field_is_active("clcalipsoopaque")) Lclcalipsoopaque=.TRUE.
- IF (xios_field_is_active("clcalipsothin")) Lclcalipsothin=.TRUE.
- IF (xios_field_is_active("clcalipsozopaque")) Lclcalipsozopaque=.TRUE.
- IF (xios_field_is_active("clcalipsoopacity")) Lclcalipsoopacity=.TRUE.
- IF (xios_field_is_active("clopaquetemp")) Lclopaquetemp=.TRUE.
- IF (xios_field_is_active("clthintemp")) Lclthintemp=.TRUE.
- IF (xios_field_is_active("clzopaquetemp")) Lclzopaquetemp=.TRUE.
- IF (xios_field_is_active("clopaquemeanz")) Lclopaquemeanz=.TRUE.
- IF (xios_field_is_active("clthinmeanz")) Lclthinmeanz=.TRUE.
- IF (xios_field_is_active("clthinemis")) Lclthinemis=.TRUE.
- IF (xios_field_is_active("clopaquemeanzse")) Lclopaquemeanzse=.TRUE.
- IF (xios_field_is_active("clthinmeanzse")) Lclthinmeanzse=.TRUE.
- IF (xios_field_is_active("clzopaquecalipsose")) Lclzopaquecalipsose=.TRUE.
-!!!! 43 champs CALIPSO
-
- IF (xios_field_is_active("parasolGrid_refl")) LparasolRefl=.TRUE.
- IF (xios_field_is_active("parasolPix_refl")) LparasolRefl=.TRUE.
-!!!! 2 champs PARASOL controles par une seule clef logique
-
- IF (xios_field_is_active("lidarBetaMol532gr")) LlidarBetaMol532gr=.TRUE.
- IF (xios_field_is_active("cfadLidarsr532gr")) LcfadLidarsr532gr=.TRUE.
- IF (xios_field_is_active("atb532gr")) Latb532gr=.TRUE.
- IF (xios_field_is_active("clgrLidar532")) LclgrLidar532=.TRUE.
- IF (xios_field_is_active("clhgrLidar532")) LclhgrLidar532=.TRUE.
- IF (xios_field_is_active("cllgrLidar532")) LcllgrLidar532=.TRUE.
- IF (xios_field_is_active("clmgrLidar532")) LclmgrLidar532=.TRUE.
- IF (xios_field_is_active("cltgrLidar532")) LcltgrLidar532=.TRUE.
-!!!! 8 champs GROUND LIDAR 532 nm
-
- IF (xios_field_is_active("lidarBetaMol355")) LlidarBetaMol355=.TRUE.
- IF (xios_field_is_active("cfadLidarsr355")) LcfadLidarsr355=.TRUE.
- IF (xios_field_is_active("atb355")) Latb355=.TRUE.
- IF (xios_field_is_active("clatlid")) Lclatlid=.TRUE.
- IF (xios_field_is_active("clhatlid")) Lclhatlid=.TRUE.
- IF (xios_field_is_active("cllatlid")) Lcllatlid=.TRUE.
- IF (xios_field_is_active("clmatlid")) Lclmatlid=.TRUE.
- IF (xios_field_is_active("cltatlid")) Lcltatlid=.TRUE.
-!!!! 8 champs ATLID
-
- IF (xios_field_is_active("cfadDbze94")) LcfadDbze94=.TRUE.
- IF (xios_field_is_active("dbze94")) Ldbze94=.TRUE.
- IF (xios_field_is_active("ptradarflag0")) Lptradarflag0=.TRUE.
- IF (xios_field_is_active("ptradarflag1")) Lptradarflag1=.TRUE.
- IF (xios_field_is_active("ptradarflag2")) Lptradarflag2=.TRUE.
- IF (xios_field_is_active("ptradarflag3")) Lptradarflag3=.TRUE.
- IF (xios_field_is_active("ptradarflag4")) Lptradarflag4=.TRUE.
- IF (xios_field_is_active("ptradarflag5")) Lptradarflag5=.TRUE.
- IF (xios_field_is_active("ptradarflag6")) Lptradarflag6=.TRUE.
- IF (xios_field_is_active("ptradarflag7")) Lptradarflag7=.TRUE.
- IF (xios_field_is_active("ptradarflag8")) Lptradarflag8=.TRUE.
- IF (xios_field_is_active("ptradarflag9")) Lptradarflag9=.TRUE.
- IF (xios_field_is_active("radarpia")) Lradarpia=.TRUE.
-!!! 13 champs CLOUDSAT
-
- IF (xios_field_is_active("cltlidarradar")) Lcltlidarradar=.TRUE.
- IF (xios_field_is_active("clcalipso2")) Lclcalipso2=.TRUE.
- IF (xios_field_is_active("cloudsat_tcc")) Lcloudsat_tcc=.TRUE. !COSPv2
- IF (xios_field_is_active("cloudsat_tcc2")) Lcloudsat_tcc2=.TRUE. !COSPv2
-!!! 4 champs CLOUDSAT et CALIPSO
-
- IF (xios_field_is_active("clisccp")) Lclisccp=.TRUE.
- IF (xios_field_is_active("boxtauisccp")) Lboxtauisccp=.TRUE.
- IF (xios_field_is_active("boxptopisccp")) Lboxptopisccp=.TRUE.
- IF (xios_field_is_active("cltisccp")) Lcltisccp=.TRUE.
- IF (xios_field_is_active("pctisccp")) Lpctisccp=.TRUE.
- IF (xios_field_is_active("tauisccp")) Ltauisccp=.TRUE.
- IF (xios_field_is_active("albisccp")) Lalbisccp=.TRUE.
- IF (xios_field_is_active("meantbisccp")) Lmeantbisccp=.TRUE.
- IF (xios_field_is_active("meantbclrisccp")) Lmeantbclrisccp=.TRUE.
-!!! 9 champs ISCCP
-
- IF (xios_field_is_active("misr_fq")) LclMISR=.TRUE.
- IF (xios_field_is_active("misr_meanztop")) LclMISR=.TRUE.
- IF (xios_field_is_active("misr_cldarea")) LclMISR=.TRUE.
-!!! 3 champs MISR controles par une seule clef logique
-
- IF (xios_field_is_active("cllmodis")) Lcllmodis=.TRUE.
- IF (xios_field_is_active("clmmodis")) Lclmmodis=.TRUE.
- IF (xios_field_is_active("clhmodis")) Lclhmodis=.TRUE.
- IF (xios_field_is_active("cltmodis")) Lcltmodis=.TRUE.
- IF (xios_field_is_active("clwmodis")) Lclwmodis=.TRUE.
- IF (xios_field_is_active("climodis")) Lclimodis=.TRUE.
- IF (xios_field_is_active("tautmodis")) Ltautmodis=.TRUE.
- IF (xios_field_is_active("tauwmodis")) Ltauwmodis=.TRUE.
- IF (xios_field_is_active("tauimodis")) Ltauimodis=.TRUE.
- IF (xios_field_is_active("tautlogmodis")) Ltautlogmodis=.TRUE.
- IF (xios_field_is_active("tauilogmodis")) Ltauilogmodis=.TRUE.
- IF (xios_field_is_active("tauwlogmodis")) Ltauwlogmodis=.TRUE.
- IF (xios_field_is_active("reffclwmodis")) Lreffclwmodis=.TRUE.
- IF (xios_field_is_active("reffclimodis")) Lreffclimodis=.TRUE.
- IF (xios_field_is_active("pctmodis")) Lpctmodis=.TRUE.
- IF (xios_field_is_active("lwpmodis")) Llwpmodis=.TRUE.
- IF (xios_field_is_active("iwpmodis")) Liwpmodis=.TRUE.
- IF (xios_field_is_active("modis_ot_vs_ctp")) Lclmodis=.TRUE.
- IF (xios_field_is_active("modis_ot_vs_reffice")) Lclmodis=.TRUE.
- IF (xios_field_is_active("modis_ot_vs_reffliq")) Lclmodis=.TRUE.
-! IF (xios_field_is_active("crimodis")) Lcrimodis=.TRUE. !COSPv2
-! IF (xios_field_is_active("crlmodis")) Lcrlmodis=.TRUE. !COSPv2
-!!! 20 champs MODIS dont 3 champs controles par la clef logique "clmodis"
-
-! IF (xios_field_is_active("tbrttov")) cfg%Ltbrttov=.TRUE.
-! IF (xios_field_is_active("fracout")) Lfracout=.TRUE.
-
-!!! 106 diagnostics en tout dans COSPv2 + fracout (107)
-
-
-! 2.  si champs demande alors activer le simulateur correspondant
-   IF (xios_field_is_active("cllcalipso").OR. &
-       xios_field_is_active("clmcalipso").OR. &
-       xios_field_is_active("clhcalipso").OR. &
-       xios_field_is_active("cltcalipso").OR. &
-       xios_field_is_active("cllcalipsoice").OR. &
-       xios_field_is_active("clmcalipsoice").OR. &
-       xios_field_is_active("clhcalipsoice").OR. &
-       xios_field_is_active("cltcalipsoice").OR. &
-       xios_field_is_active("cllcalipsoliq").OR. &
-       xios_field_is_active("clmcalipsoliq").OR. &
-       xios_field_is_active("clhcalipsoliq").OR. &
-       xios_field_is_active("cltcalipsoliq").OR. &
-       xios_field_is_active("cllcalipsoun").OR. &
-       xios_field_is_active("clmcalipsoun").OR. &
-       xios_field_is_active("clhcalipsoun").OR. &
-       xios_field_is_active("cltcalipsoun").OR. &
-       xios_field_is_active("clcalipso").OR. &
-       xios_field_is_active("clcalipsoice").OR. &
-       xios_field_is_active("clcalipsoliq").OR. &
-       xios_field_is_active("clcalipsoun").OR. &
-       xios_field_is_active("clcalipsotmp").OR. &
-       xios_field_is_active("clcalipsotmpice").OR. &
-       xios_field_is_active("clcalipsotmpliq").OR. &
-       xios_field_is_active("clcalipsotmpun").OR. &
-       xios_field_is_active("cfadLidarsr532").OR. &
-       xios_field_is_active("atb532").OR. &
-       xios_field_is_active("lidarBetaMol532").OR. &
-       xios_field_is_active("clopaquecalipso").OR. &
-       xios_field_is_active("clthincalipso").OR. &
-       xios_field_is_active("clzopaquecalipso").OR. &
-       xios_field_is_active("clcalipsoopaque").OR. &
-       xios_field_is_active("clcalipsothin").OR. &
-       xios_field_is_active("clcalipsozopaque").OR. &
-       xios_field_is_active("clcalipsoopacity").OR. &
-       xios_field_is_active("clopaquetemp").OR. &
-       xios_field_is_active("clthintemp").OR. &
-       xios_field_is_active("clzopaquetemp").OR. &
-       xios_field_is_active("clopaquemeanz").OR. &
-       xios_field_is_active("clthinmeanz").OR. &
-       xios_field_is_active("clthinemis").OR. &
-       xios_field_is_active("clopaquemeanzse").OR. &
-       xios_field_is_active("clthinmeanzse").OR. &
-       xios_field_is_active("clzopaquecalipsose"))  Lcalipso=.TRUE.
-
-    IF (xios_field_is_active("parasolGrid_refl").OR. &
-       xios_field_is_active("parasolPix_refl")) Lparasol=.TRUE.
-
-   IF (xios_field_is_active("lidarBetaMol532gr").OR. &
-       xios_field_is_active("cfadLidarsr532gr").OR. &
-       xios_field_is_active("atb532gr").OR. &
-       xios_field_is_active("clgrLidar532").OR. &
-       xios_field_is_active("clhgrLidar532").OR. &
-       xios_field_is_active("cllgrLidar532").OR. &
-       xios_field_is_active("clmgrLidar532").OR. &
-       xios_field_is_active("cltgrLidar532"))  LgrLidar532=.TRUE.
-
-   IF (xios_field_is_active("lidarBetaMol355").OR. &
-       xios_field_is_active("cfadLidarsr355").OR. &
-       xios_field_is_active("atb355").OR. &
-       xios_field_is_active("clatlid").OR. &
-       xios_field_is_active("clhatlid").OR. &
-       xios_field_is_active("cllatlid").OR. &
-       xios_field_is_active("clmatlid").OR. &
-       xios_field_is_active("cltatlid"))  Latlid=.TRUE.
-
-    IF (xios_field_is_active("cfadDbze94").OR. &
-      xios_field_is_active("dbze94").OR. &
-      xios_field_is_active("ptradarflag0").OR. &
-      xios_field_is_active("ptradarflag1").OR. &
-      xios_field_is_active("ptradarflag2").OR. &
-      xios_field_is_active("ptradarflag3").OR. &
-      xios_field_is_active("ptradarflag4").OR. &
-      xios_field_is_active("ptradarflag5").OR. &
-      xios_field_is_active("ptradarflag6").OR. &
-      xios_field_is_active("ptradarflag7").OR. &
-      xios_field_is_active("ptradarflag8").OR. &
-      xios_field_is_active("ptradarflag9").OR. &
-      xios_field_is_active("radarpia")) Lcloudsat=.TRUE.
-
-    IF (xios_field_is_active("cltlidarradar").OR. &
-      xios_field_is_active("clcalipso2").OR. &
-      xios_field_is_active("cloudsat_tcc").OR. &
-      xios_field_is_active("cloudsat_tcc2")) THEN
-               Lcloudsat=.TRUE.
-               Lcalipso=.TRUE.
-    ENDIF
-
-    IF (xios_field_is_active("clisccp").OR. &     !COSPv2 nouveau nom
-       xios_field_is_active("boxtauisccp").OR. &
-       xios_field_is_active("boxptopisccp").OR. &
-       xios_field_is_active("cltisccp").OR. &     !COSPv2 nouveau nom
-       xios_field_is_active("pctisccp").OR. &     !COSPv2 nouveau nom
-       xios_field_is_active("tauisccp").OR. &
-       xios_field_is_active("albisccp").OR. &
-       xios_field_is_active("meantbisccp").OR. &
-       xios_field_is_active("meantbclrisccp")) Lisccp=.TRUE.
-
-    IF (xios_field_is_active("misr_fq").OR. &
-       xios_field_is_active("misr_meanztop").OR. &
-       xios_field_is_active("misr_cldarea")) Lmisr=.TRUE.
-
-    IF (xios_field_is_active("cllmodis").OR. &
-       xios_field_is_active("clmmodis").OR. &
-       xios_field_is_active("clhmodis").OR. &
-       xios_field_is_active("cltmodis").OR. &
-       xios_field_is_active("clwmodis").OR. &
-       xios_field_is_active("climodis").OR. &
-       xios_field_is_active("tautmodis").OR. &
-       xios_field_is_active("tauwmodis").OR. &
-       xios_field_is_active("tauimodis").OR. &
-       xios_field_is_active("tautlogmodis").OR. &
-       xios_field_is_active("tauilogmodis").OR. &
-       xios_field_is_active("tauwlogmodis").OR. &
-       xios_field_is_active("reffclwmodis").OR. &
-       xios_field_is_active("reffclimodis").OR. &
-       xios_field_is_active("pctmodis").OR. &
-       xios_field_is_active("lwpmodis").OR. &
-       xios_field_is_active("iwpmodis").OR. &
-       xios_field_is_active("modis_ot_vs_ctp").OR. &
-       xios_field_is_active("modis_ot_vs_reffice").OR. &
-       xios_field_is_active("modis_ot_vs_reffliq")) Lmodis=.TRUE.
-!       xios_field_is_active("crimodis").OR. &              !COSPv2 n'existe plus
-!       xios_field_is_active("crlmodis")) Lmodis_sim=.TRUE. !COSPv2 n'existe plus
-
-  ENDIF !   (is_master) 
-
-!$OMP BARRIER
-
-  CALL bcast(Lcloudsat)
-  CALL bcast(Lcalipso)
-  CALL bcast(LgrLidar532)
-  CALL bcast(Latlid)
-  CALL bcast(Lisccp)
-  CALL bcast(Lmodis)
-  CALL bcast(Lmisr)
-  CALL bcast(Lparasol)
-  CALL bcast(Lrttov)
-
-  CALL bcast(Lcfaddbze94)
-  CALL bcast(Ldbze94)
-  CALL bcast(Latb532)
-  CALL bcast(LcfadLidarsr532)
-  CALL bcast(Lclcalipso)
-  CALL bcast(Lclhcalipso)
-  CALL bcast(Lcllcalipso)
-  CALL bcast(Lclmcalipso)
-  CALL bcast(Lcltcalipso)
-  CALL bcast(LparasolRefl)
-  CALL bcast(Lclcalipsoliq)
-  CALL bcast(Lclcalipsoice)
-  CALL bcast(Lclcalipsoun)
-  CALL bcast(Lclcalipsotmp)
-  CALL bcast(Lclcalipsotmpliq)
-  CALL bcast(Lclcalipsotmpice)
-  CALL bcast(Lclcalipsotmpun)
-  CALL bcast(Lclhcalipsoliq)
-  CALL bcast(Lcllcalipsoliq)
-  CALL bcast(Lclmcalipsoliq)
-  CALL bcast(Lcltcalipsoliq)
-  CALL bcast(Lclhcalipsoice)
-  CALL bcast(Lcllcalipsoice)
-  CALL bcast(Lclmcalipsoice)
-  CALL bcast(Lcltcalipsoice)
-  CALL bcast(Lclhcalipsoun)
-  CALL bcast(Lcllcalipsoun)
-  CALL bcast(Lclmcalipsoun)
-  CALL bcast(Lcltcalipsoun)
-  CALL bcast(Lclopaquecalipso)
-  CALL bcast(Lclthincalipso)
-  CALL bcast(Lclzopaquecalipso)
-  CALL bcast(Lclcalipsoopaque)
-  CALL bcast(Lclcalipsothin)
-  CALL bcast(Lclcalipsozopaque)
-  CALL bcast(Lclcalipsoopacity)
-  CALL bcast(Lclopaquetemp)
-  CALL bcast(Lclthintemp)
-  CALL bcast(Lclzopaquetemp)
-  CALL bcast(Lclopaquemeanz)
-  CALL bcast(Lclthinmeanz)
-  CALL bcast(Lclthinemis)
-  CALL bcast(Lclopaquemeanzse)
-  CALL bcast(Lclthinmeanzse)
-  CALL bcast(Lclzopaquecalipsose)
-  CALL bcast(LlidarBetaMol532gr)
-  CALL bcast(LcfadLidarsr532gr)
-  CALL bcast(Latb532gr)
-  CALL bcast(LclgrLidar532)
-  CALL bcast(LclhgrLidar532)
-  CALL bcast(LcllgrLidar532)
-  CALL bcast(LclmgrLidar532)
-  CALL bcast(LcltgrLidar532)
-  CALL bcast(LlidarBetaMol355)
-  CALL bcast(LcfadLidarsr355)
-  CALL bcast(Latb355)
-  CALL bcast(Lclatlid)
-  CALL bcast(Lclhatlid)
-  CALL bcast(Lcllatlid)
-  CALL bcast(Lclmatlid)
-  CALL bcast(Lcltatlid)
-  CALL bcast(Lalbisccp)
-  CALL bcast(Lboxptopisccp)
-  CALL bcast(Lboxtauisccp)
-  CALL bcast(Lpctisccp)
-  CALL bcast(Lclisccp)
-  CALL bcast(Ltauisccp)
-  CALL bcast(Lcltisccp)
-  CALL bcast(Lmeantbisccp)
-  CALL bcast(Lmeantbclrisccp)
-  CALL bcast(LclMISR)
-  CALL bcast(Lclcalipso2)
-  CALL bcast(Lcltlidarradar)
-  CALL bcast(Lcloudsat_tcc)
-  CALL bcast(Lcloudsat_tcc2)
-  CALL bcast(Lfracout)
-  CALL bcast(LlidarBetaMol532)
-  CALL bcast(Lcltmodis)
-  CALL bcast(Lclwmodis)
-  CALL bcast(Lclimodis)
-  CALL bcast(Lclhmodis)
-  CALL bcast(Lclmmodis)
-  CALL bcast(Lcllmodis)
-  CALL bcast(Ltautmodis)
-  CALL bcast(Ltauwmodis)
-  CALL bcast(Ltauimodis)
-  CALL bcast(Ltautlogmodis)
-  CALL bcast(Ltauwlogmodis)
-  CALL bcast(Ltauilogmodis)
-  CALL bcast(Lreffclwmodis)
-  CALL bcast(Lreffclimodis)
-  CALL bcast(Lpctmodis)
-  CALL bcast(Llwpmodis)
-  CALL bcast(Liwpmodis)
-  CALL bcast(Lclmodis)
-  CALL bcast(Ltbrttov)
-  CALL bcast(Lptradarflag0)
-  CALL bcast(Lptradarflag1)
-  CALL bcast(Lptradarflag2)
-  CALL bcast(Lptradarflag3)
-  CALL bcast(Lptradarflag4)
-  CALL bcast(Lptradarflag5)
-  CALL bcast(Lptradarflag6)
-  CALL bcast(Lptradarflag7)
-  CALL bcast(Lptradarflag8)
-  CALL bcast(Lptradarflag9)
-  CALL bcast(Lradarpia)
-
-!    IF (xios_field_is_active("tbrttov")) cfg%Lrttov_sim=.TRUE.
-
-
-  ! Copy diagnostic flags to cfg structure
-! ISCCP simulator  (9 diagnostics)
-   cfg%Lpctisccp = Lpctisccp
-   cfg%Lclisccp = Lclisccp
-   cfg%Lboxptopisccp = Lboxptopisccp
-   cfg%Lboxtauisccp = Lboxtauisccp
-   cfg%Ltauisccp = Ltauisccp
-   cfg%Lcltisccp = Lcltisccp
-   cfg%Lmeantbisccp = Lmeantbisccp
-   cfg%Lmeantbclrisccp = Lmeantbclrisccp
-   cfg%Lalbisccp = Lalbisccp
-
-! CloudSat simulator  (13 diagnostics) 
-   cfg%Ldbze94 = Ldbze94
-   cfg%LcfadDbze94 = LcfadDbze94
-   cfg%Lptradarflag0 = Lptradarflag0
-   cfg%Lptradarflag1 = Lptradarflag1
-   cfg%Lptradarflag2 = Lptradarflag2
-   cfg%Lptradarflag3 = Lptradarflag3
-   cfg%Lptradarflag4 = Lptradarflag4
-   cfg%Lptradarflag5 = Lptradarflag5
-   cfg%Lptradarflag6 = Lptradarflag6
-   cfg%Lptradarflag7 = Lptradarflag7
-   cfg%Lptradarflag8 = Lptradarflag8
-   cfg%Lptradarflag9 = Lptradarflag9
-   cfg%Lradarpia = Lradarpia
-
-! Cloudsat et Calipso  (4 diagnostics)
-   cfg%Lclcalipso2 = Lclcalipso2
-   cfg%Lcltlidarradar = Lcltlidarradar
-   cfg%Lcloudsat_tcc = Lcloudsat_tcc
-   cfg%Lcloudsat_tcc2 = Lcloudsat_tcc2
-
-! CALIPSO simulator  (43 diagnostics)
-   cfg%Latb532 = Latb532
-   cfg%LlidarBetaMol532 = LlidarBetaMol532
-   cfg%LcfadLidarsr532 = LcfadLidarsr532
-   cfg%Lclcalipso = Lclcalipso
-   cfg%Lclhcalipso = Lclhcalipso
-   cfg%Lcllcalipso = Lcllcalipso
-   cfg%Lclmcalipso = Lclmcalipso
-   cfg%Lcltcalipso = Lcltcalipso
-   cfg%Lclcalipsoliq = Lclcalipsoliq
-   cfg%Lclcalipsoice = Lclcalipsoice
-   cfg%Lclcalipsoun = Lclcalipsoun
-   cfg%Lclcalipsotmp = Lclcalipsotmp
-   cfg%Lclcalipsotmpliq = Lclcalipsotmpliq
-   cfg%Lclcalipsotmpice = Lclcalipsotmpice
-   cfg%Lclcalipsotmpun = Lclcalipsotmpun
-   cfg%Lcltcalipsoliq = Lcltcalipsoliq
-   cfg%Lcltcalipsoice = Lcltcalipsoice
-   cfg%Lcltcalipsoun = Lcltcalipsoun
-   cfg%Lclhcalipsoliq = Lclhcalipsoliq
-   cfg%Lclhcalipsoice = Lclhcalipsoice
-   cfg%Lclhcalipsoun = Lclhcalipsoun
-   cfg%Lclmcalipsoliq = Lclmcalipsoliq
-   cfg%Lclmcalipsoice = Lclmcalipsoice
-   cfg%Lclmcalipsoun = Lclmcalipsoun
-   cfg%Lcllcalipsoliq = Lcllcalipsoliq
-   cfg%Lcllcalipsoice = Lcllcalipsoice
-   cfg%Lcllcalipsoun = Lcllcalipsoun
-   cfg%Lclopaquecalipso = Lclopaquecalipso
-   cfg%Lclthincalipso = Lclthincalipso
-   cfg%Lclzopaquecalipso = Lclzopaquecalipso
-   cfg%Lclcalipsoopaque = Lclcalipsoopaque
-   cfg%Lclcalipsothin = Lclcalipsothin
-   cfg%Lclcalipsozopaque = Lclcalipsozopaque
-   cfg%Lclcalipsoopacity = Lclcalipsoopacity
-   cfg%Lclopaquetemp = Lclopaquetemp
-   cfg%Lclthintemp = Lclthintemp
-   cfg%Lclzopaquetemp = Lclzopaquetemp
-   cfg%Lclopaquemeanz = Lclopaquemeanz
-   cfg%Lclthinmeanz = Lclthinmeanz
-   cfg%Lclthinemis = Lclthinemis
-   cfg%Lclopaquemeanzse = Lclopaquemeanzse
-   cfg%Lclthinmeanzse = Lclthinmeanzse
-   cfg%Lclzopaquecalipsose = Lclzopaquecalipsose
-
-! PARASOL simulator  (2 diagnostics, 1 clef)
-   cfg%Lparasolrefl = Lparasolrefl
-
-! GROUND LIDAR 532 nm simulator  (8 diagnostics)
-   cfg%Latb532gr = Latb532gr
-   cfg%LlidarBetaMol532gr = LlidarBetaMol532gr
-   cfg%LcfadLidarsr532gr = LcfadLidarsr532gr
-   cfg%LclgrLidar532 = LclgrLidar532
-   cfg%LclhgrLidar532 = LclhgrLidar532
-   cfg%LcllgrLidar532 = LcllgrLidar532
-   cfg%LclmgrLidar532 = LclmgrLidar532
-   cfg%LcltgrLidar532 = LcltgrLidar532
-
-! ATLID simulator  (8 diagnostics)
-   cfg%Latb355 = Latb355
-   cfg%LlidarBetaMol355 = LlidarBetaMol355
-   cfg%LcfadLidarsr355 = LcfadLidarsr355
-   cfg%Lclatlid = Lclatlid
-   cfg%Lclhatlid = Lclhatlid
-   cfg%Lcllatlid = Lcllatlid
-   cfg%Lclmatlid = Lclmatlid
-   cfg%Lcltatlid = Lcltatlid
-
-! MISR simulator   (3 diagnostics, 1 clef)
-  cfg%LclMISR = LclMISR
-
-! RTTOV  (1 diagnostic)
-  cfg%Ltbrttov = Ltbrttov
-
-! MODIS simulator   (20 diagnostics, 18 clefs)
-  cfg%Lcltmodis=Lcltmodis
-  cfg%Lclwmodis=Lclwmodis
-  cfg%Lclimodis=Lclimodis
-  cfg%Lclhmodis=Lclhmodis
-  cfg%Lclmmodis=Lclmmodis
-  cfg%Lcllmodis=Lcllmodis
-  cfg%Ltautmodis=Ltautmodis
-  cfg%Ltauwmodis=Ltauwmodis
-  cfg%Ltauimodis=Ltauimodis
-  cfg%Ltautlogmodis=Ltautlogmodis
-  cfg%Ltauwlogmodis=Ltauwlogmodis
-  cfg%Ltauilogmodis=Ltauilogmodis
-  cfg%Lreffclwmodis=Lreffclwmodis
-  cfg%Lreffclimodis=Lreffclimodis
-  cfg%Lpctmodis=Lpctmodis
-  cfg%Llwpmodis=Llwpmodis
-  cfg%Liwpmodis=Liwpmodis
-  cfg%Lclmodis=Lclmodis
-
-! Others
-  cfg%Lfracout=Lfracout
-
-! Copy instrument flags to cfg structure
-  cfg%Lcloudsat = Lcloudsat
-  cfg%Lcalipso = Lcalipso
-  cfg%LgrLidar532 = LgrLidar532
-  cfg%Latlid = Latlid
-  cfg%Lparasol = Lparasol
-  cfg%Lisccp = Lisccp
-  cfg%Lmodis = Lmodis
-  cfg%Lmisr = Lmisr
-  cfg%Lrttov = Lrttov
-  if (cfg%Lcloudsat .or. cfg%Lcalipso .or. cfg%LgrLidar532 .or. cfg%Latlid .or. cfg%Lisccp .or. cfg%Lmodis .or. cfg%Lmisr .or. cfg%Lrttov .or. cfg%Lparasol .or. cfg%Lfracout) then
-   cfg%Lwrite_output=.TRUE.
- endif 
-
- ENDIF !using_xios
-
-  END SUBROUTINE read_xiosfieldactive
-
-END MODULE lmdz_cosp_read_outputkeys
Index: /LMDZ6/trunk/libf/phylmd/cospv2/lmdz_cosp_read_outputkeys.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cospv2/lmdz_cosp_read_outputkeys.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/cospv2/lmdz_cosp_read_outputkeys.f90	(revision 5268)
@@ -0,0 +1,1717 @@
+!!!=============================================================================
+!!! AI mars 2018
+!!  Module permettant de controler les cles de sorties cosp
+!!  pour LMDZ
+!! 1. on initialise les cles au 1er passage a cosp itap de la physique = 1
+!! 2. on garde la routine de lecture du fichier namelist cosp_out...txt pour le
+!!    cas non XIOS (ioipsl)
+!! 3. on rajoutte une subroutine qui interoge XIOS si les champs sont demandes
+!!    dans les xml alors on les active et on active les simulateurs
+!!    correspondant 
+!!
+!!! RG janvier 2019
+!!  Mise a jour pour avoir toutes les sorties de COSPv2
+!!  Changement de nom a "lmdz_cosp_read_outputkeys"
+!!!=============================================================================
+
+module lmdz_cosp_read_outputkeys
+
+  USE mod_phys_lmdz_para
+
+  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  ! TYPE COSP_CONFIG
+  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  TYPE COSP_CONFIG
+     logical :: &
+         Lwrite_output,    & ! Control for output file
+         Lfracout,         & ! Control SCOPS cloud fraction out ?
+! simulators
+         Lcloudsat,        & ! CLOUDSAT simulator on/off switch 
+         Lcalipso,         & ! CALIPSO simulator on/off switch 
+	 LgrLidar532,      & ! GROUND LIDAR simulator on/off switch
+         Latlid,           & ! ATLID simulator on/off switch
+         Lisccp,           & ! ISCCP simulator on/off switch
+         Lmodis,           & ! MODIS simulatoe on/off switch
+         Lmisr,            & ! MISR simulator on/off switch 
+         Lrttov,           & ! RTTOV simulator on/off switch 
+         Lparasol,         & ! PARASOL simulator on/off switch
+
+! diagnostics 
+         Lpctisccp,        & ! ISCCP mean cloud top pressure
+         Lclisccp,         & ! ISCCP cloud area fraction
+         Lboxptopisccp,    & ! ISCCP CTP in each column
+         Lboxtauisccp,     & ! ISCCP optical epth in each column
+         Ltauisccp,        & ! ISCCP mean optical depth
+         Lcltisccp,        & ! ISCCP total cloud fraction
+         Lmeantbisccp,     & ! ISCCP mean all-sky 10.5micron brightness temperature
+         Lmeantbclrisccp,  & ! ISCCP mean clear-sky 10.5micron brightness temperature
+         Lalbisccp,        & ! ISCCP mean cloud albedo         
+         LclMISR,          & ! MISR cloud fraction
+         Lcltmodis,        & ! MODIS total cloud fraction
+         Lclwmodis,        & ! MODIS liquid cloud fraction
+         Lclimodis,        & ! MODIS ice cloud fraction
+         Lclhmodis,        & ! MODIS high-level cloud fraction
+         Lclmmodis,        & ! MODIS mid-level cloud fraction
+         Lcllmodis,        & ! MODIS low-level cloud fraction
+         Ltautmodis,       & ! MODIS total cloud optical thicknes
+         Ltauwmodis,       & ! MODIS liquid optical thickness
+         Ltauimodis,       & ! MODIS ice optical thickness
+         Ltautlogmodis,    & ! MODIS total cloud optical thickness (log10 mean)
+         Ltauwlogmodis,    & ! MODIS liquid optical thickness (log10 mean)
+         Ltauilogmodis,    & ! MODIS ice optical thickness (log10 mean)
+         Lreffclwmodis,    & ! MODIS liquid cloud particle size
+         Lreffclimodis,    & ! MODIS ice particle size
+         Lpctmodis,        & ! MODIS cloud top pressure
+         Llwpmodis,        & ! MODIS cloud liquid water path
+         Liwpmodis,        & ! MODIS cloud ice water path
+         Lclmodis,         & ! MODIS cloud area fraction
+         Latb532,          & ! CALIPSO attenuated total backscatter (532nm)
+         Latb532gr,        & ! GROUND LIDAR @ 532NM attenuated total backscatter (532nm)
+         Latb355,          & ! ATLID attenuated total backscatter (355nm)
+         LlidarBetaMol532, & ! CALIPSO molecular backscatter (532nm)         
+         LlidarBetaMol532gr,&! GROUND LIDAR @ 532NM molecular backscatter (532nm)
+         LlidarBetaMol355, & ! ATLID molecular backscatter (355nm) 
+         LcfadLidarsr532,  & ! CALIPSO scattering ratio CFAD
+         LcfadLidarsr532gr,& ! GROUND LIDAR @ 532NM scattering ratio CFAD  
+         LcfadLidarsr355,  & ! ATLID scattering ratio CFAD 
+         Lclcalipso2,      & ! CALIPSO cloud fraction undetected by cloudsat
+         Lclcalipso,       & ! CALIPSO cloud area fraction
+         LclgrLidar532,   & ! GROUND LIDAR @ 532NM cloud area fraction 
+         Lclatlid,         & ! ATLID cloud area fraction 
+         Lclhcalipso,      & ! CALIPSO high-level cloud fraction
+         Lcllcalipso,      & ! CALIPSO low-level cloud fraction
+         Lclmcalipso,      & ! CALIPSO mid-level cloud fraction
+         Lcltcalipso,      & ! CALIPSO total cloud fraction
+         LclhgrLidar532,  & ! GROUND LIDAR @ 532NM high-level cloud fraction 
+         LcllgrLidar532,  & ! GROUND LIDAR @ 532NM low-level cloud fraction 
+         LclmgrLidar532,  & ! GROUND LIDAR @ 532NM mid-level cloud fraction
+         LcltgrLidar532,  & ! GROUND LIDAR @ 532NM total cloud fraction
+         Lclhatlid,        & ! ATLID high-level cloud fraction
+         Lcllatlid,        & ! ATLID low-level cloud fraction  
+         Lclmatlid,        & ! ATLID mid-level cloud fraction 
+         Lcltatlid,        & ! ATLID total cloud fraction
+         Lcltlidarradar,   & ! CALIPSO-CLOUDSAT total cloud fraction
+         Lcloudsat_tcc,    & !
+         Lcloudsat_tcc2,   & !
+         Lclcalipsoliq,    & ! CALIPSO liquid cloud area fraction
+         Lclcalipsoice,    & ! CALIPSO ice cloud area fraction 
+         Lclcalipsoun,     & ! CALIPSO undetected cloud area fraction
+         Lclcalipsotmp,    & ! CALIPSO undetected cloud area fraction
+         Lclcalipsotmpliq, & ! CALIPSO liquid cloud area fraction
+         Lclcalipsotmpice, & ! CALIPSO ice cloud area fraction
+         Lclcalipsotmpun,  & ! CALIPSO undetected cloud area fraction
+         Lcltcalipsoliq,   & ! CALIPSO liquid total cloud fraction
+         Lcltcalipsoice,   & ! CALIPSO ice total cloud fraction
+         Lcltcalipsoun,    & ! CALIPSO undetected total cloud fraction
+         Lclhcalipsoliq,   & ! CALIPSO high-level liquid cloud fraction
+         Lclhcalipsoice,   & ! CALIPSO high-level ice cloud fraction
+         Lclhcalipsoun,    & ! CALIPSO high-level undetected cloud fraction
+         Lclmcalipsoliq,   & ! CALIPSO mid-level liquid cloud fraction
+         Lclmcalipsoice,   & ! CALIPSO mid-level ice cloud fraction
+         Lclmcalipsoun,    & ! CALIPSO mid-level undetected cloud fraction
+         Lcllcalipsoliq,   & ! CALIPSO low-level liquid cloud fraction
+         Lcllcalipsoice,   & ! CALIPSO low-level ice cloud fraction
+         Lcllcalipsoun,    & ! CALIPSO low-level undetected cloud fraction
+         Lclopaquecalipso, & ! CALIPSO opaque cloud cover (2D Map)
+         Lclthincalipso,   & ! CALIPSO thin cloud cover (2D Map)
+         Lclzopaquecalipso,& ! CALIPSO z_opaque altitude (opaque clouds only, 2D Map)
+         Lclcalipsoopaque, & ! CALIPSO opaque cloud profiles 3D fraction 
+         Lclcalipsothin,   & ! CALIPSO thin cloud profiles 3D fraction 
+         Lclcalipsozopaque,& ! CALIPSO z_opaque 3D fraction 
+         Lclcalipsoopacity,& ! CALIPSO opacity 3D fraction 
+         Lclopaquetemp,    & ! CALIPSO opaque cloud temperature 
+         Lclthintemp,      & ! CALIPSO thin cloud temperature
+         Lclzopaquetemp,   & ! CALIPSO z_opaque temperature  
+         Lclopaquemeanz,   & ! CALIPSO opaque cloud altitude  
+         Lclthinmeanz,     & ! CALIPSO thin cloud altitude 
+         Lclthinemis,      & ! CALIPSO thin cloud emissivity
+         Lclopaquemeanzse,   & ! CALIPSO opaque cloud altitude with respect to SE 
+         Lclthinmeanzse,     & ! CALIPSO thin cloud altitude with respect to SE
+         Lclzopaquecalipsose,& ! CALIPSO z_opaque altitude with respect to SE
+         LcfadDbze94,      & ! CLOUDSAT radar reflectivity CFAD
+         Ldbze94,          & ! CLOUDSAT radar reflectivity
+         LparasolRefl,     & ! PARASOL reflectance
+         Ltbrttov,         & ! RTTOV mean clear-sky brightness temperature
+         Lptradarflag0,    & ! CLOUDSAT no precipitation flag
+         Lptradarflag1,    & ! CLOUDSAT rain possible flag
+         Lptradarflag2,    & ! CLOUDSAT rain probable flag
+         Lptradarflag3,    & ! CLOUDSAT rain certain flag
+         Lptradarflag4,    & ! CLOUDSAT snow possible flag
+         Lptradarflag5,    & ! CLOUDSAT snow certain flag
+         Lptradarflag6,    & ! CLOUDSAT mixed-precipitation possible flag
+         Lptradarflag7,    & ! CLOUDSAT mixed-precipitation certain flag
+         Lptradarflag8,    & ! CLOUDSAT heavy rain flag
+         Lptradarflag9,    & ! CLOUDSAT default flag
+         Lradarpia           ! CLOUDSAT PIA
+
+
+!     character(len=32),dimension(:),allocatable :: out_list
+      character(len=32) :: out_list(107)
+  END TYPE COSP_CONFIG       
+
+
+CONTAINS
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+!--------------- SUBROUTINE READ_COSP_OUTPUT_NL -------------------------
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+ SUBROUTINE cosp_outputkeys_init(cfg)
+  implicit none
+  type(cosp_config),intent(inout) :: cfg 
+  character(len=32) :: out_list(107)
+  integer :: i
+                
+   do i=1,107
+      cfg%out_list(i)=''
+   enddo
+
+
+   cfg%Lcloudsat=.false.
+   cfg%Lcalipso=.false.
+   cfg%LgrLidar532=.false.
+   cfg%Latlid=.false.
+   cfg%Lisccp=.false.
+   cfg%Lmodis=.false.
+   cfg%Lmisr=.false.
+   cfg%Lrttov=.false.
+   cfg%Lparasol=.false.
+   cfg%Lwrite_output=.false.
+   cfg%Lfracout=.false.
+
+
+   cfg%Lpctisccp=.false.
+   cfg%Lclisccp=.false.
+   cfg%Lboxptopisccp=.false.
+   cfg%Lboxtauisccp=.false.
+   cfg%Ltauisccp=.false.
+   cfg%Lcltisccp=.false.
+   cfg%Lmeantbisccp=.false.
+   cfg%Lmeantbclrisccp=.false.
+   cfg%Lalbisccp=.false.
+   cfg%LclMISR=.false.
+   cfg%Lcltmodis=.false.
+   cfg%Lclwmodis=.false.
+   cfg%Lclimodis=.false.
+   cfg%Lclhmodis=.false.
+   cfg%Lclmmodis=.false.
+   cfg%Lcllmodis=.false.
+   cfg%Ltautmodis=.false.
+   cfg%Ltauwmodis=.false.
+   cfg%Ltauimodis=.false.
+   cfg%Ltautlogmodis=.false.
+   cfg%Ltauwlogmodis=.false.
+   cfg%Ltauilogmodis=.false.
+   cfg%Lreffclwmodis=.false.
+   cfg%Lreffclimodis=.false.
+   cfg%Lpctmodis=.false.
+   cfg%Llwpmodis=.false.
+   cfg%Liwpmodis=.false.
+   cfg%Lclmodis=.false.
+   cfg%Latb532=.false.
+   cfg%Latb532gr=.false.
+   cfg%Latb355=.false.
+   cfg%LlidarBetaMol532=.false.
+   cfg%LlidarBetaMol532gr=.false.
+   cfg%LlidarBetaMol355=.false.
+   cfg%LcfadLidarsr532=.false.
+   cfg%LcfadLidarsr532gr=.false.
+   cfg%LcfadLidarsr355 =.false.
+   cfg%Lclcalipso2=.false.
+   cfg%Lclcalipso=.false.
+   cfg%LclgrLidar532=.false.
+   cfg%Lclatlid=.false.
+   cfg%Lclhcalipso=.false.
+   cfg%Lcllcalipso=.false.
+   cfg%Lclmcalipso=.false.
+   cfg%Lcltcalipso=.false.
+   cfg%LclhgrLidar532=.false.
+   cfg%LcllgrLidar532=.false.
+   cfg%LclmgrLidar532 =.false.
+   cfg%LcltgrLidar532=.false.
+   cfg%Lclhatlid=.false.
+   cfg%Lcllatlid=.false.
+   cfg%Lclmatlid=.false.
+   cfg%Lcltatlid=.false.
+   cfg%Lcltlidarradar=.false.
+   cfg%Lcloudsat_tcc=.false.
+   cfg%Lcloudsat_tcc2=.false.
+   cfg%Lclcalipsoliq=.false.
+   cfg%Lclcalipsoice=.false.
+   cfg%Lclcalipsoun=.false.
+   cfg%Lclcalipsotmp=.false.
+   cfg%Lclcalipsotmpliq=.false.
+   cfg%Lclcalipsotmpice=.false.
+   cfg%Lclcalipsotmpun=.false.
+   cfg%Lcltcalipsoliq=.false.
+   cfg%Lcltcalipsoice=.false.
+   cfg%Lcltcalipsoun=.false.
+   cfg%Lclhcalipsoliq=.false.
+   cfg%Lclhcalipsoice=.false.
+   cfg%Lclhcalipsoun=.false.
+   cfg%Lclmcalipsoliq=.false.
+   cfg%Lclmcalipsoice=.false.
+   cfg%Lclmcalipsoun=.false.
+   cfg%Lcllcalipsoliq=.false.
+   cfg%Lcllcalipsoice=.false.
+   cfg%Lcllcalipsoun =.false.
+   cfg%Lclopaquecalipso=.false.
+   cfg%Lclthincalipso=.false.
+   cfg%Lclzopaquecalipso=.false.
+   cfg%Lclcalipsoopaque=.false.
+   cfg%Lclcalipsothin=.false.
+   cfg%Lclcalipsozopaque=.false.
+   cfg%Lclcalipsoopacity=.false.
+   cfg%Lclopaquetemp=.false.
+   cfg%Lclthintemp=.false.
+   cfg%Lclzopaquetemp=.false.
+   cfg%Lclopaquemeanz=.false.
+   cfg%Lclthinmeanz=.false.
+   cfg%Lclthinemis=.false.
+   cfg%Lclopaquemeanzse=.false.
+   cfg%Lclthinmeanzse=.false.
+   cfg%Lclzopaquecalipsose=.false.
+   cfg%LcfadDbze94=.false.
+   cfg%Ldbze94=.false.
+   cfg%Lparasolrefl=.false.
+   cfg%Ltbrttov=.false.
+   cfg%Lptradarflag0=.false.
+   cfg%Lptradarflag1=.false.
+   cfg%Lptradarflag2=.false.
+   cfg%Lptradarflag3=.false.
+   cfg%Lptradarflag4=.false.
+   cfg%Lptradarflag5=.false.
+   cfg%Lptradarflag6=.false.
+   cfg%Lptradarflag7=.false.
+   cfg%Lptradarflag8=.false.
+   cfg%Lptradarflag9=.false.
+   cfg%Lradarpia=.false.
+
+ end subroutine cosp_outputkeys_init
+
+
+ SUBROUTINE cosp_outputkeys_test(cfg)
+  implicit none
+  type(cosp_config),intent(out) :: cfg
+  character(len=32) :: out_list(107)
+  integer :: i
+
+   do i=1,107
+      cfg%out_list(i)=''
+   enddo
+
+   cfg%Lcloudsat=.false.
+   cfg%Lcalipso=.true.
+   cfg%LgrLidar532=.false.
+   cfg%Latlid=.false.
+   cfg%Lisccp=.false.
+   cfg%Lmodis=.false.
+   cfg%Lmisr=.false.
+   cfg%Lrttov=.false.
+   cfg%Lparasol=.false.
+   cfg%Lwrite_output=.false.
+!   cfg%Lfracout=.false.
+
+   cfg%Lpctisccp=.false.
+   cfg%Lclisccp=.false.
+   cfg%Lboxptopisccp=.false.
+   cfg%Lboxtauisccp=.false.
+   cfg%Ltauisccp=.false.
+   cfg%Lcltisccp=.false.
+   cfg%Lmeantbisccp=.false.
+   cfg%Lmeantbclrisccp=.false.
+   cfg%Lalbisccp=.false.
+   cfg%LclMISR=.false.
+   cfg%Lcltmodis=.false.
+   cfg%Lclwmodis=.false.
+   cfg%Lclimodis=.false.
+   cfg%Lclhmodis=.false.
+   cfg%Lclmmodis=.false.
+   cfg%Lcllmodis=.false.
+   cfg%Ltautmodis=.false.
+   cfg%Ltauwmodis=.false.
+   cfg%Ltauimodis=.false.
+   cfg%Ltautlogmodis=.false.
+   cfg%Ltauwlogmodis=.false.
+   cfg%Ltauilogmodis=.false.
+   cfg%Lreffclwmodis=.false.
+   cfg%Lreffclimodis=.false.
+   cfg%Lpctmodis=.false.
+   cfg%Llwpmodis=.false.
+   cfg%Liwpmodis=.false.
+   cfg%Lclmodis=.false.
+   cfg%Latb532=.false.
+   cfg%Latb532gr=.false.
+   cfg%Latb355=.false.
+   cfg%LlidarBetaMol532=.false.
+   cfg%LlidarBetaMol532gr=.false.
+   cfg%LlidarBetaMol355=.false.
+   cfg%LcfadLidarsr532=.false.
+   cfg%LcfadLidarsr532gr=.false.
+   cfg%LcfadLidarsr355 =.false.
+   cfg%Lclcalipso2=.false.
+   cfg%Lclcalipso=.false.
+   cfg%LclgrLidar532=.false.
+   cfg%Lclatlid=.false.
+   cfg%Lclhcalipso=.true.
+   cfg%Lcllcalipso=.true.
+   cfg%Lclmcalipso=.true.
+   cfg%Lcltcalipso=.true.
+   cfg%LclhgrLidar532=.false.
+   cfg%LcllgrLidar532=.false.
+   cfg%LclmgrLidar532 =.false.
+   cfg%LcltgrLidar532=.false.
+   cfg%Lclhatlid=.false.
+   cfg%Lcllatlid=.false.
+   cfg%Lclmatlid=.false.
+   cfg%Lcltatlid=.false.
+   cfg%Lcltlidarradar=.false.
+   cfg%Lcloudsat_tcc=.false.
+   cfg%Lcloudsat_tcc2=.false.
+   cfg%Lclcalipsoliq=.false.
+   cfg%Lclcalipsoice=.false.
+   cfg%Lclcalipsoun=.false.
+   cfg%Lclcalipsotmp=.false.
+   cfg%Lclcalipsotmpliq=.false.
+   cfg%Lclcalipsotmpice=.false.
+   cfg%Lclcalipsotmpun=.false.
+   cfg%Lcltcalipsoliq=.false.
+   cfg%Lcltcalipsoice=.false.
+   cfg%Lcltcalipsoun=.false.
+   cfg%Lclhcalipsoliq=.false.
+   cfg%Lclhcalipsoice=.false.
+   cfg%Lclhcalipsoun=.false.
+   cfg%Lclmcalipsoliq=.false.
+   cfg%Lclmcalipsoice=.false.
+   cfg%Lclmcalipsoun=.false.
+   cfg%Lcllcalipsoliq=.false.
+   cfg%Lcllcalipsoice=.false.
+   cfg%Lcllcalipsoun =.false.
+   cfg%Lclopaquecalipso=.false.
+   cfg%Lclthincalipso=.false.
+   cfg%Lclzopaquecalipso=.false.
+   cfg%Lclcalipsoopaque=.false.
+   cfg%Lclcalipsothin=.false.
+   cfg%Lclcalipsozopaque=.false.
+   cfg%Lclcalipsoopacity=.false.
+   cfg%Lclopaquetemp=.false.
+   cfg%Lclthintemp=.false.
+   cfg%Lclzopaquetemp=.false.
+   cfg%Lclopaquemeanz=.false.
+   cfg%Lclthinmeanz=.false.
+   cfg%Lclthinemis=.false.
+   cfg%Lclopaquemeanzse=.false.
+   cfg%Lclthinmeanzse=.false.
+   cfg%Lclzopaquecalipsose=.false.
+   cfg%LcfadDbze94=.false.
+   cfg%Ldbze94=.false.
+   cfg%Lparasolrefl=.false.
+   cfg%Ltbrttov=.false.
+   cfg%Lptradarflag0=.false.
+   cfg%Lptradarflag1=.false.
+   cfg%Lptradarflag2=.false.
+   cfg%Lptradarflag3=.false.
+   cfg%Lptradarflag4=.false.
+   cfg%Lptradarflag5=.false.
+   cfg%Lptradarflag6=.false.
+   cfg%Lptradarflag7=.false.
+   cfg%Lptradarflag8=.false.
+   cfg%Lptradarflag9=.false.
+   cfg%Lradarpia=.false.
+
+ end subroutine cosp_outputkeys_test
+
+
+ SUBROUTINE READ_COSP_OUTPUT_NL(itap,cosp_nl,cfg)
+  USE lmdz_xios, ONLY: xios_field_is_active, using_xios
+  implicit none
+  character(len=*),intent(in) :: cosp_nl
+  type(cosp_config),intent(inout) :: cfg
+  ! Local variables
+  integer :: i, itap
+
+!COSPv2
+  logical, save :: &
+       Lisccp      = .false. ,& ! Local on/off switch for simulators
+       Lmodis      = .false., & !
+       Lmisr       = .false., & !
+       Lcalipso    = .false., & !
+       LgrLidar532 = .false., & !
+       Latlid      = .false., & !
+       Lcloudsat   = .false., & !
+       Lrttov      = .false., & !
+       Lparasol    = .false.    !
+
+
+ logical, save :: Lcfaddbze94,Ldbze94,Latb532,LcfadLidarsr532,Lclcalipso,Lclhcalipso,    &
+             Lcllcalipso,Lclmcalipso,Lcltcalipso,LparasolRefl,Lclcalipsoliq,             &
+             Lclcalipsoice,Lclcalipsoun,Lclcalipsotmp,Lclcalipsotmpliq,Lclcalipsotmpice, &
+             Lclcalipsotmpun,Lclhcalipsoliq,Lcllcalipsoliq,Lclmcalipsoliq,Lcltcalipsoliq,& 
+             Lclhcalipsoice,Lcllcalipsoice,Lclmcalipsoice,Lcltcalipsoice,Lclhcalipsoun,  & 
+             Lcllcalipsoun,Lclmcalipsoun,Lcltcalipsoun,Lclopaquecalipso,Lclthincalipso,  & 
+             Lclzopaquecalipso,Lclcalipsoopaque,Lclcalipsothin,Lclcalipsozopaque,        & 
+             Lclcalipsoopacity,Lclopaquetemp,Lclthintemp,Lclzopaquetemp,Lclopaquemeanz,  &
+             Lclthinmeanz,Lclthinemis,Lclopaquemeanzse,Lclthinmeanzse,Lclzopaquecalipsose,&
+             LlidarBetaMol532gr,LcfadLidarsr532gr,Latb532gr,LclgrLidar532,LclhgrLidar532,&
+             LcllgrLidar532,LclmgrLidar532,LcltgrLidar532,LlidarBetaMol355,              &
+             LcfadLidarsr355,Latb355,Lclatlid,Lclhatlid,Lcllatlid,Lclmatlid,Lcltatlid,   &
+             Lalbisccp,Lboxptopisccp,Lboxtauisccp,Lpctisccp,Lclisccp,Ltauisccp,Lcltisccp,&
+             Lmeantbisccp,Lmeantbclrisccp,LclMISR,Lclcalipso2,Lcltlidarradar,            &
+             Lcloudsat_tcc, Lcloudsat_tcc2,Lfracout,   &
+             LlidarBetaMol532,Lcltmodis,Lclwmodis,Lclimodis,Lclhmodis,Lclmmodis,         &
+             Lcllmodis,Ltautmodis,Ltauwmodis,Ltauimodis,Ltautlogmodis,Ltauwlogmodis,     &
+             Ltauilogmodis,Lreffclwmodis,Lreffclimodis,Lpctmodis,Llwpmodis,Liwpmodis,    &
+             Lclmodis,Ltbrttov,Lptradarflag0,Lptradarflag1,Lptradarflag2,Lptradarflag3,  &
+             Lptradarflag4,Lptradarflag5,Lptradarflag6,Lptradarflag7,Lptradarflag8,      &
+             Lptradarflag9,Lradarpia
+
+  namelist/COSP_OUTPUT/Lcfaddbze94,Ldbze94,Latb532,LcfadLidarsr532,Lclcalipso,           &
+                       Lclhcalipso,Lcllcalipso,Lclmcalipso,Lcltcalipso,LparasolRefl,     &
+                       Lclcalipsoliq,Lclcalipsoice,Lclcalipsoun,Lclcalipsotmp,           &
+                       Lclcalipsotmpliq,Lclcalipsotmpice,Lclcalipsotmpun,Lclhcalipsoliq, &
+                       Lcllcalipsoliq,Lclmcalipsoliq,Lcltcalipsoliq,Lclhcalipsoice,      &
+                       Lcllcalipsoice,Lclmcalipsoice,Lcltcalipsoice,Lclhcalipsoun,       &
+                       Lcllcalipsoun,Lclmcalipsoun,Lcltcalipsoun,Lclopaquecalipso,       &
+                       Lclthincalipso,Lclzopaquecalipso,Lclcalipsoopaque,Lclcalipsothin, &
+                       Lclcalipsozopaque,Lclcalipsoopacity,Lclopaquetemp,Lclthintemp,    &
+                       Lclzopaquetemp,Lclopaquemeanz,Lclthinmeanz,Lclthinemis,           &
+                       Lclopaquemeanzse,Lclthinmeanzse,Lclzopaquecalipsose,              &
+                       LlidarBetaMol532gr,LcfadLidarsr532gr,Latb532gr,LclgrLidar532,     &
+                       LclhgrLidar532,LcllgrLidar532,LclmgrLidar532,LcltgrLidar532,      &
+                       LlidarBetaMol355,LcfadLidarsr355,Latb355,Lclatlid,                &
+                       Lclhatlid,Lcllatlid,Lclmatlid,Lcltatlid,Lalbisccp,Lboxptopisccp,  &
+                       Lboxtauisccp,Lpctisccp,Lclisccp,Ltauisccp,Lcltisccp,Lmeantbisccp, &
+                       Lmeantbclrisccp,LclMISR,Lclcalipso2,Lcltlidarradar,               &
+                       Lcloudsat_tcc, Lcloudsat_tcc2, Lfracout,                          &
+                       LlidarBetaMol532,Lcltmodis,Lclwmodis,Lclimodis,Lclhmodis,         &
+                       Lclmmodis,Lcllmodis,Ltautmodis,Ltauwmodis,Ltauimodis,             &
+                       Ltautlogmodis,Ltauwlogmodis,Ltauilogmodis,Lreffclwmodis,          &
+                       Lreffclimodis,Lpctmodis,Llwpmodis,Liwpmodis,Lclmodis,Ltbrttov,    &
+                       Lptradarflag0,Lptradarflag1,Lptradarflag2,Lptradarflag3,          &
+                       Lptradarflag4,Lptradarflag5,Lptradarflag6,Lptradarflag7,          &
+                       Lptradarflag8,Lptradarflag9,Lradarpia
+
+  do i=1,107
+    cfg%out_list(i)=''
+  enddo
+  
+! Lecture du fichier namelist
+  IF (is_master) THEN
+    open(10,file=cosp_nl,status='old')
+    read(10,nml=cosp_output)
+    close(10)
+  ENDIF
+
+  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  ! Which simulators need to be run? Look at which outputs are requested.
+  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  if (Lpctisccp .or. Lclisccp .or. Lboxptopisccp .or.  Lboxtauisccp .or. Ltauisccp .or. &
+       Lcltisccp .or. Lmeantbisccp .or. Lmeantbclrisccp .or. Lalbisccp) Lisccp = .true.
+  if (LclMISR) Lmisr = .true.
+  if (Lcltmodis .or. Lclwmodis .or. Lclimodis .or. Lclhmodis .or. Lclmmodis .or.         &
+       Lcllmodis .or. Ltautmodis .or. Ltauwmodis .or. Ltauimodis .or. Ltautlogmodis .or. &
+       Ltauwlogmodis .or. Ltauilogmodis .or. Lreffclwmodis .or. Lreffclimodis .or.       &
+       Lpctmodis .or. Llwpmodis .or. Liwpmodis .or. Lclmodis) Lmodis = .true.
+  if (Lclcalipso2 .or. Lclcalipso .or.  Lclhcalipso .or. Lcllcalipso .or. Lclmcalipso    &
+       .or. Lcltcalipso .or. Lcltlidarradar .or. Lclcalipsoliq .or. Lclcalipsoice .or.   &
+       Lclcalipsoun .or. Lclcalipsotmp .or. Lclcalipsotmpliq .or. Lclcalipsotmpice .or.  &
+       Lclcalipsotmpun .or. Lcltcalipsoliq .or. Lcltcalipsoice .or. Lcltcalipsoun .or.   &
+       Lclhcalipsoliq .or. Lclhcalipsoice .or. Lclhcalipsoun .or. Lclmcalipsoliq .or.    &
+       Lclmcalipsoice .or. Lclmcalipsoun .or. Lcllcalipsoliq .or. Lcllcalipsoice .or.    &
+       Lcllcalipsoun .or. LlidarBetaMol532 .or. LcfadLidarsr532 .or. Lcltlidarradar .or. &
+       Lcltlidarradar .or. Lclopaquecalipso .or. Lclthincalipso .or. Lclzopaquecalipso   &
+       .or. Lclcalipsoopaque .or. Lclcalipsothin .or. Lclcalipsozopaque .or.             &
+       Lclcalipsoopacity .or. Lclopaquetemp .or. Lclthintemp .or. Lclzopaquetemp .or.    &
+       Lclopaquemeanz .or. Lclthinmeanz .or. Lclthinemis .or. Lclopaquemeanzse .or.      & 
+       Lclthinmeanzse .or. Lclzopaquecalipsose) Lcalipso = .true. 
+
+  if (LlidarBetaMol532gr .or. LcfadLidarsr532gr .or. Latb532gr .or. LclgrLidar532 .or.  & 
+       LclhgrLidar532 .or. LcllgrLidar532 .or. LclmgrLidar532 .or. LcltgrLidar532)   & 
+       LgrLidar532 = .true.
+
+  if (LlidarBetaMol355 .or. LcfadLidarsr355 .or. Latb355 .or. Lclatlid .or.              & 
+       Lclhatlid .or. Lcllatlid .or. Lclmatlid .or. Lcltatlid)                           & 
+       Latlid = .true. 
+
+  if (LcfadDbze94 .or. Ldbze94 .or. Lcltlidarradar .or. Lptradarflag0 .or. Lptradarflag1 &
+       .or. Lptradarflag2 .or. Lptradarflag3 .or. Lptradarflag4 .or. Lptradarflag5 .or.  &
+       Lptradarflag6 .or. Lptradarflag7 .or. Lptradarflag8 .or. Lptradarflag9 .or.       &
+       Lradarpia) Lcloudsat = .true.
+  if (Lparasolrefl) Lparasol = .true.
+  if (Ltbrttov) Lrttov = .true.
+
+  CALL bcast(Lcloudsat)
+  CALL bcast(Lcalipso)
+  CALL bcast(LgrLidar532)
+  CALL bcast(Latlid)
+  CALL bcast(Lparasol)
+  CALL bcast(Lisccp)
+  CALL bcast(Lmodis)
+  CALL bcast(Lmisr)
+  CALL bcast(Lrttov)
+
+  CALL bcast(Lcfaddbze94)
+  CALL bcast(Ldbze94)
+  CALL bcast(Latb532)
+  CALL bcast(LcfadLidarsr532)
+  CALL bcast(Lclcalipso)
+  CALL bcast(Lclhcalipso)
+  CALL bcast(Lcllcalipso)
+  CALL bcast(Lclmcalipso)
+  CALL bcast(Lcltcalipso)
+  CALL bcast(LparasolRefl)
+  CALL bcast(Lclcalipsoliq)
+  CALL bcast(Lclcalipsoice)
+  CALL bcast(Lclcalipsoun)
+  CALL bcast(Lclcalipsotmp)
+  CALL bcast(Lclcalipsotmpliq)
+  CALL bcast(Lclcalipsotmpice)
+  CALL bcast(Lclcalipsotmpun)
+  CALL bcast(Lclhcalipsoliq)
+  CALL bcast(Lcllcalipsoliq)
+  CALL bcast(Lclmcalipsoliq)
+  CALL bcast(Lcltcalipsoliq)
+  CALL bcast(Lclhcalipsoice)
+  CALL bcast(Lcllcalipsoice)
+  CALL bcast(Lclmcalipsoice)
+  CALL bcast(Lcltcalipsoice)
+  CALL bcast(Lclhcalipsoun)
+  CALL bcast(Lcllcalipsoun)
+  CALL bcast(Lclmcalipsoun)
+  CALL bcast(Lcltcalipsoun)
+  CALL bcast(Lclopaquecalipso)
+  CALL bcast(Lclthincalipso)
+  CALL bcast(Lclzopaquecalipso)
+  CALL bcast(Lclcalipsoopaque)
+  CALL bcast(Lclcalipsothin)
+  CALL bcast(Lclcalipsozopaque)
+  CALL bcast(Lclcalipsoopacity)
+  CALL bcast(Lclopaquetemp)
+  CALL bcast(Lclthintemp)
+  CALL bcast(Lclzopaquetemp)
+  CALL bcast(Lclopaquemeanz)
+  CALL bcast(Lclthinmeanz)
+  CALL bcast(Lclthinemis)
+  CALL bcast(Lclopaquemeanzse)
+  CALL bcast(Lclthinmeanzse)
+  CALL bcast(Lclzopaquecalipsose)
+  CALL bcast(LlidarBetaMol532gr)
+  CALL bcast(LcfadLidarsr532gr)
+  CALL bcast(Latb532gr)
+  CALL bcast(LclgrLidar532)
+  CALL bcast(LclhgrLidar532)
+  CALL bcast(LcllgrLidar532)
+  CALL bcast(LclmgrLidar532)
+  CALL bcast(LcltgrLidar532)
+  CALL bcast(LlidarBetaMol355)
+  CALL bcast(LcfadLidarsr355)
+  CALL bcast(Latb355)
+  CALL bcast(Lclatlid)
+  CALL bcast(Lclhatlid)
+  CALL bcast(Lcllatlid)
+  CALL bcast(Lclmatlid)
+  CALL bcast(Lcltatlid)
+  CALL bcast(Lalbisccp)
+  CALL bcast(Lboxptopisccp)
+  CALL bcast(Lboxtauisccp)
+  CALL bcast(Lpctisccp)
+  CALL bcast(Lclisccp)
+  CALL bcast(Ltauisccp)
+  CALL bcast(Lcltisccp)
+  CALL bcast(Lmeantbisccp)
+  CALL bcast(Lmeantbclrisccp)
+  CALL bcast(LclMISR)
+  CALL bcast(Lclcalipso2)
+  CALL bcast(Lcltlidarradar)
+  CALL bcast(Lcloudsat_tcc)
+  CALL bcast(Lcloudsat_tcc2)
+  CALL bcast(Lfracout)
+  CALL bcast(LlidarBetaMol532)
+  CALL bcast(Lcltmodis)
+  CALL bcast(Lclwmodis)
+  CALL bcast(Lclimodis)
+  CALL bcast(Lclhmodis)
+  CALL bcast(Lclmmodis)
+  CALL bcast(Lcllmodis)
+  CALL bcast(Ltautmodis)
+  CALL bcast(Ltauwmodis)
+  CALL bcast(Ltauimodis)
+  CALL bcast(Ltautlogmodis)
+  CALL bcast(Ltauwlogmodis)
+  CALL bcast(Ltauilogmodis)
+  CALL bcast(Lreffclwmodis)
+  CALL bcast(Lreffclimodis)
+  CALL bcast(Lpctmodis)
+  CALL bcast(Llwpmodis)
+  CALL bcast(Liwpmodis)
+  CALL bcast(Lclmodis)
+  CALL bcast(Ltbrttov)
+  CALL bcast(Lptradarflag0)
+  CALL bcast(Lptradarflag1)
+  CALL bcast(Lptradarflag2)
+  CALL bcast(Lptradarflag3)
+  CALL bcast(Lptradarflag4)
+  CALL bcast(Lptradarflag5)
+  CALL bcast(Lptradarflag6)
+  CALL bcast(Lptradarflag7)
+  CALL bcast(Lptradarflag8)
+  CALL bcast(Lptradarflag9)
+  CALL bcast(Lradarpia)
+
+!$OMP BARRIER
+
+  ! Copy instrument flags to cfg structure
+  cfg%Lcloudsat = Lcloudsat
+  cfg%Lcalipso = Lcalipso
+  cfg%LgrLidar532 = LgrLidar532
+  cfg%Latlid = Latlid
+  cfg%Lisccp = Lisccp
+  cfg%Lmodis = Lmodis
+  cfg%Lmisr = Lmisr
+  cfg%Lrttov = Lrttov
+  cfg%Lparasol = Lparasol
+
+    print*,' cfg%Lcloudsat = ',cfg%Lcloudsat
+
+  ! Flag to control output to file
+  cfg%Lwrite_output = .false.
+  if (cfg%Lcloudsat .or. cfg%Lcalipso .or. cfg%LgrLidar532 .or. cfg%Latlid .or. cfg%Lisccp .or. cfg%Lmodis .or. cfg%Lmisr .or. cfg%Lrttov .or. cfg%Lparasol .or. Lfracout) then
+    cfg%Lwrite_output = .true.
+  endif
+
+  ! Output diagnostics
+  i = 1
+
+  if (Lcfaddbze94)        cfg%out_list(i) = 'cfaddbze94'
+  i = i+1
+  if (Ldbze94)        cfg%out_list(i) = 'dbze94'
+  i = i+1
+  if (Latb532)        cfg%out_list(i) = 'atb532'
+  i = i+1
+  if (LcfadLidarsr532)        cfg%out_list(i) = 'cfadLidarsr532'
+  i = i+1
+  if (Lclcalipso)        cfg%out_list(i) = 'clcalipso'
+  i = i+1
+  if (Lclhcalipso)        cfg%out_list(i) = 'clhcalipso'
+  i = i+1
+  if (Lcllcalipso)        cfg%out_list(i) = 'cllcalipso'
+  i = i+1
+  if (Lclmcalipso)        cfg%out_list(i) = 'clmcalipso'
+  i = i+1
+  if (Lcltcalipso)        cfg%out_list(i) = 'cltcalipso'
+  i = i+1
+  if (LparasolRefl)        cfg%out_list(i) = 'parasolRefl'
+  i = i+1
+  if (Lclcalipsoliq)        cfg%out_list(i) = 'clcalipsoliq'
+  i = i+1
+  if (Lclcalipsoice)        cfg%out_list(i) = 'clcalipsoice'
+  i = i+1
+  if (Lclcalipsoun)        cfg%out_list(i) = 'clcalipsoun'
+  i = i+1
+  if (Lclcalipsotmp)        cfg%out_list(i) = 'clcalipsotmp'
+  i = i+1
+  if (Lclcalipsotmpliq)        cfg%out_list(i) = 'clcalipsotmpliq'
+  i = i+1
+  if (Lclcalipsotmpice)        cfg%out_list(i) = 'clcalipsotmpice'
+  i = i+1
+  if (Lclcalipsotmpun)        cfg%out_list(i) = 'clcalipsotmpun'
+  i = i+1
+  if (Lclhcalipsoliq)        cfg%out_list(i) = 'clhcalipsoliq'
+  i = i+1
+  if (Lcllcalipsoliq)        cfg%out_list(i) = 'cllcalipsoliq'
+  i = i+1
+  if (Lclmcalipsoliq)        cfg%out_list(i) = 'clmcalipsoliq'
+  i = i+1
+  if (Lcltcalipsoliq)        cfg%out_list(i) = 'cltcalipsoliq'
+  i = i+1
+  if (Lclhcalipsoice)        cfg%out_list(i) = 'clhcalipsoice'
+  i = i+1
+  if (Lcllcalipsoice)        cfg%out_list(i) = 'cllcalipsoice'
+  i = i+1
+  if (Lclmcalipsoice)        cfg%out_list(i) = 'clmcalipsoice'
+  i = i+1
+  if (Lcltcalipsoice)        cfg%out_list(i) = 'cltcalipsoice'
+  i = i+1
+  if (Lclhcalipsoun)        cfg%out_list(i) = 'clhcalipsoun'
+  i = i+1
+  if (Lcllcalipsoun)        cfg%out_list(i) = 'cllcalipsoun'
+  i = i+1
+  if (Lclmcalipsoun)        cfg%out_list(i) = 'clmcalipsoun'
+  i = i+1
+  if (Lcltcalipsoun)        cfg%out_list(i) = 'cltcalipsoun'
+  i = i+1
+  if (Lclopaquecalipso)        cfg%out_list(i) = 'clopaquecalipso'
+  i = i+1
+  if (Lclthincalipso)        cfg%out_list(i) = 'clthincalipso'
+  i = i+1
+  if (Lclzopaquecalipso)        cfg%out_list(i) = 'clzopaquecalipso'
+  i = i+1
+  if (Lclcalipsoopaque)        cfg%out_list(i) = 'clcalipsoopaque'
+  i = i+1
+  if (Lclcalipsothin)        cfg%out_list(i) = 'clcalipsothin'
+  i = i+1
+  if (Lclcalipsozopaque)        cfg%out_list(i) = 'clcalipsozopaque'
+  i = i+1
+  if (Lclcalipsoopacity)        cfg%out_list(i) = 'clcalipsoopacity'
+  i = i+1
+  if (Lclopaquetemp)        cfg%out_list(i) = 'clopaquetemp'
+  i = i+1
+  if (Lclthintemp)        cfg%out_list(i) = 'clthintemp'
+  i = i+1
+  if (Lclzopaquetemp)        cfg%out_list(i) = 'clzopaquetemp'
+  i = i+1
+  if (Lclopaquemeanz)        cfg%out_list(i) = 'clopaquemeanz'
+  i = i+1
+  if (Lclthinmeanz)        cfg%out_list(i) = 'clthinmeanz'
+  i = i+1
+  if (Lclthinemis)        cfg%out_list(i) = 'clthinemis'
+  i = i+1
+  if (Lclopaquemeanzse)        cfg%out_list(i) = 'clopaquemeanzse'
+  i = i+1
+  if (Lclthinmeanzse)        cfg%out_list(i) = 'clthinmeanzse'
+  i = i+1
+  if (Lclzopaquecalipsose)        cfg%out_list(i) = 'clzopaquecalipsose'
+  i = i+1
+  if (LlidarBetaMol532gr)        cfg%out_list(i) = 'lidarBetaMol532gr'
+  i = i+1
+  if (LcfadLidarsr532gr)        cfg%out_list(i) = 'cfadLidarsr532gr'
+  i = i+1
+  if (Latb532gr)        cfg%out_list(i) = 'atb532gr'
+  i = i+1
+  if (LclgrLidar532)        cfg%out_list(i) = 'clgrLidar532'
+  i = i+1
+  if (LclhgrLidar532)        cfg%out_list(i) = 'clhgrLidar532'
+  i = i+1
+  if (LcllgrLidar532)        cfg%out_list(i) = 'cllgrLidar532'
+  i = i+1
+  if (LclmgrLidar532)        cfg%out_list(i) = 'clmgrLidar532'
+  i = i+1
+  if (LcltgrLidar532)        cfg%out_list(i) = 'cltgrLidar532'
+  i = i+1
+  if (LlidarBetaMol355)        cfg%out_list(i) = 'lidarBetaMol355'
+  i = i+1
+  if (LcfadLidarsr355)        cfg%out_list(i) = 'cfadLidarsr355'
+  i = i+1
+  if (Latb355)        cfg%out_list(i) = 'atb355'
+  i = i+1
+  if (Lclatlid)        cfg%out_list(i) = 'clatlid'
+  i = i+1
+  if (Lclhatlid)        cfg%out_list(i) = 'clhatlid'
+  i = i+1
+  if (Lcllatlid)        cfg%out_list(i) = 'cllatlid'
+  i = i+1
+  if (Lclmatlid)        cfg%out_list(i) = 'clmatlid'
+  i = i+1
+  if (Lcltatlid)        cfg%out_list(i) = 'cltatlid'
+  i = i+1
+  if (Lalbisccp)        cfg%out_list(i) = 'albisccp'
+  i = i+1
+  if (Lboxptopisccp)        cfg%out_list(i) = 'boxptopisccp'
+  i = i+1
+  if (Lboxtauisccp)        cfg%out_list(i) = 'boxtauisccp'
+  i = i+1
+  if (Lpctisccp)        cfg%out_list(i) = 'pctisccp'
+  i = i+1
+  if (Lclisccp)        cfg%out_list(i) = 'clisccp'
+  i = i+1
+  if (Ltauisccp)        cfg%out_list(i) = 'tauisccp'
+  i = i+1
+  if (Lcltisccp)        cfg%out_list(i) = 'cltisccp'
+  i = i+1
+  if (Lmeantbisccp)        cfg%out_list(i) = 'meantbisccp'
+  i = i+1
+  if (Lmeantbclrisccp)        cfg%out_list(i) = 'meantbclrisccp'
+  i = i+1
+  if (LclMISR)        cfg%out_list(i) = 'clMISR'
+  i = i+1
+  if (Lclcalipso2)        cfg%out_list(i) = 'clcalipso2'
+  i = i+1
+  if (Lcltlidarradar)        cfg%out_list(i) = 'cltlidarradar'
+  i = i+1
+  if (Lcloudsat_tcc)        cfg%out_list(i) = 'cloudsat_tcc'
+  i = i+1
+  if (Lcloudsat_tcc2)        cfg%out_list(i) = 'cloudsat_tcc2'
+  i = i+1
+  if (Lfracout)        cfg%out_list(i) = 'fracout'
+  i = i+1
+  if (LlidarBetaMol532)        cfg%out_list(i) = 'lidarBetaMol532'
+  i = i+1
+  if (Lcltmodis)        cfg%out_list(i) = 'cltmodis'
+  i = i+1
+  if (Lclwmodis)        cfg%out_list(i) = 'clwmodis'
+  i = i+1
+  if (Lclimodis)        cfg%out_list(i) = 'climodis'
+  i = i+1
+  if (Lclhmodis)        cfg%out_list(i) = 'clhmodis'
+  i = i+1
+  if (Lclmmodis)        cfg%out_list(i) = 'clmmodis'
+  i = i+1
+  if (Lcllmodis)        cfg%out_list(i) = 'cllmodis'
+  i = i+1
+  if (Ltautmodis)        cfg%out_list(i) = 'tautmodis'
+  i = i+1
+  if (Ltauwmodis)        cfg%out_list(i) = 'tauwmodis'
+  i = i+1
+  if (Ltauimodis)        cfg%out_list(i) = 'tauimodis'
+  i = i+1
+  if (Ltautlogmodis)        cfg%out_list(i) = 'tautlogmodis'
+  i = i+1
+  if (Ltauwlogmodis)        cfg%out_list(i) = 'tauwlogmodis'
+  i = i+1
+  if (Ltauilogmodis)        cfg%out_list(i) = 'tauilogmodis'
+  i = i+1
+  if (Lreffclwmodis)        cfg%out_list(i) = 'reffclwmodis'
+  i = i+1
+  if (Lreffclimodis)        cfg%out_list(i) = 'reffclimodis'
+  i = i+1
+  if (Lpctmodis)        cfg%out_list(i) = 'pctmodis'
+  i = i+1
+  if (Llwpmodis)        cfg%out_list(i) = 'lwpmodis'
+  i = i+1
+  if (Liwpmodis)        cfg%out_list(i) = 'iwpmodis'
+  i = i+1
+  if (Lclmodis)        cfg%out_list(i) = 'clmodis'
+  i = i+1
+  if (Ltbrttov)        cfg%out_list(i) = 'tbrttov'
+  i = i+1
+  if (Lptradarflag0)        cfg%out_list(i) = 'ptradarflag0'
+  i = i+1
+  if (Lptradarflag1)        cfg%out_list(i) = 'ptradarflag1'
+  i = i+1
+  if (Lptradarflag2)        cfg%out_list(i) = 'ptradarflag2'
+  i = i+1
+  if (Lptradarflag3)        cfg%out_list(i) = 'ptradarflag3'
+  i = i+1
+  if (Lptradarflag4)        cfg%out_list(i) = 'ptradarflag4'
+  i = i+1
+  if (Lptradarflag5)        cfg%out_list(i) = 'ptradarflag5'
+  i = i+1
+  if (Lptradarflag6)        cfg%out_list(i) = 'ptradarflag6'
+  i = i+1
+  if (Lptradarflag7)        cfg%out_list(i) = 'ptradarflag7'
+  i = i+1
+  if (Lptradarflag8)        cfg%out_list(i) = 'ptradarflag8'
+  i = i+1
+  if (Lptradarflag9)        cfg%out_list(i) = 'ptradarflag9'
+  i = i+1
+  if (Lradarpia)        cfg%out_list(i) = 'radarpia'
+!  i = i+1 !si on laisse, 108 au lieu de 107
+
+  if (i.gt.107) then
+     print *, 'COSP_IO: wrong number of output diagnostics'
+     print *, i,107
+     stop
+  endif
+
+
+  ! Copy diagnostic flags to cfg structure
+
+   cfg%Lpctisccp = Lpctisccp
+   cfg%Lclisccp = Lclisccp
+   cfg%Lboxptopisccp = Lboxptopisccp
+   cfg%Lboxtauisccp = Lboxtauisccp
+   cfg%Ltauisccp = Ltauisccp
+   cfg%Lcltisccp = Lcltisccp
+   cfg%Lmeantbisccp = Lmeantbisccp
+   cfg%Lmeantbclrisccp = Lmeantbclrisccp
+   cfg%Lalbisccp = Lalbisccp
+   cfg%LclMISR = LclMISR
+   cfg%Lcltmodis = Lcltmodis
+   cfg%Lclwmodis = Lclwmodis
+   cfg%Lclimodis = Lclimodis
+   cfg%Lclhmodis = Lclhmodis
+   cfg%Lclmmodis = Lclmmodis
+   cfg%Lcllmodis = Lcllmodis
+   cfg%Ltautmodis = Ltautmodis
+   cfg%Ltauwmodis = Ltauwmodis
+   cfg%Ltauimodis = Ltauimodis
+   cfg%Ltautlogmodis = Ltautlogmodis
+   cfg%Ltauwlogmodis = Ltauwlogmodis
+   cfg%Ltauilogmodis = Ltauilogmodis
+   cfg%Lreffclwmodis = Lreffclwmodis
+   cfg%Lreffclimodis = Lreffclimodis
+   cfg%Lpctmodis = Lpctmodis
+   cfg%Llwpmodis = Llwpmodis
+   cfg%Liwpmodis = Liwpmodis
+   cfg%Lclmodis = Lclmodis
+   cfg%Latb532 = Latb532
+   cfg%Latb532gr = Latb532gr
+   cfg%Latb355 = Latb355
+   cfg%LlidarBetaMol532 = LlidarBetaMol532
+   cfg%LlidarBetaMol532gr = LlidarBetaMol532gr
+   cfg%LlidarBetaMol355 = LlidarBetaMol355
+   cfg%LcfadLidarsr532 = LcfadLidarsr532
+   cfg%LcfadLidarsr532gr = LcfadLidarsr532gr
+   cfg%LcfadLidarsr355 = LcfadLidarsr355
+   cfg%Lclcalipso2 = Lclcalipso2
+   cfg%Lclcalipso = Lclcalipso
+   cfg%LclgrLidar532 = LclgrLidar532
+   cfg%Lclatlid = Lclatlid
+   cfg%Lclhcalipso = Lclhcalipso
+   cfg%Lcllcalipso = Lcllcalipso
+   cfg%Lclmcalipso = Lclmcalipso
+   cfg%Lcltcalipso = Lcltcalipso
+   cfg%LclhgrLidar532 = LclhgrLidar532
+   cfg%LcllgrLidar532 = LcllgrLidar532
+   cfg%LclmgrLidar532 = LclmgrLidar532
+   cfg%LcltgrLidar532 = LcltgrLidar532
+   cfg%Lclhatlid = Lclhatlid
+   cfg%Lcllatlid = Lcllatlid
+   cfg%Lclmatlid = Lclmatlid
+   cfg%Lcltatlid = Lcltatlid
+   cfg%Lcltlidarradar = Lcltlidarradar
+   cfg%Lcloudsat_tcc = Lcloudsat_tcc
+   cfg%Lcloudsat_tcc2 = Lcloudsat_tcc2
+   cfg%Lclcalipsoliq = Lclcalipsoliq
+   cfg%Lclcalipsoice = Lclcalipsoice
+   cfg%Lclcalipsoun = Lclcalipsoun
+   cfg%Lclcalipsotmp = Lclcalipsotmp
+   cfg%Lclcalipsotmpliq = Lclcalipsotmpliq
+   cfg%Lclcalipsotmpice = Lclcalipsotmpice
+   cfg%Lclcalipsotmpun = Lclcalipsotmpun
+   cfg%Lcltcalipsoliq = Lcltcalipsoliq
+   cfg%Lcltcalipsoice = Lcltcalipsoice
+   cfg%Lcltcalipsoun = Lcltcalipsoun
+   cfg%Lclhcalipsoliq = Lclhcalipsoliq
+   cfg%Lclhcalipsoice = Lclhcalipsoice
+   cfg%Lclhcalipsoun = Lclhcalipsoun
+   cfg%Lclmcalipsoliq = Lclmcalipsoliq
+   cfg%Lclmcalipsoice = Lclmcalipsoice
+   cfg%Lclmcalipsoun = Lclmcalipsoun
+   cfg%Lcllcalipsoliq = Lcllcalipsoliq
+   cfg%Lcllcalipsoice = Lcllcalipsoice
+   cfg%Lcllcalipsoun = Lcllcalipsoun
+   cfg%Lclopaquecalipso = Lclopaquecalipso
+   cfg%Lclthincalipso = Lclthincalipso
+   cfg%Lclzopaquecalipso = Lclzopaquecalipso
+   cfg%Lclcalipsoopaque = Lclcalipsoopaque
+   cfg%Lclcalipsothin = Lclcalipsothin
+   cfg%Lclcalipsozopaque = Lclcalipsozopaque
+   cfg%Lclcalipsoopacity = Lclcalipsoopacity
+   cfg%Lclopaquetemp = Lclopaquetemp
+   cfg%Lclthintemp = Lclthintemp
+   cfg%Lclzopaquetemp = Lclzopaquetemp
+   cfg%Lclopaquemeanz = Lclopaquemeanz
+   cfg%Lclthinmeanz = Lclthinmeanz
+   cfg%Lclthinemis = Lclthinemis
+   cfg%Lclopaquemeanzse = Lclopaquemeanzse
+   cfg%Lclthinmeanzse = Lclthinmeanzse
+   cfg%Lclzopaquecalipsose = Lclzopaquecalipsose
+   cfg%LcfadDbze94 = LcfadDbze94
+   cfg%Ldbze94 = Ldbze94
+   cfg%Lparasolrefl = Lparasolrefl
+   cfg%Ltbrttov = Ltbrttov
+   cfg%Lptradarflag0 = Lptradarflag0
+   cfg%Lptradarflag1 = Lptradarflag1
+   cfg%Lptradarflag2 = Lptradarflag2
+   cfg%Lptradarflag3 = Lptradarflag3
+   cfg%Lptradarflag4 = Lptradarflag4
+   cfg%Lptradarflag5 = Lptradarflag5
+   cfg%Lptradarflag6 = Lptradarflag6
+   cfg%Lptradarflag7 = Lptradarflag7
+   cfg%Lptradarflag8 = Lptradarflag8
+   cfg%Lptradarflag9 = Lptradarflag9
+   cfg%Lradarpia = Lradarpia
+   cfg%Lfracout = Lfracout
+  
+ END SUBROUTINE READ_COSP_OUTPUT_NL
+
+
+ SUBROUTINE read_xiosfieldactive(cfg)
+  USE lmdz_xios, ONLY: xios_field_is_active, using_xios
+  implicit none
+  type(cosp_config),intent(inout) :: cfg
+  integer :: i
+
+!COSPv2 local variables
+  logical :: &
+       Lisccp      = .false., & ! Local on/off switch for simulators
+       Lmodis      = .false., & !
+       Lmisr       = .false., & !
+       Lcalipso    = .false., & !
+       LgrLidar532 = .false., & !
+       Latlid      = .false., & !
+       Lcloudsat   = .false., & !
+       Lrttov      = .false., & !
+       Lparasol    = .false., & !
+       Lwrite_output=.false.    ! ecrire un fichier de sortie COSP ! RG voir si on garde
+
+  logical :: Lcfaddbze94,Ldbze94,Latb532,LcfadLidarsr532,Lclcalipso,Lclhcalipso,         &
+             Lcllcalipso,Lclmcalipso,Lcltcalipso,LparasolRefl,Lclcalipsoliq,             &
+             Lclcalipsoice,Lclcalipsoun,Lclcalipsotmp,Lclcalipsotmpliq,Lclcalipsotmpice, &
+             Lclcalipsotmpun,Lclhcalipsoliq,Lcllcalipsoliq,Lclmcalipsoliq,Lcltcalipsoliq,& 
+             Lclhcalipsoice,Lcllcalipsoice,Lclmcalipsoice,Lcltcalipsoice,Lclhcalipsoun,  & 
+             Lcllcalipsoun,Lclmcalipsoun,Lcltcalipsoun,Lclopaquecalipso,Lclthincalipso,  & 
+             Lclzopaquecalipso,Lclcalipsoopaque,Lclcalipsothin,Lclcalipsozopaque,        & 
+             Lclcalipsoopacity,Lclopaquetemp,Lclthintemp,Lclzopaquetemp,Lclopaquemeanz,  &
+             Lclthinmeanz,Lclthinemis,Lclopaquemeanzse,Lclthinmeanzse,Lclzopaquecalipsose,&
+             LlidarBetaMol532gr,LcfadLidarsr532gr,Latb532gr,LclgrLidar532,LclhgrLidar532,&
+             LcllgrLidar532,LclmgrLidar532,LcltgrLidar532,LlidarBetaMol355,              &
+             LcfadLidarsr355,Latb355,Lclatlid,Lclhatlid,Lcllatlid,Lclmatlid,Lcltatlid,   &
+             Lalbisccp,Lboxptopisccp,Lboxtauisccp,Lpctisccp,Lclisccp,Ltauisccp,Lcltisccp,&
+             Lmeantbisccp,Lmeantbclrisccp,LclMISR,Lclcalipso2,Lcltlidarradar,            &
+             Lcloudsat_tcc, Lcloudsat_tcc2,Lfracout,   &
+             LlidarBetaMol532,Lcltmodis,Lclwmodis,Lclimodis,Lclhmodis,Lclmmodis,         &
+             Lcllmodis,Ltautmodis,Ltauwmodis,Ltauimodis,Ltautlogmodis,Ltauwlogmodis,     &
+             Ltauilogmodis,Lreffclwmodis,Lreffclimodis,Lpctmodis,Llwpmodis,Liwpmodis,    &
+             Lclmodis,Ltbrttov,Lptradarflag0,Lptradarflag1,Lptradarflag2,Lptradarflag3,  &
+             Lptradarflag4,Lptradarflag5,Lptradarflag6,Lptradarflag7,Lptradarflag8,      &
+             Lptradarflag9,Lradarpia
+
+        
+  character(len=32) :: out_list(107)
+
+ IF (using_xios) THEN
+
+  do i=1,107
+    cfg%out_list(i)=''
+  enddo
+
+! diagnostics
+   Lpctisccp=.false.
+   Lclisccp=.false.
+   Lboxptopisccp=.false.
+   Lboxtauisccp=.false.
+   Ltauisccp=.false.
+   Lcltisccp=.false.
+   Lmeantbisccp=.false.
+   Lmeantbclrisccp=.false.
+   Lalbisccp=.false.
+   LclMISR=.false.
+   Lcltmodis=.false.
+   Lclwmodis=.false.
+   Lclimodis=.false.
+   Lclhmodis=.false.
+   Lclmmodis=.false.
+   Lcllmodis=.false.
+   Ltautmodis=.false.
+   Ltauwmodis=.false.
+   Ltauimodis=.false.
+   Ltautlogmodis=.false.
+   Ltauwlogmodis=.false.
+   Ltauilogmodis=.false.
+   Lreffclwmodis=.false.
+   Lreffclimodis=.false.
+   Lpctmodis=.false.
+   Llwpmodis=.false.
+   Liwpmodis=.false.
+   Lclmodis=.false.
+   Latb532=.false.
+   Latb532gr=.false.
+   Latb355=.false.
+   LlidarBetaMol532=.false.
+   LlidarBetaMol532gr=.false.
+   LlidarBetaMol355=.false.
+   LcfadLidarsr532=.false.
+   LcfadLidarsr532gr=.false.
+   LcfadLidarsr355 =.false.
+   Lclcalipso2=.false.
+   Lclcalipso=.false.
+   LclgrLidar532=.false.
+   Lclatlid=.false.
+   Lclhcalipso=.false.
+   Lcllcalipso=.false.
+   Lclmcalipso=.false.
+   Lcltcalipso=.false.
+   LclhgrLidar532=.false.
+   LcllgrLidar532=.false.
+   LclmgrLidar532 =.false.
+   LcltgrLidar532=.false.
+   Lclhatlid=.false.
+   Lcllatlid=.false.
+   Lclmatlid=.false.
+   Lcltatlid=.false.
+   Lcltlidarradar=.false.
+   Lcloudsat_tcc=.false.
+   Lcloudsat_tcc2=.false.
+   Lclcalipsoliq=.false.
+   Lclcalipsoice=.false.
+   Lclcalipsoun=.false.
+   Lclcalipsotmp=.false.
+   Lclcalipsotmpliq=.false.
+   Lclcalipsotmpice=.false.
+   Lclcalipsotmpun=.false.
+   Lcltcalipsoliq=.false.
+   Lcltcalipsoice=.false.
+   Lcltcalipsoun=.false.
+   Lclhcalipsoliq=.false.
+   Lclhcalipsoice=.false.
+   Lclhcalipsoun=.false.
+   Lclmcalipsoliq=.false.
+   Lclmcalipsoice=.false.
+   Lclmcalipsoun=.false.
+   Lcllcalipsoliq=.false.
+   Lcllcalipsoice=.false.
+   Lcllcalipsoun =.false.
+   Lclopaquecalipso=.false.
+   Lclthincalipso=.false.
+   Lclzopaquecalipso=.false.
+   Lclcalipsoopaque=.false.
+   Lclcalipsothin=.false.
+   Lclcalipsozopaque=.false.
+   Lclcalipsoopacity=.false.
+   Lclopaquetemp=.false.
+   Lclthintemp=.false.
+   Lclzopaquetemp=.false.
+   Lclopaquemeanz=.false.
+   Lclthinmeanz=.false.
+   Lclthinemis=.false.
+   Lclopaquemeanzse=.false.
+   Lclthinmeanzse=.false.
+   Lclzopaquecalipsose=.false.
+   LcfadDbze94=.false.
+   Ldbze94=.false.
+   Lparasolrefl=.false.
+   Ltbrttov=.false.
+   Lptradarflag0=.false.
+   Lptradarflag1=.false.
+   Lptradarflag2=.false.
+   Lptradarflag3=.false.
+   Lptradarflag4=.false.
+   Lptradarflag5=.false.
+   Lptradarflag6=.false.
+   Lptradarflag7=.false.
+   Lptradarflag8=.false.
+   Lptradarflag9=.false.
+   Lradarpia=.false.
+   Lfracout=.false.
+
+
+  IF (is_master) THEN
+! VEREFIER LES CHAMPS DEMANDES DANS .XML
+! 2. Si champs active dans .xml alors mettre la cles de sortie en true
+ IF (xios_field_is_active("cllcalipso")) Lcllcalipso=.TRUE.
+ IF (xios_field_is_active("clmcalipso")) Lclmcalipso=.TRUE.
+ IF (xios_field_is_active("clhcalipso")) Lclhcalipso=.TRUE.
+ IF (xios_field_is_active("cltcalipso")) Lcltcalipso=.TRUE.
+ IF (xios_field_is_active("cllcalipsoice")) Lcllcalipsoice=.TRUE.
+ IF (xios_field_is_active("clmcalipsoice")) Lclmcalipsoice=.TRUE.
+ IF (xios_field_is_active("clhcalipsoice")) Lclhcalipsoice=.TRUE.
+ IF (xios_field_is_active("cltcalipsoice")) Lcltcalipsoice=.TRUE.
+ IF (xios_field_is_active("cllcalipsoliq")) Lcllcalipsoliq=.TRUE.
+ IF (xios_field_is_active("clmcalipsoliq")) Lclmcalipsoliq=.TRUE.
+ IF (xios_field_is_active("clhcalipsoliq")) Lclhcalipsoliq=.TRUE.
+ IF (xios_field_is_active("cltcalipsoliq")) Lcltcalipsoliq=.TRUE.
+ IF (xios_field_is_active("cllcalipsoun")) Lcllcalipsoun=.TRUE.
+ IF (xios_field_is_active("clmcalipsoun")) Lclmcalipsoun=.TRUE.
+ IF (xios_field_is_active("clhcalipsoun")) Lclhcalipsoun=.TRUE.
+ IF (xios_field_is_active("cltcalipsoun")) Lcltcalipsoun=.TRUE.
+ IF (xios_field_is_active("clcalipso")) Lclcalipso=.TRUE.
+ IF (xios_field_is_active("clcalipsoice")) Lclcalipsoice=.TRUE.
+ IF (xios_field_is_active("clcalipsoliq")) Lclcalipsoliq=.TRUE.
+ IF (xios_field_is_active("clcalipsoun")) Lclcalipsoun=.TRUE.
+ IF (xios_field_is_active("clcalipsotmp")) Lclcalipsotmp=.TRUE.
+ IF (xios_field_is_active("clcalipsotmpice")) Lclcalipsotmpice=.TRUE.
+ IF (xios_field_is_active("clcalipsotmpliq")) Lclcalipsotmpliq=.TRUE.
+ IF (xios_field_is_active("clcalipsotmpun")) Lclcalipsotmpun=.TRUE.
+! IF (xios_field_is_active("parasol_crefl")) cfg%LparasolRefl=.TRUE.
+! IF (xios_field_is_active("Ncrefl")) cfg%LparasolRefl=.TRUE.
+ IF (xios_field_is_active("cfadLidarsr532")) LcfadLidarsr532=.TRUE.
+ IF (xios_field_is_active("atb532")) Latb532=.TRUE.
+ IF (xios_field_is_active("lidarBetaMol532")) LlidarBetaMol532=.TRUE.
+ IF (xios_field_is_active("clopaquecalipso")) Lclopaquecalipso=.TRUE.
+ IF (xios_field_is_active("clthincalipso")) Lclthincalipso=.TRUE.
+ IF (xios_field_is_active("clzopaquecalipso")) Lclzopaquecalipso=.TRUE.
+ IF (xios_field_is_active("clcalipsoopaque")) Lclcalipsoopaque=.TRUE.
+ IF (xios_field_is_active("clcalipsothin")) Lclcalipsothin=.TRUE.
+ IF (xios_field_is_active("clcalipsozopaque")) Lclcalipsozopaque=.TRUE.
+ IF (xios_field_is_active("clcalipsoopacity")) Lclcalipsoopacity=.TRUE.
+ IF (xios_field_is_active("clopaquetemp")) Lclopaquetemp=.TRUE.
+ IF (xios_field_is_active("clthintemp")) Lclthintemp=.TRUE.
+ IF (xios_field_is_active("clzopaquetemp")) Lclzopaquetemp=.TRUE.
+ IF (xios_field_is_active("clopaquemeanz")) Lclopaquemeanz=.TRUE.
+ IF (xios_field_is_active("clthinmeanz")) Lclthinmeanz=.TRUE.
+ IF (xios_field_is_active("clthinemis")) Lclthinemis=.TRUE.
+ IF (xios_field_is_active("clopaquemeanzse")) Lclopaquemeanzse=.TRUE.
+ IF (xios_field_is_active("clthinmeanzse")) Lclthinmeanzse=.TRUE.
+ IF (xios_field_is_active("clzopaquecalipsose")) Lclzopaquecalipsose=.TRUE.
+!!!! 43 champs CALIPSO
+
+ IF (xios_field_is_active("parasolGrid_refl")) LparasolRefl=.TRUE.
+ IF (xios_field_is_active("parasolPix_refl")) LparasolRefl=.TRUE.
+!!!! 2 champs PARASOL controles par une seule clef logique
+
+ IF (xios_field_is_active("lidarBetaMol532gr")) LlidarBetaMol532gr=.TRUE.
+ IF (xios_field_is_active("cfadLidarsr532gr")) LcfadLidarsr532gr=.TRUE.
+ IF (xios_field_is_active("atb532gr")) Latb532gr=.TRUE.
+ IF (xios_field_is_active("clgrLidar532")) LclgrLidar532=.TRUE.
+ IF (xios_field_is_active("clhgrLidar532")) LclhgrLidar532=.TRUE.
+ IF (xios_field_is_active("cllgrLidar532")) LcllgrLidar532=.TRUE.
+ IF (xios_field_is_active("clmgrLidar532")) LclmgrLidar532=.TRUE.
+ IF (xios_field_is_active("cltgrLidar532")) LcltgrLidar532=.TRUE.
+!!!! 8 champs GROUND LIDAR 532 nm
+
+ IF (xios_field_is_active("lidarBetaMol355")) LlidarBetaMol355=.TRUE.
+ IF (xios_field_is_active("cfadLidarsr355")) LcfadLidarsr355=.TRUE.
+ IF (xios_field_is_active("atb355")) Latb355=.TRUE.
+ IF (xios_field_is_active("clatlid")) Lclatlid=.TRUE.
+ IF (xios_field_is_active("clhatlid")) Lclhatlid=.TRUE.
+ IF (xios_field_is_active("cllatlid")) Lcllatlid=.TRUE.
+ IF (xios_field_is_active("clmatlid")) Lclmatlid=.TRUE.
+ IF (xios_field_is_active("cltatlid")) Lcltatlid=.TRUE.
+!!!! 8 champs ATLID
+
+ IF (xios_field_is_active("cfadDbze94")) LcfadDbze94=.TRUE.
+ IF (xios_field_is_active("dbze94")) Ldbze94=.TRUE.
+ IF (xios_field_is_active("ptradarflag0")) Lptradarflag0=.TRUE.
+ IF (xios_field_is_active("ptradarflag1")) Lptradarflag1=.TRUE.
+ IF (xios_field_is_active("ptradarflag2")) Lptradarflag2=.TRUE.
+ IF (xios_field_is_active("ptradarflag3")) Lptradarflag3=.TRUE.
+ IF (xios_field_is_active("ptradarflag4")) Lptradarflag4=.TRUE.
+ IF (xios_field_is_active("ptradarflag5")) Lptradarflag5=.TRUE.
+ IF (xios_field_is_active("ptradarflag6")) Lptradarflag6=.TRUE.
+ IF (xios_field_is_active("ptradarflag7")) Lptradarflag7=.TRUE.
+ IF (xios_field_is_active("ptradarflag8")) Lptradarflag8=.TRUE.
+ IF (xios_field_is_active("ptradarflag9")) Lptradarflag9=.TRUE.
+ IF (xios_field_is_active("radarpia")) Lradarpia=.TRUE.
+!!! 13 champs CLOUDSAT
+
+ IF (xios_field_is_active("cltlidarradar")) Lcltlidarradar=.TRUE.
+ IF (xios_field_is_active("clcalipso2")) Lclcalipso2=.TRUE.
+ IF (xios_field_is_active("cloudsat_tcc")) Lcloudsat_tcc=.TRUE. !COSPv2
+ IF (xios_field_is_active("cloudsat_tcc2")) Lcloudsat_tcc2=.TRUE. !COSPv2
+!!! 4 champs CLOUDSAT et CALIPSO
+
+ IF (xios_field_is_active("clisccp")) Lclisccp=.TRUE.
+ IF (xios_field_is_active("boxtauisccp")) Lboxtauisccp=.TRUE.
+ IF (xios_field_is_active("boxptopisccp")) Lboxptopisccp=.TRUE.
+ IF (xios_field_is_active("cltisccp")) Lcltisccp=.TRUE.
+ IF (xios_field_is_active("pctisccp")) Lpctisccp=.TRUE.
+ IF (xios_field_is_active("tauisccp")) Ltauisccp=.TRUE.
+ IF (xios_field_is_active("albisccp")) Lalbisccp=.TRUE.
+ IF (xios_field_is_active("meantbisccp")) Lmeantbisccp=.TRUE.
+ IF (xios_field_is_active("meantbclrisccp")) Lmeantbclrisccp=.TRUE.
+!!! 9 champs ISCCP
+
+ IF (xios_field_is_active("misr_fq")) LclMISR=.TRUE.
+ IF (xios_field_is_active("misr_meanztop")) LclMISR=.TRUE.
+ IF (xios_field_is_active("misr_cldarea")) LclMISR=.TRUE.
+!!! 3 champs MISR controles par une seule clef logique
+
+ IF (xios_field_is_active("cllmodis")) Lcllmodis=.TRUE.
+ IF (xios_field_is_active("clmmodis")) Lclmmodis=.TRUE.
+ IF (xios_field_is_active("clhmodis")) Lclhmodis=.TRUE.
+ IF (xios_field_is_active("cltmodis")) Lcltmodis=.TRUE.
+ IF (xios_field_is_active("clwmodis")) Lclwmodis=.TRUE.
+ IF (xios_field_is_active("climodis")) Lclimodis=.TRUE.
+ IF (xios_field_is_active("tautmodis")) Ltautmodis=.TRUE.
+ IF (xios_field_is_active("tauwmodis")) Ltauwmodis=.TRUE.
+ IF (xios_field_is_active("tauimodis")) Ltauimodis=.TRUE.
+ IF (xios_field_is_active("tautlogmodis")) Ltautlogmodis=.TRUE.
+ IF (xios_field_is_active("tauilogmodis")) Ltauilogmodis=.TRUE.
+ IF (xios_field_is_active("tauwlogmodis")) Ltauwlogmodis=.TRUE.
+ IF (xios_field_is_active("reffclwmodis")) Lreffclwmodis=.TRUE.
+ IF (xios_field_is_active("reffclimodis")) Lreffclimodis=.TRUE.
+ IF (xios_field_is_active("pctmodis")) Lpctmodis=.TRUE.
+ IF (xios_field_is_active("lwpmodis")) Llwpmodis=.TRUE.
+ IF (xios_field_is_active("iwpmodis")) Liwpmodis=.TRUE.
+ IF (xios_field_is_active("modis_ot_vs_ctp")) Lclmodis=.TRUE.
+ IF (xios_field_is_active("modis_ot_vs_reffice")) Lclmodis=.TRUE.
+ IF (xios_field_is_active("modis_ot_vs_reffliq")) Lclmodis=.TRUE.
+! IF (xios_field_is_active("crimodis")) Lcrimodis=.TRUE. !COSPv2
+! IF (xios_field_is_active("crlmodis")) Lcrlmodis=.TRUE. !COSPv2
+!!! 20 champs MODIS dont 3 champs controles par la clef logique "clmodis"
+
+! IF (xios_field_is_active("tbrttov")) cfg%Ltbrttov=.TRUE.
+! IF (xios_field_is_active("fracout")) Lfracout=.TRUE.
+
+!!! 106 diagnostics en tout dans COSPv2 + fracout (107)
+
+
+! 2.  si champs demande alors activer le simulateur correspondant
+   IF (xios_field_is_active("cllcalipso").OR. &
+       xios_field_is_active("clmcalipso").OR. &
+       xios_field_is_active("clhcalipso").OR. &
+       xios_field_is_active("cltcalipso").OR. &
+       xios_field_is_active("cllcalipsoice").OR. &
+       xios_field_is_active("clmcalipsoice").OR. &
+       xios_field_is_active("clhcalipsoice").OR. &
+       xios_field_is_active("cltcalipsoice").OR. &
+       xios_field_is_active("cllcalipsoliq").OR. &
+       xios_field_is_active("clmcalipsoliq").OR. &
+       xios_field_is_active("clhcalipsoliq").OR. &
+       xios_field_is_active("cltcalipsoliq").OR. &
+       xios_field_is_active("cllcalipsoun").OR. &
+       xios_field_is_active("clmcalipsoun").OR. &
+       xios_field_is_active("clhcalipsoun").OR. &
+       xios_field_is_active("cltcalipsoun").OR. &
+       xios_field_is_active("clcalipso").OR. &
+       xios_field_is_active("clcalipsoice").OR. &
+       xios_field_is_active("clcalipsoliq").OR. &
+       xios_field_is_active("clcalipsoun").OR. &
+       xios_field_is_active("clcalipsotmp").OR. &
+       xios_field_is_active("clcalipsotmpice").OR. &
+       xios_field_is_active("clcalipsotmpliq").OR. &
+       xios_field_is_active("clcalipsotmpun").OR. &
+       xios_field_is_active("cfadLidarsr532").OR. &
+       xios_field_is_active("atb532").OR. &
+       xios_field_is_active("lidarBetaMol532").OR. &
+       xios_field_is_active("clopaquecalipso").OR. &
+       xios_field_is_active("clthincalipso").OR. &
+       xios_field_is_active("clzopaquecalipso").OR. &
+       xios_field_is_active("clcalipsoopaque").OR. &
+       xios_field_is_active("clcalipsothin").OR. &
+       xios_field_is_active("clcalipsozopaque").OR. &
+       xios_field_is_active("clcalipsoopacity").OR. &
+       xios_field_is_active("clopaquetemp").OR. &
+       xios_field_is_active("clthintemp").OR. &
+       xios_field_is_active("clzopaquetemp").OR. &
+       xios_field_is_active("clopaquemeanz").OR. &
+       xios_field_is_active("clthinmeanz").OR. &
+       xios_field_is_active("clthinemis").OR. &
+       xios_field_is_active("clopaquemeanzse").OR. &
+       xios_field_is_active("clthinmeanzse").OR. &
+       xios_field_is_active("clzopaquecalipsose"))  Lcalipso=.TRUE.
+
+    IF (xios_field_is_active("parasolGrid_refl").OR. &
+       xios_field_is_active("parasolPix_refl")) Lparasol=.TRUE.
+
+   IF (xios_field_is_active("lidarBetaMol532gr").OR. &
+       xios_field_is_active("cfadLidarsr532gr").OR. &
+       xios_field_is_active("atb532gr").OR. &
+       xios_field_is_active("clgrLidar532").OR. &
+       xios_field_is_active("clhgrLidar532").OR. &
+       xios_field_is_active("cllgrLidar532").OR. &
+       xios_field_is_active("clmgrLidar532").OR. &
+       xios_field_is_active("cltgrLidar532"))  LgrLidar532=.TRUE.
+
+   IF (xios_field_is_active("lidarBetaMol355").OR. &
+       xios_field_is_active("cfadLidarsr355").OR. &
+       xios_field_is_active("atb355").OR. &
+       xios_field_is_active("clatlid").OR. &
+       xios_field_is_active("clhatlid").OR. &
+       xios_field_is_active("cllatlid").OR. &
+       xios_field_is_active("clmatlid").OR. &
+       xios_field_is_active("cltatlid"))  Latlid=.TRUE.
+
+    IF (xios_field_is_active("cfadDbze94").OR. &
+      xios_field_is_active("dbze94").OR. &
+      xios_field_is_active("ptradarflag0").OR. &
+      xios_field_is_active("ptradarflag1").OR. &
+      xios_field_is_active("ptradarflag2").OR. &
+      xios_field_is_active("ptradarflag3").OR. &
+      xios_field_is_active("ptradarflag4").OR. &
+      xios_field_is_active("ptradarflag5").OR. &
+      xios_field_is_active("ptradarflag6").OR. &
+      xios_field_is_active("ptradarflag7").OR. &
+      xios_field_is_active("ptradarflag8").OR. &
+      xios_field_is_active("ptradarflag9").OR. &
+      xios_field_is_active("radarpia")) Lcloudsat=.TRUE.
+
+    IF (xios_field_is_active("cltlidarradar").OR. &
+      xios_field_is_active("clcalipso2").OR. &
+      xios_field_is_active("cloudsat_tcc").OR. &
+      xios_field_is_active("cloudsat_tcc2")) THEN
+               Lcloudsat=.TRUE.
+               Lcalipso=.TRUE.
+    ENDIF
+
+    IF (xios_field_is_active("clisccp").OR. &     !COSPv2 nouveau nom
+       xios_field_is_active("boxtauisccp").OR. &
+       xios_field_is_active("boxptopisccp").OR. &
+       xios_field_is_active("cltisccp").OR. &     !COSPv2 nouveau nom
+       xios_field_is_active("pctisccp").OR. &     !COSPv2 nouveau nom
+       xios_field_is_active("tauisccp").OR. &
+       xios_field_is_active("albisccp").OR. &
+       xios_field_is_active("meantbisccp").OR. &
+       xios_field_is_active("meantbclrisccp")) Lisccp=.TRUE.
+
+    IF (xios_field_is_active("misr_fq").OR. &
+       xios_field_is_active("misr_meanztop").OR. &
+       xios_field_is_active("misr_cldarea")) Lmisr=.TRUE.
+
+    IF (xios_field_is_active("cllmodis").OR. &
+       xios_field_is_active("clmmodis").OR. &
+       xios_field_is_active("clhmodis").OR. &
+       xios_field_is_active("cltmodis").OR. &
+       xios_field_is_active("clwmodis").OR. &
+       xios_field_is_active("climodis").OR. &
+       xios_field_is_active("tautmodis").OR. &
+       xios_field_is_active("tauwmodis").OR. &
+       xios_field_is_active("tauimodis").OR. &
+       xios_field_is_active("tautlogmodis").OR. &
+       xios_field_is_active("tauilogmodis").OR. &
+       xios_field_is_active("tauwlogmodis").OR. &
+       xios_field_is_active("reffclwmodis").OR. &
+       xios_field_is_active("reffclimodis").OR. &
+       xios_field_is_active("pctmodis").OR. &
+       xios_field_is_active("lwpmodis").OR. &
+       xios_field_is_active("iwpmodis").OR. &
+       xios_field_is_active("modis_ot_vs_ctp").OR. &
+       xios_field_is_active("modis_ot_vs_reffice").OR. &
+       xios_field_is_active("modis_ot_vs_reffliq")) Lmodis=.TRUE.
+!       xios_field_is_active("crimodis").OR. &              !COSPv2 n'existe plus
+!       xios_field_is_active("crlmodis")) Lmodis_sim=.TRUE. !COSPv2 n'existe plus
+
+  ENDIF !   (is_master) 
+
+!$OMP BARRIER
+
+  CALL bcast(Lcloudsat)
+  CALL bcast(Lcalipso)
+  CALL bcast(LgrLidar532)
+  CALL bcast(Latlid)
+  CALL bcast(Lisccp)
+  CALL bcast(Lmodis)
+  CALL bcast(Lmisr)
+  CALL bcast(Lparasol)
+  CALL bcast(Lrttov)
+
+  CALL bcast(Lcfaddbze94)
+  CALL bcast(Ldbze94)
+  CALL bcast(Latb532)
+  CALL bcast(LcfadLidarsr532)
+  CALL bcast(Lclcalipso)
+  CALL bcast(Lclhcalipso)
+  CALL bcast(Lcllcalipso)
+  CALL bcast(Lclmcalipso)
+  CALL bcast(Lcltcalipso)
+  CALL bcast(LparasolRefl)
+  CALL bcast(Lclcalipsoliq)
+  CALL bcast(Lclcalipsoice)
+  CALL bcast(Lclcalipsoun)
+  CALL bcast(Lclcalipsotmp)
+  CALL bcast(Lclcalipsotmpliq)
+  CALL bcast(Lclcalipsotmpice)
+  CALL bcast(Lclcalipsotmpun)
+  CALL bcast(Lclhcalipsoliq)
+  CALL bcast(Lcllcalipsoliq)
+  CALL bcast(Lclmcalipsoliq)
+  CALL bcast(Lcltcalipsoliq)
+  CALL bcast(Lclhcalipsoice)
+  CALL bcast(Lcllcalipsoice)
+  CALL bcast(Lclmcalipsoice)
+  CALL bcast(Lcltcalipsoice)
+  CALL bcast(Lclhcalipsoun)
+  CALL bcast(Lcllcalipsoun)
+  CALL bcast(Lclmcalipsoun)
+  CALL bcast(Lcltcalipsoun)
+  CALL bcast(Lclopaquecalipso)
+  CALL bcast(Lclthincalipso)
+  CALL bcast(Lclzopaquecalipso)
+  CALL bcast(Lclcalipsoopaque)
+  CALL bcast(Lclcalipsothin)
+  CALL bcast(Lclcalipsozopaque)
+  CALL bcast(Lclcalipsoopacity)
+  CALL bcast(Lclopaquetemp)
+  CALL bcast(Lclthintemp)
+  CALL bcast(Lclzopaquetemp)
+  CALL bcast(Lclopaquemeanz)
+  CALL bcast(Lclthinmeanz)
+  CALL bcast(Lclthinemis)
+  CALL bcast(Lclopaquemeanzse)
+  CALL bcast(Lclthinmeanzse)
+  CALL bcast(Lclzopaquecalipsose)
+  CALL bcast(LlidarBetaMol532gr)
+  CALL bcast(LcfadLidarsr532gr)
+  CALL bcast(Latb532gr)
+  CALL bcast(LclgrLidar532)
+  CALL bcast(LclhgrLidar532)
+  CALL bcast(LcllgrLidar532)
+  CALL bcast(LclmgrLidar532)
+  CALL bcast(LcltgrLidar532)
+  CALL bcast(LlidarBetaMol355)
+  CALL bcast(LcfadLidarsr355)
+  CALL bcast(Latb355)
+  CALL bcast(Lclatlid)
+  CALL bcast(Lclhatlid)
+  CALL bcast(Lcllatlid)
+  CALL bcast(Lclmatlid)
+  CALL bcast(Lcltatlid)
+  CALL bcast(Lalbisccp)
+  CALL bcast(Lboxptopisccp)
+  CALL bcast(Lboxtauisccp)
+  CALL bcast(Lpctisccp)
+  CALL bcast(Lclisccp)
+  CALL bcast(Ltauisccp)
+  CALL bcast(Lcltisccp)
+  CALL bcast(Lmeantbisccp)
+  CALL bcast(Lmeantbclrisccp)
+  CALL bcast(LclMISR)
+  CALL bcast(Lclcalipso2)
+  CALL bcast(Lcltlidarradar)
+  CALL bcast(Lcloudsat_tcc)
+  CALL bcast(Lcloudsat_tcc2)
+  CALL bcast(Lfracout)
+  CALL bcast(LlidarBetaMol532)
+  CALL bcast(Lcltmodis)
+  CALL bcast(Lclwmodis)
+  CALL bcast(Lclimodis)
+  CALL bcast(Lclhmodis)
+  CALL bcast(Lclmmodis)
+  CALL bcast(Lcllmodis)
+  CALL bcast(Ltautmodis)
+  CALL bcast(Ltauwmodis)
+  CALL bcast(Ltauimodis)
+  CALL bcast(Ltautlogmodis)
+  CALL bcast(Ltauwlogmodis)
+  CALL bcast(Ltauilogmodis)
+  CALL bcast(Lreffclwmodis)
+  CALL bcast(Lreffclimodis)
+  CALL bcast(Lpctmodis)
+  CALL bcast(Llwpmodis)
+  CALL bcast(Liwpmodis)
+  CALL bcast(Lclmodis)
+  CALL bcast(Ltbrttov)
+  CALL bcast(Lptradarflag0)
+  CALL bcast(Lptradarflag1)
+  CALL bcast(Lptradarflag2)
+  CALL bcast(Lptradarflag3)
+  CALL bcast(Lptradarflag4)
+  CALL bcast(Lptradarflag5)
+  CALL bcast(Lptradarflag6)
+  CALL bcast(Lptradarflag7)
+  CALL bcast(Lptradarflag8)
+  CALL bcast(Lptradarflag9)
+  CALL bcast(Lradarpia)
+
+!    IF (xios_field_is_active("tbrttov")) cfg%Lrttov_sim=.TRUE.
+
+
+  ! Copy diagnostic flags to cfg structure
+! ISCCP simulator  (9 diagnostics)
+   cfg%Lpctisccp = Lpctisccp
+   cfg%Lclisccp = Lclisccp
+   cfg%Lboxptopisccp = Lboxptopisccp
+   cfg%Lboxtauisccp = Lboxtauisccp
+   cfg%Ltauisccp = Ltauisccp
+   cfg%Lcltisccp = Lcltisccp
+   cfg%Lmeantbisccp = Lmeantbisccp
+   cfg%Lmeantbclrisccp = Lmeantbclrisccp
+   cfg%Lalbisccp = Lalbisccp
+
+! CloudSat simulator  (13 diagnostics) 
+   cfg%Ldbze94 = Ldbze94
+   cfg%LcfadDbze94 = LcfadDbze94
+   cfg%Lptradarflag0 = Lptradarflag0
+   cfg%Lptradarflag1 = Lptradarflag1
+   cfg%Lptradarflag2 = Lptradarflag2
+   cfg%Lptradarflag3 = Lptradarflag3
+   cfg%Lptradarflag4 = Lptradarflag4
+   cfg%Lptradarflag5 = Lptradarflag5
+   cfg%Lptradarflag6 = Lptradarflag6
+   cfg%Lptradarflag7 = Lptradarflag7
+   cfg%Lptradarflag8 = Lptradarflag8
+   cfg%Lptradarflag9 = Lptradarflag9
+   cfg%Lradarpia = Lradarpia
+
+! Cloudsat et Calipso  (4 diagnostics)
+   cfg%Lclcalipso2 = Lclcalipso2
+   cfg%Lcltlidarradar = Lcltlidarradar
+   cfg%Lcloudsat_tcc = Lcloudsat_tcc
+   cfg%Lcloudsat_tcc2 = Lcloudsat_tcc2
+
+! CALIPSO simulator  (43 diagnostics)
+   cfg%Latb532 = Latb532
+   cfg%LlidarBetaMol532 = LlidarBetaMol532
+   cfg%LcfadLidarsr532 = LcfadLidarsr532
+   cfg%Lclcalipso = Lclcalipso
+   cfg%Lclhcalipso = Lclhcalipso
+   cfg%Lcllcalipso = Lcllcalipso
+   cfg%Lclmcalipso = Lclmcalipso
+   cfg%Lcltcalipso = Lcltcalipso
+   cfg%Lclcalipsoliq = Lclcalipsoliq
+   cfg%Lclcalipsoice = Lclcalipsoice
+   cfg%Lclcalipsoun = Lclcalipsoun
+   cfg%Lclcalipsotmp = Lclcalipsotmp
+   cfg%Lclcalipsotmpliq = Lclcalipsotmpliq
+   cfg%Lclcalipsotmpice = Lclcalipsotmpice
+   cfg%Lclcalipsotmpun = Lclcalipsotmpun
+   cfg%Lcltcalipsoliq = Lcltcalipsoliq
+   cfg%Lcltcalipsoice = Lcltcalipsoice
+   cfg%Lcltcalipsoun = Lcltcalipsoun
+   cfg%Lclhcalipsoliq = Lclhcalipsoliq
+   cfg%Lclhcalipsoice = Lclhcalipsoice
+   cfg%Lclhcalipsoun = Lclhcalipsoun
+   cfg%Lclmcalipsoliq = Lclmcalipsoliq
+   cfg%Lclmcalipsoice = Lclmcalipsoice
+   cfg%Lclmcalipsoun = Lclmcalipsoun
+   cfg%Lcllcalipsoliq = Lcllcalipsoliq
+   cfg%Lcllcalipsoice = Lcllcalipsoice
+   cfg%Lcllcalipsoun = Lcllcalipsoun
+   cfg%Lclopaquecalipso = Lclopaquecalipso
+   cfg%Lclthincalipso = Lclthincalipso
+   cfg%Lclzopaquecalipso = Lclzopaquecalipso
+   cfg%Lclcalipsoopaque = Lclcalipsoopaque
+   cfg%Lclcalipsothin = Lclcalipsothin
+   cfg%Lclcalipsozopaque = Lclcalipsozopaque
+   cfg%Lclcalipsoopacity = Lclcalipsoopacity
+   cfg%Lclopaquetemp = Lclopaquetemp
+   cfg%Lclthintemp = Lclthintemp
+   cfg%Lclzopaquetemp = Lclzopaquetemp
+   cfg%Lclopaquemeanz = Lclopaquemeanz
+   cfg%Lclthinmeanz = Lclthinmeanz
+   cfg%Lclthinemis = Lclthinemis
+   cfg%Lclopaquemeanzse = Lclopaquemeanzse
+   cfg%Lclthinmeanzse = Lclthinmeanzse
+   cfg%Lclzopaquecalipsose = Lclzopaquecalipsose
+
+! PARASOL simulator  (2 diagnostics, 1 clef)
+   cfg%Lparasolrefl = Lparasolrefl
+
+! GROUND LIDAR 532 nm simulator  (8 diagnostics)
+   cfg%Latb532gr = Latb532gr
+   cfg%LlidarBetaMol532gr = LlidarBetaMol532gr
+   cfg%LcfadLidarsr532gr = LcfadLidarsr532gr
+   cfg%LclgrLidar532 = LclgrLidar532
+   cfg%LclhgrLidar532 = LclhgrLidar532
+   cfg%LcllgrLidar532 = LcllgrLidar532
+   cfg%LclmgrLidar532 = LclmgrLidar532
+   cfg%LcltgrLidar532 = LcltgrLidar532
+
+! ATLID simulator  (8 diagnostics)
+   cfg%Latb355 = Latb355
+   cfg%LlidarBetaMol355 = LlidarBetaMol355
+   cfg%LcfadLidarsr355 = LcfadLidarsr355
+   cfg%Lclatlid = Lclatlid
+   cfg%Lclhatlid = Lclhatlid
+   cfg%Lcllatlid = Lcllatlid
+   cfg%Lclmatlid = Lclmatlid
+   cfg%Lcltatlid = Lcltatlid
+
+! MISR simulator   (3 diagnostics, 1 clef)
+  cfg%LclMISR = LclMISR
+
+! RTTOV  (1 diagnostic)
+  cfg%Ltbrttov = Ltbrttov
+
+! MODIS simulator   (20 diagnostics, 18 clefs)
+  cfg%Lcltmodis=Lcltmodis
+  cfg%Lclwmodis=Lclwmodis
+  cfg%Lclimodis=Lclimodis
+  cfg%Lclhmodis=Lclhmodis
+  cfg%Lclmmodis=Lclmmodis
+  cfg%Lcllmodis=Lcllmodis
+  cfg%Ltautmodis=Ltautmodis
+  cfg%Ltauwmodis=Ltauwmodis
+  cfg%Ltauimodis=Ltauimodis
+  cfg%Ltautlogmodis=Ltautlogmodis
+  cfg%Ltauwlogmodis=Ltauwlogmodis
+  cfg%Ltauilogmodis=Ltauilogmodis
+  cfg%Lreffclwmodis=Lreffclwmodis
+  cfg%Lreffclimodis=Lreffclimodis
+  cfg%Lpctmodis=Lpctmodis
+  cfg%Llwpmodis=Llwpmodis
+  cfg%Liwpmodis=Liwpmodis
+  cfg%Lclmodis=Lclmodis
+
+! Others
+  cfg%Lfracout=Lfracout
+
+! Copy instrument flags to cfg structure
+  cfg%Lcloudsat = Lcloudsat
+  cfg%Lcalipso = Lcalipso
+  cfg%LgrLidar532 = LgrLidar532
+  cfg%Latlid = Latlid
+  cfg%Lparasol = Lparasol
+  cfg%Lisccp = Lisccp
+  cfg%Lmodis = Lmodis
+  cfg%Lmisr = Lmisr
+  cfg%Lrttov = Lrttov
+  if (cfg%Lcloudsat .or. cfg%Lcalipso .or. cfg%LgrLidar532 .or. cfg%Latlid .or. cfg%Lisccp .or. cfg%Lmodis .or. cfg%Lmisr .or. cfg%Lrttov .or. cfg%Lparasol .or. cfg%Lfracout) then
+   cfg%Lwrite_output=.TRUE.
+ endif 
+
+ ENDIF !using_xios
+
+  END SUBROUTINE read_xiosfieldactive
+
+END MODULE lmdz_cosp_read_outputkeys
Index: DZ6/trunk/libf/phylmd/cospv2/lmdz_cosp_subsample_and_optics_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cospv2/lmdz_cosp_subsample_and_optics_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,456 +1,0 @@
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-!
-! Module pour remplir la variable "cospIN", calculs des proprietes optiques subcolumn
-! pour les differents simulateurs
-!
-!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-
-MODULE LMDZ_COSP_SUBSAMPLE_AND_OPTICS_MOD
-
-use cosp_kinds,                only: wp                         
-USE MOD_COSP_CONFIG
-USE mod_quickbeam_optics,      only: size_distribution,quickbeam_optics,gases
-use quickbeam,                 only: radar_cfg
-use MOD_COSP,                  only: cosp_optical_inputs,cosp_column_inputs
-USE mod_rng,                   ONLY: rng_state, init_rng
-USE mod_scops,                 ONLY: scops
-USE mod_prec_scops,            ONLY: prec_scops
-USE MOD_COSP_UTILS,            ONLY: cosp_precip_mxratio
-use cosp_optics,               ONLY: cosp_simulator_optics,lidar_optics,modis_optics,   &
-                                     modis_optics_partition
-use mod_cosp_stats,            ONLY: COSP_CHANGE_VERTICAL_GRID
-use lmdz_cosp_read_outputkeys, ONLY: cosp_config
-
-
-  implicit none
-
-  ! Indices to address arrays of LS and CONV hydrometeors
-  integer,parameter :: &
-       I_LSCLIQ = 1, & ! Large-scale (stratiform) liquid
-       I_LSCICE = 2, & ! Large-scale (stratiform) ice
-       I_LSRAIN = 3, & ! Large-scale (stratiform) rain
-       I_LSSNOW = 4, & ! Large-scale (stratiform) snow
-       I_CVCLIQ = 5, & ! Convective liquid
-       I_CVCICE = 6, & ! Convective ice
-       I_CVRAIN = 7, & ! Convective rain
-       I_CVSNOW = 8, & ! Convective snow
-       I_LSGRPL = 9    ! Large-scale (stratiform) groupel
-  
-  ! Stratiform and convective clouds in frac_out.
-  integer, parameter :: &
-       I_LSC = 1, & ! Large-scale clouds
-       I_CVC = 2    ! Convective clouds      
-  
-  ! Microphysical settings for the precipitation flux to mixing ratio conversion
-  real(wp),parameter,dimension(N_HYDRO) :: &
-                 ! LSL   LSI      LSR       LSS   CVL  CVI      CVR       CVS       LSG
-       N_ax    = (/-1., -1.,     8.e6,     3.e6, -1., -1.,     8.e6,     3.e6,     4.e6/),&
-       N_bx    = (/-1., -1.,      0.0,      0.0, -1., -1.,      0.0,      0.0,      0.0/),&
-       alpha_x = (/-1., -1.,      0.0,      0.0, -1., -1.,      0.0,      0.0,      0.0/),&
-       c_x     = (/-1., -1.,    842.0,     4.84, -1., -1.,    842.0,     4.84,     94.5/),&
-       d_x     = (/-1., -1.,      0.8,     0.25, -1., -1.,      0.8,     0.25,      0.5/),&
-       g_x     = (/-1., -1.,      0.5,      0.5, -1., -1.,      0.5,      0.5,      0.5/),&
-       a_x     = (/-1., -1.,    524.0,    52.36, -1., -1.,    524.0,    52.36,   209.44/),&
-       b_x     = (/-1., -1.,      3.0,      3.0, -1., -1.,      3.0,      3.0,      3.0/),&
-       gamma_1 = (/-1., -1., 17.83725, 8.284701, -1., -1., 17.83725, 8.284701, 11.63230/),&
-       gamma_2 = (/-1., -1.,      6.0,      6.0, -1., -1.,      6.0,      6.0,      6.0/),&
-       gamma_3 = (/-1., -1.,      2.0,      2.0, -1., -1.,      2.0,      2.0,      2.0/),&
-       gamma_4 = (/-1., -1.,      6.0,      6.0, -1., -1.,      6.0,      6.0,      6.0/)
-
-
-contains
-
-  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%  
-  ! SUBROUTINE subsample_and_optics
-  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%  
-  subroutine subsample_and_optics(cfg, nPoints, nLevels, nColumns, nHydro, overlap, &
-       use_precipitation_fluxes, lidar_ice_type, sd, tca, cca, fl_lsrainIN, fl_lssnowIN,    &
-       fl_lsgrplIN, fl_ccrainIN, fl_ccsnowIN, mr_lsliq, mr_lsice, mr_ccliq, mr_ccice,       &
-       reffIN, dtau_c, dtau_s, dem_c, dem_s, cospstateIN, cospIN)
-    ! Inputs
-    integer,intent(in) :: nPoints, nLevels, nColumns, nHydro, overlap, lidar_ice_type
-    real(wp),intent(in),dimension(nPoints,nLevels) :: tca,cca,mr_lsliq,mr_lsice,mr_ccliq,   &
-         mr_ccice,dtau_c,dtau_s,dem_c,dem_s,fl_lsrainIN,fl_lssnowIN,fl_lsgrplIN,fl_ccrainIN,&
-         fl_ccsnowIN
-    real(wp),intent(in),dimension(nPoints,nLevels,nHydro) :: reffIN
-    logical,intent(in) :: use_precipitation_fluxes
-    type(size_distribution),intent(inout) :: sd
-    type(cosp_config),intent(in) :: cfg   ! Configuration options
-    
-    ! Outputs
-    type(cosp_optical_inputs),intent(inout) :: cospIN
-    type(cosp_column_inputs),intent(inout)  :: cospstateIN
-
-    type(rng_state),allocatable,dimension(:) :: rngs  ! Seeds for random number generator
-    integer,dimension(:),allocatable :: seed
-    integer,dimension(:),allocatable :: cloudsat_preclvl_index !PREC_BUG
-    integer :: i,j,k
-    real(wp),dimension(:,:), allocatable :: &
-         ls_p_rate, cv_p_rate, frac_ls, frac_cv, prec_ls, prec_cv,g_vol
-    real(wp),dimension(:,:,:),  allocatable :: &
-         frac_prec, MODIS_cloudWater, MODIS_cloudIce, fracPrecipIce, fracPrecipIce_statGrid,&
-         MODIS_watersize,MODIS_iceSize, MODIS_opticalThicknessLiq,MODIS_opticalThicknessIce
-    real(wp),dimension(:,:,:,:),allocatable :: &
-         mr_hydro, Reff, Np
-    real(wp),dimension(nPoints,nLevels) :: &
-         column_frac_out, column_prec_out, fl_lsrain, fl_lssnow, fl_lsgrpl, fl_ccrain, fl_ccsnow
-!    real(wp),dimension(nPoints,nColumns,Nlvgrid_local) :: tempOut
-    logical :: cmpGases=.true.
-
-    if (Ncolumns .gt. 1) then
-       !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-       ! Generate subcolumns for clouds (SCOPS) and precipitation type (PREC_SCOPS)
-       !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-       ! RNG used for subcolumn generation
-       allocate(rngs(nPoints),seed(nPoints))
-       seed(:)=0
-       seed = int(cospstateIN%phalf(:,Nlevels+1))  ! In case of NPoints=1
-       ! *NOTE* Chunking will change the seed
-       if (NPoints .gt. 1) seed=int((cospstateIN%phalf(:,Nlevels+1)-minval(cospstateIN%phalf(:,Nlevels+1)))/      &
-            (maxval(cospstateIN%phalf(:,Nlevels+1))-minval(cospstateIN%phalf(:,Nlevels+1)))*100000) + 1
-       call init_rng(rngs, seed)
-      
-       ! Call scops
-       call scops(NPoints,Nlevels,Ncolumns,rngs,tca,cca,overlap,cospIN%frac_out,0)
-       deallocate(seed,rngs)
-       
-       ! Sum up precipitation rates
-       allocate(ls_p_rate(nPoints,nLevels),cv_p_rate(nPoints,Nlevels))
-       if(use_precipitation_fluxes) then
-          ls_p_rate(:,1:nLevels) = fl_lsrainIN + fl_lssnowIN + fl_lsgrplIN
-          cv_p_rate(:,1:nLevels) = fl_ccrainIN + fl_ccsnowIN
-       else
-          ls_p_rate(:,1:nLevels) = 0 ! mixing_ratio(rain) + mixing_ratio(snow) + mixing_ratio (groupel)
-          cv_p_rate(:,1:nLevels) = 0 ! mixing_ratio(rain) + mixing_ratio(snow)
-       endif
-       
-       ! Call PREC_SCOPS
-       allocate(frac_prec(nPoints,nColumns,nLevels))
-       call prec_scops(nPoints,nLevels,nColumns,ls_p_rate,cv_p_rate,cospIN%frac_out,frac_prec)
-       deallocate(ls_p_rate,cv_p_rate)
-       
-       !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-       ! Compute fraction in each gridbox for precipitation  and cloud type.
-       !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-       ! Allocate
-       allocate(frac_ls(nPoints,nLevels),prec_ls(nPoints,nLevels),                       &
-                frac_cv(nPoints,nLevels),prec_cv(nPoints,nLevels))
-       
-       ! Initialize
-       frac_ls(1:nPoints,1:nLevels) = 0._wp
-       prec_ls(1:nPoints,1:nLevels) = 0._wp
-       frac_cv(1:nPoints,1:nLevels) = 0._wp
-       prec_cv(1:nPoints,1:nLevels) = 0._wp
-       do j=1,nPoints
-          do k=1,nLevels
-             do i=1,nColumns
-                if (cospIN%frac_out(j,i,k)  .eq. 1)  frac_ls(j,k) = frac_ls(j,k)+1._wp
-                if (cospIN%frac_out(j,i,k)  .eq. 2)  frac_cv(j,k) = frac_cv(j,k)+1._wp
-                if (frac_prec(j,i,k) .eq. 1)  prec_ls(j,k) = prec_ls(j,k)+1._wp
-                if (frac_prec(j,i,k) .eq. 2)  prec_cv(j,k) = prec_cv(j,k)+1._wp
-                if (frac_prec(j,i,k) .eq. 3)  prec_cv(j,k) = prec_cv(j,k)+1._wp
-                if (frac_prec(j,i,k) .eq. 3)  prec_ls(j,k) = prec_ls(j,k)+1._wp
-             enddo
-             frac_ls(j,k)=frac_ls(j,k)/nColumns
-             frac_cv(j,k)=frac_cv(j,k)/nColumns
-             prec_ls(j,k)=prec_ls(j,k)/nColumns
-             prec_cv(j,k)=prec_cv(j,k)/nColumns
-          enddo
-       enddo       
-
-       !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-       ! Assign gridmean mixing-ratios (mr_XXXXX), effective radius (ReffIN) and number
-       ! concentration (not defined) to appropriate sub-column. Here we are using scops. 
-       !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-       allocate(mr_hydro(nPoints,nColumns,nLevels,nHydro),                               &
-                Reff(nPoints,nColumns,nLevels,nHydro),                                   &
-                Np(nPoints,nColumns,nLevels,nHydro))
-
-       ! Initialize
-       mr_hydro(:,:,:,:) = 0._wp
-       Reff(:,:,:,:)     = 0._wp
-       Np(:,:,:,:)       = 0._wp
-       do k=1,nColumns
-          ! Subcolumn cloud fraction
-          column_frac_out = cospIN%frac_out(:,k,:)
-               
-          ! LS clouds
-          where (column_frac_out == I_LSC)
-             mr_hydro(:,k,:,I_LSCLIQ) = mr_lsliq
-             mr_hydro(:,k,:,I_LSCICE) = mr_lsice
-             Reff(:,k,:,I_LSCLIQ)     = ReffIN(:,:,I_LSCLIQ)
-             Reff(:,k,:,I_LSCICE)     = ReffIN(:,:,I_LSCICE)
-          ! CONV clouds   
-          elsewhere (column_frac_out == I_CVC)
-             mr_hydro(:,k,:,I_CVCLIQ) = mr_ccliq
-             mr_hydro(:,k,:,I_CVCICE) = mr_ccice
-             Reff(:,k,:,I_CVCLIQ)     = ReffIN(:,:,I_CVCLIQ)
-             Reff(:,k,:,I_CVCICE)     = ReffIN(:,:,I_CVCICE)
-          end where
-          
-          ! Subcolumn precipitation
-          column_prec_out = frac_prec(:,k,:)
-
-          ! LS Precipitation
-          where ((column_prec_out == 1) .or. (column_prec_out == 3) )
-             Reff(:,k,:,I_LSRAIN) = ReffIN(:,:,I_LSRAIN)
-             Reff(:,k,:,I_LSSNOW) = ReffIN(:,:,I_LSSNOW)
-             Reff(:,k,:,I_LSGRPL) = ReffIN(:,:,I_LSGRPL)
-             ! CONV precipitation   
-          elsewhere ((column_prec_out == 2) .or. (column_prec_out == 3))
-             Reff(:,k,:,I_CVRAIN) = ReffIN(:,:,I_CVRAIN)
-             Reff(:,k,:,I_CVSNOW) = ReffIN(:,:,I_CVSNOW)
-          end where
-       enddo
-       
-       !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-       ! Convert the subcolumn mixing ratio and precipitation fluxes from gridbox mean
-       ! values to fraction-based values. 
-       !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-       ! Initialize
-       fl_lsrain(:,:) = 0._wp
-       fl_lssnow(:,:) = 0._wp
-       fl_lsgrpl(:,:) = 0._wp
-       fl_ccrain(:,:) = 0._wp
-       fl_ccsnow(:,:) = 0._wp
-       do k=1,nLevels
-          do j=1,nPoints
-             ! In-cloud mixing ratios.
-             if (frac_ls(j,k) .ne. 0.) then
-                mr_hydro(j,:,k,I_LSCLIQ) = mr_hydro(j,:,k,I_LSCLIQ)/frac_ls(j,k)
-                mr_hydro(j,:,k,I_LSCICE) = mr_hydro(j,:,k,I_LSCICE)/frac_ls(j,k)
-             endif
-             if (frac_cv(j,k) .ne. 0.) then
-                mr_hydro(j,:,k,I_CVCLIQ) = mr_hydro(j,:,k,I_CVCLIQ)/frac_cv(j,k)
-                mr_hydro(j,:,k,I_CVCICE) = mr_hydro(j,:,k,I_CVCICE)/frac_cv(j,k)
-             endif
-             ! Precipitation
-             if (use_precipitation_fluxes) then
-                if (prec_ls(j,k) .ne. 0.) then
-                   fl_lsrain(j,k) = fl_lsrainIN(j,k)/prec_ls(j,k)
-                   fl_lssnow(j,k) = fl_lssnowIN(j,k)/prec_ls(j,k)
-                   fl_lsgrpl(j,k) = fl_lsgrplIN(j,k)/prec_ls(j,k)
-                endif
-                if (prec_cv(j,k) .ne. 0.) then
-                   fl_ccrain(j,k) = fl_ccrainIN(j,k)/prec_cv(j,k)
-                   fl_ccsnow(j,k) = fl_ccsnowIN(j,k)/prec_cv(j,k)
-                endif
-             else
-                if (prec_ls(j,k) .ne. 0.) then
-                   mr_hydro(j,:,k,I_LSRAIN) = mr_hydro(j,:,k,I_LSRAIN)/prec_ls(j,k)
-                   mr_hydro(j,:,k,I_LSSNOW) = mr_hydro(j,:,k,I_LSSNOW)/prec_ls(j,k)
-                   mr_hydro(j,:,k,I_LSGRPL) = mr_hydro(j,:,k,I_LSGRPL)/prec_ls(j,k)
-                endif
-                if (prec_cv(j,k) .ne. 0.) then
-                   mr_hydro(j,:,k,I_CVRAIN) = mr_hydro(j,:,k,I_CVRAIN)/prec_cv(j,k)
-                   mr_hydro(j,:,k,I_CVSNOW) = mr_hydro(j,:,k,I_CVSNOW)/prec_cv(j,k)
-                endif
-             endif
-          enddo
-       enddo
-
-       deallocate(frac_ls,prec_ls,frac_cv,prec_cv)
-
-       !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-       ! Convert precipitation fluxes to mixing ratios
-       !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-       if (use_precipitation_fluxes) then
-          ! LS rain
-          call cosp_precip_mxratio(nPoints, nLevels, nColumns, cospstateIN%pfull,        &
-               cospstateIN%at, frac_prec, 1._wp, n_ax(I_LSRAIN), n_bx(I_LSRAIN),         &
-               alpha_x(I_LSRAIN), c_x(I_LSRAIN),   d_x(I_LSRAIN),   g_x(I_LSRAIN),       &
-               a_x(I_LSRAIN),   b_x(I_LSRAIN),   gamma_1(I_LSRAIN), gamma_2(I_LSRAIN),   &
-               gamma_3(I_LSRAIN), gamma_4(I_LSRAIN), fl_lsrain,                          &
-               mr_hydro(:,:,:,I_LSRAIN), Reff(:,:,:,I_LSRAIN))
-          ! LS snow
-          call cosp_precip_mxratio(nPoints, nLevels, nColumns, cospstateIN%pfull,        &
-               cospstateIN%at, frac_prec, 1._wp,  n_ax(I_LSSNOW),  n_bx(I_LSSNOW),       &
-               alpha_x(I_LSSNOW), c_x(I_LSSNOW),  d_x(I_LSSNOW),  g_x(I_LSSNOW),         &
-               a_x(I_LSSNOW),   b_x(I_LSSNOW),   gamma_1(I_LSSNOW),  gamma_2(I_LSSNOW),  &
-               gamma_3(I_LSSNOW), gamma_4(I_LSSNOW), fl_lssnow,                          &
-               mr_hydro(:,:,:,I_LSSNOW), Reff(:,:,:,I_LSSNOW))
-          ! CV rain
-          call cosp_precip_mxratio(nPoints, nLevels, nColumns, cospstateIN%pfull,        &
-               cospstateIN%at, frac_prec, 2._wp, n_ax(I_CVRAIN),  n_bx(I_CVRAIN),        &
-               alpha_x(I_CVRAIN), c_x(I_CVRAIN),   d_x(I_CVRAIN),   g_x(I_CVRAIN),       &
-               a_x(I_CVRAIN),   b_x(I_CVRAIN),   gamma_1(I_CVRAIN), gamma_2(I_CVRAIN),   &
-               gamma_3(I_CVRAIN), gamma_4(I_CVRAIN), fl_ccrain,                          &
-               mr_hydro(:,:,:,I_CVRAIN), Reff(:,:,:,I_CVRAIN))
-          ! CV snow
-          call cosp_precip_mxratio(nPoints, nLevels, nColumns, cospstateIN%pfull,        &
-               cospstateIN%at, frac_prec, 2._wp, n_ax(I_CVSNOW),  n_bx(I_CVSNOW),        &
-               alpha_x(I_CVSNOW),  c_x(I_CVSNOW),   d_x(I_CVSNOW),   g_x(I_CVSNOW),      &
-               a_x(I_CVSNOW),   b_x(I_CVSNOW),   gamma_1(I_CVSNOW), gamma_2(I_CVSNOW),   &
-               gamma_3(I_CVSNOW), gamma_4(I_CVSNOW), fl_ccsnow,                          &
-               mr_hydro(:,:,:,I_CVSNOW), Reff(:,:,:,I_CVSNOW))
-          ! LS groupel.
-          call cosp_precip_mxratio(nPoints, nLevels, nColumns, cospstateIN%pfull,        &
-               cospstateIN%at, frac_prec, 1._wp, n_ax(I_LSGRPL),  n_bx(I_LSGRPL),        &
-               alpha_x(I_LSGRPL), c_x(I_LSGRPL),   d_x(I_LSGRPL),   g_x(I_LSGRPL),       &
-               a_x(I_LSGRPL),   b_x(I_LSGRPL),   gamma_1(I_LSGRPL),  gamma_2(I_LSGRPL),  &
-               gamma_3(I_LSGRPL), gamma_4(I_LSGRPL), fl_lsgrpl,                          &
-               mr_hydro(:,:,:,I_LSGRPL), Reff(:,:,:,I_LSGRPL))
-          deallocate(frac_prec)
-       endif
-
-    else
-       cospIN%frac_out(:,:,:) = 1  
-       allocate(mr_hydro(nPoints,1,nLevels,nHydro),Reff(nPoints,1,nLevels,nHydro),       &
-                Np(nPoints,1,nLevels,nHydro))
-       mr_hydro(:,1,:,I_LSCLIQ) = mr_lsliq
-       mr_hydro(:,1,:,I_LSCICE) = mr_lsice
-       mr_hydro(:,1,:,I_CVCLIQ) = mr_ccliq
-       mr_hydro(:,1,:,I_CVCICE) = mr_ccice
-       Reff(:,1,:,:)            = ReffIN
-    endif
-    
-    !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-    ! 11 micron emissivity
-    !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-    if (cfg%Lisccp) then
-       call cosp_simulator_optics(nPoints,nColumns,nLevels,cospIN%frac_out,dem_c,dem_s,    &
-                                  cospIN%emiss_11)
-    endif
-    !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-    ! 0.67 micron optical depth
-    !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-    if (cfg%Lisccp .or. cfg%Lmisr .or. cfg%Lmodis) then
-       call cosp_simulator_optics(nPoints,nColumns,nLevels,cospIN%frac_out,dtau_c,dtau_s,  &
-                                  cospIN%tau_067)
-    endif
-    !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-    ! LIDAR Polarized optics
-    !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-    if (cfg%Lcalipso) then
-       call lidar_optics(nPoints, nColumns, nLevels, 4, lidar_ice_type, 532, .false.,      &
-            mr_hydro(:,:,:,I_LSCLIQ),  mr_hydro(:,:,:,I_LSCICE), mr_hydro(:,:,:,I_CVCLIQ), &
-            mr_hydro(:,:,:,I_CVCICE), ReffIN(:,:,I_LSCLIQ), ReffIN(:,:,I_LSCICE),          &
-            ReffIN(:,:,I_CVCLIQ), ReffIN(:,:,I_CVCICE), cospstateIN%pfull,                 &
-            cospstateIN%phalf, cospstateIN%at, cospIN%beta_mol_calipso,                    &
-            cospIN%betatot_calipso, cospIN%tau_mol_calipso, cospIN%tautot_calipso,         &
-            cospIN%tautot_S_liq, cospIN%tautot_S_ice, cospIN%betatot_ice_calipso,          &
-            cospIN%betatot_liq_calipso, cospIN%tautot_ice_calipso, cospIN%tautot_liq_calipso)
-    endif
-
-    if (cfg%LgrLidar532) then
-       call lidar_optics(nPoints, nColumns, nLevels, 4, lidar_ice_type, 532, .true.,       &
-            mr_hydro(:,:,:,I_LSCLIQ),  mr_hydro(:,:,:,I_LSCICE), mr_hydro(:,:,:,I_CVCLIQ), &
-            mr_hydro(:,:,:,I_CVCICE), ReffIN(:,:,I_LSCLIQ), ReffIN(:,:,I_LSCICE),          &
-            ReffIN(:,:,I_CVCLIQ), ReffIN(:,:,I_CVCICE), cospstateIN%pfull,                 &
-            cospstateIN%phalf, cospstateIN%at, cospIN%beta_mol_grLidar532,                 &
-            cospIN%betatot_grLidar532, cospIN%tau_mol_grLidar532, cospIN%tautot_grLidar532)
-    endif
-    
-    if (cfg%Latlid) then
-       call lidar_optics(nPoints, nColumns, nLevels, 4, lidar_ice_type, 355, .false.,      &
-            mr_hydro(:,:,:,I_LSCLIQ),  mr_hydro(:,:,:,I_LSCICE), mr_hydro(:,:,:,I_CVCLIQ), &
-            mr_hydro(:,:,:,I_CVCICE), ReffIN(:,:,I_LSCLIQ), ReffIN(:,:,I_LSCICE),          &
-            ReffIN(:,:,I_CVCLIQ), ReffIN(:,:,I_CVCICE), cospstateIN%pfull,                 &
-            cospstateIN%phalf, cospstateIN%at, cospIN%beta_mol_atlid, cospIN%betatot_atlid,&
-            cospIN%tau_mol_atlid, cospIN%tautot_atlid)
-    endif
-    
-    !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-    ! CLOUDSAT RADAR OPTICS
-    !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-    if (cfg%Lcloudsat) then
-
-       ! Compute gaseous absorption (assume identical for each subcolun)
-       allocate(g_vol(nPoints,nLevels))
-       g_vol(:,:)=0._wp
-       do i=1,nPoints
-          do j=1,nLevels
-             if (cospIN%rcfg_cloudsat%use_gas_abs == 1 .or. (cospIN%rcfg_cloudsat%use_gas_abs == 2 .and. j .eq. 1)) then
-                g_vol(i,j) = gases(cospstateIN%pfull(i,j), cospstateIN%at(i,j),cospstateIN%qv(i,j),cospIN%rcfg_cloudsat%freq)
-             endif
-             cospIN%g_vol_cloudsat(i,:,j)=g_vol(i,j)
-          end do
-       end do
-       
-       ! Loop over all subcolumns
-       allocate(fracPrecipIce(nPoints,nColumns,nLevels))
-       fracPrecipIce(:,:,:) = 0._wp
-       do k=1,nColumns
-          call quickbeam_optics(sd, cospIN%rcfg_cloudsat, nPoints, nLevels, R_UNDEF,  &
-               mr_hydro(:,k,:,1:nHydro)*1000._wp, Reff(:,k,:,1:nHydro)*1.e6_wp,&
-               Np(:,k,:,1:nHydro), cospstateIN%pfull, cospstateIN%at,          &
-               cospstateIN%qv, cospIN%z_vol_cloudsat(1:nPoints,k,:),           &
-               cospIN%kr_vol_cloudsat(1:nPoints,k,:))
-          
-          ! At each model level, what fraction of the precipitation is frozen?
-          where(mr_hydro(:,k,:,I_LSRAIN) .gt. 0 .or. mr_hydro(:,k,:,I_LSSNOW) .gt. 0 .or. &
-                mr_hydro(:,k,:,I_CVRAIN) .gt. 0 .or. mr_hydro(:,k,:,I_CVSNOW) .gt. 0 .or. &
-                mr_hydro(:,k,:,I_LSGRPL) .gt. 0)
-             fracPrecipIce(:,k,:) = (mr_hydro(:,k,:,I_LSSNOW) + mr_hydro(:,k,:,I_CVSNOW) + &
-                  mr_hydro(:,k,:,I_LSGRPL)) / &
-                  (mr_hydro(:,k,:,I_LSSNOW) + mr_hydro(:,k,:,I_CVSNOW) + mr_hydro(:,k,:,I_LSGRPL) + &
-                  mr_hydro(:,k,:,I_LSRAIN)  + mr_hydro(:,k,:,I_CVRAIN))
-          elsewhere
-             fracPrecipIce(:,k,:) = 0._wp
-          endwhere
-       enddo
-
-       ! Regrid frozen fraction to Cloudsat/Calipso statistical grid
-       allocate(fracPrecipIce_statGrid(nPoints,nColumns,Nlvgrid))
-       fracPrecipIce_statGrid(:,:,:) = 0._wp
-       call cosp_change_vertical_grid(Npoints, Ncolumns, Nlevels, cospstateIN%hgt_matrix(:,Nlevels:1:-1), &
-            cospstateIN%hgt_matrix_half(:,Nlevels:1:-1), fracPrecipIce(:,:,Nlevels:1:-1), Nlvgrid,  &
-!            vgrid_zl(Nlvgrid:1:-1),  vgrid_zu(Nlvgrid:1:-1), fracPrecipIce_statGrid)  !!! ORIGINAL
-            vgrid_zl(Nlvgrid:1:-1),  vgrid_zu(Nlvgrid:1:-1), fracPrecipIce_statGrid(:,:,Nlvgrid:1:-1)) !DEBUG fracPrecipIce_statGrid
-
-       ! Find proper layer to compute precip flags in Cloudsat/Calipso statistical grid     !PREC_BUG
-       allocate(cloudsat_preclvl_index(nPoints))                                            !PREC_BUG
-       cloudsat_preclvl_index(:) = 0._wp                                                    !PREC_BUG
-       ! Computing altitude index for precip flags calculation (2nd layer above surfelev)   !PREC_BUG
-       cloudsat_preclvl_index(:) = 39 - floor( cospstateIN%surfelev(:)/480. )               !PREC_BUG
-
-       ! For near-surface diagnostics, we only need the frozen fraction at one layer.
-       do i=1,nPoints                                                                       !PREC_BUG
-	  cospIN%fracPrecipIce(i,:) = fracPrecipIce_statGrid(i,:,cloudsat_preclvl_index(i)) !PREC_BUG
-       enddo                                                                                !PREC_BUG
-!       cospIN%fracPrecipIce(:,:) = fracPrecipIce_statGrid(:,:,cloudsat_preclvl)      !!! ORIGINAL
-!       cospIN%fracPrecipIce(:,:) = fracPrecipIce_statGrid(:,:,2)                      !!! TEST ARTEM
-       
-    endif
-   
-    !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-    ! MODIS optics
-    !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-    if (cfg%Lmodis) then
-       allocate(MODIS_cloudWater(nPoints,nColumns,nLevels),                                &
-                MODIS_cloudIce(nPoints,nColumns,nLevels),                                  &
-                MODIS_waterSize(nPoints,nColumns,nLevels),                                 &
-                MODIS_iceSize(nPoints,nColumns,nLevels),                                   &
-                MODIS_opticalThicknessLiq(nPoints,nColumns,nLevels),                       &
-                MODIS_opticalThicknessIce(nPoints,nColumns,nLevels))
-       ! Cloud water
-       call cosp_simulator_optics(nPoints,nColumns,nLevels,cospIN%frac_out,                &
-            mr_hydro(:,:,:,I_CVCLIQ),mr_hydro(:,:,:,I_LSCLIQ),MODIS_cloudWater)
-       ! Cloud ice
-       call cosp_simulator_optics(nPoints,nColumns,nLevels,cospIN%frac_out,                &
-            mr_hydro(:,:,:,I_CVCICE),mr_hydro(:,:,:,I_LSCICE),MODIS_cloudIce)  
-       ! Water droplet size
-       call cosp_simulator_optics(nPoints,nColumns,nLevels,cospIN%frac_out,                &
-            Reff(:,:,:,I_CVCLIQ),Reff(:,:,:,I_LSCLIQ),MODIS_waterSize)
-       ! Ice crystal size
-       call cosp_simulator_optics(nPoints,nColumns,nLevels,cospIN%frac_out,                &
-            Reff(:,:,:,I_CVCICE),Reff(:,:,:,I_LSCICE),MODIS_iceSize)
-       
-       ! Partition optical thickness into liquid and ice parts
-       call modis_optics_partition(nPoints, nLevels, nColumns, MODIS_cloudWater,           &
-            MODIS_cloudIce, MODIS_waterSize, MODIS_iceSize, cospIN%tau_067,                &
-            MODIS_opticalThicknessLiq, MODIS_opticalThicknessIce)
-       
-       ! Compute assymetry parameter and single scattering albedo 
-       call modis_optics(nPoints, nLevels, nColumns, MODIS_opticalThicknessLiq,            &
-            MODIS_waterSize*1.0e6_wp, MODIS_opticalThicknessIce,                           &
-            MODIS_iceSize*1.0e6_wp, cospIN%fracLiq, cospIN%asym, cospIN%ss_alb)
-       
-       ! Deallocate memory
-       deallocate(MODIS_cloudWater,MODIS_cloudIce,MODIS_WaterSize,MODIS_iceSize,           &
-            MODIS_opticalThicknessLiq,MODIS_opticalThicknessIce,mr_hydro,                  &
-            Np,Reff)
-    endif
-  end subroutine subsample_and_optics
-
-END MODULE LMDZ_COSP_SUBSAMPLE_AND_OPTICS_MOD
Index: /LMDZ6/trunk/libf/phylmd/cospv2/lmdz_cosp_subsample_and_optics_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cospv2/lmdz_cosp_subsample_and_optics_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/cospv2/lmdz_cosp_subsample_and_optics_mod.f90	(revision 5268)
@@ -0,0 +1,456 @@
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+!
+! Module pour remplir la variable "cospIN", calculs des proprietes optiques subcolumn
+! pour les differents simulateurs
+!
+!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+MODULE LMDZ_COSP_SUBSAMPLE_AND_OPTICS_MOD
+
+use cosp_kinds,                only: wp                         
+USE MOD_COSP_CONFIG
+USE mod_quickbeam_optics,      only: size_distribution,quickbeam_optics,gases
+use quickbeam,                 only: radar_cfg
+use MOD_COSP,                  only: cosp_optical_inputs,cosp_column_inputs
+USE mod_rng,                   ONLY: rng_state, init_rng
+USE mod_scops,                 ONLY: scops
+USE mod_prec_scops,            ONLY: prec_scops
+USE MOD_COSP_UTILS,            ONLY: cosp_precip_mxratio
+use cosp_optics,               ONLY: cosp_simulator_optics,lidar_optics,modis_optics,   &
+                                     modis_optics_partition
+use mod_cosp_stats,            ONLY: COSP_CHANGE_VERTICAL_GRID
+use lmdz_cosp_read_outputkeys, ONLY: cosp_config
+
+
+  implicit none
+
+  ! Indices to address arrays of LS and CONV hydrometeors
+  integer,parameter :: &
+       I_LSCLIQ = 1, & ! Large-scale (stratiform) liquid
+       I_LSCICE = 2, & ! Large-scale (stratiform) ice
+       I_LSRAIN = 3, & ! Large-scale (stratiform) rain
+       I_LSSNOW = 4, & ! Large-scale (stratiform) snow
+       I_CVCLIQ = 5, & ! Convective liquid
+       I_CVCICE = 6, & ! Convective ice
+       I_CVRAIN = 7, & ! Convective rain
+       I_CVSNOW = 8, & ! Convective snow
+       I_LSGRPL = 9    ! Large-scale (stratiform) groupel
+  
+  ! Stratiform and convective clouds in frac_out.
+  integer, parameter :: &
+       I_LSC = 1, & ! Large-scale clouds
+       I_CVC = 2    ! Convective clouds      
+  
+  ! Microphysical settings for the precipitation flux to mixing ratio conversion
+  real(wp),parameter,dimension(N_HYDRO) :: &
+                 ! LSL   LSI      LSR       LSS   CVL  CVI      CVR       CVS       LSG
+       N_ax    = (/-1., -1.,     8.e6,     3.e6, -1., -1.,     8.e6,     3.e6,     4.e6/),&
+       N_bx    = (/-1., -1.,      0.0,      0.0, -1., -1.,      0.0,      0.0,      0.0/),&
+       alpha_x = (/-1., -1.,      0.0,      0.0, -1., -1.,      0.0,      0.0,      0.0/),&
+       c_x     = (/-1., -1.,    842.0,     4.84, -1., -1.,    842.0,     4.84,     94.5/),&
+       d_x     = (/-1., -1.,      0.8,     0.25, -1., -1.,      0.8,     0.25,      0.5/),&
+       g_x     = (/-1., -1.,      0.5,      0.5, -1., -1.,      0.5,      0.5,      0.5/),&
+       a_x     = (/-1., -1.,    524.0,    52.36, -1., -1.,    524.0,    52.36,   209.44/),&
+       b_x     = (/-1., -1.,      3.0,      3.0, -1., -1.,      3.0,      3.0,      3.0/),&
+       gamma_1 = (/-1., -1., 17.83725, 8.284701, -1., -1., 17.83725, 8.284701, 11.63230/),&
+       gamma_2 = (/-1., -1.,      6.0,      6.0, -1., -1.,      6.0,      6.0,      6.0/),&
+       gamma_3 = (/-1., -1.,      2.0,      2.0, -1., -1.,      2.0,      2.0,      2.0/),&
+       gamma_4 = (/-1., -1.,      6.0,      6.0, -1., -1.,      6.0,      6.0,      6.0/)
+
+
+contains
+
+  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%  
+  ! SUBROUTINE subsample_and_optics
+  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%  
+  subroutine subsample_and_optics(cfg, nPoints, nLevels, nColumns, nHydro, overlap, &
+       use_precipitation_fluxes, lidar_ice_type, sd, tca, cca, fl_lsrainIN, fl_lssnowIN,    &
+       fl_lsgrplIN, fl_ccrainIN, fl_ccsnowIN, mr_lsliq, mr_lsice, mr_ccliq, mr_ccice,       &
+       reffIN, dtau_c, dtau_s, dem_c, dem_s, cospstateIN, cospIN)
+    ! Inputs
+    integer,intent(in) :: nPoints, nLevels, nColumns, nHydro, overlap, lidar_ice_type
+    real(wp),intent(in),dimension(nPoints,nLevels) :: tca,cca,mr_lsliq,mr_lsice,mr_ccliq,   &
+         mr_ccice,dtau_c,dtau_s,dem_c,dem_s,fl_lsrainIN,fl_lssnowIN,fl_lsgrplIN,fl_ccrainIN,&
+         fl_ccsnowIN
+    real(wp),intent(in),dimension(nPoints,nLevels,nHydro) :: reffIN
+    logical,intent(in) :: use_precipitation_fluxes
+    type(size_distribution),intent(inout) :: sd
+    type(cosp_config),intent(in) :: cfg   ! Configuration options
+    
+    ! Outputs
+    type(cosp_optical_inputs),intent(inout) :: cospIN
+    type(cosp_column_inputs),intent(inout)  :: cospstateIN
+
+    type(rng_state),allocatable,dimension(:) :: rngs  ! Seeds for random number generator
+    integer,dimension(:),allocatable :: seed
+    integer,dimension(:),allocatable :: cloudsat_preclvl_index !PREC_BUG
+    integer :: i,j,k
+    real(wp),dimension(:,:), allocatable :: &
+         ls_p_rate, cv_p_rate, frac_ls, frac_cv, prec_ls, prec_cv,g_vol
+    real(wp),dimension(:,:,:),  allocatable :: &
+         frac_prec, MODIS_cloudWater, MODIS_cloudIce, fracPrecipIce, fracPrecipIce_statGrid,&
+         MODIS_watersize,MODIS_iceSize, MODIS_opticalThicknessLiq,MODIS_opticalThicknessIce
+    real(wp),dimension(:,:,:,:),allocatable :: &
+         mr_hydro, Reff, Np
+    real(wp),dimension(nPoints,nLevels) :: &
+         column_frac_out, column_prec_out, fl_lsrain, fl_lssnow, fl_lsgrpl, fl_ccrain, fl_ccsnow
+!    real(wp),dimension(nPoints,nColumns,Nlvgrid_local) :: tempOut
+    logical :: cmpGases=.true.
+
+    if (Ncolumns .gt. 1) then
+       !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+       ! Generate subcolumns for clouds (SCOPS) and precipitation type (PREC_SCOPS)
+       !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+       ! RNG used for subcolumn generation
+       allocate(rngs(nPoints),seed(nPoints))
+       seed(:)=0
+       seed = int(cospstateIN%phalf(:,Nlevels+1))  ! In case of NPoints=1
+       ! *NOTE* Chunking will change the seed
+       if (NPoints .gt. 1) seed=int((cospstateIN%phalf(:,Nlevels+1)-minval(cospstateIN%phalf(:,Nlevels+1)))/      &
+            (maxval(cospstateIN%phalf(:,Nlevels+1))-minval(cospstateIN%phalf(:,Nlevels+1)))*100000) + 1
+       call init_rng(rngs, seed)
+      
+       ! Call scops
+       call scops(NPoints,Nlevels,Ncolumns,rngs,tca,cca,overlap,cospIN%frac_out,0)
+       deallocate(seed,rngs)
+       
+       ! Sum up precipitation rates
+       allocate(ls_p_rate(nPoints,nLevels),cv_p_rate(nPoints,Nlevels))
+       if(use_precipitation_fluxes) then
+          ls_p_rate(:,1:nLevels) = fl_lsrainIN + fl_lssnowIN + fl_lsgrplIN
+          cv_p_rate(:,1:nLevels) = fl_ccrainIN + fl_ccsnowIN
+       else
+          ls_p_rate(:,1:nLevels) = 0 ! mixing_ratio(rain) + mixing_ratio(snow) + mixing_ratio (groupel)
+          cv_p_rate(:,1:nLevels) = 0 ! mixing_ratio(rain) + mixing_ratio(snow)
+       endif
+       
+       ! Call PREC_SCOPS
+       allocate(frac_prec(nPoints,nColumns,nLevels))
+       call prec_scops(nPoints,nLevels,nColumns,ls_p_rate,cv_p_rate,cospIN%frac_out,frac_prec)
+       deallocate(ls_p_rate,cv_p_rate)
+       
+       !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+       ! Compute fraction in each gridbox for precipitation  and cloud type.
+       !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+       ! Allocate
+       allocate(frac_ls(nPoints,nLevels),prec_ls(nPoints,nLevels),                       &
+                frac_cv(nPoints,nLevels),prec_cv(nPoints,nLevels))
+       
+       ! Initialize
+       frac_ls(1:nPoints,1:nLevels) = 0._wp
+       prec_ls(1:nPoints,1:nLevels) = 0._wp
+       frac_cv(1:nPoints,1:nLevels) = 0._wp
+       prec_cv(1:nPoints,1:nLevels) = 0._wp
+       do j=1,nPoints
+          do k=1,nLevels
+             do i=1,nColumns
+                if (cospIN%frac_out(j,i,k)  .eq. 1)  frac_ls(j,k) = frac_ls(j,k)+1._wp
+                if (cospIN%frac_out(j,i,k)  .eq. 2)  frac_cv(j,k) = frac_cv(j,k)+1._wp
+                if (frac_prec(j,i,k) .eq. 1)  prec_ls(j,k) = prec_ls(j,k)+1._wp
+                if (frac_prec(j,i,k) .eq. 2)  prec_cv(j,k) = prec_cv(j,k)+1._wp
+                if (frac_prec(j,i,k) .eq. 3)  prec_cv(j,k) = prec_cv(j,k)+1._wp
+                if (frac_prec(j,i,k) .eq. 3)  prec_ls(j,k) = prec_ls(j,k)+1._wp
+             enddo
+             frac_ls(j,k)=frac_ls(j,k)/nColumns
+             frac_cv(j,k)=frac_cv(j,k)/nColumns
+             prec_ls(j,k)=prec_ls(j,k)/nColumns
+             prec_cv(j,k)=prec_cv(j,k)/nColumns
+          enddo
+       enddo       
+
+       !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+       ! Assign gridmean mixing-ratios (mr_XXXXX), effective radius (ReffIN) and number
+       ! concentration (not defined) to appropriate sub-column. Here we are using scops. 
+       !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+       allocate(mr_hydro(nPoints,nColumns,nLevels,nHydro),                               &
+                Reff(nPoints,nColumns,nLevels,nHydro),                                   &
+                Np(nPoints,nColumns,nLevels,nHydro))
+
+       ! Initialize
+       mr_hydro(:,:,:,:) = 0._wp
+       Reff(:,:,:,:)     = 0._wp
+       Np(:,:,:,:)       = 0._wp
+       do k=1,nColumns
+          ! Subcolumn cloud fraction
+          column_frac_out = cospIN%frac_out(:,k,:)
+               
+          ! LS clouds
+          where (column_frac_out == I_LSC)
+             mr_hydro(:,k,:,I_LSCLIQ) = mr_lsliq
+             mr_hydro(:,k,:,I_LSCICE) = mr_lsice
+             Reff(:,k,:,I_LSCLIQ)     = ReffIN(:,:,I_LSCLIQ)
+             Reff(:,k,:,I_LSCICE)     = ReffIN(:,:,I_LSCICE)
+          ! CONV clouds   
+          elsewhere (column_frac_out == I_CVC)
+             mr_hydro(:,k,:,I_CVCLIQ) = mr_ccliq
+             mr_hydro(:,k,:,I_CVCICE) = mr_ccice
+             Reff(:,k,:,I_CVCLIQ)     = ReffIN(:,:,I_CVCLIQ)
+             Reff(:,k,:,I_CVCICE)     = ReffIN(:,:,I_CVCICE)
+          end where
+          
+          ! Subcolumn precipitation
+          column_prec_out = frac_prec(:,k,:)
+
+          ! LS Precipitation
+          where ((column_prec_out == 1) .or. (column_prec_out == 3) )
+             Reff(:,k,:,I_LSRAIN) = ReffIN(:,:,I_LSRAIN)
+             Reff(:,k,:,I_LSSNOW) = ReffIN(:,:,I_LSSNOW)
+             Reff(:,k,:,I_LSGRPL) = ReffIN(:,:,I_LSGRPL)
+             ! CONV precipitation   
+          elsewhere ((column_prec_out == 2) .or. (column_prec_out == 3))
+             Reff(:,k,:,I_CVRAIN) = ReffIN(:,:,I_CVRAIN)
+             Reff(:,k,:,I_CVSNOW) = ReffIN(:,:,I_CVSNOW)
+          end where
+       enddo
+       
+       !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+       ! Convert the subcolumn mixing ratio and precipitation fluxes from gridbox mean
+       ! values to fraction-based values. 
+       !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+       ! Initialize
+       fl_lsrain(:,:) = 0._wp
+       fl_lssnow(:,:) = 0._wp
+       fl_lsgrpl(:,:) = 0._wp
+       fl_ccrain(:,:) = 0._wp
+       fl_ccsnow(:,:) = 0._wp
+       do k=1,nLevels
+          do j=1,nPoints
+             ! In-cloud mixing ratios.
+             if (frac_ls(j,k) .ne. 0.) then
+                mr_hydro(j,:,k,I_LSCLIQ) = mr_hydro(j,:,k,I_LSCLIQ)/frac_ls(j,k)
+                mr_hydro(j,:,k,I_LSCICE) = mr_hydro(j,:,k,I_LSCICE)/frac_ls(j,k)
+             endif
+             if (frac_cv(j,k) .ne. 0.) then
+                mr_hydro(j,:,k,I_CVCLIQ) = mr_hydro(j,:,k,I_CVCLIQ)/frac_cv(j,k)
+                mr_hydro(j,:,k,I_CVCICE) = mr_hydro(j,:,k,I_CVCICE)/frac_cv(j,k)
+             endif
+             ! Precipitation
+             if (use_precipitation_fluxes) then
+                if (prec_ls(j,k) .ne. 0.) then
+                   fl_lsrain(j,k) = fl_lsrainIN(j,k)/prec_ls(j,k)
+                   fl_lssnow(j,k) = fl_lssnowIN(j,k)/prec_ls(j,k)
+                   fl_lsgrpl(j,k) = fl_lsgrplIN(j,k)/prec_ls(j,k)
+                endif
+                if (prec_cv(j,k) .ne. 0.) then
+                   fl_ccrain(j,k) = fl_ccrainIN(j,k)/prec_cv(j,k)
+                   fl_ccsnow(j,k) = fl_ccsnowIN(j,k)/prec_cv(j,k)
+                endif
+             else
+                if (prec_ls(j,k) .ne. 0.) then
+                   mr_hydro(j,:,k,I_LSRAIN) = mr_hydro(j,:,k,I_LSRAIN)/prec_ls(j,k)
+                   mr_hydro(j,:,k,I_LSSNOW) = mr_hydro(j,:,k,I_LSSNOW)/prec_ls(j,k)
+                   mr_hydro(j,:,k,I_LSGRPL) = mr_hydro(j,:,k,I_LSGRPL)/prec_ls(j,k)
+                endif
+                if (prec_cv(j,k) .ne. 0.) then
+                   mr_hydro(j,:,k,I_CVRAIN) = mr_hydro(j,:,k,I_CVRAIN)/prec_cv(j,k)
+                   mr_hydro(j,:,k,I_CVSNOW) = mr_hydro(j,:,k,I_CVSNOW)/prec_cv(j,k)
+                endif
+             endif
+          enddo
+       enddo
+
+       deallocate(frac_ls,prec_ls,frac_cv,prec_cv)
+
+       !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+       ! Convert precipitation fluxes to mixing ratios
+       !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+       if (use_precipitation_fluxes) then
+          ! LS rain
+          call cosp_precip_mxratio(nPoints, nLevels, nColumns, cospstateIN%pfull,        &
+               cospstateIN%at, frac_prec, 1._wp, n_ax(I_LSRAIN), n_bx(I_LSRAIN),         &
+               alpha_x(I_LSRAIN), c_x(I_LSRAIN),   d_x(I_LSRAIN),   g_x(I_LSRAIN),       &
+               a_x(I_LSRAIN),   b_x(I_LSRAIN),   gamma_1(I_LSRAIN), gamma_2(I_LSRAIN),   &
+               gamma_3(I_LSRAIN), gamma_4(I_LSRAIN), fl_lsrain,                          &
+               mr_hydro(:,:,:,I_LSRAIN), Reff(:,:,:,I_LSRAIN))
+          ! LS snow
+          call cosp_precip_mxratio(nPoints, nLevels, nColumns, cospstateIN%pfull,        &
+               cospstateIN%at, frac_prec, 1._wp,  n_ax(I_LSSNOW),  n_bx(I_LSSNOW),       &
+               alpha_x(I_LSSNOW), c_x(I_LSSNOW),  d_x(I_LSSNOW),  g_x(I_LSSNOW),         &
+               a_x(I_LSSNOW),   b_x(I_LSSNOW),   gamma_1(I_LSSNOW),  gamma_2(I_LSSNOW),  &
+               gamma_3(I_LSSNOW), gamma_4(I_LSSNOW), fl_lssnow,                          &
+               mr_hydro(:,:,:,I_LSSNOW), Reff(:,:,:,I_LSSNOW))
+          ! CV rain
+          call cosp_precip_mxratio(nPoints, nLevels, nColumns, cospstateIN%pfull,        &
+               cospstateIN%at, frac_prec, 2._wp, n_ax(I_CVRAIN),  n_bx(I_CVRAIN),        &
+               alpha_x(I_CVRAIN), c_x(I_CVRAIN),   d_x(I_CVRAIN),   g_x(I_CVRAIN),       &
+               a_x(I_CVRAIN),   b_x(I_CVRAIN),   gamma_1(I_CVRAIN), gamma_2(I_CVRAIN),   &
+               gamma_3(I_CVRAIN), gamma_4(I_CVRAIN), fl_ccrain,                          &
+               mr_hydro(:,:,:,I_CVRAIN), Reff(:,:,:,I_CVRAIN))
+          ! CV snow
+          call cosp_precip_mxratio(nPoints, nLevels, nColumns, cospstateIN%pfull,        &
+               cospstateIN%at, frac_prec, 2._wp, n_ax(I_CVSNOW),  n_bx(I_CVSNOW),        &
+               alpha_x(I_CVSNOW),  c_x(I_CVSNOW),   d_x(I_CVSNOW),   g_x(I_CVSNOW),      &
+               a_x(I_CVSNOW),   b_x(I_CVSNOW),   gamma_1(I_CVSNOW), gamma_2(I_CVSNOW),   &
+               gamma_3(I_CVSNOW), gamma_4(I_CVSNOW), fl_ccsnow,                          &
+               mr_hydro(:,:,:,I_CVSNOW), Reff(:,:,:,I_CVSNOW))
+          ! LS groupel.
+          call cosp_precip_mxratio(nPoints, nLevels, nColumns, cospstateIN%pfull,        &
+               cospstateIN%at, frac_prec, 1._wp, n_ax(I_LSGRPL),  n_bx(I_LSGRPL),        &
+               alpha_x(I_LSGRPL), c_x(I_LSGRPL),   d_x(I_LSGRPL),   g_x(I_LSGRPL),       &
+               a_x(I_LSGRPL),   b_x(I_LSGRPL),   gamma_1(I_LSGRPL),  gamma_2(I_LSGRPL),  &
+               gamma_3(I_LSGRPL), gamma_4(I_LSGRPL), fl_lsgrpl,                          &
+               mr_hydro(:,:,:,I_LSGRPL), Reff(:,:,:,I_LSGRPL))
+          deallocate(frac_prec)
+       endif
+
+    else
+       cospIN%frac_out(:,:,:) = 1  
+       allocate(mr_hydro(nPoints,1,nLevels,nHydro),Reff(nPoints,1,nLevels,nHydro),       &
+                Np(nPoints,1,nLevels,nHydro))
+       mr_hydro(:,1,:,I_LSCLIQ) = mr_lsliq
+       mr_hydro(:,1,:,I_LSCICE) = mr_lsice
+       mr_hydro(:,1,:,I_CVCLIQ) = mr_ccliq
+       mr_hydro(:,1,:,I_CVCICE) = mr_ccice
+       Reff(:,1,:,:)            = ReffIN
+    endif
+    
+    !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+    ! 11 micron emissivity
+    !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+    if (cfg%Lisccp) then
+       call cosp_simulator_optics(nPoints,nColumns,nLevels,cospIN%frac_out,dem_c,dem_s,    &
+                                  cospIN%emiss_11)
+    endif
+    !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+    ! 0.67 micron optical depth
+    !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+    if (cfg%Lisccp .or. cfg%Lmisr .or. cfg%Lmodis) then
+       call cosp_simulator_optics(nPoints,nColumns,nLevels,cospIN%frac_out,dtau_c,dtau_s,  &
+                                  cospIN%tau_067)
+    endif
+    !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+    ! LIDAR Polarized optics
+    !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+    if (cfg%Lcalipso) then
+       call lidar_optics(nPoints, nColumns, nLevels, 4, lidar_ice_type, 532, .false.,      &
+            mr_hydro(:,:,:,I_LSCLIQ),  mr_hydro(:,:,:,I_LSCICE), mr_hydro(:,:,:,I_CVCLIQ), &
+            mr_hydro(:,:,:,I_CVCICE), ReffIN(:,:,I_LSCLIQ), ReffIN(:,:,I_LSCICE),          &
+            ReffIN(:,:,I_CVCLIQ), ReffIN(:,:,I_CVCICE), cospstateIN%pfull,                 &
+            cospstateIN%phalf, cospstateIN%at, cospIN%beta_mol_calipso,                    &
+            cospIN%betatot_calipso, cospIN%tau_mol_calipso, cospIN%tautot_calipso,         &
+            cospIN%tautot_S_liq, cospIN%tautot_S_ice, cospIN%betatot_ice_calipso,          &
+            cospIN%betatot_liq_calipso, cospIN%tautot_ice_calipso, cospIN%tautot_liq_calipso)
+    endif
+
+    if (cfg%LgrLidar532) then
+       call lidar_optics(nPoints, nColumns, nLevels, 4, lidar_ice_type, 532, .true.,       &
+            mr_hydro(:,:,:,I_LSCLIQ),  mr_hydro(:,:,:,I_LSCICE), mr_hydro(:,:,:,I_CVCLIQ), &
+            mr_hydro(:,:,:,I_CVCICE), ReffIN(:,:,I_LSCLIQ), ReffIN(:,:,I_LSCICE),          &
+            ReffIN(:,:,I_CVCLIQ), ReffIN(:,:,I_CVCICE), cospstateIN%pfull,                 &
+            cospstateIN%phalf, cospstateIN%at, cospIN%beta_mol_grLidar532,                 &
+            cospIN%betatot_grLidar532, cospIN%tau_mol_grLidar532, cospIN%tautot_grLidar532)
+    endif
+    
+    if (cfg%Latlid) then
+       call lidar_optics(nPoints, nColumns, nLevels, 4, lidar_ice_type, 355, .false.,      &
+            mr_hydro(:,:,:,I_LSCLIQ),  mr_hydro(:,:,:,I_LSCICE), mr_hydro(:,:,:,I_CVCLIQ), &
+            mr_hydro(:,:,:,I_CVCICE), ReffIN(:,:,I_LSCLIQ), ReffIN(:,:,I_LSCICE),          &
+            ReffIN(:,:,I_CVCLIQ), ReffIN(:,:,I_CVCICE), cospstateIN%pfull,                 &
+            cospstateIN%phalf, cospstateIN%at, cospIN%beta_mol_atlid, cospIN%betatot_atlid,&
+            cospIN%tau_mol_atlid, cospIN%tautot_atlid)
+    endif
+    
+    !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+    ! CLOUDSAT RADAR OPTICS
+    !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+    if (cfg%Lcloudsat) then
+
+       ! Compute gaseous absorption (assume identical for each subcolun)
+       allocate(g_vol(nPoints,nLevels))
+       g_vol(:,:)=0._wp
+       do i=1,nPoints
+          do j=1,nLevels
+             if (cospIN%rcfg_cloudsat%use_gas_abs == 1 .or. (cospIN%rcfg_cloudsat%use_gas_abs == 2 .and. j .eq. 1)) then
+                g_vol(i,j) = gases(cospstateIN%pfull(i,j), cospstateIN%at(i,j),cospstateIN%qv(i,j),cospIN%rcfg_cloudsat%freq)
+             endif
+             cospIN%g_vol_cloudsat(i,:,j)=g_vol(i,j)
+          end do
+       end do
+       
+       ! Loop over all subcolumns
+       allocate(fracPrecipIce(nPoints,nColumns,nLevels))
+       fracPrecipIce(:,:,:) = 0._wp
+       do k=1,nColumns
+          call quickbeam_optics(sd, cospIN%rcfg_cloudsat, nPoints, nLevels, R_UNDEF,  &
+               mr_hydro(:,k,:,1:nHydro)*1000._wp, Reff(:,k,:,1:nHydro)*1.e6_wp,&
+               Np(:,k,:,1:nHydro), cospstateIN%pfull, cospstateIN%at,          &
+               cospstateIN%qv, cospIN%z_vol_cloudsat(1:nPoints,k,:),           &
+               cospIN%kr_vol_cloudsat(1:nPoints,k,:))
+          
+          ! At each model level, what fraction of the precipitation is frozen?
+          where(mr_hydro(:,k,:,I_LSRAIN) .gt. 0 .or. mr_hydro(:,k,:,I_LSSNOW) .gt. 0 .or. &
+                mr_hydro(:,k,:,I_CVRAIN) .gt. 0 .or. mr_hydro(:,k,:,I_CVSNOW) .gt. 0 .or. &
+                mr_hydro(:,k,:,I_LSGRPL) .gt. 0)
+             fracPrecipIce(:,k,:) = (mr_hydro(:,k,:,I_LSSNOW) + mr_hydro(:,k,:,I_CVSNOW) + &
+                  mr_hydro(:,k,:,I_LSGRPL)) / &
+                  (mr_hydro(:,k,:,I_LSSNOW) + mr_hydro(:,k,:,I_CVSNOW) + mr_hydro(:,k,:,I_LSGRPL) + &
+                  mr_hydro(:,k,:,I_LSRAIN)  + mr_hydro(:,k,:,I_CVRAIN))
+          elsewhere
+             fracPrecipIce(:,k,:) = 0._wp
+          endwhere
+       enddo
+
+       ! Regrid frozen fraction to Cloudsat/Calipso statistical grid
+       allocate(fracPrecipIce_statGrid(nPoints,nColumns,Nlvgrid))
+       fracPrecipIce_statGrid(:,:,:) = 0._wp
+       call cosp_change_vertical_grid(Npoints, Ncolumns, Nlevels, cospstateIN%hgt_matrix(:,Nlevels:1:-1), &
+            cospstateIN%hgt_matrix_half(:,Nlevels:1:-1), fracPrecipIce(:,:,Nlevels:1:-1), Nlvgrid,  &
+!            vgrid_zl(Nlvgrid:1:-1),  vgrid_zu(Nlvgrid:1:-1), fracPrecipIce_statGrid)  !!! ORIGINAL
+            vgrid_zl(Nlvgrid:1:-1),  vgrid_zu(Nlvgrid:1:-1), fracPrecipIce_statGrid(:,:,Nlvgrid:1:-1)) !DEBUG fracPrecipIce_statGrid
+
+       ! Find proper layer to compute precip flags in Cloudsat/Calipso statistical grid     !PREC_BUG
+       allocate(cloudsat_preclvl_index(nPoints))                                            !PREC_BUG
+       cloudsat_preclvl_index(:) = 0._wp                                                    !PREC_BUG
+       ! Computing altitude index for precip flags calculation (2nd layer above surfelev)   !PREC_BUG
+       cloudsat_preclvl_index(:) = 39 - floor( cospstateIN%surfelev(:)/480. )               !PREC_BUG
+
+       ! For near-surface diagnostics, we only need the frozen fraction at one layer.
+       do i=1,nPoints                                                                       !PREC_BUG
+	  cospIN%fracPrecipIce(i,:) = fracPrecipIce_statGrid(i,:,cloudsat_preclvl_index(i)) !PREC_BUG
+       enddo                                                                                !PREC_BUG
+!       cospIN%fracPrecipIce(:,:) = fracPrecipIce_statGrid(:,:,cloudsat_preclvl)      !!! ORIGINAL
+!       cospIN%fracPrecipIce(:,:) = fracPrecipIce_statGrid(:,:,2)                      !!! TEST ARTEM
+       
+    endif
+   
+    !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+    ! MODIS optics
+    !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+    if (cfg%Lmodis) then
+       allocate(MODIS_cloudWater(nPoints,nColumns,nLevels),                                &
+                MODIS_cloudIce(nPoints,nColumns,nLevels),                                  &
+                MODIS_waterSize(nPoints,nColumns,nLevels),                                 &
+                MODIS_iceSize(nPoints,nColumns,nLevels),                                   &
+                MODIS_opticalThicknessLiq(nPoints,nColumns,nLevels),                       &
+                MODIS_opticalThicknessIce(nPoints,nColumns,nLevels))
+       ! Cloud water
+       call cosp_simulator_optics(nPoints,nColumns,nLevels,cospIN%frac_out,                &
+            mr_hydro(:,:,:,I_CVCLIQ),mr_hydro(:,:,:,I_LSCLIQ),MODIS_cloudWater)
+       ! Cloud ice
+       call cosp_simulator_optics(nPoints,nColumns,nLevels,cospIN%frac_out,                &
+            mr_hydro(:,:,:,I_CVCICE),mr_hydro(:,:,:,I_LSCICE),MODIS_cloudIce)  
+       ! Water droplet size
+       call cosp_simulator_optics(nPoints,nColumns,nLevels,cospIN%frac_out,                &
+            Reff(:,:,:,I_CVCLIQ),Reff(:,:,:,I_LSCLIQ),MODIS_waterSize)
+       ! Ice crystal size
+       call cosp_simulator_optics(nPoints,nColumns,nLevels,cospIN%frac_out,                &
+            Reff(:,:,:,I_CVCICE),Reff(:,:,:,I_LSCICE),MODIS_iceSize)
+       
+       ! Partition optical thickness into liquid and ice parts
+       call modis_optics_partition(nPoints, nLevels, nColumns, MODIS_cloudWater,           &
+            MODIS_cloudIce, MODIS_waterSize, MODIS_iceSize, cospIN%tau_067,                &
+            MODIS_opticalThicknessLiq, MODIS_opticalThicknessIce)
+       
+       ! Compute assymetry parameter and single scattering albedo 
+       call modis_optics(nPoints, nLevels, nColumns, MODIS_opticalThicknessLiq,            &
+            MODIS_waterSize*1.0e6_wp, MODIS_opticalThicknessIce,                           &
+            MODIS_iceSize*1.0e6_wp, cospIN%fracLiq, cospIN%asym, cospIN%ss_alb)
+       
+       ! Deallocate memory
+       deallocate(MODIS_cloudWater,MODIS_cloudIce,MODIS_WaterSize,MODIS_iceSize,           &
+            MODIS_opticalThicknessLiq,MODIS_opticalThicknessIce,mr_hydro,                  &
+            Np,Reff)
+    endif
+  end subroutine subsample_and_optics
+
+END MODULE LMDZ_COSP_SUBSAMPLE_AND_OPTICS_MOD
Index: DZ6/trunk/libf/phylmd/cospv2/math_lib.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cospv2/math_lib.F90	(revision 5267)
+++ 	(revision )
@@ -1,404 +1,0 @@
-! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-! Copyright (c) 2015, Regents of the University of Colorado
-! All rights reserved.
-!
-! Redistribution and use in source and binary forms, with or without modification, are 
-! permitted provided that the following conditions are met:
-!
-! 1. Redistributions of source code must retain the above copyright notice, this list of 
-!    conditions and the following disclaimer.
-!
-! 2. Redistributions in binary form must reproduce the above copyright notice, this list
-!    of conditions and the following disclaimer in the documentation and/or other 
-!    materials provided with the distribution.
-!
-! 3. Neither the name of the copyright holder nor the names of its contributors may be 
-!    used to endorse or promote products derived from this software without specific prior
-!    written permission.
-!
-! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY 
-! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 
-! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL 
-! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 
-! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT 
-! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 
-! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
-! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-!
-! History:
-! July 2006: John Haynes      - Initial version
-! May 2015:  Dustin Swales    - Modified for COSPv2.0
-! 
-! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 
-module math_lib
-  USE COSP_KINDS,     ONLY: wp
-  use mod_cosp_error, ONLY: errorMessage
-  implicit none
-
-contains
-  ! ##########################################################################  
-  !                           function PATH_INTEGRAL 
-  ! ##########################################################################  
-  function path_integral(f,s,i1,i2)
-    use m_mrgrnk
-    use array_lib
-    implicit none
-    ! ########################################################################
-    ! Purpose:
-    !   evalues the integral (f ds) between f(index=i1) and f(index=i2)
-    !   using the AVINT procedure
-    !
-    ! Inputs:
-    !   [f]    functional values
-    !   [s]    abscissa values
-    !   [i1]   index of lower limit
-    !   [i2]   index of upper limit
-    !
-    ! Returns:
-    !   result of path integral
-    !
-    ! Notes:
-    !   [s] may be in forward or reverse numerical order
-    !
-    ! Requires:
-    !   mrgrnk package
-    !
-    ! Created:
-    !   02/02/06  John Haynes (haynes@atmos.colostate.edu)
-    ! ########################################################################
-
-    ! INPUTS
-    real(wp),intent(in), dimension(:) :: &
-         f,  & ! Functional values
-         s     ! Abscissa values  
-    integer, intent(in) :: &
-         i1, & ! Index of lower limit
-         i2    ! Index of upper limit
-
-    ! OUTPUTS
-    real(wp) :: path_integral  
-  
-    ! Internal variables
-    real(wp) :: sumo, deltah, val
-    integer :: nelm, j
-    integer, dimension(i2-i1+1) :: idx
-    real(wp), dimension(i2-i1+1) :: f_rev, s_rev
-
-    nelm = i2-i1+1
-    if (nelm > 3) then
-       call mrgrnk(s(i1:i2),idx)
-       s_rev = s(idx)
-       f_rev = f(idx)
-       call avint(f_rev(i1:i2),s_rev(i1:i2),(i2-i1+1), &
-            s_rev(i1),s_rev(i2), val)
-       path_integral = val
-    else
-       sumo = 0._wp
-       do j=i1,i2
-          deltah = abs(s(i1+1)-s(i1))
-          sumo = sumo + f(j)*deltah
-       enddo
-       path_integral = sumo
-    endif
-    
-    return
-  end function path_integral
-  
-  ! ##########################################################################
-  !                            subroutine AVINT
-  ! ##########################################################################
-  subroutine avint ( ftab, xtab, ntab, a_in, b_in, result )
-    implicit none
-    ! ########################################################################  
-    ! Purpose:
-    !   estimate the integral of unevenly spaced data
-    !
-    ! Inputs:
-    !   [ftab]     functional values
-    !   [xtab]     abscissa values
-    !   [ntab]     number of elements of [ftab] and [xtab]
-    !   [a]        lower limit of integration
-    !   [b]        upper limit of integration
-    !
-    ! Outputs:
-    !   [result]   approximate value of integral
-    !
-    ! Reference:
-    !   From SLATEC libraries, in public domain
-    !
-    !***********************************************************************
-    !
-    !  AVINT estimates the integral of unevenly spaced data.
-    !
-    !  Discussion:
-    !
-    !    The method uses overlapping parabolas and smoothing.
-    !
-    !  Modified:
-    !
-    !    30 October 2000
-    !    4 January 2008, A. Bodas-Salcedo. Error control for XTAB taken out of
-    !                    loop to allow vectorization.
-    !
-    !  Reference:
-    !
-    !    Philip Davis and Philip Rabinowitz,
-    !    Methods of Numerical Integration,
-    !    Blaisdell Publishing, 1967.
-    !
-    !    P E Hennion,
-    !    Algorithm 77,
-    !    Interpolation, Differentiation and Integration,
-    !    Communications of the Association for Computing Machinery,
-    !    Volume 5, page 96, 1962.
-    !
-    !  Parameters:
-    !
-    !    Input, real ( kind = 8 ) FTAB(NTAB), the function values,
-    !    FTAB(I) = F(XTAB(I)).
-    !
-    !    Input, real ( kind = 8 ) XTAB(NTAB), the abscissas at which the
-    !    function values are given.  The XTAB's must be distinct
-    !    and in ascending order.
-    !
-    !    Input, integer NTAB, the number of entries in FTAB and
-    !    XTAB.  NTAB must be at least 3.
-    !
-    !    Input, real ( kind = 8 ) A, the lower limit of integration.  A should
-    !    be, but need not be, near one endpoint of the interval
-    !    (X(1), X(NTAB)).
-    !
-    !    Input, real ( kind = 8 ) B, the upper limit of integration.  B should
-    !    be, but need not be, near one endpoint of the interval
-    !    (X(1), X(NTAB)).
-    !
-    !    Output, real ( kind = 8 ) RESULT, the approximate value of the integral.
-    ! ##########################################################################  
-
-    ! INPUTS
-    integer,intent(in) :: &
-         ntab    ! Number of elements of [ftab] and [xtab]
-    real(wp),intent(in) :: &
-         a_in, & ! Lower limit of integration
-         b_in    ! Upper limit of integration
-    real(wp),intent(in),dimension(ntab) :: &
-         ftab, & ! Functional values
-         xtab    ! Abscissa value
-    
-    ! OUTPUTS
-    real(wp),intent(out) :: result  ! Approximate value of integral
-
-    ! Internal varaibles
-    real(wp) :: a, atemp, b, btemp,ca,cb,cc,ctemp,sum1,syl,term1,term2,term3,x1,x2,x3
-    integer  :: i,ihi,ilo,ind
-    logical  :: lerror
-  
-    lerror = .false.
-    a = a_in
-    b = b_in  
-  
-    if ( ntab < 3 ) then
-       call errorMessage('FATAL ERROR(optics/math_lib.f90:AVINT): Ntab is less than 3.')
-       return
-    end if
-    
-    do i = 2, ntab
-       if ( xtab(i) <= xtab(i-1) ) then
-          lerror = .true.
-          exit
-       end if
-    end do
-    
-    if (lerror) then
-       call errorMessage('FATAL ERROR(optics/math_lib.f90:AVINT): Xtab(i) is not greater than Xtab(i-1).')
-       return
-    end if
-    
-!ds    result = 0.0D+00
-    result = 0._wp
-    
-    if ( a == b ) then
-       call errorMessage('WARNING(optics/math_lib.f90:AVINT): A=B => integral=0')
-       return
-    end if
-    
-    !  If B < A, temporarily switch A and B, and store sign.
-    if ( b < a ) then
-       syl = b
-       b = a
-       a = syl
-       ind = -1
-    else
-       syl = a
-       ind = 1
-    end if
-    
-    !  Bracket A and B between XTAB(ILO) and XTAB(IHI).
-    ilo = 1
-    ihi = ntab
-    
-    do i = 1, ntab
-       if ( a <= xtab(i) ) then
-          exit
-       end if
-       ilo = ilo + 1
-    end do
-    
-    ilo = max ( 2, ilo )
-    ilo = min ( ilo, ntab - 1 )
-    
-    do i = 1, ntab
-       if ( xtab(i) <= b ) then
-          exit
-       end if
-       ihi = ihi - 1
-    end do
-    
-    ihi = min ( ihi, ntab - 1 )
-    ihi = max ( ilo, ihi - 1 )
-    
-    !  Carry out approximate integration from XTAB(ILO) to XTAB(IHI).
-    sum1 = 0._wp
-!ds    sum1 = 0.0D+00
-    
-    do i = ilo, ihi
-       
-       x1 = xtab(i-1)
-       x2 = xtab(i)
-       x3 = xtab(i+1)
-       
-       term1 = ftab(i-1) / ( ( x1 - x2 ) * ( x1 - x3 ) )
-       term2 = ftab(i)   / ( ( x2 - x1 ) * ( x2 - x3 ) )
-       term3 = ftab(i+1) / ( ( x3 - x1 ) * ( x3 - x2 ) )
-       
-       atemp = term1 + term2 + term3
-       
-       btemp = - ( x2 + x3 ) * term1 &
-            - ( x1 + x3 ) * term2 &
-            - ( x1 + x2 ) * term3
-       
-       ctemp = x2 * x3 * term1 + x1 * x3 * term2 + x1 * x2 * term3
-       
-       if ( i <= ilo ) then
-          ca = atemp
-          cb = btemp
-          cc = ctemp
-       else
-          ca = 0.5_wp * ( atemp + ca )
-          cb = 0.5_wp * ( btemp + cb )
-          cc = 0.5_wp * ( ctemp + cc )
-!ds          ca = 0.5D+00 * ( atemp + ca )
-!ds          cb = 0.5D+00 * ( btemp + cb )
-!ds          cc = 0.5D+00 * ( ctemp + cc )
-       end if
-       
-       sum1 = sum1 + ca * ( x2**3 - syl**3 ) / 3._wp &
-            + cb * 0.5_wp * ( x2**2 - syl**2 ) + cc * ( x2 - syl )
-!ds       sum1 = sum1 + ca * ( x2**3 - syl**3 ) / 3.0D+00 &
-!ds            + cb * 0.5D+00 * ( x2**2 - syl**2 ) + cc * ( x2 - syl )
-       
-       ca = atemp
-       cb = btemp
-       cc = ctemp
-       
-       syl = x2
-       
-    end do
-
-    result = sum1 + ca * ( b**3 - syl**3 ) / 3._wp &
-         + cb * 0.5_wp * ( b**2 - syl**2 ) + cc * ( b - syl )
-!ds    result = sum1 + ca * ( b**3 - syl**3 ) / 3.0D+00 &
-!ds         + cb * 0.5D+00 * ( b**2 - syl**2 ) + cc * ( b - syl )
-
-    !  Restore original values of A and B, reverse sign of integral
-    !  because of earlier switch.
-    if ( ind /= 1 ) then
-       ind = 1
-       syl = b
-       b = a
-       a = syl
-       result = -result
-    end if
-    
-    return
-  end subroutine avint
-  ! ######################################################################################
-  ! SUBROUTINE gamma
-  ! Purpose:
-  !   Returns the gamma function
-  !
-  ! Input:
-  !   [x]   value to compute gamma function of
-  !
-  ! Returns:
-  !   gamma(x)
-  !
-  ! Coded:
-  !   02/02/06  John Haynes (haynes@atmos.colostate.edu)
-  !   (original code of unknown origin)
-  ! ######################################################################################
-  function gamma(x)
-    ! Inputs 
-    real(wp), intent(in) :: x
-
-    ! Outputs
-    real(wp) :: gamma
-    
-    ! Local variables
-    real(wp) :: pi,ga,z,r,gr
-    integer  :: k,m1,m  
-    
-    ! Parameters
-    real(wp),dimension(26),parameter :: &
-         g = (/1.0,0.5772156649015329, -0.6558780715202538, -0.420026350340952e-1,     &
-               0.1665386113822915,-0.421977345555443e-1,-0.96219715278770e-2,              &
-               0.72189432466630e-2,-0.11651675918591e-2, -0.2152416741149e-3,                &
-               0.1280502823882e-3, -0.201348547807e-4, -0.12504934821e-5, 0.11330272320e-5,  &
-               -0.2056338417e-6, 0.61160950e-8,0.50020075e-8, -0.11812746e-8, 0.1043427e-9,   &
-               0.77823e-11, -0.36968e-11, 0.51e-12, -0.206e-13, -0.54e-14, 0.14e-14, 0.1e-15/)  
-!ds    real(wp),dimension(26),parameter :: &
-!ds         g = (/1.0d0,0.5772156649015329d0, -0.6558780715202538d0, -0.420026350340952d-1,     &
-!ds               0.1665386113822915d0,-0.421977345555443d-1,-0.96219715278770d-2,              &
-!ds               0.72189432466630d-2,-0.11651675918591d-2, -0.2152416741149d-3,                &
-!ds               0.1280502823882d-3, -0.201348547807d-4, -0.12504934821d-5, 0.11330272320d-5,  &
-!ds               -0.2056338417d-6, 0.61160950d-8,0.50020075d-8, -0.11812746d-8, 0.1043427d-9,   &
-!ds               0.77823d-11, -0.36968d-11, 0.51d-12, -0.206d-13, -0.54d-14, 0.14d-14, 0.1d-15/)  
-    
-    pi = acos(-1._wp)    
-    if (x ==int(x)) then
-       if (x > 0.0) then
-          ga=1._wp
-          m1=x-1
-          do k=2,m1
-             ga=ga*k
-          enddo
-       else
-          ga=1._wp+300
-       endif
-    else
-       if (abs(x) > 1.0) then
-          z=abs(x)
-          m=int(z)
-          r=1._wp
-          do k=1,m
-             r=r*(z-k)
-          enddo
-          z=z-m
-       else
-          z=x
-       endif
-       gr=g(26)
-       do k=25,1,-1
-          gr=gr*z+g(k)
-       enddo
-       ga=1._wp/(gr*z)
-       if (abs(x) > 1.0) then
-          ga=ga*r
-          if (x < 0.0) ga=-pi/(x*ga*sin(pi*x))
-       endif
-    endif
-    gamma = ga
-    return
-  end function gamma
-end module math_lib
Index: /LMDZ6/trunk/libf/phylmd/cospv2/math_lib.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cospv2/math_lib.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/cospv2/math_lib.f90	(revision 5268)
@@ -0,0 +1,404 @@
+! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+! Copyright (c) 2015, Regents of the University of Colorado
+! All rights reserved.
+!
+! Redistribution and use in source and binary forms, with or without modification, are 
+! permitted provided that the following conditions are met:
+!
+! 1. Redistributions of source code must retain the above copyright notice, this list of 
+!    conditions and the following disclaimer.
+!
+! 2. Redistributions in binary form must reproduce the above copyright notice, this list
+!    of conditions and the following disclaimer in the documentation and/or other 
+!    materials provided with the distribution.
+!
+! 3. Neither the name of the copyright holder nor the names of its contributors may be 
+!    used to endorse or promote products derived from this software without specific prior
+!    written permission.
+!
+! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY 
+! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 
+! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL 
+! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 
+! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT 
+! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 
+! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+!
+! History:
+! July 2006: John Haynes      - Initial version
+! May 2015:  Dustin Swales    - Modified for COSPv2.0
+! 
+! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 
+module math_lib
+  USE COSP_KINDS,     ONLY: wp
+  use mod_cosp_error, ONLY: errorMessage
+  implicit none
+
+contains
+  ! ##########################################################################  
+  !                           function PATH_INTEGRAL 
+  ! ##########################################################################  
+  function path_integral(f,s,i1,i2)
+    use m_mrgrnk
+    use array_lib
+    implicit none
+    ! ########################################################################
+    ! Purpose:
+    !   evalues the integral (f ds) between f(index=i1) and f(index=i2)
+    !   using the AVINT procedure
+    !
+    ! Inputs:
+    !   [f]    functional values
+    !   [s]    abscissa values
+    !   [i1]   index of lower limit
+    !   [i2]   index of upper limit
+    !
+    ! Returns:
+    !   result of path integral
+    !
+    ! Notes:
+    !   [s] may be in forward or reverse numerical order
+    !
+    ! Requires:
+    !   mrgrnk package
+    !
+    ! Created:
+    !   02/02/06  John Haynes (haynes@atmos.colostate.edu)
+    ! ########################################################################
+
+    ! INPUTS
+    real(wp),intent(in), dimension(:) :: &
+         f,  & ! Functional values
+         s     ! Abscissa values  
+    integer, intent(in) :: &
+         i1, & ! Index of lower limit
+         i2    ! Index of upper limit
+
+    ! OUTPUTS
+    real(wp) :: path_integral  
+  
+    ! Internal variables
+    real(wp) :: sumo, deltah, val
+    integer :: nelm, j
+    integer, dimension(i2-i1+1) :: idx
+    real(wp), dimension(i2-i1+1) :: f_rev, s_rev
+
+    nelm = i2-i1+1
+    if (nelm > 3) then
+       call mrgrnk(s(i1:i2),idx)
+       s_rev = s(idx)
+       f_rev = f(idx)
+       call avint(f_rev(i1:i2),s_rev(i1:i2),(i2-i1+1), &
+            s_rev(i1),s_rev(i2), val)
+       path_integral = val
+    else
+       sumo = 0._wp
+       do j=i1,i2
+          deltah = abs(s(i1+1)-s(i1))
+          sumo = sumo + f(j)*deltah
+       enddo
+       path_integral = sumo
+    endif
+    
+    return
+  end function path_integral
+  
+  ! ##########################################################################
+  !                            subroutine AVINT
+  ! ##########################################################################
+  subroutine avint ( ftab, xtab, ntab, a_in, b_in, result )
+    implicit none
+    ! ########################################################################  
+    ! Purpose:
+    !   estimate the integral of unevenly spaced data
+    !
+    ! Inputs:
+    !   [ftab]     functional values
+    !   [xtab]     abscissa values
+    !   [ntab]     number of elements of [ftab] and [xtab]
+    !   [a]        lower limit of integration
+    !   [b]        upper limit of integration
+    !
+    ! Outputs:
+    !   [result]   approximate value of integral
+    !
+    ! Reference:
+    !   From SLATEC libraries, in public domain
+    !
+    !***********************************************************************
+    !
+    !  AVINT estimates the integral of unevenly spaced data.
+    !
+    !  Discussion:
+    !
+    !    The method uses overlapping parabolas and smoothing.
+    !
+    !  Modified:
+    !
+    !    30 October 2000
+    !    4 January 2008, A. Bodas-Salcedo. Error control for XTAB taken out of
+    !                    loop to allow vectorization.
+    !
+    !  Reference:
+    !
+    !    Philip Davis and Philip Rabinowitz,
+    !    Methods of Numerical Integration,
+    !    Blaisdell Publishing, 1967.
+    !
+    !    P E Hennion,
+    !    Algorithm 77,
+    !    Interpolation, Differentiation and Integration,
+    !    Communications of the Association for Computing Machinery,
+    !    Volume 5, page 96, 1962.
+    !
+    !  Parameters:
+    !
+    !    Input, real ( kind = 8 ) FTAB(NTAB), the function values,
+    !    FTAB(I) = F(XTAB(I)).
+    !
+    !    Input, real ( kind = 8 ) XTAB(NTAB), the abscissas at which the
+    !    function values are given.  The XTAB's must be distinct
+    !    and in ascending order.
+    !
+    !    Input, integer NTAB, the number of entries in FTAB and
+    !    XTAB.  NTAB must be at least 3.
+    !
+    !    Input, real ( kind = 8 ) A, the lower limit of integration.  A should
+    !    be, but need not be, near one endpoint of the interval
+    !    (X(1), X(NTAB)).
+    !
+    !    Input, real ( kind = 8 ) B, the upper limit of integration.  B should
+    !    be, but need not be, near one endpoint of the interval
+    !    (X(1), X(NTAB)).
+    !
+    !    Output, real ( kind = 8 ) RESULT, the approximate value of the integral.
+    ! ##########################################################################  
+
+    ! INPUTS
+    integer,intent(in) :: &
+         ntab    ! Number of elements of [ftab] and [xtab]
+    real(wp),intent(in) :: &
+         a_in, & ! Lower limit of integration
+         b_in    ! Upper limit of integration
+    real(wp),intent(in),dimension(ntab) :: &
+         ftab, & ! Functional values
+         xtab    ! Abscissa value
+    
+    ! OUTPUTS
+    real(wp),intent(out) :: result  ! Approximate value of integral
+
+    ! Internal varaibles
+    real(wp) :: a, atemp, b, btemp,ca,cb,cc,ctemp,sum1,syl,term1,term2,term3,x1,x2,x3
+    integer  :: i,ihi,ilo,ind
+    logical  :: lerror
+  
+    lerror = .false.
+    a = a_in
+    b = b_in  
+  
+    if ( ntab < 3 ) then
+       call errorMessage('FATAL ERROR(optics/math_lib.f90:AVINT): Ntab is less than 3.')
+       return
+    end if
+    
+    do i = 2, ntab
+       if ( xtab(i) <= xtab(i-1) ) then
+          lerror = .true.
+          exit
+       end if
+    end do
+    
+    if (lerror) then
+       call errorMessage('FATAL ERROR(optics/math_lib.f90:AVINT): Xtab(i) is not greater than Xtab(i-1).')
+       return
+    end if
+    
+!ds    result = 0.0D+00
+    result = 0._wp
+    
+    if ( a == b ) then
+       call errorMessage('WARNING(optics/math_lib.f90:AVINT): A=B => integral=0')
+       return
+    end if
+    
+    !  If B < A, temporarily switch A and B, and store sign.
+    if ( b < a ) then
+       syl = b
+       b = a
+       a = syl
+       ind = -1
+    else
+       syl = a
+       ind = 1
+    end if
+    
+    !  Bracket A and B between XTAB(ILO) and XTAB(IHI).
+    ilo = 1
+    ihi = ntab
+    
+    do i = 1, ntab
+       if ( a <= xtab(i) ) then
+          exit
+       end if
+       ilo = ilo + 1
+    end do
+    
+    ilo = max ( 2, ilo )
+    ilo = min ( ilo, ntab - 1 )
+    
+    do i = 1, ntab
+       if ( xtab(i) <= b ) then
+          exit
+       end if
+       ihi = ihi - 1
+    end do
+    
+    ihi = min ( ihi, ntab - 1 )
+    ihi = max ( ilo, ihi - 1 )
+    
+    !  Carry out approximate integration from XTAB(ILO) to XTAB(IHI).
+    sum1 = 0._wp
+!ds    sum1 = 0.0D+00
+    
+    do i = ilo, ihi
+       
+       x1 = xtab(i-1)
+       x2 = xtab(i)
+       x3 = xtab(i+1)
+       
+       term1 = ftab(i-1) / ( ( x1 - x2 ) * ( x1 - x3 ) )
+       term2 = ftab(i)   / ( ( x2 - x1 ) * ( x2 - x3 ) )
+       term3 = ftab(i+1) / ( ( x3 - x1 ) * ( x3 - x2 ) )
+       
+       atemp = term1 + term2 + term3
+       
+       btemp = - ( x2 + x3 ) * term1 &
+            - ( x1 + x3 ) * term2 &
+            - ( x1 + x2 ) * term3
+       
+       ctemp = x2 * x3 * term1 + x1 * x3 * term2 + x1 * x2 * term3
+       
+       if ( i <= ilo ) then
+          ca = atemp
+          cb = btemp
+          cc = ctemp
+       else
+          ca = 0.5_wp * ( atemp + ca )
+          cb = 0.5_wp * ( btemp + cb )
+          cc = 0.5_wp * ( ctemp + cc )
+!ds          ca = 0.5D+00 * ( atemp + ca )
+!ds          cb = 0.5D+00 * ( btemp + cb )
+!ds          cc = 0.5D+00 * ( ctemp + cc )
+       end if
+       
+       sum1 = sum1 + ca * ( x2**3 - syl**3 ) / 3._wp &
+            + cb * 0.5_wp * ( x2**2 - syl**2 ) + cc * ( x2 - syl )
+!ds       sum1 = sum1 + ca * ( x2**3 - syl**3 ) / 3.0D+00 &
+!ds            + cb * 0.5D+00 * ( x2**2 - syl**2 ) + cc * ( x2 - syl )
+       
+       ca = atemp
+       cb = btemp
+       cc = ctemp
+       
+       syl = x2
+       
+    end do
+
+    result = sum1 + ca * ( b**3 - syl**3 ) / 3._wp &
+         + cb * 0.5_wp * ( b**2 - syl**2 ) + cc * ( b - syl )
+!ds    result = sum1 + ca * ( b**3 - syl**3 ) / 3.0D+00 &
+!ds         + cb * 0.5D+00 * ( b**2 - syl**2 ) + cc * ( b - syl )
+
+    !  Restore original values of A and B, reverse sign of integral
+    !  because of earlier switch.
+    if ( ind /= 1 ) then
+       ind = 1
+       syl = b
+       b = a
+       a = syl
+       result = -result
+    end if
+    
+    return
+  end subroutine avint
+  ! ######################################################################################
+  ! SUBROUTINE gamma
+  ! Purpose:
+  !   Returns the gamma function
+  !
+  ! Input:
+  !   [x]   value to compute gamma function of
+  !
+  ! Returns:
+  !   gamma(x)
+  !
+  ! Coded:
+  !   02/02/06  John Haynes (haynes@atmos.colostate.edu)
+  !   (original code of unknown origin)
+  ! ######################################################################################
+  function gamma(x)
+    ! Inputs 
+    real(wp), intent(in) :: x
+
+    ! Outputs
+    real(wp) :: gamma
+    
+    ! Local variables
+    real(wp) :: pi,ga,z,r,gr
+    integer  :: k,m1,m  
+    
+    ! Parameters
+    real(wp),dimension(26),parameter :: &
+         g = (/1.0,0.5772156649015329, -0.6558780715202538, -0.420026350340952e-1,     &
+               0.1665386113822915,-0.421977345555443e-1,-0.96219715278770e-2,              &
+               0.72189432466630e-2,-0.11651675918591e-2, -0.2152416741149e-3,                &
+               0.1280502823882e-3, -0.201348547807e-4, -0.12504934821e-5, 0.11330272320e-5,  &
+               -0.2056338417e-6, 0.61160950e-8,0.50020075e-8, -0.11812746e-8, 0.1043427e-9,   &
+               0.77823e-11, -0.36968e-11, 0.51e-12, -0.206e-13, -0.54e-14, 0.14e-14, 0.1e-15/)  
+!ds    real(wp),dimension(26),parameter :: &
+!ds         g = (/1.0d0,0.5772156649015329d0, -0.6558780715202538d0, -0.420026350340952d-1,     &
+!ds               0.1665386113822915d0,-0.421977345555443d-1,-0.96219715278770d-2,              &
+!ds               0.72189432466630d-2,-0.11651675918591d-2, -0.2152416741149d-3,                &
+!ds               0.1280502823882d-3, -0.201348547807d-4, -0.12504934821d-5, 0.11330272320d-5,  &
+!ds               -0.2056338417d-6, 0.61160950d-8,0.50020075d-8, -0.11812746d-8, 0.1043427d-9,   &
+!ds               0.77823d-11, -0.36968d-11, 0.51d-12, -0.206d-13, -0.54d-14, 0.14d-14, 0.1d-15/)  
+    
+    pi = acos(-1._wp)    
+    if (x ==int(x)) then
+       if (x > 0.0) then
+          ga=1._wp
+          m1=x-1
+          do k=2,m1
+             ga=ga*k
+          enddo
+       else
+          ga=1._wp+300
+       endif
+    else
+       if (abs(x) > 1.0) then
+          z=abs(x)
+          m=int(z)
+          r=1._wp
+          do k=1,m
+             r=r*(z-k)
+          enddo
+          z=z-m
+       else
+          z=x
+       endif
+       gr=g(26)
+       do k=25,1,-1
+          gr=gr*z+g(k)
+       enddo
+       ga=1._wp/(gr*z)
+       if (abs(x) > 1.0) then
+          ga=ga*r
+          if (x < 0.0) ga=-pi/(x*ga*sin(pi*x))
+       endif
+    endif
+    gamma = ga
+    return
+  end function gamma
+end module math_lib
Index: DZ6/trunk/libf/phylmd/cospv2/mo_rng.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cospv2/mo_rng.F90	(revision 5267)
+++ 	(revision )
@@ -1,138 +1,0 @@
-! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-! Copyright (c) 2015, Regents of the University of Colorado
-! All rights reserved.
-!
-! Redistribution and use in source and binary forms, with or without modification, are 
-! permitted provided that the following conditions are met:
-!
-! 1. Redistributions of source code must retain the above copyright notice, this list of 
-!    conditions and the following disclaimer.
-!
-! 2. Redistributions in binary form must reproduce the above copyright notice, this list
-!    of conditions and the following disclaimer in the documentation and/or other 
-!    materials provided with the distribution.
-!
-! 3. Neither the name of the copyright holder nor the names of its contributors may be 
-!    used to endorse or promote products derived from this software without specific prior
-!    written permission.
-!
-! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY 
-! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 
-! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL 
-! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 
-! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT 
-! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 
-! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
-! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-!
-! History:
-! May 2015- D. Swales - Original version
-! 
-! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-MODULE mod_rng
-  USE cosp_kinds, ONLY: dp, sp, wp 
-  IMPLICIT NONE 
-
-  INTEGER, parameter :: ki9    = selected_int_kind(R=9)
-  integer :: testInt
-  
-  TYPE rng_state
-     INTEGER(ki9) :: seed ! 32 bit integer
-  END TYPE rng_state
-  
-  INTERFACE init_rng
-     MODULE PROCEDURE init_rng_1, init_rng_n
-  END INTERFACE init_rng
-  
-  INTERFACE get_rng
-     MODULE PROCEDURE get_rng_1, get_rng_n, get_rng_v
-  END INTERFACE get_rng
-  
-CONTAINS 
-  
-  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-  ! Set single seed
-  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-  SUBROUTINE init_rng_1(s, seed_in)
-    TYPE(rng_state), INTENT(INOUT) :: s
-    INTEGER,         INTENT(IN   ) :: seed_in
-    s%seed = seed_in     
-  END SUBROUTINE init_rng_1
-  
-  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-  ! Set vector of seeds
-  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-  SUBROUTINE init_rng_n(s, seed_in)
-    TYPE(rng_state), DIMENSION(:), INTENT(INOUT) :: s
-    INTEGER,         DIMENSION(:), INTENT(IN   ) :: seed_in
-    
-    INTEGER :: i 
-    DO i = 1, SIZE(seed_in)
-       s(i)%seed = seed_in(i) 
-    END DO
-  END SUBROUTINE init_rng_n
-  
-  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-  ! Create single random number from seed
-  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-  FUNCTION get_rng_1(s)  
-    TYPE(rng_state), INTENT(INOUT) :: s
-    REAL(WP)                       :: get_rng_1
-    REAL(SP)                       :: r
-
-    ! Return the next random numbers     
-    ! Marsaglia CONG algorithm
-    s%seed=69069*s%seed+1234567
-    ! mod 32 bit overflow
-    s%seed=mod(s%seed,2_ki9**30_ki9)   
-    r = s%seed*0.931322574615479E-09
-
-    ! convert to range 0-1 (32 bit only)
-    ! DJS2016: What is being done here is an intentional integer overflow and a test to
-    !          see if this occured. Some compilers check for integer overflows during
-    !          compilation (ie. gfortan), while others do not (ie. pgi and ifort). When
-    !          using gfortran, you cannot use the overflow and test for overflow method,
-    !          so we use sizeof(someInt) to determine wheter it is on 32 bit.
-    !if ( i2_16*i2_16 .le. huge32 ) then
-    if (digits(testInt) .le. 31) then
-    !if (sizeof(testInt) .eq. 4) then
-       r=r+1
-       r=r-int(r)
-    endif
-    get_rng_1 = REAL(r, KIND = WP) 
-    
-  END FUNCTION get_rng_1
-  
-  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-  ! Create single random number N times
-  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-  FUNCTION get_rng_n(s, n) RESULT (r) 
-    integer,intent(inout) :: n
-    TYPE(rng_state),INTENT(INOUT) :: s
-    ! Return the next N random numbers 
-    REAL(WP), DIMENSION (n)        :: r
-    
-    INTEGER :: i 
-    
-    DO i = 1, N
-       r(i) = get_rng_1(s)
-    END DO
-  END FUNCTION get_rng_n
-  
-  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-  ! Create a vector of random numbers from a vector of input seeds
-  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-  FUNCTION get_rng_v(s) RESULT (r) 
-    ! Return the next N random numbers 
-    TYPE(rng_state), DIMENSION(:), INTENT(INOUT) :: s
-    REAL(WP),        DIMENSION (SIZE(S))         :: r
-    
-    INTEGER :: i
-    
-    DO i = 1, size(s)
-       r(i) = get_rng_1(s(i))
-    END DO
-  END FUNCTION get_rng_v
-  
-END MODULE mod_rng
Index: /LMDZ6/trunk/libf/phylmd/cospv2/mo_rng.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cospv2/mo_rng.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/cospv2/mo_rng.f90	(revision 5268)
@@ -0,0 +1,138 @@
+! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+! Copyright (c) 2015, Regents of the University of Colorado
+! All rights reserved.
+!
+! Redistribution and use in source and binary forms, with or without modification, are 
+! permitted provided that the following conditions are met:
+!
+! 1. Redistributions of source code must retain the above copyright notice, this list of 
+!    conditions and the following disclaimer.
+!
+! 2. Redistributions in binary form must reproduce the above copyright notice, this list
+!    of conditions and the following disclaimer in the documentation and/or other 
+!    materials provided with the distribution.
+!
+! 3. Neither the name of the copyright holder nor the names of its contributors may be 
+!    used to endorse or promote products derived from this software without specific prior
+!    written permission.
+!
+! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY 
+! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 
+! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL 
+! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 
+! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT 
+! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 
+! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+!
+! History:
+! May 2015- D. Swales - Original version
+! 
+! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+MODULE mod_rng
+  USE cosp_kinds, ONLY: dp, sp, wp 
+  IMPLICIT NONE 
+
+  INTEGER, parameter :: ki9    = selected_int_kind(R=9)
+  integer :: testInt
+  
+  TYPE rng_state
+     INTEGER(ki9) :: seed ! 32 bit integer
+  END TYPE rng_state
+  
+  INTERFACE init_rng
+     MODULE PROCEDURE init_rng_1, init_rng_n
+  END INTERFACE init_rng
+  
+  INTERFACE get_rng
+     MODULE PROCEDURE get_rng_1, get_rng_n, get_rng_v
+  END INTERFACE get_rng
+  
+CONTAINS 
+  
+  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  ! Set single seed
+  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  SUBROUTINE init_rng_1(s, seed_in)
+    TYPE(rng_state), INTENT(INOUT) :: s
+    INTEGER,         INTENT(IN   ) :: seed_in
+    s%seed = seed_in     
+  END SUBROUTINE init_rng_1
+  
+  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  ! Set vector of seeds
+  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  SUBROUTINE init_rng_n(s, seed_in)
+    TYPE(rng_state), DIMENSION(:), INTENT(INOUT) :: s
+    INTEGER,         DIMENSION(:), INTENT(IN   ) :: seed_in
+    
+    INTEGER :: i 
+    DO i = 1, SIZE(seed_in)
+       s(i)%seed = seed_in(i) 
+    END DO
+  END SUBROUTINE init_rng_n
+  
+  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  ! Create single random number from seed
+  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  FUNCTION get_rng_1(s)  
+    TYPE(rng_state), INTENT(INOUT) :: s
+    REAL(WP)                       :: get_rng_1
+    REAL(SP)                       :: r
+
+    ! Return the next random numbers     
+    ! Marsaglia CONG algorithm
+    s%seed=69069*s%seed+1234567
+    ! mod 32 bit overflow
+    s%seed=mod(s%seed,2_ki9**30_ki9)   
+    r = s%seed*0.931322574615479E-09
+
+    ! convert to range 0-1 (32 bit only)
+    ! DJS2016: What is being done here is an intentional integer overflow and a test to
+    !          see if this occured. Some compilers check for integer overflows during
+    !          compilation (ie. gfortan), while others do not (ie. pgi and ifort). When
+    !          using gfortran, you cannot use the overflow and test for overflow method,
+    !          so we use sizeof(someInt) to determine wheter it is on 32 bit.
+    !if ( i2_16*i2_16 .le. huge32 ) then
+    if (digits(testInt) .le. 31) then
+    !if (sizeof(testInt) .eq. 4) then
+       r=r+1
+       r=r-int(r)
+    endif
+    get_rng_1 = REAL(r, KIND = WP) 
+    
+  END FUNCTION get_rng_1
+  
+  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  ! Create single random number N times
+  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  FUNCTION get_rng_n(s, n) RESULT (r) 
+    integer,intent(inout) :: n
+    TYPE(rng_state),INTENT(INOUT) :: s
+    ! Return the next N random numbers 
+    REAL(WP), DIMENSION (n)        :: r
+    
+    INTEGER :: i 
+    
+    DO i = 1, N
+       r(i) = get_rng_1(s)
+    END DO
+  END FUNCTION get_rng_n
+  
+  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  ! Create a vector of random numbers from a vector of input seeds
+  !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+  FUNCTION get_rng_v(s) RESULT (r) 
+    ! Return the next N random numbers 
+    TYPE(rng_state), DIMENSION(:), INTENT(INOUT) :: s
+    REAL(WP),        DIMENSION (SIZE(S))         :: r
+    
+    INTEGER :: i
+    
+    DO i = 1, size(s)
+       r(i) = get_rng_1(s(i))
+    END DO
+  END FUNCTION get_rng_v
+  
+END MODULE mod_rng
Index: DZ6/trunk/libf/phylmd/cospv2/modis_simulator.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cospv2/modis_simulator.F90	(revision 5267)
+++ 	(revision )
@@ -1,906 +1,0 @@
-! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-! Copyright (c) 2015, Regents of the University of Colorado
-! All rights reserved.
-!
-! Redistribution and use in source and binary forms, with or without modification, are 
-! permitted provided that the following conditions are met:
-!
-! 1. Redistributions of source code must retain the above copyright notice, this list of 
-!    conditions and the following disclaimer.
-!
-! 2. Redistributions in binary form must reproduce the above copyright notice, this list
-!    of conditions and the following disclaimer in the documentation and/or other 
-!    materials provided with the distribution.
-!
-! 3. Neither the name of the copyright holder nor the names of its contributors may be 
-!    used to endorse or promote products derived from this software without specific prior
-!    written permission.
-!
-! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY 
-! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 
-! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL 
-! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 
-! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT 
-! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 
-! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
-! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-!
-! History
-! May 2009:      Robert Pincus - Initial version
-! June 2009:     Steve Platnick and Robert Pincus - Simple radiative transfer for size 
-!                retrievals
-! August 2009:   Robert Pincus - Consistency and bug fixes suggested by Rick Hemler (GFDL) 
-! November 2009: Robert Pincus - Bux fixes and speed-ups after experience with Rick Hemler 
-!                using AM2 (GFDL) 
-! January 2010:  Robert Pincus - Added high, middle, low cloud fractions
-! May 2015:      Dustin Swales - Modified for COSPv2.0
-! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-!
-! Notes on using the MODIS simulator: 
-!  *) You may provide either layer-by-layer values of optical thickness at 0.67 and 2.1
-!     microns, or optical thickness at 0.67 microns and ice- and liquid-water contents 
-!     (in consistent units of your choosing)
-!  *) Required input also includes the optical thickness and cloud top pressure 
-!     derived from the ISCCP simulator run with parameter top_height = 1. 
-!  *) Cloud particle sizes are specified as radii, measured in meters, though within the 
-!     module we use units of microns. Where particle sizes are outside the bounds used in 
-!     the MODIS retrieval libraries (parameters re_water_min, re_ice_min, etc.) the 
-!     simulator returns missing values (re_fill)
-!
-! When error conditions are encountered this code calls the function complain_and_die, 
-! supplied at the bottom of this module. Users probably want to replace this with 
-! something more graceful. 
-!
-module mod_modis_sim
-  USE MOD_COSP_CONFIG, only: R_UNDEF,modis_histTau,modis_histPres,numMODISTauBins,       &
-                             numMODISPresBins,numMODISReffIceBins,numMODISReffLiqBins,   &
-                             modis_histReffIce,modis_histReffLiq
-  USE COSP_KINDS,      ONLY: wp
-  use MOD_COSP_STATS,  ONLY: hist2D
-
-  implicit none
-  ! ##########################################################################
-  ! Retrieval parameters
-   integer, parameter :: &
-        num_trial_res = 15              ! Increase to make the linear pseudo-retrieval of size more accurate
-   
-   real(wp) :: &
-       min_OpticalThickness,          & ! Minimum detectable optical thickness
-       CO2Slicing_PressureLimit,      & ! Cloud with higher pressures use thermal methods, units Pa
-       CO2Slicing_TauLimit,           & ! How deep into the cloud does CO2 slicing see? 
-       phase_TauLimit,                & ! How deep into the cloud does the phase detection see?
-       size_TauLimit,                 & ! Depth of the re retreivals
-       phaseDiscrimination_Threshold, & ! What fraction of total extincton needs to be in a single
-                                        ! category to make phase discrim. work? 
-       re_fill,                       & !
-       re_water_min,                  & ! Minimum effective radius (liquid)
-       re_water_max,                  & ! Maximum effective radius (liquid)
-       re_ice_min,                    & ! Minimum effective radius (ice)
-       re_ice_max,                    & ! Minimum effective radius (ice)
-       highCloudPressureLimit,        & ! High cloud pressure limit (Pa)
-       lowCloudPressureLimit            ! Low cloud pressure limit (Pa)
-  integer :: &
-       phaseIsNone,                   & !
-       phaseIsLiquid,                 & !
-       phaseIsIce,                    & !
-       phaseIsUndetermined              !
- 
-  real(wp),dimension(num_trial_res) :: &
-       trial_re_w, & ! Near-IR optical params vs size for retrieval scheme (liquid)
-       trial_re_i    ! Near-IR optical params vs size for retrieval scheme (ice)
-  real(wp),dimension(num_trial_res) :: &
-       g_w,        & ! Assymettry parameter for size retrieval (liquid)
-       g_i,        & ! Assymettry parameter for size retrieval (ice)
-       w0_w,       & ! Single-scattering albedo for size retrieval (liquid)
-       w0_i          ! Single-scattering albedo for size retrieval (ice)
-  ! Algorithmic parameters
-  real(wp),parameter :: &
-     ice_density = 0.93_wp ! Liquid density is 1. 
-      
-contains
-  ! ########################################################################################
-  ! MODIS simulator using specified liquid and ice optical thickness in each layer 
-  !
-  ! Note: this simulator operates on all points; to match MODIS itself night-time 
-  !       points should be excluded
-  !
-  ! Note: the simulator requires as input the optical thickness and cloud top pressure 
-  !       derived from the ISCCP simulator run with parameter top_height = 1. 
-  !       If cloud top pressure is higher than about 700 mb, MODIS can't use CO2 slicing 
-  !       and reverts to a thermal algorithm much like ISCCP's. Rather than replicate that 
-  !       alogrithm in this simulator we simply report the values from the ISCCP simulator. 
-  ! ########################################################################################
-  subroutine modis_subcolumn(nSubCols, nLevels, pressureLevels, optical_thickness,       & 
-                         tauLiquidFraction, g, w0,isccpCloudTopPressure,                 &
-                         retrievedPhase, retrievedCloudTopPressure,                      &
-                         retrievedTau,   retrievedSize)
-
-    ! INPUTS
-    integer,intent(in) :: &
-         nSubCols,                  & ! Number of subcolumns
-         nLevels                      ! Number of levels         
-    real(wp),dimension(nLevels+1),intent(in) :: &
-         pressureLevels               ! Gridmean pressure at layer edges (Pa)                  
-    real(wp),dimension(nSubCols,nLevels),intent(in) :: &
-         optical_thickness,         & ! Subcolumn optical thickness @ 0.67 microns.
-         tauLiquidFraction,         & ! Liquid water fraction
-         g,                         & ! Subcolumn assymetry parameter  
-         w0                           ! Subcolumn single-scattering albedo 
-    real(wp),dimension(nSubCols),intent(in) :: &
-         isccpCloudTopPressure        ! ISCCP retrieved cloud top pressure (Pa)
-
-    ! OUTPUTS
-    integer, dimension(nSubCols), intent(inout) :: &
-         retrievedPhase               ! MODIS retrieved phase (liquid/ice/other)              
-    real(wp),dimension(nSubCols), intent(inout) :: &
-         retrievedCloudTopPressure, & ! MODIS retrieved CTP (Pa)
-         retrievedTau,              & ! MODIS retrieved optical depth (unitless)              
-         retrievedSize                ! MODIS retrieved particle size (microns)              
-
-    ! LOCAL VARIABLES
-    logical, dimension(nSubCols)      :: &
-         cloudMask
-    real(wp)                          :: &
-         integratedLiquidFraction,       &
-         obs_Refl_nir
-    real(wp),dimension(num_trial_res) :: &
-         predicted_Refl_nir
-    integer                           :: &
-         i
-
-    ! ########################################################################################
-    !                           Optical depth retrieval 
-    ! This is simply a sum over the optical thickness in each layer. 
-    ! It should agree with the ISCCP values after min values have been excluded.
-    ! ########################################################################################
-    retrievedTau(1:nSubCols) = sum(optical_thickness(1:nSubCols,1:nLevels), dim = 2)
-
-    ! ########################################################################################
-    !                                 Cloud detection
-    ! does optical thickness exceed detection threshold? 
-    ! ########################################################################################
-    cloudMask = retrievedTau(1:nSubCols) >= min_OpticalThickness
-    
-    do i = 1, nSubCols
-       if(cloudMask(i)) then 
-          ! ##################################################################################
-          !                       Cloud top pressure determination 
-          ! MODIS uses CO2 slicing for clouds with tops above about 700 mb and thermal 
-          ! methods for clouds lower than that. For CO2 slicing we report the optical-depth
-          ! weighted pressure, integrating to a specified optical depth.
-          ! This assumes linear variation in p between levels. Linear in ln(p) is probably 
-          ! better, though we'd need to deal with the lowest pressure gracefully. 
-          ! ##################################################################################
-          retrievedCloudTopPressure(i) = cloud_top_pressure(nLevels,(/ 0._wp, optical_thickness(i,1:nLevels) /), &
-                                                            pressureLevels(1:nLevels),CO2Slicing_TauLimit)  
-        
-          ! ##################################################################################
-          !                               Phase determination 
-          ! Determine fraction of total tau that's liquid when ice and water contribute about 
-          ! equally to the extinction we can't tell what the phase is.
-          ! ##################################################################################
-          integratedLiquidFraction = weight_by_extinction(nLevels,optical_thickness(i,1:nLevels),       &
-                                                          tauLiquidFraction(i, 1:nLevels), &
-                                                          phase_TauLimit)
-          if(integratedLiquidFraction >= phaseDiscrimination_Threshold) then 
-             retrievedPhase(i) = phaseIsLiquid
-          else if (integratedLiquidFraction <= 1._wp- phaseDiscrimination_Threshold) then 
-             retrievedPhase(i) = phaseIsIce
-          else 
-             retrievedPhase(i) = phaseIsUndetermined
-          end if
-        
-          ! ##################################################################################
-          !                                 Size determination 
-          ! ##################################################################################
-          
-          ! Compute observed reflectance
-          obs_Refl_nir = compute_toa_reflectace(nLevels,optical_thickness(i,1:nLevels), g(i,1:nLevels), w0(i,1:nLevels))
-
-          ! Compute predicted reflectance
-          if(any(retrievedPhase(i) == (/ phaseIsLiquid, phaseIsUndetermined, phaseIsIce /))) then 
-             if (retrievedPhase(i) == phaseIsLiquid .OR. retrievedPhase(i) == phaseIsUndetermined) then
-                predicted_Refl_nir(1:num_trial_res) = two_stream_reflectance(retrievedTau(i), &
-                     g_w(1:num_trial_res), w0_w(1:num_trial_res))
-                retrievedSize(i) = 1.0e-06_wp*interpolate_to_min(trial_re_w(1:num_trial_res), &
-                     predicted_Refl_nir(1:num_trial_res), obs_Refl_nir)
-             else
-                predicted_Refl_nir(1:num_trial_res) = two_stream_reflectance(retrievedTau(i), &
-                     g_i(1:num_trial_res), w0_i(1:num_trial_res))
-                retrievedSize(i) = 1.0e-06_wp*interpolate_to_min(trial_re_i(1:num_trial_res), &
-                     predicted_Refl_nir(1:num_trial_res), obs_Refl_nir)
-             endif
-          else 
-             retrievedSize(i) = re_fill
-          endif
-       else   
-          ! Values when we don't think there's a cloud. 
-          retrievedCloudTopPressure(i) = R_UNDEF 
-          retrievedPhase(i)            = phaseIsNone
-          retrievedSize(i)             = R_UNDEF 
-          retrievedTau(i)              = R_UNDEF 
-       end if
-    end do
-    where((retrievedSize(1:nSubCols) < 0.).and.(retrievedSize(1:nSubCols) /= R_UNDEF)) &
-         retrievedSize(1:nSubCols) = 1.0e-06_wp*re_fill
-
-    ! We use the ISCCP-derived CTP for low clouds, since the ISCCP simulator ICARUS 
-    ! mimics what MODIS does to first order. 
-    ! Of course, ISCCP cloud top pressures are in mb.   
-    where(cloudMask(1:nSubCols) .and. retrievedCloudTopPressure(1:nSubCols) > CO2Slicing_PressureLimit) &
-         retrievedCloudTopPressure(1:nSubCols) = isccpCloudTopPressure! * 100._wp
-    
-  end subroutine modis_subcolumn
-
-  ! ########################################################################################
-  subroutine modis_column(nPoints,nSubCols,phase, cloud_top_pressure, optical_thickness, particle_size,     &
-       Cloud_Fraction_Total_Mean,         Cloud_Fraction_Water_Mean,         Cloud_Fraction_Ice_Mean,        &
-       Cloud_Fraction_High_Mean,          Cloud_Fraction_Mid_Mean,           Cloud_Fraction_Low_Mean,        &
-       Optical_Thickness_Total_Mean,      Optical_Thickness_Water_Mean,      Optical_Thickness_Ice_Mean,     &
-       Optical_Thickness_Total_MeanLog10, Optical_Thickness_Water_MeanLog10, Optical_Thickness_Ice_MeanLog10,&
-       Cloud_Particle_Size_Water_Mean,    Cloud_Particle_Size_Ice_Mean,      Cloud_Top_Pressure_Total_Mean,  &
-       Liquid_Water_Path_Mean,            Ice_Water_Path_Mean,                                               &    
-       Optical_Thickness_vs_Cloud_Top_Pressure,Optical_Thickness_vs_ReffIce,Optical_Thickness_vs_ReffLiq)
-    
-    ! INPUTS
-    integer,intent(in) :: &
-         nPoints,                           & ! Number of horizontal gridpoints
-         nSubCols                             ! Number of subcolumns
-    integer,intent(in), dimension(nPoints, nSubCols) ::  &
-         phase                             
-    real(wp),intent(in),dimension(nPoints, nSubCols) ::  &
-         cloud_top_pressure,                &
-         optical_thickness,                 &
-         particle_size
- 
-    ! OUTPUTS 
-    real(wp),intent(inout),dimension(nPoints)  ::   & !
-         Cloud_Fraction_Total_Mean,         & !
-         Cloud_Fraction_Water_Mean,         & !
-         Cloud_Fraction_Ice_Mean,           & !
-         Cloud_Fraction_High_Mean,          & !
-         Cloud_Fraction_Mid_Mean,           & !
-         Cloud_Fraction_Low_Mean,           & !
-         Optical_Thickness_Total_Mean,      & !
-         Optical_Thickness_Water_Mean,      & !
-         Optical_Thickness_Ice_Mean,        & !
-         Optical_Thickness_Total_MeanLog10, & !
-         Optical_Thickness_Water_MeanLog10, & !
-         Optical_Thickness_Ice_MeanLog10,   & !
-         Cloud_Particle_Size_Water_Mean,    & !
-         Cloud_Particle_Size_Ice_Mean,      & !
-         Cloud_Top_Pressure_Total_Mean,     & !
-         Liquid_Water_Path_Mean,            & !
-         Ice_Water_Path_Mean                  !
-    real(wp),intent(inout),dimension(nPoints,numMODISTauBins,numMODISPresBins) :: &
-         Optical_Thickness_vs_Cloud_Top_Pressure
-    real(wp),intent(inout),dimension(nPoints,numMODISTauBins,numMODISReffIceBins) :: &    
-         Optical_Thickness_vs_ReffIce
-    real(wp),intent(inout),dimension(nPoints,numMODISTauBins,numMODISReffLiqBins) :: &    
-         Optical_Thickness_vs_ReffLiq         
-
-    ! LOCAL VARIABLES
-    real(wp), parameter :: &
-         LWP_conversion = 2._wp/3._wp * 1000._wp ! MKS units  
-    integer :: j
-    logical, dimension(nPoints,nSubCols) :: &
-         cloudMask,      &
-         waterCloudMask, &
-         iceCloudMask,   &
-         validRetrievalMask
-    real(wp),dimension(nPoints,nSubCols) :: &
-         tauWRK,ctpWRK,reffIceWRK,reffLiqWRK
-
-    ! ########################################################################################
-    ! Include only those pixels with successful retrievals in the statistics 
-    ! ########################################################################################
-    validRetrievalMask(1:nPoints,1:nSubCols) = particle_size(1:nPoints,1:nSubCols) > 0.
-    cloudMask(1:nPoints,1:nSubCols) = phase(1:nPoints,1:nSubCols) /= phaseIsNone .and.       &
-         validRetrievalMask(1:nPoints,1:nSubCols)
-    waterCloudMask(1:nPoints,1:nSubCols) = phase(1:nPoints,1:nSubCols) == phaseIsLiquid .and. &
-         validRetrievalMask(1:nPoints,1:nSubCols)
-    iceCloudMask(1:nPoints,1:nSubCols)   = phase(1:nPoints,1:nSubCols) == phaseIsIce .and.    &
-         validRetrievalMask(1:nPoints,1:nSubCols)
-    
-    ! ########################################################################################
-    ! Use these as pixel counts at first 
-    ! ########################################################################################
-    Cloud_Fraction_Total_Mean(1:nPoints) = real(count(cloudMask,      dim = 2))
-    Cloud_Fraction_Water_Mean(1:nPoints) = real(count(waterCloudMask, dim = 2))
-    Cloud_Fraction_Ice_Mean(1:nPoints)   = real(count(iceCloudMask,   dim = 2))
-    Cloud_Fraction_High_Mean(1:nPoints)  = real(count(cloudMask .and. cloud_top_pressure <=          &
-                                           highCloudPressureLimit, dim = 2)) 
-    Cloud_Fraction_Low_Mean(1:nPoints)   = real(count(cloudMask .and. cloud_top_pressure >           &
-                                           lowCloudPressureLimit,  dim = 2)) 
-    Cloud_Fraction_Mid_Mean(1:nPoints)   = Cloud_Fraction_Total_Mean(1:nPoints) - Cloud_Fraction_High_Mean(1:nPoints)&
-                                           - Cloud_Fraction_Low_Mean(1:nPoints)
-
-    ! ########################################################################################
-    ! Compute column amounts.
-    ! ########################################################################################
-    where(Cloud_Fraction_Total_Mean(1:nPoints) > 0)
-       Optical_Thickness_Total_Mean(1:nPoints) = sum(optical_thickness, mask = cloudMask,      dim = 2) / &
-            Cloud_Fraction_Total_Mean(1:nPoints)
-       Optical_Thickness_Total_MeanLog10(1:nPoints) = sum(log10(abs(optical_thickness)), mask = cloudMask, &
-            dim = 2) / Cloud_Fraction_Total_Mean(1:nPoints)
-    elsewhere
-       Optical_Thickness_Total_Mean      = R_UNDEF
-       Optical_Thickness_Total_MeanLog10 = R_UNDEF
-    endwhere
-    where(Cloud_Fraction_Water_Mean(1:nPoints) > 0)
-       Optical_Thickness_Water_Mean(1:nPoints) = sum(optical_thickness, mask = waterCloudMask, dim = 2) / &
-            Cloud_Fraction_Water_Mean(1:nPoints)
-       Liquid_Water_Path_Mean(1:nPoints) = LWP_conversion*sum(particle_size*optical_thickness, &
-            mask=waterCloudMask,dim=2)/Cloud_Fraction_Water_Mean(1:nPoints)
-       Optical_Thickness_Water_MeanLog10(1:nPoints) = sum(log10(abs(optical_thickness)), mask = waterCloudMask,&
-            dim = 2) / Cloud_Fraction_Water_Mean(1:nPoints)
-       Cloud_Particle_Size_Water_Mean(1:nPoints) = sum(particle_size, mask = waterCloudMask, dim = 2) / &
-            Cloud_Fraction_Water_Mean(1:nPoints)
-    elsewhere
-       Optical_Thickness_Water_Mean      = R_UNDEF
-       Optical_Thickness_Water_MeanLog10 = R_UNDEF
-       Cloud_Particle_Size_Water_Mean    = R_UNDEF
-       Liquid_Water_Path_Mean            = R_UNDEF
-    endwhere
-    where(Cloud_Fraction_Ice_Mean(1:nPoints) > 0)
-       Optical_Thickness_Ice_Mean(1:nPoints)   = sum(optical_thickness, mask = iceCloudMask,   dim = 2) / &
-            Cloud_Fraction_Ice_Mean(1:nPoints)
-       Ice_Water_Path_Mean(1:nPoints) = LWP_conversion * ice_density*sum(particle_size*optical_thickness,&
-            mask=iceCloudMask,dim = 2) /Cloud_Fraction_Ice_Mean(1:nPoints) 
-       Optical_Thickness_Ice_MeanLog10(1:nPoints) = sum(log10(abs(optical_thickness)), mask = iceCloudMask,&
-            dim = 2) / Cloud_Fraction_Ice_Mean(1:nPoints)
-       Cloud_Particle_Size_Ice_Mean(1:nPoints) = sum(particle_size, mask = iceCloudMask,   dim = 2) / &
-            Cloud_Fraction_Ice_Mean(1:nPoints)    
-    elsewhere
-       Optical_Thickness_Ice_Mean        = R_UNDEF
-       Optical_Thickness_Ice_MeanLog10   = R_UNDEF
-       Cloud_Particle_Size_Ice_Mean      = R_UNDEF
-       Ice_Water_Path_Mean               = R_UNDEF
-    endwhere
-    Cloud_Top_Pressure_Total_Mean  = sum(cloud_top_pressure, mask = cloudMask, dim = 2) / &
-                                     max(1, count(cloudMask, dim = 2))
-
-    ! ########################################################################################
-    ! Normalize pixel counts to fraction. 
-    ! ########################################################################################
-    Cloud_Fraction_High_Mean(1:nPoints)  = Cloud_Fraction_High_Mean(1:nPoints)  /nSubcols
-    Cloud_Fraction_Mid_Mean(1:nPoints)   = Cloud_Fraction_Mid_Mean(1:nPoints)   /nSubcols
-    Cloud_Fraction_Low_Mean(1:nPoints)   = Cloud_Fraction_Low_Mean(1:nPoints)   /nSubcols
-    Cloud_Fraction_Total_Mean(1:nPoints) = Cloud_Fraction_Total_Mean(1:nPoints) /nSubcols
-    Cloud_Fraction_Ice_Mean(1:nPoints)   = Cloud_Fraction_Ice_Mean(1:nPoints)   /nSubcols
-    Cloud_Fraction_Water_Mean(1:nPoints) = Cloud_Fraction_Water_Mean(1:nPoints) /nSubcols
-    
-    ! ########################################################################################
-    ! Joint histograms
-    ! ########################################################################################
-    ! Loop over all points
-    tauWRK(1:nPoints,1:nSubCols)     = optical_thickness(1:nPoints,1:nSubCols)
-    ctpWRK(1:nPoints,1:nSubCols)     = cloud_top_pressure(1:nPoints,1:nSubCols)
-    reffIceWRK(1:nPoints,1:nSubCols) = merge(particle_size,R_UNDEF,iceCloudMask)
-    reffLiqWRK(1:nPoints,1:nSubCols) = merge(particle_size,R_UNDEF,waterCloudMask)
-    do j=1,nPoints
-
-       ! Fill clear and optically thin subcolumns with fill
-       where(.not. cloudMask(j,1:nSubCols)) 
-          tauWRK(j,1:nSubCols) = -999._wp
-          ctpWRK(j,1:nSubCols) = -999._wp
-       endwhere
-       ! Joint histogram of tau/CTP
-       call hist2D(tauWRK(j,1:nSubCols),ctpWRK(j,1:nSubCols),nSubCols,&
-                   modis_histTau,numMODISTauBins,&
-                   modis_histPres,numMODISPresBins,&
-                   Optical_Thickness_vs_Cloud_Top_Pressure(j,1:numMODISTauBins,1:numMODISPresBins))
-       ! Joint histogram of tau/ReffICE
-       call hist2D(tauWRK(j,1:nSubCols),reffIceWrk(j,1:nSubCols),nSubCols,               &
-                   modis_histTau,numMODISTauBins,modis_histReffIce,         &
-                   numMODISReffIceBins, Optical_Thickness_vs_ReffIce(j,1:numMODISTauBins,1:numMODISReffIceBins))
-       ! Joint histogram of tau/ReffLIQ
-       call hist2D(tauWRK(j,1:nSubCols),reffLiqWrk(j,1:nSubCols),nSubCols,               &
-                   modis_histTau,numMODISTauBins,modis_histReffLiq,         &
-                   numMODISReffLiqBins, Optical_Thickness_vs_ReffLiq(j,1:numMODISTauBins,1:numMODISReffLiqBins))                   
-
-    enddo   
-    Optical_Thickness_vs_Cloud_Top_Pressure(1:nPoints,1:numMODISTauBins,1:numMODISPresBins) = &
-         Optical_Thickness_vs_Cloud_Top_Pressure(1:nPoints,1:numMODISTauBins,1:numMODISPresBins)/nSubCols
-    Optical_Thickness_vs_ReffIce(1:nPoints,1:numMODISTauBins,1:numMODISReffIceBins) = &
-         Optical_Thickness_vs_ReffIce(1:nPoints,1:numMODISTauBins,1:numMODISReffIceBins)/nSubCols
-    Optical_Thickness_vs_ReffLiq(1:nPoints,1:numMODISTauBins,1:numMODISReffLiqBins) = &
-         Optical_Thickness_vs_ReffLiq(1:nPoints,1:numMODISTauBins,1:numMODISReffLiqBins)/nSubCols 
-                 
-
-    ! Unit conversion
-    where(Optical_Thickness_vs_Cloud_Top_Pressure /= R_UNDEF) &
-      Optical_Thickness_vs_Cloud_Top_Pressure = Optical_Thickness_vs_Cloud_Top_Pressure*100._wp
-    where(Optical_Thickness_vs_ReffIce /= R_UNDEF) Optical_Thickness_vs_ReffIce = Optical_Thickness_vs_ReffIce*100._wp
-    where(Optical_Thickness_vs_ReffLiq /= R_UNDEF) Optical_Thickness_vs_ReffLiq = Optical_Thickness_vs_ReffLiq*100._wp
-    where(Cloud_Fraction_Total_Mean /= R_UNDEF) Cloud_Fraction_Total_Mean = Cloud_Fraction_Total_Mean*100._wp
-    where(Cloud_Fraction_Water_Mean /= R_UNDEF) Cloud_Fraction_Water_Mean = Cloud_Fraction_Water_Mean*100._wp
-    where(Cloud_Fraction_Ice_Mean /= R_UNDEF)   Cloud_Fraction_Ice_Mean = Cloud_Fraction_Ice_Mean*100._wp
-    where(Cloud_Fraction_High_Mean /= R_UNDEF)  Cloud_Fraction_High_Mean = Cloud_Fraction_High_Mean*100._wp
-    where(Cloud_Fraction_Mid_Mean /= R_UNDEF)   Cloud_Fraction_Mid_Mean = Cloud_Fraction_Mid_Mean*100._wp
-    where(Cloud_Fraction_Low_Mean /= R_UNDEF)   Cloud_Fraction_Low_Mean = Cloud_Fraction_Low_Mean*100._wp
-
-  end subroutine modis_column
-
-  ! ########################################################################################
-  function cloud_top_pressure(nLevels,tauIncrement, pressure, tauLimit) 
-    ! INPUTS
-    integer, intent(in)                    :: nLevels
-    real(wp),intent(in),dimension(nLevels) :: tauIncrement, pressure
-    real(wp),intent(in)                    :: tauLimit
-    ! OUTPUTS
-    real(wp)                               :: cloud_top_pressure
-    ! LOCAL VARIABLES
-    real(wp)                               :: deltaX, totalTau, totalProduct
-    integer                                :: i 
-    
-    ! Find the extinction-weighted pressure. Assume that pressure varies linearly between 
-    !   layers and use the trapezoidal rule.
-    totalTau = 0._wp; totalProduct = 0._wp
-    do i = 2, size(tauIncrement)
-      if(totalTau + tauIncrement(i) > tauLimit) then 
-        deltaX = tauLimit - totalTau
-        totalTau = totalTau + deltaX
-        !
-        ! Result for trapezoidal rule when you take less than a full step
-        !   tauIncrement is a layer-integrated value
-        !
-        totalProduct = totalProduct           &
-                     + pressure(i-1) * deltaX &
-                     + (pressure(i) - pressure(i-1)) * deltaX**2/(2._wp * tauIncrement(i)) 
-      else
-        totalTau =     totalTau     + tauIncrement(i) 
-        totalProduct = totalProduct + tauIncrement(i) * (pressure(i) + pressure(i-1)) / 2._wp
-      end if 
-      if(totalTau >= tauLimit) exit
-    end do 
-
-    if (totalTau > 0._wp) then
-       cloud_top_pressure = totalProduct/totalTau
-    else
-       cloud_top_pressure = 0._wp
-    endif
-    
-  end function cloud_top_pressure
-
-  ! ########################################################################################
-  function weight_by_extinction(nLevels,tauIncrement, f, tauLimit) 
-    ! INPUTS
-    integer, intent(in)                    :: nLevels
-    real(wp),intent(in),dimension(nLevels) :: tauIncrement, f
-    real(wp),intent(in)                    :: tauLimit
-    ! OUTPUTS
-    real(wp)                               :: weight_by_extinction
-    ! LOCAL VARIABLES
-    real(wp)                               :: deltaX, totalTau, totalProduct
-    integer                                :: i 
-    
-    ! Find the extinction-weighted value of f(tau), assuming constant f within each layer
-    totalTau = 0._wp; totalProduct = 0._wp
-    do i = 1, size(tauIncrement)
-      if(totalTau + tauIncrement(i) > tauLimit) then 
-        deltaX       = tauLimit - totalTau
-        totalTau     = totalTau     + deltaX
-        totalProduct = totalProduct + deltaX * f(i) 
-      else
-        totalTau     = totalTau     + tauIncrement(i) 
-        totalProduct = totalProduct + tauIncrement(i) * f(i) 
-      end if 
-      if(totalTau >= tauLimit) exit
-    end do 
-
-    if (totalTau > 0._wp) then
-       weight_by_extinction = totalProduct/totalTau
-    else
-       weight_by_extinction = 0._wp
-    endif
-    
-  end function weight_by_extinction
-
-  ! ########################################################################################
-  pure function interpolate_to_min(x, y, yobs)
-    ! INPUTS
-    real(wp),intent(in),dimension(num_trial_res) :: x, y 
-    real(wp),intent(in)                          :: yobs
-    ! OUTPUTS
-    real(wp)                                     :: interpolate_to_min
-    ! LOCAL VARIABLES
-    real(wp), dimension(num_trial_res)           :: diff
-    integer                                      :: nPoints, minDiffLoc, lowerBound, upperBound
-    
-    ! Given a set of values of y as y(x), find the value of x that minimizes abs(y - yobs)
-    !   y must be monotonic in x
- 
-    nPoints = size(y)
-    diff(1:num_trial_res) = y(1:num_trial_res) - yobs
-    minDiffLoc = minloc(abs(diff), dim = 1) 
-    
-    if(minDiffLoc == 1) then 
-      lowerBound = minDiffLoc
-      upperBound = minDiffLoc + 1
-    else if(minDiffLoc == nPoints) then
-      lowerBound = minDiffLoc - 1
-      upperBound = minDiffLoc
-    else
-      if(diff(minDiffLoc-1) * diff(minDiffLoc) < 0) then
-        lowerBound = minDiffLoc-1
-        upperBound = minDiffLoc
-      else 
-        lowerBound = minDiffLoc
-        upperBound = minDiffLoc + 1
-      end if 
-    end if 
-    
-    if(diff(lowerBound) * diff(upperBound) < 0) then     
-      !
-      ! Interpolate the root position linearly if we bracket the root
-      !
-      interpolate_to_min = x(upperBound) - & 
-                           diff(upperBound) * (x(upperBound) - x(lowerBound)) / (diff(upperBound) - diff(lowerBound))
-    else 
-      interpolate_to_min = re_fill
-    end if 
-    
-
-  end function interpolate_to_min
-
-  ! ########################################################################################
-  ! Optical properties
-  ! ########################################################################################
-  elemental function get_g_nir_old (phase, re)
-    ! Polynomial fit for asummetry parameter g in MODIS band 7 (near IR) as a function 
-    !   of size for ice and water
-    ! Fits from Steve Platnick
-
-    ! INPUTS
-    integer, intent(in) :: phase
-    real(wp),intent(in) :: re
-    ! OUTPUTS
-    real(wp)            :: get_g_nir_old 
-    ! LOCAL VARIABLES(parameters)
-    real(wp), dimension(3), parameter :: &
-         ice_coefficients         = (/ 0.7432,  4.5563e-3, -2.8697e-5 /), & 
-         small_water_coefficients = (/ 0.8027, -1.0496e-2,  1.7071e-3 /), & 
-         big_water_coefficients   = (/ 0.7931,  5.3087e-3, -7.4995e-5 /) 
-   
-    ! approx. fits from MODIS Collection 5 LUT scattering calculations
-    if(phase == phaseIsLiquid) then
-      if(re < 8.) then 
-        get_g_nir_old = fit_to_quadratic(re, small_water_coefficients)
-        if(re < re_water_min) get_g_nir_old = fit_to_quadratic(re_water_min, small_water_coefficients)
-      else
-        get_g_nir_old = fit_to_quadratic(re,   big_water_coefficients)
-        if(re > re_water_max) get_g_nir_old = fit_to_quadratic(re_water_max, big_water_coefficients)
-      end if 
-    else
-      get_g_nir_old = fit_to_quadratic(re, ice_coefficients)
-      if(re < re_ice_min) get_g_nir_old = fit_to_quadratic(re_ice_min, ice_coefficients)
-      if(re > re_ice_max) get_g_nir_old = fit_to_quadratic(re_ice_max, ice_coefficients)
-    end if 
-    
-  end function get_g_nir_old
-
-  ! ########################################################################################
-  elemental function get_ssa_nir_old (phase, re)
-    ! Polynomial fit for single scattering albedo in MODIS band 7 (near IR) as a function 
-    !   of size for ice and water
-    ! Fits from Steve Platnick
-    
-    ! INPUTS
-    integer, intent(in) :: phase
-    real(wp),intent(in) :: re
-    ! OUTPUTS
-    real(wp)            :: get_ssa_nir_old
-    ! LOCAL VARIABLES (parameters)
-    real(wp), dimension(4), parameter :: ice_coefficients   = (/ 0.9994, -4.5199e-3, 3.9370e-5, -1.5235e-7 /)
-    real(wp), dimension(3), parameter :: water_coefficients = (/ 1.0008, -2.5626e-3, 1.6024e-5 /) 
-    
-    ! approx. fits from MODIS Collection 5 LUT scattering calculations
-    if(phase == phaseIsLiquid) then
-       get_ssa_nir_old = fit_to_quadratic(re, water_coefficients)
-       if(re < re_water_min) get_ssa_nir_old = fit_to_quadratic(re_water_min, water_coefficients)
-       if(re > re_water_max) get_ssa_nir_old = fit_to_quadratic(re_water_max, water_coefficients)
-    else
-       get_ssa_nir_old = fit_to_cubic(re, ice_coefficients)
-       if(re < re_ice_min) get_ssa_nir_old = fit_to_cubic(re_ice_min, ice_coefficients)
-       if(re > re_ice_max) get_ssa_nir_old = fit_to_cubic(re_ice_max, ice_coefficients)
-    end if
-    
-  end function get_ssa_nir_old
-  
-  elemental function get_g_nir (phase, re)
-    !
-    ! Polynomial fit for asummetry parameter g in MODIS band 7 (near IR) as a function 
-    !   of size for ice and water
-    ! Fits from Steve Platnick
-    !
-
-    integer, intent(in) :: phase
-    real(wp),    intent(in) :: re
-    real(wp) :: get_g_nir 
-
-    real(wp), dimension(3), parameter :: ice_coefficients         = (/ 0.7490, 6.5153e-3, -5.4136e-5 /), &
-                                         small_water_coefficients = (/ 1.0364, -8.8800e-2, 7.0000e-3 /)
-    real(wp), dimension(4), parameter :: big_water_coefficients   = (/ 0.6035, 2.8993e-2, -1.1051e-3, 1.5134e-5 /)
-
-    ! approx. fits from MODIS Collection 6 LUT scattering calculations for 3.7 µm channel size retrievals
-    if(phase == phaseIsLiquid) then 
-       if(re < 7.) then
-          get_g_nir = fit_to_quadratic(re, small_water_coefficients)
-          if(re < re_water_min) get_g_nir = fit_to_quadratic(re_water_min, small_water_coefficients)
-       else
-          get_g_nir = fit_to_cubic(re, big_water_coefficients)
-          if(re > re_water_max) get_g_nir = fit_to_cubic(re_water_max, big_water_coefficients)
-       end if
-    else
-       get_g_nir = fit_to_quadratic(re, ice_coefficients)
-      if(re < re_ice_min) get_g_nir = fit_to_quadratic(re_ice_min, ice_coefficients)
-      if(re > re_ice_max) get_g_nir = fit_to_quadratic(re_ice_max, ice_coefficients)
-    end if 
-    
-  end function get_g_nir
-
-  ! --------------------------------------------
-    elemental function get_ssa_nir (phase, re)
-        integer, intent(in) :: phase
-        real(wp),    intent(in) :: re
-        real(wp)                :: get_ssa_nir
-        !
-        ! Polynomial fit for single scattering albedo in MODIS band 7 (near IR) as a function 
-        !   of size for ice and water
-        ! Fits from Steve Platnick
-        !
-        real(wp), dimension(4), parameter :: ice_coefficients   = (/ 0.9625, -1.8069e-2, 3.3281e-4,-2.2865e-6/)
-        real(wp), dimension(3), parameter :: water_coefficients = (/ 1.0044, -1.1397e-2, 1.3300e-4 /)
-        
-        ! approx. fits from MODIS Collection 6 LUT scattering calculations
-        if(phase == phaseIsLiquid) then
-          get_ssa_nir = fit_to_quadratic(re, water_coefficients)
-          if(re < re_water_min) get_ssa_nir = fit_to_quadratic(re_water_min, water_coefficients)
-          if(re > re_water_max) get_ssa_nir = fit_to_quadratic(re_water_max, water_coefficients)
-        else
-          get_ssa_nir = fit_to_cubic(re, ice_coefficients)
-          if(re < re_ice_min) get_ssa_nir = fit_to_cubic(re_ice_min, ice_coefficients)
-          if(re > re_ice_max) get_ssa_nir = fit_to_cubic(re_ice_max, ice_coefficients)
-        end if 
-
-    end function get_ssa_nir
-
-  
-
-  ! ########################################################################################
-  pure function fit_to_cubic(x, coefficients) 
-    ! INPUTS
-    real(wp),               intent(in) :: x
-    real(wp), dimension(4), intent(in) :: coefficients
-    ! OUTPUTS
-    real(wp)                           :: fit_to_cubic  
-    
-    fit_to_cubic = coefficients(1) + x * (coefficients(2) + x * (coefficients(3) + x * coefficients(4)))
-  end function fit_to_cubic
-    
-  ! ########################################################################################
-  pure function fit_to_quadratic(x, coefficients) 
-    ! INPUTS
-    real(wp),               intent(in) :: x
-    real(wp), dimension(3), intent(in) :: coefficients
-    ! OUTPUTS
-    real(wp)                           :: fit_to_quadratic
-    
-    fit_to_quadratic = coefficients(1) + x * (coefficients(2) + x * (coefficients(3)))
-  end function fit_to_quadratic
-
-  ! ########################################################################################
-  ! Radiative transfer
-  ! ########################################################################################
-  pure function compute_toa_reflectace(nLevels,tau, g, w0)
-    ! This wrapper reports reflectance only and strips out non-cloudy elements from the 
-    ! calculation
-    
-    ! INPUTS
-    integer,intent(in)                     :: nLevels
-    real(wp),intent(in),dimension(nLevels) :: tau, g, w0
-    ! OUTPUTS
-    real(wp)                               :: compute_toa_reflectace
-    ! LOCAL VARIABLES
-    logical, dimension(nLevels)                   :: cloudMask
-    integer, dimension(count(tau(1:nLevels) > 0)) :: cloudIndicies
-    real(wp),dimension(count(tau(1:nLevels) > 0)) :: Refl,Trans
-    real(wp)                                      :: Refl_tot, Trans_tot
-    integer                                       :: i
-
-    cloudMask(1:nLevels) = tau(1:nLevels) > 0. 
-    cloudIndicies = pack((/ (i, i = 1, nLevels) /), mask = cloudMask) 
-    do i = 1, size(cloudIndicies)
-       call two_stream(tau(cloudIndicies(i)), g(cloudIndicies(i)), w0(cloudIndicies(i)), Refl(i), Trans(i))
-    end do
-    
-    call adding_doubling(count(tau(1:nLevels) > 0),Refl(:), Trans(:), Refl_tot, Trans_tot)  
-    
-    compute_toa_reflectace = Refl_tot
-    
-  end function compute_toa_reflectace
- 
-  ! ########################################################################################
-  pure subroutine two_stream(tauint, gint, w0int, ref, tra) 
-    ! Compute reflectance in a single layer using the two stream approximation 
-    !   The code itself is from Lazaros Oreopoulos via Steve Platnick 
-    ! INPUTS
-    real(wp), intent(in)  :: tauint, gint, w0int
-    ! OUTPUTS
-    real(wp), intent(out) :: ref, tra
-    ! LOCAL VARIABLES
-    !   for delta Eddington code
-    !   xmu, gamma3, and gamma4 only used for collimated beam approximation (i.e., beam=1)
-    integer, parameter :: beam = 2
-    real(wp),parameter :: xmu = 0.866, minConservativeW0 = 0.9999999
-    real(wp) :: tau, w0, g, f, gamma1, gamma2, gamma3, gamma4, &
-         rh, a1, a2, rk, r1, r2, r3, r4, r5, t1, t2, t3, t4, t5, beta, e1, e2, ef1, ef2, den, th
-    
-    ! Compute reflectance and transmittance in a single layer using the two stream approximation 
-    !   The code itself is from Lazaros Oreopoulos via Steve Platnick 
-    f   = gint**2
-    tau = (1._wp - w0int * f) * tauint
-    w0  = (1._wp - f) * w0int / (1._wp - w0int * f)
-    g   = (gint - f) / (1._wp - f)
-
-    ! delta-Eddington (Joseph et al. 1976)
-    gamma1 =  (7._wp - w0* (4._wp + 3._wp * g)) / 4._wp
-    gamma2 = -(1._wp - w0* (4._wp - 3._wp * g)) / 4._wp
-    gamma3 =  (2._wp - 3._wp*g*xmu) / 4._wp
-    gamma4 =   1._wp - gamma3
-
-    if (w0int > minConservativeW0) then
-      ! Conservative scattering
-      if (beam == 1) then
-          rh = (gamma1*tau+(gamma3-gamma1*xmu)*(1-exp(-tau/xmu)))
-  
-          ref = rh / (1._wp + gamma1 * tau)
-          tra = 1._wp - ref       
-      else if(beam == 2) then
-          ref = gamma1*tau/(1._wp + gamma1*tau)
-          tra = 1._wp - ref
-      endif
-    else
-      ! Non-conservative scattering
-      a1 = gamma1 * gamma4 + gamma2 * gamma3
-      a2 = gamma1 * gamma3 + gamma2 * gamma4
-
-      rk = sqrt(gamma1**2 - gamma2**2)
-      
-      r1 = (1._wp - rk * xmu) * (a2 + rk * gamma3)
-      r2 = (1._wp + rk * xmu) * (a2 - rk * gamma3)
-      r3 = 2._wp * rk *(gamma3 - a2 * xmu)
-      r4 = (1._wp - (rk * xmu)**2) * (rk + gamma1)
-      r5 = (1._wp - (rk * xmu)**2) * (rk - gamma1)
-      
-      t1 = (1._wp + rk * xmu) * (a1 + rk * gamma4)
-      t2 = (1._wp - rk * xmu) * (a1 - rk * gamma4)
-      t3 = 2._wp * rk * (gamma4 + a1 * xmu)
-      t4 = r4
-      t5 = r5
-
-      beta = -r5 / r4         
-  
-      e1 = min(rk * tau, 500._wp) 
-      e2 = min(tau / xmu, 500._wp) 
-      
-      if (beam == 1) then
-         den = r4 * exp(e1) + r5 * exp(-e1)
-         ref  = w0*(r1*exp(e1)-r2*exp(-e1)-r3*exp(-e2))/den
-         den = t4 * exp(e1) + t5 * exp(-e1)
-         th  = exp(-e2)
-         tra = th-th*w0*(t1*exp(e1)-t2*exp(-e1)-t3*exp(e2))/den
-      elseif (beam == 2) then
-         ef1 = exp(-e1)
-         ef2 = exp(-2*e1)
-         ref = (gamma2*(1._wp-ef2))/((rk+gamma1)*(1._wp-beta*ef2))
-         tra = (2._wp*rk*ef1)/((rk+gamma1)*(1._wp-beta*ef2))
-      endif
-    end if
-  end subroutine two_stream
-
-  ! ########################################################################################
-  elemental function two_stream_reflectance(tauint, gint, w0int)
-    ! Compute reflectance in a single layer using the two stream approximation 
-    !   The code itself is from Lazaros Oreopoulos via Steve Platnick 
-    
-    ! INPUTS
-    real(wp), intent(in) :: tauint, gint, w0int
-    ! OUTPUTS
-    real(wp)             :: two_stream_reflectance
-    ! LOCAL VARIABLES
-    !   for delta Eddington code
-    !   xmu, gamma3, and gamma4 only used for collimated beam approximation (i.e., beam=1)
-    integer, parameter :: beam = 2
-    real(wp),parameter :: xmu = 0.866, minConservativeW0 = 0.9999999
-    real(wp) :: tau, w0, g, f, gamma1, gamma2, gamma3, gamma4, &
-         rh, a1, a2, rk, r1, r2, r3, r4, r5, t1, t2, t3, t4, t5, beta, e1, e2, ef1, ef2, den
-
-    f   = gint**2
-    tau = (1._wp - w0int * f) * tauint
-    w0  = (1._wp - f) * w0int / (1._wp - w0int * f)
-    g   = (gint - f) / (1._wp - f)
-
-    ! delta-Eddington (Joseph et al. 1976)
-    gamma1 =  (7._wp - w0* (4._wp + 3._wp * g)) / 4._wp
-    gamma2 = -(1._wp - w0* (4._wp - 3._wp * g)) / 4._wp
-    gamma3 =  (2._wp - 3._wp*g*xmu) / 4._wp
-    gamma4 =   1._wp - gamma3
-
-    if (w0int > minConservativeW0) then
-      ! Conservative scattering
-      if (beam == 1) then
-          rh = (gamma1*tau+(gamma3-gamma1*xmu)*(1-exp(-tau/xmu)))
-          two_stream_reflectance = rh / (1._wp + gamma1 * tau)
-      elseif (beam == 2) then
-          two_stream_reflectance = gamma1*tau/(1._wp + gamma1*tau)
-      endif
-        
-    else    !
-
-        ! Non-conservative scattering
-         a1 = gamma1 * gamma4 + gamma2 * gamma3
-         a2 = gamma1 * gamma3 + gamma2 * gamma4
-
-         rk = sqrt(gamma1**2 - gamma2**2)
-         
-         r1 = (1._wp - rk * xmu) * (a2 + rk * gamma3)
-         r2 = (1._wp + rk * xmu) * (a2 - rk * gamma3)
-         r3 = 2._wp * rk *(gamma3 - a2 * xmu)
-         r4 = (1._wp - (rk * xmu)**2) * (rk + gamma1)
-         r5 = (1._wp - (rk * xmu)**2) * (rk - gamma1)
-         
-         t1 = (1._wp + rk * xmu) * (a1 + rk * gamma4)
-         t2 = (1._wp - rk * xmu) * (a1 - rk * gamma4)
-         t3 = 2._wp * rk * (gamma4 + a1 * xmu)
-         t4 = r4
-         t5 = r5
-
-         beta = -r5 / r4         
-         
-         e1 = min(rk * tau, 500._wp) 
-         e2 = min(tau / xmu, 500._wp) 
-         
-         if (beam == 1) then
-           den = r4 * exp(e1) + r5 * exp(-e1)
-           two_stream_reflectance  = w0*(r1*exp(e1)-r2*exp(-e1)-r3*exp(-e2))/den
-         elseif (beam == 2) then
-           ef1 = exp(-e1)
-           ef2 = exp(-2*e1)
-           two_stream_reflectance = (gamma2*(1._wp-ef2))/((rk+gamma1)*(1._wp-beta*ef2))
-         endif
-           
-      end if
-  end function two_stream_reflectance 
-
-  ! ########################################################################################
-  pure subroutine adding_doubling (npts,Refl, Tran, Refl_tot, Tran_tot)      
-    ! Use adding/doubling formulas to compute total reflectance and transmittance from 
-    ! layer values
-    
-    ! INPUTS
-    integer,intent(in)                  :: npts
-    real(wp),intent(in),dimension(npts) :: Refl,Tran
-    ! OUTPUTS
-    real(wp),intent(out)                :: Refl_tot, Tran_tot
-    ! LOCAL VARIABLES
-    integer :: i
-    real(wp), dimension(npts) :: Refl_cumulative, Tran_cumulative
-    
-    Refl_cumulative(1) = Refl(1)
-    Tran_cumulative(1) = Tran(1)    
-    
-    do i=2, npts
-       ! place (add) previous combined layer(s) reflectance on top of layer i, w/black surface (or ignoring surface):
-       Refl_cumulative(i) = Refl_cumulative(i-1) + Refl(i)*(Tran_cumulative(i-1)**2)/(1._wp - Refl_cumulative(i-1) * Refl(i))
-       Tran_cumulative(i) = (Tran_cumulative(i-1)*Tran(i)) / (1._wp - Refl_cumulative(i-1) * Refl(i))
-    end do
-    
-    Refl_tot = Refl_cumulative(size(Refl))
-    Tran_tot = Tran_cumulative(size(Refl))
-    
-  end subroutine adding_doubling
-
-end module mod_modis_sim
Index: /LMDZ6/trunk/libf/phylmd/cospv2/modis_simulator.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cospv2/modis_simulator.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/cospv2/modis_simulator.f90	(revision 5268)
@@ -0,0 +1,906 @@
+! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+! Copyright (c) 2015, Regents of the University of Colorado
+! All rights reserved.
+!
+! Redistribution and use in source and binary forms, with or without modification, are 
+! permitted provided that the following conditions are met:
+!
+! 1. Redistributions of source code must retain the above copyright notice, this list of 
+!    conditions and the following disclaimer.
+!
+! 2. Redistributions in binary form must reproduce the above copyright notice, this list
+!    of conditions and the following disclaimer in the documentation and/or other 
+!    materials provided with the distribution.
+!
+! 3. Neither the name of the copyright holder nor the names of its contributors may be 
+!    used to endorse or promote products derived from this software without specific prior
+!    written permission.
+!
+! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY 
+! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 
+! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL 
+! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 
+! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT 
+! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 
+! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+!
+! History
+! May 2009:      Robert Pincus - Initial version
+! June 2009:     Steve Platnick and Robert Pincus - Simple radiative transfer for size 
+!                retrievals
+! August 2009:   Robert Pincus - Consistency and bug fixes suggested by Rick Hemler (GFDL) 
+! November 2009: Robert Pincus - Bux fixes and speed-ups after experience with Rick Hemler 
+!                using AM2 (GFDL) 
+! January 2010:  Robert Pincus - Added high, middle, low cloud fractions
+! May 2015:      Dustin Swales - Modified for COSPv2.0
+! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+!
+! Notes on using the MODIS simulator: 
+!  *) You may provide either layer-by-layer values of optical thickness at 0.67 and 2.1
+!     microns, or optical thickness at 0.67 microns and ice- and liquid-water contents 
+!     (in consistent units of your choosing)
+!  *) Required input also includes the optical thickness and cloud top pressure 
+!     derived from the ISCCP simulator run with parameter top_height = 1. 
+!  *) Cloud particle sizes are specified as radii, measured in meters, though within the 
+!     module we use units of microns. Where particle sizes are outside the bounds used in 
+!     the MODIS retrieval libraries (parameters re_water_min, re_ice_min, etc.) the 
+!     simulator returns missing values (re_fill)
+!
+! When error conditions are encountered this code calls the function complain_and_die, 
+! supplied at the bottom of this module. Users probably want to replace this with 
+! something more graceful. 
+!
+module mod_modis_sim
+  USE MOD_COSP_CONFIG, only: R_UNDEF,modis_histTau,modis_histPres,numMODISTauBins,       &
+                             numMODISPresBins,numMODISReffIceBins,numMODISReffLiqBins,   &
+                             modis_histReffIce,modis_histReffLiq
+  USE COSP_KINDS,      ONLY: wp
+  use MOD_COSP_STATS,  ONLY: hist2D
+
+  implicit none
+  ! ##########################################################################
+  ! Retrieval parameters
+   integer, parameter :: &
+        num_trial_res = 15              ! Increase to make the linear pseudo-retrieval of size more accurate
+   
+   real(wp) :: &
+       min_OpticalThickness,          & ! Minimum detectable optical thickness
+       CO2Slicing_PressureLimit,      & ! Cloud with higher pressures use thermal methods, units Pa
+       CO2Slicing_TauLimit,           & ! How deep into the cloud does CO2 slicing see? 
+       phase_TauLimit,                & ! How deep into the cloud does the phase detection see?
+       size_TauLimit,                 & ! Depth of the re retreivals
+       phaseDiscrimination_Threshold, & ! What fraction of total extincton needs to be in a single
+                                        ! category to make phase discrim. work? 
+       re_fill,                       & !
+       re_water_min,                  & ! Minimum effective radius (liquid)
+       re_water_max,                  & ! Maximum effective radius (liquid)
+       re_ice_min,                    & ! Minimum effective radius (ice)
+       re_ice_max,                    & ! Minimum effective radius (ice)
+       highCloudPressureLimit,        & ! High cloud pressure limit (Pa)
+       lowCloudPressureLimit            ! Low cloud pressure limit (Pa)
+  integer :: &
+       phaseIsNone,                   & !
+       phaseIsLiquid,                 & !
+       phaseIsIce,                    & !
+       phaseIsUndetermined              !
+ 
+  real(wp),dimension(num_trial_res) :: &
+       trial_re_w, & ! Near-IR optical params vs size for retrieval scheme (liquid)
+       trial_re_i    ! Near-IR optical params vs size for retrieval scheme (ice)
+  real(wp),dimension(num_trial_res) :: &
+       g_w,        & ! Assymettry parameter for size retrieval (liquid)
+       g_i,        & ! Assymettry parameter for size retrieval (ice)
+       w0_w,       & ! Single-scattering albedo for size retrieval (liquid)
+       w0_i          ! Single-scattering albedo for size retrieval (ice)
+  ! Algorithmic parameters
+  real(wp),parameter :: &
+     ice_density = 0.93_wp ! Liquid density is 1. 
+      
+contains
+  ! ########################################################################################
+  ! MODIS simulator using specified liquid and ice optical thickness in each layer 
+  !
+  ! Note: this simulator operates on all points; to match MODIS itself night-time 
+  !       points should be excluded
+  !
+  ! Note: the simulator requires as input the optical thickness and cloud top pressure 
+  !       derived from the ISCCP simulator run with parameter top_height = 1. 
+  !       If cloud top pressure is higher than about 700 mb, MODIS can't use CO2 slicing 
+  !       and reverts to a thermal algorithm much like ISCCP's. Rather than replicate that 
+  !       alogrithm in this simulator we simply report the values from the ISCCP simulator. 
+  ! ########################################################################################
+  subroutine modis_subcolumn(nSubCols, nLevels, pressureLevels, optical_thickness,       & 
+                         tauLiquidFraction, g, w0,isccpCloudTopPressure,                 &
+                         retrievedPhase, retrievedCloudTopPressure,                      &
+                         retrievedTau,   retrievedSize)
+
+    ! INPUTS
+    integer,intent(in) :: &
+         nSubCols,                  & ! Number of subcolumns
+         nLevels                      ! Number of levels         
+    real(wp),dimension(nLevels+1),intent(in) :: &
+         pressureLevels               ! Gridmean pressure at layer edges (Pa)                  
+    real(wp),dimension(nSubCols,nLevels),intent(in) :: &
+         optical_thickness,         & ! Subcolumn optical thickness @ 0.67 microns.
+         tauLiquidFraction,         & ! Liquid water fraction
+         g,                         & ! Subcolumn assymetry parameter  
+         w0                           ! Subcolumn single-scattering albedo 
+    real(wp),dimension(nSubCols),intent(in) :: &
+         isccpCloudTopPressure        ! ISCCP retrieved cloud top pressure (Pa)
+
+    ! OUTPUTS
+    integer, dimension(nSubCols), intent(inout) :: &
+         retrievedPhase               ! MODIS retrieved phase (liquid/ice/other)              
+    real(wp),dimension(nSubCols), intent(inout) :: &
+         retrievedCloudTopPressure, & ! MODIS retrieved CTP (Pa)
+         retrievedTau,              & ! MODIS retrieved optical depth (unitless)              
+         retrievedSize                ! MODIS retrieved particle size (microns)              
+
+    ! LOCAL VARIABLES
+    logical, dimension(nSubCols)      :: &
+         cloudMask
+    real(wp)                          :: &
+         integratedLiquidFraction,       &
+         obs_Refl_nir
+    real(wp),dimension(num_trial_res) :: &
+         predicted_Refl_nir
+    integer                           :: &
+         i
+
+    ! ########################################################################################
+    !                           Optical depth retrieval 
+    ! This is simply a sum over the optical thickness in each layer. 
+    ! It should agree with the ISCCP values after min values have been excluded.
+    ! ########################################################################################
+    retrievedTau(1:nSubCols) = sum(optical_thickness(1:nSubCols,1:nLevels), dim = 2)
+
+    ! ########################################################################################
+    !                                 Cloud detection
+    ! does optical thickness exceed detection threshold? 
+    ! ########################################################################################
+    cloudMask = retrievedTau(1:nSubCols) >= min_OpticalThickness
+    
+    do i = 1, nSubCols
+       if(cloudMask(i)) then 
+          ! ##################################################################################
+          !                       Cloud top pressure determination 
+          ! MODIS uses CO2 slicing for clouds with tops above about 700 mb and thermal 
+          ! methods for clouds lower than that. For CO2 slicing we report the optical-depth
+          ! weighted pressure, integrating to a specified optical depth.
+          ! This assumes linear variation in p between levels. Linear in ln(p) is probably 
+          ! better, though we'd need to deal with the lowest pressure gracefully. 
+          ! ##################################################################################
+          retrievedCloudTopPressure(i) = cloud_top_pressure(nLevels,(/ 0._wp, optical_thickness(i,1:nLevels) /), &
+                                                            pressureLevels(1:nLevels),CO2Slicing_TauLimit)  
+        
+          ! ##################################################################################
+          !                               Phase determination 
+          ! Determine fraction of total tau that's liquid when ice and water contribute about 
+          ! equally to the extinction we can't tell what the phase is.
+          ! ##################################################################################
+          integratedLiquidFraction = weight_by_extinction(nLevels,optical_thickness(i,1:nLevels),       &
+                                                          tauLiquidFraction(i, 1:nLevels), &
+                                                          phase_TauLimit)
+          if(integratedLiquidFraction >= phaseDiscrimination_Threshold) then 
+             retrievedPhase(i) = phaseIsLiquid
+          else if (integratedLiquidFraction <= 1._wp- phaseDiscrimination_Threshold) then 
+             retrievedPhase(i) = phaseIsIce
+          else 
+             retrievedPhase(i) = phaseIsUndetermined
+          end if
+        
+          ! ##################################################################################
+          !                                 Size determination 
+          ! ##################################################################################
+          
+          ! Compute observed reflectance
+          obs_Refl_nir = compute_toa_reflectace(nLevels,optical_thickness(i,1:nLevels), g(i,1:nLevels), w0(i,1:nLevels))
+
+          ! Compute predicted reflectance
+          if(any(retrievedPhase(i) == (/ phaseIsLiquid, phaseIsUndetermined, phaseIsIce /))) then 
+             if (retrievedPhase(i) == phaseIsLiquid .OR. retrievedPhase(i) == phaseIsUndetermined) then
+                predicted_Refl_nir(1:num_trial_res) = two_stream_reflectance(retrievedTau(i), &
+                     g_w(1:num_trial_res), w0_w(1:num_trial_res))
+                retrievedSize(i) = 1.0e-06_wp*interpolate_to_min(trial_re_w(1:num_trial_res), &
+                     predicted_Refl_nir(1:num_trial_res), obs_Refl_nir)
+             else
+                predicted_Refl_nir(1:num_trial_res) = two_stream_reflectance(retrievedTau(i), &
+                     g_i(1:num_trial_res), w0_i(1:num_trial_res))
+                retrievedSize(i) = 1.0e-06_wp*interpolate_to_min(trial_re_i(1:num_trial_res), &
+                     predicted_Refl_nir(1:num_trial_res), obs_Refl_nir)
+             endif
+          else 
+             retrievedSize(i) = re_fill
+          endif
+       else   
+          ! Values when we don't think there's a cloud. 
+          retrievedCloudTopPressure(i) = R_UNDEF 
+          retrievedPhase(i)            = phaseIsNone
+          retrievedSize(i)             = R_UNDEF 
+          retrievedTau(i)              = R_UNDEF 
+       end if
+    end do
+    where((retrievedSize(1:nSubCols) < 0.).and.(retrievedSize(1:nSubCols) /= R_UNDEF)) &
+         retrievedSize(1:nSubCols) = 1.0e-06_wp*re_fill
+
+    ! We use the ISCCP-derived CTP for low clouds, since the ISCCP simulator ICARUS 
+    ! mimics what MODIS does to first order. 
+    ! Of course, ISCCP cloud top pressures are in mb.   
+    where(cloudMask(1:nSubCols) .and. retrievedCloudTopPressure(1:nSubCols) > CO2Slicing_PressureLimit) &
+         retrievedCloudTopPressure(1:nSubCols) = isccpCloudTopPressure! * 100._wp
+    
+  end subroutine modis_subcolumn
+
+  ! ########################################################################################
+  subroutine modis_column(nPoints,nSubCols,phase, cloud_top_pressure, optical_thickness, particle_size,     &
+       Cloud_Fraction_Total_Mean,         Cloud_Fraction_Water_Mean,         Cloud_Fraction_Ice_Mean,        &
+       Cloud_Fraction_High_Mean,          Cloud_Fraction_Mid_Mean,           Cloud_Fraction_Low_Mean,        &
+       Optical_Thickness_Total_Mean,      Optical_Thickness_Water_Mean,      Optical_Thickness_Ice_Mean,     &
+       Optical_Thickness_Total_MeanLog10, Optical_Thickness_Water_MeanLog10, Optical_Thickness_Ice_MeanLog10,&
+       Cloud_Particle_Size_Water_Mean,    Cloud_Particle_Size_Ice_Mean,      Cloud_Top_Pressure_Total_Mean,  &
+       Liquid_Water_Path_Mean,            Ice_Water_Path_Mean,                                               &    
+       Optical_Thickness_vs_Cloud_Top_Pressure,Optical_Thickness_vs_ReffIce,Optical_Thickness_vs_ReffLiq)
+    
+    ! INPUTS
+    integer,intent(in) :: &
+         nPoints,                           & ! Number of horizontal gridpoints
+         nSubCols                             ! Number of subcolumns
+    integer,intent(in), dimension(nPoints, nSubCols) ::  &
+         phase                             
+    real(wp),intent(in),dimension(nPoints, nSubCols) ::  &
+         cloud_top_pressure,                &
+         optical_thickness,                 &
+         particle_size
+ 
+    ! OUTPUTS 
+    real(wp),intent(inout),dimension(nPoints)  ::   & !
+         Cloud_Fraction_Total_Mean,         & !
+         Cloud_Fraction_Water_Mean,         & !
+         Cloud_Fraction_Ice_Mean,           & !
+         Cloud_Fraction_High_Mean,          & !
+         Cloud_Fraction_Mid_Mean,           & !
+         Cloud_Fraction_Low_Mean,           & !
+         Optical_Thickness_Total_Mean,      & !
+         Optical_Thickness_Water_Mean,      & !
+         Optical_Thickness_Ice_Mean,        & !
+         Optical_Thickness_Total_MeanLog10, & !
+         Optical_Thickness_Water_MeanLog10, & !
+         Optical_Thickness_Ice_MeanLog10,   & !
+         Cloud_Particle_Size_Water_Mean,    & !
+         Cloud_Particle_Size_Ice_Mean,      & !
+         Cloud_Top_Pressure_Total_Mean,     & !
+         Liquid_Water_Path_Mean,            & !
+         Ice_Water_Path_Mean                  !
+    real(wp),intent(inout),dimension(nPoints,numMODISTauBins,numMODISPresBins) :: &
+         Optical_Thickness_vs_Cloud_Top_Pressure
+    real(wp),intent(inout),dimension(nPoints,numMODISTauBins,numMODISReffIceBins) :: &    
+         Optical_Thickness_vs_ReffIce
+    real(wp),intent(inout),dimension(nPoints,numMODISTauBins,numMODISReffLiqBins) :: &    
+         Optical_Thickness_vs_ReffLiq         
+
+    ! LOCAL VARIABLES
+    real(wp), parameter :: &
+         LWP_conversion = 2._wp/3._wp * 1000._wp ! MKS units  
+    integer :: j
+    logical, dimension(nPoints,nSubCols) :: &
+         cloudMask,      &
+         waterCloudMask, &
+         iceCloudMask,   &
+         validRetrievalMask
+    real(wp),dimension(nPoints,nSubCols) :: &
+         tauWRK,ctpWRK,reffIceWRK,reffLiqWRK
+
+    ! ########################################################################################
+    ! Include only those pixels with successful retrievals in the statistics 
+    ! ########################################################################################
+    validRetrievalMask(1:nPoints,1:nSubCols) = particle_size(1:nPoints,1:nSubCols) > 0.
+    cloudMask(1:nPoints,1:nSubCols) = phase(1:nPoints,1:nSubCols) /= phaseIsNone .and.       &
+         validRetrievalMask(1:nPoints,1:nSubCols)
+    waterCloudMask(1:nPoints,1:nSubCols) = phase(1:nPoints,1:nSubCols) == phaseIsLiquid .and. &
+         validRetrievalMask(1:nPoints,1:nSubCols)
+    iceCloudMask(1:nPoints,1:nSubCols)   = phase(1:nPoints,1:nSubCols) == phaseIsIce .and.    &
+         validRetrievalMask(1:nPoints,1:nSubCols)
+    
+    ! ########################################################################################
+    ! Use these as pixel counts at first 
+    ! ########################################################################################
+    Cloud_Fraction_Total_Mean(1:nPoints) = real(count(cloudMask,      dim = 2))
+    Cloud_Fraction_Water_Mean(1:nPoints) = real(count(waterCloudMask, dim = 2))
+    Cloud_Fraction_Ice_Mean(1:nPoints)   = real(count(iceCloudMask,   dim = 2))
+    Cloud_Fraction_High_Mean(1:nPoints)  = real(count(cloudMask .and. cloud_top_pressure <=          &
+                                           highCloudPressureLimit, dim = 2)) 
+    Cloud_Fraction_Low_Mean(1:nPoints)   = real(count(cloudMask .and. cloud_top_pressure >           &
+                                           lowCloudPressureLimit,  dim = 2)) 
+    Cloud_Fraction_Mid_Mean(1:nPoints)   = Cloud_Fraction_Total_Mean(1:nPoints) - Cloud_Fraction_High_Mean(1:nPoints)&
+                                           - Cloud_Fraction_Low_Mean(1:nPoints)
+
+    ! ########################################################################################
+    ! Compute column amounts.
+    ! ########################################################################################
+    where(Cloud_Fraction_Total_Mean(1:nPoints) > 0)
+       Optical_Thickness_Total_Mean(1:nPoints) = sum(optical_thickness, mask = cloudMask,      dim = 2) / &
+            Cloud_Fraction_Total_Mean(1:nPoints)
+       Optical_Thickness_Total_MeanLog10(1:nPoints) = sum(log10(abs(optical_thickness)), mask = cloudMask, &
+            dim = 2) / Cloud_Fraction_Total_Mean(1:nPoints)
+    elsewhere
+       Optical_Thickness_Total_Mean      = R_UNDEF
+       Optical_Thickness_Total_MeanLog10 = R_UNDEF
+    endwhere
+    where(Cloud_Fraction_Water_Mean(1:nPoints) > 0)
+       Optical_Thickness_Water_Mean(1:nPoints) = sum(optical_thickness, mask = waterCloudMask, dim = 2) / &
+            Cloud_Fraction_Water_Mean(1:nPoints)
+       Liquid_Water_Path_Mean(1:nPoints) = LWP_conversion*sum(particle_size*optical_thickness, &
+            mask=waterCloudMask,dim=2)/Cloud_Fraction_Water_Mean(1:nPoints)
+       Optical_Thickness_Water_MeanLog10(1:nPoints) = sum(log10(abs(optical_thickness)), mask = waterCloudMask,&
+            dim = 2) / Cloud_Fraction_Water_Mean(1:nPoints)
+       Cloud_Particle_Size_Water_Mean(1:nPoints) = sum(particle_size, mask = waterCloudMask, dim = 2) / &
+            Cloud_Fraction_Water_Mean(1:nPoints)
+    elsewhere
+       Optical_Thickness_Water_Mean      = R_UNDEF
+       Optical_Thickness_Water_MeanLog10 = R_UNDEF
+       Cloud_Particle_Size_Water_Mean    = R_UNDEF
+       Liquid_Water_Path_Mean            = R_UNDEF
+    endwhere
+    where(Cloud_Fraction_Ice_Mean(1:nPoints) > 0)
+       Optical_Thickness_Ice_Mean(1:nPoints)   = sum(optical_thickness, mask = iceCloudMask,   dim = 2) / &
+            Cloud_Fraction_Ice_Mean(1:nPoints)
+       Ice_Water_Path_Mean(1:nPoints) = LWP_conversion * ice_density*sum(particle_size*optical_thickness,&
+            mask=iceCloudMask,dim = 2) /Cloud_Fraction_Ice_Mean(1:nPoints) 
+       Optical_Thickness_Ice_MeanLog10(1:nPoints) = sum(log10(abs(optical_thickness)), mask = iceCloudMask,&
+            dim = 2) / Cloud_Fraction_Ice_Mean(1:nPoints)
+       Cloud_Particle_Size_Ice_Mean(1:nPoints) = sum(particle_size, mask = iceCloudMask,   dim = 2) / &
+            Cloud_Fraction_Ice_Mean(1:nPoints)    
+    elsewhere
+       Optical_Thickness_Ice_Mean        = R_UNDEF
+       Optical_Thickness_Ice_MeanLog10   = R_UNDEF
+       Cloud_Particle_Size_Ice_Mean      = R_UNDEF
+       Ice_Water_Path_Mean               = R_UNDEF
+    endwhere
+    Cloud_Top_Pressure_Total_Mean  = sum(cloud_top_pressure, mask = cloudMask, dim = 2) / &
+                                     max(1, count(cloudMask, dim = 2))
+
+    ! ########################################################################################
+    ! Normalize pixel counts to fraction. 
+    ! ########################################################################################
+    Cloud_Fraction_High_Mean(1:nPoints)  = Cloud_Fraction_High_Mean(1:nPoints)  /nSubcols
+    Cloud_Fraction_Mid_Mean(1:nPoints)   = Cloud_Fraction_Mid_Mean(1:nPoints)   /nSubcols
+    Cloud_Fraction_Low_Mean(1:nPoints)   = Cloud_Fraction_Low_Mean(1:nPoints)   /nSubcols
+    Cloud_Fraction_Total_Mean(1:nPoints) = Cloud_Fraction_Total_Mean(1:nPoints) /nSubcols
+    Cloud_Fraction_Ice_Mean(1:nPoints)   = Cloud_Fraction_Ice_Mean(1:nPoints)   /nSubcols
+    Cloud_Fraction_Water_Mean(1:nPoints) = Cloud_Fraction_Water_Mean(1:nPoints) /nSubcols
+    
+    ! ########################################################################################
+    ! Joint histograms
+    ! ########################################################################################
+    ! Loop over all points
+    tauWRK(1:nPoints,1:nSubCols)     = optical_thickness(1:nPoints,1:nSubCols)
+    ctpWRK(1:nPoints,1:nSubCols)     = cloud_top_pressure(1:nPoints,1:nSubCols)
+    reffIceWRK(1:nPoints,1:nSubCols) = merge(particle_size,R_UNDEF,iceCloudMask)
+    reffLiqWRK(1:nPoints,1:nSubCols) = merge(particle_size,R_UNDEF,waterCloudMask)
+    do j=1,nPoints
+
+       ! Fill clear and optically thin subcolumns with fill
+       where(.not. cloudMask(j,1:nSubCols)) 
+          tauWRK(j,1:nSubCols) = -999._wp
+          ctpWRK(j,1:nSubCols) = -999._wp
+       endwhere
+       ! Joint histogram of tau/CTP
+       call hist2D(tauWRK(j,1:nSubCols),ctpWRK(j,1:nSubCols),nSubCols,&
+                   modis_histTau,numMODISTauBins,&
+                   modis_histPres,numMODISPresBins,&
+                   Optical_Thickness_vs_Cloud_Top_Pressure(j,1:numMODISTauBins,1:numMODISPresBins))
+       ! Joint histogram of tau/ReffICE
+       call hist2D(tauWRK(j,1:nSubCols),reffIceWrk(j,1:nSubCols),nSubCols,               &
+                   modis_histTau,numMODISTauBins,modis_histReffIce,         &
+                   numMODISReffIceBins, Optical_Thickness_vs_ReffIce(j,1:numMODISTauBins,1:numMODISReffIceBins))
+       ! Joint histogram of tau/ReffLIQ
+       call hist2D(tauWRK(j,1:nSubCols),reffLiqWrk(j,1:nSubCols),nSubCols,               &
+                   modis_histTau,numMODISTauBins,modis_histReffLiq,         &
+                   numMODISReffLiqBins, Optical_Thickness_vs_ReffLiq(j,1:numMODISTauBins,1:numMODISReffLiqBins))                   
+
+    enddo   
+    Optical_Thickness_vs_Cloud_Top_Pressure(1:nPoints,1:numMODISTauBins,1:numMODISPresBins) = &
+         Optical_Thickness_vs_Cloud_Top_Pressure(1:nPoints,1:numMODISTauBins,1:numMODISPresBins)/nSubCols
+    Optical_Thickness_vs_ReffIce(1:nPoints,1:numMODISTauBins,1:numMODISReffIceBins) = &
+         Optical_Thickness_vs_ReffIce(1:nPoints,1:numMODISTauBins,1:numMODISReffIceBins)/nSubCols
+    Optical_Thickness_vs_ReffLiq(1:nPoints,1:numMODISTauBins,1:numMODISReffLiqBins) = &
+         Optical_Thickness_vs_ReffLiq(1:nPoints,1:numMODISTauBins,1:numMODISReffLiqBins)/nSubCols 
+                 
+
+    ! Unit conversion
+    where(Optical_Thickness_vs_Cloud_Top_Pressure /= R_UNDEF) &
+      Optical_Thickness_vs_Cloud_Top_Pressure = Optical_Thickness_vs_Cloud_Top_Pressure*100._wp
+    where(Optical_Thickness_vs_ReffIce /= R_UNDEF) Optical_Thickness_vs_ReffIce = Optical_Thickness_vs_ReffIce*100._wp
+    where(Optical_Thickness_vs_ReffLiq /= R_UNDEF) Optical_Thickness_vs_ReffLiq = Optical_Thickness_vs_ReffLiq*100._wp
+    where(Cloud_Fraction_Total_Mean /= R_UNDEF) Cloud_Fraction_Total_Mean = Cloud_Fraction_Total_Mean*100._wp
+    where(Cloud_Fraction_Water_Mean /= R_UNDEF) Cloud_Fraction_Water_Mean = Cloud_Fraction_Water_Mean*100._wp
+    where(Cloud_Fraction_Ice_Mean /= R_UNDEF)   Cloud_Fraction_Ice_Mean = Cloud_Fraction_Ice_Mean*100._wp
+    where(Cloud_Fraction_High_Mean /= R_UNDEF)  Cloud_Fraction_High_Mean = Cloud_Fraction_High_Mean*100._wp
+    where(Cloud_Fraction_Mid_Mean /= R_UNDEF)   Cloud_Fraction_Mid_Mean = Cloud_Fraction_Mid_Mean*100._wp
+    where(Cloud_Fraction_Low_Mean /= R_UNDEF)   Cloud_Fraction_Low_Mean = Cloud_Fraction_Low_Mean*100._wp
+
+  end subroutine modis_column
+
+  ! ########################################################################################
+  function cloud_top_pressure(nLevels,tauIncrement, pressure, tauLimit) 
+    ! INPUTS
+    integer, intent(in)                    :: nLevels
+    real(wp),intent(in),dimension(nLevels) :: tauIncrement, pressure
+    real(wp),intent(in)                    :: tauLimit
+    ! OUTPUTS
+    real(wp)                               :: cloud_top_pressure
+    ! LOCAL VARIABLES
+    real(wp)                               :: deltaX, totalTau, totalProduct
+    integer                                :: i 
+    
+    ! Find the extinction-weighted pressure. Assume that pressure varies linearly between 
+    !   layers and use the trapezoidal rule.
+    totalTau = 0._wp; totalProduct = 0._wp
+    do i = 2, size(tauIncrement)
+      if(totalTau + tauIncrement(i) > tauLimit) then 
+        deltaX = tauLimit - totalTau
+        totalTau = totalTau + deltaX
+        !
+        ! Result for trapezoidal rule when you take less than a full step
+        !   tauIncrement is a layer-integrated value
+        !
+        totalProduct = totalProduct           &
+                     + pressure(i-1) * deltaX &
+                     + (pressure(i) - pressure(i-1)) * deltaX**2/(2._wp * tauIncrement(i)) 
+      else
+        totalTau =     totalTau     + tauIncrement(i) 
+        totalProduct = totalProduct + tauIncrement(i) * (pressure(i) + pressure(i-1)) / 2._wp
+      end if 
+      if(totalTau >= tauLimit) exit
+    end do 
+
+    if (totalTau > 0._wp) then
+       cloud_top_pressure = totalProduct/totalTau
+    else
+       cloud_top_pressure = 0._wp
+    endif
+    
+  end function cloud_top_pressure
+
+  ! ########################################################################################
+  function weight_by_extinction(nLevels,tauIncrement, f, tauLimit) 
+    ! INPUTS
+    integer, intent(in)                    :: nLevels
+    real(wp),intent(in),dimension(nLevels) :: tauIncrement, f
+    real(wp),intent(in)                    :: tauLimit
+    ! OUTPUTS
+    real(wp)                               :: weight_by_extinction
+    ! LOCAL VARIABLES
+    real(wp)                               :: deltaX, totalTau, totalProduct
+    integer                                :: i 
+    
+    ! Find the extinction-weighted value of f(tau), assuming constant f within each layer
+    totalTau = 0._wp; totalProduct = 0._wp
+    do i = 1, size(tauIncrement)
+      if(totalTau + tauIncrement(i) > tauLimit) then 
+        deltaX       = tauLimit - totalTau
+        totalTau     = totalTau     + deltaX
+        totalProduct = totalProduct + deltaX * f(i) 
+      else
+        totalTau     = totalTau     + tauIncrement(i) 
+        totalProduct = totalProduct + tauIncrement(i) * f(i) 
+      end if 
+      if(totalTau >= tauLimit) exit
+    end do 
+
+    if (totalTau > 0._wp) then
+       weight_by_extinction = totalProduct/totalTau
+    else
+       weight_by_extinction = 0._wp
+    endif
+    
+  end function weight_by_extinction
+
+  ! ########################################################################################
+  pure function interpolate_to_min(x, y, yobs)
+    ! INPUTS
+    real(wp),intent(in),dimension(num_trial_res) :: x, y 
+    real(wp),intent(in)                          :: yobs
+    ! OUTPUTS
+    real(wp)                                     :: interpolate_to_min
+    ! LOCAL VARIABLES
+    real(wp), dimension(num_trial_res)           :: diff
+    integer                                      :: nPoints, minDiffLoc, lowerBound, upperBound
+    
+    ! Given a set of values of y as y(x), find the value of x that minimizes abs(y - yobs)
+    !   y must be monotonic in x
+ 
+    nPoints = size(y)
+    diff(1:num_trial_res) = y(1:num_trial_res) - yobs
+    minDiffLoc = minloc(abs(diff), dim = 1) 
+    
+    if(minDiffLoc == 1) then 
+      lowerBound = minDiffLoc
+      upperBound = minDiffLoc + 1
+    else if(minDiffLoc == nPoints) then
+      lowerBound = minDiffLoc - 1
+      upperBound = minDiffLoc
+    else
+      if(diff(minDiffLoc-1) * diff(minDiffLoc) < 0) then
+        lowerBound = minDiffLoc-1
+        upperBound = minDiffLoc
+      else 
+        lowerBound = minDiffLoc
+        upperBound = minDiffLoc + 1
+      end if 
+    end if 
+    
+    if(diff(lowerBound) * diff(upperBound) < 0) then     
+      !
+      ! Interpolate the root position linearly if we bracket the root
+      !
+      interpolate_to_min = x(upperBound) - & 
+                           diff(upperBound) * (x(upperBound) - x(lowerBound)) / (diff(upperBound) - diff(lowerBound))
+    else 
+      interpolate_to_min = re_fill
+    end if 
+    
+
+  end function interpolate_to_min
+
+  ! ########################################################################################
+  ! Optical properties
+  ! ########################################################################################
+  elemental function get_g_nir_old (phase, re)
+    ! Polynomial fit for asummetry parameter g in MODIS band 7 (near IR) as a function 
+    !   of size for ice and water
+    ! Fits from Steve Platnick
+
+    ! INPUTS
+    integer, intent(in) :: phase
+    real(wp),intent(in) :: re
+    ! OUTPUTS
+    real(wp)            :: get_g_nir_old 
+    ! LOCAL VARIABLES(parameters)
+    real(wp), dimension(3), parameter :: &
+         ice_coefficients         = (/ 0.7432,  4.5563e-3, -2.8697e-5 /), & 
+         small_water_coefficients = (/ 0.8027, -1.0496e-2,  1.7071e-3 /), & 
+         big_water_coefficients   = (/ 0.7931,  5.3087e-3, -7.4995e-5 /) 
+   
+    ! approx. fits from MODIS Collection 5 LUT scattering calculations
+    if(phase == phaseIsLiquid) then
+      if(re < 8.) then 
+        get_g_nir_old = fit_to_quadratic(re, small_water_coefficients)
+        if(re < re_water_min) get_g_nir_old = fit_to_quadratic(re_water_min, small_water_coefficients)
+      else
+        get_g_nir_old = fit_to_quadratic(re,   big_water_coefficients)
+        if(re > re_water_max) get_g_nir_old = fit_to_quadratic(re_water_max, big_water_coefficients)
+      end if 
+    else
+      get_g_nir_old = fit_to_quadratic(re, ice_coefficients)
+      if(re < re_ice_min) get_g_nir_old = fit_to_quadratic(re_ice_min, ice_coefficients)
+      if(re > re_ice_max) get_g_nir_old = fit_to_quadratic(re_ice_max, ice_coefficients)
+    end if 
+    
+  end function get_g_nir_old
+
+  ! ########################################################################################
+  elemental function get_ssa_nir_old (phase, re)
+    ! Polynomial fit for single scattering albedo in MODIS band 7 (near IR) as a function 
+    !   of size for ice and water
+    ! Fits from Steve Platnick
+    
+    ! INPUTS
+    integer, intent(in) :: phase
+    real(wp),intent(in) :: re
+    ! OUTPUTS
+    real(wp)            :: get_ssa_nir_old
+    ! LOCAL VARIABLES (parameters)
+    real(wp), dimension(4), parameter :: ice_coefficients   = (/ 0.9994, -4.5199e-3, 3.9370e-5, -1.5235e-7 /)
+    real(wp), dimension(3), parameter :: water_coefficients = (/ 1.0008, -2.5626e-3, 1.6024e-5 /) 
+    
+    ! approx. fits from MODIS Collection 5 LUT scattering calculations
+    if(phase == phaseIsLiquid) then
+       get_ssa_nir_old = fit_to_quadratic(re, water_coefficients)
+       if(re < re_water_min) get_ssa_nir_old = fit_to_quadratic(re_water_min, water_coefficients)
+       if(re > re_water_max) get_ssa_nir_old = fit_to_quadratic(re_water_max, water_coefficients)
+    else
+       get_ssa_nir_old = fit_to_cubic(re, ice_coefficients)
+       if(re < re_ice_min) get_ssa_nir_old = fit_to_cubic(re_ice_min, ice_coefficients)
+       if(re > re_ice_max) get_ssa_nir_old = fit_to_cubic(re_ice_max, ice_coefficients)
+    end if
+    
+  end function get_ssa_nir_old
+  
+  elemental function get_g_nir (phase, re)
+    !
+    ! Polynomial fit for asummetry parameter g in MODIS band 7 (near IR) as a function 
+    !   of size for ice and water
+    ! Fits from Steve Platnick
+    !
+
+    integer, intent(in) :: phase
+    real(wp),    intent(in) :: re
+    real(wp) :: get_g_nir 
+
+    real(wp), dimension(3), parameter :: ice_coefficients         = (/ 0.7490, 6.5153e-3, -5.4136e-5 /), &
+                                         small_water_coefficients = (/ 1.0364, -8.8800e-2, 7.0000e-3 /)
+    real(wp), dimension(4), parameter :: big_water_coefficients   = (/ 0.6035, 2.8993e-2, -1.1051e-3, 1.5134e-5 /)
+
+    ! approx. fits from MODIS Collection 6 LUT scattering calculations for 3.7 µm channel size retrievals
+    if(phase == phaseIsLiquid) then 
+       if(re < 7.) then
+          get_g_nir = fit_to_quadratic(re, small_water_coefficients)
+          if(re < re_water_min) get_g_nir = fit_to_quadratic(re_water_min, small_water_coefficients)
+       else
+          get_g_nir = fit_to_cubic(re, big_water_coefficients)
+          if(re > re_water_max) get_g_nir = fit_to_cubic(re_water_max, big_water_coefficients)
+       end if
+    else
+       get_g_nir = fit_to_quadratic(re, ice_coefficients)
+      if(re < re_ice_min) get_g_nir = fit_to_quadratic(re_ice_min, ice_coefficients)
+      if(re > re_ice_max) get_g_nir = fit_to_quadratic(re_ice_max, ice_coefficients)
+    end if 
+    
+  end function get_g_nir
+
+  ! --------------------------------------------
+    elemental function get_ssa_nir (phase, re)
+        integer, intent(in) :: phase
+        real(wp),    intent(in) :: re
+        real(wp)                :: get_ssa_nir
+        !
+        ! Polynomial fit for single scattering albedo in MODIS band 7 (near IR) as a function 
+        !   of size for ice and water
+        ! Fits from Steve Platnick
+        !
+        real(wp), dimension(4), parameter :: ice_coefficients   = (/ 0.9625, -1.8069e-2, 3.3281e-4,-2.2865e-6/)
+        real(wp), dimension(3), parameter :: water_coefficients = (/ 1.0044, -1.1397e-2, 1.3300e-4 /)
+        
+        ! approx. fits from MODIS Collection 6 LUT scattering calculations
+        if(phase == phaseIsLiquid) then
+          get_ssa_nir = fit_to_quadratic(re, water_coefficients)
+          if(re < re_water_min) get_ssa_nir = fit_to_quadratic(re_water_min, water_coefficients)
+          if(re > re_water_max) get_ssa_nir = fit_to_quadratic(re_water_max, water_coefficients)
+        else
+          get_ssa_nir = fit_to_cubic(re, ice_coefficients)
+          if(re < re_ice_min) get_ssa_nir = fit_to_cubic(re_ice_min, ice_coefficients)
+          if(re > re_ice_max) get_ssa_nir = fit_to_cubic(re_ice_max, ice_coefficients)
+        end if 
+
+    end function get_ssa_nir
+
+  
+
+  ! ########################################################################################
+  pure function fit_to_cubic(x, coefficients) 
+    ! INPUTS
+    real(wp),               intent(in) :: x
+    real(wp), dimension(4), intent(in) :: coefficients
+    ! OUTPUTS
+    real(wp)                           :: fit_to_cubic  
+    
+    fit_to_cubic = coefficients(1) + x * (coefficients(2) + x * (coefficients(3) + x * coefficients(4)))
+  end function fit_to_cubic
+    
+  ! ########################################################################################
+  pure function fit_to_quadratic(x, coefficients) 
+    ! INPUTS
+    real(wp),               intent(in) :: x
+    real(wp), dimension(3), intent(in) :: coefficients
+    ! OUTPUTS
+    real(wp)                           :: fit_to_quadratic
+    
+    fit_to_quadratic = coefficients(1) + x * (coefficients(2) + x * (coefficients(3)))
+  end function fit_to_quadratic
+
+  ! ########################################################################################
+  ! Radiative transfer
+  ! ########################################################################################
+  pure function compute_toa_reflectace(nLevels,tau, g, w0)
+    ! This wrapper reports reflectance only and strips out non-cloudy elements from the 
+    ! calculation
+    
+    ! INPUTS
+    integer,intent(in)                     :: nLevels
+    real(wp),intent(in),dimension(nLevels) :: tau, g, w0
+    ! OUTPUTS
+    real(wp)                               :: compute_toa_reflectace
+    ! LOCAL VARIABLES
+    logical, dimension(nLevels)                   :: cloudMask
+    integer, dimension(count(tau(1:nLevels) > 0)) :: cloudIndicies
+    real(wp),dimension(count(tau(1:nLevels) > 0)) :: Refl,Trans
+    real(wp)                                      :: Refl_tot, Trans_tot
+    integer                                       :: i
+
+    cloudMask(1:nLevels) = tau(1:nLevels) > 0. 
+    cloudIndicies = pack((/ (i, i = 1, nLevels) /), mask = cloudMask) 
+    do i = 1, size(cloudIndicies)
+       call two_stream(tau(cloudIndicies(i)), g(cloudIndicies(i)), w0(cloudIndicies(i)), Refl(i), Trans(i))
+    end do
+    
+    call adding_doubling(count(tau(1:nLevels) > 0),Refl(:), Trans(:), Refl_tot, Trans_tot)  
+    
+    compute_toa_reflectace = Refl_tot
+    
+  end function compute_toa_reflectace
+ 
+  ! ########################################################################################
+  pure subroutine two_stream(tauint, gint, w0int, ref, tra) 
+    ! Compute reflectance in a single layer using the two stream approximation 
+    !   The code itself is from Lazaros Oreopoulos via Steve Platnick 
+    ! INPUTS
+    real(wp), intent(in)  :: tauint, gint, w0int
+    ! OUTPUTS
+    real(wp), intent(out) :: ref, tra
+    ! LOCAL VARIABLES
+    !   for delta Eddington code
+    !   xmu, gamma3, and gamma4 only used for collimated beam approximation (i.e., beam=1)
+    integer, parameter :: beam = 2
+    real(wp),parameter :: xmu = 0.866, minConservativeW0 = 0.9999999
+    real(wp) :: tau, w0, g, f, gamma1, gamma2, gamma3, gamma4, &
+         rh, a1, a2, rk, r1, r2, r3, r4, r5, t1, t2, t3, t4, t5, beta, e1, e2, ef1, ef2, den, th
+    
+    ! Compute reflectance and transmittance in a single layer using the two stream approximation 
+    !   The code itself is from Lazaros Oreopoulos via Steve Platnick 
+    f   = gint**2
+    tau = (1._wp - w0int * f) * tauint
+    w0  = (1._wp - f) * w0int / (1._wp - w0int * f)
+    g   = (gint - f) / (1._wp - f)
+
+    ! delta-Eddington (Joseph et al. 1976)
+    gamma1 =  (7._wp - w0* (4._wp + 3._wp * g)) / 4._wp
+    gamma2 = -(1._wp - w0* (4._wp - 3._wp * g)) / 4._wp
+    gamma3 =  (2._wp - 3._wp*g*xmu) / 4._wp
+    gamma4 =   1._wp - gamma3
+
+    if (w0int > minConservativeW0) then
+      ! Conservative scattering
+      if (beam == 1) then
+          rh = (gamma1*tau+(gamma3-gamma1*xmu)*(1-exp(-tau/xmu)))
+  
+          ref = rh / (1._wp + gamma1 * tau)
+          tra = 1._wp - ref       
+      else if(beam == 2) then
+          ref = gamma1*tau/(1._wp + gamma1*tau)
+          tra = 1._wp - ref
+      endif
+    else
+      ! Non-conservative scattering
+      a1 = gamma1 * gamma4 + gamma2 * gamma3
+      a2 = gamma1 * gamma3 + gamma2 * gamma4
+
+      rk = sqrt(gamma1**2 - gamma2**2)
+      
+      r1 = (1._wp - rk * xmu) * (a2 + rk * gamma3)
+      r2 = (1._wp + rk * xmu) * (a2 - rk * gamma3)
+      r3 = 2._wp * rk *(gamma3 - a2 * xmu)
+      r4 = (1._wp - (rk * xmu)**2) * (rk + gamma1)
+      r5 = (1._wp - (rk * xmu)**2) * (rk - gamma1)
+      
+      t1 = (1._wp + rk * xmu) * (a1 + rk * gamma4)
+      t2 = (1._wp - rk * xmu) * (a1 - rk * gamma4)
+      t3 = 2._wp * rk * (gamma4 + a1 * xmu)
+      t4 = r4
+      t5 = r5
+
+      beta = -r5 / r4         
+  
+      e1 = min(rk * tau, 500._wp) 
+      e2 = min(tau / xmu, 500._wp) 
+      
+      if (beam == 1) then
+         den = r4 * exp(e1) + r5 * exp(-e1)
+         ref  = w0*(r1*exp(e1)-r2*exp(-e1)-r3*exp(-e2))/den
+         den = t4 * exp(e1) + t5 * exp(-e1)
+         th  = exp(-e2)
+         tra = th-th*w0*(t1*exp(e1)-t2*exp(-e1)-t3*exp(e2))/den
+      elseif (beam == 2) then
+         ef1 = exp(-e1)
+         ef2 = exp(-2*e1)
+         ref = (gamma2*(1._wp-ef2))/((rk+gamma1)*(1._wp-beta*ef2))
+         tra = (2._wp*rk*ef1)/((rk+gamma1)*(1._wp-beta*ef2))
+      endif
+    end if
+  end subroutine two_stream
+
+  ! ########################################################################################
+  elemental function two_stream_reflectance(tauint, gint, w0int)
+    ! Compute reflectance in a single layer using the two stream approximation 
+    !   The code itself is from Lazaros Oreopoulos via Steve Platnick 
+    
+    ! INPUTS
+    real(wp), intent(in) :: tauint, gint, w0int
+    ! OUTPUTS
+    real(wp)             :: two_stream_reflectance
+    ! LOCAL VARIABLES
+    !   for delta Eddington code
+    !   xmu, gamma3, and gamma4 only used for collimated beam approximation (i.e., beam=1)
+    integer, parameter :: beam = 2
+    real(wp),parameter :: xmu = 0.866, minConservativeW0 = 0.9999999
+    real(wp) :: tau, w0, g, f, gamma1, gamma2, gamma3, gamma4, &
+         rh, a1, a2, rk, r1, r2, r3, r4, r5, t1, t2, t3, t4, t5, beta, e1, e2, ef1, ef2, den
+
+    f   = gint**2
+    tau = (1._wp - w0int * f) * tauint
+    w0  = (1._wp - f) * w0int / (1._wp - w0int * f)
+    g   = (gint - f) / (1._wp - f)
+
+    ! delta-Eddington (Joseph et al. 1976)
+    gamma1 =  (7._wp - w0* (4._wp + 3._wp * g)) / 4._wp
+    gamma2 = -(1._wp - w0* (4._wp - 3._wp * g)) / 4._wp
+    gamma3 =  (2._wp - 3._wp*g*xmu) / 4._wp
+    gamma4 =   1._wp - gamma3
+
+    if (w0int > minConservativeW0) then
+      ! Conservative scattering
+      if (beam == 1) then
+          rh = (gamma1*tau+(gamma3-gamma1*xmu)*(1-exp(-tau/xmu)))
+          two_stream_reflectance = rh / (1._wp + gamma1 * tau)
+      elseif (beam == 2) then
+          two_stream_reflectance = gamma1*tau/(1._wp + gamma1*tau)
+      endif
+        
+    else    !
+
+        ! Non-conservative scattering
+         a1 = gamma1 * gamma4 + gamma2 * gamma3
+         a2 = gamma1 * gamma3 + gamma2 * gamma4
+
+         rk = sqrt(gamma1**2 - gamma2**2)
+         
+         r1 = (1._wp - rk * xmu) * (a2 + rk * gamma3)
+         r2 = (1._wp + rk * xmu) * (a2 - rk * gamma3)
+         r3 = 2._wp * rk *(gamma3 - a2 * xmu)
+         r4 = (1._wp - (rk * xmu)**2) * (rk + gamma1)
+         r5 = (1._wp - (rk * xmu)**2) * (rk - gamma1)
+         
+         t1 = (1._wp + rk * xmu) * (a1 + rk * gamma4)
+         t2 = (1._wp - rk * xmu) * (a1 - rk * gamma4)
+         t3 = 2._wp * rk * (gamma4 + a1 * xmu)
+         t4 = r4
+         t5 = r5
+
+         beta = -r5 / r4         
+         
+         e1 = min(rk * tau, 500._wp) 
+         e2 = min(tau / xmu, 500._wp) 
+         
+         if (beam == 1) then
+           den = r4 * exp(e1) + r5 * exp(-e1)
+           two_stream_reflectance  = w0*(r1*exp(e1)-r2*exp(-e1)-r3*exp(-e2))/den
+         elseif (beam == 2) then
+           ef1 = exp(-e1)
+           ef2 = exp(-2*e1)
+           two_stream_reflectance = (gamma2*(1._wp-ef2))/((rk+gamma1)*(1._wp-beta*ef2))
+         endif
+           
+      end if
+  end function two_stream_reflectance 
+
+  ! ########################################################################################
+  pure subroutine adding_doubling (npts,Refl, Tran, Refl_tot, Tran_tot)      
+    ! Use adding/doubling formulas to compute total reflectance and transmittance from 
+    ! layer values
+    
+    ! INPUTS
+    integer,intent(in)                  :: npts
+    real(wp),intent(in),dimension(npts) :: Refl,Tran
+    ! OUTPUTS
+    real(wp),intent(out)                :: Refl_tot, Tran_tot
+    ! LOCAL VARIABLES
+    integer :: i
+    real(wp), dimension(npts) :: Refl_cumulative, Tran_cumulative
+    
+    Refl_cumulative(1) = Refl(1)
+    Tran_cumulative(1) = Tran(1)    
+    
+    do i=2, npts
+       ! place (add) previous combined layer(s) reflectance on top of layer i, w/black surface (or ignoring surface):
+       Refl_cumulative(i) = Refl_cumulative(i-1) + Refl(i)*(Tran_cumulative(i-1)**2)/(1._wp - Refl_cumulative(i-1) * Refl(i))
+       Tran_cumulative(i) = (Tran_cumulative(i-1)*Tran(i)) / (1._wp - Refl_cumulative(i-1) * Refl(i))
+    end do
+    
+    Refl_tot = Refl_cumulative(size(Refl))
+    Tran_tot = Tran_cumulative(size(Refl))
+    
+  end subroutine adding_doubling
+
+end module mod_modis_sim
Index: DZ6/trunk/libf/phylmd/cospv2/mrgrnk.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cospv2/mrgrnk.F90	(revision 5267)
+++ 	(revision )
@@ -1,645 +1,0 @@
-! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-! Copyright (c) 2015, Regents of the University of Colorado
-! All rights reserved.
-!
-! Redistribution and use in source and binary forms, with or without modification, are 
-! permitted provided that the following conditions are met:
-!
-! 1. Redistributions of source code must retain the above copyright notice, this list of 
-!    conditions and the following disclaimer.
-!
-! 2. Redistributions in binary form must reproduce the above copyright notice, this list
-!    of conditions and the following disclaimer in the documentation and/or other 
-!    materials provided with the distribution.
-!
-! 3. Neither the name of the copyright holder nor the names of its contributors may be 
-!    used to endorse or promote products derived from this software without specific prior
-!    written permission.
-!
-! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY 
-! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 
-! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL 
-! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 
-! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT 
-! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 
-! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
-! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-!
-! History:
-! May 2015:  Dustin Swales    - Modified for COSPv2.0
-! 
-! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 
-Module m_mrgrnk
-  USE COSP_KINDS,          ONLY: wp
-  Integer, Parameter :: kdp = selected_real_kind(15)
-  public :: mrgrnk
-  private :: kdp
-  private :: R_mrgrnk, I_mrgrnk, D_mrgrnk
-
-  interface mrgrnk
-!     module procedure D_mrgrnk, R_mrgrnk, I_mrgrnk
-     module procedure R_mrgrnk, I_mrgrnk
-     
-  end interface
-contains
-  
-  Subroutine D_mrgrnk (XDONT, IRNGT)
-    ! __________________________________________________________
-    ! MRGRNK = Merge-sort ranking of an array
-    ! For performance reasons, the first 2 passes are taken
-    ! out of the standard loop, and use dedicated coding.
-    ! __________________________________________________________
-    ! __________________________________________________________
-    Real (wp), Dimension (:), Intent (In) :: XDONT
-    Integer, Dimension (:), Intent (Out) :: IRNGT
-    ! __________________________________________________________
-    Real (wp) :: XVALA, XVALB
-    !
-    Integer, Dimension (SIZE(IRNGT)) :: JWRKT
-    Integer :: LMTNA, LMTNC, IRNG1, IRNG2
-    Integer :: NVAL, IIND, IWRKD, IWRK, IWRKF, JINDA, IINDA, IINDB
-    !
-    NVAL = Min (SIZE(XDONT), SIZE(IRNGT))
-    Select Case (NVAL)
-    Case (:0)
-       Return
-    Case (1)
-       IRNGT (1) = 1
-       Return
-    Case Default
-       Continue
-    End Select
-    !
-    ! Fill-in the index array, creating ordered couples
-    !
-    Do IIND = 2, NVAL, 2
-       If (XDONT(IIND-1) <= XDONT(IIND)) Then
-          IRNGT (IIND-1) = IIND - 1
-          IRNGT (IIND) = IIND
-       Else
-          IRNGT (IIND-1) = IIND
-          IRNGT (IIND) = IIND - 1
-       End If
-    End Do
-    If (Modulo(NVAL, 2) /= 0) Then
-       IRNGT (NVAL) = NVAL
-    End If
-    !
-    ! We will now have ordered subsets A - B - A - B - ...
-    ! and merge A and B couples into C - C - ...
-    !
-    LMTNA = 2
-    LMTNC = 4
-    !
-    ! First iteration. The length of the ordered subsets goes from 2 to 4
-    !
-    Do
-       If (NVAL <= 2) Exit
-       !
-       ! Loop on merges of A and B into C
-       !
-       Do IWRKD = 0, NVAL - 1, 4
-          If ((IWRKD+4) > NVAL) Then
-             If ((IWRKD+2) >= NVAL) Exit
-             !
-             ! 1 2 3
-             !
-             If (XDONT(IRNGT(IWRKD+2)) <= XDONT(IRNGT(IWRKD+3))) Exit
-             !
-             ! 1 3 2
-             !
-             If (XDONT(IRNGT(IWRKD+1)) <= XDONT(IRNGT(IWRKD+3))) Then
-                IRNG2 = IRNGT (IWRKD+2)
-                IRNGT (IWRKD+2) = IRNGT (IWRKD+3)
-                IRNGT (IWRKD+3) = IRNG2
-                !
-                ! 3 1 2
-                !
-             Else
-                IRNG1 = IRNGT (IWRKD+1)
-                IRNGT (IWRKD+1) = IRNGT (IWRKD+3)
-                IRNGT (IWRKD+3) = IRNGT (IWRKD+2)
-                IRNGT (IWRKD+2) = IRNG1
-             End If
-             Exit
-          End If
-          !
-          ! 1 2 3 4
-          !
-          If (XDONT(IRNGT(IWRKD+2)) <= XDONT(IRNGT(IWRKD+3))) Cycle
-          !
-          ! 1 3 x x
-          !
-          If (XDONT(IRNGT(IWRKD+1)) <= XDONT(IRNGT(IWRKD+3))) Then
-             IRNG2 = IRNGT (IWRKD+2)
-             IRNGT (IWRKD+2) = IRNGT (IWRKD+3)
-             If (XDONT(IRNG2) <= XDONT(IRNGT(IWRKD+4))) Then
-                ! 1 3 2 4
-                IRNGT (IWRKD+3) = IRNG2
-             Else
-                ! 1 3 4 2
-                IRNGT (IWRKD+3) = IRNGT (IWRKD+4)
-                IRNGT (IWRKD+4) = IRNG2
-             End If
-             !
-             ! 3 x x x
-             !
-          Else
-             IRNG1 = IRNGT (IWRKD+1)
-             IRNG2 = IRNGT (IWRKD+2)
-             IRNGT (IWRKD+1) = IRNGT (IWRKD+3)
-             If (XDONT(IRNG1) <= XDONT(IRNGT(IWRKD+4))) Then
-                IRNGT (IWRKD+2) = IRNG1
-                If (XDONT(IRNG2) <= XDONT(IRNGT(IWRKD+4))) Then
-                   ! 3 1 2 4
-                   IRNGT (IWRKD+3) = IRNG2
-                Else
-                   ! 3 1 4 2
-                   IRNGT (IWRKD+3) = IRNGT (IWRKD+4)
-                   IRNGT (IWRKD+4) = IRNG2
-                End If
-             Else
-                ! 3 4 1 2
-                IRNGT (IWRKD+2) = IRNGT (IWRKD+4)
-                IRNGT (IWRKD+3) = IRNG1
-                IRNGT (IWRKD+4) = IRNG2
-             End If
-          End If
-       End Do
-       !
-       ! The Cs become As and Bs
-       !
-       LMTNA = 4
-       Exit
-    End Do
-    !
-    ! Iteration loop. Each time, the length of the ordered subsets
-    ! is doubled.
-    !
-    Do
-       If (LMTNA >= NVAL) Exit
-       IWRKF = 0
-       LMTNC = 2 * LMTNC
-       !
-       ! Loop on merges of A and B into C
-       !
-       Do
-          IWRK = IWRKF
-          IWRKD = IWRKF + 1
-          JINDA = IWRKF + LMTNA
-          IWRKF = IWRKF + LMTNC
-          If (IWRKF >= NVAL) Then
-             If (JINDA >= NVAL) Exit
-             IWRKF = NVAL
-          End If
-          IINDA = 1
-          IINDB = JINDA + 1
-          !
-          ! Shortcut for the case when the max of A is smaller
-          ! than the min of B. This line may be activated when the
-          ! initial set is already close to sorted.
-          !
-          ! IF (XDONT(IRNGT(JINDA)) <= XDONT(IRNGT(IINDB))) CYCLE
-          !
-          ! One steps in the C subset, that we build in the final rank array
-          !
-          ! Make a copy of the rank array for the merge iteration
-          !
-          JWRKT (1:LMTNA) = IRNGT (IWRKD:JINDA)
-          !
-          XVALA = XDONT (JWRKT(IINDA))
-          XVALB = XDONT (IRNGT(IINDB))
-          !
-          Do
-             IWRK = IWRK + 1
-             !
-             ! We still have unprocessed values in both A and B
-             !
-             If (XVALA > XVALB) Then
-                IRNGT (IWRK) = IRNGT (IINDB)
-                IINDB = IINDB + 1
-                If (IINDB > IWRKF) Then
-                   ! Only A still with unprocessed values
-                   IRNGT (IWRK+1:IWRKF) = JWRKT (IINDA:LMTNA)
-                   Exit
-                End If
-                XVALB = XDONT (IRNGT(IINDB))
-             Else
-                IRNGT (IWRK) = JWRKT (IINDA)
-                IINDA = IINDA + 1
-                If (IINDA > LMTNA) Exit! Only B still with unprocessed values
-                XVALA = XDONT (JWRKT(IINDA))
-             End If
-             !
-          End Do
-       End Do
-       !
-       ! The Cs become As and Bs
-       !
-       LMTNA = 2 * LMTNA
-    End Do
-    !
-    Return
-    !
-  End Subroutine D_mrgrnk
-  
-  Subroutine R_mrgrnk (XDONT, IRNGT)
-    ! __________________________________________________________
-    ! MRGRNK = Merge-sort ranking of an array
-    ! For performance reasons, the first 2 passes are taken
-    ! out of the standard loop, and use dedicated coding.
-    ! __________________________________________________________
-    ! _________________________________________________________
-    Real(wp), Dimension (:), Intent (In) :: XDONT
-    Integer, Dimension (:), Intent (Out) :: IRNGT
-    ! __________________________________________________________
-    Real(wp) :: XVALA, XVALB
-    !
-    Integer, Dimension (SIZE(IRNGT)) :: JWRKT
-    Integer :: LMTNA, LMTNC, IRNG1, IRNG2
-    Integer :: NVAL, IIND, IWRKD, IWRK, IWRKF, JINDA, IINDA, IINDB
-    !
-    NVAL = Min (SIZE(XDONT), SIZE(IRNGT))
-    Select Case (NVAL)
-    Case (:0)
-       Return
-    Case (1)
-       IRNGT (1) = 1
-       Return
-    Case Default
-       Continue
-    End Select
-    !
-    ! Fill-in the index array, creating ordered couples
-    !
-    Do IIND = 2, NVAL, 2
-       If (XDONT(IIND-1) <= XDONT(IIND)) Then
-          IRNGT (IIND-1) = IIND - 1
-          IRNGT (IIND) = IIND
-       Else
-          IRNGT (IIND-1) = IIND
-          IRNGT (IIND) = IIND - 1
-       End If
-    End Do
-    If (Modulo(NVAL, 2) /= 0) Then
-       IRNGT (NVAL) = NVAL
-    End If
-    !
-    ! We will now have ordered subsets A - B - A - B - ...
-    ! and merge A and B couples into C - C - ...
-    !
-    LMTNA = 2
-    LMTNC = 4
-    !
-    ! First iteration. The length of the ordered subsets goes from 2 to 4
-    !
-    Do
-       If (NVAL <= 2) Exit
-       !
-       ! Loop on merges of A and B into C
-       !
-       Do IWRKD = 0, NVAL - 1, 4
-          If ((IWRKD+4) > NVAL) Then
-             If ((IWRKD+2) >= NVAL) Exit
-             !
-             ! 1 2 3
-             !
-             If (XDONT(IRNGT(IWRKD+2)) <= XDONT(IRNGT(IWRKD+3))) Exit
-             !
-             ! 1 3 2
-             !
-             If (XDONT(IRNGT(IWRKD+1)) <= XDONT(IRNGT(IWRKD+3))) Then
-                IRNG2 = IRNGT (IWRKD+2)
-                IRNGT (IWRKD+2) = IRNGT (IWRKD+3)
-                IRNGT (IWRKD+3) = IRNG2
-                !
-                ! 3 1 2
-                !
-             Else
-                IRNG1 = IRNGT (IWRKD+1)
-                IRNGT (IWRKD+1) = IRNGT (IWRKD+3)
-                IRNGT (IWRKD+3) = IRNGT (IWRKD+2)
-                IRNGT (IWRKD+2) = IRNG1
-             End If
-             Exit
-          End If
-          !
-          ! 1 2 3 4
-          !
-          If (XDONT(IRNGT(IWRKD+2)) <= XDONT(IRNGT(IWRKD+3))) Cycle
-          !
-          ! 1 3 x x
-          !
-          If (XDONT(IRNGT(IWRKD+1)) <= XDONT(IRNGT(IWRKD+3))) Then
-             IRNG2 = IRNGT (IWRKD+2)
-             IRNGT (IWRKD+2) = IRNGT (IWRKD+3)
-             If (XDONT(IRNG2) <= XDONT(IRNGT(IWRKD+4))) Then
-                ! 1 3 2 4
-                IRNGT (IWRKD+3) = IRNG2
-             Else
-                ! 1 3 4 2
-                IRNGT (IWRKD+3) = IRNGT (IWRKD+4)
-                IRNGT (IWRKD+4) = IRNG2
-             End If
-             !
-             ! 3 x x x
-             !
-          Else
-             IRNG1 = IRNGT (IWRKD+1)
-             IRNG2 = IRNGT (IWRKD+2)
-             IRNGT (IWRKD+1) = IRNGT (IWRKD+3)
-             If (XDONT(IRNG1) <= XDONT(IRNGT(IWRKD+4))) Then
-                IRNGT (IWRKD+2) = IRNG1
-                If (XDONT(IRNG2) <= XDONT(IRNGT(IWRKD+4))) Then
-                   ! 3 1 2 4
-                   IRNGT (IWRKD+3) = IRNG2
-                Else
-                   ! 3 1 4 2
-                   IRNGT (IWRKD+3) = IRNGT (IWRKD+4)
-                   IRNGT (IWRKD+4) = IRNG2
-                End If
-             Else
-                ! 3 4 1 2
-                IRNGT (IWRKD+2) = IRNGT (IWRKD+4)
-                IRNGT (IWRKD+3) = IRNG1
-                IRNGT (IWRKD+4) = IRNG2
-             End If
-          End If
-       End Do
-       !
-       ! The Cs become As and Bs
-       !
-       LMTNA = 4
-       Exit
-    End Do
-    !
-    ! Iteration loop. Each time, the length of the ordered subsets
-    ! is doubled.
-    !
-    Do
-       If (LMTNA >= NVAL) Exit
-       IWRKF = 0
-       LMTNC = 2 * LMTNC
-       !
-       ! Loop on merges of A and B into C
-       !
-       Do
-          IWRK = IWRKF
-          IWRKD = IWRKF + 1
-          JINDA = IWRKF + LMTNA
-          IWRKF = IWRKF + LMTNC
-          If (IWRKF >= NVAL) Then
-             If (JINDA >= NVAL) Exit
-             IWRKF = NVAL
-          End If
-          IINDA = 1
-          IINDB = JINDA + 1
-          !
-          ! Shortcut for the case when the max of A is smaller
-          ! than the min of B. This line may be activated when the
-          ! initial set is already close to sorted.
-          !
-          ! IF (XDONT(IRNGT(JINDA)) <= XDONT(IRNGT(IINDB))) CYCLE
-          !
-          ! One steps in the C subset, that we build in the final rank array
-          !
-          ! Make a copy of the rank array for the merge iteration
-          !
-          JWRKT (1:LMTNA) = IRNGT (IWRKD:JINDA)
-          !
-          XVALA = XDONT (JWRKT(IINDA))
-          XVALB = XDONT (IRNGT(IINDB))
-          !
-          Do
-             IWRK = IWRK + 1
-             !
-             ! We still have unprocessed values in both A and B
-             !
-             If (XVALA > XVALB) Then
-                IRNGT (IWRK) = IRNGT (IINDB)
-                IINDB = IINDB + 1
-                If (IINDB > IWRKF) Then
-                   ! Only A still with unprocessed values
-                   IRNGT (IWRK+1:IWRKF) = JWRKT (IINDA:LMTNA)
-                   Exit
-                End If
-                XVALB = XDONT (IRNGT(IINDB))
-             Else
-                IRNGT (IWRK) = JWRKT (IINDA)
-                IINDA = IINDA + 1
-                If (IINDA > LMTNA) Exit! Only B still with unprocessed values
-                XVALA = XDONT (JWRKT(IINDA))
-             End If
-             !
-          End Do
-       End Do
-       !
-       ! The Cs become As and Bs
-       !
-       LMTNA = 2 * LMTNA
-    End Do
-    !
-    Return
-    !
-  End Subroutine R_mrgrnk
-  Subroutine I_mrgrnk (XDONT, IRNGT)
-    ! __________________________________________________________
-    ! MRGRNK = Merge-sort ranking of an array
-    ! For performance reasons, the first 2 passes are taken
-    ! out of the standard loop, and use dedicated coding.
-    ! __________________________________________________________
-    ! __________________________________________________________
-    Integer, Dimension (:), Intent (In) :: XDONT
-    Integer, Dimension (:), Intent (Out) :: IRNGT
-    ! __________________________________________________________
-    Integer :: XVALA, XVALB
-    !
-    Integer, Dimension (SIZE(IRNGT)) :: JWRKT
-    Integer :: LMTNA, LMTNC, IRNG1, IRNG2
-    Integer :: NVAL, IIND, IWRKD, IWRK, IWRKF, JINDA, IINDA, IINDB
-    !
-    NVAL = Min (SIZE(XDONT), SIZE(IRNGT))
-    Select Case (NVAL)
-    Case (:0)
-       Return
-    Case (1)
-       IRNGT (1) = 1
-       Return
-    Case Default
-       Continue
-    End Select
-    !
-    ! Fill-in the index array, creating ordered couples
-    !
-    Do IIND = 2, NVAL, 2
-       If (XDONT(IIND-1) <= XDONT(IIND)) Then
-          IRNGT (IIND-1) = IIND - 1
-          IRNGT (IIND) = IIND
-       Else
-          IRNGT (IIND-1) = IIND
-          IRNGT (IIND) = IIND - 1
-       End If
-    End Do
-    If (Modulo(NVAL, 2) /= 0) Then
-       IRNGT (NVAL) = NVAL
-    End If
-    !
-    ! We will now have ordered subsets A - B - A - B - ...
-    ! and merge A and B couples into C - C - ...
-    !
-    LMTNA = 2
-    LMTNC = 4
-    !
-    ! First iteration. The length of the ordered subsets goes from 2 to 4
-    !
-    Do
-       If (NVAL <= 2) Exit
-       !
-       ! Loop on merges of A and B into C
-       !
-       Do IWRKD = 0, NVAL - 1, 4
-          If ((IWRKD+4) > NVAL) Then
-             If ((IWRKD+2) >= NVAL) Exit
-             !
-             ! 1 2 3
-             !
-             If (XDONT(IRNGT(IWRKD+2)) <= XDONT(IRNGT(IWRKD+3))) Exit
-             !
-             ! 1 3 2
-             !
-             If (XDONT(IRNGT(IWRKD+1)) <= XDONT(IRNGT(IWRKD+3))) Then
-                IRNG2 = IRNGT (IWRKD+2)
-                IRNGT (IWRKD+2) = IRNGT (IWRKD+3)
-                IRNGT (IWRKD+3) = IRNG2
-                !
-                ! 3 1 2
-                !
-             Else
-                IRNG1 = IRNGT (IWRKD+1)
-                IRNGT (IWRKD+1) = IRNGT (IWRKD+3)
-                IRNGT (IWRKD+3) = IRNGT (IWRKD+2)
-                IRNGT (IWRKD+2) = IRNG1
-             End If
-             Exit
-          End If
-          !
-          ! 1 2 3 4
-          !
-          If (XDONT(IRNGT(IWRKD+2)) <= XDONT(IRNGT(IWRKD+3))) Cycle
-          !
-          ! 1 3 x x
-          !
-          If (XDONT(IRNGT(IWRKD+1)) <= XDONT(IRNGT(IWRKD+3))) Then
-             IRNG2 = IRNGT (IWRKD+2)
-             IRNGT (IWRKD+2) = IRNGT (IWRKD+3)
-             If (XDONT(IRNG2) <= XDONT(IRNGT(IWRKD+4))) Then
-                ! 1 3 2 4
-                IRNGT (IWRKD+3) = IRNG2
-             Else
-                ! 1 3 4 2
-                IRNGT (IWRKD+3) = IRNGT (IWRKD+4)
-                IRNGT (IWRKD+4) = IRNG2
-             End If
-             !
-             ! 3 x x x
-             !
-          Else
-             IRNG1 = IRNGT (IWRKD+1)
-             IRNG2 = IRNGT (IWRKD+2)
-             IRNGT (IWRKD+1) = IRNGT (IWRKD+3)
-             If (XDONT(IRNG1) <= XDONT(IRNGT(IWRKD+4))) Then
-                IRNGT (IWRKD+2) = IRNG1
-                If (XDONT(IRNG2) <= XDONT(IRNGT(IWRKD+4))) Then
-                   ! 3 1 2 4
-                   IRNGT (IWRKD+3) = IRNG2
-                Else
-                   ! 3 1 4 2
-                   IRNGT (IWRKD+3) = IRNGT (IWRKD+4)
-                   IRNGT (IWRKD+4) = IRNG2
-                End If
-             Else
-                ! 3 4 1 2
-                IRNGT (IWRKD+2) = IRNGT (IWRKD+4)
-                IRNGT (IWRKD+3) = IRNG1
-                IRNGT (IWRKD+4) = IRNG2
-             End If
-          End If
-       End Do
-       !
-       ! The Cs become As and Bs
-       !
-       LMTNA = 4
-       Exit
-    End Do
-    !
-    ! Iteration loop. Each time, the length of the ordered subsets
-    ! is doubled.
-    !
-    Do
-       If (LMTNA >= NVAL) Exit
-       IWRKF = 0
-       LMTNC = 2 * LMTNC
-       !
-       ! Loop on merges of A and B into C
-       !
-       Do
-          IWRK = IWRKF
-          IWRKD = IWRKF + 1
-          JINDA = IWRKF + LMTNA
-          IWRKF = IWRKF + LMTNC
-          If (IWRKF >= NVAL) Then
-             If (JINDA >= NVAL) Exit
-             IWRKF = NVAL
-          End If
-          IINDA = 1
-          IINDB = JINDA + 1
-          !
-          ! Shortcut for the case when the max of A is smaller
-          ! than the min of B. This line may be activated when the
-          ! initial set is already close to sorted.
-          !
-          ! IF (XDONT(IRNGT(JINDA)) <= XDONT(IRNGT(IINDB))) CYCLE
-          !
-          ! One steps in the C subset, that we build in the final rank array
-          !
-          ! Make a copy of the rank array for the merge iteration
-          !
-          JWRKT (1:LMTNA) = IRNGT (IWRKD:JINDA)
-          !
-          XVALA = XDONT (JWRKT(IINDA))
-          XVALB = XDONT (IRNGT(IINDB))
-          !
-          Do
-             IWRK = IWRK + 1
-             !
-             ! We still have unprocessed values in both A and B
-             !
-             If (XVALA > XVALB) Then
-                IRNGT (IWRK) = IRNGT (IINDB)
-                IINDB = IINDB + 1
-                If (IINDB > IWRKF) Then
-                   ! Only A still with unprocessed values
-                   IRNGT (IWRK+1:IWRKF) = JWRKT (IINDA:LMTNA)
-                   Exit
-                End If
-                XVALB = XDONT (IRNGT(IINDB))
-             Else
-                IRNGT (IWRK) = JWRKT (IINDA)
-                IINDA = IINDA + 1
-                If (IINDA > LMTNA) Exit! Only B still with unprocessed values
-                XVALA = XDONT (JWRKT(IINDA))
-             End If
-             !
-          End Do
-       End Do
-       !
-       ! The Cs become As and Bs
-       !
-       LMTNA = 2 * LMTNA
-    End Do
-    !
-    Return
-    !
-  End Subroutine I_mrgrnk
-end module m_mrgrnk
Index: /LMDZ6/trunk/libf/phylmd/cospv2/mrgrnk.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cospv2/mrgrnk.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/cospv2/mrgrnk.f90	(revision 5268)
@@ -0,0 +1,645 @@
+! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+! Copyright (c) 2015, Regents of the University of Colorado
+! All rights reserved.
+!
+! Redistribution and use in source and binary forms, with or without modification, are 
+! permitted provided that the following conditions are met:
+!
+! 1. Redistributions of source code must retain the above copyright notice, this list of 
+!    conditions and the following disclaimer.
+!
+! 2. Redistributions in binary form must reproduce the above copyright notice, this list
+!    of conditions and the following disclaimer in the documentation and/or other 
+!    materials provided with the distribution.
+!
+! 3. Neither the name of the copyright holder nor the names of its contributors may be 
+!    used to endorse or promote products derived from this software without specific prior
+!    written permission.
+!
+! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY 
+! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 
+! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL 
+! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 
+! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT 
+! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 
+! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+!
+! History:
+! May 2015:  Dustin Swales    - Modified for COSPv2.0
+! 
+! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 
+Module m_mrgrnk
+  USE COSP_KINDS,          ONLY: wp
+  Integer, Parameter :: kdp = selected_real_kind(15)
+  public :: mrgrnk
+  private :: kdp
+  private :: R_mrgrnk, I_mrgrnk, D_mrgrnk
+
+  interface mrgrnk
+!     module procedure D_mrgrnk, R_mrgrnk, I_mrgrnk
+     module procedure R_mrgrnk, I_mrgrnk
+     
+  end interface
+contains
+  
+  Subroutine D_mrgrnk (XDONT, IRNGT)
+    ! __________________________________________________________
+    ! MRGRNK = Merge-sort ranking of an array
+    ! For performance reasons, the first 2 passes are taken
+    ! out of the standard loop, and use dedicated coding.
+    ! __________________________________________________________
+    ! __________________________________________________________
+    Real (wp), Dimension (:), Intent (In) :: XDONT
+    Integer, Dimension (:), Intent (Out) :: IRNGT
+    ! __________________________________________________________
+    Real (wp) :: XVALA, XVALB
+    !
+    Integer, Dimension (SIZE(IRNGT)) :: JWRKT
+    Integer :: LMTNA, LMTNC, IRNG1, IRNG2
+    Integer :: NVAL, IIND, IWRKD, IWRK, IWRKF, JINDA, IINDA, IINDB
+    !
+    NVAL = Min (SIZE(XDONT), SIZE(IRNGT))
+    Select Case (NVAL)
+    Case (:0)
+       Return
+    Case (1)
+       IRNGT (1) = 1
+       Return
+    Case Default
+       Continue
+    End Select
+    !
+    ! Fill-in the index array, creating ordered couples
+    !
+    Do IIND = 2, NVAL, 2
+       If (XDONT(IIND-1) <= XDONT(IIND)) Then
+          IRNGT (IIND-1) = IIND - 1
+          IRNGT (IIND) = IIND
+       Else
+          IRNGT (IIND-1) = IIND
+          IRNGT (IIND) = IIND - 1
+       End If
+    End Do
+    If (Modulo(NVAL, 2) /= 0) Then
+       IRNGT (NVAL) = NVAL
+    End If
+    !
+    ! We will now have ordered subsets A - B - A - B - ...
+    ! and merge A and B couples into C - C - ...
+    !
+    LMTNA = 2
+    LMTNC = 4
+    !
+    ! First iteration. The length of the ordered subsets goes from 2 to 4
+    !
+    Do
+       If (NVAL <= 2) Exit
+       !
+       ! Loop on merges of A and B into C
+       !
+       Do IWRKD = 0, NVAL - 1, 4
+          If ((IWRKD+4) > NVAL) Then
+             If ((IWRKD+2) >= NVAL) Exit
+             !
+             ! 1 2 3
+             !
+             If (XDONT(IRNGT(IWRKD+2)) <= XDONT(IRNGT(IWRKD+3))) Exit
+             !
+             ! 1 3 2
+             !
+             If (XDONT(IRNGT(IWRKD+1)) <= XDONT(IRNGT(IWRKD+3))) Then
+                IRNG2 = IRNGT (IWRKD+2)
+                IRNGT (IWRKD+2) = IRNGT (IWRKD+3)
+                IRNGT (IWRKD+3) = IRNG2
+                !
+                ! 3 1 2
+                !
+             Else
+                IRNG1 = IRNGT (IWRKD+1)
+                IRNGT (IWRKD+1) = IRNGT (IWRKD+3)
+                IRNGT (IWRKD+3) = IRNGT (IWRKD+2)
+                IRNGT (IWRKD+2) = IRNG1
+             End If
+             Exit
+          End If
+          !
+          ! 1 2 3 4
+          !
+          If (XDONT(IRNGT(IWRKD+2)) <= XDONT(IRNGT(IWRKD+3))) Cycle
+          !
+          ! 1 3 x x
+          !
+          If (XDONT(IRNGT(IWRKD+1)) <= XDONT(IRNGT(IWRKD+3))) Then
+             IRNG2 = IRNGT (IWRKD+2)
+             IRNGT (IWRKD+2) = IRNGT (IWRKD+3)
+             If (XDONT(IRNG2) <= XDONT(IRNGT(IWRKD+4))) Then
+                ! 1 3 2 4
+                IRNGT (IWRKD+3) = IRNG2
+             Else
+                ! 1 3 4 2
+                IRNGT (IWRKD+3) = IRNGT (IWRKD+4)
+                IRNGT (IWRKD+4) = IRNG2
+             End If
+             !
+             ! 3 x x x
+             !
+          Else
+             IRNG1 = IRNGT (IWRKD+1)
+             IRNG2 = IRNGT (IWRKD+2)
+             IRNGT (IWRKD+1) = IRNGT (IWRKD+3)
+             If (XDONT(IRNG1) <= XDONT(IRNGT(IWRKD+4))) Then
+                IRNGT (IWRKD+2) = IRNG1
+                If (XDONT(IRNG2) <= XDONT(IRNGT(IWRKD+4))) Then
+                   ! 3 1 2 4
+                   IRNGT (IWRKD+3) = IRNG2
+                Else
+                   ! 3 1 4 2
+                   IRNGT (IWRKD+3) = IRNGT (IWRKD+4)
+                   IRNGT (IWRKD+4) = IRNG2
+                End If
+             Else
+                ! 3 4 1 2
+                IRNGT (IWRKD+2) = IRNGT (IWRKD+4)
+                IRNGT (IWRKD+3) = IRNG1
+                IRNGT (IWRKD+4) = IRNG2
+             End If
+          End If
+       End Do
+       !
+       ! The Cs become As and Bs
+       !
+       LMTNA = 4
+       Exit
+    End Do
+    !
+    ! Iteration loop. Each time, the length of the ordered subsets
+    ! is doubled.
+    !
+    Do
+       If (LMTNA >= NVAL) Exit
+       IWRKF = 0
+       LMTNC = 2 * LMTNC
+       !
+       ! Loop on merges of A and B into C
+       !
+       Do
+          IWRK = IWRKF
+          IWRKD = IWRKF + 1
+          JINDA = IWRKF + LMTNA
+          IWRKF = IWRKF + LMTNC
+          If (IWRKF >= NVAL) Then
+             If (JINDA >= NVAL) Exit
+             IWRKF = NVAL
+          End If
+          IINDA = 1
+          IINDB = JINDA + 1
+          !
+          ! Shortcut for the case when the max of A is smaller
+          ! than the min of B. This line may be activated when the
+          ! initial set is already close to sorted.
+          !
+          ! IF (XDONT(IRNGT(JINDA)) <= XDONT(IRNGT(IINDB))) CYCLE
+          !
+          ! One steps in the C subset, that we build in the final rank array
+          !
+          ! Make a copy of the rank array for the merge iteration
+          !
+          JWRKT (1:LMTNA) = IRNGT (IWRKD:JINDA)
+          !
+          XVALA = XDONT (JWRKT(IINDA))
+          XVALB = XDONT (IRNGT(IINDB))
+          !
+          Do
+             IWRK = IWRK + 1
+             !
+             ! We still have unprocessed values in both A and B
+             !
+             If (XVALA > XVALB) Then
+                IRNGT (IWRK) = IRNGT (IINDB)
+                IINDB = IINDB + 1
+                If (IINDB > IWRKF) Then
+                   ! Only A still with unprocessed values
+                   IRNGT (IWRK+1:IWRKF) = JWRKT (IINDA:LMTNA)
+                   Exit
+                End If
+                XVALB = XDONT (IRNGT(IINDB))
+             Else
+                IRNGT (IWRK) = JWRKT (IINDA)
+                IINDA = IINDA + 1
+                If (IINDA > LMTNA) Exit! Only B still with unprocessed values
+                XVALA = XDONT (JWRKT(IINDA))
+             End If
+             !
+          End Do
+       End Do
+       !
+       ! The Cs become As and Bs
+       !
+       LMTNA = 2 * LMTNA
+    End Do
+    !
+    Return
+    !
+  End Subroutine D_mrgrnk
+  
+  Subroutine R_mrgrnk (XDONT, IRNGT)
+    ! __________________________________________________________
+    ! MRGRNK = Merge-sort ranking of an array
+    ! For performance reasons, the first 2 passes are taken
+    ! out of the standard loop, and use dedicated coding.
+    ! __________________________________________________________
+    ! _________________________________________________________
+    Real(wp), Dimension (:), Intent (In) :: XDONT
+    Integer, Dimension (:), Intent (Out) :: IRNGT
+    ! __________________________________________________________
+    Real(wp) :: XVALA, XVALB
+    !
+    Integer, Dimension (SIZE(IRNGT)) :: JWRKT
+    Integer :: LMTNA, LMTNC, IRNG1, IRNG2
+    Integer :: NVAL, IIND, IWRKD, IWRK, IWRKF, JINDA, IINDA, IINDB
+    !
+    NVAL = Min (SIZE(XDONT), SIZE(IRNGT))
+    Select Case (NVAL)
+    Case (:0)
+       Return
+    Case (1)
+       IRNGT (1) = 1
+       Return
+    Case Default
+       Continue
+    End Select
+    !
+    ! Fill-in the index array, creating ordered couples
+    !
+    Do IIND = 2, NVAL, 2
+       If (XDONT(IIND-1) <= XDONT(IIND)) Then
+          IRNGT (IIND-1) = IIND - 1
+          IRNGT (IIND) = IIND
+       Else
+          IRNGT (IIND-1) = IIND
+          IRNGT (IIND) = IIND - 1
+       End If
+    End Do
+    If (Modulo(NVAL, 2) /= 0) Then
+       IRNGT (NVAL) = NVAL
+    End If
+    !
+    ! We will now have ordered subsets A - B - A - B - ...
+    ! and merge A and B couples into C - C - ...
+    !
+    LMTNA = 2
+    LMTNC = 4
+    !
+    ! First iteration. The length of the ordered subsets goes from 2 to 4
+    !
+    Do
+       If (NVAL <= 2) Exit
+       !
+       ! Loop on merges of A and B into C
+       !
+       Do IWRKD = 0, NVAL - 1, 4
+          If ((IWRKD+4) > NVAL) Then
+             If ((IWRKD+2) >= NVAL) Exit
+             !
+             ! 1 2 3
+             !
+             If (XDONT(IRNGT(IWRKD+2)) <= XDONT(IRNGT(IWRKD+3))) Exit
+             !
+             ! 1 3 2
+             !
+             If (XDONT(IRNGT(IWRKD+1)) <= XDONT(IRNGT(IWRKD+3))) Then
+                IRNG2 = IRNGT (IWRKD+2)
+                IRNGT (IWRKD+2) = IRNGT (IWRKD+3)
+                IRNGT (IWRKD+3) = IRNG2
+                !
+                ! 3 1 2
+                !
+             Else
+                IRNG1 = IRNGT (IWRKD+1)
+                IRNGT (IWRKD+1) = IRNGT (IWRKD+3)
+                IRNGT (IWRKD+3) = IRNGT (IWRKD+2)
+                IRNGT (IWRKD+2) = IRNG1
+             End If
+             Exit
+          End If
+          !
+          ! 1 2 3 4
+          !
+          If (XDONT(IRNGT(IWRKD+2)) <= XDONT(IRNGT(IWRKD+3))) Cycle
+          !
+          ! 1 3 x x
+          !
+          If (XDONT(IRNGT(IWRKD+1)) <= XDONT(IRNGT(IWRKD+3))) Then
+             IRNG2 = IRNGT (IWRKD+2)
+             IRNGT (IWRKD+2) = IRNGT (IWRKD+3)
+             If (XDONT(IRNG2) <= XDONT(IRNGT(IWRKD+4))) Then
+                ! 1 3 2 4
+                IRNGT (IWRKD+3) = IRNG2
+             Else
+                ! 1 3 4 2
+                IRNGT (IWRKD+3) = IRNGT (IWRKD+4)
+                IRNGT (IWRKD+4) = IRNG2
+             End If
+             !
+             ! 3 x x x
+             !
+          Else
+             IRNG1 = IRNGT (IWRKD+1)
+             IRNG2 = IRNGT (IWRKD+2)
+             IRNGT (IWRKD+1) = IRNGT (IWRKD+3)
+             If (XDONT(IRNG1) <= XDONT(IRNGT(IWRKD+4))) Then
+                IRNGT (IWRKD+2) = IRNG1
+                If (XDONT(IRNG2) <= XDONT(IRNGT(IWRKD+4))) Then
+                   ! 3 1 2 4
+                   IRNGT (IWRKD+3) = IRNG2
+                Else
+                   ! 3 1 4 2
+                   IRNGT (IWRKD+3) = IRNGT (IWRKD+4)
+                   IRNGT (IWRKD+4) = IRNG2
+                End If
+             Else
+                ! 3 4 1 2
+                IRNGT (IWRKD+2) = IRNGT (IWRKD+4)
+                IRNGT (IWRKD+3) = IRNG1
+                IRNGT (IWRKD+4) = IRNG2
+             End If
+          End If
+       End Do
+       !
+       ! The Cs become As and Bs
+       !
+       LMTNA = 4
+       Exit
+    End Do
+    !
+    ! Iteration loop. Each time, the length of the ordered subsets
+    ! is doubled.
+    !
+    Do
+       If (LMTNA >= NVAL) Exit
+       IWRKF = 0
+       LMTNC = 2 * LMTNC
+       !
+       ! Loop on merges of A and B into C
+       !
+       Do
+          IWRK = IWRKF
+          IWRKD = IWRKF + 1
+          JINDA = IWRKF + LMTNA
+          IWRKF = IWRKF + LMTNC
+          If (IWRKF >= NVAL) Then
+             If (JINDA >= NVAL) Exit
+             IWRKF = NVAL
+          End If
+          IINDA = 1
+          IINDB = JINDA + 1
+          !
+          ! Shortcut for the case when the max of A is smaller
+          ! than the min of B. This line may be activated when the
+          ! initial set is already close to sorted.
+          !
+          ! IF (XDONT(IRNGT(JINDA)) <= XDONT(IRNGT(IINDB))) CYCLE
+          !
+          ! One steps in the C subset, that we build in the final rank array
+          !
+          ! Make a copy of the rank array for the merge iteration
+          !
+          JWRKT (1:LMTNA) = IRNGT (IWRKD:JINDA)
+          !
+          XVALA = XDONT (JWRKT(IINDA))
+          XVALB = XDONT (IRNGT(IINDB))
+          !
+          Do
+             IWRK = IWRK + 1
+             !
+             ! We still have unprocessed values in both A and B
+             !
+             If (XVALA > XVALB) Then
+                IRNGT (IWRK) = IRNGT (IINDB)
+                IINDB = IINDB + 1
+                If (IINDB > IWRKF) Then
+                   ! Only A still with unprocessed values
+                   IRNGT (IWRK+1:IWRKF) = JWRKT (IINDA:LMTNA)
+                   Exit
+                End If
+                XVALB = XDONT (IRNGT(IINDB))
+             Else
+                IRNGT (IWRK) = JWRKT (IINDA)
+                IINDA = IINDA + 1
+                If (IINDA > LMTNA) Exit! Only B still with unprocessed values
+                XVALA = XDONT (JWRKT(IINDA))
+             End If
+             !
+          End Do
+       End Do
+       !
+       ! The Cs become As and Bs
+       !
+       LMTNA = 2 * LMTNA
+    End Do
+    !
+    Return
+    !
+  End Subroutine R_mrgrnk
+  Subroutine I_mrgrnk (XDONT, IRNGT)
+    ! __________________________________________________________
+    ! MRGRNK = Merge-sort ranking of an array
+    ! For performance reasons, the first 2 passes are taken
+    ! out of the standard loop, and use dedicated coding.
+    ! __________________________________________________________
+    ! __________________________________________________________
+    Integer, Dimension (:), Intent (In) :: XDONT
+    Integer, Dimension (:), Intent (Out) :: IRNGT
+    ! __________________________________________________________
+    Integer :: XVALA, XVALB
+    !
+    Integer, Dimension (SIZE(IRNGT)) :: JWRKT
+    Integer :: LMTNA, LMTNC, IRNG1, IRNG2
+    Integer :: NVAL, IIND, IWRKD, IWRK, IWRKF, JINDA, IINDA, IINDB
+    !
+    NVAL = Min (SIZE(XDONT), SIZE(IRNGT))
+    Select Case (NVAL)
+    Case (:0)
+       Return
+    Case (1)
+       IRNGT (1) = 1
+       Return
+    Case Default
+       Continue
+    End Select
+    !
+    ! Fill-in the index array, creating ordered couples
+    !
+    Do IIND = 2, NVAL, 2
+       If (XDONT(IIND-1) <= XDONT(IIND)) Then
+          IRNGT (IIND-1) = IIND - 1
+          IRNGT (IIND) = IIND
+       Else
+          IRNGT (IIND-1) = IIND
+          IRNGT (IIND) = IIND - 1
+       End If
+    End Do
+    If (Modulo(NVAL, 2) /= 0) Then
+       IRNGT (NVAL) = NVAL
+    End If
+    !
+    ! We will now have ordered subsets A - B - A - B - ...
+    ! and merge A and B couples into C - C - ...
+    !
+    LMTNA = 2
+    LMTNC = 4
+    !
+    ! First iteration. The length of the ordered subsets goes from 2 to 4
+    !
+    Do
+       If (NVAL <= 2) Exit
+       !
+       ! Loop on merges of A and B into C
+       !
+       Do IWRKD = 0, NVAL - 1, 4
+          If ((IWRKD+4) > NVAL) Then
+             If ((IWRKD+2) >= NVAL) Exit
+             !
+             ! 1 2 3
+             !
+             If (XDONT(IRNGT(IWRKD+2)) <= XDONT(IRNGT(IWRKD+3))) Exit
+             !
+             ! 1 3 2
+             !
+             If (XDONT(IRNGT(IWRKD+1)) <= XDONT(IRNGT(IWRKD+3))) Then
+                IRNG2 = IRNGT (IWRKD+2)
+                IRNGT (IWRKD+2) = IRNGT (IWRKD+3)
+                IRNGT (IWRKD+3) = IRNG2
+                !
+                ! 3 1 2
+                !
+             Else
+                IRNG1 = IRNGT (IWRKD+1)
+                IRNGT (IWRKD+1) = IRNGT (IWRKD+3)
+                IRNGT (IWRKD+3) = IRNGT (IWRKD+2)
+                IRNGT (IWRKD+2) = IRNG1
+             End If
+             Exit
+          End If
+          !
+          ! 1 2 3 4
+          !
+          If (XDONT(IRNGT(IWRKD+2)) <= XDONT(IRNGT(IWRKD+3))) Cycle
+          !
+          ! 1 3 x x
+          !
+          If (XDONT(IRNGT(IWRKD+1)) <= XDONT(IRNGT(IWRKD+3))) Then
+             IRNG2 = IRNGT (IWRKD+2)
+             IRNGT (IWRKD+2) = IRNGT (IWRKD+3)
+             If (XDONT(IRNG2) <= XDONT(IRNGT(IWRKD+4))) Then
+                ! 1 3 2 4
+                IRNGT (IWRKD+3) = IRNG2
+             Else
+                ! 1 3 4 2
+                IRNGT (IWRKD+3) = IRNGT (IWRKD+4)
+                IRNGT (IWRKD+4) = IRNG2
+             End If
+             !
+             ! 3 x x x
+             !
+          Else
+             IRNG1 = IRNGT (IWRKD+1)
+             IRNG2 = IRNGT (IWRKD+2)
+             IRNGT (IWRKD+1) = IRNGT (IWRKD+3)
+             If (XDONT(IRNG1) <= XDONT(IRNGT(IWRKD+4))) Then
+                IRNGT (IWRKD+2) = IRNG1
+                If (XDONT(IRNG2) <= XDONT(IRNGT(IWRKD+4))) Then
+                   ! 3 1 2 4
+                   IRNGT (IWRKD+3) = IRNG2
+                Else
+                   ! 3 1 4 2
+                   IRNGT (IWRKD+3) = IRNGT (IWRKD+4)
+                   IRNGT (IWRKD+4) = IRNG2
+                End If
+             Else
+                ! 3 4 1 2
+                IRNGT (IWRKD+2) = IRNGT (IWRKD+4)
+                IRNGT (IWRKD+3) = IRNG1
+                IRNGT (IWRKD+4) = IRNG2
+             End If
+          End If
+       End Do
+       !
+       ! The Cs become As and Bs
+       !
+       LMTNA = 4
+       Exit
+    End Do
+    !
+    ! Iteration loop. Each time, the length of the ordered subsets
+    ! is doubled.
+    !
+    Do
+       If (LMTNA >= NVAL) Exit
+       IWRKF = 0
+       LMTNC = 2 * LMTNC
+       !
+       ! Loop on merges of A and B into C
+       !
+       Do
+          IWRK = IWRKF
+          IWRKD = IWRKF + 1
+          JINDA = IWRKF + LMTNA
+          IWRKF = IWRKF + LMTNC
+          If (IWRKF >= NVAL) Then
+             If (JINDA >= NVAL) Exit
+             IWRKF = NVAL
+          End If
+          IINDA = 1
+          IINDB = JINDA + 1
+          !
+          ! Shortcut for the case when the max of A is smaller
+          ! than the min of B. This line may be activated when the
+          ! initial set is already close to sorted.
+          !
+          ! IF (XDONT(IRNGT(JINDA)) <= XDONT(IRNGT(IINDB))) CYCLE
+          !
+          ! One steps in the C subset, that we build in the final rank array
+          !
+          ! Make a copy of the rank array for the merge iteration
+          !
+          JWRKT (1:LMTNA) = IRNGT (IWRKD:JINDA)
+          !
+          XVALA = XDONT (JWRKT(IINDA))
+          XVALB = XDONT (IRNGT(IINDB))
+          !
+          Do
+             IWRK = IWRK + 1
+             !
+             ! We still have unprocessed values in both A and B
+             !
+             If (XVALA > XVALB) Then
+                IRNGT (IWRK) = IRNGT (IINDB)
+                IINDB = IINDB + 1
+                If (IINDB > IWRKF) Then
+                   ! Only A still with unprocessed values
+                   IRNGT (IWRK+1:IWRKF) = JWRKT (IINDA:LMTNA)
+                   Exit
+                End If
+                XVALB = XDONT (IRNGT(IINDB))
+             Else
+                IRNGT (IWRK) = JWRKT (IINDA)
+                IINDA = IINDA + 1
+                If (IINDA > LMTNA) Exit! Only B still with unprocessed values
+                XVALA = XDONT (JWRKT(IINDA))
+             End If
+             !
+          End Do
+       End Do
+       !
+       ! The Cs become As and Bs
+       !
+       LMTNA = 2 * LMTNA
+    End Do
+    !
+    Return
+    !
+  End Subroutine I_mrgrnk
+end module m_mrgrnk
Index: DZ6/trunk/libf/phylmd/cospv2/optics_lib.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cospv2/optics_lib.F90	(revision 5267)
+++ 	(revision )
@@ -1,771 +1,0 @@
-! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-! Copyright (c) 2015, Regents of the University of Colorado
-! All rights reserved.
-!
-! Redistribution and use in source and binary forms, with or without modification, are 
-! permitted provided that the following conditions are met:
-!
-! 1. Redistributions of source code must retain the above copyright notice, this list of 
-!    conditions and the following disclaimer.
-!
-! 2. Redistributions in binary form must reproduce the above copyright notice, this list
-!    of conditions and the following disclaimer in the documentation and/or other 
-!    materials provided with the distribution.
-!
-! 3. Neither the name of the copyright holder nor the names of its contributors may be 
-!    used to endorse or promote products derived from this software without specific prior
-!    written permission.
-!
-! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY 
-! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 
-! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL 
-! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 
-! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT 
-! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 
-! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
-! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-!
-! History:
-! July 2006: John Haynes      - Initial version
-! May 2015:  Dustin Swales    - Modified for COSPv2.0
-! 
-! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 
-module optics_lib
-  USE COSP_KINDS,     ONLY: wp
-  use mod_cosp_error, ONLY: errorMessage
-  implicit none
-
-contains
-
-  ! ##############################################################################
-  !                           subroutine M_WAT
-  ! ##############################################################################
-  subroutine m_wat(freq, tk, n_r, n_i)
-    ! ############################################################################
-    !  
-    ! Purpose:
-    !   compute complex index of refraction of liquid water
-    !
-    ! Inputs:
-    !   [freq]    frequency (GHz)
-    !   [tk]       temperature (K)
-    !
-    ! Outputs:
-    !   [n_r]     real part index of refraction
-    !   [n_i]     imaginary part index of refraction
-    !
-    ! Reference:
-    !   Based on the work of Ray (1972)
-    !
-    ! Coded:
-    !   03/22/05  John Haynes (haynes@atmos.colostate.edu)
-    ! ############################################################################
-
-    ! INPUTS
-    real(wp), intent(in) :: &
-         freq, & ! Frequency (GHz)
-         tk      ! Temperature (K)
-  
-    ! OUTPUTS
-    real(wp), intent(out) :: &
-         n_r,  & ! Real part of index of refraction
-         n_i     ! Imaginary part of index of refraction
-
-    ! Internal variables
-    real(wp) :: ld,es,ei,a,ls,sg,tm1,cos1,sin1,e_r,e_i,pi,tc
-    complex(wp) :: e_comp, sq
-
-    tc = tk - 273.15_wp
-
-    ld = 100._wp*2.99792458E8_wp/(freq*1E9_wp)
-    es = 78.54_wp*(1-(4.579E-3_wp*(tc-25._wp)+1.19E-5_wp*(tc-25._wp)**2 &
-         -2.8E-8_wp*(tc-25._wp)**3))
-    ei = 5.27137_wp+0.021647_wp*tc-0.00131198_wp*tc**2
-    a = -(16.8129_wp/(tc+273._wp))+0.0609265_wp
-    ls = 0.00033836_wp*exp(2513.98_wp/(tc+273._wp))
-    sg = 12.5664E8_wp
-    
-    tm1 = (ls/ld)**(1-a)
-    pi = acos(-1._wp)
-    cos1 = cos(0.5_wp*a*pi)
-    sin1 = sin(0.5_wp*a*pi)
-    
-    e_r = ei + (((es-ei)*(1.+tm1*sin1))/(1._wp+2*tm1*sin1+tm1**2))
-    e_i = (((es-ei)*tm1*cos1)/(1._wp+2*tm1*sin1+tm1**2)) &
-         +((sg*ld)/1.885E11_wp)
-    
-!ds    e_comp = cmplx(e_r,e_i,Kind=Kind(0d0))
-    e_comp = cmplx(e_r,e_i,Kind=wp)
-    sq = sqrt(e_comp)
-    
-    n_r = real(sq)
-    n_i = aimag(sq)      
-    
-    return
-  end subroutine m_wat
-
-  ! ############################################################################
-  !                           subroutine M_ICE
-  ! ############################################################################
-  subroutine m_ice(freq,t,n_r,n_i)
-    ! ##########################################################################
-    !
-    ! Purpose:
-    !   compute complex index of refraction of ice
-    !
-    ! Inputs:
-    !   [freq]    frequency (GHz)
-    !   [t]       temperature (K)
-    !
-    ! Outputs:
-    !   [n_r]     real part index of refraction
-    !   [n_i]     imaginary part index of refraction
-    !
-    ! Reference:
-    !    Fortran 90 port from IDL of REFICE by Stephen G. Warren
-    !
-    ! Modified:
-    !   05/31/05  John Haynes (haynes@atmos.colostate.edu)
-    ! ##########################################################################
-
-    ! INPUTS
-    real(wp), intent(in) :: &
-         freq, & ! Frequency (GHz)
-         t       ! Temperature (K)
-  
-    ! OUTPUTS
-    real(wp), intent(out) :: &
-         n_r,  & ! Real part of index of refraction
-         n_i     ! Imaginary part of index of refraction
-
-    ! Internal variables
-    integer  :: i,lt1,lt2
-    real(wp) :: alam,pi,t1,t2, &
-         x,x1,x2,y,y1,y2,ylo,yhi,tk
-
-
-    ! Parameters:
-    integer,parameter :: &
-         nwl  = 468,      & !
-         nwlt = 62          !
-    real(wp),parameter,dimension(4) :: &
-         temref = [272.16,268.16,253.16,213.16]
-    real(wp),parameter :: & !
-         wlmin  = 0.045,  & !
-         wlmax  = 8.6e6,  & !
-         cutice = 167.0
-    real(wp),parameter,dimension(nwlt) :: &
-         wlt = &
-         [0.1670e+03, 0.1778e+03, 0.1884e+03, 0.1995e+03, 0.2113e+03, 0.2239e+03, &
-          0.2371e+03, 0.2512e+03, 0.2661e+03, 0.2818e+03, 0.2985e+03, 0.3162e+03, &
-          0.3548e+03, 0.3981e+03, 0.4467e+03, 0.5012e+03, 0.5623e+03, 0.6310e+03, &
-          0.7943e+03, 0.1000e+04, 0.1259e+04, 0.2500e+04, 0.5000e+04, 0.1000e+05, &
-          0.2000e+05, 0.3200e+05, 0.3500e+05, 0.4000e+05, 0.4500e+05, 0.5000e+05, &
-          0.6000e+05, 0.7000e+05, 0.9000e+05, 0.1110e+06, 0.1200e+06, 0.1300e+06, &
-          0.1400e+06, 0.1500e+06, 0.1600e+06, 0.1700e+06, 0.1800e+06, 0.2000e+06, &
-          0.2500e+06, 0.2900e+06, 0.3200e+06, 0.3500e+06, 0.3800e+06, 0.4000e+06, &
-          0.4500e+06, 0.5000e+06, 0.6000e+06, 0.6400e+06, 0.6800e+06, 0.7200e+06, &
-          0.7600e+06, 0.8000e+06, 0.8400e+06, 0.9000e+06, 0.1000e+07, 0.2000e+07, &
-          0.5000e+07,0.8600e+07]
-    real(wp),parameter,dimension(nwl) :: &
-         tabim = &
-         [0.1640e+00, 0.1730e+00, 0.1830e+00, 0.1950e+00, 0.2080e+00, 0.2230e+00, &
-          0.2400e+00, 0.2500e+00, 0.2590e+00, 0.2680e+00, 0.2790e+00, 0.2970e+00, &
-          0.3190e+00, 0.3400e+00, 0.3660e+00, 0.3920e+00, 0.4160e+00, 0.4400e+00, &
-          0.4640e+00, 0.4920e+00, 0.5170e+00, 0.5280e+00, 0.5330e+00, 0.5340e+00, &
-          0.5310e+00, 0.5240e+00, 0.5100e+00, 0.5000e+00, 0.4990e+00, 0.4680e+00, &
-          0.3800e+00, 0.3600e+00, 0.3390e+00, 0.3180e+00, 0.2910e+00, 0.2510e+00, &
-          0.2440e+00, 0.2390e+00, 0.2390e+00, 0.2440e+00, 0.2470e+00, 0.2240e+00, &
-          0.1950e+00, 0.1740e+00, 0.1720e+00, 0.1800e+00, 0.1940e+00, 0.2130e+00, &
-          0.2430e+00, 0.2710e+00, 0.2890e+00, 0.3340e+00, 0.3440e+00, 0.3820e+00, &
-          0.4010e+00, 0.4065e+00, 0.4050e+00, 0.3890e+00, 0.3770e+00, 0.3450e+00, &
-          0.3320e+00, 0.3150e+00, 0.2980e+00, 0.2740e+00, 0.2280e+00, 0.1980e+00, &
-          0.1720e+00, 0.1560e+00, 0.1100e+00, 0.8300e-01, 0.5800e-01, 0.2200e-01, &
-          0.1000e-01, 0.3000e-02, 0.1000e-02, 0.3000e-03, 0.1000e-03, 0.3000e-04, &
-          0.1000e-04, 0.3000e-05, 0.1000e-05, 0.7000e-06, 0.4000e-06, 0.2000e-06, &
-          0.1000e-06, 0.6377e-07, 0.3750e-07, 0.2800e-07, 0.2400e-07, 0.2200e-07, &
-          0.1900e-07, 0.1750e-07, 0.1640e-07, 0.1590e-07, 0.1325e-07, 0.8623e-08, &
-          0.5504e-08, 0.3765e-08, 0.2710e-08, 0.2510e-08, 0.2260e-08, 0.2080e-08, &
-          0.1910e-08, 0.1540e-08, 0.1530e-08, 0.1550e-08, 0.1640e-08, 0.1780e-08, &
-          0.1910e-08, 0.2140e-08, 0.2260e-08, 0.2540e-08, 0.2930e-08, 0.3110e-08, &
-          0.3290e-08, 0.3520e-08, 0.4040e-08, 0.4880e-08, 0.5730e-08, 0.6890e-08, &
-          0.8580e-08, 0.1040e-07, 0.1220e-07, 0.1430e-07, 0.1660e-07, 0.1890e-07, &
-          0.2090e-07, 0.2400e-07, 0.2900e-07, 0.3440e-07, 0.4030e-07, 0.4300e-07, &
-          0.4920e-07, 0.5870e-07, 0.7080e-07, 0.8580e-07, 0.1020e-06, 0.1180e-06, &
-          0.1340e-06, 0.1400e-06, 0.1430e-06, 0.1450e-06, 0.1510e-06, 0.1830e-06, &
-          0.2150e-06, 0.2650e-06, 0.3350e-06, 0.3920e-06, 0.4200e-06, 0.4440e-06, &
-          0.4740e-06, 0.5110e-06, 0.5530e-06, 0.6020e-06, 0.7550e-06, 0.9260e-06, &
-          0.1120e-05, 0.1330e-05, 0.1620e-05, 0.2000e-05, 0.2250e-05, 0.2330e-05, &
-          0.2330e-05, 0.2170e-05, 0.1960e-05, 0.1810e-05, 0.1740e-05, 0.1730e-05, &
-          0.1700e-05, 0.1760e-05, 0.1820e-05, 0.2040e-05, 0.2250e-05, 0.2290e-05, &
-          0.3040e-05, 0.3840e-05, 0.4770e-05, 0.5760e-05, 0.6710e-05, 0.8660e-05, &
-          0.1020e-04, 0.1130e-04, 0.1220e-04, 0.1290e-04, 0.1320e-04, 0.1350e-04, &
-          0.1330e-04, 0.1320e-04, 0.1320e-04, 0.1310e-04, 0.1320e-04, 0.1320e-04, &
-          0.1340e-04, 0.1390e-04, 0.1420e-04, 0.1480e-04, 0.1580e-04, 0.1740e-04, &
-          0.1980e-04, 0.2500e-04, 0.5400e-04, 0.1040e-03, 0.2030e-03, 0.2708e-03, &
-          0.3511e-03, 0.4299e-03, 0.5181e-03, 0.5855e-03, 0.5899e-03, 0.5635e-03, &
-          0.5480e-03, 0.5266e-03, 0.4394e-03, 0.3701e-03, 0.3372e-03, 0.2410e-03, &
-          0.1890e-03, 0.1660e-03, 0.1450e-03, 0.1280e-03, 0.1030e-03, 0.8600e-04, &
-          0.8220e-04, 0.8030e-04, 0.8500e-04, 0.9900e-04, 0.1500e-03, 0.2950e-03, &
-          0.4687e-03, 0.7615e-03, 0.1010e-02, 0.1313e-02, 0.1539e-02, 0.1588e-02, &
-          0.1540e-02, 0.1412e-02, 0.1244e-02, 0.1068e-02, 0.8414e-03, 0.5650e-03, &
-          0.4320e-03, 0.3500e-03, 0.2870e-03, 0.2210e-03, 0.2030e-03, 0.2010e-03, &
-          0.2030e-03, 0.2140e-03, 0.2320e-03, 0.2890e-03, 0.3810e-03, 0.4620e-03, &
-          0.5480e-03, 0.6180e-03, 0.6800e-03, 0.7300e-03, 0.7820e-03, 0.8480e-03, &
-          0.9250e-03, 0.9200e-03, 0.8920e-03, 0.8700e-03, 0.8900e-03, 0.9300e-03, &
-          0.1010e-02, 0.1350e-02, 0.3420e-02, 0.7920e-02, 0.2000e-01, 0.3800e-01, &
-          0.5200e-01, 0.6800e-01, 0.9230e-01, 0.1270e+00, 0.1690e+00, 0.2210e+00, &
-          0.2760e+00, 0.3120e+00, 0.3470e+00, 0.3880e+00, 0.4380e+00, 0.4930e+00, &
-          0.5540e+00, 0.6120e+00, 0.6250e+00, 0.5930e+00, 0.5390e+00, 0.4910e+00, &
-          0.4380e+00, 0.3720e+00, 0.3000e+00, 0.2380e+00, 0.1930e+00, 0.1580e+00, &
-          0.1210e+00, 0.1030e+00, 0.8360e-01, 0.6680e-01, 0.5400e-01, 0.4220e-01, &
-          0.3420e-01, 0.2740e-01, 0.2200e-01, 0.1860e-01, 0.1520e-01, 0.1260e-01, &
-          0.1060e-01, 0.8020e-02, 0.6850e-02, 0.6600e-02, 0.6960e-02, 0.9160e-02, &
-          0.1110e-01, 0.1450e-01, 0.2000e-01, 0.2300e-01, 0.2600e-01, 0.2900e-01, &
-          0.2930e-01, 0.3000e-01, 0.2850e-01, 0.1730e-01, 0.1290e-01, 0.1200e-01, &
-          0.1250e-01, 0.1340e-01, 0.1400e-01, 0.1750e-01, 0.2400e-01, 0.3500e-01, &
-          0.3800e-01, 0.4200e-01, 0.4600e-01, 0.5200e-01, 0.5700e-01, 0.6900e-01, &
-          0.7000e-01, 0.6700e-01, 0.6500e-01, 0.6400e-01, 0.6200e-01, 0.5900e-01, &
-          0.5700e-01, 0.5600e-01, 0.5500e-01, 0.5700e-01, 0.5800e-01, 0.5700e-01, &
-          0.5500e-01, 0.5500e-01, 0.5400e-01, 0.5200e-01, 0.5200e-01, 0.5200e-01, &
-          0.5200e-01, 0.5000e-01, 0.4700e-01, 0.4300e-01, 0.3900e-01, 0.3700e-01, &
-          0.3900e-01, 0.4000e-01, 0.4200e-01, 0.4400e-01, 0.4500e-01, 0.4600e-01, &
-          0.4700e-01, 0.5100e-01, 0.6500e-01, 0.7500e-01, 0.8800e-01, 0.1080e+00, &
-          0.1340e+00, 0.1680e+00, 0.2040e+00, 0.2480e+00, 0.2800e+00, 0.3410e+00, &
-          0.3790e+00, 0.4090e+00, 0.4220e+00, 0.4220e+00, 0.4030e+00, 0.3890e+00, &
-          0.3740e+00, 0.3540e+00, 0.3350e+00, 0.3150e+00, 0.2940e+00, 0.2710e+00, &
-          0.2460e+00, 0.1980e+00, 0.1640e+00, 0.1520e+00, 0.1420e+00, 0.1280e+00, &
-          0.1250e+00, 0.1230e+00, 0.1160e+00, 0.1070e+00, 0.7900e-01, 0.7200e-01, &
-          0.7600e-01, 0.7500e-01, 0.6700e-01, 0.5500e-01, 0.4500e-01, 0.2900e-01, &
-          0.2750e-01, 0.2700e-01, 0.2730e-01, 0.2890e-01, 0.3000e-01, 0.3400e-01, &
-          0.5300e-01, 0.7550e-01, 0.1060e+00, 0.1350e+00, 0.1761e+00, 0.2229e+00, &
-          0.2746e+00, 0.3280e+00, 0.3906e+00, 0.4642e+00, 0.5247e+00, 0.5731e+00, &
-          0.6362e+00, 0.6839e+00, 0.7091e+00, 0.6790e+00, 0.6250e+00, 0.5654e+00, &
-          0.5433e+00, 0.5292e+00, 0.5070e+00, 0.4883e+00, 0.4707e+00, 0.4203e+00, &
-          0.3771e+00, 0.3376e+00, 0.3056e+00, 0.2835e+00, 0.3170e+00, 0.3517e+00, &
-          0.3902e+00, 0.4509e+00, 0.4671e+00, 0.4779e+00, 0.4890e+00, 0.4899e+00, &
-          0.4873e+00, 0.4766e+00, 0.4508e+00, 0.4193e+00, 0.3880e+00, 0.3433e+00, &
-          0.3118e+00, 0.2935e+00, 0.2350e+00, 0.1981e+00, 0.1865e+00, 0.1771e+00, &
-          0.1620e+00, 0.1490e+00, 0.1390e+00, 0.1200e+00, 0.9620e-01, 0.8300e-01]
-    real(wp),parameter,dimension(nwl) :: &
-         wl = &
-         [0.4430e-01, 0.4510e-01, 0.4590e-01, 0.4680e-01, 0.4770e-01, 0.4860e-01, &
-          0.4960e-01, 0.5060e-01, 0.5170e-01, 0.5280e-01, 0.5390e-01, 0.5510e-01, &
-          0.5640e-01, 0.5770e-01, 0.5900e-01, 0.6050e-01, 0.6200e-01, 0.6360e-01, &
-          0.6530e-01, 0.6700e-01, 0.6890e-01, 0.7080e-01, 0.7290e-01, 0.7380e-01, &
-          0.7510e-01, 0.7750e-01, 0.8000e-01, 0.8270e-01, 0.8550e-01, 0.8860e-01, &
-          0.9180e-01, 0.9300e-01, 0.9540e-01, 0.9920e-01, 0.1033e+00, 0.1078e+00, &
-          0.1100e+00, 0.1127e+00, 0.1140e+00, 0.1181e+00, 0.1210e+00, 0.1240e+00, &
-          0.1272e+00, 0.1295e+00, 0.1305e+00, 0.1319e+00, 0.1333e+00, 0.1348e+00, &
-          0.1362e+00, 0.1370e+00, 0.1378e+00, 0.1387e+00, 0.1393e+00, 0.1409e+00, &
-          0.1425e+00, 0.1435e+00, 0.1442e+00, 0.1450e+00, 0.1459e+00, 0.1468e+00, &
-          0.1476e+00, 0.1480e+00, 0.1485e+00, 0.1494e+00, 0.1512e+00, 0.1531e+00, &
-          0.1540e+00, 0.1550e+00, 0.1569e+00, 0.1580e+00, 0.1589e+00, 0.1610e+00, &
-          0.1625e+00, 0.1648e+00, 0.1669e+00, 0.1692e+00, 0.1713e+00, 0.1737e+00, &
-          0.1757e+00, 0.1779e+00, 0.1802e+00, 0.1809e+00, 0.1821e+00, 0.1833e+00, &
-          0.1843e+00, 0.1850e+00, 0.1860e+00, 0.1870e+00, 0.1880e+00, 0.1890e+00, &
-          0.1900e+00, 0.1910e+00, 0.1930e+00, 0.1950e+00, 0.2100e+00, 0.2500e+00, &
-          0.3000e+00, 0.3500e+00, 0.4000e+00, 0.4100e+00, 0.4200e+00, 0.4300e+00, &
-          0.4400e+00, 0.4500e+00, 0.4600e+00, 0.4700e+00, 0.4800e+00, 0.4900e+00, &
-          0.5000e+00, 0.5100e+00, 0.5200e+00, 0.5300e+00, 0.5400e+00, 0.5500e+00, &
-          0.5600e+00, 0.5700e+00, 0.5800e+00, 0.5900e+00, 0.6000e+00, 0.6100e+00, &
-          0.6200e+00, 0.6300e+00, 0.6400e+00, 0.6500e+00, 0.6600e+00, 0.6700e+00, &
-          0.6800e+00, 0.6900e+00, 0.7000e+00, 0.7100e+00, 0.7200e+00, 0.7300e+00, &
-          0.7400e+00, 0.7500e+00, 0.7600e+00, 0.7700e+00, 0.7800e+00, 0.7900e+00, &
-          0.8000e+00, 0.8100e+00, 0.8200e+00, 0.8300e+00, 0.8400e+00, 0.8500e+00, &
-          0.8600e+00, 0.8700e+00, 0.8800e+00, 0.8900e+00, 0.9000e+00, 0.9100e+00, &
-          0.9200e+00, 0.9300e+00, 0.9400e+00, 0.9500e+00, 0.9600e+00, 0.9700e+00, &
-          0.9800e+00, 0.9900e+00, 0.1000e+01, 0.1010e+01, 0.1020e+01, 0.1030e+01, &
-          0.1040e+01, 0.1050e+01, 0.1060e+01, 0.1070e+01, 0.1080e+01, 0.1090e+01, &
-          0.1100e+01, 0.1110e+01, 0.1120e+01, 0.1130e+01, 0.1140e+01, 0.1150e+01, &
-          0.1160e+01, 0.1170e+01, 0.1180e+01, 0.1190e+01, 0.1200e+01, 0.1210e+01, &
-          0.1220e+01, 0.1230e+01, 0.1240e+01, 0.1250e+01, 0.1260e+01, 0.1270e+01, &
-          0.1280e+01, 0.1290e+01, 0.1300e+01, 0.1310e+01, 0.1320e+01, 0.1330e+01, &
-          0.1340e+01, 0.1350e+01, 0.1360e+01, 0.1370e+01, 0.1380e+01, 0.1390e+01, &
-          0.1400e+01, 0.1410e+01, 0.1420e+01, 0.1430e+01, 0.1440e+01, 0.1449e+01, &
-          0.1460e+01, 0.1471e+01, 0.1481e+01, 0.1493e+01, 0.1504e+01, 0.1515e+01, &
-          0.1527e+01, 0.1538e+01, 0.1563e+01, 0.1587e+01, 0.1613e+01, 0.1650e+01, &
-          0.1680e+01, 0.1700e+01, 0.1730e+01, 0.1760e+01, 0.1800e+01, 0.1830e+01, &
-          0.1840e+01, 0.1850e+01, 0.1855e+01, 0.1860e+01, 0.1870e+01, 0.1890e+01, &
-          0.1905e+01, 0.1923e+01, 0.1942e+01, 0.1961e+01, 0.1980e+01, 0.2000e+01, &
-          0.2020e+01, 0.2041e+01, 0.2062e+01, 0.2083e+01, 0.2105e+01, 0.2130e+01, &
-          0.2150e+01, 0.2170e+01, 0.2190e+01, 0.2220e+01, 0.2240e+01, 0.2245e+01, &
-          0.2250e+01, 0.2260e+01, 0.2270e+01, 0.2290e+01, 0.2310e+01, 0.2330e+01, &
-          0.2350e+01, 0.2370e+01, 0.2390e+01, 0.2410e+01, 0.2430e+01, 0.2460e+01, &
-          0.2500e+01, 0.2520e+01, 0.2550e+01, 0.2565e+01, 0.2580e+01, 0.2590e+01, &
-          0.2600e+01, 0.2620e+01, 0.2675e+01, 0.2725e+01, 0.2778e+01, 0.2817e+01, &
-          0.2833e+01, 0.2849e+01, 0.2865e+01, 0.2882e+01, 0.2899e+01, 0.2915e+01, &
-          0.2933e+01, 0.2950e+01, 0.2967e+01, 0.2985e+01, 0.3003e+01, 0.3021e+01, &
-          0.3040e+01, 0.3058e+01, 0.3077e+01, 0.3096e+01, 0.3115e+01, 0.3135e+01, &
-          0.3155e+01, 0.3175e+01, 0.3195e+01, 0.3215e+01, 0.3236e+01, 0.3257e+01, &
-          0.3279e+01, 0.3300e+01, 0.3322e+01, 0.3345e+01, 0.3367e+01, 0.3390e+01, &
-          0.3413e+01, 0.3436e+01, 0.3460e+01, 0.3484e+01, 0.3509e+01, 0.3534e+01, &
-          0.3559e+01, 0.3624e+01, 0.3732e+01, 0.3775e+01, 0.3847e+01, 0.3969e+01, &
-          0.4099e+01, 0.4239e+01, 0.4348e+01, 0.4387e+01, 0.4444e+01, 0.4505e+01, &
-          0.4547e+01, 0.4560e+01, 0.4580e+01, 0.4719e+01, 0.4904e+01, 0.5000e+01, &
-          0.5100e+01, 0.5200e+01, 0.5263e+01, 0.5400e+01, 0.5556e+01, 0.5714e+01, &
-          0.5747e+01, 0.5780e+01, 0.5814e+01, 0.5848e+01, 0.5882e+01, 0.6061e+01, &
-          0.6135e+01, 0.6250e+01, 0.6289e+01, 0.6329e+01, 0.6369e+01, 0.6410e+01, &
-          0.6452e+01, 0.6494e+01, 0.6579e+01, 0.6667e+01, 0.6757e+01, 0.6897e+01, &
-          0.7042e+01, 0.7143e+01, 0.7246e+01, 0.7353e+01, 0.7463e+01, 0.7576e+01, &
-          0.7692e+01, 0.7812e+01, 0.7937e+01, 0.8065e+01, 0.8197e+01, 0.8333e+01, &
-          0.8475e+01, 0.8696e+01, 0.8929e+01, 0.9091e+01, 0.9259e+01, 0.9524e+01, &
-          0.9804e+01, 0.1000e+02, 0.1020e+02, 0.1031e+02, 0.1042e+02, 0.1053e+02, &
-          0.1064e+02, 0.1075e+02, 0.1087e+02, 0.1100e+02, 0.1111e+02, 0.1136e+02, &
-          0.1163e+02, 0.1190e+02, 0.1220e+02, 0.1250e+02, 0.1282e+02, 0.1299e+02, &
-          0.1316e+02, 0.1333e+02, 0.1351e+02, 0.1370e+02, 0.1389e+02, 0.1408e+02, &
-          0.1429e+02, 0.1471e+02, 0.1515e+02, 0.1538e+02, 0.1563e+02, 0.1613e+02, &
-          0.1639e+02, 0.1667e+02, 0.1695e+02, 0.1724e+02, 0.1818e+02, 0.1887e+02, &
-          0.1923e+02, 0.1961e+02, 0.2000e+02, 0.2041e+02, 0.2083e+02, 0.2222e+02, &
-          0.2260e+02, 0.2305e+02, 0.2360e+02, 0.2460e+02, 0.2500e+02, 0.2600e+02, &
-          0.2857e+02, 0.3100e+02, 0.3333e+02, 0.3448e+02, 0.3564e+02, 0.3700e+02, &
-          0.3824e+02, 0.3960e+02, 0.4114e+02, 0.4276e+02, 0.4358e+02, 0.4458e+02, &
-          0.4550e+02, 0.4615e+02, 0.4671e+02, 0.4736e+02, 0.4800e+02, 0.4878e+02, &
-          0.5003e+02, 0.5128e+02, 0.5275e+02, 0.5350e+02, 0.5424e+02, 0.5500e+02, &
-          0.5574e+02, 0.5640e+02, 0.5700e+02, 0.5746e+02, 0.5840e+02, 0.5929e+02, &
-          0.6000e+02, 0.6100e+02, 0.6125e+02, 0.6250e+02, 0.6378e+02, 0.6467e+02, &
-          0.6558e+02, 0.6655e+02, 0.6760e+02, 0.6900e+02, 0.7053e+02, 0.7300e+02, &
-          0.7500e+02, 0.7629e+02, 0.8000e+02, 0.8297e+02, 0.8500e+02, 0.8680e+02, &
-          0.9080e+02, 0.9517e+02, 0.1000e+03, 0.1200e+03, 0.1500e+03, 0.1670e+03]
-    real(wp),parameter,dimension(nwlt,4) :: &
-         tabimt = reshape(source= &
-        (/0.8300e-01, 0.6900e-01, 0.5700e-01, 0.4560e-01, 0.3790e-01, 0.3140e-01, &
-          0.2620e-01, 0.2240e-01, 0.1960e-01, 0.1760e-01, 0.1665e-01, 0.1620e-01, &
-          0.1550e-01, 0.1470e-01, 0.1390e-01, 0.1320e-01, 0.1250e-01, 0.1180e-01, & 
-          0.1060e-01, 0.9540e-02, 0.8560e-02, 0.6210e-02, 0.4490e-02, 0.3240e-02, &
-          0.2340e-02, 0.1880e-02, 0.1740e-02, 0.1500e-02, 0.1320e-02, 0.1160e-02, &
-          0.8800e-03, 0.6950e-03, 0.4640e-03, 0.3400e-03, 0.3110e-03, 0.2940e-03, &
-          0.2790e-03, 0.2700e-03, 0.2640e-03, 0.2580e-03, 0.2520e-03, 0.2490e-03, &
-          0.2540e-03, 0.2640e-03, 0.2740e-03, 0.2890e-03, 0.3050e-03, 0.3150e-03, &
-          0.3460e-03, 0.3820e-03, 0.4620e-03, 0.5000e-03, 0.5500e-03, 0.5950e-03, &
-          0.6470e-03, 0.6920e-03, 0.7420e-03, 0.8200e-03, 0.9700e-03, 0.1950e-02, &
-          0.5780e-02, 0.9700e-02, 0.8300e-01, 0.6900e-01, 0.5700e-01, 0.4560e-01, &
-          0.3790e-01, 0.3140e-01, 0.2620e-01, 0.2240e-01, 0.1960e-01, 0.1760e-01, &
-          0.1665e-01, 0.1600e-01, 0.1500e-01, 0.1400e-01, 0.1310e-01, 0.1230e-01, &
-          0.1150e-01, 0.1080e-01, 0.9460e-02, 0.8290e-02, 0.7270e-02, 0.4910e-02, &
-          0.3300e-02, 0.2220e-02, 0.1490e-02, 0.1140e-02, 0.1060e-02, 0.9480e-03, &
-          0.8500e-03, 0.7660e-03, 0.6300e-03, 0.5200e-03, 0.3840e-03, 0.2960e-03, &
-          0.2700e-03, 0.2520e-03, 0.2440e-03, 0.2360e-03, 0.2300e-03, 0.2280e-03, &
-          0.2250e-03, 0.2200e-03, 0.2160e-03, 0.2170e-03, 0.2200e-03, 0.2250e-03, &
-          0.2320e-03, 0.2390e-03, 0.2600e-03, 0.2860e-03, 0.3560e-03, 0.3830e-03, &
-          0.4150e-03, 0.4450e-03, 0.4760e-03, 0.5080e-03, 0.5400e-03, 0.5860e-03, &
-          0.6780e-03, 0.1280e-02, 0.3550e-02, 0.5600e-02, 0.8300e-01, 0.6900e-01, &
-          0.5700e-01, 0.4560e-01, 0.3790e-01, 0.3140e-01, 0.2620e-01, 0.2190e-01, &
-          0.1880e-01, 0.1660e-01, 0.1540e-01, 0.1470e-01, 0.1350e-01, 0.1250e-01, &
-          0.1150e-01, 0.1060e-01, 0.9770e-02, 0.9010e-02, 0.7660e-02, 0.6520e-02, &
-          0.5540e-02, 0.3420e-02, 0.2100e-02, 0.1290e-02, 0.7930e-03, 0.5700e-03, &
-          0.5350e-03, 0.4820e-03, 0.4380e-03, 0.4080e-03, 0.3500e-03, 0.3200e-03, &
-          0.2550e-03, 0.2120e-03, 0.2000e-03, 0.1860e-03, 0.1750e-03, 0.1660e-03, &
-          0.1560e-03, 0.1490e-03, 0.1440e-03, 0.1350e-03, 0.1210e-03, 0.1160e-03, &
-          0.1160e-03, 0.1170e-03, 0.1200e-03, 0.1230e-03, 0.1320e-03, 0.1440e-03, &
-          0.1680e-03, 0.1800e-03, 0.1900e-03, 0.2090e-03, 0.2160e-03, 0.2290e-03, &
-          0.2400e-03, 0.2600e-03, 0.2920e-03, 0.6100e-03, 0.1020e-02, 0.1810e-02, &
-          0.8300e-01, 0.6900e-01, 0.5700e-01, 0.4450e-01, 0.3550e-01, 0.2910e-01, &
-          0.2440e-01, 0.1970e-01, 0.1670e-01, 0.1400e-01, 0.1235e-01, 0.1080e-01, &
-          0.8900e-02, 0.7340e-02, 0.6400e-02, 0.5600e-02, 0.5000e-02, 0.4520e-02, &
-          0.3680e-02, 0.2990e-02, 0.2490e-02, 0.1550e-02, 0.9610e-03, 0.5950e-03, &
-          0.3690e-03, 0.2670e-03, 0.2510e-03, 0.2290e-03, 0.2110e-03, 0.1960e-03, &
-          0.1730e-03, 0.1550e-03, 0.1310e-03, 0.1130e-03, 0.1060e-03, 0.9900e-04, &
-          0.9300e-04, 0.8730e-04, 0.8300e-04, 0.7870e-04, 0.7500e-04, 0.6830e-04, &
-          0.5600e-04, 0.4960e-04, 0.4550e-04, 0.4210e-04, 0.3910e-04, 0.3760e-04, &
-          0.3400e-04, 0.3100e-04, 0.2640e-04, 0.2510e-04, 0.2430e-04, 0.2390e-04, &
-          0.2370e-04, 0.2380e-04, 0.2400e-04, 0.2460e-04, 0.2660e-04, 0.4450e-04, &
-          0.8700e-04, 0.1320e-03/),shape=(/nwlt,4/))
-
-    real(wp),parameter,dimension(nwl) :: &
-         tabre = &
-         [0.83441,   0.83676,   0.83729,   0.83771,   0.83827,   0.84038, &
-          0.84719,   0.85522,   0.86047,   0.86248,   0.86157,   0.86093, &
-          0.86419,   0.86916,   0.87764,   0.89296,   0.91041,   0.93089, &
-          0.95373,   0.98188,   1.02334,   1.06735,   1.11197,   1.13134, &
-          1.15747,   1.20045,   1.23840,   1.27325,   1.32157,   1.38958, &
-          1.41644,   1.40906,   1.40063,   1.40169,   1.40934,   1.40221, &
-          1.39240,   1.38424,   1.38075,   1.38186,   1.39634,   1.40918, &
-          1.40256,   1.38013,   1.36303,   1.34144,   1.32377,   1.30605, &
-          1.29054,   1.28890,   1.28931,   1.30190,   1.32025,   1.36302, &
-          1.41872,   1.45834,   1.49028,   1.52128,   1.55376,   1.57782, &
-          1.59636,   1.60652,   1.61172,   1.61919,   1.62522,   1.63404, &
-          1.63689,   1.63833,   1.63720,   1.63233,   1.62222,   1.58269, &
-          1.55635,   1.52453,   1.50320,   1.48498,   1.47226,   1.45991, &
-          1.45115,   1.44272,   1.43498,   1.43280,   1.42924,   1.42602, &
-          1.42323,   1.42143,   1.41897,   1.41660,   1.41434,   1.41216, &
-          1.41006,   1.40805,   1.40423,   1.40067,   1.38004,   1.35085, &
-          1.33394,   1.32492,   1.31940,   1.31854,   1.31775,   1.31702, &
-          1.31633,   1.31569,   1.31509,   1.31452,   1.31399,   1.31349, &
-          1.31302,   1.31257,   1.31215,   1.31175,   1.31136,   1.31099, &
-          1.31064,   1.31031,   1.30999,   1.30968,   1.30938,   1.30909, &
-          1.30882,   1.30855,   1.30829,   1.30804,   1.30780,   1.30756, &
-          1.30733,   1.30710,   1.30688,   1.30667,   1.30646,   1.30625, &
-          1.30605,   1.30585,   1.30566,   1.30547,   1.30528,   1.30509, &
-          1.30491,   1.30473,   1.30455,   1.30437,   1.30419,   1.30402, &
-          1.30385,   1.30367,   1.30350,   1.30333,   1.30316,   1.30299, &
-          1.30283,   1.30266,   1.30249,   1.30232,   1.30216,   1.30199, &
-          1.30182,   1.30166,   1.30149,   1.30132,   1.30116,   1.30099, &
-          1.30082,   1.30065,   1.30048,   1.30031,   1.30014,   1.29997, &
-          1.29979,   1.29962,   1.29945,   1.29927,   1.29909,   1.29891, &
-          1.29873,   1.29855,   1.29837,   1.29818,   1.29800,   1.29781, &
-          1.29762,   1.29743,   1.29724,   1.29705,   1.29686,   1.29666, &
-          1.29646,   1.29626,   1.29605,   1.29584,   1.29563,   1.29542, &
-          1.29521,   1.29499,   1.29476,   1.29453,   1.29430,   1.29406, &
-          1.29381,   1.29355,   1.29327,   1.29299,   1.29272,   1.29252, &
-          1.29228,   1.29205,   1.29186,   1.29167,   1.29150,   1.29130, &
-          1.29106,   1.29083,   1.29025,   1.28962,   1.28891,   1.28784, &
-          1.28689,   1.28623,   1.28521,   1.28413,   1.28261,   1.28137, &
-          1.28093,   1.28047,   1.28022,   1.27998,   1.27948,   1.27849, &
-          1.27774,   1.27691,   1.27610,   1.27535,   1.27471,   1.27404, &
-          1.27329,   1.27240,   1.27139,   1.27029,   1.26901,   1.26736, &
-          1.26591,   1.26441,   1.26284,   1.26036,   1.25860,   1.25815, &
-          1.25768,   1.25675,   1.25579,   1.25383,   1.25179,   1.24967, &
-          1.24745,   1.24512,   1.24266,   1.24004,   1.23725,   1.23270, &
-          1.22583,   1.22198,   1.21548,   1.21184,   1.20790,   1.20507, &
-          1.20209,   1.19566,   1.17411,   1.14734,   1.10766,   1.06739, &
-          1.04762,   1.02650,   1.00357,   0.98197,   0.96503,   0.95962, &
-          0.97269,   0.99172,   1.00668,   1.02186,   1.04270,   1.07597, &
-          1.12954,   1.21267,   1.32509,   1.42599,   1.49656,   1.55095, &
-          1.59988,   1.63631,   1.65024,   1.64278,   1.62691,   1.61284, &
-          1.59245,   1.57329,   1.55770,   1.54129,   1.52654,   1.51139, &
-          1.49725,   1.48453,   1.47209,   1.46125,   1.45132,   1.44215, &
-          1.43366,   1.41553,   1.39417,   1.38732,   1.37735,   1.36448, &
-          1.35414,   1.34456,   1.33882,   1.33807,   1.33847,   1.34053, &
-          1.34287,   1.34418,   1.34634,   1.34422,   1.33453,   1.32897, &
-          1.32333,   1.31800,   1.31432,   1.30623,   1.29722,   1.28898, &
-          1.28730,   1.28603,   1.28509,   1.28535,   1.28813,   1.30156, &
-          1.30901,   1.31720,   1.31893,   1.32039,   1.32201,   1.32239, &
-          1.32149,   1.32036,   1.31814,   1.31705,   1.31807,   1.31953, &
-          1.31933,   1.31896,   1.31909,   1.31796,   1.31631,   1.31542, &
-          1.31540,   1.31552,   1.31455,   1.31193,   1.30677,   1.29934, &
-          1.29253,   1.28389,   1.27401,   1.26724,   1.25990,   1.24510, &
-          1.22241,   1.19913,   1.17150,   1.15528,   1.13700,   1.11808, &
-          1.10134,   1.09083,   1.08734,   1.09254,   1.10654,   1.14779, &
-          1.20202,   1.25825,   1.32305,   1.38574,   1.44478,   1.47170, &
-          1.49619,   1.51652,   1.53328,   1.54900,   1.56276,   1.57317, &
-          1.58028,   1.57918,   1.56672,   1.55869,   1.55081,   1.53807, &
-          1.53296,   1.53220,   1.53340,   1.53289,   1.51705,   1.50097, &
-          1.49681,   1.49928,   1.50153,   1.49856,   1.49053,   1.46070, &
-          1.45182,   1.44223,   1.43158,   1.41385,   1.40676,   1.38955, &
-          1.34894,   1.31039,   1.26420,   1.23656,   1.21663,   1.20233, &
-          1.19640,   1.19969,   1.20860,   1.22173,   1.24166,   1.28175, &
-          1.32784,   1.38657,   1.46486,   1.55323,   1.60379,   1.61877, &
-          1.62963,   1.65712,   1.69810,   1.72065,   1.74865,   1.76736, &
-          1.76476,   1.75011,   1.72327,   1.68490,   1.62398,   1.59596, &
-          1.58514,   1.59917,   1.61405,   1.66625,   1.70663,   1.73713, &
-          1.76860,   1.80343,   1.83296,   1.85682,   1.87411,   1.89110, &
-          1.89918,   1.90432,   1.90329,   1.88744,   1.87499,   1.86702, &
-          1.85361,   1.84250,   1.83225,   1.81914,   1.82268,   1.82961]
-    real(wp),parameter,dimension(nwlt,4) :: &
-         tabret = reshape( &
-           source =(/1.82961,   1.83258,   1.83149, &
-          1.82748,   1.82224,   1.81718,   1.81204,   1.80704,   1.80250, &
-          1.79834,   1.79482,   1.79214,   1.78843,   1.78601,   1.78434, &
-          1.78322,   1.78248,   1.78201,   1.78170,   1.78160,   1.78190, &
-          1.78300,   1.78430,   1.78520,   1.78620,   1.78660,   1.78680, &
-          1.78690,   1.78700,   1.78700,   1.78710,   1.78710,   1.78720, &
-          1.78720,   1.78720,   1.78720,   1.78720,   1.78720,   1.78720, &
-          1.78720,   1.78720,   1.78720,   1.78720,   1.78720,   1.78720, &
-          1.78720,   1.78720,   1.78720,   1.78720,   1.78720,   1.78720, &
-          1.78720,   1.78720,   1.78720,   1.78720,   1.78720,   1.78720, &
-          1.78720,   1.78720,   1.78720,   1.78720,   1.78800,            &
-          1.82961,   1.83258,   1.83149,   1.82748,                       &
-          1.82224,   1.81718,   1.81204,   1.80704,   1.80250,   1.79834, &
-          1.79482,   1.79214,   1.78843,   1.78601,   1.78434,   1.78322, &
-          1.78248,   1.78201,   1.78170,   1.78160,   1.78190,   1.78300, &
-          1.78430,   1.78520,   1.78610,   1.78630,   1.78640,   1.78650, &
-          1.78650,   1.78650,   1.78650,   1.78650,   1.78650,   1.78650, &
-          1.78650,   1.78650,   1.78650,   1.78650,   1.78650,   1.78650, &
-          1.78650,   1.78650,   1.78650,   1.78650,   1.78650,   1.78650, &
-          1.78650,   1.78650,   1.78650,   1.78650,   1.78650,   1.78650, &
-          1.78650,   1.78650,   1.78650,   1.78650,   1.78650,   1.78650, &
-          1.78650,   1.78650,   1.78650,   1.78720,                       &
-          1.82961,   1.83258,   1.83149,   1.82748,   1.82224,            &
-          1.81718,   1.81204,   1.80704,   1.80250,   1.79834,   1.79482, &
-          1.79214,   1.78843,   1.78601,   1.78434,   1.78322,   1.78248, &
-          1.78201,   1.78160,   1.78140,   1.78160,   1.78220,   1.78310, &
-          1.78380,   1.78390,   1.78400,   1.78400,   1.78400,   1.78400, &
-          1.78400,   1.78390,   1.78380,   1.78370,   1.78370,   1.78370, &
-          1.78370,   1.78370,   1.78370,   1.78370,   1.78370,   1.78370, &
-          1.78370,   1.78370,   1.78370,   1.78370,   1.78370,   1.78370, &
-          1.78370,   1.78370,   1.78370,   1.78370,   1.78370,   1.78370, &
-          1.78370,   1.78370,   1.78370,   1.78370,   1.78370,   1.78370, &
-          1.78370,   1.78400,   1.78450,                                  &
-          1.82961,   1.83258,   1.83149,   1.82748,   1.82224,   1.81718, &
-          1.81204,   1.80704,   1.80250,   1.79834,   1.79482,   1.79214, &
-          1.78843,   1.78601,   1.78434,   1.78322,   1.78248,   1.78201, &
-          1.78150,   1.78070,   1.78010,   1.77890,   1.77790,   1.77730, &
-          1.77720,   1.77720,   1.77720,   1.77720,   1.77720,   1.77720, &
-          1.77720,   1.77720,   1.77720,   1.77720,   1.77720,   1.77720, &
-          1.77720,   1.77720,   1.77720,   1.77720,   1.77720,   1.77720, &
-          1.77720,   1.77720,   1.77720,   1.77720,   1.77720,   1.77720, &
-          1.77720,   1.77720,   1.77720,   1.77720,   1.77720,   1.77720, &
-          1.77720,   1.77720,   1.77720,   1.77720,   1.77720,   1.77720, &
-          1.77720,   1.77800/),shape=(/nwlt,4/))
-
-    ! #####################################################################
-    ! Defines wavelength dependent complex index of refraction for ice.
-    ! Allowable wavelength range extends from 0.045 microns to 8.6 meter
-    ! temperature dependence only considered beyond 167 microns.
-    ! 
-    ! interpolation is done     n_r  vs. log(xlam)
-    !                           n_r  vs.        t
-    !                       log(n_i) vs. log(xlam)
-    !                       log(n_i) vs.        t
-    !
-    ! Stephen G. Warren - 1983
-    ! Dept. of Atmospheric Sciences
-    ! University of Washington
-    ! Seattle, Wa  98195
-    !
-    ! Based on
-    !
-    !    Warren,S.G.,1984.
-    !    Optical constants of ice from the ultraviolet to the microwave.
-    !    Applied Optics,23,1206-1225
-    !
-    ! Reference temperatures are -1.0,-5.0,-20.0, and -60.0 deg C
-    ! #####################################################################
-
-    pi  = acos(-1._wp)
-    n_r = 0._wp
-    n_i = 0._wp
-    tk  = t
-    
-    ! Convert frequency to wavelength (um)
-    alam=3E5_wp/freq
-    if((alam < wlmin) .or. (alam > wlmax)) then
-       call errorMessage('FATAL ERROR(optics/optics_lib.f90:m_ice): wavelength out of bounds')
-       return
-    endif
-    
-    if (alam < cutice) then
-       ! Region from 0.045 microns to 167.0 microns - no temperature depend
-       do i=2,nwl
-          if(alam < wl(i)) continue
-       enddo
-       x1  = log(wl(i-1))
-       x2  = log(wl(i))
-       y1  = tabre(i-1)
-       y2  = tabre(i)
-       x   = log(alam)
-       y   = ((x-x1)*(y2-y1)/(x2-x1))+y1
-       n_r = y
-       y1  = log(abs(tabim(i-1)))
-       y2  = log(abs(tabim(i)))
-       y   = ((x-x1)*(y2-y1)/(x2-x1))+y1
-       n_i = exp(y)    
-    else
-       ! Region from 167.0 microns to 8.6 meters - temperature dependence
-       if(tk > temref(1)) tk=temref(1)
-       if(tk < temref(4)) tk=temref(4)
-       do i=2,4
-          if(tk.ge.temref(i)) go to 12
-       enddo
-12     lt1 = i
-       lt2 = i-1
-       do i=2,nwlt
-          if(alam.le.wlt(i)) go to 14
-       enddo
-14     x1  = log(wlt(i-1))
-       x2  = log(wlt(i))
-       y1  = tabret(i-1,lt1)
-       y2  = tabret(i,lt1)
-       x   = log(alam)
-       ylo = ((x-x1)*(y2-y1)/(x2-x1))+y1
-       y1  = tabret(i-1,lt2)
-       y2  = tabret(i,lt2)
-       yhi = ((x-x1)*(y2-y1)/(x2-x1))+y1
-       t1  = temref(lt1)
-       t2  = temref(lt2)
-       y   = ((tk-t1)*(yhi-ylo)/(t2-t1))+ylo
-       n_r = y
-       y1  = log(abs(tabimt(i-1,lt1)))
-       y2  = log(abs(tabimt(i,lt1)))
-       ylo = ((x-x1)*(y2-y1)/(x2-x1))+y1
-       y1  = log(abs(tabimt(i-1,lt2)))
-       y2  = log(abs(tabimt(i,lt2)))
-       yhi = ((x-x1)*(y2-y1)/(x2-x1))+y1
-       y   = ((tk-t1)*(yhi-ylo)/(t2-t1))+ylo
-       n_i = exp(y)
-    endif
-  end subroutine m_ice
-
-  ! ############################################################################
-  ! subroutine MIEINT
-  ! ############################################################################
-  Subroutine MieInt(Dx, SCm, Inp, Dqv, Dqxt, Dqsc, Dbsc, Dg, Xs1, Xs2, DPh, Error)
-    ! ##########################################################################
-    !
-    !     General purpose Mie scattering routine for single particles
-    !     Author: R Grainger 1990
-    !     History:
-    !     G Thomas, March 2005: Added calculation of Phase function and
-    !     code to ensure correct calculation of backscatter coeficient
-    !     Options/Extend_Source
-    !
-    ! ##########################################################################
-    ! INPUTS
-    integer, intent(in) :: &
-         Inp
-    real(wp),intent(in) :: &
-         Dx !
-    real(wp),intent(in),dimension(Inp) :: &
-         Dqv
-    Complex(wp),intent(in) :: &
-         SCm!
-
-    ! OUTPUTS
-    Complex(wp),intent(out),dimension(InP) :: &
-         Xs1,  & !
-         Xs2     !
-    real(wp),intent(out) :: &
-         Dqxt, & !
-         Dqsc, & !
-         Dg,   & !
-         Dbsc    !
-    real(wp),intent(out),dimension(InP) :: &
-         DPh
-    integer :: &
-         Error   !!
-
-    ! PARAMETERS
-    Integer,parameter :: &
-         Imaxx   = 12000, & !
-         Itermax = 30000, & ! Must be large enough to cope with the
-                            ! largest possible nmx = x * abs(scm) + 15
-                            ! or nmx =  Dx + 4.05*Dx**(1./3.) + 2.0
-         Imaxnp = 10000     ! Change this as required
-    Real(wp),parameter :: &
-         RIMax=2.5,       & ! Largest real part of refractive index
-         IRIMax = -2        ! Largest imaginary part of refractive index
-
-    ! Internal variables
-    Integer :: I, NStop, NmX, N, Inp2
-    Real(wp)  :: Chi,Chi0,Chi1,APsi,APsi0,APsi1,Psi,Psi0,Psi1
-    Real(wp),dimension(Imaxnp) :: Pi0,Pi1,Taun
-    Complex(wp) :: Ir,Cm,A,ANM1,APB,B,BNM1,AMB,Xi,Xi0,Xi1,Y
-    Complex(wp),dimension(Itermax) :: D
-    Complex(wp),dimension(Imaxnp) :: Sp,Sm!
-
-    ! ACCELERATOR VARIABLES
-    Integer :: Tnp1,Tnm1
-    Real(wp) :: Dn, Rnx,Turbo,A2
-    real(wp),dimension(Imaxnp) :: S,T
-    Complex(wp) :: A1
-    
-    If ((Dx.Gt.Imaxx) .Or. (InP.Gt.ImaxNP)) Then
-       Error = 1
-       Return
-    EndIf
-    Cm = SCm
-    Ir = 1 / Cm
-    Y =  Dx * Cm
-    If (Dx.Lt.0.02) Then
-       NStop = 2
-    Else
-       If (Dx.Le.8.0) Then
-          NStop = Dx + 4.00*Dx**(1./3.) + 2.0
-       Else
-          If (Dx.Lt. 4200.0) Then
-             NStop = Dx + 4.05*Dx**(1./3.) + 2.0
-          Else
-             NStop = Dx + 4.00*Dx**(1./3.) + 2.0
-          End If
-       End If
-    End If
-    NmX = Max(Real(NStop),Real(Abs(Y))) + 15.
-    If (Nmx .gt. Itermax) then
-       Error = 1
-       Return
-    End If
-    Inp2 = Inp+1
-!ds    D(NmX) = cmplx(0,0,Kind=Kind(0d0))
-    D(NmX) = cmplx(0,0,Kind=wp)
-    Do N = Nmx-1,1,-1
-       A1 = (N+1) / Y
-       D(N) = A1 - 1/(A1+D(N+1))
-    End Do
-    Do I =1,Inp2
-       Sm(I) = cmplx(0,0,Kind=wp)
-!ds       Sm(I) = cmplx(0,0,Kind=Kind(0d0))
-       Sp(I) = cmplx(0,0,Kind=wp)
-!ds       Sp(I) = cmplx(0,0,Kind=Kind(0d0))
-       Pi0(I) = 0
-       Pi1(I) = 1
-    End Do
-    Psi0 = Cos(Dx)
-    Psi1 = Sin(Dx)
-    Chi0 =-Sin(Dx)
-    Chi1 = Cos(Dx)
-    APsi0 = Psi0
-    APsi1 = Psi1
-    Xi0 = cmplx(APsi0,Chi0,Kind=wp)
-!ds    Xi0 = cmplx(APsi0,Chi0,Kind=Kind(0d0))
-    Xi1 = cmplx(APsi1,Chi1,Kind=wp)
-!ds    Xi1 = cmplx(APsi1,Chi1,Kind=Kind(0d0))
-    Dg = 0
-    Dqsc = 0
-    Dqxt = 0
-    Tnp1 = 1
-    Do N = 1,Nstop
-       DN = N
-       Tnp1 = Tnp1 + 2
-       Tnm1 = Tnp1 - 2
-       A2 = Tnp1 / (DN*(DN+1._wp))
-!ds       A2 = Tnp1 / (DN*(DN+1D0))
-       Turbo = (DN+1._wp) / DN
-!ds       Turbo = (DN+1D0) / DN
-       Rnx = DN/Dx
-       Psi = Tnm1*Psi1/Dx - Psi0
-!ds       Psi = Dble(Tnm1)*Psi1/Dx - Psi0
-       APsi = Psi
-       Chi = Tnm1*Chi1/Dx       - Chi0
-       Xi = cmplx(APsi,Chi,Kind=wp)
-!ds       Xi = cmplx(APsi,Chi,Kind=Kind(0d0))
-       A = ((D(N)*Ir+Rnx)*APsi-APsi1) / ((D(N)*Ir+Rnx)*  Xi-  Xi1)
-       B = ((D(N)*Cm+Rnx)*APsi-APsi1) / ((D(N)*Cm+Rnx)*  Xi-  Xi1)
-       Dqxt = Tnp1*(A + B)+ Dqxt
-!ds       Dqxt = Tnp1 *      Dble(A + B)          + Dqxt
-       Dqsc = Tnp1 * (A*Conjg(A) + B*Conjg(B)) + Dqsc
-       If (N.Gt.1) then
-          Dg = Dg + (dN*dN - 1) * (ANM1*Conjg(A) + BNM1 * Conjg(B)) / dN + TNM1 *(ANM1*Conjg(BNM1)) / (dN*dN - dN)
-!ds          Dg = Dg + (dN*dN - 1) * Dble(ANM1*Conjg(A) + BNM1 * Conjg(B)) / dN + TNM1 * Dble(ANM1*Conjg(BNM1)) / (dN*dN - dN)
-       End If
-       Anm1 = A
-       Bnm1 = B
-       APB = A2 * (A + B)
-       AMB = A2 * (A - B)
-       Do I = 1,Inp2
-          If (I.GT.Inp) Then
-             S(I) = -Pi1(I)
-          Else
-             S(I) = Dqv(I) * Pi1(I)
-          End If
-          T(I) = S(I) - Pi0(I)
-          Taun(I) = N*T(I) - Pi0(I)
-          Sp(I) = APB * (Pi1(I) + Taun(I)) + Sp(I)
-          Sm(I) = AMB * (Pi1(I) - Taun(I)) + Sm(I)
-          Pi0(I) = Pi1(I)
-          Pi1(I) = S(I) + T(I)*Turbo
-       End Do
-       Psi0 = Psi1
-       Psi1 = Psi
-       Apsi1 = Psi1
-       Chi0 = Chi1
-       Chi1 = Chi
-       Xi1 = cmplx(APsi1,Chi1,Kind=wp)
-!ds       Xi1 = cmplx(APsi1,Chi1,Kind=Kind(0d0))
-    End Do
-
-    If (Dg .GT.0) Dg = 2 * Dg / Dqsc
-    Dqsc =  2 * Dqsc / Dx**2
-    Dqxt =  2 * Dqxt / Dx**2
-    Do I = 1,Inp
-       Xs1(I) = (Sp(I)+Sm(I)) / 2
-       Xs2(I) = (Sp(I)-Sm(I)) / 2
-       Dph(I) = 2 * (Xs1(I)*Conjg(Xs1(I)) + Xs2(I)*Conjg(Xs2(I))) / (Dx**2 * Dqsc)
-!ds       Dph(I) = 2 * Dble(Xs1(I)*Conjg(Xs1(I)) + Xs2(I)*Conjg(Xs2(I))) / (Dx**2 * Dqsc)
-    End Do
-    Dbsc = 4 * Abs(( (Sp(Inp2)+Sm(Inp2))/2 )**2) / Dx**2
-    Error = 0
-    Return
-  End subroutine MieInt
-end module optics_lib
Index: /LMDZ6/trunk/libf/phylmd/cospv2/optics_lib.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cospv2/optics_lib.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/cospv2/optics_lib.f90	(revision 5268)
@@ -0,0 +1,771 @@
+! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+! Copyright (c) 2015, Regents of the University of Colorado
+! All rights reserved.
+!
+! Redistribution and use in source and binary forms, with or without modification, are 
+! permitted provided that the following conditions are met:
+!
+! 1. Redistributions of source code must retain the above copyright notice, this list of 
+!    conditions and the following disclaimer.
+!
+! 2. Redistributions in binary form must reproduce the above copyright notice, this list
+!    of conditions and the following disclaimer in the documentation and/or other 
+!    materials provided with the distribution.
+!
+! 3. Neither the name of the copyright holder nor the names of its contributors may be 
+!    used to endorse or promote products derived from this software without specific prior
+!    written permission.
+!
+! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY 
+! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 
+! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL 
+! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 
+! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT 
+! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 
+! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+!
+! History:
+! July 2006: John Haynes      - Initial version
+! May 2015:  Dustin Swales    - Modified for COSPv2.0
+! 
+! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 
+module optics_lib
+  USE COSP_KINDS,     ONLY: wp
+  use mod_cosp_error, ONLY: errorMessage
+  implicit none
+
+contains
+
+  ! ##############################################################################
+  !                           subroutine M_WAT
+  ! ##############################################################################
+  subroutine m_wat(freq, tk, n_r, n_i)
+    ! ############################################################################
+    !  
+    ! Purpose:
+    !   compute complex index of refraction of liquid water
+    !
+    ! Inputs:
+    !   [freq]    frequency (GHz)
+    !   [tk]       temperature (K)
+    !
+    ! Outputs:
+    !   [n_r]     real part index of refraction
+    !   [n_i]     imaginary part index of refraction
+    !
+    ! Reference:
+    !   Based on the work of Ray (1972)
+    !
+    ! Coded:
+    !   03/22/05  John Haynes (haynes@atmos.colostate.edu)
+    ! ############################################################################
+
+    ! INPUTS
+    real(wp), intent(in) :: &
+         freq, & ! Frequency (GHz)
+         tk      ! Temperature (K)
+  
+    ! OUTPUTS
+    real(wp), intent(out) :: &
+         n_r,  & ! Real part of index of refraction
+         n_i     ! Imaginary part of index of refraction
+
+    ! Internal variables
+    real(wp) :: ld,es,ei,a,ls,sg,tm1,cos1,sin1,e_r,e_i,pi,tc
+    complex(wp) :: e_comp, sq
+
+    tc = tk - 273.15_wp
+
+    ld = 100._wp*2.99792458E8_wp/(freq*1E9_wp)
+    es = 78.54_wp*(1-(4.579E-3_wp*(tc-25._wp)+1.19E-5_wp*(tc-25._wp)**2 &
+         -2.8E-8_wp*(tc-25._wp)**3))
+    ei = 5.27137_wp+0.021647_wp*tc-0.00131198_wp*tc**2
+    a = -(16.8129_wp/(tc+273._wp))+0.0609265_wp
+    ls = 0.00033836_wp*exp(2513.98_wp/(tc+273._wp))
+    sg = 12.5664E8_wp
+    
+    tm1 = (ls/ld)**(1-a)
+    pi = acos(-1._wp)
+    cos1 = cos(0.5_wp*a*pi)
+    sin1 = sin(0.5_wp*a*pi)
+    
+    e_r = ei + (((es-ei)*(1.+tm1*sin1))/(1._wp+2*tm1*sin1+tm1**2))
+    e_i = (((es-ei)*tm1*cos1)/(1._wp+2*tm1*sin1+tm1**2)) &
+         +((sg*ld)/1.885E11_wp)
+    
+!ds    e_comp = cmplx(e_r,e_i,Kind=Kind(0d0))
+    e_comp = cmplx(e_r,e_i,Kind=wp)
+    sq = sqrt(e_comp)
+    
+    n_r = real(sq)
+    n_i = aimag(sq)      
+    
+    return
+  end subroutine m_wat
+
+  ! ############################################################################
+  !                           subroutine M_ICE
+  ! ############################################################################
+  subroutine m_ice(freq,t,n_r,n_i)
+    ! ##########################################################################
+    !
+    ! Purpose:
+    !   compute complex index of refraction of ice
+    !
+    ! Inputs:
+    !   [freq]    frequency (GHz)
+    !   [t]       temperature (K)
+    !
+    ! Outputs:
+    !   [n_r]     real part index of refraction
+    !   [n_i]     imaginary part index of refraction
+    !
+    ! Reference:
+    !    Fortran 90 port from IDL of REFICE by Stephen G. Warren
+    !
+    ! Modified:
+    !   05/31/05  John Haynes (haynes@atmos.colostate.edu)
+    ! ##########################################################################
+
+    ! INPUTS
+    real(wp), intent(in) :: &
+         freq, & ! Frequency (GHz)
+         t       ! Temperature (K)
+  
+    ! OUTPUTS
+    real(wp), intent(out) :: &
+         n_r,  & ! Real part of index of refraction
+         n_i     ! Imaginary part of index of refraction
+
+    ! Internal variables
+    integer  :: i,lt1,lt2
+    real(wp) :: alam,pi,t1,t2, &
+         x,x1,x2,y,y1,y2,ylo,yhi,tk
+
+
+    ! Parameters:
+    integer,parameter :: &
+         nwl  = 468,      & !
+         nwlt = 62          !
+    real(wp),parameter,dimension(4) :: &
+         temref = [272.16,268.16,253.16,213.16]
+    real(wp),parameter :: & !
+         wlmin  = 0.045,  & !
+         wlmax  = 8.6e6,  & !
+         cutice = 167.0
+    real(wp),parameter,dimension(nwlt) :: &
+         wlt = &
+         [0.1670e+03, 0.1778e+03, 0.1884e+03, 0.1995e+03, 0.2113e+03, 0.2239e+03, &
+          0.2371e+03, 0.2512e+03, 0.2661e+03, 0.2818e+03, 0.2985e+03, 0.3162e+03, &
+          0.3548e+03, 0.3981e+03, 0.4467e+03, 0.5012e+03, 0.5623e+03, 0.6310e+03, &
+          0.7943e+03, 0.1000e+04, 0.1259e+04, 0.2500e+04, 0.5000e+04, 0.1000e+05, &
+          0.2000e+05, 0.3200e+05, 0.3500e+05, 0.4000e+05, 0.4500e+05, 0.5000e+05, &
+          0.6000e+05, 0.7000e+05, 0.9000e+05, 0.1110e+06, 0.1200e+06, 0.1300e+06, &
+          0.1400e+06, 0.1500e+06, 0.1600e+06, 0.1700e+06, 0.1800e+06, 0.2000e+06, &
+          0.2500e+06, 0.2900e+06, 0.3200e+06, 0.3500e+06, 0.3800e+06, 0.4000e+06, &
+          0.4500e+06, 0.5000e+06, 0.6000e+06, 0.6400e+06, 0.6800e+06, 0.7200e+06, &
+          0.7600e+06, 0.8000e+06, 0.8400e+06, 0.9000e+06, 0.1000e+07, 0.2000e+07, &
+          0.5000e+07,0.8600e+07]
+    real(wp),parameter,dimension(nwl) :: &
+         tabim = &
+         [0.1640e+00, 0.1730e+00, 0.1830e+00, 0.1950e+00, 0.2080e+00, 0.2230e+00, &
+          0.2400e+00, 0.2500e+00, 0.2590e+00, 0.2680e+00, 0.2790e+00, 0.2970e+00, &
+          0.3190e+00, 0.3400e+00, 0.3660e+00, 0.3920e+00, 0.4160e+00, 0.4400e+00, &
+          0.4640e+00, 0.4920e+00, 0.5170e+00, 0.5280e+00, 0.5330e+00, 0.5340e+00, &
+          0.5310e+00, 0.5240e+00, 0.5100e+00, 0.5000e+00, 0.4990e+00, 0.4680e+00, &
+          0.3800e+00, 0.3600e+00, 0.3390e+00, 0.3180e+00, 0.2910e+00, 0.2510e+00, &
+          0.2440e+00, 0.2390e+00, 0.2390e+00, 0.2440e+00, 0.2470e+00, 0.2240e+00, &
+          0.1950e+00, 0.1740e+00, 0.1720e+00, 0.1800e+00, 0.1940e+00, 0.2130e+00, &
+          0.2430e+00, 0.2710e+00, 0.2890e+00, 0.3340e+00, 0.3440e+00, 0.3820e+00, &
+          0.4010e+00, 0.4065e+00, 0.4050e+00, 0.3890e+00, 0.3770e+00, 0.3450e+00, &
+          0.3320e+00, 0.3150e+00, 0.2980e+00, 0.2740e+00, 0.2280e+00, 0.1980e+00, &
+          0.1720e+00, 0.1560e+00, 0.1100e+00, 0.8300e-01, 0.5800e-01, 0.2200e-01, &
+          0.1000e-01, 0.3000e-02, 0.1000e-02, 0.3000e-03, 0.1000e-03, 0.3000e-04, &
+          0.1000e-04, 0.3000e-05, 0.1000e-05, 0.7000e-06, 0.4000e-06, 0.2000e-06, &
+          0.1000e-06, 0.6377e-07, 0.3750e-07, 0.2800e-07, 0.2400e-07, 0.2200e-07, &
+          0.1900e-07, 0.1750e-07, 0.1640e-07, 0.1590e-07, 0.1325e-07, 0.8623e-08, &
+          0.5504e-08, 0.3765e-08, 0.2710e-08, 0.2510e-08, 0.2260e-08, 0.2080e-08, &
+          0.1910e-08, 0.1540e-08, 0.1530e-08, 0.1550e-08, 0.1640e-08, 0.1780e-08, &
+          0.1910e-08, 0.2140e-08, 0.2260e-08, 0.2540e-08, 0.2930e-08, 0.3110e-08, &
+          0.3290e-08, 0.3520e-08, 0.4040e-08, 0.4880e-08, 0.5730e-08, 0.6890e-08, &
+          0.8580e-08, 0.1040e-07, 0.1220e-07, 0.1430e-07, 0.1660e-07, 0.1890e-07, &
+          0.2090e-07, 0.2400e-07, 0.2900e-07, 0.3440e-07, 0.4030e-07, 0.4300e-07, &
+          0.4920e-07, 0.5870e-07, 0.7080e-07, 0.8580e-07, 0.1020e-06, 0.1180e-06, &
+          0.1340e-06, 0.1400e-06, 0.1430e-06, 0.1450e-06, 0.1510e-06, 0.1830e-06, &
+          0.2150e-06, 0.2650e-06, 0.3350e-06, 0.3920e-06, 0.4200e-06, 0.4440e-06, &
+          0.4740e-06, 0.5110e-06, 0.5530e-06, 0.6020e-06, 0.7550e-06, 0.9260e-06, &
+          0.1120e-05, 0.1330e-05, 0.1620e-05, 0.2000e-05, 0.2250e-05, 0.2330e-05, &
+          0.2330e-05, 0.2170e-05, 0.1960e-05, 0.1810e-05, 0.1740e-05, 0.1730e-05, &
+          0.1700e-05, 0.1760e-05, 0.1820e-05, 0.2040e-05, 0.2250e-05, 0.2290e-05, &
+          0.3040e-05, 0.3840e-05, 0.4770e-05, 0.5760e-05, 0.6710e-05, 0.8660e-05, &
+          0.1020e-04, 0.1130e-04, 0.1220e-04, 0.1290e-04, 0.1320e-04, 0.1350e-04, &
+          0.1330e-04, 0.1320e-04, 0.1320e-04, 0.1310e-04, 0.1320e-04, 0.1320e-04, &
+          0.1340e-04, 0.1390e-04, 0.1420e-04, 0.1480e-04, 0.1580e-04, 0.1740e-04, &
+          0.1980e-04, 0.2500e-04, 0.5400e-04, 0.1040e-03, 0.2030e-03, 0.2708e-03, &
+          0.3511e-03, 0.4299e-03, 0.5181e-03, 0.5855e-03, 0.5899e-03, 0.5635e-03, &
+          0.5480e-03, 0.5266e-03, 0.4394e-03, 0.3701e-03, 0.3372e-03, 0.2410e-03, &
+          0.1890e-03, 0.1660e-03, 0.1450e-03, 0.1280e-03, 0.1030e-03, 0.8600e-04, &
+          0.8220e-04, 0.8030e-04, 0.8500e-04, 0.9900e-04, 0.1500e-03, 0.2950e-03, &
+          0.4687e-03, 0.7615e-03, 0.1010e-02, 0.1313e-02, 0.1539e-02, 0.1588e-02, &
+          0.1540e-02, 0.1412e-02, 0.1244e-02, 0.1068e-02, 0.8414e-03, 0.5650e-03, &
+          0.4320e-03, 0.3500e-03, 0.2870e-03, 0.2210e-03, 0.2030e-03, 0.2010e-03, &
+          0.2030e-03, 0.2140e-03, 0.2320e-03, 0.2890e-03, 0.3810e-03, 0.4620e-03, &
+          0.5480e-03, 0.6180e-03, 0.6800e-03, 0.7300e-03, 0.7820e-03, 0.8480e-03, &
+          0.9250e-03, 0.9200e-03, 0.8920e-03, 0.8700e-03, 0.8900e-03, 0.9300e-03, &
+          0.1010e-02, 0.1350e-02, 0.3420e-02, 0.7920e-02, 0.2000e-01, 0.3800e-01, &
+          0.5200e-01, 0.6800e-01, 0.9230e-01, 0.1270e+00, 0.1690e+00, 0.2210e+00, &
+          0.2760e+00, 0.3120e+00, 0.3470e+00, 0.3880e+00, 0.4380e+00, 0.4930e+00, &
+          0.5540e+00, 0.6120e+00, 0.6250e+00, 0.5930e+00, 0.5390e+00, 0.4910e+00, &
+          0.4380e+00, 0.3720e+00, 0.3000e+00, 0.2380e+00, 0.1930e+00, 0.1580e+00, &
+          0.1210e+00, 0.1030e+00, 0.8360e-01, 0.6680e-01, 0.5400e-01, 0.4220e-01, &
+          0.3420e-01, 0.2740e-01, 0.2200e-01, 0.1860e-01, 0.1520e-01, 0.1260e-01, &
+          0.1060e-01, 0.8020e-02, 0.6850e-02, 0.6600e-02, 0.6960e-02, 0.9160e-02, &
+          0.1110e-01, 0.1450e-01, 0.2000e-01, 0.2300e-01, 0.2600e-01, 0.2900e-01, &
+          0.2930e-01, 0.3000e-01, 0.2850e-01, 0.1730e-01, 0.1290e-01, 0.1200e-01, &
+          0.1250e-01, 0.1340e-01, 0.1400e-01, 0.1750e-01, 0.2400e-01, 0.3500e-01, &
+          0.3800e-01, 0.4200e-01, 0.4600e-01, 0.5200e-01, 0.5700e-01, 0.6900e-01, &
+          0.7000e-01, 0.6700e-01, 0.6500e-01, 0.6400e-01, 0.6200e-01, 0.5900e-01, &
+          0.5700e-01, 0.5600e-01, 0.5500e-01, 0.5700e-01, 0.5800e-01, 0.5700e-01, &
+          0.5500e-01, 0.5500e-01, 0.5400e-01, 0.5200e-01, 0.5200e-01, 0.5200e-01, &
+          0.5200e-01, 0.5000e-01, 0.4700e-01, 0.4300e-01, 0.3900e-01, 0.3700e-01, &
+          0.3900e-01, 0.4000e-01, 0.4200e-01, 0.4400e-01, 0.4500e-01, 0.4600e-01, &
+          0.4700e-01, 0.5100e-01, 0.6500e-01, 0.7500e-01, 0.8800e-01, 0.1080e+00, &
+          0.1340e+00, 0.1680e+00, 0.2040e+00, 0.2480e+00, 0.2800e+00, 0.3410e+00, &
+          0.3790e+00, 0.4090e+00, 0.4220e+00, 0.4220e+00, 0.4030e+00, 0.3890e+00, &
+          0.3740e+00, 0.3540e+00, 0.3350e+00, 0.3150e+00, 0.2940e+00, 0.2710e+00, &
+          0.2460e+00, 0.1980e+00, 0.1640e+00, 0.1520e+00, 0.1420e+00, 0.1280e+00, &
+          0.1250e+00, 0.1230e+00, 0.1160e+00, 0.1070e+00, 0.7900e-01, 0.7200e-01, &
+          0.7600e-01, 0.7500e-01, 0.6700e-01, 0.5500e-01, 0.4500e-01, 0.2900e-01, &
+          0.2750e-01, 0.2700e-01, 0.2730e-01, 0.2890e-01, 0.3000e-01, 0.3400e-01, &
+          0.5300e-01, 0.7550e-01, 0.1060e+00, 0.1350e+00, 0.1761e+00, 0.2229e+00, &
+          0.2746e+00, 0.3280e+00, 0.3906e+00, 0.4642e+00, 0.5247e+00, 0.5731e+00, &
+          0.6362e+00, 0.6839e+00, 0.7091e+00, 0.6790e+00, 0.6250e+00, 0.5654e+00, &
+          0.5433e+00, 0.5292e+00, 0.5070e+00, 0.4883e+00, 0.4707e+00, 0.4203e+00, &
+          0.3771e+00, 0.3376e+00, 0.3056e+00, 0.2835e+00, 0.3170e+00, 0.3517e+00, &
+          0.3902e+00, 0.4509e+00, 0.4671e+00, 0.4779e+00, 0.4890e+00, 0.4899e+00, &
+          0.4873e+00, 0.4766e+00, 0.4508e+00, 0.4193e+00, 0.3880e+00, 0.3433e+00, &
+          0.3118e+00, 0.2935e+00, 0.2350e+00, 0.1981e+00, 0.1865e+00, 0.1771e+00, &
+          0.1620e+00, 0.1490e+00, 0.1390e+00, 0.1200e+00, 0.9620e-01, 0.8300e-01]
+    real(wp),parameter,dimension(nwl) :: &
+         wl = &
+         [0.4430e-01, 0.4510e-01, 0.4590e-01, 0.4680e-01, 0.4770e-01, 0.4860e-01, &
+          0.4960e-01, 0.5060e-01, 0.5170e-01, 0.5280e-01, 0.5390e-01, 0.5510e-01, &
+          0.5640e-01, 0.5770e-01, 0.5900e-01, 0.6050e-01, 0.6200e-01, 0.6360e-01, &
+          0.6530e-01, 0.6700e-01, 0.6890e-01, 0.7080e-01, 0.7290e-01, 0.7380e-01, &
+          0.7510e-01, 0.7750e-01, 0.8000e-01, 0.8270e-01, 0.8550e-01, 0.8860e-01, &
+          0.9180e-01, 0.9300e-01, 0.9540e-01, 0.9920e-01, 0.1033e+00, 0.1078e+00, &
+          0.1100e+00, 0.1127e+00, 0.1140e+00, 0.1181e+00, 0.1210e+00, 0.1240e+00, &
+          0.1272e+00, 0.1295e+00, 0.1305e+00, 0.1319e+00, 0.1333e+00, 0.1348e+00, &
+          0.1362e+00, 0.1370e+00, 0.1378e+00, 0.1387e+00, 0.1393e+00, 0.1409e+00, &
+          0.1425e+00, 0.1435e+00, 0.1442e+00, 0.1450e+00, 0.1459e+00, 0.1468e+00, &
+          0.1476e+00, 0.1480e+00, 0.1485e+00, 0.1494e+00, 0.1512e+00, 0.1531e+00, &
+          0.1540e+00, 0.1550e+00, 0.1569e+00, 0.1580e+00, 0.1589e+00, 0.1610e+00, &
+          0.1625e+00, 0.1648e+00, 0.1669e+00, 0.1692e+00, 0.1713e+00, 0.1737e+00, &
+          0.1757e+00, 0.1779e+00, 0.1802e+00, 0.1809e+00, 0.1821e+00, 0.1833e+00, &
+          0.1843e+00, 0.1850e+00, 0.1860e+00, 0.1870e+00, 0.1880e+00, 0.1890e+00, &
+          0.1900e+00, 0.1910e+00, 0.1930e+00, 0.1950e+00, 0.2100e+00, 0.2500e+00, &
+          0.3000e+00, 0.3500e+00, 0.4000e+00, 0.4100e+00, 0.4200e+00, 0.4300e+00, &
+          0.4400e+00, 0.4500e+00, 0.4600e+00, 0.4700e+00, 0.4800e+00, 0.4900e+00, &
+          0.5000e+00, 0.5100e+00, 0.5200e+00, 0.5300e+00, 0.5400e+00, 0.5500e+00, &
+          0.5600e+00, 0.5700e+00, 0.5800e+00, 0.5900e+00, 0.6000e+00, 0.6100e+00, &
+          0.6200e+00, 0.6300e+00, 0.6400e+00, 0.6500e+00, 0.6600e+00, 0.6700e+00, &
+          0.6800e+00, 0.6900e+00, 0.7000e+00, 0.7100e+00, 0.7200e+00, 0.7300e+00, &
+          0.7400e+00, 0.7500e+00, 0.7600e+00, 0.7700e+00, 0.7800e+00, 0.7900e+00, &
+          0.8000e+00, 0.8100e+00, 0.8200e+00, 0.8300e+00, 0.8400e+00, 0.8500e+00, &
+          0.8600e+00, 0.8700e+00, 0.8800e+00, 0.8900e+00, 0.9000e+00, 0.9100e+00, &
+          0.9200e+00, 0.9300e+00, 0.9400e+00, 0.9500e+00, 0.9600e+00, 0.9700e+00, &
+          0.9800e+00, 0.9900e+00, 0.1000e+01, 0.1010e+01, 0.1020e+01, 0.1030e+01, &
+          0.1040e+01, 0.1050e+01, 0.1060e+01, 0.1070e+01, 0.1080e+01, 0.1090e+01, &
+          0.1100e+01, 0.1110e+01, 0.1120e+01, 0.1130e+01, 0.1140e+01, 0.1150e+01, &
+          0.1160e+01, 0.1170e+01, 0.1180e+01, 0.1190e+01, 0.1200e+01, 0.1210e+01, &
+          0.1220e+01, 0.1230e+01, 0.1240e+01, 0.1250e+01, 0.1260e+01, 0.1270e+01, &
+          0.1280e+01, 0.1290e+01, 0.1300e+01, 0.1310e+01, 0.1320e+01, 0.1330e+01, &
+          0.1340e+01, 0.1350e+01, 0.1360e+01, 0.1370e+01, 0.1380e+01, 0.1390e+01, &
+          0.1400e+01, 0.1410e+01, 0.1420e+01, 0.1430e+01, 0.1440e+01, 0.1449e+01, &
+          0.1460e+01, 0.1471e+01, 0.1481e+01, 0.1493e+01, 0.1504e+01, 0.1515e+01, &
+          0.1527e+01, 0.1538e+01, 0.1563e+01, 0.1587e+01, 0.1613e+01, 0.1650e+01, &
+          0.1680e+01, 0.1700e+01, 0.1730e+01, 0.1760e+01, 0.1800e+01, 0.1830e+01, &
+          0.1840e+01, 0.1850e+01, 0.1855e+01, 0.1860e+01, 0.1870e+01, 0.1890e+01, &
+          0.1905e+01, 0.1923e+01, 0.1942e+01, 0.1961e+01, 0.1980e+01, 0.2000e+01, &
+          0.2020e+01, 0.2041e+01, 0.2062e+01, 0.2083e+01, 0.2105e+01, 0.2130e+01, &
+          0.2150e+01, 0.2170e+01, 0.2190e+01, 0.2220e+01, 0.2240e+01, 0.2245e+01, &
+          0.2250e+01, 0.2260e+01, 0.2270e+01, 0.2290e+01, 0.2310e+01, 0.2330e+01, &
+          0.2350e+01, 0.2370e+01, 0.2390e+01, 0.2410e+01, 0.2430e+01, 0.2460e+01, &
+          0.2500e+01, 0.2520e+01, 0.2550e+01, 0.2565e+01, 0.2580e+01, 0.2590e+01, &
+          0.2600e+01, 0.2620e+01, 0.2675e+01, 0.2725e+01, 0.2778e+01, 0.2817e+01, &
+          0.2833e+01, 0.2849e+01, 0.2865e+01, 0.2882e+01, 0.2899e+01, 0.2915e+01, &
+          0.2933e+01, 0.2950e+01, 0.2967e+01, 0.2985e+01, 0.3003e+01, 0.3021e+01, &
+          0.3040e+01, 0.3058e+01, 0.3077e+01, 0.3096e+01, 0.3115e+01, 0.3135e+01, &
+          0.3155e+01, 0.3175e+01, 0.3195e+01, 0.3215e+01, 0.3236e+01, 0.3257e+01, &
+          0.3279e+01, 0.3300e+01, 0.3322e+01, 0.3345e+01, 0.3367e+01, 0.3390e+01, &
+          0.3413e+01, 0.3436e+01, 0.3460e+01, 0.3484e+01, 0.3509e+01, 0.3534e+01, &
+          0.3559e+01, 0.3624e+01, 0.3732e+01, 0.3775e+01, 0.3847e+01, 0.3969e+01, &
+          0.4099e+01, 0.4239e+01, 0.4348e+01, 0.4387e+01, 0.4444e+01, 0.4505e+01, &
+          0.4547e+01, 0.4560e+01, 0.4580e+01, 0.4719e+01, 0.4904e+01, 0.5000e+01, &
+          0.5100e+01, 0.5200e+01, 0.5263e+01, 0.5400e+01, 0.5556e+01, 0.5714e+01, &
+          0.5747e+01, 0.5780e+01, 0.5814e+01, 0.5848e+01, 0.5882e+01, 0.6061e+01, &
+          0.6135e+01, 0.6250e+01, 0.6289e+01, 0.6329e+01, 0.6369e+01, 0.6410e+01, &
+          0.6452e+01, 0.6494e+01, 0.6579e+01, 0.6667e+01, 0.6757e+01, 0.6897e+01, &
+          0.7042e+01, 0.7143e+01, 0.7246e+01, 0.7353e+01, 0.7463e+01, 0.7576e+01, &
+          0.7692e+01, 0.7812e+01, 0.7937e+01, 0.8065e+01, 0.8197e+01, 0.8333e+01, &
+          0.8475e+01, 0.8696e+01, 0.8929e+01, 0.9091e+01, 0.9259e+01, 0.9524e+01, &
+          0.9804e+01, 0.1000e+02, 0.1020e+02, 0.1031e+02, 0.1042e+02, 0.1053e+02, &
+          0.1064e+02, 0.1075e+02, 0.1087e+02, 0.1100e+02, 0.1111e+02, 0.1136e+02, &
+          0.1163e+02, 0.1190e+02, 0.1220e+02, 0.1250e+02, 0.1282e+02, 0.1299e+02, &
+          0.1316e+02, 0.1333e+02, 0.1351e+02, 0.1370e+02, 0.1389e+02, 0.1408e+02, &
+          0.1429e+02, 0.1471e+02, 0.1515e+02, 0.1538e+02, 0.1563e+02, 0.1613e+02, &
+          0.1639e+02, 0.1667e+02, 0.1695e+02, 0.1724e+02, 0.1818e+02, 0.1887e+02, &
+          0.1923e+02, 0.1961e+02, 0.2000e+02, 0.2041e+02, 0.2083e+02, 0.2222e+02, &
+          0.2260e+02, 0.2305e+02, 0.2360e+02, 0.2460e+02, 0.2500e+02, 0.2600e+02, &
+          0.2857e+02, 0.3100e+02, 0.3333e+02, 0.3448e+02, 0.3564e+02, 0.3700e+02, &
+          0.3824e+02, 0.3960e+02, 0.4114e+02, 0.4276e+02, 0.4358e+02, 0.4458e+02, &
+          0.4550e+02, 0.4615e+02, 0.4671e+02, 0.4736e+02, 0.4800e+02, 0.4878e+02, &
+          0.5003e+02, 0.5128e+02, 0.5275e+02, 0.5350e+02, 0.5424e+02, 0.5500e+02, &
+          0.5574e+02, 0.5640e+02, 0.5700e+02, 0.5746e+02, 0.5840e+02, 0.5929e+02, &
+          0.6000e+02, 0.6100e+02, 0.6125e+02, 0.6250e+02, 0.6378e+02, 0.6467e+02, &
+          0.6558e+02, 0.6655e+02, 0.6760e+02, 0.6900e+02, 0.7053e+02, 0.7300e+02, &
+          0.7500e+02, 0.7629e+02, 0.8000e+02, 0.8297e+02, 0.8500e+02, 0.8680e+02, &
+          0.9080e+02, 0.9517e+02, 0.1000e+03, 0.1200e+03, 0.1500e+03, 0.1670e+03]
+    real(wp),parameter,dimension(nwlt,4) :: &
+         tabimt = reshape(source= &
+        (/0.8300e-01, 0.6900e-01, 0.5700e-01, 0.4560e-01, 0.3790e-01, 0.3140e-01, &
+          0.2620e-01, 0.2240e-01, 0.1960e-01, 0.1760e-01, 0.1665e-01, 0.1620e-01, &
+          0.1550e-01, 0.1470e-01, 0.1390e-01, 0.1320e-01, 0.1250e-01, 0.1180e-01, & 
+          0.1060e-01, 0.9540e-02, 0.8560e-02, 0.6210e-02, 0.4490e-02, 0.3240e-02, &
+          0.2340e-02, 0.1880e-02, 0.1740e-02, 0.1500e-02, 0.1320e-02, 0.1160e-02, &
+          0.8800e-03, 0.6950e-03, 0.4640e-03, 0.3400e-03, 0.3110e-03, 0.2940e-03, &
+          0.2790e-03, 0.2700e-03, 0.2640e-03, 0.2580e-03, 0.2520e-03, 0.2490e-03, &
+          0.2540e-03, 0.2640e-03, 0.2740e-03, 0.2890e-03, 0.3050e-03, 0.3150e-03, &
+          0.3460e-03, 0.3820e-03, 0.4620e-03, 0.5000e-03, 0.5500e-03, 0.5950e-03, &
+          0.6470e-03, 0.6920e-03, 0.7420e-03, 0.8200e-03, 0.9700e-03, 0.1950e-02, &
+          0.5780e-02, 0.9700e-02, 0.8300e-01, 0.6900e-01, 0.5700e-01, 0.4560e-01, &
+          0.3790e-01, 0.3140e-01, 0.2620e-01, 0.2240e-01, 0.1960e-01, 0.1760e-01, &
+          0.1665e-01, 0.1600e-01, 0.1500e-01, 0.1400e-01, 0.1310e-01, 0.1230e-01, &
+          0.1150e-01, 0.1080e-01, 0.9460e-02, 0.8290e-02, 0.7270e-02, 0.4910e-02, &
+          0.3300e-02, 0.2220e-02, 0.1490e-02, 0.1140e-02, 0.1060e-02, 0.9480e-03, &
+          0.8500e-03, 0.7660e-03, 0.6300e-03, 0.5200e-03, 0.3840e-03, 0.2960e-03, &
+          0.2700e-03, 0.2520e-03, 0.2440e-03, 0.2360e-03, 0.2300e-03, 0.2280e-03, &
+          0.2250e-03, 0.2200e-03, 0.2160e-03, 0.2170e-03, 0.2200e-03, 0.2250e-03, &
+          0.2320e-03, 0.2390e-03, 0.2600e-03, 0.2860e-03, 0.3560e-03, 0.3830e-03, &
+          0.4150e-03, 0.4450e-03, 0.4760e-03, 0.5080e-03, 0.5400e-03, 0.5860e-03, &
+          0.6780e-03, 0.1280e-02, 0.3550e-02, 0.5600e-02, 0.8300e-01, 0.6900e-01, &
+          0.5700e-01, 0.4560e-01, 0.3790e-01, 0.3140e-01, 0.2620e-01, 0.2190e-01, &
+          0.1880e-01, 0.1660e-01, 0.1540e-01, 0.1470e-01, 0.1350e-01, 0.1250e-01, &
+          0.1150e-01, 0.1060e-01, 0.9770e-02, 0.9010e-02, 0.7660e-02, 0.6520e-02, &
+          0.5540e-02, 0.3420e-02, 0.2100e-02, 0.1290e-02, 0.7930e-03, 0.5700e-03, &
+          0.5350e-03, 0.4820e-03, 0.4380e-03, 0.4080e-03, 0.3500e-03, 0.3200e-03, &
+          0.2550e-03, 0.2120e-03, 0.2000e-03, 0.1860e-03, 0.1750e-03, 0.1660e-03, &
+          0.1560e-03, 0.1490e-03, 0.1440e-03, 0.1350e-03, 0.1210e-03, 0.1160e-03, &
+          0.1160e-03, 0.1170e-03, 0.1200e-03, 0.1230e-03, 0.1320e-03, 0.1440e-03, &
+          0.1680e-03, 0.1800e-03, 0.1900e-03, 0.2090e-03, 0.2160e-03, 0.2290e-03, &
+          0.2400e-03, 0.2600e-03, 0.2920e-03, 0.6100e-03, 0.1020e-02, 0.1810e-02, &
+          0.8300e-01, 0.6900e-01, 0.5700e-01, 0.4450e-01, 0.3550e-01, 0.2910e-01, &
+          0.2440e-01, 0.1970e-01, 0.1670e-01, 0.1400e-01, 0.1235e-01, 0.1080e-01, &
+          0.8900e-02, 0.7340e-02, 0.6400e-02, 0.5600e-02, 0.5000e-02, 0.4520e-02, &
+          0.3680e-02, 0.2990e-02, 0.2490e-02, 0.1550e-02, 0.9610e-03, 0.5950e-03, &
+          0.3690e-03, 0.2670e-03, 0.2510e-03, 0.2290e-03, 0.2110e-03, 0.1960e-03, &
+          0.1730e-03, 0.1550e-03, 0.1310e-03, 0.1130e-03, 0.1060e-03, 0.9900e-04, &
+          0.9300e-04, 0.8730e-04, 0.8300e-04, 0.7870e-04, 0.7500e-04, 0.6830e-04, &
+          0.5600e-04, 0.4960e-04, 0.4550e-04, 0.4210e-04, 0.3910e-04, 0.3760e-04, &
+          0.3400e-04, 0.3100e-04, 0.2640e-04, 0.2510e-04, 0.2430e-04, 0.2390e-04, &
+          0.2370e-04, 0.2380e-04, 0.2400e-04, 0.2460e-04, 0.2660e-04, 0.4450e-04, &
+          0.8700e-04, 0.1320e-03/),shape=(/nwlt,4/))
+
+    real(wp),parameter,dimension(nwl) :: &
+         tabre = &
+         [0.83441,   0.83676,   0.83729,   0.83771,   0.83827,   0.84038, &
+          0.84719,   0.85522,   0.86047,   0.86248,   0.86157,   0.86093, &
+          0.86419,   0.86916,   0.87764,   0.89296,   0.91041,   0.93089, &
+          0.95373,   0.98188,   1.02334,   1.06735,   1.11197,   1.13134, &
+          1.15747,   1.20045,   1.23840,   1.27325,   1.32157,   1.38958, &
+          1.41644,   1.40906,   1.40063,   1.40169,   1.40934,   1.40221, &
+          1.39240,   1.38424,   1.38075,   1.38186,   1.39634,   1.40918, &
+          1.40256,   1.38013,   1.36303,   1.34144,   1.32377,   1.30605, &
+          1.29054,   1.28890,   1.28931,   1.30190,   1.32025,   1.36302, &
+          1.41872,   1.45834,   1.49028,   1.52128,   1.55376,   1.57782, &
+          1.59636,   1.60652,   1.61172,   1.61919,   1.62522,   1.63404, &
+          1.63689,   1.63833,   1.63720,   1.63233,   1.62222,   1.58269, &
+          1.55635,   1.52453,   1.50320,   1.48498,   1.47226,   1.45991, &
+          1.45115,   1.44272,   1.43498,   1.43280,   1.42924,   1.42602, &
+          1.42323,   1.42143,   1.41897,   1.41660,   1.41434,   1.41216, &
+          1.41006,   1.40805,   1.40423,   1.40067,   1.38004,   1.35085, &
+          1.33394,   1.32492,   1.31940,   1.31854,   1.31775,   1.31702, &
+          1.31633,   1.31569,   1.31509,   1.31452,   1.31399,   1.31349, &
+          1.31302,   1.31257,   1.31215,   1.31175,   1.31136,   1.31099, &
+          1.31064,   1.31031,   1.30999,   1.30968,   1.30938,   1.30909, &
+          1.30882,   1.30855,   1.30829,   1.30804,   1.30780,   1.30756, &
+          1.30733,   1.30710,   1.30688,   1.30667,   1.30646,   1.30625, &
+          1.30605,   1.30585,   1.30566,   1.30547,   1.30528,   1.30509, &
+          1.30491,   1.30473,   1.30455,   1.30437,   1.30419,   1.30402, &
+          1.30385,   1.30367,   1.30350,   1.30333,   1.30316,   1.30299, &
+          1.30283,   1.30266,   1.30249,   1.30232,   1.30216,   1.30199, &
+          1.30182,   1.30166,   1.30149,   1.30132,   1.30116,   1.30099, &
+          1.30082,   1.30065,   1.30048,   1.30031,   1.30014,   1.29997, &
+          1.29979,   1.29962,   1.29945,   1.29927,   1.29909,   1.29891, &
+          1.29873,   1.29855,   1.29837,   1.29818,   1.29800,   1.29781, &
+          1.29762,   1.29743,   1.29724,   1.29705,   1.29686,   1.29666, &
+          1.29646,   1.29626,   1.29605,   1.29584,   1.29563,   1.29542, &
+          1.29521,   1.29499,   1.29476,   1.29453,   1.29430,   1.29406, &
+          1.29381,   1.29355,   1.29327,   1.29299,   1.29272,   1.29252, &
+          1.29228,   1.29205,   1.29186,   1.29167,   1.29150,   1.29130, &
+          1.29106,   1.29083,   1.29025,   1.28962,   1.28891,   1.28784, &
+          1.28689,   1.28623,   1.28521,   1.28413,   1.28261,   1.28137, &
+          1.28093,   1.28047,   1.28022,   1.27998,   1.27948,   1.27849, &
+          1.27774,   1.27691,   1.27610,   1.27535,   1.27471,   1.27404, &
+          1.27329,   1.27240,   1.27139,   1.27029,   1.26901,   1.26736, &
+          1.26591,   1.26441,   1.26284,   1.26036,   1.25860,   1.25815, &
+          1.25768,   1.25675,   1.25579,   1.25383,   1.25179,   1.24967, &
+          1.24745,   1.24512,   1.24266,   1.24004,   1.23725,   1.23270, &
+          1.22583,   1.22198,   1.21548,   1.21184,   1.20790,   1.20507, &
+          1.20209,   1.19566,   1.17411,   1.14734,   1.10766,   1.06739, &
+          1.04762,   1.02650,   1.00357,   0.98197,   0.96503,   0.95962, &
+          0.97269,   0.99172,   1.00668,   1.02186,   1.04270,   1.07597, &
+          1.12954,   1.21267,   1.32509,   1.42599,   1.49656,   1.55095, &
+          1.59988,   1.63631,   1.65024,   1.64278,   1.62691,   1.61284, &
+          1.59245,   1.57329,   1.55770,   1.54129,   1.52654,   1.51139, &
+          1.49725,   1.48453,   1.47209,   1.46125,   1.45132,   1.44215, &
+          1.43366,   1.41553,   1.39417,   1.38732,   1.37735,   1.36448, &
+          1.35414,   1.34456,   1.33882,   1.33807,   1.33847,   1.34053, &
+          1.34287,   1.34418,   1.34634,   1.34422,   1.33453,   1.32897, &
+          1.32333,   1.31800,   1.31432,   1.30623,   1.29722,   1.28898, &
+          1.28730,   1.28603,   1.28509,   1.28535,   1.28813,   1.30156, &
+          1.30901,   1.31720,   1.31893,   1.32039,   1.32201,   1.32239, &
+          1.32149,   1.32036,   1.31814,   1.31705,   1.31807,   1.31953, &
+          1.31933,   1.31896,   1.31909,   1.31796,   1.31631,   1.31542, &
+          1.31540,   1.31552,   1.31455,   1.31193,   1.30677,   1.29934, &
+          1.29253,   1.28389,   1.27401,   1.26724,   1.25990,   1.24510, &
+          1.22241,   1.19913,   1.17150,   1.15528,   1.13700,   1.11808, &
+          1.10134,   1.09083,   1.08734,   1.09254,   1.10654,   1.14779, &
+          1.20202,   1.25825,   1.32305,   1.38574,   1.44478,   1.47170, &
+          1.49619,   1.51652,   1.53328,   1.54900,   1.56276,   1.57317, &
+          1.58028,   1.57918,   1.56672,   1.55869,   1.55081,   1.53807, &
+          1.53296,   1.53220,   1.53340,   1.53289,   1.51705,   1.50097, &
+          1.49681,   1.49928,   1.50153,   1.49856,   1.49053,   1.46070, &
+          1.45182,   1.44223,   1.43158,   1.41385,   1.40676,   1.38955, &
+          1.34894,   1.31039,   1.26420,   1.23656,   1.21663,   1.20233, &
+          1.19640,   1.19969,   1.20860,   1.22173,   1.24166,   1.28175, &
+          1.32784,   1.38657,   1.46486,   1.55323,   1.60379,   1.61877, &
+          1.62963,   1.65712,   1.69810,   1.72065,   1.74865,   1.76736, &
+          1.76476,   1.75011,   1.72327,   1.68490,   1.62398,   1.59596, &
+          1.58514,   1.59917,   1.61405,   1.66625,   1.70663,   1.73713, &
+          1.76860,   1.80343,   1.83296,   1.85682,   1.87411,   1.89110, &
+          1.89918,   1.90432,   1.90329,   1.88744,   1.87499,   1.86702, &
+          1.85361,   1.84250,   1.83225,   1.81914,   1.82268,   1.82961]
+    real(wp),parameter,dimension(nwlt,4) :: &
+         tabret = reshape( &
+           source =(/1.82961,   1.83258,   1.83149, &
+          1.82748,   1.82224,   1.81718,   1.81204,   1.80704,   1.80250, &
+          1.79834,   1.79482,   1.79214,   1.78843,   1.78601,   1.78434, &
+          1.78322,   1.78248,   1.78201,   1.78170,   1.78160,   1.78190, &
+          1.78300,   1.78430,   1.78520,   1.78620,   1.78660,   1.78680, &
+          1.78690,   1.78700,   1.78700,   1.78710,   1.78710,   1.78720, &
+          1.78720,   1.78720,   1.78720,   1.78720,   1.78720,   1.78720, &
+          1.78720,   1.78720,   1.78720,   1.78720,   1.78720,   1.78720, &
+          1.78720,   1.78720,   1.78720,   1.78720,   1.78720,   1.78720, &
+          1.78720,   1.78720,   1.78720,   1.78720,   1.78720,   1.78720, &
+          1.78720,   1.78720,   1.78720,   1.78720,   1.78800,            &
+          1.82961,   1.83258,   1.83149,   1.82748,                       &
+          1.82224,   1.81718,   1.81204,   1.80704,   1.80250,   1.79834, &
+          1.79482,   1.79214,   1.78843,   1.78601,   1.78434,   1.78322, &
+          1.78248,   1.78201,   1.78170,   1.78160,   1.78190,   1.78300, &
+          1.78430,   1.78520,   1.78610,   1.78630,   1.78640,   1.78650, &
+          1.78650,   1.78650,   1.78650,   1.78650,   1.78650,   1.78650, &
+          1.78650,   1.78650,   1.78650,   1.78650,   1.78650,   1.78650, &
+          1.78650,   1.78650,   1.78650,   1.78650,   1.78650,   1.78650, &
+          1.78650,   1.78650,   1.78650,   1.78650,   1.78650,   1.78650, &
+          1.78650,   1.78650,   1.78650,   1.78650,   1.78650,   1.78650, &
+          1.78650,   1.78650,   1.78650,   1.78720,                       &
+          1.82961,   1.83258,   1.83149,   1.82748,   1.82224,            &
+          1.81718,   1.81204,   1.80704,   1.80250,   1.79834,   1.79482, &
+          1.79214,   1.78843,   1.78601,   1.78434,   1.78322,   1.78248, &
+          1.78201,   1.78160,   1.78140,   1.78160,   1.78220,   1.78310, &
+          1.78380,   1.78390,   1.78400,   1.78400,   1.78400,   1.78400, &
+          1.78400,   1.78390,   1.78380,   1.78370,   1.78370,   1.78370, &
+          1.78370,   1.78370,   1.78370,   1.78370,   1.78370,   1.78370, &
+          1.78370,   1.78370,   1.78370,   1.78370,   1.78370,   1.78370, &
+          1.78370,   1.78370,   1.78370,   1.78370,   1.78370,   1.78370, &
+          1.78370,   1.78370,   1.78370,   1.78370,   1.78370,   1.78370, &
+          1.78370,   1.78400,   1.78450,                                  &
+          1.82961,   1.83258,   1.83149,   1.82748,   1.82224,   1.81718, &
+          1.81204,   1.80704,   1.80250,   1.79834,   1.79482,   1.79214, &
+          1.78843,   1.78601,   1.78434,   1.78322,   1.78248,   1.78201, &
+          1.78150,   1.78070,   1.78010,   1.77890,   1.77790,   1.77730, &
+          1.77720,   1.77720,   1.77720,   1.77720,   1.77720,   1.77720, &
+          1.77720,   1.77720,   1.77720,   1.77720,   1.77720,   1.77720, &
+          1.77720,   1.77720,   1.77720,   1.77720,   1.77720,   1.77720, &
+          1.77720,   1.77720,   1.77720,   1.77720,   1.77720,   1.77720, &
+          1.77720,   1.77720,   1.77720,   1.77720,   1.77720,   1.77720, &
+          1.77720,   1.77720,   1.77720,   1.77720,   1.77720,   1.77720, &
+          1.77720,   1.77800/),shape=(/nwlt,4/))
+
+    ! #####################################################################
+    ! Defines wavelength dependent complex index of refraction for ice.
+    ! Allowable wavelength range extends from 0.045 microns to 8.6 meter
+    ! temperature dependence only considered beyond 167 microns.
+    ! 
+    ! interpolation is done     n_r  vs. log(xlam)
+    !                           n_r  vs.        t
+    !                       log(n_i) vs. log(xlam)
+    !                       log(n_i) vs.        t
+    !
+    ! Stephen G. Warren - 1983
+    ! Dept. of Atmospheric Sciences
+    ! University of Washington
+    ! Seattle, Wa  98195
+    !
+    ! Based on
+    !
+    !    Warren,S.G.,1984.
+    !    Optical constants of ice from the ultraviolet to the microwave.
+    !    Applied Optics,23,1206-1225
+    !
+    ! Reference temperatures are -1.0,-5.0,-20.0, and -60.0 deg C
+    ! #####################################################################
+
+    pi  = acos(-1._wp)
+    n_r = 0._wp
+    n_i = 0._wp
+    tk  = t
+    
+    ! Convert frequency to wavelength (um)
+    alam=3E5_wp/freq
+    if((alam < wlmin) .or. (alam > wlmax)) then
+       call errorMessage('FATAL ERROR(optics/optics_lib.f90:m_ice): wavelength out of bounds')
+       return
+    endif
+    
+    if (alam < cutice) then
+       ! Region from 0.045 microns to 167.0 microns - no temperature depend
+       do i=2,nwl
+          if(alam < wl(i)) continue
+       enddo
+       x1  = log(wl(i-1))
+       x2  = log(wl(i))
+       y1  = tabre(i-1)
+       y2  = tabre(i)
+       x   = log(alam)
+       y   = ((x-x1)*(y2-y1)/(x2-x1))+y1
+       n_r = y
+       y1  = log(abs(tabim(i-1)))
+       y2  = log(abs(tabim(i)))
+       y   = ((x-x1)*(y2-y1)/(x2-x1))+y1
+       n_i = exp(y)    
+    else
+       ! Region from 167.0 microns to 8.6 meters - temperature dependence
+       if(tk > temref(1)) tk=temref(1)
+       if(tk < temref(4)) tk=temref(4)
+       do i=2,4
+          if(tk.ge.temref(i)) go to 12
+       enddo
+12     lt1 = i
+       lt2 = i-1
+       do i=2,nwlt
+          if(alam.le.wlt(i)) go to 14
+       enddo
+14     x1  = log(wlt(i-1))
+       x2  = log(wlt(i))
+       y1  = tabret(i-1,lt1)
+       y2  = tabret(i,lt1)
+       x   = log(alam)
+       ylo = ((x-x1)*(y2-y1)/(x2-x1))+y1
+       y1  = tabret(i-1,lt2)
+       y2  = tabret(i,lt2)
+       yhi = ((x-x1)*(y2-y1)/(x2-x1))+y1
+       t1  = temref(lt1)
+       t2  = temref(lt2)
+       y   = ((tk-t1)*(yhi-ylo)/(t2-t1))+ylo
+       n_r = y
+       y1  = log(abs(tabimt(i-1,lt1)))
+       y2  = log(abs(tabimt(i,lt1)))
+       ylo = ((x-x1)*(y2-y1)/(x2-x1))+y1
+       y1  = log(abs(tabimt(i-1,lt2)))
+       y2  = log(abs(tabimt(i,lt2)))
+       yhi = ((x-x1)*(y2-y1)/(x2-x1))+y1
+       y   = ((tk-t1)*(yhi-ylo)/(t2-t1))+ylo
+       n_i = exp(y)
+    endif
+  end subroutine m_ice
+
+  ! ############################################################################
+  ! subroutine MIEINT
+  ! ############################################################################
+  Subroutine MieInt(Dx, SCm, Inp, Dqv, Dqxt, Dqsc, Dbsc, Dg, Xs1, Xs2, DPh, Error)
+    ! ##########################################################################
+    !
+    !     General purpose Mie scattering routine for single particles
+    !     Author: R Grainger 1990
+    !     History:
+    !     G Thomas, March 2005: Added calculation of Phase function and
+    !     code to ensure correct calculation of backscatter coeficient
+    !     Options/Extend_Source
+    !
+    ! ##########################################################################
+    ! INPUTS
+    integer, intent(in) :: &
+         Inp
+    real(wp),intent(in) :: &
+         Dx !
+    real(wp),intent(in),dimension(Inp) :: &
+         Dqv
+    Complex(wp),intent(in) :: &
+         SCm!
+
+    ! OUTPUTS
+    Complex(wp),intent(out),dimension(InP) :: &
+         Xs1,  & !
+         Xs2     !
+    real(wp),intent(out) :: &
+         Dqxt, & !
+         Dqsc, & !
+         Dg,   & !
+         Dbsc    !
+    real(wp),intent(out),dimension(InP) :: &
+         DPh
+    integer :: &
+         Error   !!
+
+    ! PARAMETERS
+    Integer,parameter :: &
+         Imaxx   = 12000, & !
+         Itermax = 30000, & ! Must be large enough to cope with the
+                            ! largest possible nmx = x * abs(scm) + 15
+                            ! or nmx =  Dx + 4.05*Dx**(1./3.) + 2.0
+         Imaxnp = 10000     ! Change this as required
+    Real(wp),parameter :: &
+         RIMax=2.5,       & ! Largest real part of refractive index
+         IRIMax = -2        ! Largest imaginary part of refractive index
+
+    ! Internal variables
+    Integer :: I, NStop, NmX, N, Inp2
+    Real(wp)  :: Chi,Chi0,Chi1,APsi,APsi0,APsi1,Psi,Psi0,Psi1
+    Real(wp),dimension(Imaxnp) :: Pi0,Pi1,Taun
+    Complex(wp) :: Ir,Cm,A,ANM1,APB,B,BNM1,AMB,Xi,Xi0,Xi1,Y
+    Complex(wp),dimension(Itermax) :: D
+    Complex(wp),dimension(Imaxnp) :: Sp,Sm!
+
+    ! ACCELERATOR VARIABLES
+    Integer :: Tnp1,Tnm1
+    Real(wp) :: Dn, Rnx,Turbo,A2
+    real(wp),dimension(Imaxnp) :: S,T
+    Complex(wp) :: A1
+    
+    If ((Dx.Gt.Imaxx) .Or. (InP.Gt.ImaxNP)) Then
+       Error = 1
+       Return
+    EndIf
+    Cm = SCm
+    Ir = 1 / Cm
+    Y =  Dx * Cm
+    If (Dx.Lt.0.02) Then
+       NStop = 2
+    Else
+       If (Dx.Le.8.0) Then
+          NStop = Dx + 4.00*Dx**(1./3.) + 2.0
+       Else
+          If (Dx.Lt. 4200.0) Then
+             NStop = Dx + 4.05*Dx**(1./3.) + 2.0
+          Else
+             NStop = Dx + 4.00*Dx**(1./3.) + 2.0
+          End If
+       End If
+    End If
+    NmX = Max(Real(NStop),Real(Abs(Y))) + 15.
+    If (Nmx .gt. Itermax) then
+       Error = 1
+       Return
+    End If
+    Inp2 = Inp+1
+!ds    D(NmX) = cmplx(0,0,Kind=Kind(0d0))
+    D(NmX) = cmplx(0,0,Kind=wp)
+    Do N = Nmx-1,1,-1
+       A1 = (N+1) / Y
+       D(N) = A1 - 1/(A1+D(N+1))
+    End Do
+    Do I =1,Inp2
+       Sm(I) = cmplx(0,0,Kind=wp)
+!ds       Sm(I) = cmplx(0,0,Kind=Kind(0d0))
+       Sp(I) = cmplx(0,0,Kind=wp)
+!ds       Sp(I) = cmplx(0,0,Kind=Kind(0d0))
+       Pi0(I) = 0
+       Pi1(I) = 1
+    End Do
+    Psi0 = Cos(Dx)
+    Psi1 = Sin(Dx)
+    Chi0 =-Sin(Dx)
+    Chi1 = Cos(Dx)
+    APsi0 = Psi0
+    APsi1 = Psi1
+    Xi0 = cmplx(APsi0,Chi0,Kind=wp)
+!ds    Xi0 = cmplx(APsi0,Chi0,Kind=Kind(0d0))
+    Xi1 = cmplx(APsi1,Chi1,Kind=wp)
+!ds    Xi1 = cmplx(APsi1,Chi1,Kind=Kind(0d0))
+    Dg = 0
+    Dqsc = 0
+    Dqxt = 0
+    Tnp1 = 1
+    Do N = 1,Nstop
+       DN = N
+       Tnp1 = Tnp1 + 2
+       Tnm1 = Tnp1 - 2
+       A2 = Tnp1 / (DN*(DN+1._wp))
+!ds       A2 = Tnp1 / (DN*(DN+1D0))
+       Turbo = (DN+1._wp) / DN
+!ds       Turbo = (DN+1D0) / DN
+       Rnx = DN/Dx
+       Psi = Tnm1*Psi1/Dx - Psi0
+!ds       Psi = Dble(Tnm1)*Psi1/Dx - Psi0
+       APsi = Psi
+       Chi = Tnm1*Chi1/Dx       - Chi0
+       Xi = cmplx(APsi,Chi,Kind=wp)
+!ds       Xi = cmplx(APsi,Chi,Kind=Kind(0d0))
+       A = ((D(N)*Ir+Rnx)*APsi-APsi1) / ((D(N)*Ir+Rnx)*  Xi-  Xi1)
+       B = ((D(N)*Cm+Rnx)*APsi-APsi1) / ((D(N)*Cm+Rnx)*  Xi-  Xi1)
+       Dqxt = Tnp1*(A + B)+ Dqxt
+!ds       Dqxt = Tnp1 *      Dble(A + B)          + Dqxt
+       Dqsc = Tnp1 * (A*Conjg(A) + B*Conjg(B)) + Dqsc
+       If (N.Gt.1) then
+          Dg = Dg + (dN*dN - 1) * (ANM1*Conjg(A) + BNM1 * Conjg(B)) / dN + TNM1 *(ANM1*Conjg(BNM1)) / (dN*dN - dN)
+!ds          Dg = Dg + (dN*dN - 1) * Dble(ANM1*Conjg(A) + BNM1 * Conjg(B)) / dN + TNM1 * Dble(ANM1*Conjg(BNM1)) / (dN*dN - dN)
+       End If
+       Anm1 = A
+       Bnm1 = B
+       APB = A2 * (A + B)
+       AMB = A2 * (A - B)
+       Do I = 1,Inp2
+          If (I.GT.Inp) Then
+             S(I) = -Pi1(I)
+          Else
+             S(I) = Dqv(I) * Pi1(I)
+          End If
+          T(I) = S(I) - Pi0(I)
+          Taun(I) = N*T(I) - Pi0(I)
+          Sp(I) = APB * (Pi1(I) + Taun(I)) + Sp(I)
+          Sm(I) = AMB * (Pi1(I) - Taun(I)) + Sm(I)
+          Pi0(I) = Pi1(I)
+          Pi1(I) = S(I) + T(I)*Turbo
+       End Do
+       Psi0 = Psi1
+       Psi1 = Psi
+       Apsi1 = Psi1
+       Chi0 = Chi1
+       Chi1 = Chi
+       Xi1 = cmplx(APsi1,Chi1,Kind=wp)
+!ds       Xi1 = cmplx(APsi1,Chi1,Kind=Kind(0d0))
+    End Do
+
+    If (Dg .GT.0) Dg = 2 * Dg / Dqsc
+    Dqsc =  2 * Dqsc / Dx**2
+    Dqxt =  2 * Dqxt / Dx**2
+    Do I = 1,Inp
+       Xs1(I) = (Sp(I)+Sm(I)) / 2
+       Xs2(I) = (Sp(I)-Sm(I)) / 2
+       Dph(I) = 2 * (Xs1(I)*Conjg(Xs1(I)) + Xs2(I)*Conjg(Xs2(I))) / (Dx**2 * Dqsc)
+!ds       Dph(I) = 2 * Dble(Xs1(I)*Conjg(Xs1(I)) + Xs2(I)*Conjg(Xs2(I))) / (Dx**2 * Dqsc)
+    End Do
+    Dbsc = 4 * Abs(( (Sp(Inp2)+Sm(Inp2))/2 )**2) / Dx**2
+    Error = 0
+    Return
+  End subroutine MieInt
+end module optics_lib
Index: DZ6/trunk/libf/phylmd/cospv2/parasol.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cospv2/parasol.F90	(revision 5267)
+++ 	(revision )
@@ -1,176 +1,0 @@
-! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-! Copyright (c) 2009, Centre National de la Recherche Scientifique
-! All rights reserved.
-!
-! Redistribution and use in source and binary forms, with or without modification, are 
-! permitted provided that the following conditions are met:
-!
-! 1. Redistributions of source code must retain the above copyright notice, this list of 
-!    conditions and the following disclaimer.
-!
-! 2. Redistributions in binary form must reproduce the above copyright notice, this list
-!    of conditions and the following disclaimer in the documentation and/or other 
-!    materials provided with the distribution.
-!
-! 3. Neither the name of the copyright holder nor the names of its contributors may be 
-!    used to endorse or promote products derived from this software without specific prior
-!    written permission.
-!
-! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY 
-! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 
-! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL 
-! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 
-! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT 
-! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 
-! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
-! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-!
-! History
-! December 2008, S. Bony,  H. Chepfer and J-L. Dufresne : 
-! - optimization for vectorization
-! Version 2.0 (October 2008)
-! Version 2.1 (December 2008)
-! May 2015 - D. Swales - Modified for COSPv2.0
-! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-module mod_parasol
-  USE COSP_KINDS,          ONLY: wp
-  USE COSP_MATH_CONSTANTS, ONLY: pi
-  use mod_cosp_config,     ONLY: R_UNDEF,PARASOL_NREFL,PARASOL_NTAU,PARASOL_TAU,PARASOL_SZA,rlumA,rlumB
-  implicit none
-
-contains
-  SUBROUTINE parasol_subcolumn(npoints,nrefl,tautot_S_liq,tautot_S_ice,refl)
-    ! ##########################################################################
-    ! Purpose: To compute Parasol reflectance signal from model-simulated profiles 
-    !          of cloud water and cloud fraction in each sub-column of each model 
-    !          gridbox.
-    !
-    !
-    ! December 2008, S. Bony,  H. Chepfer and J-L. Dufresne : 
-    ! - optimization for vectorization
-    !
-    ! Version 2.0 (October 2008)
-    ! Version 2.1 (December 2008)
-    ! ##########################################################################
-    
-    ! INPUTS
-    INTEGER,intent(in) :: &
-         npoints,              & ! Number of horizontal gridpoints
-         nrefl                   ! Number of angles for which the reflectance is computed
-    REAL(WP),intent(inout),dimension(npoints) :: &
-         tautot_S_liq,         & ! Liquid water optical thickness, from TOA to SFC
-         tautot_S_ice            ! Ice water optical thickness, from TOA to SFC
-    ! OUTPUTS
-    REAL(WP),intent(inout),dimension(npoints,nrefl) :: &
-         refl                    ! Parasol reflectances
-    
-    ! LOCAL VARIABLES
-    REAL(WP),dimension(npoints) :: &
-         tautot_S,             & ! Cloud optical thickness, from TOA to surface
-         frac_taucol_liq,      & !
-         frac_taucol_ice         !
-    
-    ! Look up table variables:
-    INTEGER                            :: ny,it 
-    REAL(WP),dimension(PARASOL_NREFL)         :: r_norm
-    REAL(WP),dimension(PARASOL_NREFL,PARASOL_NTAU-1) :: aa,ab,ba,bb
-    REAL(WP),dimension(npoints,5)      :: rlumA_mod,rlumB_mod
-    
-    !--------------------------------------------------------------------------------
-    ! Lum_norm=f(PARASOL_SZA,tau_cloud) derived from adding-doubling calculations
-    !        valid ONLY ABOVE OCEAN (albedo_sfce=5%)
-    !        valid only in one viewing direction (theta_v=30�, phi_s-phi_v=320�)
-    !        based on adding-doubling radiative transfer computation
-    !        for PARASOL_TAU values (0 to 100) and for PARASOL_SZA values (0 to 80)
-    !        for 2 scattering phase functions: liquid spherical, ice non spherical
-    
-    ! Initialize
-    rlumA_mod(1:npoints,1:5) = 0._wp
-    rlumB_mod(1:npoints,1:5) = 0._wp
-
-    r_norm(1:PARASOL_NREFL)=1._wp/ cos(pi/180._wp*PARASOL_SZA(1:PARASOL_NREFL))
-    
-    tautot_S_liq(1:npoints) = max(tautot_S_liq(1:npoints),PARASOL_TAU(1))
-    tautot_S_ice(1:npoints) = max(tautot_S_ice(1:npoints),PARASOL_TAU(1))
-    tautot_S(1:npoints)     = tautot_S_ice(1:npoints) + tautot_S_liq(1:npoints)
-
-    ! Relative fraction of the opt. thick due to liquid or ice clouds
-    WHERE (tautot_S(1:npoints) .gt. 0.)
-       frac_taucol_liq(1:npoints) = tautot_S_liq(1:npoints) / tautot_S(1:npoints)
-       frac_taucol_ice(1:npoints) = tautot_S_ice(1:npoints) / tautot_S(1:npoints)
-    ELSEWHERE
-       frac_taucol_liq(1:npoints) = 1._wp
-       frac_taucol_ice(1:npoints) = 0._wp
-    END WHERE
-    tautot_S(1:npoints)=MIN(tautot_S(1:npoints),PARASOL_TAU(PARASOL_NTAU))
-    
-    ! Linear interpolation    
-    DO ny=1,PARASOL_NTAU-1
-       ! Microphysics A (liquid clouds) 
-       aA(1:PARASOL_NREFL,ny) = (rlumA(1:PARASOL_NREFL,ny+1)-rlumA(1:PARASOL_NREFL,ny))/(PARASOL_TAU(ny+1)-PARASOL_TAU(ny))
-       bA(1:PARASOL_NREFL,ny) = rlumA(1:PARASOL_NREFL,ny) - aA(1:PARASOL_NREFL,ny)*PARASOL_TAU(ny)
-       ! Microphysics B (ice clouds)
-       aB(1:PARASOL_NREFL,ny) = (rlumB(1:PARASOL_NREFL,ny+1)-rlumB(1:PARASOL_NREFL,ny))/(PARASOL_TAU(ny+1)-PARASOL_TAU(ny))
-       bB(1:PARASOL_NREFL,ny) = rlumB(1:PARASOL_NREFL,ny) - aB(1:PARASOL_NREFL,ny)*PARASOL_TAU(ny)
-    ENDDO
-    
-    DO it=1,PARASOL_NREFL
-       DO ny=1,PARASOL_NTAU-1
-          WHERE (tautot_S(1:npoints) .ge. PARASOL_TAU(ny).and. &
-                 tautot_S(1:npoints) .le. PARASOL_TAU(ny+1))
-             rlumA_mod(1:npoints,it) = aA(it,ny)*tautot_S(1:npoints) + bA(it,ny)
-             rlumB_mod(1:npoints,it) = aB(it,ny)*tautot_S(1:npoints) + bB(it,ny)
-          END WHERE
-       END DO
-    END DO
-    
-    DO it=1,PARASOL_NREFL
-       refl(1:npoints,it) = frac_taucol_liq(1:npoints) * rlumA_mod(1:npoints,it) &
-            + frac_taucol_ice(1:npoints) * rlumB_mod(1:npoints,it)
-       ! Normalized radiance -> reflectance: 
-       refl(1:npoints,it) = refl(1:npoints,it) * r_norm(it)
-    ENDDO
-    
-    RETURN
-  END SUBROUTINE parasol_subcolumn
-  ! ######################################################################################
-  ! SUBROUTINE parasol_gridbox
-  ! ######################################################################################
-  subroutine parasol_column(npoints,nrefl,ncol,land,refl,parasolrefl)
-
-    ! Inputs
-    integer,intent(in) :: &
-         npoints, & ! Number of horizontal grid points
-         ncol,    & ! Number of subcolumns
-         nrefl      ! Number of solar zenith angles for parasol reflectances
-    real(wp),intent(in),dimension(npoints) :: &
-         land       ! Landmask [0 - Ocean, 1 - Land]
-    real(wp),intent(in),dimension(npoints,ncol,nrefl) :: &
-         refl       ! Subgrid parasol reflectance ! parasol
-
-    ! Outputs
-    real(wp),intent(out),dimension(npoints,nrefl) :: &
-         parasolrefl   ! Grid-averaged parasol reflectance
-
-    ! Local variables
-    integer :: k,ic
-
-    ! Compute grid-box averaged Parasol reflectances
-    parasolrefl(:,:) = 0._wp
-    do k = 1, nrefl
-       do ic = 1, ncol
-          parasolrefl(:,k) = parasolrefl(:,k) + refl(:,ic,k)
-       enddo
-    enddo
-    
-    do k = 1, nrefl
-       parasolrefl(:,k) = parasolrefl(:,k) / float(ncol)
-       ! if land=1 -> parasolrefl=R_UNDEF
-       ! if land=0 -> parasolrefl=parasolrefl
-       parasolrefl(:,k) = parasolrefl(:,k) * MAX(1._wp-land(:),0.0) &
-            + (1._wp - MAX(1._wp-land(:),0.0))*R_UNDEF
-    enddo
-  end subroutine parasol_column
-
-end module mod_parasol
Index: /LMDZ6/trunk/libf/phylmd/cospv2/parasol.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cospv2/parasol.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/cospv2/parasol.f90	(revision 5268)
@@ -0,0 +1,176 @@
+! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+! Copyright (c) 2009, Centre National de la Recherche Scientifique
+! All rights reserved.
+!
+! Redistribution and use in source and binary forms, with or without modification, are 
+! permitted provided that the following conditions are met:
+!
+! 1. Redistributions of source code must retain the above copyright notice, this list of 
+!    conditions and the following disclaimer.
+!
+! 2. Redistributions in binary form must reproduce the above copyright notice, this list
+!    of conditions and the following disclaimer in the documentation and/or other 
+!    materials provided with the distribution.
+!
+! 3. Neither the name of the copyright holder nor the names of its contributors may be 
+!    used to endorse or promote products derived from this software without specific prior
+!    written permission.
+!
+! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY 
+! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 
+! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL 
+! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 
+! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT 
+! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 
+! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+!
+! History
+! December 2008, S. Bony,  H. Chepfer and J-L. Dufresne : 
+! - optimization for vectorization
+! Version 2.0 (October 2008)
+! Version 2.1 (December 2008)
+! May 2015 - D. Swales - Modified for COSPv2.0
+! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+module mod_parasol
+  USE COSP_KINDS,          ONLY: wp
+  USE COSP_MATH_CONSTANTS, ONLY: pi
+  use mod_cosp_config,     ONLY: R_UNDEF,PARASOL_NREFL,PARASOL_NTAU,PARASOL_TAU,PARASOL_SZA,rlumA,rlumB
+  implicit none
+
+contains
+  SUBROUTINE parasol_subcolumn(npoints,nrefl,tautot_S_liq,tautot_S_ice,refl)
+    ! ##########################################################################
+    ! Purpose: To compute Parasol reflectance signal from model-simulated profiles 
+    !          of cloud water and cloud fraction in each sub-column of each model 
+    !          gridbox.
+    !
+    !
+    ! December 2008, S. Bony,  H. Chepfer and J-L. Dufresne : 
+    ! - optimization for vectorization
+    !
+    ! Version 2.0 (October 2008)
+    ! Version 2.1 (December 2008)
+    ! ##########################################################################
+    
+    ! INPUTS
+    INTEGER,intent(in) :: &
+         npoints,              & ! Number of horizontal gridpoints
+         nrefl                   ! Number of angles for which the reflectance is computed
+    REAL(WP),intent(inout),dimension(npoints) :: &
+         tautot_S_liq,         & ! Liquid water optical thickness, from TOA to SFC
+         tautot_S_ice            ! Ice water optical thickness, from TOA to SFC
+    ! OUTPUTS
+    REAL(WP),intent(inout),dimension(npoints,nrefl) :: &
+         refl                    ! Parasol reflectances
+    
+    ! LOCAL VARIABLES
+    REAL(WP),dimension(npoints) :: &
+         tautot_S,             & ! Cloud optical thickness, from TOA to surface
+         frac_taucol_liq,      & !
+         frac_taucol_ice         !
+    
+    ! Look up table variables:
+    INTEGER                            :: ny,it 
+    REAL(WP),dimension(PARASOL_NREFL)         :: r_norm
+    REAL(WP),dimension(PARASOL_NREFL,PARASOL_NTAU-1) :: aa,ab,ba,bb
+    REAL(WP),dimension(npoints,5)      :: rlumA_mod,rlumB_mod
+    
+    !--------------------------------------------------------------------------------
+    ! Lum_norm=f(PARASOL_SZA,tau_cloud) derived from adding-doubling calculations
+    !        valid ONLY ABOVE OCEAN (albedo_sfce=5%)
+    !        valid only in one viewing direction (theta_v=30�, phi_s-phi_v=320�)
+    !        based on adding-doubling radiative transfer computation
+    !        for PARASOL_TAU values (0 to 100) and for PARASOL_SZA values (0 to 80)
+    !        for 2 scattering phase functions: liquid spherical, ice non spherical
+    
+    ! Initialize
+    rlumA_mod(1:npoints,1:5) = 0._wp
+    rlumB_mod(1:npoints,1:5) = 0._wp
+
+    r_norm(1:PARASOL_NREFL)=1._wp/ cos(pi/180._wp*PARASOL_SZA(1:PARASOL_NREFL))
+    
+    tautot_S_liq(1:npoints) = max(tautot_S_liq(1:npoints),PARASOL_TAU(1))
+    tautot_S_ice(1:npoints) = max(tautot_S_ice(1:npoints),PARASOL_TAU(1))
+    tautot_S(1:npoints)     = tautot_S_ice(1:npoints) + tautot_S_liq(1:npoints)
+
+    ! Relative fraction of the opt. thick due to liquid or ice clouds
+    WHERE (tautot_S(1:npoints) .gt. 0.)
+       frac_taucol_liq(1:npoints) = tautot_S_liq(1:npoints) / tautot_S(1:npoints)
+       frac_taucol_ice(1:npoints) = tautot_S_ice(1:npoints) / tautot_S(1:npoints)
+    ELSEWHERE
+       frac_taucol_liq(1:npoints) = 1._wp
+       frac_taucol_ice(1:npoints) = 0._wp
+    END WHERE
+    tautot_S(1:npoints)=MIN(tautot_S(1:npoints),PARASOL_TAU(PARASOL_NTAU))
+    
+    ! Linear interpolation    
+    DO ny=1,PARASOL_NTAU-1
+       ! Microphysics A (liquid clouds) 
+       aA(1:PARASOL_NREFL,ny) = (rlumA(1:PARASOL_NREFL,ny+1)-rlumA(1:PARASOL_NREFL,ny))/(PARASOL_TAU(ny+1)-PARASOL_TAU(ny))
+       bA(1:PARASOL_NREFL,ny) = rlumA(1:PARASOL_NREFL,ny) - aA(1:PARASOL_NREFL,ny)*PARASOL_TAU(ny)
+       ! Microphysics B (ice clouds)
+       aB(1:PARASOL_NREFL,ny) = (rlumB(1:PARASOL_NREFL,ny+1)-rlumB(1:PARASOL_NREFL,ny))/(PARASOL_TAU(ny+1)-PARASOL_TAU(ny))
+       bB(1:PARASOL_NREFL,ny) = rlumB(1:PARASOL_NREFL,ny) - aB(1:PARASOL_NREFL,ny)*PARASOL_TAU(ny)
+    ENDDO
+    
+    DO it=1,PARASOL_NREFL
+       DO ny=1,PARASOL_NTAU-1
+          WHERE (tautot_S(1:npoints) .ge. PARASOL_TAU(ny).and. &
+                 tautot_S(1:npoints) .le. PARASOL_TAU(ny+1))
+             rlumA_mod(1:npoints,it) = aA(it,ny)*tautot_S(1:npoints) + bA(it,ny)
+             rlumB_mod(1:npoints,it) = aB(it,ny)*tautot_S(1:npoints) + bB(it,ny)
+          END WHERE
+       END DO
+    END DO
+    
+    DO it=1,PARASOL_NREFL
+       refl(1:npoints,it) = frac_taucol_liq(1:npoints) * rlumA_mod(1:npoints,it) &
+            + frac_taucol_ice(1:npoints) * rlumB_mod(1:npoints,it)
+       ! Normalized radiance -> reflectance: 
+       refl(1:npoints,it) = refl(1:npoints,it) * r_norm(it)
+    ENDDO
+    
+    RETURN
+  END SUBROUTINE parasol_subcolumn
+  ! ######################################################################################
+  ! SUBROUTINE parasol_gridbox
+  ! ######################################################################################
+  subroutine parasol_column(npoints,nrefl,ncol,land,refl,parasolrefl)
+
+    ! Inputs
+    integer,intent(in) :: &
+         npoints, & ! Number of horizontal grid points
+         ncol,    & ! Number of subcolumns
+         nrefl      ! Number of solar zenith angles for parasol reflectances
+    real(wp),intent(in),dimension(npoints) :: &
+         land       ! Landmask [0 - Ocean, 1 - Land]
+    real(wp),intent(in),dimension(npoints,ncol,nrefl) :: &
+         refl       ! Subgrid parasol reflectance ! parasol
+
+    ! Outputs
+    real(wp),intent(out),dimension(npoints,nrefl) :: &
+         parasolrefl   ! Grid-averaged parasol reflectance
+
+    ! Local variables
+    integer :: k,ic
+
+    ! Compute grid-box averaged Parasol reflectances
+    parasolrefl(:,:) = 0._wp
+    do k = 1, nrefl
+       do ic = 1, ncol
+          parasolrefl(:,k) = parasolrefl(:,k) + refl(:,ic,k)
+       enddo
+    enddo
+    
+    do k = 1, nrefl
+       parasolrefl(:,k) = parasolrefl(:,k) / float(ncol)
+       ! if land=1 -> parasolrefl=R_UNDEF
+       ! if land=0 -> parasolrefl=parasolrefl
+       parasolrefl(:,k) = parasolrefl(:,k) * MAX(1._wp-land(:),0.0) &
+            + (1._wp - MAX(1._wp-land(:),0.0))*R_UNDEF
+    enddo
+  end subroutine parasol_column
+
+end module mod_parasol
Index: DZ6/trunk/libf/phylmd/cospv2/prec_scops.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cospv2/prec_scops.F90	(revision 5267)
+++ 	(revision )
@@ -1,277 +1,0 @@
-! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-! Copyright (c) 2008, Lawrence Livermore National Security Limited Liability Corporation
-! All rights reserved.
-!
-! Redistribution and use in source and binary forms, with or without modification, are 
-! permitted provided that the following conditions are met:
-!
-! 1. Redistributions of source code must retain the above copyright notice, this list of 
-!    conditions and the following disclaimer.
-!
-! 2. Redistributions in binary form must reproduce the above copyright notice, this list
-!    of conditions and the following disclaimer in the documentation and/or other 
-!    materials provided with the distribution.
-!
-! 3. Neither the name of the copyright holder nor the names of its contributors may be 
-!    used to endorse or promote products derived from this software without specific prior
-!    written permission.
-!
-! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY 
-! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 
-! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL 
-! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 
-! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT 
-! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 
-! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
-! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-!
-! History:
-! May 2015- D. Swales - Modified for COSPv2.0
-! 
-! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-module mod_prec_scops
-   implicit none
-contains
-      
-      subroutine prec_scops(npoints,nlev,ncol,ls_p_rate,cv_p_rate,frac_out,prec_frac)
-
-        USE COSP_KINDS, ONLY: wp
-        use mod_cosp_config, ONLY: scops_ccfrac
-
-      INTEGER npoints       !  number of model points in the horizontal
-      INTEGER nlev          !  number of model levels in column
-      INTEGER ncol          !  number of subcolumns
-
-      INTEGER j,ilev,ibox,cv_col
-      
-      REAL(WP) ls_p_rate(npoints,nlev),cv_p_rate(npoints,nlev)
-
-      REAL(WP) frac_out(npoints,ncol,nlev) ! boxes gridbox divided up into
-                              ! Equivalent of BOX in original version, but
-                              ! indexed by column then row, rather than
-                              ! by row then column
-                              !TOA to SURFACE!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-      REAL(WP) prec_frac(npoints,ncol,nlev) ! 0 -> clear sky
-                                        ! 1 -> LS precipitation
-                                        ! 2 -> CONV precipitation
-                    ! 3 -> both
-                                        !TOA to SURFACE!!!!!!!!!!!!!!!!!!
-                    
-      INTEGER flag_ls, flag_cv
-      INTEGER frac_out_ls(npoints,ncol),frac_out_cv(npoints,ncol) !flag variables for 
-                       ! stratiform cloud and convective cloud in the vertical column
-
-      cv_col = scops_ccfrac*ncol
-      if (cv_col .eq. 0) cv_col=1
- 
-      do ilev=1,nlev
-        do ibox=1,ncol
-          do j=1,npoints 
-            prec_frac(j,ibox,ilev) = 0
-          enddo
-        enddo
-      enddo
-      
-      do j=1,npoints
-       do ibox=1,ncol
-        frac_out_ls(j,ibox)=0
-        frac_out_cv(j,ibox)=0
-        flag_ls=0
-        flag_cv=0
-        do ilev=1,nlev
-          if (frac_out(j,ibox,ilev) .eq. 1) then 
-            flag_ls=1
-          endif
-          if (frac_out(j,ibox,ilev) .eq. 2) then 
-            flag_cv=1
-          endif
-        enddo !loop over nlev
-        if (flag_ls .eq. 1) then
-           frac_out_ls(j,ibox)=1
-        endif
-        if (flag_cv .eq. 1) then
-           frac_out_cv(j,ibox)=1
-        endif
-       enddo  ! loop over ncol
-      enddo ! loop over npoints
-
-!      initialize the top layer      
-       do j=1,npoints
-        flag_ls=0
-        flag_cv=0
-    
-        if (ls_p_rate(j,1) .gt. 0.) then 
-            do ibox=1,ncol ! possibility ONE
-                if (frac_out(j,ibox,1) .eq. 1) then 
-                    prec_frac(j,ibox,1) = 1
-                    flag_ls=1
-                endif
-            enddo ! loop over ncol
-            if (flag_ls .eq. 0) then ! possibility THREE
-                do ibox=1,ncol
-                    if (frac_out(j,ibox,2) .eq. 1) then 
-                        prec_frac(j,ibox,1) = 1
-                        flag_ls=1
-                    endif
-                enddo ! loop over ncol
-            endif
-        if (flag_ls .eq. 0) then ! possibility Four
-        do ibox=1,ncol
-        if (frac_out_ls(j,ibox) .eq. 1) then 
-            prec_frac(j,ibox,1) = 1
-            flag_ls=1
-        endif
-        enddo ! loop over ncol
-        endif
-        if (flag_ls .eq. 0) then ! possibility Five
-        do ibox=1,ncol
-    !     prec_frac(j,1:ncol,1) = 1
-        prec_frac(j,ibox,1) = 1
-        enddo ! loop over ncol
-            endif
-        endif
-       ! There is large scale precipitation
-     
-        if (cv_p_rate(j,1) .gt. 0.) then 
-         do ibox=1,ncol ! possibility ONE
-          if (frac_out(j,ibox,1) .eq. 2) then 
-           if (prec_frac(j,ibox,1) .eq. 0) then
-        prec_frac(j,ibox,1) = 2
-       else
-        prec_frac(j,ibox,1) = 3
-       endif
-       flag_cv=1
-      endif
-        enddo ! loop over ncol
-        if (flag_cv .eq. 0) then ! possibility THREE
-        do ibox=1,ncol
-        if (frac_out(j,ibox,2) .eq. 2) then 
-                if (prec_frac(j,ibox,1) .eq. 0) then
-            prec_frac(j,ibox,1) = 2
-            else
-            prec_frac(j,ibox,1) = 3
-            endif
-            flag_cv=1
-        endif
-        enddo ! loop over ncol
-        endif
-        if (flag_cv .eq. 0) then ! possibility Four
-        do ibox=1,ncol
-        if (frac_out_cv(j,ibox) .eq. 1) then 
-                if (prec_frac(j,ibox,1) .eq. 0) then
-            prec_frac(j,ibox,1) = 2
-            else
-            prec_frac(j,ibox,1) = 3
-            endif
-            flag_cv=1
-        endif
-        enddo ! loop over ncol
-        endif
-        if (flag_cv .eq. 0) then  ! possibility Five
-        do ibox=1,cv_col
-                if (prec_frac(j,ibox,1) .eq. 0) then
-            prec_frac(j,ibox,1) = 2
-            else
-            prec_frac(j,ibox,1) = 3
-            endif 
-        enddo !loop over cv_col
-            endif 
-        endif 
-        ! There is convective precipitation
-        
-        enddo ! loop over npoints
-!      end of initializing the top layer
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-!     working on the levels from top to surface
-      do ilev=2,nlev
-       do j=1,npoints
-        flag_ls=0
-        flag_cv=0
-    
-        if (ls_p_rate(j,ilev) .gt. 0.) then 
-         do ibox=1,ncol ! possibility ONE&TWO
-          if ((frac_out(j,ibox,ilev) .eq. 1) .or. ((prec_frac(j,ibox,ilev-1) .eq. 1)     &
-            .or. (prec_frac(j,ibox,ilev-1) .eq. 3))) then 
-           prec_frac(j,ibox,ilev) = 1
-           flag_ls=1
-          endif
-        enddo ! loop over ncol
-        if ((flag_ls .eq. 0) .and. (ilev .lt. nlev)) then ! possibility THREE
-        do ibox=1,ncol
-        if (frac_out(j,ibox,ilev+1) .eq. 1) then 
-            prec_frac(j,ibox,ilev) = 1
-            flag_ls=1
-        endif
-        enddo ! loop over ncol
-        endif
-        if (flag_ls .eq. 0) then ! possibility Four
-        do ibox=1,ncol
-        if (frac_out_ls(j,ibox) .eq. 1) then 
-            prec_frac(j,ibox,ilev) = 1
-            flag_ls=1
-        endif
-        enddo ! loop over ncol
-        endif
-        if (flag_ls .eq. 0) then ! possibility Five
-        do ibox=1,ncol
-!     prec_frac(j,1:ncol,ilev) = 1
-        prec_frac(j,ibox,ilev) = 1
-        enddo ! loop over ncol
-         endif
-      endif ! There is large scale precipitation
-    
-        if (cv_p_rate(j,ilev) .gt. 0.) then 
-         do ibox=1,ncol ! possibility ONE&TWO
-          if ((frac_out(j,ibox,ilev) .eq. 2) .or. ((prec_frac(j,ibox,ilev-1) .eq. 2)     &
-            .or. (prec_frac(j,ibox,ilev-1) .eq. 3))) then 
-            if (prec_frac(j,ibox,ilev) .eq. 0) then
-         prec_frac(j,ibox,ilev) = 2
-        else
-         prec_frac(j,ibox,ilev) = 3
-        endif 
-        flag_cv=1
-        endif
-       enddo ! loop over ncol
-        if ((flag_cv .eq. 0) .and. (ilev .lt. nlev)) then ! possibility THREE
-        do ibox=1,ncol
-        if (frac_out(j,ibox,ilev+1) .eq. 2) then 
-                if (prec_frac(j,ibox,ilev) .eq. 0) then
-            prec_frac(j,ibox,ilev) = 2
-            else
-            prec_frac(j,ibox,ilev) = 3
-            endif
-            flag_cv=1
-        endif
-        enddo ! loop over ncol
-        endif
-        if (flag_cv .eq. 0) then ! possibility Four
-        do ibox=1,ncol
-        if (frac_out_cv(j,ibox) .eq. 1) then 
-                if (prec_frac(j,ibox,ilev) .eq. 0) then
-            prec_frac(j,ibox,ilev) = 2
-            else
-            prec_frac(j,ibox,ilev) = 3
-            endif
-            flag_cv=1
-        endif
-        enddo ! loop over ncol
-        endif
-        if (flag_cv .eq. 0) then  ! possibility Five 
-        do ibox=1,cv_col
-                if (prec_frac(j,ibox,ilev) .eq. 0) then
-            prec_frac(j,ibox,ilev) = 2
-            else
-            prec_frac(j,ibox,ilev) = 3
-            endif 
-        enddo !loop over cv_col 
-            endif 
-        endif ! There is convective precipitation
-    
-        enddo ! loop over npoints
-        enddo ! loop over nlev
-
-      end subroutine prec_scops
-end module mod_prec_scops
Index: /LMDZ6/trunk/libf/phylmd/cospv2/prec_scops.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cospv2/prec_scops.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/cospv2/prec_scops.f90	(revision 5268)
@@ -0,0 +1,277 @@
+! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+! Copyright (c) 2008, Lawrence Livermore National Security Limited Liability Corporation
+! All rights reserved.
+!
+! Redistribution and use in source and binary forms, with or without modification, are 
+! permitted provided that the following conditions are met:
+!
+! 1. Redistributions of source code must retain the above copyright notice, this list of 
+!    conditions and the following disclaimer.
+!
+! 2. Redistributions in binary form must reproduce the above copyright notice, this list
+!    of conditions and the following disclaimer in the documentation and/or other 
+!    materials provided with the distribution.
+!
+! 3. Neither the name of the copyright holder nor the names of its contributors may be 
+!    used to endorse or promote products derived from this software without specific prior
+!    written permission.
+!
+! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY 
+! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 
+! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL 
+! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 
+! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT 
+! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 
+! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+!
+! History:
+! May 2015- D. Swales - Modified for COSPv2.0
+! 
+! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+module mod_prec_scops
+   implicit none
+contains
+      
+      subroutine prec_scops(npoints,nlev,ncol,ls_p_rate,cv_p_rate,frac_out,prec_frac)
+
+        USE COSP_KINDS, ONLY: wp
+        use mod_cosp_config, ONLY: scops_ccfrac
+
+      INTEGER npoints       !  number of model points in the horizontal
+      INTEGER nlev          !  number of model levels in column
+      INTEGER ncol          !  number of subcolumns
+
+      INTEGER j,ilev,ibox,cv_col
+      
+      REAL(WP) ls_p_rate(npoints,nlev),cv_p_rate(npoints,nlev)
+
+      REAL(WP) frac_out(npoints,ncol,nlev) ! boxes gridbox divided up into
+                              ! Equivalent of BOX in original version, but
+                              ! indexed by column then row, rather than
+                              ! by row then column
+                              !TOA to SURFACE!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+      REAL(WP) prec_frac(npoints,ncol,nlev) ! 0 -> clear sky
+                                        ! 1 -> LS precipitation
+                                        ! 2 -> CONV precipitation
+                    ! 3 -> both
+                                        !TOA to SURFACE!!!!!!!!!!!!!!!!!!
+                    
+      INTEGER flag_ls, flag_cv
+      INTEGER frac_out_ls(npoints,ncol),frac_out_cv(npoints,ncol) !flag variables for 
+                       ! stratiform cloud and convective cloud in the vertical column
+
+      cv_col = scops_ccfrac*ncol
+      if (cv_col .eq. 0) cv_col=1
+ 
+      do ilev=1,nlev
+        do ibox=1,ncol
+          do j=1,npoints 
+            prec_frac(j,ibox,ilev) = 0
+          enddo
+        enddo
+      enddo
+      
+      do j=1,npoints
+       do ibox=1,ncol
+        frac_out_ls(j,ibox)=0
+        frac_out_cv(j,ibox)=0
+        flag_ls=0
+        flag_cv=0
+        do ilev=1,nlev
+          if (frac_out(j,ibox,ilev) .eq. 1) then 
+            flag_ls=1
+          endif
+          if (frac_out(j,ibox,ilev) .eq. 2) then 
+            flag_cv=1
+          endif
+        enddo !loop over nlev
+        if (flag_ls .eq. 1) then
+           frac_out_ls(j,ibox)=1
+        endif
+        if (flag_cv .eq. 1) then
+           frac_out_cv(j,ibox)=1
+        endif
+       enddo  ! loop over ncol
+      enddo ! loop over npoints
+
+!      initialize the top layer      
+       do j=1,npoints
+        flag_ls=0
+        flag_cv=0
+    
+        if (ls_p_rate(j,1) .gt. 0.) then 
+            do ibox=1,ncol ! possibility ONE
+                if (frac_out(j,ibox,1) .eq. 1) then 
+                    prec_frac(j,ibox,1) = 1
+                    flag_ls=1
+                endif
+            enddo ! loop over ncol
+            if (flag_ls .eq. 0) then ! possibility THREE
+                do ibox=1,ncol
+                    if (frac_out(j,ibox,2) .eq. 1) then 
+                        prec_frac(j,ibox,1) = 1
+                        flag_ls=1
+                    endif
+                enddo ! loop over ncol
+            endif
+        if (flag_ls .eq. 0) then ! possibility Four
+        do ibox=1,ncol
+        if (frac_out_ls(j,ibox) .eq. 1) then 
+            prec_frac(j,ibox,1) = 1
+            flag_ls=1
+        endif
+        enddo ! loop over ncol
+        endif
+        if (flag_ls .eq. 0) then ! possibility Five
+        do ibox=1,ncol
+    !     prec_frac(j,1:ncol,1) = 1
+        prec_frac(j,ibox,1) = 1
+        enddo ! loop over ncol
+            endif
+        endif
+       ! There is large scale precipitation
+     
+        if (cv_p_rate(j,1) .gt. 0.) then 
+         do ibox=1,ncol ! possibility ONE
+          if (frac_out(j,ibox,1) .eq. 2) then 
+           if (prec_frac(j,ibox,1) .eq. 0) then
+        prec_frac(j,ibox,1) = 2
+       else
+        prec_frac(j,ibox,1) = 3
+       endif
+       flag_cv=1
+      endif
+        enddo ! loop over ncol
+        if (flag_cv .eq. 0) then ! possibility THREE
+        do ibox=1,ncol
+        if (frac_out(j,ibox,2) .eq. 2) then 
+                if (prec_frac(j,ibox,1) .eq. 0) then
+            prec_frac(j,ibox,1) = 2
+            else
+            prec_frac(j,ibox,1) = 3
+            endif
+            flag_cv=1
+        endif
+        enddo ! loop over ncol
+        endif
+        if (flag_cv .eq. 0) then ! possibility Four
+        do ibox=1,ncol
+        if (frac_out_cv(j,ibox) .eq. 1) then 
+                if (prec_frac(j,ibox,1) .eq. 0) then
+            prec_frac(j,ibox,1) = 2
+            else
+            prec_frac(j,ibox,1) = 3
+            endif
+            flag_cv=1
+        endif
+        enddo ! loop over ncol
+        endif
+        if (flag_cv .eq. 0) then  ! possibility Five
+        do ibox=1,cv_col
+                if (prec_frac(j,ibox,1) .eq. 0) then
+            prec_frac(j,ibox,1) = 2
+            else
+            prec_frac(j,ibox,1) = 3
+            endif 
+        enddo !loop over cv_col
+            endif 
+        endif 
+        ! There is convective precipitation
+        
+        enddo ! loop over npoints
+!      end of initializing the top layer
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+!     working on the levels from top to surface
+      do ilev=2,nlev
+       do j=1,npoints
+        flag_ls=0
+        flag_cv=0
+    
+        if (ls_p_rate(j,ilev) .gt. 0.) then 
+         do ibox=1,ncol ! possibility ONE&TWO
+          if ((frac_out(j,ibox,ilev) .eq. 1) .or. ((prec_frac(j,ibox,ilev-1) .eq. 1)     &
+            .or. (prec_frac(j,ibox,ilev-1) .eq. 3))) then 
+           prec_frac(j,ibox,ilev) = 1
+           flag_ls=1
+          endif
+        enddo ! loop over ncol
+        if ((flag_ls .eq. 0) .and. (ilev .lt. nlev)) then ! possibility THREE
+        do ibox=1,ncol
+        if (frac_out(j,ibox,ilev+1) .eq. 1) then 
+            prec_frac(j,ibox,ilev) = 1
+            flag_ls=1
+        endif
+        enddo ! loop over ncol
+        endif
+        if (flag_ls .eq. 0) then ! possibility Four
+        do ibox=1,ncol
+        if (frac_out_ls(j,ibox) .eq. 1) then 
+            prec_frac(j,ibox,ilev) = 1
+            flag_ls=1
+        endif
+        enddo ! loop over ncol
+        endif
+        if (flag_ls .eq. 0) then ! possibility Five
+        do ibox=1,ncol
+!     prec_frac(j,1:ncol,ilev) = 1
+        prec_frac(j,ibox,ilev) = 1
+        enddo ! loop over ncol
+         endif
+      endif ! There is large scale precipitation
+    
+        if (cv_p_rate(j,ilev) .gt. 0.) then 
+         do ibox=1,ncol ! possibility ONE&TWO
+          if ((frac_out(j,ibox,ilev) .eq. 2) .or. ((prec_frac(j,ibox,ilev-1) .eq. 2)     &
+            .or. (prec_frac(j,ibox,ilev-1) .eq. 3))) then 
+            if (prec_frac(j,ibox,ilev) .eq. 0) then
+         prec_frac(j,ibox,ilev) = 2
+        else
+         prec_frac(j,ibox,ilev) = 3
+        endif 
+        flag_cv=1
+        endif
+       enddo ! loop over ncol
+        if ((flag_cv .eq. 0) .and. (ilev .lt. nlev)) then ! possibility THREE
+        do ibox=1,ncol
+        if (frac_out(j,ibox,ilev+1) .eq. 2) then 
+                if (prec_frac(j,ibox,ilev) .eq. 0) then
+            prec_frac(j,ibox,ilev) = 2
+            else
+            prec_frac(j,ibox,ilev) = 3
+            endif
+            flag_cv=1
+        endif
+        enddo ! loop over ncol
+        endif
+        if (flag_cv .eq. 0) then ! possibility Four
+        do ibox=1,ncol
+        if (frac_out_cv(j,ibox) .eq. 1) then 
+                if (prec_frac(j,ibox,ilev) .eq. 0) then
+            prec_frac(j,ibox,ilev) = 2
+            else
+            prec_frac(j,ibox,ilev) = 3
+            endif
+            flag_cv=1
+        endif
+        enddo ! loop over ncol
+        endif
+        if (flag_cv .eq. 0) then  ! possibility Five 
+        do ibox=1,cv_col
+                if (prec_frac(j,ibox,ilev) .eq. 0) then
+            prec_frac(j,ibox,ilev) = 2
+            else
+            prec_frac(j,ibox,ilev) = 3
+            endif 
+        enddo !loop over cv_col 
+            endif 
+        endif ! There is convective precipitation
+    
+        enddo ! loop over npoints
+        enddo ! loop over nlev
+
+      end subroutine prec_scops
+end module mod_prec_scops
Index: DZ6/trunk/libf/phylmd/cospv2/quickbeam.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cospv2/quickbeam.F90	(revision 5267)
+++ 	(revision )
@@ -1,643 +1,0 @@
-! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-! Copyright (c) 2015, Regents of the University of Colorado
-! All rights reserved.
-!
-! Redistribution and use in source and binary forms, with or without modification, are 
-! permitted provided that the following conditions are met:
-!
-! 1. Redistributions of source code must retain the above copyright notice, this list of 
-!    conditions and the following disclaimer.
-!
-! 2. Redistributions in binary form must reproduce the above copyright notice, this list
-!    of conditions and the following disclaimer in the documentation and/or other 
-!    materials provided with the distribution.
-!
-! 3. Neither the name of the copyright holder nor the names of its contributors may be 
-!    used to endorse or promote products derived from this software without specific prior
-!    written permission.
-!
-! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY 
-! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 
-! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL 
-! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 
-! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT 
-! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 
-! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
-! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-!
-! History
-! 11/2005: John Haynes - Created
-! 09/2006  placed into subroutine form (Roger Marchand,JMH)
-! 08/2007  added equivalent volume spheres, Z and N scalling most distrubtion types (Roger Marchand)
-! 01/2008  'Do while' to determine if hydrometeor(s) present in volume
-!           changed for vectorization purposes (A. Bodas-Salcedo)
-!
-! 07/2010  V3.0 ... Modified to load or save scale factors to disk as a Look-Up Table (LUT)
-!  ... All hydrometeor and radar simulator properties now included in hp structure
-!  ... hp structure should be initialized by call to radar_simulator_init prior 
-!  ... to calling this subroutine.  
-!     Also ... Support of Morrison 2-moment style microphyscis (Np_matrix) added 
-!  ... Changes implement by Roj Marchand following work by Laura Fowler
-!
-!   10/2011  Modified ngate loop to go in either direction depending on flag 
-!     hp%radar_at_layer_one.  This affects the direction in which attenuation is summed.
-!
-!     Also removed called to AVINT for gas and hydrometeor attenuation and replaced with simple
-!     summation. (Roger Marchand)
-! May 2015 - D. Swales - Modified for COSPv2.0
-! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-module quickbeam
-  USE COSP_KINDS,           ONLY: wp
-  USE MOD_COSP_CONFIG,      ONLY: R_UNDEF,cloudsat_histRef,use_vgrid,vgrid_zl,vgrid_zu,&
-                                  pClass_noPrecip, pClass_Rain1, pClass_Rain2, pClass_Rain3,&
-                                  pClass_Snow1, pClass_Snow2, pClass_Mixed1, pClass_Mixed2, &
-                                  pClass_Rain4, pClass_default, Zenonbinval, Zbinvallnd,    &
-                                  N_HYDRO,nCloudsatPrecipClass !,cloudsat_preclvl !PREC_BUG
-  USE MOD_COSP_STATS,       ONLY: COSP_LIDAR_ONLY_CLOUD,hist1D,COSP_CHANGE_VERTICAL_GRID
-  implicit none
-
-  integer,parameter :: &
-       maxhclass     = 20,  & ! Qucikbeam maximum number of hydrometeor classes.
-       nRe_types     = 550, & ! Quickbeam maximum number or Re size bins allowed in N and Z_scaled look up table.
-       nd            = 85,  & ! Qucikbeam number of discrete particles used in construction DSDs.
-       mt_ntt        = 39,  & ! Quickbeam number of temperatures in mie LUT.
-       Re_BIN_LENGTH = 10,  & ! Quickbeam minimum Re interval in scale LUTs  
-       Re_MAX_BIN    = 250    ! Quickbeam maximum Re interval in scale LUTs
-  real(wp),parameter :: &
-       dmin          = 0.1, & ! Quickbeam minimum size of discrete particle
-       dmax          = 10000. ! Quickbeam maximum size of discrete particle
-  
-  !djs logical :: radar_at_layer_one   ! If true radar is assume to be at the edge 
-                                  ! of the first layer, if the first layer is the
-                                  ! surface than a ground-based radar.   If the
-                                  ! first layer is the top-of-atmosphere, then
-                                  ! a space borne radar.
-
-  ! ##############################################################################################
-  type radar_cfg
-     ! Radar properties
-     real(wp) :: freq,k2
-     integer  :: nhclass               ! Number of hydrometeor classes in use
-     integer  :: use_gas_abs, do_ray
-     logical  :: radar_at_layer_one    ! If true radar is assume to be at the edge 
-                                       ! of the first layer, if the first layer is the
-                                       ! surface than a ground-based radar.   If the
-                                       ! first layer is the top-of-atmosphere, then
-                                       ! a space borne radar.
-     
-     ! Variables used to store Z scale factors
-     character(len=240)                             :: scale_LUT_file_name
-     logical                                        :: load_scale_LUTs, update_scale_LUTs
-     logical, dimension(maxhclass,nRe_types)        :: N_scale_flag
-     logical, dimension(maxhclass,mt_ntt,nRe_types) :: Z_scale_flag,Z_scale_added_flag
-     real(wp),dimension(maxhclass,mt_ntt,nRe_types) :: Ze_scaled,Zr_scaled,kr_scaled
-     real(wp),dimension(maxhclass,nd,nRe_types)     :: fc, rho_eff
-     real(wp),dimension(Re_MAX_BIN)                 :: base_list,step_list
-
-  end type radar_cfg
-
-contains
-  ! ######################################################################################
-  ! SUBROUTINE quickbeam_subcolumn
-  ! ######################################################################################
-  subroutine quickbeam_subcolumn(rcfg,nprof,ngate,hgt_matrix,z_vol,kr_vol,g_vol,dBZe,Ze_non)
-
-    ! INPUTS
-    type(radar_cfg),intent(inout) :: &
-         rcfg             ! Derived type for radar simulator setup
-    integer,intent(in) :: &
-         nprof,         & ! Number of hydrometeor profiles
-         ngate            ! Number of vertical layers
-    real(wp),intent(in),dimension(nprof,ngate) :: &
-         hgt_matrix,    & ! Height of hydrometeors (km)
-         z_vol,         & ! Effective reflectivity factor (mm^6/m^3)
-         kr_vol,        & ! Attenuation coefficient hydro (dB/km)
-         g_vol            ! Attenuation coefficient gases (dB/km)
-    
-    ! OUTPUTS
-    real(wp), intent(out),dimension(nprof,ngate) :: &
-         Ze_non,        & ! Radar reflectivity without attenuation (dBZ)
-         dBZe             ! Effective radar reflectivity factor (dBZ)
-
-    ! LOCAL VARIABLES
-    integer :: k,pr,start_gate,end_gate,d_gate
-    real(wp),dimension(nprof,ngate) :: &
-         Ze_ray,        & ! Rayleigh reflectivity (dBZ)
-         g_to_vol,      & ! Gaseous atteunation, radar to vol (dB)
-         a_to_vol,      & ! Hydromets attenuation, radar to vol (dB) 
-         z_ray            ! Reflectivity factor, Rayleigh only (mm^6/m^3)
-
-    ! Load scaling matricies from disk -- but only the first time this subroutine is called
-    if(rcfg%load_scale_LUTs) then
-       call load_scale_LUTs(rcfg)
-       rcfg%load_scale_LUTs=.false.
-       rcfg%Z_scale_added_flag = .false. ! will be set true if scaling Look Up Tables are modified during run
-    endif
-
-    ! Initialization
-    g_to_vol = 0._wp
-    a_to_vol = 0._wp
-
-    ! Loop over each range gate (ngate) ... starting with layer closest to the radar !
-    if(rcfg%radar_at_layer_one) then
-       start_gate = 1
-       end_gate   = ngate
-       d_gate     = 1
-    else
-       start_gate = ngate
-       end_gate   = 1
-       d_gate     = -1
-    endif
-    do k=start_gate,end_gate,d_gate
-       ! Loop over each profile (nprof)
-       do pr=1,nprof
-          ! Attenuation due to hydrometeors between radar and volume
-          
-          ! NOTE old scheme integrates attenuation only for the layers ABOVE
-          ! the current layer ... i.e. 1 to k-1 rather than 1 to k ...
-          ! which may be a problem.   ROJ
-          ! in the new scheme I assign half the attenuation to the current layer
-          if(d_gate==1) then
-             ! dheight calcuations assumes hgt_matrix points are the cell mid-points.
-             if (k>2) then
-                ! add to previous value to half of above layer + half of current layer
-                a_to_vol(pr,k)=  a_to_vol(pr,k-1) + &
-                     (kr_vol(pr,k-1)+kr_vol(pr,k))*(hgt_matrix(pr,k-1)-hgt_matrix(pr,k))
-             else
-                a_to_vol(pr,k)=  kr_vol(pr,k)*(hgt_matrix(pr,k)-hgt_matrix(pr,k+1))
-             endif
-          else   ! d_gate==-1
-             if(k<ngate) then
-                ! Add to previous value half of above layer + half of current layer
-                a_to_vol(pr,k) = a_to_vol(pr,k+1) + &
-                     (kr_vol(pr,k+1)+kr_vol(pr,k))*(hgt_matrix(pr,k+1)-hgt_matrix(pr,k))
-             else
-                a_to_vol(pr,k)= kr_vol(pr,k)*(hgt_matrix(pr,k)-hgt_matrix(pr,k-1))
-             endif
-          endif
-          
-          ! Attenuation due to gaseous absorption between radar and volume
-          if ((rcfg%use_gas_abs == 1) .or. (rcfg%use_gas_abs == 2 .and. pr .eq. 1)) then
-             if (d_gate==1) then
-                if (k>1) then
-                   ! Add to previous value to half of above layer + half of current layer
-                   g_to_vol(pr,k) =  g_to_vol(pr,k-1) + &
-                        0.5*(g_vol(pr,k-1)+g_vol(pr,k))*(hgt_matrix(pr,k-1)-hgt_matrix(pr,k))
-                else
-                   g_to_vol(pr,k)=  0.5_wp*g_vol(pr,k)*(hgt_matrix(pr,k)-hgt_matrix(pr,k+1))
-                endif
-             else   ! d_gate==-1
-                if (k<ngate) then
-                   ! Add to previous value to half of above layer + half of current layer
-                   g_to_vol(pr,k) = g_to_vol(pr,k+1) + &
-                        0.5_wp*(g_vol(pr,k+1)+g_vol(pr,k))*(hgt_matrix(pr,k+1)-hgt_matrix(pr,k))
-                else
-                   g_to_vol(pr,k)= 0.5_wp*g_vol(pr,k)*(hgt_matrix(pr,k)-hgt_matrix(pr,k-1))
-                endif
-             endif
-          elseif(rcfg%use_gas_abs == 2) then
-             ! Using value calculated for the first column
-             g_to_vol(pr,k) = g_to_vol(1,k)
-          elseif (rcfg%use_gas_abs == 0) then
-             g_to_vol(pr,k) = 0._wp
-          endif
-       enddo   ! End loop over pr (profile)
-    enddo ! End loop of k (range gate)
-    
-    ! Compute Rayleigh reflectivity, and full, attenuated reflectivity
-    if(rcfg%do_ray == 1) then
-       where(z_ray(1:nprof,1:ngate) > 0._wp)
-          Ze_ray(1:nprof,1:ngate) = 10._wp*log10(z_ray(1:nprof,1:ngate))
-       elsewhere
-          Ze_Ray(1:nprof,1:ngate) = 0._wp
-       endwhere
-    else 
-      Ze_ray(1:nprof,1:ngate) = R_UNDEF
-    end if
-
-    where(z_vol(1:nprof,1:ngate) > 0._wp) 
-      Ze_non(1:nprof,1:ngate) = 10._wp*log10(z_vol(1:nprof,1:ngate))
-      dBZe(1:nprof,1:ngate) = Ze_non(1:nprof,1:ngate)-a_to_vol(1:nprof,1:ngate)-g_to_vol(1:nprof,1:ngate)
-    elsewhere
-      dBZe(1:nprof,1:ngate) = R_UNDEF
-      Ze_non(1:nprof,1:ngate) = R_UNDEF
-    end where 
-
-    ! Save any updates made 
-    if (rcfg%update_scale_LUTs) call save_scale_LUTs(rcfg)
- 
-  end subroutine quickbeam_subcolumn
-  ! ######################################################################################
-  ! SUBROUTINE quickbeam_column
-  ! ######################################################################################
-  subroutine quickbeam_column(npoints, ncolumns, nlevels, llm, DBZE_BINS, platform,      &
-       Ze_tot, Ze_tot_non, land, surfelev, t2m, fracPrecipIce, zlev, zlev_half, cfad_ze, & !PREC_BUG
-       cloudsat_precip_cover, cloudsat_pia)
-    ! Inputs
-    integer,intent(in) :: &
-         npoints,    & ! Number of horizontal grid points
-         ncolumns,   & ! Number of subcolumns
-         nlevels,    & ! Number of vertical layers in OLD grid
-         llm,        & ! Number of vertical layers in NEW grid
-         DBZE_BINS     ! Number of bins for cfad.
-    character(len=*),intent(in) :: &
-         platform      ! Name of platform (e.g. cloudsat)
-    real(wp),dimension(Npoints),intent(in) :: &
-         land,               & ! Land/Sea mask. (1/0)
-         surfelev,           & ! Surface Elevation (m) !PREC_BUG
-         t2m                   ! Near-surface temperature
-    real(wp),dimension(Npoints,Ncolumns),intent(in) :: &
-         fracPrecipIce         ! Fraction of precipitation which is frozen.     (1)
-    real(wp),intent(in),dimension(npoints,ncolumns,Nlevels) :: &
-         Ze_tot,     & ! Effective reflectivity factor                 (dBZ)
-         Ze_tot_non    ! Effective reflectivity factor w/o attenuation (dBZ)
-    real(wp),intent(in),dimension(npoints,Nlevels) :: &
-         zlev          ! Model full levels
-    real(wp),intent(in),dimension(npoints,Nlevels+1) :: &
-         zlev_half     ! Model half levels
-         
-    ! Outputs
-    real(wp),intent(inout),dimension(npoints,DBZE_BINS,llm) :: &
-         cfad_ze    !
-    real(wp),dimension(Npoints,nCloudsatPrecipClass),intent(out) :: &
-         cloudsat_precip_cover ! Model precip rate in by CloudSat precip flag
-    real(wp),dimension(Npoints),intent(out) :: &
-         cloudsat_pia          ! Cloudsat path integrated attenuation
-    
-    ! Local variables
-    integer :: i,j
-    real(wp),dimension(npoints,ncolumns,llm) :: ze_toti,ze_noni
-    logical :: lcloudsat = .false.
-
-    ! Which platforms to create diagnostics for?
-    if (platform .eq. 'cloudsat') lcloudsat=.true.
-
-    ! Create Cloudsat diagnostics.
-    if (lcloudsat) then
-       if (use_vgrid) then
-          ! Regrid in the vertical (*NOTE* This routine requires SFC-2-TOA ordering, so flip
-          ! inputs and outputs to maintain TOA-2-SFC ordering convention in COSP2.)
-          call cosp_change_vertical_grid(Npoints,Ncolumns,Nlevels,zlev(:,nlevels:1:-1),&
-               zlev_half(:,nlevels:1:-1),Ze_tot(:,:,nlevels:1:-1),llm,vgrid_zl(llm:1:-1),&
-               vgrid_zu(llm:1:-1),Ze_toti(:,:,llm:1:-1),log_units=.true.)
-          
-          ! Effective reflectivity histogram
-          do i=1,Npoints
-             do j=1,llm
-                cfad_ze(i,:,j) = hist1D(Ncolumns,Ze_toti(i,:,j),DBZE_BINS,cloudsat_histRef)
-             enddo
-          enddo
-          where(cfad_ze .ne. R_UNDEF) cfad_ze = cfad_ze/Ncolumns
-
-          ! Compute cloudsat near-surface precipitation diagnostics
-          ! First, regrid in the vertical Ze_tot_non.
-          call cosp_change_vertical_grid(Npoints,Ncolumns,Nlevels,zlev(:,nlevels:1:-1),&
-               zlev_half(:,nlevels:1:-1),Ze_tot_non(:,:,nlevels:1:-1),llm,vgrid_zl(llm:1:-1),&
-               vgrid_zu(llm:1:-1),Ze_noni(:,:,llm:1:-1),log_units=.true.)
-          ! Not call routine to generate diagnostics.
-          call cloudsat_precipOccurence(Npoints, Ncolumns, llm, N_HYDRO, Ze_toti, Ze_noni, &
-               land, surfelev, t2m, fracPrecipIce, cloudsat_precip_cover, cloudsat_pia) !PREC_BUG
-       else
-          ! Effective reflectivity histogram
-          do i=1,Npoints
-             do j=1,llm
-                cfad_ze(i,:,j) = hist1D(Ncolumns,Ze_tot(i,:,j),DBZE_BINS,cloudsat_histRef)
-             enddo
-          enddo
-          where(cfad_ze .ne. R_UNDEF) cfad_ze = cfad_ze/Ncolumns
-       endif
-    endif
-
-  end subroutine quickbeam_column
-  ! ##############################################################################################
-  ! ##############################################################################################
-  ! ######################################################################################
-  ! SUBROUTINE cloudsat_precipOccurence
-  !
-  ! Notes from July 2016: Add precip flag also looped over subcolumns
-  ! Modified by Tristan L'Ecuyer (TSL) to add precipitation flagging
-  ! based on CloudSat's 2C-PRECIP-COLUMN algorithm (Haynes et al, JGR, 2009).
-  ! To mimic the satellite algorithm, this code applies thresholds to non-attenuated
-  ! reflectivities, Ze_non, consistent with those outlined in Haynes et al, JGR (2009).
-  !
-  ! Procedures/Notes:
-  !
-  ! (1) If the 2-way attenuation exceeds 40 dB, the pixel will be flagged as 'heavy rain'
-  ! consistent with the multiple-scattering analysis of Battaglia et al, JGR (2008).
-  ! (2) Rain, snow, and mixed precipitation scenes are separated according to the fraction
-  ! of the total precipitation hydrometeor mixing ratio that exists as ice.
-  ! (3) The entire analysis is applied to the range gate from 480-960 m to be consistent with
-  ! CloudSat's 720 m ground-clutter.
-  ! (4) Only a single flag is assigned to each model grid since there is no variation in
-  ! hydrometeor contents across a single model level.  Unlike CFADs, whose variation enters
-  ! due to differening attenuation corrections from hydrometeors aloft, the non-attenuated
-  ! reflectivities used in the computation of this flag cannot vary across sub-columns.
-  !
-  ! radar_prec_flag = 1-Rain possible 2-Rain probable 3-Rain certain 
-  !                   4-Snow possible 5-Snow certain 
-  !                   6-Mixed possible 7-Mixed certain 
-  !                   8-Heavy Rain
-  !                   9- default value
-  !
-  ! Modified by Dustin Swales (University of Colorado) for use with COSP2.
-  ! *NOTE* All inputs (Ze_out, Ze_non_out, fracPrecipIce) are at a single level from the
-  !        statistical output grid used by Cloudsat. This level is controlled by the
-  !        parameter cloudsat_preclvl, defined in src/cosp_config.F90
-  ! ######################################################################################
-  subroutine cloudsat_precipOccurence(Npoints, Ncolumns, llm, Nhydro, Ze_out, Ze_non_out, &
-       land, surfelev, t2m, fracPrecipIce,  cloudsat_precip_cover, cloudsat_pia) !PREC_BUG
- 
-    ! Inputs
-    integer,intent(in) :: &
-         Npoints,            & ! Number of columns
-         Ncolumns,           & ! Numner of subcolumns
-         Nhydro,             & ! Number of hydrometeor types
-         llm                   ! Number of levels
-    real(wp),dimension(Npoints),intent(in) :: &
-         land,               & ! Land/Sea mask. (1/0)
-         surfelev,           & ! Surface Elevation (m) !PREC_BUG
-         t2m                   ! Near-surface temperature
-    real(wp),dimension(Npoints,Ncolumns,llm),intent(in) :: &
-         Ze_out,             & ! Effective reflectivity factor                  (dBZ)
-         Ze_non_out            ! Effective reflectivity factor, w/o attenuation (dBZ)
-    real(wp),dimension(Npoints,Ncolumns),intent(in) :: &
-         fracPrecipIce         ! Fraction of precipitation which is frozen.     (1)
-
-    ! Outputs 
-    real(wp),dimension(Npoints,nCloudsatPrecipClass),intent(out) :: &
-         cloudsat_precip_cover ! Model precip rate in by CloudSat precip flag
-    real(wp),dimension(Npoints),intent(out) :: &
-         cloudsat_pia          ! Cloudsat path integrated attenuation
-    
-    ! Local variables 
-    integer,dimension(Npoints,Ncolumns) :: &
-         cloudsat_pflag,      & ! Subcolumn precipitation flag
-         cloudsat_precip_pia    ! Subcolumn path integrated attenutation.
-    integer,dimension(Npoints) :: &                                           !PREC_BUG
-         cloudsat_preclvl_index ! Altitude index for precip flags calculation !PREC_BUG
-                                ! in 40-level grid (2nd layer above surfelev) !PREC_BUG
-    integer :: pr,i,k,m,j,cloudsat_preclvl                                    !PREC_BUG
-    real(wp) :: Zmax
-    
-    ! Initialize 
-    cloudsat_pflag(:,:)        = pClass_default
-    cloudsat_precip_pia(:,:)   = 0._wp
-    cloudsat_precip_cover(:,:) = 0._wp
-    cloudsat_pia(:)            = 0._wp
-    cloudsat_preclvl_index(:)  = 0._wp !PREC_BUG
-
-
-!!! Computing altitude index for precip flags calculation  !PREC_BUG
-cloudsat_preclvl_index(:) = 39 - floor( surfelev(:)/480. ) !PREC_BUG
-
-    ! ######################################################################################
-    ! SUBCOLUMN processing
-    ! ######################################################################################
-    do i=1, Npoints
-
-       cloudsat_preclvl = cloudsat_preclvl_index(i) !PREC_BUG
-!       print*, 'i, surfelev(i), cloudsat_preclvl : ', i, surfelev(i), cloudsat_preclvl !PREC_BUG
-
-       do pr=1,Ncolumns
-          ! 1) Compute the PIA in all profiles containing hydrometeors
-          if ( (Ze_non_out(i,pr,cloudsat_preclvl).gt.-100) .and. (Ze_out(i,pr,cloudsat_preclvl).gt.-100) ) then
-             if ( (Ze_non_out(i,pr,cloudsat_preclvl).lt.100) .and. (Ze_out(i,pr,cloudsat_preclvl).lt.100) ) then
-                cloudsat_precip_pia(i,pr) = Ze_non_out(i,pr,cloudsat_preclvl) - Ze_out(i,pr,cloudsat_preclvl)
-             endif
-          endif
-          
-          ! 2) Compute precipitation flag
-          ! ################################################################################
-          ! 2a) Oceanic points.
-          ! ################################################################################
-          if (land(i) .eq. 0) then
-!             print*, 'aaa i, pr, fracPrecipIce(i,pr) : ', i, pr, fracPrecipIce(i,pr) !Artem
-             ! Snow
-             if(fracPrecipIce(i,pr).gt.0.9) then
-                if(Ze_non_out(i,pr,cloudsat_preclvl).gt.Zenonbinval(2)) then
-                   cloudsat_pflag(i,pr) = pClass_Snow2                   ! TSL: Snow certain
-                endif
-                if(Ze_non_out(i,pr,cloudsat_preclvl).gt.Zenonbinval(4).and. &
-                     Ze_non_out(i,pr,cloudsat_preclvl).le.Zenonbinval(2)) then
-                   cloudsat_pflag(i,pr) = pClass_Snow1                   ! TSL: Snow possible
-                endif
-             endif
-             
-             ! Mixed
-             if(fracPrecipIce(i,pr).gt.0.1.and.fracPrecipIce(i,pr).le.0.9) then
-                if(Ze_non_out(i,pr,cloudsat_preclvl).gt.Zenonbinval(2)) then
-                   cloudsat_pflag(i,pr) = pClass_Mixed2                  ! TSL: Mixed certain
-                endif
-                if(Ze_non_out(i,pr,cloudsat_preclvl).gt.Zenonbinval(4).and. &
-                     Ze_non_out(i,pr,cloudsat_preclvl).le.Zenonbinval(2)) then
-                   cloudsat_pflag(i,pr) = pClass_Mixed1                  ! TSL: Mixed possible
-                endif
-             endif
-             
-             ! Rain
-             if(fracPrecipIce(i,pr).le.0.1) then
-                if(Ze_non_out(i,pr,cloudsat_preclvl).gt.Zenonbinval(1)) then
-                   cloudsat_pflag(i,pr) = pClass_Rain3                   ! TSL: Rain certain
-                endif
-                if(Ze_non_out(i,pr,cloudsat_preclvl).gt.Zenonbinval(3).and. &
-                     Ze_non_out(i,pr,cloudsat_preclvl).le.Zenonbinval(1)) then
-                   cloudsat_pflag(i,pr) = pClass_Rain2                   ! TSL: Rain probable
-                endif
-                if(Ze_non_out(i,pr,cloudsat_preclvl).gt.Zenonbinval(4).and. &
-                     Ze_non_out(i,pr,cloudsat_preclvl).le.Zenonbinval(3)) then
-                   cloudsat_pflag(i,pr) = pClass_Rain1                   ! TSL: Rain possible
-                endif
-                if(cloudsat_precip_pia(i,pr).gt.40) then
-                   cloudsat_pflag(i,pr) = pClass_Rain4                   ! TSL: Heavy Rain
-                endif
-             endif
-             
-             ! No precipitation
-             if(Ze_non_out(i,pr,cloudsat_preclvl).le.-15) then
-                cloudsat_pflag(i,pr) = pClass_noPrecip                   ! TSL: Not Raining
-             endif
-          endif ! Ocean points
-          
-          ! ################################################################################
-          ! 2b) Land points.
-          ! ################################################################################
-          if (land(i) .eq. 1) then
-             ! Find Zmax, the maximum reflectivity value in the attenuated profile (Ze_out);
-             Zmax=maxval(Ze_out(i,pr,:))
-
-             ! Snow (T<273)
-             if(t2m(i) .lt. 273._wp) then
-                if(Ze_out(i,pr,cloudsat_preclvl) .gt. Zbinvallnd(5)) then
-                   cloudsat_pflag(i,pr) = pClass_Snow2                      ! JEK: Snow certain
-                endif
-                if(Ze_out(i,pr,cloudsat_preclvl) .gt. Zbinvallnd(6) .and. &
-                     Ze_out(i,pr,cloudsat_preclvl).le.Zbinvallnd(5)) then
-                   cloudsat_pflag(i,pr) = pClass_Snow1                      ! JEK: Snow possible
-                endif
-             endif
-             
-             ! Mized phase (273<T<275)
-             if(t2m(i) .ge. 273._wp .and. t2m(i) .le. 275._wp) then
-                if ((Zmax .gt. Zbinvallnd(1) .and. cloudsat_precip_pia(i,pr).gt.30) .or. &
-                     (Ze_out(i,pr,cloudsat_preclvl) .gt. Zbinvallnd(4))) then
-                   cloudsat_pflag(i,pr) = pClass_Mixed2                     ! JEK: Mixed certain
-                endif
-                if ((Ze_out(i,pr,cloudsat_preclvl) .gt. Zbinvallnd(6)  .and. &
-                     Ze_out(i,pr,cloudsat_preclvl) .le. Zbinvallnd(4)) .and. &
-                     (Zmax .gt. Zbinvallnd(5)) ) then
-                   cloudsat_pflag(i,pr) = pClass_Mixed1                     ! JEK: Mixed possible
-                endif
-             endif
-
-             ! Rain (T>275)
-             if(t2m(i) .gt. 275) then
-                if ((Zmax .gt. Zbinvallnd(1) .and. cloudsat_precip_pia(i,pr).gt.30) .or. &
-                     (Ze_out(i,pr,cloudsat_preclvl) .gt. Zbinvallnd(2))) then
-                   cloudsat_pflag(i,pr) = pClass_Rain3                      ! JEK: Rain certain
-                endif
-                if((Ze_out(i,pr,cloudsat_preclvl) .gt. Zbinvallnd(6)) .and. &
-                     (Zmax .gt. Zbinvallnd(3))) then
-                   cloudsat_pflag(i,pr) = pClass_Rain2                      ! JEK: Rain probable
-                endif
-                if((Ze_out(i,pr,cloudsat_preclvl) .gt. Zbinvallnd(6)) .and. &
-                     (Zmax.lt.Zbinvallnd(3))) then
-                   cloudsat_pflag(i,pr) = pClass_Rain1                      ! JEK: Rain possible
-                endif
-                if(cloudsat_precip_pia(i,pr).gt.40) then
-                   cloudsat_pflag(i,pr) = pClass_Rain4                      ! JEK: Heavy Rain
-                endif
-             endif
-             
-             ! No precipitation
-             if(Ze_out(i,pr,cloudsat_preclvl).le.-15) then
-                cloudsat_pflag(i,pr) =  pClass_noPrecip                     ! JEK: Not Precipitating
-             endif         
-          endif ! Land points
-       enddo ! Sub-columns
-    enddo    ! Gridpoints
-
-    ! ######################################################################################
-    ! COLUMN processing
-    ! ######################################################################################
-
-    ! Aggregate subcolumns
-    do i=1,Npoints
-       ! Gridmean precipitation fraction for each precipitation type
-       do k=1,nCloudsatPrecipClass
-          if (any(cloudsat_pflag(i,:) .eq. k-1)) then
-             cloudsat_precip_cover(i,k) = count(cloudsat_pflag(i,:) .eq. k-1)
-          endif
-       enddo
-
-       ! Gridmean path integrated attenuation (pia)
-       cloudsat_pia(i)=sum(cloudsat_precip_pia(i,:))
-    enddo
-  
-    ! Normalize by number of subcolumns
-    where ((cloudsat_precip_cover /= R_UNDEF).and.(cloudsat_precip_cover /= 0.0)) &
-         cloudsat_precip_cover = cloudsat_precip_cover / Ncolumns
-    where ((cloudsat_pia/= R_UNDEF).and.(cloudsat_pia/= 0.0)) &
-         cloudsat_pia = cloudsat_pia / Ncolumns 
-
-  end subroutine cloudsat_precipOccurence
-  
-  ! ##############################################################################################
-  ! ##############################################################################################
-  subroutine load_scale_LUTs(rcfg)
-    
-    type(radar_cfg), intent(inout) :: rcfg
-    logical                        :: LUT_file_exists
-    integer                        :: i,j,k,ind
-    
-    ! Load scale LUT from file 
-    inquire(file=trim(rcfg%scale_LUT_file_name) // '_radar_Z_scale_LUT.dat', &
-         exist=LUT_file_exists)
-    
-    if(.not.LUT_file_exists) then  
-       write(*,*) '*************************************************'
-       write(*,*) 'Warning: Could NOT FIND radar LUT file: ', &
-            trim(rcfg%scale_LUT_file_name) // '_radar_Z_scale_LUT.dat'        
-       write(*,*) 'Will calculated LUT values as needed'
-       write(*,*) '*************************************************'
-       return
-    else
-       OPEN(unit=12,file=trim(rcfg%scale_LUT_file_name) // '_radar_Z_scale_LUT.dat',&
-            form='unformatted', &
-            err= 89, &
-            access='DIRECT',&
-            recl=28)
-       write(*,*) 'Loading radar LUT file: ', &
-            trim(rcfg%scale_LUT_file_name) // '_radar_Z_scale_LUT.dat'
-       
-       do i=1,maxhclass
-          do j=1,mt_ntt
-             do k=1,nRe_types
-                ind = i+(j-1)*maxhclass+(k-1)*(nRe_types*mt_ntt)
-                read(12,rec=ind) rcfg%Z_scale_flag(i,j,k), &
-                     rcfg%Ze_scaled(i,j,k), &
-                     rcfg%Zr_scaled(i,j,k), &
-                     rcfg%kr_scaled(i,j,k)
-             enddo
-          enddo
-       enddo
-       close(unit=12)
-       return 
-    endif
-    
-89  write(*,*) 'Error: Found but could NOT READ radar LUT file: ', &
-         trim(rcfg%scale_LUT_file_name) // '_radar_Z_scale_LUT.dat'
-    
-  end subroutine load_scale_LUTs
-  
-  ! ##############################################################################################
-  ! ##############################################################################################
-  subroutine save_scale_LUTs(rcfg)
-    type(radar_cfg), intent(inout) :: rcfg
-    logical                        :: LUT_file_exists
-    integer                        :: i,j,k,ind
-    
-    inquire(file=trim(rcfg%scale_LUT_file_name) // '_radar_Z_scale_LUT.dat', &
-         exist=LUT_file_exists)
-    
-    OPEN(unit=12,file=trim(rcfg%scale_LUT_file_name) // '_radar_Z_scale_LUT.dat',&
-         form='unformatted',err= 99,access='DIRECT',recl=28)
-    
-    write(*,*) 'Creating or Updating radar LUT file: ', &
-         trim(rcfg%scale_LUT_file_name) // '_radar_Z_scale_LUT.dat'
-    
-    do i=1,maxhclass
-       do j=1,mt_ntt
-          do k=1,nRe_types
-             ind = i+(j-1)*maxhclass+(k-1)*(nRe_types*mt_ntt)
-             if(.not.LUT_file_exists .or. rcfg%Z_scale_added_flag(i,j,k)) then
-                rcfg%Z_scale_added_flag(i,j,k)=.false.
-                write(12,rec=ind) rcfg%Z_scale_flag(i,j,k), &
-                     rcfg%Ze_scaled(i,j,k), &
-                     rcfg%Zr_scaled(i,j,k), &
-                     rcfg%kr_scaled(i,j,k)
-             endif
-          enddo
-       enddo
-    enddo
-    close(unit=12)
-    return 
-    
-99  write(*,*) 'Error: Unable to create/update radar LUT file: ', &
-         trim(rcfg%scale_LUT_file_name) // '_radar_Z_scale_LUT.dat'
-    return  
-    
-  end subroutine save_scale_LUTs
-  ! ##############################################################################################
-  ! ##############################################################################################
-  subroutine quickbeam_init()
-
-    
-  end subroutine quickBeam_init
-  ! ##############################################################################################
-  ! ##############################################################################################
-
-
-end module quickbeam
-
-
Index: /LMDZ6/trunk/libf/phylmd/cospv2/quickbeam.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cospv2/quickbeam.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/cospv2/quickbeam.f90	(revision 5268)
@@ -0,0 +1,643 @@
+! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+! Copyright (c) 2015, Regents of the University of Colorado
+! All rights reserved.
+!
+! Redistribution and use in source and binary forms, with or without modification, are 
+! permitted provided that the following conditions are met:
+!
+! 1. Redistributions of source code must retain the above copyright notice, this list of 
+!    conditions and the following disclaimer.
+!
+! 2. Redistributions in binary form must reproduce the above copyright notice, this list
+!    of conditions and the following disclaimer in the documentation and/or other 
+!    materials provided with the distribution.
+!
+! 3. Neither the name of the copyright holder nor the names of its contributors may be 
+!    used to endorse or promote products derived from this software without specific prior
+!    written permission.
+!
+! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY 
+! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 
+! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL 
+! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 
+! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT 
+! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 
+! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+!
+! History
+! 11/2005: John Haynes - Created
+! 09/2006  placed into subroutine form (Roger Marchand,JMH)
+! 08/2007  added equivalent volume spheres, Z and N scalling most distrubtion types (Roger Marchand)
+! 01/2008  'Do while' to determine if hydrometeor(s) present in volume
+!           changed for vectorization purposes (A. Bodas-Salcedo)
+!
+! 07/2010  V3.0 ... Modified to load or save scale factors to disk as a Look-Up Table (LUT)
+!  ... All hydrometeor and radar simulator properties now included in hp structure
+!  ... hp structure should be initialized by call to radar_simulator_init prior 
+!  ... to calling this subroutine.  
+!     Also ... Support of Morrison 2-moment style microphyscis (Np_matrix) added 
+!  ... Changes implement by Roj Marchand following work by Laura Fowler
+!
+!   10/2011  Modified ngate loop to go in either direction depending on flag 
+!     hp%radar_at_layer_one.  This affects the direction in which attenuation is summed.
+!
+!     Also removed called to AVINT for gas and hydrometeor attenuation and replaced with simple
+!     summation. (Roger Marchand)
+! May 2015 - D. Swales - Modified for COSPv2.0
+! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+module quickbeam
+  USE COSP_KINDS,           ONLY: wp
+  USE MOD_COSP_CONFIG,      ONLY: R_UNDEF,cloudsat_histRef,use_vgrid,vgrid_zl,vgrid_zu,&
+                                  pClass_noPrecip, pClass_Rain1, pClass_Rain2, pClass_Rain3,&
+                                  pClass_Snow1, pClass_Snow2, pClass_Mixed1, pClass_Mixed2, &
+                                  pClass_Rain4, pClass_default, Zenonbinval, Zbinvallnd,    &
+                                  N_HYDRO,nCloudsatPrecipClass !,cloudsat_preclvl !PREC_BUG
+  USE MOD_COSP_STATS,       ONLY: COSP_LIDAR_ONLY_CLOUD,hist1D,COSP_CHANGE_VERTICAL_GRID
+  implicit none
+
+  integer,parameter :: &
+       maxhclass     = 20,  & ! Qucikbeam maximum number of hydrometeor classes.
+       nRe_types     = 550, & ! Quickbeam maximum number or Re size bins allowed in N and Z_scaled look up table.
+       nd            = 85,  & ! Qucikbeam number of discrete particles used in construction DSDs.
+       mt_ntt        = 39,  & ! Quickbeam number of temperatures in mie LUT.
+       Re_BIN_LENGTH = 10,  & ! Quickbeam minimum Re interval in scale LUTs  
+       Re_MAX_BIN    = 250    ! Quickbeam maximum Re interval in scale LUTs
+  real(wp),parameter :: &
+       dmin          = 0.1, & ! Quickbeam minimum size of discrete particle
+       dmax          = 10000. ! Quickbeam maximum size of discrete particle
+  
+  !djs logical :: radar_at_layer_one   ! If true radar is assume to be at the edge 
+                                  ! of the first layer, if the first layer is the
+                                  ! surface than a ground-based radar.   If the
+                                  ! first layer is the top-of-atmosphere, then
+                                  ! a space borne radar.
+
+  ! ##############################################################################################
+  type radar_cfg
+     ! Radar properties
+     real(wp) :: freq,k2
+     integer  :: nhclass               ! Number of hydrometeor classes in use
+     integer  :: use_gas_abs, do_ray
+     logical  :: radar_at_layer_one    ! If true radar is assume to be at the edge 
+                                       ! of the first layer, if the first layer is the
+                                       ! surface than a ground-based radar.   If the
+                                       ! first layer is the top-of-atmosphere, then
+                                       ! a space borne radar.
+     
+     ! Variables used to store Z scale factors
+     character(len=240)                             :: scale_LUT_file_name
+     logical                                        :: load_scale_LUTs, update_scale_LUTs
+     logical, dimension(maxhclass,nRe_types)        :: N_scale_flag
+     logical, dimension(maxhclass,mt_ntt,nRe_types) :: Z_scale_flag,Z_scale_added_flag
+     real(wp),dimension(maxhclass,mt_ntt,nRe_types) :: Ze_scaled,Zr_scaled,kr_scaled
+     real(wp),dimension(maxhclass,nd,nRe_types)     :: fc, rho_eff
+     real(wp),dimension(Re_MAX_BIN)                 :: base_list,step_list
+
+  end type radar_cfg
+
+contains
+  ! ######################################################################################
+  ! SUBROUTINE quickbeam_subcolumn
+  ! ######################################################################################
+  subroutine quickbeam_subcolumn(rcfg,nprof,ngate,hgt_matrix,z_vol,kr_vol,g_vol,dBZe,Ze_non)
+
+    ! INPUTS
+    type(radar_cfg),intent(inout) :: &
+         rcfg             ! Derived type for radar simulator setup
+    integer,intent(in) :: &
+         nprof,         & ! Number of hydrometeor profiles
+         ngate            ! Number of vertical layers
+    real(wp),intent(in),dimension(nprof,ngate) :: &
+         hgt_matrix,    & ! Height of hydrometeors (km)
+         z_vol,         & ! Effective reflectivity factor (mm^6/m^3)
+         kr_vol,        & ! Attenuation coefficient hydro (dB/km)
+         g_vol            ! Attenuation coefficient gases (dB/km)
+    
+    ! OUTPUTS
+    real(wp), intent(out),dimension(nprof,ngate) :: &
+         Ze_non,        & ! Radar reflectivity without attenuation (dBZ)
+         dBZe             ! Effective radar reflectivity factor (dBZ)
+
+    ! LOCAL VARIABLES
+    integer :: k,pr,start_gate,end_gate,d_gate
+    real(wp),dimension(nprof,ngate) :: &
+         Ze_ray,        & ! Rayleigh reflectivity (dBZ)
+         g_to_vol,      & ! Gaseous atteunation, radar to vol (dB)
+         a_to_vol,      & ! Hydromets attenuation, radar to vol (dB) 
+         z_ray            ! Reflectivity factor, Rayleigh only (mm^6/m^3)
+
+    ! Load scaling matricies from disk -- but only the first time this subroutine is called
+    if(rcfg%load_scale_LUTs) then
+       call load_scale_LUTs(rcfg)
+       rcfg%load_scale_LUTs=.false.
+       rcfg%Z_scale_added_flag = .false. ! will be set true if scaling Look Up Tables are modified during run
+    endif
+
+    ! Initialization
+    g_to_vol = 0._wp
+    a_to_vol = 0._wp
+
+    ! Loop over each range gate (ngate) ... starting with layer closest to the radar !
+    if(rcfg%radar_at_layer_one) then
+       start_gate = 1
+       end_gate   = ngate
+       d_gate     = 1
+    else
+       start_gate = ngate
+       end_gate   = 1
+       d_gate     = -1
+    endif
+    do k=start_gate,end_gate,d_gate
+       ! Loop over each profile (nprof)
+       do pr=1,nprof
+          ! Attenuation due to hydrometeors between radar and volume
+          
+          ! NOTE old scheme integrates attenuation only for the layers ABOVE
+          ! the current layer ... i.e. 1 to k-1 rather than 1 to k ...
+          ! which may be a problem.   ROJ
+          ! in the new scheme I assign half the attenuation to the current layer
+          if(d_gate==1) then
+             ! dheight calcuations assumes hgt_matrix points are the cell mid-points.
+             if (k>2) then
+                ! add to previous value to half of above layer + half of current layer
+                a_to_vol(pr,k)=  a_to_vol(pr,k-1) + &
+                     (kr_vol(pr,k-1)+kr_vol(pr,k))*(hgt_matrix(pr,k-1)-hgt_matrix(pr,k))
+             else
+                a_to_vol(pr,k)=  kr_vol(pr,k)*(hgt_matrix(pr,k)-hgt_matrix(pr,k+1))
+             endif
+          else   ! d_gate==-1
+             if(k<ngate) then
+                ! Add to previous value half of above layer + half of current layer
+                a_to_vol(pr,k) = a_to_vol(pr,k+1) + &
+                     (kr_vol(pr,k+1)+kr_vol(pr,k))*(hgt_matrix(pr,k+1)-hgt_matrix(pr,k))
+             else
+                a_to_vol(pr,k)= kr_vol(pr,k)*(hgt_matrix(pr,k)-hgt_matrix(pr,k-1))
+             endif
+          endif
+          
+          ! Attenuation due to gaseous absorption between radar and volume
+          if ((rcfg%use_gas_abs == 1) .or. (rcfg%use_gas_abs == 2 .and. pr .eq. 1)) then
+             if (d_gate==1) then
+                if (k>1) then
+                   ! Add to previous value to half of above layer + half of current layer
+                   g_to_vol(pr,k) =  g_to_vol(pr,k-1) + &
+                        0.5*(g_vol(pr,k-1)+g_vol(pr,k))*(hgt_matrix(pr,k-1)-hgt_matrix(pr,k))
+                else
+                   g_to_vol(pr,k)=  0.5_wp*g_vol(pr,k)*(hgt_matrix(pr,k)-hgt_matrix(pr,k+1))
+                endif
+             else   ! d_gate==-1
+                if (k<ngate) then
+                   ! Add to previous value to half of above layer + half of current layer
+                   g_to_vol(pr,k) = g_to_vol(pr,k+1) + &
+                        0.5_wp*(g_vol(pr,k+1)+g_vol(pr,k))*(hgt_matrix(pr,k+1)-hgt_matrix(pr,k))
+                else
+                   g_to_vol(pr,k)= 0.5_wp*g_vol(pr,k)*(hgt_matrix(pr,k)-hgt_matrix(pr,k-1))
+                endif
+             endif
+          elseif(rcfg%use_gas_abs == 2) then
+             ! Using value calculated for the first column
+             g_to_vol(pr,k) = g_to_vol(1,k)
+          elseif (rcfg%use_gas_abs == 0) then
+             g_to_vol(pr,k) = 0._wp
+          endif
+       enddo   ! End loop over pr (profile)
+    enddo ! End loop of k (range gate)
+    
+    ! Compute Rayleigh reflectivity, and full, attenuated reflectivity
+    if(rcfg%do_ray == 1) then
+       where(z_ray(1:nprof,1:ngate) > 0._wp)
+          Ze_ray(1:nprof,1:ngate) = 10._wp*log10(z_ray(1:nprof,1:ngate))
+       elsewhere
+          Ze_Ray(1:nprof,1:ngate) = 0._wp
+       endwhere
+    else 
+      Ze_ray(1:nprof,1:ngate) = R_UNDEF
+    end if
+
+    where(z_vol(1:nprof,1:ngate) > 0._wp) 
+      Ze_non(1:nprof,1:ngate) = 10._wp*log10(z_vol(1:nprof,1:ngate))
+      dBZe(1:nprof,1:ngate) = Ze_non(1:nprof,1:ngate)-a_to_vol(1:nprof,1:ngate)-g_to_vol(1:nprof,1:ngate)
+    elsewhere
+      dBZe(1:nprof,1:ngate) = R_UNDEF
+      Ze_non(1:nprof,1:ngate) = R_UNDEF
+    end where 
+
+    ! Save any updates made 
+    if (rcfg%update_scale_LUTs) call save_scale_LUTs(rcfg)
+ 
+  end subroutine quickbeam_subcolumn
+  ! ######################################################################################
+  ! SUBROUTINE quickbeam_column
+  ! ######################################################################################
+  subroutine quickbeam_column(npoints, ncolumns, nlevels, llm, DBZE_BINS, platform,      &
+       Ze_tot, Ze_tot_non, land, surfelev, t2m, fracPrecipIce, zlev, zlev_half, cfad_ze, & !PREC_BUG
+       cloudsat_precip_cover, cloudsat_pia)
+    ! Inputs
+    integer,intent(in) :: &
+         npoints,    & ! Number of horizontal grid points
+         ncolumns,   & ! Number of subcolumns
+         nlevels,    & ! Number of vertical layers in OLD grid
+         llm,        & ! Number of vertical layers in NEW grid
+         DBZE_BINS     ! Number of bins for cfad.
+    character(len=*),intent(in) :: &
+         platform      ! Name of platform (e.g. cloudsat)
+    real(wp),dimension(Npoints),intent(in) :: &
+         land,               & ! Land/Sea mask. (1/0)
+         surfelev,           & ! Surface Elevation (m) !PREC_BUG
+         t2m                   ! Near-surface temperature
+    real(wp),dimension(Npoints,Ncolumns),intent(in) :: &
+         fracPrecipIce         ! Fraction of precipitation which is frozen.     (1)
+    real(wp),intent(in),dimension(npoints,ncolumns,Nlevels) :: &
+         Ze_tot,     & ! Effective reflectivity factor                 (dBZ)
+         Ze_tot_non    ! Effective reflectivity factor w/o attenuation (dBZ)
+    real(wp),intent(in),dimension(npoints,Nlevels) :: &
+         zlev          ! Model full levels
+    real(wp),intent(in),dimension(npoints,Nlevels+1) :: &
+         zlev_half     ! Model half levels
+         
+    ! Outputs
+    real(wp),intent(inout),dimension(npoints,DBZE_BINS,llm) :: &
+         cfad_ze    !
+    real(wp),dimension(Npoints,nCloudsatPrecipClass),intent(out) :: &
+         cloudsat_precip_cover ! Model precip rate in by CloudSat precip flag
+    real(wp),dimension(Npoints),intent(out) :: &
+         cloudsat_pia          ! Cloudsat path integrated attenuation
+    
+    ! Local variables
+    integer :: i,j
+    real(wp),dimension(npoints,ncolumns,llm) :: ze_toti,ze_noni
+    logical :: lcloudsat = .false.
+
+    ! Which platforms to create diagnostics for?
+    if (platform .eq. 'cloudsat') lcloudsat=.true.
+
+    ! Create Cloudsat diagnostics.
+    if (lcloudsat) then
+       if (use_vgrid) then
+          ! Regrid in the vertical (*NOTE* This routine requires SFC-2-TOA ordering, so flip
+          ! inputs and outputs to maintain TOA-2-SFC ordering convention in COSP2.)
+          call cosp_change_vertical_grid(Npoints,Ncolumns,Nlevels,zlev(:,nlevels:1:-1),&
+               zlev_half(:,nlevels:1:-1),Ze_tot(:,:,nlevels:1:-1),llm,vgrid_zl(llm:1:-1),&
+               vgrid_zu(llm:1:-1),Ze_toti(:,:,llm:1:-1),log_units=.true.)
+          
+          ! Effective reflectivity histogram
+          do i=1,Npoints
+             do j=1,llm
+                cfad_ze(i,:,j) = hist1D(Ncolumns,Ze_toti(i,:,j),DBZE_BINS,cloudsat_histRef)
+             enddo
+          enddo
+          where(cfad_ze .ne. R_UNDEF) cfad_ze = cfad_ze/Ncolumns
+
+          ! Compute cloudsat near-surface precipitation diagnostics
+          ! First, regrid in the vertical Ze_tot_non.
+          call cosp_change_vertical_grid(Npoints,Ncolumns,Nlevels,zlev(:,nlevels:1:-1),&
+               zlev_half(:,nlevels:1:-1),Ze_tot_non(:,:,nlevels:1:-1),llm,vgrid_zl(llm:1:-1),&
+               vgrid_zu(llm:1:-1),Ze_noni(:,:,llm:1:-1),log_units=.true.)
+          ! Not call routine to generate diagnostics.
+          call cloudsat_precipOccurence(Npoints, Ncolumns, llm, N_HYDRO, Ze_toti, Ze_noni, &
+               land, surfelev, t2m, fracPrecipIce, cloudsat_precip_cover, cloudsat_pia) !PREC_BUG
+       else
+          ! Effective reflectivity histogram
+          do i=1,Npoints
+             do j=1,llm
+                cfad_ze(i,:,j) = hist1D(Ncolumns,Ze_tot(i,:,j),DBZE_BINS,cloudsat_histRef)
+             enddo
+          enddo
+          where(cfad_ze .ne. R_UNDEF) cfad_ze = cfad_ze/Ncolumns
+       endif
+    endif
+
+  end subroutine quickbeam_column
+  ! ##############################################################################################
+  ! ##############################################################################################
+  ! ######################################################################################
+  ! SUBROUTINE cloudsat_precipOccurence
+  !
+  ! Notes from July 2016: Add precip flag also looped over subcolumns
+  ! Modified by Tristan L'Ecuyer (TSL) to add precipitation flagging
+  ! based on CloudSat's 2C-PRECIP-COLUMN algorithm (Haynes et al, JGR, 2009).
+  ! To mimic the satellite algorithm, this code applies thresholds to non-attenuated
+  ! reflectivities, Ze_non, consistent with those outlined in Haynes et al, JGR (2009).
+  !
+  ! Procedures/Notes:
+  !
+  ! (1) If the 2-way attenuation exceeds 40 dB, the pixel will be flagged as 'heavy rain'
+  ! consistent with the multiple-scattering analysis of Battaglia et al, JGR (2008).
+  ! (2) Rain, snow, and mixed precipitation scenes are separated according to the fraction
+  ! of the total precipitation hydrometeor mixing ratio that exists as ice.
+  ! (3) The entire analysis is applied to the range gate from 480-960 m to be consistent with
+  ! CloudSat's 720 m ground-clutter.
+  ! (4) Only a single flag is assigned to each model grid since there is no variation in
+  ! hydrometeor contents across a single model level.  Unlike CFADs, whose variation enters
+  ! due to differening attenuation corrections from hydrometeors aloft, the non-attenuated
+  ! reflectivities used in the computation of this flag cannot vary across sub-columns.
+  !
+  ! radar_prec_flag = 1-Rain possible 2-Rain probable 3-Rain certain 
+  !                   4-Snow possible 5-Snow certain 
+  !                   6-Mixed possible 7-Mixed certain 
+  !                   8-Heavy Rain
+  !                   9- default value
+  !
+  ! Modified by Dustin Swales (University of Colorado) for use with COSP2.
+  ! *NOTE* All inputs (Ze_out, Ze_non_out, fracPrecipIce) are at a single level from the
+  !        statistical output grid used by Cloudsat. This level is controlled by the
+  !        parameter cloudsat_preclvl, defined in src/cosp_config.F90
+  ! ######################################################################################
+  subroutine cloudsat_precipOccurence(Npoints, Ncolumns, llm, Nhydro, Ze_out, Ze_non_out, &
+       land, surfelev, t2m, fracPrecipIce,  cloudsat_precip_cover, cloudsat_pia) !PREC_BUG
+ 
+    ! Inputs
+    integer,intent(in) :: &
+         Npoints,            & ! Number of columns
+         Ncolumns,           & ! Numner of subcolumns
+         Nhydro,             & ! Number of hydrometeor types
+         llm                   ! Number of levels
+    real(wp),dimension(Npoints),intent(in) :: &
+         land,               & ! Land/Sea mask. (1/0)
+         surfelev,           & ! Surface Elevation (m) !PREC_BUG
+         t2m                   ! Near-surface temperature
+    real(wp),dimension(Npoints,Ncolumns,llm),intent(in) :: &
+         Ze_out,             & ! Effective reflectivity factor                  (dBZ)
+         Ze_non_out            ! Effective reflectivity factor, w/o attenuation (dBZ)
+    real(wp),dimension(Npoints,Ncolumns),intent(in) :: &
+         fracPrecipIce         ! Fraction of precipitation which is frozen.     (1)
+
+    ! Outputs 
+    real(wp),dimension(Npoints,nCloudsatPrecipClass),intent(out) :: &
+         cloudsat_precip_cover ! Model precip rate in by CloudSat precip flag
+    real(wp),dimension(Npoints),intent(out) :: &
+         cloudsat_pia          ! Cloudsat path integrated attenuation
+    
+    ! Local variables 
+    integer,dimension(Npoints,Ncolumns) :: &
+         cloudsat_pflag,      & ! Subcolumn precipitation flag
+         cloudsat_precip_pia    ! Subcolumn path integrated attenutation.
+    integer,dimension(Npoints) :: &                                           !PREC_BUG
+         cloudsat_preclvl_index ! Altitude index for precip flags calculation !PREC_BUG
+                                ! in 40-level grid (2nd layer above surfelev) !PREC_BUG
+    integer :: pr,i,k,m,j,cloudsat_preclvl                                    !PREC_BUG
+    real(wp) :: Zmax
+    
+    ! Initialize 
+    cloudsat_pflag(:,:)        = pClass_default
+    cloudsat_precip_pia(:,:)   = 0._wp
+    cloudsat_precip_cover(:,:) = 0._wp
+    cloudsat_pia(:)            = 0._wp
+    cloudsat_preclvl_index(:)  = 0._wp !PREC_BUG
+
+
+!!! Computing altitude index for precip flags calculation  !PREC_BUG
+cloudsat_preclvl_index(:) = 39 - floor( surfelev(:)/480. ) !PREC_BUG
+
+    ! ######################################################################################
+    ! SUBCOLUMN processing
+    ! ######################################################################################
+    do i=1, Npoints
+
+       cloudsat_preclvl = cloudsat_preclvl_index(i) !PREC_BUG
+!       print*, 'i, surfelev(i), cloudsat_preclvl : ', i, surfelev(i), cloudsat_preclvl !PREC_BUG
+
+       do pr=1,Ncolumns
+          ! 1) Compute the PIA in all profiles containing hydrometeors
+          if ( (Ze_non_out(i,pr,cloudsat_preclvl).gt.-100) .and. (Ze_out(i,pr,cloudsat_preclvl).gt.-100) ) then
+             if ( (Ze_non_out(i,pr,cloudsat_preclvl).lt.100) .and. (Ze_out(i,pr,cloudsat_preclvl).lt.100) ) then
+                cloudsat_precip_pia(i,pr) = Ze_non_out(i,pr,cloudsat_preclvl) - Ze_out(i,pr,cloudsat_preclvl)
+             endif
+          endif
+          
+          ! 2) Compute precipitation flag
+          ! ################################################################################
+          ! 2a) Oceanic points.
+          ! ################################################################################
+          if (land(i) .eq. 0) then
+!             print*, 'aaa i, pr, fracPrecipIce(i,pr) : ', i, pr, fracPrecipIce(i,pr) !Artem
+             ! Snow
+             if(fracPrecipIce(i,pr).gt.0.9) then
+                if(Ze_non_out(i,pr,cloudsat_preclvl).gt.Zenonbinval(2)) then
+                   cloudsat_pflag(i,pr) = pClass_Snow2                   ! TSL: Snow certain
+                endif
+                if(Ze_non_out(i,pr,cloudsat_preclvl).gt.Zenonbinval(4).and. &
+                     Ze_non_out(i,pr,cloudsat_preclvl).le.Zenonbinval(2)) then
+                   cloudsat_pflag(i,pr) = pClass_Snow1                   ! TSL: Snow possible
+                endif
+             endif
+             
+             ! Mixed
+             if(fracPrecipIce(i,pr).gt.0.1.and.fracPrecipIce(i,pr).le.0.9) then
+                if(Ze_non_out(i,pr,cloudsat_preclvl).gt.Zenonbinval(2)) then
+                   cloudsat_pflag(i,pr) = pClass_Mixed2                  ! TSL: Mixed certain
+                endif
+                if(Ze_non_out(i,pr,cloudsat_preclvl).gt.Zenonbinval(4).and. &
+                     Ze_non_out(i,pr,cloudsat_preclvl).le.Zenonbinval(2)) then
+                   cloudsat_pflag(i,pr) = pClass_Mixed1                  ! TSL: Mixed possible
+                endif
+             endif
+             
+             ! Rain
+             if(fracPrecipIce(i,pr).le.0.1) then
+                if(Ze_non_out(i,pr,cloudsat_preclvl).gt.Zenonbinval(1)) then
+                   cloudsat_pflag(i,pr) = pClass_Rain3                   ! TSL: Rain certain
+                endif
+                if(Ze_non_out(i,pr,cloudsat_preclvl).gt.Zenonbinval(3).and. &
+                     Ze_non_out(i,pr,cloudsat_preclvl).le.Zenonbinval(1)) then
+                   cloudsat_pflag(i,pr) = pClass_Rain2                   ! TSL: Rain probable
+                endif
+                if(Ze_non_out(i,pr,cloudsat_preclvl).gt.Zenonbinval(4).and. &
+                     Ze_non_out(i,pr,cloudsat_preclvl).le.Zenonbinval(3)) then
+                   cloudsat_pflag(i,pr) = pClass_Rain1                   ! TSL: Rain possible
+                endif
+                if(cloudsat_precip_pia(i,pr).gt.40) then
+                   cloudsat_pflag(i,pr) = pClass_Rain4                   ! TSL: Heavy Rain
+                endif
+             endif
+             
+             ! No precipitation
+             if(Ze_non_out(i,pr,cloudsat_preclvl).le.-15) then
+                cloudsat_pflag(i,pr) = pClass_noPrecip                   ! TSL: Not Raining
+             endif
+          endif ! Ocean points
+          
+          ! ################################################################################
+          ! 2b) Land points.
+          ! ################################################################################
+          if (land(i) .eq. 1) then
+             ! Find Zmax, the maximum reflectivity value in the attenuated profile (Ze_out);
+             Zmax=maxval(Ze_out(i,pr,:))
+
+             ! Snow (T<273)
+             if(t2m(i) .lt. 273._wp) then
+                if(Ze_out(i,pr,cloudsat_preclvl) .gt. Zbinvallnd(5)) then
+                   cloudsat_pflag(i,pr) = pClass_Snow2                      ! JEK: Snow certain
+                endif
+                if(Ze_out(i,pr,cloudsat_preclvl) .gt. Zbinvallnd(6) .and. &
+                     Ze_out(i,pr,cloudsat_preclvl).le.Zbinvallnd(5)) then
+                   cloudsat_pflag(i,pr) = pClass_Snow1                      ! JEK: Snow possible
+                endif
+             endif
+             
+             ! Mized phase (273<T<275)
+             if(t2m(i) .ge. 273._wp .and. t2m(i) .le. 275._wp) then
+                if ((Zmax .gt. Zbinvallnd(1) .and. cloudsat_precip_pia(i,pr).gt.30) .or. &
+                     (Ze_out(i,pr,cloudsat_preclvl) .gt. Zbinvallnd(4))) then
+                   cloudsat_pflag(i,pr) = pClass_Mixed2                     ! JEK: Mixed certain
+                endif
+                if ((Ze_out(i,pr,cloudsat_preclvl) .gt. Zbinvallnd(6)  .and. &
+                     Ze_out(i,pr,cloudsat_preclvl) .le. Zbinvallnd(4)) .and. &
+                     (Zmax .gt. Zbinvallnd(5)) ) then
+                   cloudsat_pflag(i,pr) = pClass_Mixed1                     ! JEK: Mixed possible
+                endif
+             endif
+
+             ! Rain (T>275)
+             if(t2m(i) .gt. 275) then
+                if ((Zmax .gt. Zbinvallnd(1) .and. cloudsat_precip_pia(i,pr).gt.30) .or. &
+                     (Ze_out(i,pr,cloudsat_preclvl) .gt. Zbinvallnd(2))) then
+                   cloudsat_pflag(i,pr) = pClass_Rain3                      ! JEK: Rain certain
+                endif
+                if((Ze_out(i,pr,cloudsat_preclvl) .gt. Zbinvallnd(6)) .and. &
+                     (Zmax .gt. Zbinvallnd(3))) then
+                   cloudsat_pflag(i,pr) = pClass_Rain2                      ! JEK: Rain probable
+                endif
+                if((Ze_out(i,pr,cloudsat_preclvl) .gt. Zbinvallnd(6)) .and. &
+                     (Zmax.lt.Zbinvallnd(3))) then
+                   cloudsat_pflag(i,pr) = pClass_Rain1                      ! JEK: Rain possible
+                endif
+                if(cloudsat_precip_pia(i,pr).gt.40) then
+                   cloudsat_pflag(i,pr) = pClass_Rain4                      ! JEK: Heavy Rain
+                endif
+             endif
+             
+             ! No precipitation
+             if(Ze_out(i,pr,cloudsat_preclvl).le.-15) then
+                cloudsat_pflag(i,pr) =  pClass_noPrecip                     ! JEK: Not Precipitating
+             endif         
+          endif ! Land points
+       enddo ! Sub-columns
+    enddo    ! Gridpoints
+
+    ! ######################################################################################
+    ! COLUMN processing
+    ! ######################################################################################
+
+    ! Aggregate subcolumns
+    do i=1,Npoints
+       ! Gridmean precipitation fraction for each precipitation type
+       do k=1,nCloudsatPrecipClass
+          if (any(cloudsat_pflag(i,:) .eq. k-1)) then
+             cloudsat_precip_cover(i,k) = count(cloudsat_pflag(i,:) .eq. k-1)
+          endif
+       enddo
+
+       ! Gridmean path integrated attenuation (pia)
+       cloudsat_pia(i)=sum(cloudsat_precip_pia(i,:))
+    enddo
+  
+    ! Normalize by number of subcolumns
+    where ((cloudsat_precip_cover /= R_UNDEF).and.(cloudsat_precip_cover /= 0.0)) &
+         cloudsat_precip_cover = cloudsat_precip_cover / Ncolumns
+    where ((cloudsat_pia/= R_UNDEF).and.(cloudsat_pia/= 0.0)) &
+         cloudsat_pia = cloudsat_pia / Ncolumns 
+
+  end subroutine cloudsat_precipOccurence
+  
+  ! ##############################################################################################
+  ! ##############################################################################################
+  subroutine load_scale_LUTs(rcfg)
+    
+    type(radar_cfg), intent(inout) :: rcfg
+    logical                        :: LUT_file_exists
+    integer                        :: i,j,k,ind
+    
+    ! Load scale LUT from file 
+    inquire(file=trim(rcfg%scale_LUT_file_name) // '_radar_Z_scale_LUT.dat', &
+         exist=LUT_file_exists)
+    
+    if(.not.LUT_file_exists) then  
+       write(*,*) '*************************************************'
+       write(*,*) 'Warning: Could NOT FIND radar LUT file: ', &
+            trim(rcfg%scale_LUT_file_name) // '_radar_Z_scale_LUT.dat'        
+       write(*,*) 'Will calculated LUT values as needed'
+       write(*,*) '*************************************************'
+       return
+    else
+       OPEN(unit=12,file=trim(rcfg%scale_LUT_file_name) // '_radar_Z_scale_LUT.dat',&
+            form='unformatted', &
+            err= 89, &
+            access='DIRECT',&
+            recl=28)
+       write(*,*) 'Loading radar LUT file: ', &
+            trim(rcfg%scale_LUT_file_name) // '_radar_Z_scale_LUT.dat'
+       
+       do i=1,maxhclass
+          do j=1,mt_ntt
+             do k=1,nRe_types
+                ind = i+(j-1)*maxhclass+(k-1)*(nRe_types*mt_ntt)
+                read(12,rec=ind) rcfg%Z_scale_flag(i,j,k), &
+                     rcfg%Ze_scaled(i,j,k), &
+                     rcfg%Zr_scaled(i,j,k), &
+                     rcfg%kr_scaled(i,j,k)
+             enddo
+          enddo
+       enddo
+       close(unit=12)
+       return 
+    endif
+    
+89  write(*,*) 'Error: Found but could NOT READ radar LUT file: ', &
+         trim(rcfg%scale_LUT_file_name) // '_radar_Z_scale_LUT.dat'
+    
+  end subroutine load_scale_LUTs
+  
+  ! ##############################################################################################
+  ! ##############################################################################################
+  subroutine save_scale_LUTs(rcfg)
+    type(radar_cfg), intent(inout) :: rcfg
+    logical                        :: LUT_file_exists
+    integer                        :: i,j,k,ind
+    
+    inquire(file=trim(rcfg%scale_LUT_file_name) // '_radar_Z_scale_LUT.dat', &
+         exist=LUT_file_exists)
+    
+    OPEN(unit=12,file=trim(rcfg%scale_LUT_file_name) // '_radar_Z_scale_LUT.dat',&
+         form='unformatted',err= 99,access='DIRECT',recl=28)
+    
+    write(*,*) 'Creating or Updating radar LUT file: ', &
+         trim(rcfg%scale_LUT_file_name) // '_radar_Z_scale_LUT.dat'
+    
+    do i=1,maxhclass
+       do j=1,mt_ntt
+          do k=1,nRe_types
+             ind = i+(j-1)*maxhclass+(k-1)*(nRe_types*mt_ntt)
+             if(.not.LUT_file_exists .or. rcfg%Z_scale_added_flag(i,j,k)) then
+                rcfg%Z_scale_added_flag(i,j,k)=.false.
+                write(12,rec=ind) rcfg%Z_scale_flag(i,j,k), &
+                     rcfg%Ze_scaled(i,j,k), &
+                     rcfg%Zr_scaled(i,j,k), &
+                     rcfg%kr_scaled(i,j,k)
+             endif
+          enddo
+       enddo
+    enddo
+    close(unit=12)
+    return 
+    
+99  write(*,*) 'Error: Unable to create/update radar LUT file: ', &
+         trim(rcfg%scale_LUT_file_name) // '_radar_Z_scale_LUT.dat'
+    return  
+    
+  end subroutine save_scale_LUTs
+  ! ##############################################################################################
+  ! ##############################################################################################
+  subroutine quickbeam_init()
+
+    
+  end subroutine quickBeam_init
+  ! ##############################################################################################
+  ! ##############################################################################################
+
+
+end module quickbeam
+
+
Index: DZ6/trunk/libf/phylmd/cospv2/quickbeam_optics.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cospv2/quickbeam_optics.F90	(revision 5267)
+++ 	(revision )
@@ -1,1380 +1,0 @@
-! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-! Copyright (c) 2015, Regents of the University of Colorado
-! All rights reserved.
-!
-! Redistribution and use in source and binary forms, with or without modification, are 
-! permitted provided that the following conditions are met:
-!
-! 1. Redistributions of source code must retain the above copyright notice, this list of 
-!    conditions and the following disclaimer.
-!
-! 2. Redistributions in binary form must reproduce the above copyright notice, this list
-!    of conditions and the following disclaimer in the documentation and/or other 
-!    materials provided with the distribution.
-!
-! 3. Neither the name of the copyright holder nor the names of its contributors may be 
-!    used to endorse or promote products derived from this software without specific prior
-!    written permission.
-!
-! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY 
-! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 
-! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL 
-! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 
-! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT 
-! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 
-! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
-! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-!
-! History:
-! May 2015:  Dustin Swales - Initial version
-! 
-! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 
-module mod_quickbeam_optics
-  USE COSP_KINDS,          ONLY: wp,dp
-  USE array_lib,           ONLY: infind
-  USE math_lib,            ONLY: path_integral,avint,gamma
-  USE optics_lib,          ONLY: m_wat,m_ice,MieInt
-  USE cosp_math_constants, ONLY: pi
-  USE cosp_phys_constants, ONLY: rhoice  
-  use quickbeam,           ONLY: radar_cfg,dmin,dmax,Re_BIN_LENGTH,  &
-                                 Re_MAX_BIN,nRe_types,nd,maxhclass
-  use mod_cosp_config,     ONLY: N_HYDRO
-  use mod_cosp_error,      ONLY: errorMessage
-  implicit none
-
-  ! Derived type for particle size distribution
-  TYPE size_distribution
-     real(wp),dimension(maxhclass) :: p1,p2,p3,dmin,dmax,apm,bpm,rho
-     integer, dimension(maxhclass) :: dtype,phase
-  END TYPE size_distribution
-  
-  ! Parameters
-  integer,parameter ::   & !
-       cnt_liq       = 19, & ! Liquid temperature count
-       cnt_ice       = 20    ! Lce temperature count
-  
-  ! Initialization variables
-  real(wp),dimension(cnt_ice) :: mt_tti 
-  real(wp),dimension(cnt_liq) :: mt_ttl
-  real(wp),dimension(nd)      :: D
-  !logical :: lQuickbeamInit
-  
-contains
-  ! ######################################################################################
-  ! SUBROUTINE quickbeam_optics_init
-  ! ######################################################################################
-  subroutine quickbeam_optics_init()
-    integer :: j
-    
-    mt_tti = (/ ((j-1)*5-90 + 273.15, j = 1, cnt_ice) /) 
-    mt_ttl = (/ ((j-1)*5-60 + 273.15, j = 1, cnt_liq) /)
-    D(1) = dmin
-    do j=2,nd
-       D(j) = D(j-1)*exp((log(dmax)-log(dmin))/(nd-1))
-    enddo
-    !lQuickbeamInit = .true.
-  end subroutine quickbeam_optics_init
-  
-  ! ######################################################################################
-  ! SUBROUTINE QUICKBEAM_OPTICS
-  ! ######################################################################################
-  subroutine quickbeam_optics(sd, rcfg, nprof, ngate, undef, hm_matrix, re_matrix,       &
-       Np_matrix, p_matrix, t_matrix, sh_matrix,z_vol,kr_vol)
-    
-    ! INPUTS
-    type(size_distribution),intent(inout) :: &
-         sd               !
-    type(radar_cfg),intent(inout) :: &
-         rcfg             !
-    integer,intent(in) :: &
-         nprof,         & ! Number of hydrometeor profiles
-         ngate            ! Number of vertical layers
-    real(wp),intent(in) :: &
-         undef            ! Missing data value
-    real(wp),intent(in),dimension(nprof,ngate) :: &
-         p_matrix,      & ! Pressure profile (hPa)
-         t_matrix,      & ! Temperature profile (K)
-         sh_matrix        ! Specific humidity profile (%) -- only needed if gaseous aborption calculated.
-    real(wp),intent(in),dimension(nprof,ngate,rcfg%nhclass) :: &
-         re_matrix,     & ! Table of hydrometeor effective radii.       0 ==> use defaults. (units=microns)
-         hm_matrix        ! Table of hydrometeor mixing ratios (g/kg)
-    real(wp),intent(inout),dimension(nprof,ngate,rcfg%nhclass) :: &
-         Np_matrix        ! Table of hydrometeor number concentration.  0 ==> use defaults. (units = 1/kg)
-
-    ! OUTPUTS
-    real(wp),intent(out), dimension(nprof, ngate) :: &
-         z_vol,         & ! Effective reflectivity factor (mm^6/m^3)
-         kr_vol           ! Attenuation coefficient hydro (dB/km)
-
-    ! INTERNAL VARIABLES   
-    integer :: &
-         phase, ns,tp,j,k,pr,itt,iRe_type,n 
-    logical :: &
-         hydro
-    real(wp) :: &
-         t_kelvin,Re_internal
-    real(wp) :: &
-         rho_a,kr,ze,zr,scale_factor,Re,Np,base,step 
-
-    real(wp),dimension(:),allocatable :: &
-         Deq,     & ! Discrete drop sizes (um)
-         Ni,      & ! Discrete concentrations (cm^-3 um^-1)
-         rhoi,    & ! Discrete densities (kg m^-3)
-         xxa,     & !
-         Di         ! Discrete drop sizes (um)
-    
-    real(wp), dimension(nprof, ngate) :: &
-         z_ray      ! Reflectivity factor, Rayleigh only (mm^6/m^3)
-    
-    ! PARAMETERS    
-    logical, parameter ::       & !
-         DO_LUT_TEST = .false., & !
-         DO_NP_TEST  = .false.    !
-    real(wp), parameter :: &
-         one_third   = 1._wp/3._wp    !
-
-    ! Initialization
-    z_vol    = 0._wp
-    z_ray    = 0._wp
-    kr_vol   = 0._wp
-
-    do k=1,ngate       ! Loop over each profile (nprof)
-       do pr=1,nprof
-          ! Determine if hydrometeor(s) present in volume
-          hydro = .false.
-          do j=1,rcfg%nhclass
-             if ((hm_matrix(pr,k,j) > 1E-12) .and. (sd%dtype(j) > 0)) then
-                hydro = .true.
-                exit
-             endif
-          enddo
-
-          t_kelvin = t_matrix(pr,k)
-          ! If there is hydrometeor in the volume
-          if (hydro) then
-             rho_a = (p_matrix(pr,k))/(287._wp*(t_kelvin))
-             
-             ! Loop over hydrometeor type
-             do tp=1,rcfg%nhclass
-                Re_internal = re_matrix(pr,k,tp)
-
-                if (hm_matrix(pr,k,tp) <= 1E-12) cycle
-                
-                ! Index into temperature dimension of scaling tables
-                !   These tables have regular steps -- exploit this and abandon infind
-                phase = sd%phase(tp)
-                if (phase==0) then
-                   itt = infind(mt_ttl,t_kelvin)
-                else
-                   itt = infind(mt_tti,t_kelvin) 
-                endif
-                
-                ! Compute effective radius from number concentration and distribution parameters
-                if (Re_internal .eq. 0) then
-                   call calc_Re(hm_matrix(pr,k,tp),Np_matrix(pr,k,tp),rho_a, &
-                        sd%dtype(tp),sd%apm(tp),sd%bpm(tp),sd%rho(tp),sd%p1(tp),sd%p2(tp),sd%p3(tp),Re)
-                   Re_internal=Re
-                   !re_matrix(pr,k,tp)=Re
-                else
-                   if (Np_matrix(pr,k,tp) > 0) then
-                      call errorMessage('WARNING(optics/quickbeam_optics.f90): Re and Np set for the same volume & hydrometeor type.  Np is being ignored.')
-                   endif
-                   Re = Re_internal
-                   !Re = re_matrix(pr,k,tp)
-                endif
-                
-                ! Index into particle size dimension of scaling tables 
-                iRe_type=1
-                if(Re.gt.0) then
-                   ! Determine index in to scale LUT
-                   ! Distance between Re points (defined by "base" and "step") for
-                   ! each interval of size Re_BIN_LENGTH
-                   ! Integer asignment, avoids calling floor intrinsic
-                   n=Re/Re_BIN_LENGTH
-                   if (n>=Re_MAX_BIN) n=Re_MAX_BIN-1
-                   step = rcfg%step_list(n+1)
-                   base = rcfg%base_list(n+1)
-                   iRe_type=Re/step
-                   if (iRe_type.lt.1) iRe_type=1
-                   Re=step*(iRe_type+0.5_wp)    ! set value of Re to closest value allowed in LUT.
-                   iRe_type=iRe_type+base-int(n*Re_BIN_LENGTH/step)
-                   
-                   ! Make sure iRe_type is within bounds
-                   if (iRe_type.ge.nRe_types) then
-                      !write(*,*) 'Warning: size of Re exceed value permitted ', &
-                      !            'in Look-Up Table (LUT).  Will calculate. '
-                      ! No scaling allowed
-                      iRe_type=nRe_types
-                      rcfg%Z_scale_flag(tp,itt,iRe_type)=.false.
-                   else
-                      ! Set value in re_matrix to closest values in LUT
-                      if (.not. DO_LUT_TEST) re_internal=Re
-                      !if (.not. DO_LUT_TEST) re_matrix(pr,k,tp)=Re
-                   endif
-                endif
-                
-                ! Use Ze_scaled, Zr_scaled, and kr_scaled ... if know them
-                ! if not we will calculate Ze, Zr, and Kr from the distribution parameters
-!                if( rcfg%Z_scale_flag(tp,itt,iRe_type) .and. .not. DO_LUT_TEST)  then
-!                   ! can use z scaling
-!                   scale_factor=rho_a*hm_matrix(pr,k,tp)
-!                   zr = rcfg%Zr_scaled(tp,itt,iRe_type) * scale_factor
-!                   ze = rcfg%Ze_scaled(tp,itt,iRe_type) * scale_factor
-!                   kr = rcfg%kr_scaled(tp,itt,iRe_type) * scale_factor
-!                else
-                if( (.not. rcfg%Z_scale_flag(tp,itt,iRe_type)) .or. DO_LUT_TEST)  then
-                   ! Create a discrete distribution of hydrometeors within volume
-                   select case(sd%dtype(tp))
-                   case(4)
-                      ns = 1
-                      allocate(Di(ns),Ni(ns),rhoi(ns),xxa(ns),Deq(ns))
-                      Di = sd%p1(tp)
-                      Ni = 0._wp
-                   case default
-                      ns = nd   ! constant defined in simulator/quickbeam.f90
-                      allocate(Di(ns),Ni(ns),rhoi(ns),xxa(ns),Deq(ns))
-                      Di = D
-                      Ni = 0._wp
-                   end select
-                   call dsd(hm_matrix(pr,k,tp),re_internal,Np_matrix(pr,k,tp), &
-                        Di,Ni,ns,sd%dtype(tp),rho_a,t_kelvin, &
-                        sd%dmin(tp),sd%dmax(tp),sd%apm(tp),sd%bpm(tp), &
-                        sd%rho(tp),sd%p1(tp),sd%p2(tp),sd%p3(tp))
-                   
-                   ! Calculate particle density
-                   if (phase == 1) then
-                      if (sd%rho(tp) < 0) then
-                         ! Use equivalent volume spheres.
-                         rcfg%rho_eff(tp,1:ns,iRe_type) = rhoice ! solid ice == equivalent volume approach
-                         Deq = ( ( 6/pi*sd%apm(tp)/rhoice) ** one_third ) * ( (Di*1E-6) ** (sd%bpm(tp)/3._wp) )  * 1E6
-                         ! alternative is to comment out above two lines and use the following block
-                         ! MG Mie approach - adjust density of sphere with D = D_characteristic to match particle density
-                         !
-                         ! rcfg%rho_eff(tp,1:ns,iRe_type) = (6/pi)*sd%apm(tp)*(Di*1E-6)**(sd%bpm(tp)-3)   !MG Mie approach
-                         
-                         ! as the particle size gets small it is possible that the mass to size relationship of 
-                         ! (given by power law in hclass.data) can produce impossible results 
-                         ! where the mass is larger than a solid sphere of ice.  
-                         ! This loop ensures that no ice particle can have more mass/density larger than an ice sphere.
-                         ! do i=1,ns
-                         ! if(rcfg%rho_eff(tp,i,iRe_type) > 917 ) then
-                         ! rcfg%rho_eff(tp,i,iRe_type) = 917
-                         ! endif
-                         ! enddo
-                      else
-                         ! Equivalent volume sphere (solid ice rhoice=917 kg/m^3).
-                         rcfg%rho_eff(tp,1:ns,iRe_type) = rhoice
-                         Deq=Di * ((sd%rho(tp)/rhoice)**one_third)
-                         ! alternative ... coment out above two lines and use the following for MG-Mie
-                         ! rcfg%rho_eff(tp,1:ns,iRe_type) = sd%rho(tp)   !MG Mie approach
-                      endif
-                   else
-                      ! I assume here that water phase droplets are spheres.
-                      ! sd%rho should be ~ 1000  or sd%apm=524 .and. sd%bpm=3
-                      Deq = Di
-                   endif
-
-                   ! Calculate effective reflectivity factor of volume
-                   ! xxa are unused (Mie scattering and extinction efficiencies)
-                   xxa(1:ns) = -9.9_wp
-                   rhoi = rcfg%rho_eff(tp,1:ns,iRe_type)
-                   call zeff(rcfg%freq,Deq,Ni,ns,rcfg%k2,t_kelvin,phase,rcfg%do_ray, &
-                        ze,zr,kr,xxa,xxa,rhoi)
-
-                   ! Test compares total number concentration with sum of discrete samples 
-                   ! The second test, below, compares ab initio and "scaled" computations 
-                   !    of reflectivity
-                   !  These should get broken out as a unit test that gets called on 
-                   !    data. That routine could write to std out. 
-                   
-                   ! Test code ... compare Np value input to routine with sum of DSD
-                   ! NOTE: if .not. DO_LUT_TEST, then you are checking the LUT approximation 
-                   ! not just the DSD representation given by Ni
-                   if(Np_matrix(pr,k,tp)>0 .and. DO_NP_TEST ) then
-                      Np = path_integral(Ni,Di,1,ns-1)/rho_a*1.E6_wp
-                      ! Note: Representation is not great or small Re < 2 
-                      if( (Np_matrix(pr,k,tp)-Np)/Np_matrix(pr,k,tp)>0.1 ) then
-                         call errorMessage('ERROR(optics/quickbeam_optics.f90): Error: Np input does not match sum(N)')
-                      endif
-                   endif
-
-                   ! Clean up space
-                   deallocate(Di,Ni,rhoi,xxa,Deq)
-
-                   ! LUT test code
-                   ! This segment of code compares full calculation to scaling result
-                   if ( rcfg%Z_scale_flag(tp,itt,iRe_type) .and. DO_LUT_TEST )  then
-                      scale_factor=rho_a*hm_matrix(pr,k,tp)
-                      ! if more than 2 dBZe difference print error message/parameters.
-                      if ( abs(10*log10(ze) - 10*log10(rcfg%Ze_scaled(tp,itt,iRe_type) * &
-                           scale_factor)) > 2 ) then
-                         call errorMessage('ERROR(optics/quickbeam_optics.f90): ERROR: Roj Error?')
-                      endif
-                   endif
-                else
-                   ! Use z scaling
-                   scale_factor=rho_a*hm_matrix(pr,k,tp)
-                   zr = rcfg%Zr_scaled(tp,itt,iRe_type) * scale_factor
-                   ze = rcfg%Ze_scaled(tp,itt,iRe_type) * scale_factor
-                   kr = rcfg%kr_scaled(tp,itt,iRe_type) * scale_factor
-                endif  ! end z_scaling
-                
-                kr_vol(pr,k) = kr_vol(pr,k) + kr
-                z_vol(pr,k)  = z_vol(pr,k)  + ze
-                z_ray(pr,k)  = z_ray(pr,k)  + zr
-                
-                ! Construct Ze_scaled, Zr_scaled, and kr_scaled ... if we can
-                if ( .not. rcfg%Z_scale_flag(tp,itt,iRe_type) ) then
-                   if (iRe_type>1) then
-                      scale_factor=rho_a*hm_matrix(pr,k,tp)
-                      rcfg%Ze_scaled(tp,itt,iRe_type) = ze/ scale_factor
-                      rcfg%Zr_scaled(tp,itt,iRe_type) = zr/ scale_factor
-                      rcfg%kr_scaled(tp,itt,iRe_type) = kr/ scale_factor
-                      rcfg%Z_scale_flag(tp,itt,iRe_type) = .true.
-                      rcfg%Z_scale_added_flag(tp,itt,iRe_type)=.true.
-                   endif
-                endif
-             enddo   ! end loop of tp (hydrometeor type)
-          endif
-       enddo
-    enddo
-    
-    where(kr_vol(:,:) <= EPSILON(kr_vol)) 
-       ! Volume is hydrometeor-free	
-       !z_vol(:,:)  = undef
-       z_ray(:,:)  = undef
-    end where
-
-  end subroutine quickbeam_optics
-  ! ##############################################################################################
-  ! ##############################################################################################
-  subroutine calc_Re(Q,Np,rho_a,dtype,apm,bpm,rho_c,p1,p2,p3,Re)  
-    ! ##############################################################################################
-    ! Purpose:
-    !   Calculates Effective Radius (1/2 distribution 3rd moment / 2nd moment). 
-    !
-    !   For some distribution types, the total number concentration (per kg), Np
-    !   may be optionally specified.   Should be set to zero, otherwise.
-    !
-    !   Roj Marchand July 2010
-    !
-    ! Inputs:
-    !
-    !   [Q]        hydrometeor mixing ratio (g/kg)  ! not needed for some distribution types
-    !   [Np]       Optional Total number concentration (per kg).  0 = use defaults (p1, p2, p3)
-    !   [rho_a]    ambient air density (kg m^-3)   
-    !
-    !   Distribution parameters as per quickbeam documentation.
-    !   [dtype]    distribution type
-    !   [apm]      a parameter for mass (kg m^[-bpm])
-    !   [bmp]      b params for mass 
-    !   [p1],[p2],[p3]  distribution parameters
-    !
-    ! Outputs:
-    !   [Re]       Effective radius, 1/2 the 3rd moment/2nd moment (um)
-    !
-    ! Created:
-    !   July 2010  Roj Marchand
-    ! Modified:
-    !   12/18/14  Dustin Swales: Define type REALs as double precision (dustin.swales@noaa.gov)
-    !
-    ! ##############################################################################################
-    ! ##############################################################################################
-    
-    ! Inputs
-    real(wp), intent(in)    :: Q,Np,rho_a,rho_c,p1,p2,p3
-    integer,  intent(in)    :: dtype
-    real(wp), intent(inout) :: apm,bpm  
-    
-    ! Outputs
-    real(wp), intent(out) :: Re
-    
-    ! Internal
-    integer  :: local_dtype
-    real(wp) :: local_p3,local_Np,tmp1,tmp2
-    real(wp) :: N0,D0,vu,dm,ld,rg,log_sigma_g        ! gamma, exponential variables
-    
-    
-    ! If density is constant, set equivalent values for apm and bpm
-    if ((rho_c > 0) .and. (apm < 0)) then
-       apm = (pi/6)*rho_c
-       bpm = 3._wp
-    endif
-    
-    ! Exponential is same as modified gamma with vu =1
-    ! if Np is specified then we will just treat as modified gamma
-    if(dtype .eq. 2 .and. Np .gt. 0) then
-       local_dtype = 1
-       local_p3    = 1
-    else
-       local_dtype = dtype
-       local_p3    = p3
-    endif
-    select case(local_dtype)
-       
-       ! ---------------------------------------------------------!
-       ! Modified gamma                                           !
-       ! Np = total number concentration (1/kg) = Nt / rho_a      !
-       ! D0 = characteristic diameter (um)                        !
-       ! dm = mean diameter (um) - first moment over zeroth moment!
-       ! vu = distribution width parameter                        !
-       ! ---------------------------------------------------------!
-    case(1)  
-       
-       if( abs(local_p3+2) < 1E-8) then
-          if(Np>1E-30) then
-             ! Morrison scheme with Martin 1994 shape parameter (NOTE: vu = pc +1)
-             ! fixed Roj. Dec. 2010 -- after comment by S. Mcfarlane
-             vu = (1/(0.2714_wp + 0.00057145_wp*Np*rho_a*1E-6))**2 ! units of Nt = Np*rhoa = #/cm^3
-          else
-             call errorMessage('FATAL ERROR(optics/quickbeam_optics.f90:Calc_Re): Must specify a value for Np in each volume with Morrison/Martin Scheme.')
-             return
-          endif
-       elseif (abs(local_p3+1) > 1E-8) then
-          ! vu is fixed in hp structure  
-          vu = local_p3 
-       else
-          ! vu isn't specified
-          call errorMessage('FATAL ERROR(optics/quickbeam_optics.f90:Calc_Re): Must specify a value for vu for Modified Gamma distribution')
-          return
-       endif
-       
-       if( Np.eq.0 .and. p2+1 > 1E-8) then     ! use default value for MEAN diameter as first default  
-          dm = p2             ! by definition, should have units of microns
-          D0 = gamma(vu)/gamma(vu+1)*dm
-       else   ! use value of Np
-          if(Np.eq.0) then
-             if( abs(p1+1) > 1E-8 ) then  !   use default number concentration   
-                local_Np = p1 ! total number concentration / pa --- units kg^-1
-             else
-                call errorMessage('FATAL ERROR(optics/quickbeam_optics.f90:Calc_Re): Must specify Np or default value (p1=Dm [um] or p2=Np [1/kg]) for Modified Gamma distribution')
-                return
-             endif
-          else
-             local_Np=Np;    
-          endif
-          D0 = 1E6 * ( Q*1E-3*gamma(vu)/(apm*local_Np*gamma(vu+bpm)) )**(1/bpm)  ! units = microns
-       endif
-       Re = 0.5_wp*D0*gamma(vu+3)/gamma(vu+2)
-       
-       ! ---------------------------------------------------------!
-       ! Exponential                                              !
-       ! N0 = intercept parameter (m^-4)                          !
-       ! ld = slope parameter (um)                                !
-       ! ---------------------------------------------------------!
-    case(2)
-       
-       ! Np not specified (see if statement above) 
-       if((abs(p1+1) > 1E-8) ) then   ! N0 has been specified, determine ld
-          N0   = p1
-          tmp1 = 1._wp/(1._wp+bpm)
-          ld   = ((apm*gamma(1.+bpm)*N0)/(rho_a*Q*1E-3))**tmp1
-          ld   = ld/1E6                     ! set units to microns^-1
-       elseif (abs(p2+1) > 1E-8) then  ! lambda=ld has been specified as default
-          ld = p2     ! should have units of microns^-1 
-       else
-          call errorMessage('FATAL ERROR(optics/quickbeam_optics.f90:Calc_Re): Must specify Np or default value (p1=No or p2=lambda) for Exponential distribution')
-          return
-       endif
-       Re = 1.5_wp/ld 
-       
-       ! ---------------------------------------------------------!
-       ! Power law                                                !
-       ! ahp = Ar parameter (m^-4 mm^-bhp)                        !
-       ! bhp = br parameter                                       !
-       ! dmin_mm = lower bound (mm)                               !
-       ! dmax_mm = upper bound (mm)                               !
-       ! ---------------------------------------------------------!
-    case(3)
-       
-       Re=0._wp  ! Not supporting LUT approach for power-law ...
-       if(Np>0) then
-          call errorMessage('FATAL ERROR(optics/quickbeam_optics.f90:Calc_Re): Variable Np not supported for Power Law distribution')
-          return
-       endif
-       
-       ! ---------------------------------------------------------!
-       ! Monodisperse                                             !
-       ! D0 = particle diameter (um) == Re                        !
-       ! ---------------------------------------------------------!
-    case(4)
-       
-       Re = p1
-       if(Np>0) then
-          call errorMessage('FATAL ERROR(optics/quickbeam_optics.f90:Calc_Re): Variable Np not supported for Monodispersed distribution')
-          return
-       endif
-       
-       ! ---------------------------------------------------------!
-       ! Lognormal                                                !
-       ! N0 = total number concentration (m^-3)                   !
-       ! np = fixed number concentration (kg^-1)                  !
-       ! rg = mean radius (um)                                    !
-       ! log_sigma_g = ln(geometric standard deviation)           !
-       ! ---------------------------------------------------------!
-    case(5)
-       
-       if( abs(local_p3+1) > 1E-8 ) then
-          !set natural log width
-          log_sigma_g = local_p3 
-       else
-          call errorMessage('FATAL ERROR(optics/quickbeam_optics.f90:Calc_Re): Must specify a value for sigma_g when using a Log-Normal distribution')
-          return
-       endif
-       
-       ! get rg ... 
-       if( Np.eq.0 .and. (abs(p2+1) > 1E-8) ) then ! use default value of rg
-          rg = p2     
-       else
-          if(Np>0) then
-             local_Np=Np;  
-          elseif(abs(p2+1) < 1E-8) then
-             local_Np=p1
-          else
-             call errorMessage('ERROR(optics/quickbeam_optics.f90:Calc_Re): Must specify Np or default value (p2=Rg or p1=Np) for Log-Normal distribution')
-          endif
-          log_sigma_g = p3
-          tmp1        = (Q*1E-3)/(2._wp**bpm*apm*local_Np)
-          tmp2        = exp(0.5_wp*bpm*bpm*(log_sigma_g))*exp(0.5_wp*bpm*bpm*(log_sigma_g))    
-          rg          = ((tmp1/tmp2)**(1._wp/bpm))*1E6
-       endif
-       Re = rg*exp(2.5_wp*(log_sigma_g*log_sigma_g))    
-    end select
-  end subroutine calc_Re
-  ! ##############################################################################################
-  ! ##############################################################################################
-  subroutine dsd(Q,Re,Np,D,N,nsizes,dtype,rho_a,tk,dmin,dmax,apm,bpm,rho_c,p1,p2,p3)
-    ! ##############################################################################################
-    ! Purpose:
-    !   Create a discrete drop size distribution
-    !
-    !   Starting with Quickbeam V3, this routine now allows input of 
-    !   both effective radius (Re) and total number concentration (Nt)
-    !   Roj Marchand July 2010
-    !
-    !   The version in Quickbeam v.104 was modified to allow Re but not Nt 
-    !   This is a significantly modified form for the version      
-    !
-    !   Originally Part of QuickBeam v1.03 by John Haynes
-    !   http://reef.atmos.colostate.edu/haynes/radarsim
-    !
-    ! Inputs:
-    !
-    !   [Q]        hydrometeor mixing ratio (g/kg)
-    !   [Re]       Optional Effective Radius (microns).  0 = use defaults (p1, p2, p3)
-    !
-    !   [D]        array of discrete drop sizes (um) where we desire to know the number concentraiton n(D).
-    !   [nsizes]   number of elements of [D]
-    !
-    !   [dtype]    distribution type
-    !   [rho_a]    ambient air density (kg m^-3)
-    !   [tk]       temperature (K)
-    !   [dmin]     minimum size cutoff (um)
-    !   [dmax]     maximum size cutoff (um)
-    !   [rho_c]    alternate constant density (kg m^-3)
-    !   [p1],[p2],[p3]  distribution parameters
-    !
-    ! Input/Output:
-    !   [apm]      a parameter for mass (kg m^[-bpm])
-    !   [bmp]      b params for mass
-    !
-    ! Outputs:
-    !   [N]        discrete concentrations (cm^-3 um^-1)
-    !              or, for monodisperse, a constant (1/cm^3)
-    !
-    ! Requires:
-    !   function infind
-    !
-    ! Created:
-    !   11/28/05  John Haynes (haynes@atmos.colostate.edu)
-    ! Modified:
-    !   01/31/06  Port from IDL to Fortran 90
-    !   07/07/06  Rewritten for variable DSD's
-    !   10/02/06  Rewritten using scaling factors (Roger Marchand and JMH), Re added V1.04
-    !   July 2020 "N Scale factors" (variable fc) removed (Roj Marchand).
-    !   12/18/14  Define type REALs as double precision (dustin.swales@noaa.gov)
-    ! ##############################################################################################
-    
-    ! Inputs
-    integer, intent(in)                   :: &
-         nsizes,& ! Number of elements of [D]
-         dtype    !  distribution type
-    real(wp),intent(in),dimension(nsizes) :: &
-         D        ! Array of discrete drop sizes (um) where we desire to know the number concentraiton n(D).
-    real(wp),intent(in) :: &
-         Q,     & ! Hydrometeor mixing ratio (g/kg)
-         Np,    & !
-         rho_a, & ! Ambient air density (kg m^-3)
-         tk,    & ! Temperature (K)
-         dmin,  & ! Minimum size cutoff (um)
-         dmax,  & ! Maximum size cutoff (um)
-         rho_c, & ! Alternate constant density (kg m^-3)
-         p1,    & ! Distribution parameter 1
-         p2,    & ! Distribution parameter 2
-         p3       ! Distribution parameter 3
-    real(wp),intent(inout) :: &
-         apm,   & ! a parameter for mass (kg m^[-bpm])
-         bpm,   & ! b params for mass
-         Re       ! Optional Effective Radius (microns)
-    
-    ! Outputs
-    real(wp),intent(out),dimension(nsizes) :: &
-         N        ! Discrete concentrations (cm^-3 um^-1)
-                  ! or, for monodisperse, a constant (1/cm^3)
-    
-    ! Internal Variables
-    real(wp),dimension(nsizes) :: &
-         fc
-    real(wp)                   :: &
-         N0,D0,vu,local_np,dm,ld, & ! gamma, exponential variables
-         dmin_mm,dmax_mm,ahp,bhp, & ! power law variables
-         rg,log_sigma_g,          & ! lognormal variables
-         rho_e,                   & ! particle density (kg m^-3)
-         tmp1,tmp2,tc
-    integer :: &
-         k,lidx,uidx
-    
-    ! Convert temperature from Kelvin to Celsius
-    tc = tk - 273.15_wp
-    
-    ! If density is constant, store equivalent values for apm and bpm
-    if ((rho_c > 0) .and. (apm < 0)) then
-       apm = (pi/6)*rho_c
-       bpm = 3._wp
-    endif
-    
-    ! Will preferentially use Re input over Np.
-    ! if only Np given then calculate Re
-    ! if neigher than use other defaults (p1,p2,p3) following quickbeam documentation
-    if(Re==0 .and. Np>0) then
-       call calc_Re(Q,Np,rho_a,dtype,apm,bpm,rho_c,p1,p2,p3,Re)
-    endif
-    select case(dtype)
-       
-       ! ---------------------------------------------------------!
-       ! Modified gamma                                           !
-       ! np = total number concentration                          !
-       ! D0 = characteristic diameter (um)                        !
-       ! dm = mean diameter (um) - first moment over zeroth moment!
-       ! vu = distribution width parameter                        !
-       ! ---------------------------------------------------------!
-    case(1)  
-       
-       if( abs(p3+2) < 1E-8) then
-          if( Np>1E-30) then
-             ! Morrison scheme with Martin 1994 shape parameter (NOTE: vu = pc +1)
-             ! fixed Roj. Dec. 2010 -- after comment by S. Mcfarlane
-             vu = (1/(0.2714_wp + 0.00057145_wp*Np*rho_a*1E-6))**2._wp ! units of Nt = Np*rhoa = #/cm^3
-          else
-             call errorMessage('FATAL ERROR(optics/quickbeam_optics.f90:dsd): Must specify a value for Np in each volume with Morrison/Martin Scheme.')
-             return
-          endif
-       elseif (abs(p3+1) > 1E-8) then
-          ! vu is fixed in hp structure  
-          vu = p3 
-       else
-          ! vu isn't specified
-          call errorMessage('FATAL ERROR(optics/quickbeam_optics.f90:dsd): Must specify a value for vu for Modified Gamma distribution')
-          return
-       endif
-       
-       if(Re>0) then
-          D0 = 2._wp*Re*gamma(vu+2)/gamma(vu+3)
-          fc = (((D*1E-6)**(vu-1)*exp(-1*D/D0)) / &
-               (apm*((D0*1E-6)**(vu+bpm))*gamma(vu+bpm))) * 1E-12
-          N  = fc*rho_a*(Q*1E-3)
-       elseif( p2+1 > 1E-8) then     ! use default value for MEAN diameter
-          dm = p2
-          D0 = gamma(vu)/gamma(vu+1)*dm
-          fc = (((D*1E-6)**(vu-1)*exp(-1*D/D0)) / &
-               (apm*((D0*1E-6)**(vu+bpm))*gamma(vu+bpm))) * 1E-12
-          N  = fc*rho_a*(Q*1E-3)
-       elseif(abs(p3+1) > 1E-8)  then! use default number concentration
-          local_np = p1 ! total number concentration / pa check
-          tmp1     = (Q*1E-3)**(1./bpm)
-          fc       = (D*1E-6 / (gamma(vu)/(apm*local_np*gamma(vu+bpm)))**(1._wp/bpm))**vu
-          N        = ((rho_a*local_np*fc*(D*1E-6)**(-1._wp))/(gamma(vu)*tmp1**vu) * &
-               exp(-1._wp*fc**(1._wp/vu)/tmp1)) * 1E-12
-       else
-          call errorMessage('FATAL ERROR(optics/quickbeam_optics.f90:dsd): No default value for Dm or Np provided!')
-          return
-       endif
-       
-       ! ---------------------------------------------------------!
-       ! Exponential                                              !
-       ! N0 = intercept parameter (m^-4)                          !
-       ! ld = slope parameter (um)                                !
-       ! ---------------------------------------------------------!
-    case(2)
-       
-       if(Re>0) then
-          ld = 1.5_wp/Re   ! units 1/um
-          fc = (ld*1E6)**(1.+bpm)/(apm*gamma(1+bpm))*exp(-1._wp*(ld*1E6)*(D*1E-6))*1E-12
-          N  = fc*rho_a*(Q*1E-3)
-       elseif (abs(p1+1) > 1E-8) then
-          ! Use N0 default value
-          N0   = p1
-          tmp1 = 1._wp/(1._wp+bpm)
-          fc   = ((apm*gamma(1.+bpm)*N0)**tmp1)*(D*1E-6)
-          N    = (N0*exp(-1._wp*fc*(1._wp/(rho_a*Q*1E-3))**tmp1)) * 1E-12
-       elseif (abs(p2+1) > 1E-8) then
-          ! Use default value for lambda 
-          ld = p2
-          fc = (ld*1E6)**(1._wp+bpm)/(apm*gamma(1+bpm))*exp(-1._wp*(ld*1E6)*(D*1E-6))*1E-12
-          N  = fc*rho_a*(Q*1E-3)
-       else
-          ! ld "parameterized" from temperature (carry over from original Quickbeam).
-          ld = 1220._wp*10._wp**(-0.0245_wp*tc)*1E-6
-          N0 = ((ld*1E6)**(1._wp+bpm)*Q*1E-3*rho_a)/(apm*gamma(1+bpm))
-          N  = (N0*exp(-ld*D)) * 1E-12
-       endif
-       
-       ! ---------------------------------------------------------!
-       ! Power law                                                !
-       ! ahp = Ar parameter (m^-4 mm^-bhp)                        !
-       ! bhp = br parameter                                       !
-       ! dmin_mm = lower bound (mm)                               !
-       ! dmax_mm = upper bound (mm)                               !
-       ! ---------------------------------------------------------!
-    case(3)
-       
-       if(Re>0) then
-          call errorMessage('FATAL ERROR(optics/quickbeam_optics.f90:dsd): Variable Re not supported for Power-Law distribution')
-          return
-       elseif(Np>0) then
-          call errorMessage('FATAL ERROR(optics/quickbeam_optics.f90:dsd): Variable Np not supported for Power-Law distribution')
-          return
-       endif
-       
-       ! br parameter
-       if (abs(p1+2) < 1E-8) then
-          ! if p1=-2, bhp is parameterized according to Ryan (2000),
-          ! applicatable to cirrus clouds
-          if (tc < -30) then
-             bhp = -1.75_wp+0.09_wp*((tc+273._wp)-243.16_wp)
-          elseif ((tc >= -30) .and. (tc < -9)) then
-             bhp = -3.25_wp-0.06_wp*((tc+273._wp)-265.66_wp)
-          else
-             bhp = -2.15_wp
-          endif
-       elseif (abs(p1+3) < 1E-8) then      
-          ! if p1=-3, bhp is parameterized according to Ryan (2000),
-          ! applicable to frontal clouds
-          if (tc < -35) then
-             bhp = -1.75_wp+0.09_wp*((tc+273._wp)-243.16_wp)
-          elseif ((tc >= -35) .and. (tc < -17.5)) then
-             bhp = -2.65_wp+0.09_wp*((tc+273._wp)-255.66_wp)
-          elseif ((tc >= -17.5) .and. (tc < -9)) then
-             bhp = -3.25_wp-0.06_wp*((tc+273._wp)-265.66_wp)
-          else
-             bhp = -2.15_wp
-          endif
-       else
-          ! Otherwise the specified value is used
-          bhp = p1
-       endif
-       
-       ! Ar parameter
-       dmin_mm = dmin*1E-3
-       dmax_mm = dmax*1E-3
-       
-       ! Commented lines are original method with constant density
-       ! rc = 500.       ! (kg/m^3)
-       ! tmp1 = 6*rho_a*(bhp+4)
-       ! tmp2 = pi*rc*(dmax_mm**(bhp+4))*(1-(dmin_mm/dmax_mm)**(bhp+4))
-       ! ahp = (Q*1E-3)*1E12*tmp1/tmp2
-       
-       ! New method is more consistent with the rest of the distributions
-       ! and allows density to vary with particle size
-       tmp1 = rho_a*(Q*1E-3)*(bhp+bpm+1)
-       tmp2 = apm*(dmax_mm**bhp*dmax**(bpm+1)-dmin_mm**bhp*dmin**(bpm+1))
-       ahp  = tmp1/tmp2 * 1E24
-       ! ahp = tmp1/tmp2 
-       lidx = infind(D,dmin)
-       uidx = infind(D,dmax)    
-       do k=lidx,uidx
-          N(k) = (ahp*(D(k)*1E-3)**bhp) * 1E-12    
-       enddo
-       
-       ! ---------------------------------------------------------!
-       ! Monodisperse                                             !
-       ! D0 = particle diameter (um)                              !
-       ! ---------------------------------------------------------!
-    case(4)
-       
-       if (Re>0) then
-          D0 = Re
-       else
-          D0 = p1
-       endif
-       
-       rho_e = (6._wp/pi)*apm*(D0*1E-6)**(bpm-3)
-       fc(1) = (6._wp/(pi*D0*D0*D0*rho_e))*1E12
-       N(1)  = fc(1)*rho_a*(Q*1E-3)
-       
-       ! ---------------------------------------------------------!
-       ! Lognormal                                                !
-       ! N0 = total number concentration (m^-3)                   !
-       ! np = fixed number concentration (kg^-1)                  !
-       ! rg = mean radius (um)                                    !
-       ! og_sigma_g = ln(geometric standard deviation)            !
-       ! ---------------------------------------------------------!
-    case(5)
-       if (abs(p1+1) < 1E-8 .or. Re>0 ) then
-          ! rg, log_sigma_g are given
-          log_sigma_g = p3
-          tmp2 = (bpm*log_sigma_g)*(bpm*log_sigma_g)
-          if(Re.le.0) then 
-             rg = p2
-          else
-             !rg = Re*exp(-2.5*(log_sigma_g*log_sigma_g))
-             rg =Re*exp(-2.5_wp*(log_sigma_g**2))
-             
-          endif
-          
-          fc = 0.5_wp*((1._wp/((2._wp*rg*1E-6)**(bpm)*apm*(2._wp*pi)**(0.5_wp) * &
-               log_sigma_g*D*0.5_wp*1E-6))*exp(-0.5_wp*((log(0.5_wp*D/rg)/log_sigma_g)**2._wp+tmp2)))*1E-12
-          N = fc*rho_a*(Q*1E-3)
-          
-       elseif (abs(p2+1) < 1E-8 .or. Np>0) then
-          ! Np, log_sigma_g are given    
-          if(Np>0) then
-             local_Np = Np
-          else
-             local_Np = p1
-          endif
-          
-          log_sigma_g = p3
-          N0   = local_np*rho_a
-          tmp1 = (rho_a*(Q*1E-3))/(2._wp**bpm*apm*N0)
-          tmp2 = exp(0.5_wp*bpm*bpm*(log_sigma_g))*exp(0.5_wp*bpm*bpm*(log_sigma_g))
-          rg   = ((tmp1/tmp2)**(1/bpm))*1E6
-          
-          N = 0.5_wp*(N0 / ((2._wp*pi)**(0.5_wp)*log_sigma_g*D*0.5_wp*1E-6) * &
-               exp((-0.5_wp*(log(0.5_wp*D/rg)/log_sigma_g)**2._wp)))*1E-12      
-       else
-          call errorMessage('FATAL ERROR(optics/quickbeam_optics.f90:dsd): Must specify a value for sigma_g')
-          return
-       endif
-    end select
-  end subroutine dsd
-  ! ##############################################################################################
-  ! ##############################################################################################
-  subroutine zeff(freq,D,N,nsizes,k2,tt,ice,xr,z_eff,z_ray,kr,qe,qs,rho_e)
-    ! ##############################################################################################
-    ! Purpose:
-    !   Simulates radar return of a volume given DSD of spheres
-    !   Part of QuickBeam v1.03 by John Haynes
-    !   http://reef.atmos.colostate.edu/haynes/radarsim
-    !
-    ! Inputs:
-    !   [freq]      radar frequency (GHz)
-    !   [D]         discrete drop sizes (um)
-    !   [N]         discrete concentrations (cm^-3 um^-1)
-    !   [nsizes]    number of discrete drop sizes
-    !   [k2]        |K|^2, -1=use frequency dependent default 
-    !   [tt]        hydrometeor temperature (K)
-    !   [ice]       indicates volume consists of ice
-    !   [xr]        perform Rayleigh calculations?
-    !   [qe]        if using a mie table, these contain ext/sca ...
-    !   [qs]        ... efficiencies; otherwise set to -1
-    !   [rho_e]     medium effective density (kg m^-3) (-1 = pure)
-    !
-    ! Outputs:
-    !   [z_eff]     unattenuated effective reflectivity factor (mm^6/m^3)
-    !   [z_ray]     reflectivity factor, Rayleigh only (mm^6/m^3)
-    !   [kr]        attenuation coefficient (db km^-1)
-    !
-    ! Created:
-    !   11/28/05  John Haynes (haynes@atmos.colostate.edu)
-    ! Modified:
-    !   12/18/14  Dustin Swales: Define type REALs as double precision (dustin.swales@noaa.gov)
-    ! ##############################################################################################
-    ! Inputs
-    integer,  intent(in) :: &
-         ice,        & ! Indicates volume consists of ice
-         xr,         & ! Perform Rayleigh calculations?
-         nsizes        ! Number of discrete drop sizes
-    real(wp), intent(in),dimension(nsizes) :: &
-         D,     & ! Discrete drop sizes (um)
-         N,     & ! Discrete concentrations (cm^-3 um^-1)
-         rho_e, & ! Medium effective density (kg m^-3) (-1 = pure)
-         qe,    & ! Extinction efficiency, when using Mie tables
-         qs       ! Scatering efficiency, when using Mie tables
-    real(wp),intent(in) :: &
-         freq,  & ! Radar frequency (GHz)
-         tt       ! Hydrometeor temperature (K)
-    real(wp), intent(inout) :: &
-         k2            ! |K|^2, -1=use frequency dependent default 
-    
-    ! Outputs
-    real(wp), intent(out) :: &
-         z_eff,      & ! Unattenuated effective reflectivity factor (mm^6/m^3)
-         z_ray,      & ! Reflectivity factor, Rayleigh only (mm^6/m^3)
-         kr            ! Attenuation coefficient (db km^-1)
-    
-    ! Internal Variables
-    integer                     :: correct_for_rho ! Correct for density flag
-    real(wp), dimension(nsizes) :: &
-         D0,        &    ! D in (m)
-         N0,        &    ! N in m^-3 m^-1
-         sizep,     &    ! Size parameter
-         qext,      &    ! Extinction efficiency
-         qbsca,     &    ! Backscatter efficiency
-         f,         &    ! Ice fraction
-         xtemp           !
-    real(wp) :: &
-         wl, cr,eta_sum,eta_mie,const,z0_eff,z0_ray,k_sum,n_r,n_i,dqv(1),dqsc,dg,dph(1)
-    complex(wp)         :: &
-         m,                  &    ! Complex index of refraction of bulk form
-         Xs1(1), Xs2(1)           !
-    integer          :: &
-         i, err                   !
-    integer, parameter :: &
-         one=1                    !
-    real(wp),parameter :: &
-         conv_d  = 1e-6,     &    ! Conversion factor for drop sizes (to m)
-         conv_n  = 1e12,     &    ! Conversion factor for drop concentrations (to m^-3)
-         conv_f  = 0.299792458    ! Conversion for radar frequency (to m)
-    complex(wp),dimension(nsizes) ::&
-         m0             ! Complex index of refraction
-    
-    ! Initialize
-    z0_ray = 0._wp
-    
-    ! Conversions
-    D0 = d*conv_d
-    N0 = n*conv_n
-    wl = conv_f/freq
-    
-    ! // dielectric constant |k^2| defaults
-    if (k2 < 0) then
-       k2 = 0.933_wp
-       if (abs(94.-freq) < 3.) k2=0.75_wp
-       if (abs(35.-freq) < 3.) k2=0.88_wp
-       if (abs(13.8-freq) < 3.) k2=0.925_wp
-    endif
-    
-    if (qe(1) < -9) then
-       
-       ! Get the refractive index of the bulk hydrometeors
-       if (ice == 0) then
-          call m_wat(freq,tt,n_r,n_i)
-       else
-          call m_ice(freq,tt,n_r,n_i)
-       endif
-       m = cmplx(n_r,-n_i)
-       m0(1:nsizes) = m
-       
-       correct_for_rho = 0
-       if ((ice == 1) .and. (minval(rho_e) >= 0)) correct_for_rho = 1
-       
-       ! Correct refractive index for ice density if needed
-       if (correct_for_rho == 1) then
-          f  = rho_e/rhoice
-          m0 = sqrt((2+(m0*m0)+2*f*((m0*m0)-1))/(2+(m0*m0)+f*(1-(m0*m0))))
-       endif
-       
-       ! Mie calculations
-       sizep = (pi*D0)/wl
-       dqv(1) = 0._wp
-       do i=1,nsizes
-          call mieint(sizep(i), m0(i), one, dqv, qext(i), dqsc, qbsca(i), &
-               dg, xs1, xs2, dph, err)
-       end do
-
-    else
-       ! Mie table used
-       qext  = qe
-       qbsca = qs
-    endif
-    
-    ! eta_mie = 0.25*sum[qbsca*pi*D^2*N(D)*deltaD]
-    ! <--------- eta_sum --------->
-    ! z0_eff = (wl^4/!pi^5)*(1./k2)*eta_mie
-    eta_sum = 0._wp
-    if (size(D0) == 1) then
-       eta_sum = qbsca(1)*(n(1)*1E6)*D0(1)*D0(1)
-    else
-       xtemp = qbsca*N0*D0*D0
-       call avint(xtemp,D0,nsizes,D0(1),D0(size(D0,1)),eta_sum)
-    endif
-    
-    eta_mie = eta_sum*0.25_wp*pi
-    const   = ((wl*wl*wl*wl)/(pi*pi*pi*pi*pi))*(1._wp/k2)
-    
-    z0_eff  = const*eta_mie
-    
-    ! kr = 0.25*cr*sum[qext*pi*D^2*N(D)*deltaD]
-    ! <---------- k_sum --------->  
-    k_sum = 0._wp
-    if (size(D0) == 1) then
-       k_sum = qext(1)*(n(1)*1E6)*D0(1)*D0(1)
-    else
-       xtemp = qext*N0*D0*D0
-       call avint(xtemp,D0,nsizes,D0(1),D0(size(D0,1)),k_sum)
-    endif
-    ! DS2014 START: Making this calculation in double precision results in a small 
-    !               amount of very small errors in the COSP output field,dBZE94,
-    !               so it will be left as is.
-    !cr = 10._wp/log(10._wp)
-    cr = 10./log(10.)
-    ! DS2014 STOP
-    kr = k_sum*0.25_wp*pi*(1000._wp*cr)
-    
-    ! z_ray = sum[D^6*N(D)*deltaD]
-    if (xr == 1) then
-       z0_ray = 0._wp
-       if (size(D0) == 1) then
-          z0_ray = (n(1)*1E6)*D0(1)*D0(1)*D0(1)*D0(1)*D0(1)*D0(1)
-       else
-          xtemp = N0*D0*D0*D0*D0*D0*D0
-          call avint(xtemp,D0,nsizes,D0(1),D0(size(D0)),z0_ray)
-       endif
-    endif
-    
-    ! Convert to mm^6/m^3
-    z_eff = z0_eff*1E18 !  10.*alog10(z0_eff*1E18)
-    z_ray = z0_ray*1E18 !  10.*alog10(z0_ray*1E18)
-    
-  end subroutine zeff
-  ! ##############################################################################################
-  ! ##############################################################################################
-  function gases(PRES_mb,T,SH,f)
-    ! ##############################################################################################
-    ! Purpose:
-    !   Compute 2-way gaseous attenuation through a volume in microwave
-    !
-    ! Inputs:
-    !   [PRES_mb]   pressure (mb) (hPa)
-    !   [T]         temperature (K)
-    !   [RH]        relative humidity (%)
-    !   [f]         frequency (GHz), < 300 GHz
-    !
-    ! Returns:
-    !   2-way gaseous attenuation (dB/km)
-    !
-    ! Reference:
-    !   Uses method of Liebe (1985)
-    !
-    ! Created:
-    !   12/09/05  John Haynes (haynes@atmos.colostate.edu)
-    ! Modified:
-    !   01/31/06  Port from IDL to Fortran 90
-    !   12/19/14  Dustin Swales: Define type REALs as double precision (dustin.swales@noaa.gov)
-    ! ##############################################################################################
-    
-    ! INPUTS
-    real(wp), intent(in) :: & !
-         PRES_mb,           & ! Pressure (mb) (hPa)
-         T,                 & ! Temperature (K)
-         SH,                & ! Specific humidity
-         f                    ! Frequency (GHz), < 300 GHz
-    
-    ! PARAMETERS
-    integer, parameter   :: & !
-         nbands_o2  = 48,   & ! Number of O2 bands
-         nbands_h2o = 30      ! Number of h2o bands
-    ! LOCAL VARIABLES
-    real(wp) :: &
-         gases, th, e, p, sumo, gm0, a0, ap, term1,    &
-         term2, term3, bf, be, term4, npp,e_th,one_th, &
-         pth3,eth35,aux1,aux2,aux3, aux4,gm,delt,x,y,  &
-         gm2,fpp_o2,fpp_h2o,s_o2,s_h2o
-    integer :: i
-
-    ! Table1 parameters  v0, a1, a2, a3, a4, a5, a6  
-    real(wp),dimension(nbands_o2),parameter ::                                          &
-         v0 = (/49.4523790,49.9622570,50.4742380,50.9877480,51.5033500,                 &
-                52.0214090,52.5423930,53.0669060,53.5957480,54.1299999,54.6711570,      &
-                55.2213650,55.7838000,56.2647770,56.3378700,56.9681000,57.6124810,      &
-                58.3238740,58.4465890,59.1642040,59.5909820,60.3060570,60.4347750,      &
-                61.1505580,61.8001520,62.4112120,62.4862530,62.9979740,63.5685150,      &
-                64.1277640,64.6789000,65.2240670,65.7647690,66.3020880,66.8368270,      &
-                67.3695950,67.9008620,68.4310010,68.9603060,69.4890210,70.0173420,      &
-                118.7503410,368.4983500,424.7631200,487.2493700,715.3931500,            &
-                773.8387300, 834.1453300/),                                             &
-         a1 = (/0.0000001,0.0000003,0.0000009,0.0000025,0.0000061,0.0000141,            &
-                0.0000310,0.0000641,0.0001247,0.0002280,0.0003918,0.0006316,0.0009535,  &
-                0.0005489,0.0013440,0.0017630,0.0000213,0.0000239,0.0000146,0.0000240,  &
-                0.0000211,0.0000212,0.0000246,0.0000250,0.0000230,0.0000193,0.0000152,  &
-                0.0000150,0.0000109,0.0007335,0.0004635,0.0002748,0.0001530,0.0000801,  &
-                0.0000395,0.0000183,0.0000080,0.0000033,0.0000013,0.0000005,0.0000002,  &
-                0.0000094,0.0000679,0.0006380,0.0002350,0.0000996,0.0006710,0.0001800/),&
-         a2 = (/11.8300000,10.7200000,9.6900000,8.8900000,7.7400000,6.8400000,          &
-                6.0000000,5.2200000,4.4800000,3.8100000,3.1900000,2.6200000,2.1150000,  &
-                0.0100000,1.6550000,1.2550000,0.9100000,0.6210000,0.0790000,0.3860000,  &
-                0.2070000,0.2070000,0.3860000,0.6210000,0.9100000,1.2550000,0.0780000,  &
-                1.6600000,2.1100000,2.6200000,3.1900000,3.8100000,4.4800000,5.2200000,  &
-                6.0000000,6.8400000,7.7400000,8.6900000,9.6900000,10.7200000,11.8300000,&
-                0.0000000,0.0200000,0.0110000,0.0110000,0.0890000,0.0790000,0.0790000/),&
-         a3 = (/0.0083000,0.0085000,0.0086000,0.0087000,0.0089000,0.0092000,            &
-                0.0094000,0.0097000,0.0100000,0.0102000,0.0105000,0.0107900,0.0111000,  &
-                0.0164600,0.0114400,0.0118100,0.0122100,0.0126600,0.0144900,0.0131900,  &
-                0.0136000,0.0138200,0.0129700,0.0124800,0.0120700,0.0117100,0.0146800,  &
-                0.0113900,0.0110800,0.0107800,0.0105000,0.0102000,0.0100000,0.0097000,  &
-                0.0094000,0.0092000,0.0089000,0.0087000,0.0086000,0.0085000,0.0084000,  &
-                0.0159200,0.0192000,0.0191600,0.0192000,0.0181000,0.0181000,0.0181000/),&
-         a4 = (/0.0000000,0.0000000,0.0000000,0.0000000,0.0000000,0.0000000,            &
-                0.0000000,0.0000000,0.0000000,0.0000000,0.0000000,0.0000000,0.0000000,  &
-                0.0000000,0.0000000,0.0000000,0.0000000,0.0000000,0.0000000,0.0000000,  &
-                0.0000000,0.0000000,0.0000000,0.0000000,0.0000000,0.0000000,0.0000000,  &
-                0.0000000,0.0000000,0.0000000,0.0000000,0.0000000,0.0000000,0.0000000,  &
-                0.0000000,0.0000000,0.0000000,0.0000000,0.0000000,0.0000000,0.0000000,  &
-                0.0000000,0.6000000,0.6000000,0.6000000,0.6000000,0.6000000,0.6000000/),&
-         a5 = (/0.0056000,0.0056000,0.0056000,0.0055000,0.0056000,0.0055000,            &
-                0.0057000,0.0053000,0.0054000,0.0048000,0.0048000,0.0041700,0.0037500,  &
-                0.0077400,0.0029700,0.0021200,0.0009400,-0.0005500,0.0059700,-0.0024400,&
-                0.0034400,-0.0041300,0.0013200,-0.0003600,-0.0015900,-0.0026600,        &
-                -0.0047700,-0.0033400,-0.0041700,-0.0044800,-0.0051000,-0.0051000,      &
-                -0.0057000,-0.0055000,-0.0059000,-0.0056000,-0.0058000,-0.0057000,      &
-                -0.0056000,-0.0056000,-0.0056000,-0.0004400,0.0000000,0.0000000,        &
-                0.0000000,0.0000000,0.0000000,0.0000000/),                              & 
-         a6 = (/1.7000000,1.7000000,1.7000000,1.7000000,1.8000000,1.8000000,            &
-                1.8000000,1.9000000,1.8000000,2.0000000,1.9000000,2.1000000,2.1000000,  &
-                0.9000000,2.3000000,2.5000000,3.7000000,-3.1000000,0.8000000,0.1000000, &
-                0.5000000,0.7000000,-1.0000000,5.8000000,2.9000000,2.3000000,0.9000000, &
-                2.2000000,2.0000000,2.0000000,1.8000000,1.9000000,1.8000000,1.8000000,  &
-                1.7000000,1.8000000,1.7000000,1.7000000,1.7000000,1.7000000,1.7000000,  &
-                0.9000000,1.0000000,1.0000000,1.0000000,1.0000000,1.0000000,1.0000000/)
-    
-    ! Table2 parameters  v1, b1, b2, b3
-    real(wp),dimension(nbands_h2o),parameter ::                                          &
-         v1 = (/22.2350800,67.8139600,119.9959400,183.3101170,321.2256440,               &
-                325.1529190,336.1870000,380.1973720,390.1345080,437.3466670,439.1508120, &
-                443.0182950,448.0010750,470.8889740,474.6891270,488.4911330,503.5685320, &
-                504.4826920,556.9360020,620.7008070,658.0065000,752.0332270,841.0735950, &
-                859.8650000,899.4070000,902.5550000,906.2055240,916.1715820,970.3150220, &
-                987.9267640/),                                                           &
-         b1 = (/0.1090000,0.0011000,0.0007000,2.3000000,0.0464000,1.5400000,             &
-                0.0010000,11.9000000,0.0044000,0.0637000,0.9210000,0.1940000,10.6000000, &
-                0.3300000,1.2800000,0.2530000,0.0374000,0.0125000,510.0000000,5.0900000, &
-                0.2740000,250.0000000,0.0130000,0.1330000,0.0550000,0.0380000,0.1830000, &
-                8.5600000,9.1600000,138.0000000/),                                       &
-         b2 = (/2.1430000,8.7300000,8.3470000,0.6530000,6.1560000,1.5150000,             &
-                9.8020000,1.0180000,7.3180000,5.0150000,3.5610000,5.0150000,1.3700000,   &
-                3.5610000,2.3420000,2.8140000,6.6930000,6.6930000,0.1140000,2.1500000,   &
-                7.7670000,0.3360000,8.1130000,7.9890000,7.8450000,8.3600000,5.0390000,   &
-                1.3690000,1.8420000,0.1780000/),                                         &
-         b3 = (/0.0278400,0.0276000,0.0270000,0.0283500,0.0214000,0.0270000,             &
-                0.0265000,0.0276000,0.0190000,0.0137000,0.0164000,0.0144000,0.0238000,   &
-                0.0182000,0.0198000,0.0249000,0.0115000,0.0119000,0.0300000,0.0223000,   &
-                0.0300000,0.0286000,0.0141000,0.0286000,0.0286000,0.0264000,0.0234000,   &
-                0.0253000,0.0240000,0.0286000/)
-
-    ! Conversions
-    th     = 300._wp/T                                             ! unitless
-
-    ! DS2014 START: Using _wp for the exponential in the denominator results in slight errors
-    !               for dBze94. 0.01 % of values differ, relative range: 1.03e-05 to  1.78e-04
-    !e      = (RH*th*th*th*th*th)/(41.45_wp*10**(9.834_wp*th-10))   ! kPa
-    !e = (RH*th*th*th*th*th)/(41.45_wp*10**(9.834_wp*th-10))   ! kPa
-    e = SH*PRES_mb/(SH+0.622_wp)/1000._wp !kPa
-    ! DS2014 END
-
-    p      = PRES_mb/1000._wp-e                                      ! kPa
-    e_th   = e*th
-    one_th = 1 - th
-    pth3   = p*th*th*th
-    eth35  = e*th**(3.5)
-    
-    ! Term1
-    sumo = 0._wp
-    aux1 = 1.1_wp*e_th
-    do i=1,nbands_o2
-       aux2   = f/v0(i)
-       aux3   = v0(i)-f
-       aux4   = v0(i)+f
-       gm     = a3(i)*(p*th**(0.8_wp-a4(i))+aux1)
-       gm2    = gm*gm
-       delt   = a5(i)*p*th**a6(i)
-       x      = aux3*aux3+gm2
-       y      = aux4*aux4+gm2
-       fpp_o2 = (((1._wp/x)+(1._wp/y))*(gm*aux2) - (delt*aux2)*((aux3/(x))-(aux4/(x))))
-       s_o2   = a1(i)*pth3*exp(a2(i)*one_th)
-       sumo   = sumo + fpp_o2 * s_o2
-    enddo
-    term1 = sumo
-
-    ! Term2
-    gm0   = 5.6E-3_wp*(p+1.1_wp*e)*th**(0.8_wp)
-    a0    = 3.07E-4_wp
-    ap    = 1.4_wp*(1-1.2_wp*f**(1.5_wp)*1E-5)*1E-10
-    term2 = (2*a0*(gm0*(1+(f/gm0)*(f/gm0))*(1+(f/60._wp)**2))**(-1) + ap*p*th**(2.5_wp))*f*p*th*th
-
-    ! Term3
-    sumo = 0._wp
-    aux1 = 4.8_wp*e_th
-    do i=1,nbands_h2o
-       aux2    = f/v1(i)
-       aux3    = v1(i)-f
-       aux4    = v1(i)+f
-       gm      = b3(i)*(p*th**(0.8)+aux1)
-       gm2     = gm*gm
-       x       = aux3*aux3+gm2
-       y       = aux4*aux4+gm2
-       fpp_h2o = ((1._wp/x)+(1._wp/y))*(gm*aux2) ! - (delt*aux2)*((aux3/(x))-(aux4/(x)))
-       s_h2o   = b1(i)*eth35*exp(b2(i)*one_th)
-       sumo    = sumo + fpp_h2o * s_h2o
-    enddo
-    term3 = sumo
-
-    ! Term4
-    bf    = 1.4E-6_wp
-    be    = 5.41E-5_wp
-    term4 = (bf*p+be*e*th*th*th)*f*e*th**(2.5_wp)
-
-    ! Summation and result
-    npp   = term1 + term2 + term3 + term4
-    gases = 0.182_wp*f*npp
-    
-  end function gases
- subroutine hydro_class_init(lsingle,ldouble,sd)
-    ! ##############################################################################################
-    ! Purpose:
-    !
-    !   Initialize variables used by the radar simulator.
-    !   Part of QuickBeam v3.0 by John Haynes and Roj Marchand
-    !   
-    ! Inputs:  
-    !   NAME            SIZE        DESCRIPTION
-    !   [lsingle]       (1)         Logical flag to use single moment
-    !   [ldouble]       (1)         Logical flag to use two moment
-    ! Outputs:
-    !   [sd]                        Structure that define hydrometeor types
-    !
-    ! Local variables:
-    !   [n_hydro]       (1)         Number of hydrometeor types
-    !   [hclass_type]   (nhclass)   Type of distribution (see quickbeam documentation)
-    !   [hclass_phase]  (nhclass)   1==ice, 0=liquid
-    !   [hclass_dmin]   (nhclass)   Minimum diameter allowed is drop size distribution N(D<Dmin)=0
-    !   [hclass_dmax]   (nhclass)   Maximum diameter allowed is drop size distribution N(D>Dmax)=0
-    !   [hclass_apm]    (nhclass)   Density of partical apm*D^bpm or constant = rho
-    !   [hclass_bpm]    (nhclass)   Density of partical apm*D^bpm or constant = rho
-    !   [hclass_rho]    (nhclass)   Density of partical apm*D^bpm or constant = rho
-    !   [hclass_p1]     (nhclass)   Default values of DSD parameters (see quickbeam documentation)
-    !   [hclass_p2]     (nhclass)   Default values of DSD parameters (see quickbeam documentation)
-    !   [hclass_p3]     (nhclass)   Default values of DSD parameters (see quickbeam documentation)    
-    ! Modified:
-    !   08/23/2006  placed into subroutine form (Roger Marchand)
-    !   June 2010   New interface to support "radar_simulator_params" structure
-    !   12/22/2014  Moved radar simulator (CLOUDSAT) configuration initialization to cloudsat_init
-    ! ##############################################################################################
-
-    ! ####################################################################################
-    ! NOTES on HCLASS variables
-    !
-    ! TYPE - Set to
-    ! 1 for modified gamma distribution,
-    ! 2 for exponential distribution,
-    ! 3 for power law distribution,
-    ! 4 for monodisperse distribution,
-    ! 5 for lognormal distribution.
-	!
-    ! PHASE - Set to 0 for liquid, 1 for ice.
-    ! DMIN  - The minimum drop size for this class (micron), ignored for monodisperse.
-    ! DMAX  - The maximum drop size for this class (micron), ignored for monodisperse.
-    ! Important note: The settings for DMIN and DMAX are
-    ! ignored in the current version for all distributions except for power
-    ! law. Except when the power law distribution is used, particle size
-    ! is fixed to vary from zero to infinity, a restriction that is expected
-    ! to be lifted in future versions. A placeholder must still be specified
-    ! for each.
-    ! Density of particles is given by apm*D^bpm or a fixed value rho. ONLY specify ONE of these two!!
-    ! APM - The alpha_m coefficient in equation (1) (kg m**-beta_m )
-    ! BPM - The beta_m coefficient in equation (1), see section 4.1.
-    ! RHO - Hydrometeor density (kg m-3 ).
-    ! 
-    ! P1, P2, P3 - are default distribution parameters that depend on the type
-    ! of distribution (see quickmbeam documentation for more information)
-    !
-    ! Modified Gamma (must set P3 and one of P1 or P2)
-    ! P1 - Set to the total particle number concentration Nt /rho_a (kg-1 ), where
-    ! rho_a is the density of air in the radar volume.
-    ! P2 - Set to the particle mean diameter D (micron).
-    ! P3 - Set to the distribution width nu.
-    !
-    ! Exponetial (set one of)
-    ! P1 - Set to a constant intercept parameter N0 (m-4).
-    ! P2 - Set to a constant lambda (micron-1).
-    !
-    ! Power Law
-    ! P1 - Set this to the value of a constant power law parameter br
-    !
-    ! Monodisperse
-    ! P1 - Set to a constant diameter D0 (micron) = Re.
-    !
-    ! Log-normal (must set P3 and one of P1 or P2)
-    ! P1 - Set to the total particle number concentration Nt /rho_a (kg-1 )
-    ! P2 - Set to the geometric mean particle radius rg (micron).
-    ! P3 - Set to the natural logarithm of the geometric standard deviation.
-    ! ####################################################################################
-    ! INPUTS
-    logical,intent(in) :: &
-       lsingle, & ! True -> use single moment
-       ldouble    ! True -> use two moment 
-                     
-    ! OUTPUTS
-    type(size_distribution),intent(out) ::&
-         sd              !
-
-   ! SINGLE MOMENT PARAMETERS
-   integer,parameter,dimension(N_HYDRO) :: &
-                    ! LSL  LSI  LSR  LSS  CVL  CVI  CVR  CVS  LSG    
-       HCLASS1_TYPE  = (/5,   1,   2,   2,   5,   1,   2,   2,   2/), & ! 
-       HCLASS1_PHASE = (/0,   1,   0,   1,   0,   1,   0,   1,   1/)    ! 
-   real(wp),parameter,dimension(N_HYDRO) ::&
-                      ! LSL   LSI    LSR    LSS    CVL   CVI    CVR    CVS    LSG    
-       HCLASS1_DMIN = (/ -1.,  -1.,   -1.,   -1.,   -1.,  -1.,   -1.,   -1.,   -1.  /),  &
-       HCLASS1_DMAX = (/ -1.,  -1.,   -1.,   -1.,   -1.,  -1.,   -1.,   -1.,   -1.  /),  &
-       HCLASS1_APM  = (/524., 110.8, 524.,   -1.,  524., 110.8, 524.,   -1.,   -1.  /),  &
-       HCLASS1_BPM  = (/  3.,   2.91,  3.,   -1.,    3.,   2.91,  3.,   -1.,   -1.  /),  &
-       HCLASS1_RHO  = (/ -1.,  -1.,   -1.,  100.,   -1.,  -1.,   -1.,  100.,  400.  /),  &
-       HCLASS1_P1   = (/ -1.,  -1.,    8.e6,  3.e6, -1.,  -1.,    8.e6,  3.e6,  4.e6/),  & 
-       HCLASS1_P2   = (/  6.,  40.,   -1.,   -1.,    6.,  40.,   -1.,   -1.,   -1.   /), & 
-       HCLASS1_P3   = (/  0.3,  2.,   -1.,   -1.,    0.3,  2.,   -1.,   -1.,   -1.   /)
-
-    ! TWO MOMENT PARAMETERS
-    integer,parameter,dimension(N_HYDRO) :: &
-                      ! LSL  LSI  LSR  LSS  CVL  CVI  CVR  CVS  LSG
-       HCLASS2_TYPE  = (/ 1,   1,   1,   1,   1,   1,   1,   1,   1/), &
-       HCLASS2_PHASE = (/ 0,   1,   0,   1,   0,   1,   0,   1,   1/)
-
-    real(wp),parameter,dimension(N_HYDRO) :: &
-                      ! LSL    LSI      LSR     LSS   CVL    CVI   CVR     CVS    LSG
-       HCLASS2_DMIN = (/ -1,     -1,     -1,     -1,    -1,    -1,   -1,     -1,   -1/), &
-       HCLASS2_DMAX = (/ -1,     -1,     -1,     -1,    -1,    -1,   -1,     -1,   -1/), &        
-       HCLASS2_APM  = (/524,     -1,    524,     -1,   524,    -1,  524,     -1,   -1/), &
-       HCLASS2_BPM  = (/  3,     -1,      3,     -1,     3,    -1,    3,     -1,   -1/), &
-       HCLASS2_RHO  = (/ -1,    500,     -1,    100,    -1,   500,   -1,    100,  900/), &
-       HCLASS2_P1   = (/ -1,     -1,     -1,     -1,    -1,    -1,   -1,     -1,   -1/), &
-       HCLASS2_P2   = (/ -1,     -1,     -1,     -1,    -1,    -1,   -1,     -1,   -1/), &
-       HCLASS2_P3   = (/ -2,      1,      1,      1,    -2,     1,    1,      1,    1/) 
-    
-    if (lsingle) then    
-       sd%dtype(1:N_HYDRO) = HCLASS1_TYPE(1:N_HYDRO)
-       sd%phase(1:N_HYDRO) = HCLASS1_PHASE(1:N_HYDRO)
-       sd%dmin(1:N_HYDRO)  = HCLASS1_DMIN(1:N_HYDRO)
-       sd%dmax(1:N_HYDRO)  = HCLASS1_DMAX(1:N_HYDRO)
-       sd%apm(1:N_HYDRO)   = HCLASS1_APM(1:N_HYDRO)
-       sd%bpm(1:N_HYDRO)   = HCLASS1_BPM(1:N_HYDRO)
-       sd%rho(1:N_HYDRO)   = HCLASS1_RHO(1:N_HYDRO)
-       sd%p1(1:N_HYDRO)    = HCLASS1_P1(1:N_HYDRO)
-       sd%p2(1:N_HYDRO)    = HCLASS1_P2(1:N_HYDRO)
-       sd%p3(1:N_HYDRO)    = HCLASS1_P3(1:N_HYDRO)
-    endif
-    if (ldouble) then    
-       sd%dtype(1:N_HYDRO) = HCLASS2_TYPE(1:N_HYDRO)
-       sd%phase(1:N_HYDRO) = HCLASS2_PHASE(1:N_HYDRO)
-       sd%dmin(1:N_HYDRO)  = HCLASS2_DMIN(1:N_HYDRO)
-       sd%dmax(1:N_HYDRO)  = HCLASS2_DMAX(1:N_HYDRO)
-       sd%apm(1:N_HYDRO)   = HCLASS2_APM(1:N_HYDRO)
-       sd%bpm(1:N_HYDRO)   = HCLASS2_BPM(1:N_HYDRO)
-       sd%rho(1:N_HYDRO)   = HCLASS2_RHO(1:N_HYDRO)
-       sd%p1(1:N_HYDRO)    = HCLASS2_P1(1:N_HYDRO)
-       sd%p2(1:N_HYDRO)    = HCLASS2_P2(1:N_HYDRO)
-       sd%p3(1:N_HYDRO)    = HCLASS2_P3(1:N_HYDRO)
-    endif    
-  end subroutine hydro_class_init    
-end module mod_quickbeam_optics
Index: /LMDZ6/trunk/libf/phylmd/cospv2/quickbeam_optics.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cospv2/quickbeam_optics.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/cospv2/quickbeam_optics.f90	(revision 5268)
@@ -0,0 +1,1380 @@
+! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+! Copyright (c) 2015, Regents of the University of Colorado
+! All rights reserved.
+!
+! Redistribution and use in source and binary forms, with or without modification, are 
+! permitted provided that the following conditions are met:
+!
+! 1. Redistributions of source code must retain the above copyright notice, this list of 
+!    conditions and the following disclaimer.
+!
+! 2. Redistributions in binary form must reproduce the above copyright notice, this list
+!    of conditions and the following disclaimer in the documentation and/or other 
+!    materials provided with the distribution.
+!
+! 3. Neither the name of the copyright holder nor the names of its contributors may be 
+!    used to endorse or promote products derived from this software without specific prior
+!    written permission.
+!
+! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY 
+! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 
+! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL 
+! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 
+! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT 
+! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 
+! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+!
+! History:
+! May 2015:  Dustin Swales - Initial version
+! 
+! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 
+module mod_quickbeam_optics
+  USE COSP_KINDS,          ONLY: wp,dp
+  USE array_lib,           ONLY: infind
+  USE math_lib,            ONLY: path_integral,avint,gamma
+  USE optics_lib,          ONLY: m_wat,m_ice,MieInt
+  USE cosp_math_constants, ONLY: pi
+  USE cosp_phys_constants, ONLY: rhoice  
+  use quickbeam,           ONLY: radar_cfg,dmin,dmax,Re_BIN_LENGTH,  &
+                                 Re_MAX_BIN,nRe_types,nd,maxhclass
+  use mod_cosp_config,     ONLY: N_HYDRO
+  use mod_cosp_error,      ONLY: errorMessage
+  implicit none
+
+  ! Derived type for particle size distribution
+  TYPE size_distribution
+     real(wp),dimension(maxhclass) :: p1,p2,p3,dmin,dmax,apm,bpm,rho
+     integer, dimension(maxhclass) :: dtype,phase
+  END TYPE size_distribution
+  
+  ! Parameters
+  integer,parameter ::   & !
+       cnt_liq       = 19, & ! Liquid temperature count
+       cnt_ice       = 20    ! Lce temperature count
+  
+  ! Initialization variables
+  real(wp),dimension(cnt_ice) :: mt_tti 
+  real(wp),dimension(cnt_liq) :: mt_ttl
+  real(wp),dimension(nd)      :: D
+  !logical :: lQuickbeamInit
+  
+contains
+  ! ######################################################################################
+  ! SUBROUTINE quickbeam_optics_init
+  ! ######################################################################################
+  subroutine quickbeam_optics_init()
+    integer :: j
+    
+    mt_tti = (/ ((j-1)*5-90 + 273.15, j = 1, cnt_ice) /) 
+    mt_ttl = (/ ((j-1)*5-60 + 273.15, j = 1, cnt_liq) /)
+    D(1) = dmin
+    do j=2,nd
+       D(j) = D(j-1)*exp((log(dmax)-log(dmin))/(nd-1))
+    enddo
+    !lQuickbeamInit = .true.
+  end subroutine quickbeam_optics_init
+  
+  ! ######################################################################################
+  ! SUBROUTINE QUICKBEAM_OPTICS
+  ! ######################################################################################
+  subroutine quickbeam_optics(sd, rcfg, nprof, ngate, undef, hm_matrix, re_matrix,       &
+       Np_matrix, p_matrix, t_matrix, sh_matrix,z_vol,kr_vol)
+    
+    ! INPUTS
+    type(size_distribution),intent(inout) :: &
+         sd               !
+    type(radar_cfg),intent(inout) :: &
+         rcfg             !
+    integer,intent(in) :: &
+         nprof,         & ! Number of hydrometeor profiles
+         ngate            ! Number of vertical layers
+    real(wp),intent(in) :: &
+         undef            ! Missing data value
+    real(wp),intent(in),dimension(nprof,ngate) :: &
+         p_matrix,      & ! Pressure profile (hPa)
+         t_matrix,      & ! Temperature profile (K)
+         sh_matrix        ! Specific humidity profile (%) -- only needed if gaseous aborption calculated.
+    real(wp),intent(in),dimension(nprof,ngate,rcfg%nhclass) :: &
+         re_matrix,     & ! Table of hydrometeor effective radii.       0 ==> use defaults. (units=microns)
+         hm_matrix        ! Table of hydrometeor mixing ratios (g/kg)
+    real(wp),intent(inout),dimension(nprof,ngate,rcfg%nhclass) :: &
+         Np_matrix        ! Table of hydrometeor number concentration.  0 ==> use defaults. (units = 1/kg)
+
+    ! OUTPUTS
+    real(wp),intent(out), dimension(nprof, ngate) :: &
+         z_vol,         & ! Effective reflectivity factor (mm^6/m^3)
+         kr_vol           ! Attenuation coefficient hydro (dB/km)
+
+    ! INTERNAL VARIABLES   
+    integer :: &
+         phase, ns,tp,j,k,pr,itt,iRe_type,n 
+    logical :: &
+         hydro
+    real(wp) :: &
+         t_kelvin,Re_internal
+    real(wp) :: &
+         rho_a,kr,ze,zr,scale_factor,Re,Np,base,step 
+
+    real(wp),dimension(:),allocatable :: &
+         Deq,     & ! Discrete drop sizes (um)
+         Ni,      & ! Discrete concentrations (cm^-3 um^-1)
+         rhoi,    & ! Discrete densities (kg m^-3)
+         xxa,     & !
+         Di         ! Discrete drop sizes (um)
+    
+    real(wp), dimension(nprof, ngate) :: &
+         z_ray      ! Reflectivity factor, Rayleigh only (mm^6/m^3)
+    
+    ! PARAMETERS    
+    logical, parameter ::       & !
+         DO_LUT_TEST = .false., & !
+         DO_NP_TEST  = .false.    !
+    real(wp), parameter :: &
+         one_third   = 1._wp/3._wp    !
+
+    ! Initialization
+    z_vol    = 0._wp
+    z_ray    = 0._wp
+    kr_vol   = 0._wp
+
+    do k=1,ngate       ! Loop over each profile (nprof)
+       do pr=1,nprof
+          ! Determine if hydrometeor(s) present in volume
+          hydro = .false.
+          do j=1,rcfg%nhclass
+             if ((hm_matrix(pr,k,j) > 1E-12) .and. (sd%dtype(j) > 0)) then
+                hydro = .true.
+                exit
+             endif
+          enddo
+
+          t_kelvin = t_matrix(pr,k)
+          ! If there is hydrometeor in the volume
+          if (hydro) then
+             rho_a = (p_matrix(pr,k))/(287._wp*(t_kelvin))
+             
+             ! Loop over hydrometeor type
+             do tp=1,rcfg%nhclass
+                Re_internal = re_matrix(pr,k,tp)
+
+                if (hm_matrix(pr,k,tp) <= 1E-12) cycle
+                
+                ! Index into temperature dimension of scaling tables
+                !   These tables have regular steps -- exploit this and abandon infind
+                phase = sd%phase(tp)
+                if (phase==0) then
+                   itt = infind(mt_ttl,t_kelvin)
+                else
+                   itt = infind(mt_tti,t_kelvin) 
+                endif
+                
+                ! Compute effective radius from number concentration and distribution parameters
+                if (Re_internal .eq. 0) then
+                   call calc_Re(hm_matrix(pr,k,tp),Np_matrix(pr,k,tp),rho_a, &
+                        sd%dtype(tp),sd%apm(tp),sd%bpm(tp),sd%rho(tp),sd%p1(tp),sd%p2(tp),sd%p3(tp),Re)
+                   Re_internal=Re
+                   !re_matrix(pr,k,tp)=Re
+                else
+                   if (Np_matrix(pr,k,tp) > 0) then
+                      call errorMessage('WARNING(optics/quickbeam_optics.f90): Re and Np set for the same volume & hydrometeor type.  Np is being ignored.')
+                   endif
+                   Re = Re_internal
+                   !Re = re_matrix(pr,k,tp)
+                endif
+                
+                ! Index into particle size dimension of scaling tables 
+                iRe_type=1
+                if(Re.gt.0) then
+                   ! Determine index in to scale LUT
+                   ! Distance between Re points (defined by "base" and "step") for
+                   ! each interval of size Re_BIN_LENGTH
+                   ! Integer asignment, avoids calling floor intrinsic
+                   n=Re/Re_BIN_LENGTH
+                   if (n>=Re_MAX_BIN) n=Re_MAX_BIN-1
+                   step = rcfg%step_list(n+1)
+                   base = rcfg%base_list(n+1)
+                   iRe_type=Re/step
+                   if (iRe_type.lt.1) iRe_type=1
+                   Re=step*(iRe_type+0.5_wp)    ! set value of Re to closest value allowed in LUT.
+                   iRe_type=iRe_type+base-int(n*Re_BIN_LENGTH/step)
+                   
+                   ! Make sure iRe_type is within bounds
+                   if (iRe_type.ge.nRe_types) then
+                      !write(*,*) 'Warning: size of Re exceed value permitted ', &
+                      !            'in Look-Up Table (LUT).  Will calculate. '
+                      ! No scaling allowed
+                      iRe_type=nRe_types
+                      rcfg%Z_scale_flag(tp,itt,iRe_type)=.false.
+                   else
+                      ! Set value in re_matrix to closest values in LUT
+                      if (.not. DO_LUT_TEST) re_internal=Re
+                      !if (.not. DO_LUT_TEST) re_matrix(pr,k,tp)=Re
+                   endif
+                endif
+                
+                ! Use Ze_scaled, Zr_scaled, and kr_scaled ... if know them
+                ! if not we will calculate Ze, Zr, and Kr from the distribution parameters
+!                if( rcfg%Z_scale_flag(tp,itt,iRe_type) .and. .not. DO_LUT_TEST)  then
+!                   ! can use z scaling
+!                   scale_factor=rho_a*hm_matrix(pr,k,tp)
+!                   zr = rcfg%Zr_scaled(tp,itt,iRe_type) * scale_factor
+!                   ze = rcfg%Ze_scaled(tp,itt,iRe_type) * scale_factor
+!                   kr = rcfg%kr_scaled(tp,itt,iRe_type) * scale_factor
+!                else
+                if( (.not. rcfg%Z_scale_flag(tp,itt,iRe_type)) .or. DO_LUT_TEST)  then
+                   ! Create a discrete distribution of hydrometeors within volume
+                   select case(sd%dtype(tp))
+                   case(4)
+                      ns = 1
+                      allocate(Di(ns),Ni(ns),rhoi(ns),xxa(ns),Deq(ns))
+                      Di = sd%p1(tp)
+                      Ni = 0._wp
+                   case default
+                      ns = nd   ! constant defined in simulator/quickbeam.f90
+                      allocate(Di(ns),Ni(ns),rhoi(ns),xxa(ns),Deq(ns))
+                      Di = D
+                      Ni = 0._wp
+                   end select
+                   call dsd(hm_matrix(pr,k,tp),re_internal,Np_matrix(pr,k,tp), &
+                        Di,Ni,ns,sd%dtype(tp),rho_a,t_kelvin, &
+                        sd%dmin(tp),sd%dmax(tp),sd%apm(tp),sd%bpm(tp), &
+                        sd%rho(tp),sd%p1(tp),sd%p2(tp),sd%p3(tp))
+                   
+                   ! Calculate particle density
+                   if (phase == 1) then
+                      if (sd%rho(tp) < 0) then
+                         ! Use equivalent volume spheres.
+                         rcfg%rho_eff(tp,1:ns,iRe_type) = rhoice ! solid ice == equivalent volume approach
+                         Deq = ( ( 6/pi*sd%apm(tp)/rhoice) ** one_third ) * ( (Di*1E-6) ** (sd%bpm(tp)/3._wp) )  * 1E6
+                         ! alternative is to comment out above two lines and use the following block
+                         ! MG Mie approach - adjust density of sphere with D = D_characteristic to match particle density
+                         !
+                         ! rcfg%rho_eff(tp,1:ns,iRe_type) = (6/pi)*sd%apm(tp)*(Di*1E-6)**(sd%bpm(tp)-3)   !MG Mie approach
+                         
+                         ! as the particle size gets small it is possible that the mass to size relationship of 
+                         ! (given by power law in hclass.data) can produce impossible results 
+                         ! where the mass is larger than a solid sphere of ice.  
+                         ! This loop ensures that no ice particle can have more mass/density larger than an ice sphere.
+                         ! do i=1,ns
+                         ! if(rcfg%rho_eff(tp,i,iRe_type) > 917 ) then
+                         ! rcfg%rho_eff(tp,i,iRe_type) = 917
+                         ! endif
+                         ! enddo
+                      else
+                         ! Equivalent volume sphere (solid ice rhoice=917 kg/m^3).
+                         rcfg%rho_eff(tp,1:ns,iRe_type) = rhoice
+                         Deq=Di * ((sd%rho(tp)/rhoice)**one_third)
+                         ! alternative ... coment out above two lines and use the following for MG-Mie
+                         ! rcfg%rho_eff(tp,1:ns,iRe_type) = sd%rho(tp)   !MG Mie approach
+                      endif
+                   else
+                      ! I assume here that water phase droplets are spheres.
+                      ! sd%rho should be ~ 1000  or sd%apm=524 .and. sd%bpm=3
+                      Deq = Di
+                   endif
+
+                   ! Calculate effective reflectivity factor of volume
+                   ! xxa are unused (Mie scattering and extinction efficiencies)
+                   xxa(1:ns) = -9.9_wp
+                   rhoi = rcfg%rho_eff(tp,1:ns,iRe_type)
+                   call zeff(rcfg%freq,Deq,Ni,ns,rcfg%k2,t_kelvin,phase,rcfg%do_ray, &
+                        ze,zr,kr,xxa,xxa,rhoi)
+
+                   ! Test compares total number concentration with sum of discrete samples 
+                   ! The second test, below, compares ab initio and "scaled" computations 
+                   !    of reflectivity
+                   !  These should get broken out as a unit test that gets called on 
+                   !    data. That routine could write to std out. 
+                   
+                   ! Test code ... compare Np value input to routine with sum of DSD
+                   ! NOTE: if .not. DO_LUT_TEST, then you are checking the LUT approximation 
+                   ! not just the DSD representation given by Ni
+                   if(Np_matrix(pr,k,tp)>0 .and. DO_NP_TEST ) then
+                      Np = path_integral(Ni,Di,1,ns-1)/rho_a*1.E6_wp
+                      ! Note: Representation is not great or small Re < 2 
+                      if( (Np_matrix(pr,k,tp)-Np)/Np_matrix(pr,k,tp)>0.1 ) then
+                         call errorMessage('ERROR(optics/quickbeam_optics.f90): Error: Np input does not match sum(N)')
+                      endif
+                   endif
+
+                   ! Clean up space
+                   deallocate(Di,Ni,rhoi,xxa,Deq)
+
+                   ! LUT test code
+                   ! This segment of code compares full calculation to scaling result
+                   if ( rcfg%Z_scale_flag(tp,itt,iRe_type) .and. DO_LUT_TEST )  then
+                      scale_factor=rho_a*hm_matrix(pr,k,tp)
+                      ! if more than 2 dBZe difference print error message/parameters.
+                      if ( abs(10*log10(ze) - 10*log10(rcfg%Ze_scaled(tp,itt,iRe_type) * &
+                           scale_factor)) > 2 ) then
+                         call errorMessage('ERROR(optics/quickbeam_optics.f90): ERROR: Roj Error?')
+                      endif
+                   endif
+                else
+                   ! Use z scaling
+                   scale_factor=rho_a*hm_matrix(pr,k,tp)
+                   zr = rcfg%Zr_scaled(tp,itt,iRe_type) * scale_factor
+                   ze = rcfg%Ze_scaled(tp,itt,iRe_type) * scale_factor
+                   kr = rcfg%kr_scaled(tp,itt,iRe_type) * scale_factor
+                endif  ! end z_scaling
+                
+                kr_vol(pr,k) = kr_vol(pr,k) + kr
+                z_vol(pr,k)  = z_vol(pr,k)  + ze
+                z_ray(pr,k)  = z_ray(pr,k)  + zr
+                
+                ! Construct Ze_scaled, Zr_scaled, and kr_scaled ... if we can
+                if ( .not. rcfg%Z_scale_flag(tp,itt,iRe_type) ) then
+                   if (iRe_type>1) then
+                      scale_factor=rho_a*hm_matrix(pr,k,tp)
+                      rcfg%Ze_scaled(tp,itt,iRe_type) = ze/ scale_factor
+                      rcfg%Zr_scaled(tp,itt,iRe_type) = zr/ scale_factor
+                      rcfg%kr_scaled(tp,itt,iRe_type) = kr/ scale_factor
+                      rcfg%Z_scale_flag(tp,itt,iRe_type) = .true.
+                      rcfg%Z_scale_added_flag(tp,itt,iRe_type)=.true.
+                   endif
+                endif
+             enddo   ! end loop of tp (hydrometeor type)
+          endif
+       enddo
+    enddo
+    
+    where(kr_vol(:,:) <= EPSILON(kr_vol)) 
+       ! Volume is hydrometeor-free	
+       !z_vol(:,:)  = undef
+       z_ray(:,:)  = undef
+    end where
+
+  end subroutine quickbeam_optics
+  ! ##############################################################################################
+  ! ##############################################################################################
+  subroutine calc_Re(Q,Np,rho_a,dtype,apm,bpm,rho_c,p1,p2,p3,Re)  
+    ! ##############################################################################################
+    ! Purpose:
+    !   Calculates Effective Radius (1/2 distribution 3rd moment / 2nd moment). 
+    !
+    !   For some distribution types, the total number concentration (per kg), Np
+    !   may be optionally specified.   Should be set to zero, otherwise.
+    !
+    !   Roj Marchand July 2010
+    !
+    ! Inputs:
+    !
+    !   [Q]        hydrometeor mixing ratio (g/kg)  ! not needed for some distribution types
+    !   [Np]       Optional Total number concentration (per kg).  0 = use defaults (p1, p2, p3)
+    !   [rho_a]    ambient air density (kg m^-3)   
+    !
+    !   Distribution parameters as per quickbeam documentation.
+    !   [dtype]    distribution type
+    !   [apm]      a parameter for mass (kg m^[-bpm])
+    !   [bmp]      b params for mass 
+    !   [p1],[p2],[p3]  distribution parameters
+    !
+    ! Outputs:
+    !   [Re]       Effective radius, 1/2 the 3rd moment/2nd moment (um)
+    !
+    ! Created:
+    !   July 2010  Roj Marchand
+    ! Modified:
+    !   12/18/14  Dustin Swales: Define type REALs as double precision (dustin.swales@noaa.gov)
+    !
+    ! ##############################################################################################
+    ! ##############################################################################################
+    
+    ! Inputs
+    real(wp), intent(in)    :: Q,Np,rho_a,rho_c,p1,p2,p3
+    integer,  intent(in)    :: dtype
+    real(wp), intent(inout) :: apm,bpm  
+    
+    ! Outputs
+    real(wp), intent(out) :: Re
+    
+    ! Internal
+    integer  :: local_dtype
+    real(wp) :: local_p3,local_Np,tmp1,tmp2
+    real(wp) :: N0,D0,vu,dm,ld,rg,log_sigma_g        ! gamma, exponential variables
+    
+    
+    ! If density is constant, set equivalent values for apm and bpm
+    if ((rho_c > 0) .and. (apm < 0)) then
+       apm = (pi/6)*rho_c
+       bpm = 3._wp
+    endif
+    
+    ! Exponential is same as modified gamma with vu =1
+    ! if Np is specified then we will just treat as modified gamma
+    if(dtype .eq. 2 .and. Np .gt. 0) then
+       local_dtype = 1
+       local_p3    = 1
+    else
+       local_dtype = dtype
+       local_p3    = p3
+    endif
+    select case(local_dtype)
+       
+       ! ---------------------------------------------------------!
+       ! Modified gamma                                           !
+       ! Np = total number concentration (1/kg) = Nt / rho_a      !
+       ! D0 = characteristic diameter (um)                        !
+       ! dm = mean diameter (um) - first moment over zeroth moment!
+       ! vu = distribution width parameter                        !
+       ! ---------------------------------------------------------!
+    case(1)  
+       
+       if( abs(local_p3+2) < 1E-8) then
+          if(Np>1E-30) then
+             ! Morrison scheme with Martin 1994 shape parameter (NOTE: vu = pc +1)
+             ! fixed Roj. Dec. 2010 -- after comment by S. Mcfarlane
+             vu = (1/(0.2714_wp + 0.00057145_wp*Np*rho_a*1E-6))**2 ! units of Nt = Np*rhoa = #/cm^3
+          else
+             call errorMessage('FATAL ERROR(optics/quickbeam_optics.f90:Calc_Re): Must specify a value for Np in each volume with Morrison/Martin Scheme.')
+             return
+          endif
+       elseif (abs(local_p3+1) > 1E-8) then
+          ! vu is fixed in hp structure  
+          vu = local_p3 
+       else
+          ! vu isn't specified
+          call errorMessage('FATAL ERROR(optics/quickbeam_optics.f90:Calc_Re): Must specify a value for vu for Modified Gamma distribution')
+          return
+       endif
+       
+       if( Np.eq.0 .and. p2+1 > 1E-8) then     ! use default value for MEAN diameter as first default  
+          dm = p2             ! by definition, should have units of microns
+          D0 = gamma(vu)/gamma(vu+1)*dm
+       else   ! use value of Np
+          if(Np.eq.0) then
+             if( abs(p1+1) > 1E-8 ) then  !   use default number concentration   
+                local_Np = p1 ! total number concentration / pa --- units kg^-1
+             else
+                call errorMessage('FATAL ERROR(optics/quickbeam_optics.f90:Calc_Re): Must specify Np or default value (p1=Dm [um] or p2=Np [1/kg]) for Modified Gamma distribution')
+                return
+             endif
+          else
+             local_Np=Np;    
+          endif
+          D0 = 1E6 * ( Q*1E-3*gamma(vu)/(apm*local_Np*gamma(vu+bpm)) )**(1/bpm)  ! units = microns
+       endif
+       Re = 0.5_wp*D0*gamma(vu+3)/gamma(vu+2)
+       
+       ! ---------------------------------------------------------!
+       ! Exponential                                              !
+       ! N0 = intercept parameter (m^-4)                          !
+       ! ld = slope parameter (um)                                !
+       ! ---------------------------------------------------------!
+    case(2)
+       
+       ! Np not specified (see if statement above) 
+       if((abs(p1+1) > 1E-8) ) then   ! N0 has been specified, determine ld
+          N0   = p1
+          tmp1 = 1._wp/(1._wp+bpm)
+          ld   = ((apm*gamma(1.+bpm)*N0)/(rho_a*Q*1E-3))**tmp1
+          ld   = ld/1E6                     ! set units to microns^-1
+       elseif (abs(p2+1) > 1E-8) then  ! lambda=ld has been specified as default
+          ld = p2     ! should have units of microns^-1 
+       else
+          call errorMessage('FATAL ERROR(optics/quickbeam_optics.f90:Calc_Re): Must specify Np or default value (p1=No or p2=lambda) for Exponential distribution')
+          return
+       endif
+       Re = 1.5_wp/ld 
+       
+       ! ---------------------------------------------------------!
+       ! Power law                                                !
+       ! ahp = Ar parameter (m^-4 mm^-bhp)                        !
+       ! bhp = br parameter                                       !
+       ! dmin_mm = lower bound (mm)                               !
+       ! dmax_mm = upper bound (mm)                               !
+       ! ---------------------------------------------------------!
+    case(3)
+       
+       Re=0._wp  ! Not supporting LUT approach for power-law ...
+       if(Np>0) then
+          call errorMessage('FATAL ERROR(optics/quickbeam_optics.f90:Calc_Re): Variable Np not supported for Power Law distribution')
+          return
+       endif
+       
+       ! ---------------------------------------------------------!
+       ! Monodisperse                                             !
+       ! D0 = particle diameter (um) == Re                        !
+       ! ---------------------------------------------------------!
+    case(4)
+       
+       Re = p1
+       if(Np>0) then
+          call errorMessage('FATAL ERROR(optics/quickbeam_optics.f90:Calc_Re): Variable Np not supported for Monodispersed distribution')
+          return
+       endif
+       
+       ! ---------------------------------------------------------!
+       ! Lognormal                                                !
+       ! N0 = total number concentration (m^-3)                   !
+       ! np = fixed number concentration (kg^-1)                  !
+       ! rg = mean radius (um)                                    !
+       ! log_sigma_g = ln(geometric standard deviation)           !
+       ! ---------------------------------------------------------!
+    case(5)
+       
+       if( abs(local_p3+1) > 1E-8 ) then
+          !set natural log width
+          log_sigma_g = local_p3 
+       else
+          call errorMessage('FATAL ERROR(optics/quickbeam_optics.f90:Calc_Re): Must specify a value for sigma_g when using a Log-Normal distribution')
+          return
+       endif
+       
+       ! get rg ... 
+       if( Np.eq.0 .and. (abs(p2+1) > 1E-8) ) then ! use default value of rg
+          rg = p2     
+       else
+          if(Np>0) then
+             local_Np=Np;  
+          elseif(abs(p2+1) < 1E-8) then
+             local_Np=p1
+          else
+             call errorMessage('ERROR(optics/quickbeam_optics.f90:Calc_Re): Must specify Np or default value (p2=Rg or p1=Np) for Log-Normal distribution')
+          endif
+          log_sigma_g = p3
+          tmp1        = (Q*1E-3)/(2._wp**bpm*apm*local_Np)
+          tmp2        = exp(0.5_wp*bpm*bpm*(log_sigma_g))*exp(0.5_wp*bpm*bpm*(log_sigma_g))    
+          rg          = ((tmp1/tmp2)**(1._wp/bpm))*1E6
+       endif
+       Re = rg*exp(2.5_wp*(log_sigma_g*log_sigma_g))    
+    end select
+  end subroutine calc_Re
+  ! ##############################################################################################
+  ! ##############################################################################################
+  subroutine dsd(Q,Re,Np,D,N,nsizes,dtype,rho_a,tk,dmin,dmax,apm,bpm,rho_c,p1,p2,p3)
+    ! ##############################################################################################
+    ! Purpose:
+    !   Create a discrete drop size distribution
+    !
+    !   Starting with Quickbeam V3, this routine now allows input of 
+    !   both effective radius (Re) and total number concentration (Nt)
+    !   Roj Marchand July 2010
+    !
+    !   The version in Quickbeam v.104 was modified to allow Re but not Nt 
+    !   This is a significantly modified form for the version      
+    !
+    !   Originally Part of QuickBeam v1.03 by John Haynes
+    !   http://reef.atmos.colostate.edu/haynes/radarsim
+    !
+    ! Inputs:
+    !
+    !   [Q]        hydrometeor mixing ratio (g/kg)
+    !   [Re]       Optional Effective Radius (microns).  0 = use defaults (p1, p2, p3)
+    !
+    !   [D]        array of discrete drop sizes (um) where we desire to know the number concentraiton n(D).
+    !   [nsizes]   number of elements of [D]
+    !
+    !   [dtype]    distribution type
+    !   [rho_a]    ambient air density (kg m^-3)
+    !   [tk]       temperature (K)
+    !   [dmin]     minimum size cutoff (um)
+    !   [dmax]     maximum size cutoff (um)
+    !   [rho_c]    alternate constant density (kg m^-3)
+    !   [p1],[p2],[p3]  distribution parameters
+    !
+    ! Input/Output:
+    !   [apm]      a parameter for mass (kg m^[-bpm])
+    !   [bmp]      b params for mass
+    !
+    ! Outputs:
+    !   [N]        discrete concentrations (cm^-3 um^-1)
+    !              or, for monodisperse, a constant (1/cm^3)
+    !
+    ! Requires:
+    !   function infind
+    !
+    ! Created:
+    !   11/28/05  John Haynes (haynes@atmos.colostate.edu)
+    ! Modified:
+    !   01/31/06  Port from IDL to Fortran 90
+    !   07/07/06  Rewritten for variable DSD's
+    !   10/02/06  Rewritten using scaling factors (Roger Marchand and JMH), Re added V1.04
+    !   July 2020 "N Scale factors" (variable fc) removed (Roj Marchand).
+    !   12/18/14  Define type REALs as double precision (dustin.swales@noaa.gov)
+    ! ##############################################################################################
+    
+    ! Inputs
+    integer, intent(in)                   :: &
+         nsizes,& ! Number of elements of [D]
+         dtype    !  distribution type
+    real(wp),intent(in),dimension(nsizes) :: &
+         D        ! Array of discrete drop sizes (um) where we desire to know the number concentraiton n(D).
+    real(wp),intent(in) :: &
+         Q,     & ! Hydrometeor mixing ratio (g/kg)
+         Np,    & !
+         rho_a, & ! Ambient air density (kg m^-3)
+         tk,    & ! Temperature (K)
+         dmin,  & ! Minimum size cutoff (um)
+         dmax,  & ! Maximum size cutoff (um)
+         rho_c, & ! Alternate constant density (kg m^-3)
+         p1,    & ! Distribution parameter 1
+         p2,    & ! Distribution parameter 2
+         p3       ! Distribution parameter 3
+    real(wp),intent(inout) :: &
+         apm,   & ! a parameter for mass (kg m^[-bpm])
+         bpm,   & ! b params for mass
+         Re       ! Optional Effective Radius (microns)
+    
+    ! Outputs
+    real(wp),intent(out),dimension(nsizes) :: &
+         N        ! Discrete concentrations (cm^-3 um^-1)
+                  ! or, for monodisperse, a constant (1/cm^3)
+    
+    ! Internal Variables
+    real(wp),dimension(nsizes) :: &
+         fc
+    real(wp)                   :: &
+         N0,D0,vu,local_np,dm,ld, & ! gamma, exponential variables
+         dmin_mm,dmax_mm,ahp,bhp, & ! power law variables
+         rg,log_sigma_g,          & ! lognormal variables
+         rho_e,                   & ! particle density (kg m^-3)
+         tmp1,tmp2,tc
+    integer :: &
+         k,lidx,uidx
+    
+    ! Convert temperature from Kelvin to Celsius
+    tc = tk - 273.15_wp
+    
+    ! If density is constant, store equivalent values for apm and bpm
+    if ((rho_c > 0) .and. (apm < 0)) then
+       apm = (pi/6)*rho_c
+       bpm = 3._wp
+    endif
+    
+    ! Will preferentially use Re input over Np.
+    ! if only Np given then calculate Re
+    ! if neigher than use other defaults (p1,p2,p3) following quickbeam documentation
+    if(Re==0 .and. Np>0) then
+       call calc_Re(Q,Np,rho_a,dtype,apm,bpm,rho_c,p1,p2,p3,Re)
+    endif
+    select case(dtype)
+       
+       ! ---------------------------------------------------------!
+       ! Modified gamma                                           !
+       ! np = total number concentration                          !
+       ! D0 = characteristic diameter (um)                        !
+       ! dm = mean diameter (um) - first moment over zeroth moment!
+       ! vu = distribution width parameter                        !
+       ! ---------------------------------------------------------!
+    case(1)  
+       
+       if( abs(p3+2) < 1E-8) then
+          if( Np>1E-30) then
+             ! Morrison scheme with Martin 1994 shape parameter (NOTE: vu = pc +1)
+             ! fixed Roj. Dec. 2010 -- after comment by S. Mcfarlane
+             vu = (1/(0.2714_wp + 0.00057145_wp*Np*rho_a*1E-6))**2._wp ! units of Nt = Np*rhoa = #/cm^3
+          else
+             call errorMessage('FATAL ERROR(optics/quickbeam_optics.f90:dsd): Must specify a value for Np in each volume with Morrison/Martin Scheme.')
+             return
+          endif
+       elseif (abs(p3+1) > 1E-8) then
+          ! vu is fixed in hp structure  
+          vu = p3 
+       else
+          ! vu isn't specified
+          call errorMessage('FATAL ERROR(optics/quickbeam_optics.f90:dsd): Must specify a value for vu for Modified Gamma distribution')
+          return
+       endif
+       
+       if(Re>0) then
+          D0 = 2._wp*Re*gamma(vu+2)/gamma(vu+3)
+          fc = (((D*1E-6)**(vu-1)*exp(-1*D/D0)) / &
+               (apm*((D0*1E-6)**(vu+bpm))*gamma(vu+bpm))) * 1E-12
+          N  = fc*rho_a*(Q*1E-3)
+       elseif( p2+1 > 1E-8) then     ! use default value for MEAN diameter
+          dm = p2
+          D0 = gamma(vu)/gamma(vu+1)*dm
+          fc = (((D*1E-6)**(vu-1)*exp(-1*D/D0)) / &
+               (apm*((D0*1E-6)**(vu+bpm))*gamma(vu+bpm))) * 1E-12
+          N  = fc*rho_a*(Q*1E-3)
+       elseif(abs(p3+1) > 1E-8)  then! use default number concentration
+          local_np = p1 ! total number concentration / pa check
+          tmp1     = (Q*1E-3)**(1./bpm)
+          fc       = (D*1E-6 / (gamma(vu)/(apm*local_np*gamma(vu+bpm)))**(1._wp/bpm))**vu
+          N        = ((rho_a*local_np*fc*(D*1E-6)**(-1._wp))/(gamma(vu)*tmp1**vu) * &
+               exp(-1._wp*fc**(1._wp/vu)/tmp1)) * 1E-12
+       else
+          call errorMessage('FATAL ERROR(optics/quickbeam_optics.f90:dsd): No default value for Dm or Np provided!')
+          return
+       endif
+       
+       ! ---------------------------------------------------------!
+       ! Exponential                                              !
+       ! N0 = intercept parameter (m^-4)                          !
+       ! ld = slope parameter (um)                                !
+       ! ---------------------------------------------------------!
+    case(2)
+       
+       if(Re>0) then
+          ld = 1.5_wp/Re   ! units 1/um
+          fc = (ld*1E6)**(1.+bpm)/(apm*gamma(1+bpm))*exp(-1._wp*(ld*1E6)*(D*1E-6))*1E-12
+          N  = fc*rho_a*(Q*1E-3)
+       elseif (abs(p1+1) > 1E-8) then
+          ! Use N0 default value
+          N0   = p1
+          tmp1 = 1._wp/(1._wp+bpm)
+          fc   = ((apm*gamma(1.+bpm)*N0)**tmp1)*(D*1E-6)
+          N    = (N0*exp(-1._wp*fc*(1._wp/(rho_a*Q*1E-3))**tmp1)) * 1E-12
+       elseif (abs(p2+1) > 1E-8) then
+          ! Use default value for lambda 
+          ld = p2
+          fc = (ld*1E6)**(1._wp+bpm)/(apm*gamma(1+bpm))*exp(-1._wp*(ld*1E6)*(D*1E-6))*1E-12
+          N  = fc*rho_a*(Q*1E-3)
+       else
+          ! ld "parameterized" from temperature (carry over from original Quickbeam).
+          ld = 1220._wp*10._wp**(-0.0245_wp*tc)*1E-6
+          N0 = ((ld*1E6)**(1._wp+bpm)*Q*1E-3*rho_a)/(apm*gamma(1+bpm))
+          N  = (N0*exp(-ld*D)) * 1E-12
+       endif
+       
+       ! ---------------------------------------------------------!
+       ! Power law                                                !
+       ! ahp = Ar parameter (m^-4 mm^-bhp)                        !
+       ! bhp = br parameter                                       !
+       ! dmin_mm = lower bound (mm)                               !
+       ! dmax_mm = upper bound (mm)                               !
+       ! ---------------------------------------------------------!
+    case(3)
+       
+       if(Re>0) then
+          call errorMessage('FATAL ERROR(optics/quickbeam_optics.f90:dsd): Variable Re not supported for Power-Law distribution')
+          return
+       elseif(Np>0) then
+          call errorMessage('FATAL ERROR(optics/quickbeam_optics.f90:dsd): Variable Np not supported for Power-Law distribution')
+          return
+       endif
+       
+       ! br parameter
+       if (abs(p1+2) < 1E-8) then
+          ! if p1=-2, bhp is parameterized according to Ryan (2000),
+          ! applicatable to cirrus clouds
+          if (tc < -30) then
+             bhp = -1.75_wp+0.09_wp*((tc+273._wp)-243.16_wp)
+          elseif ((tc >= -30) .and. (tc < -9)) then
+             bhp = -3.25_wp-0.06_wp*((tc+273._wp)-265.66_wp)
+          else
+             bhp = -2.15_wp
+          endif
+       elseif (abs(p1+3) < 1E-8) then      
+          ! if p1=-3, bhp is parameterized according to Ryan (2000),
+          ! applicable to frontal clouds
+          if (tc < -35) then
+             bhp = -1.75_wp+0.09_wp*((tc+273._wp)-243.16_wp)
+          elseif ((tc >= -35) .and. (tc < -17.5)) then
+             bhp = -2.65_wp+0.09_wp*((tc+273._wp)-255.66_wp)
+          elseif ((tc >= -17.5) .and. (tc < -9)) then
+             bhp = -3.25_wp-0.06_wp*((tc+273._wp)-265.66_wp)
+          else
+             bhp = -2.15_wp
+          endif
+       else
+          ! Otherwise the specified value is used
+          bhp = p1
+       endif
+       
+       ! Ar parameter
+       dmin_mm = dmin*1E-3
+       dmax_mm = dmax*1E-3
+       
+       ! Commented lines are original method with constant density
+       ! rc = 500.       ! (kg/m^3)
+       ! tmp1 = 6*rho_a*(bhp+4)
+       ! tmp2 = pi*rc*(dmax_mm**(bhp+4))*(1-(dmin_mm/dmax_mm)**(bhp+4))
+       ! ahp = (Q*1E-3)*1E12*tmp1/tmp2
+       
+       ! New method is more consistent with the rest of the distributions
+       ! and allows density to vary with particle size
+       tmp1 = rho_a*(Q*1E-3)*(bhp+bpm+1)
+       tmp2 = apm*(dmax_mm**bhp*dmax**(bpm+1)-dmin_mm**bhp*dmin**(bpm+1))
+       ahp  = tmp1/tmp2 * 1E24
+       ! ahp = tmp1/tmp2 
+       lidx = infind(D,dmin)
+       uidx = infind(D,dmax)    
+       do k=lidx,uidx
+          N(k) = (ahp*(D(k)*1E-3)**bhp) * 1E-12    
+       enddo
+       
+       ! ---------------------------------------------------------!
+       ! Monodisperse                                             !
+       ! D0 = particle diameter (um)                              !
+       ! ---------------------------------------------------------!
+    case(4)
+       
+       if (Re>0) then
+          D0 = Re
+       else
+          D0 = p1
+       endif
+       
+       rho_e = (6._wp/pi)*apm*(D0*1E-6)**(bpm-3)
+       fc(1) = (6._wp/(pi*D0*D0*D0*rho_e))*1E12
+       N(1)  = fc(1)*rho_a*(Q*1E-3)
+       
+       ! ---------------------------------------------------------!
+       ! Lognormal                                                !
+       ! N0 = total number concentration (m^-3)                   !
+       ! np = fixed number concentration (kg^-1)                  !
+       ! rg = mean radius (um)                                    !
+       ! og_sigma_g = ln(geometric standard deviation)            !
+       ! ---------------------------------------------------------!
+    case(5)
+       if (abs(p1+1) < 1E-8 .or. Re>0 ) then
+          ! rg, log_sigma_g are given
+          log_sigma_g = p3
+          tmp2 = (bpm*log_sigma_g)*(bpm*log_sigma_g)
+          if(Re.le.0) then 
+             rg = p2
+          else
+             !rg = Re*exp(-2.5*(log_sigma_g*log_sigma_g))
+             rg =Re*exp(-2.5_wp*(log_sigma_g**2))
+             
+          endif
+          
+          fc = 0.5_wp*((1._wp/((2._wp*rg*1E-6)**(bpm)*apm*(2._wp*pi)**(0.5_wp) * &
+               log_sigma_g*D*0.5_wp*1E-6))*exp(-0.5_wp*((log(0.5_wp*D/rg)/log_sigma_g)**2._wp+tmp2)))*1E-12
+          N = fc*rho_a*(Q*1E-3)
+          
+       elseif (abs(p2+1) < 1E-8 .or. Np>0) then
+          ! Np, log_sigma_g are given    
+          if(Np>0) then
+             local_Np = Np
+          else
+             local_Np = p1
+          endif
+          
+          log_sigma_g = p3
+          N0   = local_np*rho_a
+          tmp1 = (rho_a*(Q*1E-3))/(2._wp**bpm*apm*N0)
+          tmp2 = exp(0.5_wp*bpm*bpm*(log_sigma_g))*exp(0.5_wp*bpm*bpm*(log_sigma_g))
+          rg   = ((tmp1/tmp2)**(1/bpm))*1E6
+          
+          N = 0.5_wp*(N0 / ((2._wp*pi)**(0.5_wp)*log_sigma_g*D*0.5_wp*1E-6) * &
+               exp((-0.5_wp*(log(0.5_wp*D/rg)/log_sigma_g)**2._wp)))*1E-12      
+       else
+          call errorMessage('FATAL ERROR(optics/quickbeam_optics.f90:dsd): Must specify a value for sigma_g')
+          return
+       endif
+    end select
+  end subroutine dsd
+  ! ##############################################################################################
+  ! ##############################################################################################
+  subroutine zeff(freq,D,N,nsizes,k2,tt,ice,xr,z_eff,z_ray,kr,qe,qs,rho_e)
+    ! ##############################################################################################
+    ! Purpose:
+    !   Simulates radar return of a volume given DSD of spheres
+    !   Part of QuickBeam v1.03 by John Haynes
+    !   http://reef.atmos.colostate.edu/haynes/radarsim
+    !
+    ! Inputs:
+    !   [freq]      radar frequency (GHz)
+    !   [D]         discrete drop sizes (um)
+    !   [N]         discrete concentrations (cm^-3 um^-1)
+    !   [nsizes]    number of discrete drop sizes
+    !   [k2]        |K|^2, -1=use frequency dependent default 
+    !   [tt]        hydrometeor temperature (K)
+    !   [ice]       indicates volume consists of ice
+    !   [xr]        perform Rayleigh calculations?
+    !   [qe]        if using a mie table, these contain ext/sca ...
+    !   [qs]        ... efficiencies; otherwise set to -1
+    !   [rho_e]     medium effective density (kg m^-3) (-1 = pure)
+    !
+    ! Outputs:
+    !   [z_eff]     unattenuated effective reflectivity factor (mm^6/m^3)
+    !   [z_ray]     reflectivity factor, Rayleigh only (mm^6/m^3)
+    !   [kr]        attenuation coefficient (db km^-1)
+    !
+    ! Created:
+    !   11/28/05  John Haynes (haynes@atmos.colostate.edu)
+    ! Modified:
+    !   12/18/14  Dustin Swales: Define type REALs as double precision (dustin.swales@noaa.gov)
+    ! ##############################################################################################
+    ! Inputs
+    integer,  intent(in) :: &
+         ice,        & ! Indicates volume consists of ice
+         xr,         & ! Perform Rayleigh calculations?
+         nsizes        ! Number of discrete drop sizes
+    real(wp), intent(in),dimension(nsizes) :: &
+         D,     & ! Discrete drop sizes (um)
+         N,     & ! Discrete concentrations (cm^-3 um^-1)
+         rho_e, & ! Medium effective density (kg m^-3) (-1 = pure)
+         qe,    & ! Extinction efficiency, when using Mie tables
+         qs       ! Scatering efficiency, when using Mie tables
+    real(wp),intent(in) :: &
+         freq,  & ! Radar frequency (GHz)
+         tt       ! Hydrometeor temperature (K)
+    real(wp), intent(inout) :: &
+         k2            ! |K|^2, -1=use frequency dependent default 
+    
+    ! Outputs
+    real(wp), intent(out) :: &
+         z_eff,      & ! Unattenuated effective reflectivity factor (mm^6/m^3)
+         z_ray,      & ! Reflectivity factor, Rayleigh only (mm^6/m^3)
+         kr            ! Attenuation coefficient (db km^-1)
+    
+    ! Internal Variables
+    integer                     :: correct_for_rho ! Correct for density flag
+    real(wp), dimension(nsizes) :: &
+         D0,        &    ! D in (m)
+         N0,        &    ! N in m^-3 m^-1
+         sizep,     &    ! Size parameter
+         qext,      &    ! Extinction efficiency
+         qbsca,     &    ! Backscatter efficiency
+         f,         &    ! Ice fraction
+         xtemp           !
+    real(wp) :: &
+         wl, cr,eta_sum,eta_mie,const,z0_eff,z0_ray,k_sum,n_r,n_i,dqv(1),dqsc,dg,dph(1)
+    complex(wp)         :: &
+         m,                  &    ! Complex index of refraction of bulk form
+         Xs1(1), Xs2(1)           !
+    integer          :: &
+         i, err                   !
+    integer, parameter :: &
+         one=1                    !
+    real(wp),parameter :: &
+         conv_d  = 1e-6,     &    ! Conversion factor for drop sizes (to m)
+         conv_n  = 1e12,     &    ! Conversion factor for drop concentrations (to m^-3)
+         conv_f  = 0.299792458    ! Conversion for radar frequency (to m)
+    complex(wp),dimension(nsizes) ::&
+         m0             ! Complex index of refraction
+    
+    ! Initialize
+    z0_ray = 0._wp
+    
+    ! Conversions
+    D0 = d*conv_d
+    N0 = n*conv_n
+    wl = conv_f/freq
+    
+    ! // dielectric constant |k^2| defaults
+    if (k2 < 0) then
+       k2 = 0.933_wp
+       if (abs(94.-freq) < 3.) k2=0.75_wp
+       if (abs(35.-freq) < 3.) k2=0.88_wp
+       if (abs(13.8-freq) < 3.) k2=0.925_wp
+    endif
+    
+    if (qe(1) < -9) then
+       
+       ! Get the refractive index of the bulk hydrometeors
+       if (ice == 0) then
+          call m_wat(freq,tt,n_r,n_i)
+       else
+          call m_ice(freq,tt,n_r,n_i)
+       endif
+       m = cmplx(n_r,-n_i)
+       m0(1:nsizes) = m
+       
+       correct_for_rho = 0
+       if ((ice == 1) .and. (minval(rho_e) >= 0)) correct_for_rho = 1
+       
+       ! Correct refractive index for ice density if needed
+       if (correct_for_rho == 1) then
+          f  = rho_e/rhoice
+          m0 = sqrt((2+(m0*m0)+2*f*((m0*m0)-1))/(2+(m0*m0)+f*(1-(m0*m0))))
+       endif
+       
+       ! Mie calculations
+       sizep = (pi*D0)/wl
+       dqv(1) = 0._wp
+       do i=1,nsizes
+          call mieint(sizep(i), m0(i), one, dqv, qext(i), dqsc, qbsca(i), &
+               dg, xs1, xs2, dph, err)
+       end do
+
+    else
+       ! Mie table used
+       qext  = qe
+       qbsca = qs
+    endif
+    
+    ! eta_mie = 0.25*sum[qbsca*pi*D^2*N(D)*deltaD]
+    ! <--------- eta_sum --------->
+    ! z0_eff = (wl^4/!pi^5)*(1./k2)*eta_mie
+    eta_sum = 0._wp
+    if (size(D0) == 1) then
+       eta_sum = qbsca(1)*(n(1)*1E6)*D0(1)*D0(1)
+    else
+       xtemp = qbsca*N0*D0*D0
+       call avint(xtemp,D0,nsizes,D0(1),D0(size(D0,1)),eta_sum)
+    endif
+    
+    eta_mie = eta_sum*0.25_wp*pi
+    const   = ((wl*wl*wl*wl)/(pi*pi*pi*pi*pi))*(1._wp/k2)
+    
+    z0_eff  = const*eta_mie
+    
+    ! kr = 0.25*cr*sum[qext*pi*D^2*N(D)*deltaD]
+    ! <---------- k_sum --------->  
+    k_sum = 0._wp
+    if (size(D0) == 1) then
+       k_sum = qext(1)*(n(1)*1E6)*D0(1)*D0(1)
+    else
+       xtemp = qext*N0*D0*D0
+       call avint(xtemp,D0,nsizes,D0(1),D0(size(D0,1)),k_sum)
+    endif
+    ! DS2014 START: Making this calculation in double precision results in a small 
+    !               amount of very small errors in the COSP output field,dBZE94,
+    !               so it will be left as is.
+    !cr = 10._wp/log(10._wp)
+    cr = 10./log(10.)
+    ! DS2014 STOP
+    kr = k_sum*0.25_wp*pi*(1000._wp*cr)
+    
+    ! z_ray = sum[D^6*N(D)*deltaD]
+    if (xr == 1) then
+       z0_ray = 0._wp
+       if (size(D0) == 1) then
+          z0_ray = (n(1)*1E6)*D0(1)*D0(1)*D0(1)*D0(1)*D0(1)*D0(1)
+       else
+          xtemp = N0*D0*D0*D0*D0*D0*D0
+          call avint(xtemp,D0,nsizes,D0(1),D0(size(D0)),z0_ray)
+       endif
+    endif
+    
+    ! Convert to mm^6/m^3
+    z_eff = z0_eff*1E18 !  10.*alog10(z0_eff*1E18)
+    z_ray = z0_ray*1E18 !  10.*alog10(z0_ray*1E18)
+    
+  end subroutine zeff
+  ! ##############################################################################################
+  ! ##############################################################################################
+  function gases(PRES_mb,T,SH,f)
+    ! ##############################################################################################
+    ! Purpose:
+    !   Compute 2-way gaseous attenuation through a volume in microwave
+    !
+    ! Inputs:
+    !   [PRES_mb]   pressure (mb) (hPa)
+    !   [T]         temperature (K)
+    !   [RH]        relative humidity (%)
+    !   [f]         frequency (GHz), < 300 GHz
+    !
+    ! Returns:
+    !   2-way gaseous attenuation (dB/km)
+    !
+    ! Reference:
+    !   Uses method of Liebe (1985)
+    !
+    ! Created:
+    !   12/09/05  John Haynes (haynes@atmos.colostate.edu)
+    ! Modified:
+    !   01/31/06  Port from IDL to Fortran 90
+    !   12/19/14  Dustin Swales: Define type REALs as double precision (dustin.swales@noaa.gov)
+    ! ##############################################################################################
+    
+    ! INPUTS
+    real(wp), intent(in) :: & !
+         PRES_mb,           & ! Pressure (mb) (hPa)
+         T,                 & ! Temperature (K)
+         SH,                & ! Specific humidity
+         f                    ! Frequency (GHz), < 300 GHz
+    
+    ! PARAMETERS
+    integer, parameter   :: & !
+         nbands_o2  = 48,   & ! Number of O2 bands
+         nbands_h2o = 30      ! Number of h2o bands
+    ! LOCAL VARIABLES
+    real(wp) :: &
+         gases, th, e, p, sumo, gm0, a0, ap, term1,    &
+         term2, term3, bf, be, term4, npp,e_th,one_th, &
+         pth3,eth35,aux1,aux2,aux3, aux4,gm,delt,x,y,  &
+         gm2,fpp_o2,fpp_h2o,s_o2,s_h2o
+    integer :: i
+
+    ! Table1 parameters  v0, a1, a2, a3, a4, a5, a6  
+    real(wp),dimension(nbands_o2),parameter ::                                          &
+         v0 = (/49.4523790,49.9622570,50.4742380,50.9877480,51.5033500,                 &
+                52.0214090,52.5423930,53.0669060,53.5957480,54.1299999,54.6711570,      &
+                55.2213650,55.7838000,56.2647770,56.3378700,56.9681000,57.6124810,      &
+                58.3238740,58.4465890,59.1642040,59.5909820,60.3060570,60.4347750,      &
+                61.1505580,61.8001520,62.4112120,62.4862530,62.9979740,63.5685150,      &
+                64.1277640,64.6789000,65.2240670,65.7647690,66.3020880,66.8368270,      &
+                67.3695950,67.9008620,68.4310010,68.9603060,69.4890210,70.0173420,      &
+                118.7503410,368.4983500,424.7631200,487.2493700,715.3931500,            &
+                773.8387300, 834.1453300/),                                             &
+         a1 = (/0.0000001,0.0000003,0.0000009,0.0000025,0.0000061,0.0000141,            &
+                0.0000310,0.0000641,0.0001247,0.0002280,0.0003918,0.0006316,0.0009535,  &
+                0.0005489,0.0013440,0.0017630,0.0000213,0.0000239,0.0000146,0.0000240,  &
+                0.0000211,0.0000212,0.0000246,0.0000250,0.0000230,0.0000193,0.0000152,  &
+                0.0000150,0.0000109,0.0007335,0.0004635,0.0002748,0.0001530,0.0000801,  &
+                0.0000395,0.0000183,0.0000080,0.0000033,0.0000013,0.0000005,0.0000002,  &
+                0.0000094,0.0000679,0.0006380,0.0002350,0.0000996,0.0006710,0.0001800/),&
+         a2 = (/11.8300000,10.7200000,9.6900000,8.8900000,7.7400000,6.8400000,          &
+                6.0000000,5.2200000,4.4800000,3.8100000,3.1900000,2.6200000,2.1150000,  &
+                0.0100000,1.6550000,1.2550000,0.9100000,0.6210000,0.0790000,0.3860000,  &
+                0.2070000,0.2070000,0.3860000,0.6210000,0.9100000,1.2550000,0.0780000,  &
+                1.6600000,2.1100000,2.6200000,3.1900000,3.8100000,4.4800000,5.2200000,  &
+                6.0000000,6.8400000,7.7400000,8.6900000,9.6900000,10.7200000,11.8300000,&
+                0.0000000,0.0200000,0.0110000,0.0110000,0.0890000,0.0790000,0.0790000/),&
+         a3 = (/0.0083000,0.0085000,0.0086000,0.0087000,0.0089000,0.0092000,            &
+                0.0094000,0.0097000,0.0100000,0.0102000,0.0105000,0.0107900,0.0111000,  &
+                0.0164600,0.0114400,0.0118100,0.0122100,0.0126600,0.0144900,0.0131900,  &
+                0.0136000,0.0138200,0.0129700,0.0124800,0.0120700,0.0117100,0.0146800,  &
+                0.0113900,0.0110800,0.0107800,0.0105000,0.0102000,0.0100000,0.0097000,  &
+                0.0094000,0.0092000,0.0089000,0.0087000,0.0086000,0.0085000,0.0084000,  &
+                0.0159200,0.0192000,0.0191600,0.0192000,0.0181000,0.0181000,0.0181000/),&
+         a4 = (/0.0000000,0.0000000,0.0000000,0.0000000,0.0000000,0.0000000,            &
+                0.0000000,0.0000000,0.0000000,0.0000000,0.0000000,0.0000000,0.0000000,  &
+                0.0000000,0.0000000,0.0000000,0.0000000,0.0000000,0.0000000,0.0000000,  &
+                0.0000000,0.0000000,0.0000000,0.0000000,0.0000000,0.0000000,0.0000000,  &
+                0.0000000,0.0000000,0.0000000,0.0000000,0.0000000,0.0000000,0.0000000,  &
+                0.0000000,0.0000000,0.0000000,0.0000000,0.0000000,0.0000000,0.0000000,  &
+                0.0000000,0.6000000,0.6000000,0.6000000,0.6000000,0.6000000,0.6000000/),&
+         a5 = (/0.0056000,0.0056000,0.0056000,0.0055000,0.0056000,0.0055000,            &
+                0.0057000,0.0053000,0.0054000,0.0048000,0.0048000,0.0041700,0.0037500,  &
+                0.0077400,0.0029700,0.0021200,0.0009400,-0.0005500,0.0059700,-0.0024400,&
+                0.0034400,-0.0041300,0.0013200,-0.0003600,-0.0015900,-0.0026600,        &
+                -0.0047700,-0.0033400,-0.0041700,-0.0044800,-0.0051000,-0.0051000,      &
+                -0.0057000,-0.0055000,-0.0059000,-0.0056000,-0.0058000,-0.0057000,      &
+                -0.0056000,-0.0056000,-0.0056000,-0.0004400,0.0000000,0.0000000,        &
+                0.0000000,0.0000000,0.0000000,0.0000000/),                              & 
+         a6 = (/1.7000000,1.7000000,1.7000000,1.7000000,1.8000000,1.8000000,            &
+                1.8000000,1.9000000,1.8000000,2.0000000,1.9000000,2.1000000,2.1000000,  &
+                0.9000000,2.3000000,2.5000000,3.7000000,-3.1000000,0.8000000,0.1000000, &
+                0.5000000,0.7000000,-1.0000000,5.8000000,2.9000000,2.3000000,0.9000000, &
+                2.2000000,2.0000000,2.0000000,1.8000000,1.9000000,1.8000000,1.8000000,  &
+                1.7000000,1.8000000,1.7000000,1.7000000,1.7000000,1.7000000,1.7000000,  &
+                0.9000000,1.0000000,1.0000000,1.0000000,1.0000000,1.0000000,1.0000000/)
+    
+    ! Table2 parameters  v1, b1, b2, b3
+    real(wp),dimension(nbands_h2o),parameter ::                                          &
+         v1 = (/22.2350800,67.8139600,119.9959400,183.3101170,321.2256440,               &
+                325.1529190,336.1870000,380.1973720,390.1345080,437.3466670,439.1508120, &
+                443.0182950,448.0010750,470.8889740,474.6891270,488.4911330,503.5685320, &
+                504.4826920,556.9360020,620.7008070,658.0065000,752.0332270,841.0735950, &
+                859.8650000,899.4070000,902.5550000,906.2055240,916.1715820,970.3150220, &
+                987.9267640/),                                                           &
+         b1 = (/0.1090000,0.0011000,0.0007000,2.3000000,0.0464000,1.5400000,             &
+                0.0010000,11.9000000,0.0044000,0.0637000,0.9210000,0.1940000,10.6000000, &
+                0.3300000,1.2800000,0.2530000,0.0374000,0.0125000,510.0000000,5.0900000, &
+                0.2740000,250.0000000,0.0130000,0.1330000,0.0550000,0.0380000,0.1830000, &
+                8.5600000,9.1600000,138.0000000/),                                       &
+         b2 = (/2.1430000,8.7300000,8.3470000,0.6530000,6.1560000,1.5150000,             &
+                9.8020000,1.0180000,7.3180000,5.0150000,3.5610000,5.0150000,1.3700000,   &
+                3.5610000,2.3420000,2.8140000,6.6930000,6.6930000,0.1140000,2.1500000,   &
+                7.7670000,0.3360000,8.1130000,7.9890000,7.8450000,8.3600000,5.0390000,   &
+                1.3690000,1.8420000,0.1780000/),                                         &
+         b3 = (/0.0278400,0.0276000,0.0270000,0.0283500,0.0214000,0.0270000,             &
+                0.0265000,0.0276000,0.0190000,0.0137000,0.0164000,0.0144000,0.0238000,   &
+                0.0182000,0.0198000,0.0249000,0.0115000,0.0119000,0.0300000,0.0223000,   &
+                0.0300000,0.0286000,0.0141000,0.0286000,0.0286000,0.0264000,0.0234000,   &
+                0.0253000,0.0240000,0.0286000/)
+
+    ! Conversions
+    th     = 300._wp/T                                             ! unitless
+
+    ! DS2014 START: Using _wp for the exponential in the denominator results in slight errors
+    !               for dBze94. 0.01 % of values differ, relative range: 1.03e-05 to  1.78e-04
+    !e      = (RH*th*th*th*th*th)/(41.45_wp*10**(9.834_wp*th-10))   ! kPa
+    !e = (RH*th*th*th*th*th)/(41.45_wp*10**(9.834_wp*th-10))   ! kPa
+    e = SH*PRES_mb/(SH+0.622_wp)/1000._wp !kPa
+    ! DS2014 END
+
+    p      = PRES_mb/1000._wp-e                                      ! kPa
+    e_th   = e*th
+    one_th = 1 - th
+    pth3   = p*th*th*th
+    eth35  = e*th**(3.5)
+    
+    ! Term1
+    sumo = 0._wp
+    aux1 = 1.1_wp*e_th
+    do i=1,nbands_o2
+       aux2   = f/v0(i)
+       aux3   = v0(i)-f
+       aux4   = v0(i)+f
+       gm     = a3(i)*(p*th**(0.8_wp-a4(i))+aux1)
+       gm2    = gm*gm
+       delt   = a5(i)*p*th**a6(i)
+       x      = aux3*aux3+gm2
+       y      = aux4*aux4+gm2
+       fpp_o2 = (((1._wp/x)+(1._wp/y))*(gm*aux2) - (delt*aux2)*((aux3/(x))-(aux4/(x))))
+       s_o2   = a1(i)*pth3*exp(a2(i)*one_th)
+       sumo   = sumo + fpp_o2 * s_o2
+    enddo
+    term1 = sumo
+
+    ! Term2
+    gm0   = 5.6E-3_wp*(p+1.1_wp*e)*th**(0.8_wp)
+    a0    = 3.07E-4_wp
+    ap    = 1.4_wp*(1-1.2_wp*f**(1.5_wp)*1E-5)*1E-10
+    term2 = (2*a0*(gm0*(1+(f/gm0)*(f/gm0))*(1+(f/60._wp)**2))**(-1) + ap*p*th**(2.5_wp))*f*p*th*th
+
+    ! Term3
+    sumo = 0._wp
+    aux1 = 4.8_wp*e_th
+    do i=1,nbands_h2o
+       aux2    = f/v1(i)
+       aux3    = v1(i)-f
+       aux4    = v1(i)+f
+       gm      = b3(i)*(p*th**(0.8)+aux1)
+       gm2     = gm*gm
+       x       = aux3*aux3+gm2
+       y       = aux4*aux4+gm2
+       fpp_h2o = ((1._wp/x)+(1._wp/y))*(gm*aux2) ! - (delt*aux2)*((aux3/(x))-(aux4/(x)))
+       s_h2o   = b1(i)*eth35*exp(b2(i)*one_th)
+       sumo    = sumo + fpp_h2o * s_h2o
+    enddo
+    term3 = sumo
+
+    ! Term4
+    bf    = 1.4E-6_wp
+    be    = 5.41E-5_wp
+    term4 = (bf*p+be*e*th*th*th)*f*e*th**(2.5_wp)
+
+    ! Summation and result
+    npp   = term1 + term2 + term3 + term4
+    gases = 0.182_wp*f*npp
+    
+  end function gases
+ subroutine hydro_class_init(lsingle,ldouble,sd)
+    ! ##############################################################################################
+    ! Purpose:
+    !
+    !   Initialize variables used by the radar simulator.
+    !   Part of QuickBeam v3.0 by John Haynes and Roj Marchand
+    !   
+    ! Inputs:  
+    !   NAME            SIZE        DESCRIPTION
+    !   [lsingle]       (1)         Logical flag to use single moment
+    !   [ldouble]       (1)         Logical flag to use two moment
+    ! Outputs:
+    !   [sd]                        Structure that define hydrometeor types
+    !
+    ! Local variables:
+    !   [n_hydro]       (1)         Number of hydrometeor types
+    !   [hclass_type]   (nhclass)   Type of distribution (see quickbeam documentation)
+    !   [hclass_phase]  (nhclass)   1==ice, 0=liquid
+    !   [hclass_dmin]   (nhclass)   Minimum diameter allowed is drop size distribution N(D<Dmin)=0
+    !   [hclass_dmax]   (nhclass)   Maximum diameter allowed is drop size distribution N(D>Dmax)=0
+    !   [hclass_apm]    (nhclass)   Density of partical apm*D^bpm or constant = rho
+    !   [hclass_bpm]    (nhclass)   Density of partical apm*D^bpm or constant = rho
+    !   [hclass_rho]    (nhclass)   Density of partical apm*D^bpm or constant = rho
+    !   [hclass_p1]     (nhclass)   Default values of DSD parameters (see quickbeam documentation)
+    !   [hclass_p2]     (nhclass)   Default values of DSD parameters (see quickbeam documentation)
+    !   [hclass_p3]     (nhclass)   Default values of DSD parameters (see quickbeam documentation)    
+    ! Modified:
+    !   08/23/2006  placed into subroutine form (Roger Marchand)
+    !   June 2010   New interface to support "radar_simulator_params" structure
+    !   12/22/2014  Moved radar simulator (CLOUDSAT) configuration initialization to cloudsat_init
+    ! ##############################################################################################
+
+    ! ####################################################################################
+    ! NOTES on HCLASS variables
+    !
+    ! TYPE - Set to
+    ! 1 for modified gamma distribution,
+    ! 2 for exponential distribution,
+    ! 3 for power law distribution,
+    ! 4 for monodisperse distribution,
+    ! 5 for lognormal distribution.
+	!
+    ! PHASE - Set to 0 for liquid, 1 for ice.
+    ! DMIN  - The minimum drop size for this class (micron), ignored for monodisperse.
+    ! DMAX  - The maximum drop size for this class (micron), ignored for monodisperse.
+    ! Important note: The settings for DMIN and DMAX are
+    ! ignored in the current version for all distributions except for power
+    ! law. Except when the power law distribution is used, particle size
+    ! is fixed to vary from zero to infinity, a restriction that is expected
+    ! to be lifted in future versions. A placeholder must still be specified
+    ! for each.
+    ! Density of particles is given by apm*D^bpm or a fixed value rho. ONLY specify ONE of these two!!
+    ! APM - The alpha_m coefficient in equation (1) (kg m**-beta_m )
+    ! BPM - The beta_m coefficient in equation (1), see section 4.1.
+    ! RHO - Hydrometeor density (kg m-3 ).
+    ! 
+    ! P1, P2, P3 - are default distribution parameters that depend on the type
+    ! of distribution (see quickmbeam documentation for more information)
+    !
+    ! Modified Gamma (must set P3 and one of P1 or P2)
+    ! P1 - Set to the total particle number concentration Nt /rho_a (kg-1 ), where
+    ! rho_a is the density of air in the radar volume.
+    ! P2 - Set to the particle mean diameter D (micron).
+    ! P3 - Set to the distribution width nu.
+    !
+    ! Exponetial (set one of)
+    ! P1 - Set to a constant intercept parameter N0 (m-4).
+    ! P2 - Set to a constant lambda (micron-1).
+    !
+    ! Power Law
+    ! P1 - Set this to the value of a constant power law parameter br
+    !
+    ! Monodisperse
+    ! P1 - Set to a constant diameter D0 (micron) = Re.
+    !
+    ! Log-normal (must set P3 and one of P1 or P2)
+    ! P1 - Set to the total particle number concentration Nt /rho_a (kg-1 )
+    ! P2 - Set to the geometric mean particle radius rg (micron).
+    ! P3 - Set to the natural logarithm of the geometric standard deviation.
+    ! ####################################################################################
+    ! INPUTS
+    logical,intent(in) :: &
+       lsingle, & ! True -> use single moment
+       ldouble    ! True -> use two moment 
+                     
+    ! OUTPUTS
+    type(size_distribution),intent(out) ::&
+         sd              !
+
+   ! SINGLE MOMENT PARAMETERS
+   integer,parameter,dimension(N_HYDRO) :: &
+                    ! LSL  LSI  LSR  LSS  CVL  CVI  CVR  CVS  LSG    
+       HCLASS1_TYPE  = (/5,   1,   2,   2,   5,   1,   2,   2,   2/), & ! 
+       HCLASS1_PHASE = (/0,   1,   0,   1,   0,   1,   0,   1,   1/)    ! 
+   real(wp),parameter,dimension(N_HYDRO) ::&
+                      ! LSL   LSI    LSR    LSS    CVL   CVI    CVR    CVS    LSG    
+       HCLASS1_DMIN = (/ -1.,  -1.,   -1.,   -1.,   -1.,  -1.,   -1.,   -1.,   -1.  /),  &
+       HCLASS1_DMAX = (/ -1.,  -1.,   -1.,   -1.,   -1.,  -1.,   -1.,   -1.,   -1.  /),  &
+       HCLASS1_APM  = (/524., 110.8, 524.,   -1.,  524., 110.8, 524.,   -1.,   -1.  /),  &
+       HCLASS1_BPM  = (/  3.,   2.91,  3.,   -1.,    3.,   2.91,  3.,   -1.,   -1.  /),  &
+       HCLASS1_RHO  = (/ -1.,  -1.,   -1.,  100.,   -1.,  -1.,   -1.,  100.,  400.  /),  &
+       HCLASS1_P1   = (/ -1.,  -1.,    8.e6,  3.e6, -1.,  -1.,    8.e6,  3.e6,  4.e6/),  & 
+       HCLASS1_P2   = (/  6.,  40.,   -1.,   -1.,    6.,  40.,   -1.,   -1.,   -1.   /), & 
+       HCLASS1_P3   = (/  0.3,  2.,   -1.,   -1.,    0.3,  2.,   -1.,   -1.,   -1.   /)
+
+    ! TWO MOMENT PARAMETERS
+    integer,parameter,dimension(N_HYDRO) :: &
+                      ! LSL  LSI  LSR  LSS  CVL  CVI  CVR  CVS  LSG
+       HCLASS2_TYPE  = (/ 1,   1,   1,   1,   1,   1,   1,   1,   1/), &
+       HCLASS2_PHASE = (/ 0,   1,   0,   1,   0,   1,   0,   1,   1/)
+
+    real(wp),parameter,dimension(N_HYDRO) :: &
+                      ! LSL    LSI      LSR     LSS   CVL    CVI   CVR     CVS    LSG
+       HCLASS2_DMIN = (/ -1,     -1,     -1,     -1,    -1,    -1,   -1,     -1,   -1/), &
+       HCLASS2_DMAX = (/ -1,     -1,     -1,     -1,    -1,    -1,   -1,     -1,   -1/), &        
+       HCLASS2_APM  = (/524,     -1,    524,     -1,   524,    -1,  524,     -1,   -1/), &
+       HCLASS2_BPM  = (/  3,     -1,      3,     -1,     3,    -1,    3,     -1,   -1/), &
+       HCLASS2_RHO  = (/ -1,    500,     -1,    100,    -1,   500,   -1,    100,  900/), &
+       HCLASS2_P1   = (/ -1,     -1,     -1,     -1,    -1,    -1,   -1,     -1,   -1/), &
+       HCLASS2_P2   = (/ -1,     -1,     -1,     -1,    -1,    -1,   -1,     -1,   -1/), &
+       HCLASS2_P3   = (/ -2,      1,      1,      1,    -2,     1,    1,      1,    1/) 
+    
+    if (lsingle) then    
+       sd%dtype(1:N_HYDRO) = HCLASS1_TYPE(1:N_HYDRO)
+       sd%phase(1:N_HYDRO) = HCLASS1_PHASE(1:N_HYDRO)
+       sd%dmin(1:N_HYDRO)  = HCLASS1_DMIN(1:N_HYDRO)
+       sd%dmax(1:N_HYDRO)  = HCLASS1_DMAX(1:N_HYDRO)
+       sd%apm(1:N_HYDRO)   = HCLASS1_APM(1:N_HYDRO)
+       sd%bpm(1:N_HYDRO)   = HCLASS1_BPM(1:N_HYDRO)
+       sd%rho(1:N_HYDRO)   = HCLASS1_RHO(1:N_HYDRO)
+       sd%p1(1:N_HYDRO)    = HCLASS1_P1(1:N_HYDRO)
+       sd%p2(1:N_HYDRO)    = HCLASS1_P2(1:N_HYDRO)
+       sd%p3(1:N_HYDRO)    = HCLASS1_P3(1:N_HYDRO)
+    endif
+    if (ldouble) then    
+       sd%dtype(1:N_HYDRO) = HCLASS2_TYPE(1:N_HYDRO)
+       sd%phase(1:N_HYDRO) = HCLASS2_PHASE(1:N_HYDRO)
+       sd%dmin(1:N_HYDRO)  = HCLASS2_DMIN(1:N_HYDRO)
+       sd%dmax(1:N_HYDRO)  = HCLASS2_DMAX(1:N_HYDRO)
+       sd%apm(1:N_HYDRO)   = HCLASS2_APM(1:N_HYDRO)
+       sd%bpm(1:N_HYDRO)   = HCLASS2_BPM(1:N_HYDRO)
+       sd%rho(1:N_HYDRO)   = HCLASS2_RHO(1:N_HYDRO)
+       sd%p1(1:N_HYDRO)    = HCLASS2_P1(1:N_HYDRO)
+       sd%p2(1:N_HYDRO)    = HCLASS2_P2(1:N_HYDRO)
+       sd%p3(1:N_HYDRO)    = HCLASS2_P3(1:N_HYDRO)
+    endif    
+  end subroutine hydro_class_init    
+end module mod_quickbeam_optics
Index: DZ6/trunk/libf/phylmd/cospv2/scops.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cospv2/scops.F90	(revision 5267)
+++ 	(revision )
@@ -1,240 +1,0 @@
-! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-! Copyright (c) 2009, British Crown Copyright, the Met Office
-! All rights reserved.
-!
-! Redistribution and use in source and binary forms, with or without modification, are 
-! permitted provided that the following conditions are met:
-!
-! 1. Redistributions of source code must retain the above copyright notice, this list of 
-!    conditions and the following disclaimer.
-!
-! 2. Redistributions in binary form must reproduce the above copyright notice, this list
-!    of conditions and the following disclaimer in the documentation and/or other 
-!    materials provided with the distribution.
-!
-! 3. Neither the name of the copyright holder nor the names of its contributors may be 
-!    used to endorse or promote products derived from this software without specific prior
-!    written permission.
-!
-! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY 
-! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 
-! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL 
-! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 
-! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT 
-! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 
-! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
-! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-!
-! History
-! May 2015 - D. Swales - Modified for COSPv2.0
-! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-module mod_scops
-  USE COSP_KINDS,     ONLY: wp
-  USE MOD_RNG!,        ONLY: rng_state,get_rng
-  use mod_cosp_error, ONLY: errorMessage
-
-  implicit none
-
-  integer,parameter :: default_overlap = 3 ! Used when invalid overlap assumption is provided.
-  
-contains
-  subroutine scops(npoints,nlev,ncol,rngs,cc,conv,overlap,frac_out,ncolprint)
-    INTEGER :: npoints,    &    ! Number of model points in the horizontal
-               nlev,       &    ! Number of model levels in column
-               ncol,       &    ! Number of subcolumns
-               overlap          ! Overlap type (1=max, 2=rand, 3=max/rand)
-    type(rng_state),dimension(npoints) :: rngs            
-    INTEGER, parameter :: huge32 = 2147483647
-    INTEGER, parameter :: i2_16  = 65536
-    INTEGER :: i,j,ilev,ibox,ncolprint,ilev2
-
-    REAL(WP), dimension(npoints,nlev) ::  &
-         cc,         &    ! Input cloud cover in each model level (fraction)
-                          ! NOTE:  This is the HORIZONTAL area of each
-                          !        grid box covered by clouds
-         conv,       &    ! Input convective cloud cover in each model level (fraction)
-                          ! NOTE:  This is the HORIZONTAL area of each
-                          !        grid box covered by convective clouds
-         tca              ! Total cloud cover in each model level (fraction)
-                          ! with extra layer of zeroes on top
-                          ! in this version this just contains the values input
-                          ! from cc but with an extra level
-    REAL(WP),intent(inout), dimension(npoints,ncol,nlev) :: &
-         frac_out         ! Boxes gridbox divided up into equivalent of BOX in 
-                          ! original version, but indexed by column then row, rather than
-                          ! by row then column
-    REAL(WP), dimension(npoints,ncol) :: &
-         threshold,   &   ! pointer to position in gridbox
-         maxocc,      &   ! Flag for max overlapped conv cld
-         maxosc,      &   ! Flag for max overlapped strat cld
-         boxpos,      &   ! ordered pointer to position in gridbox
-         threshold_min    ! minimum value to define range in with new threshold is chosen.
-    REAL(WP), dimension(npoints) :: &
-         ran              ! vector of random numbers
-
-    ! Test for valid input overlap assumption
-    if (overlap .ne. 1 .and. overlap .ne. 2 .and. overlap .ne. 3) then
-       overlap=default_overlap
-       call errorMessage('ERROR(scops): Invalid overlap assumption provided. Using default overlap assumption (max/ran)')
-    endif
-
-    boxpos = spread(([(i, i=1,ncol)]-0.5)/ncol,1,npoints)
-    
-    ! #######################################################################
-    ! Initialize working variables
-    ! #######################################################################
-    
-    ! Initialize frac_out to zero
-    frac_out(1:npoints,1:ncol,1:nlev)=0.0     
-    
-    ! Assign 2d tca array using 1d input array cc
-    tca(1:npoints,1:nlev) = cc(1:npoints,1:nlev)
-    
-    if (ncolprint.ne.0) then
-       write (6,'(a)') 'frac_out_pp_rev:'
-       do j=1,npoints,1000
-          write(6,'(a10)') 'j='
-          write(6,'(8I10)') j
-          write (6,'(8f5.2)') ((frac_out(j,ibox,ilev),ibox=1,ncolprint),ilev=1,nlev)
-       enddo
-       write (6,'(a)') 'ncol:'
-       write (6,'(I3)') ncol
-    endif
-    if (ncolprint.ne.0) then
-       write (6,'(a)') 'last_frac_pp:'
-       do j=1,npoints,1000
-          write(6,'(a10)') 'j='
-          write(6,'(8I10)') j
-          write (6,'(8f5.2)') (tca(j,1))
-       enddo
-    endif
-    
-    ! #######################################################################
-    ! ALLOCATE CLOUD INTO BOXES, FOR NCOLUMNS, NLEVELS
-    ! frac_out is the array that contains the information 
-    ! where 0 is no cloud, 1 is a stratiform cloud and 2 is a
-    ! convective cloud
-    ! #######################################################################
-    
-    ! Loop over vertical levels
-    DO ilev = 1,nlev
-       
-       ! Initialise threshold
-       IF (ilev.eq.1) then
-          ! If max overlap 
-          IF (overlap.eq.1) then
-             ! Select pixels spread evenly across the gridbox
-             threshold(1:npoints,1:ncol)=boxpos(1:npoints,1:ncol)
-          ELSE
-             DO ibox=1,ncol
-                !include 'congvec.f90'
-                ran(1:npoints) = get_rng(RNGS)
-                ! select random pixels from the non-convective
-                ! part the gridbox ( some will be converted into
-                ! convective pixels below )
-                threshold(1:npoints,ibox) = conv(1:npoints,ilev)+(1-conv(1:npoints,ilev))*ran(npoints)
-             enddo
-          ENDIF
-          IF (ncolprint.ne.0) then
-             write (6,'(a)') 'threshold_nsf2:'
-             do j=1,npoints,1000
-                write(6,'(a10)') 'j='
-                write(6,'(8I10)') j
-                write (6,'(8f5.2)') (threshold(j,ibox),ibox=1,ncolprint)
-             enddo
-          ENDIF
-       ENDIF
-       
-       IF (ncolprint.ne.0) then
-          write (6,'(a)') 'ilev:'
-          write (6,'(I2)') ilev
-       ENDIF
-       
-       DO ibox=1,ncol
-          ! All versions
-          !maxocc(1:npoints,ibox) = merge(1,0,boxpos(1:npoints,ibox) .le. conv(1:npoints,ilev))
-          !maxocc(1:npoints,ibox) = merge(1,0, conv(1:npoints,ilev) .gt. boxpos(1:npoints,ibox))
-          do j=1,npoints
-             if (boxpos(j,ibox).le.conv(j,ilev)) then
-                maxocc(j,ibox) = 1
-             else
-                maxocc(j,ibox) = 0
-             end if
-          enddo
-          
-          ! Max overlap
-          if (overlap.eq.1) then 
-             threshold_min(1:npoints,ibox) = conv(1:npoints,ilev)
-             maxosc(1:npoints,ibox)        = 1               
-          endif
-          
-          ! Random overlap
-          if (overlap.eq.2) then 
-             threshold_min(1:npoints,ibox) = conv(1:npoints,ilev)
-             maxosc(1:npoints,ibox)        = 0
-          endif
-          ! Max/Random overlap
-          if (overlap.eq.3) then 
-             ! DS2014 START: The bounds on tca are not valid when ilev=1.
-             !threshold_min(1:npoints,ibox) = max(conv(1:npoints,ilev),min(tca(1:npoints,ilev-1),tca(1:npoints,ilev)))
-             !maxosc(1:npoints,ibox) = merge(1,0,threshold(1:npoints,ibox) .lt. &
-             !     min(tca(1:npoints,ilev-1),tca(1:npoints,ilev)) .and. &
-             !     (threshold(1:npoints,ibox).gt.conv(1:npoints,ilev)))
-             if (ilev .ne. 1) then
-                threshold_min(1:npoints,ibox) = max(conv(1:npoints,ilev),min(tca(1:npoints,ilev-1),tca(1:npoints,ilev)))
-                maxosc(1:npoints,ibox) = merge(1,0,threshold(1:npoints,ibox) .lt. &
-                     min(tca(1:npoints,ilev-1),tca(1:npoints,ilev)) .and. &
-                     (threshold(1:npoints,ibox).gt.conv(1:npoints,ilev)))
-             else
-                threshold_min(1:npoints,ibox) = max(conv(1:npoints,ilev),min(0._wp,tca(1:npoints,ilev)))
-                maxosc(1:npoints,ibox) = merge(1,0,threshold(1:npoints,ibox) .lt. &
-                     min(0._wp,tca(1:npoints,ilev)) .and. &
-                     (threshold(1:npoints,ibox).gt.conv(1:npoints,ilev)))
-             endif
-          endif
-          
-          ! Reset threshold 
-          !include 'congvec.f90'
-          ran(1:npoints) = get_rng(RNGS)
-          
-          threshold(1:npoints,ibox)= maxocc(1:npoints,ibox)*(boxpos(1:npoints,ibox)) +            &
-               (1-maxocc(1:npoints,ibox))*((maxosc(1:npoints,ibox))*(threshold(1:npoints,ibox)) + &
-               (1-maxosc(1:npoints,ibox))*(threshold_min(1:npoints,ibox)+                         &
-               (1-threshold_min(1:npoints,ibox))*ran(1:npoints)))
-          
-          ! Fill frac_out with 1's where tca is greater than the threshold
-          frac_out(1:npoints,ibox,ilev) = merge(1,0,tca(1:npoints,ilev).gt.threshold(1:npoints,ibox))
-          
-          ! Code to partition boxes into startiform and convective parts goes here
-          where(threshold(1:npoints,ibox).le.conv(1:npoints,ilev) .and. conv(1:npoints,ilev).gt.0.) frac_out(1:npoints,ibox,ilev)=2
-       ENDDO ! ibox
-       
-       
-       ! Set last_frac to tca at this level, so as to be tca from last level next time round
-       if (ncolprint.ne.0) then
-          do j=1,npoints ,1000
-             write(6,'(a10)') 'j='
-             write(6,'(8I10)') j
-             write (6,'(a)') 'last_frac:'
-             write (6,'(8f5.2)') (tca(j,ilev))
-             write (6,'(a)') 'conv:'
-             write (6,'(8f5.2)') (conv(j,ilev),ibox=1,ncolprint)
-             write (6,'(a)') 'max_overlap_cc:'
-             write (6,'(8f5.2)') (maxocc(j,ibox),ibox=1,ncolprint)
-             write (6,'(a)') 'max_overlap_sc:'
-             write (6,'(8f5.2)') (maxosc(j,ibox),ibox=1,ncolprint)
-             write (6,'(a)') 'threshold_min_nsf2:'
-             write (6,'(8f5.2)') (threshold_min(j,ibox),ibox=1,ncolprint)
-             write (6,'(a)') 'threshold_nsf2:'
-             write (6,'(8f5.2)') (threshold(j,ibox),ibox=1,ncolprint)
-             write (6,'(a)') 'frac_out_pp_rev:'
-             write (6,'(8f5.2)') ((frac_out(j,ibox,ilev2),ibox=1,ncolprint),ilev2=1,nlev)
-          enddo
-       endif
-       
-    enddo ! Loop over nlev
-    
-    ! END
-  end subroutine scops
-end module mod_scops
Index: /LMDZ6/trunk/libf/phylmd/cospv2/scops.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cospv2/scops.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/cospv2/scops.f90	(revision 5268)
@@ -0,0 +1,240 @@
+! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+! Copyright (c) 2009, British Crown Copyright, the Met Office
+! All rights reserved.
+!
+! Redistribution and use in source and binary forms, with or without modification, are 
+! permitted provided that the following conditions are met:
+!
+! 1. Redistributions of source code must retain the above copyright notice, this list of 
+!    conditions and the following disclaimer.
+!
+! 2. Redistributions in binary form must reproduce the above copyright notice, this list
+!    of conditions and the following disclaimer in the documentation and/or other 
+!    materials provided with the distribution.
+!
+! 3. Neither the name of the copyright holder nor the names of its contributors may be 
+!    used to endorse or promote products derived from this software without specific prior
+!    written permission.
+!
+! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY 
+! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 
+! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL 
+! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 
+! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT 
+! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 
+! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+!
+! History
+! May 2015 - D. Swales - Modified for COSPv2.0
+! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+module mod_scops
+  USE COSP_KINDS,     ONLY: wp
+  USE MOD_RNG!,        ONLY: rng_state,get_rng
+  use mod_cosp_error, ONLY: errorMessage
+
+  implicit none
+
+  integer,parameter :: default_overlap = 3 ! Used when invalid overlap assumption is provided.
+  
+contains
+  subroutine scops(npoints,nlev,ncol,rngs,cc,conv,overlap,frac_out,ncolprint)
+    INTEGER :: npoints,    &    ! Number of model points in the horizontal
+               nlev,       &    ! Number of model levels in column
+               ncol,       &    ! Number of subcolumns
+               overlap          ! Overlap type (1=max, 2=rand, 3=max/rand)
+    type(rng_state),dimension(npoints) :: rngs            
+    INTEGER, parameter :: huge32 = 2147483647
+    INTEGER, parameter :: i2_16  = 65536
+    INTEGER :: i,j,ilev,ibox,ncolprint,ilev2
+
+    REAL(WP), dimension(npoints,nlev) ::  &
+         cc,         &    ! Input cloud cover in each model level (fraction)
+                          ! NOTE:  This is the HORIZONTAL area of each
+                          !        grid box covered by clouds
+         conv,       &    ! Input convective cloud cover in each model level (fraction)
+                          ! NOTE:  This is the HORIZONTAL area of each
+                          !        grid box covered by convective clouds
+         tca              ! Total cloud cover in each model level (fraction)
+                          ! with extra layer of zeroes on top
+                          ! in this version this just contains the values input
+                          ! from cc but with an extra level
+    REAL(WP),intent(inout), dimension(npoints,ncol,nlev) :: &
+         frac_out         ! Boxes gridbox divided up into equivalent of BOX in 
+                          ! original version, but indexed by column then row, rather than
+                          ! by row then column
+    REAL(WP), dimension(npoints,ncol) :: &
+         threshold,   &   ! pointer to position in gridbox
+         maxocc,      &   ! Flag for max overlapped conv cld
+         maxosc,      &   ! Flag for max overlapped strat cld
+         boxpos,      &   ! ordered pointer to position in gridbox
+         threshold_min    ! minimum value to define range in with new threshold is chosen.
+    REAL(WP), dimension(npoints) :: &
+         ran              ! vector of random numbers
+
+    ! Test for valid input overlap assumption
+    if (overlap .ne. 1 .and. overlap .ne. 2 .and. overlap .ne. 3) then
+       overlap=default_overlap
+       call errorMessage('ERROR(scops): Invalid overlap assumption provided. Using default overlap assumption (max/ran)')
+    endif
+
+    boxpos = spread(([(i, i=1,ncol)]-0.5)/ncol,1,npoints)
+    
+    ! #######################################################################
+    ! Initialize working variables
+    ! #######################################################################
+    
+    ! Initialize frac_out to zero
+    frac_out(1:npoints,1:ncol,1:nlev)=0.0     
+    
+    ! Assign 2d tca array using 1d input array cc
+    tca(1:npoints,1:nlev) = cc(1:npoints,1:nlev)
+    
+    if (ncolprint.ne.0) then
+       write (6,'(a)') 'frac_out_pp_rev:'
+       do j=1,npoints,1000
+          write(6,'(a10)') 'j='
+          write(6,'(8I10)') j
+          write (6,'(8f5.2)') ((frac_out(j,ibox,ilev),ibox=1,ncolprint),ilev=1,nlev)
+       enddo
+       write (6,'(a)') 'ncol:'
+       write (6,'(I3)') ncol
+    endif
+    if (ncolprint.ne.0) then
+       write (6,'(a)') 'last_frac_pp:'
+       do j=1,npoints,1000
+          write(6,'(a10)') 'j='
+          write(6,'(8I10)') j
+          write (6,'(8f5.2)') (tca(j,1))
+       enddo
+    endif
+    
+    ! #######################################################################
+    ! ALLOCATE CLOUD INTO BOXES, FOR NCOLUMNS, NLEVELS
+    ! frac_out is the array that contains the information 
+    ! where 0 is no cloud, 1 is a stratiform cloud and 2 is a
+    ! convective cloud
+    ! #######################################################################
+    
+    ! Loop over vertical levels
+    DO ilev = 1,nlev
+       
+       ! Initialise threshold
+       IF (ilev.eq.1) then
+          ! If max overlap 
+          IF (overlap.eq.1) then
+             ! Select pixels spread evenly across the gridbox
+             threshold(1:npoints,1:ncol)=boxpos(1:npoints,1:ncol)
+          ELSE
+             DO ibox=1,ncol
+                !include 'congvec.f90'
+                ran(1:npoints) = get_rng(RNGS)
+                ! select random pixels from the non-convective
+                ! part the gridbox ( some will be converted into
+                ! convective pixels below )
+                threshold(1:npoints,ibox) = conv(1:npoints,ilev)+(1-conv(1:npoints,ilev))*ran(npoints)
+             enddo
+          ENDIF
+          IF (ncolprint.ne.0) then
+             write (6,'(a)') 'threshold_nsf2:'
+             do j=1,npoints,1000
+                write(6,'(a10)') 'j='
+                write(6,'(8I10)') j
+                write (6,'(8f5.2)') (threshold(j,ibox),ibox=1,ncolprint)
+             enddo
+          ENDIF
+       ENDIF
+       
+       IF (ncolprint.ne.0) then
+          write (6,'(a)') 'ilev:'
+          write (6,'(I2)') ilev
+       ENDIF
+       
+       DO ibox=1,ncol
+          ! All versions
+          !maxocc(1:npoints,ibox) = merge(1,0,boxpos(1:npoints,ibox) .le. conv(1:npoints,ilev))
+          !maxocc(1:npoints,ibox) = merge(1,0, conv(1:npoints,ilev) .gt. boxpos(1:npoints,ibox))
+          do j=1,npoints
+             if (boxpos(j,ibox).le.conv(j,ilev)) then
+                maxocc(j,ibox) = 1
+             else
+                maxocc(j,ibox) = 0
+             end if
+          enddo
+          
+          ! Max overlap
+          if (overlap.eq.1) then 
+             threshold_min(1:npoints,ibox) = conv(1:npoints,ilev)
+             maxosc(1:npoints,ibox)        = 1               
+          endif
+          
+          ! Random overlap
+          if (overlap.eq.2) then 
+             threshold_min(1:npoints,ibox) = conv(1:npoints,ilev)
+             maxosc(1:npoints,ibox)        = 0
+          endif
+          ! Max/Random overlap
+          if (overlap.eq.3) then 
+             ! DS2014 START: The bounds on tca are not valid when ilev=1.
+             !threshold_min(1:npoints,ibox) = max(conv(1:npoints,ilev),min(tca(1:npoints,ilev-1),tca(1:npoints,ilev)))
+             !maxosc(1:npoints,ibox) = merge(1,0,threshold(1:npoints,ibox) .lt. &
+             !     min(tca(1:npoints,ilev-1),tca(1:npoints,ilev)) .and. &
+             !     (threshold(1:npoints,ibox).gt.conv(1:npoints,ilev)))
+             if (ilev .ne. 1) then
+                threshold_min(1:npoints,ibox) = max(conv(1:npoints,ilev),min(tca(1:npoints,ilev-1),tca(1:npoints,ilev)))
+                maxosc(1:npoints,ibox) = merge(1,0,threshold(1:npoints,ibox) .lt. &
+                     min(tca(1:npoints,ilev-1),tca(1:npoints,ilev)) .and. &
+                     (threshold(1:npoints,ibox).gt.conv(1:npoints,ilev)))
+             else
+                threshold_min(1:npoints,ibox) = max(conv(1:npoints,ilev),min(0._wp,tca(1:npoints,ilev)))
+                maxosc(1:npoints,ibox) = merge(1,0,threshold(1:npoints,ibox) .lt. &
+                     min(0._wp,tca(1:npoints,ilev)) .and. &
+                     (threshold(1:npoints,ibox).gt.conv(1:npoints,ilev)))
+             endif
+          endif
+          
+          ! Reset threshold 
+          !include 'congvec.f90'
+          ran(1:npoints) = get_rng(RNGS)
+          
+          threshold(1:npoints,ibox)= maxocc(1:npoints,ibox)*(boxpos(1:npoints,ibox)) +            &
+               (1-maxocc(1:npoints,ibox))*((maxosc(1:npoints,ibox))*(threshold(1:npoints,ibox)) + &
+               (1-maxosc(1:npoints,ibox))*(threshold_min(1:npoints,ibox)+                         &
+               (1-threshold_min(1:npoints,ibox))*ran(1:npoints)))
+          
+          ! Fill frac_out with 1's where tca is greater than the threshold
+          frac_out(1:npoints,ibox,ilev) = merge(1,0,tca(1:npoints,ilev).gt.threshold(1:npoints,ibox))
+          
+          ! Code to partition boxes into startiform and convective parts goes here
+          where(threshold(1:npoints,ibox).le.conv(1:npoints,ilev) .and. conv(1:npoints,ilev).gt.0.) frac_out(1:npoints,ibox,ilev)=2
+       ENDDO ! ibox
+       
+       
+       ! Set last_frac to tca at this level, so as to be tca from last level next time round
+       if (ncolprint.ne.0) then
+          do j=1,npoints ,1000
+             write(6,'(a10)') 'j='
+             write(6,'(8I10)') j
+             write (6,'(a)') 'last_frac:'
+             write (6,'(8f5.2)') (tca(j,ilev))
+             write (6,'(a)') 'conv:'
+             write (6,'(8f5.2)') (conv(j,ilev),ibox=1,ncolprint)
+             write (6,'(a)') 'max_overlap_cc:'
+             write (6,'(8f5.2)') (maxocc(j,ibox),ibox=1,ncolprint)
+             write (6,'(a)') 'max_overlap_sc:'
+             write (6,'(8f5.2)') (maxosc(j,ibox),ibox=1,ncolprint)
+             write (6,'(a)') 'threshold_min_nsf2:'
+             write (6,'(8f5.2)') (threshold_min(j,ibox),ibox=1,ncolprint)
+             write (6,'(a)') 'threshold_nsf2:'
+             write (6,'(8f5.2)') (threshold(j,ibox),ibox=1,ncolprint)
+             write (6,'(a)') 'frac_out_pp_rev:'
+             write (6,'(8f5.2)') ((frac_out(j,ibox,ilev2),ibox=1,ncolprint),ilev2=1,nlev)
+          enddo
+       endif
+       
+    enddo ! Loop over nlev
+    
+    ! END
+  end subroutine scops
+end module mod_scops
Index: DZ6/trunk/libf/phylmd/create_etat0_limit_unstruct_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/create_etat0_limit_unstruct_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,113 +1,0 @@
-MODULE etat0_limit_unstruct_mod
-
-  LOGICAL, SAVE  :: create_etat0_limit
-!$OMP THREADPRIVATE(create_etat0_limit) 
-
-
-
-
-CONTAINS
-  
-  SUBROUTINE init_etat0_limit_unstruct
-  USE lmdz_xios, ONLY: xios_set_axis_attr, xios_set_fieldgroup_attr, &
-                  xios_set_filegroup_attr, xios_set_file_attr
-  USE mod_phys_lmdz_para, ONLY: is_omp_master
-  USE mod_grid_phy_lmdz, ONLY: grid_type, unstructured
-  USE ioipsl, ONLY : ioget_year_len
-  USE ioipsl_getin_p_mod, ONLY: getin_p
-  USE time_phylmdz_mod, ONLY : annee_ref
-  USE create_etat0_unstruct_mod, ONLY: init_create_etat0_unstruct
-  IMPLICIT NONE
-  
-    INTEGER :: iflag_phys,i
-    INTEGER :: ndays
-    REAL,ALLOCATABLE :: value(:)
-    
-      IF (grid_type==unstructured) THEN
-        CALL getin_p("iflag_phys",iflag_phys)
-        
-        CALL getin_p('create_etat0_limit',create_etat0_limit)
-        
-        ndays=ioget_year_len(annee_ref)
-        ALLOCATE(value(ndays))
-        DO i=1,ndays
-          value(i)=i-1
-        ENDDO
-        
-        IF (is_omp_master) CALL xios_set_axis_attr("time_year",n_glo=ndays,value=value) 
-        
-        IF (create_etat0_limit) THEN
-          IF (iflag_phys<100) THEN
-            IF (is_omp_master) CALL xios_set_fieldgroup_attr("etat0_limit_read",read_access=.TRUE.,enabled=.TRUE.)
-            IF (is_omp_master) CALL xios_set_filegroup_attr("etat0_limit_read",enabled=.TRUE.)
-          ENDIF
-          IF (is_omp_master) CALL xios_set_file_attr("limit_write",enabled=.TRUE.)
-          CALL init_create_etat0_unstruct
-        ENDIF
-      
-      ENDIF  
-
-  END SUBROUTINE init_etat0_limit_unstruct
-  
-  SUBROUTINE create_etat0_limit_unstruct
-  USE mod_grid_phy_lmdz, ONLY: grid_type, unstructured
-  USE create_etat0_unstruct_mod, ONLY: create_etat0_unstruct
-  USE create_limit_unstruct_mod, ONLY: create_limit_unstruct
-  USE phyaqua_mod, ONLY: iniaqua
-  USE phys_cal_mod, only: year_len
-  USE mod_phys_lmdz_para, ONLY: is_omp_master
-  USE ioipsl_getin_p_mod, ONLY: getin_p
-  USE dimphy, ONLY: klon
-  USE lmdz_xios, ONLY: xios_context_finalize, xios_set_current_context, &
-                  xios_finalize
-  USE print_control_mod, ONLY: lunout
-  IMPLICIT NONE
-      INTEGER :: iflag_phys
-      INTEGER :: ierr
-      CHARACTER (LEN=20) :: modname='create_etat0_limit_unstruct'
-      CHARACTER (LEN=80) :: abort_message
-     
-      IF (grid_type==unstructured) THEN
-  
-        CALL getin_p("iflag_phys",iflag_phys)
-
-        IF (iflag_phys<100) THEN
-          IF ( create_etat0_limit) THEN
-              CALL create_etat0_unstruct
-              CALL create_limit_unstruct
-              IF (is_omp_master)  THEN
-                CALL xios_context_finalize()
-                CALL xios_set_current_context("icosagcm")   ! very bad, need to find an other solution
-                CALL xios_context_finalize()
-                CALL xios_finalize()
-                CALL MPI_Finalize(ierr)
-                abort_message='create_etat0_limit_unstruct, Initial state file are created, all is fine' 
-                write(lunout,*) abort_message
-                STOP 0
-!                CALL abort_physic(modname,abort_message,0)
-              ENDIF
-!$OMP BARRIER
-              abort_message='create_etat0_limit_unstruct, Initial state file are created, all is fine'
-              CALL abort_physic(modname,abort_message,0)
-          ENDIF 
-        ELSE
-          IF (create_etat0_limit) THEN 
-            CALL iniaqua(klon,year_len,iflag_phys)
-              IF (is_omp_master)  THEN
-                CALL xios_context_finalize()
-                CALL xios_set_current_context("icosagcm")   ! very bad, need to find an other solution
-                CALL xios_context_finalize()
-                CALL xios_finalize()
-                CALL MPI_Finalize(ierr)
-              ENDIF
-!$OMP BARRIER
-              abort_message='create_etat0_limit_unstruct, Initial state file are created, all is fine' 
-              CALL abort_physic(modname,abort_message,0)
-          ENDIF
-        ENDIF
-      ENDIF
-        
-  END SUBROUTINE create_etat0_limit_unstruct
-  
-END MODULE etat0_limit_unstruct_mod
-
Index: /LMDZ6/trunk/libf/phylmd/create_etat0_limit_unstruct_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/create_etat0_limit_unstruct_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/create_etat0_limit_unstruct_mod.f90	(revision 5268)
@@ -0,0 +1,113 @@
+MODULE etat0_limit_unstruct_mod
+
+  LOGICAL, SAVE  :: create_etat0_limit
+!$OMP THREADPRIVATE(create_etat0_limit) 
+
+
+
+
+CONTAINS
+  
+  SUBROUTINE init_etat0_limit_unstruct
+  USE lmdz_xios, ONLY: xios_set_axis_attr, xios_set_fieldgroup_attr, &
+                  xios_set_filegroup_attr, xios_set_file_attr
+  USE mod_phys_lmdz_para, ONLY: is_omp_master
+  USE mod_grid_phy_lmdz, ONLY: grid_type, unstructured
+  USE ioipsl, ONLY : ioget_year_len
+  USE ioipsl_getin_p_mod, ONLY: getin_p
+  USE time_phylmdz_mod, ONLY : annee_ref
+  USE create_etat0_unstruct_mod, ONLY: init_create_etat0_unstruct
+  IMPLICIT NONE
+  
+    INTEGER :: iflag_phys,i
+    INTEGER :: ndays
+    REAL,ALLOCATABLE :: value(:)
+    
+      IF (grid_type==unstructured) THEN
+        CALL getin_p("iflag_phys",iflag_phys)
+        
+        CALL getin_p('create_etat0_limit',create_etat0_limit)
+        
+        ndays=ioget_year_len(annee_ref)
+        ALLOCATE(value(ndays))
+        DO i=1,ndays
+          value(i)=i-1
+        ENDDO
+        
+        IF (is_omp_master) CALL xios_set_axis_attr("time_year",n_glo=ndays,value=value) 
+        
+        IF (create_etat0_limit) THEN
+          IF (iflag_phys<100) THEN
+            IF (is_omp_master) CALL xios_set_fieldgroup_attr("etat0_limit_read",read_access=.TRUE.,enabled=.TRUE.)
+            IF (is_omp_master) CALL xios_set_filegroup_attr("etat0_limit_read",enabled=.TRUE.)
+          ENDIF
+          IF (is_omp_master) CALL xios_set_file_attr("limit_write",enabled=.TRUE.)
+          CALL init_create_etat0_unstruct
+        ENDIF
+      
+      ENDIF  
+
+  END SUBROUTINE init_etat0_limit_unstruct
+  
+  SUBROUTINE create_etat0_limit_unstruct
+  USE mod_grid_phy_lmdz, ONLY: grid_type, unstructured
+  USE create_etat0_unstruct_mod, ONLY: create_etat0_unstruct
+  USE create_limit_unstruct_mod, ONLY: create_limit_unstruct
+  USE phyaqua_mod, ONLY: iniaqua
+  USE phys_cal_mod, only: year_len
+  USE mod_phys_lmdz_para, ONLY: is_omp_master
+  USE ioipsl_getin_p_mod, ONLY: getin_p
+  USE dimphy, ONLY: klon
+  USE lmdz_xios, ONLY: xios_context_finalize, xios_set_current_context, &
+                  xios_finalize
+  USE print_control_mod, ONLY: lunout
+  IMPLICIT NONE
+      INTEGER :: iflag_phys
+      INTEGER :: ierr
+      CHARACTER (LEN=20) :: modname='create_etat0_limit_unstruct'
+      CHARACTER (LEN=80) :: abort_message
+     
+      IF (grid_type==unstructured) THEN
+  
+        CALL getin_p("iflag_phys",iflag_phys)
+
+        IF (iflag_phys<100) THEN
+          IF ( create_etat0_limit) THEN
+              CALL create_etat0_unstruct
+              CALL create_limit_unstruct
+              IF (is_omp_master)  THEN
+                CALL xios_context_finalize()
+                CALL xios_set_current_context("icosagcm")   ! very bad, need to find an other solution
+                CALL xios_context_finalize()
+                CALL xios_finalize()
+                CALL MPI_Finalize(ierr)
+                abort_message='create_etat0_limit_unstruct, Initial state file are created, all is fine' 
+                write(lunout,*) abort_message
+                STOP 0
+!                CALL abort_physic(modname,abort_message,0)
+              ENDIF
+!$OMP BARRIER
+              abort_message='create_etat0_limit_unstruct, Initial state file are created, all is fine'
+              CALL abort_physic(modname,abort_message,0)
+          ENDIF 
+        ELSE
+          IF (create_etat0_limit) THEN 
+            CALL iniaqua(klon,year_len,iflag_phys)
+              IF (is_omp_master)  THEN
+                CALL xios_context_finalize()
+                CALL xios_set_current_context("icosagcm")   ! very bad, need to find an other solution
+                CALL xios_context_finalize()
+                CALL xios_finalize()
+                CALL MPI_Finalize(ierr)
+              ENDIF
+!$OMP BARRIER
+              abort_message='create_etat0_limit_unstruct, Initial state file are created, all is fine' 
+              CALL abort_physic(modname,abort_message,0)
+          ENDIF
+        ENDIF
+      ENDIF
+        
+  END SUBROUTINE create_etat0_limit_unstruct
+  
+END MODULE etat0_limit_unstruct_mod
+
Index: DZ6/trunk/libf/phylmd/create_etat0_unstruct_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/create_etat0_unstruct_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,339 +1,0 @@
-MODULE create_etat0_unstruct_mod
-
-  REAL, SAVE, ALLOCATABLE :: zmea_gw(:)
-  !$OMP THREADPRIVATE(zmea_gw)
-  REAL, SAVE, ALLOCATABLE :: zpic_gw(:)
-  !$OMP THREADPRIVATE(zpic_gw)
-  REAL, SAVE, ALLOCATABLE :: zval_gw(:)
-  !$OMP THREADPRIVATE(zval_gw)
-  REAL, SAVE, ALLOCATABLE :: zstd_gw(:)
-  !$OMP THREADPRIVATE(zstd_gw)
-  REAL, SAVE, ALLOCATABLE :: zsig_gw(:)
-  !$OMP THREADPRIVATE(zsig_gw)
-  REAL, SAVE, ALLOCATABLE :: zgam_gw(:)
-  !$OMP THREADPRIVATE(zgam_gw)
-  REAL, SAVE, ALLOCATABLE :: zthe_gw(:)
-  !$OMP THREADPRIVATE(zthe_gw)
-
-  PRIVATE zmea_gw, zpic_gw, zval_gw, zstd_gw, zsig_gw, zgam_gw, zthe_gw
-
-
-CONTAINS
-  
-  SUBROUTINE init_create_etat0_unstruct
-  USE lmdz_xios
-  USE netcdf
-  USE mod_phys_lmdz_para
-  IMPLICIT NONE
-  INTEGER :: file_id, iret
-  
-   ! for coupling activate ocean fraction reading from file "ocean_fraction.nc"
-    IF (is_omp_master) THEN
-
-      IF (NF90_OPEN("ocean_fraction.nc", NF90_NOWRITE, file_id)==NF90_NOERR) THEN
-        CALL xios_set_file_attr("frac_ocean",enabled=.TRUE.)
-        CALL xios_set_field_attr("mask",field_ref="frac_ocean_read")
-        iret=NF90_CLOSE(file_id)
-      ELSE IF (NF90_OPEN("land_water_0.05.nc", NF90_NOWRITE, file_id)==NF90_NOERR) THEN
-        CALL xios_set_file_attr("land_water",name="land_water_0.05",enabled=.TRUE.)
-        CALL xios_set_field_attr("mask",field_ref="land_water")
-        iret=NF90_CLOSE(file_id)
-      ELSE IF (NF90_OPEN("land_water_0.25.nc", NF90_NOWRITE, file_id)==NF90_NOERR) THEN
-        CALL xios_set_file_attr("land_water",name="land_water_0.25",enabled=.TRUE.)
-        CALL xios_set_field_attr("mask",field_ref="land_water")
-        iret=NF90_CLOSE(file_id)
-      ELSE IF (NF90_OPEN("land_water_0.50.nc", NF90_NOWRITE, file_id)==NF90_NOERR) THEN
-        CALL xios_set_file_attr("land_water",name="land_water_0.50",enabled=.TRUE.)
-        CALL xios_set_field_attr("mask",field_ref="land_water")
-        iret=NF90_CLOSE(file_id)
-      ENDIF
-
-    ENDIF
-
-  END SUBROUTINE init_create_etat0_unstruct
-  
- 
-  SUBROUTINE init_param_gw(zmea, zpic, zval, zstd, zsig, zgam, zthe)
-  USE dimphy
-    REAL, INTENT(IN) :: zmea(klon)  
-    REAL, INTENT(IN) :: zpic(klon)
-    REAL, INTENT(IN) :: zval(klon) 
-    REAL, INTENT(IN) :: zstd(klon) 
-    REAL, INTENT(IN) :: zsig(klon) 
-    REAL, INTENT(IN) :: zgam(klon) 
-    REAL, INTENT(IN) :: zthe(klon)
-
-    ALLOCATE(zmea_gw(klon), zpic_gw(klon), zval_gw(klon), zstd_gw(klon), zsig_gw(klon), zgam_gw(klon), zthe_gw(klon)) 
-    
-    zmea_gw(:)=zmea(:)
-    zpic_gw(:)=zpic(:)
-    zval_gw(:)=zval(:)
-    zstd_gw(:)=zstd(:)
-    zsig_gw(:)=zsig(:)
-    zgam_gw(:)=zgam(:)
-    zthe_gw(:)=zthe(:)
-
-  END SUBROUTINE init_param_gw
-
-
-
-
-  SUBROUTINE create_etat0_unstruct
-  USE dimphy
-  USE lmdz_xios
-  USE infotrac_phy
-  USE fonte_neige_mod
-  USE pbl_surface_mod
-  USE phys_state_var_mod
-  USE indice_sol_mod
-  USE surface_data,      ONLY: landice_opt
-  USE mod_phys_lmdz_para
-  USE print_control_mod, ONLY: lunout
-  USE geometry_mod
-  USE ioipsl_getin_p_mod, ONLY: getin_p
-
-  IMPLICIT NONE
-  INCLUDE 'dimsoil.h'
-  include "clesphys.h"
-
-    LOGICAL :: no_ter_antartique   ! If true, no land points are allowed at Antartic
-    REAL,    DIMENSION(klon)                 :: tsol
-    REAL,    DIMENSION(klon)                 :: sn
-    REAL,    DIMENSION(klon)                 :: rugmer
-    REAL,    DIMENSION(klon)                 :: run_off_lic_0
-    REAL,    DIMENSION(klon)                 :: lic
-    REAL,    DIMENSION(klon)                 :: fder
-
-    REAL,    DIMENSION(klon,nbsrf)           :: qsurf, snsrf
-    REAL,    DIMENSION(klon,nsoilmx,nbsrf)   :: tsoil
-    
-    REAL,    DIMENSION(klon_mpi)             :: tsol_mpi, qsol_mpi, zmasq_mpi, lic_mpi
-    REAL,    DIMENSION(klon_mpi)             :: zmea_mpi, zstd_mpi, zsig_mpi, zgam_mpi, zthe_mpi
-    REAL,    DIMENSION(klon_mpi)             :: cell_area_mpi
-    REAL,    DIMENSION(klon_mpi,nbsrf)       :: pctsrf_mpi
-
-    INCLUDE "compbl.h"
-    INCLUDE "alpale.h"
-   
-    INTEGER :: ji,j,i
- 
-
-!--- Initial atmospheric CO2 conc. from .def file
-    co2_ppm0 = co2_ppm
-
-    IF (is_omp_master) THEN
-      CALL xios_recv_field("ts",tsol_mpi)
-      CALL xios_recv_field("qs",qsol_mpi)
-      CALL xios_recv_field("mask",zmasq_mpi)
-      IF (landice_opt .LT. 2) CALL xios_recv_field("landice",lic_mpi)
-    ENDIF
-    CALL scatter_omp(tsol_mpi,tsol)
-    CALL scatter_omp(qsol_mpi,qsol)
-    CALL scatter_omp(zmasq_mpi,zmasq)
-    IF (landice_opt .LT. 2) CALL scatter_omp(lic_mpi,lic)
-
-    radsol(:)   = 0.0
-    rugmer(:) = 0.001
-    sn(:)     = 0
-
-    WHERE(qsol(:)<0) qsol(:)=0 
-        
-    WHERE(   zmasq(:)<EPSFRA) zmasq(:)=0.
-    WHERE(1.-zmasq(:)<EPSFRA) zmasq(:)=1.
-
-    pctsrf(:,:) = 0
-    IF (landice_opt .LT. 2) THEN
-       pctsrf(:,is_lic)=lic
-       WHERE(pctsrf(:,is_lic)<EPSFRA) pctsrf(:,is_lic)=0.
-       WHERE(zmasq(:)<EPSFRA)         pctsrf(:,is_lic)=0.
-
-       pctsrf(:,is_ter)=zmasq(:)
-       
-       !--- Adequation with soil/sea mask
-       DO ji=1,klon
-          IF(zmasq(ji)>EPSFRA) THEN 
-             IF(pctsrf(ji,is_lic)>=zmasq(ji)) THEN
-                pctsrf(ji,is_lic)=zmasq(ji)
-                pctsrf(ji,is_ter)=0.
-             ELSE
-                pctsrf(ji,is_ter)=zmasq(ji)-pctsrf(ji,is_lic)
-                IF(pctsrf(ji,is_ter)<EPSFRA) THEN
-                   pctsrf(ji,is_ter)=0.
-                   pctsrf(ji,is_lic)=zmasq(ji)
-                END IF
-             END IF
-          END IF
-       END DO
-   
-    ELSE
-       ! landice_opt=>2 : no land ice
-       pctsrf(:,is_lic)=0.0
-       pctsrf(:,is_ter)=zmasq(:)
-    END IF
-
-
-
-
-
-  !--- Option no_ter_antartique removes all land fractions souther than 60S.
-  !--- Land ice is set instead of the land fractions on these latitudes.
-  !--- The ocean and sea-ice fractions are not changed.
-  !--- This option is only available if landice_opt<2.   
-  IF (landice_opt .LT. 2) THEN
-     no_ter_antartique=.FALSE.
-     CALL getin_p('no_ter_antartique',no_ter_antartique)
-     WRITE(lunout,*)"no_ter_antartique=",no_ter_antartique
-     IF (no_ter_antartique) THEN
-        ! Remove all land fractions souther than 60S and set land-ice instead
-        WRITE(lunout,*) "Remove land fractions souther than 60deg south by increasing"
-        WRITE(lunout,*) "the continental ice fractions. No land can now be found at Antartic."
-        DO ji=1, klon
-           IF (latitude_deg(ji)<-60.0) THEN
-              pctsrf(ji,is_lic) = pctsrf(ji,is_lic) + pctsrf(ji,is_ter)
-              pctsrf(ji,is_ter) = 0
-           END IF
-        END DO
-     END IF
-  END IF
-    
-! sub-surface ocean and sea ice (sea ice set to zero for start)
-!*******************************************************************************
-    pctsrf(:,is_oce)=(1.-zmasq(:))
-    WHERE(pctsrf(:,is_oce)<EPSFRA) pctsrf(:,is_oce)=0.
-    
-!    zval(:)=max(0.,zmea-2*zstd(:))
-!    zpic(:)=zmea+2*zstd(:)
-    
-!! WARNING    DON'T FORGET FOR LATER
-!!ym  IF(couple) pctsrf(:,is_oce)=ocemask_fi(:)
-!! 
-    
-! Init: tsol, qsol, sn, evap, tsoil, rain_fall, snow_fall, solsw, sollw, frugs
-!*******************************************************************************
-    DO i=1,nbsrf
-     ftsol(:,i) = tsol
-    END DO
-  
-    DO i=1,nbsrf
-     snsrf(:,i) = sn
-    END DO
-!albedo SB >>>
-!ym error : the sub surface dimension is the third not second
-!    falb_dir(:,is_ter,:)=0.08; falb_dir(:,is_lic,:)=0.6
-!    falb_dir(:,is_oce,:)=0.5;  falb_dir(:,is_sic,:)=0.6
-    falb_dir(:,:,is_ter)=0.08; falb_dir(:,:,is_lic)=0.6
-    falb_dir(:,:,is_oce)=0.5;  falb_dir(:,:,is_sic)=0.6
-
-!ym falb_dif has been forgotten, initialize with defaukt value found in phyetat0 or 0 ?
-!ym probably the uninitialized value was 0 for standard (regular grid) case
-    falb_dif(:,:,:)=0
-    u10m(:,:)=0  
-    v10m(:,:)=0  
-    treedrg(:,:,:)=0
-!albedo SB <<<
-    fevap(:,:) = 0.
-    qsurf = 0.
-    
-    DO i=1,nbsrf 
-      DO j=1,nsoilmx
-        tsoil(:,j,i) = tsol
-      END DO
-    END DO
- 
-    rain_fall = 0.; snow_fall = 0.
-    solsw = 165.;   sollw = -53.
-    solswfdiff = 1. 
-!ym warning missing init for sollwdown => set to 0
-  sollwdown  = 0.
-    
-    
-    t_ancien = 273.15
-    u_ancien=0
-    v_ancien=0
-    q_ancien = 0.
-    ql_ancien = 0.
-    qs_ancien = 0.
-    prlw_ancien = 0.
-    prsw_ancien = 0.
-    prw_ancien = 0.
-    agesno = 0.
-    
-    ! LSCP condensation and ice supersaturation
-    cf_ancien = 0.
-    rvc_ancien = 0.
-
-    wake_delta_pbl_TKE(:,:,:)=0
-    wake_dens(:)=0
-    awake_dens = 0.
-    cv_gen = 0.
-    ale_bl = 0.
-    ale_bl_trig =0.
-    alp_bl=0.
-    ale_wake=0.
-    ale_bl_stat=0.
-    
-    z0m(:,:)=0 ! ym missing 5th subsurface initialization
-    z0m(:,is_oce) = rugmer(:)
-    z0m(:,is_ter) = 0.01 ! MAX(1.0e-05,zstd(:)*zsig(:)/2.0)
-    z0m(:,is_lic) = 0.001 !MAX(1.0e-05,zstd(:)*zsig(:)/2.0)
-    z0m(:,is_sic) = 0.001
-    z0h(:,:)=z0m(:,:)
-
-    fder = 0.0
-    clwcon = 0.0
-    rnebcon = 0.0
-    ratqs = 0.0
-    run_off_lic_0 = 0.0 
-    rugoro = 0.0
-
-! Before phyredem calling, surface modules and values to be saved in startphy.nc
-! are initialized
-!*******************************************************************************
-    pbl_tke(:,:,:) = 1.e-8 
-    zmax0(:) = 40.
-    f0(:) = 1.e-5
-    sig1(:,:) = 0.
-    w01(:,:) = 0.
-    wake_deltat(:,:) = 0.
-    wake_deltaq(:,:) = 0.
-    wake_s(:) = 0.
-    wake_cstar(:) = 0.
-    wake_fip(:) = 0.
-    wake_pe = 0.
-    fm_therm = 0.
-    entr_therm = 0.
-    detr_therm = 0.
-    awake_s = 0.
-
-    CALL fonte_neige_init(run_off_lic_0)
-    CALL pbl_surface_init( fder, snsrf, qsurf, tsoil )
-
-    IF (iflag_pbl>1 .AND. iflag_wake>=1  .AND. iflag_pbl_split >=1) then
-     delta_tsurf = 0.
-     beta_aridity = 0.
-    END IF
-    ratqs_inter_ = 0.002
-
-    CALL gather_omp(cell_area,cell_area_mpi)
-    CALL gather_omp(pctsrf,pctsrf_mpi)
-    IF (is_omp_master) THEN
-      CALL xios_send_field("area_ce0l",cell_area_mpi)
-      CALL xios_send_field("fract_oce_ce0l",pctsrf_mpi(:,is_oce))
-      CALL xios_send_field("fract_sic_ce0l",pctsrf_mpi(:,is_sic))
-    ENDIF
-    
-    zmea(:) = zmea_gw(:)
-    zpic(:) = zpic_gw(:)
-    zval(:) = zval_gw(:)
-    zstd(:) = zstd_gw(:)
-    zsig(:) = zsig_gw(:)
-    zgam(:) = zgam_gw(:)
-    zthe(:) = zthe_gw(:)
-    DEALLOCATE(zmea_gw, zpic_gw, zval_gw, zstd_gw, zsig_gw, zgam_gw, zthe_gw)
-
-    CALL phyredem( "startphy.nc" )
-
-  END SUBROUTINE create_etat0_unstruct
-
-
-END MODULE create_etat0_unstruct_mod
Index: /LMDZ6/trunk/libf/phylmd/create_etat0_unstruct_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/create_etat0_unstruct_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/create_etat0_unstruct_mod.f90	(revision 5268)
@@ -0,0 +1,339 @@
+MODULE create_etat0_unstruct_mod
+
+  REAL, SAVE, ALLOCATABLE :: zmea_gw(:)
+  !$OMP THREADPRIVATE(zmea_gw)
+  REAL, SAVE, ALLOCATABLE :: zpic_gw(:)
+  !$OMP THREADPRIVATE(zpic_gw)
+  REAL, SAVE, ALLOCATABLE :: zval_gw(:)
+  !$OMP THREADPRIVATE(zval_gw)
+  REAL, SAVE, ALLOCATABLE :: zstd_gw(:)
+  !$OMP THREADPRIVATE(zstd_gw)
+  REAL, SAVE, ALLOCATABLE :: zsig_gw(:)
+  !$OMP THREADPRIVATE(zsig_gw)
+  REAL, SAVE, ALLOCATABLE :: zgam_gw(:)
+  !$OMP THREADPRIVATE(zgam_gw)
+  REAL, SAVE, ALLOCATABLE :: zthe_gw(:)
+  !$OMP THREADPRIVATE(zthe_gw)
+
+  PRIVATE zmea_gw, zpic_gw, zval_gw, zstd_gw, zsig_gw, zgam_gw, zthe_gw
+
+
+CONTAINS
+  
+  SUBROUTINE init_create_etat0_unstruct
+  USE lmdz_xios
+  USE netcdf
+  USE mod_phys_lmdz_para
+  IMPLICIT NONE
+  INTEGER :: file_id, iret
+  
+   ! for coupling activate ocean fraction reading from file "ocean_fraction.nc"
+    IF (is_omp_master) THEN
+
+      IF (NF90_OPEN("ocean_fraction.nc", NF90_NOWRITE, file_id)==NF90_NOERR) THEN
+        CALL xios_set_file_attr("frac_ocean",enabled=.TRUE.)
+        CALL xios_set_field_attr("mask",field_ref="frac_ocean_read")
+        iret=NF90_CLOSE(file_id)
+      ELSE IF (NF90_OPEN("land_water_0.05.nc", NF90_NOWRITE, file_id)==NF90_NOERR) THEN
+        CALL xios_set_file_attr("land_water",name="land_water_0.05",enabled=.TRUE.)
+        CALL xios_set_field_attr("mask",field_ref="land_water")
+        iret=NF90_CLOSE(file_id)
+      ELSE IF (NF90_OPEN("land_water_0.25.nc", NF90_NOWRITE, file_id)==NF90_NOERR) THEN
+        CALL xios_set_file_attr("land_water",name="land_water_0.25",enabled=.TRUE.)
+        CALL xios_set_field_attr("mask",field_ref="land_water")
+        iret=NF90_CLOSE(file_id)
+      ELSE IF (NF90_OPEN("land_water_0.50.nc", NF90_NOWRITE, file_id)==NF90_NOERR) THEN
+        CALL xios_set_file_attr("land_water",name="land_water_0.50",enabled=.TRUE.)
+        CALL xios_set_field_attr("mask",field_ref="land_water")
+        iret=NF90_CLOSE(file_id)
+      ENDIF
+
+    ENDIF
+
+  END SUBROUTINE init_create_etat0_unstruct
+  
+ 
+  SUBROUTINE init_param_gw(zmea, zpic, zval, zstd, zsig, zgam, zthe)
+  USE dimphy
+    REAL, INTENT(IN) :: zmea(klon)  
+    REAL, INTENT(IN) :: zpic(klon)
+    REAL, INTENT(IN) :: zval(klon) 
+    REAL, INTENT(IN) :: zstd(klon) 
+    REAL, INTENT(IN) :: zsig(klon) 
+    REAL, INTENT(IN) :: zgam(klon) 
+    REAL, INTENT(IN) :: zthe(klon)
+
+    ALLOCATE(zmea_gw(klon), zpic_gw(klon), zval_gw(klon), zstd_gw(klon), zsig_gw(klon), zgam_gw(klon), zthe_gw(klon)) 
+    
+    zmea_gw(:)=zmea(:)
+    zpic_gw(:)=zpic(:)
+    zval_gw(:)=zval(:)
+    zstd_gw(:)=zstd(:)
+    zsig_gw(:)=zsig(:)
+    zgam_gw(:)=zgam(:)
+    zthe_gw(:)=zthe(:)
+
+  END SUBROUTINE init_param_gw
+
+
+
+
+  SUBROUTINE create_etat0_unstruct
+  USE dimphy
+  USE lmdz_xios
+  USE infotrac_phy
+  USE fonte_neige_mod
+  USE pbl_surface_mod
+  USE phys_state_var_mod
+  USE indice_sol_mod
+  USE surface_data,      ONLY: landice_opt
+  USE mod_phys_lmdz_para
+  USE print_control_mod, ONLY: lunout
+  USE geometry_mod
+  USE ioipsl_getin_p_mod, ONLY: getin_p
+
+  IMPLICIT NONE
+  INCLUDE 'dimsoil.h'
+  include "clesphys.h"
+
+    LOGICAL :: no_ter_antartique   ! If true, no land points are allowed at Antartic
+    REAL,    DIMENSION(klon)                 :: tsol
+    REAL,    DIMENSION(klon)                 :: sn
+    REAL,    DIMENSION(klon)                 :: rugmer
+    REAL,    DIMENSION(klon)                 :: run_off_lic_0
+    REAL,    DIMENSION(klon)                 :: lic
+    REAL,    DIMENSION(klon)                 :: fder
+
+    REAL,    DIMENSION(klon,nbsrf)           :: qsurf, snsrf
+    REAL,    DIMENSION(klon,nsoilmx,nbsrf)   :: tsoil
+    
+    REAL,    DIMENSION(klon_mpi)             :: tsol_mpi, qsol_mpi, zmasq_mpi, lic_mpi
+    REAL,    DIMENSION(klon_mpi)             :: zmea_mpi, zstd_mpi, zsig_mpi, zgam_mpi, zthe_mpi
+    REAL,    DIMENSION(klon_mpi)             :: cell_area_mpi
+    REAL,    DIMENSION(klon_mpi,nbsrf)       :: pctsrf_mpi
+
+    INCLUDE "compbl.h"
+    INCLUDE "alpale.h"
+   
+    INTEGER :: ji,j,i
+ 
+
+!--- Initial atmospheric CO2 conc. from .def file
+    co2_ppm0 = co2_ppm
+
+    IF (is_omp_master) THEN
+      CALL xios_recv_field("ts",tsol_mpi)
+      CALL xios_recv_field("qs",qsol_mpi)
+      CALL xios_recv_field("mask",zmasq_mpi)
+      IF (landice_opt .LT. 2) CALL xios_recv_field("landice",lic_mpi)
+    ENDIF
+    CALL scatter_omp(tsol_mpi,tsol)
+    CALL scatter_omp(qsol_mpi,qsol)
+    CALL scatter_omp(zmasq_mpi,zmasq)
+    IF (landice_opt .LT. 2) CALL scatter_omp(lic_mpi,lic)
+
+    radsol(:)   = 0.0
+    rugmer(:) = 0.001
+    sn(:)     = 0
+
+    WHERE(qsol(:)<0) qsol(:)=0 
+        
+    WHERE(   zmasq(:)<EPSFRA) zmasq(:)=0.
+    WHERE(1.-zmasq(:)<EPSFRA) zmasq(:)=1.
+
+    pctsrf(:,:) = 0
+    IF (landice_opt .LT. 2) THEN
+       pctsrf(:,is_lic)=lic
+       WHERE(pctsrf(:,is_lic)<EPSFRA) pctsrf(:,is_lic)=0.
+       WHERE(zmasq(:)<EPSFRA)         pctsrf(:,is_lic)=0.
+
+       pctsrf(:,is_ter)=zmasq(:)
+       
+       !--- Adequation with soil/sea mask
+       DO ji=1,klon
+          IF(zmasq(ji)>EPSFRA) THEN 
+             IF(pctsrf(ji,is_lic)>=zmasq(ji)) THEN
+                pctsrf(ji,is_lic)=zmasq(ji)
+                pctsrf(ji,is_ter)=0.
+             ELSE
+                pctsrf(ji,is_ter)=zmasq(ji)-pctsrf(ji,is_lic)
+                IF(pctsrf(ji,is_ter)<EPSFRA) THEN
+                   pctsrf(ji,is_ter)=0.
+                   pctsrf(ji,is_lic)=zmasq(ji)
+                END IF
+             END IF
+          END IF
+       END DO
+   
+    ELSE
+       ! landice_opt=>2 : no land ice
+       pctsrf(:,is_lic)=0.0
+       pctsrf(:,is_ter)=zmasq(:)
+    END IF
+
+
+
+
+
+  !--- Option no_ter_antartique removes all land fractions souther than 60S.
+  !--- Land ice is set instead of the land fractions on these latitudes.
+  !--- The ocean and sea-ice fractions are not changed.
+  !--- This option is only available if landice_opt<2.   
+  IF (landice_opt .LT. 2) THEN
+     no_ter_antartique=.FALSE.
+     CALL getin_p('no_ter_antartique',no_ter_antartique)
+     WRITE(lunout,*)"no_ter_antartique=",no_ter_antartique
+     IF (no_ter_antartique) THEN
+        ! Remove all land fractions souther than 60S and set land-ice instead
+        WRITE(lunout,*) "Remove land fractions souther than 60deg south by increasing"
+        WRITE(lunout,*) "the continental ice fractions. No land can now be found at Antartic."
+        DO ji=1, klon
+           IF (latitude_deg(ji)<-60.0) THEN
+              pctsrf(ji,is_lic) = pctsrf(ji,is_lic) + pctsrf(ji,is_ter)
+              pctsrf(ji,is_ter) = 0
+           END IF
+        END DO
+     END IF
+  END IF
+    
+! sub-surface ocean and sea ice (sea ice set to zero for start)
+!*******************************************************************************
+    pctsrf(:,is_oce)=(1.-zmasq(:))
+    WHERE(pctsrf(:,is_oce)<EPSFRA) pctsrf(:,is_oce)=0.
+    
+!    zval(:)=max(0.,zmea-2*zstd(:))
+!    zpic(:)=zmea+2*zstd(:)
+    
+!! WARNING    DON'T FORGET FOR LATER
+!!ym  IF(couple) pctsrf(:,is_oce)=ocemask_fi(:)
+!! 
+    
+! Init: tsol, qsol, sn, evap, tsoil, rain_fall, snow_fall, solsw, sollw, frugs
+!*******************************************************************************
+    DO i=1,nbsrf
+     ftsol(:,i) = tsol
+    END DO
+  
+    DO i=1,nbsrf
+     snsrf(:,i) = sn
+    END DO
+!albedo SB >>>
+!ym error : the sub surface dimension is the third not second
+!    falb_dir(:,is_ter,:)=0.08; falb_dir(:,is_lic,:)=0.6
+!    falb_dir(:,is_oce,:)=0.5;  falb_dir(:,is_sic,:)=0.6
+    falb_dir(:,:,is_ter)=0.08; falb_dir(:,:,is_lic)=0.6
+    falb_dir(:,:,is_oce)=0.5;  falb_dir(:,:,is_sic)=0.6
+
+!ym falb_dif has been forgotten, initialize with defaukt value found in phyetat0 or 0 ?
+!ym probably the uninitialized value was 0 for standard (regular grid) case
+    falb_dif(:,:,:)=0
+    u10m(:,:)=0  
+    v10m(:,:)=0  
+    treedrg(:,:,:)=0
+!albedo SB <<<
+    fevap(:,:) = 0.
+    qsurf = 0.
+    
+    DO i=1,nbsrf 
+      DO j=1,nsoilmx
+        tsoil(:,j,i) = tsol
+      END DO
+    END DO
+ 
+    rain_fall = 0.; snow_fall = 0.
+    solsw = 165.;   sollw = -53.
+    solswfdiff = 1. 
+!ym warning missing init for sollwdown => set to 0
+  sollwdown  = 0.
+    
+    
+    t_ancien = 273.15
+    u_ancien=0
+    v_ancien=0
+    q_ancien = 0.
+    ql_ancien = 0.
+    qs_ancien = 0.
+    prlw_ancien = 0.
+    prsw_ancien = 0.
+    prw_ancien = 0.
+    agesno = 0.
+    
+    ! LSCP condensation and ice supersaturation
+    cf_ancien = 0.
+    rvc_ancien = 0.
+
+    wake_delta_pbl_TKE(:,:,:)=0
+    wake_dens(:)=0
+    awake_dens = 0.
+    cv_gen = 0.
+    ale_bl = 0.
+    ale_bl_trig =0.
+    alp_bl=0.
+    ale_wake=0.
+    ale_bl_stat=0.
+    
+    z0m(:,:)=0 ! ym missing 5th subsurface initialization
+    z0m(:,is_oce) = rugmer(:)
+    z0m(:,is_ter) = 0.01 ! MAX(1.0e-05,zstd(:)*zsig(:)/2.0)
+    z0m(:,is_lic) = 0.001 !MAX(1.0e-05,zstd(:)*zsig(:)/2.0)
+    z0m(:,is_sic) = 0.001
+    z0h(:,:)=z0m(:,:)
+
+    fder = 0.0
+    clwcon = 0.0
+    rnebcon = 0.0
+    ratqs = 0.0
+    run_off_lic_0 = 0.0 
+    rugoro = 0.0
+
+! Before phyredem calling, surface modules and values to be saved in startphy.nc
+! are initialized
+!*******************************************************************************
+    pbl_tke(:,:,:) = 1.e-8 
+    zmax0(:) = 40.
+    f0(:) = 1.e-5
+    sig1(:,:) = 0.
+    w01(:,:) = 0.
+    wake_deltat(:,:) = 0.
+    wake_deltaq(:,:) = 0.
+    wake_s(:) = 0.
+    wake_cstar(:) = 0.
+    wake_fip(:) = 0.
+    wake_pe = 0.
+    fm_therm = 0.
+    entr_therm = 0.
+    detr_therm = 0.
+    awake_s = 0.
+
+    CALL fonte_neige_init(run_off_lic_0)
+    CALL pbl_surface_init( fder, snsrf, qsurf, tsoil )
+
+    IF (iflag_pbl>1 .AND. iflag_wake>=1  .AND. iflag_pbl_split >=1) then
+     delta_tsurf = 0.
+     beta_aridity = 0.
+    END IF
+    ratqs_inter_ = 0.002
+
+    CALL gather_omp(cell_area,cell_area_mpi)
+    CALL gather_omp(pctsrf,pctsrf_mpi)
+    IF (is_omp_master) THEN
+      CALL xios_send_field("area_ce0l",cell_area_mpi)
+      CALL xios_send_field("fract_oce_ce0l",pctsrf_mpi(:,is_oce))
+      CALL xios_send_field("fract_sic_ce0l",pctsrf_mpi(:,is_sic))
+    ENDIF
+    
+    zmea(:) = zmea_gw(:)
+    zpic(:) = zpic_gw(:)
+    zval(:) = zval_gw(:)
+    zstd(:) = zstd_gw(:)
+    zsig(:) = zsig_gw(:)
+    zgam(:) = zgam_gw(:)
+    zthe(:) = zthe_gw(:)
+    DEALLOCATE(zmea_gw, zpic_gw, zval_gw, zstd_gw, zsig_gw, zgam_gw, zthe_gw)
+
+    CALL phyredem( "startphy.nc" )
+
+  END SUBROUTINE create_etat0_unstruct
+
+
+END MODULE create_etat0_unstruct_mod
Index: DZ6/trunk/libf/phylmd/create_limit_unstruct_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/create_limit_unstruct_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,317 +1,0 @@
-MODULE create_limit_unstruct_mod
-    PRIVATE
-    INTEGER, PARAMETER                             :: lmdep=12
-
-    PUBLIC create_limit_unstruct
-
-CONTAINS
-
-
-  SUBROUTINE create_limit_unstruct
-  USE dimphy
-  USE lmdz_xios
-  USE ioipsl,             ONLY : ioget_year_len
-  USE time_phylmdz_mod, ONLY : annee_ref
-  USE indice_sol_mod
-  USE phys_state_var_mod
-  USE mod_phys_lmdz_para
-  IMPLICIT NONE
-    INCLUDE "iniprint.h"
-    REAL,    DIMENSION(:,:),ALLOCATABLE            :: sic
-    REAL,    DIMENSION(:,:),ALLOCATABLE            :: sst
-    REAL,    DIMENSION(klon,lmdep)                 :: rugos
-    REAL,    DIMENSION(klon,lmdep)                 :: albedo
-    REAL,    DIMENSION(:,:),ALLOCATABLE            :: sic_mpi
-    REAL,    DIMENSION(:,:),ALLOCATABLE            :: sst_mpi
-    REAL,    DIMENSION(klon_mpi,lmdep)             :: rugos_mpi
-    REAL,    DIMENSION(klon_mpi,lmdep)             :: albedo_mpi
-    INTEGER                                        :: ndays
-    REAL                                           :: fi_ice(klon)
-    REAL, ALLOCATABLE                              :: sic_year(:,:)
-    REAL, ALLOCATABLE                              :: sst_year(:,:)
-    REAL, ALLOCATABLE                              :: rugos_year(:,:)
-    REAL, ALLOCATABLE                              :: albedo_year(:,:)
-    REAL, ALLOCATABLE                              :: pctsrf_t(:,:,:)
-    REAL, ALLOCATABLE                              :: phy_bil(:,:)
-    REAL, ALLOCATABLE                              :: sst_year_mpi(:,:)
-    REAL, ALLOCATABLE                              :: rugos_year_mpi(:,:)
-    REAL, ALLOCATABLE                              :: albedo_year_mpi(:,:)
-    REAL, ALLOCATABLE                              :: pctsrf_t_mpi(:,:,:)
-    REAL, ALLOCATABLE                              :: phy_bil_mpi(:,:)
-    INTEGER :: l,k
-    INTEGER :: nbad
-    INTEGER :: sic_time_axis_size 
-    INTEGER :: sst_time_axis_size
-    CHARACTER(LEN=99)                  :: mess            ! error message
-    
-     
-    ndays=ioget_year_len(annee_ref)
-    
-    IF (is_omp_master) CALL xios_get_axis_attr("time_sic",n_glo=sic_time_axis_size)
-    CALL bcast_omp(sic_time_axis_size)
-    ALLOCATE(sic_mpi(klon_mpi,sic_time_axis_size))
-    ALLOCATE(sic(klon,sic_time_axis_size))
-    
-    
-    IF (is_omp_master) CALL xios_get_axis_attr("time_sst",n_glo=sst_time_axis_size)
-    CALL bcast_omp(sst_time_axis_size)
-    ALLOCATE(sst_mpi(klon_mpi,sst_time_axis_size))
-    ALLOCATE(sst(klon,sst_time_axis_size))
-    
-    IF (is_omp_master) THEN
-      CALL xios_recv_field("sic_limit",sic_mpi)
-      CALL xios_recv_field("sst_limit",sst_mpi)
-      CALL xios_recv_field("rugos_limit",rugos_mpi)
-      CALL xios_recv_field("albedo_limit",albedo_mpi)
-    ENDIF
-    CALL scatter_omp(sic_mpi,sic)
-    CALL scatter_omp(sst_mpi,sst)
-    CALL scatter_omp(rugos_mpi,rugos)
-    CALL scatter_omp(albedo_mpi,albedo)
-    
-    ALLOCATE(sic_year(klon,ndays))
-    ALLOCATE(sst_year(klon,ndays))
-    ALLOCATE(rugos_year(klon,ndays))
-    ALLOCATE(albedo_year(klon,ndays))
-    ALLOCATE(pctsrf_t(klon,nbsrf,ndays))
-    ALLOCATE(phy_bil(klon,ndays)); phy_bil=0.0
-
-
-! sic
-    IF (sic_time_axis_size==lmdep) THEN
-      CALL time_interpolation(ndays,sic,'gregorian',sic_year)
-    ELSE IF (sic_time_axis_size==ndays) THEN
-      sic_year=sic
-    ELSE
-      WRITE(mess,*) 'sic time axis is nor montly, nor daily. sic time interpolation ',&
-                    'is requiered but is not currently managed'
-      CALL abort_physic('create_limit_unstruct',TRIM(mess),1)
-    ENDIF
-    
-    sic_year(:,:)=sic_year(:,:)/100.  ! convert percent to fraction
-    WHERE(sic_year(:,:)>1.0) sic_year(:,:)=1.0    ! Some fractions have some time large negative values
-    WHERE(sic_year(:,:)<0.0) sic_year(:,:)=0.0    ! probably better to apply alse this filter before horizontal interpolation
-    
-! sst
-    IF (sst_time_axis_size==lmdep) THEN
-      CALL time_interpolation(ndays,sst,'gregorian',sst_year)
-    ELSE IF (sst_time_axis_size==ndays) THEN
-      sst_year=sst
-    ELSE
-      WRITE(mess,*)'sic time axis is nor montly, nor daily. sic time interpolation ',&
-                   'is requiered but is not currently managed'
-      CALL abort_physic('create_limit_unstruct',TRIM(mess),1)
-    ENDIF
-    WHERE(sst_year(:,:)<271.38) sst_year(:,:)=271.38
-
-
-! rugos    
-    DO l=1, lmdep
-      WHERE(NINT(zmasq(:))/=1) rugos(:,l)=0.001
-    ENDDO
-    CALL time_interpolation(ndays,rugos,'360_day',rugos_year)
-
-! albedo    
-    CALL time_interpolation(ndays,albedo,'360_day',albedo_year)
-
-
-    DO k=1,ndays
-      fi_ice=sic_year(:,k)
-      WHERE(fi_ice>=1.0  ) fi_ice=1.0
-      WHERE(fi_ice<EPSFRA) fi_ice=0.0
-      pctsrf_t(:,is_ter,k)=pctsrf(:,is_ter)       ! land soil
-      pctsrf_t(:,is_lic,k)=pctsrf(:,is_lic)       ! land ice
-
-!!     IF (icefile==trim(fcpldsic)) THEN           ! SIC=pICE*(1-LIC-TER)
-!!        pctsrf_t(:,is_sic,k)=fi_ice(:)*(1.-pctsrf(:,is_lic)-pctsrf(:,is_ter))
-!!     ELSE IF (icefile==trim(fhistsic)) THEN      ! SIC=pICE
-!!        pctsrf_t(:,is_sic,k)=fi_ice(:)
-!!     ELSE ! icefile==famipsic                    ! SIC=pICE-LIC
-        pctsrf_t(:,is_sic,k)=fi_ice-pctsrf_t(:,is_lic,k)
-!     END IF
-      WHERE(pctsrf_t(:,is_sic,k)<=0) pctsrf_t(:,is_sic,k)=0.
-      WHERE(1.0-zmasq<EPSFRA)
-        pctsrf_t(:,is_sic,k)=0.0
-        pctsrf_t(:,is_oce,k)=0.0
-      ELSEWHERE
-        WHERE(pctsrf_t(:,is_sic,k)>=1.0-zmasq)
-          pctsrf_t(:,is_sic,k)=1.0-zmasq
-          pctsrf_t(:,is_oce,k)=0.0
-        ELSEWHERE
-          pctsrf_t(:,is_oce,k)=1.0-zmasq-pctsrf_t(:,is_sic,k)
-          WHERE(pctsrf_t(:,is_oce,k)<EPSFRA)
-             pctsrf_t(:,is_oce,k)=0.0
-             pctsrf_t(:,is_sic,k)=1.0-zmasq
-          END WHERE
-        END WHERE
-      END WHERE
-      nbad=COUNT(pctsrf_t(:,is_oce,k)<0.0)
-      IF(nbad>0) WRITE(lunout,*) 'pb sous maille pour nb point = ',nbad
-      nbad=COUNT(abs(sum(pctsrf_t(:,:,k),dim=2)-1.0)>EPSFRA)
-      IF(nbad>0) WRITE(lunout,*) 'pb sous surface pour nb points = ',nbad
-    END DO
-    
-    ALLOCATE(sst_year_mpi(klon_mpi,ndays))
-    ALLOCATE(rugos_year_mpi(klon_mpi,ndays))
-    ALLOCATE(albedo_year_mpi(klon_mpi,ndays))
-    ALLOCATE(pctsrf_t_mpi(klon_mpi,nbsrf,ndays))
-    ALLOCATE(phy_bil_mpi(klon_mpi,ndays))
-    
-    CALL gather_omp(pctsrf_t   , pctsrf_t_mpi)
-    CALL gather_omp(sst_year   , sst_year_mpi)
-    CALL gather_omp(phy_bil    , phy_bil_mpi)
-    CALL gather_omp(albedo_year, albedo_year_mpi)
-    CALL gather_omp(rugos_year , rugos_year_mpi)
-
-    IF (is_omp_master) THEN
-      CALL xios_send_field("foce_limout",pctsrf_t_mpi(:,is_oce,:))
-      CALL xios_send_field("fsic_limout",pctsrf_t_mpi(:,is_sic,:))
-      CALL xios_send_field("fter_limout",pctsrf_t_mpi(:,is_ter,:))
-      CALL xios_send_field("flic_limout",pctsrf_t_mpi(:,is_lic,:))
-      CALL xios_send_field("sst_limout", sst_year_mpi)
-      CALL xios_send_field("bils_limout",phy_bil_mpi)
-      CALL xios_send_field("alb_limout", albedo_year_mpi) 
-      CALL xios_send_field("rug_limout", rugos_year_mpi) 
-    ENDIF
-  END SUBROUTINE create_limit_unstruct
-  
-  
-  SUBROUTINE time_interpolation(ndays,field_in,calendar,field_out)
-  USE pchsp_95_m, only: pchsp_95
-  USE pchfe_95_m, only: pchfe_95
-  USE arth_m, only: arth
-  USE dimphy, ONLY : klon
-  USE ioipsl,             ONLY : ioget_year_len
-  USE time_phylmdz_mod, ONLY : annee_ref
-  USE mod_phys_lmdz_para
-  IMPLICIT NONE
-   INCLUDE "iniprint.h"
-
-   INTEGER,         INTENT(IN)  :: ndays
-   REAL,            INTENT(IN)  :: field_in(klon,lmdep)
-   CHARACTER(LEN=*),INTENT(IN)  :: calendar
-   REAL,            INTENT(OUT) :: field_out(klon,ndays)
- 
-   INTEGER :: ndays_in
-   REAL    :: timeyear(lmdep)   
-   REAL    :: yder(lmdep)   
-   INTEGER :: ij,ierr, n_extrap
-   LOGICAL :: skip
-
-   CHARACTER (len = 50)         :: modname = 'create_limit_unstruct.time_interpolation'
-   CHARACTER (len = 80)         :: abort_message
-
-  
-   IF (is_omp_master) ndays_in=year_len(annee_ref, calendar)
-   CALL bcast_omp(ndays_in)
-   IF (is_omp_master) timeyear=mid_months(annee_ref, calendar, lmdep)
-   CALL bcast_omp(timeyear)
-    
-   n_extrap = 0
-   skip=.FALSE.
-   DO ij=1,klon
-     yder = pchsp_95(timeyear, field_in(ij, :), ibeg=2, iend=2, vc_beg=0., vc_end=0.)
-     CALL pchfe_95(timeyear, field_in(ij, :), yder, skip, arth(0., real(ndays_in) / ndays, ndays), field_out(ij, :), ierr)
-     if (ierr < 0) then
-        abort_message='error in pchfe_95'
-        CALL abort_physic(modname,abort_message,1)
-     endif
-     n_extrap = n_extrap + ierr
-   END DO
-   
-   IF (n_extrap /= 0) then
-     WRITE(lunout,*) "get_2Dfield pchfe_95: n_extrap = ", n_extrap
-   ENDIF 
-  
-  
-  END SUBROUTINE time_interpolation
-  !-------------------------------------------------------------------------------
-  !
-  FUNCTION year_len(y,cal_in)
-  !
-  !-------------------------------------------------------------------------------
-    USE ioipsl, ONLY : ioget_calendar,ioconf_calendar,lock_calendar,ioget_year_len
-    IMPLICIT NONE
-  !-------------------------------------------------------------------------------
-  ! Arguments:
-    INTEGER                       :: year_len
-    INTEGER,           INTENT(IN) :: y
-    CHARACTER(LEN=*),  INTENT(IN) :: cal_in
-  !-------------------------------------------------------------------------------
-  ! Local variables:
-    CHARACTER(LEN=20)             :: cal_out              ! calendar (for outputs)
-  !-------------------------------------------------------------------------------
-  !--- Getting the input calendar to reset at the end of the function
-    CALL ioget_calendar(cal_out)
-  
-  !--- Unlocking calendar and setting it to wanted one
-    CALL lock_calendar(.FALSE.); CALL ioconf_calendar(TRIM(cal_in))
-  
-  !--- Getting the number of days in this year
-    year_len=ioget_year_len(y)
-  
-  !--- Back to original calendar
-    CALL lock_calendar(.FALSE.); CALL ioconf_calendar(TRIM(cal_out))
-  
-  END FUNCTION year_len
-  !
-  !-------------------------------------------------------------------------------
-  
-  
-  !-------------------------------------------------------------------------------
-  !
-  FUNCTION mid_months(y,cal_in,nm)
-  !
-  !-------------------------------------------------------------------------------
-    USE ioipsl, ONLY : ioget_calendar,ioconf_calendar,lock_calendar,ioget_mon_len
-    IMPLICIT NONE
-  !-------------------------------------------------------------------------------
-  ! Arguments:
-    INTEGER,                INTENT(IN) :: y               ! year
-    CHARACTER(LEN=*),       INTENT(IN) :: cal_in          ! calendar
-    INTEGER,                INTENT(IN) :: nm              ! months/year number
-    REAL,    DIMENSION(nm)             :: mid_months      ! mid-month times
-  !-------------------------------------------------------------------------------
-  ! Local variables:
-    CHARACTER(LEN=99)                  :: mess            ! error message
-    CHARACTER(LEN=20)                  :: cal_out         ! calendar (for outputs)
-    INTEGER, DIMENSION(nm)             :: mnth            ! months lengths (days)
-    INTEGER                            :: m               ! months counter
-    INTEGER                            :: nd              ! number of days
-    INTEGER                            :: k
-  !-------------------------------------------------------------------------------
-    nd=year_len(y,cal_in)
-  
-    IF(nm==12) THEN
-  
-    !--- Getting the input calendar to reset at the end of the function
-      CALL ioget_calendar(cal_out)
-  
-    !--- Unlocking calendar and setting it to wanted one
-      CALL lock_calendar(.FALSE.); CALL ioconf_calendar(TRIM(cal_in))
-  
-    !--- Getting the length of each month
-      DO m=1,nm; mnth(m)=ioget_mon_len(y,m); END DO
-  
-    !--- Back to original calendar
-      CALL lock_calendar(.FALSE.); CALL ioconf_calendar(TRIM(cal_out))
-  
-    ELSE IF(MODULO(nd,nm)/=0) THEN
-      WRITE(mess,'(a,i3,a,i3,a)')'Unconsistent calendar: ',nd,' days/year, but ',&
-        nm,' months/year. Months number should divide days number.'
-      CALL abort_physic('mid_months',TRIM(mess),1)
-  
-    ELSE
-      mnth=(/(m,m=1,nm,nd/nm)/)
-    END IF
-  
-  !--- Mid-months times
-    mid_months(1)=0.5*REAL(mnth(1))
-    DO k=2,nm
-      mid_months(k)=mid_months(k-1)+0.5*REAL(mnth(k-1)+mnth(k))
-    END DO
-  
-  END FUNCTION mid_months
-  
-
-END MODULE create_limit_unstruct_mod
Index: /LMDZ6/trunk/libf/phylmd/create_limit_unstruct_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/create_limit_unstruct_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/create_limit_unstruct_mod.f90	(revision 5268)
@@ -0,0 +1,317 @@
+MODULE create_limit_unstruct_mod
+    PRIVATE
+    INTEGER, PARAMETER                             :: lmdep=12
+
+    PUBLIC create_limit_unstruct
+
+CONTAINS
+
+
+  SUBROUTINE create_limit_unstruct
+  USE dimphy
+  USE lmdz_xios
+  USE ioipsl,             ONLY : ioget_year_len
+  USE time_phylmdz_mod, ONLY : annee_ref
+  USE indice_sol_mod
+  USE phys_state_var_mod
+  USE mod_phys_lmdz_para
+  IMPLICIT NONE
+    INCLUDE "iniprint.h"
+    REAL,    DIMENSION(:,:),ALLOCATABLE            :: sic
+    REAL,    DIMENSION(:,:),ALLOCATABLE            :: sst
+    REAL,    DIMENSION(klon,lmdep)                 :: rugos
+    REAL,    DIMENSION(klon,lmdep)                 :: albedo
+    REAL,    DIMENSION(:,:),ALLOCATABLE            :: sic_mpi
+    REAL,    DIMENSION(:,:),ALLOCATABLE            :: sst_mpi
+    REAL,    DIMENSION(klon_mpi,lmdep)             :: rugos_mpi
+    REAL,    DIMENSION(klon_mpi,lmdep)             :: albedo_mpi
+    INTEGER                                        :: ndays
+    REAL                                           :: fi_ice(klon)
+    REAL, ALLOCATABLE                              :: sic_year(:,:)
+    REAL, ALLOCATABLE                              :: sst_year(:,:)
+    REAL, ALLOCATABLE                              :: rugos_year(:,:)
+    REAL, ALLOCATABLE                              :: albedo_year(:,:)
+    REAL, ALLOCATABLE                              :: pctsrf_t(:,:,:)
+    REAL, ALLOCATABLE                              :: phy_bil(:,:)
+    REAL, ALLOCATABLE                              :: sst_year_mpi(:,:)
+    REAL, ALLOCATABLE                              :: rugos_year_mpi(:,:)
+    REAL, ALLOCATABLE                              :: albedo_year_mpi(:,:)
+    REAL, ALLOCATABLE                              :: pctsrf_t_mpi(:,:,:)
+    REAL, ALLOCATABLE                              :: phy_bil_mpi(:,:)
+    INTEGER :: l,k
+    INTEGER :: nbad
+    INTEGER :: sic_time_axis_size 
+    INTEGER :: sst_time_axis_size
+    CHARACTER(LEN=99)                  :: mess            ! error message
+    
+     
+    ndays=ioget_year_len(annee_ref)
+    
+    IF (is_omp_master) CALL xios_get_axis_attr("time_sic",n_glo=sic_time_axis_size)
+    CALL bcast_omp(sic_time_axis_size)
+    ALLOCATE(sic_mpi(klon_mpi,sic_time_axis_size))
+    ALLOCATE(sic(klon,sic_time_axis_size))
+    
+    
+    IF (is_omp_master) CALL xios_get_axis_attr("time_sst",n_glo=sst_time_axis_size)
+    CALL bcast_omp(sst_time_axis_size)
+    ALLOCATE(sst_mpi(klon_mpi,sst_time_axis_size))
+    ALLOCATE(sst(klon,sst_time_axis_size))
+    
+    IF (is_omp_master) THEN
+      CALL xios_recv_field("sic_limit",sic_mpi)
+      CALL xios_recv_field("sst_limit",sst_mpi)
+      CALL xios_recv_field("rugos_limit",rugos_mpi)
+      CALL xios_recv_field("albedo_limit",albedo_mpi)
+    ENDIF
+    CALL scatter_omp(sic_mpi,sic)
+    CALL scatter_omp(sst_mpi,sst)
+    CALL scatter_omp(rugos_mpi,rugos)
+    CALL scatter_omp(albedo_mpi,albedo)
+    
+    ALLOCATE(sic_year(klon,ndays))
+    ALLOCATE(sst_year(klon,ndays))
+    ALLOCATE(rugos_year(klon,ndays))
+    ALLOCATE(albedo_year(klon,ndays))
+    ALLOCATE(pctsrf_t(klon,nbsrf,ndays))
+    ALLOCATE(phy_bil(klon,ndays)); phy_bil=0.0
+
+
+! sic
+    IF (sic_time_axis_size==lmdep) THEN
+      CALL time_interpolation(ndays,sic,'gregorian',sic_year)
+    ELSE IF (sic_time_axis_size==ndays) THEN
+      sic_year=sic
+    ELSE
+      WRITE(mess,*) 'sic time axis is nor montly, nor daily. sic time interpolation ',&
+                    'is requiered but is not currently managed'
+      CALL abort_physic('create_limit_unstruct',TRIM(mess),1)
+    ENDIF
+    
+    sic_year(:,:)=sic_year(:,:)/100.  ! convert percent to fraction
+    WHERE(sic_year(:,:)>1.0) sic_year(:,:)=1.0    ! Some fractions have some time large negative values
+    WHERE(sic_year(:,:)<0.0) sic_year(:,:)=0.0    ! probably better to apply alse this filter before horizontal interpolation
+    
+! sst
+    IF (sst_time_axis_size==lmdep) THEN
+      CALL time_interpolation(ndays,sst,'gregorian',sst_year)
+    ELSE IF (sst_time_axis_size==ndays) THEN
+      sst_year=sst
+    ELSE
+      WRITE(mess,*)'sic time axis is nor montly, nor daily. sic time interpolation ',&
+                   'is requiered but is not currently managed'
+      CALL abort_physic('create_limit_unstruct',TRIM(mess),1)
+    ENDIF
+    WHERE(sst_year(:,:)<271.38) sst_year(:,:)=271.38
+
+
+! rugos    
+    DO l=1, lmdep
+      WHERE(NINT(zmasq(:))/=1) rugos(:,l)=0.001
+    ENDDO
+    CALL time_interpolation(ndays,rugos,'360_day',rugos_year)
+
+! albedo    
+    CALL time_interpolation(ndays,albedo,'360_day',albedo_year)
+
+
+    DO k=1,ndays
+      fi_ice=sic_year(:,k)
+      WHERE(fi_ice>=1.0  ) fi_ice=1.0
+      WHERE(fi_ice<EPSFRA) fi_ice=0.0
+      pctsrf_t(:,is_ter,k)=pctsrf(:,is_ter)       ! land soil
+      pctsrf_t(:,is_lic,k)=pctsrf(:,is_lic)       ! land ice
+
+!!     IF (icefile==trim(fcpldsic)) THEN           ! SIC=pICE*(1-LIC-TER)
+!!        pctsrf_t(:,is_sic,k)=fi_ice(:)*(1.-pctsrf(:,is_lic)-pctsrf(:,is_ter))
+!!     ELSE IF (icefile==trim(fhistsic)) THEN      ! SIC=pICE
+!!        pctsrf_t(:,is_sic,k)=fi_ice(:)
+!!     ELSE ! icefile==famipsic                    ! SIC=pICE-LIC
+        pctsrf_t(:,is_sic,k)=fi_ice-pctsrf_t(:,is_lic,k)
+!     END IF
+      WHERE(pctsrf_t(:,is_sic,k)<=0) pctsrf_t(:,is_sic,k)=0.
+      WHERE(1.0-zmasq<EPSFRA)
+        pctsrf_t(:,is_sic,k)=0.0
+        pctsrf_t(:,is_oce,k)=0.0
+      ELSEWHERE
+        WHERE(pctsrf_t(:,is_sic,k)>=1.0-zmasq)
+          pctsrf_t(:,is_sic,k)=1.0-zmasq
+          pctsrf_t(:,is_oce,k)=0.0
+        ELSEWHERE
+          pctsrf_t(:,is_oce,k)=1.0-zmasq-pctsrf_t(:,is_sic,k)
+          WHERE(pctsrf_t(:,is_oce,k)<EPSFRA)
+             pctsrf_t(:,is_oce,k)=0.0
+             pctsrf_t(:,is_sic,k)=1.0-zmasq
+          END WHERE
+        END WHERE
+      END WHERE
+      nbad=COUNT(pctsrf_t(:,is_oce,k)<0.0)
+      IF(nbad>0) WRITE(lunout,*) 'pb sous maille pour nb point = ',nbad
+      nbad=COUNT(abs(sum(pctsrf_t(:,:,k),dim=2)-1.0)>EPSFRA)
+      IF(nbad>0) WRITE(lunout,*) 'pb sous surface pour nb points = ',nbad
+    END DO
+    
+    ALLOCATE(sst_year_mpi(klon_mpi,ndays))
+    ALLOCATE(rugos_year_mpi(klon_mpi,ndays))
+    ALLOCATE(albedo_year_mpi(klon_mpi,ndays))
+    ALLOCATE(pctsrf_t_mpi(klon_mpi,nbsrf,ndays))
+    ALLOCATE(phy_bil_mpi(klon_mpi,ndays))
+    
+    CALL gather_omp(pctsrf_t   , pctsrf_t_mpi)
+    CALL gather_omp(sst_year   , sst_year_mpi)
+    CALL gather_omp(phy_bil    , phy_bil_mpi)
+    CALL gather_omp(albedo_year, albedo_year_mpi)
+    CALL gather_omp(rugos_year , rugos_year_mpi)
+
+    IF (is_omp_master) THEN
+      CALL xios_send_field("foce_limout",pctsrf_t_mpi(:,is_oce,:))
+      CALL xios_send_field("fsic_limout",pctsrf_t_mpi(:,is_sic,:))
+      CALL xios_send_field("fter_limout",pctsrf_t_mpi(:,is_ter,:))
+      CALL xios_send_field("flic_limout",pctsrf_t_mpi(:,is_lic,:))
+      CALL xios_send_field("sst_limout", sst_year_mpi)
+      CALL xios_send_field("bils_limout",phy_bil_mpi)
+      CALL xios_send_field("alb_limout", albedo_year_mpi) 
+      CALL xios_send_field("rug_limout", rugos_year_mpi) 
+    ENDIF
+  END SUBROUTINE create_limit_unstruct
+  
+  
+  SUBROUTINE time_interpolation(ndays,field_in,calendar,field_out)
+  USE pchsp_95_m, only: pchsp_95
+  USE pchfe_95_m, only: pchfe_95
+  USE arth_m, only: arth
+  USE dimphy, ONLY : klon
+  USE ioipsl,             ONLY : ioget_year_len
+  USE time_phylmdz_mod, ONLY : annee_ref
+  USE mod_phys_lmdz_para
+  IMPLICIT NONE
+   INCLUDE "iniprint.h"
+
+   INTEGER,         INTENT(IN)  :: ndays
+   REAL,            INTENT(IN)  :: field_in(klon,lmdep)
+   CHARACTER(LEN=*),INTENT(IN)  :: calendar
+   REAL,            INTENT(OUT) :: field_out(klon,ndays)
+ 
+   INTEGER :: ndays_in
+   REAL    :: timeyear(lmdep)   
+   REAL    :: yder(lmdep)   
+   INTEGER :: ij,ierr, n_extrap
+   LOGICAL :: skip
+
+   CHARACTER (len = 50)         :: modname = 'create_limit_unstruct.time_interpolation'
+   CHARACTER (len = 80)         :: abort_message
+
+  
+   IF (is_omp_master) ndays_in=year_len(annee_ref, calendar)
+   CALL bcast_omp(ndays_in)
+   IF (is_omp_master) timeyear=mid_months(annee_ref, calendar, lmdep)
+   CALL bcast_omp(timeyear)
+    
+   n_extrap = 0
+   skip=.FALSE.
+   DO ij=1,klon
+     yder = pchsp_95(timeyear, field_in(ij, :), ibeg=2, iend=2, vc_beg=0., vc_end=0.)
+     CALL pchfe_95(timeyear, field_in(ij, :), yder, skip, arth(0., real(ndays_in) / ndays, ndays), field_out(ij, :), ierr)
+     if (ierr < 0) then
+        abort_message='error in pchfe_95'
+        CALL abort_physic(modname,abort_message,1)
+     endif
+     n_extrap = n_extrap + ierr
+   END DO
+   
+   IF (n_extrap /= 0) then
+     WRITE(lunout,*) "get_2Dfield pchfe_95: n_extrap = ", n_extrap
+   ENDIF 
+  
+  
+  END SUBROUTINE time_interpolation
+  !-------------------------------------------------------------------------------
+  !
+  FUNCTION year_len(y,cal_in)
+  !
+  !-------------------------------------------------------------------------------
+    USE ioipsl, ONLY : ioget_calendar,ioconf_calendar,lock_calendar,ioget_year_len
+    IMPLICIT NONE
+  !-------------------------------------------------------------------------------
+  ! Arguments:
+    INTEGER                       :: year_len
+    INTEGER,           INTENT(IN) :: y
+    CHARACTER(LEN=*),  INTENT(IN) :: cal_in
+  !-------------------------------------------------------------------------------
+  ! Local variables:
+    CHARACTER(LEN=20)             :: cal_out              ! calendar (for outputs)
+  !-------------------------------------------------------------------------------
+  !--- Getting the input calendar to reset at the end of the function
+    CALL ioget_calendar(cal_out)
+  
+  !--- Unlocking calendar and setting it to wanted one
+    CALL lock_calendar(.FALSE.); CALL ioconf_calendar(TRIM(cal_in))
+  
+  !--- Getting the number of days in this year
+    year_len=ioget_year_len(y)
+  
+  !--- Back to original calendar
+    CALL lock_calendar(.FALSE.); CALL ioconf_calendar(TRIM(cal_out))
+  
+  END FUNCTION year_len
+  !
+  !-------------------------------------------------------------------------------
+  
+  
+  !-------------------------------------------------------------------------------
+  !
+  FUNCTION mid_months(y,cal_in,nm)
+  !
+  !-------------------------------------------------------------------------------
+    USE ioipsl, ONLY : ioget_calendar,ioconf_calendar,lock_calendar,ioget_mon_len
+    IMPLICIT NONE
+  !-------------------------------------------------------------------------------
+  ! Arguments:
+    INTEGER,                INTENT(IN) :: y               ! year
+    CHARACTER(LEN=*),       INTENT(IN) :: cal_in          ! calendar
+    INTEGER,                INTENT(IN) :: nm              ! months/year number
+    REAL,    DIMENSION(nm)             :: mid_months      ! mid-month times
+  !-------------------------------------------------------------------------------
+  ! Local variables:
+    CHARACTER(LEN=99)                  :: mess            ! error message
+    CHARACTER(LEN=20)                  :: cal_out         ! calendar (for outputs)
+    INTEGER, DIMENSION(nm)             :: mnth            ! months lengths (days)
+    INTEGER                            :: m               ! months counter
+    INTEGER                            :: nd              ! number of days
+    INTEGER                            :: k
+  !-------------------------------------------------------------------------------
+    nd=year_len(y,cal_in)
+  
+    IF(nm==12) THEN
+  
+    !--- Getting the input calendar to reset at the end of the function
+      CALL ioget_calendar(cal_out)
+  
+    !--- Unlocking calendar and setting it to wanted one
+      CALL lock_calendar(.FALSE.); CALL ioconf_calendar(TRIM(cal_in))
+  
+    !--- Getting the length of each month
+      DO m=1,nm; mnth(m)=ioget_mon_len(y,m); END DO
+  
+    !--- Back to original calendar
+      CALL lock_calendar(.FALSE.); CALL ioconf_calendar(TRIM(cal_out))
+  
+    ELSE IF(MODULO(nd,nm)/=0) THEN
+      WRITE(mess,'(a,i3,a,i3,a)')'Unconsistent calendar: ',nd,' days/year, but ',&
+        nm,' months/year. Months number should divide days number.'
+      CALL abort_physic('mid_months',TRIM(mess),1)
+  
+    ELSE
+      mnth=(/(m,m=1,nm,nd/nm)/)
+    END IF
+  
+  !--- Mid-months times
+    mid_months(1)=0.5*REAL(mnth(1))
+    DO k=2,nm
+      mid_months(k)=mid_months(k-1)+0.5*REAL(mnth(k-1)+mnth(k))
+    END DO
+  
+  END FUNCTION mid_months
+  
+
+END MODULE create_limit_unstruct_mod
Index: DZ6/trunk/libf/phylmd/ctstar.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/ctstar.F90	(revision 5267)
+++ 	(revision )
@@ -1,128 +1,0 @@
-SUBROUTINE CTSTAR(KPROMA,KSTART,KPROF,PTB,PRESBH,PRESBF,POROG,PTSTAR,PT0)
-
-!**** *CTSTAR* - COMPUTES STANDARD SURFACE TEMPERATURE
-!                              AND SURFACE TEMPERATURE.
-
-!     PURPOSE.
-!     --------
-
-!           COMPUTES THE STANDARD SURFACE TEMPERATURE AND THE SURFACE
-!           TEMPERATURE TO BE USED FOR EXTRAPOLATIONS OF TEMPERATURE
-!           AND GEOPOTENTIEL.
-
-!**   INTERFACE.
-!     ----------
-!        *CALL* *CTSTAR(..)*
-
-!        EXPLICIT ARGUMENTS
-!        --------------------
-
-!        KPROMA         - HORIZONTAL DIMENSIONS.             (INPUT)
-!        KSTART         - START OF WORK                      (INPUT)
-!        KPROF          - DEPTH OF WORK                      (INPUT)
-
-!        PTB(KPROMA)    - TEMPERATURE AT NFLEVG-1             (INPUT)
-!        PRESBH(KPROMA) - LOWEST MODEL HALF LEVEL PRESSURES  (INPUT)
-
-!        PRESBF(KPROMA) - PRESSURE AT NFLEVG-1                (INPUT)
-!        POROG(KPROMA)  - MODEL ORGRAPHY                     (INPUT)
-
-
-!        PTSTAR(KPROMA) - SURFACE TEMPERATURE                (OUTPUT)
-
-!        PT0(KPROMA)    - STANDARD SURFACE TEMPERATURE       (OUTPUT)
-
-!        IMPLICIT ARGUMENTS :    CONSTANTS FROM YOMSTA,YOMCST.
-!        --------------------
-
-!     METHOD.
-!     -------
-!        SEE DOCUMENTATION
-
-!     EXTERNALS.   NONE.
-!     ----------
-
-!     REFERENCE.
-!     ----------
-!        ECMWF Research Department documentation of the IFS
-
-!     AUTHOR.
-!     -------
-!        MATS HAMRUD AND PHILIPPE COURTIER  *ECMWF*
-
-!     MODIFICATIONS.
-!     --------------
-!        ORIGINAL : 89-05-02
-
-!      Modification : 93-06-01 M.Hamrud (Comment only, now T from NFLEVG-1)
-!        M.Hamrud      01-Oct-2003 CY28 Cleaning
-
-!     ------------------------------------------------------------------
-
-!USE PARKIND1 
-!<http://intra.cnrm.meteo.fr/eac/ARPCLI5.2/doci/code/arpcli5.2/xrd/module/parkind1.F90.php#parkind1>  ,ONLY : JPIM     ,JPRB
-!USE YOMHOOK 
-!<http://intra.cnrm.meteo.fr/eac/ARPCLI5.2/doci/code/arpcli5.2/xrd/module/yomhook.F90.php#yomhook>   ,ONLY : LHOOK,   DR_HOOK
-
-!USE YOMCST, ONLY : RG, RD 
-!<http://intra.cnrm.meteo.fr/eac/ARPCLI5.2/doci/code/arpcli5.2/arp/module/yomcst.F90.php#yomcst>   , ONLY :  RG
-
-!<http://intra.cnrm.meteo.fr/eac/ARPCLI5.2/doci/code/arpcli5.2/xrd/support/rg.F.php#rg>       ,RD
-!USE YOMSTA 
-!<http://intra.cnrm.meteo.fr/eac/ARPCLI5.2/doci/code/arpcli5.2/arp/module/yomsta.F90.php#yomsta>   , ONLY : RDTDZ1
-
-IMPLICIT NONE
-
-include "YOMCST.h"
-!IM INTEGER(KIND=JPIM),INTENT(IN)    :: KPROMA
-!IM INTEGER(KIND=JPIM),INTENT(IN)    :: KSTART
-!IM INTEGER(KIND=JPIM),INTENT(IN)    :: KPROF
-INTEGER,INTENT(IN)    :: KPROMA
-INTEGER,INTENT(IN)    :: KSTART
-INTEGER,INTENT(IN)    :: KPROF
-!IM REAL(KIND=JPRB)   ,INTENT(IN)    :: PTB(KPROMA)
-REAL   ,INTENT(IN)    :: PTB(KPROMA)
-!IM REAL(KIND=JPRB)   ,INTENT(IN)    :: PRESBH(KPROMA)
-REAL   ,INTENT(IN)    :: PRESBH(KPROMA)
-!IM REAL(KIND=JPRB)   ,INTENT(IN)    :: PRESBF(KPROMA)
-REAL   ,INTENT(IN)    :: PRESBF(KPROMA)
-!IM REAL(KIND=JPRB)   ,INTENT(IN)    :: POROG(KPROMA)
-REAL   ,INTENT(IN)    :: POROG(KPROMA)
-!IM REAL(KIND=JPRB)   ,INTENT(OUT)   :: PTSTAR(KPROMA)
-REAL   ,INTENT(OUT)   :: PTSTAR(KPROMA)
-!IM REAL(KIND=JPRB)   ,INTENT(OUT)   :: PT0(KPROMA)
-REAL   ,INTENT(OUT)   :: PT0(KPROMA)
-!IM INTEGER(KIND=JPIM) :: JL
-INTEGER :: JL
-
-!IM REAL(KIND=JPRB) :: ZALPHA, ZDTDZSG
-REAL :: ZALPHA, ZDTDZSG
-!IM REAL(KIND=JPRB) :: ZHOOK_HANDLE
-REAL :: ZHOOK_HANDLE
-!IM beg
-REAL, PARAMETER                  :: RDTDZ1=-0.0065 !or USE YOMSTA
-!IM end
-
-!     ------------------------------------------------------------------
-
-!*       1.    COMPUTES SURFACE TEMPERATURE
-!*             THEN STANDARD SURFACE TEMPERATURE.
-
-!IF (LHOOK) CALL DR_HOOK('CTSTAR',0,ZHOOK_HANDLE)
-ZDTDZSG=-RDTDZ1/RG 
-!<http://intra.cnrm.meteo.fr/eac/ARPCLI5.2/doci/code/arpcli5.2/xrd/support/rg.F.php#rg>
-ZALPHA=ZDTDZSG*RD
-DO JL=KSTART,KPROF
-
-   !IM PTSTAR(JL)=PTB(JL)*(1.0_JPRB+ZALPHA*(PRESBH(JL)/PRESBF(JL)-1.0_JPRB))
-   PTSTAR(JL)=PTB(JL)*(1.0+ZALPHA*(PRESBH(JL)/PRESBF(JL)-1.0))
-   PT0(JL)=PTSTAR(JL)+ZDTDZSG*POROG(JL)
-!  print*,'cstar JL ptb zalpha PRESBH PRESBF ptstar' &
-!  ,JL,PTB(JL),ZALPHA,PRESBH(JL),PRESBF(JL),PTSTAR(JL)
-ENDDO
-
-
-!     ------------------------------------------------------------------
-
-!IF (LHOOK) CALL DR_HOOK('CTSTAR',1,ZHOOK_HANDLE)
-END SUBROUTINE CTSTAR
Index: /LMDZ6/trunk/libf/phylmd/ctstar.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/ctstar.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/ctstar.f90	(revision 5268)
@@ -0,0 +1,128 @@
+SUBROUTINE CTSTAR(KPROMA,KSTART,KPROF,PTB,PRESBH,PRESBF,POROG,PTSTAR,PT0)
+
+!**** *CTSTAR* - COMPUTES STANDARD SURFACE TEMPERATURE
+!                              AND SURFACE TEMPERATURE.
+
+!     PURPOSE.
+!     --------
+
+!           COMPUTES THE STANDARD SURFACE TEMPERATURE AND THE SURFACE
+!           TEMPERATURE TO BE USED FOR EXTRAPOLATIONS OF TEMPERATURE
+!           AND GEOPOTENTIEL.
+
+!**   INTERFACE.
+!     ----------
+!        *CALL* *CTSTAR(..)*
+
+!        EXPLICIT ARGUMENTS
+!        --------------------
+
+!        KPROMA         - HORIZONTAL DIMENSIONS.             (INPUT)
+!        KSTART         - START OF WORK                      (INPUT)
+!        KPROF          - DEPTH OF WORK                      (INPUT)
+
+!        PTB(KPROMA)    - TEMPERATURE AT NFLEVG-1             (INPUT)
+!        PRESBH(KPROMA) - LOWEST MODEL HALF LEVEL PRESSURES  (INPUT)
+
+!        PRESBF(KPROMA) - PRESSURE AT NFLEVG-1                (INPUT)
+!        POROG(KPROMA)  - MODEL ORGRAPHY                     (INPUT)
+
+
+!        PTSTAR(KPROMA) - SURFACE TEMPERATURE                (OUTPUT)
+
+!        PT0(KPROMA)    - STANDARD SURFACE TEMPERATURE       (OUTPUT)
+
+!        IMPLICIT ARGUMENTS :    CONSTANTS FROM YOMSTA,YOMCST.
+!        --------------------
+
+!     METHOD.
+!     -------
+!        SEE DOCUMENTATION
+
+!     EXTERNALS.   NONE.
+!     ----------
+
+!     REFERENCE.
+!     ----------
+!        ECMWF Research Department documentation of the IFS
+
+!     AUTHOR.
+!     -------
+!        MATS HAMRUD AND PHILIPPE COURTIER  *ECMWF*
+
+!     MODIFICATIONS.
+!     --------------
+!        ORIGINAL : 89-05-02
+
+!      Modification : 93-06-01 M.Hamrud (Comment only, now T from NFLEVG-1)
+!        M.Hamrud      01-Oct-2003 CY28 Cleaning
+
+!     ------------------------------------------------------------------
+
+!USE PARKIND1 
+!<http://intra.cnrm.meteo.fr/eac/ARPCLI5.2/doci/code/arpcli5.2/xrd/module/parkind1.F90.php#parkind1>  ,ONLY : JPIM     ,JPRB
+!USE YOMHOOK 
+!<http://intra.cnrm.meteo.fr/eac/ARPCLI5.2/doci/code/arpcli5.2/xrd/module/yomhook.F90.php#yomhook>   ,ONLY : LHOOK,   DR_HOOK
+
+!USE YOMCST, ONLY : RG, RD 
+!<http://intra.cnrm.meteo.fr/eac/ARPCLI5.2/doci/code/arpcli5.2/arp/module/yomcst.F90.php#yomcst>   , ONLY :  RG
+
+!<http://intra.cnrm.meteo.fr/eac/ARPCLI5.2/doci/code/arpcli5.2/xrd/support/rg.F.php#rg>       ,RD
+!USE YOMSTA 
+!<http://intra.cnrm.meteo.fr/eac/ARPCLI5.2/doci/code/arpcli5.2/arp/module/yomsta.F90.php#yomsta>   , ONLY : RDTDZ1
+
+IMPLICIT NONE
+
+include "YOMCST.h"
+!IM INTEGER(KIND=JPIM),INTENT(IN)    :: KPROMA
+!IM INTEGER(KIND=JPIM),INTENT(IN)    :: KSTART
+!IM INTEGER(KIND=JPIM),INTENT(IN)    :: KPROF
+INTEGER,INTENT(IN)    :: KPROMA
+INTEGER,INTENT(IN)    :: KSTART
+INTEGER,INTENT(IN)    :: KPROF
+!IM REAL(KIND=JPRB)   ,INTENT(IN)    :: PTB(KPROMA)
+REAL   ,INTENT(IN)    :: PTB(KPROMA)
+!IM REAL(KIND=JPRB)   ,INTENT(IN)    :: PRESBH(KPROMA)
+REAL   ,INTENT(IN)    :: PRESBH(KPROMA)
+!IM REAL(KIND=JPRB)   ,INTENT(IN)    :: PRESBF(KPROMA)
+REAL   ,INTENT(IN)    :: PRESBF(KPROMA)
+!IM REAL(KIND=JPRB)   ,INTENT(IN)    :: POROG(KPROMA)
+REAL   ,INTENT(IN)    :: POROG(KPROMA)
+!IM REAL(KIND=JPRB)   ,INTENT(OUT)   :: PTSTAR(KPROMA)
+REAL   ,INTENT(OUT)   :: PTSTAR(KPROMA)
+!IM REAL(KIND=JPRB)   ,INTENT(OUT)   :: PT0(KPROMA)
+REAL   ,INTENT(OUT)   :: PT0(KPROMA)
+!IM INTEGER(KIND=JPIM) :: JL
+INTEGER :: JL
+
+!IM REAL(KIND=JPRB) :: ZALPHA, ZDTDZSG
+REAL :: ZALPHA, ZDTDZSG
+!IM REAL(KIND=JPRB) :: ZHOOK_HANDLE
+REAL :: ZHOOK_HANDLE
+!IM beg
+REAL, PARAMETER                  :: RDTDZ1=-0.0065 !or USE YOMSTA
+!IM end
+
+!     ------------------------------------------------------------------
+
+!*       1.    COMPUTES SURFACE TEMPERATURE
+!*             THEN STANDARD SURFACE TEMPERATURE.
+
+!IF (LHOOK) CALL DR_HOOK('CTSTAR',0,ZHOOK_HANDLE)
+ZDTDZSG=-RDTDZ1/RG 
+!<http://intra.cnrm.meteo.fr/eac/ARPCLI5.2/doci/code/arpcli5.2/xrd/support/rg.F.php#rg>
+ZALPHA=ZDTDZSG*RD
+DO JL=KSTART,KPROF
+
+   !IM PTSTAR(JL)=PTB(JL)*(1.0_JPRB+ZALPHA*(PRESBH(JL)/PRESBF(JL)-1.0_JPRB))
+   PTSTAR(JL)=PTB(JL)*(1.0+ZALPHA*(PRESBH(JL)/PRESBF(JL)-1.0))
+   PT0(JL)=PTSTAR(JL)+ZDTDZSG*POROG(JL)
+!  print*,'cstar JL ptb zalpha PRESBH PRESBF ptstar' &
+!  ,JL,PTB(JL),ZALPHA,PRESBH(JL),PRESBF(JL),PTSTAR(JL)
+ENDDO
+
+
+!     ------------------------------------------------------------------
+
+!IF (LHOOK) CALL DR_HOOK('CTSTAR',1,ZHOOK_HANDLE)
+END SUBROUTINE CTSTAR
Index: DZ6/trunk/libf/phylmd/cv30_routines.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cv30_routines.F90	(revision 5267)
+++ 	(revision )
@@ -1,3360 +1,0 @@
-
-! $Id$
-
-
-
-SUBROUTINE cv30_param(nd, delt)
-  IMPLICIT NONE
-
-  ! ------------------------------------------------------------
-  ! Set parameters for convectL for iflag_con = 3
-  ! ------------------------------------------------------------
-
-
-  ! ***  PBCRIT IS THE CRITICAL CLOUD DEPTH (MB) BENEATH WHICH THE ***
-  ! ***      PRECIPITATION EFFICIENCY IS ASSUMED TO BE ZERO     ***
-  ! ***  PTCRIT IS THE CLOUD DEPTH (MB) ABOVE WHICH THE PRECIP. ***
-  ! ***            EFFICIENCY IS ASSUMED TO BE UNITY            ***
-  ! ***  SIGD IS THE FRACTIONAL AREA COVERED BY UNSATURATED DNDRAFT  ***
-  ! ***  SPFAC IS THE FRACTION OF PRECIPITATION FALLING OUTSIDE ***
-  ! ***                        OF CLOUD                         ***
-
-  ! [TAU: CHARACTERISTIC TIMESCALE USED TO COMPUTE ALPHA & BETA]
-  ! ***    ALPHA AND BETA ARE PARAMETERS THAT CONTROL THE RATE OF ***
-  ! ***                 APPROACH TO QUASI-EQUILIBRIUM           ***
-  ! ***    (THEIR STANDARD VALUES ARE 1.0 AND 0.96, RESPECTIVELY) ***
-  ! ***           (BETA MUST BE LESS THAN OR EQUAL TO 1)        ***
-
-  ! ***    DTCRIT IS THE CRITICAL BUOYANCY (K) USED TO ADJUST THE ***
-  ! ***                 APPROACH TO QUASI-EQUILIBRIUM           ***
-  ! ***                     IT MUST BE LESS THAN 0              ***
-
-  include "cv30param.h"
-  include "conema3.h"
-
-  INTEGER nd
-  REAL delt ! timestep (seconds)
-
-  ! noff: integer limit for convection (nd-noff)
-  ! minorig: First level of convection
-
-  ! -- limit levels for convection:
-
-  noff = 1
-  minorig = 1
-  nl = nd - noff
-  nlp = nl + 1
-  nlm = nl - 1
-
-  ! -- "microphysical" parameters:
-
-  sigd = 0.01
-  spfac = 0.15
-  pbcrit = 150.0
-  ptcrit = 500.0
-  ! IM cf. FH     epmax  = 0.993
-
-  omtrain = 45.0 ! used also for snow (no disctinction rain/snow)
-
-  ! -- misc:
-
-  dtovsh = -0.2 ! dT for overshoot
-  dpbase = -40. ! definition cloud base (400m above LCL)
-  dttrig = 5. ! (loose) condition for triggering
-
-  ! -- rate of approach to quasi-equilibrium:
-
-  dtcrit = -2.0
-  tau = 8000.
-  beta = 1.0 - delt/tau
-  alpha = 1.5E-3*delt/tau
-  ! increase alpha to compensate W decrease:
-  alpha = alpha*1.5
-
-  ! -- interface cloud parameterization:
-
-  delta = 0.01 ! cld
-
-  ! -- interface with boundary-layer (gust factor): (sb)
-
-  betad = 10.0 ! original value (from convect 4.3)
-
-  RETURN
-END SUBROUTINE cv30_param
-
-SUBROUTINE cv30_prelim(len, nd, ndp1, t, q, p, ph, lv, cpn, tv, gz, h, hm, &
-    th)
-  IMPLICIT NONE
-
-  ! =====================================================================
-  ! --- CALCULATE ARRAYS OF GEOPOTENTIAL, HEAT CAPACITY & STATIC ENERGY
-  ! "ori": from convect4.3 (vectorized)
-  ! "convect3": to be exactly consistent with convect3
-  ! =====================================================================
-
-  ! inputs:
-  INTEGER len, nd, ndp1
-  REAL t(len, nd), q(len, nd), p(len, nd), ph(len, ndp1)
-
-  ! outputs:
-  REAL lv(len, nd), cpn(len, nd), tv(len, nd)
-  REAL gz(len, nd), h(len, nd), hm(len, nd)
-  REAL th(len, nd)
-
-  ! local variables:
-  INTEGER k, i
-  REAL rdcp
-  REAL tvx, tvy ! convect3
-  REAL cpx(len, nd)
-
-  include "cvthermo.h"
-  include "cv30param.h"
-
-
-  ! ori      do 110 k=1,nlp
-  DO k = 1, nl ! convect3
-    DO i = 1, len
-      ! debug          lv(i,k)= lv0-clmcpv*(t(i,k)-t0)
-      lv(i, k) = lv0 - clmcpv*(t(i,k)-273.15)
-      cpn(i, k) = cpd*(1.0-q(i,k)) + cpv*q(i, k)
-      cpx(i, k) = cpd*(1.0-q(i,k)) + cl*q(i, k)
-      ! ori          tv(i,k)=t(i,k)*(1.0+q(i,k)*epsim1)
-      tv(i, k) = t(i, k)*(1.0+q(i,k)/eps-q(i,k))
-      rdcp = (rrd*(1.-q(i,k))+q(i,k)*rrv)/cpn(i, k)
-      th(i, k) = t(i, k)*(1000.0/p(i,k))**rdcp
-    END DO
-  END DO
-
-  ! gz = phi at the full levels (same as p).
-
-  DO i = 1, len
-    gz(i, 1) = 0.0
-  END DO
-  ! ori      do 140 k=2,nlp
-  DO k = 2, nl ! convect3
-    DO i = 1, len
-      tvx = t(i, k)*(1.+q(i,k)/eps-q(i,k)) !convect3
-      tvy = t(i, k-1)*(1.+q(i,k-1)/eps-q(i,k-1)) !convect3
-      gz(i, k) = gz(i, k-1) + 0.5*rrd*(tvx+tvy) & !convect3
-        *(p(i,k-1)-p(i,k))/ph(i, k) !convect3
-
-      ! ori         gz(i,k)=gz(i,k-1)+hrd*(tv(i,k-1)+tv(i,k))
-      ! ori    &         *(p(i,k-1)-p(i,k))/ph(i,k)
-    END DO
-  END DO
-
-  ! h  = phi + cpT (dry static energy).
-  ! hm = phi + cp(T-Tbase)+Lq
-
-  ! ori      do 170 k=1,nlp
-  DO k = 1, nl ! convect3
-    DO i = 1, len
-      h(i, k) = gz(i, k) + cpn(i, k)*t(i, k)
-      hm(i, k) = gz(i, k) + cpx(i, k)*(t(i,k)-t(i,1)) + lv(i, k)*q(i, k)
-    END DO
-  END DO
-
-  RETURN
-END SUBROUTINE cv30_prelim
-
-SUBROUTINE cv30_feed(len, nd, t, q, qs, p, ph, hm, gz, nk, icb, icbmax, &
-    iflag, tnk, qnk, gznk, plcl)
-  IMPLICIT NONE
-
-  ! ================================================================
-  ! Purpose: CONVECTIVE FEED
-
-  ! Main differences with cv_feed:
-  ! - ph added in input
-  ! - here, nk(i)=minorig
-  ! - icb defined differently (plcl compared with ph instead of p)
-
-  ! Main differences with convect3:
-  ! - we do not compute dplcldt and dplcldr of CLIFT anymore
-  ! - values iflag different (but tests identical)
-  ! - A,B explicitely defined (!...)
-  ! ================================================================
-
-  include "cv30param.h"
-
-  ! inputs:
-  INTEGER len, nd
-  REAL t(len, nd), q(len, nd), qs(len, nd), p(len, nd)
-  REAL hm(len, nd), gz(len, nd)
-  REAL ph(len, nd+1)
-
-  ! outputs:
-  INTEGER iflag(len), nk(len), icb(len), icbmax
-  REAL tnk(len), qnk(len), gznk(len), plcl(len)
-
-  ! local variables:
-  INTEGER i, k
-  INTEGER ihmin(len)
-  REAL work(len)
-  REAL pnk(len), qsnk(len), rh(len), chi(len)
-  REAL a, b ! convect3
-  ! ym
-  plcl = 0.0
-  ! @ !-------------------------------------------------------------------
-  ! @ ! --- Find level of minimum moist static energy
-  ! @ ! --- If level of minimum moist static energy coincides with
-  ! @ ! --- or is lower than minimum allowable parcel origin level,
-  ! @ ! --- set iflag to 6.
-  ! @ !-------------------------------------------------------------------
-  ! @
-  ! @       do 180 i=1,len
-  ! @        work(i)=1.0e12
-  ! @        ihmin(i)=nl
-  ! @  180  continue
-  ! @       do 200 k=2,nlp
-  ! @         do 190 i=1,len
-  ! @          if((hm(i,k).lt.work(i)).and.
-  ! @      &      (hm(i,k).lt.hm(i,k-1)))then
-  ! @            work(i)=hm(i,k)
-  ! @            ihmin(i)=k
-  ! @          endif
-  ! @  190    continue
-  ! @  200  continue
-  ! @       do 210 i=1,len
-  ! @         ihmin(i)=min(ihmin(i),nlm)
-  ! @         if(ihmin(i).le.minorig)then
-  ! @           iflag(i)=6
-  ! @         endif
-  ! @  210  continue
-  ! @ c
-  ! @ !-------------------------------------------------------------------
-  ! @ ! --- Find that model level below the level of minimum moist static
-  ! @ ! --- energy that has the maximum value of moist static energy
-  ! @ !-------------------------------------------------------------------
-  ! @
-  ! @       do 220 i=1,len
-  ! @        work(i)=hm(i,minorig)
-  ! @        nk(i)=minorig
-  ! @  220  continue
-  ! @       do 240 k=minorig+1,nl
-  ! @         do 230 i=1,len
-  ! @          if((hm(i,k).gt.work(i)).and.(k.le.ihmin(i)))then
-  ! @            work(i)=hm(i,k)
-  ! @            nk(i)=k
-  ! @          endif
-  ! @  230     continue
-  ! @  240  continue
-
-  ! -------------------------------------------------------------------
-  ! --- Origin level of ascending parcels for convect3:
-  ! -------------------------------------------------------------------
-
-  DO i = 1, len
-    nk(i) = minorig
-  END DO
-
-  ! -------------------------------------------------------------------
-  ! --- Check whether parcel level temperature and specific humidity
-  ! --- are reasonable
-  ! -------------------------------------------------------------------
-  DO i = 1, len
-    IF (((t(i,nk(i))<250.0) .OR. (q(i,nk(i))<=0.0)) & ! @      &       .or.(
-                                                      ! p(i,ihmin(i)).lt.400.0
-                                                      ! )  )
-      .AND. (iflag(i)==0)) iflag(i) = 7
-  END DO
-  ! -------------------------------------------------------------------
-  ! --- Calculate lifted condensation level of air at parcel origin level
-  ! --- (Within 0.2% of formula of Bolton, MON. WEA. REV.,1980)
-  ! -------------------------------------------------------------------
-
-  a = 1669.0 ! convect3
-  b = 122.0 ! convect3
-
-  DO i = 1, len
-
-    IF (iflag(i)/=7) THEN ! modif sb Jun7th 2002
-
-      tnk(i) = t(i, nk(i))
-      qnk(i) = q(i, nk(i))
-      gznk(i) = gz(i, nk(i))
-      pnk(i) = p(i, nk(i))
-      qsnk(i) = qs(i, nk(i))
-
-      rh(i) = qnk(i)/qsnk(i)
-      ! ori        rh(i)=min(1.0,rh(i)) ! removed for convect3
-      ! ori        chi(i)=tnk(i)/(1669.0-122.0*rh(i)-tnk(i))
-      chi(i) = tnk(i)/(a-b*rh(i)-tnk(i)) ! convect3
-      plcl(i) = pnk(i)*(rh(i)**chi(i))
-      IF (((plcl(i)<200.0) .OR. (plcl(i)>=2000.0)) .AND. (iflag(i)==0)) iflag &
-        (i) = 8
-
-    END IF ! iflag=7
-
-  END DO
-
-  ! -------------------------------------------------------------------
-  ! --- Calculate first level above lcl (=icb)
-  ! -------------------------------------------------------------------
-
-  ! @      do 270 i=1,len
-  ! @       icb(i)=nlm
-  ! @ 270  continue
-  ! @c
-  ! @      do 290 k=minorig,nl
-  ! @        do 280 i=1,len
-  ! @          if((k.ge.(nk(i)+1)).and.(p(i,k).lt.plcl(i)))
-  ! @     &    icb(i)=min(icb(i),k)
-  ! @ 280    continue
-  ! @ 290  continue
-  ! @c
-  ! @      do 300 i=1,len
-  ! @        if((icb(i).ge.nlm).and.(iflag(i).eq.0))iflag(i)=9
-  ! @ 300  continue
-
-  DO i = 1, len
-    icb(i) = nlm
-  END DO
-
-  ! la modification consiste a comparer plcl a ph et non a p:
-  ! icb est defini par :  ph(icb)<plcl<ph(icb-1)
-  ! @      do 290 k=minorig,nl
-  DO k = 3, nl - 1 ! modif pour que icb soit sup/egal a 2
-    DO i = 1, len
-      IF (ph(i,k)<plcl(i)) icb(i) = min(icb(i), k)
-    END DO
-  END DO
-
-  DO i = 1, len
-    ! @        if((icb(i).ge.nlm).and.(iflag(i).eq.0))iflag(i)=9
-    IF ((icb(i)==nlm) .AND. (iflag(i)==0)) iflag(i) = 9
-  END DO
-
-  DO i = 1, len
-    icb(i) = icb(i) - 1 ! icb sup ou egal a 2
-  END DO
-
-  ! Compute icbmax.
-
-  icbmax = 2
-  DO i = 1, len
-    ! !        icbmax=max(icbmax,icb(i))
-    IF (iflag(i)<7) icbmax = max(icbmax, icb(i)) ! sb Jun7th02
-  END DO
-
-  RETURN
-END SUBROUTINE cv30_feed
-
-SUBROUTINE cv30_undilute1(len, nd, t, q, qs, gz, plcl, p, nk, icb, tp, tvp, &
-    clw, icbs)
-  IMPLICIT NONE
-
-  ! ----------------------------------------------------------------
-  ! Equivalent de TLIFT entre NK et ICB+1 inclus
-
-  ! Differences with convect4:
-  ! - specify plcl in input
-  ! - icbs is the first level above LCL (may differ from icb)
-  ! - in the iterations, used x(icbs) instead x(icb)
-  ! - many minor differences in the iterations
-  ! - tvp is computed in only one time
-  ! - icbs: first level above Plcl (IMIN de TLIFT) in output
-  ! - if icbs=icb, compute also tp(icb+1),tvp(icb+1) & clw(icb+1)
-  ! ----------------------------------------------------------------
-
-  include "cvthermo.h"
-  include "cv30param.h"
-
-  ! inputs:
-  INTEGER len, nd
-  INTEGER nk(len), icb(len)
-  REAL t(len, nd), q(len, nd), qs(len, nd), gz(len, nd)
-  REAL p(len, nd)
-  REAL plcl(len) ! convect3
-
-  ! outputs:
-  REAL tp(len, nd), tvp(len, nd), clw(len, nd)
-
-  ! local variables:
-  INTEGER i, k
-  INTEGER icb1(len), icbs(len), icbsmax2 ! convect3
-  REAL tg, qg, alv, s, ahg, tc, denom, es, rg
-  REAL ah0(len), cpp(len)
-  REAL tnk(len), qnk(len), gznk(len), ticb(len), gzicb(len)
-  REAL qsicb(len) ! convect3
-  REAL cpinv(len) ! convect3
-
-  ! -------------------------------------------------------------------
-  ! --- Calculates the lifted parcel virtual temperature at nk,
-  ! --- the actual temperature, and the adiabatic
-  ! --- liquid water content. The procedure is to solve the equation.
-  ! cp*tp+L*qp+phi=cp*tnk+L*qnk+gznk.
-  ! -------------------------------------------------------------------
-
-  DO i = 1, len
-    tnk(i) = t(i, nk(i))
-    qnk(i) = q(i, nk(i))
-    gznk(i) = gz(i, nk(i))
-    ! ori        ticb(i)=t(i,icb(i))
-    ! ori        gzicb(i)=gz(i,icb(i))
-  END DO
-
-  ! ***  Calculate certain parcel quantities, including static energy   ***
-
-  DO i = 1, len
-    ah0(i) = (cpd*(1.-qnk(i))+cl*qnk(i))*tnk(i) + qnk(i)*(lv0-clmcpv*(tnk(i)- &
-      273.15)) + gznk(i)
-    cpp(i) = cpd*(1.-qnk(i)) + qnk(i)*cpv
-    cpinv(i) = 1./cpp(i)
-  END DO
-
-  ! ***   Calculate lifted parcel quantities below cloud base   ***
-
-  DO i = 1, len !convect3
-    icb1(i) = min(max(icb(i), 2), nl)
-    ! if icb is below LCL, start loop at ICB+1:
-    ! (icbs est le premier niveau au-dessus du LCL)
-    icbs(i) = icb1(i) !convect3
-    IF (plcl(i)<p(i,icb1(i))) THEN
-      icbs(i) = min(icbs(i)+1, nl) !convect3
-    END IF
-  END DO !convect3
-
-  DO i = 1, len !convect3
-    ticb(i) = t(i, icbs(i)) !convect3
-    gzicb(i) = gz(i, icbs(i)) !convect3
-    qsicb(i) = qs(i, icbs(i)) !convect3
-  END DO !convect3
-
-
-  ! Re-compute icbsmax (icbsmax2):        !convect3
-  ! !convect3
-  icbsmax2 = 2 !convect3
-  DO i = 1, len !convect3
-    icbsmax2 = max(icbsmax2, icbs(i)) !convect3
-  END DO !convect3
-
-  ! initialization outputs:
-
-  DO k = 1, icbsmax2 ! convect3
-    DO i = 1, len ! convect3
-      tp(i, k) = 0.0 ! convect3
-      tvp(i, k) = 0.0 ! convect3
-      clw(i, k) = 0.0 ! convect3
-    END DO ! convect3
-  END DO ! convect3
-
-  ! tp and tvp below cloud base:
-
-  DO k = minorig, icbsmax2 - 1
-    DO i = 1, len
-      tp(i, k) = tnk(i) - (gz(i,k)-gznk(i))*cpinv(i)
-      tvp(i, k) = tp(i, k)*(1.+qnk(i)/eps-qnk(i)) !whole thing (convect3)
-    END DO
-  END DO
-
-  ! ***  Find lifted parcel quantities above cloud base    ***
-
-  DO i = 1, len
-    tg = ticb(i)
-    ! ori         qg=qs(i,icb(i))
-    qg = qsicb(i) ! convect3
-    ! debug         alv=lv0-clmcpv*(ticb(i)-t0)
-    alv = lv0 - clmcpv*(ticb(i)-273.15)
-
-    ! First iteration.
-
-    ! ori          s=cpd+alv*alv*qg/(rrv*ticb(i)*ticb(i))
-    s = cpd*(1.-qnk(i)) + cl*qnk(i) & ! convect3
-      +alv*alv*qg/(rrv*ticb(i)*ticb(i)) ! convect3
-    s = 1./s
-    ! ori          ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i)
-    ahg = cpd*tg + (cl-cpd)*qnk(i)*tg + alv*qg + gzicb(i) ! convect3
-    tg = tg + s*(ah0(i)-ahg)
-    ! ori          tg=max(tg,35.0)
-    ! debug          tc=tg-t0
-    tc = tg - 273.15
-    denom = 243.5 + tc
-    denom = max(denom, 1.0) ! convect3
-    ! ori          if(tc.ge.0.0)then
-    es = 6.112*exp(17.67*tc/denom)
-    ! ori          else
-    ! ori           es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
-    ! ori          endif
-    ! ori          qg=eps*es/(p(i,icb(i))-es*(1.-eps))
-    qg = eps*es/(p(i,icbs(i))-es*(1.-eps))
-
-    ! Second iteration.
-
-
-    ! ori          s=cpd+alv*alv*qg/(rrv*ticb(i)*ticb(i))
-    ! ori          s=1./s
-    ! ori          ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i)
-    ahg = cpd*tg + (cl-cpd)*qnk(i)*tg + alv*qg + gzicb(i) ! convect3
-    tg = tg + s*(ah0(i)-ahg)
-    ! ori          tg=max(tg,35.0)
-    ! debug          tc=tg-t0
-    tc = tg - 273.15
-    denom = 243.5 + tc
-    denom = max(denom, 1.0) ! convect3
-    ! ori          if(tc.ge.0.0)then
-    es = 6.112*exp(17.67*tc/denom)
-    ! ori          else
-    ! ori           es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
-    ! ori          end if
-    ! ori          qg=eps*es/(p(i,icb(i))-es*(1.-eps))
-    qg = eps*es/(p(i,icbs(i))-es*(1.-eps))
-
-    alv = lv0 - clmcpv*(ticb(i)-273.15)
-
-    ! ori c approximation here:
-    ! ori         tp(i,icb(i))=(ah0(i)-(cl-cpd)*qnk(i)*ticb(i)
-    ! ori     &   -gz(i,icb(i))-alv*qg)/cpd
-
-    ! convect3: no approximation:
-    tp(i, icbs(i)) = (ah0(i)-gz(i,icbs(i))-alv*qg)/(cpd+(cl-cpd)*qnk(i))
-
-    ! ori         clw(i,icb(i))=qnk(i)-qg
-    ! ori         clw(i,icb(i))=max(0.0,clw(i,icb(i)))
-    clw(i, icbs(i)) = qnk(i) - qg
-    clw(i, icbs(i)) = max(0.0, clw(i,icbs(i)))
-
-    rg = qg/(1.-qnk(i))
-    ! ori         tvp(i,icb(i))=tp(i,icb(i))*(1.+rg*epsi)
-    ! convect3: (qg utilise au lieu du vrai mixing ratio rg)
-    tvp(i, icbs(i)) = tp(i, icbs(i))*(1.+qg/eps-qnk(i)) !whole thing
-
-  END DO
-
-  ! ori      do 380 k=minorig,icbsmax2
-  ! ori       do 370 i=1,len
-  ! ori         tvp(i,k)=tvp(i,k)-tp(i,k)*qnk(i)
-  ! ori 370   continue
-  ! ori 380  continue
-
-
-  ! -- The following is only for convect3:
-
-  ! * icbs is the first level above the LCL:
-  ! if plcl<p(icb), then icbs=icb+1
-  ! if plcl>p(icb), then icbs=icb
-
-  ! * the routine above computes tvp from minorig to icbs (included).
-
-  ! * to compute buoybase (in cv3_trigger.F), both tvp(icb) and tvp(icb+1)
-  ! must be known. This is the case if icbs=icb+1, but not if icbs=icb.
-
-  ! * therefore, in the case icbs=icb, we compute tvp at level icb+1
-  ! (tvp at other levels will be computed in cv3_undilute2.F)
-
-
-  DO i = 1, len
-    ticb(i) = t(i, icb(i)+1)
-    gzicb(i) = gz(i, icb(i)+1)
-    qsicb(i) = qs(i, icb(i)+1)
-  END DO
-
-  DO i = 1, len
-    tg = ticb(i)
-    qg = qsicb(i) ! convect3
-    ! debug         alv=lv0-clmcpv*(ticb(i)-t0)
-    alv = lv0 - clmcpv*(ticb(i)-273.15)
-
-    ! First iteration.
-
-    ! ori          s=cpd+alv*alv*qg/(rrv*ticb(i)*ticb(i))
-    s = cpd*(1.-qnk(i)) + cl*qnk(i) & ! convect3
-      +alv*alv*qg/(rrv*ticb(i)*ticb(i)) ! convect3
-    s = 1./s
-    ! ori          ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i)
-    ahg = cpd*tg + (cl-cpd)*qnk(i)*tg + alv*qg + gzicb(i) ! convect3
-    tg = tg + s*(ah0(i)-ahg)
-    ! ori          tg=max(tg,35.0)
-    ! debug          tc=tg-t0
-    tc = tg - 273.15
-    denom = 243.5 + tc
-    denom = max(denom, 1.0) ! convect3
-    ! ori          if(tc.ge.0.0)then
-    es = 6.112*exp(17.67*tc/denom)
-    ! ori          else
-    ! ori           es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
-    ! ori          endif
-    ! ori          qg=eps*es/(p(i,icb(i))-es*(1.-eps))
-    qg = eps*es/(p(i,icb(i)+1)-es*(1.-eps))
-
-    ! Second iteration.
-
-
-    ! ori          s=cpd+alv*alv*qg/(rrv*ticb(i)*ticb(i))
-    ! ori          s=1./s
-    ! ori          ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i)
-    ahg = cpd*tg + (cl-cpd)*qnk(i)*tg + alv*qg + gzicb(i) ! convect3
-    tg = tg + s*(ah0(i)-ahg)
-    ! ori          tg=max(tg,35.0)
-    ! debug          tc=tg-t0
-    tc = tg - 273.15
-    denom = 243.5 + tc
-    denom = max(denom, 1.0) ! convect3
-    ! ori          if(tc.ge.0.0)then
-    es = 6.112*exp(17.67*tc/denom)
-    ! ori          else
-    ! ori           es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
-    ! ori          end if
-    ! ori          qg=eps*es/(p(i,icb(i))-es*(1.-eps))
-    qg = eps*es/(p(i,icb(i)+1)-es*(1.-eps))
-
-    alv = lv0 - clmcpv*(ticb(i)-273.15)
-
-    ! ori c approximation here:
-    ! ori         tp(i,icb(i))=(ah0(i)-(cl-cpd)*qnk(i)*ticb(i)
-    ! ori     &   -gz(i,icb(i))-alv*qg)/cpd
-
-    ! convect3: no approximation:
-    tp(i, icb(i)+1) = (ah0(i)-gz(i,icb(i)+1)-alv*qg)/(cpd+(cl-cpd)*qnk(i))
-
-    ! ori         clw(i,icb(i))=qnk(i)-qg
-    ! ori         clw(i,icb(i))=max(0.0,clw(i,icb(i)))
-    clw(i, icb(i)+1) = qnk(i) - qg
-    clw(i, icb(i)+1) = max(0.0, clw(i,icb(i)+1))
-
-    rg = qg/(1.-qnk(i))
-    ! ori         tvp(i,icb(i))=tp(i,icb(i))*(1.+rg*epsi)
-    ! convect3: (qg utilise au lieu du vrai mixing ratio rg)
-    tvp(i, icb(i)+1) = tp(i, icb(i)+1)*(1.+qg/eps-qnk(i)) !whole thing
-
-  END DO
-
-  RETURN
-END SUBROUTINE cv30_undilute1
-
-SUBROUTINE cv30_trigger(len, nd, icb, plcl, p, th, tv, tvp, pbase, buoybase, &
-    iflag, sig, w0)
-  IMPLICIT NONE
-
-  ! -------------------------------------------------------------------
-  ! --- TRIGGERING
-
-  ! - computes the cloud base
-  ! - triggering (crude in this version)
-  ! - relaxation of sig and w0 when no convection
-
-  ! Caution1: if no convection, we set iflag=4
-  ! (it used to be 0 in convect3)
-
-  ! Caution2: at this stage, tvp (and thus buoy) are know up
-  ! through icb only!
-  ! -> the buoyancy below cloud base not (yet) set to the cloud base buoyancy
-  ! -------------------------------------------------------------------
-
-  include "cv30param.h"
-
-  ! input:
-  INTEGER len, nd
-  INTEGER icb(len)
-  REAL plcl(len), p(len, nd)
-  REAL th(len, nd), tv(len, nd), tvp(len, nd)
-
-  ! output:
-  REAL pbase(len), buoybase(len)
-
-  ! input AND output:
-  INTEGER iflag(len)
-  REAL sig(len, nd), w0(len, nd)
-
-  ! local variables:
-  INTEGER i, k
-  REAL tvpbase, tvbase, tdif, ath, ath1
-
-
-  ! ***   set cloud base buoyancy at (plcl+dpbase) level buoyancy
-
-  DO i = 1, len
-    pbase(i) = plcl(i) + dpbase
-    tvpbase = tvp(i, icb(i))*(pbase(i)-p(i,icb(i)+1))/ &
-      (p(i,icb(i))-p(i,icb(i)+1)) + tvp(i, icb(i)+1)*(p(i,icb(i))-pbase(i))/( &
-      p(i,icb(i))-p(i,icb(i)+1))
-    tvbase = tv(i, icb(i))*(pbase(i)-p(i,icb(i)+1))/ &
-      (p(i,icb(i))-p(i,icb(i)+1)) + tv(i, icb(i)+1)*(p(i,icb(i))-pbase(i))/(p &
-      (i,icb(i))-p(i,icb(i)+1))
-    buoybase(i) = tvpbase - tvbase
-  END DO
-
-
-  ! ***   make sure that column is dry adiabatic between the surface  ***
-  ! ***    and cloud base, and that lifted air is positively buoyant  ***
-  ! ***                         at cloud base                         ***
-  ! ***       if not, return to calling program after resetting       ***
-  ! ***                        sig(i) and w0(i)                       ***
-
-
-  ! oct3      do 200 i=1,len
-  ! oct3
-  ! oct3       tdif = buoybase(i)
-  ! oct3       ath1 = th(i,1)
-  ! oct3       ath  = th(i,icb(i)-1) - dttrig
-  ! oct3
-  ! oct3       if (tdif.lt.dtcrit .or. ath.gt.ath1) then
-  ! oct3         do 60 k=1,nl
-  ! oct3            sig(i,k) = beta*sig(i,k) - 2.*alpha*tdif*tdif
-  ! oct3            sig(i,k) = AMAX1(sig(i,k),0.0)
-  ! oct3            w0(i,k)  = beta*w0(i,k)
-  ! oct3   60    continue
-  ! oct3         iflag(i)=4 ! pour version vectorisee
-  ! oct3c convect3         iflag(i)=0
-  ! oct3cccc         return
-  ! oct3       endif
-  ! oct3
-  ! oct3200   continue
-
-  ! -- oct3: on reecrit la boucle 200 (pour la vectorisation)
-
-  DO k = 1, nl
-    DO i = 1, len
-
-      tdif = buoybase(i)
-      ath1 = th(i, 1)
-      ath = th(i, icb(i)-1) - dttrig
-
-      IF (tdif<dtcrit .OR. ath>ath1) THEN
-        sig(i, k) = beta*sig(i, k) - 2.*alpha*tdif*tdif
-        sig(i, k) = amax1(sig(i,k), 0.0)
-        w0(i, k) = beta*w0(i, k)
-        iflag(i) = 4 ! pour version vectorisee
-        ! convect3         iflag(i)=0
-      END IF
-
-    END DO
-  END DO
-
-  ! fin oct3 --
-
-  RETURN
-END SUBROUTINE cv30_trigger
-
-SUBROUTINE cv30_compress(len, nloc, ncum, nd, ntra, iflag1, nk1, icb1, icbs1, &
-    plcl1, tnk1, qnk1, gznk1, pbase1, buoybase1, t1, q1, qs1, u1, v1, gz1, &
-    th1, tra1, h1, lv1, cpn1, p1, ph1, tv1, tp1, tvp1, clw1, sig1, w01, &
-    iflag, nk, icb, icbs, plcl, tnk, qnk, gznk, pbase, buoybase, t, q, qs, u, &
-    v, gz, th, tra, h, lv, cpn, p, ph, tv, tp, tvp, clw, sig, w0)
-  USE print_control_mod, ONLY: lunout
-  IMPLICIT NONE
-
-  include "cv30param.h"
-
-  ! inputs:
-  INTEGER len, ncum, nd, ntra, nloc
-  INTEGER iflag1(len), nk1(len), icb1(len), icbs1(len)
-  REAL plcl1(len), tnk1(len), qnk1(len), gznk1(len)
-  REAL pbase1(len), buoybase1(len)
-  REAL t1(len, nd), q1(len, nd), qs1(len, nd), u1(len, nd), v1(len, nd)
-  REAL gz1(len, nd), h1(len, nd), lv1(len, nd), cpn1(len, nd)
-  REAL p1(len, nd), ph1(len, nd+1), tv1(len, nd), tp1(len, nd)
-  REAL tvp1(len, nd), clw1(len, nd)
-  REAL th1(len, nd)
-  REAL sig1(len, nd), w01(len, nd)
-  REAL tra1(len, nd, ntra)
-
-  ! outputs:
-  ! en fait, on a nloc=len pour l'instant (cf cv_driver)
-  INTEGER iflag(nloc), nk(nloc), icb(nloc), icbs(nloc)
-  REAL plcl(nloc), tnk(nloc), qnk(nloc), gznk(nloc)
-  REAL pbase(nloc), buoybase(nloc)
-  REAL t(nloc, nd), q(nloc, nd), qs(nloc, nd), u(nloc, nd), v(nloc, nd)
-  REAL gz(nloc, nd), h(nloc, nd), lv(nloc, nd), cpn(nloc, nd)
-  REAL p(nloc, nd), ph(nloc, nd+1), tv(nloc, nd), tp(nloc, nd)
-  REAL tvp(nloc, nd), clw(nloc, nd)
-  REAL th(nloc, nd)
-  REAL sig(nloc, nd), w0(nloc, nd)
-  REAL tra(nloc, nd, ntra)
-
-  ! local variables:
-  INTEGER i, k, nn, j
-
-  CHARACTER (LEN=20) :: modname = 'cv30_compress'
-  CHARACTER (LEN=80) :: abort_message
-
-
-  DO k = 1, nl + 1
-    nn = 0
-    DO i = 1, len
-      IF (iflag1(i)==0) THEN
-        nn = nn + 1
-        sig(nn, k) = sig1(i, k)
-        w0(nn, k) = w01(i, k)
-        t(nn, k) = t1(i, k)
-        q(nn, k) = q1(i, k)
-        qs(nn, k) = qs1(i, k)
-        u(nn, k) = u1(i, k)
-        v(nn, k) = v1(i, k)
-        gz(nn, k) = gz1(i, k)
-        h(nn, k) = h1(i, k)
-        lv(nn, k) = lv1(i, k)
-        cpn(nn, k) = cpn1(i, k)
-        p(nn, k) = p1(i, k)
-        ph(nn, k) = ph1(i, k)
-        tv(nn, k) = tv1(i, k)
-        tp(nn, k) = tp1(i, k)
-        tvp(nn, k) = tvp1(i, k)
-        clw(nn, k) = clw1(i, k)
-        th(nn, k) = th1(i, k)
-      END IF
-    END DO
-  END DO
-
-  ! do 121 j=1,ntra
-  ! do 111 k=1,nd
-  ! nn=0
-  ! do 101 i=1,len
-  ! if(iflag1(i).eq.0)then
-  ! nn=nn+1
-  ! tra(nn,k,j)=tra1(i,k,j)
-  ! endif
-  ! 101  continue
-  ! 111  continue
-  ! 121  continue
-
-  IF (nn/=ncum) THEN
-    WRITE (lunout, *) 'strange! nn not equal to ncum: ', nn, ncum
-    abort_message = ''
-    CALL abort_physic(modname, abort_message, 1)
-  END IF
-
-  nn = 0
-  DO i = 1, len
-    IF (iflag1(i)==0) THEN
-      nn = nn + 1
-      pbase(nn) = pbase1(i)
-      buoybase(nn) = buoybase1(i)
-      plcl(nn) = plcl1(i)
-      tnk(nn) = tnk1(i)
-      qnk(nn) = qnk1(i)
-      gznk(nn) = gznk1(i)
-      nk(nn) = nk1(i)
-      icb(nn) = icb1(i)
-      icbs(nn) = icbs1(i)
-      iflag(nn) = iflag1(i)
-    END IF
-  END DO
-
-  RETURN
-END SUBROUTINE cv30_compress
-
-SUBROUTINE cv30_undilute2(nloc, ncum, nd, icb, icbs, nk, tnk, qnk, gznk, t, &
-    q, qs, gz, p, h, tv, lv, pbase, buoybase, plcl, inb, tp, tvp, clw, hp, &
-    ep, sigp, buoy)
-    ! epmax_cape: ajout arguments
-  IMPLICIT NONE
-
-  ! ---------------------------------------------------------------------
-  ! Purpose:
-  ! FIND THE REST OF THE LIFTED PARCEL TEMPERATURES
-  ! &
-  ! COMPUTE THE PRECIPITATION EFFICIENCIES AND THE
-  ! FRACTION OF PRECIPITATION FALLING OUTSIDE OF CLOUD
-  ! &
-  ! FIND THE LEVEL OF NEUTRAL BUOYANCY
-
-  ! Main differences convect3/convect4:
-  ! - icbs (input) is the first level above LCL (may differ from icb)
-  ! - many minor differences in the iterations
-  ! - condensed water not removed from tvp in convect3
-  ! - vertical profile of buoyancy computed here (use of buoybase)
-  ! - the determination of inb is different
-  ! - no inb1, only inb in output
-  ! ---------------------------------------------------------------------
-
-  include "cvthermo.h"
-  include "cv30param.h"
-  include "conema3.h"
-
-  ! inputs:
-  INTEGER ncum, nd, nloc
-  INTEGER icb(nloc), icbs(nloc), nk(nloc)
-  REAL t(nloc, nd), q(nloc, nd), qs(nloc, nd), gz(nloc, nd)
-  REAL p(nloc, nd)
-  REAL tnk(nloc), qnk(nloc), gznk(nloc)
-  REAL lv(nloc, nd), tv(nloc, nd), h(nloc, nd)
-  REAL pbase(nloc), buoybase(nloc), plcl(nloc)
-
-  ! outputs:
-  INTEGER inb(nloc)
-  REAL tp(nloc, nd), tvp(nloc, nd), clw(nloc, nd)
-  REAL ep(nloc, nd), sigp(nloc, nd), hp(nloc, nd)
-  REAL buoy(nloc, nd)
-
-  ! local variables:
-  INTEGER i, k
-  REAL tg, qg, ahg, alv, s, tc, es, denom, rg, tca, elacrit
-  REAL by, defrac, pden
-  REAL ah0(nloc), cape(nloc), capem(nloc), byp(nloc)
-  LOGICAL lcape(nloc)
-
-  ! =====================================================================
-  ! --- SOME INITIALIZATIONS
-  ! =====================================================================
-
-  DO k = 1, nl
-    DO i = 1, ncum
-      ep(i, k) = 0.0
-      sigp(i, k) = spfac
-    END DO
-  END DO
-
-  ! =====================================================================
-  ! --- FIND THE REST OF THE LIFTED PARCEL TEMPERATURES
-  ! =====================================================================
-
-  ! ---       The procedure is to solve the equation.
-  ! cp*tp+L*qp+phi=cp*tnk+L*qnk+gznk.
-
-  ! ***  Calculate certain parcel quantities, including static energy   ***
-
-
-  DO i = 1, ncum
-    ah0(i) = (cpd*(1.-qnk(i))+cl*qnk(i))*tnk(i) & ! debug     &
-                                                  ! +qnk(i)*(lv0-clmcpv*(tnk(i)-t0))+gznk(i)
-      +qnk(i)*(lv0-clmcpv*(tnk(i)-273.15)) + gznk(i)
-  END DO
-
-
-  ! ***  Find lifted parcel quantities above cloud base    ***
-
-
-  DO k = minorig + 1, nl
-    DO i = 1, ncum
-      ! ori	    if(k.ge.(icb(i)+1))then
-      IF (k>=(icbs(i)+1)) THEN ! convect3
-        tg = t(i, k)
-        qg = qs(i, k)
-        ! debug	      alv=lv0-clmcpv*(t(i,k)-t0)
-        alv = lv0 - clmcpv*(t(i,k)-273.15)
-
-        ! First iteration.
-
-        ! ori	       s=cpd+alv*alv*qg/(rrv*t(i,k)*t(i,k))
-        s = cpd*(1.-qnk(i)) + cl*qnk(i) & ! convect3
-          +alv*alv*qg/(rrv*t(i,k)*t(i,k)) ! convect3
-        s = 1./s
-        ! ori	       ahg=cpd*tg+(cl-cpd)*qnk(i)*t(i,k)+alv*qg+gz(i,k)
-        ahg = cpd*tg + (cl-cpd)*qnk(i)*tg + alv*qg + gz(i, k) ! convect3
-        tg = tg + s*(ah0(i)-ahg)
-        ! ori	       tg=max(tg,35.0)
-        ! debug	       tc=tg-t0
-        tc = tg - 273.15
-        denom = 243.5 + tc
-        denom = max(denom, 1.0) ! convect3
-        ! ori	       if(tc.ge.0.0)then
-        es = 6.112*exp(17.67*tc/denom)
-        ! ori	       else
-        ! ori			es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
-        ! ori	       endif
-        qg = eps*es/(p(i,k)-es*(1.-eps))
-
-        ! Second iteration.
-
-        ! ori	       s=cpd+alv*alv*qg/(rrv*t(i,k)*t(i,k))
-        ! ori	       s=1./s
-        ! ori	       ahg=cpd*tg+(cl-cpd)*qnk(i)*t(i,k)+alv*qg+gz(i,k)
-        ahg = cpd*tg + (cl-cpd)*qnk(i)*tg + alv*qg + gz(i, k) ! convect3
-        tg = tg + s*(ah0(i)-ahg)
-        ! ori	       tg=max(tg,35.0)
-        ! debug	       tc=tg-t0
-        tc = tg - 273.15
-        denom = 243.5 + tc
-        denom = max(denom, 1.0) ! convect3
-        ! ori	       if(tc.ge.0.0)then
-        es = 6.112*exp(17.67*tc/denom)
-        ! ori	       else
-        ! ori			es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
-        ! ori	       endif
-        qg = eps*es/(p(i,k)-es*(1.-eps))
-
-        ! debug	       alv=lv0-clmcpv*(t(i,k)-t0)
-        alv = lv0 - clmcpv*(t(i,k)-273.15)
-        ! print*,'cpd dans convect2 ',cpd
-        ! print*,'tp(i,k),ah0(i),cl,cpd,qnk(i),t(i,k),gz(i,k),alv,qg,cpd'
-        ! print*,tp(i,k),ah0(i),cl,cpd,qnk(i),t(i,k),gz(i,k),alv,qg,cpd
-
-        ! ori c approximation here:
-        ! ori
-        ! tp(i,k)=(ah0(i)-(cl-cpd)*qnk(i)*t(i,k)-gz(i,k)-alv*qg)/cpd
-
-        ! convect3: no approximation:
-        tp(i, k) = (ah0(i)-gz(i,k)-alv*qg)/(cpd+(cl-cpd)*qnk(i))
-
-        clw(i, k) = qnk(i) - qg
-        clw(i, k) = max(0.0, clw(i,k))
-        rg = qg/(1.-qnk(i))
-        ! ori               tvp(i,k)=tp(i,k)*(1.+rg*epsi)
-        ! convect3: (qg utilise au lieu du vrai mixing ratio rg):
-        tvp(i, k) = tp(i, k)*(1.+qg/eps-qnk(i)) ! whole thing
-      END IF
-    END DO
-  END DO
-
-  ! =====================================================================
-  ! --- SET THE PRECIPITATION EFFICIENCIES AND THE FRACTION OF
-  ! --- PRECIPITATION FALLING OUTSIDE OF CLOUD
-  ! --- THESE MAY BE FUNCTIONS OF TP(I), P(I) AND CLW(I)
-  ! =====================================================================
-
-  ! ori      do 320 k=minorig+1,nl
-  DO k = 1, nl ! convect3
-    DO i = 1, ncum
-      pden = ptcrit - pbcrit
-      ep(i, k) = (plcl(i)-p(i,k)-pbcrit)/pden*epmax
-      ep(i, k) = amax1(ep(i,k), 0.0)
-      ep(i, k) = amin1(ep(i,k), epmax)
-      sigp(i, k) = spfac
-      ! ori          if(k.ge.(nk(i)+1))then
-      ! ori            tca=tp(i,k)-t0
-      ! ori            if(tca.ge.0.0)then
-      ! ori              elacrit=elcrit
-      ! ori            else
-      ! ori              elacrit=elcrit*(1.0-tca/tlcrit)
-      ! ori            endif
-      ! ori            elacrit=max(elacrit,0.0)
-      ! ori            ep(i,k)=1.0-elacrit/max(clw(i,k),1.0e-8)
-      ! ori            ep(i,k)=max(ep(i,k),0.0 )
-      ! ori            ep(i,k)=min(ep(i,k),1.0 )
-      ! ori            sigp(i,k)=sigs
-      ! ori          endif
-    END DO
-  END DO
-
-  ! =====================================================================
-  ! --- CALCULATE VIRTUAL TEMPERATURE AND LIFTED PARCEL
-  ! --- VIRTUAL TEMPERATURE
-  ! =====================================================================
-
-  ! dans convect3, tvp est calcule en une seule fois, et sans retirer
-  ! l'eau condensee (~> reversible CAPE)
-
-  ! ori      do 340 k=minorig+1,nl
-  ! ori        do 330 i=1,ncum
-  ! ori        if(k.ge.(icb(i)+1))then
-  ! ori          tvp(i,k)=tvp(i,k)*(1.0-qnk(i)+ep(i,k)*clw(i,k))
-  ! oric         print*,'i,k,tvp(i,k),qnk(i),ep(i,k),clw(i,k)'
-  ! oric         print*, i,k,tvp(i,k),qnk(i),ep(i,k),clw(i,k)
-  ! ori        endif
-  ! ori 330    continue
-  ! ori 340  continue
-
-  ! ori      do 350 i=1,ncum
-  ! ori       tvp(i,nlp)=tvp(i,nl)-(gz(i,nlp)-gz(i,nl))/cpd
-  ! ori 350  continue
-
-  DO i = 1, ncum ! convect3
-    tp(i, nlp) = tp(i, nl) ! convect3
-  END DO ! convect3
-
-  ! =====================================================================
-  ! --- EFFECTIVE VERTICAL PROFILE OF BUOYANCY (convect3 only):
-  ! =====================================================================
-
-  ! -- this is for convect3 only:
-
-  ! first estimate of buoyancy:
-
-  DO i = 1, ncum
-    DO k = 1, nl
-      buoy(i, k) = tvp(i, k) - tv(i, k)
-    END DO
-  END DO
-
-  ! set buoyancy=buoybase for all levels below base
-  ! for safety, set buoy(icb)=buoybase
-
-  DO i = 1, ncum
-    DO k = 1, nl
-      IF ((k>=icb(i)) .AND. (k<=nl) .AND. (p(i,k)>=pbase(i))) THEN
-        buoy(i, k) = buoybase(i)
-      END IF
-    END DO
-    ! IM cf. CRio/JYG 270807   buoy(icb(i),k)=buoybase(i)
-    buoy(i, icb(i)) = buoybase(i)
-  END DO
-
-  ! -- end convect3
-
-  ! =====================================================================
-  ! --- FIND THE FIRST MODEL LEVEL (INB) ABOVE THE PARCEL'S
-  ! --- LEVEL OF NEUTRAL BUOYANCY
-  ! =====================================================================
-
-  ! -- this is for convect3 only:
-
-  DO i = 1, ncum
-    inb(i) = nl - 1
-  END DO
-
-  DO i = 1, ncum
-    DO k = 1, nl - 1
-      IF ((k>=icb(i)) .AND. (buoy(i,k)<dtovsh)) THEN
-        inb(i) = min(inb(i), k)
-      END IF
-    END DO
-  END DO
-
-  ! -- end convect3
-
-  ! ori      do 510 i=1,ncum
-  ! ori        cape(i)=0.0
-  ! ori        capem(i)=0.0
-  ! ori        inb(i)=icb(i)+1
-  ! ori        inb1(i)=inb(i)
-  ! ori 510  continue
-
-  ! Originial Code
-
-  ! do 530 k=minorig+1,nl-1
-  ! do 520 i=1,ncum
-  ! if(k.ge.(icb(i)+1))then
-  ! by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k)
-  ! byp=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1)
-  ! cape(i)=cape(i)+by
-  ! if(by.ge.0.0)inb1(i)=k+1
-  ! if(cape(i).gt.0.0)then
-  ! inb(i)=k+1
-  ! capem(i)=cape(i)
-  ! endif
-  ! endif
-  ! 520    continue
-  ! 530  continue
-  ! do 540 i=1,ncum
-  ! byp=(tvp(i,nl)-tv(i,nl))*dph(i,nl)/p(i,nl)
-  ! cape(i)=capem(i)+byp
-  ! defrac=capem(i)-cape(i)
-  ! defrac=max(defrac,0.001)
-  ! frac(i)=-cape(i)/defrac
-  ! frac(i)=min(frac(i),1.0)
-  ! frac(i)=max(frac(i),0.0)
-  ! 540   continue
-
-  ! K Emanuel fix
-
-  ! call zilch(byp,ncum)
-  ! do 530 k=minorig+1,nl-1
-  ! do 520 i=1,ncum
-  ! if(k.ge.(icb(i)+1))then
-  ! by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k)
-  ! cape(i)=cape(i)+by
-  ! if(by.ge.0.0)inb1(i)=k+1
-  ! if(cape(i).gt.0.0)then
-  ! inb(i)=k+1
-  ! capem(i)=cape(i)
-  ! byp(i)=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1)
-  ! endif
-  ! endif
-  ! 520    continue
-  ! 530  continue
-  ! do 540 i=1,ncum
-  ! inb(i)=max(inb(i),inb1(i))
-  ! cape(i)=capem(i)+byp(i)
-  ! defrac=capem(i)-cape(i)
-  ! defrac=max(defrac,0.001)
-  ! frac(i)=-cape(i)/defrac
-  ! frac(i)=min(frac(i),1.0)
-  ! frac(i)=max(frac(i),0.0)
-  ! 540   continue
-
-  ! J Teixeira fix
-
-  ! ori      call zilch(byp,ncum)
-  ! ori      do 515 i=1,ncum
-  ! ori        lcape(i)=.true.
-  ! ori 515  continue
-  ! ori      do 530 k=minorig+1,nl-1
-  ! ori        do 520 i=1,ncum
-  ! ori          if(cape(i).lt.0.0)lcape(i)=.false.
-  ! ori          if((k.ge.(icb(i)+1)).and.lcape(i))then
-  ! ori            by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k)
-  ! ori            byp(i)=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1)
-  ! ori            cape(i)=cape(i)+by
-  ! ori            if(by.ge.0.0)inb1(i)=k+1
-  ! ori            if(cape(i).gt.0.0)then
-  ! ori              inb(i)=k+1
-  ! ori              capem(i)=cape(i)
-  ! ori            endif
-  ! ori          endif
-  ! ori 520    continue
-  ! ori 530  continue
-  ! ori      do 540 i=1,ncum
-  ! ori          cape(i)=capem(i)+byp(i)
-  ! ori          defrac=capem(i)-cape(i)
-  ! ori          defrac=max(defrac,0.001)
-  ! ori          frac(i)=-cape(i)/defrac
-  ! ori          frac(i)=min(frac(i),1.0)
-  ! ori          frac(i)=max(frac(i),0.0)
-  ! ori 540  continue
-
-  ! =====================================================================
-  ! ---   CALCULATE LIQUID WATER STATIC ENERGY OF LIFTED PARCEL
-  ! =====================================================================
-
-  ! ym      do i=1,ncum*nlp
-  ! ym       hp(i,1)=h(i,1)
-  ! ym      enddo
-
-  DO k = 1, nlp
-    DO i = 1, ncum
-      hp(i, k) = h(i, k)
-    END DO
-  END DO
-
-  DO k = minorig + 1, nl
-    DO i = 1, ncum
-      IF ((k>=icb(i)) .AND. (k<=inb(i))) THEN
-        hp(i, k) = h(i, nk(i)) + (lv(i,k)+(cpd-cpv)*t(i,k))*ep(i, k)*clw(i, k &
-          )
-      END IF
-    END DO
-  END DO
-
-  RETURN
-END SUBROUTINE cv30_undilute2
-
-SUBROUTINE cv30_closure(nloc, ncum, nd, icb, inb, pbase, p, ph, tv, buoy, &
-    sig, w0, cape, m)
-  IMPLICIT NONE
-
-  ! ===================================================================
-  ! ---  CLOSURE OF CONVECT3
-
-  ! vectorization: S. Bony
-  ! ===================================================================
-
-  include "cvthermo.h"
-  include "cv30param.h"
-
-  ! input:
-  INTEGER ncum, nd, nloc
-  INTEGER icb(nloc), inb(nloc)
-  REAL pbase(nloc)
-  REAL p(nloc, nd), ph(nloc, nd+1)
-  REAL tv(nloc, nd), buoy(nloc, nd)
-
-  ! input/output:
-  REAL sig(nloc, nd), w0(nloc, nd)
-
-  ! output:
-  REAL cape(nloc)
-  REAL m(nloc, nd)
-
-  ! local variables:
-  INTEGER i, j, k, icbmax
-  REAL deltap, fac, w, amu
-  REAL dtmin(nloc, nd), sigold(nloc, nd)
-
-  ! -------------------------------------------------------
-  ! -- Initialization
-  ! -------------------------------------------------------
-
-  DO k = 1, nl
-    DO i = 1, ncum
-      m(i, k) = 0.0
-    END DO
-  END DO
-
-  ! -------------------------------------------------------
-  ! -- Reset sig(i) and w0(i) for i>inb and i<icb
-  ! -------------------------------------------------------
-
-  ! update sig and w0 above LNB:
-
-  DO k = 1, nl - 1
-    DO i = 1, ncum
-      IF ((inb(i)<(nl-1)) .AND. (k>=(inb(i)+1))) THEN
-        sig(i, k) = beta*sig(i, k) + 2.*alpha*buoy(i, inb(i))*abs(buoy(i,inb( &
-          i)))
-        sig(i, k) = amax1(sig(i,k), 0.0)
-        w0(i, k) = beta*w0(i, k)
-      END IF
-    END DO
-  END DO
-
-  ! compute icbmax:
-
-  icbmax = 2
-  DO i = 1, ncum
-    icbmax = max(icbmax, icb(i))
-  END DO
-
-  ! update sig and w0 below cloud base:
-
-  DO k = 1, icbmax
-    DO i = 1, ncum
-      IF (k<=icb(i)) THEN
-        sig(i, k) = beta*sig(i, k) - 2.*alpha*buoy(i, icb(i))*buoy(i, icb(i))
-        sig(i, k) = amax1(sig(i,k), 0.0)
-        w0(i, k) = beta*w0(i, k)
-      END IF
-    END DO
-  END DO
-
-  ! !      if(inb.lt.(nl-1))then
-  ! !         do 85 i=inb+1,nl-1
-  ! !            sig(i)=beta*sig(i)+2.*alpha*buoy(inb)*
-  ! !     1              abs(buoy(inb))
-  ! !            sig(i)=amax1(sig(i),0.0)
-  ! !            w0(i)=beta*w0(i)
-  ! !   85    continue
-  ! !      end if
-
-  ! !      do 87 i=1,icb
-  ! !         sig(i)=beta*sig(i)-2.*alpha*buoy(icb)*buoy(icb)
-  ! !         sig(i)=amax1(sig(i),0.0)
-  ! !         w0(i)=beta*w0(i)
-  ! !   87 continue
-
-  ! -------------------------------------------------------------
-  ! -- Reset fractional areas of updrafts and w0 at initial time
-  ! -- and after 10 time steps of no convection
-  ! -------------------------------------------------------------
-
-  DO k = 1, nl - 1
-    DO i = 1, ncum
-      IF (sig(i,nd)<1.5 .OR. sig(i,nd)>12.0) THEN
-        sig(i, k) = 0.0
-        w0(i, k) = 0.0
-      END IF
-    END DO
-  END DO
-
-  ! -------------------------------------------------------------
-  ! -- Calculate convective available potential energy (cape),
-  ! -- vertical velocity (w), fractional area covered by
-  ! -- undilute updraft (sig), and updraft mass flux (m)
-  ! -------------------------------------------------------------
-
-  DO i = 1, ncum
-    cape(i) = 0.0
-  END DO
-
-  ! compute dtmin (minimum buoyancy between ICB and given level k):
-
-  DO i = 1, ncum
-    DO k = 1, nl
-      dtmin(i, k) = 100.0
-    END DO
-  END DO
-
-  DO i = 1, ncum
-    DO k = 1, nl
-      DO j = minorig, nl
-        IF ((k>=(icb(i)+1)) .AND. (k<=inb(i)) .AND. (j>=icb(i)) .AND. (j<=(k- &
-            1))) THEN
-          dtmin(i, k) = amin1(dtmin(i,k), buoy(i,j))
-        END IF
-      END DO
-    END DO
-  END DO
-
-  ! the interval on which cape is computed starts at pbase :
-  DO k = 1, nl
-    DO i = 1, ncum
-
-      IF ((k>=(icb(i)+1)) .AND. (k<=inb(i))) THEN
-
-        deltap = min(pbase(i), ph(i,k-1)) - min(pbase(i), ph(i,k))
-        cape(i) = cape(i) + rrd*buoy(i, k-1)*deltap/p(i, k-1)
-        cape(i) = amax1(0.0, cape(i))
-        sigold(i, k) = sig(i, k)
-
-        ! dtmin(i,k)=100.0
-        ! do 97 j=icb(i),k-1 ! mauvaise vectorisation
-        ! dtmin(i,k)=AMIN1(dtmin(i,k),buoy(i,j))
-        ! 97     continue
-
-        sig(i, k) = beta*sig(i, k) + alpha*dtmin(i, k)*abs(dtmin(i,k))
-        sig(i, k) = amax1(sig(i,k), 0.0)
-        sig(i, k) = amin1(sig(i,k), 0.01)
-        fac = amin1(((dtcrit-dtmin(i,k))/dtcrit), 1.0)
-        w = (1.-beta)*fac*sqrt(cape(i)) + beta*w0(i, k)
-        amu = 0.5*(sig(i,k)+sigold(i,k))*w
-        m(i, k) = amu*0.007*p(i, k)*(ph(i,k)-ph(i,k+1))/tv(i, k)
-        w0(i, k) = w
-      END IF
-
-    END DO
-  END DO
-
-  DO i = 1, ncum
-    w0(i, icb(i)) = 0.5*w0(i, icb(i)+1)
-    m(i, icb(i)) = 0.5*m(i, icb(i)+1)*(ph(i,icb(i))-ph(i,icb(i)+1))/ &
-      (ph(i,icb(i)+1)-ph(i,icb(i)+2))
-    sig(i, icb(i)) = sig(i, icb(i)+1)
-    sig(i, icb(i)-1) = sig(i, icb(i))
-  END DO
-
-
-  ! !      cape=0.0
-  ! !      do 98 i=icb+1,inb
-  ! !         deltap = min(pbase,ph(i-1))-min(pbase,ph(i))
-  ! !         cape=cape+rrd*buoy(i-1)*deltap/p(i-1)
-  ! !         dcape=rrd*buoy(i-1)*deltap/p(i-1)
-  ! !         dlnp=deltap/p(i-1)
-  ! !         cape=amax1(0.0,cape)
-  ! !         sigold=sig(i)
-
-  ! !         dtmin=100.0
-  ! !         do 97 j=icb,i-1
-  ! !            dtmin=amin1(dtmin,buoy(j))
-  ! !   97    continue
-
-  ! !         sig(i)=beta*sig(i)+alpha*dtmin*abs(dtmin)
-  ! !         sig(i)=amax1(sig(i),0.0)
-  ! !         sig(i)=amin1(sig(i),0.01)
-  ! !         fac=amin1(((dtcrit-dtmin)/dtcrit),1.0)
-  ! !         w=(1.-beta)*fac*sqrt(cape)+beta*w0(i)
-  ! !         amu=0.5*(sig(i)+sigold)*w
-  ! !         m(i)=amu*0.007*p(i)*(ph(i)-ph(i+1))/tv(i)
-  ! !         w0(i)=w
-  ! !   98 continue
-  ! !      w0(icb)=0.5*w0(icb+1)
-  ! !      m(icb)=0.5*m(icb+1)*(ph(icb)-ph(icb+1))/(ph(icb+1)-ph(icb+2))
-  ! !      sig(icb)=sig(icb+1)
-  ! !      sig(icb-1)=sig(icb)
-
-  RETURN
-END SUBROUTINE cv30_closure
-
-SUBROUTINE cv30_mixing(nloc, ncum, nd, na, ntra, icb, nk, inb, ph, t, rr, rs, &
-    u, v, tra, h, lv, qnk, hp, tv, tvp, ep, clw, m, sig, ment, qent, uent, &
-    vent, sij, elij, ments, qents, traent)
-  IMPLICIT NONE
-
-  ! ---------------------------------------------------------------------
-  ! a faire:
-  ! - changer rr(il,1) -> qnk(il)
-  ! - vectorisation de la partie normalisation des flux (do 789...)
-  ! ---------------------------------------------------------------------
-
-  include "cvthermo.h"
-  include "cv30param.h"
-
-  ! inputs:
-  INTEGER ncum, nd, na, ntra, nloc
-  INTEGER icb(nloc), inb(nloc), nk(nloc)
-  REAL sig(nloc, nd)
-  REAL qnk(nloc)
-  REAL ph(nloc, nd+1)
-  REAL t(nloc, nd), rr(nloc, nd), rs(nloc, nd)
-  REAL u(nloc, nd), v(nloc, nd)
-  REAL tra(nloc, nd, ntra) ! input of convect3
-  REAL lv(nloc, na), h(nloc, na), hp(nloc, na)
-  REAL tv(nloc, na), tvp(nloc, na), ep(nloc, na), clw(nloc, na)
-  REAL m(nloc, na) ! input of convect3
-
-  ! outputs:
-  REAL ment(nloc, na, na), qent(nloc, na, na)
-  REAL uent(nloc, na, na), vent(nloc, na, na)
-  REAL sij(nloc, na, na), elij(nloc, na, na)
-  REAL traent(nloc, nd, nd, ntra)
-  REAL ments(nloc, nd, nd), qents(nloc, nd, nd)
-  REAL sigij(nloc, nd, nd)
-
-  ! local variables:
-  INTEGER i, j, k, il, im, jm
-  INTEGER num1, num2
-  INTEGER nent(nloc, na)
-  REAL rti, bf2, anum, denom, dei, altem, cwat, stemp, qp
-  REAL alt, smid, sjmin, sjmax, delp, delm
-  REAL asij(nloc), smax(nloc), scrit(nloc)
-  REAL asum(nloc, nd), bsum(nloc, nd), csum(nloc, nd)
-  REAL wgh
-  REAL zm(nloc, na)
-  LOGICAL lwork(nloc)
-
-  ! =====================================================================
-  ! --- INITIALIZE VARIOUS ARRAYS USED IN THE COMPUTATIONS
-  ! =====================================================================
-
-  ! ori        do 360 i=1,ncum*nlp
-  DO j = 1, nl
-    DO i = 1, ncum
-      nent(i, j) = 0
-      ! in convect3, m is computed in cv3_closure
-      ! ori          m(i,1)=0.0
-    END DO
-  END DO
-
-  ! ori      do 400 k=1,nlp
-  ! ori       do 390 j=1,nlp
-  DO j = 1, nl
-    DO k = 1, nl
-      DO i = 1, ncum
-        qent(i, k, j) = rr(i, j)
-        uent(i, k, j) = u(i, j)
-        vent(i, k, j) = v(i, j)
-        elij(i, k, j) = 0.0
-        ! ym            ment(i,k,j)=0.0
-        ! ym            sij(i,k,j)=0.0
-      END DO
-    END DO
-  END DO
-
-  ! ym
-  ment(1:ncum, 1:nd, 1:nd) = 0.0
-  sij(1:ncum, 1:nd, 1:nd) = 0.0
-
-  ! do k=1,ntra
-  ! do j=1,nd  ! instead nlp
-  ! do i=1,nd ! instead nlp
-  ! do il=1,ncum
-  ! traent(il,i,j,k)=tra(il,j,k)
-  ! enddo
-  ! enddo
-  ! enddo
-  ! enddo
-  zm(:, :) = 0.
-
-  ! =====================================================================
-  ! --- CALCULATE ENTRAINED AIR MASS FLUX (ment), TOTAL WATER MIXING
-  ! --- RATIO (QENT), TOTAL CONDENSED WATER (elij), AND MIXING
-  ! --- FRACTION (sij)
-  ! =====================================================================
-
-  DO i = minorig + 1, nl
-
-    DO j = minorig, nl
-      DO il = 1, ncum
-        IF ((i>=icb(il)) .AND. (i<=inb(il)) .AND. (j>=(icb(il)- &
-            1)) .AND. (j<=inb(il))) THEN
-
-          rti = rr(il, 1) - ep(il, i)*clw(il, i)
-          bf2 = 1. + lv(il, j)*lv(il, j)*rs(il, j)/(rrv*t(il,j)*t(il,j)*cpd)
-          anum = h(il, j) - hp(il, i) + (cpv-cpd)*t(il, j)*(rti-rr(il,j))
-          denom = h(il, i) - hp(il, i) + (cpd-cpv)*(rr(il,i)-rti)*t(il, j)
-          dei = denom
-          IF (abs(dei)<0.01) dei = 0.01
-          sij(il, i, j) = anum/dei
-          sij(il, i, i) = 1.0
-          altem = sij(il, i, j)*rr(il, i) + (1.-sij(il,i,j))*rti - rs(il, j)
-          altem = altem/bf2
-          cwat = clw(il, j)*(1.-ep(il,j))
-          stemp = sij(il, i, j)
-          IF ((stemp<0.0 .OR. stemp>1.0 .OR. altem>cwat) .AND. j>i) THEN
-            anum = anum - lv(il, j)*(rti-rs(il,j)-cwat*bf2)
-            denom = denom + lv(il, j)*(rr(il,i)-rti)
-            IF (abs(denom)<0.01) denom = 0.01
-            sij(il, i, j) = anum/denom
-            altem = sij(il, i, j)*rr(il, i) + (1.-sij(il,i,j))*rti - &
-              rs(il, j)
-            altem = altem - (bf2-1.)*cwat
-          END IF
-          IF (sij(il,i,j)>0.0 .AND. sij(il,i,j)<0.95) THEN
-            qent(il, i, j) = sij(il, i, j)*rr(il, i) + (1.-sij(il,i,j))*rti
-            uent(il, i, j) = sij(il, i, j)*u(il, i) + &
-              (1.-sij(il,i,j))*u(il, nk(il))
-            vent(il, i, j) = sij(il, i, j)*v(il, i) + &
-              (1.-sij(il,i,j))*v(il, nk(il))
-            ! !!!      do k=1,ntra
-            ! !!!      traent(il,i,j,k)=sij(il,i,j)*tra(il,i,k)
-            ! !!!     :      +(1.-sij(il,i,j))*tra(il,nk(il),k)
-            ! !!!      end do
-            elij(il, i, j) = altem
-            elij(il, i, j) = amax1(0.0, elij(il,i,j))
-            ment(il, i, j) = m(il, i)/(1.-sij(il,i,j))
-            nent(il, i) = nent(il, i) + 1
-          END IF
-          sij(il, i, j) = amax1(0.0, sij(il,i,j))
-          sij(il, i, j) = amin1(1.0, sij(il,i,j))
-        END IF ! new
-      END DO
-    END DO
-
-    ! do k=1,ntra
-    ! do j=minorig,nl
-    ! do il=1,ncum
-    ! if( (i.ge.icb(il)).and.(i.le.inb(il)).and.
-    ! :       (j.ge.(icb(il)-1)).and.(j.le.inb(il)))then
-    ! traent(il,i,j,k)=sij(il,i,j)*tra(il,i,k)
-    ! :            +(1.-sij(il,i,j))*tra(il,nk(il),k)
-    ! endif
-    ! enddo
-    ! enddo
-    ! enddo
-
-
-    ! ***   if no air can entrain at level i assume that updraft detrains
-    ! ***
-    ! ***   at that level and calculate detrained air flux and properties
-    ! ***
-
-
-    ! @      do 170 i=icb(il),inb(il)
-
-    DO il = 1, ncum
-      IF ((i>=icb(il)) .AND. (i<=inb(il)) .AND. (nent(il,i)==0)) THEN
-        ! @      if(nent(il,i).eq.0)then
-        ment(il, i, i) = m(il, i)
-        qent(il, i, i) = rr(il, nk(il)) - ep(il, i)*clw(il, i)
-        uent(il, i, i) = u(il, nk(il))
-        vent(il, i, i) = v(il, nk(il))
-        elij(il, i, i) = clw(il, i)
-        ! MAF      sij(il,i,i)=1.0
-        sij(il, i, i) = 0.0
-      END IF
-    END DO
-  END DO
-
-  ! do j=1,ntra
-  ! do i=minorig+1,nl
-  ! do il=1,ncum
-  ! if (i.ge.icb(il) .and. i.le.inb(il) .and. nent(il,i).eq.0) then
-  ! traent(il,i,i,j)=tra(il,nk(il),j)
-  ! endif
-  ! enddo
-  ! enddo
-  ! enddo
-
-  DO j = minorig, nl
-    DO i = minorig, nl
-      DO il = 1, ncum
-        IF ((j>=(icb(il)-1)) .AND. (j<=inb(il)) .AND. (i>=icb(il)) .AND. (i<= &
-            inb(il))) THEN
-          sigij(il, i, j) = sij(il, i, j)
-        END IF
-      END DO
-    END DO
-  END DO
-  ! @      enddo
-
-  ! @170   continue
-
-  ! =====================================================================
-  ! ---  NORMALIZE ENTRAINED AIR MASS FLUXES
-  ! ---  TO REPRESENT EQUAL PROBABILITIES OF MIXING
-  ! =====================================================================
-
-  ! ym      call zilch(asum,ncum*nd)
-  ! ym      call zilch(bsum,ncum*nd)
-  ! ym      call zilch(csum,ncum*nd)
-  CALL zilch(asum, nloc*nd)
-  CALL zilch(csum, nloc*nd)
-  CALL zilch(csum, nloc*nd)
-
-  DO il = 1, ncum
-    lwork(il) = .FALSE.
-  END DO
-
-  DO i = minorig + 1, nl
-
-    num1 = 0
-    DO il = 1, ncum
-      IF (i>=icb(il) .AND. i<=inb(il)) num1 = num1 + 1
-    END DO
-    IF (num1<=0) GO TO 789
-
-
-    DO il = 1, ncum
-      IF (i>=icb(il) .AND. i<=inb(il)) THEN
-        lwork(il) = (nent(il,i)/=0)
-        qp = rr(il, 1) - ep(il, i)*clw(il, i)
-        anum = h(il, i) - hp(il, i) - lv(il, i)*(qp-rs(il,i)) + &
-          (cpv-cpd)*t(il, i)*(qp-rr(il,i))
-        denom = h(il, i) - hp(il, i) + lv(il, i)*(rr(il,i)-qp) + &
-          (cpd-cpv)*t(il, i)*(rr(il,i)-qp)
-        IF (abs(denom)<0.01) denom = 0.01
-        scrit(il) = anum/denom
-        alt = qp - rs(il, i) + scrit(il)*(rr(il,i)-qp)
-        IF (scrit(il)<=0.0 .OR. alt<=0.0) scrit(il) = 1.0
-        smax(il) = 0.0
-        asij(il) = 0.0
-      END IF
-    END DO
-
-    DO j = nl, minorig, -1
-
-      num2 = 0
-      DO il = 1, ncum
-        IF (i>=icb(il) .AND. i<=inb(il) .AND. j>=(icb( &
-          il)-1) .AND. j<=inb(il) .AND. lwork(il)) num2 = num2 + 1
-      END DO
-      IF (num2<=0) GO TO 175
-
-      DO il = 1, ncum
-        IF (i>=icb(il) .AND. i<=inb(il) .AND. j>=(icb( &
-            il)-1) .AND. j<=inb(il) .AND. lwork(il)) THEN
-
-          IF (sij(il,i,j)>1.0E-16 .AND. sij(il,i,j)<0.95) THEN
-            wgh = 1.0
-            IF (j>i) THEN
-              sjmax = amax1(sij(il,i,j+1), smax(il))
-              sjmax = amin1(sjmax, scrit(il))
-              smax(il) = amax1(sij(il,i,j), smax(il))
-              sjmin = amax1(sij(il,i,j-1), smax(il))
-              sjmin = amin1(sjmin, scrit(il))
-              IF (sij(il,i,j)<(smax(il)-1.0E-16)) wgh = 0.0
-              smid = amin1(sij(il,i,j), scrit(il))
-            ELSE
-              sjmax = amax1(sij(il,i,j+1), scrit(il))
-              smid = amax1(sij(il,i,j), scrit(il))
-              sjmin = 0.0
-              IF (j>1) sjmin = sij(il, i, j-1)
-              sjmin = amax1(sjmin, scrit(il))
-            END IF
-            delp = abs(sjmax-smid)
-            delm = abs(sjmin-smid)
-            asij(il) = asij(il) + wgh*(delp+delm)
-            ment(il, i, j) = ment(il, i, j)*(delp+delm)*wgh
-          END IF
-        END IF
-      END DO
-
-175 END DO
-
-    DO il = 1, ncum
-      IF (i>=icb(il) .AND. i<=inb(il) .AND. lwork(il)) THEN
-        asij(il) = amax1(1.0E-16, asij(il))
-        asij(il) = 1.0/asij(il)
-        asum(il, i) = 0.0
-        bsum(il, i) = 0.0
-        csum(il, i) = 0.0
-      END IF
-    END DO
-
-    DO j = minorig, nl
-      DO il = 1, ncum
-        IF (i>=icb(il) .AND. i<=inb(il) .AND. lwork(il) .AND. j>=(icb( &
-            il)-1) .AND. j<=inb(il)) THEN
-          ment(il, i, j) = ment(il, i, j)*asij(il)
-        END IF
-      END DO
-    END DO
-
-    DO j = minorig, nl
-      DO il = 1, ncum
-        IF (i>=icb(il) .AND. i<=inb(il) .AND. lwork(il) .AND. j>=(icb( &
-            il)-1) .AND. j<=inb(il)) THEN
-          asum(il, i) = asum(il, i) + ment(il, i, j)
-          ment(il, i, j) = ment(il, i, j)*sig(il, j)
-          bsum(il, i) = bsum(il, i) + ment(il, i, j)
-        END IF
-      END DO
-    END DO
-
-    DO il = 1, ncum
-      IF (i>=icb(il) .AND. i<=inb(il) .AND. lwork(il)) THEN
-        bsum(il, i) = amax1(bsum(il,i), 1.0E-16)
-        bsum(il, i) = 1.0/bsum(il, i)
-      END IF
-    END DO
-
-    DO j = minorig, nl
-      DO il = 1, ncum
-        IF (i>=icb(il) .AND. i<=inb(il) .AND. lwork(il) .AND. j>=(icb( &
-            il)-1) .AND. j<=inb(il)) THEN
-          ment(il, i, j) = ment(il, i, j)*asum(il, i)*bsum(il, i)
-        END IF
-      END DO
-    END DO
-
-    DO j = minorig, nl
-      DO il = 1, ncum
-        IF (i>=icb(il) .AND. i<=inb(il) .AND. lwork(il) .AND. j>=(icb( &
-            il)-1) .AND. j<=inb(il)) THEN
-          csum(il, i) = csum(il, i) + ment(il, i, j)
-        END IF
-      END DO
-    END DO
-
-    DO il = 1, ncum
-      IF (i>=icb(il) .AND. i<=inb(il) .AND. lwork(il) .AND. &
-          csum(il,i)<m(il,i)) THEN
-        nent(il, i) = 0
-        ment(il, i, i) = m(il, i)
-        qent(il, i, i) = rr(il, 1) - ep(il, i)*clw(il, i)
-        uent(il, i, i) = u(il, nk(il))
-        vent(il, i, i) = v(il, nk(il))
-        elij(il, i, i) = clw(il, i)
-        ! MAF        sij(il,i,i)=1.0
-        sij(il, i, i) = 0.0
-      END IF
-    END DO ! il
-
-    ! do j=1,ntra
-    ! do il=1,ncum
-    ! if ( i.ge.icb(il) .and. i.le.inb(il) .and. lwork(il)
-    ! :     .and. csum(il,i).lt.m(il,i) ) then
-    ! traent(il,i,i,j)=tra(il,nk(il),j)
-    ! endif
-    ! enddo
-    ! enddo
-789 END DO
-
-  ! MAF: renormalisation de MENT
-  DO jm = 1, nd
-    DO im = 1, nd
-      DO il = 1, ncum
-        zm(il, im) = zm(il, im) + (1.-sij(il,im,jm))*ment(il, im, jm)
-      END DO
-    END DO
-  END DO
-
-  DO jm = 1, nd
-    DO im = 1, nd
-      DO il = 1, ncum
-        IF (zm(il,im)/=0.) THEN
-          ment(il, im, jm) = ment(il, im, jm)*m(il, im)/zm(il, im)
-        END IF
-      END DO
-    END DO
-  END DO
-
-  DO jm = 1, nd
-    DO im = 1, nd
-      DO il = 1, ncum
-        qents(il, im, jm) = qent(il, im, jm)
-        ments(il, im, jm) = ment(il, im, jm)
-      END DO
-    END DO
-  END DO
-
-  RETURN
-END SUBROUTINE cv30_mixing
-
-
-SUBROUTINE cv30_unsat(nloc, ncum, nd, na, ntra, icb, inb, t, rr, rs, gz, u, &
-    v, tra, p, ph, th, tv, lv, cpn, ep, sigp, clw, m, ment, elij, delt, plcl, &
-    mp, rp, up, vp, trap, wt, water, evap, b & ! RomP-jyg
-    , wdtraina, wdtrainm) ! 26/08/10  RomP-jyg
-  IMPLICIT NONE
-
-
-  include "cvthermo.h"
-  include "cv30param.h"
-  include "cvflag.h"
-
-  ! inputs:
-  INTEGER ncum, nd, na, ntra, nloc
-  INTEGER icb(nloc), inb(nloc)
-  REAL delt, plcl(nloc)
-  REAL t(nloc, nd), rr(nloc, nd), rs(nloc, nd)
-  REAL u(nloc, nd), v(nloc, nd)
-  REAL tra(nloc, nd, ntra)
-  REAL p(nloc, nd), ph(nloc, nd+1)
-  REAL th(nloc, na), gz(nloc, na)
-  REAL lv(nloc, na), ep(nloc, na), sigp(nloc, na), clw(nloc, na)
-  REAL cpn(nloc, na), tv(nloc, na)
-  REAL m(nloc, na), ment(nloc, na, na), elij(nloc, na, na)
-
-  ! outputs:
-  REAL mp(nloc, na), rp(nloc, na), up(nloc, na), vp(nloc, na)
-  REAL water(nloc, na), evap(nloc, na), wt(nloc, na)
-  REAL trap(nloc, na, ntra)
-  REAL b(nloc, na)
-  ! 25/08/10 - RomP---- ajout des masses precipitantes ejectees
-  ! lascendance adiabatique et des flux melanges Pa et Pm.
-  ! Distinction des wdtrain
-  ! Pa = wdtrainA     Pm = wdtrainM
-  REAL wdtraina(nloc, na), wdtrainm(nloc, na)
-
-  ! local variables
-  INTEGER i, j, k, il, num1
-  REAL tinv, delti
-  REAL awat, afac, afac1, afac2, bfac
-  REAL pr1, pr2, sigt, b6, c6, revap, tevap, delth
-  REAL amfac, amp2, xf, tf, fac2, ur, sru, fac, d, af, bf
-  REAL ampmax
-  REAL lvcp(nloc, na)
-  REAL wdtrain(nloc)
-  LOGICAL lwork(nloc)
-
-
-  ! ------------------------------------------------------
-
-  delti = 1./delt
-  tinv = 1./3.
-
-  mp(:, :) = 0.
-
-  DO i = 1, nl
-    DO il = 1, ncum
-      mp(il, i) = 0.0
-      rp(il, i) = rr(il, i)
-      up(il, i) = u(il, i)
-      vp(il, i) = v(il, i)
-      wt(il, i) = 0.001
-      water(il, i) = 0.0
-      evap(il, i) = 0.0
-      b(il, i) = 0.0
-      lvcp(il, i) = lv(il, i)/cpn(il, i)
-    END DO
-  END DO
-
-  ! do k=1,ntra
-  ! do i=1,nd
-  ! do il=1,ncum
-  ! trap(il,i,k)=tra(il,i,k)
-  ! enddo
-  ! enddo
-  ! enddo
-  ! ! RomP >>>
-  DO i = 1, nd
-    DO il = 1, ncum
-      wdtraina(il, i) = 0.0
-      wdtrainm(il, i) = 0.0
-    END DO
-  END DO
-  ! ! RomP <<<
-
-  ! ***  check whether ep(inb)=0, if so, skip precipitating    ***
-  ! ***             downdraft calculation                      ***
-
-
-  DO il = 1, ncum
-    lwork(il) = .TRUE.
-    IF (ep(il,inb(il))<0.0001) lwork(il) = .FALSE.
-  END DO
-
-  CALL zilch(wdtrain, ncum)
-
-  DO i = nl + 1, 1, -1
-
-    num1 = 0
-    DO il = 1, ncum
-      IF (i<=inb(il) .AND. lwork(il)) num1 = num1 + 1
-    END DO
-    IF (num1<=0) GO TO 400
-
-
-    ! ***  integrate liquid water equation to find condensed water   ***
-    ! ***                and condensed water flux                    ***
-
-
-
-    ! ***                    begin downdraft loop                    ***
-
-
-
-    ! ***              calculate detrained precipitation             ***
-
-    DO il = 1, ncum
-      IF (i<=inb(il) .AND. lwork(il)) THEN
-        IF (cvflag_grav) THEN
-          wdtrain(il) = grav*ep(il, i)*m(il, i)*clw(il, i)
-          wdtraina(il, i) = wdtrain(il)/grav !   Pa  26/08/10   RomP
-        ELSE
-          wdtrain(il) = 10.0*ep(il, i)*m(il, i)*clw(il, i)
-          wdtraina(il, i) = wdtrain(il)/10. !   Pa  26/08/10   RomP
-        END IF
-      END IF
-    END DO
-
-    IF (i>1) THEN
-
-      DO j = 1, i - 1
-        DO il = 1, ncum
-          IF (i<=inb(il) .AND. lwork(il)) THEN
-            awat = elij(il, j, i) - (1.-ep(il,i))*clw(il, i)
-            awat = amax1(awat, 0.0)
-            IF (cvflag_grav) THEN
-              wdtrain(il) = wdtrain(il) + grav*awat*ment(il, j, i)
-            ELSE
-              wdtrain(il) = wdtrain(il) + 10.0*awat*ment(il, j, i)
-            END IF
-          END IF
-        END DO
-      END DO
-      DO il = 1, ncum
-        IF (cvflag_grav) THEN
-          wdtrainm(il, i) = wdtrain(il)/grav - wdtraina(il, i) !   Pm  26/08/10   RomP
-        ELSE
-          wdtrainm(il, i) = wdtrain(il)/10. - wdtraina(il, i) !   Pm  26/08/10   RomP
-        END IF
-      END DO
-
-    END IF
-
-
-    ! ***    find rain water and evaporation using provisional   ***
-    ! ***              estimates of rp(i)and rp(i-1)             ***
-
-
-    DO il = 1, ncum
-
-      IF (i<=inb(il) .AND. lwork(il)) THEN
-
-        wt(il, i) = 45.0
-
-        IF (i<inb(il)) THEN
-          rp(il, i) = rp(il, i+1) + (cpd*(t(il,i+1)-t(il, &
-            i))+gz(il,i+1)-gz(il,i))/lv(il, i)
-          rp(il, i) = 0.5*(rp(il,i)+rr(il,i))
-        END IF
-        rp(il, i) = amax1(rp(il,i), 0.0)
-        rp(il, i) = amin1(rp(il,i), rs(il,i))
-        rp(il, inb(il)) = rr(il, inb(il))
-
-        IF (i==1) THEN
-          afac = p(il, 1)*(rs(il,1)-rp(il,1))/(1.0E4+2000.0*p(il,1)*rs(il,1))
-        ELSE
-          rp(il, i-1) = rp(il, i) + (cpd*(t(il,i)-t(il, &
-            i-1))+gz(il,i)-gz(il,i-1))/lv(il, i)
-          rp(il, i-1) = 0.5*(rp(il,i-1)+rr(il,i-1))
-          rp(il, i-1) = amin1(rp(il,i-1), rs(il,i-1))
-          rp(il, i-1) = amax1(rp(il,i-1), 0.0)
-          afac1 = p(il, i)*(rs(il,i)-rp(il,i))/(1.0E4+2000.0*p(il,i)*rs(il,i) &
-            )
-          afac2 = p(il, i-1)*(rs(il,i-1)-rp(il,i-1))/ &
-            (1.0E4+2000.0*p(il,i-1)*rs(il,i-1))
-          afac = 0.5*(afac1+afac2)
-        END IF
-        IF (i==inb(il)) afac = 0.0
-        afac = amax1(afac, 0.0)
-        bfac = 1./(sigd*wt(il,i))
-
-        ! jyg1
-        ! cc        sigt=1.0
-        ! cc        if(i.ge.icb)sigt=sigp(i)
-        ! prise en compte de la variation progressive de sigt dans
-        ! les couches icb et icb-1:
-        ! pour plcl<ph(i+1), pr1=0 & pr2=1
-        ! pour plcl>ph(i),   pr1=1 & pr2=0
-        ! pour ph(i+1)<plcl<ph(i), pr1 est la proportion a cheval
-        ! sur le nuage, et pr2 est la proportion sous la base du
-        ! nuage.
-        pr1 = (plcl(il)-ph(il,i+1))/(ph(il,i)-ph(il,i+1))
-        pr1 = max(0., min(1.,pr1))
-        pr2 = (ph(il,i)-plcl(il))/(ph(il,i)-ph(il,i+1))
-        pr2 = max(0., min(1.,pr2))
-        sigt = sigp(il, i)*pr1 + pr2
-        ! jyg2
-
-        b6 = bfac*50.*sigd*(ph(il,i)-ph(il,i+1))*sigt*afac
-        c6 = water(il, i+1) + bfac*wdtrain(il) - 50.*sigd*bfac*(ph(il,i)-ph( &
-          il,i+1))*evap(il, i+1)
-        IF (c6>0.0) THEN
-          revap = 0.5*(-b6+sqrt(b6*b6+4.*c6))
-          evap(il, i) = sigt*afac*revap
-          water(il, i) = revap*revap
-        ELSE
-          evap(il, i) = -evap(il, i+1) + 0.02*(wdtrain(il)+sigd*wt(il,i)* &
-            water(il,i+1))/(sigd*(ph(il,i)-ph(il,i+1)))
-        END IF
-
-        ! ***  calculate precipitating downdraft mass flux under     ***
-        ! ***              hydrostatic approximation                 ***
-
-        IF (i/=1) THEN
-
-          tevap = amax1(0.0, evap(il,i))
-          delth = amax1(0.001, (th(il,i)-th(il,i-1)))
-          IF (cvflag_grav) THEN
-            mp(il, i) = 100.*ginv*lvcp(il, i)*sigd*tevap*(p(il,i-1)-p(il,i))/ &
-              delth
-          ELSE
-            mp(il, i) = 10.*lvcp(il, i)*sigd*tevap*(p(il,i-1)-p(il,i))/delth
-          END IF
-
-          ! ***           if hydrostatic assumption fails,             ***
-          ! ***   solve cubic difference equation for downdraft theta  ***
-          ! ***  and mass flux from two simultaneous differential eqns ***
-
-          amfac = sigd*sigd*70.0*ph(il, i)*(p(il,i-1)-p(il,i))* &
-            (th(il,i)-th(il,i-1))/(tv(il,i)*th(il,i))
-          amp2 = abs(mp(il,i+1)*mp(il,i+1)-mp(il,i)*mp(il,i))
-          IF (amp2>(0.1*amfac)) THEN
-            xf = 100.0*sigd*sigd*sigd*(ph(il,i)-ph(il,i+1))
-            tf = b(il, i) - 5.0*(th(il,i)-th(il,i-1))*t(il, i)/(lvcp(il,i)* &
-              sigd*th(il,i))
-            af = xf*tf + mp(il, i+1)*mp(il, i+1)*tinv
-            bf = 2.*(tinv*mp(il,i+1))**3 + tinv*mp(il, i+1)*xf*tf + &
-              50.*(p(il,i-1)-p(il,i))*xf*tevap
-            fac2 = 1.0
-            IF (bf<0.0) fac2 = -1.0
-            bf = abs(bf)
-            ur = 0.25*bf*bf - af*af*af*tinv*tinv*tinv
-            IF (ur>=0.0) THEN
-              sru = sqrt(ur)
-              fac = 1.0
-              IF ((0.5*bf-sru)<0.0) fac = -1.0
-              mp(il, i) = mp(il, i+1)*tinv + (0.5*bf+sru)**tinv + &
-                fac*(abs(0.5*bf-sru))**tinv
-            ELSE
-              d = atan(2.*sqrt(-ur)/(bf+1.0E-28))
-              IF (fac2<0.0) d = 3.14159 - d
-              mp(il, i) = mp(il, i+1)*tinv + 2.*sqrt(af*tinv)*cos(d*tinv)
-            END IF
-            mp(il, i) = amax1(0.0, mp(il,i))
-
-            IF (cvflag_grav) THEN
-              ! jyg : il y a vraisemblablement une erreur dans la ligne 2
-              ! suivante:
-              ! il faut diviser par (mp(il,i)*sigd*grav) et non par
-              ! (mp(il,i)+sigd*0.1).
-              ! Et il faut bien revoir les facteurs 100.
-              b(il, i-1) = b(il, i) + 100.0*(p(il,i-1)-p(il,i))*tevap/(mp(il, &
-                i)+sigd*0.1) - 10.0*(th(il,i)-th(il,i-1))*t(il, i)/(lvcp(il,i &
-                )*sigd*th(il,i))
-            ELSE
-              b(il, i-1) = b(il, i) + 100.0*(p(il,i-1)-p(il,i))*tevap/(mp(il, &
-                i)+sigd*0.1) - 10.0*(th(il,i)-th(il,i-1))*t(il, i)/(lvcp(il,i &
-                )*sigd*th(il,i))
-            END IF
-            b(il, i-1) = amax1(b(il,i-1), 0.0)
-          END IF
-
-          ! ***         limit magnitude of mp(i) to meet cfl condition
-          ! ***
-
-          ampmax = 2.0*(ph(il,i)-ph(il,i+1))*delti
-          amp2 = 2.0*(ph(il,i-1)-ph(il,i))*delti
-          ampmax = amin1(ampmax, amp2)
-          mp(il, i) = amin1(mp(il,i), ampmax)
-
-          ! ***      force mp to decrease linearly to zero
-          ! ***
-          ! ***       between cloud base and the surface
-          ! ***
-
-          IF (p(il,i)>p(il,icb(il))) THEN
-            mp(il, i) = mp(il, icb(il))*(p(il,1)-p(il,i))/ &
-              (p(il,1)-p(il,icb(il)))
-          END IF
-
-        END IF ! i.eq.1
-
-        ! ***       find mixing ratio of precipitating downdraft     ***
-
-
-        IF (i/=inb(il)) THEN
-
-          rp(il, i) = rr(il, i)
-
-          IF (mp(il,i)>mp(il,i+1)) THEN
-
-            IF (cvflag_grav) THEN
-              rp(il, i) = rp(il, i+1)*mp(il, i+1) + &
-                rr(il, i)*(mp(il,i)-mp(il,i+1)) + 100.*ginv*0.5*sigd*(ph(il,i &
-                )-ph(il,i+1))*(evap(il,i+1)+evap(il,i))
-            ELSE
-              rp(il, i) = rp(il, i+1)*mp(il, i+1) + &
-                rr(il, i)*(mp(il,i)-mp(il,i+1)) + 5.*sigd*(ph(il,i)-ph(il,i+1 &
-                ))*(evap(il,i+1)+evap(il,i))
-            END IF
-            rp(il, i) = rp(il, i)/mp(il, i)
-            up(il, i) = up(il, i+1)*mp(il, i+1) + u(il, i)*(mp(il,i)-mp(il,i+ &
-              1))
-            up(il, i) = up(il, i)/mp(il, i)
-            vp(il, i) = vp(il, i+1)*mp(il, i+1) + v(il, i)*(mp(il,i)-mp(il,i+ &
-              1))
-            vp(il, i) = vp(il, i)/mp(il, i)
-
-            ! do j=1,ntra
-            ! trap(il,i,j)=trap(il,i+1,j)*mp(il,i+1)
-            ! testmaf     :            +trap(il,i,j)*(mp(il,i)-mp(il,i+1))
-            ! :            +tra(il,i,j)*(mp(il,i)-mp(il,i+1))
-            ! trap(il,i,j)=trap(il,i,j)/mp(il,i)
-            ! end do
-
-          ELSE
-
-            IF (mp(il,i+1)>1.0E-16) THEN
-              IF (cvflag_grav) THEN
-                rp(il, i) = rp(il, i+1) + 100.*ginv*0.5*sigd*(ph(il,i)-ph(il, &
-                  i+1))*(evap(il,i+1)+evap(il,i))/mp(il, i+1)
-              ELSE
-                rp(il, i) = rp(il, i+1) + 5.*sigd*(ph(il,i)-ph(il,i+1))*(evap &
-                  (il,i+1)+evap(il,i))/mp(il, i+1)
-              END IF
-              up(il, i) = up(il, i+1)
-              vp(il, i) = vp(il, i+1)
-
-              ! do j=1,ntra
-              ! trap(il,i,j)=trap(il,i+1,j)
-              ! end do
-
-            END IF
-          END IF
-          rp(il, i) = amin1(rp(il,i), rs(il,i))
-          rp(il, i) = amax1(rp(il,i), 0.0)
-
-        END IF
-      END IF
-    END DO
-
-400 END DO
-
-  RETURN
-END SUBROUTINE cv30_unsat
-
-SUBROUTINE cv30_yield(nloc, ncum, nd, na, ntra, icb, inb, delt, t, rr, u, v, &
-    tra, gz, p, ph, h, hp, lv, cpn, th, ep, clw, m, tp, mp, rp, up, vp, trap, &
-    wt, water, evap, b, ment, qent, uent, vent, nent, elij, traent, sig, tv, &
-    tvp, iflag, precip, vprecip, ft, fr, fu, fv, ftra, upwd, dnwd, dnwd0, ma, &
-    mike, tls, tps, qcondc, wd)
-  IMPLICIT NONE
-
-  include "cvthermo.h"
-  include "cv30param.h"
-  include "cvflag.h"
-  include "conema3.h"
-
-  ! inputs:
-  INTEGER ncum, nd, na, ntra, nloc
-  INTEGER icb(nloc), inb(nloc)
-  REAL delt
-  REAL t(nloc, nd), rr(nloc, nd), u(nloc, nd), v(nloc, nd)
-  REAL tra(nloc, nd, ntra), sig(nloc, nd)
-  REAL gz(nloc, na), ph(nloc, nd+1), h(nloc, na), hp(nloc, na)
-  REAL th(nloc, na), p(nloc, nd), tp(nloc, na)
-  REAL lv(nloc, na), cpn(nloc, na), ep(nloc, na), clw(nloc, na)
-  REAL m(nloc, na), mp(nloc, na), rp(nloc, na), up(nloc, na)
-  REAL vp(nloc, na), wt(nloc, nd), trap(nloc, nd, ntra)
-  REAL water(nloc, na), evap(nloc, na), b(nloc, na)
-  REAL ment(nloc, na, na), qent(nloc, na, na), uent(nloc, na, na)
-  ! ym      real vent(nloc,na,na), nent(nloc,na), elij(nloc,na,na)
-  REAL vent(nloc, na, na), elij(nloc, na, na)
-  INTEGER nent(nloc, na)
-  REAL traent(nloc, na, na, ntra)
-  REAL tv(nloc, nd), tvp(nloc, nd)
-
-  ! input/output:
-  INTEGER iflag(nloc)
-
-  ! outputs:
-  REAL precip(nloc)
-  REAL vprecip(nloc, nd+1)
-  REAL ft(nloc, nd), fr(nloc, nd), fu(nloc, nd), fv(nloc, nd)
-  REAL ftra(nloc, nd, ntra)
-  REAL upwd(nloc, nd), dnwd(nloc, nd), ma(nloc, nd)
-  REAL dnwd0(nloc, nd), mike(nloc, nd)
-  REAL tls(nloc, nd), tps(nloc, nd)
-  REAL qcondc(nloc, nd) ! cld
-  REAL wd(nloc) ! gust
-
-  ! local variables:
-  INTEGER i, k, il, n, j, num1
-  REAL rat, awat, delti
-  REAL ax, bx, cx, dx, ex
-  REAL cpinv, rdcp, dpinv
-  REAL lvcp(nloc, na), mke(nloc, na)
-  REAL am(nloc), work(nloc), ad(nloc), amp1(nloc)
-  ! !!      real up1(nloc), dn1(nloc)
-  REAL up1(nloc, nd, nd), dn1(nloc, nd, nd)
-  REAL asum(nloc), bsum(nloc), csum(nloc), dsum(nloc)
-  REAL qcond(nloc, nd), nqcond(nloc, nd), wa(nloc, nd) ! cld
-  REAL siga(nloc, nd), sax(nloc, nd), mac(nloc, nd) ! cld
-
-
-  ! -------------------------------------------------------------
-
-  ! initialization:
-
-  delti = 1.0/delt
-
-  DO il = 1, ncum
-    precip(il) = 0.0
-    wd(il) = 0.0 ! gust
-    vprecip(il, nd+1) = 0.
-  END DO
-
-  DO i = 1, nd
-    DO il = 1, ncum
-      vprecip(il, i) = 0.0
-      ft(il, i) = 0.0
-      fr(il, i) = 0.0
-      fu(il, i) = 0.0
-      fv(il, i) = 0.0
-      qcondc(il, i) = 0.0 ! cld
-      qcond(il, i) = 0.0 ! cld
-      nqcond(il, i) = 0.0 ! cld
-    END DO
-  END DO
-
-  ! do j=1,ntra
-  ! do i=1,nd
-  ! do il=1,ncum
-  ! ftra(il,i,j)=0.0
-  ! enddo
-  ! enddo
-  ! enddo
-
-  DO i = 1, nl
-    DO il = 1, ncum
-      lvcp(il, i) = lv(il, i)/cpn(il, i)
-    END DO
-  END DO
-
-
-
-  ! ***  calculate surface precipitation in mm/day     ***
-
-  DO il = 1, ncum
-    IF (ep(il,inb(il))>=0.0001) THEN
-      IF (cvflag_grav) THEN
-        precip(il) = wt(il, 1)*sigd*water(il, 1)*86400.*1000./(rowl*grav)
-      ELSE
-        precip(il) = wt(il, 1)*sigd*water(il, 1)*8640.
-      END IF
-    END IF
-  END DO
-
-  ! ***  CALCULATE VERTICAL PROFILE OF  PRECIPITATIONs IN kg/m2/s  ===
-
-  ! MAF rajout pour lessivage
-  DO k = 1, nl
-    DO il = 1, ncum
-      IF (k<=inb(il)) THEN
-        IF (cvflag_grav) THEN
-          vprecip(il, k) = wt(il, k)*sigd*water(il, k)/grav
-        ELSE
-          vprecip(il, k) = wt(il, k)*sigd*water(il, k)/10.
-        END IF
-      END IF
-    END DO
-  END DO
-
-
-  ! ***  Calculate downdraft velocity scale    ***
-  ! ***  NE PAS UTILISER POUR L'INSTANT ***
-
-  ! !      do il=1,ncum
-  ! !        wd(il)=betad*abs(mp(il,icb(il)))*0.01*rrd*t(il,icb(il))
-  ! !     :                                  /(sigd*p(il,icb(il)))
-  ! !      enddo
-
-
-  ! ***  calculate tendencies of lowest level potential temperature  ***
-  ! ***                      and mixing ratio                        ***
-
-  DO il = 1, ncum
-    work(il) = 1.0/(ph(il,1)-ph(il,2))
-    am(il) = 0.0
-  END DO
-
-  DO k = 2, nl
-    DO il = 1, ncum
-      IF (k<=inb(il)) THEN
-        am(il) = am(il) + m(il, k)
-      END IF
-    END DO
-  END DO
-
-  DO il = 1, ncum
-
-    ! convect3      if((0.1*dpinv*am).ge.delti)iflag(il)=4
-    IF (cvflag_grav) THEN
-      IF ((0.01*grav*work(il)*am(il))>=delti) iflag(il) = 1 !consist vect
-      ft(il, 1) = 0.01*grav*work(il)*am(il)*(t(il,2)-t(il,1)+(gz(il,2)-gz(il, &
-        1))/cpn(il,1))
-    ELSE
-      IF ((0.1*work(il)*am(il))>=delti) iflag(il) = 1 !consistency vect
-      ft(il, 1) = 0.1*work(il)*am(il)*(t(il,2)-t(il,1)+(gz(il,2)-gz(il, &
-        1))/cpn(il,1))
-    END IF
-
-    ft(il, 1) = ft(il, 1) - 0.5*lvcp(il, 1)*sigd*(evap(il,1)+evap(il,2))
-
-    IF (cvflag_grav) THEN
-      ft(il, 1) = ft(il, 1) - 0.009*grav*sigd*mp(il, 2)*t(il, 1)*b(il, 1)* &
-        work(il)
-    ELSE
-      ft(il, 1) = ft(il, 1) - 0.09*sigd*mp(il, 2)*t(il, 1)*b(il, 1)*work(il)
-    END IF
-
-    ft(il, 1) = ft(il, 1) + 0.01*sigd*wt(il, 1)*(cl-cpd)*water(il, 2)*(t(il,2 &
-      )-t(il,1))*work(il)/cpn(il, 1)
-
-    IF (cvflag_grav) THEN
-      ! jyg1  Correction pour mieux conserver l'eau (conformite avec
-      ! CONVECT4.3)
-      ! (sb: pour l'instant, on ne fait que le chgt concernant grav, pas
-      ! evap)
-      fr(il, 1) = 0.01*grav*mp(il, 2)*(rp(il,2)-rr(il,1))*work(il) + &
-        sigd*0.5*(evap(il,1)+evap(il,2))
-      ! +tard     :          +sigd*evap(il,1)
-
-      fr(il, 1) = fr(il, 1) + 0.01*grav*am(il)*(rr(il,2)-rr(il,1))*work(il)
-
-      fu(il, 1) = fu(il, 1) + 0.01*grav*work(il)*(mp(il,2)*(up(il,2)-u(il, &
-        1))+am(il)*(u(il,2)-u(il,1)))
-      fv(il, 1) = fv(il, 1) + 0.01*grav*work(il)*(mp(il,2)*(vp(il,2)-v(il, &
-        1))+am(il)*(v(il,2)-v(il,1)))
-    ELSE ! cvflag_grav
-      fr(il, 1) = 0.1*mp(il, 2)*(rp(il,2)-rr(il,1))*work(il) + &
-        sigd*0.5*(evap(il,1)+evap(il,2))
-      fr(il, 1) = fr(il, 1) + 0.1*am(il)*(rr(il,2)-rr(il,1))*work(il)
-      fu(il, 1) = fu(il, 1) + 0.1*work(il)*(mp(il,2)*(up(il,2)-u(il, &
-        1))+am(il)*(u(il,2)-u(il,1)))
-      fv(il, 1) = fv(il, 1) + 0.1*work(il)*(mp(il,2)*(vp(il,2)-v(il, &
-        1))+am(il)*(v(il,2)-v(il,1)))
-    END IF ! cvflag_grav
-
-  END DO ! il
-
-  ! do j=1,ntra
-  ! do il=1,ncum
-  ! if (cvflag_grav) then
-  ! ftra(il,1,j)=ftra(il,1,j)+0.01*grav*work(il)
-  ! :                     *(mp(il,2)*(trap(il,2,j)-tra(il,1,j))
-  ! :             +am(il)*(tra(il,2,j)-tra(il,1,j)))
-  ! else
-  ! ftra(il,1,j)=ftra(il,1,j)+0.1*work(il)
-  ! :                     *(mp(il,2)*(trap(il,2,j)-tra(il,1,j))
-  ! :             +am(il)*(tra(il,2,j)-tra(il,1,j)))
-  ! endif
-  ! enddo
-  ! enddo
-
-  DO j = 2, nl
-    DO il = 1, ncum
-      IF (j<=inb(il)) THEN
-        IF (cvflag_grav) THEN
-          fr(il, 1) = fr(il, 1) + 0.01*grav*work(il)*ment(il, j, 1)*(qent(il, &
-            j,1)-rr(il,1))
-          fu(il, 1) = fu(il, 1) + 0.01*grav*work(il)*ment(il, j, 1)*(uent(il, &
-            j,1)-u(il,1))
-          fv(il, 1) = fv(il, 1) + 0.01*grav*work(il)*ment(il, j, 1)*(vent(il, &
-            j,1)-v(il,1))
-        ELSE ! cvflag_grav
-          fr(il, 1) = fr(il, 1) + 0.1*work(il)*ment(il, j, 1)*(qent(il,j,1)- &
-            rr(il,1))
-          fu(il, 1) = fu(il, 1) + 0.1*work(il)*ment(il, j, 1)*(uent(il,j,1)-u &
-            (il,1))
-          fv(il, 1) = fv(il, 1) + 0.1*work(il)*ment(il, j, 1)*(vent(il,j,1)-v &
-            (il,1))
-        END IF ! cvflag_grav
-      END IF ! j
-    END DO
-  END DO
-
-  ! do k=1,ntra
-  ! do j=2,nl
-  ! do il=1,ncum
-  ! if (j.le.inb(il)) then
-
-  ! if (cvflag_grav) then
-  ! ftra(il,1,k)=ftra(il,1,k)+0.01*grav*work(il)*ment(il,j,1)
-  ! :                *(traent(il,j,1,k)-tra(il,1,k))
-  ! else
-  ! ftra(il,1,k)=ftra(il,1,k)+0.1*work(il)*ment(il,j,1)
-  ! :                *(traent(il,j,1,k)-tra(il,1,k))
-  ! endif
-
-  ! endif
-  ! enddo
-  ! enddo
-  ! enddo
-
-
-  ! ***  calculate tendencies of potential temperature and mixing ratio  ***
-  ! ***               at levels above the lowest level                   ***
-
-  ! ***  first find the net saturated updraft and downdraft mass fluxes  ***
-  ! ***                      through each level                          ***
-
-
-  DO i = 2, nl + 1 ! newvecto: mettre nl au lieu nl+1?
-
-    num1 = 0
-    DO il = 1, ncum
-      IF (i<=inb(il)) num1 = num1 + 1
-    END DO
-    IF (num1<=0) GO TO 500
-
-    CALL zilch(amp1, ncum)
-    CALL zilch(ad, ncum)
-
-    DO k = i + 1, nl + 1
-      DO il = 1, ncum
-        IF (i<=inb(il) .AND. k<=(inb(il)+1)) THEN
-          amp1(il) = amp1(il) + m(il, k)
-        END IF
-      END DO
-    END DO
-
-    DO k = 1, i
-      DO j = i + 1, nl + 1
-        DO il = 1, ncum
-          IF (i<=inb(il) .AND. j<=(inb(il)+1)) THEN
-            amp1(il) = amp1(il) + ment(il, k, j)
-          END IF
-        END DO
-      END DO
-    END DO
-
-    DO k = 1, i - 1
-      DO j = i, nl + 1 ! newvecto: nl au lieu nl+1?
-        DO il = 1, ncum
-          IF (i<=inb(il) .AND. j<=inb(il)) THEN
-            ad(il) = ad(il) + ment(il, j, k)
-          END IF
-        END DO
-      END DO
-    END DO
-
-    DO il = 1, ncum
-      IF (i<=inb(il)) THEN
-        dpinv = 1.0/(ph(il,i)-ph(il,i+1))
-        cpinv = 1.0/cpn(il, i)
-
-        ! convect3      if((0.1*dpinv*amp1).ge.delti)iflag(il)=4
-        IF (cvflag_grav) THEN
-          IF ((0.01*grav*dpinv*amp1(il))>=delti) iflag(il) = 1 ! vecto
-        ELSE
-          IF ((0.1*dpinv*amp1(il))>=delti) iflag(il) = 1 ! vecto
-        END IF
-
-        IF (cvflag_grav) THEN
-          ft(il, i) = 0.01*grav*dpinv*(amp1(il)*(t(il,i+1)-t(il, &
-            i)+(gz(il,i+1)-gz(il,i))*cpinv)-ad(il)*(t(il,i)-t(il, &
-            i-1)+(gz(il,i)-gz(il,i-1))*cpinv)) - 0.5*sigd*lvcp(il, i)*(evap( &
-            il,i)+evap(il,i+1))
-          rat = cpn(il, i-1)*cpinv
-          ft(il, i) = ft(il, i) - 0.009*grav*sigd*(mp(il,i+1)*t(il,i)*b(il,i) &
-            -mp(il,i)*t(il,i-1)*rat*b(il,i-1))*dpinv
-          ft(il, i) = ft(il, i) + 0.01*grav*dpinv*ment(il, i, i)*(hp(il,i)-h( &
-            il,i)+t(il,i)*(cpv-cpd)*(rr(il,i)-qent(il,i,i)))*cpinv
-        ELSE ! cvflag_grav
-          ft(il, i) = 0.1*dpinv*(amp1(il)*(t(il,i+1)-t(il, &
-            i)+(gz(il,i+1)-gz(il,i))*cpinv)-ad(il)*(t(il,i)-t(il, &
-            i-1)+(gz(il,i)-gz(il,i-1))*cpinv)) - 0.5*sigd*lvcp(il, i)*(evap( &
-            il,i)+evap(il,i+1))
-          rat = cpn(il, i-1)*cpinv
-          ft(il, i) = ft(il, i) - 0.09*sigd*(mp(il,i+1)*t(il,i)*b(il,i)-mp(il &
-            ,i)*t(il,i-1)*rat*b(il,i-1))*dpinv
-          ft(il, i) = ft(il, i) + 0.1*dpinv*ment(il, i, i)*(hp(il,i)-h(il,i)+ &
-            t(il,i)*(cpv-cpd)*(rr(il,i)-qent(il,i,i)))*cpinv
-        END IF ! cvflag_grav
-
-
-        ft(il, i) = ft(il, i) + 0.01*sigd*wt(il, i)*(cl-cpd)*water(il, i+1)*( &
-          t(il,i+1)-t(il,i))*dpinv*cpinv
-
-        IF (cvflag_grav) THEN
-          fr(il, i) = 0.01*grav*dpinv*(amp1(il)*(rr(il,i+1)-rr(il, &
-            i))-ad(il)*(rr(il,i)-rr(il,i-1)))
-          fu(il, i) = fu(il, i) + 0.01*grav*dpinv*(amp1(il)*(u(il,i+1)-u(il, &
-            i))-ad(il)*(u(il,i)-u(il,i-1)))
-          fv(il, i) = fv(il, i) + 0.01*grav*dpinv*(amp1(il)*(v(il,i+1)-v(il, &
-            i))-ad(il)*(v(il,i)-v(il,i-1)))
-        ELSE ! cvflag_grav
-          fr(il, i) = 0.1*dpinv*(amp1(il)*(rr(il,i+1)-rr(il, &
-            i))-ad(il)*(rr(il,i)-rr(il,i-1)))
-          fu(il, i) = fu(il, i) + 0.1*dpinv*(amp1(il)*(u(il,i+1)-u(il, &
-            i))-ad(il)*(u(il,i)-u(il,i-1)))
-          fv(il, i) = fv(il, i) + 0.1*dpinv*(amp1(il)*(v(il,i+1)-v(il, &
-            i))-ad(il)*(v(il,i)-v(il,i-1)))
-        END IF ! cvflag_grav
-
-      END IF ! i
-    END DO
-
-    ! do k=1,ntra
-    ! do il=1,ncum
-    ! if (i.le.inb(il)) then
-    ! dpinv=1.0/(ph(il,i)-ph(il,i+1))
-    ! cpinv=1.0/cpn(il,i)
-    ! if (cvflag_grav) then
-    ! ftra(il,i,k)=ftra(il,i,k)+0.01*grav*dpinv
-    ! :         *(amp1(il)*(tra(il,i+1,k)-tra(il,i,k))
-    ! :           -ad(il)*(tra(il,i,k)-tra(il,i-1,k)))
-    ! else
-    ! ftra(il,i,k)=ftra(il,i,k)+0.1*dpinv
-    ! :         *(amp1(il)*(tra(il,i+1,k)-tra(il,i,k))
-    ! :           -ad(il)*(tra(il,i,k)-tra(il,i-1,k)))
-    ! endif
-    ! endif
-    ! enddo
-    ! enddo
-
-    DO k = 1, i - 1
-      DO il = 1, ncum
-        IF (i<=inb(il)) THEN
-          dpinv = 1.0/(ph(il,i)-ph(il,i+1))
-          cpinv = 1.0/cpn(il, i)
-
-          awat = elij(il, k, i) - (1.-ep(il,i))*clw(il, i)
-          awat = amax1(awat, 0.0)
-
-          IF (cvflag_grav) THEN
-            fr(il, i) = fr(il, i) + 0.01*grav*dpinv*ment(il, k, i)*(qent(il,k &
-              ,i)-awat-rr(il,i))
-            fu(il, i) = fu(il, i) + 0.01*grav*dpinv*ment(il, k, i)*(uent(il,k &
-              ,i)-u(il,i))
-            fv(il, i) = fv(il, i) + 0.01*grav*dpinv*ment(il, k, i)*(vent(il,k &
-              ,i)-v(il,i))
-          ELSE ! cvflag_grav
-            fr(il, i) = fr(il, i) + 0.1*dpinv*ment(il, k, i)*(qent(il,k,i)- &
-              awat-rr(il,i))
-            fu(il, i) = fu(il, i) + 0.01*grav*dpinv*ment(il, k, i)*(uent(il,k &
-              ,i)-u(il,i))
-            fv(il, i) = fv(il, i) + 0.1*dpinv*ment(il, k, i)*(vent(il,k,i)-v( &
-              il,i))
-          END IF ! cvflag_grav
-
-          ! (saturated updrafts resulting from mixing)        ! cld
-          qcond(il, i) = qcond(il, i) + (elij(il,k,i)-awat) ! cld
-          nqcond(il, i) = nqcond(il, i) + 1. ! cld
-        END IF ! i
-      END DO
-    END DO
-
-    ! do j=1,ntra
-    ! do k=1,i-1
-    ! do il=1,ncum
-    ! if (i.le.inb(il)) then
-    ! dpinv=1.0/(ph(il,i)-ph(il,i+1))
-    ! cpinv=1.0/cpn(il,i)
-    ! if (cvflag_grav) then
-    ! ftra(il,i,j)=ftra(il,i,j)+0.01*grav*dpinv*ment(il,k,i)
-    ! :        *(traent(il,k,i,j)-tra(il,i,j))
-    ! else
-    ! ftra(il,i,j)=ftra(il,i,j)+0.1*dpinv*ment(il,k,i)
-    ! :        *(traent(il,k,i,j)-tra(il,i,j))
-    ! endif
-    ! endif
-    ! enddo
-    ! enddo
-    ! enddo
-
-    DO k = i, nl + 1
-      DO il = 1, ncum
-        IF (i<=inb(il) .AND. k<=inb(il)) THEN
-          dpinv = 1.0/(ph(il,i)-ph(il,i+1))
-          cpinv = 1.0/cpn(il, i)
-
-          IF (cvflag_grav) THEN
-            fr(il, i) = fr(il, i) + 0.01*grav*dpinv*ment(il, k, i)*(qent(il,k &
-              ,i)-rr(il,i))
-            fu(il, i) = fu(il, i) + 0.01*grav*dpinv*ment(il, k, i)*(uent(il,k &
-              ,i)-u(il,i))
-            fv(il, i) = fv(il, i) + 0.01*grav*dpinv*ment(il, k, i)*(vent(il,k &
-              ,i)-v(il,i))
-          ELSE ! cvflag_grav
-            fr(il, i) = fr(il, i) + 0.1*dpinv*ment(il, k, i)*(qent(il,k,i)-rr &
-              (il,i))
-            fu(il, i) = fu(il, i) + 0.1*dpinv*ment(il, k, i)*(uent(il,k,i)-u( &
-              il,i))
-            fv(il, i) = fv(il, i) + 0.1*dpinv*ment(il, k, i)*(vent(il,k,i)-v( &
-              il,i))
-          END IF ! cvflag_grav
-        END IF ! i and k
-      END DO
-    END DO
-
-    ! do j=1,ntra
-    ! do k=i,nl+1
-    ! do il=1,ncum
-    ! if (i.le.inb(il) .and. k.le.inb(il)) then
-    ! dpinv=1.0/(ph(il,i)-ph(il,i+1))
-    ! cpinv=1.0/cpn(il,i)
-    ! if (cvflag_grav) then
-    ! ftra(il,i,j)=ftra(il,i,j)+0.01*grav*dpinv*ment(il,k,i)
-    ! :         *(traent(il,k,i,j)-tra(il,i,j))
-    ! else
-    ! ftra(il,i,j)=ftra(il,i,j)+0.1*dpinv*ment(il,k,i)
-    ! :             *(traent(il,k,i,j)-tra(il,i,j))
-    ! endif
-    ! endif ! i and k
-    ! enddo
-    ! enddo
-    ! enddo
-
-    DO il = 1, ncum
-      IF (i<=inb(il)) THEN
-        dpinv = 1.0/(ph(il,i)-ph(il,i+1))
-        cpinv = 1.0/cpn(il, i)
-
-        IF (cvflag_grav) THEN
-          ! sb: on ne fait pas encore la correction permettant de mieux
-          ! conserver l'eau:
-          fr(il, i) = fr(il, i) + 0.5*sigd*(evap(il,i)+evap(il,i+1)) + &
-            0.01*grav*(mp(il,i+1)*(rp(il,i+1)-rr(il,i))-mp(il,i)*(rp(il, &
-            i)-rr(il,i-1)))*dpinv
-
-          fu(il, i) = fu(il, i) + 0.01*grav*(mp(il,i+1)*(up(il,i+1)-u(il, &
-            i))-mp(il,i)*(up(il,i)-u(il,i-1)))*dpinv
-          fv(il, i) = fv(il, i) + 0.01*grav*(mp(il,i+1)*(vp(il,i+1)-v(il, &
-            i))-mp(il,i)*(vp(il,i)-v(il,i-1)))*dpinv
-        ELSE ! cvflag_grav
-          fr(il, i) = fr(il, i) + 0.5*sigd*(evap(il,i)+evap(il,i+1)) + &
-            0.1*(mp(il,i+1)*(rp(il,i+1)-rr(il,i))-mp(il,i)*(rp(il,i)-rr(il, &
-            i-1)))*dpinv
-          fu(il, i) = fu(il, i) + 0.1*(mp(il,i+1)*(up(il,i+1)-u(il, &
-            i))-mp(il,i)*(up(il,i)-u(il,i-1)))*dpinv
-          fv(il, i) = fv(il, i) + 0.1*(mp(il,i+1)*(vp(il,i+1)-v(il, &
-            i))-mp(il,i)*(vp(il,i)-v(il,i-1)))*dpinv
-        END IF ! cvflag_grav
-
-      END IF ! i
-    END DO
-
-    ! sb: interface with the cloud parameterization:          ! cld
-
-    DO k = i + 1, nl
-      DO il = 1, ncum
-        IF (k<=inb(il) .AND. i<=inb(il)) THEN ! cld
-          ! (saturated downdrafts resulting from mixing)            ! cld
-          qcond(il, i) = qcond(il, i) + elij(il, k, i) ! cld
-          nqcond(il, i) = nqcond(il, i) + 1. ! cld
-        END IF ! cld
-      END DO ! cld
-    END DO ! cld
-
-    ! (particular case: no detraining level is found)         ! cld
-    DO il = 1, ncum ! cld
-      IF (i<=inb(il) .AND. nent(il,i)==0) THEN ! cld
-        qcond(il, i) = qcond(il, i) + (1.-ep(il,i))*clw(il, i) ! cld
-        nqcond(il, i) = nqcond(il, i) + 1. ! cld
-      END IF ! cld
-    END DO ! cld
-
-    DO il = 1, ncum ! cld
-      IF (i<=inb(il) .AND. nqcond(il,i)/=0.) THEN ! cld
-        qcond(il, i) = qcond(il, i)/nqcond(il, i) ! cld
-      END IF ! cld
-    END DO
-
-    ! do j=1,ntra
-    ! do il=1,ncum
-    ! if (i.le.inb(il)) then
-    ! dpinv=1.0/(ph(il,i)-ph(il,i+1))
-    ! cpinv=1.0/cpn(il,i)
-
-    ! if (cvflag_grav) then
-    ! ftra(il,i,j)=ftra(il,i,j)+0.01*grav*dpinv
-    ! :     *(mp(il,i+1)*(trap(il,i+1,j)-tra(il,i,j))
-    ! :     -mp(il,i)*(trap(il,i,j)-tra(il,i-1,j)))
-    ! else
-    ! ftra(il,i,j)=ftra(il,i,j)+0.1*dpinv
-    ! :     *(mp(il,i+1)*(trap(il,i+1,j)-tra(il,i,j))
-    ! :     -mp(il,i)*(trap(il,i,j)-tra(il,i-1,j)))
-    ! endif
-    ! endif ! i
-    ! enddo
-    ! enddo
-
-500 END DO
-
-
-  ! ***   move the detrainment at level inb down to level inb-1   ***
-  ! ***        in such a way as to preserve the vertically        ***
-  ! ***          integrated enthalpy and water tendencies         ***
-
-  DO il = 1, ncum
-
-    ax = 0.1*ment(il, inb(il), inb(il))*(hp(il,inb(il))-h(il,inb(il))+t(il, &
-      inb(il))*(cpv-cpd)*(rr(il,inb(il))-qent(il,inb(il), &
-      inb(il))))/(cpn(il,inb(il))*(ph(il,inb(il))-ph(il,inb(il)+1)))
-    ft(il, inb(il)) = ft(il, inb(il)) - ax
-    ft(il, inb(il)-1) = ft(il, inb(il)-1) + ax*cpn(il, inb(il))*(ph(il,inb(il &
-      ))-ph(il,inb(il)+1))/(cpn(il,inb(il)-1)*(ph(il,inb(il)-1)-ph(il, &
-      inb(il))))
-
-    bx = 0.1*ment(il, inb(il), inb(il))*(qent(il,inb(il),inb(il))-rr(il,inb( &
-      il)))/(ph(il,inb(il))-ph(il,inb(il)+1))
-    fr(il, inb(il)) = fr(il, inb(il)) - bx
-    fr(il, inb(il)-1) = fr(il, inb(il)-1) + bx*(ph(il,inb(il))-ph(il,inb(il)+ &
-      1))/(ph(il,inb(il)-1)-ph(il,inb(il)))
-
-    cx = 0.1*ment(il, inb(il), inb(il))*(uent(il,inb(il),inb(il))-u(il,inb(il &
-      )))/(ph(il,inb(il))-ph(il,inb(il)+1))
-    fu(il, inb(il)) = fu(il, inb(il)) - cx
-    fu(il, inb(il)-1) = fu(il, inb(il)-1) + cx*(ph(il,inb(il))-ph(il,inb(il)+ &
-      1))/(ph(il,inb(il)-1)-ph(il,inb(il)))
-
-    dx = 0.1*ment(il, inb(il), inb(il))*(vent(il,inb(il),inb(il))-v(il,inb(il &
-      )))/(ph(il,inb(il))-ph(il,inb(il)+1))
-    fv(il, inb(il)) = fv(il, inb(il)) - dx
-    fv(il, inb(il)-1) = fv(il, inb(il)-1) + dx*(ph(il,inb(il))-ph(il,inb(il)+ &
-      1))/(ph(il,inb(il)-1)-ph(il,inb(il)))
-
-  END DO
-
-  ! do j=1,ntra
-  ! do il=1,ncum
-  ! ex=0.1*ment(il,inb(il),inb(il))
-  ! :      *(traent(il,inb(il),inb(il),j)-tra(il,inb(il),j))
-  ! :      /(ph(il,inb(il))-ph(il,inb(il)+1))
-  ! ftra(il,inb(il),j)=ftra(il,inb(il),j)-ex
-  ! ftra(il,inb(il)-1,j)=ftra(il,inb(il)-1,j)
-  ! :       +ex*(ph(il,inb(il))-ph(il,inb(il)+1))
-  ! :          /(ph(il,inb(il)-1)-ph(il,inb(il)))
-  ! enddo
-  ! enddo
-
-
-  ! ***    homoginize tendencies below cloud base    ***
-
-
-  DO il = 1, ncum
-    asum(il) = 0.0
-    bsum(il) = 0.0
-    csum(il) = 0.0
-    dsum(il) = 0.0
-  END DO
-
-  DO i = 1, nl
-    DO il = 1, ncum
-      IF (i<=(icb(il)-1)) THEN
-        asum(il) = asum(il) + ft(il, i)*(ph(il,i)-ph(il,i+1))
-        bsum(il) = bsum(il) + fr(il, i)*(lv(il,i)+(cl-cpd)*(t(il,i)-t(il, &
-          1)))*(ph(il,i)-ph(il,i+1))
-        csum(il) = csum(il) + (lv(il,i)+(cl-cpd)*(t(il,i)-t(il, &
-          1)))*(ph(il,i)-ph(il,i+1))
-        dsum(il) = dsum(il) + t(il, i)*(ph(il,i)-ph(il,i+1))/th(il, i)
-      END IF
-    END DO
-  END DO
-
-  ! !!!      do 700 i=1,icb(il)-1
-  DO i = 1, nl
-    DO il = 1, ncum
-      IF (i<=(icb(il)-1)) THEN
-        ft(il, i) = asum(il)*t(il, i)/(th(il,i)*dsum(il))
-        fr(il, i) = bsum(il)/csum(il)
-      END IF
-    END DO
-  END DO
-
-
-  ! ***           reset counter and return           ***
-
-  DO il = 1, ncum
-    sig(il, nd) = 2.0
-  END DO
-
-
-  DO i = 1, nd
-    DO il = 1, ncum
-      upwd(il, i) = 0.0
-      dnwd(il, i) = 0.0
-    END DO
-  END DO
-
-  DO i = 1, nl
-    DO il = 1, ncum
-      dnwd0(il, i) = -mp(il, i)
-    END DO
-  END DO
-  DO i = nl + 1, nd
-    DO il = 1, ncum
-      dnwd0(il, i) = 0.
-    END DO
-  END DO
-
-
-  DO i = 1, nl
-    DO il = 1, ncum
-      IF (i>=icb(il) .AND. i<=inb(il)) THEN
-        upwd(il, i) = 0.0
-        dnwd(il, i) = 0.0
-      END IF
-    END DO
-  END DO
-
-  DO i = 1, nl
-    DO k = 1, nl
-      DO il = 1, ncum
-        up1(il, k, i) = 0.0
-        dn1(il, k, i) = 0.0
-      END DO
-    END DO
-  END DO
-
-  DO i = 1, nl
-    DO k = i, nl
-      DO n = 1, i - 1
-        DO il = 1, ncum
-          IF (i>=icb(il) .AND. i<=inb(il) .AND. k<=inb(il)) THEN
-            up1(il, k, i) = up1(il, k, i) + ment(il, n, k)
-            dn1(il, k, i) = dn1(il, k, i) - ment(il, k, n)
-          END IF
-        END DO
-      END DO
-    END DO
-  END DO
-
-  DO i = 2, nl
-    DO k = i, nl
-      DO il = 1, ncum
-        ! test         if (i.ge.icb(il).and.i.le.inb(il).and.k.le.inb(il))
-        ! then
-        IF (i<=inb(il) .AND. k<=inb(il)) THEN
-          upwd(il, i) = upwd(il, i) + m(il, k) + up1(il, k, i)
-          dnwd(il, i) = dnwd(il, i) + dn1(il, k, i)
-        END IF
-      END DO
-    END DO
-  END DO
-
-
-  ! !!!      DO il=1,ncum
-  ! !!!      do i=icb(il),inb(il)
-  ! !!!
-  ! !!!      upwd(il,i)=0.0
-  ! !!!      dnwd(il,i)=0.0
-  ! !!!      do k=i,inb(il)
-  ! !!!      up1=0.0
-  ! !!!      dn1=0.0
-  ! !!!      do n=1,i-1
-  ! !!!      up1=up1+ment(il,n,k)
-  ! !!!      dn1=dn1-ment(il,k,n)
-  ! !!!      enddo
-  ! !!!      upwd(il,i)=upwd(il,i)+m(il,k)+up1
-  ! !!!      dnwd(il,i)=dnwd(il,i)+dn1
-  ! !!!      enddo
-  ! !!!      enddo
-  ! !!!
-  ! !!!      ENDDO
-
-  ! ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
-  ! determination de la variation de flux ascendant entre
-  ! deux niveau non dilue mike
-  ! ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
-
-  DO i = 1, nl
-    DO il = 1, ncum
-      mike(il, i) = m(il, i)
-    END DO
-  END DO
-
-  DO i = nl + 1, nd
-    DO il = 1, ncum
-      mike(il, i) = 0.
-    END DO
-  END DO
-
-  DO i = 1, nd
-    DO il = 1, ncum
-      ma(il, i) = 0
-    END DO
-  END DO
-
-  DO i = 1, nl
-    DO j = i, nl
-      DO il = 1, ncum
-        ma(il, i) = ma(il, i) + m(il, j)
-      END DO
-    END DO
-  END DO
-
-  DO i = nl + 1, nd
-    DO il = 1, ncum
-      ma(il, i) = 0.
-    END DO
-  END DO
-
-  DO i = 1, nl
-    DO il = 1, ncum
-      IF (i<=(icb(il)-1)) THEN
-        ma(il, i) = 0
-      END IF
-    END DO
-  END DO
-
-  ! cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
-  ! icb represente de niveau ou se trouve la
-  ! base du nuage , et inb le top du nuage
-  ! ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
-
-  DO i = 1, nd
-    DO il = 1, ncum
-      mke(il, i) = upwd(il, i) + dnwd(il, i)
-    END DO
-  END DO
-
-  DO i = 1, nd
-    DO il = 1, ncum
-      rdcp = (rrd*(1.-rr(il,i))-rr(il,i)*rrv)/(cpd*(1.-rr(il, &
-        i))+rr(il,i)*cpv)
-      tls(il, i) = t(il, i)*(1000.0/p(il,i))**rdcp
-      tps(il, i) = tp(il, i)
-    END DO
-  END DO
-
-
-  ! *** diagnose the in-cloud mixing ratio   ***            ! cld
-  ! ***           of condensed water         ***            ! cld
-  ! ! cld
-
-  DO i = 1, nd ! cld
-    DO il = 1, ncum ! cld
-      mac(il, i) = 0.0 ! cld
-      wa(il, i) = 0.0 ! cld
-      siga(il, i) = 0.0 ! cld
-      sax(il, i) = 0.0 ! cld
-    END DO ! cld
-  END DO ! cld
-
-  DO i = minorig, nl ! cld
-    DO k = i + 1, nl + 1 ! cld
-      DO il = 1, ncum ! cld
-        IF (i<=inb(il) .AND. k<=(inb(il)+1)) THEN ! cld
-          mac(il, i) = mac(il, i) + m(il, k) ! cld
-        END IF ! cld
-      END DO ! cld
-    END DO ! cld
-  END DO ! cld
-
-  DO i = 1, nl ! cld
-    DO j = 1, i ! cld
-      DO il = 1, ncum ! cld
-        IF (i>=icb(il) .AND. i<=(inb(il)-1) & ! cld
-            .AND. j>=icb(il)) THEN ! cld
-          sax(il, i) = sax(il, i) + rrd*(tvp(il,j)-tv(il,j)) & ! cld
-            *(ph(il,j)-ph(il,j+1))/p(il, j) ! cld
-        END IF ! cld
-      END DO ! cld
-    END DO ! cld
-  END DO ! cld
-
-  DO i = 1, nl ! cld
-    DO il = 1, ncum ! cld
-      IF (i>=icb(il) .AND. i<=(inb(il)-1) & ! cld
-          .AND. sax(il,i)>0.0) THEN ! cld
-        wa(il, i) = sqrt(2.*sax(il,i)) ! cld
-      END IF ! cld
-    END DO ! cld
-  END DO ! cld
-
-  DO i = 1, nl ! cld
-    DO il = 1, ncum ! cld
-      IF (wa(il,i)>0.0) &          ! cld
-        siga(il, i) = mac(il, i)/wa(il, i) & ! cld
-        *rrd*tvp(il, i)/p(il, i)/100./delta ! cld
-      siga(il, i) = min(siga(il,i), 1.0) ! cld
-      ! IM cf. FH
-      IF (iflag_clw==0) THEN
-        qcondc(il, i) = siga(il, i)*clw(il, i)*(1.-ep(il,i)) & ! cld
-          +(1.-siga(il,i))*qcond(il, i) ! cld
-      ELSE IF (iflag_clw==1) THEN
-        qcondc(il, i) = qcond(il, i) ! cld
-      END IF
-
-    END DO ! cld
-  END DO ! cld
-
-  RETURN
-END SUBROUTINE cv30_yield
-
-! !RomP >>>
-SUBROUTINE cv30_tracer(nloc, len, ncum, nd, na, ment, sij, da, phi, phi2, &
-    d1a, dam, ep, vprecip, elij, clw, epmlmmm, eplamm, icb, inb)
-  IMPLICIT NONE
-
-  include "cv30param.h"
-
-  ! inputs:
-  INTEGER ncum, nd, na, nloc, len
-  REAL ment(nloc, na, na), sij(nloc, na, na)
-  REAL clw(nloc, nd), elij(nloc, na, na)
-  REAL ep(nloc, na)
-  INTEGER icb(nloc), inb(nloc)
-  REAL vprecip(nloc, nd+1)
-  ! ouputs:
-  REAL da(nloc, na), phi(nloc, na, na)
-  REAL phi2(nloc, na, na)
-  REAL d1a(nloc, na), dam(nloc, na)
-  REAL epmlmmm(nloc, na, na), eplamm(nloc, na)
-  ! variables pour tracer dans precip de l'AA et des mel
-  ! local variables:
-  INTEGER i, j, k, nam1
-  REAL epm(nloc, na, na)
-
-  nam1=na-1 ! Introduced because ep is not defined for j=na
-  ! variables d'Emanuel : du second indice au troisieme
-  ! --->    tab(i,k,j) -> de l origine k a l arrivee j
-  ! ment, sij, elij
-  ! variables personnelles : du troisieme au second indice
-  ! --->    tab(i,j,k) -> de k a j
-  ! phi, phi2
-
-  ! initialisations
-  DO j = 1, na
-    DO i = 1, ncum
-      da(i, j) = 0.
-      d1a(i, j) = 0.
-      dam(i, j) = 0.
-      eplamm(i, j) = 0.
-    END DO
-  END DO
-  DO k = 1, na
-    DO j = 1, na
-      DO i = 1, ncum
-        epm(i, j, k) = 0.
-        epmlmmm(i, j, k) = 0.
-        phi(i, j, k) = 0.
-        phi2(i, j, k) = 0.
-      END DO
-    END DO
-  END DO
-
-  ! fraction deau condensee dans les melanges convertie en precip : epm
-  ! et eau condensée précipitée dans masse d'air saturé : l_m*dM_m/dzdz.dzdz
-  DO j = 1, nam1
-    DO k = 1, j - 1
-      DO i = 1, ncum
-        IF (k>=icb(i) .AND. k<=inb(i) .AND. j<=inb(i)) THEN
-          ! !jyg             epm(i,j,k)=1.-(1.-ep(i,j))*clw(i,j)/elij(i,k,j)
-          epm(i, j, k) = 1. - (1.-ep(i,j))*clw(i, j)/max(elij(i,k,j), 1.E-16)
-          ! !
-          epm(i, j, k) = max(epm(i,j,k), 0.0)
-        END IF
-      END DO
-    END DO
-  END DO
-
-  DO j = 1, nam1
-    DO k = 1, nam1
-      DO i = 1, ncum
-        IF (k>=icb(i) .AND. k<=inb(i)) THEN
-          eplamm(i, j) = eplamm(i, j) + ep(i, j)*clw(i, j)*ment(i, j, k)*(1.- &
-            sij(i,j,k))
-        END IF
-      END DO
-    END DO
-  END DO
-
-  DO j = 1, nam1
-    DO k = 1, j - 1
-      DO i = 1, ncum
-        IF (k>=icb(i) .AND. k<=inb(i) .AND. j<=inb(i)) THEN
-          epmlmmm(i, j, k) = epm(i, j, k)*elij(i, k, j)*ment(i, k, j)
-        END IF
-      END DO
-    END DO
-  END DO
-
-  ! matrices pour calculer la tendance des concentrations dans cvltr.F90
-  DO j = 1, nam1
-    DO k = 1, nam1
-      DO i = 1, ncum
-        da(i, j) = da(i, j) + (1.-sij(i,k,j))*ment(i, k, j)
-        phi(i, j, k) = sij(i, k, j)*ment(i, k, j)
-        d1a(i, j) = d1a(i, j) + ment(i, k, j)*ep(i, k)*(1.-sij(i,k,j))
-      END DO
-    END DO
-  END DO
-
-  DO j = 1, nam1
-    DO k = 1, j - 1
-      DO i = 1, ncum
-        dam(i, j) = dam(i, j) + ment(i, k, j)*epm(i, j, k)*(1.-ep(i,k))*(1.- &
-          sij(i,k,j))
-        phi2(i, j, k) = phi(i, j, k)*epm(i, j, k)
-      END DO
-    END DO
-  END DO
-
-  RETURN
-END SUBROUTINE cv30_tracer
-! RomP <<<
-
-SUBROUTINE cv30_uncompress(nloc, len, ncum, nd, ntra, idcum, iflag, precip, &
-    vprecip, evap, ep, sig, w0, ft, fq, fu, fv, ftra, inb, ma, upwd, dnwd, &
-    dnwd0, qcondc, wd, cape, da, phi, mp, phi2, d1a, dam, sij, elij, clw, &
-    epmlmmm, eplamm, wdtraina, wdtrainm,epmax_diag, iflag1, precip1, vprecip1, evap1, &
-    ep1, sig1, w01, ft1, fq1, fu1, fv1, ftra1, inb1, ma1, upwd1, dnwd1, &
-    dnwd01, qcondc1, wd1, cape1, da1, phi1, mp1, phi21, d1a1, dam1, sij1, &
-    elij1, clw1, epmlmmm1, eplamm1, wdtraina1, wdtrainm1,epmax_diag1) ! epmax_cape
-  IMPLICIT NONE
-
-  include "cv30param.h"
-
-  ! inputs:
-  INTEGER len, ncum, nd, ntra, nloc
-  INTEGER idcum(nloc)
-  INTEGER iflag(nloc)
-  INTEGER inb(nloc)
-  REAL precip(nloc)
-  REAL vprecip(nloc, nd+1), evap(nloc, nd)
-  REAL ep(nloc, nd)
-  REAL sig(nloc, nd), w0(nloc, nd)
-  REAL ft(nloc, nd), fq(nloc, nd), fu(nloc, nd), fv(nloc, nd)
-  REAL ftra(nloc, nd, ntra)
-  REAL ma(nloc, nd)
-  REAL upwd(nloc, nd), dnwd(nloc, nd), dnwd0(nloc, nd)
-  REAL qcondc(nloc, nd)
-  REAL wd(nloc), cape(nloc)
-  REAL da(nloc, nd), phi(nloc, nd, nd), mp(nloc, nd)
-  REAL epmax_diag(nloc) ! epmax_cape
-  ! RomP >>>
-  REAL phi2(nloc, nd, nd)
-  REAL d1a(nloc, nd), dam(nloc, nd)
-  REAL wdtraina(nloc, nd), wdtrainm(nloc, nd)
-  REAL sij(nloc, nd, nd)
-  REAL elij(nloc, nd, nd), clw(nloc, nd)
-  REAL epmlmmm(nloc, nd, nd), eplamm(nloc, nd)
-  ! RomP <<<
-
-  ! outputs:
-  INTEGER iflag1(len)
-  INTEGER inb1(len)
-  REAL precip1(len)
-  REAL vprecip1(len, nd+1), evap1(len, nd) !<<< RomP
-  REAL ep1(len, nd) !<<< RomP
-  REAL sig1(len, nd), w01(len, nd)
-  REAL ft1(len, nd), fq1(len, nd), fu1(len, nd), fv1(len, nd)
-  REAL ftra1(len, nd, ntra)
-  REAL ma1(len, nd)
-  REAL upwd1(len, nd), dnwd1(len, nd), dnwd01(len, nd)
-  REAL qcondc1(nloc, nd)
-  REAL wd1(nloc), cape1(nloc)
-  REAL da1(nloc, nd), phi1(nloc, nd, nd), mp1(nloc, nd)
-  REAL epmax_diag1(len) ! epmax_cape
-  ! RomP >>>
-  REAL phi21(len, nd, nd)
-  REAL d1a1(len, nd), dam1(len, nd)
-  REAL wdtraina1(len, nd), wdtrainm1(len, nd)
-  REAL sij1(len, nd, nd)
-  REAL elij1(len, nd, nd), clw1(len, nd)
-  REAL epmlmmm1(len, nd, nd), eplamm1(len, nd)
-  ! RomP <<<
-
-  ! local variables:
-  INTEGER i, k, j
-
-  DO i = 1, ncum
-    precip1(idcum(i)) = precip(i)
-    iflag1(idcum(i)) = iflag(i)
-    wd1(idcum(i)) = wd(i)
-    inb1(idcum(i)) = inb(i)
-    cape1(idcum(i)) = cape(i)
-    epmax_diag1(idcum(i))=epmax_diag(i) ! epmax_cape
-  END DO
-
-  DO k = 1, nl
-    DO i = 1, ncum
-      vprecip1(idcum(i), k) = vprecip(i, k)
-      evap1(idcum(i), k) = evap(i, k) !<<< RomP
-      sig1(idcum(i), k) = sig(i, k)
-      w01(idcum(i), k) = w0(i, k)
-      ft1(idcum(i), k) = ft(i, k)
-      fq1(idcum(i), k) = fq(i, k)
-      fu1(idcum(i), k) = fu(i, k)
-      fv1(idcum(i), k) = fv(i, k)
-      ma1(idcum(i), k) = ma(i, k)
-      upwd1(idcum(i), k) = upwd(i, k)
-      dnwd1(idcum(i), k) = dnwd(i, k)
-      dnwd01(idcum(i), k) = dnwd0(i, k)
-      qcondc1(idcum(i), k) = qcondc(i, k)
-      da1(idcum(i), k) = da(i, k)
-      mp1(idcum(i), k) = mp(i, k)
-      ! RomP >>>
-      ep1(idcum(i), k) = ep(i, k)
-      d1a1(idcum(i), k) = d1a(i, k)
-      dam1(idcum(i), k) = dam(i, k)
-      clw1(idcum(i), k) = clw(i, k)
-      eplamm1(idcum(i), k) = eplamm(i, k)
-      wdtraina1(idcum(i), k) = wdtraina(i, k)
-      wdtrainm1(idcum(i), k) = wdtrainm(i, k)
-      ! RomP <<<
-    END DO
-  END DO
-
-  DO i = 1, ncum
-    sig1(idcum(i), nd) = sig(i, nd)
-  END DO
-
-
-  ! do 2100 j=1,ntra
-  ! do 2110 k=1,nd ! oct3
-  ! do 2120 i=1,ncum
-  ! ftra1(idcum(i),k,j)=ftra(i,k,j)
-  ! 2120     continue
-  ! 2110    continue
-  ! 2100   continue
-  DO j = 1, nd
-    DO k = 1, nd
-      DO i = 1, ncum
-        sij1(idcum(i), k, j) = sij(i, k, j)
-        phi1(idcum(i), k, j) = phi(i, k, j)
-        phi21(idcum(i), k, j) = phi2(i, k, j)
-        elij1(idcum(i), k, j) = elij(i, k, j)
-        epmlmmm1(idcum(i), k, j) = epmlmmm(i, k, j)
-      END DO
-    END DO
-  END DO
-
-  RETURN
-END SUBROUTINE cv30_uncompress
-
-        subroutine cv30_epmax_fn_cape(nloc,ncum,nd &
-                ,cape,ep,hp,icb,inb,clw,nk,t,h,lv &
-                ,epmax_diag)
-        implicit none
-
-        ! On fait varier epmax en fn de la cape
-        ! Il faut donc recalculer ep, et hp qui a déjà été calculé et
-        ! qui en dépend
-        ! Toutes les autres variables fn de ep sont calculées plus bas.
-
-        INCLUDE "cvthermo.h"
-        INCLUDE "cv30param.h"
-        INCLUDE "conema3.h"
-
-! inputs:
-      integer ncum, nd, nloc
-      integer icb(nloc), inb(nloc)
-      real cape(nloc)
-      real clw(nloc,nd),lv(nloc,nd),t(nloc,nd),h(nloc,nd)
-      integer nk(nloc)
-! inouts:
-      real ep(nloc,nd)
-      real hp(nloc,nd)
-! outputs ou local
-      real epmax_diag(nloc)
-! locals
-      integer i,k    
-      real hp_bak(nloc,nd)
-      CHARACTER (LEN=20) :: modname='cv30_epmax_fn_cape'
-      CHARACTER (LEN=80) :: abort_message
-
-        ! on recalcule ep et hp
-        
-        if (coef_epmax_cape.gt.1e-12) then
-        do i=1,ncum
-           epmax_diag(i)=epmax-coef_epmax_cape*sqrt(cape(i))
-           do k=1,nl
-                ep(i,k)=ep(i,k)/epmax*epmax_diag(i)
-                ep(i,k)=amax1(ep(i,k),0.0)
-                ep(i,k)=amin1(ep(i,k),epmax_diag(i))
-           enddo
-        enddo
-
-! On recalcule hp:
-      do k=1,nl
-        do i=1,ncum
-	  hp_bak(i,k)=hp(i,k)
-	enddo
-      enddo
-      do k=1,nlp
-        do i=1,ncum
-	  hp(i,k)=h(i,k)
-	enddo
-      enddo
-      do k=minorig+1,nl
-       do i=1,ncum
-        if((k.ge.icb(i)).and.(k.le.inb(i)))then
-          hp(i,k)=h(i,nk(i))+(lv(i,k)+(cpd-cpv)*t(i,k))*ep(i,k)*clw(i,k)
-        endif
-       enddo
-      enddo !do k=minorig+1,n
-!     write(*,*) 'cv30_routines 6218: hp(1,20)=',hp(1,20)
-      do i=1,ncum  
-       do k=1,nl
-        if (abs(hp_bak(i,k)-hp(i,k)).gt.0.01) then
-           write(*,*) 'i,k=',i,k
-           write(*,*) 'coef_epmax_cape=',coef_epmax_cape
-           write(*,*) 'epmax_diag(i)=',epmax_diag(i)
-           write(*,*) 'ep(i,k)=',ep(i,k)
-           write(*,*) 'hp(i,k)=',hp(i,k)
-           write(*,*) 'hp_bak(i,k)=',hp_bak(i,k)
-           write(*,*) 'h(i,k)=',h(i,k)
-           write(*,*) 'nk(i)=',nk(i)
-           write(*,*) 'h(i,nk(i))=',h(i,nk(i))
-           write(*,*) 'lv(i,k)=',lv(i,k)
-           write(*,*) 't(i,k)=',t(i,k)
-           write(*,*) 'clw(i,k)=',clw(i,k)
-           write(*,*) 'cpd,cpv=',cpd,cpv
-           CALL abort_physic(modname,abort_message,1)
-        endif
-       enddo !do k=1,nl
-      enddo !do i=1,ncum  
-      endif !if (coef_epmax_cape.gt.1e-12) then
-
-      return
-      end subroutine cv30_epmax_fn_cape
-
-
Index: /LMDZ6/trunk/libf/phylmd/cv30_routines.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cv30_routines.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/cv30_routines.f90	(revision 5268)
@@ -0,0 +1,3360 @@
+
+! $Id$
+
+
+
+SUBROUTINE cv30_param(nd, delt)
+  IMPLICIT NONE
+
+  ! ------------------------------------------------------------
+  ! Set parameters for convectL for iflag_con = 3
+  ! ------------------------------------------------------------
+
+
+  ! ***  PBCRIT IS THE CRITICAL CLOUD DEPTH (MB) BENEATH WHICH THE ***
+  ! ***      PRECIPITATION EFFICIENCY IS ASSUMED TO BE ZERO     ***
+  ! ***  PTCRIT IS THE CLOUD DEPTH (MB) ABOVE WHICH THE PRECIP. ***
+  ! ***            EFFICIENCY IS ASSUMED TO BE UNITY            ***
+  ! ***  SIGD IS THE FRACTIONAL AREA COVERED BY UNSATURATED DNDRAFT  ***
+  ! ***  SPFAC IS THE FRACTION OF PRECIPITATION FALLING OUTSIDE ***
+  ! ***                        OF CLOUD                         ***
+
+  ! [TAU: CHARACTERISTIC TIMESCALE USED TO COMPUTE ALPHA & BETA]
+  ! ***    ALPHA AND BETA ARE PARAMETERS THAT CONTROL THE RATE OF ***
+  ! ***                 APPROACH TO QUASI-EQUILIBRIUM           ***
+  ! ***    (THEIR STANDARD VALUES ARE 1.0 AND 0.96, RESPECTIVELY) ***
+  ! ***           (BETA MUST BE LESS THAN OR EQUAL TO 1)        ***
+
+  ! ***    DTCRIT IS THE CRITICAL BUOYANCY (K) USED TO ADJUST THE ***
+  ! ***                 APPROACH TO QUASI-EQUILIBRIUM           ***
+  ! ***                     IT MUST BE LESS THAN 0              ***
+
+  include "cv30param.h"
+  include "conema3.h"
+
+  INTEGER nd
+  REAL delt ! timestep (seconds)
+
+  ! noff: integer limit for convection (nd-noff)
+  ! minorig: First level of convection
+
+  ! -- limit levels for convection:
+
+  noff = 1
+  minorig = 1
+  nl = nd - noff
+  nlp = nl + 1
+  nlm = nl - 1
+
+  ! -- "microphysical" parameters:
+
+  sigd = 0.01
+  spfac = 0.15
+  pbcrit = 150.0
+  ptcrit = 500.0
+  ! IM cf. FH     epmax  = 0.993
+
+  omtrain = 45.0 ! used also for snow (no disctinction rain/snow)
+
+  ! -- misc:
+
+  dtovsh = -0.2 ! dT for overshoot
+  dpbase = -40. ! definition cloud base (400m above LCL)
+  dttrig = 5. ! (loose) condition for triggering
+
+  ! -- rate of approach to quasi-equilibrium:
+
+  dtcrit = -2.0
+  tau = 8000.
+  beta = 1.0 - delt/tau
+  alpha = 1.5E-3*delt/tau
+  ! increase alpha to compensate W decrease:
+  alpha = alpha*1.5
+
+  ! -- interface cloud parameterization:
+
+  delta = 0.01 ! cld
+
+  ! -- interface with boundary-layer (gust factor): (sb)
+
+  betad = 10.0 ! original value (from convect 4.3)
+
+  RETURN
+END SUBROUTINE cv30_param
+
+SUBROUTINE cv30_prelim(len, nd, ndp1, t, q, p, ph, lv, cpn, tv, gz, h, hm, &
+    th)
+  IMPLICIT NONE
+
+  ! =====================================================================
+  ! --- CALCULATE ARRAYS OF GEOPOTENTIAL, HEAT CAPACITY & STATIC ENERGY
+  ! "ori": from convect4.3 (vectorized)
+  ! "convect3": to be exactly consistent with convect3
+  ! =====================================================================
+
+  ! inputs:
+  INTEGER len, nd, ndp1
+  REAL t(len, nd), q(len, nd), p(len, nd), ph(len, ndp1)
+
+  ! outputs:
+  REAL lv(len, nd), cpn(len, nd), tv(len, nd)
+  REAL gz(len, nd), h(len, nd), hm(len, nd)
+  REAL th(len, nd)
+
+  ! local variables:
+  INTEGER k, i
+  REAL rdcp
+  REAL tvx, tvy ! convect3
+  REAL cpx(len, nd)
+
+  include "cvthermo.h"
+  include "cv30param.h"
+
+
+  ! ori      do 110 k=1,nlp
+  DO k = 1, nl ! convect3
+    DO i = 1, len
+      ! debug          lv(i,k)= lv0-clmcpv*(t(i,k)-t0)
+      lv(i, k) = lv0 - clmcpv*(t(i,k)-273.15)
+      cpn(i, k) = cpd*(1.0-q(i,k)) + cpv*q(i, k)
+      cpx(i, k) = cpd*(1.0-q(i,k)) + cl*q(i, k)
+      ! ori          tv(i,k)=t(i,k)*(1.0+q(i,k)*epsim1)
+      tv(i, k) = t(i, k)*(1.0+q(i,k)/eps-q(i,k))
+      rdcp = (rrd*(1.-q(i,k))+q(i,k)*rrv)/cpn(i, k)
+      th(i, k) = t(i, k)*(1000.0/p(i,k))**rdcp
+    END DO
+  END DO
+
+  ! gz = phi at the full levels (same as p).
+
+  DO i = 1, len
+    gz(i, 1) = 0.0
+  END DO
+  ! ori      do 140 k=2,nlp
+  DO k = 2, nl ! convect3
+    DO i = 1, len
+      tvx = t(i, k)*(1.+q(i,k)/eps-q(i,k)) !convect3
+      tvy = t(i, k-1)*(1.+q(i,k-1)/eps-q(i,k-1)) !convect3
+      gz(i, k) = gz(i, k-1) + 0.5*rrd*(tvx+tvy) & !convect3
+        *(p(i,k-1)-p(i,k))/ph(i, k) !convect3
+
+      ! ori         gz(i,k)=gz(i,k-1)+hrd*(tv(i,k-1)+tv(i,k))
+      ! ori    &         *(p(i,k-1)-p(i,k))/ph(i,k)
+    END DO
+  END DO
+
+  ! h  = phi + cpT (dry static energy).
+  ! hm = phi + cp(T-Tbase)+Lq
+
+  ! ori      do 170 k=1,nlp
+  DO k = 1, nl ! convect3
+    DO i = 1, len
+      h(i, k) = gz(i, k) + cpn(i, k)*t(i, k)
+      hm(i, k) = gz(i, k) + cpx(i, k)*(t(i,k)-t(i,1)) + lv(i, k)*q(i, k)
+    END DO
+  END DO
+
+  RETURN
+END SUBROUTINE cv30_prelim
+
+SUBROUTINE cv30_feed(len, nd, t, q, qs, p, ph, hm, gz, nk, icb, icbmax, &
+    iflag, tnk, qnk, gznk, plcl)
+  IMPLICIT NONE
+
+  ! ================================================================
+  ! Purpose: CONVECTIVE FEED
+
+  ! Main differences with cv_feed:
+  ! - ph added in input
+  ! - here, nk(i)=minorig
+  ! - icb defined differently (plcl compared with ph instead of p)
+
+  ! Main differences with convect3:
+  ! - we do not compute dplcldt and dplcldr of CLIFT anymore
+  ! - values iflag different (but tests identical)
+  ! - A,B explicitely defined (!...)
+  ! ================================================================
+
+  include "cv30param.h"
+
+  ! inputs:
+  INTEGER len, nd
+  REAL t(len, nd), q(len, nd), qs(len, nd), p(len, nd)
+  REAL hm(len, nd), gz(len, nd)
+  REAL ph(len, nd+1)
+
+  ! outputs:
+  INTEGER iflag(len), nk(len), icb(len), icbmax
+  REAL tnk(len), qnk(len), gznk(len), plcl(len)
+
+  ! local variables:
+  INTEGER i, k
+  INTEGER ihmin(len)
+  REAL work(len)
+  REAL pnk(len), qsnk(len), rh(len), chi(len)
+  REAL a, b ! convect3
+  ! ym
+  plcl = 0.0
+  ! @ !-------------------------------------------------------------------
+  ! @ ! --- Find level of minimum moist static energy
+  ! @ ! --- If level of minimum moist static energy coincides with
+  ! @ ! --- or is lower than minimum allowable parcel origin level,
+  ! @ ! --- set iflag to 6.
+  ! @ !-------------------------------------------------------------------
+  ! @
+  ! @       do 180 i=1,len
+  ! @        work(i)=1.0e12
+  ! @        ihmin(i)=nl
+  ! @  180  continue
+  ! @       do 200 k=2,nlp
+  ! @         do 190 i=1,len
+  ! @          if((hm(i,k).lt.work(i)).and.
+  ! @      &      (hm(i,k).lt.hm(i,k-1)))then
+  ! @            work(i)=hm(i,k)
+  ! @            ihmin(i)=k
+  ! @          endif
+  ! @  190    continue
+  ! @  200  continue
+  ! @       do 210 i=1,len
+  ! @         ihmin(i)=min(ihmin(i),nlm)
+  ! @         if(ihmin(i).le.minorig)then
+  ! @           iflag(i)=6
+  ! @         endif
+  ! @  210  continue
+  ! @ c
+  ! @ !-------------------------------------------------------------------
+  ! @ ! --- Find that model level below the level of minimum moist static
+  ! @ ! --- energy that has the maximum value of moist static energy
+  ! @ !-------------------------------------------------------------------
+  ! @
+  ! @       do 220 i=1,len
+  ! @        work(i)=hm(i,minorig)
+  ! @        nk(i)=minorig
+  ! @  220  continue
+  ! @       do 240 k=minorig+1,nl
+  ! @         do 230 i=1,len
+  ! @          if((hm(i,k).gt.work(i)).and.(k.le.ihmin(i)))then
+  ! @            work(i)=hm(i,k)
+  ! @            nk(i)=k
+  ! @          endif
+  ! @  230     continue
+  ! @  240  continue
+
+  ! -------------------------------------------------------------------
+  ! --- Origin level of ascending parcels for convect3:
+  ! -------------------------------------------------------------------
+
+  DO i = 1, len
+    nk(i) = minorig
+  END DO
+
+  ! -------------------------------------------------------------------
+  ! --- Check whether parcel level temperature and specific humidity
+  ! --- are reasonable
+  ! -------------------------------------------------------------------
+  DO i = 1, len
+    IF (((t(i,nk(i))<250.0) .OR. (q(i,nk(i))<=0.0)) & ! @      &       .or.(
+                                                      ! p(i,ihmin(i)).lt.400.0
+                                                      ! )  )
+      .AND. (iflag(i)==0)) iflag(i) = 7
+  END DO
+  ! -------------------------------------------------------------------
+  ! --- Calculate lifted condensation level of air at parcel origin level
+  ! --- (Within 0.2% of formula of Bolton, MON. WEA. REV.,1980)
+  ! -------------------------------------------------------------------
+
+  a = 1669.0 ! convect3
+  b = 122.0 ! convect3
+
+  DO i = 1, len
+
+    IF (iflag(i)/=7) THEN ! modif sb Jun7th 2002
+
+      tnk(i) = t(i, nk(i))
+      qnk(i) = q(i, nk(i))
+      gznk(i) = gz(i, nk(i))
+      pnk(i) = p(i, nk(i))
+      qsnk(i) = qs(i, nk(i))
+
+      rh(i) = qnk(i)/qsnk(i)
+      ! ori        rh(i)=min(1.0,rh(i)) ! removed for convect3
+      ! ori        chi(i)=tnk(i)/(1669.0-122.0*rh(i)-tnk(i))
+      chi(i) = tnk(i)/(a-b*rh(i)-tnk(i)) ! convect3
+      plcl(i) = pnk(i)*(rh(i)**chi(i))
+      IF (((plcl(i)<200.0) .OR. (plcl(i)>=2000.0)) .AND. (iflag(i)==0)) iflag &
+        (i) = 8
+
+    END IF ! iflag=7
+
+  END DO
+
+  ! -------------------------------------------------------------------
+  ! --- Calculate first level above lcl (=icb)
+  ! -------------------------------------------------------------------
+
+  ! @      do 270 i=1,len
+  ! @       icb(i)=nlm
+  ! @ 270  continue
+  ! @c
+  ! @      do 290 k=minorig,nl
+  ! @        do 280 i=1,len
+  ! @          if((k.ge.(nk(i)+1)).and.(p(i,k).lt.plcl(i)))
+  ! @     &    icb(i)=min(icb(i),k)
+  ! @ 280    continue
+  ! @ 290  continue
+  ! @c
+  ! @      do 300 i=1,len
+  ! @        if((icb(i).ge.nlm).and.(iflag(i).eq.0))iflag(i)=9
+  ! @ 300  continue
+
+  DO i = 1, len
+    icb(i) = nlm
+  END DO
+
+  ! la modification consiste a comparer plcl a ph et non a p:
+  ! icb est defini par :  ph(icb)<plcl<ph(icb-1)
+  ! @      do 290 k=minorig,nl
+  DO k = 3, nl - 1 ! modif pour que icb soit sup/egal a 2
+    DO i = 1, len
+      IF (ph(i,k)<plcl(i)) icb(i) = min(icb(i), k)
+    END DO
+  END DO
+
+  DO i = 1, len
+    ! @        if((icb(i).ge.nlm).and.(iflag(i).eq.0))iflag(i)=9
+    IF ((icb(i)==nlm) .AND. (iflag(i)==0)) iflag(i) = 9
+  END DO
+
+  DO i = 1, len
+    icb(i) = icb(i) - 1 ! icb sup ou egal a 2
+  END DO
+
+  ! Compute icbmax.
+
+  icbmax = 2
+  DO i = 1, len
+    ! !        icbmax=max(icbmax,icb(i))
+    IF (iflag(i)<7) icbmax = max(icbmax, icb(i)) ! sb Jun7th02
+  END DO
+
+  RETURN
+END SUBROUTINE cv30_feed
+
+SUBROUTINE cv30_undilute1(len, nd, t, q, qs, gz, plcl, p, nk, icb, tp, tvp, &
+    clw, icbs)
+  IMPLICIT NONE
+
+  ! ----------------------------------------------------------------
+  ! Equivalent de TLIFT entre NK et ICB+1 inclus
+
+  ! Differences with convect4:
+  ! - specify plcl in input
+  ! - icbs is the first level above LCL (may differ from icb)
+  ! - in the iterations, used x(icbs) instead x(icb)
+  ! - many minor differences in the iterations
+  ! - tvp is computed in only one time
+  ! - icbs: first level above Plcl (IMIN de TLIFT) in output
+  ! - if icbs=icb, compute also tp(icb+1),tvp(icb+1) & clw(icb+1)
+  ! ----------------------------------------------------------------
+
+  include "cvthermo.h"
+  include "cv30param.h"
+
+  ! inputs:
+  INTEGER len, nd
+  INTEGER nk(len), icb(len)
+  REAL t(len, nd), q(len, nd), qs(len, nd), gz(len, nd)
+  REAL p(len, nd)
+  REAL plcl(len) ! convect3
+
+  ! outputs:
+  REAL tp(len, nd), tvp(len, nd), clw(len, nd)
+
+  ! local variables:
+  INTEGER i, k
+  INTEGER icb1(len), icbs(len), icbsmax2 ! convect3
+  REAL tg, qg, alv, s, ahg, tc, denom, es, rg
+  REAL ah0(len), cpp(len)
+  REAL tnk(len), qnk(len), gznk(len), ticb(len), gzicb(len)
+  REAL qsicb(len) ! convect3
+  REAL cpinv(len) ! convect3
+
+  ! -------------------------------------------------------------------
+  ! --- Calculates the lifted parcel virtual temperature at nk,
+  ! --- the actual temperature, and the adiabatic
+  ! --- liquid water content. The procedure is to solve the equation.
+  ! cp*tp+L*qp+phi=cp*tnk+L*qnk+gznk.
+  ! -------------------------------------------------------------------
+
+  DO i = 1, len
+    tnk(i) = t(i, nk(i))
+    qnk(i) = q(i, nk(i))
+    gznk(i) = gz(i, nk(i))
+    ! ori        ticb(i)=t(i,icb(i))
+    ! ori        gzicb(i)=gz(i,icb(i))
+  END DO
+
+  ! ***  Calculate certain parcel quantities, including static energy   ***
+
+  DO i = 1, len
+    ah0(i) = (cpd*(1.-qnk(i))+cl*qnk(i))*tnk(i) + qnk(i)*(lv0-clmcpv*(tnk(i)- &
+      273.15)) + gznk(i)
+    cpp(i) = cpd*(1.-qnk(i)) + qnk(i)*cpv
+    cpinv(i) = 1./cpp(i)
+  END DO
+
+  ! ***   Calculate lifted parcel quantities below cloud base   ***
+
+  DO i = 1, len !convect3
+    icb1(i) = min(max(icb(i), 2), nl)
+    ! if icb is below LCL, start loop at ICB+1:
+    ! (icbs est le premier niveau au-dessus du LCL)
+    icbs(i) = icb1(i) !convect3
+    IF (plcl(i)<p(i,icb1(i))) THEN
+      icbs(i) = min(icbs(i)+1, nl) !convect3
+    END IF
+  END DO !convect3
+
+  DO i = 1, len !convect3
+    ticb(i) = t(i, icbs(i)) !convect3
+    gzicb(i) = gz(i, icbs(i)) !convect3
+    qsicb(i) = qs(i, icbs(i)) !convect3
+  END DO !convect3
+
+
+  ! Re-compute icbsmax (icbsmax2):        !convect3
+  ! !convect3
+  icbsmax2 = 2 !convect3
+  DO i = 1, len !convect3
+    icbsmax2 = max(icbsmax2, icbs(i)) !convect3
+  END DO !convect3
+
+  ! initialization outputs:
+
+  DO k = 1, icbsmax2 ! convect3
+    DO i = 1, len ! convect3
+      tp(i, k) = 0.0 ! convect3
+      tvp(i, k) = 0.0 ! convect3
+      clw(i, k) = 0.0 ! convect3
+    END DO ! convect3
+  END DO ! convect3
+
+  ! tp and tvp below cloud base:
+
+  DO k = minorig, icbsmax2 - 1
+    DO i = 1, len
+      tp(i, k) = tnk(i) - (gz(i,k)-gznk(i))*cpinv(i)
+      tvp(i, k) = tp(i, k)*(1.+qnk(i)/eps-qnk(i)) !whole thing (convect3)
+    END DO
+  END DO
+
+  ! ***  Find lifted parcel quantities above cloud base    ***
+
+  DO i = 1, len
+    tg = ticb(i)
+    ! ori         qg=qs(i,icb(i))
+    qg = qsicb(i) ! convect3
+    ! debug         alv=lv0-clmcpv*(ticb(i)-t0)
+    alv = lv0 - clmcpv*(ticb(i)-273.15)
+
+    ! First iteration.
+
+    ! ori          s=cpd+alv*alv*qg/(rrv*ticb(i)*ticb(i))
+    s = cpd*(1.-qnk(i)) + cl*qnk(i) & ! convect3
+      +alv*alv*qg/(rrv*ticb(i)*ticb(i)) ! convect3
+    s = 1./s
+    ! ori          ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i)
+    ahg = cpd*tg + (cl-cpd)*qnk(i)*tg + alv*qg + gzicb(i) ! convect3
+    tg = tg + s*(ah0(i)-ahg)
+    ! ori          tg=max(tg,35.0)
+    ! debug          tc=tg-t0
+    tc = tg - 273.15
+    denom = 243.5 + tc
+    denom = max(denom, 1.0) ! convect3
+    ! ori          if(tc.ge.0.0)then
+    es = 6.112*exp(17.67*tc/denom)
+    ! ori          else
+    ! ori           es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
+    ! ori          endif
+    ! ori          qg=eps*es/(p(i,icb(i))-es*(1.-eps))
+    qg = eps*es/(p(i,icbs(i))-es*(1.-eps))
+
+    ! Second iteration.
+
+
+    ! ori          s=cpd+alv*alv*qg/(rrv*ticb(i)*ticb(i))
+    ! ori          s=1./s
+    ! ori          ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i)
+    ahg = cpd*tg + (cl-cpd)*qnk(i)*tg + alv*qg + gzicb(i) ! convect3
+    tg = tg + s*(ah0(i)-ahg)
+    ! ori          tg=max(tg,35.0)
+    ! debug          tc=tg-t0
+    tc = tg - 273.15
+    denom = 243.5 + tc
+    denom = max(denom, 1.0) ! convect3
+    ! ori          if(tc.ge.0.0)then
+    es = 6.112*exp(17.67*tc/denom)
+    ! ori          else
+    ! ori           es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
+    ! ori          end if
+    ! ori          qg=eps*es/(p(i,icb(i))-es*(1.-eps))
+    qg = eps*es/(p(i,icbs(i))-es*(1.-eps))
+
+    alv = lv0 - clmcpv*(ticb(i)-273.15)
+
+    ! ori c approximation here:
+    ! ori         tp(i,icb(i))=(ah0(i)-(cl-cpd)*qnk(i)*ticb(i)
+    ! ori     &   -gz(i,icb(i))-alv*qg)/cpd
+
+    ! convect3: no approximation:
+    tp(i, icbs(i)) = (ah0(i)-gz(i,icbs(i))-alv*qg)/(cpd+(cl-cpd)*qnk(i))
+
+    ! ori         clw(i,icb(i))=qnk(i)-qg
+    ! ori         clw(i,icb(i))=max(0.0,clw(i,icb(i)))
+    clw(i, icbs(i)) = qnk(i) - qg
+    clw(i, icbs(i)) = max(0.0, clw(i,icbs(i)))
+
+    rg = qg/(1.-qnk(i))
+    ! ori         tvp(i,icb(i))=tp(i,icb(i))*(1.+rg*epsi)
+    ! convect3: (qg utilise au lieu du vrai mixing ratio rg)
+    tvp(i, icbs(i)) = tp(i, icbs(i))*(1.+qg/eps-qnk(i)) !whole thing
+
+  END DO
+
+  ! ori      do 380 k=minorig,icbsmax2
+  ! ori       do 370 i=1,len
+  ! ori         tvp(i,k)=tvp(i,k)-tp(i,k)*qnk(i)
+  ! ori 370   continue
+  ! ori 380  continue
+
+
+  ! -- The following is only for convect3:
+
+  ! * icbs is the first level above the LCL:
+  ! if plcl<p(icb), then icbs=icb+1
+  ! if plcl>p(icb), then icbs=icb
+
+  ! * the routine above computes tvp from minorig to icbs (included).
+
+  ! * to compute buoybase (in cv3_trigger.F), both tvp(icb) and tvp(icb+1)
+  ! must be known. This is the case if icbs=icb+1, but not if icbs=icb.
+
+  ! * therefore, in the case icbs=icb, we compute tvp at level icb+1
+  ! (tvp at other levels will be computed in cv3_undilute2.F)
+
+
+  DO i = 1, len
+    ticb(i) = t(i, icb(i)+1)
+    gzicb(i) = gz(i, icb(i)+1)
+    qsicb(i) = qs(i, icb(i)+1)
+  END DO
+
+  DO i = 1, len
+    tg = ticb(i)
+    qg = qsicb(i) ! convect3
+    ! debug         alv=lv0-clmcpv*(ticb(i)-t0)
+    alv = lv0 - clmcpv*(ticb(i)-273.15)
+
+    ! First iteration.
+
+    ! ori          s=cpd+alv*alv*qg/(rrv*ticb(i)*ticb(i))
+    s = cpd*(1.-qnk(i)) + cl*qnk(i) & ! convect3
+      +alv*alv*qg/(rrv*ticb(i)*ticb(i)) ! convect3
+    s = 1./s
+    ! ori          ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i)
+    ahg = cpd*tg + (cl-cpd)*qnk(i)*tg + alv*qg + gzicb(i) ! convect3
+    tg = tg + s*(ah0(i)-ahg)
+    ! ori          tg=max(tg,35.0)
+    ! debug          tc=tg-t0
+    tc = tg - 273.15
+    denom = 243.5 + tc
+    denom = max(denom, 1.0) ! convect3
+    ! ori          if(tc.ge.0.0)then
+    es = 6.112*exp(17.67*tc/denom)
+    ! ori          else
+    ! ori           es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
+    ! ori          endif
+    ! ori          qg=eps*es/(p(i,icb(i))-es*(1.-eps))
+    qg = eps*es/(p(i,icb(i)+1)-es*(1.-eps))
+
+    ! Second iteration.
+
+
+    ! ori          s=cpd+alv*alv*qg/(rrv*ticb(i)*ticb(i))
+    ! ori          s=1./s
+    ! ori          ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i)
+    ahg = cpd*tg + (cl-cpd)*qnk(i)*tg + alv*qg + gzicb(i) ! convect3
+    tg = tg + s*(ah0(i)-ahg)
+    ! ori          tg=max(tg,35.0)
+    ! debug          tc=tg-t0
+    tc = tg - 273.15
+    denom = 243.5 + tc
+    denom = max(denom, 1.0) ! convect3
+    ! ori          if(tc.ge.0.0)then
+    es = 6.112*exp(17.67*tc/denom)
+    ! ori          else
+    ! ori           es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
+    ! ori          end if
+    ! ori          qg=eps*es/(p(i,icb(i))-es*(1.-eps))
+    qg = eps*es/(p(i,icb(i)+1)-es*(1.-eps))
+
+    alv = lv0 - clmcpv*(ticb(i)-273.15)
+
+    ! ori c approximation here:
+    ! ori         tp(i,icb(i))=(ah0(i)-(cl-cpd)*qnk(i)*ticb(i)
+    ! ori     &   -gz(i,icb(i))-alv*qg)/cpd
+
+    ! convect3: no approximation:
+    tp(i, icb(i)+1) = (ah0(i)-gz(i,icb(i)+1)-alv*qg)/(cpd+(cl-cpd)*qnk(i))
+
+    ! ori         clw(i,icb(i))=qnk(i)-qg
+    ! ori         clw(i,icb(i))=max(0.0,clw(i,icb(i)))
+    clw(i, icb(i)+1) = qnk(i) - qg
+    clw(i, icb(i)+1) = max(0.0, clw(i,icb(i)+1))
+
+    rg = qg/(1.-qnk(i))
+    ! ori         tvp(i,icb(i))=tp(i,icb(i))*(1.+rg*epsi)
+    ! convect3: (qg utilise au lieu du vrai mixing ratio rg)
+    tvp(i, icb(i)+1) = tp(i, icb(i)+1)*(1.+qg/eps-qnk(i)) !whole thing
+
+  END DO
+
+  RETURN
+END SUBROUTINE cv30_undilute1
+
+SUBROUTINE cv30_trigger(len, nd, icb, plcl, p, th, tv, tvp, pbase, buoybase, &
+    iflag, sig, w0)
+  IMPLICIT NONE
+
+  ! -------------------------------------------------------------------
+  ! --- TRIGGERING
+
+  ! - computes the cloud base
+  ! - triggering (crude in this version)
+  ! - relaxation of sig and w0 when no convection
+
+  ! Caution1: if no convection, we set iflag=4
+  ! (it used to be 0 in convect3)
+
+  ! Caution2: at this stage, tvp (and thus buoy) are know up
+  ! through icb only!
+  ! -> the buoyancy below cloud base not (yet) set to the cloud base buoyancy
+  ! -------------------------------------------------------------------
+
+  include "cv30param.h"
+
+  ! input:
+  INTEGER len, nd
+  INTEGER icb(len)
+  REAL plcl(len), p(len, nd)
+  REAL th(len, nd), tv(len, nd), tvp(len, nd)
+
+  ! output:
+  REAL pbase(len), buoybase(len)
+
+  ! input AND output:
+  INTEGER iflag(len)
+  REAL sig(len, nd), w0(len, nd)
+
+  ! local variables:
+  INTEGER i, k
+  REAL tvpbase, tvbase, tdif, ath, ath1
+
+
+  ! ***   set cloud base buoyancy at (plcl+dpbase) level buoyancy
+
+  DO i = 1, len
+    pbase(i) = plcl(i) + dpbase
+    tvpbase = tvp(i, icb(i))*(pbase(i)-p(i,icb(i)+1))/ &
+      (p(i,icb(i))-p(i,icb(i)+1)) + tvp(i, icb(i)+1)*(p(i,icb(i))-pbase(i))/( &
+      p(i,icb(i))-p(i,icb(i)+1))
+    tvbase = tv(i, icb(i))*(pbase(i)-p(i,icb(i)+1))/ &
+      (p(i,icb(i))-p(i,icb(i)+1)) + tv(i, icb(i)+1)*(p(i,icb(i))-pbase(i))/(p &
+      (i,icb(i))-p(i,icb(i)+1))
+    buoybase(i) = tvpbase - tvbase
+  END DO
+
+
+  ! ***   make sure that column is dry adiabatic between the surface  ***
+  ! ***    and cloud base, and that lifted air is positively buoyant  ***
+  ! ***                         at cloud base                         ***
+  ! ***       if not, return to calling program after resetting       ***
+  ! ***                        sig(i) and w0(i)                       ***
+
+
+  ! oct3      do 200 i=1,len
+  ! oct3
+  ! oct3       tdif = buoybase(i)
+  ! oct3       ath1 = th(i,1)
+  ! oct3       ath  = th(i,icb(i)-1) - dttrig
+  ! oct3
+  ! oct3       if (tdif.lt.dtcrit .or. ath.gt.ath1) then
+  ! oct3         do 60 k=1,nl
+  ! oct3            sig(i,k) = beta*sig(i,k) - 2.*alpha*tdif*tdif
+  ! oct3            sig(i,k) = AMAX1(sig(i,k),0.0)
+  ! oct3            w0(i,k)  = beta*w0(i,k)
+  ! oct3   60    continue
+  ! oct3         iflag(i)=4 ! pour version vectorisee
+  ! oct3c convect3         iflag(i)=0
+  ! oct3cccc         return
+  ! oct3       endif
+  ! oct3
+  ! oct3200   continue
+
+  ! -- oct3: on reecrit la boucle 200 (pour la vectorisation)
+
+  DO k = 1, nl
+    DO i = 1, len
+
+      tdif = buoybase(i)
+      ath1 = th(i, 1)
+      ath = th(i, icb(i)-1) - dttrig
+
+      IF (tdif<dtcrit .OR. ath>ath1) THEN
+        sig(i, k) = beta*sig(i, k) - 2.*alpha*tdif*tdif
+        sig(i, k) = amax1(sig(i,k), 0.0)
+        w0(i, k) = beta*w0(i, k)
+        iflag(i) = 4 ! pour version vectorisee
+        ! convect3         iflag(i)=0
+      END IF
+
+    END DO
+  END DO
+
+  ! fin oct3 --
+
+  RETURN
+END SUBROUTINE cv30_trigger
+
+SUBROUTINE cv30_compress(len, nloc, ncum, nd, ntra, iflag1, nk1, icb1, icbs1, &
+    plcl1, tnk1, qnk1, gznk1, pbase1, buoybase1, t1, q1, qs1, u1, v1, gz1, &
+    th1, tra1, h1, lv1, cpn1, p1, ph1, tv1, tp1, tvp1, clw1, sig1, w01, &
+    iflag, nk, icb, icbs, plcl, tnk, qnk, gznk, pbase, buoybase, t, q, qs, u, &
+    v, gz, th, tra, h, lv, cpn, p, ph, tv, tp, tvp, clw, sig, w0)
+  USE print_control_mod, ONLY: lunout
+  IMPLICIT NONE
+
+  include "cv30param.h"
+
+  ! inputs:
+  INTEGER len, ncum, nd, ntra, nloc
+  INTEGER iflag1(len), nk1(len), icb1(len), icbs1(len)
+  REAL plcl1(len), tnk1(len), qnk1(len), gznk1(len)
+  REAL pbase1(len), buoybase1(len)
+  REAL t1(len, nd), q1(len, nd), qs1(len, nd), u1(len, nd), v1(len, nd)
+  REAL gz1(len, nd), h1(len, nd), lv1(len, nd), cpn1(len, nd)
+  REAL p1(len, nd), ph1(len, nd+1), tv1(len, nd), tp1(len, nd)
+  REAL tvp1(len, nd), clw1(len, nd)
+  REAL th1(len, nd)
+  REAL sig1(len, nd), w01(len, nd)
+  REAL tra1(len, nd, ntra)
+
+  ! outputs:
+  ! en fait, on a nloc=len pour l'instant (cf cv_driver)
+  INTEGER iflag(nloc), nk(nloc), icb(nloc), icbs(nloc)
+  REAL plcl(nloc), tnk(nloc), qnk(nloc), gznk(nloc)
+  REAL pbase(nloc), buoybase(nloc)
+  REAL t(nloc, nd), q(nloc, nd), qs(nloc, nd), u(nloc, nd), v(nloc, nd)
+  REAL gz(nloc, nd), h(nloc, nd), lv(nloc, nd), cpn(nloc, nd)
+  REAL p(nloc, nd), ph(nloc, nd+1), tv(nloc, nd), tp(nloc, nd)
+  REAL tvp(nloc, nd), clw(nloc, nd)
+  REAL th(nloc, nd)
+  REAL sig(nloc, nd), w0(nloc, nd)
+  REAL tra(nloc, nd, ntra)
+
+  ! local variables:
+  INTEGER i, k, nn, j
+
+  CHARACTER (LEN=20) :: modname = 'cv30_compress'
+  CHARACTER (LEN=80) :: abort_message
+
+
+  DO k = 1, nl + 1
+    nn = 0
+    DO i = 1, len
+      IF (iflag1(i)==0) THEN
+        nn = nn + 1
+        sig(nn, k) = sig1(i, k)
+        w0(nn, k) = w01(i, k)
+        t(nn, k) = t1(i, k)
+        q(nn, k) = q1(i, k)
+        qs(nn, k) = qs1(i, k)
+        u(nn, k) = u1(i, k)
+        v(nn, k) = v1(i, k)
+        gz(nn, k) = gz1(i, k)
+        h(nn, k) = h1(i, k)
+        lv(nn, k) = lv1(i, k)
+        cpn(nn, k) = cpn1(i, k)
+        p(nn, k) = p1(i, k)
+        ph(nn, k) = ph1(i, k)
+        tv(nn, k) = tv1(i, k)
+        tp(nn, k) = tp1(i, k)
+        tvp(nn, k) = tvp1(i, k)
+        clw(nn, k) = clw1(i, k)
+        th(nn, k) = th1(i, k)
+      END IF
+    END DO
+  END DO
+
+  ! do 121 j=1,ntra
+  ! do 111 k=1,nd
+  ! nn=0
+  ! do 101 i=1,len
+  ! if(iflag1(i).eq.0)then
+  ! nn=nn+1
+  ! tra(nn,k,j)=tra1(i,k,j)
+  ! endif
+  ! 101  continue
+  ! 111  continue
+  ! 121  continue
+
+  IF (nn/=ncum) THEN
+    WRITE (lunout, *) 'strange! nn not equal to ncum: ', nn, ncum
+    abort_message = ''
+    CALL abort_physic(modname, abort_message, 1)
+  END IF
+
+  nn = 0
+  DO i = 1, len
+    IF (iflag1(i)==0) THEN
+      nn = nn + 1
+      pbase(nn) = pbase1(i)
+      buoybase(nn) = buoybase1(i)
+      plcl(nn) = plcl1(i)
+      tnk(nn) = tnk1(i)
+      qnk(nn) = qnk1(i)
+      gznk(nn) = gznk1(i)
+      nk(nn) = nk1(i)
+      icb(nn) = icb1(i)
+      icbs(nn) = icbs1(i)
+      iflag(nn) = iflag1(i)
+    END IF
+  END DO
+
+  RETURN
+END SUBROUTINE cv30_compress
+
+SUBROUTINE cv30_undilute2(nloc, ncum, nd, icb, icbs, nk, tnk, qnk, gznk, t, &
+    q, qs, gz, p, h, tv, lv, pbase, buoybase, plcl, inb, tp, tvp, clw, hp, &
+    ep, sigp, buoy)
+    ! epmax_cape: ajout arguments
+  IMPLICIT NONE
+
+  ! ---------------------------------------------------------------------
+  ! Purpose:
+  ! FIND THE REST OF THE LIFTED PARCEL TEMPERATURES
+  ! &
+  ! COMPUTE THE PRECIPITATION EFFICIENCIES AND THE
+  ! FRACTION OF PRECIPITATION FALLING OUTSIDE OF CLOUD
+  ! &
+  ! FIND THE LEVEL OF NEUTRAL BUOYANCY
+
+  ! Main differences convect3/convect4:
+  ! - icbs (input) is the first level above LCL (may differ from icb)
+  ! - many minor differences in the iterations
+  ! - condensed water not removed from tvp in convect3
+  ! - vertical profile of buoyancy computed here (use of buoybase)
+  ! - the determination of inb is different
+  ! - no inb1, only inb in output
+  ! ---------------------------------------------------------------------
+
+  include "cvthermo.h"
+  include "cv30param.h"
+  include "conema3.h"
+
+  ! inputs:
+  INTEGER ncum, nd, nloc
+  INTEGER icb(nloc), icbs(nloc), nk(nloc)
+  REAL t(nloc, nd), q(nloc, nd), qs(nloc, nd), gz(nloc, nd)
+  REAL p(nloc, nd)
+  REAL tnk(nloc), qnk(nloc), gznk(nloc)
+  REAL lv(nloc, nd), tv(nloc, nd), h(nloc, nd)
+  REAL pbase(nloc), buoybase(nloc), plcl(nloc)
+
+  ! outputs:
+  INTEGER inb(nloc)
+  REAL tp(nloc, nd), tvp(nloc, nd), clw(nloc, nd)
+  REAL ep(nloc, nd), sigp(nloc, nd), hp(nloc, nd)
+  REAL buoy(nloc, nd)
+
+  ! local variables:
+  INTEGER i, k
+  REAL tg, qg, ahg, alv, s, tc, es, denom, rg, tca, elacrit
+  REAL by, defrac, pden
+  REAL ah0(nloc), cape(nloc), capem(nloc), byp(nloc)
+  LOGICAL lcape(nloc)
+
+  ! =====================================================================
+  ! --- SOME INITIALIZATIONS
+  ! =====================================================================
+
+  DO k = 1, nl
+    DO i = 1, ncum
+      ep(i, k) = 0.0
+      sigp(i, k) = spfac
+    END DO
+  END DO
+
+  ! =====================================================================
+  ! --- FIND THE REST OF THE LIFTED PARCEL TEMPERATURES
+  ! =====================================================================
+
+  ! ---       The procedure is to solve the equation.
+  ! cp*tp+L*qp+phi=cp*tnk+L*qnk+gznk.
+
+  ! ***  Calculate certain parcel quantities, including static energy   ***
+
+
+  DO i = 1, ncum
+    ah0(i) = (cpd*(1.-qnk(i))+cl*qnk(i))*tnk(i) & ! debug     &
+                                                  ! +qnk(i)*(lv0-clmcpv*(tnk(i)-t0))+gznk(i)
+      +qnk(i)*(lv0-clmcpv*(tnk(i)-273.15)) + gznk(i)
+  END DO
+
+
+  ! ***  Find lifted parcel quantities above cloud base    ***
+
+
+  DO k = minorig + 1, nl
+    DO i = 1, ncum
+      ! ori	    if(k.ge.(icb(i)+1))then
+      IF (k>=(icbs(i)+1)) THEN ! convect3
+        tg = t(i, k)
+        qg = qs(i, k)
+        ! debug	      alv=lv0-clmcpv*(t(i,k)-t0)
+        alv = lv0 - clmcpv*(t(i,k)-273.15)
+
+        ! First iteration.
+
+        ! ori	       s=cpd+alv*alv*qg/(rrv*t(i,k)*t(i,k))
+        s = cpd*(1.-qnk(i)) + cl*qnk(i) & ! convect3
+          +alv*alv*qg/(rrv*t(i,k)*t(i,k)) ! convect3
+        s = 1./s
+        ! ori	       ahg=cpd*tg+(cl-cpd)*qnk(i)*t(i,k)+alv*qg+gz(i,k)
+        ahg = cpd*tg + (cl-cpd)*qnk(i)*tg + alv*qg + gz(i, k) ! convect3
+        tg = tg + s*(ah0(i)-ahg)
+        ! ori	       tg=max(tg,35.0)
+        ! debug	       tc=tg-t0
+        tc = tg - 273.15
+        denom = 243.5 + tc
+        denom = max(denom, 1.0) ! convect3
+        ! ori	       if(tc.ge.0.0)then
+        es = 6.112*exp(17.67*tc/denom)
+        ! ori	       else
+        ! ori			es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
+        ! ori	       endif
+        qg = eps*es/(p(i,k)-es*(1.-eps))
+
+        ! Second iteration.
+
+        ! ori	       s=cpd+alv*alv*qg/(rrv*t(i,k)*t(i,k))
+        ! ori	       s=1./s
+        ! ori	       ahg=cpd*tg+(cl-cpd)*qnk(i)*t(i,k)+alv*qg+gz(i,k)
+        ahg = cpd*tg + (cl-cpd)*qnk(i)*tg + alv*qg + gz(i, k) ! convect3
+        tg = tg + s*(ah0(i)-ahg)
+        ! ori	       tg=max(tg,35.0)
+        ! debug	       tc=tg-t0
+        tc = tg - 273.15
+        denom = 243.5 + tc
+        denom = max(denom, 1.0) ! convect3
+        ! ori	       if(tc.ge.0.0)then
+        es = 6.112*exp(17.67*tc/denom)
+        ! ori	       else
+        ! ori			es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
+        ! ori	       endif
+        qg = eps*es/(p(i,k)-es*(1.-eps))
+
+        ! debug	       alv=lv0-clmcpv*(t(i,k)-t0)
+        alv = lv0 - clmcpv*(t(i,k)-273.15)
+        ! print*,'cpd dans convect2 ',cpd
+        ! print*,'tp(i,k),ah0(i),cl,cpd,qnk(i),t(i,k),gz(i,k),alv,qg,cpd'
+        ! print*,tp(i,k),ah0(i),cl,cpd,qnk(i),t(i,k),gz(i,k),alv,qg,cpd
+
+        ! ori c approximation here:
+        ! ori
+        ! tp(i,k)=(ah0(i)-(cl-cpd)*qnk(i)*t(i,k)-gz(i,k)-alv*qg)/cpd
+
+        ! convect3: no approximation:
+        tp(i, k) = (ah0(i)-gz(i,k)-alv*qg)/(cpd+(cl-cpd)*qnk(i))
+
+        clw(i, k) = qnk(i) - qg
+        clw(i, k) = max(0.0, clw(i,k))
+        rg = qg/(1.-qnk(i))
+        ! ori               tvp(i,k)=tp(i,k)*(1.+rg*epsi)
+        ! convect3: (qg utilise au lieu du vrai mixing ratio rg):
+        tvp(i, k) = tp(i, k)*(1.+qg/eps-qnk(i)) ! whole thing
+      END IF
+    END DO
+  END DO
+
+  ! =====================================================================
+  ! --- SET THE PRECIPITATION EFFICIENCIES AND THE FRACTION OF
+  ! --- PRECIPITATION FALLING OUTSIDE OF CLOUD
+  ! --- THESE MAY BE FUNCTIONS OF TP(I), P(I) AND CLW(I)
+  ! =====================================================================
+
+  ! ori      do 320 k=minorig+1,nl
+  DO k = 1, nl ! convect3
+    DO i = 1, ncum
+      pden = ptcrit - pbcrit
+      ep(i, k) = (plcl(i)-p(i,k)-pbcrit)/pden*epmax
+      ep(i, k) = amax1(ep(i,k), 0.0)
+      ep(i, k) = amin1(ep(i,k), epmax)
+      sigp(i, k) = spfac
+      ! ori          if(k.ge.(nk(i)+1))then
+      ! ori            tca=tp(i,k)-t0
+      ! ori            if(tca.ge.0.0)then
+      ! ori              elacrit=elcrit
+      ! ori            else
+      ! ori              elacrit=elcrit*(1.0-tca/tlcrit)
+      ! ori            endif
+      ! ori            elacrit=max(elacrit,0.0)
+      ! ori            ep(i,k)=1.0-elacrit/max(clw(i,k),1.0e-8)
+      ! ori            ep(i,k)=max(ep(i,k),0.0 )
+      ! ori            ep(i,k)=min(ep(i,k),1.0 )
+      ! ori            sigp(i,k)=sigs
+      ! ori          endif
+    END DO
+  END DO
+
+  ! =====================================================================
+  ! --- CALCULATE VIRTUAL TEMPERATURE AND LIFTED PARCEL
+  ! --- VIRTUAL TEMPERATURE
+  ! =====================================================================
+
+  ! dans convect3, tvp est calcule en une seule fois, et sans retirer
+  ! l'eau condensee (~> reversible CAPE)
+
+  ! ori      do 340 k=minorig+1,nl
+  ! ori        do 330 i=1,ncum
+  ! ori        if(k.ge.(icb(i)+1))then
+  ! ori          tvp(i,k)=tvp(i,k)*(1.0-qnk(i)+ep(i,k)*clw(i,k))
+  ! oric         print*,'i,k,tvp(i,k),qnk(i),ep(i,k),clw(i,k)'
+  ! oric         print*, i,k,tvp(i,k),qnk(i),ep(i,k),clw(i,k)
+  ! ori        endif
+  ! ori 330    continue
+  ! ori 340  continue
+
+  ! ori      do 350 i=1,ncum
+  ! ori       tvp(i,nlp)=tvp(i,nl)-(gz(i,nlp)-gz(i,nl))/cpd
+  ! ori 350  continue
+
+  DO i = 1, ncum ! convect3
+    tp(i, nlp) = tp(i, nl) ! convect3
+  END DO ! convect3
+
+  ! =====================================================================
+  ! --- EFFECTIVE VERTICAL PROFILE OF BUOYANCY (convect3 only):
+  ! =====================================================================
+
+  ! -- this is for convect3 only:
+
+  ! first estimate of buoyancy:
+
+  DO i = 1, ncum
+    DO k = 1, nl
+      buoy(i, k) = tvp(i, k) - tv(i, k)
+    END DO
+  END DO
+
+  ! set buoyancy=buoybase for all levels below base
+  ! for safety, set buoy(icb)=buoybase
+
+  DO i = 1, ncum
+    DO k = 1, nl
+      IF ((k>=icb(i)) .AND. (k<=nl) .AND. (p(i,k)>=pbase(i))) THEN
+        buoy(i, k) = buoybase(i)
+      END IF
+    END DO
+    ! IM cf. CRio/JYG 270807   buoy(icb(i),k)=buoybase(i)
+    buoy(i, icb(i)) = buoybase(i)
+  END DO
+
+  ! -- end convect3
+
+  ! =====================================================================
+  ! --- FIND THE FIRST MODEL LEVEL (INB) ABOVE THE PARCEL'S
+  ! --- LEVEL OF NEUTRAL BUOYANCY
+  ! =====================================================================
+
+  ! -- this is for convect3 only:
+
+  DO i = 1, ncum
+    inb(i) = nl - 1
+  END DO
+
+  DO i = 1, ncum
+    DO k = 1, nl - 1
+      IF ((k>=icb(i)) .AND. (buoy(i,k)<dtovsh)) THEN
+        inb(i) = min(inb(i), k)
+      END IF
+    END DO
+  END DO
+
+  ! -- end convect3
+
+  ! ori      do 510 i=1,ncum
+  ! ori        cape(i)=0.0
+  ! ori        capem(i)=0.0
+  ! ori        inb(i)=icb(i)+1
+  ! ori        inb1(i)=inb(i)
+  ! ori 510  continue
+
+  ! Originial Code
+
+  ! do 530 k=minorig+1,nl-1
+  ! do 520 i=1,ncum
+  ! if(k.ge.(icb(i)+1))then
+  ! by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k)
+  ! byp=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1)
+  ! cape(i)=cape(i)+by
+  ! if(by.ge.0.0)inb1(i)=k+1
+  ! if(cape(i).gt.0.0)then
+  ! inb(i)=k+1
+  ! capem(i)=cape(i)
+  ! endif
+  ! endif
+  ! 520    continue
+  ! 530  continue
+  ! do 540 i=1,ncum
+  ! byp=(tvp(i,nl)-tv(i,nl))*dph(i,nl)/p(i,nl)
+  ! cape(i)=capem(i)+byp
+  ! defrac=capem(i)-cape(i)
+  ! defrac=max(defrac,0.001)
+  ! frac(i)=-cape(i)/defrac
+  ! frac(i)=min(frac(i),1.0)
+  ! frac(i)=max(frac(i),0.0)
+  ! 540   continue
+
+  ! K Emanuel fix
+
+  ! call zilch(byp,ncum)
+  ! do 530 k=minorig+1,nl-1
+  ! do 520 i=1,ncum
+  ! if(k.ge.(icb(i)+1))then
+  ! by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k)
+  ! cape(i)=cape(i)+by
+  ! if(by.ge.0.0)inb1(i)=k+1
+  ! if(cape(i).gt.0.0)then
+  ! inb(i)=k+1
+  ! capem(i)=cape(i)
+  ! byp(i)=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1)
+  ! endif
+  ! endif
+  ! 520    continue
+  ! 530  continue
+  ! do 540 i=1,ncum
+  ! inb(i)=max(inb(i),inb1(i))
+  ! cape(i)=capem(i)+byp(i)
+  ! defrac=capem(i)-cape(i)
+  ! defrac=max(defrac,0.001)
+  ! frac(i)=-cape(i)/defrac
+  ! frac(i)=min(frac(i),1.0)
+  ! frac(i)=max(frac(i),0.0)
+  ! 540   continue
+
+  ! J Teixeira fix
+
+  ! ori      call zilch(byp,ncum)
+  ! ori      do 515 i=1,ncum
+  ! ori        lcape(i)=.true.
+  ! ori 515  continue
+  ! ori      do 530 k=minorig+1,nl-1
+  ! ori        do 520 i=1,ncum
+  ! ori          if(cape(i).lt.0.0)lcape(i)=.false.
+  ! ori          if((k.ge.(icb(i)+1)).and.lcape(i))then
+  ! ori            by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k)
+  ! ori            byp(i)=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1)
+  ! ori            cape(i)=cape(i)+by
+  ! ori            if(by.ge.0.0)inb1(i)=k+1
+  ! ori            if(cape(i).gt.0.0)then
+  ! ori              inb(i)=k+1
+  ! ori              capem(i)=cape(i)
+  ! ori            endif
+  ! ori          endif
+  ! ori 520    continue
+  ! ori 530  continue
+  ! ori      do 540 i=1,ncum
+  ! ori          cape(i)=capem(i)+byp(i)
+  ! ori          defrac=capem(i)-cape(i)
+  ! ori          defrac=max(defrac,0.001)
+  ! ori          frac(i)=-cape(i)/defrac
+  ! ori          frac(i)=min(frac(i),1.0)
+  ! ori          frac(i)=max(frac(i),0.0)
+  ! ori 540  continue
+
+  ! =====================================================================
+  ! ---   CALCULATE LIQUID WATER STATIC ENERGY OF LIFTED PARCEL
+  ! =====================================================================
+
+  ! ym      do i=1,ncum*nlp
+  ! ym       hp(i,1)=h(i,1)
+  ! ym      enddo
+
+  DO k = 1, nlp
+    DO i = 1, ncum
+      hp(i, k) = h(i, k)
+    END DO
+  END DO
+
+  DO k = minorig + 1, nl
+    DO i = 1, ncum
+      IF ((k>=icb(i)) .AND. (k<=inb(i))) THEN
+        hp(i, k) = h(i, nk(i)) + (lv(i,k)+(cpd-cpv)*t(i,k))*ep(i, k)*clw(i, k &
+          )
+      END IF
+    END DO
+  END DO
+
+  RETURN
+END SUBROUTINE cv30_undilute2
+
+SUBROUTINE cv30_closure(nloc, ncum, nd, icb, inb, pbase, p, ph, tv, buoy, &
+    sig, w0, cape, m)
+  IMPLICIT NONE
+
+  ! ===================================================================
+  ! ---  CLOSURE OF CONVECT3
+
+  ! vectorization: S. Bony
+  ! ===================================================================
+
+  include "cvthermo.h"
+  include "cv30param.h"
+
+  ! input:
+  INTEGER ncum, nd, nloc
+  INTEGER icb(nloc), inb(nloc)
+  REAL pbase(nloc)
+  REAL p(nloc, nd), ph(nloc, nd+1)
+  REAL tv(nloc, nd), buoy(nloc, nd)
+
+  ! input/output:
+  REAL sig(nloc, nd), w0(nloc, nd)
+
+  ! output:
+  REAL cape(nloc)
+  REAL m(nloc, nd)
+
+  ! local variables:
+  INTEGER i, j, k, icbmax
+  REAL deltap, fac, w, amu
+  REAL dtmin(nloc, nd), sigold(nloc, nd)
+
+  ! -------------------------------------------------------
+  ! -- Initialization
+  ! -------------------------------------------------------
+
+  DO k = 1, nl
+    DO i = 1, ncum
+      m(i, k) = 0.0
+    END DO
+  END DO
+
+  ! -------------------------------------------------------
+  ! -- Reset sig(i) and w0(i) for i>inb and i<icb
+  ! -------------------------------------------------------
+
+  ! update sig and w0 above LNB:
+
+  DO k = 1, nl - 1
+    DO i = 1, ncum
+      IF ((inb(i)<(nl-1)) .AND. (k>=(inb(i)+1))) THEN
+        sig(i, k) = beta*sig(i, k) + 2.*alpha*buoy(i, inb(i))*abs(buoy(i,inb( &
+          i)))
+        sig(i, k) = amax1(sig(i,k), 0.0)
+        w0(i, k) = beta*w0(i, k)
+      END IF
+    END DO
+  END DO
+
+  ! compute icbmax:
+
+  icbmax = 2
+  DO i = 1, ncum
+    icbmax = max(icbmax, icb(i))
+  END DO
+
+  ! update sig and w0 below cloud base:
+
+  DO k = 1, icbmax
+    DO i = 1, ncum
+      IF (k<=icb(i)) THEN
+        sig(i, k) = beta*sig(i, k) - 2.*alpha*buoy(i, icb(i))*buoy(i, icb(i))
+        sig(i, k) = amax1(sig(i,k), 0.0)
+        w0(i, k) = beta*w0(i, k)
+      END IF
+    END DO
+  END DO
+
+  ! !      if(inb.lt.(nl-1))then
+  ! !         do 85 i=inb+1,nl-1
+  ! !            sig(i)=beta*sig(i)+2.*alpha*buoy(inb)*
+  ! !     1              abs(buoy(inb))
+  ! !            sig(i)=amax1(sig(i),0.0)
+  ! !            w0(i)=beta*w0(i)
+  ! !   85    continue
+  ! !      end if
+
+  ! !      do 87 i=1,icb
+  ! !         sig(i)=beta*sig(i)-2.*alpha*buoy(icb)*buoy(icb)
+  ! !         sig(i)=amax1(sig(i),0.0)
+  ! !         w0(i)=beta*w0(i)
+  ! !   87 continue
+
+  ! -------------------------------------------------------------
+  ! -- Reset fractional areas of updrafts and w0 at initial time
+  ! -- and after 10 time steps of no convection
+  ! -------------------------------------------------------------
+
+  DO k = 1, nl - 1
+    DO i = 1, ncum
+      IF (sig(i,nd)<1.5 .OR. sig(i,nd)>12.0) THEN
+        sig(i, k) = 0.0
+        w0(i, k) = 0.0
+      END IF
+    END DO
+  END DO
+
+  ! -------------------------------------------------------------
+  ! -- Calculate convective available potential energy (cape),
+  ! -- vertical velocity (w), fractional area covered by
+  ! -- undilute updraft (sig), and updraft mass flux (m)
+  ! -------------------------------------------------------------
+
+  DO i = 1, ncum
+    cape(i) = 0.0
+  END DO
+
+  ! compute dtmin (minimum buoyancy between ICB and given level k):
+
+  DO i = 1, ncum
+    DO k = 1, nl
+      dtmin(i, k) = 100.0
+    END DO
+  END DO
+
+  DO i = 1, ncum
+    DO k = 1, nl
+      DO j = minorig, nl
+        IF ((k>=(icb(i)+1)) .AND. (k<=inb(i)) .AND. (j>=icb(i)) .AND. (j<=(k- &
+            1))) THEN
+          dtmin(i, k) = amin1(dtmin(i,k), buoy(i,j))
+        END IF
+      END DO
+    END DO
+  END DO
+
+  ! the interval on which cape is computed starts at pbase :
+  DO k = 1, nl
+    DO i = 1, ncum
+
+      IF ((k>=(icb(i)+1)) .AND. (k<=inb(i))) THEN
+
+        deltap = min(pbase(i), ph(i,k-1)) - min(pbase(i), ph(i,k))
+        cape(i) = cape(i) + rrd*buoy(i, k-1)*deltap/p(i, k-1)
+        cape(i) = amax1(0.0, cape(i))
+        sigold(i, k) = sig(i, k)
+
+        ! dtmin(i,k)=100.0
+        ! do 97 j=icb(i),k-1 ! mauvaise vectorisation
+        ! dtmin(i,k)=AMIN1(dtmin(i,k),buoy(i,j))
+        ! 97     continue
+
+        sig(i, k) = beta*sig(i, k) + alpha*dtmin(i, k)*abs(dtmin(i,k))
+        sig(i, k) = amax1(sig(i,k), 0.0)
+        sig(i, k) = amin1(sig(i,k), 0.01)
+        fac = amin1(((dtcrit-dtmin(i,k))/dtcrit), 1.0)
+        w = (1.-beta)*fac*sqrt(cape(i)) + beta*w0(i, k)
+        amu = 0.5*(sig(i,k)+sigold(i,k))*w
+        m(i, k) = amu*0.007*p(i, k)*(ph(i,k)-ph(i,k+1))/tv(i, k)
+        w0(i, k) = w
+      END IF
+
+    END DO
+  END DO
+
+  DO i = 1, ncum
+    w0(i, icb(i)) = 0.5*w0(i, icb(i)+1)
+    m(i, icb(i)) = 0.5*m(i, icb(i)+1)*(ph(i,icb(i))-ph(i,icb(i)+1))/ &
+      (ph(i,icb(i)+1)-ph(i,icb(i)+2))
+    sig(i, icb(i)) = sig(i, icb(i)+1)
+    sig(i, icb(i)-1) = sig(i, icb(i))
+  END DO
+
+
+  ! !      cape=0.0
+  ! !      do 98 i=icb+1,inb
+  ! !         deltap = min(pbase,ph(i-1))-min(pbase,ph(i))
+  ! !         cape=cape+rrd*buoy(i-1)*deltap/p(i-1)
+  ! !         dcape=rrd*buoy(i-1)*deltap/p(i-1)
+  ! !         dlnp=deltap/p(i-1)
+  ! !         cape=amax1(0.0,cape)
+  ! !         sigold=sig(i)
+
+  ! !         dtmin=100.0
+  ! !         do 97 j=icb,i-1
+  ! !            dtmin=amin1(dtmin,buoy(j))
+  ! !   97    continue
+
+  ! !         sig(i)=beta*sig(i)+alpha*dtmin*abs(dtmin)
+  ! !         sig(i)=amax1(sig(i),0.0)
+  ! !         sig(i)=amin1(sig(i),0.01)
+  ! !         fac=amin1(((dtcrit-dtmin)/dtcrit),1.0)
+  ! !         w=(1.-beta)*fac*sqrt(cape)+beta*w0(i)
+  ! !         amu=0.5*(sig(i)+sigold)*w
+  ! !         m(i)=amu*0.007*p(i)*(ph(i)-ph(i+1))/tv(i)
+  ! !         w0(i)=w
+  ! !   98 continue
+  ! !      w0(icb)=0.5*w0(icb+1)
+  ! !      m(icb)=0.5*m(icb+1)*(ph(icb)-ph(icb+1))/(ph(icb+1)-ph(icb+2))
+  ! !      sig(icb)=sig(icb+1)
+  ! !      sig(icb-1)=sig(icb)
+
+  RETURN
+END SUBROUTINE cv30_closure
+
+SUBROUTINE cv30_mixing(nloc, ncum, nd, na, ntra, icb, nk, inb, ph, t, rr, rs, &
+    u, v, tra, h, lv, qnk, hp, tv, tvp, ep, clw, m, sig, ment, qent, uent, &
+    vent, sij, elij, ments, qents, traent)
+  IMPLICIT NONE
+
+  ! ---------------------------------------------------------------------
+  ! a faire:
+  ! - changer rr(il,1) -> qnk(il)
+  ! - vectorisation de la partie normalisation des flux (do 789...)
+  ! ---------------------------------------------------------------------
+
+  include "cvthermo.h"
+  include "cv30param.h"
+
+  ! inputs:
+  INTEGER ncum, nd, na, ntra, nloc
+  INTEGER icb(nloc), inb(nloc), nk(nloc)
+  REAL sig(nloc, nd)
+  REAL qnk(nloc)
+  REAL ph(nloc, nd+1)
+  REAL t(nloc, nd), rr(nloc, nd), rs(nloc, nd)
+  REAL u(nloc, nd), v(nloc, nd)
+  REAL tra(nloc, nd, ntra) ! input of convect3
+  REAL lv(nloc, na), h(nloc, na), hp(nloc, na)
+  REAL tv(nloc, na), tvp(nloc, na), ep(nloc, na), clw(nloc, na)
+  REAL m(nloc, na) ! input of convect3
+
+  ! outputs:
+  REAL ment(nloc, na, na), qent(nloc, na, na)
+  REAL uent(nloc, na, na), vent(nloc, na, na)
+  REAL sij(nloc, na, na), elij(nloc, na, na)
+  REAL traent(nloc, nd, nd, ntra)
+  REAL ments(nloc, nd, nd), qents(nloc, nd, nd)
+  REAL sigij(nloc, nd, nd)
+
+  ! local variables:
+  INTEGER i, j, k, il, im, jm
+  INTEGER num1, num2
+  INTEGER nent(nloc, na)
+  REAL rti, bf2, anum, denom, dei, altem, cwat, stemp, qp
+  REAL alt, smid, sjmin, sjmax, delp, delm
+  REAL asij(nloc), smax(nloc), scrit(nloc)
+  REAL asum(nloc, nd), bsum(nloc, nd), csum(nloc, nd)
+  REAL wgh
+  REAL zm(nloc, na)
+  LOGICAL lwork(nloc)
+
+  ! =====================================================================
+  ! --- INITIALIZE VARIOUS ARRAYS USED IN THE COMPUTATIONS
+  ! =====================================================================
+
+  ! ori        do 360 i=1,ncum*nlp
+  DO j = 1, nl
+    DO i = 1, ncum
+      nent(i, j) = 0
+      ! in convect3, m is computed in cv3_closure
+      ! ori          m(i,1)=0.0
+    END DO
+  END DO
+
+  ! ori      do 400 k=1,nlp
+  ! ori       do 390 j=1,nlp
+  DO j = 1, nl
+    DO k = 1, nl
+      DO i = 1, ncum
+        qent(i, k, j) = rr(i, j)
+        uent(i, k, j) = u(i, j)
+        vent(i, k, j) = v(i, j)
+        elij(i, k, j) = 0.0
+        ! ym            ment(i,k,j)=0.0
+        ! ym            sij(i,k,j)=0.0
+      END DO
+    END DO
+  END DO
+
+  ! ym
+  ment(1:ncum, 1:nd, 1:nd) = 0.0
+  sij(1:ncum, 1:nd, 1:nd) = 0.0
+
+  ! do k=1,ntra
+  ! do j=1,nd  ! instead nlp
+  ! do i=1,nd ! instead nlp
+  ! do il=1,ncum
+  ! traent(il,i,j,k)=tra(il,j,k)
+  ! enddo
+  ! enddo
+  ! enddo
+  ! enddo
+  zm(:, :) = 0.
+
+  ! =====================================================================
+  ! --- CALCULATE ENTRAINED AIR MASS FLUX (ment), TOTAL WATER MIXING
+  ! --- RATIO (QENT), TOTAL CONDENSED WATER (elij), AND MIXING
+  ! --- FRACTION (sij)
+  ! =====================================================================
+
+  DO i = minorig + 1, nl
+
+    DO j = minorig, nl
+      DO il = 1, ncum
+        IF ((i>=icb(il)) .AND. (i<=inb(il)) .AND. (j>=(icb(il)- &
+            1)) .AND. (j<=inb(il))) THEN
+
+          rti = rr(il, 1) - ep(il, i)*clw(il, i)
+          bf2 = 1. + lv(il, j)*lv(il, j)*rs(il, j)/(rrv*t(il,j)*t(il,j)*cpd)
+          anum = h(il, j) - hp(il, i) + (cpv-cpd)*t(il, j)*(rti-rr(il,j))
+          denom = h(il, i) - hp(il, i) + (cpd-cpv)*(rr(il,i)-rti)*t(il, j)
+          dei = denom
+          IF (abs(dei)<0.01) dei = 0.01
+          sij(il, i, j) = anum/dei
+          sij(il, i, i) = 1.0
+          altem = sij(il, i, j)*rr(il, i) + (1.-sij(il,i,j))*rti - rs(il, j)
+          altem = altem/bf2
+          cwat = clw(il, j)*(1.-ep(il,j))
+          stemp = sij(il, i, j)
+          IF ((stemp<0.0 .OR. stemp>1.0 .OR. altem>cwat) .AND. j>i) THEN
+            anum = anum - lv(il, j)*(rti-rs(il,j)-cwat*bf2)
+            denom = denom + lv(il, j)*(rr(il,i)-rti)
+            IF (abs(denom)<0.01) denom = 0.01
+            sij(il, i, j) = anum/denom
+            altem = sij(il, i, j)*rr(il, i) + (1.-sij(il,i,j))*rti - &
+              rs(il, j)
+            altem = altem - (bf2-1.)*cwat
+          END IF
+          IF (sij(il,i,j)>0.0 .AND. sij(il,i,j)<0.95) THEN
+            qent(il, i, j) = sij(il, i, j)*rr(il, i) + (1.-sij(il,i,j))*rti
+            uent(il, i, j) = sij(il, i, j)*u(il, i) + &
+              (1.-sij(il,i,j))*u(il, nk(il))
+            vent(il, i, j) = sij(il, i, j)*v(il, i) + &
+              (1.-sij(il,i,j))*v(il, nk(il))
+            ! !!!      do k=1,ntra
+            ! !!!      traent(il,i,j,k)=sij(il,i,j)*tra(il,i,k)
+            ! !!!     :      +(1.-sij(il,i,j))*tra(il,nk(il),k)
+            ! !!!      end do
+            elij(il, i, j) = altem
+            elij(il, i, j) = amax1(0.0, elij(il,i,j))
+            ment(il, i, j) = m(il, i)/(1.-sij(il,i,j))
+            nent(il, i) = nent(il, i) + 1
+          END IF
+          sij(il, i, j) = amax1(0.0, sij(il,i,j))
+          sij(il, i, j) = amin1(1.0, sij(il,i,j))
+        END IF ! new
+      END DO
+    END DO
+
+    ! do k=1,ntra
+    ! do j=minorig,nl
+    ! do il=1,ncum
+    ! if( (i.ge.icb(il)).and.(i.le.inb(il)).and.
+    ! :       (j.ge.(icb(il)-1)).and.(j.le.inb(il)))then
+    ! traent(il,i,j,k)=sij(il,i,j)*tra(il,i,k)
+    ! :            +(1.-sij(il,i,j))*tra(il,nk(il),k)
+    ! endif
+    ! enddo
+    ! enddo
+    ! enddo
+
+
+    ! ***   if no air can entrain at level i assume that updraft detrains
+    ! ***
+    ! ***   at that level and calculate detrained air flux and properties
+    ! ***
+
+
+    ! @      do 170 i=icb(il),inb(il)
+
+    DO il = 1, ncum
+      IF ((i>=icb(il)) .AND. (i<=inb(il)) .AND. (nent(il,i)==0)) THEN
+        ! @      if(nent(il,i).eq.0)then
+        ment(il, i, i) = m(il, i)
+        qent(il, i, i) = rr(il, nk(il)) - ep(il, i)*clw(il, i)
+        uent(il, i, i) = u(il, nk(il))
+        vent(il, i, i) = v(il, nk(il))
+        elij(il, i, i) = clw(il, i)
+        ! MAF      sij(il,i,i)=1.0
+        sij(il, i, i) = 0.0
+      END IF
+    END DO
+  END DO
+
+  ! do j=1,ntra
+  ! do i=minorig+1,nl
+  ! do il=1,ncum
+  ! if (i.ge.icb(il) .and. i.le.inb(il) .and. nent(il,i).eq.0) then
+  ! traent(il,i,i,j)=tra(il,nk(il),j)
+  ! endif
+  ! enddo
+  ! enddo
+  ! enddo
+
+  DO j = minorig, nl
+    DO i = minorig, nl
+      DO il = 1, ncum
+        IF ((j>=(icb(il)-1)) .AND. (j<=inb(il)) .AND. (i>=icb(il)) .AND. (i<= &
+            inb(il))) THEN
+          sigij(il, i, j) = sij(il, i, j)
+        END IF
+      END DO
+    END DO
+  END DO
+  ! @      enddo
+
+  ! @170   continue
+
+  ! =====================================================================
+  ! ---  NORMALIZE ENTRAINED AIR MASS FLUXES
+  ! ---  TO REPRESENT EQUAL PROBABILITIES OF MIXING
+  ! =====================================================================
+
+  ! ym      call zilch(asum,ncum*nd)
+  ! ym      call zilch(bsum,ncum*nd)
+  ! ym      call zilch(csum,ncum*nd)
+  CALL zilch(asum, nloc*nd)
+  CALL zilch(csum, nloc*nd)
+  CALL zilch(csum, nloc*nd)
+
+  DO il = 1, ncum
+    lwork(il) = .FALSE.
+  END DO
+
+  DO i = minorig + 1, nl
+
+    num1 = 0
+    DO il = 1, ncum
+      IF (i>=icb(il) .AND. i<=inb(il)) num1 = num1 + 1
+    END DO
+    IF (num1<=0) GO TO 789
+
+
+    DO il = 1, ncum
+      IF (i>=icb(il) .AND. i<=inb(il)) THEN
+        lwork(il) = (nent(il,i)/=0)
+        qp = rr(il, 1) - ep(il, i)*clw(il, i)
+        anum = h(il, i) - hp(il, i) - lv(il, i)*(qp-rs(il,i)) + &
+          (cpv-cpd)*t(il, i)*(qp-rr(il,i))
+        denom = h(il, i) - hp(il, i) + lv(il, i)*(rr(il,i)-qp) + &
+          (cpd-cpv)*t(il, i)*(rr(il,i)-qp)
+        IF (abs(denom)<0.01) denom = 0.01
+        scrit(il) = anum/denom
+        alt = qp - rs(il, i) + scrit(il)*(rr(il,i)-qp)
+        IF (scrit(il)<=0.0 .OR. alt<=0.0) scrit(il) = 1.0
+        smax(il) = 0.0
+        asij(il) = 0.0
+      END IF
+    END DO
+
+    DO j = nl, minorig, -1
+
+      num2 = 0
+      DO il = 1, ncum
+        IF (i>=icb(il) .AND. i<=inb(il) .AND. j>=(icb( &
+          il)-1) .AND. j<=inb(il) .AND. lwork(il)) num2 = num2 + 1
+      END DO
+      IF (num2<=0) GO TO 175
+
+      DO il = 1, ncum
+        IF (i>=icb(il) .AND. i<=inb(il) .AND. j>=(icb( &
+            il)-1) .AND. j<=inb(il) .AND. lwork(il)) THEN
+
+          IF (sij(il,i,j)>1.0E-16 .AND. sij(il,i,j)<0.95) THEN
+            wgh = 1.0
+            IF (j>i) THEN
+              sjmax = amax1(sij(il,i,j+1), smax(il))
+              sjmax = amin1(sjmax, scrit(il))
+              smax(il) = amax1(sij(il,i,j), smax(il))
+              sjmin = amax1(sij(il,i,j-1), smax(il))
+              sjmin = amin1(sjmin, scrit(il))
+              IF (sij(il,i,j)<(smax(il)-1.0E-16)) wgh = 0.0
+              smid = amin1(sij(il,i,j), scrit(il))
+            ELSE
+              sjmax = amax1(sij(il,i,j+1), scrit(il))
+              smid = amax1(sij(il,i,j), scrit(il))
+              sjmin = 0.0
+              IF (j>1) sjmin = sij(il, i, j-1)
+              sjmin = amax1(sjmin, scrit(il))
+            END IF
+            delp = abs(sjmax-smid)
+            delm = abs(sjmin-smid)
+            asij(il) = asij(il) + wgh*(delp+delm)
+            ment(il, i, j) = ment(il, i, j)*(delp+delm)*wgh
+          END IF
+        END IF
+      END DO
+
+175 END DO
+
+    DO il = 1, ncum
+      IF (i>=icb(il) .AND. i<=inb(il) .AND. lwork(il)) THEN
+        asij(il) = amax1(1.0E-16, asij(il))
+        asij(il) = 1.0/asij(il)
+        asum(il, i) = 0.0
+        bsum(il, i) = 0.0
+        csum(il, i) = 0.0
+      END IF
+    END DO
+
+    DO j = minorig, nl
+      DO il = 1, ncum
+        IF (i>=icb(il) .AND. i<=inb(il) .AND. lwork(il) .AND. j>=(icb( &
+            il)-1) .AND. j<=inb(il)) THEN
+          ment(il, i, j) = ment(il, i, j)*asij(il)
+        END IF
+      END DO
+    END DO
+
+    DO j = minorig, nl
+      DO il = 1, ncum
+        IF (i>=icb(il) .AND. i<=inb(il) .AND. lwork(il) .AND. j>=(icb( &
+            il)-1) .AND. j<=inb(il)) THEN
+          asum(il, i) = asum(il, i) + ment(il, i, j)
+          ment(il, i, j) = ment(il, i, j)*sig(il, j)
+          bsum(il, i) = bsum(il, i) + ment(il, i, j)
+        END IF
+      END DO
+    END DO
+
+    DO il = 1, ncum
+      IF (i>=icb(il) .AND. i<=inb(il) .AND. lwork(il)) THEN
+        bsum(il, i) = amax1(bsum(il,i), 1.0E-16)
+        bsum(il, i) = 1.0/bsum(il, i)
+      END IF
+    END DO
+
+    DO j = minorig, nl
+      DO il = 1, ncum
+        IF (i>=icb(il) .AND. i<=inb(il) .AND. lwork(il) .AND. j>=(icb( &
+            il)-1) .AND. j<=inb(il)) THEN
+          ment(il, i, j) = ment(il, i, j)*asum(il, i)*bsum(il, i)
+        END IF
+      END DO
+    END DO
+
+    DO j = minorig, nl
+      DO il = 1, ncum
+        IF (i>=icb(il) .AND. i<=inb(il) .AND. lwork(il) .AND. j>=(icb( &
+            il)-1) .AND. j<=inb(il)) THEN
+          csum(il, i) = csum(il, i) + ment(il, i, j)
+        END IF
+      END DO
+    END DO
+
+    DO il = 1, ncum
+      IF (i>=icb(il) .AND. i<=inb(il) .AND. lwork(il) .AND. &
+          csum(il,i)<m(il,i)) THEN
+        nent(il, i) = 0
+        ment(il, i, i) = m(il, i)
+        qent(il, i, i) = rr(il, 1) - ep(il, i)*clw(il, i)
+        uent(il, i, i) = u(il, nk(il))
+        vent(il, i, i) = v(il, nk(il))
+        elij(il, i, i) = clw(il, i)
+        ! MAF        sij(il,i,i)=1.0
+        sij(il, i, i) = 0.0
+      END IF
+    END DO ! il
+
+    ! do j=1,ntra
+    ! do il=1,ncum
+    ! if ( i.ge.icb(il) .and. i.le.inb(il) .and. lwork(il)
+    ! :     .and. csum(il,i).lt.m(il,i) ) then
+    ! traent(il,i,i,j)=tra(il,nk(il),j)
+    ! endif
+    ! enddo
+    ! enddo
+789 END DO
+
+  ! MAF: renormalisation de MENT
+  DO jm = 1, nd
+    DO im = 1, nd
+      DO il = 1, ncum
+        zm(il, im) = zm(il, im) + (1.-sij(il,im,jm))*ment(il, im, jm)
+      END DO
+    END DO
+  END DO
+
+  DO jm = 1, nd
+    DO im = 1, nd
+      DO il = 1, ncum
+        IF (zm(il,im)/=0.) THEN
+          ment(il, im, jm) = ment(il, im, jm)*m(il, im)/zm(il, im)
+        END IF
+      END DO
+    END DO
+  END DO
+
+  DO jm = 1, nd
+    DO im = 1, nd
+      DO il = 1, ncum
+        qents(il, im, jm) = qent(il, im, jm)
+        ments(il, im, jm) = ment(il, im, jm)
+      END DO
+    END DO
+  END DO
+
+  RETURN
+END SUBROUTINE cv30_mixing
+
+
+SUBROUTINE cv30_unsat(nloc, ncum, nd, na, ntra, icb, inb, t, rr, rs, gz, u, &
+    v, tra, p, ph, th, tv, lv, cpn, ep, sigp, clw, m, ment, elij, delt, plcl, &
+    mp, rp, up, vp, trap, wt, water, evap, b & ! RomP-jyg
+    , wdtraina, wdtrainm) ! 26/08/10  RomP-jyg
+  IMPLICIT NONE
+
+
+  include "cvthermo.h"
+  include "cv30param.h"
+  include "cvflag.h"
+
+  ! inputs:
+  INTEGER ncum, nd, na, ntra, nloc
+  INTEGER icb(nloc), inb(nloc)
+  REAL delt, plcl(nloc)
+  REAL t(nloc, nd), rr(nloc, nd), rs(nloc, nd)
+  REAL u(nloc, nd), v(nloc, nd)
+  REAL tra(nloc, nd, ntra)
+  REAL p(nloc, nd), ph(nloc, nd+1)
+  REAL th(nloc, na), gz(nloc, na)
+  REAL lv(nloc, na), ep(nloc, na), sigp(nloc, na), clw(nloc, na)
+  REAL cpn(nloc, na), tv(nloc, na)
+  REAL m(nloc, na), ment(nloc, na, na), elij(nloc, na, na)
+
+  ! outputs:
+  REAL mp(nloc, na), rp(nloc, na), up(nloc, na), vp(nloc, na)
+  REAL water(nloc, na), evap(nloc, na), wt(nloc, na)
+  REAL trap(nloc, na, ntra)
+  REAL b(nloc, na)
+  ! 25/08/10 - RomP---- ajout des masses precipitantes ejectees
+  ! lascendance adiabatique et des flux melanges Pa et Pm.
+  ! Distinction des wdtrain
+  ! Pa = wdtrainA     Pm = wdtrainM
+  REAL wdtraina(nloc, na), wdtrainm(nloc, na)
+
+  ! local variables
+  INTEGER i, j, k, il, num1
+  REAL tinv, delti
+  REAL awat, afac, afac1, afac2, bfac
+  REAL pr1, pr2, sigt, b6, c6, revap, tevap, delth
+  REAL amfac, amp2, xf, tf, fac2, ur, sru, fac, d, af, bf
+  REAL ampmax
+  REAL lvcp(nloc, na)
+  REAL wdtrain(nloc)
+  LOGICAL lwork(nloc)
+
+
+  ! ------------------------------------------------------
+
+  delti = 1./delt
+  tinv = 1./3.
+
+  mp(:, :) = 0.
+
+  DO i = 1, nl
+    DO il = 1, ncum
+      mp(il, i) = 0.0
+      rp(il, i) = rr(il, i)
+      up(il, i) = u(il, i)
+      vp(il, i) = v(il, i)
+      wt(il, i) = 0.001
+      water(il, i) = 0.0
+      evap(il, i) = 0.0
+      b(il, i) = 0.0
+      lvcp(il, i) = lv(il, i)/cpn(il, i)
+    END DO
+  END DO
+
+  ! do k=1,ntra
+  ! do i=1,nd
+  ! do il=1,ncum
+  ! trap(il,i,k)=tra(il,i,k)
+  ! enddo
+  ! enddo
+  ! enddo
+  ! ! RomP >>>
+  DO i = 1, nd
+    DO il = 1, ncum
+      wdtraina(il, i) = 0.0
+      wdtrainm(il, i) = 0.0
+    END DO
+  END DO
+  ! ! RomP <<<
+
+  ! ***  check whether ep(inb)=0, if so, skip precipitating    ***
+  ! ***             downdraft calculation                      ***
+
+
+  DO il = 1, ncum
+    lwork(il) = .TRUE.
+    IF (ep(il,inb(il))<0.0001) lwork(il) = .FALSE.
+  END DO
+
+  CALL zilch(wdtrain, ncum)
+
+  DO i = nl + 1, 1, -1
+
+    num1 = 0
+    DO il = 1, ncum
+      IF (i<=inb(il) .AND. lwork(il)) num1 = num1 + 1
+    END DO
+    IF (num1<=0) GO TO 400
+
+
+    ! ***  integrate liquid water equation to find condensed water   ***
+    ! ***                and condensed water flux                    ***
+
+
+
+    ! ***                    begin downdraft loop                    ***
+
+
+
+    ! ***              calculate detrained precipitation             ***
+
+    DO il = 1, ncum
+      IF (i<=inb(il) .AND. lwork(il)) THEN
+        IF (cvflag_grav) THEN
+          wdtrain(il) = grav*ep(il, i)*m(il, i)*clw(il, i)
+          wdtraina(il, i) = wdtrain(il)/grav !   Pa  26/08/10   RomP
+        ELSE
+          wdtrain(il) = 10.0*ep(il, i)*m(il, i)*clw(il, i)
+          wdtraina(il, i) = wdtrain(il)/10. !   Pa  26/08/10   RomP
+        END IF
+      END IF
+    END DO
+
+    IF (i>1) THEN
+
+      DO j = 1, i - 1
+        DO il = 1, ncum
+          IF (i<=inb(il) .AND. lwork(il)) THEN
+            awat = elij(il, j, i) - (1.-ep(il,i))*clw(il, i)
+            awat = amax1(awat, 0.0)
+            IF (cvflag_grav) THEN
+              wdtrain(il) = wdtrain(il) + grav*awat*ment(il, j, i)
+            ELSE
+              wdtrain(il) = wdtrain(il) + 10.0*awat*ment(il, j, i)
+            END IF
+          END IF
+        END DO
+      END DO
+      DO il = 1, ncum
+        IF (cvflag_grav) THEN
+          wdtrainm(il, i) = wdtrain(il)/grav - wdtraina(il, i) !   Pm  26/08/10   RomP
+        ELSE
+          wdtrainm(il, i) = wdtrain(il)/10. - wdtraina(il, i) !   Pm  26/08/10   RomP
+        END IF
+      END DO
+
+    END IF
+
+
+    ! ***    find rain water and evaporation using provisional   ***
+    ! ***              estimates of rp(i)and rp(i-1)             ***
+
+
+    DO il = 1, ncum
+
+      IF (i<=inb(il) .AND. lwork(il)) THEN
+
+        wt(il, i) = 45.0
+
+        IF (i<inb(il)) THEN
+          rp(il, i) = rp(il, i+1) + (cpd*(t(il,i+1)-t(il, &
+            i))+gz(il,i+1)-gz(il,i))/lv(il, i)
+          rp(il, i) = 0.5*(rp(il,i)+rr(il,i))
+        END IF
+        rp(il, i) = amax1(rp(il,i), 0.0)
+        rp(il, i) = amin1(rp(il,i), rs(il,i))
+        rp(il, inb(il)) = rr(il, inb(il))
+
+        IF (i==1) THEN
+          afac = p(il, 1)*(rs(il,1)-rp(il,1))/(1.0E4+2000.0*p(il,1)*rs(il,1))
+        ELSE
+          rp(il, i-1) = rp(il, i) + (cpd*(t(il,i)-t(il, &
+            i-1))+gz(il,i)-gz(il,i-1))/lv(il, i)
+          rp(il, i-1) = 0.5*(rp(il,i-1)+rr(il,i-1))
+          rp(il, i-1) = amin1(rp(il,i-1), rs(il,i-1))
+          rp(il, i-1) = amax1(rp(il,i-1), 0.0)
+          afac1 = p(il, i)*(rs(il,i)-rp(il,i))/(1.0E4+2000.0*p(il,i)*rs(il,i) &
+            )
+          afac2 = p(il, i-1)*(rs(il,i-1)-rp(il,i-1))/ &
+            (1.0E4+2000.0*p(il,i-1)*rs(il,i-1))
+          afac = 0.5*(afac1+afac2)
+        END IF
+        IF (i==inb(il)) afac = 0.0
+        afac = amax1(afac, 0.0)
+        bfac = 1./(sigd*wt(il,i))
+
+        ! jyg1
+        ! cc        sigt=1.0
+        ! cc        if(i.ge.icb)sigt=sigp(i)
+        ! prise en compte de la variation progressive de sigt dans
+        ! les couches icb et icb-1:
+        ! pour plcl<ph(i+1), pr1=0 & pr2=1
+        ! pour plcl>ph(i),   pr1=1 & pr2=0
+        ! pour ph(i+1)<plcl<ph(i), pr1 est la proportion a cheval
+        ! sur le nuage, et pr2 est la proportion sous la base du
+        ! nuage.
+        pr1 = (plcl(il)-ph(il,i+1))/(ph(il,i)-ph(il,i+1))
+        pr1 = max(0., min(1.,pr1))
+        pr2 = (ph(il,i)-plcl(il))/(ph(il,i)-ph(il,i+1))
+        pr2 = max(0., min(1.,pr2))
+        sigt = sigp(il, i)*pr1 + pr2
+        ! jyg2
+
+        b6 = bfac*50.*sigd*(ph(il,i)-ph(il,i+1))*sigt*afac
+        c6 = water(il, i+1) + bfac*wdtrain(il) - 50.*sigd*bfac*(ph(il,i)-ph( &
+          il,i+1))*evap(il, i+1)
+        IF (c6>0.0) THEN
+          revap = 0.5*(-b6+sqrt(b6*b6+4.*c6))
+          evap(il, i) = sigt*afac*revap
+          water(il, i) = revap*revap
+        ELSE
+          evap(il, i) = -evap(il, i+1) + 0.02*(wdtrain(il)+sigd*wt(il,i)* &
+            water(il,i+1))/(sigd*(ph(il,i)-ph(il,i+1)))
+        END IF
+
+        ! ***  calculate precipitating downdraft mass flux under     ***
+        ! ***              hydrostatic approximation                 ***
+
+        IF (i/=1) THEN
+
+          tevap = amax1(0.0, evap(il,i))
+          delth = amax1(0.001, (th(il,i)-th(il,i-1)))
+          IF (cvflag_grav) THEN
+            mp(il, i) = 100.*ginv*lvcp(il, i)*sigd*tevap*(p(il,i-1)-p(il,i))/ &
+              delth
+          ELSE
+            mp(il, i) = 10.*lvcp(il, i)*sigd*tevap*(p(il,i-1)-p(il,i))/delth
+          END IF
+
+          ! ***           if hydrostatic assumption fails,             ***
+          ! ***   solve cubic difference equation for downdraft theta  ***
+          ! ***  and mass flux from two simultaneous differential eqns ***
+
+          amfac = sigd*sigd*70.0*ph(il, i)*(p(il,i-1)-p(il,i))* &
+            (th(il,i)-th(il,i-1))/(tv(il,i)*th(il,i))
+          amp2 = abs(mp(il,i+1)*mp(il,i+1)-mp(il,i)*mp(il,i))
+          IF (amp2>(0.1*amfac)) THEN
+            xf = 100.0*sigd*sigd*sigd*(ph(il,i)-ph(il,i+1))
+            tf = b(il, i) - 5.0*(th(il,i)-th(il,i-1))*t(il, i)/(lvcp(il,i)* &
+              sigd*th(il,i))
+            af = xf*tf + mp(il, i+1)*mp(il, i+1)*tinv
+            bf = 2.*(tinv*mp(il,i+1))**3 + tinv*mp(il, i+1)*xf*tf + &
+              50.*(p(il,i-1)-p(il,i))*xf*tevap
+            fac2 = 1.0
+            IF (bf<0.0) fac2 = -1.0
+            bf = abs(bf)
+            ur = 0.25*bf*bf - af*af*af*tinv*tinv*tinv
+            IF (ur>=0.0) THEN
+              sru = sqrt(ur)
+              fac = 1.0
+              IF ((0.5*bf-sru)<0.0) fac = -1.0
+              mp(il, i) = mp(il, i+1)*tinv + (0.5*bf+sru)**tinv + &
+                fac*(abs(0.5*bf-sru))**tinv
+            ELSE
+              d = atan(2.*sqrt(-ur)/(bf+1.0E-28))
+              IF (fac2<0.0) d = 3.14159 - d
+              mp(il, i) = mp(il, i+1)*tinv + 2.*sqrt(af*tinv)*cos(d*tinv)
+            END IF
+            mp(il, i) = amax1(0.0, mp(il,i))
+
+            IF (cvflag_grav) THEN
+              ! jyg : il y a vraisemblablement une erreur dans la ligne 2
+              ! suivante:
+              ! il faut diviser par (mp(il,i)*sigd*grav) et non par
+              ! (mp(il,i)+sigd*0.1).
+              ! Et il faut bien revoir les facteurs 100.
+              b(il, i-1) = b(il, i) + 100.0*(p(il,i-1)-p(il,i))*tevap/(mp(il, &
+                i)+sigd*0.1) - 10.0*(th(il,i)-th(il,i-1))*t(il, i)/(lvcp(il,i &
+                )*sigd*th(il,i))
+            ELSE
+              b(il, i-1) = b(il, i) + 100.0*(p(il,i-1)-p(il,i))*tevap/(mp(il, &
+                i)+sigd*0.1) - 10.0*(th(il,i)-th(il,i-1))*t(il, i)/(lvcp(il,i &
+                )*sigd*th(il,i))
+            END IF
+            b(il, i-1) = amax1(b(il,i-1), 0.0)
+          END IF
+
+          ! ***         limit magnitude of mp(i) to meet cfl condition
+          ! ***
+
+          ampmax = 2.0*(ph(il,i)-ph(il,i+1))*delti
+          amp2 = 2.0*(ph(il,i-1)-ph(il,i))*delti
+          ampmax = amin1(ampmax, amp2)
+          mp(il, i) = amin1(mp(il,i), ampmax)
+
+          ! ***      force mp to decrease linearly to zero
+          ! ***
+          ! ***       between cloud base and the surface
+          ! ***
+
+          IF (p(il,i)>p(il,icb(il))) THEN
+            mp(il, i) = mp(il, icb(il))*(p(il,1)-p(il,i))/ &
+              (p(il,1)-p(il,icb(il)))
+          END IF
+
+        END IF ! i.eq.1
+
+        ! ***       find mixing ratio of precipitating downdraft     ***
+
+
+        IF (i/=inb(il)) THEN
+
+          rp(il, i) = rr(il, i)
+
+          IF (mp(il,i)>mp(il,i+1)) THEN
+
+            IF (cvflag_grav) THEN
+              rp(il, i) = rp(il, i+1)*mp(il, i+1) + &
+                rr(il, i)*(mp(il,i)-mp(il,i+1)) + 100.*ginv*0.5*sigd*(ph(il,i &
+                )-ph(il,i+1))*(evap(il,i+1)+evap(il,i))
+            ELSE
+              rp(il, i) = rp(il, i+1)*mp(il, i+1) + &
+                rr(il, i)*(mp(il,i)-mp(il,i+1)) + 5.*sigd*(ph(il,i)-ph(il,i+1 &
+                ))*(evap(il,i+1)+evap(il,i))
+            END IF
+            rp(il, i) = rp(il, i)/mp(il, i)
+            up(il, i) = up(il, i+1)*mp(il, i+1) + u(il, i)*(mp(il,i)-mp(il,i+ &
+              1))
+            up(il, i) = up(il, i)/mp(il, i)
+            vp(il, i) = vp(il, i+1)*mp(il, i+1) + v(il, i)*(mp(il,i)-mp(il,i+ &
+              1))
+            vp(il, i) = vp(il, i)/mp(il, i)
+
+            ! do j=1,ntra
+            ! trap(il,i,j)=trap(il,i+1,j)*mp(il,i+1)
+            ! testmaf     :            +trap(il,i,j)*(mp(il,i)-mp(il,i+1))
+            ! :            +tra(il,i,j)*(mp(il,i)-mp(il,i+1))
+            ! trap(il,i,j)=trap(il,i,j)/mp(il,i)
+            ! end do
+
+          ELSE
+
+            IF (mp(il,i+1)>1.0E-16) THEN
+              IF (cvflag_grav) THEN
+                rp(il, i) = rp(il, i+1) + 100.*ginv*0.5*sigd*(ph(il,i)-ph(il, &
+                  i+1))*(evap(il,i+1)+evap(il,i))/mp(il, i+1)
+              ELSE
+                rp(il, i) = rp(il, i+1) + 5.*sigd*(ph(il,i)-ph(il,i+1))*(evap &
+                  (il,i+1)+evap(il,i))/mp(il, i+1)
+              END IF
+              up(il, i) = up(il, i+1)
+              vp(il, i) = vp(il, i+1)
+
+              ! do j=1,ntra
+              ! trap(il,i,j)=trap(il,i+1,j)
+              ! end do
+
+            END IF
+          END IF
+          rp(il, i) = amin1(rp(il,i), rs(il,i))
+          rp(il, i) = amax1(rp(il,i), 0.0)
+
+        END IF
+      END IF
+    END DO
+
+400 END DO
+
+  RETURN
+END SUBROUTINE cv30_unsat
+
+SUBROUTINE cv30_yield(nloc, ncum, nd, na, ntra, icb, inb, delt, t, rr, u, v, &
+    tra, gz, p, ph, h, hp, lv, cpn, th, ep, clw, m, tp, mp, rp, up, vp, trap, &
+    wt, water, evap, b, ment, qent, uent, vent, nent, elij, traent, sig, tv, &
+    tvp, iflag, precip, vprecip, ft, fr, fu, fv, ftra, upwd, dnwd, dnwd0, ma, &
+    mike, tls, tps, qcondc, wd)
+  IMPLICIT NONE
+
+  include "cvthermo.h"
+  include "cv30param.h"
+  include "cvflag.h"
+  include "conema3.h"
+
+  ! inputs:
+  INTEGER ncum, nd, na, ntra, nloc
+  INTEGER icb(nloc), inb(nloc)
+  REAL delt
+  REAL t(nloc, nd), rr(nloc, nd), u(nloc, nd), v(nloc, nd)
+  REAL tra(nloc, nd, ntra), sig(nloc, nd)
+  REAL gz(nloc, na), ph(nloc, nd+1), h(nloc, na), hp(nloc, na)
+  REAL th(nloc, na), p(nloc, nd), tp(nloc, na)
+  REAL lv(nloc, na), cpn(nloc, na), ep(nloc, na), clw(nloc, na)
+  REAL m(nloc, na), mp(nloc, na), rp(nloc, na), up(nloc, na)
+  REAL vp(nloc, na), wt(nloc, nd), trap(nloc, nd, ntra)
+  REAL water(nloc, na), evap(nloc, na), b(nloc, na)
+  REAL ment(nloc, na, na), qent(nloc, na, na), uent(nloc, na, na)
+  ! ym      real vent(nloc,na,na), nent(nloc,na), elij(nloc,na,na)
+  REAL vent(nloc, na, na), elij(nloc, na, na)
+  INTEGER nent(nloc, na)
+  REAL traent(nloc, na, na, ntra)
+  REAL tv(nloc, nd), tvp(nloc, nd)
+
+  ! input/output:
+  INTEGER iflag(nloc)
+
+  ! outputs:
+  REAL precip(nloc)
+  REAL vprecip(nloc, nd+1)
+  REAL ft(nloc, nd), fr(nloc, nd), fu(nloc, nd), fv(nloc, nd)
+  REAL ftra(nloc, nd, ntra)
+  REAL upwd(nloc, nd), dnwd(nloc, nd), ma(nloc, nd)
+  REAL dnwd0(nloc, nd), mike(nloc, nd)
+  REAL tls(nloc, nd), tps(nloc, nd)
+  REAL qcondc(nloc, nd) ! cld
+  REAL wd(nloc) ! gust
+
+  ! local variables:
+  INTEGER i, k, il, n, j, num1
+  REAL rat, awat, delti
+  REAL ax, bx, cx, dx, ex
+  REAL cpinv, rdcp, dpinv
+  REAL lvcp(nloc, na), mke(nloc, na)
+  REAL am(nloc), work(nloc), ad(nloc), amp1(nloc)
+  ! !!      real up1(nloc), dn1(nloc)
+  REAL up1(nloc, nd, nd), dn1(nloc, nd, nd)
+  REAL asum(nloc), bsum(nloc), csum(nloc), dsum(nloc)
+  REAL qcond(nloc, nd), nqcond(nloc, nd), wa(nloc, nd) ! cld
+  REAL siga(nloc, nd), sax(nloc, nd), mac(nloc, nd) ! cld
+
+
+  ! -------------------------------------------------------------
+
+  ! initialization:
+
+  delti = 1.0/delt
+
+  DO il = 1, ncum
+    precip(il) = 0.0
+    wd(il) = 0.0 ! gust
+    vprecip(il, nd+1) = 0.
+  END DO
+
+  DO i = 1, nd
+    DO il = 1, ncum
+      vprecip(il, i) = 0.0
+      ft(il, i) = 0.0
+      fr(il, i) = 0.0
+      fu(il, i) = 0.0
+      fv(il, i) = 0.0
+      qcondc(il, i) = 0.0 ! cld
+      qcond(il, i) = 0.0 ! cld
+      nqcond(il, i) = 0.0 ! cld
+    END DO
+  END DO
+
+  ! do j=1,ntra
+  ! do i=1,nd
+  ! do il=1,ncum
+  ! ftra(il,i,j)=0.0
+  ! enddo
+  ! enddo
+  ! enddo
+
+  DO i = 1, nl
+    DO il = 1, ncum
+      lvcp(il, i) = lv(il, i)/cpn(il, i)
+    END DO
+  END DO
+
+
+
+  ! ***  calculate surface precipitation in mm/day     ***
+
+  DO il = 1, ncum
+    IF (ep(il,inb(il))>=0.0001) THEN
+      IF (cvflag_grav) THEN
+        precip(il) = wt(il, 1)*sigd*water(il, 1)*86400.*1000./(rowl*grav)
+      ELSE
+        precip(il) = wt(il, 1)*sigd*water(il, 1)*8640.
+      END IF
+    END IF
+  END DO
+
+  ! ***  CALCULATE VERTICAL PROFILE OF  PRECIPITATIONs IN kg/m2/s  ===
+
+  ! MAF rajout pour lessivage
+  DO k = 1, nl
+    DO il = 1, ncum
+      IF (k<=inb(il)) THEN
+        IF (cvflag_grav) THEN
+          vprecip(il, k) = wt(il, k)*sigd*water(il, k)/grav
+        ELSE
+          vprecip(il, k) = wt(il, k)*sigd*water(il, k)/10.
+        END IF
+      END IF
+    END DO
+  END DO
+
+
+  ! ***  Calculate downdraft velocity scale    ***
+  ! ***  NE PAS UTILISER POUR L'INSTANT ***
+
+  ! !      do il=1,ncum
+  ! !        wd(il)=betad*abs(mp(il,icb(il)))*0.01*rrd*t(il,icb(il))
+  ! !     :                                  /(sigd*p(il,icb(il)))
+  ! !      enddo
+
+
+  ! ***  calculate tendencies of lowest level potential temperature  ***
+  ! ***                      and mixing ratio                        ***
+
+  DO il = 1, ncum
+    work(il) = 1.0/(ph(il,1)-ph(il,2))
+    am(il) = 0.0
+  END DO
+
+  DO k = 2, nl
+    DO il = 1, ncum
+      IF (k<=inb(il)) THEN
+        am(il) = am(il) + m(il, k)
+      END IF
+    END DO
+  END DO
+
+  DO il = 1, ncum
+
+    ! convect3      if((0.1*dpinv*am).ge.delti)iflag(il)=4
+    IF (cvflag_grav) THEN
+      IF ((0.01*grav*work(il)*am(il))>=delti) iflag(il) = 1 !consist vect
+      ft(il, 1) = 0.01*grav*work(il)*am(il)*(t(il,2)-t(il,1)+(gz(il,2)-gz(il, &
+        1))/cpn(il,1))
+    ELSE
+      IF ((0.1*work(il)*am(il))>=delti) iflag(il) = 1 !consistency vect
+      ft(il, 1) = 0.1*work(il)*am(il)*(t(il,2)-t(il,1)+(gz(il,2)-gz(il, &
+        1))/cpn(il,1))
+    END IF
+
+    ft(il, 1) = ft(il, 1) - 0.5*lvcp(il, 1)*sigd*(evap(il,1)+evap(il,2))
+
+    IF (cvflag_grav) THEN
+      ft(il, 1) = ft(il, 1) - 0.009*grav*sigd*mp(il, 2)*t(il, 1)*b(il, 1)* &
+        work(il)
+    ELSE
+      ft(il, 1) = ft(il, 1) - 0.09*sigd*mp(il, 2)*t(il, 1)*b(il, 1)*work(il)
+    END IF
+
+    ft(il, 1) = ft(il, 1) + 0.01*sigd*wt(il, 1)*(cl-cpd)*water(il, 2)*(t(il,2 &
+      )-t(il,1))*work(il)/cpn(il, 1)
+
+    IF (cvflag_grav) THEN
+      ! jyg1  Correction pour mieux conserver l'eau (conformite avec
+      ! CONVECT4.3)
+      ! (sb: pour l'instant, on ne fait que le chgt concernant grav, pas
+      ! evap)
+      fr(il, 1) = 0.01*grav*mp(il, 2)*(rp(il,2)-rr(il,1))*work(il) + &
+        sigd*0.5*(evap(il,1)+evap(il,2))
+      ! +tard     :          +sigd*evap(il,1)
+
+      fr(il, 1) = fr(il, 1) + 0.01*grav*am(il)*(rr(il,2)-rr(il,1))*work(il)
+
+      fu(il, 1) = fu(il, 1) + 0.01*grav*work(il)*(mp(il,2)*(up(il,2)-u(il, &
+        1))+am(il)*(u(il,2)-u(il,1)))
+      fv(il, 1) = fv(il, 1) + 0.01*grav*work(il)*(mp(il,2)*(vp(il,2)-v(il, &
+        1))+am(il)*(v(il,2)-v(il,1)))
+    ELSE ! cvflag_grav
+      fr(il, 1) = 0.1*mp(il, 2)*(rp(il,2)-rr(il,1))*work(il) + &
+        sigd*0.5*(evap(il,1)+evap(il,2))
+      fr(il, 1) = fr(il, 1) + 0.1*am(il)*(rr(il,2)-rr(il,1))*work(il)
+      fu(il, 1) = fu(il, 1) + 0.1*work(il)*(mp(il,2)*(up(il,2)-u(il, &
+        1))+am(il)*(u(il,2)-u(il,1)))
+      fv(il, 1) = fv(il, 1) + 0.1*work(il)*(mp(il,2)*(vp(il,2)-v(il, &
+        1))+am(il)*(v(il,2)-v(il,1)))
+    END IF ! cvflag_grav
+
+  END DO ! il
+
+  ! do j=1,ntra
+  ! do il=1,ncum
+  ! if (cvflag_grav) then
+  ! ftra(il,1,j)=ftra(il,1,j)+0.01*grav*work(il)
+  ! :                     *(mp(il,2)*(trap(il,2,j)-tra(il,1,j))
+  ! :             +am(il)*(tra(il,2,j)-tra(il,1,j)))
+  ! else
+  ! ftra(il,1,j)=ftra(il,1,j)+0.1*work(il)
+  ! :                     *(mp(il,2)*(trap(il,2,j)-tra(il,1,j))
+  ! :             +am(il)*(tra(il,2,j)-tra(il,1,j)))
+  ! endif
+  ! enddo
+  ! enddo
+
+  DO j = 2, nl
+    DO il = 1, ncum
+      IF (j<=inb(il)) THEN
+        IF (cvflag_grav) THEN
+          fr(il, 1) = fr(il, 1) + 0.01*grav*work(il)*ment(il, j, 1)*(qent(il, &
+            j,1)-rr(il,1))
+          fu(il, 1) = fu(il, 1) + 0.01*grav*work(il)*ment(il, j, 1)*(uent(il, &
+            j,1)-u(il,1))
+          fv(il, 1) = fv(il, 1) + 0.01*grav*work(il)*ment(il, j, 1)*(vent(il, &
+            j,1)-v(il,1))
+        ELSE ! cvflag_grav
+          fr(il, 1) = fr(il, 1) + 0.1*work(il)*ment(il, j, 1)*(qent(il,j,1)- &
+            rr(il,1))
+          fu(il, 1) = fu(il, 1) + 0.1*work(il)*ment(il, j, 1)*(uent(il,j,1)-u &
+            (il,1))
+          fv(il, 1) = fv(il, 1) + 0.1*work(il)*ment(il, j, 1)*(vent(il,j,1)-v &
+            (il,1))
+        END IF ! cvflag_grav
+      END IF ! j
+    END DO
+  END DO
+
+  ! do k=1,ntra
+  ! do j=2,nl
+  ! do il=1,ncum
+  ! if (j.le.inb(il)) then
+
+  ! if (cvflag_grav) then
+  ! ftra(il,1,k)=ftra(il,1,k)+0.01*grav*work(il)*ment(il,j,1)
+  ! :                *(traent(il,j,1,k)-tra(il,1,k))
+  ! else
+  ! ftra(il,1,k)=ftra(il,1,k)+0.1*work(il)*ment(il,j,1)
+  ! :                *(traent(il,j,1,k)-tra(il,1,k))
+  ! endif
+
+  ! endif
+  ! enddo
+  ! enddo
+  ! enddo
+
+
+  ! ***  calculate tendencies of potential temperature and mixing ratio  ***
+  ! ***               at levels above the lowest level                   ***
+
+  ! ***  first find the net saturated updraft and downdraft mass fluxes  ***
+  ! ***                      through each level                          ***
+
+
+  DO i = 2, nl + 1 ! newvecto: mettre nl au lieu nl+1?
+
+    num1 = 0
+    DO il = 1, ncum
+      IF (i<=inb(il)) num1 = num1 + 1
+    END DO
+    IF (num1<=0) GO TO 500
+
+    CALL zilch(amp1, ncum)
+    CALL zilch(ad, ncum)
+
+    DO k = i + 1, nl + 1
+      DO il = 1, ncum
+        IF (i<=inb(il) .AND. k<=(inb(il)+1)) THEN
+          amp1(il) = amp1(il) + m(il, k)
+        END IF
+      END DO
+    END DO
+
+    DO k = 1, i
+      DO j = i + 1, nl + 1
+        DO il = 1, ncum
+          IF (i<=inb(il) .AND. j<=(inb(il)+1)) THEN
+            amp1(il) = amp1(il) + ment(il, k, j)
+          END IF
+        END DO
+      END DO
+    END DO
+
+    DO k = 1, i - 1
+      DO j = i, nl + 1 ! newvecto: nl au lieu nl+1?
+        DO il = 1, ncum
+          IF (i<=inb(il) .AND. j<=inb(il)) THEN
+            ad(il) = ad(il) + ment(il, j, k)
+          END IF
+        END DO
+      END DO
+    END DO
+
+    DO il = 1, ncum
+      IF (i<=inb(il)) THEN
+        dpinv = 1.0/(ph(il,i)-ph(il,i+1))
+        cpinv = 1.0/cpn(il, i)
+
+        ! convect3      if((0.1*dpinv*amp1).ge.delti)iflag(il)=4
+        IF (cvflag_grav) THEN
+          IF ((0.01*grav*dpinv*amp1(il))>=delti) iflag(il) = 1 ! vecto
+        ELSE
+          IF ((0.1*dpinv*amp1(il))>=delti) iflag(il) = 1 ! vecto
+        END IF
+
+        IF (cvflag_grav) THEN
+          ft(il, i) = 0.01*grav*dpinv*(amp1(il)*(t(il,i+1)-t(il, &
+            i)+(gz(il,i+1)-gz(il,i))*cpinv)-ad(il)*(t(il,i)-t(il, &
+            i-1)+(gz(il,i)-gz(il,i-1))*cpinv)) - 0.5*sigd*lvcp(il, i)*(evap( &
+            il,i)+evap(il,i+1))
+          rat = cpn(il, i-1)*cpinv
+          ft(il, i) = ft(il, i) - 0.009*grav*sigd*(mp(il,i+1)*t(il,i)*b(il,i) &
+            -mp(il,i)*t(il,i-1)*rat*b(il,i-1))*dpinv
+          ft(il, i) = ft(il, i) + 0.01*grav*dpinv*ment(il, i, i)*(hp(il,i)-h( &
+            il,i)+t(il,i)*(cpv-cpd)*(rr(il,i)-qent(il,i,i)))*cpinv
+        ELSE ! cvflag_grav
+          ft(il, i) = 0.1*dpinv*(amp1(il)*(t(il,i+1)-t(il, &
+            i)+(gz(il,i+1)-gz(il,i))*cpinv)-ad(il)*(t(il,i)-t(il, &
+            i-1)+(gz(il,i)-gz(il,i-1))*cpinv)) - 0.5*sigd*lvcp(il, i)*(evap( &
+            il,i)+evap(il,i+1))
+          rat = cpn(il, i-1)*cpinv
+          ft(il, i) = ft(il, i) - 0.09*sigd*(mp(il,i+1)*t(il,i)*b(il,i)-mp(il &
+            ,i)*t(il,i-1)*rat*b(il,i-1))*dpinv
+          ft(il, i) = ft(il, i) + 0.1*dpinv*ment(il, i, i)*(hp(il,i)-h(il,i)+ &
+            t(il,i)*(cpv-cpd)*(rr(il,i)-qent(il,i,i)))*cpinv
+        END IF ! cvflag_grav
+
+
+        ft(il, i) = ft(il, i) + 0.01*sigd*wt(il, i)*(cl-cpd)*water(il, i+1)*( &
+          t(il,i+1)-t(il,i))*dpinv*cpinv
+
+        IF (cvflag_grav) THEN
+          fr(il, i) = 0.01*grav*dpinv*(amp1(il)*(rr(il,i+1)-rr(il, &
+            i))-ad(il)*(rr(il,i)-rr(il,i-1)))
+          fu(il, i) = fu(il, i) + 0.01*grav*dpinv*(amp1(il)*(u(il,i+1)-u(il, &
+            i))-ad(il)*(u(il,i)-u(il,i-1)))
+          fv(il, i) = fv(il, i) + 0.01*grav*dpinv*(amp1(il)*(v(il,i+1)-v(il, &
+            i))-ad(il)*(v(il,i)-v(il,i-1)))
+        ELSE ! cvflag_grav
+          fr(il, i) = 0.1*dpinv*(amp1(il)*(rr(il,i+1)-rr(il, &
+            i))-ad(il)*(rr(il,i)-rr(il,i-1)))
+          fu(il, i) = fu(il, i) + 0.1*dpinv*(amp1(il)*(u(il,i+1)-u(il, &
+            i))-ad(il)*(u(il,i)-u(il,i-1)))
+          fv(il, i) = fv(il, i) + 0.1*dpinv*(amp1(il)*(v(il,i+1)-v(il, &
+            i))-ad(il)*(v(il,i)-v(il,i-1)))
+        END IF ! cvflag_grav
+
+      END IF ! i
+    END DO
+
+    ! do k=1,ntra
+    ! do il=1,ncum
+    ! if (i.le.inb(il)) then
+    ! dpinv=1.0/(ph(il,i)-ph(il,i+1))
+    ! cpinv=1.0/cpn(il,i)
+    ! if (cvflag_grav) then
+    ! ftra(il,i,k)=ftra(il,i,k)+0.01*grav*dpinv
+    ! :         *(amp1(il)*(tra(il,i+1,k)-tra(il,i,k))
+    ! :           -ad(il)*(tra(il,i,k)-tra(il,i-1,k)))
+    ! else
+    ! ftra(il,i,k)=ftra(il,i,k)+0.1*dpinv
+    ! :         *(amp1(il)*(tra(il,i+1,k)-tra(il,i,k))
+    ! :           -ad(il)*(tra(il,i,k)-tra(il,i-1,k)))
+    ! endif
+    ! endif
+    ! enddo
+    ! enddo
+
+    DO k = 1, i - 1
+      DO il = 1, ncum
+        IF (i<=inb(il)) THEN
+          dpinv = 1.0/(ph(il,i)-ph(il,i+1))
+          cpinv = 1.0/cpn(il, i)
+
+          awat = elij(il, k, i) - (1.-ep(il,i))*clw(il, i)
+          awat = amax1(awat, 0.0)
+
+          IF (cvflag_grav) THEN
+            fr(il, i) = fr(il, i) + 0.01*grav*dpinv*ment(il, k, i)*(qent(il,k &
+              ,i)-awat-rr(il,i))
+            fu(il, i) = fu(il, i) + 0.01*grav*dpinv*ment(il, k, i)*(uent(il,k &
+              ,i)-u(il,i))
+            fv(il, i) = fv(il, i) + 0.01*grav*dpinv*ment(il, k, i)*(vent(il,k &
+              ,i)-v(il,i))
+          ELSE ! cvflag_grav
+            fr(il, i) = fr(il, i) + 0.1*dpinv*ment(il, k, i)*(qent(il,k,i)- &
+              awat-rr(il,i))
+            fu(il, i) = fu(il, i) + 0.01*grav*dpinv*ment(il, k, i)*(uent(il,k &
+              ,i)-u(il,i))
+            fv(il, i) = fv(il, i) + 0.1*dpinv*ment(il, k, i)*(vent(il,k,i)-v( &
+              il,i))
+          END IF ! cvflag_grav
+
+          ! (saturated updrafts resulting from mixing)        ! cld
+          qcond(il, i) = qcond(il, i) + (elij(il,k,i)-awat) ! cld
+          nqcond(il, i) = nqcond(il, i) + 1. ! cld
+        END IF ! i
+      END DO
+    END DO
+
+    ! do j=1,ntra
+    ! do k=1,i-1
+    ! do il=1,ncum
+    ! if (i.le.inb(il)) then
+    ! dpinv=1.0/(ph(il,i)-ph(il,i+1))
+    ! cpinv=1.0/cpn(il,i)
+    ! if (cvflag_grav) then
+    ! ftra(il,i,j)=ftra(il,i,j)+0.01*grav*dpinv*ment(il,k,i)
+    ! :        *(traent(il,k,i,j)-tra(il,i,j))
+    ! else
+    ! ftra(il,i,j)=ftra(il,i,j)+0.1*dpinv*ment(il,k,i)
+    ! :        *(traent(il,k,i,j)-tra(il,i,j))
+    ! endif
+    ! endif
+    ! enddo
+    ! enddo
+    ! enddo
+
+    DO k = i, nl + 1
+      DO il = 1, ncum
+        IF (i<=inb(il) .AND. k<=inb(il)) THEN
+          dpinv = 1.0/(ph(il,i)-ph(il,i+1))
+          cpinv = 1.0/cpn(il, i)
+
+          IF (cvflag_grav) THEN
+            fr(il, i) = fr(il, i) + 0.01*grav*dpinv*ment(il, k, i)*(qent(il,k &
+              ,i)-rr(il,i))
+            fu(il, i) = fu(il, i) + 0.01*grav*dpinv*ment(il, k, i)*(uent(il,k &
+              ,i)-u(il,i))
+            fv(il, i) = fv(il, i) + 0.01*grav*dpinv*ment(il, k, i)*(vent(il,k &
+              ,i)-v(il,i))
+          ELSE ! cvflag_grav
+            fr(il, i) = fr(il, i) + 0.1*dpinv*ment(il, k, i)*(qent(il,k,i)-rr &
+              (il,i))
+            fu(il, i) = fu(il, i) + 0.1*dpinv*ment(il, k, i)*(uent(il,k,i)-u( &
+              il,i))
+            fv(il, i) = fv(il, i) + 0.1*dpinv*ment(il, k, i)*(vent(il,k,i)-v( &
+              il,i))
+          END IF ! cvflag_grav
+        END IF ! i and k
+      END DO
+    END DO
+
+    ! do j=1,ntra
+    ! do k=i,nl+1
+    ! do il=1,ncum
+    ! if (i.le.inb(il) .and. k.le.inb(il)) then
+    ! dpinv=1.0/(ph(il,i)-ph(il,i+1))
+    ! cpinv=1.0/cpn(il,i)
+    ! if (cvflag_grav) then
+    ! ftra(il,i,j)=ftra(il,i,j)+0.01*grav*dpinv*ment(il,k,i)
+    ! :         *(traent(il,k,i,j)-tra(il,i,j))
+    ! else
+    ! ftra(il,i,j)=ftra(il,i,j)+0.1*dpinv*ment(il,k,i)
+    ! :             *(traent(il,k,i,j)-tra(il,i,j))
+    ! endif
+    ! endif ! i and k
+    ! enddo
+    ! enddo
+    ! enddo
+
+    DO il = 1, ncum
+      IF (i<=inb(il)) THEN
+        dpinv = 1.0/(ph(il,i)-ph(il,i+1))
+        cpinv = 1.0/cpn(il, i)
+
+        IF (cvflag_grav) THEN
+          ! sb: on ne fait pas encore la correction permettant de mieux
+          ! conserver l'eau:
+          fr(il, i) = fr(il, i) + 0.5*sigd*(evap(il,i)+evap(il,i+1)) + &
+            0.01*grav*(mp(il,i+1)*(rp(il,i+1)-rr(il,i))-mp(il,i)*(rp(il, &
+            i)-rr(il,i-1)))*dpinv
+
+          fu(il, i) = fu(il, i) + 0.01*grav*(mp(il,i+1)*(up(il,i+1)-u(il, &
+            i))-mp(il,i)*(up(il,i)-u(il,i-1)))*dpinv
+          fv(il, i) = fv(il, i) + 0.01*grav*(mp(il,i+1)*(vp(il,i+1)-v(il, &
+            i))-mp(il,i)*(vp(il,i)-v(il,i-1)))*dpinv
+        ELSE ! cvflag_grav
+          fr(il, i) = fr(il, i) + 0.5*sigd*(evap(il,i)+evap(il,i+1)) + &
+            0.1*(mp(il,i+1)*(rp(il,i+1)-rr(il,i))-mp(il,i)*(rp(il,i)-rr(il, &
+            i-1)))*dpinv
+          fu(il, i) = fu(il, i) + 0.1*(mp(il,i+1)*(up(il,i+1)-u(il, &
+            i))-mp(il,i)*(up(il,i)-u(il,i-1)))*dpinv
+          fv(il, i) = fv(il, i) + 0.1*(mp(il,i+1)*(vp(il,i+1)-v(il, &
+            i))-mp(il,i)*(vp(il,i)-v(il,i-1)))*dpinv
+        END IF ! cvflag_grav
+
+      END IF ! i
+    END DO
+
+    ! sb: interface with the cloud parameterization:          ! cld
+
+    DO k = i + 1, nl
+      DO il = 1, ncum
+        IF (k<=inb(il) .AND. i<=inb(il)) THEN ! cld
+          ! (saturated downdrafts resulting from mixing)            ! cld
+          qcond(il, i) = qcond(il, i) + elij(il, k, i) ! cld
+          nqcond(il, i) = nqcond(il, i) + 1. ! cld
+        END IF ! cld
+      END DO ! cld
+    END DO ! cld
+
+    ! (particular case: no detraining level is found)         ! cld
+    DO il = 1, ncum ! cld
+      IF (i<=inb(il) .AND. nent(il,i)==0) THEN ! cld
+        qcond(il, i) = qcond(il, i) + (1.-ep(il,i))*clw(il, i) ! cld
+        nqcond(il, i) = nqcond(il, i) + 1. ! cld
+      END IF ! cld
+    END DO ! cld
+
+    DO il = 1, ncum ! cld
+      IF (i<=inb(il) .AND. nqcond(il,i)/=0.) THEN ! cld
+        qcond(il, i) = qcond(il, i)/nqcond(il, i) ! cld
+      END IF ! cld
+    END DO
+
+    ! do j=1,ntra
+    ! do il=1,ncum
+    ! if (i.le.inb(il)) then
+    ! dpinv=1.0/(ph(il,i)-ph(il,i+1))
+    ! cpinv=1.0/cpn(il,i)
+
+    ! if (cvflag_grav) then
+    ! ftra(il,i,j)=ftra(il,i,j)+0.01*grav*dpinv
+    ! :     *(mp(il,i+1)*(trap(il,i+1,j)-tra(il,i,j))
+    ! :     -mp(il,i)*(trap(il,i,j)-tra(il,i-1,j)))
+    ! else
+    ! ftra(il,i,j)=ftra(il,i,j)+0.1*dpinv
+    ! :     *(mp(il,i+1)*(trap(il,i+1,j)-tra(il,i,j))
+    ! :     -mp(il,i)*(trap(il,i,j)-tra(il,i-1,j)))
+    ! endif
+    ! endif ! i
+    ! enddo
+    ! enddo
+
+500 END DO
+
+
+  ! ***   move the detrainment at level inb down to level inb-1   ***
+  ! ***        in such a way as to preserve the vertically        ***
+  ! ***          integrated enthalpy and water tendencies         ***
+
+  DO il = 1, ncum
+
+    ax = 0.1*ment(il, inb(il), inb(il))*(hp(il,inb(il))-h(il,inb(il))+t(il, &
+      inb(il))*(cpv-cpd)*(rr(il,inb(il))-qent(il,inb(il), &
+      inb(il))))/(cpn(il,inb(il))*(ph(il,inb(il))-ph(il,inb(il)+1)))
+    ft(il, inb(il)) = ft(il, inb(il)) - ax
+    ft(il, inb(il)-1) = ft(il, inb(il)-1) + ax*cpn(il, inb(il))*(ph(il,inb(il &
+      ))-ph(il,inb(il)+1))/(cpn(il,inb(il)-1)*(ph(il,inb(il)-1)-ph(il, &
+      inb(il))))
+
+    bx = 0.1*ment(il, inb(il), inb(il))*(qent(il,inb(il),inb(il))-rr(il,inb( &
+      il)))/(ph(il,inb(il))-ph(il,inb(il)+1))
+    fr(il, inb(il)) = fr(il, inb(il)) - bx
+    fr(il, inb(il)-1) = fr(il, inb(il)-1) + bx*(ph(il,inb(il))-ph(il,inb(il)+ &
+      1))/(ph(il,inb(il)-1)-ph(il,inb(il)))
+
+    cx = 0.1*ment(il, inb(il), inb(il))*(uent(il,inb(il),inb(il))-u(il,inb(il &
+      )))/(ph(il,inb(il))-ph(il,inb(il)+1))
+    fu(il, inb(il)) = fu(il, inb(il)) - cx
+    fu(il, inb(il)-1) = fu(il, inb(il)-1) + cx*(ph(il,inb(il))-ph(il,inb(il)+ &
+      1))/(ph(il,inb(il)-1)-ph(il,inb(il)))
+
+    dx = 0.1*ment(il, inb(il), inb(il))*(vent(il,inb(il),inb(il))-v(il,inb(il &
+      )))/(ph(il,inb(il))-ph(il,inb(il)+1))
+    fv(il, inb(il)) = fv(il, inb(il)) - dx
+    fv(il, inb(il)-1) = fv(il, inb(il)-1) + dx*(ph(il,inb(il))-ph(il,inb(il)+ &
+      1))/(ph(il,inb(il)-1)-ph(il,inb(il)))
+
+  END DO
+
+  ! do j=1,ntra
+  ! do il=1,ncum
+  ! ex=0.1*ment(il,inb(il),inb(il))
+  ! :      *(traent(il,inb(il),inb(il),j)-tra(il,inb(il),j))
+  ! :      /(ph(il,inb(il))-ph(il,inb(il)+1))
+  ! ftra(il,inb(il),j)=ftra(il,inb(il),j)-ex
+  ! ftra(il,inb(il)-1,j)=ftra(il,inb(il)-1,j)
+  ! :       +ex*(ph(il,inb(il))-ph(il,inb(il)+1))
+  ! :          /(ph(il,inb(il)-1)-ph(il,inb(il)))
+  ! enddo
+  ! enddo
+
+
+  ! ***    homoginize tendencies below cloud base    ***
+
+
+  DO il = 1, ncum
+    asum(il) = 0.0
+    bsum(il) = 0.0
+    csum(il) = 0.0
+    dsum(il) = 0.0
+  END DO
+
+  DO i = 1, nl
+    DO il = 1, ncum
+      IF (i<=(icb(il)-1)) THEN
+        asum(il) = asum(il) + ft(il, i)*(ph(il,i)-ph(il,i+1))
+        bsum(il) = bsum(il) + fr(il, i)*(lv(il,i)+(cl-cpd)*(t(il,i)-t(il, &
+          1)))*(ph(il,i)-ph(il,i+1))
+        csum(il) = csum(il) + (lv(il,i)+(cl-cpd)*(t(il,i)-t(il, &
+          1)))*(ph(il,i)-ph(il,i+1))
+        dsum(il) = dsum(il) + t(il, i)*(ph(il,i)-ph(il,i+1))/th(il, i)
+      END IF
+    END DO
+  END DO
+
+  ! !!!      do 700 i=1,icb(il)-1
+  DO i = 1, nl
+    DO il = 1, ncum
+      IF (i<=(icb(il)-1)) THEN
+        ft(il, i) = asum(il)*t(il, i)/(th(il,i)*dsum(il))
+        fr(il, i) = bsum(il)/csum(il)
+      END IF
+    END DO
+  END DO
+
+
+  ! ***           reset counter and return           ***
+
+  DO il = 1, ncum
+    sig(il, nd) = 2.0
+  END DO
+
+
+  DO i = 1, nd
+    DO il = 1, ncum
+      upwd(il, i) = 0.0
+      dnwd(il, i) = 0.0
+    END DO
+  END DO
+
+  DO i = 1, nl
+    DO il = 1, ncum
+      dnwd0(il, i) = -mp(il, i)
+    END DO
+  END DO
+  DO i = nl + 1, nd
+    DO il = 1, ncum
+      dnwd0(il, i) = 0.
+    END DO
+  END DO
+
+
+  DO i = 1, nl
+    DO il = 1, ncum
+      IF (i>=icb(il) .AND. i<=inb(il)) THEN
+        upwd(il, i) = 0.0
+        dnwd(il, i) = 0.0
+      END IF
+    END DO
+  END DO
+
+  DO i = 1, nl
+    DO k = 1, nl
+      DO il = 1, ncum
+        up1(il, k, i) = 0.0
+        dn1(il, k, i) = 0.0
+      END DO
+    END DO
+  END DO
+
+  DO i = 1, nl
+    DO k = i, nl
+      DO n = 1, i - 1
+        DO il = 1, ncum
+          IF (i>=icb(il) .AND. i<=inb(il) .AND. k<=inb(il)) THEN
+            up1(il, k, i) = up1(il, k, i) + ment(il, n, k)
+            dn1(il, k, i) = dn1(il, k, i) - ment(il, k, n)
+          END IF
+        END DO
+      END DO
+    END DO
+  END DO
+
+  DO i = 2, nl
+    DO k = i, nl
+      DO il = 1, ncum
+        ! test         if (i.ge.icb(il).and.i.le.inb(il).and.k.le.inb(il))
+        ! then
+        IF (i<=inb(il) .AND. k<=inb(il)) THEN
+          upwd(il, i) = upwd(il, i) + m(il, k) + up1(il, k, i)
+          dnwd(il, i) = dnwd(il, i) + dn1(il, k, i)
+        END IF
+      END DO
+    END DO
+  END DO
+
+
+  ! !!!      DO il=1,ncum
+  ! !!!      do i=icb(il),inb(il)
+  ! !!!
+  ! !!!      upwd(il,i)=0.0
+  ! !!!      dnwd(il,i)=0.0
+  ! !!!      do k=i,inb(il)
+  ! !!!      up1=0.0
+  ! !!!      dn1=0.0
+  ! !!!      do n=1,i-1
+  ! !!!      up1=up1+ment(il,n,k)
+  ! !!!      dn1=dn1-ment(il,k,n)
+  ! !!!      enddo
+  ! !!!      upwd(il,i)=upwd(il,i)+m(il,k)+up1
+  ! !!!      dnwd(il,i)=dnwd(il,i)+dn1
+  ! !!!      enddo
+  ! !!!      enddo
+  ! !!!
+  ! !!!      ENDDO
+
+  ! ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+  ! determination de la variation de flux ascendant entre
+  ! deux niveau non dilue mike
+  ! ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+
+  DO i = 1, nl
+    DO il = 1, ncum
+      mike(il, i) = m(il, i)
+    END DO
+  END DO
+
+  DO i = nl + 1, nd
+    DO il = 1, ncum
+      mike(il, i) = 0.
+    END DO
+  END DO
+
+  DO i = 1, nd
+    DO il = 1, ncum
+      ma(il, i) = 0
+    END DO
+  END DO
+
+  DO i = 1, nl
+    DO j = i, nl
+      DO il = 1, ncum
+        ma(il, i) = ma(il, i) + m(il, j)
+      END DO
+    END DO
+  END DO
+
+  DO i = nl + 1, nd
+    DO il = 1, ncum
+      ma(il, i) = 0.
+    END DO
+  END DO
+
+  DO i = 1, nl
+    DO il = 1, ncum
+      IF (i<=(icb(il)-1)) THEN
+        ma(il, i) = 0
+      END IF
+    END DO
+  END DO
+
+  ! cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+  ! icb represente de niveau ou se trouve la
+  ! base du nuage , et inb le top du nuage
+  ! ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+
+  DO i = 1, nd
+    DO il = 1, ncum
+      mke(il, i) = upwd(il, i) + dnwd(il, i)
+    END DO
+  END DO
+
+  DO i = 1, nd
+    DO il = 1, ncum
+      rdcp = (rrd*(1.-rr(il,i))-rr(il,i)*rrv)/(cpd*(1.-rr(il, &
+        i))+rr(il,i)*cpv)
+      tls(il, i) = t(il, i)*(1000.0/p(il,i))**rdcp
+      tps(il, i) = tp(il, i)
+    END DO
+  END DO
+
+
+  ! *** diagnose the in-cloud mixing ratio   ***            ! cld
+  ! ***           of condensed water         ***            ! cld
+  ! ! cld
+
+  DO i = 1, nd ! cld
+    DO il = 1, ncum ! cld
+      mac(il, i) = 0.0 ! cld
+      wa(il, i) = 0.0 ! cld
+      siga(il, i) = 0.0 ! cld
+      sax(il, i) = 0.0 ! cld
+    END DO ! cld
+  END DO ! cld
+
+  DO i = minorig, nl ! cld
+    DO k = i + 1, nl + 1 ! cld
+      DO il = 1, ncum ! cld
+        IF (i<=inb(il) .AND. k<=(inb(il)+1)) THEN ! cld
+          mac(il, i) = mac(il, i) + m(il, k) ! cld
+        END IF ! cld
+      END DO ! cld
+    END DO ! cld
+  END DO ! cld
+
+  DO i = 1, nl ! cld
+    DO j = 1, i ! cld
+      DO il = 1, ncum ! cld
+        IF (i>=icb(il) .AND. i<=(inb(il)-1) & ! cld
+            .AND. j>=icb(il)) THEN ! cld
+          sax(il, i) = sax(il, i) + rrd*(tvp(il,j)-tv(il,j)) & ! cld
+            *(ph(il,j)-ph(il,j+1))/p(il, j) ! cld
+        END IF ! cld
+      END DO ! cld
+    END DO ! cld
+  END DO ! cld
+
+  DO i = 1, nl ! cld
+    DO il = 1, ncum ! cld
+      IF (i>=icb(il) .AND. i<=(inb(il)-1) & ! cld
+          .AND. sax(il,i)>0.0) THEN ! cld
+        wa(il, i) = sqrt(2.*sax(il,i)) ! cld
+      END IF ! cld
+    END DO ! cld
+  END DO ! cld
+
+  DO i = 1, nl ! cld
+    DO il = 1, ncum ! cld
+      IF (wa(il,i)>0.0) &          ! cld
+        siga(il, i) = mac(il, i)/wa(il, i) & ! cld
+        *rrd*tvp(il, i)/p(il, i)/100./delta ! cld
+      siga(il, i) = min(siga(il,i), 1.0) ! cld
+      ! IM cf. FH
+      IF (iflag_clw==0) THEN
+        qcondc(il, i) = siga(il, i)*clw(il, i)*(1.-ep(il,i)) & ! cld
+          +(1.-siga(il,i))*qcond(il, i) ! cld
+      ELSE IF (iflag_clw==1) THEN
+        qcondc(il, i) = qcond(il, i) ! cld
+      END IF
+
+    END DO ! cld
+  END DO ! cld
+
+  RETURN
+END SUBROUTINE cv30_yield
+
+! !RomP >>>
+SUBROUTINE cv30_tracer(nloc, len, ncum, nd, na, ment, sij, da, phi, phi2, &
+    d1a, dam, ep, vprecip, elij, clw, epmlmmm, eplamm, icb, inb)
+  IMPLICIT NONE
+
+  include "cv30param.h"
+
+  ! inputs:
+  INTEGER ncum, nd, na, nloc, len
+  REAL ment(nloc, na, na), sij(nloc, na, na)
+  REAL clw(nloc, nd), elij(nloc, na, na)
+  REAL ep(nloc, na)
+  INTEGER icb(nloc), inb(nloc)
+  REAL vprecip(nloc, nd+1)
+  ! ouputs:
+  REAL da(nloc, na), phi(nloc, na, na)
+  REAL phi2(nloc, na, na)
+  REAL d1a(nloc, na), dam(nloc, na)
+  REAL epmlmmm(nloc, na, na), eplamm(nloc, na)
+  ! variables pour tracer dans precip de l'AA et des mel
+  ! local variables:
+  INTEGER i, j, k, nam1
+  REAL epm(nloc, na, na)
+
+  nam1=na-1 ! Introduced because ep is not defined for j=na
+  ! variables d'Emanuel : du second indice au troisieme
+  ! --->    tab(i,k,j) -> de l origine k a l arrivee j
+  ! ment, sij, elij
+  ! variables personnelles : du troisieme au second indice
+  ! --->    tab(i,j,k) -> de k a j
+  ! phi, phi2
+
+  ! initialisations
+  DO j = 1, na
+    DO i = 1, ncum
+      da(i, j) = 0.
+      d1a(i, j) = 0.
+      dam(i, j) = 0.
+      eplamm(i, j) = 0.
+    END DO
+  END DO
+  DO k = 1, na
+    DO j = 1, na
+      DO i = 1, ncum
+        epm(i, j, k) = 0.
+        epmlmmm(i, j, k) = 0.
+        phi(i, j, k) = 0.
+        phi2(i, j, k) = 0.
+      END DO
+    END DO
+  END DO
+
+  ! fraction deau condensee dans les melanges convertie en precip : epm
+  ! et eau condensée précipitée dans masse d'air saturé : l_m*dM_m/dzdz.dzdz
+  DO j = 1, nam1
+    DO k = 1, j - 1
+      DO i = 1, ncum
+        IF (k>=icb(i) .AND. k<=inb(i) .AND. j<=inb(i)) THEN
+          ! !jyg             epm(i,j,k)=1.-(1.-ep(i,j))*clw(i,j)/elij(i,k,j)
+          epm(i, j, k) = 1. - (1.-ep(i,j))*clw(i, j)/max(elij(i,k,j), 1.E-16)
+          ! !
+          epm(i, j, k) = max(epm(i,j,k), 0.0)
+        END IF
+      END DO
+    END DO
+  END DO
+
+  DO j = 1, nam1
+    DO k = 1, nam1
+      DO i = 1, ncum
+        IF (k>=icb(i) .AND. k<=inb(i)) THEN
+          eplamm(i, j) = eplamm(i, j) + ep(i, j)*clw(i, j)*ment(i, j, k)*(1.- &
+            sij(i,j,k))
+        END IF
+      END DO
+    END DO
+  END DO
+
+  DO j = 1, nam1
+    DO k = 1, j - 1
+      DO i = 1, ncum
+        IF (k>=icb(i) .AND. k<=inb(i) .AND. j<=inb(i)) THEN
+          epmlmmm(i, j, k) = epm(i, j, k)*elij(i, k, j)*ment(i, k, j)
+        END IF
+      END DO
+    END DO
+  END DO
+
+  ! matrices pour calculer la tendance des concentrations dans cvltr.F90
+  DO j = 1, nam1
+    DO k = 1, nam1
+      DO i = 1, ncum
+        da(i, j) = da(i, j) + (1.-sij(i,k,j))*ment(i, k, j)
+        phi(i, j, k) = sij(i, k, j)*ment(i, k, j)
+        d1a(i, j) = d1a(i, j) + ment(i, k, j)*ep(i, k)*(1.-sij(i,k,j))
+      END DO
+    END DO
+  END DO
+
+  DO j = 1, nam1
+    DO k = 1, j - 1
+      DO i = 1, ncum
+        dam(i, j) = dam(i, j) + ment(i, k, j)*epm(i, j, k)*(1.-ep(i,k))*(1.- &
+          sij(i,k,j))
+        phi2(i, j, k) = phi(i, j, k)*epm(i, j, k)
+      END DO
+    END DO
+  END DO
+
+  RETURN
+END SUBROUTINE cv30_tracer
+! RomP <<<
+
+SUBROUTINE cv30_uncompress(nloc, len, ncum, nd, ntra, idcum, iflag, precip, &
+    vprecip, evap, ep, sig, w0, ft, fq, fu, fv, ftra, inb, ma, upwd, dnwd, &
+    dnwd0, qcondc, wd, cape, da, phi, mp, phi2, d1a, dam, sij, elij, clw, &
+    epmlmmm, eplamm, wdtraina, wdtrainm,epmax_diag, iflag1, precip1, vprecip1, evap1, &
+    ep1, sig1, w01, ft1, fq1, fu1, fv1, ftra1, inb1, ma1, upwd1, dnwd1, &
+    dnwd01, qcondc1, wd1, cape1, da1, phi1, mp1, phi21, d1a1, dam1, sij1, &
+    elij1, clw1, epmlmmm1, eplamm1, wdtraina1, wdtrainm1,epmax_diag1) ! epmax_cape
+  IMPLICIT NONE
+
+  include "cv30param.h"
+
+  ! inputs:
+  INTEGER len, ncum, nd, ntra, nloc
+  INTEGER idcum(nloc)
+  INTEGER iflag(nloc)
+  INTEGER inb(nloc)
+  REAL precip(nloc)
+  REAL vprecip(nloc, nd+1), evap(nloc, nd)
+  REAL ep(nloc, nd)
+  REAL sig(nloc, nd), w0(nloc, nd)
+  REAL ft(nloc, nd), fq(nloc, nd), fu(nloc, nd), fv(nloc, nd)
+  REAL ftra(nloc, nd, ntra)
+  REAL ma(nloc, nd)
+  REAL upwd(nloc, nd), dnwd(nloc, nd), dnwd0(nloc, nd)
+  REAL qcondc(nloc, nd)
+  REAL wd(nloc), cape(nloc)
+  REAL da(nloc, nd), phi(nloc, nd, nd), mp(nloc, nd)
+  REAL epmax_diag(nloc) ! epmax_cape
+  ! RomP >>>
+  REAL phi2(nloc, nd, nd)
+  REAL d1a(nloc, nd), dam(nloc, nd)
+  REAL wdtraina(nloc, nd), wdtrainm(nloc, nd)
+  REAL sij(nloc, nd, nd)
+  REAL elij(nloc, nd, nd), clw(nloc, nd)
+  REAL epmlmmm(nloc, nd, nd), eplamm(nloc, nd)
+  ! RomP <<<
+
+  ! outputs:
+  INTEGER iflag1(len)
+  INTEGER inb1(len)
+  REAL precip1(len)
+  REAL vprecip1(len, nd+1), evap1(len, nd) !<<< RomP
+  REAL ep1(len, nd) !<<< RomP
+  REAL sig1(len, nd), w01(len, nd)
+  REAL ft1(len, nd), fq1(len, nd), fu1(len, nd), fv1(len, nd)
+  REAL ftra1(len, nd, ntra)
+  REAL ma1(len, nd)
+  REAL upwd1(len, nd), dnwd1(len, nd), dnwd01(len, nd)
+  REAL qcondc1(nloc, nd)
+  REAL wd1(nloc), cape1(nloc)
+  REAL da1(nloc, nd), phi1(nloc, nd, nd), mp1(nloc, nd)
+  REAL epmax_diag1(len) ! epmax_cape
+  ! RomP >>>
+  REAL phi21(len, nd, nd)
+  REAL d1a1(len, nd), dam1(len, nd)
+  REAL wdtraina1(len, nd), wdtrainm1(len, nd)
+  REAL sij1(len, nd, nd)
+  REAL elij1(len, nd, nd), clw1(len, nd)
+  REAL epmlmmm1(len, nd, nd), eplamm1(len, nd)
+  ! RomP <<<
+
+  ! local variables:
+  INTEGER i, k, j
+
+  DO i = 1, ncum
+    precip1(idcum(i)) = precip(i)
+    iflag1(idcum(i)) = iflag(i)
+    wd1(idcum(i)) = wd(i)
+    inb1(idcum(i)) = inb(i)
+    cape1(idcum(i)) = cape(i)
+    epmax_diag1(idcum(i))=epmax_diag(i) ! epmax_cape
+  END DO
+
+  DO k = 1, nl
+    DO i = 1, ncum
+      vprecip1(idcum(i), k) = vprecip(i, k)
+      evap1(idcum(i), k) = evap(i, k) !<<< RomP
+      sig1(idcum(i), k) = sig(i, k)
+      w01(idcum(i), k) = w0(i, k)
+      ft1(idcum(i), k) = ft(i, k)
+      fq1(idcum(i), k) = fq(i, k)
+      fu1(idcum(i), k) = fu(i, k)
+      fv1(idcum(i), k) = fv(i, k)
+      ma1(idcum(i), k) = ma(i, k)
+      upwd1(idcum(i), k) = upwd(i, k)
+      dnwd1(idcum(i), k) = dnwd(i, k)
+      dnwd01(idcum(i), k) = dnwd0(i, k)
+      qcondc1(idcum(i), k) = qcondc(i, k)
+      da1(idcum(i), k) = da(i, k)
+      mp1(idcum(i), k) = mp(i, k)
+      ! RomP >>>
+      ep1(idcum(i), k) = ep(i, k)
+      d1a1(idcum(i), k) = d1a(i, k)
+      dam1(idcum(i), k) = dam(i, k)
+      clw1(idcum(i), k) = clw(i, k)
+      eplamm1(idcum(i), k) = eplamm(i, k)
+      wdtraina1(idcum(i), k) = wdtraina(i, k)
+      wdtrainm1(idcum(i), k) = wdtrainm(i, k)
+      ! RomP <<<
+    END DO
+  END DO
+
+  DO i = 1, ncum
+    sig1(idcum(i), nd) = sig(i, nd)
+  END DO
+
+
+  ! do 2100 j=1,ntra
+  ! do 2110 k=1,nd ! oct3
+  ! do 2120 i=1,ncum
+  ! ftra1(idcum(i),k,j)=ftra(i,k,j)
+  ! 2120     continue
+  ! 2110    continue
+  ! 2100   continue
+  DO j = 1, nd
+    DO k = 1, nd
+      DO i = 1, ncum
+        sij1(idcum(i), k, j) = sij(i, k, j)
+        phi1(idcum(i), k, j) = phi(i, k, j)
+        phi21(idcum(i), k, j) = phi2(i, k, j)
+        elij1(idcum(i), k, j) = elij(i, k, j)
+        epmlmmm1(idcum(i), k, j) = epmlmmm(i, k, j)
+      END DO
+    END DO
+  END DO
+
+  RETURN
+END SUBROUTINE cv30_uncompress
+
+        subroutine cv30_epmax_fn_cape(nloc,ncum,nd &
+                ,cape,ep,hp,icb,inb,clw,nk,t,h,lv &
+                ,epmax_diag)
+        implicit none
+
+        ! On fait varier epmax en fn de la cape
+        ! Il faut donc recalculer ep, et hp qui a déjà été calculé et
+        ! qui en dépend
+        ! Toutes les autres variables fn de ep sont calculées plus bas.
+
+        INCLUDE "cvthermo.h"
+        INCLUDE "cv30param.h"
+        INCLUDE "conema3.h"
+
+! inputs:
+      integer ncum, nd, nloc
+      integer icb(nloc), inb(nloc)
+      real cape(nloc)
+      real clw(nloc,nd),lv(nloc,nd),t(nloc,nd),h(nloc,nd)
+      integer nk(nloc)
+! inouts:
+      real ep(nloc,nd)
+      real hp(nloc,nd)
+! outputs ou local
+      real epmax_diag(nloc)
+! locals
+      integer i,k    
+      real hp_bak(nloc,nd)
+      CHARACTER (LEN=20) :: modname='cv30_epmax_fn_cape'
+      CHARACTER (LEN=80) :: abort_message
+
+        ! on recalcule ep et hp
+        
+        if (coef_epmax_cape.gt.1e-12) then
+        do i=1,ncum
+           epmax_diag(i)=epmax-coef_epmax_cape*sqrt(cape(i))
+           do k=1,nl
+                ep(i,k)=ep(i,k)/epmax*epmax_diag(i)
+                ep(i,k)=amax1(ep(i,k),0.0)
+                ep(i,k)=amin1(ep(i,k),epmax_diag(i))
+           enddo
+        enddo
+
+! On recalcule hp:
+      do k=1,nl
+        do i=1,ncum
+	  hp_bak(i,k)=hp(i,k)
+	enddo
+      enddo
+      do k=1,nlp
+        do i=1,ncum
+	  hp(i,k)=h(i,k)
+	enddo
+      enddo
+      do k=minorig+1,nl
+       do i=1,ncum
+        if((k.ge.icb(i)).and.(k.le.inb(i)))then
+          hp(i,k)=h(i,nk(i))+(lv(i,k)+(cpd-cpv)*t(i,k))*ep(i,k)*clw(i,k)
+        endif
+       enddo
+      enddo !do k=minorig+1,n
+!     write(*,*) 'cv30_routines 6218: hp(1,20)=',hp(1,20)
+      do i=1,ncum  
+       do k=1,nl
+        if (abs(hp_bak(i,k)-hp(i,k)).gt.0.01) then
+           write(*,*) 'i,k=',i,k
+           write(*,*) 'coef_epmax_cape=',coef_epmax_cape
+           write(*,*) 'epmax_diag(i)=',epmax_diag(i)
+           write(*,*) 'ep(i,k)=',ep(i,k)
+           write(*,*) 'hp(i,k)=',hp(i,k)
+           write(*,*) 'hp_bak(i,k)=',hp_bak(i,k)
+           write(*,*) 'h(i,k)=',h(i,k)
+           write(*,*) 'nk(i)=',nk(i)
+           write(*,*) 'h(i,nk(i))=',h(i,nk(i))
+           write(*,*) 'lv(i,k)=',lv(i,k)
+           write(*,*) 't(i,k)=',t(i,k)
+           write(*,*) 'clw(i,k)=',clw(i,k)
+           write(*,*) 'cpd,cpv=',cpd,cpv
+           CALL abort_physic(modname,abort_message,1)
+        endif
+       enddo !do k=1,nl
+      enddo !do i=1,ncum  
+      endif !if (coef_epmax_cape.gt.1e-12) then
+
+      return
+      end subroutine cv30_epmax_fn_cape
+
+
Index: DZ6/trunk/libf/phylmd/cv3_buoy.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cv3_buoy.F90	(revision 5267)
+++ 	(revision )
@@ -1,155 +1,0 @@
-SUBROUTINE cv3_buoy(nloc, ncum, nd, icb, inb, pbase, plcl, p, ph, ale, cin, &
-    tv, tvp, buoy)
-  ! **************************************************************
-  ! *
-  ! CV3_BUOY                                                    *
-  ! Buoyancy corrections to account for ALE             *
-  ! *
-  ! written by   : MOREAU Cecile, 07/08/2003, 15.55.48          *
-  ! modified by :                                               *
-  ! **************************************************************
-
-  IMPLICIT NONE
-
-  include "cvthermo.h"
-  include "cv3param.h"
-  include "YOMCST2.h"
-
-  ! input:
-  INTEGER ncum, nd, nloc
-  INTEGER icb(nloc), inb(nloc)
-  REAL pbase(nloc), plcl(nloc)
-  REAL p(nloc, nd), ph(nloc, nd+1)
-  REAL ale(nloc), cin(nloc)
-  REAL tv(nloc, nd), tvp(nloc, nd)
-
-  ! output:
-  REAL buoy(nloc, nd)
-
-  ! local variables:
-  INTEGER il, k
-  INTEGER kmx(nloc)
-  REAL bll(nloc), bmx(nloc)
-  REAL gamma(nloc)
-  LOGICAL ok(nloc)
-
-  REAL dgamma
-  REAL buoymin
-  PARAMETER (dgamma=2.E-03) !dgamma gamma
-  PARAMETER (buoymin=2.)
-
-  LOGICAL fixed_bll
-  SAVE fixed_bll
-  DATA fixed_bll/.TRUE./
-  !$OMP THREADPRIVATE(fixed_bll)
-
-
-  ! print *,' Ale+cin ',ale(1)+cin(1)
-  ! --------------------------------------------------------------
-  ! Recompute buoyancies
-  ! --------------------------------------------------------------
-  DO k = 1, nl
-    DO il = 1, ncum
-      buoy(il, k) = tvp(il, k) - tv(il, k)
-    END DO
-  END DO
-
-  ! -------------------------------------------------------------
-  ! -- Compute low level buoyancy ( function of Ale+Cin )
-  ! -------------------------------------------------------------
-  IF (fixed_bll) THEN
-
-    DO il = 1, ncum
-      bll(il) = 0.5
-    END DO
-  ELSE
-
-    DO il = 1, ncum
-      IF (ale(il)+cin(il)>0.) THEN
-        gamma(il) = 4.*buoy(il, icb(il))**2 + 8.*dgamma*(ale(il)+cin(il))*tv( &
-          il, icb(il))/grav
-        gamma(il) = max(gamma(il), 1.E-10)
-      END IF
-    END DO
-
-    DO il = 1, ncum
-      IF (ale(il)+cin(il)>0.) THEN
-        bll(il) = 4.*dgamma*(ale(il)+cin(il))*tv(il, icb(il))/ &
-          (grav*(abs(buoy(il,icb(il))+0.5*sqrt(gamma(il)))))
-      END IF
-    END DO
-
-    DO il = 1, ncum
-      IF (ale(il)+cin(il)>0.) THEN
-        bll(il) = min(bll(il), buoymin)
-      END IF
-    END DO
-
-  END IF !(fixed_bll)
-
-
-  ! -------------------------------------------------------------
-  ! --Get highest buoyancy among levels below LCL-200hPa
-  ! -------------------------------------------------------------
-
-  DO il = 1, ncum
-    bmx(il) = -1000.
-    kmx(il) = icb(il)
-    ok(il) = .TRUE.
-  END DO
-
-  DO k = 1, nl
-    DO il = 1, ncum
-      IF (ale(il)+cin(il)>0. .AND. ok(il)) THEN
-        IF (k>icb(il) .AND. k<=inb(il)) THEN
-          ! c         print *,'k,p(il,k),plcl(il)-200. ',
-          ! k,p(il,k),plcl(il)-200.
-          IF (p(il,k)>plcl(il)-200.) THEN
-            IF (buoy(il,k)>bmx(il)) THEN
-              bmx(il) = buoy(il, k)
-              kmx(il) = k
-              IF (bmx(il)>=bll(il)) ok(il) = .FALSE.
-            END IF
-          END IF
-        END IF
-      END IF
-    END DO
-  END DO
-
-  ! print *,' ==cv3_buoy== bll(1),bmx(1),icb(1),kmx(1) '
-  ! $       ,bll(1),bmx(1),icb(1),kmx(1)
-
-  ! -------------------------------------------------------------
-  ! --Calculate modified buoyancies
-  ! -------------------------------------------------------------
-
-  DO il = 1, ncum
-    IF (ale(il)+cin(il)>0.) THEN
-      bll(il) = min(bll(il), bmx(il))
-    END IF
-  END DO
-
-  DO k = 1, nl
-    DO il = 1, ncum
-      IF (ale(il)+cin(il)>0.) THEN
-        IF (k>=icb(il) .AND. k<=kmx(il)-1) THEN
-          buoy(il, k) = bll(il)
-        END IF
-      END IF
-    END DO
-  END DO
-
-!CR:Correction of buoy for what comes next
-!keep flag or to modify in all cases?
-  IF (iflag_mix_adiab.eq.1) THEN
-  DO k = 1, nl 
-    DO il = 1, ncum
-       IF ((k>=kmx(il)) .AND. (k<=inb(il)) .AND. (buoy(il,k).lt.0.)) THEN
-          buoy(il,k)=buoy(il,k-1)
-       END IF
-    ENDDO
-  ENDDO
-  ENDIF
-
-  RETURN
-END SUBROUTINE cv3_buoy
Index: /LMDZ6/trunk/libf/phylmd/cv3_buoy.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cv3_buoy.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/cv3_buoy.f90	(revision 5268)
@@ -0,0 +1,155 @@
+SUBROUTINE cv3_buoy(nloc, ncum, nd, icb, inb, pbase, plcl, p, ph, ale, cin, &
+    tv, tvp, buoy)
+  ! **************************************************************
+  ! *
+  ! CV3_BUOY                                                    *
+  ! Buoyancy corrections to account for ALE             *
+  ! *
+  ! written by   : MOREAU Cecile, 07/08/2003, 15.55.48          *
+  ! modified by :                                               *
+  ! **************************************************************
+
+  IMPLICIT NONE
+
+  include "cvthermo.h"
+  include "cv3param.h"
+  include "YOMCST2.h"
+
+  ! input:
+  INTEGER ncum, nd, nloc
+  INTEGER icb(nloc), inb(nloc)
+  REAL pbase(nloc), plcl(nloc)
+  REAL p(nloc, nd), ph(nloc, nd+1)
+  REAL ale(nloc), cin(nloc)
+  REAL tv(nloc, nd), tvp(nloc, nd)
+
+  ! output:
+  REAL buoy(nloc, nd)
+
+  ! local variables:
+  INTEGER il, k
+  INTEGER kmx(nloc)
+  REAL bll(nloc), bmx(nloc)
+  REAL gamma(nloc)
+  LOGICAL ok(nloc)
+
+  REAL dgamma
+  REAL buoymin
+  PARAMETER (dgamma=2.E-03) !dgamma gamma
+  PARAMETER (buoymin=2.)
+
+  LOGICAL fixed_bll
+  SAVE fixed_bll
+  DATA fixed_bll/.TRUE./
+  !$OMP THREADPRIVATE(fixed_bll)
+
+
+  ! print *,' Ale+cin ',ale(1)+cin(1)
+  ! --------------------------------------------------------------
+  ! Recompute buoyancies
+  ! --------------------------------------------------------------
+  DO k = 1, nl
+    DO il = 1, ncum
+      buoy(il, k) = tvp(il, k) - tv(il, k)
+    END DO
+  END DO
+
+  ! -------------------------------------------------------------
+  ! -- Compute low level buoyancy ( function of Ale+Cin )
+  ! -------------------------------------------------------------
+  IF (fixed_bll) THEN
+
+    DO il = 1, ncum
+      bll(il) = 0.5
+    END DO
+  ELSE
+
+    DO il = 1, ncum
+      IF (ale(il)+cin(il)>0.) THEN
+        gamma(il) = 4.*buoy(il, icb(il))**2 + 8.*dgamma*(ale(il)+cin(il))*tv( &
+          il, icb(il))/grav
+        gamma(il) = max(gamma(il), 1.E-10)
+      END IF
+    END DO
+
+    DO il = 1, ncum
+      IF (ale(il)+cin(il)>0.) THEN
+        bll(il) = 4.*dgamma*(ale(il)+cin(il))*tv(il, icb(il))/ &
+          (grav*(abs(buoy(il,icb(il))+0.5*sqrt(gamma(il)))))
+      END IF
+    END DO
+
+    DO il = 1, ncum
+      IF (ale(il)+cin(il)>0.) THEN
+        bll(il) = min(bll(il), buoymin)
+      END IF
+    END DO
+
+  END IF !(fixed_bll)
+
+
+  ! -------------------------------------------------------------
+  ! --Get highest buoyancy among levels below LCL-200hPa
+  ! -------------------------------------------------------------
+
+  DO il = 1, ncum
+    bmx(il) = -1000.
+    kmx(il) = icb(il)
+    ok(il) = .TRUE.
+  END DO
+
+  DO k = 1, nl
+    DO il = 1, ncum
+      IF (ale(il)+cin(il)>0. .AND. ok(il)) THEN
+        IF (k>icb(il) .AND. k<=inb(il)) THEN
+          ! c         print *,'k,p(il,k),plcl(il)-200. ',
+          ! k,p(il,k),plcl(il)-200.
+          IF (p(il,k)>plcl(il)-200.) THEN
+            IF (buoy(il,k)>bmx(il)) THEN
+              bmx(il) = buoy(il, k)
+              kmx(il) = k
+              IF (bmx(il)>=bll(il)) ok(il) = .FALSE.
+            END IF
+          END IF
+        END IF
+      END IF
+    END DO
+  END DO
+
+  ! print *,' ==cv3_buoy== bll(1),bmx(1),icb(1),kmx(1) '
+  ! $       ,bll(1),bmx(1),icb(1),kmx(1)
+
+  ! -------------------------------------------------------------
+  ! --Calculate modified buoyancies
+  ! -------------------------------------------------------------
+
+  DO il = 1, ncum
+    IF (ale(il)+cin(il)>0.) THEN
+      bll(il) = min(bll(il), bmx(il))
+    END IF
+  END DO
+
+  DO k = 1, nl
+    DO il = 1, ncum
+      IF (ale(il)+cin(il)>0.) THEN
+        IF (k>=icb(il) .AND. k<=kmx(il)-1) THEN
+          buoy(il, k) = bll(il)
+        END IF
+      END IF
+    END DO
+  END DO
+
+!CR:Correction of buoy for what comes next
+!keep flag or to modify in all cases?
+  IF (iflag_mix_adiab.eq.1) THEN
+  DO k = 1, nl 
+    DO il = 1, ncum
+       IF ((k>=kmx(il)) .AND. (k<=inb(il)) .AND. (buoy(il,k).lt.0.)) THEN
+          buoy(il,k)=buoy(il,k-1)
+       END IF
+    ENDDO
+  ENDDO
+  ENDIF
+
+  RETURN
+END SUBROUTINE cv3_buoy
Index: DZ6/trunk/libf/phylmd/cv3_cine.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cv3_cine.F90	(revision 5267)
+++ 	(revision )
@@ -1,461 +1,0 @@
-
-! $Id$
-
-SUBROUTINE cv3_cine(nloc, ncum, nd, icb, inb, pbase, plcl, p, ph, tv, tvp, &
-    cina, cinb, plfc)
-
-  ! **************************************************************
-  ! *
-  ! CV3_CINE                                                    *
-  ! *
-  ! *
-  ! written by   :   Frederique Cheruy                          *
-  ! vectorization:   Jean-Yves Grandpeix, 19/06/2003, 11.54.43  *
-  ! modified by :                                               *
-  ! **************************************************************
-
-  IMPLICIT NONE
-
-  include "YOMCST.h"
-  include "cvthermo.h"
-  include "cv3param.h"
-  ! input:
-  INTEGER ncum, nd, nloc
-  INTEGER icb(nloc), inb(nloc)
-  REAL pbase(nloc), plcl(nloc)
-  REAL p(nloc, nd), ph(nloc, nd+1)
-  REAL tv(nloc, nd), tvp(nloc, nd)
-
-  ! output
-  REAL cina(nloc), cinb(nloc), plfc(nloc)
-
-  ! local variables
-  INTEGER il, i, j, k
-  INTEGER itop(nloc), ineg(nloc), ilow(nloc)
-  INTEGER ifst(nloc), isublcl(nloc)
-  LOGICAL lswitch(nloc), lswitch1(nloc), lswitch2(nloc), lswitch3(nloc)
-  LOGICAL exist_lfc(nloc)
-  REAL dpmax
-  REAL deltap, dcin
-  REAL buoylcl(nloc), tvplcl(nloc), tvlcl(nloc)
-  REAL p0(nloc)
-  REAL buoyz(nloc), buoy(nloc, nd)
-
-  ! -------------------------------------------------------------
-  ! Initialization
-  ! -------------------------------------------------------------
-  DO il = 1, ncum
-    cina(il) = 0.
-    cinb(il) = 0.
-  END DO
-
-  ! --------------------------------------------------------------
-  ! Recompute buoyancies
-  ! --------------------------------------------------------------
-  DO k = 1, nd
-    DO il = 1, ncum
-      ! print*,'tvp tv=',tvp(il,k),tv(il,k)
-      buoy(il, k) = tvp(il, k) - tv(il, k)
-    END DO
-  END DO
-  ! ---------------------------------------------------------------
-
-  ! calcul de la flottabilite a LCL (Buoylcl)
-  ! ifst = first P-level above lcl
-  ! isublcl = highest P-level below lcl.
-  ! ---------------------------------------------------------------
-
-  DO il = 1, ncum
-    tvplcl(il) = tvp(il, 1)*(plcl(il)/p(il,1))**(2./7.) !For dry air, R/Cp=2/7
-  END DO
-
-  DO il = 1, ncum
-    IF (plcl(il)>p(il,icb(il))) THEN
-      ifst(il) = icb(il)
-      isublcl(il) = icb(il) - 1
-    ELSE
-      ifst(il) = icb(il) + 1
-      isublcl(il) = icb(il)
-    END IF
-  END DO
-
-  DO il = 1, ncum
-    tvlcl(il) = tv(il, ifst(il)-1) + (tv(il,ifst(il))-tv(il,ifst(il)-1))*( &
-      plcl(il)-p(il,ifst(il)-1))/(p(il,ifst(il))-p(il,ifst(il)-1))
-  END DO
-
-  DO il = 1, ncum
-    buoylcl(il) = tvplcl(il) - tvlcl(il)
-  END DO
-
-  ! ---------------------------------------------------------------
-  ! premiere couche contenant un  niveau de flotabilite positive
-  ! et premiere couche contenant un  niveau de flotabilite negative
-  ! au dessus du niveau de condensation
-  ! ---------------------------------------------------------------
-  DO il = 1, ncum
-    itop(il) = nl - 1
-    ineg(il) = nl - 1
-    exist_lfc(il) = .FALSE.
-  END DO
-  DO k = nl - 1, 1, -1
-    DO il = 1, ncum
-      IF (k>=ifst(il)) THEN
-        IF (buoy(il,k)>0.) THEN
-          itop(il) = k
-          exist_lfc(il) = .TRUE.
-        ELSE
-          ineg(il) = k
-        END IF
-      END IF
-    END DO
-  END DO
-
-  ! ---------------------------------------------------------------
-  ! When there is no positive buoyancy level, set Plfc, Cina and Cinb
-  ! to arbitrary extreme values.
-  ! ---------------------------------------------------------------
-  DO il = 1, ncum
-    IF (.NOT. exist_lfc(il)) THEN
-      plfc(il) = 1.111
-      cinb(il) = -1111.
-      cina(il) = -1112.
-    END IF
-  END DO
-
-
-  ! ---------------------------------------------------------------
-  ! -- Two cases : BUOYlcl >= 0 and BUOYlcl < 0.
-  ! ---------------------------------------------------------------
-
-  ! --------------------
-  ! -- 1.0 BUOYlcl >=0.
-  ! --------------------
-
-  dpmax = 50.
-  DO il = 1, ncum
-    lswitch1(il) = buoylcl(il) >= 0. .AND. exist_lfc(il)
-    lswitch(il) = lswitch1(il)
-  END DO
-
-  ! 1.1 No inhibition case
-  ! ----------------------
-  ! If buoyancy is positive at LCL and stays positive over a large enough
-  ! pressure interval (=DPMAX), inhibition is set to zero,
-
-  DO il = 1, ncum
-    IF (lswitch(il)) THEN
-      IF (p(il,ineg(il))<p(il,icb(il))-dpmax) THEN
-        plfc(il) = plcl(il)
-        cina(il) = 0.
-        cinb(il) = 0.
-      END IF
-    END IF
-  END DO
-
-  ! 1.2 Upper inhibition only case
-  ! ------------------------------
-  DO il = 1, ncum
-    lswitch2(il) = p(il, ineg(il)) >= p(il, icb(il)) - dpmax
-    lswitch(il) = lswitch1(il) .AND. lswitch2(il)
-  END DO
-
-  ! 1.2.1 Recompute itop (=1st layer with positive buoyancy above ineg)
-  ! -------------------------------------------------------------------
-
-  DO il = 1, ncum
-    IF (lswitch(il)) THEN
-      itop(il) = nl - 1
-    END IF
-  END DO
-
-  DO k = nl, 1, -1
-    DO il = 1, ncum
-      IF (lswitch(il)) THEN
-        IF (k>=ineg(il) .AND. buoy(il,k)>0) THEN
-          itop(il) = k
-        END IF
-      END IF
-    END DO
-  END DO
-
-  ! If there is no layer with positive buoyancy above ineg, set Plfc, 
-  ! Cina and Cinb to arbitrary extreme values.
-  DO il = 1, ncum
-    IF (lswitch(il) .AND. itop(il) == nl - 1) THEN
-      plfc(il) = 1.121
-      cinb(il) = -1121.
-      cina(il) = -1122.
-    END IF
-  END DO
-
-  DO il = 1, ncum
-    lswitch3(il) = itop(il) < nl -1
-    lswitch(il) = lswitch1(il) .AND. lswitch2(il) .AND. lswitch3(il)
-  END DO
-
-  DO il = 1, ncum
-    IF (lswitch(il)) THEN
-      cinb(il) = 0.
-
-      ! 1.2.2  Calcul de la pression du niveau de flot. nulle juste au-dessus
-      ! de LCL
-      ! ---------------------------------------------------------------------------
-      IF (ineg(il)>isublcl(il)+1) THEN
-        ! In order to get P0, one may interpolate linearly buoyancies
-        ! between P(ineg) and P(ineg-1).
-        p0(il) = (buoy(il,ineg(il))*p(il,ineg(il)-1)-buoy(il,ineg(il)-1)*p(il,ineg(il)))/ &
-          (buoy(il,ineg(il))-buoy(il,ineg(il)-1))
-      ELSE
-        ! In order to get P0, one has to interpolate between P(ineg) and
-        ! Plcl.
-        p0(il) = (buoy(il,ineg(il))*plcl(il)-buoylcl(il)*p(il,ineg(il)))/ &
-          (buoy(il,ineg(il))-buoylcl(il))
-      END IF
-    END IF
-  END DO
-
-  ! 1.2.3 Computation of PLFC
-  ! -------------------------
-  DO il = 1, ncum
-    IF (lswitch(il)) THEN
-      plfc(il) = (buoy(il,itop(il))*p(il,itop(il)-1)-buoy(il,itop( &
-        il)-1)*p(il,itop(il)))/(buoy(il,itop(il))-buoy(il,itop(il)-1))
-    END IF
-  END DO
-
-  ! 1.2.4 Computation of CINA
-  ! -------------------------
-
-  ! Upper part of CINA : integral from P(itop-1) to Plfc
-  DO il = 1, ncum
-    IF (lswitch(il)) THEN
-      deltap = p(il, itop(il)-1) - plfc(il)
-      dcin = rd*buoy(il, itop(il)-1)*deltap/(p(il,itop(il)-1)+plfc(il))
-      cina(il) = min(0., dcin)
-    END IF
-  END DO
-
-  ! Middle part of CINA : integral from P(ineg) to P(itop-1)
-  DO k = 1, nl
-    DO il = 1, ncum
-      IF (lswitch(il)) THEN
-        IF (k>=ineg(il) .AND. k<=itop(il)-2) THEN
-          deltap = p(il, k) - p(il, k+1)
-          dcin = 0.5*rd*(buoy(il,k)+buoy(il,k+1))*deltap/ph(il, k+1)
-          cina(il) = cina(il) + min(0., dcin)
-        END IF
-      END IF
-    END DO
-  END DO
-
-  ! Lower part of CINA : integral from P0 to P(ineg)
-  DO il = 1, ncum
-    IF (lswitch(il)) THEN
-      deltap = p0(il) - p(il, ineg(il))
-      dcin = rd*buoy(il, ineg(il))*deltap/(p(il,ineg(il))+p0(il))
-      cina(il) = cina(il) + min(0., dcin)
-    END IF
-  END DO
-
-
-  ! ------------------
-  ! -- 2.0 BUOYlcl <0.
-  ! ------------------
-
-  DO il = 1, ncum
-    lswitch1(il) = buoylcl(il) < 0. .AND. exist_lfc(il)
-    lswitch(il) = lswitch1(il)
-  END DO
-
-  ! 2.0.1 Premiere  couche ou la flotabilite est negative au dessus du sol
-  ! ----------------------------------------------------
-  ! au cas ou elle existe  sinon ilow=1 (nk apres)
-  ! on suppose que la parcelle part de la premiere couche
-
-  DO il = 1, ncum
-    IF (lswitch(il)) THEN
-      ilow(il) = 1
-    END IF
-  END DO
-
-  DO k = nl, 1, -1
-    DO il = 1, ncum
-      IF (lswitch(il) .AND. k<=icb(il)-1) THEN
-        IF (buoy(il,k)<0.) THEN
-          ilow(il) = k
-        END IF
-      END IF
-    END DO
-  END DO
-
-  ! 2.0.2  Calcul de la pression du niveau de flot. nulle sous le nuage
-  ! ----------------------------------------------------
-  DO il = 1, ncum
-    IF (lswitch(il)) THEN
-      IF (ilow(il)>1) THEN
-        p0(il) = (buoy(il,ilow(il))*p(il,ilow(il)-1)-buoy(il,ilow( &
-          il)-1)*p(il,ilow(il)))/(buoy(il,ilow(il))-buoy(il,ilow(il)-1))
-        buoyz(il) = 0.
-      ELSE
-        p0(il) = p(il, 1)
-        buoyz(il) = buoy(il, 1)
-      END IF
-    END IF
-  END DO
-
-  ! 2.1. Computation of CINB
-  ! -----------------------
-
-  DO il = 1, ncum
-    lswitch2(il) = (isublcl(il)==1 .AND. ilow(il)==1) .OR. &
-      (isublcl(il)==ilow(il)-1)
-    lswitch(il) = lswitch1(il) .AND. lswitch2(il)
-  END DO
-  ! c      IF (    (isublcl .EQ. 1 .AND. ilow .EQ. 1)
-  ! c     $    .OR.(isublcl .EQ. ilow-1)) THEN
-
-  ! 2.1.1 First case : Plcl just above P0
-  ! -------------------------------------
-  DO il = 1, ncum
-    IF (lswitch(il)) THEN
-      deltap = p0(il) - plcl(il)
-      dcin = rd*(buoyz(il)+buoylcl(il))*deltap/(p0(il)+plcl(il))
-      cinb(il) = min(0., dcin)
-    END IF
-  END DO
-
-  DO il = 1, ncum
-    lswitch(il) = lswitch1(il) .AND. .NOT. lswitch2(il)
-  END DO
-  ! c      ELSE
-
-  ! 2.1.2 Second case : there is at least one P-level between P0 and Plcl
-  ! ---------------------------------------------------------------------
-
-  ! Lower part of CINB : integral from P0 to P(ilow)
-  DO il = 1, ncum
-    IF (lswitch(il)) THEN
-      deltap = p0(il) - p(il, ilow(il))
-      dcin = rd*(buoyz(il)+buoy(il,ilow(il)))*deltap/(p0(il)+p(il,ilow(il)))
-      cinb(il) = min(0., dcin)
-    END IF
-  END DO
-
-
-  ! Middle part of CINB : integral from P(ilow) to P(isublcl)
-  ! c      DO k = ilow,isublcl-1
-  DO k = 1, nl
-    DO il = 1, ncum
-      IF (lswitch(il) .AND. k>=ilow(il) .AND. k<=isublcl(il)-1) THEN
-        deltap = p(il, k) - p(il, k+1)
-        dcin = 0.5*rd*(buoy(il,k)+buoy(il,k+1))*deltap/ph(il, k+1)
-        cinb(il) = cinb(il) + min(0., dcin)
-      END IF
-    END DO
-  END DO
-
-  ! Upper part of CINB : integral from P(isublcl) to Plcl
-  DO il = 1, ncum
-    IF (lswitch(il)) THEN
-      deltap = p(il, isublcl(il)) - plcl(il)
-      dcin = rd*(buoy(il,isublcl(il))+buoylcl(il))*deltap/ &
-        (p(il,isublcl(il))+plcl(il))
-      cinb(il) = cinb(il) + min(0., dcin)
-    END IF
-  END DO
-
-
-  ! c      ENDIF
-
-  ! 2.2 Computation of CINA
-  ! ---------------------
-
-  DO il = 1, ncum
-    lswitch2(il) = plcl(il) > p(il, itop(il)-1)
-    lswitch(il) = lswitch1(il) .AND. lswitch2(il)
-  END DO
-
-  ! 2.2.1 FIrst case : Plcl > P(itop-1)
-  ! ---------------------------------
-  ! In order to get Plfc, one may interpolate linearly buoyancies
-  ! between P(itop) and P(itop-1).
-  DO il = 1, ncum
-    IF (lswitch(il)) THEN
-      plfc(il) = (buoy(il,itop(il))*p(il,itop(il)-1)-buoy(il,itop( &
-        il)-1)*p(il,itop(il)))/(buoy(il,itop(il))-buoy(il,itop(il)-1))
-    END IF
-  END DO
-
-  ! Upper part of CINA : integral from P(itop-1) to Plfc
-  DO il = 1, ncum
-    IF (lswitch(il)) THEN
-      deltap = p(il, itop(il)-1) - plfc(il)
-      dcin = rd*buoy(il, itop(il)-1)*deltap/(p(il,itop(il)-1)+plfc(il))
-      cina(il) = min(0., dcin)
-    END IF
-  END DO
-
-  ! Middle part of CINA : integral from P(icb+1) to P(itop-1)
-  DO k = 1, nl
-    DO il = 1, ncum
-      IF (lswitch(il) .AND. k>=icb(il)+1 .AND. k<=itop(il)-2) THEN
-        deltap = p(il, k) - p(il, k+1)
-        dcin = 0.5*rd*(buoy(il,k)+buoy(il,k+1))*deltap/ph(il, k+1)
-        cina(il) = cina(il) + min(0., dcin)
-      END IF
-    END DO
-  END DO
-
-  ! Lower part of CINA : integral from Plcl to P(icb+1)
-  DO il = 1, ncum
-    IF (lswitch(il)) THEN
-      IF (plcl(il)>p(il,icb(il))) THEN
-        IF (icb(il)<itop(il)-1) THEN
-          deltap = p(il, icb(il)) - p(il, icb(il)+1)
-          dcin = 0.5*rd*(buoy(il,icb(il))+buoy(il,icb(il)+1))*deltap/ &
-            ph(il, icb(il)+1)
-          cina(il) = cina(il) + min(0., dcin)
-        END IF
-
-        deltap = plcl(il) - p(il, icb(il))
-        dcin = rd*(buoylcl(il)+buoy(il,icb(il)))*deltap/ &
-          (plcl(il)+p(il,icb(il)))
-        cina(il) = cina(il) + min(0., dcin)
-      ELSE
-        deltap = plcl(il) - p(il, icb(il)+1)
-        dcin = rd*(buoylcl(il)+buoy(il,icb(il)+1))*deltap/ &
-          (plcl(il)+p(il,icb(il)+1))
-        cina(il) = cina(il) + min(0., dcin)
-      END IF
-    END IF
-  END DO
-
-  DO il = 1, ncum
-    lswitch(il) = lswitch1(il) .AND. .NOT. lswitch2(il)
-  END DO
-  ! c      ELSE
-
-  ! 2.2.2 Second case : Plcl lies between P(itop-1) and P(itop);
-  ! ----------------------------------------------------------
-  ! In order to get Plfc, one has to interpolate between P(itop) and Plcl.
-  DO il = 1, ncum
-    IF (lswitch(il)) THEN
-      plfc(il) = (buoy(il,itop(il))*plcl(il)-buoylcl(il)*p(il,itop(il)))/ &
-        (buoy(il,itop(il))-buoylcl(il))
-    END IF
-  END DO
-
-  DO il = 1, ncum
-    IF (lswitch(il)) THEN
-      deltap = plcl(il) - plfc(il)
-      dcin = rd*buoylcl(il)*deltap/(plcl(il)+plfc(il))
-      cina(il) = min(0., dcin)
-    END IF
-  END DO
-  ! c      ENDIF
-
-
-
-  RETURN
-END SUBROUTINE cv3_cine
Index: /LMDZ6/trunk/libf/phylmd/cv3_cine.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cv3_cine.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/cv3_cine.f90	(revision 5268)
@@ -0,0 +1,461 @@
+
+! $Id$
+
+SUBROUTINE cv3_cine(nloc, ncum, nd, icb, inb, pbase, plcl, p, ph, tv, tvp, &
+    cina, cinb, plfc)
+
+  ! **************************************************************
+  ! *
+  ! CV3_CINE                                                    *
+  ! *
+  ! *
+  ! written by   :   Frederique Cheruy                          *
+  ! vectorization:   Jean-Yves Grandpeix, 19/06/2003, 11.54.43  *
+  ! modified by :                                               *
+  ! **************************************************************
+
+  IMPLICIT NONE
+
+  include "YOMCST.h"
+  include "cvthermo.h"
+  include "cv3param.h"
+  ! input:
+  INTEGER ncum, nd, nloc
+  INTEGER icb(nloc), inb(nloc)
+  REAL pbase(nloc), plcl(nloc)
+  REAL p(nloc, nd), ph(nloc, nd+1)
+  REAL tv(nloc, nd), tvp(nloc, nd)
+
+  ! output
+  REAL cina(nloc), cinb(nloc), plfc(nloc)
+
+  ! local variables
+  INTEGER il, i, j, k
+  INTEGER itop(nloc), ineg(nloc), ilow(nloc)
+  INTEGER ifst(nloc), isublcl(nloc)
+  LOGICAL lswitch(nloc), lswitch1(nloc), lswitch2(nloc), lswitch3(nloc)
+  LOGICAL exist_lfc(nloc)
+  REAL dpmax
+  REAL deltap, dcin
+  REAL buoylcl(nloc), tvplcl(nloc), tvlcl(nloc)
+  REAL p0(nloc)
+  REAL buoyz(nloc), buoy(nloc, nd)
+
+  ! -------------------------------------------------------------
+  ! Initialization
+  ! -------------------------------------------------------------
+  DO il = 1, ncum
+    cina(il) = 0.
+    cinb(il) = 0.
+  END DO
+
+  ! --------------------------------------------------------------
+  ! Recompute buoyancies
+  ! --------------------------------------------------------------
+  DO k = 1, nd
+    DO il = 1, ncum
+      ! print*,'tvp tv=',tvp(il,k),tv(il,k)
+      buoy(il, k) = tvp(il, k) - tv(il, k)
+    END DO
+  END DO
+  ! ---------------------------------------------------------------
+
+  ! calcul de la flottabilite a LCL (Buoylcl)
+  ! ifst = first P-level above lcl
+  ! isublcl = highest P-level below lcl.
+  ! ---------------------------------------------------------------
+
+  DO il = 1, ncum
+    tvplcl(il) = tvp(il, 1)*(plcl(il)/p(il,1))**(2./7.) !For dry air, R/Cp=2/7
+  END DO
+
+  DO il = 1, ncum
+    IF (plcl(il)>p(il,icb(il))) THEN
+      ifst(il) = icb(il)
+      isublcl(il) = icb(il) - 1
+    ELSE
+      ifst(il) = icb(il) + 1
+      isublcl(il) = icb(il)
+    END IF
+  END DO
+
+  DO il = 1, ncum
+    tvlcl(il) = tv(il, ifst(il)-1) + (tv(il,ifst(il))-tv(il,ifst(il)-1))*( &
+      plcl(il)-p(il,ifst(il)-1))/(p(il,ifst(il))-p(il,ifst(il)-1))
+  END DO
+
+  DO il = 1, ncum
+    buoylcl(il) = tvplcl(il) - tvlcl(il)
+  END DO
+
+  ! ---------------------------------------------------------------
+  ! premiere couche contenant un  niveau de flotabilite positive
+  ! et premiere couche contenant un  niveau de flotabilite negative
+  ! au dessus du niveau de condensation
+  ! ---------------------------------------------------------------
+  DO il = 1, ncum
+    itop(il) = nl - 1
+    ineg(il) = nl - 1
+    exist_lfc(il) = .FALSE.
+  END DO
+  DO k = nl - 1, 1, -1
+    DO il = 1, ncum
+      IF (k>=ifst(il)) THEN
+        IF (buoy(il,k)>0.) THEN
+          itop(il) = k
+          exist_lfc(il) = .TRUE.
+        ELSE
+          ineg(il) = k
+        END IF
+      END IF
+    END DO
+  END DO
+
+  ! ---------------------------------------------------------------
+  ! When there is no positive buoyancy level, set Plfc, Cina and Cinb
+  ! to arbitrary extreme values.
+  ! ---------------------------------------------------------------
+  DO il = 1, ncum
+    IF (.NOT. exist_lfc(il)) THEN
+      plfc(il) = 1.111
+      cinb(il) = -1111.
+      cina(il) = -1112.
+    END IF
+  END DO
+
+
+  ! ---------------------------------------------------------------
+  ! -- Two cases : BUOYlcl >= 0 and BUOYlcl < 0.
+  ! ---------------------------------------------------------------
+
+  ! --------------------
+  ! -- 1.0 BUOYlcl >=0.
+  ! --------------------
+
+  dpmax = 50.
+  DO il = 1, ncum
+    lswitch1(il) = buoylcl(il) >= 0. .AND. exist_lfc(il)
+    lswitch(il) = lswitch1(il)
+  END DO
+
+  ! 1.1 No inhibition case
+  ! ----------------------
+  ! If buoyancy is positive at LCL and stays positive over a large enough
+  ! pressure interval (=DPMAX), inhibition is set to zero,
+
+  DO il = 1, ncum
+    IF (lswitch(il)) THEN
+      IF (p(il,ineg(il))<p(il,icb(il))-dpmax) THEN
+        plfc(il) = plcl(il)
+        cina(il) = 0.
+        cinb(il) = 0.
+      END IF
+    END IF
+  END DO
+
+  ! 1.2 Upper inhibition only case
+  ! ------------------------------
+  DO il = 1, ncum
+    lswitch2(il) = p(il, ineg(il)) >= p(il, icb(il)) - dpmax
+    lswitch(il) = lswitch1(il) .AND. lswitch2(il)
+  END DO
+
+  ! 1.2.1 Recompute itop (=1st layer with positive buoyancy above ineg)
+  ! -------------------------------------------------------------------
+
+  DO il = 1, ncum
+    IF (lswitch(il)) THEN
+      itop(il) = nl - 1
+    END IF
+  END DO
+
+  DO k = nl, 1, -1
+    DO il = 1, ncum
+      IF (lswitch(il)) THEN
+        IF (k>=ineg(il) .AND. buoy(il,k)>0) THEN
+          itop(il) = k
+        END IF
+      END IF
+    END DO
+  END DO
+
+  ! If there is no layer with positive buoyancy above ineg, set Plfc, 
+  ! Cina and Cinb to arbitrary extreme values.
+  DO il = 1, ncum
+    IF (lswitch(il) .AND. itop(il) == nl - 1) THEN
+      plfc(il) = 1.121
+      cinb(il) = -1121.
+      cina(il) = -1122.
+    END IF
+  END DO
+
+  DO il = 1, ncum
+    lswitch3(il) = itop(il) < nl -1
+    lswitch(il) = lswitch1(il) .AND. lswitch2(il) .AND. lswitch3(il)
+  END DO
+
+  DO il = 1, ncum
+    IF (lswitch(il)) THEN
+      cinb(il) = 0.
+
+      ! 1.2.2  Calcul de la pression du niveau de flot. nulle juste au-dessus
+      ! de LCL
+      ! ---------------------------------------------------------------------------
+      IF (ineg(il)>isublcl(il)+1) THEN
+        ! In order to get P0, one may interpolate linearly buoyancies
+        ! between P(ineg) and P(ineg-1).
+        p0(il) = (buoy(il,ineg(il))*p(il,ineg(il)-1)-buoy(il,ineg(il)-1)*p(il,ineg(il)))/ &
+          (buoy(il,ineg(il))-buoy(il,ineg(il)-1))
+      ELSE
+        ! In order to get P0, one has to interpolate between P(ineg) and
+        ! Plcl.
+        p0(il) = (buoy(il,ineg(il))*plcl(il)-buoylcl(il)*p(il,ineg(il)))/ &
+          (buoy(il,ineg(il))-buoylcl(il))
+      END IF
+    END IF
+  END DO
+
+  ! 1.2.3 Computation of PLFC
+  ! -------------------------
+  DO il = 1, ncum
+    IF (lswitch(il)) THEN
+      plfc(il) = (buoy(il,itop(il))*p(il,itop(il)-1)-buoy(il,itop( &
+        il)-1)*p(il,itop(il)))/(buoy(il,itop(il))-buoy(il,itop(il)-1))
+    END IF
+  END DO
+
+  ! 1.2.4 Computation of CINA
+  ! -------------------------
+
+  ! Upper part of CINA : integral from P(itop-1) to Plfc
+  DO il = 1, ncum
+    IF (lswitch(il)) THEN
+      deltap = p(il, itop(il)-1) - plfc(il)
+      dcin = rd*buoy(il, itop(il)-1)*deltap/(p(il,itop(il)-1)+plfc(il))
+      cina(il) = min(0., dcin)
+    END IF
+  END DO
+
+  ! Middle part of CINA : integral from P(ineg) to P(itop-1)
+  DO k = 1, nl
+    DO il = 1, ncum
+      IF (lswitch(il)) THEN
+        IF (k>=ineg(il) .AND. k<=itop(il)-2) THEN
+          deltap = p(il, k) - p(il, k+1)
+          dcin = 0.5*rd*(buoy(il,k)+buoy(il,k+1))*deltap/ph(il, k+1)
+          cina(il) = cina(il) + min(0., dcin)
+        END IF
+      END IF
+    END DO
+  END DO
+
+  ! Lower part of CINA : integral from P0 to P(ineg)
+  DO il = 1, ncum
+    IF (lswitch(il)) THEN
+      deltap = p0(il) - p(il, ineg(il))
+      dcin = rd*buoy(il, ineg(il))*deltap/(p(il,ineg(il))+p0(il))
+      cina(il) = cina(il) + min(0., dcin)
+    END IF
+  END DO
+
+
+  ! ------------------
+  ! -- 2.0 BUOYlcl <0.
+  ! ------------------
+
+  DO il = 1, ncum
+    lswitch1(il) = buoylcl(il) < 0. .AND. exist_lfc(il)
+    lswitch(il) = lswitch1(il)
+  END DO
+
+  ! 2.0.1 Premiere  couche ou la flotabilite est negative au dessus du sol
+  ! ----------------------------------------------------
+  ! au cas ou elle existe  sinon ilow=1 (nk apres)
+  ! on suppose que la parcelle part de la premiere couche
+
+  DO il = 1, ncum
+    IF (lswitch(il)) THEN
+      ilow(il) = 1
+    END IF
+  END DO
+
+  DO k = nl, 1, -1
+    DO il = 1, ncum
+      IF (lswitch(il) .AND. k<=icb(il)-1) THEN
+        IF (buoy(il,k)<0.) THEN
+          ilow(il) = k
+        END IF
+      END IF
+    END DO
+  END DO
+
+  ! 2.0.2  Calcul de la pression du niveau de flot. nulle sous le nuage
+  ! ----------------------------------------------------
+  DO il = 1, ncum
+    IF (lswitch(il)) THEN
+      IF (ilow(il)>1) THEN
+        p0(il) = (buoy(il,ilow(il))*p(il,ilow(il)-1)-buoy(il,ilow( &
+          il)-1)*p(il,ilow(il)))/(buoy(il,ilow(il))-buoy(il,ilow(il)-1))
+        buoyz(il) = 0.
+      ELSE
+        p0(il) = p(il, 1)
+        buoyz(il) = buoy(il, 1)
+      END IF
+    END IF
+  END DO
+
+  ! 2.1. Computation of CINB
+  ! -----------------------
+
+  DO il = 1, ncum
+    lswitch2(il) = (isublcl(il)==1 .AND. ilow(il)==1) .OR. &
+      (isublcl(il)==ilow(il)-1)
+    lswitch(il) = lswitch1(il) .AND. lswitch2(il)
+  END DO
+  ! c      IF (    (isublcl .EQ. 1 .AND. ilow .EQ. 1)
+  ! c     $    .OR.(isublcl .EQ. ilow-1)) THEN
+
+  ! 2.1.1 First case : Plcl just above P0
+  ! -------------------------------------
+  DO il = 1, ncum
+    IF (lswitch(il)) THEN
+      deltap = p0(il) - plcl(il)
+      dcin = rd*(buoyz(il)+buoylcl(il))*deltap/(p0(il)+plcl(il))
+      cinb(il) = min(0., dcin)
+    END IF
+  END DO
+
+  DO il = 1, ncum
+    lswitch(il) = lswitch1(il) .AND. .NOT. lswitch2(il)
+  END DO
+  ! c      ELSE
+
+  ! 2.1.2 Second case : there is at least one P-level between P0 and Plcl
+  ! ---------------------------------------------------------------------
+
+  ! Lower part of CINB : integral from P0 to P(ilow)
+  DO il = 1, ncum
+    IF (lswitch(il)) THEN
+      deltap = p0(il) - p(il, ilow(il))
+      dcin = rd*(buoyz(il)+buoy(il,ilow(il)))*deltap/(p0(il)+p(il,ilow(il)))
+      cinb(il) = min(0., dcin)
+    END IF
+  END DO
+
+
+  ! Middle part of CINB : integral from P(ilow) to P(isublcl)
+  ! c      DO k = ilow,isublcl-1
+  DO k = 1, nl
+    DO il = 1, ncum
+      IF (lswitch(il) .AND. k>=ilow(il) .AND. k<=isublcl(il)-1) THEN
+        deltap = p(il, k) - p(il, k+1)
+        dcin = 0.5*rd*(buoy(il,k)+buoy(il,k+1))*deltap/ph(il, k+1)
+        cinb(il) = cinb(il) + min(0., dcin)
+      END IF
+    END DO
+  END DO
+
+  ! Upper part of CINB : integral from P(isublcl) to Plcl
+  DO il = 1, ncum
+    IF (lswitch(il)) THEN
+      deltap = p(il, isublcl(il)) - plcl(il)
+      dcin = rd*(buoy(il,isublcl(il))+buoylcl(il))*deltap/ &
+        (p(il,isublcl(il))+plcl(il))
+      cinb(il) = cinb(il) + min(0., dcin)
+    END IF
+  END DO
+
+
+  ! c      ENDIF
+
+  ! 2.2 Computation of CINA
+  ! ---------------------
+
+  DO il = 1, ncum
+    lswitch2(il) = plcl(il) > p(il, itop(il)-1)
+    lswitch(il) = lswitch1(il) .AND. lswitch2(il)
+  END DO
+
+  ! 2.2.1 FIrst case : Plcl > P(itop-1)
+  ! ---------------------------------
+  ! In order to get Plfc, one may interpolate linearly buoyancies
+  ! between P(itop) and P(itop-1).
+  DO il = 1, ncum
+    IF (lswitch(il)) THEN
+      plfc(il) = (buoy(il,itop(il))*p(il,itop(il)-1)-buoy(il,itop( &
+        il)-1)*p(il,itop(il)))/(buoy(il,itop(il))-buoy(il,itop(il)-1))
+    END IF
+  END DO
+
+  ! Upper part of CINA : integral from P(itop-1) to Plfc
+  DO il = 1, ncum
+    IF (lswitch(il)) THEN
+      deltap = p(il, itop(il)-1) - plfc(il)
+      dcin = rd*buoy(il, itop(il)-1)*deltap/(p(il,itop(il)-1)+plfc(il))
+      cina(il) = min(0., dcin)
+    END IF
+  END DO
+
+  ! Middle part of CINA : integral from P(icb+1) to P(itop-1)
+  DO k = 1, nl
+    DO il = 1, ncum
+      IF (lswitch(il) .AND. k>=icb(il)+1 .AND. k<=itop(il)-2) THEN
+        deltap = p(il, k) - p(il, k+1)
+        dcin = 0.5*rd*(buoy(il,k)+buoy(il,k+1))*deltap/ph(il, k+1)
+        cina(il) = cina(il) + min(0., dcin)
+      END IF
+    END DO
+  END DO
+
+  ! Lower part of CINA : integral from Plcl to P(icb+1)
+  DO il = 1, ncum
+    IF (lswitch(il)) THEN
+      IF (plcl(il)>p(il,icb(il))) THEN
+        IF (icb(il)<itop(il)-1) THEN
+          deltap = p(il, icb(il)) - p(il, icb(il)+1)
+          dcin = 0.5*rd*(buoy(il,icb(il))+buoy(il,icb(il)+1))*deltap/ &
+            ph(il, icb(il)+1)
+          cina(il) = cina(il) + min(0., dcin)
+        END IF
+
+        deltap = plcl(il) - p(il, icb(il))
+        dcin = rd*(buoylcl(il)+buoy(il,icb(il)))*deltap/ &
+          (plcl(il)+p(il,icb(il)))
+        cina(il) = cina(il) + min(0., dcin)
+      ELSE
+        deltap = plcl(il) - p(il, icb(il)+1)
+        dcin = rd*(buoylcl(il)+buoy(il,icb(il)+1))*deltap/ &
+          (plcl(il)+p(il,icb(il)+1))
+        cina(il) = cina(il) + min(0., dcin)
+      END IF
+    END IF
+  END DO
+
+  DO il = 1, ncum
+    lswitch(il) = lswitch1(il) .AND. .NOT. lswitch2(il)
+  END DO
+  ! c      ELSE
+
+  ! 2.2.2 Second case : Plcl lies between P(itop-1) and P(itop);
+  ! ----------------------------------------------------------
+  ! In order to get Plfc, one has to interpolate between P(itop) and Plcl.
+  DO il = 1, ncum
+    IF (lswitch(il)) THEN
+      plfc(il) = (buoy(il,itop(il))*plcl(il)-buoylcl(il)*p(il,itop(il)))/ &
+        (buoy(il,itop(il))-buoylcl(il))
+    END IF
+  END DO
+
+  DO il = 1, ncum
+    IF (lswitch(il)) THEN
+      deltap = plcl(il) - plfc(il)
+      dcin = rd*buoylcl(il)*deltap/(plcl(il)+plfc(il))
+      cina(il) = min(0., dcin)
+    END IF
+  END DO
+  ! c      ENDIF
+
+
+
+  RETURN
+END SUBROUTINE cv3_cine
Index: DZ6/trunk/libf/phylmd/cv3_crit.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cv3_crit.F90	(revision 5267)
+++ 	(revision )
@@ -1,59 +1,0 @@
-SUBROUTINE cv3_crit(nloc, ncum, nd, icb, inb, p, ph, pzero, v, threshold, &
-    kcrit, pcrit)
-  ! **************************************************************
-  ! *
-  ! CV3_CRIT   Find pressure level where vertical profile of    *
-  ! variable 'v' intersects 'threshold'              *
-  ! *
-  ! written by   : FROHWIRTH Julie, 13/08/2003, 21.55.12        *
-  ! modified by :                                               *
-  ! **************************************************************
-
-  IMPLICIT NONE
-
-  include "cv3param.h"
-
-  ! input:
-  INTEGER ncum, nd, nloc
-  INTEGER icb(nloc), inb(nloc)
-  REAL p(nloc, nd), ph(nloc, nd+1)
-  REAL pzero(nloc)
-  REAL v(nloc, nd), threshold
-
-  ! output:
-  INTEGER kcrit(nloc)
-  REAL pcrit(nloc)
-
-  ! local variables
-  INTEGER i, j, k, il
-  LOGICAL ok(nloc)
-
-  DO il = 1, ncum
-    ok(il) = .TRUE.
-    pcrit(il) = -1.
-    kcrit(il) = 0
-  END DO
-
-  DO i = 1, nl
-    DO il = 1, ncum
-      IF (i>icb(il) .AND. i<=inb(il)) THEN
-        IF (p(il,i)<=pzero(il) .AND. ok(il)) THEN
-          IF ((v(il,i)-threshold)*(v(il,i-1)-threshold)<0.) THEN
-            pcrit(il) = ((threshold-v(il,i))*p(il,i-1)-(threshold-v(il, &
-              i-1))*p(il,i))/(v(il,i-1)-v(il,i))
-            IF (pcrit(il)>pzero(il)) THEN
-              pcrit(il) = -1.
-            ELSE
-              ok(il) = .FALSE.
-              kcrit(il) = i
-              IF (pcrit(il)<ph(il,i)) kcrit(il) = kcrit(il) + 1
-            END IF
-          END IF ! end IF (v(i) ...
-        END IF ! end IF (P(i) ...
-      END IF ! end IF (icb+1 le i le inb)
-    END DO
-  END DO
-
-
-  RETURN
-END SUBROUTINE cv3_crit
Index: /LMDZ6/trunk/libf/phylmd/cv3_crit.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cv3_crit.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/cv3_crit.f90	(revision 5268)
@@ -0,0 +1,59 @@
+SUBROUTINE cv3_crit(nloc, ncum, nd, icb, inb, p, ph, pzero, v, threshold, &
+    kcrit, pcrit)
+  ! **************************************************************
+  ! *
+  ! CV3_CRIT   Find pressure level where vertical profile of    *
+  ! variable 'v' intersects 'threshold'              *
+  ! *
+  ! written by   : FROHWIRTH Julie, 13/08/2003, 21.55.12        *
+  ! modified by :                                               *
+  ! **************************************************************
+
+  IMPLICIT NONE
+
+  include "cv3param.h"
+
+  ! input:
+  INTEGER ncum, nd, nloc
+  INTEGER icb(nloc), inb(nloc)
+  REAL p(nloc, nd), ph(nloc, nd+1)
+  REAL pzero(nloc)
+  REAL v(nloc, nd), threshold
+
+  ! output:
+  INTEGER kcrit(nloc)
+  REAL pcrit(nloc)
+
+  ! local variables
+  INTEGER i, j, k, il
+  LOGICAL ok(nloc)
+
+  DO il = 1, ncum
+    ok(il) = .TRUE.
+    pcrit(il) = -1.
+    kcrit(il) = 0
+  END DO
+
+  DO i = 1, nl
+    DO il = 1, ncum
+      IF (i>icb(il) .AND. i<=inb(il)) THEN
+        IF (p(il,i)<=pzero(il) .AND. ok(il)) THEN
+          IF ((v(il,i)-threshold)*(v(il,i-1)-threshold)<0.) THEN
+            pcrit(il) = ((threshold-v(il,i))*p(il,i-1)-(threshold-v(il, &
+              i-1))*p(il,i))/(v(il,i-1)-v(il,i))
+            IF (pcrit(il)>pzero(il)) THEN
+              pcrit(il) = -1.
+            ELSE
+              ok(il) = .FALSE.
+              kcrit(il) = i
+              IF (pcrit(il)<ph(il,i)) kcrit(il) = kcrit(il) + 1
+            END IF
+          END IF ! end IF (v(i) ...
+        END IF ! end IF (P(i) ...
+      END IF ! end IF (icb+1 le i le inb)
+    END DO
+  END DO
+
+
+  RETURN
+END SUBROUTINE cv3_crit
Index: DZ6/trunk/libf/phylmd/cv3_enthalpmix.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cv3_enthalpmix.F90	(revision 5267)
+++ 	(revision )
@@ -1,215 +1,0 @@
-SUBROUTINE cv3_enthalpmix(len, nd, iflag, plim1, plim2, p, ph, &
-                       t, q, u, v, w, &
-                       wi, nk, tmix, thmix, qmix, qsmix, umix, vmix, plcl)
-  ! **************************************************************
-  ! *
-  ! CV3_ENTHALPMIX   Brassage adiabatique d'une couche d'epaisseur *
-  ! arbitraire.                                   *
-  ! *
-  ! written by   : Grandpeix Jean-Yves, 28/12/2001, 13.14.24    *
-  ! modified by :  Filiberti M-A 06/2005 vectorisation          *
-  ! **************************************************************
-
-  IMPLICIT NONE
-  ! ==============================================================
-
-  ! vertmix : determines theta, t, q, qs, u and v of the mixture generated by
-  ! adiabatic mixing of air between plim1 and plim2 with weighting w.
-  ! If plim1 and plim2 fall within the same model layer, then theta, ... v
-  ! are those of that layer.
-  ! A minimum value (dpmin) is imposed upon plim1-plim2
-
-  ! ===============================================================
-
-  include "cvthermo.h"
-  include "YOETHF.h"
-  include "YOMCST.h"
-  include "FCTTRE.h"
-!inputs:
-  INTEGER, INTENT (IN)                      :: nd, len
-  INTEGER, DIMENSION (len), INTENT (IN)     :: nk
-  REAL, DIMENSION (len), INTENT (IN)        :: plim1, plim2
-  REAL, DIMENSION (len,nd), INTENT (IN)     :: t, q
-  REAL, DIMENSION (len,nd), INTENT (IN)     :: u, v
-  REAL, DIMENSION (nd), INTENT (IN)         :: w
-  REAL, DIMENSION (len,nd), INTENT (IN)     :: p
-  REAL, DIMENSION (len,nd+1), INTENT (IN)   :: ph
-!input/output:
-  INTEGER, DIMENSION (len), INTENT (INOUT)  ::  iflag
-!outputs:
-  REAL, DIMENSION (len), INTENT (OUT)       :: tmix, thmix, qmix
-  REAL, DIMENSION (len), INTENT (OUT)       :: umix, vmix
-  REAL, DIMENSION (len), INTENT (OUT)       :: qsmix
-  REAL, DIMENSION (len), INTENT (OUT)       :: plcl
-  REAL, DIMENSION (len,nd), INTENT (OUT)    :: wi
-!internal variables :
-  INTEGER i, j
-  INTEGER niflag7
-  INTEGER, DIMENSION(len)                   :: j1, j2
-  REAL                                      :: a, b
-  REAL                                      :: cpn
-  REAL                                      :: x, y, p0, p0m1, zdelta, zcor
-  REAL, SAVE                                :: dpmin=1.
-!$OMP THREADPRIVATE(dpmin)
-  REAL, DIMENSION(len)                      :: plim2p  ! = min(plim2(:),plim1(:)-dpmin)
-  REAL, DIMENSION(len)                      :: akm     ! mixture enthalpy
-  REAL, DIMENSION(len)                      :: dpw, coef
-  REAL, DIMENSION(len)                      :: rdcp, a2, b2, pnk
-  REAL, DIMENSION(len)                      :: rh, chi
-  REAL, DIMENSION(len)                      :: eqwght
-  REAL, DIMENSION(len,nd)                   :: p1, p2
-
-
-!!  print *,' ->cv3_vertmix, plim1,plim2 ', plim1,plim2   !jyg
-  plim2p(:) = min(plim2(:),plim1(:)-dpmin)
-  j1(:)=nd
-  j2(:) = 0
-  DO j = 1, nd
-    DO i = 1, len
-      IF (plim1(i)<=ph(i,j)) j1(i) = j
-!!!      IF (plim2p(i)>=ph(i,j+1) .AND. plim2p(i)<ph(i,j)) j2(i) = j
-      IF (plim2p(i)< ph(i,j)) j2(i) = j
-    END DO
-  END DO
-
-  DO j = 1, nd
-    DO i = 1, len
-      wi(i, j) = 0.
-    END DO
-  END DO
-  DO i = 1, len
-    akm(i) = 0.
-    qmix(i) = 0.
-    umix(i) = 0.
-    vmix(i) = 0.
-    dpw(i) = 0.
-    a2(i) = 0.0
-    b2(i) = 0.
-    pnk(i) = p(i, nk(i))
-  END DO
-  eqwght(:) = 0.
-
-  p0 = 1000.
-  p0m1 = 1./p0
-
-  DO i = 1, len
-    IF (j2(i) < j1(i)) THEN
-      coef(i) = 1.
-      eqwght(i) = 1.
-    ELSE
-      coef(i) = 1./(plim1(i)-plim2p(i))
-    ENDIF
-  END DO
-
-!!  print *,'cv3_vertmix, j1,j2,coef ', j1,j2,coef  !jyg
-
-  DO j = 1, nd
-    DO i = 1, len
-      IF (j>=j1(i) .AND. j<=j2(i)) THEN
-        p1(i, j) = min(ph(i,j), plim1(i))
-        p2(i, j) = max(ph(i,j+1), plim2p(i))
-        ! CRtest:couplage thermiques: deja normalise
-        ! wi(i,j) = w(j)
-        ! print*,'wi',wi(i,j)
-        wi(i, j) = w(j)*(p1(i,j)-p2(i,j))*coef(i)+eqwght(i)
-        dpw(i) = dpw(i) + wi(i, j)
-
-!!  print *,'cv3_vertmix, j, wi(1,j),dpw ', j, wi(1,j),dpw  !jyg
-
-      END IF
-    END DO
-  END DO
-
-  ! CR:print
-  ! do i=1,len
-  ! print*,'plim',plim1(i),plim2p(i)
-  ! enddo
-  DO j = 1, nd
-    DO i = 1, len
-      IF (j>=j1(i) .AND. j<=j2(i)) THEN
-        wi(i, j) = wi(i, j)/dpw(i)
-        akm(i) = akm(i) + (cpd*(1.-q(i,j))+q(i,j)*cpv)*t(i, j)*wi(i, j)
-        qmix(i) = qmix(i) + q(i, j)*wi(i, j)
-        umix(i) = umix(i) + u(i, j)*wi(i, j)
-        vmix(i) = vmix(i) + v(i, j)*wi(i, j)
-      END IF
-    END DO
-  END DO
-
-  DO i = 1, len
-    rdcp(i) = (rrd*(1.-qmix(i))+qmix(i)*rrv)/(cpd*(1.-qmix(i))+qmix(i)*cpv)
-  END DO
-
-
-!!  print *,'cv3_vertmix, rdcp ', rdcp  !jyg
-
-
-
-  DO j = 1, nd
-    DO i = 1, len
-      IF (j>=j1(i) .AND. j<=j2(i)) THEN
-        ! c            x=(.5*(p1(i,j)+p2(i,j))*p0m1)**rdcp(i)
-        y = (.5*(p1(i,j)+p2(i,j))/pnk(i))**rdcp(i)
-        ! c            a2(i)=a2(i)+(cpd*(1.-qmix(i))+qmix(i)*cpv)*x*wi(i,j)
-        b2(i) = b2(i) + (cpd*(1.-qmix(i))+qmix(i)*cpv)*y*wi(i, j)
-      END IF
-    END DO
-  END DO
-
-  DO i = 1, len
-    tmix(i) = akm(i)/b2(i)
-    thmix(i) = tmix(i)*(p0/pnk(i))**rdcp(i)
-    ! print*,'thmix akm',akm(i),b2(i)
-    ! print*,'thmix t',tmix(i),p0
-    ! print*,'thmix p',pnk(i),rdcp(i)
-    ! print*,'thmix',thmix(i)
-    ! c         thmix(i) = akm(i)/a2(i)
-    ! c         tmix(i)= thmix(i)*(pnk(i)*p0m1)**rdcp(i)
-    zdelta = max(0., sign(1.,rtt-tmix(i)))
-    qsmix(i) = r2es*foeew(tmix(i), zdelta)/(pnk(i)*100.)
-    qsmix(i) = min(0.5, qsmix(i))
-    zcor = 1./(1.-retv*qsmix(i))
-    qsmix(i) = qsmix(i)*zcor
-  END DO
-
-  ! -------------------------------------------------------------------
-  ! --- Calculate lifted condensation level of air at parcel origin level
-  ! --- (Within 0.2% of formula of Bolton, MON. WEA. REV.,1980)
-  ! -------------------------------------------------------------------
-
-  a = 1669.0 ! convect3
-  b = 122.0 ! convect3
-
-
-  niflag7 = 0
-  DO i = 1, len
-
-    IF (iflag(i)/=7) THEN ! modif sb Jun7th 2002
-
-      rh(i) = qmix(i)/qsmix(i)
-      chi(i) = tmix(i)/(a-b*rh(i)-tmix(i)) ! convect3
-      ! ATTENTION, la LIGNE DESSOUS A ETE RAJOUTEE ARBITRAIREMENT ET
-      ! MASQUE UN PB POTENTIEL
-      chi(i) = max(chi(i), 0.)
-      rh(i) = max(rh(i), 0.)
-      plcl(i) = pnk(i)*(rh(i)**chi(i))
-      IF (((plcl(i)<200.0) .OR. (plcl(i)>=2000.0)) .AND. (iflag(i)==0)) &
-          iflag(i) = 8
-
-    ELSE
-
-      niflag7 = niflag7 + 1
-      plcl(i) = plim2p(i)
-
-    END IF ! iflag=7
-
-    ! print*,'NIFLAG7  =',niflag7
-
-  END DO
-
-!!  print *,' cv3_vertmix->'  !jyg
-
-
-  RETURN
-END SUBROUTINE cv3_enthalpmix
-
Index: /LMDZ6/trunk/libf/phylmd/cv3_enthalpmix.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cv3_enthalpmix.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/cv3_enthalpmix.f90	(revision 5268)
@@ -0,0 +1,215 @@
+SUBROUTINE cv3_enthalpmix(len, nd, iflag, plim1, plim2, p, ph, &
+                       t, q, u, v, w, &
+                       wi, nk, tmix, thmix, qmix, qsmix, umix, vmix, plcl)
+  ! **************************************************************
+  ! *
+  ! CV3_ENTHALPMIX   Brassage adiabatique d'une couche d'epaisseur *
+  ! arbitraire.                                   *
+  ! *
+  ! written by   : Grandpeix Jean-Yves, 28/12/2001, 13.14.24    *
+  ! modified by :  Filiberti M-A 06/2005 vectorisation          *
+  ! **************************************************************
+
+  IMPLICIT NONE
+  ! ==============================================================
+
+  ! vertmix : determines theta, t, q, qs, u and v of the mixture generated by
+  ! adiabatic mixing of air between plim1 and plim2 with weighting w.
+  ! If plim1 and plim2 fall within the same model layer, then theta, ... v
+  ! are those of that layer.
+  ! A minimum value (dpmin) is imposed upon plim1-plim2
+
+  ! ===============================================================
+
+  include "cvthermo.h"
+  include "YOETHF.h"
+  include "YOMCST.h"
+  include "FCTTRE.h"
+!inputs:
+  INTEGER, INTENT (IN)                      :: nd, len
+  INTEGER, DIMENSION (len), INTENT (IN)     :: nk
+  REAL, DIMENSION (len), INTENT (IN)        :: plim1, plim2
+  REAL, DIMENSION (len,nd), INTENT (IN)     :: t, q
+  REAL, DIMENSION (len,nd), INTENT (IN)     :: u, v
+  REAL, DIMENSION (nd), INTENT (IN)         :: w
+  REAL, DIMENSION (len,nd), INTENT (IN)     :: p
+  REAL, DIMENSION (len,nd+1), INTENT (IN)   :: ph
+!input/output:
+  INTEGER, DIMENSION (len), INTENT (INOUT)  ::  iflag
+!outputs:
+  REAL, DIMENSION (len), INTENT (OUT)       :: tmix, thmix, qmix
+  REAL, DIMENSION (len), INTENT (OUT)       :: umix, vmix
+  REAL, DIMENSION (len), INTENT (OUT)       :: qsmix
+  REAL, DIMENSION (len), INTENT (OUT)       :: plcl
+  REAL, DIMENSION (len,nd), INTENT (OUT)    :: wi
+!internal variables :
+  INTEGER i, j
+  INTEGER niflag7
+  INTEGER, DIMENSION(len)                   :: j1, j2
+  REAL                                      :: a, b
+  REAL                                      :: cpn
+  REAL                                      :: x, y, p0, p0m1, zdelta, zcor
+  REAL, SAVE                                :: dpmin=1.
+!$OMP THREADPRIVATE(dpmin)
+  REAL, DIMENSION(len)                      :: plim2p  ! = min(plim2(:),plim1(:)-dpmin)
+  REAL, DIMENSION(len)                      :: akm     ! mixture enthalpy
+  REAL, DIMENSION(len)                      :: dpw, coef
+  REAL, DIMENSION(len)                      :: rdcp, a2, b2, pnk
+  REAL, DIMENSION(len)                      :: rh, chi
+  REAL, DIMENSION(len)                      :: eqwght
+  REAL, DIMENSION(len,nd)                   :: p1, p2
+
+
+!!  print *,' ->cv3_vertmix, plim1,plim2 ', plim1,plim2   !jyg
+  plim2p(:) = min(plim2(:),plim1(:)-dpmin)
+  j1(:)=nd
+  j2(:) = 0
+  DO j = 1, nd
+    DO i = 1, len
+      IF (plim1(i)<=ph(i,j)) j1(i) = j
+!!!      IF (plim2p(i)>=ph(i,j+1) .AND. plim2p(i)<ph(i,j)) j2(i) = j
+      IF (plim2p(i)< ph(i,j)) j2(i) = j
+    END DO
+  END DO
+
+  DO j = 1, nd
+    DO i = 1, len
+      wi(i, j) = 0.
+    END DO
+  END DO
+  DO i = 1, len
+    akm(i) = 0.
+    qmix(i) = 0.
+    umix(i) = 0.
+    vmix(i) = 0.
+    dpw(i) = 0.
+    a2(i) = 0.0
+    b2(i) = 0.
+    pnk(i) = p(i, nk(i))
+  END DO
+  eqwght(:) = 0.
+
+  p0 = 1000.
+  p0m1 = 1./p0
+
+  DO i = 1, len
+    IF (j2(i) < j1(i)) THEN
+      coef(i) = 1.
+      eqwght(i) = 1.
+    ELSE
+      coef(i) = 1./(plim1(i)-plim2p(i))
+    ENDIF
+  END DO
+
+!!  print *,'cv3_vertmix, j1,j2,coef ', j1,j2,coef  !jyg
+
+  DO j = 1, nd
+    DO i = 1, len
+      IF (j>=j1(i) .AND. j<=j2(i)) THEN
+        p1(i, j) = min(ph(i,j), plim1(i))
+        p2(i, j) = max(ph(i,j+1), plim2p(i))
+        ! CRtest:couplage thermiques: deja normalise
+        ! wi(i,j) = w(j)
+        ! print*,'wi',wi(i,j)
+        wi(i, j) = w(j)*(p1(i,j)-p2(i,j))*coef(i)+eqwght(i)
+        dpw(i) = dpw(i) + wi(i, j)
+
+!!  print *,'cv3_vertmix, j, wi(1,j),dpw ', j, wi(1,j),dpw  !jyg
+
+      END IF
+    END DO
+  END DO
+
+  ! CR:print
+  ! do i=1,len
+  ! print*,'plim',plim1(i),plim2p(i)
+  ! enddo
+  DO j = 1, nd
+    DO i = 1, len
+      IF (j>=j1(i) .AND. j<=j2(i)) THEN
+        wi(i, j) = wi(i, j)/dpw(i)
+        akm(i) = akm(i) + (cpd*(1.-q(i,j))+q(i,j)*cpv)*t(i, j)*wi(i, j)
+        qmix(i) = qmix(i) + q(i, j)*wi(i, j)
+        umix(i) = umix(i) + u(i, j)*wi(i, j)
+        vmix(i) = vmix(i) + v(i, j)*wi(i, j)
+      END IF
+    END DO
+  END DO
+
+  DO i = 1, len
+    rdcp(i) = (rrd*(1.-qmix(i))+qmix(i)*rrv)/(cpd*(1.-qmix(i))+qmix(i)*cpv)
+  END DO
+
+
+!!  print *,'cv3_vertmix, rdcp ', rdcp  !jyg
+
+
+
+  DO j = 1, nd
+    DO i = 1, len
+      IF (j>=j1(i) .AND. j<=j2(i)) THEN
+        ! c            x=(.5*(p1(i,j)+p2(i,j))*p0m1)**rdcp(i)
+        y = (.5*(p1(i,j)+p2(i,j))/pnk(i))**rdcp(i)
+        ! c            a2(i)=a2(i)+(cpd*(1.-qmix(i))+qmix(i)*cpv)*x*wi(i,j)
+        b2(i) = b2(i) + (cpd*(1.-qmix(i))+qmix(i)*cpv)*y*wi(i, j)
+      END IF
+    END DO
+  END DO
+
+  DO i = 1, len
+    tmix(i) = akm(i)/b2(i)
+    thmix(i) = tmix(i)*(p0/pnk(i))**rdcp(i)
+    ! print*,'thmix akm',akm(i),b2(i)
+    ! print*,'thmix t',tmix(i),p0
+    ! print*,'thmix p',pnk(i),rdcp(i)
+    ! print*,'thmix',thmix(i)
+    ! c         thmix(i) = akm(i)/a2(i)
+    ! c         tmix(i)= thmix(i)*(pnk(i)*p0m1)**rdcp(i)
+    zdelta = max(0., sign(1.,rtt-tmix(i)))
+    qsmix(i) = r2es*foeew(tmix(i), zdelta)/(pnk(i)*100.)
+    qsmix(i) = min(0.5, qsmix(i))
+    zcor = 1./(1.-retv*qsmix(i))
+    qsmix(i) = qsmix(i)*zcor
+  END DO
+
+  ! -------------------------------------------------------------------
+  ! --- Calculate lifted condensation level of air at parcel origin level
+  ! --- (Within 0.2% of formula of Bolton, MON. WEA. REV.,1980)
+  ! -------------------------------------------------------------------
+
+  a = 1669.0 ! convect3
+  b = 122.0 ! convect3
+
+
+  niflag7 = 0
+  DO i = 1, len
+
+    IF (iflag(i)/=7) THEN ! modif sb Jun7th 2002
+
+      rh(i) = qmix(i)/qsmix(i)
+      chi(i) = tmix(i)/(a-b*rh(i)-tmix(i)) ! convect3
+      ! ATTENTION, la LIGNE DESSOUS A ETE RAJOUTEE ARBITRAIREMENT ET
+      ! MASQUE UN PB POTENTIEL
+      chi(i) = max(chi(i), 0.)
+      rh(i) = max(rh(i), 0.)
+      plcl(i) = pnk(i)*(rh(i)**chi(i))
+      IF (((plcl(i)<200.0) .OR. (plcl(i)>=2000.0)) .AND. (iflag(i)==0)) &
+          iflag(i) = 8
+
+    ELSE
+
+      niflag7 = niflag7 + 1
+      plcl(i) = plim2p(i)
+
+    END IF ! iflag=7
+
+    ! print*,'NIFLAG7  =',niflag7
+
+  END DO
+
+!!  print *,' cv3_vertmix->'  !jyg
+
+
+  RETURN
+END SUBROUTINE cv3_enthalpmix
+
Index: DZ6/trunk/libf/phylmd/cv3_estatmix.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cv3_estatmix.F90	(revision 5267)
+++ 	(revision )
@@ -1,198 +1,0 @@
-SUBROUTINE cv3_estatmix(len, nd, iflag, plim1, plim2, p, ph, &
-                       t, q, u, v, h, gz, w, &
-                       wi, nk, tmix, thmix, qmix, qsmix, umix, vmix, plcl)
-  ! **************************************************************
-  ! *
-  ! CV3_ESTATMIX  Determine the properties of an adiabatic updraft  *
-  !                made of air coming from several layers by        *
-  !                mixing static energy                             *
-  !                                                                 *
-  ! written by   : Grandpeix Jean-Yves, 28/12/2001, 13.14.24        *
-  ! modified by :  Filiberti M-A 06/2005 vectorisation              *
-  ! ****************************************************************
-
-  IMPLICIT NONE
-  ! ==============================================================
-
-  ! estatmix : determines theta, t, q, qs, u and v of the lifted mixture
-  ! made of air between plim1 and plim2 with weighting w.
-  ! If plim1 and plim2 fall within the same model layer, then theta, ... v
-  ! are those of that layer.
-  ! A minimum value (dpmin) is imposed upon plim1-plim2
-
-  ! ===============================================================
-
-  include "cvthermo.h"
-  include "YOETHF.h"
-  include "YOMCST.h"
-  include "FCTTRE.h"
-!inputs:
-  INTEGER, INTENT (IN)                      :: nd, len
-  INTEGER, DIMENSION (len), INTENT (IN)     :: nk
-  REAL, DIMENSION (len), INTENT (IN)        :: plim1, plim2
-  REAL, DIMENSION (len,nd), INTENT (IN)     :: t, q
-  REAL, DIMENSION (len,nd), INTENT (IN)     :: u, v
-  REAL, DIMENSION (len,nd), INTENT (IN)     :: h ! static energy of the layers
-  REAL, DIMENSION (len,nd), INTENT (IN)     :: gz
-  REAL, DIMENSION (nd), INTENT (IN)         :: w
-  REAL, DIMENSION (len,nd), INTENT (IN)     :: p
-  REAL, DIMENSION (len,nd+1), INTENT (IN)   :: ph
-!input/output:
-  INTEGER, DIMENSION (len), INTENT (INOUT)  ::  iflag
-!outputs:
-  REAL, DIMENSION (len), INTENT (OUT)       :: tmix, thmix, qmix
-  REAL, DIMENSION (len), INTENT (OUT)       :: umix, vmix
-  REAL, DIMENSION (len), INTENT (OUT)       :: qsmix
-  REAL, DIMENSION (len), INTENT (OUT)       :: plcl
-  REAL, DIMENSION (len,nd), INTENT (OUT)    :: wi
-!internal variables :
-  INTEGER i, j
-  INTEGER niflag7
-  INTEGER, DIMENSION(len)                   :: j1, j2
-  REAL                                      :: a, b
-  REAL                                      :: cpn
-  REAL                                      :: x, y, p0, zdelta, zcor
-  REAL, SAVE                                :: dpmin=1.
-!$OMP THREADPRIVATE(dpmin)
-  REAL, DIMENSION(len)                      :: plim2p  ! = min(plim2(:),plim1(:)-dpmin)
-  REAL, DIMENSION(len)                      :: dpw, coef
-  REAL, DIMENSION(len)                      :: hmix ! static energy of the updraft
-  REAL, DIMENSION(len)                      :: rdcp, pnk
-  REAL, DIMENSION(len)                      :: rh, chi
-  REAL, DIMENSION(len)                      :: eqwght
-  REAL, DIMENSION(len,nd)                   :: p1, p2
-
-
-!!  print *,' ->cv3_vertmix, plim1,plim2 ', plim1,plim2   !jyg
-  plim2p(:) = min(plim2(:),plim1(:)-dpmin)
-  j1(:)=nd
-  j2(:) = 0
-  DO j = 1, nd
-    DO i = 1, len
-      IF (plim1(i)<=ph(i,j)) j1(i) = j
-!!!      IF (plim2p(i)>=ph(i,j+1) .AND. plim2p(i)<ph(i,j)) j2(i) = j
-      IF (plim2p(i)< ph(i,j)) j2(i) = j
-    END DO
-  END DO
-
-  DO j = 1, nd
-    DO i = 1, len
-      wi(i, j) = 0.
-    END DO
-  END DO
-  DO i = 1, len
-    hmix(i) = 0.
-    qmix(i) = 0.
-    umix(i) = 0.
-    vmix(i) = 0.
-    dpw(i) = 0.
-    pnk(i) = p(i, nk(i))
-  END DO
-  eqwght(:) = 0.
-
-  p0 = 1000.
-
-  DO i = 1, len
-    IF (j2(i) < j1(i)) THEN
-      coef(i) = 1.
-      eqwght(i) = 1.
-    ELSE
-      coef(i) = 1./(plim1(i)-plim2p(i))
-    ENDIF
-  END DO
-
-!!  print *,'cv3_vertmix, j1,j2,coef ', j1,j2,coef  !jyg
-
-  DO j = 1, nd
-    DO i = 1, len
-      IF (j>=j1(i) .AND. j<=j2(i)) THEN
-        p1(i, j) = min(ph(i,j), plim1(i))
-        p2(i, j) = max(ph(i,j+1), plim2p(i))
-        ! CRtest:couplage thermiques: deja normalise
-        ! wi(i,j) = w(j)
-        ! print*,'wi',wi(i,j)
-        wi(i, j) = w(j)*(p1(i,j)-p2(i,j))*coef(i)+eqwght(i)
-        dpw(i) = dpw(i) + wi(i, j)
-
-!!  print *,'cv3_vertmix, j, wi(1,j),dpw ', j, wi(1,j),dpw  !jyg
-
-      END IF
-    END DO
-  END DO
-
-  ! CR:print
-  ! do i=1,len
-  ! print*,'plim',plim1(i),plim2p(i)
-  ! enddo
-  DO j = 1, nd
-    DO i = 1, len
-      IF (j>=j1(i) .AND. j<=j2(i)) THEN
-        wi(i, j) = wi(i, j)/dpw(i)
-        hmix(i) = hmix(i) + h(i, j)*wi(i, j)
-        qmix(i) = qmix(i) +  q(i, j)*wi(i, j)
-        umix(i) = umix(i) +  u(i, j)*wi(i, j)
-        vmix(i) = vmix(i) +  v(i, j)*wi(i, j)
-      END IF
-    END DO
-  END DO
-
-  DO i = 1, len
-    rdcp(i) = (rrd*(1.-qmix(i))+qmix(i)*rrv)/(cpd*(1.-qmix(i))+qmix(i)*cpv)
-  END DO
-
-
-!!  print *,'cv3_vertmix, rdcp ', rdcp  !jyg
-
-  DO i = 1, len
-    tmix(i) = (hmix(i) - gz(i,1))/(cpd*(1.-qmix(i)) + qmix(i)*cpv)
-    !      (Use of Cpv since we are dealing with dry static energy)
-    thmix(i) = tmix(i)*(p0/pnk(i))**rdcp(i)
-    ! print*,'tmix thmix hmix ',tmix(i),thmix(i),hmix(i)
-    zdelta = max(0., sign(1.,rtt-tmix(i)))
-    qsmix(i) = r2es*foeew(tmix(i), zdelta)/(pnk(i)*100.)
-    qsmix(i) = min(0.5, qsmix(i))
-    zcor = 1./(1.-retv*qsmix(i))
-    qsmix(i) = qsmix(i)*zcor
-  END DO
-
-  ! -------------------------------------------------------------------
-  ! --- Calculate lifted condensation level of air at parcel origin level
-  ! --- (Within 0.2% of formula of Bolton, MON. WEA. REV.,1980)
-  ! -------------------------------------------------------------------
-
-  a = 1669.0 ! convect3
-  b = 122.0 ! convect3
-
-
-  niflag7 = 0
-  DO i = 1, len
-
-    IF (iflag(i)/=7) THEN ! modif sb Jun7th 2002
-
-      rh(i) = qmix(i)/qsmix(i)
-      chi(i) = tmix(i)/(a-b*rh(i)-tmix(i)) ! convect3
-      ! ATTENTION, la LIGNE DESSOUS A ETE RAJOUTEE ARBITRAIREMENT ET
-      ! MASQUE UN PB POTENTIEL
-      chi(i) = max(chi(i), 0.)
-      rh(i) = max(rh(i), 0.)
-      plcl(i) = pnk(i)*(rh(i)**chi(i))
-      IF (((plcl(i)<200.0) .OR. (plcl(i)>=2000.0)) .AND. (iflag(i)==0)) &
-          iflag(i) = 8
-
-    ELSE
-
-      niflag7 = niflag7 + 1
-      plcl(i) = plim2p(i)
-
-    END IF ! iflag=7
-
-    ! print*,'NIFLAG7  =',niflag7
-
-  END DO
-
-!!  print *,' cv3_vertmix->'  !jyg
-
-
-  RETURN
-END SUBROUTINE cv3_estatmix
-
Index: /LMDZ6/trunk/libf/phylmd/cv3_estatmix.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cv3_estatmix.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/cv3_estatmix.f90	(revision 5268)
@@ -0,0 +1,198 @@
+SUBROUTINE cv3_estatmix(len, nd, iflag, plim1, plim2, p, ph, &
+                       t, q, u, v, h, gz, w, &
+                       wi, nk, tmix, thmix, qmix, qsmix, umix, vmix, plcl)
+  ! **************************************************************
+  ! *
+  ! CV3_ESTATMIX  Determine the properties of an adiabatic updraft  *
+  !                made of air coming from several layers by        *
+  !                mixing static energy                             *
+  !                                                                 *
+  ! written by   : Grandpeix Jean-Yves, 28/12/2001, 13.14.24        *
+  ! modified by :  Filiberti M-A 06/2005 vectorisation              *
+  ! ****************************************************************
+
+  IMPLICIT NONE
+  ! ==============================================================
+
+  ! estatmix : determines theta, t, q, qs, u and v of the lifted mixture
+  ! made of air between plim1 and plim2 with weighting w.
+  ! If plim1 and plim2 fall within the same model layer, then theta, ... v
+  ! are those of that layer.
+  ! A minimum value (dpmin) is imposed upon plim1-plim2
+
+  ! ===============================================================
+
+  include "cvthermo.h"
+  include "YOETHF.h"
+  include "YOMCST.h"
+  include "FCTTRE.h"
+!inputs:
+  INTEGER, INTENT (IN)                      :: nd, len
+  INTEGER, DIMENSION (len), INTENT (IN)     :: nk
+  REAL, DIMENSION (len), INTENT (IN)        :: plim1, plim2
+  REAL, DIMENSION (len,nd), INTENT (IN)     :: t, q
+  REAL, DIMENSION (len,nd), INTENT (IN)     :: u, v
+  REAL, DIMENSION (len,nd), INTENT (IN)     :: h ! static energy of the layers
+  REAL, DIMENSION (len,nd), INTENT (IN)     :: gz
+  REAL, DIMENSION (nd), INTENT (IN)         :: w
+  REAL, DIMENSION (len,nd), INTENT (IN)     :: p
+  REAL, DIMENSION (len,nd+1), INTENT (IN)   :: ph
+!input/output:
+  INTEGER, DIMENSION (len), INTENT (INOUT)  ::  iflag
+!outputs:
+  REAL, DIMENSION (len), INTENT (OUT)       :: tmix, thmix, qmix
+  REAL, DIMENSION (len), INTENT (OUT)       :: umix, vmix
+  REAL, DIMENSION (len), INTENT (OUT)       :: qsmix
+  REAL, DIMENSION (len), INTENT (OUT)       :: plcl
+  REAL, DIMENSION (len,nd), INTENT (OUT)    :: wi
+!internal variables :
+  INTEGER i, j
+  INTEGER niflag7
+  INTEGER, DIMENSION(len)                   :: j1, j2
+  REAL                                      :: a, b
+  REAL                                      :: cpn
+  REAL                                      :: x, y, p0, zdelta, zcor
+  REAL, SAVE                                :: dpmin=1.
+!$OMP THREADPRIVATE(dpmin)
+  REAL, DIMENSION(len)                      :: plim2p  ! = min(plim2(:),plim1(:)-dpmin)
+  REAL, DIMENSION(len)                      :: dpw, coef
+  REAL, DIMENSION(len)                      :: hmix ! static energy of the updraft
+  REAL, DIMENSION(len)                      :: rdcp, pnk
+  REAL, DIMENSION(len)                      :: rh, chi
+  REAL, DIMENSION(len)                      :: eqwght
+  REAL, DIMENSION(len,nd)                   :: p1, p2
+
+
+!!  print *,' ->cv3_vertmix, plim1,plim2 ', plim1,plim2   !jyg
+  plim2p(:) = min(plim2(:),plim1(:)-dpmin)
+  j1(:)=nd
+  j2(:) = 0
+  DO j = 1, nd
+    DO i = 1, len
+      IF (plim1(i)<=ph(i,j)) j1(i) = j
+!!!      IF (plim2p(i)>=ph(i,j+1) .AND. plim2p(i)<ph(i,j)) j2(i) = j
+      IF (plim2p(i)< ph(i,j)) j2(i) = j
+    END DO
+  END DO
+
+  DO j = 1, nd
+    DO i = 1, len
+      wi(i, j) = 0.
+    END DO
+  END DO
+  DO i = 1, len
+    hmix(i) = 0.
+    qmix(i) = 0.
+    umix(i) = 0.
+    vmix(i) = 0.
+    dpw(i) = 0.
+    pnk(i) = p(i, nk(i))
+  END DO
+  eqwght(:) = 0.
+
+  p0 = 1000.
+
+  DO i = 1, len
+    IF (j2(i) < j1(i)) THEN
+      coef(i) = 1.
+      eqwght(i) = 1.
+    ELSE
+      coef(i) = 1./(plim1(i)-plim2p(i))
+    ENDIF
+  END DO
+
+!!  print *,'cv3_vertmix, j1,j2,coef ', j1,j2,coef  !jyg
+
+  DO j = 1, nd
+    DO i = 1, len
+      IF (j>=j1(i) .AND. j<=j2(i)) THEN
+        p1(i, j) = min(ph(i,j), plim1(i))
+        p2(i, j) = max(ph(i,j+1), plim2p(i))
+        ! CRtest:couplage thermiques: deja normalise
+        ! wi(i,j) = w(j)
+        ! print*,'wi',wi(i,j)
+        wi(i, j) = w(j)*(p1(i,j)-p2(i,j))*coef(i)+eqwght(i)
+        dpw(i) = dpw(i) + wi(i, j)
+
+!!  print *,'cv3_vertmix, j, wi(1,j),dpw ', j, wi(1,j),dpw  !jyg
+
+      END IF
+    END DO
+  END DO
+
+  ! CR:print
+  ! do i=1,len
+  ! print*,'plim',plim1(i),plim2p(i)
+  ! enddo
+  DO j = 1, nd
+    DO i = 1, len
+      IF (j>=j1(i) .AND. j<=j2(i)) THEN
+        wi(i, j) = wi(i, j)/dpw(i)
+        hmix(i) = hmix(i) + h(i, j)*wi(i, j)
+        qmix(i) = qmix(i) +  q(i, j)*wi(i, j)
+        umix(i) = umix(i) +  u(i, j)*wi(i, j)
+        vmix(i) = vmix(i) +  v(i, j)*wi(i, j)
+      END IF
+    END DO
+  END DO
+
+  DO i = 1, len
+    rdcp(i) = (rrd*(1.-qmix(i))+qmix(i)*rrv)/(cpd*(1.-qmix(i))+qmix(i)*cpv)
+  END DO
+
+
+!!  print *,'cv3_vertmix, rdcp ', rdcp  !jyg
+
+  DO i = 1, len
+    tmix(i) = (hmix(i) - gz(i,1))/(cpd*(1.-qmix(i)) + qmix(i)*cpv)
+    !      (Use of Cpv since we are dealing with dry static energy)
+    thmix(i) = tmix(i)*(p0/pnk(i))**rdcp(i)
+    ! print*,'tmix thmix hmix ',tmix(i),thmix(i),hmix(i)
+    zdelta = max(0., sign(1.,rtt-tmix(i)))
+    qsmix(i) = r2es*foeew(tmix(i), zdelta)/(pnk(i)*100.)
+    qsmix(i) = min(0.5, qsmix(i))
+    zcor = 1./(1.-retv*qsmix(i))
+    qsmix(i) = qsmix(i)*zcor
+  END DO
+
+  ! -------------------------------------------------------------------
+  ! --- Calculate lifted condensation level of air at parcel origin level
+  ! --- (Within 0.2% of formula of Bolton, MON. WEA. REV.,1980)
+  ! -------------------------------------------------------------------
+
+  a = 1669.0 ! convect3
+  b = 122.0 ! convect3
+
+
+  niflag7 = 0
+  DO i = 1, len
+
+    IF (iflag(i)/=7) THEN ! modif sb Jun7th 2002
+
+      rh(i) = qmix(i)/qsmix(i)
+      chi(i) = tmix(i)/(a-b*rh(i)-tmix(i)) ! convect3
+      ! ATTENTION, la LIGNE DESSOUS A ETE RAJOUTEE ARBITRAIREMENT ET
+      ! MASQUE UN PB POTENTIEL
+      chi(i) = max(chi(i), 0.)
+      rh(i) = max(rh(i), 0.)
+      plcl(i) = pnk(i)*(rh(i)**chi(i))
+      IF (((plcl(i)<200.0) .OR. (plcl(i)>=2000.0)) .AND. (iflag(i)==0)) &
+          iflag(i) = 8
+
+    ELSE
+
+      niflag7 = niflag7 + 1
+      plcl(i) = plim2p(i)
+
+    END IF ! iflag=7
+
+    ! print*,'NIFLAG7  =',niflag7
+
+  END DO
+
+!!  print *,' cv3_vertmix->'  !jyg
+
+
+  RETURN
+END SUBROUTINE cv3_estatmix
+
Index: DZ6/trunk/libf/phylmd/cv3_inicp.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cv3_inicp.F90	(revision 5267)
+++ 	(revision )
@@ -1,118 +1,0 @@
-SUBROUTINE cv3_inicp()
-
-  ! **************************************************************
-  ! *
-  ! CV3_INIP Lecture des choix de lois de probabilité de mélange*
-  ! et calcul de leurs coefficients normalisés.        *
-  ! *
-  ! written by   : Jean-Yves Grandpeix, 06/06/2006, 19.39.27    *
-  ! modified by :                                               *
-  ! **************************************************************
-  IMPLICIT NONE
-  include "YOMCST2.h"
-
-  INTEGER iflag_clos
-  CHARACTER (LEN=20) :: modname = 'cv3_inicp'
-  CHARACTER (LEN=80) :: abort_message
-
-  ! --   Mixing probability distribution functions
-
-  REAL qcoef1, qcoef2, qff, qfff, qmix, rmix, qmix1, rmix1, qmix2, rmix2, f
-  REAL :: sumcoef,sigma,aire,pdf,mu,df,ff
-
-  qcoef1(f) = tanh(f/gammas)
-  qcoef2(f) = (tanh(f/gammas)+gammas*log(cosh((1.-f)/gammas)/cosh(f/gammas)))
-  qff(f) = max(min(f,1.), 0.)
-  qfff(f) = min(qff(f), scut)
-  qmix1(f) = (tanh((qff(f)-fmax)/gammas)+qcoef1max)/qcoef2max
-  rmix1(f) = (gammas*log(cosh((qff(f)-fmax)/gammas))+qff(f)*qcoef1max)/ &
-    qcoef2max
-  qmix2(f) = -log(1.-qfff(f))/scut
-  rmix2(f) = (qfff(f)+(1.-qff(f))*log(1.-qfff(f)))/scut
-  qmix(f) = qqa1*qmix1(f) + qqa2*qmix2(f)
-  rmix(f) = qqa1*rmix1(f) + qqa2*rmix2(f)
-
-  ! cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
-
-
-  ! ===========================================================================
-  ! READ IN PARAMETERS FOR THE MIXING DISTRIBUTION
-  ! AND PASS THESE THROUGH A COMMON BLOCK TO SUBROUTINE CONVECT etc.
-  ! (Written by V.T.J. Phillips, 20-30/Jan/99)
-  ! ===========================================================================
-
-  ! line 1:  a flag (0 or 1) to decide whether P(F) = 1 or the general P(F)
-  ! is to be
-  ! used, followed by SCUT, which is the cut-off value of F in CONVECT
-  ! line 2:  blank
-  ! line 3:  the coefficients for the linear combination of P(F)s to
-  ! make the general P(F)
-  ! line 4:  blank
-  ! line 5:  gammas, Fmax for the cosh^2 component of P(F)
-  ! line 6:  blank
-  ! line 7:  alphas for the 1st irrational P(F)
-  ! line 8:  blank
-  ! line 9:  betas  for the 2nd irrational P(F)
-
-
-  ! open(57,file='parameter_mix.data')
-
-  ! read(57,*) iflag_clos
-  ! read(57,*) iflag_mix, scut
-  ! read(57,*)
-  ! if(iflag_mix .gt. 0) then
-  ! read(57,*) qqa1, qqa2
-  ! read(57,*)
-  ! read(57,*) gammas, Fmax
-  ! read(57,*)
-  ! read(57,*) alphas
-  ! endif
-  ! close(57)
-
-  IF (iflag_mix>0) THEN
-
-    ! --      Normalize Pdf weights
-
-    sumcoef = qqa1 + qqa2
-    qqa1 = qqa1/sumcoef
-    qqa2 = qqa2/sumcoef
-
-    qcoef1max = qcoef1(fmax)
-    qcoef2max = qcoef2(fmax)
-
-    sigma = 0.
-    aire = 0.0
-    pdf = 0.0
-    mu = 0.0
-    df = 0.0001
-
-    ! do ff = 0.0 + df, 1.0 - 2.*df, df
-    ff = df
-    DO WHILE (ff<=1.0-2.*df)
-      pdf = (qmix(ff+df)-qmix(ff))*(1.-ff)/df
-      aire = aire + (qmix(ff+df)-qmix(ff))*(1.-ff)
-      mu = mu + pdf*ff*df
-      ! c              write(*,*) pdf,  Qmix(ff), aire, ff
-      ff = ff + df
-    END DO
-
-    ! do ff=0.0+df,1.0 - 2.*df,df
-    ff = df
-    DO WHILE (ff<=1.0-2.*df)
-      pdf = (qmix(ff+df)-qmix(ff))*(1.-ff)/df
-      sigma = sigma + pdf*(ff-mu)*(ff-mu)*df
-      ff = ff + df
-    END DO
-    sigma = sqrt(sigma)
-
-    IF (abs(aire-1.0)>0.02) THEN
-      PRINT *, 'WARNING:: AREA OF MIXING PDF IS::', aire
-      abort_message = ''
-      CALL abort_physic(modname, abort_message, 1)
-    ELSE
-      PRINT *, 'Area, mean & std deviation are ::', aire, mu, sigma
-    END IF
-  END IF !  (iflag_mix .gt. 0)
-
-  RETURN
-END SUBROUTINE cv3_inicp
Index: /LMDZ6/trunk/libf/phylmd/cv3_inicp.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cv3_inicp.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/cv3_inicp.f90	(revision 5268)
@@ -0,0 +1,118 @@
+SUBROUTINE cv3_inicp()
+
+  ! **************************************************************
+  ! *
+  ! CV3_INIP Lecture des choix de lois de probabilité de mélange*
+  ! et calcul de leurs coefficients normalisés.        *
+  ! *
+  ! written by   : Jean-Yves Grandpeix, 06/06/2006, 19.39.27    *
+  ! modified by :                                               *
+  ! **************************************************************
+  IMPLICIT NONE
+  include "YOMCST2.h"
+
+  INTEGER iflag_clos
+  CHARACTER (LEN=20) :: modname = 'cv3_inicp'
+  CHARACTER (LEN=80) :: abort_message
+
+  ! --   Mixing probability distribution functions
+
+  REAL qcoef1, qcoef2, qff, qfff, qmix, rmix, qmix1, rmix1, qmix2, rmix2, f
+  REAL :: sumcoef,sigma,aire,pdf,mu,df,ff
+
+  qcoef1(f) = tanh(f/gammas)
+  qcoef2(f) = (tanh(f/gammas)+gammas*log(cosh((1.-f)/gammas)/cosh(f/gammas)))
+  qff(f) = max(min(f,1.), 0.)
+  qfff(f) = min(qff(f), scut)
+  qmix1(f) = (tanh((qff(f)-fmax)/gammas)+qcoef1max)/qcoef2max
+  rmix1(f) = (gammas*log(cosh((qff(f)-fmax)/gammas))+qff(f)*qcoef1max)/ &
+    qcoef2max
+  qmix2(f) = -log(1.-qfff(f))/scut
+  rmix2(f) = (qfff(f)+(1.-qff(f))*log(1.-qfff(f)))/scut
+  qmix(f) = qqa1*qmix1(f) + qqa2*qmix2(f)
+  rmix(f) = qqa1*rmix1(f) + qqa2*rmix2(f)
+
+  ! cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+
+
+  ! ===========================================================================
+  ! READ IN PARAMETERS FOR THE MIXING DISTRIBUTION
+  ! AND PASS THESE THROUGH A COMMON BLOCK TO SUBROUTINE CONVECT etc.
+  ! (Written by V.T.J. Phillips, 20-30/Jan/99)
+  ! ===========================================================================
+
+  ! line 1:  a flag (0 or 1) to decide whether P(F) = 1 or the general P(F)
+  ! is to be
+  ! used, followed by SCUT, which is the cut-off value of F in CONVECT
+  ! line 2:  blank
+  ! line 3:  the coefficients for the linear combination of P(F)s to
+  ! make the general P(F)
+  ! line 4:  blank
+  ! line 5:  gammas, Fmax for the cosh^2 component of P(F)
+  ! line 6:  blank
+  ! line 7:  alphas for the 1st irrational P(F)
+  ! line 8:  blank
+  ! line 9:  betas  for the 2nd irrational P(F)
+
+
+  ! open(57,file='parameter_mix.data')
+
+  ! read(57,*) iflag_clos
+  ! read(57,*) iflag_mix, scut
+  ! read(57,*)
+  ! if(iflag_mix .gt. 0) then
+  ! read(57,*) qqa1, qqa2
+  ! read(57,*)
+  ! read(57,*) gammas, Fmax
+  ! read(57,*)
+  ! read(57,*) alphas
+  ! endif
+  ! close(57)
+
+  IF (iflag_mix>0) THEN
+
+    ! --      Normalize Pdf weights
+
+    sumcoef = qqa1 + qqa2
+    qqa1 = qqa1/sumcoef
+    qqa2 = qqa2/sumcoef
+
+    qcoef1max = qcoef1(fmax)
+    qcoef2max = qcoef2(fmax)
+
+    sigma = 0.
+    aire = 0.0
+    pdf = 0.0
+    mu = 0.0
+    df = 0.0001
+
+    ! do ff = 0.0 + df, 1.0 - 2.*df, df
+    ff = df
+    DO WHILE (ff<=1.0-2.*df)
+      pdf = (qmix(ff+df)-qmix(ff))*(1.-ff)/df
+      aire = aire + (qmix(ff+df)-qmix(ff))*(1.-ff)
+      mu = mu + pdf*ff*df
+      ! c              write(*,*) pdf,  Qmix(ff), aire, ff
+      ff = ff + df
+    END DO
+
+    ! do ff=0.0+df,1.0 - 2.*df,df
+    ff = df
+    DO WHILE (ff<=1.0-2.*df)
+      pdf = (qmix(ff+df)-qmix(ff))*(1.-ff)/df
+      sigma = sigma + pdf*(ff-mu)*(ff-mu)*df
+      ff = ff + df
+    END DO
+    sigma = sqrt(sigma)
+
+    IF (abs(aire-1.0)>0.02) THEN
+      PRINT *, 'WARNING:: AREA OF MIXING PDF IS::', aire
+      abort_message = ''
+      CALL abort_physic(modname, abort_message, 1)
+    ELSE
+      PRINT *, 'Area, mean & std deviation are ::', aire, mu, sigma
+    END IF
+  END IF !  (iflag_mix .gt. 0)
+
+  RETURN
+END SUBROUTINE cv3_inicp
Index: DZ6/trunk/libf/phylmd/cv3_inip.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cv3_inip.F90	(revision 5267)
+++ 	(revision )
@@ -1,146 +1,0 @@
-SUBROUTINE cv3_inip()
-  ! *******************************************************************
-  ! *                                                                  *
-  ! CV3_INIP Input = choice of mixing probability laws                 *
-  !          Output = normalized coefficients of the probability laws. *
-  ! *                                                                  *
-  ! written by   : Jean-Yves Grandpeix, 06/06/2006, 19.39.27           *
-  ! modified by :                                                      *
-  ! *******************************************************************
-!
-!----------------------------------------------
-!  INPUT (from Common YOMCST2 in "YOMCST2.h") : 
-! iflag_mix
-! gammas    
-! alphas
-! betas
-! Fmax
-! scut
-!
-!----------------------------------------------
-!  INPUT/OUTPUT (from and to Common YOMCST2 in "YOMCST2.h") : 
-! qqa1
-! qqa2
-!
-!----------------------------------------------
-!  OUTPUT (to Common YOMCST2 in "YOMCST2.h") :
-! Qcoef1max
-! Qcoef2max
-!
-!----------------------------------------------
-
-  USE print_control_mod, ONLY: prt_level, lunout
-  IMPLICIT NONE
-
-  include "YOMCST2.h"
-
-!----------------------------------------------
-! Local variables :
-   CHARACTER (LEN=20) :: modname = 'cv3_inip'
-   CHARACTER (LEN=80) :: abort_message
-
-   REAL               :: sumcoef
-   REAL               :: sigma, aire, pdf, mu, df
-   REAL               :: ff
-
-
-  ! --   Mixing probability distribution functions
-
-  REAL qcoef1, qcoef2, qff, qfff, qmix, rmix, qmix1, rmix1, qmix2, rmix2, f
-
-  qcoef1(f) = tanh(f/gammas)
-  qcoef2(f) = (tanh(f/gammas)+gammas*log(cosh((1.-f)/gammas)/cosh(f/gammas)))
-  qff(f) = max(min(f,1.), 0.)
-  qfff(f) = min(qff(f), scut)
-  qmix1(f) = (tanh((qff(f)-fmax)/gammas)+qcoef1max)/qcoef2max
-  rmix1(f) = (gammas*log(cosh((qff(f)-fmax)/gammas))+qff(f)*qcoef1max)/ &
-    qcoef2max
-  qmix2(f) = -log(1.-qfff(f))/scut
-  rmix2(f) = (qfff(f)+(1.-qff(f))*log(1.-qfff(f)))/scut
-  qmix(f) = qqa1*qmix1(f) + qqa2*qmix2(f)
-  rmix(f) = qqa1*rmix1(f) + qqa2*rmix2(f)
-
-  ! cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
-
-
-  ! ===========================================================================
-  ! READ IN PARAMETERS FOR THE MIXING DISTRIBUTION
-  ! AND PASS THESE THROUGH A COMMON BLOCK TO SUBROUTINE CONVECT etc.
-  ! (Written by V.T.J. Phillips, 20-30/Jan/99)
-  ! ===========================================================================
-
-  ! line 1:  a flag (0 or 1) to decide whether P(F) = 1 or the general P(F)
-  ! is to be
-  ! used, followed by SCUT, which is the cut-off value of F in CONVECT
-  ! line 2:  blank
-  ! line 3:  the coefficients for the linear combination of P(F)s to
-  ! make the general P(F)
-  ! line 4:  blank
-  ! line 5:  gammas, Fmax for the cosh^2 component of P(F)
-  ! line 6:  blank
-  ! line 7:  alphas for the 1st irrational P(F)
-  ! line 8:  blank
-  ! line 9:  betas  for the 2nd irrational P(F)
-
-
-  ! c$$$        open(57,file='parameter_mix.data')
-  ! c$$$
-  ! c$$$        read(57,*) iflag_mix, scut
-  ! c$$$        read(57,*)
-  ! c$$$        if(iflag_mix .gt. 0) then
-  ! c$$$	      read(57,*) qqa1, qqa2
-  ! c$$$              read(57,*)
-  ! c$$$              read(57,*) gammas, Fmax
-  ! c$$$              read(57,*)
-  ! c$$$              read(57,*) alphas
-  ! c$$$         endif
-  ! c$$$	 close(57)
-
-
-  IF (iflag_mix>0) THEN
-
-    ! --      Normalize Pdf weights
-
-    sumcoef = qqa1 + qqa2
-    qqa1 = qqa1/sumcoef
-    qqa2 = qqa2/sumcoef
-
-    qcoef1max = qcoef1(fmax)
-    qcoef2max = qcoef2(fmax)
-
-    sigma = 0.
-    aire = 0.0
-    pdf = 0.0
-    mu = 0.0
-    df = 0.0001
-
-    ! do ff = 0.0 + df, 1.0 - 2.*df, df
-    ff = df
-    DO WHILE (ff<=1.0-2.*df)
-      pdf = (qmix(ff+df)-qmix(ff))*(1.-ff)/df
-      aire = aire + (qmix(ff+df)-qmix(ff))*(1.-ff)
-      mu = mu + pdf*ff*df
-      IF (prt_level>9) WRITE (lunout, *) pdf, qmix(ff), aire, ff
-      ff = ff + df
-    END DO
-
-    ! do ff=0.0+df,1.0 - 2.*df,df
-    ff = df
-    DO WHILE (ff<=1.0-2.*df)
-      pdf = (qmix(ff+df)-qmix(ff))*(1.-ff)/df
-      sigma = sigma + pdf*(ff-mu)*(ff-mu)*df
-      ff = ff + df
-    END DO
-    sigma = sqrt(sigma)
-
-    IF (abs(aire-1.0)>0.02) THEN
-      WRITE (lunout, *) 'WARNING:: AREA OF MIXING PDF IS::', aire
-      abort_message = ''
-      CALL abort_physic(modname, abort_message, 1)
-    ELSE
-      PRINT *, 'Area, mean & std deviation are ::', aire, mu, sigma
-    END IF
-  END IF !  (iflag_mix .gt. 0)
-
-  RETURN
-END SUBROUTINE cv3_inip
Index: /LMDZ6/trunk/libf/phylmd/cv3_inip.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cv3_inip.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/cv3_inip.f90	(revision 5268)
@@ -0,0 +1,146 @@
+SUBROUTINE cv3_inip()
+  ! *******************************************************************
+  ! *                                                                  *
+  ! CV3_INIP Input = choice of mixing probability laws                 *
+  !          Output = normalized coefficients of the probability laws. *
+  ! *                                                                  *
+  ! written by   : Jean-Yves Grandpeix, 06/06/2006, 19.39.27           *
+  ! modified by :                                                      *
+  ! *******************************************************************
+!
+!----------------------------------------------
+!  INPUT (from Common YOMCST2 in "YOMCST2.h") : 
+! iflag_mix
+! gammas    
+! alphas
+! betas
+! Fmax
+! scut
+!
+!----------------------------------------------
+!  INPUT/OUTPUT (from and to Common YOMCST2 in "YOMCST2.h") : 
+! qqa1
+! qqa2
+!
+!----------------------------------------------
+!  OUTPUT (to Common YOMCST2 in "YOMCST2.h") :
+! Qcoef1max
+! Qcoef2max
+!
+!----------------------------------------------
+
+  USE print_control_mod, ONLY: prt_level, lunout
+  IMPLICIT NONE
+
+  include "YOMCST2.h"
+
+!----------------------------------------------
+! Local variables :
+   CHARACTER (LEN=20) :: modname = 'cv3_inip'
+   CHARACTER (LEN=80) :: abort_message
+
+   REAL               :: sumcoef
+   REAL               :: sigma, aire, pdf, mu, df
+   REAL               :: ff
+
+
+  ! --   Mixing probability distribution functions
+
+  REAL qcoef1, qcoef2, qff, qfff, qmix, rmix, qmix1, rmix1, qmix2, rmix2, f
+
+  qcoef1(f) = tanh(f/gammas)
+  qcoef2(f) = (tanh(f/gammas)+gammas*log(cosh((1.-f)/gammas)/cosh(f/gammas)))
+  qff(f) = max(min(f,1.), 0.)
+  qfff(f) = min(qff(f), scut)
+  qmix1(f) = (tanh((qff(f)-fmax)/gammas)+qcoef1max)/qcoef2max
+  rmix1(f) = (gammas*log(cosh((qff(f)-fmax)/gammas))+qff(f)*qcoef1max)/ &
+    qcoef2max
+  qmix2(f) = -log(1.-qfff(f))/scut
+  rmix2(f) = (qfff(f)+(1.-qff(f))*log(1.-qfff(f)))/scut
+  qmix(f) = qqa1*qmix1(f) + qqa2*qmix2(f)
+  rmix(f) = qqa1*rmix1(f) + qqa2*rmix2(f)
+
+  ! cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+
+
+  ! ===========================================================================
+  ! READ IN PARAMETERS FOR THE MIXING DISTRIBUTION
+  ! AND PASS THESE THROUGH A COMMON BLOCK TO SUBROUTINE CONVECT etc.
+  ! (Written by V.T.J. Phillips, 20-30/Jan/99)
+  ! ===========================================================================
+
+  ! line 1:  a flag (0 or 1) to decide whether P(F) = 1 or the general P(F)
+  ! is to be
+  ! used, followed by SCUT, which is the cut-off value of F in CONVECT
+  ! line 2:  blank
+  ! line 3:  the coefficients for the linear combination of P(F)s to
+  ! make the general P(F)
+  ! line 4:  blank
+  ! line 5:  gammas, Fmax for the cosh^2 component of P(F)
+  ! line 6:  blank
+  ! line 7:  alphas for the 1st irrational P(F)
+  ! line 8:  blank
+  ! line 9:  betas  for the 2nd irrational P(F)
+
+
+  ! c$$$        open(57,file='parameter_mix.data')
+  ! c$$$
+  ! c$$$        read(57,*) iflag_mix, scut
+  ! c$$$        read(57,*)
+  ! c$$$        if(iflag_mix .gt. 0) then
+  ! c$$$	      read(57,*) qqa1, qqa2
+  ! c$$$              read(57,*)
+  ! c$$$              read(57,*) gammas, Fmax
+  ! c$$$              read(57,*)
+  ! c$$$              read(57,*) alphas
+  ! c$$$         endif
+  ! c$$$	 close(57)
+
+
+  IF (iflag_mix>0) THEN
+
+    ! --      Normalize Pdf weights
+
+    sumcoef = qqa1 + qqa2
+    qqa1 = qqa1/sumcoef
+    qqa2 = qqa2/sumcoef
+
+    qcoef1max = qcoef1(fmax)
+    qcoef2max = qcoef2(fmax)
+
+    sigma = 0.
+    aire = 0.0
+    pdf = 0.0
+    mu = 0.0
+    df = 0.0001
+
+    ! do ff = 0.0 + df, 1.0 - 2.*df, df
+    ff = df
+    DO WHILE (ff<=1.0-2.*df)
+      pdf = (qmix(ff+df)-qmix(ff))*(1.-ff)/df
+      aire = aire + (qmix(ff+df)-qmix(ff))*(1.-ff)
+      mu = mu + pdf*ff*df
+      IF (prt_level>9) WRITE (lunout, *) pdf, qmix(ff), aire, ff
+      ff = ff + df
+    END DO
+
+    ! do ff=0.0+df,1.0 - 2.*df,df
+    ff = df
+    DO WHILE (ff<=1.0-2.*df)
+      pdf = (qmix(ff+df)-qmix(ff))*(1.-ff)/df
+      sigma = sigma + pdf*(ff-mu)*(ff-mu)*df
+      ff = ff + df
+    END DO
+    sigma = sqrt(sigma)
+
+    IF (abs(aire-1.0)>0.02) THEN
+      WRITE (lunout, *) 'WARNING:: AREA OF MIXING PDF IS::', aire
+      abort_message = ''
+      CALL abort_physic(modname, abort_message, 1)
+    ELSE
+      PRINT *, 'Area, mean & std deviation are ::', aire, mu, sigma
+    END IF
+  END IF !  (iflag_mix .gt. 0)
+
+  RETURN
+END SUBROUTINE cv3_inip
Index: DZ6/trunk/libf/phylmd/cv3_mixscale.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cv3_mixscale.F90	(revision 5267)
+++ 	(revision )
@@ -1,34 +1,0 @@
-SUBROUTINE cv3_mixscale(nloc, ncum, na, ment, m)
-  ! **************************************************************
-  ! *
-  ! CV3_MIXSCALE                                                *
-  ! *
-  ! *
-  ! written by   : Jean-Yves Grandpeix, 30/05/2003, 16.34.37    *
-  ! modified by :                                               *
-  ! **************************************************************
-
-  IMPLICIT NONE
-
-  include "cv3param.h"
-
-!inputs:
-  INTEGER, INTENT (IN)                               :: ncum, na, nloc
-  REAL, DIMENSION (nloc, na), INTENT (IN)            :: m
-!input/outputs:
-  REAL, DIMENSION (nloc, na, na), INTENT (INOUT)     :: ment
-
-!local variables:
-  INTEGER i, j, il
-
-    DO j = 1, nl
-      DO i = 1, nl
-        DO il = 1, ncum
-          ment(il, i, j) = m(il, i)*ment(il, i, j)
-        END DO
-      END DO
-    END DO
-
-
-  RETURN
-END SUBROUTINE cv3_mixscale
Index: /LMDZ6/trunk/libf/phylmd/cv3_mixscale.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cv3_mixscale.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/cv3_mixscale.f90	(revision 5268)
@@ -0,0 +1,34 @@
+SUBROUTINE cv3_mixscale(nloc, ncum, na, ment, m)
+  ! **************************************************************
+  ! *
+  ! CV3_MIXSCALE                                                *
+  ! *
+  ! *
+  ! written by   : Jean-Yves Grandpeix, 30/05/2003, 16.34.37    *
+  ! modified by :                                               *
+  ! **************************************************************
+
+  IMPLICIT NONE
+
+  include "cv3param.h"
+
+!inputs:
+  INTEGER, INTENT (IN)                               :: ncum, na, nloc
+  REAL, DIMENSION (nloc, na), INTENT (IN)            :: m
+!input/outputs:
+  REAL, DIMENSION (nloc, na, na), INTENT (INOUT)     :: ment
+
+!local variables:
+  INTEGER i, j, il
+
+    DO j = 1, nl
+      DO i = 1, nl
+        DO il = 1, ncum
+          ment(il, i, j) = m(il, i)*ment(il, i, j)
+        END DO
+      END DO
+    END DO
+
+
+  RETURN
+END SUBROUTINE cv3_mixscale
Index: DZ6/trunk/libf/phylmd/cv3_routines.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cv3_routines.F90	(revision 5267)
+++ 	(revision )
@@ -1,5279 +1,0 @@
-
-! $Id$
-
-
-
-
-SUBROUTINE cv3_param(nd, k_upper, delt)
-
-  USE ioipsl_getin_p_mod, ONLY : getin_p
-  use mod_phys_lmdz_para
-  IMPLICIT NONE
-
-!------------------------------------------------------------
-!Set parameters for convectL for iflag_con = 3
-!------------------------------------------------------------
-
-
-!***  PBCRIT IS THE CRITICAL CLOUD DEPTH (MB) BENEATH WHICH THE ***
-!***      PRECIPITATION EFFICIENCY IS ASSUMED TO BE ZERO     ***
-!***  PTCRIT IS THE CLOUD DEPTH (MB) ABOVE WHICH THE PRECIP. ***
-!***            EFFICIENCY IS ASSUMED TO BE UNITY            ***
-!***  SIGD IS THE FRACTIONAL AREA COVERED BY UNSATURATED DNDRAFT  ***
-!***  SPFAC IS THE FRACTION OF PRECIPITATION FALLING OUTSIDE ***
-!***                        OF CLOUD                         ***
-
-![TAU: CHARACTERISTIC TIMESCALE USED TO COMPUTE ALPHA & BETA]
-!***    ALPHA AND BETA ARE PARAMETERS THAT CONTROL THE RATE OF ***
-!***                 APPROACH TO QUASI-EQUILIBRIUM           ***
-!***    (THEIR STANDARD VALUES ARE 1.0 AND 0.96, RESPECTIVELY) ***
-!***           (BETA MUST BE LESS THAN OR EQUAL TO 1)        ***
-
-!***    DTCRIT IS THE CRITICAL BUOYANCY (K) USED TO ADJUST THE ***
-!***                 APPROACH TO QUASI-EQUILIBRIUM           ***
-!***                     IT MUST BE LESS THAN 0              ***
-
-  include "cv3param.h"
-  include "cvflag.h"
-  include "conema3.h"
-
-  INTEGER, INTENT(IN)              :: nd
-  INTEGER, INTENT(IN)              :: k_upper
-  REAL, INTENT(IN)                 :: delt ! timestep (seconds)
-
-! Local variables
-  CHARACTER (LEN=20) :: modname = 'cv3_param'
-  CHARACTER (LEN=80) :: abort_message
-
-  LOGICAL, SAVE :: first = .TRUE.
-!$OMP THREADPRIVATE(first)
-
-!glb  noff: integer limit for convection (nd-noff)
-! minorig: First level of convection
-
-! -- limit levels for convection:
-
-!jyg<
-!  noff is chosen such that nl = k_upper so that upmost loops end at about 22 km
-!
-  noff = min(max(nd-k_upper, 1), (nd+1)/2)
-!!  noff = 1
-!>jyg
-  minorig = 1
-  nl = nd - noff
-  nlp = nl + 1
-  nlm = nl - 1
-
-  IF (first) THEN
-! -- "microphysical" parameters:
-! IM beg: ajout fis. reglage ep
-! CR+JYG: shedding coefficient (used when iflag_mix_adiab=1)
-! IM lu dans physiq.def via conf_phys.F90     epmax  = 0.993
-
-    omtrain = 45.0 ! used also for snow (no disctinction rain/snow)
-! -- misc:
-    dtovsh = -0.2 ! dT for overshoot
-! cc      dttrig = 5.   ! (loose) condition for triggering
-    dttrig = 10. ! (loose) condition for triggering
-    dtcrit = -2.0
-! -- end of convection
-! -- interface cloud parameterization:
-    delta = 0.01 ! cld
-! -- interface with boundary-layer (gust factor): (sb)
-    betad = 10.0 ! original value (from convect 4.3)
-
-! Var interm pour le getin
-     cv_flag_feed=1
-     CALL getin_p('cv_flag_feed',cv_flag_feed)
-     T_top_max = 1000.
-     CALL getin_p('t_top_max',T_top_max)
-     dpbase=-40.
-     CALL getin_p('dpbase',dpbase)
-     pbcrit=150.0
-     CALL getin_p('pbcrit',pbcrit)
-     ptcrit=500.0
-     CALL getin_p('ptcrit',ptcrit)
-     sigdz=0.01
-     CALL getin_p('sigdz',sigdz)
-     spfac=0.15
-     CALL getin_p('spfac',spfac)
-     tau=8000.
-     CALL getin_p('tau',tau)
-     flag_wb=1
-     CALL getin_p('flag_wb',flag_wb)
-     wbmax=6.
-     CALL getin_p('wbmax',wbmax)
-     ok_convstop=.False.
-     CALL getin_p('ok_convstop',ok_convstop)
-     tau_stop=15000.
-     CALL getin_p('tau_stop',tau_stop)
-     ok_intermittent=.False.
-     CALL getin_p('ok_intermittent',ok_intermittent)
-     ok_optim_yield=.False.
-     CALL getin_p('ok_optim_yield',ok_optim_yield)
-     ok_homo_tend=.TRUE.
-     CALL getin_p('ok_homo_tend',ok_homo_tend)
-     ok_entrain=.TRUE.
-     CALL getin_p('ok_entrain',ok_entrain)
-
-     coef_peel=0.25
-     CALL getin_p('coef_peel',coef_peel)
-
-     flag_epKEorig=1
-     CALL getin_p('flag_epKEorig',flag_epKEorig)
-     elcrit=0.0003
-     CALL getin_p('elcrit',elcrit)
-     tlcrit=-55.0
-     CALL getin_p('tlcrit',tlcrit)
-     ejectliq=0.
-     CALL getin_p('ejectliq',ejectliq)
-     ejectice=0.
-     CALL getin_p('ejectice',ejectice)
-     cvflag_prec_eject = .FALSE.
-     CALL getin_p('cvflag_prec_eject',cvflag_prec_eject)
-     qsat_depends_on_qt = .FALSE.
-     CALL getin_p('qsat_depends_on_qt',qsat_depends_on_qt)
-     adiab_ascent_mass_flux_depends_on_ejectliq = .FALSE.
-     CALL getin_p('adiab_ascent_mass_flux_depends_on_ejectliq',adiab_ascent_mass_flux_depends_on_ejectliq)
-     keepbug_ice_frac = .TRUE.
-     CALL getin_p('keepbug_ice_frac', keepbug_ice_frac)
-
-    WRITE (*, *) 't_top_max=', t_top_max
-    WRITE (*, *) 'dpbase=', dpbase
-    WRITE (*, *) 'pbcrit=', pbcrit
-    WRITE (*, *) 'ptcrit=', ptcrit
-    WRITE (*, *) 'sigdz=', sigdz
-    WRITE (*, *) 'spfac=', spfac
-    WRITE (*, *) 'tau=', tau
-    WRITE (*, *) 'flag_wb=', flag_wb
-    WRITE (*, *) 'wbmax=', wbmax
-    WRITE (*, *) 'ok_convstop=', ok_convstop
-    WRITE (*, *) 'tau_stop=', tau_stop
-    WRITE (*, *) 'ok_intermittent=', ok_intermittent
-    WRITE (*, *) 'ok_optim_yield =', ok_optim_yield
-    WRITE (*, *) 'coef_peel=', coef_peel
-
-    WRITE (*, *) 'flag_epKEorig=', flag_epKEorig
-    WRITE (*, *) 'elcrit=', elcrit
-    WRITE (*, *) 'tlcrit=', tlcrit
-    WRITE (*, *) 'ejectliq=', ejectliq
-    WRITE (*, *) 'ejectice=', ejectice
-    WRITE (*, *) 'cvflag_prec_eject =', cvflag_prec_eject 
-    WRITE (*, *) 'qsat_depends_on_qt =', qsat_depends_on_qt 
-    WRITE (*, *) 'adiab_ascent_mass_flux_depends_on_ejectliq =', adiab_ascent_mass_flux_depends_on_ejectliq
-    WRITE (*, *) 'keepbug_ice_frac =', keepbug_ice_frac 
-
-    first = .FALSE.
-  END IF ! (first)
-
-  beta = 1.0 - delt/tau
-  alpha1 = 1.5E-3
-!JYG    Correction bug alpha
-  alpha1 = alpha1*1.5
-  alpha = alpha1*delt/tau
-!JYG    Bug
-! cc increase alpha to compensate W decrease:
-! c      alpha  = alpha*1.5
-
-  noconv_stop = max(2.,tau_stop/delt)
-
-  RETURN
-END SUBROUTINE cv3_param
-
-SUBROUTINE cv3_incrcount(len, nd, delt, sig)
-
-IMPLICIT NONE
-
-! =====================================================================
-!  Increment the counter sig(nd)
-! =====================================================================
-
-  include "cv3param.h"
-  include "cvflag.h"
-
-!inputs:
-  INTEGER, INTENT(IN)                     :: len
-  INTEGER, INTENT(IN)                     :: nd
-  REAL, INTENT(IN)                        :: delt ! timestep (seconds)
-
-!input/output
-  REAL, DIMENSION(len,nd), INTENT(INOUT)  :: sig
-
-!local variables
-  INTEGER il
-
-!    print *,'cv3_incrcount : noconv_stop ',noconv_stop
-!    print *,'cv3_incrcount in, sig(1,nd) ',sig(1,nd)
-    IF(ok_convstop) THEN
-      DO il = 1, len
-        sig(il, nd) = sig(il, nd) + 1.
-        sig(il, nd) = min(sig(il,nd), noconv_stop+0.1)
-      END DO
-    ELSE
-      DO il = 1, len
-        sig(il, nd) = sig(il, nd) + 1.
-        sig(il, nd) = min(sig(il,nd), 12.1)
-      END DO
-    ENDIF  ! (ok_convstop)
-!    print *,'cv3_incrcount out, sig(1,nd) ',sig(1,nd)
-
-  RETURN
-END SUBROUTINE cv3_incrcount
-
-SUBROUTINE cv3_prelim(len, nd, ndp1, t, q, p, ph, &
-                      lv, lf, cpn, tv, gz, h, hm, th)
-  IMPLICIT NONE
-
-! =====================================================================
-! --- CALCULATE ARRAYS OF GEOPOTENTIAL, HEAT CAPACITY & STATIC ENERGY
-! "ori": from convect4.3 (vectorized)
-! "convect3": to be exactly consistent with convect3
-! =====================================================================
-
-! inputs:
-  INTEGER len, nd, ndp1
-  REAL t(len, nd), q(len, nd), p(len, nd), ph(len, ndp1)
-
-! outputs:
-  REAL lv(len, nd), lf(len, nd), cpn(len, nd), tv(len, nd)
-  REAL gz(len, nd), h(len, nd), hm(len, nd)
-  REAL th(len, nd)
-
-! local variables:
-  INTEGER k, i
-  REAL rdcp
-  REAL tvx, tvy ! convect3
-  REAL cpx(len, nd)
-
-  include "cvthermo.h"
-  include "cv3param.h"
-
-
-! ori      do 110 k=1,nlp
-! abderr     do 110 k=1,nl ! convect3
-  DO k = 1, nlp
-
-    DO i = 1, len
-! debug          lv(i,k)= lv0-clmcpv*(t(i,k)-t0)
-      lv(i, k) = lv0 - clmcpv*(t(i,k)-273.15)
-!!      lf(i, k) = lf0 - clmci*(t(i,k)-273.15)   ! erreur de signe !!
-      lf(i, k) = lf0 + clmci*(t(i,k)-273.15)
-      cpn(i, k) = cpd*(1.0-q(i,k)) + cpv*q(i, k)
-      cpx(i, k) = cpd*(1.0-q(i,k)) + cl*q(i, k)
-! ori          tv(i,k)=t(i,k)*(1.0+q(i,k)*epsim1)
-      tv(i, k) = t(i, k)*(1.0+q(i,k)/eps-q(i,k))
-      rdcp = (rrd*(1.-q(i,k))+q(i,k)*rrv)/cpn(i, k)
-      th(i, k) = t(i, k)*(1000.0/p(i,k))**rdcp
-    END DO
-  END DO
-
-! gz = phi at the full levels (same as p).
-
-!!  DO i = 1, len                    !jyg
-!!    gz(i, 1) = 0.0                 !jyg
-!!  END DO                           !jyg
-    gz(:,:) = 0.                     !jyg: initialization of the whole array
-! ori      do 140 k=2,nlp
-  DO k = 2, nl ! convect3
-    DO i = 1, len
-      tvx = t(i, k)*(1.+q(i,k)/eps-q(i,k))         !convect3
-      tvy = t(i, k-1)*(1.+q(i,k-1)/eps-q(i,k-1))   !convect3
-      gz(i, k) = gz(i, k-1) + 0.5*rrd*(tvx+tvy)* & !convect3
-                 (p(i,k-1)-p(i,k))/ph(i, k)        !convect3
-
-! c        print *,' gz(',k,')',gz(i,k),' tvx',tvx,' tvy ',tvy
-
-! ori         gz(i,k)=gz(i,k-1)+hrd*(tv(i,k-1)+tv(i,k))
-! ori    &         *(p(i,k-1)-p(i,k))/ph(i,k)
-    END DO
-  END DO
-
-! h  = phi + cpT (dry static energy).
-! hm = phi + cp(T-Tbase)+Lq
-
-! ori      do 170 k=1,nlp
-  DO k = 1, nl ! convect3
-    DO i = 1, len
-      h(i, k) = gz(i, k) + cpn(i, k)*t(i, k)
-      hm(i, k) = gz(i, k) + cpx(i, k)*(t(i,k)-t(i,1)) + lv(i, k)*q(i, k)
-    END DO
-  END DO
-
-  RETURN
-END SUBROUTINE cv3_prelim
-
-SUBROUTINE cv3_feed(len, nd, ok_conserv_q, &
-                    t, q, u, v, p, ph, h, gz, &
-                    p1feed, p2feed, wght, &
-                    wghti, tnk, thnk, qnk, qsnk, unk, vnk, &
-                    cpnk, hnk, nk, icb, icbmax, iflag, gznk, plcl)
-
-  USE mod_phys_lmdz_transfert_para, ONLY : bcast
-  USE add_phys_tend_mod, ONLY: fl_cor_ebil
-  USE print_control_mod, ONLY: prt_level
-  IMPLICIT NONE
-
-! ================================================================
-! Purpose: CONVECTIVE FEED
-
-! Main differences with cv_feed:
-! - ph added in input
-! - here, nk(i)=minorig
-! - icb defined differently (plcl compared with ph instead of p)
-! - dry static energy as argument instead of moist static energy
-
-! Main differences with convect3:
-! - we do not compute dplcldt and dplcldr of CLIFT anymore
-! - values iflag different (but tests identical)
-! - A,B explicitely defined (!...)
-! ================================================================
-
-  include "cv3param.h"
-  include "cvthermo.h"
-
-!inputs:
-  INTEGER, INTENT (IN)                               :: len, nd
-  LOGICAL, INTENT (IN)                               :: ok_conserv_q
-  REAL, DIMENSION (len, nd), INTENT (IN)             :: t, q, p
-  REAL, DIMENSION (len, nd), INTENT (IN)             :: u, v
-  REAL, DIMENSION (len, nd), INTENT (IN)             :: h, gz
-  REAL, DIMENSION (len, nd+1), INTENT (IN)           :: ph
-  REAL, DIMENSION (len), INTENT (IN)                 :: p1feed
-  REAL, DIMENSION (nd), INTENT (IN)                  :: wght
-!input-output
-  REAL, DIMENSION (len), INTENT (INOUT)              :: p2feed
-!outputs:
-  INTEGER, INTENT (OUT)                              :: icbmax
-  INTEGER, DIMENSION (len), INTENT (OUT)             :: iflag, nk, icb
-  REAL, DIMENSION (len, nd), INTENT (OUT)            :: wghti
-  REAL, DIMENSION (len), INTENT (OUT)                :: tnk, thnk, qnk, qsnk
-  REAL, DIMENSION (len), INTENT (OUT)                :: unk, vnk
-  REAL, DIMENSION (len), INTENT (OUT)                :: cpnk, hnk, gznk
-  REAL, DIMENSION (len), INTENT (OUT)                :: plcl
-
-!local variables:
-  INTEGER i, k, iter, niter
-  INTEGER ihmin(len)
-  REAL work(len)
-  REAL pup(len), plo(len), pfeed(len)
-  REAL plclup(len), plcllo(len), plclfeed(len)
-  REAL pfeedmin(len)
-  REAL posit(len)
-  LOGICAL nocond(len)
-
-!jyg20140217<
-  INTEGER iostat
-  LOGICAL, SAVE :: first
-  LOGICAL, SAVE :: ok_new_feed
-  REAL, SAVE :: dp_lcl_feed
-!$OMP THREADPRIVATE (first,ok_new_feed,dp_lcl_feed)
-  DATA first/.TRUE./
-  DATA dp_lcl_feed/2./
-
-  IF (first) THEN
-!$OMP MASTER
-    ok_new_feed = ok_conserv_q
-    OPEN (98, FILE='cv3feed_param.data', STATUS='old', FORM='formatted', IOSTAT=iostat)
-    IF (iostat==0) THEN
-      READ (98, *, END=998) ok_new_feed
-998   CONTINUE
-      CLOSE (98)
-    END IF
-    PRINT *, ' ok_new_feed: ', ok_new_feed
-!$OMP END MASTER
-    call bcast(ok_new_feed)
-    first = .FALSE.   
-  END IF
-!jyg>
-! -------------------------------------------------------------------
-! --- Origin level of ascending parcels for convect3:
-! -------------------------------------------------------------------
-
-  DO i = 1, len
-    nk(i) = minorig
-    gznk(i) = gz(i, nk(i))
-  END DO
-
-! -------------------------------------------------------------------
-! --- Adjust feeding layer thickness so that lifting up to the top of
-! --- the feeding layer does not induce condensation (i.e. so that
-! --- plcl < p2feed).
-! --- Method : iterative secant method.
-! -------------------------------------------------------------------
-
-! 1- First bracketing of the solution : ph(nk+1), p2feed
-
-! 1.a- LCL associated with p2feed
-  DO i = 1, len
-    pup(i) = p2feed(i)
-  END DO
-  IF (fl_cor_ebil >=2 ) THEN
-    CALL cv3_estatmix(len, nd, iflag, p1feed, pup, p, ph, &
-                     t, q, u, v, h, gz, wght, &
-                     wghti, nk, tnk, thnk, qnk, qsnk, unk, vnk, plclup)
-  ELSE
-    CALL cv3_enthalpmix(len, nd, iflag, p1feed, pup, p, ph, &
-                       t, q, u, v, wght, &
-                       wghti, nk, tnk, thnk, qnk, qsnk, unk, vnk, plclup)
-  ENDIF  ! (fl_cor_ebil >=2 ) 
-! 1.b- LCL associated with ph(nk+1)
-  DO i = 1, len
-    plo(i) = ph(i, nk(i)+1)
-  END DO
-  IF (fl_cor_ebil >=2 ) THEN
-    CALL cv3_estatmix(len, nd, iflag, p1feed, plo, p, ph, &
-                     t, q, u, v, h, gz, wght, &
-                     wghti, nk, tnk, thnk, qnk, qsnk, unk, vnk, plcllo)
-  ELSE
-    CALL cv3_enthalpmix(len, nd, iflag, p1feed, plo, p, ph, &
-                       t, q, u, v, wght, &
-                       wghti, nk, tnk, thnk, qnk, qsnk, unk, vnk, plcllo)
-  ENDIF  ! (fl_cor_ebil >=2 ) 
-! 2- Iterations
-  niter = 5
-  DO iter = 1, niter
-    DO i = 1, len
-      plcllo(i) = min(plo(i), plcllo(i))
-      plclup(i) = max(pup(i), plclup(i))
-      nocond(i) = plclup(i) <= pup(i)
-    END DO
-    DO i = 1, len
-      IF (nocond(i)) THEN
-        pfeed(i) = pup(i)
-      ELSE
-!JYG20140217<
-        IF (ok_new_feed) THEN
-          pfeed(i) = (pup(i)*(plo(i)-plcllo(i)-dp_lcl_feed)+  &
-                      plo(i)*(plclup(i)-pup(i)+dp_lcl_feed))/ &
-                     (plo(i)-plcllo(i)+plclup(i)-pup(i))
-        ELSE
-          pfeed(i) = (pup(i)*(plo(i)-plcllo(i))+  &
-                      plo(i)*(plclup(i)-pup(i)))/ &
-                     (plo(i)-plcllo(i)+plclup(i)-pup(i))
-        END IF
-!JYG>
-      END IF
-    END DO
-!jyg20140217<
-! For the last iteration, make sure that the top of the feeding layer
-! and LCL are not in the same layer:
-    IF (ok_new_feed) THEN
-      IF (iter==niter) THEN
-        DO i = 1,len                         !jyg
-          pfeedmin(i) = ph(i,minorig+1)      !jyg
-        ENDDO                                !jyg
-        DO k = minorig+1, nl                 !jyg
-!!        DO k = minorig, nl                 !jyg
-          DO i = 1, len
-            IF (ph(i,k)>=plclfeed(i)) pfeedmin(i) = ph(i, k)
-          END DO
-        END DO
-        DO i = 1, len
-          pfeed(i) = max(pfeedmin(i), pfeed(i))
-        END DO
-      END IF
-    END IF
-!jyg>
-
-    IF (fl_cor_ebil >=2 ) THEN
-      CALL cv3_estatmix(len, nd, iflag, p1feed, pfeed, p, ph, &
-                       t, q, u, v, h, gz, wght, &
-                       wghti, nk, tnk, thnk, qnk, qsnk, unk, vnk, plclfeed)
-    ELSE
-      CALL cv3_enthalpmix(len, nd, iflag, p1feed, pfeed, p, ph, &
-                         t, q, u, v, wght, &
-                         wghti, nk, tnk, thnk, qnk, qsnk, unk, vnk, plclfeed)
-    ENDIF  ! (fl_cor_ebil >=2 ) 
-!jyg20140217<
-    IF (ok_new_feed) THEN
-      DO i = 1, len
-        posit(i) = (sign(1.,plclfeed(i)-pfeed(i)+dp_lcl_feed)+1.)*0.5
-        IF (plclfeed(i)-pfeed(i)+dp_lcl_feed==0.) posit(i) = 1.
-      END DO
-    ELSE
-      DO i = 1, len
-        posit(i) = (sign(1.,plclfeed(i)-pfeed(i))+1.)*0.5
-        IF (plclfeed(i)==pfeed(i)) posit(i) = 1.
-      END DO
-    END IF
-!jyg>
-    DO i = 1, len
-! - posit = 1 when lcl is below top of feeding layer (plclfeed>pfeed)
-! -               => pup=pfeed
-! - posit = 0 when lcl is above top of feeding layer (plclfeed<pfeed)
-! -               => plo=pfeed
-      pup(i) = posit(i)*pfeed(i) + (1.-posit(i))*pup(i)
-      plo(i) = (1.-posit(i))*pfeed(i) + posit(i)*plo(i)
-      plclup(i) = posit(i)*plclfeed(i) + (1.-posit(i))*plclup(i)
-      plcllo(i) = (1.-posit(i))*plclfeed(i) + posit(i)*plcllo(i)
-    END DO
-  END DO !  iter
-
-  DO i = 1, len
-    p2feed(i) = pfeed(i)
-    plcl(i) = plclfeed(i)
-  END DO
-
-  DO i = 1, len
-    cpnk(i) = cpd*(1.0-qnk(i)) + cpv*qnk(i)
-    hnk(i) = gz(i, 1) + cpnk(i)*tnk(i)
-  END DO
-
-! -------------------------------------------------------------------
-! --- Check whether parcel level temperature and specific humidity
-! --- are reasonable
-! -------------------------------------------------------------------
-  IF (cv_flag_feed == 1) THEN
-    DO i = 1, len
-      IF (((tnk(i)<250.0)                       .OR.  &
-           (qnk(i)<=0.0))                       .AND. &
-          (iflag(i)==0)) iflag(i) = 7
-    END DO
-  ELSEIF (cv_flag_feed >= 2) THEN
-! --- and demand that LCL be high enough
-    DO i = 1, len
-      IF (((tnk(i)<250.0)                       .OR.  &
-           (qnk(i)<=0.0)                        .OR.  &
-           (plcl(i)>min(0.99*ph(i,1),ph(i,3)))) .AND. &
-          (iflag(i)==0)) iflag(i) = 7
-    END DO
-  ENDIF
-  IF (prt_level .GE. 10) THEN
-    print *,'cv3_feed : iflag(1), pfeed(1), plcl(1), wghti(1,k) ', &
-                        iflag(1), pfeed(1), plcl(1), (wghti(1,k),k=1,10)
-  ENDIF
-
-! -------------------------------------------------------------------
-! --- Calculate first level above lcl (=icb)
-! -------------------------------------------------------------------
-
-!@      do 270 i=1,len
-!@       icb(i)=nlm
-!@ 270  continue
-!@c
-!@      do 290 k=minorig,nl
-!@        do 280 i=1,len
-!@          if((k.ge.(nk(i)+1)).and.(p(i,k).lt.plcl(i)))
-!@     &    icb(i)=min(icb(i),k)
-!@ 280    continue
-!@ 290  continue
-!@c
-!@      do 300 i=1,len
-!@        if((icb(i).ge.nlm).and.(iflag(i).eq.0))iflag(i)=9
-!@ 300  continue
-
-  DO i = 1, len
-    icb(i) = nlm
-  END DO
-
-! la modification consiste a comparer plcl a ph et non a p:
-! icb est defini par :  ph(icb)<plcl<ph(icb-1)
-!@      do 290 k=minorig,nl
-  DO k = 3, nl - 1 ! modif pour que icb soit sup/egal a 2
-    DO i = 1, len
-      IF (ph(i,k)<plcl(i)) icb(i) = min(icb(i), k)
-    END DO
-  END DO
-
-
-! print*,'icb dans cv3_feed '
-! write(*,'(64i2)') icb(2:len-1)
-! call dump2d(64,43,'plcl dans cv3_feed ',plcl(2:len-1))
-
-  DO i = 1, len
-!@        if((icb(i).ge.nlm).and.(iflag(i).eq.0))iflag(i)=9
-    IF ((icb(i)==nlm) .AND. (iflag(i)==0)) iflag(i) = 9
-  END DO
-
-  DO i = 1, len
-    icb(i) = icb(i) - 1 ! icb sup ou egal a 2
-  END DO
-
-! Compute icbmax.
-
-  icbmax = 2
-  DO i = 1, len
-!!        icbmax=max(icbmax,icb(i))
-    IF (iflag(i)<7) icbmax = max(icbmax, icb(i))     ! sb Jun7th02
-  END DO
-
-  RETURN
-END SUBROUTINE cv3_feed
-
-SUBROUTINE cv3_undilute1(len, nd, t, qs, gz, plcl, p, icb, tnk, qnk, gznk, &
-                         tp, tvp, clw, icbs)
-  IMPLICIT NONE
-
-! ----------------------------------------------------------------
-! Equivalent de TLIFT entre NK et ICB+1 inclus
-
-! Differences with convect4:
-!    - specify plcl in input
-!    - icbs is the first level above LCL (may differ from icb)
-!    - in the iterations, used x(icbs) instead x(icb)
-!    - many minor differences in the iterations
-!    - tvp is computed in only one time
-!    - icbs: first level above Plcl (IMIN de TLIFT) in output
-!    - if icbs=icb, compute also tp(icb+1),tvp(icb+1) & clw(icb+1)
-! ----------------------------------------------------------------
-
-  include "cvthermo.h"
-  include "cv3param.h"
-
-! inputs:
-  INTEGER, INTENT (IN)                              :: len, nd
-  INTEGER, DIMENSION (len), INTENT (IN)             :: icb
-  REAL, DIMENSION (len, nd), INTENT (IN)            :: t, qs, gz
-  REAL, DIMENSION (len), INTENT (IN)                :: tnk, qnk, gznk
-  REAL, DIMENSION (len, nd), INTENT (IN)            :: p
-  REAL, DIMENSION (len), INTENT (IN)                :: plcl              ! convect3
-
-! outputs:
-  INTEGER, DIMENSION (len), INTENT (OUT)            :: icbs
-  REAL, DIMENSION (len, nd), INTENT (OUT)           :: tp, tvp, clw
-
-! local variables:
-  INTEGER i, k
-  INTEGER icb1(len), icbsmax2                                            ! convect3
-  REAL tg, qg, alv, s, ahg, tc, denom, es, rg
-  REAL ah0(len), cpp(len)
-  REAL ticb(len), gzicb(len)
-  REAL qsicb(len)                                                        ! convect3
-  REAL cpinv(len)                                                        ! convect3
-
-! -------------------------------------------------------------------
-! --- Calculates the lifted parcel virtual temperature at nk,
-! --- the actual temperature, and the adiabatic
-! --- liquid water content. The procedure is to solve the equation.
-!     cp*tp+L*qp+phi=cp*tnk+L*qnk+gznk.
-! -------------------------------------------------------------------
-
-
-! ***  Calculate certain parcel quantities, including static energy   ***
-
-  DO i = 1, len
-    ah0(i) = (cpd*(1.-qnk(i))+cl*qnk(i))*tnk(i) + qnk(i)*(lv0-clmcpv*(tnk(i)-273.15)) + gznk(i)
-    cpp(i) = cpd*(1.-qnk(i)) + qnk(i)*cpv
-    cpinv(i) = 1./cpp(i)
-  END DO
-
-! ***   Calculate lifted parcel quantities below cloud base   ***
-
-  DO i = 1, len                                           !convect3
-    icb1(i) = min(max(icb(i), 2), nl)
-! if icb is below LCL, start loop at ICB+1:
-! (icbs est le premier niveau au-dessus du LCL)
-    icbs(i) = icb1(i)                                     !convect3
-    IF (plcl(i)<p(i,icb1(i))) THEN
-      icbs(i) = min(icbs(i)+1, nl)                        !convect3
-    END IF
-  END DO                                                  !convect3
-
-  DO i = 1, len !convect3
-    ticb(i) = t(i, icbs(i))                               !convect3
-    gzicb(i) = gz(i, icbs(i))                             !convect3
-    qsicb(i) = qs(i, icbs(i))                             !convect3
-  END DO !convect3
-
-
-! Re-compute icbsmax (icbsmax2):                          !convect3
-!                                                         !convect3
-  icbsmax2 = 2                                            !convect3
-  DO i = 1, len                                           !convect3
-    icbsmax2 = max(icbsmax2, icbs(i))                     !convect3
-  END DO                                                  !convect3
-
-! initialization outputs:
-
-  DO k = 1, icbsmax2                                      ! convect3
-    DO i = 1, len                                         ! convect3
-      tp(i, k) = 0.0                                      ! convect3
-      tvp(i, k) = 0.0                                     ! convect3
-      clw(i, k) = 0.0                                     ! convect3
-    END DO                                                ! convect3
-  END DO                                                  ! convect3
-
-! tp and tvp below cloud base:
-
-  DO k = minorig, icbsmax2 - 1
-    DO i = 1, len
-      tp(i, k) = tnk(i) - (gz(i,k)-gznk(i))*cpinv(i)
-      tvp(i, k) = tp(i, k)*(1.+qnk(i)/eps-qnk(i))        !whole thing (convect3)
-    END DO
-  END DO
-
-! ***  Find lifted parcel quantities above cloud base    ***
-
-  DO i = 1, len
-    tg = ticb(i)
-! ori         qg=qs(i,icb(i))
-    qg = qsicb(i) ! convect3
-! debug         alv=lv0-clmcpv*(ticb(i)-t0)
-    alv = lv0 - clmcpv*(ticb(i)-273.15)
-
-! First iteration.
-
-! ori          s=cpd+alv*alv*qg/(rrv*ticb(i)*ticb(i))
-    s = cpd*(1.-qnk(i)) + cl*qnk(i) + &                   ! convect3
-        alv*alv*qg/(rrv*ticb(i)*ticb(i))                  ! convect3
-    s = 1./s
-! ori          ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i)
-    ahg = cpd*tg + (cl-cpd)*qnk(i)*tg + alv*qg + gzicb(i) ! convect3
-    tg = tg + s*(ah0(i)-ahg)
-! ori          tg=max(tg,35.0)
-! debug          tc=tg-t0
-    tc = tg - 273.15
-    denom = 243.5 + tc
-    denom = max(denom, 1.0) ! convect3
-! ori          if(tc.ge.0.0)then
-    es = 6.112*exp(17.67*tc/denom)
-! ori          else
-! ori           es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
-! ori          endif
-! ori          qg=eps*es/(p(i,icb(i))-es*(1.-eps))
-    qg = eps*es/(p(i,icbs(i))-es*(1.-eps))
-
-! Second iteration.
-
-
-! ori          s=cpd+alv*alv*qg/(rrv*ticb(i)*ticb(i))
-! ori          s=1./s
-! ori          ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i)
-    ahg = cpd*tg + (cl-cpd)*qnk(i)*tg + alv*qg + gzicb(i) ! convect3
-    tg = tg + s*(ah0(i)-ahg)
-! ori          tg=max(tg,35.0)
-! debug          tc=tg-t0
-    tc = tg - 273.15
-    denom = 243.5 + tc
-    denom = max(denom, 1.0)                               ! convect3
-! ori          if(tc.ge.0.0)then
-    es = 6.112*exp(17.67*tc/denom)
-! ori          else
-! ori           es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
-! ori          end if
-! ori          qg=eps*es/(p(i,icb(i))-es*(1.-eps))
-    qg = eps*es/(p(i,icbs(i))-es*(1.-eps))
-
-    alv = lv0 - clmcpv*(ticb(i)-273.15)
-
-! ori c approximation here:
-! ori         tp(i,icb(i))=(ah0(i)-(cl-cpd)*qnk(i)*ticb(i)
-! ori     &   -gz(i,icb(i))-alv*qg)/cpd
-
-! convect3: no approximation:
-    tp(i, icbs(i)) = (ah0(i)-gz(i,icbs(i))-alv*qg)/(cpd+(cl-cpd)*qnk(i))
-
-! ori         clw(i,icb(i))=qnk(i)-qg
-! ori         clw(i,icb(i))=max(0.0,clw(i,icb(i)))
-    clw(i, icbs(i)) = qnk(i) - qg
-    clw(i, icbs(i)) = max(0.0, clw(i,icbs(i)))
-
-    rg = qg/(1.-qnk(i))
-! ori         tvp(i,icb(i))=tp(i,icb(i))*(1.+rg*epsi)
-! convect3: (qg utilise au lieu du vrai mixing ratio rg)
-    tvp(i, icbs(i)) = tp(i, icbs(i))*(1.+qg/eps-qnk(i))   !whole thing
-
-  END DO
-
-! ori      do 380 k=minorig,icbsmax2
-! ori       do 370 i=1,len
-! ori         tvp(i,k)=tvp(i,k)-tp(i,k)*qnk(i)
-! ori 370   continue
-! ori 380  continue
-
-
-! -- The following is only for convect3:
-
-! * icbs is the first level above the LCL:
-! if plcl<p(icb), then icbs=icb+1
-! if plcl>p(icb), then icbs=icb
-
-! * the routine above computes tvp from minorig to icbs (included).
-
-! * to compute buoybase (in cv3_trigger.F), both tvp(icb) and tvp(icb+1)
-! must be known. This is the case if icbs=icb+1, but not if icbs=icb.
-
-! * therefore, in the case icbs=icb, we compute tvp at level icb+1
-! (tvp at other levels will be computed in cv3_undilute2.F)
-
-
-  DO i = 1, len
-    ticb(i) = t(i, icb(i)+1)
-    gzicb(i) = gz(i, icb(i)+1)
-    qsicb(i) = qs(i, icb(i)+1)
-  END DO
-
-  DO i = 1, len
-    tg = ticb(i)
-    qg = qsicb(i) ! convect3
-! debug         alv=lv0-clmcpv*(ticb(i)-t0)
-    alv = lv0 - clmcpv*(ticb(i)-273.15)
-
-! First iteration.
-
-! ori          s=cpd+alv*alv*qg/(rrv*ticb(i)*ticb(i))
-    s = cpd*(1.-qnk(i)) + cl*qnk(i) &                         ! convect3
-      +alv*alv*qg/(rrv*ticb(i)*ticb(i))                       ! convect3
-    s = 1./s
-! ori          ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i)
-    ahg = cpd*tg + (cl-cpd)*qnk(i)*tg + alv*qg + gzicb(i)     ! convect3
-    tg = tg + s*(ah0(i)-ahg)
-! ori          tg=max(tg,35.0)
-! debug          tc=tg-t0
-    tc = tg - 273.15
-    denom = 243.5 + tc
-    denom = max(denom, 1.0)                                   ! convect3
-! ori          if(tc.ge.0.0)then
-    es = 6.112*exp(17.67*tc/denom)
-! ori          else
-! ori           es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
-! ori          endif
-! ori          qg=eps*es/(p(i,icb(i))-es*(1.-eps))
-    qg = eps*es/(p(i,icb(i)+1)-es*(1.-eps))
-
-! Second iteration.
-
-
-! ori          s=cpd+alv*alv*qg/(rrv*ticb(i)*ticb(i))
-! ori          s=1./s
-! ori          ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i)
-    ahg = cpd*tg + (cl-cpd)*qnk(i)*tg + alv*qg + gzicb(i)     ! convect3
-    tg = tg + s*(ah0(i)-ahg)
-! ori          tg=max(tg,35.0)
-! debug          tc=tg-t0
-    tc = tg - 273.15
-    denom = 243.5 + tc
-    denom = max(denom, 1.0)                                   ! convect3
-! ori          if(tc.ge.0.0)then
-    es = 6.112*exp(17.67*tc/denom)
-! ori          else
-! ori           es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
-! ori          end if
-! ori          qg=eps*es/(p(i,icb(i))-es*(1.-eps))
-    qg = eps*es/(p(i,icb(i)+1)-es*(1.-eps))
-
-    alv = lv0 - clmcpv*(ticb(i)-273.15)
-
-! ori c approximation here:
-! ori         tp(i,icb(i))=(ah0(i)-(cl-cpd)*qnk(i)*ticb(i)
-! ori     &   -gz(i,icb(i))-alv*qg)/cpd
-
-! convect3: no approximation:
-    tp(i, icb(i)+1) = (ah0(i)-gz(i,icb(i)+1)-alv*qg)/(cpd+(cl-cpd)*qnk(i))
-
-! ori         clw(i,icb(i))=qnk(i)-qg
-! ori         clw(i,icb(i))=max(0.0,clw(i,icb(i)))
-    clw(i, icb(i)+1) = qnk(i) - qg
-    clw(i, icb(i)+1) = max(0.0, clw(i,icb(i)+1))
-
-    rg = qg/(1.-qnk(i))
-! ori         tvp(i,icb(i))=tp(i,icb(i))*(1.+rg*epsi)
-! convect3: (qg utilise au lieu du vrai mixing ratio rg)
-    tvp(i, icb(i)+1) = tp(i, icb(i)+1)*(1.+qg/eps-qnk(i))     !whole thing
-
-  END DO
-
-  RETURN
-END SUBROUTINE cv3_undilute1
-
-SUBROUTINE cv3_trigger(len, nd, icb, plcl, p, th, tv, tvp, thnk, &
-                       pbase, buoybase, iflag, sig, w0)
-  IMPLICIT NONE
-
-! -------------------------------------------------------------------
-! --- TRIGGERING
-
-! - computes the cloud base
-! - triggering (crude in this version)
-! - relaxation of sig and w0 when no convection
-
-! Caution1: if no convection, we set iflag=14
-! (it used to be 0 in convect3)
-
-! Caution2: at this stage, tvp (and thus buoy) are know up
-! through icb only!
-! -> the buoyancy below cloud base not (yet) set to the cloud base buoyancy
-! -------------------------------------------------------------------
-
-  include "cv3param.h"
-
-! input:
-  INTEGER len, nd
-  INTEGER icb(len)
-  REAL plcl(len), p(len, nd)
-  REAL th(len, nd), tv(len, nd), tvp(len, nd)
-  REAL thnk(len)
-
-! output:
-  REAL pbase(len), buoybase(len)
-
-! input AND output:
-  INTEGER iflag(len)
-  REAL sig(len, nd), w0(len, nd)
-
-! local variables:
-  INTEGER i, k
-  REAL tvpbase, tvbase, tdif, ath, ath1
-
-
-! ***   set cloud base buoyancy at (plcl+dpbase) level buoyancy
-
-  DO i = 1, len
-    pbase(i) = plcl(i) + dpbase
-    tvpbase = tvp(i, icb(i))  *(pbase(i)-p(i,icb(i)+1))/(p(i,icb(i))-p(i,icb(i)+1)) + &
-              tvp(i, icb(i)+1)*(p(i,icb(i))-pbase(i))  /(p(i,icb(i))-p(i,icb(i)+1))
-    tvbase = tv(i, icb(i))  *(pbase(i)-p(i,icb(i)+1))/(p(i,icb(i))-p(i,icb(i)+1)) + &
-             tv(i, icb(i)+1)*(p(i,icb(i))-pbase(i))  /(p(i,icb(i))-p(i,icb(i)+1))
-    buoybase(i) = tvpbase - tvbase
-  END DO
-
-
-! ***   make sure that column is dry adiabatic between the surface  ***
-! ***    and cloud base, and that lifted air is positively buoyant  ***
-! ***                         at cloud base                         ***
-! ***       if not, return to calling program after resetting       ***
-! ***                        sig(i) and w0(i)                       ***
-
-
-! oct3      do 200 i=1,len
-! oct3
-! oct3       tdif = buoybase(i)
-! oct3       ath1 = th(i,1)
-! oct3       ath  = th(i,icb(i)-1) - dttrig
-! oct3
-! oct3       if (tdif.lt.dtcrit .or. ath.gt.ath1) then
-! oct3         do 60 k=1,nl
-! oct3            sig(i,k) = beta*sig(i,k) - 2.*alpha*tdif*tdif
-! oct3            sig(i,k) = AMAX1(sig(i,k),0.0)
-! oct3            w0(i,k)  = beta*w0(i,k)
-! oct3   60    continue
-! oct3         iflag(i)=4 ! pour version vectorisee
-! oct3c convect3         iflag(i)=0
-! oct3cccc         return
-! oct3       endif
-! oct3
-! oct3200   continue
-
-! -- oct3: on reecrit la boucle 200 (pour la vectorisation)
-
-  DO k = 1, nl
-    DO i = 1, len
-
-      tdif = buoybase(i)
-      ath1 = thnk(i)
-      ath = th(i, icb(i)-1) - dttrig
-
-      IF (tdif<dtcrit .OR. ath>ath1) THEN
-        sig(i, k) = beta*sig(i, k) - 2.*alpha*tdif*tdif
-        sig(i, k) = amax1(sig(i,k), 0.0)
-        w0(i, k) = beta*w0(i, k)
-        iflag(i) = 14 ! pour version vectorisee
-! convect3         iflag(i)=0
-      END IF
-
-    END DO
-  END DO
-
-! fin oct3 --
-
-  RETURN
-END SUBROUTINE cv3_trigger
-
-SUBROUTINE cv3_compress(len, nloc, ncum, nd, ntra, &
-                        iflag1, nk1, icb1, icbs1, &
-                        plcl1, tnk1, qnk1, gznk1, pbase1, buoybase1, &
-                        t1, q1, qs1, u1, v1, gz1, th1, &
-                        tra1, &
-                        h1, lv1, cpn1, p1, ph1, tv1, tp1, tvp1, clw1, &
-                        sig1, w01, &
-                        iflag, nk, icb, icbs, &
-                        plcl, tnk, qnk, gznk, pbase, buoybase, &
-                        t, q, qs, u, v, gz, th, &
-                        tra, &
-                        h, lv, cpn, p, ph, tv, tp, tvp, clw, &
-                        sig, w0)
-  USE print_control_mod, ONLY: lunout
-  IMPLICIT NONE
-
-  include "cv3param.h"
-
-!inputs:
-  INTEGER len, ncum, nd, ntra, nloc
-  INTEGER iflag1(len), nk1(len), icb1(len), icbs1(len)
-  REAL plcl1(len), tnk1(len), qnk1(len), gznk1(len)
-  REAL pbase1(len), buoybase1(len)
-  REAL t1(len, nd), q1(len, nd), qs1(len, nd), u1(len, nd), v1(len, nd)
-  REAL gz1(len, nd), h1(len, nd), lv1(len, nd), cpn1(len, nd)
-  REAL p1(len, nd), ph1(len, nd+1), tv1(len, nd), tp1(len, nd)
-  REAL tvp1(len, nd), clw1(len, nd)
-  REAL th1(len, nd)
-  REAL sig1(len, nd), w01(len, nd)
-  REAL tra1(len, nd, ntra)
-
-!outputs:
-! en fait, on a nloc=len pour l'instant (cf cv_driver)
-  INTEGER iflag(nloc), nk(nloc), icb(nloc), icbs(nloc)
-  REAL plcl(nloc), tnk(nloc), qnk(nloc), gznk(nloc)
-  REAL pbase(nloc), buoybase(nloc)
-  REAL t(nloc, nd), q(nloc, nd), qs(nloc, nd), u(nloc, nd), v(nloc, nd)
-  REAL gz(nloc, nd), h(nloc, nd), lv(nloc, nd), cpn(nloc, nd)
-  REAL p(nloc, nd), ph(nloc, nd+1), tv(nloc, nd), tp(nloc, nd)
-  REAL tvp(nloc, nd), clw(nloc, nd)
-  REAL th(nloc, nd)
-  REAL sig(nloc, nd), w0(nloc, nd)
-  REAL tra(nloc, nd, ntra)
-
-!local variables:
-  INTEGER i, k, nn, j
-
-  CHARACTER (LEN=20) :: modname = 'cv3_compress'
-  CHARACTER (LEN=80) :: abort_message
-
-  DO k = 1, nl + 1
-    nn = 0
-    DO i = 1, len
-      IF (iflag1(i)==0) THEN
-        nn = nn + 1
-        sig(nn, k) = sig1(i, k)
-        w0(nn, k) = w01(i, k)
-        t(nn, k) = t1(i, k)
-        q(nn, k) = q1(i, k)
-        qs(nn, k) = qs1(i, k)
-        u(nn, k) = u1(i, k)
-        v(nn, k) = v1(i, k)
-        gz(nn, k) = gz1(i, k)
-        h(nn, k) = h1(i, k)
-        lv(nn, k) = lv1(i, k)
-        cpn(nn, k) = cpn1(i, k)
-        p(nn, k) = p1(i, k)
-        ph(nn, k) = ph1(i, k)
-        tv(nn, k) = tv1(i, k)
-        tp(nn, k) = tp1(i, k)
-        tvp(nn, k) = tvp1(i, k)
-        clw(nn, k) = clw1(i, k)
-        th(nn, k) = th1(i, k)
-      END IF
-    END DO
-  END DO
-
-!AC!      do 121 j=1,ntra
-!AC!ccccc      do 111 k=1,nl+1
-!AC!      do 111 k=1,nd
-!AC!       nn=0
-!AC!      do 101 i=1,len
-!AC!      if(iflag1(i).eq.0)then
-!AC!       nn=nn+1
-!AC!       tra(nn,k,j)=tra1(i,k,j)
-!AC!      endif
-!AC! 101  continue
-!AC! 111  continue
-!AC! 121  continue
-
-  IF (nn/=ncum) THEN
-    WRITE (lunout, *) 'strange! nn not equal to ncum: ', nn, ncum
-    abort_message = ''
-    CALL abort_physic(modname, abort_message, 1)
-  END IF
-
-  nn = 0
-  DO i = 1, len
-    IF (iflag1(i)==0) THEN
-      nn = nn + 1
-      pbase(nn) = pbase1(i)
-      buoybase(nn) = buoybase1(i)
-      plcl(nn) = plcl1(i)
-      tnk(nn) = tnk1(i)
-      qnk(nn) = qnk1(i)
-      gznk(nn) = gznk1(i)
-      nk(nn) = nk1(i)
-      icb(nn) = icb1(i)
-      icbs(nn) = icbs1(i)
-      iflag(nn) = iflag1(i)
-    END IF
-  END DO
-
-  RETURN
-END SUBROUTINE cv3_compress
-
-SUBROUTINE icefrac(t, clw, qi, nl, len)
-  IMPLICIT NONE
-
-
-!JAM--------------------------------------------------------------------
-! Calcul de la quantité d'eau sous forme de glace
-! --------------------------------------------------------------------
-  INTEGER nl, len
-  REAL qi(len, nl)
-  REAL t(len, nl), clw(len, nl)
-  REAL fracg
-  INTEGER k, i
-
-  DO k = 3, nl
-    DO i = 1, len
-      IF (t(i,k)>263.15) THEN
-        qi(i, k) = 0.
-      ELSE
-        IF (t(i,k)<243.15) THEN
-          qi(i, k) = clw(i, k)
-        ELSE
-          fracg = (263.15-t(i,k))/20
-          qi(i, k) = clw(i, k)*fracg
-        END IF
-      END IF
-! print*,t(i,k),qi(i,k),'temp,testglace'
-    END DO
-  END DO
-
-  RETURN
-
-END SUBROUTINE icefrac
-
-SUBROUTINE cv3_undilute2(nloc, ncum, nd, iflag, icb, icbs, nk, &
-                         tnk, qnk, gznk, hnk, t, q, qs, gz, &
-                         p, ph, h, tv, lv, lf, pbase, buoybase, plcl, &
-                         inb, tp, tvp, clw, hp, ep, sigp, buoy, &
-                         frac_a, frac_s, qpreca, qta)
-  USE print_control_mod, ONLY: prt_level
-  IMPLICIT NONE
-
-! ---------------------------------------------------------------------
-! Purpose:
-! FIND THE REST OF THE LIFTED PARCEL TEMPERATURES
-! &
-! COMPUTE THE PRECIPITATION EFFICIENCIES AND THE
-! FRACTION OF PRECIPITATION FALLING OUTSIDE OF CLOUD
-! &
-! FIND THE LEVEL OF NEUTRAL BUOYANCY
-
-! Main differences convect3/convect4:
-!   - icbs (input) is the first level above LCL (may differ from icb)
-!   - many minor differences in the iterations
-!   - condensed water not removed from tvp in convect3
-!   - vertical profile of buoyancy computed here (use of buoybase)
-!   - the determination of inb is different
-!   - no inb1, only inb in output
-! ---------------------------------------------------------------------
-
-  include "cvthermo.h"
-  include "cv3param.h"
-  include "conema3.h"
-  include "cvflag.h"
-  include "YOMCST2.h"
-
-!inputs:
-  INTEGER, INTENT (IN)                               :: ncum, nd, nloc
-  INTEGER, DIMENSION (nloc), INTENT (IN)             :: icb, icbs, nk
-  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: t, q, qs, gz
-  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: p
-  REAL, DIMENSION (nloc, nd+1), INTENT (IN)          :: ph
-  REAL, DIMENSION (nloc), INTENT (IN)                :: tnk, qnk, gznk
-  REAL, DIMENSION (nloc), INTENT (IN)                :: hnk
-  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: lv, lf, tv, h
-  REAL, DIMENSION (nloc), INTENT (IN)                :: pbase, buoybase, plcl
-
-!input/outputs:
-  REAL, DIMENSION (nloc, nd), INTENT (INOUT)         :: tp, tvp, clw   ! Input for k = 1, icb+1 (computed in cv3_undilute1)
-                                                                       ! Output above
-  INTEGER, DIMENSION (nloc), INTENT (INOUT)          :: iflag
-
-!outputs:
-  INTEGER, DIMENSION (nloc), INTENT (OUT)            :: inb
-  REAL, DIMENSION (nloc, nd), INTENT (OUT)           :: ep, sigp, hp
-  REAL, DIMENSION (nloc, nd), INTENT (OUT)           :: buoy
-  REAL, DIMENSION (nloc, nd), INTENT (OUT)           :: frac_a, frac_s
-  REAL, DIMENSION (nloc, nd), INTENT (OUT)           :: qpreca
-  REAL, DIMENSION (nloc, nd), INTENT (OUT)           :: qta
-
-!local variables:
-  INTEGER i, j, k
-  REAL smallestreal
-  REAL tg, qg, dqgdT, ahg, alv, alf, s, tc, es, esi, denom, rg, tca, elacrit
-  REAL                                               :: phinu2p
-  REAL                                               :: qhthreshold
-  REAL                                               :: als
-  REAL                                               :: qsat_new, snew
-  REAL, DIMENSION (nloc,nd)                          :: qi
-  REAL, DIMENSION (nloc,nd)                          :: ha    ! moist static energy of adiabatic ascents 
-                                                              ! taking into account precip ejection
-  REAL, DIMENSION (nloc,nd)                          :: hla   ! liquid water static energy of adiabatic ascents 
-                                                              ! taking into account precip ejection
-  REAL, DIMENSION (nloc,nd)                          :: qcld  ! specific cloud water
-  REAL, DIMENSION (nloc,nd)                          :: qhsat    ! specific humidity at saturation
-  REAL, DIMENSION (nloc,nd)                          :: dqhsatdT ! dqhsat/dT
-  REAL, DIMENSION (nloc,nd)                          :: frac  ! ice fraction function of envt temperature
-  REAL, DIMENSION (nloc,nd)                          :: qps   ! specific solid precipitation
-  REAL, DIMENSION (nloc,nd)                          :: qpl   ! specific liquid precipitation
-  REAL, DIMENSION (nloc)                             :: ah0, cape, capem, byp
-  LOGICAL, DIMENSION (nloc)                          :: lcape
-  INTEGER, DIMENSION (nloc)                          :: iposit
-  REAL                                               :: denomm1
-  REAL                                               :: by, defrac, pden, tbis
-  REAL                                               :: fracg
-  REAL                                               :: deltap
-  REAL, SAVE                                         :: Tx, Tm
-  DATA Tx/263.15/, Tm/243.15/
-!$OMP THREADPRIVATE(Tx, Tm)
-  REAL                                               :: aa, bb, dd, ddelta, discr
-  REAL                                               :: ff, fp
-  REAL                                               :: coefx, coefm, Zx, Zm, Ux, U, Um
-
-  IF (prt_level >= 10) THEN
-    print *,'cv3_undilute2.0. icvflag_Tpa, t(1,k), q(1,k), qs(1,k) ', &
-                        icvflag_Tpa, (k, t(1,k), q(1,k), qs(1,k), k = 1,nl)
-  ENDIF
-  smallestreal=tiny(smallestreal)
-
-! =====================================================================
-! --- SOME INITIALIZATIONS
-! =====================================================================
-
-  DO k = 1, nl
-    DO i = 1, ncum
-      qi(i, k) = 0.
-    END DO
-  END DO
-
-
-! =====================================================================
-! --- FIND THE REST OF THE LIFTED PARCEL TEMPERATURES
-! =====================================================================
-
-! ---       The procedure is to solve the equation.
-!                cp*tp+L*qp+phi=cp*tnk+L*qnk+gznk.
-
-! ***  Calculate certain parcel quantities, including static energy   ***
-
-
-  DO i = 1, ncum
-    ah0(i) = (cpd*(1.-qnk(i))+cl*qnk(i))*tnk(i)+ & 
-! debug          qnk(i)*(lv0-clmcpv*(tnk(i)-t0))+gznk(i)
-             qnk(i)*(lv0-clmcpv*(tnk(i)-273.15)) + gznk(i)
-  END DO
-!
-!  Ice fraction
-!
-  IF (cvflag_ice) THEN
-    DO k = minorig, nl
-      DO i = 1, ncum
-          frac(i, k) = (Tx - t(i,k))/(Tx - Tm)
-          frac(i, k) = min(max(frac(i,k),0.0), 1.0)
-      END DO
-    END DO
-! Below cloud base, set ice fraction to cloud base value
-    DO k = 1, nl
-      DO i = 1, ncum
-        IF (k<icb(i)) THEN
-          frac(i,k) = frac(i,icb(i))
-        END IF
-      END DO
-    END DO
-  ELSE
-    DO k = 1, nl
-      DO i = 1, ncum
-          frac(i,k) = 0.
-      END DO
-    END DO
-  ENDIF ! (cvflag_ice)
-
-
-  DO k = minorig, nl
-    DO i = 1,ncum
-      ha(i,k) = ah0(i)
-      hla(i,k) = hnk(i)
-      qta(i,k) = qnk(i)
-      qpreca(i,k) = 0.
-      frac_a(i,k) = 0.
-      frac_s(i,k) = frac(i,k)
-      qpl(i,k) = 0.
-      qps(i,k) = 0.
-      qhsat(i,k) = qs(i,k)
-      qcld(i,k) = max(qta(i,k)-qhsat(i,k),0.)
-      IF (k <= icb(i)+1) THEN
-        qhsat(i,k) = qnk(i)-clw(i,k)
-        qcld(i,k) = clw(i,k)
-      ENDIF 
-    ENDDO
-  ENDDO
-
-!jyg<
-! =====================================================================
-! --- SET THE THE FRACTION OF PRECIPITATION FALLING OUTSIDE OF CLOUD
-! =====================================================================
-  DO k = 1, nl
-    DO i = 1, ncum
-      ep(i, k) = 0.0
-      sigp(i, k) = spfac
-    END DO
-  END DO
-!>jyg
-!
-
-! ***  Find lifted parcel quantities above cloud base    ***
-
-!----------------------------------------------------------------------------
-!
-  IF (icvflag_Tpa == 2) THEN
-!
-!----------------------------------------------------------------------------
-!
-    DO k = minorig + 1, nl
-      DO i = 1,ncum
-        tp(i,k) = t(i,k)
-      ENDDO
-!!      alv = lv0 - clmcpv*(t(i,k)-273.15)
-!!      alf = lf0 + clmci*(t(i,k)-273.15)
-!!      als = alf + alv
-      DO j = 1,4
-        DO i = 1, ncum
-! ori	    if(k.ge.(icb(i)+1))then
-          IF (k>=(icbs(i)+1)) THEN                                ! convect3
-            tg = tp(i, k)
-            IF (tg .gt. Tx) THEN
-              es = 6.112*exp(17.67*(tg - 273.15)/(tg + 243.5 - 273.15))
-              qg = eps*es/(p(i,k)-es*(1.-eps))
-            ELSE
-              esi = exp(23.33086-(6111.72784/tg)+0.15215*log(tg))
-              qg = eps*esi/(p(i,k)-esi*(1.-eps))
-            ENDIF
-! Ice fraction
-            ff = 0.
-            fp = 1./(Tx - Tm)
-            IF (tg < Tx) THEN
-              IF (tg > Tm) THEN
-                ff = (Tx - tg)*fp
-              ELSE
-                ff = 1.
-              ENDIF ! (tg > Tm)
-            ENDIF ! (tg < Tx)
-! Intermediate variables
-            aa = cpd + (cl-cpd)*qnk(i) + lv(i,k)*lv(i,k)*qg/(rrv*tg*tg)
-            ahg = (cpd + (cl-cpd)*qnk(i))*tg + lv(i,k)*qg - &
-                  lf(i,k)*ff*(qnk(i) - qg) + gz(i,k)
-            dd = lf(i,k)*lv(i,k)*qg/(rrv*tg*tg)
-            ddelta = lf(i,k)*(qnk(i) - qg)
-            bb = aa + ddelta*fp + dd*fp*(Tx-tg)
-! Compute Zx and Zm
-            coefx = aa
-            coefm = aa + dd
-            IF (tg .gt. Tx) THEN
-              Zx = ahg            + coefx*(Tx - tg)
-              Zm = ahg - ddelta   + coefm*(Tm - tg)
-            ELSE
-              IF (tg .gt. Tm) THEN
-                Zx = ahg          + (coefx +fp*ddelta)*(Tx - Tg)
-                Zm = ahg          + (coefm +fp*ddelta)*(Tm - Tg)
-              ELSE
-                Zx = ahg + ddelta + coefx*(Tx - tg)
-                Zm = ahg          + coefm*(Tm - tg)
-              ENDIF ! (tg .gt. Tm)
-            ENDIF ! (tg .gt. Tx)
-! Compute the masks Um, U, Ux
-            Um = (sign(1., Zm-ah0(i))+1.)/2.
-            Ux = (sign(1., ah0(i)-Zx)+1.)/2.
-            U = (1. - Um)*(1. - Ux)
-! Compute the updated parcell temperature Tp : 3 cases depending on tg value
-            IF (tg .gt. Tx) THEN
-              discr = bb*bb - 4*dd*fp*(ah0(i) - ahg + ddelta*fp*(Tx-tg))
-              Tp(i,k) = tg + &
-                  Um*  (ah0(i) - ahg + ddelta)           /(aa + dd) + &
-                  U *2*(ah0(i) - ahg + ddelta*fp*(Tx-tg))/(bb + sqrt(discr)) + &
-                  Ux*  (ah0(i) - ahg)                    /aa
-            ELSEIF (tg .gt. Tm) THEN
-              discr = bb*bb - 4*dd*fp*(ah0(i) - ahg)
-              Tp(i,k) = tg + &
-                  Um*  (ah0(i) - ahg + ddelta*fp*(tg-Tm))/(aa + dd) + &
-                  U *2*(ah0(i) - ahg)                    /(bb + sqrt(discr)) + &
-                  Ux*  (ah0(i) - ahg + ddelta*fp*(tg-Tx))/aa
-            ELSE
-              discr = bb*bb - 4*dd*fp*(ah0(i) - ahg + ddelta*fp*(Tm-tg))
-              Tp(i,k) = tg + &
-                  Um*  (ah0(i) - ahg)                    /(aa + dd) + &
-                  U *2*(ah0(i) - ahg + ddelta*fp*(Tm-tg))/(bb + sqrt(discr)) + &
-                  Ux*  (ah0(i) - ahg - ddelta)           /aa
-            ENDIF ! (tg .gt. Tx)
-!
-!!     print *,' j, k, Um, U, Ux, aa, bb, discr, dd, ddelta ', j, k, Um, U, Ux, aa, bb, discr, dd, ddelta
-!!     print *,' j, k, ah0(i), ahg, tg, qg, tp(i,k), ff ', j, k, ah0(i), ahg, tg, qg, tp(i,k), ff
-          END IF ! (k>=(icbs(i)+1))
-        END DO ! i = 1, ncum
-      END DO ! j = 1,4
-      DO i = 1, ncum
-        IF (k>=(icbs(i)+1)) THEN                                ! convect3
-          tg = tp(i, k)
-          IF (tg .gt. Tx) THEN
-            es = 6.112*exp(17.67*(tg - 273.15)/(tg + 243.5 - 273.15))
-            qg = eps*es/(p(i,k)-es*(1.-eps))
-          ELSE
-            esi = exp(23.33086-(6111.72784/tg)+0.15215*log(tg))
-            qg = eps*esi/(p(i,k)-esi*(1.-eps))
-          ENDIF
-          clw(i, k) = qnk(i) - qg
-          clw(i, k) = max(0.0, clw(i,k))
-          tvp(i, k) = max(0., tp(i,k)*(1.+qg/eps-qnk(i)))
-! print*,tvp(i,k),'tvp'
-          IF (clw(i,k)<1.E-11) THEN
-            tp(i, k) = tv(i, k)
-            tvp(i, k) = tv(i, k)
-          END IF ! (clw(i,k)<1.E-11)
-        END IF ! (k>=(icbs(i)+1))
-      END DO ! i = 1, ncum
-    END DO ! k = minorig + 1, nl
-!----------------------------------------------------------------------------
-!
-  ELSE IF (icvflag_Tpa == 1) THEN  ! (icvflag_Tpa == 2)
-!
-!----------------------------------------------------------------------------
-!
-    DO k = minorig + 1, nl
-      DO i = 1,ncum
-        tp(i,k) = t(i,k)
-      ENDDO
-!!      alv = lv0 - clmcpv*(t(i,k)-273.15)
-!!      alf = lf0 + clmci*(t(i,k)-273.15)
-!!      als = alf + alv
-      DO j = 1,4
-        DO i = 1, ncum
-! ori	    if(k.ge.(icb(i)+1))then
-          IF (k>=(icbs(i)+1)) THEN                                ! convect3
-            tg = tp(i, k)
-            IF (tg .gt. Tx .OR. .NOT.cvflag_ice) THEN
-              es = 6.112*exp(17.67*(tg - 273.15)/(tg + 243.5 - 273.15))
-              qg = eps*es/(p(i,k)-es*(1.-eps))
-              dqgdT = lv(i,k)*qg/(rrv*tg*tg)
-            ELSE
-              esi = exp(23.33086-(6111.72784/tg)+0.15215*log(tg))
-              qg = eps*esi/(p(i,k)-esi*(1.-eps))
-              dqgdT = (lv(i,k)+lf(i,k))*qg/(rrv*tg*tg)
-            ENDIF
-            IF (qsat_depends_on_qt) THEN
-              dqgdT = dqgdT*(1.-qta(i,k-1))/(1.-qg)**2
-              qg = qg*(1.-qta(i,k-1))/(1.-qg)            
-            ENDIF
-            ahg = (cpd + (cl-cpd)*qta(i,k-1))*tg + lv(i,k)*qg - &
-                  lf(i,k)*frac(i,k)*(qta(i,k-1) - qg) + gz(i,k)
-            Tp(i,k) = tg + (ah0(i) - ahg)/ &
-                    (cpd + (cl-cpd)*qta(i,k-1) + (lv(i,k)+frac(i,k)*lf(i,k))*dqgdT)
-!!   print *,'undilute2 iterations k, Tp(i,k), ah0(i), ahg ', &
-!!                                 k, Tp(i,k), ah0(i), ahg
-          END IF ! (k>=(icbs(i)+1))
-        END DO ! i = 1, ncum
-      END DO ! j = 1,4
-      DO i = 1, ncum
-        IF (k>=(icbs(i)+1)) THEN                                ! convect3
-          tg = tp(i, k)
-          IF (tg .gt. Tx .OR. .NOT.cvflag_ice) THEN
-            es = 6.112*exp(17.67*(tg - 273.15)/(tg + 243.5 - 273.15))
-            qg = eps*es/(p(i,k)-es*(1.-eps))
-          ELSE
-            esi = exp(23.33086-(6111.72784/tg)+0.15215*log(tg))
-            qg = eps*esi/(p(i,k)-esi*(1.-eps))
-          ENDIF
-          IF (qsat_depends_on_qt) THEN
-            qg = qg*(1.-qta(i,k-1))/(1.-qg)            
-          ENDIF
-          qhsat(i,k) = qg
-        END IF ! (k>=(icbs(i)+1))
-      END DO ! i = 1, ncum
-      DO i = 1, ncum
-        IF (k>=(icbs(i)+1)) THEN                                ! convect3
-          clw(i, k) = qta(i,k-1) - qhsat(i,k)
-          clw(i, k) = max(0.0, clw(i,k))
-          tvp(i, k) = max(0., tp(i,k)*(1.+qhsat(i,k)/eps-qta(i,k-1)))
-! print*,tvp(i,k),'tvp'
-          IF (clw(i,k)<1.E-11) THEN
-            tp(i, k) = tv(i, k)
-            tvp(i, k) = tv(i, k)
-          END IF ! (clw(i,k)<1.E-11)
-        END IF ! (k>=(icbs(i)+1))
-      END DO ! i = 1, ncum
-!
-      IF (cvflag_prec_eject) THEN
-        DO i = 1, ncum
-          IF (k>=(icbs(i)+1)) THEN                                ! convect3
-!  Specific precipitation (liquid and solid) and ice content 
-!  before ejection of precipitation                                                     !!jygprl
-            elacrit = elcrit*min(max(1.-(tp(i,k)-T0)/Tlcrit, 0.), 1.)                   !!jygprl
-!!!!            qcld(i,k) = min(clw(i,k), elacrit)                                          !!jygprl
-            qhthreshold = elacrit*(1.-qta(i,k-1))/(1.-elacrit)
-            qcld(i,k) = min(clw(i,k), qhthreshold)             !!jygprl
-!!!!            phinu2p = max(qhsat(i,k-1) + qcld(i,k-1) - (qhsat(i,k) + qcld(i,k)),0.)   !!jygprl
-            phinu2p = max(clw(i,k) - max(qta(i,k-1) - qhsat(i,k-1), qhthreshold), 0.)
-            qpl(i,k) = qpl(i,k-1) + (1.-frac(i,k))*phinu2p                            !!jygprl
-            qps(i,k) = qps(i,k-1) + frac(i,k)     *phinu2p                            !!jygprl
-            qi(i,k) = (1.-ejectliq)*clw(i,k)*frac(i,k) + &                            !!jygprl
-                     ejectliq*(qps(i,k-1) + frac(i,k)*(phinu2p+qcld(i,k)))            !!jygprl
-!!
-!  =====================================================================================
-!  Ejection of precipitation from adiabatic ascents if requested (cvflag_prec_eject=True):
-!  Compute the steps of total water (qta), of moist static energy (ha), of specific 
-!  precipitation (qpl and qps) and of specific cloud water (qcld) associated with precipitation
-!   ejection.
-!  =====================================================================================
-!  
-!   Verif
-            qpreca(i,k) = ejectliq*qpl(i,k) + ejectice*qps(i,k)                                   !!jygprl
-            frac_a(i,k) = ejectice*qps(i,k)/max(qpreca(i,k),smallestreal)                         !!jygprl
-            frac_s(i,k) = (1.-ejectliq)*frac(i,k) + &                                             !!jygprl
-               ejectliq*(1. - (qpl(i,k)+(1.-frac(i,k))*qcld(i,k))/max(clw(i,k),smallestreal))     !!jygprl
-!          
-            denomm1 = 1./(1. - qpreca(i,k))
-!          
-            qta(i,k) = qta(i,k-1) - &
-                      qpreca(i,k)*(1.-qta(i,k-1))*denomm1
-            ha(i,k)  = ha(i,k-1) + &
-                      ( qpreca(i,k)*(-(1.-qta(i,k-1))*(cl-cpd)*tp(i,k) + &
-                                  lv(i,k)*qhsat(i,k) - lf(i,k)*(frac_s(i,k)*qcld(i,k)+qps(i,k))) + &
-                        lf(i,k)*ejectice*qps(i,k))*denomm1
-            hla(i,k) = hla(i,k-1) + &
-                      ( qpreca(i,k)*(-(1.-qta(i,k-1))*(cpv-cpd)*tp(i,k) - &
-                                  lv(i,k)*((1.-frac_s(i,k))*qcld(i,k)+qpl(i,k)) - &
-                                  (lv(i,k)+lf(i,k))*(frac_s(i,k)*qcld(i,k)+qps(i,k))) + &
-                        lv(i,k)*ejectliq*qpl(i,k) + (lv(i,k)+lf(i,k))*ejectice*qps(i,k))*denomm1
-            qpl(i,k) = qpl(i,k)*(1.-ejectliq)*denomm1
-            qps(i,k) = qps(i,k)*(1.-ejectice)*denomm1
-            qcld(i,k) = qcld(i,k)*denomm1
-            qhsat(i,k) = qhsat(i,k)*(1.-qta(i,k))/(1.-qta(i,k-1))
-         END IF ! (k>=(icbs(i)+1))
-        END DO ! i = 1, ncum
-      ENDIF  ! (cvflag_prec_eject)
-! 
-    END DO ! k = minorig + 1, nl
-!
-!----------------------------------------------------------------------------
-!
-  ELSE IF (icvflag_Tpa == 0) THEN! (icvflag_Tpa == 2) ELSE IF(icvflag_Tpa == 1)
-!
-!----------------------------------------------------------------------------
-!
-  DO k = minorig + 1, nl
-    DO i = 1, ncum
-! ori	    if(k.ge.(icb(i)+1))then
-      IF (k>=(icbs(i)+1)) THEN                                ! convect3
-        tg = t(i, k)
-        qg = qs(i, k)
-! debug	      alv=lv0-clmcpv*(t(i,k)-t0)
-        alv = lv0 - clmcpv*(t(i,k)-273.15)
-
-! First iteration.
-
-! ori	       s=cpd+alv*alv*qg/(rrv*t(i,k)*t(i,k))
-        s = cpd*(1.-qnk(i)) + cl*qnk(i) + &                   ! convect3
-            alv*alv*qg/(rrv*t(i,k)*t(i,k))                    ! convect3
-        s = 1./s
-! ori	       ahg=cpd*tg+(cl-cpd)*qnk(i)*t(i,k)+alv*qg+gz(i,k)
-        ahg = cpd*tg + (cl-cpd)*qnk(i)*tg + alv*qg + gz(i, k) ! convect3
-        tg = tg + s*(ah0(i)-ahg)
-! ori	       tg=max(tg,35.0)
-! debug	       tc=tg-t0
-        tc = tg - 273.15
-        denom = 243.5 + tc
-        denom = max(denom, 1.0)                               ! convect3
-! ori	       if(tc.ge.0.0)then
-        es = 6.112*exp(17.67*tc/denom)
-! ori	       else
-! ori			es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
-! ori	       endif
-        qg = eps*es/(p(i,k)-es*(1.-eps))
-
-! Second iteration.
-
-! ori	       s=cpd+alv*alv*qg/(rrv*t(i,k)*t(i,k))
-! ori	       s=1./s
-! ori	       ahg=cpd*tg+(cl-cpd)*qnk(i)*t(i,k)+alv*qg+gz(i,k)
-        ahg = cpd*tg + (cl-cpd)*qnk(i)*tg + alv*qg + gz(i, k) ! convect3
-        tg = tg + s*(ah0(i)-ahg)
-! ori	       tg=max(tg,35.0)
-! debug	       tc=tg-t0
-        tc = tg - 273.15
-        denom = 243.5 + tc
-        denom = max(denom, 1.0)                               ! convect3
-! ori	       if(tc.ge.0.0)then
-        es = 6.112*exp(17.67*tc/denom)
-! ori	       else
-! ori			es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
-! ori	       endif
-        qg = eps*es/(p(i,k)-es*(1.-eps))
-
-! debug	       alv=lv0-clmcpv*(t(i,k)-t0)
-        alv = lv0 - clmcpv*(t(i,k)-273.15)
-! print*,'cpd dans convect2 ',cpd
-! print*,'tp(i,k),ah0(i),cl,cpd,qnk(i),t(i,k),gz(i,k),alv,qg,cpd'
-! print*,tp(i,k),ah0(i),cl,cpd,qnk(i),t(i,k),gz(i,k),alv,qg,cpd
-
-! ori c approximation here:
-! ori        tp(i,k)=(ah0(i)-(cl-cpd)*qnk(i)*t(i,k)-gz(i,k)-alv*qg)/cpd
-
-! convect3: no approximation:
-        IF (cvflag_ice) THEN
-          tp(i, k) = max(0., (ah0(i)-gz(i,k)-alv*qg)/(cpd+(cl-cpd)*qnk(i)))
-        ELSE
-          tp(i, k) = (ah0(i)-gz(i,k)-alv*qg)/(cpd+(cl-cpd)*qnk(i))
-        END IF
-
-        clw(i, k) = qnk(i) - qg
-        clw(i, k) = max(0.0, clw(i,k))
-        rg = qg/(1.-qnk(i))
-! ori               tvp(i,k)=tp(i,k)*(1.+rg*epsi)
-! convect3: (qg utilise au lieu du vrai mixing ratio rg):
-        tvp(i, k) = tp(i, k)*(1.+qg/eps-qnk(i)) ! whole thing
-        IF (cvflag_ice) THEN
-          IF (clw(i,k)<1.E-11) THEN
-            tp(i, k) = tv(i, k)
-            tvp(i, k) = tv(i, k)
-          END IF
-        END IF
-!jyg<
-!!      END IF  ! Endif moved to the end of the loop
-!>jyg
-
-      IF (cvflag_ice) THEN
-!CR:attention boucle en klon dans Icefrac
-! Call Icefrac(t,clw,qi,nl,nloc)
-        IF (t(i,k)>263.15) THEN
-          qi(i, k) = 0.
-        ELSE
-          IF (t(i,k)<243.15) THEN
-            qi(i, k) = clw(i, k)
-          ELSE
-            fracg = (263.15-t(i,k))/20
-            qi(i, k) = clw(i, k)*fracg
-          END IF
-        END IF
-!CR: fin test
-        IF (t(i,k)<263.15) THEN
-!CR: on commente les calculs d'Arnaud car division par zero
-! nouveau calcul propose par JYG
-!       alv=lv0-clmcpv*(t(i,k)-273.15)
-!       alf=lf0-clmci*(t(i,k)-273.15)
-!       tg=tp(i,k)
-!       tc=tp(i,k)-273.15
-!       denom=243.5+tc
-!       do j=1,3
-! cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
-! il faudra que esi vienne en argument de la convection
-! cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
-!        tbis=t(i,k)+(tp(i,k)-tg)
-!        esi=exp(23.33086-(6111.72784/tbis) + &
-!                       0.15215*log(tbis))
-!        qsat_new=eps*esi/(p(i,k)-esi*(1.-eps))
-!        snew=cpd*(1.-qnk(i))+cl*qnk(i)+alv*alv*qsat_new/ &
-!                                       (rrv*tbis*tbis)
-!        snew=1./snew
-!        print*,esi,qsat_new,snew,'esi,qsat,snew'
-!        tp(i,k)=tg+(alf*qi(i,k)+alv*qg*(1.-(esi/es)))*snew
-!        print*,k,tp(i,k),qnk(i),'avec glace'
-!        print*,'tpNAN',tg,alf,qi(i,k),alv,qg,esi,es,snew
-!       enddo
-
-          alv = lv0 - clmcpv*(t(i,k)-273.15)
-          alf = lf0 + clmci*(t(i,k)-273.15)
-          als = alf + alv
-          tg = tp(i, k)
-          tp(i, k) = t(i, k)
-          DO j = 1, 3
-            esi = exp(23.33086-(6111.72784/tp(i,k))+0.15215*log(tp(i,k)))
-            qsat_new = eps*esi/(p(i,k)-esi*(1.-eps))
-            snew = cpd*(1.-qnk(i)) + cl*qnk(i) + alv*als*qsat_new/ &
-                                                 (rrv*tp(i,k)*tp(i,k))
-            snew = 1./snew
-! c             print*,esi,qsat_new,snew,'esi,qsat,snew'
-            tp(i, k) = tp(i, k) + &
-                       ((cpd*(1.-qnk(i))+cl*qnk(i))*(tg-tp(i,k)) + &
-                        alv*(qg-qsat_new)+alf*qi(i,k))*snew
-! print*,k,tp(i,k),qsat_new,qnk(i),qi(i,k), &
-!              'k,tp,q,qt,qi avec glace'
-          END DO
-
-!CR:reprise du code AJ
-          clw(i, k) = qnk(i) - qsat_new
-          clw(i, k) = max(0.0, clw(i,k))
-          tvp(i, k) = max(0., tp(i,k)*(1.+qsat_new/eps-qnk(i)))
-! print*,tvp(i,k),'tvp'
-        END IF
-        IF (clw(i,k)<1.E-11) THEN
-          tp(i, k) = tv(i, k)
-          tvp(i, k) = tv(i, k)
-        END IF
-      END IF ! (cvflag_ice)
-!jyg<
-      END IF ! (k>=(icbs(i)+1))
-!>jyg
-    END DO
-  END DO
-
-!----------------------------------------------------------------------------
-!
-  ENDIF ! (icvflag_Tpa == 2) ELSEIF (icvflag_Tpa == 1) ELSE (icvflag_Tpa == 0)
-!
-!----------------------------------------------------------------------------
-!
-! =====================================================================
-! --- SET THE PRECIPITATION EFFICIENCIES 
-! --- THESE MAY BE FUNCTIONS OF TP(I), P(I) AND CLW(I)
-! =====================================================================
-!
-  IF (flag_epkeorig/=1) THEN
-    DO k = 1, nl ! convect3
-      DO i = 1, ncum
-!jyg<
-       IF(k>=icb(i)) THEN
-!>jyg
-         pden = ptcrit - pbcrit
-         ep(i, k) = (plcl(i)-p(i,k)-pbcrit)/pden*epmax
-         ep(i, k) = max(ep(i,k), 0.0)
-         ep(i, k) = min(ep(i,k), epmax)
-!!         sigp(i, k) = spfac  ! jyg
-        ENDIF   ! (k>=icb(i))
-      END DO
-    END DO
-  ELSE
-    DO k = 1, nl
-      DO i = 1, ncum
-        IF(k>=icb(i)) THEN
-!!        IF (k>=(nk(i)+1)) THEN
-!>jyg
-          tca = tp(i, k) - t0
-          IF (tca>=0.0) THEN
-            elacrit = elcrit
-          ELSE
-            elacrit = elcrit*(1.0-tca/tlcrit)
-          END IF
-          elacrit = max(elacrit, 0.0)
-          ep(i, k) = 1.0 - elacrit/max(clw(i,k), 1.0E-8)
-          ep(i, k) = max(ep(i,k), 0.0)
-          ep(i, k) = min(ep(i,k), epmax)
-!!          sigp(i, k) = spfac  ! jyg
-        END IF  ! (k>=icb(i))
-      END DO
-    END DO
-  END IF
-!
-!   =========================================================================
-  IF (prt_level >= 10) THEN
-    print *,'cv3_undilute2.1. tp(1,k), tvp(1,k) ', &
-                          (k, tp(1,k), tvp(1,k), k = 1,nl)
-  ENDIF
-!
-! =====================================================================
-! --- CALCULATE VIRTUAL TEMPERATURE AND LIFTED PARCEL
-! --- VIRTUAL TEMPERATURE
-! =====================================================================
-
-! dans convect3, tvp est calcule en une seule fois, et sans retirer
-! l'eau condensee (~> reversible CAPE)
-
-! ori      do 340 k=minorig+1,nl
-! ori        do 330 i=1,ncum
-! ori        if(k.ge.(icb(i)+1))then
-! ori          tvp(i,k)=tvp(i,k)*(1.0-qnk(i)+ep(i,k)*clw(i,k))
-! oric         print*,'i,k,tvp(i,k),qnk(i),ep(i,k),clw(i,k)'
-! oric         print*, i,k,tvp(i,k),qnk(i),ep(i,k),clw(i,k)
-! ori        endif
-! ori 330    continue
-! ori 340  continue
-
-! ori      do 350 i=1,ncum
-! ori       tvp(i,nlp)=tvp(i,nl)-(gz(i,nlp)-gz(i,nl))/cpd
-! ori 350  continue
-
-  DO i = 1, ncum                                           ! convect3
-    tp(i, nlp) = tp(i, nl)                                 ! convect3
-  END DO                                                   ! convect3
-
-! =====================================================================
-! --- EFFECTIVE VERTICAL PROFILE OF BUOYANCY (convect3 only):
-! =====================================================================
-
-! -- this is for convect3 only:
-
-! first estimate of buoyancy:
-
-!jyg : k-loop outside i-loop (07042015)
-  DO k = 1, nl
-    DO i = 1, ncum
-      buoy(i, k) = tvp(i, k) - tv(i, k)
-    END DO
-  END DO
-
-! set buoyancy=buoybase for all levels below base
-! for safety, set buoy(icb)=buoybase
-
-!jyg : k-loop outside i-loop (07042015)
-  DO k = 1, nl
-    DO i = 1, ncum
-      IF ((k>=icb(i)) .AND. (k<=nl) .AND. (p(i,k)>=pbase(i))) THEN
-        buoy(i, k) = buoybase(i)
-      END IF
-    END DO
-  END DO
-  DO i = 1, ncum
-!    buoy(icb(i),k)=buoybase(i)
-    buoy(i, icb(i)) = buoybase(i)
-  END DO
-
-! -- end convect3
-
-! =====================================================================
-! --- FIND THE FIRST MODEL LEVEL (INB) ABOVE THE PARCEL'S
-! --- LEVEL OF NEUTRAL BUOYANCY
-! =====================================================================
-
-! -- this is for convect3 only:
-
-  DO i = 1, ncum
-    inb(i) = nl - 1
-    iposit(i) = nl
-  END DO
-
-
-! --    iposit(i) = first level, above icb, with positive buoyancy
-  DO k = 1, nl - 1
-    DO i = 1, ncum
-      IF (k>=icb(i) .AND. buoy(i,k)>0.) THEN
-        iposit(i) = min(iposit(i), k)
-      END IF
-    END DO
-  END DO
-
-  DO i = 1, ncum
-    IF (iposit(i)==nl) THEN
-      iposit(i) = icb(i)
-    END IF
-  END DO
-
-  DO k = 1, nl - 1
-    DO i = 1, ncum
-      IF ((k>=iposit(i)) .AND. (buoy(i,k)<dtovsh)) THEN
-        inb(i) = min(inb(i), k)
-      END IF
-    END DO
-  END DO
-
-!CR fix computation of inb
-!keep flag or modify in all cases?
-  IF (iflag_mix_adiab.eq.1) THEN
-  DO i = 1, ncum
-     cape(i)=0.
-     inb(i)=icb(i)+1
-  ENDDO
-  
-  DO k = 2, nl 
-    DO i = 1, ncum
-       IF ((k>=iposit(i))) THEN
-       deltap = min(plcl(i), ph(i,k-1)) - min(plcl(i), ph(i,k))
-       cape(i) = cape(i) + rrd*buoy(i, k-1)*deltap/p(i, k-1)
-       IF (cape(i).gt.0.) THEN
-        inb(i) = max(inb(i), k)
-       END IF
-       ENDIF
-    ENDDO
-  ENDDO
-
-!  DO i = 1, ncum
-!     print*,"inb",inb(i)
-!  ENDDO
-
-  endif
-
-! -- end convect3
-
-! ori      do 510 i=1,ncum
-! ori        cape(i)=0.0
-! ori        capem(i)=0.0
-! ori        inb(i)=icb(i)+1
-! ori        inb1(i)=inb(i)
-! ori 510  continue
-
-! Originial Code
-
-!    do 530 k=minorig+1,nl-1
-!     do 520 i=1,ncum
-!      if(k.ge.(icb(i)+1))then
-!       by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k)
-!       byp=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1)
-!       cape(i)=cape(i)+by
-!       if(by.ge.0.0)inb1(i)=k+1
-!       if(cape(i).gt.0.0)then
-!        inb(i)=k+1
-!        capem(i)=cape(i)
-!       endif
-!      endif
-!520    continue
-!530  continue
-!    do 540 i=1,ncum
-!     byp=(tvp(i,nl)-tv(i,nl))*dph(i,nl)/p(i,nl)
-!     cape(i)=capem(i)+byp
-!     defrac=capem(i)-cape(i)
-!     defrac=max(defrac,0.001)
-!     frac(i)=-cape(i)/defrac
-!     frac(i)=min(frac(i),1.0)
-!     frac(i)=max(frac(i),0.0)
-!540   continue
-
-!    K Emanuel fix
-
-!    call zilch(byp,ncum)
-!    do 530 k=minorig+1,nl-1
-!     do 520 i=1,ncum
-!      if(k.ge.(icb(i)+1))then
-!       by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k)
-!       cape(i)=cape(i)+by
-!       if(by.ge.0.0)inb1(i)=k+1
-!       if(cape(i).gt.0.0)then
-!        inb(i)=k+1
-!        capem(i)=cape(i)
-!        byp(i)=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1)
-!       endif
-!      endif
-!520    continue
-!530  continue
-!    do 540 i=1,ncum
-!     inb(i)=max(inb(i),inb1(i))
-!     cape(i)=capem(i)+byp(i)
-!     defrac=capem(i)-cape(i)
-!     defrac=max(defrac,0.001)
-!     frac(i)=-cape(i)/defrac
-!     frac(i)=min(frac(i),1.0)
-!     frac(i)=max(frac(i),0.0)
-!540   continue
-
-! J Teixeira fix
-
-! ori      call zilch(byp,ncum)
-! ori      do 515 i=1,ncum
-! ori        lcape(i)=.true.
-! ori 515  continue
-! ori      do 530 k=minorig+1,nl-1
-! ori        do 520 i=1,ncum
-! ori          if(cape(i).lt.0.0)lcape(i)=.false.
-! ori          if((k.ge.(icb(i)+1)).and.lcape(i))then
-! ori            by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k)
-! ori            byp(i)=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1)
-! ori            cape(i)=cape(i)+by
-! ori            if(by.ge.0.0)inb1(i)=k+1
-! ori            if(cape(i).gt.0.0)then
-! ori              inb(i)=k+1
-! ori              capem(i)=cape(i)
-! ori            endif
-! ori          endif
-! ori 520    continue
-! ori 530  continue
-! ori      do 540 i=1,ncum
-! ori          cape(i)=capem(i)+byp(i)
-! ori          defrac=capem(i)-cape(i)
-! ori          defrac=max(defrac,0.001)
-! ori          frac(i)=-cape(i)/defrac
-! ori          frac(i)=min(frac(i),1.0)
-! ori          frac(i)=max(frac(i),0.0)
-! ori 540  continue
-
-! --------------------------------------------------------------------
-!   Prevent convection when top is too hot
-! --------------------------------------------------------------------
-  DO i = 1,ncum
-    IF (t(i,inb(i)) > T_top_max) iflag(i) = 10
-  ENDDO
-
-! =====================================================================
-! ---   CALCULATE LIQUID WATER STATIC ENERGY OF LIFTED PARCEL
-! =====================================================================
-
-  DO k = 1, nl
-    DO i = 1, ncum
-      hp(i, k) = h(i, k)
-    END DO
-  END DO
-
-!jyg : cvflag_ice test outside the loops (07042015)
-!
-  IF (cvflag_ice) THEN
-!
-  IF (cvflag_prec_eject) THEN
-!!    DO k = minorig + 1, nl
-!!      DO i = 1, ncum
-!!        IF ((k>=icb(i)) .AND. (k<=inb(i))) THEN
-!!          frac_s(i,k) = qi(i,k)/max(clw(i,k),smallestreal)    
-!!          frac_s(i,k) = 1. - (qpl(i,k)+(1.-frac_s(i,k))*qcld(i,k))/max(clw(i,k),smallestreal)    
-!!        END IF
-!!      END DO
-!!    END DO
-  ELSE    ! (cvflag_prec_eject)
-    DO k = minorig + 1, nl
-      DO i = 1, ncum
-        IF ((k>=icb(i)) .AND. (k<=inb(i))) THEN
-!jyg< frac computation moved to beginning of cv3_undilute2.
-!     kept here for compatibility test with CMip6 version
-          frac_s(i, k) = 1. - (t(i,k)-243.15)/(263.15-243.15)
-          frac_s(i, k) = min(max(frac_s(i,k),0.0), 1.0)
-        END IF
-      END DO
-    END DO
-  ENDIF  ! (cvflag_prec_eject) ELSE
-    DO k = minorig + 1, nl
-      DO i = 1, ncum
-        IF ((k>=icb(i)) .AND. (k<=inb(i))) THEN
-!!          hp(i, k) = hnk(i) + (lv(i,k)+(cpd-cpv)*t(i,k)+frac_s(i,k)*lf(i,k))* &     !!jygprl
-!!                              ep(i, k)*clw(i, k)                                    !!jygprl
-          hp(i, k) = hla(i,k-1) + (lv(i,k)+(cpd-cpv)*t(i,k)+frac_s(i,k)*lf(i,k))* &   !!jygprl
-                              ep(i, k)*clw(i, k)                                      !!jygprl
-        END IF
-      END DO
-    END DO
-!
-  ELSE   ! (cvflag_ice)
-!
-    DO k = minorig + 1, nl
-      DO i = 1, ncum
-        IF ((k>=icb(i)) .AND. (k<=inb(i))) THEN
-!jyg<   (energy conservation tests)
-!!          hp(i, k) = hnk(i) + (lv(i,k)+(cpd-cpv)*tp(i,k))*ep(i, k)*clw(i, k)
-!!          hp(i, k) = ( hnk(i) + (lv(i,k)+(cpd-cpv)*t(i,k))*ep(i, k)*clw(i, k) ) / &
-!!                     (1. - ep(i,k)*clw(i,k))
-!!          hp(i, k) = ( hnk(i) + (lv(i,k)+(cpd-cl)*t(i,k))*ep(i, k)*clw(i, k) ) / &
-!!                     (1. - ep(i,k)*clw(i,k))
-          hp(i, k) = hnk(i) + (lv(i,k)+(cpd-cpv)*t(i,k))*ep(i, k)*clw(i, k)
-        END IF
-      END DO
-    END DO
-!
-  END IF  ! (cvflag_ice)
-
-  RETURN
-END SUBROUTINE cv3_undilute2
-
-SUBROUTINE cv3_closure(nloc, ncum, nd, icb, inb, &
-                       pbase, p, ph, tv, buoy, &
-                       sig, w0, cape, m, iflag)
-  IMPLICIT NONE
-
-! ===================================================================
-! ---  CLOSURE OF CONVECT3
-!
-! vectorization: S. Bony
-! ===================================================================
-
-  include "cvthermo.h"
-  include "cv3param.h"
-
-!input:
-  INTEGER ncum, nd, nloc
-  INTEGER icb(nloc), inb(nloc)
-  REAL pbase(nloc)
-  REAL p(nloc, nd), ph(nloc, nd+1)
-  REAL tv(nloc, nd), buoy(nloc, nd)
-
-!input/output:
-  REAL sig(nloc, nd), w0(nloc, nd)
-  INTEGER iflag(nloc)
-
-!output:
-  REAL cape(nloc)
-  REAL m(nloc, nd)
-
-!local variables:
-  INTEGER i, j, k, icbmax
-  REAL deltap, fac, w, amu
-  REAL dtmin(nloc, nd), sigold(nloc, nd)
-  REAL cbmflast(nloc)
-
-
-! -------------------------------------------------------
-! -- Initialization
-! -------------------------------------------------------
-
-  DO k = 1, nl
-    DO i = 1, ncum
-      m(i, k) = 0.0
-    END DO
-  END DO
-
-! -------------------------------------------------------
-! -- Reset sig(i) and w0(i) for i>inb and i<icb
-! -------------------------------------------------------
-
-! update sig and w0 above LNB:
-
-  DO k = 1, nl - 1
-    DO i = 1, ncum
-      IF ((inb(i)<(nl-1)) .AND. (k>=(inb(i)+1))) THEN
-        sig(i, k) = beta*sig(i, k) + &
-                    2.*alpha*buoy(i, inb(i))*abs(buoy(i,inb(i)))
-        sig(i, k) = amax1(sig(i,k), 0.0)
-        w0(i, k) = beta*w0(i, k)
-      END IF
-    END DO
-  END DO
-
-! compute icbmax:
-
-  icbmax = 2
-  DO i = 1, ncum
-    icbmax = max(icbmax, icb(i))
-  END DO
-
-! update sig and w0 below cloud base:
-
-  DO k = 1, icbmax
-    DO i = 1, ncum
-      IF (k<=icb(i)) THEN
-        sig(i, k) = beta*sig(i, k) - &
-                    2.*alpha*buoy(i, icb(i))*buoy(i, icb(i))
-        sig(i, k) = max(sig(i,k), 0.0)
-        w0(i, k) = beta*w0(i, k)
-      END IF
-    END DO
-  END DO
-
-!!      if(inb.lt.(nl-1))then
-!!         do 85 i=inb+1,nl-1
-!!            sig(i)=beta*sig(i)+2.*alpha*buoy(inb)*
-!!     1              abs(buoy(inb))
-!!            sig(i)=max(sig(i),0.0)
-!!            w0(i)=beta*w0(i)
-!!   85    continue
-!!      end if
-
-!!      do 87 i=1,icb
-!!         sig(i)=beta*sig(i)-2.*alpha*buoy(icb)*buoy(icb)
-!!         sig(i)=max(sig(i),0.0)
-!!         w0(i)=beta*w0(i)
-!!   87 continue
-
-! -------------------------------------------------------------
-! -- Reset fractional areas of updrafts and w0 at initial time
-! -- and after 10 time steps of no convection
-! -------------------------------------------------------------
-
-  DO k = 1, nl - 1
-    DO i = 1, ncum
-      IF (sig(i,nd)<1.5 .OR. sig(i,nd)>12.0) THEN
-        sig(i, k) = 0.0
-        w0(i, k) = 0.0
-      END IF
-    END DO
-  END DO
-
-! -------------------------------------------------------------
-! -- Calculate convective available potential energy (cape),
-! -- vertical velocity (w), fractional area covered by
-! -- undilute updraft (sig), and updraft mass flux (m)
-! -------------------------------------------------------------
-
-  DO i = 1, ncum
-    cape(i) = 0.0
-  END DO
-
-! compute dtmin (minimum buoyancy between ICB and given level k):
-
-  DO i = 1, ncum
-    DO k = 1, nl
-      dtmin(i, k) = 100.0
-    END DO
-  END DO
-
-  DO i = 1, ncum
-    DO k = 1, nl
-      DO j = minorig, nl
-        IF ((k>=(icb(i)+1)) .AND. (k<=inb(i)) .AND. (j>=icb(i)) .AND. (j<=(k-1))) THEN
-          dtmin(i, k) = amin1(dtmin(i,k), buoy(i,j))
-        END IF
-      END DO
-    END DO
-  END DO
-
-! the interval on which cape is computed starts at pbase :
-
-  DO k = 1, nl
-    DO i = 1, ncum
-
-      IF ((k>=(icb(i)+1)) .AND. (k<=inb(i))) THEN
-
-        deltap = min(pbase(i), ph(i,k-1)) - min(pbase(i), ph(i,k))
-        cape(i) = cape(i) + rrd*buoy(i, k-1)*deltap/p(i, k-1)
-        cape(i) = amax1(0.0, cape(i))
-        sigold(i, k) = sig(i, k)
-
-! dtmin(i,k)=100.0
-! do 97 j=icb(i),k-1 ! mauvaise vectorisation
-! dtmin(i,k)=AMIN1(dtmin(i,k),buoy(i,j))
-! 97     continue
-
-        sig(i, k) = beta*sig(i, k) + alpha*dtmin(i, k)*abs(dtmin(i,k))
-        sig(i, k) = max(sig(i,k), 0.0)
-        sig(i, k) = amin1(sig(i,k), 0.01)
-        fac = amin1(((dtcrit-dtmin(i,k))/dtcrit), 1.0)
-        w = (1.-beta)*fac*sqrt(cape(i)) + beta*w0(i, k)
-        amu = 0.5*(sig(i,k)+sigold(i,k))*w
-        m(i, k) = amu*0.007*p(i, k)*(ph(i,k)-ph(i,k+1))/tv(i, k)
-        w0(i, k) = w
-      END IF
-
-    END DO
-  END DO
-
-  DO i = 1, ncum
-    w0(i, icb(i)) = 0.5*w0(i, icb(i)+1)
-    m(i, icb(i)) = 0.5*m(i, icb(i)+1)*(ph(i,icb(i))-ph(i,icb(i)+1))/(ph(i,icb(i)+1)-ph(i,icb(i)+2))
-    sig(i, icb(i)) = sig(i, icb(i)+1)
-    sig(i, icb(i)-1) = sig(i, icb(i))
-  END DO
-
-! ccc 3. Compute final cloud base mass flux and set iflag to 3 if
-! ccc    cloud base mass flux is exceedingly small and is decreasing (i.e. if
-! ccc    the final mass flux (cbmflast) is greater than the target mass flux
-! ccc    (cbmf) ??).
-! cc
-! c      do i = 1,ncum
-! c       cbmflast(i) = 0.
-! c      enddo
-! cc
-! c      do k= 1,nl
-! c       do i = 1,ncum
-! c        IF (k .ge. icb(i) .and. k .le. inb(i)) THEN
-! c         cbmflast(i) = cbmflast(i)+M(i,k)
-! c        ENDIF
-! c       enddo
-! c      enddo
-! cc
-! c      do i = 1,ncum
-! c       IF (cbmflast(i) .lt. 1.e-6) THEN
-! c         iflag(i) = 3
-! c       ENDIF
-! c      enddo
-! cc
-! c      do k= 1,nl
-! c       do i = 1,ncum
-! c        IF (iflag(i) .ge. 3) THEN
-! c         M(i,k) = 0.
-! c         sig(i,k) = 0.
-! c         w0(i,k) = 0.
-! c        ENDIF
-! c       enddo
-! c      enddo
-! cc
-!!      cape=0.0
-!!      do 98 i=icb+1,inb
-!!         deltap = min(pbase,ph(i-1))-min(pbase,ph(i))
-!!         cape=cape+rrd*buoy(i-1)*deltap/p(i-1)
-!!         dcape=rrd*buoy(i-1)*deltap/p(i-1)
-!!         dlnp=deltap/p(i-1)
-!!         cape=max(0.0,cape)
-!!         sigold=sig(i)
-
-!!         dtmin=100.0
-!!         do 97 j=icb,i-1
-!!            dtmin=amin1(dtmin,buoy(j))
-!!   97    continue
-
-!!         sig(i)=beta*sig(i)+alpha*dtmin*abs(dtmin)
-!!         sig(i)=max(sig(i),0.0)
-!!         sig(i)=amin1(sig(i),0.01)
-!!         fac=amin1(((dtcrit-dtmin)/dtcrit),1.0)
-!!         w=(1.-beta)*fac*sqrt(cape)+beta*w0(i)
-!!         amu=0.5*(sig(i)+sigold)*w
-!!         m(i)=amu*0.007*p(i)*(ph(i)-ph(i+1))/tv(i)
-!!         w0(i)=w
-!!   98 continue
-!!      w0(icb)=0.5*w0(icb+1)
-!!      m(icb)=0.5*m(icb+1)*(ph(icb)-ph(icb+1))/(ph(icb+1)-ph(icb+2))
-!!      sig(icb)=sig(icb+1)
-!!      sig(icb-1)=sig(icb)
-
-  RETURN
-END SUBROUTINE cv3_closure
-
-SUBROUTINE cv3_mixing(nloc, ncum, nd, na, ntra, icb, nk, inb, &
-                      ph, t, rr, rs, u, v, tra, h, lv, lf, frac, qnk, &
-                      unk, vnk, hp, tv, tvp, ep, clw, m, sig, &
-                      ment, qent, uent, vent, nent, sij, elij, ments, qents, traent)
-  IMPLICIT NONE
-
-! ---------------------------------------------------------------------
-! a faire:
-! - vectorisation de la partie normalisation des flux (do 789...)
-! ---------------------------------------------------------------------
-
-  include "cvthermo.h"
-  include "cv3param.h"
-  include "cvflag.h"
-
-!inputs:
-  INTEGER, INTENT (IN)                               :: ncum, nd, na, ntra, nloc
-  INTEGER, DIMENSION (nloc), INTENT (IN)             :: icb, inb, nk
-  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: sig
-  REAL, DIMENSION (nloc), INTENT (IN)                :: qnk, unk, vnk
-  REAL, DIMENSION (nloc, nd+1), INTENT (IN)          :: ph
-  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: t, rr, rs
-  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: u, v
-  REAL, DIMENSION (nloc, nd, ntra), INTENT (IN)      :: tra               ! input of convect3
-  REAL, DIMENSION (nloc, na), INTENT (IN)            :: lv, h, hp
-  REAL, DIMENSION (nloc, na), INTENT (IN)            :: lf, frac
-  REAL, DIMENSION (nloc, na), INTENT (IN)            :: tv, tvp, ep, clw
-  REAL, DIMENSION (nloc, na), INTENT (IN)            :: m                 ! input of convect3
-
-!outputs:
-  REAL, DIMENSION (nloc, na, na), INTENT (OUT)        :: ment, qent
-  REAL, DIMENSION (nloc, na, na), INTENT (OUT)        :: uent, vent
-  REAL, DIMENSION (nloc, na, na), INTENT (OUT)        :: sij, elij
-  REAL, DIMENSION (nloc, nd, nd, ntra), INTENT (OUT)  :: traent
-  REAL, DIMENSION (nloc, nd, nd), INTENT (OUT)        :: ments, qents
-  INTEGER, DIMENSION (nloc, nd), INTENT (OUT)         :: nent
-
-!local variables:
-  INTEGER i, j, k, il, im, jm
-  INTEGER num1, num2
-  REAL rti, bf2, anum, denom, dei, altem, cwat, stemp, qp
-  REAL alt, smid, sjmin, sjmax, delp, delm
-  REAL asij(nloc), smax(nloc), scrit(nloc)
-  REAL asum(nloc, nd), bsum(nloc, nd), csum(nloc, nd)
-  REAL sigij(nloc, nd, nd)
-  REAL wgh
-  REAL zm(nloc, na)
-  LOGICAL lwork(nloc)
-
-! =====================================================================
-! --- INITIALIZE VARIOUS ARRAYS USED IN THE COMPUTATIONS
-! =====================================================================
-
-! ori        do 360 i=1,ncum*nlp
-  DO j = 1, nl
-    DO i = 1, ncum
-      nent(i, j) = 0
-! in convect3, m is computed in cv3_closure
-! ori          m(i,1)=0.0
-    END DO
-  END DO
-
-! ori      do 400 k=1,nlp
-! ori       do 390 j=1,nlp
-  DO j = 1, nl
-    DO k = 1, nl
-      DO i = 1, ncum
-        qent(i, k, j) = rr(i, j)
-        uent(i, k, j) = u(i, j)
-        vent(i, k, j) = v(i, j)
-        elij(i, k, j) = 0.0
-!ym            ment(i,k,j)=0.0
-!ym            sij(i,k,j)=0.0
-      END DO
-    END DO
-  END DO
-
-!ym
-  ment(1:ncum, 1:nd, 1:nd) = 0.0
-  sij(1:ncum, 1:nd, 1:nd) = 0.0
-
-!AC!      do k=1,ntra
-!AC!       do j=1,nd  ! instead nlp
-!AC!        do i=1,nd ! instead nlp
-!AC!         do il=1,ncum
-!AC!            traent(il,i,j,k)=tra(il,j,k)
-!AC!         enddo
-!AC!        enddo
-!AC!       enddo
-!AC!      enddo
-  zm(:, :) = 0.
-
-! =====================================================================
-! --- CALCULATE ENTRAINED AIR MASS FLUX (ment), TOTAL WATER MIXING
-! --- RATIO (QENT), TOTAL CONDENSED WATER (elij), AND MIXING
-! --- FRACTION (sij)
-! =====================================================================
-
-  DO i = minorig + 1, nl
-
-    DO j = minorig, nl
-      DO il = 1, ncum
-        IF ((i>=icb(il)) .AND. (i<=inb(il)) .AND. (j>=(icb(il)-1)) .AND. (j<=inb(il))) THEN
-
-          rti = qnk(il) - ep(il, i)*clw(il, i)
-          bf2 = 1. + lv(il, j)*lv(il, j)*rs(il, j)/(rrv*t(il,j)*t(il,j)*cpd)
-
-
-          IF (cvflag_ice) THEN
-! print*,cvflag_ice,'cvflag_ice dans do 700'
-            IF (t(il,j)<=263.15) THEN
-              bf2 = 1. + (lf(il,j)+lv(il,j))*(lv(il,j)+frac(il,j)* &
-                   lf(il,j))*rs(il, j)/(rrv*t(il,j)*t(il,j)*cpd)
-            END IF
-          END IF
-
-          anum = h(il, j) - hp(il, i) + (cpv-cpd)*t(il, j)*(rti-rr(il,j))
-          denom = h(il, i) - hp(il, i) + (cpd-cpv)*(rr(il,i)-rti)*t(il, j)
-          dei = denom
-          IF (abs(dei)<0.01) dei = 0.01
-          sij(il, i, j) = anum/dei
-          sij(il, i, i) = 1.0
-          altem = sij(il, i, j)*rr(il, i) + (1.-sij(il,i,j))*rti - rs(il, j)
-          altem = altem/bf2
-          cwat = clw(il, j)*(1.-ep(il,j))
-          stemp = sij(il, i, j)
-          IF ((stemp<0.0 .OR. stemp>1.0 .OR. altem>cwat) .AND. j>i) THEN
-
-            IF (cvflag_ice) THEN
-              anum = anum - (lv(il,j)+frac(il,j)*lf(il,j))*(rti-rs(il,j)-cwat*bf2)
-              denom = denom + (lv(il,j)+frac(il,j)*lf(il,j))*(rr(il,i)-rti)
-            ELSE
-              anum = anum - lv(il, j)*(rti-rs(il,j)-cwat*bf2)
-              denom = denom + lv(il, j)*(rr(il,i)-rti)
-            END IF
-
-            IF (abs(denom)<0.01) denom = 0.01
-            sij(il, i, j) = anum/denom
-            altem = sij(il, i, j)*rr(il, i) + (1.-sij(il,i,j))*rti - rs(il, j)
-            altem = altem - (bf2-1.)*cwat
-          END IF
-          IF (sij(il,i,j)>0.0 .AND. sij(il,i,j)<0.95) THEN
-            qent(il, i, j) = sij(il, i, j)*rr(il, i) + (1.-sij(il,i,j))*rti
-            uent(il, i, j) = sij(il, i, j)*u(il, i) + (1.-sij(il,i,j))*unk(il)
-            vent(il, i, j) = sij(il, i, j)*v(il, i) + (1.-sij(il,i,j))*vnk(il)
-!!!!      do k=1,ntra
-!!!!      traent(il,i,j,k)=sij(il,i,j)*tra(il,i,k)
-!!!!     :      +(1.-sij(il,i,j))*tra(il,nk(il),k)
-!!!!      end do
-            elij(il, i, j) = altem
-            elij(il, i, j) = max(0.0, elij(il,i,j))
-            ment(il, i, j) = m(il, i)/(1.-sij(il,i,j))
-            nent(il, i) = nent(il, i) + 1
-          END IF
-          sij(il, i, j) = max(0.0, sij(il,i,j))
-          sij(il, i, j) = amin1(1.0, sij(il,i,j))
-        END IF ! new
-      END DO
-    END DO
-
-!AC!       do k=1,ntra
-!AC!        do j=minorig,nl
-!AC!         do il=1,ncum
-!AC!          if( (i.ge.icb(il)).and.(i.le.inb(il)).and.
-!AC!     :       (j.ge.(icb(il)-1)).and.(j.le.inb(il)))then
-!AC!            traent(il,i,j,k)=sij(il,i,j)*tra(il,i,k)
-!AC!     :            +(1.-sij(il,i,j))*tra(il,nk(il),k)
-!AC!          endif
-!AC!         enddo
-!AC!        enddo
-!AC!       enddo
-
-
-! ***   if no air can entrain at level i assume that updraft detrains  ***
-! ***   at that level and calculate detrained air flux and properties  ***
-
-
-! @      do 170 i=icb(il),inb(il)
-
-    DO il = 1, ncum
-      IF ((i>=icb(il)) .AND. (i<=inb(il)) .AND. (nent(il,i)==0)) THEN
-! @      if(nent(il,i).eq.0)then
-        ment(il, i, i) = m(il, i)
-        qent(il, i, i) = qnk(il) - ep(il, i)*clw(il, i)
-        uent(il, i, i) = unk(il)
-        vent(il, i, i) = vnk(il)
-        elij(il, i, i) = clw(il, i)
-! MAF      sij(il,i,i)=1.0
-        sij(il, i, i) = 0.0
-      END IF
-    END DO
-  END DO
-
-!AC!      do j=1,ntra
-!AC!       do i=minorig+1,nl
-!AC!        do il=1,ncum
-!AC!         if (i.ge.icb(il) .and. i.le.inb(il) .and. nent(il,i).eq.0) then
-!AC!          traent(il,i,i,j)=tra(il,nk(il),j)
-!AC!         endif
-!AC!        enddo
-!AC!       enddo
-!AC!      enddo
-
-  DO j = minorig, nl
-    DO i = minorig, nl
-      DO il = 1, ncum
-        IF ((j>=(icb(il)-1)) .AND. (j<=inb(il)) .AND. (i>=icb(il)) .AND. (i<=inb(il))) THEN
-          sigij(il, i, j) = sij(il, i, j)
-        END IF
-      END DO
-    END DO
-  END DO
-! @      enddo
-
-! @170   continue
-
-! =====================================================================
-! ---  NORMALIZE ENTRAINED AIR MASS FLUXES
-! ---  TO REPRESENT EQUAL PROBABILITIES OF MIXING
-! =====================================================================
-
-  CALL zilch(asum, nloc*nd)
-  CALL zilch(csum, nloc*nd)
-  CALL zilch(csum, nloc*nd)
-
-  DO il = 1, ncum
-    lwork(il) = .FALSE.
-  END DO
-
-  DO i = minorig + 1, nl
-
-    num1 = 0
-    DO il = 1, ncum
-      IF (i>=icb(il) .AND. i<=inb(il)) num1 = num1 + 1
-    END DO
-    IF (num1<=0) GO TO 789
-
-
-    DO il = 1, ncum
-      IF (i>=icb(il) .AND. i<=inb(il)) THEN
-        lwork(il) = (nent(il,i)/=0)
-        qp = qnk(il) - ep(il, i)*clw(il, i)
-
-        IF (cvflag_ice) THEN
-
-          anum = h(il, i) - hp(il, i) - (lv(il,i)+frac(il,i)*lf(il,i))* &
-                       (qp-rs(il,i)) + (cpv-cpd)*t(il, i)*(qp-rr(il,i))
-          denom = h(il, i) - hp(il, i) + (lv(il,i)+frac(il,i)*lf(il,i))* &
-                       (rr(il,i)-qp) + (cpd-cpv)*t(il, i)*(rr(il,i)-qp)
-        ELSE
-
-          anum = h(il, i) - hp(il, i) - lv(il, i)*(qp-rs(il,i)) + &
-                       (cpv-cpd)*t(il, i)*(qp-rr(il,i))
-          denom = h(il, i) - hp(il, i) + lv(il, i)*(rr(il,i)-qp) + &
-                       (cpd-cpv)*t(il, i)*(rr(il,i)-qp)
-        END IF
-
-        IF (abs(denom)<0.01) denom = 0.01
-        scrit(il) = anum/denom
-        alt = qp - rs(il, i) + scrit(il)*(rr(il,i)-qp)
-        IF (scrit(il)<=0.0 .OR. alt<=0.0) scrit(il) = 1.0
-        smax(il) = 0.0
-        asij(il) = 0.0
-      END IF
-    END DO
-
-    DO j = nl, minorig, -1
-
-      num2 = 0
-      DO il = 1, ncum
-        IF (i>=icb(il) .AND. i<=inb(il) .AND. &
-            j>=(icb(il)-1) .AND. j<=inb(il) .AND. &
-            lwork(il)) num2 = num2 + 1
-      END DO
-      IF (num2<=0) GO TO 175
-
-      DO il = 1, ncum
-        IF (i>=icb(il) .AND. i<=inb(il) .AND. &
-            j>=(icb(il)-1) .AND. j<=inb(il) .AND. &
-            lwork(il)) THEN
-
-          IF (sij(il,i,j)>1.0E-16 .AND. sij(il,i,j)<0.95) THEN
-            wgh = 1.0
-            IF (j>i) THEN
-              sjmax = max(sij(il,i,j+1), smax(il))
-              sjmax = amin1(sjmax, scrit(il))
-              smax(il) = max(sij(il,i,j), smax(il))
-              sjmin = max(sij(il,i,j-1), smax(il))
-              sjmin = amin1(sjmin, scrit(il))
-              IF (sij(il,i,j)<(smax(il)-1.0E-16)) wgh = 0.0
-              smid = amin1(sij(il,i,j), scrit(il))
-            ELSE
-              sjmax = max(sij(il,i,j+1), scrit(il))
-              smid = max(sij(il,i,j), scrit(il))
-              sjmin = 0.0
-              IF (j>1) sjmin = sij(il, i, j-1)
-              sjmin = max(sjmin, scrit(il))
-            END IF
-            delp = abs(sjmax-smid)
-            delm = abs(sjmin-smid)
-            asij(il) = asij(il) + wgh*(delp+delm)
-            ment(il, i, j) = ment(il, i, j)*(delp+delm)*wgh
-          END IF
-        END IF
-      END DO
-
-175 END DO
-
-    DO il = 1, ncum
-      IF (i>=icb(il) .AND. i<=inb(il) .AND. lwork(il)) THEN
-        asij(il) = max(1.0E-16, asij(il))
-        asij(il) = 1.0/asij(il)
-        asum(il, i) = 0.0
-        bsum(il, i) = 0.0
-        csum(il, i) = 0.0
-      END IF
-    END DO
-
-    DO j = minorig, nl
-      DO il = 1, ncum
-        IF (i>=icb(il) .AND. i<=inb(il) .AND. lwork(il) .AND. &
-            j>=(icb(il)-1) .AND. j<=inb(il)) THEN
-          ment(il, i, j) = ment(il, i, j)*asij(il)
-        END IF
-      END DO
-    END DO
-
-    DO j = minorig, nl
-      DO il = 1, ncum
-        IF (i>=icb(il) .AND. i<=inb(il) .AND. lwork(il) .AND. &
-            j>=(icb(il)-1) .AND. j<=inb(il)) THEN
-          asum(il, i) = asum(il, i) + ment(il, i, j)
-          ment(il, i, j) = ment(il, i, j)*sig(il, j)
-          bsum(il, i) = bsum(il, i) + ment(il, i, j)
-        END IF
-      END DO
-    END DO
-
-    DO il = 1, ncum
-      IF (i>=icb(il) .AND. i<=inb(il) .AND. lwork(il)) THEN
-        bsum(il, i) = max(bsum(il,i), 1.0E-16)
-        bsum(il, i) = 1.0/bsum(il, i)
-      END IF
-    END DO
-
-    DO j = minorig, nl
-      DO il = 1, ncum
-        IF (i>=icb(il) .AND. i<=inb(il) .AND. lwork(il) .AND. &
-            j>=(icb(il)-1) .AND. j<=inb(il)) THEN
-          ment(il, i, j) = ment(il, i, j)*asum(il, i)*bsum(il, i)
-        END IF
-      END DO
-    END DO
-
-    DO j = minorig, nl
-      DO il = 1, ncum
-        IF (i>=icb(il) .AND. i<=inb(il) .AND. lwork(il) .AND. &
-            j>=(icb(il)-1) .AND. j<=inb(il)) THEN
-          csum(il, i) = csum(il, i) + ment(il, i, j)
-        END IF
-      END DO
-    END DO
-
-    DO il = 1, ncum
-      IF (i>=icb(il) .AND. i<=inb(il) .AND. lwork(il) .AND. &
-          csum(il,i)<m(il,i)) THEN
-        nent(il, i) = 0
-        ment(il, i, i) = m(il, i)
-        qent(il, i, i) = qnk(il) - ep(il, i)*clw(il, i)
-        uent(il, i, i) = unk(il)
-        vent(il, i, i) = vnk(il)
-        elij(il, i, i) = clw(il, i)
-! MAF        sij(il,i,i)=1.0
-        sij(il, i, i) = 0.0
-      END IF
-    END DO ! il
-
-!AC!      do j=1,ntra
-!AC!       do il=1,ncum
-!AC!        if ( i.ge.icb(il) .and. i.le.inb(il) .and. lwork(il)
-!AC!     :     .and. csum(il,i).lt.m(il,i) ) then
-!AC!         traent(il,i,i,j)=tra(il,nk(il),j)
-!AC!        endif
-!AC!       enddo
-!AC!      enddo
-789 END DO
-
-! MAF: renormalisation de MENT
-  CALL zilch(zm, nloc*na)
-  DO jm = 1, nl
-    DO im = 1, nl
-      DO il = 1, ncum
-        zm(il, im) = zm(il, im) + (1.-sij(il,im,jm))*ment(il, im, jm)
-      END DO
-    END DO
-  END DO
-
-  DO jm = 1, nl
-    DO im = 1, nl
-      DO il = 1, ncum
-        IF (zm(il,im)/=0.) THEN
-          ment(il, im, jm) = ment(il, im, jm)*m(il, im)/zm(il, im)
-        END IF
-      END DO
-    END DO
-  END DO
-
-  DO jm = 1, nl
-    DO im = 1, nl
-      DO il = 1, ncum
-        qents(il, im, jm) = qent(il, im, jm)
-        ments(il, im, jm) = ment(il, im, jm)
-      END DO
-    END DO
-  END DO
-
-  RETURN
-END SUBROUTINE cv3_mixing
-
-SUBROUTINE cv3_unsat(nloc, ncum, nd, na, ntra, icb, inb, iflag, &
-                     t, rr, rs, gz, u, v, tra, p, ph, &
-                     th, tv, lv, lf, cpn, ep, sigp, clw, frac_s, qpreca, frac_a, qta , &                       !!jygprl
-                     m, ment, elij, delt, plcl, coef_clos, &
-                     mp, rp, up, vp, trap, wt, water, evap, fondue, ice, &
-                     faci, b, sigd, &
-                     wdtrainA, wdtrainS, wdtrainM)                                      ! RomP
-  USE print_control_mod, ONLY: prt_level, lunout
-  IMPLICIT NONE
-
-
-  include "cvthermo.h"
-  include "cv3param.h"
-  include "cvflag.h"
-  include "nuage.h"
-
-!inputs:
-  INTEGER, INTENT (IN)                               :: ncum, nd, na, ntra, nloc
-  INTEGER, DIMENSION (nloc), INTENT (IN)             :: icb, inb
-  REAL, INTENT(IN)                                   :: delt
-  REAL, DIMENSION (nloc), INTENT (IN)                :: plcl
-  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: t, rr, rs
-  REAL, DIMENSION (nloc, na), INTENT (IN)            :: gz
-  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: u, v
-  REAL, DIMENSION (nloc, nd, ntra), INTENT(IN)       :: tra
-  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: p
-  REAL, DIMENSION (nloc, nd+1), INTENT (IN)          :: ph
-  REAL, DIMENSION (nloc, na), INTENT (IN)            :: ep, sigp, clw   !adiab ascent shedding
-  REAL, DIMENSION (nloc, na), INTENT (IN)            :: frac_s          !ice fraction in adiab ascent shedding !!jygprl
-  REAL, DIMENSION (nloc, na), INTENT (IN)            :: qpreca          !adiab ascent precip                   !!jygprl
-  REAL, DIMENSION (nloc, na), INTENT (IN)            :: frac_a          !ice fraction in adiab ascent precip   !!jygprl
-  REAL, DIMENSION (nloc, na), INTENT (IN)            :: qta             !adiab ascent specific total water     !!jygprl
-  REAL, DIMENSION (nloc, na), INTENT (IN)            :: th, tv, lv, cpn
-  REAL, DIMENSION (nloc, na), INTENT (IN)            :: lf
-  REAL, DIMENSION (nloc, na), INTENT (IN)            :: m
-  REAL, DIMENSION (nloc, na, na), INTENT (IN)        :: ment, elij
-  REAL, DIMENSION (nloc), INTENT (IN)                :: coef_clos
-
-!input/output
-  INTEGER, DIMENSION (nloc), INTENT (INOUT)          :: iflag(nloc)
-
-!outputs:
-  REAL, DIMENSION (nloc, na), INTENT (OUT)           :: mp, rp, up, vp
-  REAL, DIMENSION (nloc, na), INTENT (OUT)           :: water, evap, wt
-  REAL, DIMENSION (nloc, na), INTENT (OUT)           :: ice, fondue
-  REAL, DIMENSION (nloc, na), INTENT (OUT)           :: faci            ! ice fraction in precipitation
-  REAL, DIMENSION (nloc, na, ntra), INTENT (OUT)     :: trap
-  REAL, DIMENSION (nloc, na), INTENT (OUT)           :: b
-  REAL, DIMENSION (nloc), INTENT (OUT)               :: sigd
-! 25/08/10 - RomP---- ajout des masses precipitantes ejectees
-! de l ascendance adiabatique et des flux melanges Pa et Pm.
-! Distinction des wdtrain
-! Pa = wdtrainA     Pm = wdtrainM
-  REAL, DIMENSION (nloc, na), INTENT (OUT)           :: wdtrainA, wdtrainS, wdtrainM
-
-!local variables
-  INTEGER i, j, k, il, num1, ndp1
-  REAL smallestreal
-  REAL tinv, delti, coef
-  REAL awat, afac, afac1, afac2, bfac
-  REAL pr1, pr2, sigt, b6, c6, d6, e6, f6, revap, delth
-  REAL amfac, amp2, xf, tf, fac2, ur, sru, fac, d, af, bf
-  REAL ampmax, thaw
-  REAL tevap(nloc)
-  REAL, DIMENSION (nloc, na)      :: lvcp, lfcp
-  REAL, DIMENSION (nloc, na)      :: h, hm
-  REAL, DIMENSION (nloc, na)      :: ma
-  REAL, DIMENSION (nloc, na)      :: frac          ! ice fraction in precipitation source
-  REAL, DIMENSION (nloc, na)      :: fraci         ! provisionnal ice fraction in precipitation
-  REAL, DIMENSION (nloc, na)      :: prec
-  REAL wdtrain(nloc)
-  LOGICAL lwork(nloc), mplus(nloc)
-
-
-! ------------------------------------------------------
-IF (prt_level .GE. 10) print *,' ->cv3_unsat, iflag(1) ', iflag(1)
-
-smallestreal=tiny(smallestreal)
-
-! =============================
-! --- INITIALIZE OUTPUT ARRAYS 
-! =============================
-!  (loops up to nl+1)
-mp(:,:) = 0.
-rp(:,:) = 0.
-up(:,:) = 0.
-vp(:,:) = 0.
-water(:,:) = 0.
-evap(:,:) = 0.
-wt(:,:) = 0.
-ice(:,:) = 0.
-fondue(:,:) = 0.
-faci(:,:) = 0.
-b(:,:) = 0.
-sigd(:) = 0.
-!! RomP >>>
-wdtrainA(:,:) = 0.
-wdtrainS(:,:) = 0.
-wdtrainM(:,:) = 0.
-!! RomP <<<
-
-  DO i = 1, nlp
-    DO il = 1, ncum
-      rp(il, i) = rr(il, i)
-      up(il, i) = u(il, i)
-      vp(il, i) = v(il, i)
-      wt(il, i) = 0.001
-    END DO
-  END DO
-
-! ***  Set the fractionnal area sigd of precipitating downdraughts
-  DO il = 1, ncum
-    sigd(il) = sigdz*coef_clos(il)
-  END DO
-
-! =====================================================================
-! --- INITIALIZE VARIOUS ARRAYS AND PARAMETERS USED IN THE COMPUTATIONS
-! =====================================================================
-!  (loops up to nl+1)
-
-  delti = 1./delt
-  tinv = 1./3.
-
-  DO i = 1, nlp
-    DO il = 1, ncum
-      frac(il, i) = 0.0
-      fraci(il, i) = 0.0
-      prec(il, i) = 0.0
-      lvcp(il, i) = lv(il, i)/cpn(il, i)
-      lfcp(il, i) = lf(il, i)/cpn(il, i)
-    END DO
-  END DO
-
-!AC!        do k=1,ntra
-!AC!         do i=1,nd
-!AC!          do il=1,ncum
-!AC!           trap(il,i,k)=tra(il,i,k)
-!AC!          enddo
-!AC!         enddo
-!AC!        enddo
-
-! ***  check whether ep(inb)=0, if so, skip precipitating    ***
-! ***             downdraft calculation                      ***
-
-
-  DO il = 1, ncum
-!!          lwork(il)=.TRUE.
-!!          if(ep(il,inb(il)).lt.0.0001)lwork(il)=.FALSE.
-!jyg<
-!!    lwork(il) = ep(il, inb(il)) >= 0.0001
-    lwork(il) = ep(il, inb(il)) >= 0.0001 .AND. iflag(il) <= 2
-  END DO
-
-!
-! Get adiabatic ascent mass flux 
-!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-  IF (adiab_ascent_mass_flux_depends_on_ejectliq) THEN
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!!! Warning : this option leads to water conservation violation
-!!!           Expert only
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-    DO il = 1, ncum
-      ma(il, nlp) = 0.
-      ma(il, 1)   = 0.
-    END DO
-
-  DO i = nl, 2, -1
-      DO il = 1, ncum
-        ma(il, i) = ma(il, i+1)*(1.-qta(il,i))/(1.-qta(il,i-1)) + m(il, i)
-      END DO
-  END DO
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-  ELSE ! (adiab_ascent_mass_flux_depends_on_ejectliq)
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-    DO il = 1, ncum
-      ma(il, nlp) = 0.
-      ma(il, 1)   = 0.
-    END DO
-
-  DO i = nl, 2, -1
-      DO il = 1, ncum
-        ma(il, i) = ma(il, i+1) + m(il, i)
-      END DO
-  END DO
-
-  ENDIF ! (adiab_ascent_mass_flux_depends_on_ejectliq) ELSE
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-!
-! ***                    begin downdraft loop                    ***
-!
-! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-
-  DO i = nl + 1, 1, -1
-
-    num1 = 0
-    DO il = 1, ncum
-      IF (i<=inb(il) .AND. lwork(il)) num1 = num1 + 1
-    END DO
-    IF (num1<=0) GO TO 400
-
-    CALL zilch(wdtrain, ncum)
-
-
-! ***  integrate liquid water equation to find condensed water   ***
-! ***                and condensed water flux                    ***
-!
-!
-! ***              calculate detrained precipitation             ***
-
-
-    DO il = 1, ncum                                                   
-      IF (i<=inb(il) .AND. lwork(il)) THEN                            
-        wdtrain(il) = grav*ep(il, i)*m(il, i)*clw(il, i)            
-        wdtrainS(il, i) = wdtrain(il)/grav                                            !   Ps   jyg
-!!        wdtrainA(il, i) = wdtrain(il)/grav                                          !   Ps   RomP
-      END IF                                                          
-    END DO                                                            
-
-    IF (i>1) THEN
-      DO j = 1, i - 1
-        DO il = 1, ncum
-          IF (i<=inb(il) .AND. lwork(il)) THEN
-            awat = elij(il, j, i) - (1.-ep(il,i))*clw(il, i)
-            awat = max(awat, 0.0)
-            wdtrain(il) = wdtrain(il) + grav*awat*ment(il, j, i)
-            wdtrainM(il, i) = wdtrain(il)/grav - wdtrainS(il, i)    !   Pm  jyg
-!!            wdtrainM(il, i) = wdtrain(il)/grav - wdtrainA(il, i)  !   Pm  RomP
-          END IF
-        END DO
-      END DO
-    END IF
-
-    IF (cvflag_prec_eject) THEN
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-      IF (adiab_ascent_mass_flux_depends_on_ejectliq) THEN
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!!! Warning : this option leads to water conservation violation
-!!!           Expert only
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-          IF ( i > 1) THEN
-            DO il = 1, ncum
-              IF (i<=inb(il) .AND. lwork(il)) THEN
-                wdtrainA(il,i) = ma(il, i+1)*(qta(il, i-1)-qta(il,i))/(1. - qta(il, i-1))    !   Pa   jygprl
-                wdtrain(il) = wdtrain(il) + grav*wdtrainA(il,i)
-              END IF
-            END DO
-          ENDIF  ! ( i > 1)
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-      ELSE ! (adiab_ascent_mass_flux_depends_on_ejectliq)
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-          IF ( i > 1) THEN
-            DO il = 1, ncum
-              IF (i<=inb(il) .AND. lwork(il)) THEN
-                wdtrainA(il,i) = ma(il, i+1)*(qta(il, i-1)-qta(il,i))                        !   Pa   jygprl
-                wdtrain(il) = wdtrain(il) + grav*wdtrainA(il,i)
-              END IF
-            END DO
-          ENDIF  ! ( i > 1)
-
-      ENDIF ! (adiab_ascent_mass_flux_depends_on_ejectliq) ELSE
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-    ENDIF  ! (cvflag_prec_eject)
-
-
-! ***    find rain water and evaporation using provisional   ***
-! ***              estimates of rp(i)and rp(i-1)             ***
-
-
-    IF (cvflag_ice) THEN                                                                                !!jygprl
-      IF (cvflag_prec_eject) THEN
-        DO il = 1, ncum                                                                                   !!jygprl
-          IF (i<=inb(il) .AND. lwork(il)) THEN                                                            !!jygprl
-            frac(il, i) = (frac_a(il,i)*wdtrainA(il,i)+frac_s(il,i)*(wdtrainS(il,i)+wdtrainM(il,i))) / &  !!jygprl
-                          max(wdtrainA(il,i)+wdtrainS(il,i)+wdtrainM(il,i),smallestreal)                  !!jygprl
-            fraci(il, i) = frac(il, i)                                                                    !!jygprl
-          END IF                                                                                          !!jygprl
-        END DO                                                                                            !!jygprl
-      ELSE  ! (cvflag_prec_eject)
-        DO il = 1, ncum                                                                                   !!jygprl
-          IF (i<=inb(il) .AND. lwork(il)) THEN                                                            !!jygprl
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-            IF (keepbug_ice_frac) THEN
-              frac(il, i) = frac_s(il, i)
-!       Ice fraction computed again here as a function of the temperature seen by unsaturated downdraughts
-!       (i.e. the cold pool temperature) for compatibility with earlier versions.
-              fraci(il, i) = 1. - (t(il,i)-243.15)/(263.15-243.15)
-              fraci(il, i) = min(max(fraci(il,i),0.0), 1.0)
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-            ELSE  ! (keepbug_ice_frac)
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-              frac(il, i) = frac_s(il, i)
-              fraci(il, i) = frac(il, i)                                                                    !!jygprl
-            ENDIF  ! (keepbug_ice_frac)
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-          END IF                                                                                          !!jygprl
-        END DO                                                                                            !!jygprl
-      ENDIF  ! (cvflag_prec_eject)
-    END IF                                                                                              !!jygprl
-
-
-    DO il = 1, ncum
-      IF (i<=inb(il) .AND. lwork(il)) THEN
-
-        wt(il, i) = 45.0
-
-        IF (i<inb(il)) THEN
-          rp(il, i) = rp(il, i+1) + &
-                      (cpd*(t(il,i+1)-t(il,i))+gz(il,i+1)-gz(il,i))/lv(il, i)
-          rp(il, i) = 0.5*(rp(il,i)+rr(il,i))
-        END IF
-        rp(il, i) = max(rp(il,i), 0.0)
-        rp(il, i) = amin1(rp(il,i), rs(il,i))
-        rp(il, inb(il)) = rr(il, inb(il))
-
-        IF (i==1) THEN
-          afac = p(il, 1)*(rs(il,1)-rp(il,1))/(1.0E4+2000.0*p(il,1)*rs(il,1))
-          IF (cvflag_ice) THEN
-            afac1 = p(il, i)*(rs(il,1)-rp(il,1))/(1.0E4+2000.0*p(il,1)*rs(il,1))
-          END IF
-        ELSE
-          rp(il, i-1) = rp(il, i) + (cpd*(t(il,i)-t(il,i-1))+gz(il,i)-gz(il,i-1))/lv(il, i)
-          rp(il, i-1) = 0.5*(rp(il,i-1)+rr(il,i-1))
-          rp(il, i-1) = amin1(rp(il,i-1), rs(il,i-1))
-          rp(il, i-1) = max(rp(il,i-1), 0.0)
-          afac1 = p(il, i)*(rs(il,i)-rp(il,i))/(1.0E4+2000.0*p(il,i)*rs(il,i))
-          afac2 = p(il, i-1)*(rs(il,i-1)-rp(il,i-1))/(1.0E4+2000.0*p(il,i-1)*rs(il,i-1))
-          afac = 0.5*(afac1+afac2)
-        END IF
-        IF (i==inb(il)) afac = 0.0
-        afac = max(afac, 0.0)
-        bfac = 1./(sigd(il)*wt(il,i))
-
-!
-    IF (prt_level >= 20) THEN
-      Print*, 'cv3_unsat after provisional rp estimate: rp, afac, bfac ', &
-          i, rp(1, i), afac,bfac
-    ENDIF
-!
-!JYG1
-! cc        sigt=1.0
-! cc        if(i.ge.icb)sigt=sigp(i)
-! prise en compte de la variation progressive de sigt dans
-! les couches icb et icb-1:
-! pour plcl<ph(i+1), pr1=0 & pr2=1
-! pour plcl>ph(i),   pr1=1 & pr2=0
-! pour ph(i+1)<plcl<ph(i), pr1 est la proportion a cheval
-! sur le nuage, et pr2 est la proportion sous la base du
-! nuage.
-        pr1 = (plcl(il)-ph(il,i+1))/(ph(il,i)-ph(il,i+1))
-        pr1 = max(0., min(1.,pr1))
-        pr2 = (ph(il,i)-plcl(il))/(ph(il,i)-ph(il,i+1))
-        pr2 = max(0., min(1.,pr2))
-        sigt = sigp(il, i)*pr1 + pr2
-!JYG2
-
-!JYG----
-!    b6 = bfac*100.*sigd(il)*(ph(il,i)-ph(il,i+1))*sigt*afac
-!    c6 = water(il,i+1) + wdtrain(il)*bfac
-!    c6 = prec(il,i+1) + wdtrain(il)*bfac
-!    revap=0.5*(-b6+sqrt(b6*b6+4.*c6))
-!    evap(il,i)=sigt*afac*revap
-!    water(il,i)=revap*revap
-!    prec(il,i)=revap*revap
-!!        print *,' i,b6,c6,revap,evap(il,i),water(il,i),wdtrain(il) ', &
-!!                 i,b6,c6,revap,evap(il,i),water(il,i),wdtrain(il)
-!!---end jyg---
-
-! --------retour à la formulation originale d'Emanuel.
-        IF (cvflag_ice) THEN
-
-!   b6=bfac*50.*sigd(il)*(ph(il,i)-ph(il,i+1))*sigt*afac
-!   c6=prec(il,i+1)+bfac*wdtrain(il) &
-!       -50.*sigd(il)*bfac*(ph(il,i)-ph(il,i+1))*evap(il,i+1)
-!   if(c6.gt.0.0)then
-!   revap=0.5*(-b6+sqrt(b6*b6+4.*c6))
-
-!JAM  Attention: evap=sigt*E
-!    Modification: evap devient l'évaporation en milieu de couche
-!    car nécessaire dans cv3_yield
-!    Du coup, il faut modifier pas mal d'équations...
-!    et l'expression de afac qui devient afac1
-!    revap=sqrt((prec(i+1)+prec(i))/2)
-
-          b6 = bfac*50.*sigd(il)*(ph(il,i)-ph(il,i+1))*sigt*afac1
-          c6 = prec(il, i+1) + 0.5*bfac*wdtrain(il)
-! print *,'bfac,sigd(il),sigt,afac1 ',bfac,sigd(il),sigt,afac1
-! print *,'prec(il,i+1),wdtrain(il) ',prec(il,i+1),wdtrain(il)
-! print *,'b6,c6,b6*b6+4.*c6 ',b6,c6,b6*b6+4.*c6
-          IF (c6>b6*b6+1.E-20) THEN
-            revap = 2.*c6/(b6+sqrt(b6*b6+4.*c6))
-          ELSE
-            revap = (-b6+sqrt(b6*b6+4.*c6))/2.
-          END IF
-          prec(il, i) = max(0., 2.*revap*revap-prec(il,i+1))
-! print*,prec(il,i),'neige'
-
-!JYG    Dans sa formulation originale, Emanuel calcule l'evaporation par:
-! c             evap(il,i)=sigt*afac*revap
-! ce qui n'est pas correct. Dans cv_routines, la formulation a été modifiee.
-! Ici,l'evaporation evap est simplement calculee par l'equation de
-! conservation.
-! prec(il,i)=revap*revap
-! else
-!JYG----   Correction : si c6 <= 0, water(il,i)=0.
-! prec(il,i)=0.
-! endif
-
-!JYG---   Dans tous les cas, evaporation = [tt ce qui entre dans la couche i]
-! moins [tt ce qui sort de la couche i]
-! print *, 'evap avec ice'
-          evap(il, i) = (wdtrain(il)+sigd(il)*wt(il,i)*(prec(il,i+1)-prec(il,i))) / &
-                        (sigd(il)*(ph(il,i)-ph(il,i+1))*100.)
-!
-    IF (prt_level >= 20) THEN
-      Print*, 'cv3_unsat after evap computation: wdtrain, sigd, wt, prec(i+1),prec(i) ', &
-          i, wdtrain(1), sigd(1), wt(1,i), prec(1,i+1),prec(1,i)
-    ENDIF
-!
-
-!jyg<
-          d6 = prec(il,i)-prec(il,i+1)
-
-!!          d6 = bfac*wdtrain(il) - 100.*sigd(il)*bfac*(ph(il,i)-ph(il,i+1))*evap(il, i)
-!!          e6 = bfac*wdtrain(il)
-!!          f6 = -100.*sigd(il)*bfac*(ph(il,i)-ph(il,i+1))*evap(il, i)
-!>jyg
-!CR:tmax_fonte_cv: T for which ice is totally melted (used to be 275.15)
-          thaw = (t(il,i)-273.15)/(tmax_fonte_cv-273.15)
-          thaw = min(max(thaw,0.0), 1.0)
-!jyg<
-          water(il, i) = water(il, i+1) + (1-fraci(il,i))*d6
-          ice(il, i)   = ice(il, i+1)   + fraci(il, i)*d6
-          water(il, i) = min(prec(il,i), max(water(il,i), 0.))
-          ice(il, i)   = min(prec(il,i), max(ice(il,i),   0.))
-
-!!          water(il, i) = water(il, i+1) + (1-fraci(il,i))*d6
-!!          water(il, i) = max(water(il,i), 0.)
-!!          ice(il, i) = ice(il, i+1) + fraci(il, i)*d6
-!!          ice(il, i) = max(ice(il,i), 0.)
-!>jyg
-          fondue(il, i) = ice(il, i)*thaw
-          water(il, i) = water(il, i) + fondue(il, i)
-          ice(il, i) = ice(il, i) - fondue(il, i)
-
-          IF (water(il,i)+ice(il,i)<1.E-30) THEN
-            faci(il, i) = 0.
-          ELSE
-            faci(il, i) = ice(il, i)/(water(il,i)+ice(il,i))
-          END IF
-
-!           water(il,i)=water(il,i+1)+(1.-fraci(il,i))*e6+(1.-faci(il,i))*f6
-!           water(il,i)=max(water(il,i),0.)
-!           ice(il,i)=ice(il,i+1)+fraci(il,i)*e6+faci(il,i)*f6
-!           ice(il,i)=max(ice(il,i),0.)
-!           fondue(il,i)=ice(il,i)*thaw
-!           water(il,i)=water(il,i)+fondue(il,i)
-!           ice(il,i)=ice(il,i)-fondue(il,i)
-            
-!           if((water(il,i)+ice(il,i)).lt.1.e-30)then
-!             faci(il,i)=0.
-!           else
-!             faci(il,i)=ice(il,i)/(water(il,i)+ice(il,i))
-!           endif
-
-        ELSE
-          b6 = bfac*50.*sigd(il)*(ph(il,i)-ph(il,i+1))*sigt*afac
-          c6 = water(il, i+1) + bfac*wdtrain(il) - &
-               50.*sigd(il)*bfac*(ph(il,i)-ph(il,i+1))*evap(il, i+1)
-          IF (c6>0.0) THEN
-            revap = 0.5*(-b6+sqrt(b6*b6+4.*c6))
-            water(il, i) = revap*revap
-          ELSE
-            water(il, i) = 0.
-          END IF
-! print *, 'evap sans ice'
-          evap(il, i) = (wdtrain(il)+sigd(il)*wt(il,i)*(water(il,i+1)-water(il,i)))/ &
-                        (sigd(il)*(ph(il,i)-ph(il,i+1))*100.)
-
-        END IF
-      END IF !(i.le.inb(il) .and. lwork(il))
-    END DO
-! ----------------------------------------------------------------
-
-! cc
-! ***  calculate precipitating downdraft mass flux under     ***
-! ***              hydrostatic approximation                 ***
-
-    DO il = 1, ncum
-      IF (i<=inb(il) .AND. lwork(il) .AND. i/=1) THEN
-
-        tevap(il) = max(0.0, evap(il,i))
-        delth = max(0.001, (th(il,i)-th(il,i-1)))
-        IF (cvflag_ice) THEN
-          IF (cvflag_grav) THEN
-            mp(il, i) = 100.*ginv*(lvcp(il,i)*sigd(il)*tevap(il)* &
-                                               (p(il,i-1)-p(il,i))/delth + &
-                                   lfcp(il,i)*sigd(il)*faci(il,i)*tevap(il)* &
-                                               (p(il,i-1)-p(il,i))/delth + &
-                                   lfcp(il,i)*sigd(il)*wt(il,i)/100.*fondue(il,i)* &
-                                               (p(il,i-1)-p(il,i))/delth/(ph(il,i)-ph(il,i+1)))
-          ELSE
-            mp(il, i) = 10.*(lvcp(il,i)*sigd(il)*tevap(il)* &
-                                                (p(il,i-1)-p(il,i))/delth + &
-                             lfcp(il,i)*sigd(il)*faci(il,i)*tevap(il)* &
-                                                (p(il,i-1)-p(il,i))/delth + &
-                             lfcp(il,i)*sigd(il)*wt(il,i)/100.*fondue(il,i)* &
-                                                (p(il,i-1)-p(il,i))/delth/(ph(il,i)-ph(il,i+1)))
-
-          END IF
-        ELSE
-          IF (cvflag_grav) THEN
-            mp(il, i) = 100.*ginv*lvcp(il, i)*sigd(il)*tevap(il)* &
-                                                (p(il,i-1)-p(il,i))/delth
-          ELSE
-            mp(il, i) = 10.*lvcp(il, i)*sigd(il)*tevap(il)* &
-                                                (p(il,i-1)-p(il,i))/delth
-          END IF
-
-        END IF
-
-      END IF !(i.le.inb(il) .and. lwork(il) .and. i.ne.1)
-      IF (prt_level .GE. 20) THEN
-        PRINT *,'cv3_unsat, mp hydrostatic ', i, mp(il,i)
-      ENDIF
-    END DO
-! ----------------------------------------------------------------
-
-! ***           if hydrostatic assumption fails,             ***
-! ***   solve cubic difference equation for downdraft theta  ***
-! ***  and mass flux from two simultaneous differential eqns ***
-
-    DO il = 1, ncum
-      IF (i<=inb(il) .AND. lwork(il) .AND. i/=1) THEN
-
-        amfac = sigd(il)*sigd(il)*70.0*ph(il, i)*(p(il,i-1)-p(il,i))* &
-                         (th(il,i)-th(il,i-1))/(tv(il,i)*th(il,i))
-        amp2 = abs(mp(il,i+1)*mp(il,i+1)-mp(il,i)*mp(il,i))
-
-        IF (amp2>(0.1*amfac)) THEN
-          xf = 100.0*sigd(il)*sigd(il)*sigd(il)*(ph(il,i)-ph(il,i+1))
-          tf = b(il, i) - 5.0*(th(il,i)-th(il,i-1))*t(il, i) / &
-                              (lvcp(il,i)*sigd(il)*th(il,i))
-          af = xf*tf + mp(il, i+1)*mp(il, i+1)*tinv
-
-          IF (cvflag_ice) THEN
-            bf = 2.*(tinv*mp(il,i+1))**3 + tinv*mp(il, i+1)*xf*tf + &
-                 50.*(p(il,i-1)-p(il,i))*xf*(tevap(il)*(1.+(lf(il,i)/lv(il,i))*faci(il,i)) + &
-                (lf(il,i)/lv(il,i))*wt(il,i)/100.*fondue(il,i)/(ph(il,i)-ph(il,i+1)))
-          ELSE
-
-            bf = 2.*(tinv*mp(il,i+1))**3 + tinv*mp(il, i+1)*xf*tf + &
-                                           50.*(p(il,i-1)-p(il,i))*xf*tevap(il)
-          END IF
-
-          fac2 = 1.0
-          IF (bf<0.0) fac2 = -1.0
-          bf = abs(bf)
-          ur = 0.25*bf*bf - af*af*af*tinv*tinv*tinv
-          IF (ur>=0.0) THEN
-            sru = sqrt(ur)
-            fac = 1.0
-            IF ((0.5*bf-sru)<0.0) fac = -1.0
-            mp(il, i) = mp(il, i+1)*tinv + (0.5*bf+sru)**tinv + &
-                                           fac*(abs(0.5*bf-sru))**tinv
-          ELSE
-            d = atan(2.*sqrt(-ur)/(bf+1.0E-28))
-            IF (fac2<0.0) d = 3.14159 - d
-            mp(il, i) = mp(il, i+1)*tinv + 2.*sqrt(af*tinv)*cos(d*tinv)
-          END IF
-          mp(il, i) = max(0.0, mp(il,i))
-          IF (prt_level .GE. 20) THEN
-            PRINT *,'cv3_unsat, mp cubic ', i, mp(il,i)
-          ENDIF
-
-          IF (cvflag_ice) THEN
-            IF (cvflag_grav) THEN
-!JYG : il y a vraisemblablement une erreur dans la ligne 2 suivante:
-! il faut diviser par (mp(il,i)*sigd(il)*grav) et non par (mp(il,i)+sigd(il)*0.1).
-! Et il faut bien revoir les facteurs 100.
-              b(il, i-1) = b(il, i) + 100.0*(p(il,i-1)-p(il,i))* &
-                           (tevap(il)*(1.+(lf(il,i)/lv(il,i))*faci(il,i)) + &
-                           (lf(il,i)/lv(il,i))*wt(il,i)/100.*fondue(il,i) / &
-                           (ph(il,i)-ph(il,i+1))) / &
-                           (mp(il,i)+sigd(il)*0.1) - &
-                           10.0*(th(il,i)-th(il,i-1))*t(il, i) / &
-                           (lvcp(il,i)*sigd(il)*th(il,i))
-            ELSE
-              b(il, i-1) = b(il, i) + 100.0*(p(il,i-1)-p(il,i))*&
-                           (tevap(il)*(1.+(lf(il,i)/lv(il,i))*faci(il,i)) + &
-                           (lf(il,i)/lv(il,i))*wt(il,i)/100.*fondue(il,i) / &
-                           (ph(il,i)-ph(il,i+1))) / &
-                           (mp(il,i)+sigd(il)*0.1) - &
-                           10.0*(th(il,i)-th(il,i-1))*t(il, i) / &
-                           (lvcp(il,i)*sigd(il)*th(il,i))
-            END IF
-          ELSE
-            IF (cvflag_grav) THEN
-              b(il, i-1) = b(il, i) + 100.0*(p(il,i-1)-p(il,i))*tevap(il) / &
-                           (mp(il,i)+sigd(il)*0.1) - &
-                           10.0*(th(il,i)-th(il,i-1))*t(il, i) / &
-                           (lvcp(il,i)*sigd(il)*th(il,i))
-            ELSE
-              b(il, i-1) = b(il, i) + 100.0*(p(il,i-1)-p(il,i))*tevap(il) / &
-                           (mp(il,i)+sigd(il)*0.1) - &
-                           10.0*(th(il,i)-th(il,i-1))*t(il, i) / &
-                           (lvcp(il,i)*sigd(il)*th(il,i))
-            END IF
-          END IF
-          b(il, i-1) = max(b(il,i-1), 0.0)
-
-        END IF !(amp2.gt.(0.1*amfac))
-
-!jyg<    This part shifted 10 lines farther
-!!! ***         limit magnitude of mp(i) to meet cfl condition      ***
-!!
-!!        ampmax = 2.0*(ph(il,i)-ph(il,i+1))*delti
-!!        amp2 = 2.0*(ph(il,i-1)-ph(il,i))*delti
-!!        ampmax = min(ampmax, amp2)
-!!        mp(il, i) = min(mp(il,i), ampmax)
-!>jyg
-
-! ***      force mp to decrease linearly to zero                 ***
-! ***       between cloud base and the surface                   ***
-
-
-! c      if(p(il,i).gt.p(il,icb(il)))then
-! c       mp(il,i)=mp(il,icb(il))*(p(il,1)-p(il,i))/(p(il,1)-p(il,icb(il)))
-! c      endif
-        IF (ph(il,i)>0.9*plcl(il)) THEN
-          mp(il, i) = mp(il, i)*(ph(il,1)-ph(il,i))/(ph(il,1)-0.9*plcl(il))
-        END IF
-
-!jyg<    Shifted part
-! ***         limit magnitude of mp(i) to meet cfl condition      ***
-
-        ampmax = 2.0*(ph(il,i)-ph(il,i+1))*delti
-        amp2 = 2.0*(ph(il,i-1)-ph(il,i))*delti
-        ampmax = min(ampmax, amp2)
-        mp(il, i) = min(mp(il,i), ampmax)
-!>jyg
-
-      END IF ! (i.le.inb(il) .and. lwork(il) .and. i.ne.1)
-    END DO
-! ----------------------------------------------------------------
-!
-    IF (prt_level >= 20) THEN
-      Print*, 'cv3_unsat after mp computation: mp, b(i), b(i-1) ', &
-          i, mp(1, i), b(1,i), b(1,max(i-1,1))
-    ENDIF
-!
-
-! ***       find mixing ratio of precipitating downdraft     ***
-
-    DO il = 1, ncum
-      IF (i<inb(il) .AND. lwork(il)) THEN
-        mplus(il) = mp(il, i) > mp(il, i+1)
-      END IF ! (i.lt.inb(il) .and. lwork(il))
-    END DO
-
-    DO il = 1, ncum
-      IF (i<inb(il) .AND. lwork(il)) THEN
-
-        rp(il, i) = rr(il, i)
-
-        IF (mplus(il)) THEN
-
-          IF (cvflag_grav) THEN
-            rp(il, i) = rp(il, i+1)*mp(il, i+1) + rr(il, i)*(mp(il,i)-mp(il,i+1)) + &
-              100.*ginv*0.5*sigd(il)*(ph(il,i)-ph(il,i+1))*(evap(il,i+1)+evap(il,i))
-          ELSE
-            rp(il, i) = rp(il, i+1)*mp(il, i+1) + rr(il, i)*(mp(il,i)-mp(il,i+1)) + &
-              5.*sigd(il)*(ph(il,i)-ph(il,i+1))*(evap(il,i+1)+evap(il,i))
-          END IF
-          rp(il, i) = rp(il, i)/mp(il, i)
-          up(il, i) = up(il, i+1)*mp(il, i+1) + u(il, i)*(mp(il,i)-mp(il,i+1))
-          up(il, i) = up(il, i)/mp(il, i)
-          vp(il, i) = vp(il, i+1)*mp(il, i+1) + v(il, i)*(mp(il,i)-mp(il,i+1))
-          vp(il, i) = vp(il, i)/mp(il, i)
-
-        ELSE ! if (mplus(il))
-
-          IF (mp(il,i+1)>1.0E-16) THEN
-            IF (cvflag_grav) THEN
-              rp(il, i) = rp(il,i+1) + 100.*ginv*0.5*sigd(il)*(ph(il,i)-ph(il,i+1)) * &
-                                       (evap(il,i+1)+evap(il,i))/mp(il,i+1)
-            ELSE
-              rp(il, i) = rp(il,i+1) + 5.*sigd(il)*(ph(il,i)-ph(il,i+1)) * &
-                                       (evap(il,i+1)+evap(il,i))/mp(il, i+1)
-            END IF
-            up(il, i) = up(il, i+1)
-            vp(il, i) = vp(il, i+1)
-          END IF ! (mp(il,i+1).gt.1.0e-16)
-        END IF ! (mplus(il)) else if (.not.mplus(il))
-
-        rp(il, i) = amin1(rp(il,i), rs(il,i))
-        rp(il, i) = max(rp(il,i), 0.0)
-
-      END IF ! (i.lt.inb(il) .and. lwork(il))
-    END DO
-! ----------------------------------------------------------------
-
-! ***       find tracer concentrations in precipitating downdraft     ***
-
-!AC!      do j=1,ntra
-!AC!       do il = 1,ncum
-!AC!       if (i.lt.inb(il) .and. lwork(il)) then
-!AC!c
-!AC!         if(mplus(il))then
-!AC!          trap(il,i,j)=trap(il,i+1,j)*mp(il,i+1)
-!AC!     :              +trap(il,i,j)*(mp(il,i)-mp(il,i+1))
-!AC!          trap(il,i,j)=trap(il,i,j)/mp(il,i)
-!AC!         else ! if (mplus(il))
-!AC!          if(mp(il,i+1).gt.1.0e-16)then
-!AC!           trap(il,i,j)=trap(il,i+1,j)
-!AC!          endif
-!AC!         endif ! (mplus(il)) else if (.not.mplus(il))
-!AC!c
-!AC!        endif ! (i.lt.inb(il) .and. lwork(il))
-!AC!       enddo
-!AC!      end do
-
-400 END DO
-! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-
-! ***                    end of downdraft loop                    ***
-
-! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-
-
-  RETURN
-
-END SUBROUTINE cv3_unsat
-
-SUBROUTINE cv3_yield(nloc, ncum, nd, na, ntra, ok_conserv_q, &
-                     icb, inb, delt, &
-                     t, rr, t_wake, rr_wake, s_wake, u, v, tra, &
-                     gz, p, ph, h, hp, lv, lf, cpn, th, th_wake, &
-                     ep, clw, qpreca, m, tp, mp, rp, up, vp, trap, &
-                     wt, water, ice, evap, fondue, faci, b, sigd, &
-                     ment, qent, hent, iflag_mix, uent, vent, &
-                     nent, elij, traent, sig, &
-                     tv, tvp, wghti, &
-                     iflag, precip, Vprecip, Vprecipi, &     ! jyg: Vprecipi
-                     ft, fr, fr_comp, fu, fv, ftra, &                 ! jyg
-                     cbmf, upwd, dnwd, dnwd0, ma, mip, &
-!!                     tls, tps,                             ! useless . jyg
-                     qcondc, wd, &
-                     ftd, fqd, qta, qtc, sigt, detrain, tau_cld_cv, coefw_cld_cv)
-
-    USE print_control_mod, ONLY: lunout, prt_level
-    USE add_phys_tend_mod, only : fl_cor_ebil
-
-  IMPLICIT NONE
-
-  include "cvthermo.h"
-  include "cv3param.h"
-  include "cvflag.h"
-  include "conema3.h"
-
-!inputs:
-      INTEGER, INTENT (IN)                               :: iflag_mix
-      INTEGER, INTENT (IN)                               :: ncum, nd, na, ntra, nloc
-      LOGICAL, INTENT (IN)                               :: ok_conserv_q
-      INTEGER, DIMENSION (nloc), INTENT (IN)             :: icb, inb
-      REAL, INTENT (IN)                                  :: delt
-      REAL, DIMENSION (nloc, nd), INTENT (IN)            :: t, rr, u, v
-      REAL, DIMENSION (nloc, nd), INTENT (IN)            :: t_wake, rr_wake
-      REAL, DIMENSION (nloc), INTENT (IN)                :: s_wake
-      REAL, DIMENSION (nloc, nd, ntra), INTENT (IN)      :: tra
-      REAL, DIMENSION (nloc, nd), INTENT (IN)            :: p
-      REAL, DIMENSION (nloc, nd+1), INTENT (IN)          :: ph
-      REAL, DIMENSION (nloc, na), INTENT (IN)            :: gz, h, hp
-      REAL, DIMENSION (nloc, na), INTENT (IN)            :: th, tp
-      REAL, DIMENSION (nloc, na), INTENT (IN)            :: lv, cpn, ep, clw
-      REAL, DIMENSION (nloc, na), INTENT (IN)            :: lf
-      REAL, DIMENSION (nloc, na), INTENT (IN)            :: rp, up
-      REAL, DIMENSION (nloc, na), INTENT (IN)            :: vp
-      REAL, DIMENSION (nloc, nd), INTENT (IN)            :: wt
-      REAL, DIMENSION (nloc, nd, ntra), INTENT (IN)      :: trap
-      REAL, DIMENSION (nloc, na), INTENT (IN)            :: water, evap, b
-      REAL, DIMENSION (nloc, na), INTENT (IN)            :: fondue, faci, ice
-      REAL, DIMENSION (nloc, na, na), INTENT (IN)        :: qent, uent
-      REAL, DIMENSION (nloc, na, na), INTENT (IN)        :: hent
-      REAL, DIMENSION (nloc, na, na), INTENT (IN)        :: vent, elij
-      INTEGER, DIMENSION (nloc, nd), INTENT (IN)         :: nent
-      REAL, DIMENSION (nloc, na, na, ntra), INTENT (IN)  :: traent
-      REAL, DIMENSION (nloc, nd), INTENT (IN)            :: tv, tvp, wghti
-      REAL, DIMENSION (nloc, nd), INTENT (IN)            :: qta
-      REAL, DIMENSION (nloc, na),INTENT(IN)              :: qpreca
-      REAL, INTENT(IN)                                   :: tau_cld_cv, coefw_cld_cv
-!
-!input/output:
-      REAL, DIMENSION (nloc, na), INTENT (INOUT)         :: m, mp
-      REAL, DIMENSION (nloc, na, na), INTENT (INOUT)     :: ment
-      INTEGER, DIMENSION (nloc), INTENT (INOUT)          :: iflag
-      REAL, DIMENSION (nloc, nd), INTENT (INOUT)         :: sig
-      REAL, DIMENSION (nloc), INTENT (INOUT)             :: sigd
-!
-!outputs:
-      REAL, DIMENSION (nloc), INTENT (OUT)               :: precip
-      REAL, DIMENSION (nloc, nd), INTENT (OUT)           :: ft, fr, fu, fv , fr_comp
-      REAL, DIMENSION (nloc, nd), INTENT (OUT)           :: ftd, fqd
-      REAL, DIMENSION (nloc, nd, ntra), INTENT (OUT)     :: ftra
-      REAL, DIMENSION (nloc, nd), INTENT (OUT)           :: upwd, dnwd, ma
-      REAL, DIMENSION (nloc, nd), INTENT (OUT)           :: dnwd0, mip
-      REAL, DIMENSION (nloc, nd+1), INTENT (OUT)         :: Vprecip
-      REAL, DIMENSION (nloc, nd+1), INTENT (OUT)         :: Vprecipi
-!!      REAL tls(nloc, nd), tps(nloc, nd)                    ! useless . jyg
-      REAL, DIMENSION (nloc, nd), INTENT (OUT)           :: qcondc                      ! cld
-      REAL, DIMENSION (nloc, nd), INTENT (OUT)           :: qtc, sigt                   ! cld
-      REAL, DIMENSION (nloc, nd), INTENT (OUT)           :: detrain                     ! Louis : pour le calcul de Klein du terme de variance qui dÃ©traine dans lenvironnement
-      REAL, DIMENSION (nloc), INTENT (OUT)               :: wd                          ! gust
-      REAL, DIMENSION (nloc), INTENT (OUT)               :: cbmf
-!
-!local variables:
-      INTEGER                                            :: i, k, il, n, j, num1
-      REAL                                               :: rat, delti
-      REAL                                               :: ax, bx, cx, dx, ex
-      REAL                                               :: cpinv, rdcp, dpinv
-      REAL                                               :: sigaq
-      REAL, DIMENSION (nloc)                             ::  awat
-      REAL, DIMENSION (nloc, nd)                         :: lvcp, lfcp              ! , mke ! unused . jyg
-      REAL, DIMENSION (nloc)                             :: am, work, ad, amp1
-!!      real up1(nloc), dn1(nloc)
-      REAL, DIMENSION (nloc, nd, nd)                     :: up1, dn1
-!jyg<
-      REAL, DIMENSION (nloc, nd)                         :: up_to, up_from
-      REAL, DIMENSION (nloc, nd)                         :: dn_to, dn_from
-!>jyg
-      REAL, DIMENSION (nloc)                             :: asum, bsum, csum, dsum
-      REAL, DIMENSION (nloc)                             :: esum, fsum, gsum, hsum
-      REAL, DIMENSION (nloc, nd)                         :: th_wake
-      REAL, DIMENSION (nloc)                             :: alpha_qpos, alpha_qpos1
-      REAL, DIMENSION (nloc, nd)                         :: qcond, nqcond, wa           ! cld
-      REAL, DIMENSION (nloc, nd)                         :: siga, sax, mac              ! cld
-      REAL, DIMENSION (nloc)                             :: sument
-      REAL, DIMENSION (nloc, nd)                         :: sigment, qtment             ! cld
-      REAL, DIMENSION (nloc, nd, nd)                     :: qdet
-      REAL sumdq !jyg
-! 
-! -------------------------------------------------------------
-
-! initialization:
-
-  delti = 1.0/delt
-! print*,'cv3_yield initialisation delt', delt
-
-  DO il = 1, ncum
-    precip(il) = 0.0
-    wd(il) = 0.0 ! gust
-  END DO
-
-!   Fluxes are on a staggered grid : loops extend up to nl+1
-  DO i = 1, nlp
-    DO il = 1, ncum
-      Vprecip(il, i) = 0.0
-      Vprecipi(il, i) = 0.0                               ! jyg
-      upwd(il, i) = 0.0
-      dnwd(il, i) = 0.0
-      dnwd0(il, i) = 0.0
-      mip(il, i) = 0.0
-    END DO
-  END DO
-  DO i = 1, nl
-    DO il = 1, ncum
-      ft(il, i) = 0.0
-      fr(il, i) = 0.0
-      fr_comp(il,i) = 0.0
-      fu(il, i) = 0.0
-      fv(il, i) = 0.0
-      ftd(il, i) = 0.0
-      fqd(il, i) = 0.0
-      qcondc(il, i) = 0.0 ! cld
-      qcond(il, i) = 0.0 ! cld
-      qtc(il, i) = 0.0 ! cld
-      qtment(il, i) = 0.0 ! cld
-      sigment(il, i) = 0.0 ! cld
-      sigt(il, i) = 0.0 ! cld
-      qdet(il,i,:) = 0.0 ! cld
-      detrain(il, i) = 0.0 ! cld
-      nqcond(il, i) = 0.0 ! cld
-    END DO
-  END DO
-! print*,'cv3_yield initialisation 2'
-!AC!      do j=1,ntra
-!AC!       do i=1,nd
-!AC!        do il=1,ncum
-!AC!          ftra(il,i,j)=0.0
-!AC!        enddo
-!AC!       enddo
-!AC!      enddo
-! print*,'cv3_yield initialisation 3'
-  DO i = 1, nl
-    DO il = 1, ncum
-      lvcp(il, i) = lv(il, i)/cpn(il, i)
-      lfcp(il, i) = lf(il, i)/cpn(il, i)
-    END DO
-  END DO
-
-
-
-! ***  calculate surface precipitation in mm/day     ***
-
-  DO il = 1, ncum
-    IF (ep(il,inb(il))>=0.0001 .AND. iflag(il)<=1) THEN
-      IF (cvflag_ice) THEN
-        precip(il) = wt(il, 1)*sigd(il)*(water(il,1)+ice(il,1)) &
-                              *86400.*1000./(rowl*grav)
-      ELSE
-        precip(il) = wt(il, 1)*sigd(il)*water(il, 1) &
-                              *86400.*1000./(rowl*grav)
-      END IF
-    END IF
-  END DO
-! print*,'cv3_yield apres calcul precip'
-
-
-! ===  calculate vertical profile of  precipitation in kg/m2/s  ===
-
-  DO i = 1, nl
-    DO il = 1, ncum
-      IF (ep(il,inb(il))>=0.0001 .AND. i<=inb(il) .AND. iflag(il)<=1) THEN
-        IF (cvflag_ice) THEN
-          Vprecip(il, i) = wt(il, i)*sigd(il)*(water(il,i)+ice(il,i))/grav
-          Vprecipi(il, i) = wt(il, i)*sigd(il)*ice(il,i)/grav                   ! jyg
-        ELSE
-          Vprecip(il, i) = wt(il, i)*sigd(il)*water(il, i)/grav
-          Vprecipi(il, i) = 0.                                                  ! jyg
-        END IF
-      END IF
-    END DO
-  END DO
-
-
-! ***  Calculate downdraft velocity scale    ***
-! ***  NE PAS UTILISER POUR L'INSTANT ***
-
-!!      do il=1,ncum
-!!        wd(il)=betad*abs(mp(il,icb(il)))*0.01*rrd*t(il,icb(il)) &
-!!                                       /(sigd(il)*p(il,icb(il)))
-!!      enddo
-
-
-! ***  calculate tendencies of lowest level potential temperature  ***
-! ***                      and mixing ratio                        ***
-
-  DO il = 1, ncum
-    work(il) = 1.0/(ph(il,1)-ph(il,2))
-    cbmf(il) = 0.0
-  END DO
-
-! - Adiabatic ascent mass flux "ma" and cloud base mass flux "cbmf"
-!-----------------------------------------------------------------
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-  IF (adiab_ascent_mass_flux_depends_on_ejectliq) THEN
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!!! Warning : this option leads to water conservation violation
-!!!           Expert only
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-  DO il = 1, ncum
-    ma(il, nlp) = 0.
-    ma(il, 1)   = 0.
-  END DO
-  DO k = nl, 2, -1
-    DO il = 1, ncum
-      ma(il, k) = ma(il, k+1)*(1.-qta(il, k))/(1.-qta(il, k-1)) + m(il, k)
-      cbmf(il) = max(cbmf(il), ma(il,k))
-    END DO
-  END DO
-  DO k = 2,nl
-    DO il = 1, ncum
-      IF (k <icb(il)) THEN
-        ma(il, k) = ma(il, k-1) + wghti(il,k-1)*cbmf(il)
-      ENDIF
-    END DO
-  END DO
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-  ELSE ! (adiab_ascent_mass_flux_depends_on_ejectliq)
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!! Line kept for compatibility with earlier versions
-  DO k = 2, nl
-    DO il = 1, ncum
-      IF (k>=icb(il)) THEN
-        cbmf(il) = cbmf(il) + m(il, k)
-      END IF
-    END DO
-  END DO
-
-  DO il = 1, ncum
-    ma(il, nlp) = 0.
-    ma(il, 1)   = 0.
-  END DO
-  DO k = nl, 2, -1
-    DO il = 1, ncum
-      ma(il, k) = ma(il, k+1) + m(il, k)
-    END DO
-  END DO
-  DO k = 2,nl
-    DO il = 1, ncum
-      IF (k <icb(il)) THEN
-        ma(il, k) = ma(il, k-1) + wghti(il,k-1)*cbmf(il)
-      ENDIF
-    END DO
-  END DO
-
-  ENDIF ! (adiab_ascent_mass_flux_depends_on_ejectliq) ELSE
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!
-!    print*,'cv3_yield avant ft'
-! am is the part of cbmf taken from the first level
-  DO il = 1, ncum
-    am(il) = cbmf(il)*wghti(il, 1)
-  END DO
-
-  DO il = 1, ncum
-    IF (iflag(il)<=1) THEN
-! convect3      if((0.1*dpinv*am).ge.delti)iflag(il)=4
-!JYG  Correction pour conserver l'eau
-! cc       ft(il,1)=-0.5*lvcp(il,1)*sigd(il)*(evap(il,1)+evap(il,2))          !precip
-      IF (cvflag_ice) THEN
-        ft(il, 1) = -lvcp(il, 1)*sigd(il)*evap(il, 1) - &
-                     lfcp(il, 1)*sigd(il)*evap(il, 1)*faci(il, 1) - &
-                     lfcp(il, 1)*sigd(il)*(fondue(il,1)*wt(il,1)) / &
-                       (100.*(ph(il,1)-ph(il,2)))                             !precip
-      ELSE
-        ft(il, 1) = -lvcp(il, 1)*sigd(il)*evap(il, 1)
-      END IF
-
-      ft(il, 1) = ft(il, 1) - 0.009*grav*sigd(il)*mp(il, 2)*t_wake(il, 1)*b(il, 1)*work(il)
-
-      IF (cvflag_ice) THEN
-        ft(il, 1) = ft(il, 1) + 0.01*sigd(il)*wt(il, 1)*(cl-cpd)*water(il, 2) * &
-                                     (t_wake(il,2)-t_wake(il,1))*work(il)/cpn(il, 1) + &
-                                0.01*sigd(il)*wt(il, 1)*(ci-cpd)*ice(il, 2) * &
-                                     (t_wake(il,2)-t_wake(il,1))*work(il)/cpn(il, 1)
-      ELSE
-        ft(il, 1) = ft(il, 1) + 0.01*sigd(il)*wt(il, 1)*(cl-cpd)*water(il, 2) * &
-                                     (t_wake(il,2)-t_wake(il,1))*work(il)/cpn(il, 1)
-      END IF
-
-      ftd(il, 1) = ft(il, 1)                                                  ! fin precip
-
-      IF ((0.01*grav*work(il)*am(il))>=delti) iflag(il) = 1 !consist vect
-!jyg<
-        IF (fl_cor_ebil >= 2) THEN
-          ft(il, 1) = ft(il, 1) + 0.01*grav*work(il)*am(il) * &
-                    ((t(il,2)-t(il,1))*cpn(il,2)+gz(il,2)-gz(il,1))/cpn(il,1)
-        ELSE
-          ft(il, 1) = ft(il, 1) + 0.01*grav*work(il)*am(il) * &
-                    (t(il,2)-t(il,1)+(gz(il,2)-gz(il,1))/cpn(il,1))
-        ENDIF
-!>jyg
-    END IF ! iflag
-  END DO
-
-
-  DO j = 2, nl
-    IF (iflag_mix>0) THEN
-      DO il = 1, ncum
-! FH WARNING a modifier :
-        cpinv = 0.
-! cpinv=1.0/cpn(il,1)
-        IF (j<=inb(il) .AND. iflag(il)<=1) THEN
-          ft(il, 1) = ft(il, 1) + 0.01*grav*work(il)*ment(il, j, 1) * &
-                     (hent(il,j,1)-h(il,1)+t(il,1)*(cpv-cpd)*(rr(il,1)-qent(il,j,1)))*cpinv
-        END IF ! j
-      END DO
-    END IF
-  END DO
-! fin sature
-
-
-  DO il = 1, ncum
-    IF (iflag(il)<=1) THEN
-!JYG1  Correction pour mieux conserver l'eau (conformite avec CONVECT4.3)
-      fr(il, 1) = 0.01*grav*mp(il, 2)*(rp(il,2)-rr_wake(il,1))*work(il) + &
-                  sigd(il)*evap(il, 1)
-!!!                  sigd(il)*0.5*(evap(il,1)+evap(il,2))
-
-      fqd(il, 1) = fr(il, 1) !precip
-
-      fr(il, 1) = fr(il, 1) + 0.01*grav*am(il)*(rr(il,2)-rr(il,1))*work(il)        !sature
-
-      fu(il, 1) = fu(il, 1) + 0.01*grav*work(il)*(mp(il,2)*(up(il,2)-u(il,1)) + &
-                                                  am(il)*(u(il,2)-u(il,1)))
-      fv(il, 1) = fv(il, 1) + 0.01*grav*work(il)*(mp(il,2)*(vp(il,2)-v(il,1)) + &
-                                                  am(il)*(v(il,2)-v(il,1)))
-    END IF ! iflag
-  END DO ! il
-
-
-!AC!     do j=1,ntra
-!AC!      do il=1,ncum
-!AC!       if (iflag(il) .le. 1) then
-!AC!       if (cvflag_grav) then
-!AC!        ftra(il,1,j)=ftra(il,1,j)+0.01*grav*work(il)
-!AC!    :                     *(mp(il,2)*(trap(il,2,j)-tra(il,1,j))
-!AC!    :             +am(il)*(tra(il,2,j)-tra(il,1,j)))
-!AC!       else
-!AC!        ftra(il,1,j)=ftra(il,1,j)+0.1*work(il)
-!AC!    :                     *(mp(il,2)*(trap(il,2,j)-tra(il,1,j))
-!AC!    :             +am(il)*(tra(il,2,j)-tra(il,1,j)))
-!AC!       endif
-!AC!       endif  ! iflag
-!AC!      enddo
-!AC!     enddo
-
-  DO j = 2, nl
-    DO il = 1, ncum
-      IF (j<=inb(il) .AND. iflag(il)<=1) THEN
-        fr(il, 1) = fr(il, 1) + 0.01*grav*work(il)*ment(il, j, 1)*(qent(il,j,1)-rr(il,1))
-        fr_comp(il,1) = fr_comp(il,1) + 0.01*grav*work(il)*ment(il, j, 1)*(qent(il,j,1)-rr(il,1))
-        fu(il, 1) = fu(il, 1) + 0.01*grav*work(il)*ment(il, j, 1)*(uent(il,j,1)-u(il,1))
-        fv(il, 1) = fv(il, 1) + 0.01*grav*work(il)*ment(il, j, 1)*(vent(il,j,1)-v(il,1))
-      END IF ! j
-    END DO
-  END DO
-
-!AC!      do k=1,ntra
-!AC!       do j=2,nl
-!AC!        do il=1,ncum
-!AC!         if (j.le.inb(il) .and. iflag(il) .le. 1) then
-!AC!
-!AC!          if (cvflag_grav) then
-!AC!           ftra(il,1,k)=ftra(il,1,k)+0.01*grav*work(il)*ment(il,j,1)
-!AC!     :                *(traent(il,j,1,k)-tra(il,1,k))
-!AC!          else
-!AC!           ftra(il,1,k)=ftra(il,1,k)+0.1*work(il)*ment(il,j,1)
-!AC!     :                *(traent(il,j,1,k)-tra(il,1,k))
-!AC!          endif
-!AC!
-!AC!         endif
-!AC!        enddo
-!AC!       enddo
-!AC!      enddo
-! print*,'cv3_yield apres ft'
-
-!jyg<
-!-----------------------------------------------------------
-           IF (ok_optim_yield) THEN                       !|
-!-----------------------------------------------------------
-!
-!***                                                      ***
-!***    Compute convective mass fluxes upwd and dnwd      ***
-
-!
-! =================================================
-!              upward fluxes                      |
-! ------------------------------------------------
-!
-upwd(:,:) = 0.
-up_to(:,:) = 0.
-up_from(:,:) = 0.
-!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-  IF (adiab_ascent_mass_flux_depends_on_ejectliq) THEN
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!! The decrease of the adiabatic ascent mass flux due to ejection of precipitation 
-!! is taken into account. 
-!! WARNING : in the present version, taking into account the mass-flux decrease due to 
-!! precipitation ejection leads to water conservation violation.
-!
-! - Upward mass flux of mixed draughts
-!---------------------------------------
-DO i = 2, nl
-  DO j = 1, i-1
-    DO il = 1, ncum
-      IF (i<=inb(il)) THEN
-        up_to(il,i) = up_to(il,i) + ment(il,j,i)
-      ENDIF
-    ENDDO
-  ENDDO
-ENDDO
-!
-DO j = 3, nl
-  DO i = 2, j-1
-    DO il = 1, ncum
-      IF (j<=inb(il)) THEN
-        up_from(il,i) = up_from(il,i) + ment(il,i,j)
-      ENDIF
-    ENDDO
-  ENDDO
-ENDDO
-!
-! The difference between upwd(il,i) and upwd(il,i-1) is due to updrafts ending in layer 
-!(i-1) (theses drafts cross interface (i-1) but not interface(i)) and to updrafts starting 
-!from layer (i-1) (theses drafts cross interface (i) but not interface(i-1)): 
-! 
-DO i = 2, nlp
-  DO il = 1, ncum
-    IF (i<=inb(il)+1) THEN
-      upwd(il,i) = max(0., upwd(il,i-1) - up_to(il,i-1) + up_from(il,i-1))
-    ENDIF
-  ENDDO
-ENDDO
-!
-! - Total upward mass flux
-!---------------------------
-DO i = 2, nlp
-  DO il = 1, ncum
-    IF (i<=inb(il)+1) THEN
-      upwd(il,i) = upwd(il,i) + ma(il,i)
-    ENDIF
-  ENDDO
-ENDDO
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-  ELSE ! (adiab_ascent_mass_flux_depends_on_ejectliq)
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!! The decrease of the adiabatic ascent mass flux due to ejection of precipitation 
-!! is not taken into account. 
-!
-! - Upward mass flux
-!-------------------
-DO i = 2, nl
-  DO il = 1, ncum
-    IF (i<=inb(il)) THEN
-      up_to(il,i) = m(il,i)
-    ENDIF
-  ENDDO
-  DO j = 1, i-1
-    DO il = 1, ncum
-      IF (i<=inb(il)) THEN
-        up_to(il,i) = up_to(il,i) + ment(il,j,i)
-      ENDIF
-    ENDDO
-  ENDDO
-ENDDO
-!
-DO i = 1, nl
-  DO il = 1, ncum
-    IF (i<=inb(il)) THEN
-      up_from(il,i) = cbmf(il)*wghti(il,i)
-    ENDIF
-  ENDDO
-ENDDO
-!
-DO j = 3, nl
-  DO i = 2, j-1
-    DO il = 1, ncum
-      IF (j<=inb(il)) THEN
-        up_from(il,i) = up_from(il,i) + ment(il,i,j)
-      ENDIF
-    ENDDO
-  ENDDO
-ENDDO
-!
-! The difference between upwd(il,i) and upwd(il,i-1) is due to updrafts ending in layer 
-!(i-1) (theses drafts cross interface (i-1) but not interface(i)) and to updrafts starting 
-!from layer (i-1) (theses drafts cross interface (i) but not interface(i-1)): 
-! 
-DO i = 2, nlp
-  DO il = 1, ncum
-    IF (i<=inb(il)+1) THEN
-      upwd(il,i) = max(0., upwd(il,i-1) - up_to(il,i-1) + up_from(il,i-1))
-    ENDIF
-  ENDDO
-ENDDO
-
-
-  ENDIF ! (adiab_ascent_mass_flux_depends_on_ejectliq) ELSE
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-!
-! =================================================
-!              downward fluxes                    |
-! ------------------------------------------------
-dnwd(:,:) = 0.
-dn_to(:,:) = 0.
-dn_from(:,:) = 0.
-DO i = 1, nl
-  DO j = i+1, nl
-    DO il = 1, ncum
-      IF (j<=inb(il)) THEN
-!!        dn_to(il,i) = dn_to(il,i) + ment(il,j,i)       !jyg,20220202
-        dn_to(il,i) = dn_to(il,i) - ment(il,j,i)
-      ENDIF
-    ENDDO
-  ENDDO
-ENDDO
-!
-DO j = 1, nl
-  DO i = j+1, nl
-    DO il = 1, ncum
-      IF (i<=inb(il)) THEN
-!!        dn_from(il,i) = dn_from(il,i) + ment(il,i,j)   !jyg,20220202
-        dn_from(il,i) = dn_from(il,i) - ment(il,i,j)
-      ENDIF
-    ENDDO
-  ENDDO
-ENDDO
-!
-! The difference between dnwd(il,i) and dnwd(il,i+1) is due to downdrafts ending in layer 
-!(i) (theses drafts cross interface (i+1) but not interface(i)) and to downdrafts 
-!starting from layer (i) (theses drafts cross interface (i) but not interface(i+1)): 
-!
-DO i = nl-1, 1, -1
-  DO il = 1, ncum
-!!    dnwd(il,i) = max(0., dnwd(il,i+1) - dn_to(il,i) + dn_from(il,i)) !jyg,20220202
-    dnwd(il,i) = min(0., dnwd(il,i+1) - dn_to(il,i) + dn_from(il,i))
-  ENDDO
-ENDDO
-! =================================================
-!
-!-----------------------------------------------------------
-        ENDIF !(ok_optim_yield)                           !|
-!-----------------------------------------------------------
-!>jyg
-
-! ***  calculate tendencies of potential temperature and mixing ratio  ***
-! ***               at levels above the lowest level                   ***
-
-! ***  first find the net saturated updraft and downdraft mass fluxes  ***
-! ***                      through each level                          ***
-
-
-!jyg<
-!!  DO i = 2, nl + 1 ! newvecto: mettre nl au lieu nl+1?
-  DO i = 2, nl
-!>jyg 
-
-    num1 = 0
-    DO il = 1, ncum
-      IF (i<=inb(il) .AND. iflag(il)<=1) num1 = num1 + 1
-    END DO
-    IF (num1<=0) GO TO 500
-
-!
-!jyg<
-!-----------------------------------------------------------
-           IF (ok_optim_yield) THEN                       !|
-!-----------------------------------------------------------
-DO il = 1, ncum
-   amp1(il) = upwd(il,i+1)
-   ad(il) = dnwd(il,i)
-ENDDO
-!-----------------------------------------------------------
-        ELSE !(ok_optim_yield)                            !|
-!-----------------------------------------------------------
-!>jyg
-    DO il = 1,ncum
-      amp1(il) = 0.
-      ad(il) = 0.
-    ENDDO
-
-    DO k = 1, nl + 1
-      DO il = 1, ncum
-        IF (i>=icb(il)) THEN
-          IF (k>=i+1 .AND. k<=(inb(il)+1)) THEN
-            amp1(il) = amp1(il) + m(il, k)
-          END IF
-        ELSE
-! AMP1 is the part of cbmf taken from layers I and lower
-          IF (k<=i) THEN
-            amp1(il) = amp1(il) + cbmf(il)*wghti(il, k)
-          END IF
-        END IF
-      END DO
-    END DO
-
-    DO j = i + 1, nl + 1         
-       DO k = 1, i
-          !yor! reverted j and k loops 
-          DO il = 1, ncum
-!yor!        IF (i<=inb(il) .AND. j<=(inb(il)+1)) THEN ! the second condition implies the first !
-             IF (j<=(inb(il)+1)) THEN  
-                amp1(il) = amp1(il) + ment(il, k, j)
-             END IF
-          END DO
-       END DO
-    END DO
-
-    DO k = 1, i - 1
-!jyg<
-!!      DO j = i, nl + 1 ! newvecto: nl au lieu nl+1?
-      DO j = i, nl
-!>jyg
-        DO il = 1, ncum
-!yor!        IF (i<=inb(il) .AND. j<=inb(il)) THEN ! the second condition implies the 1st !
-             IF (j<=inb(il)) THEN   
-            ad(il) = ad(il) + ment(il, j, k)
-          END IF
-        END DO
-      END DO
-    END DO
-!
-!-----------------------------------------------------------
-        ENDIF !(ok_optim_yield)                           !|
-!-----------------------------------------------------------
-!
-!!   print *,'yield, i, amp1, ad', i, amp1(1), ad(1)
-
-    DO il = 1, ncum
-      IF (i<=inb(il) .AND. iflag(il)<=1) THEN
-        dpinv = 1.0/(ph(il,i)-ph(il,i+1))
-        cpinv = 1.0/cpn(il, i)
-
-! convect3      if((0.1*dpinv*amp1).ge.delti)iflag(il)=4
-        IF ((0.01*grav*dpinv*amp1(il))>=delti) iflag(il) = 1 ! vecto
-
-! precip
-! cc       ft(il,i)= -0.5*sigd(il)*lvcp(il,i)*(evap(il,i)+evap(il,i+1))
-        IF (cvflag_ice) THEN
-          ft(il, i) = -sigd(il)*lvcp(il, i)*evap(il, i) - &
-                       sigd(il)*lfcp(il, i)*evap(il, i)*faci(il, i) - &
-                       sigd(il)*lfcp(il, i)*fondue(il, i)*wt(il, i)/(100.*(p(il,i-1)-p(il,i)))
-        ELSE
-          ft(il, i) = -sigd(il)*lvcp(il, i)*evap(il, i)
-        END IF
-
-        rat = cpn(il, i-1)*cpinv
-
-        ft(il, i) = ft(il, i) - 0.009*grav*sigd(il) * &
-                     (mp(il,i+1)*t_wake(il,i)*b(il,i)-mp(il,i)*t_wake(il,i-1)*rat*b(il,i-1))*dpinv
-        IF (cvflag_ice) THEN
-          ft(il, i) = ft(il, i) + 0.01*sigd(il)*wt(il, i)*(cl-cpd)*water(il, i+1) * &
-                                       (t_wake(il,i+1)-t_wake(il,i))*dpinv*cpinv + &
-                                  0.01*sigd(il)*wt(il, i)*(ci-cpd)*ice(il, i+1) * &
-                                       (t_wake(il,i+1)-t_wake(il,i))*dpinv*cpinv
-        ELSE
-          ft(il, i) = ft(il, i) + 0.01*sigd(il)*wt(il, i)*(cl-cpd)*water(il, i+1) * &
-                                       (t_wake(il,i+1)-t_wake(il,i))*dpinv* &
-            cpinv
-        END IF
-
-        ftd(il, i) = ft(il, i)
-! fin precip
-
-! sature
-!jyg<
-        IF (fl_cor_ebil >= 2) THEN
-          ft(il, i) = ft(il, i) + 0.01*grav*dpinv * &
-              ( amp1(il)*( (t(il,i+1)-t(il,i))*cpn(il,i+1) + gz(il,i+1)-gz(il,i))*cpinv - &
-                ad(il)*( (t(il,i)-t(il,i-1))*cpn(il,i-1) + gz(il,i)-gz(il,i-1))*cpinv)
-        ELSE
-          ft(il, i) = ft(il, i) + 0.01*grav*dpinv * &
-                     (amp1(il)*(t(il,i+1)-t(il,i) + (gz(il,i+1)-gz(il,i))*cpinv) - &
-                      ad(il)*(t(il,i)-t(il,i-1)+(gz(il,i)-gz(il,i-1))*cpinv))
-        ENDIF
-!>jyg
-
-
-        IF (iflag_mix==0) THEN
-          ft(il, i) = ft(il, i) + 0.01*grav*dpinv*ment(il, i, i)*(hp(il,i)-h(il,i) + &
-                                    t(il,i)*(cpv-cpd)*(rr(il,i)-qent(il,i,i)))*cpinv
-        END IF
-!
-! sb: on ne fait pas encore la correction permettant de mieux
-! conserver l'eau:
-!JYG: correction permettant de mieux conserver l'eau:
-! cc         fr(il,i)=0.5*sigd(il)*(evap(il,i)+evap(il,i+1))
-        fr(il, i) = sigd(il)*evap(il, i) + 0.01*grav*(mp(il,i+1)*(rp(il,i+1)-rr_wake(il,i)) - &
-                                                      mp(il,i)*(rp(il,i)-rr_wake(il,i-1)))*dpinv
-        fqd(il, i) = fr(il, i)                                                                     ! precip
-
-        fu(il, i) = 0.01*grav*(mp(il,i+1)*(up(il,i+1)-u(il,i)) - &
-                               mp(il,i)*(up(il,i)-u(il,i-1)))*dpinv
-        fv(il, i) = 0.01*grav*(mp(il,i+1)*(vp(il,i+1)-v(il,i)) - &
-                               mp(il,i)*(vp(il,i)-v(il,i-1)))*dpinv
-
-
-        fr(il, i) = fr(il, i) + 0.01*grav*dpinv*(amp1(il)*(rr(il,i+1)-rr(il,i)) - &
-                                                 ad(il)*(rr(il,i)-rr(il,i-1)))
-        fu(il, i) = fu(il, i) + 0.01*grav*dpinv*(amp1(il)*(u(il,i+1)-u(il,i)) - &
-                                                 ad(il)*(u(il,i)-u(il,i-1)))
-        fv(il, i) = fv(il, i) + 0.01*grav*dpinv*(amp1(il)*(v(il,i+1)-v(il,i)) - &
-                                                 ad(il)*(v(il,i)-v(il,i-1)))
-
-      END IF ! i
-    END DO
-
-!AC!      do k=1,ntra
-!AC!       do il=1,ncum
-!AC!        if (i.le.inb(il) .and. iflag(il) .le. 1) then
-!AC!         dpinv=1.0/(ph(il,i)-ph(il,i+1))
-!AC!         cpinv=1.0/cpn(il,i)
-!AC!         if (cvflag_grav) then
-!AC!           ftra(il,i,k)=ftra(il,i,k)+0.01*grav*dpinv
-!AC!     :         *(amp1(il)*(tra(il,i+1,k)-tra(il,i,k))
-!AC!     :           -ad(il)*(tra(il,i,k)-tra(il,i-1,k)))
-!AC!         else
-!AC!           ftra(il,i,k)=ftra(il,i,k)+0.1*dpinv
-!AC!     :         *(amp1(il)*(tra(il,i+1,k)-tra(il,i,k))
-!AC!     :           -ad(il)*(tra(il,i,k)-tra(il,i-1,k)))
-!AC!         endif
-!AC!        endif
-!AC!       enddo
-!AC!      enddo
-
-    DO k = 1, i - 1
-
-      DO il = 1, ncum
-        awat(il) = elij(il, k, i) - (1.-ep(il,i))*clw(il, i)
-        awat(il) = max(awat(il), 0.0)
-      END DO
-
-      IF (iflag_mix/=0) THEN
-        DO il = 1, ncum
-          IF (i<=inb(il) .AND. iflag(il)<=1) THEN
-            dpinv = 1.0/(ph(il,i)-ph(il,i+1))
-            cpinv = 1.0/cpn(il, i)
-            ft(il, i) = ft(il, i) + 0.01*grav*dpinv*ment(il, k, i) * &
-                 (hent(il,k,i)-h(il,i)+t(il,i)*(cpv-cpd)*(rr(il,i)+awat(il)-qent(il,k,i)))*cpinv
-!
-!
-          END IF ! i
-        END DO
-      END IF
-
-      DO il = 1, ncum
-        IF (i<=inb(il) .AND. iflag(il)<=1) THEN
-          dpinv = 1.0/(ph(il,i)-ph(il,i+1))
-          cpinv = 1.0/cpn(il, i)
-          fr(il, i) = fr(il, i) + 0.01*grav*dpinv*ment(il, k, i) * &
-                                                       (qent(il,k,i)-awat(il)-rr(il,i))
-          fr_comp(il,i) = fr_comp(il,i) + 0.01*grav*dpinv*ment(il, k, i)*(qent(il,k,i)-awat(il)-rr(il,i))
-          fu(il, i) = fu(il, i) + 0.01*grav*dpinv*ment(il, k, i)*(uent(il,k,i)-u(il,i))
-          fv(il, i) = fv(il, i) + 0.01*grav*dpinv*ment(il, k, i)*(vent(il,k,i)-v(il,i))
-
-! (saturated updrafts resulting from mixing)                                   ! cld
-          qcond(il, i) = qcond(il, i) + (elij(il,k,i)-awat(il))                ! cld
-          qdet(il,k,i) = (qent(il,k,i)-awat(il))                               ! cld Louis : specific humidity in detraining water
-          qtment(il, i) = qtment(il, i) + qent(il,k,i)                         ! cld
-          nqcond(il, i) = nqcond(il, i) + 1.                                   ! cld
-        END IF ! i
-      END DO
-    END DO
-
-!AC!      do j=1,ntra
-!AC!       do k=1,i-1
-!AC!        do il=1,ncum
-!AC!         if (i.le.inb(il) .and. iflag(il) .le. 1) then
-!AC!          dpinv=1.0/(ph(il,i)-ph(il,i+1))
-!AC!          cpinv=1.0/cpn(il,i)
-!AC!          if (cvflag_grav) then
-!AC!           ftra(il,i,j)=ftra(il,i,j)+0.01*grav*dpinv*ment(il,k,i)
-!AC!     :        *(traent(il,k,i,j)-tra(il,i,j))
-!AC!          else
-!AC!           ftra(il,i,j)=ftra(il,i,j)+0.1*dpinv*ment(il,k,i)
-!AC!     :        *(traent(il,k,i,j)-tra(il,i,j))
-!AC!          endif
-!AC!         endif
-!AC!        enddo
-!AC!       enddo
-!AC!      enddo
-
-!jyg<
-!!    DO k = i, nl + 1
-    DO k = i, nl
-!>jyg
-
-      IF (iflag_mix/=0) THEN
-        DO il = 1, ncum
-          IF (i<=inb(il) .AND. k<=inb(il) .AND. iflag(il)<=1) THEN
-            dpinv = 1.0/(ph(il,i)-ph(il,i+1))
-            cpinv = 1.0/cpn(il, i)
-            ft(il, i) = ft(il, i) + 0.01*grav*dpinv*ment(il, k, i) * &
-                  (hent(il,k,i)-h(il,i)+t(il,i)*(cpv-cpd)*(rr(il,i)-qent(il,k,i)))*cpinv
-
-
-          END IF ! i
-        END DO
-      END IF
-
-      DO il = 1, ncum
-        IF (i<=inb(il) .AND. k<=inb(il) .AND. iflag(il)<=1) THEN
-          dpinv = 1.0/(ph(il,i)-ph(il,i+1))
-          cpinv = 1.0/cpn(il, i)
-
-          fr(il, i) = fr(il, i) + 0.01*grav*dpinv*ment(il, k, i)*(qent(il,k,i)-rr(il,i))
-          fu(il, i) = fu(il, i) + 0.01*grav*dpinv*ment(il, k, i)*(uent(il,k,i)-u(il,i))
-          fv(il, i) = fv(il, i) + 0.01*grav*dpinv*ment(il, k, i)*(vent(il,k,i)-v(il,i))
-        END IF ! i and k
-      END DO
-    END DO
-
-!AC!      do j=1,ntra
-!AC!       do k=i,nl+1
-!AC!        do il=1,ncum
-!AC!         if (i.le.inb(il) .and. k.le.inb(il)
-!AC!     $                .and. iflag(il) .le. 1) then
-!AC!          dpinv=1.0/(ph(il,i)-ph(il,i+1))
-!AC!          cpinv=1.0/cpn(il,i)
-!AC!          if (cvflag_grav) then
-!AC!           ftra(il,i,j)=ftra(il,i,j)+0.01*grav*dpinv*ment(il,k,i)
-!AC!     :         *(traent(il,k,i,j)-tra(il,i,j))
-!AC!          else
-!AC!           ftra(il,i,j)=ftra(il,i,j)+0.1*dpinv*ment(il,k,i)
-!AC!     :             *(traent(il,k,i,j)-tra(il,i,j))
-!AC!          endif
-!AC!         endif ! i and k
-!AC!        enddo
-!AC!       enddo
-!AC!      enddo
-
-! sb: interface with the cloud parameterization:                               ! cld
-
-    DO k = i + 1, nl
-      DO il = 1, ncum
-        IF (k<=inb(il) .AND. i<=inb(il) .AND. iflag(il)<=1) THEN               ! cld
-! (saturated downdrafts resulting from mixing)                                 ! cld
-          qcond(il, i) = qcond(il, i) + elij(il, k, i)                         ! cld
-          qdet(il,k,i) = qent(il,k,i)                                          ! cld Louis : specific humidity in detraining water
-          qtment(il, i) = qent(il,k,i) + qtment(il,i)                          ! cld
-          nqcond(il, i) = nqcond(il, i) + 1.                                   ! cld
-        END IF ! cld
-      END DO ! cld
-    END DO ! cld
-
-!ym BIG Warning : it seems that the k loop is missing !!!
-!ym Strong advice to check this
-!ym add a k loop temporary 
-
-! (particular case: no detraining level is found)                              ! cld
-! Verif merge Dynamico<<<<<<< .working
-    DO il = 1, ncum                                                            ! cld
-      IF (i<=inb(il) .AND. nent(il,i)==0 .AND. iflag(il)<=1) THEN              ! cld
-        qcond(il, i) = qcond(il, i) + (1.-ep(il,i))*clw(il, i)                 ! cld
-!jyg<   Bug correction 20180620
-!      PROBLEM: Should not qent(il,i,i) be taken into account even if nent(il,i)/=0?
-!!        qtment(il, i) = qent(il,k,i) + qtment(il,i)                            ! cld
-        qdet(il,i,i) = qent(il,i,i)                                            ! cld Louis : specific humidity in detraining water
-        qtment(il, i) = qent(il,i,i) + qtment(il,i)                            ! cld
-!>jyg
-        nqcond(il, i) = nqcond(il, i) + 1.                                     ! cld
-      END IF                                                                   ! cld
-    END DO                                                                     ! cld
-! Verif merge Dynamico =======
-! Verif merge Dynamico     DO k = i + 1, nl
-! Verif merge Dynamico       DO il = 1, ncum        !ym k loop added                                    ! cld
-! Verif merge Dynamico         IF (i<=inb(il) .AND. nent(il,i)==0 .AND. iflag(il)<=1) THEN              ! cld
-! Verif merge Dynamico           qcond(il, i) = qcond(il, i) + (1.-ep(il,i))*clw(il, i)                 ! cld
-! Verif merge Dynamico           qtment(il, i) = qent(il,k,i) + qtment(il,i)                          ! cld
-! Verif merge Dynamico           nqcond(il, i) = nqcond(il, i) + 1.                                     ! cld
-! Verif merge Dynamico         END IF                                                                   ! cld
-! Verif merge Dynamico       END DO
-! Verif merge Dynamico     ENDDO                                                                     ! cld
-! Verif merge Dynamico >>>>>>> .merge-right.r3413
-
-    DO il = 1, ncum                                                            ! cld
-      IF (i<=inb(il) .AND. nqcond(il,i)/=0 .AND. iflag(il)<=1) THEN            ! cld
-        qcond(il, i) = qcond(il, i)/nqcond(il, i)                              ! cld
-        qtment(il, i) = qtment(il,i)/nqcond(il, i)                             ! cld
-      END IF                                                                   ! cld
-    END DO
-
-!AC!      do j=1,ntra
-!AC!       do il=1,ncum
-!AC!        if (i.le.inb(il) .and. iflag(il) .le. 1) then
-!AC!         dpinv=1.0/(ph(il,i)-ph(il,i+1))
-!AC!         cpinv=1.0/cpn(il,i)
-!AC!
-!AC!         if (cvflag_grav) then
-!AC!          ftra(il,i,j)=ftra(il,i,j)+0.01*grav*dpinv
-!AC!     :     *(mp(il,i+1)*(trap(il,i+1,j)-tra(il,i,j))
-!AC!     :     -mp(il,i)*(trap(il,i,j)-trap(il,i-1,j)))
-!AC!         else
-!AC!          ftra(il,i,j)=ftra(il,i,j)+0.1*dpinv
-!AC!     :     *(mp(il,i+1)*(trap(il,i+1,j)-tra(il,i,j))
-!AC!     :     -mp(il,i)*(trap(il,i,j)-trap(il,i-1,j)))
-!AC!         endif
-!AC!        endif ! i
-!AC!       enddo
-!AC!      enddo
-
-
-500 END DO
-
-!JYG<
-!Conservation de l'eau
-!   sumdq = 0.
-!   DO k = 1, nl
-!     sumdq = sumdq + fr(1, k)*100.*(ph(1,k)-ph(1,k+1))/grav
-!   END DO
-!   PRINT *, 'cv3_yield, apres 500, sum(dq), precip, somme ', sumdq, Vprecip(1, 1), sumdq + vprecip(1, 1)
-!JYG>
-! ***   move the detrainment at level inb down to level inb-1   ***
-! ***        in such a way as to preserve the vertically        ***
-! ***          integrated enthalpy and water tendencies         ***
-
-! Correction bug le 18-03-09
-  DO il = 1, ncum
-    IF (iflag(il)<=1) THEN
-      ax = 0.01*grav*ment(il, inb(il), inb(il))* &
-           (hp(il,inb(il))-h(il,inb(il))+t(il,inb(il))*(cpv-cpd)*(rr(il,inb(il))-qent(il,inb(il),inb(il))))/ &
-                                (cpn(il,inb(il))*(ph(il,inb(il))-ph(il,inb(il)+1)))
-      ft(il, inb(il)) = ft(il, inb(il)) - ax
-      ft(il, inb(il)-1) = ft(il, inb(il)-1) + ax*cpn(il, inb(il))*(ph(il,inb(il))-ph(il,inb(il)+1))/ &
-                              (cpn(il,inb(il)-1)*(ph(il,inb(il)-1)-ph(il,inb(il))))
-
-      bx = 0.01*grav*ment(il, inb(il), inb(il))*(qent(il,inb(il),inb(il))-rr(il,inb(il)))/ &
-                                                 (ph(il,inb(il))-ph(il,inb(il)+1))
-      fr(il, inb(il)) = fr(il, inb(il)) - bx
-      fr(il, inb(il)-1) = fr(il, inb(il)-1) + bx*(ph(il,inb(il))-ph(il,inb(il)+1))/ &
-                                                 (ph(il,inb(il)-1)-ph(il,inb(il)))
-
-      cx = 0.01*grav*ment(il, inb(il), inb(il))*(uent(il,inb(il),inb(il))-u(il,inb(il)))/ &
-                                                 (ph(il,inb(il))-ph(il,inb(il)+1))
-      fu(il, inb(il)) = fu(il, inb(il)) - cx
-      fu(il, inb(il)-1) = fu(il, inb(il)-1) + cx*(ph(il,inb(il))-ph(il,inb(il)+1))/ &
-                                                 (ph(il,inb(il)-1)-ph(il,inb(il)))
-
-      dx = 0.01*grav*ment(il, inb(il), inb(il))*(vent(il,inb(il),inb(il))-v(il,inb(il)))/ &
-                                                 (ph(il,inb(il))-ph(il,inb(il)+1))
-      fv(il, inb(il)) = fv(il, inb(il)) - dx
-      fv(il, inb(il)-1) = fv(il, inb(il)-1) + dx*(ph(il,inb(il))-ph(il,inb(il)+1))/ &
-                                                 (ph(il,inb(il)-1)-ph(il,inb(il)))
-    END IF !iflag
-  END DO
-
-!JYG<
-!Conservation de l'eau
-!   sumdq = 0.
-!   DO k = 1, nl
-!     sumdq = sumdq + fr(1, k)*100.*(ph(1,k)-ph(1,k+1))/grav
-!   END DO
-!   PRINT *, 'cv3_yield, apres 503, sum(dq), precip, somme ', sumdq, Vprecip(1, 1), sumdq + vprecip(1, 1)
-!JYG>
-
-!AC!      do j=1,ntra
-!AC!       do il=1,ncum
-!AC!        IF (iflag(il) .le. 1) THEN
-!AC!	IF (cvflag_grav) then
-!AC!        ex=0.01*grav*ment(il,inb(il),inb(il))
-!AC!     :      *(traent(il,inb(il),inb(il),j)-tra(il,inb(il),j))
-!AC!     :      /(ph(i l,inb(il))-ph(il,inb(il)+1))
-!AC!        ftra(il,inb(il),j)=ftra(il,inb(il),j)-ex
-!AC!        ftra(il,inb(il)-1,j)=ftra(il,inb(il)-1,j)
-!AC!     :       +ex*(ph(il,inb(il))-ph(il,inb(il)+1))
-!AC!     :          /(ph(il,inb(il)-1)-ph(il,inb(il)))
-!AC!	else
-!AC!        ex=0.1*ment(il,inb(il),inb(il))
-!AC!     :      *(traent(il,inb(il),inb(il),j)-tra(il,inb(il),j))
-!AC!     :      /(ph(i l,inb(il))-ph(il,inb(il)+1))
-!AC!        ftra(il,inb(il),j)=ftra(il,inb(il),j)-ex
-!AC!        ftra(il,inb(il)-1,j)=ftra(il,inb(il)-1,j)
-!AC!     :       +ex*(ph(il,inb(il))-ph(il,inb(il)+1))
-!AC!     :          /(ph(il,inb(il)-1)-ph(il,inb(il)))
-!AC!        ENDIF   !cvflag grav
-!AC!        ENDIF    !iflag
-!AC!       enddo
-!AC!      enddo
-
-
-! ***    homogenize tendencies below cloud base    ***
-
-
-  DO il = 1, ncum
-    asum(il) = 0.0
-    bsum(il) = 0.0
-    csum(il) = 0.0
-    dsum(il) = 0.0
-    esum(il) = 0.0
-    fsum(il) = 0.0
-    gsum(il) = 0.0
-    hsum(il) = 0.0
-  END DO
-
-!do i=1,nl
-!do il=1,ncum
-!th_wake(il,i)=t_wake(il,i)*(1000.0/p(il,i))**rdcp
-!enddo
-!enddo
-
-  DO i = 1, nl
-    DO il = 1, ncum
-      IF (i<=(icb(il)-1) .AND. iflag(il)<=1) THEN
-!jyg  Saturated part : use T profile
-        asum(il) = asum(il) + (ft(il,i)-ftd(il,i))*(ph(il,i)-ph(il,i+1))
-!jyg<20140311
-!Correction pour conserver l eau
-        IF (ok_conserv_q) THEN
-          bsum(il) = bsum(il) + (fr(il,i)-fqd(il,i))*(ph(il,i)-ph(il,i+1))
-          csum(il) = csum(il) + (ph(il,i)-ph(il,i+1))
-
-        ELSE
-          bsum(il)=bsum(il)+(fr(il,i)-fqd(il,i))*(lv(il,i)+(cl-cpd)*(t(il,i)-t(il,1)))* &
-                            (ph(il,i)-ph(il,i+1))
-          csum(il)=csum(il)+(lv(il,i)+(cl-cpd)*(t(il,i)-t(il,1)))* &
-                            (ph(il,i)-ph(il,i+1))
-        ENDIF ! (ok_conserv_q)
-!jyg>
-        dsum(il) = dsum(il) + t(il, i)*(ph(il,i)-ph(il,i+1))/th(il, i)
-!jyg  Unsaturated part : use T_wake profile
-        esum(il) = esum(il) + ftd(il, i)*(ph(il,i)-ph(il,i+1))
-!jyg<20140311
-!Correction pour conserver l eau
-        IF (ok_conserv_q) THEN
-          fsum(il) = fsum(il) + fqd(il, i)*(ph(il,i)-ph(il,i+1))
-          gsum(il) = gsum(il) + (ph(il,i)-ph(il,i+1))
-        ELSE
-          fsum(il)=fsum(il)+fqd(il,i)*(lv(il,i)+(cl-cpd)*(t_wake(il,i)-t_wake(il,1)))* &
-                            (ph(il,i)-ph(il,i+1))
-          gsum(il)=gsum(il)+(lv(il,i)+(cl-cpd)*(t_wake(il,i)-t_wake(il,1)))* &
-                            (ph(il,i)-ph(il,i+1))
-        ENDIF ! (ok_conserv_q)
-!jyg>
-        hsum(il) = hsum(il) + t_wake(il, i)*(ph(il,i)-ph(il,i+1))/th_wake(il, i)
-      END IF
-    END DO
-  END DO
-
-!!!!      do 700 i=1,icb(il)-1
-  IF (ok_homo_tend) THEN
-    DO i = 1, nl
-      DO il = 1, ncum
-        IF (i<=(icb(il)-1) .AND. iflag(il)<=1) THEN
-          ftd(il, i) = esum(il)*t_wake(il, i)/(th_wake(il,i)*hsum(il))
-          fqd(il, i) = fsum(il)/gsum(il)
-          ft(il, i) = ftd(il, i) + asum(il)*t(il, i)/(th(il,i)*dsum(il))
-          fr(il, i) = fqd(il, i) + bsum(il)/csum(il)
-        END IF
-      END DO
-    END DO
-  ENDIF
-
-!jyg<
-!Conservation de l'eau
-!!  sumdq = 0.
-!!  DO k = 1, nl
-!!    sumdq = sumdq + fr(1, k)*100.*(ph(1,k)-ph(1,k+1))/grav
-!!  END DO
-!!  PRINT *, 'cv3_yield, apres hom, sum(dq), precip, somme ', sumdq, Vprecip(1, 1), sumdq + vprecip(1, 1)
-!jyg>
-
-
-! ***   Check that moisture stays positive. If not, scale tendencies
-! in order to ensure moisture positivity
-  DO il = 1, ncum
-    alpha_qpos(il) = 1.
-    IF (iflag(il)<=1) THEN
-      IF (fr(il,1)<=0.) THEN
-        alpha_qpos(il) = max(alpha_qpos(il), (-delt*fr(il,1))/(s_wake(il)*rr_wake(il,1)+(1.-s_wake(il))*rr(il,1)))
-      END IF
-    END IF
-  END DO
-  DO i = 2, nl
-    DO il = 1, ncum
-      IF (iflag(il)<=1) THEN
-        IF (fr(il,i)<=0.) THEN
-          alpha_qpos1(il) = max(1., (-delt*fr(il,i))/(s_wake(il)*rr_wake(il,i)+(1.-s_wake(il))*rr(il,i)))
-          IF (alpha_qpos1(il)>=alpha_qpos(il)) alpha_qpos(il) = alpha_qpos1(il)
-        END IF
-      END IF
-    END DO
-  END DO
-  DO il = 1, ncum
-    IF (iflag(il)<=1 .AND. alpha_qpos(il)>1.001) THEN
-      alpha_qpos(il) = alpha_qpos(il)*1.1
-    END IF
-  END DO
-!
-    IF (prt_level .GE. 5) THEN
-      print *,' CV3_YIELD : alpha_qpos ',alpha_qpos(1)
-    ENDIF
-!
-  DO il = 1, ncum
-    IF (iflag(il)<=1) THEN
-      sigd(il) = sigd(il)/alpha_qpos(il)
-      precip(il) = precip(il)/alpha_qpos(il)
-      cbmf(il) = cbmf(il)/alpha_qpos(il)
-    END IF
-  END DO
-  DO i = 1, nl
-    DO il = 1, ncum
-      IF (iflag(il)<=1) THEN
-        fr(il, i) = fr(il, i)/alpha_qpos(il)
-        ft(il, i) = ft(il, i)/alpha_qpos(il)
-        fqd(il, i) = fqd(il, i)/alpha_qpos(il)
-        ftd(il, i) = ftd(il, i)/alpha_qpos(il)
-        fu(il, i) = fu(il, i)/alpha_qpos(il)
-        fv(il, i) = fv(il, i)/alpha_qpos(il)
-        m(il, i) = m(il, i)/alpha_qpos(il)
-        mp(il, i) = mp(il, i)/alpha_qpos(il)
-        Vprecip(il, i) = Vprecip(il, i)/alpha_qpos(il)
-        Vprecipi(il, i) = Vprecipi(il, i)/alpha_qpos(il)                     ! jyg
-      END IF
-    END DO
-  END DO
-!jyg<
-!-----------------------------------------------------------
-           IF (ok_optim_yield) THEN                       !|
-!-----------------------------------------------------------
-  DO i = 1, nl
-    DO il = 1, ncum
-      IF (iflag(il)<=1) THEN
-        upwd(il, i) = upwd(il, i)/alpha_qpos(il)
-        dnwd(il, i) = dnwd(il, i)/alpha_qpos(il)
-      END IF
-    END DO
-  END DO
-!-----------------------------------------------------------
-        ENDIF !(ok_optim_yield)                           !|
-!-----------------------------------------------------------
-!>jyg
-  DO j = 1, nl !yor! inverted i and j loops
-     DO i = 1, nl
-      DO il = 1, ncum
-        IF (iflag(il)<=1) THEN
-          ment(il, i, j) = ment(il, i, j)/alpha_qpos(il)
-        END IF
-      END DO
-    END DO
-  END DO
-
-!AC!      DO j = 1,ntra
-!AC!      DO i = 1,nl
-!AC!       DO il = 1,ncum
-!AC!        IF (iflag(il) .le. 1) THEN
-!AC!         ftra(il,i,j) = ftra(il,i,j)/alpha_qpos(il)
-!AC!        ENDIF
-!AC!       ENDDO
-!AC!      ENDDO
-!AC!      ENDDO
-
-
-! ***           reset counter and return           ***
-
-! Reset counter only for points actually convective (jyg)
-! In order take into account the possibility of changing the compression,
-! reset m, sig and w0 to zero for non-convecting points.
-  DO il = 1, ncum
-    IF (iflag(il) < 3) THEN
-      sig(il, nd) = 2.0
-    ENDIF
-  END DO
-
-
-  DO i = 1, nl
-    DO il = 1, ncum
-      dnwd0(il, i) = -mp(il, i)
-    END DO
-  END DO
-!jyg<  (loops stop at nl)
-!!  DO i = nl + 1, nd
-!!    DO il = 1, ncum
-!!      dnwd0(il, i) = 0.
-!!    END DO
-!!  END DO
-!>jyg
-
-
-!jyg<
-!-----------------------------------------------------------
-           IF (.NOT.ok_optim_yield) THEN                  !|
-!-----------------------------------------------------------
-  DO i = 1, nl
-    DO il = 1, ncum
-      upwd(il, i) = 0.0
-      dnwd(il, i) = 0.0
-    END DO
-  END DO
-
-!!  DO i = 1, nl                                           ! useless; jyg
-!!    DO il = 1, ncum                                      ! useless; jyg
-!!      IF (i>=icb(il) .AND. i<=inb(il)) THEN              ! useless; jyg
-!!        upwd(il, i) = 0.0                                ! useless; jyg
-!!        dnwd(il, i) = 0.0                                ! useless; jyg
-!!      END IF                                             ! useless; jyg
-!!    END DO                                               ! useless; jyg
-!!  END DO                                                 ! useless; jyg
-
-  DO i = 1, nl
-    DO k = 1, nl
-      DO il = 1, ncum
-        up1(il, k, i) = 0.0
-        dn1(il, k, i) = 0.0
-      END DO
-    END DO
-  END DO
-
-!yor! commented original
-!  DO i = 1, nl
-!    DO k = i, nl
-!      DO n = 1, i - 1
-!        DO il = 1, ncum
-!          IF (i>=icb(il) .AND. i<=inb(il) .AND. k<=inb(il)) THEN
-!            up1(il, k, i) = up1(il, k, i) + ment(il, n, k)
-!            dn1(il, k, i) = dn1(il, k, i) - ment(il, k, n)
-!          END IF
-!        END DO
-!      END DO
-!    END DO
-!  END DO
-!yor! replaced with
-  DO i = 1, nl
-    DO k = i, nl
-      DO n = 1, i - 1
-        DO il = 1, ncum
-          IF (i>=icb(il) .AND. k<=inb(il)) THEN ! yor ! as i always <= k
-             up1(il, k, i) = up1(il, k, i) + ment(il, n, k)
-          END IF
-        END DO
-      END DO
-    END DO
-  END DO
-  DO i = 1, nl
-    DO n = 1, i - 1
-      DO k = i, nl
-        DO il = 1, ncum
-          IF (i>=icb(il) .AND. k<=inb(il)) THEN ! yor !  i always <= k
-             dn1(il, k, i) = dn1(il, k, i) - ment(il, k, n)
-          END IF
-        END DO
-      END DO
-    END DO
-  END DO
-!yor! end replace 
-
-  DO i = 1, nl
-    DO k = 1, nl
-      DO il = 1, ncum
-        IF (i>=icb(il)) THEN
-          IF (k>=i .AND. k<=(inb(il))) THEN
-            upwd(il, i) = upwd(il, i) + m(il, k)
-          END IF
-        ELSE
-          IF (k<i) THEN
-            upwd(il, i) = upwd(il, i) + cbmf(il)*wghti(il, k)
-          END IF
-        END IF
-! c        print *,'cbmf',il,i,k,cbmf(il),wghti(il,k)
-      END DO
-    END DO
-  END DO
-
-  DO i = 2, nl
-    DO k = i, nl
-      DO il = 1, ncum
-! test         if (i.ge.icb(il).and.i.le.inb(il).and.k.le.inb(il)) then
-        IF (i<=inb(il) .AND. k<=inb(il)) THEN
-          upwd(il, i) = upwd(il, i) + up1(il, k, i)
-          dnwd(il, i) = dnwd(il, i) + dn1(il, k, i)
-        END IF
-! c         print *,'upwd',il,i,k,inb(il),upwd(il,i),m(il,k),up1(il,k,i)
-      END DO
-    END DO
-  END DO
-
-
-!!!!      DO il=1,ncum
-!!!!      do i=icb(il),inb(il)
-!!!!
-!!!!      upwd(il,i)=0.0
-!!!!      dnwd(il,i)=0.0
-!!!!      do k=i,inb(il)
-!!!!      up1=0.0
-!!!!      dn1=0.0
-!!!!      do n=1,i-1
-!!!!      up1=up1+ment(il,n,k)
-!!!!      dn1=dn1-ment(il,k,n)
-!!!!      enddo
-!!!!      upwd(il,i)=upwd(il,i)+m(il,k)+up1
-!!!!      dnwd(il,i)=dnwd(il,i)+dn1
-!!!!      enddo
-!!!!      enddo
-!!!!
-!!!!      ENDDO
-
-!!  DO i = 1, nlp
-!!    DO il = 1, ncum
-!!      ma(il, i) = 0
-!!    END DO
-!!  END DO
-!!
-!!  DO i = 1, nl
-!!    DO j = i, nl
-!!      DO il = 1, ncum
-!!        ma(il, i) = ma(il, i) + m(il, j)
-!!      END DO
-!!    END DO
-!!  END DO
-
-!jyg<  (loops stop at nl)
-!!  DO i = nl + 1, nd
-!!    DO il = 1, ncum
-!!      ma(il, i) = 0.
-!!    END DO
-!!  END DO
-!>jyg
-
-!!  DO i = 1, nl
-!!    DO il = 1, ncum
-!!      IF (i<=(icb(il)-1)) THEN
-!!        ma(il, i) = 0
-!!      END IF
-!!    END DO
-!!  END DO
-
-!-----------------------------------------------------------
-        ENDIF !(.NOT.ok_optim_yield)                      !|
-!-----------------------------------------------------------
-!>jyg
-
-! ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
-! determination de la variation de flux ascendant entre
-! deux niveau non dilue mip
-! ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
-
-  DO i = 1, nl
-    DO il = 1, ncum
-      mip(il, i) = m(il, i)
-    END DO
-  END DO
-
-!jyg<  (loops stop at nl)
-!!  DO i = nl + 1, nd
-!!    DO il = 1, ncum
-!!      mip(il, i) = 0.
-!!    END DO
-!!  END DO
-!>jyg
-
-
-! cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
-! icb represente de niveau ou se trouve la
-! base du nuage , et inb le top du nuage
-! ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
-
-!!  DO i = 1, nd                                  ! unused . jyg
-!!    DO il = 1, ncum                             ! unused . jyg
-!!      mke(il, i) = upwd(il, i) + dnwd(il, i)    ! unused . jyg
-!!    END DO                                      ! unused . jyg
-!!  END DO                                        ! unused . jyg
-
-!!  DO i = 1, nd                                                                 ! unused . jyg
-!!    DO il = 1, ncum                                                            ! unused . jyg
-!!      rdcp = (rrd*(1.-rr(il,i))-rr(il,i)*rrv)/(cpd*(1.-rr(il,i))+rr(il,i)*cpv) ! unused . jyg
-!!      tls(il, i) = t(il, i)*(1000.0/p(il,i))**rdcp                             ! unused . jyg
-!!      tps(il, i) = tp(il, i)                                                   ! unused . jyg
-!!    END DO                                                                     ! unused . jyg
-!!  END DO                                                                       ! unused . jyg
-
-
-! *** diagnose the in-cloud mixing ratio   ***                       ! cld
-! ***           of condensed water         ***                       ! cld
-!! cld                                                               
-                                                                     
-  DO i = 1, nl+1                                                     ! cld
-    DO il = 1, ncum                                                  ! cld
-      mac(il, i) = 0.0                                               ! cld
-      wa(il, i) = 0.0                                                ! cld
-      siga(il, i) = 0.0                                              ! cld
-      sax(il, i) = 0.0                                               ! cld
-    END DO                                                           ! cld
-  END DO                                                             ! cld
-                                                                     
-  DO i = minorig, nl                                                 ! cld
-    DO k = i + 1, nl + 1                                             ! cld
-      DO il = 1, ncum                                                ! cld
-        IF (i<=inb(il) .AND. k<=(inb(il)+1) .AND. iflag(il)<=1) THEN ! cld
-          mac(il, i) = mac(il, i) + m(il, k)                         ! cld
-        END IF                                                       ! cld
-      END DO                                                         ! cld
-    END DO                                                           ! cld
-  END DO                                                             ! cld
-
-  DO i = 1, nl                                                       ! cld
-    DO j = 1, i                                                      ! cld
-      DO il = 1, ncum                                                ! cld
-        IF (i>=icb(il) .AND. i<=(inb(il)-1) &                        ! cld
-            .AND. j>=icb(il) .AND. iflag(il)<=1) THEN                ! cld
-          sax(il, i) = sax(il, i) + rrd*(tvp(il,j)-tv(il,j)) &       ! cld
-            *(ph(il,j)-ph(il,j+1))/p(il, j)                          ! cld
-        END IF                                                       ! cld
-      END DO                                                         ! cld
-    END DO                                                           ! cld
-  END DO                                                             ! cld
-
-  DO i = 1, nl                                                       ! cld
-    DO il = 1, ncum                                                  ! cld
-      IF (i>=icb(il) .AND. i<=(inb(il)-1) &                          ! cld
-          .AND. sax(il,i)>0.0 .AND. iflag(il)<=1) THEN               ! cld
-        wa(il, i) = sqrt(2.*sax(il,i))                               ! cld
-      END IF                                                         ! cld
-    END DO                                                           ! cld
-  END DO  
-                                                           ! cld
-  DO i = 1, nl  
-
-! 14/01/15 AJ je remets les parties manquantes cf JYG
-! Initialize sument to 0
-
-    DO il = 1,ncum
-     sument(il) = 0.
-    ENDDO
-
-! Sum mixed mass fluxes in sument
-
-    DO k = 1,nl
-      DO il = 1,ncum
-        IF  (k<=inb(il) .AND. i<=inb(il) .AND. iflag(il)<=1) THEN   ! cld
-          sument(il) =sument(il) + abs(ment(il,k,i))
-          detrain(il,i) = detrain(il,i) + abs(ment(il,k,i))*(qdet(il,k,i) - rr(il,i))*(qdet(il,k,i) - rr(il,i)) ! Louis terme de dÃ©trainement dans le bilan de variance
-        ENDIF
-      ENDDO     ! il
-    ENDDO       ! k
-
-! 14/01/15 AJ delta n'a rien à faire là...                                                 
-    DO il = 1, ncum                                                  ! cld
-!!      IF (wa(il,i)>0.0 .AND. iflag(il)<=1) &                         ! cld
-!!        siga(il, i) = mac(il, i)/(coefw_cld_cv*wa(il, i)) &          ! cld
-!!        *rrd*tvp(il, i)/p(il, i)/100.                                ! cld
-!!
-!!      siga(il, i) = min(siga(il,i), 1.0)                             ! cld
-      sigaq = 0.
-      IF (wa(il,i)>0.0 .AND. iflag(il)<=1)  THEN                     ! cld
-        siga(il, i) = mac(il, i)/(coefw_cld_cv*wa(il, i)) &          ! cld
-                     *rrd*tvp(il, i)/p(il, i)/100.                   ! cld
-        siga(il, i) = min(siga(il,i), 1.0)                           ! cld
-        sigaq = siga(il,i)*qta(il,i-1)                               ! cld
-      ENDIF
-
-! IM cf. FH 
-! 14/01/15 AJ ne correspond pas à ce qui a été codé par JYG et SB           
-                                                         
-      IF (iflag_clw==0) THEN                                         ! cld
-        qcondc(il, i) = siga(il, i)*clw(il, i)*(1.-ep(il,i)) &       ! cld
-          +(1.-siga(il,i))*qcond(il, i)                              ! cld
-
-
-        sigment(il,i)=sument(il)*tau_cld_cv/(ph(il,i)-ph(il,i+1))    ! cld
-        sigment(il, i) = min(1.e-4+sigment(il,i), 1.0 - siga(il,i))  ! cld
-!!        qtc(il, i) = (siga(il,i)*qta(il,i-1)+sigment(il,i)*qtment(il,i)) & ! cld
-        qtc(il, i) = (sigaq+sigment(il,i)*qtment(il,i)) & ! cld
-                     /(siga(il,i)+sigment(il,i))                     ! cld
-        sigt(il,i) = sigment(il, i) + siga(il, i)
-
-!        qtc(il, i) = siga(il,i)*qta(il,i-1)+(1.-siga(il,i))*qtment(il,i) ! cld
-!     print*,'BIGAUSSIAN CONV',siga(il,i),sigment(il,i),qtc(il,i)  
-      		
-      ELSE IF (iflag_clw==1) THEN                                    ! cld
-        qcondc(il, i) = qcond(il, i)                                 ! cld
-        qtc(il,i) = qtment(il,i)                                     ! cld
-      END IF                                                         ! cld
-
-    END DO                                                           ! cld
-  END DO
-! print*,'cv3_yield fin'
-
-  RETURN
-END SUBROUTINE cv3_yield
-
-!AC! et !RomP >>>
-SUBROUTINE cv3_tracer(nloc, len, ncum, nd, na, &
-                      ment, sigij, da, phi, phi2, d1a, dam, &
-                      ep, Vprecip, elij, clw, epmlmMm, eplaMm, &
-                      icb, inb)
-  IMPLICIT NONE
-
-  include "cv3param.h"
-
-!inputs:
-  INTEGER, INTENT (IN)                               :: ncum, nd, na, nloc, len
-  INTEGER, DIMENSION (len), INTENT (IN)              :: icb, inb
-  REAL, DIMENSION (len, na, na), INTENT (IN)         :: ment, sigij, elij
-  REAL, DIMENSION (len, nd), INTENT (IN)             :: clw
-  REAL, DIMENSION (len, na), INTENT (IN)             :: ep
-  REAL, DIMENSION (len, nd+1), INTENT (IN)           :: Vprecip
-!ouputs:
-  REAL, DIMENSION (len, na, na), INTENT (OUT)        :: phi, phi2, epmlmMm
-  REAL, DIMENSION (len, na), INTENT (OUT)            :: da, d1a, dam, eplaMm
-!
-! variables pour tracer dans precip de l'AA et des mel
-!local variables:
-  INTEGER i, j, k
-  REAL epm(nloc, na, na)
-
-! variables d'Emanuel : du second indice au troisieme
-! --->    tab(i,k,j) -> de l origine k a l arrivee j
-! ment, sigij, elij
-! variables personnelles : du troisieme au second indice
-! --->    tab(i,j,k) -> de k a j
-! phi, phi2
-
-! initialisations
-
-  da(:, :) = 0.
-  d1a(:, :) = 0.
-  dam(:, :) = 0.
-  epm(:, :, :) = 0.
-  eplaMm(:, :) = 0.
-  epmlmMm(:, :, :) = 0.
-  phi(:, :, :) = 0.
-  phi2(:, :, :) = 0.
-
-! fraction deau condensee dans les melanges convertie en precip : epm
-! et eau condensée précipitée dans masse d'air saturé : l_m*dM_m/dzdz.dzdz
-  DO j = 1, nl
-    DO k = 1, nl
-      DO i = 1, ncum
-        IF (k>=icb(i) .AND. k<=inb(i) .AND. & 
-!!jyg              j.ge.k.and.j.le.inb(i)) then
-!!jyg             epm(i,j,k)=1.-(1.-ep(i,j))*clw(i,j)/elij(i,k,j)
-            j>k .AND. j<=inb(i)) THEN
-          epm(i, j, k) = 1. - (1.-ep(i,j))*clw(i, j)/max(elij(i,k,j), 1.E-16)
-!!
-          epm(i, j, k) = max(epm(i,j,k), 0.0)
-        END IF
-      END DO
-    END DO
-  END DO
-
-
-  DO j = 1, nl
-    DO k = 1, nl
-      DO i = 1, ncum
-        IF (k>=icb(i) .AND. k<=inb(i)) THEN
-          eplaMm(i, j) = eplamm(i, j) + &
-                         ep(i, j)*clw(i, j)*ment(i, j, k)*(1.-sigij(i,j,k))
-        END IF
-      END DO
-    END DO
-  END DO
-
-  DO j = 1, nl
-    DO k = 1, j - 1
-      DO i = 1, ncum
-        IF (k>=icb(i) .AND. k<=inb(i) .AND. j<=inb(i)) THEN
-          epmlmMm(i, j, k) = epm(i, j, k)*elij(i, k, j)*ment(i, k, j)
-        END IF
-      END DO
-    END DO
-  END DO
-
-! matrices pour calculer la tendance des concentrations dans cvltr.F90
-  DO j = 1, nl
-    DO k = 1, nl
-      DO i = 1, ncum
-        da(i, j) = da(i, j) + (1.-sigij(i,k,j))*ment(i, k, j)
-        phi(i, j, k) = sigij(i, k, j)*ment(i, k, j)
-        d1a(i, j) = d1a(i, j) + ment(i, k, j)*ep(i, k)*(1.-sigij(i,k,j))
-        IF (k<=j) THEN
-          dam(i, j) = dam(i, j) + ment(i, k, j)*epm(i, k, j)*(1.-ep(i,k))*(1.-sigij(i,k,j))
-          phi2(i, j, k) = phi(i, j, k)*epm(i, j, k)
-        END IF
-      END DO
-    END DO
-  END DO
-
-  RETURN
-END SUBROUTINE cv3_tracer
-!AC! et !RomP <<<
-
-SUBROUTINE cv3_uncompress(nloc, len, ncum, nd, ntra, idcum, &
-                          iflag, &
-                          precip, sig, w0, &
-                          ft, fq, fu, fv, ftra, &
-                          Ma, upwd, dnwd, dnwd0, qcondc, wd, cape, &
-                          epmax_diag, & ! epmax_cape
-                          iflag1, &
-                          precip1, sig1, w01, &
-                          ft1, fq1, fu1, fv1, ftra1, &
-                          Ma1, upwd1, dnwd1, dnwd01, qcondc1, wd1, cape1, &
-                          epmax_diag1) ! epmax_cape
-  IMPLICIT NONE
-
-  include "cv3param.h"
-
-!inputs:
-  INTEGER len, ncum, nd, ntra, nloc
-  INTEGER idcum(nloc)
-  INTEGER iflag(nloc)
-  REAL precip(nloc)
-  REAL sig(nloc, nd), w0(nloc, nd)
-  REAL ft(nloc, nd), fq(nloc, nd), fu(nloc, nd), fv(nloc, nd)
-  REAL ftra(nloc, nd, ntra)
-  REAL ma(nloc, nd)
-  REAL upwd(nloc, nd), dnwd(nloc, nd), dnwd0(nloc, nd)
-  REAL qcondc(nloc, nd)
-  REAL wd(nloc), cape(nloc)
-  REAL epmax_diag(nloc)
-
-!outputs:
-  INTEGER iflag1(len)
-  REAL precip1(len)
-  REAL sig1(len, nd), w01(len, nd)
-  REAL ft1(len, nd), fq1(len, nd), fu1(len, nd), fv1(len, nd)
-  REAL ftra1(len, nd, ntra)
-  REAL ma1(len, nd)
-  REAL upwd1(len, nd), dnwd1(len, nd), dnwd01(len, nd)
-  REAL qcondc1(nloc, nd)
-  REAL wd1(nloc), cape1(nloc)
-  REAL epmax_diag1(len) ! epmax_cape
-
-!local variables:
-  INTEGER i, k, j
-
-  DO i = 1, ncum
-    precip1(idcum(i)) = precip(i)
-    iflag1(idcum(i)) = iflag(i)
-    wd1(idcum(i)) = wd(i)
-    cape1(idcum(i)) = cape(i)
-    epmax_diag1(idcum(i))=epmax_diag(i) ! epmax_cape
-  END DO
-
-  DO k = 1, nl
-    DO i = 1, ncum
-      sig1(idcum(i), k) = sig(i, k)
-      w01(idcum(i), k) = w0(i, k)
-      ft1(idcum(i), k) = ft(i, k)
-      fq1(idcum(i), k) = fq(i, k)
-      fu1(idcum(i), k) = fu(i, k)
-      fv1(idcum(i), k) = fv(i, k)
-      ma1(idcum(i), k) = ma(i, k)
-      upwd1(idcum(i), k) = upwd(i, k)
-      dnwd1(idcum(i), k) = dnwd(i, k)
-      dnwd01(idcum(i), k) = dnwd0(i, k)
-      qcondc1(idcum(i), k) = qcondc(i, k)
-    END DO
-  END DO
-
-  DO i = 1, ncum
-    sig1(idcum(i), nd) = sig(i, nd)
-  END DO
-
-
-!AC!        do 2100 j=1,ntra
-!AC!c oct3         do 2110 k=1,nl
-!AC!         do 2110 k=1,nd ! oct3
-!AC!          do 2120 i=1,ncum
-!AC!            ftra1(idcum(i),k,j)=ftra(i,k,j)
-!AC! 2120     continue
-!AC! 2110    continue
-!AC! 2100   continue
-!
-  RETURN
-END SUBROUTINE cv3_uncompress
-
-
-        subroutine cv3_epmax_fn_cape(nloc,ncum,nd &
-                 , ep,hp,icb,inb,clw,nk,t,h,hnk,lv,lf,frac &
-                 , pbase, p, ph, tv, buoy, sig, w0,iflag &
-                 , epmax_diag)
-        implicit none
-
-        ! On fait varier epmax en fn de la cape
-        ! Il faut donc recalculer ep, et hp qui a déjà été calculé et
-        ! qui en dépend
-        ! Toutes les autres variables fn de ep sont calculées plus bas.
-
-  include "cvthermo.h"
-  include "cv3param.h"  
-  include "conema3.h"
-  include "cvflag.h"
-
-! inputs:
-      INTEGER, INTENT (IN)                               :: ncum, nd, nloc
-      INTEGER, DIMENSION (nloc), INTENT (IN)             :: icb, inb, nk
-      REAL, DIMENSION (nloc), INTENT (IN)                :: hnk,pbase
-      REAL, DIMENSION (nloc, nd), INTENT (IN)            :: t, lv, lf, tv, h
-      REAL, DIMENSION (nloc, nd), INTENT (IN)            :: clw, buoy,frac
-      REAL, DIMENSION (nloc, nd), INTENT (IN)            :: sig,w0
-      INTEGER, DIMENSION (nloc), INTENT (IN)             :: iflag(nloc)
-      REAL, DIMENSION (nloc, nd), INTENT (IN)            :: p
-      REAL, DIMENSION (nloc, nd+1), INTENT (IN)          :: ph
-! inouts:
-      REAL, DIMENSION (nloc, nd), INTENT (INOUT)         :: ep,hp  
-! outputs
-      REAL, DIMENSION (nloc), INTENT (OUT)           :: epmax_diag
-
-! local
-      integer i,k    
-!      real hp_bak(nloc,nd)
-!      real ep_bak(nloc,nd)
-      real m_loc(nloc,nd)
-      real sig_loc(nloc,nd)
-      real w0_loc(nloc,nd)
-      integer iflag_loc(nloc)
-      real cape(nloc)
-        
-        if (coef_epmax_cape.gt.1e-12) then
-
-        ! il faut calculer la cape: on fait un calcule simple car tant qu'on ne
-        ! connait pas ep, on ne connait pas les mélanges, ddfts etc... qui sont
-        ! necessaires au calcul de la cape dans la nouvelle physique
-        
-!        write(*,*) 'cv3_routines check 4303'
-        do i=1,ncum
-        do k=1,nd
-          sig_loc(i,k)=sig(i,k)
-          w0_loc(i,k)=w0(i,k)
-          iflag_loc(i)=iflag(i)
-!          ep_bak(i,k)=ep(i,k)
-        enddo ! do k=1,nd
-        enddo !do i=1,ncum
-
-!        write(*,*) 'cv3_routines check 4311'
-!        write(*,*) 'nl=',nl
-        CALL cv3_closure(nloc, ncum, nd, icb, inb, & ! na->nd
-          pbase, p, ph, tv, buoy, &
-          sig_loc, w0_loc, cape, m_loc,iflag_loc)
-
-!        write(*,*) 'cv3_routines check 4316'
-!        write(*,*) 'ep(1,:)=',ep(1,:)
-        do i=1,ncum
-           epmax_diag(i)=epmax-coef_epmax_cape*sqrt(cape(i))
-           epmax_diag(i)=amax1(epmax_diag(i),0.0)
-!           write(*,*) 'i,icb,inb,cape,epmax_diag=', &
-!                i,icb(i),inb(i),cape(i),epmax_diag(i)
-           do k=1,nl
-                ep(i,k)=ep(i,k)/epmax*epmax_diag(i)
-                ep(i,k)=amax1(ep(i,k),0.0)
-                ep(i,k)=amin1(ep(i,k),epmax_diag(i))
-           enddo
-        enddo
- !       write(*,*) 'ep(1,:)=',ep(1,:)
-
-      !write(*,*) 'cv3_routines check 4326'
-! On recalcule hp:
-!      do k=1,nl
-!        do i=1,ncum
-!	  hp_bak(i,k)=hp(i,k)
-!	enddo
-!      enddo
-      do k=1,nl
-        do i=1,ncum
-          hp(i,k)=h(i,k)
-        enddo
-      enddo
-
-  IF (cvflag_ice) THEN
-
-      do k=minorig+1,nl
-       do i=1,ncum
-        if((k.ge.icb(i)).and.(k.le.inb(i)))then
-          hp(i, k) = hnk(i) + (lv(i,k)+(cpd-cpv)*t(i,k)+frac(i,k)*lf(i,k))* &
-                              ep(i, k)*clw(i, k)
-        endif
-       enddo
-      enddo !do k=minorig+1,n
-  ELSE !IF (cvflag_ice) THEN
-
-      DO k = minorig + 1, nl
-       DO i = 1, ncum
-        IF ((k>=icb(i)) .AND. (k<=inb(i))) THEN
-          hp(i,k)=hnk(i)+(lv(i,k)+(cpd-cpv)*t(i,k))*ep(i,k)*clw(i,k)
-        endif
-       enddo
-      enddo !do k=minorig+1,n
-
-  ENDIF !IF (cvflag_ice) THEN     
-      !write(*,*) 'cv3_routines check 4345'
-!      do i=1,ncum  
-!       do k=1,nl
-!        if ((abs(hp_bak(i,k)-hp(i,k))/hp_bak(i,k).gt.1e-1).or. &
-!            ((abs(hp_bak(i,k)-hp(i,k))/hp_bak(i,k).gt.1e-4).and. &
-!            (ep(i,k)-ep_bak(i,k).lt.1e-4))) then
-!           write(*,*) 'i,k=',i,k
-!           write(*,*) 'coef_epmax_cape=',coef_epmax_cape
-!           write(*,*) 'epmax_diag(i)=',epmax_diag(i)
-!           write(*,*) 'ep(i,k)=',ep(i,k)
-!           write(*,*) 'ep_bak(i,k)=',ep_bak(i,k)
-!           write(*,*) 'hp(i,k)=',hp(i,k)
-!           write(*,*) 'hp_bak(i,k)=',hp_bak(i,k)
-!           write(*,*) 'h(i,k)=',h(i,k)
-!           write(*,*) 'nk(i)=',nk(i)
-!           write(*,*) 'h(i,nk(i))=',h(i,nk(i))
-!           write(*,*) 'lv(i,k)=',lv(i,k)
-!           write(*,*) 't(i,k)=',t(i,k)
-!           write(*,*) 'clw(i,k)=',clw(i,k)
-!           write(*,*) 'cpd,cpv=',cpd,cpv
-!           stop
-!        endif
-!       enddo !do k=1,nl
-!      enddo !do i=1,ncum  
-      endif !if (coef_epmax_cape.gt.1e-12) then
-      !write(*,*) 'cv3_routines check 4367'
-
-      return
-      end subroutine cv3_epmax_fn_cape
-
-
-
Index: /LMDZ6/trunk/libf/phylmd/cv3_routines.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cv3_routines.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/cv3_routines.f90	(revision 5268)
@@ -0,0 +1,5279 @@
+
+! $Id$
+
+
+
+
+SUBROUTINE cv3_param(nd, k_upper, delt)
+
+  USE ioipsl_getin_p_mod, ONLY : getin_p
+  use mod_phys_lmdz_para
+  IMPLICIT NONE
+
+!------------------------------------------------------------
+!Set parameters for convectL for iflag_con = 3
+!------------------------------------------------------------
+
+
+!***  PBCRIT IS THE CRITICAL CLOUD DEPTH (MB) BENEATH WHICH THE ***
+!***      PRECIPITATION EFFICIENCY IS ASSUMED TO BE ZERO     ***
+!***  PTCRIT IS THE CLOUD DEPTH (MB) ABOVE WHICH THE PRECIP. ***
+!***            EFFICIENCY IS ASSUMED TO BE UNITY            ***
+!***  SIGD IS THE FRACTIONAL AREA COVERED BY UNSATURATED DNDRAFT  ***
+!***  SPFAC IS THE FRACTION OF PRECIPITATION FALLING OUTSIDE ***
+!***                        OF CLOUD                         ***
+
+![TAU: CHARACTERISTIC TIMESCALE USED TO COMPUTE ALPHA & BETA]
+!***    ALPHA AND BETA ARE PARAMETERS THAT CONTROL THE RATE OF ***
+!***                 APPROACH TO QUASI-EQUILIBRIUM           ***
+!***    (THEIR STANDARD VALUES ARE 1.0 AND 0.96, RESPECTIVELY) ***
+!***           (BETA MUST BE LESS THAN OR EQUAL TO 1)        ***
+
+!***    DTCRIT IS THE CRITICAL BUOYANCY (K) USED TO ADJUST THE ***
+!***                 APPROACH TO QUASI-EQUILIBRIUM           ***
+!***                     IT MUST BE LESS THAN 0              ***
+
+  include "cv3param.h"
+  include "cvflag.h"
+  include "conema3.h"
+
+  INTEGER, INTENT(IN)              :: nd
+  INTEGER, INTENT(IN)              :: k_upper
+  REAL, INTENT(IN)                 :: delt ! timestep (seconds)
+
+! Local variables
+  CHARACTER (LEN=20) :: modname = 'cv3_param'
+  CHARACTER (LEN=80) :: abort_message
+
+  LOGICAL, SAVE :: first = .TRUE.
+!$OMP THREADPRIVATE(first)
+
+!glb  noff: integer limit for convection (nd-noff)
+! minorig: First level of convection
+
+! -- limit levels for convection:
+
+!jyg<
+!  noff is chosen such that nl = k_upper so that upmost loops end at about 22 km
+!
+  noff = min(max(nd-k_upper, 1), (nd+1)/2)
+!!  noff = 1
+!>jyg
+  minorig = 1
+  nl = nd - noff
+  nlp = nl + 1
+  nlm = nl - 1
+
+  IF (first) THEN
+! -- "microphysical" parameters:
+! IM beg: ajout fis. reglage ep
+! CR+JYG: shedding coefficient (used when iflag_mix_adiab=1)
+! IM lu dans physiq.def via conf_phys.F90     epmax  = 0.993
+
+    omtrain = 45.0 ! used also for snow (no disctinction rain/snow)
+! -- misc:
+    dtovsh = -0.2 ! dT for overshoot
+! cc      dttrig = 5.   ! (loose) condition for triggering
+    dttrig = 10. ! (loose) condition for triggering
+    dtcrit = -2.0
+! -- end of convection
+! -- interface cloud parameterization:
+    delta = 0.01 ! cld
+! -- interface with boundary-layer (gust factor): (sb)
+    betad = 10.0 ! original value (from convect 4.3)
+
+! Var interm pour le getin
+     cv_flag_feed=1
+     CALL getin_p('cv_flag_feed',cv_flag_feed)
+     T_top_max = 1000.
+     CALL getin_p('t_top_max',T_top_max)
+     dpbase=-40.
+     CALL getin_p('dpbase',dpbase)
+     pbcrit=150.0
+     CALL getin_p('pbcrit',pbcrit)
+     ptcrit=500.0
+     CALL getin_p('ptcrit',ptcrit)
+     sigdz=0.01
+     CALL getin_p('sigdz',sigdz)
+     spfac=0.15
+     CALL getin_p('spfac',spfac)
+     tau=8000.
+     CALL getin_p('tau',tau)
+     flag_wb=1
+     CALL getin_p('flag_wb',flag_wb)
+     wbmax=6.
+     CALL getin_p('wbmax',wbmax)
+     ok_convstop=.False.
+     CALL getin_p('ok_convstop',ok_convstop)
+     tau_stop=15000.
+     CALL getin_p('tau_stop',tau_stop)
+     ok_intermittent=.False.
+     CALL getin_p('ok_intermittent',ok_intermittent)
+     ok_optim_yield=.False.
+     CALL getin_p('ok_optim_yield',ok_optim_yield)
+     ok_homo_tend=.TRUE.
+     CALL getin_p('ok_homo_tend',ok_homo_tend)
+     ok_entrain=.TRUE.
+     CALL getin_p('ok_entrain',ok_entrain)
+
+     coef_peel=0.25
+     CALL getin_p('coef_peel',coef_peel)
+
+     flag_epKEorig=1
+     CALL getin_p('flag_epKEorig',flag_epKEorig)
+     elcrit=0.0003
+     CALL getin_p('elcrit',elcrit)
+     tlcrit=-55.0
+     CALL getin_p('tlcrit',tlcrit)
+     ejectliq=0.
+     CALL getin_p('ejectliq',ejectliq)
+     ejectice=0.
+     CALL getin_p('ejectice',ejectice)
+     cvflag_prec_eject = .FALSE.
+     CALL getin_p('cvflag_prec_eject',cvflag_prec_eject)
+     qsat_depends_on_qt = .FALSE.
+     CALL getin_p('qsat_depends_on_qt',qsat_depends_on_qt)
+     adiab_ascent_mass_flux_depends_on_ejectliq = .FALSE.
+     CALL getin_p('adiab_ascent_mass_flux_depends_on_ejectliq',adiab_ascent_mass_flux_depends_on_ejectliq)
+     keepbug_ice_frac = .TRUE.
+     CALL getin_p('keepbug_ice_frac', keepbug_ice_frac)
+
+    WRITE (*, *) 't_top_max=', t_top_max
+    WRITE (*, *) 'dpbase=', dpbase
+    WRITE (*, *) 'pbcrit=', pbcrit
+    WRITE (*, *) 'ptcrit=', ptcrit
+    WRITE (*, *) 'sigdz=', sigdz
+    WRITE (*, *) 'spfac=', spfac
+    WRITE (*, *) 'tau=', tau
+    WRITE (*, *) 'flag_wb=', flag_wb
+    WRITE (*, *) 'wbmax=', wbmax
+    WRITE (*, *) 'ok_convstop=', ok_convstop
+    WRITE (*, *) 'tau_stop=', tau_stop
+    WRITE (*, *) 'ok_intermittent=', ok_intermittent
+    WRITE (*, *) 'ok_optim_yield =', ok_optim_yield
+    WRITE (*, *) 'coef_peel=', coef_peel
+
+    WRITE (*, *) 'flag_epKEorig=', flag_epKEorig
+    WRITE (*, *) 'elcrit=', elcrit
+    WRITE (*, *) 'tlcrit=', tlcrit
+    WRITE (*, *) 'ejectliq=', ejectliq
+    WRITE (*, *) 'ejectice=', ejectice
+    WRITE (*, *) 'cvflag_prec_eject =', cvflag_prec_eject 
+    WRITE (*, *) 'qsat_depends_on_qt =', qsat_depends_on_qt 
+    WRITE (*, *) 'adiab_ascent_mass_flux_depends_on_ejectliq =', adiab_ascent_mass_flux_depends_on_ejectliq
+    WRITE (*, *) 'keepbug_ice_frac =', keepbug_ice_frac 
+
+    first = .FALSE.
+  END IF ! (first)
+
+  beta = 1.0 - delt/tau
+  alpha1 = 1.5E-3
+!JYG    Correction bug alpha
+  alpha1 = alpha1*1.5
+  alpha = alpha1*delt/tau
+!JYG    Bug
+! cc increase alpha to compensate W decrease:
+! c      alpha  = alpha*1.5
+
+  noconv_stop = max(2.,tau_stop/delt)
+
+  RETURN
+END SUBROUTINE cv3_param
+
+SUBROUTINE cv3_incrcount(len, nd, delt, sig)
+
+IMPLICIT NONE
+
+! =====================================================================
+!  Increment the counter sig(nd)
+! =====================================================================
+
+  include "cv3param.h"
+  include "cvflag.h"
+
+!inputs:
+  INTEGER, INTENT(IN)                     :: len
+  INTEGER, INTENT(IN)                     :: nd
+  REAL, INTENT(IN)                        :: delt ! timestep (seconds)
+
+!input/output
+  REAL, DIMENSION(len,nd), INTENT(INOUT)  :: sig
+
+!local variables
+  INTEGER il
+
+!    print *,'cv3_incrcount : noconv_stop ',noconv_stop
+!    print *,'cv3_incrcount in, sig(1,nd) ',sig(1,nd)
+    IF(ok_convstop) THEN
+      DO il = 1, len
+        sig(il, nd) = sig(il, nd) + 1.
+        sig(il, nd) = min(sig(il,nd), noconv_stop+0.1)
+      END DO
+    ELSE
+      DO il = 1, len
+        sig(il, nd) = sig(il, nd) + 1.
+        sig(il, nd) = min(sig(il,nd), 12.1)
+      END DO
+    ENDIF  ! (ok_convstop)
+!    print *,'cv3_incrcount out, sig(1,nd) ',sig(1,nd)
+
+  RETURN
+END SUBROUTINE cv3_incrcount
+
+SUBROUTINE cv3_prelim(len, nd, ndp1, t, q, p, ph, &
+                      lv, lf, cpn, tv, gz, h, hm, th)
+  IMPLICIT NONE
+
+! =====================================================================
+! --- CALCULATE ARRAYS OF GEOPOTENTIAL, HEAT CAPACITY & STATIC ENERGY
+! "ori": from convect4.3 (vectorized)
+! "convect3": to be exactly consistent with convect3
+! =====================================================================
+
+! inputs:
+  INTEGER len, nd, ndp1
+  REAL t(len, nd), q(len, nd), p(len, nd), ph(len, ndp1)
+
+! outputs:
+  REAL lv(len, nd), lf(len, nd), cpn(len, nd), tv(len, nd)
+  REAL gz(len, nd), h(len, nd), hm(len, nd)
+  REAL th(len, nd)
+
+! local variables:
+  INTEGER k, i
+  REAL rdcp
+  REAL tvx, tvy ! convect3
+  REAL cpx(len, nd)
+
+  include "cvthermo.h"
+  include "cv3param.h"
+
+
+! ori      do 110 k=1,nlp
+! abderr     do 110 k=1,nl ! convect3
+  DO k = 1, nlp
+
+    DO i = 1, len
+! debug          lv(i,k)= lv0-clmcpv*(t(i,k)-t0)
+      lv(i, k) = lv0 - clmcpv*(t(i,k)-273.15)
+!!      lf(i, k) = lf0 - clmci*(t(i,k)-273.15)   ! erreur de signe !!
+      lf(i, k) = lf0 + clmci*(t(i,k)-273.15)
+      cpn(i, k) = cpd*(1.0-q(i,k)) + cpv*q(i, k)
+      cpx(i, k) = cpd*(1.0-q(i,k)) + cl*q(i, k)
+! ori          tv(i,k)=t(i,k)*(1.0+q(i,k)*epsim1)
+      tv(i, k) = t(i, k)*(1.0+q(i,k)/eps-q(i,k))
+      rdcp = (rrd*(1.-q(i,k))+q(i,k)*rrv)/cpn(i, k)
+      th(i, k) = t(i, k)*(1000.0/p(i,k))**rdcp
+    END DO
+  END DO
+
+! gz = phi at the full levels (same as p).
+
+!!  DO i = 1, len                    !jyg
+!!    gz(i, 1) = 0.0                 !jyg
+!!  END DO                           !jyg
+    gz(:,:) = 0.                     !jyg: initialization of the whole array
+! ori      do 140 k=2,nlp
+  DO k = 2, nl ! convect3
+    DO i = 1, len
+      tvx = t(i, k)*(1.+q(i,k)/eps-q(i,k))         !convect3
+      tvy = t(i, k-1)*(1.+q(i,k-1)/eps-q(i,k-1))   !convect3
+      gz(i, k) = gz(i, k-1) + 0.5*rrd*(tvx+tvy)* & !convect3
+                 (p(i,k-1)-p(i,k))/ph(i, k)        !convect3
+
+! c        print *,' gz(',k,')',gz(i,k),' tvx',tvx,' tvy ',tvy
+
+! ori         gz(i,k)=gz(i,k-1)+hrd*(tv(i,k-1)+tv(i,k))
+! ori    &         *(p(i,k-1)-p(i,k))/ph(i,k)
+    END DO
+  END DO
+
+! h  = phi + cpT (dry static energy).
+! hm = phi + cp(T-Tbase)+Lq
+
+! ori      do 170 k=1,nlp
+  DO k = 1, nl ! convect3
+    DO i = 1, len
+      h(i, k) = gz(i, k) + cpn(i, k)*t(i, k)
+      hm(i, k) = gz(i, k) + cpx(i, k)*(t(i,k)-t(i,1)) + lv(i, k)*q(i, k)
+    END DO
+  END DO
+
+  RETURN
+END SUBROUTINE cv3_prelim
+
+SUBROUTINE cv3_feed(len, nd, ok_conserv_q, &
+                    t, q, u, v, p, ph, h, gz, &
+                    p1feed, p2feed, wght, &
+                    wghti, tnk, thnk, qnk, qsnk, unk, vnk, &
+                    cpnk, hnk, nk, icb, icbmax, iflag, gznk, plcl)
+
+  USE mod_phys_lmdz_transfert_para, ONLY : bcast
+  USE add_phys_tend_mod, ONLY: fl_cor_ebil
+  USE print_control_mod, ONLY: prt_level
+  IMPLICIT NONE
+
+! ================================================================
+! Purpose: CONVECTIVE FEED
+
+! Main differences with cv_feed:
+! - ph added in input
+! - here, nk(i)=minorig
+! - icb defined differently (plcl compared with ph instead of p)
+! - dry static energy as argument instead of moist static energy
+
+! Main differences with convect3:
+! - we do not compute dplcldt and dplcldr of CLIFT anymore
+! - values iflag different (but tests identical)
+! - A,B explicitely defined (!...)
+! ================================================================
+
+  include "cv3param.h"
+  include "cvthermo.h"
+
+!inputs:
+  INTEGER, INTENT (IN)                               :: len, nd
+  LOGICAL, INTENT (IN)                               :: ok_conserv_q
+  REAL, DIMENSION (len, nd), INTENT (IN)             :: t, q, p
+  REAL, DIMENSION (len, nd), INTENT (IN)             :: u, v
+  REAL, DIMENSION (len, nd), INTENT (IN)             :: h, gz
+  REAL, DIMENSION (len, nd+1), INTENT (IN)           :: ph
+  REAL, DIMENSION (len), INTENT (IN)                 :: p1feed
+  REAL, DIMENSION (nd), INTENT (IN)                  :: wght
+!input-output
+  REAL, DIMENSION (len), INTENT (INOUT)              :: p2feed
+!outputs:
+  INTEGER, INTENT (OUT)                              :: icbmax
+  INTEGER, DIMENSION (len), INTENT (OUT)             :: iflag, nk, icb
+  REAL, DIMENSION (len, nd), INTENT (OUT)            :: wghti
+  REAL, DIMENSION (len), INTENT (OUT)                :: tnk, thnk, qnk, qsnk
+  REAL, DIMENSION (len), INTENT (OUT)                :: unk, vnk
+  REAL, DIMENSION (len), INTENT (OUT)                :: cpnk, hnk, gznk
+  REAL, DIMENSION (len), INTENT (OUT)                :: plcl
+
+!local variables:
+  INTEGER i, k, iter, niter
+  INTEGER ihmin(len)
+  REAL work(len)
+  REAL pup(len), plo(len), pfeed(len)
+  REAL plclup(len), plcllo(len), plclfeed(len)
+  REAL pfeedmin(len)
+  REAL posit(len)
+  LOGICAL nocond(len)
+
+!jyg20140217<
+  INTEGER iostat
+  LOGICAL, SAVE :: first
+  LOGICAL, SAVE :: ok_new_feed
+  REAL, SAVE :: dp_lcl_feed
+!$OMP THREADPRIVATE (first,ok_new_feed,dp_lcl_feed)
+  DATA first/.TRUE./
+  DATA dp_lcl_feed/2./
+
+  IF (first) THEN
+!$OMP MASTER
+    ok_new_feed = ok_conserv_q
+    OPEN (98, FILE='cv3feed_param.data', STATUS='old', FORM='formatted', IOSTAT=iostat)
+    IF (iostat==0) THEN
+      READ (98, *, END=998) ok_new_feed
+998   CONTINUE
+      CLOSE (98)
+    END IF
+    PRINT *, ' ok_new_feed: ', ok_new_feed
+!$OMP END MASTER
+    call bcast(ok_new_feed)
+    first = .FALSE.   
+  END IF
+!jyg>
+! -------------------------------------------------------------------
+! --- Origin level of ascending parcels for convect3:
+! -------------------------------------------------------------------
+
+  DO i = 1, len
+    nk(i) = minorig
+    gznk(i) = gz(i, nk(i))
+  END DO
+
+! -------------------------------------------------------------------
+! --- Adjust feeding layer thickness so that lifting up to the top of
+! --- the feeding layer does not induce condensation (i.e. so that
+! --- plcl < p2feed).
+! --- Method : iterative secant method.
+! -------------------------------------------------------------------
+
+! 1- First bracketing of the solution : ph(nk+1), p2feed
+
+! 1.a- LCL associated with p2feed
+  DO i = 1, len
+    pup(i) = p2feed(i)
+  END DO
+  IF (fl_cor_ebil >=2 ) THEN
+    CALL cv3_estatmix(len, nd, iflag, p1feed, pup, p, ph, &
+                     t, q, u, v, h, gz, wght, &
+                     wghti, nk, tnk, thnk, qnk, qsnk, unk, vnk, plclup)
+  ELSE
+    CALL cv3_enthalpmix(len, nd, iflag, p1feed, pup, p, ph, &
+                       t, q, u, v, wght, &
+                       wghti, nk, tnk, thnk, qnk, qsnk, unk, vnk, plclup)
+  ENDIF  ! (fl_cor_ebil >=2 ) 
+! 1.b- LCL associated with ph(nk+1)
+  DO i = 1, len
+    plo(i) = ph(i, nk(i)+1)
+  END DO
+  IF (fl_cor_ebil >=2 ) THEN
+    CALL cv3_estatmix(len, nd, iflag, p1feed, plo, p, ph, &
+                     t, q, u, v, h, gz, wght, &
+                     wghti, nk, tnk, thnk, qnk, qsnk, unk, vnk, plcllo)
+  ELSE
+    CALL cv3_enthalpmix(len, nd, iflag, p1feed, plo, p, ph, &
+                       t, q, u, v, wght, &
+                       wghti, nk, tnk, thnk, qnk, qsnk, unk, vnk, plcllo)
+  ENDIF  ! (fl_cor_ebil >=2 ) 
+! 2- Iterations
+  niter = 5
+  DO iter = 1, niter
+    DO i = 1, len
+      plcllo(i) = min(plo(i), plcllo(i))
+      plclup(i) = max(pup(i), plclup(i))
+      nocond(i) = plclup(i) <= pup(i)
+    END DO
+    DO i = 1, len
+      IF (nocond(i)) THEN
+        pfeed(i) = pup(i)
+      ELSE
+!JYG20140217<
+        IF (ok_new_feed) THEN
+          pfeed(i) = (pup(i)*(plo(i)-plcllo(i)-dp_lcl_feed)+  &
+                      plo(i)*(plclup(i)-pup(i)+dp_lcl_feed))/ &
+                     (plo(i)-plcllo(i)+plclup(i)-pup(i))
+        ELSE
+          pfeed(i) = (pup(i)*(plo(i)-plcllo(i))+  &
+                      plo(i)*(plclup(i)-pup(i)))/ &
+                     (plo(i)-plcllo(i)+plclup(i)-pup(i))
+        END IF
+!JYG>
+      END IF
+    END DO
+!jyg20140217<
+! For the last iteration, make sure that the top of the feeding layer
+! and LCL are not in the same layer:
+    IF (ok_new_feed) THEN
+      IF (iter==niter) THEN
+        DO i = 1,len                         !jyg
+          pfeedmin(i) = ph(i,minorig+1)      !jyg
+        ENDDO                                !jyg
+        DO k = minorig+1, nl                 !jyg
+!!        DO k = minorig, nl                 !jyg
+          DO i = 1, len
+            IF (ph(i,k)>=plclfeed(i)) pfeedmin(i) = ph(i, k)
+          END DO
+        END DO
+        DO i = 1, len
+          pfeed(i) = max(pfeedmin(i), pfeed(i))
+        END DO
+      END IF
+    END IF
+!jyg>
+
+    IF (fl_cor_ebil >=2 ) THEN
+      CALL cv3_estatmix(len, nd, iflag, p1feed, pfeed, p, ph, &
+                       t, q, u, v, h, gz, wght, &
+                       wghti, nk, tnk, thnk, qnk, qsnk, unk, vnk, plclfeed)
+    ELSE
+      CALL cv3_enthalpmix(len, nd, iflag, p1feed, pfeed, p, ph, &
+                         t, q, u, v, wght, &
+                         wghti, nk, tnk, thnk, qnk, qsnk, unk, vnk, plclfeed)
+    ENDIF  ! (fl_cor_ebil >=2 ) 
+!jyg20140217<
+    IF (ok_new_feed) THEN
+      DO i = 1, len
+        posit(i) = (sign(1.,plclfeed(i)-pfeed(i)+dp_lcl_feed)+1.)*0.5
+        IF (plclfeed(i)-pfeed(i)+dp_lcl_feed==0.) posit(i) = 1.
+      END DO
+    ELSE
+      DO i = 1, len
+        posit(i) = (sign(1.,plclfeed(i)-pfeed(i))+1.)*0.5
+        IF (plclfeed(i)==pfeed(i)) posit(i) = 1.
+      END DO
+    END IF
+!jyg>
+    DO i = 1, len
+! - posit = 1 when lcl is below top of feeding layer (plclfeed>pfeed)
+! -               => pup=pfeed
+! - posit = 0 when lcl is above top of feeding layer (plclfeed<pfeed)
+! -               => plo=pfeed
+      pup(i) = posit(i)*pfeed(i) + (1.-posit(i))*pup(i)
+      plo(i) = (1.-posit(i))*pfeed(i) + posit(i)*plo(i)
+      plclup(i) = posit(i)*plclfeed(i) + (1.-posit(i))*plclup(i)
+      plcllo(i) = (1.-posit(i))*plclfeed(i) + posit(i)*plcllo(i)
+    END DO
+  END DO !  iter
+
+  DO i = 1, len
+    p2feed(i) = pfeed(i)
+    plcl(i) = plclfeed(i)
+  END DO
+
+  DO i = 1, len
+    cpnk(i) = cpd*(1.0-qnk(i)) + cpv*qnk(i)
+    hnk(i) = gz(i, 1) + cpnk(i)*tnk(i)
+  END DO
+
+! -------------------------------------------------------------------
+! --- Check whether parcel level temperature and specific humidity
+! --- are reasonable
+! -------------------------------------------------------------------
+  IF (cv_flag_feed == 1) THEN
+    DO i = 1, len
+      IF (((tnk(i)<250.0)                       .OR.  &
+           (qnk(i)<=0.0))                       .AND. &
+          (iflag(i)==0)) iflag(i) = 7
+    END DO
+  ELSEIF (cv_flag_feed >= 2) THEN
+! --- and demand that LCL be high enough
+    DO i = 1, len
+      IF (((tnk(i)<250.0)                       .OR.  &
+           (qnk(i)<=0.0)                        .OR.  &
+           (plcl(i)>min(0.99*ph(i,1),ph(i,3)))) .AND. &
+          (iflag(i)==0)) iflag(i) = 7
+    END DO
+  ENDIF
+  IF (prt_level .GE. 10) THEN
+    print *,'cv3_feed : iflag(1), pfeed(1), plcl(1), wghti(1,k) ', &
+                        iflag(1), pfeed(1), plcl(1), (wghti(1,k),k=1,10)
+  ENDIF
+
+! -------------------------------------------------------------------
+! --- Calculate first level above lcl (=icb)
+! -------------------------------------------------------------------
+
+!@      do 270 i=1,len
+!@       icb(i)=nlm
+!@ 270  continue
+!@c
+!@      do 290 k=minorig,nl
+!@        do 280 i=1,len
+!@          if((k.ge.(nk(i)+1)).and.(p(i,k).lt.plcl(i)))
+!@     &    icb(i)=min(icb(i),k)
+!@ 280    continue
+!@ 290  continue
+!@c
+!@      do 300 i=1,len
+!@        if((icb(i).ge.nlm).and.(iflag(i).eq.0))iflag(i)=9
+!@ 300  continue
+
+  DO i = 1, len
+    icb(i) = nlm
+  END DO
+
+! la modification consiste a comparer plcl a ph et non a p:
+! icb est defini par :  ph(icb)<plcl<ph(icb-1)
+!@      do 290 k=minorig,nl
+  DO k = 3, nl - 1 ! modif pour que icb soit sup/egal a 2
+    DO i = 1, len
+      IF (ph(i,k)<plcl(i)) icb(i) = min(icb(i), k)
+    END DO
+  END DO
+
+
+! print*,'icb dans cv3_feed '
+! write(*,'(64i2)') icb(2:len-1)
+! call dump2d(64,43,'plcl dans cv3_feed ',plcl(2:len-1))
+
+  DO i = 1, len
+!@        if((icb(i).ge.nlm).and.(iflag(i).eq.0))iflag(i)=9
+    IF ((icb(i)==nlm) .AND. (iflag(i)==0)) iflag(i) = 9
+  END DO
+
+  DO i = 1, len
+    icb(i) = icb(i) - 1 ! icb sup ou egal a 2
+  END DO
+
+! Compute icbmax.
+
+  icbmax = 2
+  DO i = 1, len
+!!        icbmax=max(icbmax,icb(i))
+    IF (iflag(i)<7) icbmax = max(icbmax, icb(i))     ! sb Jun7th02
+  END DO
+
+  RETURN
+END SUBROUTINE cv3_feed
+
+SUBROUTINE cv3_undilute1(len, nd, t, qs, gz, plcl, p, icb, tnk, qnk, gznk, &
+                         tp, tvp, clw, icbs)
+  IMPLICIT NONE
+
+! ----------------------------------------------------------------
+! Equivalent de TLIFT entre NK et ICB+1 inclus
+
+! Differences with convect4:
+!    - specify plcl in input
+!    - icbs is the first level above LCL (may differ from icb)
+!    - in the iterations, used x(icbs) instead x(icb)
+!    - many minor differences in the iterations
+!    - tvp is computed in only one time
+!    - icbs: first level above Plcl (IMIN de TLIFT) in output
+!    - if icbs=icb, compute also tp(icb+1),tvp(icb+1) & clw(icb+1)
+! ----------------------------------------------------------------
+
+  include "cvthermo.h"
+  include "cv3param.h"
+
+! inputs:
+  INTEGER, INTENT (IN)                              :: len, nd
+  INTEGER, DIMENSION (len), INTENT (IN)             :: icb
+  REAL, DIMENSION (len, nd), INTENT (IN)            :: t, qs, gz
+  REAL, DIMENSION (len), INTENT (IN)                :: tnk, qnk, gznk
+  REAL, DIMENSION (len, nd), INTENT (IN)            :: p
+  REAL, DIMENSION (len), INTENT (IN)                :: plcl              ! convect3
+
+! outputs:
+  INTEGER, DIMENSION (len), INTENT (OUT)            :: icbs
+  REAL, DIMENSION (len, nd), INTENT (OUT)           :: tp, tvp, clw
+
+! local variables:
+  INTEGER i, k
+  INTEGER icb1(len), icbsmax2                                            ! convect3
+  REAL tg, qg, alv, s, ahg, tc, denom, es, rg
+  REAL ah0(len), cpp(len)
+  REAL ticb(len), gzicb(len)
+  REAL qsicb(len)                                                        ! convect3
+  REAL cpinv(len)                                                        ! convect3
+
+! -------------------------------------------------------------------
+! --- Calculates the lifted parcel virtual temperature at nk,
+! --- the actual temperature, and the adiabatic
+! --- liquid water content. The procedure is to solve the equation.
+!     cp*tp+L*qp+phi=cp*tnk+L*qnk+gznk.
+! -------------------------------------------------------------------
+
+
+! ***  Calculate certain parcel quantities, including static energy   ***
+
+  DO i = 1, len
+    ah0(i) = (cpd*(1.-qnk(i))+cl*qnk(i))*tnk(i) + qnk(i)*(lv0-clmcpv*(tnk(i)-273.15)) + gznk(i)
+    cpp(i) = cpd*(1.-qnk(i)) + qnk(i)*cpv
+    cpinv(i) = 1./cpp(i)
+  END DO
+
+! ***   Calculate lifted parcel quantities below cloud base   ***
+
+  DO i = 1, len                                           !convect3
+    icb1(i) = min(max(icb(i), 2), nl)
+! if icb is below LCL, start loop at ICB+1:
+! (icbs est le premier niveau au-dessus du LCL)
+    icbs(i) = icb1(i)                                     !convect3
+    IF (plcl(i)<p(i,icb1(i))) THEN
+      icbs(i) = min(icbs(i)+1, nl)                        !convect3
+    END IF
+  END DO                                                  !convect3
+
+  DO i = 1, len !convect3
+    ticb(i) = t(i, icbs(i))                               !convect3
+    gzicb(i) = gz(i, icbs(i))                             !convect3
+    qsicb(i) = qs(i, icbs(i))                             !convect3
+  END DO !convect3
+
+
+! Re-compute icbsmax (icbsmax2):                          !convect3
+!                                                         !convect3
+  icbsmax2 = 2                                            !convect3
+  DO i = 1, len                                           !convect3
+    icbsmax2 = max(icbsmax2, icbs(i))                     !convect3
+  END DO                                                  !convect3
+
+! initialization outputs:
+
+  DO k = 1, icbsmax2                                      ! convect3
+    DO i = 1, len                                         ! convect3
+      tp(i, k) = 0.0                                      ! convect3
+      tvp(i, k) = 0.0                                     ! convect3
+      clw(i, k) = 0.0                                     ! convect3
+    END DO                                                ! convect3
+  END DO                                                  ! convect3
+
+! tp and tvp below cloud base:
+
+  DO k = minorig, icbsmax2 - 1
+    DO i = 1, len
+      tp(i, k) = tnk(i) - (gz(i,k)-gznk(i))*cpinv(i)
+      tvp(i, k) = tp(i, k)*(1.+qnk(i)/eps-qnk(i))        !whole thing (convect3)
+    END DO
+  END DO
+
+! ***  Find lifted parcel quantities above cloud base    ***
+
+  DO i = 1, len
+    tg = ticb(i)
+! ori         qg=qs(i,icb(i))
+    qg = qsicb(i) ! convect3
+! debug         alv=lv0-clmcpv*(ticb(i)-t0)
+    alv = lv0 - clmcpv*(ticb(i)-273.15)
+
+! First iteration.
+
+! ori          s=cpd+alv*alv*qg/(rrv*ticb(i)*ticb(i))
+    s = cpd*(1.-qnk(i)) + cl*qnk(i) + &                   ! convect3
+        alv*alv*qg/(rrv*ticb(i)*ticb(i))                  ! convect3
+    s = 1./s
+! ori          ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i)
+    ahg = cpd*tg + (cl-cpd)*qnk(i)*tg + alv*qg + gzicb(i) ! convect3
+    tg = tg + s*(ah0(i)-ahg)
+! ori          tg=max(tg,35.0)
+! debug          tc=tg-t0
+    tc = tg - 273.15
+    denom = 243.5 + tc
+    denom = max(denom, 1.0) ! convect3
+! ori          if(tc.ge.0.0)then
+    es = 6.112*exp(17.67*tc/denom)
+! ori          else
+! ori           es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
+! ori          endif
+! ori          qg=eps*es/(p(i,icb(i))-es*(1.-eps))
+    qg = eps*es/(p(i,icbs(i))-es*(1.-eps))
+
+! Second iteration.
+
+
+! ori          s=cpd+alv*alv*qg/(rrv*ticb(i)*ticb(i))
+! ori          s=1./s
+! ori          ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i)
+    ahg = cpd*tg + (cl-cpd)*qnk(i)*tg + alv*qg + gzicb(i) ! convect3
+    tg = tg + s*(ah0(i)-ahg)
+! ori          tg=max(tg,35.0)
+! debug          tc=tg-t0
+    tc = tg - 273.15
+    denom = 243.5 + tc
+    denom = max(denom, 1.0)                               ! convect3
+! ori          if(tc.ge.0.0)then
+    es = 6.112*exp(17.67*tc/denom)
+! ori          else
+! ori           es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
+! ori          end if
+! ori          qg=eps*es/(p(i,icb(i))-es*(1.-eps))
+    qg = eps*es/(p(i,icbs(i))-es*(1.-eps))
+
+    alv = lv0 - clmcpv*(ticb(i)-273.15)
+
+! ori c approximation here:
+! ori         tp(i,icb(i))=(ah0(i)-(cl-cpd)*qnk(i)*ticb(i)
+! ori     &   -gz(i,icb(i))-alv*qg)/cpd
+
+! convect3: no approximation:
+    tp(i, icbs(i)) = (ah0(i)-gz(i,icbs(i))-alv*qg)/(cpd+(cl-cpd)*qnk(i))
+
+! ori         clw(i,icb(i))=qnk(i)-qg
+! ori         clw(i,icb(i))=max(0.0,clw(i,icb(i)))
+    clw(i, icbs(i)) = qnk(i) - qg
+    clw(i, icbs(i)) = max(0.0, clw(i,icbs(i)))
+
+    rg = qg/(1.-qnk(i))
+! ori         tvp(i,icb(i))=tp(i,icb(i))*(1.+rg*epsi)
+! convect3: (qg utilise au lieu du vrai mixing ratio rg)
+    tvp(i, icbs(i)) = tp(i, icbs(i))*(1.+qg/eps-qnk(i))   !whole thing
+
+  END DO
+
+! ori      do 380 k=minorig,icbsmax2
+! ori       do 370 i=1,len
+! ori         tvp(i,k)=tvp(i,k)-tp(i,k)*qnk(i)
+! ori 370   continue
+! ori 380  continue
+
+
+! -- The following is only for convect3:
+
+! * icbs is the first level above the LCL:
+! if plcl<p(icb), then icbs=icb+1
+! if plcl>p(icb), then icbs=icb
+
+! * the routine above computes tvp from minorig to icbs (included).
+
+! * to compute buoybase (in cv3_trigger.F), both tvp(icb) and tvp(icb+1)
+! must be known. This is the case if icbs=icb+1, but not if icbs=icb.
+
+! * therefore, in the case icbs=icb, we compute tvp at level icb+1
+! (tvp at other levels will be computed in cv3_undilute2.F)
+
+
+  DO i = 1, len
+    ticb(i) = t(i, icb(i)+1)
+    gzicb(i) = gz(i, icb(i)+1)
+    qsicb(i) = qs(i, icb(i)+1)
+  END DO
+
+  DO i = 1, len
+    tg = ticb(i)
+    qg = qsicb(i) ! convect3
+! debug         alv=lv0-clmcpv*(ticb(i)-t0)
+    alv = lv0 - clmcpv*(ticb(i)-273.15)
+
+! First iteration.
+
+! ori          s=cpd+alv*alv*qg/(rrv*ticb(i)*ticb(i))
+    s = cpd*(1.-qnk(i)) + cl*qnk(i) &                         ! convect3
+      +alv*alv*qg/(rrv*ticb(i)*ticb(i))                       ! convect3
+    s = 1./s
+! ori          ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i)
+    ahg = cpd*tg + (cl-cpd)*qnk(i)*tg + alv*qg + gzicb(i)     ! convect3
+    tg = tg + s*(ah0(i)-ahg)
+! ori          tg=max(tg,35.0)
+! debug          tc=tg-t0
+    tc = tg - 273.15
+    denom = 243.5 + tc
+    denom = max(denom, 1.0)                                   ! convect3
+! ori          if(tc.ge.0.0)then
+    es = 6.112*exp(17.67*tc/denom)
+! ori          else
+! ori           es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
+! ori          endif
+! ori          qg=eps*es/(p(i,icb(i))-es*(1.-eps))
+    qg = eps*es/(p(i,icb(i)+1)-es*(1.-eps))
+
+! Second iteration.
+
+
+! ori          s=cpd+alv*alv*qg/(rrv*ticb(i)*ticb(i))
+! ori          s=1./s
+! ori          ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i)
+    ahg = cpd*tg + (cl-cpd)*qnk(i)*tg + alv*qg + gzicb(i)     ! convect3
+    tg = tg + s*(ah0(i)-ahg)
+! ori          tg=max(tg,35.0)
+! debug          tc=tg-t0
+    tc = tg - 273.15
+    denom = 243.5 + tc
+    denom = max(denom, 1.0)                                   ! convect3
+! ori          if(tc.ge.0.0)then
+    es = 6.112*exp(17.67*tc/denom)
+! ori          else
+! ori           es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
+! ori          end if
+! ori          qg=eps*es/(p(i,icb(i))-es*(1.-eps))
+    qg = eps*es/(p(i,icb(i)+1)-es*(1.-eps))
+
+    alv = lv0 - clmcpv*(ticb(i)-273.15)
+
+! ori c approximation here:
+! ori         tp(i,icb(i))=(ah0(i)-(cl-cpd)*qnk(i)*ticb(i)
+! ori     &   -gz(i,icb(i))-alv*qg)/cpd
+
+! convect3: no approximation:
+    tp(i, icb(i)+1) = (ah0(i)-gz(i,icb(i)+1)-alv*qg)/(cpd+(cl-cpd)*qnk(i))
+
+! ori         clw(i,icb(i))=qnk(i)-qg
+! ori         clw(i,icb(i))=max(0.0,clw(i,icb(i)))
+    clw(i, icb(i)+1) = qnk(i) - qg
+    clw(i, icb(i)+1) = max(0.0, clw(i,icb(i)+1))
+
+    rg = qg/(1.-qnk(i))
+! ori         tvp(i,icb(i))=tp(i,icb(i))*(1.+rg*epsi)
+! convect3: (qg utilise au lieu du vrai mixing ratio rg)
+    tvp(i, icb(i)+1) = tp(i, icb(i)+1)*(1.+qg/eps-qnk(i))     !whole thing
+
+  END DO
+
+  RETURN
+END SUBROUTINE cv3_undilute1
+
+SUBROUTINE cv3_trigger(len, nd, icb, plcl, p, th, tv, tvp, thnk, &
+                       pbase, buoybase, iflag, sig, w0)
+  IMPLICIT NONE
+
+! -------------------------------------------------------------------
+! --- TRIGGERING
+
+! - computes the cloud base
+! - triggering (crude in this version)
+! - relaxation of sig and w0 when no convection
+
+! Caution1: if no convection, we set iflag=14
+! (it used to be 0 in convect3)
+
+! Caution2: at this stage, tvp (and thus buoy) are know up
+! through icb only!
+! -> the buoyancy below cloud base not (yet) set to the cloud base buoyancy
+! -------------------------------------------------------------------
+
+  include "cv3param.h"
+
+! input:
+  INTEGER len, nd
+  INTEGER icb(len)
+  REAL plcl(len), p(len, nd)
+  REAL th(len, nd), tv(len, nd), tvp(len, nd)
+  REAL thnk(len)
+
+! output:
+  REAL pbase(len), buoybase(len)
+
+! input AND output:
+  INTEGER iflag(len)
+  REAL sig(len, nd), w0(len, nd)
+
+! local variables:
+  INTEGER i, k
+  REAL tvpbase, tvbase, tdif, ath, ath1
+
+
+! ***   set cloud base buoyancy at (plcl+dpbase) level buoyancy
+
+  DO i = 1, len
+    pbase(i) = plcl(i) + dpbase
+    tvpbase = tvp(i, icb(i))  *(pbase(i)-p(i,icb(i)+1))/(p(i,icb(i))-p(i,icb(i)+1)) + &
+              tvp(i, icb(i)+1)*(p(i,icb(i))-pbase(i))  /(p(i,icb(i))-p(i,icb(i)+1))
+    tvbase = tv(i, icb(i))  *(pbase(i)-p(i,icb(i)+1))/(p(i,icb(i))-p(i,icb(i)+1)) + &
+             tv(i, icb(i)+1)*(p(i,icb(i))-pbase(i))  /(p(i,icb(i))-p(i,icb(i)+1))
+    buoybase(i) = tvpbase - tvbase
+  END DO
+
+
+! ***   make sure that column is dry adiabatic between the surface  ***
+! ***    and cloud base, and that lifted air is positively buoyant  ***
+! ***                         at cloud base                         ***
+! ***       if not, return to calling program after resetting       ***
+! ***                        sig(i) and w0(i)                       ***
+
+
+! oct3      do 200 i=1,len
+! oct3
+! oct3       tdif = buoybase(i)
+! oct3       ath1 = th(i,1)
+! oct3       ath  = th(i,icb(i)-1) - dttrig
+! oct3
+! oct3       if (tdif.lt.dtcrit .or. ath.gt.ath1) then
+! oct3         do 60 k=1,nl
+! oct3            sig(i,k) = beta*sig(i,k) - 2.*alpha*tdif*tdif
+! oct3            sig(i,k) = AMAX1(sig(i,k),0.0)
+! oct3            w0(i,k)  = beta*w0(i,k)
+! oct3   60    continue
+! oct3         iflag(i)=4 ! pour version vectorisee
+! oct3c convect3         iflag(i)=0
+! oct3cccc         return
+! oct3       endif
+! oct3
+! oct3200   continue
+
+! -- oct3: on reecrit la boucle 200 (pour la vectorisation)
+
+  DO k = 1, nl
+    DO i = 1, len
+
+      tdif = buoybase(i)
+      ath1 = thnk(i)
+      ath = th(i, icb(i)-1) - dttrig
+
+      IF (tdif<dtcrit .OR. ath>ath1) THEN
+        sig(i, k) = beta*sig(i, k) - 2.*alpha*tdif*tdif
+        sig(i, k) = amax1(sig(i,k), 0.0)
+        w0(i, k) = beta*w0(i, k)
+        iflag(i) = 14 ! pour version vectorisee
+! convect3         iflag(i)=0
+      END IF
+
+    END DO
+  END DO
+
+! fin oct3 --
+
+  RETURN
+END SUBROUTINE cv3_trigger
+
+SUBROUTINE cv3_compress(len, nloc, ncum, nd, ntra, &
+                        iflag1, nk1, icb1, icbs1, &
+                        plcl1, tnk1, qnk1, gznk1, pbase1, buoybase1, &
+                        t1, q1, qs1, u1, v1, gz1, th1, &
+                        tra1, &
+                        h1, lv1, cpn1, p1, ph1, tv1, tp1, tvp1, clw1, &
+                        sig1, w01, &
+                        iflag, nk, icb, icbs, &
+                        plcl, tnk, qnk, gznk, pbase, buoybase, &
+                        t, q, qs, u, v, gz, th, &
+                        tra, &
+                        h, lv, cpn, p, ph, tv, tp, tvp, clw, &
+                        sig, w0)
+  USE print_control_mod, ONLY: lunout
+  IMPLICIT NONE
+
+  include "cv3param.h"
+
+!inputs:
+  INTEGER len, ncum, nd, ntra, nloc
+  INTEGER iflag1(len), nk1(len), icb1(len), icbs1(len)
+  REAL plcl1(len), tnk1(len), qnk1(len), gznk1(len)
+  REAL pbase1(len), buoybase1(len)
+  REAL t1(len, nd), q1(len, nd), qs1(len, nd), u1(len, nd), v1(len, nd)
+  REAL gz1(len, nd), h1(len, nd), lv1(len, nd), cpn1(len, nd)
+  REAL p1(len, nd), ph1(len, nd+1), tv1(len, nd), tp1(len, nd)
+  REAL tvp1(len, nd), clw1(len, nd)
+  REAL th1(len, nd)
+  REAL sig1(len, nd), w01(len, nd)
+  REAL tra1(len, nd, ntra)
+
+!outputs:
+! en fait, on a nloc=len pour l'instant (cf cv_driver)
+  INTEGER iflag(nloc), nk(nloc), icb(nloc), icbs(nloc)
+  REAL plcl(nloc), tnk(nloc), qnk(nloc), gznk(nloc)
+  REAL pbase(nloc), buoybase(nloc)
+  REAL t(nloc, nd), q(nloc, nd), qs(nloc, nd), u(nloc, nd), v(nloc, nd)
+  REAL gz(nloc, nd), h(nloc, nd), lv(nloc, nd), cpn(nloc, nd)
+  REAL p(nloc, nd), ph(nloc, nd+1), tv(nloc, nd), tp(nloc, nd)
+  REAL tvp(nloc, nd), clw(nloc, nd)
+  REAL th(nloc, nd)
+  REAL sig(nloc, nd), w0(nloc, nd)
+  REAL tra(nloc, nd, ntra)
+
+!local variables:
+  INTEGER i, k, nn, j
+
+  CHARACTER (LEN=20) :: modname = 'cv3_compress'
+  CHARACTER (LEN=80) :: abort_message
+
+  DO k = 1, nl + 1
+    nn = 0
+    DO i = 1, len
+      IF (iflag1(i)==0) THEN
+        nn = nn + 1
+        sig(nn, k) = sig1(i, k)
+        w0(nn, k) = w01(i, k)
+        t(nn, k) = t1(i, k)
+        q(nn, k) = q1(i, k)
+        qs(nn, k) = qs1(i, k)
+        u(nn, k) = u1(i, k)
+        v(nn, k) = v1(i, k)
+        gz(nn, k) = gz1(i, k)
+        h(nn, k) = h1(i, k)
+        lv(nn, k) = lv1(i, k)
+        cpn(nn, k) = cpn1(i, k)
+        p(nn, k) = p1(i, k)
+        ph(nn, k) = ph1(i, k)
+        tv(nn, k) = tv1(i, k)
+        tp(nn, k) = tp1(i, k)
+        tvp(nn, k) = tvp1(i, k)
+        clw(nn, k) = clw1(i, k)
+        th(nn, k) = th1(i, k)
+      END IF
+    END DO
+  END DO
+
+!AC!      do 121 j=1,ntra
+!AC!ccccc      do 111 k=1,nl+1
+!AC!      do 111 k=1,nd
+!AC!       nn=0
+!AC!      do 101 i=1,len
+!AC!      if(iflag1(i).eq.0)then
+!AC!       nn=nn+1
+!AC!       tra(nn,k,j)=tra1(i,k,j)
+!AC!      endif
+!AC! 101  continue
+!AC! 111  continue
+!AC! 121  continue
+
+  IF (nn/=ncum) THEN
+    WRITE (lunout, *) 'strange! nn not equal to ncum: ', nn, ncum
+    abort_message = ''
+    CALL abort_physic(modname, abort_message, 1)
+  END IF
+
+  nn = 0
+  DO i = 1, len
+    IF (iflag1(i)==0) THEN
+      nn = nn + 1
+      pbase(nn) = pbase1(i)
+      buoybase(nn) = buoybase1(i)
+      plcl(nn) = plcl1(i)
+      tnk(nn) = tnk1(i)
+      qnk(nn) = qnk1(i)
+      gznk(nn) = gznk1(i)
+      nk(nn) = nk1(i)
+      icb(nn) = icb1(i)
+      icbs(nn) = icbs1(i)
+      iflag(nn) = iflag1(i)
+    END IF
+  END DO
+
+  RETURN
+END SUBROUTINE cv3_compress
+
+SUBROUTINE icefrac(t, clw, qi, nl, len)
+  IMPLICIT NONE
+
+
+!JAM--------------------------------------------------------------------
+! Calcul de la quantité d'eau sous forme de glace
+! --------------------------------------------------------------------
+  INTEGER nl, len
+  REAL qi(len, nl)
+  REAL t(len, nl), clw(len, nl)
+  REAL fracg
+  INTEGER k, i
+
+  DO k = 3, nl
+    DO i = 1, len
+      IF (t(i,k)>263.15) THEN
+        qi(i, k) = 0.
+      ELSE
+        IF (t(i,k)<243.15) THEN
+          qi(i, k) = clw(i, k)
+        ELSE
+          fracg = (263.15-t(i,k))/20
+          qi(i, k) = clw(i, k)*fracg
+        END IF
+      END IF
+! print*,t(i,k),qi(i,k),'temp,testglace'
+    END DO
+  END DO
+
+  RETURN
+
+END SUBROUTINE icefrac
+
+SUBROUTINE cv3_undilute2(nloc, ncum, nd, iflag, icb, icbs, nk, &
+                         tnk, qnk, gznk, hnk, t, q, qs, gz, &
+                         p, ph, h, tv, lv, lf, pbase, buoybase, plcl, &
+                         inb, tp, tvp, clw, hp, ep, sigp, buoy, &
+                         frac_a, frac_s, qpreca, qta)
+  USE print_control_mod, ONLY: prt_level
+  IMPLICIT NONE
+
+! ---------------------------------------------------------------------
+! Purpose:
+! FIND THE REST OF THE LIFTED PARCEL TEMPERATURES
+! &
+! COMPUTE THE PRECIPITATION EFFICIENCIES AND THE
+! FRACTION OF PRECIPITATION FALLING OUTSIDE OF CLOUD
+! &
+! FIND THE LEVEL OF NEUTRAL BUOYANCY
+
+! Main differences convect3/convect4:
+!   - icbs (input) is the first level above LCL (may differ from icb)
+!   - many minor differences in the iterations
+!   - condensed water not removed from tvp in convect3
+!   - vertical profile of buoyancy computed here (use of buoybase)
+!   - the determination of inb is different
+!   - no inb1, only inb in output
+! ---------------------------------------------------------------------
+
+  include "cvthermo.h"
+  include "cv3param.h"
+  include "conema3.h"
+  include "cvflag.h"
+  include "YOMCST2.h"
+
+!inputs:
+  INTEGER, INTENT (IN)                               :: ncum, nd, nloc
+  INTEGER, DIMENSION (nloc), INTENT (IN)             :: icb, icbs, nk
+  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: t, q, qs, gz
+  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: p
+  REAL, DIMENSION (nloc, nd+1), INTENT (IN)          :: ph
+  REAL, DIMENSION (nloc), INTENT (IN)                :: tnk, qnk, gznk
+  REAL, DIMENSION (nloc), INTENT (IN)                :: hnk
+  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: lv, lf, tv, h
+  REAL, DIMENSION (nloc), INTENT (IN)                :: pbase, buoybase, plcl
+
+!input/outputs:
+  REAL, DIMENSION (nloc, nd), INTENT (INOUT)         :: tp, tvp, clw   ! Input for k = 1, icb+1 (computed in cv3_undilute1)
+                                                                       ! Output above
+  INTEGER, DIMENSION (nloc), INTENT (INOUT)          :: iflag
+
+!outputs:
+  INTEGER, DIMENSION (nloc), INTENT (OUT)            :: inb
+  REAL, DIMENSION (nloc, nd), INTENT (OUT)           :: ep, sigp, hp
+  REAL, DIMENSION (nloc, nd), INTENT (OUT)           :: buoy
+  REAL, DIMENSION (nloc, nd), INTENT (OUT)           :: frac_a, frac_s
+  REAL, DIMENSION (nloc, nd), INTENT (OUT)           :: qpreca
+  REAL, DIMENSION (nloc, nd), INTENT (OUT)           :: qta
+
+!local variables:
+  INTEGER i, j, k
+  REAL smallestreal
+  REAL tg, qg, dqgdT, ahg, alv, alf, s, tc, es, esi, denom, rg, tca, elacrit
+  REAL                                               :: phinu2p
+  REAL                                               :: qhthreshold
+  REAL                                               :: als
+  REAL                                               :: qsat_new, snew
+  REAL, DIMENSION (nloc,nd)                          :: qi
+  REAL, DIMENSION (nloc,nd)                          :: ha    ! moist static energy of adiabatic ascents 
+                                                              ! taking into account precip ejection
+  REAL, DIMENSION (nloc,nd)                          :: hla   ! liquid water static energy of adiabatic ascents 
+                                                              ! taking into account precip ejection
+  REAL, DIMENSION (nloc,nd)                          :: qcld  ! specific cloud water
+  REAL, DIMENSION (nloc,nd)                          :: qhsat    ! specific humidity at saturation
+  REAL, DIMENSION (nloc,nd)                          :: dqhsatdT ! dqhsat/dT
+  REAL, DIMENSION (nloc,nd)                          :: frac  ! ice fraction function of envt temperature
+  REAL, DIMENSION (nloc,nd)                          :: qps   ! specific solid precipitation
+  REAL, DIMENSION (nloc,nd)                          :: qpl   ! specific liquid precipitation
+  REAL, DIMENSION (nloc)                             :: ah0, cape, capem, byp
+  LOGICAL, DIMENSION (nloc)                          :: lcape
+  INTEGER, DIMENSION (nloc)                          :: iposit
+  REAL                                               :: denomm1
+  REAL                                               :: by, defrac, pden, tbis
+  REAL                                               :: fracg
+  REAL                                               :: deltap
+  REAL, SAVE                                         :: Tx, Tm
+  DATA Tx/263.15/, Tm/243.15/
+!$OMP THREADPRIVATE(Tx, Tm)
+  REAL                                               :: aa, bb, dd, ddelta, discr
+  REAL                                               :: ff, fp
+  REAL                                               :: coefx, coefm, Zx, Zm, Ux, U, Um
+
+  IF (prt_level >= 10) THEN
+    print *,'cv3_undilute2.0. icvflag_Tpa, t(1,k), q(1,k), qs(1,k) ', &
+                        icvflag_Tpa, (k, t(1,k), q(1,k), qs(1,k), k = 1,nl)
+  ENDIF
+  smallestreal=tiny(smallestreal)
+
+! =====================================================================
+! --- SOME INITIALIZATIONS
+! =====================================================================
+
+  DO k = 1, nl
+    DO i = 1, ncum
+      qi(i, k) = 0.
+    END DO
+  END DO
+
+
+! =====================================================================
+! --- FIND THE REST OF THE LIFTED PARCEL TEMPERATURES
+! =====================================================================
+
+! ---       The procedure is to solve the equation.
+!                cp*tp+L*qp+phi=cp*tnk+L*qnk+gznk.
+
+! ***  Calculate certain parcel quantities, including static energy   ***
+
+
+  DO i = 1, ncum
+    ah0(i) = (cpd*(1.-qnk(i))+cl*qnk(i))*tnk(i)+ & 
+! debug          qnk(i)*(lv0-clmcpv*(tnk(i)-t0))+gznk(i)
+             qnk(i)*(lv0-clmcpv*(tnk(i)-273.15)) + gznk(i)
+  END DO
+!
+!  Ice fraction
+!
+  IF (cvflag_ice) THEN
+    DO k = minorig, nl
+      DO i = 1, ncum
+          frac(i, k) = (Tx - t(i,k))/(Tx - Tm)
+          frac(i, k) = min(max(frac(i,k),0.0), 1.0)
+      END DO
+    END DO
+! Below cloud base, set ice fraction to cloud base value
+    DO k = 1, nl
+      DO i = 1, ncum
+        IF (k<icb(i)) THEN
+          frac(i,k) = frac(i,icb(i))
+        END IF
+      END DO
+    END DO
+  ELSE
+    DO k = 1, nl
+      DO i = 1, ncum
+          frac(i,k) = 0.
+      END DO
+    END DO
+  ENDIF ! (cvflag_ice)
+
+
+  DO k = minorig, nl
+    DO i = 1,ncum
+      ha(i,k) = ah0(i)
+      hla(i,k) = hnk(i)
+      qta(i,k) = qnk(i)
+      qpreca(i,k) = 0.
+      frac_a(i,k) = 0.
+      frac_s(i,k) = frac(i,k)
+      qpl(i,k) = 0.
+      qps(i,k) = 0.
+      qhsat(i,k) = qs(i,k)
+      qcld(i,k) = max(qta(i,k)-qhsat(i,k),0.)
+      IF (k <= icb(i)+1) THEN
+        qhsat(i,k) = qnk(i)-clw(i,k)
+        qcld(i,k) = clw(i,k)
+      ENDIF 
+    ENDDO
+  ENDDO
+
+!jyg<
+! =====================================================================
+! --- SET THE THE FRACTION OF PRECIPITATION FALLING OUTSIDE OF CLOUD
+! =====================================================================
+  DO k = 1, nl
+    DO i = 1, ncum
+      ep(i, k) = 0.0
+      sigp(i, k) = spfac
+    END DO
+  END DO
+!>jyg
+!
+
+! ***  Find lifted parcel quantities above cloud base    ***
+
+!----------------------------------------------------------------------------
+!
+  IF (icvflag_Tpa == 2) THEN
+!
+!----------------------------------------------------------------------------
+!
+    DO k = minorig + 1, nl
+      DO i = 1,ncum
+        tp(i,k) = t(i,k)
+      ENDDO
+!!      alv = lv0 - clmcpv*(t(i,k)-273.15)
+!!      alf = lf0 + clmci*(t(i,k)-273.15)
+!!      als = alf + alv
+      DO j = 1,4
+        DO i = 1, ncum
+! ori	    if(k.ge.(icb(i)+1))then
+          IF (k>=(icbs(i)+1)) THEN                                ! convect3
+            tg = tp(i, k)
+            IF (tg .gt. Tx) THEN
+              es = 6.112*exp(17.67*(tg - 273.15)/(tg + 243.5 - 273.15))
+              qg = eps*es/(p(i,k)-es*(1.-eps))
+            ELSE
+              esi = exp(23.33086-(6111.72784/tg)+0.15215*log(tg))
+              qg = eps*esi/(p(i,k)-esi*(1.-eps))
+            ENDIF
+! Ice fraction
+            ff = 0.
+            fp = 1./(Tx - Tm)
+            IF (tg < Tx) THEN
+              IF (tg > Tm) THEN
+                ff = (Tx - tg)*fp
+              ELSE
+                ff = 1.
+              ENDIF ! (tg > Tm)
+            ENDIF ! (tg < Tx)
+! Intermediate variables
+            aa = cpd + (cl-cpd)*qnk(i) + lv(i,k)*lv(i,k)*qg/(rrv*tg*tg)
+            ahg = (cpd + (cl-cpd)*qnk(i))*tg + lv(i,k)*qg - &
+                  lf(i,k)*ff*(qnk(i) - qg) + gz(i,k)
+            dd = lf(i,k)*lv(i,k)*qg/(rrv*tg*tg)
+            ddelta = lf(i,k)*(qnk(i) - qg)
+            bb = aa + ddelta*fp + dd*fp*(Tx-tg)
+! Compute Zx and Zm
+            coefx = aa
+            coefm = aa + dd
+            IF (tg .gt. Tx) THEN
+              Zx = ahg            + coefx*(Tx - tg)
+              Zm = ahg - ddelta   + coefm*(Tm - tg)
+            ELSE
+              IF (tg .gt. Tm) THEN
+                Zx = ahg          + (coefx +fp*ddelta)*(Tx - Tg)
+                Zm = ahg          + (coefm +fp*ddelta)*(Tm - Tg)
+              ELSE
+                Zx = ahg + ddelta + coefx*(Tx - tg)
+                Zm = ahg          + coefm*(Tm - tg)
+              ENDIF ! (tg .gt. Tm)
+            ENDIF ! (tg .gt. Tx)
+! Compute the masks Um, U, Ux
+            Um = (sign(1., Zm-ah0(i))+1.)/2.
+            Ux = (sign(1., ah0(i)-Zx)+1.)/2.
+            U = (1. - Um)*(1. - Ux)
+! Compute the updated parcell temperature Tp : 3 cases depending on tg value
+            IF (tg .gt. Tx) THEN
+              discr = bb*bb - 4*dd*fp*(ah0(i) - ahg + ddelta*fp*(Tx-tg))
+              Tp(i,k) = tg + &
+                  Um*  (ah0(i) - ahg + ddelta)           /(aa + dd) + &
+                  U *2*(ah0(i) - ahg + ddelta*fp*(Tx-tg))/(bb + sqrt(discr)) + &
+                  Ux*  (ah0(i) - ahg)                    /aa
+            ELSEIF (tg .gt. Tm) THEN
+              discr = bb*bb - 4*dd*fp*(ah0(i) - ahg)
+              Tp(i,k) = tg + &
+                  Um*  (ah0(i) - ahg + ddelta*fp*(tg-Tm))/(aa + dd) + &
+                  U *2*(ah0(i) - ahg)                    /(bb + sqrt(discr)) + &
+                  Ux*  (ah0(i) - ahg + ddelta*fp*(tg-Tx))/aa
+            ELSE
+              discr = bb*bb - 4*dd*fp*(ah0(i) - ahg + ddelta*fp*(Tm-tg))
+              Tp(i,k) = tg + &
+                  Um*  (ah0(i) - ahg)                    /(aa + dd) + &
+                  U *2*(ah0(i) - ahg + ddelta*fp*(Tm-tg))/(bb + sqrt(discr)) + &
+                  Ux*  (ah0(i) - ahg - ddelta)           /aa
+            ENDIF ! (tg .gt. Tx)
+!
+!!     print *,' j, k, Um, U, Ux, aa, bb, discr, dd, ddelta ', j, k, Um, U, Ux, aa, bb, discr, dd, ddelta
+!!     print *,' j, k, ah0(i), ahg, tg, qg, tp(i,k), ff ', j, k, ah0(i), ahg, tg, qg, tp(i,k), ff
+          END IF ! (k>=(icbs(i)+1))
+        END DO ! i = 1, ncum
+      END DO ! j = 1,4
+      DO i = 1, ncum
+        IF (k>=(icbs(i)+1)) THEN                                ! convect3
+          tg = tp(i, k)
+          IF (tg .gt. Tx) THEN
+            es = 6.112*exp(17.67*(tg - 273.15)/(tg + 243.5 - 273.15))
+            qg = eps*es/(p(i,k)-es*(1.-eps))
+          ELSE
+            esi = exp(23.33086-(6111.72784/tg)+0.15215*log(tg))
+            qg = eps*esi/(p(i,k)-esi*(1.-eps))
+          ENDIF
+          clw(i, k) = qnk(i) - qg
+          clw(i, k) = max(0.0, clw(i,k))
+          tvp(i, k) = max(0., tp(i,k)*(1.+qg/eps-qnk(i)))
+! print*,tvp(i,k),'tvp'
+          IF (clw(i,k)<1.E-11) THEN
+            tp(i, k) = tv(i, k)
+            tvp(i, k) = tv(i, k)
+          END IF ! (clw(i,k)<1.E-11)
+        END IF ! (k>=(icbs(i)+1))
+      END DO ! i = 1, ncum
+    END DO ! k = minorig + 1, nl
+!----------------------------------------------------------------------------
+!
+  ELSE IF (icvflag_Tpa == 1) THEN  ! (icvflag_Tpa == 2)
+!
+!----------------------------------------------------------------------------
+!
+    DO k = minorig + 1, nl
+      DO i = 1,ncum
+        tp(i,k) = t(i,k)
+      ENDDO
+!!      alv = lv0 - clmcpv*(t(i,k)-273.15)
+!!      alf = lf0 + clmci*(t(i,k)-273.15)
+!!      als = alf + alv
+      DO j = 1,4
+        DO i = 1, ncum
+! ori	    if(k.ge.(icb(i)+1))then
+          IF (k>=(icbs(i)+1)) THEN                                ! convect3
+            tg = tp(i, k)
+            IF (tg .gt. Tx .OR. .NOT.cvflag_ice) THEN
+              es = 6.112*exp(17.67*(tg - 273.15)/(tg + 243.5 - 273.15))
+              qg = eps*es/(p(i,k)-es*(1.-eps))
+              dqgdT = lv(i,k)*qg/(rrv*tg*tg)
+            ELSE
+              esi = exp(23.33086-(6111.72784/tg)+0.15215*log(tg))
+              qg = eps*esi/(p(i,k)-esi*(1.-eps))
+              dqgdT = (lv(i,k)+lf(i,k))*qg/(rrv*tg*tg)
+            ENDIF
+            IF (qsat_depends_on_qt) THEN
+              dqgdT = dqgdT*(1.-qta(i,k-1))/(1.-qg)**2
+              qg = qg*(1.-qta(i,k-1))/(1.-qg)            
+            ENDIF
+            ahg = (cpd + (cl-cpd)*qta(i,k-1))*tg + lv(i,k)*qg - &
+                  lf(i,k)*frac(i,k)*(qta(i,k-1) - qg) + gz(i,k)
+            Tp(i,k) = tg + (ah0(i) - ahg)/ &
+                    (cpd + (cl-cpd)*qta(i,k-1) + (lv(i,k)+frac(i,k)*lf(i,k))*dqgdT)
+!!   print *,'undilute2 iterations k, Tp(i,k), ah0(i), ahg ', &
+!!                                 k, Tp(i,k), ah0(i), ahg
+          END IF ! (k>=(icbs(i)+1))
+        END DO ! i = 1, ncum
+      END DO ! j = 1,4
+      DO i = 1, ncum
+        IF (k>=(icbs(i)+1)) THEN                                ! convect3
+          tg = tp(i, k)
+          IF (tg .gt. Tx .OR. .NOT.cvflag_ice) THEN
+            es = 6.112*exp(17.67*(tg - 273.15)/(tg + 243.5 - 273.15))
+            qg = eps*es/(p(i,k)-es*(1.-eps))
+          ELSE
+            esi = exp(23.33086-(6111.72784/tg)+0.15215*log(tg))
+            qg = eps*esi/(p(i,k)-esi*(1.-eps))
+          ENDIF
+          IF (qsat_depends_on_qt) THEN
+            qg = qg*(1.-qta(i,k-1))/(1.-qg)            
+          ENDIF
+          qhsat(i,k) = qg
+        END IF ! (k>=(icbs(i)+1))
+      END DO ! i = 1, ncum
+      DO i = 1, ncum
+        IF (k>=(icbs(i)+1)) THEN                                ! convect3
+          clw(i, k) = qta(i,k-1) - qhsat(i,k)
+          clw(i, k) = max(0.0, clw(i,k))
+          tvp(i, k) = max(0., tp(i,k)*(1.+qhsat(i,k)/eps-qta(i,k-1)))
+! print*,tvp(i,k),'tvp'
+          IF (clw(i,k)<1.E-11) THEN
+            tp(i, k) = tv(i, k)
+            tvp(i, k) = tv(i, k)
+          END IF ! (clw(i,k)<1.E-11)
+        END IF ! (k>=(icbs(i)+1))
+      END DO ! i = 1, ncum
+!
+      IF (cvflag_prec_eject) THEN
+        DO i = 1, ncum
+          IF (k>=(icbs(i)+1)) THEN                                ! convect3
+!  Specific precipitation (liquid and solid) and ice content 
+!  before ejection of precipitation                                                     !!jygprl
+            elacrit = elcrit*min(max(1.-(tp(i,k)-T0)/Tlcrit, 0.), 1.)                   !!jygprl
+!!!!            qcld(i,k) = min(clw(i,k), elacrit)                                          !!jygprl
+            qhthreshold = elacrit*(1.-qta(i,k-1))/(1.-elacrit)
+            qcld(i,k) = min(clw(i,k), qhthreshold)             !!jygprl
+!!!!            phinu2p = max(qhsat(i,k-1) + qcld(i,k-1) - (qhsat(i,k) + qcld(i,k)),0.)   !!jygprl
+            phinu2p = max(clw(i,k) - max(qta(i,k-1) - qhsat(i,k-1), qhthreshold), 0.)
+            qpl(i,k) = qpl(i,k-1) + (1.-frac(i,k))*phinu2p                            !!jygprl
+            qps(i,k) = qps(i,k-1) + frac(i,k)     *phinu2p                            !!jygprl
+            qi(i,k) = (1.-ejectliq)*clw(i,k)*frac(i,k) + &                            !!jygprl
+                     ejectliq*(qps(i,k-1) + frac(i,k)*(phinu2p+qcld(i,k)))            !!jygprl
+!!
+!  =====================================================================================
+!  Ejection of precipitation from adiabatic ascents if requested (cvflag_prec_eject=True):
+!  Compute the steps of total water (qta), of moist static energy (ha), of specific 
+!  precipitation (qpl and qps) and of specific cloud water (qcld) associated with precipitation
+!   ejection.
+!  =====================================================================================
+!  
+!   Verif
+            qpreca(i,k) = ejectliq*qpl(i,k) + ejectice*qps(i,k)                                   !!jygprl
+            frac_a(i,k) = ejectice*qps(i,k)/max(qpreca(i,k),smallestreal)                         !!jygprl
+            frac_s(i,k) = (1.-ejectliq)*frac(i,k) + &                                             !!jygprl
+               ejectliq*(1. - (qpl(i,k)+(1.-frac(i,k))*qcld(i,k))/max(clw(i,k),smallestreal))     !!jygprl
+!          
+            denomm1 = 1./(1. - qpreca(i,k))
+!          
+            qta(i,k) = qta(i,k-1) - &
+                      qpreca(i,k)*(1.-qta(i,k-1))*denomm1
+            ha(i,k)  = ha(i,k-1) + &
+                      ( qpreca(i,k)*(-(1.-qta(i,k-1))*(cl-cpd)*tp(i,k) + &
+                                  lv(i,k)*qhsat(i,k) - lf(i,k)*(frac_s(i,k)*qcld(i,k)+qps(i,k))) + &
+                        lf(i,k)*ejectice*qps(i,k))*denomm1
+            hla(i,k) = hla(i,k-1) + &
+                      ( qpreca(i,k)*(-(1.-qta(i,k-1))*(cpv-cpd)*tp(i,k) - &
+                                  lv(i,k)*((1.-frac_s(i,k))*qcld(i,k)+qpl(i,k)) - &
+                                  (lv(i,k)+lf(i,k))*(frac_s(i,k)*qcld(i,k)+qps(i,k))) + &
+                        lv(i,k)*ejectliq*qpl(i,k) + (lv(i,k)+lf(i,k))*ejectice*qps(i,k))*denomm1
+            qpl(i,k) = qpl(i,k)*(1.-ejectliq)*denomm1
+            qps(i,k) = qps(i,k)*(1.-ejectice)*denomm1
+            qcld(i,k) = qcld(i,k)*denomm1
+            qhsat(i,k) = qhsat(i,k)*(1.-qta(i,k))/(1.-qta(i,k-1))
+         END IF ! (k>=(icbs(i)+1))
+        END DO ! i = 1, ncum
+      ENDIF  ! (cvflag_prec_eject)
+! 
+    END DO ! k = minorig + 1, nl
+!
+!----------------------------------------------------------------------------
+!
+  ELSE IF (icvflag_Tpa == 0) THEN! (icvflag_Tpa == 2) ELSE IF(icvflag_Tpa == 1)
+!
+!----------------------------------------------------------------------------
+!
+  DO k = minorig + 1, nl
+    DO i = 1, ncum
+! ori	    if(k.ge.(icb(i)+1))then
+      IF (k>=(icbs(i)+1)) THEN                                ! convect3
+        tg = t(i, k)
+        qg = qs(i, k)
+! debug	      alv=lv0-clmcpv*(t(i,k)-t0)
+        alv = lv0 - clmcpv*(t(i,k)-273.15)
+
+! First iteration.
+
+! ori	       s=cpd+alv*alv*qg/(rrv*t(i,k)*t(i,k))
+        s = cpd*(1.-qnk(i)) + cl*qnk(i) + &                   ! convect3
+            alv*alv*qg/(rrv*t(i,k)*t(i,k))                    ! convect3
+        s = 1./s
+! ori	       ahg=cpd*tg+(cl-cpd)*qnk(i)*t(i,k)+alv*qg+gz(i,k)
+        ahg = cpd*tg + (cl-cpd)*qnk(i)*tg + alv*qg + gz(i, k) ! convect3
+        tg = tg + s*(ah0(i)-ahg)
+! ori	       tg=max(tg,35.0)
+! debug	       tc=tg-t0
+        tc = tg - 273.15
+        denom = 243.5 + tc
+        denom = max(denom, 1.0)                               ! convect3
+! ori	       if(tc.ge.0.0)then
+        es = 6.112*exp(17.67*tc/denom)
+! ori	       else
+! ori			es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
+! ori	       endif
+        qg = eps*es/(p(i,k)-es*(1.-eps))
+
+! Second iteration.
+
+! ori	       s=cpd+alv*alv*qg/(rrv*t(i,k)*t(i,k))
+! ori	       s=1./s
+! ori	       ahg=cpd*tg+(cl-cpd)*qnk(i)*t(i,k)+alv*qg+gz(i,k)
+        ahg = cpd*tg + (cl-cpd)*qnk(i)*tg + alv*qg + gz(i, k) ! convect3
+        tg = tg + s*(ah0(i)-ahg)
+! ori	       tg=max(tg,35.0)
+! debug	       tc=tg-t0
+        tc = tg - 273.15
+        denom = 243.5 + tc
+        denom = max(denom, 1.0)                               ! convect3
+! ori	       if(tc.ge.0.0)then
+        es = 6.112*exp(17.67*tc/denom)
+! ori	       else
+! ori			es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
+! ori	       endif
+        qg = eps*es/(p(i,k)-es*(1.-eps))
+
+! debug	       alv=lv0-clmcpv*(t(i,k)-t0)
+        alv = lv0 - clmcpv*(t(i,k)-273.15)
+! print*,'cpd dans convect2 ',cpd
+! print*,'tp(i,k),ah0(i),cl,cpd,qnk(i),t(i,k),gz(i,k),alv,qg,cpd'
+! print*,tp(i,k),ah0(i),cl,cpd,qnk(i),t(i,k),gz(i,k),alv,qg,cpd
+
+! ori c approximation here:
+! ori        tp(i,k)=(ah0(i)-(cl-cpd)*qnk(i)*t(i,k)-gz(i,k)-alv*qg)/cpd
+
+! convect3: no approximation:
+        IF (cvflag_ice) THEN
+          tp(i, k) = max(0., (ah0(i)-gz(i,k)-alv*qg)/(cpd+(cl-cpd)*qnk(i)))
+        ELSE
+          tp(i, k) = (ah0(i)-gz(i,k)-alv*qg)/(cpd+(cl-cpd)*qnk(i))
+        END IF
+
+        clw(i, k) = qnk(i) - qg
+        clw(i, k) = max(0.0, clw(i,k))
+        rg = qg/(1.-qnk(i))
+! ori               tvp(i,k)=tp(i,k)*(1.+rg*epsi)
+! convect3: (qg utilise au lieu du vrai mixing ratio rg):
+        tvp(i, k) = tp(i, k)*(1.+qg/eps-qnk(i)) ! whole thing
+        IF (cvflag_ice) THEN
+          IF (clw(i,k)<1.E-11) THEN
+            tp(i, k) = tv(i, k)
+            tvp(i, k) = tv(i, k)
+          END IF
+        END IF
+!jyg<
+!!      END IF  ! Endif moved to the end of the loop
+!>jyg
+
+      IF (cvflag_ice) THEN
+!CR:attention boucle en klon dans Icefrac
+! Call Icefrac(t,clw,qi,nl,nloc)
+        IF (t(i,k)>263.15) THEN
+          qi(i, k) = 0.
+        ELSE
+          IF (t(i,k)<243.15) THEN
+            qi(i, k) = clw(i, k)
+          ELSE
+            fracg = (263.15-t(i,k))/20
+            qi(i, k) = clw(i, k)*fracg
+          END IF
+        END IF
+!CR: fin test
+        IF (t(i,k)<263.15) THEN
+!CR: on commente les calculs d'Arnaud car division par zero
+! nouveau calcul propose par JYG
+!       alv=lv0-clmcpv*(t(i,k)-273.15)
+!       alf=lf0-clmci*(t(i,k)-273.15)
+!       tg=tp(i,k)
+!       tc=tp(i,k)-273.15
+!       denom=243.5+tc
+!       do j=1,3
+! cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+! il faudra que esi vienne en argument de la convection
+! cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+!        tbis=t(i,k)+(tp(i,k)-tg)
+!        esi=exp(23.33086-(6111.72784/tbis) + &
+!                       0.15215*log(tbis))
+!        qsat_new=eps*esi/(p(i,k)-esi*(1.-eps))
+!        snew=cpd*(1.-qnk(i))+cl*qnk(i)+alv*alv*qsat_new/ &
+!                                       (rrv*tbis*tbis)
+!        snew=1./snew
+!        print*,esi,qsat_new,snew,'esi,qsat,snew'
+!        tp(i,k)=tg+(alf*qi(i,k)+alv*qg*(1.-(esi/es)))*snew
+!        print*,k,tp(i,k),qnk(i),'avec glace'
+!        print*,'tpNAN',tg,alf,qi(i,k),alv,qg,esi,es,snew
+!       enddo
+
+          alv = lv0 - clmcpv*(t(i,k)-273.15)
+          alf = lf0 + clmci*(t(i,k)-273.15)
+          als = alf + alv
+          tg = tp(i, k)
+          tp(i, k) = t(i, k)
+          DO j = 1, 3
+            esi = exp(23.33086-(6111.72784/tp(i,k))+0.15215*log(tp(i,k)))
+            qsat_new = eps*esi/(p(i,k)-esi*(1.-eps))
+            snew = cpd*(1.-qnk(i)) + cl*qnk(i) + alv*als*qsat_new/ &
+                                                 (rrv*tp(i,k)*tp(i,k))
+            snew = 1./snew
+! c             print*,esi,qsat_new,snew,'esi,qsat,snew'
+            tp(i, k) = tp(i, k) + &
+                       ((cpd*(1.-qnk(i))+cl*qnk(i))*(tg-tp(i,k)) + &
+                        alv*(qg-qsat_new)+alf*qi(i,k))*snew
+! print*,k,tp(i,k),qsat_new,qnk(i),qi(i,k), &
+!              'k,tp,q,qt,qi avec glace'
+          END DO
+
+!CR:reprise du code AJ
+          clw(i, k) = qnk(i) - qsat_new
+          clw(i, k) = max(0.0, clw(i,k))
+          tvp(i, k) = max(0., tp(i,k)*(1.+qsat_new/eps-qnk(i)))
+! print*,tvp(i,k),'tvp'
+        END IF
+        IF (clw(i,k)<1.E-11) THEN
+          tp(i, k) = tv(i, k)
+          tvp(i, k) = tv(i, k)
+        END IF
+      END IF ! (cvflag_ice)
+!jyg<
+      END IF ! (k>=(icbs(i)+1))
+!>jyg
+    END DO
+  END DO
+
+!----------------------------------------------------------------------------
+!
+  ENDIF ! (icvflag_Tpa == 2) ELSEIF (icvflag_Tpa == 1) ELSE (icvflag_Tpa == 0)
+!
+!----------------------------------------------------------------------------
+!
+! =====================================================================
+! --- SET THE PRECIPITATION EFFICIENCIES 
+! --- THESE MAY BE FUNCTIONS OF TP(I), P(I) AND CLW(I)
+! =====================================================================
+!
+  IF (flag_epkeorig/=1) THEN
+    DO k = 1, nl ! convect3
+      DO i = 1, ncum
+!jyg<
+       IF(k>=icb(i)) THEN
+!>jyg
+         pden = ptcrit - pbcrit
+         ep(i, k) = (plcl(i)-p(i,k)-pbcrit)/pden*epmax
+         ep(i, k) = max(ep(i,k), 0.0)
+         ep(i, k) = min(ep(i,k), epmax)
+!!         sigp(i, k) = spfac  ! jyg
+        ENDIF   ! (k>=icb(i))
+      END DO
+    END DO
+  ELSE
+    DO k = 1, nl
+      DO i = 1, ncum
+        IF(k>=icb(i)) THEN
+!!        IF (k>=(nk(i)+1)) THEN
+!>jyg
+          tca = tp(i, k) - t0
+          IF (tca>=0.0) THEN
+            elacrit = elcrit
+          ELSE
+            elacrit = elcrit*(1.0-tca/tlcrit)
+          END IF
+          elacrit = max(elacrit, 0.0)
+          ep(i, k) = 1.0 - elacrit/max(clw(i,k), 1.0E-8)
+          ep(i, k) = max(ep(i,k), 0.0)
+          ep(i, k) = min(ep(i,k), epmax)
+!!          sigp(i, k) = spfac  ! jyg
+        END IF  ! (k>=icb(i))
+      END DO
+    END DO
+  END IF
+!
+!   =========================================================================
+  IF (prt_level >= 10) THEN
+    print *,'cv3_undilute2.1. tp(1,k), tvp(1,k) ', &
+                          (k, tp(1,k), tvp(1,k), k = 1,nl)
+  ENDIF
+!
+! =====================================================================
+! --- CALCULATE VIRTUAL TEMPERATURE AND LIFTED PARCEL
+! --- VIRTUAL TEMPERATURE
+! =====================================================================
+
+! dans convect3, tvp est calcule en une seule fois, et sans retirer
+! l'eau condensee (~> reversible CAPE)
+
+! ori      do 340 k=minorig+1,nl
+! ori        do 330 i=1,ncum
+! ori        if(k.ge.(icb(i)+1))then
+! ori          tvp(i,k)=tvp(i,k)*(1.0-qnk(i)+ep(i,k)*clw(i,k))
+! oric         print*,'i,k,tvp(i,k),qnk(i),ep(i,k),clw(i,k)'
+! oric         print*, i,k,tvp(i,k),qnk(i),ep(i,k),clw(i,k)
+! ori        endif
+! ori 330    continue
+! ori 340  continue
+
+! ori      do 350 i=1,ncum
+! ori       tvp(i,nlp)=tvp(i,nl)-(gz(i,nlp)-gz(i,nl))/cpd
+! ori 350  continue
+
+  DO i = 1, ncum                                           ! convect3
+    tp(i, nlp) = tp(i, nl)                                 ! convect3
+  END DO                                                   ! convect3
+
+! =====================================================================
+! --- EFFECTIVE VERTICAL PROFILE OF BUOYANCY (convect3 only):
+! =====================================================================
+
+! -- this is for convect3 only:
+
+! first estimate of buoyancy:
+
+!jyg : k-loop outside i-loop (07042015)
+  DO k = 1, nl
+    DO i = 1, ncum
+      buoy(i, k) = tvp(i, k) - tv(i, k)
+    END DO
+  END DO
+
+! set buoyancy=buoybase for all levels below base
+! for safety, set buoy(icb)=buoybase
+
+!jyg : k-loop outside i-loop (07042015)
+  DO k = 1, nl
+    DO i = 1, ncum
+      IF ((k>=icb(i)) .AND. (k<=nl) .AND. (p(i,k)>=pbase(i))) THEN
+        buoy(i, k) = buoybase(i)
+      END IF
+    END DO
+  END DO
+  DO i = 1, ncum
+!    buoy(icb(i),k)=buoybase(i)
+    buoy(i, icb(i)) = buoybase(i)
+  END DO
+
+! -- end convect3
+
+! =====================================================================
+! --- FIND THE FIRST MODEL LEVEL (INB) ABOVE THE PARCEL'S
+! --- LEVEL OF NEUTRAL BUOYANCY
+! =====================================================================
+
+! -- this is for convect3 only:
+
+  DO i = 1, ncum
+    inb(i) = nl - 1
+    iposit(i) = nl
+  END DO
+
+
+! --    iposit(i) = first level, above icb, with positive buoyancy
+  DO k = 1, nl - 1
+    DO i = 1, ncum
+      IF (k>=icb(i) .AND. buoy(i,k)>0.) THEN
+        iposit(i) = min(iposit(i), k)
+      END IF
+    END DO
+  END DO
+
+  DO i = 1, ncum
+    IF (iposit(i)==nl) THEN
+      iposit(i) = icb(i)
+    END IF
+  END DO
+
+  DO k = 1, nl - 1
+    DO i = 1, ncum
+      IF ((k>=iposit(i)) .AND. (buoy(i,k)<dtovsh)) THEN
+        inb(i) = min(inb(i), k)
+      END IF
+    END DO
+  END DO
+
+!CR fix computation of inb
+!keep flag or modify in all cases?
+  IF (iflag_mix_adiab.eq.1) THEN
+  DO i = 1, ncum
+     cape(i)=0.
+     inb(i)=icb(i)+1
+  ENDDO
+  
+  DO k = 2, nl 
+    DO i = 1, ncum
+       IF ((k>=iposit(i))) THEN
+       deltap = min(plcl(i), ph(i,k-1)) - min(plcl(i), ph(i,k))
+       cape(i) = cape(i) + rrd*buoy(i, k-1)*deltap/p(i, k-1)
+       IF (cape(i).gt.0.) THEN
+        inb(i) = max(inb(i), k)
+       END IF
+       ENDIF
+    ENDDO
+  ENDDO
+
+!  DO i = 1, ncum
+!     print*,"inb",inb(i)
+!  ENDDO
+
+  endif
+
+! -- end convect3
+
+! ori      do 510 i=1,ncum
+! ori        cape(i)=0.0
+! ori        capem(i)=0.0
+! ori        inb(i)=icb(i)+1
+! ori        inb1(i)=inb(i)
+! ori 510  continue
+
+! Originial Code
+
+!    do 530 k=minorig+1,nl-1
+!     do 520 i=1,ncum
+!      if(k.ge.(icb(i)+1))then
+!       by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k)
+!       byp=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1)
+!       cape(i)=cape(i)+by
+!       if(by.ge.0.0)inb1(i)=k+1
+!       if(cape(i).gt.0.0)then
+!        inb(i)=k+1
+!        capem(i)=cape(i)
+!       endif
+!      endif
+!520    continue
+!530  continue
+!    do 540 i=1,ncum
+!     byp=(tvp(i,nl)-tv(i,nl))*dph(i,nl)/p(i,nl)
+!     cape(i)=capem(i)+byp
+!     defrac=capem(i)-cape(i)
+!     defrac=max(defrac,0.001)
+!     frac(i)=-cape(i)/defrac
+!     frac(i)=min(frac(i),1.0)
+!     frac(i)=max(frac(i),0.0)
+!540   continue
+
+!    K Emanuel fix
+
+!    call zilch(byp,ncum)
+!    do 530 k=minorig+1,nl-1
+!     do 520 i=1,ncum
+!      if(k.ge.(icb(i)+1))then
+!       by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k)
+!       cape(i)=cape(i)+by
+!       if(by.ge.0.0)inb1(i)=k+1
+!       if(cape(i).gt.0.0)then
+!        inb(i)=k+1
+!        capem(i)=cape(i)
+!        byp(i)=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1)
+!       endif
+!      endif
+!520    continue
+!530  continue
+!    do 540 i=1,ncum
+!     inb(i)=max(inb(i),inb1(i))
+!     cape(i)=capem(i)+byp(i)
+!     defrac=capem(i)-cape(i)
+!     defrac=max(defrac,0.001)
+!     frac(i)=-cape(i)/defrac
+!     frac(i)=min(frac(i),1.0)
+!     frac(i)=max(frac(i),0.0)
+!540   continue
+
+! J Teixeira fix
+
+! ori      call zilch(byp,ncum)
+! ori      do 515 i=1,ncum
+! ori        lcape(i)=.true.
+! ori 515  continue
+! ori      do 530 k=minorig+1,nl-1
+! ori        do 520 i=1,ncum
+! ori          if(cape(i).lt.0.0)lcape(i)=.false.
+! ori          if((k.ge.(icb(i)+1)).and.lcape(i))then
+! ori            by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k)
+! ori            byp(i)=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1)
+! ori            cape(i)=cape(i)+by
+! ori            if(by.ge.0.0)inb1(i)=k+1
+! ori            if(cape(i).gt.0.0)then
+! ori              inb(i)=k+1
+! ori              capem(i)=cape(i)
+! ori            endif
+! ori          endif
+! ori 520    continue
+! ori 530  continue
+! ori      do 540 i=1,ncum
+! ori          cape(i)=capem(i)+byp(i)
+! ori          defrac=capem(i)-cape(i)
+! ori          defrac=max(defrac,0.001)
+! ori          frac(i)=-cape(i)/defrac
+! ori          frac(i)=min(frac(i),1.0)
+! ori          frac(i)=max(frac(i),0.0)
+! ori 540  continue
+
+! --------------------------------------------------------------------
+!   Prevent convection when top is too hot
+! --------------------------------------------------------------------
+  DO i = 1,ncum
+    IF (t(i,inb(i)) > T_top_max) iflag(i) = 10
+  ENDDO
+
+! =====================================================================
+! ---   CALCULATE LIQUID WATER STATIC ENERGY OF LIFTED PARCEL
+! =====================================================================
+
+  DO k = 1, nl
+    DO i = 1, ncum
+      hp(i, k) = h(i, k)
+    END DO
+  END DO
+
+!jyg : cvflag_ice test outside the loops (07042015)
+!
+  IF (cvflag_ice) THEN
+!
+  IF (cvflag_prec_eject) THEN
+!!    DO k = minorig + 1, nl
+!!      DO i = 1, ncum
+!!        IF ((k>=icb(i)) .AND. (k<=inb(i))) THEN
+!!          frac_s(i,k) = qi(i,k)/max(clw(i,k),smallestreal)    
+!!          frac_s(i,k) = 1. - (qpl(i,k)+(1.-frac_s(i,k))*qcld(i,k))/max(clw(i,k),smallestreal)    
+!!        END IF
+!!      END DO
+!!    END DO
+  ELSE    ! (cvflag_prec_eject)
+    DO k = minorig + 1, nl
+      DO i = 1, ncum
+        IF ((k>=icb(i)) .AND. (k<=inb(i))) THEN
+!jyg< frac computation moved to beginning of cv3_undilute2.
+!     kept here for compatibility test with CMip6 version
+          frac_s(i, k) = 1. - (t(i,k)-243.15)/(263.15-243.15)
+          frac_s(i, k) = min(max(frac_s(i,k),0.0), 1.0)
+        END IF
+      END DO
+    END DO
+  ENDIF  ! (cvflag_prec_eject) ELSE
+    DO k = minorig + 1, nl
+      DO i = 1, ncum
+        IF ((k>=icb(i)) .AND. (k<=inb(i))) THEN
+!!          hp(i, k) = hnk(i) + (lv(i,k)+(cpd-cpv)*t(i,k)+frac_s(i,k)*lf(i,k))* &     !!jygprl
+!!                              ep(i, k)*clw(i, k)                                    !!jygprl
+          hp(i, k) = hla(i,k-1) + (lv(i,k)+(cpd-cpv)*t(i,k)+frac_s(i,k)*lf(i,k))* &   !!jygprl
+                              ep(i, k)*clw(i, k)                                      !!jygprl
+        END IF
+      END DO
+    END DO
+!
+  ELSE   ! (cvflag_ice)
+!
+    DO k = minorig + 1, nl
+      DO i = 1, ncum
+        IF ((k>=icb(i)) .AND. (k<=inb(i))) THEN
+!jyg<   (energy conservation tests)
+!!          hp(i, k) = hnk(i) + (lv(i,k)+(cpd-cpv)*tp(i,k))*ep(i, k)*clw(i, k)
+!!          hp(i, k) = ( hnk(i) + (lv(i,k)+(cpd-cpv)*t(i,k))*ep(i, k)*clw(i, k) ) / &
+!!                     (1. - ep(i,k)*clw(i,k))
+!!          hp(i, k) = ( hnk(i) + (lv(i,k)+(cpd-cl)*t(i,k))*ep(i, k)*clw(i, k) ) / &
+!!                     (1. - ep(i,k)*clw(i,k))
+          hp(i, k) = hnk(i) + (lv(i,k)+(cpd-cpv)*t(i,k))*ep(i, k)*clw(i, k)
+        END IF
+      END DO
+    END DO
+!
+  END IF  ! (cvflag_ice)
+
+  RETURN
+END SUBROUTINE cv3_undilute2
+
+SUBROUTINE cv3_closure(nloc, ncum, nd, icb, inb, &
+                       pbase, p, ph, tv, buoy, &
+                       sig, w0, cape, m, iflag)
+  IMPLICIT NONE
+
+! ===================================================================
+! ---  CLOSURE OF CONVECT3
+!
+! vectorization: S. Bony
+! ===================================================================
+
+  include "cvthermo.h"
+  include "cv3param.h"
+
+!input:
+  INTEGER ncum, nd, nloc
+  INTEGER icb(nloc), inb(nloc)
+  REAL pbase(nloc)
+  REAL p(nloc, nd), ph(nloc, nd+1)
+  REAL tv(nloc, nd), buoy(nloc, nd)
+
+!input/output:
+  REAL sig(nloc, nd), w0(nloc, nd)
+  INTEGER iflag(nloc)
+
+!output:
+  REAL cape(nloc)
+  REAL m(nloc, nd)
+
+!local variables:
+  INTEGER i, j, k, icbmax
+  REAL deltap, fac, w, amu
+  REAL dtmin(nloc, nd), sigold(nloc, nd)
+  REAL cbmflast(nloc)
+
+
+! -------------------------------------------------------
+! -- Initialization
+! -------------------------------------------------------
+
+  DO k = 1, nl
+    DO i = 1, ncum
+      m(i, k) = 0.0
+    END DO
+  END DO
+
+! -------------------------------------------------------
+! -- Reset sig(i) and w0(i) for i>inb and i<icb
+! -------------------------------------------------------
+
+! update sig and w0 above LNB:
+
+  DO k = 1, nl - 1
+    DO i = 1, ncum
+      IF ((inb(i)<(nl-1)) .AND. (k>=(inb(i)+1))) THEN
+        sig(i, k) = beta*sig(i, k) + &
+                    2.*alpha*buoy(i, inb(i))*abs(buoy(i,inb(i)))
+        sig(i, k) = amax1(sig(i,k), 0.0)
+        w0(i, k) = beta*w0(i, k)
+      END IF
+    END DO
+  END DO
+
+! compute icbmax:
+
+  icbmax = 2
+  DO i = 1, ncum
+    icbmax = max(icbmax, icb(i))
+  END DO
+
+! update sig and w0 below cloud base:
+
+  DO k = 1, icbmax
+    DO i = 1, ncum
+      IF (k<=icb(i)) THEN
+        sig(i, k) = beta*sig(i, k) - &
+                    2.*alpha*buoy(i, icb(i))*buoy(i, icb(i))
+        sig(i, k) = max(sig(i,k), 0.0)
+        w0(i, k) = beta*w0(i, k)
+      END IF
+    END DO
+  END DO
+
+!!      if(inb.lt.(nl-1))then
+!!         do 85 i=inb+1,nl-1
+!!            sig(i)=beta*sig(i)+2.*alpha*buoy(inb)*
+!!     1              abs(buoy(inb))
+!!            sig(i)=max(sig(i),0.0)
+!!            w0(i)=beta*w0(i)
+!!   85    continue
+!!      end if
+
+!!      do 87 i=1,icb
+!!         sig(i)=beta*sig(i)-2.*alpha*buoy(icb)*buoy(icb)
+!!         sig(i)=max(sig(i),0.0)
+!!         w0(i)=beta*w0(i)
+!!   87 continue
+
+! -------------------------------------------------------------
+! -- Reset fractional areas of updrafts and w0 at initial time
+! -- and after 10 time steps of no convection
+! -------------------------------------------------------------
+
+  DO k = 1, nl - 1
+    DO i = 1, ncum
+      IF (sig(i,nd)<1.5 .OR. sig(i,nd)>12.0) THEN
+        sig(i, k) = 0.0
+        w0(i, k) = 0.0
+      END IF
+    END DO
+  END DO
+
+! -------------------------------------------------------------
+! -- Calculate convective available potential energy (cape),
+! -- vertical velocity (w), fractional area covered by
+! -- undilute updraft (sig), and updraft mass flux (m)
+! -------------------------------------------------------------
+
+  DO i = 1, ncum
+    cape(i) = 0.0
+  END DO
+
+! compute dtmin (minimum buoyancy between ICB and given level k):
+
+  DO i = 1, ncum
+    DO k = 1, nl
+      dtmin(i, k) = 100.0
+    END DO
+  END DO
+
+  DO i = 1, ncum
+    DO k = 1, nl
+      DO j = minorig, nl
+        IF ((k>=(icb(i)+1)) .AND. (k<=inb(i)) .AND. (j>=icb(i)) .AND. (j<=(k-1))) THEN
+          dtmin(i, k) = amin1(dtmin(i,k), buoy(i,j))
+        END IF
+      END DO
+    END DO
+  END DO
+
+! the interval on which cape is computed starts at pbase :
+
+  DO k = 1, nl
+    DO i = 1, ncum
+
+      IF ((k>=(icb(i)+1)) .AND. (k<=inb(i))) THEN
+
+        deltap = min(pbase(i), ph(i,k-1)) - min(pbase(i), ph(i,k))
+        cape(i) = cape(i) + rrd*buoy(i, k-1)*deltap/p(i, k-1)
+        cape(i) = amax1(0.0, cape(i))
+        sigold(i, k) = sig(i, k)
+
+! dtmin(i,k)=100.0
+! do 97 j=icb(i),k-1 ! mauvaise vectorisation
+! dtmin(i,k)=AMIN1(dtmin(i,k),buoy(i,j))
+! 97     continue
+
+        sig(i, k) = beta*sig(i, k) + alpha*dtmin(i, k)*abs(dtmin(i,k))
+        sig(i, k) = max(sig(i,k), 0.0)
+        sig(i, k) = amin1(sig(i,k), 0.01)
+        fac = amin1(((dtcrit-dtmin(i,k))/dtcrit), 1.0)
+        w = (1.-beta)*fac*sqrt(cape(i)) + beta*w0(i, k)
+        amu = 0.5*(sig(i,k)+sigold(i,k))*w
+        m(i, k) = amu*0.007*p(i, k)*(ph(i,k)-ph(i,k+1))/tv(i, k)
+        w0(i, k) = w
+      END IF
+
+    END DO
+  END DO
+
+  DO i = 1, ncum
+    w0(i, icb(i)) = 0.5*w0(i, icb(i)+1)
+    m(i, icb(i)) = 0.5*m(i, icb(i)+1)*(ph(i,icb(i))-ph(i,icb(i)+1))/(ph(i,icb(i)+1)-ph(i,icb(i)+2))
+    sig(i, icb(i)) = sig(i, icb(i)+1)
+    sig(i, icb(i)-1) = sig(i, icb(i))
+  END DO
+
+! ccc 3. Compute final cloud base mass flux and set iflag to 3 if
+! ccc    cloud base mass flux is exceedingly small and is decreasing (i.e. if
+! ccc    the final mass flux (cbmflast) is greater than the target mass flux
+! ccc    (cbmf) ??).
+! cc
+! c      do i = 1,ncum
+! c       cbmflast(i) = 0.
+! c      enddo
+! cc
+! c      do k= 1,nl
+! c       do i = 1,ncum
+! c        IF (k .ge. icb(i) .and. k .le. inb(i)) THEN
+! c         cbmflast(i) = cbmflast(i)+M(i,k)
+! c        ENDIF
+! c       enddo
+! c      enddo
+! cc
+! c      do i = 1,ncum
+! c       IF (cbmflast(i) .lt. 1.e-6) THEN
+! c         iflag(i) = 3
+! c       ENDIF
+! c      enddo
+! cc
+! c      do k= 1,nl
+! c       do i = 1,ncum
+! c        IF (iflag(i) .ge. 3) THEN
+! c         M(i,k) = 0.
+! c         sig(i,k) = 0.
+! c         w0(i,k) = 0.
+! c        ENDIF
+! c       enddo
+! c      enddo
+! cc
+!!      cape=0.0
+!!      do 98 i=icb+1,inb
+!!         deltap = min(pbase,ph(i-1))-min(pbase,ph(i))
+!!         cape=cape+rrd*buoy(i-1)*deltap/p(i-1)
+!!         dcape=rrd*buoy(i-1)*deltap/p(i-1)
+!!         dlnp=deltap/p(i-1)
+!!         cape=max(0.0,cape)
+!!         sigold=sig(i)
+
+!!         dtmin=100.0
+!!         do 97 j=icb,i-1
+!!            dtmin=amin1(dtmin,buoy(j))
+!!   97    continue
+
+!!         sig(i)=beta*sig(i)+alpha*dtmin*abs(dtmin)
+!!         sig(i)=max(sig(i),0.0)
+!!         sig(i)=amin1(sig(i),0.01)
+!!         fac=amin1(((dtcrit-dtmin)/dtcrit),1.0)
+!!         w=(1.-beta)*fac*sqrt(cape)+beta*w0(i)
+!!         amu=0.5*(sig(i)+sigold)*w
+!!         m(i)=amu*0.007*p(i)*(ph(i)-ph(i+1))/tv(i)
+!!         w0(i)=w
+!!   98 continue
+!!      w0(icb)=0.5*w0(icb+1)
+!!      m(icb)=0.5*m(icb+1)*(ph(icb)-ph(icb+1))/(ph(icb+1)-ph(icb+2))
+!!      sig(icb)=sig(icb+1)
+!!      sig(icb-1)=sig(icb)
+
+  RETURN
+END SUBROUTINE cv3_closure
+
+SUBROUTINE cv3_mixing(nloc, ncum, nd, na, ntra, icb, nk, inb, &
+                      ph, t, rr, rs, u, v, tra, h, lv, lf, frac, qnk, &
+                      unk, vnk, hp, tv, tvp, ep, clw, m, sig, &
+                      ment, qent, uent, vent, nent, sij, elij, ments, qents, traent)
+  IMPLICIT NONE
+
+! ---------------------------------------------------------------------
+! a faire:
+! - vectorisation de la partie normalisation des flux (do 789...)
+! ---------------------------------------------------------------------
+
+  include "cvthermo.h"
+  include "cv3param.h"
+  include "cvflag.h"
+
+!inputs:
+  INTEGER, INTENT (IN)                               :: ncum, nd, na, ntra, nloc
+  INTEGER, DIMENSION (nloc), INTENT (IN)             :: icb, inb, nk
+  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: sig
+  REAL, DIMENSION (nloc), INTENT (IN)                :: qnk, unk, vnk
+  REAL, DIMENSION (nloc, nd+1), INTENT (IN)          :: ph
+  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: t, rr, rs
+  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: u, v
+  REAL, DIMENSION (nloc, nd, ntra), INTENT (IN)      :: tra               ! input of convect3
+  REAL, DIMENSION (nloc, na), INTENT (IN)            :: lv, h, hp
+  REAL, DIMENSION (nloc, na), INTENT (IN)            :: lf, frac
+  REAL, DIMENSION (nloc, na), INTENT (IN)            :: tv, tvp, ep, clw
+  REAL, DIMENSION (nloc, na), INTENT (IN)            :: m                 ! input of convect3
+
+!outputs:
+  REAL, DIMENSION (nloc, na, na), INTENT (OUT)        :: ment, qent
+  REAL, DIMENSION (nloc, na, na), INTENT (OUT)        :: uent, vent
+  REAL, DIMENSION (nloc, na, na), INTENT (OUT)        :: sij, elij
+  REAL, DIMENSION (nloc, nd, nd, ntra), INTENT (OUT)  :: traent
+  REAL, DIMENSION (nloc, nd, nd), INTENT (OUT)        :: ments, qents
+  INTEGER, DIMENSION (nloc, nd), INTENT (OUT)         :: nent
+
+!local variables:
+  INTEGER i, j, k, il, im, jm
+  INTEGER num1, num2
+  REAL rti, bf2, anum, denom, dei, altem, cwat, stemp, qp
+  REAL alt, smid, sjmin, sjmax, delp, delm
+  REAL asij(nloc), smax(nloc), scrit(nloc)
+  REAL asum(nloc, nd), bsum(nloc, nd), csum(nloc, nd)
+  REAL sigij(nloc, nd, nd)
+  REAL wgh
+  REAL zm(nloc, na)
+  LOGICAL lwork(nloc)
+
+! =====================================================================
+! --- INITIALIZE VARIOUS ARRAYS USED IN THE COMPUTATIONS
+! =====================================================================
+
+! ori        do 360 i=1,ncum*nlp
+  DO j = 1, nl
+    DO i = 1, ncum
+      nent(i, j) = 0
+! in convect3, m is computed in cv3_closure
+! ori          m(i,1)=0.0
+    END DO
+  END DO
+
+! ori      do 400 k=1,nlp
+! ori       do 390 j=1,nlp
+  DO j = 1, nl
+    DO k = 1, nl
+      DO i = 1, ncum
+        qent(i, k, j) = rr(i, j)
+        uent(i, k, j) = u(i, j)
+        vent(i, k, j) = v(i, j)
+        elij(i, k, j) = 0.0
+!ym            ment(i,k,j)=0.0
+!ym            sij(i,k,j)=0.0
+      END DO
+    END DO
+  END DO
+
+!ym
+  ment(1:ncum, 1:nd, 1:nd) = 0.0
+  sij(1:ncum, 1:nd, 1:nd) = 0.0
+
+!AC!      do k=1,ntra
+!AC!       do j=1,nd  ! instead nlp
+!AC!        do i=1,nd ! instead nlp
+!AC!         do il=1,ncum
+!AC!            traent(il,i,j,k)=tra(il,j,k)
+!AC!         enddo
+!AC!        enddo
+!AC!       enddo
+!AC!      enddo
+  zm(:, :) = 0.
+
+! =====================================================================
+! --- CALCULATE ENTRAINED AIR MASS FLUX (ment), TOTAL WATER MIXING
+! --- RATIO (QENT), TOTAL CONDENSED WATER (elij), AND MIXING
+! --- FRACTION (sij)
+! =====================================================================
+
+  DO i = minorig + 1, nl
+
+    DO j = minorig, nl
+      DO il = 1, ncum
+        IF ((i>=icb(il)) .AND. (i<=inb(il)) .AND. (j>=(icb(il)-1)) .AND. (j<=inb(il))) THEN
+
+          rti = qnk(il) - ep(il, i)*clw(il, i)
+          bf2 = 1. + lv(il, j)*lv(il, j)*rs(il, j)/(rrv*t(il,j)*t(il,j)*cpd)
+
+
+          IF (cvflag_ice) THEN
+! print*,cvflag_ice,'cvflag_ice dans do 700'
+            IF (t(il,j)<=263.15) THEN
+              bf2 = 1. + (lf(il,j)+lv(il,j))*(lv(il,j)+frac(il,j)* &
+                   lf(il,j))*rs(il, j)/(rrv*t(il,j)*t(il,j)*cpd)
+            END IF
+          END IF
+
+          anum = h(il, j) - hp(il, i) + (cpv-cpd)*t(il, j)*(rti-rr(il,j))
+          denom = h(il, i) - hp(il, i) + (cpd-cpv)*(rr(il,i)-rti)*t(il, j)
+          dei = denom
+          IF (abs(dei)<0.01) dei = 0.01
+          sij(il, i, j) = anum/dei
+          sij(il, i, i) = 1.0
+          altem = sij(il, i, j)*rr(il, i) + (1.-sij(il,i,j))*rti - rs(il, j)
+          altem = altem/bf2
+          cwat = clw(il, j)*(1.-ep(il,j))
+          stemp = sij(il, i, j)
+          IF ((stemp<0.0 .OR. stemp>1.0 .OR. altem>cwat) .AND. j>i) THEN
+
+            IF (cvflag_ice) THEN
+              anum = anum - (lv(il,j)+frac(il,j)*lf(il,j))*(rti-rs(il,j)-cwat*bf2)
+              denom = denom + (lv(il,j)+frac(il,j)*lf(il,j))*(rr(il,i)-rti)
+            ELSE
+              anum = anum - lv(il, j)*(rti-rs(il,j)-cwat*bf2)
+              denom = denom + lv(il, j)*(rr(il,i)-rti)
+            END IF
+
+            IF (abs(denom)<0.01) denom = 0.01
+            sij(il, i, j) = anum/denom
+            altem = sij(il, i, j)*rr(il, i) + (1.-sij(il,i,j))*rti - rs(il, j)
+            altem = altem - (bf2-1.)*cwat
+          END IF
+          IF (sij(il,i,j)>0.0 .AND. sij(il,i,j)<0.95) THEN
+            qent(il, i, j) = sij(il, i, j)*rr(il, i) + (1.-sij(il,i,j))*rti
+            uent(il, i, j) = sij(il, i, j)*u(il, i) + (1.-sij(il,i,j))*unk(il)
+            vent(il, i, j) = sij(il, i, j)*v(il, i) + (1.-sij(il,i,j))*vnk(il)
+!!!!      do k=1,ntra
+!!!!      traent(il,i,j,k)=sij(il,i,j)*tra(il,i,k)
+!!!!     :      +(1.-sij(il,i,j))*tra(il,nk(il),k)
+!!!!      end do
+            elij(il, i, j) = altem
+            elij(il, i, j) = max(0.0, elij(il,i,j))
+            ment(il, i, j) = m(il, i)/(1.-sij(il,i,j))
+            nent(il, i) = nent(il, i) + 1
+          END IF
+          sij(il, i, j) = max(0.0, sij(il,i,j))
+          sij(il, i, j) = amin1(1.0, sij(il,i,j))
+        END IF ! new
+      END DO
+    END DO
+
+!AC!       do k=1,ntra
+!AC!        do j=minorig,nl
+!AC!         do il=1,ncum
+!AC!          if( (i.ge.icb(il)).and.(i.le.inb(il)).and.
+!AC!     :       (j.ge.(icb(il)-1)).and.(j.le.inb(il)))then
+!AC!            traent(il,i,j,k)=sij(il,i,j)*tra(il,i,k)
+!AC!     :            +(1.-sij(il,i,j))*tra(il,nk(il),k)
+!AC!          endif
+!AC!         enddo
+!AC!        enddo
+!AC!       enddo
+
+
+! ***   if no air can entrain at level i assume that updraft detrains  ***
+! ***   at that level and calculate detrained air flux and properties  ***
+
+
+! @      do 170 i=icb(il),inb(il)
+
+    DO il = 1, ncum
+      IF ((i>=icb(il)) .AND. (i<=inb(il)) .AND. (nent(il,i)==0)) THEN
+! @      if(nent(il,i).eq.0)then
+        ment(il, i, i) = m(il, i)
+        qent(il, i, i) = qnk(il) - ep(il, i)*clw(il, i)
+        uent(il, i, i) = unk(il)
+        vent(il, i, i) = vnk(il)
+        elij(il, i, i) = clw(il, i)
+! MAF      sij(il,i,i)=1.0
+        sij(il, i, i) = 0.0
+      END IF
+    END DO
+  END DO
+
+!AC!      do j=1,ntra
+!AC!       do i=minorig+1,nl
+!AC!        do il=1,ncum
+!AC!         if (i.ge.icb(il) .and. i.le.inb(il) .and. nent(il,i).eq.0) then
+!AC!          traent(il,i,i,j)=tra(il,nk(il),j)
+!AC!         endif
+!AC!        enddo
+!AC!       enddo
+!AC!      enddo
+
+  DO j = minorig, nl
+    DO i = minorig, nl
+      DO il = 1, ncum
+        IF ((j>=(icb(il)-1)) .AND. (j<=inb(il)) .AND. (i>=icb(il)) .AND. (i<=inb(il))) THEN
+          sigij(il, i, j) = sij(il, i, j)
+        END IF
+      END DO
+    END DO
+  END DO
+! @      enddo
+
+! @170   continue
+
+! =====================================================================
+! ---  NORMALIZE ENTRAINED AIR MASS FLUXES
+! ---  TO REPRESENT EQUAL PROBABILITIES OF MIXING
+! =====================================================================
+
+  CALL zilch(asum, nloc*nd)
+  CALL zilch(csum, nloc*nd)
+  CALL zilch(csum, nloc*nd)
+
+  DO il = 1, ncum
+    lwork(il) = .FALSE.
+  END DO
+
+  DO i = minorig + 1, nl
+
+    num1 = 0
+    DO il = 1, ncum
+      IF (i>=icb(il) .AND. i<=inb(il)) num1 = num1 + 1
+    END DO
+    IF (num1<=0) GO TO 789
+
+
+    DO il = 1, ncum
+      IF (i>=icb(il) .AND. i<=inb(il)) THEN
+        lwork(il) = (nent(il,i)/=0)
+        qp = qnk(il) - ep(il, i)*clw(il, i)
+
+        IF (cvflag_ice) THEN
+
+          anum = h(il, i) - hp(il, i) - (lv(il,i)+frac(il,i)*lf(il,i))* &
+                       (qp-rs(il,i)) + (cpv-cpd)*t(il, i)*(qp-rr(il,i))
+          denom = h(il, i) - hp(il, i) + (lv(il,i)+frac(il,i)*lf(il,i))* &
+                       (rr(il,i)-qp) + (cpd-cpv)*t(il, i)*(rr(il,i)-qp)
+        ELSE
+
+          anum = h(il, i) - hp(il, i) - lv(il, i)*(qp-rs(il,i)) + &
+                       (cpv-cpd)*t(il, i)*(qp-rr(il,i))
+          denom = h(il, i) - hp(il, i) + lv(il, i)*(rr(il,i)-qp) + &
+                       (cpd-cpv)*t(il, i)*(rr(il,i)-qp)
+        END IF
+
+        IF (abs(denom)<0.01) denom = 0.01
+        scrit(il) = anum/denom
+        alt = qp - rs(il, i) + scrit(il)*(rr(il,i)-qp)
+        IF (scrit(il)<=0.0 .OR. alt<=0.0) scrit(il) = 1.0
+        smax(il) = 0.0
+        asij(il) = 0.0
+      END IF
+    END DO
+
+    DO j = nl, minorig, -1
+
+      num2 = 0
+      DO il = 1, ncum
+        IF (i>=icb(il) .AND. i<=inb(il) .AND. &
+            j>=(icb(il)-1) .AND. j<=inb(il) .AND. &
+            lwork(il)) num2 = num2 + 1
+      END DO
+      IF (num2<=0) GO TO 175
+
+      DO il = 1, ncum
+        IF (i>=icb(il) .AND. i<=inb(il) .AND. &
+            j>=(icb(il)-1) .AND. j<=inb(il) .AND. &
+            lwork(il)) THEN
+
+          IF (sij(il,i,j)>1.0E-16 .AND. sij(il,i,j)<0.95) THEN
+            wgh = 1.0
+            IF (j>i) THEN
+              sjmax = max(sij(il,i,j+1), smax(il))
+              sjmax = amin1(sjmax, scrit(il))
+              smax(il) = max(sij(il,i,j), smax(il))
+              sjmin = max(sij(il,i,j-1), smax(il))
+              sjmin = amin1(sjmin, scrit(il))
+              IF (sij(il,i,j)<(smax(il)-1.0E-16)) wgh = 0.0
+              smid = amin1(sij(il,i,j), scrit(il))
+            ELSE
+              sjmax = max(sij(il,i,j+1), scrit(il))
+              smid = max(sij(il,i,j), scrit(il))
+              sjmin = 0.0
+              IF (j>1) sjmin = sij(il, i, j-1)
+              sjmin = max(sjmin, scrit(il))
+            END IF
+            delp = abs(sjmax-smid)
+            delm = abs(sjmin-smid)
+            asij(il) = asij(il) + wgh*(delp+delm)
+            ment(il, i, j) = ment(il, i, j)*(delp+delm)*wgh
+          END IF
+        END IF
+      END DO
+
+175 END DO
+
+    DO il = 1, ncum
+      IF (i>=icb(il) .AND. i<=inb(il) .AND. lwork(il)) THEN
+        asij(il) = max(1.0E-16, asij(il))
+        asij(il) = 1.0/asij(il)
+        asum(il, i) = 0.0
+        bsum(il, i) = 0.0
+        csum(il, i) = 0.0
+      END IF
+    END DO
+
+    DO j = minorig, nl
+      DO il = 1, ncum
+        IF (i>=icb(il) .AND. i<=inb(il) .AND. lwork(il) .AND. &
+            j>=(icb(il)-1) .AND. j<=inb(il)) THEN
+          ment(il, i, j) = ment(il, i, j)*asij(il)
+        END IF
+      END DO
+    END DO
+
+    DO j = minorig, nl
+      DO il = 1, ncum
+        IF (i>=icb(il) .AND. i<=inb(il) .AND. lwork(il) .AND. &
+            j>=(icb(il)-1) .AND. j<=inb(il)) THEN
+          asum(il, i) = asum(il, i) + ment(il, i, j)
+          ment(il, i, j) = ment(il, i, j)*sig(il, j)
+          bsum(il, i) = bsum(il, i) + ment(il, i, j)
+        END IF
+      END DO
+    END DO
+
+    DO il = 1, ncum
+      IF (i>=icb(il) .AND. i<=inb(il) .AND. lwork(il)) THEN
+        bsum(il, i) = max(bsum(il,i), 1.0E-16)
+        bsum(il, i) = 1.0/bsum(il, i)
+      END IF
+    END DO
+
+    DO j = minorig, nl
+      DO il = 1, ncum
+        IF (i>=icb(il) .AND. i<=inb(il) .AND. lwork(il) .AND. &
+            j>=(icb(il)-1) .AND. j<=inb(il)) THEN
+          ment(il, i, j) = ment(il, i, j)*asum(il, i)*bsum(il, i)
+        END IF
+      END DO
+    END DO
+
+    DO j = minorig, nl
+      DO il = 1, ncum
+        IF (i>=icb(il) .AND. i<=inb(il) .AND. lwork(il) .AND. &
+            j>=(icb(il)-1) .AND. j<=inb(il)) THEN
+          csum(il, i) = csum(il, i) + ment(il, i, j)
+        END IF
+      END DO
+    END DO
+
+    DO il = 1, ncum
+      IF (i>=icb(il) .AND. i<=inb(il) .AND. lwork(il) .AND. &
+          csum(il,i)<m(il,i)) THEN
+        nent(il, i) = 0
+        ment(il, i, i) = m(il, i)
+        qent(il, i, i) = qnk(il) - ep(il, i)*clw(il, i)
+        uent(il, i, i) = unk(il)
+        vent(il, i, i) = vnk(il)
+        elij(il, i, i) = clw(il, i)
+! MAF        sij(il,i,i)=1.0
+        sij(il, i, i) = 0.0
+      END IF
+    END DO ! il
+
+!AC!      do j=1,ntra
+!AC!       do il=1,ncum
+!AC!        if ( i.ge.icb(il) .and. i.le.inb(il) .and. lwork(il)
+!AC!     :     .and. csum(il,i).lt.m(il,i) ) then
+!AC!         traent(il,i,i,j)=tra(il,nk(il),j)
+!AC!        endif
+!AC!       enddo
+!AC!      enddo
+789 END DO
+
+! MAF: renormalisation de MENT
+  CALL zilch(zm, nloc*na)
+  DO jm = 1, nl
+    DO im = 1, nl
+      DO il = 1, ncum
+        zm(il, im) = zm(il, im) + (1.-sij(il,im,jm))*ment(il, im, jm)
+      END DO
+    END DO
+  END DO
+
+  DO jm = 1, nl
+    DO im = 1, nl
+      DO il = 1, ncum
+        IF (zm(il,im)/=0.) THEN
+          ment(il, im, jm) = ment(il, im, jm)*m(il, im)/zm(il, im)
+        END IF
+      END DO
+    END DO
+  END DO
+
+  DO jm = 1, nl
+    DO im = 1, nl
+      DO il = 1, ncum
+        qents(il, im, jm) = qent(il, im, jm)
+        ments(il, im, jm) = ment(il, im, jm)
+      END DO
+    END DO
+  END DO
+
+  RETURN
+END SUBROUTINE cv3_mixing
+
+SUBROUTINE cv3_unsat(nloc, ncum, nd, na, ntra, icb, inb, iflag, &
+                     t, rr, rs, gz, u, v, tra, p, ph, &
+                     th, tv, lv, lf, cpn, ep, sigp, clw, frac_s, qpreca, frac_a, qta , &                       !!jygprl
+                     m, ment, elij, delt, plcl, coef_clos, &
+                     mp, rp, up, vp, trap, wt, water, evap, fondue, ice, &
+                     faci, b, sigd, &
+                     wdtrainA, wdtrainS, wdtrainM)                                      ! RomP
+  USE print_control_mod, ONLY: prt_level, lunout
+  IMPLICIT NONE
+
+
+  include "cvthermo.h"
+  include "cv3param.h"
+  include "cvflag.h"
+  include "nuage.h"
+
+!inputs:
+  INTEGER, INTENT (IN)                               :: ncum, nd, na, ntra, nloc
+  INTEGER, DIMENSION (nloc), INTENT (IN)             :: icb, inb
+  REAL, INTENT(IN)                                   :: delt
+  REAL, DIMENSION (nloc), INTENT (IN)                :: plcl
+  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: t, rr, rs
+  REAL, DIMENSION (nloc, na), INTENT (IN)            :: gz
+  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: u, v
+  REAL, DIMENSION (nloc, nd, ntra), INTENT(IN)       :: tra
+  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: p
+  REAL, DIMENSION (nloc, nd+1), INTENT (IN)          :: ph
+  REAL, DIMENSION (nloc, na), INTENT (IN)            :: ep, sigp, clw   !adiab ascent shedding
+  REAL, DIMENSION (nloc, na), INTENT (IN)            :: frac_s          !ice fraction in adiab ascent shedding !!jygprl
+  REAL, DIMENSION (nloc, na), INTENT (IN)            :: qpreca          !adiab ascent precip                   !!jygprl
+  REAL, DIMENSION (nloc, na), INTENT (IN)            :: frac_a          !ice fraction in adiab ascent precip   !!jygprl
+  REAL, DIMENSION (nloc, na), INTENT (IN)            :: qta             !adiab ascent specific total water     !!jygprl
+  REAL, DIMENSION (nloc, na), INTENT (IN)            :: th, tv, lv, cpn
+  REAL, DIMENSION (nloc, na), INTENT (IN)            :: lf
+  REAL, DIMENSION (nloc, na), INTENT (IN)            :: m
+  REAL, DIMENSION (nloc, na, na), INTENT (IN)        :: ment, elij
+  REAL, DIMENSION (nloc), INTENT (IN)                :: coef_clos
+
+!input/output
+  INTEGER, DIMENSION (nloc), INTENT (INOUT)          :: iflag(nloc)
+
+!outputs:
+  REAL, DIMENSION (nloc, na), INTENT (OUT)           :: mp, rp, up, vp
+  REAL, DIMENSION (nloc, na), INTENT (OUT)           :: water, evap, wt
+  REAL, DIMENSION (nloc, na), INTENT (OUT)           :: ice, fondue
+  REAL, DIMENSION (nloc, na), INTENT (OUT)           :: faci            ! ice fraction in precipitation
+  REAL, DIMENSION (nloc, na, ntra), INTENT (OUT)     :: trap
+  REAL, DIMENSION (nloc, na), INTENT (OUT)           :: b
+  REAL, DIMENSION (nloc), INTENT (OUT)               :: sigd
+! 25/08/10 - RomP---- ajout des masses precipitantes ejectees
+! de l ascendance adiabatique et des flux melanges Pa et Pm.
+! Distinction des wdtrain
+! Pa = wdtrainA     Pm = wdtrainM
+  REAL, DIMENSION (nloc, na), INTENT (OUT)           :: wdtrainA, wdtrainS, wdtrainM
+
+!local variables
+  INTEGER i, j, k, il, num1, ndp1
+  REAL smallestreal
+  REAL tinv, delti, coef
+  REAL awat, afac, afac1, afac2, bfac
+  REAL pr1, pr2, sigt, b6, c6, d6, e6, f6, revap, delth
+  REAL amfac, amp2, xf, tf, fac2, ur, sru, fac, d, af, bf
+  REAL ampmax, thaw
+  REAL tevap(nloc)
+  REAL, DIMENSION (nloc, na)      :: lvcp, lfcp
+  REAL, DIMENSION (nloc, na)      :: h, hm
+  REAL, DIMENSION (nloc, na)      :: ma
+  REAL, DIMENSION (nloc, na)      :: frac          ! ice fraction in precipitation source
+  REAL, DIMENSION (nloc, na)      :: fraci         ! provisionnal ice fraction in precipitation
+  REAL, DIMENSION (nloc, na)      :: prec
+  REAL wdtrain(nloc)
+  LOGICAL lwork(nloc), mplus(nloc)
+
+
+! ------------------------------------------------------
+IF (prt_level .GE. 10) print *,' ->cv3_unsat, iflag(1) ', iflag(1)
+
+smallestreal=tiny(smallestreal)
+
+! =============================
+! --- INITIALIZE OUTPUT ARRAYS 
+! =============================
+!  (loops up to nl+1)
+mp(:,:) = 0.
+rp(:,:) = 0.
+up(:,:) = 0.
+vp(:,:) = 0.
+water(:,:) = 0.
+evap(:,:) = 0.
+wt(:,:) = 0.
+ice(:,:) = 0.
+fondue(:,:) = 0.
+faci(:,:) = 0.
+b(:,:) = 0.
+sigd(:) = 0.
+!! RomP >>>
+wdtrainA(:,:) = 0.
+wdtrainS(:,:) = 0.
+wdtrainM(:,:) = 0.
+!! RomP <<<
+
+  DO i = 1, nlp
+    DO il = 1, ncum
+      rp(il, i) = rr(il, i)
+      up(il, i) = u(il, i)
+      vp(il, i) = v(il, i)
+      wt(il, i) = 0.001
+    END DO
+  END DO
+
+! ***  Set the fractionnal area sigd of precipitating downdraughts
+  DO il = 1, ncum
+    sigd(il) = sigdz*coef_clos(il)
+  END DO
+
+! =====================================================================
+! --- INITIALIZE VARIOUS ARRAYS AND PARAMETERS USED IN THE COMPUTATIONS
+! =====================================================================
+!  (loops up to nl+1)
+
+  delti = 1./delt
+  tinv = 1./3.
+
+  DO i = 1, nlp
+    DO il = 1, ncum
+      frac(il, i) = 0.0
+      fraci(il, i) = 0.0
+      prec(il, i) = 0.0
+      lvcp(il, i) = lv(il, i)/cpn(il, i)
+      lfcp(il, i) = lf(il, i)/cpn(il, i)
+    END DO
+  END DO
+
+!AC!        do k=1,ntra
+!AC!         do i=1,nd
+!AC!          do il=1,ncum
+!AC!           trap(il,i,k)=tra(il,i,k)
+!AC!          enddo
+!AC!         enddo
+!AC!        enddo
+
+! ***  check whether ep(inb)=0, if so, skip precipitating    ***
+! ***             downdraft calculation                      ***
+
+
+  DO il = 1, ncum
+!!          lwork(il)=.TRUE.
+!!          if(ep(il,inb(il)).lt.0.0001)lwork(il)=.FALSE.
+!jyg<
+!!    lwork(il) = ep(il, inb(il)) >= 0.0001
+    lwork(il) = ep(il, inb(il)) >= 0.0001 .AND. iflag(il) <= 2
+  END DO
+
+!
+! Get adiabatic ascent mass flux 
+!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+  IF (adiab_ascent_mass_flux_depends_on_ejectliq) THEN
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!! Warning : this option leads to water conservation violation
+!!!           Expert only
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+    DO il = 1, ncum
+      ma(il, nlp) = 0.
+      ma(il, 1)   = 0.
+    END DO
+
+  DO i = nl, 2, -1
+      DO il = 1, ncum
+        ma(il, i) = ma(il, i+1)*(1.-qta(il,i))/(1.-qta(il,i-1)) + m(il, i)
+      END DO
+  END DO
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+  ELSE ! (adiab_ascent_mass_flux_depends_on_ejectliq)
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+    DO il = 1, ncum
+      ma(il, nlp) = 0.
+      ma(il, 1)   = 0.
+    END DO
+
+  DO i = nl, 2, -1
+      DO il = 1, ncum
+        ma(il, i) = ma(il, i+1) + m(il, i)
+      END DO
+  END DO
+
+  ENDIF ! (adiab_ascent_mass_flux_depends_on_ejectliq) ELSE
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+!
+! ***                    begin downdraft loop                    ***
+!
+! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+  DO i = nl + 1, 1, -1
+
+    num1 = 0
+    DO il = 1, ncum
+      IF (i<=inb(il) .AND. lwork(il)) num1 = num1 + 1
+    END DO
+    IF (num1<=0) GO TO 400
+
+    CALL zilch(wdtrain, ncum)
+
+
+! ***  integrate liquid water equation to find condensed water   ***
+! ***                and condensed water flux                    ***
+!
+!
+! ***              calculate detrained precipitation             ***
+
+
+    DO il = 1, ncum                                                   
+      IF (i<=inb(il) .AND. lwork(il)) THEN                            
+        wdtrain(il) = grav*ep(il, i)*m(il, i)*clw(il, i)            
+        wdtrainS(il, i) = wdtrain(il)/grav                                            !   Ps   jyg
+!!        wdtrainA(il, i) = wdtrain(il)/grav                                          !   Ps   RomP
+      END IF                                                          
+    END DO                                                            
+
+    IF (i>1) THEN
+      DO j = 1, i - 1
+        DO il = 1, ncum
+          IF (i<=inb(il) .AND. lwork(il)) THEN
+            awat = elij(il, j, i) - (1.-ep(il,i))*clw(il, i)
+            awat = max(awat, 0.0)
+            wdtrain(il) = wdtrain(il) + grav*awat*ment(il, j, i)
+            wdtrainM(il, i) = wdtrain(il)/grav - wdtrainS(il, i)    !   Pm  jyg
+!!            wdtrainM(il, i) = wdtrain(il)/grav - wdtrainA(il, i)  !   Pm  RomP
+          END IF
+        END DO
+      END DO
+    END IF
+
+    IF (cvflag_prec_eject) THEN
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+      IF (adiab_ascent_mass_flux_depends_on_ejectliq) THEN
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!! Warning : this option leads to water conservation violation
+!!!           Expert only
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+          IF ( i > 1) THEN
+            DO il = 1, ncum
+              IF (i<=inb(il) .AND. lwork(il)) THEN
+                wdtrainA(il,i) = ma(il, i+1)*(qta(il, i-1)-qta(il,i))/(1. - qta(il, i-1))    !   Pa   jygprl
+                wdtrain(il) = wdtrain(il) + grav*wdtrainA(il,i)
+              END IF
+            END DO
+          ENDIF  ! ( i > 1)
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+      ELSE ! (adiab_ascent_mass_flux_depends_on_ejectliq)
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+          IF ( i > 1) THEN
+            DO il = 1, ncum
+              IF (i<=inb(il) .AND. lwork(il)) THEN
+                wdtrainA(il,i) = ma(il, i+1)*(qta(il, i-1)-qta(il,i))                        !   Pa   jygprl
+                wdtrain(il) = wdtrain(il) + grav*wdtrainA(il,i)
+              END IF
+            END DO
+          ENDIF  ! ( i > 1)
+
+      ENDIF ! (adiab_ascent_mass_flux_depends_on_ejectliq) ELSE
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+    ENDIF  ! (cvflag_prec_eject)
+
+
+! ***    find rain water and evaporation using provisional   ***
+! ***              estimates of rp(i)and rp(i-1)             ***
+
+
+    IF (cvflag_ice) THEN                                                                                !!jygprl
+      IF (cvflag_prec_eject) THEN
+        DO il = 1, ncum                                                                                   !!jygprl
+          IF (i<=inb(il) .AND. lwork(il)) THEN                                                            !!jygprl
+            frac(il, i) = (frac_a(il,i)*wdtrainA(il,i)+frac_s(il,i)*(wdtrainS(il,i)+wdtrainM(il,i))) / &  !!jygprl
+                          max(wdtrainA(il,i)+wdtrainS(il,i)+wdtrainM(il,i),smallestreal)                  !!jygprl
+            fraci(il, i) = frac(il, i)                                                                    !!jygprl
+          END IF                                                                                          !!jygprl
+        END DO                                                                                            !!jygprl
+      ELSE  ! (cvflag_prec_eject)
+        DO il = 1, ncum                                                                                   !!jygprl
+          IF (i<=inb(il) .AND. lwork(il)) THEN                                                            !!jygprl
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+            IF (keepbug_ice_frac) THEN
+              frac(il, i) = frac_s(il, i)
+!       Ice fraction computed again here as a function of the temperature seen by unsaturated downdraughts
+!       (i.e. the cold pool temperature) for compatibility with earlier versions.
+              fraci(il, i) = 1. - (t(il,i)-243.15)/(263.15-243.15)
+              fraci(il, i) = min(max(fraci(il,i),0.0), 1.0)
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+            ELSE  ! (keepbug_ice_frac)
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+              frac(il, i) = frac_s(il, i)
+              fraci(il, i) = frac(il, i)                                                                    !!jygprl
+            ENDIF  ! (keepbug_ice_frac)
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+          END IF                                                                                          !!jygprl
+        END DO                                                                                            !!jygprl
+      ENDIF  ! (cvflag_prec_eject)
+    END IF                                                                                              !!jygprl
+
+
+    DO il = 1, ncum
+      IF (i<=inb(il) .AND. lwork(il)) THEN
+
+        wt(il, i) = 45.0
+
+        IF (i<inb(il)) THEN
+          rp(il, i) = rp(il, i+1) + &
+                      (cpd*(t(il,i+1)-t(il,i))+gz(il,i+1)-gz(il,i))/lv(il, i)
+          rp(il, i) = 0.5*(rp(il,i)+rr(il,i))
+        END IF
+        rp(il, i) = max(rp(il,i), 0.0)
+        rp(il, i) = amin1(rp(il,i), rs(il,i))
+        rp(il, inb(il)) = rr(il, inb(il))
+
+        IF (i==1) THEN
+          afac = p(il, 1)*(rs(il,1)-rp(il,1))/(1.0E4+2000.0*p(il,1)*rs(il,1))
+          IF (cvflag_ice) THEN
+            afac1 = p(il, i)*(rs(il,1)-rp(il,1))/(1.0E4+2000.0*p(il,1)*rs(il,1))
+          END IF
+        ELSE
+          rp(il, i-1) = rp(il, i) + (cpd*(t(il,i)-t(il,i-1))+gz(il,i)-gz(il,i-1))/lv(il, i)
+          rp(il, i-1) = 0.5*(rp(il,i-1)+rr(il,i-1))
+          rp(il, i-1) = amin1(rp(il,i-1), rs(il,i-1))
+          rp(il, i-1) = max(rp(il,i-1), 0.0)
+          afac1 = p(il, i)*(rs(il,i)-rp(il,i))/(1.0E4+2000.0*p(il,i)*rs(il,i))
+          afac2 = p(il, i-1)*(rs(il,i-1)-rp(il,i-1))/(1.0E4+2000.0*p(il,i-1)*rs(il,i-1))
+          afac = 0.5*(afac1+afac2)
+        END IF
+        IF (i==inb(il)) afac = 0.0
+        afac = max(afac, 0.0)
+        bfac = 1./(sigd(il)*wt(il,i))
+
+!
+    IF (prt_level >= 20) THEN
+      Print*, 'cv3_unsat after provisional rp estimate: rp, afac, bfac ', &
+          i, rp(1, i), afac,bfac
+    ENDIF
+!
+!JYG1
+! cc        sigt=1.0
+! cc        if(i.ge.icb)sigt=sigp(i)
+! prise en compte de la variation progressive de sigt dans
+! les couches icb et icb-1:
+! pour plcl<ph(i+1), pr1=0 & pr2=1
+! pour plcl>ph(i),   pr1=1 & pr2=0
+! pour ph(i+1)<plcl<ph(i), pr1 est la proportion a cheval
+! sur le nuage, et pr2 est la proportion sous la base du
+! nuage.
+        pr1 = (plcl(il)-ph(il,i+1))/(ph(il,i)-ph(il,i+1))
+        pr1 = max(0., min(1.,pr1))
+        pr2 = (ph(il,i)-plcl(il))/(ph(il,i)-ph(il,i+1))
+        pr2 = max(0., min(1.,pr2))
+        sigt = sigp(il, i)*pr1 + pr2
+!JYG2
+
+!JYG----
+!    b6 = bfac*100.*sigd(il)*(ph(il,i)-ph(il,i+1))*sigt*afac
+!    c6 = water(il,i+1) + wdtrain(il)*bfac
+!    c6 = prec(il,i+1) + wdtrain(il)*bfac
+!    revap=0.5*(-b6+sqrt(b6*b6+4.*c6))
+!    evap(il,i)=sigt*afac*revap
+!    water(il,i)=revap*revap
+!    prec(il,i)=revap*revap
+!!        print *,' i,b6,c6,revap,evap(il,i),water(il,i),wdtrain(il) ', &
+!!                 i,b6,c6,revap,evap(il,i),water(il,i),wdtrain(il)
+!!---end jyg---
+
+! --------retour à la formulation originale d'Emanuel.
+        IF (cvflag_ice) THEN
+
+!   b6=bfac*50.*sigd(il)*(ph(il,i)-ph(il,i+1))*sigt*afac
+!   c6=prec(il,i+1)+bfac*wdtrain(il) &
+!       -50.*sigd(il)*bfac*(ph(il,i)-ph(il,i+1))*evap(il,i+1)
+!   if(c6.gt.0.0)then
+!   revap=0.5*(-b6+sqrt(b6*b6+4.*c6))
+
+!JAM  Attention: evap=sigt*E
+!    Modification: evap devient l'évaporation en milieu de couche
+!    car nécessaire dans cv3_yield
+!    Du coup, il faut modifier pas mal d'équations...
+!    et l'expression de afac qui devient afac1
+!    revap=sqrt((prec(i+1)+prec(i))/2)
+
+          b6 = bfac*50.*sigd(il)*(ph(il,i)-ph(il,i+1))*sigt*afac1
+          c6 = prec(il, i+1) + 0.5*bfac*wdtrain(il)
+! print *,'bfac,sigd(il),sigt,afac1 ',bfac,sigd(il),sigt,afac1
+! print *,'prec(il,i+1),wdtrain(il) ',prec(il,i+1),wdtrain(il)
+! print *,'b6,c6,b6*b6+4.*c6 ',b6,c6,b6*b6+4.*c6
+          IF (c6>b6*b6+1.E-20) THEN
+            revap = 2.*c6/(b6+sqrt(b6*b6+4.*c6))
+          ELSE
+            revap = (-b6+sqrt(b6*b6+4.*c6))/2.
+          END IF
+          prec(il, i) = max(0., 2.*revap*revap-prec(il,i+1))
+! print*,prec(il,i),'neige'
+
+!JYG    Dans sa formulation originale, Emanuel calcule l'evaporation par:
+! c             evap(il,i)=sigt*afac*revap
+! ce qui n'est pas correct. Dans cv_routines, la formulation a été modifiee.
+! Ici,l'evaporation evap est simplement calculee par l'equation de
+! conservation.
+! prec(il,i)=revap*revap
+! else
+!JYG----   Correction : si c6 <= 0, water(il,i)=0.
+! prec(il,i)=0.
+! endif
+
+!JYG---   Dans tous les cas, evaporation = [tt ce qui entre dans la couche i]
+! moins [tt ce qui sort de la couche i]
+! print *, 'evap avec ice'
+          evap(il, i) = (wdtrain(il)+sigd(il)*wt(il,i)*(prec(il,i+1)-prec(il,i))) / &
+                        (sigd(il)*(ph(il,i)-ph(il,i+1))*100.)
+!
+    IF (prt_level >= 20) THEN
+      Print*, 'cv3_unsat after evap computation: wdtrain, sigd, wt, prec(i+1),prec(i) ', &
+          i, wdtrain(1), sigd(1), wt(1,i), prec(1,i+1),prec(1,i)
+    ENDIF
+!
+
+!jyg<
+          d6 = prec(il,i)-prec(il,i+1)
+
+!!          d6 = bfac*wdtrain(il) - 100.*sigd(il)*bfac*(ph(il,i)-ph(il,i+1))*evap(il, i)
+!!          e6 = bfac*wdtrain(il)
+!!          f6 = -100.*sigd(il)*bfac*(ph(il,i)-ph(il,i+1))*evap(il, i)
+!>jyg
+!CR:tmax_fonte_cv: T for which ice is totally melted (used to be 275.15)
+          thaw = (t(il,i)-273.15)/(tmax_fonte_cv-273.15)
+          thaw = min(max(thaw,0.0), 1.0)
+!jyg<
+          water(il, i) = water(il, i+1) + (1-fraci(il,i))*d6
+          ice(il, i)   = ice(il, i+1)   + fraci(il, i)*d6
+          water(il, i) = min(prec(il,i), max(water(il,i), 0.))
+          ice(il, i)   = min(prec(il,i), max(ice(il,i),   0.))
+
+!!          water(il, i) = water(il, i+1) + (1-fraci(il,i))*d6
+!!          water(il, i) = max(water(il,i), 0.)
+!!          ice(il, i) = ice(il, i+1) + fraci(il, i)*d6
+!!          ice(il, i) = max(ice(il,i), 0.)
+!>jyg
+          fondue(il, i) = ice(il, i)*thaw
+          water(il, i) = water(il, i) + fondue(il, i)
+          ice(il, i) = ice(il, i) - fondue(il, i)
+
+          IF (water(il,i)+ice(il,i)<1.E-30) THEN
+            faci(il, i) = 0.
+          ELSE
+            faci(il, i) = ice(il, i)/(water(il,i)+ice(il,i))
+          END IF
+
+!           water(il,i)=water(il,i+1)+(1.-fraci(il,i))*e6+(1.-faci(il,i))*f6
+!           water(il,i)=max(water(il,i),0.)
+!           ice(il,i)=ice(il,i+1)+fraci(il,i)*e6+faci(il,i)*f6
+!           ice(il,i)=max(ice(il,i),0.)
+!           fondue(il,i)=ice(il,i)*thaw
+!           water(il,i)=water(il,i)+fondue(il,i)
+!           ice(il,i)=ice(il,i)-fondue(il,i)
+            
+!           if((water(il,i)+ice(il,i)).lt.1.e-30)then
+!             faci(il,i)=0.
+!           else
+!             faci(il,i)=ice(il,i)/(water(il,i)+ice(il,i))
+!           endif
+
+        ELSE
+          b6 = bfac*50.*sigd(il)*(ph(il,i)-ph(il,i+1))*sigt*afac
+          c6 = water(il, i+1) + bfac*wdtrain(il) - &
+               50.*sigd(il)*bfac*(ph(il,i)-ph(il,i+1))*evap(il, i+1)
+          IF (c6>0.0) THEN
+            revap = 0.5*(-b6+sqrt(b6*b6+4.*c6))
+            water(il, i) = revap*revap
+          ELSE
+            water(il, i) = 0.
+          END IF
+! print *, 'evap sans ice'
+          evap(il, i) = (wdtrain(il)+sigd(il)*wt(il,i)*(water(il,i+1)-water(il,i)))/ &
+                        (sigd(il)*(ph(il,i)-ph(il,i+1))*100.)
+
+        END IF
+      END IF !(i.le.inb(il) .and. lwork(il))
+    END DO
+! ----------------------------------------------------------------
+
+! cc
+! ***  calculate precipitating downdraft mass flux under     ***
+! ***              hydrostatic approximation                 ***
+
+    DO il = 1, ncum
+      IF (i<=inb(il) .AND. lwork(il) .AND. i/=1) THEN
+
+        tevap(il) = max(0.0, evap(il,i))
+        delth = max(0.001, (th(il,i)-th(il,i-1)))
+        IF (cvflag_ice) THEN
+          IF (cvflag_grav) THEN
+            mp(il, i) = 100.*ginv*(lvcp(il,i)*sigd(il)*tevap(il)* &
+                                               (p(il,i-1)-p(il,i))/delth + &
+                                   lfcp(il,i)*sigd(il)*faci(il,i)*tevap(il)* &
+                                               (p(il,i-1)-p(il,i))/delth + &
+                                   lfcp(il,i)*sigd(il)*wt(il,i)/100.*fondue(il,i)* &
+                                               (p(il,i-1)-p(il,i))/delth/(ph(il,i)-ph(il,i+1)))
+          ELSE
+            mp(il, i) = 10.*(lvcp(il,i)*sigd(il)*tevap(il)* &
+                                                (p(il,i-1)-p(il,i))/delth + &
+                             lfcp(il,i)*sigd(il)*faci(il,i)*tevap(il)* &
+                                                (p(il,i-1)-p(il,i))/delth + &
+                             lfcp(il,i)*sigd(il)*wt(il,i)/100.*fondue(il,i)* &
+                                                (p(il,i-1)-p(il,i))/delth/(ph(il,i)-ph(il,i+1)))
+
+          END IF
+        ELSE
+          IF (cvflag_grav) THEN
+            mp(il, i) = 100.*ginv*lvcp(il, i)*sigd(il)*tevap(il)* &
+                                                (p(il,i-1)-p(il,i))/delth
+          ELSE
+            mp(il, i) = 10.*lvcp(il, i)*sigd(il)*tevap(il)* &
+                                                (p(il,i-1)-p(il,i))/delth
+          END IF
+
+        END IF
+
+      END IF !(i.le.inb(il) .and. lwork(il) .and. i.ne.1)
+      IF (prt_level .GE. 20) THEN
+        PRINT *,'cv3_unsat, mp hydrostatic ', i, mp(il,i)
+      ENDIF
+    END DO
+! ----------------------------------------------------------------
+
+! ***           if hydrostatic assumption fails,             ***
+! ***   solve cubic difference equation for downdraft theta  ***
+! ***  and mass flux from two simultaneous differential eqns ***
+
+    DO il = 1, ncum
+      IF (i<=inb(il) .AND. lwork(il) .AND. i/=1) THEN
+
+        amfac = sigd(il)*sigd(il)*70.0*ph(il, i)*(p(il,i-1)-p(il,i))* &
+                         (th(il,i)-th(il,i-1))/(tv(il,i)*th(il,i))
+        amp2 = abs(mp(il,i+1)*mp(il,i+1)-mp(il,i)*mp(il,i))
+
+        IF (amp2>(0.1*amfac)) THEN
+          xf = 100.0*sigd(il)*sigd(il)*sigd(il)*(ph(il,i)-ph(il,i+1))
+          tf = b(il, i) - 5.0*(th(il,i)-th(il,i-1))*t(il, i) / &
+                              (lvcp(il,i)*sigd(il)*th(il,i))
+          af = xf*tf + mp(il, i+1)*mp(il, i+1)*tinv
+
+          IF (cvflag_ice) THEN
+            bf = 2.*(tinv*mp(il,i+1))**3 + tinv*mp(il, i+1)*xf*tf + &
+                 50.*(p(il,i-1)-p(il,i))*xf*(tevap(il)*(1.+(lf(il,i)/lv(il,i))*faci(il,i)) + &
+                (lf(il,i)/lv(il,i))*wt(il,i)/100.*fondue(il,i)/(ph(il,i)-ph(il,i+1)))
+          ELSE
+
+            bf = 2.*(tinv*mp(il,i+1))**3 + tinv*mp(il, i+1)*xf*tf + &
+                                           50.*(p(il,i-1)-p(il,i))*xf*tevap(il)
+          END IF
+
+          fac2 = 1.0
+          IF (bf<0.0) fac2 = -1.0
+          bf = abs(bf)
+          ur = 0.25*bf*bf - af*af*af*tinv*tinv*tinv
+          IF (ur>=0.0) THEN
+            sru = sqrt(ur)
+            fac = 1.0
+            IF ((0.5*bf-sru)<0.0) fac = -1.0
+            mp(il, i) = mp(il, i+1)*tinv + (0.5*bf+sru)**tinv + &
+                                           fac*(abs(0.5*bf-sru))**tinv
+          ELSE
+            d = atan(2.*sqrt(-ur)/(bf+1.0E-28))
+            IF (fac2<0.0) d = 3.14159 - d
+            mp(il, i) = mp(il, i+1)*tinv + 2.*sqrt(af*tinv)*cos(d*tinv)
+          END IF
+          mp(il, i) = max(0.0, mp(il,i))
+          IF (prt_level .GE. 20) THEN
+            PRINT *,'cv3_unsat, mp cubic ', i, mp(il,i)
+          ENDIF
+
+          IF (cvflag_ice) THEN
+            IF (cvflag_grav) THEN
+!JYG : il y a vraisemblablement une erreur dans la ligne 2 suivante:
+! il faut diviser par (mp(il,i)*sigd(il)*grav) et non par (mp(il,i)+sigd(il)*0.1).
+! Et il faut bien revoir les facteurs 100.
+              b(il, i-1) = b(il, i) + 100.0*(p(il,i-1)-p(il,i))* &
+                           (tevap(il)*(1.+(lf(il,i)/lv(il,i))*faci(il,i)) + &
+                           (lf(il,i)/lv(il,i))*wt(il,i)/100.*fondue(il,i) / &
+                           (ph(il,i)-ph(il,i+1))) / &
+                           (mp(il,i)+sigd(il)*0.1) - &
+                           10.0*(th(il,i)-th(il,i-1))*t(il, i) / &
+                           (lvcp(il,i)*sigd(il)*th(il,i))
+            ELSE
+              b(il, i-1) = b(il, i) + 100.0*(p(il,i-1)-p(il,i))*&
+                           (tevap(il)*(1.+(lf(il,i)/lv(il,i))*faci(il,i)) + &
+                           (lf(il,i)/lv(il,i))*wt(il,i)/100.*fondue(il,i) / &
+                           (ph(il,i)-ph(il,i+1))) / &
+                           (mp(il,i)+sigd(il)*0.1) - &
+                           10.0*(th(il,i)-th(il,i-1))*t(il, i) / &
+                           (lvcp(il,i)*sigd(il)*th(il,i))
+            END IF
+          ELSE
+            IF (cvflag_grav) THEN
+              b(il, i-1) = b(il, i) + 100.0*(p(il,i-1)-p(il,i))*tevap(il) / &
+                           (mp(il,i)+sigd(il)*0.1) - &
+                           10.0*(th(il,i)-th(il,i-1))*t(il, i) / &
+                           (lvcp(il,i)*sigd(il)*th(il,i))
+            ELSE
+              b(il, i-1) = b(il, i) + 100.0*(p(il,i-1)-p(il,i))*tevap(il) / &
+                           (mp(il,i)+sigd(il)*0.1) - &
+                           10.0*(th(il,i)-th(il,i-1))*t(il, i) / &
+                           (lvcp(il,i)*sigd(il)*th(il,i))
+            END IF
+          END IF
+          b(il, i-1) = max(b(il,i-1), 0.0)
+
+        END IF !(amp2.gt.(0.1*amfac))
+
+!jyg<    This part shifted 10 lines farther
+!!! ***         limit magnitude of mp(i) to meet cfl condition      ***
+!!
+!!        ampmax = 2.0*(ph(il,i)-ph(il,i+1))*delti
+!!        amp2 = 2.0*(ph(il,i-1)-ph(il,i))*delti
+!!        ampmax = min(ampmax, amp2)
+!!        mp(il, i) = min(mp(il,i), ampmax)
+!>jyg
+
+! ***      force mp to decrease linearly to zero                 ***
+! ***       between cloud base and the surface                   ***
+
+
+! c      if(p(il,i).gt.p(il,icb(il)))then
+! c       mp(il,i)=mp(il,icb(il))*(p(il,1)-p(il,i))/(p(il,1)-p(il,icb(il)))
+! c      endif
+        IF (ph(il,i)>0.9*plcl(il)) THEN
+          mp(il, i) = mp(il, i)*(ph(il,1)-ph(il,i))/(ph(il,1)-0.9*plcl(il))
+        END IF
+
+!jyg<    Shifted part
+! ***         limit magnitude of mp(i) to meet cfl condition      ***
+
+        ampmax = 2.0*(ph(il,i)-ph(il,i+1))*delti
+        amp2 = 2.0*(ph(il,i-1)-ph(il,i))*delti
+        ampmax = min(ampmax, amp2)
+        mp(il, i) = min(mp(il,i), ampmax)
+!>jyg
+
+      END IF ! (i.le.inb(il) .and. lwork(il) .and. i.ne.1)
+    END DO
+! ----------------------------------------------------------------
+!
+    IF (prt_level >= 20) THEN
+      Print*, 'cv3_unsat after mp computation: mp, b(i), b(i-1) ', &
+          i, mp(1, i), b(1,i), b(1,max(i-1,1))
+    ENDIF
+!
+
+! ***       find mixing ratio of precipitating downdraft     ***
+
+    DO il = 1, ncum
+      IF (i<inb(il) .AND. lwork(il)) THEN
+        mplus(il) = mp(il, i) > mp(il, i+1)
+      END IF ! (i.lt.inb(il) .and. lwork(il))
+    END DO
+
+    DO il = 1, ncum
+      IF (i<inb(il) .AND. lwork(il)) THEN
+
+        rp(il, i) = rr(il, i)
+
+        IF (mplus(il)) THEN
+
+          IF (cvflag_grav) THEN
+            rp(il, i) = rp(il, i+1)*mp(il, i+1) + rr(il, i)*(mp(il,i)-mp(il,i+1)) + &
+              100.*ginv*0.5*sigd(il)*(ph(il,i)-ph(il,i+1))*(evap(il,i+1)+evap(il,i))
+          ELSE
+            rp(il, i) = rp(il, i+1)*mp(il, i+1) + rr(il, i)*(mp(il,i)-mp(il,i+1)) + &
+              5.*sigd(il)*(ph(il,i)-ph(il,i+1))*(evap(il,i+1)+evap(il,i))
+          END IF
+          rp(il, i) = rp(il, i)/mp(il, i)
+          up(il, i) = up(il, i+1)*mp(il, i+1) + u(il, i)*(mp(il,i)-mp(il,i+1))
+          up(il, i) = up(il, i)/mp(il, i)
+          vp(il, i) = vp(il, i+1)*mp(il, i+1) + v(il, i)*(mp(il,i)-mp(il,i+1))
+          vp(il, i) = vp(il, i)/mp(il, i)
+
+        ELSE ! if (mplus(il))
+
+          IF (mp(il,i+1)>1.0E-16) THEN
+            IF (cvflag_grav) THEN
+              rp(il, i) = rp(il,i+1) + 100.*ginv*0.5*sigd(il)*(ph(il,i)-ph(il,i+1)) * &
+                                       (evap(il,i+1)+evap(il,i))/mp(il,i+1)
+            ELSE
+              rp(il, i) = rp(il,i+1) + 5.*sigd(il)*(ph(il,i)-ph(il,i+1)) * &
+                                       (evap(il,i+1)+evap(il,i))/mp(il, i+1)
+            END IF
+            up(il, i) = up(il, i+1)
+            vp(il, i) = vp(il, i+1)
+          END IF ! (mp(il,i+1).gt.1.0e-16)
+        END IF ! (mplus(il)) else if (.not.mplus(il))
+
+        rp(il, i) = amin1(rp(il,i), rs(il,i))
+        rp(il, i) = max(rp(il,i), 0.0)
+
+      END IF ! (i.lt.inb(il) .and. lwork(il))
+    END DO
+! ----------------------------------------------------------------
+
+! ***       find tracer concentrations in precipitating downdraft     ***
+
+!AC!      do j=1,ntra
+!AC!       do il = 1,ncum
+!AC!       if (i.lt.inb(il) .and. lwork(il)) then
+!AC!c
+!AC!         if(mplus(il))then
+!AC!          trap(il,i,j)=trap(il,i+1,j)*mp(il,i+1)
+!AC!     :              +trap(il,i,j)*(mp(il,i)-mp(il,i+1))
+!AC!          trap(il,i,j)=trap(il,i,j)/mp(il,i)
+!AC!         else ! if (mplus(il))
+!AC!          if(mp(il,i+1).gt.1.0e-16)then
+!AC!           trap(il,i,j)=trap(il,i+1,j)
+!AC!          endif
+!AC!         endif ! (mplus(il)) else if (.not.mplus(il))
+!AC!c
+!AC!        endif ! (i.lt.inb(il) .and. lwork(il))
+!AC!       enddo
+!AC!      end do
+
+400 END DO
+! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+! ***                    end of downdraft loop                    ***
+
+! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+  RETURN
+
+END SUBROUTINE cv3_unsat
+
+SUBROUTINE cv3_yield(nloc, ncum, nd, na, ntra, ok_conserv_q, &
+                     icb, inb, delt, &
+                     t, rr, t_wake, rr_wake, s_wake, u, v, tra, &
+                     gz, p, ph, h, hp, lv, lf, cpn, th, th_wake, &
+                     ep, clw, qpreca, m, tp, mp, rp, up, vp, trap, &
+                     wt, water, ice, evap, fondue, faci, b, sigd, &
+                     ment, qent, hent, iflag_mix, uent, vent, &
+                     nent, elij, traent, sig, &
+                     tv, tvp, wghti, &
+                     iflag, precip, Vprecip, Vprecipi, &     ! jyg: Vprecipi
+                     ft, fr, fr_comp, fu, fv, ftra, &                 ! jyg
+                     cbmf, upwd, dnwd, dnwd0, ma, mip, &
+!!                     tls, tps,                             ! useless . jyg
+                     qcondc, wd, &
+                     ftd, fqd, qta, qtc, sigt, detrain, tau_cld_cv, coefw_cld_cv)
+
+    USE print_control_mod, ONLY: lunout, prt_level
+    USE add_phys_tend_mod, only : fl_cor_ebil
+
+  IMPLICIT NONE
+
+  include "cvthermo.h"
+  include "cv3param.h"
+  include "cvflag.h"
+  include "conema3.h"
+
+!inputs:
+      INTEGER, INTENT (IN)                               :: iflag_mix
+      INTEGER, INTENT (IN)                               :: ncum, nd, na, ntra, nloc
+      LOGICAL, INTENT (IN)                               :: ok_conserv_q
+      INTEGER, DIMENSION (nloc), INTENT (IN)             :: icb, inb
+      REAL, INTENT (IN)                                  :: delt
+      REAL, DIMENSION (nloc, nd), INTENT (IN)            :: t, rr, u, v
+      REAL, DIMENSION (nloc, nd), INTENT (IN)            :: t_wake, rr_wake
+      REAL, DIMENSION (nloc), INTENT (IN)                :: s_wake
+      REAL, DIMENSION (nloc, nd, ntra), INTENT (IN)      :: tra
+      REAL, DIMENSION (nloc, nd), INTENT (IN)            :: p
+      REAL, DIMENSION (nloc, nd+1), INTENT (IN)          :: ph
+      REAL, DIMENSION (nloc, na), INTENT (IN)            :: gz, h, hp
+      REAL, DIMENSION (nloc, na), INTENT (IN)            :: th, tp
+      REAL, DIMENSION (nloc, na), INTENT (IN)            :: lv, cpn, ep, clw
+      REAL, DIMENSION (nloc, na), INTENT (IN)            :: lf
+      REAL, DIMENSION (nloc, na), INTENT (IN)            :: rp, up
+      REAL, DIMENSION (nloc, na), INTENT (IN)            :: vp
+      REAL, DIMENSION (nloc, nd), INTENT (IN)            :: wt
+      REAL, DIMENSION (nloc, nd, ntra), INTENT (IN)      :: trap
+      REAL, DIMENSION (nloc, na), INTENT (IN)            :: water, evap, b
+      REAL, DIMENSION (nloc, na), INTENT (IN)            :: fondue, faci, ice
+      REAL, DIMENSION (nloc, na, na), INTENT (IN)        :: qent, uent
+      REAL, DIMENSION (nloc, na, na), INTENT (IN)        :: hent
+      REAL, DIMENSION (nloc, na, na), INTENT (IN)        :: vent, elij
+      INTEGER, DIMENSION (nloc, nd), INTENT (IN)         :: nent
+      REAL, DIMENSION (nloc, na, na, ntra), INTENT (IN)  :: traent
+      REAL, DIMENSION (nloc, nd), INTENT (IN)            :: tv, tvp, wghti
+      REAL, DIMENSION (nloc, nd), INTENT (IN)            :: qta
+      REAL, DIMENSION (nloc, na),INTENT(IN)              :: qpreca
+      REAL, INTENT(IN)                                   :: tau_cld_cv, coefw_cld_cv
+!
+!input/output:
+      REAL, DIMENSION (nloc, na), INTENT (INOUT)         :: m, mp
+      REAL, DIMENSION (nloc, na, na), INTENT (INOUT)     :: ment
+      INTEGER, DIMENSION (nloc), INTENT (INOUT)          :: iflag
+      REAL, DIMENSION (nloc, nd), INTENT (INOUT)         :: sig
+      REAL, DIMENSION (nloc), INTENT (INOUT)             :: sigd
+!
+!outputs:
+      REAL, DIMENSION (nloc), INTENT (OUT)               :: precip
+      REAL, DIMENSION (nloc, nd), INTENT (OUT)           :: ft, fr, fu, fv , fr_comp
+      REAL, DIMENSION (nloc, nd), INTENT (OUT)           :: ftd, fqd
+      REAL, DIMENSION (nloc, nd, ntra), INTENT (OUT)     :: ftra
+      REAL, DIMENSION (nloc, nd), INTENT (OUT)           :: upwd, dnwd, ma
+      REAL, DIMENSION (nloc, nd), INTENT (OUT)           :: dnwd0, mip
+      REAL, DIMENSION (nloc, nd+1), INTENT (OUT)         :: Vprecip
+      REAL, DIMENSION (nloc, nd+1), INTENT (OUT)         :: Vprecipi
+!!      REAL tls(nloc, nd), tps(nloc, nd)                    ! useless . jyg
+      REAL, DIMENSION (nloc, nd), INTENT (OUT)           :: qcondc                      ! cld
+      REAL, DIMENSION (nloc, nd), INTENT (OUT)           :: qtc, sigt                   ! cld
+      REAL, DIMENSION (nloc, nd), INTENT (OUT)           :: detrain                     ! Louis : pour le calcul de Klein du terme de variance qui dÃ©traine dans lenvironnement
+      REAL, DIMENSION (nloc), INTENT (OUT)               :: wd                          ! gust
+      REAL, DIMENSION (nloc), INTENT (OUT)               :: cbmf
+!
+!local variables:
+      INTEGER                                            :: i, k, il, n, j, num1
+      REAL                                               :: rat, delti
+      REAL                                               :: ax, bx, cx, dx, ex
+      REAL                                               :: cpinv, rdcp, dpinv
+      REAL                                               :: sigaq
+      REAL, DIMENSION (nloc)                             ::  awat
+      REAL, DIMENSION (nloc, nd)                         :: lvcp, lfcp              ! , mke ! unused . jyg
+      REAL, DIMENSION (nloc)                             :: am, work, ad, amp1
+!!      real up1(nloc), dn1(nloc)
+      REAL, DIMENSION (nloc, nd, nd)                     :: up1, dn1
+!jyg<
+      REAL, DIMENSION (nloc, nd)                         :: up_to, up_from
+      REAL, DIMENSION (nloc, nd)                         :: dn_to, dn_from
+!>jyg
+      REAL, DIMENSION (nloc)                             :: asum, bsum, csum, dsum
+      REAL, DIMENSION (nloc)                             :: esum, fsum, gsum, hsum
+      REAL, DIMENSION (nloc, nd)                         :: th_wake
+      REAL, DIMENSION (nloc)                             :: alpha_qpos, alpha_qpos1
+      REAL, DIMENSION (nloc, nd)                         :: qcond, nqcond, wa           ! cld
+      REAL, DIMENSION (nloc, nd)                         :: siga, sax, mac              ! cld
+      REAL, DIMENSION (nloc)                             :: sument
+      REAL, DIMENSION (nloc, nd)                         :: sigment, qtment             ! cld
+      REAL, DIMENSION (nloc, nd, nd)                     :: qdet
+      REAL sumdq !jyg
+! 
+! -------------------------------------------------------------
+
+! initialization:
+
+  delti = 1.0/delt
+! print*,'cv3_yield initialisation delt', delt
+
+  DO il = 1, ncum
+    precip(il) = 0.0
+    wd(il) = 0.0 ! gust
+  END DO
+
+!   Fluxes are on a staggered grid : loops extend up to nl+1
+  DO i = 1, nlp
+    DO il = 1, ncum
+      Vprecip(il, i) = 0.0
+      Vprecipi(il, i) = 0.0                               ! jyg
+      upwd(il, i) = 0.0
+      dnwd(il, i) = 0.0
+      dnwd0(il, i) = 0.0
+      mip(il, i) = 0.0
+    END DO
+  END DO
+  DO i = 1, nl
+    DO il = 1, ncum
+      ft(il, i) = 0.0
+      fr(il, i) = 0.0
+      fr_comp(il,i) = 0.0
+      fu(il, i) = 0.0
+      fv(il, i) = 0.0
+      ftd(il, i) = 0.0
+      fqd(il, i) = 0.0
+      qcondc(il, i) = 0.0 ! cld
+      qcond(il, i) = 0.0 ! cld
+      qtc(il, i) = 0.0 ! cld
+      qtment(il, i) = 0.0 ! cld
+      sigment(il, i) = 0.0 ! cld
+      sigt(il, i) = 0.0 ! cld
+      qdet(il,i,:) = 0.0 ! cld
+      detrain(il, i) = 0.0 ! cld
+      nqcond(il, i) = 0.0 ! cld
+    END DO
+  END DO
+! print*,'cv3_yield initialisation 2'
+!AC!      do j=1,ntra
+!AC!       do i=1,nd
+!AC!        do il=1,ncum
+!AC!          ftra(il,i,j)=0.0
+!AC!        enddo
+!AC!       enddo
+!AC!      enddo
+! print*,'cv3_yield initialisation 3'
+  DO i = 1, nl
+    DO il = 1, ncum
+      lvcp(il, i) = lv(il, i)/cpn(il, i)
+      lfcp(il, i) = lf(il, i)/cpn(il, i)
+    END DO
+  END DO
+
+
+
+! ***  calculate surface precipitation in mm/day     ***
+
+  DO il = 1, ncum
+    IF (ep(il,inb(il))>=0.0001 .AND. iflag(il)<=1) THEN
+      IF (cvflag_ice) THEN
+        precip(il) = wt(il, 1)*sigd(il)*(water(il,1)+ice(il,1)) &
+                              *86400.*1000./(rowl*grav)
+      ELSE
+        precip(il) = wt(il, 1)*sigd(il)*water(il, 1) &
+                              *86400.*1000./(rowl*grav)
+      END IF
+    END IF
+  END DO
+! print*,'cv3_yield apres calcul precip'
+
+
+! ===  calculate vertical profile of  precipitation in kg/m2/s  ===
+
+  DO i = 1, nl
+    DO il = 1, ncum
+      IF (ep(il,inb(il))>=0.0001 .AND. i<=inb(il) .AND. iflag(il)<=1) THEN
+        IF (cvflag_ice) THEN
+          Vprecip(il, i) = wt(il, i)*sigd(il)*(water(il,i)+ice(il,i))/grav
+          Vprecipi(il, i) = wt(il, i)*sigd(il)*ice(il,i)/grav                   ! jyg
+        ELSE
+          Vprecip(il, i) = wt(il, i)*sigd(il)*water(il, i)/grav
+          Vprecipi(il, i) = 0.                                                  ! jyg
+        END IF
+      END IF
+    END DO
+  END DO
+
+
+! ***  Calculate downdraft velocity scale    ***
+! ***  NE PAS UTILISER POUR L'INSTANT ***
+
+!!      do il=1,ncum
+!!        wd(il)=betad*abs(mp(il,icb(il)))*0.01*rrd*t(il,icb(il)) &
+!!                                       /(sigd(il)*p(il,icb(il)))
+!!      enddo
+
+
+! ***  calculate tendencies of lowest level potential temperature  ***
+! ***                      and mixing ratio                        ***
+
+  DO il = 1, ncum
+    work(il) = 1.0/(ph(il,1)-ph(il,2))
+    cbmf(il) = 0.0
+  END DO
+
+! - Adiabatic ascent mass flux "ma" and cloud base mass flux "cbmf"
+!-----------------------------------------------------------------
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+  IF (adiab_ascent_mass_flux_depends_on_ejectliq) THEN
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!! Warning : this option leads to water conservation violation
+!!!           Expert only
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+  DO il = 1, ncum
+    ma(il, nlp) = 0.
+    ma(il, 1)   = 0.
+  END DO
+  DO k = nl, 2, -1
+    DO il = 1, ncum
+      ma(il, k) = ma(il, k+1)*(1.-qta(il, k))/(1.-qta(il, k-1)) + m(il, k)
+      cbmf(il) = max(cbmf(il), ma(il,k))
+    END DO
+  END DO
+  DO k = 2,nl
+    DO il = 1, ncum
+      IF (k <icb(il)) THEN
+        ma(il, k) = ma(il, k-1) + wghti(il,k-1)*cbmf(il)
+      ENDIF
+    END DO
+  END DO
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+  ELSE ! (adiab_ascent_mass_flux_depends_on_ejectliq)
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! Line kept for compatibility with earlier versions
+  DO k = 2, nl
+    DO il = 1, ncum
+      IF (k>=icb(il)) THEN
+        cbmf(il) = cbmf(il) + m(il, k)
+      END IF
+    END DO
+  END DO
+
+  DO il = 1, ncum
+    ma(il, nlp) = 0.
+    ma(il, 1)   = 0.
+  END DO
+  DO k = nl, 2, -1
+    DO il = 1, ncum
+      ma(il, k) = ma(il, k+1) + m(il, k)
+    END DO
+  END DO
+  DO k = 2,nl
+    DO il = 1, ncum
+      IF (k <icb(il)) THEN
+        ma(il, k) = ma(il, k-1) + wghti(il,k-1)*cbmf(il)
+      ENDIF
+    END DO
+  END DO
+
+  ENDIF ! (adiab_ascent_mass_flux_depends_on_ejectliq) ELSE
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
+!    print*,'cv3_yield avant ft'
+! am is the part of cbmf taken from the first level
+  DO il = 1, ncum
+    am(il) = cbmf(il)*wghti(il, 1)
+  END DO
+
+  DO il = 1, ncum
+    IF (iflag(il)<=1) THEN
+! convect3      if((0.1*dpinv*am).ge.delti)iflag(il)=4
+!JYG  Correction pour conserver l'eau
+! cc       ft(il,1)=-0.5*lvcp(il,1)*sigd(il)*(evap(il,1)+evap(il,2))          !precip
+      IF (cvflag_ice) THEN
+        ft(il, 1) = -lvcp(il, 1)*sigd(il)*evap(il, 1) - &
+                     lfcp(il, 1)*sigd(il)*evap(il, 1)*faci(il, 1) - &
+                     lfcp(il, 1)*sigd(il)*(fondue(il,1)*wt(il,1)) / &
+                       (100.*(ph(il,1)-ph(il,2)))                             !precip
+      ELSE
+        ft(il, 1) = -lvcp(il, 1)*sigd(il)*evap(il, 1)
+      END IF
+
+      ft(il, 1) = ft(il, 1) - 0.009*grav*sigd(il)*mp(il, 2)*t_wake(il, 1)*b(il, 1)*work(il)
+
+      IF (cvflag_ice) THEN
+        ft(il, 1) = ft(il, 1) + 0.01*sigd(il)*wt(il, 1)*(cl-cpd)*water(il, 2) * &
+                                     (t_wake(il,2)-t_wake(il,1))*work(il)/cpn(il, 1) + &
+                                0.01*sigd(il)*wt(il, 1)*(ci-cpd)*ice(il, 2) * &
+                                     (t_wake(il,2)-t_wake(il,1))*work(il)/cpn(il, 1)
+      ELSE
+        ft(il, 1) = ft(il, 1) + 0.01*sigd(il)*wt(il, 1)*(cl-cpd)*water(il, 2) * &
+                                     (t_wake(il,2)-t_wake(il,1))*work(il)/cpn(il, 1)
+      END IF
+
+      ftd(il, 1) = ft(il, 1)                                                  ! fin precip
+
+      IF ((0.01*grav*work(il)*am(il))>=delti) iflag(il) = 1 !consist vect
+!jyg<
+        IF (fl_cor_ebil >= 2) THEN
+          ft(il, 1) = ft(il, 1) + 0.01*grav*work(il)*am(il) * &
+                    ((t(il,2)-t(il,1))*cpn(il,2)+gz(il,2)-gz(il,1))/cpn(il,1)
+        ELSE
+          ft(il, 1) = ft(il, 1) + 0.01*grav*work(il)*am(il) * &
+                    (t(il,2)-t(il,1)+(gz(il,2)-gz(il,1))/cpn(il,1))
+        ENDIF
+!>jyg
+    END IF ! iflag
+  END DO
+
+
+  DO j = 2, nl
+    IF (iflag_mix>0) THEN
+      DO il = 1, ncum
+! FH WARNING a modifier :
+        cpinv = 0.
+! cpinv=1.0/cpn(il,1)
+        IF (j<=inb(il) .AND. iflag(il)<=1) THEN
+          ft(il, 1) = ft(il, 1) + 0.01*grav*work(il)*ment(il, j, 1) * &
+                     (hent(il,j,1)-h(il,1)+t(il,1)*(cpv-cpd)*(rr(il,1)-qent(il,j,1)))*cpinv
+        END IF ! j
+      END DO
+    END IF
+  END DO
+! fin sature
+
+
+  DO il = 1, ncum
+    IF (iflag(il)<=1) THEN
+!JYG1  Correction pour mieux conserver l'eau (conformite avec CONVECT4.3)
+      fr(il, 1) = 0.01*grav*mp(il, 2)*(rp(il,2)-rr_wake(il,1))*work(il) + &
+                  sigd(il)*evap(il, 1)
+!!!                  sigd(il)*0.5*(evap(il,1)+evap(il,2))
+
+      fqd(il, 1) = fr(il, 1) !precip
+
+      fr(il, 1) = fr(il, 1) + 0.01*grav*am(il)*(rr(il,2)-rr(il,1))*work(il)        !sature
+
+      fu(il, 1) = fu(il, 1) + 0.01*grav*work(il)*(mp(il,2)*(up(il,2)-u(il,1)) + &
+                                                  am(il)*(u(il,2)-u(il,1)))
+      fv(il, 1) = fv(il, 1) + 0.01*grav*work(il)*(mp(il,2)*(vp(il,2)-v(il,1)) + &
+                                                  am(il)*(v(il,2)-v(il,1)))
+    END IF ! iflag
+  END DO ! il
+
+
+!AC!     do j=1,ntra
+!AC!      do il=1,ncum
+!AC!       if (iflag(il) .le. 1) then
+!AC!       if (cvflag_grav) then
+!AC!        ftra(il,1,j)=ftra(il,1,j)+0.01*grav*work(il)
+!AC!    :                     *(mp(il,2)*(trap(il,2,j)-tra(il,1,j))
+!AC!    :             +am(il)*(tra(il,2,j)-tra(il,1,j)))
+!AC!       else
+!AC!        ftra(il,1,j)=ftra(il,1,j)+0.1*work(il)
+!AC!    :                     *(mp(il,2)*(trap(il,2,j)-tra(il,1,j))
+!AC!    :             +am(il)*(tra(il,2,j)-tra(il,1,j)))
+!AC!       endif
+!AC!       endif  ! iflag
+!AC!      enddo
+!AC!     enddo
+
+  DO j = 2, nl
+    DO il = 1, ncum
+      IF (j<=inb(il) .AND. iflag(il)<=1) THEN
+        fr(il, 1) = fr(il, 1) + 0.01*grav*work(il)*ment(il, j, 1)*(qent(il,j,1)-rr(il,1))
+        fr_comp(il,1) = fr_comp(il,1) + 0.01*grav*work(il)*ment(il, j, 1)*(qent(il,j,1)-rr(il,1))
+        fu(il, 1) = fu(il, 1) + 0.01*grav*work(il)*ment(il, j, 1)*(uent(il,j,1)-u(il,1))
+        fv(il, 1) = fv(il, 1) + 0.01*grav*work(il)*ment(il, j, 1)*(vent(il,j,1)-v(il,1))
+      END IF ! j
+    END DO
+  END DO
+
+!AC!      do k=1,ntra
+!AC!       do j=2,nl
+!AC!        do il=1,ncum
+!AC!         if (j.le.inb(il) .and. iflag(il) .le. 1) then
+!AC!
+!AC!          if (cvflag_grav) then
+!AC!           ftra(il,1,k)=ftra(il,1,k)+0.01*grav*work(il)*ment(il,j,1)
+!AC!     :                *(traent(il,j,1,k)-tra(il,1,k))
+!AC!          else
+!AC!           ftra(il,1,k)=ftra(il,1,k)+0.1*work(il)*ment(il,j,1)
+!AC!     :                *(traent(il,j,1,k)-tra(il,1,k))
+!AC!          endif
+!AC!
+!AC!         endif
+!AC!        enddo
+!AC!       enddo
+!AC!      enddo
+! print*,'cv3_yield apres ft'
+
+!jyg<
+!-----------------------------------------------------------
+           IF (ok_optim_yield) THEN                       !|
+!-----------------------------------------------------------
+!
+!***                                                      ***
+!***    Compute convective mass fluxes upwd and dnwd      ***
+
+!
+! =================================================
+!              upward fluxes                      |
+! ------------------------------------------------
+!
+upwd(:,:) = 0.
+up_to(:,:) = 0.
+up_from(:,:) = 0.
+!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+  IF (adiab_ascent_mass_flux_depends_on_ejectliq) THEN
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! The decrease of the adiabatic ascent mass flux due to ejection of precipitation 
+!! is taken into account. 
+!! WARNING : in the present version, taking into account the mass-flux decrease due to 
+!! precipitation ejection leads to water conservation violation.
+!
+! - Upward mass flux of mixed draughts
+!---------------------------------------
+DO i = 2, nl
+  DO j = 1, i-1
+    DO il = 1, ncum
+      IF (i<=inb(il)) THEN
+        up_to(il,i) = up_to(il,i) + ment(il,j,i)
+      ENDIF
+    ENDDO
+  ENDDO
+ENDDO
+!
+DO j = 3, nl
+  DO i = 2, j-1
+    DO il = 1, ncum
+      IF (j<=inb(il)) THEN
+        up_from(il,i) = up_from(il,i) + ment(il,i,j)
+      ENDIF
+    ENDDO
+  ENDDO
+ENDDO
+!
+! The difference between upwd(il,i) and upwd(il,i-1) is due to updrafts ending in layer 
+!(i-1) (theses drafts cross interface (i-1) but not interface(i)) and to updrafts starting 
+!from layer (i-1) (theses drafts cross interface (i) but not interface(i-1)): 
+! 
+DO i = 2, nlp
+  DO il = 1, ncum
+    IF (i<=inb(il)+1) THEN
+      upwd(il,i) = max(0., upwd(il,i-1) - up_to(il,i-1) + up_from(il,i-1))
+    ENDIF
+  ENDDO
+ENDDO
+!
+! - Total upward mass flux
+!---------------------------
+DO i = 2, nlp
+  DO il = 1, ncum
+    IF (i<=inb(il)+1) THEN
+      upwd(il,i) = upwd(il,i) + ma(il,i)
+    ENDIF
+  ENDDO
+ENDDO
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+  ELSE ! (adiab_ascent_mass_flux_depends_on_ejectliq)
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! The decrease of the adiabatic ascent mass flux due to ejection of precipitation 
+!! is not taken into account. 
+!
+! - Upward mass flux
+!-------------------
+DO i = 2, nl
+  DO il = 1, ncum
+    IF (i<=inb(il)) THEN
+      up_to(il,i) = m(il,i)
+    ENDIF
+  ENDDO
+  DO j = 1, i-1
+    DO il = 1, ncum
+      IF (i<=inb(il)) THEN
+        up_to(il,i) = up_to(il,i) + ment(il,j,i)
+      ENDIF
+    ENDDO
+  ENDDO
+ENDDO
+!
+DO i = 1, nl
+  DO il = 1, ncum
+    IF (i<=inb(il)) THEN
+      up_from(il,i) = cbmf(il)*wghti(il,i)
+    ENDIF
+  ENDDO
+ENDDO
+!
+DO j = 3, nl
+  DO i = 2, j-1
+    DO il = 1, ncum
+      IF (j<=inb(il)) THEN
+        up_from(il,i) = up_from(il,i) + ment(il,i,j)
+      ENDIF
+    ENDDO
+  ENDDO
+ENDDO
+!
+! The difference between upwd(il,i) and upwd(il,i-1) is due to updrafts ending in layer 
+!(i-1) (theses drafts cross interface (i-1) but not interface(i)) and to updrafts starting 
+!from layer (i-1) (theses drafts cross interface (i) but not interface(i-1)): 
+! 
+DO i = 2, nlp
+  DO il = 1, ncum
+    IF (i<=inb(il)+1) THEN
+      upwd(il,i) = max(0., upwd(il,i-1) - up_to(il,i-1) + up_from(il,i-1))
+    ENDIF
+  ENDDO
+ENDDO
+
+
+  ENDIF ! (adiab_ascent_mass_flux_depends_on_ejectliq) ELSE
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+!
+! =================================================
+!              downward fluxes                    |
+! ------------------------------------------------
+dnwd(:,:) = 0.
+dn_to(:,:) = 0.
+dn_from(:,:) = 0.
+DO i = 1, nl
+  DO j = i+1, nl
+    DO il = 1, ncum
+      IF (j<=inb(il)) THEN
+!!        dn_to(il,i) = dn_to(il,i) + ment(il,j,i)       !jyg,20220202
+        dn_to(il,i) = dn_to(il,i) - ment(il,j,i)
+      ENDIF
+    ENDDO
+  ENDDO
+ENDDO
+!
+DO j = 1, nl
+  DO i = j+1, nl
+    DO il = 1, ncum
+      IF (i<=inb(il)) THEN
+!!        dn_from(il,i) = dn_from(il,i) + ment(il,i,j)   !jyg,20220202
+        dn_from(il,i) = dn_from(il,i) - ment(il,i,j)
+      ENDIF
+    ENDDO
+  ENDDO
+ENDDO
+!
+! The difference between dnwd(il,i) and dnwd(il,i+1) is due to downdrafts ending in layer 
+!(i) (theses drafts cross interface (i+1) but not interface(i)) and to downdrafts 
+!starting from layer (i) (theses drafts cross interface (i) but not interface(i+1)): 
+!
+DO i = nl-1, 1, -1
+  DO il = 1, ncum
+!!    dnwd(il,i) = max(0., dnwd(il,i+1) - dn_to(il,i) + dn_from(il,i)) !jyg,20220202
+    dnwd(il,i) = min(0., dnwd(il,i+1) - dn_to(il,i) + dn_from(il,i))
+  ENDDO
+ENDDO
+! =================================================
+!
+!-----------------------------------------------------------
+        ENDIF !(ok_optim_yield)                           !|
+!-----------------------------------------------------------
+!>jyg
+
+! ***  calculate tendencies of potential temperature and mixing ratio  ***
+! ***               at levels above the lowest level                   ***
+
+! ***  first find the net saturated updraft and downdraft mass fluxes  ***
+! ***                      through each level                          ***
+
+
+!jyg<
+!!  DO i = 2, nl + 1 ! newvecto: mettre nl au lieu nl+1?
+  DO i = 2, nl
+!>jyg 
+
+    num1 = 0
+    DO il = 1, ncum
+      IF (i<=inb(il) .AND. iflag(il)<=1) num1 = num1 + 1
+    END DO
+    IF (num1<=0) GO TO 500
+
+!
+!jyg<
+!-----------------------------------------------------------
+           IF (ok_optim_yield) THEN                       !|
+!-----------------------------------------------------------
+DO il = 1, ncum
+   amp1(il) = upwd(il,i+1)
+   ad(il) = dnwd(il,i)
+ENDDO
+!-----------------------------------------------------------
+        ELSE !(ok_optim_yield)                            !|
+!-----------------------------------------------------------
+!>jyg
+    DO il = 1,ncum
+      amp1(il) = 0.
+      ad(il) = 0.
+    ENDDO
+
+    DO k = 1, nl + 1
+      DO il = 1, ncum
+        IF (i>=icb(il)) THEN
+          IF (k>=i+1 .AND. k<=(inb(il)+1)) THEN
+            amp1(il) = amp1(il) + m(il, k)
+          END IF
+        ELSE
+! AMP1 is the part of cbmf taken from layers I and lower
+          IF (k<=i) THEN
+            amp1(il) = amp1(il) + cbmf(il)*wghti(il, k)
+          END IF
+        END IF
+      END DO
+    END DO
+
+    DO j = i + 1, nl + 1         
+       DO k = 1, i
+          !yor! reverted j and k loops 
+          DO il = 1, ncum
+!yor!        IF (i<=inb(il) .AND. j<=(inb(il)+1)) THEN ! the second condition implies the first !
+             IF (j<=(inb(il)+1)) THEN  
+                amp1(il) = amp1(il) + ment(il, k, j)
+             END IF
+          END DO
+       END DO
+    END DO
+
+    DO k = 1, i - 1
+!jyg<
+!!      DO j = i, nl + 1 ! newvecto: nl au lieu nl+1?
+      DO j = i, nl
+!>jyg
+        DO il = 1, ncum
+!yor!        IF (i<=inb(il) .AND. j<=inb(il)) THEN ! the second condition implies the 1st !
+             IF (j<=inb(il)) THEN   
+            ad(il) = ad(il) + ment(il, j, k)
+          END IF
+        END DO
+      END DO
+    END DO
+!
+!-----------------------------------------------------------
+        ENDIF !(ok_optim_yield)                           !|
+!-----------------------------------------------------------
+!
+!!   print *,'yield, i, amp1, ad', i, amp1(1), ad(1)
+
+    DO il = 1, ncum
+      IF (i<=inb(il) .AND. iflag(il)<=1) THEN
+        dpinv = 1.0/(ph(il,i)-ph(il,i+1))
+        cpinv = 1.0/cpn(il, i)
+
+! convect3      if((0.1*dpinv*amp1).ge.delti)iflag(il)=4
+        IF ((0.01*grav*dpinv*amp1(il))>=delti) iflag(il) = 1 ! vecto
+
+! precip
+! cc       ft(il,i)= -0.5*sigd(il)*lvcp(il,i)*(evap(il,i)+evap(il,i+1))
+        IF (cvflag_ice) THEN
+          ft(il, i) = -sigd(il)*lvcp(il, i)*evap(il, i) - &
+                       sigd(il)*lfcp(il, i)*evap(il, i)*faci(il, i) - &
+                       sigd(il)*lfcp(il, i)*fondue(il, i)*wt(il, i)/(100.*(p(il,i-1)-p(il,i)))
+        ELSE
+          ft(il, i) = -sigd(il)*lvcp(il, i)*evap(il, i)
+        END IF
+
+        rat = cpn(il, i-1)*cpinv
+
+        ft(il, i) = ft(il, i) - 0.009*grav*sigd(il) * &
+                     (mp(il,i+1)*t_wake(il,i)*b(il,i)-mp(il,i)*t_wake(il,i-1)*rat*b(il,i-1))*dpinv
+        IF (cvflag_ice) THEN
+          ft(il, i) = ft(il, i) + 0.01*sigd(il)*wt(il, i)*(cl-cpd)*water(il, i+1) * &
+                                       (t_wake(il,i+1)-t_wake(il,i))*dpinv*cpinv + &
+                                  0.01*sigd(il)*wt(il, i)*(ci-cpd)*ice(il, i+1) * &
+                                       (t_wake(il,i+1)-t_wake(il,i))*dpinv*cpinv
+        ELSE
+          ft(il, i) = ft(il, i) + 0.01*sigd(il)*wt(il, i)*(cl-cpd)*water(il, i+1) * &
+                                       (t_wake(il,i+1)-t_wake(il,i))*dpinv* &
+            cpinv
+        END IF
+
+        ftd(il, i) = ft(il, i)
+! fin precip
+
+! sature
+!jyg<
+        IF (fl_cor_ebil >= 2) THEN
+          ft(il, i) = ft(il, i) + 0.01*grav*dpinv * &
+              ( amp1(il)*( (t(il,i+1)-t(il,i))*cpn(il,i+1) + gz(il,i+1)-gz(il,i))*cpinv - &
+                ad(il)*( (t(il,i)-t(il,i-1))*cpn(il,i-1) + gz(il,i)-gz(il,i-1))*cpinv)
+        ELSE
+          ft(il, i) = ft(il, i) + 0.01*grav*dpinv * &
+                     (amp1(il)*(t(il,i+1)-t(il,i) + (gz(il,i+1)-gz(il,i))*cpinv) - &
+                      ad(il)*(t(il,i)-t(il,i-1)+(gz(il,i)-gz(il,i-1))*cpinv))
+        ENDIF
+!>jyg
+
+
+        IF (iflag_mix==0) THEN
+          ft(il, i) = ft(il, i) + 0.01*grav*dpinv*ment(il, i, i)*(hp(il,i)-h(il,i) + &
+                                    t(il,i)*(cpv-cpd)*(rr(il,i)-qent(il,i,i)))*cpinv
+        END IF
+!
+! sb: on ne fait pas encore la correction permettant de mieux
+! conserver l'eau:
+!JYG: correction permettant de mieux conserver l'eau:
+! cc         fr(il,i)=0.5*sigd(il)*(evap(il,i)+evap(il,i+1))
+        fr(il, i) = sigd(il)*evap(il, i) + 0.01*grav*(mp(il,i+1)*(rp(il,i+1)-rr_wake(il,i)) - &
+                                                      mp(il,i)*(rp(il,i)-rr_wake(il,i-1)))*dpinv
+        fqd(il, i) = fr(il, i)                                                                     ! precip
+
+        fu(il, i) = 0.01*grav*(mp(il,i+1)*(up(il,i+1)-u(il,i)) - &
+                               mp(il,i)*(up(il,i)-u(il,i-1)))*dpinv
+        fv(il, i) = 0.01*grav*(mp(il,i+1)*(vp(il,i+1)-v(il,i)) - &
+                               mp(il,i)*(vp(il,i)-v(il,i-1)))*dpinv
+
+
+        fr(il, i) = fr(il, i) + 0.01*grav*dpinv*(amp1(il)*(rr(il,i+1)-rr(il,i)) - &
+                                                 ad(il)*(rr(il,i)-rr(il,i-1)))
+        fu(il, i) = fu(il, i) + 0.01*grav*dpinv*(amp1(il)*(u(il,i+1)-u(il,i)) - &
+                                                 ad(il)*(u(il,i)-u(il,i-1)))
+        fv(il, i) = fv(il, i) + 0.01*grav*dpinv*(amp1(il)*(v(il,i+1)-v(il,i)) - &
+                                                 ad(il)*(v(il,i)-v(il,i-1)))
+
+      END IF ! i
+    END DO
+
+!AC!      do k=1,ntra
+!AC!       do il=1,ncum
+!AC!        if (i.le.inb(il) .and. iflag(il) .le. 1) then
+!AC!         dpinv=1.0/(ph(il,i)-ph(il,i+1))
+!AC!         cpinv=1.0/cpn(il,i)
+!AC!         if (cvflag_grav) then
+!AC!           ftra(il,i,k)=ftra(il,i,k)+0.01*grav*dpinv
+!AC!     :         *(amp1(il)*(tra(il,i+1,k)-tra(il,i,k))
+!AC!     :           -ad(il)*(tra(il,i,k)-tra(il,i-1,k)))
+!AC!         else
+!AC!           ftra(il,i,k)=ftra(il,i,k)+0.1*dpinv
+!AC!     :         *(amp1(il)*(tra(il,i+1,k)-tra(il,i,k))
+!AC!     :           -ad(il)*(tra(il,i,k)-tra(il,i-1,k)))
+!AC!         endif
+!AC!        endif
+!AC!       enddo
+!AC!      enddo
+
+    DO k = 1, i - 1
+
+      DO il = 1, ncum
+        awat(il) = elij(il, k, i) - (1.-ep(il,i))*clw(il, i)
+        awat(il) = max(awat(il), 0.0)
+      END DO
+
+      IF (iflag_mix/=0) THEN
+        DO il = 1, ncum
+          IF (i<=inb(il) .AND. iflag(il)<=1) THEN
+            dpinv = 1.0/(ph(il,i)-ph(il,i+1))
+            cpinv = 1.0/cpn(il, i)
+            ft(il, i) = ft(il, i) + 0.01*grav*dpinv*ment(il, k, i) * &
+                 (hent(il,k,i)-h(il,i)+t(il,i)*(cpv-cpd)*(rr(il,i)+awat(il)-qent(il,k,i)))*cpinv
+!
+!
+          END IF ! i
+        END DO
+      END IF
+
+      DO il = 1, ncum
+        IF (i<=inb(il) .AND. iflag(il)<=1) THEN
+          dpinv = 1.0/(ph(il,i)-ph(il,i+1))
+          cpinv = 1.0/cpn(il, i)
+          fr(il, i) = fr(il, i) + 0.01*grav*dpinv*ment(il, k, i) * &
+                                                       (qent(il,k,i)-awat(il)-rr(il,i))
+          fr_comp(il,i) = fr_comp(il,i) + 0.01*grav*dpinv*ment(il, k, i)*(qent(il,k,i)-awat(il)-rr(il,i))
+          fu(il, i) = fu(il, i) + 0.01*grav*dpinv*ment(il, k, i)*(uent(il,k,i)-u(il,i))
+          fv(il, i) = fv(il, i) + 0.01*grav*dpinv*ment(il, k, i)*(vent(il,k,i)-v(il,i))
+
+! (saturated updrafts resulting from mixing)                                   ! cld
+          qcond(il, i) = qcond(il, i) + (elij(il,k,i)-awat(il))                ! cld
+          qdet(il,k,i) = (qent(il,k,i)-awat(il))                               ! cld Louis : specific humidity in detraining water
+          qtment(il, i) = qtment(il, i) + qent(il,k,i)                         ! cld
+          nqcond(il, i) = nqcond(il, i) + 1.                                   ! cld
+        END IF ! i
+      END DO
+    END DO
+
+!AC!      do j=1,ntra
+!AC!       do k=1,i-1
+!AC!        do il=1,ncum
+!AC!         if (i.le.inb(il) .and. iflag(il) .le. 1) then
+!AC!          dpinv=1.0/(ph(il,i)-ph(il,i+1))
+!AC!          cpinv=1.0/cpn(il,i)
+!AC!          if (cvflag_grav) then
+!AC!           ftra(il,i,j)=ftra(il,i,j)+0.01*grav*dpinv*ment(il,k,i)
+!AC!     :        *(traent(il,k,i,j)-tra(il,i,j))
+!AC!          else
+!AC!           ftra(il,i,j)=ftra(il,i,j)+0.1*dpinv*ment(il,k,i)
+!AC!     :        *(traent(il,k,i,j)-tra(il,i,j))
+!AC!          endif
+!AC!         endif
+!AC!        enddo
+!AC!       enddo
+!AC!      enddo
+
+!jyg<
+!!    DO k = i, nl + 1
+    DO k = i, nl
+!>jyg
+
+      IF (iflag_mix/=0) THEN
+        DO il = 1, ncum
+          IF (i<=inb(il) .AND. k<=inb(il) .AND. iflag(il)<=1) THEN
+            dpinv = 1.0/(ph(il,i)-ph(il,i+1))
+            cpinv = 1.0/cpn(il, i)
+            ft(il, i) = ft(il, i) + 0.01*grav*dpinv*ment(il, k, i) * &
+                  (hent(il,k,i)-h(il,i)+t(il,i)*(cpv-cpd)*(rr(il,i)-qent(il,k,i)))*cpinv
+
+
+          END IF ! i
+        END DO
+      END IF
+
+      DO il = 1, ncum
+        IF (i<=inb(il) .AND. k<=inb(il) .AND. iflag(il)<=1) THEN
+          dpinv = 1.0/(ph(il,i)-ph(il,i+1))
+          cpinv = 1.0/cpn(il, i)
+
+          fr(il, i) = fr(il, i) + 0.01*grav*dpinv*ment(il, k, i)*(qent(il,k,i)-rr(il,i))
+          fu(il, i) = fu(il, i) + 0.01*grav*dpinv*ment(il, k, i)*(uent(il,k,i)-u(il,i))
+          fv(il, i) = fv(il, i) + 0.01*grav*dpinv*ment(il, k, i)*(vent(il,k,i)-v(il,i))
+        END IF ! i and k
+      END DO
+    END DO
+
+!AC!      do j=1,ntra
+!AC!       do k=i,nl+1
+!AC!        do il=1,ncum
+!AC!         if (i.le.inb(il) .and. k.le.inb(il)
+!AC!     $                .and. iflag(il) .le. 1) then
+!AC!          dpinv=1.0/(ph(il,i)-ph(il,i+1))
+!AC!          cpinv=1.0/cpn(il,i)
+!AC!          if (cvflag_grav) then
+!AC!           ftra(il,i,j)=ftra(il,i,j)+0.01*grav*dpinv*ment(il,k,i)
+!AC!     :         *(traent(il,k,i,j)-tra(il,i,j))
+!AC!          else
+!AC!           ftra(il,i,j)=ftra(il,i,j)+0.1*dpinv*ment(il,k,i)
+!AC!     :             *(traent(il,k,i,j)-tra(il,i,j))
+!AC!          endif
+!AC!         endif ! i and k
+!AC!        enddo
+!AC!       enddo
+!AC!      enddo
+
+! sb: interface with the cloud parameterization:                               ! cld
+
+    DO k = i + 1, nl
+      DO il = 1, ncum
+        IF (k<=inb(il) .AND. i<=inb(il) .AND. iflag(il)<=1) THEN               ! cld
+! (saturated downdrafts resulting from mixing)                                 ! cld
+          qcond(il, i) = qcond(il, i) + elij(il, k, i)                         ! cld
+          qdet(il,k,i) = qent(il,k,i)                                          ! cld Louis : specific humidity in detraining water
+          qtment(il, i) = qent(il,k,i) + qtment(il,i)                          ! cld
+          nqcond(il, i) = nqcond(il, i) + 1.                                   ! cld
+        END IF ! cld
+      END DO ! cld
+    END DO ! cld
+
+!ym BIG Warning : it seems that the k loop is missing !!!
+!ym Strong advice to check this
+!ym add a k loop temporary 
+
+! (particular case: no detraining level is found)                              ! cld
+! Verif merge Dynamico<<<<<<< .working
+    DO il = 1, ncum                                                            ! cld
+      IF (i<=inb(il) .AND. nent(il,i)==0 .AND. iflag(il)<=1) THEN              ! cld
+        qcond(il, i) = qcond(il, i) + (1.-ep(il,i))*clw(il, i)                 ! cld
+!jyg<   Bug correction 20180620
+!      PROBLEM: Should not qent(il,i,i) be taken into account even if nent(il,i)/=0?
+!!        qtment(il, i) = qent(il,k,i) + qtment(il,i)                            ! cld
+        qdet(il,i,i) = qent(il,i,i)                                            ! cld Louis : specific humidity in detraining water
+        qtment(il, i) = qent(il,i,i) + qtment(il,i)                            ! cld
+!>jyg
+        nqcond(il, i) = nqcond(il, i) + 1.                                     ! cld
+      END IF                                                                   ! cld
+    END DO                                                                     ! cld
+! Verif merge Dynamico =======
+! Verif merge Dynamico     DO k = i + 1, nl
+! Verif merge Dynamico       DO il = 1, ncum        !ym k loop added                                    ! cld
+! Verif merge Dynamico         IF (i<=inb(il) .AND. nent(il,i)==0 .AND. iflag(il)<=1) THEN              ! cld
+! Verif merge Dynamico           qcond(il, i) = qcond(il, i) + (1.-ep(il,i))*clw(il, i)                 ! cld
+! Verif merge Dynamico           qtment(il, i) = qent(il,k,i) + qtment(il,i)                          ! cld
+! Verif merge Dynamico           nqcond(il, i) = nqcond(il, i) + 1.                                     ! cld
+! Verif merge Dynamico         END IF                                                                   ! cld
+! Verif merge Dynamico       END DO
+! Verif merge Dynamico     ENDDO                                                                     ! cld
+! Verif merge Dynamico >>>>>>> .merge-right.r3413
+
+    DO il = 1, ncum                                                            ! cld
+      IF (i<=inb(il) .AND. nqcond(il,i)/=0 .AND. iflag(il)<=1) THEN            ! cld
+        qcond(il, i) = qcond(il, i)/nqcond(il, i)                              ! cld
+        qtment(il, i) = qtment(il,i)/nqcond(il, i)                             ! cld
+      END IF                                                                   ! cld
+    END DO
+
+!AC!      do j=1,ntra
+!AC!       do il=1,ncum
+!AC!        if (i.le.inb(il) .and. iflag(il) .le. 1) then
+!AC!         dpinv=1.0/(ph(il,i)-ph(il,i+1))
+!AC!         cpinv=1.0/cpn(il,i)
+!AC!
+!AC!         if (cvflag_grav) then
+!AC!          ftra(il,i,j)=ftra(il,i,j)+0.01*grav*dpinv
+!AC!     :     *(mp(il,i+1)*(trap(il,i+1,j)-tra(il,i,j))
+!AC!     :     -mp(il,i)*(trap(il,i,j)-trap(il,i-1,j)))
+!AC!         else
+!AC!          ftra(il,i,j)=ftra(il,i,j)+0.1*dpinv
+!AC!     :     *(mp(il,i+1)*(trap(il,i+1,j)-tra(il,i,j))
+!AC!     :     -mp(il,i)*(trap(il,i,j)-trap(il,i-1,j)))
+!AC!         endif
+!AC!        endif ! i
+!AC!       enddo
+!AC!      enddo
+
+
+500 END DO
+
+!JYG<
+!Conservation de l'eau
+!   sumdq = 0.
+!   DO k = 1, nl
+!     sumdq = sumdq + fr(1, k)*100.*(ph(1,k)-ph(1,k+1))/grav
+!   END DO
+!   PRINT *, 'cv3_yield, apres 500, sum(dq), precip, somme ', sumdq, Vprecip(1, 1), sumdq + vprecip(1, 1)
+!JYG>
+! ***   move the detrainment at level inb down to level inb-1   ***
+! ***        in such a way as to preserve the vertically        ***
+! ***          integrated enthalpy and water tendencies         ***
+
+! Correction bug le 18-03-09
+  DO il = 1, ncum
+    IF (iflag(il)<=1) THEN
+      ax = 0.01*grav*ment(il, inb(il), inb(il))* &
+           (hp(il,inb(il))-h(il,inb(il))+t(il,inb(il))*(cpv-cpd)*(rr(il,inb(il))-qent(il,inb(il),inb(il))))/ &
+                                (cpn(il,inb(il))*(ph(il,inb(il))-ph(il,inb(il)+1)))
+      ft(il, inb(il)) = ft(il, inb(il)) - ax
+      ft(il, inb(il)-1) = ft(il, inb(il)-1) + ax*cpn(il, inb(il))*(ph(il,inb(il))-ph(il,inb(il)+1))/ &
+                              (cpn(il,inb(il)-1)*(ph(il,inb(il)-1)-ph(il,inb(il))))
+
+      bx = 0.01*grav*ment(il, inb(il), inb(il))*(qent(il,inb(il),inb(il))-rr(il,inb(il)))/ &
+                                                 (ph(il,inb(il))-ph(il,inb(il)+1))
+      fr(il, inb(il)) = fr(il, inb(il)) - bx
+      fr(il, inb(il)-1) = fr(il, inb(il)-1) + bx*(ph(il,inb(il))-ph(il,inb(il)+1))/ &
+                                                 (ph(il,inb(il)-1)-ph(il,inb(il)))
+
+      cx = 0.01*grav*ment(il, inb(il), inb(il))*(uent(il,inb(il),inb(il))-u(il,inb(il)))/ &
+                                                 (ph(il,inb(il))-ph(il,inb(il)+1))
+      fu(il, inb(il)) = fu(il, inb(il)) - cx
+      fu(il, inb(il)-1) = fu(il, inb(il)-1) + cx*(ph(il,inb(il))-ph(il,inb(il)+1))/ &
+                                                 (ph(il,inb(il)-1)-ph(il,inb(il)))
+
+      dx = 0.01*grav*ment(il, inb(il), inb(il))*(vent(il,inb(il),inb(il))-v(il,inb(il)))/ &
+                                                 (ph(il,inb(il))-ph(il,inb(il)+1))
+      fv(il, inb(il)) = fv(il, inb(il)) - dx
+      fv(il, inb(il)-1) = fv(il, inb(il)-1) + dx*(ph(il,inb(il))-ph(il,inb(il)+1))/ &
+                                                 (ph(il,inb(il)-1)-ph(il,inb(il)))
+    END IF !iflag
+  END DO
+
+!JYG<
+!Conservation de l'eau
+!   sumdq = 0.
+!   DO k = 1, nl
+!     sumdq = sumdq + fr(1, k)*100.*(ph(1,k)-ph(1,k+1))/grav
+!   END DO
+!   PRINT *, 'cv3_yield, apres 503, sum(dq), precip, somme ', sumdq, Vprecip(1, 1), sumdq + vprecip(1, 1)
+!JYG>
+
+!AC!      do j=1,ntra
+!AC!       do il=1,ncum
+!AC!        IF (iflag(il) .le. 1) THEN
+!AC!	IF (cvflag_grav) then
+!AC!        ex=0.01*grav*ment(il,inb(il),inb(il))
+!AC!     :      *(traent(il,inb(il),inb(il),j)-tra(il,inb(il),j))
+!AC!     :      /(ph(i l,inb(il))-ph(il,inb(il)+1))
+!AC!        ftra(il,inb(il),j)=ftra(il,inb(il),j)-ex
+!AC!        ftra(il,inb(il)-1,j)=ftra(il,inb(il)-1,j)
+!AC!     :       +ex*(ph(il,inb(il))-ph(il,inb(il)+1))
+!AC!     :          /(ph(il,inb(il)-1)-ph(il,inb(il)))
+!AC!	else
+!AC!        ex=0.1*ment(il,inb(il),inb(il))
+!AC!     :      *(traent(il,inb(il),inb(il),j)-tra(il,inb(il),j))
+!AC!     :      /(ph(i l,inb(il))-ph(il,inb(il)+1))
+!AC!        ftra(il,inb(il),j)=ftra(il,inb(il),j)-ex
+!AC!        ftra(il,inb(il)-1,j)=ftra(il,inb(il)-1,j)
+!AC!     :       +ex*(ph(il,inb(il))-ph(il,inb(il)+1))
+!AC!     :          /(ph(il,inb(il)-1)-ph(il,inb(il)))
+!AC!        ENDIF   !cvflag grav
+!AC!        ENDIF    !iflag
+!AC!       enddo
+!AC!      enddo
+
+
+! ***    homogenize tendencies below cloud base    ***
+
+
+  DO il = 1, ncum
+    asum(il) = 0.0
+    bsum(il) = 0.0
+    csum(il) = 0.0
+    dsum(il) = 0.0
+    esum(il) = 0.0
+    fsum(il) = 0.0
+    gsum(il) = 0.0
+    hsum(il) = 0.0
+  END DO
+
+!do i=1,nl
+!do il=1,ncum
+!th_wake(il,i)=t_wake(il,i)*(1000.0/p(il,i))**rdcp
+!enddo
+!enddo
+
+  DO i = 1, nl
+    DO il = 1, ncum
+      IF (i<=(icb(il)-1) .AND. iflag(il)<=1) THEN
+!jyg  Saturated part : use T profile
+        asum(il) = asum(il) + (ft(il,i)-ftd(il,i))*(ph(il,i)-ph(il,i+1))
+!jyg<20140311
+!Correction pour conserver l eau
+        IF (ok_conserv_q) THEN
+          bsum(il) = bsum(il) + (fr(il,i)-fqd(il,i))*(ph(il,i)-ph(il,i+1))
+          csum(il) = csum(il) + (ph(il,i)-ph(il,i+1))
+
+        ELSE
+          bsum(il)=bsum(il)+(fr(il,i)-fqd(il,i))*(lv(il,i)+(cl-cpd)*(t(il,i)-t(il,1)))* &
+                            (ph(il,i)-ph(il,i+1))
+          csum(il)=csum(il)+(lv(il,i)+(cl-cpd)*(t(il,i)-t(il,1)))* &
+                            (ph(il,i)-ph(il,i+1))
+        ENDIF ! (ok_conserv_q)
+!jyg>
+        dsum(il) = dsum(il) + t(il, i)*(ph(il,i)-ph(il,i+1))/th(il, i)
+!jyg  Unsaturated part : use T_wake profile
+        esum(il) = esum(il) + ftd(il, i)*(ph(il,i)-ph(il,i+1))
+!jyg<20140311
+!Correction pour conserver l eau
+        IF (ok_conserv_q) THEN
+          fsum(il) = fsum(il) + fqd(il, i)*(ph(il,i)-ph(il,i+1))
+          gsum(il) = gsum(il) + (ph(il,i)-ph(il,i+1))
+        ELSE
+          fsum(il)=fsum(il)+fqd(il,i)*(lv(il,i)+(cl-cpd)*(t_wake(il,i)-t_wake(il,1)))* &
+                            (ph(il,i)-ph(il,i+1))
+          gsum(il)=gsum(il)+(lv(il,i)+(cl-cpd)*(t_wake(il,i)-t_wake(il,1)))* &
+                            (ph(il,i)-ph(il,i+1))
+        ENDIF ! (ok_conserv_q)
+!jyg>
+        hsum(il) = hsum(il) + t_wake(il, i)*(ph(il,i)-ph(il,i+1))/th_wake(il, i)
+      END IF
+    END DO
+  END DO
+
+!!!!      do 700 i=1,icb(il)-1
+  IF (ok_homo_tend) THEN
+    DO i = 1, nl
+      DO il = 1, ncum
+        IF (i<=(icb(il)-1) .AND. iflag(il)<=1) THEN
+          ftd(il, i) = esum(il)*t_wake(il, i)/(th_wake(il,i)*hsum(il))
+          fqd(il, i) = fsum(il)/gsum(il)
+          ft(il, i) = ftd(il, i) + asum(il)*t(il, i)/(th(il,i)*dsum(il))
+          fr(il, i) = fqd(il, i) + bsum(il)/csum(il)
+        END IF
+      END DO
+    END DO
+  ENDIF
+
+!jyg<
+!Conservation de l'eau
+!!  sumdq = 0.
+!!  DO k = 1, nl
+!!    sumdq = sumdq + fr(1, k)*100.*(ph(1,k)-ph(1,k+1))/grav
+!!  END DO
+!!  PRINT *, 'cv3_yield, apres hom, sum(dq), precip, somme ', sumdq, Vprecip(1, 1), sumdq + vprecip(1, 1)
+!jyg>
+
+
+! ***   Check that moisture stays positive. If not, scale tendencies
+! in order to ensure moisture positivity
+  DO il = 1, ncum
+    alpha_qpos(il) = 1.
+    IF (iflag(il)<=1) THEN
+      IF (fr(il,1)<=0.) THEN
+        alpha_qpos(il) = max(alpha_qpos(il), (-delt*fr(il,1))/(s_wake(il)*rr_wake(il,1)+(1.-s_wake(il))*rr(il,1)))
+      END IF
+    END IF
+  END DO
+  DO i = 2, nl
+    DO il = 1, ncum
+      IF (iflag(il)<=1) THEN
+        IF (fr(il,i)<=0.) THEN
+          alpha_qpos1(il) = max(1., (-delt*fr(il,i))/(s_wake(il)*rr_wake(il,i)+(1.-s_wake(il))*rr(il,i)))
+          IF (alpha_qpos1(il)>=alpha_qpos(il)) alpha_qpos(il) = alpha_qpos1(il)
+        END IF
+      END IF
+    END DO
+  END DO
+  DO il = 1, ncum
+    IF (iflag(il)<=1 .AND. alpha_qpos(il)>1.001) THEN
+      alpha_qpos(il) = alpha_qpos(il)*1.1
+    END IF
+  END DO
+!
+    IF (prt_level .GE. 5) THEN
+      print *,' CV3_YIELD : alpha_qpos ',alpha_qpos(1)
+    ENDIF
+!
+  DO il = 1, ncum
+    IF (iflag(il)<=1) THEN
+      sigd(il) = sigd(il)/alpha_qpos(il)
+      precip(il) = precip(il)/alpha_qpos(il)
+      cbmf(il) = cbmf(il)/alpha_qpos(il)
+    END IF
+  END DO
+  DO i = 1, nl
+    DO il = 1, ncum
+      IF (iflag(il)<=1) THEN
+        fr(il, i) = fr(il, i)/alpha_qpos(il)
+        ft(il, i) = ft(il, i)/alpha_qpos(il)
+        fqd(il, i) = fqd(il, i)/alpha_qpos(il)
+        ftd(il, i) = ftd(il, i)/alpha_qpos(il)
+        fu(il, i) = fu(il, i)/alpha_qpos(il)
+        fv(il, i) = fv(il, i)/alpha_qpos(il)
+        m(il, i) = m(il, i)/alpha_qpos(il)
+        mp(il, i) = mp(il, i)/alpha_qpos(il)
+        Vprecip(il, i) = Vprecip(il, i)/alpha_qpos(il)
+        Vprecipi(il, i) = Vprecipi(il, i)/alpha_qpos(il)                     ! jyg
+      END IF
+    END DO
+  END DO
+!jyg<
+!-----------------------------------------------------------
+           IF (ok_optim_yield) THEN                       !|
+!-----------------------------------------------------------
+  DO i = 1, nl
+    DO il = 1, ncum
+      IF (iflag(il)<=1) THEN
+        upwd(il, i) = upwd(il, i)/alpha_qpos(il)
+        dnwd(il, i) = dnwd(il, i)/alpha_qpos(il)
+      END IF
+    END DO
+  END DO
+!-----------------------------------------------------------
+        ENDIF !(ok_optim_yield)                           !|
+!-----------------------------------------------------------
+!>jyg
+  DO j = 1, nl !yor! inverted i and j loops
+     DO i = 1, nl
+      DO il = 1, ncum
+        IF (iflag(il)<=1) THEN
+          ment(il, i, j) = ment(il, i, j)/alpha_qpos(il)
+        END IF
+      END DO
+    END DO
+  END DO
+
+!AC!      DO j = 1,ntra
+!AC!      DO i = 1,nl
+!AC!       DO il = 1,ncum
+!AC!        IF (iflag(il) .le. 1) THEN
+!AC!         ftra(il,i,j) = ftra(il,i,j)/alpha_qpos(il)
+!AC!        ENDIF
+!AC!       ENDDO
+!AC!      ENDDO
+!AC!      ENDDO
+
+
+! ***           reset counter and return           ***
+
+! Reset counter only for points actually convective (jyg)
+! In order take into account the possibility of changing the compression,
+! reset m, sig and w0 to zero for non-convecting points.
+  DO il = 1, ncum
+    IF (iflag(il) < 3) THEN
+      sig(il, nd) = 2.0
+    ENDIF
+  END DO
+
+
+  DO i = 1, nl
+    DO il = 1, ncum
+      dnwd0(il, i) = -mp(il, i)
+    END DO
+  END DO
+!jyg<  (loops stop at nl)
+!!  DO i = nl + 1, nd
+!!    DO il = 1, ncum
+!!      dnwd0(il, i) = 0.
+!!    END DO
+!!  END DO
+!>jyg
+
+
+!jyg<
+!-----------------------------------------------------------
+           IF (.NOT.ok_optim_yield) THEN                  !|
+!-----------------------------------------------------------
+  DO i = 1, nl
+    DO il = 1, ncum
+      upwd(il, i) = 0.0
+      dnwd(il, i) = 0.0
+    END DO
+  END DO
+
+!!  DO i = 1, nl                                           ! useless; jyg
+!!    DO il = 1, ncum                                      ! useless; jyg
+!!      IF (i>=icb(il) .AND. i<=inb(il)) THEN              ! useless; jyg
+!!        upwd(il, i) = 0.0                                ! useless; jyg
+!!        dnwd(il, i) = 0.0                                ! useless; jyg
+!!      END IF                                             ! useless; jyg
+!!    END DO                                               ! useless; jyg
+!!  END DO                                                 ! useless; jyg
+
+  DO i = 1, nl
+    DO k = 1, nl
+      DO il = 1, ncum
+        up1(il, k, i) = 0.0
+        dn1(il, k, i) = 0.0
+      END DO
+    END DO
+  END DO
+
+!yor! commented original
+!  DO i = 1, nl
+!    DO k = i, nl
+!      DO n = 1, i - 1
+!        DO il = 1, ncum
+!          IF (i>=icb(il) .AND. i<=inb(il) .AND. k<=inb(il)) THEN
+!            up1(il, k, i) = up1(il, k, i) + ment(il, n, k)
+!            dn1(il, k, i) = dn1(il, k, i) - ment(il, k, n)
+!          END IF
+!        END DO
+!      END DO
+!    END DO
+!  END DO
+!yor! replaced with
+  DO i = 1, nl
+    DO k = i, nl
+      DO n = 1, i - 1
+        DO il = 1, ncum
+          IF (i>=icb(il) .AND. k<=inb(il)) THEN ! yor ! as i always <= k
+             up1(il, k, i) = up1(il, k, i) + ment(il, n, k)
+          END IF
+        END DO
+      END DO
+    END DO
+  END DO
+  DO i = 1, nl
+    DO n = 1, i - 1
+      DO k = i, nl
+        DO il = 1, ncum
+          IF (i>=icb(il) .AND. k<=inb(il)) THEN ! yor !  i always <= k
+             dn1(il, k, i) = dn1(il, k, i) - ment(il, k, n)
+          END IF
+        END DO
+      END DO
+    END DO
+  END DO
+!yor! end replace 
+
+  DO i = 1, nl
+    DO k = 1, nl
+      DO il = 1, ncum
+        IF (i>=icb(il)) THEN
+          IF (k>=i .AND. k<=(inb(il))) THEN
+            upwd(il, i) = upwd(il, i) + m(il, k)
+          END IF
+        ELSE
+          IF (k<i) THEN
+            upwd(il, i) = upwd(il, i) + cbmf(il)*wghti(il, k)
+          END IF
+        END IF
+! c        print *,'cbmf',il,i,k,cbmf(il),wghti(il,k)
+      END DO
+    END DO
+  END DO
+
+  DO i = 2, nl
+    DO k = i, nl
+      DO il = 1, ncum
+! test         if (i.ge.icb(il).and.i.le.inb(il).and.k.le.inb(il)) then
+        IF (i<=inb(il) .AND. k<=inb(il)) THEN
+          upwd(il, i) = upwd(il, i) + up1(il, k, i)
+          dnwd(il, i) = dnwd(il, i) + dn1(il, k, i)
+        END IF
+! c         print *,'upwd',il,i,k,inb(il),upwd(il,i),m(il,k),up1(il,k,i)
+      END DO
+    END DO
+  END DO
+
+
+!!!!      DO il=1,ncum
+!!!!      do i=icb(il),inb(il)
+!!!!
+!!!!      upwd(il,i)=0.0
+!!!!      dnwd(il,i)=0.0
+!!!!      do k=i,inb(il)
+!!!!      up1=0.0
+!!!!      dn1=0.0
+!!!!      do n=1,i-1
+!!!!      up1=up1+ment(il,n,k)
+!!!!      dn1=dn1-ment(il,k,n)
+!!!!      enddo
+!!!!      upwd(il,i)=upwd(il,i)+m(il,k)+up1
+!!!!      dnwd(il,i)=dnwd(il,i)+dn1
+!!!!      enddo
+!!!!      enddo
+!!!!
+!!!!      ENDDO
+
+!!  DO i = 1, nlp
+!!    DO il = 1, ncum
+!!      ma(il, i) = 0
+!!    END DO
+!!  END DO
+!!
+!!  DO i = 1, nl
+!!    DO j = i, nl
+!!      DO il = 1, ncum
+!!        ma(il, i) = ma(il, i) + m(il, j)
+!!      END DO
+!!    END DO
+!!  END DO
+
+!jyg<  (loops stop at nl)
+!!  DO i = nl + 1, nd
+!!    DO il = 1, ncum
+!!      ma(il, i) = 0.
+!!    END DO
+!!  END DO
+!>jyg
+
+!!  DO i = 1, nl
+!!    DO il = 1, ncum
+!!      IF (i<=(icb(il)-1)) THEN
+!!        ma(il, i) = 0
+!!      END IF
+!!    END DO
+!!  END DO
+
+!-----------------------------------------------------------
+        ENDIF !(.NOT.ok_optim_yield)                      !|
+!-----------------------------------------------------------
+!>jyg
+
+! ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+! determination de la variation de flux ascendant entre
+! deux niveau non dilue mip
+! ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+
+  DO i = 1, nl
+    DO il = 1, ncum
+      mip(il, i) = m(il, i)
+    END DO
+  END DO
+
+!jyg<  (loops stop at nl)
+!!  DO i = nl + 1, nd
+!!    DO il = 1, ncum
+!!      mip(il, i) = 0.
+!!    END DO
+!!  END DO
+!>jyg
+
+
+! cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+! icb represente de niveau ou se trouve la
+! base du nuage , et inb le top du nuage
+! ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+
+!!  DO i = 1, nd                                  ! unused . jyg
+!!    DO il = 1, ncum                             ! unused . jyg
+!!      mke(il, i) = upwd(il, i) + dnwd(il, i)    ! unused . jyg
+!!    END DO                                      ! unused . jyg
+!!  END DO                                        ! unused . jyg
+
+!!  DO i = 1, nd                                                                 ! unused . jyg
+!!    DO il = 1, ncum                                                            ! unused . jyg
+!!      rdcp = (rrd*(1.-rr(il,i))-rr(il,i)*rrv)/(cpd*(1.-rr(il,i))+rr(il,i)*cpv) ! unused . jyg
+!!      tls(il, i) = t(il, i)*(1000.0/p(il,i))**rdcp                             ! unused . jyg
+!!      tps(il, i) = tp(il, i)                                                   ! unused . jyg
+!!    END DO                                                                     ! unused . jyg
+!!  END DO                                                                       ! unused . jyg
+
+
+! *** diagnose the in-cloud mixing ratio   ***                       ! cld
+! ***           of condensed water         ***                       ! cld
+!! cld                                                               
+                                                                     
+  DO i = 1, nl+1                                                     ! cld
+    DO il = 1, ncum                                                  ! cld
+      mac(il, i) = 0.0                                               ! cld
+      wa(il, i) = 0.0                                                ! cld
+      siga(il, i) = 0.0                                              ! cld
+      sax(il, i) = 0.0                                               ! cld
+    END DO                                                           ! cld
+  END DO                                                             ! cld
+                                                                     
+  DO i = minorig, nl                                                 ! cld
+    DO k = i + 1, nl + 1                                             ! cld
+      DO il = 1, ncum                                                ! cld
+        IF (i<=inb(il) .AND. k<=(inb(il)+1) .AND. iflag(il)<=1) THEN ! cld
+          mac(il, i) = mac(il, i) + m(il, k)                         ! cld
+        END IF                                                       ! cld
+      END DO                                                         ! cld
+    END DO                                                           ! cld
+  END DO                                                             ! cld
+
+  DO i = 1, nl                                                       ! cld
+    DO j = 1, i                                                      ! cld
+      DO il = 1, ncum                                                ! cld
+        IF (i>=icb(il) .AND. i<=(inb(il)-1) &                        ! cld
+            .AND. j>=icb(il) .AND. iflag(il)<=1) THEN                ! cld
+          sax(il, i) = sax(il, i) + rrd*(tvp(il,j)-tv(il,j)) &       ! cld
+            *(ph(il,j)-ph(il,j+1))/p(il, j)                          ! cld
+        END IF                                                       ! cld
+      END DO                                                         ! cld
+    END DO                                                           ! cld
+  END DO                                                             ! cld
+
+  DO i = 1, nl                                                       ! cld
+    DO il = 1, ncum                                                  ! cld
+      IF (i>=icb(il) .AND. i<=(inb(il)-1) &                          ! cld
+          .AND. sax(il,i)>0.0 .AND. iflag(il)<=1) THEN               ! cld
+        wa(il, i) = sqrt(2.*sax(il,i))                               ! cld
+      END IF                                                         ! cld
+    END DO                                                           ! cld
+  END DO  
+                                                           ! cld
+  DO i = 1, nl  
+
+! 14/01/15 AJ je remets les parties manquantes cf JYG
+! Initialize sument to 0
+
+    DO il = 1,ncum
+     sument(il) = 0.
+    ENDDO
+
+! Sum mixed mass fluxes in sument
+
+    DO k = 1,nl
+      DO il = 1,ncum
+        IF  (k<=inb(il) .AND. i<=inb(il) .AND. iflag(il)<=1) THEN   ! cld
+          sument(il) =sument(il) + abs(ment(il,k,i))
+          detrain(il,i) = detrain(il,i) + abs(ment(il,k,i))*(qdet(il,k,i) - rr(il,i))*(qdet(il,k,i) - rr(il,i)) ! Louis terme de dÃ©trainement dans le bilan de variance
+        ENDIF
+      ENDDO     ! il
+    ENDDO       ! k
+
+! 14/01/15 AJ delta n'a rien à faire là...                                                 
+    DO il = 1, ncum                                                  ! cld
+!!      IF (wa(il,i)>0.0 .AND. iflag(il)<=1) &                         ! cld
+!!        siga(il, i) = mac(il, i)/(coefw_cld_cv*wa(il, i)) &          ! cld
+!!        *rrd*tvp(il, i)/p(il, i)/100.                                ! cld
+!!
+!!      siga(il, i) = min(siga(il,i), 1.0)                             ! cld
+      sigaq = 0.
+      IF (wa(il,i)>0.0 .AND. iflag(il)<=1)  THEN                     ! cld
+        siga(il, i) = mac(il, i)/(coefw_cld_cv*wa(il, i)) &          ! cld
+                     *rrd*tvp(il, i)/p(il, i)/100.                   ! cld
+        siga(il, i) = min(siga(il,i), 1.0)                           ! cld
+        sigaq = siga(il,i)*qta(il,i-1)                               ! cld
+      ENDIF
+
+! IM cf. FH 
+! 14/01/15 AJ ne correspond pas à ce qui a été codé par JYG et SB           
+                                                         
+      IF (iflag_clw==0) THEN                                         ! cld
+        qcondc(il, i) = siga(il, i)*clw(il, i)*(1.-ep(il,i)) &       ! cld
+          +(1.-siga(il,i))*qcond(il, i)                              ! cld
+
+
+        sigment(il,i)=sument(il)*tau_cld_cv/(ph(il,i)-ph(il,i+1))    ! cld
+        sigment(il, i) = min(1.e-4+sigment(il,i), 1.0 - siga(il,i))  ! cld
+!!        qtc(il, i) = (siga(il,i)*qta(il,i-1)+sigment(il,i)*qtment(il,i)) & ! cld
+        qtc(il, i) = (sigaq+sigment(il,i)*qtment(il,i)) & ! cld
+                     /(siga(il,i)+sigment(il,i))                     ! cld
+        sigt(il,i) = sigment(il, i) + siga(il, i)
+
+!        qtc(il, i) = siga(il,i)*qta(il,i-1)+(1.-siga(il,i))*qtment(il,i) ! cld
+!     print*,'BIGAUSSIAN CONV',siga(il,i),sigment(il,i),qtc(il,i)  
+      		
+      ELSE IF (iflag_clw==1) THEN                                    ! cld
+        qcondc(il, i) = qcond(il, i)                                 ! cld
+        qtc(il,i) = qtment(il,i)                                     ! cld
+      END IF                                                         ! cld
+
+    END DO                                                           ! cld
+  END DO
+! print*,'cv3_yield fin'
+
+  RETURN
+END SUBROUTINE cv3_yield
+
+!AC! et !RomP >>>
+SUBROUTINE cv3_tracer(nloc, len, ncum, nd, na, &
+                      ment, sigij, da, phi, phi2, d1a, dam, &
+                      ep, Vprecip, elij, clw, epmlmMm, eplaMm, &
+                      icb, inb)
+  IMPLICIT NONE
+
+  include "cv3param.h"
+
+!inputs:
+  INTEGER, INTENT (IN)                               :: ncum, nd, na, nloc, len
+  INTEGER, DIMENSION (len), INTENT (IN)              :: icb, inb
+  REAL, DIMENSION (len, na, na), INTENT (IN)         :: ment, sigij, elij
+  REAL, DIMENSION (len, nd), INTENT (IN)             :: clw
+  REAL, DIMENSION (len, na), INTENT (IN)             :: ep
+  REAL, DIMENSION (len, nd+1), INTENT (IN)           :: Vprecip
+!ouputs:
+  REAL, DIMENSION (len, na, na), INTENT (OUT)        :: phi, phi2, epmlmMm
+  REAL, DIMENSION (len, na), INTENT (OUT)            :: da, d1a, dam, eplaMm
+!
+! variables pour tracer dans precip de l'AA et des mel
+!local variables:
+  INTEGER i, j, k
+  REAL epm(nloc, na, na)
+
+! variables d'Emanuel : du second indice au troisieme
+! --->    tab(i,k,j) -> de l origine k a l arrivee j
+! ment, sigij, elij
+! variables personnelles : du troisieme au second indice
+! --->    tab(i,j,k) -> de k a j
+! phi, phi2
+
+! initialisations
+
+  da(:, :) = 0.
+  d1a(:, :) = 0.
+  dam(:, :) = 0.
+  epm(:, :, :) = 0.
+  eplaMm(:, :) = 0.
+  epmlmMm(:, :, :) = 0.
+  phi(:, :, :) = 0.
+  phi2(:, :, :) = 0.
+
+! fraction deau condensee dans les melanges convertie en precip : epm
+! et eau condensée précipitée dans masse d'air saturé : l_m*dM_m/dzdz.dzdz
+  DO j = 1, nl
+    DO k = 1, nl
+      DO i = 1, ncum
+        IF (k>=icb(i) .AND. k<=inb(i) .AND. & 
+!!jyg              j.ge.k.and.j.le.inb(i)) then
+!!jyg             epm(i,j,k)=1.-(1.-ep(i,j))*clw(i,j)/elij(i,k,j)
+            j>k .AND. j<=inb(i)) THEN
+          epm(i, j, k) = 1. - (1.-ep(i,j))*clw(i, j)/max(elij(i,k,j), 1.E-16)
+!!
+          epm(i, j, k) = max(epm(i,j,k), 0.0)
+        END IF
+      END DO
+    END DO
+  END DO
+
+
+  DO j = 1, nl
+    DO k = 1, nl
+      DO i = 1, ncum
+        IF (k>=icb(i) .AND. k<=inb(i)) THEN
+          eplaMm(i, j) = eplamm(i, j) + &
+                         ep(i, j)*clw(i, j)*ment(i, j, k)*(1.-sigij(i,j,k))
+        END IF
+      END DO
+    END DO
+  END DO
+
+  DO j = 1, nl
+    DO k = 1, j - 1
+      DO i = 1, ncum
+        IF (k>=icb(i) .AND. k<=inb(i) .AND. j<=inb(i)) THEN
+          epmlmMm(i, j, k) = epm(i, j, k)*elij(i, k, j)*ment(i, k, j)
+        END IF
+      END DO
+    END DO
+  END DO
+
+! matrices pour calculer la tendance des concentrations dans cvltr.F90
+  DO j = 1, nl
+    DO k = 1, nl
+      DO i = 1, ncum
+        da(i, j) = da(i, j) + (1.-sigij(i,k,j))*ment(i, k, j)
+        phi(i, j, k) = sigij(i, k, j)*ment(i, k, j)
+        d1a(i, j) = d1a(i, j) + ment(i, k, j)*ep(i, k)*(1.-sigij(i,k,j))
+        IF (k<=j) THEN
+          dam(i, j) = dam(i, j) + ment(i, k, j)*epm(i, k, j)*(1.-ep(i,k))*(1.-sigij(i,k,j))
+          phi2(i, j, k) = phi(i, j, k)*epm(i, j, k)
+        END IF
+      END DO
+    END DO
+  END DO
+
+  RETURN
+END SUBROUTINE cv3_tracer
+!AC! et !RomP <<<
+
+SUBROUTINE cv3_uncompress(nloc, len, ncum, nd, ntra, idcum, &
+                          iflag, &
+                          precip, sig, w0, &
+                          ft, fq, fu, fv, ftra, &
+                          Ma, upwd, dnwd, dnwd0, qcondc, wd, cape, &
+                          epmax_diag, & ! epmax_cape
+                          iflag1, &
+                          precip1, sig1, w01, &
+                          ft1, fq1, fu1, fv1, ftra1, &
+                          Ma1, upwd1, dnwd1, dnwd01, qcondc1, wd1, cape1, &
+                          epmax_diag1) ! epmax_cape
+  IMPLICIT NONE
+
+  include "cv3param.h"
+
+!inputs:
+  INTEGER len, ncum, nd, ntra, nloc
+  INTEGER idcum(nloc)
+  INTEGER iflag(nloc)
+  REAL precip(nloc)
+  REAL sig(nloc, nd), w0(nloc, nd)
+  REAL ft(nloc, nd), fq(nloc, nd), fu(nloc, nd), fv(nloc, nd)
+  REAL ftra(nloc, nd, ntra)
+  REAL ma(nloc, nd)
+  REAL upwd(nloc, nd), dnwd(nloc, nd), dnwd0(nloc, nd)
+  REAL qcondc(nloc, nd)
+  REAL wd(nloc), cape(nloc)
+  REAL epmax_diag(nloc)
+
+!outputs:
+  INTEGER iflag1(len)
+  REAL precip1(len)
+  REAL sig1(len, nd), w01(len, nd)
+  REAL ft1(len, nd), fq1(len, nd), fu1(len, nd), fv1(len, nd)
+  REAL ftra1(len, nd, ntra)
+  REAL ma1(len, nd)
+  REAL upwd1(len, nd), dnwd1(len, nd), dnwd01(len, nd)
+  REAL qcondc1(nloc, nd)
+  REAL wd1(nloc), cape1(nloc)
+  REAL epmax_diag1(len) ! epmax_cape
+
+!local variables:
+  INTEGER i, k, j
+
+  DO i = 1, ncum
+    precip1(idcum(i)) = precip(i)
+    iflag1(idcum(i)) = iflag(i)
+    wd1(idcum(i)) = wd(i)
+    cape1(idcum(i)) = cape(i)
+    epmax_diag1(idcum(i))=epmax_diag(i) ! epmax_cape
+  END DO
+
+  DO k = 1, nl
+    DO i = 1, ncum
+      sig1(idcum(i), k) = sig(i, k)
+      w01(idcum(i), k) = w0(i, k)
+      ft1(idcum(i), k) = ft(i, k)
+      fq1(idcum(i), k) = fq(i, k)
+      fu1(idcum(i), k) = fu(i, k)
+      fv1(idcum(i), k) = fv(i, k)
+      ma1(idcum(i), k) = ma(i, k)
+      upwd1(idcum(i), k) = upwd(i, k)
+      dnwd1(idcum(i), k) = dnwd(i, k)
+      dnwd01(idcum(i), k) = dnwd0(i, k)
+      qcondc1(idcum(i), k) = qcondc(i, k)
+    END DO
+  END DO
+
+  DO i = 1, ncum
+    sig1(idcum(i), nd) = sig(i, nd)
+  END DO
+
+
+!AC!        do 2100 j=1,ntra
+!AC!c oct3         do 2110 k=1,nl
+!AC!         do 2110 k=1,nd ! oct3
+!AC!          do 2120 i=1,ncum
+!AC!            ftra1(idcum(i),k,j)=ftra(i,k,j)
+!AC! 2120     continue
+!AC! 2110    continue
+!AC! 2100   continue
+!
+  RETURN
+END SUBROUTINE cv3_uncompress
+
+
+        subroutine cv3_epmax_fn_cape(nloc,ncum,nd &
+                 , ep,hp,icb,inb,clw,nk,t,h,hnk,lv,lf,frac &
+                 , pbase, p, ph, tv, buoy, sig, w0,iflag &
+                 , epmax_diag)
+        implicit none
+
+        ! On fait varier epmax en fn de la cape
+        ! Il faut donc recalculer ep, et hp qui a déjà été calculé et
+        ! qui en dépend
+        ! Toutes les autres variables fn de ep sont calculées plus bas.
+
+  include "cvthermo.h"
+  include "cv3param.h"  
+  include "conema3.h"
+  include "cvflag.h"
+
+! inputs:
+      INTEGER, INTENT (IN)                               :: ncum, nd, nloc
+      INTEGER, DIMENSION (nloc), INTENT (IN)             :: icb, inb, nk
+      REAL, DIMENSION (nloc), INTENT (IN)                :: hnk,pbase
+      REAL, DIMENSION (nloc, nd), INTENT (IN)            :: t, lv, lf, tv, h
+      REAL, DIMENSION (nloc, nd), INTENT (IN)            :: clw, buoy,frac
+      REAL, DIMENSION (nloc, nd), INTENT (IN)            :: sig,w0
+      INTEGER, DIMENSION (nloc), INTENT (IN)             :: iflag(nloc)
+      REAL, DIMENSION (nloc, nd), INTENT (IN)            :: p
+      REAL, DIMENSION (nloc, nd+1), INTENT (IN)          :: ph
+! inouts:
+      REAL, DIMENSION (nloc, nd), INTENT (INOUT)         :: ep,hp  
+! outputs
+      REAL, DIMENSION (nloc), INTENT (OUT)           :: epmax_diag
+
+! local
+      integer i,k    
+!      real hp_bak(nloc,nd)
+!      real ep_bak(nloc,nd)
+      real m_loc(nloc,nd)
+      real sig_loc(nloc,nd)
+      real w0_loc(nloc,nd)
+      integer iflag_loc(nloc)
+      real cape(nloc)
+        
+        if (coef_epmax_cape.gt.1e-12) then
+
+        ! il faut calculer la cape: on fait un calcule simple car tant qu'on ne
+        ! connait pas ep, on ne connait pas les mélanges, ddfts etc... qui sont
+        ! necessaires au calcul de la cape dans la nouvelle physique
+        
+!        write(*,*) 'cv3_routines check 4303'
+        do i=1,ncum
+        do k=1,nd
+          sig_loc(i,k)=sig(i,k)
+          w0_loc(i,k)=w0(i,k)
+          iflag_loc(i)=iflag(i)
+!          ep_bak(i,k)=ep(i,k)
+        enddo ! do k=1,nd
+        enddo !do i=1,ncum
+
+!        write(*,*) 'cv3_routines check 4311'
+!        write(*,*) 'nl=',nl
+        CALL cv3_closure(nloc, ncum, nd, icb, inb, & ! na->nd
+          pbase, p, ph, tv, buoy, &
+          sig_loc, w0_loc, cape, m_loc,iflag_loc)
+
+!        write(*,*) 'cv3_routines check 4316'
+!        write(*,*) 'ep(1,:)=',ep(1,:)
+        do i=1,ncum
+           epmax_diag(i)=epmax-coef_epmax_cape*sqrt(cape(i))
+           epmax_diag(i)=amax1(epmax_diag(i),0.0)
+!           write(*,*) 'i,icb,inb,cape,epmax_diag=', &
+!                i,icb(i),inb(i),cape(i),epmax_diag(i)
+           do k=1,nl
+                ep(i,k)=ep(i,k)/epmax*epmax_diag(i)
+                ep(i,k)=amax1(ep(i,k),0.0)
+                ep(i,k)=amin1(ep(i,k),epmax_diag(i))
+           enddo
+        enddo
+ !       write(*,*) 'ep(1,:)=',ep(1,:)
+
+      !write(*,*) 'cv3_routines check 4326'
+! On recalcule hp:
+!      do k=1,nl
+!        do i=1,ncum
+!	  hp_bak(i,k)=hp(i,k)
+!	enddo
+!      enddo
+      do k=1,nl
+        do i=1,ncum
+          hp(i,k)=h(i,k)
+        enddo
+      enddo
+
+  IF (cvflag_ice) THEN
+
+      do k=minorig+1,nl
+       do i=1,ncum
+        if((k.ge.icb(i)).and.(k.le.inb(i)))then
+          hp(i, k) = hnk(i) + (lv(i,k)+(cpd-cpv)*t(i,k)+frac(i,k)*lf(i,k))* &
+                              ep(i, k)*clw(i, k)
+        endif
+       enddo
+      enddo !do k=minorig+1,n
+  ELSE !IF (cvflag_ice) THEN
+
+      DO k = minorig + 1, nl
+       DO i = 1, ncum
+        IF ((k>=icb(i)) .AND. (k<=inb(i))) THEN
+          hp(i,k)=hnk(i)+(lv(i,k)+(cpd-cpv)*t(i,k))*ep(i,k)*clw(i,k)
+        endif
+       enddo
+      enddo !do k=minorig+1,n
+
+  ENDIF !IF (cvflag_ice) THEN     
+      !write(*,*) 'cv3_routines check 4345'
+!      do i=1,ncum  
+!       do k=1,nl
+!        if ((abs(hp_bak(i,k)-hp(i,k))/hp_bak(i,k).gt.1e-1).or. &
+!            ((abs(hp_bak(i,k)-hp(i,k))/hp_bak(i,k).gt.1e-4).and. &
+!            (ep(i,k)-ep_bak(i,k).lt.1e-4))) then
+!           write(*,*) 'i,k=',i,k
+!           write(*,*) 'coef_epmax_cape=',coef_epmax_cape
+!           write(*,*) 'epmax_diag(i)=',epmax_diag(i)
+!           write(*,*) 'ep(i,k)=',ep(i,k)
+!           write(*,*) 'ep_bak(i,k)=',ep_bak(i,k)
+!           write(*,*) 'hp(i,k)=',hp(i,k)
+!           write(*,*) 'hp_bak(i,k)=',hp_bak(i,k)
+!           write(*,*) 'h(i,k)=',h(i,k)
+!           write(*,*) 'nk(i)=',nk(i)
+!           write(*,*) 'h(i,nk(i))=',h(i,nk(i))
+!           write(*,*) 'lv(i,k)=',lv(i,k)
+!           write(*,*) 't(i,k)=',t(i,k)
+!           write(*,*) 'clw(i,k)=',clw(i,k)
+!           write(*,*) 'cpd,cpv=',cpd,cpv
+!           stop
+!        endif
+!       enddo !do k=1,nl
+!      enddo !do i=1,ncum  
+      endif !if (coef_epmax_cape.gt.1e-12) then
+      !write(*,*) 'cv3_routines check 4367'
+
+      return
+      end subroutine cv3_epmax_fn_cape
+
+
+
Index: DZ6/trunk/libf/phylmd/cv3a_compress.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cv3a_compress.F90	(revision 5267)
+++ 	(revision )
@@ -1,249 +1,0 @@
-SUBROUTINE cv3a_compress(len, nloc, ncum, nd, ntra, compress, &
-                         iflag1, nk1, icb1, icbs1, &
-                         plcl1, tnk1, qnk1, gznk1, hnk1, unk1, vnk1, &
-                         wghti1, pbase1, buoybase1, &
-                         t1, q1, qs1, t1_wake, q1_wake, qs1_wake, s1_wake, &
-                         u1, v1, gz1, th1, th1_wake, &
-                         tra1, &
-                         h1, lv1, lf1, cpn1, p1, ph1, tv1, tp1, tvp1, clw1, &
-                         h1_wake, lv1_wake, lf1_wake, cpn1_wake, tv1_wake, &
-                         sig1, w01, ptop21, &
-                         Ale1, Alp1, omega1, &
-                         iflag, nk, icb, icbs, &
-                         plcl, tnk, qnk, gznk, hnk, unk, vnk, &
-                         wghti, pbase, buoybase, &
-                         t, q, qs, t_wake, q_wake, qs_wake, s_wake, &
-                         u, v, gz, th, th_wake, &
-                         tra, &
-                         h, lv, lf, cpn, p, ph, tv, tp, tvp, clw, &
-                         h_wake, lv_wake, lf_wake, cpn_wake, tv_wake, &
-                         sig, w0, ptop2, &
-                         Ale, Alp, omega)
-  ! **************************************************************
-  ! *
-  ! CV3A_COMPRESS                                               *
-  ! *
-  ! *
-  ! written by   : Sandrine Bony-Lena , 17/05/2003, 11.22.15    *
-  ! modified by  : Jean-Yves Grandpeix, 23/06/2003, 10.28.09    *
-  ! **************************************************************
-
-  IMPLICIT NONE
-
-  include "cv3param.h"
-
-  ! inputs:
-  INTEGER, INTENT (IN)                               :: len, nloc, nd, ntra
-!jyg<
-  LOGICAL, INTENT (IN)                               :: compress  ! compression is performed if compress is true
-!>jyg
-  INTEGER, DIMENSION (len), INTENT (IN)              :: iflag1, nk1, icb1, icbs1
-  REAL, DIMENSION (len), INTENT (IN)                 :: plcl1, tnk1, qnk1, gznk1
-  REAL, DIMENSION (len), INTENT (IN)                 :: hnk1, unk1, vnk1
-  REAL, DIMENSION (len, nd), INTENT (IN)             :: wghti1(len, nd)
-  REAL, DIMENSION (len), INTENT (IN)                 :: pbase1, buoybase1
-  REAL, DIMENSION (len, nd), INTENT (IN)             :: t1, q1, qs1
-  REAL, DIMENSION (len, nd), INTENT (IN)             :: t1_wake, q1_wake, qs1_wake
-  REAL, DIMENSION (len), INTENT (IN)                 :: s1_wake
-  REAL, DIMENSION (len, nd), INTENT (IN)             :: u1, v1
-  REAL, DIMENSION (len, nd), INTENT (IN)             :: gz1, th1, th1_wake
-  REAL, DIMENSION (len, nd,ntra), INTENT (IN)        :: tra1
-  REAL, DIMENSION (len, nd), INTENT (IN)             :: h1, lv1, lf1, cpn1
-  REAL, DIMENSION (len, nd), INTENT (IN)             :: p1
-  REAL, DIMENSION (len, nd+1), INTENT (IN)           :: ph1(len, nd+1)
-  REAL, DIMENSION (len, nd), INTENT (IN)             :: tv1, tp1
-  REAL, DIMENSION (len, nd), INTENT (IN)             :: tvp1, clw1
-  REAL, DIMENSION (len, nd), INTENT (IN)             :: h1_wake, lv1_wake, cpn1_wake
-  REAL, DIMENSION (len, nd), INTENT (IN)             :: tv1_wake, lf1_wake
-  REAL, DIMENSION (len, nd), INTENT (IN)             :: sig1, w01
-  REAL, DIMENSION (len), INTENT (IN)                 :: ptop21
-  REAL, DIMENSION (len), INTENT (IN)                 :: Ale1, Alp1
-  REAL, DIMENSION (len, nd), INTENT (IN)             :: omega1
-!
-  ! in/out 
-  INTEGER, INTENT (INOUT)                            :: ncum
-!
-  ! outputs:
-  ! en fait, on a nloc=len pour l'instant (cf cv_driver)
-  INTEGER, DIMENSION (nloc), INTENT (OUT)            ::  iflag, nk, icb, icbs
-  REAL, DIMENSION (nloc), INTENT (OUT)               ::  plcl, tnk, qnk, gznk
-  REAL, DIMENSION (nloc), INTENT (OUT)               ::  hnk, unk, vnk
-  REAL, DIMENSION (nloc, nd), INTENT (OUT)           ::  wghti
-  REAL, DIMENSION (nloc), INTENT (OUT)               ::  pbase, buoybase
-  REAL, DIMENSION (nloc, nd), INTENT (OUT)           ::  t, q, qs
-  REAL, DIMENSION (nloc, nd), INTENT (OUT)           ::  t_wake, q_wake, qs_wake
-  REAL, DIMENSION (nloc), INTENT (OUT)               ::  s_wake
-  REAL, DIMENSION (nloc, nd), INTENT (OUT)           ::  u, v
-  REAL, DIMENSION (nloc, nd), INTENT (OUT)           ::  gz, th, th_wake
-  REAL, DIMENSION (nloc, nd,ntra), INTENT (OUT)      ::  tra
-  REAL, DIMENSION (nloc, nd), INTENT (OUT)           ::  h, lv, lf, cpn
-  REAL, DIMENSION (nloc, nd), INTENT (OUT)           ::  p
-  REAL, DIMENSION (nloc, nd+1), INTENT (OUT)         ::  ph
-  REAL, DIMENSION (nloc, nd), INTENT (OUT)           ::  tv, tp
-  REAL, DIMENSION (nloc, nd), INTENT (OUT)           ::  tvp, clw
-  REAL, DIMENSION (nloc, nd), INTENT (OUT)           ::  h_wake, lv_wake, cpn_wake
-  REAL, DIMENSION (nloc, nd), INTENT (OUT)           ::  tv_wake, lf_wake
-  REAL, DIMENSION (nloc, nd), INTENT (OUT)           ::  sig, w0
-  REAL, DIMENSION (nloc), INTENT (OUT)               ::  ptop2
-  REAL, DIMENSION (nloc), INTENT (OUT)               ::  Ale, Alp
-  REAL, DIMENSION (nloc, nd), INTENT (OUT)           ::  omega
-
-  ! local variables:
-  INTEGER i, k, nn, j
-
-  CHARACTER (LEN=20) :: modname = 'cv3a_compress'
-  CHARACTER (LEN=80) :: abort_message
-
-!jyg<
-  IF (compress) THEN
-!>jyg
-
-  DO k = 1, nl + 1
-    nn = 0
-    DO i = 1, len
-      IF (iflag1(i)==0) THEN
-        nn = nn + 1
-        wghti(nn, k) = wghti1(i, k)
-        t(nn, k) = t1(i, k)
-        q(nn, k) = q1(i, k)
-        qs(nn, k) = qs1(i, k)
-        t_wake(nn, k) = t1_wake(i, k)
-        q_wake(nn, k) = q1_wake(i, k)
-        qs_wake(nn, k) = qs1_wake(i, k)
-        u(nn, k) = u1(i, k)
-        v(nn, k) = v1(i, k)
-        gz(nn, k) = gz1(i, k)
-        th(nn, k) = th1(i, k)
-        th_wake(nn, k) = th1_wake(i, k)
-        h(nn, k) = h1(i, k)
-        lv(nn, k) = lv1(i, k)
-        lf(nn, k) = lf1(i, k)
-        cpn(nn, k) = cpn1(i, k)
-        p(nn, k) = p1(i, k)
-        ph(nn, k) = ph1(i, k)
-        tv(nn, k) = tv1(i, k)
-        tp(nn, k) = tp1(i, k)
-        tvp(nn, k) = tvp1(i, k)
-        clw(nn, k) = clw1(i, k)
-        h_wake(nn, k) = h1_wake(i, k)
-        lv_wake(nn, k) = lv1_wake(i, k)
-        lf_wake(nn, k) = lf1_wake(i, k)
-        cpn_wake(nn, k) = cpn1_wake(i, k)
-        tv_wake(nn, k) = tv1_wake(i, k)
-        sig(nn, k) = sig1(i, k)
-        w0(nn, k) = w01(i, k)
-        omega(nn, k) = omega1(i, k)
-      END IF
-    END DO
-  END DO
-!
-  ! AC!      do 121 j=1,ntra
-  ! AC!ccccc      do 111 k=1,nl+1
-  ! AC!      do 111 k=1,nd
-  ! AC!       nn=0
-  ! AC!      do 101 i=1,len
-  ! AC!      if(iflag1(i).eq.0)then
-  ! AC!       nn=nn+1
-  ! AC!       tra(nn,k,j)=tra1(i,k,j)
-  ! AC!      endif
-  ! AC! 101  continue
-  ! AC! 111  continue
-  ! AC! 121  continue
-
-  IF (nn/=ncum) THEN
-    PRINT *, 'WARNING nn not equal to ncum: ', nn, ncum
-    abort_message = ''
-    CALL abort_physic(modname, abort_message, 1)
-  END IF
-
-  nn = 0
-  DO i = 1, len
-    IF (iflag1(i)==0) THEN
-      nn = nn + 1
-      s_wake(nn) = s1_wake(i)
-      iflag(nn) = iflag1(i)
-      nk(nn) = nk1(i)
-      icb(nn) = icb1(i)
-      icbs(nn) = icbs1(i)
-      plcl(nn) = plcl1(i)
-      tnk(nn) = tnk1(i)
-      qnk(nn) = qnk1(i)
-      gznk(nn) = gznk1(i)
-      hnk(nn) = hnk1(i)
-      unk(nn) = unk1(i)
-      vnk(nn) = vnk1(i)
-      pbase(nn) = pbase1(i)
-      buoybase(nn) = buoybase1(i)
-      sig(nn, nd) = sig1(i, nd)
-      ptop2(nn) = ptop2(i)
-      Ale(nn) = Ale1(i)
-      Alp(nn) = Alp1(i)
-    END IF
-  END DO
-
-  IF (nn/=ncum) THEN
-    PRINT *, 'WARNING nn not equal to ncum: ', nn, ncum
-    abort_message = ''
-    CALL abort_physic(modname, abort_message, 1)
-  END IF
-!
-!jyg<
-  ELSE  !(compress)
-!
-      ncum = len
-!
-      wghti(:,1:nl+1) = wghti1(:,1:nl+1)
-      t(:,1:nl+1) = t1(:,1:nl+1)
-      q(:,1:nl+1) = q1(:,1:nl+1)
-      qs(:,1:nl+1) = qs1(:,1:nl+1)
-      t_wake(:,1:nl+1) = t1_wake(:,1:nl+1)
-      q_wake(:,1:nl+1) = q1_wake(:,1:nl+1)
-      qs_wake(:,1:nl+1) = qs1_wake(:,1:nl+1)
-      u(:,1:nl+1) = u1(:,1:nl+1)
-      v(:,1:nl+1) = v1(:,1:nl+1)
-      gz(:,1:nl+1) = gz1(:,1:nl+1)
-      th(:,1:nl+1) = th1(:,1:nl+1)
-      th_wake(:,1:nl+1) = th1_wake(:,1:nl+1)
-      h(:,1:nl+1) = h1(:,1:nl+1)
-      lv(:,1:nl+1) = lv1(:,1:nl+1)
-      lf(:,1:nl+1) = lf1(:,1:nl+1)
-      cpn(:,1:nl+1) = cpn1(:,1:nl+1)
-      p(:,1:nl+1) = p1(:,1:nl+1)
-      ph(:,1:nl+1) = ph1(:,1:nl+1)
-      tv(:,1:nl+1) = tv1(:,1:nl+1)
-      tp(:,1:nl+1) = tp1(:,1:nl+1)
-      tvp(:,1:nl+1) = tvp1(:,1:nl+1)
-      clw(:,1:nl+1) = clw1(:,1:nl+1)
-      h_wake(:,1:nl+1) = h1_wake(:,1:nl+1)
-      lv_wake(:,1:nl+1) = lv1_wake(:,1:nl+1)
-      lf_wake(:,1:nl+1) = lf1_wake(:,1:nl+1)
-      cpn_wake(:,1:nl+1) = cpn1_wake(:,1:nl+1)
-      tv_wake(:,1:nl+1) = tv1_wake(:,1:nl+1)
-      sig(:,1:nl+1) = sig1(:,1:nl+1)
-      w0(:,1:nl+1) = w01(:,1:nl+1)
-      omega(:,1:nl+1) = omega1(:,1:nl+1)
-!
-      s_wake(:) = s1_wake(:)
-      iflag(:) = iflag1(:)
-      nk(:) = nk1(:)
-      icb(:) = icb1(:)
-      icbs(:) = icbs1(:)
-      plcl(:) = plcl1(:)
-      tnk(:) = tnk1(:)
-      qnk(:) = qnk1(:)
-      gznk(:) = gznk1(:)
-      hnk(:) = hnk1(:)
-      unk(:) = unk1(:)
-      vnk(:) = vnk1(:)
-      pbase(:) = pbase1(:)
-      buoybase(:) = buoybase1(:)
-      sig(:, nd) = sig1(:, nd)
-      ptop2(:) = ptop2(:)
-      Ale(:) = Ale1(:)
-      Alp(:) = Alp1(:)
-!
-  ENDIF !(compress)
-!>jyg
-
-  RETURN
-END SUBROUTINE cv3a_compress
Index: /LMDZ6/trunk/libf/phylmd/cv3a_compress.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cv3a_compress.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/cv3a_compress.f90	(revision 5268)
@@ -0,0 +1,249 @@
+SUBROUTINE cv3a_compress(len, nloc, ncum, nd, ntra, compress, &
+                         iflag1, nk1, icb1, icbs1, &
+                         plcl1, tnk1, qnk1, gznk1, hnk1, unk1, vnk1, &
+                         wghti1, pbase1, buoybase1, &
+                         t1, q1, qs1, t1_wake, q1_wake, qs1_wake, s1_wake, &
+                         u1, v1, gz1, th1, th1_wake, &
+                         tra1, &
+                         h1, lv1, lf1, cpn1, p1, ph1, tv1, tp1, tvp1, clw1, &
+                         h1_wake, lv1_wake, lf1_wake, cpn1_wake, tv1_wake, &
+                         sig1, w01, ptop21, &
+                         Ale1, Alp1, omega1, &
+                         iflag, nk, icb, icbs, &
+                         plcl, tnk, qnk, gznk, hnk, unk, vnk, &
+                         wghti, pbase, buoybase, &
+                         t, q, qs, t_wake, q_wake, qs_wake, s_wake, &
+                         u, v, gz, th, th_wake, &
+                         tra, &
+                         h, lv, lf, cpn, p, ph, tv, tp, tvp, clw, &
+                         h_wake, lv_wake, lf_wake, cpn_wake, tv_wake, &
+                         sig, w0, ptop2, &
+                         Ale, Alp, omega)
+  ! **************************************************************
+  ! *
+  ! CV3A_COMPRESS                                               *
+  ! *
+  ! *
+  ! written by   : Sandrine Bony-Lena , 17/05/2003, 11.22.15    *
+  ! modified by  : Jean-Yves Grandpeix, 23/06/2003, 10.28.09    *
+  ! **************************************************************
+
+  IMPLICIT NONE
+
+  include "cv3param.h"
+
+  ! inputs:
+  INTEGER, INTENT (IN)                               :: len, nloc, nd, ntra
+!jyg<
+  LOGICAL, INTENT (IN)                               :: compress  ! compression is performed if compress is true
+!>jyg
+  INTEGER, DIMENSION (len), INTENT (IN)              :: iflag1, nk1, icb1, icbs1
+  REAL, DIMENSION (len), INTENT (IN)                 :: plcl1, tnk1, qnk1, gznk1
+  REAL, DIMENSION (len), INTENT (IN)                 :: hnk1, unk1, vnk1
+  REAL, DIMENSION (len, nd), INTENT (IN)             :: wghti1(len, nd)
+  REAL, DIMENSION (len), INTENT (IN)                 :: pbase1, buoybase1
+  REAL, DIMENSION (len, nd), INTENT (IN)             :: t1, q1, qs1
+  REAL, DIMENSION (len, nd), INTENT (IN)             :: t1_wake, q1_wake, qs1_wake
+  REAL, DIMENSION (len), INTENT (IN)                 :: s1_wake
+  REAL, DIMENSION (len, nd), INTENT (IN)             :: u1, v1
+  REAL, DIMENSION (len, nd), INTENT (IN)             :: gz1, th1, th1_wake
+  REAL, DIMENSION (len, nd,ntra), INTENT (IN)        :: tra1
+  REAL, DIMENSION (len, nd), INTENT (IN)             :: h1, lv1, lf1, cpn1
+  REAL, DIMENSION (len, nd), INTENT (IN)             :: p1
+  REAL, DIMENSION (len, nd+1), INTENT (IN)           :: ph1(len, nd+1)
+  REAL, DIMENSION (len, nd), INTENT (IN)             :: tv1, tp1
+  REAL, DIMENSION (len, nd), INTENT (IN)             :: tvp1, clw1
+  REAL, DIMENSION (len, nd), INTENT (IN)             :: h1_wake, lv1_wake, cpn1_wake
+  REAL, DIMENSION (len, nd), INTENT (IN)             :: tv1_wake, lf1_wake
+  REAL, DIMENSION (len, nd), INTENT (IN)             :: sig1, w01
+  REAL, DIMENSION (len), INTENT (IN)                 :: ptop21
+  REAL, DIMENSION (len), INTENT (IN)                 :: Ale1, Alp1
+  REAL, DIMENSION (len, nd), INTENT (IN)             :: omega1
+!
+  ! in/out 
+  INTEGER, INTENT (INOUT)                            :: ncum
+!
+  ! outputs:
+  ! en fait, on a nloc=len pour l'instant (cf cv_driver)
+  INTEGER, DIMENSION (nloc), INTENT (OUT)            ::  iflag, nk, icb, icbs
+  REAL, DIMENSION (nloc), INTENT (OUT)               ::  plcl, tnk, qnk, gznk
+  REAL, DIMENSION (nloc), INTENT (OUT)               ::  hnk, unk, vnk
+  REAL, DIMENSION (nloc, nd), INTENT (OUT)           ::  wghti
+  REAL, DIMENSION (nloc), INTENT (OUT)               ::  pbase, buoybase
+  REAL, DIMENSION (nloc, nd), INTENT (OUT)           ::  t, q, qs
+  REAL, DIMENSION (nloc, nd), INTENT (OUT)           ::  t_wake, q_wake, qs_wake
+  REAL, DIMENSION (nloc), INTENT (OUT)               ::  s_wake
+  REAL, DIMENSION (nloc, nd), INTENT (OUT)           ::  u, v
+  REAL, DIMENSION (nloc, nd), INTENT (OUT)           ::  gz, th, th_wake
+  REAL, DIMENSION (nloc, nd,ntra), INTENT (OUT)      ::  tra
+  REAL, DIMENSION (nloc, nd), INTENT (OUT)           ::  h, lv, lf, cpn
+  REAL, DIMENSION (nloc, nd), INTENT (OUT)           ::  p
+  REAL, DIMENSION (nloc, nd+1), INTENT (OUT)         ::  ph
+  REAL, DIMENSION (nloc, nd), INTENT (OUT)           ::  tv, tp
+  REAL, DIMENSION (nloc, nd), INTENT (OUT)           ::  tvp, clw
+  REAL, DIMENSION (nloc, nd), INTENT (OUT)           ::  h_wake, lv_wake, cpn_wake
+  REAL, DIMENSION (nloc, nd), INTENT (OUT)           ::  tv_wake, lf_wake
+  REAL, DIMENSION (nloc, nd), INTENT (OUT)           ::  sig, w0
+  REAL, DIMENSION (nloc), INTENT (OUT)               ::  ptop2
+  REAL, DIMENSION (nloc), INTENT (OUT)               ::  Ale, Alp
+  REAL, DIMENSION (nloc, nd), INTENT (OUT)           ::  omega
+
+  ! local variables:
+  INTEGER i, k, nn, j
+
+  CHARACTER (LEN=20) :: modname = 'cv3a_compress'
+  CHARACTER (LEN=80) :: abort_message
+
+!jyg<
+  IF (compress) THEN
+!>jyg
+
+  DO k = 1, nl + 1
+    nn = 0
+    DO i = 1, len
+      IF (iflag1(i)==0) THEN
+        nn = nn + 1
+        wghti(nn, k) = wghti1(i, k)
+        t(nn, k) = t1(i, k)
+        q(nn, k) = q1(i, k)
+        qs(nn, k) = qs1(i, k)
+        t_wake(nn, k) = t1_wake(i, k)
+        q_wake(nn, k) = q1_wake(i, k)
+        qs_wake(nn, k) = qs1_wake(i, k)
+        u(nn, k) = u1(i, k)
+        v(nn, k) = v1(i, k)
+        gz(nn, k) = gz1(i, k)
+        th(nn, k) = th1(i, k)
+        th_wake(nn, k) = th1_wake(i, k)
+        h(nn, k) = h1(i, k)
+        lv(nn, k) = lv1(i, k)
+        lf(nn, k) = lf1(i, k)
+        cpn(nn, k) = cpn1(i, k)
+        p(nn, k) = p1(i, k)
+        ph(nn, k) = ph1(i, k)
+        tv(nn, k) = tv1(i, k)
+        tp(nn, k) = tp1(i, k)
+        tvp(nn, k) = tvp1(i, k)
+        clw(nn, k) = clw1(i, k)
+        h_wake(nn, k) = h1_wake(i, k)
+        lv_wake(nn, k) = lv1_wake(i, k)
+        lf_wake(nn, k) = lf1_wake(i, k)
+        cpn_wake(nn, k) = cpn1_wake(i, k)
+        tv_wake(nn, k) = tv1_wake(i, k)
+        sig(nn, k) = sig1(i, k)
+        w0(nn, k) = w01(i, k)
+        omega(nn, k) = omega1(i, k)
+      END IF
+    END DO
+  END DO
+!
+  ! AC!      do 121 j=1,ntra
+  ! AC!ccccc      do 111 k=1,nl+1
+  ! AC!      do 111 k=1,nd
+  ! AC!       nn=0
+  ! AC!      do 101 i=1,len
+  ! AC!      if(iflag1(i).eq.0)then
+  ! AC!       nn=nn+1
+  ! AC!       tra(nn,k,j)=tra1(i,k,j)
+  ! AC!      endif
+  ! AC! 101  continue
+  ! AC! 111  continue
+  ! AC! 121  continue
+
+  IF (nn/=ncum) THEN
+    PRINT *, 'WARNING nn not equal to ncum: ', nn, ncum
+    abort_message = ''
+    CALL abort_physic(modname, abort_message, 1)
+  END IF
+
+  nn = 0
+  DO i = 1, len
+    IF (iflag1(i)==0) THEN
+      nn = nn + 1
+      s_wake(nn) = s1_wake(i)
+      iflag(nn) = iflag1(i)
+      nk(nn) = nk1(i)
+      icb(nn) = icb1(i)
+      icbs(nn) = icbs1(i)
+      plcl(nn) = plcl1(i)
+      tnk(nn) = tnk1(i)
+      qnk(nn) = qnk1(i)
+      gznk(nn) = gznk1(i)
+      hnk(nn) = hnk1(i)
+      unk(nn) = unk1(i)
+      vnk(nn) = vnk1(i)
+      pbase(nn) = pbase1(i)
+      buoybase(nn) = buoybase1(i)
+      sig(nn, nd) = sig1(i, nd)
+      ptop2(nn) = ptop2(i)
+      Ale(nn) = Ale1(i)
+      Alp(nn) = Alp1(i)
+    END IF
+  END DO
+
+  IF (nn/=ncum) THEN
+    PRINT *, 'WARNING nn not equal to ncum: ', nn, ncum
+    abort_message = ''
+    CALL abort_physic(modname, abort_message, 1)
+  END IF
+!
+!jyg<
+  ELSE  !(compress)
+!
+      ncum = len
+!
+      wghti(:,1:nl+1) = wghti1(:,1:nl+1)
+      t(:,1:nl+1) = t1(:,1:nl+1)
+      q(:,1:nl+1) = q1(:,1:nl+1)
+      qs(:,1:nl+1) = qs1(:,1:nl+1)
+      t_wake(:,1:nl+1) = t1_wake(:,1:nl+1)
+      q_wake(:,1:nl+1) = q1_wake(:,1:nl+1)
+      qs_wake(:,1:nl+1) = qs1_wake(:,1:nl+1)
+      u(:,1:nl+1) = u1(:,1:nl+1)
+      v(:,1:nl+1) = v1(:,1:nl+1)
+      gz(:,1:nl+1) = gz1(:,1:nl+1)
+      th(:,1:nl+1) = th1(:,1:nl+1)
+      th_wake(:,1:nl+1) = th1_wake(:,1:nl+1)
+      h(:,1:nl+1) = h1(:,1:nl+1)
+      lv(:,1:nl+1) = lv1(:,1:nl+1)
+      lf(:,1:nl+1) = lf1(:,1:nl+1)
+      cpn(:,1:nl+1) = cpn1(:,1:nl+1)
+      p(:,1:nl+1) = p1(:,1:nl+1)
+      ph(:,1:nl+1) = ph1(:,1:nl+1)
+      tv(:,1:nl+1) = tv1(:,1:nl+1)
+      tp(:,1:nl+1) = tp1(:,1:nl+1)
+      tvp(:,1:nl+1) = tvp1(:,1:nl+1)
+      clw(:,1:nl+1) = clw1(:,1:nl+1)
+      h_wake(:,1:nl+1) = h1_wake(:,1:nl+1)
+      lv_wake(:,1:nl+1) = lv1_wake(:,1:nl+1)
+      lf_wake(:,1:nl+1) = lf1_wake(:,1:nl+1)
+      cpn_wake(:,1:nl+1) = cpn1_wake(:,1:nl+1)
+      tv_wake(:,1:nl+1) = tv1_wake(:,1:nl+1)
+      sig(:,1:nl+1) = sig1(:,1:nl+1)
+      w0(:,1:nl+1) = w01(:,1:nl+1)
+      omega(:,1:nl+1) = omega1(:,1:nl+1)
+!
+      s_wake(:) = s1_wake(:)
+      iflag(:) = iflag1(:)
+      nk(:) = nk1(:)
+      icb(:) = icb1(:)
+      icbs(:) = icbs1(:)
+      plcl(:) = plcl1(:)
+      tnk(:) = tnk1(:)
+      qnk(:) = qnk1(:)
+      gznk(:) = gznk1(:)
+      hnk(:) = hnk1(:)
+      unk(:) = unk1(:)
+      vnk(:) = vnk1(:)
+      pbase(:) = pbase1(:)
+      buoybase(:) = buoybase1(:)
+      sig(:, nd) = sig1(:, nd)
+      ptop2(:) = ptop2(:)
+      Ale(:) = Ale1(:)
+      Alp(:) = Alp1(:)
+!
+  ENDIF !(compress)
+!>jyg
+
+  RETURN
+END SUBROUTINE cv3a_compress
Index: DZ6/trunk/libf/phylmd/cv3a_uncompress.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cv3a_uncompress.F90	(revision 5267)
+++ 	(revision )
@@ -1,339 +1,0 @@
-SUBROUTINE cv3a_uncompress(nloc, len, ncum, nd, ntra, idcum, compress, &
-                           iflag, kbas, ktop, &
-                           precip, cbmf, plcl, plfc, wbeff, sig, w0, ptop2, &
-                           ft, fq, fqcomp, fu, fv, ftra,  &
-                           sigd, ma, mip, vprecip, vprecipi, upwd, dnwd, dnwd0, &
-                           qcondc, wd, cape, cin, &
-                           tvp, &
-                           ftd, fqd, &
-                           plim1, plim2, asupmax, supmax0, &
-                           asupmaxmin, &
-                           da, phi, mp, phi2, d1a, dam, sigij, &                ! RomP+AC+jyg
-                           qta, clw, elij, evap, ep, epmlmMm, eplaMm, &         ! RomP+jyg
-                           wdtrainA, wdtrainS, wdtrainM, &                      ! RomP
-                           qtc, sigt, detrain,         &
-                           epmax_diag, & ! epmax_cape
-                           iflag1, kbas1, ktop1, &
-                           precip1, cbmf1, plcl1, plfc1, wbeff1, sig1, w01, ptop21, &
-                           ft1, fq1, fqcomp1, fu1, fv1, ftra1, &
-                           sigd1, ma1, mip1, vprecip1, vprecipi1, upwd1, dnwd1, dnwd01, &
-                           qcondc1, wd1, cape1, cin1, &
-                           tvp1, &
-                           ftd1, fqd1, &
-                           plim11, plim21, asupmax1, supmax01, &
-                           asupmaxmin1, &
-                           da1, phi1, mp1, phi21, d1a1, dam1, sigij1, &         ! RomP+AC+jyg
-                           qta1, clw1, elij1, evap1, ep1, epmlmMm1, eplaMm1, &  ! RomP+jyg
-                           wdtrainA1, wdtrainS1, wdtrainM1, &                   ! RomP
-                           qtc1, sigt1, detrain1, &
-                           epmax_diag1) ! epmax_cape
-
-  ! **************************************************************
-  ! *
-  ! CV3A_UNCOMPRESS                                             *
-  ! *
-  ! *
-  ! written by   : Sandrine Bony-Lena , 17/05/2003, 11.22.15    *
-  ! modified by  : Jean-Yves Grandpeix, 23/06/2003, 10.36.17    *
-  ! **************************************************************
-
-  IMPLICIT NONE
-
-  include "cv3param.h"
-
-  ! inputs:
-  INTEGER, INTENT (IN)                               :: nloc, len, ncum, nd, ntra
-  INTEGER, DIMENSION (nloc), INTENT (IN)             :: idcum(nloc)
-!jyg<
-  LOGICAL, INTENT (IN)                               :: compress
-!>jyg
-  INTEGER, DIMENSION (nloc), INTENT (IN)             ::iflag, kbas, ktop
-  REAL, DIMENSION (nloc), INTENT (IN)                :: precip, cbmf, plcl, plfc
-  REAL, DIMENSION (nloc), INTENT (IN)                :: wbeff
-  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: sig, w0
-  REAL, DIMENSION (nloc), INTENT (IN)                :: ptop2
-  REAL, DIMENSION (nloc), INTENT (IN)                :: epmax_diag
-  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: ft, fq, fqcomp, fu, fv
-  REAL, DIMENSION (nloc, nd, ntra), INTENT (IN)      :: ftra
-  REAL, DIMENSION (nloc), INTENT (IN)                :: sigd
-  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: ma, mip
-  REAL, DIMENSION (nloc, nd+1), INTENT (IN)          :: vprecip
-  REAL, DIMENSION (nloc, nd+1), INTENT (IN)          :: vprecipi
-  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: upwd, dnwd, dnwd0
-  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: qcondc
-  REAL, DIMENSION (nloc), INTENT (IN)                :: wd, cape, cin
-  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: tvp
-  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: ftd, fqd
-  REAL, DIMENSION (nloc), INTENT (IN)                :: plim1, plim2
-  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: asupmax
-  REAL, DIMENSION (nloc), INTENT (IN)                :: supmax0, asupmaxmin
-
-  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: da
-  REAL, DIMENSION (nloc, nd, nd), INTENT (IN)        :: phi                    !AC!
-  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: mp                     !RomP
-  REAL, DIMENSION (nloc, nd, nd), INTENT (IN)        :: phi2                   !RomP
-  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: d1a, dam               !RomP
-  REAL, DIMENSION (nloc, nd, nd), INTENT (IN)        :: sigij                  !RomP
-  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: qta                    !jyg
-  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: clw                    !RomP
-  REAL, DIMENSION (nloc, nd, nd), INTENT (IN)        :: elij                   !RomP
-  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: evap, ep               !RomP
-  REAL, DIMENSION (nloc, nd, nd), INTENT (IN)        :: epmlmMm                !RomP+jyg
-  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: eplamM                 !RomP+jyg
-  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: qtc, sigt, detrain              !RomP
-  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: wdtrainA, wdtrainS, wdtrainM     !RomP
-
-  ! outputs:
-  INTEGER, DIMENSION (len), INTENT (OUT)             :: iflag1, kbas1, ktop1
-  REAL, DIMENSION (len), INTENT (OUT)                :: precip1, cbmf1, plcl1, plfc1
-  REAL, DIMENSION (len), INTENT (OUT)                :: wbeff1
-  REAL, DIMENSION (len, nd), INTENT (OUT)            :: sig1, w01
-  REAL, DIMENSION (len), INTENT (OUT)                :: epmax_diag1 ! epmax_cape
-  REAL, DIMENSION (len), INTENT (OUT)                :: ptop21
-  REAL, DIMENSION (len, nd), INTENT (OUT)            :: ft1, fq1, fqcomp1, fu1, fv1
-  REAL, DIMENSION (len, nd, ntra), INTENT (OUT)      :: ftra1
-  REAL, DIMENSION (len), INTENT (OUT)                :: sigd1
-  REAL, DIMENSION (len, nd), INTENT (OUT)            :: ma1, mip1
-  REAL, DIMENSION (len, nd+1), INTENT (OUT)          :: vprecip1
-  REAL, DIMENSION (len, nd+1), INTENT (OUT)          :: vprecipi1
-  REAL, DIMENSION (len, nd), INTENT (OUT)            :: upwd1, dnwd1, dnwd01
-  REAL, DIMENSION (len, nd), INTENT (OUT)            :: qcondc1
-  REAL, DIMENSION (len), INTENT (OUT)                :: wd1, cape1, cin1
-  REAL, DIMENSION (len, nd), INTENT (OUT)            :: tvp1
-  REAL, DIMENSION (len, nd), INTENT (OUT)            :: ftd1, fqd1
-  REAL, DIMENSION (len), INTENT (OUT)                :: plim11, plim21
-  REAL, DIMENSION (len, nd), INTENT (OUT)            :: asupmax1
-  REAL, DIMENSION (len), INTENT (OUT)                :: supmax01, asupmaxmin1
-                                                    
-  REAL, DIMENSION (len, nd), INTENT (OUT)            :: da1
-  REAL, DIMENSION (len, nd, nd), INTENT (OUT)        :: phi1                   !AC!
-  REAL, DIMENSION (len, nd), INTENT (OUT)            :: mp1                    !RomP
-  REAL, DIMENSION (len, nd, nd), INTENT (OUT)        :: phi21                  !RomP
-  REAL, DIMENSION (len, nd), INTENT (OUT)            :: d1a1, dam1 !RomP       !RomP
-  REAL, DIMENSION (len, nd, nd), INTENT (OUT)        :: sigij1                 !RomP
-  REAL, DIMENSION (len, nd), INTENT (OUT)            :: qta1                   !jyg
-  REAL, DIMENSION (len, nd), INTENT (OUT)            :: clw1                   !RomP
-  REAL, DIMENSION (len, nd, nd), INTENT (OUT)        :: elij1                  !RomP
-  REAL, DIMENSION (len, nd), INTENT (OUT)            :: evap1, ep1             !RomP
-  REAL, DIMENSION (len, nd, nd), INTENT (OUT)        :: epmlmMm1               !RomP+jyg
-  REAL, DIMENSION (len, nd), INTENT (OUT)            :: eplamM1                !RomP+jyg
-  REAL, DIMENSION (len, nd), INTENT (OUT)            :: qtc1, sigt1, detrain1            !RomP
-  REAL, DIMENSION (len, nd), INTENT (OUT)            :: wdtrainA1, wdtrainS1, wdtrainM1   !RomP
-
-
-  ! local variables:
-  INTEGER i, k, j
-  INTEGER jdcum
-  ! c    integer k1,k2
-
-!jyg<
-  IF (compress) THEN
-!>jyg
-    DO i = 1, ncum
-      sig1(idcum(i), nd) = sig(i, nd)
-      ptop21(idcum(i)) = ptop2(i)
-      sigd1(idcum(i)) = sigd(i)
-      precip1(idcum(i)) = precip(i)
-      cbmf1(idcum(i)) = cbmf(i)
-      plcl1(idcum(i)) = plcl(i)
-      plfc1(idcum(i)) = plfc(i)
-      wbeff1(idcum(i)) = wbeff(i)
-      iflag1(idcum(i)) = iflag(i)
-      kbas1(idcum(i)) = kbas(i)
-      ktop1(idcum(i)) = ktop(i)
-      wd1(idcum(i)) = wd(i)
-      cape1(idcum(i)) = cape(i)
-      cin1(idcum(i)) = cin(i)
-      plim11(idcum(i)) = plim1(i)
-      plim21(idcum(i)) = plim2(i)
-      supmax01(idcum(i)) = supmax0(i)
-      asupmaxmin1(idcum(i)) = asupmaxmin(i)
-      epmax_diag1(idcum(i)) = epmax_diag(i)
-    END DO
-   
-    DO k = 1, nl
-      DO i = 1, ncum
-        sig1(idcum(i), k) = sig(i, k)
-        w01(idcum(i), k) = w0(i, k)
-        ft1(idcum(i), k) = ft(i, k)
-        fq1(idcum(i), k) = fq(i, k)
-        fqcomp1(idcum(i), k) = fqcomp(i, k)
-        fu1(idcum(i), k) = fu(i, k)
-        fv1(idcum(i), k) = fv(i, k)
-        ma1(idcum(i), k) = ma(i, k)
-        mip1(idcum(i), k) = mip(i, k)
-        vprecip1(idcum(i), k) = vprecip(i, k)
-        vprecipi1(idcum(i), k) = vprecipi(i, k)
-        upwd1(idcum(i), k) = upwd(i, k)
-        dnwd1(idcum(i), k) = dnwd(i, k)
-        dnwd01(idcum(i), k) = dnwd0(i, k)
-        qcondc1(idcum(i), k) = qcondc(i, k)
-        tvp1(idcum(i), k) = tvp(i, k)
-        ftd1(idcum(i), k) = ftd(i, k)
-        fqd1(idcum(i), k) = fqd(i, k)
-        asupmax1(idcum(i), k) = asupmax(i, k)
-   
-        da1(idcum(i), k) = da(i, k) !AC!
-        mp1(idcum(i), k) = mp(i, k) !RomP
-        d1a1(idcum(i), k) = d1a(i, k) !RomP
-        dam1(idcum(i), k) = dam(i, k) !RomP
-        qta1(idcum(i), k) = qta(i, k) !jyg
-        clw1(idcum(i), k) = clw(i, k) !RomP
-        evap1(idcum(i), k) = evap(i, k) !RomP
-        ep1(idcum(i), k) = ep(i, k) !RomP
-        eplamM1(idcum(i), k) = eplamM(i, k) !RomP+jyg
-        wdtrainA1(idcum(i), k) = wdtrainA(i, k) !RomP
-        wdtrainS1(idcum(i), k) = wdtrainS(i, k) !RomP
-        wdtrainM1(idcum(i), k) = wdtrainM(i, k) !RomP
-        qtc1(idcum(i), k) = qtc(i, k)
-        sigt1(idcum(i), k) = sigt(i, k)
-        detrain1(idcum(i), k) = detrain(i, k)
-   
-      END DO
-    END DO
-
-! Fluxes are defined on a staggered grid and extend up to nl+1
-    DO i = 1, ncum
-      ma1(idcum(i), nlp) = 0.
-      vprecip1(idcum(i), nlp) = 0.
-      vprecipi1(idcum(i), nlp) = 0.
-      upwd1(idcum(i), nlp) = 0.
-      dnwd1(idcum(i), nlp) = 0.
-      dnwd01(idcum(i), nlp) = 0.
-    END DO
-   
-    ! AC!        do 2100 j=1,ntra
-    ! AC!c oct3         do 2110 k=1,nl
-    ! AC!         do 2110 k=1,nd ! oct3
-    ! AC!          do 2120 i=1,ncum
-    ! AC!            ftra1(idcum(i),k,j)=ftra(i,k,j)
-    ! AC! 2120     continue
-    ! AC! 2110    continue
-    ! AC! 2100   continue
-   
-    ! AC!
-!jyg<
-!  Essais pour gagner du temps en diminuant l'adressage indirect 
-!!    DO j = 1, nd
-!!      DO k = 1, nd
-!!        DO i = 1, ncum
-!!          phi1(idcum(i), k, j) = phi(i, k, j) !AC!
-!!          phi21(idcum(i), k, j) = phi2(i, k, j) !RomP
-!!          sigij1(idcum(i), k, j) = sigij(i, k, j) !RomP
-!!          elij1(idcum(i), k, j) = elij(i, k, j) !RomP
-!!          epmlmMm(idcum(i), k, j) = epmlmMm(i, k, j) !RomP+jyg
-!!        END DO
-!!      END DO
-!!    END DO
-
-!!      DO i = 1, ncum
-!!        jdcum=idcum(i)
-!!        phi1    (jdcum, 1:nl+1, 1:nl+1) = phi    (i, 1:nl+1, 1:nl+1)          !AC!
-!!        phi21   (jdcum, 1:nl+1, 1:nl+1) = phi2   (i, 1:nl+1, 1:nl+1)          !RomP
-!!        sigij1  (jdcum, 1:nl+1, 1:nl+1) = sigij  (i, 1:nl+1, 1:nl+1)          !RomP
-!!        elij1   (jdcum, 1:nl+1, 1:nl+1) = elij   (i, 1:nl+1, 1:nl+1)          !RomP
-!!        epmlmMm1(jdcum, 1:nl+1, 1:nl+1) = epmlmMm(i, 1:nl+1, 1:nl+1)          !RomP+jyg
-!!      END DO
-!  These tracer associated arrays are defined up to nl, not nl+1
-  DO i = 1, ncum
-    jdcum=idcum(i)
-    DO k = 1,nl
-      DO j = 1,nl
-        phi1    (jdcum, j, k) = phi    (i, j, k)          !AC!
-        phi21   (jdcum, j, k) = phi2   (i, j, k)          !RomP
-        sigij1  (jdcum, j, k) = sigij  (i, j, k)          !RomP
-        elij1   (jdcum, j, k) = elij   (i, j, k)          !RomP
-        epmlmMm1(jdcum, j, k) = epmlmMm(i, j, k)          !RomP+jyg
-      END DO
-    ENDDO
-  ENDDO
-!>jyg
-    ! AC!
-   
-   
-    ! do 2220 k2=1,nd
-    ! do 2210 k1=1,nd
-    ! do 2200 i=1,ncum
-    ! ment1(idcum(i),k1,k2) = ment(i,k1,k2)
-    ! sigij1(idcum(i),k1,k2) = sigij(i,k1,k2)
-    ! 2200      enddo
-    ! 2210     enddo
-    ! 2220    enddo
-!
-!jyg<
-  ELSE  !(compress)
-!
-      sig1(:,nd) = sig(:,nd)
-      ptop21(:) = ptop2(:)
-      sigd1(:) = sigd(:)
-      precip1(:) = precip(:)
-      cbmf1(:) = cbmf(:)
-      plcl1(:) = plcl(:)
-      plfc1(:) = plfc(:)
-      wbeff1(:) = wbeff(:)
-      iflag1(:) = iflag(:)
-      kbas1(:) = kbas(:)
-      ktop1(:) = ktop(:)
-      wd1(:) = wd(:)
-      cape1(:) = cape(:)
-      cin1(:) = cin(:)
-      plim11(:) = plim1(:)
-      plim21(:) = plim2(:)
-      supmax01(:) = supmax0(:)
-      asupmaxmin1(:) = asupmaxmin(:)
-!
-      sig1(:, 1:nl) = sig(:, 1:nl)
-      w01(:, 1:nl) = w0(:, 1:nl)
-      ft1(:, 1:nl) = ft(:, 1:nl)
-      fq1(:, 1:nl) = fq(:, 1:nl)
-      fqcomp1(:, 1:nl) = fqcomp(:, 1:nl)
-      fu1(:, 1:nl) = fu(:, 1:nl)
-      fv1(:, 1:nl) = fv(:, 1:nl)
-      ma1(:, 1:nl) = ma(:, 1:nl)
-      mip1(:, 1:nl) = mip(:, 1:nl)
-      vprecip1(:, 1:nl) = vprecip(:, 1:nl)
-      vprecipi1(:, 1:nl) = vprecipi(:, 1:nl)
-      upwd1(:, 1:nl) = upwd(:, 1:nl)
-      dnwd1(:, 1:nl) = dnwd(:, 1:nl)
-      dnwd01(:, 1:nl) = dnwd0(:, 1:nl)
-      qcondc1(:, 1:nl) = qcondc(:, 1:nl)
-      tvp1(:, 1:nl) = tvp(:, 1:nl)
-      ftd1(:, 1:nl) = ftd(:, 1:nl)
-      fqd1(:, 1:nl) = fqd(:, 1:nl)
-      asupmax1(:, 1:nl) = asupmax(:, 1:nl)
-
-      da1(:, 1:nl) = da(:, 1:nl)              !AC!
-      mp1(:, 1:nl) = mp(:, 1:nl)              !RomP
-      d1a1(:, 1:nl) = d1a(:, 1:nl)            !RomP
-      dam1(:, 1:nl) = dam(:, 1:nl)            !RomP
-      qta1(:, 1:nl) = qta(:, 1:nl)            !jyg
-      clw1(:, 1:nl) = clw(:, 1:nl)            !RomP
-      evap1(:, 1:nl) = evap(:, 1:nl)          !RomP
-      ep1(:, 1:nl) = ep(:, 1:nl)              !RomP
-      eplamM1(:, 1:nl) = eplamM(:, 1:nl)       !RomP+jyg
-      wdtrainA1(:, 1:nl) = wdtrainA(:, 1:nl)  !RomP
-      wdtrainS1(:, 1:nl) = wdtrainS(:, 1:nl)  !RomP
-      wdtrainM1(:, 1:nl) = wdtrainM(:, 1:nl)  !RomP
-      qtc1(:, 1:nl) = qtc(:, 1:nl)
-      sigt1(:, 1:nl) = sigt(:, 1:nl)
-      detrain1(:, 1:nl) = detrain(:, 1:nl)
-!
-      ma1(:, nlp) = 0.
-      vprecip1(:, nlp) = 0.
-      vprecipi1(:, nlp) = 0.
-      upwd1(:, nlp) = 0.
-      dnwd1(:, nlp) = 0.
-      dnwd01(:, nlp) = 0.
-
-!
-      phi1    (:, 1:nl, 1:nl) = phi    (:, 1:nl, 1:nl)  !AC!
-      phi21   (:, 1:nl, 1:nl) = phi2   (:, 1:nl, 1:nl)  !RomP
-      sigij1  (:, 1:nl, 1:nl) = sigij  (:, 1:nl, 1:nl)  !RomP
-      elij1   (:, 1:nl, 1:nl) = elij   (:, 1:nl, 1:nl)  !RomP
-      epmlmMm1(:, 1:nl, 1:nl) = epmlmMm(:, 1:nl, 1:nl)  !RomP+jyg
-  ENDIF !(compress)
-!>jyg
-
-  RETURN
-END SUBROUTINE cv3a_uncompress
-
Index: /LMDZ6/trunk/libf/phylmd/cv3a_uncompress.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cv3a_uncompress.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/cv3a_uncompress.f90	(revision 5268)
@@ -0,0 +1,339 @@
+SUBROUTINE cv3a_uncompress(nloc, len, ncum, nd, ntra, idcum, compress, &
+                           iflag, kbas, ktop, &
+                           precip, cbmf, plcl, plfc, wbeff, sig, w0, ptop2, &
+                           ft, fq, fqcomp, fu, fv, ftra,  &
+                           sigd, ma, mip, vprecip, vprecipi, upwd, dnwd, dnwd0, &
+                           qcondc, wd, cape, cin, &
+                           tvp, &
+                           ftd, fqd, &
+                           plim1, plim2, asupmax, supmax0, &
+                           asupmaxmin, &
+                           da, phi, mp, phi2, d1a, dam, sigij, &                ! RomP+AC+jyg
+                           qta, clw, elij, evap, ep, epmlmMm, eplaMm, &         ! RomP+jyg
+                           wdtrainA, wdtrainS, wdtrainM, &                      ! RomP
+                           qtc, sigt, detrain,         &
+                           epmax_diag, & ! epmax_cape
+                           iflag1, kbas1, ktop1, &
+                           precip1, cbmf1, plcl1, plfc1, wbeff1, sig1, w01, ptop21, &
+                           ft1, fq1, fqcomp1, fu1, fv1, ftra1, &
+                           sigd1, ma1, mip1, vprecip1, vprecipi1, upwd1, dnwd1, dnwd01, &
+                           qcondc1, wd1, cape1, cin1, &
+                           tvp1, &
+                           ftd1, fqd1, &
+                           plim11, plim21, asupmax1, supmax01, &
+                           asupmaxmin1, &
+                           da1, phi1, mp1, phi21, d1a1, dam1, sigij1, &         ! RomP+AC+jyg
+                           qta1, clw1, elij1, evap1, ep1, epmlmMm1, eplaMm1, &  ! RomP+jyg
+                           wdtrainA1, wdtrainS1, wdtrainM1, &                   ! RomP
+                           qtc1, sigt1, detrain1, &
+                           epmax_diag1) ! epmax_cape
+
+  ! **************************************************************
+  ! *
+  ! CV3A_UNCOMPRESS                                             *
+  ! *
+  ! *
+  ! written by   : Sandrine Bony-Lena , 17/05/2003, 11.22.15    *
+  ! modified by  : Jean-Yves Grandpeix, 23/06/2003, 10.36.17    *
+  ! **************************************************************
+
+  IMPLICIT NONE
+
+  include "cv3param.h"
+
+  ! inputs:
+  INTEGER, INTENT (IN)                               :: nloc, len, ncum, nd, ntra
+  INTEGER, DIMENSION (nloc), INTENT (IN)             :: idcum(nloc)
+!jyg<
+  LOGICAL, INTENT (IN)                               :: compress
+!>jyg
+  INTEGER, DIMENSION (nloc), INTENT (IN)             ::iflag, kbas, ktop
+  REAL, DIMENSION (nloc), INTENT (IN)                :: precip, cbmf, plcl, plfc
+  REAL, DIMENSION (nloc), INTENT (IN)                :: wbeff
+  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: sig, w0
+  REAL, DIMENSION (nloc), INTENT (IN)                :: ptop2
+  REAL, DIMENSION (nloc), INTENT (IN)                :: epmax_diag
+  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: ft, fq, fqcomp, fu, fv
+  REAL, DIMENSION (nloc, nd, ntra), INTENT (IN)      :: ftra
+  REAL, DIMENSION (nloc), INTENT (IN)                :: sigd
+  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: ma, mip
+  REAL, DIMENSION (nloc, nd+1), INTENT (IN)          :: vprecip
+  REAL, DIMENSION (nloc, nd+1), INTENT (IN)          :: vprecipi
+  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: upwd, dnwd, dnwd0
+  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: qcondc
+  REAL, DIMENSION (nloc), INTENT (IN)                :: wd, cape, cin
+  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: tvp
+  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: ftd, fqd
+  REAL, DIMENSION (nloc), INTENT (IN)                :: plim1, plim2
+  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: asupmax
+  REAL, DIMENSION (nloc), INTENT (IN)                :: supmax0, asupmaxmin
+
+  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: da
+  REAL, DIMENSION (nloc, nd, nd), INTENT (IN)        :: phi                    !AC!
+  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: mp                     !RomP
+  REAL, DIMENSION (nloc, nd, nd), INTENT (IN)        :: phi2                   !RomP
+  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: d1a, dam               !RomP
+  REAL, DIMENSION (nloc, nd, nd), INTENT (IN)        :: sigij                  !RomP
+  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: qta                    !jyg
+  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: clw                    !RomP
+  REAL, DIMENSION (nloc, nd, nd), INTENT (IN)        :: elij                   !RomP
+  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: evap, ep               !RomP
+  REAL, DIMENSION (nloc, nd, nd), INTENT (IN)        :: epmlmMm                !RomP+jyg
+  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: eplamM                 !RomP+jyg
+  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: qtc, sigt, detrain              !RomP
+  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: wdtrainA, wdtrainS, wdtrainM     !RomP
+
+  ! outputs:
+  INTEGER, DIMENSION (len), INTENT (OUT)             :: iflag1, kbas1, ktop1
+  REAL, DIMENSION (len), INTENT (OUT)                :: precip1, cbmf1, plcl1, plfc1
+  REAL, DIMENSION (len), INTENT (OUT)                :: wbeff1
+  REAL, DIMENSION (len, nd), INTENT (OUT)            :: sig1, w01
+  REAL, DIMENSION (len), INTENT (OUT)                :: epmax_diag1 ! epmax_cape
+  REAL, DIMENSION (len), INTENT (OUT)                :: ptop21
+  REAL, DIMENSION (len, nd), INTENT (OUT)            :: ft1, fq1, fqcomp1, fu1, fv1
+  REAL, DIMENSION (len, nd, ntra), INTENT (OUT)      :: ftra1
+  REAL, DIMENSION (len), INTENT (OUT)                :: sigd1
+  REAL, DIMENSION (len, nd), INTENT (OUT)            :: ma1, mip1
+  REAL, DIMENSION (len, nd+1), INTENT (OUT)          :: vprecip1
+  REAL, DIMENSION (len, nd+1), INTENT (OUT)          :: vprecipi1
+  REAL, DIMENSION (len, nd), INTENT (OUT)            :: upwd1, dnwd1, dnwd01
+  REAL, DIMENSION (len, nd), INTENT (OUT)            :: qcondc1
+  REAL, DIMENSION (len), INTENT (OUT)                :: wd1, cape1, cin1
+  REAL, DIMENSION (len, nd), INTENT (OUT)            :: tvp1
+  REAL, DIMENSION (len, nd), INTENT (OUT)            :: ftd1, fqd1
+  REAL, DIMENSION (len), INTENT (OUT)                :: plim11, plim21
+  REAL, DIMENSION (len, nd), INTENT (OUT)            :: asupmax1
+  REAL, DIMENSION (len), INTENT (OUT)                :: supmax01, asupmaxmin1
+                                                    
+  REAL, DIMENSION (len, nd), INTENT (OUT)            :: da1
+  REAL, DIMENSION (len, nd, nd), INTENT (OUT)        :: phi1                   !AC!
+  REAL, DIMENSION (len, nd), INTENT (OUT)            :: mp1                    !RomP
+  REAL, DIMENSION (len, nd, nd), INTENT (OUT)        :: phi21                  !RomP
+  REAL, DIMENSION (len, nd), INTENT (OUT)            :: d1a1, dam1 !RomP       !RomP
+  REAL, DIMENSION (len, nd, nd), INTENT (OUT)        :: sigij1                 !RomP
+  REAL, DIMENSION (len, nd), INTENT (OUT)            :: qta1                   !jyg
+  REAL, DIMENSION (len, nd), INTENT (OUT)            :: clw1                   !RomP
+  REAL, DIMENSION (len, nd, nd), INTENT (OUT)        :: elij1                  !RomP
+  REAL, DIMENSION (len, nd), INTENT (OUT)            :: evap1, ep1             !RomP
+  REAL, DIMENSION (len, nd, nd), INTENT (OUT)        :: epmlmMm1               !RomP+jyg
+  REAL, DIMENSION (len, nd), INTENT (OUT)            :: eplamM1                !RomP+jyg
+  REAL, DIMENSION (len, nd), INTENT (OUT)            :: qtc1, sigt1, detrain1            !RomP
+  REAL, DIMENSION (len, nd), INTENT (OUT)            :: wdtrainA1, wdtrainS1, wdtrainM1   !RomP
+
+
+  ! local variables:
+  INTEGER i, k, j
+  INTEGER jdcum
+  ! c    integer k1,k2
+
+!jyg<
+  IF (compress) THEN
+!>jyg
+    DO i = 1, ncum
+      sig1(idcum(i), nd) = sig(i, nd)
+      ptop21(idcum(i)) = ptop2(i)
+      sigd1(idcum(i)) = sigd(i)
+      precip1(idcum(i)) = precip(i)
+      cbmf1(idcum(i)) = cbmf(i)
+      plcl1(idcum(i)) = plcl(i)
+      plfc1(idcum(i)) = plfc(i)
+      wbeff1(idcum(i)) = wbeff(i)
+      iflag1(idcum(i)) = iflag(i)
+      kbas1(idcum(i)) = kbas(i)
+      ktop1(idcum(i)) = ktop(i)
+      wd1(idcum(i)) = wd(i)
+      cape1(idcum(i)) = cape(i)
+      cin1(idcum(i)) = cin(i)
+      plim11(idcum(i)) = plim1(i)
+      plim21(idcum(i)) = plim2(i)
+      supmax01(idcum(i)) = supmax0(i)
+      asupmaxmin1(idcum(i)) = asupmaxmin(i)
+      epmax_diag1(idcum(i)) = epmax_diag(i)
+    END DO
+   
+    DO k = 1, nl
+      DO i = 1, ncum
+        sig1(idcum(i), k) = sig(i, k)
+        w01(idcum(i), k) = w0(i, k)
+        ft1(idcum(i), k) = ft(i, k)
+        fq1(idcum(i), k) = fq(i, k)
+        fqcomp1(idcum(i), k) = fqcomp(i, k)
+        fu1(idcum(i), k) = fu(i, k)
+        fv1(idcum(i), k) = fv(i, k)
+        ma1(idcum(i), k) = ma(i, k)
+        mip1(idcum(i), k) = mip(i, k)
+        vprecip1(idcum(i), k) = vprecip(i, k)
+        vprecipi1(idcum(i), k) = vprecipi(i, k)
+        upwd1(idcum(i), k) = upwd(i, k)
+        dnwd1(idcum(i), k) = dnwd(i, k)
+        dnwd01(idcum(i), k) = dnwd0(i, k)
+        qcondc1(idcum(i), k) = qcondc(i, k)
+        tvp1(idcum(i), k) = tvp(i, k)
+        ftd1(idcum(i), k) = ftd(i, k)
+        fqd1(idcum(i), k) = fqd(i, k)
+        asupmax1(idcum(i), k) = asupmax(i, k)
+   
+        da1(idcum(i), k) = da(i, k) !AC!
+        mp1(idcum(i), k) = mp(i, k) !RomP
+        d1a1(idcum(i), k) = d1a(i, k) !RomP
+        dam1(idcum(i), k) = dam(i, k) !RomP
+        qta1(idcum(i), k) = qta(i, k) !jyg
+        clw1(idcum(i), k) = clw(i, k) !RomP
+        evap1(idcum(i), k) = evap(i, k) !RomP
+        ep1(idcum(i), k) = ep(i, k) !RomP
+        eplamM1(idcum(i), k) = eplamM(i, k) !RomP+jyg
+        wdtrainA1(idcum(i), k) = wdtrainA(i, k) !RomP
+        wdtrainS1(idcum(i), k) = wdtrainS(i, k) !RomP
+        wdtrainM1(idcum(i), k) = wdtrainM(i, k) !RomP
+        qtc1(idcum(i), k) = qtc(i, k)
+        sigt1(idcum(i), k) = sigt(i, k)
+        detrain1(idcum(i), k) = detrain(i, k)
+   
+      END DO
+    END DO
+
+! Fluxes are defined on a staggered grid and extend up to nl+1
+    DO i = 1, ncum
+      ma1(idcum(i), nlp) = 0.
+      vprecip1(idcum(i), nlp) = 0.
+      vprecipi1(idcum(i), nlp) = 0.
+      upwd1(idcum(i), nlp) = 0.
+      dnwd1(idcum(i), nlp) = 0.
+      dnwd01(idcum(i), nlp) = 0.
+    END DO
+   
+    ! AC!        do 2100 j=1,ntra
+    ! AC!c oct3         do 2110 k=1,nl
+    ! AC!         do 2110 k=1,nd ! oct3
+    ! AC!          do 2120 i=1,ncum
+    ! AC!            ftra1(idcum(i),k,j)=ftra(i,k,j)
+    ! AC! 2120     continue
+    ! AC! 2110    continue
+    ! AC! 2100   continue
+   
+    ! AC!
+!jyg<
+!  Essais pour gagner du temps en diminuant l'adressage indirect 
+!!    DO j = 1, nd
+!!      DO k = 1, nd
+!!        DO i = 1, ncum
+!!          phi1(idcum(i), k, j) = phi(i, k, j) !AC!
+!!          phi21(idcum(i), k, j) = phi2(i, k, j) !RomP
+!!          sigij1(idcum(i), k, j) = sigij(i, k, j) !RomP
+!!          elij1(idcum(i), k, j) = elij(i, k, j) !RomP
+!!          epmlmMm(idcum(i), k, j) = epmlmMm(i, k, j) !RomP+jyg
+!!        END DO
+!!      END DO
+!!    END DO
+
+!!      DO i = 1, ncum
+!!        jdcum=idcum(i)
+!!        phi1    (jdcum, 1:nl+1, 1:nl+1) = phi    (i, 1:nl+1, 1:nl+1)          !AC!
+!!        phi21   (jdcum, 1:nl+1, 1:nl+1) = phi2   (i, 1:nl+1, 1:nl+1)          !RomP
+!!        sigij1  (jdcum, 1:nl+1, 1:nl+1) = sigij  (i, 1:nl+1, 1:nl+1)          !RomP
+!!        elij1   (jdcum, 1:nl+1, 1:nl+1) = elij   (i, 1:nl+1, 1:nl+1)          !RomP
+!!        epmlmMm1(jdcum, 1:nl+1, 1:nl+1) = epmlmMm(i, 1:nl+1, 1:nl+1)          !RomP+jyg
+!!      END DO
+!  These tracer associated arrays are defined up to nl, not nl+1
+  DO i = 1, ncum
+    jdcum=idcum(i)
+    DO k = 1,nl
+      DO j = 1,nl
+        phi1    (jdcum, j, k) = phi    (i, j, k)          !AC!
+        phi21   (jdcum, j, k) = phi2   (i, j, k)          !RomP
+        sigij1  (jdcum, j, k) = sigij  (i, j, k)          !RomP
+        elij1   (jdcum, j, k) = elij   (i, j, k)          !RomP
+        epmlmMm1(jdcum, j, k) = epmlmMm(i, j, k)          !RomP+jyg
+      END DO
+    ENDDO
+  ENDDO
+!>jyg
+    ! AC!
+   
+   
+    ! do 2220 k2=1,nd
+    ! do 2210 k1=1,nd
+    ! do 2200 i=1,ncum
+    ! ment1(idcum(i),k1,k2) = ment(i,k1,k2)
+    ! sigij1(idcum(i),k1,k2) = sigij(i,k1,k2)
+    ! 2200      enddo
+    ! 2210     enddo
+    ! 2220    enddo
+!
+!jyg<
+  ELSE  !(compress)
+!
+      sig1(:,nd) = sig(:,nd)
+      ptop21(:) = ptop2(:)
+      sigd1(:) = sigd(:)
+      precip1(:) = precip(:)
+      cbmf1(:) = cbmf(:)
+      plcl1(:) = plcl(:)
+      plfc1(:) = plfc(:)
+      wbeff1(:) = wbeff(:)
+      iflag1(:) = iflag(:)
+      kbas1(:) = kbas(:)
+      ktop1(:) = ktop(:)
+      wd1(:) = wd(:)
+      cape1(:) = cape(:)
+      cin1(:) = cin(:)
+      plim11(:) = plim1(:)
+      plim21(:) = plim2(:)
+      supmax01(:) = supmax0(:)
+      asupmaxmin1(:) = asupmaxmin(:)
+!
+      sig1(:, 1:nl) = sig(:, 1:nl)
+      w01(:, 1:nl) = w0(:, 1:nl)
+      ft1(:, 1:nl) = ft(:, 1:nl)
+      fq1(:, 1:nl) = fq(:, 1:nl)
+      fqcomp1(:, 1:nl) = fqcomp(:, 1:nl)
+      fu1(:, 1:nl) = fu(:, 1:nl)
+      fv1(:, 1:nl) = fv(:, 1:nl)
+      ma1(:, 1:nl) = ma(:, 1:nl)
+      mip1(:, 1:nl) = mip(:, 1:nl)
+      vprecip1(:, 1:nl) = vprecip(:, 1:nl)
+      vprecipi1(:, 1:nl) = vprecipi(:, 1:nl)
+      upwd1(:, 1:nl) = upwd(:, 1:nl)
+      dnwd1(:, 1:nl) = dnwd(:, 1:nl)
+      dnwd01(:, 1:nl) = dnwd0(:, 1:nl)
+      qcondc1(:, 1:nl) = qcondc(:, 1:nl)
+      tvp1(:, 1:nl) = tvp(:, 1:nl)
+      ftd1(:, 1:nl) = ftd(:, 1:nl)
+      fqd1(:, 1:nl) = fqd(:, 1:nl)
+      asupmax1(:, 1:nl) = asupmax(:, 1:nl)
+
+      da1(:, 1:nl) = da(:, 1:nl)              !AC!
+      mp1(:, 1:nl) = mp(:, 1:nl)              !RomP
+      d1a1(:, 1:nl) = d1a(:, 1:nl)            !RomP
+      dam1(:, 1:nl) = dam(:, 1:nl)            !RomP
+      qta1(:, 1:nl) = qta(:, 1:nl)            !jyg
+      clw1(:, 1:nl) = clw(:, 1:nl)            !RomP
+      evap1(:, 1:nl) = evap(:, 1:nl)          !RomP
+      ep1(:, 1:nl) = ep(:, 1:nl)              !RomP
+      eplamM1(:, 1:nl) = eplamM(:, 1:nl)       !RomP+jyg
+      wdtrainA1(:, 1:nl) = wdtrainA(:, 1:nl)  !RomP
+      wdtrainS1(:, 1:nl) = wdtrainS(:, 1:nl)  !RomP
+      wdtrainM1(:, 1:nl) = wdtrainM(:, 1:nl)  !RomP
+      qtc1(:, 1:nl) = qtc(:, 1:nl)
+      sigt1(:, 1:nl) = sigt(:, 1:nl)
+      detrain1(:, 1:nl) = detrain(:, 1:nl)
+!
+      ma1(:, nlp) = 0.
+      vprecip1(:, nlp) = 0.
+      vprecipi1(:, nlp) = 0.
+      upwd1(:, nlp) = 0.
+      dnwd1(:, nlp) = 0.
+      dnwd01(:, nlp) = 0.
+
+!
+      phi1    (:, 1:nl, 1:nl) = phi    (:, 1:nl, 1:nl)  !AC!
+      phi21   (:, 1:nl, 1:nl) = phi2   (:, 1:nl, 1:nl)  !RomP
+      sigij1  (:, 1:nl, 1:nl) = sigij  (:, 1:nl, 1:nl)  !RomP
+      elij1   (:, 1:nl, 1:nl) = elij   (:, 1:nl, 1:nl)  !RomP
+      epmlmMm1(:, 1:nl, 1:nl) = epmlmMm(:, 1:nl, 1:nl)  !RomP+jyg
+  ENDIF !(compress)
+!>jyg
+
+  RETURN
+END SUBROUTINE cv3a_uncompress
+
Index: DZ6/trunk/libf/phylmd/cv3p1_closure.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cv3p1_closure.F90	(revision 5267)
+++ 	(revision )
@@ -1,773 +1,0 @@
-
-! $Id$
-
-SUBROUTINE cv3p1_closure(nloc, ncum, nd, icb, inb, pbase, plcl, p, ph, tv, &
-    tvp, buoy, supmax, ok_inhib, ale, alp, omega,sig, w0, ptop2, cape, cin, m, &
-    iflag, coef, plim1, plim2, asupmax, supmax0, asupmaxmin, cbmf, plfc, &
-    wbeff)
-
-
-  ! **************************************************************
-  ! *
-  ! CV3P1_CLOSURE                                               *
-  ! Ale & Alp Closure of Convect3              *
-  ! *
-  ! written by   :   Kerry Emanuel                              *
-  ! vectorization:   S. Bony                                    *
-  ! modified by :    Jean-Yves Grandpeix, 18/06/2003, 19.32.10  *
-  ! Julie Frohwirth,     14/10/2005  17.44.22  *
-  ! **************************************************************
-
-  USE print_control_mod, ONLY: prt_level, lunout
-  IMPLICIT NONE
-
-  include "cvthermo.h"
-  include "cv3param.h"
-  include "YOMCST2.h"
-  include "YOMCST.h"
-  include "conema3.h"
-
-  ! input:
-  INTEGER, INTENT (IN)                               :: ncum, nd, nloc
-  INTEGER, DIMENSION (nloc), INTENT (IN)             :: icb, inb
-  REAL, DIMENSION (nloc), INTENT (IN)                :: pbase, plcl
-  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: p
-  REAL, DIMENSION (nloc, nd+1), INTENT (IN)          :: ph
-  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: tv, tvp, buoy
-  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: supmax
-  LOGICAL, INTENT (IN)                               :: ok_inhib ! enable convection inhibition by dryness
-  REAL, DIMENSION (nloc), INTENT (IN)                :: ale, alp
-  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: omega
-
-  ! input/output:
-  INTEGER, DIMENSION (nloc), INTENT (INOUT)          :: iflag
-  REAL, DIMENSION (nloc, nd), INTENT (INOUT)         :: sig, w0
-  REAL, DIMENSION (nloc), INTENT (INOUT)             :: ptop2
-
-  ! output:
-  REAL, DIMENSION (nloc), INTENT (OUT)               :: cape, cin
-  REAL, DIMENSION (nloc, nd), INTENT (OUT)           :: m
-  REAL, DIMENSION (nloc), INTENT (OUT)               :: plim1, plim2
-  REAL, DIMENSION (nloc, nd), INTENT (OUT)           :: asupmax
-  REAL, DIMENSION (nloc), INTENT (OUT)               :: supmax0
-  REAL, DIMENSION (nloc), INTENT (OUT)               :: asupmaxmin
-  REAL, DIMENSION (nloc), INTENT (OUT)               :: cbmf, plfc
-  REAL, DIMENSION (nloc), INTENT (OUT)               :: wbeff
-
-  ! local variables:
-  INTEGER il, i, j, k, icbmax, i0(nloc), klfc(nloc)
-  REAL deltap, fac, w, amu
-  REAL rhodp, dz
-  REAL pbmxup
-  REAL dtmin(nloc, nd), sigold(nloc, nd)
-  REAL coefmix(nloc, nd)
-  REAL pzero(nloc), ptop2old(nloc)
-  REAL cina(nloc), cinb(nloc)
-  INTEGER ibeg(nloc)
-  INTEGER nsupmax(nloc)
-  REAL supcrit, temp(nloc, nd)
-  REAL p1(nloc), pmin(nloc)
-  REAL asupmax0(nloc)
-  LOGICAL ok(nloc)
-  REAL siglim(nloc, nd), wlim(nloc, nd), mlim(nloc, nd)
-  REAL wb2(nloc)
-  REAL cbmflim(nloc), cbmf1(nloc), cbmfmax(nloc)
-  REAL cbmflast(nloc)
-  REAL coef(nloc)
-  REAL xp(nloc), xq(nloc), xr(nloc), discr(nloc), b3(nloc), b4(nloc)
-  REAL theta(nloc), bb(nloc)
-  REAL term1, term2, term3
-  REAL alp2(nloc) ! Alp with offset
-  !CR: variables for new erosion of adiabiatic ascent
-  REAL mad(nloc, nd), me(nloc, nd), betalim(nloc, nd), beta_coef(nloc, nd)
-  REAL med(nloc, nd), md(nloc,nd)
-!jyg<
-! coef_peel is now in the common cv3_param 
-!!  REAL coef_peel
-!!  PARAMETER (coef_peel=0.25)
-!>jyg
-
-  REAL sigmax
-  PARAMETER (sigmax=0.1)
-
-  CHARACTER (LEN=20) :: modname = 'cv3p1_closure'
-  CHARACTER (LEN=80) :: abort_message
-
-  ! print *,' -> cv3p1_closure, Ale ',ale(1)
-
-
-  ! -------------------------------------------------------
-  ! -- Initialization
-  ! -------------------------------------------------------
-
-
-  DO il = 1, ncum
-    alp2(il) = max(alp(il), 1.E-5)
-    ! IM
-    alp2(il) = max(alp(il), 1.E-12)
-  END DO
-
-  pbmxup = 50. ! PBMXUP+PBCRIT = cloud depth above which mixed updraughts
-  ! exist (if any)
-
-  IF (prt_level>=20) PRINT *, 'cv3p1_param nloc ncum nd icb inb nl', nloc, &
-    ncum, nd, icb(nloc), inb(nloc), nl
-  DO k = 1, nd          !jyg: initialization up to nd
-    DO il = 1, ncum
-      m(il, k) = 0.0
-    END DO
-  END DO
-
-!CR: initializations for erosion of adiabatic ascent 
-  DO k = 1,nd           !jyg: initialization up to nd
-    DO il = 1, ncum
-        mad(il,k)=0.
-        me(il,k)=0.
-        betalim(il,k)=1.
-        wlim(il,k)=0.
-    ENDDO
-  ENDDO
-
-  ! -------------------------------------------------------
-  ! -- Reset sig(i) and w0(i) for i>inb and i<icb
-  ! -------------------------------------------------------
-
-  ! update sig and w0 above LNB:
-
-  DO k = 1, nl - 1
-    DO il = 1, ncum
-      IF ((inb(il)<(nl-1)) .AND. (k>=(inb(il)+1))) THEN
-        sig(il, k) = beta*sig(il, k) + 2.*alpha*buoy(il, inb(il))*abs(buoy(il &
-          ,inb(il)))
-        sig(il, k) = amax1(sig(il,k), 0.0)
-        w0(il, k) = beta*w0(il, k)
-      END IF
-    END DO
-  END DO
-
-  ! if(prt.level.GE.20) print*,'cv3p1_param apres 100'
-  ! compute icbmax:
-
-  icbmax = 2
-  DO il = 1, ncum
-    icbmax = max(icbmax, icb(il))
-  END DO
-  ! if(prt.level.GE.20) print*,'cv3p1_param apres 200'
-
-  ! update sig and w0 below cloud base:
-
-  DO k = 1, icbmax
-    DO il = 1, ncum
-      IF (k<=icb(il)) THEN
-        sig(il, k) = beta*sig(il, k) - 2.*alpha*buoy(il, icb(il))*buoy(il, &
-          icb(il))
-        sig(il, k) = amax1(sig(il,k), 0.0)
-        w0(il, k) = beta*w0(il, k)
-      END IF
-    END DO
-  END DO
-  IF (prt_level>=20) PRINT *, 'cv3p1_param apres 300'
-  ! -------------------------------------------------------------
-  ! -- Reset fractional areas of updrafts and w0 at initial time
-  ! -- and after 10 time steps of no convection
-  ! -------------------------------------------------------------
-
-  DO k = 1, nl - 1
-    DO il = 1, ncum
-      IF (sig(il,nd)<1.5 .OR. sig(il,nd)>12.0) THEN
-        sig(il, k) = 0.0
-        w0(il, k) = 0.0
-      END IF
-    END DO
-  END DO
-  IF (prt_level>=20) PRINT *, 'cv3p1_param apres 400'
-
-  ! -------------------------------------------------------------
-  ! jyg1
-  ! --  Calculate adiabatic ascent top pressure (ptop)
-  ! -------------------------------------------------------------
-
-
-  ! c 1. Start at first level where precipitations form
-  DO il = 1, ncum
-    pzero(il) = plcl(il) - pbcrit
-  END DO
-
-  ! c 2. Add offset
-  DO il = 1, ncum
-    pzero(il) = pzero(il) - pbmxup
-  END DO
-  DO il = 1, ncum
-    ptop2old(il) = ptop2(il)
-  END DO
-
-  DO il = 1, ncum
-    ! CR:c est quoi ce 300??
-    p1(il) = pzero(il) - 300.
-  END DO
-
-  ! compute asupmax=abs(supmax) up to lnm+1
-
-  DO il = 1, ncum
-    ok(il) = .TRUE.
-    nsupmax(il) = inb(il)
-  END DO
-
-  DO i = 1, nl
-    DO il = 1, ncum
-      IF (i>icb(il) .AND. i<=inb(il)) THEN
-        IF (p(il,i)<=pzero(il) .AND. supmax(il,i)<0 .AND. ok(il)) THEN
-          nsupmax(il) = i
-          ok(il) = .FALSE.
-        END IF ! end IF (P(i) ...  )
-      END IF ! end IF (icb+1 le i le inb)
-    END DO
-  END DO
-
-  IF (prt_level>=20) PRINT *, 'cv3p1_param apres 2.'
-  DO i = 1, nl
-    DO il = 1, ncum
-      asupmax(il, i) = abs(supmax(il,i))
-    END DO
-  END DO
-
-
-  DO il = 1, ncum
-    asupmaxmin(il) = 10.
-    pmin(il) = 100.
-    ! IM ??
-    asupmax0(il) = 0.
-  END DO
-
-  ! c 3.  Compute in which level is Pzero
-
-  ! IM bug      i0 = 18
-  DO il = 1, ncum
-    i0(il) = nl
-  END DO
-
-  DO i = 1, nl
-    DO il = 1, ncum
-      IF (i>icb(il) .AND. i<=inb(il)) THEN
-        IF (p(il,i)<=pzero(il) .AND. p(il,i)>=p1(il)) THEN
-          IF (pzero(il)>p(il,i) .AND. pzero(il)<p(il,i-1)) THEN
-            i0(il) = i
-          END IF
-        END IF
-      END IF
-    END DO
-  END DO
-  IF (prt_level>=20) PRINT *, 'cv3p1_param apres 3.'
-
-  ! c 4.  Compute asupmax at Pzero
-
-  DO i = 1, nl
-    DO il = 1, ncum
-      IF (i>icb(il) .AND. i<=inb(il)) THEN
-        IF (p(il,i)<=pzero(il) .AND. p(il,i)>=p1(il)) THEN
-          asupmax0(il) = ((pzero(il)-p(il,i0(il)-1))*asupmax(il,i0(il))-( &
-            pzero(il)-p(il,i0(il)))*asupmax(il,i0(il)-1))/(p(il,i0(il))-p(il, &
-            i0(il)-1))
-        END IF
-      END IF
-    END DO
-  END DO
-
-
-  DO i = 1, nl
-    DO il = 1, ncum
-      IF (p(il,i)==pzero(il)) THEN
-        asupmax(i, il) = asupmax0(il)
-      END IF
-    END DO
-  END DO
-  IF (prt_level>=20) PRINT *, 'cv3p1_param apres 4.'
-
-  ! c 5. Compute asupmaxmin, minimum of asupmax
-
-  DO i = 1, nl
-    DO il = 1, ncum
-      IF (i>icb(il) .AND. i<=inb(il)) THEN
-        IF (p(il,i)<=pzero(il) .AND. p(il,i)>=p1(il)) THEN
-          IF (asupmax(il,i)<asupmaxmin(il)) THEN
-            asupmaxmin(il) = asupmax(il, i)
-            pmin(il) = p(il, i)
-          END IF
-        END IF
-      END IF
-    END DO
-  END DO
-
-  DO il = 1, ncum
-    ! IM
-    IF (prt_level>=20) THEN
-      PRINT *, 'cv3p1_closure il asupmax0 asupmaxmin', il, asupmax0(il), &
-        asupmaxmin(il), pzero(il), pmin(il)
-    END IF
-    IF (asupmax0(il)<asupmaxmin(il)) THEN
-      asupmaxmin(il) = asupmax0(il)
-      pmin(il) = pzero(il)
-    END IF
-  END DO
-  IF (prt_level>=20) PRINT *, 'cv3p1_param apres 5.'
-
-
-  ! Compute Supmax at Pzero
-
-  DO i = 1, nl
-    DO il = 1, ncum
-      IF (i>icb(il) .AND. i<=inb(il)) THEN
-        IF (p(il,i)<=pzero(il)) THEN
-          supmax0(il) = ((p(il,i)-pzero(il))*asupmax(il,i-1)-(p(il, &
-            i-1)-pzero(il))*asupmax(il,i))/(p(il,i)-p(il,i-1))
-          GO TO 425
-        END IF ! end IF (P(i) ... )
-      END IF ! end IF (icb+1 le i le inb)
-    END DO
-  END DO
-
-425 CONTINUE
-  IF (prt_level>=20) PRINT *, 'cv3p1_param apres 425.'
-
-  ! c 6. Calculate ptop2
-
-  DO il = 1, ncum
-    IF (asupmaxmin(il)<supcrit1) THEN
-      ptop2(il) = pmin(il)
-    END IF
-
-    IF (asupmaxmin(il)>supcrit1 .AND. asupmaxmin(il)<supcrit2) THEN
-      ptop2(il) = ptop2old(il)
-    END IF
-
-    IF (asupmaxmin(il)>supcrit2) THEN
-      ptop2(il) = ph(il, inb(il))
-    END IF
-  END DO
-
-  IF (prt_level>=20) PRINT *, 'cv3p1_param apres 6.'
-
-  ! c 7. Compute multiplying factor for adiabatic updraught mass flux
-
-
-  IF (ok_inhib) THEN
-
-    DO i = 1, nl
-      DO il = 1, ncum
-        IF (i<=nl) THEN
-          coefmix(il, i) = (min(ptop2(il),ph(il,i))-ph(il,i))/(ph(il,i+1)-ph( &
-            il,i))
-          coefmix(il, i) = min(coefmix(il,i), 1.)
-        END IF
-      END DO
-    END DO
-
-
-  ELSE ! when inhibition is not taken into account, coefmix=1
-
-
-
-    DO i = 1, nl
-      DO il = 1, ncum
-        IF (i<=nl) THEN
-          coefmix(il, i) = 1.
-        END IF
-      END DO
-    END DO
-
-  END IF ! ok_inhib
-  IF (prt_level>=20) PRINT *, 'cv3p1_param apres 7.'
-  ! -------------------------------------------------------------------
-  ! -------------------------------------------------------------------
-
-
-  ! jyg2
-
-  ! ==========================================================================
-
-
-  ! -------------------------------------------------------------
-  ! -- Calculate convective inhibition (CIN)
-  ! -------------------------------------------------------------
-
-  ! do i=1,nloc
-  ! print*,'avant cine p',pbase(i),plcl(i)
-  ! enddo
-  ! do j=1,nd
-  ! do i=1,nloc
-  ! print*,'avant cine t',tv(i),tvp(i)
-  ! enddo
-  ! enddo
-  CALL cv3_cine(nloc, ncum, nd, icb, inb, pbase, plcl, p, ph, tv, tvp, cina, &
-    cinb, plfc)
-
-  DO il = 1, ncum
-    cin(il) = cina(il) + cinb(il)
-  END DO
-  IF (prt_level>=20) PRINT *, 'cv3p1_param apres cv3_cine'
-  ! -------------------------------------------------------------
-  ! --Update buoyancies to account for Ale
-  ! -------------------------------------------------------------
-
-  CALL cv3_buoy(nloc, ncum, nd, icb, inb, pbase, plcl, p, ph, ale, cin, tv, &
-    tvp, buoy)
-  IF (prt_level>=20) PRINT *, 'cv3p1_param apres cv3_buoy'
-
-  ! -------------------------------------------------------------
-  ! -- Calculate convective available potential energy (cape),
-  ! -- vertical velocity (w), fractional area covered by
-  ! -- undilute updraft (sig), and updraft mass flux (m)
-  ! -------------------------------------------------------------
-
-  DO il = 1, ncum
-    cape(il) = 0.0
-  END DO
-
-  ! compute dtmin (minimum buoyancy between ICB and given level k):
-
-  DO k = 1, nl
-    DO il = 1, ncum
-      dtmin(il, k) = 100.0
-    END DO
-  END DO
-
-  DO k = 1, nl
-    DO j = minorig, nl
-      DO il = 1, ncum
-        IF ((k>=(icb(il)+1)) .AND. (k<=inb(il)) .AND. (j>=icb(il)) .AND. (j<= &
-            (k-1))) THEN
-          dtmin(il, k) = amin1(dtmin(il,k), buoy(il,j))
-        END IF
-      END DO
-    END DO
-  END DO
-
-  ! the interval on which cape is computed starts at pbase :
-
-  DO k = 1, nl
-    DO il = 1, ncum
-
-      IF ((k>=(icb(il)+1)) .AND. (k<=inb(il))) THEN
-        IF (iflag_mix_adiab.eq.1) THEN
-!CR:computation of cape from LCL: keep flag or to modify in all cases?
-        deltap = min(plcl(il), ph(il,k-1)) - min(plcl(il), ph(il,k))
-        ELSE
-        deltap = min(pbase(il), ph(il,k-1)) - min(pbase(il), ph(il,k))
-        ENDIF
-        cape(il) = cape(il) + rrd*buoy(il, k-1)*deltap/p(il, k-1)
-        cape(il) = amax1(0.0, cape(il))
-        sigold(il, k) = sig(il, k)
-
-
-        ! jyg       Coefficient coefmix limits convection to levels where a
-        ! sufficient
-        ! fraction of mixed draughts are ascending.
-        siglim(il, k) = coefmix(il, k)*alpha1*dtmin(il, k)*abs(dtmin(il,k))
-        siglim(il, k) = amax1(siglim(il,k), 0.0)
-        siglim(il, k) = amin1(siglim(il,k), 0.01)
-        ! c         fac=AMIN1(((dtcrit-dtmin(il,k))/dtcrit),1.0)
-        fac = 1.
-        wlim(il, k) = fac*sqrt(cape(il))
-        amu = siglim(il, k)*wlim(il, k)
-        rhodp = 0.007*p(il, k)*(ph(il,k)-ph(il,k+1))/tv(il, k)
-        mlim(il, k) = amu*rhodp
-        ! print*, 'siglim ', k,siglim(1,k)
-      END IF
-
-    END DO
-  END DO
-  IF (prt_level>=20) PRINT *, 'cv3p1_param apres 600'
-
-  DO il = 1, ncum
-    ! IM beg
-    IF (prt_level>=20) THEN
-      PRINT *, 'cv3p1_closure il icb mlim ph ph+1 ph+2', il, icb(il), &
-        mlim(il, icb(il)+1), ph(il, icb(il)), ph(il, icb(il)+1), &
-        ph(il, icb(il)+2)
-    END IF
-
-    IF (icb(il)+1<=inb(il)) THEN
-      ! IM end
-      mlim(il, icb(il)) = 0.5*mlim(il, icb(il)+1)*(ph(il,icb(il))-ph(il,icb( &
-        il)+1))/(ph(il,icb(il)+1)-ph(il,icb(il)+2))
-      ! IM beg
-    END IF !(icb(il.le.inb(il))) then
-    ! IM end
-  END DO
-  IF (prt_level>=20) PRINT *, 'cv3p1_param apres 700'
-
-  ! jyg1
-  ! ------------------------------------------------------------------------
-  ! c     Correct mass fluxes so that power used to overcome CIN does not
-  ! c     exceed Power Available for Lifting (PAL).
-  ! ------------------------------------------------------------------------
-
-  DO il = 1, ncum
-    cbmflim(il) = 0.
-    cbmf(il) = 0.
-  END DO
-
-  ! c 1. Compute cloud base mass flux of elementary system (Cbmf0=Cbmflim)
-
-  DO k = 1, nl
-    DO il = 1, ncum
-      ! old       IF (k .ge. icb(il) .and. k .le. inb(il)) THEN
-      ! IM        IF (k .ge. icb(il)+1 .and. k .le. inb(il)) THEN
-      IF (k>=icb(il) .AND. k<=inb(il) & !cor jyg
-          .AND. icb(il)+1<=inb(il)) THEN !cor jyg
-        cbmflim(il) = cbmflim(il) + mlim(il, k)
-      END IF
-    END DO
-  END DO
-  IF (prt_level>=20) PRINT *, 'cv3p1_param apres cbmflim'
-
-  ! 1.5 Compute cloud base mass flux given by Alp closure (Cbmf1), maximum
-  !     allowed mass flux (Cbmfmax) and final target mass flux (Cbmf)
-  !     Cbmf is set to zero if Cbmflim (the mass flux of elementary cloud)
-  !     is exceedingly small.
-
-  DO il = 1, ncum
-    wb2(il) = sqrt(2.*max(ale(il)+cin(il),0.))
-  END DO
-
-  DO il = 1, ncum
-    IF (plfc(il)<100.) THEN
-      ! This is an irealistic value for plfc => no calculation of wbeff
-      wbeff(il) = 100.1
-    ELSE
-      ! Calculate wbeff
-      IF (NINT(flag_wb)==0) THEN
-        wbeff(il) = wbmax
-      ELSE IF (NINT(flag_wb)==1) THEN
-        wbeff(il) = wbmax/(1.+500./(ph(il,1)-plfc(il)))
-      ELSE IF (NINT(flag_wb)==2) THEN
-        wbeff(il) = wbmax*(0.01*(ph(il,1)-plfc(il)))**2
-      ELSE ! Option provisoire ou le iflag_wb/10 est considere comme une vitesse
-        wbeff(il) = flag_wb*0.01+wbmax/(1.+500./(ph(il,1)-plfc(il)))
-      END IF
-    END IF
-  END DO
-
-!CR:Compute k at plfc
-  DO il=1,ncum
-           klfc(il)=nl
-  ENDDO
-  DO k=1,nl
-     DO il=1,ncum
-        if ((plfc(il).lt.ph(il,k)).and.(plfc(il).ge.ph(il,k+1))) then
-           klfc(il)=k
-        endif
-     ENDDO
-  ENDDO
-!RC
-
-  DO il = 1, ncum
-    ! jyg    Modification du coef de wb*wb pour conformite avec papier Wake
-    ! c       cbmf1(il) = alp2(il)/(0.5*wb*wb-Cin(il))
-    cbmf1(il) = alp2(il)/(2.*wbeff(il)*wbeff(il)-cin(il))
-!CR: Add large-scale component to the mass-flux
-!encore connu sous le nom "Experience du tube de dentifrice"
-    if ((coef_clos_ls.gt.0.).and.(plfc(il).gt.0.)) then 
-       cbmf1(il) = cbmf1(il) - coef_clos_ls*min(0.,1./RG*omega(il,klfc(il)))
-    endif
-!RC
-    IF (cbmf1(il)==0 .AND. alp2(il)/=0.) THEN
-      WRITE (lunout, *) 'cv3p1_closure cbmf1=0 and alp NE 0 il alp2 alp cin ' &
-        , il, alp2(il), alp(il), cin(il)
-      abort_message = ''
-      CALL abort_physic(modname, abort_message, 1)
-    END IF
-    cbmfmax(il) = sigmax*wb2(il)*100.*p(il, icb(il))/(rrd*tv(il,icb(il)))
-  END DO
-
-  DO il = 1, ncum
-    IF (cbmflim(il)>1.E-6) THEN
-      ! ATTENTION TEST CR
-      ! if (cbmfmax(il).lt.1.e-12) then
-      cbmf(il) = min(cbmf1(il), cbmfmax(il))
-      ! else
-      ! cbmf(il) = cbmf1(il)
-      ! endif
-      ! print*,'cbmf',cbmf1(il),cbmfmax(il)
-    END IF
-  END DO
-  IF (prt_level>=20) PRINT *, 'cv3p1_param apres cbmflim_testCR'
-
-  ! c 2. Compute coefficient and apply correction
-
-  DO il = 1, ncum
-    coef(il) = (cbmf(il)+1.E-10)/(cbmflim(il)+1.E-10)
-  END DO
-  IF (prt_level>=20) PRINT *, 'cv3p1_param apres coef_plantePLUS'
-
-  DO k = 1, nl
-    DO il = 1, ncum
-      IF (k>=icb(il)+1 .AND. k<=inb(il)) THEN
-        amu = beta*sig(il, k)*w0(il, k) + (1.-beta)*coef(il)*siglim(il, k)* &
-          wlim(il, k)
-        w0(il, k) = wlim(il, k)
-        w0(il, k) = max(w0(il,k), 1.E-10)
-        sig(il, k) = amu/w0(il, k)
-        sig(il, k) = min(sig(il,k), 1.)
-        ! c         amu = 0.5*(SIG(il,k)+sigold(il,k))*W0(il,k)
-        m(il, k) = amu*0.007*p(il, k)*(ph(il,k)-ph(il,k+1))/tv(il, k)
-      END IF
-    END DO
-  END DO
-  ! jyg2
-  DO il = 1, ncum
-    w0(il, icb(il)) = 0.5*w0(il, icb(il)+1)
-    m(il, icb(il)) = 0.5*m(il, icb(il)+1)*(ph(il,icb(il))-ph(il,icb(il)+1))/ &
-      (ph(il,icb(il)+1)-ph(il,icb(il)+2))
-    sig(il, icb(il)) = sig(il, icb(il)+1)
-    sig(il, icb(il)-1) = sig(il, icb(il))
-  END DO
-  IF (prt_level>=20) PRINT *, 'cv3p1_param apres w0_sig_M'
-
-!CR: new erosion of adiabatic ascent: modification of m
-!computation of the sum of ascending fluxes 
-  IF (iflag_mix_adiab.eq.1) THEN
-
-!Verification sum(me)=sum(m)
-  DO k = 1,nd                         !jyg: initialization up to nd
-    DO il = 1, ncum
-       md(il,k)=0.
-       med(il,k)=0.
-    ENDDO
-  ENDDO
-
-  DO k = nl,1,-1
-    DO il = 1, ncum
-           md(il,k)=md(il,k+1)+m(il,k+1)
-    ENDDO
-  ENDDO
-
-  DO k = nl,1,-1
-    DO il = 1, ncum
-        IF ((k>=(icb(il))) .AND. (k<=inb(il))) THEN
-           mad(il,k)=mad(il,k+1)+m(il,k+1)
-        ENDIF
-!        print*,"mad",il,k,mad(il,k)
-    ENDDO
-  ENDDO
-
-!CR: erosion of each adiabatic ascent during its ascent
-
-!Computation of erosion coefficient beta_coef
-  DO k = 1, nl
-    DO il = 1, ncum
-       IF ((k>=(icb(il)+1)) .AND. (k<=inb(il)) .AND. (mlim(il,k).gt.0.)) THEN     
-!          print*,"beta_coef",il,k,icb(il),inb(il),buoy(il,k),tv(il,k),wlim(il,k),wlim(il,k+1)
-          beta_coef(il,k)=RG*coef_peel*buoy(il,k)/tv(il,k)/((wlim(il,k)+wlim(il,k+1))/2.)**2
-       ELSE
-          beta_coef(il,k)=0.
-       ENDIF
-    ENDDO
-  ENDDO
-
-!  print*,"apres beta_coef"
-
-  DO k = 1, nl
-    DO il = 1, ncum
-
-      IF ((k>=(icb(il)+1)) .AND. (k<=inb(il))) THEN
-
-!        print*,"dz",il,k,tv(il, k-1)
-        dz = (ph(il,k-1)-ph(il,k))/(p(il, k-1)/(rrd*tv(il, k-1))*RG)
-        betalim(il,k)=betalim(il,k-1)*exp(-1.*beta_coef(il,k-1)*dz)
-!        betalim(il,k)=betalim(il,k-1)*exp(-RG*coef_peel*buoy(il,k-1)/tv(il,k-1)/5.**2*dz)
-!        print*,"me",il,k,mlim(il,k),buoy(il,k),wlim(il,k),mad(il,k)
-        dz = (ph(il,k)-ph(il,k+1))/(p(il, k)/(rrd*tv(il, k))*RG)
-!        me(il,k)=betalim(il,k)*(m(il,k)+RG*coef_peel*buoy(il,k)/tv(il,k)/((wlim(il,k)+wlim(il,k+1))/2.)**2*dz*mad(il,k))
-        me(il,k)=betalim(il,k)*(m(il,k)+beta_coef(il,k)*dz*mad(il,k))
-!        print*,"B/w2",il,k,RG*coef_peel*buoy(il,k)/tv(il,k)/((wlim(il,k)+wlim(il,k+1))/2.)**2*dz    
-      
-      END IF
-        
-!Modification of m
-      m(il,k)=me(il,k) 
-    END DO
-  END DO
- 
-!  DO il = 1, ncum
-!     dz = (ph(il,icb(il))-ph(il,icb(il)+1))/(p(il, icb(il))/(rrd*tv(il, icb(il)))*RG)
-!     m(il,icb(il))=m(il,icb(il))+RG*coef_peel*buoy(il,icb(il))/tv(il,icb(il)) &
-!                  /((wlim(il,icb(il))+wlim(il,icb(il)+1))/2.)**2*dz*mad(il,icb(il))
-!     print*,"wlim(icb)",icb(il),wlim(il,icb(il)),m(il,icb(il))
-!  ENDDO
-
-!Verification sum(me)=sum(m)
-  DO k = nl,1,-1
-    DO il = 1, ncum
-           med(il,k)=med(il,k+1)+m(il,k+1)
-!           print*,"somme(me),somme(m)",il,k,icb(il),med(il,k),md(il,k),me(il,k),m(il,k),wlim(il,k)
-    ENDDO
-  ENDDO
-
-
-  ENDIF !(iflag_mix_adiab)
-!RC
-
-
-
-  ! c 3. Compute final cloud base mass flux and set iflag to 3 if
-  ! c    cloud base mass flux is exceedingly small and is decreasing (i.e. if
-  ! c    the final mass flux (cbmflast) is greater than the target mass flux
-  ! c    (cbmf)).
-
-  DO il = 1, ncum
-    cbmflast(il) = 0.
-  END DO
-
-  DO k = 1, nl
-    DO il = 1, ncum
-      IF (k>=icb(il) .AND. k<=inb(il)) THEN
-          !IMpropo??      IF ((k.ge.(icb(il)+1)).and.(k.le.inb(il))) THEN
-        cbmflast(il) = cbmflast(il) + m(il, k)
-      END IF
-    END DO
-  END DO
-
-  DO il = 1, ncum
-    IF (cbmflast(il)<1.E-6 .AND. cbmflast(il)>=cbmf(il)) THEN
-      iflag(il) = 3
-    END IF
-  END DO
-
-  DO k = 1, nl
-    DO il = 1, ncum
-      IF (iflag(il)>=3) THEN
-        m(il, k) = 0.
-        sig(il, k) = 0.
-        w0(il, k) = 0.
-      END IF
-    END DO
-  END DO
-  IF (prt_level>=20) PRINT *, 'cv3p1_param apres iflag'
-
-  ! c 4. Introduce a correcting factor for coef, in order to obtain an
-  ! effective
-  ! c    sigdz larger in the present case (using cv3p1_closure) than in the
-  ! old
-  ! c    closure (using cv3_closure).
-  IF (1==0) THEN
-    DO il = 1, ncum
-      ! c      coef(il) = 2.*coef(il)
-      coef(il) = 5.*coef(il)
-    END DO
-    ! version CVS du ..2008
-  ELSE
-    IF (iflag_cvl_sigd==0) THEN
-      ! test pour verifier qu on fait la meme chose qu avant: sid constant
-      coef(1:ncum) = 1.
-    ELSE
-      coef(1:ncum) = min(2.*coef(1:ncum), 5.)
-      coef(1:ncum) = max(2.*coef(1:ncum), 0.2)
-    END IF
-  END IF
-
-  IF (prt_level>=20) PRINT *, 'cv3p1_param FIN'
-  RETURN
-END SUBROUTINE cv3p1_closure
-
-
Index: /LMDZ6/trunk/libf/phylmd/cv3p1_closure.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cv3p1_closure.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/cv3p1_closure.f90	(revision 5268)
@@ -0,0 +1,773 @@
+
+! $Id$
+
+SUBROUTINE cv3p1_closure(nloc, ncum, nd, icb, inb, pbase, plcl, p, ph, tv, &
+    tvp, buoy, supmax, ok_inhib, ale, alp, omega,sig, w0, ptop2, cape, cin, m, &
+    iflag, coef, plim1, plim2, asupmax, supmax0, asupmaxmin, cbmf, plfc, &
+    wbeff)
+
+
+  ! **************************************************************
+  ! *
+  ! CV3P1_CLOSURE                                               *
+  ! Ale & Alp Closure of Convect3              *
+  ! *
+  ! written by   :   Kerry Emanuel                              *
+  ! vectorization:   S. Bony                                    *
+  ! modified by :    Jean-Yves Grandpeix, 18/06/2003, 19.32.10  *
+  ! Julie Frohwirth,     14/10/2005  17.44.22  *
+  ! **************************************************************
+
+  USE print_control_mod, ONLY: prt_level, lunout
+  IMPLICIT NONE
+
+  include "cvthermo.h"
+  include "cv3param.h"
+  include "YOMCST2.h"
+  include "YOMCST.h"
+  include "conema3.h"
+
+  ! input:
+  INTEGER, INTENT (IN)                               :: ncum, nd, nloc
+  INTEGER, DIMENSION (nloc), INTENT (IN)             :: icb, inb
+  REAL, DIMENSION (nloc), INTENT (IN)                :: pbase, plcl
+  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: p
+  REAL, DIMENSION (nloc, nd+1), INTENT (IN)          :: ph
+  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: tv, tvp, buoy
+  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: supmax
+  LOGICAL, INTENT (IN)                               :: ok_inhib ! enable convection inhibition by dryness
+  REAL, DIMENSION (nloc), INTENT (IN)                :: ale, alp
+  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: omega
+
+  ! input/output:
+  INTEGER, DIMENSION (nloc), INTENT (INOUT)          :: iflag
+  REAL, DIMENSION (nloc, nd), INTENT (INOUT)         :: sig, w0
+  REAL, DIMENSION (nloc), INTENT (INOUT)             :: ptop2
+
+  ! output:
+  REAL, DIMENSION (nloc), INTENT (OUT)               :: cape, cin
+  REAL, DIMENSION (nloc, nd), INTENT (OUT)           :: m
+  REAL, DIMENSION (nloc), INTENT (OUT)               :: plim1, plim2
+  REAL, DIMENSION (nloc, nd), INTENT (OUT)           :: asupmax
+  REAL, DIMENSION (nloc), INTENT (OUT)               :: supmax0
+  REAL, DIMENSION (nloc), INTENT (OUT)               :: asupmaxmin
+  REAL, DIMENSION (nloc), INTENT (OUT)               :: cbmf, plfc
+  REAL, DIMENSION (nloc), INTENT (OUT)               :: wbeff
+
+  ! local variables:
+  INTEGER il, i, j, k, icbmax, i0(nloc), klfc(nloc)
+  REAL deltap, fac, w, amu
+  REAL rhodp, dz
+  REAL pbmxup
+  REAL dtmin(nloc, nd), sigold(nloc, nd)
+  REAL coefmix(nloc, nd)
+  REAL pzero(nloc), ptop2old(nloc)
+  REAL cina(nloc), cinb(nloc)
+  INTEGER ibeg(nloc)
+  INTEGER nsupmax(nloc)
+  REAL supcrit, temp(nloc, nd)
+  REAL p1(nloc), pmin(nloc)
+  REAL asupmax0(nloc)
+  LOGICAL ok(nloc)
+  REAL siglim(nloc, nd), wlim(nloc, nd), mlim(nloc, nd)
+  REAL wb2(nloc)
+  REAL cbmflim(nloc), cbmf1(nloc), cbmfmax(nloc)
+  REAL cbmflast(nloc)
+  REAL coef(nloc)
+  REAL xp(nloc), xq(nloc), xr(nloc), discr(nloc), b3(nloc), b4(nloc)
+  REAL theta(nloc), bb(nloc)
+  REAL term1, term2, term3
+  REAL alp2(nloc) ! Alp with offset
+  !CR: variables for new erosion of adiabiatic ascent
+  REAL mad(nloc, nd), me(nloc, nd), betalim(nloc, nd), beta_coef(nloc, nd)
+  REAL med(nloc, nd), md(nloc,nd)
+!jyg<
+! coef_peel is now in the common cv3_param 
+!!  REAL coef_peel
+!!  PARAMETER (coef_peel=0.25)
+!>jyg
+
+  REAL sigmax
+  PARAMETER (sigmax=0.1)
+
+  CHARACTER (LEN=20) :: modname = 'cv3p1_closure'
+  CHARACTER (LEN=80) :: abort_message
+
+  ! print *,' -> cv3p1_closure, Ale ',ale(1)
+
+
+  ! -------------------------------------------------------
+  ! -- Initialization
+  ! -------------------------------------------------------
+
+
+  DO il = 1, ncum
+    alp2(il) = max(alp(il), 1.E-5)
+    ! IM
+    alp2(il) = max(alp(il), 1.E-12)
+  END DO
+
+  pbmxup = 50. ! PBMXUP+PBCRIT = cloud depth above which mixed updraughts
+  ! exist (if any)
+
+  IF (prt_level>=20) PRINT *, 'cv3p1_param nloc ncum nd icb inb nl', nloc, &
+    ncum, nd, icb(nloc), inb(nloc), nl
+  DO k = 1, nd          !jyg: initialization up to nd
+    DO il = 1, ncum
+      m(il, k) = 0.0
+    END DO
+  END DO
+
+!CR: initializations for erosion of adiabatic ascent 
+  DO k = 1,nd           !jyg: initialization up to nd
+    DO il = 1, ncum
+        mad(il,k)=0.
+        me(il,k)=0.
+        betalim(il,k)=1.
+        wlim(il,k)=0.
+    ENDDO
+  ENDDO
+
+  ! -------------------------------------------------------
+  ! -- Reset sig(i) and w0(i) for i>inb and i<icb
+  ! -------------------------------------------------------
+
+  ! update sig and w0 above LNB:
+
+  DO k = 1, nl - 1
+    DO il = 1, ncum
+      IF ((inb(il)<(nl-1)) .AND. (k>=(inb(il)+1))) THEN
+        sig(il, k) = beta*sig(il, k) + 2.*alpha*buoy(il, inb(il))*abs(buoy(il &
+          ,inb(il)))
+        sig(il, k) = amax1(sig(il,k), 0.0)
+        w0(il, k) = beta*w0(il, k)
+      END IF
+    END DO
+  END DO
+
+  ! if(prt.level.GE.20) print*,'cv3p1_param apres 100'
+  ! compute icbmax:
+
+  icbmax = 2
+  DO il = 1, ncum
+    icbmax = max(icbmax, icb(il))
+  END DO
+  ! if(prt.level.GE.20) print*,'cv3p1_param apres 200'
+
+  ! update sig and w0 below cloud base:
+
+  DO k = 1, icbmax
+    DO il = 1, ncum
+      IF (k<=icb(il)) THEN
+        sig(il, k) = beta*sig(il, k) - 2.*alpha*buoy(il, icb(il))*buoy(il, &
+          icb(il))
+        sig(il, k) = amax1(sig(il,k), 0.0)
+        w0(il, k) = beta*w0(il, k)
+      END IF
+    END DO
+  END DO
+  IF (prt_level>=20) PRINT *, 'cv3p1_param apres 300'
+  ! -------------------------------------------------------------
+  ! -- Reset fractional areas of updrafts and w0 at initial time
+  ! -- and after 10 time steps of no convection
+  ! -------------------------------------------------------------
+
+  DO k = 1, nl - 1
+    DO il = 1, ncum
+      IF (sig(il,nd)<1.5 .OR. sig(il,nd)>12.0) THEN
+        sig(il, k) = 0.0
+        w0(il, k) = 0.0
+      END IF
+    END DO
+  END DO
+  IF (prt_level>=20) PRINT *, 'cv3p1_param apres 400'
+
+  ! -------------------------------------------------------------
+  ! jyg1
+  ! --  Calculate adiabatic ascent top pressure (ptop)
+  ! -------------------------------------------------------------
+
+
+  ! c 1. Start at first level where precipitations form
+  DO il = 1, ncum
+    pzero(il) = plcl(il) - pbcrit
+  END DO
+
+  ! c 2. Add offset
+  DO il = 1, ncum
+    pzero(il) = pzero(il) - pbmxup
+  END DO
+  DO il = 1, ncum
+    ptop2old(il) = ptop2(il)
+  END DO
+
+  DO il = 1, ncum
+    ! CR:c est quoi ce 300??
+    p1(il) = pzero(il) - 300.
+  END DO
+
+  ! compute asupmax=abs(supmax) up to lnm+1
+
+  DO il = 1, ncum
+    ok(il) = .TRUE.
+    nsupmax(il) = inb(il)
+  END DO
+
+  DO i = 1, nl
+    DO il = 1, ncum
+      IF (i>icb(il) .AND. i<=inb(il)) THEN
+        IF (p(il,i)<=pzero(il) .AND. supmax(il,i)<0 .AND. ok(il)) THEN
+          nsupmax(il) = i
+          ok(il) = .FALSE.
+        END IF ! end IF (P(i) ...  )
+      END IF ! end IF (icb+1 le i le inb)
+    END DO
+  END DO
+
+  IF (prt_level>=20) PRINT *, 'cv3p1_param apres 2.'
+  DO i = 1, nl
+    DO il = 1, ncum
+      asupmax(il, i) = abs(supmax(il,i))
+    END DO
+  END DO
+
+
+  DO il = 1, ncum
+    asupmaxmin(il) = 10.
+    pmin(il) = 100.
+    ! IM ??
+    asupmax0(il) = 0.
+  END DO
+
+  ! c 3.  Compute in which level is Pzero
+
+  ! IM bug      i0 = 18
+  DO il = 1, ncum
+    i0(il) = nl
+  END DO
+
+  DO i = 1, nl
+    DO il = 1, ncum
+      IF (i>icb(il) .AND. i<=inb(il)) THEN
+        IF (p(il,i)<=pzero(il) .AND. p(il,i)>=p1(il)) THEN
+          IF (pzero(il)>p(il,i) .AND. pzero(il)<p(il,i-1)) THEN
+            i0(il) = i
+          END IF
+        END IF
+      END IF
+    END DO
+  END DO
+  IF (prt_level>=20) PRINT *, 'cv3p1_param apres 3.'
+
+  ! c 4.  Compute asupmax at Pzero
+
+  DO i = 1, nl
+    DO il = 1, ncum
+      IF (i>icb(il) .AND. i<=inb(il)) THEN
+        IF (p(il,i)<=pzero(il) .AND. p(il,i)>=p1(il)) THEN
+          asupmax0(il) = ((pzero(il)-p(il,i0(il)-1))*asupmax(il,i0(il))-( &
+            pzero(il)-p(il,i0(il)))*asupmax(il,i0(il)-1))/(p(il,i0(il))-p(il, &
+            i0(il)-1))
+        END IF
+      END IF
+    END DO
+  END DO
+
+
+  DO i = 1, nl
+    DO il = 1, ncum
+      IF (p(il,i)==pzero(il)) THEN
+        asupmax(i, il) = asupmax0(il)
+      END IF
+    END DO
+  END DO
+  IF (prt_level>=20) PRINT *, 'cv3p1_param apres 4.'
+
+  ! c 5. Compute asupmaxmin, minimum of asupmax
+
+  DO i = 1, nl
+    DO il = 1, ncum
+      IF (i>icb(il) .AND. i<=inb(il)) THEN
+        IF (p(il,i)<=pzero(il) .AND. p(il,i)>=p1(il)) THEN
+          IF (asupmax(il,i)<asupmaxmin(il)) THEN
+            asupmaxmin(il) = asupmax(il, i)
+            pmin(il) = p(il, i)
+          END IF
+        END IF
+      END IF
+    END DO
+  END DO
+
+  DO il = 1, ncum
+    ! IM
+    IF (prt_level>=20) THEN
+      PRINT *, 'cv3p1_closure il asupmax0 asupmaxmin', il, asupmax0(il), &
+        asupmaxmin(il), pzero(il), pmin(il)
+    END IF
+    IF (asupmax0(il)<asupmaxmin(il)) THEN
+      asupmaxmin(il) = asupmax0(il)
+      pmin(il) = pzero(il)
+    END IF
+  END DO
+  IF (prt_level>=20) PRINT *, 'cv3p1_param apres 5.'
+
+
+  ! Compute Supmax at Pzero
+
+  DO i = 1, nl
+    DO il = 1, ncum
+      IF (i>icb(il) .AND. i<=inb(il)) THEN
+        IF (p(il,i)<=pzero(il)) THEN
+          supmax0(il) = ((p(il,i)-pzero(il))*asupmax(il,i-1)-(p(il, &
+            i-1)-pzero(il))*asupmax(il,i))/(p(il,i)-p(il,i-1))
+          GO TO 425
+        END IF ! end IF (P(i) ... )
+      END IF ! end IF (icb+1 le i le inb)
+    END DO
+  END DO
+
+425 CONTINUE
+  IF (prt_level>=20) PRINT *, 'cv3p1_param apres 425.'
+
+  ! c 6. Calculate ptop2
+
+  DO il = 1, ncum
+    IF (asupmaxmin(il)<supcrit1) THEN
+      ptop2(il) = pmin(il)
+    END IF
+
+    IF (asupmaxmin(il)>supcrit1 .AND. asupmaxmin(il)<supcrit2) THEN
+      ptop2(il) = ptop2old(il)
+    END IF
+
+    IF (asupmaxmin(il)>supcrit2) THEN
+      ptop2(il) = ph(il, inb(il))
+    END IF
+  END DO
+
+  IF (prt_level>=20) PRINT *, 'cv3p1_param apres 6.'
+
+  ! c 7. Compute multiplying factor for adiabatic updraught mass flux
+
+
+  IF (ok_inhib) THEN
+
+    DO i = 1, nl
+      DO il = 1, ncum
+        IF (i<=nl) THEN
+          coefmix(il, i) = (min(ptop2(il),ph(il,i))-ph(il,i))/(ph(il,i+1)-ph( &
+            il,i))
+          coefmix(il, i) = min(coefmix(il,i), 1.)
+        END IF
+      END DO
+    END DO
+
+
+  ELSE ! when inhibition is not taken into account, coefmix=1
+
+
+
+    DO i = 1, nl
+      DO il = 1, ncum
+        IF (i<=nl) THEN
+          coefmix(il, i) = 1.
+        END IF
+      END DO
+    END DO
+
+  END IF ! ok_inhib
+  IF (prt_level>=20) PRINT *, 'cv3p1_param apres 7.'
+  ! -------------------------------------------------------------------
+  ! -------------------------------------------------------------------
+
+
+  ! jyg2
+
+  ! ==========================================================================
+
+
+  ! -------------------------------------------------------------
+  ! -- Calculate convective inhibition (CIN)
+  ! -------------------------------------------------------------
+
+  ! do i=1,nloc
+  ! print*,'avant cine p',pbase(i),plcl(i)
+  ! enddo
+  ! do j=1,nd
+  ! do i=1,nloc
+  ! print*,'avant cine t',tv(i),tvp(i)
+  ! enddo
+  ! enddo
+  CALL cv3_cine(nloc, ncum, nd, icb, inb, pbase, plcl, p, ph, tv, tvp, cina, &
+    cinb, plfc)
+
+  DO il = 1, ncum
+    cin(il) = cina(il) + cinb(il)
+  END DO
+  IF (prt_level>=20) PRINT *, 'cv3p1_param apres cv3_cine'
+  ! -------------------------------------------------------------
+  ! --Update buoyancies to account for Ale
+  ! -------------------------------------------------------------
+
+  CALL cv3_buoy(nloc, ncum, nd, icb, inb, pbase, plcl, p, ph, ale, cin, tv, &
+    tvp, buoy)
+  IF (prt_level>=20) PRINT *, 'cv3p1_param apres cv3_buoy'
+
+  ! -------------------------------------------------------------
+  ! -- Calculate convective available potential energy (cape),
+  ! -- vertical velocity (w), fractional area covered by
+  ! -- undilute updraft (sig), and updraft mass flux (m)
+  ! -------------------------------------------------------------
+
+  DO il = 1, ncum
+    cape(il) = 0.0
+  END DO
+
+  ! compute dtmin (minimum buoyancy between ICB and given level k):
+
+  DO k = 1, nl
+    DO il = 1, ncum
+      dtmin(il, k) = 100.0
+    END DO
+  END DO
+
+  DO k = 1, nl
+    DO j = minorig, nl
+      DO il = 1, ncum
+        IF ((k>=(icb(il)+1)) .AND. (k<=inb(il)) .AND. (j>=icb(il)) .AND. (j<= &
+            (k-1))) THEN
+          dtmin(il, k) = amin1(dtmin(il,k), buoy(il,j))
+        END IF
+      END DO
+    END DO
+  END DO
+
+  ! the interval on which cape is computed starts at pbase :
+
+  DO k = 1, nl
+    DO il = 1, ncum
+
+      IF ((k>=(icb(il)+1)) .AND. (k<=inb(il))) THEN
+        IF (iflag_mix_adiab.eq.1) THEN
+!CR:computation of cape from LCL: keep flag or to modify in all cases?
+        deltap = min(plcl(il), ph(il,k-1)) - min(plcl(il), ph(il,k))
+        ELSE
+        deltap = min(pbase(il), ph(il,k-1)) - min(pbase(il), ph(il,k))
+        ENDIF
+        cape(il) = cape(il) + rrd*buoy(il, k-1)*deltap/p(il, k-1)
+        cape(il) = amax1(0.0, cape(il))
+        sigold(il, k) = sig(il, k)
+
+
+        ! jyg       Coefficient coefmix limits convection to levels where a
+        ! sufficient
+        ! fraction of mixed draughts are ascending.
+        siglim(il, k) = coefmix(il, k)*alpha1*dtmin(il, k)*abs(dtmin(il,k))
+        siglim(il, k) = amax1(siglim(il,k), 0.0)
+        siglim(il, k) = amin1(siglim(il,k), 0.01)
+        ! c         fac=AMIN1(((dtcrit-dtmin(il,k))/dtcrit),1.0)
+        fac = 1.
+        wlim(il, k) = fac*sqrt(cape(il))
+        amu = siglim(il, k)*wlim(il, k)
+        rhodp = 0.007*p(il, k)*(ph(il,k)-ph(il,k+1))/tv(il, k)
+        mlim(il, k) = amu*rhodp
+        ! print*, 'siglim ', k,siglim(1,k)
+      END IF
+
+    END DO
+  END DO
+  IF (prt_level>=20) PRINT *, 'cv3p1_param apres 600'
+
+  DO il = 1, ncum
+    ! IM beg
+    IF (prt_level>=20) THEN
+      PRINT *, 'cv3p1_closure il icb mlim ph ph+1 ph+2', il, icb(il), &
+        mlim(il, icb(il)+1), ph(il, icb(il)), ph(il, icb(il)+1), &
+        ph(il, icb(il)+2)
+    END IF
+
+    IF (icb(il)+1<=inb(il)) THEN
+      ! IM end
+      mlim(il, icb(il)) = 0.5*mlim(il, icb(il)+1)*(ph(il,icb(il))-ph(il,icb( &
+        il)+1))/(ph(il,icb(il)+1)-ph(il,icb(il)+2))
+      ! IM beg
+    END IF !(icb(il.le.inb(il))) then
+    ! IM end
+  END DO
+  IF (prt_level>=20) PRINT *, 'cv3p1_param apres 700'
+
+  ! jyg1
+  ! ------------------------------------------------------------------------
+  ! c     Correct mass fluxes so that power used to overcome CIN does not
+  ! c     exceed Power Available for Lifting (PAL).
+  ! ------------------------------------------------------------------------
+
+  DO il = 1, ncum
+    cbmflim(il) = 0.
+    cbmf(il) = 0.
+  END DO
+
+  ! c 1. Compute cloud base mass flux of elementary system (Cbmf0=Cbmflim)
+
+  DO k = 1, nl
+    DO il = 1, ncum
+      ! old       IF (k .ge. icb(il) .and. k .le. inb(il)) THEN
+      ! IM        IF (k .ge. icb(il)+1 .and. k .le. inb(il)) THEN
+      IF (k>=icb(il) .AND. k<=inb(il) & !cor jyg
+          .AND. icb(il)+1<=inb(il)) THEN !cor jyg
+        cbmflim(il) = cbmflim(il) + mlim(il, k)
+      END IF
+    END DO
+  END DO
+  IF (prt_level>=20) PRINT *, 'cv3p1_param apres cbmflim'
+
+  ! 1.5 Compute cloud base mass flux given by Alp closure (Cbmf1), maximum
+  !     allowed mass flux (Cbmfmax) and final target mass flux (Cbmf)
+  !     Cbmf is set to zero if Cbmflim (the mass flux of elementary cloud)
+  !     is exceedingly small.
+
+  DO il = 1, ncum
+    wb2(il) = sqrt(2.*max(ale(il)+cin(il),0.))
+  END DO
+
+  DO il = 1, ncum
+    IF (plfc(il)<100.) THEN
+      ! This is an irealistic value for plfc => no calculation of wbeff
+      wbeff(il) = 100.1
+    ELSE
+      ! Calculate wbeff
+      IF (NINT(flag_wb)==0) THEN
+        wbeff(il) = wbmax
+      ELSE IF (NINT(flag_wb)==1) THEN
+        wbeff(il) = wbmax/(1.+500./(ph(il,1)-plfc(il)))
+      ELSE IF (NINT(flag_wb)==2) THEN
+        wbeff(il) = wbmax*(0.01*(ph(il,1)-plfc(il)))**2
+      ELSE ! Option provisoire ou le iflag_wb/10 est considere comme une vitesse
+        wbeff(il) = flag_wb*0.01+wbmax/(1.+500./(ph(il,1)-plfc(il)))
+      END IF
+    END IF
+  END DO
+
+!CR:Compute k at plfc
+  DO il=1,ncum
+           klfc(il)=nl
+  ENDDO
+  DO k=1,nl
+     DO il=1,ncum
+        if ((plfc(il).lt.ph(il,k)).and.(plfc(il).ge.ph(il,k+1))) then
+           klfc(il)=k
+        endif
+     ENDDO
+  ENDDO
+!RC
+
+  DO il = 1, ncum
+    ! jyg    Modification du coef de wb*wb pour conformite avec papier Wake
+    ! c       cbmf1(il) = alp2(il)/(0.5*wb*wb-Cin(il))
+    cbmf1(il) = alp2(il)/(2.*wbeff(il)*wbeff(il)-cin(il))
+!CR: Add large-scale component to the mass-flux
+!encore connu sous le nom "Experience du tube de dentifrice"
+    if ((coef_clos_ls.gt.0.).and.(plfc(il).gt.0.)) then 
+       cbmf1(il) = cbmf1(il) - coef_clos_ls*min(0.,1./RG*omega(il,klfc(il)))
+    endif
+!RC
+    IF (cbmf1(il)==0 .AND. alp2(il)/=0.) THEN
+      WRITE (lunout, *) 'cv3p1_closure cbmf1=0 and alp NE 0 il alp2 alp cin ' &
+        , il, alp2(il), alp(il), cin(il)
+      abort_message = ''
+      CALL abort_physic(modname, abort_message, 1)
+    END IF
+    cbmfmax(il) = sigmax*wb2(il)*100.*p(il, icb(il))/(rrd*tv(il,icb(il)))
+  END DO
+
+  DO il = 1, ncum
+    IF (cbmflim(il)>1.E-6) THEN
+      ! ATTENTION TEST CR
+      ! if (cbmfmax(il).lt.1.e-12) then
+      cbmf(il) = min(cbmf1(il), cbmfmax(il))
+      ! else
+      ! cbmf(il) = cbmf1(il)
+      ! endif
+      ! print*,'cbmf',cbmf1(il),cbmfmax(il)
+    END IF
+  END DO
+  IF (prt_level>=20) PRINT *, 'cv3p1_param apres cbmflim_testCR'
+
+  ! c 2. Compute coefficient and apply correction
+
+  DO il = 1, ncum
+    coef(il) = (cbmf(il)+1.E-10)/(cbmflim(il)+1.E-10)
+  END DO
+  IF (prt_level>=20) PRINT *, 'cv3p1_param apres coef_plantePLUS'
+
+  DO k = 1, nl
+    DO il = 1, ncum
+      IF (k>=icb(il)+1 .AND. k<=inb(il)) THEN
+        amu = beta*sig(il, k)*w0(il, k) + (1.-beta)*coef(il)*siglim(il, k)* &
+          wlim(il, k)
+        w0(il, k) = wlim(il, k)
+        w0(il, k) = max(w0(il,k), 1.E-10)
+        sig(il, k) = amu/w0(il, k)
+        sig(il, k) = min(sig(il,k), 1.)
+        ! c         amu = 0.5*(SIG(il,k)+sigold(il,k))*W0(il,k)
+        m(il, k) = amu*0.007*p(il, k)*(ph(il,k)-ph(il,k+1))/tv(il, k)
+      END IF
+    END DO
+  END DO
+  ! jyg2
+  DO il = 1, ncum
+    w0(il, icb(il)) = 0.5*w0(il, icb(il)+1)
+    m(il, icb(il)) = 0.5*m(il, icb(il)+1)*(ph(il,icb(il))-ph(il,icb(il)+1))/ &
+      (ph(il,icb(il)+1)-ph(il,icb(il)+2))
+    sig(il, icb(il)) = sig(il, icb(il)+1)
+    sig(il, icb(il)-1) = sig(il, icb(il))
+  END DO
+  IF (prt_level>=20) PRINT *, 'cv3p1_param apres w0_sig_M'
+
+!CR: new erosion of adiabatic ascent: modification of m
+!computation of the sum of ascending fluxes 
+  IF (iflag_mix_adiab.eq.1) THEN
+
+!Verification sum(me)=sum(m)
+  DO k = 1,nd                         !jyg: initialization up to nd
+    DO il = 1, ncum
+       md(il,k)=0.
+       med(il,k)=0.
+    ENDDO
+  ENDDO
+
+  DO k = nl,1,-1
+    DO il = 1, ncum
+           md(il,k)=md(il,k+1)+m(il,k+1)
+    ENDDO
+  ENDDO
+
+  DO k = nl,1,-1
+    DO il = 1, ncum
+        IF ((k>=(icb(il))) .AND. (k<=inb(il))) THEN
+           mad(il,k)=mad(il,k+1)+m(il,k+1)
+        ENDIF
+!        print*,"mad",il,k,mad(il,k)
+    ENDDO
+  ENDDO
+
+!CR: erosion of each adiabatic ascent during its ascent
+
+!Computation of erosion coefficient beta_coef
+  DO k = 1, nl
+    DO il = 1, ncum
+       IF ((k>=(icb(il)+1)) .AND. (k<=inb(il)) .AND. (mlim(il,k).gt.0.)) THEN     
+!          print*,"beta_coef",il,k,icb(il),inb(il),buoy(il,k),tv(il,k),wlim(il,k),wlim(il,k+1)
+          beta_coef(il,k)=RG*coef_peel*buoy(il,k)/tv(il,k)/((wlim(il,k)+wlim(il,k+1))/2.)**2
+       ELSE
+          beta_coef(il,k)=0.
+       ENDIF
+    ENDDO
+  ENDDO
+
+!  print*,"apres beta_coef"
+
+  DO k = 1, nl
+    DO il = 1, ncum
+
+      IF ((k>=(icb(il)+1)) .AND. (k<=inb(il))) THEN
+
+!        print*,"dz",il,k,tv(il, k-1)
+        dz = (ph(il,k-1)-ph(il,k))/(p(il, k-1)/(rrd*tv(il, k-1))*RG)
+        betalim(il,k)=betalim(il,k-1)*exp(-1.*beta_coef(il,k-1)*dz)
+!        betalim(il,k)=betalim(il,k-1)*exp(-RG*coef_peel*buoy(il,k-1)/tv(il,k-1)/5.**2*dz)
+!        print*,"me",il,k,mlim(il,k),buoy(il,k),wlim(il,k),mad(il,k)
+        dz = (ph(il,k)-ph(il,k+1))/(p(il, k)/(rrd*tv(il, k))*RG)
+!        me(il,k)=betalim(il,k)*(m(il,k)+RG*coef_peel*buoy(il,k)/tv(il,k)/((wlim(il,k)+wlim(il,k+1))/2.)**2*dz*mad(il,k))
+        me(il,k)=betalim(il,k)*(m(il,k)+beta_coef(il,k)*dz*mad(il,k))
+!        print*,"B/w2",il,k,RG*coef_peel*buoy(il,k)/tv(il,k)/((wlim(il,k)+wlim(il,k+1))/2.)**2*dz    
+      
+      END IF
+        
+!Modification of m
+      m(il,k)=me(il,k) 
+    END DO
+  END DO
+ 
+!  DO il = 1, ncum
+!     dz = (ph(il,icb(il))-ph(il,icb(il)+1))/(p(il, icb(il))/(rrd*tv(il, icb(il)))*RG)
+!     m(il,icb(il))=m(il,icb(il))+RG*coef_peel*buoy(il,icb(il))/tv(il,icb(il)) &
+!                  /((wlim(il,icb(il))+wlim(il,icb(il)+1))/2.)**2*dz*mad(il,icb(il))
+!     print*,"wlim(icb)",icb(il),wlim(il,icb(il)),m(il,icb(il))
+!  ENDDO
+
+!Verification sum(me)=sum(m)
+  DO k = nl,1,-1
+    DO il = 1, ncum
+           med(il,k)=med(il,k+1)+m(il,k+1)
+!           print*,"somme(me),somme(m)",il,k,icb(il),med(il,k),md(il,k),me(il,k),m(il,k),wlim(il,k)
+    ENDDO
+  ENDDO
+
+
+  ENDIF !(iflag_mix_adiab)
+!RC
+
+
+
+  ! c 3. Compute final cloud base mass flux and set iflag to 3 if
+  ! c    cloud base mass flux is exceedingly small and is decreasing (i.e. if
+  ! c    the final mass flux (cbmflast) is greater than the target mass flux
+  ! c    (cbmf)).
+
+  DO il = 1, ncum
+    cbmflast(il) = 0.
+  END DO
+
+  DO k = 1, nl
+    DO il = 1, ncum
+      IF (k>=icb(il) .AND. k<=inb(il)) THEN
+          !IMpropo??      IF ((k.ge.(icb(il)+1)).and.(k.le.inb(il))) THEN
+        cbmflast(il) = cbmflast(il) + m(il, k)
+      END IF
+    END DO
+  END DO
+
+  DO il = 1, ncum
+    IF (cbmflast(il)<1.E-6 .AND. cbmflast(il)>=cbmf(il)) THEN
+      iflag(il) = 3
+    END IF
+  END DO
+
+  DO k = 1, nl
+    DO il = 1, ncum
+      IF (iflag(il)>=3) THEN
+        m(il, k) = 0.
+        sig(il, k) = 0.
+        w0(il, k) = 0.
+      END IF
+    END DO
+  END DO
+  IF (prt_level>=20) PRINT *, 'cv3p1_param apres iflag'
+
+  ! c 4. Introduce a correcting factor for coef, in order to obtain an
+  ! effective
+  ! c    sigdz larger in the present case (using cv3p1_closure) than in the
+  ! old
+  ! c    closure (using cv3_closure).
+  IF (1==0) THEN
+    DO il = 1, ncum
+      ! c      coef(il) = 2.*coef(il)
+      coef(il) = 5.*coef(il)
+    END DO
+    ! version CVS du ..2008
+  ELSE
+    IF (iflag_cvl_sigd==0) THEN
+      ! test pour verifier qu on fait la meme chose qu avant: sid constant
+      coef(1:ncum) = 1.
+    ELSE
+      coef(1:ncum) = min(2.*coef(1:ncum), 5.)
+      coef(1:ncum) = max(2.*coef(1:ncum), 0.2)
+    END IF
+  END IF
+
+  IF (prt_level>=20) PRINT *, 'cv3p1_param FIN'
+  RETURN
+END SUBROUTINE cv3p1_closure
+
+
Index: DZ6/trunk/libf/phylmd/cv3p2_closure.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cv3p2_closure.F90	(revision 5267)
+++ 	(revision )
@@ -1,869 +1,0 @@
-
-
-SUBROUTINE cv3p2_closure(nloc, ncum, nd, icb, inb, pbase, plcl, p, ph, tv, &
-    tvp, buoy, supmax, ok_inhib, ale, alp, omega,sig, w0, ptop2, cape, cin, m, &
-    iflag, coef, plim1, plim2, asupmax, supmax0, asupmaxmin, cbmflast, plfc, &
-    wbeff)
-
-
-  ! **************************************************************
-  ! *
-  ! CV3P2_CLOSURE                                               *
-  ! Ale & Alp Closure of Convect3              *
-  ! *
-  ! written by   :   Kerry Emanuel                              *
-  ! vectorization:   S. Bony                                    *
-  ! modified by :    Jean-Yves Grandpeix, 18/06/2003, 19.32.10  *
-  ! Julie Frohwirth,     14/10/2005  17.44.22  *
-  ! **************************************************************
-
-  USE print_control_mod, ONLY: prt_level, lunout
-  IMPLICIT NONE
-
-  include "cvthermo.h"
-  include "cv3param.h"
-  include "cvflag.h"
-  include "YOMCST2.h"
-  include "YOMCST.h"
-  include "conema3.h"
-
-  ! input:
-  INTEGER, INTENT (IN)                               :: ncum, nd, nloc
-  INTEGER, DIMENSION (nloc), INTENT (IN)             :: icb, inb
-  REAL, DIMENSION (nloc), INTENT (IN)                :: pbase, plcl
-  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: p
-  REAL, DIMENSION (nloc, nd+1), INTENT (IN)          :: ph
-  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: tv, tvp, buoy
-  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: supmax
-  LOGICAL, INTENT (IN)                               :: ok_inhib ! enable convection inhibition by dryness
-  REAL, DIMENSION (nloc), INTENT (IN)                :: ale, alp
-  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: omega
-
-  ! input/output:
-  INTEGER, DIMENSION (nloc), INTENT (INOUT)          :: iflag
-  REAL, DIMENSION (nloc, nd), INTENT (INOUT)         :: sig, w0
-  REAL, DIMENSION (nloc), INTENT (INOUT)             :: ptop2
-
-  ! output:
-  REAL, DIMENSION (nloc), INTENT (OUT)               :: cape, cin
-  REAL, DIMENSION (nloc, nd), INTENT (OUT)           :: m
-  REAL, DIMENSION (nloc), INTENT (OUT)               :: plim1, plim2
-  REAL, DIMENSION (nloc, nd), INTENT (OUT)           :: asupmax
-  REAL, DIMENSION (nloc), INTENT (OUT)               :: supmax0
-  REAL, DIMENSION (nloc), INTENT (OUT)               :: asupmaxmin
-  REAL, DIMENSION (nloc), INTENT (OUT)               :: cbmflast, plfc
-  REAL, DIMENSION (nloc), INTENT (OUT)               :: wbeff
-
-  ! local variables:
-  INTEGER                                            :: il, i, j, k, icbmax
-  INTEGER, DIMENSION (nloc)                          :: i0, klfc
-  REAL                                               :: deltap, fac, w, amu
-  REAL, DIMENSION (nloc, nd)                         :: rhodp               ! Factor such that m=rhodp*sig*w
-  REAL                                               :: dz
-  REAL                                               :: pbmxup
-  REAL, DIMENSION (nloc, nd)                         :: dtmin, sigold
-  REAL, DIMENSION (nloc, nd)                         :: coefmix
-  REAL, DIMENSION (nloc)                             :: dtminmax
-  REAL, DIMENSION (nloc)                             :: pzero, ptop2old
-  REAL, DIMENSION (nloc)                             :: cina, cinb
-  INTEGER, DIMENSION (nloc)                          :: ibeg
-  INTEGER, DIMENSION (nloc)                          :: nsupmax
-  REAL                                               :: supcrit
-  REAL, DIMENSION (nloc, nd)                         :: temp
-  REAL, DIMENSION (nloc)                             :: p1, pmin
-  REAL, DIMENSION (nloc)                             :: asupmax0
-  LOGICAL, DIMENSION (nloc)                          :: ok
-  REAL, DIMENSION (nloc, nd)                         :: siglim, wlim, mlim
-  REAL, DIMENSION (nloc)                             :: wb2
-  REAL, DIMENSION (nloc)                             :: cbmf0        ! initial cloud base mass flux
-  REAL, DIMENSION (nloc)                             :: cbmflim      ! cbmf given by Cape closure
-  REAL, DIMENSION (nloc)                             :: cbmfalp      ! cbmf given by Alp closure
-  REAL, DIMENSION (nloc)                             :: cbmfalpb     ! bounded cbmf given by Alp closure
-  REAL, DIMENSION (nloc)                             :: cbmfmax      ! upper bound on cbmf
-  REAL, DIMENSION (nloc)                             :: coef
-  REAL, DIMENSION (nloc)                             :: xp, xq, xr, discr, b3, b4
-  REAL, DIMENSION (nloc)                             :: theta, bb
-  REAL                                               :: term1, term2, term3
-  REAL, DIMENSION (nloc)                             :: alp2                  ! Alp with offset
-
-!CR: variables for new erosion of adiabiatic ascent
-  REAL, DIMENSION (nloc, nd)                         :: mad, me, betalim, beta_coef
-  REAL, DIMENSION (nloc, nd)                         :: med, md
-!jyg<
-! coef_peel is now in the common cv3_param 
-!!  REAL                                               :: coef_peel
-!!  PARAMETER (coef_peel=0.25)
-!>jyg
-
-  REAL                                               :: sigmax
-  PARAMETER (sigmax=0.1)
-!!  PARAMETER (sigmax=10.)
-
-  CHARACTER (LEN=20)                                 :: modname = 'cv3p2_closure'
-  CHARACTER (LEN=80)                                 :: abort_message
-
-  INTEGER,SAVE                                       :: igout=1
-!$OMP THREADPRIVATE(igout)
-
- IF (prt_level>=20) print *,' -> cv3p2_closure, Ale ',ale(igout)
-
-
-  ! -------------------------------------------------------
-  ! -- Initialization
-  ! -------------------------------------------------------
-
-
-  DO il = 1, ncum
-    alp2(il) = max(alp(il), 1.E-5)
-    ! IM
-    alp2(il) = max(alp(il), 1.E-12)
-  END DO
-
-  pbmxup = 50. ! PBMXUP+PBCRIT = cloud depth above which mixed updraughts
-  ! exist (if any)
-
-  IF (prt_level>=20) PRINT *, 'cv3p2_closure nloc ncum nd icb inb nl', nloc, &
-    ncum, nd, icb(nloc), inb(nloc), nl
-  DO k = 1, nl
-    DO il = 1, ncum
-      rhodp(il,k) = 0.007*p(il, k)*(ph(il,k)-ph(il,k+1))/tv(il, k)
-    END DO
-  END DO
-
-!CR+jyg: initializations (up to nd) for erosion of adiabatic ascent and of m and wlim
-  DO k = 1,nd
-    DO il = 1, ncum
-        mad(il,k)=0.
-        me(il,k)=0.
-        betalim(il,k)=1.
-        wlim(il,k)=0.
-        m(il, k) = 0.0
-    ENDDO
-  ENDDO
-
-  ! -------------------------------------------------------
-  ! -- Reset sig(i) and w0(i) for i>inb and i<icb
-  ! -------------------------------------------------------
-
-  ! update sig and w0 above LNB:
-
-  DO k = 1, nl - 1
-    DO il = 1, ncum
-      IF ((inb(il)<(nl-1)) .AND. (k>=(inb(il)+1))) THEN
-        sig(il, k) = beta*sig(il, k) + 2.*alpha*buoy(il, inb(il))*abs(buoy(il,inb(il)))
-        sig(il, k) = amax1(sig(il,k), 0.0)
-        w0(il, k) = beta*w0(il, k)
-      END IF
-    END DO
-  END DO
-
-  ! if(prt.level.GE.20) print*,'cv3p2_closure apres 100'
-  ! compute icbmax:
-
-  icbmax = 2
-  DO il = 1, ncum
-    icbmax = max(icbmax, icb(il))
-  END DO
-  ! if(prt.level.GE.20) print*,'cv3p2_closure apres 200'
-
-  ! update sig and w0 below cloud base:
-
-  DO k = 1, icbmax
-    DO il = 1, ncum
-      IF (k<=icb(il)) THEN
-        sig(il, k) = beta*sig(il, k) - 2.*alpha*buoy(il, icb(il))*buoy(il,icb(il))
-        sig(il, k) = amax1(sig(il,k), 0.0)
-        w0(il, k) = beta*w0(il, k)
-      END IF
-    END DO
-  END DO
-  IF (prt_level>=20) PRINT *, 'cv3p2_closure apres 300'
-
-  ! -------------------------------------------------------------
-  ! -- Reset fractional areas of updrafts and w0 at initial time
-  ! -- and after 10 time steps of no convection
-  ! -------------------------------------------------------------
-
-!jyg<
-  IF (ok_convstop) THEN
-    DO k = 1, nl - 1
-      DO il = 1, ncum
-        IF (sig(il,nd)<1.5 .OR. sig(il,nd)>noconv_stop) THEN
-          sig(il, k) = 0.0
-          w0(il, k) = 0.0
-        END IF
-      END DO
-    END DO
-  ELSE
-  DO k = 1, nl - 1
-    DO il = 1, ncum
-      IF (sig(il,nd)<1.5 .OR. sig(il,nd)>12.0) THEN
-        sig(il, k) = 0.0
-        w0(il, k) = 0.0
-      END IF
-    END DO
-  END DO
-  ENDIF  ! (ok_convstop)
-!>jyg
-  IF (prt_level>=20) PRINT *, 'cv3p2_closure apres 400'
-
-  ! -------------------------------------------------------
-  ! -- Compute initial cloud base mass flux (Cbmf0)
-  ! -------------------------------------------------------
-  DO il = 1, ncum
-    cbmf0(il) = 0.0
-  END DO
-
-  DO k = 1, nl
-    DO il = 1, ncum
-      IF (k>=icb(il) .AND. k<=inb(il) & 
-          .AND. icb(il)+1<=inb(il)) THEN
-        cbmf0(il) = cbmf0(il) + sig(il, k)*w0(il,k)*rhodp(il,k)
-      END IF
-    END DO
-  END DO
-
-  ! -------------------------------------------------------------
-  ! jyg1
-  ! --  Calculate adiabatic ascent top pressure (ptop)
-  ! -------------------------------------------------------------
-
-
-  ! c 1. Start at first level where precipitations form
-  DO il = 1, ncum
-    pzero(il) = plcl(il) - pbcrit
-  END DO
-
-  ! c 2. Add offset
-  DO il = 1, ncum
-    pzero(il) = pzero(il) - pbmxup
-  END DO
-  DO il = 1, ncum
-    ptop2old(il) = ptop2(il)
-  END DO
-
-  DO il = 1, ncum
-    ! CR:c est quoi ce 300??
-    p1(il) = pzero(il) - 300.
-  END DO
-
-  ! compute asupmax=abs(supmax) up to lnm+1
-
-  DO il = 1, ncum
-    ok(il) = .TRUE.
-    nsupmax(il) = inb(il)
-  END DO
-
-  DO i = 1, nl
-    DO il = 1, ncum
-      IF (i>icb(il) .AND. i<=inb(il)) THEN
-        IF (p(il,i)<=pzero(il) .AND. supmax(il,i)<0 .AND. ok(il)) THEN
-          nsupmax(il) = i
-          ok(il) = .FALSE.
-        END IF ! end IF (P(i) ...  )
-      END IF ! end IF (icb+1 le i le inb)
-    END DO
-  END DO
-
-  IF (prt_level>=20) PRINT *, 'cv3p2_closure apres 2.'
-  DO i = 1, nl
-    DO il = 1, ncum
-      asupmax(il, i) = abs(supmax(il,i))
-    END DO
-  END DO
-
-
-  DO il = 1, ncum
-    asupmaxmin(il) = 10.
-    pmin(il) = 100.
-    ! IM ??
-    asupmax0(il) = 0.
-  END DO
-
-  ! c 3.  Compute in which level is Pzero
-
-  ! IM bug      i0 = 18
-  DO il = 1, ncum
-    i0(il) = nl
-  END DO
-
-  DO i = 1, nl
-    DO il = 1, ncum
-      IF (i>icb(il) .AND. i<=inb(il)) THEN
-        IF (p(il,i)<=pzero(il) .AND. p(il,i)>=p1(il)) THEN
-          IF (pzero(il)>p(il,i) .AND. pzero(il)<p(il,i-1)) THEN
-            i0(il) = i
-          END IF
-        END IF
-      END IF
-    END DO
-  END DO
-  IF (prt_level>=20) PRINT *, 'cv3p2_closure apres 3.'
-
-  ! c 4.  Compute asupmax at Pzero
-
-  DO i = 1, nl
-    DO il = 1, ncum
-      IF (i>icb(il) .AND. i<=inb(il)) THEN
-        IF (p(il,i)<=pzero(il) .AND. p(il,i)>=p1(il)) THEN
-          asupmax0(il) = ((pzero(il)-p(il,i0(il)-1))*asupmax(il,i0(il))- &
-            (pzero(il)-p(il,i0(il)))*asupmax(il,i0(il)-1))/(p(il,i0(il))-p(il,i0(il)-1))
-        END IF
-      END IF
-    END DO
-  END DO
-
-
-  DO i = 1, nl
-    DO il = 1, ncum
-      IF (p(il,i)==pzero(il)) THEN
-        asupmax(i, il) = asupmax0(il)
-      END IF
-    END DO
-  END DO
-  IF (prt_level>=20) PRINT *, 'cv3p2_closure apres 4.'
-
-  ! c 5. Compute asupmaxmin, minimum of asupmax
-
-  DO i = 1, nl
-    DO il = 1, ncum
-      IF (i>icb(il) .AND. i<=inb(il)) THEN
-        IF (p(il,i)<=pzero(il) .AND. p(il,i)>=p1(il)) THEN
-          IF (asupmax(il,i)<asupmaxmin(il)) THEN
-            asupmaxmin(il) = asupmax(il, i)
-            pmin(il) = p(il, i)
-          END IF
-        END IF
-      END IF
-    END DO
-  END DO
-
-  DO il = 1, ncum
-    ! IM
-    IF (prt_level>=20) THEN
-      PRINT *, 'cv3p2_closure il asupmax0 asupmaxmin', il, asupmax0(il), &
-        asupmaxmin(il), pzero(il), pmin(il)
-    END IF
-    IF (asupmax0(il)<asupmaxmin(il)) THEN
-      asupmaxmin(il) = asupmax0(il)
-      pmin(il) = pzero(il)
-    END IF
-  END DO
-  IF (prt_level>=20) PRINT *, 'cv3p2_closure apres 5.'
-
-
-  ! Compute Supmax at Pzero
-
-  DO i = 1, nl
-    DO il = 1, ncum
-      IF (i>icb(il) .AND. i<=inb(il)) THEN
-        IF (p(il,i)<=pzero(il)) THEN
-          supmax0(il) = ((p(il,i)-pzero(il))*asupmax(il,i-1)- &
-            (p(il,i-1)-pzero(il))*asupmax(il,i))/(p(il,i)-p(il,i-1))
-          GO TO 425
-        END IF ! end IF (P(i) ... )
-      END IF ! end IF (icb+1 le i le inb)
-    END DO
-  END DO
-
-425 CONTINUE
-  IF (prt_level>=20) PRINT *, 'cv3p2_closure apres 425.'
-
-  ! c 6. Calculate ptop2
-
-  DO il = 1, ncum
-    IF (asupmaxmin(il)<supcrit1) THEN
-      ptop2(il) = pmin(il)
-    END IF
-
-    IF (asupmaxmin(il)>supcrit1 .AND. asupmaxmin(il)<supcrit2) THEN
-      ptop2(il) = ptop2old(il)
-    END IF
-
-    IF (asupmaxmin(il)>supcrit2) THEN
-      ptop2(il) = ph(il, inb(il))
-    END IF
-  END DO
-
-  IF (prt_level>=20) PRINT *, 'cv3p2_closure apres 6.'
-
-  ! c 7. Compute multiplying factor for adiabatic updraught mass flux
-
-
-  IF (ok_inhib) THEN
-
-    DO i = 1, nl
-      DO il = 1, ncum
-        IF (i<=nl) THEN
-          coefmix(il, i) = (min(ptop2(il),ph(il,i))-ph(il,i))/(ph(il,i+1)-ph(il,i))
-          coefmix(il, i) = min(coefmix(il,i), 1.)
-        END IF
-      END DO
-    END DO
-
-
-  ELSE ! when inhibition is not taken into account, coefmix=1
-
-
-
-    DO i = 1, nl
-      DO il = 1, ncum
-        IF (i<=nl) THEN
-          coefmix(il, i) = 1.
-        END IF
-      END DO
-    END DO
-
-  END IF ! ok_inhib
-  IF (prt_level>=20) PRINT *, 'cv3p2_closure apres 7.'
-  ! -------------------------------------------------------------------
-  ! -------------------------------------------------------------------
-
-
-  ! jyg2
-
-  ! ==========================================================================
-
-
-  ! -------------------------------------------------------------
-  ! -- Calculate convective inhibition (CIN)
-  ! -------------------------------------------------------------
-
-  ! do i=1,nloc
-  ! print*,'avant cine p',pbase(i),plcl(i)
-  ! enddo
-  ! do j=1,nd
-  ! do i=1,nloc
-  ! print*,'avant cine t',tv(i),tvp(i)
-  ! enddo
-  ! enddo
-  CALL cv3_cine(nloc, ncum, nd, icb, inb, pbase, plcl, p, ph, tv, tvp, cina, &
-    cinb, plfc)
-
-  DO il = 1, ncum
-    cin(il) = cina(il) + cinb(il)
-  END DO
-  IF (prt_level>=20) PRINT *, 'cv3p2_closure after cv3_cine: cina, cinb, cin ', &
-                              cina(igout), cinb(igout), cin(igout)
-  ! -------------------------------------------------------------
-  ! --Update buoyancies to account for Ale
-  ! -------------------------------------------------------------
-
-  CALL cv3_buoy(nloc, ncum, nd, icb, inb, pbase, plcl, p, ph, ale, cin, tv, &
-    tvp, buoy)
-  IF (prt_level>=20) PRINT *, 'cv3p2_closure after cv3_buoy'
-
-  ! -------------------------------------------------------------
-  ! -- Calculate convective available potential energy (cape),
-  ! -- vertical velocity (w), fractional area covered by
-  ! -- undilute updraft (sig), and updraft mass flux (m)
-  ! -------------------------------------------------------------
-
-  DO il = 1, ncum
-    cape(il) = 0.0
-    dtminmax(il) = -100.
-  END DO
-
-  ! compute dtmin (minimum buoyancy between ICB and given level k):
-
-  DO k = 1, nl
-    DO il = 1, ncum
-      dtmin(il, k) = 100.0
-    END DO
-  END DO
-
-  DO k = 1, nl
-    DO j = minorig, nl
-      DO il = 1, ncum
-        IF ((k>=(icb(il)+1)) .AND. (k<=inb(il)) .AND. (j>=icb(il)) &
-                             .AND. (j<=(k-1))) THEN
-          dtmin(il, k) = amin1(dtmin(il,k), buoy(il,j))
-        END IF
-      END DO
-    END DO
-  END DO
-!jyg<
-!  Store maximum of dtmin
-!  C est pas terrible d avoir ce test sur Ale+Cin encore une fois ici.
-!                      A REVOIR !
-  DO k = 1, nl
-    DO il = 1, ncum
-      IF (k>=(icb(il)+1) .AND. k<=inb(il) .AND. ale(il)+cin(il)>0.) THEN
-        dtminmax(il) = max(dtmin(il,k), dtminmax(il))
-      ENDIF
-    END DO
-  END DO
-!
-!    prevent convection when ale+cin <= 0
-  DO k = 1, nl
-    DO il = 1, ncum
-      IF (k>=(icb(il)+1) .AND. k<=inb(il)) THEN
-        dtmin(il,k) = min(dtmin(il,k), dtminmax(il))
-      ENDIF
-    END DO
-  END DO
-!>jyg
-!
-  IF (prt_level >= 20) THEN
-    print *,'cv3p2_closure: dtmin ', (k, dtmin(igout,k), k=1,nl)
-    print *,'cv3p2_closure: dtminmax ', dtminmax(igout)
-  ENDIF
-!
-  ! the interval on which cape is computed starts at pbase :
-
-  DO k = 1, nl
-    DO il = 1, ncum
-
-      IF ((k>=(icb(il)+1)) .AND. (k<=inb(il))) THEN
-
-        IF (iflag_mix_adiab.eq.1) THEN
-!CR:computation of cape from LCL: keep flag or to modify in all cases?
-        deltap = min(plcl(il), ph(il,k-1)) - min(plcl(il), ph(il,k))
-        ELSE
-        deltap = min(pbase(il), ph(il,k-1)) - min(pbase(il), ph(il,k))
-        ENDIF
-        cape(il) = cape(il) + rrd*buoy(il, k-1)*deltap/p(il, k-1)
-        cape(il) = amax1(0.0, cape(il))
-        sigold(il, k) = sig(il, k)
-
-
-        ! jyg       Coefficient coefmix limits convection to levels where a
-        ! sufficient
-        ! fraction of mixed draughts are ascending.
-        siglim(il, k) = coefmix(il, k)*alpha1*dtmin(il, k)*abs(dtmin(il,k))
-        siglim(il, k) = amax1(siglim(il,k), 0.0)
-        siglim(il, k) = amin1(siglim(il,k), 0.01)
-        ! c         fac=AMIN1(((dtcrit-dtmin(il,k))/dtcrit),1.0)
-        fac = 1.
-        wlim(il, k) = fac*sqrt(cape(il))
-        amu = siglim(il, k)*wlim(il, k)
-!!        rhodp(il,k) = 0.007*p(il, k)*(ph(il,k)-ph(il,k+1))/tv(il, k) !cor jyg : computed earlier
-        mlim(il, k) = amu*rhodp(il,k)
-        ! print*, 'siglim ', k,siglim(1,k)
-      END IF
-
-    END DO
-  END DO
-  IF (prt_level>=20) PRINT *, 'cv3p2_closure apres 600'
-
-  DO il = 1, ncum
-    ! IM beg
-    IF (prt_level>=20) THEN
-      PRINT *, 'cv3p2_closure il icb mlim ph ph+1 ph+2', il, icb(il), &
-        mlim(il, icb(il)+1), ph(il, icb(il)), ph(il, icb(il)+1), &
-        ph(il, icb(il)+2)
-    END IF
-
-    IF (icb(il)+1<=inb(il)) THEN
-      ! IM end
-      mlim(il, icb(il)) = 0.5*mlim(il,icb(il)+1)*(ph(il,icb(il))-ph(il,icb(il)+1))/ &
-                                               (ph(il,icb(il)+1)-ph(il,icb(il)+2))
-      ! IM beg
-    END IF !(icb(il.le.inb(il))) then
-    ! IM end
-  END DO
-  IF (prt_level>=20) PRINT *, 'cv3p2_closure apres 700'
-
-  ! 
-  ! ------------------------------------------------------------------------
-  ! c     Compute Cloud base mass flux given by Cape closure (cbmflim = cbmf of 
-  ! c     elementary systems), cbmf given by Alp closure (cbmfalp), cbmf given by Alp 
-  ! c     closure with an upper bound imposed (cbmfalpb) and cbmf resulting from
-  ! c     time integration (cbmflast).
-  ! ------------------------------------------------------------------------
-
-  DO il = 1, ncum
-    cbmflim(il) = 0.
-    cbmfalp(il) = 0.
-    cbmfalpb(il) = 0.
-    cbmflast(il) = 0.
-  END DO
-
-  ! c 1. Compute cloud base mass flux of elementary system (Cbmflim)
-
-  DO k = 1, nl
-    DO il = 1, ncum
-      ! old       IF (k .ge. icb(il) .and. k .le. inb(il)) THEN
-      ! IM        IF (k .ge. icb(il)+1 .and. k .le. inb(il)) THEN
-      IF (k>=icb(il) .AND. k<=inb(il) & !cor jyg
-          .AND. icb(il)+1<=inb(il)) THEN !cor jyg
-        cbmflim(il) = cbmflim(il) + mlim(il, k)
-      END IF
-    END DO
-  END DO
-  IF (prt_level>=20) PRINT *, 'cv3p2_closure after cbmflim: cbmflim ', cbmflim(igout)
-
-  ! 1.5 Compute cloud base mass flux given by Alp closure (Cbmfalp), maximum
-  !     allowed mass flux (Cbmfmax) and bounded mass flux (Cbmfalpb)
-  !     Cbmfalpb is set to zero if Cbmflim (the mass flux of elementary cloud)
-  !     is exceedingly small.
-
-  DO il = 1, ncum
-    wb2(il) = sqrt(2.*max(ale(il)+cin(il),0.))
-  END DO
-
-  DO il = 1, ncum
-    IF (plfc(il)<100.) THEN
-      ! This is an irealistic value for plfc => no calculation of wbeff
-      wbeff(il) = 100.1
-    ELSE
-      ! Calculate wbeff
-      IF (NINT(flag_wb)==0) THEN
-        wbeff(il) = wbmax
-      ELSE IF (NINT(flag_wb)==1) THEN
-        wbeff(il) = wbmax/(1.+500./(ph(il,1)-plfc(il)))
-      ELSE IF (NINT(flag_wb)==2) THEN
-        wbeff(il) = wbmax*(0.01*(ph(il,1)-plfc(il)))**2
-      END IF
-    END IF
-  END DO
-
-!CR:Compute k at plfc
-  DO il=1,ncum
-           klfc(il)=nl
-  ENDDO
-  DO k=1,nl
-     DO il=1,ncum
-        if ((plfc(il).lt.ph(il,k)).and.(plfc(il).ge.ph(il,k+1))) then
-           klfc(il)=k
-        endif
-     ENDDO
-  ENDDO
-!RC
-
-  DO il = 1, ncum
-    ! jyg    Modification du coef de wb*wb pour conformite avec papier Wake
-    ! c       cbmfalp(il) = alp2(il)/(0.5*wb*wb-Cin(il))
-    cbmfalp(il) = alp2(il)/(2.*wbeff(il)*wbeff(il)-cin(il))
-!CR: Add large-scale component to the mass-flux
-!encore connu sous le nom "Experience du tube de dentifrice"
-    if ((coef_clos_ls.gt.0.).and.(plfc(il).gt.0.)) then 
-       cbmfalp(il) = cbmfalp(il) - coef_clos_ls*min(0.,1./RG*omega(il,klfc(il)))
-    endif
-!RC
-    IF (cbmfalp(il)==0 .AND. alp2(il)/=0.) THEN
-      WRITE (lunout, *) 'cv3p2_closure cbmfalp=0 and alp NE 0 il alp2 alp cin ' , &
-                         il, alp2(il), alp(il), cin(il)
-      abort_message = ''
-      CALL abort_physic(modname, abort_message, 1)
-    END IF
-    cbmfmax(il) = sigmax*wb2(il)*100.*p(il, icb(il))/(rrd*tv(il,icb(il)))
-  END DO
-
-!jyg<
-  IF (OK_intermittent) THEN
-    DO il = 1, ncum
-      IF (cbmflim(il)>1.E-6) THEN
-        cbmfalpb(il) = min(cbmfalp(il), (cbmfmax(il)-beta*cbmf0(il))/(1.-beta))
-        ! print*,'cbmfalpb',cbmfalpb(il),cbmfmax(il)
-      END IF
-    END DO
-  ELSE
-!>jyg
-  DO il = 1, ncum
-    IF (cbmflim(il)>1.E-6) THEN
-      ! ATTENTION TEST CR
-      ! if (cbmfmax(il).lt.1.e-12) then
-      cbmfalpb(il) = min(cbmfalp(il), cbmfmax(il))
-      ! else
-      ! cbmfalpb(il) = cbmfalp(il)
-      ! endif
-      ! print*,'cbmfalpb',cbmfalp(il),cbmfmax(il)
-    END IF
-  END DO
-  ENDIF  !(OK_intermittent)
-  IF (prt_level>=20) PRINT *, 'cv3p2_closure apres cbmfalpb: cbmfalpb ',cbmfalpb(igout)
-
-  ! c 2. Compute coefficient and apply correction
-
-  DO il = 1, ncum
-    coef(il) = (cbmfalpb(il)+1.E-10)/(cbmflim(il)+1.E-10)
-  END DO
-  IF (prt_level>=20) PRINT *, 'cv3p2_closure apres coef_plantePLUS'
-
-     DO k = 1, nl
-       DO il = 1, ncum
-         IF (k>=icb(il)+1 .AND. k<=inb(il)) THEN
-           amu = beta*sig(il, k)*w0(il, k) + (1.-beta)*coef(il)*siglim(il, k)*wlim(il, k)
-           w0(il, k) = wlim(il, k)
-           w0(il, k) = max(w0(il,k), 1.E-10)
-           sig(il, k) = amu/w0(il, k)
-           sig(il, k) = min(sig(il,k), 1.)
-           ! c         amu = 0.5*(SIG(il,k)+sigold(il,k))*W0(il,k)
-           !jyg m(il, k) = amu*0.007*p(il, k)*(ph(il,k)-ph(il,k+1))/tv(il, k)
-           m(il, k) = amu*rhodp(il,k)
-         END IF
-       END DO
-     END DO
-  ! jyg2
-  DO il = 1, ncum
-    w0(il, icb(il)) = 0.5*w0(il, icb(il)+1)
-    m(il, icb(il)) = 0.5*m(il, icb(il)+1)*(ph(il,icb(il))-ph(il,icb(il)+1))/ &
-                                         (ph(il,icb(il)+1)-ph(il,icb(il)+2))
-    sig(il, icb(il)) = sig(il, icb(il)+1)
-    sig(il, icb(il)-1) = sig(il, icb(il))
-  END DO
-  IF (prt_level>=20) PRINT *, 'cv3p2_closure apres w0_sig_M: w0, sig ', &
-                         (k,w0(igout,k),sig(igout,k), k=icb(igout),inb(igout))
-
-!CR: new erosion of adiabatic ascent: modification of m
-!computation of the sum of ascending fluxes 
-  IF (iflag_mix_adiab.eq.1) THEN
-
-!Verification sum(me)=sum(m)
-  DO k = 1,nd
-    DO il = 1, ncum
-       md(il,k)=0.
-       med(il,k)=0.
-    ENDDO
-  ENDDO
-
-  DO k = nl,1,-1
-    DO il = 1, ncum
-           md(il,k)=md(il,k+1)+m(il,k+1)
-    ENDDO
-  ENDDO
-
-  DO k = nl,1,-1
-    DO il = 1, ncum
-        IF ((k>=(icb(il))) .AND. (k<=inb(il))) THEN
-           mad(il,k)=mad(il,k+1)+m(il,k+1)
-        ENDIF
-!        print*,"mad",il,k,mad(il,k)
-    ENDDO
-  ENDDO
-
-!CR: erosion of each adiabatic ascent during its ascent
-
-!Computation of erosion coefficient beta_coef
-  DO k = 1, nl
-    DO il = 1, ncum
-       IF ((k>=(icb(il)+1)) .AND. (k<=inb(il)) .AND. (mlim(il,k).gt.0.)) THEN     
-!          print*,"beta_coef",il,k,icb(il),inb(il),buoy(il,k),tv(il,k),wlim(il,k),wlim(il,k+1)
-          beta_coef(il,k)=RG*coef_peel*buoy(il,k)/tv(il,k)/((wlim(il,k)+wlim(il,k+1))/2.)**2
-       ELSE
-          beta_coef(il,k)=0.
-       ENDIF
-    ENDDO
-  ENDDO
-
-!  print*,"apres beta_coef"
-
-  DO k = 1, nl
-    DO il = 1, ncum
-
-      IF ((k>=(icb(il)+1)) .AND. (k<=inb(il))) THEN
-
-!        print*,"dz",il,k,tv(il, k-1)
-        dz = (ph(il,k-1)-ph(il,k))/(p(il, k-1)/(rrd*tv(il, k-1))*RG)
-        betalim(il,k)=betalim(il,k-1)*exp(-1.*beta_coef(il,k-1)*dz)
-!        betalim(il,k)=betalim(il,k-1)*exp(-RG*coef_peel*buoy(il,k-1)/tv(il,k-1)/5.**2*dz)
-!        print*,"me",il,k,mlim(il,k),buoy(il,k),wlim(il,k),mad(il,k)
-        dz = (ph(il,k)-ph(il,k+1))/(p(il, k)/(rrd*tv(il, k))*RG)
-!        me(il,k)=betalim(il,k)*(m(il,k)+RG*coef_peel*buoy(il,k)/tv(il,k)/((wlim(il,k)+wlim(il,k+1))/2.)**2*dz*mad(il,k))
-        me(il,k)=betalim(il,k)*(m(il,k)+beta_coef(il,k)*dz*mad(il,k))
-!        print*,"B/w2",il,k,RG*coef_peel*buoy(il,k)/tv(il,k)/((wlim(il,k)+wlim(il,k+1))/2.)**2*dz    
-      
-      END IF
-        
-!Modification of m
-      m(il,k)=me(il,k) 
-    END DO
-  END DO
- 
-!  DO il = 1, ncum
-!     dz = (ph(il,icb(il))-ph(il,icb(il)+1))/(p(il, icb(il))/(rrd*tv(il, icb(il)))*RG)
-!     m(il,icb(il))=m(il,icb(il))+RG*coef_peel*buoy(il,icb(il))/tv(il,icb(il)) &
-!                  /((wlim(il,icb(il))+wlim(il,icb(il)+1))/2.)**2*dz*mad(il,icb(il))
-!     print*,"wlim(icb)",icb(il),wlim(il,icb(il)),m(il,icb(il))
-!  ENDDO
-
-!Verification sum(me)=sum(m)
-  DO k = nl,1,-1
-    DO il = 1, ncum
-           med(il,k)=med(il,k+1)+m(il,k+1)
-!           print*,"somme(me),somme(m)",il,k,icb(il),med(il,k),md(il,k),me(il,k),m(il,k),wlim(il,k)
-    ENDDO
-  ENDDO
-
-
-  ENDIF !(iflag_mix_adiab)
-!RC
-
-  ! c 3. Compute final cloud base mass flux;
-  ! c    set iflag to 3 if cloud base mass flux is exceedingly small and is 
-  ! c     decreasing (i.e. if the final mass flux (cbmflast) is greater than 
-  ! c     the target mass flux (cbmfalpb)).
-  ! c    If(ok_convstop): set iflag to 4 if no positive buoyancy has been met
-
-!jyg  DO il = 1, ncum
-!jyg    cbmflast(il) = 0.
-!jyg  END DO
-
-  DO k = 1, nl
-    DO il = 1, ncum
-      IF (k>=icb(il) .AND. k<=inb(il)) THEN
-          !IMpropo??      IF ((k.ge.(icb(il)+1)).and.(k.le.inb(il))) THEN
-        cbmflast(il) = cbmflast(il) + m(il, k)
-      END IF
-    END DO
-  END DO
-  IF (prt_level>=20) PRINT *, 'cv3p2_closure apres cbmflast: cbmflast ',cbmflast(igout)
-
-  DO il = 1, ncum
-    IF (cbmflast(il)<1.E-6 .AND. cbmflast(il)>=cbmfalpb(il)) THEN
-      iflag(il) = 3
-    END IF
-  END DO
-
-!jyg<
-  IF (ok_convstop) THEN
-    DO il = 1, ncum
-      IF (dtminmax(il) .LE. 0.) THEN
-        iflag(il) = 4
-      END IF
-    END DO
-  ELSE
-!>jyg
-  DO k = 1, nl
-    DO il = 1, ncum
-      IF (iflag(il)>=3) THEN
-        m(il, k) = 0.
-        sig(il, k) = 0.
-        w0(il, k) = 0.
-      END IF
-    END DO
-  END DO
-  ENDIF ! (ok_convstop)
-!
-  IF (prt_level >= 10) THEN
-   print *,'cv3p2_closure: iflag ',iflag(igout)
-  ENDIF
-!
-
-  ! c 4. Introduce a correcting factor for coef, in order to obtain an
-  ! effective
-  ! c    sigdz larger in the present case (using cv3p2_closure) than in the
-  ! old
-  ! c    closure (using cv3_closure).
-  IF (1==0) THEN
-    DO il = 1, ncum
-      ! c      coef(il) = 2.*coef(il)
-      coef(il) = 5.*coef(il)
-    END DO
-    ! version CVS du ..2008
-  ELSE
-    IF (iflag_cvl_sigd==0) THEN
-      ! test pour verifier qu on fait la meme chose qu avant: sid constant
-      coef(1:ncum) = 1.
-    ELSE
-      coef(1:ncum) = min(2.*coef(1:ncum), 5.)
-      coef(1:ncum) = max(2.*coef(1:ncum), 0.2)
-    END IF
-  END IF
-
-  IF (prt_level>=20) PRINT *, 'cv3p2_closure FIN'
-  RETURN
-END SUBROUTINE cv3p2_closure
-
-
Index: /LMDZ6/trunk/libf/phylmd/cv3p2_closure.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cv3p2_closure.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/cv3p2_closure.f90	(revision 5268)
@@ -0,0 +1,869 @@
+
+
+SUBROUTINE cv3p2_closure(nloc, ncum, nd, icb, inb, pbase, plcl, p, ph, tv, &
+    tvp, buoy, supmax, ok_inhib, ale, alp, omega,sig, w0, ptop2, cape, cin, m, &
+    iflag, coef, plim1, plim2, asupmax, supmax0, asupmaxmin, cbmflast, plfc, &
+    wbeff)
+
+
+  ! **************************************************************
+  ! *
+  ! CV3P2_CLOSURE                                               *
+  ! Ale & Alp Closure of Convect3              *
+  ! *
+  ! written by   :   Kerry Emanuel                              *
+  ! vectorization:   S. Bony                                    *
+  ! modified by :    Jean-Yves Grandpeix, 18/06/2003, 19.32.10  *
+  ! Julie Frohwirth,     14/10/2005  17.44.22  *
+  ! **************************************************************
+
+  USE print_control_mod, ONLY: prt_level, lunout
+  IMPLICIT NONE
+
+  include "cvthermo.h"
+  include "cv3param.h"
+  include "cvflag.h"
+  include "YOMCST2.h"
+  include "YOMCST.h"
+  include "conema3.h"
+
+  ! input:
+  INTEGER, INTENT (IN)                               :: ncum, nd, nloc
+  INTEGER, DIMENSION (nloc), INTENT (IN)             :: icb, inb
+  REAL, DIMENSION (nloc), INTENT (IN)                :: pbase, plcl
+  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: p
+  REAL, DIMENSION (nloc, nd+1), INTENT (IN)          :: ph
+  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: tv, tvp, buoy
+  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: supmax
+  LOGICAL, INTENT (IN)                               :: ok_inhib ! enable convection inhibition by dryness
+  REAL, DIMENSION (nloc), INTENT (IN)                :: ale, alp
+  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: omega
+
+  ! input/output:
+  INTEGER, DIMENSION (nloc), INTENT (INOUT)          :: iflag
+  REAL, DIMENSION (nloc, nd), INTENT (INOUT)         :: sig, w0
+  REAL, DIMENSION (nloc), INTENT (INOUT)             :: ptop2
+
+  ! output:
+  REAL, DIMENSION (nloc), INTENT (OUT)               :: cape, cin
+  REAL, DIMENSION (nloc, nd), INTENT (OUT)           :: m
+  REAL, DIMENSION (nloc), INTENT (OUT)               :: plim1, plim2
+  REAL, DIMENSION (nloc, nd), INTENT (OUT)           :: asupmax
+  REAL, DIMENSION (nloc), INTENT (OUT)               :: supmax0
+  REAL, DIMENSION (nloc), INTENT (OUT)               :: asupmaxmin
+  REAL, DIMENSION (nloc), INTENT (OUT)               :: cbmflast, plfc
+  REAL, DIMENSION (nloc), INTENT (OUT)               :: wbeff
+
+  ! local variables:
+  INTEGER                                            :: il, i, j, k, icbmax
+  INTEGER, DIMENSION (nloc)                          :: i0, klfc
+  REAL                                               :: deltap, fac, w, amu
+  REAL, DIMENSION (nloc, nd)                         :: rhodp               ! Factor such that m=rhodp*sig*w
+  REAL                                               :: dz
+  REAL                                               :: pbmxup
+  REAL, DIMENSION (nloc, nd)                         :: dtmin, sigold
+  REAL, DIMENSION (nloc, nd)                         :: coefmix
+  REAL, DIMENSION (nloc)                             :: dtminmax
+  REAL, DIMENSION (nloc)                             :: pzero, ptop2old
+  REAL, DIMENSION (nloc)                             :: cina, cinb
+  INTEGER, DIMENSION (nloc)                          :: ibeg
+  INTEGER, DIMENSION (nloc)                          :: nsupmax
+  REAL                                               :: supcrit
+  REAL, DIMENSION (nloc, nd)                         :: temp
+  REAL, DIMENSION (nloc)                             :: p1, pmin
+  REAL, DIMENSION (nloc)                             :: asupmax0
+  LOGICAL, DIMENSION (nloc)                          :: ok
+  REAL, DIMENSION (nloc, nd)                         :: siglim, wlim, mlim
+  REAL, DIMENSION (nloc)                             :: wb2
+  REAL, DIMENSION (nloc)                             :: cbmf0        ! initial cloud base mass flux
+  REAL, DIMENSION (nloc)                             :: cbmflim      ! cbmf given by Cape closure
+  REAL, DIMENSION (nloc)                             :: cbmfalp      ! cbmf given by Alp closure
+  REAL, DIMENSION (nloc)                             :: cbmfalpb     ! bounded cbmf given by Alp closure
+  REAL, DIMENSION (nloc)                             :: cbmfmax      ! upper bound on cbmf
+  REAL, DIMENSION (nloc)                             :: coef
+  REAL, DIMENSION (nloc)                             :: xp, xq, xr, discr, b3, b4
+  REAL, DIMENSION (nloc)                             :: theta, bb
+  REAL                                               :: term1, term2, term3
+  REAL, DIMENSION (nloc)                             :: alp2                  ! Alp with offset
+
+!CR: variables for new erosion of adiabiatic ascent
+  REAL, DIMENSION (nloc, nd)                         :: mad, me, betalim, beta_coef
+  REAL, DIMENSION (nloc, nd)                         :: med, md
+!jyg<
+! coef_peel is now in the common cv3_param 
+!!  REAL                                               :: coef_peel
+!!  PARAMETER (coef_peel=0.25)
+!>jyg
+
+  REAL                                               :: sigmax
+  PARAMETER (sigmax=0.1)
+!!  PARAMETER (sigmax=10.)
+
+  CHARACTER (LEN=20)                                 :: modname = 'cv3p2_closure'
+  CHARACTER (LEN=80)                                 :: abort_message
+
+  INTEGER,SAVE                                       :: igout=1
+!$OMP THREADPRIVATE(igout)
+
+ IF (prt_level>=20) print *,' -> cv3p2_closure, Ale ',ale(igout)
+
+
+  ! -------------------------------------------------------
+  ! -- Initialization
+  ! -------------------------------------------------------
+
+
+  DO il = 1, ncum
+    alp2(il) = max(alp(il), 1.E-5)
+    ! IM
+    alp2(il) = max(alp(il), 1.E-12)
+  END DO
+
+  pbmxup = 50. ! PBMXUP+PBCRIT = cloud depth above which mixed updraughts
+  ! exist (if any)
+
+  IF (prt_level>=20) PRINT *, 'cv3p2_closure nloc ncum nd icb inb nl', nloc, &
+    ncum, nd, icb(nloc), inb(nloc), nl
+  DO k = 1, nl
+    DO il = 1, ncum
+      rhodp(il,k) = 0.007*p(il, k)*(ph(il,k)-ph(il,k+1))/tv(il, k)
+    END DO
+  END DO
+
+!CR+jyg: initializations (up to nd) for erosion of adiabatic ascent and of m and wlim
+  DO k = 1,nd
+    DO il = 1, ncum
+        mad(il,k)=0.
+        me(il,k)=0.
+        betalim(il,k)=1.
+        wlim(il,k)=0.
+        m(il, k) = 0.0
+    ENDDO
+  ENDDO
+
+  ! -------------------------------------------------------
+  ! -- Reset sig(i) and w0(i) for i>inb and i<icb
+  ! -------------------------------------------------------
+
+  ! update sig and w0 above LNB:
+
+  DO k = 1, nl - 1
+    DO il = 1, ncum
+      IF ((inb(il)<(nl-1)) .AND. (k>=(inb(il)+1))) THEN
+        sig(il, k) = beta*sig(il, k) + 2.*alpha*buoy(il, inb(il))*abs(buoy(il,inb(il)))
+        sig(il, k) = amax1(sig(il,k), 0.0)
+        w0(il, k) = beta*w0(il, k)
+      END IF
+    END DO
+  END DO
+
+  ! if(prt.level.GE.20) print*,'cv3p2_closure apres 100'
+  ! compute icbmax:
+
+  icbmax = 2
+  DO il = 1, ncum
+    icbmax = max(icbmax, icb(il))
+  END DO
+  ! if(prt.level.GE.20) print*,'cv3p2_closure apres 200'
+
+  ! update sig and w0 below cloud base:
+
+  DO k = 1, icbmax
+    DO il = 1, ncum
+      IF (k<=icb(il)) THEN
+        sig(il, k) = beta*sig(il, k) - 2.*alpha*buoy(il, icb(il))*buoy(il,icb(il))
+        sig(il, k) = amax1(sig(il,k), 0.0)
+        w0(il, k) = beta*w0(il, k)
+      END IF
+    END DO
+  END DO
+  IF (prt_level>=20) PRINT *, 'cv3p2_closure apres 300'
+
+  ! -------------------------------------------------------------
+  ! -- Reset fractional areas of updrafts and w0 at initial time
+  ! -- and after 10 time steps of no convection
+  ! -------------------------------------------------------------
+
+!jyg<
+  IF (ok_convstop) THEN
+    DO k = 1, nl - 1
+      DO il = 1, ncum
+        IF (sig(il,nd)<1.5 .OR. sig(il,nd)>noconv_stop) THEN
+          sig(il, k) = 0.0
+          w0(il, k) = 0.0
+        END IF
+      END DO
+    END DO
+  ELSE
+  DO k = 1, nl - 1
+    DO il = 1, ncum
+      IF (sig(il,nd)<1.5 .OR. sig(il,nd)>12.0) THEN
+        sig(il, k) = 0.0
+        w0(il, k) = 0.0
+      END IF
+    END DO
+  END DO
+  ENDIF  ! (ok_convstop)
+!>jyg
+  IF (prt_level>=20) PRINT *, 'cv3p2_closure apres 400'
+
+  ! -------------------------------------------------------
+  ! -- Compute initial cloud base mass flux (Cbmf0)
+  ! -------------------------------------------------------
+  DO il = 1, ncum
+    cbmf0(il) = 0.0
+  END DO
+
+  DO k = 1, nl
+    DO il = 1, ncum
+      IF (k>=icb(il) .AND. k<=inb(il) & 
+          .AND. icb(il)+1<=inb(il)) THEN
+        cbmf0(il) = cbmf0(il) + sig(il, k)*w0(il,k)*rhodp(il,k)
+      END IF
+    END DO
+  END DO
+
+  ! -------------------------------------------------------------
+  ! jyg1
+  ! --  Calculate adiabatic ascent top pressure (ptop)
+  ! -------------------------------------------------------------
+
+
+  ! c 1. Start at first level where precipitations form
+  DO il = 1, ncum
+    pzero(il) = plcl(il) - pbcrit
+  END DO
+
+  ! c 2. Add offset
+  DO il = 1, ncum
+    pzero(il) = pzero(il) - pbmxup
+  END DO
+  DO il = 1, ncum
+    ptop2old(il) = ptop2(il)
+  END DO
+
+  DO il = 1, ncum
+    ! CR:c est quoi ce 300??
+    p1(il) = pzero(il) - 300.
+  END DO
+
+  ! compute asupmax=abs(supmax) up to lnm+1
+
+  DO il = 1, ncum
+    ok(il) = .TRUE.
+    nsupmax(il) = inb(il)
+  END DO
+
+  DO i = 1, nl
+    DO il = 1, ncum
+      IF (i>icb(il) .AND. i<=inb(il)) THEN
+        IF (p(il,i)<=pzero(il) .AND. supmax(il,i)<0 .AND. ok(il)) THEN
+          nsupmax(il) = i
+          ok(il) = .FALSE.
+        END IF ! end IF (P(i) ...  )
+      END IF ! end IF (icb+1 le i le inb)
+    END DO
+  END DO
+
+  IF (prt_level>=20) PRINT *, 'cv3p2_closure apres 2.'
+  DO i = 1, nl
+    DO il = 1, ncum
+      asupmax(il, i) = abs(supmax(il,i))
+    END DO
+  END DO
+
+
+  DO il = 1, ncum
+    asupmaxmin(il) = 10.
+    pmin(il) = 100.
+    ! IM ??
+    asupmax0(il) = 0.
+  END DO
+
+  ! c 3.  Compute in which level is Pzero
+
+  ! IM bug      i0 = 18
+  DO il = 1, ncum
+    i0(il) = nl
+  END DO
+
+  DO i = 1, nl
+    DO il = 1, ncum
+      IF (i>icb(il) .AND. i<=inb(il)) THEN
+        IF (p(il,i)<=pzero(il) .AND. p(il,i)>=p1(il)) THEN
+          IF (pzero(il)>p(il,i) .AND. pzero(il)<p(il,i-1)) THEN
+            i0(il) = i
+          END IF
+        END IF
+      END IF
+    END DO
+  END DO
+  IF (prt_level>=20) PRINT *, 'cv3p2_closure apres 3.'
+
+  ! c 4.  Compute asupmax at Pzero
+
+  DO i = 1, nl
+    DO il = 1, ncum
+      IF (i>icb(il) .AND. i<=inb(il)) THEN
+        IF (p(il,i)<=pzero(il) .AND. p(il,i)>=p1(il)) THEN
+          asupmax0(il) = ((pzero(il)-p(il,i0(il)-1))*asupmax(il,i0(il))- &
+            (pzero(il)-p(il,i0(il)))*asupmax(il,i0(il)-1))/(p(il,i0(il))-p(il,i0(il)-1))
+        END IF
+      END IF
+    END DO
+  END DO
+
+
+  DO i = 1, nl
+    DO il = 1, ncum
+      IF (p(il,i)==pzero(il)) THEN
+        asupmax(i, il) = asupmax0(il)
+      END IF
+    END DO
+  END DO
+  IF (prt_level>=20) PRINT *, 'cv3p2_closure apres 4.'
+
+  ! c 5. Compute asupmaxmin, minimum of asupmax
+
+  DO i = 1, nl
+    DO il = 1, ncum
+      IF (i>icb(il) .AND. i<=inb(il)) THEN
+        IF (p(il,i)<=pzero(il) .AND. p(il,i)>=p1(il)) THEN
+          IF (asupmax(il,i)<asupmaxmin(il)) THEN
+            asupmaxmin(il) = asupmax(il, i)
+            pmin(il) = p(il, i)
+          END IF
+        END IF
+      END IF
+    END DO
+  END DO
+
+  DO il = 1, ncum
+    ! IM
+    IF (prt_level>=20) THEN
+      PRINT *, 'cv3p2_closure il asupmax0 asupmaxmin', il, asupmax0(il), &
+        asupmaxmin(il), pzero(il), pmin(il)
+    END IF
+    IF (asupmax0(il)<asupmaxmin(il)) THEN
+      asupmaxmin(il) = asupmax0(il)
+      pmin(il) = pzero(il)
+    END IF
+  END DO
+  IF (prt_level>=20) PRINT *, 'cv3p2_closure apres 5.'
+
+
+  ! Compute Supmax at Pzero
+
+  DO i = 1, nl
+    DO il = 1, ncum
+      IF (i>icb(il) .AND. i<=inb(il)) THEN
+        IF (p(il,i)<=pzero(il)) THEN
+          supmax0(il) = ((p(il,i)-pzero(il))*asupmax(il,i-1)- &
+            (p(il,i-1)-pzero(il))*asupmax(il,i))/(p(il,i)-p(il,i-1))
+          GO TO 425
+        END IF ! end IF (P(i) ... )
+      END IF ! end IF (icb+1 le i le inb)
+    END DO
+  END DO
+
+425 CONTINUE
+  IF (prt_level>=20) PRINT *, 'cv3p2_closure apres 425.'
+
+  ! c 6. Calculate ptop2
+
+  DO il = 1, ncum
+    IF (asupmaxmin(il)<supcrit1) THEN
+      ptop2(il) = pmin(il)
+    END IF
+
+    IF (asupmaxmin(il)>supcrit1 .AND. asupmaxmin(il)<supcrit2) THEN
+      ptop2(il) = ptop2old(il)
+    END IF
+
+    IF (asupmaxmin(il)>supcrit2) THEN
+      ptop2(il) = ph(il, inb(il))
+    END IF
+  END DO
+
+  IF (prt_level>=20) PRINT *, 'cv3p2_closure apres 6.'
+
+  ! c 7. Compute multiplying factor for adiabatic updraught mass flux
+
+
+  IF (ok_inhib) THEN
+
+    DO i = 1, nl
+      DO il = 1, ncum
+        IF (i<=nl) THEN
+          coefmix(il, i) = (min(ptop2(il),ph(il,i))-ph(il,i))/(ph(il,i+1)-ph(il,i))
+          coefmix(il, i) = min(coefmix(il,i), 1.)
+        END IF
+      END DO
+    END DO
+
+
+  ELSE ! when inhibition is not taken into account, coefmix=1
+
+
+
+    DO i = 1, nl
+      DO il = 1, ncum
+        IF (i<=nl) THEN
+          coefmix(il, i) = 1.
+        END IF
+      END DO
+    END DO
+
+  END IF ! ok_inhib
+  IF (prt_level>=20) PRINT *, 'cv3p2_closure apres 7.'
+  ! -------------------------------------------------------------------
+  ! -------------------------------------------------------------------
+
+
+  ! jyg2
+
+  ! ==========================================================================
+
+
+  ! -------------------------------------------------------------
+  ! -- Calculate convective inhibition (CIN)
+  ! -------------------------------------------------------------
+
+  ! do i=1,nloc
+  ! print*,'avant cine p',pbase(i),plcl(i)
+  ! enddo
+  ! do j=1,nd
+  ! do i=1,nloc
+  ! print*,'avant cine t',tv(i),tvp(i)
+  ! enddo
+  ! enddo
+  CALL cv3_cine(nloc, ncum, nd, icb, inb, pbase, plcl, p, ph, tv, tvp, cina, &
+    cinb, plfc)
+
+  DO il = 1, ncum
+    cin(il) = cina(il) + cinb(il)
+  END DO
+  IF (prt_level>=20) PRINT *, 'cv3p2_closure after cv3_cine: cina, cinb, cin ', &
+                              cina(igout), cinb(igout), cin(igout)
+  ! -------------------------------------------------------------
+  ! --Update buoyancies to account for Ale
+  ! -------------------------------------------------------------
+
+  CALL cv3_buoy(nloc, ncum, nd, icb, inb, pbase, plcl, p, ph, ale, cin, tv, &
+    tvp, buoy)
+  IF (prt_level>=20) PRINT *, 'cv3p2_closure after cv3_buoy'
+
+  ! -------------------------------------------------------------
+  ! -- Calculate convective available potential energy (cape),
+  ! -- vertical velocity (w), fractional area covered by
+  ! -- undilute updraft (sig), and updraft mass flux (m)
+  ! -------------------------------------------------------------
+
+  DO il = 1, ncum
+    cape(il) = 0.0
+    dtminmax(il) = -100.
+  END DO
+
+  ! compute dtmin (minimum buoyancy between ICB and given level k):
+
+  DO k = 1, nl
+    DO il = 1, ncum
+      dtmin(il, k) = 100.0
+    END DO
+  END DO
+
+  DO k = 1, nl
+    DO j = minorig, nl
+      DO il = 1, ncum
+        IF ((k>=(icb(il)+1)) .AND. (k<=inb(il)) .AND. (j>=icb(il)) &
+                             .AND. (j<=(k-1))) THEN
+          dtmin(il, k) = amin1(dtmin(il,k), buoy(il,j))
+        END IF
+      END DO
+    END DO
+  END DO
+!jyg<
+!  Store maximum of dtmin
+!  C est pas terrible d avoir ce test sur Ale+Cin encore une fois ici.
+!                      A REVOIR !
+  DO k = 1, nl
+    DO il = 1, ncum
+      IF (k>=(icb(il)+1) .AND. k<=inb(il) .AND. ale(il)+cin(il)>0.) THEN
+        dtminmax(il) = max(dtmin(il,k), dtminmax(il))
+      ENDIF
+    END DO
+  END DO
+!
+!    prevent convection when ale+cin <= 0
+  DO k = 1, nl
+    DO il = 1, ncum
+      IF (k>=(icb(il)+1) .AND. k<=inb(il)) THEN
+        dtmin(il,k) = min(dtmin(il,k), dtminmax(il))
+      ENDIF
+    END DO
+  END DO
+!>jyg
+!
+  IF (prt_level >= 20) THEN
+    print *,'cv3p2_closure: dtmin ', (k, dtmin(igout,k), k=1,nl)
+    print *,'cv3p2_closure: dtminmax ', dtminmax(igout)
+  ENDIF
+!
+  ! the interval on which cape is computed starts at pbase :
+
+  DO k = 1, nl
+    DO il = 1, ncum
+
+      IF ((k>=(icb(il)+1)) .AND. (k<=inb(il))) THEN
+
+        IF (iflag_mix_adiab.eq.1) THEN
+!CR:computation of cape from LCL: keep flag or to modify in all cases?
+        deltap = min(plcl(il), ph(il,k-1)) - min(plcl(il), ph(il,k))
+        ELSE
+        deltap = min(pbase(il), ph(il,k-1)) - min(pbase(il), ph(il,k))
+        ENDIF
+        cape(il) = cape(il) + rrd*buoy(il, k-1)*deltap/p(il, k-1)
+        cape(il) = amax1(0.0, cape(il))
+        sigold(il, k) = sig(il, k)
+
+
+        ! jyg       Coefficient coefmix limits convection to levels where a
+        ! sufficient
+        ! fraction of mixed draughts are ascending.
+        siglim(il, k) = coefmix(il, k)*alpha1*dtmin(il, k)*abs(dtmin(il,k))
+        siglim(il, k) = amax1(siglim(il,k), 0.0)
+        siglim(il, k) = amin1(siglim(il,k), 0.01)
+        ! c         fac=AMIN1(((dtcrit-dtmin(il,k))/dtcrit),1.0)
+        fac = 1.
+        wlim(il, k) = fac*sqrt(cape(il))
+        amu = siglim(il, k)*wlim(il, k)
+!!        rhodp(il,k) = 0.007*p(il, k)*(ph(il,k)-ph(il,k+1))/tv(il, k) !cor jyg : computed earlier
+        mlim(il, k) = amu*rhodp(il,k)
+        ! print*, 'siglim ', k,siglim(1,k)
+      END IF
+
+    END DO
+  END DO
+  IF (prt_level>=20) PRINT *, 'cv3p2_closure apres 600'
+
+  DO il = 1, ncum
+    ! IM beg
+    IF (prt_level>=20) THEN
+      PRINT *, 'cv3p2_closure il icb mlim ph ph+1 ph+2', il, icb(il), &
+        mlim(il, icb(il)+1), ph(il, icb(il)), ph(il, icb(il)+1), &
+        ph(il, icb(il)+2)
+    END IF
+
+    IF (icb(il)+1<=inb(il)) THEN
+      ! IM end
+      mlim(il, icb(il)) = 0.5*mlim(il,icb(il)+1)*(ph(il,icb(il))-ph(il,icb(il)+1))/ &
+                                               (ph(il,icb(il)+1)-ph(il,icb(il)+2))
+      ! IM beg
+    END IF !(icb(il.le.inb(il))) then
+    ! IM end
+  END DO
+  IF (prt_level>=20) PRINT *, 'cv3p2_closure apres 700'
+
+  ! 
+  ! ------------------------------------------------------------------------
+  ! c     Compute Cloud base mass flux given by Cape closure (cbmflim = cbmf of 
+  ! c     elementary systems), cbmf given by Alp closure (cbmfalp), cbmf given by Alp 
+  ! c     closure with an upper bound imposed (cbmfalpb) and cbmf resulting from
+  ! c     time integration (cbmflast).
+  ! ------------------------------------------------------------------------
+
+  DO il = 1, ncum
+    cbmflim(il) = 0.
+    cbmfalp(il) = 0.
+    cbmfalpb(il) = 0.
+    cbmflast(il) = 0.
+  END DO
+
+  ! c 1. Compute cloud base mass flux of elementary system (Cbmflim)
+
+  DO k = 1, nl
+    DO il = 1, ncum
+      ! old       IF (k .ge. icb(il) .and. k .le. inb(il)) THEN
+      ! IM        IF (k .ge. icb(il)+1 .and. k .le. inb(il)) THEN
+      IF (k>=icb(il) .AND. k<=inb(il) & !cor jyg
+          .AND. icb(il)+1<=inb(il)) THEN !cor jyg
+        cbmflim(il) = cbmflim(il) + mlim(il, k)
+      END IF
+    END DO
+  END DO
+  IF (prt_level>=20) PRINT *, 'cv3p2_closure after cbmflim: cbmflim ', cbmflim(igout)
+
+  ! 1.5 Compute cloud base mass flux given by Alp closure (Cbmfalp), maximum
+  !     allowed mass flux (Cbmfmax) and bounded mass flux (Cbmfalpb)
+  !     Cbmfalpb is set to zero if Cbmflim (the mass flux of elementary cloud)
+  !     is exceedingly small.
+
+  DO il = 1, ncum
+    wb2(il) = sqrt(2.*max(ale(il)+cin(il),0.))
+  END DO
+
+  DO il = 1, ncum
+    IF (plfc(il)<100.) THEN
+      ! This is an irealistic value for plfc => no calculation of wbeff
+      wbeff(il) = 100.1
+    ELSE
+      ! Calculate wbeff
+      IF (NINT(flag_wb)==0) THEN
+        wbeff(il) = wbmax
+      ELSE IF (NINT(flag_wb)==1) THEN
+        wbeff(il) = wbmax/(1.+500./(ph(il,1)-plfc(il)))
+      ELSE IF (NINT(flag_wb)==2) THEN
+        wbeff(il) = wbmax*(0.01*(ph(il,1)-plfc(il)))**2
+      END IF
+    END IF
+  END DO
+
+!CR:Compute k at plfc
+  DO il=1,ncum
+           klfc(il)=nl
+  ENDDO
+  DO k=1,nl
+     DO il=1,ncum
+        if ((plfc(il).lt.ph(il,k)).and.(plfc(il).ge.ph(il,k+1))) then
+           klfc(il)=k
+        endif
+     ENDDO
+  ENDDO
+!RC
+
+  DO il = 1, ncum
+    ! jyg    Modification du coef de wb*wb pour conformite avec papier Wake
+    ! c       cbmfalp(il) = alp2(il)/(0.5*wb*wb-Cin(il))
+    cbmfalp(il) = alp2(il)/(2.*wbeff(il)*wbeff(il)-cin(il))
+!CR: Add large-scale component to the mass-flux
+!encore connu sous le nom "Experience du tube de dentifrice"
+    if ((coef_clos_ls.gt.0.).and.(plfc(il).gt.0.)) then 
+       cbmfalp(il) = cbmfalp(il) - coef_clos_ls*min(0.,1./RG*omega(il,klfc(il)))
+    endif
+!RC
+    IF (cbmfalp(il)==0 .AND. alp2(il)/=0.) THEN
+      WRITE (lunout, *) 'cv3p2_closure cbmfalp=0 and alp NE 0 il alp2 alp cin ' , &
+                         il, alp2(il), alp(il), cin(il)
+      abort_message = ''
+      CALL abort_physic(modname, abort_message, 1)
+    END IF
+    cbmfmax(il) = sigmax*wb2(il)*100.*p(il, icb(il))/(rrd*tv(il,icb(il)))
+  END DO
+
+!jyg<
+  IF (OK_intermittent) THEN
+    DO il = 1, ncum
+      IF (cbmflim(il)>1.E-6) THEN
+        cbmfalpb(il) = min(cbmfalp(il), (cbmfmax(il)-beta*cbmf0(il))/(1.-beta))
+        ! print*,'cbmfalpb',cbmfalpb(il),cbmfmax(il)
+      END IF
+    END DO
+  ELSE
+!>jyg
+  DO il = 1, ncum
+    IF (cbmflim(il)>1.E-6) THEN
+      ! ATTENTION TEST CR
+      ! if (cbmfmax(il).lt.1.e-12) then
+      cbmfalpb(il) = min(cbmfalp(il), cbmfmax(il))
+      ! else
+      ! cbmfalpb(il) = cbmfalp(il)
+      ! endif
+      ! print*,'cbmfalpb',cbmfalp(il),cbmfmax(il)
+    END IF
+  END DO
+  ENDIF  !(OK_intermittent)
+  IF (prt_level>=20) PRINT *, 'cv3p2_closure apres cbmfalpb: cbmfalpb ',cbmfalpb(igout)
+
+  ! c 2. Compute coefficient and apply correction
+
+  DO il = 1, ncum
+    coef(il) = (cbmfalpb(il)+1.E-10)/(cbmflim(il)+1.E-10)
+  END DO
+  IF (prt_level>=20) PRINT *, 'cv3p2_closure apres coef_plantePLUS'
+
+     DO k = 1, nl
+       DO il = 1, ncum
+         IF (k>=icb(il)+1 .AND. k<=inb(il)) THEN
+           amu = beta*sig(il, k)*w0(il, k) + (1.-beta)*coef(il)*siglim(il, k)*wlim(il, k)
+           w0(il, k) = wlim(il, k)
+           w0(il, k) = max(w0(il,k), 1.E-10)
+           sig(il, k) = amu/w0(il, k)
+           sig(il, k) = min(sig(il,k), 1.)
+           ! c         amu = 0.5*(SIG(il,k)+sigold(il,k))*W0(il,k)
+           !jyg m(il, k) = amu*0.007*p(il, k)*(ph(il,k)-ph(il,k+1))/tv(il, k)
+           m(il, k) = amu*rhodp(il,k)
+         END IF
+       END DO
+     END DO
+  ! jyg2
+  DO il = 1, ncum
+    w0(il, icb(il)) = 0.5*w0(il, icb(il)+1)
+    m(il, icb(il)) = 0.5*m(il, icb(il)+1)*(ph(il,icb(il))-ph(il,icb(il)+1))/ &
+                                         (ph(il,icb(il)+1)-ph(il,icb(il)+2))
+    sig(il, icb(il)) = sig(il, icb(il)+1)
+    sig(il, icb(il)-1) = sig(il, icb(il))
+  END DO
+  IF (prt_level>=20) PRINT *, 'cv3p2_closure apres w0_sig_M: w0, sig ', &
+                         (k,w0(igout,k),sig(igout,k), k=icb(igout),inb(igout))
+
+!CR: new erosion of adiabatic ascent: modification of m
+!computation of the sum of ascending fluxes 
+  IF (iflag_mix_adiab.eq.1) THEN
+
+!Verification sum(me)=sum(m)
+  DO k = 1,nd
+    DO il = 1, ncum
+       md(il,k)=0.
+       med(il,k)=0.
+    ENDDO
+  ENDDO
+
+  DO k = nl,1,-1
+    DO il = 1, ncum
+           md(il,k)=md(il,k+1)+m(il,k+1)
+    ENDDO
+  ENDDO
+
+  DO k = nl,1,-1
+    DO il = 1, ncum
+        IF ((k>=(icb(il))) .AND. (k<=inb(il))) THEN
+           mad(il,k)=mad(il,k+1)+m(il,k+1)
+        ENDIF
+!        print*,"mad",il,k,mad(il,k)
+    ENDDO
+  ENDDO
+
+!CR: erosion of each adiabatic ascent during its ascent
+
+!Computation of erosion coefficient beta_coef
+  DO k = 1, nl
+    DO il = 1, ncum
+       IF ((k>=(icb(il)+1)) .AND. (k<=inb(il)) .AND. (mlim(il,k).gt.0.)) THEN     
+!          print*,"beta_coef",il,k,icb(il),inb(il),buoy(il,k),tv(il,k),wlim(il,k),wlim(il,k+1)
+          beta_coef(il,k)=RG*coef_peel*buoy(il,k)/tv(il,k)/((wlim(il,k)+wlim(il,k+1))/2.)**2
+       ELSE
+          beta_coef(il,k)=0.
+       ENDIF
+    ENDDO
+  ENDDO
+
+!  print*,"apres beta_coef"
+
+  DO k = 1, nl
+    DO il = 1, ncum
+
+      IF ((k>=(icb(il)+1)) .AND. (k<=inb(il))) THEN
+
+!        print*,"dz",il,k,tv(il, k-1)
+        dz = (ph(il,k-1)-ph(il,k))/(p(il, k-1)/(rrd*tv(il, k-1))*RG)
+        betalim(il,k)=betalim(il,k-1)*exp(-1.*beta_coef(il,k-1)*dz)
+!        betalim(il,k)=betalim(il,k-1)*exp(-RG*coef_peel*buoy(il,k-1)/tv(il,k-1)/5.**2*dz)
+!        print*,"me",il,k,mlim(il,k),buoy(il,k),wlim(il,k),mad(il,k)
+        dz = (ph(il,k)-ph(il,k+1))/(p(il, k)/(rrd*tv(il, k))*RG)
+!        me(il,k)=betalim(il,k)*(m(il,k)+RG*coef_peel*buoy(il,k)/tv(il,k)/((wlim(il,k)+wlim(il,k+1))/2.)**2*dz*mad(il,k))
+        me(il,k)=betalim(il,k)*(m(il,k)+beta_coef(il,k)*dz*mad(il,k))
+!        print*,"B/w2",il,k,RG*coef_peel*buoy(il,k)/tv(il,k)/((wlim(il,k)+wlim(il,k+1))/2.)**2*dz    
+      
+      END IF
+        
+!Modification of m
+      m(il,k)=me(il,k) 
+    END DO
+  END DO
+ 
+!  DO il = 1, ncum
+!     dz = (ph(il,icb(il))-ph(il,icb(il)+1))/(p(il, icb(il))/(rrd*tv(il, icb(il)))*RG)
+!     m(il,icb(il))=m(il,icb(il))+RG*coef_peel*buoy(il,icb(il))/tv(il,icb(il)) &
+!                  /((wlim(il,icb(il))+wlim(il,icb(il)+1))/2.)**2*dz*mad(il,icb(il))
+!     print*,"wlim(icb)",icb(il),wlim(il,icb(il)),m(il,icb(il))
+!  ENDDO
+
+!Verification sum(me)=sum(m)
+  DO k = nl,1,-1
+    DO il = 1, ncum
+           med(il,k)=med(il,k+1)+m(il,k+1)
+!           print*,"somme(me),somme(m)",il,k,icb(il),med(il,k),md(il,k),me(il,k),m(il,k),wlim(il,k)
+    ENDDO
+  ENDDO
+
+
+  ENDIF !(iflag_mix_adiab)
+!RC
+
+  ! c 3. Compute final cloud base mass flux;
+  ! c    set iflag to 3 if cloud base mass flux is exceedingly small and is 
+  ! c     decreasing (i.e. if the final mass flux (cbmflast) is greater than 
+  ! c     the target mass flux (cbmfalpb)).
+  ! c    If(ok_convstop): set iflag to 4 if no positive buoyancy has been met
+
+!jyg  DO il = 1, ncum
+!jyg    cbmflast(il) = 0.
+!jyg  END DO
+
+  DO k = 1, nl
+    DO il = 1, ncum
+      IF (k>=icb(il) .AND. k<=inb(il)) THEN
+          !IMpropo??      IF ((k.ge.(icb(il)+1)).and.(k.le.inb(il))) THEN
+        cbmflast(il) = cbmflast(il) + m(il, k)
+      END IF
+    END DO
+  END DO
+  IF (prt_level>=20) PRINT *, 'cv3p2_closure apres cbmflast: cbmflast ',cbmflast(igout)
+
+  DO il = 1, ncum
+    IF (cbmflast(il)<1.E-6 .AND. cbmflast(il)>=cbmfalpb(il)) THEN
+      iflag(il) = 3
+    END IF
+  END DO
+
+!jyg<
+  IF (ok_convstop) THEN
+    DO il = 1, ncum
+      IF (dtminmax(il) .LE. 0.) THEN
+        iflag(il) = 4
+      END IF
+    END DO
+  ELSE
+!>jyg
+  DO k = 1, nl
+    DO il = 1, ncum
+      IF (iflag(il)>=3) THEN
+        m(il, k) = 0.
+        sig(il, k) = 0.
+        w0(il, k) = 0.
+      END IF
+    END DO
+  END DO
+  ENDIF ! (ok_convstop)
+!
+  IF (prt_level >= 10) THEN
+   print *,'cv3p2_closure: iflag ',iflag(igout)
+  ENDIF
+!
+
+  ! c 4. Introduce a correcting factor for coef, in order to obtain an
+  ! effective
+  ! c    sigdz larger in the present case (using cv3p2_closure) than in the
+  ! old
+  ! c    closure (using cv3_closure).
+  IF (1==0) THEN
+    DO il = 1, ncum
+      ! c      coef(il) = 2.*coef(il)
+      coef(il) = 5.*coef(il)
+    END DO
+    ! version CVS du ..2008
+  ELSE
+    IF (iflag_cvl_sigd==0) THEN
+      ! test pour verifier qu on fait la meme chose qu avant: sid constant
+      coef(1:ncum) = 1.
+    ELSE
+      coef(1:ncum) = min(2.*coef(1:ncum), 5.)
+      coef(1:ncum) = max(2.*coef(1:ncum), 0.2)
+    END IF
+  END IF
+
+  IF (prt_level>=20) PRINT *, 'cv3p2_closure FIN'
+  RETURN
+END SUBROUTINE cv3p2_closure
+
+
Index: DZ6/trunk/libf/phylmd/cv3p_mixing.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cv3p_mixing.F90	(revision 5267)
+++ 	(revision )
@@ -1,701 +1,0 @@
-SUBROUTINE cv3p_mixing(nloc, ncum, nd, na, ntra, icb, nk, inb, &
-                       ph, t, rr, rs, u, v, tra, h, lv, lf, frac, qta, &
-                       unk, vnk, hp, tv, tvp, ep, clw, sig, &
-                       Ment, Qent, hent, uent, vent, nent, &
-                       Sigij, elij, supmax, Ments, Qents, traent)
-! **************************************************************
-! *
-! CV3P_MIXING : compute mixed draught properties and,         *
-! within a scaling factor, mixed draught        *
-! mass fluxes.                                  *
-! written by  : VTJ Philips,JY Grandpeix, 21/05/2003, 09.14.15*
-! modified by :                                               *
-! **************************************************************
-
-  USE print_control_mod, ONLY: mydebug=>debug , lunout, prt_level
-  USE ioipsl_getin_p_mod, ONLY: getin_p
-  USE add_phys_tend_mod, ONLY: fl_cor_ebil
-
-  IMPLICIT NONE
-
-  include "cvthermo.h"
-  include "cv3param.h"
-  include "YOMCST2.h"
-  include "cvflag.h"
-
-!inputs:
-  INTEGER, INTENT (IN)                               :: ncum, nd, na
-  INTEGER, INTENT (IN)                               :: ntra, nloc
-  INTEGER, DIMENSION (nloc), INTENT (IN)             :: icb, inb, nk
-  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: sig
-  REAL, DIMENSION (nloc), INTENT (IN)                :: unk, vnk
-  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: qta
-  REAL, DIMENSION (nloc, nd+1), INTENT (IN)          :: ph
-  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: t, rr, rs
-  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: u, v
-  REAL, DIMENSION (nloc, nd, ntra), INTENT (IN)      :: tra ! input of convect3
-  REAL, DIMENSION (nloc, na), INTENT (IN)            :: lv
-  REAL, DIMENSION (nloc, na), INTENT (IN)            :: lf
-  REAL, DIMENSION (nloc, na), INTENT (IN)            :: frac !ice fraction in condensate
-  REAL, DIMENSION (nloc, na), INTENT (IN)            :: h  !liquid water static energy of environment
-  REAL, DIMENSION (nloc, na), INTENT (IN)            :: hp !liquid water static energy of air shed from adiab. asc.
-  REAL, DIMENSION (nloc, na), INTENT (IN)            :: tv, tvp
-  REAL, DIMENSION (nloc, na), INTENT (IN)            :: ep, clw
-
-!outputs:
-  REAL, DIMENSION (nloc, na, na), INTENT (OUT)       :: Ment, Qent
-  REAL, DIMENSION (nloc, na, na), INTENT (OUT)       :: uent, vent
-  REAL, DIMENSION (nloc, na, na), INTENT (OUT)       :: Sigij, elij
-  REAL, DIMENSION (nloc, na), INTENT (OUT)           :: supmax           ! Highest mixing fraction of mixed
-                                                                         ! updraughts with the sign of (h-hp)
-  REAL, DIMENSION (nloc, nd, nd, ntra), INTENT (OUT) :: traent
-  REAL, DIMENSION (nloc, nd, nd), INTENT (OUT)       :: Ments, Qents
-  REAL, DIMENSION (nloc, nd, nd), INTENT (OUT)       :: hent
-  INTEGER, DIMENSION (nloc, nd), INTENT (OUT)        :: nent
-
-!local variables:
-  INTEGER i, j, k, il, im, jm
-  INTEGER num1, num2
-  REAL                               :: rti, bf2, anum, denom, dei, altem, cwat, stemp
-  REAL                               :: alt, delp, delm
-  REAL, DIMENSION (nloc)             :: Qmixmax, Rmixmax, sqmrmax
-  REAL, DIMENSION (nloc)             :: Qmixmin, Rmixmin, sqmrmin
-  REAL, DIMENSION (nloc)             :: signhpmh
-  REAL, DIMENSION (nloc)             :: Sx
-  REAL                               :: Scrit2
-  REAL, DIMENSION (nloc)             :: Smid, Sjmin, Sjmax
-  REAL, DIMENSION (nloc)             :: Sbef, sup, smin
-  REAL, DIMENSION (nloc)             :: ASij, ASij_inv, smax, Scrit
-  REAL, DIMENSION (nloc, nd, nd)     :: Sij
-  REAL, DIMENSION (nloc, nd)         :: csum
-  REAL                               :: awat
-  REAL                               :: cpm        !Mixed draught heat capacity
-  REAL                               :: Tm         !Mixed draught temperature
-  LOGICAL, DIMENSION (nloc)          :: lwork
-
-  REAL amxupcrit, df, ff
-  INTEGER nstep
-
-  INTEGER,SAVE                                       :: igout=1
-!$OMP THREADPRIVATE(igout)
-
-! --   Mixing probability distribution functions
-
-  REAL Qcoef1, Qcoef2, QFF, QFFF, Qmix, Rmix, Qmix1, Rmix1, Qmix2, Rmix2, F
-
-  Qcoef1(F) = tanh(F/gammas)
-  Qcoef2(F) = (tanh(F/gammas)+gammas*log(cosh((1.-F)/gammas)/cosh(F/gammas)))
-  QFF(F) = max(min(F,1.), 0.)
-  QFFf(F) = min(QFF(F), scut)
-  Qmix1(F) = (tanh((QFF(F)-Fmax)/gammas)+Qcoef1max)/Qcoef2max
-  Rmix1(F) = (gammas*log(cosh((QFF(F)-Fmax)/gammas))+QFF(F)*Qcoef1max)/Qcoef2max
-  Qmix2(F) = -log(1.-QFFf(F))/scut
-  Rmix2(F) = (QFFf(F)+(1.-QFF(F))*log(1.-QFFf(F)))/scut
-  Qmix(F) = qqa1*Qmix1(F) + qqa2*Qmix2(F)
-  Rmix(F) = qqa1*Rmix1(F) + qqa2*Rmix2(F)
-
-  INTEGER, SAVE :: ifrst
-  DATA ifrst/0/
-!$OMP THREADPRIVATE(ifrst)
-
-
-! =====================================================================
-! --- INITIALIZE VARIOUS ARRAYS USED IN THE COMPUTATIONS
-! =====================================================================
-
-! -- Initialize mixing PDF coefficients
-  IF (ifrst==0) THEN
-    ifrst = 1
-    Qcoef1max = Qcoef1(Fmax)
-    Qcoef2max = Qcoef2(Fmax)
-!<jyg
-   print*, 'fmax, gammas, qqa1, qqa2, Qcoef1max, Qcoef2max ', &
-            fmax, gammas, qqa1, qqa2, Qcoef1max, Qcoef2max
-!>jyg
-!
-  END IF
-
-
-! ori        do 360 i=1,ncum*nlp
-  DO j = 1, nl
-    DO i = 1, ncum
-      nent(i, j) = 0
-! in convect3, m is computed in cv3_closure
-! ori          m(i,1)=0.0
-    END DO
-  END DO
-
-! ori      do 400 k=1,nlp
-! ori       do 390 j=1,nlp
-  DO j = 1, nl
-    DO k = 1, nl
-      DO i = 1, ncum
-        Qent(i, k, j) = rr(i, j)
-        uent(i, k, j) = u(i, j)
-        vent(i, k, j) = v(i, j) 
-        elij(i, k, j) = 0.0
-        hent(i, k, j) = 0.0
-!AC!            Ment(i,k,j)=0.0
-!AC!            Sij(i,k,j)=0.0
-      END DO
-    END DO
-  END DO
-
-!AC!
-  Ment(1:ncum, 1:nd, 1:nd) = 0.0
-  Sij(1:ncum, 1:nd, 1:nd) = 0.0
-!AC!
-!ym
-  Sigij(1:ncum, 1:nd, 1:nd) = 0.0
-!ym 
-
-!jyg!  DO k = 1, ntra
-!jyg!    DO j = 1, nd ! instead nlp
-!jyg!      DO i = 1, nd ! instead nlp
-!jyg!        DO il = 1, ncum
-!jyg!          traent(il, i, j, k) = tra(il, j, k)
-!jyg!        END DO
-!jyg!      END DO
-!jyg!    END DO
-!jyg!  END DO
-
-! =====================================================================
-! --- CALCULATE ENTRAINED AIR MASS FLUX (Ment), TOTAL WATER MIXING
-! --- RATIO (QENT), TOTAL CONDENSED WATER (elij), AND MIXING
-! --- FRACTION (Sij)
-! =====================================================================
-
-  DO i = minorig + 1, nl
-
-    IF (ok_entrain) THEN
-      DO j = minorig, nl
-        DO il = 1, ncum
-          IF ((i>=icb(il)) .AND. (i<=inb(il)) .AND. (j>=(icb(il)-1)) &
-                           .AND. (j<=inb(il))) THEN
-
-!!            rti = qnk(il) - ep(il, i)*clw(il, i)
-            rti = qta(il,i-1) - ep(il, i)*clw(il, i)
-            bf2 = 1. + lv(il, j)*lv(il, j)*rs(il, j)/(rrv*t(il,j)*t(il,j)*cpd)
-!jyg(from aj)<
-            IF (cvflag_ice) THEN
-! print*,cvflag_ice,'cvflag_ice dans do 700'
-              IF (t(il,j)<=263.15) THEN
-                bf2 = 1. + (lf(il,j)+lv(il,j))*(lv(il,j)+frac(il,j)* &
-                     lf(il,j))*rs(il, j)/(rrv*t(il,j)*t(il,j)*cpd)
-              END IF
-            END IF
-!>jyg
-            anum = h(il, j) - hp(il, i) + (cpv-cpd)*t(il, j)*(rti-rr(il,j))
-            denom = h(il, i) - hp(il, i) + (cpd-cpv)*(rr(il,i)-rti)*t(il, j)
-            dei = denom
-            IF (abs(dei)<0.01) dei = 0.01
-            Sij(il, i, j) = anum/dei
-            Sij(il, i, i) = 1.0
-            altem = Sij(il, i, j)*rr(il, i) + (1.-Sij(il,i,j))*rti - rs(il, j)
-            altem = altem/bf2
-            cwat = clw(il, j)*(1.-ep(il,j))
-            stemp = Sij(il, i, j)
-            IF ((stemp<0.0 .OR. stemp>1.0 .OR. altem>cwat) .AND. j>i) THEN
-!jyg(from aj)<
-              IF (cvflag_ice) THEN
-                anum = anum - (lv(il,j)+frac(il,j)*lf(il,j))*(rti-rs(il,j)-cwat*bf2)
-                denom = denom + (lv(il,j)+frac(il,j)*lf(il,j))*(rr(il,i)-rti)
-              ELSE
-                anum = anum - lv(il, j)*(rti-rs(il,j)-cwat*bf2)
-                denom = denom + lv(il, j)*(rr(il,i)-rti)
-              END IF
-!>jyg
-              IF (abs(denom)<0.01) denom = 0.01
-              Sij(il, i, j) = anum/denom
-              altem = Sij(il, i, j)*rr(il, i) + (1.-Sij(il,i,j))*rti - rs(il, j)
-              altem = altem - (bf2-1.)*cwat
-            END IF
-            IF (Sij(il,i,j)>0.0) THEN
-!!!                 Ment(il,i,j)=m(il,i)
-              Ment(il, i, j) = 1.
-              elij(il, i, j) = altem
-              elij(il, i, j) = amax1(0.0, elij(il,i,j))
-              nent(il, i) = nent(il, i) + 1
-            END IF
-
-            Sij(il, i, j) = amax1(0.0, Sij(il,i,j))
-            Sij(il, i, j) = amin1(1.0, Sij(il,i,j))
-          ELSE IF (j > i) THEN
-            IF (prt_level >= 10) THEN
-              print *,'cv3p_mixing i, j, Sij given by the no-precip eq. ', i, j, Sij(il,i,j)
-            ENDIF
-          END IF ! new
-        END DO
-      END DO
-    ELSE  ! (ok_entrain)
-      DO il = 1,ncum
-        nent(il,i) = 0
-      ENDDO
-    ENDIF ! (ok_entrain)
-
-!jygdebug<
-    IF (prt_level >= 10) THEN
-      print *,'cv3p_mixing i, nent(i), icb, inb ',i, nent(igout,i), icb(igout), inb(igout)
-      IF (nent(igout,i) .gt. 0) THEN
-        print *,'i,(j,Sij(i,j),j=icb-1,inb) ',i,(j,Sij(igout,i,j),j=icb(igout)-1,inb(igout))
-      ENDIF
-    ENDIF
-!>jygdebug
-
-! ***   if no air can entrain at level i assume that updraft detrains  ***
-! ***   at that level and calculate detrained air flux and properties  ***
-
-
-! @      do 170 i=icb(il),inb(il)
-
-    DO il = 1, ncum
-      IF ((i>=icb(il)) .AND. (i<=inb(il)) .AND. (nent(il,i)==0)) THEN
-! @      if(nent(il,i).eq.0)then
-!!!       Ment(il,i,i)=m(il,i)
-        Ment(il, i, i) = 1.
-!!        Qent(il, i, i) = qnk(il) - ep(il, i)*clw(il, i)
-        Qent(il, i, i) = qta(il,i-1) - ep(il, i)*clw(il, i)
-        uent(il, i, i) = unk(il)
-        vent(il, i, i) = vnk(il)
-        IF (fl_cor_ebil .GE. 2) THEN
-          hent(il, i, i) = hp(il,i)
-        ENDIF
-        elij(il, i, i) = clw(il, i)*(1.-ep(il,i))
-        Sij(il, i, i) = 0.0
-      END IF
-    END DO
-  END DO ! i = minorig + 1, nl
-
-!jyg!  DO j = 1, ntra
-!jyg!    DO i = minorig + 1, nl
-!jyg!      DO il = 1, ncum
-!jyg!        IF (i>=icb(il) .AND. i<=inb(il) .AND. nent(il,i)==0) THEN
-!jyg!          traent(il, i, i, j) = tra(il, nk(il), j)
-!jyg!        END IF
-!jyg!      END DO
-!jyg!    END DO
-!jyg!  END DO
-
-  DO j = minorig, nl
-    DO i = minorig, nl
-      DO il = 1, ncum
-        IF ((j>=(icb(il)-1)) .AND. (j<=inb(il)) .AND. &
-            (i>=icb(il)) .AND. (i<=inb(il))) THEN
-          Sigij(il, i, j) = Sij(il, i, j)
-        END IF
-      END DO
-    END DO
-  END DO
-! @      enddo
-
-! @170   continue
-
-! =====================================================================
-! ---  NORMALIZE ENTRAINED AIR MASS FLUXES
-! ---  TO REPRESENT EQUAL PROBABILITIES OF MIXING
-! =====================================================================
-
-  CALL zilch(csum, nloc*nd)
-
-  DO il = 1, ncum
-    lwork(il) = .FALSE.
-  END DO
-
-! ---------------------------------------------------------------
-  DO i = minorig + 1, nl      !Loop on origin level "i"
-! ---------------------------------------------------------------
-
-    num1 = 0
-    DO il = 1, ncum
-      IF (i>=icb(il) .AND. i<=inb(il)) num1 = num1 + 1
-    END DO
-    IF (num1<=0) GO TO 789
-
-
-!JYG1    Find maximum of SIJ for J>I, if any.
-
-    Sx(:) = 0.
-
-    DO il = 1, ncum
-      IF (i>=icb(il) .AND. i<=inb(il)) THEN
-        signhpmh(il) = sign(1., hp(il,i)-h(il,i))
-        Sbef(il) = max(0., signhpmh(il))
-      END IF
-    END DO
-
-    DO j = i + 1, nl
-      DO il = 1, ncum
-        IF (i>=icb(il) .AND. i<=inb(il) .AND. j<=inb(il)) THEN
-          IF (Sbef(il)<Sij(il,i,j)) THEN
-            Sx(il) = max(Sij(il,i,j), Sx(il))
-          END IF
-          Sbef(il) = Sij(il, i, j)
-        END IF
-      END DO
-    END DO
-
-
-    DO il = 1, ncum
-      IF (i>=icb(il) .AND. i<=inb(il)) THEN
-        lwork(il) = (nent(il,i)/=0)
-!!        rti = qnk(il) - ep(il, i)*clw(il, i)
-        rti = qta(il,i-1) - ep(il, i)*clw(il, i)
-!jyg<
-        IF (cvflag_ice) THEN
-
-          anum = h(il, i) - hp(il, i) - (lv(il,i)+frac(il,i)*lf(il,i))* &
-                       (rti-rs(il,i)) + (cpv-cpd)*t(il, i)*(rti-rr(il,i))
-          denom = h(il, i) - hp(il, i) + (lv(il,i)+frac(il,i)*lf(il,i))* &
-                       (rr(il,i)-rti) + (cpd-cpv)*t(il, i)*(rr(il,i)-rti)
-        ELSE
-
-          anum = h(il, i) - hp(il, i) - lv(il, i)*(rti-rs(il,i)) + &
-                       (cpv-cpd)*t(il, i)*(rti-rr(il,i))
-          denom = h(il, i) - hp(il, i) + lv(il, i)*(rr(il,i)-rti) + &
-                       (cpd-cpv)*t(il, i)*(rr(il,i)-rti)
-        END IF
-!>jyg
-        IF (abs(denom)<0.01) denom = 0.01
-        Scrit(il) = min(anum/denom, 1.)
-        alt = rti - rs(il, i) + Scrit(il)*(rr(il,i)-rti)
-
-!JYG1    Find new critical value Scrit2
-!         such that : Sij > Scrit2  => mixed draught will detrain at J<I
-!                     Sij < Scrit2  => mixed draught will detrain at J>I
-
-        Scrit2 = min(Scrit(il), Sx(il))*max(0., -signhpmh(il)) + &
-                 Scrit(il)*max(0., signhpmh(il))
-
-        Scrit(il) = Scrit2
-
-!JYG    Correction pour la nouvelle logique; la correction pour ALT
-! est un peu au hazard
-        IF (Scrit(il)<=0.0) Scrit(il) = 0.0
-        IF (alt<=0.0) Scrit(il) = 1.0
-
-        smax(il) = 0.0
-        ASij(il) = 0.0
-        sup(il) = 0.      ! upper S-value reached by descending draughts
-      END IF
-    END DO
-
-! ---------------------------------------------------------------
-    DO j = minorig, nl         !Loop on destination level "j"
-! ---------------------------------------------------------------
-
-      num2 = 0
-      DO il = 1, ncum
-        IF (i>=icb(il) .AND. i<=inb(il) .AND. &
-            j>=(icb(il)-1) .AND. j<=inb(il) .AND. &
-            lwork(il)) num2 = num2 + 1
-      END DO
-      IF (num2<=0) GO TO 175
-
-! -----------------------------------------------
-      IF (j>i) THEN
-! -----------------------------------------------
-        DO il = 1, ncum
-          IF (i>=icb(il) .AND. i<=inb(il) .AND. &
-              j>=(icb(il)-1) .AND. j<=inb(il) .AND. &
-              lwork(il)) THEN
-            IF (Sij(il,i,j)>0.0) THEN
-              Smid(il) = min(Sij(il,i,j), Scrit(il))
-              Sjmax(il) = Smid(il)
-              Sjmin(il) = Smid(il)
-              IF (Smid(il)<smin(il) .AND. Sij(il,i,j+1)<Smid(il)) THEN
-                smin(il) = Smid(il)
-                Sjmax(il) = min((Sij(il,i,j+1)+Sij(il,i,j))/2., Sij(il,i,j), Scrit(il))
-                Sjmin(il) = max((Sbef(il)+Sij(il,i,j))/2., Sij(il,i,j))
-                Sjmin(il) = min(Sjmin(il), Scrit(il))
-                Sbef(il) = Sij(il, i, j)
-              END IF
-            END IF
-          END IF
-        END DO
-! -----------------------------------------------
-      ELSE IF (j==i) THEN
-! -----------------------------------------------
-        DO il = 1, ncum
-          IF (i>=icb(il) .AND. i<=inb(il) .AND. &
-              j>=(icb(il)-1) .AND. j<=inb(il) .AND. &
-              lwork(il)) THEN
-            IF (Sij(il,i,j)>0.0) THEN
-              Smid(il) = 1.
-              Sjmin(il) = max((Sij(il,i,j-1)+Smid(il))/2., Scrit(il))*max(0., -signhpmh(il)) + &
-                          min((Sij(il,i,j+1)+Smid(il))/2., Scrit(il))*max(0., signhpmh(il))
-              Sjmin(il) = max(Sjmin(il), sup(il))
-              Sjmax(il) = 1.
-
-! -             preparation des variables Scrit, Smin et Sbef pour la partie j>i
-              Scrit(il) = min(Sjmin(il), Sjmax(il), Scrit(il))
-
-              smin(il) = 1.
-              Sbef(il) = max(0., signhpmh(il))
-              supmax(il, i) = sign(Scrit(il), -signhpmh(il))
-            END IF
-          END IF
-        END DO
-! -----------------------------------------------
-      ELSE IF (j<i) THEN
-! -----------------------------------------------
-        DO il = 1, ncum
-          IF (i>=icb(il) .AND. i<=inb(il) .AND. &
-              j>=(icb(il)-1) .AND. j<=inb(il) .AND. &
-              lwork(il)) THEN
-            IF (Sij(il,i,j)>0.0) THEN
-              Smid(il) = max(Sij(il,i,j), Scrit(il))
-              Sjmax(il) = Smid(il)
-              Sjmin(il) = Smid(il)
-              IF (Smid(il)>smax(il) .AND. Sij(il,i,j+1)>Smid(il)) THEN
-                smax(il) = Smid(il)
-                Sjmax(il) = max((Sij(il,i,j+1)+Sij(il,i,j))/2., Sij(il,i,j))
-                Sjmax(il) = max(Sjmax(il), Scrit(il))
-                Sjmin(il) = min((Sbef(il)+Sij(il,i,j))/2., Sij(il,i,j))
-                Sjmin(il) = max(Sjmin(il), Scrit(il))
-                Sbef(il) = Sij(il, i, j)
-              END IF
-              IF (abs(Sjmin(il)-Sjmax(il))>1.E-10) &
-                             sup(il) = max(Sjmin(il), Sjmax(il), sup(il))
-            END IF
-          END IF
-        END DO
-! -----------------------------------------------
-      END IF
-! -----------------------------------------------
-
-
-      DO il = 1, ncum
-        IF (i>=icb(il) .AND. i<=inb(il) .AND. &
-            j>=(icb(il)-1) .AND. j<=inb(il) .AND. &
-            lwork(il)) THEN
-          IF (Sij(il,i,j)>0.0) THEN
-!!            rti = qnk(il) - ep(il, i)*clw(il, i)
-            rti = qta(il,i-1) - ep(il, i)*clw(il, i)
-            Qmixmax(il) = Qmix(Sjmax(il))
-            Qmixmin(il) = Qmix(Sjmin(il))
-            Rmixmax(il) = Rmix(Sjmax(il))
-            Rmixmin(il) = Rmix(Sjmin(il))
-            sqmrmax(il) = Sjmax(il)*Qmix(Sjmax(il)) - Rmix(Sjmax(il))
-            sqmrmin(il) = Sjmin(il)*Qmix(Sjmin(il)) - Rmix(Sjmin(il))
-
-            Ment(il, i, j) = abs(Qmixmax(il)-Qmixmin(il))*Ment(il, i, j)
-
-! Sigij(i,j) is the 'true' mixing fraction of mixture Ment(i,j)
-            IF (abs(Qmixmax(il)-Qmixmin(il))>1.E-10) THEN
-              Sigij(il, i, j) = (sqmrmax(il)-sqmrmin(il))/(Qmixmax(il)-Qmixmin(il))
-            ELSE
-              Sigij(il, i, j) = 0.
-            END IF
-
-! --    Compute Qent, uent, vent according to the true mixing fraction
-            Qent(il, i, j) = (1.-Sigij(il,i,j))*rti     + Sigij(il, i, j)*rr(il, i)
-            uent(il, i, j) = (1.-Sigij(il,i,j))*unk(il) + Sigij(il, i, j)*u(il, i)
-            vent(il, i, j) = (1.-Sigij(il,i,j))*vnk(il) + Sigij(il, i, j)*v(il, i)
-
-! --     Compute liquid water static energy of mixed draughts
-!    IF (j .GT. i) THEN
-!      awat=elij(il,i,j)-(1.-ep(il,j))*clw(il,j)
-!      awat=amax1(awat,0.0)
-!    ELSE
-!      awat = 0.
-!    ENDIF
-!    Hent(il,i,j) = (1.-Sigij(il,i,j))*HP(il,i)
-!    :         + Sigij(il,i,j)*H(il,i)
-!    :         + (LV(il,j)+(cpd-cpv)*t(il,j))*awat
-!IM 301008 beg
-            hent(il, i, j) = (1.-Sigij(il,i,j))*hp(il, i) + Sigij(il, i, j)*h(il, i)
-
-!jyg<
-!            elij(il, i, j) = Qent(il, i, j) - rs(il, j)
-!            elij(il, i, j) = elij(il, i, j) + &
-!                             ((h(il,j)-hent(il,i,j))*rs(il,j)*lv(il,j) / &
-!                              ((cpd*(1.-Qent(il,i,j))+Qent(il,i,j)*cpv)*rrv*t(il,j)*t(il,j)))
-!            elij(il, i, j) = elij(il, i, j) / &
-!                             (1.+lv(il,j)*lv(il,j)*rs(il,j) / &
-!                              ((cpd*(1.-Qent(il,i,j))+Qent(il,i,j)*cpv)*rrv*t(il,j)*t(il,j)))
-!
-!       Computation of condensate amount Elij, taking into account the ice fraction frac
-!       Warning : the same saturation humidity rs is used over both liquid water and ice; this
-!                 should be corrected.
-!
-!  Heat capacity of mixed draught
-    cpm = cpd+Qent(il,i,j)*(cpv-cpd)
-!
-    IF (cvflag_ice .and. frac(il,j) .gt. 0.) THEN
-            elij(il, i, j) = Qent(il, i, j) - rs(il, j)
-            elij(il, i, j) = elij(il, i, j) + &
-                             (h(il,j)-hent(il,i,j)+(cpv-cpd)*(Qent(il,i,j)-rr(il,j))*t(il,j))* &
-                             rs(il,j)*lv(il,j) / (cpm*rrv*t(il,j)*t(il,j))
-            elij(il, i, j) = elij(il, i, j) / &
-                             (1.+(lv(il,j)+frac(il,j)*lf(il,j))*lv(il,j)*rs(il,j) / &
-                              (cpm*rrv*t(il,j)*t(il,j)))
-    ELSE
-            elij(il, i, j) = Qent(il, i, j) - rs(il, j)
-            elij(il, i, j) = elij(il, i, j) + &
-                             (h(il,j)-hent(il,i,j)+(cpv-cpd)*(Qent(il,i,j)-rr(il,j))*t(il,j))* &
-                             rs(il,j)*lv(il,j) / (cpm*rrv*t(il,j)*t(il,j))
-            elij(il, i, j) = elij(il, i, j) / &
-                             (1.+lv(il,j)*lv(il,j)*rs(il,j) / &
-                              (cpm*rrv*t(il,j)*t(il,j)))
-    ENDIF
-!>jyg
-            elij(il, i, j) = max(elij(il,i,j), 0.)
-
-            elij(il, i, j) = min(elij(il,i,j), Qent(il,i,j))
-
-            IF (j>i) THEN
-              awat = elij(il, i, j) - (1.-ep(il,j))*clw(il, j)
-              awat = amax1(awat, 0.0)
-            ELSE
-              awat = 0.
-            END IF
-
-! print *,h(il,j)-hent(il,i,j),LV(il,j)*rs(il,j)/(cpd*rrv*t(il,j)*
-! :         t(il,j))
-
-!jyg<
-!            hent(il, i, j) = hent(il, i, j) + (lv(il,j)+(cpd-cpv)*t(il,j))*awat
-! Mixed draught temperature at level j
-    IF (cvflag_ice .and. frac(il,j) .gt. 0.) THEN
-          Tm = t(il,j) + (Qent(il,i,j)-elij(il,i,j)-rs(il,j))*rrv*t(il,j)*t(il,j)/(lv(il,j)*rs(il,j))
-          hent(il, i, j) = hent(il, i, j) + (lv(il,j)+frac(il,j)*lf(il,j)+(cpd-cpv)*Tm)*awat
-    ELSE
-          Tm = t(il,j) + (Qent(il,i,j)-elij(il,i,j)-rs(il,j))*rrv*t(il,j)*t(il,j)/(lv(il,j)*rs(il,j))
-          hent(il, i, j) = hent(il, i, j) + (lv(il,j)+(cpd-cpv)*Tm)*awat
-    ENDIF
-!>jyg
-
-!IM 301008 end
-
-! print *,'mix : i,j,hent(il,i,j),Sigij(il,i,j) ',
-! :               i,j,hent(il,i,j),Sigij(il,i,j)
-
-! --      ASij is the integral of P(F) over the relevant F interval
-            ASij(il) = ASij(il) + abs(Qmixmax(il)*(1.-Sjmax(il))+Rmixmax(il) - &
-                                      Qmixmin(il)*(1.-Sjmin(il))-Rmixmin(il))
-
-          END IF
-        END IF
-      END DO
-!jyg!      DO k = 1, ntra
-!jyg!        DO il = 1, ncum
-!jyg!          IF ((i>=icb(il)) .AND. (i<=inb(il)) .AND. &
-!jyg!              (j>=(icb(il)-1)) .AND. (j<=inb(il)) .AND. &
-!jyg!              lwork(il)) THEN
-!jyg!            IF (Sij(il,i,j)>0.0) THEN
-!jyg!              traent(il, i, j, k) = Sigij(il, i, j)*tra(il, i, k) + &
-!jyg!                                    (1.-Sigij(il,i,j))*tra(il, nk(il), k)
-!jyg!            END IF
-!jyg!          END IF
-!jyg!        END DO
-!jyg!      END DO
-
-! --    If I=J (detrainement and entrainement at the same level), then only the
-! --    adiabatic ascent part of the mixture is considered
-      IF (i==j) THEN
-        DO il = 1, ncum
-          IF (i>=icb(il) .AND. i<=inb(il) .AND. &
-              j>=(icb(il)-1) .AND. j<=inb(il) .AND. &
-              lwork(il)) THEN
-            IF (Sij(il,i,j)>0.0) THEN
-!!              rti = qnk(il) - ep(il, i)*clw(il, i)
-              rti = qta(il,i-1) - ep(il, i)*clw(il, i)
-!!!             Ment(il,i,i) = m(il,i)*abs(Qmixmax(il)*(1.-Sjmax(il))
-              Ment(il, i, i) = abs(Qmixmax(il)*(1.-Sjmax(il))+Rmixmax(il) - &
-                                   Qmixmin(il)*(1.-Sjmin(il))-Rmixmin(il))
-              Qent(il, i, i) = rti
-              uent(il, i, i) = unk(il)
-              vent(il, i, i) = vnk(il)
-              hent(il, i, i) = hp(il, i)
-              elij(il, i, i) = clw(il, i)*(1.-ep(il,i))
-              Sigij(il, i, i) = 0.
-            END IF
-          END IF
-        END DO
-!jyg!        DO k = 1, ntra
-!jyg!          DO il = 1, ncum
-!jyg!            IF ((i>=icb(il)) .AND. (i<=inb(il)) .AND. &
-!jyg!                (j>=(icb(il)-1)) .AND. (j<=inb(il)) .AND. &
-!jyg!                lwork(il)) THEN
-!jyg!              IF (Sij(il,i,j)>0.0) THEN
-!jyg!                traent(il, i, i, k) = tra(il, nk(il), k)
-!jyg!              END IF
-!jyg!            END IF
-!jyg!          END DO
-!jyg!        END DO
-
-      END IF
-
-! ---------------------------------------------------------------
-175 END DO        ! End loop on destination level "j"
-! ---------------------------------------------------------------
-
-    DO il = 1, ncum
-      IF (i>=icb(il) .AND. i<=inb(il) .AND. lwork(il)) THEN
-        ASij(il) = amax1(1.0E-16, ASij(il))
-!jyg+lluis<
-!!        ASij(il) = 1.0/ASij(il)
-        ASij_inv(il) = 1.0/ASij(il)
-!   IF the F-interval spanned by possible mixtures is less than 0.01, no mixing occurs
-        IF (ASij_inv(il) > 100.)  ASij_inv(il) = 0.
-!>jyg+lluis
-        csum(il, i) = 0.0
-      END IF
-    END DO
-
-    DO j = minorig, nl
-      DO il = 1, ncum
-        IF (i>=icb(il) .AND. i<=inb(il) .AND. lwork(il) .AND. &
-            j>=(icb(il)-1) .AND. j<=inb(il)) THEN
-!jyg          Ment(il, i, j) = Ment(il, i, j)*ASij(il)
-          Ment(il, i, j) = Ment(il, i, j)*ASij_inv(il)
-        END IF
-      END DO
-    END DO
-
-    DO j = minorig, nl
-      DO il = 1, ncum
-        IF (i>=icb(il) .AND. i<=inb(il) .AND. lwork(il) .AND. &
-            j>=(icb(il)-1) .AND. j<=inb(il)) THEN
-          csum(il, i) = csum(il, i) + Ment(il, i, j)
-        END IF
-      END DO
-    END DO
-
-    DO il = 1, ncum
-      IF (i>=icb(il) .AND. i<=inb(il) .AND. lwork(il) .AND. csum(il,i)<1.) THEN
-! cc     :     .and. csum(il,i).lt.m(il,i) ) then
-        nent(il, i) = 0
-! cc        Ment(il,i,i)=m(il,i)
-        Ment(il, i, i) = 1.
-!!        Qent(il, i, i) = qnk(il) - ep(il, i)*clw(il, i)
-        Qent(il, i, i) = qta(il,i-1) - ep(il, i)*clw(il, i)
-        uent(il, i, i) = unk(il)
-        vent(il, i, i) = vnk(il)
-        elij(il, i, i) = clw(il, i)*(1.-ep(il,i))
-        IF (fl_cor_ebil .GE. 2) THEN
-          hent(il, i, i) = hp(il,i)
-          Sigij(il, i, i) = 0.0
-        ELSE
-          Sij(il, i, i) = 0.0
-        ENDIF
-      END IF
-    END DO ! il
-
-!jyg!    DO j = 1, ntra
-!jyg!      DO il = 1, ncum
-!jyg!        IF (i>=icb(il) .AND. i<=inb(il) .AND. lwork(il) .AND. csum(il,i)<1.) THEN
-!jyg!! cc     :     .and. csum(il,i).lt.m(il,i) ) then
-!jyg!          traent(il, i, i, j) = tra(il, nk(il), j)
-!jyg!        END IF
-!jyg!      END DO
-!jyg!    END DO
-
-! ---------------------------------------------------------------
-789 END DO              ! End loop on origin level "i"
-! ---------------------------------------------------------------
-
-
-  RETURN
-END SUBROUTINE cv3p_mixing
-
Index: /LMDZ6/trunk/libf/phylmd/cv3p_mixing.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cv3p_mixing.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/cv3p_mixing.f90	(revision 5268)
@@ -0,0 +1,701 @@
+SUBROUTINE cv3p_mixing(nloc, ncum, nd, na, ntra, icb, nk, inb, &
+                       ph, t, rr, rs, u, v, tra, h, lv, lf, frac, qta, &
+                       unk, vnk, hp, tv, tvp, ep, clw, sig, &
+                       Ment, Qent, hent, uent, vent, nent, &
+                       Sigij, elij, supmax, Ments, Qents, traent)
+! **************************************************************
+! *
+! CV3P_MIXING : compute mixed draught properties and,         *
+! within a scaling factor, mixed draught        *
+! mass fluxes.                                  *
+! written by  : VTJ Philips,JY Grandpeix, 21/05/2003, 09.14.15*
+! modified by :                                               *
+! **************************************************************
+
+  USE print_control_mod, ONLY: mydebug=>debug , lunout, prt_level
+  USE ioipsl_getin_p_mod, ONLY: getin_p
+  USE add_phys_tend_mod, ONLY: fl_cor_ebil
+
+  IMPLICIT NONE
+
+  include "cvthermo.h"
+  include "cv3param.h"
+  include "YOMCST2.h"
+  include "cvflag.h"
+
+!inputs:
+  INTEGER, INTENT (IN)                               :: ncum, nd, na
+  INTEGER, INTENT (IN)                               :: ntra, nloc
+  INTEGER, DIMENSION (nloc), INTENT (IN)             :: icb, inb, nk
+  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: sig
+  REAL, DIMENSION (nloc), INTENT (IN)                :: unk, vnk
+  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: qta
+  REAL, DIMENSION (nloc, nd+1), INTENT (IN)          :: ph
+  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: t, rr, rs
+  REAL, DIMENSION (nloc, nd), INTENT (IN)            :: u, v
+  REAL, DIMENSION (nloc, nd, ntra), INTENT (IN)      :: tra ! input of convect3
+  REAL, DIMENSION (nloc, na), INTENT (IN)            :: lv
+  REAL, DIMENSION (nloc, na), INTENT (IN)            :: lf
+  REAL, DIMENSION (nloc, na), INTENT (IN)            :: frac !ice fraction in condensate
+  REAL, DIMENSION (nloc, na), INTENT (IN)            :: h  !liquid water static energy of environment
+  REAL, DIMENSION (nloc, na), INTENT (IN)            :: hp !liquid water static energy of air shed from adiab. asc.
+  REAL, DIMENSION (nloc, na), INTENT (IN)            :: tv, tvp
+  REAL, DIMENSION (nloc, na), INTENT (IN)            :: ep, clw
+
+!outputs:
+  REAL, DIMENSION (nloc, na, na), INTENT (OUT)       :: Ment, Qent
+  REAL, DIMENSION (nloc, na, na), INTENT (OUT)       :: uent, vent
+  REAL, DIMENSION (nloc, na, na), INTENT (OUT)       :: Sigij, elij
+  REAL, DIMENSION (nloc, na), INTENT (OUT)           :: supmax           ! Highest mixing fraction of mixed
+                                                                         ! updraughts with the sign of (h-hp)
+  REAL, DIMENSION (nloc, nd, nd, ntra), INTENT (OUT) :: traent
+  REAL, DIMENSION (nloc, nd, nd), INTENT (OUT)       :: Ments, Qents
+  REAL, DIMENSION (nloc, nd, nd), INTENT (OUT)       :: hent
+  INTEGER, DIMENSION (nloc, nd), INTENT (OUT)        :: nent
+
+!local variables:
+  INTEGER i, j, k, il, im, jm
+  INTEGER num1, num2
+  REAL                               :: rti, bf2, anum, denom, dei, altem, cwat, stemp
+  REAL                               :: alt, delp, delm
+  REAL, DIMENSION (nloc)             :: Qmixmax, Rmixmax, sqmrmax
+  REAL, DIMENSION (nloc)             :: Qmixmin, Rmixmin, sqmrmin
+  REAL, DIMENSION (nloc)             :: signhpmh
+  REAL, DIMENSION (nloc)             :: Sx
+  REAL                               :: Scrit2
+  REAL, DIMENSION (nloc)             :: Smid, Sjmin, Sjmax
+  REAL, DIMENSION (nloc)             :: Sbef, sup, smin
+  REAL, DIMENSION (nloc)             :: ASij, ASij_inv, smax, Scrit
+  REAL, DIMENSION (nloc, nd, nd)     :: Sij
+  REAL, DIMENSION (nloc, nd)         :: csum
+  REAL                               :: awat
+  REAL                               :: cpm        !Mixed draught heat capacity
+  REAL                               :: Tm         !Mixed draught temperature
+  LOGICAL, DIMENSION (nloc)          :: lwork
+
+  REAL amxupcrit, df, ff
+  INTEGER nstep
+
+  INTEGER,SAVE                                       :: igout=1
+!$OMP THREADPRIVATE(igout)
+
+! --   Mixing probability distribution functions
+
+  REAL Qcoef1, Qcoef2, QFF, QFFF, Qmix, Rmix, Qmix1, Rmix1, Qmix2, Rmix2, F
+
+  Qcoef1(F) = tanh(F/gammas)
+  Qcoef2(F) = (tanh(F/gammas)+gammas*log(cosh((1.-F)/gammas)/cosh(F/gammas)))
+  QFF(F) = max(min(F,1.), 0.)
+  QFFf(F) = min(QFF(F), scut)
+  Qmix1(F) = (tanh((QFF(F)-Fmax)/gammas)+Qcoef1max)/Qcoef2max
+  Rmix1(F) = (gammas*log(cosh((QFF(F)-Fmax)/gammas))+QFF(F)*Qcoef1max)/Qcoef2max
+  Qmix2(F) = -log(1.-QFFf(F))/scut
+  Rmix2(F) = (QFFf(F)+(1.-QFF(F))*log(1.-QFFf(F)))/scut
+  Qmix(F) = qqa1*Qmix1(F) + qqa2*Qmix2(F)
+  Rmix(F) = qqa1*Rmix1(F) + qqa2*Rmix2(F)
+
+  INTEGER, SAVE :: ifrst
+  DATA ifrst/0/
+!$OMP THREADPRIVATE(ifrst)
+
+
+! =====================================================================
+! --- INITIALIZE VARIOUS ARRAYS USED IN THE COMPUTATIONS
+! =====================================================================
+
+! -- Initialize mixing PDF coefficients
+  IF (ifrst==0) THEN
+    ifrst = 1
+    Qcoef1max = Qcoef1(Fmax)
+    Qcoef2max = Qcoef2(Fmax)
+!<jyg
+   print*, 'fmax, gammas, qqa1, qqa2, Qcoef1max, Qcoef2max ', &
+            fmax, gammas, qqa1, qqa2, Qcoef1max, Qcoef2max
+!>jyg
+!
+  END IF
+
+
+! ori        do 360 i=1,ncum*nlp
+  DO j = 1, nl
+    DO i = 1, ncum
+      nent(i, j) = 0
+! in convect3, m is computed in cv3_closure
+! ori          m(i,1)=0.0
+    END DO
+  END DO
+
+! ori      do 400 k=1,nlp
+! ori       do 390 j=1,nlp
+  DO j = 1, nl
+    DO k = 1, nl
+      DO i = 1, ncum
+        Qent(i, k, j) = rr(i, j)
+        uent(i, k, j) = u(i, j)
+        vent(i, k, j) = v(i, j) 
+        elij(i, k, j) = 0.0
+        hent(i, k, j) = 0.0
+!AC!            Ment(i,k,j)=0.0
+!AC!            Sij(i,k,j)=0.0
+      END DO
+    END DO
+  END DO
+
+!AC!
+  Ment(1:ncum, 1:nd, 1:nd) = 0.0
+  Sij(1:ncum, 1:nd, 1:nd) = 0.0
+!AC!
+!ym
+  Sigij(1:ncum, 1:nd, 1:nd) = 0.0
+!ym 
+
+!jyg!  DO k = 1, ntra
+!jyg!    DO j = 1, nd ! instead nlp
+!jyg!      DO i = 1, nd ! instead nlp
+!jyg!        DO il = 1, ncum
+!jyg!          traent(il, i, j, k) = tra(il, j, k)
+!jyg!        END DO
+!jyg!      END DO
+!jyg!    END DO
+!jyg!  END DO
+
+! =====================================================================
+! --- CALCULATE ENTRAINED AIR MASS FLUX (Ment), TOTAL WATER MIXING
+! --- RATIO (QENT), TOTAL CONDENSED WATER (elij), AND MIXING
+! --- FRACTION (Sij)
+! =====================================================================
+
+  DO i = minorig + 1, nl
+
+    IF (ok_entrain) THEN
+      DO j = minorig, nl
+        DO il = 1, ncum
+          IF ((i>=icb(il)) .AND. (i<=inb(il)) .AND. (j>=(icb(il)-1)) &
+                           .AND. (j<=inb(il))) THEN
+
+!!            rti = qnk(il) - ep(il, i)*clw(il, i)
+            rti = qta(il,i-1) - ep(il, i)*clw(il, i)
+            bf2 = 1. + lv(il, j)*lv(il, j)*rs(il, j)/(rrv*t(il,j)*t(il,j)*cpd)
+!jyg(from aj)<
+            IF (cvflag_ice) THEN
+! print*,cvflag_ice,'cvflag_ice dans do 700'
+              IF (t(il,j)<=263.15) THEN
+                bf2 = 1. + (lf(il,j)+lv(il,j))*(lv(il,j)+frac(il,j)* &
+                     lf(il,j))*rs(il, j)/(rrv*t(il,j)*t(il,j)*cpd)
+              END IF
+            END IF
+!>jyg
+            anum = h(il, j) - hp(il, i) + (cpv-cpd)*t(il, j)*(rti-rr(il,j))
+            denom = h(il, i) - hp(il, i) + (cpd-cpv)*(rr(il,i)-rti)*t(il, j)
+            dei = denom
+            IF (abs(dei)<0.01) dei = 0.01
+            Sij(il, i, j) = anum/dei
+            Sij(il, i, i) = 1.0
+            altem = Sij(il, i, j)*rr(il, i) + (1.-Sij(il,i,j))*rti - rs(il, j)
+            altem = altem/bf2
+            cwat = clw(il, j)*(1.-ep(il,j))
+            stemp = Sij(il, i, j)
+            IF ((stemp<0.0 .OR. stemp>1.0 .OR. altem>cwat) .AND. j>i) THEN
+!jyg(from aj)<
+              IF (cvflag_ice) THEN
+                anum = anum - (lv(il,j)+frac(il,j)*lf(il,j))*(rti-rs(il,j)-cwat*bf2)
+                denom = denom + (lv(il,j)+frac(il,j)*lf(il,j))*(rr(il,i)-rti)
+              ELSE
+                anum = anum - lv(il, j)*(rti-rs(il,j)-cwat*bf2)
+                denom = denom + lv(il, j)*(rr(il,i)-rti)
+              END IF
+!>jyg
+              IF (abs(denom)<0.01) denom = 0.01
+              Sij(il, i, j) = anum/denom
+              altem = Sij(il, i, j)*rr(il, i) + (1.-Sij(il,i,j))*rti - rs(il, j)
+              altem = altem - (bf2-1.)*cwat
+            END IF
+            IF (Sij(il,i,j)>0.0) THEN
+!!!                 Ment(il,i,j)=m(il,i)
+              Ment(il, i, j) = 1.
+              elij(il, i, j) = altem
+              elij(il, i, j) = amax1(0.0, elij(il,i,j))
+              nent(il, i) = nent(il, i) + 1
+            END IF
+
+            Sij(il, i, j) = amax1(0.0, Sij(il,i,j))
+            Sij(il, i, j) = amin1(1.0, Sij(il,i,j))
+          ELSE IF (j > i) THEN
+            IF (prt_level >= 10) THEN
+              print *,'cv3p_mixing i, j, Sij given by the no-precip eq. ', i, j, Sij(il,i,j)
+            ENDIF
+          END IF ! new
+        END DO
+      END DO
+    ELSE  ! (ok_entrain)
+      DO il = 1,ncum
+        nent(il,i) = 0
+      ENDDO
+    ENDIF ! (ok_entrain)
+
+!jygdebug<
+    IF (prt_level >= 10) THEN
+      print *,'cv3p_mixing i, nent(i), icb, inb ',i, nent(igout,i), icb(igout), inb(igout)
+      IF (nent(igout,i) .gt. 0) THEN
+        print *,'i,(j,Sij(i,j),j=icb-1,inb) ',i,(j,Sij(igout,i,j),j=icb(igout)-1,inb(igout))
+      ENDIF
+    ENDIF
+!>jygdebug
+
+! ***   if no air can entrain at level i assume that updraft detrains  ***
+! ***   at that level and calculate detrained air flux and properties  ***
+
+
+! @      do 170 i=icb(il),inb(il)
+
+    DO il = 1, ncum
+      IF ((i>=icb(il)) .AND. (i<=inb(il)) .AND. (nent(il,i)==0)) THEN
+! @      if(nent(il,i).eq.0)then
+!!!       Ment(il,i,i)=m(il,i)
+        Ment(il, i, i) = 1.
+!!        Qent(il, i, i) = qnk(il) - ep(il, i)*clw(il, i)
+        Qent(il, i, i) = qta(il,i-1) - ep(il, i)*clw(il, i)
+        uent(il, i, i) = unk(il)
+        vent(il, i, i) = vnk(il)
+        IF (fl_cor_ebil .GE. 2) THEN
+          hent(il, i, i) = hp(il,i)
+        ENDIF
+        elij(il, i, i) = clw(il, i)*(1.-ep(il,i))
+        Sij(il, i, i) = 0.0
+      END IF
+    END DO
+  END DO ! i = minorig + 1, nl
+
+!jyg!  DO j = 1, ntra
+!jyg!    DO i = minorig + 1, nl
+!jyg!      DO il = 1, ncum
+!jyg!        IF (i>=icb(il) .AND. i<=inb(il) .AND. nent(il,i)==0) THEN
+!jyg!          traent(il, i, i, j) = tra(il, nk(il), j)
+!jyg!        END IF
+!jyg!      END DO
+!jyg!    END DO
+!jyg!  END DO
+
+  DO j = minorig, nl
+    DO i = minorig, nl
+      DO il = 1, ncum
+        IF ((j>=(icb(il)-1)) .AND. (j<=inb(il)) .AND. &
+            (i>=icb(il)) .AND. (i<=inb(il))) THEN
+          Sigij(il, i, j) = Sij(il, i, j)
+        END IF
+      END DO
+    END DO
+  END DO
+! @      enddo
+
+! @170   continue
+
+! =====================================================================
+! ---  NORMALIZE ENTRAINED AIR MASS FLUXES
+! ---  TO REPRESENT EQUAL PROBABILITIES OF MIXING
+! =====================================================================
+
+  CALL zilch(csum, nloc*nd)
+
+  DO il = 1, ncum
+    lwork(il) = .FALSE.
+  END DO
+
+! ---------------------------------------------------------------
+  DO i = minorig + 1, nl      !Loop on origin level "i"
+! ---------------------------------------------------------------
+
+    num1 = 0
+    DO il = 1, ncum
+      IF (i>=icb(il) .AND. i<=inb(il)) num1 = num1 + 1
+    END DO
+    IF (num1<=0) GO TO 789
+
+
+!JYG1    Find maximum of SIJ for J>I, if any.
+
+    Sx(:) = 0.
+
+    DO il = 1, ncum
+      IF (i>=icb(il) .AND. i<=inb(il)) THEN
+        signhpmh(il) = sign(1., hp(il,i)-h(il,i))
+        Sbef(il) = max(0., signhpmh(il))
+      END IF
+    END DO
+
+    DO j = i + 1, nl
+      DO il = 1, ncum
+        IF (i>=icb(il) .AND. i<=inb(il) .AND. j<=inb(il)) THEN
+          IF (Sbef(il)<Sij(il,i,j)) THEN
+            Sx(il) = max(Sij(il,i,j), Sx(il))
+          END IF
+          Sbef(il) = Sij(il, i, j)
+        END IF
+      END DO
+    END DO
+
+
+    DO il = 1, ncum
+      IF (i>=icb(il) .AND. i<=inb(il)) THEN
+        lwork(il) = (nent(il,i)/=0)
+!!        rti = qnk(il) - ep(il, i)*clw(il, i)
+        rti = qta(il,i-1) - ep(il, i)*clw(il, i)
+!jyg<
+        IF (cvflag_ice) THEN
+
+          anum = h(il, i) - hp(il, i) - (lv(il,i)+frac(il,i)*lf(il,i))* &
+                       (rti-rs(il,i)) + (cpv-cpd)*t(il, i)*(rti-rr(il,i))
+          denom = h(il, i) - hp(il, i) + (lv(il,i)+frac(il,i)*lf(il,i))* &
+                       (rr(il,i)-rti) + (cpd-cpv)*t(il, i)*(rr(il,i)-rti)
+        ELSE
+
+          anum = h(il, i) - hp(il, i) - lv(il, i)*(rti-rs(il,i)) + &
+                       (cpv-cpd)*t(il, i)*(rti-rr(il,i))
+          denom = h(il, i) - hp(il, i) + lv(il, i)*(rr(il,i)-rti) + &
+                       (cpd-cpv)*t(il, i)*(rr(il,i)-rti)
+        END IF
+!>jyg
+        IF (abs(denom)<0.01) denom = 0.01
+        Scrit(il) = min(anum/denom, 1.)
+        alt = rti - rs(il, i) + Scrit(il)*(rr(il,i)-rti)
+
+!JYG1    Find new critical value Scrit2
+!         such that : Sij > Scrit2  => mixed draught will detrain at J<I
+!                     Sij < Scrit2  => mixed draught will detrain at J>I
+
+        Scrit2 = min(Scrit(il), Sx(il))*max(0., -signhpmh(il)) + &
+                 Scrit(il)*max(0., signhpmh(il))
+
+        Scrit(il) = Scrit2
+
+!JYG    Correction pour la nouvelle logique; la correction pour ALT
+! est un peu au hazard
+        IF (Scrit(il)<=0.0) Scrit(il) = 0.0
+        IF (alt<=0.0) Scrit(il) = 1.0
+
+        smax(il) = 0.0
+        ASij(il) = 0.0
+        sup(il) = 0.      ! upper S-value reached by descending draughts
+      END IF
+    END DO
+
+! ---------------------------------------------------------------
+    DO j = minorig, nl         !Loop on destination level "j"
+! ---------------------------------------------------------------
+
+      num2 = 0
+      DO il = 1, ncum
+        IF (i>=icb(il) .AND. i<=inb(il) .AND. &
+            j>=(icb(il)-1) .AND. j<=inb(il) .AND. &
+            lwork(il)) num2 = num2 + 1
+      END DO
+      IF (num2<=0) GO TO 175
+
+! -----------------------------------------------
+      IF (j>i) THEN
+! -----------------------------------------------
+        DO il = 1, ncum
+          IF (i>=icb(il) .AND. i<=inb(il) .AND. &
+              j>=(icb(il)-1) .AND. j<=inb(il) .AND. &
+              lwork(il)) THEN
+            IF (Sij(il,i,j)>0.0) THEN
+              Smid(il) = min(Sij(il,i,j), Scrit(il))
+              Sjmax(il) = Smid(il)
+              Sjmin(il) = Smid(il)
+              IF (Smid(il)<smin(il) .AND. Sij(il,i,j+1)<Smid(il)) THEN
+                smin(il) = Smid(il)
+                Sjmax(il) = min((Sij(il,i,j+1)+Sij(il,i,j))/2., Sij(il,i,j), Scrit(il))
+                Sjmin(il) = max((Sbef(il)+Sij(il,i,j))/2., Sij(il,i,j))
+                Sjmin(il) = min(Sjmin(il), Scrit(il))
+                Sbef(il) = Sij(il, i, j)
+              END IF
+            END IF
+          END IF
+        END DO
+! -----------------------------------------------
+      ELSE IF (j==i) THEN
+! -----------------------------------------------
+        DO il = 1, ncum
+          IF (i>=icb(il) .AND. i<=inb(il) .AND. &
+              j>=(icb(il)-1) .AND. j<=inb(il) .AND. &
+              lwork(il)) THEN
+            IF (Sij(il,i,j)>0.0) THEN
+              Smid(il) = 1.
+              Sjmin(il) = max((Sij(il,i,j-1)+Smid(il))/2., Scrit(il))*max(0., -signhpmh(il)) + &
+                          min((Sij(il,i,j+1)+Smid(il))/2., Scrit(il))*max(0., signhpmh(il))
+              Sjmin(il) = max(Sjmin(il), sup(il))
+              Sjmax(il) = 1.
+
+! -             preparation des variables Scrit, Smin et Sbef pour la partie j>i
+              Scrit(il) = min(Sjmin(il), Sjmax(il), Scrit(il))
+
+              smin(il) = 1.
+              Sbef(il) = max(0., signhpmh(il))
+              supmax(il, i) = sign(Scrit(il), -signhpmh(il))
+            END IF
+          END IF
+        END DO
+! -----------------------------------------------
+      ELSE IF (j<i) THEN
+! -----------------------------------------------
+        DO il = 1, ncum
+          IF (i>=icb(il) .AND. i<=inb(il) .AND. &
+              j>=(icb(il)-1) .AND. j<=inb(il) .AND. &
+              lwork(il)) THEN
+            IF (Sij(il,i,j)>0.0) THEN
+              Smid(il) = max(Sij(il,i,j), Scrit(il))
+              Sjmax(il) = Smid(il)
+              Sjmin(il) = Smid(il)
+              IF (Smid(il)>smax(il) .AND. Sij(il,i,j+1)>Smid(il)) THEN
+                smax(il) = Smid(il)
+                Sjmax(il) = max((Sij(il,i,j+1)+Sij(il,i,j))/2., Sij(il,i,j))
+                Sjmax(il) = max(Sjmax(il), Scrit(il))
+                Sjmin(il) = min((Sbef(il)+Sij(il,i,j))/2., Sij(il,i,j))
+                Sjmin(il) = max(Sjmin(il), Scrit(il))
+                Sbef(il) = Sij(il, i, j)
+              END IF
+              IF (abs(Sjmin(il)-Sjmax(il))>1.E-10) &
+                             sup(il) = max(Sjmin(il), Sjmax(il), sup(il))
+            END IF
+          END IF
+        END DO
+! -----------------------------------------------
+      END IF
+! -----------------------------------------------
+
+
+      DO il = 1, ncum
+        IF (i>=icb(il) .AND. i<=inb(il) .AND. &
+            j>=(icb(il)-1) .AND. j<=inb(il) .AND. &
+            lwork(il)) THEN
+          IF (Sij(il,i,j)>0.0) THEN
+!!            rti = qnk(il) - ep(il, i)*clw(il, i)
+            rti = qta(il,i-1) - ep(il, i)*clw(il, i)
+            Qmixmax(il) = Qmix(Sjmax(il))
+            Qmixmin(il) = Qmix(Sjmin(il))
+            Rmixmax(il) = Rmix(Sjmax(il))
+            Rmixmin(il) = Rmix(Sjmin(il))
+            sqmrmax(il) = Sjmax(il)*Qmix(Sjmax(il)) - Rmix(Sjmax(il))
+            sqmrmin(il) = Sjmin(il)*Qmix(Sjmin(il)) - Rmix(Sjmin(il))
+
+            Ment(il, i, j) = abs(Qmixmax(il)-Qmixmin(il))*Ment(il, i, j)
+
+! Sigij(i,j) is the 'true' mixing fraction of mixture Ment(i,j)
+            IF (abs(Qmixmax(il)-Qmixmin(il))>1.E-10) THEN
+              Sigij(il, i, j) = (sqmrmax(il)-sqmrmin(il))/(Qmixmax(il)-Qmixmin(il))
+            ELSE
+              Sigij(il, i, j) = 0.
+            END IF
+
+! --    Compute Qent, uent, vent according to the true mixing fraction
+            Qent(il, i, j) = (1.-Sigij(il,i,j))*rti     + Sigij(il, i, j)*rr(il, i)
+            uent(il, i, j) = (1.-Sigij(il,i,j))*unk(il) + Sigij(il, i, j)*u(il, i)
+            vent(il, i, j) = (1.-Sigij(il,i,j))*vnk(il) + Sigij(il, i, j)*v(il, i)
+
+! --     Compute liquid water static energy of mixed draughts
+!    IF (j .GT. i) THEN
+!      awat=elij(il,i,j)-(1.-ep(il,j))*clw(il,j)
+!      awat=amax1(awat,0.0)
+!    ELSE
+!      awat = 0.
+!    ENDIF
+!    Hent(il,i,j) = (1.-Sigij(il,i,j))*HP(il,i)
+!    :         + Sigij(il,i,j)*H(il,i)
+!    :         + (LV(il,j)+(cpd-cpv)*t(il,j))*awat
+!IM 301008 beg
+            hent(il, i, j) = (1.-Sigij(il,i,j))*hp(il, i) + Sigij(il, i, j)*h(il, i)
+
+!jyg<
+!            elij(il, i, j) = Qent(il, i, j) - rs(il, j)
+!            elij(il, i, j) = elij(il, i, j) + &
+!                             ((h(il,j)-hent(il,i,j))*rs(il,j)*lv(il,j) / &
+!                              ((cpd*(1.-Qent(il,i,j))+Qent(il,i,j)*cpv)*rrv*t(il,j)*t(il,j)))
+!            elij(il, i, j) = elij(il, i, j) / &
+!                             (1.+lv(il,j)*lv(il,j)*rs(il,j) / &
+!                              ((cpd*(1.-Qent(il,i,j))+Qent(il,i,j)*cpv)*rrv*t(il,j)*t(il,j)))
+!
+!       Computation of condensate amount Elij, taking into account the ice fraction frac
+!       Warning : the same saturation humidity rs is used over both liquid water and ice; this
+!                 should be corrected.
+!
+!  Heat capacity of mixed draught
+    cpm = cpd+Qent(il,i,j)*(cpv-cpd)
+!
+    IF (cvflag_ice .and. frac(il,j) .gt. 0.) THEN
+            elij(il, i, j) = Qent(il, i, j) - rs(il, j)
+            elij(il, i, j) = elij(il, i, j) + &
+                             (h(il,j)-hent(il,i,j)+(cpv-cpd)*(Qent(il,i,j)-rr(il,j))*t(il,j))* &
+                             rs(il,j)*lv(il,j) / (cpm*rrv*t(il,j)*t(il,j))
+            elij(il, i, j) = elij(il, i, j) / &
+                             (1.+(lv(il,j)+frac(il,j)*lf(il,j))*lv(il,j)*rs(il,j) / &
+                              (cpm*rrv*t(il,j)*t(il,j)))
+    ELSE
+            elij(il, i, j) = Qent(il, i, j) - rs(il, j)
+            elij(il, i, j) = elij(il, i, j) + &
+                             (h(il,j)-hent(il,i,j)+(cpv-cpd)*(Qent(il,i,j)-rr(il,j))*t(il,j))* &
+                             rs(il,j)*lv(il,j) / (cpm*rrv*t(il,j)*t(il,j))
+            elij(il, i, j) = elij(il, i, j) / &
+                             (1.+lv(il,j)*lv(il,j)*rs(il,j) / &
+                              (cpm*rrv*t(il,j)*t(il,j)))
+    ENDIF
+!>jyg
+            elij(il, i, j) = max(elij(il,i,j), 0.)
+
+            elij(il, i, j) = min(elij(il,i,j), Qent(il,i,j))
+
+            IF (j>i) THEN
+              awat = elij(il, i, j) - (1.-ep(il,j))*clw(il, j)
+              awat = amax1(awat, 0.0)
+            ELSE
+              awat = 0.
+            END IF
+
+! print *,h(il,j)-hent(il,i,j),LV(il,j)*rs(il,j)/(cpd*rrv*t(il,j)*
+! :         t(il,j))
+
+!jyg<
+!            hent(il, i, j) = hent(il, i, j) + (lv(il,j)+(cpd-cpv)*t(il,j))*awat
+! Mixed draught temperature at level j
+    IF (cvflag_ice .and. frac(il,j) .gt. 0.) THEN
+          Tm = t(il,j) + (Qent(il,i,j)-elij(il,i,j)-rs(il,j))*rrv*t(il,j)*t(il,j)/(lv(il,j)*rs(il,j))
+          hent(il, i, j) = hent(il, i, j) + (lv(il,j)+frac(il,j)*lf(il,j)+(cpd-cpv)*Tm)*awat
+    ELSE
+          Tm = t(il,j) + (Qent(il,i,j)-elij(il,i,j)-rs(il,j))*rrv*t(il,j)*t(il,j)/(lv(il,j)*rs(il,j))
+          hent(il, i, j) = hent(il, i, j) + (lv(il,j)+(cpd-cpv)*Tm)*awat
+    ENDIF
+!>jyg
+
+!IM 301008 end
+
+! print *,'mix : i,j,hent(il,i,j),Sigij(il,i,j) ',
+! :               i,j,hent(il,i,j),Sigij(il,i,j)
+
+! --      ASij is the integral of P(F) over the relevant F interval
+            ASij(il) = ASij(il) + abs(Qmixmax(il)*(1.-Sjmax(il))+Rmixmax(il) - &
+                                      Qmixmin(il)*(1.-Sjmin(il))-Rmixmin(il))
+
+          END IF
+        END IF
+      END DO
+!jyg!      DO k = 1, ntra
+!jyg!        DO il = 1, ncum
+!jyg!          IF ((i>=icb(il)) .AND. (i<=inb(il)) .AND. &
+!jyg!              (j>=(icb(il)-1)) .AND. (j<=inb(il)) .AND. &
+!jyg!              lwork(il)) THEN
+!jyg!            IF (Sij(il,i,j)>0.0) THEN
+!jyg!              traent(il, i, j, k) = Sigij(il, i, j)*tra(il, i, k) + &
+!jyg!                                    (1.-Sigij(il,i,j))*tra(il, nk(il), k)
+!jyg!            END IF
+!jyg!          END IF
+!jyg!        END DO
+!jyg!      END DO
+
+! --    If I=J (detrainement and entrainement at the same level), then only the
+! --    adiabatic ascent part of the mixture is considered
+      IF (i==j) THEN
+        DO il = 1, ncum
+          IF (i>=icb(il) .AND. i<=inb(il) .AND. &
+              j>=(icb(il)-1) .AND. j<=inb(il) .AND. &
+              lwork(il)) THEN
+            IF (Sij(il,i,j)>0.0) THEN
+!!              rti = qnk(il) - ep(il, i)*clw(il, i)
+              rti = qta(il,i-1) - ep(il, i)*clw(il, i)
+!!!             Ment(il,i,i) = m(il,i)*abs(Qmixmax(il)*(1.-Sjmax(il))
+              Ment(il, i, i) = abs(Qmixmax(il)*(1.-Sjmax(il))+Rmixmax(il) - &
+                                   Qmixmin(il)*(1.-Sjmin(il))-Rmixmin(il))
+              Qent(il, i, i) = rti
+              uent(il, i, i) = unk(il)
+              vent(il, i, i) = vnk(il)
+              hent(il, i, i) = hp(il, i)
+              elij(il, i, i) = clw(il, i)*(1.-ep(il,i))
+              Sigij(il, i, i) = 0.
+            END IF
+          END IF
+        END DO
+!jyg!        DO k = 1, ntra
+!jyg!          DO il = 1, ncum
+!jyg!            IF ((i>=icb(il)) .AND. (i<=inb(il)) .AND. &
+!jyg!                (j>=(icb(il)-1)) .AND. (j<=inb(il)) .AND. &
+!jyg!                lwork(il)) THEN
+!jyg!              IF (Sij(il,i,j)>0.0) THEN
+!jyg!                traent(il, i, i, k) = tra(il, nk(il), k)
+!jyg!              END IF
+!jyg!            END IF
+!jyg!          END DO
+!jyg!        END DO
+
+      END IF
+
+! ---------------------------------------------------------------
+175 END DO        ! End loop on destination level "j"
+! ---------------------------------------------------------------
+
+    DO il = 1, ncum
+      IF (i>=icb(il) .AND. i<=inb(il) .AND. lwork(il)) THEN
+        ASij(il) = amax1(1.0E-16, ASij(il))
+!jyg+lluis<
+!!        ASij(il) = 1.0/ASij(il)
+        ASij_inv(il) = 1.0/ASij(il)
+!   IF the F-interval spanned by possible mixtures is less than 0.01, no mixing occurs
+        IF (ASij_inv(il) > 100.)  ASij_inv(il) = 0.
+!>jyg+lluis
+        csum(il, i) = 0.0
+      END IF
+    END DO
+
+    DO j = minorig, nl
+      DO il = 1, ncum
+        IF (i>=icb(il) .AND. i<=inb(il) .AND. lwork(il) .AND. &
+            j>=(icb(il)-1) .AND. j<=inb(il)) THEN
+!jyg          Ment(il, i, j) = Ment(il, i, j)*ASij(il)
+          Ment(il, i, j) = Ment(il, i, j)*ASij_inv(il)
+        END IF
+      END DO
+    END DO
+
+    DO j = minorig, nl
+      DO il = 1, ncum
+        IF (i>=icb(il) .AND. i<=inb(il) .AND. lwork(il) .AND. &
+            j>=(icb(il)-1) .AND. j<=inb(il)) THEN
+          csum(il, i) = csum(il, i) + Ment(il, i, j)
+        END IF
+      END DO
+    END DO
+
+    DO il = 1, ncum
+      IF (i>=icb(il) .AND. i<=inb(il) .AND. lwork(il) .AND. csum(il,i)<1.) THEN
+! cc     :     .and. csum(il,i).lt.m(il,i) ) then
+        nent(il, i) = 0
+! cc        Ment(il,i,i)=m(il,i)
+        Ment(il, i, i) = 1.
+!!        Qent(il, i, i) = qnk(il) - ep(il, i)*clw(il, i)
+        Qent(il, i, i) = qta(il,i-1) - ep(il, i)*clw(il, i)
+        uent(il, i, i) = unk(il)
+        vent(il, i, i) = vnk(il)
+        elij(il, i, i) = clw(il, i)*(1.-ep(il,i))
+        IF (fl_cor_ebil .GE. 2) THEN
+          hent(il, i, i) = hp(il,i)
+          Sigij(il, i, i) = 0.0
+        ELSE
+          Sij(il, i, i) = 0.0
+        ENDIF
+      END IF
+    END DO ! il
+
+!jyg!    DO j = 1, ntra
+!jyg!      DO il = 1, ncum
+!jyg!        IF (i>=icb(il) .AND. i<=inb(il) .AND. lwork(il) .AND. csum(il,i)<1.) THEN
+!jyg!! cc     :     .and. csum(il,i).lt.m(il,i) ) then
+!jyg!          traent(il, i, i, j) = tra(il, nk(il), j)
+!jyg!        END IF
+!jyg!      END DO
+!jyg!    END DO
+
+! ---------------------------------------------------------------
+789 END DO              ! End loop on origin level "i"
+! ---------------------------------------------------------------
+
+
+  RETURN
+END SUBROUTINE cv3p_mixing
+
Index: DZ6/trunk/libf/phylmd/cv_routines.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cv_routines.F90	(revision 5267)
+++ 	(revision )
@@ -1,1713 +1,0 @@
-
-! $Id$
-
-SUBROUTINE cv_param(nd)
-  IMPLICIT NONE
-
-  ! ------------------------------------------------------------
-  ! Set parameters for convectL
-  ! (includes microphysical parameters and parameters that
-  ! control the rate of approach to quasi-equilibrium)
-  ! ------------------------------------------------------------
-
-  ! *** ELCRIT IS THE AUTOCONVERSION THERSHOLD WATER CONTENT (gm/gm) ***
-  ! ***  TLCRIT IS CRITICAL TEMPERATURE BELOW WHICH THE AUTO-        ***
-  ! ***       CONVERSION THRESHOLD IS ASSUMED TO BE ZERO             ***
-  ! ***     (THE AUTOCONVERSION THRESHOLD VARIES LINEARLY            ***
-  ! ***               BETWEEN 0 C AND TLCRIT)                        ***
-  ! ***   ENTP IS THE COEFFICIENT OF MIXING IN THE ENTRAINMENT       ***
-  ! ***                       FORMULATION                            ***
-  ! ***  SIGD IS THE FRACTIONAL AREA COVERED BY UNSATURATED DNDRAFT  ***
-  ! ***  SIGS IS THE FRACTION OF PRECIPITATION FALLING OUTSIDE       ***
-  ! ***                        OF CLOUD                              ***
-  ! ***        OMTRAIN IS THE ASSUMED FALL SPEED (P/s) OF RAIN       ***
-  ! ***     OMTSNOW IS THE ASSUMED FALL SPEED (P/s) OF SNOW          ***
-  ! ***  COEFFR IS A COEFFICIENT GOVERNING THE RATE OF EVAPORATION   ***
-  ! ***                          OF RAIN                             ***
-  ! ***  COEFFS IS A COEFFICIENT GOVERNING THE RATE OF EVAPORATION   ***
-  ! ***                          OF SNOW                             ***
-  ! ***     CU IS THE COEFFICIENT GOVERNING CONVECTIVE MOMENTUM      ***
-  ! ***                         TRANSPORT                            ***
-  ! ***    DTMAX IS THE MAXIMUM NEGATIVE TEMPERATURE PERTURBATION    ***
-  ! ***        A LIFTED PARCEL IS ALLOWED TO HAVE BELOW ITS LFC      ***
-  ! ***    ALPHA AND DAMP ARE PARAMETERS THAT CONTROL THE RATE OF    ***
-  ! ***                 APPROACH TO QUASI-EQUILIBRIUM                ***
-  ! ***   (THEIR STANDARD VALUES ARE  0.20 AND 0.1, RESPECTIVELY)    ***
-  ! ***                   (DAMP MUST BE LESS THAN 1)                 ***
-
-  include "cvparam.h"
-  INTEGER nd
-  CHARACTER (LEN=20) :: modname = 'cv_routines'
-  CHARACTER (LEN=80) :: abort_message
-
-  ! noff: integer limit for convection (nd-noff)
-  ! minorig: First level of convection
-
-  noff = 2
-  minorig = 2
-
-  nl = nd - noff
-  nlp = nl + 1
-  nlm = nl - 1
-
-  elcrit = 0.0011
-  tlcrit = -55.0
-  entp = 1.5
-  sigs = 0.12
-  sigd = 0.05
-  omtrain = 50.0
-  omtsnow = 5.5
-  coeffr = 1.0
-  coeffs = 0.8
-  dtmax = 0.9
-
-  cu = 0.70
-
-  betad = 10.0
-
-  damp = 0.1
-  alpha = 0.2
-
-  delta = 0.01 ! cld
-
-  RETURN
-END SUBROUTINE cv_param
-
-SUBROUTINE cv_prelim(len, nd, ndp1, t, q, p, ph, lv, cpn, tv, gz, h, hm)
-  IMPLICIT NONE
-
-  ! =====================================================================
-  ! --- CALCULATE ARRAYS OF GEOPOTENTIAL, HEAT CAPACITY & STATIC ENERGY
-  ! =====================================================================
-
-  ! inputs:
-  INTEGER len, nd, ndp1
-  REAL t(len, nd), q(len, nd), p(len, nd), ph(len, ndp1)
-
-  ! outputs:
-  REAL lv(len, nd), cpn(len, nd), tv(len, nd)
-  REAL gz(len, nd), h(len, nd), hm(len, nd)
-
-  ! local variables:
-  INTEGER k, i
-  REAL cpx(len, nd)
-
-  include "cvthermo.h"
-  include "cvparam.h"
-
-
-  DO k = 1, nlp
-    DO i = 1, len
-      lv(i, k) = lv0 - clmcpv*(t(i,k)-t0)
-      cpn(i, k) = cpd*(1.0-q(i,k)) + cpv*q(i, k)
-      cpx(i, k) = cpd*(1.0-q(i,k)) + cl*q(i, k)
-      tv(i, k) = t(i, k)*(1.0+q(i,k)*epsim1)
-    END DO
-  END DO
-
-  ! gz = phi at the full levels (same as p).
-
-  DO i = 1, len
-    gz(i, 1) = 0.0
-  END DO
-  DO k = 2, nlp
-    DO i = 1, len
-      gz(i, k) = gz(i, k-1) + hrd*(tv(i,k-1)+tv(i,k))*(p(i,k-1)-p(i,k))/ph(i, &
-        k)
-    END DO
-  END DO
-
-  ! h  = phi + cpT (dry static energy).
-  ! hm = phi + cp(T-Tbase)+Lq
-
-  DO k = 1, nlp
-    DO i = 1, len
-      h(i, k) = gz(i, k) + cpn(i, k)*t(i, k)
-      hm(i, k) = gz(i, k) + cpx(i, k)*(t(i,k)-t(i,1)) + lv(i, k)*q(i, k)
-    END DO
-  END DO
-
-  RETURN
-END SUBROUTINE cv_prelim
-
-SUBROUTINE cv_feed(len, nd, t, q, qs, p, hm, gz, nk, icb, icbmax, iflag, tnk, &
-    qnk, gznk, plcl)
-  IMPLICIT NONE
-
-  ! ================================================================
-  ! Purpose: CONVECTIVE FEED
-  ! ================================================================
-
-  include "cvparam.h"
-
-  ! inputs:
-  INTEGER len, nd
-  REAL t(len, nd), q(len, nd), qs(len, nd), p(len, nd)
-  REAL hm(len, nd), gz(len, nd)
-
-  ! outputs:
-  INTEGER iflag(len), nk(len), icb(len), icbmax
-  REAL tnk(len), qnk(len), gznk(len), plcl(len)
-
-  ! local variables:
-  INTEGER i, k
-  INTEGER ihmin(len)
-  REAL work(len)
-  REAL pnk(len), qsnk(len), rh(len), chi(len)
-
-  ! -------------------------------------------------------------------
-  ! --- Find level of minimum moist static energy
-  ! --- If level of minimum moist static energy coincides with
-  ! --- or is lower than minimum allowable parcel origin level,
-  ! --- set iflag to 6.
-  ! -------------------------------------------------------------------
-
-  DO i = 1, len
-    work(i) = 1.0E12
-    ihmin(i) = nl
-  END DO
-  DO k = 2, nlp
-    DO i = 1, len
-      IF ((hm(i,k)<work(i)) .AND. (hm(i,k)<hm(i,k-1))) THEN
-        work(i) = hm(i, k)
-        ihmin(i) = k
-      END IF
-    END DO
-  END DO
-  DO i = 1, len
-    ihmin(i) = min(ihmin(i), nlm)
-    IF (ihmin(i)<=minorig) THEN
-      iflag(i) = 6
-    END IF
-  END DO
-
-  ! -------------------------------------------------------------------
-  ! --- Find that model level below the level of minimum moist static
-  ! --- energy that has the maximum value of moist static energy
-  ! -------------------------------------------------------------------
-
-  DO i = 1, len
-    work(i) = hm(i, minorig)
-    nk(i) = minorig
-  END DO
-  DO k = minorig + 1, nl
-    DO i = 1, len
-      IF ((hm(i,k)>work(i)) .AND. (k<=ihmin(i))) THEN
-        work(i) = hm(i, k)
-        nk(i) = k
-      END IF
-    END DO
-  END DO
-  ! -------------------------------------------------------------------
-  ! --- Check whether parcel level temperature and specific humidity
-  ! --- are reasonable
-  ! -------------------------------------------------------------------
-  DO i = 1, len
-    IF (((t(i,nk(i))<250.0) .OR. (q(i,nk(i))<=0.0) .OR. (p(i,ihmin(i))< &
-      400.0)) .AND. (iflag(i)==0)) iflag(i) = 7
-  END DO
-  ! -------------------------------------------------------------------
-  ! --- Calculate lifted condensation level of air at parcel origin level
-  ! --- (Within 0.2% of formula of Bolton, MON. WEA. REV.,1980)
-  ! -------------------------------------------------------------------
-  DO i = 1, len
-    tnk(i) = t(i, nk(i))
-    qnk(i) = q(i, nk(i))
-    gznk(i) = gz(i, nk(i))
-    pnk(i) = p(i, nk(i))
-    qsnk(i) = qs(i, nk(i))
-
-    rh(i) = qnk(i)/qsnk(i)
-    rh(i) = min(1.0, rh(i))
-    chi(i) = tnk(i)/(1669.0-122.0*rh(i)-tnk(i))
-    plcl(i) = pnk(i)*(rh(i)**chi(i))
-    IF (((plcl(i)<200.0) .OR. (plcl(i)>=2000.0)) .AND. (iflag(i)==0)) iflag(i &
-      ) = 8
-  END DO
-  ! -------------------------------------------------------------------
-  ! --- Calculate first level above lcl (=icb)
-  ! -------------------------------------------------------------------
-  DO i = 1, len
-    icb(i) = nlm
-  END DO
-
-  DO k = minorig, nl
-    DO i = 1, len
-      IF ((k>=(nk(i)+1)) .AND. (p(i,k)<plcl(i))) icb(i) = min(icb(i), k)
-    END DO
-  END DO
-
-  DO i = 1, len
-    IF ((icb(i)>=nlm) .AND. (iflag(i)==0)) iflag(i) = 9
-  END DO
-
-  ! Compute icbmax.
-
-  icbmax = 2
-  DO i = 1, len
-    icbmax = max(icbmax, icb(i))
-  END DO
-
-  RETURN
-END SUBROUTINE cv_feed
-
-SUBROUTINE cv_undilute1(len, nd, t, q, qs, gz, p, nk, icb, icbmax, tp, tvp, &
-    clw)
-  IMPLICIT NONE
-
-  include "cvthermo.h"
-  include "cvparam.h"
-
-  ! inputs:
-  INTEGER len, nd
-  INTEGER nk(len), icb(len), icbmax
-  REAL t(len, nd), q(len, nd), qs(len, nd), gz(len, nd)
-  REAL p(len, nd)
-
-  ! outputs:
-  REAL tp(len, nd), tvp(len, nd), clw(len, nd)
-
-  ! local variables:
-  INTEGER i, k
-  REAL tg, qg, alv, s, ahg, tc, denom, es, rg
-  REAL ah0(len), cpp(len)
-  REAL tnk(len), qnk(len), gznk(len), ticb(len), gzicb(len)
-
-  ! -------------------------------------------------------------------
-  ! --- Calculates the lifted parcel virtual temperature at nk,
-  ! --- the actual temperature, and the adiabatic
-  ! --- liquid water content. The procedure is to solve the equation.
-  ! cp*tp+L*qp+phi=cp*tnk+L*qnk+gznk.
-  ! -------------------------------------------------------------------
-
-  DO i = 1, len
-    tnk(i) = t(i, nk(i))
-    qnk(i) = q(i, nk(i))
-    gznk(i) = gz(i, nk(i))
-    ticb(i) = t(i, icb(i))
-    gzicb(i) = gz(i, icb(i))
-  END DO
-
-  ! ***  Calculate certain parcel quantities, including static energy   ***
-
-  DO i = 1, len
-    ah0(i) = (cpd*(1.-qnk(i))+cl*qnk(i))*tnk(i) + qnk(i)*(lv0-clmcpv*(tnk(i)- &
-      273.15)) + gznk(i)
-    cpp(i) = cpd*(1.-qnk(i)) + qnk(i)*cpv
-  END DO
-
-  ! ***   Calculate lifted parcel quantities below cloud base   ***
-
-  DO k = minorig, icbmax - 1
-    DO i = 1, len
-      tp(i, k) = tnk(i) - (gz(i,k)-gznk(i))/cpp(i)
-      tvp(i, k) = tp(i, k)*(1.+qnk(i)*epsi)
-    END DO
-  END DO
-
-  ! ***  Find lifted parcel quantities above cloud base    ***
-
-  DO i = 1, len
-    tg = ticb(i)
-    qg = qs(i, icb(i))
-    alv = lv0 - clmcpv*(ticb(i)-t0)
-
-    ! First iteration.
-
-    s = cpd + alv*alv*qg/(rrv*ticb(i)*ticb(i))
-    s = 1./s
-    ahg = cpd*tg + (cl-cpd)*qnk(i)*ticb(i) + alv*qg + gzicb(i)
-    tg = tg + s*(ah0(i)-ahg)
-    tg = max(tg, 35.0)
-    tc = tg - t0
-    denom = 243.5 + tc
-    IF (tc>=0.0) THEN
-      es = 6.112*exp(17.67*tc/denom)
-    ELSE
-      es = exp(23.33086-6111.72784/tg+0.15215*log(tg))
-    END IF
-    qg = eps*es/(p(i,icb(i))-es*(1.-eps))
-
-    ! Second iteration.
-
-    s = cpd + alv*alv*qg/(rrv*ticb(i)*ticb(i))
-    s = 1./s
-    ahg = cpd*tg + (cl-cpd)*qnk(i)*ticb(i) + alv*qg + gzicb(i)
-    tg = tg + s*(ah0(i)-ahg)
-    tg = max(tg, 35.0)
-    tc = tg - t0
-    denom = 243.5 + tc
-    IF (tc>=0.0) THEN
-      es = 6.112*exp(17.67*tc/denom)
-    ELSE
-      es = exp(23.33086-6111.72784/tg+0.15215*log(tg))
-    END IF
-    qg = eps*es/(p(i,icb(i))-es*(1.-eps))
-
-    alv = lv0 - clmcpv*(ticb(i)-273.15)
-    tp(i, icb(i)) = (ah0(i)-(cl-cpd)*qnk(i)*ticb(i)-gz(i,icb(i))-alv*qg)/cpd
-    clw(i, icb(i)) = qnk(i) - qg
-    clw(i, icb(i)) = max(0.0, clw(i,icb(i)))
-    rg = qg/(1.-qnk(i))
-    tvp(i, icb(i)) = tp(i, icb(i))*(1.+rg*epsi)
-  END DO
-
-  DO k = minorig, icbmax
-    DO i = 1, len
-      tvp(i, k) = tvp(i, k) - tp(i, k)*qnk(i)
-    END DO
-  END DO
-
-  RETURN
-END SUBROUTINE cv_undilute1
-
-SUBROUTINE cv_trigger(len, nd, icb, cbmf, tv, tvp, iflag)
-  IMPLICIT NONE
-
-  ! -------------------------------------------------------------------
-  ! --- Test for instability.
-  ! --- If there was no convection at last time step and parcel
-  ! --- is stable at icb, then set iflag to 4.
-  ! -------------------------------------------------------------------
-
-  include "cvparam.h"
-
-  ! inputs:
-  INTEGER len, nd, icb(len)
-  REAL cbmf(len), tv(len, nd), tvp(len, nd)
-
-  ! outputs:
-  INTEGER iflag(len) ! also an input
-
-  ! local variables:
-  INTEGER i
-
-
-  DO i = 1, len
-    IF ((cbmf(i)==0.0) .AND. (iflag(i)==0) .AND. (tvp(i, &
-      icb(i))<=(tv(i,icb(i))-dtmax))) iflag(i) = 4
-  END DO
-
-  RETURN
-END SUBROUTINE cv_trigger
-
-SUBROUTINE cv_compress(len, nloc, ncum, nd, iflag1, nk1, icb1, cbmf1, plcl1, &
-    tnk1, qnk1, gznk1, t1, q1, qs1, u1, v1, gz1, h1, lv1, cpn1, p1, ph1, tv1, &
-    tp1, tvp1, clw1, iflag, nk, icb, cbmf, plcl, tnk, qnk, gznk, t, q, qs, u, &
-    v, gz, h, lv, cpn, p, ph, tv, tp, tvp, clw, dph)
-  USE print_control_mod, ONLY: lunout
-  IMPLICIT NONE
-
-  include "cvparam.h"
-
-  ! inputs:
-  INTEGER len, ncum, nd, nloc
-  INTEGER iflag1(len), nk1(len), icb1(len)
-  REAL cbmf1(len), plcl1(len), tnk1(len), qnk1(len), gznk1(len)
-  REAL t1(len, nd), q1(len, nd), qs1(len, nd), u1(len, nd), v1(len, nd)
-  REAL gz1(len, nd), h1(len, nd), lv1(len, nd), cpn1(len, nd)
-  REAL p1(len, nd), ph1(len, nd+1), tv1(len, nd), tp1(len, nd)
-  REAL tvp1(len, nd), clw1(len, nd)
-
-  ! outputs:
-  INTEGER iflag(nloc), nk(nloc), icb(nloc)
-  REAL cbmf(nloc), plcl(nloc), tnk(nloc), qnk(nloc), gznk(nloc)
-  REAL t(nloc, nd), q(nloc, nd), qs(nloc, nd), u(nloc, nd), v(nloc, nd)
-  REAL gz(nloc, nd), h(nloc, nd), lv(nloc, nd), cpn(nloc, nd)
-  REAL p(nloc, nd), ph(nloc, nd+1), tv(nloc, nd), tp(nloc, nd)
-  REAL tvp(nloc, nd), clw(nloc, nd)
-  REAL dph(nloc, nd)
-
-  ! local variables:
-  INTEGER i, k, nn
-  CHARACTER (LEN=20) :: modname = 'cv_compress'
-  CHARACTER (LEN=80) :: abort_message
-
-
-  DO k = 1, nl + 1
-    nn = 0
-    DO i = 1, len
-      IF (iflag1(i)==0) THEN
-        nn = nn + 1
-        t(nn, k) = t1(i, k)
-        q(nn, k) = q1(i, k)
-        qs(nn, k) = qs1(i, k)
-        u(nn, k) = u1(i, k)
-        v(nn, k) = v1(i, k)
-        gz(nn, k) = gz1(i, k)
-        h(nn, k) = h1(i, k)
-        lv(nn, k) = lv1(i, k)
-        cpn(nn, k) = cpn1(i, k)
-        p(nn, k) = p1(i, k)
-        ph(nn, k) = ph1(i, k)
-        tv(nn, k) = tv1(i, k)
-        tp(nn, k) = tp1(i, k)
-        tvp(nn, k) = tvp1(i, k)
-        clw(nn, k) = clw1(i, k)
-      END IF
-    END DO
-  END DO
-
-  IF (nn/=ncum) THEN
-    WRITE (lunout, *) 'strange! nn not equal to ncum: ', nn, ncum
-    abort_message = ''
-    CALL abort_physic(modname, abort_message, 1)
-  END IF
-
-  nn = 0
-  DO i = 1, len
-    IF (iflag1(i)==0) THEN
-      nn = nn + 1
-      cbmf(nn) = cbmf1(i)
-      plcl(nn) = plcl1(i)
-      tnk(nn) = tnk1(i)
-      qnk(nn) = qnk1(i)
-      gznk(nn) = gznk1(i)
-      nk(nn) = nk1(i)
-      icb(nn) = icb1(i)
-      iflag(nn) = iflag1(i)
-    END IF
-  END DO
-
-  DO k = 1, nl
-    DO i = 1, ncum
-      dph(i, k) = ph(i, k) - ph(i, k+1)
-    END DO
-  END DO
-
-  RETURN
-END SUBROUTINE cv_compress
-
-SUBROUTINE cv_undilute2(nloc, ncum, nd, icb, nk, tnk, qnk, gznk, t, q, qs, &
-    gz, p, dph, h, tv, lv, inb, inb1, tp, tvp, clw, hp, ep, sigp, frac)
-  IMPLICIT NONE
-
-  ! ---------------------------------------------------------------------
-  ! Purpose:
-  ! FIND THE REST OF THE LIFTED PARCEL TEMPERATURES
-  ! &
-  ! COMPUTE THE PRECIPITATION EFFICIENCIES AND THE
-  ! FRACTION OF PRECIPITATION FALLING OUTSIDE OF CLOUD
-  ! &
-  ! FIND THE LEVEL OF NEUTRAL BUOYANCY
-  ! ---------------------------------------------------------------------
-
-  include "cvthermo.h"
-  include "cvparam.h"
-
-  ! inputs:
-  INTEGER ncum, nd, nloc
-  INTEGER icb(nloc), nk(nloc)
-  REAL t(nloc, nd), q(nloc, nd), qs(nloc, nd), gz(nloc, nd)
-  REAL p(nloc, nd), dph(nloc, nd)
-  REAL tnk(nloc), qnk(nloc), gznk(nloc)
-  REAL lv(nloc, nd), tv(nloc, nd), h(nloc, nd)
-
-  ! outputs:
-  INTEGER inb(nloc), inb1(nloc)
-  REAL tp(nloc, nd), tvp(nloc, nd), clw(nloc, nd)
-  REAL ep(nloc, nd), sigp(nloc, nd), hp(nloc, nd)
-  REAL frac(nloc)
-
-  ! local variables:
-  INTEGER i, k
-  REAL tg, qg, ahg, alv, s, tc, es, denom, rg, tca, elacrit
-  REAL by, defrac
-  REAL ah0(nloc), cape(nloc), capem(nloc), byp(nloc)
-  LOGICAL lcape(nloc)
-
-  ! =====================================================================
-  ! --- SOME INITIALIZATIONS
-  ! =====================================================================
-
-  DO k = 1, nl
-    DO i = 1, ncum
-      ep(i, k) = 0.0
-      sigp(i, k) = sigs
-    END DO
-  END DO
-
-  ! =====================================================================
-  ! --- FIND THE REST OF THE LIFTED PARCEL TEMPERATURES
-  ! =====================================================================
-
-  ! ---       The procedure is to solve the equation.
-  ! cp*tp+L*qp+phi=cp*tnk+L*qnk+gznk.
-
-  ! ***  Calculate certain parcel quantities, including static energy   ***
-
-
-  DO i = 1, ncum
-    ah0(i) = (cpd*(1.-qnk(i))+cl*qnk(i))*tnk(i) + qnk(i)*(lv0-clmcpv*(tnk(i)- &
-      t0)) + gznk(i)
-  END DO
-
-
-  ! ***  Find lifted parcel quantities above cloud base    ***
-
-
-  DO k = minorig + 1, nl
-    DO i = 1, ncum
-      IF (k>=(icb(i)+1)) THEN
-        tg = t(i, k)
-        qg = qs(i, k)
-        alv = lv0 - clmcpv*(t(i,k)-t0)
-
-        ! First iteration.
-
-        s = cpd + alv*alv*qg/(rrv*t(i,k)*t(i,k))
-        s = 1./s
-        ahg = cpd*tg + (cl-cpd)*qnk(i)*t(i, k) + alv*qg + gz(i, k)
-        tg = tg + s*(ah0(i)-ahg)
-        tg = max(tg, 35.0)
-        tc = tg - t0
-        denom = 243.5 + tc
-        IF (tc>=0.0) THEN
-          es = 6.112*exp(17.67*tc/denom)
-        ELSE
-          es = exp(23.33086-6111.72784/tg+0.15215*log(tg))
-        END IF
-        qg = eps*es/(p(i,k)-es*(1.-eps))
-
-        ! Second iteration.
-
-        s = cpd + alv*alv*qg/(rrv*t(i,k)*t(i,k))
-        s = 1./s
-        ahg = cpd*tg + (cl-cpd)*qnk(i)*t(i, k) + alv*qg + gz(i, k)
-        tg = tg + s*(ah0(i)-ahg)
-        tg = max(tg, 35.0)
-        tc = tg - t0
-        denom = 243.5 + tc
-        IF (tc>=0.0) THEN
-          es = 6.112*exp(17.67*tc/denom)
-        ELSE
-          es = exp(23.33086-6111.72784/tg+0.15215*log(tg))
-        END IF
-        qg = eps*es/(p(i,k)-es*(1.-eps))
-
-        alv = lv0 - clmcpv*(t(i,k)-t0)
-        ! print*,'cpd dans convect2 ',cpd
-        ! print*,'tp(i,k),ah0(i),cl,cpd,qnk(i),t(i,k),gz(i,k),alv,qg,cpd'
-        ! print*,tp(i,k),ah0(i),cl,cpd,qnk(i),t(i,k),gz(i,k),alv,qg,cpd
-        tp(i, k) = (ah0(i)-(cl-cpd)*qnk(i)*t(i,k)-gz(i,k)-alv*qg)/cpd
-        ! if (.not.cpd.gt.1000.) then
-        ! print*,'CPD=',cpd
-        ! stop
-        ! endif
-        clw(i, k) = qnk(i) - qg
-        clw(i, k) = max(0.0, clw(i,k))
-        rg = qg/(1.-qnk(i))
-        tvp(i, k) = tp(i, k)*(1.+rg*epsi)
-      END IF
-    END DO
-  END DO
-
-  ! =====================================================================
-  ! --- SET THE PRECIPITATION EFFICIENCIES AND THE FRACTION OF
-  ! --- PRECIPITATION FALLING OUTSIDE OF CLOUD
-  ! --- THESE MAY BE FUNCTIONS OF TP(I), P(I) AND CLW(I)
-  ! =====================================================================
-
-  DO k = minorig + 1, nl
-    DO i = 1, ncum
-      IF (k>=(nk(i)+1)) THEN
-        tca = tp(i, k) - t0
-        IF (tca>=0.0) THEN
-          elacrit = elcrit
-        ELSE
-          elacrit = elcrit*(1.0-tca/tlcrit)
-        END IF
-        elacrit = max(elacrit, 0.0)
-        ep(i, k) = 1.0 - elacrit/max(clw(i,k), 1.0E-8)
-        ep(i, k) = max(ep(i,k), 0.0)
-        ep(i, k) = min(ep(i,k), 1.0)
-        sigp(i, k) = sigs
-      END IF
-    END DO
-  END DO
-
-  ! =====================================================================
-  ! --- CALCULATE VIRTUAL TEMPERATURE AND LIFTED PARCEL
-  ! --- VIRTUAL TEMPERATURE
-  ! =====================================================================
-
-  DO k = minorig + 1, nl
-    DO i = 1, ncum
-      IF (k>=(icb(i)+1)) THEN
-        tvp(i, k) = tvp(i, k)*(1.0-qnk(i)+ep(i,k)*clw(i,k))
-        ! print*,'i,k,tvp(i,k),qnk(i),ep(i,k),clw(i,k)'
-        ! print*, i,k,tvp(i,k),qnk(i),ep(i,k),clw(i,k)
-      END IF
-    END DO
-  END DO
-  DO i = 1, ncum
-    tvp(i, nlp) = tvp(i, nl) - (gz(i,nlp)-gz(i,nl))/cpd
-  END DO
-
-  ! =====================================================================
-  ! --- FIND THE FIRST MODEL LEVEL (INB1) ABOVE THE PARCEL'S
-  ! --- HIGHEST LEVEL OF NEUTRAL BUOYANCY
-  ! --- AND THE HIGHEST LEVEL OF POSITIVE CAPE (INB)
-  ! =====================================================================
-
-  DO i = 1, ncum
-    cape(i) = 0.0
-    capem(i) = 0.0
-    inb(i) = icb(i) + 1
-    inb1(i) = inb(i)
-  END DO
-
-  ! Originial Code
-
-  ! do 530 k=minorig+1,nl-1
-  ! do 520 i=1,ncum
-  ! if(k.ge.(icb(i)+1))then
-  ! by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k)
-  ! byp=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1)
-  ! cape(i)=cape(i)+by
-  ! if(by.ge.0.0)inb1(i)=k+1
-  ! if(cape(i).gt.0.0)then
-  ! inb(i)=k+1
-  ! capem(i)=cape(i)
-  ! endif
-  ! endif
-  ! 520    continue
-  ! 530  continue
-  ! do 540 i=1,ncum
-  ! byp=(tvp(i,nl)-tv(i,nl))*dph(i,nl)/p(i,nl)
-  ! cape(i)=capem(i)+byp
-  ! defrac=capem(i)-cape(i)
-  ! defrac=max(defrac,0.001)
-  ! frac(i)=-cape(i)/defrac
-  ! frac(i)=min(frac(i),1.0)
-  ! frac(i)=max(frac(i),0.0)
-  ! 540   continue
-
-  ! K Emanuel fix
-
-  ! call zilch(byp,ncum)
-  ! do 530 k=minorig+1,nl-1
-  ! do 520 i=1,ncum
-  ! if(k.ge.(icb(i)+1))then
-  ! by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k)
-  ! cape(i)=cape(i)+by
-  ! if(by.ge.0.0)inb1(i)=k+1
-  ! if(cape(i).gt.0.0)then
-  ! inb(i)=k+1
-  ! capem(i)=cape(i)
-  ! byp(i)=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1)
-  ! endif
-  ! endif
-  ! 520    continue
-  ! 530  continue
-  ! do 540 i=1,ncum
-  ! inb(i)=max(inb(i),inb1(i))
-  ! cape(i)=capem(i)+byp(i)
-  ! defrac=capem(i)-cape(i)
-  ! defrac=max(defrac,0.001)
-  ! frac(i)=-cape(i)/defrac
-  ! frac(i)=min(frac(i),1.0)
-  ! frac(i)=max(frac(i),0.0)
-  ! 540   continue
-
-  ! J Teixeira fix
-
-  CALL zilch(byp, ncum)
-  DO i = 1, ncum
-    lcape(i) = .TRUE.
-  END DO
-  DO k = minorig + 1, nl - 1
-    DO i = 1, ncum
-      IF (cape(i)<0.0) lcape(i) = .FALSE.
-      IF ((k>=(icb(i)+1)) .AND. lcape(i)) THEN
-        by = (tvp(i,k)-tv(i,k))*dph(i, k)/p(i, k)
-        byp(i) = (tvp(i,k+1)-tv(i,k+1))*dph(i, k+1)/p(i, k+1)
-        cape(i) = cape(i) + by
-        IF (by>=0.0) inb1(i) = k + 1
-        IF (cape(i)>0.0) THEN
-          inb(i) = k + 1
-          capem(i) = cape(i)
-        END IF
-      END IF
-    END DO
-  END DO
-  DO i = 1, ncum
-    cape(i) = capem(i) + byp(i)
-    defrac = capem(i) - cape(i)
-    defrac = max(defrac, 0.001)
-    frac(i) = -cape(i)/defrac
-    frac(i) = min(frac(i), 1.0)
-    frac(i) = max(frac(i), 0.0)
-  END DO
-
-  ! =====================================================================
-  ! ---   CALCULATE LIQUID WATER STATIC ENERGY OF LIFTED PARCEL
-  ! =====================================================================
-
-  ! initialization:
-  DO i = 1, ncum*nlp
-    hp(i, 1) = h(i, 1)
-  END DO
-
-  DO k = minorig + 1, nl
-    DO i = 1, ncum
-      IF ((k>=icb(i)) .AND. (k<=inb(i))) THEN
-        hp(i, k) = h(i, nk(i)) + (lv(i,k)+(cpd-cpv)*t(i,k))*ep(i, k)*clw(i, k &
-          )
-      END IF
-    END DO
-  END DO
-
-  RETURN
-END SUBROUTINE cv_undilute2
-
-SUBROUTINE cv_closure(nloc, ncum, nd, nk, icb, tv, tvp, p, ph, dph, plcl, &
-    cpn, iflag, cbmf)
-  IMPLICIT NONE
-
-  ! inputs:
-  INTEGER ncum, nd, nloc
-  INTEGER nk(nloc), icb(nloc)
-  REAL tv(nloc, nd), tvp(nloc, nd), p(nloc, nd), dph(nloc, nd)
-  REAL ph(nloc, nd+1) ! caution nd instead ndp1 to be consistent...
-  REAL plcl(nloc), cpn(nloc, nd)
-
-  ! outputs:
-  INTEGER iflag(nloc)
-  REAL cbmf(nloc) ! also an input
-
-  ! local variables:
-  INTEGER i, k, icbmax
-  REAL dtpbl(nloc), dtmin(nloc), tvpplcl(nloc), tvaplcl(nloc)
-  REAL work(nloc)
-
-  include "cvthermo.h"
-  include "cvparam.h"
-
-  ! -------------------------------------------------------------------
-  ! Compute icbmax.
-  ! -------------------------------------------------------------------
-
-  icbmax = 2
-  DO i = 1, ncum
-    icbmax = max(icbmax, icb(i))
-  END DO
-
-  ! =====================================================================
-  ! ---  CALCULATE CLOUD BASE MASS FLUX
-  ! =====================================================================
-
-  ! tvpplcl = parcel temperature lifted adiabatically from level
-  ! icb-1 to the LCL.
-  ! tvaplcl = virtual temperature at the LCL.
-
-  DO i = 1, ncum
-    dtpbl(i) = 0.0
-    tvpplcl(i) = tvp(i, icb(i)-1) - rrd*tvp(i, icb(i)-1)*(p(i,icb(i)-1)-plcl( &
-      i))/(cpn(i,icb(i)-1)*p(i,icb(i)-1))
-    tvaplcl(i) = tv(i, icb(i)) + (tvp(i,icb(i))-tvp(i,icb(i)+1))*(plcl(i)-p(i &
-      ,icb(i)))/(p(i,icb(i))-p(i,icb(i)+1))
-  END DO
-
-  ! -------------------------------------------------------------------
-  ! --- Interpolate difference between lifted parcel and
-  ! --- environmental temperatures to lifted condensation level
-  ! -------------------------------------------------------------------
-
-  ! dtpbl = average of tvp-tv in the PBL (k=nk to icb-1).
-
-  DO k = minorig, icbmax
-    DO i = 1, ncum
-      IF ((k>=nk(i)) .AND. (k<=(icb(i)-1))) THEN
-        dtpbl(i) = dtpbl(i) + (tvp(i,k)-tv(i,k))*dph(i, k)
-      END IF
-    END DO
-  END DO
-  DO i = 1, ncum
-    dtpbl(i) = dtpbl(i)/(ph(i,nk(i))-ph(i,icb(i)))
-    dtmin(i) = tvpplcl(i) - tvaplcl(i) + dtmax + dtpbl(i)
-  END DO
-
-  ! -------------------------------------------------------------------
-  ! --- Adjust cloud base mass flux
-  ! -------------------------------------------------------------------
-
-  DO i = 1, ncum
-    work(i) = cbmf(i)
-    cbmf(i) = max(0.0, (1.0-damp)*cbmf(i)+0.1*alpha*dtmin(i))
-    IF ((work(i)==0.0) .AND. (cbmf(i)==0.0)) THEN
-      iflag(i) = 3
-    END IF
-  END DO
-
-  RETURN
-END SUBROUTINE cv_closure
-
-SUBROUTINE cv_mixing(nloc, ncum, nd, icb, nk, inb, inb1, ph, t, q, qs, u, v, &
-    h, lv, qnk, hp, tv, tvp, ep, clw, cbmf, m, ment, qent, uent, vent, nent, &
-    sij, elij)
-  IMPLICIT NONE
-
-  include "cvthermo.h"
-  include "cvparam.h"
-
-  ! inputs:
-  INTEGER ncum, nd, nloc
-  INTEGER icb(nloc), inb(nloc), inb1(nloc), nk(nloc)
-  REAL cbmf(nloc), qnk(nloc)
-  REAL ph(nloc, nd+1)
-  REAL t(nloc, nd), q(nloc, nd), qs(nloc, nd), lv(nloc, nd)
-  REAL u(nloc, nd), v(nloc, nd), h(nloc, nd), hp(nloc, nd)
-  REAL tv(nloc, nd), tvp(nloc, nd), ep(nloc, nd), clw(nloc, nd)
-
-  ! outputs:
-  INTEGER nent(nloc, nd)
-  REAL m(nloc, nd), ment(nloc, nd, nd), qent(nloc, nd, nd)
-  REAL uent(nloc, nd, nd), vent(nloc, nd, nd)
-  REAL sij(nloc, nd, nd), elij(nloc, nd, nd)
-
-  ! local variables:
-  INTEGER i, j, k, ij
-  INTEGER num1, num2
-  REAL dbo, qti, bf2, anum, denom, dei, altem, cwat, stemp
-  REAL alt, qp1, smid, sjmin, sjmax, delp, delm
-  REAL work(nloc), asij(nloc), smin(nloc), scrit(nloc)
-  REAL bsum(nloc, nd)
-  LOGICAL lwork(nloc)
-
-  ! =====================================================================
-  ! --- INITIALIZE VARIOUS ARRAYS USED IN THE COMPUTATIONS
-  ! =====================================================================
-
-  DO i = 1, ncum*nlp
-    nent(i, 1) = 0
-    m(i, 1) = 0.0
-  END DO
-
-  DO k = 1, nlp
-    DO j = 1, nlp
-      DO i = 1, ncum
-        qent(i, k, j) = q(i, j)
-        uent(i, k, j) = u(i, j)
-        vent(i, k, j) = v(i, j)
-        elij(i, k, j) = 0.0
-        ment(i, k, j) = 0.0
-        sij(i, k, j) = 0.0
-      END DO
-    END DO
-  END DO
-
-  ! -------------------------------------------------------------------
-  ! --- Calculate rates of mixing,  m(i)
-  ! -------------------------------------------------------------------
-
-  CALL zilch(work, ncum)
-
-  DO j = minorig + 1, nl
-    DO i = 1, ncum
-      IF ((j>=(icb(i)+1)) .AND. (j<=inb(i))) THEN
-        k = min(j, inb1(i))
-        dbo = abs(tv(i,k+1)-tvp(i,k+1)-tv(i,k-1)+tvp(i,k-1)) + &
-          entp*0.04*(ph(i,k)-ph(i,k+1))
-        work(i) = work(i) + dbo
-        m(i, j) = cbmf(i)*dbo
-      END IF
-    END DO
-  END DO
-  DO k = minorig + 1, nl
-    DO i = 1, ncum
-      IF ((k>=(icb(i)+1)) .AND. (k<=inb(i))) THEN
-        m(i, k) = m(i, k)/work(i)
-      END IF
-    END DO
-  END DO
-
-
-  ! =====================================================================
-  ! --- CALCULATE ENTRAINED AIR MASS FLUX (ment), TOTAL WATER MIXING
-  ! --- RATIO (QENT), TOTAL CONDENSED WATER (elij), AND MIXING
-  ! --- FRACTION (sij)
-  ! =====================================================================
-
-
-  DO i = minorig + 1, nl
-    DO j = minorig + 1, nl
-      DO ij = 1, ncum
-        IF ((i>=(icb(ij)+1)) .AND. (j>=icb(ij)) .AND. (i<=inb(ij)) .AND. (j<= &
-            inb(ij))) THEN
-          qti = qnk(ij) - ep(ij, i)*clw(ij, i)
-          bf2 = 1. + lv(ij, j)*lv(ij, j)*qs(ij, j)/(rrv*t(ij,j)*t(ij,j)*cpd)
-          anum = h(ij, j) - hp(ij, i) + (cpv-cpd)*t(ij, j)*(qti-q(ij,j))
-          denom = h(ij, i) - hp(ij, i) + (cpd-cpv)*(q(ij,i)-qti)*t(ij, j)
-          dei = denom
-          IF (abs(dei)<0.01) dei = 0.01
-          sij(ij, i, j) = anum/dei
-          sij(ij, i, i) = 1.0
-          altem = sij(ij, i, j)*q(ij, i) + (1.-sij(ij,i,j))*qti - qs(ij, j)
-          altem = altem/bf2
-          cwat = clw(ij, j)*(1.-ep(ij,j))
-          stemp = sij(ij, i, j)
-          IF ((stemp<0.0 .OR. stemp>1.0 .OR. altem>cwat) .AND. j>i) THEN
-            anum = anum - lv(ij, j)*(qti-qs(ij,j)-cwat*bf2)
-            denom = denom + lv(ij, j)*(q(ij,i)-qti)
-            IF (abs(denom)<0.01) denom = 0.01
-            sij(ij, i, j) = anum/denom
-            altem = sij(ij, i, j)*q(ij, i) + (1.-sij(ij,i,j))*qti - qs(ij, j)
-            altem = altem - (bf2-1.)*cwat
-          END IF
-          IF (sij(ij,i,j)>0.0 .AND. sij(ij,i,j)<0.9) THEN
-            qent(ij, i, j) = sij(ij, i, j)*q(ij, i) + (1.-sij(ij,i,j))*qti
-            uent(ij, i, j) = sij(ij, i, j)*u(ij, i) + &
-              (1.-sij(ij,i,j))*u(ij, nk(ij))
-            vent(ij, i, j) = sij(ij, i, j)*v(ij, i) + &
-              (1.-sij(ij,i,j))*v(ij, nk(ij))
-            elij(ij, i, j) = altem
-            elij(ij, i, j) = max(0.0, elij(ij,i,j))
-            ment(ij, i, j) = m(ij, i)/(1.-sij(ij,i,j))
-            nent(ij, i) = nent(ij, i) + 1
-          END IF
-          sij(ij, i, j) = max(0.0, sij(ij,i,j))
-          sij(ij, i, j) = min(1.0, sij(ij,i,j))
-        END IF
-      END DO
-    END DO
-
-    ! ***   If no air can entrain at level i assume that updraft detrains
-    ! ***
-    ! ***   at that level and calculate detrained air flux and properties
-    ! ***
-
-    DO ij = 1, ncum
-      IF ((i>=(icb(ij)+1)) .AND. (i<=inb(ij)) .AND. (nent(ij,i)==0)) THEN
-        ment(ij, i, i) = m(ij, i)
-        qent(ij, i, i) = q(ij, nk(ij)) - ep(ij, i)*clw(ij, i)
-        uent(ij, i, i) = u(ij, nk(ij))
-        vent(ij, i, i) = v(ij, nk(ij))
-        elij(ij, i, i) = clw(ij, i)
-        sij(ij, i, i) = 1.0
-      END IF
-    END DO
-  END DO
-
-  DO i = 1, ncum
-    sij(i, inb(i), inb(i)) = 1.0
-  END DO
-
-  ! =====================================================================
-  ! ---  NORMALIZE ENTRAINED AIR MASS FLUXES
-  ! ---  TO REPRESENT EQUAL PROBABILITIES OF MIXING
-  ! =====================================================================
-
-  CALL zilch(bsum, ncum*nlp)
-  DO ij = 1, ncum
-    lwork(ij) = .FALSE.
-  END DO
-  DO i = minorig + 1, nl
-
-    num1 = 0
-    DO ij = 1, ncum
-      IF ((i>=icb(ij)+1) .AND. (i<=inb(ij))) num1 = num1 + 1
-    END DO
-    IF (num1<=0) GO TO 789
-
-    DO ij = 1, ncum
-      IF ((i>=icb(ij)+1) .AND. (i<=inb(ij))) THEN
-        lwork(ij) = (nent(ij,i)/=0)
-        qp1 = q(ij, nk(ij)) - ep(ij, i)*clw(ij, i)
-        anum = h(ij, i) - hp(ij, i) - lv(ij, i)*(qp1-qs(ij,i))
-        denom = h(ij, i) - hp(ij, i) + lv(ij, i)*(q(ij,i)-qp1)
-        IF (abs(denom)<0.01) denom = 0.01
-        scrit(ij) = anum/denom
-        alt = qp1 - qs(ij, i) + scrit(ij)*(q(ij,i)-qp1)
-        IF (scrit(ij)<0.0 .OR. alt<0.0) scrit(ij) = 1.0
-        asij(ij) = 0.0
-        smin(ij) = 1.0
-      END IF
-    END DO
-    DO j = minorig, nl
-
-      num2 = 0
-      DO ij = 1, ncum
-        IF ((i>=icb(ij)+1) .AND. (i<=inb(ij)) .AND. (j>=icb( &
-          ij)) .AND. (j<=inb(ij)) .AND. lwork(ij)) num2 = num2 + 1
-      END DO
-      IF (num2<=0) GO TO 783
-
-      DO ij = 1, ncum
-        IF ((i>=icb(ij)+1) .AND. (i<=inb(ij)) .AND. (j>=icb( &
-            ij)) .AND. (j<=inb(ij)) .AND. lwork(ij)) THEN
-          IF (sij(ij,i,j)>0.0 .AND. sij(ij,i,j)<0.9) THEN
-            IF (j>i) THEN
-              smid = min(sij(ij,i,j), scrit(ij))
-              sjmax = smid
-              sjmin = smid
-              IF (smid<smin(ij) .AND. sij(ij,i,j+1)<smid) THEN
-                smin(ij) = smid
-                sjmax = min(sij(ij,i,j+1), sij(ij,i,j), scrit(ij))
-                sjmin = max(sij(ij,i,j-1), sij(ij,i,j))
-                sjmin = min(sjmin, scrit(ij))
-              END IF
-            ELSE
-              sjmax = max(sij(ij,i,j+1), scrit(ij))
-              smid = max(sij(ij,i,j), scrit(ij))
-              sjmin = 0.0
-              IF (j>1) sjmin = sij(ij, i, j-1)
-              sjmin = max(sjmin, scrit(ij))
-            END IF
-            delp = abs(sjmax-smid)
-            delm = abs(sjmin-smid)
-            asij(ij) = asij(ij) + (delp+delm)*(ph(ij,j)-ph(ij,j+1))
-            ment(ij, i, j) = ment(ij, i, j)*(delp+delm)*(ph(ij,j)-ph(ij,j+1))
-          END IF
-        END IF
-      END DO
-783 END DO
-    DO ij = 1, ncum
-      IF ((i>=icb(ij)+1) .AND. (i<=inb(ij)) .AND. lwork(ij)) THEN
-        asij(ij) = max(1.0E-21, asij(ij))
-        asij(ij) = 1.0/asij(ij)
-        bsum(ij, i) = 0.0
-      END IF
-    END DO
-    DO j = minorig, nl + 1
-      DO ij = 1, ncum
-        IF ((i>=icb(ij)+1) .AND. (i<=inb(ij)) .AND. (j>=icb( &
-            ij)) .AND. (j<=inb(ij)) .AND. lwork(ij)) THEN
-          ment(ij, i, j) = ment(ij, i, j)*asij(ij)
-          bsum(ij, i) = bsum(ij, i) + ment(ij, i, j)
-        END IF
-      END DO
-    END DO
-    DO ij = 1, ncum
-      IF ((i>=icb(ij)+1) .AND. (i<=inb(ij)) .AND. (bsum(ij, &
-          i)<1.0E-18) .AND. lwork(ij)) THEN
-        nent(ij, i) = 0
-        ment(ij, i, i) = m(ij, i)
-        qent(ij, i, i) = q(ij, nk(ij)) - ep(ij, i)*clw(ij, i)
-        uent(ij, i, i) = u(ij, nk(ij))
-        vent(ij, i, i) = v(ij, nk(ij))
-        elij(ij, i, i) = clw(ij, i)
-        sij(ij, i, i) = 1.0
-      END IF
-    END DO
-789 END DO
-
-  RETURN
-END SUBROUTINE cv_mixing
-
-SUBROUTINE cv_unsat(nloc, ncum, nd, inb, t, q, qs, gz, u, v, p, ph, h, lv, &
-    ep, sigp, clw, m, ment, elij, iflag, mp, qp, up, vp, wt, water, evap)
-  IMPLICIT NONE
-
-
-  include "cvthermo.h"
-  include "cvparam.h"
-
-  ! inputs:
-  INTEGER ncum, nd, nloc
-  INTEGER inb(nloc)
-  REAL t(nloc, nd), q(nloc, nd), qs(nloc, nd)
-  REAL gz(nloc, nd), u(nloc, nd), v(nloc, nd)
-  REAL p(nloc, nd), ph(nloc, nd+1), h(nloc, nd)
-  REAL lv(nloc, nd), ep(nloc, nd), sigp(nloc, nd), clw(nloc, nd)
-  REAL m(nloc, nd), ment(nloc, nd, nd), elij(nloc, nd, nd)
-
-  ! outputs:
-  INTEGER iflag(nloc) ! also an input
-  REAL mp(nloc, nd), qp(nloc, nd), up(nloc, nd), vp(nloc, nd)
-  REAL water(nloc, nd), evap(nloc, nd), wt(nloc, nd)
-
-  ! local variables:
-  INTEGER i, j, k, ij, num1
-  INTEGER jtt(nloc)
-  REAL awat, coeff, qsm, afac, sigt, b6, c6, revap
-  REAL dhdp, fac, qstm, rat
-  REAL wdtrain(nloc)
-  LOGICAL lwork(nloc)
-
-  ! =====================================================================
-  ! --- PRECIPITATING DOWNDRAFT CALCULATION
-  ! =====================================================================
-
-  ! Initializations:
-
-  DO i = 1, ncum
-    DO k = 1, nl + 1
-      wt(i, k) = omtsnow
-      mp(i, k) = 0.0
-      evap(i, k) = 0.0
-      water(i, k) = 0.0
-    END DO
-  END DO
-
-  DO i = 1, ncum
-    qp(i, 1) = q(i, 1)
-    up(i, 1) = u(i, 1)
-    vp(i, 1) = v(i, 1)
-  END DO
-
-  DO k = 2, nl + 1
-    DO i = 1, ncum
-      qp(i, k) = q(i, k-1)
-      up(i, k) = u(i, k-1)
-      vp(i, k) = v(i, k-1)
-    END DO
-  END DO
-
-
-  ! ***  Check whether ep(inb)=0, if so, skip precipitating    ***
-  ! ***             downdraft calculation                      ***
-
-
-  ! ***  Integrate liquid water equation to find condensed water   ***
-  ! ***                and condensed water flux                    ***
-
-
-  DO i = 1, ncum
-    jtt(i) = 2
-    IF (ep(i,inb(i))<=0.0001) iflag(i) = 2
-    IF (iflag(i)==0) THEN
-      lwork(i) = .TRUE.
-    ELSE
-      lwork(i) = .FALSE.
-    END IF
-  END DO
-
-  ! ***                    Begin downdraft loop                    ***
-
-
-  CALL zilch(wdtrain, ncum)
-  DO i = nl + 1, 1, -1
-
-    num1 = 0
-    DO ij = 1, ncum
-      IF ((i<=inb(ij)) .AND. lwork(ij)) num1 = num1 + 1
-    END DO
-    IF (num1<=0) GO TO 899
-
-
-    ! ***        Calculate detrained precipitation             ***
-
-    DO ij = 1, ncum
-      IF ((i<=inb(ij)) .AND. (lwork(ij))) THEN
-        wdtrain(ij) = g*ep(ij, i)*m(ij, i)*clw(ij, i)
-      END IF
-    END DO
-
-    IF (i>1) THEN
-      DO j = 1, i - 1
-        DO ij = 1, ncum
-          IF ((i<=inb(ij)) .AND. (lwork(ij))) THEN
-            awat = elij(ij, j, i) - (1.-ep(ij,i))*clw(ij, i)
-            awat = max(0.0, awat)
-            wdtrain(ij) = wdtrain(ij) + g*awat*ment(ij, j, i)
-          END IF
-        END DO
-      END DO
-    END IF
-
-    ! ***    Find rain water and evaporation using provisional   ***
-    ! ***              estimates of qp(i)and qp(i-1)             ***
-
-
-    ! ***  Value of terminal velocity and coeffecient of evaporation for snow
-    ! ***
-
-    DO ij = 1, ncum
-      IF ((i<=inb(ij)) .AND. (lwork(ij))) THEN
-        coeff = coeffs
-        wt(ij, i) = omtsnow
-
-        ! ***  Value of terminal velocity and coeffecient of evaporation for
-        ! rain   ***
-
-        IF (t(ij,i)>273.0) THEN
-          coeff = coeffr
-          wt(ij, i) = omtrain
-        END IF
-        qsm = 0.5*(q(ij,i)+qp(ij,i+1))
-        afac = coeff*ph(ij, i)*(qs(ij,i)-qsm)/(1.0E4+2.0E3*ph(ij,i)*qs(ij,i))
-        afac = max(afac, 0.0)
-        sigt = sigp(ij, i)
-        sigt = max(0.0, sigt)
-        sigt = min(1.0, sigt)
-        b6 = 100.*(ph(ij,i)-ph(ij,i+1))*sigt*afac/wt(ij, i)
-        c6 = (water(ij,i+1)*wt(ij,i+1)+wdtrain(ij)/sigd)/wt(ij, i)
-        revap = 0.5*(-b6+sqrt(b6*b6+4.*c6))
-        evap(ij, i) = sigt*afac*revap
-        water(ij, i) = revap*revap
-
-        ! ***  Calculate precipitating downdraft mass flux under     ***
-        ! ***              hydrostatic approximation                 ***
-
-        IF (i>1) THEN
-          dhdp = (h(ij,i)-h(ij,i-1))/(p(ij,i-1)-p(ij,i))
-          dhdp = max(dhdp, 10.0)
-          mp(ij, i) = 100.*ginv*lv(ij, i)*sigd*evap(ij, i)/dhdp
-          mp(ij, i) = max(mp(ij,i), 0.0)
-
-          ! ***   Add small amount of inertia to downdraft              ***
-
-          fac = 20.0/(ph(ij,i-1)-ph(ij,i))
-          mp(ij, i) = (fac*mp(ij,i+1)+mp(ij,i))/(1.+fac)
-
-          ! ***      Force mp to decrease linearly to zero
-          ! ***
-          ! ***      between about 950 mb and the surface
-          ! ***
-
-          IF (p(ij,i)>(0.949*p(ij,1))) THEN
-            jtt(ij) = max(jtt(ij), i)
-            mp(ij, i) = mp(ij, jtt(ij))*(p(ij,1)-p(ij,i))/ &
-              (p(ij,1)-p(ij,jtt(ij)))
-          END IF
-        END IF
-
-        ! ***       Find mixing ratio of precipitating downdraft     ***
-
-        IF (i/=inb(ij)) THEN
-          IF (i==1) THEN
-            qstm = qs(ij, 1)
-          ELSE
-            qstm = qs(ij, i-1)
-          END IF
-          IF (mp(ij,i)>mp(ij,i+1)) THEN
-            rat = mp(ij, i+1)/mp(ij, i)
-            qp(ij, i) = qp(ij, i+1)*rat + q(ij, i)*(1.0-rat) + &
-              100.*ginv*sigd*(ph(ij,i)-ph(ij,i+1))*(evap(ij,i)/mp(ij,i))
-            up(ij, i) = up(ij, i+1)*rat + u(ij, i)*(1.-rat)
-            vp(ij, i) = vp(ij, i+1)*rat + v(ij, i)*(1.-rat)
-          ELSE
-            IF (mp(ij,i+1)>0.0) THEN
-              qp(ij, i) = (gz(ij,i+1)-gz(ij,i)+qp(ij,i+1)*(lv(ij,i+1)+t(ij, &
-                i+1)*(cl-cpd))+cpd*(t(ij,i+1)-t(ij, &
-                i)))/(lv(ij,i)+t(ij,i)*(cl-cpd))
-              up(ij, i) = up(ij, i+1)
-              vp(ij, i) = vp(ij, i+1)
-            END IF
-          END IF
-          qp(ij, i) = min(qp(ij,i), qstm)
-          qp(ij, i) = max(qp(ij,i), 0.0)
-        END IF
-      END IF
-    END DO
-899 END DO
-
-  RETURN
-END SUBROUTINE cv_unsat
-
-SUBROUTINE cv_yield(nloc, ncum, nd, nk, icb, inb, delt, t, q, u, v, gz, p, &
-    ph, h, hp, lv, cpn, ep, clw, frac, m, mp, qp, up, vp, wt, water, evap, &
-    ment, qent, uent, vent, nent, elij, tv, tvp, iflag, wd, qprime, tprime, &
-    precip, cbmf, ft, fq, fu, fv, ma, qcondc)
-  IMPLICIT NONE
-
-  include "cvthermo.h"
-  include "cvparam.h"
-
-  ! inputs
-  INTEGER ncum, nd, nloc
-  INTEGER nk(nloc), icb(nloc), inb(nloc)
-  INTEGER nent(nloc, nd)
-  REAL delt
-  REAL t(nloc, nd), q(nloc, nd), u(nloc, nd), v(nloc, nd)
-  REAL gz(nloc, nd)
-  REAL p(nloc, nd), ph(nloc, nd+1), h(nloc, nd)
-  REAL hp(nloc, nd), lv(nloc, nd)
-  REAL cpn(nloc, nd), ep(nloc, nd), clw(nloc, nd), frac(nloc)
-  REAL m(nloc, nd), mp(nloc, nd), qp(nloc, nd)
-  REAL up(nloc, nd), vp(nloc, nd)
-  REAL wt(nloc, nd), water(nloc, nd), evap(nloc, nd)
-  REAL ment(nloc, nd, nd), qent(nloc, nd, nd), elij(nloc, nd, nd)
-  REAL uent(nloc, nd, nd), vent(nloc, nd, nd)
-  REAL tv(nloc, nd), tvp(nloc, nd)
-
-  ! outputs
-  INTEGER iflag(nloc) ! also an input
-  REAL cbmf(nloc) ! also an input
-  REAL wd(nloc), tprime(nloc), qprime(nloc)
-  REAL precip(nloc)
-  REAL ft(nloc, nd), fq(nloc, nd), fu(nloc, nd), fv(nloc, nd)
-  REAL ma(nloc, nd)
-  REAL qcondc(nloc, nd)
-
-  ! local variables
-  INTEGER i, j, ij, k, num1
-  REAL dpinv, cpinv, awat, fqold, ftold, fuold, fvold, delti
-  REAL work(nloc), am(nloc), amp1(nloc), ad(nloc)
-  REAL ents(nloc), uav(nloc), vav(nloc), lvcp(nloc, nd)
-  REAL qcond(nloc, nd), nqcond(nloc, nd), wa(nloc, nd) ! cld
-  REAL siga(nloc, nd), ax(nloc, nd), mac(nloc, nd) ! cld
-
-
-  ! -- initializations:
-
-  delti = 1.0/delt
-
-  DO i = 1, ncum
-    precip(i) = 0.0
-    wd(i) = 0.0
-    tprime(i) = 0.0
-    qprime(i) = 0.0
-    DO k = 1, nl + 1
-      ft(i, k) = 0.0
-      fu(i, k) = 0.0
-      fv(i, k) = 0.0
-      fq(i, k) = 0.0
-      lvcp(i, k) = lv(i, k)/cpn(i, k)
-      qcondc(i, k) = 0.0 ! cld
-      qcond(i, k) = 0.0 ! cld
-      nqcond(i, k) = 0.0 ! cld
-    END DO
-  END DO
-
-
-  ! ***  Calculate surface precipitation in mm/day     ***
-
-  DO i = 1, ncum
-    IF (iflag(i)<=1) THEN
-      ! c            precip(i)=precip(i)+wt(i,1)*sigd*water(i,1)*3600.*24000.
-      ! c     &                /(rowl*g)
-      ! c            precip(i)=precip(i)*delt/86400.
-      precip(i) = wt(i, 1)*sigd*water(i, 1)*86400/g
-    END IF
-  END DO
-
-
-  ! ***  Calculate downdraft velocity scale and surface temperature and  ***
-  ! ***                    water vapor fluctuations                      ***
-
-  DO i = 1, ncum
-    wd(i) = betad*abs(mp(i,icb(i)))*0.01*rrd*t(i, icb(i))/(sigd*p(i,icb(i)))
-    qprime(i) = 0.5*(qp(i,1)-q(i,1))
-    tprime(i) = lv0*qprime(i)/cpd
-  END DO
-
-  ! ***  Calculate tendencies of lowest level potential temperature  ***
-  ! ***                      and mixing ratio                        ***
-
-  DO i = 1, ncum
-    work(i) = 0.01/(ph(i,1)-ph(i,2))
-    am(i) = 0.0
-  END DO
-  DO k = 2, nl
-    DO i = 1, ncum
-      IF ((nk(i)==1) .AND. (k<=inb(i)) .AND. (nk(i)==1)) THEN
-        am(i) = am(i) + m(i, k)
-      END IF
-    END DO
-  END DO
-  DO i = 1, ncum
-    IF ((g*work(i)*am(i))>=delti) iflag(i) = 1
-    ft(i, 1) = ft(i, 1) + g*work(i)*am(i)*(t(i,2)-t(i,1)+(gz(i,2)-gz(i, &
-      1))/cpn(i,1))
-    ft(i, 1) = ft(i, 1) - lvcp(i, 1)*sigd*evap(i, 1)
-    ft(i, 1) = ft(i, 1) + sigd*wt(i, 2)*(cl-cpd)*water(i, 2)*(t(i,2)-t(i,1))* &
-      work(i)/cpn(i, 1)
-    fq(i, 1) = fq(i, 1) + g*mp(i, 2)*(qp(i,2)-q(i,1))*work(i) + &
-      sigd*evap(i, 1)
-    fq(i, 1) = fq(i, 1) + g*am(i)*(q(i,2)-q(i,1))*work(i)
-    fu(i, 1) = fu(i, 1) + g*work(i)*(mp(i,2)*(up(i,2)-u(i,1))+am(i)*(u(i, &
-      2)-u(i,1)))
-    fv(i, 1) = fv(i, 1) + g*work(i)*(mp(i,2)*(vp(i,2)-v(i,1))+am(i)*(v(i, &
-      2)-v(i,1)))
-  END DO
-  DO j = 2, nl
-    DO i = 1, ncum
-      IF (j<=inb(i)) THEN
-        fq(i, 1) = fq(i, 1) + g*work(i)*ment(i, j, 1)*(qent(i,j,1)-q(i,1))
-        fu(i, 1) = fu(i, 1) + g*work(i)*ment(i, j, 1)*(uent(i,j,1)-u(i,1))
-        fv(i, 1) = fv(i, 1) + g*work(i)*ment(i, j, 1)*(vent(i,j,1)-v(i,1))
-      END IF
-    END DO
-  END DO
-
-  ! ***  Calculate tendencies of potential temperature and mixing ratio  ***
-  ! ***               at levels above the lowest level                   ***
-
-  ! ***  First find the net saturated updraft and downdraft mass fluxes  ***
-  ! ***                      through each level                          ***
-
-  DO i = 2, nl + 1
-
-    num1 = 0
-    DO ij = 1, ncum
-      IF (i<=inb(ij)) num1 = num1 + 1
-    END DO
-    IF (num1<=0) GO TO 1500
-
-    CALL zilch(amp1, ncum)
-    CALL zilch(ad, ncum)
-
-    DO k = i + 1, nl + 1
-      DO ij = 1, ncum
-        IF ((i>=nk(ij)) .AND. (i<=inb(ij)) .AND. (k<=(inb(ij)+1))) THEN
-          amp1(ij) = amp1(ij) + m(ij, k)
-        END IF
-      END DO
-    END DO
-
-    DO k = 1, i
-      DO j = i + 1, nl + 1
-        DO ij = 1, ncum
-          IF ((j<=(inb(ij)+1)) .AND. (i<=inb(ij))) THEN
-            amp1(ij) = amp1(ij) + ment(ij, k, j)
-          END IF
-        END DO
-      END DO
-    END DO
-    DO k = 1, i - 1
-      DO j = i, nl + 1
-        DO ij = 1, ncum
-          IF ((i<=inb(ij)) .AND. (j<=inb(ij))) THEN
-            ad(ij) = ad(ij) + ment(ij, j, k)
-          END IF
-        END DO
-      END DO
-    END DO
-
-    DO ij = 1, ncum
-      IF (i<=inb(ij)) THEN
-        dpinv = 0.01/(ph(ij,i)-ph(ij,i+1))
-        cpinv = 1.0/cpn(ij, i)
-
-        ft(ij, i) = ft(ij, i) + g*dpinv*(amp1(ij)*(t(ij,i+1)-t(ij, &
-          i)+(gz(ij,i+1)-gz(ij,i))*cpinv)-ad(ij)*(t(ij,i)-t(ij, &
-          i-1)+(gz(ij,i)-gz(ij,i-1))*cpinv)) - sigd*lvcp(ij, i)*evap(ij, i)
-        ft(ij, i) = ft(ij, i) + g*dpinv*ment(ij, i, i)*(hp(ij,i)-h(ij,i)+t(ij &
-          ,i)*(cpv-cpd)*(q(ij,i)-qent(ij,i,i)))*cpinv
-        ft(ij, i) = ft(ij, i) + sigd*wt(ij, i+1)*(cl-cpd)*water(ij, i+1)*(t( &
-          ij,i+1)-t(ij,i))*dpinv*cpinv
-        fq(ij, i) = fq(ij, i) + g*dpinv*(amp1(ij)*(q(ij,i+1)-q(ij, &
-          i))-ad(ij)*(q(ij,i)-q(ij,i-1)))
-        fu(ij, i) = fu(ij, i) + g*dpinv*(amp1(ij)*(u(ij,i+1)-u(ij, &
-          i))-ad(ij)*(u(ij,i)-u(ij,i-1)))
-        fv(ij, i) = fv(ij, i) + g*dpinv*(amp1(ij)*(v(ij,i+1)-v(ij, &
-          i))-ad(ij)*(v(ij,i)-v(ij,i-1)))
-      END IF
-    END DO
-    DO k = 1, i - 1
-      DO ij = 1, ncum
-        IF (i<=inb(ij)) THEN
-          awat = elij(ij, k, i) - (1.-ep(ij,i))*clw(ij, i)
-          awat = max(awat, 0.0)
-          fq(ij, i) = fq(ij, i) + g*dpinv*ment(ij, k, i)*(qent(ij,k,i)-awat-q &
-            (ij,i))
-          fu(ij, i) = fu(ij, i) + g*dpinv*ment(ij, k, i)*(uent(ij,k,i)-u(ij,i &
-            ))
-          fv(ij, i) = fv(ij, i) + g*dpinv*ment(ij, k, i)*(vent(ij,k,i)-v(ij,i &
-            ))
-          ! (saturated updrafts resulting from mixing)               ! cld
-          qcond(ij, i) = qcond(ij, i) + (elij(ij,k,i)-awat) ! cld
-          nqcond(ij, i) = nqcond(ij, i) + 1. ! cld
-        END IF
-      END DO
-    END DO
-    DO k = i, nl + 1
-      DO ij = 1, ncum
-        IF ((i<=inb(ij)) .AND. (k<=inb(ij))) THEN
-          fq(ij, i) = fq(ij, i) + g*dpinv*ment(ij, k, i)*(qent(ij,k,i)-q(ij,i &
-            ))
-          fu(ij, i) = fu(ij, i) + g*dpinv*ment(ij, k, i)*(uent(ij,k,i)-u(ij,i &
-            ))
-          fv(ij, i) = fv(ij, i) + g*dpinv*ment(ij, k, i)*(vent(ij,k,i)-v(ij,i &
-            ))
-        END IF
-      END DO
-    END DO
-    DO ij = 1, ncum
-      IF (i<=inb(ij)) THEN
-        fq(ij, i) = fq(ij, i) + sigd*evap(ij, i) + g*(mp(ij,i+1)*(qp(ij, &
-          i+1)-q(ij,i))-mp(ij,i)*(qp(ij,i)-q(ij,i-1)))*dpinv
-        fu(ij, i) = fu(ij, i) + g*(mp(ij,i+1)*(up(ij,i+1)-u(ij, &
-          i))-mp(ij,i)*(up(ij,i)-u(ij,i-1)))*dpinv
-        fv(ij, i) = fv(ij, i) + g*(mp(ij,i+1)*(vp(ij,i+1)-v(ij, &
-          i))-mp(ij,i)*(vp(ij,i)-v(ij,i-1)))*dpinv
-        ! (saturated downdrafts resulting from mixing)               ! cld
-        DO k = i + 1, inb(ij) ! cld
-          qcond(ij, i) = qcond(ij, i) + elij(ij, k, i) ! cld
-          nqcond(ij, i) = nqcond(ij, i) + 1. ! cld
-        END DO ! cld
-        ! (particular case: no detraining level is found)            ! cld
-        IF (nent(ij,i)==0) THEN ! cld
-          qcond(ij, i) = qcond(ij, i) + (1.-ep(ij,i))*clw(ij, i) ! cld
-          nqcond(ij, i) = nqcond(ij, i) + 1. ! cld
-        END IF ! cld
-        IF (nqcond(ij,i)/=0.) THEN ! cld
-          qcond(ij, i) = qcond(ij, i)/nqcond(ij, i) ! cld
-        END IF ! cld
-      END IF
-    END DO
-1500 END DO
-
-  ! *** Adjust tendencies at top of convection layer to reflect  ***
-  ! ***       actual position of the level zero cape             ***
-
-  DO ij = 1, ncum
-    fqold = fq(ij, inb(ij))
-    fq(ij, inb(ij)) = fq(ij, inb(ij))*(1.-frac(ij))
-    fq(ij, inb(ij)-1) = fq(ij, inb(ij)-1) + frac(ij)*fqold*((ph(ij, &
-      inb(ij))-ph(ij,inb(ij)+1))/(ph(ij,inb(ij)-1)-ph(ij, &
-      inb(ij))))*lv(ij, inb(ij))/lv(ij, inb(ij)-1)
-    ftold = ft(ij, inb(ij))
-    ft(ij, inb(ij)) = ft(ij, inb(ij))*(1.-frac(ij))
-    ft(ij, inb(ij)-1) = ft(ij, inb(ij)-1) + frac(ij)*ftold*((ph(ij, &
-      inb(ij))-ph(ij,inb(ij)+1))/(ph(ij,inb(ij)-1)-ph(ij, &
-      inb(ij))))*cpn(ij, inb(ij))/cpn(ij, inb(ij)-1)
-    fuold = fu(ij, inb(ij))
-    fu(ij, inb(ij)) = fu(ij, inb(ij))*(1.-frac(ij))
-    fu(ij, inb(ij)-1) = fu(ij, inb(ij)-1) + frac(ij)*fuold*((ph(ij, &
-      inb(ij))-ph(ij,inb(ij)+1))/(ph(ij,inb(ij)-1)-ph(ij,inb(ij))))
-    fvold = fv(ij, inb(ij))
-    fv(ij, inb(ij)) = fv(ij, inb(ij))*(1.-frac(ij))
-    fv(ij, inb(ij)-1) = fv(ij, inb(ij)-1) + frac(ij)*fvold*((ph(ij, &
-      inb(ij))-ph(ij,inb(ij)+1))/(ph(ij,inb(ij)-1)-ph(ij,inb(ij))))
-  END DO
-
-  ! ***   Very slightly adjust tendencies to force exact   ***
-  ! ***     enthalpy, momentum and tracer conservation     ***
-
-  DO ij = 1, ncum
-    ents(ij) = 0.0
-    uav(ij) = 0.0
-    vav(ij) = 0.0
-    DO i = 1, inb(ij)
-      ents(ij) = ents(ij) + (cpn(ij,i)*ft(ij,i)+lv(ij,i)*fq(ij,i))*(ph(ij,i)- &
-        ph(ij,i+1))
-      uav(ij) = uav(ij) + fu(ij, i)*(ph(ij,i)-ph(ij,i+1))
-      vav(ij) = vav(ij) + fv(ij, i)*(ph(ij,i)-ph(ij,i+1))
-    END DO
-  END DO
-  DO ij = 1, ncum
-    ents(ij) = ents(ij)/(ph(ij,1)-ph(ij,inb(ij)+1))
-    uav(ij) = uav(ij)/(ph(ij,1)-ph(ij,inb(ij)+1))
-    vav(ij) = vav(ij)/(ph(ij,1)-ph(ij,inb(ij)+1))
-  END DO
-  DO ij = 1, ncum
-    DO i = 1, inb(ij)
-      ft(ij, i) = ft(ij, i) - ents(ij)/cpn(ij, i)
-      fu(ij, i) = (1.-cu)*(fu(ij,i)-uav(ij))
-      fv(ij, i) = (1.-cu)*(fv(ij,i)-vav(ij))
-    END DO
-  END DO
-
-  DO k = 1, nl + 1
-    DO i = 1, ncum
-      IF ((q(i,k)+delt*fq(i,k))<0.0) iflag(i) = 10
-    END DO
-  END DO
-
-
-  DO i = 1, ncum
-    IF (iflag(i)>2) THEN
-      precip(i) = 0.0
-      cbmf(i) = 0.0
-    END IF
-  END DO
-  DO k = 1, nl
-    DO i = 1, ncum
-      IF (iflag(i)>2) THEN
-        ft(i, k) = 0.0
-        fq(i, k) = 0.0
-        fu(i, k) = 0.0
-        fv(i, k) = 0.0
-        qcondc(i, k) = 0.0 ! cld
-      END IF
-    END DO
-  END DO
-
-  DO k = 1, nl + 1
-    DO i = 1, ncum
-      ma(i, k) = 0.
-    END DO
-  END DO
-  DO k = nl, 1, -1
-    DO i = 1, ncum
-      ma(i, k) = ma(i, k+1) + m(i, k)
-    END DO
-  END DO
-
-
-  ! *** diagnose the in-cloud mixing ratio   ***            ! cld
-  ! ***           of condensed water         ***            ! cld
-  ! ! cld
-  DO ij = 1, ncum ! cld
-    DO i = 1, nd ! cld
-      mac(ij, i) = 0.0 ! cld
-      wa(ij, i) = 0.0 ! cld
-      siga(ij, i) = 0.0 ! cld
-    END DO ! cld
-    DO i = nk(ij), inb(ij) ! cld
-      DO k = i + 1, inb(ij) + 1 ! cld
-        mac(ij, i) = mac(ij, i) + m(ij, k) ! cld
-      END DO ! cld
-    END DO ! cld
-    DO i = icb(ij), inb(ij) - 1 ! cld
-      ax(ij, i) = 0. ! cld
-      DO j = icb(ij), i ! cld
-        ax(ij, i) = ax(ij, i) + rrd*(tvp(ij,j)-tv(ij,j)) & ! cld
-          *(ph(ij,j)-ph(ij,j+1))/p(ij, j) ! cld
-      END DO ! cld
-      IF (ax(ij,i)>0.0) THEN ! cld
-        wa(ij, i) = sqrt(2.*ax(ij,i)) ! cld
-      END IF ! cld
-    END DO ! cld
-    DO i = 1, nl ! cld
-      IF (wa(ij,i)>0.0) &          ! cld
-        siga(ij, i) = mac(ij, i)/wa(ij, i) & ! cld
-        *rrd*tvp(ij, i)/p(ij, i)/100./delta ! cld
-      siga(ij, i) = min(siga(ij,i), 1.0) ! cld
-      qcondc(ij, i) = siga(ij, i)*clw(ij, i)*(1.-ep(ij,i)) & ! cld
-        +(1.-siga(ij,i))*qcond(ij, i) ! cld
-    END DO ! cld
-  END DO ! cld
-
-  RETURN
-END SUBROUTINE cv_yield
-
-SUBROUTINE cv_uncompress(nloc, len, ncum, nd, idcum, iflag, precip, cbmf, ft, &
-    fq, fu, fv, ma, qcondc, iflag1, precip1, cbmf1, ft1, fq1, fu1, fv1, ma1, &
-    qcondc1)
-  IMPLICIT NONE
-
-  include "cvparam.h"
-
-  ! inputs:
-  INTEGER len, ncum, nd, nloc
-  INTEGER idcum(nloc)
-  INTEGER iflag(nloc)
-  REAL precip(nloc), cbmf(nloc)
-  REAL ft(nloc, nd), fq(nloc, nd), fu(nloc, nd), fv(nloc, nd)
-  REAL ma(nloc, nd)
-  REAL qcondc(nloc, nd) !cld
-
-  ! outputs:
-  INTEGER iflag1(len)
-  REAL precip1(len), cbmf1(len)
-  REAL ft1(len, nd), fq1(len, nd), fu1(len, nd), fv1(len, nd)
-  REAL ma1(len, nd)
-  REAL qcondc1(len, nd) !cld
-
-  ! local variables:
-  INTEGER i, k
-
-  DO i = 1, ncum
-    precip1(idcum(i)) = precip(i)
-    cbmf1(idcum(i)) = cbmf(i)
-    iflag1(idcum(i)) = iflag(i)
-  END DO
-
-  DO k = 1, nl
-    DO i = 1, ncum
-      ft1(idcum(i), k) = ft(i, k)
-      fq1(idcum(i), k) = fq(i, k)
-      fu1(idcum(i), k) = fu(i, k)
-      fv1(idcum(i), k) = fv(i, k)
-      ma1(idcum(i), k) = ma(i, k)
-      qcondc1(idcum(i), k) = qcondc(i, k)
-    END DO
-  END DO
-
-  RETURN
-END SUBROUTINE cv_uncompress
-
Index: /LMDZ6/trunk/libf/phylmd/cv_routines.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cv_routines.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/cv_routines.f90	(revision 5268)
@@ -0,0 +1,1713 @@
+
+! $Id$
+
+SUBROUTINE cv_param(nd)
+  IMPLICIT NONE
+
+  ! ------------------------------------------------------------
+  ! Set parameters for convectL
+  ! (includes microphysical parameters and parameters that
+  ! control the rate of approach to quasi-equilibrium)
+  ! ------------------------------------------------------------
+
+  ! *** ELCRIT IS THE AUTOCONVERSION THERSHOLD WATER CONTENT (gm/gm) ***
+  ! ***  TLCRIT IS CRITICAL TEMPERATURE BELOW WHICH THE AUTO-        ***
+  ! ***       CONVERSION THRESHOLD IS ASSUMED TO BE ZERO             ***
+  ! ***     (THE AUTOCONVERSION THRESHOLD VARIES LINEARLY            ***
+  ! ***               BETWEEN 0 C AND TLCRIT)                        ***
+  ! ***   ENTP IS THE COEFFICIENT OF MIXING IN THE ENTRAINMENT       ***
+  ! ***                       FORMULATION                            ***
+  ! ***  SIGD IS THE FRACTIONAL AREA COVERED BY UNSATURATED DNDRAFT  ***
+  ! ***  SIGS IS THE FRACTION OF PRECIPITATION FALLING OUTSIDE       ***
+  ! ***                        OF CLOUD                              ***
+  ! ***        OMTRAIN IS THE ASSUMED FALL SPEED (P/s) OF RAIN       ***
+  ! ***     OMTSNOW IS THE ASSUMED FALL SPEED (P/s) OF SNOW          ***
+  ! ***  COEFFR IS A COEFFICIENT GOVERNING THE RATE OF EVAPORATION   ***
+  ! ***                          OF RAIN                             ***
+  ! ***  COEFFS IS A COEFFICIENT GOVERNING THE RATE OF EVAPORATION   ***
+  ! ***                          OF SNOW                             ***
+  ! ***     CU IS THE COEFFICIENT GOVERNING CONVECTIVE MOMENTUM      ***
+  ! ***                         TRANSPORT                            ***
+  ! ***    DTMAX IS THE MAXIMUM NEGATIVE TEMPERATURE PERTURBATION    ***
+  ! ***        A LIFTED PARCEL IS ALLOWED TO HAVE BELOW ITS LFC      ***
+  ! ***    ALPHA AND DAMP ARE PARAMETERS THAT CONTROL THE RATE OF    ***
+  ! ***                 APPROACH TO QUASI-EQUILIBRIUM                ***
+  ! ***   (THEIR STANDARD VALUES ARE  0.20 AND 0.1, RESPECTIVELY)    ***
+  ! ***                   (DAMP MUST BE LESS THAN 1)                 ***
+
+  include "cvparam.h"
+  INTEGER nd
+  CHARACTER (LEN=20) :: modname = 'cv_routines'
+  CHARACTER (LEN=80) :: abort_message
+
+  ! noff: integer limit for convection (nd-noff)
+  ! minorig: First level of convection
+
+  noff = 2
+  minorig = 2
+
+  nl = nd - noff
+  nlp = nl + 1
+  nlm = nl - 1
+
+  elcrit = 0.0011
+  tlcrit = -55.0
+  entp = 1.5
+  sigs = 0.12
+  sigd = 0.05
+  omtrain = 50.0
+  omtsnow = 5.5
+  coeffr = 1.0
+  coeffs = 0.8
+  dtmax = 0.9
+
+  cu = 0.70
+
+  betad = 10.0
+
+  damp = 0.1
+  alpha = 0.2
+
+  delta = 0.01 ! cld
+
+  RETURN
+END SUBROUTINE cv_param
+
+SUBROUTINE cv_prelim(len, nd, ndp1, t, q, p, ph, lv, cpn, tv, gz, h, hm)
+  IMPLICIT NONE
+
+  ! =====================================================================
+  ! --- CALCULATE ARRAYS OF GEOPOTENTIAL, HEAT CAPACITY & STATIC ENERGY
+  ! =====================================================================
+
+  ! inputs:
+  INTEGER len, nd, ndp1
+  REAL t(len, nd), q(len, nd), p(len, nd), ph(len, ndp1)
+
+  ! outputs:
+  REAL lv(len, nd), cpn(len, nd), tv(len, nd)
+  REAL gz(len, nd), h(len, nd), hm(len, nd)
+
+  ! local variables:
+  INTEGER k, i
+  REAL cpx(len, nd)
+
+  include "cvthermo.h"
+  include "cvparam.h"
+
+
+  DO k = 1, nlp
+    DO i = 1, len
+      lv(i, k) = lv0 - clmcpv*(t(i,k)-t0)
+      cpn(i, k) = cpd*(1.0-q(i,k)) + cpv*q(i, k)
+      cpx(i, k) = cpd*(1.0-q(i,k)) + cl*q(i, k)
+      tv(i, k) = t(i, k)*(1.0+q(i,k)*epsim1)
+    END DO
+  END DO
+
+  ! gz = phi at the full levels (same as p).
+
+  DO i = 1, len
+    gz(i, 1) = 0.0
+  END DO
+  DO k = 2, nlp
+    DO i = 1, len
+      gz(i, k) = gz(i, k-1) + hrd*(tv(i,k-1)+tv(i,k))*(p(i,k-1)-p(i,k))/ph(i, &
+        k)
+    END DO
+  END DO
+
+  ! h  = phi + cpT (dry static energy).
+  ! hm = phi + cp(T-Tbase)+Lq
+
+  DO k = 1, nlp
+    DO i = 1, len
+      h(i, k) = gz(i, k) + cpn(i, k)*t(i, k)
+      hm(i, k) = gz(i, k) + cpx(i, k)*(t(i,k)-t(i,1)) + lv(i, k)*q(i, k)
+    END DO
+  END DO
+
+  RETURN
+END SUBROUTINE cv_prelim
+
+SUBROUTINE cv_feed(len, nd, t, q, qs, p, hm, gz, nk, icb, icbmax, iflag, tnk, &
+    qnk, gznk, plcl)
+  IMPLICIT NONE
+
+  ! ================================================================
+  ! Purpose: CONVECTIVE FEED
+  ! ================================================================
+
+  include "cvparam.h"
+
+  ! inputs:
+  INTEGER len, nd
+  REAL t(len, nd), q(len, nd), qs(len, nd), p(len, nd)
+  REAL hm(len, nd), gz(len, nd)
+
+  ! outputs:
+  INTEGER iflag(len), nk(len), icb(len), icbmax
+  REAL tnk(len), qnk(len), gznk(len), plcl(len)
+
+  ! local variables:
+  INTEGER i, k
+  INTEGER ihmin(len)
+  REAL work(len)
+  REAL pnk(len), qsnk(len), rh(len), chi(len)
+
+  ! -------------------------------------------------------------------
+  ! --- Find level of minimum moist static energy
+  ! --- If level of minimum moist static energy coincides with
+  ! --- or is lower than minimum allowable parcel origin level,
+  ! --- set iflag to 6.
+  ! -------------------------------------------------------------------
+
+  DO i = 1, len
+    work(i) = 1.0E12
+    ihmin(i) = nl
+  END DO
+  DO k = 2, nlp
+    DO i = 1, len
+      IF ((hm(i,k)<work(i)) .AND. (hm(i,k)<hm(i,k-1))) THEN
+        work(i) = hm(i, k)
+        ihmin(i) = k
+      END IF
+    END DO
+  END DO
+  DO i = 1, len
+    ihmin(i) = min(ihmin(i), nlm)
+    IF (ihmin(i)<=minorig) THEN
+      iflag(i) = 6
+    END IF
+  END DO
+
+  ! -------------------------------------------------------------------
+  ! --- Find that model level below the level of minimum moist static
+  ! --- energy that has the maximum value of moist static energy
+  ! -------------------------------------------------------------------
+
+  DO i = 1, len
+    work(i) = hm(i, minorig)
+    nk(i) = minorig
+  END DO
+  DO k = minorig + 1, nl
+    DO i = 1, len
+      IF ((hm(i,k)>work(i)) .AND. (k<=ihmin(i))) THEN
+        work(i) = hm(i, k)
+        nk(i) = k
+      END IF
+    END DO
+  END DO
+  ! -------------------------------------------------------------------
+  ! --- Check whether parcel level temperature and specific humidity
+  ! --- are reasonable
+  ! -------------------------------------------------------------------
+  DO i = 1, len
+    IF (((t(i,nk(i))<250.0) .OR. (q(i,nk(i))<=0.0) .OR. (p(i,ihmin(i))< &
+      400.0)) .AND. (iflag(i)==0)) iflag(i) = 7
+  END DO
+  ! -------------------------------------------------------------------
+  ! --- Calculate lifted condensation level of air at parcel origin level
+  ! --- (Within 0.2% of formula of Bolton, MON. WEA. REV.,1980)
+  ! -------------------------------------------------------------------
+  DO i = 1, len
+    tnk(i) = t(i, nk(i))
+    qnk(i) = q(i, nk(i))
+    gznk(i) = gz(i, nk(i))
+    pnk(i) = p(i, nk(i))
+    qsnk(i) = qs(i, nk(i))
+
+    rh(i) = qnk(i)/qsnk(i)
+    rh(i) = min(1.0, rh(i))
+    chi(i) = tnk(i)/(1669.0-122.0*rh(i)-tnk(i))
+    plcl(i) = pnk(i)*(rh(i)**chi(i))
+    IF (((plcl(i)<200.0) .OR. (plcl(i)>=2000.0)) .AND. (iflag(i)==0)) iflag(i &
+      ) = 8
+  END DO
+  ! -------------------------------------------------------------------
+  ! --- Calculate first level above lcl (=icb)
+  ! -------------------------------------------------------------------
+  DO i = 1, len
+    icb(i) = nlm
+  END DO
+
+  DO k = minorig, nl
+    DO i = 1, len
+      IF ((k>=(nk(i)+1)) .AND. (p(i,k)<plcl(i))) icb(i) = min(icb(i), k)
+    END DO
+  END DO
+
+  DO i = 1, len
+    IF ((icb(i)>=nlm) .AND. (iflag(i)==0)) iflag(i) = 9
+  END DO
+
+  ! Compute icbmax.
+
+  icbmax = 2
+  DO i = 1, len
+    icbmax = max(icbmax, icb(i))
+  END DO
+
+  RETURN
+END SUBROUTINE cv_feed
+
+SUBROUTINE cv_undilute1(len, nd, t, q, qs, gz, p, nk, icb, icbmax, tp, tvp, &
+    clw)
+  IMPLICIT NONE
+
+  include "cvthermo.h"
+  include "cvparam.h"
+
+  ! inputs:
+  INTEGER len, nd
+  INTEGER nk(len), icb(len), icbmax
+  REAL t(len, nd), q(len, nd), qs(len, nd), gz(len, nd)
+  REAL p(len, nd)
+
+  ! outputs:
+  REAL tp(len, nd), tvp(len, nd), clw(len, nd)
+
+  ! local variables:
+  INTEGER i, k
+  REAL tg, qg, alv, s, ahg, tc, denom, es, rg
+  REAL ah0(len), cpp(len)
+  REAL tnk(len), qnk(len), gznk(len), ticb(len), gzicb(len)
+
+  ! -------------------------------------------------------------------
+  ! --- Calculates the lifted parcel virtual temperature at nk,
+  ! --- the actual temperature, and the adiabatic
+  ! --- liquid water content. The procedure is to solve the equation.
+  ! cp*tp+L*qp+phi=cp*tnk+L*qnk+gznk.
+  ! -------------------------------------------------------------------
+
+  DO i = 1, len
+    tnk(i) = t(i, nk(i))
+    qnk(i) = q(i, nk(i))
+    gznk(i) = gz(i, nk(i))
+    ticb(i) = t(i, icb(i))
+    gzicb(i) = gz(i, icb(i))
+  END DO
+
+  ! ***  Calculate certain parcel quantities, including static energy   ***
+
+  DO i = 1, len
+    ah0(i) = (cpd*(1.-qnk(i))+cl*qnk(i))*tnk(i) + qnk(i)*(lv0-clmcpv*(tnk(i)- &
+      273.15)) + gznk(i)
+    cpp(i) = cpd*(1.-qnk(i)) + qnk(i)*cpv
+  END DO
+
+  ! ***   Calculate lifted parcel quantities below cloud base   ***
+
+  DO k = minorig, icbmax - 1
+    DO i = 1, len
+      tp(i, k) = tnk(i) - (gz(i,k)-gznk(i))/cpp(i)
+      tvp(i, k) = tp(i, k)*(1.+qnk(i)*epsi)
+    END DO
+  END DO
+
+  ! ***  Find lifted parcel quantities above cloud base    ***
+
+  DO i = 1, len
+    tg = ticb(i)
+    qg = qs(i, icb(i))
+    alv = lv0 - clmcpv*(ticb(i)-t0)
+
+    ! First iteration.
+
+    s = cpd + alv*alv*qg/(rrv*ticb(i)*ticb(i))
+    s = 1./s
+    ahg = cpd*tg + (cl-cpd)*qnk(i)*ticb(i) + alv*qg + gzicb(i)
+    tg = tg + s*(ah0(i)-ahg)
+    tg = max(tg, 35.0)
+    tc = tg - t0
+    denom = 243.5 + tc
+    IF (tc>=0.0) THEN
+      es = 6.112*exp(17.67*tc/denom)
+    ELSE
+      es = exp(23.33086-6111.72784/tg+0.15215*log(tg))
+    END IF
+    qg = eps*es/(p(i,icb(i))-es*(1.-eps))
+
+    ! Second iteration.
+
+    s = cpd + alv*alv*qg/(rrv*ticb(i)*ticb(i))
+    s = 1./s
+    ahg = cpd*tg + (cl-cpd)*qnk(i)*ticb(i) + alv*qg + gzicb(i)
+    tg = tg + s*(ah0(i)-ahg)
+    tg = max(tg, 35.0)
+    tc = tg - t0
+    denom = 243.5 + tc
+    IF (tc>=0.0) THEN
+      es = 6.112*exp(17.67*tc/denom)
+    ELSE
+      es = exp(23.33086-6111.72784/tg+0.15215*log(tg))
+    END IF
+    qg = eps*es/(p(i,icb(i))-es*(1.-eps))
+
+    alv = lv0 - clmcpv*(ticb(i)-273.15)
+    tp(i, icb(i)) = (ah0(i)-(cl-cpd)*qnk(i)*ticb(i)-gz(i,icb(i))-alv*qg)/cpd
+    clw(i, icb(i)) = qnk(i) - qg
+    clw(i, icb(i)) = max(0.0, clw(i,icb(i)))
+    rg = qg/(1.-qnk(i))
+    tvp(i, icb(i)) = tp(i, icb(i))*(1.+rg*epsi)
+  END DO
+
+  DO k = minorig, icbmax
+    DO i = 1, len
+      tvp(i, k) = tvp(i, k) - tp(i, k)*qnk(i)
+    END DO
+  END DO
+
+  RETURN
+END SUBROUTINE cv_undilute1
+
+SUBROUTINE cv_trigger(len, nd, icb, cbmf, tv, tvp, iflag)
+  IMPLICIT NONE
+
+  ! -------------------------------------------------------------------
+  ! --- Test for instability.
+  ! --- If there was no convection at last time step and parcel
+  ! --- is stable at icb, then set iflag to 4.
+  ! -------------------------------------------------------------------
+
+  include "cvparam.h"
+
+  ! inputs:
+  INTEGER len, nd, icb(len)
+  REAL cbmf(len), tv(len, nd), tvp(len, nd)
+
+  ! outputs:
+  INTEGER iflag(len) ! also an input
+
+  ! local variables:
+  INTEGER i
+
+
+  DO i = 1, len
+    IF ((cbmf(i)==0.0) .AND. (iflag(i)==0) .AND. (tvp(i, &
+      icb(i))<=(tv(i,icb(i))-dtmax))) iflag(i) = 4
+  END DO
+
+  RETURN
+END SUBROUTINE cv_trigger
+
+SUBROUTINE cv_compress(len, nloc, ncum, nd, iflag1, nk1, icb1, cbmf1, plcl1, &
+    tnk1, qnk1, gznk1, t1, q1, qs1, u1, v1, gz1, h1, lv1, cpn1, p1, ph1, tv1, &
+    tp1, tvp1, clw1, iflag, nk, icb, cbmf, plcl, tnk, qnk, gznk, t, q, qs, u, &
+    v, gz, h, lv, cpn, p, ph, tv, tp, tvp, clw, dph)
+  USE print_control_mod, ONLY: lunout
+  IMPLICIT NONE
+
+  include "cvparam.h"
+
+  ! inputs:
+  INTEGER len, ncum, nd, nloc
+  INTEGER iflag1(len), nk1(len), icb1(len)
+  REAL cbmf1(len), plcl1(len), tnk1(len), qnk1(len), gznk1(len)
+  REAL t1(len, nd), q1(len, nd), qs1(len, nd), u1(len, nd), v1(len, nd)
+  REAL gz1(len, nd), h1(len, nd), lv1(len, nd), cpn1(len, nd)
+  REAL p1(len, nd), ph1(len, nd+1), tv1(len, nd), tp1(len, nd)
+  REAL tvp1(len, nd), clw1(len, nd)
+
+  ! outputs:
+  INTEGER iflag(nloc), nk(nloc), icb(nloc)
+  REAL cbmf(nloc), plcl(nloc), tnk(nloc), qnk(nloc), gznk(nloc)
+  REAL t(nloc, nd), q(nloc, nd), qs(nloc, nd), u(nloc, nd), v(nloc, nd)
+  REAL gz(nloc, nd), h(nloc, nd), lv(nloc, nd), cpn(nloc, nd)
+  REAL p(nloc, nd), ph(nloc, nd+1), tv(nloc, nd), tp(nloc, nd)
+  REAL tvp(nloc, nd), clw(nloc, nd)
+  REAL dph(nloc, nd)
+
+  ! local variables:
+  INTEGER i, k, nn
+  CHARACTER (LEN=20) :: modname = 'cv_compress'
+  CHARACTER (LEN=80) :: abort_message
+
+
+  DO k = 1, nl + 1
+    nn = 0
+    DO i = 1, len
+      IF (iflag1(i)==0) THEN
+        nn = nn + 1
+        t(nn, k) = t1(i, k)
+        q(nn, k) = q1(i, k)
+        qs(nn, k) = qs1(i, k)
+        u(nn, k) = u1(i, k)
+        v(nn, k) = v1(i, k)
+        gz(nn, k) = gz1(i, k)
+        h(nn, k) = h1(i, k)
+        lv(nn, k) = lv1(i, k)
+        cpn(nn, k) = cpn1(i, k)
+        p(nn, k) = p1(i, k)
+        ph(nn, k) = ph1(i, k)
+        tv(nn, k) = tv1(i, k)
+        tp(nn, k) = tp1(i, k)
+        tvp(nn, k) = tvp1(i, k)
+        clw(nn, k) = clw1(i, k)
+      END IF
+    END DO
+  END DO
+
+  IF (nn/=ncum) THEN
+    WRITE (lunout, *) 'strange! nn not equal to ncum: ', nn, ncum
+    abort_message = ''
+    CALL abort_physic(modname, abort_message, 1)
+  END IF
+
+  nn = 0
+  DO i = 1, len
+    IF (iflag1(i)==0) THEN
+      nn = nn + 1
+      cbmf(nn) = cbmf1(i)
+      plcl(nn) = plcl1(i)
+      tnk(nn) = tnk1(i)
+      qnk(nn) = qnk1(i)
+      gznk(nn) = gznk1(i)
+      nk(nn) = nk1(i)
+      icb(nn) = icb1(i)
+      iflag(nn) = iflag1(i)
+    END IF
+  END DO
+
+  DO k = 1, nl
+    DO i = 1, ncum
+      dph(i, k) = ph(i, k) - ph(i, k+1)
+    END DO
+  END DO
+
+  RETURN
+END SUBROUTINE cv_compress
+
+SUBROUTINE cv_undilute2(nloc, ncum, nd, icb, nk, tnk, qnk, gznk, t, q, qs, &
+    gz, p, dph, h, tv, lv, inb, inb1, tp, tvp, clw, hp, ep, sigp, frac)
+  IMPLICIT NONE
+
+  ! ---------------------------------------------------------------------
+  ! Purpose:
+  ! FIND THE REST OF THE LIFTED PARCEL TEMPERATURES
+  ! &
+  ! COMPUTE THE PRECIPITATION EFFICIENCIES AND THE
+  ! FRACTION OF PRECIPITATION FALLING OUTSIDE OF CLOUD
+  ! &
+  ! FIND THE LEVEL OF NEUTRAL BUOYANCY
+  ! ---------------------------------------------------------------------
+
+  include "cvthermo.h"
+  include "cvparam.h"
+
+  ! inputs:
+  INTEGER ncum, nd, nloc
+  INTEGER icb(nloc), nk(nloc)
+  REAL t(nloc, nd), q(nloc, nd), qs(nloc, nd), gz(nloc, nd)
+  REAL p(nloc, nd), dph(nloc, nd)
+  REAL tnk(nloc), qnk(nloc), gznk(nloc)
+  REAL lv(nloc, nd), tv(nloc, nd), h(nloc, nd)
+
+  ! outputs:
+  INTEGER inb(nloc), inb1(nloc)
+  REAL tp(nloc, nd), tvp(nloc, nd), clw(nloc, nd)
+  REAL ep(nloc, nd), sigp(nloc, nd), hp(nloc, nd)
+  REAL frac(nloc)
+
+  ! local variables:
+  INTEGER i, k
+  REAL tg, qg, ahg, alv, s, tc, es, denom, rg, tca, elacrit
+  REAL by, defrac
+  REAL ah0(nloc), cape(nloc), capem(nloc), byp(nloc)
+  LOGICAL lcape(nloc)
+
+  ! =====================================================================
+  ! --- SOME INITIALIZATIONS
+  ! =====================================================================
+
+  DO k = 1, nl
+    DO i = 1, ncum
+      ep(i, k) = 0.0
+      sigp(i, k) = sigs
+    END DO
+  END DO
+
+  ! =====================================================================
+  ! --- FIND THE REST OF THE LIFTED PARCEL TEMPERATURES
+  ! =====================================================================
+
+  ! ---       The procedure is to solve the equation.
+  ! cp*tp+L*qp+phi=cp*tnk+L*qnk+gznk.
+
+  ! ***  Calculate certain parcel quantities, including static energy   ***
+
+
+  DO i = 1, ncum
+    ah0(i) = (cpd*(1.-qnk(i))+cl*qnk(i))*tnk(i) + qnk(i)*(lv0-clmcpv*(tnk(i)- &
+      t0)) + gznk(i)
+  END DO
+
+
+  ! ***  Find lifted parcel quantities above cloud base    ***
+
+
+  DO k = minorig + 1, nl
+    DO i = 1, ncum
+      IF (k>=(icb(i)+1)) THEN
+        tg = t(i, k)
+        qg = qs(i, k)
+        alv = lv0 - clmcpv*(t(i,k)-t0)
+
+        ! First iteration.
+
+        s = cpd + alv*alv*qg/(rrv*t(i,k)*t(i,k))
+        s = 1./s
+        ahg = cpd*tg + (cl-cpd)*qnk(i)*t(i, k) + alv*qg + gz(i, k)
+        tg = tg + s*(ah0(i)-ahg)
+        tg = max(tg, 35.0)
+        tc = tg - t0
+        denom = 243.5 + tc
+        IF (tc>=0.0) THEN
+          es = 6.112*exp(17.67*tc/denom)
+        ELSE
+          es = exp(23.33086-6111.72784/tg+0.15215*log(tg))
+        END IF
+        qg = eps*es/(p(i,k)-es*(1.-eps))
+
+        ! Second iteration.
+
+        s = cpd + alv*alv*qg/(rrv*t(i,k)*t(i,k))
+        s = 1./s
+        ahg = cpd*tg + (cl-cpd)*qnk(i)*t(i, k) + alv*qg + gz(i, k)
+        tg = tg + s*(ah0(i)-ahg)
+        tg = max(tg, 35.0)
+        tc = tg - t0
+        denom = 243.5 + tc
+        IF (tc>=0.0) THEN
+          es = 6.112*exp(17.67*tc/denom)
+        ELSE
+          es = exp(23.33086-6111.72784/tg+0.15215*log(tg))
+        END IF
+        qg = eps*es/(p(i,k)-es*(1.-eps))
+
+        alv = lv0 - clmcpv*(t(i,k)-t0)
+        ! print*,'cpd dans convect2 ',cpd
+        ! print*,'tp(i,k),ah0(i),cl,cpd,qnk(i),t(i,k),gz(i,k),alv,qg,cpd'
+        ! print*,tp(i,k),ah0(i),cl,cpd,qnk(i),t(i,k),gz(i,k),alv,qg,cpd
+        tp(i, k) = (ah0(i)-(cl-cpd)*qnk(i)*t(i,k)-gz(i,k)-alv*qg)/cpd
+        ! if (.not.cpd.gt.1000.) then
+        ! print*,'CPD=',cpd
+        ! stop
+        ! endif
+        clw(i, k) = qnk(i) - qg
+        clw(i, k) = max(0.0, clw(i,k))
+        rg = qg/(1.-qnk(i))
+        tvp(i, k) = tp(i, k)*(1.+rg*epsi)
+      END IF
+    END DO
+  END DO
+
+  ! =====================================================================
+  ! --- SET THE PRECIPITATION EFFICIENCIES AND THE FRACTION OF
+  ! --- PRECIPITATION FALLING OUTSIDE OF CLOUD
+  ! --- THESE MAY BE FUNCTIONS OF TP(I), P(I) AND CLW(I)
+  ! =====================================================================
+
+  DO k = minorig + 1, nl
+    DO i = 1, ncum
+      IF (k>=(nk(i)+1)) THEN
+        tca = tp(i, k) - t0
+        IF (tca>=0.0) THEN
+          elacrit = elcrit
+        ELSE
+          elacrit = elcrit*(1.0-tca/tlcrit)
+        END IF
+        elacrit = max(elacrit, 0.0)
+        ep(i, k) = 1.0 - elacrit/max(clw(i,k), 1.0E-8)
+        ep(i, k) = max(ep(i,k), 0.0)
+        ep(i, k) = min(ep(i,k), 1.0)
+        sigp(i, k) = sigs
+      END IF
+    END DO
+  END DO
+
+  ! =====================================================================
+  ! --- CALCULATE VIRTUAL TEMPERATURE AND LIFTED PARCEL
+  ! --- VIRTUAL TEMPERATURE
+  ! =====================================================================
+
+  DO k = minorig + 1, nl
+    DO i = 1, ncum
+      IF (k>=(icb(i)+1)) THEN
+        tvp(i, k) = tvp(i, k)*(1.0-qnk(i)+ep(i,k)*clw(i,k))
+        ! print*,'i,k,tvp(i,k),qnk(i),ep(i,k),clw(i,k)'
+        ! print*, i,k,tvp(i,k),qnk(i),ep(i,k),clw(i,k)
+      END IF
+    END DO
+  END DO
+  DO i = 1, ncum
+    tvp(i, nlp) = tvp(i, nl) - (gz(i,nlp)-gz(i,nl))/cpd
+  END DO
+
+  ! =====================================================================
+  ! --- FIND THE FIRST MODEL LEVEL (INB1) ABOVE THE PARCEL'S
+  ! --- HIGHEST LEVEL OF NEUTRAL BUOYANCY
+  ! --- AND THE HIGHEST LEVEL OF POSITIVE CAPE (INB)
+  ! =====================================================================
+
+  DO i = 1, ncum
+    cape(i) = 0.0
+    capem(i) = 0.0
+    inb(i) = icb(i) + 1
+    inb1(i) = inb(i)
+  END DO
+
+  ! Originial Code
+
+  ! do 530 k=minorig+1,nl-1
+  ! do 520 i=1,ncum
+  ! if(k.ge.(icb(i)+1))then
+  ! by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k)
+  ! byp=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1)
+  ! cape(i)=cape(i)+by
+  ! if(by.ge.0.0)inb1(i)=k+1
+  ! if(cape(i).gt.0.0)then
+  ! inb(i)=k+1
+  ! capem(i)=cape(i)
+  ! endif
+  ! endif
+  ! 520    continue
+  ! 530  continue
+  ! do 540 i=1,ncum
+  ! byp=(tvp(i,nl)-tv(i,nl))*dph(i,nl)/p(i,nl)
+  ! cape(i)=capem(i)+byp
+  ! defrac=capem(i)-cape(i)
+  ! defrac=max(defrac,0.001)
+  ! frac(i)=-cape(i)/defrac
+  ! frac(i)=min(frac(i),1.0)
+  ! frac(i)=max(frac(i),0.0)
+  ! 540   continue
+
+  ! K Emanuel fix
+
+  ! call zilch(byp,ncum)
+  ! do 530 k=minorig+1,nl-1
+  ! do 520 i=1,ncum
+  ! if(k.ge.(icb(i)+1))then
+  ! by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k)
+  ! cape(i)=cape(i)+by
+  ! if(by.ge.0.0)inb1(i)=k+1
+  ! if(cape(i).gt.0.0)then
+  ! inb(i)=k+1
+  ! capem(i)=cape(i)
+  ! byp(i)=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1)
+  ! endif
+  ! endif
+  ! 520    continue
+  ! 530  continue
+  ! do 540 i=1,ncum
+  ! inb(i)=max(inb(i),inb1(i))
+  ! cape(i)=capem(i)+byp(i)
+  ! defrac=capem(i)-cape(i)
+  ! defrac=max(defrac,0.001)
+  ! frac(i)=-cape(i)/defrac
+  ! frac(i)=min(frac(i),1.0)
+  ! frac(i)=max(frac(i),0.0)
+  ! 540   continue
+
+  ! J Teixeira fix
+
+  CALL zilch(byp, ncum)
+  DO i = 1, ncum
+    lcape(i) = .TRUE.
+  END DO
+  DO k = minorig + 1, nl - 1
+    DO i = 1, ncum
+      IF (cape(i)<0.0) lcape(i) = .FALSE.
+      IF ((k>=(icb(i)+1)) .AND. lcape(i)) THEN
+        by = (tvp(i,k)-tv(i,k))*dph(i, k)/p(i, k)
+        byp(i) = (tvp(i,k+1)-tv(i,k+1))*dph(i, k+1)/p(i, k+1)
+        cape(i) = cape(i) + by
+        IF (by>=0.0) inb1(i) = k + 1
+        IF (cape(i)>0.0) THEN
+          inb(i) = k + 1
+          capem(i) = cape(i)
+        END IF
+      END IF
+    END DO
+  END DO
+  DO i = 1, ncum
+    cape(i) = capem(i) + byp(i)
+    defrac = capem(i) - cape(i)
+    defrac = max(defrac, 0.001)
+    frac(i) = -cape(i)/defrac
+    frac(i) = min(frac(i), 1.0)
+    frac(i) = max(frac(i), 0.0)
+  END DO
+
+  ! =====================================================================
+  ! ---   CALCULATE LIQUID WATER STATIC ENERGY OF LIFTED PARCEL
+  ! =====================================================================
+
+  ! initialization:
+  DO i = 1, ncum*nlp
+    hp(i, 1) = h(i, 1)
+  END DO
+
+  DO k = minorig + 1, nl
+    DO i = 1, ncum
+      IF ((k>=icb(i)) .AND. (k<=inb(i))) THEN
+        hp(i, k) = h(i, nk(i)) + (lv(i,k)+(cpd-cpv)*t(i,k))*ep(i, k)*clw(i, k &
+          )
+      END IF
+    END DO
+  END DO
+
+  RETURN
+END SUBROUTINE cv_undilute2
+
+SUBROUTINE cv_closure(nloc, ncum, nd, nk, icb, tv, tvp, p, ph, dph, plcl, &
+    cpn, iflag, cbmf)
+  IMPLICIT NONE
+
+  ! inputs:
+  INTEGER ncum, nd, nloc
+  INTEGER nk(nloc), icb(nloc)
+  REAL tv(nloc, nd), tvp(nloc, nd), p(nloc, nd), dph(nloc, nd)
+  REAL ph(nloc, nd+1) ! caution nd instead ndp1 to be consistent...
+  REAL plcl(nloc), cpn(nloc, nd)
+
+  ! outputs:
+  INTEGER iflag(nloc)
+  REAL cbmf(nloc) ! also an input
+
+  ! local variables:
+  INTEGER i, k, icbmax
+  REAL dtpbl(nloc), dtmin(nloc), tvpplcl(nloc), tvaplcl(nloc)
+  REAL work(nloc)
+
+  include "cvthermo.h"
+  include "cvparam.h"
+
+  ! -------------------------------------------------------------------
+  ! Compute icbmax.
+  ! -------------------------------------------------------------------
+
+  icbmax = 2
+  DO i = 1, ncum
+    icbmax = max(icbmax, icb(i))
+  END DO
+
+  ! =====================================================================
+  ! ---  CALCULATE CLOUD BASE MASS FLUX
+  ! =====================================================================
+
+  ! tvpplcl = parcel temperature lifted adiabatically from level
+  ! icb-1 to the LCL.
+  ! tvaplcl = virtual temperature at the LCL.
+
+  DO i = 1, ncum
+    dtpbl(i) = 0.0
+    tvpplcl(i) = tvp(i, icb(i)-1) - rrd*tvp(i, icb(i)-1)*(p(i,icb(i)-1)-plcl( &
+      i))/(cpn(i,icb(i)-1)*p(i,icb(i)-1))
+    tvaplcl(i) = tv(i, icb(i)) + (tvp(i,icb(i))-tvp(i,icb(i)+1))*(plcl(i)-p(i &
+      ,icb(i)))/(p(i,icb(i))-p(i,icb(i)+1))
+  END DO
+
+  ! -------------------------------------------------------------------
+  ! --- Interpolate difference between lifted parcel and
+  ! --- environmental temperatures to lifted condensation level
+  ! -------------------------------------------------------------------
+
+  ! dtpbl = average of tvp-tv in the PBL (k=nk to icb-1).
+
+  DO k = minorig, icbmax
+    DO i = 1, ncum
+      IF ((k>=nk(i)) .AND. (k<=(icb(i)-1))) THEN
+        dtpbl(i) = dtpbl(i) + (tvp(i,k)-tv(i,k))*dph(i, k)
+      END IF
+    END DO
+  END DO
+  DO i = 1, ncum
+    dtpbl(i) = dtpbl(i)/(ph(i,nk(i))-ph(i,icb(i)))
+    dtmin(i) = tvpplcl(i) - tvaplcl(i) + dtmax + dtpbl(i)
+  END DO
+
+  ! -------------------------------------------------------------------
+  ! --- Adjust cloud base mass flux
+  ! -------------------------------------------------------------------
+
+  DO i = 1, ncum
+    work(i) = cbmf(i)
+    cbmf(i) = max(0.0, (1.0-damp)*cbmf(i)+0.1*alpha*dtmin(i))
+    IF ((work(i)==0.0) .AND. (cbmf(i)==0.0)) THEN
+      iflag(i) = 3
+    END IF
+  END DO
+
+  RETURN
+END SUBROUTINE cv_closure
+
+SUBROUTINE cv_mixing(nloc, ncum, nd, icb, nk, inb, inb1, ph, t, q, qs, u, v, &
+    h, lv, qnk, hp, tv, tvp, ep, clw, cbmf, m, ment, qent, uent, vent, nent, &
+    sij, elij)
+  IMPLICIT NONE
+
+  include "cvthermo.h"
+  include "cvparam.h"
+
+  ! inputs:
+  INTEGER ncum, nd, nloc
+  INTEGER icb(nloc), inb(nloc), inb1(nloc), nk(nloc)
+  REAL cbmf(nloc), qnk(nloc)
+  REAL ph(nloc, nd+1)
+  REAL t(nloc, nd), q(nloc, nd), qs(nloc, nd), lv(nloc, nd)
+  REAL u(nloc, nd), v(nloc, nd), h(nloc, nd), hp(nloc, nd)
+  REAL tv(nloc, nd), tvp(nloc, nd), ep(nloc, nd), clw(nloc, nd)
+
+  ! outputs:
+  INTEGER nent(nloc, nd)
+  REAL m(nloc, nd), ment(nloc, nd, nd), qent(nloc, nd, nd)
+  REAL uent(nloc, nd, nd), vent(nloc, nd, nd)
+  REAL sij(nloc, nd, nd), elij(nloc, nd, nd)
+
+  ! local variables:
+  INTEGER i, j, k, ij
+  INTEGER num1, num2
+  REAL dbo, qti, bf2, anum, denom, dei, altem, cwat, stemp
+  REAL alt, qp1, smid, sjmin, sjmax, delp, delm
+  REAL work(nloc), asij(nloc), smin(nloc), scrit(nloc)
+  REAL bsum(nloc, nd)
+  LOGICAL lwork(nloc)
+
+  ! =====================================================================
+  ! --- INITIALIZE VARIOUS ARRAYS USED IN THE COMPUTATIONS
+  ! =====================================================================
+
+  DO i = 1, ncum*nlp
+    nent(i, 1) = 0
+    m(i, 1) = 0.0
+  END DO
+
+  DO k = 1, nlp
+    DO j = 1, nlp
+      DO i = 1, ncum
+        qent(i, k, j) = q(i, j)
+        uent(i, k, j) = u(i, j)
+        vent(i, k, j) = v(i, j)
+        elij(i, k, j) = 0.0
+        ment(i, k, j) = 0.0
+        sij(i, k, j) = 0.0
+      END DO
+    END DO
+  END DO
+
+  ! -------------------------------------------------------------------
+  ! --- Calculate rates of mixing,  m(i)
+  ! -------------------------------------------------------------------
+
+  CALL zilch(work, ncum)
+
+  DO j = minorig + 1, nl
+    DO i = 1, ncum
+      IF ((j>=(icb(i)+1)) .AND. (j<=inb(i))) THEN
+        k = min(j, inb1(i))
+        dbo = abs(tv(i,k+1)-tvp(i,k+1)-tv(i,k-1)+tvp(i,k-1)) + &
+          entp*0.04*(ph(i,k)-ph(i,k+1))
+        work(i) = work(i) + dbo
+        m(i, j) = cbmf(i)*dbo
+      END IF
+    END DO
+  END DO
+  DO k = minorig + 1, nl
+    DO i = 1, ncum
+      IF ((k>=(icb(i)+1)) .AND. (k<=inb(i))) THEN
+        m(i, k) = m(i, k)/work(i)
+      END IF
+    END DO
+  END DO
+
+
+  ! =====================================================================
+  ! --- CALCULATE ENTRAINED AIR MASS FLUX (ment), TOTAL WATER MIXING
+  ! --- RATIO (QENT), TOTAL CONDENSED WATER (elij), AND MIXING
+  ! --- FRACTION (sij)
+  ! =====================================================================
+
+
+  DO i = minorig + 1, nl
+    DO j = minorig + 1, nl
+      DO ij = 1, ncum
+        IF ((i>=(icb(ij)+1)) .AND. (j>=icb(ij)) .AND. (i<=inb(ij)) .AND. (j<= &
+            inb(ij))) THEN
+          qti = qnk(ij) - ep(ij, i)*clw(ij, i)
+          bf2 = 1. + lv(ij, j)*lv(ij, j)*qs(ij, j)/(rrv*t(ij,j)*t(ij,j)*cpd)
+          anum = h(ij, j) - hp(ij, i) + (cpv-cpd)*t(ij, j)*(qti-q(ij,j))
+          denom = h(ij, i) - hp(ij, i) + (cpd-cpv)*(q(ij,i)-qti)*t(ij, j)
+          dei = denom
+          IF (abs(dei)<0.01) dei = 0.01
+          sij(ij, i, j) = anum/dei
+          sij(ij, i, i) = 1.0
+          altem = sij(ij, i, j)*q(ij, i) + (1.-sij(ij,i,j))*qti - qs(ij, j)
+          altem = altem/bf2
+          cwat = clw(ij, j)*(1.-ep(ij,j))
+          stemp = sij(ij, i, j)
+          IF ((stemp<0.0 .OR. stemp>1.0 .OR. altem>cwat) .AND. j>i) THEN
+            anum = anum - lv(ij, j)*(qti-qs(ij,j)-cwat*bf2)
+            denom = denom + lv(ij, j)*(q(ij,i)-qti)
+            IF (abs(denom)<0.01) denom = 0.01
+            sij(ij, i, j) = anum/denom
+            altem = sij(ij, i, j)*q(ij, i) + (1.-sij(ij,i,j))*qti - qs(ij, j)
+            altem = altem - (bf2-1.)*cwat
+          END IF
+          IF (sij(ij,i,j)>0.0 .AND. sij(ij,i,j)<0.9) THEN
+            qent(ij, i, j) = sij(ij, i, j)*q(ij, i) + (1.-sij(ij,i,j))*qti
+            uent(ij, i, j) = sij(ij, i, j)*u(ij, i) + &
+              (1.-sij(ij,i,j))*u(ij, nk(ij))
+            vent(ij, i, j) = sij(ij, i, j)*v(ij, i) + &
+              (1.-sij(ij,i,j))*v(ij, nk(ij))
+            elij(ij, i, j) = altem
+            elij(ij, i, j) = max(0.0, elij(ij,i,j))
+            ment(ij, i, j) = m(ij, i)/(1.-sij(ij,i,j))
+            nent(ij, i) = nent(ij, i) + 1
+          END IF
+          sij(ij, i, j) = max(0.0, sij(ij,i,j))
+          sij(ij, i, j) = min(1.0, sij(ij,i,j))
+        END IF
+      END DO
+    END DO
+
+    ! ***   If no air can entrain at level i assume that updraft detrains
+    ! ***
+    ! ***   at that level and calculate detrained air flux and properties
+    ! ***
+
+    DO ij = 1, ncum
+      IF ((i>=(icb(ij)+1)) .AND. (i<=inb(ij)) .AND. (nent(ij,i)==0)) THEN
+        ment(ij, i, i) = m(ij, i)
+        qent(ij, i, i) = q(ij, nk(ij)) - ep(ij, i)*clw(ij, i)
+        uent(ij, i, i) = u(ij, nk(ij))
+        vent(ij, i, i) = v(ij, nk(ij))
+        elij(ij, i, i) = clw(ij, i)
+        sij(ij, i, i) = 1.0
+      END IF
+    END DO
+  END DO
+
+  DO i = 1, ncum
+    sij(i, inb(i), inb(i)) = 1.0
+  END DO
+
+  ! =====================================================================
+  ! ---  NORMALIZE ENTRAINED AIR MASS FLUXES
+  ! ---  TO REPRESENT EQUAL PROBABILITIES OF MIXING
+  ! =====================================================================
+
+  CALL zilch(bsum, ncum*nlp)
+  DO ij = 1, ncum
+    lwork(ij) = .FALSE.
+  END DO
+  DO i = minorig + 1, nl
+
+    num1 = 0
+    DO ij = 1, ncum
+      IF ((i>=icb(ij)+1) .AND. (i<=inb(ij))) num1 = num1 + 1
+    END DO
+    IF (num1<=0) GO TO 789
+
+    DO ij = 1, ncum
+      IF ((i>=icb(ij)+1) .AND. (i<=inb(ij))) THEN
+        lwork(ij) = (nent(ij,i)/=0)
+        qp1 = q(ij, nk(ij)) - ep(ij, i)*clw(ij, i)
+        anum = h(ij, i) - hp(ij, i) - lv(ij, i)*(qp1-qs(ij,i))
+        denom = h(ij, i) - hp(ij, i) + lv(ij, i)*(q(ij,i)-qp1)
+        IF (abs(denom)<0.01) denom = 0.01
+        scrit(ij) = anum/denom
+        alt = qp1 - qs(ij, i) + scrit(ij)*(q(ij,i)-qp1)
+        IF (scrit(ij)<0.0 .OR. alt<0.0) scrit(ij) = 1.0
+        asij(ij) = 0.0
+        smin(ij) = 1.0
+      END IF
+    END DO
+    DO j = minorig, nl
+
+      num2 = 0
+      DO ij = 1, ncum
+        IF ((i>=icb(ij)+1) .AND. (i<=inb(ij)) .AND. (j>=icb( &
+          ij)) .AND. (j<=inb(ij)) .AND. lwork(ij)) num2 = num2 + 1
+      END DO
+      IF (num2<=0) GO TO 783
+
+      DO ij = 1, ncum
+        IF ((i>=icb(ij)+1) .AND. (i<=inb(ij)) .AND. (j>=icb( &
+            ij)) .AND. (j<=inb(ij)) .AND. lwork(ij)) THEN
+          IF (sij(ij,i,j)>0.0 .AND. sij(ij,i,j)<0.9) THEN
+            IF (j>i) THEN
+              smid = min(sij(ij,i,j), scrit(ij))
+              sjmax = smid
+              sjmin = smid
+              IF (smid<smin(ij) .AND. sij(ij,i,j+1)<smid) THEN
+                smin(ij) = smid
+                sjmax = min(sij(ij,i,j+1), sij(ij,i,j), scrit(ij))
+                sjmin = max(sij(ij,i,j-1), sij(ij,i,j))
+                sjmin = min(sjmin, scrit(ij))
+              END IF
+            ELSE
+              sjmax = max(sij(ij,i,j+1), scrit(ij))
+              smid = max(sij(ij,i,j), scrit(ij))
+              sjmin = 0.0
+              IF (j>1) sjmin = sij(ij, i, j-1)
+              sjmin = max(sjmin, scrit(ij))
+            END IF
+            delp = abs(sjmax-smid)
+            delm = abs(sjmin-smid)
+            asij(ij) = asij(ij) + (delp+delm)*(ph(ij,j)-ph(ij,j+1))
+            ment(ij, i, j) = ment(ij, i, j)*(delp+delm)*(ph(ij,j)-ph(ij,j+1))
+          END IF
+        END IF
+      END DO
+783 END DO
+    DO ij = 1, ncum
+      IF ((i>=icb(ij)+1) .AND. (i<=inb(ij)) .AND. lwork(ij)) THEN
+        asij(ij) = max(1.0E-21, asij(ij))
+        asij(ij) = 1.0/asij(ij)
+        bsum(ij, i) = 0.0
+      END IF
+    END DO
+    DO j = minorig, nl + 1
+      DO ij = 1, ncum
+        IF ((i>=icb(ij)+1) .AND. (i<=inb(ij)) .AND. (j>=icb( &
+            ij)) .AND. (j<=inb(ij)) .AND. lwork(ij)) THEN
+          ment(ij, i, j) = ment(ij, i, j)*asij(ij)
+          bsum(ij, i) = bsum(ij, i) + ment(ij, i, j)
+        END IF
+      END DO
+    END DO
+    DO ij = 1, ncum
+      IF ((i>=icb(ij)+1) .AND. (i<=inb(ij)) .AND. (bsum(ij, &
+          i)<1.0E-18) .AND. lwork(ij)) THEN
+        nent(ij, i) = 0
+        ment(ij, i, i) = m(ij, i)
+        qent(ij, i, i) = q(ij, nk(ij)) - ep(ij, i)*clw(ij, i)
+        uent(ij, i, i) = u(ij, nk(ij))
+        vent(ij, i, i) = v(ij, nk(ij))
+        elij(ij, i, i) = clw(ij, i)
+        sij(ij, i, i) = 1.0
+      END IF
+    END DO
+789 END DO
+
+  RETURN
+END SUBROUTINE cv_mixing
+
+SUBROUTINE cv_unsat(nloc, ncum, nd, inb, t, q, qs, gz, u, v, p, ph, h, lv, &
+    ep, sigp, clw, m, ment, elij, iflag, mp, qp, up, vp, wt, water, evap)
+  IMPLICIT NONE
+
+
+  include "cvthermo.h"
+  include "cvparam.h"
+
+  ! inputs:
+  INTEGER ncum, nd, nloc
+  INTEGER inb(nloc)
+  REAL t(nloc, nd), q(nloc, nd), qs(nloc, nd)
+  REAL gz(nloc, nd), u(nloc, nd), v(nloc, nd)
+  REAL p(nloc, nd), ph(nloc, nd+1), h(nloc, nd)
+  REAL lv(nloc, nd), ep(nloc, nd), sigp(nloc, nd), clw(nloc, nd)
+  REAL m(nloc, nd), ment(nloc, nd, nd), elij(nloc, nd, nd)
+
+  ! outputs:
+  INTEGER iflag(nloc) ! also an input
+  REAL mp(nloc, nd), qp(nloc, nd), up(nloc, nd), vp(nloc, nd)
+  REAL water(nloc, nd), evap(nloc, nd), wt(nloc, nd)
+
+  ! local variables:
+  INTEGER i, j, k, ij, num1
+  INTEGER jtt(nloc)
+  REAL awat, coeff, qsm, afac, sigt, b6, c6, revap
+  REAL dhdp, fac, qstm, rat
+  REAL wdtrain(nloc)
+  LOGICAL lwork(nloc)
+
+  ! =====================================================================
+  ! --- PRECIPITATING DOWNDRAFT CALCULATION
+  ! =====================================================================
+
+  ! Initializations:
+
+  DO i = 1, ncum
+    DO k = 1, nl + 1
+      wt(i, k) = omtsnow
+      mp(i, k) = 0.0
+      evap(i, k) = 0.0
+      water(i, k) = 0.0
+    END DO
+  END DO
+
+  DO i = 1, ncum
+    qp(i, 1) = q(i, 1)
+    up(i, 1) = u(i, 1)
+    vp(i, 1) = v(i, 1)
+  END DO
+
+  DO k = 2, nl + 1
+    DO i = 1, ncum
+      qp(i, k) = q(i, k-1)
+      up(i, k) = u(i, k-1)
+      vp(i, k) = v(i, k-1)
+    END DO
+  END DO
+
+
+  ! ***  Check whether ep(inb)=0, if so, skip precipitating    ***
+  ! ***             downdraft calculation                      ***
+
+
+  ! ***  Integrate liquid water equation to find condensed water   ***
+  ! ***                and condensed water flux                    ***
+
+
+  DO i = 1, ncum
+    jtt(i) = 2
+    IF (ep(i,inb(i))<=0.0001) iflag(i) = 2
+    IF (iflag(i)==0) THEN
+      lwork(i) = .TRUE.
+    ELSE
+      lwork(i) = .FALSE.
+    END IF
+  END DO
+
+  ! ***                    Begin downdraft loop                    ***
+
+
+  CALL zilch(wdtrain, ncum)
+  DO i = nl + 1, 1, -1
+
+    num1 = 0
+    DO ij = 1, ncum
+      IF ((i<=inb(ij)) .AND. lwork(ij)) num1 = num1 + 1
+    END DO
+    IF (num1<=0) GO TO 899
+
+
+    ! ***        Calculate detrained precipitation             ***
+
+    DO ij = 1, ncum
+      IF ((i<=inb(ij)) .AND. (lwork(ij))) THEN
+        wdtrain(ij) = g*ep(ij, i)*m(ij, i)*clw(ij, i)
+      END IF
+    END DO
+
+    IF (i>1) THEN
+      DO j = 1, i - 1
+        DO ij = 1, ncum
+          IF ((i<=inb(ij)) .AND. (lwork(ij))) THEN
+            awat = elij(ij, j, i) - (1.-ep(ij,i))*clw(ij, i)
+            awat = max(0.0, awat)
+            wdtrain(ij) = wdtrain(ij) + g*awat*ment(ij, j, i)
+          END IF
+        END DO
+      END DO
+    END IF
+
+    ! ***    Find rain water and evaporation using provisional   ***
+    ! ***              estimates of qp(i)and qp(i-1)             ***
+
+
+    ! ***  Value of terminal velocity and coeffecient of evaporation for snow
+    ! ***
+
+    DO ij = 1, ncum
+      IF ((i<=inb(ij)) .AND. (lwork(ij))) THEN
+        coeff = coeffs
+        wt(ij, i) = omtsnow
+
+        ! ***  Value of terminal velocity and coeffecient of evaporation for
+        ! rain   ***
+
+        IF (t(ij,i)>273.0) THEN
+          coeff = coeffr
+          wt(ij, i) = omtrain
+        END IF
+        qsm = 0.5*(q(ij,i)+qp(ij,i+1))
+        afac = coeff*ph(ij, i)*(qs(ij,i)-qsm)/(1.0E4+2.0E3*ph(ij,i)*qs(ij,i))
+        afac = max(afac, 0.0)
+        sigt = sigp(ij, i)
+        sigt = max(0.0, sigt)
+        sigt = min(1.0, sigt)
+        b6 = 100.*(ph(ij,i)-ph(ij,i+1))*sigt*afac/wt(ij, i)
+        c6 = (water(ij,i+1)*wt(ij,i+1)+wdtrain(ij)/sigd)/wt(ij, i)
+        revap = 0.5*(-b6+sqrt(b6*b6+4.*c6))
+        evap(ij, i) = sigt*afac*revap
+        water(ij, i) = revap*revap
+
+        ! ***  Calculate precipitating downdraft mass flux under     ***
+        ! ***              hydrostatic approximation                 ***
+
+        IF (i>1) THEN
+          dhdp = (h(ij,i)-h(ij,i-1))/(p(ij,i-1)-p(ij,i))
+          dhdp = max(dhdp, 10.0)
+          mp(ij, i) = 100.*ginv*lv(ij, i)*sigd*evap(ij, i)/dhdp
+          mp(ij, i) = max(mp(ij,i), 0.0)
+
+          ! ***   Add small amount of inertia to downdraft              ***
+
+          fac = 20.0/(ph(ij,i-1)-ph(ij,i))
+          mp(ij, i) = (fac*mp(ij,i+1)+mp(ij,i))/(1.+fac)
+
+          ! ***      Force mp to decrease linearly to zero
+          ! ***
+          ! ***      between about 950 mb and the surface
+          ! ***
+
+          IF (p(ij,i)>(0.949*p(ij,1))) THEN
+            jtt(ij) = max(jtt(ij), i)
+            mp(ij, i) = mp(ij, jtt(ij))*(p(ij,1)-p(ij,i))/ &
+              (p(ij,1)-p(ij,jtt(ij)))
+          END IF
+        END IF
+
+        ! ***       Find mixing ratio of precipitating downdraft     ***
+
+        IF (i/=inb(ij)) THEN
+          IF (i==1) THEN
+            qstm = qs(ij, 1)
+          ELSE
+            qstm = qs(ij, i-1)
+          END IF
+          IF (mp(ij,i)>mp(ij,i+1)) THEN
+            rat = mp(ij, i+1)/mp(ij, i)
+            qp(ij, i) = qp(ij, i+1)*rat + q(ij, i)*(1.0-rat) + &
+              100.*ginv*sigd*(ph(ij,i)-ph(ij,i+1))*(evap(ij,i)/mp(ij,i))
+            up(ij, i) = up(ij, i+1)*rat + u(ij, i)*(1.-rat)
+            vp(ij, i) = vp(ij, i+1)*rat + v(ij, i)*(1.-rat)
+          ELSE
+            IF (mp(ij,i+1)>0.0) THEN
+              qp(ij, i) = (gz(ij,i+1)-gz(ij,i)+qp(ij,i+1)*(lv(ij,i+1)+t(ij, &
+                i+1)*(cl-cpd))+cpd*(t(ij,i+1)-t(ij, &
+                i)))/(lv(ij,i)+t(ij,i)*(cl-cpd))
+              up(ij, i) = up(ij, i+1)
+              vp(ij, i) = vp(ij, i+1)
+            END IF
+          END IF
+          qp(ij, i) = min(qp(ij,i), qstm)
+          qp(ij, i) = max(qp(ij,i), 0.0)
+        END IF
+      END IF
+    END DO
+899 END DO
+
+  RETURN
+END SUBROUTINE cv_unsat
+
+SUBROUTINE cv_yield(nloc, ncum, nd, nk, icb, inb, delt, t, q, u, v, gz, p, &
+    ph, h, hp, lv, cpn, ep, clw, frac, m, mp, qp, up, vp, wt, water, evap, &
+    ment, qent, uent, vent, nent, elij, tv, tvp, iflag, wd, qprime, tprime, &
+    precip, cbmf, ft, fq, fu, fv, ma, qcondc)
+  IMPLICIT NONE
+
+  include "cvthermo.h"
+  include "cvparam.h"
+
+  ! inputs
+  INTEGER ncum, nd, nloc
+  INTEGER nk(nloc), icb(nloc), inb(nloc)
+  INTEGER nent(nloc, nd)
+  REAL delt
+  REAL t(nloc, nd), q(nloc, nd), u(nloc, nd), v(nloc, nd)
+  REAL gz(nloc, nd)
+  REAL p(nloc, nd), ph(nloc, nd+1), h(nloc, nd)
+  REAL hp(nloc, nd), lv(nloc, nd)
+  REAL cpn(nloc, nd), ep(nloc, nd), clw(nloc, nd), frac(nloc)
+  REAL m(nloc, nd), mp(nloc, nd), qp(nloc, nd)
+  REAL up(nloc, nd), vp(nloc, nd)
+  REAL wt(nloc, nd), water(nloc, nd), evap(nloc, nd)
+  REAL ment(nloc, nd, nd), qent(nloc, nd, nd), elij(nloc, nd, nd)
+  REAL uent(nloc, nd, nd), vent(nloc, nd, nd)
+  REAL tv(nloc, nd), tvp(nloc, nd)
+
+  ! outputs
+  INTEGER iflag(nloc) ! also an input
+  REAL cbmf(nloc) ! also an input
+  REAL wd(nloc), tprime(nloc), qprime(nloc)
+  REAL precip(nloc)
+  REAL ft(nloc, nd), fq(nloc, nd), fu(nloc, nd), fv(nloc, nd)
+  REAL ma(nloc, nd)
+  REAL qcondc(nloc, nd)
+
+  ! local variables
+  INTEGER i, j, ij, k, num1
+  REAL dpinv, cpinv, awat, fqold, ftold, fuold, fvold, delti
+  REAL work(nloc), am(nloc), amp1(nloc), ad(nloc)
+  REAL ents(nloc), uav(nloc), vav(nloc), lvcp(nloc, nd)
+  REAL qcond(nloc, nd), nqcond(nloc, nd), wa(nloc, nd) ! cld
+  REAL siga(nloc, nd), ax(nloc, nd), mac(nloc, nd) ! cld
+
+
+  ! -- initializations:
+
+  delti = 1.0/delt
+
+  DO i = 1, ncum
+    precip(i) = 0.0
+    wd(i) = 0.0
+    tprime(i) = 0.0
+    qprime(i) = 0.0
+    DO k = 1, nl + 1
+      ft(i, k) = 0.0
+      fu(i, k) = 0.0
+      fv(i, k) = 0.0
+      fq(i, k) = 0.0
+      lvcp(i, k) = lv(i, k)/cpn(i, k)
+      qcondc(i, k) = 0.0 ! cld
+      qcond(i, k) = 0.0 ! cld
+      nqcond(i, k) = 0.0 ! cld
+    END DO
+  END DO
+
+
+  ! ***  Calculate surface precipitation in mm/day     ***
+
+  DO i = 1, ncum
+    IF (iflag(i)<=1) THEN
+      ! c            precip(i)=precip(i)+wt(i,1)*sigd*water(i,1)*3600.*24000.
+      ! c     &                /(rowl*g)
+      ! c            precip(i)=precip(i)*delt/86400.
+      precip(i) = wt(i, 1)*sigd*water(i, 1)*86400/g
+    END IF
+  END DO
+
+
+  ! ***  Calculate downdraft velocity scale and surface temperature and  ***
+  ! ***                    water vapor fluctuations                      ***
+
+  DO i = 1, ncum
+    wd(i) = betad*abs(mp(i,icb(i)))*0.01*rrd*t(i, icb(i))/(sigd*p(i,icb(i)))
+    qprime(i) = 0.5*(qp(i,1)-q(i,1))
+    tprime(i) = lv0*qprime(i)/cpd
+  END DO
+
+  ! ***  Calculate tendencies of lowest level potential temperature  ***
+  ! ***                      and mixing ratio                        ***
+
+  DO i = 1, ncum
+    work(i) = 0.01/(ph(i,1)-ph(i,2))
+    am(i) = 0.0
+  END DO
+  DO k = 2, nl
+    DO i = 1, ncum
+      IF ((nk(i)==1) .AND. (k<=inb(i)) .AND. (nk(i)==1)) THEN
+        am(i) = am(i) + m(i, k)
+      END IF
+    END DO
+  END DO
+  DO i = 1, ncum
+    IF ((g*work(i)*am(i))>=delti) iflag(i) = 1
+    ft(i, 1) = ft(i, 1) + g*work(i)*am(i)*(t(i,2)-t(i,1)+(gz(i,2)-gz(i, &
+      1))/cpn(i,1))
+    ft(i, 1) = ft(i, 1) - lvcp(i, 1)*sigd*evap(i, 1)
+    ft(i, 1) = ft(i, 1) + sigd*wt(i, 2)*(cl-cpd)*water(i, 2)*(t(i,2)-t(i,1))* &
+      work(i)/cpn(i, 1)
+    fq(i, 1) = fq(i, 1) + g*mp(i, 2)*(qp(i,2)-q(i,1))*work(i) + &
+      sigd*evap(i, 1)
+    fq(i, 1) = fq(i, 1) + g*am(i)*(q(i,2)-q(i,1))*work(i)
+    fu(i, 1) = fu(i, 1) + g*work(i)*(mp(i,2)*(up(i,2)-u(i,1))+am(i)*(u(i, &
+      2)-u(i,1)))
+    fv(i, 1) = fv(i, 1) + g*work(i)*(mp(i,2)*(vp(i,2)-v(i,1))+am(i)*(v(i, &
+      2)-v(i,1)))
+  END DO
+  DO j = 2, nl
+    DO i = 1, ncum
+      IF (j<=inb(i)) THEN
+        fq(i, 1) = fq(i, 1) + g*work(i)*ment(i, j, 1)*(qent(i,j,1)-q(i,1))
+        fu(i, 1) = fu(i, 1) + g*work(i)*ment(i, j, 1)*(uent(i,j,1)-u(i,1))
+        fv(i, 1) = fv(i, 1) + g*work(i)*ment(i, j, 1)*(vent(i,j,1)-v(i,1))
+      END IF
+    END DO
+  END DO
+
+  ! ***  Calculate tendencies of potential temperature and mixing ratio  ***
+  ! ***               at levels above the lowest level                   ***
+
+  ! ***  First find the net saturated updraft and downdraft mass fluxes  ***
+  ! ***                      through each level                          ***
+
+  DO i = 2, nl + 1
+
+    num1 = 0
+    DO ij = 1, ncum
+      IF (i<=inb(ij)) num1 = num1 + 1
+    END DO
+    IF (num1<=0) GO TO 1500
+
+    CALL zilch(amp1, ncum)
+    CALL zilch(ad, ncum)
+
+    DO k = i + 1, nl + 1
+      DO ij = 1, ncum
+        IF ((i>=nk(ij)) .AND. (i<=inb(ij)) .AND. (k<=(inb(ij)+1))) THEN
+          amp1(ij) = amp1(ij) + m(ij, k)
+        END IF
+      END DO
+    END DO
+
+    DO k = 1, i
+      DO j = i + 1, nl + 1
+        DO ij = 1, ncum
+          IF ((j<=(inb(ij)+1)) .AND. (i<=inb(ij))) THEN
+            amp1(ij) = amp1(ij) + ment(ij, k, j)
+          END IF
+        END DO
+      END DO
+    END DO
+    DO k = 1, i - 1
+      DO j = i, nl + 1
+        DO ij = 1, ncum
+          IF ((i<=inb(ij)) .AND. (j<=inb(ij))) THEN
+            ad(ij) = ad(ij) + ment(ij, j, k)
+          END IF
+        END DO
+      END DO
+    END DO
+
+    DO ij = 1, ncum
+      IF (i<=inb(ij)) THEN
+        dpinv = 0.01/(ph(ij,i)-ph(ij,i+1))
+        cpinv = 1.0/cpn(ij, i)
+
+        ft(ij, i) = ft(ij, i) + g*dpinv*(amp1(ij)*(t(ij,i+1)-t(ij, &
+          i)+(gz(ij,i+1)-gz(ij,i))*cpinv)-ad(ij)*(t(ij,i)-t(ij, &
+          i-1)+(gz(ij,i)-gz(ij,i-1))*cpinv)) - sigd*lvcp(ij, i)*evap(ij, i)
+        ft(ij, i) = ft(ij, i) + g*dpinv*ment(ij, i, i)*(hp(ij,i)-h(ij,i)+t(ij &
+          ,i)*(cpv-cpd)*(q(ij,i)-qent(ij,i,i)))*cpinv
+        ft(ij, i) = ft(ij, i) + sigd*wt(ij, i+1)*(cl-cpd)*water(ij, i+1)*(t( &
+          ij,i+1)-t(ij,i))*dpinv*cpinv
+        fq(ij, i) = fq(ij, i) + g*dpinv*(amp1(ij)*(q(ij,i+1)-q(ij, &
+          i))-ad(ij)*(q(ij,i)-q(ij,i-1)))
+        fu(ij, i) = fu(ij, i) + g*dpinv*(amp1(ij)*(u(ij,i+1)-u(ij, &
+          i))-ad(ij)*(u(ij,i)-u(ij,i-1)))
+        fv(ij, i) = fv(ij, i) + g*dpinv*(amp1(ij)*(v(ij,i+1)-v(ij, &
+          i))-ad(ij)*(v(ij,i)-v(ij,i-1)))
+      END IF
+    END DO
+    DO k = 1, i - 1
+      DO ij = 1, ncum
+        IF (i<=inb(ij)) THEN
+          awat = elij(ij, k, i) - (1.-ep(ij,i))*clw(ij, i)
+          awat = max(awat, 0.0)
+          fq(ij, i) = fq(ij, i) + g*dpinv*ment(ij, k, i)*(qent(ij,k,i)-awat-q &
+            (ij,i))
+          fu(ij, i) = fu(ij, i) + g*dpinv*ment(ij, k, i)*(uent(ij,k,i)-u(ij,i &
+            ))
+          fv(ij, i) = fv(ij, i) + g*dpinv*ment(ij, k, i)*(vent(ij,k,i)-v(ij,i &
+            ))
+          ! (saturated updrafts resulting from mixing)               ! cld
+          qcond(ij, i) = qcond(ij, i) + (elij(ij,k,i)-awat) ! cld
+          nqcond(ij, i) = nqcond(ij, i) + 1. ! cld
+        END IF
+      END DO
+    END DO
+    DO k = i, nl + 1
+      DO ij = 1, ncum
+        IF ((i<=inb(ij)) .AND. (k<=inb(ij))) THEN
+          fq(ij, i) = fq(ij, i) + g*dpinv*ment(ij, k, i)*(qent(ij,k,i)-q(ij,i &
+            ))
+          fu(ij, i) = fu(ij, i) + g*dpinv*ment(ij, k, i)*(uent(ij,k,i)-u(ij,i &
+            ))
+          fv(ij, i) = fv(ij, i) + g*dpinv*ment(ij, k, i)*(vent(ij,k,i)-v(ij,i &
+            ))
+        END IF
+      END DO
+    END DO
+    DO ij = 1, ncum
+      IF (i<=inb(ij)) THEN
+        fq(ij, i) = fq(ij, i) + sigd*evap(ij, i) + g*(mp(ij,i+1)*(qp(ij, &
+          i+1)-q(ij,i))-mp(ij,i)*(qp(ij,i)-q(ij,i-1)))*dpinv
+        fu(ij, i) = fu(ij, i) + g*(mp(ij,i+1)*(up(ij,i+1)-u(ij, &
+          i))-mp(ij,i)*(up(ij,i)-u(ij,i-1)))*dpinv
+        fv(ij, i) = fv(ij, i) + g*(mp(ij,i+1)*(vp(ij,i+1)-v(ij, &
+          i))-mp(ij,i)*(vp(ij,i)-v(ij,i-1)))*dpinv
+        ! (saturated downdrafts resulting from mixing)               ! cld
+        DO k = i + 1, inb(ij) ! cld
+          qcond(ij, i) = qcond(ij, i) + elij(ij, k, i) ! cld
+          nqcond(ij, i) = nqcond(ij, i) + 1. ! cld
+        END DO ! cld
+        ! (particular case: no detraining level is found)            ! cld
+        IF (nent(ij,i)==0) THEN ! cld
+          qcond(ij, i) = qcond(ij, i) + (1.-ep(ij,i))*clw(ij, i) ! cld
+          nqcond(ij, i) = nqcond(ij, i) + 1. ! cld
+        END IF ! cld
+        IF (nqcond(ij,i)/=0.) THEN ! cld
+          qcond(ij, i) = qcond(ij, i)/nqcond(ij, i) ! cld
+        END IF ! cld
+      END IF
+    END DO
+1500 END DO
+
+  ! *** Adjust tendencies at top of convection layer to reflect  ***
+  ! ***       actual position of the level zero cape             ***
+
+  DO ij = 1, ncum
+    fqold = fq(ij, inb(ij))
+    fq(ij, inb(ij)) = fq(ij, inb(ij))*(1.-frac(ij))
+    fq(ij, inb(ij)-1) = fq(ij, inb(ij)-1) + frac(ij)*fqold*((ph(ij, &
+      inb(ij))-ph(ij,inb(ij)+1))/(ph(ij,inb(ij)-1)-ph(ij, &
+      inb(ij))))*lv(ij, inb(ij))/lv(ij, inb(ij)-1)
+    ftold = ft(ij, inb(ij))
+    ft(ij, inb(ij)) = ft(ij, inb(ij))*(1.-frac(ij))
+    ft(ij, inb(ij)-1) = ft(ij, inb(ij)-1) + frac(ij)*ftold*((ph(ij, &
+      inb(ij))-ph(ij,inb(ij)+1))/(ph(ij,inb(ij)-1)-ph(ij, &
+      inb(ij))))*cpn(ij, inb(ij))/cpn(ij, inb(ij)-1)
+    fuold = fu(ij, inb(ij))
+    fu(ij, inb(ij)) = fu(ij, inb(ij))*(1.-frac(ij))
+    fu(ij, inb(ij)-1) = fu(ij, inb(ij)-1) + frac(ij)*fuold*((ph(ij, &
+      inb(ij))-ph(ij,inb(ij)+1))/(ph(ij,inb(ij)-1)-ph(ij,inb(ij))))
+    fvold = fv(ij, inb(ij))
+    fv(ij, inb(ij)) = fv(ij, inb(ij))*(1.-frac(ij))
+    fv(ij, inb(ij)-1) = fv(ij, inb(ij)-1) + frac(ij)*fvold*((ph(ij, &
+      inb(ij))-ph(ij,inb(ij)+1))/(ph(ij,inb(ij)-1)-ph(ij,inb(ij))))
+  END DO
+
+  ! ***   Very slightly adjust tendencies to force exact   ***
+  ! ***     enthalpy, momentum and tracer conservation     ***
+
+  DO ij = 1, ncum
+    ents(ij) = 0.0
+    uav(ij) = 0.0
+    vav(ij) = 0.0
+    DO i = 1, inb(ij)
+      ents(ij) = ents(ij) + (cpn(ij,i)*ft(ij,i)+lv(ij,i)*fq(ij,i))*(ph(ij,i)- &
+        ph(ij,i+1))
+      uav(ij) = uav(ij) + fu(ij, i)*(ph(ij,i)-ph(ij,i+1))
+      vav(ij) = vav(ij) + fv(ij, i)*(ph(ij,i)-ph(ij,i+1))
+    END DO
+  END DO
+  DO ij = 1, ncum
+    ents(ij) = ents(ij)/(ph(ij,1)-ph(ij,inb(ij)+1))
+    uav(ij) = uav(ij)/(ph(ij,1)-ph(ij,inb(ij)+1))
+    vav(ij) = vav(ij)/(ph(ij,1)-ph(ij,inb(ij)+1))
+  END DO
+  DO ij = 1, ncum
+    DO i = 1, inb(ij)
+      ft(ij, i) = ft(ij, i) - ents(ij)/cpn(ij, i)
+      fu(ij, i) = (1.-cu)*(fu(ij,i)-uav(ij))
+      fv(ij, i) = (1.-cu)*(fv(ij,i)-vav(ij))
+    END DO
+  END DO
+
+  DO k = 1, nl + 1
+    DO i = 1, ncum
+      IF ((q(i,k)+delt*fq(i,k))<0.0) iflag(i) = 10
+    END DO
+  END DO
+
+
+  DO i = 1, ncum
+    IF (iflag(i)>2) THEN
+      precip(i) = 0.0
+      cbmf(i) = 0.0
+    END IF
+  END DO
+  DO k = 1, nl
+    DO i = 1, ncum
+      IF (iflag(i)>2) THEN
+        ft(i, k) = 0.0
+        fq(i, k) = 0.0
+        fu(i, k) = 0.0
+        fv(i, k) = 0.0
+        qcondc(i, k) = 0.0 ! cld
+      END IF
+    END DO
+  END DO
+
+  DO k = 1, nl + 1
+    DO i = 1, ncum
+      ma(i, k) = 0.
+    END DO
+  END DO
+  DO k = nl, 1, -1
+    DO i = 1, ncum
+      ma(i, k) = ma(i, k+1) + m(i, k)
+    END DO
+  END DO
+
+
+  ! *** diagnose the in-cloud mixing ratio   ***            ! cld
+  ! ***           of condensed water         ***            ! cld
+  ! ! cld
+  DO ij = 1, ncum ! cld
+    DO i = 1, nd ! cld
+      mac(ij, i) = 0.0 ! cld
+      wa(ij, i) = 0.0 ! cld
+      siga(ij, i) = 0.0 ! cld
+    END DO ! cld
+    DO i = nk(ij), inb(ij) ! cld
+      DO k = i + 1, inb(ij) + 1 ! cld
+        mac(ij, i) = mac(ij, i) + m(ij, k) ! cld
+      END DO ! cld
+    END DO ! cld
+    DO i = icb(ij), inb(ij) - 1 ! cld
+      ax(ij, i) = 0. ! cld
+      DO j = icb(ij), i ! cld
+        ax(ij, i) = ax(ij, i) + rrd*(tvp(ij,j)-tv(ij,j)) & ! cld
+          *(ph(ij,j)-ph(ij,j+1))/p(ij, j) ! cld
+      END DO ! cld
+      IF (ax(ij,i)>0.0) THEN ! cld
+        wa(ij, i) = sqrt(2.*ax(ij,i)) ! cld
+      END IF ! cld
+    END DO ! cld
+    DO i = 1, nl ! cld
+      IF (wa(ij,i)>0.0) &          ! cld
+        siga(ij, i) = mac(ij, i)/wa(ij, i) & ! cld
+        *rrd*tvp(ij, i)/p(ij, i)/100./delta ! cld
+      siga(ij, i) = min(siga(ij,i), 1.0) ! cld
+      qcondc(ij, i) = siga(ij, i)*clw(ij, i)*(1.-ep(ij,i)) & ! cld
+        +(1.-siga(ij,i))*qcond(ij, i) ! cld
+    END DO ! cld
+  END DO ! cld
+
+  RETURN
+END SUBROUTINE cv_yield
+
+SUBROUTINE cv_uncompress(nloc, len, ncum, nd, idcum, iflag, precip, cbmf, ft, &
+    fq, fu, fv, ma, qcondc, iflag1, precip1, cbmf1, ft1, fq1, fu1, fv1, ma1, &
+    qcondc1)
+  IMPLICIT NONE
+
+  include "cvparam.h"
+
+  ! inputs:
+  INTEGER len, ncum, nd, nloc
+  INTEGER idcum(nloc)
+  INTEGER iflag(nloc)
+  REAL precip(nloc), cbmf(nloc)
+  REAL ft(nloc, nd), fq(nloc, nd), fu(nloc, nd), fv(nloc, nd)
+  REAL ma(nloc, nd)
+  REAL qcondc(nloc, nd) !cld
+
+  ! outputs:
+  INTEGER iflag1(len)
+  REAL precip1(len), cbmf1(len)
+  REAL ft1(len, nd), fq1(len, nd), fu1(len, nd), fv1(len, nd)
+  REAL ma1(len, nd)
+  REAL qcondc1(len, nd) !cld
+
+  ! local variables:
+  INTEGER i, k
+
+  DO i = 1, ncum
+    precip1(idcum(i)) = precip(i)
+    cbmf1(idcum(i)) = cbmf(i)
+    iflag1(idcum(i)) = iflag(i)
+  END DO
+
+  DO k = 1, nl
+    DO i = 1, ncum
+      ft1(idcum(i), k) = ft(i, k)
+      fq1(idcum(i), k) = fq(i, k)
+      fu1(idcum(i), k) = fu(i, k)
+      fv1(idcum(i), k) = fv(i, k)
+      ma1(idcum(i), k) = ma(i, k)
+      qcondc1(idcum(i), k) = qcondc(i, k)
+    END DO
+  END DO
+
+  RETURN
+END SUBROUTINE cv_uncompress
+
Index: DZ6/trunk/libf/phylmd/cva_driver.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cva_driver.F90	(revision 5267)
+++ 	(revision )
@@ -1,1286 +1,0 @@
-
-! $Id$
-
-SUBROUTINE cva_driver(len, nd, ndp1, ntra, nloc, k_upper, &
-                      iflag_con, iflag_mix, iflag_ice_thermo, iflag_clos, ok_conserv_q, &
-!!                      delt, t1, q1, qs1, t1_wake, q1_wake, qs1_wake, s1_wake, &  ! jyg
-                      delt, comp_threshold, &                                      ! jyg
-                      t1, q1, qs1, t1_wake, q1_wake, qs1_wake, s1_wake, &          ! jyg
-                      u1, v1, tra1, &
-                      p1, ph1, &
-                      Ale1, Alp1, omega1, &
-                      sig1feed1, sig2feed1, wght1, &
-                      iflag1, ft1, fq1, fqcomp1, fu1, fv1, ftra1, &
-                      precip1, kbas1, ktop1, &
-                      cbmf1, plcl1, plfc1, wbeff1, &
-                      sig1, w01, & !input/output
-                      ptop21, sigd1, &
-                      ma1, mip1, Vprecip1, Vprecipi1, upwd1, dnwd1, dnwd01, &      ! jyg
-                      qcondc1, wd1, &
-                      cape1, cin1, tvp1, &
-                      ftd1, fqd1, &
-                      Plim11, Plim21, asupmax1, supmax01, asupmaxmin1, &
-                      lalim_conv1, & 
-!!                      da1,phi1,mp1,phi21,d1a1,dam1,sigij1,clw1, &        ! RomP
-!!                      elij1,evap1,ep1,epmlmMm1,eplaMm1, &                ! RomP
-                      da1, phi1, mp1, phi21, d1a1, dam1, sigij1, wghti1, & ! RomP, RL
-                      qta1, clw1, elij1, evap1, ep1, epmlmMm1, eplaMm1, &  ! RomP, RL
-                      wdtrainA1, wdtrainS1, wdtrainM1, qtc1, sigt1, detrain1, tau_cld_cv, &     !!jygprl
-                      coefw_cld_cv, &                                      ! RomP, AJ
-                      epmax_diag1)  ! epmax_cape
-! **************************************************************
-! *
-! CV_DRIVER                                                   *
-! *
-! *
-! written by   : Sandrine Bony-Lena , 17/05/2003, 11.19.41    *
-! modified by :                                               *
-! **************************************************************
-! **************************************************************
-
-  USE print_control_mod, ONLY: prt_level, lunout
-  USE add_phys_tend_mod, ONLY: fl_cor_ebil
-  IMPLICIT NONE
-
-! .............................START PROLOGUE............................
-
-
-! All argument names (except len,nd,ntra,nloc,delt and the flags) have a "1" appended.
-! The "1" is removed for the corresponding compressed variables.
-! PARAMETERS:
-! Name            Type         Usage            Description
-! ----------      ----------     -------  ----------------------------
-
-! len           Integer        Input        first (i) dimension
-! nd            Integer        Input        vertical (k) dimension
-! ndp1          Integer        Input        nd + 1
-! ntra          Integer        Input        number of tracors
-! nloc          Integer        Input        dimension of arrays for compressed fields
-! k_upper       Integer        Input        upmost level for vertical loops
-! iflag_con     Integer        Input        version of convect (3/4)
-! iflag_mix     Integer        Input        version of mixing  (0/1/2)
-! iflag_ice_thermo Integer        Input        accounting for ice thermodynamics (0/1)
-! iflag_clos    Integer        Input        version of closure (0/1)
-! tau_cld_cv    Real           Input        characteristic time of dissipation of mixing fluxes
-! coefw_cld_cv  Real           Input        coefficient for updraft velocity in convection
-! ok_conserv_q  Logical        Input        when true corrections for water conservation are swtiched on
-! delt          Real           Input        time step
-! comp_threshold Real           Input       threshold on the fraction of convective points below which
-!                                            fields  are compressed
-! t1            Real           Input        temperature (sat draught envt)
-! q1            Real           Input        specific hum (sat draught envt)
-! qs1           Real           Input        sat specific hum (sat draught envt)
-! t1_wake       Real           Input        temperature (unsat draught envt)
-! q1_wake       Real           Input        specific hum(unsat draught envt)
-! qs1_wake      Real           Input        sat specific hum(unsat draughts envt)
-! s1_wake       Real           Input        fractionnal area covered by wakes
-! u1            Real           Input        u-wind
-! v1            Real           Input        v-wind
-! tra1          Real           Input        tracors
-! p1            Real           Input        full level pressure
-! ph1           Real           Input        half level pressure
-! ALE1          Real           Input        Available lifting Energy
-! ALP1          Real           Input        Available lifting Power
-! sig1feed1     Real           Input        sigma coord at lower bound of feeding layer
-! sig2feed1     Real           Input        sigma coord at upper bound of feeding layer
-! wght1         Real           Input        weight density determining the feeding mixture
-! iflag1        Integer        Output       flag for Emanuel conditions
-! ft1           Real           Output       temp tend
-! fq1           Real           Output       spec hum tend
-! fqcomp1       Real           Output       spec hum tend (only mixed draughts)
-! fu1           Real           Output       u-wind tend
-! fv1           Real           Output       v-wind tend
-! ftra1         Real           Output       tracor tend
-! precip1       Real           Output       precipitation
-! kbas1         Integer        Output       cloud base level
-! ktop1         Integer        Output       cloud top level
-! cbmf1         Real           Output       cloud base mass flux
-! sig1          Real           In/Out       section adiabatic updraft
-! w01           Real           In/Out       vertical velocity within adiab updraft
-! ptop21        Real           In/Out       top of entraining zone
-! Ma1           Real           Output       mass flux adiabatic updraft
-! mip1          Real           Output       mass flux shed by the adiabatic updraft
-! Vprecip1      Real           Output       vertical profile of total precipitation
-! Vprecipi1     Real           Output       vertical profile of ice precipitation
-! upwd1         Real           Output       total upward mass flux (adiab+mixed)
-! dnwd1         Real           Output       saturated downward mass flux (mixed)
-! dnwd01        Real           Output       unsaturated downward mass flux
-! qcondc1       Real           Output       in-cld mixing ratio of condensed water
-! wd1           Real           Output       downdraft velocity scale for sfc fluxes
-! cape1         Real           Output       CAPE
-! cin1          Real           Output       CIN
-! tvp1          Real           Output       adiab lifted parcell virt temp
-! ftd1          Real           Output       precip temp tend
-! fqt1          Real           Output       precip spec hum tend
-! Plim11        Real           Output
-! Plim21        Real           Output
-! asupmax1      Real           Output
-! supmax01      Real           Output
-! asupmaxmin1   Real           Output
-
-! ftd1          Real           Output  Array of temperature tendency due to precipitations (K/s) of dimension ND,
-!                                      defined at same grid levels as T, Q, QS and P.
-
-! fqd1          Real           Output  Array of specific humidity tendencies due to precipitations ((gm/gm)/s)
-!                                      of dimension ND, defined at same grid levels as T, Q, QS and P.
-
-! wdtrainA1     Real           Output   precipitation ejected from adiabatic draught;
-!                                         should be used in tracer transport (cvltr)
-! wdtrainS1     Real           Output   precipitation detrained from shedding of adiabatic draught;
-!                                         used in tracer transport (cvltr)
-! wdtrainM1     Real           Output   precipitation detrained from mixed draughts;
-!                                         used in tracer transport (cvltr)
-! da1           Real           Output     used in tracer transport (cvltr)
-! phi1          Real           Output     used in tracer transport (cvltr)
-! mp1           Real           Output     used in tracer transport (cvltr)
-! qtc1          Real           Output     specific humidity in convection
-! sigt1         Real           Output     surface fraction in adiabatic updrafts                                         
-! detrain1      Real           Output     detrainment terme klein
-! phi21         Real           Output     used in tracer transport (cvltr)
-                                         
-! d1a1          Real           Output     used in tracer transport (cvltr)
-! dam1          Real           Output     used in tracer transport (cvltr)
-                                         
-! epmlmMm1      Real           Output     used in tracer transport (cvltr)
-! eplaMm1       Real           Output     used in tracer transport (cvltr)
-                                         
-! evap1         Real           Output    
-! ep1           Real           Output    
-! sigij1        Real           Output     used in tracer transport (cvltr)
-! clw1          Real           Output   condensed water content of the adiabatic updraught
-! elij1         Real           Output
-! wghti1        Real           Output   final weight of the feeding layers,
-!                                         used in tracer transport (cvltr)
-
-
-! S. Bony, Mar 2002:
-! * Several modules corresponding to different physical processes
-! * Several versions of convect may be used:
-!         - iflag_con=3: version lmd  (previously named convect3)
-!         - iflag_con=4: version 4.3b (vect. version, previously convect1/2)
-! + tard: - iflag_con=5: version lmd with ice (previously named convectg)
-! S. Bony, Oct 2002:
-! * Vectorization of convect3 (ie version lmd)
-
-! ..............................END PROLOGUE.............................
-
-
-
-! Input
-  INTEGER, INTENT (IN)                               :: len
-  INTEGER, INTENT (IN)                               :: nd
-  INTEGER, INTENT (IN)                               :: ndp1
-  INTEGER, INTENT (IN)                               :: ntra
-  INTEGER, INTENT(IN)                                :: nloc ! (nloc=len)  pour l'instant
-  INTEGER, INTENT (IN)                               :: k_upper
-  INTEGER, INTENT (IN)                               :: iflag_con
-  INTEGER, INTENT (IN)                               :: iflag_mix
-  INTEGER, INTENT (IN)                               :: iflag_ice_thermo
-  INTEGER, INTENT (IN)                               :: iflag_clos
-  LOGICAL, INTENT (IN)                               :: ok_conserv_q
-  REAL, INTENT (IN)                                  :: tau_cld_cv
-  REAL, INTENT (IN)                                  :: coefw_cld_cv
-  REAL, INTENT (IN)                                  :: delt
-  REAL, INTENT (IN)                                  :: comp_threshold
-  REAL, DIMENSION (len, nd), INTENT (IN)             :: t1
-  REAL, DIMENSION (len, nd), INTENT (IN)             :: q1
-  REAL, DIMENSION (len, nd), INTENT (IN)             :: qs1
-  REAL, DIMENSION (len, nd), INTENT (IN)             :: t1_wake
-  REAL, DIMENSION (len, nd), INTENT (IN)             :: q1_wake
-  REAL, DIMENSION (len, nd), INTENT (IN)             :: qs1_wake
-  REAL, DIMENSION (len), INTENT (IN)                 :: s1_wake
-  REAL, DIMENSION (len, nd), INTENT (IN)             :: u1
-  REAL, DIMENSION (len, nd), INTENT (IN)             :: v1
-  REAL, DIMENSION (len, nd, ntra), INTENT (IN)       :: tra1
-  REAL, DIMENSION (len, nd), INTENT (IN)             :: p1
-  REAL, DIMENSION (len, ndp1), INTENT (IN)           :: ph1
-  REAL, DIMENSION (len), INTENT (IN)                 :: Ale1
-  REAL, DIMENSION (len), INTENT (IN)                 :: Alp1
-  REAL, DIMENSION (len, nd), INTENT (IN)             :: omega1
-  REAL, INTENT (IN)                                  :: sig1feed1 ! pressure at lower bound of feeding layer
-  REAL, INTENT (IN)                                  :: sig2feed1 ! pressure at upper bound of feeding layer
-  REAL, DIMENSION (nd), INTENT (IN)                  :: wght1     ! weight density determining the feeding mixture
-  INTEGER, DIMENSION (len), INTENT (IN)              :: lalim_conv1
-
-! Input/Output
-  REAL, DIMENSION (len, nd), INTENT (INOUT)          :: sig1
-  REAL, DIMENSION (len, nd), INTENT (INOUT)          :: w01
-
-! Output
-  INTEGER, DIMENSION (len), INTENT (OUT)             :: iflag1
-  REAL, DIMENSION (len, nd), INTENT (OUT)            :: ft1
-  REAL, DIMENSION (len, nd), INTENT (OUT)            :: fq1
-  REAL, DIMENSION (len, nd), INTENT (OUT)            :: fqcomp1
-  REAL, DIMENSION (len, nd), INTENT (OUT)            :: fu1
-  REAL, DIMENSION (len, nd), INTENT (OUT)            :: fv1
-  REAL, DIMENSION (len, nd, ntra), INTENT (OUT)      :: ftra1
-  REAL, DIMENSION (len), INTENT (OUT)                :: precip1
-  INTEGER, DIMENSION (len), INTENT (OUT)             :: kbas1
-  INTEGER, DIMENSION (len), INTENT (OUT)             :: ktop1
-  REAL, DIMENSION (len), INTENT (OUT)                :: cbmf1
-  REAL, DIMENSION (len), INTENT (OUT)                :: plcl1
-  REAL, DIMENSION (len), INTENT (OUT)                :: plfc1
-  REAL, DIMENSION (len), INTENT (OUT)                :: wbeff1
-  REAL, DIMENSION (len), INTENT (OUT)                :: ptop21
-  REAL, DIMENSION (len), INTENT (OUT)                :: sigd1
-  REAL, DIMENSION (len, nd), INTENT (OUT)            :: ma1        ! adiab. asc. mass flux (staggered grid)
-  REAL, DIMENSION (len, nd), INTENT (OUT)            :: mip1       ! mass flux shed from adiab. ascent (extensive)
-! real Vprecip1(len,nd)
-  REAL, DIMENSION (len, ndp1), INTENT (OUT)          :: vprecip1   ! tot precipitation flux (staggered grid)
-  REAL, DIMENSION (len, ndp1), INTENT (OUT)          :: vprecipi1  ! ice precipitation flux (staggered grid)
-  REAL, DIMENSION (len, nd), INTENT (OUT)            :: upwd1      ! upwd sat. mass flux (staggered grid)
-  REAL, DIMENSION (len, nd), INTENT (OUT)            :: dnwd1      ! dnwd sat. mass flux (staggered grid)
-  REAL, DIMENSION (len, nd), INTENT (OUT)            :: dnwd01     ! unsat. mass flux (staggered grid)
-  REAL, DIMENSION (len, nd), INTENT (OUT)            :: qcondc1    ! max cloud condensate (intensive)  ! cld
-  REAL, DIMENSION (len), INTENT (OUT)                :: wd1             ! gust
-  REAL, DIMENSION (len), INTENT (OUT)                :: cape1
-  REAL, DIMENSION (len), INTENT (OUT)                :: cin1
-  REAL, DIMENSION (len, nd), INTENT (OUT)            :: tvp1       ! Virt. temp. in the adiab. ascent
-
-!AC!
-!!      real da1(len,nd),phi1(len,nd,nd)
-!!      real da(len,nd),phi(len,nd,nd)
-!AC!
-  REAL, DIMENSION (len, nd), INTENT (OUT)            :: ftd1       ! Temp. tendency due to the sole unsat. drafts
-  REAL, DIMENSION (len, nd), INTENT (OUT)            :: fqd1       ! Moist. tendency due to the sole unsat. drafts
-  REAL, DIMENSION (len), INTENT (OUT)                :: Plim11
-  REAL, DIMENSION (len), INTENT (OUT)                :: Plim21
-  REAL, DIMENSION (len, nd), INTENT (OUT)            :: asupmax1   ! Highest mixing fraction of mixed updraughts
-  REAL, DIMENSION (len), INTENT (OUT)                :: supmax01
-  REAL, DIMENSION (len), INTENT (OUT)                :: asupmaxmin1
-  REAL, DIMENSION (len, nd), INTENT (OUT)            :: qtc1    ! in cloud water content (intensive)   ! cld
-  REAL, DIMENSION (len, nd), INTENT (OUT)            :: sigt1   ! fract. cloud area (intensive)        ! cld
-  REAL, DIMENSION (len, nd), INTENT (OUT)            :: detrain1   ! detrainement term of mixed draughts in environment
-
-! RomP >>>
-  REAL, DIMENSION (len, nd), INTENT (OUT)            :: wdtrainA1, wdtrainS1, wdtrainM1 ! precipitation sources (extensive)
-  REAL, DIMENSION (len, nd), INTENT (OUT)            :: mp1  ! unsat. mass flux (staggered grid)
-  REAL, DIMENSION (len, nd), INTENT (OUT)            :: da1  ! detrained mass flux of adiab. asc. air (extensive)
-  REAL, DIMENSION (len, nd, nd), INTENT (OUT)        :: phi1 ! mass flux of envt. air in mixed draughts (extensive)
-  REAL, DIMENSION (len, nd, nd), INTENT (OUT)        :: epmlmMm1  ! (extensive)
-  REAL, DIMENSION (len, nd), INTENT (OUT)            :: eplaMm1   ! (extensive)
-  REAL, DIMENSION (len, nd), INTENT (OUT)            :: evap1 ! evaporation rate in precip. downdraft. (intensive)
-  REAL, DIMENSION (len, nd), INTENT (OUT)            :: ep1
-  REAL, DIMENSION (len, nd, nd), INTENT (OUT)        :: sigij1 ! mass fraction of env. air in mixed draughts (intensive) 
-  REAL, DIMENSION (len, nd, nd), INTENT (OUT)        :: elij1! cond. water per unit mass of mixed draughts (intensive) 
-  REAL, DIMENSION (len, nd), INTENT (OUT)            :: qta1 ! total water per unit mass of the adiab. asc. (intensive)
-  REAL, DIMENSION (len, nd), INTENT (OUT)            :: clw1 ! cond. water per unit mass of the adiab. asc. (intensive) 
-!JYG,RL
-  REAL, DIMENSION (len, nd), INTENT (OUT)            :: wghti1   ! final weight of the feeding layers (extensive)
-!JYG,RL
-  REAL, DIMENSION (len, nd, nd), INTENT (OUT)        :: phi21    ! (extensive)
-  REAL, DIMENSION (len, nd), INTENT (OUT)            :: d1a1     ! (extensive)
-  REAL, DIMENSION (len, nd), INTENT (OUT)            :: dam1     ! (extensive)
-! RomP <<<
-  REAL, DIMENSION (len ), INTENT (OUT)               :: epmax_diag1      
-
-! -------------------------------------------------------------------
-! Prolog by Kerry Emanuel.
-! -------------------------------------------------------------------
-! --- ARGUMENTS
-! -------------------------------------------------------------------
-! --- On input:
-
-! t:   Array of absolute temperature (K) of dimension ND, with first
-! index corresponding to lowest model level. Note that this array
-! will be altered by the subroutine if dry convective adjustment
-! occurs and if IPBL is not equal to 0.
-
-! q:   Array of specific humidity (gm/gm) of dimension ND, with first
-! index corresponding to lowest model level. Must be defined
-! at same grid levels as T. Note that this array will be altered
-! if dry convective adjustment occurs and if IPBL is not equal to 0.
-
-! qs:  Array of saturation specific humidity of dimension ND, with first
-! index corresponding to lowest model level. Must be defined
-! at same grid levels as T. Note that this array will be altered
-! if dry convective adjustment occurs and if IPBL is not equal to 0.
-
-! t_wake: Array of absolute temperature (K), seen by unsaturated draughts,
-! of dimension ND, with first index corresponding to lowest model level.
-
-! q_wake: Array of specific humidity (gm/gm), seen by unsaturated draughts,
-! of dimension ND, with first index corresponding to lowest model level.
-! Must be defined at same grid levels as T.
-
-! qs_wake: Array of saturation specific humidity, seen by unsaturated draughts,
-! of dimension ND, with first index corresponding to lowest model level.
-! Must be defined at same grid levels as T.
-
-! s_wake: Array of fractionnal area occupied by the wakes.
-
-! u:   Array of zonal wind velocity (m/s) of dimension ND, witth first
-! index corresponding with the lowest model level. Defined at
-! same levels as T. Note that this array will be altered if
-! dry convective adjustment occurs and if IPBL is not equal to 0.
-
-! v:   Same as u but for meridional velocity.
-
-! tra: Array of passive tracer mixing ratio, of dimensions (ND,NTRA),
-! where NTRA is the number of different tracers. If no
-! convective tracer transport is needed, define a dummy
-! input array of dimension (ND,1). Tracers are defined at
-! same vertical levels as T. Note that this array will be altered
-! if dry convective adjustment occurs and if IPBL is not equal to 0.
-
-! p:   Array of pressure (mb) of dimension ND, with first
-! index corresponding to lowest model level. Must be defined
-! at same grid levels as T.
-
-! ph:  Array of pressure (mb) of dimension ND+1, with first index
-! corresponding to lowest level. These pressures are defined at
-! levels intermediate between those of P, T, Q and QS. The first
-! value of PH should be greater than (i.e. at a lower level than)
-! the first value of the array P.
-
-! ALE:  Available lifting Energy
-
-! ALP:  Available lifting Power
-
-! nl:  The maximum number of levels to which convection can penetrate, plus 1.
-!       NL MUST be less than or equal to ND-1.
-
-! delt: The model time step (sec) between calls to CONVECT
-
-! ----------------------------------------------------------------------------
-! ---   On Output:
-
-! iflag: An output integer whose value denotes the following:
-!       VALUE   INTERPRETATION
-!       -----   --------------
-!         0     Moist convection occurs.
-!         1     Moist convection occurs, but a CFL condition
-!               on the subsidence warming is violated. This
-!               does not cause the scheme to terminate.
-!         2     Moist convection, but no precip because ep(inb) lt 0.0001
-!         3     No moist convection because new cbmf is 0 and old cbmf is 0.
-!         4     No moist convection; atmosphere is not
-!               unstable
-!         6     No moist convection because ihmin le minorig.
-!         7     No moist convection because unreasonable
-!               parcel level temperature or specific humidity.
-!         8     No moist convection: lifted condensation
-!               level is above the 200 mb level.
-!         9     No moist convection: cloud base is higher
-!               then the level NL-1.
-!        10     No moist convection: cloud top is too warm.
-!        14     No moist convection; atmosphere is very
-!               stable (=> no computation)
-!
-
-! ft:   Array of temperature tendency (K/s) of dimension ND, defined at same
-!       grid levels as T, Q, QS and P.
-
-! fq:   Array of specific humidity tendencies ((gm/gm)/s) of dimension ND,
-!       defined at same grid levels as T, Q, QS and P.
-
-! fu:   Array of forcing of zonal velocity (m/s^2) of dimension ND,
-!      defined at same grid levels as T.
-
-! fv:   Same as FU, but for forcing of meridional velocity.
-
-! ftra: Array of forcing of tracer content, in tracer mixing ratio per
-!       second, defined at same levels as T. Dimensioned (ND,NTRA).
-
-! precip: Scalar convective precipitation rate (mm/day).
-
-! wd:   A convective downdraft velocity scale. For use in surface
-!       flux parameterizations. See convect.ps file for details.
-
-! tprime: A convective downdraft temperature perturbation scale (K).
-!         For use in surface flux parameterizations. See convect.ps
-!         file for details.
-
-! qprime: A convective downdraft specific humidity
-!         perturbation scale (gm/gm).
-!         For use in surface flux parameterizations. See convect.ps
-!         file for details.
-
-! cbmf: The cloud base mass flux ((kg/m**2)/s). THIS SCALAR VALUE MUST
-!       BE STORED BY THE CALLING PROGRAM AND RETURNED TO CONVECT AT
-!       ITS NEXT CALL. That is, the value of CBMF must be "remembered"
-!       by the calling program between calls to CONVECT.
-
-! det:   Array of detrainment mass flux of dimension ND.
-! -------------------------------------------------------------------
-
-! Local (non compressed) arrays
-
-
-  INTEGER i, k, il
-  INTEGER nword1, nword2, nword3, nword4
-  INTEGER icbmax
-  INTEGER nk1(len)
-  INTEGER icb1(len)
-  INTEGER icbs1(len)
-
-  LOGICAL ok_inhib ! True => possible inhibition of convection by dryness
-  LOGICAL, SAVE :: debut = .TRUE.
-!$OMP THREADPRIVATE(debut)
-
-  REAL coef_convective(len)   ! = 1 for convective points, = 0 otherwise
-  REAL tnk1(len)
-  REAL thnk1(len)
-  REAL qnk1(len)
-  REAL gznk1(len)
-  REAL qsnk1(len)
-  REAL unk1(len)
-  REAL vnk1(len)
-  REAL cpnk1(len)
-  REAL hnk1(len)
-  REAL pbase1(len)
-  REAL buoybase1(len)
-
-  REAL lf1(len, nd), lf1_wake(len, nd)
-  REAL lv1(len, nd), lv1_wake(len, nd)
-  REAL cpn1(len, nd), cpn1_wake(len, nd)
-  REAL tv1(len, nd), tv1_wake(len, nd)
-  REAL gz1(len, nd), gz1_wake(len, nd)
-  REAL hm1(len, nd)
-  REAL h1(len, nd), h1_wake(len, nd)
-  REAL tp1(len, nd)
-  REAL th1(len, nd), th1_wake(len, nd)
-
-  REAL bid(len, nd) ! dummy array
-
-  INTEGER ncum
-
-  REAL p1feed1(len) ! pressure at lower bound of feeding layer
-  REAL p2feed1(len) ! pressure at upper bound of feeding layer
-!JYG,RL
-!!      real wghti1(len,nd) ! weights of the feeding layers
-!JYG,RL
-
-! (local) compressed fields:
-
-
-  INTEGER idcum(nloc)
-!jyg<
-  LOGICAL compress    ! True if compression occurs
-!>jyg
-  INTEGER iflag(nloc), nk(nloc), icb(nloc)
-  INTEGER nent(nloc, nd)
-  INTEGER icbs(nloc)
-  INTEGER inb(nloc), inbis(nloc)
-
-  REAL cbmf(nloc), plcl(nloc), plfc(nloc), wbeff(nloc)
-  REAL t(nloc, nd), q(nloc, nd), qs(nloc, nd)
-  REAL t_wake(nloc, nd), q_wake(nloc, nd), qs_wake(nloc, nd)
-  REAL s_wake(nloc)
-  REAL u(nloc, nd), v(nloc, nd)
-  REAL gz(nloc, nd), h(nloc, nd)
-  REAL h_wake(nloc, nd)
-  REAL lv(nloc, nd), lf(nloc, nd), cpn(nloc, nd)
-  REAL lv_wake(nloc, nd), lf_wake(nloc, nd), cpn_wake(nloc, nd)
-  REAL p(nloc, nd), ph(nloc, nd+1), tv(nloc, nd), tp(nloc, nd)
-  REAL tv_wake(nloc, nd)
-  REAL clw(nloc, nd)
-  REAL, DIMENSION(nloc, nd)    :: qta, qpreca                       !!jygprl
-  REAL dph(nloc, nd)
-  REAL pbase(nloc), buoybase(nloc), th(nloc, nd)
-  REAL th_wake(nloc, nd)
-  REAL tvp(nloc, nd)
-  REAL sig(nloc, nd), w0(nloc, nd), ptop2(nloc)
-  REAL hp(nloc, nd), ep(nloc, nd), sigp(nloc, nd)
-  REAL buoy(nloc, nd)
-  REAL cape(nloc)
-  REAL cin(nloc)
-  REAL m(nloc, nd)
-  REAL mm(nloc, nd)
-  REAL ment(nloc, nd, nd), sigij(nloc, nd, nd)
-  REAL qent(nloc, nd, nd)
-  REAL hent(nloc, nd, nd)
-  REAL uent(nloc, nd, nd), vent(nloc, nd, nd)
-  REAL ments(nloc, nd, nd), qents(nloc, nd, nd)
-  REAL elij(nloc, nd, nd)
-  REAL supmax(nloc, nd)
-  REAL Ale(nloc), Alp(nloc), coef_clos(nloc)
-  REAL omega(nloc,nd)
-  REAL sigd(nloc)
-! real mp(nloc,nd), qp(nloc,nd), up(nloc,nd), vp(nloc,nd)
-! real wt(nloc,nd), water(nloc,nd), evap(nloc,nd), ice(nloc,nd)
-! real b(nloc,nd), sigd(nloc)
-! save mp,qp,up,vp,wt,water,evap,b
-  REAL, DIMENSION(len,nd)     :: mp, qp, up, vp
-  REAL, DIMENSION(len,nd)     :: wt, water, evap
-  REAL, DIMENSION(len,nd)     :: ice, fondue, b
-  REAL, DIMENSION(len,nd)     :: frac_a, frac_s, faci               !!jygprl
-  REAL ft(nloc, nd), fq(nloc, nd), fqcomp(nloc, nd)
-  REAL ftd(nloc, nd), fqd(nloc, nd)
-  REAL fu(nloc, nd), fv(nloc, nd)
-  REAL upwd(nloc, nd), dnwd(nloc, nd), dnwd0(nloc, nd)
-  REAL ma(nloc, nd), mip(nloc, nd)
-!!  REAL tls(nloc, nd), tps(nloc, nd)                 ! unused . jyg
-  REAL qprime(nloc), tprime(nloc)
-  REAL precip(nloc)
-! real Vprecip(nloc,nd)
-  REAL vprecip(nloc, nd+1)
-  REAL vprecipi(nloc, nd+1)
-  REAL tra(nloc, nd, ntra), trap(nloc, nd, ntra)
-  REAL ftra(nloc, nd, ntra), traent(nloc, nd, nd, ntra)
-  REAL qcondc(nloc, nd)      ! cld
-  REAL wd(nloc)                ! gust
-  REAL Plim1(nloc), plim2(nloc)
-  REAL asupmax(nloc, nd)
-  REAL supmax0(nloc)
-  REAL asupmaxmin(nloc)
-
-  REAL tnk(nloc), qnk(nloc), gznk(nloc)
-  REAL wghti(nloc, nd)
-  REAL hnk(nloc), unk(nloc), vnk(nloc)
-
-  REAL qtc(nloc, nd)         ! cld
-  REAL sigt(nloc, nd)        ! cld
-  REAL detrain(nloc, nd)     ! cld
- 
-! RomP >>>
-  REAL wdtrainA(nloc, nd), wdtrainS(nloc, nd), wdtrainM(nloc, nd)   !!jygprl
-  REAL da(len, nd), phi(len, nd, nd)
-  REAL epmlmMm(nloc, nd, nd), eplaMm(nloc, nd)
-  REAL phi2(len, nd, nd)
-  REAL d1a(len, nd), dam(len, nd)
-! RomP <<<
-  REAL epmax_diag(nloc) ! epmax_cape
-
-  CHARACTER (LEN=20) :: modname = 'cva_driver'
-  CHARACTER (LEN=80) :: abort_message
-
-  REAL, PARAMETER    :: Cin_noconv = -100000.
-  REAL, PARAMETER    :: Cape_noconv = -1.
-
-  INTEGER,SAVE                                       :: igout=1
-!$OMP THREADPRIVATE(igout)
-
-
-! print *, 't1, t1_wake ',(k,t1(1,k),t1_wake(1,k),k=1,nd)
-! print *, 'q1, q1_wake ',(k,q1(1,k),q1_wake(1,k),k=1,nd)
-
-! -------------------------------------------------------------------
-! --- SET CONSTANTS AND PARAMETERS
-! -------------------------------------------------------------------
-
-! -- set simulation flags:
-! (common cvflag)
-
-  CALL cv_flag(iflag_ice_thermo)
-
-! -- set thermodynamical constants:
-! (common cvthermo)
-
-  CALL cv_thermo(iflag_con)
-
-! -- set convect parameters
-
-! includes microphysical parameters and parameters that
-! control the rate of approach to quasi-equilibrium)
-! (common cvparam)
-
-  IF (iflag_con==3) THEN
-    CALL cv3_param(nd, k_upper, delt)
-
-  END IF
-
-  IF (iflag_con==4) THEN
-    CALL cv_param(nd)
-  END IF
-
-! ---------------------------------------------------------------------
-! --- INITIALIZE OUTPUT ARRAYS AND PARAMETERS
-! ---------------------------------------------------------------------
-  nword1 = len
-  nword2 = len*nd
-  nword3 = len*nd*ntra
-  nword4 = len*nd*nd
-
-  iflag1(:) = 0
-  ktop1(:) = 0
-  kbas1(:) = 0
-  ft1(:, :) = 0.0
-  fq1(:, :) = 0.0
-  fqcomp1(:, :) = 0.0
-  fu1(:, :) = 0.0
-  fv1(:, :) = 0.0
-  ftra1(:, :, :) = 0.
-  precip1(:) = 0.
-  cbmf1(:) = 0.
-  plcl1(:) = 0.
-  plfc1(:) = 0.
-  wbeff1(:) = 0.
-  ptop21(:) = 0.
-  sigd1(:) = 0.
-  ma1(:, :) = 0.
-  mip1(:, :) = 0.
-  vprecip1(:, :) = 0.
-  vprecipi1(:, :) = 0.
-  upwd1(:, :) = 0.
-  dnwd1(:, :) = 0.
-  dnwd01(:, :) = 0.
-  qcondc1(:, :) = 0.
-  wd1(:) = 0.
-  cape1(:) = 0.
-  cin1(:) = 0.
-  tvp1(:, :) = 0.
-  ftd1(:, :) = 0.
-  fqd1(:, :) = 0.
-  Plim11(:) = 0.
-  Plim21(:) = 0.
-  asupmax1(:, :) = 0.
-  supmax01(:) = 0.
-  asupmaxmin1(:) = 0.
-
-  tvp(:, :) = 0. !ym missing init, need to have a look by developpers
-  tv(:, :) = 0. !ym missing init, need to have a look by developpers
-
-  DO il = 1, len
-!!    cin1(il) = -100000.
-!!    cape1(il) = -1.
-    cin1(il) = Cin_noconv
-    cape1(il) = Cape_noconv
-  END DO
-
-!!  IF (iflag_con==3) THEN
-!!    DO il = 1, len
-!!      sig1(il, nd) = sig1(il, nd) + 1.
-!!      sig1(il, nd) = amin1(sig1(il,nd), 12.1)
-!!    END DO
-!!  END IF
-
-  IF (iflag_con==3) THEN
-      CALL cv3_incrcount(len,nd,delt,sig1)
-  END IF  ! (iflag_con==3)
-
-! RomP >>>
-  sigt1(:, :) = 0.
-  detrain1(:, :) = 0.
-  qtc1(:, :) = 0.
-  wdtrainA1(:, :) = 0.
-  wdtrainS1(:, :) = 0.
-  wdtrainM1(:, :) = 0.
-  da1(:, :) = 0.
-  phi1(:, :, :) = 0.
-  epmlmMm1(:, :, :) = 0.
-  eplaMm1(:, :) = 0.
-  mp1(:, :) = 0.
-  evap1(:, :) = 0.
-  ep1(:, :) = 0.
-  sigij1(:, :, :) = 0.
-  elij1(:, :, :) = 0.
-  qta1(:,:) = 0.
-  clw1(:,:) = 0.
-  wghti1(:,:) = 0.
-  phi21(:, :, :) = 0.
-  d1a1(:, :) = 0.
-  dam1(:, :) = 0.
-! RomP <<<
-! ---------------------------------------------------------------------
-! --- INITIALIZE LOCAL ARRAYS AND PARAMETERS
-! ---------------------------------------------------------------------
-
-  DO il = 1, nloc
-    coef_clos(il) = 1.
-  END DO
-
-! --------------------------------------------------------------------
-! --- CALCULATE ARRAYS OF GEOPOTENTIAL, HEAT CAPACITY & STATIC ENERGY
-! --------------------------------------------------------------------
-
-  IF (iflag_con==3) THEN
-
-    IF (debut) THEN
-      PRINT *, 'Emanuel version 3 nouvelle'
-    END IF
-! print*,'t1, q1 ',t1,q1
-        if (prt_level >= 9) &
-             PRINT *, 'cva_driver -> cv3_prelim'
-    CALL cv3_prelim(len, nd, ndp1, t1, q1, p1, ph1, &           ! nd->na
-                    lv1, lf1, cpn1, tv1, gz1, h1, hm1, th1)
-
-
-        if (prt_level >= 9) &
-             PRINT *, 'cva_driver -> cv3_prelim'
-    CALL cv3_prelim(len, nd, ndp1, t1_wake, q1_wake, p1, ph1, & ! nd->na
-                    lv1_wake, lf1_wake, cpn1_wake, tv1_wake, gz1_wake, &
-                    h1_wake, bid, th1_wake)
-
-  END IF
-
-  IF (iflag_con==4) THEN
-    PRINT *, 'Emanuel version 4 '
-        if (prt_level >= 9) &
-             PRINT *, 'cva_driver -> cv_prelim'
-    CALL cv_prelim(len, nd, ndp1, t1, q1, p1, ph1, &
-                   lv1, cpn1, tv1, gz1, h1, hm1)
-  END IF
-
-! --------------------------------------------------------------------
-! --- CONVECTIVE FEED
-! --------------------------------------------------------------------
-
-! compute feeding layer potential temperature and mixing ratio :
-
-! get bounds of feeding layer
-
-! test niveaux couche alimentation KE
-  IF (sig1feed1==sig2feed1) THEN
-    WRITE (lunout, *) 'impossible de choisir sig1feed=sig2feed'
-    WRITE (lunout, *) 'changer la valeur de sig2feed dans physiq.def'
-    abort_message = ''
-    CALL abort_physic(modname, abort_message, 1)
-  END IF
-
-  DO i = 1, len
-    p1feed1(i) = sig1feed1*ph1(i, 1)
-    p2feed1(i) = sig2feed1*ph1(i, 1)
-!test maf
-!   p1feed1(i)=ph1(i,1)
-!   p2feed1(i)=ph1(i,2)
-!   p2feed1(i)=ph1(i,3)
-!testCR: on prend la couche alim des thermiques
-!   p2feed1(i)=ph1(i,lalim_conv1(i)+1)
-!   print*,'lentr=',lentr(i),ph1(i,lentr(i)+1),ph1(i,2)
-  END DO
-
-  IF (iflag_con==3) THEN
-  END IF
-  DO i = 1, len
-! print*,'avant cv3_feed Plim',p1feed1(i),p2feed1(i)
-  END DO
-  IF (iflag_con==3) THEN
-
-! print*, 'IFLAG1 avant cv3_feed'
-! print*,'len,nd',len,nd
-! write(*,'(64i1)') iflag1(2:len-1)
-
-        if (prt_level >= 9) &
-             PRINT *, 'cva_driver -> cv3_feed'
-    CALL cv3_feed(len, nd, ok_conserv_q, &                 ! nd->na
-                  t1, q1, u1, v1, p1, ph1, h1, gz1, & 
-                  p1feed1, p2feed1, wght1, &
-                  wghti1, tnk1, thnk1, qnk1, qsnk1, unk1, vnk1, &
-                  cpnk1, hnk1, nk1, icb1, icbmax, iflag1, gznk1, plcl1)
-  END IF
-
-! print*, 'IFLAG1 apres cv3_feed'
-! print*,'len,nd',len,nd
-! write(*,'(64i1)') iflag1(2:len-1)
-
-  IF (iflag_con==4) THEN
-        if (prt_level >= 9) &
-             PRINT *, 'cva_driver -> cv_feed'
-    CALL cv_feed(len, nd, t1, q1, qs1, p1, hm1, gz1, &
-                 nk1, icb1, icbmax, iflag1, tnk1, qnk1, gznk1, plcl1)
-  END IF
-
-! print *, 'cv3_feed-> iflag1, plcl1 ',iflag1(1),plcl1(1)
-
-! --------------------------------------------------------------------
-! --- UNDILUTE (ADIABATIC) UPDRAFT / 1st part
-! (up through ICB for convect4, up through ICB+1 for convect3)
-! Calculates the lifted parcel virtual temperature at nk, the
-! actual temperature, and the adiabatic liquid water content.
-! --------------------------------------------------------------------
-
-  IF (iflag_con==3) THEN
-
-        if (prt_level >= 9) &
-             PRINT *, 'cva_driver -> cv3_undilute1'
-    CALL cv3_undilute1(len, nd, t1, qs1, gz1, plcl1, p1, icb1, tnk1, qnk1, & ! nd->na
-                       gznk1, tp1, tvp1, clw1, icbs1)
-  END IF
-
-
-  IF (iflag_con==4) THEN
-        if (prt_level >= 9) &
-             PRINT *, 'cva_driver -> cv_undilute1'
-    CALL cv_undilute1(len, nd, t1, q1, qs1, gz1, p1, nk1, icb1, icbmax, &
-                      tp1, tvp1, clw1)
-  END IF
-
-! -------------------------------------------------------------------
-! --- TRIGGERING
-! -------------------------------------------------------------------
-
-! print *,' avant triggering, iflag_con ',iflag_con
-
-  IF (iflag_con==3) THEN
-
-        if (prt_level >= 9) &
-             PRINT *, 'cva_driver -> cv3_trigger'
-    CALL cv3_trigger(len, nd, icb1, plcl1, p1, th1, tv1, tvp1, thnk1, & ! nd->na
-                      pbase1, buoybase1, iflag1, sig1, w01)
-
-
-! print*, 'IFLAG1 apres cv3_triger'
-! print*,'len,nd',len,nd
-! write(*,'(64i1)') iflag1(2:len-1)
-
-! call dump2d(iim,jjm-1,sig1(2)
-  END IF
-
-  IF (iflag_con==4) THEN
-        if (prt_level >= 9) &
-             PRINT *, 'cva_driver -> cv_trigger'
-    CALL cv_trigger(len, nd, icb1, cbmf1, tv1, tvp1, iflag1)
-  END IF
-
-
-! =====================================================================
-! --- IF THIS POINT IS REACHED, MOIST CONVECTIVE ADJUSTMENT IS NECESSARY
-! =====================================================================
-
-!  Determine the number "ncum" of convective gridpoints, the list "idcum" of convective
-!  gridpoints and the weights "coef_convective" (= 1. for convective gridpoints and = 0.
-!  elsewhere).
-  ncum = 0
-  coef_convective(:) = 0.
-  DO i = 1, len
-    IF (iflag1(i)==0) THEN
-      coef_convective(i) = 1.
-      ncum = ncum + 1
-      idcum(ncum) = i
-    END IF
-  END DO
-
-! print*,'len, ncum = ',len,ncum
-
-  IF (ncum>0) THEN
-
-! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-! --- COMPRESS THE FIELDS
-!       (-> vectorization over convective gridpoints)
-! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-
-    IF (iflag_con==3) THEN
-! print*,'ncum tv1 ',ncum,tv1
-! print*,'tvp1 ',tvp1
-!jyg<
-!   If the fraction of convective points is larger than comp_threshold, then compression
-!   is assumed useless.
-!
-  compress = ncum .lt. len*comp_threshold
-!
-  IF (.not. compress) THEN
-    DO i = 1,len
-      idcum(i) = i
-    ENDDO
-  ENDIF
-!
-!>jyg
-        if (prt_level >= 9) &
-             PRINT *, 'cva_driver -> cv3a_compress'
-      CALL cv3a_compress(len, nloc, ncum, nd, ntra, compress, &
-                         iflag1, nk1, icb1, icbs1, &
-                         plcl1, tnk1, qnk1, gznk1, hnk1, unk1, vnk1, &
-                         wghti1, pbase1, buoybase1, &
-                         t1, q1, qs1, t1_wake, q1_wake, qs1_wake, s1_wake, &
-                         u1, v1, gz1, th1, th1_wake, &
-                         tra1, &
-                         h1, lv1, lf1, cpn1, p1, ph1, tv1, tp1, tvp1, clw1, &
-                         h1_wake, lv1_wake, lf1_wake, cpn1_wake, tv1_wake, &
-                         sig1, w01, ptop21, &
-                         Ale1, Alp1, omega1, &
-                         iflag, nk, icb, icbs, &
-                         plcl, tnk, qnk, gznk, hnk, unk, vnk, &
-                         wghti, pbase, buoybase, &
-                         t, q, qs, t_wake, q_wake, qs_wake, s_wake, &
-                         u, v, gz, th, th_wake, &
-                         tra, &
-                         h, lv, lf, cpn, p, ph, tv, tp, tvp, clw, &
-                         h_wake, lv_wake, lf_wake, cpn_wake, tv_wake, &
-                         sig, w0, ptop2, &
-                         Ale, Alp, omega)
-
-! print*,'tv ',tv
-! print*,'tvp ',tvp
-
-    END IF
-
-    IF (iflag_con==4) THEN
-        if (prt_level >= 9) &
-             PRINT *, 'cva_driver -> cv_compress'
-      CALL cv_compress(len, nloc, ncum, nd, &
-                       iflag1, nk1, icb1, &
-                       cbmf1, plcl1, tnk1, qnk1, gznk1, &
-                       t1, q1, qs1, u1, v1, gz1, &
-                       h1, lv1, cpn1, p1, ph1, tv1, tp1, tvp1, clw1, &
-                       iflag, nk, icb, &
-                       cbmf, plcl, tnk, qnk, gznk, &
-                       t, q, qs, u, v, gz, h, lv, cpn, p, ph, tv, tp, tvp, clw, &
-                       dph)
-    END IF
-
-! -------------------------------------------------------------------
-! --- UNDILUTE (ADIABATIC) UPDRAFT / second part :
-! ---   FIND THE REST OF THE LIFTED PARCEL TEMPERATURES
-! ---   &
-! ---   COMPUTE THE PRECIPITATION EFFICIENCIES AND THE
-! ---   FRACTION OF PRECIPITATION FALLING OUTSIDE OF CLOUD
-! ---   &
-! ---   FIND THE LEVEL OF NEUTRAL BUOYANCY
-! -------------------------------------------------------------------
-
-    IF (iflag_con==3) THEN
-        if (prt_level >= 9) &
-             PRINT *, 'cva_driver -> cv3_undilute2'
-      CALL cv3_undilute2(nloc, ncum, nd, iflag, icb, icbs, nk, &        !na->nd
-                         tnk, qnk, gznk, hnk, t, q, qs, gz, &
-                         p, ph, h, tv, lv, lf, pbase, buoybase, plcl, &
-                         inb, tp, tvp, clw, hp, ep, sigp, buoy, &
-                         frac_a, frac_s, qpreca, qta)                        !!jygprl
-    END IF
-
-    IF (iflag_con==4) THEN
-        if (prt_level >= 9) &
-             PRINT *, 'cva_driver -> cv_undilute2'
-      CALL cv_undilute2(nloc, ncum, nd, icb, nk, &
-                        tnk, qnk, gznk, t, q, qs, gz, &
-                        p, dph, h, tv, lv, &
-                        inb, inbis, tp, tvp, clw, hp, ep, sigp, frac_s)
-    END IF
-
-    ! epmax_cape
-    ! on recalcule ep et hp    
-        if (prt_level >= 9) &
-             PRINT *, 'cva_driver -> cv3_epmax_cape'
-    call cv3_epmax_fn_cape(nloc,ncum,nd &
-                , ep,hp,icb,inb,clw,nk,t,h,hnk,lv,lf,frac_s &
-                , pbase, p, ph, tv, buoy, sig, w0,iflag &
-                , epmax_diag)
-
-! -------------------------------------------------------------------
-! --- MIXING(1)   (if iflag_mix .ge. 1)
-! -------------------------------------------------------------------
-    IF (iflag_con==3) THEN
-!      IF ((iflag_ice_thermo==1) .AND. (iflag_mix/=0)) THEN
-!        WRITE (*, *) ' iflag_ice_thermo==1 requires iflag_mix==0', ' but iflag_mix=', iflag_mix, &
-!          '. Might as well stop here.'
-!        STOP
-!      END IF
-      IF (iflag_mix>=1) THEN
-        CALL zilch(supmax, nloc*nd)
-        if (prt_level >= 9) &
-             PRINT *, 'cva_driver -> cv3p_mixing'
-        CALL cv3p_mixing(nloc, ncum, nd, nd, ntra, icb, nk, inb, &           ! na->nd
-!!                         ph, t, q, qs, u, v, tra, h, lv, lf, frac, qnk, &
-                         ph, t, q, qs, u, v, tra, h, lv, lf, frac_s, qta, &      !!jygprl
-                         unk, vnk, hp, tv, tvp, ep, clw, sig, &
-                         ment, qent, hent, uent, vent, nent, &
-                         sigij, elij, supmax, ments, qents, traent)
-! print*, 'cv3p_mixing-> supmax ', (supmax(1,k), k=1,nd)
-
-      ELSE
-        CALL zilch(supmax, nloc*nd)
-      END IF
-    END IF
-! -------------------------------------------------------------------
-! --- CLOSURE
-! -------------------------------------------------------------------
-
-
-    IF (iflag_con==3) THEN
-      IF (iflag_clos==0) THEN
-        if (prt_level >= 9) &
-             PRINT *, 'cva_driver -> cv3_closure'
-        CALL cv3_closure(nloc, ncum, nd, icb, inb, &           ! na->nd
-                         pbase, p, ph, tv, buoy, &
-                         sig, w0, cape, m, iflag)
-      END IF   ! iflag_clos==0
-
-      ok_inhib = iflag_mix == 2
-
-      IF (iflag_clos==1) THEN
-        PRINT *, ' pas d appel cv3p_closure'
-! c        CALL cv3p_closure(nloc,ncum,nd,icb,inb              ! na->nd
-! c    :                       ,pbase,plcl,p,ph,tv,tvp,buoy
-! c    :                       ,supmax
-! c    o                       ,sig,w0,ptop2,cape,cin,m)
-      END IF   ! iflag_clos==1
-
-      IF (iflag_clos==2) THEN
-        if (prt_level >= 9) &
-             PRINT *, 'cva_driver -> cv3p1_closure'
-        CALL cv3p1_closure(nloc, ncum, nd, icb, inb, &         ! na->nd
-                           pbase, plcl, p, ph, tv, tvp, buoy, &
-                           supmax, ok_inhib, Ale, Alp, omega, &
-                           sig, w0, ptop2, cape, cin, m, iflag, coef_clos, &
-                           Plim1, plim2, asupmax, supmax0, &
-                           asupmaxmin, cbmf, plfc, wbeff)
-        if (prt_level >= 10) &
-             PRINT *, 'cv3p1_closure-> plfc,wbeff ', plfc(1), wbeff(1)
-      END IF   ! iflag_clos==2
-
-      IF (iflag_clos==3) THEN
-        if (prt_level >= 9) &
-             PRINT *, 'cva_driver -> cv3p2_closure'
-        CALL cv3p2_closure(nloc, ncum, nd, icb, inb, &         ! na->nd
-                           pbase, plcl, p, ph, tv, tvp, buoy, &
-                           supmax, ok_inhib, Ale, Alp, omega, &
-                           sig, w0, ptop2, cape, cin, m, iflag, coef_clos, &
-                           Plim1, plim2, asupmax, supmax0, &
-                           asupmaxmin, cbmf, plfc, wbeff)
-        if (prt_level >= 10) &
-             PRINT *, 'cv3p2_closure-> plfc,wbeff ', plfc(1), wbeff(1)
-      END IF   ! iflag_clos==3
-    END IF ! iflag_con==3
-
-    IF (iflag_con==4) THEN
-        if (prt_level >= 9) &
-             PRINT *, 'cva_driver -> cv_closure'
-      CALL cv_closure(nloc, ncum, nd, nk, icb, &
-                         tv, tvp, p, ph, dph, plcl, cpn, &
-                         iflag, cbmf)
-    END IF
-
-! print *,'cv_closure-> cape ',cape(1)
-
-! -------------------------------------------------------------------
-! --- MIXING(2)
-! -------------------------------------------------------------------
-
-    IF (iflag_con==3) THEN
-      IF (iflag_mix==0) THEN
-        if (prt_level >= 9) &
-             PRINT *, 'cva_driver -> cv3_mixing'
-        CALL cv3_mixing(nloc, ncum, nd, nd, ntra, icb, nk, inb, &             ! na->nd
-                        ph, t, q, qs, u, v, tra, h, lv, lf, frac_s, qnk, &
-                        unk, vnk, hp, tv, tvp, ep, clw, m, sig, &
-                        ment, qent, uent, vent, nent, sigij, elij, ments, qents, traent)
-        CALL zilch(hent, nloc*nd*nd)
-      ELSE
-!!jyg:  Essais absurde pour voir
-!!        mm(:,1) = 0.
-!!        DO  i = 2,nd
-!!          mm(:,i) = m(:,i)*(1.-qta(:,i-1))
-!!        ENDDO
-        mm(:,:) = m(:,:)
-        CALL cv3_mixscale(nloc, ncum, nd, ment, mm)
-        IF (debut) THEN
-          PRINT *, ' cv3_mixscale-> '
-        END IF !(debut) THEN
-      END IF
-    END IF
-
-    IF (iflag_con==4) THEN
-        if (prt_level >= 9) &
-             PRINT *, 'cva_driver -> cv_mixing'
-      CALL cv_mixing(nloc, ncum, nd, icb, nk, inb, inbis, &
-                     ph, t, q, qs, u, v, h, lv, qnk, &
-                     hp, tv, tvp, ep, clw, cbmf, &
-                     m, ment, qent, uent, vent, nent, sigij, elij)
-    END IF                                                                                         
-
-    IF (debut) THEN
-      PRINT *, ' cv_mixing ->'
-    END IF !(debut) THEN
-! do i = 1,nd
-! print*,'cv_mixing-> i,ment ',i,(ment(1,i,j),j=1,nd)
-! enddo
-
-! -------------------------------------------------------------------
-! --- UNSATURATED (PRECIPITATING) DOWNDRAFTS
-! -------------------------------------------------------------------
-    IF (iflag_con==3) THEN
-      IF (debut) THEN
-        PRINT *, ' cva_driver -> cv3_unsat '
-      END IF !(debut) THEN
-
-        if (prt_level >= 9) &
-             PRINT *, 'cva_driver -> cv3_unsat'
-      CALL cv3_unsat(nloc, ncum, nd, nd, ntra, icb, inb, iflag, &              ! na->nd
-                     t_wake, q_wake, qs_wake, gz, u, v, tra, p, ph, &
-                     th_wake, tv_wake, lv_wake, lf_wake, cpn_wake, &
-                     ep, sigp, clw, frac_s, qpreca, frac_a, qta, &                    !!jygprl
-                     m, ment, elij, delt, plcl, coef_clos, &
-                     mp, qp, up, vp, trap, wt, water, evap, fondue, ice, &
-                     faci, b, sigd, &
-!!                     wdtrainA, wdtrainM)                                       ! RomP
-                     wdtrainA, wdtrainS, wdtrainM)                               !!jygprl
-!
-      IF (prt_level >= 10) THEN
-        Print *, 'cva_driver after cv3_unsat:mp , water, ice, evap, fondue '
-        DO k = 1,nd
-        write (6, '(i4,5(1x,e13.6))'), &
-          k, mp(igout,k), water(igout,k), ice(igout,k), &
-           evap(igout,k), fondue(igout,k)
-        ENDDO
-        Print *, 'cva_driver after cv3_unsat: wdtrainA, wdtrainS, wdtrainM '     !!jygprl
-        DO k = 1,nd
-        write (6, '(i4,3(1x,e13.6))'), &
-           k, wdtrainA(igout,k), wdtrainS(igout,k), wdtrainM(igout,k)            !!jygprl
-        ENDDO
-      ENDIF
-!
-    END IF  !(iflag_con==3)
-
-    IF (iflag_con==4) THEN
-        if (prt_level >= 9) &
-             PRINT *, 'cva_driver -> cv_unsat'
-      CALL cv_unsat(nloc, ncum, nd, inb, t, q, qs, gz, u, v, p, ph, &
-                     h, lv, ep, sigp, clw, m, ment, elij, &
-                     iflag, mp, qp, up, vp, wt, water, evap)
-    END IF
-
-    IF (debut) THEN
-      PRINT *, 'cv_unsat-> '
-    END IF !(debut) THEN
-
-! print *,'cv_unsat-> mp ',mp
-! print *,'cv_unsat-> water ',water
-! -------------------------------------------------------------------
-! --- YIELD
-! (tendencies, precipitation, variables of interface with other
-! processes, etc)
-! -------------------------------------------------------------------
-
-    IF (iflag_con==3) THEN
-
-        if (prt_level >= 9) &
-             PRINT *, 'cva_driver -> cv3_yield'
-      CALL cv3_yield(nloc, ncum, nd, nd, ntra, ok_conserv_q, &                      ! na->nd
-                     icb, inb, delt, &
-                     t, q, t_wake, q_wake, s_wake, u, v, tra, &
-                     gz, p, ph, h, hp, lv, lf, cpn, th, th_wake, &
-                     ep, clw, qpreca, m, tp, mp, qp, up, vp, trap, &
-                     wt, water, ice, evap, fondue, faci, b, sigd, &
-                     ment, qent, hent, iflag_mix, uent, vent, &
-                     nent, elij, traent, sig, &
-                     tv, tvp, wghti, &
-                     iflag, precip, Vprecip, Vprecipi, ft, fq, fqcomp, fu, fv, ftra, &      ! jyg
-                     cbmf, upwd, dnwd, dnwd0, ma, mip, &
-!!                     tls, tps, &                            ! useless . jyg
-                     qcondc, wd, &
-!!                     ftd, fqd, qnk, qtc, sigt, tau_cld_cv, coefw_cld_cv)
-                     ftd, fqd, qta, qtc, sigt, detrain, tau_cld_cv, coefw_cld_cv)         !!jygprl
-!
-!         Test conseravtion de l'eau
-!
-      IF (debut) THEN
-        PRINT *, ' cv3_yield -> fqd(1) = ', fqd(igout, 1)
-      END IF !(debut) THEN
-!   
-      IF (prt_level >= 10) THEN
-        Print *, 'cva_driver after cv3_yield:ft(1) , ftd(1) ', &
-                    ft(igout,1), ftd(igout,1)
-        Print *, 'cva_driver after cv3_yield:fq(1) , fqd(1) ', &
-                    fq(igout,1), fqd(igout,1)
-      ENDIF
-!   
-    END IF
-
-    IF (iflag_con==4) THEN
-        if (prt_level >= 9) &
-             PRINT *, 'cva_driver -> cv_yield'
-      CALL cv_yield(nloc, ncum, nd, nk, icb, inb, delt, &
-                     t, q, u, v, &
-                     gz, p, ph, h, hp, lv, cpn, &
-                     ep, clw, frac_s, m, mp, qp, up, vp, &
-                     wt, water, evap, &
-                     ment, qent, uent, vent, nent, elij, &
-                     tv, tvp, &
-                     iflag, wd, qprime, tprime, &
-                     precip, cbmf, ft, fq, fu, fv, ma, qcondc)
-    END IF
-
-!AC!
-!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-!--- passive tracers
-!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-
-    IF (iflag_con==3) THEN
-!RomP >>>
-        if (prt_level >= 9) &
-             PRINT *, 'cva_driver -> cv3_tracer'
-      CALL cv3_tracer(nloc, len, ncum, nd, nd, &
-                     ment, sigij, da, phi, phi2, d1a, dam, &
-                     ep, vprecip, elij, clw, epmlmMm, eplaMm, &
-                     icb, inb)
-!RomP <<<
-    END IF
-
-!AC!
-
-! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-! --- UNCOMPRESS THE FIELDS
-! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-
-
-    IF (iflag_con==3) THEN
-        if (prt_level >= 9) &
-             PRINT *, 'cva_driver -> cv3a_uncompress'
-      CALL cv3a_uncompress(nloc, len, ncum, nd, ntra, idcum, compress, &
-                           iflag, icb, inb, &
-                           precip, cbmf, plcl, plfc, wbeff, sig, w0, ptop2, &
-                           ft, fq, fqcomp, fu, fv, ftra, &
-                           sigd, ma, mip, vprecip, vprecipi, upwd, dnwd, dnwd0, &
-                           qcondc, wd, cape, cin, &
-                           tvp, &
-                           ftd, fqd, &
-                           Plim1, plim2, asupmax, supmax0, &
-                           asupmaxmin, &
-                           da, phi, mp, phi2, d1a, dam, sigij, &         ! RomP
-                           qta, clw, elij, evap, ep, epmlmMm, eplaMm, &  ! RomP
-                           wdtrainA, wdtrainS, wdtrainM, &                         ! RomP
-                           qtc, sigt, detrain, epmax_diag, & ! epmax_cape
-                           iflag1, kbas1, ktop1, &
-                           precip1, cbmf1, plcl1, plfc1, wbeff1, sig1, w01, ptop21, &
-                           ft1, fq1, fqcomp1, fu1, fv1, ftra1, &
-                           sigd1, ma1, mip1, vprecip1, vprecipi1, upwd1, dnwd1, dnwd01, &
-                           qcondc1, wd1, cape1, cin1, &
-                           tvp1, &
-                           ftd1, fqd1, &
-                           Plim11, plim21, asupmax1, supmax01, &
-                           asupmaxmin1, &
-                           da1, phi1, mp1, phi21, d1a1, dam1, sigij1,  &       ! RomP
-                           qta1, clw1, elij1, evap1, ep1, epmlmMm1, eplaMm1, & ! RomP
-                           wdtrainA1, wdtrainS1, wdtrainM1,                  & ! RomP
-                           qtc1, sigt1, detrain1, epmax_diag1) ! epmax_cape
-!   
-      IF (prt_level >= 10) THEN
-        Print *, 'cva_driver after cv3_uncompress:ft1(1) , ftd1(1) ', &
-                    ft1(igout,1), ftd1(igout,1)
-        Print *, 'cva_driver after cv3_uncompress:fq1(1) , fqd1(1) ', &
-                    fq1(igout,1), fqd1(igout,1)
-      ENDIF
-!   
-    END IF
-
-    IF (iflag_con==4) THEN
-        if (prt_level >= 9) &
-             PRINT *, 'cva_driver -> cv_uncompress'
-      CALL cv_uncompress(nloc, len, ncum, nd, idcum, &
-                           iflag, &
-                           precip, cbmf, &
-                           ft, fq, fu, fv, &
-                           ma, qcondc, &
-                           iflag1, &
-                           precip1,cbmf1, &
-                           ft1, fq1, fu1, fv1, &
-                           ma1, qcondc1)
-    END IF
-
-  END IF ! ncum>0
-!
-!
-  DO i = 1,len
-    IF (iflag1(i) == 14) THEN
-      Cin1(i) = Cin_noconv
-      Cape1(i) = Cape_noconv
-    ENDIF
-  ENDDO
-
-!
-! In order take into account the possibility of changing the compression,
-! reset m, sig and w0 to zero for non-convective points.
-  DO k = 1,nd-1
-        sig1(:, k) = sig1(:, k)*coef_convective(:)
-        w01(:, k)  = w01(:, k)*coef_convective(:)
-  ENDDO
-
-  IF (debut) THEN
-    PRINT *, ' cv_uncompress -> '
-    debut = .FALSE.
-  END IF  !(debut) THEN
-
-
-  RETURN
-END SUBROUTINE cva_driver
Index: /LMDZ6/trunk/libf/phylmd/cva_driver.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cva_driver.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/cva_driver.f90	(revision 5268)
@@ -0,0 +1,1286 @@
+
+! $Id$
+
+SUBROUTINE cva_driver(len, nd, ndp1, ntra, nloc, k_upper, &
+                      iflag_con, iflag_mix, iflag_ice_thermo, iflag_clos, ok_conserv_q, &
+!!                      delt, t1, q1, qs1, t1_wake, q1_wake, qs1_wake, s1_wake, &  ! jyg
+                      delt, comp_threshold, &                                      ! jyg
+                      t1, q1, qs1, t1_wake, q1_wake, qs1_wake, s1_wake, &          ! jyg
+                      u1, v1, tra1, &
+                      p1, ph1, &
+                      Ale1, Alp1, omega1, &
+                      sig1feed1, sig2feed1, wght1, &
+                      iflag1, ft1, fq1, fqcomp1, fu1, fv1, ftra1, &
+                      precip1, kbas1, ktop1, &
+                      cbmf1, plcl1, plfc1, wbeff1, &
+                      sig1, w01, & !input/output
+                      ptop21, sigd1, &
+                      ma1, mip1, Vprecip1, Vprecipi1, upwd1, dnwd1, dnwd01, &      ! jyg
+                      qcondc1, wd1, &
+                      cape1, cin1, tvp1, &
+                      ftd1, fqd1, &
+                      Plim11, Plim21, asupmax1, supmax01, asupmaxmin1, &
+                      lalim_conv1, & 
+!!                      da1,phi1,mp1,phi21,d1a1,dam1,sigij1,clw1, &        ! RomP
+!!                      elij1,evap1,ep1,epmlmMm1,eplaMm1, &                ! RomP
+                      da1, phi1, mp1, phi21, d1a1, dam1, sigij1, wghti1, & ! RomP, RL
+                      qta1, clw1, elij1, evap1, ep1, epmlmMm1, eplaMm1, &  ! RomP, RL
+                      wdtrainA1, wdtrainS1, wdtrainM1, qtc1, sigt1, detrain1, tau_cld_cv, &     !!jygprl
+                      coefw_cld_cv, &                                      ! RomP, AJ
+                      epmax_diag1)  ! epmax_cape
+! **************************************************************
+! *
+! CV_DRIVER                                                   *
+! *
+! *
+! written by   : Sandrine Bony-Lena , 17/05/2003, 11.19.41    *
+! modified by :                                               *
+! **************************************************************
+! **************************************************************
+
+  USE print_control_mod, ONLY: prt_level, lunout
+  USE add_phys_tend_mod, ONLY: fl_cor_ebil
+  IMPLICIT NONE
+
+! .............................START PROLOGUE............................
+
+
+! All argument names (except len,nd,ntra,nloc,delt and the flags) have a "1" appended.
+! The "1" is removed for the corresponding compressed variables.
+! PARAMETERS:
+! Name            Type         Usage            Description
+! ----------      ----------     -------  ----------------------------
+
+! len           Integer        Input        first (i) dimension
+! nd            Integer        Input        vertical (k) dimension
+! ndp1          Integer        Input        nd + 1
+! ntra          Integer        Input        number of tracors
+! nloc          Integer        Input        dimension of arrays for compressed fields
+! k_upper       Integer        Input        upmost level for vertical loops
+! iflag_con     Integer        Input        version of convect (3/4)
+! iflag_mix     Integer        Input        version of mixing  (0/1/2)
+! iflag_ice_thermo Integer        Input        accounting for ice thermodynamics (0/1)
+! iflag_clos    Integer        Input        version of closure (0/1)
+! tau_cld_cv    Real           Input        characteristic time of dissipation of mixing fluxes
+! coefw_cld_cv  Real           Input        coefficient for updraft velocity in convection
+! ok_conserv_q  Logical        Input        when true corrections for water conservation are swtiched on
+! delt          Real           Input        time step
+! comp_threshold Real           Input       threshold on the fraction of convective points below which
+!                                            fields  are compressed
+! t1            Real           Input        temperature (sat draught envt)
+! q1            Real           Input        specific hum (sat draught envt)
+! qs1           Real           Input        sat specific hum (sat draught envt)
+! t1_wake       Real           Input        temperature (unsat draught envt)
+! q1_wake       Real           Input        specific hum(unsat draught envt)
+! qs1_wake      Real           Input        sat specific hum(unsat draughts envt)
+! s1_wake       Real           Input        fractionnal area covered by wakes
+! u1            Real           Input        u-wind
+! v1            Real           Input        v-wind
+! tra1          Real           Input        tracors
+! p1            Real           Input        full level pressure
+! ph1           Real           Input        half level pressure
+! ALE1          Real           Input        Available lifting Energy
+! ALP1          Real           Input        Available lifting Power
+! sig1feed1     Real           Input        sigma coord at lower bound of feeding layer
+! sig2feed1     Real           Input        sigma coord at upper bound of feeding layer
+! wght1         Real           Input        weight density determining the feeding mixture
+! iflag1        Integer        Output       flag for Emanuel conditions
+! ft1           Real           Output       temp tend
+! fq1           Real           Output       spec hum tend
+! fqcomp1       Real           Output       spec hum tend (only mixed draughts)
+! fu1           Real           Output       u-wind tend
+! fv1           Real           Output       v-wind tend
+! ftra1         Real           Output       tracor tend
+! precip1       Real           Output       precipitation
+! kbas1         Integer        Output       cloud base level
+! ktop1         Integer        Output       cloud top level
+! cbmf1         Real           Output       cloud base mass flux
+! sig1          Real           In/Out       section adiabatic updraft
+! w01           Real           In/Out       vertical velocity within adiab updraft
+! ptop21        Real           In/Out       top of entraining zone
+! Ma1           Real           Output       mass flux adiabatic updraft
+! mip1          Real           Output       mass flux shed by the adiabatic updraft
+! Vprecip1      Real           Output       vertical profile of total precipitation
+! Vprecipi1     Real           Output       vertical profile of ice precipitation
+! upwd1         Real           Output       total upward mass flux (adiab+mixed)
+! dnwd1         Real           Output       saturated downward mass flux (mixed)
+! dnwd01        Real           Output       unsaturated downward mass flux
+! qcondc1       Real           Output       in-cld mixing ratio of condensed water
+! wd1           Real           Output       downdraft velocity scale for sfc fluxes
+! cape1         Real           Output       CAPE
+! cin1          Real           Output       CIN
+! tvp1          Real           Output       adiab lifted parcell virt temp
+! ftd1          Real           Output       precip temp tend
+! fqt1          Real           Output       precip spec hum tend
+! Plim11        Real           Output
+! Plim21        Real           Output
+! asupmax1      Real           Output
+! supmax01      Real           Output
+! asupmaxmin1   Real           Output
+
+! ftd1          Real           Output  Array of temperature tendency due to precipitations (K/s) of dimension ND,
+!                                      defined at same grid levels as T, Q, QS and P.
+
+! fqd1          Real           Output  Array of specific humidity tendencies due to precipitations ((gm/gm)/s)
+!                                      of dimension ND, defined at same grid levels as T, Q, QS and P.
+
+! wdtrainA1     Real           Output   precipitation ejected from adiabatic draught;
+!                                         should be used in tracer transport (cvltr)
+! wdtrainS1     Real           Output   precipitation detrained from shedding of adiabatic draught;
+!                                         used in tracer transport (cvltr)
+! wdtrainM1     Real           Output   precipitation detrained from mixed draughts;
+!                                         used in tracer transport (cvltr)
+! da1           Real           Output     used in tracer transport (cvltr)
+! phi1          Real           Output     used in tracer transport (cvltr)
+! mp1           Real           Output     used in tracer transport (cvltr)
+! qtc1          Real           Output     specific humidity in convection
+! sigt1         Real           Output     surface fraction in adiabatic updrafts                                         
+! detrain1      Real           Output     detrainment terme klein
+! phi21         Real           Output     used in tracer transport (cvltr)
+                                         
+! d1a1          Real           Output     used in tracer transport (cvltr)
+! dam1          Real           Output     used in tracer transport (cvltr)
+                                         
+! epmlmMm1      Real           Output     used in tracer transport (cvltr)
+! eplaMm1       Real           Output     used in tracer transport (cvltr)
+                                         
+! evap1         Real           Output    
+! ep1           Real           Output    
+! sigij1        Real           Output     used in tracer transport (cvltr)
+! clw1          Real           Output   condensed water content of the adiabatic updraught
+! elij1         Real           Output
+! wghti1        Real           Output   final weight of the feeding layers,
+!                                         used in tracer transport (cvltr)
+
+
+! S. Bony, Mar 2002:
+! * Several modules corresponding to different physical processes
+! * Several versions of convect may be used:
+!         - iflag_con=3: version lmd  (previously named convect3)
+!         - iflag_con=4: version 4.3b (vect. version, previously convect1/2)
+! + tard: - iflag_con=5: version lmd with ice (previously named convectg)
+! S. Bony, Oct 2002:
+! * Vectorization of convect3 (ie version lmd)
+
+! ..............................END PROLOGUE.............................
+
+
+
+! Input
+  INTEGER, INTENT (IN)                               :: len
+  INTEGER, INTENT (IN)                               :: nd
+  INTEGER, INTENT (IN)                               :: ndp1
+  INTEGER, INTENT (IN)                               :: ntra
+  INTEGER, INTENT(IN)                                :: nloc ! (nloc=len)  pour l'instant
+  INTEGER, INTENT (IN)                               :: k_upper
+  INTEGER, INTENT (IN)                               :: iflag_con
+  INTEGER, INTENT (IN)                               :: iflag_mix
+  INTEGER, INTENT (IN)                               :: iflag_ice_thermo
+  INTEGER, INTENT (IN)                               :: iflag_clos
+  LOGICAL, INTENT (IN)                               :: ok_conserv_q
+  REAL, INTENT (IN)                                  :: tau_cld_cv
+  REAL, INTENT (IN)                                  :: coefw_cld_cv
+  REAL, INTENT (IN)                                  :: delt
+  REAL, INTENT (IN)                                  :: comp_threshold
+  REAL, DIMENSION (len, nd), INTENT (IN)             :: t1
+  REAL, DIMENSION (len, nd), INTENT (IN)             :: q1
+  REAL, DIMENSION (len, nd), INTENT (IN)             :: qs1
+  REAL, DIMENSION (len, nd), INTENT (IN)             :: t1_wake
+  REAL, DIMENSION (len, nd), INTENT (IN)             :: q1_wake
+  REAL, DIMENSION (len, nd), INTENT (IN)             :: qs1_wake
+  REAL, DIMENSION (len), INTENT (IN)                 :: s1_wake
+  REAL, DIMENSION (len, nd), INTENT (IN)             :: u1
+  REAL, DIMENSION (len, nd), INTENT (IN)             :: v1
+  REAL, DIMENSION (len, nd, ntra), INTENT (IN)       :: tra1
+  REAL, DIMENSION (len, nd), INTENT (IN)             :: p1
+  REAL, DIMENSION (len, ndp1), INTENT (IN)           :: ph1
+  REAL, DIMENSION (len), INTENT (IN)                 :: Ale1
+  REAL, DIMENSION (len), INTENT (IN)                 :: Alp1
+  REAL, DIMENSION (len, nd), INTENT (IN)             :: omega1
+  REAL, INTENT (IN)                                  :: sig1feed1 ! pressure at lower bound of feeding layer
+  REAL, INTENT (IN)                                  :: sig2feed1 ! pressure at upper bound of feeding layer
+  REAL, DIMENSION (nd), INTENT (IN)                  :: wght1     ! weight density determining the feeding mixture
+  INTEGER, DIMENSION (len), INTENT (IN)              :: lalim_conv1
+
+! Input/Output
+  REAL, DIMENSION (len, nd), INTENT (INOUT)          :: sig1
+  REAL, DIMENSION (len, nd), INTENT (INOUT)          :: w01
+
+! Output
+  INTEGER, DIMENSION (len), INTENT (OUT)             :: iflag1
+  REAL, DIMENSION (len, nd), INTENT (OUT)            :: ft1
+  REAL, DIMENSION (len, nd), INTENT (OUT)            :: fq1
+  REAL, DIMENSION (len, nd), INTENT (OUT)            :: fqcomp1
+  REAL, DIMENSION (len, nd), INTENT (OUT)            :: fu1
+  REAL, DIMENSION (len, nd), INTENT (OUT)            :: fv1
+  REAL, DIMENSION (len, nd, ntra), INTENT (OUT)      :: ftra1
+  REAL, DIMENSION (len), INTENT (OUT)                :: precip1
+  INTEGER, DIMENSION (len), INTENT (OUT)             :: kbas1
+  INTEGER, DIMENSION (len), INTENT (OUT)             :: ktop1
+  REAL, DIMENSION (len), INTENT (OUT)                :: cbmf1
+  REAL, DIMENSION (len), INTENT (OUT)                :: plcl1
+  REAL, DIMENSION (len), INTENT (OUT)                :: plfc1
+  REAL, DIMENSION (len), INTENT (OUT)                :: wbeff1
+  REAL, DIMENSION (len), INTENT (OUT)                :: ptop21
+  REAL, DIMENSION (len), INTENT (OUT)                :: sigd1
+  REAL, DIMENSION (len, nd), INTENT (OUT)            :: ma1        ! adiab. asc. mass flux (staggered grid)
+  REAL, DIMENSION (len, nd), INTENT (OUT)            :: mip1       ! mass flux shed from adiab. ascent (extensive)
+! real Vprecip1(len,nd)
+  REAL, DIMENSION (len, ndp1), INTENT (OUT)          :: vprecip1   ! tot precipitation flux (staggered grid)
+  REAL, DIMENSION (len, ndp1), INTENT (OUT)          :: vprecipi1  ! ice precipitation flux (staggered grid)
+  REAL, DIMENSION (len, nd), INTENT (OUT)            :: upwd1      ! upwd sat. mass flux (staggered grid)
+  REAL, DIMENSION (len, nd), INTENT (OUT)            :: dnwd1      ! dnwd sat. mass flux (staggered grid)
+  REAL, DIMENSION (len, nd), INTENT (OUT)            :: dnwd01     ! unsat. mass flux (staggered grid)
+  REAL, DIMENSION (len, nd), INTENT (OUT)            :: qcondc1    ! max cloud condensate (intensive)  ! cld
+  REAL, DIMENSION (len), INTENT (OUT)                :: wd1             ! gust
+  REAL, DIMENSION (len), INTENT (OUT)                :: cape1
+  REAL, DIMENSION (len), INTENT (OUT)                :: cin1
+  REAL, DIMENSION (len, nd), INTENT (OUT)            :: tvp1       ! Virt. temp. in the adiab. ascent
+
+!AC!
+!!      real da1(len,nd),phi1(len,nd,nd)
+!!      real da(len,nd),phi(len,nd,nd)
+!AC!
+  REAL, DIMENSION (len, nd), INTENT (OUT)            :: ftd1       ! Temp. tendency due to the sole unsat. drafts
+  REAL, DIMENSION (len, nd), INTENT (OUT)            :: fqd1       ! Moist. tendency due to the sole unsat. drafts
+  REAL, DIMENSION (len), INTENT (OUT)                :: Plim11
+  REAL, DIMENSION (len), INTENT (OUT)                :: Plim21
+  REAL, DIMENSION (len, nd), INTENT (OUT)            :: asupmax1   ! Highest mixing fraction of mixed updraughts
+  REAL, DIMENSION (len), INTENT (OUT)                :: supmax01
+  REAL, DIMENSION (len), INTENT (OUT)                :: asupmaxmin1
+  REAL, DIMENSION (len, nd), INTENT (OUT)            :: qtc1    ! in cloud water content (intensive)   ! cld
+  REAL, DIMENSION (len, nd), INTENT (OUT)            :: sigt1   ! fract. cloud area (intensive)        ! cld
+  REAL, DIMENSION (len, nd), INTENT (OUT)            :: detrain1   ! detrainement term of mixed draughts in environment
+
+! RomP >>>
+  REAL, DIMENSION (len, nd), INTENT (OUT)            :: wdtrainA1, wdtrainS1, wdtrainM1 ! precipitation sources (extensive)
+  REAL, DIMENSION (len, nd), INTENT (OUT)            :: mp1  ! unsat. mass flux (staggered grid)
+  REAL, DIMENSION (len, nd), INTENT (OUT)            :: da1  ! detrained mass flux of adiab. asc. air (extensive)
+  REAL, DIMENSION (len, nd, nd), INTENT (OUT)        :: phi1 ! mass flux of envt. air in mixed draughts (extensive)
+  REAL, DIMENSION (len, nd, nd), INTENT (OUT)        :: epmlmMm1  ! (extensive)
+  REAL, DIMENSION (len, nd), INTENT (OUT)            :: eplaMm1   ! (extensive)
+  REAL, DIMENSION (len, nd), INTENT (OUT)            :: evap1 ! evaporation rate in precip. downdraft. (intensive)
+  REAL, DIMENSION (len, nd), INTENT (OUT)            :: ep1
+  REAL, DIMENSION (len, nd, nd), INTENT (OUT)        :: sigij1 ! mass fraction of env. air in mixed draughts (intensive) 
+  REAL, DIMENSION (len, nd, nd), INTENT (OUT)        :: elij1! cond. water per unit mass of mixed draughts (intensive) 
+  REAL, DIMENSION (len, nd), INTENT (OUT)            :: qta1 ! total water per unit mass of the adiab. asc. (intensive)
+  REAL, DIMENSION (len, nd), INTENT (OUT)            :: clw1 ! cond. water per unit mass of the adiab. asc. (intensive) 
+!JYG,RL
+  REAL, DIMENSION (len, nd), INTENT (OUT)            :: wghti1   ! final weight of the feeding layers (extensive)
+!JYG,RL
+  REAL, DIMENSION (len, nd, nd), INTENT (OUT)        :: phi21    ! (extensive)
+  REAL, DIMENSION (len, nd), INTENT (OUT)            :: d1a1     ! (extensive)
+  REAL, DIMENSION (len, nd), INTENT (OUT)            :: dam1     ! (extensive)
+! RomP <<<
+  REAL, DIMENSION (len ), INTENT (OUT)               :: epmax_diag1      
+
+! -------------------------------------------------------------------
+! Prolog by Kerry Emanuel.
+! -------------------------------------------------------------------
+! --- ARGUMENTS
+! -------------------------------------------------------------------
+! --- On input:
+
+! t:   Array of absolute temperature (K) of dimension ND, with first
+! index corresponding to lowest model level. Note that this array
+! will be altered by the subroutine if dry convective adjustment
+! occurs and if IPBL is not equal to 0.
+
+! q:   Array of specific humidity (gm/gm) of dimension ND, with first
+! index corresponding to lowest model level. Must be defined
+! at same grid levels as T. Note that this array will be altered
+! if dry convective adjustment occurs and if IPBL is not equal to 0.
+
+! qs:  Array of saturation specific humidity of dimension ND, with first
+! index corresponding to lowest model level. Must be defined
+! at same grid levels as T. Note that this array will be altered
+! if dry convective adjustment occurs and if IPBL is not equal to 0.
+
+! t_wake: Array of absolute temperature (K), seen by unsaturated draughts,
+! of dimension ND, with first index corresponding to lowest model level.
+
+! q_wake: Array of specific humidity (gm/gm), seen by unsaturated draughts,
+! of dimension ND, with first index corresponding to lowest model level.
+! Must be defined at same grid levels as T.
+
+! qs_wake: Array of saturation specific humidity, seen by unsaturated draughts,
+! of dimension ND, with first index corresponding to lowest model level.
+! Must be defined at same grid levels as T.
+
+! s_wake: Array of fractionnal area occupied by the wakes.
+
+! u:   Array of zonal wind velocity (m/s) of dimension ND, witth first
+! index corresponding with the lowest model level. Defined at
+! same levels as T. Note that this array will be altered if
+! dry convective adjustment occurs and if IPBL is not equal to 0.
+
+! v:   Same as u but for meridional velocity.
+
+! tra: Array of passive tracer mixing ratio, of dimensions (ND,NTRA),
+! where NTRA is the number of different tracers. If no
+! convective tracer transport is needed, define a dummy
+! input array of dimension (ND,1). Tracers are defined at
+! same vertical levels as T. Note that this array will be altered
+! if dry convective adjustment occurs and if IPBL is not equal to 0.
+
+! p:   Array of pressure (mb) of dimension ND, with first
+! index corresponding to lowest model level. Must be defined
+! at same grid levels as T.
+
+! ph:  Array of pressure (mb) of dimension ND+1, with first index
+! corresponding to lowest level. These pressures are defined at
+! levels intermediate between those of P, T, Q and QS. The first
+! value of PH should be greater than (i.e. at a lower level than)
+! the first value of the array P.
+
+! ALE:  Available lifting Energy
+
+! ALP:  Available lifting Power
+
+! nl:  The maximum number of levels to which convection can penetrate, plus 1.
+!       NL MUST be less than or equal to ND-1.
+
+! delt: The model time step (sec) between calls to CONVECT
+
+! ----------------------------------------------------------------------------
+! ---   On Output:
+
+! iflag: An output integer whose value denotes the following:
+!       VALUE   INTERPRETATION
+!       -----   --------------
+!         0     Moist convection occurs.
+!         1     Moist convection occurs, but a CFL condition
+!               on the subsidence warming is violated. This
+!               does not cause the scheme to terminate.
+!         2     Moist convection, but no precip because ep(inb) lt 0.0001
+!         3     No moist convection because new cbmf is 0 and old cbmf is 0.
+!         4     No moist convection; atmosphere is not
+!               unstable
+!         6     No moist convection because ihmin le minorig.
+!         7     No moist convection because unreasonable
+!               parcel level temperature or specific humidity.
+!         8     No moist convection: lifted condensation
+!               level is above the 200 mb level.
+!         9     No moist convection: cloud base is higher
+!               then the level NL-1.
+!        10     No moist convection: cloud top is too warm.
+!        14     No moist convection; atmosphere is very
+!               stable (=> no computation)
+!
+
+! ft:   Array of temperature tendency (K/s) of dimension ND, defined at same
+!       grid levels as T, Q, QS and P.
+
+! fq:   Array of specific humidity tendencies ((gm/gm)/s) of dimension ND,
+!       defined at same grid levels as T, Q, QS and P.
+
+! fu:   Array of forcing of zonal velocity (m/s^2) of dimension ND,
+!      defined at same grid levels as T.
+
+! fv:   Same as FU, but for forcing of meridional velocity.
+
+! ftra: Array of forcing of tracer content, in tracer mixing ratio per
+!       second, defined at same levels as T. Dimensioned (ND,NTRA).
+
+! precip: Scalar convective precipitation rate (mm/day).
+
+! wd:   A convective downdraft velocity scale. For use in surface
+!       flux parameterizations. See convect.ps file for details.
+
+! tprime: A convective downdraft temperature perturbation scale (K).
+!         For use in surface flux parameterizations. See convect.ps
+!         file for details.
+
+! qprime: A convective downdraft specific humidity
+!         perturbation scale (gm/gm).
+!         For use in surface flux parameterizations. See convect.ps
+!         file for details.
+
+! cbmf: The cloud base mass flux ((kg/m**2)/s). THIS SCALAR VALUE MUST
+!       BE STORED BY THE CALLING PROGRAM AND RETURNED TO CONVECT AT
+!       ITS NEXT CALL. That is, the value of CBMF must be "remembered"
+!       by the calling program between calls to CONVECT.
+
+! det:   Array of detrainment mass flux of dimension ND.
+! -------------------------------------------------------------------
+
+! Local (non compressed) arrays
+
+
+  INTEGER i, k, il
+  INTEGER nword1, nword2, nword3, nword4
+  INTEGER icbmax
+  INTEGER nk1(len)
+  INTEGER icb1(len)
+  INTEGER icbs1(len)
+
+  LOGICAL ok_inhib ! True => possible inhibition of convection by dryness
+  LOGICAL, SAVE :: debut = .TRUE.
+!$OMP THREADPRIVATE(debut)
+
+  REAL coef_convective(len)   ! = 1 for convective points, = 0 otherwise
+  REAL tnk1(len)
+  REAL thnk1(len)
+  REAL qnk1(len)
+  REAL gznk1(len)
+  REAL qsnk1(len)
+  REAL unk1(len)
+  REAL vnk1(len)
+  REAL cpnk1(len)
+  REAL hnk1(len)
+  REAL pbase1(len)
+  REAL buoybase1(len)
+
+  REAL lf1(len, nd), lf1_wake(len, nd)
+  REAL lv1(len, nd), lv1_wake(len, nd)
+  REAL cpn1(len, nd), cpn1_wake(len, nd)
+  REAL tv1(len, nd), tv1_wake(len, nd)
+  REAL gz1(len, nd), gz1_wake(len, nd)
+  REAL hm1(len, nd)
+  REAL h1(len, nd), h1_wake(len, nd)
+  REAL tp1(len, nd)
+  REAL th1(len, nd), th1_wake(len, nd)
+
+  REAL bid(len, nd) ! dummy array
+
+  INTEGER ncum
+
+  REAL p1feed1(len) ! pressure at lower bound of feeding layer
+  REAL p2feed1(len) ! pressure at upper bound of feeding layer
+!JYG,RL
+!!      real wghti1(len,nd) ! weights of the feeding layers
+!JYG,RL
+
+! (local) compressed fields:
+
+
+  INTEGER idcum(nloc)
+!jyg<
+  LOGICAL compress    ! True if compression occurs
+!>jyg
+  INTEGER iflag(nloc), nk(nloc), icb(nloc)
+  INTEGER nent(nloc, nd)
+  INTEGER icbs(nloc)
+  INTEGER inb(nloc), inbis(nloc)
+
+  REAL cbmf(nloc), plcl(nloc), plfc(nloc), wbeff(nloc)
+  REAL t(nloc, nd), q(nloc, nd), qs(nloc, nd)
+  REAL t_wake(nloc, nd), q_wake(nloc, nd), qs_wake(nloc, nd)
+  REAL s_wake(nloc)
+  REAL u(nloc, nd), v(nloc, nd)
+  REAL gz(nloc, nd), h(nloc, nd)
+  REAL h_wake(nloc, nd)
+  REAL lv(nloc, nd), lf(nloc, nd), cpn(nloc, nd)
+  REAL lv_wake(nloc, nd), lf_wake(nloc, nd), cpn_wake(nloc, nd)
+  REAL p(nloc, nd), ph(nloc, nd+1), tv(nloc, nd), tp(nloc, nd)
+  REAL tv_wake(nloc, nd)
+  REAL clw(nloc, nd)
+  REAL, DIMENSION(nloc, nd)    :: qta, qpreca                       !!jygprl
+  REAL dph(nloc, nd)
+  REAL pbase(nloc), buoybase(nloc), th(nloc, nd)
+  REAL th_wake(nloc, nd)
+  REAL tvp(nloc, nd)
+  REAL sig(nloc, nd), w0(nloc, nd), ptop2(nloc)
+  REAL hp(nloc, nd), ep(nloc, nd), sigp(nloc, nd)
+  REAL buoy(nloc, nd)
+  REAL cape(nloc)
+  REAL cin(nloc)
+  REAL m(nloc, nd)
+  REAL mm(nloc, nd)
+  REAL ment(nloc, nd, nd), sigij(nloc, nd, nd)
+  REAL qent(nloc, nd, nd)
+  REAL hent(nloc, nd, nd)
+  REAL uent(nloc, nd, nd), vent(nloc, nd, nd)
+  REAL ments(nloc, nd, nd), qents(nloc, nd, nd)
+  REAL elij(nloc, nd, nd)
+  REAL supmax(nloc, nd)
+  REAL Ale(nloc), Alp(nloc), coef_clos(nloc)
+  REAL omega(nloc,nd)
+  REAL sigd(nloc)
+! real mp(nloc,nd), qp(nloc,nd), up(nloc,nd), vp(nloc,nd)
+! real wt(nloc,nd), water(nloc,nd), evap(nloc,nd), ice(nloc,nd)
+! real b(nloc,nd), sigd(nloc)
+! save mp,qp,up,vp,wt,water,evap,b
+  REAL, DIMENSION(len,nd)     :: mp, qp, up, vp
+  REAL, DIMENSION(len,nd)     :: wt, water, evap
+  REAL, DIMENSION(len,nd)     :: ice, fondue, b
+  REAL, DIMENSION(len,nd)     :: frac_a, frac_s, faci               !!jygprl
+  REAL ft(nloc, nd), fq(nloc, nd), fqcomp(nloc, nd)
+  REAL ftd(nloc, nd), fqd(nloc, nd)
+  REAL fu(nloc, nd), fv(nloc, nd)
+  REAL upwd(nloc, nd), dnwd(nloc, nd), dnwd0(nloc, nd)
+  REAL ma(nloc, nd), mip(nloc, nd)
+!!  REAL tls(nloc, nd), tps(nloc, nd)                 ! unused . jyg
+  REAL qprime(nloc), tprime(nloc)
+  REAL precip(nloc)
+! real Vprecip(nloc,nd)
+  REAL vprecip(nloc, nd+1)
+  REAL vprecipi(nloc, nd+1)
+  REAL tra(nloc, nd, ntra), trap(nloc, nd, ntra)
+  REAL ftra(nloc, nd, ntra), traent(nloc, nd, nd, ntra)
+  REAL qcondc(nloc, nd)      ! cld
+  REAL wd(nloc)                ! gust
+  REAL Plim1(nloc), plim2(nloc)
+  REAL asupmax(nloc, nd)
+  REAL supmax0(nloc)
+  REAL asupmaxmin(nloc)
+
+  REAL tnk(nloc), qnk(nloc), gznk(nloc)
+  REAL wghti(nloc, nd)
+  REAL hnk(nloc), unk(nloc), vnk(nloc)
+
+  REAL qtc(nloc, nd)         ! cld
+  REAL sigt(nloc, nd)        ! cld
+  REAL detrain(nloc, nd)     ! cld
+ 
+! RomP >>>
+  REAL wdtrainA(nloc, nd), wdtrainS(nloc, nd), wdtrainM(nloc, nd)   !!jygprl
+  REAL da(len, nd), phi(len, nd, nd)
+  REAL epmlmMm(nloc, nd, nd), eplaMm(nloc, nd)
+  REAL phi2(len, nd, nd)
+  REAL d1a(len, nd), dam(len, nd)
+! RomP <<<
+  REAL epmax_diag(nloc) ! epmax_cape
+
+  CHARACTER (LEN=20) :: modname = 'cva_driver'
+  CHARACTER (LEN=80) :: abort_message
+
+  REAL, PARAMETER    :: Cin_noconv = -100000.
+  REAL, PARAMETER    :: Cape_noconv = -1.
+
+  INTEGER,SAVE                                       :: igout=1
+!$OMP THREADPRIVATE(igout)
+
+
+! print *, 't1, t1_wake ',(k,t1(1,k),t1_wake(1,k),k=1,nd)
+! print *, 'q1, q1_wake ',(k,q1(1,k),q1_wake(1,k),k=1,nd)
+
+! -------------------------------------------------------------------
+! --- SET CONSTANTS AND PARAMETERS
+! -------------------------------------------------------------------
+
+! -- set simulation flags:
+! (common cvflag)
+
+  CALL cv_flag(iflag_ice_thermo)
+
+! -- set thermodynamical constants:
+! (common cvthermo)
+
+  CALL cv_thermo(iflag_con)
+
+! -- set convect parameters
+
+! includes microphysical parameters and parameters that
+! control the rate of approach to quasi-equilibrium)
+! (common cvparam)
+
+  IF (iflag_con==3) THEN
+    CALL cv3_param(nd, k_upper, delt)
+
+  END IF
+
+  IF (iflag_con==4) THEN
+    CALL cv_param(nd)
+  END IF
+
+! ---------------------------------------------------------------------
+! --- INITIALIZE OUTPUT ARRAYS AND PARAMETERS
+! ---------------------------------------------------------------------
+  nword1 = len
+  nword2 = len*nd
+  nword3 = len*nd*ntra
+  nword4 = len*nd*nd
+
+  iflag1(:) = 0
+  ktop1(:) = 0
+  kbas1(:) = 0
+  ft1(:, :) = 0.0
+  fq1(:, :) = 0.0
+  fqcomp1(:, :) = 0.0
+  fu1(:, :) = 0.0
+  fv1(:, :) = 0.0
+  ftra1(:, :, :) = 0.
+  precip1(:) = 0.
+  cbmf1(:) = 0.
+  plcl1(:) = 0.
+  plfc1(:) = 0.
+  wbeff1(:) = 0.
+  ptop21(:) = 0.
+  sigd1(:) = 0.
+  ma1(:, :) = 0.
+  mip1(:, :) = 0.
+  vprecip1(:, :) = 0.
+  vprecipi1(:, :) = 0.
+  upwd1(:, :) = 0.
+  dnwd1(:, :) = 0.
+  dnwd01(:, :) = 0.
+  qcondc1(:, :) = 0.
+  wd1(:) = 0.
+  cape1(:) = 0.
+  cin1(:) = 0.
+  tvp1(:, :) = 0.
+  ftd1(:, :) = 0.
+  fqd1(:, :) = 0.
+  Plim11(:) = 0.
+  Plim21(:) = 0.
+  asupmax1(:, :) = 0.
+  supmax01(:) = 0.
+  asupmaxmin1(:) = 0.
+
+  tvp(:, :) = 0. !ym missing init, need to have a look by developpers
+  tv(:, :) = 0. !ym missing init, need to have a look by developpers
+
+  DO il = 1, len
+!!    cin1(il) = -100000.
+!!    cape1(il) = -1.
+    cin1(il) = Cin_noconv
+    cape1(il) = Cape_noconv
+  END DO
+
+!!  IF (iflag_con==3) THEN
+!!    DO il = 1, len
+!!      sig1(il, nd) = sig1(il, nd) + 1.
+!!      sig1(il, nd) = amin1(sig1(il,nd), 12.1)
+!!    END DO
+!!  END IF
+
+  IF (iflag_con==3) THEN
+      CALL cv3_incrcount(len,nd,delt,sig1)
+  END IF  ! (iflag_con==3)
+
+! RomP >>>
+  sigt1(:, :) = 0.
+  detrain1(:, :) = 0.
+  qtc1(:, :) = 0.
+  wdtrainA1(:, :) = 0.
+  wdtrainS1(:, :) = 0.
+  wdtrainM1(:, :) = 0.
+  da1(:, :) = 0.
+  phi1(:, :, :) = 0.
+  epmlmMm1(:, :, :) = 0.
+  eplaMm1(:, :) = 0.
+  mp1(:, :) = 0.
+  evap1(:, :) = 0.
+  ep1(:, :) = 0.
+  sigij1(:, :, :) = 0.
+  elij1(:, :, :) = 0.
+  qta1(:,:) = 0.
+  clw1(:,:) = 0.
+  wghti1(:,:) = 0.
+  phi21(:, :, :) = 0.
+  d1a1(:, :) = 0.
+  dam1(:, :) = 0.
+! RomP <<<
+! ---------------------------------------------------------------------
+! --- INITIALIZE LOCAL ARRAYS AND PARAMETERS
+! ---------------------------------------------------------------------
+
+  DO il = 1, nloc
+    coef_clos(il) = 1.
+  END DO
+
+! --------------------------------------------------------------------
+! --- CALCULATE ARRAYS OF GEOPOTENTIAL, HEAT CAPACITY & STATIC ENERGY
+! --------------------------------------------------------------------
+
+  IF (iflag_con==3) THEN
+
+    IF (debut) THEN
+      PRINT *, 'Emanuel version 3 nouvelle'
+    END IF
+! print*,'t1, q1 ',t1,q1
+        if (prt_level >= 9) &
+             PRINT *, 'cva_driver -> cv3_prelim'
+    CALL cv3_prelim(len, nd, ndp1, t1, q1, p1, ph1, &           ! nd->na
+                    lv1, lf1, cpn1, tv1, gz1, h1, hm1, th1)
+
+
+        if (prt_level >= 9) &
+             PRINT *, 'cva_driver -> cv3_prelim'
+    CALL cv3_prelim(len, nd, ndp1, t1_wake, q1_wake, p1, ph1, & ! nd->na
+                    lv1_wake, lf1_wake, cpn1_wake, tv1_wake, gz1_wake, &
+                    h1_wake, bid, th1_wake)
+
+  END IF
+
+  IF (iflag_con==4) THEN
+    PRINT *, 'Emanuel version 4 '
+        if (prt_level >= 9) &
+             PRINT *, 'cva_driver -> cv_prelim'
+    CALL cv_prelim(len, nd, ndp1, t1, q1, p1, ph1, &
+                   lv1, cpn1, tv1, gz1, h1, hm1)
+  END IF
+
+! --------------------------------------------------------------------
+! --- CONVECTIVE FEED
+! --------------------------------------------------------------------
+
+! compute feeding layer potential temperature and mixing ratio :
+
+! get bounds of feeding layer
+
+! test niveaux couche alimentation KE
+  IF (sig1feed1==sig2feed1) THEN
+    WRITE (lunout, *) 'impossible de choisir sig1feed=sig2feed'
+    WRITE (lunout, *) 'changer la valeur de sig2feed dans physiq.def'
+    abort_message = ''
+    CALL abort_physic(modname, abort_message, 1)
+  END IF
+
+  DO i = 1, len
+    p1feed1(i) = sig1feed1*ph1(i, 1)
+    p2feed1(i) = sig2feed1*ph1(i, 1)
+!test maf
+!   p1feed1(i)=ph1(i,1)
+!   p2feed1(i)=ph1(i,2)
+!   p2feed1(i)=ph1(i,3)
+!testCR: on prend la couche alim des thermiques
+!   p2feed1(i)=ph1(i,lalim_conv1(i)+1)
+!   print*,'lentr=',lentr(i),ph1(i,lentr(i)+1),ph1(i,2)
+  END DO
+
+  IF (iflag_con==3) THEN
+  END IF
+  DO i = 1, len
+! print*,'avant cv3_feed Plim',p1feed1(i),p2feed1(i)
+  END DO
+  IF (iflag_con==3) THEN
+
+! print*, 'IFLAG1 avant cv3_feed'
+! print*,'len,nd',len,nd
+! write(*,'(64i1)') iflag1(2:len-1)
+
+        if (prt_level >= 9) &
+             PRINT *, 'cva_driver -> cv3_feed'
+    CALL cv3_feed(len, nd, ok_conserv_q, &                 ! nd->na
+                  t1, q1, u1, v1, p1, ph1, h1, gz1, & 
+                  p1feed1, p2feed1, wght1, &
+                  wghti1, tnk1, thnk1, qnk1, qsnk1, unk1, vnk1, &
+                  cpnk1, hnk1, nk1, icb1, icbmax, iflag1, gznk1, plcl1)
+  END IF
+
+! print*, 'IFLAG1 apres cv3_feed'
+! print*,'len,nd',len,nd
+! write(*,'(64i1)') iflag1(2:len-1)
+
+  IF (iflag_con==4) THEN
+        if (prt_level >= 9) &
+             PRINT *, 'cva_driver -> cv_feed'
+    CALL cv_feed(len, nd, t1, q1, qs1, p1, hm1, gz1, &
+                 nk1, icb1, icbmax, iflag1, tnk1, qnk1, gznk1, plcl1)
+  END IF
+
+! print *, 'cv3_feed-> iflag1, plcl1 ',iflag1(1),plcl1(1)
+
+! --------------------------------------------------------------------
+! --- UNDILUTE (ADIABATIC) UPDRAFT / 1st part
+! (up through ICB for convect4, up through ICB+1 for convect3)
+! Calculates the lifted parcel virtual temperature at nk, the
+! actual temperature, and the adiabatic liquid water content.
+! --------------------------------------------------------------------
+
+  IF (iflag_con==3) THEN
+
+        if (prt_level >= 9) &
+             PRINT *, 'cva_driver -> cv3_undilute1'
+    CALL cv3_undilute1(len, nd, t1, qs1, gz1, plcl1, p1, icb1, tnk1, qnk1, & ! nd->na
+                       gznk1, tp1, tvp1, clw1, icbs1)
+  END IF
+
+
+  IF (iflag_con==4) THEN
+        if (prt_level >= 9) &
+             PRINT *, 'cva_driver -> cv_undilute1'
+    CALL cv_undilute1(len, nd, t1, q1, qs1, gz1, p1, nk1, icb1, icbmax, &
+                      tp1, tvp1, clw1)
+  END IF
+
+! -------------------------------------------------------------------
+! --- TRIGGERING
+! -------------------------------------------------------------------
+
+! print *,' avant triggering, iflag_con ',iflag_con
+
+  IF (iflag_con==3) THEN
+
+        if (prt_level >= 9) &
+             PRINT *, 'cva_driver -> cv3_trigger'
+    CALL cv3_trigger(len, nd, icb1, plcl1, p1, th1, tv1, tvp1, thnk1, & ! nd->na
+                      pbase1, buoybase1, iflag1, sig1, w01)
+
+
+! print*, 'IFLAG1 apres cv3_triger'
+! print*,'len,nd',len,nd
+! write(*,'(64i1)') iflag1(2:len-1)
+
+! call dump2d(iim,jjm-1,sig1(2)
+  END IF
+
+  IF (iflag_con==4) THEN
+        if (prt_level >= 9) &
+             PRINT *, 'cva_driver -> cv_trigger'
+    CALL cv_trigger(len, nd, icb1, cbmf1, tv1, tvp1, iflag1)
+  END IF
+
+
+! =====================================================================
+! --- IF THIS POINT IS REACHED, MOIST CONVECTIVE ADJUSTMENT IS NECESSARY
+! =====================================================================
+
+!  Determine the number "ncum" of convective gridpoints, the list "idcum" of convective
+!  gridpoints and the weights "coef_convective" (= 1. for convective gridpoints and = 0.
+!  elsewhere).
+  ncum = 0
+  coef_convective(:) = 0.
+  DO i = 1, len
+    IF (iflag1(i)==0) THEN
+      coef_convective(i) = 1.
+      ncum = ncum + 1
+      idcum(ncum) = i
+    END IF
+  END DO
+
+! print*,'len, ncum = ',len,ncum
+
+  IF (ncum>0) THEN
+
+! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+! --- COMPRESS THE FIELDS
+!       (-> vectorization over convective gridpoints)
+! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+
+    IF (iflag_con==3) THEN
+! print*,'ncum tv1 ',ncum,tv1
+! print*,'tvp1 ',tvp1
+!jyg<
+!   If the fraction of convective points is larger than comp_threshold, then compression
+!   is assumed useless.
+!
+  compress = ncum .lt. len*comp_threshold
+!
+  IF (.not. compress) THEN
+    DO i = 1,len
+      idcum(i) = i
+    ENDDO
+  ENDIF
+!
+!>jyg
+        if (prt_level >= 9) &
+             PRINT *, 'cva_driver -> cv3a_compress'
+      CALL cv3a_compress(len, nloc, ncum, nd, ntra, compress, &
+                         iflag1, nk1, icb1, icbs1, &
+                         plcl1, tnk1, qnk1, gznk1, hnk1, unk1, vnk1, &
+                         wghti1, pbase1, buoybase1, &
+                         t1, q1, qs1, t1_wake, q1_wake, qs1_wake, s1_wake, &
+                         u1, v1, gz1, th1, th1_wake, &
+                         tra1, &
+                         h1, lv1, lf1, cpn1, p1, ph1, tv1, tp1, tvp1, clw1, &
+                         h1_wake, lv1_wake, lf1_wake, cpn1_wake, tv1_wake, &
+                         sig1, w01, ptop21, &
+                         Ale1, Alp1, omega1, &
+                         iflag, nk, icb, icbs, &
+                         plcl, tnk, qnk, gznk, hnk, unk, vnk, &
+                         wghti, pbase, buoybase, &
+                         t, q, qs, t_wake, q_wake, qs_wake, s_wake, &
+                         u, v, gz, th, th_wake, &
+                         tra, &
+                         h, lv, lf, cpn, p, ph, tv, tp, tvp, clw, &
+                         h_wake, lv_wake, lf_wake, cpn_wake, tv_wake, &
+                         sig, w0, ptop2, &
+                         Ale, Alp, omega)
+
+! print*,'tv ',tv
+! print*,'tvp ',tvp
+
+    END IF
+
+    IF (iflag_con==4) THEN
+        if (prt_level >= 9) &
+             PRINT *, 'cva_driver -> cv_compress'
+      CALL cv_compress(len, nloc, ncum, nd, &
+                       iflag1, nk1, icb1, &
+                       cbmf1, plcl1, tnk1, qnk1, gznk1, &
+                       t1, q1, qs1, u1, v1, gz1, &
+                       h1, lv1, cpn1, p1, ph1, tv1, tp1, tvp1, clw1, &
+                       iflag, nk, icb, &
+                       cbmf, plcl, tnk, qnk, gznk, &
+                       t, q, qs, u, v, gz, h, lv, cpn, p, ph, tv, tp, tvp, clw, &
+                       dph)
+    END IF
+
+! -------------------------------------------------------------------
+! --- UNDILUTE (ADIABATIC) UPDRAFT / second part :
+! ---   FIND THE REST OF THE LIFTED PARCEL TEMPERATURES
+! ---   &
+! ---   COMPUTE THE PRECIPITATION EFFICIENCIES AND THE
+! ---   FRACTION OF PRECIPITATION FALLING OUTSIDE OF CLOUD
+! ---   &
+! ---   FIND THE LEVEL OF NEUTRAL BUOYANCY
+! -------------------------------------------------------------------
+
+    IF (iflag_con==3) THEN
+        if (prt_level >= 9) &
+             PRINT *, 'cva_driver -> cv3_undilute2'
+      CALL cv3_undilute2(nloc, ncum, nd, iflag, icb, icbs, nk, &        !na->nd
+                         tnk, qnk, gznk, hnk, t, q, qs, gz, &
+                         p, ph, h, tv, lv, lf, pbase, buoybase, plcl, &
+                         inb, tp, tvp, clw, hp, ep, sigp, buoy, &
+                         frac_a, frac_s, qpreca, qta)                        !!jygprl
+    END IF
+
+    IF (iflag_con==4) THEN
+        if (prt_level >= 9) &
+             PRINT *, 'cva_driver -> cv_undilute2'
+      CALL cv_undilute2(nloc, ncum, nd, icb, nk, &
+                        tnk, qnk, gznk, t, q, qs, gz, &
+                        p, dph, h, tv, lv, &
+                        inb, inbis, tp, tvp, clw, hp, ep, sigp, frac_s)
+    END IF
+
+    ! epmax_cape
+    ! on recalcule ep et hp    
+        if (prt_level >= 9) &
+             PRINT *, 'cva_driver -> cv3_epmax_cape'
+    call cv3_epmax_fn_cape(nloc,ncum,nd &
+                , ep,hp,icb,inb,clw,nk,t,h,hnk,lv,lf,frac_s &
+                , pbase, p, ph, tv, buoy, sig, w0,iflag &
+                , epmax_diag)
+
+! -------------------------------------------------------------------
+! --- MIXING(1)   (if iflag_mix .ge. 1)
+! -------------------------------------------------------------------
+    IF (iflag_con==3) THEN
+!      IF ((iflag_ice_thermo==1) .AND. (iflag_mix/=0)) THEN
+!        WRITE (*, *) ' iflag_ice_thermo==1 requires iflag_mix==0', ' but iflag_mix=', iflag_mix, &
+!          '. Might as well stop here.'
+!        STOP
+!      END IF
+      IF (iflag_mix>=1) THEN
+        CALL zilch(supmax, nloc*nd)
+        if (prt_level >= 9) &
+             PRINT *, 'cva_driver -> cv3p_mixing'
+        CALL cv3p_mixing(nloc, ncum, nd, nd, ntra, icb, nk, inb, &           ! na->nd
+!!                         ph, t, q, qs, u, v, tra, h, lv, lf, frac, qnk, &
+                         ph, t, q, qs, u, v, tra, h, lv, lf, frac_s, qta, &      !!jygprl
+                         unk, vnk, hp, tv, tvp, ep, clw, sig, &
+                         ment, qent, hent, uent, vent, nent, &
+                         sigij, elij, supmax, ments, qents, traent)
+! print*, 'cv3p_mixing-> supmax ', (supmax(1,k), k=1,nd)
+
+      ELSE
+        CALL zilch(supmax, nloc*nd)
+      END IF
+    END IF
+! -------------------------------------------------------------------
+! --- CLOSURE
+! -------------------------------------------------------------------
+
+
+    IF (iflag_con==3) THEN
+      IF (iflag_clos==0) THEN
+        if (prt_level >= 9) &
+             PRINT *, 'cva_driver -> cv3_closure'
+        CALL cv3_closure(nloc, ncum, nd, icb, inb, &           ! na->nd
+                         pbase, p, ph, tv, buoy, &
+                         sig, w0, cape, m, iflag)
+      END IF   ! iflag_clos==0
+
+      ok_inhib = iflag_mix == 2
+
+      IF (iflag_clos==1) THEN
+        PRINT *, ' pas d appel cv3p_closure'
+! c        CALL cv3p_closure(nloc,ncum,nd,icb,inb              ! na->nd
+! c    :                       ,pbase,plcl,p,ph,tv,tvp,buoy
+! c    :                       ,supmax
+! c    o                       ,sig,w0,ptop2,cape,cin,m)
+      END IF   ! iflag_clos==1
+
+      IF (iflag_clos==2) THEN
+        if (prt_level >= 9) &
+             PRINT *, 'cva_driver -> cv3p1_closure'
+        CALL cv3p1_closure(nloc, ncum, nd, icb, inb, &         ! na->nd
+                           pbase, plcl, p, ph, tv, tvp, buoy, &
+                           supmax, ok_inhib, Ale, Alp, omega, &
+                           sig, w0, ptop2, cape, cin, m, iflag, coef_clos, &
+                           Plim1, plim2, asupmax, supmax0, &
+                           asupmaxmin, cbmf, plfc, wbeff)
+        if (prt_level >= 10) &
+             PRINT *, 'cv3p1_closure-> plfc,wbeff ', plfc(1), wbeff(1)
+      END IF   ! iflag_clos==2
+
+      IF (iflag_clos==3) THEN
+        if (prt_level >= 9) &
+             PRINT *, 'cva_driver -> cv3p2_closure'
+        CALL cv3p2_closure(nloc, ncum, nd, icb, inb, &         ! na->nd
+                           pbase, plcl, p, ph, tv, tvp, buoy, &
+                           supmax, ok_inhib, Ale, Alp, omega, &
+                           sig, w0, ptop2, cape, cin, m, iflag, coef_clos, &
+                           Plim1, plim2, asupmax, supmax0, &
+                           asupmaxmin, cbmf, plfc, wbeff)
+        if (prt_level >= 10) &
+             PRINT *, 'cv3p2_closure-> plfc,wbeff ', plfc(1), wbeff(1)
+      END IF   ! iflag_clos==3
+    END IF ! iflag_con==3
+
+    IF (iflag_con==4) THEN
+        if (prt_level >= 9) &
+             PRINT *, 'cva_driver -> cv_closure'
+      CALL cv_closure(nloc, ncum, nd, nk, icb, &
+                         tv, tvp, p, ph, dph, plcl, cpn, &
+                         iflag, cbmf)
+    END IF
+
+! print *,'cv_closure-> cape ',cape(1)
+
+! -------------------------------------------------------------------
+! --- MIXING(2)
+! -------------------------------------------------------------------
+
+    IF (iflag_con==3) THEN
+      IF (iflag_mix==0) THEN
+        if (prt_level >= 9) &
+             PRINT *, 'cva_driver -> cv3_mixing'
+        CALL cv3_mixing(nloc, ncum, nd, nd, ntra, icb, nk, inb, &             ! na->nd
+                        ph, t, q, qs, u, v, tra, h, lv, lf, frac_s, qnk, &
+                        unk, vnk, hp, tv, tvp, ep, clw, m, sig, &
+                        ment, qent, uent, vent, nent, sigij, elij, ments, qents, traent)
+        CALL zilch(hent, nloc*nd*nd)
+      ELSE
+!!jyg:  Essais absurde pour voir
+!!        mm(:,1) = 0.
+!!        DO  i = 2,nd
+!!          mm(:,i) = m(:,i)*(1.-qta(:,i-1))
+!!        ENDDO
+        mm(:,:) = m(:,:)
+        CALL cv3_mixscale(nloc, ncum, nd, ment, mm)
+        IF (debut) THEN
+          PRINT *, ' cv3_mixscale-> '
+        END IF !(debut) THEN
+      END IF
+    END IF
+
+    IF (iflag_con==4) THEN
+        if (prt_level >= 9) &
+             PRINT *, 'cva_driver -> cv_mixing'
+      CALL cv_mixing(nloc, ncum, nd, icb, nk, inb, inbis, &
+                     ph, t, q, qs, u, v, h, lv, qnk, &
+                     hp, tv, tvp, ep, clw, cbmf, &
+                     m, ment, qent, uent, vent, nent, sigij, elij)
+    END IF                                                                                         
+
+    IF (debut) THEN
+      PRINT *, ' cv_mixing ->'
+    END IF !(debut) THEN
+! do i = 1,nd
+! print*,'cv_mixing-> i,ment ',i,(ment(1,i,j),j=1,nd)
+! enddo
+
+! -------------------------------------------------------------------
+! --- UNSATURATED (PRECIPITATING) DOWNDRAFTS
+! -------------------------------------------------------------------
+    IF (iflag_con==3) THEN
+      IF (debut) THEN
+        PRINT *, ' cva_driver -> cv3_unsat '
+      END IF !(debut) THEN
+
+        if (prt_level >= 9) &
+             PRINT *, 'cva_driver -> cv3_unsat'
+      CALL cv3_unsat(nloc, ncum, nd, nd, ntra, icb, inb, iflag, &              ! na->nd
+                     t_wake, q_wake, qs_wake, gz, u, v, tra, p, ph, &
+                     th_wake, tv_wake, lv_wake, lf_wake, cpn_wake, &
+                     ep, sigp, clw, frac_s, qpreca, frac_a, qta, &                    !!jygprl
+                     m, ment, elij, delt, plcl, coef_clos, &
+                     mp, qp, up, vp, trap, wt, water, evap, fondue, ice, &
+                     faci, b, sigd, &
+!!                     wdtrainA, wdtrainM)                                       ! RomP
+                     wdtrainA, wdtrainS, wdtrainM)                               !!jygprl
+!
+      IF (prt_level >= 10) THEN
+        Print *, 'cva_driver after cv3_unsat:mp , water, ice, evap, fondue '
+        DO k = 1,nd
+        write (6, '(i4,5(1x,e13.6))'), &
+          k, mp(igout,k), water(igout,k), ice(igout,k), &
+           evap(igout,k), fondue(igout,k)
+        ENDDO
+        Print *, 'cva_driver after cv3_unsat: wdtrainA, wdtrainS, wdtrainM '     !!jygprl
+        DO k = 1,nd
+        write (6, '(i4,3(1x,e13.6))'), &
+           k, wdtrainA(igout,k), wdtrainS(igout,k), wdtrainM(igout,k)            !!jygprl
+        ENDDO
+      ENDIF
+!
+    END IF  !(iflag_con==3)
+
+    IF (iflag_con==4) THEN
+        if (prt_level >= 9) &
+             PRINT *, 'cva_driver -> cv_unsat'
+      CALL cv_unsat(nloc, ncum, nd, inb, t, q, qs, gz, u, v, p, ph, &
+                     h, lv, ep, sigp, clw, m, ment, elij, &
+                     iflag, mp, qp, up, vp, wt, water, evap)
+    END IF
+
+    IF (debut) THEN
+      PRINT *, 'cv_unsat-> '
+    END IF !(debut) THEN
+
+! print *,'cv_unsat-> mp ',mp
+! print *,'cv_unsat-> water ',water
+! -------------------------------------------------------------------
+! --- YIELD
+! (tendencies, precipitation, variables of interface with other
+! processes, etc)
+! -------------------------------------------------------------------
+
+    IF (iflag_con==3) THEN
+
+        if (prt_level >= 9) &
+             PRINT *, 'cva_driver -> cv3_yield'
+      CALL cv3_yield(nloc, ncum, nd, nd, ntra, ok_conserv_q, &                      ! na->nd
+                     icb, inb, delt, &
+                     t, q, t_wake, q_wake, s_wake, u, v, tra, &
+                     gz, p, ph, h, hp, lv, lf, cpn, th, th_wake, &
+                     ep, clw, qpreca, m, tp, mp, qp, up, vp, trap, &
+                     wt, water, ice, evap, fondue, faci, b, sigd, &
+                     ment, qent, hent, iflag_mix, uent, vent, &
+                     nent, elij, traent, sig, &
+                     tv, tvp, wghti, &
+                     iflag, precip, Vprecip, Vprecipi, ft, fq, fqcomp, fu, fv, ftra, &      ! jyg
+                     cbmf, upwd, dnwd, dnwd0, ma, mip, &
+!!                     tls, tps, &                            ! useless . jyg
+                     qcondc, wd, &
+!!                     ftd, fqd, qnk, qtc, sigt, tau_cld_cv, coefw_cld_cv)
+                     ftd, fqd, qta, qtc, sigt, detrain, tau_cld_cv, coefw_cld_cv)         !!jygprl
+!
+!         Test conseravtion de l'eau
+!
+      IF (debut) THEN
+        PRINT *, ' cv3_yield -> fqd(1) = ', fqd(igout, 1)
+      END IF !(debut) THEN
+!   
+      IF (prt_level >= 10) THEN
+        Print *, 'cva_driver after cv3_yield:ft(1) , ftd(1) ', &
+                    ft(igout,1), ftd(igout,1)
+        Print *, 'cva_driver after cv3_yield:fq(1) , fqd(1) ', &
+                    fq(igout,1), fqd(igout,1)
+      ENDIF
+!   
+    END IF
+
+    IF (iflag_con==4) THEN
+        if (prt_level >= 9) &
+             PRINT *, 'cva_driver -> cv_yield'
+      CALL cv_yield(nloc, ncum, nd, nk, icb, inb, delt, &
+                     t, q, u, v, &
+                     gz, p, ph, h, hp, lv, cpn, &
+                     ep, clw, frac_s, m, mp, qp, up, vp, &
+                     wt, water, evap, &
+                     ment, qent, uent, vent, nent, elij, &
+                     tv, tvp, &
+                     iflag, wd, qprime, tprime, &
+                     precip, cbmf, ft, fq, fu, fv, ma, qcondc)
+    END IF
+
+!AC!
+!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+!--- passive tracers
+!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+
+    IF (iflag_con==3) THEN
+!RomP >>>
+        if (prt_level >= 9) &
+             PRINT *, 'cva_driver -> cv3_tracer'
+      CALL cv3_tracer(nloc, len, ncum, nd, nd, &
+                     ment, sigij, da, phi, phi2, d1a, dam, &
+                     ep, vprecip, elij, clw, epmlmMm, eplaMm, &
+                     icb, inb)
+!RomP <<<
+    END IF
+
+!AC!
+
+! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+! --- UNCOMPRESS THE FIELDS
+! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+
+
+    IF (iflag_con==3) THEN
+        if (prt_level >= 9) &
+             PRINT *, 'cva_driver -> cv3a_uncompress'
+      CALL cv3a_uncompress(nloc, len, ncum, nd, ntra, idcum, compress, &
+                           iflag, icb, inb, &
+                           precip, cbmf, plcl, plfc, wbeff, sig, w0, ptop2, &
+                           ft, fq, fqcomp, fu, fv, ftra, &
+                           sigd, ma, mip, vprecip, vprecipi, upwd, dnwd, dnwd0, &
+                           qcondc, wd, cape, cin, &
+                           tvp, &
+                           ftd, fqd, &
+                           Plim1, plim2, asupmax, supmax0, &
+                           asupmaxmin, &
+                           da, phi, mp, phi2, d1a, dam, sigij, &         ! RomP
+                           qta, clw, elij, evap, ep, epmlmMm, eplaMm, &  ! RomP
+                           wdtrainA, wdtrainS, wdtrainM, &                         ! RomP
+                           qtc, sigt, detrain, epmax_diag, & ! epmax_cape
+                           iflag1, kbas1, ktop1, &
+                           precip1, cbmf1, plcl1, plfc1, wbeff1, sig1, w01, ptop21, &
+                           ft1, fq1, fqcomp1, fu1, fv1, ftra1, &
+                           sigd1, ma1, mip1, vprecip1, vprecipi1, upwd1, dnwd1, dnwd01, &
+                           qcondc1, wd1, cape1, cin1, &
+                           tvp1, &
+                           ftd1, fqd1, &
+                           Plim11, plim21, asupmax1, supmax01, &
+                           asupmaxmin1, &
+                           da1, phi1, mp1, phi21, d1a1, dam1, sigij1,  &       ! RomP
+                           qta1, clw1, elij1, evap1, ep1, epmlmMm1, eplaMm1, & ! RomP
+                           wdtrainA1, wdtrainS1, wdtrainM1,                  & ! RomP
+                           qtc1, sigt1, detrain1, epmax_diag1) ! epmax_cape
+!   
+      IF (prt_level >= 10) THEN
+        Print *, 'cva_driver after cv3_uncompress:ft1(1) , ftd1(1) ', &
+                    ft1(igout,1), ftd1(igout,1)
+        Print *, 'cva_driver after cv3_uncompress:fq1(1) , fqd1(1) ', &
+                    fq1(igout,1), fqd1(igout,1)
+      ENDIF
+!   
+    END IF
+
+    IF (iflag_con==4) THEN
+        if (prt_level >= 9) &
+             PRINT *, 'cva_driver -> cv_uncompress'
+      CALL cv_uncompress(nloc, len, ncum, nd, idcum, &
+                           iflag, &
+                           precip, cbmf, &
+                           ft, fq, fu, fv, &
+                           ma, qcondc, &
+                           iflag1, &
+                           precip1,cbmf1, &
+                           ft1, fq1, fu1, fv1, &
+                           ma1, qcondc1)
+    END IF
+
+  END IF ! ncum>0
+!
+!
+  DO i = 1,len
+    IF (iflag1(i) == 14) THEN
+      Cin1(i) = Cin_noconv
+      Cape1(i) = Cape_noconv
+    ENDIF
+  ENDDO
+
+!
+! In order take into account the possibility of changing the compression,
+! reset m, sig and w0 to zero for non-convective points.
+  DO k = 1,nd-1
+        sig1(:, k) = sig1(:, k)*coef_convective(:)
+        w01(:, k)  = w01(:, k)*coef_convective(:)
+  ENDDO
+
+  IF (debut) THEN
+    PRINT *, ' cv_uncompress -> '
+    debut = .FALSE.
+  END IF  !(debut) THEN
+
+
+  RETURN
+END SUBROUTINE cva_driver
Index: DZ6/trunk/libf/phylmd/cvltr.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cvltr.F90	(revision 5267)
+++ 	(revision )
@@ -1,696 +1,0 @@
-!
-! $Id $
-!
-SUBROUTINE cvltr(pdtime, da, phi,phi2,d1a,dam, mpIN,epIN, &
-!!           sigd,sij,clw,elij,epmlmMm,eplaMm,              &   !RL
-           sigd,sij,wght_cvfd,clw,elij,epmlmMm,eplaMm,    &     !RL
-           pmflxrIN,pmflxsIN,ev,te,wdtrainA,wdtrainM,     &
-           paprs,it,tr,upd,dnd,inb,icb,                   &
-           dtrcv,trsptd,dtrSscav,dtrsat,dtrUscav,qDi,qPr, &
-           qPa,qMel,qTrdi,dtrcvMA,Mint,                   &
-           zmfd1a,zmfphi2,zmfdam)
-  USE IOIPSL 
-  USE dimphy
-  USE infotrac_phy, ONLY : nbtr
-  IMPLICIT NONE 
-!=====================================================================
-! Objet : convection des traceurs / KE
-! Auteurs: M-A Filiberti and J-Y Grandpeix
-! modifiee par R Pilon : lessivage des traceurs / KE
-!=====================================================================
-
-  include "YOMCST.h"
-  include "YOECUMF.h"
-  include "conema3.h"
-
-! Entree
-  REAL,INTENT(IN)                           :: pdtime
-  REAL,DIMENSION(klon,klev),INTENT(IN)      :: da
-  REAL,DIMENSION(klon,klev,klev),INTENT(IN) :: phi
-! RomP
-  REAL,DIMENSION(klon,klev),INTENT(IN)      :: d1a,dam ! matrices pour simplifier
-  REAL,DIMENSION(klon,klev,klev),INTENT(IN) :: phi2    ! l'ecriture des tendances
-!
-  REAL,DIMENSION(klon,klev),INTENT(IN)      :: mpIN
-  REAL,DIMENSION(klon,klev+1),INTENT(IN)    :: paprs  ! pression aux 1/2 couches (bas en haut)
-!  REAL,DIMENSION(klon,klev),INTENT(IN)    :: pplay ! pression aux 1/2 couches (bas en haut)
-  REAL,DIMENSION(klon,klev,nbtr),INTENT(IN) :: tr     ! q de traceur (bas en haut)
-  INTEGER,INTENT(IN)                        :: it 
-  REAL,DIMENSION(klon,klev),INTENT(IN)      :: upd   ! saturated updraft mass flux
-  REAL,DIMENSION(klon,klev),INTENT(IN)      :: dnd   ! saturated downdraft mass flux
-!
-  REAL,DIMENSION(klon,klev),INTENT(IN)      :: wdtrainA   ! masses precipitantes de l'asc adiab
-  REAL,DIMENSION(klon,klev),INTENT(IN)      :: wdtrainM   ! masses precipitantes des melanges
-  REAL,DIMENSION(klon,klev),INTENT(IN)      :: pmflxrIN   ! vprecip: eau
-  REAL,DIMENSION(klon,klev),INTENT(IN)      :: pmflxsIN   ! vprecip: neige
-  REAL,DIMENSION(klon,klev),INTENT(IN)      :: ev         ! evaporation cv30_routine
-  REAL,DIMENSION(klon,klev),INTENT(IN)      :: epIN
-  REAL,DIMENSION(klon,klev),INTENT(IN)      :: te 
-  REAL,DIMENSION(klon,klev,klev),INTENT(IN) :: sij        ! fraction dair de lenv
-  REAL,DIMENSION(klon,klev),INTENT(IN)      :: wght_cvfd  ! weights of the layers feeding convection
-  REAL,DIMENSION(klon,klev,klev),INTENT(IN) :: elij       ! contenu en eau condensée spécifique/conc deau condensée massique
-  REAL,DIMENSION(klon,klev,klev),INTENT(IN) :: epmlmMm    ! eau condensee precipitee dans mel masse dair sat
-  REAL,DIMENSION(klon,klev),INTENT(IN)      :: eplaMm    ! eau condensee precipitee dans aa masse dair sat
-
-  REAL,DIMENSION(klon,klev),INTENT(IN)      :: clw        ! contenu en eau condensée dans lasc adiab
-  REAL,DIMENSION(klon),INTENT(IN)           :: sigd
-  INTEGER,DIMENSION(klon),INTENT(IN)        :: icb,inb
-! Sortie
-  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)     :: dtrcv     ! tendance totale (bas en haut)
-  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)     :: dtrcvMA ! M-A Filiberti
-  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)     :: trsptd    ! tendance du transport 
-  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)     :: dtrSscav  ! tendance du lessivage courant sat
-  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)     :: dtrsat    ! tendance trsp+sat scav
-  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)     :: dtrUscav  ! tendance du lessivage courant unsat
-!
-! Variables locales
-  INTEGER                           :: i,j,k
-  REAL,DIMENSION(klon,klev)         :: dxpres   ! difference de pression entre niveau (j+1) et (j)
-  REAL                              :: pdtimeRG ! pas de temps * gravite
-! variables pour les courants satures
-  REAL,DIMENSION(klon,klev,klev)    :: zmd
-  REAL,DIMENSION(klon,klev,klev)    :: za
-  REAL,DIMENSION(klon,klev,nbtr)    :: zmfd,zmfa
-  REAL,DIMENSION(klon,klev,nbtr)    :: zmfp,zmfu
-  REAL,DIMENSION(klon,nbtr)         :: qfeed     ! tracer concentration feeding convection
-
-  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)    :: zmfd1a
-  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)    :: zmfdam
-  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)    :: zmfphi2
-
-! RomP ! les variables sont nettoyees des valeurs aberrantes
-  REAL,DIMENSION(klon,klev)         :: Pa, Pm  ! pluie AA et mélanges, var temporaire
-  REAL,DIMENSION(klon,klev)         :: pmflxs,pmflxr ! pmflxrIN,pmflxsIN sans valeur aberante
-  REAL,DIMENSION(klon,klev)         :: mp            ! flux de masse
-  REAL,DIMENSION(klon,klev)         :: ep            ! fraction d'eau convertie en precipitation 
-  REAL,DIMENSION(klon,klev)         :: evap          ! evaporation : variable temporaire 
-  REAL,DIMENSION(klon,klev)         :: rho    !environmental density
-
-  REAL,DIMENSION(klon,klev)         :: kappa ! denominateur du au calcul de la matrice 
-                                             ! pour obtenir qd et qp
-  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)    :: qTrdi ! traceurs descente air insature transport MA
-  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)    :: qDi  ! traceurs descente insaturees
-  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)    :: qPr  ! traceurs colonne precipitante
-  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)    :: qPa  ! traceurs dans les precip issues lasc. adiab.
-  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)    :: qMel ! traceurs dans les precip issues des melanges
-  REAL,DIMENSION(klon,klev,nbtr)                :: qMeltmp ! variable temporaire 
-  REAL,DIMENSION(klon,klev,nbtr)                :: qpmMint
-  REAL,DIMENSION(klon,klev),INTENT(OUT)         :: Mint
-! tendances
-  REAL                              :: tdcvMA           ! terme de transport de traceur (schema Marie Angele)
-  REAL                              :: trsptrac         ! terme de transport de traceur par l'air
-  REAL                              :: scavtrac         ! terme de lessivage courant sature
-  REAL                              :: uscavtrac        ! terme de lessivage courant insature
-! impaction
-!!!       Correction apres discussion Romain P. / Olivier B. 
-!!!  REAL,PARAMETER                    :: rdrop=2.5e-3     ! rayon des gouttes d'eau
-  REAL,PARAMETER                    :: rdrop=1.e-3     ! rayon des gouttes d'eau 
-!!!
-  REAL,DIMENSION(klon,klev)         :: imp              ! coefficient d'impaction
-! parametres lessivage
-  REAL                    :: ccntrAA_coef        ! \alpha_a : fract aerosols de l'AA convertis en CCN
-  REAL                    :: ccntrENV_coef       ! \beta_m  : fract aerosols de l'env convertis en CCN
-  REAL                    :: coefcoli            ! coefficient de collision des gouttes sur les aerosols
-!
-  LOGICAL,DIMENSION(klon,klev) :: NO_precip
-!  LOGICAL                      :: scavON
-! var tmp tests
-  REAL                           :: conserv
-  real                           :: conservMA
-
-! coefficient lessivage
-   ccntrAA_coef     = 0.
-   ccntrENV_coef    = 0.
-   coefcoli         = 0.
-
-!$OMP MASTER
-  call getin('ccntrAA_coef',ccntrAA_coef)
-  call getin('ccntrENV_coef',ccntrENV_coef)
-  call getin('coefcoli',coefcoli)
-!$OMP END MASTER
-!$OMP BARRIER
-  print*,'cvltr coef lessivage convectif', ccntrAA_coef,ccntrENV_coef,coefcoli
-
-!  scavON=.TRUE.
-!  if(scavON) then
-!   ccntrAA_coef     = 1.
-!   ccntrENV_coef    = 1.
-!   coefcoli         = 1.
-!  else
-!   ccntrAA_coef     = 0.
-!   ccntrENV_coef    = 0.
-!   coefcoli         = 0.
-!  endif
-
-! ======================================================
-! calcul de l'impaction
-! ======================================================
-!initialisation
-  do j=1,klev
-   do i=1,klon
-     imp(i,j)=0.
-   enddo
-  enddo
-! impaction sur la surface de la colonne de la descente insaturee
-! On prend la moyenne des precip entre le niveau i+1 et i
-! I=3/4* (P(1+1)+P(i))/2 / (sigd*r*rho_l)
-!  1000kg/m3= densité de l'eau
-! 0.75e-3 = 3/4 /1000
-! Par la suite, I est tout le temps multiplié par sig_d pour avoir l'impaction sur la surface de la maille
-! on le néglige ici pour simplifier le code
-  do j=1,klev-1
-   do i=1,klon
-    imp(i,j) = coefcoli*0.75e-3/rdrop *&
-             0.5*(pmflxr(i,j+1)+pmflxs(i,j+1)+pmflxr(i,j)+pmflxs(i,j))
-!    rho(i,j)=pplay(i,j)/(rd*te(i,j))
-   enddo
-  enddo
-!
-! initialisation pour flux de traceurs, td et autre
-   trsptrac = 0.
-   scavtrac = 0.
-   uscavtrac = 0.
-   qfeed(:,it) = 0.              !RL
-  DO j=1,klev
-   DO i=1,klon
-    zmfd(i,j,it)=0.
-    zmfa(i,j,it)=0.
-    zmfu(i,j,it)=0.
-    zmfp(i,j,it)=0.
-    zmfphi2(i,j,it)=0.
-    zmfd1a(i,j,it)=0.
-    zmfdam(i,j,it)=0.
-    qDi(i,j,it)=0.
-    qPr(i,j,it)=0.
-    qPa(i,j,it)=0.
-    qMel(i,j,it)=0.
-    qMeltmp(i,j,it)=0.
-    qTrdi(i,j,it)=0.
-    kappa(i,j)=0.
-    trsptd(i,j,it)=0.
-    dtrsat(i,j,it)=0.
-    dtrSscav(i,j,it)=0.
-    dtrUscav(i,j,it)=0.
-    dtrcv(i,j,it)=0.
-    dtrcvMA(i,j,it)=0.
-    evap(i,j)=0.
-    dxpres(i,j)=0.
-    qpmMint(i,j,it)=0.
-    Mint(i,j)=0.
-   END DO
-  END DO
-
-! suppression des valeurs très faibles (~1e-320)
-! multiplication de levaporation pour lavoir par unite de temps
-! et par unite de surface de la maille
-! -> cv30_unsat : evap : masse evaporee/s/(m2 de la descente)
-  DO j=1,klev
-   DO i=1,klon
-    if(ev(i,j).lt.1.e-16) then
-     evap(i,j)=0.
-    else
-     evap(i,j)=ev(i,j)*sigd(i)
-    endif
-   END DO
-  END DO
-
-  DO j=1,klev
-   DO i=1,klon
-   if(j.lt.klev) then
-    if(epIN(i,j).lt.1.e-32) then
-     ep(i,j)=0.
-    else
-     ep(i,j)=epIN(i,j)
-    endif
-   else
-    ep(i,j)=epmax
-   endif
-    if(mpIN(i,j).lt.1.e-32) then
-     mp(i,j)=0.
-    else
-     mp(i,j)=mpIN(i,j)
-    endif
-    if(pmflxsIN(i,j).lt.1.e-32) then
-     pmflxs(i,j)=0.
-    else
-     pmflxs(i,j)=pmflxsIN(i,j)
-    endif
-    if(pmflxrIN(i,j).lt.1.e-32) then
-     pmflxr(i,j)=0.
-    else
-     pmflxr(i,j)=pmflxrIN(i,j)
-    endif
-    if(wdtrainA(i,j).lt.1.e-32) then
-     Pa(i,j)=0.
-    else
-     Pa(i,j)=wdtrainA(i,j)
-    endif
-    if(wdtrainM(i,j).lt.1.e-32) then
-     Pm(i,j)=0.
-    else
-     Pm(i,j)=wdtrainM(i,j)
-    endif
-   END DO
-  END DO
-
-!==========================================
-  DO j = klev-1,1,-1
-   DO i = 1,klon
-     NO_precip(i,j) = (pmflxr(i,j+1)+pmflxs(i,j+1)).lt.1.e-10&
-                    .and.Pa(i,j).lt.1.e-10.and.Pm(i,j).lt.1.e-10
-   END DO
-  END DO
-
-! =========================================
-! calcul des tendances liees au downdraft
-! =========================================
-!cdir collapse
-  DO k=1,klev
-   DO j=1,klev
-    DO i=1,klon
-     zmd(i,j,k)=0.
-     za (i,j,k)=0.
-    END DO
-   END DO
-  END DO
-! calcul de la matrice d echange
-! matrice de distribution de la masse entrainee en k
-! commmentaire RomP : mp > 0
-  DO k=1,klev-1
-     DO i=1,klon
-        zmd(i,k,k)=max(0.,mp(i,k)-mp(i,k+1))   ! ~ mk(k)
-     END DO
-  END DO
-  DO k=2,klev
-     DO j=k-1,1,-1
-        DO i=1,klon
-           if(mp(i,j+1).gt.1.e-10) then
-              zmd(i,j,k)=zmd(i,j+1,k)*min(1.,mp(i,j)/mp(i,j+1)) !det ~ mk(j)=mk(j+1)*mp(i,j)/mp(i,j+1)
-           ENDif
-        END DO
-     END DO
-  END DO
-  DO k=1,klev
-     DO j=1,klev-1
-        DO i=1,klon
-           za(i,j,k)=max(0.,zmd(i,j+1,k)-zmd(i,j,k))
-        END DO
-     END DO
-  END DO
-!!!!! quantite  de traceur dans la descente d'air insaturee  :   4 juin 2012
-  DO k=1,klev
-     DO j=1,klev-1
-        DO i=1,klon
-        if(mp(i,j+1).gt.1.e-10) then
-          qTrdi(i,j+1,it)=qTrdi(i,j+1,it)+(zmd(i,j+1,k)/mp(i,j+1))*tr(i,k,it)
-        else
-          qTrdi(i,j,it)=0.!tr(i,j,it)
-        endif
-        ENDDO
-     ENDDO
-  ENDDO
-!!!!!
-!
-! rajout du terme lie a l ascendance induite
-!
-  DO j=2,klev
-     DO i=1,klon
-        za(i,j,j-1)=za(i,j,j-1)+mp(i,j)
-     END DO
-  END DO
-!
-! tendance courants insatures  ! sans lessivage ancien schema
-!
-  DO k=1,klev
-     DO j=1,klev
-        DO i=1,klon
-           zmfd(i,j,it)=zmfd(i,j,it)+za(i,j,k)*(tr(i,k,it)-tr(i,j,it))
-        END DO
-     END DO
-  END DO
-!
-! =========================================
-! calcul des tendances liees aux courants satures   j <-> z ; k <-> z'
-! =========================================
-!
-!RL
-!  Feeding concentrations
-  DO j=1,klev
-     DO i=1,klon
-        qfeed(i,it)=qfeed(i,it)+wght_cvfd(i,j)*tr(i,j,it)
-     END DO
-  END DO
-!RL
-!
-  DO j=1,klev
-     DO i=1,klon
-!RL
-!!        zmfa(i,j,it)=da(i,j)*(tr(i,1,it)-tr(i,j,it))                     ! da
-        zmfa(i,j,it)=da(i,j)*(qfeed(i,it)-tr(i,j,it))                     ! da
-!RL
-     END DO
-  END DO
-!
-  DO k=1,klev
-     DO j=1,klev
-        DO i=1,klon
-           zmfp(i,j,it)=zmfp(i,j,it)+phi(i,j,k)*(tr(i,k,it)-tr(i,j,it))  ! phi
-        END DO
-     END DO
-  END DO
-! RomP ajout des matrices liees au lessivage
-  DO j=1,klev
-     DO i=1,klon
-        zmfd1a(i,j,it)=d1a(i,j)*tr(i,1,it)   ! da1
-        zmfdam(i,j,it)=dam(i,j)*tr(i,1,it)   ! dam
-     END DO
-  END DO
-  DO k=1,klev
-     DO j=1,klev
-        DO i=1,klon
-          zmfphi2(i,j,it)=zmfphi2(i,j,it)+phi2(i,j,k)*tr(i,k,it)  ! psi
-        END DO
-     END DO
-  END DO
-  DO j=1,klev-1
-     DO i=1,klon
-        zmfu(i,j,it)=max(0.,upd(i,j+1)+dnd(i,j+1))*(tr(i,j+1,it)-tr(i,j,it))
-     END DO
-  END DO
-  DO j=2,klev
-     DO i=1,klon
-        zmfu(i,j,it)=zmfu(i,j,it)+min(0.,upd(i,j)+dnd(i,j))*(tr(i,j,it)-tr(i,j-1,it))
-     END DO
-  END DO
-! ===================================================
-! calcul des tendances liees aux courants insatures
-! ===================================================
-!  pression  
-  DO k=1, klev
-     DO i=1, klon
-        dxpres(i,k)=paprs(i,k)-paprs(i,k+1)
-     ENDDO
-  ENDDO
-  pdtimeRG=pdtime*RG
-
-! q_pa et q_pm    traceurs issues des courants satures se retrouvant dans les precipitations
-  DO j=1,klev
-     DO i=1,klon
-        if(j.ge.icb(i).and.j.le.inb(i)) then
-          if(clw(i,j).gt.1.e-16) then
-           qPa(i,j,it)=ccntrAA_coef*tr(i,1,it)/clw(i,j)
-          else
-           qPa(i,j,it)=0.
-          endif
-        endif
-     END DO
-  END DO
-
-! calcul de q_pm en 2 parties :
-! 1) calcul de sa valeur pour un niveau z' donne
-! 2) integration sur la verticale sur z'
-     DO j=1,klev
-      DO k=1,j-1
-        DO i=1,klon
-        if(k.ge.icb(i).and.k.le.inb(i).and.& 
-           j.le.inb(i)) then
-            if(elij(i,k,j).gt.1.e-16) then
-             qMeltmp(i,j,it)=((1-ep(i,k))*ccntrAA_coef*tr(i,1,it)&
-                         *(1.-sij(i,k,j))  +ccntrENV_coef&
-                         *tr(i,k,it)*sij(i,k,j)) / elij(i,k,j)
-            else
-             qMeltmp(i,j,it)=0.
-            endif
-          qpmMint(i,j,it)=qpmMint(i,j,it) + qMeltmp(i,j,it)*epmlmMm(i,j,k)
-          Mint(i,j)=Mint(i,j) + epmlmMm(i,j,k)
-        endif ! end if dans nuage
-        END DO
-     END DO
-  END DO
-
-     DO j=1,klev
-        DO i=1,klon
-          if(Mint(i,j).gt.1.e-16) then
-           qMel(i,j,it)=qpmMint(i,j,it)/Mint(i,j)
-          else
-           qMel(i,j,it)=0.
-          endif
-     END DO
-  END DO
-
-! calcul de q_d et q_p    traceurs de la descente precipitante 
-   DO j=klev-1,1,-1
-    DO i=1,klon
-     if(mp(i,j+1).gt.mp(i,j).and.mp(i,j+1).gt.1.e-10) then  ! detrainement
-       kappa(i,j)=((pmflxr(i,j+1)+pmflxs(i,j+1)+Pa(i,j)+Pm(i,j))*&
-                (-mp(i,j+1)-imp(i,j)/RG*dxpres(i,j))&
-                + (imp(i,j)/RG*dxpres(i,j))*(evap(i,j)/RG*dxpres(i,j)))
-             
-     elseif(mp(i,j).gt.mp(i,j+1).and.mp(i,j).gt.1.e-10) then! entrainement
-       if(j.eq.1) then
-        kappa(i,j)=((pmflxr(i,j+1)+pmflxs(i,j+1)+Pa(i,j)+Pm(i,j))*&
-                 (-mp(i,2)-imp(i,j)/RG*dxpres(i,j))&
-                 + (imp(i,j)/RG*dxpres(i,j))*(evap(i,j)/RG*dxpres(i,j)))
-       else
-        kappa(i,j)=((pmflxr(i,j+1)+pmflxs(i,j+1)+Pa(i,j)+Pm(i,j))*&
-                 (-mp(i,j)-imp(i,j)/RG*dxpres(i,j))&
-                 + (imp(i,j)/RG*dxpres(i,j))*(evap(i,j)/RG*dxpres(i,j)))
-       endif
-      else
-        kappa(i,j)=1.
-      endif
-    ENDDO
-   ENDDO
-
-  DO j=klev-1,1,-1
-   DO i=1,klon
-    if (abs(kappa(i,j)).lt.1.e-25) then    !si denominateur nul (il peut y avoir des mp!=0)
-     kappa(i,j)=1.
-     if(j.eq.1) then
-       qDi(i,j,it)=qDi(i,j+1,it) !orig tr(i,j,it)   ! mp(1)=0 donc tout vient de la couche supérieure
-     elseif(mp(i,j+1).gt.mp(i,j).and.mp(i,j+1).gt.1.e-10) then
-       qDi(i,j,it)=qDi(i,j+1,it)
-     elseif(mp(i,j).gt.mp(i,j+1).and.mp(i,j).gt.1.e-10) then! entrainement
-       qDi(i,j,it)=(-mp(i,j+1)*(qDi(i,j+1,it)-tr(i,j,it))-mp(i,j)*tr(i,j,it))/(-mp(i,j))
-     else  ! si  mp (i)=0 et mp(j+1)=0
-       qDi(i,j,it)=tr(i,j,it) ! orig 0.
-     endif 
-
-      if(NO_precip(i,j)) then
-       qPr(i,j,it)=0.
-      else
-       qPr(i,j,it)=((pmflxr(i,j+1)+pmflxs(i,j+1))*qPr(i,j+1,it)+&
-                   Pa(i,j)*qPa(i,j,it)+Pm(i,j)*qMel(i,j,it)&
-                   +imp(i,j)/RG*dxpres(i,j)*qDi(i,j,it))/&
-                  (pmflxr(i,j+1)+pmflxs(i,j+1)+Pa(i,j)+Pm(i,j))
-      endif
-    else   !     denominateur non nul
-     kappa(i,j)=1./kappa(i,j)     
-! calcul de qd et qp
-!!jyg  (20130119) correction pour le sommet du nuage
-!!     if(j.ge.inb(i)) then       !au-dessus du nuage, sommet inclu
-     if(j.gt.inb(i)) then       !au-dessus du nuage
-       qDi(i,j,it)=tr(i,j,it)   ! pas de descente => environnement = descente insaturee
-       qPr(i,j,it)=0.
-
-!  vvv premiere couche du modele ou mp(1)=0  ! det tout le temps  vvv
-     elseif(j.eq.1) then 
-      if(mp(i,2).gt.1.e-10) then !mp(2) non nul -> detrainement (car mp(1) = 0) !ent pas possible
-       if(NO_precip(i,j)) then !pas de precip en (i)
-        qDi(i,j,it)=qDi(i,j+1,it)
-        qPr(i,j,it)=0.
-       else
-        qDi(i,j,it)=kappa(i,j)*(&
-            (-evap(i,j)/RG*dxpres(i,j))*((pmflxr(i,j+1)+pmflxs(i,j+1))*qPr(i,j+1,it)+&
-            Pa(i,j)*qPa(i,j,it)+Pm(i,j)*qMel(i,j,it)) +&
-            (pmflxr(i,j+1)+pmflxs(i,j+1)+Pa(i,j)+Pm(i,j))*&
-            (-mp(i,j+1)*qDi(i,j+1,it)))
-
-        qPr(i,j,it)=kappa(i,j)*(&
-            (-mp(i,j+1)-imp(i,j)/RG*dxpres(i,j))*&
-            ((pmflxr(i,j+1)+pmflxs(i,j+1))*qPr(i,j+1,it)+&
-            Pa(i,j)*qPa(i,j,it)+Pm(i,j)*qMel(i,j,it))&
-            +(-mp(i,j+1)*qDi(i,j+1,it)) * (imp(i,j)/RG*dxpres(i,j)))
-       endif
-
-      else !mp(2) nul -> plus de descente insaturee -> pluie agit sur environnement
-        qDi(i,j,it)=tr(i,j,it) ! orig 0.
-        if(NO_precip(i,j)) then
-         qPr(i,j,it)=0.
-        else
-         qPr(i,j,it)=((pmflxr(i,j+1)+pmflxs(i,j+1))*qPr(i,j+1,it)+&
-                   Pa(i,j)*qPa(i,j,it)+Pm(i,j)*qMel(i,j,it)&
-                   +imp(i,j)/RG*dxpres(i,j)*tr(i,j,it))/&
-                  (pmflxr(i,j+1)+pmflxs(i,j+1)+Pa(i,j)+Pm(i,j))
-        endif
-
-      endif  !mp(2) nul ou non
-
-! vvv  (j!=1.and.j.lt.inb(i))  en-dessous du sommet nuage   vvv
-     else 
-!------------------------------------------------------------- detrainement 
-      if(mp(i,j+1).gt.mp(i,j).and.mp(i,j+1).gt.1.e-10) then !mp(i,j).gt.1.e-10) then
-         if(NO_precip(i,j)) then 
-          qDi(i,j,it)=qDi(i,j+1,it)
-          qPr(i,j,it)=0.
-         else
-          qDi(i,j,it)=kappa(i,j)*(&
-            (-evap(i,j)/RG*dxpres(i,j))*((pmflxr(i,j+1)+pmflxs(i,j+1))*qPr(i,j+1,it)+&
-            Pa(i,j)*qPa(i,j,it)+Pm(i,j)*qMel(i,j,it)) +&
-            (pmflxr(i,j+1)+pmflxs(i,j+1)+Pa(i,j)+Pm(i,j))*&
-            (-mp(i,j+1)*qDi(i,j+1,it)))
-!
-          qPr(i,j,it)=kappa(i,j)*(&
-            (-mp(i,j+1)-imp(i,j)/RG*dxpres(i,j))*&
-            ((pmflxr(i,j+1)+pmflxs(i,j+1))*qPr(i,j+1,it)+&
-            Pa(i,j)*qPa(i,j,it)+Pm(i,j)*qMel(i,j,it))&
-            +(-mp(i,j+1)*qDi(i,j+1,it)) * (imp(i,j)/RG*dxpres(i,j)))
-         endif !precip
-!------------------------------------------------------------- entrainement 
-      elseif(mp(i,j).gt.mp(i,j+1).and.mp(i,j).gt.1.e-10) then 
-         if(NO_precip(i,j)) then
-          qDi(i,j,it)=(-mp(i,j+1)*(qDi(i,j+1,it)-tr(i,j,it))-mp(i,j)*tr(i,j,it))/(-mp(i,j))
-          qPr(i,j,it)=0.
-         else
-          qDi(i,j,it)=kappa(i,j)*(&
-            (-evap(i,j)/RG*dxpres(i,j))*((pmflxr(i,j+1)+pmflxs(i,j+1))*qPr(i,j+1,it)+&
-            Pa(i,j)*qPa(i,j,it)+Pm(i,j)*qMel(i,j,it)) +&
-            (pmflxr(i,j+1)+pmflxs(i,j+1)+Pa(i,j)+Pm(i,j))*&
-            (-mp(i,j+1)*(qDi(i,j+1,it)-tr(i,j,it))-mp(i,j)*tr(i,j,it)))
-!
-          qPr(i,j,it)=kappa(i,j)*(&
-            (-mp(i,j)-imp(i,j)/RG*dxpres(i,j))*&
-            ((pmflxr(i,j+1)+pmflxs(i,j+1))*qPr(i,j+1,it)+&
-            Pa(i,j)*qPa(i,j,it)+Pm(i,j)*qMel(i,j,it))&
-            +(-mp(i,j+1)*(qDi(i,j+1,it)-tr(i,j,it))-mp(i,j)*tr(i,j,it))*&
-            (imp(i,j)/RG*dxpres(i,j)))
-         endif !precip
-!------------------------------------------------------------- endif ! ent/det
-      else  !mp nul
-        qDi(i,j,it)=tr(i,j,it) ! orig 0.
-        if(NO_precip(i,j)) then
-         qPr(i,j,it)=0.
-        else
-         qPr(i,j,it)=((pmflxr(i,j+1)+pmflxs(i,j+1))*qPr(i,j+1,it)+&
-                   Pa(i,j)*qPa(i,j,it)+Pm(i,j)*qMel(i,j,it)&
-                   +imp(i,j)/RG*dxpres(i,j)*tr(i,j,it))/&
-                  (pmflxr(i,j+1)+pmflxs(i,j+1)+Pa(i,j)+Pm(i,j))
-        endif
-      endif ! mp nul ou non
-     endif ! condition sur j
-    endif ! kappa
-   ENDDO
-  ENDDO
-
-!! print test descente insaturee
-!  DO j=klev,1,-1
-!   DO i=1,klon
-!     if(it.eq.3) then
-!   write(*,'(I2,2X,a,e20.12,2X,a,e20.12,2X,a,e20.12,2X,a,e20.12,2X,a,e20.12,2X,a,e20.12,2X,a,e20.12)') j,&
-!!         'zmfdam',zmfdam(i,j,it),'zmfpsi',zmfphi2(i,j,it),&
-!          'zmfdam+zmfpsi',zmfdam(i,j,it)+zmfphi2(i,j,it),'qpmMint',qpmMint(i,j,it),&
-!          'Pm',Pm(i,j),'Mint',Mint(i,j),&
-!!          'zmfa',zmfa(i,j,it),'zmfp',zmfp(i,j,it),&
-!        'zmfdam',zmfdam(i,j,it),'zmfpsi',zmfphi2(i,j,it),'zmfd1a',zmfd1a(i,j,it)
-!!          'Pa',Pa(i,j),'eplaMm',eplaMm(i,j)
-!!         'zmfd1a=da1*qa',zmfd1a(i,j,it),'Pa*qPa',wdtrainA(i,j)*qPa(i,j,it),'da1',d1a(i,j)
-!     endif
-!   ENDDO
-!  ENDDO
-
-
-! ===================================================
-! calcul final des tendances
-! ===================================================
-
-  DO k=klev-1,1,-1
-    DO i=1, klon
-! transport
-     tdcvMA=zmfd(i,k,it)+zmfu(i,k,it)+zmfa(i,k,it)+zmfp(i,k,it)   ! double comptage des downdraft insatures
-     trsptrac=zmfu(i,k,it)+zmfa(i,k,it)+zmfp(i,k,it)
-! lessivage courants satures
-     scavtrac=-ccntrAA_coef*zmfd1a(i,k,it)&
-               -zmfphi2(i,k,it)*ccntrENV_coef&
-               -zmfdam(i,k,it)*ccntrAA_coef
-! lessivage courants insatures
-   if(k.le.inb(i).and.k.gt.1) then   ! tendances dans le nuage
-!------------------------------------------------------------- detrainement
-      if(mp(i,k+1).gt.mp(i,k).and.mp(i,k+1).gt.1.e-10) then
-        uscavtrac= (-mp(i,k)+mp(i,k+1))*(qDi(i,k,it)-tr(i,k,it))&
-                   + mp(i,k)*(tr(i,k-1,it)-tr(i,k,it))
-!
-!        if(it.eq.3) write(*,'(I2,1X,a,5X,e20.12,82X,a,e20.12)')k,' det incloud',&
-!                    (-mp(i,k)+mp(i,k+1))*(qDi(i,k,it)-tr(i,k,it))*pdtimeRG/dxpres(i,k)+&
-!                    mp(i,k)*(tr(i,k-1,it)-tr(i,k,it))*pdtimeRG/dxpres(i,k),&
-!                    'mp',mp(i,k)
-!------------------------------------------------------------- entrainement 
-      elseif(mp(i,k).gt.mp(i,k+1).and.mp(i,k).gt.1.e-10) then
-         uscavtrac= mp(i,k)*(tr(i,k-1,it)-tr(i,k,it))
-!
-!         if(it.eq.3) write(*,'(I2,1X,a,5X,e20.12,82X,a,e20.12)')k,' ent incloud',uscavtrac*pdtimeRG/dxpres(i,k), 'mp',mp(i,k)
-!=!------------------------------------------------------------- end ent/det 
-      else !        mp(i,k+1)=0. et mp(i,k)=0.    pluie directement sur l environnement
-
-        if(NO_precip(i,k)) then
-          uscavtrac=0.
-!         if(it.eq.3) write(*,'(I2,1X,a,e20.12,82X,a,e20.12)')k,' no P ent incloud',uscavtrac*pdtimeRG/dxpres(i,k), 'mp',mp(i,k)
-        else
-          uscavtrac=-imp(i,k)*tr(i,k,it)*dxpres(i,k)/RG+evap(i,k)*qPr(i,k,it)*dxpres(i,k)/RG
-!         if(it.eq.3) write(*,'(I2,1X,a,3X,e20.12,82X,a,e20.12)')k,' P env incloud',uscavtrac*pdtimeRG/dxpres(i,k), 'mp',mp(i,k)
-        endif
-      endif  ! mp/det/ent
-!------------------------------------------------------------- premiere couche 
-   elseif(k.eq.1) then  !                                      mp(1)=0.
-      if(mp(i,2).gt.1.e-10) then  !detrainement
-         uscavtrac= (-0.+mp(i,2))*(qDi(i,k,it)-tr(i,k,it)) !&
-!                   + mp(i,2)*(0.-tr(i,k,it))
-!
-!       if(it.eq.3) write(*,'(I2,1X,a,e20.12,84X,a,e20.12)')k,' 1 det',&
-!                  (-0.+mp(i,2))*(qDi(i,k,it)-tr(i,k,it))*pdtimeRG/dxpres(i,k)+&
-!                  mp(i,2)*(0.-tr(i,k,it))*pdtimeRG/dxpres(i,k),&
-!                   'mp',mp(i,k)
-      else   ! mp(2) = 0 = mp(1) pas de descente insaturee, rien ne se passe s'il ne pleut pas, sinon pluie->env
-        if(NO_precip(i,1)) then
-          uscavtrac=0.
-        else
-          uscavtrac=-imp(i,k)*tr(i,k,it)*dxpres(i,k)/RG+evap(i,k)*qPr(i,k,it)*dxpres(i,k)/RG
-        endif
-!         if(it.eq.3) write(*,'(I2,1X,a,2X,e20.12,82X,a,e20.12)')k,'1 P env incloud',uscavtrac*pdtimeRG/dxpres(i,k), 'mp',mp(i,k)
-      endif
-
-   else   ! k > INB  au-dessus du nuage
-    uscavtrac=0.
-   endif
-
-! =====    tendances finales  ======
-     trsptd(i,k,it)=trsptrac*pdtimeRG/dxpres(i,k)              ! td transport sans eau dans courants satures
-     dtrSscav(i,k,it)=scavtrac*pdtimeRG/dxpres(i,k)            ! td du lessivage dans courants satures
-     dtrUscav(i,k,it)=uscavtrac*pdtimeRG/dxpres(i,k)           ! td courant insat
-     dtrsat(i,k,it)=(trsptrac+scavtrac)*pdtimeRG/dxpres(i,k)   ! td courant sat
-     dtrcv(i,k,it)=(trsptrac+scavtrac+uscavtrac)*pdtimeRG/dxpres(i,k)!dtrsat(i,k,it)+dtrUscav(i,k,it)         td conv
-!!!!!!
-     dtrcvMA(i,k,it)=tdcvMA*pdtimeRG/dxpres(i,k) ! MA tendance convection
-     ENDDO
-  ENDDO
-
-! test de conservation du traceur
-!print*,"_____________________________________________________________"
-!print*,"                                                             "
-!      conserv=0.
-!      conservMA=0.
-!      DO k= klev-1,1,-1
-!        DO i=1, klon
-!         conserv=conserv+dtrcv(i,k,it)*   &
-!        (paprs(i,k)-paprs(i,k+1))/RG
-!         conservMA=conservMA+dtrcvMA(i,k,it)*   &
-!        (paprs(i,k)-paprs(i,k+1))/RG
-!
-!      if(it.eq.3)  write(*,'(I2,2X,a,e20.12,2X,a,e20.12,2X,a,e20.12,2X,a,e20.12)') k,&
-!         'MA td ',dtrcvMA(i,k,it)*dxpres(i,k)/RG,&
-!         ' td',dtrcv(i,k,it)*dxpres(i,k)/RG,'         conservMA ',conservMA,'conserv ',conserv
-!!
-!        ENDDO
-!      ENDDO
-!       if(it.eq.3) print *,'it',it,'conserv ',conserv,'conservMA ',conservMA
-
-END SUBROUTINE cvltr
Index: /LMDZ6/trunk/libf/phylmd/cvltr.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cvltr.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/cvltr.f90	(revision 5268)
@@ -0,0 +1,696 @@
+!
+! $Id $
+!
+SUBROUTINE cvltr(pdtime, da, phi,phi2,d1a,dam, mpIN,epIN, &
+!!           sigd,sij,clw,elij,epmlmMm,eplaMm,              &   !RL
+           sigd,sij,wght_cvfd,clw,elij,epmlmMm,eplaMm,    &     !RL
+           pmflxrIN,pmflxsIN,ev,te,wdtrainA,wdtrainM,     &
+           paprs,it,tr,upd,dnd,inb,icb,                   &
+           dtrcv,trsptd,dtrSscav,dtrsat,dtrUscav,qDi,qPr, &
+           qPa,qMel,qTrdi,dtrcvMA,Mint,                   &
+           zmfd1a,zmfphi2,zmfdam)
+  USE IOIPSL 
+  USE dimphy
+  USE infotrac_phy, ONLY : nbtr
+  IMPLICIT NONE 
+!=====================================================================
+! Objet : convection des traceurs / KE
+! Auteurs: M-A Filiberti and J-Y Grandpeix
+! modifiee par R Pilon : lessivage des traceurs / KE
+!=====================================================================
+
+  include "YOMCST.h"
+  include "YOECUMF.h"
+  include "conema3.h"
+
+! Entree
+  REAL,INTENT(IN)                           :: pdtime
+  REAL,DIMENSION(klon,klev),INTENT(IN)      :: da
+  REAL,DIMENSION(klon,klev,klev),INTENT(IN) :: phi
+! RomP
+  REAL,DIMENSION(klon,klev),INTENT(IN)      :: d1a,dam ! matrices pour simplifier
+  REAL,DIMENSION(klon,klev,klev),INTENT(IN) :: phi2    ! l'ecriture des tendances
+!
+  REAL,DIMENSION(klon,klev),INTENT(IN)      :: mpIN
+  REAL,DIMENSION(klon,klev+1),INTENT(IN)    :: paprs  ! pression aux 1/2 couches (bas en haut)
+!  REAL,DIMENSION(klon,klev),INTENT(IN)    :: pplay ! pression aux 1/2 couches (bas en haut)
+  REAL,DIMENSION(klon,klev,nbtr),INTENT(IN) :: tr     ! q de traceur (bas en haut)
+  INTEGER,INTENT(IN)                        :: it 
+  REAL,DIMENSION(klon,klev),INTENT(IN)      :: upd   ! saturated updraft mass flux
+  REAL,DIMENSION(klon,klev),INTENT(IN)      :: dnd   ! saturated downdraft mass flux
+!
+  REAL,DIMENSION(klon,klev),INTENT(IN)      :: wdtrainA   ! masses precipitantes de l'asc adiab
+  REAL,DIMENSION(klon,klev),INTENT(IN)      :: wdtrainM   ! masses precipitantes des melanges
+  REAL,DIMENSION(klon,klev),INTENT(IN)      :: pmflxrIN   ! vprecip: eau
+  REAL,DIMENSION(klon,klev),INTENT(IN)      :: pmflxsIN   ! vprecip: neige
+  REAL,DIMENSION(klon,klev),INTENT(IN)      :: ev         ! evaporation cv30_routine
+  REAL,DIMENSION(klon,klev),INTENT(IN)      :: epIN
+  REAL,DIMENSION(klon,klev),INTENT(IN)      :: te 
+  REAL,DIMENSION(klon,klev,klev),INTENT(IN) :: sij        ! fraction dair de lenv
+  REAL,DIMENSION(klon,klev),INTENT(IN)      :: wght_cvfd  ! weights of the layers feeding convection
+  REAL,DIMENSION(klon,klev,klev),INTENT(IN) :: elij       ! contenu en eau condensée spécifique/conc deau condensée massique
+  REAL,DIMENSION(klon,klev,klev),INTENT(IN) :: epmlmMm    ! eau condensee precipitee dans mel masse dair sat
+  REAL,DIMENSION(klon,klev),INTENT(IN)      :: eplaMm    ! eau condensee precipitee dans aa masse dair sat
+
+  REAL,DIMENSION(klon,klev),INTENT(IN)      :: clw        ! contenu en eau condensée dans lasc adiab
+  REAL,DIMENSION(klon),INTENT(IN)           :: sigd
+  INTEGER,DIMENSION(klon),INTENT(IN)        :: icb,inb
+! Sortie
+  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)     :: dtrcv     ! tendance totale (bas en haut)
+  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)     :: dtrcvMA ! M-A Filiberti
+  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)     :: trsptd    ! tendance du transport 
+  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)     :: dtrSscav  ! tendance du lessivage courant sat
+  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)     :: dtrsat    ! tendance trsp+sat scav
+  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)     :: dtrUscav  ! tendance du lessivage courant unsat
+!
+! Variables locales
+  INTEGER                           :: i,j,k
+  REAL,DIMENSION(klon,klev)         :: dxpres   ! difference de pression entre niveau (j+1) et (j)
+  REAL                              :: pdtimeRG ! pas de temps * gravite
+! variables pour les courants satures
+  REAL,DIMENSION(klon,klev,klev)    :: zmd
+  REAL,DIMENSION(klon,klev,klev)    :: za
+  REAL,DIMENSION(klon,klev,nbtr)    :: zmfd,zmfa
+  REAL,DIMENSION(klon,klev,nbtr)    :: zmfp,zmfu
+  REAL,DIMENSION(klon,nbtr)         :: qfeed     ! tracer concentration feeding convection
+
+  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)    :: zmfd1a
+  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)    :: zmfdam
+  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)    :: zmfphi2
+
+! RomP ! les variables sont nettoyees des valeurs aberrantes
+  REAL,DIMENSION(klon,klev)         :: Pa, Pm  ! pluie AA et mélanges, var temporaire
+  REAL,DIMENSION(klon,klev)         :: pmflxs,pmflxr ! pmflxrIN,pmflxsIN sans valeur aberante
+  REAL,DIMENSION(klon,klev)         :: mp            ! flux de masse
+  REAL,DIMENSION(klon,klev)         :: ep            ! fraction d'eau convertie en precipitation 
+  REAL,DIMENSION(klon,klev)         :: evap          ! evaporation : variable temporaire 
+  REAL,DIMENSION(klon,klev)         :: rho    !environmental density
+
+  REAL,DIMENSION(klon,klev)         :: kappa ! denominateur du au calcul de la matrice 
+                                             ! pour obtenir qd et qp
+  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)    :: qTrdi ! traceurs descente air insature transport MA
+  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)    :: qDi  ! traceurs descente insaturees
+  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)    :: qPr  ! traceurs colonne precipitante
+  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)    :: qPa  ! traceurs dans les precip issues lasc. adiab.
+  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)    :: qMel ! traceurs dans les precip issues des melanges
+  REAL,DIMENSION(klon,klev,nbtr)                :: qMeltmp ! variable temporaire 
+  REAL,DIMENSION(klon,klev,nbtr)                :: qpmMint
+  REAL,DIMENSION(klon,klev),INTENT(OUT)         :: Mint
+! tendances
+  REAL                              :: tdcvMA           ! terme de transport de traceur (schema Marie Angele)
+  REAL                              :: trsptrac         ! terme de transport de traceur par l'air
+  REAL                              :: scavtrac         ! terme de lessivage courant sature
+  REAL                              :: uscavtrac        ! terme de lessivage courant insature
+! impaction
+!!!       Correction apres discussion Romain P. / Olivier B. 
+!!!  REAL,PARAMETER                    :: rdrop=2.5e-3     ! rayon des gouttes d'eau
+  REAL,PARAMETER                    :: rdrop=1.e-3     ! rayon des gouttes d'eau 
+!!!
+  REAL,DIMENSION(klon,klev)         :: imp              ! coefficient d'impaction
+! parametres lessivage
+  REAL                    :: ccntrAA_coef        ! \alpha_a : fract aerosols de l'AA convertis en CCN
+  REAL                    :: ccntrENV_coef       ! \beta_m  : fract aerosols de l'env convertis en CCN
+  REAL                    :: coefcoli            ! coefficient de collision des gouttes sur les aerosols
+!
+  LOGICAL,DIMENSION(klon,klev) :: NO_precip
+!  LOGICAL                      :: scavON
+! var tmp tests
+  REAL                           :: conserv
+  real                           :: conservMA
+
+! coefficient lessivage
+   ccntrAA_coef     = 0.
+   ccntrENV_coef    = 0.
+   coefcoli         = 0.
+
+!$OMP MASTER
+  call getin('ccntrAA_coef',ccntrAA_coef)
+  call getin('ccntrENV_coef',ccntrENV_coef)
+  call getin('coefcoli',coefcoli)
+!$OMP END MASTER
+!$OMP BARRIER
+  print*,'cvltr coef lessivage convectif', ccntrAA_coef,ccntrENV_coef,coefcoli
+
+!  scavON=.TRUE.
+!  if(scavON) then
+!   ccntrAA_coef     = 1.
+!   ccntrENV_coef    = 1.
+!   coefcoli         = 1.
+!  else
+!   ccntrAA_coef     = 0.
+!   ccntrENV_coef    = 0.
+!   coefcoli         = 0.
+!  endif
+
+! ======================================================
+! calcul de l'impaction
+! ======================================================
+!initialisation
+  do j=1,klev
+   do i=1,klon
+     imp(i,j)=0.
+   enddo
+  enddo
+! impaction sur la surface de la colonne de la descente insaturee
+! On prend la moyenne des precip entre le niveau i+1 et i
+! I=3/4* (P(1+1)+P(i))/2 / (sigd*r*rho_l)
+!  1000kg/m3= densité de l'eau
+! 0.75e-3 = 3/4 /1000
+! Par la suite, I est tout le temps multiplié par sig_d pour avoir l'impaction sur la surface de la maille
+! on le néglige ici pour simplifier le code
+  do j=1,klev-1
+   do i=1,klon
+    imp(i,j) = coefcoli*0.75e-3/rdrop *&
+             0.5*(pmflxr(i,j+1)+pmflxs(i,j+1)+pmflxr(i,j)+pmflxs(i,j))
+!    rho(i,j)=pplay(i,j)/(rd*te(i,j))
+   enddo
+  enddo
+!
+! initialisation pour flux de traceurs, td et autre
+   trsptrac = 0.
+   scavtrac = 0.
+   uscavtrac = 0.
+   qfeed(:,it) = 0.              !RL
+  DO j=1,klev
+   DO i=1,klon
+    zmfd(i,j,it)=0.
+    zmfa(i,j,it)=0.
+    zmfu(i,j,it)=0.
+    zmfp(i,j,it)=0.
+    zmfphi2(i,j,it)=0.
+    zmfd1a(i,j,it)=0.
+    zmfdam(i,j,it)=0.
+    qDi(i,j,it)=0.
+    qPr(i,j,it)=0.
+    qPa(i,j,it)=0.
+    qMel(i,j,it)=0.
+    qMeltmp(i,j,it)=0.
+    qTrdi(i,j,it)=0.
+    kappa(i,j)=0.
+    trsptd(i,j,it)=0.
+    dtrsat(i,j,it)=0.
+    dtrSscav(i,j,it)=0.
+    dtrUscav(i,j,it)=0.
+    dtrcv(i,j,it)=0.
+    dtrcvMA(i,j,it)=0.
+    evap(i,j)=0.
+    dxpres(i,j)=0.
+    qpmMint(i,j,it)=0.
+    Mint(i,j)=0.
+   END DO
+  END DO
+
+! suppression des valeurs très faibles (~1e-320)
+! multiplication de levaporation pour lavoir par unite de temps
+! et par unite de surface de la maille
+! -> cv30_unsat : evap : masse evaporee/s/(m2 de la descente)
+  DO j=1,klev
+   DO i=1,klon
+    if(ev(i,j).lt.1.e-16) then
+     evap(i,j)=0.
+    else
+     evap(i,j)=ev(i,j)*sigd(i)
+    endif
+   END DO
+  END DO
+
+  DO j=1,klev
+   DO i=1,klon
+   if(j.lt.klev) then
+    if(epIN(i,j).lt.1.e-32) then
+     ep(i,j)=0.
+    else
+     ep(i,j)=epIN(i,j)
+    endif
+   else
+    ep(i,j)=epmax
+   endif
+    if(mpIN(i,j).lt.1.e-32) then
+     mp(i,j)=0.
+    else
+     mp(i,j)=mpIN(i,j)
+    endif
+    if(pmflxsIN(i,j).lt.1.e-32) then
+     pmflxs(i,j)=0.
+    else
+     pmflxs(i,j)=pmflxsIN(i,j)
+    endif
+    if(pmflxrIN(i,j).lt.1.e-32) then
+     pmflxr(i,j)=0.
+    else
+     pmflxr(i,j)=pmflxrIN(i,j)
+    endif
+    if(wdtrainA(i,j).lt.1.e-32) then
+     Pa(i,j)=0.
+    else
+     Pa(i,j)=wdtrainA(i,j)
+    endif
+    if(wdtrainM(i,j).lt.1.e-32) then
+     Pm(i,j)=0.
+    else
+     Pm(i,j)=wdtrainM(i,j)
+    endif
+   END DO
+  END DO
+
+!==========================================
+  DO j = klev-1,1,-1
+   DO i = 1,klon
+     NO_precip(i,j) = (pmflxr(i,j+1)+pmflxs(i,j+1)).lt.1.e-10&
+                    .and.Pa(i,j).lt.1.e-10.and.Pm(i,j).lt.1.e-10
+   END DO
+  END DO
+
+! =========================================
+! calcul des tendances liees au downdraft
+! =========================================
+!cdir collapse
+  DO k=1,klev
+   DO j=1,klev
+    DO i=1,klon
+     zmd(i,j,k)=0.
+     za (i,j,k)=0.
+    END DO
+   END DO
+  END DO
+! calcul de la matrice d echange
+! matrice de distribution de la masse entrainee en k
+! commmentaire RomP : mp > 0
+  DO k=1,klev-1
+     DO i=1,klon
+        zmd(i,k,k)=max(0.,mp(i,k)-mp(i,k+1))   ! ~ mk(k)
+     END DO
+  END DO
+  DO k=2,klev
+     DO j=k-1,1,-1
+        DO i=1,klon
+           if(mp(i,j+1).gt.1.e-10) then
+              zmd(i,j,k)=zmd(i,j+1,k)*min(1.,mp(i,j)/mp(i,j+1)) !det ~ mk(j)=mk(j+1)*mp(i,j)/mp(i,j+1)
+           ENDif
+        END DO
+     END DO
+  END DO
+  DO k=1,klev
+     DO j=1,klev-1
+        DO i=1,klon
+           za(i,j,k)=max(0.,zmd(i,j+1,k)-zmd(i,j,k))
+        END DO
+     END DO
+  END DO
+!!!!! quantite  de traceur dans la descente d'air insaturee  :   4 juin 2012
+  DO k=1,klev
+     DO j=1,klev-1
+        DO i=1,klon
+        if(mp(i,j+1).gt.1.e-10) then
+          qTrdi(i,j+1,it)=qTrdi(i,j+1,it)+(zmd(i,j+1,k)/mp(i,j+1))*tr(i,k,it)
+        else
+          qTrdi(i,j,it)=0.!tr(i,j,it)
+        endif
+        ENDDO
+     ENDDO
+  ENDDO
+!!!!!
+!
+! rajout du terme lie a l ascendance induite
+!
+  DO j=2,klev
+     DO i=1,klon
+        za(i,j,j-1)=za(i,j,j-1)+mp(i,j)
+     END DO
+  END DO
+!
+! tendance courants insatures  ! sans lessivage ancien schema
+!
+  DO k=1,klev
+     DO j=1,klev
+        DO i=1,klon
+           zmfd(i,j,it)=zmfd(i,j,it)+za(i,j,k)*(tr(i,k,it)-tr(i,j,it))
+        END DO
+     END DO
+  END DO
+!
+! =========================================
+! calcul des tendances liees aux courants satures   j <-> z ; k <-> z'
+! =========================================
+!
+!RL
+!  Feeding concentrations
+  DO j=1,klev
+     DO i=1,klon
+        qfeed(i,it)=qfeed(i,it)+wght_cvfd(i,j)*tr(i,j,it)
+     END DO
+  END DO
+!RL
+!
+  DO j=1,klev
+     DO i=1,klon
+!RL
+!!        zmfa(i,j,it)=da(i,j)*(tr(i,1,it)-tr(i,j,it))                     ! da
+        zmfa(i,j,it)=da(i,j)*(qfeed(i,it)-tr(i,j,it))                     ! da
+!RL
+     END DO
+  END DO
+!
+  DO k=1,klev
+     DO j=1,klev
+        DO i=1,klon
+           zmfp(i,j,it)=zmfp(i,j,it)+phi(i,j,k)*(tr(i,k,it)-tr(i,j,it))  ! phi
+        END DO
+     END DO
+  END DO
+! RomP ajout des matrices liees au lessivage
+  DO j=1,klev
+     DO i=1,klon
+        zmfd1a(i,j,it)=d1a(i,j)*tr(i,1,it)   ! da1
+        zmfdam(i,j,it)=dam(i,j)*tr(i,1,it)   ! dam
+     END DO
+  END DO
+  DO k=1,klev
+     DO j=1,klev
+        DO i=1,klon
+          zmfphi2(i,j,it)=zmfphi2(i,j,it)+phi2(i,j,k)*tr(i,k,it)  ! psi
+        END DO
+     END DO
+  END DO
+  DO j=1,klev-1
+     DO i=1,klon
+        zmfu(i,j,it)=max(0.,upd(i,j+1)+dnd(i,j+1))*(tr(i,j+1,it)-tr(i,j,it))
+     END DO
+  END DO
+  DO j=2,klev
+     DO i=1,klon
+        zmfu(i,j,it)=zmfu(i,j,it)+min(0.,upd(i,j)+dnd(i,j))*(tr(i,j,it)-tr(i,j-1,it))
+     END DO
+  END DO
+! ===================================================
+! calcul des tendances liees aux courants insatures
+! ===================================================
+!  pression  
+  DO k=1, klev
+     DO i=1, klon
+        dxpres(i,k)=paprs(i,k)-paprs(i,k+1)
+     ENDDO
+  ENDDO
+  pdtimeRG=pdtime*RG
+
+! q_pa et q_pm    traceurs issues des courants satures se retrouvant dans les precipitations
+  DO j=1,klev
+     DO i=1,klon
+        if(j.ge.icb(i).and.j.le.inb(i)) then
+          if(clw(i,j).gt.1.e-16) then
+           qPa(i,j,it)=ccntrAA_coef*tr(i,1,it)/clw(i,j)
+          else
+           qPa(i,j,it)=0.
+          endif
+        endif
+     END DO
+  END DO
+
+! calcul de q_pm en 2 parties :
+! 1) calcul de sa valeur pour un niveau z' donne
+! 2) integration sur la verticale sur z'
+     DO j=1,klev
+      DO k=1,j-1
+        DO i=1,klon
+        if(k.ge.icb(i).and.k.le.inb(i).and.& 
+           j.le.inb(i)) then
+            if(elij(i,k,j).gt.1.e-16) then
+             qMeltmp(i,j,it)=((1-ep(i,k))*ccntrAA_coef*tr(i,1,it)&
+                         *(1.-sij(i,k,j))  +ccntrENV_coef&
+                         *tr(i,k,it)*sij(i,k,j)) / elij(i,k,j)
+            else
+             qMeltmp(i,j,it)=0.
+            endif
+          qpmMint(i,j,it)=qpmMint(i,j,it) + qMeltmp(i,j,it)*epmlmMm(i,j,k)
+          Mint(i,j)=Mint(i,j) + epmlmMm(i,j,k)
+        endif ! end if dans nuage
+        END DO
+     END DO
+  END DO
+
+     DO j=1,klev
+        DO i=1,klon
+          if(Mint(i,j).gt.1.e-16) then
+           qMel(i,j,it)=qpmMint(i,j,it)/Mint(i,j)
+          else
+           qMel(i,j,it)=0.
+          endif
+     END DO
+  END DO
+
+! calcul de q_d et q_p    traceurs de la descente precipitante 
+   DO j=klev-1,1,-1
+    DO i=1,klon
+     if(mp(i,j+1).gt.mp(i,j).and.mp(i,j+1).gt.1.e-10) then  ! detrainement
+       kappa(i,j)=((pmflxr(i,j+1)+pmflxs(i,j+1)+Pa(i,j)+Pm(i,j))*&
+                (-mp(i,j+1)-imp(i,j)/RG*dxpres(i,j))&
+                + (imp(i,j)/RG*dxpres(i,j))*(evap(i,j)/RG*dxpres(i,j)))
+             
+     elseif(mp(i,j).gt.mp(i,j+1).and.mp(i,j).gt.1.e-10) then! entrainement
+       if(j.eq.1) then
+        kappa(i,j)=((pmflxr(i,j+1)+pmflxs(i,j+1)+Pa(i,j)+Pm(i,j))*&
+                 (-mp(i,2)-imp(i,j)/RG*dxpres(i,j))&
+                 + (imp(i,j)/RG*dxpres(i,j))*(evap(i,j)/RG*dxpres(i,j)))
+       else
+        kappa(i,j)=((pmflxr(i,j+1)+pmflxs(i,j+1)+Pa(i,j)+Pm(i,j))*&
+                 (-mp(i,j)-imp(i,j)/RG*dxpres(i,j))&
+                 + (imp(i,j)/RG*dxpres(i,j))*(evap(i,j)/RG*dxpres(i,j)))
+       endif
+      else
+        kappa(i,j)=1.
+      endif
+    ENDDO
+   ENDDO
+
+  DO j=klev-1,1,-1
+   DO i=1,klon
+    if (abs(kappa(i,j)).lt.1.e-25) then    !si denominateur nul (il peut y avoir des mp!=0)
+     kappa(i,j)=1.
+     if(j.eq.1) then
+       qDi(i,j,it)=qDi(i,j+1,it) !orig tr(i,j,it)   ! mp(1)=0 donc tout vient de la couche supérieure
+     elseif(mp(i,j+1).gt.mp(i,j).and.mp(i,j+1).gt.1.e-10) then
+       qDi(i,j,it)=qDi(i,j+1,it)
+     elseif(mp(i,j).gt.mp(i,j+1).and.mp(i,j).gt.1.e-10) then! entrainement
+       qDi(i,j,it)=(-mp(i,j+1)*(qDi(i,j+1,it)-tr(i,j,it))-mp(i,j)*tr(i,j,it))/(-mp(i,j))
+     else  ! si  mp (i)=0 et mp(j+1)=0
+       qDi(i,j,it)=tr(i,j,it) ! orig 0.
+     endif 
+
+      if(NO_precip(i,j)) then
+       qPr(i,j,it)=0.
+      else
+       qPr(i,j,it)=((pmflxr(i,j+1)+pmflxs(i,j+1))*qPr(i,j+1,it)+&
+                   Pa(i,j)*qPa(i,j,it)+Pm(i,j)*qMel(i,j,it)&
+                   +imp(i,j)/RG*dxpres(i,j)*qDi(i,j,it))/&
+                  (pmflxr(i,j+1)+pmflxs(i,j+1)+Pa(i,j)+Pm(i,j))
+      endif
+    else   !     denominateur non nul
+     kappa(i,j)=1./kappa(i,j)     
+! calcul de qd et qp
+!!jyg  (20130119) correction pour le sommet du nuage
+!!     if(j.ge.inb(i)) then       !au-dessus du nuage, sommet inclu
+     if(j.gt.inb(i)) then       !au-dessus du nuage
+       qDi(i,j,it)=tr(i,j,it)   ! pas de descente => environnement = descente insaturee
+       qPr(i,j,it)=0.
+
+!  vvv premiere couche du modele ou mp(1)=0  ! det tout le temps  vvv
+     elseif(j.eq.1) then 
+      if(mp(i,2).gt.1.e-10) then !mp(2) non nul -> detrainement (car mp(1) = 0) !ent pas possible
+       if(NO_precip(i,j)) then !pas de precip en (i)
+        qDi(i,j,it)=qDi(i,j+1,it)
+        qPr(i,j,it)=0.
+       else
+        qDi(i,j,it)=kappa(i,j)*(&
+            (-evap(i,j)/RG*dxpres(i,j))*((pmflxr(i,j+1)+pmflxs(i,j+1))*qPr(i,j+1,it)+&
+            Pa(i,j)*qPa(i,j,it)+Pm(i,j)*qMel(i,j,it)) +&
+            (pmflxr(i,j+1)+pmflxs(i,j+1)+Pa(i,j)+Pm(i,j))*&
+            (-mp(i,j+1)*qDi(i,j+1,it)))
+
+        qPr(i,j,it)=kappa(i,j)*(&
+            (-mp(i,j+1)-imp(i,j)/RG*dxpres(i,j))*&
+            ((pmflxr(i,j+1)+pmflxs(i,j+1))*qPr(i,j+1,it)+&
+            Pa(i,j)*qPa(i,j,it)+Pm(i,j)*qMel(i,j,it))&
+            +(-mp(i,j+1)*qDi(i,j+1,it)) * (imp(i,j)/RG*dxpres(i,j)))
+       endif
+
+      else !mp(2) nul -> plus de descente insaturee -> pluie agit sur environnement
+        qDi(i,j,it)=tr(i,j,it) ! orig 0.
+        if(NO_precip(i,j)) then
+         qPr(i,j,it)=0.
+        else
+         qPr(i,j,it)=((pmflxr(i,j+1)+pmflxs(i,j+1))*qPr(i,j+1,it)+&
+                   Pa(i,j)*qPa(i,j,it)+Pm(i,j)*qMel(i,j,it)&
+                   +imp(i,j)/RG*dxpres(i,j)*tr(i,j,it))/&
+                  (pmflxr(i,j+1)+pmflxs(i,j+1)+Pa(i,j)+Pm(i,j))
+        endif
+
+      endif  !mp(2) nul ou non
+
+! vvv  (j!=1.and.j.lt.inb(i))  en-dessous du sommet nuage   vvv
+     else 
+!------------------------------------------------------------- detrainement 
+      if(mp(i,j+1).gt.mp(i,j).and.mp(i,j+1).gt.1.e-10) then !mp(i,j).gt.1.e-10) then
+         if(NO_precip(i,j)) then 
+          qDi(i,j,it)=qDi(i,j+1,it)
+          qPr(i,j,it)=0.
+         else
+          qDi(i,j,it)=kappa(i,j)*(&
+            (-evap(i,j)/RG*dxpres(i,j))*((pmflxr(i,j+1)+pmflxs(i,j+1))*qPr(i,j+1,it)+&
+            Pa(i,j)*qPa(i,j,it)+Pm(i,j)*qMel(i,j,it)) +&
+            (pmflxr(i,j+1)+pmflxs(i,j+1)+Pa(i,j)+Pm(i,j))*&
+            (-mp(i,j+1)*qDi(i,j+1,it)))
+!
+          qPr(i,j,it)=kappa(i,j)*(&
+            (-mp(i,j+1)-imp(i,j)/RG*dxpres(i,j))*&
+            ((pmflxr(i,j+1)+pmflxs(i,j+1))*qPr(i,j+1,it)+&
+            Pa(i,j)*qPa(i,j,it)+Pm(i,j)*qMel(i,j,it))&
+            +(-mp(i,j+1)*qDi(i,j+1,it)) * (imp(i,j)/RG*dxpres(i,j)))
+         endif !precip
+!------------------------------------------------------------- entrainement 
+      elseif(mp(i,j).gt.mp(i,j+1).and.mp(i,j).gt.1.e-10) then 
+         if(NO_precip(i,j)) then
+          qDi(i,j,it)=(-mp(i,j+1)*(qDi(i,j+1,it)-tr(i,j,it))-mp(i,j)*tr(i,j,it))/(-mp(i,j))
+          qPr(i,j,it)=0.
+         else
+          qDi(i,j,it)=kappa(i,j)*(&
+            (-evap(i,j)/RG*dxpres(i,j))*((pmflxr(i,j+1)+pmflxs(i,j+1))*qPr(i,j+1,it)+&
+            Pa(i,j)*qPa(i,j,it)+Pm(i,j)*qMel(i,j,it)) +&
+            (pmflxr(i,j+1)+pmflxs(i,j+1)+Pa(i,j)+Pm(i,j))*&
+            (-mp(i,j+1)*(qDi(i,j+1,it)-tr(i,j,it))-mp(i,j)*tr(i,j,it)))
+!
+          qPr(i,j,it)=kappa(i,j)*(&
+            (-mp(i,j)-imp(i,j)/RG*dxpres(i,j))*&
+            ((pmflxr(i,j+1)+pmflxs(i,j+1))*qPr(i,j+1,it)+&
+            Pa(i,j)*qPa(i,j,it)+Pm(i,j)*qMel(i,j,it))&
+            +(-mp(i,j+1)*(qDi(i,j+1,it)-tr(i,j,it))-mp(i,j)*tr(i,j,it))*&
+            (imp(i,j)/RG*dxpres(i,j)))
+         endif !precip
+!------------------------------------------------------------- endif ! ent/det
+      else  !mp nul
+        qDi(i,j,it)=tr(i,j,it) ! orig 0.
+        if(NO_precip(i,j)) then
+         qPr(i,j,it)=0.
+        else
+         qPr(i,j,it)=((pmflxr(i,j+1)+pmflxs(i,j+1))*qPr(i,j+1,it)+&
+                   Pa(i,j)*qPa(i,j,it)+Pm(i,j)*qMel(i,j,it)&
+                   +imp(i,j)/RG*dxpres(i,j)*tr(i,j,it))/&
+                  (pmflxr(i,j+1)+pmflxs(i,j+1)+Pa(i,j)+Pm(i,j))
+        endif
+      endif ! mp nul ou non
+     endif ! condition sur j
+    endif ! kappa
+   ENDDO
+  ENDDO
+
+!! print test descente insaturee
+!  DO j=klev,1,-1
+!   DO i=1,klon
+!     if(it.eq.3) then
+!   write(*,'(I2,2X,a,e20.12,2X,a,e20.12,2X,a,e20.12,2X,a,e20.12,2X,a,e20.12,2X,a,e20.12,2X,a,e20.12)') j,&
+!!         'zmfdam',zmfdam(i,j,it),'zmfpsi',zmfphi2(i,j,it),&
+!          'zmfdam+zmfpsi',zmfdam(i,j,it)+zmfphi2(i,j,it),'qpmMint',qpmMint(i,j,it),&
+!          'Pm',Pm(i,j),'Mint',Mint(i,j),&
+!!          'zmfa',zmfa(i,j,it),'zmfp',zmfp(i,j,it),&
+!        'zmfdam',zmfdam(i,j,it),'zmfpsi',zmfphi2(i,j,it),'zmfd1a',zmfd1a(i,j,it)
+!!          'Pa',Pa(i,j),'eplaMm',eplaMm(i,j)
+!!         'zmfd1a=da1*qa',zmfd1a(i,j,it),'Pa*qPa',wdtrainA(i,j)*qPa(i,j,it),'da1',d1a(i,j)
+!     endif
+!   ENDDO
+!  ENDDO
+
+
+! ===================================================
+! calcul final des tendances
+! ===================================================
+
+  DO k=klev-1,1,-1
+    DO i=1, klon
+! transport
+     tdcvMA=zmfd(i,k,it)+zmfu(i,k,it)+zmfa(i,k,it)+zmfp(i,k,it)   ! double comptage des downdraft insatures
+     trsptrac=zmfu(i,k,it)+zmfa(i,k,it)+zmfp(i,k,it)
+! lessivage courants satures
+     scavtrac=-ccntrAA_coef*zmfd1a(i,k,it)&
+               -zmfphi2(i,k,it)*ccntrENV_coef&
+               -zmfdam(i,k,it)*ccntrAA_coef
+! lessivage courants insatures
+   if(k.le.inb(i).and.k.gt.1) then   ! tendances dans le nuage
+!------------------------------------------------------------- detrainement
+      if(mp(i,k+1).gt.mp(i,k).and.mp(i,k+1).gt.1.e-10) then
+        uscavtrac= (-mp(i,k)+mp(i,k+1))*(qDi(i,k,it)-tr(i,k,it))&
+                   + mp(i,k)*(tr(i,k-1,it)-tr(i,k,it))
+!
+!        if(it.eq.3) write(*,'(I2,1X,a,5X,e20.12,82X,a,e20.12)')k,' det incloud',&
+!                    (-mp(i,k)+mp(i,k+1))*(qDi(i,k,it)-tr(i,k,it))*pdtimeRG/dxpres(i,k)+&
+!                    mp(i,k)*(tr(i,k-1,it)-tr(i,k,it))*pdtimeRG/dxpres(i,k),&
+!                    'mp',mp(i,k)
+!------------------------------------------------------------- entrainement 
+      elseif(mp(i,k).gt.mp(i,k+1).and.mp(i,k).gt.1.e-10) then
+         uscavtrac= mp(i,k)*(tr(i,k-1,it)-tr(i,k,it))
+!
+!         if(it.eq.3) write(*,'(I2,1X,a,5X,e20.12,82X,a,e20.12)')k,' ent incloud',uscavtrac*pdtimeRG/dxpres(i,k), 'mp',mp(i,k)
+!=!------------------------------------------------------------- end ent/det 
+      else !        mp(i,k+1)=0. et mp(i,k)=0.    pluie directement sur l environnement
+
+        if(NO_precip(i,k)) then
+          uscavtrac=0.
+!         if(it.eq.3) write(*,'(I2,1X,a,e20.12,82X,a,e20.12)')k,' no P ent incloud',uscavtrac*pdtimeRG/dxpres(i,k), 'mp',mp(i,k)
+        else
+          uscavtrac=-imp(i,k)*tr(i,k,it)*dxpres(i,k)/RG+evap(i,k)*qPr(i,k,it)*dxpres(i,k)/RG
+!         if(it.eq.3) write(*,'(I2,1X,a,3X,e20.12,82X,a,e20.12)')k,' P env incloud',uscavtrac*pdtimeRG/dxpres(i,k), 'mp',mp(i,k)
+        endif
+      endif  ! mp/det/ent
+!------------------------------------------------------------- premiere couche 
+   elseif(k.eq.1) then  !                                      mp(1)=0.
+      if(mp(i,2).gt.1.e-10) then  !detrainement
+         uscavtrac= (-0.+mp(i,2))*(qDi(i,k,it)-tr(i,k,it)) !&
+!                   + mp(i,2)*(0.-tr(i,k,it))
+!
+!       if(it.eq.3) write(*,'(I2,1X,a,e20.12,84X,a,e20.12)')k,' 1 det',&
+!                  (-0.+mp(i,2))*(qDi(i,k,it)-tr(i,k,it))*pdtimeRG/dxpres(i,k)+&
+!                  mp(i,2)*(0.-tr(i,k,it))*pdtimeRG/dxpres(i,k),&
+!                   'mp',mp(i,k)
+      else   ! mp(2) = 0 = mp(1) pas de descente insaturee, rien ne se passe s'il ne pleut pas, sinon pluie->env
+        if(NO_precip(i,1)) then
+          uscavtrac=0.
+        else
+          uscavtrac=-imp(i,k)*tr(i,k,it)*dxpres(i,k)/RG+evap(i,k)*qPr(i,k,it)*dxpres(i,k)/RG
+        endif
+!         if(it.eq.3) write(*,'(I2,1X,a,2X,e20.12,82X,a,e20.12)')k,'1 P env incloud',uscavtrac*pdtimeRG/dxpres(i,k), 'mp',mp(i,k)
+      endif
+
+   else   ! k > INB  au-dessus du nuage
+    uscavtrac=0.
+   endif
+
+! =====    tendances finales  ======
+     trsptd(i,k,it)=trsptrac*pdtimeRG/dxpres(i,k)              ! td transport sans eau dans courants satures
+     dtrSscav(i,k,it)=scavtrac*pdtimeRG/dxpres(i,k)            ! td du lessivage dans courants satures
+     dtrUscav(i,k,it)=uscavtrac*pdtimeRG/dxpres(i,k)           ! td courant insat
+     dtrsat(i,k,it)=(trsptrac+scavtrac)*pdtimeRG/dxpres(i,k)   ! td courant sat
+     dtrcv(i,k,it)=(trsptrac+scavtrac+uscavtrac)*pdtimeRG/dxpres(i,k)!dtrsat(i,k,it)+dtrUscav(i,k,it)         td conv
+!!!!!!
+     dtrcvMA(i,k,it)=tdcvMA*pdtimeRG/dxpres(i,k) ! MA tendance convection
+     ENDDO
+  ENDDO
+
+! test de conservation du traceur
+!print*,"_____________________________________________________________"
+!print*,"                                                             "
+!      conserv=0.
+!      conservMA=0.
+!      DO k= klev-1,1,-1
+!        DO i=1, klon
+!         conserv=conserv+dtrcv(i,k,it)*   &
+!        (paprs(i,k)-paprs(i,k+1))/RG
+!         conservMA=conservMA+dtrcvMA(i,k,it)*   &
+!        (paprs(i,k)-paprs(i,k+1))/RG
+!
+!      if(it.eq.3)  write(*,'(I2,2X,a,e20.12,2X,a,e20.12,2X,a,e20.12,2X,a,e20.12)') k,&
+!         'MA td ',dtrcvMA(i,k,it)*dxpres(i,k)/RG,&
+!         ' td',dtrcv(i,k,it)*dxpres(i,k)/RG,'         conservMA ',conservMA,'conserv ',conserv
+!!
+!        ENDDO
+!      ENDDO
+!       if(it.eq.3) print *,'it',it,'conserv ',conserv,'conservMA ',conservMA
+
+END SUBROUTINE cvltr
Index: DZ6/trunk/libf/phylmd/cvltr_noscav.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cvltr_noscav.F90	(revision 5267)
+++ 	(revision )
@@ -1,201 +1,0 @@
-!
-! $Id $
-!
-SUBROUTINE cvltr_noscav(it,pdtime,da, phi, mp,wght_cvfd,paprs,pplay,x,upd,dnd,dx)
-  USE dimphy
-  USE infotrac_phy, ONLY : nbtr
-  IMPLICIT NONE 
-!=====================================================================
-! Objet : convection des traceurs / KE
-! Auteurs: M-A Filiberti and J-Y Grandpeix
-!=====================================================================
-  include "YOMCST.h"
-  include "YOECUMF.h" 
-
-! Entree
-  REAL,INTENT(IN)                           :: pdtime
-  INTEGER, INTENT(IN)                       :: it
-  REAL,DIMENSION(klon,klev),INTENT(IN)      :: da
-  REAL,DIMENSION(klon,klev,klev),INTENT(IN) :: phi
-  REAL,DIMENSION(klon,klev),INTENT(IN)      :: mp
-  REAL,DIMENSION(klon,klev),INTENT(IN)      :: wght_cvfd  ! weights of the layers feeding convection
-  REAL,DIMENSION(klon,klev+1),INTENT(IN)    :: paprs ! pression aux 1/2 couches (bas en haut)
-  REAL,DIMENSION(klon,klev),INTENT(IN)      :: pplay ! pression pour le milieu de chaque couche
-  REAL,DIMENSION(klon,klev,nbtr),INTENT(IN)      :: x     ! q de traceur (bas en haut) 
-  REAL,DIMENSION(klon,klev),INTENT(IN)      :: upd   ! saturated updraft mass flux
-  REAL,DIMENSION(klon,klev),INTENT(IN)      :: dnd   ! saturated downdraft mass flux
-
-! Sortie
-  REAL,DIMENSION(klon,klev,nbtr),INTENT(inOUT) :: dx ! tendance de traceur  (bas en haut)
-
-! Variables locales     
-! REAL,DIMENSION(klon,klev)       :: zed
-  REAL,DIMENSION(klon,klev,klev)  :: zmd
-  REAL,DIMENSION(klon,klev,klev)  :: za
-  REAL,DIMENSION(klon,klev)       :: zmfd,zmfa
-  REAL,DIMENSION(klon,klev)       :: zmfp,zmfu
-  REAL,DIMENSION(klon,nbtr)       :: qfeed     ! tracer concentration feeding convection
-  REAL,DIMENSION(klon,klev)       :: deltap
-  INTEGER                         :: i,k,j 
-  REAL                            :: pdtimeRG
-  REAL                            :: smallest_mp
-  real conserv
-  real smfd
-  real smfu
-  real smfa
-  real smfp
-! =========================================
-! calcul des tendances liees au downdraft
-! =========================================
-!
-  smallest_mp = tiny(mp(1,1))
-!cdir collapse
-  qfeed(:,it) = 0.
-  DO j=1,klev
-  DO i=1,klon
-!   zed(i,j)=0.
-    zmfd(i,j)=0.
-    zmfa(i,j)=0.
-    zmfu(i,j)=0.
-    zmfp(i,j)=0.
-  END DO
-  END DO
-!cdir collapse
-  DO k=1,klev
-  DO j=1,klev
-  DO i=1,klon
-    zmd(i,j,k)=0.
-    za (i,j,k)=0.
-  END DO
-  END DO
-  END DO
-! entrainement
-! DO k=1,klev-1
-!    DO i=1,klon
-!       zed(i,k)=max(0.,mp(i,k)-mp(i,k+1))
-!    END DO
-! END DO
-
-! calcul de la matrice d echange
-! matrice de distribution de la masse entrainee en k
-
-  DO k=1,klev-1
-     DO i=1,klon
-        zmd(i,k,k)=max(0.,mp(i,k)-mp(i,k+1))
-     END DO
-  END DO
-  DO k=2,klev
-     DO j=k-1,1,-1
-        DO i=1,klon
-!!           if(mp(i,j+1).ne.0) then
-!!              zmd(i,j,k)=zmd(i,j+1,k)*min(1.,mp(i,j)/mp(i,j+1))
-!!           ENDif
-           zmd(i,j,k)=zmd(i,j+1,k)*mp(i,j)/max(mp(i,j),mp(i,j+1),smallest_mp)
-        END DO
-     END DO
-  END DO
-  DO k=1,klev
-     DO j=1,klev-1
-        DO i=1,klon
-           za(i,j,k)=max(0.,zmd(i,j+1,k)-zmd(i,j,k))
-        END DO
-     END DO
-  END DO
-!
-! rajout du terme lie a l ascendance induite
-!
-  DO j=2,klev
-     DO i=1,klon
-        za(i,j,j-1)=za(i,j,j-1)+mp(i,j)
-     END DO
-  END DO
-!
-! tendances
-!            
-  DO k=1,klev
-     DO j=1,klev
-        DO i=1,klon
-           zmfd(i,j)=zmfd(i,j)+za(i,j,k)*(x(i,k,it)-x(i,j,it))
-        END DO
-     END DO
-  END DO
-!
-! =========================================
-! calcul des tendances liees aux flux satures
-! =========================================
-!RL
-!  Feeding concentrations
-  DO j=1,klev
-     DO i=1,klon
-        qfeed(i,it)=qfeed(i,it)+wght_cvfd(i,j)*x(i,j,it)
-     END DO
-  END DO
-!RL
-!
-  DO j=1,klev
-     DO i=1,klon
-!RL
-!!        zmfa(i,j,it)=da(i,j)*(x(i,1,it)-x(i,j,it))                     ! da
-        zmfa(i,j)=da(i,j)*(qfeed(i,it)-x(i,j,it))                     ! da
-!RL
-     END DO
-  END DO
-!
-!!  print *,'it, qfeed(1,it), x(1,1,it) ', it, qfeed(1,it), x(1,1,it)  !jyg
-!!  print *,'wght_cvfd ', (j, wght_cvfd(1,j), j=1,5)                     !jyg
-!
-  DO k=1,klev
-     DO j=1,klev
-        DO i=1,klon
-           zmfp(i,j)=zmfp(i,j)+phi(i,j,k)*(x(i,k,it)-x(i,j,it))
-        END DO
-     END DO
-  END DO
-  DO j=1,klev-1
-     DO i=1,klon
-        zmfu(i,j)=max(0.,upd(i,j+1)+dnd(i,j+1))*(x(i,j+1,it)-x(i,j,it))
-     END DO
-  END DO
-  DO j=2,klev
-     DO i=1,klon
-        zmfu(i,j)=zmfu(i,j)+min(0.,upd(i,j)+dnd(i,j))*(x(i,j,it)-x(i,j-1,it))
-     END DO
-  END DO
-
-! =========================================
-! calcul final des tendances
-! =========================================
-  DO k=1, klev
-     DO i=1, klon
-        deltap(i,k)=paprs(i,k)-paprs(i,k+1)
-     ENDDO
-  ENDDO
-  pdtimeRG=pdtime*RG
-!cdir collapse
-  DO k=1, klev
-     DO i=1, klon
-        dx(i,k,it)=(zmfd(i,k)+zmfu(i,k)       &
-                +zmfa(i,k)+zmfp(i,k))*pdtimeRG/deltap(i,k)
-     ENDDO
-  ENDDO
-
-!! test de conservation du traceur
-      conserv=0.
-      smfd = 0.
-      smfu = 0.
-      smfa = 0.
-      smfp = 0.
-      DO k=1, klev
-        DO i=1, klon
-         conserv=conserv+dx(i,k,it)*   &
-          deltap(i,k)/RG
-         smfd = smfd + zmfd(i,k)*pdtime
-         smfu = smfu + zmfu(i,k)*pdtime
-         smfa = smfa + zmfa(i,k)*pdtime
-         smfp = smfp + zmfp(i,k)*pdtime
-        ENDDO
-      ENDDO
-!!      print *,'it',it,'cvltr_noscav conserv, smfd, smfu, smfa, smfp ',conserv,  &
-!!               smfd, smfu, smfa, smfp
-     
-END SUBROUTINE cvltr_noscav
Index: /LMDZ6/trunk/libf/phylmd/cvltr_noscav.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cvltr_noscav.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/cvltr_noscav.f90	(revision 5268)
@@ -0,0 +1,201 @@
+!
+! $Id $
+!
+SUBROUTINE cvltr_noscav(it,pdtime,da, phi, mp,wght_cvfd,paprs,pplay,x,upd,dnd,dx)
+  USE dimphy
+  USE infotrac_phy, ONLY : nbtr
+  IMPLICIT NONE 
+!=====================================================================
+! Objet : convection des traceurs / KE
+! Auteurs: M-A Filiberti and J-Y Grandpeix
+!=====================================================================
+  include "YOMCST.h"
+  include "YOECUMF.h" 
+
+! Entree
+  REAL,INTENT(IN)                           :: pdtime
+  INTEGER, INTENT(IN)                       :: it
+  REAL,DIMENSION(klon,klev),INTENT(IN)      :: da
+  REAL,DIMENSION(klon,klev,klev),INTENT(IN) :: phi
+  REAL,DIMENSION(klon,klev),INTENT(IN)      :: mp
+  REAL,DIMENSION(klon,klev),INTENT(IN)      :: wght_cvfd  ! weights of the layers feeding convection
+  REAL,DIMENSION(klon,klev+1),INTENT(IN)    :: paprs ! pression aux 1/2 couches (bas en haut)
+  REAL,DIMENSION(klon,klev),INTENT(IN)      :: pplay ! pression pour le milieu de chaque couche
+  REAL,DIMENSION(klon,klev,nbtr),INTENT(IN)      :: x     ! q de traceur (bas en haut) 
+  REAL,DIMENSION(klon,klev),INTENT(IN)      :: upd   ! saturated updraft mass flux
+  REAL,DIMENSION(klon,klev),INTENT(IN)      :: dnd   ! saturated downdraft mass flux
+
+! Sortie
+  REAL,DIMENSION(klon,klev,nbtr),INTENT(inOUT) :: dx ! tendance de traceur  (bas en haut)
+
+! Variables locales     
+! REAL,DIMENSION(klon,klev)       :: zed
+  REAL,DIMENSION(klon,klev,klev)  :: zmd
+  REAL,DIMENSION(klon,klev,klev)  :: za
+  REAL,DIMENSION(klon,klev)       :: zmfd,zmfa
+  REAL,DIMENSION(klon,klev)       :: zmfp,zmfu
+  REAL,DIMENSION(klon,nbtr)       :: qfeed     ! tracer concentration feeding convection
+  REAL,DIMENSION(klon,klev)       :: deltap
+  INTEGER                         :: i,k,j 
+  REAL                            :: pdtimeRG
+  REAL                            :: smallest_mp
+  real conserv
+  real smfd
+  real smfu
+  real smfa
+  real smfp
+! =========================================
+! calcul des tendances liees au downdraft
+! =========================================
+!
+  smallest_mp = tiny(mp(1,1))
+!cdir collapse
+  qfeed(:,it) = 0.
+  DO j=1,klev
+  DO i=1,klon
+!   zed(i,j)=0.
+    zmfd(i,j)=0.
+    zmfa(i,j)=0.
+    zmfu(i,j)=0.
+    zmfp(i,j)=0.
+  END DO
+  END DO
+!cdir collapse
+  DO k=1,klev
+  DO j=1,klev
+  DO i=1,klon
+    zmd(i,j,k)=0.
+    za (i,j,k)=0.
+  END DO
+  END DO
+  END DO
+! entrainement
+! DO k=1,klev-1
+!    DO i=1,klon
+!       zed(i,k)=max(0.,mp(i,k)-mp(i,k+1))
+!    END DO
+! END DO
+
+! calcul de la matrice d echange
+! matrice de distribution de la masse entrainee en k
+
+  DO k=1,klev-1
+     DO i=1,klon
+        zmd(i,k,k)=max(0.,mp(i,k)-mp(i,k+1))
+     END DO
+  END DO
+  DO k=2,klev
+     DO j=k-1,1,-1
+        DO i=1,klon
+!!           if(mp(i,j+1).ne.0) then
+!!              zmd(i,j,k)=zmd(i,j+1,k)*min(1.,mp(i,j)/mp(i,j+1))
+!!           ENDif
+           zmd(i,j,k)=zmd(i,j+1,k)*mp(i,j)/max(mp(i,j),mp(i,j+1),smallest_mp)
+        END DO
+     END DO
+  END DO
+  DO k=1,klev
+     DO j=1,klev-1
+        DO i=1,klon
+           za(i,j,k)=max(0.,zmd(i,j+1,k)-zmd(i,j,k))
+        END DO
+     END DO
+  END DO
+!
+! rajout du terme lie a l ascendance induite
+!
+  DO j=2,klev
+     DO i=1,klon
+        za(i,j,j-1)=za(i,j,j-1)+mp(i,j)
+     END DO
+  END DO
+!
+! tendances
+!            
+  DO k=1,klev
+     DO j=1,klev
+        DO i=1,klon
+           zmfd(i,j)=zmfd(i,j)+za(i,j,k)*(x(i,k,it)-x(i,j,it))
+        END DO
+     END DO
+  END DO
+!
+! =========================================
+! calcul des tendances liees aux flux satures
+! =========================================
+!RL
+!  Feeding concentrations
+  DO j=1,klev
+     DO i=1,klon
+        qfeed(i,it)=qfeed(i,it)+wght_cvfd(i,j)*x(i,j,it)
+     END DO
+  END DO
+!RL
+!
+  DO j=1,klev
+     DO i=1,klon
+!RL
+!!        zmfa(i,j,it)=da(i,j)*(x(i,1,it)-x(i,j,it))                     ! da
+        zmfa(i,j)=da(i,j)*(qfeed(i,it)-x(i,j,it))                     ! da
+!RL
+     END DO
+  END DO
+!
+!!  print *,'it, qfeed(1,it), x(1,1,it) ', it, qfeed(1,it), x(1,1,it)  !jyg
+!!  print *,'wght_cvfd ', (j, wght_cvfd(1,j), j=1,5)                     !jyg
+!
+  DO k=1,klev
+     DO j=1,klev
+        DO i=1,klon
+           zmfp(i,j)=zmfp(i,j)+phi(i,j,k)*(x(i,k,it)-x(i,j,it))
+        END DO
+     END DO
+  END DO
+  DO j=1,klev-1
+     DO i=1,klon
+        zmfu(i,j)=max(0.,upd(i,j+1)+dnd(i,j+1))*(x(i,j+1,it)-x(i,j,it))
+     END DO
+  END DO
+  DO j=2,klev
+     DO i=1,klon
+        zmfu(i,j)=zmfu(i,j)+min(0.,upd(i,j)+dnd(i,j))*(x(i,j,it)-x(i,j-1,it))
+     END DO
+  END DO
+
+! =========================================
+! calcul final des tendances
+! =========================================
+  DO k=1, klev
+     DO i=1, klon
+        deltap(i,k)=paprs(i,k)-paprs(i,k+1)
+     ENDDO
+  ENDDO
+  pdtimeRG=pdtime*RG
+!cdir collapse
+  DO k=1, klev
+     DO i=1, klon
+        dx(i,k,it)=(zmfd(i,k)+zmfu(i,k)       &
+                +zmfa(i,k)+zmfp(i,k))*pdtimeRG/deltap(i,k)
+     ENDDO
+  ENDDO
+
+!! test de conservation du traceur
+      conserv=0.
+      smfd = 0.
+      smfu = 0.
+      smfa = 0.
+      smfp = 0.
+      DO k=1, klev
+        DO i=1, klon
+         conserv=conserv+dx(i,k,it)*   &
+          deltap(i,k)/RG
+         smfd = smfd + zmfd(i,k)*pdtime
+         smfu = smfu + zmfu(i,k)*pdtime
+         smfa = smfa + zmfa(i,k)*pdtime
+         smfp = smfp + zmfp(i,k)*pdtime
+        ENDDO
+      ENDDO
+!!      print *,'it',it,'cvltr_noscav conserv, smfd, smfu, smfa, smfp ',conserv,  &
+!!               smfd, smfu, smfa, smfp
+     
+END SUBROUTINE cvltr_noscav
Index: DZ6/trunk/libf/phylmd/cvltr_scav.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cvltr_scav.F90	(revision 5267)
+++ 	(revision )
@@ -1,707 +1,0 @@
-!
-! $Id $
-!
-SUBROUTINE cvltr_scav(pdtime, da, phi,phi2,d1a,dam, mpIN,epIN, &
-     sigd,sij,wght_cvfd,clw,elij,epmlmMm,eplaMm,    &
-     pmflxrIN,pmflxsIN,ev,te,wdtrainA,wdtrainM,     &
-     paprs,it,tr,upd,dnd,inb,icb,                   &
-     ccntrAA_3d,ccntrENV_3d,coefcoli_3d,            &
-     dtrcv,trsptd,dtrSscav,dtrsat,dtrUscav,qDi,qPr, &
-     qPa,qMel,qTrdi,dtrcvMA,Mint,                   &
-     zmfd1a,zmfphi2,zmfdam)
-  !
-  USE IOIPSL 
-  USE dimphy
-  USE infotrac_phy, ONLY : nbtr
-  IMPLICIT NONE 
-  !=====================================================================
-  ! Objet : convection des traceurs / KE
-  ! Auteurs: M-A Filiberti and J-Y Grandpeix
-  ! modifiee par R Pilon : lessivage des traceurs / KE
-  !=====================================================================
-
-  include "YOMCST.h"
-  include "YOECUMF.h"
-  include "conema3.h"
-  include "chem.h"
-
-  ! Entree
-  REAL,INTENT(IN)                           :: pdtime
-  REAL,DIMENSION(klon,klev),INTENT(IN)      :: da
-  REAL,DIMENSION(klon,klev,klev),INTENT(IN) :: phi
-  ! RomP
-  REAL,DIMENSION(klon,klev),INTENT(IN)      :: d1a,dam ! matrices pour simplifier
-  REAL,DIMENSION(klon,klev,klev),INTENT(IN) :: phi2    ! l'ecriture des tendances
-  !
-  REAL,DIMENSION(klon,klev),INTENT(IN)      :: mpIN
-  REAL,DIMENSION(klon,klev+1),INTENT(IN)    :: paprs  ! pression aux 1/2 couches (bas en haut)
-  INTEGER,INTENT(IN)                        :: it     ! numero du traceur
-  REAL,DIMENSION(klon,klev,nbtr),INTENT(IN) :: tr     ! q de traceur (bas en haut)
-  REAL,DIMENSION(klon,klev),INTENT(IN)      :: upd   ! saturated updraft mass flux
-  REAL,DIMENSION(klon,klev),INTENT(IN)      :: dnd   ! saturated downdraft mass flux
-  !
-  REAL,DIMENSION(klon,klev),INTENT(IN)      :: wdtrainA   ! masses precipitantes de l'asc adiab
-  REAL,DIMENSION(klon,klev),INTENT(IN)      :: wdtrainM   ! masses precipitantes des melanges
-  !JE  REAL,DIMENSION(klon,klev),INTENT(IN)      :: pmflxrIN   ! vprecip: eau
-  REAL,DIMENSION(klon,klev+1),INTENT(IN)      :: pmflxrIN   ! vprecip: eau
-  !JE  REAL,DIMENSION(klon,klev),INTENT(IN)      :: pmflxsIN   ! vprecip: neige
-  REAL,DIMENSION(klon,klev+1),INTENT(IN)      :: pmflxsIN   ! vprecip: neige
-  REAL,DIMENSION(klon,klev),INTENT(IN)      :: ev         ! evaporation cv30_routine
-  REAL,DIMENSION(klon,klev),INTENT(IN)      :: epIN
-  REAL,DIMENSION(klon,klev),INTENT(IN)      :: te 
-  REAL,DIMENSION(klon,klev,klev),INTENT(IN) :: sij        ! fraction dair de lenv
-  REAL,DIMENSION(klon,klev),INTENT(IN)      :: wght_cvfd  ! weights of the layers feeding convection
-  REAL,DIMENSION(klon,klev,klev),INTENT(IN) :: elij       ! contenu en eau condensée spécifique/conc deau condensée massique
-  REAL,DIMENSION(klon,klev,klev),INTENT(IN) :: epmlmMm    ! eau condensee precipitee dans mel masse dair sat
-  REAL,DIMENSION(klon,klev),INTENT(IN)      :: eplaMm    ! eau condensee precipitee dans aa masse dair sat
-
-  REAL,DIMENSION(klon,klev),INTENT(IN)      :: clw        ! contenu en eau condensée dans lasc adiab
-  REAL,DIMENSION(klon),INTENT(IN)           :: sigd
-  INTEGER,DIMENSION(klon),INTENT(IN)        :: icb,inb
-  !
-  REAL,DIMENSION(klon,klev),INTENT(IN) :: ccntrAA_3d
-  REAL,DIMENSION(klon,klev),INTENT(IN) :: ccntrENV_3d
-  REAL,DIMENSION(klon,klev),INTENT(IN) :: coefcoli_3d
-  !
-  ! Sortie
-  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)     :: dtrcv     ! tendance totale (bas en haut)
-  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)     :: dtrcvMA ! M-A Filiberti
-  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)     :: trsptd    ! tendance du transport 
-  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)     :: dtrSscav  ! tendance du lessivage courant sat
-  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)     :: dtrsat    ! tendance trsp+sat scav
-  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)     :: dtrUscav  ! tendance du lessivage courant unsat
-  !
-  ! Variables locales
-  INTEGER                           :: i,j,k
-  REAL,DIMENSION(klon,klev)         :: dxpres   ! difference de pression entre niveau (j+1) et (j)
-  REAL                              :: pdtimeRG ! pas de temps * gravite
-  REAL,DIMENSION(klon,nbtr)         :: qfeed     ! tracer concentration feeding convection
-  ! variables pour les courants satures
-  REAL,DIMENSION(klon,klev,klev)    :: zmd
-  REAL,DIMENSION(klon,klev,klev)    :: za
-  REAL,DIMENSION(klon,klev,nbtr)    :: zmfd,zmfa
-  REAL,DIMENSION(klon,klev,nbtr)    :: zmfp,zmfu
-
-  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)    :: zmfd1a
-  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)    :: zmfdam
-  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)    :: zmfphi2
-
-  ! RomP ! les variables sont nettoyees des valeurs aberrantes
-  REAL,DIMENSION(klon,klev)         :: Pa, Pm  ! pluie AA et mélanges, var temporaire
-  REAL,DIMENSION(klon,klev)         :: pmflxs,pmflxr ! pmflxrIN,pmflxsIN sans valeur aberante
-  REAL,DIMENSION(klon,klev)         :: mp            ! flux de masse
-  REAL,DIMENSION(klon,klev)         :: ep            ! fraction d'eau convertie en precipitation 
-  REAL,DIMENSION(klon,klev)         :: evap          ! evaporation : variable temporaire 
-  REAL,DIMENSION(klon,klev)         :: rho    !environmental density
-
-  REAL,DIMENSION(klon,klev)         :: kappa ! denominateur du au calcul de la matrice 
-  ! pour obtenir qd et qp
-  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)    :: qTrdi ! traceurs descente air insature transport MA
-  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)    :: qDi  ! traceurs descente insaturees
-  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)    :: qPr  ! traceurs colonne precipitante
-  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)    :: qPa  ! traceurs dans les precip issues lasc. adiab.
-  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)    :: qMel ! traceurs dans les precip issues des melanges
-  REAL,DIMENSION(klon,klev,nbtr)                :: qMeltmp ! variable temporaire 
-  REAL,DIMENSION(klon,klev,nbtr)                :: qpmMint
-  REAL,DIMENSION(klon,klev),INTENT(OUT)         :: Mint
-  ! tendances
-  REAL                              :: tdcvMA           ! terme de transport de traceur (schema Marie Angele)
-  REAL                              :: trsptrac         ! terme de transport de traceur par l'air
-  REAL                              :: scavtrac         ! terme de lessivage courant sature
-  REAL                              :: uscavtrac        ! terme de lessivage courant insature
-  ! impaction
-!!!       Correction apres discussion Romain P. / Olivier B. 
-!!!  REAL,PARAMETER                    :: rdrop=2.5e-3     ! rayon des gouttes d'eau
-  REAL,PARAMETER                    :: rdrop=1.e-3     ! rayon des gouttes d'eau 
-!!!
-  REAL,DIMENSION(klon,klev)         :: imp              ! coefficient d'impaction
-  !
-  LOGICAL,DIMENSION(klon,klev) :: NO_precip
-  ! var tmp tests
-  REAL                           :: conserv
-  real                           :: conservMA
-
-!jyg<
-!!  ! ======================================================
-!!  ! calcul de l'impaction
-!!  ! ======================================================
-!!
-!!  ! impaction sur la surface de la colonne de la descente insaturee
-!!  ! On prend la moyenne des precip entre le niveau i+1 et i
-!!  ! I=3/4* (P(1+1)+P(i))/2 / (sigd*r*rho_l)
-!!  ! 1000kg/m3= densite de l'eau
-!!  ! 0.75e-3 = 3/4 /1000
-!!  ! Par la suite, I est tout le temps multiplie par sig_d pour avoir l'impaction sur la surface de la maille
-!!!!  ! on le neglige ici pour simplifier le code
-!!
-!!  DO j=1,klev-1
-!!     DO i=1,klon
-!!        imp(i,j) = coefcoli_3d(i,j)*0.75e-3/rdrop *&
-!!             0.5*(pmflxr(i,j+1)+pmflxs(i,j+1)+pmflxr(i,j)+pmflxs(i,j))
-!!     ENDDO
-!!  ENDDO
-!>jyg
-  !
-  ! initialisation pour flux de traceurs, td et autre
-  !
-  trsptrac = 0.
-  scavtrac = 0.
-  uscavtrac = 0.
-  qfeed(:,it) = 0.              !RL
-  DO j=1,klev
-     DO i=1,klon
-        zmfd(i,j,it)=0.
-        zmfa(i,j,it)=0.
-        zmfu(i,j,it)=0.
-        zmfp(i,j,it)=0.
-        zmfphi2(i,j,it)=0.
-        zmfd1a(i,j,it)=0.
-        zmfdam(i,j,it)=0.
-        qDi(i,j,it)=0.
-        qPr(i,j,it)=0.
-        qPa(i,j,it)=0.
-        qMel(i,j,it)=0.
-        qMeltmp(i,j,it)=0.
-        qTrdi(i,j,it)=0.
-        kappa(i,j)=0.
-        trsptd(i,j,it)=0.
-        dtrsat(i,j,it)=0.
-        dtrSscav(i,j,it)=0.
-        dtrUscav(i,j,it)=0.
-        dtrcv(i,j,it)=0.
-        dtrcvMA(i,j,it)=0.
-        evap(i,j)=0.
-        dxpres(i,j)=0.
-        qpmMint(i,j,it)=0.
-        Mint(i,j)=0.
-     END DO
-  END DO
-
-  ! suppression des valeurs très faibles (~1e-320)
-  ! multiplication de levaporation pour lavoir par unite de temps
-  ! et par unite de surface de la maille
-  ! -> cv30_unsat : evap : masse evaporee/s/(m2 de la descente)
-  DO j=1,klev
-     DO i=1,klon
-        IF(ev(i,j).lt.1.e-16) THEN
-           evap(i,j)=0.
-        ELSE
-           evap(i,j)=ev(i,j)*sigd(i)
-        ENDIF
-     END DO
-  END DO
-
-  DO j=1,klev
-     DO i=1,klon
-        IF(j.LT.klev) THEN
-           IF(epIN(i,j).LT.1.e-32) THEN
-              ep(i,j)=0.
-           ELSE
-              ep(i,j)=epIN(i,j)
-           ENDIF
-        ELSE
-           ep(i,j)=epmax
-        ENDIF
-        IF(mpIN(i,j).LT.1.e-32) THEN
-           mp(i,j)=0.
-        ELSE
-           mp(i,j)=mpIN(i,j)
-        ENDIF
-        IF(pmflxsIN(i,j).LT.1.e-32) THEN
-           pmflxs(i,j)=0.
-        ELSE
-           pmflxs(i,j)=pmflxsIN(i,j)
-        ENDIF
-        IF(pmflxrIN(i,j).LT.1.e-32) THEN
-           pmflxr(i,j)=0.
-        ELSE
-           pmflxr(i,j)=pmflxrIN(i,j)
-        ENDIF
-        IF(wdtrainA(i,j).LT.1.e-32) THEN
-           Pa(i,j)=0.
-        ELSE
-           Pa(i,j)=wdtrainA(i,j)
-        ENDIF
-        IF(wdtrainM(i,j).LT.1.e-32) THEN
-           Pm(i,j)=0.
-        ELSE
-           Pm(i,j)=wdtrainM(i,j)
-        ENDIF
-     END DO
-  END DO
-
-  !==========================================
-  DO j = klev-1,1,-1
-     DO i = 1,klon
-        NO_precip(i,j) = (pmflxr(i,j+1)+pmflxs(i,j+1)).LT.1.e-10&
-             .AND.Pa(i,j).LT.1.e-10.AND.Pm(i,j).LT.1.e-10
-     END DO
-  END DO
-
-!jyg<
-  ! ======================================================
-  ! calcul de l'impaction
-  ! ======================================================
-
-  ! impaction sur la surface de la colonne de la descente insaturee
-  ! On prend la moyenne des precip entre le niveau i+1 et i
-  ! I=3/4* (P(1+1)+P(i))/2 / (sigd*r*rho_l)
-  ! 1000kg/m3= densite de l'eau
-  ! 0.75e-3 = 3/4 /1000
-  ! Par la suite, I est tout le temps multiplie par sig_d pour avoir l'impaction sur la surface de la maille
-  ! on le neglige ici pour simplifier le code
-
-  DO j=1,klev-1
-     DO i=1,klon
-        imp(i,j) = coefcoli_3d(i,j)*0.75e-3/rdrop *&
-             0.5*(pmflxr(i,j+1)+pmflxs(i,j+1)+pmflxr(i,j)+pmflxs(i,j))
-     ENDDO
-  ENDDO
-!>jyg
-  ! =========================================
-  ! calcul des tendances liees au downdraft
-  ! =========================================
-  !cdir collapse
-  DO k=1,klev
-     DO j=1,klev
-        DO i=1,klon
-           zmd(i,j,k)=0.
-           za (i,j,k)=0.
-        END DO
-     END DO
-  END DO
-  ! calcul de la matrice d echange
-  ! matrice de distribution de la masse entrainee en k
-  ! commmentaire RomP : mp > 0
-  DO k=1,klev-1
-     DO i=1,klon
-        zmd(i,k,k)=max(0.,mp(i,k)-mp(i,k+1))   ! ~ mk(k)
-     END DO
-  END DO
-  DO k=2,klev
-     DO j=k-1,1,-1
-        DO i=1,klon
-           IF(mp(i,j+1).GT.1.e-10) THEN
-              zmd(i,j,k)=zmd(i,j+1,k)*min(1.,mp(i,j)/mp(i,j+1)) !det ~ mk(j)=mk(j+1)*mp(i,j)/mp(i,j+1)
-           ENDIF
-        END DO
-     END DO
-  END DO
-  DO k=1,klev
-     DO j=1,klev-1
-        DO i=1,klon
-           za(i,j,k)=max(0.,zmd(i,j+1,k)-zmd(i,j,k))
-        END DO
-     END DO
-  END DO
-!!!!! quantite  de traceur dans la descente d'air insaturee  :   4 juin 2012
-  DO k=1,klev
-     DO j=1,klev-1
-        DO i=1,klon
-           IF(mp(i,j+1).GT.1.e-10) THEN
-              qTrdi(i,j+1,it)=qTrdi(i,j+1,it)+(zmd(i,j+1,k)/mp(i,j+1))*tr(i,k,it)
-           ELSE
-              qTrdi(i,j,it)=0.!tr(i,j,it)
-           ENDIF
-        ENDDO
-     ENDDO
-  ENDDO
-!!!!!
-  !
-  ! rajout du terme lie a l ascendance induite
-  !
-  DO j=2,klev
-     DO i=1,klon
-        za(i,j,j-1)=za(i,j,j-1)+mp(i,j)
-     END DO
-  END DO
-  !
-  ! tendance courants insatures  ! sans lessivage ancien schema
-  !
-  DO k=1,klev
-     DO j=1,klev
-        DO i=1,klon
-           zmfd(i,j,it)=zmfd(i,j,it)+za(i,j,k)*(tr(i,k,it)-tr(i,j,it))
-        END DO
-     END DO
-  END DO
-  !
-  ! =========================================
-  ! calcul des tendances liees aux courants satures   j <-> z ; k <-> z'
-  ! =========================================
-  !RL
-  !  Feeding concentrations
-  DO j=1,klev
-     DO i=1,klon
-        qfeed(i,it)=qfeed(i,it)+wght_cvfd(i,j)*tr(i,j,it)
-     END DO
-  END DO
-  !RL
-  !
-  DO j=1,klev
-     DO i=1,klon
-        !RL
-        !!        zmfa(i,j,it)=da(i,j)*(tr(i,1,it)-tr(i,j,it))                     ! da
-        zmfa(i,j,it)=da(i,j)*(qfeed(i,it)-tr(i,j,it))                     ! da
-        !RL
-     END DO
-  END DO
-  !
-  DO k=1,klev
-     DO j=1,klev
-        DO i=1,klon
-           zmfp(i,j,it)=zmfp(i,j,it)+phi(i,j,k)*(tr(i,k,it)-tr(i,j,it))  ! phi
-        END DO
-     END DO
-  END DO
-  ! RomP ajout des matrices liees au lessivage
-  DO j=1,klev
-     DO i=1,klon
-        zmfd1a(i,j,it)=d1a(i,j)*tr(i,1,it)   ! da1
-        zmfdam(i,j,it)=dam(i,j)*tr(i,1,it)   ! dam
-     END DO
-  END DO
-  DO k=1,klev
-     DO j=1,klev
-        DO i=1,klon
-           zmfphi2(i,j,it)=zmfphi2(i,j,it)+phi2(i,j,k)*tr(i,k,it)  ! psi
-        END DO
-     END DO
-  END DO
-  DO j=1,klev-1
-     DO i=1,klon
-        zmfu(i,j,it)=max(0.,upd(i,j+1)+dnd(i,j+1))*(tr(i,j+1,it)-tr(i,j,it))
-     END DO
-  END DO
-  DO j=2,klev
-     DO i=1,klon
-        zmfu(i,j,it)=zmfu(i,j,it)+min(0.,upd(i,j)+dnd(i,j))*(tr(i,j,it)-tr(i,j-1,it))
-     END DO
-  END DO
-  ! ===================================================
-  ! calcul des tendances liees aux courants insatures
-  ! ===================================================
-  !  pression  
-  DO k=1, klev
-     DO i=1, klon
-        dxpres(i,k)=paprs(i,k)-paprs(i,k+1)
-     ENDDO
-  ENDDO
-  pdtimeRG=pdtime*RG
-
-  ! q_pa et q_pm    traceurs issues des courants satures se retrouvant dans les precipitations
-  DO j=1,klev
-     DO i=1,klon
-        IF(j.GE.icb(i).AND.j.LE.inb(i)) THEN
-           IF(clw(i,j).GT.1.e-16) THEN
-              !JE           qPa(i,j,it)=ccntrAA_coef*tr(i,1,it)/clw(i,j)
-              qPa(i,j,it)=ccntrAA_3d(i,j)*tr(i,1,it)/clw(i,j)
-           ELSE
-              qPa(i,j,it)=0.
-           ENDIF
-        ENDIF
-     END DO
-  END DO
-
-  ! calcul de q_pm en 2 parties :
-  ! 1) calcul de sa valeur pour un niveau z' donne
-  ! 2) integration sur la verticale sur z'
-  DO j=1,klev
-     DO k=1,j-1
-        DO i=1,klon
-           IF(k.GE.icb(i).AND.k.LE.inb(i).AND.& 
-                j.LE.inb(i)) THEN
-              IF(elij(i,k,j).GT.1.e-16) THEN
-                 !JE             qMeltmp(i,j,it)=((1-ep(i,k))*ccntrAA_coef*tr(i,1,it)&
-                 !JE                         *(1.-sij(i,k,j))  +ccntrENV_coef&
-                 !JE                         *tr(i,k,it)*sij(i,k,j)) / elij(i,k,j)
-                 qMeltmp(i,j,it)=((1-ep(i,k))*ccntrAA_3d(i,k)*tr(i,1,it)&
-                      *(1.-sij(i,k,j))  +ccntrENV_3d(i,k)&
-                      *tr(i,k,it)*sij(i,k,j)) / elij(i,k,j)
-              ELSE
-                 qMeltmp(i,j,it)=0.
-              ENDIF
-              qpmMint(i,j,it)=qpmMint(i,j,it) + qMeltmp(i,j,it)*epmlmMm(i,j,k)
-              Mint(i,j)=Mint(i,j) + epmlmMm(i,j,k)
-           ENDIF ! end if dans nuage
-        END DO
-     END DO
-  END DO
-
-  DO j=1,klev
-     DO i=1,klon
-        IF(Mint(i,j).GT.1.e-16) THEN
-           qMel(i,j,it)=qpmMint(i,j,it)/Mint(i,j)
-        ELSE
-           qMel(i,j,it)=0.
-        ENDIF
-     END DO
-  END DO
-
-  ! calcul de q_d et q_p    traceurs de la descente precipitante 
-  DO j=klev-1,1,-1
-     DO i=1,klon
-        IF(mp(i,j+1).GT.mp(i,j).AND.mp(i,j+1).GT.1.e-10) THEN  ! detrainement
-           kappa(i,j)=((pmflxr(i,j+1)+pmflxs(i,j+1)+Pa(i,j)+Pm(i,j))*&
-                (-mp(i,j+1)-imp(i,j)/RG*dxpres(i,j))&
-                + (imp(i,j)/RG*dxpres(i,j))*(evap(i,j)/RG*dxpres(i,j)))
-
-        ELSEIF(mp(i,j).GT.mp(i,j+1).AND.mp(i,j).GT.1.e-10) THEN! entrainement
-           IF(j.eq.1) THEN
-              kappa(i,j)=((pmflxr(i,j+1)+pmflxs(i,j+1)+Pa(i,j)+Pm(i,j))*&
-                   (-mp(i,2)-imp(i,j)/RG*dxpres(i,j))&
-                   + (imp(i,j)/RG*dxpres(i,j))*(evap(i,j)/RG*dxpres(i,j)))
-           ELSE
-              kappa(i,j)=((pmflxr(i,j+1)+pmflxs(i,j+1)+Pa(i,j)+Pm(i,j))*&
-                   (-mp(i,j)-imp(i,j)/RG*dxpres(i,j))&
-                   + (imp(i,j)/RG*dxpres(i,j))*(evap(i,j)/RG*dxpres(i,j)))
-           ENDIF
-        ELSE
-           kappa(i,j)=1.
-        ENDIF
-     ENDDO
-  ENDDO
-
-  DO j=klev-1,1,-1
-     DO i=1,klon
-        IF (abs(kappa(i,j)).LT.1.e-25) THEN    !si denominateur nul (il peut y avoir des mp!=0)
-           kappa(i,j)=1.
-           IF(j.eq.1) THEN
-              qDi(i,j,it)=qDi(i,j+1,it) !orig tr(i,j,it)   ! mp(1)=0 donc tout vient de la couche supérieure
-           ELSEIF(mp(i,j+1).GT.mp(i,j).AND.mp(i,j+1).GT.1.e-10) THEN
-              qDi(i,j,it)=qDi(i,j+1,it)
-           ELSEIF(mp(i,j).GT.mp(i,j+1).AND.mp(i,j).GT.1.e-10) THEN! entrainement
-              qDi(i,j,it)=(-mp(i,j+1)*(qDi(i,j+1,it)-tr(i,j,it))-mp(i,j)*tr(i,j,it))/(-mp(i,j))
-           ELSE  ! si  mp (i)=0 et mp(j+1)=0
-              qDi(i,j,it)=tr(i,j,it) ! orig 0.
-           ENDIF
-
-           IF(NO_precip(i,j)) THEN
-              qPr(i,j,it)=0.
-           ELSE
-              qPr(i,j,it)=((pmflxr(i,j+1)+pmflxs(i,j+1))*qPr(i,j+1,it)+&
-                   Pa(i,j)*qPa(i,j,it)+Pm(i,j)*qMel(i,j,it)&
-                   +imp(i,j)/RG*dxpres(i,j)*qDi(i,j,it))/&
-                   (pmflxr(i,j+1)+pmflxs(i,j+1)+Pa(i,j)+Pm(i,j))
-           ENDIF
-        ELSE   !     denominateur non nul
-           kappa(i,j)=1./kappa(i,j)     
-           ! calcul de qd et qp
-           !!jyg  (20130119) correction pour le sommet du nuage
-           !!     if(j.GE.inb(i)) THEN       !au-dessus du nuage, sommet inclu
-           if(j.GT.inb(i)) THEN       !au-dessus du nuage
-              qDi(i,j,it)=tr(i,j,it)   ! pas de descente => environnement = descente insaturee
-              qPr(i,j,it)=0.
-
-              !  vvv premiere couche du modele ou mp(1)=0  ! det tout le temps  vvv
-           ELSEIF(j.eq.1) THEN 
-              if(mp(i,2).GT.1.e-10) THEN !mp(2) non nul -> detrainement (car mp(1) = 0) !ent pas possible
-                 if(NO_precip(i,j)) THEN !pas de precip en (i)
-                    qDi(i,j,it)=qDi(i,j+1,it)
-                    qPr(i,j,it)=0.
-                 ELSE
-                    qDi(i,j,it)=kappa(i,j)*(&
-                         (-evap(i,j)/RG*dxpres(i,j))*((pmflxr(i,j+1)+pmflxs(i,j+1))*qPr(i,j+1,it)+&
-                         Pa(i,j)*qPa(i,j,it)+Pm(i,j)*qMel(i,j,it)) +&
-                         (pmflxr(i,j+1)+pmflxs(i,j+1)+Pa(i,j)+Pm(i,j))*&
-                         (-mp(i,j+1)*qDi(i,j+1,it)))
-
-                    qPr(i,j,it)=kappa(i,j)*(&
-                         (-mp(i,j+1)-imp(i,j)/RG*dxpres(i,j))*&
-                         ((pmflxr(i,j+1)+pmflxs(i,j+1))*qPr(i,j+1,it)+&
-                         Pa(i,j)*qPa(i,j,it)+Pm(i,j)*qMel(i,j,it))&
-                         +(-mp(i,j+1)*qDi(i,j+1,it)) * (imp(i,j)/RG*dxpres(i,j)))
-                 ENDIF
-
-              ELSE !mp(2) nul -> plus de descente insaturee -> pluie agit sur environnement
-                 qDi(i,j,it)=tr(i,j,it) ! orig 0.
-                 if(NO_precip(i,j)) THEN
-                    qPr(i,j,it)=0.
-                 ELSE
-                    qPr(i,j,it)=((pmflxr(i,j+1)+pmflxs(i,j+1))*qPr(i,j+1,it)+&
-                         Pa(i,j)*qPa(i,j,it)+Pm(i,j)*qMel(i,j,it)&
-                         +imp(i,j)/RG*dxpres(i,j)*tr(i,j,it))/&
-                         (pmflxr(i,j+1)+pmflxs(i,j+1)+Pa(i,j)+Pm(i,j))
-                 ENDIF
-
-              ENDIF  !mp(2) nul ou non
-
-              ! vvv  (j!=1.AND.j.LT.inb(i))  en-dessous du sommet nuage   vvv
-           ELSE 
-              !------------------------------------------------------------- detrainement 
-              if(mp(i,j+1).GT.mp(i,j).AND.mp(i,j+1).GT.1.e-10) THEN !mp(i,j).GT.1.e-10) THEN
-                 if(NO_precip(i,j)) THEN 
-                    qDi(i,j,it)=qDi(i,j+1,it)
-                    qPr(i,j,it)=0.
-                 ELSE
-                    qDi(i,j,it)=kappa(i,j)*(&
-                         (-evap(i,j)/RG*dxpres(i,j))*((pmflxr(i,j+1)+pmflxs(i,j+1))*qPr(i,j+1,it)+&
-                         Pa(i,j)*qPa(i,j,it)+Pm(i,j)*qMel(i,j,it)) +&
-                         (pmflxr(i,j+1)+pmflxs(i,j+1)+Pa(i,j)+Pm(i,j))*&
-                         (-mp(i,j+1)*qDi(i,j+1,it)))
-                    !
-                    qPr(i,j,it)=kappa(i,j)*(&
-                         (-mp(i,j+1)-imp(i,j)/RG*dxpres(i,j))*&
-                         ((pmflxr(i,j+1)+pmflxs(i,j+1))*qPr(i,j+1,it)+&
-                         Pa(i,j)*qPa(i,j,it)+Pm(i,j)*qMel(i,j,it))&
-                         +(-mp(i,j+1)*qDi(i,j+1,it)) * (imp(i,j)/RG*dxpres(i,j)))
-                 ENDIF !precip
-                 !------------------------------------------------------------- entrainement 
-              ELSEIF(mp(i,j).GT.mp(i,j+1).AND.mp(i,j).GT.1.e-10) THEN 
-                 if(NO_precip(i,j)) THEN
-                    qDi(i,j,it)=(-mp(i,j+1)*(qDi(i,j+1,it)-tr(i,j,it))-mp(i,j)*tr(i,j,it))/(-mp(i,j))
-                    qPr(i,j,it)=0.
-                 ELSE
-                    qDi(i,j,it)=kappa(i,j)*(&
-                         (-evap(i,j)/RG*dxpres(i,j))*((pmflxr(i,j+1)+pmflxs(i,j+1))*qPr(i,j+1,it)+&
-                         Pa(i,j)*qPa(i,j,it)+Pm(i,j)*qMel(i,j,it)) +&
-                         (pmflxr(i,j+1)+pmflxs(i,j+1)+Pa(i,j)+Pm(i,j))*&
-                         (-mp(i,j+1)*(qDi(i,j+1,it)-tr(i,j,it))-mp(i,j)*tr(i,j,it)))
-                    !
-                    qPr(i,j,it)=kappa(i,j)*(&
-                         (-mp(i,j)-imp(i,j)/RG*dxpres(i,j))*&
-                         ((pmflxr(i,j+1)+pmflxs(i,j+1))*qPr(i,j+1,it)+&
-                         Pa(i,j)*qPa(i,j,it)+Pm(i,j)*qMel(i,j,it))&
-                         +(-mp(i,j+1)*(qDi(i,j+1,it)-tr(i,j,it))-mp(i,j)*tr(i,j,it))*&
-                         (imp(i,j)/RG*dxpres(i,j)))
-                 ENDIF !precip
-                 !------------------------------------------------------------- ENDIF ! ent/det
-              ELSE  !mp nul
-                 qDi(i,j,it)=tr(i,j,it) ! orig 0.
-                 if(NO_precip(i,j)) THEN
-                    qPr(i,j,it)=0.
-                 ELSE
-                    qPr(i,j,it)=((pmflxr(i,j+1)+pmflxs(i,j+1))*qPr(i,j+1,it)+&
-                         Pa(i,j)*qPa(i,j,it)+Pm(i,j)*qMel(i,j,it)&
-                         +imp(i,j)/RG*dxpres(i,j)*tr(i,j,it))/&
-                         (pmflxr(i,j+1)+pmflxs(i,j+1)+Pa(i,j)+Pm(i,j))
-                 ENDIF
-              ENDIF ! mp nul ou non
-           ENDIF ! condition sur j
-        ENDIF ! kappa
-     ENDDO
-  ENDDO
-
-  !! print test descente insaturee
-  !  DO j=klev,1,-1
-  !   DO i=1,klon
-  !     if(it.eq.3) THEN
-  !   write(*,'(I2,2X,a,e20.12,2X,a,e20.12,2X,a,e20.12,2X,a,e20.12,2X,a,e20.12,2X,a,e20.12,2X,a,e20.12)') j,&
-  !!         'zmfdam',zmfdam(i,j,it),'zmfpsi',zmfphi2(i,j,it),&
-  !          'zmfdam+zmfpsi',zmfdam(i,j,it)+zmfphi2(i,j,it),'qpmMint',qpmMint(i,j,it),&
-  !          'Pm',Pm(i,j),'Mint',Mint(i,j),&
-  !!          'zmfa',zmfa(i,j,it),'zmfp',zmfp(i,j,it),&
-  !        'zmfdam',zmfdam(i,j,it),'zmfpsi',zmfphi2(i,j,it),'zmfd1a',zmfd1a(i,j,it)
-  !!          'Pa',Pa(i,j),'eplaMm',eplaMm(i,j)
-  !!         'zmfd1a=da1*qa',zmfd1a(i,j,it),'Pa*qPa',wdtrainA(i,j)*qPa(i,j,it),'da1',d1a(i,j)
-  !     ENDIF
-  !   ENDDO
-  !  ENDDO
-
-
-  ! ===================================================
-  ! calcul final des tendances
-  ! ===================================================
-
-  DO k=klev-1,1,-1
-     DO i=1, klon
-        ! transport
-        tdcvMA=zmfd(i,k,it)+zmfu(i,k,it)+zmfa(i,k,it)+zmfp(i,k,it)   ! double comptage des downdraft insatures
-        trsptrac=zmfu(i,k,it)+zmfa(i,k,it)+zmfp(i,k,it)
-        ! lessivage courants satures
-        !JE     scavtrac=-ccntrAA_coef*zmfd1a(i,k,it)&
-        !JE               -zmfphi2(i,k,it)*ccntrENV_coef&
-        !JE               -zmfdam(i,k,it)*ccntrAA_coef
-        scavtrac=-ccntrAA_3d(i,k)*zmfd1a(i,k,it)&
-             -zmfphi2(i,k,it)*ccntrENV_3d(i,k)&
-             -zmfdam(i,k,it)*ccntrAA_3d(i,k)
-        ! lessivage courants insatures
-        if(k.LE.inb(i).AND.k.GT.1) THEN   ! tendances dans le nuage
-           !------------------------------------------------------------- detrainement
-           if(mp(i,k+1).GT.mp(i,k).AND.mp(i,k+1).GT.1.e-10) THEN
-              uscavtrac= (-mp(i,k)+mp(i,k+1))*(qDi(i,k,it)-tr(i,k,it))&
-                   + mp(i,k)*(tr(i,k-1,it)-tr(i,k,it))
-              !
-              !        if(it.eq.3) write(*,'(I2,1X,a,5X,e20.12,82X,a,e20.12)')k,' det incloud',&
-              !                    (-mp(i,k)+mp(i,k+1))*(qDi(i,k,it)-tr(i,k,it))*pdtimeRG/dxpres(i,k)+&
-              !                    mp(i,k)*(tr(i,k-1,it)-tr(i,k,it))*pdtimeRG/dxpres(i,k),&
-              !                    'mp',mp(i,k)
-              !------------------------------------------------------------- entrainement 
-           ELSEIF(mp(i,k).GT.mp(i,k+1).AND.mp(i,k).GT.1.e-10) THEN
-              uscavtrac= mp(i,k)*(tr(i,k-1,it)-tr(i,k,it))
-              !
-              !         if(it.eq.3) write(*,'(I2,1X,a,5X,e20.12,82X,a,e20.12)')k,' ent incloud',uscavtrac*pdtimeRG/dxpres(i,k), 'mp',mp(i,k)
-              !=!------------------------------------------------------------- end ent/det 
-           ELSE !        mp(i,k+1)=0. et mp(i,k)=0.    pluie directement sur l environnement
-
-              if(NO_precip(i,k)) THEN
-                 uscavtrac=0.
-                 !         if(it.eq.3) write(*,'(I2,1X,a,e20.12,82X,a,e20.12)')k,' no P ent incloud',uscavtrac*pdtimeRG/dxpres(i,k), 'mp',mp(i,k)
-              ELSE
-                 uscavtrac=-imp(i,k)*tr(i,k,it)*dxpres(i,k)/RG+evap(i,k)*qPr(i,k,it)*dxpres(i,k)/RG
-                 !         if(it.eq.3) write(*,'(I2,1X,a,3X,e20.12,82X,a,e20.12)')k,' P env incloud',uscavtrac*pdtimeRG/dxpres(i,k), 'mp',mp(i,k)
-                 !!JE adds
-                 !         if(it.eq.3) write(*,'(I2,1X,a,3X,e20.12,82X,a,e20.12)')k,' P env incloud',uscavtrac, 'imp',imp(i,k)
-                 !         if(it.eq.3) write(*,'(I2,1X,a,3X,e20.12,82X,a,e20.12)')k,' P env incloud',uscavtrac, 'tr',tr(i,k,it)
-                 !         if(it.eq.3) write(*,'(I2,1X,a,3X,e20.12,82X,a,e20.12)')k,' P env incloud',uscavtrac, 'evap',evap(i,k)
-                 !         if(it.eq.3) write(*,'(I2,1X,a,3X,e20.12,82X,a,e20.12)')k,' P env incloud',uscavtrac, 'qPr',qPr(i,k,it)
-                 !         if(it.eq.3) write(*,'(I2,1X,a,3X,e20.12,82X,a,e20.12)')k,' P env incloud',uscavtrac, 'dxpres',dxpres(i,k)
-                 !!Je end
-
-              ENDIF
-           ENDIF  ! mp/det/ent
-           !------------------------------------------------------------- premiere couche 
-        ELSEIF(k.eq.1) THEN  !                                      mp(1)=0.
-           if(mp(i,2).GT.1.e-10) THEN  !detrainement
-              uscavtrac= (-0.+mp(i,2))*(qDi(i,k,it)-tr(i,k,it)) !&
-              !                   + mp(i,2)*(0.-tr(i,k,it))
-              !
-              !       if(it.eq.3) write(*,'(I2,1X,a,e20.12,84X,a,e20.12)')k,' 1 det',&
-              !                  (-0.+mp(i,2))*(qDi(i,k,it)-tr(i,k,it))*pdtimeRG/dxpres(i,k)+&
-              !                  mp(i,2)*(0.-tr(i,k,it))*pdtimeRG/dxpres(i,k),&
-              !                   'mp',mp(i,k)
-           ELSE   ! mp(2) = 0 = mp(1) pas de descente insaturee, rien ne se passe s'il ne pleut pas, sinon pluie->env
-              if(NO_precip(i,1)) THEN
-                 uscavtrac=0.
-              ELSE
-                 uscavtrac=-imp(i,k)*tr(i,k,it)*dxpres(i,k)/RG+evap(i,k)*qPr(i,k,it)*dxpres(i,k)/RG
-              ENDIF
-              !         if(it.eq.3) write(*,'(I2,1X,a,2X,e20.12,82X,a,e20.12)')k,'1 P env incloud',uscavtrac*pdtimeRG/dxpres(i,k), 'mp',mp(i,k)
-           ENDIF
-
-        ELSE   ! k > INB  au-dessus du nuage
-           uscavtrac=0.
-        ENDIF
-
-        ! =====    tendances finales  ======
-        trsptd(i,k,it)=trsptrac*pdtimeRG/dxpres(i,k)              ! td transport sans eau dans courants satures
-        dtrSscav(i,k,it)=scavtrac*pdtimeRG/dxpres(i,k)            ! td du lessivage dans courants satures
-        dtrUscav(i,k,it)=uscavtrac*pdtimeRG/dxpres(i,k)           ! td courant insat
-        dtrsat(i,k,it)=(trsptrac+scavtrac)*pdtimeRG/dxpres(i,k)   ! td courant sat
-        dtrcv(i,k,it)=(trsptrac+scavtrac+uscavtrac)*pdtimeRG/dxpres(i,k)!dtrsat(i,k,it)+dtrUscav(i,k,it)         td conv
-!!!!!!
-        dtrcvMA(i,k,it)=tdcvMA*pdtimeRG/dxpres(i,k) ! MA tendance convection
-     ENDDO
-  ENDDO
-
-  ! test de conservation du traceur
-  !print*,"_____________________________________________________________"
-  !print*,"                                                             "
-  !      conserv=0.
-  !      conservMA=0.
-  !      DO k= klev-1,1,-1
-  !        DO i=1, klon
-  !         conserv=conserv+dtrcv(i,k,it)*   &
-  !        (paprs(i,k)-paprs(i,k+1))/RG
-  !         conservMA=conservMA+dtrcvMA(i,k,it)*   &
-  !        (paprs(i,k)-paprs(i,k+1))/RG
-  !
-  !      if(it.eq.3)  write(*,'(I2,2X,a,e20.12,2X,a,e20.12,2X,a,e20.12,2X,a,e20.12)') k,&
-  !         'MA td ',dtrcvMA(i,k,it)*dxpres(i,k)/RG,&
-  !         ' td',dtrcv(i,k,it)*dxpres(i,k)/RG,'         conservMA ',conservMA,'conserv ',conserv
-  !!
-  !        ENDDO
-  !      ENDDO
-  !       if(it.eq.3) print *,'it',it,'conserv ',conserv,'conservMA ',conservMA
-
-END SUBROUTINE cvltr_scav
Index: /LMDZ6/trunk/libf/phylmd/cvltr_scav.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cvltr_scav.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/cvltr_scav.f90	(revision 5268)
@@ -0,0 +1,707 @@
+!
+! $Id $
+!
+SUBROUTINE cvltr_scav(pdtime, da, phi,phi2,d1a,dam, mpIN,epIN, &
+     sigd,sij,wght_cvfd,clw,elij,epmlmMm,eplaMm,    &
+     pmflxrIN,pmflxsIN,ev,te,wdtrainA,wdtrainM,     &
+     paprs,it,tr,upd,dnd,inb,icb,                   &
+     ccntrAA_3d,ccntrENV_3d,coefcoli_3d,            &
+     dtrcv,trsptd,dtrSscav,dtrsat,dtrUscav,qDi,qPr, &
+     qPa,qMel,qTrdi,dtrcvMA,Mint,                   &
+     zmfd1a,zmfphi2,zmfdam)
+  !
+  USE IOIPSL 
+  USE dimphy
+  USE infotrac_phy, ONLY : nbtr
+  IMPLICIT NONE 
+  !=====================================================================
+  ! Objet : convection des traceurs / KE
+  ! Auteurs: M-A Filiberti and J-Y Grandpeix
+  ! modifiee par R Pilon : lessivage des traceurs / KE
+  !=====================================================================
+
+  include "YOMCST.h"
+  include "YOECUMF.h"
+  include "conema3.h"
+  include "chem.h"
+
+  ! Entree
+  REAL,INTENT(IN)                           :: pdtime
+  REAL,DIMENSION(klon,klev),INTENT(IN)      :: da
+  REAL,DIMENSION(klon,klev,klev),INTENT(IN) :: phi
+  ! RomP
+  REAL,DIMENSION(klon,klev),INTENT(IN)      :: d1a,dam ! matrices pour simplifier
+  REAL,DIMENSION(klon,klev,klev),INTENT(IN) :: phi2    ! l'ecriture des tendances
+  !
+  REAL,DIMENSION(klon,klev),INTENT(IN)      :: mpIN
+  REAL,DIMENSION(klon,klev+1),INTENT(IN)    :: paprs  ! pression aux 1/2 couches (bas en haut)
+  INTEGER,INTENT(IN)                        :: it     ! numero du traceur
+  REAL,DIMENSION(klon,klev,nbtr),INTENT(IN) :: tr     ! q de traceur (bas en haut)
+  REAL,DIMENSION(klon,klev),INTENT(IN)      :: upd   ! saturated updraft mass flux
+  REAL,DIMENSION(klon,klev),INTENT(IN)      :: dnd   ! saturated downdraft mass flux
+  !
+  REAL,DIMENSION(klon,klev),INTENT(IN)      :: wdtrainA   ! masses precipitantes de l'asc adiab
+  REAL,DIMENSION(klon,klev),INTENT(IN)      :: wdtrainM   ! masses precipitantes des melanges
+  !JE  REAL,DIMENSION(klon,klev),INTENT(IN)      :: pmflxrIN   ! vprecip: eau
+  REAL,DIMENSION(klon,klev+1),INTENT(IN)      :: pmflxrIN   ! vprecip: eau
+  !JE  REAL,DIMENSION(klon,klev),INTENT(IN)      :: pmflxsIN   ! vprecip: neige
+  REAL,DIMENSION(klon,klev+1),INTENT(IN)      :: pmflxsIN   ! vprecip: neige
+  REAL,DIMENSION(klon,klev),INTENT(IN)      :: ev         ! evaporation cv30_routine
+  REAL,DIMENSION(klon,klev),INTENT(IN)      :: epIN
+  REAL,DIMENSION(klon,klev),INTENT(IN)      :: te 
+  REAL,DIMENSION(klon,klev,klev),INTENT(IN) :: sij        ! fraction dair de lenv
+  REAL,DIMENSION(klon,klev),INTENT(IN)      :: wght_cvfd  ! weights of the layers feeding convection
+  REAL,DIMENSION(klon,klev,klev),INTENT(IN) :: elij       ! contenu en eau condensée spécifique/conc deau condensée massique
+  REAL,DIMENSION(klon,klev,klev),INTENT(IN) :: epmlmMm    ! eau condensee precipitee dans mel masse dair sat
+  REAL,DIMENSION(klon,klev),INTENT(IN)      :: eplaMm    ! eau condensee precipitee dans aa masse dair sat
+
+  REAL,DIMENSION(klon,klev),INTENT(IN)      :: clw        ! contenu en eau condensée dans lasc adiab
+  REAL,DIMENSION(klon),INTENT(IN)           :: sigd
+  INTEGER,DIMENSION(klon),INTENT(IN)        :: icb,inb
+  !
+  REAL,DIMENSION(klon,klev),INTENT(IN) :: ccntrAA_3d
+  REAL,DIMENSION(klon,klev),INTENT(IN) :: ccntrENV_3d
+  REAL,DIMENSION(klon,klev),INTENT(IN) :: coefcoli_3d
+  !
+  ! Sortie
+  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)     :: dtrcv     ! tendance totale (bas en haut)
+  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)     :: dtrcvMA ! M-A Filiberti
+  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)     :: trsptd    ! tendance du transport 
+  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)     :: dtrSscav  ! tendance du lessivage courant sat
+  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)     :: dtrsat    ! tendance trsp+sat scav
+  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)     :: dtrUscav  ! tendance du lessivage courant unsat
+  !
+  ! Variables locales
+  INTEGER                           :: i,j,k
+  REAL,DIMENSION(klon,klev)         :: dxpres   ! difference de pression entre niveau (j+1) et (j)
+  REAL                              :: pdtimeRG ! pas de temps * gravite
+  REAL,DIMENSION(klon,nbtr)         :: qfeed     ! tracer concentration feeding convection
+  ! variables pour les courants satures
+  REAL,DIMENSION(klon,klev,klev)    :: zmd
+  REAL,DIMENSION(klon,klev,klev)    :: za
+  REAL,DIMENSION(klon,klev,nbtr)    :: zmfd,zmfa
+  REAL,DIMENSION(klon,klev,nbtr)    :: zmfp,zmfu
+
+  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)    :: zmfd1a
+  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)    :: zmfdam
+  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)    :: zmfphi2
+
+  ! RomP ! les variables sont nettoyees des valeurs aberrantes
+  REAL,DIMENSION(klon,klev)         :: Pa, Pm  ! pluie AA et mélanges, var temporaire
+  REAL,DIMENSION(klon,klev)         :: pmflxs,pmflxr ! pmflxrIN,pmflxsIN sans valeur aberante
+  REAL,DIMENSION(klon,klev)         :: mp            ! flux de masse
+  REAL,DIMENSION(klon,klev)         :: ep            ! fraction d'eau convertie en precipitation 
+  REAL,DIMENSION(klon,klev)         :: evap          ! evaporation : variable temporaire 
+  REAL,DIMENSION(klon,klev)         :: rho    !environmental density
+
+  REAL,DIMENSION(klon,klev)         :: kappa ! denominateur du au calcul de la matrice 
+  ! pour obtenir qd et qp
+  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)    :: qTrdi ! traceurs descente air insature transport MA
+  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)    :: qDi  ! traceurs descente insaturees
+  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)    :: qPr  ! traceurs colonne precipitante
+  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)    :: qPa  ! traceurs dans les precip issues lasc. adiab.
+  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)    :: qMel ! traceurs dans les precip issues des melanges
+  REAL,DIMENSION(klon,klev,nbtr)                :: qMeltmp ! variable temporaire 
+  REAL,DIMENSION(klon,klev,nbtr)                :: qpmMint
+  REAL,DIMENSION(klon,klev),INTENT(OUT)         :: Mint
+  ! tendances
+  REAL                              :: tdcvMA           ! terme de transport de traceur (schema Marie Angele)
+  REAL                              :: trsptrac         ! terme de transport de traceur par l'air
+  REAL                              :: scavtrac         ! terme de lessivage courant sature
+  REAL                              :: uscavtrac        ! terme de lessivage courant insature
+  ! impaction
+!!!       Correction apres discussion Romain P. / Olivier B. 
+!!!  REAL,PARAMETER                    :: rdrop=2.5e-3     ! rayon des gouttes d'eau
+  REAL,PARAMETER                    :: rdrop=1.e-3     ! rayon des gouttes d'eau 
+!!!
+  REAL,DIMENSION(klon,klev)         :: imp              ! coefficient d'impaction
+  !
+  LOGICAL,DIMENSION(klon,klev) :: NO_precip
+  ! var tmp tests
+  REAL                           :: conserv
+  real                           :: conservMA
+
+!jyg<
+!!  ! ======================================================
+!!  ! calcul de l'impaction
+!!  ! ======================================================
+!!
+!!  ! impaction sur la surface de la colonne de la descente insaturee
+!!  ! On prend la moyenne des precip entre le niveau i+1 et i
+!!  ! I=3/4* (P(1+1)+P(i))/2 / (sigd*r*rho_l)
+!!  ! 1000kg/m3= densite de l'eau
+!!  ! 0.75e-3 = 3/4 /1000
+!!  ! Par la suite, I est tout le temps multiplie par sig_d pour avoir l'impaction sur la surface de la maille
+!!!!  ! on le neglige ici pour simplifier le code
+!!
+!!  DO j=1,klev-1
+!!     DO i=1,klon
+!!        imp(i,j) = coefcoli_3d(i,j)*0.75e-3/rdrop *&
+!!             0.5*(pmflxr(i,j+1)+pmflxs(i,j+1)+pmflxr(i,j)+pmflxs(i,j))
+!!     ENDDO
+!!  ENDDO
+!>jyg
+  !
+  ! initialisation pour flux de traceurs, td et autre
+  !
+  trsptrac = 0.
+  scavtrac = 0.
+  uscavtrac = 0.
+  qfeed(:,it) = 0.              !RL
+  DO j=1,klev
+     DO i=1,klon
+        zmfd(i,j,it)=0.
+        zmfa(i,j,it)=0.
+        zmfu(i,j,it)=0.
+        zmfp(i,j,it)=0.
+        zmfphi2(i,j,it)=0.
+        zmfd1a(i,j,it)=0.
+        zmfdam(i,j,it)=0.
+        qDi(i,j,it)=0.
+        qPr(i,j,it)=0.
+        qPa(i,j,it)=0.
+        qMel(i,j,it)=0.
+        qMeltmp(i,j,it)=0.
+        qTrdi(i,j,it)=0.
+        kappa(i,j)=0.
+        trsptd(i,j,it)=0.
+        dtrsat(i,j,it)=0.
+        dtrSscav(i,j,it)=0.
+        dtrUscav(i,j,it)=0.
+        dtrcv(i,j,it)=0.
+        dtrcvMA(i,j,it)=0.
+        evap(i,j)=0.
+        dxpres(i,j)=0.
+        qpmMint(i,j,it)=0.
+        Mint(i,j)=0.
+     END DO
+  END DO
+
+  ! suppression des valeurs très faibles (~1e-320)
+  ! multiplication de levaporation pour lavoir par unite de temps
+  ! et par unite de surface de la maille
+  ! -> cv30_unsat : evap : masse evaporee/s/(m2 de la descente)
+  DO j=1,klev
+     DO i=1,klon
+        IF(ev(i,j).lt.1.e-16) THEN
+           evap(i,j)=0.
+        ELSE
+           evap(i,j)=ev(i,j)*sigd(i)
+        ENDIF
+     END DO
+  END DO
+
+  DO j=1,klev
+     DO i=1,klon
+        IF(j.LT.klev) THEN
+           IF(epIN(i,j).LT.1.e-32) THEN
+              ep(i,j)=0.
+           ELSE
+              ep(i,j)=epIN(i,j)
+           ENDIF
+        ELSE
+           ep(i,j)=epmax
+        ENDIF
+        IF(mpIN(i,j).LT.1.e-32) THEN
+           mp(i,j)=0.
+        ELSE
+           mp(i,j)=mpIN(i,j)
+        ENDIF
+        IF(pmflxsIN(i,j).LT.1.e-32) THEN
+           pmflxs(i,j)=0.
+        ELSE
+           pmflxs(i,j)=pmflxsIN(i,j)
+        ENDIF
+        IF(pmflxrIN(i,j).LT.1.e-32) THEN
+           pmflxr(i,j)=0.
+        ELSE
+           pmflxr(i,j)=pmflxrIN(i,j)
+        ENDIF
+        IF(wdtrainA(i,j).LT.1.e-32) THEN
+           Pa(i,j)=0.
+        ELSE
+           Pa(i,j)=wdtrainA(i,j)
+        ENDIF
+        IF(wdtrainM(i,j).LT.1.e-32) THEN
+           Pm(i,j)=0.
+        ELSE
+           Pm(i,j)=wdtrainM(i,j)
+        ENDIF
+     END DO
+  END DO
+
+  !==========================================
+  DO j = klev-1,1,-1
+     DO i = 1,klon
+        NO_precip(i,j) = (pmflxr(i,j+1)+pmflxs(i,j+1)).LT.1.e-10&
+             .AND.Pa(i,j).LT.1.e-10.AND.Pm(i,j).LT.1.e-10
+     END DO
+  END DO
+
+!jyg<
+  ! ======================================================
+  ! calcul de l'impaction
+  ! ======================================================
+
+  ! impaction sur la surface de la colonne de la descente insaturee
+  ! On prend la moyenne des precip entre le niveau i+1 et i
+  ! I=3/4* (P(1+1)+P(i))/2 / (sigd*r*rho_l)
+  ! 1000kg/m3= densite de l'eau
+  ! 0.75e-3 = 3/4 /1000
+  ! Par la suite, I est tout le temps multiplie par sig_d pour avoir l'impaction sur la surface de la maille
+  ! on le neglige ici pour simplifier le code
+
+  DO j=1,klev-1
+     DO i=1,klon
+        imp(i,j) = coefcoli_3d(i,j)*0.75e-3/rdrop *&
+             0.5*(pmflxr(i,j+1)+pmflxs(i,j+1)+pmflxr(i,j)+pmflxs(i,j))
+     ENDDO
+  ENDDO
+!>jyg
+  ! =========================================
+  ! calcul des tendances liees au downdraft
+  ! =========================================
+  !cdir collapse
+  DO k=1,klev
+     DO j=1,klev
+        DO i=1,klon
+           zmd(i,j,k)=0.
+           za (i,j,k)=0.
+        END DO
+     END DO
+  END DO
+  ! calcul de la matrice d echange
+  ! matrice de distribution de la masse entrainee en k
+  ! commmentaire RomP : mp > 0
+  DO k=1,klev-1
+     DO i=1,klon
+        zmd(i,k,k)=max(0.,mp(i,k)-mp(i,k+1))   ! ~ mk(k)
+     END DO
+  END DO
+  DO k=2,klev
+     DO j=k-1,1,-1
+        DO i=1,klon
+           IF(mp(i,j+1).GT.1.e-10) THEN
+              zmd(i,j,k)=zmd(i,j+1,k)*min(1.,mp(i,j)/mp(i,j+1)) !det ~ mk(j)=mk(j+1)*mp(i,j)/mp(i,j+1)
+           ENDIF
+        END DO
+     END DO
+  END DO
+  DO k=1,klev
+     DO j=1,klev-1
+        DO i=1,klon
+           za(i,j,k)=max(0.,zmd(i,j+1,k)-zmd(i,j,k))
+        END DO
+     END DO
+  END DO
+!!!!! quantite  de traceur dans la descente d'air insaturee  :   4 juin 2012
+  DO k=1,klev
+     DO j=1,klev-1
+        DO i=1,klon
+           IF(mp(i,j+1).GT.1.e-10) THEN
+              qTrdi(i,j+1,it)=qTrdi(i,j+1,it)+(zmd(i,j+1,k)/mp(i,j+1))*tr(i,k,it)
+           ELSE
+              qTrdi(i,j,it)=0.!tr(i,j,it)
+           ENDIF
+        ENDDO
+     ENDDO
+  ENDDO
+!!!!!
+  !
+  ! rajout du terme lie a l ascendance induite
+  !
+  DO j=2,klev
+     DO i=1,klon
+        za(i,j,j-1)=za(i,j,j-1)+mp(i,j)
+     END DO
+  END DO
+  !
+  ! tendance courants insatures  ! sans lessivage ancien schema
+  !
+  DO k=1,klev
+     DO j=1,klev
+        DO i=1,klon
+           zmfd(i,j,it)=zmfd(i,j,it)+za(i,j,k)*(tr(i,k,it)-tr(i,j,it))
+        END DO
+     END DO
+  END DO
+  !
+  ! =========================================
+  ! calcul des tendances liees aux courants satures   j <-> z ; k <-> z'
+  ! =========================================
+  !RL
+  !  Feeding concentrations
+  DO j=1,klev
+     DO i=1,klon
+        qfeed(i,it)=qfeed(i,it)+wght_cvfd(i,j)*tr(i,j,it)
+     END DO
+  END DO
+  !RL
+  !
+  DO j=1,klev
+     DO i=1,klon
+        !RL
+        !!        zmfa(i,j,it)=da(i,j)*(tr(i,1,it)-tr(i,j,it))                     ! da
+        zmfa(i,j,it)=da(i,j)*(qfeed(i,it)-tr(i,j,it))                     ! da
+        !RL
+     END DO
+  END DO
+  !
+  DO k=1,klev
+     DO j=1,klev
+        DO i=1,klon
+           zmfp(i,j,it)=zmfp(i,j,it)+phi(i,j,k)*(tr(i,k,it)-tr(i,j,it))  ! phi
+        END DO
+     END DO
+  END DO
+  ! RomP ajout des matrices liees au lessivage
+  DO j=1,klev
+     DO i=1,klon
+        zmfd1a(i,j,it)=d1a(i,j)*tr(i,1,it)   ! da1
+        zmfdam(i,j,it)=dam(i,j)*tr(i,1,it)   ! dam
+     END DO
+  END DO
+  DO k=1,klev
+     DO j=1,klev
+        DO i=1,klon
+           zmfphi2(i,j,it)=zmfphi2(i,j,it)+phi2(i,j,k)*tr(i,k,it)  ! psi
+        END DO
+     END DO
+  END DO
+  DO j=1,klev-1
+     DO i=1,klon
+        zmfu(i,j,it)=max(0.,upd(i,j+1)+dnd(i,j+1))*(tr(i,j+1,it)-tr(i,j,it))
+     END DO
+  END DO
+  DO j=2,klev
+     DO i=1,klon
+        zmfu(i,j,it)=zmfu(i,j,it)+min(0.,upd(i,j)+dnd(i,j))*(tr(i,j,it)-tr(i,j-1,it))
+     END DO
+  END DO
+  ! ===================================================
+  ! calcul des tendances liees aux courants insatures
+  ! ===================================================
+  !  pression  
+  DO k=1, klev
+     DO i=1, klon
+        dxpres(i,k)=paprs(i,k)-paprs(i,k+1)
+     ENDDO
+  ENDDO
+  pdtimeRG=pdtime*RG
+
+  ! q_pa et q_pm    traceurs issues des courants satures se retrouvant dans les precipitations
+  DO j=1,klev
+     DO i=1,klon
+        IF(j.GE.icb(i).AND.j.LE.inb(i)) THEN
+           IF(clw(i,j).GT.1.e-16) THEN
+              !JE           qPa(i,j,it)=ccntrAA_coef*tr(i,1,it)/clw(i,j)
+              qPa(i,j,it)=ccntrAA_3d(i,j)*tr(i,1,it)/clw(i,j)
+           ELSE
+              qPa(i,j,it)=0.
+           ENDIF
+        ENDIF
+     END DO
+  END DO
+
+  ! calcul de q_pm en 2 parties :
+  ! 1) calcul de sa valeur pour un niveau z' donne
+  ! 2) integration sur la verticale sur z'
+  DO j=1,klev
+     DO k=1,j-1
+        DO i=1,klon
+           IF(k.GE.icb(i).AND.k.LE.inb(i).AND.& 
+                j.LE.inb(i)) THEN
+              IF(elij(i,k,j).GT.1.e-16) THEN
+                 !JE             qMeltmp(i,j,it)=((1-ep(i,k))*ccntrAA_coef*tr(i,1,it)&
+                 !JE                         *(1.-sij(i,k,j))  +ccntrENV_coef&
+                 !JE                         *tr(i,k,it)*sij(i,k,j)) / elij(i,k,j)
+                 qMeltmp(i,j,it)=((1-ep(i,k))*ccntrAA_3d(i,k)*tr(i,1,it)&
+                      *(1.-sij(i,k,j))  +ccntrENV_3d(i,k)&
+                      *tr(i,k,it)*sij(i,k,j)) / elij(i,k,j)
+              ELSE
+                 qMeltmp(i,j,it)=0.
+              ENDIF
+              qpmMint(i,j,it)=qpmMint(i,j,it) + qMeltmp(i,j,it)*epmlmMm(i,j,k)
+              Mint(i,j)=Mint(i,j) + epmlmMm(i,j,k)
+           ENDIF ! end if dans nuage
+        END DO
+     END DO
+  END DO
+
+  DO j=1,klev
+     DO i=1,klon
+        IF(Mint(i,j).GT.1.e-16) THEN
+           qMel(i,j,it)=qpmMint(i,j,it)/Mint(i,j)
+        ELSE
+           qMel(i,j,it)=0.
+        ENDIF
+     END DO
+  END DO
+
+  ! calcul de q_d et q_p    traceurs de la descente precipitante 
+  DO j=klev-1,1,-1
+     DO i=1,klon
+        IF(mp(i,j+1).GT.mp(i,j).AND.mp(i,j+1).GT.1.e-10) THEN  ! detrainement
+           kappa(i,j)=((pmflxr(i,j+1)+pmflxs(i,j+1)+Pa(i,j)+Pm(i,j))*&
+                (-mp(i,j+1)-imp(i,j)/RG*dxpres(i,j))&
+                + (imp(i,j)/RG*dxpres(i,j))*(evap(i,j)/RG*dxpres(i,j)))
+
+        ELSEIF(mp(i,j).GT.mp(i,j+1).AND.mp(i,j).GT.1.e-10) THEN! entrainement
+           IF(j.eq.1) THEN
+              kappa(i,j)=((pmflxr(i,j+1)+pmflxs(i,j+1)+Pa(i,j)+Pm(i,j))*&
+                   (-mp(i,2)-imp(i,j)/RG*dxpres(i,j))&
+                   + (imp(i,j)/RG*dxpres(i,j))*(evap(i,j)/RG*dxpres(i,j)))
+           ELSE
+              kappa(i,j)=((pmflxr(i,j+1)+pmflxs(i,j+1)+Pa(i,j)+Pm(i,j))*&
+                   (-mp(i,j)-imp(i,j)/RG*dxpres(i,j))&
+                   + (imp(i,j)/RG*dxpres(i,j))*(evap(i,j)/RG*dxpres(i,j)))
+           ENDIF
+        ELSE
+           kappa(i,j)=1.
+        ENDIF
+     ENDDO
+  ENDDO
+
+  DO j=klev-1,1,-1
+     DO i=1,klon
+        IF (abs(kappa(i,j)).LT.1.e-25) THEN    !si denominateur nul (il peut y avoir des mp!=0)
+           kappa(i,j)=1.
+           IF(j.eq.1) THEN
+              qDi(i,j,it)=qDi(i,j+1,it) !orig tr(i,j,it)   ! mp(1)=0 donc tout vient de la couche supérieure
+           ELSEIF(mp(i,j+1).GT.mp(i,j).AND.mp(i,j+1).GT.1.e-10) THEN
+              qDi(i,j,it)=qDi(i,j+1,it)
+           ELSEIF(mp(i,j).GT.mp(i,j+1).AND.mp(i,j).GT.1.e-10) THEN! entrainement
+              qDi(i,j,it)=(-mp(i,j+1)*(qDi(i,j+1,it)-tr(i,j,it))-mp(i,j)*tr(i,j,it))/(-mp(i,j))
+           ELSE  ! si  mp (i)=0 et mp(j+1)=0
+              qDi(i,j,it)=tr(i,j,it) ! orig 0.
+           ENDIF
+
+           IF(NO_precip(i,j)) THEN
+              qPr(i,j,it)=0.
+           ELSE
+              qPr(i,j,it)=((pmflxr(i,j+1)+pmflxs(i,j+1))*qPr(i,j+1,it)+&
+                   Pa(i,j)*qPa(i,j,it)+Pm(i,j)*qMel(i,j,it)&
+                   +imp(i,j)/RG*dxpres(i,j)*qDi(i,j,it))/&
+                   (pmflxr(i,j+1)+pmflxs(i,j+1)+Pa(i,j)+Pm(i,j))
+           ENDIF
+        ELSE   !     denominateur non nul
+           kappa(i,j)=1./kappa(i,j)     
+           ! calcul de qd et qp
+           !!jyg  (20130119) correction pour le sommet du nuage
+           !!     if(j.GE.inb(i)) THEN       !au-dessus du nuage, sommet inclu
+           if(j.GT.inb(i)) THEN       !au-dessus du nuage
+              qDi(i,j,it)=tr(i,j,it)   ! pas de descente => environnement = descente insaturee
+              qPr(i,j,it)=0.
+
+              !  vvv premiere couche du modele ou mp(1)=0  ! det tout le temps  vvv
+           ELSEIF(j.eq.1) THEN 
+              if(mp(i,2).GT.1.e-10) THEN !mp(2) non nul -> detrainement (car mp(1) = 0) !ent pas possible
+                 if(NO_precip(i,j)) THEN !pas de precip en (i)
+                    qDi(i,j,it)=qDi(i,j+1,it)
+                    qPr(i,j,it)=0.
+                 ELSE
+                    qDi(i,j,it)=kappa(i,j)*(&
+                         (-evap(i,j)/RG*dxpres(i,j))*((pmflxr(i,j+1)+pmflxs(i,j+1))*qPr(i,j+1,it)+&
+                         Pa(i,j)*qPa(i,j,it)+Pm(i,j)*qMel(i,j,it)) +&
+                         (pmflxr(i,j+1)+pmflxs(i,j+1)+Pa(i,j)+Pm(i,j))*&
+                         (-mp(i,j+1)*qDi(i,j+1,it)))
+
+                    qPr(i,j,it)=kappa(i,j)*(&
+                         (-mp(i,j+1)-imp(i,j)/RG*dxpres(i,j))*&
+                         ((pmflxr(i,j+1)+pmflxs(i,j+1))*qPr(i,j+1,it)+&
+                         Pa(i,j)*qPa(i,j,it)+Pm(i,j)*qMel(i,j,it))&
+                         +(-mp(i,j+1)*qDi(i,j+1,it)) * (imp(i,j)/RG*dxpres(i,j)))
+                 ENDIF
+
+              ELSE !mp(2) nul -> plus de descente insaturee -> pluie agit sur environnement
+                 qDi(i,j,it)=tr(i,j,it) ! orig 0.
+                 if(NO_precip(i,j)) THEN
+                    qPr(i,j,it)=0.
+                 ELSE
+                    qPr(i,j,it)=((pmflxr(i,j+1)+pmflxs(i,j+1))*qPr(i,j+1,it)+&
+                         Pa(i,j)*qPa(i,j,it)+Pm(i,j)*qMel(i,j,it)&
+                         +imp(i,j)/RG*dxpres(i,j)*tr(i,j,it))/&
+                         (pmflxr(i,j+1)+pmflxs(i,j+1)+Pa(i,j)+Pm(i,j))
+                 ENDIF
+
+              ENDIF  !mp(2) nul ou non
+
+              ! vvv  (j!=1.AND.j.LT.inb(i))  en-dessous du sommet nuage   vvv
+           ELSE 
+              !------------------------------------------------------------- detrainement 
+              if(mp(i,j+1).GT.mp(i,j).AND.mp(i,j+1).GT.1.e-10) THEN !mp(i,j).GT.1.e-10) THEN
+                 if(NO_precip(i,j)) THEN 
+                    qDi(i,j,it)=qDi(i,j+1,it)
+                    qPr(i,j,it)=0.
+                 ELSE
+                    qDi(i,j,it)=kappa(i,j)*(&
+                         (-evap(i,j)/RG*dxpres(i,j))*((pmflxr(i,j+1)+pmflxs(i,j+1))*qPr(i,j+1,it)+&
+                         Pa(i,j)*qPa(i,j,it)+Pm(i,j)*qMel(i,j,it)) +&
+                         (pmflxr(i,j+1)+pmflxs(i,j+1)+Pa(i,j)+Pm(i,j))*&
+                         (-mp(i,j+1)*qDi(i,j+1,it)))
+                    !
+                    qPr(i,j,it)=kappa(i,j)*(&
+                         (-mp(i,j+1)-imp(i,j)/RG*dxpres(i,j))*&
+                         ((pmflxr(i,j+1)+pmflxs(i,j+1))*qPr(i,j+1,it)+&
+                         Pa(i,j)*qPa(i,j,it)+Pm(i,j)*qMel(i,j,it))&
+                         +(-mp(i,j+1)*qDi(i,j+1,it)) * (imp(i,j)/RG*dxpres(i,j)))
+                 ENDIF !precip
+                 !------------------------------------------------------------- entrainement 
+              ELSEIF(mp(i,j).GT.mp(i,j+1).AND.mp(i,j).GT.1.e-10) THEN 
+                 if(NO_precip(i,j)) THEN
+                    qDi(i,j,it)=(-mp(i,j+1)*(qDi(i,j+1,it)-tr(i,j,it))-mp(i,j)*tr(i,j,it))/(-mp(i,j))
+                    qPr(i,j,it)=0.
+                 ELSE
+                    qDi(i,j,it)=kappa(i,j)*(&
+                         (-evap(i,j)/RG*dxpres(i,j))*((pmflxr(i,j+1)+pmflxs(i,j+1))*qPr(i,j+1,it)+&
+                         Pa(i,j)*qPa(i,j,it)+Pm(i,j)*qMel(i,j,it)) +&
+                         (pmflxr(i,j+1)+pmflxs(i,j+1)+Pa(i,j)+Pm(i,j))*&
+                         (-mp(i,j+1)*(qDi(i,j+1,it)-tr(i,j,it))-mp(i,j)*tr(i,j,it)))
+                    !
+                    qPr(i,j,it)=kappa(i,j)*(&
+                         (-mp(i,j)-imp(i,j)/RG*dxpres(i,j))*&
+                         ((pmflxr(i,j+1)+pmflxs(i,j+1))*qPr(i,j+1,it)+&
+                         Pa(i,j)*qPa(i,j,it)+Pm(i,j)*qMel(i,j,it))&
+                         +(-mp(i,j+1)*(qDi(i,j+1,it)-tr(i,j,it))-mp(i,j)*tr(i,j,it))*&
+                         (imp(i,j)/RG*dxpres(i,j)))
+                 ENDIF !precip
+                 !------------------------------------------------------------- ENDIF ! ent/det
+              ELSE  !mp nul
+                 qDi(i,j,it)=tr(i,j,it) ! orig 0.
+                 if(NO_precip(i,j)) THEN
+                    qPr(i,j,it)=0.
+                 ELSE
+                    qPr(i,j,it)=((pmflxr(i,j+1)+pmflxs(i,j+1))*qPr(i,j+1,it)+&
+                         Pa(i,j)*qPa(i,j,it)+Pm(i,j)*qMel(i,j,it)&
+                         +imp(i,j)/RG*dxpres(i,j)*tr(i,j,it))/&
+                         (pmflxr(i,j+1)+pmflxs(i,j+1)+Pa(i,j)+Pm(i,j))
+                 ENDIF
+              ENDIF ! mp nul ou non
+           ENDIF ! condition sur j
+        ENDIF ! kappa
+     ENDDO
+  ENDDO
+
+  !! print test descente insaturee
+  !  DO j=klev,1,-1
+  !   DO i=1,klon
+  !     if(it.eq.3) THEN
+  !   write(*,'(I2,2X,a,e20.12,2X,a,e20.12,2X,a,e20.12,2X,a,e20.12,2X,a,e20.12,2X,a,e20.12,2X,a,e20.12)') j,&
+  !!         'zmfdam',zmfdam(i,j,it),'zmfpsi',zmfphi2(i,j,it),&
+  !          'zmfdam+zmfpsi',zmfdam(i,j,it)+zmfphi2(i,j,it),'qpmMint',qpmMint(i,j,it),&
+  !          'Pm',Pm(i,j),'Mint',Mint(i,j),&
+  !!          'zmfa',zmfa(i,j,it),'zmfp',zmfp(i,j,it),&
+  !        'zmfdam',zmfdam(i,j,it),'zmfpsi',zmfphi2(i,j,it),'zmfd1a',zmfd1a(i,j,it)
+  !!          'Pa',Pa(i,j),'eplaMm',eplaMm(i,j)
+  !!         'zmfd1a=da1*qa',zmfd1a(i,j,it),'Pa*qPa',wdtrainA(i,j)*qPa(i,j,it),'da1',d1a(i,j)
+  !     ENDIF
+  !   ENDDO
+  !  ENDDO
+
+
+  ! ===================================================
+  ! calcul final des tendances
+  ! ===================================================
+
+  DO k=klev-1,1,-1
+     DO i=1, klon
+        ! transport
+        tdcvMA=zmfd(i,k,it)+zmfu(i,k,it)+zmfa(i,k,it)+zmfp(i,k,it)   ! double comptage des downdraft insatures
+        trsptrac=zmfu(i,k,it)+zmfa(i,k,it)+zmfp(i,k,it)
+        ! lessivage courants satures
+        !JE     scavtrac=-ccntrAA_coef*zmfd1a(i,k,it)&
+        !JE               -zmfphi2(i,k,it)*ccntrENV_coef&
+        !JE               -zmfdam(i,k,it)*ccntrAA_coef
+        scavtrac=-ccntrAA_3d(i,k)*zmfd1a(i,k,it)&
+             -zmfphi2(i,k,it)*ccntrENV_3d(i,k)&
+             -zmfdam(i,k,it)*ccntrAA_3d(i,k)
+        ! lessivage courants insatures
+        if(k.LE.inb(i).AND.k.GT.1) THEN   ! tendances dans le nuage
+           !------------------------------------------------------------- detrainement
+           if(mp(i,k+1).GT.mp(i,k).AND.mp(i,k+1).GT.1.e-10) THEN
+              uscavtrac= (-mp(i,k)+mp(i,k+1))*(qDi(i,k,it)-tr(i,k,it))&
+                   + mp(i,k)*(tr(i,k-1,it)-tr(i,k,it))
+              !
+              !        if(it.eq.3) write(*,'(I2,1X,a,5X,e20.12,82X,a,e20.12)')k,' det incloud',&
+              !                    (-mp(i,k)+mp(i,k+1))*(qDi(i,k,it)-tr(i,k,it))*pdtimeRG/dxpres(i,k)+&
+              !                    mp(i,k)*(tr(i,k-1,it)-tr(i,k,it))*pdtimeRG/dxpres(i,k),&
+              !                    'mp',mp(i,k)
+              !------------------------------------------------------------- entrainement 
+           ELSEIF(mp(i,k).GT.mp(i,k+1).AND.mp(i,k).GT.1.e-10) THEN
+              uscavtrac= mp(i,k)*(tr(i,k-1,it)-tr(i,k,it))
+              !
+              !         if(it.eq.3) write(*,'(I2,1X,a,5X,e20.12,82X,a,e20.12)')k,' ent incloud',uscavtrac*pdtimeRG/dxpres(i,k), 'mp',mp(i,k)
+              !=!------------------------------------------------------------- end ent/det 
+           ELSE !        mp(i,k+1)=0. et mp(i,k)=0.    pluie directement sur l environnement
+
+              if(NO_precip(i,k)) THEN
+                 uscavtrac=0.
+                 !         if(it.eq.3) write(*,'(I2,1X,a,e20.12,82X,a,e20.12)')k,' no P ent incloud',uscavtrac*pdtimeRG/dxpres(i,k), 'mp',mp(i,k)
+              ELSE
+                 uscavtrac=-imp(i,k)*tr(i,k,it)*dxpres(i,k)/RG+evap(i,k)*qPr(i,k,it)*dxpres(i,k)/RG
+                 !         if(it.eq.3) write(*,'(I2,1X,a,3X,e20.12,82X,a,e20.12)')k,' P env incloud',uscavtrac*pdtimeRG/dxpres(i,k), 'mp',mp(i,k)
+                 !!JE adds
+                 !         if(it.eq.3) write(*,'(I2,1X,a,3X,e20.12,82X,a,e20.12)')k,' P env incloud',uscavtrac, 'imp',imp(i,k)
+                 !         if(it.eq.3) write(*,'(I2,1X,a,3X,e20.12,82X,a,e20.12)')k,' P env incloud',uscavtrac, 'tr',tr(i,k,it)
+                 !         if(it.eq.3) write(*,'(I2,1X,a,3X,e20.12,82X,a,e20.12)')k,' P env incloud',uscavtrac, 'evap',evap(i,k)
+                 !         if(it.eq.3) write(*,'(I2,1X,a,3X,e20.12,82X,a,e20.12)')k,' P env incloud',uscavtrac, 'qPr',qPr(i,k,it)
+                 !         if(it.eq.3) write(*,'(I2,1X,a,3X,e20.12,82X,a,e20.12)')k,' P env incloud',uscavtrac, 'dxpres',dxpres(i,k)
+                 !!Je end
+
+              ENDIF
+           ENDIF  ! mp/det/ent
+           !------------------------------------------------------------- premiere couche 
+        ELSEIF(k.eq.1) THEN  !                                      mp(1)=0.
+           if(mp(i,2).GT.1.e-10) THEN  !detrainement
+              uscavtrac= (-0.+mp(i,2))*(qDi(i,k,it)-tr(i,k,it)) !&
+              !                   + mp(i,2)*(0.-tr(i,k,it))
+              !
+              !       if(it.eq.3) write(*,'(I2,1X,a,e20.12,84X,a,e20.12)')k,' 1 det',&
+              !                  (-0.+mp(i,2))*(qDi(i,k,it)-tr(i,k,it))*pdtimeRG/dxpres(i,k)+&
+              !                  mp(i,2)*(0.-tr(i,k,it))*pdtimeRG/dxpres(i,k),&
+              !                   'mp',mp(i,k)
+           ELSE   ! mp(2) = 0 = mp(1) pas de descente insaturee, rien ne se passe s'il ne pleut pas, sinon pluie->env
+              if(NO_precip(i,1)) THEN
+                 uscavtrac=0.
+              ELSE
+                 uscavtrac=-imp(i,k)*tr(i,k,it)*dxpres(i,k)/RG+evap(i,k)*qPr(i,k,it)*dxpres(i,k)/RG
+              ENDIF
+              !         if(it.eq.3) write(*,'(I2,1X,a,2X,e20.12,82X,a,e20.12)')k,'1 P env incloud',uscavtrac*pdtimeRG/dxpres(i,k), 'mp',mp(i,k)
+           ENDIF
+
+        ELSE   ! k > INB  au-dessus du nuage
+           uscavtrac=0.
+        ENDIF
+
+        ! =====    tendances finales  ======
+        trsptd(i,k,it)=trsptrac*pdtimeRG/dxpres(i,k)              ! td transport sans eau dans courants satures
+        dtrSscav(i,k,it)=scavtrac*pdtimeRG/dxpres(i,k)            ! td du lessivage dans courants satures
+        dtrUscav(i,k,it)=uscavtrac*pdtimeRG/dxpres(i,k)           ! td courant insat
+        dtrsat(i,k,it)=(trsptrac+scavtrac)*pdtimeRG/dxpres(i,k)   ! td courant sat
+        dtrcv(i,k,it)=(trsptrac+scavtrac+uscavtrac)*pdtimeRG/dxpres(i,k)!dtrsat(i,k,it)+dtrUscav(i,k,it)         td conv
+!!!!!!
+        dtrcvMA(i,k,it)=tdcvMA*pdtimeRG/dxpres(i,k) ! MA tendance convection
+     ENDDO
+  ENDDO
+
+  ! test de conservation du traceur
+  !print*,"_____________________________________________________________"
+  !print*,"                                                             "
+  !      conserv=0.
+  !      conservMA=0.
+  !      DO k= klev-1,1,-1
+  !        DO i=1, klon
+  !         conserv=conserv+dtrcv(i,k,it)*   &
+  !        (paprs(i,k)-paprs(i,k+1))/RG
+  !         conservMA=conservMA+dtrcvMA(i,k,it)*   &
+  !        (paprs(i,k)-paprs(i,k+1))/RG
+  !
+  !      if(it.eq.3)  write(*,'(I2,2X,a,e20.12,2X,a,e20.12,2X,a,e20.12,2X,a,e20.12)') k,&
+  !         'MA td ',dtrcvMA(i,k,it)*dxpres(i,k)/RG,&
+  !         ' td',dtrcv(i,k,it)*dxpres(i,k)/RG,'         conservMA ',conservMA,'conserv ',conserv
+  !!
+  !        ENDDO
+  !      ENDDO
+  !       if(it.eq.3) print *,'it',it,'conserv ',conserv,'conservMA ',conservMA
+
+END SUBROUTINE cvltr_scav
Index: DZ6/trunk/libf/phylmd/cvltr_spl.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cvltr_spl.F90	(revision 5267)
+++ 	(revision )
@@ -1,841 +1,0 @@
-!
-! $Id $
-!
-SUBROUTINE cvltr_spl(pdtime, da, phi,phi2,d1a,dam, mpIN,epIN, &
-           sigd,sij,wght_cvfd,clw,elij,epmlmMm,eplaMm,              &
-           pmflxrIN,pmflxsIN,ev,te,wdtrainA,wdtrainM,     &
-           paprs,it,tr,upd,dnd,inb,icb,                   &
-           kk,henry,zrho, ccntrAA_spla,ccntrENV_spla,coefcoli_spla, &
-           id_prec,id_fine,id_coss, id_codu, id_scdu, &
-           dtrcv,trsptd,dtrSscav,dtrsat,dtrUscav,qDi,qPr, &
-           qPa,qMel,qTrdi,dtrcvMA,Mint,                   &
-           zmfd1a,zmfphi2,zmfdam)
-  USE IOIPSL 
-  USE dimphy
-  USE infotrac_phy, ONLY : nbtr
-  IMPLICIT NONE 
-!=====================================================================
-! Objet : convection des traceurs / KE
-! Auteurs: M-A Filiberti and J-Y Grandpeix
-! modifiee par R Pilon : lessivage des traceurs / KE
-!=====================================================================
-
-  include "YOMCST.h"
-  include "YOECUMF.h"
-  include "conema3.h"
-  include "chem.h"
-
-! Entree
-  REAL,INTENT(IN)                           :: pdtime
-  REAL,DIMENSION(klon,klev),INTENT(IN)      :: da
-  REAL,DIMENSION(klon,klev,klev),INTENT(IN) :: phi
-! RomP
-  REAL,DIMENSION(klon,klev),INTENT(IN)      :: d1a,dam ! matrices pour simplifier
-  REAL,DIMENSION(klon,klev,klev),INTENT(IN) :: phi2    ! l'ecriture des tendances
-!
-  REAL,DIMENSION(klon,klev),INTENT(IN)      :: mpIN
-  REAL,DIMENSION(klon,klev+1),INTENT(IN)    :: paprs  ! pression aux 1/2 couches (bas en haut)
-!  REAL,DIMENSION(klon,klev),INTENT(IN)    :: pplay ! pression aux 1/2 couches (bas en haut)
-  REAL,DIMENSION(klon,klev,nbtr),INTENT(IN) :: tr     ! q de traceur (bas en haut)
-  INTEGER,INTENT(IN)                        :: it 
-  REAL,DIMENSION(klon,klev),INTENT(IN)      :: upd   ! saturated updraft mass flux
-  REAL,DIMENSION(klon,klev),INTENT(IN)      :: dnd   ! saturated downdraft mass flux
-!
-  REAL,DIMENSION(klon,klev),INTENT(IN)      :: wdtrainA   ! masses precipitantes de l'asc adiab
-  REAL,DIMENSION(klon,klev),INTENT(IN)      :: wdtrainM   ! masses precipitantes des melanges
-!JE  REAL,DIMENSION(klon,klev),INTENT(IN)      :: pmflxrIN   ! vprecip: eau
-  REAL,DIMENSION(klon,klev+1),INTENT(IN)      :: pmflxrIN   ! vprecip: eau
-!JE  REAL,DIMENSION(klon,klev),INTENT(IN)      :: pmflxsIN   ! vprecip: neige
-  REAL,DIMENSION(klon,klev+1),INTENT(IN)      :: pmflxsIN   ! vprecip: neige
-  REAL,DIMENSION(klon,klev),INTENT(IN)      :: ev         ! evaporation cv30_routine
-  REAL,DIMENSION(klon,klev),INTENT(IN)      :: epIN
-  REAL,DIMENSION(klon,klev),INTENT(IN)      :: te 
-  REAL,DIMENSION(klon,klev,klev),INTENT(IN) :: sij        ! fraction dair de lenv
-  REAL,DIMENSION(klon,klev),INTENT(IN)      :: wght_cvfd  ! weights of the layers feeding convection
-  REAL,DIMENSION(klon,klev,klev),INTENT(IN) :: elij       ! contenu en eau condensée spécifique/conc deau condensée massique
-  REAL,DIMENSION(klon,klev,klev),INTENT(IN) :: epmlmMm    ! eau condensee precipitee dans mel masse dair sat
-  REAL,DIMENSION(klon,klev),INTENT(IN)      :: eplaMm    ! eau condensee precipitee dans aa masse dair sat
-
-  REAL,DIMENSION(klon,klev),INTENT(IN)      :: clw        ! contenu en eau condensée dans lasc adiab
-  REAL,DIMENSION(klon),INTENT(IN)           :: sigd
-  INTEGER,DIMENSION(klon),INTENT(IN)        :: icb,inb
-! Sortie
-  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)     :: dtrcv     ! tendance totale (bas en haut)
-  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)     :: dtrcvMA ! M-A Filiberti
-  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)     :: trsptd    ! tendance du transport 
-  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)     :: dtrSscav  ! tendance du lessivage courant sat
-  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)     :: dtrsat    ! tendance trsp+sat scav
-  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)     :: dtrUscav  ! tendance du lessivage courant unsat
-!
-! Variables locales
-  INTEGER                           :: i,j,k
-  REAL,DIMENSION(klon,klev)         :: dxpres   ! difference de pression entre niveau (j+1) et (j)
-  REAL                              :: pdtimeRG ! pas de temps * gravite
-  REAL,DIMENSION(klon,nbtr)         :: qfeed     ! tracer concentration feeding convection
-! variables pour les courants satures
-  REAL,DIMENSION(klon,klev,klev)    :: zmd
-  REAL,DIMENSION(klon,klev,klev)    :: za
-  REAL,DIMENSION(klon,klev,nbtr)    :: zmfd,zmfa
-  REAL,DIMENSION(klon,klev,nbtr)    :: zmfp,zmfu
-
-  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)    :: zmfd1a
-  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)    :: zmfdam
-  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)    :: zmfphi2
-
-! RomP ! les variables sont nettoyees des valeurs aberrantes
-  REAL,DIMENSION(klon,klev)         :: Pa, Pm  ! pluie AA et mélanges, var temporaire
-  REAL,DIMENSION(klon,klev)         :: pmflxs,pmflxr ! pmflxrIN,pmflxsIN sans valeur aberante
-  REAL,DIMENSION(klon,klev)         :: mp            ! flux de masse
-  REAL,DIMENSION(klon,klev)         :: ep            ! fraction d'eau convertie en precipitation 
-  REAL,DIMENSION(klon,klev)         :: evap          ! evaporation : variable temporaire 
-  REAL,DIMENSION(klon,klev)         :: rho    !environmental density
-
-  REAL,DIMENSION(klon,klev)         :: kappa ! denominateur du au calcul de la matrice 
-                                             ! pour obtenir qd et qp
-  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)    :: qTrdi ! traceurs descente air insature transport MA
-  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)    :: qDi  ! traceurs descente insaturees
-  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)    :: qPr  ! traceurs colonne precipitante
-  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)    :: qPa  ! traceurs dans les precip issues lasc. adiab.
-  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)    :: qMel ! traceurs dans les precip issues des melanges
-  REAL,DIMENSION(klon,klev,nbtr)                :: qMeltmp ! variable temporaire 
-  REAL,DIMENSION(klon,klev,nbtr)                :: qpmMint
-  REAL,DIMENSION(klon,klev),INTENT(OUT)         :: Mint
-! tendances
-  REAL                              :: tdcvMA           ! terme de transport de traceur (schema Marie Angele)
-  REAL                              :: trsptrac         ! terme de transport de traceur par l'air
-  REAL                              :: scavtrac         ! terme de lessivage courant sature
-  REAL                              :: uscavtrac        ! terme de lessivage courant insature
-! impaction
-!!!       Correction apres discussion Romain P. / Olivier B. 
-!!!  REAL,PARAMETER                    :: rdrop=2.5e-3     ! rayon des gouttes d'eau
-  REAL,PARAMETER                    :: rdrop=1.e-3     ! rayon des gouttes d'eau 
-!!!
-  REAL,DIMENSION(klon,klev)         :: imp              ! coefficient d'impaction
-! parametres lessivage
-  REAL                    :: ccntrAA_coef        ! \alpha_a : fract aerosols de l'AA convertis en CCN
-  REAL                    :: ccntrENV_coef       ! \beta_m  : fract aerosols de l'env convertis en CCN
-  REAL                    :: coefcoli            ! coefficient de collision des gouttes sur les aerosols
-!
-  LOGICAL,DIMENSION(klon,klev) :: NO_precip
-!  LOGICAL                      :: scavON
-! var tmp tests
-  REAL                           :: conserv
-  real                           :: conservMA
-! JE SPLA adaptation
-
-   INTEGER :: id_prec,id_fine,id_coss, id_codu, id_scdu
-   REAL,DIMENSION(nbtr) :: ccntrAA_spla,ccntrENV_spla,coefcoli_spla
-   REAL,DIMENSION(klon,klev) :: ccntrAA_coef3d
-   REAL,DIMENSION(klon,klev) :: ccntrENV_coef3d
-   REAL,DIMENSION(klon,klev) :: coefcoli3d
-
-   REAL,DIMENSION(nbtr) :: henry         !--cste de Henry  mol/l/atm
-   REAL,DIMENSION(nbtr) :: kk            !--coefficient de var avec T (K)
-   REAL :: henry_t !--constante de Henry a T t  (mol/l/atm)
-   REAL :: f_a     !--rapport de la phase aqueuse a la phase gazeuse
-
-   REAL, PARAMETER :: ph=5.
-   REAL ::  K1, K2
-   REAL,DIMENSION(klon,klev) :: zrho
-   REAL, PARAMETER :: qliq=1.e-3 ! CONVECTIVE ONLY 
-
-! Je end 20140105
-
-!JE20140724<<
-!JE SPLA adapt:
-!
-!
-!! coefficient lessivage
-!   ccntrAA_coef     = 0.
-!   ccntrENV_coef    = 0.
-!   coefcoli         = 0.
-!
-!!$OMP MASTER
-!  call getin('ccntrAA_coef',ccntrAA_coef)
-!  call getin('ccntrENV_coef',ccntrENV_coef)
-!  call getin('coefcoli',coefcoli)
-!!$OMP END MASTER
-!!$OMP BARRIER
-!!! JE
-!  do j=1,klev
-!   do i=1,klon
-!     imp(i,j)=0.
-!     ccntrAA_coef3d(i,j)=ccntrAA_coef
-!     ccntrENV_coef3d(i,j)=ccntrENV_coef
-!     coefcoli3d(i,j)=coefcoli
-!   enddo
-!  enddo
-!
-!
-!!! for SPLA
-!!!JEend
-!  print*,'cvltr coef lessivage convectif', ccntrAA_coef,ccntrENV_coef,coefcoli
-!
-!JE20140724>>
-
-!  scavON=.TRUE.
-!  if(scavON) then
-!   ccntrAA_coef     = 1.
-!   ccntrENV_coef    = 1.
-!   coefcoli         = 1.
-!  else
-!   ccntrAA_coef     = 0.
-!   ccntrENV_coef    = 0.
-!   coefcoli         = 0.
-!  endif
-
-! ======================================================
-! calcul de l'impaction
-! ======================================================
-!initialisation
-  do j=1,klev
-   do i=1,klon
-     imp(i,j)=0.
-   enddo
-  enddo
-!JE init 20140103 
-!! impaction sur la surface de la colonne de la descente insaturee
-!! On prend la moyenne des precip entre le niveau i+1 et i
-!! I=3/4* (P(1+1)+P(i))/2 / (sigd*r*rho_l)
-!!  1000kg/m3= densité de l'eau
-!! 0.75e-3 = 3/4 /1000
-!! Par la suite, I est tout le temps multiplié par sig_d pour avoir l'impaction sur la surface de la maille
-!! on le néglige ici pour simplifier le code
-!  do j=1,klev-1
-!   do i=1,klon
-!    imp(i,j) = coefcoli*0.75e-3/rdrop *&
-!             0.5*(pmflxr(i,j+1)+pmflxs(i,j+1)+pmflxr(i,j)+pmflxs(i,j))
-!!    rho(i,j)=pplay(i,j)/(rd*te(i,j))
-!   enddo
-!  enddo
-!JE end 20140103
-
-!
-! initialisation pour flux de traceurs, td et autre
-   trsptrac = 0.
-   scavtrac = 0.
-   uscavtrac = 0.
-   qfeed(:,it) = 0.              !RL
-  DO j=1,klev
-   DO i=1,klon
-    zmfd(i,j,it)=0.
-    zmfa(i,j,it)=0.
-    zmfu(i,j,it)=0.
-    zmfp(i,j,it)=0.
-    zmfphi2(i,j,it)=0.
-    zmfd1a(i,j,it)=0.
-    zmfdam(i,j,it)=0.
-    qDi(i,j,it)=0.
-    qPr(i,j,it)=0.
-    qPa(i,j,it)=0.
-    qMel(i,j,it)=0.
-    qMeltmp(i,j,it)=0.
-    qTrdi(i,j,it)=0.
-    kappa(i,j)=0.
-    trsptd(i,j,it)=0.
-    dtrsat(i,j,it)=0.
-    dtrSscav(i,j,it)=0.
-    dtrUscav(i,j,it)=0.
-    dtrcv(i,j,it)=0.
-    dtrcvMA(i,j,it)=0.
-    evap(i,j)=0.
-    dxpres(i,j)=0.
-    qpmMint(i,j,it)=0.
-    Mint(i,j)=0.
-   END DO
-  END DO
-
-! suppression des valeurs très faibles (~1e-320)
-! multiplication de levaporation pour lavoir par unite de temps
-! et par unite de surface de la maille
-! -> cv30_unsat : evap : masse evaporee/s/(m2 de la descente)
-  DO j=1,klev
-   DO i=1,klon
-    if(ev(i,j).lt.1.e-16) then
-     evap(i,j)=0.
-    else
-     evap(i,j)=ev(i,j)*sigd(i)
-    endif
-   END DO
-  END DO
-
-  DO j=1,klev
-   DO i=1,klon
-   if(j.lt.klev) then
-    if(epIN(i,j).lt.1.e-32) then
-     ep(i,j)=0.
-    else
-     ep(i,j)=epIN(i,j)
-    endif
-   else
-    ep(i,j)=epmax
-   endif
-    if(mpIN(i,j).lt.1.e-32) then
-     mp(i,j)=0.
-    else
-     mp(i,j)=mpIN(i,j)
-    endif
-    if(pmflxsIN(i,j).lt.1.e-32) then
-     pmflxs(i,j)=0.
-    else
-     pmflxs(i,j)=pmflxsIN(i,j)
-    endif
-    if(pmflxrIN(i,j).lt.1.e-32) then
-     pmflxr(i,j)=0.
-    else
-     pmflxr(i,j)=pmflxrIN(i,j)
-    endif
-    if(wdtrainA(i,j).lt.1.e-32) then
-     Pa(i,j)=0.
-    else
-     Pa(i,j)=wdtrainA(i,j)
-    endif
-    if(wdtrainM(i,j).lt.1.e-32) then
-     Pm(i,j)=0.
-    else
-     Pm(i,j)=wdtrainM(i,j)
-    endif
-   END DO
-  END DO
-
-!==========================================
-  DO j = klev-1,1,-1
-   DO i = 1,klon
-     NO_precip(i,j) = (pmflxr(i,j+1)+pmflxs(i,j+1)).lt.1.e-10&
-                    .and.Pa(i,j).lt.1.e-10.and.Pm(i,j).lt.1.e-10
-   END DO
-  END DO
-!==============================================================================
-! JE SPLA: Calc of ccntrAA_coef,ccntrENV_coef, coefcoli for SPLA aerosols and
-! precursors. From SPLA code inscav_spl.F 
-!print *,'Using SPLA values for cvltr_spl ccntr and coefcoli params'
-!
-!
-!IF (it.EQ.2) THEN !--fine aerosol
-!  DO j=1,klev
-!   DO i=1,klon
-!    ccntrAA_coef3d(i,j)=0.7
-!    ccntrENV_coef3d(i,j)=0.7
-!    coefcoli3d(i,j)=0.001
-!   ENDDO
-!  ENDDO
-!ELSEIF (it.EQ.3) THEN !-- Coarse Sea salt aerosol
-!  DO j=1,klev
-!   DO i=1,klon
-!    ccntrAA_coef3d(i,j)=1.0
-!    ccntrENV_coef3d(i,j)=1.0
-!    coefcoli3d(i,j)=0.001
-!   ENDDO
-!  ENDDO
-!
-!ELSEIF (it.EQ.4) THEN !--Coarse Dust aerosol
-!  DO j=1,klev
- !  DO i=1,klon
-!    ccntrAA_coef3d(i,j)=0.7
-!    ccntrENV_coef3d(i,j)=0.7
-!    coefcoli3d(i,j)=0.001
-!
-!   ENDDO
-!  ENDDO
-! Gas precursor: Henry's law
-
-IF (it .EQ. id_prec) THEN
-      DO k=1, klev
-      DO i=1, klon
-        henry_t=henry(it)*exp(-kk(it)*(1./298.-1./te(i,k)))    !--mol/l/atm
-        K1=1.2e-2*exp(-2010*(1/298.-1/te(i,k)))
-        K2=6.6e-8*exp(-1510*(1/298.-1/te(i,k)))
-        henry_t=henry_t*(1. + K1/10.**(-ph) + K1*K2/(10.**(-ph))**2)
-        f_a=henry_t/101.325*R*te(i,k)*qliq*zrho(i,k)/rho_water
- !       scav(i,k)=f_a/(1.+f_a)
-        ccntrAA_coef3d(i,k)= f_a/(1.+f_a)
-        ccntrENV_coef3d(i,k)= f_a/(1.+f_a)
-        coefcoli3d(i,k)=0.0
-      ENDDO
-      ENDDO
- !    CALL minmaxqfi2(clw,1.e33,-1.e33,'minmax clw')
-ELSE
-  DO j=1,klev
-   DO i=1,klon
-    ccntrAA_coef3d(i,j)=ccntrAA_spla(it)
-    ccntrENV_coef3d(i,j)=ccntrENV_spla(it)
-    coefcoli3d(i,j)=coefcoli_spla(it)
-   ENDDO
-  ENDDO
-
-
-ENDIF
-
-! JE end SPLA modifs in ccn parameters
-!==============================================================================
-
-
-
-
-!JE init 20140103
-! impaction sur la surface de la colonne de la descente insaturee
-! On prend la moyenne des precip entre le niveau i+1 et i
-! I=3/4* (P(1+1)+P(i))/2 / (sigd*r*rho_l)
-!  1000kg/m3= densité de l'eau
-! 0.75e-3 = 3/4 /1000
-! Par la suite, I est tout le temps multiplié par sig_d pour avoir l'impaction sur la surface de la maille
-! on le néglige ici pour simplifier le code
-  do j=1,klev-1
-   do i=1,klon
-!JE    imp(i,j) = coefcoli*0.75e-3/rdrop *&
-!JE             0.5*(pmflxr(i,j+1)+pmflxs(i,j+1)+pmflxr(i,j)+pmflxs(i,j))
-    imp(i,j) = coefcoli3d(i,j)*0.75e-3/rdrop *&
-             0.5*(pmflxr(i,j+1)+pmflxs(i,j+1)+pmflxr(i,j)+pmflxs(i,j))
-!    rho(i,j)=pplay(i,j)/(rd*te(i,j))
-   enddo
-  enddo
-!JE end 20140103
-
-
-! =========================================
-! calcul des tendances liees au downdraft
-! =========================================
-!cdir collapse
-  DO k=1,klev
-   DO j=1,klev
-    DO i=1,klon
-     zmd(i,j,k)=0.
-     za (i,j,k)=0.
-    END DO
-   END DO
-  END DO
-! calcul de la matrice d echange
-! matrice de distribution de la masse entrainee en k
-! commmentaire RomP : mp > 0
-  DO k=1,klev-1
-     DO i=1,klon
-        zmd(i,k,k)=max(0.,mp(i,k)-mp(i,k+1))   ! ~ mk(k)
-     END DO
-  END DO
-  DO k=2,klev
-     DO j=k-1,1,-1
-        DO i=1,klon
-           if(mp(i,j+1).gt.1.e-10) then
-              zmd(i,j,k)=zmd(i,j+1,k)*min(1.,mp(i,j)/mp(i,j+1)) !det ~ mk(j)=mk(j+1)*mp(i,j)/mp(i,j+1)
-           ENDif
-        END DO
-     END DO
-  END DO
-  DO k=1,klev
-     DO j=1,klev-1
-        DO i=1,klon
-           za(i,j,k)=max(0.,zmd(i,j+1,k)-zmd(i,j,k))
-        END DO
-     END DO
-  END DO
-!!!!! quantite  de traceur dans la descente d'air insaturee  :   4 juin 2012
-  DO k=1,klev
-     DO j=1,klev-1
-        DO i=1,klon
-        if(mp(i,j+1).gt.1.e-10) then
-          qTrdi(i,j+1,it)=qTrdi(i,j+1,it)+(zmd(i,j+1,k)/mp(i,j+1))*tr(i,k,it)
-        else
-          qTrdi(i,j,it)=0.!tr(i,j,it)
-        endif
-        ENDDO
-     ENDDO
-  ENDDO
-!!!!!
-!
-! rajout du terme lie a l ascendance induite
-!
-  DO j=2,klev
-     DO i=1,klon
-        za(i,j,j-1)=za(i,j,j-1)+mp(i,j)
-     END DO
-  END DO
-!
-! tendance courants insatures  ! sans lessivage ancien schema
-!
-  DO k=1,klev
-     DO j=1,klev
-        DO i=1,klon
-           zmfd(i,j,it)=zmfd(i,j,it)+za(i,j,k)*(tr(i,k,it)-tr(i,j,it))
-        END DO
-     END DO
-  END DO
-!
-! =========================================
-! calcul des tendances liees aux courants satures   j <-> z ; k <-> z'
-! =========================================
-!RL
-!  Feeding concentrations
-  DO j=1,klev
-     DO i=1,klon
-        qfeed(i,it)=qfeed(i,it)+wght_cvfd(i,j)*tr(i,j,it)
-     END DO
-  END DO
-!RL
-!
-  DO j=1,klev
-     DO i=1,klon
-!RL
-!!        zmfa(i,j,it)=da(i,j)*(tr(i,1,it)-tr(i,j,it))                     ! da
-        zmfa(i,j,it)=da(i,j)*(qfeed(i,it)-tr(i,j,it))                     ! da
-!RL
-     END DO
-  END DO
-!
-  DO k=1,klev
-     DO j=1,klev
-        DO i=1,klon
-           zmfp(i,j,it)=zmfp(i,j,it)+phi(i,j,k)*(tr(i,k,it)-tr(i,j,it))  ! phi
-        END DO
-     END DO
-  END DO
-! RomP ajout des matrices liees au lessivage
-  DO j=1,klev
-     DO i=1,klon
-        zmfd1a(i,j,it)=d1a(i,j)*tr(i,1,it)   ! da1
-        zmfdam(i,j,it)=dam(i,j)*tr(i,1,it)   ! dam
-     END DO
-  END DO
-  DO k=1,klev
-     DO j=1,klev
-        DO i=1,klon
-          zmfphi2(i,j,it)=zmfphi2(i,j,it)+phi2(i,j,k)*tr(i,k,it)  ! psi
-        END DO
-     END DO
-  END DO
-  DO j=1,klev-1
-     DO i=1,klon
-        zmfu(i,j,it)=max(0.,upd(i,j+1)+dnd(i,j+1))*(tr(i,j+1,it)-tr(i,j,it))
-     END DO
-  END DO
-  DO j=2,klev
-     DO i=1,klon
-        zmfu(i,j,it)=zmfu(i,j,it)+min(0.,upd(i,j)+dnd(i,j))*(tr(i,j,it)-tr(i,j-1,it))
-     END DO
-  END DO
-! ===================================================
-! calcul des tendances liees aux courants insatures
-! ===================================================
-!  pression  
-  DO k=1, klev
-     DO i=1, klon
-        dxpres(i,k)=paprs(i,k)-paprs(i,k+1)
-     ENDDO
-  ENDDO
-  pdtimeRG=pdtime*RG
-
-! q_pa et q_pm    traceurs issues des courants satures se retrouvant dans les precipitations
-  DO j=1,klev
-     DO i=1,klon
-        if(j.ge.icb(i).and.j.le.inb(i)) then
-          if(clw(i,j).gt.1.e-16) then
-!           qPa(i,j,it)=ccntrAA_coef*tr(i,1,it)/clw(i,j)
-           qPa(i,j,it)=ccntrAA_coef3d(i,j)*tr(i,1,it)/clw(i,j)
-          else
-           qPa(i,j,it)=0.
-          endif
-        endif
-     END DO
-  END DO
-
-! calcul de q_pm en 2 parties :
-! 1) calcul de sa valeur pour un niveau z' donne
-! 2) integration sur la verticale sur z'
-     DO j=1,klev
-      DO k=1,j-1
-        DO i=1,klon
-        if(k.ge.icb(i).and.k.le.inb(i).and.& 
-           j.le.inb(i)) then
-            if(elij(i,k,j).gt.1.e-16) then
-!JE             qMeltmp(i,j,it)=((1-ep(i,k))*ccntrAA_coef*tr(i,1,it)&
-!JE                         *(1.-sij(i,k,j))  +ccntrENV_coef&
-!JE                         *tr(i,k,it)*sij(i,k,j)) / elij(i,k,j)
-             qMeltmp(i,j,it)=((1-ep(i,k))*ccntrAA_coef3d(i,k)*tr(i,1,it)&
-                         *(1.-sij(i,k,j))  +ccntrENV_coef3d(i,k)&
-                         *tr(i,k,it)*sij(i,k,j)) / elij(i,k,j)
-            else
-             qMeltmp(i,j,it)=0.
-            endif
-          qpmMint(i,j,it)=qpmMint(i,j,it) + qMeltmp(i,j,it)*epmlmMm(i,j,k)
-          Mint(i,j)=Mint(i,j) + epmlmMm(i,j,k)
-        endif ! end if dans nuage
-        END DO
-     END DO
-  END DO
-
-     DO j=1,klev
-        DO i=1,klon
-          if(Mint(i,j).gt.1.e-16) then
-           qMel(i,j,it)=qpmMint(i,j,it)/Mint(i,j)
-          else
-           qMel(i,j,it)=0.
-          endif
-     END DO
-  END DO
-
-! calcul de q_d et q_p    traceurs de la descente precipitante 
-   DO j=klev-1,1,-1
-    DO i=1,klon
-     if(mp(i,j+1).gt.mp(i,j).and.mp(i,j+1).gt.1.e-10) then  ! detrainement
-       kappa(i,j)=((pmflxr(i,j+1)+pmflxs(i,j+1)+Pa(i,j)+Pm(i,j))*&
-                (-mp(i,j+1)-imp(i,j)/RG*dxpres(i,j))&
-                + (imp(i,j)/RG*dxpres(i,j))*(evap(i,j)/RG*dxpres(i,j)))
-             
-     elseif(mp(i,j).gt.mp(i,j+1).and.mp(i,j).gt.1.e-10) then! entrainement
-       if(j.eq.1) then
-        kappa(i,j)=((pmflxr(i,j+1)+pmflxs(i,j+1)+Pa(i,j)+Pm(i,j))*&
-                 (-mp(i,2)-imp(i,j)/RG*dxpres(i,j))&
-                 + (imp(i,j)/RG*dxpres(i,j))*(evap(i,j)/RG*dxpres(i,j)))
-       else
-        kappa(i,j)=((pmflxr(i,j+1)+pmflxs(i,j+1)+Pa(i,j)+Pm(i,j))*&
-                 (-mp(i,j)-imp(i,j)/RG*dxpres(i,j))&
-                 + (imp(i,j)/RG*dxpres(i,j))*(evap(i,j)/RG*dxpres(i,j)))
-       endif
-      else
-        kappa(i,j)=1.
-      endif
-    ENDDO
-   ENDDO
-
-  DO j=klev-1,1,-1
-   DO i=1,klon
-    if (abs(kappa(i,j)).lt.1.e-25) then    !si denominateur nul (il peut y avoir des mp!=0)
-     kappa(i,j)=1.
-     if(j.eq.1) then
-       qDi(i,j,it)=qDi(i,j+1,it) !orig tr(i,j,it)   ! mp(1)=0 donc tout vient de la couche supérieure
-     elseif(mp(i,j+1).gt.mp(i,j).and.mp(i,j+1).gt.1.e-10) then
-       qDi(i,j,it)=qDi(i,j+1,it)
-     elseif(mp(i,j).gt.mp(i,j+1).and.mp(i,j).gt.1.e-10) then! entrainement
-       qDi(i,j,it)=(-mp(i,j+1)*(qDi(i,j+1,it)-tr(i,j,it))-mp(i,j)*tr(i,j,it))/(-mp(i,j))
-     else  ! si  mp (i)=0 et mp(j+1)=0
-       qDi(i,j,it)=tr(i,j,it) ! orig 0.
-     endif 
-
-      if(NO_precip(i,j)) then
-       qPr(i,j,it)=0.
-      else
-       qPr(i,j,it)=((pmflxr(i,j+1)+pmflxs(i,j+1))*qPr(i,j+1,it)+&
-                   Pa(i,j)*qPa(i,j,it)+Pm(i,j)*qMel(i,j,it)&
-                   +imp(i,j)/RG*dxpres(i,j)*qDi(i,j,it))/&
-                  (pmflxr(i,j+1)+pmflxs(i,j+1)+Pa(i,j)+Pm(i,j))
-      endif
-    else   !     denominateur non nul
-     kappa(i,j)=1./kappa(i,j)     
-! calcul de qd et qp
-!!jyg  (20130119) correction pour le sommet du nuage
-!!     if(j.ge.inb(i)) then       !au-dessus du nuage, sommet inclu
-     if(j.gt.inb(i)) then       !au-dessus du nuage
-       qDi(i,j,it)=tr(i,j,it)   ! pas de descente => environnement = descente insaturee
-       qPr(i,j,it)=0.
-
-!  vvv premiere couche du modele ou mp(1)=0  ! det tout le temps  vvv
-     elseif(j.eq.1) then 
-      if(mp(i,2).gt.1.e-10) then !mp(2) non nul -> detrainement (car mp(1) = 0) !ent pas possible
-       if(NO_precip(i,j)) then !pas de precip en (i)
-        qDi(i,j,it)=qDi(i,j+1,it)
-        qPr(i,j,it)=0.
-       else
-        qDi(i,j,it)=kappa(i,j)*(&
-            (-evap(i,j)/RG*dxpres(i,j))*((pmflxr(i,j+1)+pmflxs(i,j+1))*qPr(i,j+1,it)+&
-            Pa(i,j)*qPa(i,j,it)+Pm(i,j)*qMel(i,j,it)) +&
-            (pmflxr(i,j+1)+pmflxs(i,j+1)+Pa(i,j)+Pm(i,j))*&
-            (-mp(i,j+1)*qDi(i,j+1,it)))
-
-        qPr(i,j,it)=kappa(i,j)*(&
-            (-mp(i,j+1)-imp(i,j)/RG*dxpres(i,j))*&
-            ((pmflxr(i,j+1)+pmflxs(i,j+1))*qPr(i,j+1,it)+&
-            Pa(i,j)*qPa(i,j,it)+Pm(i,j)*qMel(i,j,it))&
-            +(-mp(i,j+1)*qDi(i,j+1,it)) * (imp(i,j)/RG*dxpres(i,j)))
-       endif
-
-      else !mp(2) nul -> plus de descente insaturee -> pluie agit sur environnement
-        qDi(i,j,it)=tr(i,j,it) ! orig 0.
-        if(NO_precip(i,j)) then
-         qPr(i,j,it)=0.
-        else
-         qPr(i,j,it)=((pmflxr(i,j+1)+pmflxs(i,j+1))*qPr(i,j+1,it)+&
-                   Pa(i,j)*qPa(i,j,it)+Pm(i,j)*qMel(i,j,it)&
-                   +imp(i,j)/RG*dxpres(i,j)*tr(i,j,it))/&
-                  (pmflxr(i,j+1)+pmflxs(i,j+1)+Pa(i,j)+Pm(i,j))
-        endif
-
-      endif  !mp(2) nul ou non
-
-! vvv  (j!=1.and.j.lt.inb(i))  en-dessous du sommet nuage   vvv
-     else 
-!------------------------------------------------------------- detrainement 
-      if(mp(i,j+1).gt.mp(i,j).and.mp(i,j+1).gt.1.e-10) then !mp(i,j).gt.1.e-10) then
-         if(NO_precip(i,j)) then 
-          qDi(i,j,it)=qDi(i,j+1,it)
-          qPr(i,j,it)=0.
-         else
-          qDi(i,j,it)=kappa(i,j)*(&
-            (-evap(i,j)/RG*dxpres(i,j))*((pmflxr(i,j+1)+pmflxs(i,j+1))*qPr(i,j+1,it)+&
-            Pa(i,j)*qPa(i,j,it)+Pm(i,j)*qMel(i,j,it)) +&
-            (pmflxr(i,j+1)+pmflxs(i,j+1)+Pa(i,j)+Pm(i,j))*&
-            (-mp(i,j+1)*qDi(i,j+1,it)))
-!
-          qPr(i,j,it)=kappa(i,j)*(&
-            (-mp(i,j+1)-imp(i,j)/RG*dxpres(i,j))*&
-            ((pmflxr(i,j+1)+pmflxs(i,j+1))*qPr(i,j+1,it)+&
-            Pa(i,j)*qPa(i,j,it)+Pm(i,j)*qMel(i,j,it))&
-            +(-mp(i,j+1)*qDi(i,j+1,it)) * (imp(i,j)/RG*dxpres(i,j)))
-         endif !precip
-!------------------------------------------------------------- entrainement 
-      elseif(mp(i,j).gt.mp(i,j+1).and.mp(i,j).gt.1.e-10) then 
-         if(NO_precip(i,j)) then
-          qDi(i,j,it)=(-mp(i,j+1)*(qDi(i,j+1,it)-tr(i,j,it))-mp(i,j)*tr(i,j,it))/(-mp(i,j))
-          qPr(i,j,it)=0.
-         else
-          qDi(i,j,it)=kappa(i,j)*(&
-            (-evap(i,j)/RG*dxpres(i,j))*((pmflxr(i,j+1)+pmflxs(i,j+1))*qPr(i,j+1,it)+&
-            Pa(i,j)*qPa(i,j,it)+Pm(i,j)*qMel(i,j,it)) +&
-            (pmflxr(i,j+1)+pmflxs(i,j+1)+Pa(i,j)+Pm(i,j))*&
-            (-mp(i,j+1)*(qDi(i,j+1,it)-tr(i,j,it))-mp(i,j)*tr(i,j,it)))
-!
-          qPr(i,j,it)=kappa(i,j)*(&
-            (-mp(i,j)-imp(i,j)/RG*dxpres(i,j))*&
-            ((pmflxr(i,j+1)+pmflxs(i,j+1))*qPr(i,j+1,it)+&
-            Pa(i,j)*qPa(i,j,it)+Pm(i,j)*qMel(i,j,it))&
-            +(-mp(i,j+1)*(qDi(i,j+1,it)-tr(i,j,it))-mp(i,j)*tr(i,j,it))*&
-            (imp(i,j)/RG*dxpres(i,j)))
-         endif !precip
-!------------------------------------------------------------- endif ! ent/det
-      else  !mp nul
-        qDi(i,j,it)=tr(i,j,it) ! orig 0.
-        if(NO_precip(i,j)) then
-         qPr(i,j,it)=0.
-        else
-         qPr(i,j,it)=((pmflxr(i,j+1)+pmflxs(i,j+1))*qPr(i,j+1,it)+&
-                   Pa(i,j)*qPa(i,j,it)+Pm(i,j)*qMel(i,j,it)&
-                   +imp(i,j)/RG*dxpres(i,j)*tr(i,j,it))/&
-                  (pmflxr(i,j+1)+pmflxs(i,j+1)+Pa(i,j)+Pm(i,j))
-        endif
-      endif ! mp nul ou non
-     endif ! condition sur j
-    endif ! kappa
-   ENDDO
-  ENDDO
-
-!! print test descente insaturee
-!  DO j=klev,1,-1
-!   DO i=1,klon
-!     if(it.eq.3) then
-!   write(*,'(I2,2X,a,e20.12,2X,a,e20.12,2X,a,e20.12,2X,a,e20.12,2X,a,e20.12,2X,a,e20.12,2X,a,e20.12)') j,&
-!!         'zmfdam',zmfdam(i,j,it),'zmfpsi',zmfphi2(i,j,it),&
-!          'zmfdam+zmfpsi',zmfdam(i,j,it)+zmfphi2(i,j,it),'qpmMint',qpmMint(i,j,it),&
-!          'Pm',Pm(i,j),'Mint',Mint(i,j),&
-!!          'zmfa',zmfa(i,j,it),'zmfp',zmfp(i,j,it),&
-!        'zmfdam',zmfdam(i,j,it),'zmfpsi',zmfphi2(i,j,it),'zmfd1a',zmfd1a(i,j,it)
-!!          'Pa',Pa(i,j),'eplaMm',eplaMm(i,j)
-!!         'zmfd1a=da1*qa',zmfd1a(i,j,it),'Pa*qPa',wdtrainA(i,j)*qPa(i,j,it),'da1',d1a(i,j)
-!     endif
-!   ENDDO
-!  ENDDO
-
-
-! ===================================================
-! calcul final des tendances
-! ===================================================
-
-  DO k=klev-1,1,-1
-    DO i=1, klon
-! transport
-     tdcvMA=zmfd(i,k,it)+zmfu(i,k,it)+zmfa(i,k,it)+zmfp(i,k,it)   ! double comptage des downdraft insatures
-     trsptrac=zmfu(i,k,it)+zmfa(i,k,it)+zmfp(i,k,it)
-! lessivage courants satures
-!JE     scavtrac=-ccntrAA_coef*zmfd1a(i,k,it)&
-!JE               -zmfphi2(i,k,it)*ccntrENV_coef&
-!JE               -zmfdam(i,k,it)*ccntrAA_coef
-     scavtrac=-ccntrAA_coef3d(i,k)*zmfd1a(i,k,it)&
-               -zmfphi2(i,k,it)*ccntrENV_coef3d(i,k)&
-               -zmfdam(i,k,it)*ccntrAA_coef3d(i,k)
-! lessivage courants insatures
-   if(k.le.inb(i).and.k.gt.1) then   ! tendances dans le nuage
-!------------------------------------------------------------- detrainement
-      if(mp(i,k+1).gt.mp(i,k).and.mp(i,k+1).gt.1.e-10) then
-        uscavtrac= (-mp(i,k)+mp(i,k+1))*(qDi(i,k,it)-tr(i,k,it))&
-                   + mp(i,k)*(tr(i,k-1,it)-tr(i,k,it))
-!
-!        if(it.eq.3) write(*,'(I2,1X,a,5X,e20.12,82X,a,e20.12)')k,' det incloud',&
-!                    (-mp(i,k)+mp(i,k+1))*(qDi(i,k,it)-tr(i,k,it))*pdtimeRG/dxpres(i,k)+&
-!                    mp(i,k)*(tr(i,k-1,it)-tr(i,k,it))*pdtimeRG/dxpres(i,k),&
-!                    'mp',mp(i,k)
-!------------------------------------------------------------- entrainement 
-      elseif(mp(i,k).gt.mp(i,k+1).and.mp(i,k).gt.1.e-10) then
-         uscavtrac= mp(i,k)*(tr(i,k-1,it)-tr(i,k,it))
-!
-!         if(it.eq.3) write(*,'(I2,1X,a,5X,e20.12,82X,a,e20.12)')k,' ent incloud',uscavtrac*pdtimeRG/dxpres(i,k), 'mp',mp(i,k)
-!=!------------------------------------------------------------- end ent/det 
-      else !        mp(i,k+1)=0. et mp(i,k)=0.    pluie directement sur l environnement
-
-        if(NO_precip(i,k)) then
-          uscavtrac=0.
-!         if(it.eq.3) write(*,'(I2,1X,a,e20.12,82X,a,e20.12)')k,' no P ent incloud',uscavtrac*pdtimeRG/dxpres(i,k), 'mp',mp(i,k)
-        else
-          uscavtrac=-imp(i,k)*tr(i,k,it)*dxpres(i,k)/RG+evap(i,k)*qPr(i,k,it)*dxpres(i,k)/RG
-!         if(it.eq.3) write(*,'(I2,1X,a,3X,e20.12,82X,a,e20.12)')k,' P env incloud',uscavtrac*pdtimeRG/dxpres(i,k), 'mp',mp(i,k)
-!!JE adds
-!         if(it.eq.3) write(*,'(I2,1X,a,3X,e20.12,82X,a,e20.12)')k,' P env incloud',uscavtrac, 'imp',imp(i,k)
-!         if(it.eq.3) write(*,'(I2,1X,a,3X,e20.12,82X,a,e20.12)')k,' P env incloud',uscavtrac, 'tr',tr(i,k,it)
-!         if(it.eq.3) write(*,'(I2,1X,a,3X,e20.12,82X,a,e20.12)')k,' P env incloud',uscavtrac, 'evap',evap(i,k)
-!         if(it.eq.3) write(*,'(I2,1X,a,3X,e20.12,82X,a,e20.12)')k,' P env incloud',uscavtrac, 'qPr',qPr(i,k,it)
-!         if(it.eq.3) write(*,'(I2,1X,a,3X,e20.12,82X,a,e20.12)')k,' P env incloud',uscavtrac, 'dxpres',dxpres(i,k)
-!!Je end
-
-        endif
-      endif  ! mp/det/ent
-!------------------------------------------------------------- premiere couche 
-   elseif(k.eq.1) then  !                                      mp(1)=0.
-      if(mp(i,2).gt.1.e-10) then  !detrainement
-         uscavtrac= (-0.+mp(i,2))*(qDi(i,k,it)-tr(i,k,it)) !&
-!                   + mp(i,2)*(0.-tr(i,k,it))
-!
-!       if(it.eq.3) write(*,'(I2,1X,a,e20.12,84X,a,e20.12)')k,' 1 det',&
-!                  (-0.+mp(i,2))*(qDi(i,k,it)-tr(i,k,it))*pdtimeRG/dxpres(i,k)+&
-!                  mp(i,2)*(0.-tr(i,k,it))*pdtimeRG/dxpres(i,k),&
-!                   'mp',mp(i,k)
-      else   ! mp(2) = 0 = mp(1) pas de descente insaturee, rien ne se passe s'il ne pleut pas, sinon pluie->env
-        if(NO_precip(i,1)) then
-          uscavtrac=0.
-        else
-          uscavtrac=-imp(i,k)*tr(i,k,it)*dxpres(i,k)/RG+evap(i,k)*qPr(i,k,it)*dxpres(i,k)/RG
-        endif
-!         if(it.eq.3) write(*,'(I2,1X,a,2X,e20.12,82X,a,e20.12)')k,'1 P env incloud',uscavtrac*pdtimeRG/dxpres(i,k), 'mp',mp(i,k)
-      endif
-
-   else   ! k > INB  au-dessus du nuage
-    uscavtrac=0.
-   endif
-
-! =====    tendances finales  ======
-     trsptd(i,k,it)=trsptrac*pdtimeRG/dxpres(i,k)              ! td transport sans eau dans courants satures
-     dtrSscav(i,k,it)=scavtrac*pdtimeRG/dxpres(i,k)            ! td du lessivage dans courants satures
-     dtrUscav(i,k,it)=uscavtrac*pdtimeRG/dxpres(i,k)           ! td courant insat
-     dtrsat(i,k,it)=(trsptrac+scavtrac)*pdtimeRG/dxpres(i,k)   ! td courant sat
-     dtrcv(i,k,it)=(trsptrac+scavtrac+uscavtrac)*pdtimeRG/dxpres(i,k)!dtrsat(i,k,it)+dtrUscav(i,k,it)         td conv
-!!!!!!
-     dtrcvMA(i,k,it)=tdcvMA*pdtimeRG/dxpres(i,k) ! MA tendance convection
-     ENDDO
-  ENDDO
-
-! test de conservation du traceur
-!print*,"_____________________________________________________________"
-!print*,"                                                             "
-!      conserv=0.
-!      conservMA=0.
-!      DO k= klev-1,1,-1
-!        DO i=1, klon
-!         conserv=conserv+dtrcv(i,k,it)*   &
-!        (paprs(i,k)-paprs(i,k+1))/RG
-!         conservMA=conservMA+dtrcvMA(i,k,it)*   &
-!        (paprs(i,k)-paprs(i,k+1))/RG
-!
-!      if(it.eq.3)  write(*,'(I2,2X,a,e20.12,2X,a,e20.12,2X,a,e20.12,2X,a,e20.12)') k,&
-!         'MA td ',dtrcvMA(i,k,it)*dxpres(i,k)/RG,&
-!         ' td',dtrcv(i,k,it)*dxpres(i,k)/RG,'         conservMA ',conservMA,'conserv ',conserv
-!!
-!        ENDDO
-!      ENDDO
-!       if(it.eq.3) print *,'it',it,'conserv ',conserv,'conservMA ',conservMA
-
-END SUBROUTINE cvltr_spl
Index: /LMDZ6/trunk/libf/phylmd/cvltr_spl.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cvltr_spl.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/cvltr_spl.f90	(revision 5268)
@@ -0,0 +1,841 @@
+!
+! $Id $
+!
+SUBROUTINE cvltr_spl(pdtime, da, phi,phi2,d1a,dam, mpIN,epIN, &
+           sigd,sij,wght_cvfd,clw,elij,epmlmMm,eplaMm,              &
+           pmflxrIN,pmflxsIN,ev,te,wdtrainA,wdtrainM,     &
+           paprs,it,tr,upd,dnd,inb,icb,                   &
+           kk,henry,zrho, ccntrAA_spla,ccntrENV_spla,coefcoli_spla, &
+           id_prec,id_fine,id_coss, id_codu, id_scdu, &
+           dtrcv,trsptd,dtrSscav,dtrsat,dtrUscav,qDi,qPr, &
+           qPa,qMel,qTrdi,dtrcvMA,Mint,                   &
+           zmfd1a,zmfphi2,zmfdam)
+  USE IOIPSL 
+  USE dimphy
+  USE infotrac_phy, ONLY : nbtr
+  IMPLICIT NONE 
+!=====================================================================
+! Objet : convection des traceurs / KE
+! Auteurs: M-A Filiberti and J-Y Grandpeix
+! modifiee par R Pilon : lessivage des traceurs / KE
+!=====================================================================
+
+  include "YOMCST.h"
+  include "YOECUMF.h"
+  include "conema3.h"
+  include "chem.h"
+
+! Entree
+  REAL,INTENT(IN)                           :: pdtime
+  REAL,DIMENSION(klon,klev),INTENT(IN)      :: da
+  REAL,DIMENSION(klon,klev,klev),INTENT(IN) :: phi
+! RomP
+  REAL,DIMENSION(klon,klev),INTENT(IN)      :: d1a,dam ! matrices pour simplifier
+  REAL,DIMENSION(klon,klev,klev),INTENT(IN) :: phi2    ! l'ecriture des tendances
+!
+  REAL,DIMENSION(klon,klev),INTENT(IN)      :: mpIN
+  REAL,DIMENSION(klon,klev+1),INTENT(IN)    :: paprs  ! pression aux 1/2 couches (bas en haut)
+!  REAL,DIMENSION(klon,klev),INTENT(IN)    :: pplay ! pression aux 1/2 couches (bas en haut)
+  REAL,DIMENSION(klon,klev,nbtr),INTENT(IN) :: tr     ! q de traceur (bas en haut)
+  INTEGER,INTENT(IN)                        :: it 
+  REAL,DIMENSION(klon,klev),INTENT(IN)      :: upd   ! saturated updraft mass flux
+  REAL,DIMENSION(klon,klev),INTENT(IN)      :: dnd   ! saturated downdraft mass flux
+!
+  REAL,DIMENSION(klon,klev),INTENT(IN)      :: wdtrainA   ! masses precipitantes de l'asc adiab
+  REAL,DIMENSION(klon,klev),INTENT(IN)      :: wdtrainM   ! masses precipitantes des melanges
+!JE  REAL,DIMENSION(klon,klev),INTENT(IN)      :: pmflxrIN   ! vprecip: eau
+  REAL,DIMENSION(klon,klev+1),INTENT(IN)      :: pmflxrIN   ! vprecip: eau
+!JE  REAL,DIMENSION(klon,klev),INTENT(IN)      :: pmflxsIN   ! vprecip: neige
+  REAL,DIMENSION(klon,klev+1),INTENT(IN)      :: pmflxsIN   ! vprecip: neige
+  REAL,DIMENSION(klon,klev),INTENT(IN)      :: ev         ! evaporation cv30_routine
+  REAL,DIMENSION(klon,klev),INTENT(IN)      :: epIN
+  REAL,DIMENSION(klon,klev),INTENT(IN)      :: te 
+  REAL,DIMENSION(klon,klev,klev),INTENT(IN) :: sij        ! fraction dair de lenv
+  REAL,DIMENSION(klon,klev),INTENT(IN)      :: wght_cvfd  ! weights of the layers feeding convection
+  REAL,DIMENSION(klon,klev,klev),INTENT(IN) :: elij       ! contenu en eau condensée spécifique/conc deau condensée massique
+  REAL,DIMENSION(klon,klev,klev),INTENT(IN) :: epmlmMm    ! eau condensee precipitee dans mel masse dair sat
+  REAL,DIMENSION(klon,klev),INTENT(IN)      :: eplaMm    ! eau condensee precipitee dans aa masse dair sat
+
+  REAL,DIMENSION(klon,klev),INTENT(IN)      :: clw        ! contenu en eau condensée dans lasc adiab
+  REAL,DIMENSION(klon),INTENT(IN)           :: sigd
+  INTEGER,DIMENSION(klon),INTENT(IN)        :: icb,inb
+! Sortie
+  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)     :: dtrcv     ! tendance totale (bas en haut)
+  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)     :: dtrcvMA ! M-A Filiberti
+  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)     :: trsptd    ! tendance du transport 
+  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)     :: dtrSscav  ! tendance du lessivage courant sat
+  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)     :: dtrsat    ! tendance trsp+sat scav
+  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)     :: dtrUscav  ! tendance du lessivage courant unsat
+!
+! Variables locales
+  INTEGER                           :: i,j,k
+  REAL,DIMENSION(klon,klev)         :: dxpres   ! difference de pression entre niveau (j+1) et (j)
+  REAL                              :: pdtimeRG ! pas de temps * gravite
+  REAL,DIMENSION(klon,nbtr)         :: qfeed     ! tracer concentration feeding convection
+! variables pour les courants satures
+  REAL,DIMENSION(klon,klev,klev)    :: zmd
+  REAL,DIMENSION(klon,klev,klev)    :: za
+  REAL,DIMENSION(klon,klev,nbtr)    :: zmfd,zmfa
+  REAL,DIMENSION(klon,klev,nbtr)    :: zmfp,zmfu
+
+  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)    :: zmfd1a
+  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)    :: zmfdam
+  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)    :: zmfphi2
+
+! RomP ! les variables sont nettoyees des valeurs aberrantes
+  REAL,DIMENSION(klon,klev)         :: Pa, Pm  ! pluie AA et mélanges, var temporaire
+  REAL,DIMENSION(klon,klev)         :: pmflxs,pmflxr ! pmflxrIN,pmflxsIN sans valeur aberante
+  REAL,DIMENSION(klon,klev)         :: mp            ! flux de masse
+  REAL,DIMENSION(klon,klev)         :: ep            ! fraction d'eau convertie en precipitation 
+  REAL,DIMENSION(klon,klev)         :: evap          ! evaporation : variable temporaire 
+  REAL,DIMENSION(klon,klev)         :: rho    !environmental density
+
+  REAL,DIMENSION(klon,klev)         :: kappa ! denominateur du au calcul de la matrice 
+                                             ! pour obtenir qd et qp
+  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)    :: qTrdi ! traceurs descente air insature transport MA
+  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)    :: qDi  ! traceurs descente insaturees
+  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)    :: qPr  ! traceurs colonne precipitante
+  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)    :: qPa  ! traceurs dans les precip issues lasc. adiab.
+  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)    :: qMel ! traceurs dans les precip issues des melanges
+  REAL,DIMENSION(klon,klev,nbtr)                :: qMeltmp ! variable temporaire 
+  REAL,DIMENSION(klon,klev,nbtr)                :: qpmMint
+  REAL,DIMENSION(klon,klev),INTENT(OUT)         :: Mint
+! tendances
+  REAL                              :: tdcvMA           ! terme de transport de traceur (schema Marie Angele)
+  REAL                              :: trsptrac         ! terme de transport de traceur par l'air
+  REAL                              :: scavtrac         ! terme de lessivage courant sature
+  REAL                              :: uscavtrac        ! terme de lessivage courant insature
+! impaction
+!!!       Correction apres discussion Romain P. / Olivier B. 
+!!!  REAL,PARAMETER                    :: rdrop=2.5e-3     ! rayon des gouttes d'eau
+  REAL,PARAMETER                    :: rdrop=1.e-3     ! rayon des gouttes d'eau 
+!!!
+  REAL,DIMENSION(klon,klev)         :: imp              ! coefficient d'impaction
+! parametres lessivage
+  REAL                    :: ccntrAA_coef        ! \alpha_a : fract aerosols de l'AA convertis en CCN
+  REAL                    :: ccntrENV_coef       ! \beta_m  : fract aerosols de l'env convertis en CCN
+  REAL                    :: coefcoli            ! coefficient de collision des gouttes sur les aerosols
+!
+  LOGICAL,DIMENSION(klon,klev) :: NO_precip
+!  LOGICAL                      :: scavON
+! var tmp tests
+  REAL                           :: conserv
+  real                           :: conservMA
+! JE SPLA adaptation
+
+   INTEGER :: id_prec,id_fine,id_coss, id_codu, id_scdu
+   REAL,DIMENSION(nbtr) :: ccntrAA_spla,ccntrENV_spla,coefcoli_spla
+   REAL,DIMENSION(klon,klev) :: ccntrAA_coef3d
+   REAL,DIMENSION(klon,klev) :: ccntrENV_coef3d
+   REAL,DIMENSION(klon,klev) :: coefcoli3d
+
+   REAL,DIMENSION(nbtr) :: henry         !--cste de Henry  mol/l/atm
+   REAL,DIMENSION(nbtr) :: kk            !--coefficient de var avec T (K)
+   REAL :: henry_t !--constante de Henry a T t  (mol/l/atm)
+   REAL :: f_a     !--rapport de la phase aqueuse a la phase gazeuse
+
+   REAL, PARAMETER :: ph=5.
+   REAL ::  K1, K2
+   REAL,DIMENSION(klon,klev) :: zrho
+   REAL, PARAMETER :: qliq=1.e-3 ! CONVECTIVE ONLY 
+
+! Je end 20140105
+
+!JE20140724<<
+!JE SPLA adapt:
+!
+!
+!! coefficient lessivage
+!   ccntrAA_coef     = 0.
+!   ccntrENV_coef    = 0.
+!   coefcoli         = 0.
+!
+!!$OMP MASTER
+!  call getin('ccntrAA_coef',ccntrAA_coef)
+!  call getin('ccntrENV_coef',ccntrENV_coef)
+!  call getin('coefcoli',coefcoli)
+!!$OMP END MASTER
+!!$OMP BARRIER
+!!! JE
+!  do j=1,klev
+!   do i=1,klon
+!     imp(i,j)=0.
+!     ccntrAA_coef3d(i,j)=ccntrAA_coef
+!     ccntrENV_coef3d(i,j)=ccntrENV_coef
+!     coefcoli3d(i,j)=coefcoli
+!   enddo
+!  enddo
+!
+!
+!!! for SPLA
+!!!JEend
+!  print*,'cvltr coef lessivage convectif', ccntrAA_coef,ccntrENV_coef,coefcoli
+!
+!JE20140724>>
+
+!  scavON=.TRUE.
+!  if(scavON) then
+!   ccntrAA_coef     = 1.
+!   ccntrENV_coef    = 1.
+!   coefcoli         = 1.
+!  else
+!   ccntrAA_coef     = 0.
+!   ccntrENV_coef    = 0.
+!   coefcoli         = 0.
+!  endif
+
+! ======================================================
+! calcul de l'impaction
+! ======================================================
+!initialisation
+  do j=1,klev
+   do i=1,klon
+     imp(i,j)=0.
+   enddo
+  enddo
+!JE init 20140103 
+!! impaction sur la surface de la colonne de la descente insaturee
+!! On prend la moyenne des precip entre le niveau i+1 et i
+!! I=3/4* (P(1+1)+P(i))/2 / (sigd*r*rho_l)
+!!  1000kg/m3= densité de l'eau
+!! 0.75e-3 = 3/4 /1000
+!! Par la suite, I est tout le temps multiplié par sig_d pour avoir l'impaction sur la surface de la maille
+!! on le néglige ici pour simplifier le code
+!  do j=1,klev-1
+!   do i=1,klon
+!    imp(i,j) = coefcoli*0.75e-3/rdrop *&
+!             0.5*(pmflxr(i,j+1)+pmflxs(i,j+1)+pmflxr(i,j)+pmflxs(i,j))
+!!    rho(i,j)=pplay(i,j)/(rd*te(i,j))
+!   enddo
+!  enddo
+!JE end 20140103
+
+!
+! initialisation pour flux de traceurs, td et autre
+   trsptrac = 0.
+   scavtrac = 0.
+   uscavtrac = 0.
+   qfeed(:,it) = 0.              !RL
+  DO j=1,klev
+   DO i=1,klon
+    zmfd(i,j,it)=0.
+    zmfa(i,j,it)=0.
+    zmfu(i,j,it)=0.
+    zmfp(i,j,it)=0.
+    zmfphi2(i,j,it)=0.
+    zmfd1a(i,j,it)=0.
+    zmfdam(i,j,it)=0.
+    qDi(i,j,it)=0.
+    qPr(i,j,it)=0.
+    qPa(i,j,it)=0.
+    qMel(i,j,it)=0.
+    qMeltmp(i,j,it)=0.
+    qTrdi(i,j,it)=0.
+    kappa(i,j)=0.
+    trsptd(i,j,it)=0.
+    dtrsat(i,j,it)=0.
+    dtrSscav(i,j,it)=0.
+    dtrUscav(i,j,it)=0.
+    dtrcv(i,j,it)=0.
+    dtrcvMA(i,j,it)=0.
+    evap(i,j)=0.
+    dxpres(i,j)=0.
+    qpmMint(i,j,it)=0.
+    Mint(i,j)=0.
+   END DO
+  END DO
+
+! suppression des valeurs très faibles (~1e-320)
+! multiplication de levaporation pour lavoir par unite de temps
+! et par unite de surface de la maille
+! -> cv30_unsat : evap : masse evaporee/s/(m2 de la descente)
+  DO j=1,klev
+   DO i=1,klon
+    if(ev(i,j).lt.1.e-16) then
+     evap(i,j)=0.
+    else
+     evap(i,j)=ev(i,j)*sigd(i)
+    endif
+   END DO
+  END DO
+
+  DO j=1,klev
+   DO i=1,klon
+   if(j.lt.klev) then
+    if(epIN(i,j).lt.1.e-32) then
+     ep(i,j)=0.
+    else
+     ep(i,j)=epIN(i,j)
+    endif
+   else
+    ep(i,j)=epmax
+   endif
+    if(mpIN(i,j).lt.1.e-32) then
+     mp(i,j)=0.
+    else
+     mp(i,j)=mpIN(i,j)
+    endif
+    if(pmflxsIN(i,j).lt.1.e-32) then
+     pmflxs(i,j)=0.
+    else
+     pmflxs(i,j)=pmflxsIN(i,j)
+    endif
+    if(pmflxrIN(i,j).lt.1.e-32) then
+     pmflxr(i,j)=0.
+    else
+     pmflxr(i,j)=pmflxrIN(i,j)
+    endif
+    if(wdtrainA(i,j).lt.1.e-32) then
+     Pa(i,j)=0.
+    else
+     Pa(i,j)=wdtrainA(i,j)
+    endif
+    if(wdtrainM(i,j).lt.1.e-32) then
+     Pm(i,j)=0.
+    else
+     Pm(i,j)=wdtrainM(i,j)
+    endif
+   END DO
+  END DO
+
+!==========================================
+  DO j = klev-1,1,-1
+   DO i = 1,klon
+     NO_precip(i,j) = (pmflxr(i,j+1)+pmflxs(i,j+1)).lt.1.e-10&
+                    .and.Pa(i,j).lt.1.e-10.and.Pm(i,j).lt.1.e-10
+   END DO
+  END DO
+!==============================================================================
+! JE SPLA: Calc of ccntrAA_coef,ccntrENV_coef, coefcoli for SPLA aerosols and
+! precursors. From SPLA code inscav_spl.F 
+!print *,'Using SPLA values for cvltr_spl ccntr and coefcoli params'
+!
+!
+!IF (it.EQ.2) THEN !--fine aerosol
+!  DO j=1,klev
+!   DO i=1,klon
+!    ccntrAA_coef3d(i,j)=0.7
+!    ccntrENV_coef3d(i,j)=0.7
+!    coefcoli3d(i,j)=0.001
+!   ENDDO
+!  ENDDO
+!ELSEIF (it.EQ.3) THEN !-- Coarse Sea salt aerosol
+!  DO j=1,klev
+!   DO i=1,klon
+!    ccntrAA_coef3d(i,j)=1.0
+!    ccntrENV_coef3d(i,j)=1.0
+!    coefcoli3d(i,j)=0.001
+!   ENDDO
+!  ENDDO
+!
+!ELSEIF (it.EQ.4) THEN !--Coarse Dust aerosol
+!  DO j=1,klev
+ !  DO i=1,klon
+!    ccntrAA_coef3d(i,j)=0.7
+!    ccntrENV_coef3d(i,j)=0.7
+!    coefcoli3d(i,j)=0.001
+!
+!   ENDDO
+!  ENDDO
+! Gas precursor: Henry's law
+
+IF (it .EQ. id_prec) THEN
+      DO k=1, klev
+      DO i=1, klon
+        henry_t=henry(it)*exp(-kk(it)*(1./298.-1./te(i,k)))    !--mol/l/atm
+        K1=1.2e-2*exp(-2010*(1/298.-1/te(i,k)))
+        K2=6.6e-8*exp(-1510*(1/298.-1/te(i,k)))
+        henry_t=henry_t*(1. + K1/10.**(-ph) + K1*K2/(10.**(-ph))**2)
+        f_a=henry_t/101.325*R*te(i,k)*qliq*zrho(i,k)/rho_water
+ !       scav(i,k)=f_a/(1.+f_a)
+        ccntrAA_coef3d(i,k)= f_a/(1.+f_a)
+        ccntrENV_coef3d(i,k)= f_a/(1.+f_a)
+        coefcoli3d(i,k)=0.0
+      ENDDO
+      ENDDO
+ !    CALL minmaxqfi2(clw,1.e33,-1.e33,'minmax clw')
+ELSE
+  DO j=1,klev
+   DO i=1,klon
+    ccntrAA_coef3d(i,j)=ccntrAA_spla(it)
+    ccntrENV_coef3d(i,j)=ccntrENV_spla(it)
+    coefcoli3d(i,j)=coefcoli_spla(it)
+   ENDDO
+  ENDDO
+
+
+ENDIF
+
+! JE end SPLA modifs in ccn parameters
+!==============================================================================
+
+
+
+
+!JE init 20140103
+! impaction sur la surface de la colonne de la descente insaturee
+! On prend la moyenne des precip entre le niveau i+1 et i
+! I=3/4* (P(1+1)+P(i))/2 / (sigd*r*rho_l)
+!  1000kg/m3= densité de l'eau
+! 0.75e-3 = 3/4 /1000
+! Par la suite, I est tout le temps multiplié par sig_d pour avoir l'impaction sur la surface de la maille
+! on le néglige ici pour simplifier le code
+  do j=1,klev-1
+   do i=1,klon
+!JE    imp(i,j) = coefcoli*0.75e-3/rdrop *&
+!JE             0.5*(pmflxr(i,j+1)+pmflxs(i,j+1)+pmflxr(i,j)+pmflxs(i,j))
+    imp(i,j) = coefcoli3d(i,j)*0.75e-3/rdrop *&
+             0.5*(pmflxr(i,j+1)+pmflxs(i,j+1)+pmflxr(i,j)+pmflxs(i,j))
+!    rho(i,j)=pplay(i,j)/(rd*te(i,j))
+   enddo
+  enddo
+!JE end 20140103
+
+
+! =========================================
+! calcul des tendances liees au downdraft
+! =========================================
+!cdir collapse
+  DO k=1,klev
+   DO j=1,klev
+    DO i=1,klon
+     zmd(i,j,k)=0.
+     za (i,j,k)=0.
+    END DO
+   END DO
+  END DO
+! calcul de la matrice d echange
+! matrice de distribution de la masse entrainee en k
+! commmentaire RomP : mp > 0
+  DO k=1,klev-1
+     DO i=1,klon
+        zmd(i,k,k)=max(0.,mp(i,k)-mp(i,k+1))   ! ~ mk(k)
+     END DO
+  END DO
+  DO k=2,klev
+     DO j=k-1,1,-1
+        DO i=1,klon
+           if(mp(i,j+1).gt.1.e-10) then
+              zmd(i,j,k)=zmd(i,j+1,k)*min(1.,mp(i,j)/mp(i,j+1)) !det ~ mk(j)=mk(j+1)*mp(i,j)/mp(i,j+1)
+           ENDif
+        END DO
+     END DO
+  END DO
+  DO k=1,klev
+     DO j=1,klev-1
+        DO i=1,klon
+           za(i,j,k)=max(0.,zmd(i,j+1,k)-zmd(i,j,k))
+        END DO
+     END DO
+  END DO
+!!!!! quantite  de traceur dans la descente d'air insaturee  :   4 juin 2012
+  DO k=1,klev
+     DO j=1,klev-1
+        DO i=1,klon
+        if(mp(i,j+1).gt.1.e-10) then
+          qTrdi(i,j+1,it)=qTrdi(i,j+1,it)+(zmd(i,j+1,k)/mp(i,j+1))*tr(i,k,it)
+        else
+          qTrdi(i,j,it)=0.!tr(i,j,it)
+        endif
+        ENDDO
+     ENDDO
+  ENDDO
+!!!!!
+!
+! rajout du terme lie a l ascendance induite
+!
+  DO j=2,klev
+     DO i=1,klon
+        za(i,j,j-1)=za(i,j,j-1)+mp(i,j)
+     END DO
+  END DO
+!
+! tendance courants insatures  ! sans lessivage ancien schema
+!
+  DO k=1,klev
+     DO j=1,klev
+        DO i=1,klon
+           zmfd(i,j,it)=zmfd(i,j,it)+za(i,j,k)*(tr(i,k,it)-tr(i,j,it))
+        END DO
+     END DO
+  END DO
+!
+! =========================================
+! calcul des tendances liees aux courants satures   j <-> z ; k <-> z'
+! =========================================
+!RL
+!  Feeding concentrations
+  DO j=1,klev
+     DO i=1,klon
+        qfeed(i,it)=qfeed(i,it)+wght_cvfd(i,j)*tr(i,j,it)
+     END DO
+  END DO
+!RL
+!
+  DO j=1,klev
+     DO i=1,klon
+!RL
+!!        zmfa(i,j,it)=da(i,j)*(tr(i,1,it)-tr(i,j,it))                     ! da
+        zmfa(i,j,it)=da(i,j)*(qfeed(i,it)-tr(i,j,it))                     ! da
+!RL
+     END DO
+  END DO
+!
+  DO k=1,klev
+     DO j=1,klev
+        DO i=1,klon
+           zmfp(i,j,it)=zmfp(i,j,it)+phi(i,j,k)*(tr(i,k,it)-tr(i,j,it))  ! phi
+        END DO
+     END DO
+  END DO
+! RomP ajout des matrices liees au lessivage
+  DO j=1,klev
+     DO i=1,klon
+        zmfd1a(i,j,it)=d1a(i,j)*tr(i,1,it)   ! da1
+        zmfdam(i,j,it)=dam(i,j)*tr(i,1,it)   ! dam
+     END DO
+  END DO
+  DO k=1,klev
+     DO j=1,klev
+        DO i=1,klon
+          zmfphi2(i,j,it)=zmfphi2(i,j,it)+phi2(i,j,k)*tr(i,k,it)  ! psi
+        END DO
+     END DO
+  END DO
+  DO j=1,klev-1
+     DO i=1,klon
+        zmfu(i,j,it)=max(0.,upd(i,j+1)+dnd(i,j+1))*(tr(i,j+1,it)-tr(i,j,it))
+     END DO
+  END DO
+  DO j=2,klev
+     DO i=1,klon
+        zmfu(i,j,it)=zmfu(i,j,it)+min(0.,upd(i,j)+dnd(i,j))*(tr(i,j,it)-tr(i,j-1,it))
+     END DO
+  END DO
+! ===================================================
+! calcul des tendances liees aux courants insatures
+! ===================================================
+!  pression  
+  DO k=1, klev
+     DO i=1, klon
+        dxpres(i,k)=paprs(i,k)-paprs(i,k+1)
+     ENDDO
+  ENDDO
+  pdtimeRG=pdtime*RG
+
+! q_pa et q_pm    traceurs issues des courants satures se retrouvant dans les precipitations
+  DO j=1,klev
+     DO i=1,klon
+        if(j.ge.icb(i).and.j.le.inb(i)) then
+          if(clw(i,j).gt.1.e-16) then
+!           qPa(i,j,it)=ccntrAA_coef*tr(i,1,it)/clw(i,j)
+           qPa(i,j,it)=ccntrAA_coef3d(i,j)*tr(i,1,it)/clw(i,j)
+          else
+           qPa(i,j,it)=0.
+          endif
+        endif
+     END DO
+  END DO
+
+! calcul de q_pm en 2 parties :
+! 1) calcul de sa valeur pour un niveau z' donne
+! 2) integration sur la verticale sur z'
+     DO j=1,klev
+      DO k=1,j-1
+        DO i=1,klon
+        if(k.ge.icb(i).and.k.le.inb(i).and.& 
+           j.le.inb(i)) then
+            if(elij(i,k,j).gt.1.e-16) then
+!JE             qMeltmp(i,j,it)=((1-ep(i,k))*ccntrAA_coef*tr(i,1,it)&
+!JE                         *(1.-sij(i,k,j))  +ccntrENV_coef&
+!JE                         *tr(i,k,it)*sij(i,k,j)) / elij(i,k,j)
+             qMeltmp(i,j,it)=((1-ep(i,k))*ccntrAA_coef3d(i,k)*tr(i,1,it)&
+                         *(1.-sij(i,k,j))  +ccntrENV_coef3d(i,k)&
+                         *tr(i,k,it)*sij(i,k,j)) / elij(i,k,j)
+            else
+             qMeltmp(i,j,it)=0.
+            endif
+          qpmMint(i,j,it)=qpmMint(i,j,it) + qMeltmp(i,j,it)*epmlmMm(i,j,k)
+          Mint(i,j)=Mint(i,j) + epmlmMm(i,j,k)
+        endif ! end if dans nuage
+        END DO
+     END DO
+  END DO
+
+     DO j=1,klev
+        DO i=1,klon
+          if(Mint(i,j).gt.1.e-16) then
+           qMel(i,j,it)=qpmMint(i,j,it)/Mint(i,j)
+          else
+           qMel(i,j,it)=0.
+          endif
+     END DO
+  END DO
+
+! calcul de q_d et q_p    traceurs de la descente precipitante 
+   DO j=klev-1,1,-1
+    DO i=1,klon
+     if(mp(i,j+1).gt.mp(i,j).and.mp(i,j+1).gt.1.e-10) then  ! detrainement
+       kappa(i,j)=((pmflxr(i,j+1)+pmflxs(i,j+1)+Pa(i,j)+Pm(i,j))*&
+                (-mp(i,j+1)-imp(i,j)/RG*dxpres(i,j))&
+                + (imp(i,j)/RG*dxpres(i,j))*(evap(i,j)/RG*dxpres(i,j)))
+             
+     elseif(mp(i,j).gt.mp(i,j+1).and.mp(i,j).gt.1.e-10) then! entrainement
+       if(j.eq.1) then
+        kappa(i,j)=((pmflxr(i,j+1)+pmflxs(i,j+1)+Pa(i,j)+Pm(i,j))*&
+                 (-mp(i,2)-imp(i,j)/RG*dxpres(i,j))&
+                 + (imp(i,j)/RG*dxpres(i,j))*(evap(i,j)/RG*dxpres(i,j)))
+       else
+        kappa(i,j)=((pmflxr(i,j+1)+pmflxs(i,j+1)+Pa(i,j)+Pm(i,j))*&
+                 (-mp(i,j)-imp(i,j)/RG*dxpres(i,j))&
+                 + (imp(i,j)/RG*dxpres(i,j))*(evap(i,j)/RG*dxpres(i,j)))
+       endif
+      else
+        kappa(i,j)=1.
+      endif
+    ENDDO
+   ENDDO
+
+  DO j=klev-1,1,-1
+   DO i=1,klon
+    if (abs(kappa(i,j)).lt.1.e-25) then    !si denominateur nul (il peut y avoir des mp!=0)
+     kappa(i,j)=1.
+     if(j.eq.1) then
+       qDi(i,j,it)=qDi(i,j+1,it) !orig tr(i,j,it)   ! mp(1)=0 donc tout vient de la couche supérieure
+     elseif(mp(i,j+1).gt.mp(i,j).and.mp(i,j+1).gt.1.e-10) then
+       qDi(i,j,it)=qDi(i,j+1,it)
+     elseif(mp(i,j).gt.mp(i,j+1).and.mp(i,j).gt.1.e-10) then! entrainement
+       qDi(i,j,it)=(-mp(i,j+1)*(qDi(i,j+1,it)-tr(i,j,it))-mp(i,j)*tr(i,j,it))/(-mp(i,j))
+     else  ! si  mp (i)=0 et mp(j+1)=0
+       qDi(i,j,it)=tr(i,j,it) ! orig 0.
+     endif 
+
+      if(NO_precip(i,j)) then
+       qPr(i,j,it)=0.
+      else
+       qPr(i,j,it)=((pmflxr(i,j+1)+pmflxs(i,j+1))*qPr(i,j+1,it)+&
+                   Pa(i,j)*qPa(i,j,it)+Pm(i,j)*qMel(i,j,it)&
+                   +imp(i,j)/RG*dxpres(i,j)*qDi(i,j,it))/&
+                  (pmflxr(i,j+1)+pmflxs(i,j+1)+Pa(i,j)+Pm(i,j))
+      endif
+    else   !     denominateur non nul
+     kappa(i,j)=1./kappa(i,j)     
+! calcul de qd et qp
+!!jyg  (20130119) correction pour le sommet du nuage
+!!     if(j.ge.inb(i)) then       !au-dessus du nuage, sommet inclu
+     if(j.gt.inb(i)) then       !au-dessus du nuage
+       qDi(i,j,it)=tr(i,j,it)   ! pas de descente => environnement = descente insaturee
+       qPr(i,j,it)=0.
+
+!  vvv premiere couche du modele ou mp(1)=0  ! det tout le temps  vvv
+     elseif(j.eq.1) then 
+      if(mp(i,2).gt.1.e-10) then !mp(2) non nul -> detrainement (car mp(1) = 0) !ent pas possible
+       if(NO_precip(i,j)) then !pas de precip en (i)
+        qDi(i,j,it)=qDi(i,j+1,it)
+        qPr(i,j,it)=0.
+       else
+        qDi(i,j,it)=kappa(i,j)*(&
+            (-evap(i,j)/RG*dxpres(i,j))*((pmflxr(i,j+1)+pmflxs(i,j+1))*qPr(i,j+1,it)+&
+            Pa(i,j)*qPa(i,j,it)+Pm(i,j)*qMel(i,j,it)) +&
+            (pmflxr(i,j+1)+pmflxs(i,j+1)+Pa(i,j)+Pm(i,j))*&
+            (-mp(i,j+1)*qDi(i,j+1,it)))
+
+        qPr(i,j,it)=kappa(i,j)*(&
+            (-mp(i,j+1)-imp(i,j)/RG*dxpres(i,j))*&
+            ((pmflxr(i,j+1)+pmflxs(i,j+1))*qPr(i,j+1,it)+&
+            Pa(i,j)*qPa(i,j,it)+Pm(i,j)*qMel(i,j,it))&
+            +(-mp(i,j+1)*qDi(i,j+1,it)) * (imp(i,j)/RG*dxpres(i,j)))
+       endif
+
+      else !mp(2) nul -> plus de descente insaturee -> pluie agit sur environnement
+        qDi(i,j,it)=tr(i,j,it) ! orig 0.
+        if(NO_precip(i,j)) then
+         qPr(i,j,it)=0.
+        else
+         qPr(i,j,it)=((pmflxr(i,j+1)+pmflxs(i,j+1))*qPr(i,j+1,it)+&
+                   Pa(i,j)*qPa(i,j,it)+Pm(i,j)*qMel(i,j,it)&
+                   +imp(i,j)/RG*dxpres(i,j)*tr(i,j,it))/&
+                  (pmflxr(i,j+1)+pmflxs(i,j+1)+Pa(i,j)+Pm(i,j))
+        endif
+
+      endif  !mp(2) nul ou non
+
+! vvv  (j!=1.and.j.lt.inb(i))  en-dessous du sommet nuage   vvv
+     else 
+!------------------------------------------------------------- detrainement 
+      if(mp(i,j+1).gt.mp(i,j).and.mp(i,j+1).gt.1.e-10) then !mp(i,j).gt.1.e-10) then
+         if(NO_precip(i,j)) then 
+          qDi(i,j,it)=qDi(i,j+1,it)
+          qPr(i,j,it)=0.
+         else
+          qDi(i,j,it)=kappa(i,j)*(&
+            (-evap(i,j)/RG*dxpres(i,j))*((pmflxr(i,j+1)+pmflxs(i,j+1))*qPr(i,j+1,it)+&
+            Pa(i,j)*qPa(i,j,it)+Pm(i,j)*qMel(i,j,it)) +&
+            (pmflxr(i,j+1)+pmflxs(i,j+1)+Pa(i,j)+Pm(i,j))*&
+            (-mp(i,j+1)*qDi(i,j+1,it)))
+!
+          qPr(i,j,it)=kappa(i,j)*(&
+            (-mp(i,j+1)-imp(i,j)/RG*dxpres(i,j))*&
+            ((pmflxr(i,j+1)+pmflxs(i,j+1))*qPr(i,j+1,it)+&
+            Pa(i,j)*qPa(i,j,it)+Pm(i,j)*qMel(i,j,it))&
+            +(-mp(i,j+1)*qDi(i,j+1,it)) * (imp(i,j)/RG*dxpres(i,j)))
+         endif !precip
+!------------------------------------------------------------- entrainement 
+      elseif(mp(i,j).gt.mp(i,j+1).and.mp(i,j).gt.1.e-10) then 
+         if(NO_precip(i,j)) then
+          qDi(i,j,it)=(-mp(i,j+1)*(qDi(i,j+1,it)-tr(i,j,it))-mp(i,j)*tr(i,j,it))/(-mp(i,j))
+          qPr(i,j,it)=0.
+         else
+          qDi(i,j,it)=kappa(i,j)*(&
+            (-evap(i,j)/RG*dxpres(i,j))*((pmflxr(i,j+1)+pmflxs(i,j+1))*qPr(i,j+1,it)+&
+            Pa(i,j)*qPa(i,j,it)+Pm(i,j)*qMel(i,j,it)) +&
+            (pmflxr(i,j+1)+pmflxs(i,j+1)+Pa(i,j)+Pm(i,j))*&
+            (-mp(i,j+1)*(qDi(i,j+1,it)-tr(i,j,it))-mp(i,j)*tr(i,j,it)))
+!
+          qPr(i,j,it)=kappa(i,j)*(&
+            (-mp(i,j)-imp(i,j)/RG*dxpres(i,j))*&
+            ((pmflxr(i,j+1)+pmflxs(i,j+1))*qPr(i,j+1,it)+&
+            Pa(i,j)*qPa(i,j,it)+Pm(i,j)*qMel(i,j,it))&
+            +(-mp(i,j+1)*(qDi(i,j+1,it)-tr(i,j,it))-mp(i,j)*tr(i,j,it))*&
+            (imp(i,j)/RG*dxpres(i,j)))
+         endif !precip
+!------------------------------------------------------------- endif ! ent/det
+      else  !mp nul
+        qDi(i,j,it)=tr(i,j,it) ! orig 0.
+        if(NO_precip(i,j)) then
+         qPr(i,j,it)=0.
+        else
+         qPr(i,j,it)=((pmflxr(i,j+1)+pmflxs(i,j+1))*qPr(i,j+1,it)+&
+                   Pa(i,j)*qPa(i,j,it)+Pm(i,j)*qMel(i,j,it)&
+                   +imp(i,j)/RG*dxpres(i,j)*tr(i,j,it))/&
+                  (pmflxr(i,j+1)+pmflxs(i,j+1)+Pa(i,j)+Pm(i,j))
+        endif
+      endif ! mp nul ou non
+     endif ! condition sur j
+    endif ! kappa
+   ENDDO
+  ENDDO
+
+!! print test descente insaturee
+!  DO j=klev,1,-1
+!   DO i=1,klon
+!     if(it.eq.3) then
+!   write(*,'(I2,2X,a,e20.12,2X,a,e20.12,2X,a,e20.12,2X,a,e20.12,2X,a,e20.12,2X,a,e20.12,2X,a,e20.12)') j,&
+!!         'zmfdam',zmfdam(i,j,it),'zmfpsi',zmfphi2(i,j,it),&
+!          'zmfdam+zmfpsi',zmfdam(i,j,it)+zmfphi2(i,j,it),'qpmMint',qpmMint(i,j,it),&
+!          'Pm',Pm(i,j),'Mint',Mint(i,j),&
+!!          'zmfa',zmfa(i,j,it),'zmfp',zmfp(i,j,it),&
+!        'zmfdam',zmfdam(i,j,it),'zmfpsi',zmfphi2(i,j,it),'zmfd1a',zmfd1a(i,j,it)
+!!          'Pa',Pa(i,j),'eplaMm',eplaMm(i,j)
+!!         'zmfd1a=da1*qa',zmfd1a(i,j,it),'Pa*qPa',wdtrainA(i,j)*qPa(i,j,it),'da1',d1a(i,j)
+!     endif
+!   ENDDO
+!  ENDDO
+
+
+! ===================================================
+! calcul final des tendances
+! ===================================================
+
+  DO k=klev-1,1,-1
+    DO i=1, klon
+! transport
+     tdcvMA=zmfd(i,k,it)+zmfu(i,k,it)+zmfa(i,k,it)+zmfp(i,k,it)   ! double comptage des downdraft insatures
+     trsptrac=zmfu(i,k,it)+zmfa(i,k,it)+zmfp(i,k,it)
+! lessivage courants satures
+!JE     scavtrac=-ccntrAA_coef*zmfd1a(i,k,it)&
+!JE               -zmfphi2(i,k,it)*ccntrENV_coef&
+!JE               -zmfdam(i,k,it)*ccntrAA_coef
+     scavtrac=-ccntrAA_coef3d(i,k)*zmfd1a(i,k,it)&
+               -zmfphi2(i,k,it)*ccntrENV_coef3d(i,k)&
+               -zmfdam(i,k,it)*ccntrAA_coef3d(i,k)
+! lessivage courants insatures
+   if(k.le.inb(i).and.k.gt.1) then   ! tendances dans le nuage
+!------------------------------------------------------------- detrainement
+      if(mp(i,k+1).gt.mp(i,k).and.mp(i,k+1).gt.1.e-10) then
+        uscavtrac= (-mp(i,k)+mp(i,k+1))*(qDi(i,k,it)-tr(i,k,it))&
+                   + mp(i,k)*(tr(i,k-1,it)-tr(i,k,it))
+!
+!        if(it.eq.3) write(*,'(I2,1X,a,5X,e20.12,82X,a,e20.12)')k,' det incloud',&
+!                    (-mp(i,k)+mp(i,k+1))*(qDi(i,k,it)-tr(i,k,it))*pdtimeRG/dxpres(i,k)+&
+!                    mp(i,k)*(tr(i,k-1,it)-tr(i,k,it))*pdtimeRG/dxpres(i,k),&
+!                    'mp',mp(i,k)
+!------------------------------------------------------------- entrainement 
+      elseif(mp(i,k).gt.mp(i,k+1).and.mp(i,k).gt.1.e-10) then
+         uscavtrac= mp(i,k)*(tr(i,k-1,it)-tr(i,k,it))
+!
+!         if(it.eq.3) write(*,'(I2,1X,a,5X,e20.12,82X,a,e20.12)')k,' ent incloud',uscavtrac*pdtimeRG/dxpres(i,k), 'mp',mp(i,k)
+!=!------------------------------------------------------------- end ent/det 
+      else !        mp(i,k+1)=0. et mp(i,k)=0.    pluie directement sur l environnement
+
+        if(NO_precip(i,k)) then
+          uscavtrac=0.
+!         if(it.eq.3) write(*,'(I2,1X,a,e20.12,82X,a,e20.12)')k,' no P ent incloud',uscavtrac*pdtimeRG/dxpres(i,k), 'mp',mp(i,k)
+        else
+          uscavtrac=-imp(i,k)*tr(i,k,it)*dxpres(i,k)/RG+evap(i,k)*qPr(i,k,it)*dxpres(i,k)/RG
+!         if(it.eq.3) write(*,'(I2,1X,a,3X,e20.12,82X,a,e20.12)')k,' P env incloud',uscavtrac*pdtimeRG/dxpres(i,k), 'mp',mp(i,k)
+!!JE adds
+!         if(it.eq.3) write(*,'(I2,1X,a,3X,e20.12,82X,a,e20.12)')k,' P env incloud',uscavtrac, 'imp',imp(i,k)
+!         if(it.eq.3) write(*,'(I2,1X,a,3X,e20.12,82X,a,e20.12)')k,' P env incloud',uscavtrac, 'tr',tr(i,k,it)
+!         if(it.eq.3) write(*,'(I2,1X,a,3X,e20.12,82X,a,e20.12)')k,' P env incloud',uscavtrac, 'evap',evap(i,k)
+!         if(it.eq.3) write(*,'(I2,1X,a,3X,e20.12,82X,a,e20.12)')k,' P env incloud',uscavtrac, 'qPr',qPr(i,k,it)
+!         if(it.eq.3) write(*,'(I2,1X,a,3X,e20.12,82X,a,e20.12)')k,' P env incloud',uscavtrac, 'dxpres',dxpres(i,k)
+!!Je end
+
+        endif
+      endif  ! mp/det/ent
+!------------------------------------------------------------- premiere couche 
+   elseif(k.eq.1) then  !                                      mp(1)=0.
+      if(mp(i,2).gt.1.e-10) then  !detrainement
+         uscavtrac= (-0.+mp(i,2))*(qDi(i,k,it)-tr(i,k,it)) !&
+!                   + mp(i,2)*(0.-tr(i,k,it))
+!
+!       if(it.eq.3) write(*,'(I2,1X,a,e20.12,84X,a,e20.12)')k,' 1 det',&
+!                  (-0.+mp(i,2))*(qDi(i,k,it)-tr(i,k,it))*pdtimeRG/dxpres(i,k)+&
+!                  mp(i,2)*(0.-tr(i,k,it))*pdtimeRG/dxpres(i,k),&
+!                   'mp',mp(i,k)
+      else   ! mp(2) = 0 = mp(1) pas de descente insaturee, rien ne se passe s'il ne pleut pas, sinon pluie->env
+        if(NO_precip(i,1)) then
+          uscavtrac=0.
+        else
+          uscavtrac=-imp(i,k)*tr(i,k,it)*dxpres(i,k)/RG+evap(i,k)*qPr(i,k,it)*dxpres(i,k)/RG
+        endif
+!         if(it.eq.3) write(*,'(I2,1X,a,2X,e20.12,82X,a,e20.12)')k,'1 P env incloud',uscavtrac*pdtimeRG/dxpres(i,k), 'mp',mp(i,k)
+      endif
+
+   else   ! k > INB  au-dessus du nuage
+    uscavtrac=0.
+   endif
+
+! =====    tendances finales  ======
+     trsptd(i,k,it)=trsptrac*pdtimeRG/dxpres(i,k)              ! td transport sans eau dans courants satures
+     dtrSscav(i,k,it)=scavtrac*pdtimeRG/dxpres(i,k)            ! td du lessivage dans courants satures
+     dtrUscav(i,k,it)=uscavtrac*pdtimeRG/dxpres(i,k)           ! td courant insat
+     dtrsat(i,k,it)=(trsptrac+scavtrac)*pdtimeRG/dxpres(i,k)   ! td courant sat
+     dtrcv(i,k,it)=(trsptrac+scavtrac+uscavtrac)*pdtimeRG/dxpres(i,k)!dtrsat(i,k,it)+dtrUscav(i,k,it)         td conv
+!!!!!!
+     dtrcvMA(i,k,it)=tdcvMA*pdtimeRG/dxpres(i,k) ! MA tendance convection
+     ENDDO
+  ENDDO
+
+! test de conservation du traceur
+!print*,"_____________________________________________________________"
+!print*,"                                                             "
+!      conserv=0.
+!      conservMA=0.
+!      DO k= klev-1,1,-1
+!        DO i=1, klon
+!         conserv=conserv+dtrcv(i,k,it)*   &
+!        (paprs(i,k)-paprs(i,k+1))/RG
+!         conservMA=conservMA+dtrcvMA(i,k,it)*   &
+!        (paprs(i,k)-paprs(i,k+1))/RG
+!
+!      if(it.eq.3)  write(*,'(I2,2X,a,e20.12,2X,a,e20.12,2X,a,e20.12,2X,a,e20.12)') k,&
+!         'MA td ',dtrcvMA(i,k,it)*dxpres(i,k)/RG,&
+!         ' td',dtrcv(i,k,it)*dxpres(i,k)/RG,'         conservMA ',conservMA,'conserv ',conserv
+!!
+!        ENDDO
+!      ENDDO
+!       if(it.eq.3) print *,'it',it,'conserv ',conserv,'conservMA ',conservMA
+
+END SUBROUTINE cvltr_spl
Index: DZ6/trunk/libf/phylmd/cvltrorig.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cvltrorig.F90	(revision 5267)
+++ 	(revision )
@@ -1,166 +1,0 @@
-!
-! $Id $
-!
-SUBROUTINE cvltrorig(it,pdtime,da, phi, mp,paprs,pplay,x,upd,dnd,dx)
-  USE dimphy
-  USE infotrac_phy, ONLY : nbtr
-  IMPLICIT NONE 
-!=====================================================================
-! Objet : convection des traceurs / KE
-! Auteurs: M-A Filiberti and J-Y Grandpeix
-!=====================================================================
-  include "YOMCST.h"
-  include "YOECUMF.h" 
-
-! Entree
-  REAL,INTENT(IN)                           :: pdtime
-  INTEGER, INTENT(IN)                       :: it
-  REAL,DIMENSION(klon,klev),INTENT(IN)      :: da
-  REAL,DIMENSION(klon,klev,klev),INTENT(IN) :: phi
-  REAL,DIMENSION(klon,klev),INTENT(IN)      :: mp
-  REAL,DIMENSION(klon,klev+1),INTENT(IN)    :: paprs ! pression aux 1/2 couches (bas en haut)
-  REAL,DIMENSION(klon,klev),INTENT(IN)      :: pplay ! pression pour le milieu de chaque couche
-  REAL,DIMENSION(klon,klev,nbtr),INTENT(IN)      :: x     ! q de traceur (bas en haut) 
-  REAL,DIMENSION(klon,klev),INTENT(IN)      :: upd   ! saturated updraft mass flux
-  REAL,DIMENSION(klon,klev),INTENT(IN)      :: dnd   ! saturated downdraft mass flux
-
-! Sortie
-  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT) :: dx ! tendance de traceur  (bas en haut)
-
-! Variables locales     
-! REAL,DIMENSION(klon,klev)       :: zed
-  REAL,DIMENSION(klon,klev,klev)  :: zmd
-  REAL,DIMENSION(klon,klev,klev)  :: za
-  REAL,DIMENSION(klon,klev)       :: zmfd,zmfa
-  REAL,DIMENSION(klon,klev)       :: zmfp,zmfu
-  REAL,DIMENSION(klon,klev)       :: deltap
-  INTEGER                         :: i,k,j 
-  REAL                            :: pdtimeRG
-!!  real conserv
-
-! =========================================
-! calcul des tendances liees au downdraft
-! =========================================
-!cdir collapse
-  DO j=1,klev
-  DO i=1,klon
-!   zed(i,j)=0.
-    zmfd(i,j)=0.
-    zmfa(i,j)=0.
-    zmfu(i,j)=0.
-    zmfp(i,j)=0.
-  END DO
-  END DO
-!cdir collapse
-  DO k=1,klev
-  DO j=1,klev
-  DO i=1,klon
-    zmd(i,j,k)=0.
-    za (i,j,k)=0.
-  END DO
-  END DO
-  END DO
-! entrainement
-! DO k=1,klev-1
-!    DO i=1,klon
-!       zed(i,k)=max(0.,mp(i,k)-mp(i,k+1))
-!    END DO
-! END DO
-
-! calcul de la matrice d echange
-! matrice de distribution de la masse entrainee en k
-
-  DO k=1,klev-1
-     DO i=1,klon
-        zmd(i,k,k)=max(0.,mp(i,k)-mp(i,k+1))
-     END DO
-  END DO
-  DO k=2,klev
-     DO j=k-1,1,-1
-        DO i=1,klon
-           if(mp(i,j+1).ne.0) then
-              zmd(i,j,k)=zmd(i,j+1,k)*min(1.,mp(i,j)/mp(i,j+1))
-           ENDif
-        END DO
-     END DO
-  END DO
-  DO k=1,klev
-     DO j=1,klev-1
-        DO i=1,klon
-           za(i,j,k)=max(0.,zmd(i,j+1,k)-zmd(i,j,k))
-        END DO
-     END DO
-  END DO
-!
-! rajout du terme lie a l ascendance induite
-!
-  DO j=2,klev
-     DO i=1,klon
-        za(i,j,j-1)=za(i,j,j-1)+mp(i,j)
-     END DO
-  END DO
-!
-! tendances
-!            
-  DO k=1,klev
-     DO j=1,klev
-        DO i=1,klon
-           zmfd(i,j)=zmfd(i,j)+za(i,j,k)*(x(i,k,it)-x(i,j,it))
-        END DO
-     END DO
-  END DO
-!
-! =========================================
-! calcul des tendances liees aux flux satures
-! =========================================
-  DO j=1,klev
-     DO i=1,klon
-        zmfa(i,j)=da(i,j)*(x(i,1,it)-x(i,j,it))
-     END DO
-  END DO
-  DO k=1,klev
-     DO j=1,klev
-        DO i=1,klon
-           zmfp(i,j)=zmfp(i,j)+phi(i,j,k)*(x(i,k,it)-x(i,j,it))
-        END DO
-     END DO
-  END DO
-  DO j=1,klev-1
-     DO i=1,klon
-        zmfu(i,j)=max(0.,upd(i,j+1)+dnd(i,j+1))*(x(i,j+1,it)-x(i,j,it))
-     END DO
-  END DO
-  DO j=2,klev
-     DO i=1,klon
-        zmfu(i,j)=zmfu(i,j)+min(0.,upd(i,j)+dnd(i,j))*(x(i,j,it)-x(i,j-1,it))
-     END DO
-  END DO
-
-! =========================================
-! calcul final des tendances
-! =========================================
-  DO k=1, klev
-     DO i=1, klon
-        deltap(i,k)=paprs(i,k)-paprs(i,k+1)
-     ENDDO
-  ENDDO
-  pdtimeRG=pdtime*RG
-!cdir collapse
-  DO k=1, klev
-     DO i=1, klon
-        dx(i,k,it)=(zmfd(i,k)+zmfu(i,k)       &
-                +zmfa(i,k)+zmfp(i,k))*pdtimeRG/deltap(i,k)
-     ENDDO
-  ENDDO
-
-! test de conservation du traceur
-!      conserv=0.
-!      DO k=1, klev
-!        DO i=1, klon
-!         conserv=conserv+dx(i,k,it)*   &
-!          deltap(i,k)/RG
-!        ENDDO
-!      ENDDO
-!      print *,'it',it,'cvltrorig conserv',conserv
-     
-END SUBROUTINE cvltrorig
Index: /LMDZ6/trunk/libf/phylmd/cvltrorig.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/cvltrorig.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/cvltrorig.f90	(revision 5268)
@@ -0,0 +1,166 @@
+!
+! $Id $
+!
+SUBROUTINE cvltrorig(it,pdtime,da, phi, mp,paprs,pplay,x,upd,dnd,dx)
+  USE dimphy
+  USE infotrac_phy, ONLY : nbtr
+  IMPLICIT NONE 
+!=====================================================================
+! Objet : convection des traceurs / KE
+! Auteurs: M-A Filiberti and J-Y Grandpeix
+!=====================================================================
+  include "YOMCST.h"
+  include "YOECUMF.h" 
+
+! Entree
+  REAL,INTENT(IN)                           :: pdtime
+  INTEGER, INTENT(IN)                       :: it
+  REAL,DIMENSION(klon,klev),INTENT(IN)      :: da
+  REAL,DIMENSION(klon,klev,klev),INTENT(IN) :: phi
+  REAL,DIMENSION(klon,klev),INTENT(IN)      :: mp
+  REAL,DIMENSION(klon,klev+1),INTENT(IN)    :: paprs ! pression aux 1/2 couches (bas en haut)
+  REAL,DIMENSION(klon,klev),INTENT(IN)      :: pplay ! pression pour le milieu de chaque couche
+  REAL,DIMENSION(klon,klev,nbtr),INTENT(IN)      :: x     ! q de traceur (bas en haut) 
+  REAL,DIMENSION(klon,klev),INTENT(IN)      :: upd   ! saturated updraft mass flux
+  REAL,DIMENSION(klon,klev),INTENT(IN)      :: dnd   ! saturated downdraft mass flux
+
+! Sortie
+  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT) :: dx ! tendance de traceur  (bas en haut)
+
+! Variables locales     
+! REAL,DIMENSION(klon,klev)       :: zed
+  REAL,DIMENSION(klon,klev,klev)  :: zmd
+  REAL,DIMENSION(klon,klev,klev)  :: za
+  REAL,DIMENSION(klon,klev)       :: zmfd,zmfa
+  REAL,DIMENSION(klon,klev)       :: zmfp,zmfu
+  REAL,DIMENSION(klon,klev)       :: deltap
+  INTEGER                         :: i,k,j 
+  REAL                            :: pdtimeRG
+!!  real conserv
+
+! =========================================
+! calcul des tendances liees au downdraft
+! =========================================
+!cdir collapse
+  DO j=1,klev
+  DO i=1,klon
+!   zed(i,j)=0.
+    zmfd(i,j)=0.
+    zmfa(i,j)=0.
+    zmfu(i,j)=0.
+    zmfp(i,j)=0.
+  END DO
+  END DO
+!cdir collapse
+  DO k=1,klev
+  DO j=1,klev
+  DO i=1,klon
+    zmd(i,j,k)=0.
+    za (i,j,k)=0.
+  END DO
+  END DO
+  END DO
+! entrainement
+! DO k=1,klev-1
+!    DO i=1,klon
+!       zed(i,k)=max(0.,mp(i,k)-mp(i,k+1))
+!    END DO
+! END DO
+
+! calcul de la matrice d echange
+! matrice de distribution de la masse entrainee en k
+
+  DO k=1,klev-1
+     DO i=1,klon
+        zmd(i,k,k)=max(0.,mp(i,k)-mp(i,k+1))
+     END DO
+  END DO
+  DO k=2,klev
+     DO j=k-1,1,-1
+        DO i=1,klon
+           if(mp(i,j+1).ne.0) then
+              zmd(i,j,k)=zmd(i,j+1,k)*min(1.,mp(i,j)/mp(i,j+1))
+           ENDif
+        END DO
+     END DO
+  END DO
+  DO k=1,klev
+     DO j=1,klev-1
+        DO i=1,klon
+           za(i,j,k)=max(0.,zmd(i,j+1,k)-zmd(i,j,k))
+        END DO
+     END DO
+  END DO
+!
+! rajout du terme lie a l ascendance induite
+!
+  DO j=2,klev
+     DO i=1,klon
+        za(i,j,j-1)=za(i,j,j-1)+mp(i,j)
+     END DO
+  END DO
+!
+! tendances
+!            
+  DO k=1,klev
+     DO j=1,klev
+        DO i=1,klon
+           zmfd(i,j)=zmfd(i,j)+za(i,j,k)*(x(i,k,it)-x(i,j,it))
+        END DO
+     END DO
+  END DO
+!
+! =========================================
+! calcul des tendances liees aux flux satures
+! =========================================
+  DO j=1,klev
+     DO i=1,klon
+        zmfa(i,j)=da(i,j)*(x(i,1,it)-x(i,j,it))
+     END DO
+  END DO
+  DO k=1,klev
+     DO j=1,klev
+        DO i=1,klon
+           zmfp(i,j)=zmfp(i,j)+phi(i,j,k)*(x(i,k,it)-x(i,j,it))
+        END DO
+     END DO
+  END DO
+  DO j=1,klev-1
+     DO i=1,klon
+        zmfu(i,j)=max(0.,upd(i,j+1)+dnd(i,j+1))*(x(i,j+1,it)-x(i,j,it))
+     END DO
+  END DO
+  DO j=2,klev
+     DO i=1,klon
+        zmfu(i,j)=zmfu(i,j)+min(0.,upd(i,j)+dnd(i,j))*(x(i,j,it)-x(i,j-1,it))
+     END DO
+  END DO
+
+! =========================================
+! calcul final des tendances
+! =========================================
+  DO k=1, klev
+     DO i=1, klon
+        deltap(i,k)=paprs(i,k)-paprs(i,k+1)
+     ENDDO
+  ENDDO
+  pdtimeRG=pdtime*RG
+!cdir collapse
+  DO k=1, klev
+     DO i=1, klon
+        dx(i,k,it)=(zmfd(i,k)+zmfu(i,k)       &
+                +zmfa(i,k)+zmfp(i,k))*pdtimeRG/deltap(i,k)
+     ENDDO
+  ENDDO
+
+! test de conservation du traceur
+!      conserv=0.
+!      DO k=1, klev
+!        DO i=1, klon
+!         conserv=conserv+dx(i,k,it)*   &
+!          deltap(i,k)/RG
+!        ENDDO
+!      ENDDO
+!      print *,'it',it,'cvltrorig conserv',conserv
+     
+END SUBROUTINE cvltrorig
Index: DZ6/trunk/libf/phylmd/diag_slp.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/diag_slp.F90	(revision 5267)
+++ 	(revision )
@@ -1,45 +1,0 @@
-SUBROUTINE diag_slp(nlon,t,pab,pal,pphis,tasfc,tastd,pmer)
- USE dimphy
- USE phys_output_write_mod
- USE phys_output_ctrlout_mod
- USE phys_local_var_mod
- IMPLICIT NONE
-  !>======================================================================
-  !!
-  !! Auteur(s) I.Musat (LMD/CNRS) date: 20151106
-  !!
-  !! Objet: Calcul pression au niveau de la mer cf. Arpege-IFS 
-  !! ctstar: calcule la temperature de l'air a la surface (tasfc) et
-  !!                 la temperature de l'air standard a la surface (tastd)
-  !! pppmer: calcule la slp a partir de tasfc, tastd, de la pression a la surface (pab1)
-  !!                 et du geopotentiel de la surface
-  !!======================================================================
-  !! nlon--input-R-temperature au milieu de chaque couche (en K)
-  !! t--input-R-temperature au milieu de chaque couche (en K)
-  !! pab--input-R-pression pour chaque inter-couche (en Pa)
-  !! pal---input-R-pression pour le mileu de chaque couche (en Pa)
-  !! pphis---input-R-geopotentiel du sol (en m2/s2)
-  !! tasfc---output-R-temperature air au sol (en K)
-  !! tastd---output-R-temperature air 'standard' au sol (en K)
-  !! pmer---output-R-pression au niveau de la mer (en Pa)
-  !!======================================================================
-  INTEGER nlon
-  REAL t(nlon,klev)
-  REAL pab(nlon,klev+1)
-  REAL pal(nlon,klev)
-  REAL pphis(nlon)
-  REAL tasfc(nlon), tastd(nlon)
-  REAL pmer(nlon)
-!!!
-!!! calcul tasfc et tastd
-  tal1(:)=t(:,1)
-  pab2(:)=pab(:,2)
-  pal1(:)=pal(:,1)
-  CALL ctstar(nlon,1,nlon,tal1,pab2,pal1,pphis,tasfc,tastd)
-!!!
-!!! calcul slp
-  pab1(:)=pab(:,1)
-  CALL pppmer(nlon,1,nlon,pab1,pphis,tasfc,tastd,pmer)
-!
-  RETURN
-  END
Index: /LMDZ6/trunk/libf/phylmd/diag_slp.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/diag_slp.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/diag_slp.f90	(revision 5268)
@@ -0,0 +1,45 @@
+SUBROUTINE diag_slp(nlon,t,pab,pal,pphis,tasfc,tastd,pmer)
+ USE dimphy
+ USE phys_output_write_mod
+ USE phys_output_ctrlout_mod
+ USE phys_local_var_mod
+ IMPLICIT NONE
+  !>======================================================================
+  !!
+  !! Auteur(s) I.Musat (LMD/CNRS) date: 20151106
+  !!
+  !! Objet: Calcul pression au niveau de la mer cf. Arpege-IFS 
+  !! ctstar: calcule la temperature de l'air a la surface (tasfc) et
+  !!                 la temperature de l'air standard a la surface (tastd)
+  !! pppmer: calcule la slp a partir de tasfc, tastd, de la pression a la surface (pab1)
+  !!                 et du geopotentiel de la surface
+  !!======================================================================
+  !! nlon--input-R-temperature au milieu de chaque couche (en K)
+  !! t--input-R-temperature au milieu de chaque couche (en K)
+  !! pab--input-R-pression pour chaque inter-couche (en Pa)
+  !! pal---input-R-pression pour le mileu de chaque couche (en Pa)
+  !! pphis---input-R-geopotentiel du sol (en m2/s2)
+  !! tasfc---output-R-temperature air au sol (en K)
+  !! tastd---output-R-temperature air 'standard' au sol (en K)
+  !! pmer---output-R-pression au niveau de la mer (en Pa)
+  !!======================================================================
+  INTEGER nlon
+  REAL t(nlon,klev)
+  REAL pab(nlon,klev+1)
+  REAL pal(nlon,klev)
+  REAL pphis(nlon)
+  REAL tasfc(nlon), tastd(nlon)
+  REAL pmer(nlon)
+!!!
+!!! calcul tasfc et tastd
+  tal1(:)=t(:,1)
+  pab2(:)=pab(:,2)
+  pal1(:)=pal(:,1)
+  CALL ctstar(nlon,1,nlon,tal1,pab2,pal1,pphis,tasfc,tastd)
+!!!
+!!! calcul slp
+  pab1(:)=pab(:,1)
+  CALL pppmer(nlon,1,nlon,pab1,pphis,tasfc,tastd,pmer)
+!
+  RETURN
+  END
Index: DZ6/trunk/libf/phylmd/diagphy.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/diagphy.F90	(revision 5267)
+++ 	(revision )
@@ -1,402 +1,0 @@
-
-! $Header$
-
-SUBROUTINE diagphy(airephy, tit, iprt, tops, topl, sols, soll, sens, evap, &
-    rain_fall, snow_fall, ts, d_etp_tot, d_qt_tot, d_ec_tot, fs_bound, &
-    fq_bound)
-  ! ======================================================================
-
-  ! Purpose:
-  ! Compute the thermal flux and the watter mass flux at the atmosphere
-  ! boundaries. Print them and also the atmospheric enthalpy change and
-  ! the  atmospheric mass change.
-
-  ! Arguments:
-  ! airephy-------input-R-  grid area
-  ! tit---------input-A15- Comment to be added in PRINT (CHARACTER*15)
-  ! iprt--------input-I-  PRINT level ( <=0 : no PRINT)
-  ! tops(klon)--input-R-  SW rad. at TOA (W/m2), positive up.
-  ! topl(klon)--input-R-  LW rad. at TOA (W/m2), positive down
-  ! sols(klon)--input-R-  Net SW flux above surface (W/m2), positive up
-  ! (i.e. -1 * flux absorbed by the surface)
-  ! soll(klon)--input-R-  Net LW flux above surface (W/m2), positive up
-  ! (i.e. flux emited - flux absorbed by the surface)
-  ! sens(klon)--input-R-  Sensible Flux at surface  (W/m2), positive down
-  ! evap(klon)--input-R-  Evaporation + sublimation watter vapour mass flux
-  ! (kg/m2/s), positive up
-  ! rain_fall(klon)
-  ! --input-R- Liquid  watter mass flux (kg/m2/s), positive down
-  ! snow_fall(klon)
-  ! --input-R- Solid  watter mass flux (kg/m2/s), positive down
-  ! ts(klon)----input-R- Surface temperature (K)
-  ! d_etp_tot---input-R- Heat flux equivalent to atmospheric enthalpy
-  ! change (W/m2)
-  ! d_qt_tot----input-R- Mass flux equivalent to atmospheric watter mass
-  ! change (kg/m2/s)
-  ! d_ec_tot----input-R- Flux equivalent to atmospheric cinetic energy
-  ! change (W/m2)
-
-  ! fs_bound---output-R- Thermal flux at the atmosphere boundaries (W/m2)
-  ! fq_bound---output-R- Watter mass flux at the atmosphere boundaries
-  ! (kg/m2/s)
-
-  ! J.L. Dufresne, July 2002
-  ! Version prise sur
-  ! ~rlmd833/LMDZOR_201102/modipsl/modeles/LMDZ.3.3/libf/phylmd
-  ! le 25 Novembre 2002.
-  ! ======================================================================
-
-  USE dimphy
-  IMPLICIT NONE
-
-  include "YOMCST.h"
-  include "YOETHF.h"
-
-  ! Input variables
-  REAL airephy(klon)
-  CHARACTER *15 tit
-  INTEGER iprt
-  REAL tops(klon), topl(klon), sols(klon), soll(klon)
-  REAL sens(klon), evap(klon), rain_fall(klon), snow_fall(klon)
-  REAL ts(klon)
-  REAL d_etp_tot, d_qt_tot, d_ec_tot
-  ! Output variables
-  REAL fs_bound, fq_bound
-
-  ! Local variables
-  REAL stops, stopl, ssols, ssoll
-  REAL ssens, sfront, slat
-  REAL airetot, zcpvap, zcwat, zcice
-  REAL rain_fall_tot, snow_fall_tot, evap_tot
-
-  INTEGER i
-
-  INTEGER pas
-  SAVE pas
-  DATA pas/0/
-  !$OMP THREADPRIVATE(pas)
-
-  pas = pas + 1
-  stops = 0.
-  stopl = 0.
-  ssols = 0.
-  ssoll = 0.
-  ssens = 0.
-  sfront = 0.
-  evap_tot = 0.
-  rain_fall_tot = 0.
-  snow_fall_tot = 0.
-  airetot = 0.
-
-  ! Pour les chaleur specifiques de la vapeur d'eau, de l'eau et de
-  ! la glace, on travaille par difference a la chaleur specifique de l'
-  ! air sec. En effet, comme on travaille a niveau de pression donne,
-  ! toute variation de la masse d'un constituant est totalement
-  ! compense par une variation de masse d'air.
-
-  zcpvap = rcpv - rcpd
-  zcwat = rcw - rcpd
-  zcice = rcs - rcpd
-
-  DO i = 1, klon
-    stops = stops + tops(i)*airephy(i)
-    stopl = stopl + topl(i)*airephy(i)
-    ssols = ssols + sols(i)*airephy(i)
-    ssoll = ssoll + soll(i)*airephy(i)
-    ssens = ssens + sens(i)*airephy(i)
-    sfront = sfront + (evap(i)*zcpvap-rain_fall(i)*zcwat-snow_fall(i)*zcice)* &
-      ts(i)*airephy(i)
-    evap_tot = evap_tot + evap(i)*airephy(i)
-    rain_fall_tot = rain_fall_tot + rain_fall(i)*airephy(i)
-    snow_fall_tot = snow_fall_tot + snow_fall(i)*airephy(i)
-    airetot = airetot + airephy(i)
-  END DO
-  stops = stops/airetot
-  stopl = stopl/airetot
-  ssols = ssols/airetot
-  ssoll = ssoll/airetot
-  ssens = ssens/airetot
-  sfront = sfront/airetot
-  evap_tot = evap_tot/airetot
-  rain_fall_tot = rain_fall_tot/airetot
-  snow_fall_tot = snow_fall_tot/airetot
-
-  slat = rlvtt*rain_fall_tot + rlstt*snow_fall_tot
-  ! Heat flux at atm. boundaries
-  fs_bound = stops - stopl - (ssols+ssoll) + ssens + sfront + slat
-  ! Watter flux at atm. boundaries
-  fq_bound = evap_tot - rain_fall_tot - snow_fall_tot
-
-  IF (iprt>=1) WRITE (6, 6666) tit, pas, fs_bound, d_etp_tot, fq_bound, &
-    d_qt_tot
-
-  IF (iprt>=1) WRITE (6, 6668) tit, pas, d_etp_tot + d_ec_tot - fs_bound, &
-    d_qt_tot - fq_bound
-
-  IF (iprt>=2) WRITE (6, 6667) tit, pas, stops, stopl, ssols, ssoll, ssens, &
-    slat, evap_tot, rain_fall_tot + snow_fall_tot
-
-  RETURN
-
-6666 FORMAT ('Phys. Flux Budget ', A15, 1I6, 2F8.2, 2(1PE13.5))
-6667 FORMAT ('Phys. Boundary Flux ', A15, 1I6, 6F8.2, 2(1PE13.5))
-6668 FORMAT ('Phys. Total Budget ', A15, 1I6, F8.2, 2(1PE13.5))
-
-END SUBROUTINE diagphy
-
-! ======================================================================
-SUBROUTINE diagetpq(airephy, tit, iprt, idiag, idiag2, dtime, t, q, ql, qs, &
-    u, v, paprs, pplay, d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec)
-  ! ======================================================================
-
-  ! Purpose:
-  ! Calcul la difference d'enthalpie et de masse d'eau entre 2 appels,
-  ! et calcul le flux de chaleur et le flux d'eau necessaire a ces
-  ! changements. Ces valeurs sont moyennees sur la surface de tout
-  ! le globe et sont exprime en W/2 et kg/s/m2
-  ! Outil pour diagnostiquer la conservation de l'energie
-  ! et de la masse dans la physique. Suppose que les niveau de
-  ! pression entre couche ne varie pas entre 2 appels.
-
-  ! Plusieurs de ces diagnostics peuvent etre fait en parallele: les
-  ! bilans sont sauvegardes dans des tableaux indices. On parlera
-  ! "d'indice de diagnostic"
-
-
-  ! ======================================================================
-  ! Arguments:
-  ! airephy-------input-R-  grid area
-  ! tit-----imput-A15- Comment added in PRINT (CHARACTER*15)
-  ! iprt----input-I-  PRINT level ( <=1 : no PRINT)
-  ! idiag---input-I- indice dans lequel sera range les nouveaux
-  ! bilans d' entalpie et de masse
-  ! idiag2--input-I-les nouveaux bilans d'entalpie et de masse
-  ! sont compare au bilan de d'enthalpie de masse de
-  ! l'indice numero idiag2
-  ! Cas parriculier : si idiag2=0, pas de comparaison, on
-  ! sort directement les bilans d'enthalpie et de masse
-  ! dtime----input-R- time step (s)
-  ! t--------input-R- temperature (K)
-  ! q--------input-R- vapeur d'eau (kg/kg)
-  ! ql-------input-R- liquid watter (kg/kg)
-  ! qs-------input-R- solid watter (kg/kg)
-  ! u--------input-R- vitesse u
-  ! v--------input-R- vitesse v
-  ! paprs----input-R- pression a intercouche (Pa)
-  ! pplay----input-R- pression au milieu de couche (Pa)
-
-  ! the following total value are computed by UNIT of earth surface
-
-  ! d_h_vcol--output-R- Heat flux (W/m2) define as the Enthalpy
-  ! change (J/m2) during one time step (dtime) for the whole
-  ! atmosphere (air, watter vapour, liquid and solid)
-  ! d_qt------output-R- total water mass flux (kg/m2/s) defined as the
-  ! total watter (kg/m2) change during one time step (dtime),
-  ! d_qw------output-R- same, for the watter vapour only (kg/m2/s)
-  ! d_ql------output-R- same, for the liquid watter only (kg/m2/s)
-  ! d_qs------output-R- same, for the solid watter only (kg/m2/s)
-  ! d_ec------output-R- Cinetic Energy Budget (W/m2) for vertical air column
-
-  ! other (COMMON...)
-  ! RCPD, RCPV, ....
-
-  ! J.L. Dufresne, July 2002
-  ! ======================================================================
-
-  USE dimphy
-  IMPLICIT NONE
-
-  include "YOMCST.h"
-  include "YOETHF.h"
-
-  ! Input variables
-  REAL airephy(klon)
-  CHARACTER *15 tit
-  INTEGER iprt, idiag, idiag2
-  REAL dtime
-  REAL t(klon, klev), q(klon, klev), ql(klon, klev), qs(klon, klev)
-  REAL u(klon, klev), v(klon, klev)
-  REAL paprs(klon, klev+1), pplay(klon, klev)
-  ! Output variables
-  REAL d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec
-
-  ! Local variables
-
-  REAL h_vcol_tot, h_dair_tot, h_qw_tot, h_ql_tot, h_qs_tot, qw_tot, ql_tot, &
-    qs_tot, ec_tot
-  ! h_vcol_tot--  total enthalpy of vertical air column
-  ! (air with watter vapour, liquid and solid) (J/m2)
-  ! h_dair_tot-- total enthalpy of dry air (J/m2)
-  ! h_qw_tot----  total enthalpy of watter vapour (J/m2)
-  ! h_ql_tot----  total enthalpy of liquid watter (J/m2)
-  ! h_qs_tot----  total enthalpy of solid watter  (J/m2)
-  ! qw_tot------  total mass of watter vapour (kg/m2)
-  ! ql_tot------  total mass of liquid watter (kg/m2)
-  ! qs_tot------  total mass of solid watter (kg/m2)
-  ! ec_tot------  total cinetic energy (kg/m2)
-
-  REAL zairm(klon, klev) ! layer air mass (kg/m2)
-  REAL zqw_col(klon)
-  REAL zql_col(klon)
-  REAL zqs_col(klon)
-  REAL zec_col(klon)
-  REAL zh_dair_col(klon)
-  REAL zh_qw_col(klon), zh_ql_col(klon), zh_qs_col(klon)
-
-  REAL d_h_dair, d_h_qw, d_h_ql, d_h_qs
-
-  REAL airetot, zcpvap, zcwat, zcice
-
-  INTEGER i, k
-
-  INTEGER ndiag ! max number of diagnostic in parallel
-  PARAMETER (ndiag=10)
-  INTEGER pas(ndiag)
-  SAVE pas
-  DATA pas/ndiag*0/
-  !$OMP THREADPRIVATE(pas)
-
-  REAL h_vcol_pre(ndiag), h_dair_pre(ndiag), h_qw_pre(ndiag), &
-    h_ql_pre(ndiag), h_qs_pre(ndiag), qw_pre(ndiag), ql_pre(ndiag), &
-    qs_pre(ndiag), ec_pre(ndiag)
-  SAVE h_vcol_pre, h_dair_pre, h_qw_pre, h_ql_pre, h_qs_pre, qw_pre, ql_pre, &
-    qs_pre, ec_pre
-  !$OMP THREADPRIVATE(h_vcol_pre, h_dair_pre, h_qw_pre, h_ql_pre)
-  !$OMP THREADPRIVATE(h_qs_pre, qw_pre, ql_pre, qs_pre , ec_pre)
-  ! ======================================================================
-
-  DO k = 1, klev
-    DO i = 1, klon
-      ! layer air mass
-      zairm(i, k) = (paprs(i,k)-paprs(i,k+1))/rg
-    END DO
-  END DO
-
-  ! Reset variables
-  DO i = 1, klon
-    zqw_col(i) = 0.
-    zql_col(i) = 0.
-    zqs_col(i) = 0.
-    zec_col(i) = 0.
-    zh_dair_col(i) = 0.
-    zh_qw_col(i) = 0.
-    zh_ql_col(i) = 0.
-    zh_qs_col(i) = 0.
-  END DO
-
-  zcpvap = rcpv
-  zcwat = rcw
-  zcice = rcs
-
-  ! Compute vertical sum for each atmospheric column
-  ! ================================================
-  DO k = 1, klev
-    DO i = 1, klon
-      ! Watter mass
-      zqw_col(i) = zqw_col(i) + q(i, k)*zairm(i, k)
-      zql_col(i) = zql_col(i) + ql(i, k)*zairm(i, k)
-      zqs_col(i) = zqs_col(i) + qs(i, k)*zairm(i, k)
-      ! Cinetic Energy
-      zec_col(i) = zec_col(i) + 0.5*(u(i,k)**2+v(i,k)**2)*zairm(i, k)
-      ! Air enthalpy
-      zh_dair_col(i) = zh_dair_col(i) + rcpd*(1.-q(i,k)-ql(i,k)-qs(i,k))* &
-        zairm(i, k)*t(i, k)
-      zh_qw_col(i) = zh_qw_col(i) + zcpvap*q(i, k)*zairm(i, k)*t(i, k)
-      zh_ql_col(i) = zh_ql_col(i) + zcwat*ql(i, k)*zairm(i, k)*t(i, k) - &
-        rlvtt*ql(i, k)*zairm(i, k)
-      zh_qs_col(i) = zh_qs_col(i) + zcice*qs(i, k)*zairm(i, k)*t(i, k) - &
-        rlstt*qs(i, k)*zairm(i, k)
-
-    END DO
-  END DO
-
-  ! Mean over the planete surface
-  ! =============================
-  qw_tot = 0.
-  ql_tot = 0.
-  qs_tot = 0.
-  ec_tot = 0.
-  h_vcol_tot = 0.
-  h_dair_tot = 0.
-  h_qw_tot = 0.
-  h_ql_tot = 0.
-  h_qs_tot = 0.
-  airetot = 0.
-
-  DO i = 1, klon
-    qw_tot = qw_tot + zqw_col(i)*airephy(i)
-    ql_tot = ql_tot + zql_col(i)*airephy(i)
-    qs_tot = qs_tot + zqs_col(i)*airephy(i)
-    ec_tot = ec_tot + zec_col(i)*airephy(i)
-    h_dair_tot = h_dair_tot + zh_dair_col(i)*airephy(i)
-    h_qw_tot = h_qw_tot + zh_qw_col(i)*airephy(i)
-    h_ql_tot = h_ql_tot + zh_ql_col(i)*airephy(i)
-    h_qs_tot = h_qs_tot + zh_qs_col(i)*airephy(i)
-    airetot = airetot + airephy(i)
-  END DO
-
-  qw_tot = qw_tot/airetot
-  ql_tot = ql_tot/airetot
-  qs_tot = qs_tot/airetot
-  ec_tot = ec_tot/airetot
-  h_dair_tot = h_dair_tot/airetot
-  h_qw_tot = h_qw_tot/airetot
-  h_ql_tot = h_ql_tot/airetot
-  h_qs_tot = h_qs_tot/airetot
-
-  h_vcol_tot = h_dair_tot + h_qw_tot + h_ql_tot + h_qs_tot
-
-  ! Compute the change of the atmospheric state compare to the one
-  ! stored in "idiag2", and convert it in flux. THis computation
-  ! is performed IF idiag2 /= 0 and IF it is not the first CALL
-  ! for "idiag"
-  ! ===================================
-
-  IF ((idiag2>0) .AND. (pas(idiag2)/=0)) THEN
-    d_h_vcol = (h_vcol_tot-h_vcol_pre(idiag2))/dtime
-    d_h_dair = (h_dair_tot-h_dair_pre(idiag2))/dtime
-    d_h_qw = (h_qw_tot-h_qw_pre(idiag2))/dtime
-    d_h_ql = (h_ql_tot-h_ql_pre(idiag2))/dtime
-    d_h_qs = (h_qs_tot-h_qs_pre(idiag2))/dtime
-    d_qw = (qw_tot-qw_pre(idiag2))/dtime
-    d_ql = (ql_tot-ql_pre(idiag2))/dtime
-    d_qs = (qs_tot-qs_pre(idiag2))/dtime
-    d_ec = (ec_tot-ec_pre(idiag2))/dtime
-    d_qt = d_qw + d_ql + d_qs
-  ELSE
-    d_h_vcol = 0.
-    d_h_dair = 0.
-    d_h_qw = 0.
-    d_h_ql = 0.
-    d_h_qs = 0.
-    d_qw = 0.
-    d_ql = 0.
-    d_qs = 0.
-    d_ec = 0.
-    d_qt = 0.
-  END IF
-
-  IF (iprt>=2) THEN
-    WRITE (6, 9000) tit, pas(idiag), d_qt, d_qw, d_ql, d_qs
-9000 FORMAT ('Phys. Watter Mass Budget (kg/m2/s)', A15, 1I6, 10(1PE14.6))
-    WRITE (6, 9001) tit, pas(idiag), d_h_vcol
-9001 FORMAT ('Phys. Enthalpy Budget (W/m2) ', A15, 1I6, 10(F8.2))
-    WRITE (6, 9002) tit, pas(idiag), d_ec
-9002 FORMAT ('Phys. Cinetic Energy Budget (W/m2) ', A15, 1I6, 10(F8.2))
-  END IF
-
-  ! Store the new atmospheric state in "idiag"
-
-  pas(idiag) = pas(idiag) + 1
-  h_vcol_pre(idiag) = h_vcol_tot
-  h_dair_pre(idiag) = h_dair_tot
-  h_qw_pre(idiag) = h_qw_tot
-  h_ql_pre(idiag) = h_ql_tot
-  h_qs_pre(idiag) = h_qs_tot
-  qw_pre(idiag) = qw_tot
-  ql_pre(idiag) = ql_tot
-  qs_pre(idiag) = qs_tot
-  ec_pre(idiag) = ec_tot
-
-  RETURN
-END SUBROUTINE diagetpq
Index: /LMDZ6/trunk/libf/phylmd/diagphy.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/diagphy.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/diagphy.f90	(revision 5268)
@@ -0,0 +1,402 @@
+
+! $Header$
+
+SUBROUTINE diagphy(airephy, tit, iprt, tops, topl, sols, soll, sens, evap, &
+    rain_fall, snow_fall, ts, d_etp_tot, d_qt_tot, d_ec_tot, fs_bound, &
+    fq_bound)
+  ! ======================================================================
+
+  ! Purpose:
+  ! Compute the thermal flux and the watter mass flux at the atmosphere
+  ! boundaries. Print them and also the atmospheric enthalpy change and
+  ! the  atmospheric mass change.
+
+  ! Arguments:
+  ! airephy-------input-R-  grid area
+  ! tit---------input-A15- Comment to be added in PRINT (CHARACTER*15)
+  ! iprt--------input-I-  PRINT level ( <=0 : no PRINT)
+  ! tops(klon)--input-R-  SW rad. at TOA (W/m2), positive up.
+  ! topl(klon)--input-R-  LW rad. at TOA (W/m2), positive down
+  ! sols(klon)--input-R-  Net SW flux above surface (W/m2), positive up
+  ! (i.e. -1 * flux absorbed by the surface)
+  ! soll(klon)--input-R-  Net LW flux above surface (W/m2), positive up
+  ! (i.e. flux emited - flux absorbed by the surface)
+  ! sens(klon)--input-R-  Sensible Flux at surface  (W/m2), positive down
+  ! evap(klon)--input-R-  Evaporation + sublimation watter vapour mass flux
+  ! (kg/m2/s), positive up
+  ! rain_fall(klon)
+  ! --input-R- Liquid  watter mass flux (kg/m2/s), positive down
+  ! snow_fall(klon)
+  ! --input-R- Solid  watter mass flux (kg/m2/s), positive down
+  ! ts(klon)----input-R- Surface temperature (K)
+  ! d_etp_tot---input-R- Heat flux equivalent to atmospheric enthalpy
+  ! change (W/m2)
+  ! d_qt_tot----input-R- Mass flux equivalent to atmospheric watter mass
+  ! change (kg/m2/s)
+  ! d_ec_tot----input-R- Flux equivalent to atmospheric cinetic energy
+  ! change (W/m2)
+
+  ! fs_bound---output-R- Thermal flux at the atmosphere boundaries (W/m2)
+  ! fq_bound---output-R- Watter mass flux at the atmosphere boundaries
+  ! (kg/m2/s)
+
+  ! J.L. Dufresne, July 2002
+  ! Version prise sur
+  ! ~rlmd833/LMDZOR_201102/modipsl/modeles/LMDZ.3.3/libf/phylmd
+  ! le 25 Novembre 2002.
+  ! ======================================================================
+
+  USE dimphy
+  IMPLICIT NONE
+
+  include "YOMCST.h"
+  include "YOETHF.h"
+
+  ! Input variables
+  REAL airephy(klon)
+  CHARACTER *15 tit
+  INTEGER iprt
+  REAL tops(klon), topl(klon), sols(klon), soll(klon)
+  REAL sens(klon), evap(klon), rain_fall(klon), snow_fall(klon)
+  REAL ts(klon)
+  REAL d_etp_tot, d_qt_tot, d_ec_tot
+  ! Output variables
+  REAL fs_bound, fq_bound
+
+  ! Local variables
+  REAL stops, stopl, ssols, ssoll
+  REAL ssens, sfront, slat
+  REAL airetot, zcpvap, zcwat, zcice
+  REAL rain_fall_tot, snow_fall_tot, evap_tot
+
+  INTEGER i
+
+  INTEGER pas
+  SAVE pas
+  DATA pas/0/
+  !$OMP THREADPRIVATE(pas)
+
+  pas = pas + 1
+  stops = 0.
+  stopl = 0.
+  ssols = 0.
+  ssoll = 0.
+  ssens = 0.
+  sfront = 0.
+  evap_tot = 0.
+  rain_fall_tot = 0.
+  snow_fall_tot = 0.
+  airetot = 0.
+
+  ! Pour les chaleur specifiques de la vapeur d'eau, de l'eau et de
+  ! la glace, on travaille par difference a la chaleur specifique de l'
+  ! air sec. En effet, comme on travaille a niveau de pression donne,
+  ! toute variation de la masse d'un constituant est totalement
+  ! compense par une variation de masse d'air.
+
+  zcpvap = rcpv - rcpd
+  zcwat = rcw - rcpd
+  zcice = rcs - rcpd
+
+  DO i = 1, klon
+    stops = stops + tops(i)*airephy(i)
+    stopl = stopl + topl(i)*airephy(i)
+    ssols = ssols + sols(i)*airephy(i)
+    ssoll = ssoll + soll(i)*airephy(i)
+    ssens = ssens + sens(i)*airephy(i)
+    sfront = sfront + (evap(i)*zcpvap-rain_fall(i)*zcwat-snow_fall(i)*zcice)* &
+      ts(i)*airephy(i)
+    evap_tot = evap_tot + evap(i)*airephy(i)
+    rain_fall_tot = rain_fall_tot + rain_fall(i)*airephy(i)
+    snow_fall_tot = snow_fall_tot + snow_fall(i)*airephy(i)
+    airetot = airetot + airephy(i)
+  END DO
+  stops = stops/airetot
+  stopl = stopl/airetot
+  ssols = ssols/airetot
+  ssoll = ssoll/airetot
+  ssens = ssens/airetot
+  sfront = sfront/airetot
+  evap_tot = evap_tot/airetot
+  rain_fall_tot = rain_fall_tot/airetot
+  snow_fall_tot = snow_fall_tot/airetot
+
+  slat = rlvtt*rain_fall_tot + rlstt*snow_fall_tot
+  ! Heat flux at atm. boundaries
+  fs_bound = stops - stopl - (ssols+ssoll) + ssens + sfront + slat
+  ! Watter flux at atm. boundaries
+  fq_bound = evap_tot - rain_fall_tot - snow_fall_tot
+
+  IF (iprt>=1) WRITE (6, 6666) tit, pas, fs_bound, d_etp_tot, fq_bound, &
+    d_qt_tot
+
+  IF (iprt>=1) WRITE (6, 6668) tit, pas, d_etp_tot + d_ec_tot - fs_bound, &
+    d_qt_tot - fq_bound
+
+  IF (iprt>=2) WRITE (6, 6667) tit, pas, stops, stopl, ssols, ssoll, ssens, &
+    slat, evap_tot, rain_fall_tot + snow_fall_tot
+
+  RETURN
+
+6666 FORMAT ('Phys. Flux Budget ', A15, 1I6, 2F8.2, 2(1PE13.5))
+6667 FORMAT ('Phys. Boundary Flux ', A15, 1I6, 6F8.2, 2(1PE13.5))
+6668 FORMAT ('Phys. Total Budget ', A15, 1I6, F8.2, 2(1PE13.5))
+
+END SUBROUTINE diagphy
+
+! ======================================================================
+SUBROUTINE diagetpq(airephy, tit, iprt, idiag, idiag2, dtime, t, q, ql, qs, &
+    u, v, paprs, pplay, d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec)
+  ! ======================================================================
+
+  ! Purpose:
+  ! Calcul la difference d'enthalpie et de masse d'eau entre 2 appels,
+  ! et calcul le flux de chaleur et le flux d'eau necessaire a ces
+  ! changements. Ces valeurs sont moyennees sur la surface de tout
+  ! le globe et sont exprime en W/2 et kg/s/m2
+  ! Outil pour diagnostiquer la conservation de l'energie
+  ! et de la masse dans la physique. Suppose que les niveau de
+  ! pression entre couche ne varie pas entre 2 appels.
+
+  ! Plusieurs de ces diagnostics peuvent etre fait en parallele: les
+  ! bilans sont sauvegardes dans des tableaux indices. On parlera
+  ! "d'indice de diagnostic"
+
+
+  ! ======================================================================
+  ! Arguments:
+  ! airephy-------input-R-  grid area
+  ! tit-----imput-A15- Comment added in PRINT (CHARACTER*15)
+  ! iprt----input-I-  PRINT level ( <=1 : no PRINT)
+  ! idiag---input-I- indice dans lequel sera range les nouveaux
+  ! bilans d' entalpie et de masse
+  ! idiag2--input-I-les nouveaux bilans d'entalpie et de masse
+  ! sont compare au bilan de d'enthalpie de masse de
+  ! l'indice numero idiag2
+  ! Cas parriculier : si idiag2=0, pas de comparaison, on
+  ! sort directement les bilans d'enthalpie et de masse
+  ! dtime----input-R- time step (s)
+  ! t--------input-R- temperature (K)
+  ! q--------input-R- vapeur d'eau (kg/kg)
+  ! ql-------input-R- liquid watter (kg/kg)
+  ! qs-------input-R- solid watter (kg/kg)
+  ! u--------input-R- vitesse u
+  ! v--------input-R- vitesse v
+  ! paprs----input-R- pression a intercouche (Pa)
+  ! pplay----input-R- pression au milieu de couche (Pa)
+
+  ! the following total value are computed by UNIT of earth surface
+
+  ! d_h_vcol--output-R- Heat flux (W/m2) define as the Enthalpy
+  ! change (J/m2) during one time step (dtime) for the whole
+  ! atmosphere (air, watter vapour, liquid and solid)
+  ! d_qt------output-R- total water mass flux (kg/m2/s) defined as the
+  ! total watter (kg/m2) change during one time step (dtime),
+  ! d_qw------output-R- same, for the watter vapour only (kg/m2/s)
+  ! d_ql------output-R- same, for the liquid watter only (kg/m2/s)
+  ! d_qs------output-R- same, for the solid watter only (kg/m2/s)
+  ! d_ec------output-R- Cinetic Energy Budget (W/m2) for vertical air column
+
+  ! other (COMMON...)
+  ! RCPD, RCPV, ....
+
+  ! J.L. Dufresne, July 2002
+  ! ======================================================================
+
+  USE dimphy
+  IMPLICIT NONE
+
+  include "YOMCST.h"
+  include "YOETHF.h"
+
+  ! Input variables
+  REAL airephy(klon)
+  CHARACTER *15 tit
+  INTEGER iprt, idiag, idiag2
+  REAL dtime
+  REAL t(klon, klev), q(klon, klev), ql(klon, klev), qs(klon, klev)
+  REAL u(klon, klev), v(klon, klev)
+  REAL paprs(klon, klev+1), pplay(klon, klev)
+  ! Output variables
+  REAL d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec
+
+  ! Local variables
+
+  REAL h_vcol_tot, h_dair_tot, h_qw_tot, h_ql_tot, h_qs_tot, qw_tot, ql_tot, &
+    qs_tot, ec_tot
+  ! h_vcol_tot--  total enthalpy of vertical air column
+  ! (air with watter vapour, liquid and solid) (J/m2)
+  ! h_dair_tot-- total enthalpy of dry air (J/m2)
+  ! h_qw_tot----  total enthalpy of watter vapour (J/m2)
+  ! h_ql_tot----  total enthalpy of liquid watter (J/m2)
+  ! h_qs_tot----  total enthalpy of solid watter  (J/m2)
+  ! qw_tot------  total mass of watter vapour (kg/m2)
+  ! ql_tot------  total mass of liquid watter (kg/m2)
+  ! qs_tot------  total mass of solid watter (kg/m2)
+  ! ec_tot------  total cinetic energy (kg/m2)
+
+  REAL zairm(klon, klev) ! layer air mass (kg/m2)
+  REAL zqw_col(klon)
+  REAL zql_col(klon)
+  REAL zqs_col(klon)
+  REAL zec_col(klon)
+  REAL zh_dair_col(klon)
+  REAL zh_qw_col(klon), zh_ql_col(klon), zh_qs_col(klon)
+
+  REAL d_h_dair, d_h_qw, d_h_ql, d_h_qs
+
+  REAL airetot, zcpvap, zcwat, zcice
+
+  INTEGER i, k
+
+  INTEGER ndiag ! max number of diagnostic in parallel
+  PARAMETER (ndiag=10)
+  INTEGER pas(ndiag)
+  SAVE pas
+  DATA pas/ndiag*0/
+  !$OMP THREADPRIVATE(pas)
+
+  REAL h_vcol_pre(ndiag), h_dair_pre(ndiag), h_qw_pre(ndiag), &
+    h_ql_pre(ndiag), h_qs_pre(ndiag), qw_pre(ndiag), ql_pre(ndiag), &
+    qs_pre(ndiag), ec_pre(ndiag)
+  SAVE h_vcol_pre, h_dair_pre, h_qw_pre, h_ql_pre, h_qs_pre, qw_pre, ql_pre, &
+    qs_pre, ec_pre
+  !$OMP THREADPRIVATE(h_vcol_pre, h_dair_pre, h_qw_pre, h_ql_pre)
+  !$OMP THREADPRIVATE(h_qs_pre, qw_pre, ql_pre, qs_pre , ec_pre)
+  ! ======================================================================
+
+  DO k = 1, klev
+    DO i = 1, klon
+      ! layer air mass
+      zairm(i, k) = (paprs(i,k)-paprs(i,k+1))/rg
+    END DO
+  END DO
+
+  ! Reset variables
+  DO i = 1, klon
+    zqw_col(i) = 0.
+    zql_col(i) = 0.
+    zqs_col(i) = 0.
+    zec_col(i) = 0.
+    zh_dair_col(i) = 0.
+    zh_qw_col(i) = 0.
+    zh_ql_col(i) = 0.
+    zh_qs_col(i) = 0.
+  END DO
+
+  zcpvap = rcpv
+  zcwat = rcw
+  zcice = rcs
+
+  ! Compute vertical sum for each atmospheric column
+  ! ================================================
+  DO k = 1, klev
+    DO i = 1, klon
+      ! Watter mass
+      zqw_col(i) = zqw_col(i) + q(i, k)*zairm(i, k)
+      zql_col(i) = zql_col(i) + ql(i, k)*zairm(i, k)
+      zqs_col(i) = zqs_col(i) + qs(i, k)*zairm(i, k)
+      ! Cinetic Energy
+      zec_col(i) = zec_col(i) + 0.5*(u(i,k)**2+v(i,k)**2)*zairm(i, k)
+      ! Air enthalpy
+      zh_dair_col(i) = zh_dair_col(i) + rcpd*(1.-q(i,k)-ql(i,k)-qs(i,k))* &
+        zairm(i, k)*t(i, k)
+      zh_qw_col(i) = zh_qw_col(i) + zcpvap*q(i, k)*zairm(i, k)*t(i, k)
+      zh_ql_col(i) = zh_ql_col(i) + zcwat*ql(i, k)*zairm(i, k)*t(i, k) - &
+        rlvtt*ql(i, k)*zairm(i, k)
+      zh_qs_col(i) = zh_qs_col(i) + zcice*qs(i, k)*zairm(i, k)*t(i, k) - &
+        rlstt*qs(i, k)*zairm(i, k)
+
+    END DO
+  END DO
+
+  ! Mean over the planete surface
+  ! =============================
+  qw_tot = 0.
+  ql_tot = 0.
+  qs_tot = 0.
+  ec_tot = 0.
+  h_vcol_tot = 0.
+  h_dair_tot = 0.
+  h_qw_tot = 0.
+  h_ql_tot = 0.
+  h_qs_tot = 0.
+  airetot = 0.
+
+  DO i = 1, klon
+    qw_tot = qw_tot + zqw_col(i)*airephy(i)
+    ql_tot = ql_tot + zql_col(i)*airephy(i)
+    qs_tot = qs_tot + zqs_col(i)*airephy(i)
+    ec_tot = ec_tot + zec_col(i)*airephy(i)
+    h_dair_tot = h_dair_tot + zh_dair_col(i)*airephy(i)
+    h_qw_tot = h_qw_tot + zh_qw_col(i)*airephy(i)
+    h_ql_tot = h_ql_tot + zh_ql_col(i)*airephy(i)
+    h_qs_tot = h_qs_tot + zh_qs_col(i)*airephy(i)
+    airetot = airetot + airephy(i)
+  END DO
+
+  qw_tot = qw_tot/airetot
+  ql_tot = ql_tot/airetot
+  qs_tot = qs_tot/airetot
+  ec_tot = ec_tot/airetot
+  h_dair_tot = h_dair_tot/airetot
+  h_qw_tot = h_qw_tot/airetot
+  h_ql_tot = h_ql_tot/airetot
+  h_qs_tot = h_qs_tot/airetot
+
+  h_vcol_tot = h_dair_tot + h_qw_tot + h_ql_tot + h_qs_tot
+
+  ! Compute the change of the atmospheric state compare to the one
+  ! stored in "idiag2", and convert it in flux. THis computation
+  ! is performed IF idiag2 /= 0 and IF it is not the first CALL
+  ! for "idiag"
+  ! ===================================
+
+  IF ((idiag2>0) .AND. (pas(idiag2)/=0)) THEN
+    d_h_vcol = (h_vcol_tot-h_vcol_pre(idiag2))/dtime
+    d_h_dair = (h_dair_tot-h_dair_pre(idiag2))/dtime
+    d_h_qw = (h_qw_tot-h_qw_pre(idiag2))/dtime
+    d_h_ql = (h_ql_tot-h_ql_pre(idiag2))/dtime
+    d_h_qs = (h_qs_tot-h_qs_pre(idiag2))/dtime
+    d_qw = (qw_tot-qw_pre(idiag2))/dtime
+    d_ql = (ql_tot-ql_pre(idiag2))/dtime
+    d_qs = (qs_tot-qs_pre(idiag2))/dtime
+    d_ec = (ec_tot-ec_pre(idiag2))/dtime
+    d_qt = d_qw + d_ql + d_qs
+  ELSE
+    d_h_vcol = 0.
+    d_h_dair = 0.
+    d_h_qw = 0.
+    d_h_ql = 0.
+    d_h_qs = 0.
+    d_qw = 0.
+    d_ql = 0.
+    d_qs = 0.
+    d_ec = 0.
+    d_qt = 0.
+  END IF
+
+  IF (iprt>=2) THEN
+    WRITE (6, 9000) tit, pas(idiag), d_qt, d_qw, d_ql, d_qs
+9000 FORMAT ('Phys. Watter Mass Budget (kg/m2/s)', A15, 1I6, 10(1PE14.6))
+    WRITE (6, 9001) tit, pas(idiag), d_h_vcol
+9001 FORMAT ('Phys. Enthalpy Budget (W/m2) ', A15, 1I6, 10(F8.2))
+    WRITE (6, 9002) tit, pas(idiag), d_ec
+9002 FORMAT ('Phys. Cinetic Energy Budget (W/m2) ', A15, 1I6, 10(F8.2))
+  END IF
+
+  ! Store the new atmospheric state in "idiag"
+
+  pas(idiag) = pas(idiag) + 1
+  h_vcol_pre(idiag) = h_vcol_tot
+  h_dair_pre(idiag) = h_dair_tot
+  h_qw_pre(idiag) = h_qw_tot
+  h_ql_pre(idiag) = h_ql_tot
+  h_qs_pre(idiag) = h_qs_tot
+  qw_pre(idiag) = qw_tot
+  ql_pre(idiag) = ql_tot
+  qs_pre(idiag) = qs_tot
+  ec_pre(idiag) = ec_tot
+
+  RETURN
+END SUBROUTINE diagetpq
Index: DZ6/trunk/libf/phylmd/dimphy.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/dimphy.F90	(revision 5267)
+++ 	(revision )
@@ -1,62 +1,0 @@
-!
-! $Id$
-!
-  MODULE dimphy
-  
-  INTEGER,SAVE :: klon
-  INTEGER,SAVE :: kdlon
-  INTEGER,SAVE :: kfdia
-  INTEGER,SAVE :: kidia
-  INTEGER,SAVE :: klev
-  INTEGER,SAVE :: klevp1
-  INTEGER,SAVE :: klevm1
-  INTEGER,SAVE :: kflev
-
-!$OMP THREADPRIVATE(klon,kfdia,kidia,kdlon)
-  REAL,save,allocatable,dimension(:) :: zmasq
-!$OMP THREADPRIVATE(zmasq)   
-
-CONTAINS
-  
-  SUBROUTINE Init_dimphy(klon0,klev0)
-  IMPLICIT NONE
-  
-    INTEGER, INTENT(in) :: klon0
-    INTEGER, INTENT(in) :: klev0
-    
-    klon=klon0
-    kdlon=klon
-    kidia=1
-    kfdia=klon
-!$OMP MASTER 
-    klev=klev0
-    klevp1=klev+1
-    klevm1=klev-1
-    kflev=klev
-!$OMP END MASTER    
-    ALLOCATE(zmasq(klon))    
-    zmasq=0.
-    
-  END SUBROUTINE Init_dimphy
-
-  SUBROUTINE Init_dimphy1D(klon0,klev0)
-! 1D special version of dimphy without ALLOCATE(zmasq)
-! which will be allocated in iniphysiq
-  IMPLICIT NONE
-  
-    INTEGER, INTENT(in) :: klon0
-    INTEGER, INTENT(in) :: klev0
-    
-    klon=klon0
-    kdlon=klon
-    kidia=1
-    kfdia=klon
-    klev=klev0
-    klevp1=klev+1
-    klevm1=klev-1
-    kflev=klev
-    
-  END SUBROUTINE Init_dimphy1D
-
-  
-END MODULE dimphy
Index: /LMDZ6/trunk/libf/phylmd/dimphy.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/dimphy.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/dimphy.f90	(revision 5268)
@@ -0,0 +1,62 @@
+!
+! $Id$
+!
+  MODULE dimphy
+  
+  INTEGER,SAVE :: klon
+  INTEGER,SAVE :: kdlon
+  INTEGER,SAVE :: kfdia
+  INTEGER,SAVE :: kidia
+  INTEGER,SAVE :: klev
+  INTEGER,SAVE :: klevp1
+  INTEGER,SAVE :: klevm1
+  INTEGER,SAVE :: kflev
+
+!$OMP THREADPRIVATE(klon,kfdia,kidia,kdlon)
+  REAL,save,allocatable,dimension(:) :: zmasq
+!$OMP THREADPRIVATE(zmasq)   
+
+CONTAINS
+  
+  SUBROUTINE Init_dimphy(klon0,klev0)
+  IMPLICIT NONE
+  
+    INTEGER, INTENT(in) :: klon0
+    INTEGER, INTENT(in) :: klev0
+    
+    klon=klon0
+    kdlon=klon
+    kidia=1
+    kfdia=klon
+!$OMP MASTER 
+    klev=klev0
+    klevp1=klev+1
+    klevm1=klev-1
+    kflev=klev
+!$OMP END MASTER    
+    ALLOCATE(zmasq(klon))    
+    zmasq=0.
+    
+  END SUBROUTINE Init_dimphy
+
+  SUBROUTINE Init_dimphy1D(klon0,klev0)
+! 1D special version of dimphy without ALLOCATE(zmasq)
+! which will be allocated in iniphysiq
+  IMPLICIT NONE
+  
+    INTEGER, INTENT(in) :: klon0
+    INTEGER, INTENT(in) :: klev0
+    
+    klon=klon0
+    kdlon=klon
+    kidia=1
+    kfdia=klon
+    klev=klev0
+    klevp1=klev+1
+    klevm1=klev-1
+    kflev=klev
+    
+  END SUBROUTINE Init_dimphy1D
+
+  
+END MODULE dimphy
Index: /LMDZ6/trunk/libf/phylmd/dyn1d/1DUTILS.h
===================================================================
--- /LMDZ6/trunk/libf/phylmd/dyn1d/1DUTILS.h	(revision 5267)
+++ /LMDZ6/trunk/libf/phylmd/dyn1d/1DUTILS.h	(revision 5268)
@@ -1,3 +1,3 @@
-#include "conf_gcm.F90"
+#include "conf_gcm.f90"
 
 !
Index: DZ6/trunk/libf/phylmd/dyn1d/comconst_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/dyn1d/comconst_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../../dyn3d_common/comconst_mod.F90
Index: /LMDZ6/trunk/libf/phylmd/dyn1d/comconst_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/dyn1d/comconst_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/dyn1d/comconst_mod.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../../dyn3d_common/comconst_mod.f90
Index: DZ6/trunk/libf/phylmd/dyn1d/comvert_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/dyn1d/comvert_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../../dyn3d_common/comvert_mod.F90
Index: /LMDZ6/trunk/libf/phylmd/dyn1d/comvert_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/dyn1d/comvert_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/dyn1d/comvert_mod.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../../dyn3d_common/comvert_mod.f90
Index: DZ6/trunk/libf/phylmd/dyn1d/conf_gcm.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/dyn1d/conf_gcm.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../../dyn3d/conf_gcm.F90
Index: /LMDZ6/trunk/libf/phylmd/dyn1d/conf_gcm.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/dyn1d/conf_gcm.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/dyn1d/conf_gcm.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../../dyn3d/conf_gcm.f90
Index: DZ6/trunk/libf/phylmd/dyn1d/control_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/dyn1d/control_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../../dyn3d_common/control_mod.F90
Index: /LMDZ6/trunk/libf/phylmd/dyn1d/control_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/dyn1d/control_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/dyn1d/control_mod.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../../dyn3d_common/control_mod.f90
Index: DZ6/trunk/libf/phylmd/dyn1d/disvert.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/dyn1d/disvert.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../../dyn3d_common/disvert.F90
Index: /LMDZ6/trunk/libf/phylmd/dyn1d/disvert.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/dyn1d/disvert.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/dyn1d/disvert.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../../dyn3d_common/disvert.f90
Index: DZ6/trunk/libf/phylmd/dyn1d/exner_hyb_m.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/dyn1d/exner_hyb_m.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../../dyn3d_common/exner_hyb_m.F90
Index: /LMDZ6/trunk/libf/phylmd/dyn1d/exner_hyb_m.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/dyn1d/exner_hyb_m.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/dyn1d/exner_hyb_m.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../../dyn3d_common/exner_hyb_m.f90
Index: DZ6/trunk/libf/phylmd/dyn1d/infotrac.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/dyn1d/infotrac.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../../dyn3d_common/infotrac.F90
Index: /LMDZ6/trunk/libf/phylmd/dyn1d/infotrac.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/dyn1d/infotrac.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/dyn1d/infotrac.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../../dyn3d_common/infotrac.f90
Index: DZ6/trunk/libf/phylmd/dyn1d/inigeomphy_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/dyn1d/inigeomphy_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../../dynphy_lonlat/inigeomphy_mod.F90
Index: /LMDZ6/trunk/libf/phylmd/dyn1d/inigeomphy_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/dyn1d/inigeomphy_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/dyn1d/inigeomphy_mod.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../../dynphy_lonlat/inigeomphy_mod.f90
Index: DZ6/trunk/libf/phylmd/dyn1d/logic_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/dyn1d/logic_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../../dyn3d/logic_mod.F90
Index: /LMDZ6/trunk/libf/phylmd/dyn1d/logic_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/dyn1d/logic_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/dyn1d/logic_mod.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../../dyn3d/logic_mod.f90
Index: DZ6/trunk/libf/phylmd/dyn1d/mod_1D_amma_read.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/dyn1d/mod_1D_amma_read.F90	(revision 5267)
+++ 	(revision )
@@ -1,461 +1,0 @@
-MODULE mod_1D_amma_read
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!Declarations specifiques au cas AMMA
-        character*80 :: fich_amma
-! Option du cas AMMA ou on impose la discretisation verticale (Ap,Bp)
-        integer nlev_amma, nt_amma
-
-
-        integer year_ini_amma, day_ini_amma, mth_ini_amma
-        real heure_ini_amma
-        real day_ju_ini_amma   ! Julian day of amma first day
-        parameter (year_ini_amma=2006)
-        parameter (mth_ini_amma=7)
-        parameter (day_ini_amma=10)  ! 10 = 10Juil2006
-        parameter (heure_ini_amma=0.) !0h en secondes
-        real dt_amma
-        parameter (dt_amma=1800.)
-
-!profils initiaux:
-        real, allocatable::  plev_amma(:)
-
-        real, allocatable::  z_amma(:)
-        real, allocatable::  th_amma(:),q_amma(:)
-        real, allocatable::  u_amma(:)
-        real, allocatable::  v_amma(:)
-
-        real, allocatable::  th_ammai(:),q_ammai(:)
-        real, allocatable::  u_ammai(:)
-        real, allocatable::  v_ammai(:)
-        real, allocatable::  vitw_ammai(:)
-        real, allocatable::  ht_ammai(:)
-        real, allocatable::  hq_ammai(:)
-        real, allocatable::  vt_ammai(:)
-        real, allocatable::  vq_ammai(:)
-
-!forcings
-        real, allocatable::  ht_amma(:,:)
-        real, allocatable::  hq_amma(:,:)
-        real, allocatable::  vitw_amma(:,:)
-        real, allocatable::  lat_amma(:),sens_amma(:)
-
-!champs interpoles
-        real, allocatable::  vitw_profamma(:)
-        real, allocatable::  ht_profamma(:)
-        real, allocatable::  hq_profamma(:)
-        real lat_profamma,sens_profamma
-        real, allocatable::  vt_profamma(:)
-        real, allocatable::  vq_profamma(:)
-        real, allocatable::  th_profamma(:)
-        real, allocatable::  q_profamma(:)
-        real, allocatable::  u_profamma(:)
-        real, allocatable::  v_profamma(:)
-
-
-CONTAINS
-
-SUBROUTINE read_1D_cases
-      implicit none
-
-      INCLUDE "netcdf.inc"
-
-      INTEGER nid,rid,ierr
-
-      fich_amma='amma.nc'
-      print*,'fich_amma ',fich_amma
-      ierr = NF_OPEN(fich_amma,NF_NOWRITE,nid)
-      print*,'fich_amma,NF_NOWRITE,nid ',fich_amma,NF_NOWRITE,nid
-      if (ierr.NE.NF_NOERR) then
-         write(*,*) 'ERROR: GROS Pb opening forcings nc file '
-         write(*,*) NF_STRERROR(ierr)
-         stop ""
-      endif
-!.......................................................................
-      ierr=NF_INQ_DIMID(nid,'lev',rid)
-      IF (ierr.NE.NF_NOERR) THEN
-         print*, 'Oh probleme lecture dimension zz'
-      ENDIF
-      ierr=NF_INQ_DIMLEN(nid,rid,nlev_amma)
-      print*,'OK nid,rid,nlev_amma',nid,rid,nlev_amma
-!.......................................................................
-      ierr=NF_INQ_DIMID(nid,'time',rid)
-      print*,'nid,rid',nid,rid
-      nt_amma=0
-      IF (ierr.NE.NF_NOERR) THEN
-        stop 'probleme lecture dimension sens'
-      ENDIF
-      ierr=NF_INQ_DIMLEN(nid,rid,nt_amma)
-      print*,'nid,rid,nlev_amma',nid,rid,nt_amma
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!profils initiaux:
-        allocate(plev_amma(nlev_amma))
-        
-        allocate(z_amma(nlev_amma))
-        allocate(th_amma(nlev_amma),q_amma(nlev_amma))
-        allocate(u_amma(nlev_amma))
-        allocate(v_amma(nlev_amma))
-
-!forcings
-        allocate(ht_amma(nlev_amma,nt_amma))
-        allocate(hq_amma(nlev_amma,nt_amma))
-        allocate(vitw_amma(nlev_amma,nt_amma))
-        allocate(lat_amma(nt_amma),sens_amma(nt_amma))
-
-!profils initiaux:
-        allocate(th_ammai(nlev_amma),q_ammai(nlev_amma))
-        allocate(u_ammai(nlev_amma))
-        allocate(v_ammai(nlev_amma))
-        allocate(vitw_ammai(nlev_amma) )
-        allocate(ht_ammai(nlev_amma))
-        allocate(hq_ammai(nlev_amma))
-        allocate(vt_ammai(nlev_amma))
-        allocate(vq_ammai(nlev_amma))
-
-!champs interpoles
-        allocate(vitw_profamma(nlev_amma))
-        allocate(ht_profamma(nlev_amma))
-        allocate(hq_profamma(nlev_amma))
-        allocate(vt_profamma(nlev_amma))
-        allocate(vq_profamma(nlev_amma))
-        allocate(th_profamma(nlev_amma))
-        allocate(q_profamma(nlev_amma))
-        allocate(u_profamma(nlev_amma))
-        allocate(v_profamma(nlev_amma))
-
-        print*,'Allocations OK'
-        call read_amma(nid,nlev_amma,nt_amma                                  &
-     &     ,z_amma,plev_amma,th_amma,q_amma,u_amma,v_amma,vitw_amma         &
-     &     ,ht_amma,hq_amma,sens_amma,lat_amma)
-
-END SUBROUTINE read_1D_cases
-
-
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-SUBROUTINE deallocate_1D_cases
-!profils initiaux:
-        deallocate(plev_amma)
-        
-        deallocate(z_amma)
-        deallocate(th_amma,q_amma)
-        deallocate(u_amma)
-        deallocate(v_amma)
-
-        deallocate(th_ammai,q_ammai)
-        deallocate(u_ammai)
-        deallocate(v_ammai)
-        deallocate(vitw_ammai )
-        deallocate(ht_ammai)
-        deallocate(hq_ammai)
-        deallocate(vt_ammai)
-        deallocate(vq_ammai)
-        
-!forcings
-        deallocate(ht_amma)
-        deallocate(hq_amma)
-        deallocate(vitw_amma)
-        deallocate(lat_amma,sens_amma)
-
-!champs interpoles
-        deallocate(vitw_profamma)
-        deallocate(ht_profamma)
-        deallocate(hq_profamma)
-        deallocate(vt_profamma)
-        deallocate(vq_profamma)
-        deallocate(th_profamma)
-        deallocate(q_profamma)
-        deallocate(u_profamma)
-        deallocate(v_profamma)
-END SUBROUTINE deallocate_1D_cases
-
-
-END MODULE mod_1D_amma_read
-!=====================================================================
-      subroutine read_amma(nid,nlevel,ntime                          &
-     &     ,zz,pp,temp,qv,u,v,dw                   &
-     &     ,dt,dq,sens,flat)
-
-!program reading forcings of the AMMA case study
-      USE netcdf, ONLY: nf90_get_var
-      implicit none
-      INCLUDE "netcdf.inc"
-
-      integer ntime,nlevel
-
-      real zz(nlevel)
-      real temp(nlevel),pp(nlevel)
-      real qv(nlevel),u(nlevel)
-      real v(nlevel)
-      real dw(nlevel,ntime)
-      real dt(nlevel,ntime)
-      real dq(nlevel,ntime)
-      real flat(ntime),sens(ntime)
-
-
-      integer nid, ierr,rid
-      integer nbvar3d
-      parameter(nbvar3d=30)
-      integer var3didin(nbvar3d)
-
-       ierr=NF_INQ_VARID(nid,"zz",var3didin(1)) 
-         if(ierr/=NF_NOERR) then
-           write(*,*) NF_STRERROR(ierr)
-           stop 'lev'
-         endif
-
-
-      ierr=NF_INQ_VARID(nid,"temp",var3didin(2))
-         if(ierr/=NF_NOERR) then
-           write(*,*) NF_STRERROR(ierr)
-           stop 'temp'
-         endif
-
-      ierr=NF_INQ_VARID(nid,"qv",var3didin(3))
-         if(ierr/=NF_NOERR) then
-           write(*,*) NF_STRERROR(ierr)
-           stop 'qv'
-         endif
-
-      ierr=NF_INQ_VARID(nid,"u",var3didin(4))
-         if(ierr/=NF_NOERR) then
-           write(*,*) NF_STRERROR(ierr)
-           stop 'u'
-         endif
-
-      ierr=NF_INQ_VARID(nid,"v",var3didin(5))
-         if(ierr/=NF_NOERR) then
-           write(*,*) NF_STRERROR(ierr)
-           stop 'v'
-         endif
-
-      ierr=NF_INQ_VARID(nid,"dw",var3didin(6))
-         if(ierr/=NF_NOERR) then
-           write(*,*) NF_STRERROR(ierr)
-           stop 'dw'
-         endif
-
-      ierr=NF_INQ_VARID(nid,"dt",var3didin(7))
-         if(ierr/=NF_NOERR) then
-           write(*,*) NF_STRERROR(ierr)
-           stop 'dt'
-         endif
-
-      ierr=NF_INQ_VARID(nid,"dq",var3didin(8))
-         if(ierr/=NF_NOERR) then
-           write(*,*) NF_STRERROR(ierr)
-           stop 'dq'
-         endif
-      
-      ierr=NF_INQ_VARID(nid,"sens",var3didin(9))
-         if(ierr/=NF_NOERR) then
-           write(*,*) NF_STRERROR(ierr)
-           stop 'sens'
-         endif
-
-      ierr=NF_INQ_VARID(nid,"flat",var3didin(10))
-         if(ierr/=NF_NOERR) then
-           write(*,*) NF_STRERROR(ierr)
-           stop 'flat'
-         endif
-
-      ierr=NF_INQ_VARID(nid,"pp",var3didin(11))
-         if(ierr/=NF_NOERR) then
-           write(*,*) NF_STRERROR(ierr)
-      endif
-
-!dimensions lecture
-!      call catchaxis(nid,ntime,nlevel,time,z,ierr)
- 
-         ierr = nf90_get_var(nid, var3didin(1), zz)
-         if(ierr/=NF_NOERR) then
-            write(*,*) NF_STRERROR(ierr)
-            stop "getvarup"
-         endif
-!          write(*,*)'lecture z ok',zz
-
-         ierr = nf90_get_var(nid, var3didin(2), temp)
-         if(ierr/=NF_NOERR) then
-            write(*,*) NF_STRERROR(ierr)
-            stop "getvarup"
-         endif
-!          write(*,*)'lecture th ok',temp
-
-         ierr = nf90_get_var(nid, var3didin(3), qv)
-         if(ierr/=NF_NOERR) then
-            write(*,*) NF_STRERROR(ierr)
-            stop "getvarup"
-         endif
-!          write(*,*)'lecture qv ok',qv
- 
-         ierr = nf90_get_var(nid, var3didin(4), u)
-         if(ierr/=NF_NOERR) then
-            write(*,*) NF_STRERROR(ierr)
-            stop "getvarup"
-         endif
-!          write(*,*)'lecture u ok',u
-
-         ierr = nf90_get_var(nid, var3didin(5), v)
-         if(ierr/=NF_NOERR) then
-            write(*,*) NF_STRERROR(ierr)
-            stop "getvarup"
-         endif
-!          write(*,*)'lecture v ok',v
-
-         ierr = nf90_get_var(nid, var3didin(6), dw)
-         if(ierr/=NF_NOERR) then
-            write(*,*) NF_STRERROR(ierr)
-            stop "getvarup"
-         endif
-!          write(*,*)'lecture w ok',dw
-
-         ierr = nf90_get_var(nid, var3didin(7), dt)
-         if(ierr/=NF_NOERR) then
-            write(*,*) NF_STRERROR(ierr)
-            stop "getvarup"
-         endif
-!          write(*,*)'lecture dt ok',dt
-
-         ierr = nf90_get_var(nid, var3didin(8), dq)
-         if(ierr/=NF_NOERR) then
-            write(*,*) NF_STRERROR(ierr)
-            stop "getvarup"
-         endif
-!          write(*,*)'lecture dq ok',dq
-
-         ierr = nf90_get_var(nid, var3didin(9), sens)
-         if(ierr/=NF_NOERR) then
-            write(*,*) NF_STRERROR(ierr)
-            stop "getvarup"
-         endif
-!          write(*,*)'lecture sens ok',sens
-
-         ierr = nf90_get_var(nid, var3didin(10), flat)
-         if(ierr/=NF_NOERR) then
-            write(*,*) NF_STRERROR(ierr)
-            stop "getvarup"
-         endif
-!          write(*,*)'lecture flat ok',flat
-
-         ierr = nf90_get_var(nid, var3didin(11), pp)
-         if(ierr/=NF_NOERR) then
-            write(*,*) NF_STRERROR(ierr)
-            stop "getvarup"
-         endif
-!          write(*,*)'lecture pp ok',pp
-
-         return 
-         end subroutine read_amma
-!======================================================================
-        SUBROUTINE interp_amma_time(day,day1,annee_ref                     &
-     &         ,year_ini_amma,day_ini_amma,nt_amma,dt_amma,nlev_amma       &
-     &         ,vitw_amma,ht_amma,hq_amma,lat_amma,sens_amma               &
-     &         ,vitw_prof,ht_prof,hq_prof,lat_prof,sens_prof)
-        implicit none
-
-!---------------------------------------------------------------------------------------
-! Time interpolation of a 2D field to the timestep corresponding to day
-!
-! day: current julian day (e.g. 717538.2)
-! day1: first day of the simulation
-! nt_amma: total nb of data in the forcing (e.g. 48 for AMMA)
-! dt_amma: total time interval (in sec) between 2 forcing data (e.g. 30min for AMMA)
-!---------------------------------------------------------------------------------------
-
-        INCLUDE "compar1d.h"
-
-! inputs:
-        integer annee_ref
-        integer nt_amma,nlev_amma
-        integer year_ini_amma
-        real day, day1,day_ini_amma,dt_amma
-        real vitw_amma(nlev_amma,nt_amma)
-        real ht_amma(nlev_amma,nt_amma)
-        real hq_amma(nlev_amma,nt_amma)
-        real lat_amma(nt_amma)
-        real sens_amma(nt_amma)
-! outputs:
-        real vitw_prof(nlev_amma)
-        real ht_prof(nlev_amma)
-        real hq_prof(nlev_amma)
-        real lat_prof,sens_prof
-! local:
-        integer it_amma1, it_amma2,k
-        real timeit,time_amma1,time_amma2,frac
-
-
-        if (forcing_type.eq.6) then
-! Check that initial day of the simulation consistent with AMMA case:
-       if (annee_ref.ne.2006) then
-        print*,'Pour AMMA, annee_ref doit etre 2006'
-        print*,'Changer annee_ref dans run.def'
-        stop
-       endif
-       if (annee_ref.eq.2006 .and. day1.lt.day_ini_amma) then
-        print*,'AMMA a d�but� le 10 juillet 2006',day1,day_ini_amma
-        print*,'Changer dayref dans run.def'
-        stop
-       endif
-       if (annee_ref.eq.2006 .and. day1.gt.day_ini_amma+1) then
-        print*,'AMMA a fini le 11 juillet'
-        print*,'Changer dayref ou nday dans run.def'
-        stop
-       endif
-       endif
-
-! Determine timestep relative to the 1st day of AMMA:
-!       timeit=(day-day1)*86400.
-!       if (annee_ref.eq.1992) then
-!        timeit=(day-day_ini_toga)*86400.
-!       else
-!        timeit=(day+61.-1.)*86400. ! 61 days between Nov01 and Dec31 1992
-!       endif
-      timeit=(day-day_ini_amma)*86400
-
-! Determine the closest observation times:
-!       it_amma1=INT(timeit/dt_amma)+1
-!       it_amma2=it_amma1 + 1
-!       time_amma1=(it_amma1-1)*dt_amma
-!       time_amma2=(it_amma2-1)*dt_amma
-
-       it_amma1=INT(timeit/dt_amma)+1
-       IF (it_amma1 .EQ. nt_amma) THEN
-       it_amma2=it_amma1 
-       ELSE
-       it_amma2=it_amma1 + 1
-       ENDIF
-       time_amma1=(it_amma1-1)*dt_amma
-       time_amma2=(it_amma2-1)*dt_amma
-
-       if (it_amma1 .gt. nt_amma) then
-        write(*,*) 'PB-stop: day, it_amma1, it_amma2, timeit: '            &
-     &        ,day,day_ini_amma,it_amma1,it_amma2,timeit/86400.
-        stop
-       endif
-
-! time interpolation:
-       IF (it_amma1 .EQ. it_amma2) THEN
-          frac=0.
-       ELSE 
-          frac=(time_amma2-timeit)/(time_amma2-time_amma1)
-          frac=max(frac,0.0)
-       ENDIF
-
-       lat_prof = lat_amma(it_amma2)                                       &
-     &          -frac*(lat_amma(it_amma2)-lat_amma(it_amma1)) 
-       sens_prof = sens_amma(it_amma2)                                     &
-     &          -frac*(sens_amma(it_amma2)-sens_amma(it_amma1))
-
-       do k=1,nlev_amma
-        vitw_prof(k) = vitw_amma(k,it_amma2)                               &
-     &          -frac*(vitw_amma(k,it_amma2)-vitw_amma(k,it_amma1))
-        ht_prof(k) = ht_amma(k,it_amma2)                                   &
-     &          -frac*(ht_amma(k,it_amma2)-ht_amma(k,it_amma1))
-        hq_prof(k) = hq_amma(k,it_amma2)                                   &
-     &          -frac*(hq_amma(k,it_amma2)-hq_amma(k,it_amma1))
-        enddo
-
-        return
-        END
-
Index: /LMDZ6/trunk/libf/phylmd/dyn1d/mod_1D_amma_read.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/dyn1d/mod_1D_amma_read.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/dyn1d/mod_1D_amma_read.f90	(revision 5268)
@@ -0,0 +1,461 @@
+MODULE mod_1D_amma_read
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!Declarations specifiques au cas AMMA
+        character*80 :: fich_amma
+! Option du cas AMMA ou on impose la discretisation verticale (Ap,Bp)
+        integer nlev_amma, nt_amma
+
+
+        integer year_ini_amma, day_ini_amma, mth_ini_amma
+        real heure_ini_amma
+        real day_ju_ini_amma   ! Julian day of amma first day
+        parameter (year_ini_amma=2006)
+        parameter (mth_ini_amma=7)
+        parameter (day_ini_amma=10)  ! 10 = 10Juil2006
+        parameter (heure_ini_amma=0.) !0h en secondes
+        real dt_amma
+        parameter (dt_amma=1800.)
+
+!profils initiaux:
+        real, allocatable::  plev_amma(:)
+
+        real, allocatable::  z_amma(:)
+        real, allocatable::  th_amma(:),q_amma(:)
+        real, allocatable::  u_amma(:)
+        real, allocatable::  v_amma(:)
+
+        real, allocatable::  th_ammai(:),q_ammai(:)
+        real, allocatable::  u_ammai(:)
+        real, allocatable::  v_ammai(:)
+        real, allocatable::  vitw_ammai(:)
+        real, allocatable::  ht_ammai(:)
+        real, allocatable::  hq_ammai(:)
+        real, allocatable::  vt_ammai(:)
+        real, allocatable::  vq_ammai(:)
+
+!forcings
+        real, allocatable::  ht_amma(:,:)
+        real, allocatable::  hq_amma(:,:)
+        real, allocatable::  vitw_amma(:,:)
+        real, allocatable::  lat_amma(:),sens_amma(:)
+
+!champs interpoles
+        real, allocatable::  vitw_profamma(:)
+        real, allocatable::  ht_profamma(:)
+        real, allocatable::  hq_profamma(:)
+        real lat_profamma,sens_profamma
+        real, allocatable::  vt_profamma(:)
+        real, allocatable::  vq_profamma(:)
+        real, allocatable::  th_profamma(:)
+        real, allocatable::  q_profamma(:)
+        real, allocatable::  u_profamma(:)
+        real, allocatable::  v_profamma(:)
+
+
+CONTAINS
+
+SUBROUTINE read_1D_cases
+      implicit none
+
+      INCLUDE "netcdf.inc"
+
+      INTEGER nid,rid,ierr
+
+      fich_amma='amma.nc'
+      print*,'fich_amma ',fich_amma
+      ierr = NF_OPEN(fich_amma,NF_NOWRITE,nid)
+      print*,'fich_amma,NF_NOWRITE,nid ',fich_amma,NF_NOWRITE,nid
+      if (ierr.NE.NF_NOERR) then
+         write(*,*) 'ERROR: GROS Pb opening forcings nc file '
+         write(*,*) NF_STRERROR(ierr)
+         stop ""
+      endif
+!.......................................................................
+      ierr=NF_INQ_DIMID(nid,'lev',rid)
+      IF (ierr.NE.NF_NOERR) THEN
+         print*, 'Oh probleme lecture dimension zz'
+      ENDIF
+      ierr=NF_INQ_DIMLEN(nid,rid,nlev_amma)
+      print*,'OK nid,rid,nlev_amma',nid,rid,nlev_amma
+!.......................................................................
+      ierr=NF_INQ_DIMID(nid,'time',rid)
+      print*,'nid,rid',nid,rid
+      nt_amma=0
+      IF (ierr.NE.NF_NOERR) THEN
+        stop 'probleme lecture dimension sens'
+      ENDIF
+      ierr=NF_INQ_DIMLEN(nid,rid,nt_amma)
+      print*,'nid,rid,nlev_amma',nid,rid,nt_amma
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!profils initiaux:
+        allocate(plev_amma(nlev_amma))
+        
+        allocate(z_amma(nlev_amma))
+        allocate(th_amma(nlev_amma),q_amma(nlev_amma))
+        allocate(u_amma(nlev_amma))
+        allocate(v_amma(nlev_amma))
+
+!forcings
+        allocate(ht_amma(nlev_amma,nt_amma))
+        allocate(hq_amma(nlev_amma,nt_amma))
+        allocate(vitw_amma(nlev_amma,nt_amma))
+        allocate(lat_amma(nt_amma),sens_amma(nt_amma))
+
+!profils initiaux:
+        allocate(th_ammai(nlev_amma),q_ammai(nlev_amma))
+        allocate(u_ammai(nlev_amma))
+        allocate(v_ammai(nlev_amma))
+        allocate(vitw_ammai(nlev_amma) )
+        allocate(ht_ammai(nlev_amma))
+        allocate(hq_ammai(nlev_amma))
+        allocate(vt_ammai(nlev_amma))
+        allocate(vq_ammai(nlev_amma))
+
+!champs interpoles
+        allocate(vitw_profamma(nlev_amma))
+        allocate(ht_profamma(nlev_amma))
+        allocate(hq_profamma(nlev_amma))
+        allocate(vt_profamma(nlev_amma))
+        allocate(vq_profamma(nlev_amma))
+        allocate(th_profamma(nlev_amma))
+        allocate(q_profamma(nlev_amma))
+        allocate(u_profamma(nlev_amma))
+        allocate(v_profamma(nlev_amma))
+
+        print*,'Allocations OK'
+        call read_amma(nid,nlev_amma,nt_amma                                  &
+     &     ,z_amma,plev_amma,th_amma,q_amma,u_amma,v_amma,vitw_amma         &
+     &     ,ht_amma,hq_amma,sens_amma,lat_amma)
+
+END SUBROUTINE read_1D_cases
+
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+SUBROUTINE deallocate_1D_cases
+!profils initiaux:
+        deallocate(plev_amma)
+        
+        deallocate(z_amma)
+        deallocate(th_amma,q_amma)
+        deallocate(u_amma)
+        deallocate(v_amma)
+
+        deallocate(th_ammai,q_ammai)
+        deallocate(u_ammai)
+        deallocate(v_ammai)
+        deallocate(vitw_ammai )
+        deallocate(ht_ammai)
+        deallocate(hq_ammai)
+        deallocate(vt_ammai)
+        deallocate(vq_ammai)
+        
+!forcings
+        deallocate(ht_amma)
+        deallocate(hq_amma)
+        deallocate(vitw_amma)
+        deallocate(lat_amma,sens_amma)
+
+!champs interpoles
+        deallocate(vitw_profamma)
+        deallocate(ht_profamma)
+        deallocate(hq_profamma)
+        deallocate(vt_profamma)
+        deallocate(vq_profamma)
+        deallocate(th_profamma)
+        deallocate(q_profamma)
+        deallocate(u_profamma)
+        deallocate(v_profamma)
+END SUBROUTINE deallocate_1D_cases
+
+
+END MODULE mod_1D_amma_read
+!=====================================================================
+      subroutine read_amma(nid,nlevel,ntime                          &
+     &     ,zz,pp,temp,qv,u,v,dw                   &
+     &     ,dt,dq,sens,flat)
+
+!program reading forcings of the AMMA case study
+      USE netcdf, ONLY: nf90_get_var
+      implicit none
+      INCLUDE "netcdf.inc"
+
+      integer ntime,nlevel
+
+      real zz(nlevel)
+      real temp(nlevel),pp(nlevel)
+      real qv(nlevel),u(nlevel)
+      real v(nlevel)
+      real dw(nlevel,ntime)
+      real dt(nlevel,ntime)
+      real dq(nlevel,ntime)
+      real flat(ntime),sens(ntime)
+
+
+      integer nid, ierr,rid
+      integer nbvar3d
+      parameter(nbvar3d=30)
+      integer var3didin(nbvar3d)
+
+       ierr=NF_INQ_VARID(nid,"zz",var3didin(1)) 
+         if(ierr/=NF_NOERR) then
+           write(*,*) NF_STRERROR(ierr)
+           stop 'lev'
+         endif
+
+
+      ierr=NF_INQ_VARID(nid,"temp",var3didin(2))
+         if(ierr/=NF_NOERR) then
+           write(*,*) NF_STRERROR(ierr)
+           stop 'temp'
+         endif
+
+      ierr=NF_INQ_VARID(nid,"qv",var3didin(3))
+         if(ierr/=NF_NOERR) then
+           write(*,*) NF_STRERROR(ierr)
+           stop 'qv'
+         endif
+
+      ierr=NF_INQ_VARID(nid,"u",var3didin(4))
+         if(ierr/=NF_NOERR) then
+           write(*,*) NF_STRERROR(ierr)
+           stop 'u'
+         endif
+
+      ierr=NF_INQ_VARID(nid,"v",var3didin(5))
+         if(ierr/=NF_NOERR) then
+           write(*,*) NF_STRERROR(ierr)
+           stop 'v'
+         endif
+
+      ierr=NF_INQ_VARID(nid,"dw",var3didin(6))
+         if(ierr/=NF_NOERR) then
+           write(*,*) NF_STRERROR(ierr)
+           stop 'dw'
+         endif
+
+      ierr=NF_INQ_VARID(nid,"dt",var3didin(7))
+         if(ierr/=NF_NOERR) then
+           write(*,*) NF_STRERROR(ierr)
+           stop 'dt'
+         endif
+
+      ierr=NF_INQ_VARID(nid,"dq",var3didin(8))
+         if(ierr/=NF_NOERR) then
+           write(*,*) NF_STRERROR(ierr)
+           stop 'dq'
+         endif
+      
+      ierr=NF_INQ_VARID(nid,"sens",var3didin(9))
+         if(ierr/=NF_NOERR) then
+           write(*,*) NF_STRERROR(ierr)
+           stop 'sens'
+         endif
+
+      ierr=NF_INQ_VARID(nid,"flat",var3didin(10))
+         if(ierr/=NF_NOERR) then
+           write(*,*) NF_STRERROR(ierr)
+           stop 'flat'
+         endif
+
+      ierr=NF_INQ_VARID(nid,"pp",var3didin(11))
+         if(ierr/=NF_NOERR) then
+           write(*,*) NF_STRERROR(ierr)
+      endif
+
+!dimensions lecture
+!      call catchaxis(nid,ntime,nlevel,time,z,ierr)
+ 
+         ierr = nf90_get_var(nid, var3didin(1), zz)
+         if(ierr/=NF_NOERR) then
+            write(*,*) NF_STRERROR(ierr)
+            stop "getvarup"
+         endif
+!          write(*,*)'lecture z ok',zz
+
+         ierr = nf90_get_var(nid, var3didin(2), temp)
+         if(ierr/=NF_NOERR) then
+            write(*,*) NF_STRERROR(ierr)
+            stop "getvarup"
+         endif
+!          write(*,*)'lecture th ok',temp
+
+         ierr = nf90_get_var(nid, var3didin(3), qv)
+         if(ierr/=NF_NOERR) then
+            write(*,*) NF_STRERROR(ierr)
+            stop "getvarup"
+         endif
+!          write(*,*)'lecture qv ok',qv
+ 
+         ierr = nf90_get_var(nid, var3didin(4), u)
+         if(ierr/=NF_NOERR) then
+            write(*,*) NF_STRERROR(ierr)
+            stop "getvarup"
+         endif
+!          write(*,*)'lecture u ok',u
+
+         ierr = nf90_get_var(nid, var3didin(5), v)
+         if(ierr/=NF_NOERR) then
+            write(*,*) NF_STRERROR(ierr)
+            stop "getvarup"
+         endif
+!          write(*,*)'lecture v ok',v
+
+         ierr = nf90_get_var(nid, var3didin(6), dw)
+         if(ierr/=NF_NOERR) then
+            write(*,*) NF_STRERROR(ierr)
+            stop "getvarup"
+         endif
+!          write(*,*)'lecture w ok',dw
+
+         ierr = nf90_get_var(nid, var3didin(7), dt)
+         if(ierr/=NF_NOERR) then
+            write(*,*) NF_STRERROR(ierr)
+            stop "getvarup"
+         endif
+!          write(*,*)'lecture dt ok',dt
+
+         ierr = nf90_get_var(nid, var3didin(8), dq)
+         if(ierr/=NF_NOERR) then
+            write(*,*) NF_STRERROR(ierr)
+            stop "getvarup"
+         endif
+!          write(*,*)'lecture dq ok',dq
+
+         ierr = nf90_get_var(nid, var3didin(9), sens)
+         if(ierr/=NF_NOERR) then
+            write(*,*) NF_STRERROR(ierr)
+            stop "getvarup"
+         endif
+!          write(*,*)'lecture sens ok',sens
+
+         ierr = nf90_get_var(nid, var3didin(10), flat)
+         if(ierr/=NF_NOERR) then
+            write(*,*) NF_STRERROR(ierr)
+            stop "getvarup"
+         endif
+!          write(*,*)'lecture flat ok',flat
+
+         ierr = nf90_get_var(nid, var3didin(11), pp)
+         if(ierr/=NF_NOERR) then
+            write(*,*) NF_STRERROR(ierr)
+            stop "getvarup"
+         endif
+!          write(*,*)'lecture pp ok',pp
+
+         return 
+         end subroutine read_amma
+!======================================================================
+        SUBROUTINE interp_amma_time(day,day1,annee_ref                     &
+     &         ,year_ini_amma,day_ini_amma,nt_amma,dt_amma,nlev_amma       &
+     &         ,vitw_amma,ht_amma,hq_amma,lat_amma,sens_amma               &
+     &         ,vitw_prof,ht_prof,hq_prof,lat_prof,sens_prof)
+        implicit none
+
+!---------------------------------------------------------------------------------------
+! Time interpolation of a 2D field to the timestep corresponding to day
+!
+! day: current julian day (e.g. 717538.2)
+! day1: first day of the simulation
+! nt_amma: total nb of data in the forcing (e.g. 48 for AMMA)
+! dt_amma: total time interval (in sec) between 2 forcing data (e.g. 30min for AMMA)
+!---------------------------------------------------------------------------------------
+
+        INCLUDE "compar1d.h"
+
+! inputs:
+        integer annee_ref
+        integer nt_amma,nlev_amma
+        integer year_ini_amma
+        real day, day1,day_ini_amma,dt_amma
+        real vitw_amma(nlev_amma,nt_amma)
+        real ht_amma(nlev_amma,nt_amma)
+        real hq_amma(nlev_amma,nt_amma)
+        real lat_amma(nt_amma)
+        real sens_amma(nt_amma)
+! outputs:
+        real vitw_prof(nlev_amma)
+        real ht_prof(nlev_amma)
+        real hq_prof(nlev_amma)
+        real lat_prof,sens_prof
+! local:
+        integer it_amma1, it_amma2,k
+        real timeit,time_amma1,time_amma2,frac
+
+
+        if (forcing_type.eq.6) then
+! Check that initial day of the simulation consistent with AMMA case:
+       if (annee_ref.ne.2006) then
+        print*,'Pour AMMA, annee_ref doit etre 2006'
+        print*,'Changer annee_ref dans run.def'
+        stop
+       endif
+       if (annee_ref.eq.2006 .and. day1.lt.day_ini_amma) then
+        print*,'AMMA a d�but� le 10 juillet 2006',day1,day_ini_amma
+        print*,'Changer dayref dans run.def'
+        stop
+       endif
+       if (annee_ref.eq.2006 .and. day1.gt.day_ini_amma+1) then
+        print*,'AMMA a fini le 11 juillet'
+        print*,'Changer dayref ou nday dans run.def'
+        stop
+       endif
+       endif
+
+! Determine timestep relative to the 1st day of AMMA:
+!       timeit=(day-day1)*86400.
+!       if (annee_ref.eq.1992) then
+!        timeit=(day-day_ini_toga)*86400.
+!       else
+!        timeit=(day+61.-1.)*86400. ! 61 days between Nov01 and Dec31 1992
+!       endif
+      timeit=(day-day_ini_amma)*86400
+
+! Determine the closest observation times:
+!       it_amma1=INT(timeit/dt_amma)+1
+!       it_amma2=it_amma1 + 1
+!       time_amma1=(it_amma1-1)*dt_amma
+!       time_amma2=(it_amma2-1)*dt_amma
+
+       it_amma1=INT(timeit/dt_amma)+1
+       IF (it_amma1 .EQ. nt_amma) THEN
+       it_amma2=it_amma1 
+       ELSE
+       it_amma2=it_amma1 + 1
+       ENDIF
+       time_amma1=(it_amma1-1)*dt_amma
+       time_amma2=(it_amma2-1)*dt_amma
+
+       if (it_amma1 .gt. nt_amma) then
+        write(*,*) 'PB-stop: day, it_amma1, it_amma2, timeit: '            &
+     &        ,day,day_ini_amma,it_amma1,it_amma2,timeit/86400.
+        stop
+       endif
+
+! time interpolation:
+       IF (it_amma1 .EQ. it_amma2) THEN
+          frac=0.
+       ELSE 
+          frac=(time_amma2-timeit)/(time_amma2-time_amma1)
+          frac=max(frac,0.0)
+       ENDIF
+
+       lat_prof = lat_amma(it_amma2)                                       &
+     &          -frac*(lat_amma(it_amma2)-lat_amma(it_amma1)) 
+       sens_prof = sens_amma(it_amma2)                                     &
+     &          -frac*(sens_amma(it_amma2)-sens_amma(it_amma1))
+
+       do k=1,nlev_amma
+        vitw_prof(k) = vitw_amma(k,it_amma2)                               &
+     &          -frac*(vitw_amma(k,it_amma2)-vitw_amma(k,it_amma1))
+        ht_prof(k) = ht_amma(k,it_amma2)                                   &
+     &          -frac*(ht_amma(k,it_amma2)-ht_amma(k,it_amma1))
+        hq_prof(k) = hq_amma(k,it_amma2)                                   &
+     &          -frac*(hq_amma(k,it_amma2)-hq_amma(k,it_amma1))
+        enddo
+
+        return
+        END
+
Index: DZ6/trunk/libf/phylmd/dyn1d/mod_1D_cases_read.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/dyn1d/mod_1D_cases_read.F90	(revision 5267)
+++ 	(revision )
@@ -1,1019 +1,0 @@
-!
-! $Id$
-!
-MODULE mod_1D_cases_read
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!Declarations specifiques au cas standard
-        character*80 :: fich_cas
-! Discr?tisation 
-        integer nlev_cas, nt_cas
-
-
-!       integer year_ini_cas, day_ini_cas, mth_ini_cas
-!       real heure_ini_cas
-!       real day_ju_ini_cas   ! Julian day of case first day
-!       parameter (year_ini_cas=2011)
-!       parameter (year_ini_cas=1969)
-!       parameter (mth_ini_cas=10)
-!       parameter (mth_ini_cas=6)
-!       parameter (day_ini_cas=1)  ! 10 = 10Juil2006
-!       parameter (day_ini_cas=24)  ! 24 = 24 juin 1969
-!       parameter (heure_ini_cas=0.) !0h en secondes
-!       real pdt_cas
-!       parameter (pdt_cas=3.*3600)
-
-!CR ATTENTION TEST AMMA
-!        parameter (year_ini_cas=2006)
-!        parameter (mth_ini_cas=7)
-!        parameter (day_ini_cas=10)  ! 10 = 10Juil2006
-!        parameter (heure_ini_cas=0.) !0h en secondes
-!        parameter (pdt_cas=1800.)
-
-!profils environnementaux
-        real, allocatable::  plev_cas(:,:)
-
-        real, allocatable::  z_cas(:,:)
-        real, allocatable::  t_cas(:,:),q_cas(:,:),rh_cas(:,:)
-        real, allocatable::  th_cas(:,:),rv_cas(:,:)
-        real, allocatable::  u_cas(:,:)
-        real, allocatable::  v_cas(:,:)
-
-!forcing
-        real, allocatable::  ht_cas(:,:),vt_cas(:,:),dt_cas(:,:),dtrad_cas(:,:)
-        real, allocatable::  hth_cas(:,:),vth_cas(:,:),dth_cas(:,:)
-        real, allocatable::  hq_cas(:,:),vq_cas(:,:),dq_cas(:,:)
-        real, allocatable::  hr_cas(:,:),vr_cas(:,:),dr_cas(:,:)
-        real, allocatable::  hu_cas(:,:),vu_cas(:,:),du_cas(:,:)
-        real, allocatable::  hv_cas(:,:),vv_cas(:,:),dv_cas(:,:)
-        real, allocatable::  vitw_cas(:,:)
-        real, allocatable::  ug_cas(:,:),vg_cas(:,:)
-        real, allocatable::  lat_cas(:),sens_cas(:),ts_cas(:),ustar_cas(:)
-        real, allocatable::  uw_cas(:,:),vw_cas(:,:),q1_cas(:,:),q2_cas(:,:)
-
-!champs interpoles
-        real, allocatable::  plev_prof_cas(:)
-        real, allocatable::  t_prof_cas(:)
-        real, allocatable::  q_prof_cas(:)
-        real, allocatable::  u_prof_cas(:)
-        real, allocatable::  v_prof_cas(:)        
-
-        real, allocatable::  vitw_prof_cas(:)
-        real, allocatable::  ug_prof_cas(:)
-        real, allocatable::  vg_prof_cas(:)
-        real, allocatable::  ht_prof_cas(:)
-        real, allocatable::  hq_prof_cas(:)
-        real, allocatable::  vt_prof_cas(:)
-        real, allocatable::  vq_prof_cas(:)
-        real, allocatable::  dt_prof_cas(:)
-        real, allocatable::  dtrad_prof_cas(:)
-        real, allocatable::  dq_prof_cas(:)
-        real, allocatable::  hu_prof_cas(:)
-        real, allocatable::  hv_prof_cas(:)
-        real, allocatable::  vu_prof_cas(:)
-        real, allocatable::  vv_prof_cas(:)
-        real, allocatable::  du_prof_cas(:)
-        real, allocatable::  dv_prof_cas(:)
-        real, allocatable::  uw_prof_cas(:)
-        real, allocatable::  vw_prof_cas(:)
-        real, allocatable::  q1_prof_cas(:)
-        real, allocatable::  q2_prof_cas(:)
-
-
-        real lat_prof_cas,sens_prof_cas,ts_prof_cas,ustar_prof_cas
-      
-
-
-CONTAINS
-
-SUBROUTINE read_1D_cas
-      implicit none
-
-      INCLUDE "netcdf.inc"
-
-      INTEGER nid,rid,ierr
-      INTEGER ii,jj
-
-      fich_cas='setup/cas.nc'
-      print*,'fich_cas ',fich_cas
-      ierr = NF_OPEN(fich_cas,NF_NOWRITE,nid)
-      print*,'fich_cas,NF_NOWRITE,nid ',fich_cas,NF_NOWRITE,nid
-      if (ierr.NE.NF_NOERR) then
-         write(*,*) 'ERROR: GROS Pb opening forcings nc file '
-         write(*,*) NF_STRERROR(ierr)
-         stop ""
-      endif
-!.......................................................................
-      ierr=NF_INQ_DIMID(nid,'lat',rid)
-      IF (ierr.NE.NF_NOERR) THEN
-         print*, 'Oh probleme lecture dimension lat'
-      ENDIF
-      ierr=NF_INQ_DIMLEN(nid,rid,ii)
-      print*,'OK1 nid,rid,lat',nid,rid,ii
-!.......................................................................
-      ierr=NF_INQ_DIMID(nid,'lon',rid)
-      IF (ierr.NE.NF_NOERR) THEN
-         print*, 'Oh probleme lecture dimension lon'
-      ENDIF
-      ierr=NF_INQ_DIMLEN(nid,rid,jj)
-      print*,'OK2 nid,rid,lat',nid,rid,jj
-!.......................................................................
-      ierr=NF_INQ_DIMID(nid,'lev',rid)
-      IF (ierr.NE.NF_NOERR) THEN
-         print*, 'Oh probleme lecture dimension zz'
-      ENDIF
-      ierr=NF_INQ_DIMLEN(nid,rid,nlev_cas)
-      print*,'OK3 nid,rid,nlev_cas',nid,rid,nlev_cas
-!.......................................................................
-      ierr=NF_INQ_DIMID(nid,'time',rid)
-      print*,'nid,rid',nid,rid
-      nt_cas=0
-      IF (ierr.NE.NF_NOERR) THEN
-        stop 'probleme lecture dimension sens'
-      ENDIF
-      ierr=NF_INQ_DIMLEN(nid,rid,nt_cas)
-      print*,'OK4 nid,rid,nt_cas',nid,rid,nt_cas
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!profils moyens:
-        allocate(plev_cas(nlev_cas,nt_cas))        
-        allocate(z_cas(nlev_cas,nt_cas))
-        allocate(t_cas(nlev_cas,nt_cas),q_cas(nlev_cas,nt_cas),rh_cas(nlev_cas,nt_cas))
-        allocate(th_cas(nlev_cas,nt_cas),rv_cas(nlev_cas,nt_cas))
-        allocate(u_cas(nlev_cas,nt_cas))
-        allocate(v_cas(nlev_cas,nt_cas))
-
-!forcing
-        allocate(ht_cas(nlev_cas,nt_cas),vt_cas(nlev_cas,nt_cas),dt_cas(nlev_cas,nt_cas),dtrad_cas(nlev_cas,nt_cas))
-        allocate(hq_cas(nlev_cas,nt_cas),vq_cas(nlev_cas,nt_cas),dq_cas(nlev_cas,nt_cas))
-        allocate(hth_cas(nlev_cas,nt_cas),vth_cas(nlev_cas,nt_cas),dth_cas(nlev_cas,nt_cas))
-        allocate(hr_cas(nlev_cas,nt_cas),vr_cas(nlev_cas,nt_cas),dr_cas(nlev_cas,nt_cas))
-        allocate(hu_cas(nlev_cas,nt_cas),vu_cas(nlev_cas,nt_cas),du_cas(nlev_cas,nt_cas))
-        allocate(hv_cas(nlev_cas,nt_cas),vv_cas(nlev_cas,nt_cas),dv_cas(nlev_cas,nt_cas))
-        allocate(vitw_cas(nlev_cas,nt_cas))
-        allocate(ug_cas(nlev_cas,nt_cas))
-        allocate(vg_cas(nlev_cas,nt_cas))
-        allocate(lat_cas(nt_cas),sens_cas(nt_cas),ts_cas(nt_cas),ustar_cas(nt_cas))
-        allocate(uw_cas(nlev_cas,nt_cas),vw_cas(nlev_cas,nt_cas),q1_cas(nlev_cas,nt_cas),q2_cas(nlev_cas,nt_cas))
-
-
-!champs interpoles
-        allocate(plev_prof_cas(nlev_cas))
-        allocate(t_prof_cas(nlev_cas))
-        allocate(q_prof_cas(nlev_cas))
-        allocate(u_prof_cas(nlev_cas))
-        allocate(v_prof_cas(nlev_cas))
-
-        allocate(vitw_prof_cas(nlev_cas))
-        allocate(ug_prof_cas(nlev_cas))
-        allocate(vg_prof_cas(nlev_cas))
-        allocate(ht_prof_cas(nlev_cas))
-        allocate(hq_prof_cas(nlev_cas))
-        allocate(hu_prof_cas(nlev_cas))
-        allocate(hv_prof_cas(nlev_cas))
-        allocate(vt_prof_cas(nlev_cas))
-        allocate(vq_prof_cas(nlev_cas))
-        allocate(vu_prof_cas(nlev_cas))
-        allocate(vv_prof_cas(nlev_cas))
-        allocate(dt_prof_cas(nlev_cas))
-        allocate(dtrad_prof_cas(nlev_cas))
-        allocate(dq_prof_cas(nlev_cas))
-        allocate(du_prof_cas(nlev_cas))
-        allocate(dv_prof_cas(nlev_cas))
-        allocate(uw_prof_cas(nlev_cas))
-        allocate(vw_prof_cas(nlev_cas))
-        allocate(q1_prof_cas(nlev_cas))
-        allocate(q2_prof_cas(nlev_cas))
-
-        print*,'Allocations OK'
-        call read_cas(nid,nlev_cas,nt_cas                                       &
-     &     ,z_cas,plev_cas,t_cas,q_cas,rh_cas,th_cas,rv_cas,u_cas,v_cas         &
-     &     ,ug_cas,vg_cas,vitw_cas,du_cas,hu_cas,vu_cas,dv_cas,hv_cas,vv_cas    &
-     &     ,dt_cas,dtrad_cas,ht_cas,vt_cas,dq_cas,hq_cas,vq_cas                 &
-     &     ,dth_cas,hth_cas,vth_cas,dr_cas,hr_cas,vr_cas,sens_cas,lat_cas,ts_cas&
-     &     ,ustar_cas,uw_cas,vw_cas,q1_cas,q2_cas)
-        print*,'Read cas OK'
-
-
-END SUBROUTINE read_1D_cas
-
-
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-SUBROUTINE deallocate_1D_cases
-!profils environnementaux:
-        deallocate(plev_cas)
-        
-        deallocate(z_cas)
-        deallocate(t_cas,q_cas,rh_cas)
-        deallocate(th_cas,rv_cas)
-        deallocate(u_cas)
-        deallocate(v_cas)
-        
-!forcing
-        deallocate(ht_cas,vt_cas,dt_cas,dtrad_cas)
-        deallocate(hq_cas,vq_cas,dq_cas)
-        deallocate(hth_cas,vth_cas,dth_cas)
-        deallocate(hr_cas,vr_cas,dr_cas)
-        deallocate(hu_cas,vu_cas,du_cas)
-        deallocate(hv_cas,vv_cas,dv_cas)
-        deallocate(vitw_cas)
-        deallocate(ug_cas)
-        deallocate(vg_cas)
-        deallocate(lat_cas,sens_cas,ts_cas,ustar_cas,uw_cas,vw_cas,q1_cas,q2_cas)
-
-!champs interpoles
-        deallocate(plev_prof_cas)
-        deallocate(t_prof_cas)
-        deallocate(q_prof_cas)
-        deallocate(u_prof_cas)
-        deallocate(v_prof_cas)
-
-        deallocate(vitw_prof_cas)
-        deallocate(ug_prof_cas)
-        deallocate(vg_prof_cas)
-        deallocate(ht_prof_cas)
-        deallocate(hq_prof_cas)
-        deallocate(hu_prof_cas)
-        deallocate(hv_prof_cas)
-        deallocate(vt_prof_cas)
-        deallocate(vq_prof_cas)
-        deallocate(vu_prof_cas)
-        deallocate(vv_prof_cas)
-        deallocate(dt_prof_cas)
-        deallocate(dtrad_prof_cas)
-        deallocate(dq_prof_cas)
-        deallocate(du_prof_cas)
-        deallocate(dv_prof_cas)
-        deallocate(t_prof_cas)
-        deallocate(q_prof_cas)
-        deallocate(u_prof_cas)
-        deallocate(v_prof_cas)
-        deallocate(uw_prof_cas)
-        deallocate(vw_prof_cas)
-        deallocate(q1_prof_cas)
-        deallocate(q2_prof_cas)
-
-END SUBROUTINE deallocate_1D_cases
-
-
-END MODULE mod_1D_cases_read
-!=====================================================================
-      subroutine read_cas(nid,nlevel,ntime                          &
-     &     ,zz,pp,temp,qv,rh,theta,rv,u,v,ug,vg,w,                   &
-     &     du,hu,vu,dv,hv,vv,dt,dtrad,ht,vt,dq,hq,vq,                     &
-     &     dth,hth,vth,dr,hr,vr,sens,flat,ts,ustar,uw,vw,q1,q2)
-
-!program reading forcing of the case study
-      USE netcdf, ONLY: nf90_get_var
-      implicit none
-      INCLUDE "netcdf.inc"
-
-      integer ntime,nlevel
-
-      real zz(nlevel,ntime)
-      real pp(nlevel,ntime)
-      real temp(nlevel,ntime),qv(nlevel,ntime),rh(nlevel,ntime)
-      real theta(nlevel,ntime),rv(nlevel,ntime)
-      real u(nlevel,ntime)
-      real v(nlevel,ntime)
-      real ug(nlevel,ntime)
-      real vg(nlevel,ntime)
-      real w(nlevel,ntime)
-      real du(nlevel,ntime),hu(nlevel,ntime),vu(nlevel,ntime)
-      real dv(nlevel,ntime),hv(nlevel,ntime),vv(nlevel,ntime)
-      real dt(nlevel,ntime),ht(nlevel,ntime),vt(nlevel,ntime)
-      real dtrad(nlevel,ntime)
-      real dq(nlevel,ntime),hq(nlevel,ntime),vq(nlevel,ntime)
-      real dth(nlevel,ntime),hth(nlevel,ntime),vth(nlevel,ntime)
-      real dr(nlevel,ntime),hr(nlevel,ntime),vr(nlevel,ntime)
-      real flat(ntime),sens(ntime),ts(ntime),ustar(ntime)
-      real uw(nlevel,ntime),vw(nlevel,ntime),q1(nlevel,ntime),q2(nlevel,ntime)
-
-
-      integer nid, ierr,rid
-      integer nbvar3d
-      parameter(nbvar3d=39)
-      integer var3didin(nbvar3d)
-
-       ierr=NF_INQ_VARID(nid,"zz",var3didin(1)) 
-         if(ierr/=NF_NOERR) then
-           write(*,*) NF_STRERROR(ierr)
-           stop 'lev'
-         endif
-      
-      ierr=NF_INQ_VARID(nid,"pp",var3didin(2)) 
-         if(ierr/=NF_NOERR) then
-           write(*,*) NF_STRERROR(ierr)
-           stop 'plev'
-         endif
-
-
-      ierr=NF_INQ_VARID(nid,"temp",var3didin(3))
-         if(ierr/=NF_NOERR) then
-           write(*,*) NF_STRERROR(ierr)
-           stop 'temp'
-         endif
-
-      ierr=NF_INQ_VARID(nid,"qv",var3didin(4))
-         if(ierr/=NF_NOERR) then
-           write(*,*) NF_STRERROR(ierr)
-           stop 'qv'
-         endif
-
-      ierr=NF_INQ_VARID(nid,"rh",var3didin(5))
-         if(ierr/=NF_NOERR) then
-           write(*,*) NF_STRERROR(ierr)
-           stop 'rh'
-         endif
-
-      ierr=NF_INQ_VARID(nid,"theta",var3didin(6))
-         if(ierr/=NF_NOERR) then
-           write(*,*) NF_STRERROR(ierr)
-           stop 'theta'
-         endif
-
-      ierr=NF_INQ_VARID(nid,"rv",var3didin(7))
-         if(ierr/=NF_NOERR) then
-           write(*,*) NF_STRERROR(ierr)
-           stop 'rv'
-         endif
-
-
-      ierr=NF_INQ_VARID(nid,"u",var3didin(8))
-         if(ierr/=NF_NOERR) then
-           write(*,*) NF_STRERROR(ierr)
-           stop 'u'
-         endif
-
-      ierr=NF_INQ_VARID(nid,"v",var3didin(9))
-         if(ierr/=NF_NOERR) then
-           write(*,*) NF_STRERROR(ierr)
-           stop 'v'
-         endif
-
-       ierr=NF_INQ_VARID(nid,"ug",var3didin(10))
-         if(ierr/=NF_NOERR) then
-           write(*,*) NF_STRERROR(ierr)
-           stop 'ug'
-         endif
-
-      ierr=NF_INQ_VARID(nid,"vg",var3didin(11))
-         if(ierr/=NF_NOERR) then
-           write(*,*) NF_STRERROR(ierr)
-           stop 'vg'
-         endif
-
-      ierr=NF_INQ_VARID(nid,"w",var3didin(12))
-         if(ierr/=NF_NOERR) then
-           write(*,*) NF_STRERROR(ierr)
-           stop 'w'
-         endif
-
-      ierr=NF_INQ_VARID(nid,"advu",var3didin(13))
-         if(ierr/=NF_NOERR) then
-           write(*,*) NF_STRERROR(ierr)
-           stop 'advu'
-         endif
-
-      ierr=NF_INQ_VARID(nid,"hu",var3didin(14))
-         if(ierr/=NF_NOERR) then
-           write(*,*) NF_STRERROR(ierr)
-           stop 'hu'
-         endif
-
-       ierr=NF_INQ_VARID(nid,"vu",var3didin(15))
-         if(ierr/=NF_NOERR) then
-           write(*,*) NF_STRERROR(ierr)
-           stop 'vu'
-         endif
-
-       ierr=NF_INQ_VARID(nid,"advv",var3didin(16))
-         if(ierr/=NF_NOERR) then
-           write(*,*) NF_STRERROR(ierr)
-           stop 'advv'
-         endif
-
-      ierr=NF_INQ_VARID(nid,"hv",var3didin(17))
-         if(ierr/=NF_NOERR) then
-           write(*,*) NF_STRERROR(ierr)
-           stop 'hv'
-         endif
-
-       ierr=NF_INQ_VARID(nid,"vv",var3didin(18))
-         if(ierr/=NF_NOERR) then
-           write(*,*) NF_STRERROR(ierr)
-           stop 'vv'
-         endif
-
-      ierr=NF_INQ_VARID(nid,"advT",var3didin(19))
-         if(ierr/=NF_NOERR) then
-           write(*,*) NF_STRERROR(ierr)
-           stop 'advT'
-         endif
-
-      ierr=NF_INQ_VARID(nid,"hT",var3didin(20))
-         if(ierr/=NF_NOERR) then
-           write(*,*) NF_STRERROR(ierr)
-           stop 'hT'
-         endif
-
-      ierr=NF_INQ_VARID(nid,"vT",var3didin(21))
-         if(ierr/=NF_NOERR) then
-           write(*,*) NF_STRERROR(ierr)
-           stop 'vT'
-         endif
-
-      ierr=NF_INQ_VARID(nid,"advq",var3didin(22))
-         if(ierr/=NF_NOERR) then
-           write(*,*) NF_STRERROR(ierr)
-           stop 'advq'
-         endif
-      
-      ierr=NF_INQ_VARID(nid,"hq",var3didin(23))
-         if(ierr/=NF_NOERR) then
-           write(*,*) NF_STRERROR(ierr)
-           stop 'hq'
-         endif
-
-      ierr=NF_INQ_VARID(nid,"vq",var3didin(24))
-         if(ierr/=NF_NOERR) then
-           write(*,*) NF_STRERROR(ierr)
-           stop 'vq'
-         endif
-
-      ierr=NF_INQ_VARID(nid,"advth",var3didin(25))
-         if(ierr/=NF_NOERR) then
-           write(*,*) NF_STRERROR(ierr)
-           stop 'advth'
-         endif
-
-      ierr=NF_INQ_VARID(nid,"hth",var3didin(26))
-         if(ierr/=NF_NOERR) then
-           write(*,*) NF_STRERROR(ierr)
-           stop 'hth'
-         endif
-
-      ierr=NF_INQ_VARID(nid,"vth",var3didin(27))
-         if(ierr/=NF_NOERR) then
-           write(*,*) NF_STRERROR(ierr)
-           stop 'vth'
-         endif
-
-      ierr=NF_INQ_VARID(nid,"advr",var3didin(28))
-         if(ierr/=NF_NOERR) then
-           write(*,*) NF_STRERROR(ierr)
-           stop 'advr'
-         endif
-      
-      ierr=NF_INQ_VARID(nid,"hr",var3didin(29))
-         if(ierr/=NF_NOERR) then
-           write(*,*) NF_STRERROR(ierr)
-           stop 'hr'
-         endif
-
-      ierr=NF_INQ_VARID(nid,"vr",var3didin(30))
-         if(ierr/=NF_NOERR) then
-           write(*,*) NF_STRERROR(ierr)
-           stop 'vr'
-         endif
-
-      ierr=NF_INQ_VARID(nid,"radT",var3didin(31))
-         if(ierr/=NF_NOERR) then
-           write(*,*) NF_STRERROR(ierr)
-           stop 'radT'
-         endif
-
-      ierr=NF_INQ_VARID(nid,"sens",var3didin(32))
-         if(ierr/=NF_NOERR) then
-           write(*,*) NF_STRERROR(ierr)
-           stop 'sens'
-         endif
-
-      ierr=NF_INQ_VARID(nid,"flat",var3didin(33))
-         if(ierr/=NF_NOERR) then
-           write(*,*) NF_STRERROR(ierr)
-           stop 'flat'
-         endif
-
-      ierr=NF_INQ_VARID(nid,"ts",var3didin(34))
-         if(ierr/=NF_NOERR) then
-           write(*,*) NF_STRERROR(ierr)
-           stop 'ts'
-         endif
-
-      ierr=NF_INQ_VARID(nid,"ustar",var3didin(35))
-         if(ierr/=NF_NOERR) then
-           write(*,*) NF_STRERROR(ierr)
-           stop 'ustar'
-         endif
-
-      ierr=NF_INQ_VARID(nid,"uw",var3didin(36))
-         if(ierr/=NF_NOERR) then
-           write(*,*) NF_STRERROR(ierr)
-           stop 'uw'
-         endif
-
-      ierr=NF_INQ_VARID(nid,"vw",var3didin(37))
-         if(ierr/=NF_NOERR) then
-           write(*,*) NF_STRERROR(ierr)
-           stop 'vw'
-         endif
-
-      ierr=NF_INQ_VARID(nid,"q1",var3didin(38))
-         if(ierr/=NF_NOERR) then
-           write(*,*) NF_STRERROR(ierr)
-           stop 'q1'
-         endif
-
-      ierr=NF_INQ_VARID(nid,"q2",var3didin(39))
-         if(ierr/=NF_NOERR) then
-           write(*,*) NF_STRERROR(ierr)
-           stop 'q2'
-         endif
- 
-         ierr = nf90_get_var(nid, var3didin(1), zz)
-         if(ierr/=NF_NOERR) then
-            write(*,*) NF_STRERROR(ierr)
-            stop "getvarup"
-         endif
-!          write(*,*)'lecture z ok',zz
-
-         ierr = nf90_get_var(nid, var3didin(2), pp)
-         if(ierr/=NF_NOERR) then
-            write(*,*) NF_STRERROR(ierr)
-            stop "getvarup"
-         endif
-!          write(*,*)'lecture pp ok',pp
-
-
-         ierr = nf90_get_var(nid, var3didin(3), temp)
-         if(ierr/=NF_NOERR) then
-            write(*,*) NF_STRERROR(ierr)
-            stop "getvarup"
-         endif
-!          write(*,*)'lecture T ok',temp
-
-         ierr = nf90_get_var(nid, var3didin(4), qv)
-         if(ierr/=NF_NOERR) then
-            write(*,*) NF_STRERROR(ierr)
-            stop "getvarup"
-         endif
-!          write(*,*)'lecture qv ok',qv
- 
-         ierr = nf90_get_var(nid, var3didin(5), rh)
-         if(ierr/=NF_NOERR) then
-            write(*,*) NF_STRERROR(ierr)
-            stop "getvarup"
-         endif
-!          write(*,*)'lecture rh ok',rh
-
-         ierr = nf90_get_var(nid, var3didin(6), theta)
-         if(ierr/=NF_NOERR) then
-            write(*,*) NF_STRERROR(ierr)
-            stop "getvarup"
-         endif
-!          write(*,*)'lecture theta ok',theta
-
-         ierr = nf90_get_var(nid, var3didin(7), rv)
-         if(ierr/=NF_NOERR) then
-            write(*,*) NF_STRERROR(ierr)
-            stop "getvarup"
-         endif
-!          write(*,*)'lecture rv ok',rv
-
-         ierr = nf90_get_var(nid, var3didin(8), u)
-         if(ierr/=NF_NOERR) then
-            write(*,*) NF_STRERROR(ierr)
-            stop "getvarup"
-         endif
-!          write(*,*)'lecture u ok',u
-
-         ierr = nf90_get_var(nid, var3didin(9), v)
-         if(ierr/=NF_NOERR) then
-            write(*,*) NF_STRERROR(ierr)
-            stop "getvarup"
-         endif
-!          write(*,*)'lecture v ok',v
-
-         ierr = nf90_get_var(nid, var3didin(10), ug)
-         if(ierr/=NF_NOERR) then
-            write(*,*) NF_STRERROR(ierr)
-            stop "getvarup"
-         endif
-!          write(*,*)'lecture ug ok',ug
-
-         ierr = nf90_get_var(nid, var3didin(11), vg)
-         if(ierr/=NF_NOERR) then
-            write(*,*) NF_STRERROR(ierr)
-            stop "getvarup"
-         endif
-!          write(*,*)'lecture vg ok',vg
-
-         ierr = nf90_get_var(nid, var3didin(12), w)
-         if(ierr/=NF_NOERR) then
-            write(*,*) NF_STRERROR(ierr)
-            stop "getvarup"
-         endif
-!          write(*,*)'lecture w ok',w
-
-         ierr = nf90_get_var(nid, var3didin(13), du)
-         if(ierr/=NF_NOERR) then
-            write(*,*) NF_STRERROR(ierr)
-            stop "getvarup"
-         endif
-!          write(*,*)'lecture du ok',du
-
-         ierr = nf90_get_var(nid, var3didin(14), hu)
-         if(ierr/=NF_NOERR) then
-            write(*,*) NF_STRERROR(ierr)
-            stop "getvarup"
-         endif
-!          write(*,*)'lecture hu ok',hu
-
-         ierr = nf90_get_var(nid, var3didin(15), vu)
-         if(ierr/=NF_NOERR) then
-            write(*,*) NF_STRERROR(ierr)
-            stop "getvarup"
-         endif
-!          write(*,*)'lecture vu ok',vu
-
-         ierr = nf90_get_var(nid, var3didin(16), dv)
-         if(ierr/=NF_NOERR) then
-            write(*,*) NF_STRERROR(ierr)
-            stop "getvarup"
-         endif
-!          write(*,*)'lecture dv ok',dv
-
-         ierr = nf90_get_var(nid, var3didin(17), hv)
-         if(ierr/=NF_NOERR) then
-            write(*,*) NF_STRERROR(ierr)
-            stop "getvarup"
-         endif
-!          write(*,*)'lecture hv ok',hv
-
-         ierr = nf90_get_var(nid, var3didin(18), vv)
-         if(ierr/=NF_NOERR) then
-            write(*,*) NF_STRERROR(ierr)
-            stop "getvarup"
-         endif
-!          write(*,*)'lecture vv ok',vv
-
-         ierr = nf90_get_var(nid, var3didin(19), dt)
-         if(ierr/=NF_NOERR) then
-            write(*,*) NF_STRERROR(ierr)
-            stop "getvarup"
-         endif
-!          write(*,*)'lecture dt ok',dt
-
-         ierr = nf90_get_var(nid, var3didin(20), ht)
-         if(ierr/=NF_NOERR) then
-            write(*,*) NF_STRERROR(ierr)
-            stop "getvarup"
-         endif
-!          write(*,*)'lecture ht ok',ht
-
-         ierr = nf90_get_var(nid, var3didin(21), vt)
-         if(ierr/=NF_NOERR) then
-            write(*,*) NF_STRERROR(ierr)
-            stop "getvarup"
-         endif
-!          write(*,*)'lecture vt ok',vt
-
-         ierr = nf90_get_var(nid, var3didin(22), dq)
-         if(ierr/=NF_NOERR) then
-            write(*,*) NF_STRERROR(ierr)
-            stop "getvarup"
-         endif
-!          write(*,*)'lecture dq ok',dq
-
-         ierr = nf90_get_var(nid, var3didin(23), hq)
-         if(ierr/=NF_NOERR) then
-            write(*,*) NF_STRERROR(ierr)
-            stop "getvarup"
-         endif
-!          write(*,*)'lecture hq ok',hq
-
-         ierr = nf90_get_var(nid, var3didin(24), vq)
-         if(ierr/=NF_NOERR) then
-            write(*,*) NF_STRERROR(ierr)
-            stop "getvarup"
-         endif
-!          write(*,*)'lecture vq ok',vq
-
-         ierr = nf90_get_var(nid, var3didin(25), dth)
-         if(ierr/=NF_NOERR) then
-            write(*,*) NF_STRERROR(ierr)
-            stop "getvarup"
-         endif
-!          write(*,*)'lecture dth ok',dth
-
-         ierr = nf90_get_var(nid, var3didin(26), hth)
-         if(ierr/=NF_NOERR) then
-            write(*,*) NF_STRERROR(ierr)
-            stop "getvarup"
-         endif
-!          write(*,*)'lecture hth ok',hth
-
-         ierr = nf90_get_var(nid, var3didin(27), vth)
-         if(ierr/=NF_NOERR) then
-            write(*,*) NF_STRERROR(ierr)
-            stop "getvarup"
-         endif
-!          write(*,*)'lecture vth ok',vth
-
-         ierr = nf90_get_var(nid, var3didin(28), dr)
-         if(ierr/=NF_NOERR) then
-            write(*,*) NF_STRERROR(ierr)
-            stop "getvarup"
-         endif
-!          write(*,*)'lecture dr ok',dr
-
-         ierr = nf90_get_var(nid, var3didin(29), hr)
-         if(ierr/=NF_NOERR) then
-            write(*,*) NF_STRERROR(ierr)
-            stop "getvarup"
-         endif
-!          write(*,*)'lecture hr ok',hr
-
-         ierr = nf90_get_var(nid, var3didin(30), vr)
-         if(ierr/=NF_NOERR) then
-            write(*,*) NF_STRERROR(ierr)
-            stop "getvarup"
-         endif
-!          write(*,*)'lecture vr ok',vr
-
-         ierr = nf90_get_var(nid, var3didin(31), dtrad)
-         if(ierr/=NF_NOERR) then
-            write(*,*) NF_STRERROR(ierr)
-            stop "getvarup"
-         endif
-!          write(*,*)'lecture dtrad ok',dtrad
-
-         ierr = nf90_get_var(nid, var3didin(32), sens)
-         if(ierr/=NF_NOERR) then
-            write(*,*) NF_STRERROR(ierr)
-            stop "getvarup"
-         endif
-!          write(*,*)'lecture sens ok',sens
-
-         ierr = nf90_get_var(nid, var3didin(33), flat)
-         if(ierr/=NF_NOERR) then
-            write(*,*) NF_STRERROR(ierr)
-            stop "getvarup"
-         endif
-!          write(*,*)'lecture flat ok',flat
-
-         ierr = nf90_get_var(nid, var3didin(34), ts)
-         if(ierr/=NF_NOERR) then
-            write(*,*) NF_STRERROR(ierr)
-            stop "getvarup"
-         endif
-!          write(*,*)'lecture ts ok',ts
-
-         ierr = nf90_get_var(nid, var3didin(35), ustar)
-         if(ierr/=NF_NOERR) then
-            write(*,*) NF_STRERROR(ierr)
-            stop "getvarup"
-         endif
-!         write(*,*)'lecture ustar ok',ustar
-
-         ierr = nf90_get_var(nid, var3didin(36), uw)
-         if(ierr/=NF_NOERR) then
-            write(*,*) NF_STRERROR(ierr)
-            stop "getvarup"
-         endif
-!         write(*,*)'lecture uw ok',uw
-
-         ierr = nf90_get_var(nid, var3didin(37), vw)
-         if(ierr/=NF_NOERR) then
-            write(*,*) NF_STRERROR(ierr)
-            stop "getvarup"
-         endif
-!         write(*,*)'lecture vw ok',vw
-
-         ierr = nf90_get_var(nid, var3didin(38), q1)
-         if(ierr/=NF_NOERR) then
-            write(*,*) NF_STRERROR(ierr)
-            stop "getvarup"
-         endif
-!         write(*,*)'lecture q1 ok',q1
-
-         ierr = nf90_get_var(nid, var3didin(39), q2)
-         if(ierr/=NF_NOERR) then
-            write(*,*) NF_STRERROR(ierr)
-            stop "getvarup"
-         endif
-!         write(*,*)'lecture q2 ok',q2
-
-
-         return 
-         end subroutine read_cas
-!======================================================================
-        SUBROUTINE interp_case_time(day,day1,annee_ref                &
-!    &         ,year_cas,day_cas,nt_cas,pdt_forc,nlev_cas      &
-     &         ,nt_cas,nlev_cas                                       &
-     &         ,ts_cas,plev_cas,t_cas,q_cas,u_cas,v_cas               &
-     &         ,ug_cas,vg_cas,vitw_cas,du_cas,hu_cas,vu_cas           &
-     &         ,dv_cas,hv_cas,vv_cas,dt_cas,ht_cas,vt_cas,dtrad_cas   &
-     &         ,dq_cas,hq_cas,vq_cas,lat_cas,sens_cas,ustar_cas       &
-     &         ,uw_cas,vw_cas,q1_cas,q2_cas                           &
-     &         ,ts_prof_cas,plev_prof_cas,t_prof_cas,q_prof_cas       &
-     &         ,u_prof_cas,v_prof_cas,ug_prof_cas,vg_prof_cas         &
-     &         ,vitw_prof_cas,du_prof_cas,hu_prof_cas,vu_prof_cas     &
-     &         ,dv_prof_cas,hv_prof_cas,vv_prof_cas,dt_prof_cas       &
-     &         ,ht_prof_cas,vt_prof_cas,dtrad_prof_cas,dq_prof_cas    &
-     &         ,hq_prof_cas,vq_prof_cas,lat_prof_cas,sens_prof_cas    &
-     &         ,ustar_prof_cas,uw_prof_cas,vw_prof_cas,q1_prof_cas,q2_prof_cas)
-          
-
-        implicit none
-
-!---------------------------------------------------------------------------------------
-! Time interpolation of a 2D field to the timestep corresponding to day
-!
-! day: current julian day (e.g. 717538.2)
-! day1: first day of the simulation
-! nt_cas: total nb of data in the forcing 
-! pdt_cas: total time interval (in sec) between 2 forcing data
-!---------------------------------------------------------------------------------------
-
-        INCLUDE "compar1d.h"
-        INCLUDE "date_cas.h"
-
-! inputs:
-        integer annee_ref
-        integer nt_cas,nlev_cas
-        real day, day1,day_cas
-        real ts_cas(nt_cas)
-        real plev_cas(nlev_cas,nt_cas)
-        real t_cas(nlev_cas,nt_cas),q_cas(nlev_cas,nt_cas)
-        real u_cas(nlev_cas,nt_cas),v_cas(nlev_cas,nt_cas)
-        real ug_cas(nlev_cas,nt_cas),vg_cas(nlev_cas,nt_cas)
-        real vitw_cas(nlev_cas,nt_cas)
-        real du_cas(nlev_cas,nt_cas),hu_cas(nlev_cas,nt_cas),vu_cas(nlev_cas,nt_cas)
-        real dv_cas(nlev_cas,nt_cas),hv_cas(nlev_cas,nt_cas),vv_cas(nlev_cas,nt_cas)
-        real dt_cas(nlev_cas,nt_cas),ht_cas(nlev_cas,nt_cas),vt_cas(nlev_cas,nt_cas)
-        real dtrad_cas(nlev_cas,nt_cas)
-        real dq_cas(nlev_cas,nt_cas),hq_cas(nlev_cas,nt_cas),vq_cas(nlev_cas,nt_cas)
-        real lat_cas(nt_cas)
-        real sens_cas(nt_cas)
-        real ustar_cas(nt_cas),uw_cas(nlev_cas,nt_cas),vw_cas(nlev_cas,nt_cas)
-        real q1_cas(nlev_cas,nt_cas),q2_cas(nlev_cas,nt_cas)
-
-! outputs:
-        real plev_prof_cas(nlev_cas)
-        real t_prof_cas(nlev_cas),q_prof_cas(nlev_cas)
-        real u_prof_cas(nlev_cas),v_prof_cas(nlev_cas)
-        real ug_prof_cas(nlev_cas),vg_prof_cas(nlev_cas)
-        real vitw_prof_cas(nlev_cas)
-        real du_prof_cas(nlev_cas),hu_prof_cas(nlev_cas),vu_prof_cas(nlev_cas)
-        real dv_prof_cas(nlev_cas),hv_prof_cas(nlev_cas),vv_prof_cas(nlev_cas)
-        real dt_prof_cas(nlev_cas),ht_prof_cas(nlev_cas),vt_prof_cas(nlev_cas)
-        real dtrad_prof_cas(nlev_cas)
-        real dq_prof_cas(nlev_cas),hq_prof_cas(nlev_cas),vq_prof_cas(nlev_cas)
-        real lat_prof_cas,sens_prof_cas,ts_prof_cas,ustar_prof_cas
-        real uw_prof_cas(nlev_cas),vw_prof_cas(nlev_cas),q1_prof_cas(nlev_cas),q2_prof_cas(nlev_cas)
-! local:
-        integer it_cas1, it_cas2,k
-        real timeit,time_cas1,time_cas2,frac
-
-
-        print*,'Check time',day1,day_ju_ini_cas,day_deb+1,pdt_cas
-
-! On teste si la date du cas AMMA est correcte.
-! C est pour memoire car en fait les fichiers .def
-! sont censes etre corrects.
-! A supprimer a terme (MPL 20150623)
-!     if ((forcing_type.eq.10).and.(1.eq.0)) then
-! Check that initial day of the simulation consistent with AMMA case:
-!      if (annee_ref.ne.2006) then
-!       print*,'Pour AMMA, annee_ref doit etre 2006'
-!       print*,'Changer annee_ref dans run.def'
-!       stop
-!      endif
-!      if (annee_ref.eq.2006 .and. day1.lt.day_cas) then
-!       print*,'AMMA a debute le 10 juillet 2006',day1,day_cas
-!       print*,'Changer dayref dans run.def'
-!       stop
-!      endif
-!      if (annee_ref.eq.2006 .and. day1.gt.day_cas+1) then
-!       print*,'AMMA a fini le 11 juillet'
-!       print*,'Changer dayref ou nday dans run.def'
-!       stop
-!      endif
-!      endif
-
-! Determine timestep relative to the 1st day:
-!       timeit=(day-day1)*86400.
-!       if (annee_ref.eq.1992) then
-!        timeit=(day-day_cas)*86400.
-!       else
-!        timeit=(day+61.-1.)*86400. ! 61 days between Nov01 and Dec31 1992
-!       endif
-      timeit=(day-day_ju_ini_cas)*86400
-      print *,'day=',day
-      print *,'day_ju_ini_cas=',day_ju_ini_cas
-      print *,'pdt_cas=',pdt_cas
-      print *,'timeit=',timeit
-      print *,'nt_cas=',nt_cas
-
-! Determine the closest observation times:
-!       it_cas1=INT(timeit/pdt_cas)+1
-!       it_cas2=it_cas1 + 1
-!       time_cas1=(it_cas1-1)*pdt_cas
-!       time_cas2=(it_cas2-1)*pdt_cas
-
-       it_cas1=INT(timeit/pdt_cas)+1
-       IF (it_cas1 .EQ. nt_cas) THEN
-       it_cas2=it_cas1 
-       ELSE
-       it_cas2=it_cas1 + 1
-       ENDIF
-       time_cas1=(it_cas1-1)*pdt_cas
-       time_cas2=(it_cas2-1)*pdt_cas
-      print *,'it_cas1=',it_cas1
-      print *,'it_cas2=',it_cas2
-      print *,'time_cas1=',time_cas1
-      print *,'time_cas2=',time_cas2
-
-       if (it_cas1 .gt. nt_cas) then
-        write(*,*) 'PB-stop: day, day_ju_ini_cas,it_cas1, it_cas2, timeit: '            &
-     &        ,day,day_ju_ini_cas,it_cas1,it_cas2,timeit
-        stop
-       endif
-
-! time interpolation:
-       IF (it_cas1 .EQ. it_cas2) THEN
-          frac=0.
-       ELSE
-          frac=(time_cas2-timeit)/(time_cas2-time_cas1)
-          frac=max(frac,0.0)
-       ENDIF
-
-       lat_prof_cas = lat_cas(it_cas2)                                       &
-     &          -frac*(lat_cas(it_cas2)-lat_cas(it_cas1)) 
-       sens_prof_cas = sens_cas(it_cas2)                                     &
-     &          -frac*(sens_cas(it_cas2)-sens_cas(it_cas1))
-       ts_prof_cas = ts_cas(it_cas2)                                         &
-     &          -frac*(ts_cas(it_cas2)-ts_cas(it_cas1))
-       ustar_prof_cas = ustar_cas(it_cas2)                                   &
-     &          -frac*(ustar_cas(it_cas2)-ustar_cas(it_cas1))
-
-       do k=1,nlev_cas
-        plev_prof_cas(k) = plev_cas(k,it_cas2)                               &
-     &          -frac*(plev_cas(k,it_cas2)-plev_cas(k,it_cas1))
-        t_prof_cas(k) = t_cas(k,it_cas2)                               &
-     &          -frac*(t_cas(k,it_cas2)-t_cas(k,it_cas1))
-        q_prof_cas(k) = q_cas(k,it_cas2)                               &
-     &          -frac*(q_cas(k,it_cas2)-q_cas(k,it_cas1))
-        u_prof_cas(k) = u_cas(k,it_cas2)                               &
-     &          -frac*(u_cas(k,it_cas2)-u_cas(k,it_cas1))
-        v_prof_cas(k) = v_cas(k,it_cas2)                               &
-     &          -frac*(v_cas(k,it_cas2)-v_cas(k,it_cas1))
-        ug_prof_cas(k) = ug_cas(k,it_cas2)                               &
-     &          -frac*(ug_cas(k,it_cas2)-ug_cas(k,it_cas1))
-        vg_prof_cas(k) = vg_cas(k,it_cas2)                               &
-     &          -frac*(vg_cas(k,it_cas2)-vg_cas(k,it_cas1))
-        vitw_prof_cas(k) = vitw_cas(k,it_cas2)                               &
-     &          -frac*(vitw_cas(k,it_cas2)-vitw_cas(k,it_cas1))
-        du_prof_cas(k) = du_cas(k,it_cas2)                                   &
-     &          -frac*(du_cas(k,it_cas2)-du_cas(k,it_cas1))
-        hu_prof_cas(k) = hu_cas(k,it_cas2)                                   &
-     &          -frac*(hu_cas(k,it_cas2)-hu_cas(k,it_cas1))
-        vu_prof_cas(k) = vu_cas(k,it_cas2)                                   &
-     &          -frac*(vu_cas(k,it_cas2)-vu_cas(k,it_cas1))
-        dv_prof_cas(k) = dv_cas(k,it_cas2)                                   &
-     &          -frac*(dv_cas(k,it_cas2)-dv_cas(k,it_cas1))
-        hv_prof_cas(k) = hv_cas(k,it_cas2)                                   &
-     &          -frac*(hv_cas(k,it_cas2)-hv_cas(k,it_cas1))
-        vv_prof_cas(k) = vv_cas(k,it_cas2)                                   &
-     &          -frac*(vv_cas(k,it_cas2)-vv_cas(k,it_cas1))
-        dt_prof_cas(k) = dt_cas(k,it_cas2)                                   &
-     &          -frac*(dt_cas(k,it_cas2)-dt_cas(k,it_cas1))
-        ht_prof_cas(k) = ht_cas(k,it_cas2)                                   &
-     &          -frac*(ht_cas(k,it_cas2)-ht_cas(k,it_cas1))
-        vt_prof_cas(k) = vt_cas(k,it_cas2)                                   &
-     &          -frac*(vt_cas(k,it_cas2)-vt_cas(k,it_cas1))
-        dtrad_prof_cas(k) = dtrad_cas(k,it_cas2)                                   &
-     &          -frac*(dtrad_cas(k,it_cas2)-dtrad_cas(k,it_cas1))
-        dq_prof_cas(k) = dq_cas(k,it_cas2)                                   &
-     &          -frac*(dq_cas(k,it_cas2)-dq_cas(k,it_cas1))
-        hq_prof_cas(k) = hq_cas(k,it_cas2)                                   &
-     &          -frac*(hq_cas(k,it_cas2)-hq_cas(k,it_cas1))
-        vq_prof_cas(k) = vq_cas(k,it_cas2)                                   &
-     &          -frac*(vq_cas(k,it_cas2)-vq_cas(k,it_cas1))
-       uw_prof_cas(k) = uw_cas(k,it_cas2)                                   &
-     &          -frac*(uw_cas(k,it_cas2)-uw_cas(k,it_cas1))
-       vw_prof_cas(k) = vw_cas(k,it_cas2)                                   &
-     &          -frac*(vw_cas(k,it_cas2)-vw_cas(k,it_cas1))
-       q1_prof_cas(k) = q1_cas(k,it_cas2)                                   &
-     &          -frac*(q1_cas(k,it_cas2)-q1_cas(k,it_cas1))
-       q2_prof_cas(k) = q2_cas(k,it_cas2)                                   &
-     &          -frac*(q2_cas(k,it_cas2)-q2_cas(k,it_cas1))
-        enddo
-
-        return
-        END
-
-!**********************************************************************************************
Index: /LMDZ6/trunk/libf/phylmd/dyn1d/mod_1D_cases_read.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/dyn1d/mod_1D_cases_read.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/dyn1d/mod_1D_cases_read.f90	(revision 5268)
@@ -0,0 +1,1019 @@
+!
+! $Id$
+!
+MODULE mod_1D_cases_read
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!Declarations specifiques au cas standard
+        character*80 :: fich_cas
+! Discr?tisation 
+        integer nlev_cas, nt_cas
+
+
+!       integer year_ini_cas, day_ini_cas, mth_ini_cas
+!       real heure_ini_cas
+!       real day_ju_ini_cas   ! Julian day of case first day
+!       parameter (year_ini_cas=2011)
+!       parameter (year_ini_cas=1969)
+!       parameter (mth_ini_cas=10)
+!       parameter (mth_ini_cas=6)
+!       parameter (day_ini_cas=1)  ! 10 = 10Juil2006
+!       parameter (day_ini_cas=24)  ! 24 = 24 juin 1969
+!       parameter (heure_ini_cas=0.) !0h en secondes
+!       real pdt_cas
+!       parameter (pdt_cas=3.*3600)
+
+!CR ATTENTION TEST AMMA
+!        parameter (year_ini_cas=2006)
+!        parameter (mth_ini_cas=7)
+!        parameter (day_ini_cas=10)  ! 10 = 10Juil2006
+!        parameter (heure_ini_cas=0.) !0h en secondes
+!        parameter (pdt_cas=1800.)
+
+!profils environnementaux
+        real, allocatable::  plev_cas(:,:)
+
+        real, allocatable::  z_cas(:,:)
+        real, allocatable::  t_cas(:,:),q_cas(:,:),rh_cas(:,:)
+        real, allocatable::  th_cas(:,:),rv_cas(:,:)
+        real, allocatable::  u_cas(:,:)
+        real, allocatable::  v_cas(:,:)
+
+!forcing
+        real, allocatable::  ht_cas(:,:),vt_cas(:,:),dt_cas(:,:),dtrad_cas(:,:)
+        real, allocatable::  hth_cas(:,:),vth_cas(:,:),dth_cas(:,:)
+        real, allocatable::  hq_cas(:,:),vq_cas(:,:),dq_cas(:,:)
+        real, allocatable::  hr_cas(:,:),vr_cas(:,:),dr_cas(:,:)
+        real, allocatable::  hu_cas(:,:),vu_cas(:,:),du_cas(:,:)
+        real, allocatable::  hv_cas(:,:),vv_cas(:,:),dv_cas(:,:)
+        real, allocatable::  vitw_cas(:,:)
+        real, allocatable::  ug_cas(:,:),vg_cas(:,:)
+        real, allocatable::  lat_cas(:),sens_cas(:),ts_cas(:),ustar_cas(:)
+        real, allocatable::  uw_cas(:,:),vw_cas(:,:),q1_cas(:,:),q2_cas(:,:)
+
+!champs interpoles
+        real, allocatable::  plev_prof_cas(:)
+        real, allocatable::  t_prof_cas(:)
+        real, allocatable::  q_prof_cas(:)
+        real, allocatable::  u_prof_cas(:)
+        real, allocatable::  v_prof_cas(:)        
+
+        real, allocatable::  vitw_prof_cas(:)
+        real, allocatable::  ug_prof_cas(:)
+        real, allocatable::  vg_prof_cas(:)
+        real, allocatable::  ht_prof_cas(:)
+        real, allocatable::  hq_prof_cas(:)
+        real, allocatable::  vt_prof_cas(:)
+        real, allocatable::  vq_prof_cas(:)
+        real, allocatable::  dt_prof_cas(:)
+        real, allocatable::  dtrad_prof_cas(:)
+        real, allocatable::  dq_prof_cas(:)
+        real, allocatable::  hu_prof_cas(:)
+        real, allocatable::  hv_prof_cas(:)
+        real, allocatable::  vu_prof_cas(:)
+        real, allocatable::  vv_prof_cas(:)
+        real, allocatable::  du_prof_cas(:)
+        real, allocatable::  dv_prof_cas(:)
+        real, allocatable::  uw_prof_cas(:)
+        real, allocatable::  vw_prof_cas(:)
+        real, allocatable::  q1_prof_cas(:)
+        real, allocatable::  q2_prof_cas(:)
+
+
+        real lat_prof_cas,sens_prof_cas,ts_prof_cas,ustar_prof_cas
+      
+
+
+CONTAINS
+
+SUBROUTINE read_1D_cas
+      implicit none
+
+      INCLUDE "netcdf.inc"
+
+      INTEGER nid,rid,ierr
+      INTEGER ii,jj
+
+      fich_cas='setup/cas.nc'
+      print*,'fich_cas ',fich_cas
+      ierr = NF_OPEN(fich_cas,NF_NOWRITE,nid)
+      print*,'fich_cas,NF_NOWRITE,nid ',fich_cas,NF_NOWRITE,nid
+      if (ierr.NE.NF_NOERR) then
+         write(*,*) 'ERROR: GROS Pb opening forcings nc file '
+         write(*,*) NF_STRERROR(ierr)
+         stop ""
+      endif
+!.......................................................................
+      ierr=NF_INQ_DIMID(nid,'lat',rid)
+      IF (ierr.NE.NF_NOERR) THEN
+         print*, 'Oh probleme lecture dimension lat'
+      ENDIF
+      ierr=NF_INQ_DIMLEN(nid,rid,ii)
+      print*,'OK1 nid,rid,lat',nid,rid,ii
+!.......................................................................
+      ierr=NF_INQ_DIMID(nid,'lon',rid)
+      IF (ierr.NE.NF_NOERR) THEN
+         print*, 'Oh probleme lecture dimension lon'
+      ENDIF
+      ierr=NF_INQ_DIMLEN(nid,rid,jj)
+      print*,'OK2 nid,rid,lat',nid,rid,jj
+!.......................................................................
+      ierr=NF_INQ_DIMID(nid,'lev',rid)
+      IF (ierr.NE.NF_NOERR) THEN
+         print*, 'Oh probleme lecture dimension zz'
+      ENDIF
+      ierr=NF_INQ_DIMLEN(nid,rid,nlev_cas)
+      print*,'OK3 nid,rid,nlev_cas',nid,rid,nlev_cas
+!.......................................................................
+      ierr=NF_INQ_DIMID(nid,'time',rid)
+      print*,'nid,rid',nid,rid
+      nt_cas=0
+      IF (ierr.NE.NF_NOERR) THEN
+        stop 'probleme lecture dimension sens'
+      ENDIF
+      ierr=NF_INQ_DIMLEN(nid,rid,nt_cas)
+      print*,'OK4 nid,rid,nt_cas',nid,rid,nt_cas
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!profils moyens:
+        allocate(plev_cas(nlev_cas,nt_cas))        
+        allocate(z_cas(nlev_cas,nt_cas))
+        allocate(t_cas(nlev_cas,nt_cas),q_cas(nlev_cas,nt_cas),rh_cas(nlev_cas,nt_cas))
+        allocate(th_cas(nlev_cas,nt_cas),rv_cas(nlev_cas,nt_cas))
+        allocate(u_cas(nlev_cas,nt_cas))
+        allocate(v_cas(nlev_cas,nt_cas))
+
+!forcing
+        allocate(ht_cas(nlev_cas,nt_cas),vt_cas(nlev_cas,nt_cas),dt_cas(nlev_cas,nt_cas),dtrad_cas(nlev_cas,nt_cas))
+        allocate(hq_cas(nlev_cas,nt_cas),vq_cas(nlev_cas,nt_cas),dq_cas(nlev_cas,nt_cas))
+        allocate(hth_cas(nlev_cas,nt_cas),vth_cas(nlev_cas,nt_cas),dth_cas(nlev_cas,nt_cas))
+        allocate(hr_cas(nlev_cas,nt_cas),vr_cas(nlev_cas,nt_cas),dr_cas(nlev_cas,nt_cas))
+        allocate(hu_cas(nlev_cas,nt_cas),vu_cas(nlev_cas,nt_cas),du_cas(nlev_cas,nt_cas))
+        allocate(hv_cas(nlev_cas,nt_cas),vv_cas(nlev_cas,nt_cas),dv_cas(nlev_cas,nt_cas))
+        allocate(vitw_cas(nlev_cas,nt_cas))
+        allocate(ug_cas(nlev_cas,nt_cas))
+        allocate(vg_cas(nlev_cas,nt_cas))
+        allocate(lat_cas(nt_cas),sens_cas(nt_cas),ts_cas(nt_cas),ustar_cas(nt_cas))
+        allocate(uw_cas(nlev_cas,nt_cas),vw_cas(nlev_cas,nt_cas),q1_cas(nlev_cas,nt_cas),q2_cas(nlev_cas,nt_cas))
+
+
+!champs interpoles
+        allocate(plev_prof_cas(nlev_cas))
+        allocate(t_prof_cas(nlev_cas))
+        allocate(q_prof_cas(nlev_cas))
+        allocate(u_prof_cas(nlev_cas))
+        allocate(v_prof_cas(nlev_cas))
+
+        allocate(vitw_prof_cas(nlev_cas))
+        allocate(ug_prof_cas(nlev_cas))
+        allocate(vg_prof_cas(nlev_cas))
+        allocate(ht_prof_cas(nlev_cas))
+        allocate(hq_prof_cas(nlev_cas))
+        allocate(hu_prof_cas(nlev_cas))
+        allocate(hv_prof_cas(nlev_cas))
+        allocate(vt_prof_cas(nlev_cas))
+        allocate(vq_prof_cas(nlev_cas))
+        allocate(vu_prof_cas(nlev_cas))
+        allocate(vv_prof_cas(nlev_cas))
+        allocate(dt_prof_cas(nlev_cas))
+        allocate(dtrad_prof_cas(nlev_cas))
+        allocate(dq_prof_cas(nlev_cas))
+        allocate(du_prof_cas(nlev_cas))
+        allocate(dv_prof_cas(nlev_cas))
+        allocate(uw_prof_cas(nlev_cas))
+        allocate(vw_prof_cas(nlev_cas))
+        allocate(q1_prof_cas(nlev_cas))
+        allocate(q2_prof_cas(nlev_cas))
+
+        print*,'Allocations OK'
+        call read_cas(nid,nlev_cas,nt_cas                                       &
+     &     ,z_cas,plev_cas,t_cas,q_cas,rh_cas,th_cas,rv_cas,u_cas,v_cas         &
+     &     ,ug_cas,vg_cas,vitw_cas,du_cas,hu_cas,vu_cas,dv_cas,hv_cas,vv_cas    &
+     &     ,dt_cas,dtrad_cas,ht_cas,vt_cas,dq_cas,hq_cas,vq_cas                 &
+     &     ,dth_cas,hth_cas,vth_cas,dr_cas,hr_cas,vr_cas,sens_cas,lat_cas,ts_cas&
+     &     ,ustar_cas,uw_cas,vw_cas,q1_cas,q2_cas)
+        print*,'Read cas OK'
+
+
+END SUBROUTINE read_1D_cas
+
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+SUBROUTINE deallocate_1D_cases
+!profils environnementaux:
+        deallocate(plev_cas)
+        
+        deallocate(z_cas)
+        deallocate(t_cas,q_cas,rh_cas)
+        deallocate(th_cas,rv_cas)
+        deallocate(u_cas)
+        deallocate(v_cas)
+        
+!forcing
+        deallocate(ht_cas,vt_cas,dt_cas,dtrad_cas)
+        deallocate(hq_cas,vq_cas,dq_cas)
+        deallocate(hth_cas,vth_cas,dth_cas)
+        deallocate(hr_cas,vr_cas,dr_cas)
+        deallocate(hu_cas,vu_cas,du_cas)
+        deallocate(hv_cas,vv_cas,dv_cas)
+        deallocate(vitw_cas)
+        deallocate(ug_cas)
+        deallocate(vg_cas)
+        deallocate(lat_cas,sens_cas,ts_cas,ustar_cas,uw_cas,vw_cas,q1_cas,q2_cas)
+
+!champs interpoles
+        deallocate(plev_prof_cas)
+        deallocate(t_prof_cas)
+        deallocate(q_prof_cas)
+        deallocate(u_prof_cas)
+        deallocate(v_prof_cas)
+
+        deallocate(vitw_prof_cas)
+        deallocate(ug_prof_cas)
+        deallocate(vg_prof_cas)
+        deallocate(ht_prof_cas)
+        deallocate(hq_prof_cas)
+        deallocate(hu_prof_cas)
+        deallocate(hv_prof_cas)
+        deallocate(vt_prof_cas)
+        deallocate(vq_prof_cas)
+        deallocate(vu_prof_cas)
+        deallocate(vv_prof_cas)
+        deallocate(dt_prof_cas)
+        deallocate(dtrad_prof_cas)
+        deallocate(dq_prof_cas)
+        deallocate(du_prof_cas)
+        deallocate(dv_prof_cas)
+        deallocate(t_prof_cas)
+        deallocate(q_prof_cas)
+        deallocate(u_prof_cas)
+        deallocate(v_prof_cas)
+        deallocate(uw_prof_cas)
+        deallocate(vw_prof_cas)
+        deallocate(q1_prof_cas)
+        deallocate(q2_prof_cas)
+
+END SUBROUTINE deallocate_1D_cases
+
+
+END MODULE mod_1D_cases_read
+!=====================================================================
+      subroutine read_cas(nid,nlevel,ntime                          &
+     &     ,zz,pp,temp,qv,rh,theta,rv,u,v,ug,vg,w,                   &
+     &     du,hu,vu,dv,hv,vv,dt,dtrad,ht,vt,dq,hq,vq,                     &
+     &     dth,hth,vth,dr,hr,vr,sens,flat,ts,ustar,uw,vw,q1,q2)
+
+!program reading forcing of the case study
+      USE netcdf, ONLY: nf90_get_var
+      implicit none
+      INCLUDE "netcdf.inc"
+
+      integer ntime,nlevel
+
+      real zz(nlevel,ntime)
+      real pp(nlevel,ntime)
+      real temp(nlevel,ntime),qv(nlevel,ntime),rh(nlevel,ntime)
+      real theta(nlevel,ntime),rv(nlevel,ntime)
+      real u(nlevel,ntime)
+      real v(nlevel,ntime)
+      real ug(nlevel,ntime)
+      real vg(nlevel,ntime)
+      real w(nlevel,ntime)
+      real du(nlevel,ntime),hu(nlevel,ntime),vu(nlevel,ntime)
+      real dv(nlevel,ntime),hv(nlevel,ntime),vv(nlevel,ntime)
+      real dt(nlevel,ntime),ht(nlevel,ntime),vt(nlevel,ntime)
+      real dtrad(nlevel,ntime)
+      real dq(nlevel,ntime),hq(nlevel,ntime),vq(nlevel,ntime)
+      real dth(nlevel,ntime),hth(nlevel,ntime),vth(nlevel,ntime)
+      real dr(nlevel,ntime),hr(nlevel,ntime),vr(nlevel,ntime)
+      real flat(ntime),sens(ntime),ts(ntime),ustar(ntime)
+      real uw(nlevel,ntime),vw(nlevel,ntime),q1(nlevel,ntime),q2(nlevel,ntime)
+
+
+      integer nid, ierr,rid
+      integer nbvar3d
+      parameter(nbvar3d=39)
+      integer var3didin(nbvar3d)
+
+       ierr=NF_INQ_VARID(nid,"zz",var3didin(1)) 
+         if(ierr/=NF_NOERR) then
+           write(*,*) NF_STRERROR(ierr)
+           stop 'lev'
+         endif
+      
+      ierr=NF_INQ_VARID(nid,"pp",var3didin(2)) 
+         if(ierr/=NF_NOERR) then
+           write(*,*) NF_STRERROR(ierr)
+           stop 'plev'
+         endif
+
+
+      ierr=NF_INQ_VARID(nid,"temp",var3didin(3))
+         if(ierr/=NF_NOERR) then
+           write(*,*) NF_STRERROR(ierr)
+           stop 'temp'
+         endif
+
+      ierr=NF_INQ_VARID(nid,"qv",var3didin(4))
+         if(ierr/=NF_NOERR) then
+           write(*,*) NF_STRERROR(ierr)
+           stop 'qv'
+         endif
+
+      ierr=NF_INQ_VARID(nid,"rh",var3didin(5))
+         if(ierr/=NF_NOERR) then
+           write(*,*) NF_STRERROR(ierr)
+           stop 'rh'
+         endif
+
+      ierr=NF_INQ_VARID(nid,"theta",var3didin(6))
+         if(ierr/=NF_NOERR) then
+           write(*,*) NF_STRERROR(ierr)
+           stop 'theta'
+         endif
+
+      ierr=NF_INQ_VARID(nid,"rv",var3didin(7))
+         if(ierr/=NF_NOERR) then
+           write(*,*) NF_STRERROR(ierr)
+           stop 'rv'
+         endif
+
+
+      ierr=NF_INQ_VARID(nid,"u",var3didin(8))
+         if(ierr/=NF_NOERR) then
+           write(*,*) NF_STRERROR(ierr)
+           stop 'u'
+         endif
+
+      ierr=NF_INQ_VARID(nid,"v",var3didin(9))
+         if(ierr/=NF_NOERR) then
+           write(*,*) NF_STRERROR(ierr)
+           stop 'v'
+         endif
+
+       ierr=NF_INQ_VARID(nid,"ug",var3didin(10))
+         if(ierr/=NF_NOERR) then
+           write(*,*) NF_STRERROR(ierr)
+           stop 'ug'
+         endif
+
+      ierr=NF_INQ_VARID(nid,"vg",var3didin(11))
+         if(ierr/=NF_NOERR) then
+           write(*,*) NF_STRERROR(ierr)
+           stop 'vg'
+         endif
+
+      ierr=NF_INQ_VARID(nid,"w",var3didin(12))
+         if(ierr/=NF_NOERR) then
+           write(*,*) NF_STRERROR(ierr)
+           stop 'w'
+         endif
+
+      ierr=NF_INQ_VARID(nid,"advu",var3didin(13))
+         if(ierr/=NF_NOERR) then
+           write(*,*) NF_STRERROR(ierr)
+           stop 'advu'
+         endif
+
+      ierr=NF_INQ_VARID(nid,"hu",var3didin(14))
+         if(ierr/=NF_NOERR) then
+           write(*,*) NF_STRERROR(ierr)
+           stop 'hu'
+         endif
+
+       ierr=NF_INQ_VARID(nid,"vu",var3didin(15))
+         if(ierr/=NF_NOERR) then
+           write(*,*) NF_STRERROR(ierr)
+           stop 'vu'
+         endif
+
+       ierr=NF_INQ_VARID(nid,"advv",var3didin(16))
+         if(ierr/=NF_NOERR) then
+           write(*,*) NF_STRERROR(ierr)
+           stop 'advv'
+         endif
+
+      ierr=NF_INQ_VARID(nid,"hv",var3didin(17))
+         if(ierr/=NF_NOERR) then
+           write(*,*) NF_STRERROR(ierr)
+           stop 'hv'
+         endif
+
+       ierr=NF_INQ_VARID(nid,"vv",var3didin(18))
+         if(ierr/=NF_NOERR) then
+           write(*,*) NF_STRERROR(ierr)
+           stop 'vv'
+         endif
+
+      ierr=NF_INQ_VARID(nid,"advT",var3didin(19))
+         if(ierr/=NF_NOERR) then
+           write(*,*) NF_STRERROR(ierr)
+           stop 'advT'
+         endif
+
+      ierr=NF_INQ_VARID(nid,"hT",var3didin(20))
+         if(ierr/=NF_NOERR) then
+           write(*,*) NF_STRERROR(ierr)
+           stop 'hT'
+         endif
+
+      ierr=NF_INQ_VARID(nid,"vT",var3didin(21))
+         if(ierr/=NF_NOERR) then
+           write(*,*) NF_STRERROR(ierr)
+           stop 'vT'
+         endif
+
+      ierr=NF_INQ_VARID(nid,"advq",var3didin(22))
+         if(ierr/=NF_NOERR) then
+           write(*,*) NF_STRERROR(ierr)
+           stop 'advq'
+         endif
+      
+      ierr=NF_INQ_VARID(nid,"hq",var3didin(23))
+         if(ierr/=NF_NOERR) then
+           write(*,*) NF_STRERROR(ierr)
+           stop 'hq'
+         endif
+
+      ierr=NF_INQ_VARID(nid,"vq",var3didin(24))
+         if(ierr/=NF_NOERR) then
+           write(*,*) NF_STRERROR(ierr)
+           stop 'vq'
+         endif
+
+      ierr=NF_INQ_VARID(nid,"advth",var3didin(25))
+         if(ierr/=NF_NOERR) then
+           write(*,*) NF_STRERROR(ierr)
+           stop 'advth'
+         endif
+
+      ierr=NF_INQ_VARID(nid,"hth",var3didin(26))
+         if(ierr/=NF_NOERR) then
+           write(*,*) NF_STRERROR(ierr)
+           stop 'hth'
+         endif
+
+      ierr=NF_INQ_VARID(nid,"vth",var3didin(27))
+         if(ierr/=NF_NOERR) then
+           write(*,*) NF_STRERROR(ierr)
+           stop 'vth'
+         endif
+
+      ierr=NF_INQ_VARID(nid,"advr",var3didin(28))
+         if(ierr/=NF_NOERR) then
+           write(*,*) NF_STRERROR(ierr)
+           stop 'advr'
+         endif
+      
+      ierr=NF_INQ_VARID(nid,"hr",var3didin(29))
+         if(ierr/=NF_NOERR) then
+           write(*,*) NF_STRERROR(ierr)
+           stop 'hr'
+         endif
+
+      ierr=NF_INQ_VARID(nid,"vr",var3didin(30))
+         if(ierr/=NF_NOERR) then
+           write(*,*) NF_STRERROR(ierr)
+           stop 'vr'
+         endif
+
+      ierr=NF_INQ_VARID(nid,"radT",var3didin(31))
+         if(ierr/=NF_NOERR) then
+           write(*,*) NF_STRERROR(ierr)
+           stop 'radT'
+         endif
+
+      ierr=NF_INQ_VARID(nid,"sens",var3didin(32))
+         if(ierr/=NF_NOERR) then
+           write(*,*) NF_STRERROR(ierr)
+           stop 'sens'
+         endif
+
+      ierr=NF_INQ_VARID(nid,"flat",var3didin(33))
+         if(ierr/=NF_NOERR) then
+           write(*,*) NF_STRERROR(ierr)
+           stop 'flat'
+         endif
+
+      ierr=NF_INQ_VARID(nid,"ts",var3didin(34))
+         if(ierr/=NF_NOERR) then
+           write(*,*) NF_STRERROR(ierr)
+           stop 'ts'
+         endif
+
+      ierr=NF_INQ_VARID(nid,"ustar",var3didin(35))
+         if(ierr/=NF_NOERR) then
+           write(*,*) NF_STRERROR(ierr)
+           stop 'ustar'
+         endif
+
+      ierr=NF_INQ_VARID(nid,"uw",var3didin(36))
+         if(ierr/=NF_NOERR) then
+           write(*,*) NF_STRERROR(ierr)
+           stop 'uw'
+         endif
+
+      ierr=NF_INQ_VARID(nid,"vw",var3didin(37))
+         if(ierr/=NF_NOERR) then
+           write(*,*) NF_STRERROR(ierr)
+           stop 'vw'
+         endif
+
+      ierr=NF_INQ_VARID(nid,"q1",var3didin(38))
+         if(ierr/=NF_NOERR) then
+           write(*,*) NF_STRERROR(ierr)
+           stop 'q1'
+         endif
+
+      ierr=NF_INQ_VARID(nid,"q2",var3didin(39))
+         if(ierr/=NF_NOERR) then
+           write(*,*) NF_STRERROR(ierr)
+           stop 'q2'
+         endif
+ 
+         ierr = nf90_get_var(nid, var3didin(1), zz)
+         if(ierr/=NF_NOERR) then
+            write(*,*) NF_STRERROR(ierr)
+            stop "getvarup"
+         endif
+!          write(*,*)'lecture z ok',zz
+
+         ierr = nf90_get_var(nid, var3didin(2), pp)
+         if(ierr/=NF_NOERR) then
+            write(*,*) NF_STRERROR(ierr)
+            stop "getvarup"
+         endif
+!          write(*,*)'lecture pp ok',pp
+
+
+         ierr = nf90_get_var(nid, var3didin(3), temp)
+         if(ierr/=NF_NOERR) then
+            write(*,*) NF_STRERROR(ierr)
+            stop "getvarup"
+         endif
+!          write(*,*)'lecture T ok',temp
+
+         ierr = nf90_get_var(nid, var3didin(4), qv)
+         if(ierr/=NF_NOERR) then
+            write(*,*) NF_STRERROR(ierr)
+            stop "getvarup"
+         endif
+!          write(*,*)'lecture qv ok',qv
+ 
+         ierr = nf90_get_var(nid, var3didin(5), rh)
+         if(ierr/=NF_NOERR) then
+            write(*,*) NF_STRERROR(ierr)
+            stop "getvarup"
+         endif
+!          write(*,*)'lecture rh ok',rh
+
+         ierr = nf90_get_var(nid, var3didin(6), theta)
+         if(ierr/=NF_NOERR) then
+            write(*,*) NF_STRERROR(ierr)
+            stop "getvarup"
+         endif
+!          write(*,*)'lecture theta ok',theta
+
+         ierr = nf90_get_var(nid, var3didin(7), rv)
+         if(ierr/=NF_NOERR) then
+            write(*,*) NF_STRERROR(ierr)
+            stop "getvarup"
+         endif
+!          write(*,*)'lecture rv ok',rv
+
+         ierr = nf90_get_var(nid, var3didin(8), u)
+         if(ierr/=NF_NOERR) then
+            write(*,*) NF_STRERROR(ierr)
+            stop "getvarup"
+         endif
+!          write(*,*)'lecture u ok',u
+
+         ierr = nf90_get_var(nid, var3didin(9), v)
+         if(ierr/=NF_NOERR) then
+            write(*,*) NF_STRERROR(ierr)
+            stop "getvarup"
+         endif
+!          write(*,*)'lecture v ok',v
+
+         ierr = nf90_get_var(nid, var3didin(10), ug)
+         if(ierr/=NF_NOERR) then
+            write(*,*) NF_STRERROR(ierr)
+            stop "getvarup"
+         endif
+!          write(*,*)'lecture ug ok',ug
+
+         ierr = nf90_get_var(nid, var3didin(11), vg)
+         if(ierr/=NF_NOERR) then
+            write(*,*) NF_STRERROR(ierr)
+            stop "getvarup"
+         endif
+!          write(*,*)'lecture vg ok',vg
+
+         ierr = nf90_get_var(nid, var3didin(12), w)
+         if(ierr/=NF_NOERR) then
+            write(*,*) NF_STRERROR(ierr)
+            stop "getvarup"
+         endif
+!          write(*,*)'lecture w ok',w
+
+         ierr = nf90_get_var(nid, var3didin(13), du)
+         if(ierr/=NF_NOERR) then
+            write(*,*) NF_STRERROR(ierr)
+            stop "getvarup"
+         endif
+!          write(*,*)'lecture du ok',du
+
+         ierr = nf90_get_var(nid, var3didin(14), hu)
+         if(ierr/=NF_NOERR) then
+            write(*,*) NF_STRERROR(ierr)
+            stop "getvarup"
+         endif
+!          write(*,*)'lecture hu ok',hu
+
+         ierr = nf90_get_var(nid, var3didin(15), vu)
+         if(ierr/=NF_NOERR) then
+            write(*,*) NF_STRERROR(ierr)
+            stop "getvarup"
+         endif
+!          write(*,*)'lecture vu ok',vu
+
+         ierr = nf90_get_var(nid, var3didin(16), dv)
+         if(ierr/=NF_NOERR) then
+            write(*,*) NF_STRERROR(ierr)
+            stop "getvarup"
+         endif
+!          write(*,*)'lecture dv ok',dv
+
+         ierr = nf90_get_var(nid, var3didin(17), hv)
+         if(ierr/=NF_NOERR) then
+            write(*,*) NF_STRERROR(ierr)
+            stop "getvarup"
+         endif
+!          write(*,*)'lecture hv ok',hv
+
+         ierr = nf90_get_var(nid, var3didin(18), vv)
+         if(ierr/=NF_NOERR) then
+            write(*,*) NF_STRERROR(ierr)
+            stop "getvarup"
+         endif
+!          write(*,*)'lecture vv ok',vv
+
+         ierr = nf90_get_var(nid, var3didin(19), dt)
+         if(ierr/=NF_NOERR) then
+            write(*,*) NF_STRERROR(ierr)
+            stop "getvarup"
+         endif
+!          write(*,*)'lecture dt ok',dt
+
+         ierr = nf90_get_var(nid, var3didin(20), ht)
+         if(ierr/=NF_NOERR) then
+            write(*,*) NF_STRERROR(ierr)
+            stop "getvarup"
+         endif
+!          write(*,*)'lecture ht ok',ht
+
+         ierr = nf90_get_var(nid, var3didin(21), vt)
+         if(ierr/=NF_NOERR) then
+            write(*,*) NF_STRERROR(ierr)
+            stop "getvarup"
+         endif
+!          write(*,*)'lecture vt ok',vt
+
+         ierr = nf90_get_var(nid, var3didin(22), dq)
+         if(ierr/=NF_NOERR) then
+            write(*,*) NF_STRERROR(ierr)
+            stop "getvarup"
+         endif
+!          write(*,*)'lecture dq ok',dq
+
+         ierr = nf90_get_var(nid, var3didin(23), hq)
+         if(ierr/=NF_NOERR) then
+            write(*,*) NF_STRERROR(ierr)
+            stop "getvarup"
+         endif
+!          write(*,*)'lecture hq ok',hq
+
+         ierr = nf90_get_var(nid, var3didin(24), vq)
+         if(ierr/=NF_NOERR) then
+            write(*,*) NF_STRERROR(ierr)
+            stop "getvarup"
+         endif
+!          write(*,*)'lecture vq ok',vq
+
+         ierr = nf90_get_var(nid, var3didin(25), dth)
+         if(ierr/=NF_NOERR) then
+            write(*,*) NF_STRERROR(ierr)
+            stop "getvarup"
+         endif
+!          write(*,*)'lecture dth ok',dth
+
+         ierr = nf90_get_var(nid, var3didin(26), hth)
+         if(ierr/=NF_NOERR) then
+            write(*,*) NF_STRERROR(ierr)
+            stop "getvarup"
+         endif
+!          write(*,*)'lecture hth ok',hth
+
+         ierr = nf90_get_var(nid, var3didin(27), vth)
+         if(ierr/=NF_NOERR) then
+            write(*,*) NF_STRERROR(ierr)
+            stop "getvarup"
+         endif
+!          write(*,*)'lecture vth ok',vth
+
+         ierr = nf90_get_var(nid, var3didin(28), dr)
+         if(ierr/=NF_NOERR) then
+            write(*,*) NF_STRERROR(ierr)
+            stop "getvarup"
+         endif
+!          write(*,*)'lecture dr ok',dr
+
+         ierr = nf90_get_var(nid, var3didin(29), hr)
+         if(ierr/=NF_NOERR) then
+            write(*,*) NF_STRERROR(ierr)
+            stop "getvarup"
+         endif
+!          write(*,*)'lecture hr ok',hr
+
+         ierr = nf90_get_var(nid, var3didin(30), vr)
+         if(ierr/=NF_NOERR) then
+            write(*,*) NF_STRERROR(ierr)
+            stop "getvarup"
+         endif
+!          write(*,*)'lecture vr ok',vr
+
+         ierr = nf90_get_var(nid, var3didin(31), dtrad)
+         if(ierr/=NF_NOERR) then
+            write(*,*) NF_STRERROR(ierr)
+            stop "getvarup"
+         endif
+!          write(*,*)'lecture dtrad ok',dtrad
+
+         ierr = nf90_get_var(nid, var3didin(32), sens)
+         if(ierr/=NF_NOERR) then
+            write(*,*) NF_STRERROR(ierr)
+            stop "getvarup"
+         endif
+!          write(*,*)'lecture sens ok',sens
+
+         ierr = nf90_get_var(nid, var3didin(33), flat)
+         if(ierr/=NF_NOERR) then
+            write(*,*) NF_STRERROR(ierr)
+            stop "getvarup"
+         endif
+!          write(*,*)'lecture flat ok',flat
+
+         ierr = nf90_get_var(nid, var3didin(34), ts)
+         if(ierr/=NF_NOERR) then
+            write(*,*) NF_STRERROR(ierr)
+            stop "getvarup"
+         endif
+!          write(*,*)'lecture ts ok',ts
+
+         ierr = nf90_get_var(nid, var3didin(35), ustar)
+         if(ierr/=NF_NOERR) then
+            write(*,*) NF_STRERROR(ierr)
+            stop "getvarup"
+         endif
+!         write(*,*)'lecture ustar ok',ustar
+
+         ierr = nf90_get_var(nid, var3didin(36), uw)
+         if(ierr/=NF_NOERR) then
+            write(*,*) NF_STRERROR(ierr)
+            stop "getvarup"
+         endif
+!         write(*,*)'lecture uw ok',uw
+
+         ierr = nf90_get_var(nid, var3didin(37), vw)
+         if(ierr/=NF_NOERR) then
+            write(*,*) NF_STRERROR(ierr)
+            stop "getvarup"
+         endif
+!         write(*,*)'lecture vw ok',vw
+
+         ierr = nf90_get_var(nid, var3didin(38), q1)
+         if(ierr/=NF_NOERR) then
+            write(*,*) NF_STRERROR(ierr)
+            stop "getvarup"
+         endif
+!         write(*,*)'lecture q1 ok',q1
+
+         ierr = nf90_get_var(nid, var3didin(39), q2)
+         if(ierr/=NF_NOERR) then
+            write(*,*) NF_STRERROR(ierr)
+            stop "getvarup"
+         endif
+!         write(*,*)'lecture q2 ok',q2
+
+
+         return 
+         end subroutine read_cas
+!======================================================================
+        SUBROUTINE interp_case_time(day,day1,annee_ref                &
+!    &         ,year_cas,day_cas,nt_cas,pdt_forc,nlev_cas      &
+     &         ,nt_cas,nlev_cas                                       &
+     &         ,ts_cas,plev_cas,t_cas,q_cas,u_cas,v_cas               &
+     &         ,ug_cas,vg_cas,vitw_cas,du_cas,hu_cas,vu_cas           &
+     &         ,dv_cas,hv_cas,vv_cas,dt_cas,ht_cas,vt_cas,dtrad_cas   &
+     &         ,dq_cas,hq_cas,vq_cas,lat_cas,sens_cas,ustar_cas       &
+     &         ,uw_cas,vw_cas,q1_cas,q2_cas                           &
+     &         ,ts_prof_cas,plev_prof_cas,t_prof_cas,q_prof_cas       &
+     &         ,u_prof_cas,v_prof_cas,ug_prof_cas,vg_prof_cas         &
+     &         ,vitw_prof_cas,du_prof_cas,hu_prof_cas,vu_prof_cas     &
+     &         ,dv_prof_cas,hv_prof_cas,vv_prof_cas,dt_prof_cas       &
+     &         ,ht_prof_cas,vt_prof_cas,dtrad_prof_cas,dq_prof_cas    &
+     &         ,hq_prof_cas,vq_prof_cas,lat_prof_cas,sens_prof_cas    &
+     &         ,ustar_prof_cas,uw_prof_cas,vw_prof_cas,q1_prof_cas,q2_prof_cas)
+          
+
+        implicit none
+
+!---------------------------------------------------------------------------------------
+! Time interpolation of a 2D field to the timestep corresponding to day
+!
+! day: current julian day (e.g. 717538.2)
+! day1: first day of the simulation
+! nt_cas: total nb of data in the forcing 
+! pdt_cas: total time interval (in sec) between 2 forcing data
+!---------------------------------------------------------------------------------------
+
+        INCLUDE "compar1d.h"
+        INCLUDE "date_cas.h"
+
+! inputs:
+        integer annee_ref
+        integer nt_cas,nlev_cas
+        real day, day1,day_cas
+        real ts_cas(nt_cas)
+        real plev_cas(nlev_cas,nt_cas)
+        real t_cas(nlev_cas,nt_cas),q_cas(nlev_cas,nt_cas)
+        real u_cas(nlev_cas,nt_cas),v_cas(nlev_cas,nt_cas)
+        real ug_cas(nlev_cas,nt_cas),vg_cas(nlev_cas,nt_cas)
+        real vitw_cas(nlev_cas,nt_cas)
+        real du_cas(nlev_cas,nt_cas),hu_cas(nlev_cas,nt_cas),vu_cas(nlev_cas,nt_cas)
+        real dv_cas(nlev_cas,nt_cas),hv_cas(nlev_cas,nt_cas),vv_cas(nlev_cas,nt_cas)
+        real dt_cas(nlev_cas,nt_cas),ht_cas(nlev_cas,nt_cas),vt_cas(nlev_cas,nt_cas)
+        real dtrad_cas(nlev_cas,nt_cas)
+        real dq_cas(nlev_cas,nt_cas),hq_cas(nlev_cas,nt_cas),vq_cas(nlev_cas,nt_cas)
+        real lat_cas(nt_cas)
+        real sens_cas(nt_cas)
+        real ustar_cas(nt_cas),uw_cas(nlev_cas,nt_cas),vw_cas(nlev_cas,nt_cas)
+        real q1_cas(nlev_cas,nt_cas),q2_cas(nlev_cas,nt_cas)
+
+! outputs:
+        real plev_prof_cas(nlev_cas)
+        real t_prof_cas(nlev_cas),q_prof_cas(nlev_cas)
+        real u_prof_cas(nlev_cas),v_prof_cas(nlev_cas)
+        real ug_prof_cas(nlev_cas),vg_prof_cas(nlev_cas)
+        real vitw_prof_cas(nlev_cas)
+        real du_prof_cas(nlev_cas),hu_prof_cas(nlev_cas),vu_prof_cas(nlev_cas)
+        real dv_prof_cas(nlev_cas),hv_prof_cas(nlev_cas),vv_prof_cas(nlev_cas)
+        real dt_prof_cas(nlev_cas),ht_prof_cas(nlev_cas),vt_prof_cas(nlev_cas)
+        real dtrad_prof_cas(nlev_cas)
+        real dq_prof_cas(nlev_cas),hq_prof_cas(nlev_cas),vq_prof_cas(nlev_cas)
+        real lat_prof_cas,sens_prof_cas,ts_prof_cas,ustar_prof_cas
+        real uw_prof_cas(nlev_cas),vw_prof_cas(nlev_cas),q1_prof_cas(nlev_cas),q2_prof_cas(nlev_cas)
+! local:
+        integer it_cas1, it_cas2,k
+        real timeit,time_cas1,time_cas2,frac
+
+
+        print*,'Check time',day1,day_ju_ini_cas,day_deb+1,pdt_cas
+
+! On teste si la date du cas AMMA est correcte.
+! C est pour memoire car en fait les fichiers .def
+! sont censes etre corrects.
+! A supprimer a terme (MPL 20150623)
+!     if ((forcing_type.eq.10).and.(1.eq.0)) then
+! Check that initial day of the simulation consistent with AMMA case:
+!      if (annee_ref.ne.2006) then
+!       print*,'Pour AMMA, annee_ref doit etre 2006'
+!       print*,'Changer annee_ref dans run.def'
+!       stop
+!      endif
+!      if (annee_ref.eq.2006 .and. day1.lt.day_cas) then
+!       print*,'AMMA a debute le 10 juillet 2006',day1,day_cas
+!       print*,'Changer dayref dans run.def'
+!       stop
+!      endif
+!      if (annee_ref.eq.2006 .and. day1.gt.day_cas+1) then
+!       print*,'AMMA a fini le 11 juillet'
+!       print*,'Changer dayref ou nday dans run.def'
+!       stop
+!      endif
+!      endif
+
+! Determine timestep relative to the 1st day:
+!       timeit=(day-day1)*86400.
+!       if (annee_ref.eq.1992) then
+!        timeit=(day-day_cas)*86400.
+!       else
+!        timeit=(day+61.-1.)*86400. ! 61 days between Nov01 and Dec31 1992
+!       endif
+      timeit=(day-day_ju_ini_cas)*86400
+      print *,'day=',day
+      print *,'day_ju_ini_cas=',day_ju_ini_cas
+      print *,'pdt_cas=',pdt_cas
+      print *,'timeit=',timeit
+      print *,'nt_cas=',nt_cas
+
+! Determine the closest observation times:
+!       it_cas1=INT(timeit/pdt_cas)+1
+!       it_cas2=it_cas1 + 1
+!       time_cas1=(it_cas1-1)*pdt_cas
+!       time_cas2=(it_cas2-1)*pdt_cas
+
+       it_cas1=INT(timeit/pdt_cas)+1
+       IF (it_cas1 .EQ. nt_cas) THEN
+       it_cas2=it_cas1 
+       ELSE
+       it_cas2=it_cas1 + 1
+       ENDIF
+       time_cas1=(it_cas1-1)*pdt_cas
+       time_cas2=(it_cas2-1)*pdt_cas
+      print *,'it_cas1=',it_cas1
+      print *,'it_cas2=',it_cas2
+      print *,'time_cas1=',time_cas1
+      print *,'time_cas2=',time_cas2
+
+       if (it_cas1 .gt. nt_cas) then
+        write(*,*) 'PB-stop: day, day_ju_ini_cas,it_cas1, it_cas2, timeit: '            &
+     &        ,day,day_ju_ini_cas,it_cas1,it_cas2,timeit
+        stop
+       endif
+
+! time interpolation:
+       IF (it_cas1 .EQ. it_cas2) THEN
+          frac=0.
+       ELSE
+          frac=(time_cas2-timeit)/(time_cas2-time_cas1)
+          frac=max(frac,0.0)
+       ENDIF
+
+       lat_prof_cas = lat_cas(it_cas2)                                       &
+     &          -frac*(lat_cas(it_cas2)-lat_cas(it_cas1)) 
+       sens_prof_cas = sens_cas(it_cas2)                                     &
+     &          -frac*(sens_cas(it_cas2)-sens_cas(it_cas1))
+       ts_prof_cas = ts_cas(it_cas2)                                         &
+     &          -frac*(ts_cas(it_cas2)-ts_cas(it_cas1))
+       ustar_prof_cas = ustar_cas(it_cas2)                                   &
+     &          -frac*(ustar_cas(it_cas2)-ustar_cas(it_cas1))
+
+       do k=1,nlev_cas
+        plev_prof_cas(k) = plev_cas(k,it_cas2)                               &
+     &          -frac*(plev_cas(k,it_cas2)-plev_cas(k,it_cas1))
+        t_prof_cas(k) = t_cas(k,it_cas2)                               &
+     &          -frac*(t_cas(k,it_cas2)-t_cas(k,it_cas1))
+        q_prof_cas(k) = q_cas(k,it_cas2)                               &
+     &          -frac*(q_cas(k,it_cas2)-q_cas(k,it_cas1))
+        u_prof_cas(k) = u_cas(k,it_cas2)                               &
+     &          -frac*(u_cas(k,it_cas2)-u_cas(k,it_cas1))
+        v_prof_cas(k) = v_cas(k,it_cas2)                               &
+     &          -frac*(v_cas(k,it_cas2)-v_cas(k,it_cas1))
+        ug_prof_cas(k) = ug_cas(k,it_cas2)                               &
+     &          -frac*(ug_cas(k,it_cas2)-ug_cas(k,it_cas1))
+        vg_prof_cas(k) = vg_cas(k,it_cas2)                               &
+     &          -frac*(vg_cas(k,it_cas2)-vg_cas(k,it_cas1))
+        vitw_prof_cas(k) = vitw_cas(k,it_cas2)                               &
+     &          -frac*(vitw_cas(k,it_cas2)-vitw_cas(k,it_cas1))
+        du_prof_cas(k) = du_cas(k,it_cas2)                                   &
+     &          -frac*(du_cas(k,it_cas2)-du_cas(k,it_cas1))
+        hu_prof_cas(k) = hu_cas(k,it_cas2)                                   &
+     &          -frac*(hu_cas(k,it_cas2)-hu_cas(k,it_cas1))
+        vu_prof_cas(k) = vu_cas(k,it_cas2)                                   &
+     &          -frac*(vu_cas(k,it_cas2)-vu_cas(k,it_cas1))
+        dv_prof_cas(k) = dv_cas(k,it_cas2)                                   &
+     &          -frac*(dv_cas(k,it_cas2)-dv_cas(k,it_cas1))
+        hv_prof_cas(k) = hv_cas(k,it_cas2)                                   &
+     &          -frac*(hv_cas(k,it_cas2)-hv_cas(k,it_cas1))
+        vv_prof_cas(k) = vv_cas(k,it_cas2)                                   &
+     &          -frac*(vv_cas(k,it_cas2)-vv_cas(k,it_cas1))
+        dt_prof_cas(k) = dt_cas(k,it_cas2)                                   &
+     &          -frac*(dt_cas(k,it_cas2)-dt_cas(k,it_cas1))
+        ht_prof_cas(k) = ht_cas(k,it_cas2)                                   &
+     &          -frac*(ht_cas(k,it_cas2)-ht_cas(k,it_cas1))
+        vt_prof_cas(k) = vt_cas(k,it_cas2)                                   &
+     &          -frac*(vt_cas(k,it_cas2)-vt_cas(k,it_cas1))
+        dtrad_prof_cas(k) = dtrad_cas(k,it_cas2)                                   &
+     &          -frac*(dtrad_cas(k,it_cas2)-dtrad_cas(k,it_cas1))
+        dq_prof_cas(k) = dq_cas(k,it_cas2)                                   &
+     &          -frac*(dq_cas(k,it_cas2)-dq_cas(k,it_cas1))
+        hq_prof_cas(k) = hq_cas(k,it_cas2)                                   &
+     &          -frac*(hq_cas(k,it_cas2)-hq_cas(k,it_cas1))
+        vq_prof_cas(k) = vq_cas(k,it_cas2)                                   &
+     &          -frac*(vq_cas(k,it_cas2)-vq_cas(k,it_cas1))
+       uw_prof_cas(k) = uw_cas(k,it_cas2)                                   &
+     &          -frac*(uw_cas(k,it_cas2)-uw_cas(k,it_cas1))
+       vw_prof_cas(k) = vw_cas(k,it_cas2)                                   &
+     &          -frac*(vw_cas(k,it_cas2)-vw_cas(k,it_cas1))
+       q1_prof_cas(k) = q1_cas(k,it_cas2)                                   &
+     &          -frac*(q1_cas(k,it_cas2)-q1_cas(k,it_cas1))
+       q2_prof_cas(k) = q2_cas(k,it_cas2)                                   &
+     &          -frac*(q2_cas(k,it_cas2)-q2_cas(k,it_cas1))
+        enddo
+
+        return
+        END
+
+!**********************************************************************************************
Index: DZ6/trunk/libf/phylmd/dyn1d/mod_1D_cases_read2.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/dyn1d/mod_1D_cases_read2.F90	(revision 5267)
+++ 	(revision )
@@ -1,1476 +1,0 @@
-!
-! $Id: mod_1D_cases_read.F90 2373 2015-10-13 17:28:01Z jyg $
-!
-MODULE mod_1D_cases_read2
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-  !Declarations specifiques au cas standard
-  character*80 :: fich_cas
-  ! Discr?tisation 
-  integer nlev_cas, nt_cas
-
-
-  !profils environnementaux
-  real, allocatable::  plev_cas(:,:),plevh_cas(:)
-  real, allocatable::  ap_cas(:),bp_cas(:)
-
-  real, allocatable::  z_cas(:,:),zh_cas(:)
-  real, allocatable::  t_cas(:,:),q_cas(:,:),qv_cas(:,:),ql_cas(:,:),qi_cas(:,:),rh_cas(:,:)
-  real, allocatable::  th_cas(:,:),thv_cas(:,:),thl_cas(:,:),rv_cas(:,:)
-  real, allocatable::  u_cas(:,:),v_cas(:,:),vitw_cas(:,:),omega_cas(:,:)
-
-  !forcing
-  real, allocatable::  ht_cas(:,:),vt_cas(:,:),dt_cas(:,:),dtrad_cas(:,:)
-  real, allocatable::  hth_cas(:,:),vth_cas(:,:),dth_cas(:,:)
-  real, allocatable::  hq_cas(:,:),vq_cas(:,:),dq_cas(:,:)
-  real, allocatable::  hr_cas(:,:),vr_cas(:,:),dr_cas(:,:)
-  real, allocatable::  hu_cas(:,:),vu_cas(:,:),du_cas(:,:)
-  real, allocatable::  hv_cas(:,:),vv_cas(:,:),dv_cas(:,:)
-  real, allocatable::  ug_cas(:,:),vg_cas(:,:)
-  real, allocatable::  lat_cas(:),sens_cas(:),ts_cas(:),ps_cas(:),ustar_cas(:)
-  real, allocatable::  uw_cas(:,:),vw_cas(:,:),q1_cas(:,:),q2_cas(:,:),tke_cas(:)
-
-  !champs interpoles
-  real, allocatable::  plev_prof_cas(:)
-  real, allocatable::  t_prof_cas(:)
-  real, allocatable::  theta_prof_cas(:)
-  real, allocatable::  thl_prof_cas(:)
-  real, allocatable::  thv_prof_cas(:)
-  real, allocatable::  q_prof_cas(:)
-  real, allocatable::  qv_prof_cas(:)
-  real, allocatable::  ql_prof_cas(:)
-  real, allocatable::  qi_prof_cas(:)
-  real, allocatable::  rh_prof_cas(:)
-  real, allocatable::  rv_prof_cas(:)
-  real, allocatable::  u_prof_cas(:)
-  real, allocatable::  v_prof_cas(:)        
-  real, allocatable::  vitw_prof_cas(:)
-  real, allocatable::  omega_prof_cas(:)
-  real, allocatable::  ug_prof_cas(:)
-  real, allocatable::  vg_prof_cas(:)
-  real, allocatable::  ht_prof_cas(:)
-  real, allocatable::  hth_prof_cas(:)
-  real, allocatable::  hq_prof_cas(:)
-  real, allocatable::  vt_prof_cas(:)
-  real, allocatable::  vth_prof_cas(:)
-  real, allocatable::  vq_prof_cas(:)
-  real, allocatable::  dt_prof_cas(:)
-  real, allocatable::  dth_prof_cas(:)
-  real, allocatable::  dtrad_prof_cas(:)
-  real, allocatable::  dq_prof_cas(:)
-  real, allocatable::  hu_prof_cas(:)
-  real, allocatable::  hv_prof_cas(:)
-  real, allocatable::  vu_prof_cas(:)
-  real, allocatable::  vv_prof_cas(:)
-  real, allocatable::  du_prof_cas(:)
-  real, allocatable::  dv_prof_cas(:)
-  real, allocatable::  uw_prof_cas(:)
-  real, allocatable::  vw_prof_cas(:)
-  real, allocatable::  q1_prof_cas(:)
-  real, allocatable::  q2_prof_cas(:)
-
-
-  real lat_prof_cas,sens_prof_cas,ts_prof_cas,ps_prof_cas,ustar_prof_cas,tke_prof_cas
-  real o3_cas,orog_cas,albedo_cas,emiss_cas,t_skin_cas,q_skin_cas,mom_rough,heat_rough,rugos_cas,sand_cas,clay_cas
-
-
-
-CONTAINS
-
-  SUBROUTINE read_1D_cas
-    implicit none
-
-    INCLUDE "netcdf.inc"
-
-    INTEGER nid,rid,ierr
-    INTEGER ii,jj
-
-    fich_cas='setup/cas.nc'
-    print*,'fich_cas ',fich_cas
-    ierr = NF_OPEN(fich_cas,NF_NOWRITE,nid)
-    print*,'fich_cas,NF_NOWRITE,nid ',fich_cas,NF_NOWRITE,nid
-    if (ierr.NE.NF_NOERR) then
-       write(*,*) 'ERROR: GROS Pb opening forcings nc file '
-       write(*,*) NF_STRERROR(ierr)
-       stop ""
-    endif
-    !.......................................................................
-    ierr=NF_INQ_DIMID(nid,'lat',rid)
-    IF (ierr.NE.NF_NOERR) THEN
-       print*, 'Oh probleme lecture dimension lat'
-    ENDIF
-    ierr=NF_INQ_DIMLEN(nid,rid,ii)
-    print*,'OK1 nid,rid,lat',nid,rid,ii
-    !.......................................................................
-    ierr=NF_INQ_DIMID(nid,'lon',rid)
-    IF (ierr.NE.NF_NOERR) THEN
-       print*, 'Oh probleme lecture dimension lon'
-    ENDIF
-    ierr=NF_INQ_DIMLEN(nid,rid,jj)
-    print*,'OK2 nid,rid,lat',nid,rid,jj
-    !.......................................................................
-    ierr=NF_INQ_DIMID(nid,'lev',rid)
-    IF (ierr.NE.NF_NOERR) THEN
-       print*, 'Oh probleme lecture dimension zz'
-    ENDIF
-    ierr=NF_INQ_DIMLEN(nid,rid,nlev_cas)
-    print*,'OK3 nid,rid,nlev_cas',nid,rid,nlev_cas
-    !.......................................................................
-    ierr=NF_INQ_DIMID(nid,'time',rid)
-    print*,'nid,rid',nid,rid
-    nt_cas=0
-    IF (ierr.NE.NF_NOERR) THEN
-       stop 'probleme lecture dimension sens'
-    ENDIF
-    ierr=NF_INQ_DIMLEN(nid,rid,nt_cas)
-    print*,'OK4 nid,rid,nt_cas',nid,rid,nt_cas
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-    !profils moyens:
-    allocate(plev_cas(nlev_cas,nt_cas))        
-    allocate(z_cas(nlev_cas,nt_cas))
-    allocate(t_cas(nlev_cas,nt_cas),q_cas(nlev_cas,nt_cas),rh_cas(nlev_cas,nt_cas))
-    allocate(th_cas(nlev_cas,nt_cas),rv_cas(nlev_cas,nt_cas))
-    allocate(u_cas(nlev_cas,nt_cas))
-    allocate(v_cas(nlev_cas,nt_cas))
-
-    !forcing
-    allocate(ht_cas(nlev_cas,nt_cas),vt_cas(nlev_cas,nt_cas),dt_cas(nlev_cas,nt_cas),dtrad_cas(nlev_cas,nt_cas))
-    allocate(hq_cas(nlev_cas,nt_cas),vq_cas(nlev_cas,nt_cas),dq_cas(nlev_cas,nt_cas))
-    allocate(hth_cas(nlev_cas,nt_cas),vth_cas(nlev_cas,nt_cas),dth_cas(nlev_cas,nt_cas))
-    allocate(hr_cas(nlev_cas,nt_cas),vr_cas(nlev_cas,nt_cas),dr_cas(nlev_cas,nt_cas))
-    allocate(hu_cas(nlev_cas,nt_cas),vu_cas(nlev_cas,nt_cas),du_cas(nlev_cas,nt_cas))
-    allocate(hv_cas(nlev_cas,nt_cas),vv_cas(nlev_cas,nt_cas),dv_cas(nlev_cas,nt_cas))
-    allocate(vitw_cas(nlev_cas,nt_cas))
-    allocate(ug_cas(nlev_cas,nt_cas))
-    allocate(vg_cas(nlev_cas,nt_cas))
-    allocate(lat_cas(nt_cas),sens_cas(nt_cas),ts_cas(nt_cas),ps_cas(nt_cas),ustar_cas(nt_cas))
-    allocate(uw_cas(nlev_cas,nt_cas),vw_cas(nlev_cas,nt_cas),q1_cas(nlev_cas,nt_cas),q2_cas(nlev_cas,nt_cas))
-
-
-    !champs interpoles
-    allocate(plev_prof_cas(nlev_cas))
-    allocate(t_prof_cas(nlev_cas))
-    allocate(q_prof_cas(nlev_cas))
-    allocate(u_prof_cas(nlev_cas))
-    allocate(v_prof_cas(nlev_cas))
-
-    allocate(vitw_prof_cas(nlev_cas))
-    allocate(ug_prof_cas(nlev_cas))
-    allocate(vg_prof_cas(nlev_cas))
-    allocate(ht_prof_cas(nlev_cas))
-    allocate(hq_prof_cas(nlev_cas))
-    allocate(hu_prof_cas(nlev_cas))
-    allocate(hv_prof_cas(nlev_cas))
-    allocate(vt_prof_cas(nlev_cas))
-    allocate(vq_prof_cas(nlev_cas))
-    allocate(vu_prof_cas(nlev_cas))
-    allocate(vv_prof_cas(nlev_cas))
-    allocate(dt_prof_cas(nlev_cas))
-    allocate(dtrad_prof_cas(nlev_cas))
-    allocate(dq_prof_cas(nlev_cas))
-    allocate(du_prof_cas(nlev_cas))
-    allocate(dv_prof_cas(nlev_cas))
-    allocate(uw_prof_cas(nlev_cas))
-    allocate(vw_prof_cas(nlev_cas))
-    allocate(q1_prof_cas(nlev_cas))
-    allocate(q2_prof_cas(nlev_cas))
-
-    print*,'Allocations OK'
-    call read_cas2(nid,nlev_cas,nt_cas                                       &
-         ,z_cas,plev_cas,t_cas,q_cas,rh_cas,th_cas,rv_cas,u_cas,v_cas         &
-         ,ug_cas,vg_cas,vitw_cas,du_cas,hu_cas,vu_cas,dv_cas,hv_cas,vv_cas    &
-         ,dt_cas,dtrad_cas,ht_cas,vt_cas,dq_cas,hq_cas,vq_cas                 &
-         ,dth_cas,hth_cas,vth_cas,dr_cas,hr_cas,vr_cas,sens_cas,lat_cas,ts_cas&
-         ,ustar_cas,uw_cas,vw_cas,q1_cas,q2_cas)
-    print*,'Read cas OK'
-
-
-  END SUBROUTINE read_1D_cas
-  !**********************************************************************************************
-  SUBROUTINE read2_1D_cas
-    implicit none
-
-    INCLUDE "netcdf.inc"
-
-    INTEGER nid,rid,ierr
-    INTEGER ii,jj
-
-    fich_cas='setup/cas.nc'
-    print*,'fich_cas ',fich_cas
-    ierr = NF_OPEN(fich_cas,NF_NOWRITE,nid)
-    print*,'fich_cas,NF_NOWRITE,nid ',fich_cas,NF_NOWRITE,nid
-    if (ierr.NE.NF_NOERR) then
-       write(*,*) 'ERROR: GROS Pb opening forcings nc file '
-       write(*,*) NF_STRERROR(ierr)
-       stop ""
-    endif
-    !.......................................................................
-    ierr=NF_INQ_DIMID(nid,'lat',rid)
-    IF (ierr.NE.NF_NOERR) THEN
-       print*, 'Oh probleme lecture dimension lat'
-    ENDIF
-    ierr=NF_INQ_DIMLEN(nid,rid,ii)
-    print*,'OK1 read2: nid,rid,lat',nid,rid,ii
-    !.......................................................................
-    ierr=NF_INQ_DIMID(nid,'lon',rid)
-    IF (ierr.NE.NF_NOERR) THEN
-       print*, 'Oh probleme lecture dimension lon'
-    ENDIF
-    ierr=NF_INQ_DIMLEN(nid,rid,jj)
-    print*,'OK2 read2: nid,rid,lat',nid,rid,jj
-    !.......................................................................
-    ierr=NF_INQ_DIMID(nid,'nlev',rid)
-    IF (ierr.NE.NF_NOERR) THEN
-       print*, 'Oh probleme lecture dimension nlev'
-    ENDIF
-    ierr=NF_INQ_DIMLEN(nid,rid,nlev_cas)
-    print*,'OK3 read2: nid,rid,nlev_cas',nid,rid,nlev_cas
-    !.......................................................................
-    ierr=NF_INQ_DIMID(nid,'time',rid)
-    nt_cas=0
-    IF (ierr.NE.NF_NOERR) THEN
-       stop 'Oh probleme lecture dimension time'
-    ENDIF
-    ierr=NF_INQ_DIMLEN(nid,rid,nt_cas)
-    print*,'OK4 read2: nid,rid,nt_cas',nid,rid,nt_cas
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-    !profils moyens:
-    allocate(plev_cas(nlev_cas,nt_cas),plevh_cas(nlev_cas+1))        
-    allocate(z_cas(nlev_cas,nt_cas),zh_cas(nlev_cas+1))
-    allocate(ap_cas(nlev_cas+1),bp_cas(nlev_cas+1))
-    allocate(t_cas(nlev_cas,nt_cas),q_cas(nlev_cas,nt_cas),qv_cas(nlev_cas,nt_cas),ql_cas(nlev_cas,nt_cas), &
-         qi_cas(nlev_cas,nt_cas),rh_cas(nlev_cas,nt_cas))
-    allocate(th_cas(nlev_cas,nt_cas),thl_cas(nlev_cas,nt_cas),thv_cas(nlev_cas,nt_cas),rv_cas(nlev_cas,nt_cas))
-    allocate(u_cas(nlev_cas,nt_cas),v_cas(nlev_cas,nt_cas),vitw_cas(nlev_cas,nt_cas),omega_cas(nlev_cas,nt_cas))
-
-    !forcing
-    allocate(ht_cas(nlev_cas,nt_cas),vt_cas(nlev_cas,nt_cas),dt_cas(nlev_cas,nt_cas),dtrad_cas(nlev_cas,nt_cas))
-    allocate(hq_cas(nlev_cas,nt_cas),vq_cas(nlev_cas,nt_cas),dq_cas(nlev_cas,nt_cas))
-    allocate(hth_cas(nlev_cas,nt_cas),vth_cas(nlev_cas,nt_cas),dth_cas(nlev_cas,nt_cas))
-    allocate(hr_cas(nlev_cas,nt_cas),vr_cas(nlev_cas,nt_cas),dr_cas(nlev_cas,nt_cas))
-    allocate(hu_cas(nlev_cas,nt_cas),vu_cas(nlev_cas,nt_cas),du_cas(nlev_cas,nt_cas))
-    allocate(hv_cas(nlev_cas,nt_cas),vv_cas(nlev_cas,nt_cas),dv_cas(nlev_cas,nt_cas))
-    allocate(ug_cas(nlev_cas,nt_cas))
-    allocate(vg_cas(nlev_cas,nt_cas))
-    allocate(lat_cas(nt_cas),sens_cas(nt_cas),ts_cas(nt_cas),ps_cas(nt_cas),ustar_cas(nt_cas),tke_cas(nt_cas))
-    allocate(uw_cas(nlev_cas,nt_cas),vw_cas(nlev_cas,nt_cas),q1_cas(nlev_cas,nt_cas),q2_cas(nlev_cas,nt_cas))
-
-
-
-    !champs interpoles
-    allocate(plev_prof_cas(nlev_cas))
-    allocate(t_prof_cas(nlev_cas))
-    allocate(theta_prof_cas(nlev_cas))
-    allocate(thl_prof_cas(nlev_cas))
-    allocate(thv_prof_cas(nlev_cas))
-    allocate(q_prof_cas(nlev_cas))
-    allocate(qv_prof_cas(nlev_cas))
-    allocate(ql_prof_cas(nlev_cas))
-    allocate(qi_prof_cas(nlev_cas))
-    allocate(rh_prof_cas(nlev_cas))
-    allocate(rv_prof_cas(nlev_cas))
-    allocate(u_prof_cas(nlev_cas))
-    allocate(v_prof_cas(nlev_cas))
-    allocate(vitw_prof_cas(nlev_cas))
-    allocate(omega_prof_cas(nlev_cas))
-    allocate(ug_prof_cas(nlev_cas))
-    allocate(vg_prof_cas(nlev_cas))
-    allocate(ht_prof_cas(nlev_cas))
-    allocate(hth_prof_cas(nlev_cas))
-    allocate(hq_prof_cas(nlev_cas))
-    allocate(hu_prof_cas(nlev_cas))
-    allocate(hv_prof_cas(nlev_cas))
-    allocate(vt_prof_cas(nlev_cas))
-    allocate(vth_prof_cas(nlev_cas))
-    allocate(vq_prof_cas(nlev_cas))
-    allocate(vu_prof_cas(nlev_cas))
-    allocate(vv_prof_cas(nlev_cas))
-    allocate(dt_prof_cas(nlev_cas))
-    allocate(dth_prof_cas(nlev_cas))
-    allocate(dtrad_prof_cas(nlev_cas))
-    allocate(dq_prof_cas(nlev_cas))
-    allocate(du_prof_cas(nlev_cas))
-    allocate(dv_prof_cas(nlev_cas))
-    allocate(uw_prof_cas(nlev_cas))
-    allocate(vw_prof_cas(nlev_cas))
-    allocate(q1_prof_cas(nlev_cas))
-    allocate(q2_prof_cas(nlev_cas))
-
-    print*,'Allocations OK'
-    call read2_cas (nid,nlev_cas,nt_cas,                                                                     &
-         ap_cas,bp_cas,z_cas,plev_cas,zh_cas,plevh_cas,t_cas,th_cas,thv_cas,thl_cas,qv_cas,                    &
-         ql_cas,qi_cas,rh_cas,rv_cas,u_cas,v_cas,vitw_cas,omega_cas,ug_cas,vg_cas,du_cas,hu_cas,vu_cas,        &
-         dv_cas,hv_cas,vv_cas,dt_cas,ht_cas,vt_cas,dq_cas,hq_cas,vq_cas,dth_cas,hth_cas,vth_cas,               &
-         dr_cas,hr_cas,vr_cas,dtrad_cas,sens_cas,lat_cas,ts_cas,ps_cas,ustar_cas,tke_cas,                      &
-         uw_cas,vw_cas,q1_cas,q2_cas,orog_cas,albedo_cas,emiss_cas,t_skin_cas,q_skin_cas,mom_rough,heat_rough, &
-         o3_cas,rugos_cas,clay_cas,sand_cas)
-    print*,'Read2 cas OK'
-    do ii=1,nlev_cas
-       print*,'apres read2_cas, plev_cas=',ii,plev_cas(ii,1)
-    enddo
-
-
-  END SUBROUTINE read2_1D_cas
-
-  !**********************************************************************************************
-  SUBROUTINE old_read_SCM_cas
-    use netcdf, only: nf90_get_var
-    implicit none
-
-    INCLUDE "netcdf.inc"
-    INCLUDE "date_cas.h"
-
-    INTEGER nid,rid,ierr
-    INTEGER ii,jj,timeid
-    REAL, ALLOCATABLE :: time_val(:)
-
-    fich_cas='cas.nc'
-    print*,'fich_cas ',fich_cas
-    ierr = NF_OPEN(fich_cas,NF_NOWRITE,nid)
-    print*,'fich_cas,NF_NOWRITE,nid ',fich_cas,NF_NOWRITE,nid
-    if (ierr.NE.NF_NOERR) then
-       write(*,*) 'ERROR: GROS Pb opening forcings nc file '
-       write(*,*) NF_STRERROR(ierr)
-       stop ""
-    endif
-    !.......................................................................
-    ierr=NF_INQ_DIMID(nid,'lat',rid)
-    IF (ierr.NE.NF_NOERR) THEN
-       print*, 'Oh probleme lecture dimension lat'
-    ENDIF
-    ierr=NF_INQ_DIMLEN(nid,rid,ii)
-    print*,'OK1 read2: nid,rid,lat',nid,rid,ii
-    !.......................................................................
-    ierr=NF_INQ_DIMID(nid,'lon',rid)
-    IF (ierr.NE.NF_NOERR) THEN
-       print*, 'Oh probleme lecture dimension lon'
-    ENDIF
-    ierr=NF_INQ_DIMLEN(nid,rid,jj)
-    print*,'OK2 read2: nid,rid,lat',nid,rid,jj
-    !.......................................................................
-    ierr=NF_INQ_DIMID(nid,'lev',rid)
-    IF (ierr.NE.NF_NOERR) THEN
-       print*, 'Oh probleme lecture dimension nlev'
-    ENDIF
-    ierr=NF_INQ_DIMLEN(nid,rid,nlev_cas)
-    print*,'OK3 read2: nid,rid,nlev_cas',nid,rid,nlev_cas
-    IF ( .NOT. ( nlev_cas > 10 .AND. nlev_cas < 1000 )) THEN
-       print*,'Valeur de nlev_cas peu probable'
-       STOP
-    ENDIF
-    !.......................................................................
-    ierr=NF_INQ_DIMID(nid,'time',rid)
-    nt_cas=0
-    IF (ierr.NE.NF_NOERR) THEN
-       stop 'Oh probleme lecture dimension time'
-    ENDIF
-    ierr=NF_INQ_DIMLEN(nid,rid,nt_cas)
-    print*,'OK4 read2: nid,rid,nt_cas',nid,rid,nt_cas
-    ! Lecture de l'axe des temps
-    print*,'LECTURE DU TEMPS'
-    ierr=NF_INQ_VARID(nid,'time',timeid)
-    if(ierr/=NF_NOERR) then
-       print *,'Variable time manquante dans cas.nc:'
-       ierr=NF_NOERR
-    else
-       allocate(time_val(nt_cas))
-       ierr = NF90_GET_VAR(nid,timeid,time_val)
-       if(ierr/=NF_NOERR) then
-          print *,'Pb a la lecture de time cas.nc: '
-       endif
-    endif
-    IF (nt_cas>1) THEN
-       pdt_cas=time_val(2)-time_val(1)
-    ELSE
-       pdt_cas=0.
-    ENDIF
-
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-    !profils moyens:
-    allocate(plev_cas(nlev_cas,nt_cas),plevh_cas(nlev_cas+1))        
-    allocate(z_cas(nlev_cas,nt_cas),zh_cas(nlev_cas+1))
-    allocate(ap_cas(nlev_cas+1),bp_cas(nlev_cas+1))
-    allocate(t_cas(nlev_cas,nt_cas),q_cas(nlev_cas,nt_cas),qv_cas(nlev_cas,nt_cas),ql_cas(nlev_cas,nt_cas), &
-         qi_cas(nlev_cas,nt_cas),rh_cas(nlev_cas,nt_cas))
-    allocate(th_cas(nlev_cas,nt_cas),thl_cas(nlev_cas,nt_cas),thv_cas(nlev_cas,nt_cas),rv_cas(nlev_cas,nt_cas))
-    allocate(u_cas(nlev_cas,nt_cas),v_cas(nlev_cas,nt_cas),vitw_cas(nlev_cas,nt_cas),omega_cas(nlev_cas,nt_cas))
-
-    !forcing
-    allocate(ht_cas(nlev_cas,nt_cas),vt_cas(nlev_cas,nt_cas),dt_cas(nlev_cas,nt_cas),dtrad_cas(nlev_cas,nt_cas))
-    allocate(hq_cas(nlev_cas,nt_cas),vq_cas(nlev_cas,nt_cas),dq_cas(nlev_cas,nt_cas))
-    allocate(hth_cas(nlev_cas,nt_cas),vth_cas(nlev_cas,nt_cas),dth_cas(nlev_cas,nt_cas))
-    allocate(hr_cas(nlev_cas,nt_cas),vr_cas(nlev_cas,nt_cas),dr_cas(nlev_cas,nt_cas))
-    allocate(hu_cas(nlev_cas,nt_cas),vu_cas(nlev_cas,nt_cas),du_cas(nlev_cas,nt_cas))
-    allocate(hv_cas(nlev_cas,nt_cas),vv_cas(nlev_cas,nt_cas),dv_cas(nlev_cas,nt_cas))
-    allocate(ug_cas(nlev_cas,nt_cas))
-    allocate(vg_cas(nlev_cas,nt_cas))
-    allocate(lat_cas(nt_cas),sens_cas(nt_cas),ts_cas(nt_cas),ps_cas(nt_cas),ustar_cas(nt_cas),tke_cas(nt_cas))
-    allocate(uw_cas(nlev_cas,nt_cas),vw_cas(nlev_cas,nt_cas),q1_cas(nlev_cas,nt_cas),q2_cas(nlev_cas,nt_cas))
-
-
-
-    !champs interpoles
-    allocate(plev_prof_cas(nlev_cas))
-    allocate(t_prof_cas(nlev_cas))
-    allocate(theta_prof_cas(nlev_cas))
-    allocate(thl_prof_cas(nlev_cas))
-    allocate(thv_prof_cas(nlev_cas))
-    allocate(q_prof_cas(nlev_cas))
-    allocate(qv_prof_cas(nlev_cas))
-    allocate(ql_prof_cas(nlev_cas))
-    allocate(qi_prof_cas(nlev_cas))
-    allocate(rh_prof_cas(nlev_cas))
-    allocate(rv_prof_cas(nlev_cas))
-    allocate(u_prof_cas(nlev_cas))
-    allocate(v_prof_cas(nlev_cas))
-    allocate(vitw_prof_cas(nlev_cas))
-    allocate(omega_prof_cas(nlev_cas))
-    allocate(ug_prof_cas(nlev_cas))
-    allocate(vg_prof_cas(nlev_cas))
-    allocate(ht_prof_cas(nlev_cas))
-    allocate(hth_prof_cas(nlev_cas))
-    allocate(hq_prof_cas(nlev_cas))
-    allocate(hu_prof_cas(nlev_cas))
-    allocate(hv_prof_cas(nlev_cas))
-    allocate(vt_prof_cas(nlev_cas))
-    allocate(vth_prof_cas(nlev_cas))
-    allocate(vq_prof_cas(nlev_cas))
-    allocate(vu_prof_cas(nlev_cas))
-    allocate(vv_prof_cas(nlev_cas))
-    allocate(dt_prof_cas(nlev_cas))
-    allocate(dth_prof_cas(nlev_cas))
-    allocate(dtrad_prof_cas(nlev_cas))
-    allocate(dq_prof_cas(nlev_cas))
-    allocate(du_prof_cas(nlev_cas))
-    allocate(dv_prof_cas(nlev_cas))
-    allocate(uw_prof_cas(nlev_cas))
-    allocate(vw_prof_cas(nlev_cas))
-    allocate(q1_prof_cas(nlev_cas))
-    allocate(q2_prof_cas(nlev_cas))
-
-    print*,'Allocations OK'
-    call old_read_SCM (nid,nlev_cas,nt_cas,                                                                     &
-         ap_cas,bp_cas,z_cas,plev_cas,zh_cas,plevh_cas,t_cas,th_cas,thv_cas,thl_cas,qv_cas,                    &
-         ql_cas,qi_cas,rh_cas,rv_cas,u_cas,v_cas,vitw_cas,omega_cas,ug_cas,vg_cas,du_cas,hu_cas,vu_cas,        &
-         dv_cas,hv_cas,vv_cas,dt_cas,ht_cas,vt_cas,dq_cas,hq_cas,vq_cas,dth_cas,hth_cas,vth_cas,               &
-         dr_cas,hr_cas,vr_cas,dtrad_cas,sens_cas,lat_cas,ts_cas,ps_cas,ustar_cas,tke_cas,                      &
-         uw_cas,vw_cas,q1_cas,q2_cas,orog_cas,albedo_cas,emiss_cas,t_skin_cas,q_skin_cas,mom_rough,heat_rough, &
-         o3_cas,rugos_cas,clay_cas,sand_cas)
-    print*,'Read2 cas OK'
-    do ii=1,nlev_cas
-       print*,'apres read2_cas, plev_cas=',ii,plev_cas(ii,1)
-    enddo
-
-
-  END SUBROUTINE old_read_SCM_cas
-
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-  SUBROUTINE deallocate2_1D_cases
-    !profils environnementaux:
-    deallocate(plev_cas,plevh_cas)
-
-    deallocate(z_cas,zh_cas)
-    deallocate(ap_cas,bp_cas)
-    deallocate(t_cas,q_cas,qv_cas,ql_cas,qi_cas,rh_cas)
-    deallocate(th_cas,thl_cas,thv_cas,rv_cas)
-    deallocate(u_cas,v_cas,vitw_cas,omega_cas)
-
-    !forcing
-    deallocate(ht_cas,vt_cas,dt_cas,dtrad_cas)
-    deallocate(hq_cas,vq_cas,dq_cas)
-    deallocate(hth_cas,vth_cas,dth_cas)
-    deallocate(hr_cas,vr_cas,dr_cas)
-    deallocate(hu_cas,vu_cas,du_cas)
-    deallocate(hv_cas,vv_cas,dv_cas)
-    deallocate(ug_cas)
-    deallocate(vg_cas)
-    deallocate(lat_cas,sens_cas,ts_cas,ps_cas,ustar_cas,tke_cas,uw_cas,vw_cas,q1_cas,q2_cas)
-
-    !champs interpoles
-    deallocate(plev_prof_cas)
-    deallocate(t_prof_cas)
-    deallocate(theta_prof_cas)
-    deallocate(thl_prof_cas)
-    deallocate(thv_prof_cas)
-    deallocate(q_prof_cas)
-    deallocate(qv_prof_cas)
-    deallocate(ql_prof_cas)
-    deallocate(qi_prof_cas)
-    deallocate(rh_prof_cas)
-    deallocate(rv_prof_cas)
-    deallocate(u_prof_cas)
-    deallocate(v_prof_cas)
-    deallocate(vitw_prof_cas)
-    deallocate(omega_prof_cas)
-    deallocate(ug_prof_cas)
-    deallocate(vg_prof_cas)
-    deallocate(ht_prof_cas)
-    deallocate(hq_prof_cas)
-    deallocate(hu_prof_cas)
-    deallocate(hv_prof_cas)
-    deallocate(vt_prof_cas)
-    deallocate(vq_prof_cas)
-    deallocate(vu_prof_cas)
-    deallocate(vv_prof_cas)
-    deallocate(dt_prof_cas)
-    deallocate(dtrad_prof_cas)
-    deallocate(dq_prof_cas)
-    deallocate(du_prof_cas)
-    deallocate(dv_prof_cas)
-    deallocate(t_prof_cas)
-    deallocate(u_prof_cas)
-    deallocate(v_prof_cas)
-    deallocate(uw_prof_cas)
-    deallocate(vw_prof_cas)
-    deallocate(q1_prof_cas)
-    deallocate(q2_prof_cas)
-
-  END SUBROUTINE deallocate2_1D_cases
-
-
-END MODULE mod_1D_cases_read2
-!=====================================================================
-subroutine read_cas2(nid,nlevel,ntime                          &
-     ,zz,pp,temp,qv,rh,theta,rv,u,v,ug,vg,w,                   &
-     du,hu,vu,dv,hv,vv,dt,dtrad,ht,vt,dq,hq,vq,                     &
-     dth,hth,vth,dr,hr,vr,sens,flat,ts,ustar,uw,vw,q1,q2)
-
-  !program reading forcing of the case study
-  use netcdf, only: nf90_get_var
-  implicit none
-  INCLUDE "netcdf.inc"
-
-  integer ntime,nlevel
-
-  real zz(nlevel,ntime)
-  real pp(nlevel,ntime)
-  real temp(nlevel,ntime),qv(nlevel,ntime),rh(nlevel,ntime)
-  real theta(nlevel,ntime),rv(nlevel,ntime)
-  real u(nlevel,ntime)
-  real v(nlevel,ntime)
-  real ug(nlevel,ntime)
-  real vg(nlevel,ntime)
-  real w(nlevel,ntime)
-  real du(nlevel,ntime),hu(nlevel,ntime),vu(nlevel,ntime)
-  real dv(nlevel,ntime),hv(nlevel,ntime),vv(nlevel,ntime)
-  real dt(nlevel,ntime),ht(nlevel,ntime),vt(nlevel,ntime)
-  real dtrad(nlevel,ntime)
-  real dq(nlevel,ntime),hq(nlevel,ntime),vq(nlevel,ntime)
-  real dth(nlevel,ntime),hth(nlevel,ntime),vth(nlevel,ntime)
-  real dr(nlevel,ntime),hr(nlevel,ntime),vr(nlevel,ntime)
-  real flat(ntime),sens(ntime),ts(ntime),ustar(ntime)
-  real uw(nlevel,ntime),vw(nlevel,ntime),q1(nlevel,ntime),q2(nlevel,ntime),resul(nlevel,ntime),resul1(ntime)
-
-
-  integer nid, ierr, ierr1,ierr2,rid,i
-  integer nbvar3d
-  parameter(nbvar3d=39)
-  integer var3didin(nbvar3d)
-  character*5 name_var(1:nbvar3d)
-  data name_var/'zz','pp','temp','qv','rh','theta','rv','u','v','ug','vg','w','advu','hu','vu',&
-       'advv','hv','vv','advT','hT','vT','advq','hq','vq','advth','hth','vth','advr','hr','vr',&
-       'radT','uw','vw','q1','q2','sens','flat','ts','ustar'/
-
-
-  do i=1,nbvar3d
-     print *,'Dans read_cas2, on va lire ',nid,i,name_var(i)
-  enddo
-  do i=1,nbvar3d
-     ierr=NF_INQ_VARID(nid,name_var(i),var3didin(i)) 
-     print *,'ierr=',i,ierr,name_var(i),var3didin(i)
-     if(ierr/=NF_NOERR) then
-        print *,'Variable manquante dans cas.nc:',name_var(i)
-     endif
-  enddo
-  do i=1,nbvar3d
-     print *,'Dans read_cas2, on va lire ',var3didin(i),name_var(i)
-     if(i.LE.35) then
-        ierr = NF90_GET_VAR(nid,var3didin(i),resul, count = [1, 1, nlevel, ntime])
-        print *,'Dans read_cas2, on a lu ',ierr,var3didin(i),name_var(i)
-        if(ierr/=NF_NOERR) then
-           print *,'Pb a la lecture de cas.nc: ',name_var(i)
-           stop "getvarup"
-        endif
-     else
-        print *,'Dans read_cas2, on a lu ',ierr,var3didin(i),name_var(i)
-        ierr = NF90_GET_VAR(nid,var3didin(i),resul1, count = [1, 1, ntime])
-        if(ierr/=NF_NOERR) then
-           print *,'Pb a la lecture de cas.nc: ',name_var(i)
-           stop "getvarup"
-        endif
-     endif
-     select case(i)
-     case(1) ; zz=resul
-     case(2) ; pp=resul
-     case(3) ; temp=resul
-     case(4) ; qv=resul
-     case(5) ; rh=resul
-     case(6) ; theta=resul
-     case(7) ; rv=resul
-     case(8) ; u=resul
-     case(9) ; v=resul
-     case(10) ; ug=resul
-     case(11) ; vg=resul
-     case(12) ; w=resul
-     case(13) ; du=resul
-     case(14) ; hu=resul
-     case(15) ; vu=resul
-     case(16) ; dv=resul
-     case(17) ; hv=resul
-     case(18) ; vv=resul
-     case(19) ; dt=resul
-     case(20) ; ht=resul
-     case(21) ; vt=resul
-     case(22) ; dq=resul
-     case(23) ; hq=resul
-     case(24) ; vq=resul
-     case(25) ; dth=resul
-     case(26) ; hth=resul
-     case(27) ; vth=resul
-     case(28) ; dr=resul
-     case(29) ; hr=resul
-     case(30) ; vr=resul
-     case(31) ; dtrad=resul
-     case(32) ; uw=resul
-     case(33) ; vw=resul
-     case(34) ; q1=resul
-     case(35) ; q2=resul
-     case(36) ; sens=resul1
-     case(37) ; flat=resul1
-     case(38) ; ts=resul1
-     case(39) ; ustar=resul1
-     end select
-  enddo
-
-  return 
-end subroutine read_cas2
-!======================================================================
-subroutine read2_cas(nid,nlevel,ntime,                                       &
-     ap,bp,zz,pp,zzh,pph,temp,theta,thv,thl,qv,ql,qi,rh,rv,u,v,vitw,omega,ug,vg,&
-     du,hu,vu,dv,hv,vv,dt,ht,vt,dq,hq,vq,                                    &
-     dth,hth,vth,dr,hr,vr,dtrad,sens,flat,ts,ps,ustar,tke,uw,vw,q1,q2,       &
-     orog_cas,albedo_cas,emiss_cas,t_skin_cas,q_skin_cas,mom_rough,          &
-     heat_rough,o3_cas,rugos_cas,clay_cas,sand_cas)
-
-  !program reading forcing of the case study
-  use netcdf, only: nf90_get_var
-  implicit none
-  INCLUDE "netcdf.inc"
-
-  integer ntime,nlevel
-
-  real ap(nlevel+1),bp(nlevel+1)
-  real zz(nlevel,ntime),zzh(nlevel+1)
-  real pp(nlevel,ntime),pph(nlevel+1)
-  real temp(nlevel,ntime),qv(nlevel,ntime),ql(nlevel,ntime),qi(nlevel,ntime),rh(nlevel,ntime)
-  real theta(nlevel,ntime),thv(nlevel,ntime),thl(nlevel,ntime),rv(nlevel,ntime)
-  real u(nlevel,ntime),v(nlevel,ntime)
-  real ug(nlevel,ntime),vg(nlevel,ntime)
-  real vitw(nlevel,ntime),omega(nlevel,ntime)
-  real du(nlevel,ntime),hu(nlevel,ntime),vu(nlevel,ntime)
-  real dv(nlevel,ntime),hv(nlevel,ntime),vv(nlevel,ntime)
-  real dt(nlevel,ntime),ht(nlevel,ntime),vt(nlevel,ntime)
-  real dtrad(nlevel,ntime)
-  real dq(nlevel,ntime),hq(nlevel,ntime),vq(nlevel,ntime)
-  real dth(nlevel,ntime),hth(nlevel,ntime),vth(nlevel,ntime),hthl(nlevel,ntime)
-  real dr(nlevel,ntime),hr(nlevel,ntime),vr(nlevel,ntime)
-  real flat(ntime),sens(ntime),ustar(ntime)
-  real uw(nlevel,ntime),vw(nlevel,ntime),q1(nlevel,ntime),q2(nlevel,ntime)
-  real ts(ntime),ps(ntime),tke(ntime)
-  real orog_cas,albedo_cas,emiss_cas,t_skin_cas,q_skin_cas,mom_rough,heat_rough,o3_cas,rugos_cas,clay_cas,sand_cas
-  real apbp(nlevel+1),resul(nlevel,ntime),resul1(nlevel),resul2(ntime),resul3
-
-
-  integer nid, ierr,ierr1,ierr2,rid,i
-  integer nbvar3d
-  parameter(nbvar3d=62)
-  integer var3didin(nbvar3d),missing_var(nbvar3d)
-  character*12 name_var(1:nbvar3d)
-  data name_var/'coor_par_a','coor_par_b','height_h','pressure_h',&
-       'w','omega','ug','vg','uadv','uadvh','uadvv','vadv','vadvh','vadvv','tadv','tadvh','tadvv',&
-       'qadv','qadvh','qadvv','thadv','thadvh','thadvv','thladvh','radv','radvh','radvv','radcool','q1','q2','ustress','vstress', &
-       'rh',&
-       'height_f','pressure_f','temp','theta','thv','thl','qv','ql','qi','rv','u','v',&
-       'sfc_sens_flx','sfc_lat_flx','ts','ps','ustar','tke',&
-       'orog','albedo','emiss','t_skin','q_skin','mom_rough','heat_rough','o3','rugos','clay','sand'/
-  do i=1,nbvar3d
-     missing_var(i)=0.
-  enddo
-
-  !-----------------------------------------------------------------------
-  do i=1,nbvar3d
-     ierr=NF_INQ_VARID(nid,name_var(i),var3didin(i)) 
-     if(ierr/=NF_NOERR) then
-        print *,'Variable manquante dans cas.nc:',i,name_var(i)
-        ierr=NF_NOERR
-        missing_var(i)=1
-     else
-        !-----------------------------------------------------------------------
-        if(i.LE.4) then     ! Lecture des coord pression en (nlevelp1,lat,lon)
-           ierr = NF90_GET_VAR(nid,var3didin(i),apbp, count = [1, 1, nlevel + 1])
-           print *,'read2_cas(apbp), on a lu ',i,name_var(i)
-           if(ierr/=NF_NOERR) then
-              print *,'Pb a la lecture de cas.nc: ',name_var(i)
-              stop "getvarup"
-           endif
-           !-----------------------------------------------------------------------
-        else if(i.gt.4.and.i.LE.45) then   ! Lecture des variables en (time,nlevel,lat,lon)
-           ierr = NF90_GET_VAR(nid,var3didin(i),resul, count = [1, 1, nlevel, ntime])
-           print *,'read2_cas(resul), on a lu ',i,name_var(i)
-           if(ierr/=NF_NOERR) then
-              print *,'Pb a la lecture de cas.nc: ',name_var(i)
-              stop "getvarup"
-           endif
-           !-----------------------------------------------------------------------
-        else if (i.gt.45.and.i.LE.51) then   ! Lecture des variables en (time,lat,lon)
-           ierr = NF90_GET_VAR(nid,var3didin(i),resul2, count = [1, 1, ntime])
-           print *,'read2_cas(resul2), on a lu ',i,name_var(i)
-           if(ierr/=NF_NOERR) then
-              print *,'Pb a la lecture de cas.nc: ',name_var(i)
-              stop "getvarup"
-           endif
-           !-----------------------------------------------------------------------
-        else     ! Lecture des constantes (lat,lon)
-           ierr = NF90_GET_VAR(nid,var3didin(i),resul3)
-           print *,'read2_cas(resul3), on a lu ',i,name_var(i)
-           if(ierr/=NF_NOERR) then
-              print *,'Pb a la lecture de cas.nc: ',name_var(i)
-              stop "getvarup"
-           endif
-        endif
-     endif
-     !-----------------------------------------------------------------------
-     select case(i)
-     case(1) ; ap=apbp       ! donnees indexees en nlevel+1
-     case(2) ; bp=apbp
-     case(3) ; zzh=apbp
-     case(4) ; pph=apbp
-     case(5) ; vitw=resul    ! donnees indexees en nlevel,time
-     case(6) ; omega=resul
-     case(7) ; ug=resul
-     case(8) ; vg=resul
-     case(9) ; du=resul
-     case(10) ; hu=resul
-     case(11) ; vu=resul
-     case(12) ; dv=resul
-     case(13) ; hv=resul
-     case(14) ; vv=resul
-     case(15) ; dt=resul
-     case(16) ; ht=resul
-     case(17) ; vt=resul
-     case(18) ; dq=resul
-     case(19) ; hq=resul
-     case(20) ; vq=resul
-     case(21) ; dth=resul
-     case(22) ; hth=resul
-     case(23) ; vth=resul
-     case(24) ; hthl=resul
-     case(25) ; dr=resul
-     case(26) ; hr=resul
-     case(27) ; vr=resul
-     case(28) ; dtrad=resul
-     case(29) ; q1=resul
-     case(30) ; q2=resul
-     case(31) ; uw=resul
-     case(32) ; vw=resul
-     case(33) ; rh=resul
-     case(34) ; zz=resul      ! donnees en time,nlevel pour profil initial
-     case(35) ; pp=resul
-     case(36) ; temp=resul
-     case(37) ; theta=resul
-     case(38) ; thv=resul
-     case(39) ; thl=resul
-     case(40) ; qv=resul
-     case(41) ; ql=resul
-     case(42) ; qi=resul
-     case(43) ; rv=resul
-     case(44) ; u=resul
-     case(45) ; v=resul
-     case(46) ; sens=resul2   ! donnees indexees en time
-     case(47) ; flat=resul2
-     case(48) ; ts=resul2
-     case(49) ; ps=resul2
-     case(50) ; ustar=resul2
-     case(51) ; tke=resul2
-     case(52) ; orog_cas=resul3      ! constantes
-     case(53) ; albedo_cas=resul3
-     case(54) ; emiss_cas=resul3
-     case(55) ; t_skin_cas=resul3
-     case(56) ; q_skin_cas=resul3
-     case(57) ; mom_rough=resul3
-     case(58) ; heat_rough=resul3
-     case(59) ; o3_cas=resul3        
-     case(60) ; rugos_cas=resul3
-     case(61) ; clay_cas=resul3
-     case(62) ; sand_cas=resul3
-     end select
-     resul=0.
-     resul1=0.
-     resul2=0.
-     resul3=0.
-  enddo
-  !-----------------------------------------------------------------------
-
-
-  return 
-end subroutine read2_cas
-
-!======================================================================
-subroutine old_read_SCM(nid,nlevel,ntime,                                       &
-     ap,bp,zz,pp,zzh,pph,temp,theta,thv,thl,qv,ql,qi,rh,rv,u,v,vitw,omega,ug,vg,&
-     du,hu,vu,dv,hv,vv,dt,ht,vt,dq,hq,vq,                                    &
-     dth,hth,vth,dr,hr,vr,dtrad,sens,flat,ts,ps,ustar,tke,uw,vw,q1,q2,       &
-     orog_cas,albedo_cas,emiss_cas,t_skin_cas,q_skin_cas,mom_rough,          &
-     heat_rough,o3_cas,rugos_cas,clay_cas,sand_cas)
-
-  !program reading forcing of the case study
-  use netcdf, only: nf90_get_var
-  implicit none
-  INCLUDE "netcdf.inc"
-
-  integer ntime,nlevel,k,t
-
-  real ap(nlevel+1),bp(nlevel+1)
-  real zz(nlevel,ntime),zzh(nlevel+1)
-  real pp(nlevel,ntime),pph(nlevel+1)
-  !profils initiaux
-  real temp0(nlevel),qv0(nlevel),ql0(nlevel),qi0(nlevel),u0(nlevel),v0(nlevel),tke0(nlevel)
-  real pp0(nlevel)    
-  real temp(nlevel,ntime),qv(nlevel,ntime),ql(nlevel,ntime),qi(nlevel,ntime),rh(nlevel,ntime)
-  real theta(nlevel,ntime),thv(nlevel,ntime),thl(nlevel,ntime),rv(nlevel,ntime)
-  real u(nlevel,ntime),v(nlevel,ntime),tke(nlevel,ntime)
-  real ug(nlevel,ntime),vg(nlevel,ntime)
-  real vitw(nlevel,ntime),omega(nlevel,ntime)
-  real du(nlevel,ntime),hu(nlevel,ntime),vu(nlevel,ntime)
-  real dv(nlevel,ntime),hv(nlevel,ntime),vv(nlevel,ntime)
-  real dt(nlevel,ntime),ht(nlevel,ntime),vt(nlevel,ntime)
-  real dtrad(nlevel,ntime)
-  real dq(nlevel,ntime),hq(nlevel,ntime),vq(nlevel,ntime)
-  real dth(nlevel,ntime),hth(nlevel,ntime),vth(nlevel,ntime),hthl(nlevel,ntime)
-  real dr(nlevel,ntime),hr(nlevel,ntime),vr(nlevel,ntime)
-  real flat(ntime),sens(ntime),ustar(ntime)
-  real uw(nlevel,ntime),vw(nlevel,ntime),q1(nlevel,ntime),q2(nlevel,ntime)
-  real ts(ntime),ps(ntime)
-  real orog_cas,albedo_cas,emiss_cas,t_skin_cas,q_skin_cas,mom_rough,heat_rough,o3_cas,rugos_cas,clay_cas,sand_cas
-  real apbp(nlevel+1),resul(nlevel,ntime),resul1(nlevel),resul2(ntime),resul3
-
-
-  integer nid, ierr,ierr1,ierr2,rid,i
-  integer nbvar3d
-  parameter(nbvar3d=70)
-  integer var3didin(nbvar3d),missing_var(nbvar3d)
-  character*13 name_var(1:nbvar3d)
-  data name_var/'coor_par_a','coor_par_b','height_h','pressure_h',&
-       'temp','qv','ql','qi','u','v','tke','pressure',&
-       'w','omega','ug','vg','uadv','uadvh','uadvv','vadv','vadvh','vadvv','tadv','tadvh','tadvv',&
-       'qvadv','qvadvh','qvadvv','thadv','thadvh','thadvv','thladvh','radv','radvh','radvv','radcool','q1','q2','ustress', &
-       'vstress','rh',&
-       'height_f','pressure_forc','tempt','theta','thv','thl','qvt','qlt','qit','rv','ut','vt','tket',&
-       'sfc_sens_flx','sfc_lat_flx','ts','ps','ustar',&
-       'orog','albedo','emiss','t_skin','q_skin','mom_rough','heat_rough','o3','rugos','clay','sand'/
-  do i=1,nbvar3d
-     missing_var(i)=0.
-  enddo
-
-  !-----------------------------------------------------------------------
-
-  print*,'ON EST LA'
-  do i=1,nbvar3d
-     ierr=NF_INQ_VARID(nid,name_var(i),var3didin(i)) 
-     if(ierr/=NF_NOERR) then
-        print *,'Variable manquante dans cas.nc:',i,name_var(i)
-        ierr=NF_NOERR
-        missing_var(i)=1
-     else
-        !-----------------------------------------------------------------------
-        if(i.LE.4) then     ! Lecture des coord pression en (nlevelp1,lat,lon)
-           ierr = NF90_GET_VAR(nid,var3didin(i),apbp)
-           print *,'read2_cas(apbp), on a lu ',i,name_var(i)
-           if(ierr/=NF_NOERR) then
-              print *,'Pb a la lecture de cas.nc: ',name_var(i)
-              stop "getvarup"
-           endif
-           !-----------------------------------------------------------------------
-        else if(i.gt.4.and.i.LE.12) then   ! Lecture des variables en (time,nlevel,lat,lon)
-           ierr = NF90_GET_VAR(nid,var3didin(i),resul1)
-           print *,'read2_cas(resul1), on a lu ',i,name_var(i)
-           if(ierr/=NF_NOERR) then
-              print *,'Pb a la lecture de cas.nc: ',name_var(i)
-              stop "getvarup"
-           endif
-           print*,'Lecture de la variable #i ',i,name_var(i),minval(resul1),maxval(resul1)
-           !-----------------------------------------------------------------------
-        else if(i.gt.12.and.i.LE.54) then   ! Lecture des variables en (time,nlevel,lat,lon)
-           ierr = NF90_GET_VAR(nid,var3didin(i),resul)
-           print *,'read2_cas(resul), on a lu ',i,name_var(i)
-           if(ierr/=NF_NOERR) then
-              print *,'Pb a la lecture de cas.nc: ',name_var(i)
-              stop "getvarup"
-           endif
-           print*,'Lecture de la variable #i ',i,name_var(i),minval(resul),maxval(resul)
-           !-----------------------------------------------------------------------
-        else if (i.gt.54.and.i.LE.65) then   ! Lecture des variables en (time,lat,lon)
-           ierr = NF90_GET_VAR(nid,var3didin(i),resul2)
-           print *,'read2_cas(resul2), on a lu ',i,name_var(i)
-           if(ierr/=NF_NOERR) then
-              print *,'Pb a la lecture de cas.nc: ',name_var(i)
-              stop "getvarup"
-           endif
-           print*,'Lecture de la variable #i  ',i,name_var(i),minval(resul2),maxval(resul2)
-           !-----------------------------------------------------------------------
-        else     ! Lecture des constantes (lat,lon)
-           ierr = NF90_GET_VAR(nid,var3didin(i),resul3)
-           print *,'read2_cas(resul3), on a lu ',i,name_var(i)
-           if(ierr/=NF_NOERR) then
-              print *,'Pb a la lecture de cas.nc: ',name_var(i)
-              stop "getvarup"
-           endif
-           print*,'Lecture de la variable #i ',i,name_var(i),resul3
-        endif
-     endif
-     !-----------------------------------------------------------------------
-     select case(i)
-        !case(1) ; ap=apbp       ! donnees indexees en nlevel+1
-        ! case(2) ; bp=apbp
-     case(3) ; zzh=apbp
-     case(4) ; pph=apbp
-     case(5) ; temp0=resul1    ! donnees initiales
-     case(6) ; qv0=resul1
-     case(7) ; ql0=resul1
-     case(8) ; qi0=resul1
-     case(9) ; u0=resul1
-     case(10) ; v0=resul1
-     case(11) ; tke0=resul1
-     case(12) ; pp0=resul1
-     case(13) ; vitw=resul    ! donnees indexees en nlevel,time
-     case(14) ; omega=resul
-     case(15) ; ug=resul
-     case(16) ; vg=resul
-     case(17) ; du=resul
-     case(18) ; hu=resul
-     case(19) ; vu=resul
-     case(20) ; dv=resul
-     case(21) ; hv=resul
-     case(22) ; vv=resul
-     case(23) ; dt=resul
-     case(24) ; ht=resul
-     case(25) ; vt=resul
-     case(26) ; dq=resul
-     case(27) ; hq=resul
-     case(28) ; vq=resul
-     case(29) ; dth=resul
-     case(30) ; hth=resul
-     case(31) ; vth=resul
-     case(32) ; hthl=resul
-     case(33) ; dr=resul
-     case(34) ; hr=resul
-     case(35) ; vr=resul
-     case(36) ; dtrad=resul
-     case(37) ; q1=resul
-     case(38) ; q2=resul
-     case(39) ; uw=resul
-     case(40) ; vw=resul
-     case(41) ; rh=resul
-     case(42) ; zz=resul      ! donnees en time,nlevel pour profil initial
-     case(43) ; pp=resul
-     case(44) ; temp=resul
-     case(45) ; theta=resul
-     case(46) ; thv=resul
-     case(47) ; thl=resul
-     case(48) ; qv=resul
-     case(49) ; ql=resul
-     case(50) ; qi=resul
-     case(51) ; rv=resul
-     case(52) ; u=resul
-     case(53) ; v=resul
-     case(54) ; tke=resul
-     case(55) ; sens=resul2   ! donnees indexees en time
-     case(56) ; flat=resul2
-     case(57) ; ts=resul2
-     case(58) ; ps=resul2
-     case(59) ; ustar=resul2
-     case(60) ; orog_cas=resul3      ! constantes
-     case(61) ; albedo_cas=resul3
-     case(62) ; emiss_cas=resul3
-     case(63) ; t_skin_cas=resul3
-     case(64) ; q_skin_cas=resul3
-     case(65) ; mom_rough=resul3
-     case(66) ; heat_rough=resul3
-     case(67) ; o3_cas=resul3        
-     case(68) ; rugos_cas=resul3
-     case(69) ; clay_cas=resul3
-     case(70) ; sand_cas=resul3
-     end select
-     resul=0.
-     resul1=0.
-     resul2=0.
-     resul3=0.
-  enddo
-  print*,'Lecture de la variable APRES ,sens ',minval(sens),maxval(sens)
-  print*,'Lecture de la variable APRES ,flat ',minval(flat),maxval(flat)
-
-  !CR:ATTENTION EN ATTENTE DE REGLER LA QUESTION DU PAS DE TEMPS INITIAL
-  do t=1,ntime
-     do k=1,nlevel
-        temp(k,t)=temp0(k)
-        qv(k,t)=qv0(k)
-        ql(k,t)=ql0(k)
-        qi(k,t)=qi0(k)
-        u(k,t)=u0(k)
-        v(k,t)=v0(k)
-        tke(k,t)=tke0(k)
-     enddo
-  enddo
-  !-----------------------------------------------------------------------
-
-  return 
-end subroutine old_read_SCM
-!======================================================================
-
-!======================================================================
-SUBROUTINE interp_case_time2(day,day1,annee_ref                &
-     !    &         ,year_cas,day_cas,nt_cas,pdt_forc,nlev_cas      &
-     ,nt_cas,nlev_cas                                       &
-     ,ts_cas,ps_cas,plev_cas,t_cas,q_cas,u_cas,v_cas               &
-     ,ug_cas,vg_cas,vitw_cas,du_cas,hu_cas,vu_cas           &
-     ,dv_cas,hv_cas,vv_cas,dt_cas,ht_cas,vt_cas,dtrad_cas   &
-     ,dq_cas,hq_cas,vq_cas,lat_cas,sens_cas,ustar_cas       &
-     ,uw_cas,vw_cas,q1_cas,q2_cas                           &
-     ,ts_prof_cas,plev_prof_cas,t_prof_cas,q_prof_cas       &
-     ,u_prof_cas,v_prof_cas,ug_prof_cas,vg_prof_cas         &
-     ,vitw_prof_cas,du_prof_cas,hu_prof_cas,vu_prof_cas     &
-     ,dv_prof_cas,hv_prof_cas,vv_prof_cas,dt_prof_cas       &
-     ,ht_prof_cas,vt_prof_cas,dtrad_prof_cas,dq_prof_cas    &
-     ,hq_prof_cas,vq_prof_cas,lat_prof_cas,sens_prof_cas    &
-     ,ustar_prof_cas,uw_prof_cas,vw_prof_cas,q1_prof_cas,q2_prof_cas)
-
-
-  implicit none
-
-  !---------------------------------------------------------------------------------------
-  ! Time interpolation of a 2D field to the timestep corresponding to day
-  !
-  ! day: current julian day (e.g. 717538.2)
-  ! day1: first day of the simulation
-  ! nt_cas: total nb of data in the forcing 
-  ! pdt_cas: total time interval (in sec) between 2 forcing data
-  !---------------------------------------------------------------------------------------
-
-  INCLUDE "compar1d.h"
-  INCLUDE "date_cas.h"
-
-  ! inputs:
-  integer annee_ref
-  integer nt_cas,nlev_cas
-  real day, day1,day_cas
-  real ts_cas(nt_cas),ps_cas(nt_cas)
-  real plev_cas(nlev_cas,nt_cas)
-  real t_cas(nlev_cas,nt_cas),q_cas(nlev_cas,nt_cas)
-  real u_cas(nlev_cas,nt_cas),v_cas(nlev_cas,nt_cas)
-  real ug_cas(nlev_cas,nt_cas),vg_cas(nlev_cas,nt_cas)
-  real vitw_cas(nlev_cas,nt_cas)
-  real du_cas(nlev_cas,nt_cas),hu_cas(nlev_cas,nt_cas),vu_cas(nlev_cas,nt_cas)
-  real dv_cas(nlev_cas,nt_cas),hv_cas(nlev_cas,nt_cas),vv_cas(nlev_cas,nt_cas)
-  real dt_cas(nlev_cas,nt_cas),ht_cas(nlev_cas,nt_cas),vt_cas(nlev_cas,nt_cas)
-  real dtrad_cas(nlev_cas,nt_cas)
-  real dq_cas(nlev_cas,nt_cas),hq_cas(nlev_cas,nt_cas),vq_cas(nlev_cas,nt_cas)
-  real lat_cas(nt_cas)
-  real sens_cas(nt_cas)
-  real ustar_cas(nt_cas),uw_cas(nlev_cas,nt_cas),vw_cas(nlev_cas,nt_cas)
-  real q1_cas(nlev_cas,nt_cas),q2_cas(nlev_cas,nt_cas)
-
-  ! outputs:
-  real plev_prof_cas(nlev_cas)
-  real t_prof_cas(nlev_cas),q_prof_cas(nlev_cas)
-  real u_prof_cas(nlev_cas),v_prof_cas(nlev_cas)
-  real ug_prof_cas(nlev_cas),vg_prof_cas(nlev_cas)
-  real vitw_prof_cas(nlev_cas)
-  real du_prof_cas(nlev_cas),hu_prof_cas(nlev_cas),vu_prof_cas(nlev_cas)
-  real dv_prof_cas(nlev_cas),hv_prof_cas(nlev_cas),vv_prof_cas(nlev_cas)
-  real dt_prof_cas(nlev_cas),ht_prof_cas(nlev_cas),vt_prof_cas(nlev_cas)
-  real dtrad_prof_cas(nlev_cas)
-  real dq_prof_cas(nlev_cas),hq_prof_cas(nlev_cas),vq_prof_cas(nlev_cas)
-  real lat_prof_cas,sens_prof_cas,ts_prof_cas,ustar_prof_cas
-  real uw_prof_cas(nlev_cas),vw_prof_cas(nlev_cas),q1_prof_cas(nlev_cas),q2_prof_cas(nlev_cas)
-  ! local:
-  integer it_cas1, it_cas2,k
-  real timeit,time_cas1,time_cas2,frac
-
-
-  print*,'Check time',day1,day_ju_ini_cas,day_deb+1,pdt_cas
-
-  ! On teste si la date du cas AMMA est correcte.
-  ! C est pour memoire car en fait les fichiers .def
-  ! sont censes etre corrects.
-  ! A supprimer a terme (MPL 20150623)
-  !     if ((forcing_type.eq.10).and.(1.eq.0)) then
-  ! Check that initial day of the simulation consistent with AMMA case:
-  !      if (annee_ref.ne.2006) then
-  !       print*,'Pour AMMA, annee_ref doit etre 2006'
-  !       print*,'Changer annee_ref dans run.def'
-  !       stop
-  !      endif
-  !      if (annee_ref.eq.2006 .and. day1.lt.day_cas) then
-  !       print*,'AMMA a debute le 10 juillet 2006',day1,day_cas
-  !       print*,'Changer dayref dans run.def'
-  !       stop
-  !      endif
-  !      if (annee_ref.eq.2006 .and. day1.gt.day_cas+1) then
-  !       print*,'AMMA a fini le 11 juillet'
-  !       print*,'Changer dayref ou nday dans run.def'
-  !       stop
-  !      endif
-  !      endif
-
-  ! Determine timestep relative to the 1st day:
-  !       timeit=(day-day1)*86400.
-  !       if (annee_ref.eq.1992) then
-  !        timeit=(day-day_cas)*86400.
-  !       else
-  !        timeit=(day+61.-1.)*86400. ! 61 days between Nov01 and Dec31 1992
-  !       endif
-  timeit=(day-day_ju_ini_cas)*86400
-  !print *,'day=',day
-  !print *,'day_ju_ini_cas=',day_ju_ini_cas
-  !print *,'pdt_cas=',pdt_cas
-  !print *,'timeit=',timeit
-  !print *,'nt_cas=',nt_cas
-
-  ! Determine the closest observation times:
-  !       it_cas1=INT(timeit/pdt_cas)+1
-  !       it_cas2=it_cas1 + 1
-  !       time_cas1=(it_cas1-1)*pdt_cas
-  !       time_cas2=(it_cas2-1)*pdt_cas
-
-  it_cas1=INT(timeit/pdt_cas)+1
-  IF (it_cas1 .EQ. nt_cas) THEN
-     it_cas2=it_cas1 
-  ELSE
-     it_cas2=it_cas1 + 1
-  ENDIF
-  time_cas1=(it_cas1-1)*pdt_cas
-  time_cas2=(it_cas2-1)*pdt_cas
-  !print *,'it_cas1,it_cas2,time_cas1,time_cas2=',it_cas1,it_cas2,time_cas1,time_cas2
-
-  if (it_cas1 .gt. nt_cas) then
-     write(*,*) 'PB-stop: day, day_ju_ini_cas,it_cas1, it_cas2, timeit: '            &
-          ,day,day_ju_ini_cas,it_cas1,it_cas2,timeit
-     stop
-  endif
-
-  ! time interpolation:
-  IF (it_cas1 .EQ. it_cas2) THEN
-     frac=0.
-  ELSE
-     frac=(time_cas2-timeit)/(time_cas2-time_cas1)
-     frac=max(frac,0.0)
-  ENDIF
-
-  lat_prof_cas = lat_cas(it_cas2)                                       &
-       -frac*(lat_cas(it_cas2)-lat_cas(it_cas1)) 
-  sens_prof_cas = sens_cas(it_cas2)                                     &
-       -frac*(sens_cas(it_cas2)-sens_cas(it_cas1))
-  ts_prof_cas = ts_cas(it_cas2)                                         &
-       -frac*(ts_cas(it_cas2)-ts_cas(it_cas1))
-  ustar_prof_cas = ustar_cas(it_cas2)                                   &
-       -frac*(ustar_cas(it_cas2)-ustar_cas(it_cas1))
-
-  do k=1,nlev_cas
-     plev_prof_cas(k) = plev_cas(k,it_cas2)                               &
-          -frac*(plev_cas(k,it_cas2)-plev_cas(k,it_cas1))
-     t_prof_cas(k) = t_cas(k,it_cas2)                               &
-          -frac*(t_cas(k,it_cas2)-t_cas(k,it_cas1))
-     q_prof_cas(k) = q_cas(k,it_cas2)                               &
-          -frac*(q_cas(k,it_cas2)-q_cas(k,it_cas1))
-     u_prof_cas(k) = u_cas(k,it_cas2)                               &
-          -frac*(u_cas(k,it_cas2)-u_cas(k,it_cas1))
-     v_prof_cas(k) = v_cas(k,it_cas2)                               &
-          -frac*(v_cas(k,it_cas2)-v_cas(k,it_cas1))
-     ug_prof_cas(k) = ug_cas(k,it_cas2)                               &
-          -frac*(ug_cas(k,it_cas2)-ug_cas(k,it_cas1))
-     vg_prof_cas(k) = vg_cas(k,it_cas2)                               &
-          -frac*(vg_cas(k,it_cas2)-vg_cas(k,it_cas1))
-     vitw_prof_cas(k) = vitw_cas(k,it_cas2)                               &
-          -frac*(vitw_cas(k,it_cas2)-vitw_cas(k,it_cas1))
-     du_prof_cas(k) = du_cas(k,it_cas2)                                   &
-          -frac*(du_cas(k,it_cas2)-du_cas(k,it_cas1))
-     hu_prof_cas(k) = hu_cas(k,it_cas2)                                   &
-          -frac*(hu_cas(k,it_cas2)-hu_cas(k,it_cas1))
-     vu_prof_cas(k) = vu_cas(k,it_cas2)                                   &
-          -frac*(vu_cas(k,it_cas2)-vu_cas(k,it_cas1))
-     dv_prof_cas(k) = dv_cas(k,it_cas2)                                   &
-          -frac*(dv_cas(k,it_cas2)-dv_cas(k,it_cas1))
-     hv_prof_cas(k) = hv_cas(k,it_cas2)                                   &
-          -frac*(hv_cas(k,it_cas2)-hv_cas(k,it_cas1))
-     vv_prof_cas(k) = vv_cas(k,it_cas2)                                   &
-          -frac*(vv_cas(k,it_cas2)-vv_cas(k,it_cas1))
-     dt_prof_cas(k) = dt_cas(k,it_cas2)                                   &
-          -frac*(dt_cas(k,it_cas2)-dt_cas(k,it_cas1))
-     ht_prof_cas(k) = ht_cas(k,it_cas2)                                   &
-          -frac*(ht_cas(k,it_cas2)-ht_cas(k,it_cas1))
-     vt_prof_cas(k) = vt_cas(k,it_cas2)                                   &
-          -frac*(vt_cas(k,it_cas2)-vt_cas(k,it_cas1))
-     dtrad_prof_cas(k) = dtrad_cas(k,it_cas2)                                   &
-          -frac*(dtrad_cas(k,it_cas2)-dtrad_cas(k,it_cas1))
-     dq_prof_cas(k) = dq_cas(k,it_cas2)                                   &
-          -frac*(dq_cas(k,it_cas2)-dq_cas(k,it_cas1))
-     hq_prof_cas(k) = hq_cas(k,it_cas2)                                   &
-          -frac*(hq_cas(k,it_cas2)-hq_cas(k,it_cas1))
-     vq_prof_cas(k) = vq_cas(k,it_cas2)                                   &
-          -frac*(vq_cas(k,it_cas2)-vq_cas(k,it_cas1))
-     uw_prof_cas(k) = uw_cas(k,it_cas2)                                   &
-          -frac*(uw_cas(k,it_cas2)-uw_cas(k,it_cas1))
-     vw_prof_cas(k) = vw_cas(k,it_cas2)                                   &
-          -frac*(vw_cas(k,it_cas2)-vw_cas(k,it_cas1))
-     q1_prof_cas(k) = q1_cas(k,it_cas2)                                   &
-          -frac*(q1_cas(k,it_cas2)-q1_cas(k,it_cas1))
-     q2_prof_cas(k) = q2_cas(k,it_cas2)                                   &
-          -frac*(q2_cas(k,it_cas2)-q2_cas(k,it_cas1))
-  enddo
-
-  return
-END SUBROUTINE interp_case_time2
-
-!**********************************************************************************************
-SUBROUTINE interp2_case_time(day,day1,annee_ref                           &
-     !    &         ,year_cas,day_cas,nt_cas,pdt_forc,nlev_cas                         &
-     ,nt_cas,nlev_cas                                                   &
-     ,ts_cas,ps_cas,plev_cas,t_cas,theta_cas,thv_cas,thl_cas            &
-     ,qv_cas,ql_cas,qi_cas,u_cas,v_cas                                  &
-     ,ug_cas,vg_cas,vitw_cas,omega_cas,du_cas,hu_cas,vu_cas             &
-     ,dv_cas,hv_cas,vv_cas,dt_cas,ht_cas,vt_cas,dtrad_cas               &
-     ,dq_cas,hq_cas,vq_cas,dth_cas,hth_cas,vth_cas                      &
-     ,lat_cas,sens_cas,ustar_cas                                        &
-     ,uw_cas,vw_cas,q1_cas,q2_cas,tke_cas                               &
-     !
-     ,ts_prof_cas,plev_prof_cas,t_prof_cas,theta_prof_cas               &
-     ,thv_prof_cas,thl_prof_cas,qv_prof_cas,ql_prof_cas,qi_prof_cas     &
-     ,u_prof_cas,v_prof_cas,ug_prof_cas,vg_prof_cas                     &
-     ,vitw_prof_cas,omega_prof_cas,du_prof_cas,hu_prof_cas,vu_prof_cas  &
-     ,dv_prof_cas,hv_prof_cas,vv_prof_cas,dt_prof_cas                   &
-     ,ht_prof_cas,vt_prof_cas,dtrad_prof_cas,dq_prof_cas                &
-     ,hq_prof_cas,vq_prof_cas,dth_prof_cas,hth_prof_cas,vth_prof_cas    &
-     ,lat_prof_cas,sens_prof_cas                                        &
-     ,ustar_prof_cas,uw_prof_cas,vw_prof_cas,q1_prof_cas,q2_prof_cas,tke_prof_cas)
-
-
-  implicit none
-
-  !---------------------------------------------------------------------------------------
-  ! Time interpolation of a 2D field to the timestep corresponding to day
-  !
-  ! day: current julian day (e.g. 717538.2)
-  ! day1: first day of the simulation
-  ! nt_cas: total nb of data in the forcing 
-  ! pdt_cas: total time interval (in sec) between 2 forcing data
-  !---------------------------------------------------------------------------------------
-
-  INCLUDE "compar1d.h"
-  INCLUDE "date_cas.h"
-
-  ! inputs:
-  integer annee_ref
-  integer nt_cas,nlev_cas
-  real day, day1,day_cas
-  real ts_cas(nt_cas),ps_cas(nt_cas)
-  real plev_cas(nlev_cas,nt_cas)
-  real t_cas(nlev_cas,nt_cas),theta_cas(nlev_cas,nt_cas),thv_cas(nlev_cas,nt_cas),thl_cas(nlev_cas,nt_cas)
-  real qv_cas(nlev_cas,nt_cas),ql_cas(nlev_cas,nt_cas),qi_cas(nlev_cas,nt_cas)
-  real u_cas(nlev_cas,nt_cas),v_cas(nlev_cas,nt_cas)
-  real ug_cas(nlev_cas,nt_cas),vg_cas(nlev_cas,nt_cas)
-  real vitw_cas(nlev_cas,nt_cas),omega_cas(nlev_cas,nt_cas)
-  real du_cas(nlev_cas,nt_cas),hu_cas(nlev_cas,nt_cas),vu_cas(nlev_cas,nt_cas)
-  real dv_cas(nlev_cas,nt_cas),hv_cas(nlev_cas,nt_cas),vv_cas(nlev_cas,nt_cas)
-  real dt_cas(nlev_cas,nt_cas),ht_cas(nlev_cas,nt_cas),vt_cas(nlev_cas,nt_cas)
-  real dth_cas(nlev_cas,nt_cas),hth_cas(nlev_cas,nt_cas),vth_cas(nlev_cas,nt_cas)
-  real dtrad_cas(nlev_cas,nt_cas)
-  real dq_cas(nlev_cas,nt_cas),hq_cas(nlev_cas,nt_cas),vq_cas(nlev_cas,nt_cas)
-  real lat_cas(nt_cas),sens_cas(nt_cas),tke_cas(nt_cas)
-  real ustar_cas(nt_cas),uw_cas(nlev_cas,nt_cas),vw_cas(nlev_cas,nt_cas)
-  real q1_cas(nlev_cas,nt_cas),q2_cas(nlev_cas,nt_cas)
-
-  ! outputs:
-  real plev_prof_cas(nlev_cas)
-  real t_prof_cas(nlev_cas),theta_prof_cas(nlev_cas),thl_prof_cas(nlev_cas),thv_prof_cas(nlev_cas)
-  real qv_prof_cas(nlev_cas),ql_prof_cas(nlev_cas),qi_prof_cas(nlev_cas)
-  real u_prof_cas(nlev_cas),v_prof_cas(nlev_cas)
-  real ug_prof_cas(nlev_cas),vg_prof_cas(nlev_cas)
-  real vitw_prof_cas(nlev_cas),omega_prof_cas(nlev_cas)
-  real du_prof_cas(nlev_cas),hu_prof_cas(nlev_cas),vu_prof_cas(nlev_cas)
-  real dv_prof_cas(nlev_cas),hv_prof_cas(nlev_cas),vv_prof_cas(nlev_cas)
-  real dt_prof_cas(nlev_cas),ht_prof_cas(nlev_cas),vt_prof_cas(nlev_cas)
-  real dth_prof_cas(nlev_cas),hth_prof_cas(nlev_cas),vth_prof_cas(nlev_cas)
-  real dtrad_prof_cas(nlev_cas)
-  real dq_prof_cas(nlev_cas),hq_prof_cas(nlev_cas),vq_prof_cas(nlev_cas)
-  real lat_prof_cas,sens_prof_cas,tke_prof_cas,ts_prof_cas,ustar_prof_cas
-  real uw_prof_cas(nlev_cas),vw_prof_cas(nlev_cas),q1_prof_cas(nlev_cas),q2_prof_cas(nlev_cas)
-  ! local:
-  integer it_cas1, it_cas2,k
-  real timeit,time_cas1,time_cas2,frac
-
-
-  print*,'Check time',day1,day_ju_ini_cas,day_deb+1,pdt_cas
-  !       do k=1,nlev_cas
-  !       print*,'debut de interp2_case_time, plev_cas=',k,plev_cas(k,1)
-  !       enddo
-
-  ! On teste si la date du cas AMMA est correcte.
-  ! C est pour memoire car en fait les fichiers .def
-  ! sont censes etre corrects.
-  ! A supprimer a terme (MPL 20150623)
-  !     if ((forcing_type.eq.10).and.(1.eq.0)) then
-  ! Check that initial day of the simulation consistent with AMMA case:
-  !      if (annee_ref.ne.2006) then
-  !       print*,'Pour AMMA, annee_ref doit etre 2006'
-  !       print*,'Changer annee_ref dans run.def'
-  !       stop
-  !      endif
-  !      if (annee_ref.eq.2006 .and. day1.lt.day_cas) then
-  !       print*,'AMMA a debute le 10 juillet 2006',day1,day_cas
-  !       print*,'Changer dayref dans run.def'
-  !       stop
-  !      endif
-  !      if (annee_ref.eq.2006 .and. day1.gt.day_cas+1) then
-  !       print*,'AMMA a fini le 11 juillet'
-  !       print*,'Changer dayref ou nday dans run.def'
-  !       stop
-  !      endif
-  !      endif
-
-  ! Determine timestep relative to the 1st day:
-  !       timeit=(day-day1)*86400.
-  !       if (annee_ref.eq.1992) then
-  !        timeit=(day-day_cas)*86400.
-  !       else
-  !        timeit=(day+61.-1.)*86400. ! 61 days between Nov01 and Dec31 1992
-  !       endif
-  timeit=(day-day_ju_ini_cas)*86400
-  !print *,'day=',day
-  !print *,'day_ju_ini_cas=',day_ju_ini_cas
-  !print *,'pdt_cas=',pdt_cas
-  !print *,'timeit=',timeit
-  !print *,'nt_cas=',nt_cas
-
-  ! Determine the closest observation times:
-  !       it_cas1=INT(timeit/pdt_cas)+1
-  !       it_cas2=it_cas1 + 1
-  !       time_cas1=(it_cas1-1)*pdt_cas
-  !       time_cas2=(it_cas2-1)*pdt_cas
-
-  it_cas1=INT(timeit/pdt_cas)+1
-  IF (it_cas1 .EQ. nt_cas) THEN
-     it_cas2=it_cas1 
-  ELSE
-     it_cas2=it_cas1 + 1
-  ENDIF
-  time_cas1=(it_cas1-1)*pdt_cas
-  time_cas2=(it_cas2-1)*pdt_cas
-  !print *,'timeit,pdt_cas,nt_cas=',timeit,pdt_cas,nt_cas
-  !print *,'it_cas1,it_cas2,time_cas1,time_cas2=',it_cas1,it_cas2,time_cas1,time_cas2
-
-  if (it_cas1 .gt. nt_cas) then 
-     write(*,*) 'PB-stop: day, day_ju_ini_cas,it_cas1, it_cas2, timeit: '            &
-          ,day,day_ju_ini_cas,it_cas1,it_cas2,timeit
-     stop
-  endif
-
-  ! time interpolation:
-  IF (it_cas1 .EQ. it_cas2) THEN
-     frac=0.
-  ELSE
-     frac=(time_cas2-timeit)/(time_cas2-time_cas1)
-     frac=max(frac,0.0)
-  ENDIF
-
-  lat_prof_cas = lat_cas(it_cas2)                                   &
-       -frac*(lat_cas(it_cas2)-lat_cas(it_cas1)) 
-  sens_prof_cas = sens_cas(it_cas2)                                 &
-       -frac*(sens_cas(it_cas2)-sens_cas(it_cas1))
-  tke_prof_cas = tke_cas(it_cas2)                                   &
-       -frac*(tke_cas(it_cas2)-tke_cas(it_cas1))
-  ts_prof_cas = ts_cas(it_cas2)                                     &
-       -frac*(ts_cas(it_cas2)-ts_cas(it_cas1))
-  ustar_prof_cas = ustar_cas(it_cas2)                               &
-       -frac*(ustar_cas(it_cas2)-ustar_cas(it_cas1))
-
-  do k=1,nlev_cas
-     plev_prof_cas(k) = plev_cas(k,it_cas2)                           &     
-          -frac*(plev_cas(k,it_cas2)-plev_cas(k,it_cas1))
-     t_prof_cas(k) = t_cas(k,it_cas2)                                 &        
-          -frac*(t_cas(k,it_cas2)-t_cas(k,it_cas1))
-     !print *,'k,frac,plev_cas1,plev_cas2=',k,frac,plev_cas(k,it_cas1),plev_cas(k,it_cas2)
-     theta_prof_cas(k) = theta_cas(k,it_cas2)                         &                      
-          -frac*(theta_cas(k,it_cas2)-theta_cas(k,it_cas1))
-     thv_prof_cas(k) = thv_cas(k,it_cas2)                             &          
-          -frac*(thv_cas(k,it_cas2)-thv_cas(k,it_cas1))
-     thl_prof_cas(k) = thl_cas(k,it_cas2)                             &              
-          -frac*(thl_cas(k,it_cas2)-thl_cas(k,it_cas1))
-     qv_prof_cas(k) = qv_cas(k,it_cas2)                               &
-          -frac*(qv_cas(k,it_cas2)-qv_cas(k,it_cas1))
-     ql_prof_cas(k) = ql_cas(k,it_cas2)                               &
-          -frac*(ql_cas(k,it_cas2)-ql_cas(k,it_cas1))
-     qi_prof_cas(k) = qi_cas(k,it_cas2)                               &
-          -frac*(qi_cas(k,it_cas2)-qi_cas(k,it_cas1))
-     u_prof_cas(k) = u_cas(k,it_cas2)                                 &
-          -frac*(u_cas(k,it_cas2)-u_cas(k,it_cas1))
-     v_prof_cas(k) = v_cas(k,it_cas2)                                 &
-          -frac*(v_cas(k,it_cas2)-v_cas(k,it_cas1))
-     ug_prof_cas(k) = ug_cas(k,it_cas2)                               &
-          -frac*(ug_cas(k,it_cas2)-ug_cas(k,it_cas1))
-     vg_prof_cas(k) = vg_cas(k,it_cas2)                               &
-          -frac*(vg_cas(k,it_cas2)-vg_cas(k,it_cas1))
-     vitw_prof_cas(k) = vitw_cas(k,it_cas2)                           &
-          -frac*(vitw_cas(k,it_cas2)-vitw_cas(k,it_cas1))
-     omega_prof_cas(k) = omega_cas(k,it_cas2)                         &
-          -frac*(omega_cas(k,it_cas2)-omega_cas(k,it_cas1))
-     du_prof_cas(k) = du_cas(k,it_cas2)                               &
-          -frac*(du_cas(k,it_cas2)-du_cas(k,it_cas1))
-     hu_prof_cas(k) = hu_cas(k,it_cas2)                               &
-          -frac*(hu_cas(k,it_cas2)-hu_cas(k,it_cas1))
-     vu_prof_cas(k) = vu_cas(k,it_cas2)                               &
-          -frac*(vu_cas(k,it_cas2)-vu_cas(k,it_cas1))
-     dv_prof_cas(k) = dv_cas(k,it_cas2)                               &
-          -frac*(dv_cas(k,it_cas2)-dv_cas(k,it_cas1))
-     hv_prof_cas(k) = hv_cas(k,it_cas2)                               &
-          -frac*(hv_cas(k,it_cas2)-hv_cas(k,it_cas1))
-     vv_prof_cas(k) = vv_cas(k,it_cas2)                               &
-          -frac*(vv_cas(k,it_cas2)-vv_cas(k,it_cas1))
-     dt_prof_cas(k) = dt_cas(k,it_cas2)                               &
-          -frac*(dt_cas(k,it_cas2)-dt_cas(k,it_cas1))
-     ht_prof_cas(k) = ht_cas(k,it_cas2)                               &
-          -frac*(ht_cas(k,it_cas2)-ht_cas(k,it_cas1))
-     vt_prof_cas(k) = vt_cas(k,it_cas2)                               &
-          -frac*(vt_cas(k,it_cas2)-vt_cas(k,it_cas1))
-     dth_prof_cas(k) = dth_cas(k,it_cas2)                             &
-          -frac*(dth_cas(k,it_cas2)-dth_cas(k,it_cas1))
-     hth_prof_cas(k) = hth_cas(k,it_cas2)                             &
-          -frac*(hth_cas(k,it_cas2)-hth_cas(k,it_cas1))
-     vth_prof_cas(k) = vth_cas(k,it_cas2)                             &
-          -frac*(vth_cas(k,it_cas2)-vth_cas(k,it_cas1))
-     dtrad_prof_cas(k) = dtrad_cas(k,it_cas2)                         &
-          -frac*(dtrad_cas(k,it_cas2)-dtrad_cas(k,it_cas1))
-     dq_prof_cas(k) = dq_cas(k,it_cas2)                               &
-          -frac*(dq_cas(k,it_cas2)-dq_cas(k,it_cas1))
-     hq_prof_cas(k) = hq_cas(k,it_cas2)                               &
-          -frac*(hq_cas(k,it_cas2)-hq_cas(k,it_cas1))
-     vq_prof_cas(k) = vq_cas(k,it_cas2)                               &
-          -frac*(vq_cas(k,it_cas2)-vq_cas(k,it_cas1))
-     uw_prof_cas(k) = uw_cas(k,it_cas2)                                &
-          -frac*(uw_cas(k,it_cas2)-uw_cas(k,it_cas1))
-     vw_prof_cas(k) = vw_cas(k,it_cas2)                                &
-          -frac*(vw_cas(k,it_cas2)-vw_cas(k,it_cas1))
-     q1_prof_cas(k) = q1_cas(k,it_cas2)                                &
-          -frac*(q1_cas(k,it_cas2)-q1_cas(k,it_cas1))
-     q2_prof_cas(k) = q2_cas(k,it_cas2)                                &
-          -frac*(q2_cas(k,it_cas2)-q2_cas(k,it_cas1))
-  enddo
-
-  return
-END SUBROUTINE interp2_case_time
-
-!**********************************************************************************************
-
Index: /LMDZ6/trunk/libf/phylmd/dyn1d/mod_1D_cases_read2.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/dyn1d/mod_1D_cases_read2.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/dyn1d/mod_1D_cases_read2.f90	(revision 5268)
@@ -0,0 +1,1476 @@
+!
+! $Id: mod_1D_cases_read.F90 2373 2015-10-13 17:28:01Z jyg $
+!
+MODULE mod_1D_cases_read2
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+  !Declarations specifiques au cas standard
+  character*80 :: fich_cas
+  ! Discr?tisation 
+  integer nlev_cas, nt_cas
+
+
+  !profils environnementaux
+  real, allocatable::  plev_cas(:,:),plevh_cas(:)
+  real, allocatable::  ap_cas(:),bp_cas(:)
+
+  real, allocatable::  z_cas(:,:),zh_cas(:)
+  real, allocatable::  t_cas(:,:),q_cas(:,:),qv_cas(:,:),ql_cas(:,:),qi_cas(:,:),rh_cas(:,:)
+  real, allocatable::  th_cas(:,:),thv_cas(:,:),thl_cas(:,:),rv_cas(:,:)
+  real, allocatable::  u_cas(:,:),v_cas(:,:),vitw_cas(:,:),omega_cas(:,:)
+
+  !forcing
+  real, allocatable::  ht_cas(:,:),vt_cas(:,:),dt_cas(:,:),dtrad_cas(:,:)
+  real, allocatable::  hth_cas(:,:),vth_cas(:,:),dth_cas(:,:)
+  real, allocatable::  hq_cas(:,:),vq_cas(:,:),dq_cas(:,:)
+  real, allocatable::  hr_cas(:,:),vr_cas(:,:),dr_cas(:,:)
+  real, allocatable::  hu_cas(:,:),vu_cas(:,:),du_cas(:,:)
+  real, allocatable::  hv_cas(:,:),vv_cas(:,:),dv_cas(:,:)
+  real, allocatable::  ug_cas(:,:),vg_cas(:,:)
+  real, allocatable::  lat_cas(:),sens_cas(:),ts_cas(:),ps_cas(:),ustar_cas(:)
+  real, allocatable::  uw_cas(:,:),vw_cas(:,:),q1_cas(:,:),q2_cas(:,:),tke_cas(:)
+
+  !champs interpoles
+  real, allocatable::  plev_prof_cas(:)
+  real, allocatable::  t_prof_cas(:)
+  real, allocatable::  theta_prof_cas(:)
+  real, allocatable::  thl_prof_cas(:)
+  real, allocatable::  thv_prof_cas(:)
+  real, allocatable::  q_prof_cas(:)
+  real, allocatable::  qv_prof_cas(:)
+  real, allocatable::  ql_prof_cas(:)
+  real, allocatable::  qi_prof_cas(:)
+  real, allocatable::  rh_prof_cas(:)
+  real, allocatable::  rv_prof_cas(:)
+  real, allocatable::  u_prof_cas(:)
+  real, allocatable::  v_prof_cas(:)        
+  real, allocatable::  vitw_prof_cas(:)
+  real, allocatable::  omega_prof_cas(:)
+  real, allocatable::  ug_prof_cas(:)
+  real, allocatable::  vg_prof_cas(:)
+  real, allocatable::  ht_prof_cas(:)
+  real, allocatable::  hth_prof_cas(:)
+  real, allocatable::  hq_prof_cas(:)
+  real, allocatable::  vt_prof_cas(:)
+  real, allocatable::  vth_prof_cas(:)
+  real, allocatable::  vq_prof_cas(:)
+  real, allocatable::  dt_prof_cas(:)
+  real, allocatable::  dth_prof_cas(:)
+  real, allocatable::  dtrad_prof_cas(:)
+  real, allocatable::  dq_prof_cas(:)
+  real, allocatable::  hu_prof_cas(:)
+  real, allocatable::  hv_prof_cas(:)
+  real, allocatable::  vu_prof_cas(:)
+  real, allocatable::  vv_prof_cas(:)
+  real, allocatable::  du_prof_cas(:)
+  real, allocatable::  dv_prof_cas(:)
+  real, allocatable::  uw_prof_cas(:)
+  real, allocatable::  vw_prof_cas(:)
+  real, allocatable::  q1_prof_cas(:)
+  real, allocatable::  q2_prof_cas(:)
+
+
+  real lat_prof_cas,sens_prof_cas,ts_prof_cas,ps_prof_cas,ustar_prof_cas,tke_prof_cas
+  real o3_cas,orog_cas,albedo_cas,emiss_cas,t_skin_cas,q_skin_cas,mom_rough,heat_rough,rugos_cas,sand_cas,clay_cas
+
+
+
+CONTAINS
+
+  SUBROUTINE read_1D_cas
+    implicit none
+
+    INCLUDE "netcdf.inc"
+
+    INTEGER nid,rid,ierr
+    INTEGER ii,jj
+
+    fich_cas='setup/cas.nc'
+    print*,'fich_cas ',fich_cas
+    ierr = NF_OPEN(fich_cas,NF_NOWRITE,nid)
+    print*,'fich_cas,NF_NOWRITE,nid ',fich_cas,NF_NOWRITE,nid
+    if (ierr.NE.NF_NOERR) then
+       write(*,*) 'ERROR: GROS Pb opening forcings nc file '
+       write(*,*) NF_STRERROR(ierr)
+       stop ""
+    endif
+    !.......................................................................
+    ierr=NF_INQ_DIMID(nid,'lat',rid)
+    IF (ierr.NE.NF_NOERR) THEN
+       print*, 'Oh probleme lecture dimension lat'
+    ENDIF
+    ierr=NF_INQ_DIMLEN(nid,rid,ii)
+    print*,'OK1 nid,rid,lat',nid,rid,ii
+    !.......................................................................
+    ierr=NF_INQ_DIMID(nid,'lon',rid)
+    IF (ierr.NE.NF_NOERR) THEN
+       print*, 'Oh probleme lecture dimension lon'
+    ENDIF
+    ierr=NF_INQ_DIMLEN(nid,rid,jj)
+    print*,'OK2 nid,rid,lat',nid,rid,jj
+    !.......................................................................
+    ierr=NF_INQ_DIMID(nid,'lev',rid)
+    IF (ierr.NE.NF_NOERR) THEN
+       print*, 'Oh probleme lecture dimension zz'
+    ENDIF
+    ierr=NF_INQ_DIMLEN(nid,rid,nlev_cas)
+    print*,'OK3 nid,rid,nlev_cas',nid,rid,nlev_cas
+    !.......................................................................
+    ierr=NF_INQ_DIMID(nid,'time',rid)
+    print*,'nid,rid',nid,rid
+    nt_cas=0
+    IF (ierr.NE.NF_NOERR) THEN
+       stop 'probleme lecture dimension sens'
+    ENDIF
+    ierr=NF_INQ_DIMLEN(nid,rid,nt_cas)
+    print*,'OK4 nid,rid,nt_cas',nid,rid,nt_cas
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+    !profils moyens:
+    allocate(plev_cas(nlev_cas,nt_cas))        
+    allocate(z_cas(nlev_cas,nt_cas))
+    allocate(t_cas(nlev_cas,nt_cas),q_cas(nlev_cas,nt_cas),rh_cas(nlev_cas,nt_cas))
+    allocate(th_cas(nlev_cas,nt_cas),rv_cas(nlev_cas,nt_cas))
+    allocate(u_cas(nlev_cas,nt_cas))
+    allocate(v_cas(nlev_cas,nt_cas))
+
+    !forcing
+    allocate(ht_cas(nlev_cas,nt_cas),vt_cas(nlev_cas,nt_cas),dt_cas(nlev_cas,nt_cas),dtrad_cas(nlev_cas,nt_cas))
+    allocate(hq_cas(nlev_cas,nt_cas),vq_cas(nlev_cas,nt_cas),dq_cas(nlev_cas,nt_cas))
+    allocate(hth_cas(nlev_cas,nt_cas),vth_cas(nlev_cas,nt_cas),dth_cas(nlev_cas,nt_cas))
+    allocate(hr_cas(nlev_cas,nt_cas),vr_cas(nlev_cas,nt_cas),dr_cas(nlev_cas,nt_cas))
+    allocate(hu_cas(nlev_cas,nt_cas),vu_cas(nlev_cas,nt_cas),du_cas(nlev_cas,nt_cas))
+    allocate(hv_cas(nlev_cas,nt_cas),vv_cas(nlev_cas,nt_cas),dv_cas(nlev_cas,nt_cas))
+    allocate(vitw_cas(nlev_cas,nt_cas))
+    allocate(ug_cas(nlev_cas,nt_cas))
+    allocate(vg_cas(nlev_cas,nt_cas))
+    allocate(lat_cas(nt_cas),sens_cas(nt_cas),ts_cas(nt_cas),ps_cas(nt_cas),ustar_cas(nt_cas))
+    allocate(uw_cas(nlev_cas,nt_cas),vw_cas(nlev_cas,nt_cas),q1_cas(nlev_cas,nt_cas),q2_cas(nlev_cas,nt_cas))
+
+
+    !champs interpoles
+    allocate(plev_prof_cas(nlev_cas))
+    allocate(t_prof_cas(nlev_cas))
+    allocate(q_prof_cas(nlev_cas))
+    allocate(u_prof_cas(nlev_cas))
+    allocate(v_prof_cas(nlev_cas))
+
+    allocate(vitw_prof_cas(nlev_cas))
+    allocate(ug_prof_cas(nlev_cas))
+    allocate(vg_prof_cas(nlev_cas))
+    allocate(ht_prof_cas(nlev_cas))
+    allocate(hq_prof_cas(nlev_cas))
+    allocate(hu_prof_cas(nlev_cas))
+    allocate(hv_prof_cas(nlev_cas))
+    allocate(vt_prof_cas(nlev_cas))
+    allocate(vq_prof_cas(nlev_cas))
+    allocate(vu_prof_cas(nlev_cas))
+    allocate(vv_prof_cas(nlev_cas))
+    allocate(dt_prof_cas(nlev_cas))
+    allocate(dtrad_prof_cas(nlev_cas))
+    allocate(dq_prof_cas(nlev_cas))
+    allocate(du_prof_cas(nlev_cas))
+    allocate(dv_prof_cas(nlev_cas))
+    allocate(uw_prof_cas(nlev_cas))
+    allocate(vw_prof_cas(nlev_cas))
+    allocate(q1_prof_cas(nlev_cas))
+    allocate(q2_prof_cas(nlev_cas))
+
+    print*,'Allocations OK'
+    call read_cas2(nid,nlev_cas,nt_cas                                       &
+         ,z_cas,plev_cas,t_cas,q_cas,rh_cas,th_cas,rv_cas,u_cas,v_cas         &
+         ,ug_cas,vg_cas,vitw_cas,du_cas,hu_cas,vu_cas,dv_cas,hv_cas,vv_cas    &
+         ,dt_cas,dtrad_cas,ht_cas,vt_cas,dq_cas,hq_cas,vq_cas                 &
+         ,dth_cas,hth_cas,vth_cas,dr_cas,hr_cas,vr_cas,sens_cas,lat_cas,ts_cas&
+         ,ustar_cas,uw_cas,vw_cas,q1_cas,q2_cas)
+    print*,'Read cas OK'
+
+
+  END SUBROUTINE read_1D_cas
+  !**********************************************************************************************
+  SUBROUTINE read2_1D_cas
+    implicit none
+
+    INCLUDE "netcdf.inc"
+
+    INTEGER nid,rid,ierr
+    INTEGER ii,jj
+
+    fich_cas='setup/cas.nc'
+    print*,'fich_cas ',fich_cas
+    ierr = NF_OPEN(fich_cas,NF_NOWRITE,nid)
+    print*,'fich_cas,NF_NOWRITE,nid ',fich_cas,NF_NOWRITE,nid
+    if (ierr.NE.NF_NOERR) then
+       write(*,*) 'ERROR: GROS Pb opening forcings nc file '
+       write(*,*) NF_STRERROR(ierr)
+       stop ""
+    endif
+    !.......................................................................
+    ierr=NF_INQ_DIMID(nid,'lat',rid)
+    IF (ierr.NE.NF_NOERR) THEN
+       print*, 'Oh probleme lecture dimension lat'
+    ENDIF
+    ierr=NF_INQ_DIMLEN(nid,rid,ii)
+    print*,'OK1 read2: nid,rid,lat',nid,rid,ii
+    !.......................................................................
+    ierr=NF_INQ_DIMID(nid,'lon',rid)
+    IF (ierr.NE.NF_NOERR) THEN
+       print*, 'Oh probleme lecture dimension lon'
+    ENDIF
+    ierr=NF_INQ_DIMLEN(nid,rid,jj)
+    print*,'OK2 read2: nid,rid,lat',nid,rid,jj
+    !.......................................................................
+    ierr=NF_INQ_DIMID(nid,'nlev',rid)
+    IF (ierr.NE.NF_NOERR) THEN
+       print*, 'Oh probleme lecture dimension nlev'
+    ENDIF
+    ierr=NF_INQ_DIMLEN(nid,rid,nlev_cas)
+    print*,'OK3 read2: nid,rid,nlev_cas',nid,rid,nlev_cas
+    !.......................................................................
+    ierr=NF_INQ_DIMID(nid,'time',rid)
+    nt_cas=0
+    IF (ierr.NE.NF_NOERR) THEN
+       stop 'Oh probleme lecture dimension time'
+    ENDIF
+    ierr=NF_INQ_DIMLEN(nid,rid,nt_cas)
+    print*,'OK4 read2: nid,rid,nt_cas',nid,rid,nt_cas
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+    !profils moyens:
+    allocate(plev_cas(nlev_cas,nt_cas),plevh_cas(nlev_cas+1))        
+    allocate(z_cas(nlev_cas,nt_cas),zh_cas(nlev_cas+1))
+    allocate(ap_cas(nlev_cas+1),bp_cas(nlev_cas+1))
+    allocate(t_cas(nlev_cas,nt_cas),q_cas(nlev_cas,nt_cas),qv_cas(nlev_cas,nt_cas),ql_cas(nlev_cas,nt_cas), &
+         qi_cas(nlev_cas,nt_cas),rh_cas(nlev_cas,nt_cas))
+    allocate(th_cas(nlev_cas,nt_cas),thl_cas(nlev_cas,nt_cas),thv_cas(nlev_cas,nt_cas),rv_cas(nlev_cas,nt_cas))
+    allocate(u_cas(nlev_cas,nt_cas),v_cas(nlev_cas,nt_cas),vitw_cas(nlev_cas,nt_cas),omega_cas(nlev_cas,nt_cas))
+
+    !forcing
+    allocate(ht_cas(nlev_cas,nt_cas),vt_cas(nlev_cas,nt_cas),dt_cas(nlev_cas,nt_cas),dtrad_cas(nlev_cas,nt_cas))
+    allocate(hq_cas(nlev_cas,nt_cas),vq_cas(nlev_cas,nt_cas),dq_cas(nlev_cas,nt_cas))
+    allocate(hth_cas(nlev_cas,nt_cas),vth_cas(nlev_cas,nt_cas),dth_cas(nlev_cas,nt_cas))
+    allocate(hr_cas(nlev_cas,nt_cas),vr_cas(nlev_cas,nt_cas),dr_cas(nlev_cas,nt_cas))
+    allocate(hu_cas(nlev_cas,nt_cas),vu_cas(nlev_cas,nt_cas),du_cas(nlev_cas,nt_cas))
+    allocate(hv_cas(nlev_cas,nt_cas),vv_cas(nlev_cas,nt_cas),dv_cas(nlev_cas,nt_cas))
+    allocate(ug_cas(nlev_cas,nt_cas))
+    allocate(vg_cas(nlev_cas,nt_cas))
+    allocate(lat_cas(nt_cas),sens_cas(nt_cas),ts_cas(nt_cas),ps_cas(nt_cas),ustar_cas(nt_cas),tke_cas(nt_cas))
+    allocate(uw_cas(nlev_cas,nt_cas),vw_cas(nlev_cas,nt_cas),q1_cas(nlev_cas,nt_cas),q2_cas(nlev_cas,nt_cas))
+
+
+
+    !champs interpoles
+    allocate(plev_prof_cas(nlev_cas))
+    allocate(t_prof_cas(nlev_cas))
+    allocate(theta_prof_cas(nlev_cas))
+    allocate(thl_prof_cas(nlev_cas))
+    allocate(thv_prof_cas(nlev_cas))
+    allocate(q_prof_cas(nlev_cas))
+    allocate(qv_prof_cas(nlev_cas))
+    allocate(ql_prof_cas(nlev_cas))
+    allocate(qi_prof_cas(nlev_cas))
+    allocate(rh_prof_cas(nlev_cas))
+    allocate(rv_prof_cas(nlev_cas))
+    allocate(u_prof_cas(nlev_cas))
+    allocate(v_prof_cas(nlev_cas))
+    allocate(vitw_prof_cas(nlev_cas))
+    allocate(omega_prof_cas(nlev_cas))
+    allocate(ug_prof_cas(nlev_cas))
+    allocate(vg_prof_cas(nlev_cas))
+    allocate(ht_prof_cas(nlev_cas))
+    allocate(hth_prof_cas(nlev_cas))
+    allocate(hq_prof_cas(nlev_cas))
+    allocate(hu_prof_cas(nlev_cas))
+    allocate(hv_prof_cas(nlev_cas))
+    allocate(vt_prof_cas(nlev_cas))
+    allocate(vth_prof_cas(nlev_cas))
+    allocate(vq_prof_cas(nlev_cas))
+    allocate(vu_prof_cas(nlev_cas))
+    allocate(vv_prof_cas(nlev_cas))
+    allocate(dt_prof_cas(nlev_cas))
+    allocate(dth_prof_cas(nlev_cas))
+    allocate(dtrad_prof_cas(nlev_cas))
+    allocate(dq_prof_cas(nlev_cas))
+    allocate(du_prof_cas(nlev_cas))
+    allocate(dv_prof_cas(nlev_cas))
+    allocate(uw_prof_cas(nlev_cas))
+    allocate(vw_prof_cas(nlev_cas))
+    allocate(q1_prof_cas(nlev_cas))
+    allocate(q2_prof_cas(nlev_cas))
+
+    print*,'Allocations OK'
+    call read2_cas (nid,nlev_cas,nt_cas,                                                                     &
+         ap_cas,bp_cas,z_cas,plev_cas,zh_cas,plevh_cas,t_cas,th_cas,thv_cas,thl_cas,qv_cas,                    &
+         ql_cas,qi_cas,rh_cas,rv_cas,u_cas,v_cas,vitw_cas,omega_cas,ug_cas,vg_cas,du_cas,hu_cas,vu_cas,        &
+         dv_cas,hv_cas,vv_cas,dt_cas,ht_cas,vt_cas,dq_cas,hq_cas,vq_cas,dth_cas,hth_cas,vth_cas,               &
+         dr_cas,hr_cas,vr_cas,dtrad_cas,sens_cas,lat_cas,ts_cas,ps_cas,ustar_cas,tke_cas,                      &
+         uw_cas,vw_cas,q1_cas,q2_cas,orog_cas,albedo_cas,emiss_cas,t_skin_cas,q_skin_cas,mom_rough,heat_rough, &
+         o3_cas,rugos_cas,clay_cas,sand_cas)
+    print*,'Read2 cas OK'
+    do ii=1,nlev_cas
+       print*,'apres read2_cas, plev_cas=',ii,plev_cas(ii,1)
+    enddo
+
+
+  END SUBROUTINE read2_1D_cas
+
+  !**********************************************************************************************
+  SUBROUTINE old_read_SCM_cas
+    use netcdf, only: nf90_get_var
+    implicit none
+
+    INCLUDE "netcdf.inc"
+    INCLUDE "date_cas.h"
+
+    INTEGER nid,rid,ierr
+    INTEGER ii,jj,timeid
+    REAL, ALLOCATABLE :: time_val(:)
+
+    fich_cas='cas.nc'
+    print*,'fich_cas ',fich_cas
+    ierr = NF_OPEN(fich_cas,NF_NOWRITE,nid)
+    print*,'fich_cas,NF_NOWRITE,nid ',fich_cas,NF_NOWRITE,nid
+    if (ierr.NE.NF_NOERR) then
+       write(*,*) 'ERROR: GROS Pb opening forcings nc file '
+       write(*,*) NF_STRERROR(ierr)
+       stop ""
+    endif
+    !.......................................................................
+    ierr=NF_INQ_DIMID(nid,'lat',rid)
+    IF (ierr.NE.NF_NOERR) THEN
+       print*, 'Oh probleme lecture dimension lat'
+    ENDIF
+    ierr=NF_INQ_DIMLEN(nid,rid,ii)
+    print*,'OK1 read2: nid,rid,lat',nid,rid,ii
+    !.......................................................................
+    ierr=NF_INQ_DIMID(nid,'lon',rid)
+    IF (ierr.NE.NF_NOERR) THEN
+       print*, 'Oh probleme lecture dimension lon'
+    ENDIF
+    ierr=NF_INQ_DIMLEN(nid,rid,jj)
+    print*,'OK2 read2: nid,rid,lat',nid,rid,jj
+    !.......................................................................
+    ierr=NF_INQ_DIMID(nid,'lev',rid)
+    IF (ierr.NE.NF_NOERR) THEN
+       print*, 'Oh probleme lecture dimension nlev'
+    ENDIF
+    ierr=NF_INQ_DIMLEN(nid,rid,nlev_cas)
+    print*,'OK3 read2: nid,rid,nlev_cas',nid,rid,nlev_cas
+    IF ( .NOT. ( nlev_cas > 10 .AND. nlev_cas < 1000 )) THEN
+       print*,'Valeur de nlev_cas peu probable'
+       STOP
+    ENDIF
+    !.......................................................................
+    ierr=NF_INQ_DIMID(nid,'time',rid)
+    nt_cas=0
+    IF (ierr.NE.NF_NOERR) THEN
+       stop 'Oh probleme lecture dimension time'
+    ENDIF
+    ierr=NF_INQ_DIMLEN(nid,rid,nt_cas)
+    print*,'OK4 read2: nid,rid,nt_cas',nid,rid,nt_cas
+    ! Lecture de l'axe des temps
+    print*,'LECTURE DU TEMPS'
+    ierr=NF_INQ_VARID(nid,'time',timeid)
+    if(ierr/=NF_NOERR) then
+       print *,'Variable time manquante dans cas.nc:'
+       ierr=NF_NOERR
+    else
+       allocate(time_val(nt_cas))
+       ierr = NF90_GET_VAR(nid,timeid,time_val)
+       if(ierr/=NF_NOERR) then
+          print *,'Pb a la lecture de time cas.nc: '
+       endif
+    endif
+    IF (nt_cas>1) THEN
+       pdt_cas=time_val(2)-time_val(1)
+    ELSE
+       pdt_cas=0.
+    ENDIF
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+    !profils moyens:
+    allocate(plev_cas(nlev_cas,nt_cas),plevh_cas(nlev_cas+1))        
+    allocate(z_cas(nlev_cas,nt_cas),zh_cas(nlev_cas+1))
+    allocate(ap_cas(nlev_cas+1),bp_cas(nlev_cas+1))
+    allocate(t_cas(nlev_cas,nt_cas),q_cas(nlev_cas,nt_cas),qv_cas(nlev_cas,nt_cas),ql_cas(nlev_cas,nt_cas), &
+         qi_cas(nlev_cas,nt_cas),rh_cas(nlev_cas,nt_cas))
+    allocate(th_cas(nlev_cas,nt_cas),thl_cas(nlev_cas,nt_cas),thv_cas(nlev_cas,nt_cas),rv_cas(nlev_cas,nt_cas))
+    allocate(u_cas(nlev_cas,nt_cas),v_cas(nlev_cas,nt_cas),vitw_cas(nlev_cas,nt_cas),omega_cas(nlev_cas,nt_cas))
+
+    !forcing
+    allocate(ht_cas(nlev_cas,nt_cas),vt_cas(nlev_cas,nt_cas),dt_cas(nlev_cas,nt_cas),dtrad_cas(nlev_cas,nt_cas))
+    allocate(hq_cas(nlev_cas,nt_cas),vq_cas(nlev_cas,nt_cas),dq_cas(nlev_cas,nt_cas))
+    allocate(hth_cas(nlev_cas,nt_cas),vth_cas(nlev_cas,nt_cas),dth_cas(nlev_cas,nt_cas))
+    allocate(hr_cas(nlev_cas,nt_cas),vr_cas(nlev_cas,nt_cas),dr_cas(nlev_cas,nt_cas))
+    allocate(hu_cas(nlev_cas,nt_cas),vu_cas(nlev_cas,nt_cas),du_cas(nlev_cas,nt_cas))
+    allocate(hv_cas(nlev_cas,nt_cas),vv_cas(nlev_cas,nt_cas),dv_cas(nlev_cas,nt_cas))
+    allocate(ug_cas(nlev_cas,nt_cas))
+    allocate(vg_cas(nlev_cas,nt_cas))
+    allocate(lat_cas(nt_cas),sens_cas(nt_cas),ts_cas(nt_cas),ps_cas(nt_cas),ustar_cas(nt_cas),tke_cas(nt_cas))
+    allocate(uw_cas(nlev_cas,nt_cas),vw_cas(nlev_cas,nt_cas),q1_cas(nlev_cas,nt_cas),q2_cas(nlev_cas,nt_cas))
+
+
+
+    !champs interpoles
+    allocate(plev_prof_cas(nlev_cas))
+    allocate(t_prof_cas(nlev_cas))
+    allocate(theta_prof_cas(nlev_cas))
+    allocate(thl_prof_cas(nlev_cas))
+    allocate(thv_prof_cas(nlev_cas))
+    allocate(q_prof_cas(nlev_cas))
+    allocate(qv_prof_cas(nlev_cas))
+    allocate(ql_prof_cas(nlev_cas))
+    allocate(qi_prof_cas(nlev_cas))
+    allocate(rh_prof_cas(nlev_cas))
+    allocate(rv_prof_cas(nlev_cas))
+    allocate(u_prof_cas(nlev_cas))
+    allocate(v_prof_cas(nlev_cas))
+    allocate(vitw_prof_cas(nlev_cas))
+    allocate(omega_prof_cas(nlev_cas))
+    allocate(ug_prof_cas(nlev_cas))
+    allocate(vg_prof_cas(nlev_cas))
+    allocate(ht_prof_cas(nlev_cas))
+    allocate(hth_prof_cas(nlev_cas))
+    allocate(hq_prof_cas(nlev_cas))
+    allocate(hu_prof_cas(nlev_cas))
+    allocate(hv_prof_cas(nlev_cas))
+    allocate(vt_prof_cas(nlev_cas))
+    allocate(vth_prof_cas(nlev_cas))
+    allocate(vq_prof_cas(nlev_cas))
+    allocate(vu_prof_cas(nlev_cas))
+    allocate(vv_prof_cas(nlev_cas))
+    allocate(dt_prof_cas(nlev_cas))
+    allocate(dth_prof_cas(nlev_cas))
+    allocate(dtrad_prof_cas(nlev_cas))
+    allocate(dq_prof_cas(nlev_cas))
+    allocate(du_prof_cas(nlev_cas))
+    allocate(dv_prof_cas(nlev_cas))
+    allocate(uw_prof_cas(nlev_cas))
+    allocate(vw_prof_cas(nlev_cas))
+    allocate(q1_prof_cas(nlev_cas))
+    allocate(q2_prof_cas(nlev_cas))
+
+    print*,'Allocations OK'
+    call old_read_SCM (nid,nlev_cas,nt_cas,                                                                     &
+         ap_cas,bp_cas,z_cas,plev_cas,zh_cas,plevh_cas,t_cas,th_cas,thv_cas,thl_cas,qv_cas,                    &
+         ql_cas,qi_cas,rh_cas,rv_cas,u_cas,v_cas,vitw_cas,omega_cas,ug_cas,vg_cas,du_cas,hu_cas,vu_cas,        &
+         dv_cas,hv_cas,vv_cas,dt_cas,ht_cas,vt_cas,dq_cas,hq_cas,vq_cas,dth_cas,hth_cas,vth_cas,               &
+         dr_cas,hr_cas,vr_cas,dtrad_cas,sens_cas,lat_cas,ts_cas,ps_cas,ustar_cas,tke_cas,                      &
+         uw_cas,vw_cas,q1_cas,q2_cas,orog_cas,albedo_cas,emiss_cas,t_skin_cas,q_skin_cas,mom_rough,heat_rough, &
+         o3_cas,rugos_cas,clay_cas,sand_cas)
+    print*,'Read2 cas OK'
+    do ii=1,nlev_cas
+       print*,'apres read2_cas, plev_cas=',ii,plev_cas(ii,1)
+    enddo
+
+
+  END SUBROUTINE old_read_SCM_cas
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+  SUBROUTINE deallocate2_1D_cases
+    !profils environnementaux:
+    deallocate(plev_cas,plevh_cas)
+
+    deallocate(z_cas,zh_cas)
+    deallocate(ap_cas,bp_cas)
+    deallocate(t_cas,q_cas,qv_cas,ql_cas,qi_cas,rh_cas)
+    deallocate(th_cas,thl_cas,thv_cas,rv_cas)
+    deallocate(u_cas,v_cas,vitw_cas,omega_cas)
+
+    !forcing
+    deallocate(ht_cas,vt_cas,dt_cas,dtrad_cas)
+    deallocate(hq_cas,vq_cas,dq_cas)
+    deallocate(hth_cas,vth_cas,dth_cas)
+    deallocate(hr_cas,vr_cas,dr_cas)
+    deallocate(hu_cas,vu_cas,du_cas)
+    deallocate(hv_cas,vv_cas,dv_cas)
+    deallocate(ug_cas)
+    deallocate(vg_cas)
+    deallocate(lat_cas,sens_cas,ts_cas,ps_cas,ustar_cas,tke_cas,uw_cas,vw_cas,q1_cas,q2_cas)
+
+    !champs interpoles
+    deallocate(plev_prof_cas)
+    deallocate(t_prof_cas)
+    deallocate(theta_prof_cas)
+    deallocate(thl_prof_cas)
+    deallocate(thv_prof_cas)
+    deallocate(q_prof_cas)
+    deallocate(qv_prof_cas)
+    deallocate(ql_prof_cas)
+    deallocate(qi_prof_cas)
+    deallocate(rh_prof_cas)
+    deallocate(rv_prof_cas)
+    deallocate(u_prof_cas)
+    deallocate(v_prof_cas)
+    deallocate(vitw_prof_cas)
+    deallocate(omega_prof_cas)
+    deallocate(ug_prof_cas)
+    deallocate(vg_prof_cas)
+    deallocate(ht_prof_cas)
+    deallocate(hq_prof_cas)
+    deallocate(hu_prof_cas)
+    deallocate(hv_prof_cas)
+    deallocate(vt_prof_cas)
+    deallocate(vq_prof_cas)
+    deallocate(vu_prof_cas)
+    deallocate(vv_prof_cas)
+    deallocate(dt_prof_cas)
+    deallocate(dtrad_prof_cas)
+    deallocate(dq_prof_cas)
+    deallocate(du_prof_cas)
+    deallocate(dv_prof_cas)
+    deallocate(t_prof_cas)
+    deallocate(u_prof_cas)
+    deallocate(v_prof_cas)
+    deallocate(uw_prof_cas)
+    deallocate(vw_prof_cas)
+    deallocate(q1_prof_cas)
+    deallocate(q2_prof_cas)
+
+  END SUBROUTINE deallocate2_1D_cases
+
+
+END MODULE mod_1D_cases_read2
+!=====================================================================
+subroutine read_cas2(nid,nlevel,ntime                          &
+     ,zz,pp,temp,qv,rh,theta,rv,u,v,ug,vg,w,                   &
+     du,hu,vu,dv,hv,vv,dt,dtrad,ht,vt,dq,hq,vq,                     &
+     dth,hth,vth,dr,hr,vr,sens,flat,ts,ustar,uw,vw,q1,q2)
+
+  !program reading forcing of the case study
+  use netcdf, only: nf90_get_var
+  implicit none
+  INCLUDE "netcdf.inc"
+
+  integer ntime,nlevel
+
+  real zz(nlevel,ntime)
+  real pp(nlevel,ntime)
+  real temp(nlevel,ntime),qv(nlevel,ntime),rh(nlevel,ntime)
+  real theta(nlevel,ntime),rv(nlevel,ntime)
+  real u(nlevel,ntime)
+  real v(nlevel,ntime)
+  real ug(nlevel,ntime)
+  real vg(nlevel,ntime)
+  real w(nlevel,ntime)
+  real du(nlevel,ntime),hu(nlevel,ntime),vu(nlevel,ntime)
+  real dv(nlevel,ntime),hv(nlevel,ntime),vv(nlevel,ntime)
+  real dt(nlevel,ntime),ht(nlevel,ntime),vt(nlevel,ntime)
+  real dtrad(nlevel,ntime)
+  real dq(nlevel,ntime),hq(nlevel,ntime),vq(nlevel,ntime)
+  real dth(nlevel,ntime),hth(nlevel,ntime),vth(nlevel,ntime)
+  real dr(nlevel,ntime),hr(nlevel,ntime),vr(nlevel,ntime)
+  real flat(ntime),sens(ntime),ts(ntime),ustar(ntime)
+  real uw(nlevel,ntime),vw(nlevel,ntime),q1(nlevel,ntime),q2(nlevel,ntime),resul(nlevel,ntime),resul1(ntime)
+
+
+  integer nid, ierr, ierr1,ierr2,rid,i
+  integer nbvar3d
+  parameter(nbvar3d=39)
+  integer var3didin(nbvar3d)
+  character*5 name_var(1:nbvar3d)
+  data name_var/'zz','pp','temp','qv','rh','theta','rv','u','v','ug','vg','w','advu','hu','vu',&
+       'advv','hv','vv','advT','hT','vT','advq','hq','vq','advth','hth','vth','advr','hr','vr',&
+       'radT','uw','vw','q1','q2','sens','flat','ts','ustar'/
+
+
+  do i=1,nbvar3d
+     print *,'Dans read_cas2, on va lire ',nid,i,name_var(i)
+  enddo
+  do i=1,nbvar3d
+     ierr=NF_INQ_VARID(nid,name_var(i),var3didin(i)) 
+     print *,'ierr=',i,ierr,name_var(i),var3didin(i)
+     if(ierr/=NF_NOERR) then
+        print *,'Variable manquante dans cas.nc:',name_var(i)
+     endif
+  enddo
+  do i=1,nbvar3d
+     print *,'Dans read_cas2, on va lire ',var3didin(i),name_var(i)
+     if(i.LE.35) then
+        ierr = NF90_GET_VAR(nid,var3didin(i),resul, count = [1, 1, nlevel, ntime])
+        print *,'Dans read_cas2, on a lu ',ierr,var3didin(i),name_var(i)
+        if(ierr/=NF_NOERR) then
+           print *,'Pb a la lecture de cas.nc: ',name_var(i)
+           stop "getvarup"
+        endif
+     else
+        print *,'Dans read_cas2, on a lu ',ierr,var3didin(i),name_var(i)
+        ierr = NF90_GET_VAR(nid,var3didin(i),resul1, count = [1, 1, ntime])
+        if(ierr/=NF_NOERR) then
+           print *,'Pb a la lecture de cas.nc: ',name_var(i)
+           stop "getvarup"
+        endif
+     endif
+     select case(i)
+     case(1) ; zz=resul
+     case(2) ; pp=resul
+     case(3) ; temp=resul
+     case(4) ; qv=resul
+     case(5) ; rh=resul
+     case(6) ; theta=resul
+     case(7) ; rv=resul
+     case(8) ; u=resul
+     case(9) ; v=resul
+     case(10) ; ug=resul
+     case(11) ; vg=resul
+     case(12) ; w=resul
+     case(13) ; du=resul
+     case(14) ; hu=resul
+     case(15) ; vu=resul
+     case(16) ; dv=resul
+     case(17) ; hv=resul
+     case(18) ; vv=resul
+     case(19) ; dt=resul
+     case(20) ; ht=resul
+     case(21) ; vt=resul
+     case(22) ; dq=resul
+     case(23) ; hq=resul
+     case(24) ; vq=resul
+     case(25) ; dth=resul
+     case(26) ; hth=resul
+     case(27) ; vth=resul
+     case(28) ; dr=resul
+     case(29) ; hr=resul
+     case(30) ; vr=resul
+     case(31) ; dtrad=resul
+     case(32) ; uw=resul
+     case(33) ; vw=resul
+     case(34) ; q1=resul
+     case(35) ; q2=resul
+     case(36) ; sens=resul1
+     case(37) ; flat=resul1
+     case(38) ; ts=resul1
+     case(39) ; ustar=resul1
+     end select
+  enddo
+
+  return 
+end subroutine read_cas2
+!======================================================================
+subroutine read2_cas(nid,nlevel,ntime,                                       &
+     ap,bp,zz,pp,zzh,pph,temp,theta,thv,thl,qv,ql,qi,rh,rv,u,v,vitw,omega,ug,vg,&
+     du,hu,vu,dv,hv,vv,dt,ht,vt,dq,hq,vq,                                    &
+     dth,hth,vth,dr,hr,vr,dtrad,sens,flat,ts,ps,ustar,tke,uw,vw,q1,q2,       &
+     orog_cas,albedo_cas,emiss_cas,t_skin_cas,q_skin_cas,mom_rough,          &
+     heat_rough,o3_cas,rugos_cas,clay_cas,sand_cas)
+
+  !program reading forcing of the case study
+  use netcdf, only: nf90_get_var
+  implicit none
+  INCLUDE "netcdf.inc"
+
+  integer ntime,nlevel
+
+  real ap(nlevel+1),bp(nlevel+1)
+  real zz(nlevel,ntime),zzh(nlevel+1)
+  real pp(nlevel,ntime),pph(nlevel+1)
+  real temp(nlevel,ntime),qv(nlevel,ntime),ql(nlevel,ntime),qi(nlevel,ntime),rh(nlevel,ntime)
+  real theta(nlevel,ntime),thv(nlevel,ntime),thl(nlevel,ntime),rv(nlevel,ntime)
+  real u(nlevel,ntime),v(nlevel,ntime)
+  real ug(nlevel,ntime),vg(nlevel,ntime)
+  real vitw(nlevel,ntime),omega(nlevel,ntime)
+  real du(nlevel,ntime),hu(nlevel,ntime),vu(nlevel,ntime)
+  real dv(nlevel,ntime),hv(nlevel,ntime),vv(nlevel,ntime)
+  real dt(nlevel,ntime),ht(nlevel,ntime),vt(nlevel,ntime)
+  real dtrad(nlevel,ntime)
+  real dq(nlevel,ntime),hq(nlevel,ntime),vq(nlevel,ntime)
+  real dth(nlevel,ntime),hth(nlevel,ntime),vth(nlevel,ntime),hthl(nlevel,ntime)
+  real dr(nlevel,ntime),hr(nlevel,ntime),vr(nlevel,ntime)
+  real flat(ntime),sens(ntime),ustar(ntime)
+  real uw(nlevel,ntime),vw(nlevel,ntime),q1(nlevel,ntime),q2(nlevel,ntime)
+  real ts(ntime),ps(ntime),tke(ntime)
+  real orog_cas,albedo_cas,emiss_cas,t_skin_cas,q_skin_cas,mom_rough,heat_rough,o3_cas,rugos_cas,clay_cas,sand_cas
+  real apbp(nlevel+1),resul(nlevel,ntime),resul1(nlevel),resul2(ntime),resul3
+
+
+  integer nid, ierr,ierr1,ierr2,rid,i
+  integer nbvar3d
+  parameter(nbvar3d=62)
+  integer var3didin(nbvar3d),missing_var(nbvar3d)
+  character*12 name_var(1:nbvar3d)
+  data name_var/'coor_par_a','coor_par_b','height_h','pressure_h',&
+       'w','omega','ug','vg','uadv','uadvh','uadvv','vadv','vadvh','vadvv','tadv','tadvh','tadvv',&
+       'qadv','qadvh','qadvv','thadv','thadvh','thadvv','thladvh','radv','radvh','radvv','radcool','q1','q2','ustress','vstress', &
+       'rh',&
+       'height_f','pressure_f','temp','theta','thv','thl','qv','ql','qi','rv','u','v',&
+       'sfc_sens_flx','sfc_lat_flx','ts','ps','ustar','tke',&
+       'orog','albedo','emiss','t_skin','q_skin','mom_rough','heat_rough','o3','rugos','clay','sand'/
+  do i=1,nbvar3d
+     missing_var(i)=0.
+  enddo
+
+  !-----------------------------------------------------------------------
+  do i=1,nbvar3d
+     ierr=NF_INQ_VARID(nid,name_var(i),var3didin(i)) 
+     if(ierr/=NF_NOERR) then
+        print *,'Variable manquante dans cas.nc:',i,name_var(i)
+        ierr=NF_NOERR
+        missing_var(i)=1
+     else
+        !-----------------------------------------------------------------------
+        if(i.LE.4) then     ! Lecture des coord pression en (nlevelp1,lat,lon)
+           ierr = NF90_GET_VAR(nid,var3didin(i),apbp, count = [1, 1, nlevel + 1])
+           print *,'read2_cas(apbp), on a lu ',i,name_var(i)
+           if(ierr/=NF_NOERR) then
+              print *,'Pb a la lecture de cas.nc: ',name_var(i)
+              stop "getvarup"
+           endif
+           !-----------------------------------------------------------------------
+        else if(i.gt.4.and.i.LE.45) then   ! Lecture des variables en (time,nlevel,lat,lon)
+           ierr = NF90_GET_VAR(nid,var3didin(i),resul, count = [1, 1, nlevel, ntime])
+           print *,'read2_cas(resul), on a lu ',i,name_var(i)
+           if(ierr/=NF_NOERR) then
+              print *,'Pb a la lecture de cas.nc: ',name_var(i)
+              stop "getvarup"
+           endif
+           !-----------------------------------------------------------------------
+        else if (i.gt.45.and.i.LE.51) then   ! Lecture des variables en (time,lat,lon)
+           ierr = NF90_GET_VAR(nid,var3didin(i),resul2, count = [1, 1, ntime])
+           print *,'read2_cas(resul2), on a lu ',i,name_var(i)
+           if(ierr/=NF_NOERR) then
+              print *,'Pb a la lecture de cas.nc: ',name_var(i)
+              stop "getvarup"
+           endif
+           !-----------------------------------------------------------------------
+        else     ! Lecture des constantes (lat,lon)
+           ierr = NF90_GET_VAR(nid,var3didin(i),resul3)
+           print *,'read2_cas(resul3), on a lu ',i,name_var(i)
+           if(ierr/=NF_NOERR) then
+              print *,'Pb a la lecture de cas.nc: ',name_var(i)
+              stop "getvarup"
+           endif
+        endif
+     endif
+     !-----------------------------------------------------------------------
+     select case(i)
+     case(1) ; ap=apbp       ! donnees indexees en nlevel+1
+     case(2) ; bp=apbp
+     case(3) ; zzh=apbp
+     case(4) ; pph=apbp
+     case(5) ; vitw=resul    ! donnees indexees en nlevel,time
+     case(6) ; omega=resul
+     case(7) ; ug=resul
+     case(8) ; vg=resul
+     case(9) ; du=resul
+     case(10) ; hu=resul
+     case(11) ; vu=resul
+     case(12) ; dv=resul
+     case(13) ; hv=resul
+     case(14) ; vv=resul
+     case(15) ; dt=resul
+     case(16) ; ht=resul
+     case(17) ; vt=resul
+     case(18) ; dq=resul
+     case(19) ; hq=resul
+     case(20) ; vq=resul
+     case(21) ; dth=resul
+     case(22) ; hth=resul
+     case(23) ; vth=resul
+     case(24) ; hthl=resul
+     case(25) ; dr=resul
+     case(26) ; hr=resul
+     case(27) ; vr=resul
+     case(28) ; dtrad=resul
+     case(29) ; q1=resul
+     case(30) ; q2=resul
+     case(31) ; uw=resul
+     case(32) ; vw=resul
+     case(33) ; rh=resul
+     case(34) ; zz=resul      ! donnees en time,nlevel pour profil initial
+     case(35) ; pp=resul
+     case(36) ; temp=resul
+     case(37) ; theta=resul
+     case(38) ; thv=resul
+     case(39) ; thl=resul
+     case(40) ; qv=resul
+     case(41) ; ql=resul
+     case(42) ; qi=resul
+     case(43) ; rv=resul
+     case(44) ; u=resul
+     case(45) ; v=resul
+     case(46) ; sens=resul2   ! donnees indexees en time
+     case(47) ; flat=resul2
+     case(48) ; ts=resul2
+     case(49) ; ps=resul2
+     case(50) ; ustar=resul2
+     case(51) ; tke=resul2
+     case(52) ; orog_cas=resul3      ! constantes
+     case(53) ; albedo_cas=resul3
+     case(54) ; emiss_cas=resul3
+     case(55) ; t_skin_cas=resul3
+     case(56) ; q_skin_cas=resul3
+     case(57) ; mom_rough=resul3
+     case(58) ; heat_rough=resul3
+     case(59) ; o3_cas=resul3        
+     case(60) ; rugos_cas=resul3
+     case(61) ; clay_cas=resul3
+     case(62) ; sand_cas=resul3
+     end select
+     resul=0.
+     resul1=0.
+     resul2=0.
+     resul3=0.
+  enddo
+  !-----------------------------------------------------------------------
+
+
+  return 
+end subroutine read2_cas
+
+!======================================================================
+subroutine old_read_SCM(nid,nlevel,ntime,                                       &
+     ap,bp,zz,pp,zzh,pph,temp,theta,thv,thl,qv,ql,qi,rh,rv,u,v,vitw,omega,ug,vg,&
+     du,hu,vu,dv,hv,vv,dt,ht,vt,dq,hq,vq,                                    &
+     dth,hth,vth,dr,hr,vr,dtrad,sens,flat,ts,ps,ustar,tke,uw,vw,q1,q2,       &
+     orog_cas,albedo_cas,emiss_cas,t_skin_cas,q_skin_cas,mom_rough,          &
+     heat_rough,o3_cas,rugos_cas,clay_cas,sand_cas)
+
+  !program reading forcing of the case study
+  use netcdf, only: nf90_get_var
+  implicit none
+  INCLUDE "netcdf.inc"
+
+  integer ntime,nlevel,k,t
+
+  real ap(nlevel+1),bp(nlevel+1)
+  real zz(nlevel,ntime),zzh(nlevel+1)
+  real pp(nlevel,ntime),pph(nlevel+1)
+  !profils initiaux
+  real temp0(nlevel),qv0(nlevel),ql0(nlevel),qi0(nlevel),u0(nlevel),v0(nlevel),tke0(nlevel)
+  real pp0(nlevel)    
+  real temp(nlevel,ntime),qv(nlevel,ntime),ql(nlevel,ntime),qi(nlevel,ntime),rh(nlevel,ntime)
+  real theta(nlevel,ntime),thv(nlevel,ntime),thl(nlevel,ntime),rv(nlevel,ntime)
+  real u(nlevel,ntime),v(nlevel,ntime),tke(nlevel,ntime)
+  real ug(nlevel,ntime),vg(nlevel,ntime)
+  real vitw(nlevel,ntime),omega(nlevel,ntime)
+  real du(nlevel,ntime),hu(nlevel,ntime),vu(nlevel,ntime)
+  real dv(nlevel,ntime),hv(nlevel,ntime),vv(nlevel,ntime)
+  real dt(nlevel,ntime),ht(nlevel,ntime),vt(nlevel,ntime)
+  real dtrad(nlevel,ntime)
+  real dq(nlevel,ntime),hq(nlevel,ntime),vq(nlevel,ntime)
+  real dth(nlevel,ntime),hth(nlevel,ntime),vth(nlevel,ntime),hthl(nlevel,ntime)
+  real dr(nlevel,ntime),hr(nlevel,ntime),vr(nlevel,ntime)
+  real flat(ntime),sens(ntime),ustar(ntime)
+  real uw(nlevel,ntime),vw(nlevel,ntime),q1(nlevel,ntime),q2(nlevel,ntime)
+  real ts(ntime),ps(ntime)
+  real orog_cas,albedo_cas,emiss_cas,t_skin_cas,q_skin_cas,mom_rough,heat_rough,o3_cas,rugos_cas,clay_cas,sand_cas
+  real apbp(nlevel+1),resul(nlevel,ntime),resul1(nlevel),resul2(ntime),resul3
+
+
+  integer nid, ierr,ierr1,ierr2,rid,i
+  integer nbvar3d
+  parameter(nbvar3d=70)
+  integer var3didin(nbvar3d),missing_var(nbvar3d)
+  character*13 name_var(1:nbvar3d)
+  data name_var/'coor_par_a','coor_par_b','height_h','pressure_h',&
+       'temp','qv','ql','qi','u','v','tke','pressure',&
+       'w','omega','ug','vg','uadv','uadvh','uadvv','vadv','vadvh','vadvv','tadv','tadvh','tadvv',&
+       'qvadv','qvadvh','qvadvv','thadv','thadvh','thadvv','thladvh','radv','radvh','radvv','radcool','q1','q2','ustress', &
+       'vstress','rh',&
+       'height_f','pressure_forc','tempt','theta','thv','thl','qvt','qlt','qit','rv','ut','vt','tket',&
+       'sfc_sens_flx','sfc_lat_flx','ts','ps','ustar',&
+       'orog','albedo','emiss','t_skin','q_skin','mom_rough','heat_rough','o3','rugos','clay','sand'/
+  do i=1,nbvar3d
+     missing_var(i)=0.
+  enddo
+
+  !-----------------------------------------------------------------------
+
+  print*,'ON EST LA'
+  do i=1,nbvar3d
+     ierr=NF_INQ_VARID(nid,name_var(i),var3didin(i)) 
+     if(ierr/=NF_NOERR) then
+        print *,'Variable manquante dans cas.nc:',i,name_var(i)
+        ierr=NF_NOERR
+        missing_var(i)=1
+     else
+        !-----------------------------------------------------------------------
+        if(i.LE.4) then     ! Lecture des coord pression en (nlevelp1,lat,lon)
+           ierr = NF90_GET_VAR(nid,var3didin(i),apbp)
+           print *,'read2_cas(apbp), on a lu ',i,name_var(i)
+           if(ierr/=NF_NOERR) then
+              print *,'Pb a la lecture de cas.nc: ',name_var(i)
+              stop "getvarup"
+           endif
+           !-----------------------------------------------------------------------
+        else if(i.gt.4.and.i.LE.12) then   ! Lecture des variables en (time,nlevel,lat,lon)
+           ierr = NF90_GET_VAR(nid,var3didin(i),resul1)
+           print *,'read2_cas(resul1), on a lu ',i,name_var(i)
+           if(ierr/=NF_NOERR) then
+              print *,'Pb a la lecture de cas.nc: ',name_var(i)
+              stop "getvarup"
+           endif
+           print*,'Lecture de la variable #i ',i,name_var(i),minval(resul1),maxval(resul1)
+           !-----------------------------------------------------------------------
+        else if(i.gt.12.and.i.LE.54) then   ! Lecture des variables en (time,nlevel,lat,lon)
+           ierr = NF90_GET_VAR(nid,var3didin(i),resul)
+           print *,'read2_cas(resul), on a lu ',i,name_var(i)
+           if(ierr/=NF_NOERR) then
+              print *,'Pb a la lecture de cas.nc: ',name_var(i)
+              stop "getvarup"
+           endif
+           print*,'Lecture de la variable #i ',i,name_var(i),minval(resul),maxval(resul)
+           !-----------------------------------------------------------------------
+        else if (i.gt.54.and.i.LE.65) then   ! Lecture des variables en (time,lat,lon)
+           ierr = NF90_GET_VAR(nid,var3didin(i),resul2)
+           print *,'read2_cas(resul2), on a lu ',i,name_var(i)
+           if(ierr/=NF_NOERR) then
+              print *,'Pb a la lecture de cas.nc: ',name_var(i)
+              stop "getvarup"
+           endif
+           print*,'Lecture de la variable #i  ',i,name_var(i),minval(resul2),maxval(resul2)
+           !-----------------------------------------------------------------------
+        else     ! Lecture des constantes (lat,lon)
+           ierr = NF90_GET_VAR(nid,var3didin(i),resul3)
+           print *,'read2_cas(resul3), on a lu ',i,name_var(i)
+           if(ierr/=NF_NOERR) then
+              print *,'Pb a la lecture de cas.nc: ',name_var(i)
+              stop "getvarup"
+           endif
+           print*,'Lecture de la variable #i ',i,name_var(i),resul3
+        endif
+     endif
+     !-----------------------------------------------------------------------
+     select case(i)
+        !case(1) ; ap=apbp       ! donnees indexees en nlevel+1
+        ! case(2) ; bp=apbp
+     case(3) ; zzh=apbp
+     case(4) ; pph=apbp
+     case(5) ; temp0=resul1    ! donnees initiales
+     case(6) ; qv0=resul1
+     case(7) ; ql0=resul1
+     case(8) ; qi0=resul1
+     case(9) ; u0=resul1
+     case(10) ; v0=resul1
+     case(11) ; tke0=resul1
+     case(12) ; pp0=resul1
+     case(13) ; vitw=resul    ! donnees indexees en nlevel,time
+     case(14) ; omega=resul
+     case(15) ; ug=resul
+     case(16) ; vg=resul
+     case(17) ; du=resul
+     case(18) ; hu=resul
+     case(19) ; vu=resul
+     case(20) ; dv=resul
+     case(21) ; hv=resul
+     case(22) ; vv=resul
+     case(23) ; dt=resul
+     case(24) ; ht=resul
+     case(25) ; vt=resul
+     case(26) ; dq=resul
+     case(27) ; hq=resul
+     case(28) ; vq=resul
+     case(29) ; dth=resul
+     case(30) ; hth=resul
+     case(31) ; vth=resul
+     case(32) ; hthl=resul
+     case(33) ; dr=resul
+     case(34) ; hr=resul
+     case(35) ; vr=resul
+     case(36) ; dtrad=resul
+     case(37) ; q1=resul
+     case(38) ; q2=resul
+     case(39) ; uw=resul
+     case(40) ; vw=resul
+     case(41) ; rh=resul
+     case(42) ; zz=resul      ! donnees en time,nlevel pour profil initial
+     case(43) ; pp=resul
+     case(44) ; temp=resul
+     case(45) ; theta=resul
+     case(46) ; thv=resul
+     case(47) ; thl=resul
+     case(48) ; qv=resul
+     case(49) ; ql=resul
+     case(50) ; qi=resul
+     case(51) ; rv=resul
+     case(52) ; u=resul
+     case(53) ; v=resul
+     case(54) ; tke=resul
+     case(55) ; sens=resul2   ! donnees indexees en time
+     case(56) ; flat=resul2
+     case(57) ; ts=resul2
+     case(58) ; ps=resul2
+     case(59) ; ustar=resul2
+     case(60) ; orog_cas=resul3      ! constantes
+     case(61) ; albedo_cas=resul3
+     case(62) ; emiss_cas=resul3
+     case(63) ; t_skin_cas=resul3
+     case(64) ; q_skin_cas=resul3
+     case(65) ; mom_rough=resul3
+     case(66) ; heat_rough=resul3
+     case(67) ; o3_cas=resul3        
+     case(68) ; rugos_cas=resul3
+     case(69) ; clay_cas=resul3
+     case(70) ; sand_cas=resul3
+     end select
+     resul=0.
+     resul1=0.
+     resul2=0.
+     resul3=0.
+  enddo
+  print*,'Lecture de la variable APRES ,sens ',minval(sens),maxval(sens)
+  print*,'Lecture de la variable APRES ,flat ',minval(flat),maxval(flat)
+
+  !CR:ATTENTION EN ATTENTE DE REGLER LA QUESTION DU PAS DE TEMPS INITIAL
+  do t=1,ntime
+     do k=1,nlevel
+        temp(k,t)=temp0(k)
+        qv(k,t)=qv0(k)
+        ql(k,t)=ql0(k)
+        qi(k,t)=qi0(k)
+        u(k,t)=u0(k)
+        v(k,t)=v0(k)
+        tke(k,t)=tke0(k)
+     enddo
+  enddo
+  !-----------------------------------------------------------------------
+
+  return 
+end subroutine old_read_SCM
+!======================================================================
+
+!======================================================================
+SUBROUTINE interp_case_time2(day,day1,annee_ref                &
+     !    &         ,year_cas,day_cas,nt_cas,pdt_forc,nlev_cas      &
+     ,nt_cas,nlev_cas                                       &
+     ,ts_cas,ps_cas,plev_cas,t_cas,q_cas,u_cas,v_cas               &
+     ,ug_cas,vg_cas,vitw_cas,du_cas,hu_cas,vu_cas           &
+     ,dv_cas,hv_cas,vv_cas,dt_cas,ht_cas,vt_cas,dtrad_cas   &
+     ,dq_cas,hq_cas,vq_cas,lat_cas,sens_cas,ustar_cas       &
+     ,uw_cas,vw_cas,q1_cas,q2_cas                           &
+     ,ts_prof_cas,plev_prof_cas,t_prof_cas,q_prof_cas       &
+     ,u_prof_cas,v_prof_cas,ug_prof_cas,vg_prof_cas         &
+     ,vitw_prof_cas,du_prof_cas,hu_prof_cas,vu_prof_cas     &
+     ,dv_prof_cas,hv_prof_cas,vv_prof_cas,dt_prof_cas       &
+     ,ht_prof_cas,vt_prof_cas,dtrad_prof_cas,dq_prof_cas    &
+     ,hq_prof_cas,vq_prof_cas,lat_prof_cas,sens_prof_cas    &
+     ,ustar_prof_cas,uw_prof_cas,vw_prof_cas,q1_prof_cas,q2_prof_cas)
+
+
+  implicit none
+
+  !---------------------------------------------------------------------------------------
+  ! Time interpolation of a 2D field to the timestep corresponding to day
+  !
+  ! day: current julian day (e.g. 717538.2)
+  ! day1: first day of the simulation
+  ! nt_cas: total nb of data in the forcing 
+  ! pdt_cas: total time interval (in sec) between 2 forcing data
+  !---------------------------------------------------------------------------------------
+
+  INCLUDE "compar1d.h"
+  INCLUDE "date_cas.h"
+
+  ! inputs:
+  integer annee_ref
+  integer nt_cas,nlev_cas
+  real day, day1,day_cas
+  real ts_cas(nt_cas),ps_cas(nt_cas)
+  real plev_cas(nlev_cas,nt_cas)
+  real t_cas(nlev_cas,nt_cas),q_cas(nlev_cas,nt_cas)
+  real u_cas(nlev_cas,nt_cas),v_cas(nlev_cas,nt_cas)
+  real ug_cas(nlev_cas,nt_cas),vg_cas(nlev_cas,nt_cas)
+  real vitw_cas(nlev_cas,nt_cas)
+  real du_cas(nlev_cas,nt_cas),hu_cas(nlev_cas,nt_cas),vu_cas(nlev_cas,nt_cas)
+  real dv_cas(nlev_cas,nt_cas),hv_cas(nlev_cas,nt_cas),vv_cas(nlev_cas,nt_cas)
+  real dt_cas(nlev_cas,nt_cas),ht_cas(nlev_cas,nt_cas),vt_cas(nlev_cas,nt_cas)
+  real dtrad_cas(nlev_cas,nt_cas)
+  real dq_cas(nlev_cas,nt_cas),hq_cas(nlev_cas,nt_cas),vq_cas(nlev_cas,nt_cas)
+  real lat_cas(nt_cas)
+  real sens_cas(nt_cas)
+  real ustar_cas(nt_cas),uw_cas(nlev_cas,nt_cas),vw_cas(nlev_cas,nt_cas)
+  real q1_cas(nlev_cas,nt_cas),q2_cas(nlev_cas,nt_cas)
+
+  ! outputs:
+  real plev_prof_cas(nlev_cas)
+  real t_prof_cas(nlev_cas),q_prof_cas(nlev_cas)
+  real u_prof_cas(nlev_cas),v_prof_cas(nlev_cas)
+  real ug_prof_cas(nlev_cas),vg_prof_cas(nlev_cas)
+  real vitw_prof_cas(nlev_cas)
+  real du_prof_cas(nlev_cas),hu_prof_cas(nlev_cas),vu_prof_cas(nlev_cas)
+  real dv_prof_cas(nlev_cas),hv_prof_cas(nlev_cas),vv_prof_cas(nlev_cas)
+  real dt_prof_cas(nlev_cas),ht_prof_cas(nlev_cas),vt_prof_cas(nlev_cas)
+  real dtrad_prof_cas(nlev_cas)
+  real dq_prof_cas(nlev_cas),hq_prof_cas(nlev_cas),vq_prof_cas(nlev_cas)
+  real lat_prof_cas,sens_prof_cas,ts_prof_cas,ustar_prof_cas
+  real uw_prof_cas(nlev_cas),vw_prof_cas(nlev_cas),q1_prof_cas(nlev_cas),q2_prof_cas(nlev_cas)
+  ! local:
+  integer it_cas1, it_cas2,k
+  real timeit,time_cas1,time_cas2,frac
+
+
+  print*,'Check time',day1,day_ju_ini_cas,day_deb+1,pdt_cas
+
+  ! On teste si la date du cas AMMA est correcte.
+  ! C est pour memoire car en fait les fichiers .def
+  ! sont censes etre corrects.
+  ! A supprimer a terme (MPL 20150623)
+  !     if ((forcing_type.eq.10).and.(1.eq.0)) then
+  ! Check that initial day of the simulation consistent with AMMA case:
+  !      if (annee_ref.ne.2006) then
+  !       print*,'Pour AMMA, annee_ref doit etre 2006'
+  !       print*,'Changer annee_ref dans run.def'
+  !       stop
+  !      endif
+  !      if (annee_ref.eq.2006 .and. day1.lt.day_cas) then
+  !       print*,'AMMA a debute le 10 juillet 2006',day1,day_cas
+  !       print*,'Changer dayref dans run.def'
+  !       stop
+  !      endif
+  !      if (annee_ref.eq.2006 .and. day1.gt.day_cas+1) then
+  !       print*,'AMMA a fini le 11 juillet'
+  !       print*,'Changer dayref ou nday dans run.def'
+  !       stop
+  !      endif
+  !      endif
+
+  ! Determine timestep relative to the 1st day:
+  !       timeit=(day-day1)*86400.
+  !       if (annee_ref.eq.1992) then
+  !        timeit=(day-day_cas)*86400.
+  !       else
+  !        timeit=(day+61.-1.)*86400. ! 61 days between Nov01 and Dec31 1992
+  !       endif
+  timeit=(day-day_ju_ini_cas)*86400
+  !print *,'day=',day
+  !print *,'day_ju_ini_cas=',day_ju_ini_cas
+  !print *,'pdt_cas=',pdt_cas
+  !print *,'timeit=',timeit
+  !print *,'nt_cas=',nt_cas
+
+  ! Determine the closest observation times:
+  !       it_cas1=INT(timeit/pdt_cas)+1
+  !       it_cas2=it_cas1 + 1
+  !       time_cas1=(it_cas1-1)*pdt_cas
+  !       time_cas2=(it_cas2-1)*pdt_cas
+
+  it_cas1=INT(timeit/pdt_cas)+1
+  IF (it_cas1 .EQ. nt_cas) THEN
+     it_cas2=it_cas1 
+  ELSE
+     it_cas2=it_cas1 + 1
+  ENDIF
+  time_cas1=(it_cas1-1)*pdt_cas
+  time_cas2=(it_cas2-1)*pdt_cas
+  !print *,'it_cas1,it_cas2,time_cas1,time_cas2=',it_cas1,it_cas2,time_cas1,time_cas2
+
+  if (it_cas1 .gt. nt_cas) then
+     write(*,*) 'PB-stop: day, day_ju_ini_cas,it_cas1, it_cas2, timeit: '            &
+          ,day,day_ju_ini_cas,it_cas1,it_cas2,timeit
+     stop
+  endif
+
+  ! time interpolation:
+  IF (it_cas1 .EQ. it_cas2) THEN
+     frac=0.
+  ELSE
+     frac=(time_cas2-timeit)/(time_cas2-time_cas1)
+     frac=max(frac,0.0)
+  ENDIF
+
+  lat_prof_cas = lat_cas(it_cas2)                                       &
+       -frac*(lat_cas(it_cas2)-lat_cas(it_cas1)) 
+  sens_prof_cas = sens_cas(it_cas2)                                     &
+       -frac*(sens_cas(it_cas2)-sens_cas(it_cas1))
+  ts_prof_cas = ts_cas(it_cas2)                                         &
+       -frac*(ts_cas(it_cas2)-ts_cas(it_cas1))
+  ustar_prof_cas = ustar_cas(it_cas2)                                   &
+       -frac*(ustar_cas(it_cas2)-ustar_cas(it_cas1))
+
+  do k=1,nlev_cas
+     plev_prof_cas(k) = plev_cas(k,it_cas2)                               &
+          -frac*(plev_cas(k,it_cas2)-plev_cas(k,it_cas1))
+     t_prof_cas(k) = t_cas(k,it_cas2)                               &
+          -frac*(t_cas(k,it_cas2)-t_cas(k,it_cas1))
+     q_prof_cas(k) = q_cas(k,it_cas2)                               &
+          -frac*(q_cas(k,it_cas2)-q_cas(k,it_cas1))
+     u_prof_cas(k) = u_cas(k,it_cas2)                               &
+          -frac*(u_cas(k,it_cas2)-u_cas(k,it_cas1))
+     v_prof_cas(k) = v_cas(k,it_cas2)                               &
+          -frac*(v_cas(k,it_cas2)-v_cas(k,it_cas1))
+     ug_prof_cas(k) = ug_cas(k,it_cas2)                               &
+          -frac*(ug_cas(k,it_cas2)-ug_cas(k,it_cas1))
+     vg_prof_cas(k) = vg_cas(k,it_cas2)                               &
+          -frac*(vg_cas(k,it_cas2)-vg_cas(k,it_cas1))
+     vitw_prof_cas(k) = vitw_cas(k,it_cas2)                               &
+          -frac*(vitw_cas(k,it_cas2)-vitw_cas(k,it_cas1))
+     du_prof_cas(k) = du_cas(k,it_cas2)                                   &
+          -frac*(du_cas(k,it_cas2)-du_cas(k,it_cas1))
+     hu_prof_cas(k) = hu_cas(k,it_cas2)                                   &
+          -frac*(hu_cas(k,it_cas2)-hu_cas(k,it_cas1))
+     vu_prof_cas(k) = vu_cas(k,it_cas2)                                   &
+          -frac*(vu_cas(k,it_cas2)-vu_cas(k,it_cas1))
+     dv_prof_cas(k) = dv_cas(k,it_cas2)                                   &
+          -frac*(dv_cas(k,it_cas2)-dv_cas(k,it_cas1))
+     hv_prof_cas(k) = hv_cas(k,it_cas2)                                   &
+          -frac*(hv_cas(k,it_cas2)-hv_cas(k,it_cas1))
+     vv_prof_cas(k) = vv_cas(k,it_cas2)                                   &
+          -frac*(vv_cas(k,it_cas2)-vv_cas(k,it_cas1))
+     dt_prof_cas(k) = dt_cas(k,it_cas2)                                   &
+          -frac*(dt_cas(k,it_cas2)-dt_cas(k,it_cas1))
+     ht_prof_cas(k) = ht_cas(k,it_cas2)                                   &
+          -frac*(ht_cas(k,it_cas2)-ht_cas(k,it_cas1))
+     vt_prof_cas(k) = vt_cas(k,it_cas2)                                   &
+          -frac*(vt_cas(k,it_cas2)-vt_cas(k,it_cas1))
+     dtrad_prof_cas(k) = dtrad_cas(k,it_cas2)                                   &
+          -frac*(dtrad_cas(k,it_cas2)-dtrad_cas(k,it_cas1))
+     dq_prof_cas(k) = dq_cas(k,it_cas2)                                   &
+          -frac*(dq_cas(k,it_cas2)-dq_cas(k,it_cas1))
+     hq_prof_cas(k) = hq_cas(k,it_cas2)                                   &
+          -frac*(hq_cas(k,it_cas2)-hq_cas(k,it_cas1))
+     vq_prof_cas(k) = vq_cas(k,it_cas2)                                   &
+          -frac*(vq_cas(k,it_cas2)-vq_cas(k,it_cas1))
+     uw_prof_cas(k) = uw_cas(k,it_cas2)                                   &
+          -frac*(uw_cas(k,it_cas2)-uw_cas(k,it_cas1))
+     vw_prof_cas(k) = vw_cas(k,it_cas2)                                   &
+          -frac*(vw_cas(k,it_cas2)-vw_cas(k,it_cas1))
+     q1_prof_cas(k) = q1_cas(k,it_cas2)                                   &
+          -frac*(q1_cas(k,it_cas2)-q1_cas(k,it_cas1))
+     q2_prof_cas(k) = q2_cas(k,it_cas2)                                   &
+          -frac*(q2_cas(k,it_cas2)-q2_cas(k,it_cas1))
+  enddo
+
+  return
+END SUBROUTINE interp_case_time2
+
+!**********************************************************************************************
+SUBROUTINE interp2_case_time(day,day1,annee_ref                           &
+     !    &         ,year_cas,day_cas,nt_cas,pdt_forc,nlev_cas                         &
+     ,nt_cas,nlev_cas                                                   &
+     ,ts_cas,ps_cas,plev_cas,t_cas,theta_cas,thv_cas,thl_cas            &
+     ,qv_cas,ql_cas,qi_cas,u_cas,v_cas                                  &
+     ,ug_cas,vg_cas,vitw_cas,omega_cas,du_cas,hu_cas,vu_cas             &
+     ,dv_cas,hv_cas,vv_cas,dt_cas,ht_cas,vt_cas,dtrad_cas               &
+     ,dq_cas,hq_cas,vq_cas,dth_cas,hth_cas,vth_cas                      &
+     ,lat_cas,sens_cas,ustar_cas                                        &
+     ,uw_cas,vw_cas,q1_cas,q2_cas,tke_cas                               &
+     !
+     ,ts_prof_cas,plev_prof_cas,t_prof_cas,theta_prof_cas               &
+     ,thv_prof_cas,thl_prof_cas,qv_prof_cas,ql_prof_cas,qi_prof_cas     &
+     ,u_prof_cas,v_prof_cas,ug_prof_cas,vg_prof_cas                     &
+     ,vitw_prof_cas,omega_prof_cas,du_prof_cas,hu_prof_cas,vu_prof_cas  &
+     ,dv_prof_cas,hv_prof_cas,vv_prof_cas,dt_prof_cas                   &
+     ,ht_prof_cas,vt_prof_cas,dtrad_prof_cas,dq_prof_cas                &
+     ,hq_prof_cas,vq_prof_cas,dth_prof_cas,hth_prof_cas,vth_prof_cas    &
+     ,lat_prof_cas,sens_prof_cas                                        &
+     ,ustar_prof_cas,uw_prof_cas,vw_prof_cas,q1_prof_cas,q2_prof_cas,tke_prof_cas)
+
+
+  implicit none
+
+  !---------------------------------------------------------------------------------------
+  ! Time interpolation of a 2D field to the timestep corresponding to day
+  !
+  ! day: current julian day (e.g. 717538.2)
+  ! day1: first day of the simulation
+  ! nt_cas: total nb of data in the forcing 
+  ! pdt_cas: total time interval (in sec) between 2 forcing data
+  !---------------------------------------------------------------------------------------
+
+  INCLUDE "compar1d.h"
+  INCLUDE "date_cas.h"
+
+  ! inputs:
+  integer annee_ref
+  integer nt_cas,nlev_cas
+  real day, day1,day_cas
+  real ts_cas(nt_cas),ps_cas(nt_cas)
+  real plev_cas(nlev_cas,nt_cas)
+  real t_cas(nlev_cas,nt_cas),theta_cas(nlev_cas,nt_cas),thv_cas(nlev_cas,nt_cas),thl_cas(nlev_cas,nt_cas)
+  real qv_cas(nlev_cas,nt_cas),ql_cas(nlev_cas,nt_cas),qi_cas(nlev_cas,nt_cas)
+  real u_cas(nlev_cas,nt_cas),v_cas(nlev_cas,nt_cas)
+  real ug_cas(nlev_cas,nt_cas),vg_cas(nlev_cas,nt_cas)
+  real vitw_cas(nlev_cas,nt_cas),omega_cas(nlev_cas,nt_cas)
+  real du_cas(nlev_cas,nt_cas),hu_cas(nlev_cas,nt_cas),vu_cas(nlev_cas,nt_cas)
+  real dv_cas(nlev_cas,nt_cas),hv_cas(nlev_cas,nt_cas),vv_cas(nlev_cas,nt_cas)
+  real dt_cas(nlev_cas,nt_cas),ht_cas(nlev_cas,nt_cas),vt_cas(nlev_cas,nt_cas)
+  real dth_cas(nlev_cas,nt_cas),hth_cas(nlev_cas,nt_cas),vth_cas(nlev_cas,nt_cas)
+  real dtrad_cas(nlev_cas,nt_cas)
+  real dq_cas(nlev_cas,nt_cas),hq_cas(nlev_cas,nt_cas),vq_cas(nlev_cas,nt_cas)
+  real lat_cas(nt_cas),sens_cas(nt_cas),tke_cas(nt_cas)
+  real ustar_cas(nt_cas),uw_cas(nlev_cas,nt_cas),vw_cas(nlev_cas,nt_cas)
+  real q1_cas(nlev_cas,nt_cas),q2_cas(nlev_cas,nt_cas)
+
+  ! outputs:
+  real plev_prof_cas(nlev_cas)
+  real t_prof_cas(nlev_cas),theta_prof_cas(nlev_cas),thl_prof_cas(nlev_cas),thv_prof_cas(nlev_cas)
+  real qv_prof_cas(nlev_cas),ql_prof_cas(nlev_cas),qi_prof_cas(nlev_cas)
+  real u_prof_cas(nlev_cas),v_prof_cas(nlev_cas)
+  real ug_prof_cas(nlev_cas),vg_prof_cas(nlev_cas)
+  real vitw_prof_cas(nlev_cas),omega_prof_cas(nlev_cas)
+  real du_prof_cas(nlev_cas),hu_prof_cas(nlev_cas),vu_prof_cas(nlev_cas)
+  real dv_prof_cas(nlev_cas),hv_prof_cas(nlev_cas),vv_prof_cas(nlev_cas)
+  real dt_prof_cas(nlev_cas),ht_prof_cas(nlev_cas),vt_prof_cas(nlev_cas)
+  real dth_prof_cas(nlev_cas),hth_prof_cas(nlev_cas),vth_prof_cas(nlev_cas)
+  real dtrad_prof_cas(nlev_cas)
+  real dq_prof_cas(nlev_cas),hq_prof_cas(nlev_cas),vq_prof_cas(nlev_cas)
+  real lat_prof_cas,sens_prof_cas,tke_prof_cas,ts_prof_cas,ustar_prof_cas
+  real uw_prof_cas(nlev_cas),vw_prof_cas(nlev_cas),q1_prof_cas(nlev_cas),q2_prof_cas(nlev_cas)
+  ! local:
+  integer it_cas1, it_cas2,k
+  real timeit,time_cas1,time_cas2,frac
+
+
+  print*,'Check time',day1,day_ju_ini_cas,day_deb+1,pdt_cas
+  !       do k=1,nlev_cas
+  !       print*,'debut de interp2_case_time, plev_cas=',k,plev_cas(k,1)
+  !       enddo
+
+  ! On teste si la date du cas AMMA est correcte.
+  ! C est pour memoire car en fait les fichiers .def
+  ! sont censes etre corrects.
+  ! A supprimer a terme (MPL 20150623)
+  !     if ((forcing_type.eq.10).and.(1.eq.0)) then
+  ! Check that initial day of the simulation consistent with AMMA case:
+  !      if (annee_ref.ne.2006) then
+  !       print*,'Pour AMMA, annee_ref doit etre 2006'
+  !       print*,'Changer annee_ref dans run.def'
+  !       stop
+  !      endif
+  !      if (annee_ref.eq.2006 .and. day1.lt.day_cas) then
+  !       print*,'AMMA a debute le 10 juillet 2006',day1,day_cas
+  !       print*,'Changer dayref dans run.def'
+  !       stop
+  !      endif
+  !      if (annee_ref.eq.2006 .and. day1.gt.day_cas+1) then
+  !       print*,'AMMA a fini le 11 juillet'
+  !       print*,'Changer dayref ou nday dans run.def'
+  !       stop
+  !      endif
+  !      endif
+
+  ! Determine timestep relative to the 1st day:
+  !       timeit=(day-day1)*86400.
+  !       if (annee_ref.eq.1992) then
+  !        timeit=(day-day_cas)*86400.
+  !       else
+  !        timeit=(day+61.-1.)*86400. ! 61 days between Nov01 and Dec31 1992
+  !       endif
+  timeit=(day-day_ju_ini_cas)*86400
+  !print *,'day=',day
+  !print *,'day_ju_ini_cas=',day_ju_ini_cas
+  !print *,'pdt_cas=',pdt_cas
+  !print *,'timeit=',timeit
+  !print *,'nt_cas=',nt_cas
+
+  ! Determine the closest observation times:
+  !       it_cas1=INT(timeit/pdt_cas)+1
+  !       it_cas2=it_cas1 + 1
+  !       time_cas1=(it_cas1-1)*pdt_cas
+  !       time_cas2=(it_cas2-1)*pdt_cas
+
+  it_cas1=INT(timeit/pdt_cas)+1
+  IF (it_cas1 .EQ. nt_cas) THEN
+     it_cas2=it_cas1 
+  ELSE
+     it_cas2=it_cas1 + 1
+  ENDIF
+  time_cas1=(it_cas1-1)*pdt_cas
+  time_cas2=(it_cas2-1)*pdt_cas
+  !print *,'timeit,pdt_cas,nt_cas=',timeit,pdt_cas,nt_cas
+  !print *,'it_cas1,it_cas2,time_cas1,time_cas2=',it_cas1,it_cas2,time_cas1,time_cas2
+
+  if (it_cas1 .gt. nt_cas) then 
+     write(*,*) 'PB-stop: day, day_ju_ini_cas,it_cas1, it_cas2, timeit: '            &
+          ,day,day_ju_ini_cas,it_cas1,it_cas2,timeit
+     stop
+  endif
+
+  ! time interpolation:
+  IF (it_cas1 .EQ. it_cas2) THEN
+     frac=0.
+  ELSE
+     frac=(time_cas2-timeit)/(time_cas2-time_cas1)
+     frac=max(frac,0.0)
+  ENDIF
+
+  lat_prof_cas = lat_cas(it_cas2)                                   &
+       -frac*(lat_cas(it_cas2)-lat_cas(it_cas1)) 
+  sens_prof_cas = sens_cas(it_cas2)                                 &
+       -frac*(sens_cas(it_cas2)-sens_cas(it_cas1))
+  tke_prof_cas = tke_cas(it_cas2)                                   &
+       -frac*(tke_cas(it_cas2)-tke_cas(it_cas1))
+  ts_prof_cas = ts_cas(it_cas2)                                     &
+       -frac*(ts_cas(it_cas2)-ts_cas(it_cas1))
+  ustar_prof_cas = ustar_cas(it_cas2)                               &
+       -frac*(ustar_cas(it_cas2)-ustar_cas(it_cas1))
+
+  do k=1,nlev_cas
+     plev_prof_cas(k) = plev_cas(k,it_cas2)                           &     
+          -frac*(plev_cas(k,it_cas2)-plev_cas(k,it_cas1))
+     t_prof_cas(k) = t_cas(k,it_cas2)                                 &        
+          -frac*(t_cas(k,it_cas2)-t_cas(k,it_cas1))
+     !print *,'k,frac,plev_cas1,plev_cas2=',k,frac,plev_cas(k,it_cas1),plev_cas(k,it_cas2)
+     theta_prof_cas(k) = theta_cas(k,it_cas2)                         &                      
+          -frac*(theta_cas(k,it_cas2)-theta_cas(k,it_cas1))
+     thv_prof_cas(k) = thv_cas(k,it_cas2)                             &          
+          -frac*(thv_cas(k,it_cas2)-thv_cas(k,it_cas1))
+     thl_prof_cas(k) = thl_cas(k,it_cas2)                             &              
+          -frac*(thl_cas(k,it_cas2)-thl_cas(k,it_cas1))
+     qv_prof_cas(k) = qv_cas(k,it_cas2)                               &
+          -frac*(qv_cas(k,it_cas2)-qv_cas(k,it_cas1))
+     ql_prof_cas(k) = ql_cas(k,it_cas2)                               &
+          -frac*(ql_cas(k,it_cas2)-ql_cas(k,it_cas1))
+     qi_prof_cas(k) = qi_cas(k,it_cas2)                               &
+          -frac*(qi_cas(k,it_cas2)-qi_cas(k,it_cas1))
+     u_prof_cas(k) = u_cas(k,it_cas2)                                 &
+          -frac*(u_cas(k,it_cas2)-u_cas(k,it_cas1))
+     v_prof_cas(k) = v_cas(k,it_cas2)                                 &
+          -frac*(v_cas(k,it_cas2)-v_cas(k,it_cas1))
+     ug_prof_cas(k) = ug_cas(k,it_cas2)                               &
+          -frac*(ug_cas(k,it_cas2)-ug_cas(k,it_cas1))
+     vg_prof_cas(k) = vg_cas(k,it_cas2)                               &
+          -frac*(vg_cas(k,it_cas2)-vg_cas(k,it_cas1))
+     vitw_prof_cas(k) = vitw_cas(k,it_cas2)                           &
+          -frac*(vitw_cas(k,it_cas2)-vitw_cas(k,it_cas1))
+     omega_prof_cas(k) = omega_cas(k,it_cas2)                         &
+          -frac*(omega_cas(k,it_cas2)-omega_cas(k,it_cas1))
+     du_prof_cas(k) = du_cas(k,it_cas2)                               &
+          -frac*(du_cas(k,it_cas2)-du_cas(k,it_cas1))
+     hu_prof_cas(k) = hu_cas(k,it_cas2)                               &
+          -frac*(hu_cas(k,it_cas2)-hu_cas(k,it_cas1))
+     vu_prof_cas(k) = vu_cas(k,it_cas2)                               &
+          -frac*(vu_cas(k,it_cas2)-vu_cas(k,it_cas1))
+     dv_prof_cas(k) = dv_cas(k,it_cas2)                               &
+          -frac*(dv_cas(k,it_cas2)-dv_cas(k,it_cas1))
+     hv_prof_cas(k) = hv_cas(k,it_cas2)                               &
+          -frac*(hv_cas(k,it_cas2)-hv_cas(k,it_cas1))
+     vv_prof_cas(k) = vv_cas(k,it_cas2)                               &
+          -frac*(vv_cas(k,it_cas2)-vv_cas(k,it_cas1))
+     dt_prof_cas(k) = dt_cas(k,it_cas2)                               &
+          -frac*(dt_cas(k,it_cas2)-dt_cas(k,it_cas1))
+     ht_prof_cas(k) = ht_cas(k,it_cas2)                               &
+          -frac*(ht_cas(k,it_cas2)-ht_cas(k,it_cas1))
+     vt_prof_cas(k) = vt_cas(k,it_cas2)                               &
+          -frac*(vt_cas(k,it_cas2)-vt_cas(k,it_cas1))
+     dth_prof_cas(k) = dth_cas(k,it_cas2)                             &
+          -frac*(dth_cas(k,it_cas2)-dth_cas(k,it_cas1))
+     hth_prof_cas(k) = hth_cas(k,it_cas2)                             &
+          -frac*(hth_cas(k,it_cas2)-hth_cas(k,it_cas1))
+     vth_prof_cas(k) = vth_cas(k,it_cas2)                             &
+          -frac*(vth_cas(k,it_cas2)-vth_cas(k,it_cas1))
+     dtrad_prof_cas(k) = dtrad_cas(k,it_cas2)                         &
+          -frac*(dtrad_cas(k,it_cas2)-dtrad_cas(k,it_cas1))
+     dq_prof_cas(k) = dq_cas(k,it_cas2)                               &
+          -frac*(dq_cas(k,it_cas2)-dq_cas(k,it_cas1))
+     hq_prof_cas(k) = hq_cas(k,it_cas2)                               &
+          -frac*(hq_cas(k,it_cas2)-hq_cas(k,it_cas1))
+     vq_prof_cas(k) = vq_cas(k,it_cas2)                               &
+          -frac*(vq_cas(k,it_cas2)-vq_cas(k,it_cas1))
+     uw_prof_cas(k) = uw_cas(k,it_cas2)                                &
+          -frac*(uw_cas(k,it_cas2)-uw_cas(k,it_cas1))
+     vw_prof_cas(k) = vw_cas(k,it_cas2)                                &
+          -frac*(vw_cas(k,it_cas2)-vw_cas(k,it_cas1))
+     q1_prof_cas(k) = q1_cas(k,it_cas2)                                &
+          -frac*(q1_cas(k,it_cas2)-q1_cas(k,it_cas1))
+     q2_prof_cas(k) = q2_cas(k,it_cas2)                                &
+          -frac*(q2_cas(k,it_cas2)-q2_cas(k,it_cas1))
+  enddo
+
+  return
+END SUBROUTINE interp2_case_time
+
+!**********************************************************************************************
+
Index: DZ6/trunk/libf/phylmd/dyn1d/mod_1D_cases_read_std.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/dyn1d/mod_1D_cases_read_std.F90	(revision 5267)
+++ 	(revision )
@@ -1,1219 +1,0 @@
-!
-! $Id: mod_1D_cases_read.F90 2373 2015-10-13 17:28:01Z jyg $
-!
-MODULE mod_1D_cases_read_std
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-  !Declarations specifiques au cas standard
-  character*80 :: fich_cas
-  ! Discr?tisation 
-  integer nlev_cas, nt_cas
-
-
-  !profils environnementaux
-  real, allocatable::  plev_cas(:,:),plevh_cas(:)
-  real, allocatable::  ap_cas(:),bp_cas(:)
-
-  real, allocatable::  z_cas(:,:),zh_cas(:)
-  real, allocatable::  t_cas(:,:),q_cas(:,:),qv_cas(:,:),ql_cas(:,:),qi_cas(:,:),rh_cas(:,:)
-  real, allocatable::  th_cas(:,:),thv_cas(:,:),thl_cas(:,:),rv_cas(:,:)
-  real, allocatable::  u_cas(:,:),v_cas(:,:),vitw_cas(:,:),omega_cas(:,:),tke_cas(:,:)
-
-  !forcing
-  real, allocatable::  ht_cas(:,:),vt_cas(:,:),dt_cas(:,:),dtrad_cas(:,:)
-  real, allocatable::  hth_cas(:,:),vth_cas(:,:),dth_cas(:,:)
-  real, allocatable::  hq_cas(:,:),vq_cas(:,:),dq_cas(:,:)
-  real, allocatable::  hr_cas(:,:),vr_cas(:,:),dr_cas(:,:)
-  real, allocatable::  hu_cas(:,:),vu_cas(:,:),du_cas(:,:)
-  real, allocatable::  hv_cas(:,:),vv_cas(:,:),dv_cas(:,:)
-  real, allocatable::  ug_cas(:,:),vg_cas(:,:)
-  real, allocatable::  temp_nudg_cas(:,:),qv_nudg_cas(:,:),u_nudg_cas(:,:),v_nudg_cas(:,:)
-  real, allocatable::  invtau_temp_nudg_cas(:,:),invtau_qv_nudg_cas(:,:),invtau_u_nudg_cas(:,:),invtau_v_nudg_cas(:,:)
-  real, allocatable::  lat_cas(:),sens_cas(:),tskin_cas(:),ts_cas(:),ps_cas(:),ustar_cas(:)
-  real, allocatable::  uw_cas(:,:),vw_cas(:,:),q1_cas(:,:),q2_cas(:,:),tkes_cas(:)
-
-  !champs interpoles
-  real, allocatable::  plev_prof_cas(:)
-  real, allocatable::  t_prof_cas(:)
-  real, allocatable::  theta_prof_cas(:)
-  real, allocatable::  thl_prof_cas(:)
-  real, allocatable::  thv_prof_cas(:)
-  real, allocatable::  q_prof_cas(:)
-  real, allocatable::  qv_prof_cas(:)
-  real, allocatable::  ql_prof_cas(:)
-  real, allocatable::  qi_prof_cas(:)
-  real, allocatable::  rh_prof_cas(:)
-  real, allocatable::  rv_prof_cas(:)
-  real, allocatable::  u_prof_cas(:)
-  real, allocatable::  v_prof_cas(:)        
-  real, allocatable::  vitw_prof_cas(:)
-  real, allocatable::  omega_prof_cas(:)
-  real, allocatable::  tke_prof_cas(:)
-  real, allocatable::  ug_prof_cas(:)
-  real, allocatable::  vg_prof_cas(:)
-  real, allocatable::  temp_nudg_prof_cas(:),qv_nudg_prof_cas(:),u_nudg_prof_cas(:),v_nudg_prof_cas(:)
-  real, allocatable::  invtau_temp_nudg_prof_cas(:),invtau_qv_nudg_prof_cas(:),invtau_u_nudg_prof_cas(:),invtau_v_nudg_prof_cas(:)
-
-  real, allocatable::  ht_prof_cas(:)
-  real, allocatable::  hth_prof_cas(:)
-  real, allocatable::  hq_prof_cas(:)
-  real, allocatable::  vt_prof_cas(:)
-  real, allocatable::  vth_prof_cas(:)
-  real, allocatable::  vq_prof_cas(:)
-  real, allocatable::  dt_prof_cas(:)
-  real, allocatable::  dth_prof_cas(:)
-  real, allocatable::  dtrad_prof_cas(:)
-  real, allocatable::  dq_prof_cas(:)
-  real, allocatable::  hu_prof_cas(:)
-  real, allocatable::  hv_prof_cas(:)
-  real, allocatable::  vu_prof_cas(:)
-  real, allocatable::  vv_prof_cas(:)
-  real, allocatable::  du_prof_cas(:)
-  real, allocatable::  dv_prof_cas(:)
-  real, allocatable::  uw_prof_cas(:)
-  real, allocatable::  vw_prof_cas(:)
-  real, allocatable::  q1_prof_cas(:)
-  real, allocatable::  q2_prof_cas(:)
-
-
-  real o3_cas,lat_prof_cas,sens_prof_cas,ts_prof_cas,tskin_prof_cas,ps_prof_cas,ustar_prof_cas,tkes_prof_cas
-  real orog_cas,albedo_cas,emiss_cas,q_skin_cas,mom_rough,heat_rough,rugos_cas,sand_cas,clay_cas
-
-
-
-CONTAINS
-
-
-  !**********************************************************************************************
-  SUBROUTINE read_SCM_cas
-    use netcdf, only: nf90_get_var
-    implicit none
-
-    INCLUDE "netcdf.inc"
-    INCLUDE "date_cas.h"
-
-    INTEGER nid,rid,ierr
-    INTEGER ii,jj,timeid
-    REAL, ALLOCATABLE :: time_val(:)
-
-    fich_cas='cas.nc'
-    print*,'fich_cas ',fich_cas
-    ierr = NF_OPEN(fich_cas,NF_NOWRITE,nid)
-    print*,'fich_cas,NF_NOWRITE,nid ',fich_cas,NF_NOWRITE,nid
-    if (ierr.NE.NF_NOERR) then
-       write(*,*) 'ERROR: GROS Pb opening forcings nc file '
-       write(*,*) NF_STRERROR(ierr)
-       stop ""
-    endif
-    !.......................................................................
-    ierr=NF_INQ_DIMID(nid,'lat',rid)
-    IF (ierr.NE.NF_NOERR) THEN
-       print*, 'Oh probleme lecture dimension lat'
-    ENDIF
-    ierr=NF_INQ_DIMLEN(nid,rid,ii)
-    print*,'OK1 read_SCM_cas: nid,rid,lat',nid,rid,ii
-    !.......................................................................
-    ierr=NF_INQ_DIMID(nid,'lon',rid)
-    IF (ierr.NE.NF_NOERR) THEN
-       print*, 'Oh probleme lecture dimension lon'
-    ENDIF
-    ierr=NF_INQ_DIMLEN(nid,rid,jj)
-    print*,'OK2 read_SCM_cas: nid,rid,lat',nid,rid,jj
-    !.......................................................................
-    ierr=NF_INQ_DIMID(nid,'lev',rid)
-    IF (ierr.NE.NF_NOERR) THEN
-       print*, 'Oh probleme lecture dimension nlev'
-    ENDIF
-    ierr=NF_INQ_DIMLEN(nid,rid,nlev_cas)
-    print*,'OK3 read_SCM_cas: nid,rid,nlev_cas',nid,rid,nlev_cas
-    IF ( .NOT. ( nlev_cas > 10 .AND. nlev_cas < 200000 )) THEN
-       print*,'Valeur de nlev_cas peu probable'
-       STOP
-    ENDIF
-    !.......................................................................
-    ierr=NF_INQ_DIMID(nid,'time',rid)
-    nt_cas=0
-    IF (ierr.NE.NF_NOERR) THEN
-       stop 'Oh probleme lecture dimension time'
-    ENDIF
-    ierr=NF_INQ_DIMLEN(nid,rid,nt_cas)
-    print*,'OK4 read_SCM_cas: nid,rid,nt_cas',nid,rid,nt_cas
-    ! Lecture de l'axe des temps
-    print*,'LECTURE DU TEMPS'
-    ierr=NF_INQ_VARID(nid,'time',timeid)
-    if(ierr/=NF_NOERR) then
-       print *,'Variable time manquante dans cas.nc:'
-       ierr=NF_NOERR
-    else
-       allocate(time_val(nt_cas))
-       ierr = NF90_GET_VAR(nid,timeid,time_val)
-       if(ierr/=NF_NOERR) then
-          print *,'A Pb a la lecture de time cas.nc: '
-       endif
-    endif
-    IF (nt_cas>1) THEN
-       pdt_cas=time_val(2)-time_val(1)
-    ELSE
-       pdt_cas=0.
-    ENDIF
-
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-    !profils moyens:
-    allocate(plev_cas(nlev_cas,nt_cas),plevh_cas(nlev_cas+1))        
-    allocate(z_cas(nlev_cas,nt_cas),zh_cas(nlev_cas+1))
-    allocate(ap_cas(nlev_cas+1),bp_cas(nlev_cas+1))
-    allocate(t_cas(nlev_cas,nt_cas),q_cas(nlev_cas,nt_cas),qv_cas(nlev_cas,nt_cas),ql_cas(nlev_cas,nt_cas), &
-         qi_cas(nlev_cas,nt_cas),rh_cas(nlev_cas,nt_cas))
-    allocate(th_cas(nlev_cas,nt_cas),thl_cas(nlev_cas,nt_cas),thv_cas(nlev_cas,nt_cas),rv_cas(nlev_cas,nt_cas))
-    allocate(u_cas(nlev_cas,nt_cas),v_cas(nlev_cas,nt_cas),vitw_cas(nlev_cas,nt_cas),omega_cas(nlev_cas,nt_cas))
-    allocate(tke_cas(nlev_cas,nt_cas))
-    !forcing
-    allocate(ht_cas(nlev_cas,nt_cas),vt_cas(nlev_cas,nt_cas),dt_cas(nlev_cas,nt_cas),dtrad_cas(nlev_cas,nt_cas))
-    allocate(hq_cas(nlev_cas,nt_cas),vq_cas(nlev_cas,nt_cas),dq_cas(nlev_cas,nt_cas))
-    allocate(hth_cas(nlev_cas,nt_cas),vth_cas(nlev_cas,nt_cas),dth_cas(nlev_cas,nt_cas))
-    allocate(hr_cas(nlev_cas,nt_cas),vr_cas(nlev_cas,nt_cas),dr_cas(nlev_cas,nt_cas))
-    allocate(hu_cas(nlev_cas,nt_cas),vu_cas(nlev_cas,nt_cas),du_cas(nlev_cas,nt_cas))
-    allocate(hv_cas(nlev_cas,nt_cas),vv_cas(nlev_cas,nt_cas),dv_cas(nlev_cas,nt_cas))
-    allocate(ug_cas(nlev_cas,nt_cas),vg_cas(nlev_cas,nt_cas))
-    allocate(temp_nudg_cas(nlev_cas,nt_cas),qv_nudg_cas(nlev_cas,nt_cas))
-    allocate(u_nudg_cas(nlev_cas,nt_cas),v_nudg_cas(nlev_cas,nt_cas))
-    allocate(invtau_temp_nudg_cas(nlev_cas,nt_cas),invtau_qv_nudg_cas(nlev_cas,nt_cas))
-    allocate(invtau_u_nudg_cas(nlev_cas,nt_cas),invtau_v_nudg_cas(nlev_cas,nt_cas))
-    allocate(lat_cas(nt_cas),sens_cas(nt_cas),ts_cas(nt_cas),tskin_cas(nt_cas),ps_cas(nt_cas),ustar_cas(nt_cas),tkes_cas(nt_cas))
-    allocate(uw_cas(nlev_cas,nt_cas),vw_cas(nlev_cas,nt_cas),q1_cas(nlev_cas,nt_cas),q2_cas(nlev_cas,nt_cas))
-
-
-
-    !champs interpoles
-    allocate(plev_prof_cas(nlev_cas))
-    allocate(t_prof_cas(nlev_cas))
-    allocate(theta_prof_cas(nlev_cas))
-    allocate(thl_prof_cas(nlev_cas))
-    allocate(thv_prof_cas(nlev_cas))
-    allocate(q_prof_cas(nlev_cas))
-    allocate(qv_prof_cas(nlev_cas))
-    allocate(ql_prof_cas(nlev_cas))
-    allocate(qi_prof_cas(nlev_cas))
-    allocate(rh_prof_cas(nlev_cas))
-    allocate(rv_prof_cas(nlev_cas))
-    allocate(u_prof_cas(nlev_cas))
-    allocate(v_prof_cas(nlev_cas))
-    allocate(vitw_prof_cas(nlev_cas))
-    allocate(omega_prof_cas(nlev_cas))
-    allocate(tke_prof_cas(nlev_cas))
-    allocate(ug_prof_cas(nlev_cas))
-    allocate(vg_prof_cas(nlev_cas))
-    allocate(temp_nudg_prof_cas(nlev_cas),qv_nudg_prof_cas(nlev_cas))
-    allocate(u_nudg_prof_cas(nlev_cas),v_nudg_prof_cas(nlev_cas))
-    allocate(invtau_temp_nudg_prof_cas(nlev_cas),invtau_qv_nudg_prof_cas(nlev_cas))
-    allocate(invtau_u_nudg_prof_cas(nlev_cas),invtau_v_nudg_prof_cas(nlev_cas))
-    allocate(ht_prof_cas(nlev_cas))
-    allocate(hth_prof_cas(nlev_cas))
-    allocate(hq_prof_cas(nlev_cas))
-    allocate(hu_prof_cas(nlev_cas))
-    allocate(hv_prof_cas(nlev_cas))
-    allocate(vt_prof_cas(nlev_cas))
-    allocate(vth_prof_cas(nlev_cas))
-    allocate(vq_prof_cas(nlev_cas))
-    allocate(vu_prof_cas(nlev_cas))
-    allocate(vv_prof_cas(nlev_cas))
-    allocate(dt_prof_cas(nlev_cas))
-    allocate(dth_prof_cas(nlev_cas))
-    allocate(dtrad_prof_cas(nlev_cas))
-    allocate(dq_prof_cas(nlev_cas))
-    allocate(du_prof_cas(nlev_cas))
-    allocate(dv_prof_cas(nlev_cas))
-    allocate(uw_prof_cas(nlev_cas))
-    allocate(vw_prof_cas(nlev_cas))
-    allocate(q1_prof_cas(nlev_cas))
-    allocate(q2_prof_cas(nlev_cas))
-
-    print*,'Allocations OK'
-    CALL read_SCM (nid,nlev_cas,nt_cas,                                                                     &
-         ap_cas,bp_cas,z_cas,plev_cas,zh_cas,plevh_cas,t_cas,th_cas,thv_cas,thl_cas,qv_cas,                   &
-         ql_cas,qi_cas,rh_cas,rv_cas,u_cas,v_cas,vitw_cas,omega_cas,tke_cas,ug_cas,vg_cas,                            &
-         temp_nudg_cas,qv_nudg_cas,u_nudg_cas,v_nudg_cas,                                                     &
-         invtau_temp_nudg_cas,invtau_qv_nudg_cas,invtau_u_nudg_cas,invtau_v_nudg_cas,                         &
-         du_cas,hu_cas,vu_cas,                                                                                &
-         dv_cas,hv_cas,vv_cas,dt_cas,ht_cas,vt_cas,dq_cas,hq_cas,vq_cas,dth_cas,hth_cas,vth_cas,               &
-         dr_cas,hr_cas,vr_cas,dtrad_cas,sens_cas,lat_cas,ts_cas,tskin_cas,ps_cas,ustar_cas,tkes_cas,            &
-         uw_cas,vw_cas,q1_cas,q2_cas,orog_cas,albedo_cas,emiss_cas,q_skin_cas,mom_rough,heat_rough, &
-         o3_cas,rugos_cas,clay_cas,sand_cas)
-    print*,'read_SCM cas OK'
-    do ii=1,nlev_cas
-       print*,'apres read_SCM_cas, plev_cas=',ii,plev_cas(ii,1)
-       !print*,'apres read_SCM, plev_cas=',ii,omega_cas(ii,nt_cas/2+1)
-    enddo
-
-
-  END SUBROUTINE read_SCM_cas
-
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-  SUBROUTINE deallocate2_1D_cases
-    !profils environnementaux:
-    deallocate(plev_cas,plevh_cas)
-
-    deallocate(z_cas,zh_cas)
-    deallocate(ap_cas,bp_cas)
-    deallocate(t_cas,q_cas,qv_cas,ql_cas,qi_cas,rh_cas)
-    deallocate(th_cas,thl_cas,thv_cas,rv_cas)
-    deallocate(u_cas,v_cas,vitw_cas,omega_cas,tke_cas)
-
-    !forcing
-    deallocate(ht_cas,vt_cas,dt_cas,dtrad_cas)
-    deallocate(hq_cas,vq_cas,dq_cas)
-    deallocate(hth_cas,vth_cas,dth_cas)
-    deallocate(hr_cas,vr_cas,dr_cas)
-    deallocate(hu_cas,vu_cas,du_cas)
-    deallocate(hv_cas,vv_cas,dv_cas)
-    deallocate(ug_cas)
-    deallocate(vg_cas)
-    deallocate(lat_cas,sens_cas,tskin_cas,ts_cas,ps_cas,ustar_cas,tkes_cas,uw_cas,vw_cas,q1_cas,q2_cas)
-
-    !champs interpoles
-    deallocate(plev_prof_cas)
-    deallocate(t_prof_cas)
-    deallocate(theta_prof_cas)
-    deallocate(thl_prof_cas)
-    deallocate(thv_prof_cas)
-    deallocate(q_prof_cas)
-    deallocate(qv_prof_cas)
-    deallocate(ql_prof_cas)
-    deallocate(qi_prof_cas)
-    deallocate(rh_prof_cas)
-    deallocate(rv_prof_cas)
-    deallocate(u_prof_cas)
-    deallocate(v_prof_cas)
-    deallocate(vitw_prof_cas)
-    deallocate(omega_prof_cas)
-    deallocate(tke_prof_cas)
-    deallocate(ug_prof_cas)
-    deallocate(vg_prof_cas)
-    deallocate(temp_nudg_prof_cas,qv_nudg_prof_cas,u_nudg_prof_cas,v_nudg_prof_cas)
-    deallocate(invtau_temp_nudg_prof_cas,invtau_qv_nudg_prof_cas,invtau_u_nudg_prof_cas,invtau_v_nudg_prof_cas)
-    deallocate(ht_prof_cas)
-    deallocate(hq_prof_cas)
-    deallocate(hu_prof_cas)
-    deallocate(hv_prof_cas)
-    deallocate(vt_prof_cas)
-    deallocate(vq_prof_cas)
-    deallocate(vu_prof_cas)
-    deallocate(vv_prof_cas)
-    deallocate(dt_prof_cas)
-    deallocate(dtrad_prof_cas)
-    deallocate(dq_prof_cas)
-    deallocate(du_prof_cas)
-    deallocate(dv_prof_cas)
-    deallocate(t_prof_cas)
-    deallocate(u_prof_cas)
-    deallocate(v_prof_cas)
-    deallocate(uw_prof_cas)
-    deallocate(vw_prof_cas)
-    deallocate(q1_prof_cas)
-    deallocate(q2_prof_cas)
-
-  END SUBROUTINE deallocate2_1D_cases
-
-
-  !=====================================================================
-  SUBROUTINE read_SCM(nid,nlevel,ntime,                                       &
-       ap,bp,zz,pp,zzh,pph,temp,theta,thv,thl,qv,ql,qi,rh,rv,u,v,vitw,omega,tke,ug,vg,&
-       temp_nudg,qv_nudg,u_nudg,v_nudg,                                        &
-       invtau_temp_nudg,invtau_qv_nudg,invtau_u_nudg,invtau_v_nudg,             &
-       du,hu,vu,dv,hv,vv,dt,ht,vt,dq,hq,vq,                                    &
-       dth,hth,vth,dr,hr,vr,dtrad,sens,flat,ts,tskin,ps,ustar,tkes,uw,vw,q1,q2,       &
-       orog_cas,albedo_cas,emiss_cas,q_skin_cas,mom_rough,          &
-       heat_rough,o3_cas,rugos_cas,clay_cas,sand_cas)
-
-    !program reading forcing of the case study
-    use netcdf, only: nf90_get_var
-    implicit none
-    INCLUDE "netcdf.inc"
-    INCLUDE "compar1d.h"
-
-    integer ntime,nlevel,k,t
-
-    real ap(nlevel+1),bp(nlevel+1)
-    real zz(nlevel,ntime),zzh(nlevel+1)
-    real pp(nlevel,ntime),pph(nlevel+1)
-    !profils initiaux
-    real temp0(nlevel),qv0(nlevel),ql0(nlevel),qi0(nlevel),u0(nlevel),v0(nlevel),tke0(nlevel)
-    real pp0(nlevel)    
-    real temp(nlevel,ntime),qv(nlevel,ntime),ql(nlevel,ntime),qi(nlevel,ntime),rh(nlevel,ntime)
-    real theta(nlevel,ntime),thv(nlevel,ntime),thl(nlevel,ntime),rv(nlevel,ntime)
-    real u(nlevel,ntime),v(nlevel,ntime),tkes(ntime)
-    real temp_nudg(nlevel,ntime),qv_nudg(nlevel,ntime),u_nudg(nlevel,ntime),v_nudg(nlevel,ntime)
-    real invtau_temp_nudg(nlevel,ntime),invtau_qv_nudg(nlevel,ntime),invtau_u_nudg(nlevel,ntime),invtau_v_nudg(nlevel,ntime)
-    real ug(nlevel,ntime),vg(nlevel,ntime)
-    real vitw(nlevel,ntime),omega(nlevel,ntime),tke(nlevel,ntime)
-    real du(nlevel,ntime),hu(nlevel,ntime),vu(nlevel,ntime)
-    real dv(nlevel,ntime),hv(nlevel,ntime),vv(nlevel,ntime)
-    real dt(nlevel,ntime),ht(nlevel,ntime),vt(nlevel,ntime)
-    real dtrad(nlevel,ntime)
-    real dq(nlevel,ntime),hq(nlevel,ntime),vq(nlevel,ntime)
-    real dth(nlevel,ntime),hth(nlevel,ntime),vth(nlevel,ntime),hthl(nlevel,ntime)
-    real dr(nlevel,ntime),hr(nlevel,ntime),vr(nlevel,ntime)
-    real flat(ntime),sens(ntime),ustar(ntime)
-    real uw(nlevel,ntime),vw(nlevel,ntime),q1(nlevel,ntime),q2(nlevel,ntime)
-    real ts(ntime),tskin(ntime),ps(ntime)
-    real orog_cas,albedo_cas,emiss_cas,q_skin_cas,mom_rough,heat_rough,o3_cas,rugos_cas,clay_cas,sand_cas
-    real apbp(nlevel+1),resul(nlevel,ntime),resul1(nlevel),resul2(ntime),resul3
-
-
-    integer nid, ierr,ierr1,ierr2,rid,i,int_test
-    integer nbvar3d
-    parameter(nbvar3d=78)
-    integer var3didin(nbvar3d),missing_var(nbvar3d)
-    character*13 name_var(1:nbvar3d)
-
-
-    !      data name_var/ &
-    !     ! coordonnees pression (n+1 niveaux) #4
-    !     & 'coor_par_a','coor_par_b','height_h','pressure_h',& ! #1-#4
-    !     ! coordonnees pression (n niveaux) #8
-    !     &'temp','qv','ql','qi','u','v','tke','pressure',& ! #5-#12
-    !     ! coordonnees pression + temps #42
-    !     &'w','omega','ug','vg','uadv','uadvh','uadvv','vadv','vadvh','vadvv','temp_adv','tadvh','tadvv',& !  #13 - #25
-    !     &'qv_adv','qvadvh','qvadvv','thadv','thadvh','thadvv','thladvh',                             & ! #26 - #32
-    !     & 'radv','radvh','radvv','radcool','q1','q2','ustress','vstress',                           & ! #33 - #40
-    !     & 'rh','temp_nudging','qv_nudging','u_nudging','v_nudging',                                       & ! #41-45
-    !     &'height_f','pressure_forc','tempt','theta','thv','thl','qvt','qlt','qit','rv','ut','vt',   & ! #46-58
-    !     ! coordonnees temps #12
-    !     &'tkes','sfc_sens_flx','sfc_lat_flx','ts','ps','ustar',&
-    !     &'orog','albedo','emiss','t_skin','q_skin','mom_rough','heat_rough',&
-    !     ! scalaires #4
-    !     &'o3','rugos','clay','sand'/
-
-
-
-    data name_var/ &
-                                ! coordonnees pression (n+1 niveaux) #4
-         'coor_par_a','coor_par_b','zf','pressure_h',& ! #1-#4
-                                ! coordonnees pression (n niveaux) #8
-         'ta','qv','ql','qi','ua','va','tke','pa',& ! #5-#12
-                                ! coordonnees pression + temps #46
-         'wa','wap','ug','vg','tnua_adv','tnua_advh','tnua_advv','tnva_adv','tnva_advh','tnva_advv','tnta_adv','tnta_advh',& !  #13 - #25
-         'tnta_advv','tnqv_adv','tnqv_advh','tnqv_advv','thadv','thadvh','thadvv','thladvh',                             & ! #26 - #32
-         'radv','radvh','radvv','tnta_rad','q1','q2','ustress','vstress',                           & ! #33 - #40
-         'rh','ta_nud','qv_nud','ua_nud','va_nud',                                       & ! #41-45
-         'zh_forc','pa_forc','tat','thetat','thetavt','thetalt','qvt','qlt','qit','rvt','uat','vat',   & ! #46-57
-         'nudging_constant_ta', 'nudging_constant_qv', 'nudging_constant_ua', 'nudging_constant_va',           & ! # 58-61
-                                ! coordonnees temps #12
-         'tkes','hfss','hfls','ts_forc','tskin','ps_forc','ustar', &                     ! 62-68
-                                  ! scalaires 
-         'orog','albedo','emiss','q_skin','z0','z0h',       &                    ! 69-74
-         'O3','rugos','clay','sand'/                                                      ! 75-78
-
-
-    !-----------------------------------------------------------------------
-    ! First check that we are using a version > v2 of the 1D standard format
-    ! use the difference between 'temp' (old version) and 'ta' (new version)
-    !-----------------------------------------------------------------------
-
-
-    ierr=NF_INQ_VARID(nid,'ta',int_test)
-    if(ierr/=NF_NOERR) then
-       print*, '++++++++++++++++++++++++++++++'
-       print*, 'variable ta missing in cas.nc '
-       print*, 'You are probably using an obsolete version of the 1D cases'
-       print*, 'please dowload the last version of the 1D archive from https://lmdz.lmd.jussieu.fr/pub/'
-       print*, '++++++++++++++++++++++++++++++'
-       CALL abort_gcm ('mod_1D_cases_read_std','bad version of 1D directory',0)
-    endif
-
-    !-----------------------------------------------------------------------
-    ! Checking availability of variable #i in the cas.nc file
-    !     missing_var=1 if the variable is missing
-    !-----------------------------------------------------------------------
-
-    do i=1,nbvar3d
-       missing_var(i)=0.
-       ierr=NF_INQ_VARID(nid,name_var(i),var3didin(i)) 
-       print*, 'name_var(i)', name_var(i), var3didin(i)
-       if(ierr/=NF_NOERR) then
-          print *,'Variable manquante dans cas.nc:',i,name_var(i)
-          ierr=NF_NOERR
-          missing_var(i)=1
-       else
-
-          !-----------------------------------------------------------------------
-          ! Activating keys depending on the presence of specific variables in cas.nc
-          !-----------------------------------------------------------------------
-          if ( 1 == 1 ) THEN
-             ! A MODIFIER: il faudrait dire nudging_temp mais faut le declarer dans compar1d.h etc...        
-             !           if ( name_var(i) == 'temp_nudging' .and. nint(nudging_t)==0) stop 'Nudging inconsistency temp'
-             if ( name_var(i) == 'qv_nud' .and. nint(nudging_qv)==0) stop 'Nudging inconsistency qv'
-             if ( name_var(i) == 'ua_nud' .and. nint(nudging_u)==0) stop 'Nudging inconsistency u'
-             if ( name_var(i) == 'va_nud' .and. nint(nudging_v)==0) stop 'Nudging inconsistency v'
-          ELSE
-             print*,'GUIDAGE : CONSISTENCY CHECK DEACTIVATED FOR TESTS of SANDU/REF'
-          ENDIF
-
-          !-----------------------------------------------------------------------
-          ! Reading variables 1D (N+1) vertical variables (nlevelp1,lat,lon)
-          !-----------------------------------------------------------------------
-          if(i.LE.4) then
-             ierr = NF90_GET_VAR(nid,var3didin(i),apbp)
-             print *,'read_SCM(apbp), on a lu ',i,name_var(i)
-             if(ierr/=NF_NOERR) then
-                print *,'B Pb a la lecture de cas.nc: ',name_var(i)
-                stop "getvarup"
-             endif
-
-             !-----------------------------------------------------------------------
-             !  Reading 1D (N) vertical varialbes    (nlevel,lat,lon)   
-             !-----------------------------------------------------------------------
-          else if(i.gt.4.and.i.LE.12) then  
-             ierr = NF90_GET_VAR(nid,var3didin(i),resul1)
-             print *,'read_SCM(resul1), on a lu ',i,name_var(i)
-             if(ierr/=NF_NOERR) then
-                print *,'C Pb a la lecture de cas.nc: ',name_var(i)
-                stop "getvarup"
-             endif
-             print*,'Lecture de la variable #i ',i,name_var(i),minval(resul1),maxval(resul1)
-
-             !-----------------------------------------------------------------------
-             !  Reading 2D tim-vertical variables  (time,nlevel,lat,lon)
-             !  TBD : seems to be the same as above.
-             !-----------------------------------------------------------------------
-          else if(i.gt.12.and.i.LE.61) then
-             ierr = NF90_GET_VAR(nid,var3didin(i),resul)
-             print *,'read_SCM(resul), on a lu ',i,name_var(i)
-             if(ierr/=NF_NOERR) then
-                print *,'D Pb a la lecture de cas.nc: ',name_var(i)
-                stop "getvarup"
-             endif
-             print*,'Lecture de la variable #i ',i,name_var(i),minval(resul),maxval(resul)
-
-             !-----------------------------------------------------------------------
-             !  Reading 1D time variables (time,lat,lon)
-             !-----------------------------------------------------------------------
-          else if (i.gt.62.and.i.LE.75) then
-             ierr = NF90_GET_VAR(nid,var3didin(i),resul2)
-             print *,'read_SCM(resul2), on a lu ',i,name_var(i)
-             if(ierr/=NF_NOERR) then
-                print *,'E Pb a la lecture de cas.nc: ',name_var(i)
-                stop "getvarup"
-             endif
-             print*,'Lecture de la variable #i  ',i,name_var(i),minval(resul2),maxval(resul2)
-
-             !-----------------------------------------------------------------------
-             ! Reading scalar variables (lat,lon)
-             !-----------------------------------------------------------------------
-          else
-             ierr = NF90_GET_VAR(nid,var3didin(i),resul3)
-             print *,'read_SCM(resul3), on a lu ',i,name_var(i)
-             if(ierr/=NF_NOERR) then
-                print *,'F Pb a la lecture de cas.nc: ',name_var(i)
-                stop "getvarup"
-             endif
-             print*,'Lecture de la variable #i ',i,name_var(i),resul3
-          endif
-       endif
-
-       !-----------------------------------------------------------------------
-       ! Attributing variables
-       !-----------------------------------------------------------------------
-       select case(i)
-          !case(1) ; ap=apbp       ! donnees indexees en nlevel+1
-          ! case(2) ; bp=apbp
-       case(3) ; zzh=apbp
-       case(4) ; pph=apbp
-       case(5) ; temp0=resul1    ! donnees initiales
-       case(6) ; qv0=resul1
-       case(7) ; ql0=resul1
-       case(8) ; qi0=resul1
-       case(9) ; u0=resul1
-       case(10) ; v0=resul1
-       case(11) ; tke0=resul1
-       case(12) ; pp0=resul1
-       case(13) ; vitw=resul    ! donnees indexees en nlevel,time
-       case(14) ; omega=resul
-       case(15) ; ug=resul
-       case(16) ; vg=resul
-       case(17) ; du=resul
-       case(18) ; hu=resul
-       case(19) ; vu=resul
-       case(20) ; dv=resul
-       case(21) ; hv=resul
-       case(22) ; vv=resul
-       case(23) ; dt=resul
-       case(24) ; ht=resul
-       case(25) ; vt=resul
-       case(26) ; dq=resul
-       case(27) ; hq=resul
-       case(28) ; vq=resul
-       case(29) ; dth=resul
-       case(30) ; hth=resul
-       case(31) ; vth=resul
-       case(32) ; hthl=resul
-       case(33) ; dr=resul
-       case(34) ; hr=resul
-       case(35) ; vr=resul
-       case(36) ; dtrad=resul
-       case(37) ; q1=resul
-       case(38) ; q2=resul
-       case(39) ; uw=resul
-       case(40) ; vw=resul
-       case(41) ; rh=resul
-       case(42) ; temp_nudg=resul
-       case(43) ; qv_nudg=resul
-       case(44) ; u_nudg=resul
-       case(45) ; v_nudg=resul
-       case(46) ; zz=resul      ! donnees en time,nlevel pour profil initial
-       case(47) ; pp=resul
-       case(48) ; temp=resul
-       case(49) ; theta=resul
-       case(50) ; thv=resul
-       case(51) ; thl=resul
-       case(52) ; qv=resul
-       case(53) ; ql=resul
-       case(54) ; qi=resul
-       case(55) ; rv=resul
-       case(56) ; u=resul
-       case(57) ; v=resul
-       case(58) ; invtau_temp_nudg=resul
-       case(59) ; invtau_qv_nudg=resul
-       case(60) ; invtau_u_nudg=resul
-       case(61) ; invtau_v_nudg=resul
-       case(62) ; tkes=resul2   ! donnees indexees en time
-       case(63) ; sens=resul2
-       case(64) ; flat=resul2
-       case(65) ; ts=resul2
-       case(66) ; tskin=resul2        
-       case(67) ; ps=resul2
-       case(68) ; ustar=resul2
-       case(69) ; orog_cas=resul3      ! constantes
-       case(70) ; albedo_cas=resul3
-       case(71) ; emiss_cas=resul3
-       case(72) ; q_skin_cas=resul3
-       case(73) ; mom_rough=resul3
-       case(74) ; heat_rough=resul3
-       case(75) ; o3_cas=resul3        
-       case(76) ; rugos_cas=resul3
-       case(77) ; clay_cas=resul3
-       case(78) ; sand_cas=resul3
-       end select
-       resul=0.
-       resul1=0.
-       resul2=0.
-       resul3=0.
-    enddo
-    print*,'Lecture de la variable APRES ,sens ',minval(sens),maxval(sens)
-    print*,'Lecture de la variable APRES ,flat ',minval(flat),maxval(flat)
-
-    !CR:ATTENTION EN ATTENTE DE REGLER LA QUESTION DU PAS DE TEMPS INITIAL
-    do t=1,ntime
-       do k=1,nlevel
-          temp(k,t)=temp0(k)
-          qv(k,t)=qv0(k)
-          ql(k,t)=ql0(k)
-          qi(k,t)=qi0(k)
-          u(k,t)=u0(k)
-          v(k,t)=v0(k)
-          tke(k,t)=tke0(k)
-       enddo
-    enddo
-!!!! TRAVAIL : EN FONCTION DES DECISIONS SUR LA SPECIFICATION DE W
-!!!omega=-vitw*pres*rg/(rd*temp)
-    !-----------------------------------------------------------------------
-
-    return 
-  END SUBROUTINE read_SCM
-  !======================================================================
-
-  !======================================================================
-
-  !**********************************************************************************************
-
-  !**********************************************************************************************
-  SUBROUTINE interp_case_time_std(day,day1,annee_ref                           &
-       !    &         ,year_cas,day_cas,nt_cas,pdt_forc,nlev_cas                         &
-       ,nt_cas,nlev_cas                                                   &
-       ,ts_cas,tskin_cas,ps_cas,plev_cas,t_cas,theta_cas,thv_cas,thl_cas            &
-       ,qv_cas,ql_cas,qi_cas,u_cas,v_cas                                  &
-       ,ug_cas,vg_cas,temp_nudg_cas,qv_nudg_cas,u_nudg_cas,v_nudg_cas     &
-       ,invtau_temp_nudg_cas,invtau_qv_nudg_cas,invtau_u_nudg_cas,invtau_v_nudg_cas     &
-       ,vitw_cas,omega_cas,tke_cas,du_cas,hu_cas,vu_cas             &
-       ,dv_cas,hv_cas,vv_cas,dt_cas,ht_cas,vt_cas,dtrad_cas               &
-       ,dq_cas,hq_cas,vq_cas,dth_cas,hth_cas,vth_cas                      &
-       ,lat_cas,sens_cas,ustar_cas                                        &
-       ,uw_cas,vw_cas,q1_cas,q2_cas,tkes_cas                               &
-       !
-       ,ts_prof_cas,tskin_prof_cas,ps_prof_cas,plev_prof_cas,t_prof_cas,theta_prof_cas               &
-       ,thv_prof_cas,thl_prof_cas,qv_prof_cas,ql_prof_cas,qi_prof_cas     &
-       ,u_prof_cas,v_prof_cas,ug_prof_cas,vg_prof_cas                     &
-       ,temp_nudg_prof_cas,qv_nudg_prof_cas,u_nudg_prof_cas,v_nudg_prof_cas     &
-       ,invtau_temp_nudg_prof_cas,invtau_qv_nudg_prof_cas,invtau_u_nudg_prof_cas,invtau_v_nudg_prof_cas     &     
-       ,vitw_prof_cas,omega_prof_cas,tke_prof_cas,du_prof_cas,hu_prof_cas,vu_prof_cas  &
-       ,dv_prof_cas,hv_prof_cas,vv_prof_cas,dt_prof_cas                   &
-       ,ht_prof_cas,vt_prof_cas,dtrad_prof_cas,dq_prof_cas                &
-       ,hq_prof_cas,vq_prof_cas,dth_prof_cas,hth_prof_cas,vth_prof_cas    &
-       ,lat_prof_cas,sens_prof_cas                                        &
-       ,ustar_prof_cas,uw_prof_cas,vw_prof_cas,q1_prof_cas,q2_prof_cas,tkes_prof_cas)
-
-
-
-
-
-
-    implicit none
-
-    !---------------------------------------------------------------------------------------
-    ! Time interpolation of a 2D field to the timestep corresponding to day
-    !
-    ! day: current julian day (e.g. 717538.2)
-    ! day1: first day of the simulation
-    ! nt_cas: total nb of data in the forcing 
-    ! pdt_cas: total time interval (in sec) between 2 forcing data
-    !---------------------------------------------------------------------------------------
-
-    INCLUDE "compar1d.h"
-    INCLUDE "date_cas.h"
-
-    ! inputs:
-    integer annee_ref
-    integer nt_cas,nlev_cas
-    real day, day1,day_cas
-    real ts_cas(nt_cas),tskin_cas(nt_cas),ps_cas(nt_cas)
-    real plev_cas(nlev_cas,nt_cas)
-    real t_cas(nlev_cas,nt_cas),theta_cas(nlev_cas,nt_cas)
-    real thv_cas(nlev_cas,nt_cas), thl_cas(nlev_cas,nt_cas)
-    real qv_cas(nlev_cas,nt_cas),ql_cas(nlev_cas,nt_cas),qi_cas(nlev_cas,nt_cas)
-    real u_cas(nlev_cas,nt_cas),v_cas(nlev_cas,nt_cas)
-    real ug_cas(nlev_cas,nt_cas),vg_cas(nlev_cas,nt_cas)
-    real temp_nudg_cas(nlev_cas,nt_cas),qv_nudg_cas(nlev_cas,nt_cas)
-    real u_nudg_cas(nlev_cas,nt_cas),v_nudg_cas(nlev_cas,nt_cas)
-
-    real invtau_temp_nudg_cas(nlev_cas,nt_cas),invtau_qv_nudg_cas(nlev_cas,nt_cas)
-    real invtau_u_nudg_cas(nlev_cas,nt_cas),invtau_v_nudg_cas(nlev_cas,nt_cas)
-
-    real vitw_cas(nlev_cas,nt_cas),omega_cas(nlev_cas,nt_cas),tke_cas(nlev_cas,nt_cas)
-    real du_cas(nlev_cas,nt_cas),hu_cas(nlev_cas,nt_cas),vu_cas(nlev_cas,nt_cas)
-    real dv_cas(nlev_cas,nt_cas),hv_cas(nlev_cas,nt_cas),vv_cas(nlev_cas,nt_cas)
-    real dt_cas(nlev_cas,nt_cas),ht_cas(nlev_cas,nt_cas),vt_cas(nlev_cas,nt_cas)
-    real dth_cas(nlev_cas,nt_cas),hth_cas(nlev_cas,nt_cas),vth_cas(nlev_cas,nt_cas)
-    real dtrad_cas(nlev_cas,nt_cas)
-    real dq_cas(nlev_cas,nt_cas),hq_cas(nlev_cas,nt_cas),vq_cas(nlev_cas,nt_cas)
-    real lat_cas(nt_cas),sens_cas(nt_cas),tkes_cas(nt_cas)
-    real ustar_cas(nt_cas),uw_cas(nlev_cas,nt_cas),vw_cas(nlev_cas,nt_cas)
-    real q1_cas(nlev_cas,nt_cas),q2_cas(nlev_cas,nt_cas)
-
-    ! outputs:
-    real plev_prof_cas(nlev_cas)
-    real t_prof_cas(nlev_cas),theta_prof_cas(nlev_cas),thl_prof_cas(nlev_cas),thv_prof_cas(nlev_cas)
-    real qv_prof_cas(nlev_cas),ql_prof_cas(nlev_cas),qi_prof_cas(nlev_cas)
-    real u_prof_cas(nlev_cas),v_prof_cas(nlev_cas)
-    real ug_prof_cas(nlev_cas),vg_prof_cas(nlev_cas)
-    real temp_nudg_prof_cas(nlev_cas),qv_nudg_prof_cas(nlev_cas)
-    real u_nudg_prof_cas(nlev_cas),v_nudg_prof_cas(nlev_cas)
-
-    real invtau_temp_nudg_prof_cas(nlev_cas),invtau_qv_nudg_prof_cas(nlev_cas)
-    real invtau_u_nudg_prof_cas(nlev_cas),invtau_v_nudg_prof_cas(nlev_cas)
-
-    real vitw_prof_cas(nlev_cas),omega_prof_cas(nlev_cas),tke_prof_cas(nlev_cas)
-    real du_prof_cas(nlev_cas),hu_prof_cas(nlev_cas),vu_prof_cas(nlev_cas)
-    real dv_prof_cas(nlev_cas),hv_prof_cas(nlev_cas),vv_prof_cas(nlev_cas)
-    real dt_prof_cas(nlev_cas),ht_prof_cas(nlev_cas),vt_prof_cas(nlev_cas)
-    real dth_prof_cas(nlev_cas),hth_prof_cas(nlev_cas),vth_prof_cas(nlev_cas)
-    real dtrad_prof_cas(nlev_cas)
-    real dq_prof_cas(nlev_cas),hq_prof_cas(nlev_cas),vq_prof_cas(nlev_cas)
-    real lat_prof_cas,sens_prof_cas,tkes_prof_cas,ts_prof_cas,tskin_prof_cas,ps_prof_cas,ustar_prof_cas
-    real uw_prof_cas(nlev_cas),vw_prof_cas(nlev_cas),q1_prof_cas(nlev_cas),q2_prof_cas(nlev_cas)
-    ! local:
-    integer it_cas1, it_cas2,k
-    real timeit,time_cas1,time_cas2,frac
-
-
-    print*,'Check time',day1,day_ju_ini_cas,day_deb+1,pdt_cas
-    !       do k=1,nlev_cas
-    !       print*,'debut de interp2_case_time, plev_cas=',k,plev_cas(k,1)
-    !       enddo
-
-    ! On teste si la date du cas AMMA est correcte.
-    ! C est pour memoire car en fait les fichiers .def
-    ! sont censes etre corrects.
-    ! A supprimer a terme (MPL 20150623)
-    !     if ((forcing_type.eq.10).and.(1.eq.0)) then
-    ! Check that initial day of the simulation consistent with AMMA case:
-    !      if (annee_ref.ne.2006) then
-    !       print*,'Pour AMMA, annee_ref doit etre 2006'
-    !       print*,'Changer annee_ref dans run.def'
-    !       stop
-    !      endif
-    !      if (annee_ref.eq.2006 .and. day1.lt.day_cas) then
-    !       print*,'AMMA a debute le 10 juillet 2006',day1,day_cas
-    !       print*,'Changer dayref dans run.def'
-    !       stop
-    !      endif
-    !      if (annee_ref.eq.2006 .and. day1.gt.day_cas+1) then
-    !       print*,'AMMA a fini le 11 juillet'
-    !       print*,'Changer dayref ou nday dans run.def'
-    !       stop
-    !      endif
-    !      endif
-
-    ! Determine timestep relative to the 1st day:
-    !       timeit=(day-day1)*86400.
-    !       if (annee_ref.eq.1992) then
-    !        timeit=(day-day_cas)*86400.
-    !       else
-    !        timeit=(day+61.-1.)*86400. ! 61 days between Nov01 and Dec31 1992
-    !       endif
-    timeit=(day-day_ju_ini_cas)*86400
-    print *,'day=',day
-    print *,'day_ju_ini_cas=',day_ju_ini_cas
-    print *,'pdt_cas=',pdt_cas
-    print *,'timeit=',timeit
-    print *,'nt_cas=',nt_cas
-
-    ! Determine the closest observation times:
-    !       it_cas1=INT(timeit/pdt_cas)+1
-    !       it_cas2=it_cas1 + 1
-    !       time_cas1=(it_cas1-1)*pdt_cas
-    !       time_cas2=(it_cas2-1)*pdt_cas
-
-    it_cas1=INT(timeit/pdt_cas)+1
-    IF (it_cas1 .EQ. nt_cas) THEN
-       it_cas2=it_cas1 
-    ELSE
-       it_cas2=it_cas1 + 1
-    ENDIF
-    time_cas1=(it_cas1-1)*pdt_cas
-    time_cas2=(it_cas2-1)*pdt_cas
-    !     print *,'timeit,pdt_cas,nt_cas=',timeit,pdt_cas,nt_cas
-    !     print *,'it_cas1,it_cas2,time_cas1,time_cas2=',it_cas1,it_cas2,time_cas1,time_cas2
-
-    if (it_cas1 .gt. nt_cas) then 
-       write(*,*) 'PB-stop: day, day_ju_ini_cas,it_cas1, it_cas2, timeit: '            &
-            ,day,day_ju_ini_cas,it_cas1,it_cas2,timeit
-       stop
-    endif
-
-    ! time interpolation:
-    IF (it_cas1 .EQ. it_cas2) THEN
-       frac=0.
-    ELSE
-       frac=(time_cas2-timeit)/(time_cas2-time_cas1)
-       frac=max(frac,0.0)
-    ENDIF
-
-    lat_prof_cas = lat_cas(it_cas2)                                   &
-         -frac*(lat_cas(it_cas2)-lat_cas(it_cas1)) 
-    sens_prof_cas = sens_cas(it_cas2)                                 &
-         -frac*(sens_cas(it_cas2)-sens_cas(it_cas1))
-    tkes_prof_cas = tkes_cas(it_cas2)                                   &
-         -frac*(tkes_cas(it_cas2)-tkes_cas(it_cas1))
-    ts_prof_cas = ts_cas(it_cas2)                                     &
-         -frac*(ts_cas(it_cas2)-ts_cas(it_cas1))
-    tskin_prof_cas = tskin_cas(it_cas2)                                     &
-         -frac*(tskin_cas(it_cas2)-tskin_cas(it_cas1))
-    ps_prof_cas = ps_cas(it_cas2)                                     &
-         -frac*(ps_cas(it_cas2)-ps_cas(it_cas1))
-    ustar_prof_cas = ustar_cas(it_cas2)                               &
-         -frac*(ustar_cas(it_cas2)-ustar_cas(it_cas1))
-
-    do k=1,nlev_cas
-       plev_prof_cas(k) = plev_cas(k,it_cas2)                           &     
-            -frac*(plev_cas(k,it_cas2)-plev_cas(k,it_cas1))
-       t_prof_cas(k) = t_cas(k,it_cas2)                                 &        
-            -frac*(t_cas(k,it_cas2)-t_cas(k,it_cas1))
-       !print *,'k,frac,plev_cas1,plev_cas2=',k,frac,plev_cas(k,it_cas1),plev_cas(k,it_cas2)
-       theta_prof_cas(k) = theta_cas(k,it_cas2)                         &                      
-            -frac*(theta_cas(k,it_cas2)-theta_cas(k,it_cas1))
-       thv_prof_cas(k) = thv_cas(k,it_cas2)                             &          
-            -frac*(thv_cas(k,it_cas2)-thv_cas(k,it_cas1))
-       thl_prof_cas(k) = thl_cas(k,it_cas2)                             &              
-            -frac*(thl_cas(k,it_cas2)-thl_cas(k,it_cas1))
-       qv_prof_cas(k) = qv_cas(k,it_cas2)                               &
-            -frac*(qv_cas(k,it_cas2)-qv_cas(k,it_cas1))
-       ql_prof_cas(k) = ql_cas(k,it_cas2)                               &
-            -frac*(ql_cas(k,it_cas2)-ql_cas(k,it_cas1))
-       qi_prof_cas(k) = qi_cas(k,it_cas2)                               &
-            -frac*(qi_cas(k,it_cas2)-qi_cas(k,it_cas1))
-       u_prof_cas(k) = u_cas(k,it_cas2)                                 &
-            -frac*(u_cas(k,it_cas2)-u_cas(k,it_cas1))
-       v_prof_cas(k) = v_cas(k,it_cas2)                                 &
-            -frac*(v_cas(k,it_cas2)-v_cas(k,it_cas1))
-       ug_prof_cas(k) = ug_cas(k,it_cas2)                               &
-            -frac*(ug_cas(k,it_cas2)-ug_cas(k,it_cas1))
-       vg_prof_cas(k) = vg_cas(k,it_cas2)                               &
-            -frac*(vg_cas(k,it_cas2)-vg_cas(k,it_cas1))
-       temp_nudg_prof_cas(k) = temp_nudg_cas(k,it_cas2)                    &
-            -frac*(temp_nudg_cas(k,it_cas2)-temp_nudg_cas(k,it_cas1))
-       qv_nudg_prof_cas(k) = qv_nudg_cas(k,it_cas2)                        &
-            -frac*(qv_nudg_cas(k,it_cas2)-qv_nudg_cas(k,it_cas1))
-       u_nudg_prof_cas(k) = u_nudg_cas(k,it_cas2)                          &
-            -frac*(u_nudg_cas(k,it_cas2)-u_nudg_cas(k,it_cas1))
-       v_nudg_prof_cas(k) = v_nudg_cas(k,it_cas2)                          &
-            -frac*(v_nudg_cas(k,it_cas2)-v_nudg_cas(k,it_cas1))
-       invtau_temp_nudg_prof_cas(k) = invtau_temp_nudg_cas(k,it_cas2)                    &
-            -frac*(invtau_temp_nudg_cas(k,it_cas2)-invtau_temp_nudg_cas(k,it_cas1))
-       invtau_qv_nudg_prof_cas(k) = invtau_qv_nudg_cas(k,it_cas2)                        &
-            -frac*(invtau_qv_nudg_cas(k,it_cas2)-invtau_qv_nudg_cas(k,it_cas1))
-       invtau_u_nudg_prof_cas(k) = invtau_u_nudg_cas(k,it_cas2)                          &
-            -frac*(invtau_u_nudg_cas(k,it_cas2)-invtau_u_nudg_cas(k,it_cas1))
-       invtau_v_nudg_prof_cas(k) = invtau_v_nudg_cas(k,it_cas2)                          &
-            -frac*(invtau_v_nudg_cas(k,it_cas2)-invtau_v_nudg_cas(k,it_cas1))
-       vitw_prof_cas(k) = vitw_cas(k,it_cas2)                           &
-            -frac*(vitw_cas(k,it_cas2)-vitw_cas(k,it_cas1))
-       omega_prof_cas(k) = omega_cas(k,it_cas2)                         &
-            -frac*(omega_cas(k,it_cas2)-omega_cas(k,it_cas1))
-       tke_prof_cas(k) = tke_cas(k,it_cas2)                         &
-            -frac*(tke_cas(k,it_cas2)-tke_cas(k,it_cas1))
-       du_prof_cas(k) = du_cas(k,it_cas2)                               &
-            -frac*(du_cas(k,it_cas2)-du_cas(k,it_cas1))
-       hu_prof_cas(k) = hu_cas(k,it_cas2)                               &
-            -frac*(hu_cas(k,it_cas2)-hu_cas(k,it_cas1))
-       vu_prof_cas(k) = vu_cas(k,it_cas2)                               &
-            -frac*(vu_cas(k,it_cas2)-vu_cas(k,it_cas1))
-       dv_prof_cas(k) = dv_cas(k,it_cas2)                               &
-            -frac*(dv_cas(k,it_cas2)-dv_cas(k,it_cas1))
-       hv_prof_cas(k) = hv_cas(k,it_cas2)                               &
-            -frac*(hv_cas(k,it_cas2)-hv_cas(k,it_cas1))
-       vv_prof_cas(k) = vv_cas(k,it_cas2)                               &
-            -frac*(vv_cas(k,it_cas2)-vv_cas(k,it_cas1))
-       dt_prof_cas(k) = dt_cas(k,it_cas2)                               &
-            -frac*(dt_cas(k,it_cas2)-dt_cas(k,it_cas1))
-       ht_prof_cas(k) = ht_cas(k,it_cas2)                               &
-            -frac*(ht_cas(k,it_cas2)-ht_cas(k,it_cas1))
-       vt_prof_cas(k) = vt_cas(k,it_cas2)                               &
-            -frac*(vt_cas(k,it_cas2)-vt_cas(k,it_cas1))
-       dth_prof_cas(k) = dth_cas(k,it_cas2)                             &
-            -frac*(dth_cas(k,it_cas2)-dth_cas(k,it_cas1))
-       hth_prof_cas(k) = hth_cas(k,it_cas2)                             &
-            -frac*(hth_cas(k,it_cas2)-hth_cas(k,it_cas1))
-       vth_prof_cas(k) = vth_cas(k,it_cas2)                             &
-            -frac*(vth_cas(k,it_cas2)-vth_cas(k,it_cas1))
-       dtrad_prof_cas(k) = dtrad_cas(k,it_cas2)                         &
-            -frac*(dtrad_cas(k,it_cas2)-dtrad_cas(k,it_cas1))
-       dq_prof_cas(k) = dq_cas(k,it_cas2)                               &
-            -frac*(dq_cas(k,it_cas2)-dq_cas(k,it_cas1))
-       hq_prof_cas(k) = hq_cas(k,it_cas2)                               &
-            -frac*(hq_cas(k,it_cas2)-hq_cas(k,it_cas1))
-       vq_prof_cas(k) = vq_cas(k,it_cas2)                               &
-            -frac*(vq_cas(k,it_cas2)-vq_cas(k,it_cas1))
-       uw_prof_cas(k) = uw_cas(k,it_cas2)                                &
-            -frac*(uw_cas(k,it_cas2)-uw_cas(k,it_cas1))
-       vw_prof_cas(k) = vw_cas(k,it_cas2)                                &
-            -frac*(vw_cas(k,it_cas2)-vw_cas(k,it_cas1))
-       q1_prof_cas(k) = q1_cas(k,it_cas2)                                &
-            -frac*(q1_cas(k,it_cas2)-q1_cas(k,it_cas1))
-       q2_prof_cas(k) = q2_cas(k,it_cas2)                                &
-            -frac*(q2_cas(k,it_cas2)-q2_cas(k,it_cas1))
-    enddo
-
-    return
-  END SUBROUTINE interp_case_time_std
-
-  !**********************************************************************************************
-  !=====================================================================
-  SUBROUTINE interp2_case_vertical_std(play,plev,nlev_cas,plev_prof_cas                           &
-       ,t_prof_cas,th_prof_cas,thv_prof_cas,thl_prof_cas                                       &
-       ,qv_prof_cas,ql_prof_cas,qi_prof_cas,u_prof_cas,v_prof_cas                              &
-       ,ug_prof_cas,vg_prof_cas                                                                &
-       ,temp_nudg_prof_cas,qv_nudg_prof_cas,u_nudg_prof_cas,v_nudg_prof_cas                    &
-       ,invtau_temp_nudg_prof_cas,invtau_qv_nudg_prof_cas,invtau_u_nudg_prof_cas,invtau_v_nudg_prof_cas &     
-       ,vitw_prof_cas,omega_prof_cas,tke_prof_cas                                              &
-       ,du_prof_cas,hu_prof_cas,vu_prof_cas,dv_prof_cas,hv_prof_cas,vv_prof_cas                &
-       ,dt_prof_cas,ht_prof_cas,vt_prof_cas,dtrad_prof_cas,dq_prof_cas,hq_prof_cas,vq_prof_cas &
-       ,dth_prof_cas,hth_prof_cas,vth_prof_cas                                                 &
-       !
-       ,t_mod_cas,theta_mod_cas,thv_mod_cas,thl_mod_cas                                        &
-       ,qv_mod_cas,ql_mod_cas,qi_mod_cas,u_mod_cas,v_mod_cas                                   &
-       ,ug_mod_cas,vg_mod_cas                                                                  &
-       ,temp_nudg_mod_cas,qv_nudg_mod_cas,u_nudg_mod_cas,v_nudg_mod_cas                        &
-       ,invtau_temp_nudg_mod_cas,invtau_qv_nudg_mod_cas,invtau_u_nudg_mod_cas,invtau_v_nudg_mod_cas                        &     
-       ,w_mod_cas,omega_mod_cas,tke_mod_cas                                                    &
-       ,du_mod_cas,hu_mod_cas,vu_mod_cas,dv_mod_cas,hv_mod_cas,vv_mod_cas                      &
-       ,dt_mod_cas,ht_mod_cas,vt_mod_cas,dtrad_mod_cas,dq_mod_cas,hq_mod_cas,vq_mod_cas        &
-       ,dth_mod_cas,hth_mod_cas,vth_mod_cas,mxcalc)
-
-    implicit none
-
-    INCLUDE "YOMCST.h"
-    INCLUDE "dimensions.h"
-
-    !-------------------------------------------------------------------------
-    ! Vertical interpolation of generic case forcing data onto mod_casel levels
-    !-------------------------------------------------------------------------
-
-    integer nlevmax
-    parameter (nlevmax=41)
-    integer nlev_cas,mxcalc
-    !       real play(llm), plev_prof(nlevmax) 
-    !       real t_prof(nlevmax),q_prof(nlevmax)
-    !       real u_prof(nlevmax),v_prof(nlevmax), w_prof(nlevmax)
-    !       real ht_prof(nlevmax),vt_prof(nlevmax)
-    !       real hq_prof(nlevmax),vq_prof(nlevmax)
-
-    real play(llm), plev(llm+1), plev_prof_cas(nlev_cas) 
-    real t_prof_cas(nlev_cas),th_prof_cas(nlev_cas),thv_prof_cas(nlev_cas),thl_prof_cas(nlev_cas)
-    real qv_prof_cas(nlev_cas),ql_prof_cas(nlev_cas),qi_prof_cas(nlev_cas)
-    real u_prof_cas(nlev_cas),v_prof_cas(nlev_cas)
-    real ug_prof_cas(nlev_cas),vg_prof_cas(nlev_cas), vitw_prof_cas(nlev_cas),omega_prof_cas(nlev_cas),tke_prof_cas(nlev_cas)
-    real temp_nudg_prof_cas(nlev_cas),qv_nudg_prof_cas(nlev_cas)
-    real u_nudg_prof_cas(nlev_cas),v_nudg_prof_cas(nlev_cas)
-    real invtau_temp_nudg_prof_cas(nlev_cas),invtau_qv_nudg_prof_cas(nlev_cas)
-    real invtau_u_nudg_prof_cas(nlev_cas),invtau_v_nudg_prof_cas(nlev_cas)
-
-    real du_prof_cas(nlev_cas),hu_prof_cas(nlev_cas),vu_prof_cas(nlev_cas)
-    real dv_prof_cas(nlev_cas),hv_prof_cas(nlev_cas),vv_prof_cas(nlev_cas)
-    real dt_prof_cas(nlev_cas),ht_prof_cas(nlev_cas),vt_prof_cas(nlev_cas),dtrad_prof_cas(nlev_cas)
-    real dth_prof_cas(nlev_cas),hth_prof_cas(nlev_cas),vth_prof_cas(nlev_cas)
-    real dq_prof_cas(nlev_cas),hq_prof_cas(nlev_cas),vq_prof_cas(nlev_cas)
-
-    real t_mod_cas(llm),theta_mod_cas(llm),thv_mod_cas(llm),thl_mod_cas(llm)
-    real qv_mod_cas(llm),ql_mod_cas(llm),qi_mod_cas(llm)
-    real u_mod_cas(llm),v_mod_cas(llm)
-    real ug_mod_cas(llm),vg_mod_cas(llm), w_mod_cas(llm),omega_mod_cas(llm),tke_mod_cas(llm+1)
-    real temp_nudg_mod_cas(llm),qv_nudg_mod_cas(llm)
-    real u_nudg_mod_cas(llm),v_nudg_mod_cas(llm)
-    real invtau_temp_nudg_mod_cas(llm),invtau_qv_nudg_mod_cas(llm)
-    real invtau_u_nudg_mod_cas(llm),invtau_v_nudg_mod_cas(llm)
-    real du_mod_cas(llm),hu_mod_cas(llm),vu_mod_cas(llm)
-    real dv_mod_cas(llm),hv_mod_cas(llm),vv_mod_cas(llm)
-    real dt_mod_cas(llm),ht_mod_cas(llm),vt_mod_cas(llm),dtrad_mod_cas(llm)
-    real dth_mod_cas(llm),hth_mod_cas(llm),vth_mod_cas(llm)
-    real dq_mod_cas(llm),hq_mod_cas(llm),vq_mod_cas(llm)
-
-    integer l,k,k1,k2
-    real frac,frac1,frac2,fact
-
-
-
-    ! for variables defined at the middle of layers
-
-    do l = 1, llm
-
-       if (play(l).ge.plev_prof_cas(nlev_cas)) then
-
-          mxcalc=l
-          !        print *,'debut interp2, mxcalc=',mxcalc
-          k1=0
-          k2=0
-
-          if (play(l).le.plev_prof_cas(1)) then
-
-             do k = 1, nlev_cas-1
-                if (play(l).le.plev_prof_cas(k).and. play(l).gt.plev_prof_cas(k+1)) then
-                   k1=k
-                   k2=k+1
-                endif
-             enddo
-
-             if (k1.eq.0 .or. k2.eq.0) then
-                write(*,*) 'PB! k1, k2 = ',k1,k2
-                write(*,*) 'l,play(l) = ',l,play(l)/100
-                do k = 1, nlev_cas-1
-                   write(*,*) 'k,plev_prof_cas(k) = ',k,plev_prof_cas(k)/100
-                enddo
-             endif
-
-
-
-             frac = (plev_prof_cas(k2)-play(l))/(plev_prof_cas(k2)-plev_prof_cas(k1))
-
-             t_mod_cas(l)= t_prof_cas(k2) - frac*(t_prof_cas(k2)-t_prof_cas(k1))
-             theta_mod_cas(l)= th_prof_cas(k2) - frac*(th_prof_cas(k2)-th_prof_cas(k1))
-             if(theta_mod_cas(l).NE.0) t_mod_cas(l)= theta_mod_cas(l)*(play(l)/100000.)**(RD/RCPD)
-             thv_mod_cas(l)= thv_prof_cas(k2) - frac*(thv_prof_cas(k2)-thv_prof_cas(k1))
-             thl_mod_cas(l)= thl_prof_cas(k2) - frac*(thl_prof_cas(k2)-thl_prof_cas(k1))
-             qv_mod_cas(l)= qv_prof_cas(k2) - frac*(qv_prof_cas(k2)-qv_prof_cas(k1))
-             ql_mod_cas(l)= ql_prof_cas(k2) - frac*(ql_prof_cas(k2)-ql_prof_cas(k1))
-             qi_mod_cas(l)= qi_prof_cas(k2) - frac*(qi_prof_cas(k2)-qi_prof_cas(k1))
-             u_mod_cas(l)= u_prof_cas(k2) - frac*(u_prof_cas(k2)-u_prof_cas(k1))
-             v_mod_cas(l)= v_prof_cas(k2) - frac*(v_prof_cas(k2)-v_prof_cas(k1))
-             ug_mod_cas(l)= ug_prof_cas(k2) - frac*(ug_prof_cas(k2)-ug_prof_cas(k1))
-             vg_mod_cas(l)= vg_prof_cas(k2) - frac*(vg_prof_cas(k2)-vg_prof_cas(k1))
-             temp_nudg_mod_cas(l)= temp_nudg_prof_cas(k2) - frac*(temp_nudg_prof_cas(k2)-temp_nudg_prof_cas(k1))
-             qv_nudg_mod_cas(l)= qv_nudg_prof_cas(k2) - frac*(qv_nudg_prof_cas(k2)-qv_nudg_prof_cas(k1))
-             u_nudg_mod_cas(l)= u_nudg_prof_cas(k2) - frac*(u_nudg_prof_cas(k2)-u_nudg_prof_cas(k1))
-             v_nudg_mod_cas(l)= v_nudg_prof_cas(k2) - frac*(v_nudg_prof_cas(k2)-v_nudg_prof_cas(k1))
-
-             invtau_temp_nudg_mod_cas(l)= invtau_temp_nudg_prof_cas(k2) &
-                  - frac*(invtau_temp_nudg_prof_cas(k2)-invtau_temp_nudg_prof_cas(k1))
-             invtau_qv_nudg_mod_cas(l)= invtau_qv_nudg_prof_cas(k2) - frac*(invtau_qv_nudg_prof_cas(k2)-invtau_qv_nudg_prof_cas(k1))
-             invtau_u_nudg_mod_cas(l)= invtau_u_nudg_prof_cas(k2) - frac*(invtau_u_nudg_prof_cas(k2)-invtau_u_nudg_prof_cas(k1))
-             invtau_v_nudg_mod_cas(l)= invtau_v_nudg_prof_cas(k2) - frac*(invtau_v_nudg_prof_cas(k2)-invtau_v_nudg_prof_cas(k1))
-
-             w_mod_cas(l)= vitw_prof_cas(k2) - frac*(vitw_prof_cas(k2)-vitw_prof_cas(k1))
-             omega_mod_cas(l)= omega_prof_cas(k2) - frac*(omega_prof_cas(k2)-omega_prof_cas(k1))
-             du_mod_cas(l)= du_prof_cas(k2) - frac*(du_prof_cas(k2)-du_prof_cas(k1))
-             hu_mod_cas(l)= hu_prof_cas(k2) - frac*(hu_prof_cas(k2)-hu_prof_cas(k1))
-             vu_mod_cas(l)= vu_prof_cas(k2) - frac*(vu_prof_cas(k2)-vu_prof_cas(k1))
-             dv_mod_cas(l)= dv_prof_cas(k2) - frac*(dv_prof_cas(k2)-dv_prof_cas(k1))
-             hv_mod_cas(l)= hv_prof_cas(k2) - frac*(hv_prof_cas(k2)-hv_prof_cas(k1))
-             vv_mod_cas(l)= vv_prof_cas(k2) - frac*(vv_prof_cas(k2)-vv_prof_cas(k1))
-             dt_mod_cas(l)= dt_prof_cas(k2) - frac*(dt_prof_cas(k2)-dt_prof_cas(k1))
-             ht_mod_cas(l)= ht_prof_cas(k2) - frac*(ht_prof_cas(k2)-ht_prof_cas(k1))
-             vt_mod_cas(l)= vt_prof_cas(k2) - frac*(vt_prof_cas(k2)-vt_prof_cas(k1))
-             dth_mod_cas(l)= dth_prof_cas(k2) - frac*(dth_prof_cas(k2)-dth_prof_cas(k1))
-             hth_mod_cas(l)= hth_prof_cas(k2) - frac*(hth_prof_cas(k2)-hth_prof_cas(k1))
-             vth_mod_cas(l)= vth_prof_cas(k2) - frac*(vth_prof_cas(k2)-vth_prof_cas(k1))
-             dq_mod_cas(l)= dq_prof_cas(k2) - frac*(dq_prof_cas(k2)-dq_prof_cas(k1))
-             hq_mod_cas(l)= hq_prof_cas(k2) - frac*(hq_prof_cas(k2)-hq_prof_cas(k1))
-             vq_mod_cas(l)= vq_prof_cas(k2) - frac*(vq_prof_cas(k2)-vq_prof_cas(k1))
-             dtrad_mod_cas(l)= dtrad_prof_cas(k2) - frac*(dtrad_prof_cas(k2)-dtrad_prof_cas(k1))
-
-          else !play>plev_prof_cas(1)
-
-             k1=1
-             k2=2
-             print *,'interp2_vert, k1,k2=',plev_prof_cas(k1),plev_prof_cas(k2)
-             frac1 = (play(l)-plev_prof_cas(k2))/(plev_prof_cas(k1)-plev_prof_cas(k2))
-             frac2 = (play(l)-plev_prof_cas(k1))/(plev_prof_cas(k1)-plev_prof_cas(k2))
-             t_mod_cas(l)= frac1*t_prof_cas(k1) - frac2*t_prof_cas(k2)
-             theta_mod_cas(l)= frac1*th_prof_cas(k1) - frac2*th_prof_cas(k2)
-             if(theta_mod_cas(l).NE.0) t_mod_cas(l)= theta_mod_cas(l)*(play(l)/100000.)**(RD/RCPD)
-             thv_mod_cas(l)= frac1*thv_prof_cas(k1) - frac2*thv_prof_cas(k2)
-             thl_mod_cas(l)= frac1*thl_prof_cas(k1) - frac2*thl_prof_cas(k2)
-             qv_mod_cas(l)= frac1*qv_prof_cas(k1) - frac2*qv_prof_cas(k2)
-             ql_mod_cas(l)= frac1*ql_prof_cas(k1) - frac2*ql_prof_cas(k2)
-             qi_mod_cas(l)= frac1*qi_prof_cas(k1) - frac2*qi_prof_cas(k2)
-             u_mod_cas(l)= frac1*u_prof_cas(k1) - frac2*u_prof_cas(k2)
-             v_mod_cas(l)= frac1*v_prof_cas(k1) - frac2*v_prof_cas(k2)
-             ug_mod_cas(l)= frac1*ug_prof_cas(k1) - frac2*ug_prof_cas(k2)
-             vg_mod_cas(l)= frac1*vg_prof_cas(k1) - frac2*vg_prof_cas(k2)
-             temp_nudg_mod_cas(l)= frac1*temp_nudg_prof_cas(k1) - frac2*temp_nudg_prof_cas(k2)
-             qv_nudg_mod_cas(l)= frac1*qv_nudg_prof_cas(k1) - frac2*qv_nudg_prof_cas(k2)
-             u_nudg_mod_cas(l)= frac1*u_nudg_prof_cas(k1) - frac2*u_nudg_prof_cas(k2)
-             v_nudg_mod_cas(l)= frac1*v_nudg_prof_cas(k1) - frac2*v_nudg_prof_cas(k2)
-
-             invtau_temp_nudg_mod_cas(l)= frac1*invtau_temp_nudg_prof_cas(k1) - frac2*invtau_temp_nudg_prof_cas(k2)
-             invtau_qv_nudg_mod_cas(l)= frac1*invtau_qv_nudg_prof_cas(k1) - frac2*invtau_qv_nudg_prof_cas(k2)
-             invtau_u_nudg_mod_cas(l)= frac1*invtau_u_nudg_prof_cas(k1) - frac2*invtau_u_nudg_prof_cas(k2)
-             invtau_v_nudg_mod_cas(l)= frac1*invtau_v_nudg_prof_cas(k1) - frac2*invtau_v_nudg_prof_cas(k2)
-
-             w_mod_cas(l)= frac1*vitw_prof_cas(k1) - frac2*vitw_prof_cas(k2)
-             omega_mod_cas(l)= frac1*omega_prof_cas(k1) - frac2*omega_prof_cas(k2)
-             du_mod_cas(l)= frac1*du_prof_cas(k1) - frac2*du_prof_cas(k2)
-             hu_mod_cas(l)= frac1*hu_prof_cas(k1) - frac2*hu_prof_cas(k2)
-             vu_mod_cas(l)= frac1*vu_prof_cas(k1) - frac2*vu_prof_cas(k2)
-             dv_mod_cas(l)= frac1*dv_prof_cas(k1) - frac2*dv_prof_cas(k2)
-             hv_mod_cas(l)= frac1*hv_prof_cas(k1) - frac2*hv_prof_cas(k2)
-             vv_mod_cas(l)= frac1*vv_prof_cas(k1) - frac2*vv_prof_cas(k2)
-             dt_mod_cas(l)= frac1*dt_prof_cas(k1) - frac2*dt_prof_cas(k2)
-             ht_mod_cas(l)= frac1*ht_prof_cas(k1) - frac2*ht_prof_cas(k2)
-             vt_mod_cas(l)= frac1*vt_prof_cas(k1) - frac2*vt_prof_cas(k2)
-             dth_mod_cas(l)= frac1*dth_prof_cas(k1) - frac2*dth_prof_cas(k2)
-             hth_mod_cas(l)= frac1*hth_prof_cas(k1) - frac2*hth_prof_cas(k2)
-             vth_mod_cas(l)= frac1*vth_prof_cas(k1) - frac2*vth_prof_cas(k2)
-             dq_mod_cas(l)= frac1*dq_prof_cas(k1) - frac2*dq_prof_cas(k2)
-             hq_mod_cas(l)= frac1*hq_prof_cas(k1) - frac2*hq_prof_cas(k2)
-             vq_mod_cas(l)= frac1*vq_prof_cas(k1) - frac2*vq_prof_cas(k2)
-             dtrad_mod_cas(l)= frac1*dtrad_prof_cas(k1) - frac2*dtrad_prof_cas(k2)
-
-          endif ! play.le.plev_prof_cas(1)
-
-       else ! above max altitude of forcing file
-
-          !jyg
-          fact=20.*(plev_prof_cas(nlev_cas)-play(l))/plev_prof_cas(nlev_cas) !jyg
-          fact = max(fact,0.)                                           !jyg
-          fact = exp(-fact)                                             !jyg
-          t_mod_cas(l)= t_prof_cas(nlev_cas)                            !jyg
-          theta_mod_cas(l)= th_prof_cas(nlev_cas)                       !jyg
-          thv_mod_cas(l)= thv_prof_cas(nlev_cas)                        !jyg
-          thl_mod_cas(l)= thl_prof_cas(nlev_cas)                        !jyg
-          qv_mod_cas(l)= qv_prof_cas(nlev_cas)*fact                     !jyg
-          ql_mod_cas(l)= ql_prof_cas(nlev_cas)*fact                     !jyg
-          qi_mod_cas(l)= qi_prof_cas(nlev_cas)*fact                     !jyg
-          u_mod_cas(l)= u_prof_cas(nlev_cas)*fact                       !jyg
-          v_mod_cas(l)= v_prof_cas(nlev_cas)*fact                       !jyg
-          ug_mod_cas(l)= ug_prof_cas(nlev_cas)                          !jyg
-          vg_mod_cas(l)= vg_prof_cas(nlev_cas)                          !jyg
-          temp_nudg_mod_cas(l)= temp_nudg_prof_cas(nlev_cas)            !jyg
-          qv_nudg_mod_cas(l)= qv_nudg_prof_cas(nlev_cas)                !jyg
-          u_nudg_mod_cas(l)= u_nudg_prof_cas(nlev_cas)                  !jyg
-          v_nudg_mod_cas(l)= v_nudg_prof_cas(nlev_cas)                  !jyg
-
-          invtau_temp_nudg_mod_cas(l)= invtau_temp_nudg_prof_cas(nlev_cas)            !jyg
-          invtau_qv_nudg_mod_cas(l)= invtau_qv_nudg_prof_cas(nlev_cas)                !jyg
-          invtau_u_nudg_mod_cas(l)= invtau_u_nudg_prof_cas(nlev_cas)                  !jyg
-          invtau_v_nudg_mod_cas(l)= invtau_v_nudg_prof_cas(nlev_cas)                  !jyg
-
-          thv_mod_cas(l)= thv_prof_cas(nlev_cas)                        !jyg
-          w_mod_cas(l)= 0.0                                             !jyg
-          omega_mod_cas(l)= 0.0                                         !jyg
-          du_mod_cas(l)= du_prof_cas(nlev_cas)*fact 
-          hu_mod_cas(l)= hu_prof_cas(nlev_cas)*fact                     !jyg
-          vu_mod_cas(l)= vu_prof_cas(nlev_cas)*fact                     !jyg
-          dv_mod_cas(l)= dv_prof_cas(nlev_cas)*fact
-          hv_mod_cas(l)= hv_prof_cas(nlev_cas)*fact                     !jyg
-          vv_mod_cas(l)= vv_prof_cas(nlev_cas)*fact                     !jyg
-          dt_mod_cas(l)= dt_prof_cas(nlev_cas) 
-          ht_mod_cas(l)= ht_prof_cas(nlev_cas)                          !jyg
-          vt_mod_cas(l)= vt_prof_cas(nlev_cas)                          !jyg
-          dth_mod_cas(l)= dth_prof_cas(nlev_cas) 
-          hth_mod_cas(l)= hth_prof_cas(nlev_cas)                        !jyg
-          vth_mod_cas(l)= vth_prof_cas(nlev_cas)                        !jyg
-          dq_mod_cas(l)= dq_prof_cas(nlev_cas)*fact 
-          hq_mod_cas(l)= hq_prof_cas(nlev_cas)*fact                     !jyg
-          vq_mod_cas(l)= vq_prof_cas(nlev_cas)*fact                     !jyg
-          dtrad_mod_cas(l)= dtrad_prof_cas(nlev_cas)*fact               !jyg
-
-       endif ! play
-
-    enddo ! l
-
-    ! for variables defined at layer interfaces (EV):
-
-
-    do l = 1, llm+1
-
-       if (plev(l).ge.plev_prof_cas(nlev_cas)) then
-
-          mxcalc=l
-          k1=0
-          k2=0
-
-          if (plev(l).le.plev_prof_cas(1)) then
-
-             do k = 1, nlev_cas-1
-                if (plev(l).le.plev_prof_cas(k).and. plev(l).gt.plev_prof_cas(k+1)) then
-                   k1=k
-                   k2=k+1
-                endif
-             enddo
-
-             if (k1.eq.0 .or. k2.eq.0) then
-                write(*,*) 'PB! k1, k2 = ',k1,k2
-                write(*,*) 'l,plev(l) = ',l,plev(l)/100
-                do k = 1, nlev_cas-1
-                   write(*,*) 'k,plev_prof_cas(k) = ',k,plev_prof_cas(k)/100
-                enddo
-             endif
-
-             frac = (plev_prof_cas(k2)-plev(l))/(plev_prof_cas(k2)-plev_prof_cas(k1))
-             tke_mod_cas(l)= tke_prof_cas(k2) - frac*(tke_prof_cas(k2)-tke_prof_cas(k1))
-          else !play>plev_prof_cas(1)
-             k1=1
-             k2=2
-             frac1 = (play(l)-plev_prof_cas(k2))/(plev_prof_cas(k1)-plev_prof_cas(k2))
-             frac2 = (play(l)-plev_prof_cas(k1))/(plev_prof_cas(k1)-plev_prof_cas(k2))
-             tke_mod_cas(l)= frac1*tke_prof_cas(k1) - frac2*tke_prof_cas(k2)
-
-          endif ! plev.le.plev_prof_cas(1)
-
-       else ! above max altitude of forcing file
-
-          tke_mod_cas(l)=0.0
-
-       endif ! plev
-
-    enddo ! l
-
-
-
-    return
-  end SUBROUTINE interp2_case_vertical_std
-  !***************************************************************************** 
-
-
-
-
-
-END MODULE mod_1D_cases_read_std
Index: /LMDZ6/trunk/libf/phylmd/dyn1d/mod_1D_cases_read_std.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/dyn1d/mod_1D_cases_read_std.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/dyn1d/mod_1D_cases_read_std.f90	(revision 5268)
@@ -0,0 +1,1219 @@
+!
+! $Id: mod_1D_cases_read.F90 2373 2015-10-13 17:28:01Z jyg $
+!
+MODULE mod_1D_cases_read_std
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+  !Declarations specifiques au cas standard
+  character*80 :: fich_cas
+  ! Discr?tisation 
+  integer nlev_cas, nt_cas
+
+
+  !profils environnementaux
+  real, allocatable::  plev_cas(:,:),plevh_cas(:)
+  real, allocatable::  ap_cas(:),bp_cas(:)
+
+  real, allocatable::  z_cas(:,:),zh_cas(:)
+  real, allocatable::  t_cas(:,:),q_cas(:,:),qv_cas(:,:),ql_cas(:,:),qi_cas(:,:),rh_cas(:,:)
+  real, allocatable::  th_cas(:,:),thv_cas(:,:),thl_cas(:,:),rv_cas(:,:)
+  real, allocatable::  u_cas(:,:),v_cas(:,:),vitw_cas(:,:),omega_cas(:,:),tke_cas(:,:)
+
+  !forcing
+  real, allocatable::  ht_cas(:,:),vt_cas(:,:),dt_cas(:,:),dtrad_cas(:,:)
+  real, allocatable::  hth_cas(:,:),vth_cas(:,:),dth_cas(:,:)
+  real, allocatable::  hq_cas(:,:),vq_cas(:,:),dq_cas(:,:)
+  real, allocatable::  hr_cas(:,:),vr_cas(:,:),dr_cas(:,:)
+  real, allocatable::  hu_cas(:,:),vu_cas(:,:),du_cas(:,:)
+  real, allocatable::  hv_cas(:,:),vv_cas(:,:),dv_cas(:,:)
+  real, allocatable::  ug_cas(:,:),vg_cas(:,:)
+  real, allocatable::  temp_nudg_cas(:,:),qv_nudg_cas(:,:),u_nudg_cas(:,:),v_nudg_cas(:,:)
+  real, allocatable::  invtau_temp_nudg_cas(:,:),invtau_qv_nudg_cas(:,:),invtau_u_nudg_cas(:,:),invtau_v_nudg_cas(:,:)
+  real, allocatable::  lat_cas(:),sens_cas(:),tskin_cas(:),ts_cas(:),ps_cas(:),ustar_cas(:)
+  real, allocatable::  uw_cas(:,:),vw_cas(:,:),q1_cas(:,:),q2_cas(:,:),tkes_cas(:)
+
+  !champs interpoles
+  real, allocatable::  plev_prof_cas(:)
+  real, allocatable::  t_prof_cas(:)
+  real, allocatable::  theta_prof_cas(:)
+  real, allocatable::  thl_prof_cas(:)
+  real, allocatable::  thv_prof_cas(:)
+  real, allocatable::  q_prof_cas(:)
+  real, allocatable::  qv_prof_cas(:)
+  real, allocatable::  ql_prof_cas(:)
+  real, allocatable::  qi_prof_cas(:)
+  real, allocatable::  rh_prof_cas(:)
+  real, allocatable::  rv_prof_cas(:)
+  real, allocatable::  u_prof_cas(:)
+  real, allocatable::  v_prof_cas(:)        
+  real, allocatable::  vitw_prof_cas(:)
+  real, allocatable::  omega_prof_cas(:)
+  real, allocatable::  tke_prof_cas(:)
+  real, allocatable::  ug_prof_cas(:)
+  real, allocatable::  vg_prof_cas(:)
+  real, allocatable::  temp_nudg_prof_cas(:),qv_nudg_prof_cas(:),u_nudg_prof_cas(:),v_nudg_prof_cas(:)
+  real, allocatable::  invtau_temp_nudg_prof_cas(:),invtau_qv_nudg_prof_cas(:),invtau_u_nudg_prof_cas(:),invtau_v_nudg_prof_cas(:)
+
+  real, allocatable::  ht_prof_cas(:)
+  real, allocatable::  hth_prof_cas(:)
+  real, allocatable::  hq_prof_cas(:)
+  real, allocatable::  vt_prof_cas(:)
+  real, allocatable::  vth_prof_cas(:)
+  real, allocatable::  vq_prof_cas(:)
+  real, allocatable::  dt_prof_cas(:)
+  real, allocatable::  dth_prof_cas(:)
+  real, allocatable::  dtrad_prof_cas(:)
+  real, allocatable::  dq_prof_cas(:)
+  real, allocatable::  hu_prof_cas(:)
+  real, allocatable::  hv_prof_cas(:)
+  real, allocatable::  vu_prof_cas(:)
+  real, allocatable::  vv_prof_cas(:)
+  real, allocatable::  du_prof_cas(:)
+  real, allocatable::  dv_prof_cas(:)
+  real, allocatable::  uw_prof_cas(:)
+  real, allocatable::  vw_prof_cas(:)
+  real, allocatable::  q1_prof_cas(:)
+  real, allocatable::  q2_prof_cas(:)
+
+
+  real o3_cas,lat_prof_cas,sens_prof_cas,ts_prof_cas,tskin_prof_cas,ps_prof_cas,ustar_prof_cas,tkes_prof_cas
+  real orog_cas,albedo_cas,emiss_cas,q_skin_cas,mom_rough,heat_rough,rugos_cas,sand_cas,clay_cas
+
+
+
+CONTAINS
+
+
+  !**********************************************************************************************
+  SUBROUTINE read_SCM_cas
+    use netcdf, only: nf90_get_var
+    implicit none
+
+    INCLUDE "netcdf.inc"
+    INCLUDE "date_cas.h"
+
+    INTEGER nid,rid,ierr
+    INTEGER ii,jj,timeid
+    REAL, ALLOCATABLE :: time_val(:)
+
+    fich_cas='cas.nc'
+    print*,'fich_cas ',fich_cas
+    ierr = NF_OPEN(fich_cas,NF_NOWRITE,nid)
+    print*,'fich_cas,NF_NOWRITE,nid ',fich_cas,NF_NOWRITE,nid
+    if (ierr.NE.NF_NOERR) then
+       write(*,*) 'ERROR: GROS Pb opening forcings nc file '
+       write(*,*) NF_STRERROR(ierr)
+       stop ""
+    endif
+    !.......................................................................
+    ierr=NF_INQ_DIMID(nid,'lat',rid)
+    IF (ierr.NE.NF_NOERR) THEN
+       print*, 'Oh probleme lecture dimension lat'
+    ENDIF
+    ierr=NF_INQ_DIMLEN(nid,rid,ii)
+    print*,'OK1 read_SCM_cas: nid,rid,lat',nid,rid,ii
+    !.......................................................................
+    ierr=NF_INQ_DIMID(nid,'lon',rid)
+    IF (ierr.NE.NF_NOERR) THEN
+       print*, 'Oh probleme lecture dimension lon'
+    ENDIF
+    ierr=NF_INQ_DIMLEN(nid,rid,jj)
+    print*,'OK2 read_SCM_cas: nid,rid,lat',nid,rid,jj
+    !.......................................................................
+    ierr=NF_INQ_DIMID(nid,'lev',rid)
+    IF (ierr.NE.NF_NOERR) THEN
+       print*, 'Oh probleme lecture dimension nlev'
+    ENDIF
+    ierr=NF_INQ_DIMLEN(nid,rid,nlev_cas)
+    print*,'OK3 read_SCM_cas: nid,rid,nlev_cas',nid,rid,nlev_cas
+    IF ( .NOT. ( nlev_cas > 10 .AND. nlev_cas < 200000 )) THEN
+       print*,'Valeur de nlev_cas peu probable'
+       STOP
+    ENDIF
+    !.......................................................................
+    ierr=NF_INQ_DIMID(nid,'time',rid)
+    nt_cas=0
+    IF (ierr.NE.NF_NOERR) THEN
+       stop 'Oh probleme lecture dimension time'
+    ENDIF
+    ierr=NF_INQ_DIMLEN(nid,rid,nt_cas)
+    print*,'OK4 read_SCM_cas: nid,rid,nt_cas',nid,rid,nt_cas
+    ! Lecture de l'axe des temps
+    print*,'LECTURE DU TEMPS'
+    ierr=NF_INQ_VARID(nid,'time',timeid)
+    if(ierr/=NF_NOERR) then
+       print *,'Variable time manquante dans cas.nc:'
+       ierr=NF_NOERR
+    else
+       allocate(time_val(nt_cas))
+       ierr = NF90_GET_VAR(nid,timeid,time_val)
+       if(ierr/=NF_NOERR) then
+          print *,'A Pb a la lecture de time cas.nc: '
+       endif
+    endif
+    IF (nt_cas>1) THEN
+       pdt_cas=time_val(2)-time_val(1)
+    ELSE
+       pdt_cas=0.
+    ENDIF
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+    !profils moyens:
+    allocate(plev_cas(nlev_cas,nt_cas),plevh_cas(nlev_cas+1))        
+    allocate(z_cas(nlev_cas,nt_cas),zh_cas(nlev_cas+1))
+    allocate(ap_cas(nlev_cas+1),bp_cas(nlev_cas+1))
+    allocate(t_cas(nlev_cas,nt_cas),q_cas(nlev_cas,nt_cas),qv_cas(nlev_cas,nt_cas),ql_cas(nlev_cas,nt_cas), &
+         qi_cas(nlev_cas,nt_cas),rh_cas(nlev_cas,nt_cas))
+    allocate(th_cas(nlev_cas,nt_cas),thl_cas(nlev_cas,nt_cas),thv_cas(nlev_cas,nt_cas),rv_cas(nlev_cas,nt_cas))
+    allocate(u_cas(nlev_cas,nt_cas),v_cas(nlev_cas,nt_cas),vitw_cas(nlev_cas,nt_cas),omega_cas(nlev_cas,nt_cas))
+    allocate(tke_cas(nlev_cas,nt_cas))
+    !forcing
+    allocate(ht_cas(nlev_cas,nt_cas),vt_cas(nlev_cas,nt_cas),dt_cas(nlev_cas,nt_cas),dtrad_cas(nlev_cas,nt_cas))
+    allocate(hq_cas(nlev_cas,nt_cas),vq_cas(nlev_cas,nt_cas),dq_cas(nlev_cas,nt_cas))
+    allocate(hth_cas(nlev_cas,nt_cas),vth_cas(nlev_cas,nt_cas),dth_cas(nlev_cas,nt_cas))
+    allocate(hr_cas(nlev_cas,nt_cas),vr_cas(nlev_cas,nt_cas),dr_cas(nlev_cas,nt_cas))
+    allocate(hu_cas(nlev_cas,nt_cas),vu_cas(nlev_cas,nt_cas),du_cas(nlev_cas,nt_cas))
+    allocate(hv_cas(nlev_cas,nt_cas),vv_cas(nlev_cas,nt_cas),dv_cas(nlev_cas,nt_cas))
+    allocate(ug_cas(nlev_cas,nt_cas),vg_cas(nlev_cas,nt_cas))
+    allocate(temp_nudg_cas(nlev_cas,nt_cas),qv_nudg_cas(nlev_cas,nt_cas))
+    allocate(u_nudg_cas(nlev_cas,nt_cas),v_nudg_cas(nlev_cas,nt_cas))
+    allocate(invtau_temp_nudg_cas(nlev_cas,nt_cas),invtau_qv_nudg_cas(nlev_cas,nt_cas))
+    allocate(invtau_u_nudg_cas(nlev_cas,nt_cas),invtau_v_nudg_cas(nlev_cas,nt_cas))
+    allocate(lat_cas(nt_cas),sens_cas(nt_cas),ts_cas(nt_cas),tskin_cas(nt_cas),ps_cas(nt_cas),ustar_cas(nt_cas),tkes_cas(nt_cas))
+    allocate(uw_cas(nlev_cas,nt_cas),vw_cas(nlev_cas,nt_cas),q1_cas(nlev_cas,nt_cas),q2_cas(nlev_cas,nt_cas))
+
+
+
+    !champs interpoles
+    allocate(plev_prof_cas(nlev_cas))
+    allocate(t_prof_cas(nlev_cas))
+    allocate(theta_prof_cas(nlev_cas))
+    allocate(thl_prof_cas(nlev_cas))
+    allocate(thv_prof_cas(nlev_cas))
+    allocate(q_prof_cas(nlev_cas))
+    allocate(qv_prof_cas(nlev_cas))
+    allocate(ql_prof_cas(nlev_cas))
+    allocate(qi_prof_cas(nlev_cas))
+    allocate(rh_prof_cas(nlev_cas))
+    allocate(rv_prof_cas(nlev_cas))
+    allocate(u_prof_cas(nlev_cas))
+    allocate(v_prof_cas(nlev_cas))
+    allocate(vitw_prof_cas(nlev_cas))
+    allocate(omega_prof_cas(nlev_cas))
+    allocate(tke_prof_cas(nlev_cas))
+    allocate(ug_prof_cas(nlev_cas))
+    allocate(vg_prof_cas(nlev_cas))
+    allocate(temp_nudg_prof_cas(nlev_cas),qv_nudg_prof_cas(nlev_cas))
+    allocate(u_nudg_prof_cas(nlev_cas),v_nudg_prof_cas(nlev_cas))
+    allocate(invtau_temp_nudg_prof_cas(nlev_cas),invtau_qv_nudg_prof_cas(nlev_cas))
+    allocate(invtau_u_nudg_prof_cas(nlev_cas),invtau_v_nudg_prof_cas(nlev_cas))
+    allocate(ht_prof_cas(nlev_cas))
+    allocate(hth_prof_cas(nlev_cas))
+    allocate(hq_prof_cas(nlev_cas))
+    allocate(hu_prof_cas(nlev_cas))
+    allocate(hv_prof_cas(nlev_cas))
+    allocate(vt_prof_cas(nlev_cas))
+    allocate(vth_prof_cas(nlev_cas))
+    allocate(vq_prof_cas(nlev_cas))
+    allocate(vu_prof_cas(nlev_cas))
+    allocate(vv_prof_cas(nlev_cas))
+    allocate(dt_prof_cas(nlev_cas))
+    allocate(dth_prof_cas(nlev_cas))
+    allocate(dtrad_prof_cas(nlev_cas))
+    allocate(dq_prof_cas(nlev_cas))
+    allocate(du_prof_cas(nlev_cas))
+    allocate(dv_prof_cas(nlev_cas))
+    allocate(uw_prof_cas(nlev_cas))
+    allocate(vw_prof_cas(nlev_cas))
+    allocate(q1_prof_cas(nlev_cas))
+    allocate(q2_prof_cas(nlev_cas))
+
+    print*,'Allocations OK'
+    CALL read_SCM (nid,nlev_cas,nt_cas,                                                                     &
+         ap_cas,bp_cas,z_cas,plev_cas,zh_cas,plevh_cas,t_cas,th_cas,thv_cas,thl_cas,qv_cas,                   &
+         ql_cas,qi_cas,rh_cas,rv_cas,u_cas,v_cas,vitw_cas,omega_cas,tke_cas,ug_cas,vg_cas,                            &
+         temp_nudg_cas,qv_nudg_cas,u_nudg_cas,v_nudg_cas,                                                     &
+         invtau_temp_nudg_cas,invtau_qv_nudg_cas,invtau_u_nudg_cas,invtau_v_nudg_cas,                         &
+         du_cas,hu_cas,vu_cas,                                                                                &
+         dv_cas,hv_cas,vv_cas,dt_cas,ht_cas,vt_cas,dq_cas,hq_cas,vq_cas,dth_cas,hth_cas,vth_cas,               &
+         dr_cas,hr_cas,vr_cas,dtrad_cas,sens_cas,lat_cas,ts_cas,tskin_cas,ps_cas,ustar_cas,tkes_cas,            &
+         uw_cas,vw_cas,q1_cas,q2_cas,orog_cas,albedo_cas,emiss_cas,q_skin_cas,mom_rough,heat_rough, &
+         o3_cas,rugos_cas,clay_cas,sand_cas)
+    print*,'read_SCM cas OK'
+    do ii=1,nlev_cas
+       print*,'apres read_SCM_cas, plev_cas=',ii,plev_cas(ii,1)
+       !print*,'apres read_SCM, plev_cas=',ii,omega_cas(ii,nt_cas/2+1)
+    enddo
+
+
+  END SUBROUTINE read_SCM_cas
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+  SUBROUTINE deallocate2_1D_cases
+    !profils environnementaux:
+    deallocate(plev_cas,plevh_cas)
+
+    deallocate(z_cas,zh_cas)
+    deallocate(ap_cas,bp_cas)
+    deallocate(t_cas,q_cas,qv_cas,ql_cas,qi_cas,rh_cas)
+    deallocate(th_cas,thl_cas,thv_cas,rv_cas)
+    deallocate(u_cas,v_cas,vitw_cas,omega_cas,tke_cas)
+
+    !forcing
+    deallocate(ht_cas,vt_cas,dt_cas,dtrad_cas)
+    deallocate(hq_cas,vq_cas,dq_cas)
+    deallocate(hth_cas,vth_cas,dth_cas)
+    deallocate(hr_cas,vr_cas,dr_cas)
+    deallocate(hu_cas,vu_cas,du_cas)
+    deallocate(hv_cas,vv_cas,dv_cas)
+    deallocate(ug_cas)
+    deallocate(vg_cas)
+    deallocate(lat_cas,sens_cas,tskin_cas,ts_cas,ps_cas,ustar_cas,tkes_cas,uw_cas,vw_cas,q1_cas,q2_cas)
+
+    !champs interpoles
+    deallocate(plev_prof_cas)
+    deallocate(t_prof_cas)
+    deallocate(theta_prof_cas)
+    deallocate(thl_prof_cas)
+    deallocate(thv_prof_cas)
+    deallocate(q_prof_cas)
+    deallocate(qv_prof_cas)
+    deallocate(ql_prof_cas)
+    deallocate(qi_prof_cas)
+    deallocate(rh_prof_cas)
+    deallocate(rv_prof_cas)
+    deallocate(u_prof_cas)
+    deallocate(v_prof_cas)
+    deallocate(vitw_prof_cas)
+    deallocate(omega_prof_cas)
+    deallocate(tke_prof_cas)
+    deallocate(ug_prof_cas)
+    deallocate(vg_prof_cas)
+    deallocate(temp_nudg_prof_cas,qv_nudg_prof_cas,u_nudg_prof_cas,v_nudg_prof_cas)
+    deallocate(invtau_temp_nudg_prof_cas,invtau_qv_nudg_prof_cas,invtau_u_nudg_prof_cas,invtau_v_nudg_prof_cas)
+    deallocate(ht_prof_cas)
+    deallocate(hq_prof_cas)
+    deallocate(hu_prof_cas)
+    deallocate(hv_prof_cas)
+    deallocate(vt_prof_cas)
+    deallocate(vq_prof_cas)
+    deallocate(vu_prof_cas)
+    deallocate(vv_prof_cas)
+    deallocate(dt_prof_cas)
+    deallocate(dtrad_prof_cas)
+    deallocate(dq_prof_cas)
+    deallocate(du_prof_cas)
+    deallocate(dv_prof_cas)
+    deallocate(t_prof_cas)
+    deallocate(u_prof_cas)
+    deallocate(v_prof_cas)
+    deallocate(uw_prof_cas)
+    deallocate(vw_prof_cas)
+    deallocate(q1_prof_cas)
+    deallocate(q2_prof_cas)
+
+  END SUBROUTINE deallocate2_1D_cases
+
+
+  !=====================================================================
+  SUBROUTINE read_SCM(nid,nlevel,ntime,                                       &
+       ap,bp,zz,pp,zzh,pph,temp,theta,thv,thl,qv,ql,qi,rh,rv,u,v,vitw,omega,tke,ug,vg,&
+       temp_nudg,qv_nudg,u_nudg,v_nudg,                                        &
+       invtau_temp_nudg,invtau_qv_nudg,invtau_u_nudg,invtau_v_nudg,             &
+       du,hu,vu,dv,hv,vv,dt,ht,vt,dq,hq,vq,                                    &
+       dth,hth,vth,dr,hr,vr,dtrad,sens,flat,ts,tskin,ps,ustar,tkes,uw,vw,q1,q2,       &
+       orog_cas,albedo_cas,emiss_cas,q_skin_cas,mom_rough,          &
+       heat_rough,o3_cas,rugos_cas,clay_cas,sand_cas)
+
+    !program reading forcing of the case study
+    use netcdf, only: nf90_get_var
+    implicit none
+    INCLUDE "netcdf.inc"
+    INCLUDE "compar1d.h"
+
+    integer ntime,nlevel,k,t
+
+    real ap(nlevel+1),bp(nlevel+1)
+    real zz(nlevel,ntime),zzh(nlevel+1)
+    real pp(nlevel,ntime),pph(nlevel+1)
+    !profils initiaux
+    real temp0(nlevel),qv0(nlevel),ql0(nlevel),qi0(nlevel),u0(nlevel),v0(nlevel),tke0(nlevel)
+    real pp0(nlevel)    
+    real temp(nlevel,ntime),qv(nlevel,ntime),ql(nlevel,ntime),qi(nlevel,ntime),rh(nlevel,ntime)
+    real theta(nlevel,ntime),thv(nlevel,ntime),thl(nlevel,ntime),rv(nlevel,ntime)
+    real u(nlevel,ntime),v(nlevel,ntime),tkes(ntime)
+    real temp_nudg(nlevel,ntime),qv_nudg(nlevel,ntime),u_nudg(nlevel,ntime),v_nudg(nlevel,ntime)
+    real invtau_temp_nudg(nlevel,ntime),invtau_qv_nudg(nlevel,ntime),invtau_u_nudg(nlevel,ntime),invtau_v_nudg(nlevel,ntime)
+    real ug(nlevel,ntime),vg(nlevel,ntime)
+    real vitw(nlevel,ntime),omega(nlevel,ntime),tke(nlevel,ntime)
+    real du(nlevel,ntime),hu(nlevel,ntime),vu(nlevel,ntime)
+    real dv(nlevel,ntime),hv(nlevel,ntime),vv(nlevel,ntime)
+    real dt(nlevel,ntime),ht(nlevel,ntime),vt(nlevel,ntime)
+    real dtrad(nlevel,ntime)
+    real dq(nlevel,ntime),hq(nlevel,ntime),vq(nlevel,ntime)
+    real dth(nlevel,ntime),hth(nlevel,ntime),vth(nlevel,ntime),hthl(nlevel,ntime)
+    real dr(nlevel,ntime),hr(nlevel,ntime),vr(nlevel,ntime)
+    real flat(ntime),sens(ntime),ustar(ntime)
+    real uw(nlevel,ntime),vw(nlevel,ntime),q1(nlevel,ntime),q2(nlevel,ntime)
+    real ts(ntime),tskin(ntime),ps(ntime)
+    real orog_cas,albedo_cas,emiss_cas,q_skin_cas,mom_rough,heat_rough,o3_cas,rugos_cas,clay_cas,sand_cas
+    real apbp(nlevel+1),resul(nlevel,ntime),resul1(nlevel),resul2(ntime),resul3
+
+
+    integer nid, ierr,ierr1,ierr2,rid,i,int_test
+    integer nbvar3d
+    parameter(nbvar3d=78)
+    integer var3didin(nbvar3d),missing_var(nbvar3d)
+    character*13 name_var(1:nbvar3d)
+
+
+    !      data name_var/ &
+    !     ! coordonnees pression (n+1 niveaux) #4
+    !     & 'coor_par_a','coor_par_b','height_h','pressure_h',& ! #1-#4
+    !     ! coordonnees pression (n niveaux) #8
+    !     &'temp','qv','ql','qi','u','v','tke','pressure',& ! #5-#12
+    !     ! coordonnees pression + temps #42
+    !     &'w','omega','ug','vg','uadv','uadvh','uadvv','vadv','vadvh','vadvv','temp_adv','tadvh','tadvv',& !  #13 - #25
+    !     &'qv_adv','qvadvh','qvadvv','thadv','thadvh','thadvv','thladvh',                             & ! #26 - #32
+    !     & 'radv','radvh','radvv','radcool','q1','q2','ustress','vstress',                           & ! #33 - #40
+    !     & 'rh','temp_nudging','qv_nudging','u_nudging','v_nudging',                                       & ! #41-45
+    !     &'height_f','pressure_forc','tempt','theta','thv','thl','qvt','qlt','qit','rv','ut','vt',   & ! #46-58
+    !     ! coordonnees temps #12
+    !     &'tkes','sfc_sens_flx','sfc_lat_flx','ts','ps','ustar',&
+    !     &'orog','albedo','emiss','t_skin','q_skin','mom_rough','heat_rough',&
+    !     ! scalaires #4
+    !     &'o3','rugos','clay','sand'/
+
+
+
+    data name_var/ &
+                                ! coordonnees pression (n+1 niveaux) #4
+         'coor_par_a','coor_par_b','zf','pressure_h',& ! #1-#4
+                                ! coordonnees pression (n niveaux) #8
+         'ta','qv','ql','qi','ua','va','tke','pa',& ! #5-#12
+                                ! coordonnees pression + temps #46
+         'wa','wap','ug','vg','tnua_adv','tnua_advh','tnua_advv','tnva_adv','tnva_advh','tnva_advv','tnta_adv','tnta_advh',& !  #13 - #25
+         'tnta_advv','tnqv_adv','tnqv_advh','tnqv_advv','thadv','thadvh','thadvv','thladvh',                             & ! #26 - #32
+         'radv','radvh','radvv','tnta_rad','q1','q2','ustress','vstress',                           & ! #33 - #40
+         'rh','ta_nud','qv_nud','ua_nud','va_nud',                                       & ! #41-45
+         'zh_forc','pa_forc','tat','thetat','thetavt','thetalt','qvt','qlt','qit','rvt','uat','vat',   & ! #46-57
+         'nudging_constant_ta', 'nudging_constant_qv', 'nudging_constant_ua', 'nudging_constant_va',           & ! # 58-61
+                                ! coordonnees temps #12
+         'tkes','hfss','hfls','ts_forc','tskin','ps_forc','ustar', &                     ! 62-68
+                                  ! scalaires 
+         'orog','albedo','emiss','q_skin','z0','z0h',       &                    ! 69-74
+         'O3','rugos','clay','sand'/                                                      ! 75-78
+
+
+    !-----------------------------------------------------------------------
+    ! First check that we are using a version > v2 of the 1D standard format
+    ! use the difference between 'temp' (old version) and 'ta' (new version)
+    !-----------------------------------------------------------------------
+
+
+    ierr=NF_INQ_VARID(nid,'ta',int_test)
+    if(ierr/=NF_NOERR) then
+       print*, '++++++++++++++++++++++++++++++'
+       print*, 'variable ta missing in cas.nc '
+       print*, 'You are probably using an obsolete version of the 1D cases'
+       print*, 'please dowload the last version of the 1D archive from https://lmdz.lmd.jussieu.fr/pub/'
+       print*, '++++++++++++++++++++++++++++++'
+       CALL abort_gcm ('mod_1D_cases_read_std','bad version of 1D directory',0)
+    endif
+
+    !-----------------------------------------------------------------------
+    ! Checking availability of variable #i in the cas.nc file
+    !     missing_var=1 if the variable is missing
+    !-----------------------------------------------------------------------
+
+    do i=1,nbvar3d
+       missing_var(i)=0.
+       ierr=NF_INQ_VARID(nid,name_var(i),var3didin(i)) 
+       print*, 'name_var(i)', name_var(i), var3didin(i)
+       if(ierr/=NF_NOERR) then
+          print *,'Variable manquante dans cas.nc:',i,name_var(i)
+          ierr=NF_NOERR
+          missing_var(i)=1
+       else
+
+          !-----------------------------------------------------------------------
+          ! Activating keys depending on the presence of specific variables in cas.nc
+          !-----------------------------------------------------------------------
+          if ( 1 == 1 ) THEN
+             ! A MODIFIER: il faudrait dire nudging_temp mais faut le declarer dans compar1d.h etc...        
+             !           if ( name_var(i) == 'temp_nudging' .and. nint(nudging_t)==0) stop 'Nudging inconsistency temp'
+             if ( name_var(i) == 'qv_nud' .and. nint(nudging_qv)==0) stop 'Nudging inconsistency qv'
+             if ( name_var(i) == 'ua_nud' .and. nint(nudging_u)==0) stop 'Nudging inconsistency u'
+             if ( name_var(i) == 'va_nud' .and. nint(nudging_v)==0) stop 'Nudging inconsistency v'
+          ELSE
+             print*,'GUIDAGE : CONSISTENCY CHECK DEACTIVATED FOR TESTS of SANDU/REF'
+          ENDIF
+
+          !-----------------------------------------------------------------------
+          ! Reading variables 1D (N+1) vertical variables (nlevelp1,lat,lon)
+          !-----------------------------------------------------------------------
+          if(i.LE.4) then
+             ierr = NF90_GET_VAR(nid,var3didin(i),apbp)
+             print *,'read_SCM(apbp), on a lu ',i,name_var(i)
+             if(ierr/=NF_NOERR) then
+                print *,'B Pb a la lecture de cas.nc: ',name_var(i)
+                stop "getvarup"
+             endif
+
+             !-----------------------------------------------------------------------
+             !  Reading 1D (N) vertical varialbes    (nlevel,lat,lon)   
+             !-----------------------------------------------------------------------
+          else if(i.gt.4.and.i.LE.12) then  
+             ierr = NF90_GET_VAR(nid,var3didin(i),resul1)
+             print *,'read_SCM(resul1), on a lu ',i,name_var(i)
+             if(ierr/=NF_NOERR) then
+                print *,'C Pb a la lecture de cas.nc: ',name_var(i)
+                stop "getvarup"
+             endif
+             print*,'Lecture de la variable #i ',i,name_var(i),minval(resul1),maxval(resul1)
+
+             !-----------------------------------------------------------------------
+             !  Reading 2D tim-vertical variables  (time,nlevel,lat,lon)
+             !  TBD : seems to be the same as above.
+             !-----------------------------------------------------------------------
+          else if(i.gt.12.and.i.LE.61) then
+             ierr = NF90_GET_VAR(nid,var3didin(i),resul)
+             print *,'read_SCM(resul), on a lu ',i,name_var(i)
+             if(ierr/=NF_NOERR) then
+                print *,'D Pb a la lecture de cas.nc: ',name_var(i)
+                stop "getvarup"
+             endif
+             print*,'Lecture de la variable #i ',i,name_var(i),minval(resul),maxval(resul)
+
+             !-----------------------------------------------------------------------
+             !  Reading 1D time variables (time,lat,lon)
+             !-----------------------------------------------------------------------
+          else if (i.gt.62.and.i.LE.75) then
+             ierr = NF90_GET_VAR(nid,var3didin(i),resul2)
+             print *,'read_SCM(resul2), on a lu ',i,name_var(i)
+             if(ierr/=NF_NOERR) then
+                print *,'E Pb a la lecture de cas.nc: ',name_var(i)
+                stop "getvarup"
+             endif
+             print*,'Lecture de la variable #i  ',i,name_var(i),minval(resul2),maxval(resul2)
+
+             !-----------------------------------------------------------------------
+             ! Reading scalar variables (lat,lon)
+             !-----------------------------------------------------------------------
+          else
+             ierr = NF90_GET_VAR(nid,var3didin(i),resul3)
+             print *,'read_SCM(resul3), on a lu ',i,name_var(i)
+             if(ierr/=NF_NOERR) then
+                print *,'F Pb a la lecture de cas.nc: ',name_var(i)
+                stop "getvarup"
+             endif
+             print*,'Lecture de la variable #i ',i,name_var(i),resul3
+          endif
+       endif
+
+       !-----------------------------------------------------------------------
+       ! Attributing variables
+       !-----------------------------------------------------------------------
+       select case(i)
+          !case(1) ; ap=apbp       ! donnees indexees en nlevel+1
+          ! case(2) ; bp=apbp
+       case(3) ; zzh=apbp
+       case(4) ; pph=apbp
+       case(5) ; temp0=resul1    ! donnees initiales
+       case(6) ; qv0=resul1
+       case(7) ; ql0=resul1
+       case(8) ; qi0=resul1
+       case(9) ; u0=resul1
+       case(10) ; v0=resul1
+       case(11) ; tke0=resul1
+       case(12) ; pp0=resul1
+       case(13) ; vitw=resul    ! donnees indexees en nlevel,time
+       case(14) ; omega=resul
+       case(15) ; ug=resul
+       case(16) ; vg=resul
+       case(17) ; du=resul
+       case(18) ; hu=resul
+       case(19) ; vu=resul
+       case(20) ; dv=resul
+       case(21) ; hv=resul
+       case(22) ; vv=resul
+       case(23) ; dt=resul
+       case(24) ; ht=resul
+       case(25) ; vt=resul
+       case(26) ; dq=resul
+       case(27) ; hq=resul
+       case(28) ; vq=resul
+       case(29) ; dth=resul
+       case(30) ; hth=resul
+       case(31) ; vth=resul
+       case(32) ; hthl=resul
+       case(33) ; dr=resul
+       case(34) ; hr=resul
+       case(35) ; vr=resul
+       case(36) ; dtrad=resul
+       case(37) ; q1=resul
+       case(38) ; q2=resul
+       case(39) ; uw=resul
+       case(40) ; vw=resul
+       case(41) ; rh=resul
+       case(42) ; temp_nudg=resul
+       case(43) ; qv_nudg=resul
+       case(44) ; u_nudg=resul
+       case(45) ; v_nudg=resul
+       case(46) ; zz=resul      ! donnees en time,nlevel pour profil initial
+       case(47) ; pp=resul
+       case(48) ; temp=resul
+       case(49) ; theta=resul
+       case(50) ; thv=resul
+       case(51) ; thl=resul
+       case(52) ; qv=resul
+       case(53) ; ql=resul
+       case(54) ; qi=resul
+       case(55) ; rv=resul
+       case(56) ; u=resul
+       case(57) ; v=resul
+       case(58) ; invtau_temp_nudg=resul
+       case(59) ; invtau_qv_nudg=resul
+       case(60) ; invtau_u_nudg=resul
+       case(61) ; invtau_v_nudg=resul
+       case(62) ; tkes=resul2   ! donnees indexees en time
+       case(63) ; sens=resul2
+       case(64) ; flat=resul2
+       case(65) ; ts=resul2
+       case(66) ; tskin=resul2        
+       case(67) ; ps=resul2
+       case(68) ; ustar=resul2
+       case(69) ; orog_cas=resul3      ! constantes
+       case(70) ; albedo_cas=resul3
+       case(71) ; emiss_cas=resul3
+       case(72) ; q_skin_cas=resul3
+       case(73) ; mom_rough=resul3
+       case(74) ; heat_rough=resul3
+       case(75) ; o3_cas=resul3        
+       case(76) ; rugos_cas=resul3
+       case(77) ; clay_cas=resul3
+       case(78) ; sand_cas=resul3
+       end select
+       resul=0.
+       resul1=0.
+       resul2=0.
+       resul3=0.
+    enddo
+    print*,'Lecture de la variable APRES ,sens ',minval(sens),maxval(sens)
+    print*,'Lecture de la variable APRES ,flat ',minval(flat),maxval(flat)
+
+    !CR:ATTENTION EN ATTENTE DE REGLER LA QUESTION DU PAS DE TEMPS INITIAL
+    do t=1,ntime
+       do k=1,nlevel
+          temp(k,t)=temp0(k)
+          qv(k,t)=qv0(k)
+          ql(k,t)=ql0(k)
+          qi(k,t)=qi0(k)
+          u(k,t)=u0(k)
+          v(k,t)=v0(k)
+          tke(k,t)=tke0(k)
+       enddo
+    enddo
+!!!! TRAVAIL : EN FONCTION DES DECISIONS SUR LA SPECIFICATION DE W
+!!!omega=-vitw*pres*rg/(rd*temp)
+    !-----------------------------------------------------------------------
+
+    return 
+  END SUBROUTINE read_SCM
+  !======================================================================
+
+  !======================================================================
+
+  !**********************************************************************************************
+
+  !**********************************************************************************************
+  SUBROUTINE interp_case_time_std(day,day1,annee_ref                           &
+       !    &         ,year_cas,day_cas,nt_cas,pdt_forc,nlev_cas                         &
+       ,nt_cas,nlev_cas                                                   &
+       ,ts_cas,tskin_cas,ps_cas,plev_cas,t_cas,theta_cas,thv_cas,thl_cas            &
+       ,qv_cas,ql_cas,qi_cas,u_cas,v_cas                                  &
+       ,ug_cas,vg_cas,temp_nudg_cas,qv_nudg_cas,u_nudg_cas,v_nudg_cas     &
+       ,invtau_temp_nudg_cas,invtau_qv_nudg_cas,invtau_u_nudg_cas,invtau_v_nudg_cas     &
+       ,vitw_cas,omega_cas,tke_cas,du_cas,hu_cas,vu_cas             &
+       ,dv_cas,hv_cas,vv_cas,dt_cas,ht_cas,vt_cas,dtrad_cas               &
+       ,dq_cas,hq_cas,vq_cas,dth_cas,hth_cas,vth_cas                      &
+       ,lat_cas,sens_cas,ustar_cas                                        &
+       ,uw_cas,vw_cas,q1_cas,q2_cas,tkes_cas                               &
+       !
+       ,ts_prof_cas,tskin_prof_cas,ps_prof_cas,plev_prof_cas,t_prof_cas,theta_prof_cas               &
+       ,thv_prof_cas,thl_prof_cas,qv_prof_cas,ql_prof_cas,qi_prof_cas     &
+       ,u_prof_cas,v_prof_cas,ug_prof_cas,vg_prof_cas                     &
+       ,temp_nudg_prof_cas,qv_nudg_prof_cas,u_nudg_prof_cas,v_nudg_prof_cas     &
+       ,invtau_temp_nudg_prof_cas,invtau_qv_nudg_prof_cas,invtau_u_nudg_prof_cas,invtau_v_nudg_prof_cas     &     
+       ,vitw_prof_cas,omega_prof_cas,tke_prof_cas,du_prof_cas,hu_prof_cas,vu_prof_cas  &
+       ,dv_prof_cas,hv_prof_cas,vv_prof_cas,dt_prof_cas                   &
+       ,ht_prof_cas,vt_prof_cas,dtrad_prof_cas,dq_prof_cas                &
+       ,hq_prof_cas,vq_prof_cas,dth_prof_cas,hth_prof_cas,vth_prof_cas    &
+       ,lat_prof_cas,sens_prof_cas                                        &
+       ,ustar_prof_cas,uw_prof_cas,vw_prof_cas,q1_prof_cas,q2_prof_cas,tkes_prof_cas)
+
+
+
+
+
+
+    implicit none
+
+    !---------------------------------------------------------------------------------------
+    ! Time interpolation of a 2D field to the timestep corresponding to day
+    !
+    ! day: current julian day (e.g. 717538.2)
+    ! day1: first day of the simulation
+    ! nt_cas: total nb of data in the forcing 
+    ! pdt_cas: total time interval (in sec) between 2 forcing data
+    !---------------------------------------------------------------------------------------
+
+    INCLUDE "compar1d.h"
+    INCLUDE "date_cas.h"
+
+    ! inputs:
+    integer annee_ref
+    integer nt_cas,nlev_cas
+    real day, day1,day_cas
+    real ts_cas(nt_cas),tskin_cas(nt_cas),ps_cas(nt_cas)
+    real plev_cas(nlev_cas,nt_cas)
+    real t_cas(nlev_cas,nt_cas),theta_cas(nlev_cas,nt_cas)
+    real thv_cas(nlev_cas,nt_cas), thl_cas(nlev_cas,nt_cas)
+    real qv_cas(nlev_cas,nt_cas),ql_cas(nlev_cas,nt_cas),qi_cas(nlev_cas,nt_cas)
+    real u_cas(nlev_cas,nt_cas),v_cas(nlev_cas,nt_cas)
+    real ug_cas(nlev_cas,nt_cas),vg_cas(nlev_cas,nt_cas)
+    real temp_nudg_cas(nlev_cas,nt_cas),qv_nudg_cas(nlev_cas,nt_cas)
+    real u_nudg_cas(nlev_cas,nt_cas),v_nudg_cas(nlev_cas,nt_cas)
+
+    real invtau_temp_nudg_cas(nlev_cas,nt_cas),invtau_qv_nudg_cas(nlev_cas,nt_cas)
+    real invtau_u_nudg_cas(nlev_cas,nt_cas),invtau_v_nudg_cas(nlev_cas,nt_cas)
+
+    real vitw_cas(nlev_cas,nt_cas),omega_cas(nlev_cas,nt_cas),tke_cas(nlev_cas,nt_cas)
+    real du_cas(nlev_cas,nt_cas),hu_cas(nlev_cas,nt_cas),vu_cas(nlev_cas,nt_cas)
+    real dv_cas(nlev_cas,nt_cas),hv_cas(nlev_cas,nt_cas),vv_cas(nlev_cas,nt_cas)
+    real dt_cas(nlev_cas,nt_cas),ht_cas(nlev_cas,nt_cas),vt_cas(nlev_cas,nt_cas)
+    real dth_cas(nlev_cas,nt_cas),hth_cas(nlev_cas,nt_cas),vth_cas(nlev_cas,nt_cas)
+    real dtrad_cas(nlev_cas,nt_cas)
+    real dq_cas(nlev_cas,nt_cas),hq_cas(nlev_cas,nt_cas),vq_cas(nlev_cas,nt_cas)
+    real lat_cas(nt_cas),sens_cas(nt_cas),tkes_cas(nt_cas)
+    real ustar_cas(nt_cas),uw_cas(nlev_cas,nt_cas),vw_cas(nlev_cas,nt_cas)
+    real q1_cas(nlev_cas,nt_cas),q2_cas(nlev_cas,nt_cas)
+
+    ! outputs:
+    real plev_prof_cas(nlev_cas)
+    real t_prof_cas(nlev_cas),theta_prof_cas(nlev_cas),thl_prof_cas(nlev_cas),thv_prof_cas(nlev_cas)
+    real qv_prof_cas(nlev_cas),ql_prof_cas(nlev_cas),qi_prof_cas(nlev_cas)
+    real u_prof_cas(nlev_cas),v_prof_cas(nlev_cas)
+    real ug_prof_cas(nlev_cas),vg_prof_cas(nlev_cas)
+    real temp_nudg_prof_cas(nlev_cas),qv_nudg_prof_cas(nlev_cas)
+    real u_nudg_prof_cas(nlev_cas),v_nudg_prof_cas(nlev_cas)
+
+    real invtau_temp_nudg_prof_cas(nlev_cas),invtau_qv_nudg_prof_cas(nlev_cas)
+    real invtau_u_nudg_prof_cas(nlev_cas),invtau_v_nudg_prof_cas(nlev_cas)
+
+    real vitw_prof_cas(nlev_cas),omega_prof_cas(nlev_cas),tke_prof_cas(nlev_cas)
+    real du_prof_cas(nlev_cas),hu_prof_cas(nlev_cas),vu_prof_cas(nlev_cas)
+    real dv_prof_cas(nlev_cas),hv_prof_cas(nlev_cas),vv_prof_cas(nlev_cas)
+    real dt_prof_cas(nlev_cas),ht_prof_cas(nlev_cas),vt_prof_cas(nlev_cas)
+    real dth_prof_cas(nlev_cas),hth_prof_cas(nlev_cas),vth_prof_cas(nlev_cas)
+    real dtrad_prof_cas(nlev_cas)
+    real dq_prof_cas(nlev_cas),hq_prof_cas(nlev_cas),vq_prof_cas(nlev_cas)
+    real lat_prof_cas,sens_prof_cas,tkes_prof_cas,ts_prof_cas,tskin_prof_cas,ps_prof_cas,ustar_prof_cas
+    real uw_prof_cas(nlev_cas),vw_prof_cas(nlev_cas),q1_prof_cas(nlev_cas),q2_prof_cas(nlev_cas)
+    ! local:
+    integer it_cas1, it_cas2,k
+    real timeit,time_cas1,time_cas2,frac
+
+
+    print*,'Check time',day1,day_ju_ini_cas,day_deb+1,pdt_cas
+    !       do k=1,nlev_cas
+    !       print*,'debut de interp2_case_time, plev_cas=',k,plev_cas(k,1)
+    !       enddo
+
+    ! On teste si la date du cas AMMA est correcte.
+    ! C est pour memoire car en fait les fichiers .def
+    ! sont censes etre corrects.
+    ! A supprimer a terme (MPL 20150623)
+    !     if ((forcing_type.eq.10).and.(1.eq.0)) then
+    ! Check that initial day of the simulation consistent with AMMA case:
+    !      if (annee_ref.ne.2006) then
+    !       print*,'Pour AMMA, annee_ref doit etre 2006'
+    !       print*,'Changer annee_ref dans run.def'
+    !       stop
+    !      endif
+    !      if (annee_ref.eq.2006 .and. day1.lt.day_cas) then
+    !       print*,'AMMA a debute le 10 juillet 2006',day1,day_cas
+    !       print*,'Changer dayref dans run.def'
+    !       stop
+    !      endif
+    !      if (annee_ref.eq.2006 .and. day1.gt.day_cas+1) then
+    !       print*,'AMMA a fini le 11 juillet'
+    !       print*,'Changer dayref ou nday dans run.def'
+    !       stop
+    !      endif
+    !      endif
+
+    ! Determine timestep relative to the 1st day:
+    !       timeit=(day-day1)*86400.
+    !       if (annee_ref.eq.1992) then
+    !        timeit=(day-day_cas)*86400.
+    !       else
+    !        timeit=(day+61.-1.)*86400. ! 61 days between Nov01 and Dec31 1992
+    !       endif
+    timeit=(day-day_ju_ini_cas)*86400
+    print *,'day=',day
+    print *,'day_ju_ini_cas=',day_ju_ini_cas
+    print *,'pdt_cas=',pdt_cas
+    print *,'timeit=',timeit
+    print *,'nt_cas=',nt_cas
+
+    ! Determine the closest observation times:
+    !       it_cas1=INT(timeit/pdt_cas)+1
+    !       it_cas2=it_cas1 + 1
+    !       time_cas1=(it_cas1-1)*pdt_cas
+    !       time_cas2=(it_cas2-1)*pdt_cas
+
+    it_cas1=INT(timeit/pdt_cas)+1
+    IF (it_cas1 .EQ. nt_cas) THEN
+       it_cas2=it_cas1 
+    ELSE
+       it_cas2=it_cas1 + 1
+    ENDIF
+    time_cas1=(it_cas1-1)*pdt_cas
+    time_cas2=(it_cas2-1)*pdt_cas
+    !     print *,'timeit,pdt_cas,nt_cas=',timeit,pdt_cas,nt_cas
+    !     print *,'it_cas1,it_cas2,time_cas1,time_cas2=',it_cas1,it_cas2,time_cas1,time_cas2
+
+    if (it_cas1 .gt. nt_cas) then 
+       write(*,*) 'PB-stop: day, day_ju_ini_cas,it_cas1, it_cas2, timeit: '            &
+            ,day,day_ju_ini_cas,it_cas1,it_cas2,timeit
+       stop
+    endif
+
+    ! time interpolation:
+    IF (it_cas1 .EQ. it_cas2) THEN
+       frac=0.
+    ELSE
+       frac=(time_cas2-timeit)/(time_cas2-time_cas1)
+       frac=max(frac,0.0)
+    ENDIF
+
+    lat_prof_cas = lat_cas(it_cas2)                                   &
+         -frac*(lat_cas(it_cas2)-lat_cas(it_cas1)) 
+    sens_prof_cas = sens_cas(it_cas2)                                 &
+         -frac*(sens_cas(it_cas2)-sens_cas(it_cas1))
+    tkes_prof_cas = tkes_cas(it_cas2)                                   &
+         -frac*(tkes_cas(it_cas2)-tkes_cas(it_cas1))
+    ts_prof_cas = ts_cas(it_cas2)                                     &
+         -frac*(ts_cas(it_cas2)-ts_cas(it_cas1))
+    tskin_prof_cas = tskin_cas(it_cas2)                                     &
+         -frac*(tskin_cas(it_cas2)-tskin_cas(it_cas1))
+    ps_prof_cas = ps_cas(it_cas2)                                     &
+         -frac*(ps_cas(it_cas2)-ps_cas(it_cas1))
+    ustar_prof_cas = ustar_cas(it_cas2)                               &
+         -frac*(ustar_cas(it_cas2)-ustar_cas(it_cas1))
+
+    do k=1,nlev_cas
+       plev_prof_cas(k) = plev_cas(k,it_cas2)                           &     
+            -frac*(plev_cas(k,it_cas2)-plev_cas(k,it_cas1))
+       t_prof_cas(k) = t_cas(k,it_cas2)                                 &        
+            -frac*(t_cas(k,it_cas2)-t_cas(k,it_cas1))
+       !print *,'k,frac,plev_cas1,plev_cas2=',k,frac,plev_cas(k,it_cas1),plev_cas(k,it_cas2)
+       theta_prof_cas(k) = theta_cas(k,it_cas2)                         &                      
+            -frac*(theta_cas(k,it_cas2)-theta_cas(k,it_cas1))
+       thv_prof_cas(k) = thv_cas(k,it_cas2)                             &          
+            -frac*(thv_cas(k,it_cas2)-thv_cas(k,it_cas1))
+       thl_prof_cas(k) = thl_cas(k,it_cas2)                             &              
+            -frac*(thl_cas(k,it_cas2)-thl_cas(k,it_cas1))
+       qv_prof_cas(k) = qv_cas(k,it_cas2)                               &
+            -frac*(qv_cas(k,it_cas2)-qv_cas(k,it_cas1))
+       ql_prof_cas(k) = ql_cas(k,it_cas2)                               &
+            -frac*(ql_cas(k,it_cas2)-ql_cas(k,it_cas1))
+       qi_prof_cas(k) = qi_cas(k,it_cas2)                               &
+            -frac*(qi_cas(k,it_cas2)-qi_cas(k,it_cas1))
+       u_prof_cas(k) = u_cas(k,it_cas2)                                 &
+            -frac*(u_cas(k,it_cas2)-u_cas(k,it_cas1))
+       v_prof_cas(k) = v_cas(k,it_cas2)                                 &
+            -frac*(v_cas(k,it_cas2)-v_cas(k,it_cas1))
+       ug_prof_cas(k) = ug_cas(k,it_cas2)                               &
+            -frac*(ug_cas(k,it_cas2)-ug_cas(k,it_cas1))
+       vg_prof_cas(k) = vg_cas(k,it_cas2)                               &
+            -frac*(vg_cas(k,it_cas2)-vg_cas(k,it_cas1))
+       temp_nudg_prof_cas(k) = temp_nudg_cas(k,it_cas2)                    &
+            -frac*(temp_nudg_cas(k,it_cas2)-temp_nudg_cas(k,it_cas1))
+       qv_nudg_prof_cas(k) = qv_nudg_cas(k,it_cas2)                        &
+            -frac*(qv_nudg_cas(k,it_cas2)-qv_nudg_cas(k,it_cas1))
+       u_nudg_prof_cas(k) = u_nudg_cas(k,it_cas2)                          &
+            -frac*(u_nudg_cas(k,it_cas2)-u_nudg_cas(k,it_cas1))
+       v_nudg_prof_cas(k) = v_nudg_cas(k,it_cas2)                          &
+            -frac*(v_nudg_cas(k,it_cas2)-v_nudg_cas(k,it_cas1))
+       invtau_temp_nudg_prof_cas(k) = invtau_temp_nudg_cas(k,it_cas2)                    &
+            -frac*(invtau_temp_nudg_cas(k,it_cas2)-invtau_temp_nudg_cas(k,it_cas1))
+       invtau_qv_nudg_prof_cas(k) = invtau_qv_nudg_cas(k,it_cas2)                        &
+            -frac*(invtau_qv_nudg_cas(k,it_cas2)-invtau_qv_nudg_cas(k,it_cas1))
+       invtau_u_nudg_prof_cas(k) = invtau_u_nudg_cas(k,it_cas2)                          &
+            -frac*(invtau_u_nudg_cas(k,it_cas2)-invtau_u_nudg_cas(k,it_cas1))
+       invtau_v_nudg_prof_cas(k) = invtau_v_nudg_cas(k,it_cas2)                          &
+            -frac*(invtau_v_nudg_cas(k,it_cas2)-invtau_v_nudg_cas(k,it_cas1))
+       vitw_prof_cas(k) = vitw_cas(k,it_cas2)                           &
+            -frac*(vitw_cas(k,it_cas2)-vitw_cas(k,it_cas1))
+       omega_prof_cas(k) = omega_cas(k,it_cas2)                         &
+            -frac*(omega_cas(k,it_cas2)-omega_cas(k,it_cas1))
+       tke_prof_cas(k) = tke_cas(k,it_cas2)                         &
+            -frac*(tke_cas(k,it_cas2)-tke_cas(k,it_cas1))
+       du_prof_cas(k) = du_cas(k,it_cas2)                               &
+            -frac*(du_cas(k,it_cas2)-du_cas(k,it_cas1))
+       hu_prof_cas(k) = hu_cas(k,it_cas2)                               &
+            -frac*(hu_cas(k,it_cas2)-hu_cas(k,it_cas1))
+       vu_prof_cas(k) = vu_cas(k,it_cas2)                               &
+            -frac*(vu_cas(k,it_cas2)-vu_cas(k,it_cas1))
+       dv_prof_cas(k) = dv_cas(k,it_cas2)                               &
+            -frac*(dv_cas(k,it_cas2)-dv_cas(k,it_cas1))
+       hv_prof_cas(k) = hv_cas(k,it_cas2)                               &
+            -frac*(hv_cas(k,it_cas2)-hv_cas(k,it_cas1))
+       vv_prof_cas(k) = vv_cas(k,it_cas2)                               &
+            -frac*(vv_cas(k,it_cas2)-vv_cas(k,it_cas1))
+       dt_prof_cas(k) = dt_cas(k,it_cas2)                               &
+            -frac*(dt_cas(k,it_cas2)-dt_cas(k,it_cas1))
+       ht_prof_cas(k) = ht_cas(k,it_cas2)                               &
+            -frac*(ht_cas(k,it_cas2)-ht_cas(k,it_cas1))
+       vt_prof_cas(k) = vt_cas(k,it_cas2)                               &
+            -frac*(vt_cas(k,it_cas2)-vt_cas(k,it_cas1))
+       dth_prof_cas(k) = dth_cas(k,it_cas2)                             &
+            -frac*(dth_cas(k,it_cas2)-dth_cas(k,it_cas1))
+       hth_prof_cas(k) = hth_cas(k,it_cas2)                             &
+            -frac*(hth_cas(k,it_cas2)-hth_cas(k,it_cas1))
+       vth_prof_cas(k) = vth_cas(k,it_cas2)                             &
+            -frac*(vth_cas(k,it_cas2)-vth_cas(k,it_cas1))
+       dtrad_prof_cas(k) = dtrad_cas(k,it_cas2)                         &
+            -frac*(dtrad_cas(k,it_cas2)-dtrad_cas(k,it_cas1))
+       dq_prof_cas(k) = dq_cas(k,it_cas2)                               &
+            -frac*(dq_cas(k,it_cas2)-dq_cas(k,it_cas1))
+       hq_prof_cas(k) = hq_cas(k,it_cas2)                               &
+            -frac*(hq_cas(k,it_cas2)-hq_cas(k,it_cas1))
+       vq_prof_cas(k) = vq_cas(k,it_cas2)                               &
+            -frac*(vq_cas(k,it_cas2)-vq_cas(k,it_cas1))
+       uw_prof_cas(k) = uw_cas(k,it_cas2)                                &
+            -frac*(uw_cas(k,it_cas2)-uw_cas(k,it_cas1))
+       vw_prof_cas(k) = vw_cas(k,it_cas2)                                &
+            -frac*(vw_cas(k,it_cas2)-vw_cas(k,it_cas1))
+       q1_prof_cas(k) = q1_cas(k,it_cas2)                                &
+            -frac*(q1_cas(k,it_cas2)-q1_cas(k,it_cas1))
+       q2_prof_cas(k) = q2_cas(k,it_cas2)                                &
+            -frac*(q2_cas(k,it_cas2)-q2_cas(k,it_cas1))
+    enddo
+
+    return
+  END SUBROUTINE interp_case_time_std
+
+  !**********************************************************************************************
+  !=====================================================================
+  SUBROUTINE interp2_case_vertical_std(play,plev,nlev_cas,plev_prof_cas                           &
+       ,t_prof_cas,th_prof_cas,thv_prof_cas,thl_prof_cas                                       &
+       ,qv_prof_cas,ql_prof_cas,qi_prof_cas,u_prof_cas,v_prof_cas                              &
+       ,ug_prof_cas,vg_prof_cas                                                                &
+       ,temp_nudg_prof_cas,qv_nudg_prof_cas,u_nudg_prof_cas,v_nudg_prof_cas                    &
+       ,invtau_temp_nudg_prof_cas,invtau_qv_nudg_prof_cas,invtau_u_nudg_prof_cas,invtau_v_nudg_prof_cas &     
+       ,vitw_prof_cas,omega_prof_cas,tke_prof_cas                                              &
+       ,du_prof_cas,hu_prof_cas,vu_prof_cas,dv_prof_cas,hv_prof_cas,vv_prof_cas                &
+       ,dt_prof_cas,ht_prof_cas,vt_prof_cas,dtrad_prof_cas,dq_prof_cas,hq_prof_cas,vq_prof_cas &
+       ,dth_prof_cas,hth_prof_cas,vth_prof_cas                                                 &
+       !
+       ,t_mod_cas,theta_mod_cas,thv_mod_cas,thl_mod_cas                                        &
+       ,qv_mod_cas,ql_mod_cas,qi_mod_cas,u_mod_cas,v_mod_cas                                   &
+       ,ug_mod_cas,vg_mod_cas                                                                  &
+       ,temp_nudg_mod_cas,qv_nudg_mod_cas,u_nudg_mod_cas,v_nudg_mod_cas                        &
+       ,invtau_temp_nudg_mod_cas,invtau_qv_nudg_mod_cas,invtau_u_nudg_mod_cas,invtau_v_nudg_mod_cas                        &     
+       ,w_mod_cas,omega_mod_cas,tke_mod_cas                                                    &
+       ,du_mod_cas,hu_mod_cas,vu_mod_cas,dv_mod_cas,hv_mod_cas,vv_mod_cas                      &
+       ,dt_mod_cas,ht_mod_cas,vt_mod_cas,dtrad_mod_cas,dq_mod_cas,hq_mod_cas,vq_mod_cas        &
+       ,dth_mod_cas,hth_mod_cas,vth_mod_cas,mxcalc)
+
+    implicit none
+
+    INCLUDE "YOMCST.h"
+    INCLUDE "dimensions.h"
+
+    !-------------------------------------------------------------------------
+    ! Vertical interpolation of generic case forcing data onto mod_casel levels
+    !-------------------------------------------------------------------------
+
+    integer nlevmax
+    parameter (nlevmax=41)
+    integer nlev_cas,mxcalc
+    !       real play(llm), plev_prof(nlevmax) 
+    !       real t_prof(nlevmax),q_prof(nlevmax)
+    !       real u_prof(nlevmax),v_prof(nlevmax), w_prof(nlevmax)
+    !       real ht_prof(nlevmax),vt_prof(nlevmax)
+    !       real hq_prof(nlevmax),vq_prof(nlevmax)
+
+    real play(llm), plev(llm+1), plev_prof_cas(nlev_cas) 
+    real t_prof_cas(nlev_cas),th_prof_cas(nlev_cas),thv_prof_cas(nlev_cas),thl_prof_cas(nlev_cas)
+    real qv_prof_cas(nlev_cas),ql_prof_cas(nlev_cas),qi_prof_cas(nlev_cas)
+    real u_prof_cas(nlev_cas),v_prof_cas(nlev_cas)
+    real ug_prof_cas(nlev_cas),vg_prof_cas(nlev_cas), vitw_prof_cas(nlev_cas),omega_prof_cas(nlev_cas),tke_prof_cas(nlev_cas)
+    real temp_nudg_prof_cas(nlev_cas),qv_nudg_prof_cas(nlev_cas)
+    real u_nudg_prof_cas(nlev_cas),v_nudg_prof_cas(nlev_cas)
+    real invtau_temp_nudg_prof_cas(nlev_cas),invtau_qv_nudg_prof_cas(nlev_cas)
+    real invtau_u_nudg_prof_cas(nlev_cas),invtau_v_nudg_prof_cas(nlev_cas)
+
+    real du_prof_cas(nlev_cas),hu_prof_cas(nlev_cas),vu_prof_cas(nlev_cas)
+    real dv_prof_cas(nlev_cas),hv_prof_cas(nlev_cas),vv_prof_cas(nlev_cas)
+    real dt_prof_cas(nlev_cas),ht_prof_cas(nlev_cas),vt_prof_cas(nlev_cas),dtrad_prof_cas(nlev_cas)
+    real dth_prof_cas(nlev_cas),hth_prof_cas(nlev_cas),vth_prof_cas(nlev_cas)
+    real dq_prof_cas(nlev_cas),hq_prof_cas(nlev_cas),vq_prof_cas(nlev_cas)
+
+    real t_mod_cas(llm),theta_mod_cas(llm),thv_mod_cas(llm),thl_mod_cas(llm)
+    real qv_mod_cas(llm),ql_mod_cas(llm),qi_mod_cas(llm)
+    real u_mod_cas(llm),v_mod_cas(llm)
+    real ug_mod_cas(llm),vg_mod_cas(llm), w_mod_cas(llm),omega_mod_cas(llm),tke_mod_cas(llm+1)
+    real temp_nudg_mod_cas(llm),qv_nudg_mod_cas(llm)
+    real u_nudg_mod_cas(llm),v_nudg_mod_cas(llm)
+    real invtau_temp_nudg_mod_cas(llm),invtau_qv_nudg_mod_cas(llm)
+    real invtau_u_nudg_mod_cas(llm),invtau_v_nudg_mod_cas(llm)
+    real du_mod_cas(llm),hu_mod_cas(llm),vu_mod_cas(llm)
+    real dv_mod_cas(llm),hv_mod_cas(llm),vv_mod_cas(llm)
+    real dt_mod_cas(llm),ht_mod_cas(llm),vt_mod_cas(llm),dtrad_mod_cas(llm)
+    real dth_mod_cas(llm),hth_mod_cas(llm),vth_mod_cas(llm)
+    real dq_mod_cas(llm),hq_mod_cas(llm),vq_mod_cas(llm)
+
+    integer l,k,k1,k2
+    real frac,frac1,frac2,fact
+
+
+
+    ! for variables defined at the middle of layers
+
+    do l = 1, llm
+
+       if (play(l).ge.plev_prof_cas(nlev_cas)) then
+
+          mxcalc=l
+          !        print *,'debut interp2, mxcalc=',mxcalc
+          k1=0
+          k2=0
+
+          if (play(l).le.plev_prof_cas(1)) then
+
+             do k = 1, nlev_cas-1
+                if (play(l).le.plev_prof_cas(k).and. play(l).gt.plev_prof_cas(k+1)) then
+                   k1=k
+                   k2=k+1
+                endif
+             enddo
+
+             if (k1.eq.0 .or. k2.eq.0) then
+                write(*,*) 'PB! k1, k2 = ',k1,k2
+                write(*,*) 'l,play(l) = ',l,play(l)/100
+                do k = 1, nlev_cas-1
+                   write(*,*) 'k,plev_prof_cas(k) = ',k,plev_prof_cas(k)/100
+                enddo
+             endif
+
+
+
+             frac = (plev_prof_cas(k2)-play(l))/(plev_prof_cas(k2)-plev_prof_cas(k1))
+
+             t_mod_cas(l)= t_prof_cas(k2) - frac*(t_prof_cas(k2)-t_prof_cas(k1))
+             theta_mod_cas(l)= th_prof_cas(k2) - frac*(th_prof_cas(k2)-th_prof_cas(k1))
+             if(theta_mod_cas(l).NE.0) t_mod_cas(l)= theta_mod_cas(l)*(play(l)/100000.)**(RD/RCPD)
+             thv_mod_cas(l)= thv_prof_cas(k2) - frac*(thv_prof_cas(k2)-thv_prof_cas(k1))
+             thl_mod_cas(l)= thl_prof_cas(k2) - frac*(thl_prof_cas(k2)-thl_prof_cas(k1))
+             qv_mod_cas(l)= qv_prof_cas(k2) - frac*(qv_prof_cas(k2)-qv_prof_cas(k1))
+             ql_mod_cas(l)= ql_prof_cas(k2) - frac*(ql_prof_cas(k2)-ql_prof_cas(k1))
+             qi_mod_cas(l)= qi_prof_cas(k2) - frac*(qi_prof_cas(k2)-qi_prof_cas(k1))
+             u_mod_cas(l)= u_prof_cas(k2) - frac*(u_prof_cas(k2)-u_prof_cas(k1))
+             v_mod_cas(l)= v_prof_cas(k2) - frac*(v_prof_cas(k2)-v_prof_cas(k1))
+             ug_mod_cas(l)= ug_prof_cas(k2) - frac*(ug_prof_cas(k2)-ug_prof_cas(k1))
+             vg_mod_cas(l)= vg_prof_cas(k2) - frac*(vg_prof_cas(k2)-vg_prof_cas(k1))
+             temp_nudg_mod_cas(l)= temp_nudg_prof_cas(k2) - frac*(temp_nudg_prof_cas(k2)-temp_nudg_prof_cas(k1))
+             qv_nudg_mod_cas(l)= qv_nudg_prof_cas(k2) - frac*(qv_nudg_prof_cas(k2)-qv_nudg_prof_cas(k1))
+             u_nudg_mod_cas(l)= u_nudg_prof_cas(k2) - frac*(u_nudg_prof_cas(k2)-u_nudg_prof_cas(k1))
+             v_nudg_mod_cas(l)= v_nudg_prof_cas(k2) - frac*(v_nudg_prof_cas(k2)-v_nudg_prof_cas(k1))
+
+             invtau_temp_nudg_mod_cas(l)= invtau_temp_nudg_prof_cas(k2) &
+                  - frac*(invtau_temp_nudg_prof_cas(k2)-invtau_temp_nudg_prof_cas(k1))
+             invtau_qv_nudg_mod_cas(l)= invtau_qv_nudg_prof_cas(k2) - frac*(invtau_qv_nudg_prof_cas(k2)-invtau_qv_nudg_prof_cas(k1))
+             invtau_u_nudg_mod_cas(l)= invtau_u_nudg_prof_cas(k2) - frac*(invtau_u_nudg_prof_cas(k2)-invtau_u_nudg_prof_cas(k1))
+             invtau_v_nudg_mod_cas(l)= invtau_v_nudg_prof_cas(k2) - frac*(invtau_v_nudg_prof_cas(k2)-invtau_v_nudg_prof_cas(k1))
+
+             w_mod_cas(l)= vitw_prof_cas(k2) - frac*(vitw_prof_cas(k2)-vitw_prof_cas(k1))
+             omega_mod_cas(l)= omega_prof_cas(k2) - frac*(omega_prof_cas(k2)-omega_prof_cas(k1))
+             du_mod_cas(l)= du_prof_cas(k2) - frac*(du_prof_cas(k2)-du_prof_cas(k1))
+             hu_mod_cas(l)= hu_prof_cas(k2) - frac*(hu_prof_cas(k2)-hu_prof_cas(k1))
+             vu_mod_cas(l)= vu_prof_cas(k2) - frac*(vu_prof_cas(k2)-vu_prof_cas(k1))
+             dv_mod_cas(l)= dv_prof_cas(k2) - frac*(dv_prof_cas(k2)-dv_prof_cas(k1))
+             hv_mod_cas(l)= hv_prof_cas(k2) - frac*(hv_prof_cas(k2)-hv_prof_cas(k1))
+             vv_mod_cas(l)= vv_prof_cas(k2) - frac*(vv_prof_cas(k2)-vv_prof_cas(k1))
+             dt_mod_cas(l)= dt_prof_cas(k2) - frac*(dt_prof_cas(k2)-dt_prof_cas(k1))
+             ht_mod_cas(l)= ht_prof_cas(k2) - frac*(ht_prof_cas(k2)-ht_prof_cas(k1))
+             vt_mod_cas(l)= vt_prof_cas(k2) - frac*(vt_prof_cas(k2)-vt_prof_cas(k1))
+             dth_mod_cas(l)= dth_prof_cas(k2) - frac*(dth_prof_cas(k2)-dth_prof_cas(k1))
+             hth_mod_cas(l)= hth_prof_cas(k2) - frac*(hth_prof_cas(k2)-hth_prof_cas(k1))
+             vth_mod_cas(l)= vth_prof_cas(k2) - frac*(vth_prof_cas(k2)-vth_prof_cas(k1))
+             dq_mod_cas(l)= dq_prof_cas(k2) - frac*(dq_prof_cas(k2)-dq_prof_cas(k1))
+             hq_mod_cas(l)= hq_prof_cas(k2) - frac*(hq_prof_cas(k2)-hq_prof_cas(k1))
+             vq_mod_cas(l)= vq_prof_cas(k2) - frac*(vq_prof_cas(k2)-vq_prof_cas(k1))
+             dtrad_mod_cas(l)= dtrad_prof_cas(k2) - frac*(dtrad_prof_cas(k2)-dtrad_prof_cas(k1))
+
+          else !play>plev_prof_cas(1)
+
+             k1=1
+             k2=2
+             print *,'interp2_vert, k1,k2=',plev_prof_cas(k1),plev_prof_cas(k2)
+             frac1 = (play(l)-plev_prof_cas(k2))/(plev_prof_cas(k1)-plev_prof_cas(k2))
+             frac2 = (play(l)-plev_prof_cas(k1))/(plev_prof_cas(k1)-plev_prof_cas(k2))
+             t_mod_cas(l)= frac1*t_prof_cas(k1) - frac2*t_prof_cas(k2)
+             theta_mod_cas(l)= frac1*th_prof_cas(k1) - frac2*th_prof_cas(k2)
+             if(theta_mod_cas(l).NE.0) t_mod_cas(l)= theta_mod_cas(l)*(play(l)/100000.)**(RD/RCPD)
+             thv_mod_cas(l)= frac1*thv_prof_cas(k1) - frac2*thv_prof_cas(k2)
+             thl_mod_cas(l)= frac1*thl_prof_cas(k1) - frac2*thl_prof_cas(k2)
+             qv_mod_cas(l)= frac1*qv_prof_cas(k1) - frac2*qv_prof_cas(k2)
+             ql_mod_cas(l)= frac1*ql_prof_cas(k1) - frac2*ql_prof_cas(k2)
+             qi_mod_cas(l)= frac1*qi_prof_cas(k1) - frac2*qi_prof_cas(k2)
+             u_mod_cas(l)= frac1*u_prof_cas(k1) - frac2*u_prof_cas(k2)
+             v_mod_cas(l)= frac1*v_prof_cas(k1) - frac2*v_prof_cas(k2)
+             ug_mod_cas(l)= frac1*ug_prof_cas(k1) - frac2*ug_prof_cas(k2)
+             vg_mod_cas(l)= frac1*vg_prof_cas(k1) - frac2*vg_prof_cas(k2)
+             temp_nudg_mod_cas(l)= frac1*temp_nudg_prof_cas(k1) - frac2*temp_nudg_prof_cas(k2)
+             qv_nudg_mod_cas(l)= frac1*qv_nudg_prof_cas(k1) - frac2*qv_nudg_prof_cas(k2)
+             u_nudg_mod_cas(l)= frac1*u_nudg_prof_cas(k1) - frac2*u_nudg_prof_cas(k2)
+             v_nudg_mod_cas(l)= frac1*v_nudg_prof_cas(k1) - frac2*v_nudg_prof_cas(k2)
+
+             invtau_temp_nudg_mod_cas(l)= frac1*invtau_temp_nudg_prof_cas(k1) - frac2*invtau_temp_nudg_prof_cas(k2)
+             invtau_qv_nudg_mod_cas(l)= frac1*invtau_qv_nudg_prof_cas(k1) - frac2*invtau_qv_nudg_prof_cas(k2)
+             invtau_u_nudg_mod_cas(l)= frac1*invtau_u_nudg_prof_cas(k1) - frac2*invtau_u_nudg_prof_cas(k2)
+             invtau_v_nudg_mod_cas(l)= frac1*invtau_v_nudg_prof_cas(k1) - frac2*invtau_v_nudg_prof_cas(k2)
+
+             w_mod_cas(l)= frac1*vitw_prof_cas(k1) - frac2*vitw_prof_cas(k2)
+             omega_mod_cas(l)= frac1*omega_prof_cas(k1) - frac2*omega_prof_cas(k2)
+             du_mod_cas(l)= frac1*du_prof_cas(k1) - frac2*du_prof_cas(k2)
+             hu_mod_cas(l)= frac1*hu_prof_cas(k1) - frac2*hu_prof_cas(k2)
+             vu_mod_cas(l)= frac1*vu_prof_cas(k1) - frac2*vu_prof_cas(k2)
+             dv_mod_cas(l)= frac1*dv_prof_cas(k1) - frac2*dv_prof_cas(k2)
+             hv_mod_cas(l)= frac1*hv_prof_cas(k1) - frac2*hv_prof_cas(k2)
+             vv_mod_cas(l)= frac1*vv_prof_cas(k1) - frac2*vv_prof_cas(k2)
+             dt_mod_cas(l)= frac1*dt_prof_cas(k1) - frac2*dt_prof_cas(k2)
+             ht_mod_cas(l)= frac1*ht_prof_cas(k1) - frac2*ht_prof_cas(k2)
+             vt_mod_cas(l)= frac1*vt_prof_cas(k1) - frac2*vt_prof_cas(k2)
+             dth_mod_cas(l)= frac1*dth_prof_cas(k1) - frac2*dth_prof_cas(k2)
+             hth_mod_cas(l)= frac1*hth_prof_cas(k1) - frac2*hth_prof_cas(k2)
+             vth_mod_cas(l)= frac1*vth_prof_cas(k1) - frac2*vth_prof_cas(k2)
+             dq_mod_cas(l)= frac1*dq_prof_cas(k1) - frac2*dq_prof_cas(k2)
+             hq_mod_cas(l)= frac1*hq_prof_cas(k1) - frac2*hq_prof_cas(k2)
+             vq_mod_cas(l)= frac1*vq_prof_cas(k1) - frac2*vq_prof_cas(k2)
+             dtrad_mod_cas(l)= frac1*dtrad_prof_cas(k1) - frac2*dtrad_prof_cas(k2)
+
+          endif ! play.le.plev_prof_cas(1)
+
+       else ! above max altitude of forcing file
+
+          !jyg
+          fact=20.*(plev_prof_cas(nlev_cas)-play(l))/plev_prof_cas(nlev_cas) !jyg
+          fact = max(fact,0.)                                           !jyg
+          fact = exp(-fact)                                             !jyg
+          t_mod_cas(l)= t_prof_cas(nlev_cas)                            !jyg
+          theta_mod_cas(l)= th_prof_cas(nlev_cas)                       !jyg
+          thv_mod_cas(l)= thv_prof_cas(nlev_cas)                        !jyg
+          thl_mod_cas(l)= thl_prof_cas(nlev_cas)                        !jyg
+          qv_mod_cas(l)= qv_prof_cas(nlev_cas)*fact                     !jyg
+          ql_mod_cas(l)= ql_prof_cas(nlev_cas)*fact                     !jyg
+          qi_mod_cas(l)= qi_prof_cas(nlev_cas)*fact                     !jyg
+          u_mod_cas(l)= u_prof_cas(nlev_cas)*fact                       !jyg
+          v_mod_cas(l)= v_prof_cas(nlev_cas)*fact                       !jyg
+          ug_mod_cas(l)= ug_prof_cas(nlev_cas)                          !jyg
+          vg_mod_cas(l)= vg_prof_cas(nlev_cas)                          !jyg
+          temp_nudg_mod_cas(l)= temp_nudg_prof_cas(nlev_cas)            !jyg
+          qv_nudg_mod_cas(l)= qv_nudg_prof_cas(nlev_cas)                !jyg
+          u_nudg_mod_cas(l)= u_nudg_prof_cas(nlev_cas)                  !jyg
+          v_nudg_mod_cas(l)= v_nudg_prof_cas(nlev_cas)                  !jyg
+
+          invtau_temp_nudg_mod_cas(l)= invtau_temp_nudg_prof_cas(nlev_cas)            !jyg
+          invtau_qv_nudg_mod_cas(l)= invtau_qv_nudg_prof_cas(nlev_cas)                !jyg
+          invtau_u_nudg_mod_cas(l)= invtau_u_nudg_prof_cas(nlev_cas)                  !jyg
+          invtau_v_nudg_mod_cas(l)= invtau_v_nudg_prof_cas(nlev_cas)                  !jyg
+
+          thv_mod_cas(l)= thv_prof_cas(nlev_cas)                        !jyg
+          w_mod_cas(l)= 0.0                                             !jyg
+          omega_mod_cas(l)= 0.0                                         !jyg
+          du_mod_cas(l)= du_prof_cas(nlev_cas)*fact 
+          hu_mod_cas(l)= hu_prof_cas(nlev_cas)*fact                     !jyg
+          vu_mod_cas(l)= vu_prof_cas(nlev_cas)*fact                     !jyg
+          dv_mod_cas(l)= dv_prof_cas(nlev_cas)*fact
+          hv_mod_cas(l)= hv_prof_cas(nlev_cas)*fact                     !jyg
+          vv_mod_cas(l)= vv_prof_cas(nlev_cas)*fact                     !jyg
+          dt_mod_cas(l)= dt_prof_cas(nlev_cas) 
+          ht_mod_cas(l)= ht_prof_cas(nlev_cas)                          !jyg
+          vt_mod_cas(l)= vt_prof_cas(nlev_cas)                          !jyg
+          dth_mod_cas(l)= dth_prof_cas(nlev_cas) 
+          hth_mod_cas(l)= hth_prof_cas(nlev_cas)                        !jyg
+          vth_mod_cas(l)= vth_prof_cas(nlev_cas)                        !jyg
+          dq_mod_cas(l)= dq_prof_cas(nlev_cas)*fact 
+          hq_mod_cas(l)= hq_prof_cas(nlev_cas)*fact                     !jyg
+          vq_mod_cas(l)= vq_prof_cas(nlev_cas)*fact                     !jyg
+          dtrad_mod_cas(l)= dtrad_prof_cas(nlev_cas)*fact               !jyg
+
+       endif ! play
+
+    enddo ! l
+
+    ! for variables defined at layer interfaces (EV):
+
+
+    do l = 1, llm+1
+
+       if (plev(l).ge.plev_prof_cas(nlev_cas)) then
+
+          mxcalc=l
+          k1=0
+          k2=0
+
+          if (plev(l).le.plev_prof_cas(1)) then
+
+             do k = 1, nlev_cas-1
+                if (plev(l).le.plev_prof_cas(k).and. plev(l).gt.plev_prof_cas(k+1)) then
+                   k1=k
+                   k2=k+1
+                endif
+             enddo
+
+             if (k1.eq.0 .or. k2.eq.0) then
+                write(*,*) 'PB! k1, k2 = ',k1,k2
+                write(*,*) 'l,plev(l) = ',l,plev(l)/100
+                do k = 1, nlev_cas-1
+                   write(*,*) 'k,plev_prof_cas(k) = ',k,plev_prof_cas(k)/100
+                enddo
+             endif
+
+             frac = (plev_prof_cas(k2)-plev(l))/(plev_prof_cas(k2)-plev_prof_cas(k1))
+             tke_mod_cas(l)= tke_prof_cas(k2) - frac*(tke_prof_cas(k2)-tke_prof_cas(k1))
+          else !play>plev_prof_cas(1)
+             k1=1
+             k2=2
+             frac1 = (play(l)-plev_prof_cas(k2))/(plev_prof_cas(k1)-plev_prof_cas(k2))
+             frac2 = (play(l)-plev_prof_cas(k1))/(plev_prof_cas(k1)-plev_prof_cas(k2))
+             tke_mod_cas(l)= frac1*tke_prof_cas(k1) - frac2*tke_prof_cas(k2)
+
+          endif ! plev.le.plev_prof_cas(1)
+
+       else ! above max altitude of forcing file
+
+          tke_mod_cas(l)=0.0
+
+       endif ! plev
+
+    enddo ! l
+
+
+
+    return
+  end SUBROUTINE interp2_case_vertical_std
+  !***************************************************************************** 
+
+
+
+
+
+END MODULE mod_1D_cases_read_std
Index: DZ6/trunk/libf/phylmd/dyn1d/mod_const_mpi.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/dyn1d/mod_const_mpi.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../../dyn3d/mod_const_mpi.F90
Index: /LMDZ6/trunk/libf/phylmd/dyn1d/mod_const_mpi.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/dyn1d/mod_const_mpi.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/dyn1d/mod_const_mpi.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../../dyn3d/mod_const_mpi.f90
Index: DZ6/trunk/libf/phylmd/dyn1d/old_lmdz1d.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/dyn1d/old_lmdz1d.F90	(revision 5267)
+++ 	(revision )
@@ -1,1374 +1,0 @@
-!
-! $Id: lmdz1d.F90 3540 2019-06-25 14:50:13Z fairhead $
-!
-
-      SUBROUTINE old_lmdz1d
-
-   USE ioipsl, only: ju2ymds, ymds2ju, ioconf_calendar,getin
-   USE phys_state_var_mod, ONLY : phys_state_var_init, phys_state_var_end, &
-       clwcon, detr_therm, &
-       qsol, fevap, z0m, z0h, agesno, &
-       du_gwd_rando, du_gwd_front, entr_therm, f0, fm_therm, &
-       falb_dir, falb_dif, &
-       ftsol, beta_aridity, pbl_tke, pctsrf, radsol, rain_fall, snow_fall, ratqs, &
-       rnebcon, rugoro, sig1, w01, solaire_etat0, sollw, sollwdown, &
-       solsw, solswfdiff, t_ancien, q_ancien, u_ancien, v_ancien, &
-       wake_delta_pbl_TKE, delta_tsurf, wake_fip, wake_pe, &
-       wake_deltaq, wake_deltat, wake_s, awake_s, wake_dens, &
-       awake_dens, cv_gen, wake_cstar, &
-       zgam, zmax0, zmea, zpic, zsig, &
-       zstd, zthe, zval, ale_bl, ale_bl_trig, alp_bl, &
-       ql_ancien, qs_ancien, qbs_ancien, cf_ancien, rvc_ancien, &
-       prlw_ancien, prsw_ancien, prbsw_ancien, prw_ancien, &
-       u10m,v10m,ale_wake,ale_bl_stat
-
-  
-   USE dimphy
-   USE surface_data, only : type_ocean,ok_veget
-   USE pbl_surface_mod, only : ftsoil, pbl_surface_init, &
-                                 pbl_surface_final
-   USE fonte_neige_mod, only : fonte_neige_init, fonte_neige_final 
-
-   USE infotrac ! new
-   USE control_mod
-   USE indice_sol_mod
-   USE phyaqua_mod
-!  USE mod_1D_cases_read
-   USE mod_1D_cases_read2
-   USE mod_1D_amma_read
-   USE print_control_mod, ONLY: lunout, prt_level
-   USE iniphysiq_mod, ONLY: iniphysiq
-   USE mod_const_mpi, ONLY: comm_lmdz
-   USE physiq_mod, ONLY: physiq
-   USE comvert_mod, ONLY: presnivs, ap, bp, dpres,nivsig, nivsigs, pa, &
-                          preff, aps, bps, pseudoalt, scaleheight
-   USE temps_mod, ONLY: annee_ref, calend, day_end, day_ini, day_ref, &
-                        itau_dyn, itau_phy, start_time, year_len
-   USE phys_cal_mod, ONLY : year_len_phys_cal_mod => year_len
-   USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_OUTPUTPHYSSCM
-
-      implicit none
-      INCLUDE "dimensions.h"
-      INCLUDE "YOMCST.h"
-!!      INCLUDE "control.h"
-      INCLUDE "clesphys.h"
-      INCLUDE "dimsoil.h"
-!      INCLUDE "indicesol.h"
-
-      INCLUDE "compar1d.h"
-      INCLUDE "flux_arp.h"
-      INCLUDE "date_cas.h"
-      INCLUDE "tsoilnudge.h"
-      INCLUDE "fcg_gcssold.h"
-!!!      INCLUDE "fbforcing.h"
-      INCLUDE "compbl.h"
-
-!=====================================================================
-! DECLARATIONS
-!=====================================================================
-
-!---------------------------------------------------------------------
-!  Externals
-!---------------------------------------------------------------------
-      external fq_sat
-      real fq_sat
-
-!---------------------------------------------------------------------
-!  Arguments d' initialisations de la physique (USER DEFINE)
-!---------------------------------------------------------------------
-
-      integer, parameter :: ngrid=1
-      real :: zcufi    = 1.
-      real :: zcvfi    = 1.
-
-!-      real :: nat_surf
-!-      logical :: ok_flux_surf
-!-      real :: fsens
-!-      real :: flat
-!-      real :: tsurf
-!-      real :: rugos
-!-      real :: qsol(1:2)
-!-      real :: qsurf
-!-      real :: psurf
-!-      real :: zsurf
-!-      real :: albedo
-!-
-!-      real :: time     = 0.
-!-      real :: time_ini
-!-      real :: xlat 
-!-      real :: xlon 
-!-      real :: wtsurf 
-!-      real :: wqsurf 
-!-      real :: restart_runoff 
-!-      real :: xagesno 
-!-      real :: qsolinp 
-!-      real :: zpicinp 
-!-
-      real :: fnday 
-      real :: day, daytime 
-      real :: day1
-      real :: heure
-      integer :: jour
-      integer :: mois
-      integer :: an
- 
-!---------------------------------------------------------------------
-!  Declarations related to forcing and initial profiles 
-!---------------------------------------------------------------------
-
-        integer :: kmax = llm
-        integer llm700,nq1,nq2
-        INTEGER, PARAMETER :: nlev_max=1000, nqmx=1000
-        real timestep, frac
-        real height(nlev_max),tttprof(nlev_max),qtprof(nlev_max)
-        real  uprof(nlev_max),vprof(nlev_max),e12prof(nlev_max)
-        real  ugprof(nlev_max),vgprof(nlev_max),wfls(nlev_max)
-        real  dqtdxls(nlev_max),dqtdyls(nlev_max)
-        real  dqtdtls(nlev_max),thlpcar(nlev_max)
-        real  qprof(nlev_max,nqmx)
-
-!        integer :: forcing_type
-        logical :: forcing_les     = .false.
-        logical :: forcing_armcu   = .false.
-        logical :: forcing_rico    = .false.
-        logical :: forcing_radconv = .false.
-        logical :: forcing_toga    = .false.
-        logical :: forcing_twpice  = .false.
-        logical :: forcing_amma    = .false.
-        logical :: forcing_dice    = .false.
-        logical :: forcing_gabls4  = .false.
-
-        logical :: forcing_GCM2SCM = .false.
-        logical :: forcing_GCSSold = .false.
-        logical :: forcing_sandu   = .false.
-        logical :: forcing_astex   = .false.
-        logical :: forcing_fire    = .false.
-        logical :: forcing_case    = .false.
-        logical :: forcing_case2   = .false.
-        logical :: forcing_SCM   = .false.
-        integer :: type_ts_forcing ! 0 = SST constant; 1 = SST read from a file
-!                                                            (cf read_tsurf1d.F)
-
-real wwww
-!vertical advection computation
-!       real d_t_z(llm), d_q_z(llm)
-!       real d_t_dyn_z(llm), dq_dyn_z(llm)
-!       real zz(llm)
-!       real zfact
-
-!flag forcings
-        logical :: nudge_wind=.true.
-        logical :: nudge_thermo=.false.
-        logical :: cptadvw=.true.
-!=====================================================================
-! DECLARATIONS FOR EACH CASE
-!=====================================================================
-!
-      INCLUDE "old_1D_decl_cases.h"
-!
-!---------------------------------------------------------------------
-!  Declarations related to nudging
-!---------------------------------------------------------------------
-     integer :: nudge_max
-     parameter (nudge_max=9)
-     integer :: inudge_RHT=1
-     integer :: inudge_UV=2
-     logical :: nudge(nudge_max)
-     real :: t_targ(llm)
-     real :: rh_targ(llm)
-     real :: u_targ(llm)
-     real :: v_targ(llm)
-!
-!---------------------------------------------------------------------
-!  Declarations related to vertical discretization:
-!---------------------------------------------------------------------
-      real :: pzero=1.e5
-      real :: play (llm),zlay (llm),sig_s(llm),plev(llm+1)
-      real :: playd(llm),zlayd(llm),ap_amma(llm+1),bp_amma(llm+1)
-
-!---------------------------------------------------------------------
-!  Declarations related to variables
-!---------------------------------------------------------------------
-
-      real :: phi(llm)
-      real :: teta(llm),tetal(llm),temp(llm),u(llm),v(llm),w(llm)
-      REAL rot(1, llm) ! relative vorticity, in s-1
-      real :: rlat_rad(1),rlon_rad(1)
-      real :: omega(llm+1),omega2(llm),rho(llm+1)
-      real :: ug(llm),vg(llm),fcoriolis
-      real :: sfdt, cfdt
-      real :: du_phys(llm),dv_phys(llm),dt_phys(llm)
-      real :: dt_dyn(llm)
-      real :: dt_cooling(llm),d_t_adv(llm),d_t_nudge(llm)
-      real :: d_u_nudge(llm),d_v_nudge(llm)
-      real :: du_adv(llm),dv_adv(llm)
-      real :: du_age(llm),dv_age(llm)
-      real :: alpha
-      real :: ttt
-
-      REAL, ALLOCATABLE, DIMENSION(:,:):: q
-      REAL, ALLOCATABLE, DIMENSION(:,:):: dq
-      REAL, ALLOCATABLE, DIMENSION(:,:):: dq_dyn
-      REAL, ALLOCATABLE, DIMENSION(:,:):: d_q_adv
-      REAL, ALLOCATABLE, DIMENSION(:,:):: d_q_nudge
-!      REAL, ALLOCATABLE, DIMENSION(:):: d_th_adv
-
-!---------------------------------------------------------------------
-!  Initialization of surface variables
-!---------------------------------------------------------------------
-      real :: run_off_lic_0(1)
-      real :: fder(1),snsrf(1,nbsrf),qsurfsrf(1,nbsrf)
-      real :: tsoil(1,nsoilmx,nbsrf)
-!     real :: agesno(1,nbsrf)
-
-!---------------------------------------------------------------------
-!  Call to phyredem
-!---------------------------------------------------------------------
-      logical :: ok_writedem =.true.
-      real :: sollw_in = 0.
-      real :: solsw_in = 0.
-      
-!---------------------------------------------------------------------
-!  Call to physiq
-!---------------------------------------------------------------------
-      logical :: firstcall=.true.
-      logical :: lastcall=.false.
-      real :: phis(1)    = 0.0
-      real :: dpsrf(1)
-
-!---------------------------------------------------------------------
-!  Initializations of boundary conditions 
-!---------------------------------------------------------------------
-      real, allocatable :: phy_nat (:)  ! 0=ocean libre,1=land,2=glacier,3=banquise
-      real, allocatable :: phy_alb (:)  ! Albedo land only (old value condsurf_jyg=0.3)
-      real, allocatable :: phy_sst (:)  ! SST (will not be used; cf read_tsurf1d.F)
-      real, allocatable :: phy_bil (:)  ! Ne sert que pour les slab_ocean
-      real, allocatable :: phy_rug (:) ! Longueur rugosite utilisee sur land only
-      real, allocatable :: phy_ice (:) ! Fraction de glace
-      real, allocatable :: phy_fter(:) ! Fraction de terre
-      real, allocatable :: phy_foce(:) ! Fraction de ocean
-      real, allocatable :: phy_fsic(:) ! Fraction de glace
-      real, allocatable :: phy_flic(:) ! Fraction de glace
-
-!---------------------------------------------------------------------
-!  Fichiers et d'autres variables
-!---------------------------------------------------------------------
-      integer :: k,l,i,it=1,mxcalc
-      integer :: nsrf
-      integer jcode
-      INTEGER read_climoz 
-!
-      integer :: it_end ! iteration number of the last call
-!Al1
-      integer ecrit_slab_oc !1=ecrit,-1=lit,0=no file
-      data ecrit_slab_oc/-1/
-!
-!     if flag_inhib_forcing = 0, tendencies of forcing are added
-!                           <> 0, tendencies of forcing are not added
-      INTEGER :: flag_inhib_forcing = 0
-
-!=====================================================================
-! INITIALIZATIONS 
-!=====================================================================
-      du_phys(:)=0.
-      dv_phys(:)=0.
-      dt_phys(:)=0.
-      dt_dyn(:)=0.
-      dt_cooling(:)=0.
-      d_t_adv(:)=0.
-      d_t_nudge(:)=0.
-      d_u_nudge(:)=0.
-      d_v_nudge(:)=0.
-      du_adv(:)=0.
-      dv_adv(:)=0.
-      du_age(:)=0.
-      dv_age(:)=0.
-      
-! Initialization of Common turb_forcing
-       dtime_frcg = 0.
-       Turb_fcg_gcssold=.false.
-       hthturb_gcssold = 0.
-       hqturb_gcssold = 0.
-
-
-
-
-!---------------------------------------------------------------------
-! OPTIONS OF THE 1D SIMULATION (lmdz1d.def => unicol.def)
-!---------------------------------------------------------------------
-!Al1
-        call conf_unicol
-!Al1 moves this gcssold var from common fcg_gcssold to 
-        Turb_fcg_gcssold = xTurb_fcg_gcssold
-! --------------------------------------------------------------------
-        close(1)
-!Al1
-        write(*,*) 'lmdz1d.def lu => unicol.def'
-
-! forcing_type defines the way the SCM is forced:
-!forcing_type = 0 ==> forcing_les = .true.
-!             initial profiles from file prof.inp.001
-!             no forcing by LS convergence ; 
-!             surface temperature imposed ;
-!             radiative cooling may be imposed (iflag_radia=0 in physiq.def)
-!forcing_type = 1 ==> forcing_radconv = .true.
-!             idem forcing_type = 0, but the imposed radiative cooling 
-!             is set to 0 (hence, if iflag_radia=0 in physiq.def, 
-!             then there is no radiative cooling at all)
-!forcing_type = 2 ==> forcing_toga = .true.
-!             initial profiles from TOGA-COARE IFA files 
-!             LS convergence and SST imposed from TOGA-COARE IFA files 
-!forcing_type = 3 ==> forcing_GCM2SCM = .true.
-!             initial profiles from the GCM output
-!             LS convergence imposed from the GCM output
-!forcing_type = 4 ==> forcing_twpice = .true.
-!             initial profiles from TWP-ICE cdf file 
-!             LS convergence, omega and SST imposed from TWP-ICE files 
-!forcing_type = 5 ==> forcing_rico = .true.
-!             initial profiles from RICO files 
-!             LS convergence imposed from RICO files 
-!forcing_type = 6 ==> forcing_amma = .true.
-!             initial profiles from AMMA nc file 
-!             LS convergence, omega and surface fluxes imposed from AMMA file  
-!forcing_type = 7 ==> forcing_dice = .true.
-!             initial profiles and large scale forcings in dice_driver.nc
-!             Different stages: soil model alone, atm. model alone
-!             then both models coupled
-!forcing_type = 8 ==> forcing_gabls4 = .true.
-!             initial profiles and large scale forcings in gabls4_driver.nc
-!forcing_type >= 100 ==> forcing_case = .true.
-!             initial profiles and large scale forcings in cas.nc
-!             LS convergence, omega and SST imposed from CINDY-DYNAMO files 
-!             101=cindynamo
-!             102=bomex
-!forcing_type >= 100 ==> forcing_case2 = .true.
-!             temporary flag while all the 1D cases are not whith the same cas.nc forcing file
-!             103=arm_cu2 ie arm_cu with new forcing format
-!             104=rico2 ie rico with new forcing format
-!forcing_type = 40 ==> forcing_GCSSold = .true.
-!             initial profile from GCSS file
-!             LS convergence imposed from GCSS file
-!forcing_type = 50 ==> forcing_fire = .true.
-!             forcing from fire.nc
-!forcing_type = 59 ==> forcing_sandu = .true.
-!             initial profiles from sanduref file: see prof.inp.001
-!             SST varying with time and divergence constante: see ifa_sanduref.txt file
-!             Radiation has to be computed interactively
-!forcing_type = 60 ==> forcing_astex = .true.
-!             initial profiles from file: see prof.inp.001 
-!             SST,divergence,ug,vg,ufa,vfa varying with time : see ifa_astex.txt file
-!             Radiation has to be computed interactively
-!forcing_type = 61 ==> forcing_armcu = .true.
-!             initial profiles from file: see prof.inp.001 
-!             sensible and latent heat flux imposed: see ifa_arm_cu_1.txt
-!             large scale advective forcing & radiative tendencies applied below 1000m: see ifa_arm_cu_2.txt
-!             use geostrophic wind ug=10m/s vg=0m/s. Duration of the case 53100s 
-!             Radiation to be switched off
-!
-      if (forcing_type <=0) THEN
-       forcing_les = .true.
-      elseif (forcing_type .eq.1) THEN
-       forcing_radconv = .true.
-      elseif (forcing_type .eq.2) THEN
-       forcing_toga    = .true.
-      elseif (forcing_type .eq.3) THEN
-       forcing_GCM2SCM = .true.
-      elseif (forcing_type .eq.4) THEN
-       forcing_twpice = .true.
-      elseif (forcing_type .eq.5) THEN
-       forcing_rico = .true.
-      elseif (forcing_type .eq.6) THEN
-       forcing_amma = .true.
-      elseif (forcing_type .eq.7) THEN
-       forcing_dice = .true.
-      elseif (forcing_type .eq.8) THEN
-       forcing_gabls4 = .true.
-      elseif (forcing_type .eq.101) THEN ! Cindynamo starts 1-10-2011 0h
-       forcing_case = .true.
-       year_ini_cas=2011
-       mth_ini_cas=10
-       day_deb=1
-       heure_ini_cas=0.
-       pdt_cas=3*3600.         ! forcing frequency
-      elseif (forcing_type .eq.102) THEN ! Bomex starts 24-6-1969 0h
-       forcing_case = .true.
-       year_ini_cas=1969
-       mth_ini_cas=6
-       day_deb=24
-       heure_ini_cas=0.
-       pdt_cas=1800.         ! forcing frequency
-      elseif (forcing_type .eq.103) THEN ! Arm_cu starts 21-6-1997 11h30
-       forcing_case2 = .true.
-       year_ini_cas=1997
-       mth_ini_cas=6
-       day_deb=21
-       heure_ini_cas=11.5
-       pdt_cas=1800.         ! forcing frequency
-      elseif (forcing_type .eq.104) THEN ! rico starts 16-12-2004 0h
-       forcing_case2 = .true.
-       year_ini_cas=2004
-       mth_ini_cas=12
-       day_deb=16
-       heure_ini_cas=0.
-       pdt_cas=1800.         ! forcing frequency
-      elseif (forcing_type .eq.105) THEN ! bomex starts 16-12-2004 0h
-       forcing_case2 = .true.
-       year_ini_cas=1969
-       mth_ini_cas=6
-       day_deb=24
-       heure_ini_cas=0.
-       pdt_cas=1800.         ! forcing frequency
-      elseif (forcing_type .eq.106) THEN ! ayotte_24SC starts 6-11-1992 0h
-       forcing_case2 = .true.
-       year_ini_cas=1992
-       mth_ini_cas=11
-       day_deb=6
-       heure_ini_cas=10.
-       pdt_cas=86400.        ! forcing frequency
-      elseif (forcing_type .eq.113) THEN ! Arm_cu starts 21-6-1997 11h30
-       forcing_SCM = .true.
-       year_ini_cas=1997
-       ! It is possible that those parameters are run twice.
-       call getin('anneeref',year_ini_cas)
-       call getin('dayref',day_deb)
-       mth_ini_cas=1 ! pour le moment on compte depuis le debut de l'annee
-       call getin('time_ini',heure_ini_cas)
-      elseif (forcing_type .eq.40) THEN
-       forcing_GCSSold = .true.
-      elseif (forcing_type .eq.50) THEN
-       forcing_fire = .true.
-      elseif (forcing_type .eq.59) THEN
-       forcing_sandu   = .true.
-      elseif (forcing_type .eq.60) THEN
-       forcing_astex   = .true.
-      elseif (forcing_type .eq.61) THEN
-       forcing_armcu = .true.
-       IF(llm.NE.19.AND.llm.NE.40) stop 'Erreur nombre de niveaux !!'
-      else
-       write (*,*) 'ERROR : unknown forcing_type ', forcing_type
-       stop 'Forcing_type should be 0,1,2,3,4,5,6 or 40,59,60,61'
-      ENDIF
-      print*,"forcing type=",forcing_type
-
-! if type_ts_forcing=0, the surface temp of 1D simulation is constant in time
-! (specified by tsurf in lmdz1d.def); if type_ts_forcing=1, the surface temperature
-! varies in time according to a forcing (e.g. forcing_toga) and is passed to read_tsurf1d.F
-! through the common sst_forcing.
-
-        type_ts_forcing = 0
-        if (forcing_toga.or.forcing_sandu.or.forcing_astex .or. forcing_dice)                 &
-     &    type_ts_forcing = 1
-!
-! Initialization of the logical switch for nudging
-     jcode = iflag_nudge
-     do i = 1,nudge_max
-       nudge(i) = mod(jcode,10) .ge. 1
-       jcode = jcode/10
-     enddo
-!---------------------------------------------------------------------
-!  Definition of the run
-!---------------------------------------------------------------------
-
-      call conf_gcm( 99, .TRUE. )
-      
-!-----------------------------------------------------------------------
-      allocate( phy_nat (year_len))  ! 0=ocean libre,1=land,2=glacier,3=banquise
-      phy_nat(:)=0.0
-      allocate( phy_alb (year_len))  ! Albedo land only (old value condsurf_jyg=0.3)
-      allocate( phy_sst (year_len))  ! SST (will not be used; cf read_tsurf1d.F)
-      allocate( phy_bil (year_len))  ! Ne sert que pour les slab_ocean
-      phy_bil(:)=1.0
-      allocate( phy_rug (year_len)) ! Longueur rugosite utilisee sur land only
-      allocate( phy_ice (year_len)) ! Fraction de glace
-      phy_ice(:)=0.0
-      allocate( phy_fter(year_len)) ! Fraction de terre
-      phy_fter(:)=0.0
-      allocate( phy_foce(year_len)) ! Fraction de ocean
-      phy_foce(:)=0.0
-      allocate( phy_fsic(year_len)) ! Fraction de glace
-      phy_fsic(:)=0.0
-      allocate( phy_flic(year_len)) ! Fraction de glace
-      phy_flic(:)=0.0
-!-----------------------------------------------------------------------
-!   Choix du calendrier
-!   -------------------
-
-!      calend = 'earth_365d'
-      if (calend == 'earth_360d') then
-        call ioconf_calendar('360_day')
-        write(*,*)'CALENDRIER CHOISI: Terrestre a 360 jours/an'
-      else if (calend == 'earth_365d') then
-        call ioconf_calendar('noleap')
-        write(*,*)'CALENDRIER CHOISI: Terrestre a 365 jours/an'
-      else if (calend == 'earth_366d') then
-        call ioconf_calendar('all_leap')
-        write(*,*)'CALENDRIER CHOISI: Terrestre bissextile'
-      else if (calend == 'gregorian') then
-        stop 'gregorian calend should not be used by normal user'
-        call ioconf_calendar('gregorian') ! not to be used by normal users
-        write(*,*)'CALENDRIER CHOISI: Gregorien'
-      else
-        write (*,*) 'ERROR : unknown calendar ', calend
-        stop 'calend should be 360d,earth_365d,earth_366d,gregorian'
-      endif
-!-----------------------------------------------------------------------
-!
-!c Date :
-!      La date est supposee donnee sous la forme [annee, numero du jour dans 
-!      l annee] ; l heure est donnee dans time_ini, lu dans lmdz1d.def.
-!      On appelle ymds2ju pour convertir [annee, jour] en [jour Julien].
-!      Le numero du jour est dans "day". L heure est traitee separement.
-!      La date complete est dans "daytime" (l'unite est le jour).
-      if (nday>0) then
-         fnday=nday
-      else
-         fnday=-nday/float(day_step)
-      endif
-      print *,'fnday=',fnday
-!     start_time doit etre en FRACTION DE JOUR
-      start_time=time_ini/24.
-
-! Special case for arm_cu which lasts less than one day : 53100s !! (MPL 20111026)
-      IF(forcing_type .EQ. 61) fnday=53100./86400.
-      IF(forcing_type .EQ. 103) fnday=53100./86400.
-! Special case for amma which lasts less than one day : 64800s !! (MPL 20120216)
-      IF(forcing_type .EQ. 6) fnday=64800./86400.
-!     IF(forcing_type .EQ. 6) fnday=50400./86400.
- IF(forcing_type .EQ. 8 ) fnday=129600./86400. 
-      annee_ref = anneeref
-      mois = 1
-      day_ref = dayref
-      heure = 0.
-      itau_dyn = 0
-      itau_phy = 0
-      call ymds2ju(annee_ref,mois,day_ref,heure,day)
-      day_ini = int(day)
-      day_end = day_ini + int(fnday)
-
-      IF (forcing_type .eq.2) THEN
-! Convert the initial date of Toga-Coare to Julian day
-      call ymds2ju                                                          &
-     & (year_ini_toga,mth_ini_toga,day_ini_toga,heure,day_ju_ini_toga)
-
-      ELSEIF (forcing_type .eq.4) THEN
-! Convert the initial date of TWPICE to Julian day
-      call ymds2ju                                                          &
-     & (year_ini_twpi,mth_ini_twpi,day_ini_twpi,heure_ini_twpi              &
-     & ,day_ju_ini_twpi)
-      ELSEIF (forcing_type .eq.6) THEN
-! Convert the initial date of AMMA to Julian day
-      call ymds2ju                                                          &
-     & (year_ini_amma,mth_ini_amma,day_ini_amma,heure_ini_amma              &
-     & ,day_ju_ini_amma)
-      ELSEIF (forcing_type .eq.7) THEN
-! Convert the initial date of DICE to Julian day
-      call ymds2ju                                                         &
-     & (year_ini_dice,mth_ini_dice,day_ini_dice,heure_ini_dice             & 
-     & ,day_ju_ini_dice)
- ELSEIF (forcing_type .eq.8 ) THEN
-! Convert the initial date of GABLS4 to Julian day
-      call ymds2ju                                                         &
-     & (year_ini_gabls4,mth_ini_gabls4,day_ini_gabls4,heure_ini_gabls4     & 
-     & ,day_ju_ini_gabls4)
-      ELSEIF (forcing_type .gt.100) THEN
-! Convert the initial date to Julian day
-      day_ini_cas=day_deb
-      print*,'time case',year_ini_cas,mth_ini_cas,day_ini_cas
-      call ymds2ju                                                         &
-     & (year_ini_cas,mth_ini_cas,day_ini_cas,heure_ini_cas*3600            &
-     & ,day_ju_ini_cas)
-      print*,'time case 2',day_ini_cas,day_ju_ini_cas
-      ELSEIF (forcing_type .eq.59) THEN
-! Convert the initial date of Sandu case to Julian day
-      call ymds2ju                                                          &
-     &   (year_ini_sandu,mth_ini_sandu,day_ini_sandu,                       &
-     &    time_ini*3600.,day_ju_ini_sandu)
-
-      ELSEIF (forcing_type .eq.60) THEN
-! Convert the initial date of Astex case to Julian day
-      call ymds2ju                                                          &
-     &   (year_ini_astex,mth_ini_astex,day_ini_astex,                        &
-     &    time_ini*3600.,day_ju_ini_astex)
-
-      ELSEIF (forcing_type .eq.61) THEN
-! Convert the initial date of Arm_cu case to Julian day
-      call ymds2ju                                                          &
-     & (year_ini_armcu,mth_ini_armcu,day_ini_armcu,heure_ini_armcu          &
-     & ,day_ju_ini_armcu)
-      ENDIF
-
-      IF (forcing_type .gt.100) THEN
-      daytime = day + heure_ini_cas/24. ! 1st day and initial time of the simulation 
-      ELSE
-      daytime = day + time_ini/24. ! 1st day and initial time of the simulation 
-      ENDIF
-! Print out the actual date of the beginning of the simulation :
-      call ju2ymds(daytime,year_print, month_print,day_print,sec_print)
-      print *,' Time of beginning : ',                                      &
-     &        year_print, month_print, day_print, sec_print
-
-!---------------------------------------------------------------------
-! Initialization of dimensions, geometry and initial state
-!---------------------------------------------------------------------
-!      call init_phys_lmdz(1,1,llm,1,(/1/)) ! job now done via iniphysiq
-!     but we still need to initialize dimphy module (klon,klev,etc.)  here.
-      call init_dimphy1D(1,llm)
-      call suphel
-      call init_infotrac
-
-      if (nqtot>nqmx) STOP 'Augmenter nqmx dans lmdz1d.F'
-      allocate(q(llm,nqtot)) ; q(:,:)=0.
-      allocate(dq(llm,nqtot)) 
-      allocate(dq_dyn(llm,nqtot)) 
-      allocate(d_q_adv(llm,nqtot)) 
-      allocate(d_q_nudge(llm,nqtot)) 
-!      allocate(d_th_adv(llm)) 
-
-      q(:,:) = 0.
-      dq(:,:) = 0.
-      dq_dyn(:,:) = 0.
-      d_q_adv(:,:) = 0.
-      d_q_nudge(:,:) = 0.
-
-!
-!   No ozone climatology need be read in this pre-initialization
-!          (phys_state_var_init is called again in physiq)
-      read_climoz = 0
-      nsw=6          ! EV et LF: sinon, falb_dir et falb_dif ne peuvent etre alloues
-
-
-      call phys_state_var_init(read_climoz)
-
-      if (ngrid.ne.klon) then
-         print*,'stop in inifis'
-         print*,'Probleme de dimensions :'
-         print*,'ngrid = ',ngrid
-         print*,'klon  = ',klon
-         stop
-      endif
-!!!=====================================================================
-!!! Feedback forcing values for Gateaux differentiation (al1)
-!!!=====================================================================
-!!! Surface Planck forcing bracketing call radiation
-!!      surf_Planck = 0.
-!!      surf_Conv   = 0.
-!!      write(*,*) 'Gateaux-dif Planck,Conv:',surf_Planck,surf_Conv
-!!! a mettre dans le lmdz1d.def ou autre
-!!
-!!
-      qsol = qsolinp
-      qsurf = fq_sat(tsurf,psurf/100.)
-      beta_surf = 1.
-      beta_aridity(:,:) = beta_surf
-      day1= day_ini
-      time=daytime-day
-      ts_toga(1)=tsurf ! needed by read_tsurf1d.F
-      rho(1)=psurf/(rd*tsurf*(1.+(rv/rd-1.)*qsurf)) 
-
-!
-!! mpl et jyg le 22/08/2012 : 
-!!  pour que les cas a flux de surface imposes marchent
-      IF(.NOT.ok_flux_surf.or.max(abs(wtsurf),abs(wqsurf))>0.) THEN
-       fsens=-wtsurf*rcpd*rho(1)
-       flat=-wqsurf*rlvtt*rho(1)
-       print *,'Flux: ok_flux wtsurf wqsurf',ok_flux_surf,wtsurf,wqsurf
-      ENDIF
-      print*,'Flux sol ',fsens,flat
-!!      ok_flux_surf=.false.
-!!      fsens=-wtsurf*rcpd*rho(1)
-!!      flat=-wqsurf*rlvtt*rho(1)
-!!!!
-
-! Vertical discretization and pressure levels at half and mid levels:
-
-      pa   = 5e4
-!!      preff= 1.01325e5
-      preff = psurf
-      IF (ok_old_disvert) THEN
-        call disvert0(pa,preff,ap,bp,dpres,presnivs,nivsigs,nivsig)
-        print *,'On utilise disvert0'
-        aps(1:llm)=0.5*(ap(1:llm)+ap(2:llm+1))
-        bps(1:llm)=0.5*(bp(1:llm)+bp(2:llm+1))
-        scaleheight=8.
-        pseudoalt(1:llm)=-scaleheight*log(presnivs(1:llm)/preff)
-      ELSE
-        call disvert()
-        print *,'On utilise disvert'
-!       Nouvelle version disvert permettant d imposer ap,bp (modif L.Guez) MPL 18092012
-!       Dans ce cas, on lit ap,bp dans le fichier hybrid.txt
-      ENDIF
-
-      sig_s=presnivs/preff
-      plev =ap+bp*psurf
-      play = 0.5*(plev(1:llm)+plev(2:llm+1))
-      zlay=-rd*300.*log(play/psurf)/rg ! moved after reading profiles
-
-      IF (forcing_type .eq. 59) THEN
-! pour forcing_sandu, on cherche l'indice le plus proche de 700hpa#3000m
-      write(*,*) '***********************'
-      do l = 1, llm
-       write(*,*) 'l,play(l),presnivs(l): ',l,play(l),presnivs(l)
-       if (trouve_700 .and. play(l).le.70000) then
-         llm700=l
-         print *,'llm700,play=',llm700,play(l)/100.
-         trouve_700= .false.
-       endif
-      enddo
-      write(*,*) '***********************'
-      ENDIF
-
-!
-!=====================================================================
-! EVENTUALLY, READ FORCING DATA :
-!=====================================================================
-
-      INCLUDE "old_1D_read_forc_cases.h"
-
-      if (forcing_GCM2SCM) then
-        write (*,*) 'forcing_GCM2SCM not yet implemented'
-        stop 'in initialization'
-      endif ! forcing_GCM2SCM
-
-      print*,'mxcalc=',mxcalc
-!     print*,'zlay=',zlay(mxcalc)
-      print*,'play=',play(mxcalc)
-
-!Al1 pour SST forced, appell?? depuis ocean_forced_noice
-! EV tg instead of ts_cur
-
-      tg = tsurf ! SST used in read_tsurf1d
-!=====================================================================
-! Initialisation de la physique : 
-!=====================================================================
-
-!  Rq: conf_phys.F90 lit tous les flags de physiq.def; conf_phys appele depuis physiq.F
-!
-! day_step, iphysiq lus dans gcm.def ci-dessus
-! timestep: calcule ci-dessous from rday et day_step
-! ngrid=1
-! llm: defini dans .../modipsl/modeles/LMDZ4/libf/grid/dimension
-! rday: defini dans suphel.F (86400.)
-! day_ini: lu dans run.def (dayref)
-! rlat_rad,rlon-rad: transformes en radian de rlat,rlon lus dans lmdz1d.def (en degres)
-! airefi,zcufi,zcvfi initialises au debut de ce programme
-! rday,ra,rg,rd,rcpd declares dans YOMCST.h et calcules dans suphel.F
-      day_step = float(nsplit_phys)*day_step/float(iphysiq)
-      write (*,*) 'Time step divided by nsplit_phys (=',nsplit_phys,')'
-      timestep =rday/day_step
-      dtime_frcg = timestep
-!
-      zcufi=airefi
-      zcvfi=airefi
-!
-      rlat_rad(1)=xlat*rpi/180.
-      rlon_rad(1)=xlon*rpi/180.
-
-     ! iniphysiq will call iniaqua who needs year_len from phys_cal_mod
-     year_len_phys_cal_mod=year_len
-           
-     ! Ehouarn: iniphysiq requires arrays related to (3D) dynamics grid,
-     ! e.g. for cell boundaries, which are meaningless in 1D; so pad these 
-     ! with '0.' when necessary
-      call iniphysiq(iim,jjm,llm, &
-           1,comm_lmdz, &
-           rday,day_ini,timestep,  &
-           (/rlat_rad(1),0./),(/0./), &
-           (/0.,0./),(/rlon_rad(1),0./),  &
-           (/ (/airefi,0./),(/0.,0./) /), &
-           (/zcufi,0.,0.,0./), &
-           (/zcvfi,0./), &
-           ra,rg,rd,rcpd,1)
-      print*,'apres iniphysiq'
-
-! 2 PARAMETRES QUI DEVRAIENT ETRE LUS DANS run.def MAIS NE LE SONT PAS ICI:
-      co2_ppm= 330.0
-      solaire=1370.0
-
-! Ecriture du startphy avant le premier appel a la physique.
-! On le met juste avant pour avoir acces a tous les champs
-
-      if (ok_writedem) then
-
-!--------------------------------------------------------------------------
-! pbl_surface_init (called here) and pbl_surface_final (called by phyredem)
-! need : qsol fder snow qsurf evap rugos agesno ftsoil
-!--------------------------------------------------------------------------
-
-        type_ocean = "force"
-        run_off_lic_0(1) = restart_runoff 
-        call fonte_neige_init(run_off_lic_0)
-
-        fder=0.
-        snsrf(1,:)=snowmass ! masse de neige des sous surface
-        print *, 'snsrf', snsrf
-        qsurfsrf(1,:)=qsurf ! humidite de l'air des sous surface
-        fevap=0.
-        z0m(1,:)=rugos     ! couverture de neige des sous surface
-        z0h(1,:)=rugosh    ! couverture de neige des sous surface
-        agesno  = xagesno
-        tsoil(:,:,:)=tsurf
-!------ AMMA 2e run avec modele sol et rayonnement actif (MPL 23052012)
-!       tsoil(1,1,1)=299.18
-!       tsoil(1,2,1)=300.08
-!       tsoil(1,3,1)=301.88
-!       tsoil(1,4,1)=305.48
-!       tsoil(1,5,1)=308.00
-!       tsoil(1,6,1)=308.00
-!       tsoil(1,7,1)=308.00
-!       tsoil(1,8,1)=308.00
-!       tsoil(1,9,1)=308.00
-!       tsoil(1,10,1)=308.00
-!       tsoil(1,11,1)=308.00
-!-----------------------------------------------------------------------
-        call pbl_surface_init(fder, snsrf, qsurfsrf, tsoil)
-
-!------------------ prepare limit conditions for limit.nc -----------------
-!--   Ocean force
-
-        print*,'avant phyredem'
-        pctsrf(1,:)=0.
-          if (nat_surf.eq.0.) then
-          pctsrf(1,is_oce)=1.
-          pctsrf(1,is_ter)=0.
-          pctsrf(1,is_lic)=0.
-          pctsrf(1,is_sic)=0.
-        else if (nat_surf .eq. 1) then 
-          pctsrf(1,is_oce)=0.
-          pctsrf(1,is_ter)=1.
-          pctsrf(1,is_lic)=0.
-          pctsrf(1,is_sic)=0.
-        else if (nat_surf .eq. 2) then 
-          pctsrf(1,is_oce)=0.
-          pctsrf(1,is_ter)=0.
-          pctsrf(1,is_lic)=1.
-          pctsrf(1,is_sic)=0.
-        else if (nat_surf .eq. 3) then 
-          pctsrf(1,is_oce)=0.
-          pctsrf(1,is_ter)=0.
-          pctsrf(1,is_lic)=0.
-          pctsrf(1,is_sic)=1.
-
-     end if
-
-        print*,'nat_surf,pctsrf(1,is_oce),pctsrf(1,is_ter)',nat_surf         &
-     &        ,pctsrf(1,is_oce),pctsrf(1,is_ter)
-
-        zmasq=pctsrf(1,is_ter)+pctsrf(1,is_lic)
-        zpic = zpicinp
-        ftsol=tsurf
-        falb_dir=albedo
-        falb_dif=albedo
-        rugoro=rugos 
-        t_ancien(1,:)=temp(:)
-        q_ancien(1,:)=q(:,1)
-        ql_ancien = 0.
-        qs_ancien = 0.
-        prlw_ancien = 0.
-        prsw_ancien = 0.
-        prw_ancien = 0.
-        IF ( ok_bs ) THEN
-          qbs_ancien = 0.
-          prbsw_ancien = 0.
-        ENDIF
-        IF ( ok_ice_supersat ) THEN
-          cf_ancien = 0.
-          rvc_ancien = 0.
-        ENDIF
-!jyg<
-!!        pbl_tke(:,:,:)=1.e-8
-        pbl_tke(:,:,:)=0.
-        pbl_tke(:,2,:)=1.e-2
-        PRINT *, ' pbl_tke dans lmdz1d '
-        if (prt_level .ge. 5) then 
-         DO nsrf = 1,4
-           PRINT *,'pbl_tke(1,:,',nsrf,') ',pbl_tke(1,:,nsrf)
-         ENDDO
-        end if
-
-!>jyg
-
-        rain_fall=0.
-        snow_fall=0.
-        solsw=0.
-        solswfdiff=0.
-        sollw=0.
-        sollwdown=rsigma*tsurf**4
-        radsol=0.
-        rnebcon=0.
-        ratqs=0.
-        clwcon=0.
-        zmax0 = 0.
-        zmea=zsurf
-        zstd=0.
-        zsig=0.
-        zgam=0.
-        zval=0. 
-        zthe=0. 
-        sig1=0.
-        w01=0.
-!
-        wake_deltaq = 0.
-        wake_deltat = 0.
-        wake_delta_pbl_TKE(:,:,:) = 0.
-        delta_tsurf = 0.
-        wake_fip = 0.
-        wake_pe = 0.
-        wake_s = 0.
-        awake_s = 0.
-        wake_dens = 0.
-        awake_dens = 0.
-        cv_gen = 0.
-        wake_cstar = 0.
-        ale_bl = 0.
-        ale_bl_trig = 0.
-        alp_bl = 0.
-        IF (ALLOCATED(du_gwd_rando)) du_gwd_rando = 0.
-        IF (ALLOCATED(du_gwd_front)) du_gwd_front = 0.
-        entr_therm = 0.
-        detr_therm = 0.
-        f0 = 0.
-        fm_therm = 0.
-        u_ancien(1,:)=u(:)
-        v_ancien(1,:)=v(:)
-
-        u10m=0.
-        v10m=0.
-        ale_wake=0.
-        ale_bl_stat=0.
- 
-!------------------------------------------------------------------------
-! Make file containing restart for the physics (startphy.nc)
-!
-! NB: List of the variables to be written by phyredem (via put_field):
-! rlon,rlat,zmasq,pctsrf(:,is_ter),pctsrf(:,is_lic),pctsrf(:,is_oce)
-! pctsrf(:,is_sic),ftsol(:,nsrf),tsoil(:,isoil,nsrf),qsurf(:,nsrf)
-! qsol,falb_dir(:,nsrf),falb_dif(:,nsrf),evap(:,nsrf),snow(:,nsrf)
-! radsol,solsw,solswfdiff,sollw, sollwdown,fder,rain_fall,snow_fall,frugs(:,nsrf)
-! agesno(:,nsrf),zmea,zstd,zsig,zgam,zthe,zpic,zval,rugoro
-! t_ancien,q_ancien,,frugs(:,is_oce),clwcon(:,1),rnebcon(:,1),ratqs(:,1)
-! run_off_lic_0,pbl_tke(:,1:klev,nsrf), zmax0,f0,sig1,w01
-! wake_deltat,wake_deltaq,wake_s,awake_s,wake_dens,awake_dens,cv_gen,wake_cstar,
-! wake_fip,wake_delta_pbl_tke(:,1:klev,nsrf)
-!
-! NB2: The content of the startphy.nc file depends on some flags defined in
-! the ".def" files. However, since conf_phys is not called in lmdz1d.F90, these flags have 
-! to be set at some arbitratry convenient values.
-!------------------------------------------------------------------------
-!Al1 =============== restart option ==========================
-        iflag_physiq=0
-        call getin('iflag_physiq',iflag_physiq)
-
-        if (.not.restart) then
-          iflag_pbl = 5
-          call phyredem ("startphy.nc")
-        else
-! (desallocations)
-        print*,'callin surf final'
-          call pbl_surface_final( fder, snsrf, qsurfsrf, tsoil)
-        print*,'after surf final'
-          CALL fonte_neige_final(run_off_lic_0)
-        endif
-
-        ok_writedem=.false.
-        print*,'apres phyredem'
-
-      endif ! ok_writedem
-      
-!------------------------------------------------------------------------
-! Make file containing boundary conditions (limit.nc) **Al1->restartdyn***
-! --------------------------------------------------
-! NB: List of the variables to be written in limit.nc 
-!     (by writelim.F, subroutine of 1DUTILS.h):
-!        phy_nat,phy_alb,phy_sst,phy_bil,phy_rug,phy_ice,
-!        phy_fter,phy_foce,phy_flic,phy_fsic)
-!------------------------------------------------------------------------
-      do i=1,year_len
-        phy_nat(i)  = nat_surf
-        phy_alb(i)  = albedo
-        phy_sst(i)  = tsurf ! read_tsurf1d will be used instead
-        phy_rug(i)  = rugos
-        phy_fter(i) = pctsrf(1,is_ter)
-        phy_foce(i) = pctsrf(1,is_oce)
-        phy_fsic(i) = pctsrf(1,is_sic)
-        phy_flic(i) = pctsrf(1,is_lic)
-      enddo
-
-! fabrication de limit.nc
-      call writelim (1,phy_nat,phy_alb,phy_sst,phy_bil,phy_rug,             &
-     &               phy_ice,phy_fter,phy_foce,phy_flic,phy_fsic)
-
-
-      call phys_state_var_end
-!Al1
-      if (restart) then
-        print*,'call to restart dyn 1d'
-        Call dyn1deta0("start1dyn.nc",plev,play,phi,phis,presnivs,          &
-     &              u,v,temp,q,omega2)
-
-       print*,'fnday,annee_ref,day_ref,day_ini',                            &
-     &     fnday,annee_ref,day_ref,day_ini
-!**      call ymds2ju(annee_ref,mois,day_ini,heure,day)
-       day = day_ini
-       day_end = day_ini + nday
-       daytime = day + time_ini/24. ! 1st day and initial time of the simulation 
-
-! Print out the actual date of the beginning of the simulation :
-       call ju2ymds(daytime, an, mois, jour, heure)
-       print *,' Time of beginning : y m d h',an, mois,jour,heure/3600.
-
-       day = int(daytime)
-       time=daytime-day
-  
-       print*,'****** intialised fields from restart1dyn *******'
-       print*,'plev,play,phi,phis,presnivs,u,v,temp,q,omega2'
-       print*,'temp(1),q(1,1),u(1),v(1),plev(1),phis :'
-       print*,temp(1),q(1,1),u(1),v(1),plev(1),phis
-! raz for safety
-       do l=1,llm
-         dq_dyn(l,1) = 0.
-       enddo
-      endif
-!Al1 ================  end restart =================================
-      IF (ecrit_slab_oc.eq.1) then
-         open(97,file='div_slab.dat',STATUS='UNKNOWN')
-       elseif (ecrit_slab_oc.eq.0) then
-         open(97,file='div_slab.dat',STATUS='OLD')
-       endif
-!
-!---------------------------------------------------------------------
-!    Initialize target profile for RHT nudging if needed
-!---------------------------------------------------------------------
-      if (nudge(inudge_RHT)) then
-        call nudge_RHT_init(plev,play,temp,q(:,1),t_targ,rh_targ)
-      endif
-      if (nudge(inudge_UV)) then
-        call nudge_UV_init(plev,play,u,v,u_targ,v_targ)
-      endif
-!
-!=====================================================================
-IF (CPPKEY_OUTPUTPHYSSCM) THEN
-       CALL iophys_ini(timestep)
-END IF
-! START OF THE TEMPORAL LOOP :
-!=====================================================================
-           
-      it_end = nint(fnday*day_step)
-!test JLD     it_end = 10
-      do while(it.le.it_end)
-
-       if (prt_level.ge.1) then
-         print*,'XXXXXXXXXXXXXXXXXXX ITAP,day,time=',                       &
-     &             it,day,time,it_end,day_step
-         print*,'PAS DE TEMPS ',timestep
-       endif
-!Al1 demande de restartphy.nc
-       if (it.eq.it_end) lastcall=.True.
-
-!---------------------------------------------------------------------
-!  Geopotential :
-!---------------------------------------------------------------------
-
-        phi(1)=RD*temp(1)*(plev(1)-play(1))/(.5*(plev(1)+play(1)))
-        do l = 1, llm-1
-          phi(l+1)=phi(l)+RD*(temp(l)+temp(l+1))*                           &
-     &    (play(l)-play(l+1))/(play(l)+play(l+1))
-        enddo
-
-!---------------------------------------------------------------------
-! Interpolation of forcings in time and onto model levels
-!---------------------------------------------------------------------
-
-      INCLUDE "old_1D_interp_cases.h"
-
-      if (forcing_GCM2SCM) then
-        write (*,*) 'forcing_GCM2SCM not yet implemented'
-        stop 'in time loop'
-      endif ! forcing_GCM2SCM
-
-!!!!---------------------------------------------------------------------
-!!!!  Geopotential :
-!!!!---------------------------------------------------------------------
-!!!
-!!!        phi(1)=RD*temp(1)*(plev(1)-play(1))/(.5*(plev(1)+play(1)))
-!!!        do l = 1, llm-1
-!!!          phi(l+1)=phi(l)+RD*(temp(l)+temp(l+1))*                           &
-!!!     &    (play(l)-play(l+1))/(play(l)+play(l+1))
-!!!        enddo
-
-!---------------------------------------------------------------------
-! Listing output for debug prt_level>=1
-!---------------------------------------------------------------------
-       if (prt_level>=1) then
-         print *,' avant physiq : -------- day time ',day,time
-         write(*,*) 'firstcall,lastcall,phis',                               &
-     &               firstcall,lastcall,phis
-       end if
-       if (prt_level>=5) then
-         write(*,'(a10,2a4,4a13)') 'BEFOR1 IT=','it','l',                   &
-     &        'presniv','plev','play','phi'
-         write(*,'(a10,2i4,4f13.2)') ('BEFOR1 IT= ',it,l,                   &
-     &         presnivs(l),plev(l),play(l),phi(l),l=1,llm)
-         write(*,'(a11,2a4,a11,6a8)') 'BEFOR2','it','l',                    &
-     &         'presniv','u','v','temp','q1','q2','omega2'
-         write(*,'(a11,2i4,f11.2,5f8.2,e10.2)') ('BEFOR2 IT= ',it,l,         &
-     &   presnivs(l),u(l),v(l),temp(l),q(l,1),q(l,2),omega2(l),l=1,llm)
-       endif
-
-!---------------------------------------------------------------------
-!   Call physiq :
-!---------------------------------------------------------------------
-       call physiq(ngrid,llm, &
-                    firstcall,lastcall,timestep, &
-                    plev,play,phi,phis,presnivs, &
-                    u,v, rot, temp,q,omega2, &
-                    du_phys,dv_phys,dt_phys,dq,dpsrf)
-                firstcall=.false.
-
-!---------------------------------------------------------------------
-! Listing output for debug
-!---------------------------------------------------------------------
-        if (prt_level>=5) then
-          write(*,'(a11,2a4,4a13)') 'AFTER1 IT=','it','l',                  &
-     &        'presniv','plev','play','phi'
-          write(*,'(a11,2i4,4f13.2)') ('AFTER1 it= ',it,l,                  &
-     &    presnivs(l),plev(l),play(l),phi(l),l=1,llm)
-          write(*,'(a11,2a4,a11,6a8)') 'AFTER2','it','l',                   &
-     &         'presniv','u','v','temp','q1','q2','omega2'
-          write(*,'(a11,2i4,f11.2,5f8.2,e10.2)') ('AFTER2 it= ',it,l,       &
-     &    presnivs(l),u(l),v(l),temp(l),q(l,1),q(l,2),omega2(l),l=1,llm)
-          write(*,'(a11,2a4,a11,5a8)') 'AFTER3','it','l',                   &
-     &         'presniv','du_phys','dv_phys','dt_phys','dq1','dq2'    
-           write(*,'(a11,2i4,f11.2,5f8.2)') ('AFTER3 it= ',it,l,            &
-     &      presnivs(l),86400*du_phys(l),86400*dv_phys(l),                   &
-     &       86400*dt_phys(l),86400*dq(l,1),dq(l,2),l=1,llm)
-          write(*,*) 'dpsrf',dpsrf
-        endif
-!---------------------------------------------------------------------
-!   Add physical tendencies :
-!---------------------------------------------------------------------
-
-       fcoriolis=2.*sin(rpi*xlat/180.)*romega
-       if (forcing_radconv .or. forcing_fire) then
-         fcoriolis=0.0
-         dt_cooling=0.0
-         d_t_adv=0.0
-         d_q_adv=0.0
-       endif
-!      print*, 'calcul de fcoriolis ', fcoriolis
-
-       if (forcing_toga .or. forcing_GCSSold .or. forcing_twpice            &
-     &    .or.forcing_amma .or. forcing_type.eq.101) then
-         fcoriolis=0.0 ; ug=0. ; vg=0.
-       endif
-
-       if(forcing_rico) then
-          dt_cooling=0.
-       endif
-
-!CRio:Attention modif sp??cifique cas de Caroline
-      if (forcing_type==-1) then
-         fcoriolis=0.
-!Nudging
-        
-!on calcule dt_cooling
-        do l=1,llm
-        if (play(l).ge.20000.) then
-            dt_cooling(l)=-1.5/86400.
-        elseif ((play(l).ge.10000.).and.((play(l).lt.20000.))) then
-            dt_cooling(l)=-1.5/86400.*(play(l)-10000.)/(10000.)-1./86400.*(20000.-play(l))/10000.*(temp(l)-200.)
-        else
-            dt_cooling(l)=-1.*(temp(l)-200.)/86400.
-        endif
-        enddo
-
-      endif     
-!RC
-      if (forcing_sandu) then
-         ug(1:llm)=u_mod(1:llm)
-         vg(1:llm)=v_mod(1:llm)
-      endif
-
-      IF (prt_level >= 5) print*, 'fcoriolis, xlat,mxcalc ', &
-                                   fcoriolis, xlat,mxcalc
-
-!       print *,'u-ug=',u-ug
-
-!!!!!!!!!!!!!!!!!!!!!!!!
-! Geostrophic wind
-! Le calcul ci dessous est insuffisamment precis
-!      du_age(1:mxcalc)=fcoriolis*(v(1:mxcalc)-vg(1:mxcalc))
-!      dv_age(1:mxcalc)=-fcoriolis*(u(1:mxcalc)-ug(1:mxcalc))
-!!!!!!!!!!!!!!!!!!!!!!!!
-       sfdt = sin(0.5*fcoriolis*timestep)
-       cfdt = cos(0.5*fcoriolis*timestep)
-!       print *,'fcoriolis,sfdt,cfdt,timestep',fcoriolis,sfdt,cfdt,timestep
-!
-        du_age(1:mxcalc)= -2.*sfdt/timestep*                                &
-     &          (sfdt*(u(1:mxcalc)-ug(1:mxcalc)) -                          &
-     &           cfdt*(v(1:mxcalc)-vg(1:mxcalc))  )
-!!     : fcoriolis*(v(1:mxcalc)-vg(1:mxcalc))
-!
-       dv_age(1:mxcalc)= -2.*sfdt/timestep*                                 &
-     &          (cfdt*(u(1:mxcalc)-ug(1:mxcalc)) +                           &
-     &           sfdt*(v(1:mxcalc)-vg(1:mxcalc))  )
-!!     : -fcoriolis*(u(1:mxcalc)-ug(1:mxcalc))
-!
-!!!!!!!!!!!!!!!!!!!!!!!!
-!  Nudging
-!!!!!!!!!!!!!!!!!!!!!!!!
-      d_t_nudge(:) = 0.
-      d_q_nudge(:,:) = 0.
-      d_u_nudge(:) = 0.
-      d_v_nudge(:) = 0.
-      if (nudge(inudge_RHT)) then
-        call nudge_RHT(timestep,plev,play,t_targ,rh_targ,temp,q(:,1),     &
-    &                  d_t_nudge,d_q_nudge(:,1))
-      endif
-      if (nudge(inudge_UV)) then
-        call nudge_UV(timestep,plev,play,u_targ,v_targ,u,v,     &
-    &                  d_u_nudge,d_v_nudge)
-      endif
-!
-       if (forcing_fire) THEN
-
-!let ww=if ( alt le 1100 ) then alt*-0.00001 else 0
-!let wt=if ( alt le 1100 ) then min( -3.75e-5 , -7.5e-8*alt)  else 0
-!let wq=if ( alt le 1100 ) then max( 1.5e-8 , 3e-11*alt)  else 0
-           d_t_adv=0.
-           d_q_adv=0.
-           teta=temp*(pzero/play)**rkappa
-           d_t_adv=0.
-           d_q_adv=0.
-           do l=2,llm-1
-              if (zlay(l)<=1100) then
-                  wwww=-0.00001*zlay(l)
-                  d_t_adv(l)=-wwww*(teta(l)-teta(l+1))/(zlay(l)-zlay(l+1)) /(pzero/play(l))**rkappa
-                  d_q_adv(l,1:2)=-wwww*(q(l,1:2)-q(l+1,1:2))/(zlay(l)-zlay(l+1))
-                  d_t_adv(l)=d_t_adv(l)+min(-3.75e-5 , -7.5e-8*zlay(l))
-                  d_q_adv(l,1)=d_q_adv(l,1)+max( 1.5e-8 , 3e-11*zlay(l))
-              endif
-           enddo
-
-        endif
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!         call  writefield_phy('dv_age' ,dv_age,llm)
-!         call  writefield_phy('du_age' ,du_age,llm)
-!         call  writefield_phy('du_phys' ,du_phys,llm)
-!         call  writefield_phy('u_tend' ,u,llm)
-!         call  writefield_phy('u_g' ,ug,llm)
-!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!! Increment state variables
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-    IF (flag_inhib_forcing == 0) then ! if tendency of forcings should be added
-
-! pour les cas sandu et astex, on reclacule u,v,q,temp et teta dans 1D_nudge_sandu_astex.h
-! au dessus de 700hpa, on relaxe vers les profils initiaux
-      if (forcing_sandu .OR. forcing_astex) then
-      INCLUDE "1D_nudge_sandu_astex.h"
-      else
-        u(1:mxcalc)=u(1:mxcalc) + timestep*(                                &
-     &              du_phys(1:mxcalc)                                       &
-     &             +du_age(1:mxcalc)+du_adv(1:mxcalc)                       &
-     &             +d_u_nudge(1:mxcalc) )            
-        v(1:mxcalc)=v(1:mxcalc) + timestep*(                                 &
-     &              dv_phys(1:mxcalc)                                       &
-     &             +dv_age(1:mxcalc)+dv_adv(1:mxcalc)                       &
-     &             +d_v_nudge(1:mxcalc) )
-        q(1:mxcalc,:)=q(1:mxcalc,:)+timestep*(                              &
-     &                dq(1:mxcalc,:)                                        &
-     &               +d_q_adv(1:mxcalc,:)                                   &
-     &               +d_q_nudge(1:mxcalc,:) )
-
-        if (prt_level.ge.3) then
-          print *,                                                          &
-     &    'physiq-> temp(1),dt_phys(1),d_t_adv(1),dt_cooling(1) ',         &
-     &              temp(1),dt_phys(1),d_t_adv(1),dt_cooling(1)
-           print* ,'dv_phys=',dv_phys
-           print* ,'dv_age=',dv_age
-           print* ,'dv_adv=',dv_adv
-           print* ,'d_v_nudge=',d_v_nudge
-           print*, v
-           print*, vg
-        endif
-
-        temp(1:mxcalc)=temp(1:mxcalc)+timestep*(                            &
-     &              dt_phys(1:mxcalc)                                       &
-     &             +d_t_adv(1:mxcalc)                                      &
-     &             +d_t_nudge(1:mxcalc)                                      &
-     &             +dt_cooling(1:mxcalc))  ! Taux de chauffage ou refroid.
-
-IF (CPPKEY_OUTPUTPHYSSCM) THEN
-      CALL iophys_ecrit('d_t_adv',klev,'d_t_adv','m/s',d_t_adv)
-      CALL iophys_ecrit('d_t_nudge',klev,'d_t_nudge','m/s',d_t_nudge)
-END IF
-
-      endif  ! forcing_sandu or forcing_astex
-
-        teta=temp*(pzero/play)**rkappa
-!
-!---------------------------------------------------------------------
-!   Nudge soil temperature if requested
-!---------------------------------------------------------------------
-
-      IF (nudge_tsoil .AND. .NOT. lastcall) THEN
-       ftsoil(1,isoil_nudge,:) = ftsoil(1,isoil_nudge,:)                     &
-     &  -timestep/tau_soil_nudge*(ftsoil(1,isoil_nudge,:)-Tsoil_nudge)
-      ENDIF
-
-!---------------------------------------------------------------------
-!   Add large-scale tendencies (advection, etc) :
-!---------------------------------------------------------------------
-
-!cc nrlmd
-!cc        tmpvar=teta
-!cc        call advect_vert(llm,omega,timestep,tmpvar,plev)
-!cc
-!cc        teta(1:mxcalc)=tmpvar(1:mxcalc)
-!cc        tmpvar(:)=q(:,1)
-!cc        call advect_vert(llm,omega,timestep,tmpvar,plev)
-!cc        q(1:mxcalc,1)=tmpvar(1:mxcalc)
-!cc        tmpvar(:)=q(:,2)
-!cc        call advect_vert(llm,omega,timestep,tmpvar,plev)
-!cc        q(1:mxcalc,2)=tmpvar(1:mxcalc)
-
-   END IF ! end if tendency of tendency should be added
-
-!---------------------------------------------------------------------
-!   Air temperature :
-!---------------------------------------------------------------------        
-        if (lastcall) then
-          print*,'Pas de temps final ',it
-          call ju2ymds(daytime, an, mois, jour, heure)
-          print*,'a la date : a m j h',an, mois, jour ,heure/3600.
-        endif
-
-!  incremente day time
-!        print*,'daytime bef',daytime,1./day_step
-        daytime = daytime+1./day_step
-!Al1dbg
-        day = int(daytime+0.1/day_step)
-!        time = max(daytime-day,0.0)
-!Al1&jyg: correction de bug
-!cc        time = real(mod(it,day_step))/day_step
-        time = time_ini/24.+real(mod(it,day_step))/day_step
-!        print*,'daytime nxt time',daytime,time
-        it=it+1
-
-      enddo
-
-!Al1
-      if (ecrit_slab_oc.ne.-1) close(97)
-
-!Al1 Call to 1D equivalent of dynredem (an,mois,jour,heure ?)
-! -------------------------------------
-       call dyn1dredem("restart1dyn.nc",                                    &
-     &              plev,play,phi,phis,presnivs,                            &
-     &              u,v,temp,q,omega2)
-
-        CALL abort_gcm ('lmdz1d   ','The End  ',0)
-
-        END SUBROUTINE old_lmdz1d
-
-        INCLUDE "old_1DUTILS_read_interp.h"
Index: /LMDZ6/trunk/libf/phylmd/dyn1d/old_lmdz1d.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/dyn1d/old_lmdz1d.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/dyn1d/old_lmdz1d.f90	(revision 5268)
@@ -0,0 +1,1374 @@
+!
+! $Id: lmdz1d.F90 3540 2019-06-25 14:50:13Z fairhead $
+!
+
+      SUBROUTINE old_lmdz1d
+
+   USE ioipsl, only: ju2ymds, ymds2ju, ioconf_calendar,getin
+   USE phys_state_var_mod, ONLY : phys_state_var_init, phys_state_var_end, &
+       clwcon, detr_therm, &
+       qsol, fevap, z0m, z0h, agesno, &
+       du_gwd_rando, du_gwd_front, entr_therm, f0, fm_therm, &
+       falb_dir, falb_dif, &
+       ftsol, beta_aridity, pbl_tke, pctsrf, radsol, rain_fall, snow_fall, ratqs, &
+       rnebcon, rugoro, sig1, w01, solaire_etat0, sollw, sollwdown, &
+       solsw, solswfdiff, t_ancien, q_ancien, u_ancien, v_ancien, &
+       wake_delta_pbl_TKE, delta_tsurf, wake_fip, wake_pe, &
+       wake_deltaq, wake_deltat, wake_s, awake_s, wake_dens, &
+       awake_dens, cv_gen, wake_cstar, &
+       zgam, zmax0, zmea, zpic, zsig, &
+       zstd, zthe, zval, ale_bl, ale_bl_trig, alp_bl, &
+       ql_ancien, qs_ancien, qbs_ancien, cf_ancien, rvc_ancien, &
+       prlw_ancien, prsw_ancien, prbsw_ancien, prw_ancien, &
+       u10m,v10m,ale_wake,ale_bl_stat
+
+  
+   USE dimphy
+   USE surface_data, only : type_ocean,ok_veget
+   USE pbl_surface_mod, only : ftsoil, pbl_surface_init, &
+                                 pbl_surface_final
+   USE fonte_neige_mod, only : fonte_neige_init, fonte_neige_final 
+
+   USE infotrac ! new
+   USE control_mod
+   USE indice_sol_mod
+   USE phyaqua_mod
+!  USE mod_1D_cases_read
+   USE mod_1D_cases_read2
+   USE mod_1D_amma_read
+   USE print_control_mod, ONLY: lunout, prt_level
+   USE iniphysiq_mod, ONLY: iniphysiq
+   USE mod_const_mpi, ONLY: comm_lmdz
+   USE physiq_mod, ONLY: physiq
+   USE comvert_mod, ONLY: presnivs, ap, bp, dpres,nivsig, nivsigs, pa, &
+                          preff, aps, bps, pseudoalt, scaleheight
+   USE temps_mod, ONLY: annee_ref, calend, day_end, day_ini, day_ref, &
+                        itau_dyn, itau_phy, start_time, year_len
+   USE phys_cal_mod, ONLY : year_len_phys_cal_mod => year_len
+   USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_OUTPUTPHYSSCM
+
+      implicit none
+      INCLUDE "dimensions.h"
+      INCLUDE "YOMCST.h"
+!!      INCLUDE "control.h"
+      INCLUDE "clesphys.h"
+      INCLUDE "dimsoil.h"
+!      INCLUDE "indicesol.h"
+
+      INCLUDE "compar1d.h"
+      INCLUDE "flux_arp.h"
+      INCLUDE "date_cas.h"
+      INCLUDE "tsoilnudge.h"
+      INCLUDE "fcg_gcssold.h"
+!!!      INCLUDE "fbforcing.h"
+      INCLUDE "compbl.h"
+
+!=====================================================================
+! DECLARATIONS
+!=====================================================================
+
+!---------------------------------------------------------------------
+!  Externals
+!---------------------------------------------------------------------
+      external fq_sat
+      real fq_sat
+
+!---------------------------------------------------------------------
+!  Arguments d' initialisations de la physique (USER DEFINE)
+!---------------------------------------------------------------------
+
+      integer, parameter :: ngrid=1
+      real :: zcufi    = 1.
+      real :: zcvfi    = 1.
+
+!-      real :: nat_surf
+!-      logical :: ok_flux_surf
+!-      real :: fsens
+!-      real :: flat
+!-      real :: tsurf
+!-      real :: rugos
+!-      real :: qsol(1:2)
+!-      real :: qsurf
+!-      real :: psurf
+!-      real :: zsurf
+!-      real :: albedo
+!-
+!-      real :: time     = 0.
+!-      real :: time_ini
+!-      real :: xlat 
+!-      real :: xlon 
+!-      real :: wtsurf 
+!-      real :: wqsurf 
+!-      real :: restart_runoff 
+!-      real :: xagesno 
+!-      real :: qsolinp 
+!-      real :: zpicinp 
+!-
+      real :: fnday 
+      real :: day, daytime 
+      real :: day1
+      real :: heure
+      integer :: jour
+      integer :: mois
+      integer :: an
+ 
+!---------------------------------------------------------------------
+!  Declarations related to forcing and initial profiles 
+!---------------------------------------------------------------------
+
+        integer :: kmax = llm
+        integer llm700,nq1,nq2
+        INTEGER, PARAMETER :: nlev_max=1000, nqmx=1000
+        real timestep, frac
+        real height(nlev_max),tttprof(nlev_max),qtprof(nlev_max)
+        real  uprof(nlev_max),vprof(nlev_max),e12prof(nlev_max)
+        real  ugprof(nlev_max),vgprof(nlev_max),wfls(nlev_max)
+        real  dqtdxls(nlev_max),dqtdyls(nlev_max)
+        real  dqtdtls(nlev_max),thlpcar(nlev_max)
+        real  qprof(nlev_max,nqmx)
+
+!        integer :: forcing_type
+        logical :: forcing_les     = .false.
+        logical :: forcing_armcu   = .false.
+        logical :: forcing_rico    = .false.
+        logical :: forcing_radconv = .false.
+        logical :: forcing_toga    = .false.
+        logical :: forcing_twpice  = .false.
+        logical :: forcing_amma    = .false.
+        logical :: forcing_dice    = .false.
+        logical :: forcing_gabls4  = .false.
+
+        logical :: forcing_GCM2SCM = .false.
+        logical :: forcing_GCSSold = .false.
+        logical :: forcing_sandu   = .false.
+        logical :: forcing_astex   = .false.
+        logical :: forcing_fire    = .false.
+        logical :: forcing_case    = .false.
+        logical :: forcing_case2   = .false.
+        logical :: forcing_SCM   = .false.
+        integer :: type_ts_forcing ! 0 = SST constant; 1 = SST read from a file
+!                                                            (cf read_tsurf1d.F)
+
+real wwww
+!vertical advection computation
+!       real d_t_z(llm), d_q_z(llm)
+!       real d_t_dyn_z(llm), dq_dyn_z(llm)
+!       real zz(llm)
+!       real zfact
+
+!flag forcings
+        logical :: nudge_wind=.true.
+        logical :: nudge_thermo=.false.
+        logical :: cptadvw=.true.
+!=====================================================================
+! DECLARATIONS FOR EACH CASE
+!=====================================================================
+!
+      INCLUDE "old_1D_decl_cases.h"
+!
+!---------------------------------------------------------------------
+!  Declarations related to nudging
+!---------------------------------------------------------------------
+     integer :: nudge_max
+     parameter (nudge_max=9)
+     integer :: inudge_RHT=1
+     integer :: inudge_UV=2
+     logical :: nudge(nudge_max)
+     real :: t_targ(llm)
+     real :: rh_targ(llm)
+     real :: u_targ(llm)
+     real :: v_targ(llm)
+!
+!---------------------------------------------------------------------
+!  Declarations related to vertical discretization:
+!---------------------------------------------------------------------
+      real :: pzero=1.e5
+      real :: play (llm),zlay (llm),sig_s(llm),plev(llm+1)
+      real :: playd(llm),zlayd(llm),ap_amma(llm+1),bp_amma(llm+1)
+
+!---------------------------------------------------------------------
+!  Declarations related to variables
+!---------------------------------------------------------------------
+
+      real :: phi(llm)
+      real :: teta(llm),tetal(llm),temp(llm),u(llm),v(llm),w(llm)
+      REAL rot(1, llm) ! relative vorticity, in s-1
+      real :: rlat_rad(1),rlon_rad(1)
+      real :: omega(llm+1),omega2(llm),rho(llm+1)
+      real :: ug(llm),vg(llm),fcoriolis
+      real :: sfdt, cfdt
+      real :: du_phys(llm),dv_phys(llm),dt_phys(llm)
+      real :: dt_dyn(llm)
+      real :: dt_cooling(llm),d_t_adv(llm),d_t_nudge(llm)
+      real :: d_u_nudge(llm),d_v_nudge(llm)
+      real :: du_adv(llm),dv_adv(llm)
+      real :: du_age(llm),dv_age(llm)
+      real :: alpha
+      real :: ttt
+
+      REAL, ALLOCATABLE, DIMENSION(:,:):: q
+      REAL, ALLOCATABLE, DIMENSION(:,:):: dq
+      REAL, ALLOCATABLE, DIMENSION(:,:):: dq_dyn
+      REAL, ALLOCATABLE, DIMENSION(:,:):: d_q_adv
+      REAL, ALLOCATABLE, DIMENSION(:,:):: d_q_nudge
+!      REAL, ALLOCATABLE, DIMENSION(:):: d_th_adv
+
+!---------------------------------------------------------------------
+!  Initialization of surface variables
+!---------------------------------------------------------------------
+      real :: run_off_lic_0(1)
+      real :: fder(1),snsrf(1,nbsrf),qsurfsrf(1,nbsrf)
+      real :: tsoil(1,nsoilmx,nbsrf)
+!     real :: agesno(1,nbsrf)
+
+!---------------------------------------------------------------------
+!  Call to phyredem
+!---------------------------------------------------------------------
+      logical :: ok_writedem =.true.
+      real :: sollw_in = 0.
+      real :: solsw_in = 0.
+      
+!---------------------------------------------------------------------
+!  Call to physiq
+!---------------------------------------------------------------------
+      logical :: firstcall=.true.
+      logical :: lastcall=.false.
+      real :: phis(1)    = 0.0
+      real :: dpsrf(1)
+
+!---------------------------------------------------------------------
+!  Initializations of boundary conditions 
+!---------------------------------------------------------------------
+      real, allocatable :: phy_nat (:)  ! 0=ocean libre,1=land,2=glacier,3=banquise
+      real, allocatable :: phy_alb (:)  ! Albedo land only (old value condsurf_jyg=0.3)
+      real, allocatable :: phy_sst (:)  ! SST (will not be used; cf read_tsurf1d.F)
+      real, allocatable :: phy_bil (:)  ! Ne sert que pour les slab_ocean
+      real, allocatable :: phy_rug (:) ! Longueur rugosite utilisee sur land only
+      real, allocatable :: phy_ice (:) ! Fraction de glace
+      real, allocatable :: phy_fter(:) ! Fraction de terre
+      real, allocatable :: phy_foce(:) ! Fraction de ocean
+      real, allocatable :: phy_fsic(:) ! Fraction de glace
+      real, allocatable :: phy_flic(:) ! Fraction de glace
+
+!---------------------------------------------------------------------
+!  Fichiers et d'autres variables
+!---------------------------------------------------------------------
+      integer :: k,l,i,it=1,mxcalc
+      integer :: nsrf
+      integer jcode
+      INTEGER read_climoz 
+!
+      integer :: it_end ! iteration number of the last call
+!Al1
+      integer ecrit_slab_oc !1=ecrit,-1=lit,0=no file
+      data ecrit_slab_oc/-1/
+!
+!     if flag_inhib_forcing = 0, tendencies of forcing are added
+!                           <> 0, tendencies of forcing are not added
+      INTEGER :: flag_inhib_forcing = 0
+
+!=====================================================================
+! INITIALIZATIONS 
+!=====================================================================
+      du_phys(:)=0.
+      dv_phys(:)=0.
+      dt_phys(:)=0.
+      dt_dyn(:)=0.
+      dt_cooling(:)=0.
+      d_t_adv(:)=0.
+      d_t_nudge(:)=0.
+      d_u_nudge(:)=0.
+      d_v_nudge(:)=0.
+      du_adv(:)=0.
+      dv_adv(:)=0.
+      du_age(:)=0.
+      dv_age(:)=0.
+      
+! Initialization of Common turb_forcing
+       dtime_frcg = 0.
+       Turb_fcg_gcssold=.false.
+       hthturb_gcssold = 0.
+       hqturb_gcssold = 0.
+
+
+
+
+!---------------------------------------------------------------------
+! OPTIONS OF THE 1D SIMULATION (lmdz1d.def => unicol.def)
+!---------------------------------------------------------------------
+!Al1
+        call conf_unicol
+!Al1 moves this gcssold var from common fcg_gcssold to 
+        Turb_fcg_gcssold = xTurb_fcg_gcssold
+! --------------------------------------------------------------------
+        close(1)
+!Al1
+        write(*,*) 'lmdz1d.def lu => unicol.def'
+
+! forcing_type defines the way the SCM is forced:
+!forcing_type = 0 ==> forcing_les = .true.
+!             initial profiles from file prof.inp.001
+!             no forcing by LS convergence ; 
+!             surface temperature imposed ;
+!             radiative cooling may be imposed (iflag_radia=0 in physiq.def)
+!forcing_type = 1 ==> forcing_radconv = .true.
+!             idem forcing_type = 0, but the imposed radiative cooling 
+!             is set to 0 (hence, if iflag_radia=0 in physiq.def, 
+!             then there is no radiative cooling at all)
+!forcing_type = 2 ==> forcing_toga = .true.
+!             initial profiles from TOGA-COARE IFA files 
+!             LS convergence and SST imposed from TOGA-COARE IFA files 
+!forcing_type = 3 ==> forcing_GCM2SCM = .true.
+!             initial profiles from the GCM output
+!             LS convergence imposed from the GCM output
+!forcing_type = 4 ==> forcing_twpice = .true.
+!             initial profiles from TWP-ICE cdf file 
+!             LS convergence, omega and SST imposed from TWP-ICE files 
+!forcing_type = 5 ==> forcing_rico = .true.
+!             initial profiles from RICO files 
+!             LS convergence imposed from RICO files 
+!forcing_type = 6 ==> forcing_amma = .true.
+!             initial profiles from AMMA nc file 
+!             LS convergence, omega and surface fluxes imposed from AMMA file  
+!forcing_type = 7 ==> forcing_dice = .true.
+!             initial profiles and large scale forcings in dice_driver.nc
+!             Different stages: soil model alone, atm. model alone
+!             then both models coupled
+!forcing_type = 8 ==> forcing_gabls4 = .true.
+!             initial profiles and large scale forcings in gabls4_driver.nc
+!forcing_type >= 100 ==> forcing_case = .true.
+!             initial profiles and large scale forcings in cas.nc
+!             LS convergence, omega and SST imposed from CINDY-DYNAMO files 
+!             101=cindynamo
+!             102=bomex
+!forcing_type >= 100 ==> forcing_case2 = .true.
+!             temporary flag while all the 1D cases are not whith the same cas.nc forcing file
+!             103=arm_cu2 ie arm_cu with new forcing format
+!             104=rico2 ie rico with new forcing format
+!forcing_type = 40 ==> forcing_GCSSold = .true.
+!             initial profile from GCSS file
+!             LS convergence imposed from GCSS file
+!forcing_type = 50 ==> forcing_fire = .true.
+!             forcing from fire.nc
+!forcing_type = 59 ==> forcing_sandu = .true.
+!             initial profiles from sanduref file: see prof.inp.001
+!             SST varying with time and divergence constante: see ifa_sanduref.txt file
+!             Radiation has to be computed interactively
+!forcing_type = 60 ==> forcing_astex = .true.
+!             initial profiles from file: see prof.inp.001 
+!             SST,divergence,ug,vg,ufa,vfa varying with time : see ifa_astex.txt file
+!             Radiation has to be computed interactively
+!forcing_type = 61 ==> forcing_armcu = .true.
+!             initial profiles from file: see prof.inp.001 
+!             sensible and latent heat flux imposed: see ifa_arm_cu_1.txt
+!             large scale advective forcing & radiative tendencies applied below 1000m: see ifa_arm_cu_2.txt
+!             use geostrophic wind ug=10m/s vg=0m/s. Duration of the case 53100s 
+!             Radiation to be switched off
+!
+      if (forcing_type <=0) THEN
+       forcing_les = .true.
+      elseif (forcing_type .eq.1) THEN
+       forcing_radconv = .true.
+      elseif (forcing_type .eq.2) THEN
+       forcing_toga    = .true.
+      elseif (forcing_type .eq.3) THEN
+       forcing_GCM2SCM = .true.
+      elseif (forcing_type .eq.4) THEN
+       forcing_twpice = .true.
+      elseif (forcing_type .eq.5) THEN
+       forcing_rico = .true.
+      elseif (forcing_type .eq.6) THEN
+       forcing_amma = .true.
+      elseif (forcing_type .eq.7) THEN
+       forcing_dice = .true.
+      elseif (forcing_type .eq.8) THEN
+       forcing_gabls4 = .true.
+      elseif (forcing_type .eq.101) THEN ! Cindynamo starts 1-10-2011 0h
+       forcing_case = .true.
+       year_ini_cas=2011
+       mth_ini_cas=10
+       day_deb=1
+       heure_ini_cas=0.
+       pdt_cas=3*3600.         ! forcing frequency
+      elseif (forcing_type .eq.102) THEN ! Bomex starts 24-6-1969 0h
+       forcing_case = .true.
+       year_ini_cas=1969
+       mth_ini_cas=6
+       day_deb=24
+       heure_ini_cas=0.
+       pdt_cas=1800.         ! forcing frequency
+      elseif (forcing_type .eq.103) THEN ! Arm_cu starts 21-6-1997 11h30
+       forcing_case2 = .true.
+       year_ini_cas=1997
+       mth_ini_cas=6
+       day_deb=21
+       heure_ini_cas=11.5
+       pdt_cas=1800.         ! forcing frequency
+      elseif (forcing_type .eq.104) THEN ! rico starts 16-12-2004 0h
+       forcing_case2 = .true.
+       year_ini_cas=2004
+       mth_ini_cas=12
+       day_deb=16
+       heure_ini_cas=0.
+       pdt_cas=1800.         ! forcing frequency
+      elseif (forcing_type .eq.105) THEN ! bomex starts 16-12-2004 0h
+       forcing_case2 = .true.
+       year_ini_cas=1969
+       mth_ini_cas=6
+       day_deb=24
+       heure_ini_cas=0.
+       pdt_cas=1800.         ! forcing frequency
+      elseif (forcing_type .eq.106) THEN ! ayotte_24SC starts 6-11-1992 0h
+       forcing_case2 = .true.
+       year_ini_cas=1992
+       mth_ini_cas=11
+       day_deb=6
+       heure_ini_cas=10.
+       pdt_cas=86400.        ! forcing frequency
+      elseif (forcing_type .eq.113) THEN ! Arm_cu starts 21-6-1997 11h30
+       forcing_SCM = .true.
+       year_ini_cas=1997
+       ! It is possible that those parameters are run twice.
+       call getin('anneeref',year_ini_cas)
+       call getin('dayref',day_deb)
+       mth_ini_cas=1 ! pour le moment on compte depuis le debut de l'annee
+       call getin('time_ini',heure_ini_cas)
+      elseif (forcing_type .eq.40) THEN
+       forcing_GCSSold = .true.
+      elseif (forcing_type .eq.50) THEN
+       forcing_fire = .true.
+      elseif (forcing_type .eq.59) THEN
+       forcing_sandu   = .true.
+      elseif (forcing_type .eq.60) THEN
+       forcing_astex   = .true.
+      elseif (forcing_type .eq.61) THEN
+       forcing_armcu = .true.
+       IF(llm.NE.19.AND.llm.NE.40) stop 'Erreur nombre de niveaux !!'
+      else
+       write (*,*) 'ERROR : unknown forcing_type ', forcing_type
+       stop 'Forcing_type should be 0,1,2,3,4,5,6 or 40,59,60,61'
+      ENDIF
+      print*,"forcing type=",forcing_type
+
+! if type_ts_forcing=0, the surface temp of 1D simulation is constant in time
+! (specified by tsurf in lmdz1d.def); if type_ts_forcing=1, the surface temperature
+! varies in time according to a forcing (e.g. forcing_toga) and is passed to read_tsurf1d.F
+! through the common sst_forcing.
+
+        type_ts_forcing = 0
+        if (forcing_toga.or.forcing_sandu.or.forcing_astex .or. forcing_dice)                 &
+     &    type_ts_forcing = 1
+!
+! Initialization of the logical switch for nudging
+     jcode = iflag_nudge
+     do i = 1,nudge_max
+       nudge(i) = mod(jcode,10) .ge. 1
+       jcode = jcode/10
+     enddo
+!---------------------------------------------------------------------
+!  Definition of the run
+!---------------------------------------------------------------------
+
+      call conf_gcm( 99, .TRUE. )
+      
+!-----------------------------------------------------------------------
+      allocate( phy_nat (year_len))  ! 0=ocean libre,1=land,2=glacier,3=banquise
+      phy_nat(:)=0.0
+      allocate( phy_alb (year_len))  ! Albedo land only (old value condsurf_jyg=0.3)
+      allocate( phy_sst (year_len))  ! SST (will not be used; cf read_tsurf1d.F)
+      allocate( phy_bil (year_len))  ! Ne sert que pour les slab_ocean
+      phy_bil(:)=1.0
+      allocate( phy_rug (year_len)) ! Longueur rugosite utilisee sur land only
+      allocate( phy_ice (year_len)) ! Fraction de glace
+      phy_ice(:)=0.0
+      allocate( phy_fter(year_len)) ! Fraction de terre
+      phy_fter(:)=0.0
+      allocate( phy_foce(year_len)) ! Fraction de ocean
+      phy_foce(:)=0.0
+      allocate( phy_fsic(year_len)) ! Fraction de glace
+      phy_fsic(:)=0.0
+      allocate( phy_flic(year_len)) ! Fraction de glace
+      phy_flic(:)=0.0
+!-----------------------------------------------------------------------
+!   Choix du calendrier
+!   -------------------
+
+!      calend = 'earth_365d'
+      if (calend == 'earth_360d') then
+        call ioconf_calendar('360_day')
+        write(*,*)'CALENDRIER CHOISI: Terrestre a 360 jours/an'
+      else if (calend == 'earth_365d') then
+        call ioconf_calendar('noleap')
+        write(*,*)'CALENDRIER CHOISI: Terrestre a 365 jours/an'
+      else if (calend == 'earth_366d') then
+        call ioconf_calendar('all_leap')
+        write(*,*)'CALENDRIER CHOISI: Terrestre bissextile'
+      else if (calend == 'gregorian') then
+        stop 'gregorian calend should not be used by normal user'
+        call ioconf_calendar('gregorian') ! not to be used by normal users
+        write(*,*)'CALENDRIER CHOISI: Gregorien'
+      else
+        write (*,*) 'ERROR : unknown calendar ', calend
+        stop 'calend should be 360d,earth_365d,earth_366d,gregorian'
+      endif
+!-----------------------------------------------------------------------
+!
+!c Date :
+!      La date est supposee donnee sous la forme [annee, numero du jour dans 
+!      l annee] ; l heure est donnee dans time_ini, lu dans lmdz1d.def.
+!      On appelle ymds2ju pour convertir [annee, jour] en [jour Julien].
+!      Le numero du jour est dans "day". L heure est traitee separement.
+!      La date complete est dans "daytime" (l'unite est le jour).
+      if (nday>0) then
+         fnday=nday
+      else
+         fnday=-nday/float(day_step)
+      endif
+      print *,'fnday=',fnday
+!     start_time doit etre en FRACTION DE JOUR
+      start_time=time_ini/24.
+
+! Special case for arm_cu which lasts less than one day : 53100s !! (MPL 20111026)
+      IF(forcing_type .EQ. 61) fnday=53100./86400.
+      IF(forcing_type .EQ. 103) fnday=53100./86400.
+! Special case for amma which lasts less than one day : 64800s !! (MPL 20120216)
+      IF(forcing_type .EQ. 6) fnday=64800./86400.
+!     IF(forcing_type .EQ. 6) fnday=50400./86400.
+ IF(forcing_type .EQ. 8 ) fnday=129600./86400. 
+      annee_ref = anneeref
+      mois = 1
+      day_ref = dayref
+      heure = 0.
+      itau_dyn = 0
+      itau_phy = 0
+      call ymds2ju(annee_ref,mois,day_ref,heure,day)
+      day_ini = int(day)
+      day_end = day_ini + int(fnday)
+
+      IF (forcing_type .eq.2) THEN
+! Convert the initial date of Toga-Coare to Julian day
+      call ymds2ju                                                          &
+     & (year_ini_toga,mth_ini_toga,day_ini_toga,heure,day_ju_ini_toga)
+
+      ELSEIF (forcing_type .eq.4) THEN
+! Convert the initial date of TWPICE to Julian day
+      call ymds2ju                                                          &
+     & (year_ini_twpi,mth_ini_twpi,day_ini_twpi,heure_ini_twpi              &
+     & ,day_ju_ini_twpi)
+      ELSEIF (forcing_type .eq.6) THEN
+! Convert the initial date of AMMA to Julian day
+      call ymds2ju                                                          &
+     & (year_ini_amma,mth_ini_amma,day_ini_amma,heure_ini_amma              &
+     & ,day_ju_ini_amma)
+      ELSEIF (forcing_type .eq.7) THEN
+! Convert the initial date of DICE to Julian day
+      call ymds2ju                                                         &
+     & (year_ini_dice,mth_ini_dice,day_ini_dice,heure_ini_dice             & 
+     & ,day_ju_ini_dice)
+ ELSEIF (forcing_type .eq.8 ) THEN
+! Convert the initial date of GABLS4 to Julian day
+      call ymds2ju                                                         &
+     & (year_ini_gabls4,mth_ini_gabls4,day_ini_gabls4,heure_ini_gabls4     & 
+     & ,day_ju_ini_gabls4)
+      ELSEIF (forcing_type .gt.100) THEN
+! Convert the initial date to Julian day
+      day_ini_cas=day_deb
+      print*,'time case',year_ini_cas,mth_ini_cas,day_ini_cas
+      call ymds2ju                                                         &
+     & (year_ini_cas,mth_ini_cas,day_ini_cas,heure_ini_cas*3600            &
+     & ,day_ju_ini_cas)
+      print*,'time case 2',day_ini_cas,day_ju_ini_cas
+      ELSEIF (forcing_type .eq.59) THEN
+! Convert the initial date of Sandu case to Julian day
+      call ymds2ju                                                          &
+     &   (year_ini_sandu,mth_ini_sandu,day_ini_sandu,                       &
+     &    time_ini*3600.,day_ju_ini_sandu)
+
+      ELSEIF (forcing_type .eq.60) THEN
+! Convert the initial date of Astex case to Julian day
+      call ymds2ju                                                          &
+     &   (year_ini_astex,mth_ini_astex,day_ini_astex,                        &
+     &    time_ini*3600.,day_ju_ini_astex)
+
+      ELSEIF (forcing_type .eq.61) THEN
+! Convert the initial date of Arm_cu case to Julian day
+      call ymds2ju                                                          &
+     & (year_ini_armcu,mth_ini_armcu,day_ini_armcu,heure_ini_armcu          &
+     & ,day_ju_ini_armcu)
+      ENDIF
+
+      IF (forcing_type .gt.100) THEN
+      daytime = day + heure_ini_cas/24. ! 1st day and initial time of the simulation 
+      ELSE
+      daytime = day + time_ini/24. ! 1st day and initial time of the simulation 
+      ENDIF
+! Print out the actual date of the beginning of the simulation :
+      call ju2ymds(daytime,year_print, month_print,day_print,sec_print)
+      print *,' Time of beginning : ',                                      &
+     &        year_print, month_print, day_print, sec_print
+
+!---------------------------------------------------------------------
+! Initialization of dimensions, geometry and initial state
+!---------------------------------------------------------------------
+!      call init_phys_lmdz(1,1,llm,1,(/1/)) ! job now done via iniphysiq
+!     but we still need to initialize dimphy module (klon,klev,etc.)  here.
+      call init_dimphy1D(1,llm)
+      call suphel
+      call init_infotrac
+
+      if (nqtot>nqmx) STOP 'Augmenter nqmx dans lmdz1d.F'
+      allocate(q(llm,nqtot)) ; q(:,:)=0.
+      allocate(dq(llm,nqtot)) 
+      allocate(dq_dyn(llm,nqtot)) 
+      allocate(d_q_adv(llm,nqtot)) 
+      allocate(d_q_nudge(llm,nqtot)) 
+!      allocate(d_th_adv(llm)) 
+
+      q(:,:) = 0.
+      dq(:,:) = 0.
+      dq_dyn(:,:) = 0.
+      d_q_adv(:,:) = 0.
+      d_q_nudge(:,:) = 0.
+
+!
+!   No ozone climatology need be read in this pre-initialization
+!          (phys_state_var_init is called again in physiq)
+      read_climoz = 0
+      nsw=6          ! EV et LF: sinon, falb_dir et falb_dif ne peuvent etre alloues
+
+
+      call phys_state_var_init(read_climoz)
+
+      if (ngrid.ne.klon) then
+         print*,'stop in inifis'
+         print*,'Probleme de dimensions :'
+         print*,'ngrid = ',ngrid
+         print*,'klon  = ',klon
+         stop
+      endif
+!!!=====================================================================
+!!! Feedback forcing values for Gateaux differentiation (al1)
+!!!=====================================================================
+!!! Surface Planck forcing bracketing call radiation
+!!      surf_Planck = 0.
+!!      surf_Conv   = 0.
+!!      write(*,*) 'Gateaux-dif Planck,Conv:',surf_Planck,surf_Conv
+!!! a mettre dans le lmdz1d.def ou autre
+!!
+!!
+      qsol = qsolinp
+      qsurf = fq_sat(tsurf,psurf/100.)
+      beta_surf = 1.
+      beta_aridity(:,:) = beta_surf
+      day1= day_ini
+      time=daytime-day
+      ts_toga(1)=tsurf ! needed by read_tsurf1d.F
+      rho(1)=psurf/(rd*tsurf*(1.+(rv/rd-1.)*qsurf)) 
+
+!
+!! mpl et jyg le 22/08/2012 : 
+!!  pour que les cas a flux de surface imposes marchent
+      IF(.NOT.ok_flux_surf.or.max(abs(wtsurf),abs(wqsurf))>0.) THEN
+       fsens=-wtsurf*rcpd*rho(1)
+       flat=-wqsurf*rlvtt*rho(1)
+       print *,'Flux: ok_flux wtsurf wqsurf',ok_flux_surf,wtsurf,wqsurf
+      ENDIF
+      print*,'Flux sol ',fsens,flat
+!!      ok_flux_surf=.false.
+!!      fsens=-wtsurf*rcpd*rho(1)
+!!      flat=-wqsurf*rlvtt*rho(1)
+!!!!
+
+! Vertical discretization and pressure levels at half and mid levels:
+
+      pa   = 5e4
+!!      preff= 1.01325e5
+      preff = psurf
+      IF (ok_old_disvert) THEN
+        call disvert0(pa,preff,ap,bp,dpres,presnivs,nivsigs,nivsig)
+        print *,'On utilise disvert0'
+        aps(1:llm)=0.5*(ap(1:llm)+ap(2:llm+1))
+        bps(1:llm)=0.5*(bp(1:llm)+bp(2:llm+1))
+        scaleheight=8.
+        pseudoalt(1:llm)=-scaleheight*log(presnivs(1:llm)/preff)
+      ELSE
+        call disvert()
+        print *,'On utilise disvert'
+!       Nouvelle version disvert permettant d imposer ap,bp (modif L.Guez) MPL 18092012
+!       Dans ce cas, on lit ap,bp dans le fichier hybrid.txt
+      ENDIF
+
+      sig_s=presnivs/preff
+      plev =ap+bp*psurf
+      play = 0.5*(plev(1:llm)+plev(2:llm+1))
+      zlay=-rd*300.*log(play/psurf)/rg ! moved after reading profiles
+
+      IF (forcing_type .eq. 59) THEN
+! pour forcing_sandu, on cherche l'indice le plus proche de 700hpa#3000m
+      write(*,*) '***********************'
+      do l = 1, llm
+       write(*,*) 'l,play(l),presnivs(l): ',l,play(l),presnivs(l)
+       if (trouve_700 .and. play(l).le.70000) then
+         llm700=l
+         print *,'llm700,play=',llm700,play(l)/100.
+         trouve_700= .false.
+       endif
+      enddo
+      write(*,*) '***********************'
+      ENDIF
+
+!
+!=====================================================================
+! EVENTUALLY, READ FORCING DATA :
+!=====================================================================
+
+      INCLUDE "old_1D_read_forc_cases.h"
+
+      if (forcing_GCM2SCM) then
+        write (*,*) 'forcing_GCM2SCM not yet implemented'
+        stop 'in initialization'
+      endif ! forcing_GCM2SCM
+
+      print*,'mxcalc=',mxcalc
+!     print*,'zlay=',zlay(mxcalc)
+      print*,'play=',play(mxcalc)
+
+!Al1 pour SST forced, appell?? depuis ocean_forced_noice
+! EV tg instead of ts_cur
+
+      tg = tsurf ! SST used in read_tsurf1d
+!=====================================================================
+! Initialisation de la physique : 
+!=====================================================================
+
+!  Rq: conf_phys.F90 lit tous les flags de physiq.def; conf_phys appele depuis physiq.F
+!
+! day_step, iphysiq lus dans gcm.def ci-dessus
+! timestep: calcule ci-dessous from rday et day_step
+! ngrid=1
+! llm: defini dans .../modipsl/modeles/LMDZ4/libf/grid/dimension
+! rday: defini dans suphel.F (86400.)
+! day_ini: lu dans run.def (dayref)
+! rlat_rad,rlon-rad: transformes en radian de rlat,rlon lus dans lmdz1d.def (en degres)
+! airefi,zcufi,zcvfi initialises au debut de ce programme
+! rday,ra,rg,rd,rcpd declares dans YOMCST.h et calcules dans suphel.F
+      day_step = float(nsplit_phys)*day_step/float(iphysiq)
+      write (*,*) 'Time step divided by nsplit_phys (=',nsplit_phys,')'
+      timestep =rday/day_step
+      dtime_frcg = timestep
+!
+      zcufi=airefi
+      zcvfi=airefi
+!
+      rlat_rad(1)=xlat*rpi/180.
+      rlon_rad(1)=xlon*rpi/180.
+
+     ! iniphysiq will call iniaqua who needs year_len from phys_cal_mod
+     year_len_phys_cal_mod=year_len
+           
+     ! Ehouarn: iniphysiq requires arrays related to (3D) dynamics grid,
+     ! e.g. for cell boundaries, which are meaningless in 1D; so pad these 
+     ! with '0.' when necessary
+      call iniphysiq(iim,jjm,llm, &
+           1,comm_lmdz, &
+           rday,day_ini,timestep,  &
+           (/rlat_rad(1),0./),(/0./), &
+           (/0.,0./),(/rlon_rad(1),0./),  &
+           (/ (/airefi,0./),(/0.,0./) /), &
+           (/zcufi,0.,0.,0./), &
+           (/zcvfi,0./), &
+           ra,rg,rd,rcpd,1)
+      print*,'apres iniphysiq'
+
+! 2 PARAMETRES QUI DEVRAIENT ETRE LUS DANS run.def MAIS NE LE SONT PAS ICI:
+      co2_ppm= 330.0
+      solaire=1370.0
+
+! Ecriture du startphy avant le premier appel a la physique.
+! On le met juste avant pour avoir acces a tous les champs
+
+      if (ok_writedem) then
+
+!--------------------------------------------------------------------------
+! pbl_surface_init (called here) and pbl_surface_final (called by phyredem)
+! need : qsol fder snow qsurf evap rugos agesno ftsoil
+!--------------------------------------------------------------------------
+
+        type_ocean = "force"
+        run_off_lic_0(1) = restart_runoff 
+        call fonte_neige_init(run_off_lic_0)
+
+        fder=0.
+        snsrf(1,:)=snowmass ! masse de neige des sous surface
+        print *, 'snsrf', snsrf
+        qsurfsrf(1,:)=qsurf ! humidite de l'air des sous surface
+        fevap=0.
+        z0m(1,:)=rugos     ! couverture de neige des sous surface
+        z0h(1,:)=rugosh    ! couverture de neige des sous surface
+        agesno  = xagesno
+        tsoil(:,:,:)=tsurf
+!------ AMMA 2e run avec modele sol et rayonnement actif (MPL 23052012)
+!       tsoil(1,1,1)=299.18
+!       tsoil(1,2,1)=300.08
+!       tsoil(1,3,1)=301.88
+!       tsoil(1,4,1)=305.48
+!       tsoil(1,5,1)=308.00
+!       tsoil(1,6,1)=308.00
+!       tsoil(1,7,1)=308.00
+!       tsoil(1,8,1)=308.00
+!       tsoil(1,9,1)=308.00
+!       tsoil(1,10,1)=308.00
+!       tsoil(1,11,1)=308.00
+!-----------------------------------------------------------------------
+        call pbl_surface_init(fder, snsrf, qsurfsrf, tsoil)
+
+!------------------ prepare limit conditions for limit.nc -----------------
+!--   Ocean force
+
+        print*,'avant phyredem'
+        pctsrf(1,:)=0.
+          if (nat_surf.eq.0.) then
+          pctsrf(1,is_oce)=1.
+          pctsrf(1,is_ter)=0.
+          pctsrf(1,is_lic)=0.
+          pctsrf(1,is_sic)=0.
+        else if (nat_surf .eq. 1) then 
+          pctsrf(1,is_oce)=0.
+          pctsrf(1,is_ter)=1.
+          pctsrf(1,is_lic)=0.
+          pctsrf(1,is_sic)=0.
+        else if (nat_surf .eq. 2) then 
+          pctsrf(1,is_oce)=0.
+          pctsrf(1,is_ter)=0.
+          pctsrf(1,is_lic)=1.
+          pctsrf(1,is_sic)=0.
+        else if (nat_surf .eq. 3) then 
+          pctsrf(1,is_oce)=0.
+          pctsrf(1,is_ter)=0.
+          pctsrf(1,is_lic)=0.
+          pctsrf(1,is_sic)=1.
+
+     end if
+
+        print*,'nat_surf,pctsrf(1,is_oce),pctsrf(1,is_ter)',nat_surf         &
+     &        ,pctsrf(1,is_oce),pctsrf(1,is_ter)
+
+        zmasq=pctsrf(1,is_ter)+pctsrf(1,is_lic)
+        zpic = zpicinp
+        ftsol=tsurf
+        falb_dir=albedo
+        falb_dif=albedo
+        rugoro=rugos 
+        t_ancien(1,:)=temp(:)
+        q_ancien(1,:)=q(:,1)
+        ql_ancien = 0.
+        qs_ancien = 0.
+        prlw_ancien = 0.
+        prsw_ancien = 0.
+        prw_ancien = 0.
+        IF ( ok_bs ) THEN
+          qbs_ancien = 0.
+          prbsw_ancien = 0.
+        ENDIF
+        IF ( ok_ice_supersat ) THEN
+          cf_ancien = 0.
+          rvc_ancien = 0.
+        ENDIF
+!jyg<
+!!        pbl_tke(:,:,:)=1.e-8
+        pbl_tke(:,:,:)=0.
+        pbl_tke(:,2,:)=1.e-2
+        PRINT *, ' pbl_tke dans lmdz1d '
+        if (prt_level .ge. 5) then 
+         DO nsrf = 1,4
+           PRINT *,'pbl_tke(1,:,',nsrf,') ',pbl_tke(1,:,nsrf)
+         ENDDO
+        end if
+
+!>jyg
+
+        rain_fall=0.
+        snow_fall=0.
+        solsw=0.
+        solswfdiff=0.
+        sollw=0.
+        sollwdown=rsigma*tsurf**4
+        radsol=0.
+        rnebcon=0.
+        ratqs=0.
+        clwcon=0.
+        zmax0 = 0.
+        zmea=zsurf
+        zstd=0.
+        zsig=0.
+        zgam=0.
+        zval=0. 
+        zthe=0. 
+        sig1=0.
+        w01=0.
+!
+        wake_deltaq = 0.
+        wake_deltat = 0.
+        wake_delta_pbl_TKE(:,:,:) = 0.
+        delta_tsurf = 0.
+        wake_fip = 0.
+        wake_pe = 0.
+        wake_s = 0.
+        awake_s = 0.
+        wake_dens = 0.
+        awake_dens = 0.
+        cv_gen = 0.
+        wake_cstar = 0.
+        ale_bl = 0.
+        ale_bl_trig = 0.
+        alp_bl = 0.
+        IF (ALLOCATED(du_gwd_rando)) du_gwd_rando = 0.
+        IF (ALLOCATED(du_gwd_front)) du_gwd_front = 0.
+        entr_therm = 0.
+        detr_therm = 0.
+        f0 = 0.
+        fm_therm = 0.
+        u_ancien(1,:)=u(:)
+        v_ancien(1,:)=v(:)
+
+        u10m=0.
+        v10m=0.
+        ale_wake=0.
+        ale_bl_stat=0.
+ 
+!------------------------------------------------------------------------
+! Make file containing restart for the physics (startphy.nc)
+!
+! NB: List of the variables to be written by phyredem (via put_field):
+! rlon,rlat,zmasq,pctsrf(:,is_ter),pctsrf(:,is_lic),pctsrf(:,is_oce)
+! pctsrf(:,is_sic),ftsol(:,nsrf),tsoil(:,isoil,nsrf),qsurf(:,nsrf)
+! qsol,falb_dir(:,nsrf),falb_dif(:,nsrf),evap(:,nsrf),snow(:,nsrf)
+! radsol,solsw,solswfdiff,sollw, sollwdown,fder,rain_fall,snow_fall,frugs(:,nsrf)
+! agesno(:,nsrf),zmea,zstd,zsig,zgam,zthe,zpic,zval,rugoro
+! t_ancien,q_ancien,,frugs(:,is_oce),clwcon(:,1),rnebcon(:,1),ratqs(:,1)
+! run_off_lic_0,pbl_tke(:,1:klev,nsrf), zmax0,f0,sig1,w01
+! wake_deltat,wake_deltaq,wake_s,awake_s,wake_dens,awake_dens,cv_gen,wake_cstar,
+! wake_fip,wake_delta_pbl_tke(:,1:klev,nsrf)
+!
+! NB2: The content of the startphy.nc file depends on some flags defined in
+! the ".def" files. However, since conf_phys is not called in lmdz1d.F90, these flags have 
+! to be set at some arbitratry convenient values.
+!------------------------------------------------------------------------
+!Al1 =============== restart option ==========================
+        iflag_physiq=0
+        call getin('iflag_physiq',iflag_physiq)
+
+        if (.not.restart) then
+          iflag_pbl = 5
+          call phyredem ("startphy.nc")
+        else
+! (desallocations)
+        print*,'callin surf final'
+          call pbl_surface_final( fder, snsrf, qsurfsrf, tsoil)
+        print*,'after surf final'
+          CALL fonte_neige_final(run_off_lic_0)
+        endif
+
+        ok_writedem=.false.
+        print*,'apres phyredem'
+
+      endif ! ok_writedem
+      
+!------------------------------------------------------------------------
+! Make file containing boundary conditions (limit.nc) **Al1->restartdyn***
+! --------------------------------------------------
+! NB: List of the variables to be written in limit.nc 
+!     (by writelim.F, subroutine of 1DUTILS.h):
+!        phy_nat,phy_alb,phy_sst,phy_bil,phy_rug,phy_ice,
+!        phy_fter,phy_foce,phy_flic,phy_fsic)
+!------------------------------------------------------------------------
+      do i=1,year_len
+        phy_nat(i)  = nat_surf
+        phy_alb(i)  = albedo
+        phy_sst(i)  = tsurf ! read_tsurf1d will be used instead
+        phy_rug(i)  = rugos
+        phy_fter(i) = pctsrf(1,is_ter)
+        phy_foce(i) = pctsrf(1,is_oce)
+        phy_fsic(i) = pctsrf(1,is_sic)
+        phy_flic(i) = pctsrf(1,is_lic)
+      enddo
+
+! fabrication de limit.nc
+      call writelim (1,phy_nat,phy_alb,phy_sst,phy_bil,phy_rug,             &
+     &               phy_ice,phy_fter,phy_foce,phy_flic,phy_fsic)
+
+
+      call phys_state_var_end
+!Al1
+      if (restart) then
+        print*,'call to restart dyn 1d'
+        Call dyn1deta0("start1dyn.nc",plev,play,phi,phis,presnivs,          &
+     &              u,v,temp,q,omega2)
+
+       print*,'fnday,annee_ref,day_ref,day_ini',                            &
+     &     fnday,annee_ref,day_ref,day_ini
+!**      call ymds2ju(annee_ref,mois,day_ini,heure,day)
+       day = day_ini
+       day_end = day_ini + nday
+       daytime = day + time_ini/24. ! 1st day and initial time of the simulation 
+
+! Print out the actual date of the beginning of the simulation :
+       call ju2ymds(daytime, an, mois, jour, heure)
+       print *,' Time of beginning : y m d h',an, mois,jour,heure/3600.
+
+       day = int(daytime)
+       time=daytime-day
+  
+       print*,'****** intialised fields from restart1dyn *******'
+       print*,'plev,play,phi,phis,presnivs,u,v,temp,q,omega2'
+       print*,'temp(1),q(1,1),u(1),v(1),plev(1),phis :'
+       print*,temp(1),q(1,1),u(1),v(1),plev(1),phis
+! raz for safety
+       do l=1,llm
+         dq_dyn(l,1) = 0.
+       enddo
+      endif
+!Al1 ================  end restart =================================
+      IF (ecrit_slab_oc.eq.1) then
+         open(97,file='div_slab.dat',STATUS='UNKNOWN')
+       elseif (ecrit_slab_oc.eq.0) then
+         open(97,file='div_slab.dat',STATUS='OLD')
+       endif
+!
+!---------------------------------------------------------------------
+!    Initialize target profile for RHT nudging if needed
+!---------------------------------------------------------------------
+      if (nudge(inudge_RHT)) then
+        call nudge_RHT_init(plev,play,temp,q(:,1),t_targ,rh_targ)
+      endif
+      if (nudge(inudge_UV)) then
+        call nudge_UV_init(plev,play,u,v,u_targ,v_targ)
+      endif
+!
+!=====================================================================
+IF (CPPKEY_OUTPUTPHYSSCM) THEN
+       CALL iophys_ini(timestep)
+END IF
+! START OF THE TEMPORAL LOOP :
+!=====================================================================
+           
+      it_end = nint(fnday*day_step)
+!test JLD     it_end = 10
+      do while(it.le.it_end)
+
+       if (prt_level.ge.1) then
+         print*,'XXXXXXXXXXXXXXXXXXX ITAP,day,time=',                       &
+     &             it,day,time,it_end,day_step
+         print*,'PAS DE TEMPS ',timestep
+       endif
+!Al1 demande de restartphy.nc
+       if (it.eq.it_end) lastcall=.True.
+
+!---------------------------------------------------------------------
+!  Geopotential :
+!---------------------------------------------------------------------
+
+        phi(1)=RD*temp(1)*(plev(1)-play(1))/(.5*(plev(1)+play(1)))
+        do l = 1, llm-1
+          phi(l+1)=phi(l)+RD*(temp(l)+temp(l+1))*                           &
+     &    (play(l)-play(l+1))/(play(l)+play(l+1))
+        enddo
+
+!---------------------------------------------------------------------
+! Interpolation of forcings in time and onto model levels
+!---------------------------------------------------------------------
+
+      INCLUDE "old_1D_interp_cases.h"
+
+      if (forcing_GCM2SCM) then
+        write (*,*) 'forcing_GCM2SCM not yet implemented'
+        stop 'in time loop'
+      endif ! forcing_GCM2SCM
+
+!!!!---------------------------------------------------------------------
+!!!!  Geopotential :
+!!!!---------------------------------------------------------------------
+!!!
+!!!        phi(1)=RD*temp(1)*(plev(1)-play(1))/(.5*(plev(1)+play(1)))
+!!!        do l = 1, llm-1
+!!!          phi(l+1)=phi(l)+RD*(temp(l)+temp(l+1))*                           &
+!!!     &    (play(l)-play(l+1))/(play(l)+play(l+1))
+!!!        enddo
+
+!---------------------------------------------------------------------
+! Listing output for debug prt_level>=1
+!---------------------------------------------------------------------
+       if (prt_level>=1) then
+         print *,' avant physiq : -------- day time ',day,time
+         write(*,*) 'firstcall,lastcall,phis',                               &
+     &               firstcall,lastcall,phis
+       end if
+       if (prt_level>=5) then
+         write(*,'(a10,2a4,4a13)') 'BEFOR1 IT=','it','l',                   &
+     &        'presniv','plev','play','phi'
+         write(*,'(a10,2i4,4f13.2)') ('BEFOR1 IT= ',it,l,                   &
+     &         presnivs(l),plev(l),play(l),phi(l),l=1,llm)
+         write(*,'(a11,2a4,a11,6a8)') 'BEFOR2','it','l',                    &
+     &         'presniv','u','v','temp','q1','q2','omega2'
+         write(*,'(a11,2i4,f11.2,5f8.2,e10.2)') ('BEFOR2 IT= ',it,l,         &
+     &   presnivs(l),u(l),v(l),temp(l),q(l,1),q(l,2),omega2(l),l=1,llm)
+       endif
+
+!---------------------------------------------------------------------
+!   Call physiq :
+!---------------------------------------------------------------------
+       call physiq(ngrid,llm, &
+                    firstcall,lastcall,timestep, &
+                    plev,play,phi,phis,presnivs, &
+                    u,v, rot, temp,q,omega2, &
+                    du_phys,dv_phys,dt_phys,dq,dpsrf)
+                firstcall=.false.
+
+!---------------------------------------------------------------------
+! Listing output for debug
+!---------------------------------------------------------------------
+        if (prt_level>=5) then
+          write(*,'(a11,2a4,4a13)') 'AFTER1 IT=','it','l',                  &
+     &        'presniv','plev','play','phi'
+          write(*,'(a11,2i4,4f13.2)') ('AFTER1 it= ',it,l,                  &
+     &    presnivs(l),plev(l),play(l),phi(l),l=1,llm)
+          write(*,'(a11,2a4,a11,6a8)') 'AFTER2','it','l',                   &
+     &         'presniv','u','v','temp','q1','q2','omega2'
+          write(*,'(a11,2i4,f11.2,5f8.2,e10.2)') ('AFTER2 it= ',it,l,       &
+     &    presnivs(l),u(l),v(l),temp(l),q(l,1),q(l,2),omega2(l),l=1,llm)
+          write(*,'(a11,2a4,a11,5a8)') 'AFTER3','it','l',                   &
+     &         'presniv','du_phys','dv_phys','dt_phys','dq1','dq2'    
+           write(*,'(a11,2i4,f11.2,5f8.2)') ('AFTER3 it= ',it,l,            &
+     &      presnivs(l),86400*du_phys(l),86400*dv_phys(l),                   &
+     &       86400*dt_phys(l),86400*dq(l,1),dq(l,2),l=1,llm)
+          write(*,*) 'dpsrf',dpsrf
+        endif
+!---------------------------------------------------------------------
+!   Add physical tendencies :
+!---------------------------------------------------------------------
+
+       fcoriolis=2.*sin(rpi*xlat/180.)*romega
+       if (forcing_radconv .or. forcing_fire) then
+         fcoriolis=0.0
+         dt_cooling=0.0
+         d_t_adv=0.0
+         d_q_adv=0.0
+       endif
+!      print*, 'calcul de fcoriolis ', fcoriolis
+
+       if (forcing_toga .or. forcing_GCSSold .or. forcing_twpice            &
+     &    .or.forcing_amma .or. forcing_type.eq.101) then
+         fcoriolis=0.0 ; ug=0. ; vg=0.
+       endif
+
+       if(forcing_rico) then
+          dt_cooling=0.
+       endif
+
+!CRio:Attention modif sp??cifique cas de Caroline
+      if (forcing_type==-1) then
+         fcoriolis=0.
+!Nudging
+        
+!on calcule dt_cooling
+        do l=1,llm
+        if (play(l).ge.20000.) then
+            dt_cooling(l)=-1.5/86400.
+        elseif ((play(l).ge.10000.).and.((play(l).lt.20000.))) then
+            dt_cooling(l)=-1.5/86400.*(play(l)-10000.)/(10000.)-1./86400.*(20000.-play(l))/10000.*(temp(l)-200.)
+        else
+            dt_cooling(l)=-1.*(temp(l)-200.)/86400.
+        endif
+        enddo
+
+      endif     
+!RC
+      if (forcing_sandu) then
+         ug(1:llm)=u_mod(1:llm)
+         vg(1:llm)=v_mod(1:llm)
+      endif
+
+      IF (prt_level >= 5) print*, 'fcoriolis, xlat,mxcalc ', &
+                                   fcoriolis, xlat,mxcalc
+
+!       print *,'u-ug=',u-ug
+
+!!!!!!!!!!!!!!!!!!!!!!!!
+! Geostrophic wind
+! Le calcul ci dessous est insuffisamment precis
+!      du_age(1:mxcalc)=fcoriolis*(v(1:mxcalc)-vg(1:mxcalc))
+!      dv_age(1:mxcalc)=-fcoriolis*(u(1:mxcalc)-ug(1:mxcalc))
+!!!!!!!!!!!!!!!!!!!!!!!!
+       sfdt = sin(0.5*fcoriolis*timestep)
+       cfdt = cos(0.5*fcoriolis*timestep)
+!       print *,'fcoriolis,sfdt,cfdt,timestep',fcoriolis,sfdt,cfdt,timestep
+!
+        du_age(1:mxcalc)= -2.*sfdt/timestep*                                &
+     &          (sfdt*(u(1:mxcalc)-ug(1:mxcalc)) -                          &
+     &           cfdt*(v(1:mxcalc)-vg(1:mxcalc))  )
+!!     : fcoriolis*(v(1:mxcalc)-vg(1:mxcalc))
+!
+       dv_age(1:mxcalc)= -2.*sfdt/timestep*                                 &
+     &          (cfdt*(u(1:mxcalc)-ug(1:mxcalc)) +                           &
+     &           sfdt*(v(1:mxcalc)-vg(1:mxcalc))  )
+!!     : -fcoriolis*(u(1:mxcalc)-ug(1:mxcalc))
+!
+!!!!!!!!!!!!!!!!!!!!!!!!
+!  Nudging
+!!!!!!!!!!!!!!!!!!!!!!!!
+      d_t_nudge(:) = 0.
+      d_q_nudge(:,:) = 0.
+      d_u_nudge(:) = 0.
+      d_v_nudge(:) = 0.
+      if (nudge(inudge_RHT)) then
+        call nudge_RHT(timestep,plev,play,t_targ,rh_targ,temp,q(:,1),     &
+    &                  d_t_nudge,d_q_nudge(:,1))
+      endif
+      if (nudge(inudge_UV)) then
+        call nudge_UV(timestep,plev,play,u_targ,v_targ,u,v,     &
+    &                  d_u_nudge,d_v_nudge)
+      endif
+!
+       if (forcing_fire) THEN
+
+!let ww=if ( alt le 1100 ) then alt*-0.00001 else 0
+!let wt=if ( alt le 1100 ) then min( -3.75e-5 , -7.5e-8*alt)  else 0
+!let wq=if ( alt le 1100 ) then max( 1.5e-8 , 3e-11*alt)  else 0
+           d_t_adv=0.
+           d_q_adv=0.
+           teta=temp*(pzero/play)**rkappa
+           d_t_adv=0.
+           d_q_adv=0.
+           do l=2,llm-1
+              if (zlay(l)<=1100) then
+                  wwww=-0.00001*zlay(l)
+                  d_t_adv(l)=-wwww*(teta(l)-teta(l+1))/(zlay(l)-zlay(l+1)) /(pzero/play(l))**rkappa
+                  d_q_adv(l,1:2)=-wwww*(q(l,1:2)-q(l+1,1:2))/(zlay(l)-zlay(l+1))
+                  d_t_adv(l)=d_t_adv(l)+min(-3.75e-5 , -7.5e-8*zlay(l))
+                  d_q_adv(l,1)=d_q_adv(l,1)+max( 1.5e-8 , 3e-11*zlay(l))
+              endif
+           enddo
+
+        endif
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!         call  writefield_phy('dv_age' ,dv_age,llm)
+!         call  writefield_phy('du_age' ,du_age,llm)
+!         call  writefield_phy('du_phys' ,du_phys,llm)
+!         call  writefield_phy('u_tend' ,u,llm)
+!         call  writefield_phy('u_g' ,ug,llm)
+!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! Increment state variables
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+    IF (flag_inhib_forcing == 0) then ! if tendency of forcings should be added
+
+! pour les cas sandu et astex, on reclacule u,v,q,temp et teta dans 1D_nudge_sandu_astex.h
+! au dessus de 700hpa, on relaxe vers les profils initiaux
+      if (forcing_sandu .OR. forcing_astex) then
+      INCLUDE "1D_nudge_sandu_astex.h"
+      else
+        u(1:mxcalc)=u(1:mxcalc) + timestep*(                                &
+     &              du_phys(1:mxcalc)                                       &
+     &             +du_age(1:mxcalc)+du_adv(1:mxcalc)                       &
+     &             +d_u_nudge(1:mxcalc) )            
+        v(1:mxcalc)=v(1:mxcalc) + timestep*(                                 &
+     &              dv_phys(1:mxcalc)                                       &
+     &             +dv_age(1:mxcalc)+dv_adv(1:mxcalc)                       &
+     &             +d_v_nudge(1:mxcalc) )
+        q(1:mxcalc,:)=q(1:mxcalc,:)+timestep*(                              &
+     &                dq(1:mxcalc,:)                                        &
+     &               +d_q_adv(1:mxcalc,:)                                   &
+     &               +d_q_nudge(1:mxcalc,:) )
+
+        if (prt_level.ge.3) then
+          print *,                                                          &
+     &    'physiq-> temp(1),dt_phys(1),d_t_adv(1),dt_cooling(1) ',         &
+     &              temp(1),dt_phys(1),d_t_adv(1),dt_cooling(1)
+           print* ,'dv_phys=',dv_phys
+           print* ,'dv_age=',dv_age
+           print* ,'dv_adv=',dv_adv
+           print* ,'d_v_nudge=',d_v_nudge
+           print*, v
+           print*, vg
+        endif
+
+        temp(1:mxcalc)=temp(1:mxcalc)+timestep*(                            &
+     &              dt_phys(1:mxcalc)                                       &
+     &             +d_t_adv(1:mxcalc)                                      &
+     &             +d_t_nudge(1:mxcalc)                                      &
+     &             +dt_cooling(1:mxcalc))  ! Taux de chauffage ou refroid.
+
+IF (CPPKEY_OUTPUTPHYSSCM) THEN
+      CALL iophys_ecrit('d_t_adv',klev,'d_t_adv','m/s',d_t_adv)
+      CALL iophys_ecrit('d_t_nudge',klev,'d_t_nudge','m/s',d_t_nudge)
+END IF
+
+      endif  ! forcing_sandu or forcing_astex
+
+        teta=temp*(pzero/play)**rkappa
+!
+!---------------------------------------------------------------------
+!   Nudge soil temperature if requested
+!---------------------------------------------------------------------
+
+      IF (nudge_tsoil .AND. .NOT. lastcall) THEN
+       ftsoil(1,isoil_nudge,:) = ftsoil(1,isoil_nudge,:)                     &
+     &  -timestep/tau_soil_nudge*(ftsoil(1,isoil_nudge,:)-Tsoil_nudge)
+      ENDIF
+
+!---------------------------------------------------------------------
+!   Add large-scale tendencies (advection, etc) :
+!---------------------------------------------------------------------
+
+!cc nrlmd
+!cc        tmpvar=teta
+!cc        call advect_vert(llm,omega,timestep,tmpvar,plev)
+!cc
+!cc        teta(1:mxcalc)=tmpvar(1:mxcalc)
+!cc        tmpvar(:)=q(:,1)
+!cc        call advect_vert(llm,omega,timestep,tmpvar,plev)
+!cc        q(1:mxcalc,1)=tmpvar(1:mxcalc)
+!cc        tmpvar(:)=q(:,2)
+!cc        call advect_vert(llm,omega,timestep,tmpvar,plev)
+!cc        q(1:mxcalc,2)=tmpvar(1:mxcalc)
+
+   END IF ! end if tendency of tendency should be added
+
+!---------------------------------------------------------------------
+!   Air temperature :
+!---------------------------------------------------------------------        
+        if (lastcall) then
+          print*,'Pas de temps final ',it
+          call ju2ymds(daytime, an, mois, jour, heure)
+          print*,'a la date : a m j h',an, mois, jour ,heure/3600.
+        endif
+
+!  incremente day time
+!        print*,'daytime bef',daytime,1./day_step
+        daytime = daytime+1./day_step
+!Al1dbg
+        day = int(daytime+0.1/day_step)
+!        time = max(daytime-day,0.0)
+!Al1&jyg: correction de bug
+!cc        time = real(mod(it,day_step))/day_step
+        time = time_ini/24.+real(mod(it,day_step))/day_step
+!        print*,'daytime nxt time',daytime,time
+        it=it+1
+
+      enddo
+
+!Al1
+      if (ecrit_slab_oc.ne.-1) close(97)
+
+!Al1 Call to 1D equivalent of dynredem (an,mois,jour,heure ?)
+! -------------------------------------
+       call dyn1dredem("restart1dyn.nc",                                    &
+     &              plev,play,phi,phis,presnivs,                            &
+     &              u,v,temp,q,omega2)
+
+        CALL abort_gcm ('lmdz1d   ','The End  ',0)
+
+        END SUBROUTINE old_lmdz1d
+
+        INCLUDE "old_1DUTILS_read_interp.h"
Index: DZ6/trunk/libf/phylmd/dyn1d/replay1d.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/dyn1d/replay1d.F90	(revision 5267)
+++ 	(revision )
@@ -1,159 +1,0 @@
-PROGRAM rejouer
-
-USE mod_const_mpi, ONLY: comm_lmdz
-USE inigeomphy_mod, ONLY: inigeomphy
-USE comvert_mod, ONLY: presnivs
-USE comvert_mod, only :  preff, pa
-USE ioipsl, only: getin
-
-
-
-
-      implicit none
-      INCLUDE "dimensions.h"
-
-real :: airefi
-real :: zcufi    = 1.
-real :: zcvfi    = 1.
-real :: rlat_rad(1),rlon_rad(1)
-
-integer ntime
-integer jour0,mois0,an0,day_step,anneeref,dayref
-integer klev,klon
-CHARACTER (len=10) :: calend
-CHARACTER(len=20) :: calendrier
-
-
-!---------------------------------------------------------------------
-! L'appel a inigeomphy n'est utile que pour avoir getin_p dans 
-! les initialisations
-!---------------------------------------------------------------------
-  zcufi=1.
-  zcvfi=1.
-  rlat_rad(1)=0.
-  rlon_rad(1)=0.
-
-preff=101325.
-!preff=100000.
-pa=50000.
-  CALL disvert()
-  CALL inigeomphy(1,1,llm, &
-               1, comm_lmdz, &
-           (/rlat_rad(1),0./),(/0./), &
-           (/0.,0./),(/rlon_rad(1),0./),  &
-           (/ (/airefi,0./),(/0.,0./) /), &
-           (/zcufi,0.,0.,0./), &
-           (/zcvfi,0./))
-
-CALL suphel
-!ntime=4320
-ntime=10000000
-dayref=1
-anneeref=2000
-call getin('dayref',dayref)
-call getin('anneeref',anneeref)
-call getin('calend',calend)
-call getin('day_step',day_step)
-calendrier=calend
-if ( calendrier == "earth_360d" ) calendrier="360_day"
-
-
-jour0=dayref
-mois0=(jour0-1)/30+1
-jour0=jour0-30*((jour0-1)/30)
-an0=anneeref
-
-!print*,"REPLAY1D jour0,mois0,an0",jour0,mois0,an0
-
-
-klon=1
-klev=llm
-call iotd_ini('phys.nc',1,1,klev,0.,0.,presnivs,jour0,mois0,an0,0.,86400./day_step,calendrier)
-! Consistent with ... CALL iophys_ini(600.)
-
-!---------------------------------------------------------------------
-! Initialisation de la parametrisation
-!---------------------------------------------------------------------
-call call_ini_replay
-
-!---------------------------------------------------------------------
-! Boucle en temps sur l'appel à la parametrisation
-!---------------------------------------------------------------------
-call call_param_replay(klon,klev)
-
-end
-
-!---------------------------------------------------------------------
-!/////////////////////////////////////////////////////////////////////
-!/////////////////////////////////////////////////////////////////////
-!     routine additionnelles utiles, prises dans 1DUTILS.h
-!/////////////////////////////////////////////////////////////////////
-!/////////////////////////////////////////////////////////////////////
-!---------------------------------------------------------------------
-
-!=======================================================================
-      SUBROUTINE abort_gcm(modname, message, ierr)
-      USE IOIPSL
-! Stops the simulation cleanly, closing files and printing various
-! comments
-!=======================================================================
-!
-!  Input: modname = name of calling program
-!         message = stuff to print
-!         ierr    = severity of situation ( = 0 normal )
- 
-      character(len=*) modname
-      integer ierr
-      character(len=*) message
- 
-      write(*,*) 'in abort_gcm'
-      call histclo
-      write(*,*) 'out of histclo'
-      write(*,*) 'Stopping in ', modname
-      write(*,*) 'Reason = ',message
-      call getin_dump
-!
-      if (ierr .eq. 0) then
-        write(*,*) 'Everything is cool'
-      else
-        write(*,*) 'Houston, we have a problem ', ierr
-      endif
-      STOP
-      END
-
-!=======================================================================
-      SUBROUTINE gr_dyn_fi(nfield,im,jm,ngrid,pdyn,pfi)
-      IMPLICIT NONE
-!   passage d'un champ de la grille scalaire a la grille physique
-!=======================================================================
- 
-!-----------------------------------------------------------------------
-!   declarations:
-!   -------------
- 
-      INTEGER im,jm,ngrid,nfield
-      REAL pdyn(im,jm,nfield)
-      REAL pfi(ngrid,nfield)
- 
-      INTEGER j,ifield,ig
- 
-!-----------------------------------------------------------------------
-!   calcul:
-!   -------
- 
-      IF(ngrid.NE.2+(jm-2)*(im-1).AND.ngrid.NE.1)                          &
-     &    STOP 'probleme de dim'
-!   traitement des poles
-      CALL SCOPY(nfield,pdyn,im*jm,pfi,ngrid)
-      CALL SCOPY(nfield,pdyn(1,jm,1),im*jm,pfi(ngrid,1),ngrid)
- 
-!   traitement des point normaux
-      DO ifield=1,nfield
-         DO j=2,jm-1
-            ig=2+(j-2)*(im-1)
-            CALL SCOPY(im-1,pdyn(1,j,ifield),1,pfi(ig,ifield),1)
-         ENDDO
-      ENDDO
- 
-      RETURN
-      END
Index: /LMDZ6/trunk/libf/phylmd/dyn1d/replay1d.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/dyn1d/replay1d.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/dyn1d/replay1d.f90	(revision 5268)
@@ -0,0 +1,159 @@
+PROGRAM rejouer
+
+USE mod_const_mpi, ONLY: comm_lmdz
+USE inigeomphy_mod, ONLY: inigeomphy
+USE comvert_mod, ONLY: presnivs
+USE comvert_mod, only :  preff, pa
+USE ioipsl, only: getin
+
+
+
+
+      implicit none
+      INCLUDE "dimensions.h"
+
+real :: airefi
+real :: zcufi    = 1.
+real :: zcvfi    = 1.
+real :: rlat_rad(1),rlon_rad(1)
+
+integer ntime
+integer jour0,mois0,an0,day_step,anneeref,dayref
+integer klev,klon
+CHARACTER (len=10) :: calend
+CHARACTER(len=20) :: calendrier
+
+
+!---------------------------------------------------------------------
+! L'appel a inigeomphy n'est utile que pour avoir getin_p dans 
+! les initialisations
+!---------------------------------------------------------------------
+  zcufi=1.
+  zcvfi=1.
+  rlat_rad(1)=0.
+  rlon_rad(1)=0.
+
+preff=101325.
+!preff=100000.
+pa=50000.
+  CALL disvert()
+  CALL inigeomphy(1,1,llm, &
+               1, comm_lmdz, &
+           (/rlat_rad(1),0./),(/0./), &
+           (/0.,0./),(/rlon_rad(1),0./),  &
+           (/ (/airefi,0./),(/0.,0./) /), &
+           (/zcufi,0.,0.,0./), &
+           (/zcvfi,0./))
+
+CALL suphel
+!ntime=4320
+ntime=10000000
+dayref=1
+anneeref=2000
+call getin('dayref',dayref)
+call getin('anneeref',anneeref)
+call getin('calend',calend)
+call getin('day_step',day_step)
+calendrier=calend
+if ( calendrier == "earth_360d" ) calendrier="360_day"
+
+
+jour0=dayref
+mois0=(jour0-1)/30+1
+jour0=jour0-30*((jour0-1)/30)
+an0=anneeref
+
+!print*,"REPLAY1D jour0,mois0,an0",jour0,mois0,an0
+
+
+klon=1
+klev=llm
+call iotd_ini('phys.nc',1,1,klev,0.,0.,presnivs,jour0,mois0,an0,0.,86400./day_step,calendrier)
+! Consistent with ... CALL iophys_ini(600.)
+
+!---------------------------------------------------------------------
+! Initialisation de la parametrisation
+!---------------------------------------------------------------------
+call call_ini_replay
+
+!---------------------------------------------------------------------
+! Boucle en temps sur l'appel à la parametrisation
+!---------------------------------------------------------------------
+call call_param_replay(klon,klev)
+
+end
+
+!---------------------------------------------------------------------
+!/////////////////////////////////////////////////////////////////////
+!/////////////////////////////////////////////////////////////////////
+!     routine additionnelles utiles, prises dans 1DUTILS.h
+!/////////////////////////////////////////////////////////////////////
+!/////////////////////////////////////////////////////////////////////
+!---------------------------------------------------------------------
+
+!=======================================================================
+      SUBROUTINE abort_gcm(modname, message, ierr)
+      USE IOIPSL
+! Stops the simulation cleanly, closing files and printing various
+! comments
+!=======================================================================
+!
+!  Input: modname = name of calling program
+!         message = stuff to print
+!         ierr    = severity of situation ( = 0 normal )
+ 
+      character(len=*) modname
+      integer ierr
+      character(len=*) message
+ 
+      write(*,*) 'in abort_gcm'
+      call histclo
+      write(*,*) 'out of histclo'
+      write(*,*) 'Stopping in ', modname
+      write(*,*) 'Reason = ',message
+      call getin_dump
+!
+      if (ierr .eq. 0) then
+        write(*,*) 'Everything is cool'
+      else
+        write(*,*) 'Houston, we have a problem ', ierr
+      endif
+      STOP
+      END
+
+!=======================================================================
+      SUBROUTINE gr_dyn_fi(nfield,im,jm,ngrid,pdyn,pfi)
+      IMPLICIT NONE
+!   passage d'un champ de la grille scalaire a la grille physique
+!=======================================================================
+ 
+!-----------------------------------------------------------------------
+!   declarations:
+!   -------------
+ 
+      INTEGER im,jm,ngrid,nfield
+      REAL pdyn(im,jm,nfield)
+      REAL pfi(ngrid,nfield)
+ 
+      INTEGER j,ifield,ig
+ 
+!-----------------------------------------------------------------------
+!   calcul:
+!   -------
+ 
+      IF(ngrid.NE.2+(jm-2)*(im-1).AND.ngrid.NE.1)                          &
+     &    STOP 'probleme de dim'
+!   traitement des poles
+      CALL SCOPY(nfield,pdyn,im*jm,pfi,ngrid)
+      CALL SCOPY(nfield,pdyn(1,jm,1),im*jm,pfi(ngrid,1),ngrid)
+ 
+!   traitement des point normaux
+      DO ifield=1,nfield
+         DO j=2,jm-1
+            ig=2+(j-2)*(im-1)
+            CALL SCOPY(im-1,pdyn(1,j,ifield),1,pfi(ig,ifield),1)
+         ENDDO
+      ENDDO
+ 
+      RETURN
+      END
Index: DZ6/trunk/libf/phylmd/dyn1d/scm.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/dyn1d/scm.F90	(revision 5267)
+++ 	(revision )
@@ -1,1124 +1,0 @@
-SUBROUTINE scm
-
-   USE ioipsl, only: ju2ymds, ymds2ju, ioconf_calendar,getin
-   USE phys_state_var_mod, ONLY : phys_state_var_init, phys_state_var_end, &
-       clwcon, detr_therm, &
-       qsol, fevap, z0m, z0h, agesno, &
-       du_gwd_rando, du_gwd_front, entr_therm, f0, fm_therm, &
-       falb_dir, falb_dif, &
-       ftsol, beta_aridity, pbl_tke, pctsrf, radsol, rain_fall, snow_fall, ratqs, &
-       rnebcon, rugoro, sig1, w01, solaire_etat0, sollw, sollwdown, &
-       solsw, solswfdiff, t_ancien, q_ancien, u_ancien, v_ancien, &
-       wake_delta_pbl_TKE, delta_tsurf, wake_fip, wake_pe, &
-       wake_deltaq, wake_deltat, wake_s, awake_s, wake_dens, &
-       awake_dens, cv_gen, wake_cstar, &
-       zgam, zmax0, zmea, zpic, zsig, &
-       zstd, zthe, zval, ale_bl, ale_bl_trig, alp_bl, &
-       ql_ancien, qs_ancien, qbs_ancien, cf_ancien, rvc_ancien, &
-       prlw_ancien, prsw_ancien, prbsw_ancien, prw_ancien, &
-       u10m,v10m,ale_wake,ale_bl_stat, ratqs_inter_
-
-  
-   USE dimphy
-   USE surface_data, only : type_ocean,ok_veget
-   USE pbl_surface_mod, only : ftsoil, pbl_surface_init, &
-                                 pbl_surface_final
-   USE fonte_neige_mod, only : fonte_neige_init, fonte_neige_final 
-
-   USE infotrac ! new
-   USE control_mod
-   USE indice_sol_mod
-   USE phyaqua_mod
-!  USE mod_1D_cases_read
-   USE mod_1D_cases_read_std
-   !USE mod_1D_amma_read
-   USE print_control_mod, ONLY: lunout, prt_level
-   USE iniphysiq_mod, ONLY: iniphysiq
-   USE mod_const_mpi, ONLY: comm_lmdz
-   USE physiq_mod, ONLY: physiq
-   USE comvert_mod, ONLY: presnivs, ap, bp, dpres,nivsig, nivsigs, pa, &
-                          preff, aps, bps, pseudoalt, scaleheight
-   USE temps_mod, ONLY: annee_ref, calend, day_end, day_ini, day_ref, &
-                        itau_dyn, itau_phy, start_time, year_len
-   USE phys_cal_mod, ONLY : year_len_phys_cal_mod => year_len
-   USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_OUTPUTPHYSSCM
-
-      implicit none
-      INCLUDE "dimensions.h"
-      INCLUDE "YOMCST.h"
-!!      INCLUDE "control.h"
-      INCLUDE "clesphys.h"
-      INCLUDE "dimsoil.h"
-!      INCLUDE "indicesol.h"
-
-      INCLUDE "compar1d.h"
-      INCLUDE "flux_arp.h"
-      INCLUDE "date_cas.h"
-      INCLUDE "tsoilnudge.h"
-      INCLUDE "fcg_gcssold.h"
-      INCLUDE "compbl.h"
-
-!=====================================================================
-! DECLARATIONS
-!=====================================================================
-
-!---------------------------------------------------------------------
-!  Externals
-!---------------------------------------------------------------------
-      external fq_sat
-      real fq_sat
-
-!---------------------------------------------------------------------
-!  Arguments d' initialisations de la physique (USER DEFINE)
-!---------------------------------------------------------------------
-
-      integer, parameter :: ngrid=1
-      real :: zcufi    = 1.
-      real :: zcvfi    = 1.
-      real :: fnday 
-      real :: day, daytime 
-      real :: day1
-      real :: heure
-      integer :: jour
-      integer :: mois
-      integer :: an
- 
-!---------------------------------------------------------------------
-!  Declarations related to forcing and initial profiles 
-!---------------------------------------------------------------------
-
-        integer :: kmax = llm
-        integer llm700,nq1,nq2
-        INTEGER, PARAMETER :: nlev_max=1000, nqmx=1000
-        real timestep, frac
-        real height(nlev_max),tttprof(nlev_max),qtprof(nlev_max)
-        real  uprof(nlev_max),vprof(nlev_max),e12prof(nlev_max)
-        real  ugprof(nlev_max),vgprof(nlev_max),wfls(nlev_max)
-        real  dqtdxls(nlev_max),dqtdyls(nlev_max)
-        real  dqtdtls(nlev_max),thlpcar(nlev_max)
-        real  qprof(nlev_max,nqmx)
-
-!        integer :: forcing_type
-        logical :: forcing_les     = .false.
-        logical :: forcing_armcu   = .false.
-        logical :: forcing_rico    = .false.
-        logical :: forcing_radconv = .false.
-        logical :: forcing_toga    = .false.
-        logical :: forcing_twpice  = .false.
-        logical :: forcing_amma    = .false.
-        logical :: forcing_dice    = .false.
-        logical :: forcing_gabls4  = .false.
-
-        logical :: forcing_GCM2SCM = .false.
-        logical :: forcing_GCSSold = .false.
-        logical :: forcing_sandu   = .false.
-        logical :: forcing_astex   = .false.
-        logical :: forcing_fire    = .false.
-        logical :: forcing_case    = .false.
-        logical :: forcing_case2   = .false.
-        logical :: forcing_SCM   = .false.
-
-!flag forcings
-        logical :: nudge_wind=.true.
-        logical :: nudge_thermo=.false.
-        logical :: cptadvw=.true.
-
-
-!=====================================================================
-! DECLARATIONS FOR EACH CASE
-!=====================================================================
-!
-      INCLUDE "1D_decl_cases.h"
-!
-!---------------------------------------------------------------------
-!  Declarations related to nudging
-!---------------------------------------------------------------------
-     integer :: nudge_max
-     parameter (nudge_max=9)
-     integer :: inudge_RHT=1
-     integer :: inudge_UV=2
-     logical :: nudge(nudge_max)
-     real :: t_targ(llm)
-     real :: rh_targ(llm)
-     real :: u_targ(llm)
-     real :: v_targ(llm)
-!
-!---------------------------------------------------------------------
-!  Declarations related to vertical discretization:
-!---------------------------------------------------------------------
-      real :: pzero=1.e5
-      real :: play (llm),zlay (llm),sig_s(llm),plev(llm+1)
-      real :: playd(llm),zlayd(llm),ap_amma(llm+1),bp_amma(llm+1)
-
-!---------------------------------------------------------------------
-!  Declarations related to variables
-!---------------------------------------------------------------------
-
-      real :: phi(llm)
-      real :: teta(llm),tetal(llm),temp(llm),u(llm),v(llm),w(llm)
-      REAL rot(1, llm) ! relative vorticity, in s-1
-      real :: rlat_rad(1),rlon_rad(1)
-      real :: omega(llm),omega2(llm),rho(llm+1)
-      real :: ug(llm),vg(llm),fcoriolis
-      real :: sfdt, cfdt
-      real :: du_phys(llm),dv_phys(llm),dt_phys(llm)
-      real :: w_adv(llm),z_adv(llm)
-      real :: d_t_vert_adv(llm),d_u_vert_adv(llm),d_v_vert_adv(llm)
-      real :: dt_cooling(llm),d_t_adv(llm),d_t_nudge(llm)
-      real :: d_u_nudge(llm),d_v_nudge(llm)
-!      real :: d_u_adv(llm),d_v_adv(llm)
-      real :: d_u_age(llm),d_v_age(llm)
-      real :: alpha
-      real :: ttt
-
-      REAL, ALLOCATABLE, DIMENSION(:,:):: q
-      REAL, ALLOCATABLE, DIMENSION(:,:):: dq
-      REAL, ALLOCATABLE, DIMENSION(:,:):: d_q_vert_adv
-      REAL, ALLOCATABLE, DIMENSION(:,:):: d_q_adv
-      REAL, ALLOCATABLE, DIMENSION(:,:):: d_q_nudge
-!      REAL, ALLOCATABLE, DIMENSION(:):: d_th_adv
-
-!---------------------------------------------------------------------
-!  Initialization of surface variables
-!---------------------------------------------------------------------
-      real :: run_off_lic_0(1)
-      real :: fder(1),snsrf(1,nbsrf),qsurfsrf(1,nbsrf)
-      real :: tsoil(1,nsoilmx,nbsrf)
-!     real :: agesno(1,nbsrf)
-
-!---------------------------------------------------------------------
-!  Call to phyredem
-!---------------------------------------------------------------------
-      logical :: ok_writedem =.true.
-      real :: sollw_in = 0.
-      real :: solsw_in = 0.
-      
-!---------------------------------------------------------------------
-!  Call to physiq
-!---------------------------------------------------------------------
-      logical :: firstcall=.true.
-      logical :: lastcall=.false.
-      real :: phis(1)    = 0.0
-      real :: dpsrf(1)
-
-!---------------------------------------------------------------------
-!  Initializations of boundary conditions 
-!---------------------------------------------------------------------
-      real, allocatable :: phy_nat (:)  ! 0=ocean libre,1=land,2=glacier,3=banquise
-      real, allocatable :: phy_alb (:)  ! Albedo land only (old value condsurf_jyg=0.3)
-      real, allocatable :: phy_sst (:)  ! SST (will not be used; cf read_tsurf1d.F)
-      real, allocatable :: phy_bil (:)  ! Ne sert que pour les slab_ocean
-      real, allocatable :: phy_rug (:) ! Longueur rugosite utilisee sur land only
-      real, allocatable :: phy_ice (:) ! Fraction de glace
-      real, allocatable :: phy_fter(:) ! Fraction de terre
-      real, allocatable :: phy_foce(:) ! Fraction de ocean
-      real, allocatable :: phy_fsic(:) ! Fraction de glace
-      real, allocatable :: phy_flic(:) ! Fraction de glace
-
-!---------------------------------------------------------------------
-!  Fichiers et d'autres variables
-!---------------------------------------------------------------------
-      integer :: k,l,i,it=1,mxcalc
-      integer :: nsrf
-      integer jcode
-      INTEGER read_climoz 
-!
-      integer :: it_end ! iteration number of the last call
-!Al1,plev,play,phi,phis,presnivs,
-      integer ecrit_slab_oc !1=ecrit,-1=lit,0=no file
-      data ecrit_slab_oc/-1/
-!
-!     if flag_inhib_forcing = 0, tendencies of forcing are added
-!                           <> 0, tendencies of forcing are not added
-      INTEGER :: flag_inhib_forcing = 0
-
-
-      print*,'VOUS ENTREZ DANS LE 1D FORMAT STANDARD'
-
-!=====================================================================
-! INITIALIZATIONS 
-!=====================================================================
-      du_phys(:)=0.
-      dv_phys(:)=0.
-      dt_phys(:)=0.
-      d_t_vert_adv(:)=0.
-      d_u_vert_adv(:)=0.
-      d_v_vert_adv(:)=0.
-      dt_cooling(:)=0.
-      d_t_adv(:)=0.
-      d_t_nudge(:)=0.
-      d_u_nudge(:)=0.
-      d_v_nudge(:)=0.
-      d_u_adv(:)=0.
-      d_v_adv(:)=0.
-      d_u_age(:)=0.
-      d_v_age(:)=0.
-      
-      
-! Initialization of Common turb_forcing
-       dtime_frcg = 0.
-       Turb_fcg_gcssold=.false.
-       hthturb_gcssold = 0.
-       hqturb_gcssold = 0.
-
-
-
-
-!---------------------------------------------------------------------
-! OPTIONS OF THE 1D SIMULATION (lmdz1d.def => unicol.def)
-!---------------------------------------------------------------------
-        call conf_unicol
-!Al1 moves this gcssold var from common fcg_gcssold to 
-        Turb_fcg_gcssold = xTurb_fcg_gcssold
-! --------------------------------------------------------------------
-        close(1)
-        write(*,*) 'lmdz1d.def lu => unicol.def'
-
-       forcing_SCM = .true.
-       year_ini_cas=1997
-       ! It is possible that those parameters are run twice.
-       ! A REVOIR : LIRE PEUT ETRE AN MOIS JOUR DIRECETEMENT
-
-
-       call getin('anneeref',year_ini_cas)
-       call getin('dayref',day_deb)
-       mth_ini_cas=1 ! pour le moment on compte depuis le debut de l'annee
-       call getin('time_ini',heure_ini_cas)
-
-      print*,'NATURE DE LA SURFACE ',nat_surf
-!
-! Initialization of the logical switch for nudging
-
-     jcode = iflag_nudge
-     do i = 1,nudge_max
-       nudge(i) = mod(jcode,10) .ge. 1
-       jcode = jcode/10
-     enddo
-!-----------------------------------------------------------------------
-!  Definition of the run
-!-----------------------------------------------------------------------
-
-      call conf_gcm( 99, .TRUE. )
-      
-!-----------------------------------------------------------------------
-      allocate( phy_nat (year_len))  ! 0=ocean libre,1=land,2=glacier,3=banquise
-      phy_nat(:)=0.0
-      allocate( phy_alb (year_len))  ! Albedo land only (old value condsurf_jyg=0.3)
-      allocate( phy_sst (year_len))  ! SST (will not be used; cf read_tsurf1d.F)
-      allocate( phy_bil (year_len))  ! Ne sert que pour les slab_ocean
-      phy_bil(:)=1.0
-      allocate( phy_rug (year_len)) ! Longueur rugosite utilisee sur land only
-      allocate( phy_ice (year_len)) ! Fraction de glace
-      phy_ice(:)=0.0
-      allocate( phy_fter(year_len)) ! Fraction de terre
-      phy_fter(:)=0.0
-      allocate( phy_foce(year_len)) ! Fraction de ocean
-      phy_foce(:)=0.0
-      allocate( phy_fsic(year_len)) ! Fraction de glace
-      phy_fsic(:)=0.0
-      allocate( phy_flic(year_len)) ! Fraction de glace
-      phy_flic(:)=0.0
-
-
-!-----------------------------------------------------------------------
-!   Choix du calendrier
-!   -------------------
-
-!      calend = 'earth_365d'
-      if (calend == 'earth_360d') then
-        call ioconf_calendar('360_day')
-        write(*,*)'CALENDRIER CHOISI: Terrestre a 360 jours/an'
-      else if (calend == 'earth_365d') then
-        call ioconf_calendar('noleap')
-        write(*,*)'CALENDRIER CHOISI: Terrestre a 365 jours/an'
-      else if (calend == 'earth_366d') then
-        call ioconf_calendar('all_leap')
-        write(*,*)'CALENDRIER CHOISI: Terrestre bissextile'
-      else if (calend == 'gregorian') then
-        stop 'gregorian calend should not be used by normal user'
-        call ioconf_calendar('gregorian') ! not to be used by normal users
-        write(*,*)'CALENDRIER CHOISI: Gregorien'
-      else
-        write (*,*) 'ERROR : unknown calendar ', calend
-        stop 'calend should be 360d,earth_365d,earth_366d,gregorian'
-      endif
-!-----------------------------------------------------------------------
-!
-!c Date :
-!      La date est supposee donnee sous la forme [annee, numero du jour dans 
-!      l annee] ; l heure est donnee dans time_ini, lu dans lmdz1d.def.
-!      On appelle ymds2ju pour convertir [annee, jour] en [jour Julien].
-!      Le numero du jour est dans "day". L heure est traitee separement.
-!      La date complete est dans "daytime" (l'unite est le jour).
-
-
-      if (nday>0) then
-         fnday=nday
-      else
-         fnday=-nday/float(day_step)
-      endif
-      print *,'fnday=',fnday
-!     start_time doit etre en FRACTION DE JOUR
-      start_time=time_ini/24.
-
-      annee_ref = anneeref
-      mois = 1
-      day_ref = dayref
-      heure = 0.
-      itau_dyn = 0
-      itau_phy = 0
-      call ymds2ju(annee_ref,mois,day_ref,heure,day)
-      day_ini = int(day)
-      day_end = day_ini + int(fnday)
-
-! Convert the initial date to Julian day
-      day_ini_cas=day_deb
-      print*,'time case',year_ini_cas,mth_ini_cas,day_ini_cas
-      call ymds2ju                                                         &
-     & (year_ini_cas,mth_ini_cas,day_ini_cas,heure_ini_cas*3600            &
-     & ,day_ju_ini_cas)
-      print*,'time case 2',day_ini_cas,day_ju_ini_cas
-      daytime = day + heure_ini_cas/24. ! 1st day and initial time of the simulation 
-
-! Print out the actual date of the beginning of the simulation :
-      call ju2ymds(daytime,year_print, month_print,day_print,sec_print)
-      print *,' Time of beginning : ',                                      &
-     &        year_print, month_print, day_print, sec_print
-
-!---------------------------------------------------------------------
-! Initialization of dimensions, geometry and initial state
-!---------------------------------------------------------------------
-!     call init_phys_lmdz(1,1,llm,1,(/1/)) ! job now done via iniphysiq
-!     but we still need to initialize dimphy module (klon,klev,etc.)  here.
-      call init_dimphy1D(1,llm)
-      call suphel
-      call init_infotrac
-
-      if (nqtot>nqmx) STOP 'Augmenter nqmx dans lmdz1d.F'
-      allocate(q(llm,nqtot)) ; q(:,:)=0.
-      allocate(dq(llm,nqtot)) 
-      allocate(d_q_vert_adv(llm,nqtot)) 
-      allocate(d_q_adv(llm,nqtot)) 
-      allocate(d_q_nudge(llm,nqtot)) 
-!      allocate(d_th_adv(llm)) 
-
-      q(:,:) = 0.
-      dq(:,:) = 0.
-      d_q_vert_adv(:,:) = 0.
-      d_q_adv(:,:) = 0.
-      d_q_nudge(:,:) = 0.
-
-!
-!   No ozone climatology need be read in this pre-initialization
-!          (phys_state_var_init is called again in physiq)
-      read_climoz = 0
-      nsw=6
-
-      call phys_state_var_init(read_climoz)
-
-      if (ngrid.ne.klon) then
-         print*,'stop in inifis'
-         print*,'Probleme de dimensions :'
-         print*,'ngrid = ',ngrid
-         print*,'klon  = ',klon
-         stop
-      endif
-!!!=====================================================================
-!!! Feedback forcing values for Gateaux differentiation (al1)
-!!!=====================================================================
-!!
-      qsol = qsolinp
-      qsurf = fq_sat(tsurf,psurf/100.)
-      beta_aridity(:,:) = beta_surf
-      day1= day_ini
-      time=daytime-day
-      ts_toga(1)=tsurf ! needed by read_tsurf1d.F
-      rho(1)=psurf/(rd*tsurf*(1.+(rv/rd-1.)*qsurf)) 
-
-!
-!! mpl et jyg le 22/08/2012 : 
-!!  pour que les cas a flux de surface imposes marchent
-      IF(.NOT.ok_flux_surf.or.max(abs(wtsurf),abs(wqsurf))>0.) THEN
-       fsens=-wtsurf*rcpd*rho(1)
-       flat=-wqsurf*rlvtt*rho(1)
-       print *,'Flux: ok_flux wtsurf wqsurf',ok_flux_surf,wtsurf,wqsurf
-      ENDIF
-      print*,'Flux sol ',fsens,flat
-
-! Vertical discretization and pressure levels at half and mid levels:
-
-      pa   = 5e4
-!!      preff= 1.01325e5
-      preff = psurf
-      IF (ok_old_disvert) THEN
-        call disvert0(pa,preff,ap,bp,dpres,presnivs,nivsigs,nivsig)
-        print *,'On utilise disvert0'
-        aps(1:llm)=0.5*(ap(1:llm)+ap(2:llm+1))
-        bps(1:llm)=0.5*(bp(1:llm)+bp(2:llm+1))
-        scaleheight=8.
-        pseudoalt(1:llm)=-scaleheight*log(presnivs(1:llm)/preff)
-      ELSE
-        call disvert()
-        print *,'On utilise disvert'
-!       Nouvelle version disvert permettant d imposer ap,bp (modif L.Guez) MPL 18092012
-!       Dans ce cas, on lit ap,bp dans le fichier hybrid.txt
-      ENDIF
-
-      sig_s=presnivs/preff
-      plev =ap+bp*psurf
-      play = 0.5*(plev(1:llm)+plev(2:llm+1))
-      zlay=-rd*300.*log(play/psurf)/rg ! moved after reading profiles. 
-
-      IF (forcing_type .eq. 59) THEN
-! pour forcing_sandu, on cherche l'indice le plus proche de 700hpa#3000m
-      write(*,*) '***********************'
-      do l = 1, llm
-       write(*,*) 'l,play(l),presnivs(l): ',l,play(l),presnivs(l)
-       if (trouve_700 .and. play(l).le.70000) then
-         llm700=l
-         print *,'llm700,play=',llm700,play(l)/100.
-         trouve_700= .false.
-       endif
-      enddo
-      write(*,*) '***********************'
-      ENDIF
-
-!
-!=====================================================================
-! EVENTUALLY, READ FORCING DATA :
-!=====================================================================
-
-      INCLUDE "1D_read_forc_cases.h"
-   print*,'A d_t_adv ',d_t_adv(1:20)*86400
-
-      if (forcing_GCM2SCM) then
-        write (*,*) 'forcing_GCM2SCM not yet implemented'
-        stop 'in initialization'
-      endif ! forcing_GCM2SCM
-
-
-!=====================================================================
-! Initialisation de la physique : 
-!=====================================================================
-
-!  Rq: conf_phys.F90 lit tous les flags de physiq.def; conf_phys appele depuis physiq.F
-!
-! day_step, iphysiq lus dans gcm.def ci-dessus
-! timestep: calcule ci-dessous from rday et day_step
-! ngrid=1
-! llm: defini dans .../modipsl/modeles/LMDZ4/libf/grid/dimension
-! rday: defini dans suphel.F (86400.)
-! day_ini: lu dans run.def (dayref)
-! rlat_rad,rlon-rad: transformes en radian de rlat,rlon lus dans lmdz1d.def (en degres)
-! airefi,zcufi,zcvfi initialises au debut de ce programme
-! rday,ra,rg,rd,rcpd declares dans YOMCST.h et calcules dans suphel.F
-
-
-      day_step = float(nsplit_phys)*day_step/float(iphysiq)
-      write (*,*) 'Time step divided by nsplit_phys (=',nsplit_phys,')'
-      timestep =rday/day_step
-      dtime_frcg = timestep
-!
-      zcufi=airefi
-      zcvfi=airefi
-!
-      rlat_rad(1)=xlat*rpi/180.
-      rlon_rad(1)=xlon*rpi/180.
-
-     ! iniphysiq will call iniaqua who needs year_len from phys_cal_mod
-     year_len_phys_cal_mod=year_len
-           
-     ! Ehouarn: iniphysiq requires arrays related to (3D) dynamics grid,
-     ! e.g. for cell boundaries, which are meaningless in 1D; so pad these 
-     ! with '0.' when necessary
-
-      call iniphysiq(iim,jjm,llm, &
-           1,comm_lmdz, &
-           rday,day_ini,timestep,  &
-           (/rlat_rad(1),0./),(/0./), &
-           (/0.,0./),(/rlon_rad(1),0./),  &
-           (/ (/airefi,0./),(/0.,0./) /), &
-           (/zcufi,0.,0.,0./), &
-           (/zcvfi,0./), &
-           ra,rg,rd,rcpd,1)
-      print*,'apres iniphysiq'
-
-! 2 PARAMETRES QUI DEVRAIENT ETRE LUS DANS run.def MAIS NE LE SONT PAS ICI:
-      co2_ppm= 330.0
-      solaire=1370.0
-
-! Ecriture du startphy avant le premier appel a la physique.
-! On le met juste avant pour avoir acces a tous les champs
-
-      if (ok_writedem) then
-
-!--------------------------------------------------------------------------
-! pbl_surface_init (called here) and pbl_surface_final (called by phyredem)
-! need : qsol fder snow qsurf evap rugos agesno ftsoil
-!--------------------------------------------------------------------------
-
-        type_ocean = "force"
-        run_off_lic_0(1) = restart_runoff 
-        call fonte_neige_init(run_off_lic_0)
-
-        fder=0.
-        snsrf(1,:)=snowmass ! masse de neige des sous surface
-        qsurfsrf(1,:)=qsurf ! humidite de l'air des sous surface
-        fevap=0.
-        z0m(1,:)=rugos     ! couverture de neige des sous surface
-        z0h(1,:)=rugosh    ! couverture de neige des sous surface
-        agesno  = xagesno
-        tsoil(:,:,:)=tsurf
-!------ AMMA 2e run avec modele sol et rayonnement actif (MPL 23052012)
-!       tsoil(1,1,1)=299.18
-!       tsoil(1,2,1)=300.08
-!       tsoil(1,3,1)=301.88
-!       tsoil(1,4,1)=305.48
-!       tsoil(1,5,1)=308.00
-!       tsoil(1,6,1)=308.00
-!       tsoil(1,7,1)=308.00
-!       tsoil(1,8,1)=308.00
-!       tsoil(1,9,1)=308.00
-!       tsoil(1,10,1)=308.00
-!       tsoil(1,11,1)=308.00
-!-----------------------------------------------------------------------
-        call pbl_surface_init(fder, snsrf, qsurfsrf, tsoil)
-
-!------------------ prepare limit conditions for limit.nc -----------------
-!--   Ocean force
-
-        print*,'avant phyredem'
-        pctsrf(1,:)=0.
-          if (nat_surf.eq.0.) then
-          pctsrf(1,is_oce)=1.
-          pctsrf(1,is_ter)=0.
-          pctsrf(1,is_lic)=0.
-          pctsrf(1,is_sic)=0.
-        else if (nat_surf .eq. 1) then 
-          pctsrf(1,is_oce)=0.
-          pctsrf(1,is_ter)=1.
-          pctsrf(1,is_lic)=0.
-          pctsrf(1,is_sic)=0.
-        else if (nat_surf .eq. 2) then 
-          pctsrf(1,is_oce)=0.
-          pctsrf(1,is_ter)=0.
-          pctsrf(1,is_lic)=1.
-          pctsrf(1,is_sic)=0.
-        else if (nat_surf .eq. 3) then 
-          pctsrf(1,is_oce)=0.
-          pctsrf(1,is_ter)=0.
-          pctsrf(1,is_lic)=0.
-          pctsrf(1,is_sic)=1.
-
-     end if
-
-
-        print*,'nat_surf,pctsrf(1,is_oce),pctsrf(1,is_ter)',nat_surf         &
-     &        ,pctsrf(1,is_oce),pctsrf(1,is_ter)
-
-        zmasq=pctsrf(1,is_ter)+pctsrf(1,is_lic)
-        zpic = zpicinp
-        ftsol=tsurf
-        falb_dir=albedo
-        falb_dif=albedo
-        rugoro=rugos 
-        t_ancien(1,:)=temp(:)
-        q_ancien(1,:)=q(:,1)
-        ql_ancien = 0.
-        qs_ancien = 0.
-        prlw_ancien = 0.
-        prsw_ancien = 0.
-        prw_ancien = 0.
-        IF ( ok_bs ) THEN
-           qbs_ancien = 0.
-           prbsw_ancien = 0.
-        ENDIF
-        IF ( ok_ice_supersat ) THEN
-          cf_ancien = 0.
-          rvc_ancien = 0.
-        ENDIF
-!jyg<
-! Etienne: comment those lines since now the TKE is inialized in 1D_read_forc_cases
-!!      pbl_tke(:,:,:)=1.e-8
-!        pbl_tke(:,:,:)=0.
-!        pbl_tke(:,2,:)=1.e-2
-!>jyg
-        rain_fall=0.
-        snow_fall=0.
-        solsw=0.
-        solswfdiff=0.
-        sollw=0.
-        sollwdown=rsigma*tsurf**4
-        radsol=0.
-        rnebcon=0.
-        ratqs=0.
-        clwcon=0.
-        zmax0 = 0.
-        zmea=zsurf
-        zstd=0.
-        zsig=0.
-        zgam=0.
-        zval=0. 
-        zthe=0. 
-        sig1=0.
-        w01=0.
-!
-        wake_deltaq = 0.
-        wake_deltat = 0.
-        wake_delta_pbl_TKE(:,:,:) = 0.
-        delta_tsurf = 0.
-        wake_fip = 0.
-        wake_pe = 0.
-        wake_s = 0.
-        awake_s = 0.
-        wake_dens = 0.
-        awake_dens = 0.
-        cv_gen = 0.
-        wake_cstar = 0.
-        ale_bl = 0.
-        ale_bl_trig = 0.
-        alp_bl = 0.
-        IF (ALLOCATED(du_gwd_rando)) du_gwd_rando = 0.
-        IF (ALLOCATED(du_gwd_front)) du_gwd_front = 0.
-        entr_therm = 0.
-        detr_therm = 0.
-        f0 = 0.
-        fm_therm = 0.
-        u_ancien(1,:)=u(:)
-        v_ancien(1,:)=v(:)
- 
-        u10m=0.
-        v10m=0.
-        ale_wake=0.
-        ale_bl_stat=0.
-        ratqs_inter_(:,:)= 0.002
-
-!------------------------------------------------------------------------
-! Make file containing restart for the physics (startphy.nc)
-!
-! NB: List of the variables to be written by phyredem (via put_field):
-! rlon,rlat,zmasq,pctsrf(:,is_ter),pctsrf(:,is_lic),pctsrf(:,is_oce)
-! pctsrf(:,is_sic),ftsol(:,nsrf),tsoil(:,isoil,nsrf),qsurf(:,nsrf)
-! qsol,falb_dir(:,nsrf),falb_dif(:,nsrf),evap(:,nsrf),snow(:,nsrf)
-! radsol,solsw,solswfdiff,sollw, sollwdown,fder,rain_fall,snow_fall,frugs(:,nsrf)
-! agesno(:,nsrf),zmea,zstd,zsig,zgam,zthe,zpic,zval,rugoro
-! t_ancien,q_ancien,,frugs(:,is_oce),clwcon(:,1),rnebcon(:,1),ratqs(:,1)
-! run_off_lic_0,pbl_tke(:,1:klev,nsrf), zmax0,f0,sig1,w01
-! wake_deltat,wake_deltaq,wake_s,awake_s,wake_dens,awake_dens,cv_gen,wake_cstar,
-! wake_fip,wake_delta_pbl_tke(:,1:klev,nsrf)
-!
-! NB2: The content of the startphy.nc file depends on some flags defined in
-! the ".def" files. However, since conf_phys is not called in lmdz1d.F90, these flags have 
-! to be set at some arbitratry convenient values.
-!------------------------------------------------------------------------
-!Al1 =============== restart option ======================================
-        iflag_physiq=0
-        call getin('iflag_physiq',iflag_physiq)
-
-        if (.not.restart) then
-          iflag_pbl = 5
-          call phyredem ("startphy.nc")
-        else
-! (desallocations)
-        print*,'callin surf final'
-          call pbl_surface_final( fder, snsrf, qsurfsrf, tsoil)
-        print*,'after surf final'
-          CALL fonte_neige_final(run_off_lic_0)
-        endif
-
-        ok_writedem=.false.
-        print*,'apres phyredem'
-
-      endif ! ok_writedem
-      
-!------------------------------------------------------------------------
-! Make file containing boundary conditions (limit.nc) **Al1->restartdyn***
-! --------------------------------------------------
-! NB: List of the variables to be written in limit.nc 
-!     (by writelim.F, subroutine of 1DUTILS.h):
-!        phy_nat,phy_alb,phy_sst,phy_bil,phy_rug,phy_ice,
-!        phy_fter,phy_foce,phy_flic,phy_fsic)
-!------------------------------------------------------------------------
-      do i=1,year_len
-        phy_nat(i)  = nat_surf
-        phy_alb(i)  = albedo
-        phy_sst(i)  = tsurf ! read_tsurf1d will be used instead
-        phy_rug(i)  = rugos
-        phy_fter(i) = pctsrf(1,is_ter)
-        phy_foce(i) = pctsrf(1,is_oce)
-        phy_fsic(i) = pctsrf(1,is_sic)
-        phy_flic(i) = pctsrf(1,is_lic)
-      enddo
-
-! fabrication de limit.nc
-      call writelim (1,phy_nat,phy_alb,phy_sst,phy_bil,phy_rug,             &
-     &               phy_ice,phy_fter,phy_foce,phy_flic,phy_fsic)
-
-
-      call phys_state_var_end
-!Al1
-      if (restart) then
-        print*,'call to restart dyn 1d'
-        Call dyn1deta0("start1dyn.nc",plev,play,phi,phis,presnivs,          &
-     &              u,v,temp,q,omega2)
-
-       print*,'fnday,annee_ref,day_ref,day_ini',                            &
-     &     fnday,annee_ref,day_ref,day_ini
-!**      call ymds2ju(annee_ref,mois,day_ini,heure,day)
-       day = day_ini
-       day_end = day_ini + nday
-       daytime = day + time_ini/24. ! 1st day and initial time of the simulation 
-
-! Print out the actual date of the beginning of the simulation :
-       call ju2ymds(daytime, an, mois, jour, heure)
-       print *,' Time of beginning : y m d h',an, mois,jour,heure/3600.
-
-       day = int(daytime)
-       time=daytime-day
-  
-       print*,'****** intialised fields from restart1dyn *******'
-       print*,'plev,play,phi,phis,presnivs,u,v,temp,q,omega2'
-       print*,'temp(1),q(1,1),u(1),v(1),plev(1),phis :'
-       print*,temp(1),q(1,1),u(1),v(1),plev(1),phis(1)
-! raz for safety
-       do l=1,llm
-         d_q_vert_adv(l,1) = 0.
-       enddo
-      endif
-!======================  end restart =================================
-      IF (ecrit_slab_oc.eq.1) then
-         open(97,file='div_slab.dat',STATUS='UNKNOWN')
-       elseif (ecrit_slab_oc.eq.0) then
-         open(97,file='div_slab.dat',STATUS='OLD')
-       endif
-!
-!=====================================================================
-IF (CPPKEY_OUTPUTPHYSSCM) THEN
-       CALL iophys_ini(timestep)
-END IF
-
-!=====================================================================
-! START OF THE TEMPORAL LOOP :
-!=====================================================================
-           
-      it_end = nint(fnday*day_step)
-      do while(it.le.it_end)
-
-       if (prt_level.ge.1) then
-         print*,'XXXXXXXXXXXXXXXXXXX ITAP,day,time=',                       &
-     &             it,day,time,it_end,day_step
-         print*,'PAS DE TEMPS ',timestep
-       endif
-       if (it.eq.it_end) lastcall=.True.
-
-!---------------------------------------------------------------------
-! Interpolation of forcings in time and onto model levels
-!---------------------------------------------------------------------
-
-      INCLUDE "1D_interp_cases.h"
-
-!---------------------------------------------------------------------
-!  Geopotential :
-!---------------------------------------------------------------------
-        phis(1)=zsurf*RG
-!        phi(1)=phis(1)+RD*temp(1)*(plev(1)-play(1))/(.5*(plev(1)+play(1)))
-
-        ! Calculate geopotential from the ground surface since phi and phis are added in physiq_mod
-        phi(1)=RD*temp(1)*(plev(1)-play(1))/(.5*(plev(1)+play(1)))
-
-        do l = 1, llm-1
-          phi(l+1)=phi(l)+RD*(temp(l)+temp(l+1))*                           &
-     &    (play(l)-play(l+1))/(play(l)+play(l+1))
-        enddo
-
-!---------------------------------------------------------------------
-!  Vertical advection
-!---------------------------------------------------------------------
-
-   IF ( forc_w+forc_omega > 0 ) THEN
-
-      IF ( forc_w == 1 ) THEN
-         w_adv=w_mod_cas
-         z_adv=phi/RG
-      ELSE
-         w_adv=omega
-         z_adv=play
-      ENDIF
-
-      teta=temp*(pzero/play)**rkappa
-      do l=2,llm-1
-        ! vertical tendencies computed as d X / d t = -W  d X / d z
-        d_u_vert_adv(l)=-w_adv(l)*(u(l+1)-u(l-1))/(z_adv(l+1)-z_adv(l-1))
-        d_v_vert_adv(l)=-w_adv(l)*(v(l+1)-v(l-1))/(z_adv(l+1)-z_adv(l-1))
-        ! d theta / dt = -W d theta / d z, transformed into d temp / d t dividing by (pzero/play(l))**rkappa
-        d_t_vert_adv(l)=-w_adv(l)*(teta(l+1)-teta(l-1))/(z_adv(l+1)-z_adv(l-1)) / (pzero/play(l))**rkappa
-        d_q_vert_adv(l,1)=-w_adv(l)*(q(l+1,1)-q(l-1,1))/(z_adv(l+1)-z_adv(l-1))
-      enddo
-      d_u_adv(:)=d_u_adv(:)+d_u_vert_adv(:)
-      d_v_adv(:)=d_v_adv(:)+d_v_vert_adv(:)
-      d_t_adv(:)=d_t_adv(:)+d_t_vert_adv(:)
-      d_q_adv(:,1)=d_q_adv(:,1)+d_q_vert_adv(:,1)
-   
-   ENDIF
-
-!---------------------------------------------------------------------
-! Listing output for debug prt_level>=1
-!---------------------------------------------------------------------
-       if (prt_level>=1) then
-         print *,' avant physiq : -------- day time ',day,time
-         write(*,*) 'firstcall,lastcall,phis',                               &
-     &               firstcall,lastcall,phis
-       end if
-       if (prt_level>=5) then
-         write(*,'(a10,2a4,4a13)') 'BEFOR1 IT=','it','l',                   &
-     &        'presniv','plev','play','phi'
-         write(*,'(a10,2i4,4f13.2)') ('BEFOR1 IT= ',it,l,                   &
-     &         presnivs(l),plev(l),play(l),phi(l),l=1,llm)
-         write(*,'(a11,2a4,a11,6a8)') 'BEFOR2','it','l',                    &
-     &         'presniv','u','v','temp','q1','q2','omega2'
-         write(*,'(a11,2i4,f11.2,5f8.2,e10.2)') ('BEFOR2 IT= ',it,l,         &
-     &   presnivs(l),u(l),v(l),temp(l),q(l,1),q(l,2),omega2(l),l=1,llm)
-       endif
-
-!---------------------------------------------------------------------
-!   Call physiq :
-!---------------------------------------------------------------------
-       call physiq(ngrid,llm, &
-                    firstcall,lastcall,timestep, &
-                    plev,play,phi,phis,presnivs, &
-                    u,v, rot, temp,q,omega2, &
-                    du_phys,dv_phys,dt_phys,dq,dpsrf)
-                firstcall=.false.
-
-!---------------------------------------------------------------------
-! Listing output for debug
-!---------------------------------------------------------------------
-        if (prt_level>=5) then
-          write(*,'(a11,2a4,4a13)') 'AFTER1 IT=','it','l',                  &
-     &        'presniv','plev','play','phi'
-          write(*,'(a11,2i4,4f13.2)') ('AFTER1 it= ',it,l,                  &
-     &    presnivs(l),plev(l),play(l),phi(l),l=1,llm)
-          write(*,'(a11,2a4,a11,6a8)') 'AFTER2','it','l',                   &
-     &         'presniv','u','v','temp','q1','q2','omega2'
-          write(*,'(a11,2i4,f11.2,5f8.2,e10.2)') ('AFTER2 it= ',it,l,       &
-     &    presnivs(l),u(l),v(l),temp(l),q(l,1),q(l,2),omega2(l),l=1,llm)
-          write(*,'(a11,2a4,a11,5a8)') 'AFTER3','it','l',                   &
-     &         'presniv','du_phys','dv_phys','dt_phys','dq1','dq2'    
-           write(*,'(a11,2i4,f11.2,5f8.2)') ('AFTER3 it= ',it,l,            &
-     &      presnivs(l),86400*du_phys(l),86400*dv_phys(l),                   &
-     &       86400*dt_phys(l),86400*dq(l,1),dq(l,2),l=1,llm)
-          write(*,*) 'dpsrf',dpsrf
-        endif
-!---------------------------------------------------------------------
-!   Add physical tendencies :
-!---------------------------------------------------------------------
-
-       fcoriolis=2.*sin(rpi*xlat/180.)*romega
-
-      IF (prt_level >= 5) print*, 'fcoriolis, xlat,mxcalc ', &
-                                   fcoriolis, xlat,mxcalc
-
-!---------------------------------------------------------------------
-! Geostrophic forcing 
-!---------------------------------------------------------------------
-
-      IF ( forc_geo == 0 ) THEN
-              d_u_age(1:mxcalc)=0.
-              d_v_age(1:mxcalc)=0.
-      ELSE
-       sfdt = sin(0.5*fcoriolis*timestep)
-       cfdt = cos(0.5*fcoriolis*timestep)
-
-        d_u_age(1:mxcalc)= -2.*sfdt/timestep*                                &
-     &          (sfdt*(u(1:mxcalc)-ug(1:mxcalc)) -                          &
-     &           cfdt*(v(1:mxcalc)-vg(1:mxcalc))  )
-!!     : fcoriolis*(v(1:mxcalc)-vg(1:mxcalc))
-!
-       d_v_age(1:mxcalc)= -2.*sfdt/timestep*                                 &
-     &          (cfdt*(u(1:mxcalc)-ug(1:mxcalc)) +                           &
-     &           sfdt*(v(1:mxcalc)-vg(1:mxcalc))  )
-!!     : -fcoriolis*(u(1:mxcalc)-ug(1:mxcalc))
-      ENDIF
-!
-!---------------------------------------------------------------------
-!  Nudging
-!  EV: rewrite the section to account for a time- and height-varying
-!  nudging
-!---------------------------------------------------------------------
-      d_t_nudge(:) = 0.
-      d_u_nudge(:) = 0.
-      d_v_nudge(:) = 0.
-      d_q_nudge(:,:) = 0.
-
-      DO l=1,llm
-
-         IF (nudging_u .LT. 0) THEN
-              
-             d_u_nudge(l)=(u_nudg_mod_cas(l)-u(l))*invtau_u_nudg_mod_cas(l)
-       
-         ELSE
-
-             IF ( play(l) < p_nudging_u .AND. nint(nudging_u) /= 0 ) &
-             & d_u_nudge(l)=(u_nudg_mod_cas(l)-u(l))/nudging_u
-
-         ENDIF 
-
-
-         IF (nudging_v .LT. 0) THEN
-              
-             d_v_nudge(l)=(v_nudg_mod_cas(l)-v(l))*invtau_v_nudg_mod_cas(l)
-       
-         ELSE
-
-
-             IF ( play(l) < p_nudging_v .AND. nint(nudging_v) /= 0 ) &
-             & d_v_nudge(l)=(v_nudg_mod_cas(l)-v(l))/nudging_v
-
-         ENDIF
-
-
-         IF (nudging_t .LT. 0) THEN
-              
-             d_t_nudge(l)=(temp_nudg_mod_cas(l)-temp(l))*invtau_temp_nudg_mod_cas(l)
-       
-         ELSE
-
-
-             IF ( play(l) < p_nudging_t .AND. nint(nudging_t) /= 0 ) &
-             & d_t_nudge(l)=(temp_nudg_mod_cas(l)-temp(l))/nudging_t
-
-          ENDIF
-
-
-         IF (nudging_qv .LT. 0) THEN
-              
-             d_q_nudge(l,1)=(qv_nudg_mod_cas(l)-q(l,1))*invtau_qv_nudg_mod_cas(l)
-       
-         ELSE
-
-             IF ( play(l) < p_nudging_qv .AND. nint(nudging_qv) /= 0 ) &
-             & d_q_nudge(l,1)=(qv_nudg_mod_cas(l)-q(l,1))/nudging_qv
-
-         ENDIF
-
-      ENDDO
-
-!---------------------------------------------------------------------
-!  Optional outputs
-!---------------------------------------------------------------------
-
-IF (CPPKEY_OUTPUTPHYSSCM) THEN
-      CALL iophys_ecrit('w_adv',klev,'w_adv','K/day',w_adv)
-      CALL iophys_ecrit('z_adv',klev,'z_adv','K/day',z_adv)
-      CALL iophys_ecrit('dtadv',klev,'dtadv','K/day',86400*d_t_adv)
-      CALL iophys_ecrit('dtdyn',klev,'dtdyn','K/day',86400*d_t_vert_adv)
-      CALL iophys_ecrit('qv',klev,'qv','g/kg',1000*q(:,1))
-      CALL iophys_ecrit('qvnud',klev,'qvnud','g/kg',1000*u_nudg_mod_cas)
-      CALL iophys_ecrit('u',klev,'u','m/s',u)
-      CALL iophys_ecrit('unud',klev,'unud','m/s',u_nudg_mod_cas)
-      CALL iophys_ecrit('v',klev,'v','m/s',v)
-      CALL iophys_ecrit('vnud',klev,'vnud','m/s',v_nudg_mod_cas)
-      CALL iophys_ecrit('temp',klev,'temp','K',temp)
-      CALL iophys_ecrit('tempnud',klev,'temp_nudg_mod_cas','K',temp_nudg_mod_cas)
-      CALL iophys_ecrit('dtnud',klev,'dtnud','K/day',86400*d_t_nudge)
-      CALL iophys_ecrit('dqnud',klev,'dqnud','K/day',1000*86400*d_q_nudge(:,1))
-END IF
-
-    IF (flag_inhib_forcing == 0) then ! if tendency of forcings should be added
-
-        u(1:mxcalc)=u(1:mxcalc) + timestep*(                                &
-     &              du_phys(1:mxcalc)                                       &
-     &             +d_u_age(1:mxcalc)+d_u_adv(1:mxcalc)                       &
-     &             +d_u_nudge(1:mxcalc) )            
-        v(1:mxcalc)=v(1:mxcalc) + timestep*(                                 &
-     &              dv_phys(1:mxcalc)                                       &
-     &             +d_v_age(1:mxcalc)+d_v_adv(1:mxcalc)                       &
-     &             +d_v_nudge(1:mxcalc) )
-        q(1:mxcalc,:)=q(1:mxcalc,:)+timestep*(                              &
-     &                dq(1:mxcalc,:)                                        &
-     &               +d_q_adv(1:mxcalc,:)                                   &
-     &               +d_q_nudge(1:mxcalc,:) )
-
-        if (prt_level.ge.3) then
-          print *,                                                          &
-     &    'physiq-> temp(1),dt_phys(1),d_t_adv(1),dt_cooling(1) ',         &
-     &              temp(1),dt_phys(1),d_t_adv(1),dt_cooling(1)
-           print* ,'dv_phys=',dv_phys
-           print* ,'d_v_age=',d_v_age
-           print* ,'d_v_adv=',d_v_adv
-           print* ,'d_v_nudge=',d_v_nudge
-           print*, v
-           print*, vg
-        endif
-
-        temp(1:mxcalc)=temp(1:mxcalc)+timestep*(                            &
-     &              dt_phys(1:mxcalc)                                       &
-     &             +d_t_adv(1:mxcalc)                                       &
-     &             +d_t_nudge(1:mxcalc)                                     &
-     &             +dt_cooling(1:mxcalc))  ! Taux de chauffage ou refroid.
-
-
-!=======================================================================
-!! CONSERVE EN ATTENDANT QUE LE CAS EN QUESTION FONCTIONNE EN STD !!
-!=======================================================================
-
-        teta=temp*(pzero/play)**rkappa
-
-!---------------------------------------------------------------------
-!   Nudge soil temperature if requested
-!---------------------------------------------------------------------
-
-      IF (nudge_tsoil .AND. .NOT. lastcall) THEN
-       ftsoil(1,isoil_nudge,:) = ftsoil(1,isoil_nudge,:)                     &
-     &  -timestep/tau_soil_nudge*(ftsoil(1,isoil_nudge,:)-Tsoil_nudge)
-      ENDIF
-
-!---------------------------------------------------------------------
-!   Add large-scale tendencies (advection, etc) :
-!---------------------------------------------------------------------
-
-!cc nrlmd
-!cc        tmpvar=teta
-!cc        call advect_vert(llm,omega,timestep,tmpvar,plev)
-!cc
-!cc        teta(1:mxcalc)=tmpvar(1:mxcalc)
-!cc        tmpvar(:)=q(:,1)
-!cc        call advect_vert(llm,omega,timestep,tmpvar,plev)
-!cc        q(1:mxcalc,1)=tmpvar(1:mxcalc)
-!cc        tmpvar(:)=q(:,2)
-!cc        call advect_vert(llm,omega,timestep,tmpvar,plev)
-!cc        q(1:mxcalc,2)=tmpvar(1:mxcalc)
-
-   END IF ! end if tendency of tendency should be added
-
-!---------------------------------------------------------------------
-!   Air temperature :
-!---------------------------------------------------------------------        
-        if (lastcall) then
-          print*,'Pas de temps final ',it
-          call ju2ymds(daytime, an, mois, jour, heure)
-          print*,'a la date : a m j h',an, mois, jour ,heure/3600.
-        endif
-
-!  incremente day time
-        daytime = daytime+1./day_step
-        day = int(daytime+0.1/day_step)
-!        time = max(daytime-day,0.0)
-!Al1&jyg: correction de bug
-!cc        time = real(mod(it,day_step))/day_step
-        time = time_ini/24.+real(mod(it,day_step))/day_step
-        it=it+1
-
-      enddo
-
-      if (ecrit_slab_oc.ne.-1) close(97)
-
-!Al1 Call to 1D equivalent of dynredem (an,mois,jour,heure ?)
-! ---------------------------------------------------------------------------
-       call dyn1dredem("restart1dyn.nc",                                    &
-     &              plev,play,phi,phis,presnivs,                            &
-     &              u,v,temp,q,omega2)
-
-        CALL abort_gcm ('lmdz1d   ','The End  ',0)
-
-END SUBROUTINE scm
Index: /LMDZ6/trunk/libf/phylmd/dyn1d/scm.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/dyn1d/scm.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/dyn1d/scm.f90	(revision 5268)
@@ -0,0 +1,1124 @@
+SUBROUTINE scm
+
+   USE ioipsl, only: ju2ymds, ymds2ju, ioconf_calendar,getin
+   USE phys_state_var_mod, ONLY : phys_state_var_init, phys_state_var_end, &
+       clwcon, detr_therm, &
+       qsol, fevap, z0m, z0h, agesno, &
+       du_gwd_rando, du_gwd_front, entr_therm, f0, fm_therm, &
+       falb_dir, falb_dif, &
+       ftsol, beta_aridity, pbl_tke, pctsrf, radsol, rain_fall, snow_fall, ratqs, &
+       rnebcon, rugoro, sig1, w01, solaire_etat0, sollw, sollwdown, &
+       solsw, solswfdiff, t_ancien, q_ancien, u_ancien, v_ancien, &
+       wake_delta_pbl_TKE, delta_tsurf, wake_fip, wake_pe, &
+       wake_deltaq, wake_deltat, wake_s, awake_s, wake_dens, &
+       awake_dens, cv_gen, wake_cstar, &
+       zgam, zmax0, zmea, zpic, zsig, &
+       zstd, zthe, zval, ale_bl, ale_bl_trig, alp_bl, &
+       ql_ancien, qs_ancien, qbs_ancien, cf_ancien, rvc_ancien, &
+       prlw_ancien, prsw_ancien, prbsw_ancien, prw_ancien, &
+       u10m,v10m,ale_wake,ale_bl_stat, ratqs_inter_
+
+  
+   USE dimphy
+   USE surface_data, only : type_ocean,ok_veget
+   USE pbl_surface_mod, only : ftsoil, pbl_surface_init, &
+                                 pbl_surface_final
+   USE fonte_neige_mod, only : fonte_neige_init, fonte_neige_final 
+
+   USE infotrac ! new
+   USE control_mod
+   USE indice_sol_mod
+   USE phyaqua_mod
+!  USE mod_1D_cases_read
+   USE mod_1D_cases_read_std
+   !USE mod_1D_amma_read
+   USE print_control_mod, ONLY: lunout, prt_level
+   USE iniphysiq_mod, ONLY: iniphysiq
+   USE mod_const_mpi, ONLY: comm_lmdz
+   USE physiq_mod, ONLY: physiq
+   USE comvert_mod, ONLY: presnivs, ap, bp, dpres,nivsig, nivsigs, pa, &
+                          preff, aps, bps, pseudoalt, scaleheight
+   USE temps_mod, ONLY: annee_ref, calend, day_end, day_ini, day_ref, &
+                        itau_dyn, itau_phy, start_time, year_len
+   USE phys_cal_mod, ONLY : year_len_phys_cal_mod => year_len
+   USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_OUTPUTPHYSSCM
+
+      implicit none
+      INCLUDE "dimensions.h"
+      INCLUDE "YOMCST.h"
+!!      INCLUDE "control.h"
+      INCLUDE "clesphys.h"
+      INCLUDE "dimsoil.h"
+!      INCLUDE "indicesol.h"
+
+      INCLUDE "compar1d.h"
+      INCLUDE "flux_arp.h"
+      INCLUDE "date_cas.h"
+      INCLUDE "tsoilnudge.h"
+      INCLUDE "fcg_gcssold.h"
+      INCLUDE "compbl.h"
+
+!=====================================================================
+! DECLARATIONS
+!=====================================================================
+
+!---------------------------------------------------------------------
+!  Externals
+!---------------------------------------------------------------------
+      external fq_sat
+      real fq_sat
+
+!---------------------------------------------------------------------
+!  Arguments d' initialisations de la physique (USER DEFINE)
+!---------------------------------------------------------------------
+
+      integer, parameter :: ngrid=1
+      real :: zcufi    = 1.
+      real :: zcvfi    = 1.
+      real :: fnday 
+      real :: day, daytime 
+      real :: day1
+      real :: heure
+      integer :: jour
+      integer :: mois
+      integer :: an
+ 
+!---------------------------------------------------------------------
+!  Declarations related to forcing and initial profiles 
+!---------------------------------------------------------------------
+
+        integer :: kmax = llm
+        integer llm700,nq1,nq2
+        INTEGER, PARAMETER :: nlev_max=1000, nqmx=1000
+        real timestep, frac
+        real height(nlev_max),tttprof(nlev_max),qtprof(nlev_max)
+        real  uprof(nlev_max),vprof(nlev_max),e12prof(nlev_max)
+        real  ugprof(nlev_max),vgprof(nlev_max),wfls(nlev_max)
+        real  dqtdxls(nlev_max),dqtdyls(nlev_max)
+        real  dqtdtls(nlev_max),thlpcar(nlev_max)
+        real  qprof(nlev_max,nqmx)
+
+!        integer :: forcing_type
+        logical :: forcing_les     = .false.
+        logical :: forcing_armcu   = .false.
+        logical :: forcing_rico    = .false.
+        logical :: forcing_radconv = .false.
+        logical :: forcing_toga    = .false.
+        logical :: forcing_twpice  = .false.
+        logical :: forcing_amma    = .false.
+        logical :: forcing_dice    = .false.
+        logical :: forcing_gabls4  = .false.
+
+        logical :: forcing_GCM2SCM = .false.
+        logical :: forcing_GCSSold = .false.
+        logical :: forcing_sandu   = .false.
+        logical :: forcing_astex   = .false.
+        logical :: forcing_fire    = .false.
+        logical :: forcing_case    = .false.
+        logical :: forcing_case2   = .false.
+        logical :: forcing_SCM   = .false.
+
+!flag forcings
+        logical :: nudge_wind=.true.
+        logical :: nudge_thermo=.false.
+        logical :: cptadvw=.true.
+
+
+!=====================================================================
+! DECLARATIONS FOR EACH CASE
+!=====================================================================
+!
+      INCLUDE "1D_decl_cases.h"
+!
+!---------------------------------------------------------------------
+!  Declarations related to nudging
+!---------------------------------------------------------------------
+     integer :: nudge_max
+     parameter (nudge_max=9)
+     integer :: inudge_RHT=1
+     integer :: inudge_UV=2
+     logical :: nudge(nudge_max)
+     real :: t_targ(llm)
+     real :: rh_targ(llm)
+     real :: u_targ(llm)
+     real :: v_targ(llm)
+!
+!---------------------------------------------------------------------
+!  Declarations related to vertical discretization:
+!---------------------------------------------------------------------
+      real :: pzero=1.e5
+      real :: play (llm),zlay (llm),sig_s(llm),plev(llm+1)
+      real :: playd(llm),zlayd(llm),ap_amma(llm+1),bp_amma(llm+1)
+
+!---------------------------------------------------------------------
+!  Declarations related to variables
+!---------------------------------------------------------------------
+
+      real :: phi(llm)
+      real :: teta(llm),tetal(llm),temp(llm),u(llm),v(llm),w(llm)
+      REAL rot(1, llm) ! relative vorticity, in s-1
+      real :: rlat_rad(1),rlon_rad(1)
+      real :: omega(llm),omega2(llm),rho(llm+1)
+      real :: ug(llm),vg(llm),fcoriolis
+      real :: sfdt, cfdt
+      real :: du_phys(llm),dv_phys(llm),dt_phys(llm)
+      real :: w_adv(llm),z_adv(llm)
+      real :: d_t_vert_adv(llm),d_u_vert_adv(llm),d_v_vert_adv(llm)
+      real :: dt_cooling(llm),d_t_adv(llm),d_t_nudge(llm)
+      real :: d_u_nudge(llm),d_v_nudge(llm)
+!      real :: d_u_adv(llm),d_v_adv(llm)
+      real :: d_u_age(llm),d_v_age(llm)
+      real :: alpha
+      real :: ttt
+
+      REAL, ALLOCATABLE, DIMENSION(:,:):: q
+      REAL, ALLOCATABLE, DIMENSION(:,:):: dq
+      REAL, ALLOCATABLE, DIMENSION(:,:):: d_q_vert_adv
+      REAL, ALLOCATABLE, DIMENSION(:,:):: d_q_adv
+      REAL, ALLOCATABLE, DIMENSION(:,:):: d_q_nudge
+!      REAL, ALLOCATABLE, DIMENSION(:):: d_th_adv
+
+!---------------------------------------------------------------------
+!  Initialization of surface variables
+!---------------------------------------------------------------------
+      real :: run_off_lic_0(1)
+      real :: fder(1),snsrf(1,nbsrf),qsurfsrf(1,nbsrf)
+      real :: tsoil(1,nsoilmx,nbsrf)
+!     real :: agesno(1,nbsrf)
+
+!---------------------------------------------------------------------
+!  Call to phyredem
+!---------------------------------------------------------------------
+      logical :: ok_writedem =.true.
+      real :: sollw_in = 0.
+      real :: solsw_in = 0.
+      
+!---------------------------------------------------------------------
+!  Call to physiq
+!---------------------------------------------------------------------
+      logical :: firstcall=.true.
+      logical :: lastcall=.false.
+      real :: phis(1)    = 0.0
+      real :: dpsrf(1)
+
+!---------------------------------------------------------------------
+!  Initializations of boundary conditions 
+!---------------------------------------------------------------------
+      real, allocatable :: phy_nat (:)  ! 0=ocean libre,1=land,2=glacier,3=banquise
+      real, allocatable :: phy_alb (:)  ! Albedo land only (old value condsurf_jyg=0.3)
+      real, allocatable :: phy_sst (:)  ! SST (will not be used; cf read_tsurf1d.F)
+      real, allocatable :: phy_bil (:)  ! Ne sert que pour les slab_ocean
+      real, allocatable :: phy_rug (:) ! Longueur rugosite utilisee sur land only
+      real, allocatable :: phy_ice (:) ! Fraction de glace
+      real, allocatable :: phy_fter(:) ! Fraction de terre
+      real, allocatable :: phy_foce(:) ! Fraction de ocean
+      real, allocatable :: phy_fsic(:) ! Fraction de glace
+      real, allocatable :: phy_flic(:) ! Fraction de glace
+
+!---------------------------------------------------------------------
+!  Fichiers et d'autres variables
+!---------------------------------------------------------------------
+      integer :: k,l,i,it=1,mxcalc
+      integer :: nsrf
+      integer jcode
+      INTEGER read_climoz 
+!
+      integer :: it_end ! iteration number of the last call
+!Al1,plev,play,phi,phis,presnivs,
+      integer ecrit_slab_oc !1=ecrit,-1=lit,0=no file
+      data ecrit_slab_oc/-1/
+!
+!     if flag_inhib_forcing = 0, tendencies of forcing are added
+!                           <> 0, tendencies of forcing are not added
+      INTEGER :: flag_inhib_forcing = 0
+
+
+      print*,'VOUS ENTREZ DANS LE 1D FORMAT STANDARD'
+
+!=====================================================================
+! INITIALIZATIONS 
+!=====================================================================
+      du_phys(:)=0.
+      dv_phys(:)=0.
+      dt_phys(:)=0.
+      d_t_vert_adv(:)=0.
+      d_u_vert_adv(:)=0.
+      d_v_vert_adv(:)=0.
+      dt_cooling(:)=0.
+      d_t_adv(:)=0.
+      d_t_nudge(:)=0.
+      d_u_nudge(:)=0.
+      d_v_nudge(:)=0.
+      d_u_adv(:)=0.
+      d_v_adv(:)=0.
+      d_u_age(:)=0.
+      d_v_age(:)=0.
+      
+      
+! Initialization of Common turb_forcing
+       dtime_frcg = 0.
+       Turb_fcg_gcssold=.false.
+       hthturb_gcssold = 0.
+       hqturb_gcssold = 0.
+
+
+
+
+!---------------------------------------------------------------------
+! OPTIONS OF THE 1D SIMULATION (lmdz1d.def => unicol.def)
+!---------------------------------------------------------------------
+        call conf_unicol
+!Al1 moves this gcssold var from common fcg_gcssold to 
+        Turb_fcg_gcssold = xTurb_fcg_gcssold
+! --------------------------------------------------------------------
+        close(1)
+        write(*,*) 'lmdz1d.def lu => unicol.def'
+
+       forcing_SCM = .true.
+       year_ini_cas=1997
+       ! It is possible that those parameters are run twice.
+       ! A REVOIR : LIRE PEUT ETRE AN MOIS JOUR DIRECETEMENT
+
+
+       call getin('anneeref',year_ini_cas)
+       call getin('dayref',day_deb)
+       mth_ini_cas=1 ! pour le moment on compte depuis le debut de l'annee
+       call getin('time_ini',heure_ini_cas)
+
+      print*,'NATURE DE LA SURFACE ',nat_surf
+!
+! Initialization of the logical switch for nudging
+
+     jcode = iflag_nudge
+     do i = 1,nudge_max
+       nudge(i) = mod(jcode,10) .ge. 1
+       jcode = jcode/10
+     enddo
+!-----------------------------------------------------------------------
+!  Definition of the run
+!-----------------------------------------------------------------------
+
+      call conf_gcm( 99, .TRUE. )
+      
+!-----------------------------------------------------------------------
+      allocate( phy_nat (year_len))  ! 0=ocean libre,1=land,2=glacier,3=banquise
+      phy_nat(:)=0.0
+      allocate( phy_alb (year_len))  ! Albedo land only (old value condsurf_jyg=0.3)
+      allocate( phy_sst (year_len))  ! SST (will not be used; cf read_tsurf1d.F)
+      allocate( phy_bil (year_len))  ! Ne sert que pour les slab_ocean
+      phy_bil(:)=1.0
+      allocate( phy_rug (year_len)) ! Longueur rugosite utilisee sur land only
+      allocate( phy_ice (year_len)) ! Fraction de glace
+      phy_ice(:)=0.0
+      allocate( phy_fter(year_len)) ! Fraction de terre
+      phy_fter(:)=0.0
+      allocate( phy_foce(year_len)) ! Fraction de ocean
+      phy_foce(:)=0.0
+      allocate( phy_fsic(year_len)) ! Fraction de glace
+      phy_fsic(:)=0.0
+      allocate( phy_flic(year_len)) ! Fraction de glace
+      phy_flic(:)=0.0
+
+
+!-----------------------------------------------------------------------
+!   Choix du calendrier
+!   -------------------
+
+!      calend = 'earth_365d'
+      if (calend == 'earth_360d') then
+        call ioconf_calendar('360_day')
+        write(*,*)'CALENDRIER CHOISI: Terrestre a 360 jours/an'
+      else if (calend == 'earth_365d') then
+        call ioconf_calendar('noleap')
+        write(*,*)'CALENDRIER CHOISI: Terrestre a 365 jours/an'
+      else if (calend == 'earth_366d') then
+        call ioconf_calendar('all_leap')
+        write(*,*)'CALENDRIER CHOISI: Terrestre bissextile'
+      else if (calend == 'gregorian') then
+        stop 'gregorian calend should not be used by normal user'
+        call ioconf_calendar('gregorian') ! not to be used by normal users
+        write(*,*)'CALENDRIER CHOISI: Gregorien'
+      else
+        write (*,*) 'ERROR : unknown calendar ', calend
+        stop 'calend should be 360d,earth_365d,earth_366d,gregorian'
+      endif
+!-----------------------------------------------------------------------
+!
+!c Date :
+!      La date est supposee donnee sous la forme [annee, numero du jour dans 
+!      l annee] ; l heure est donnee dans time_ini, lu dans lmdz1d.def.
+!      On appelle ymds2ju pour convertir [annee, jour] en [jour Julien].
+!      Le numero du jour est dans "day". L heure est traitee separement.
+!      La date complete est dans "daytime" (l'unite est le jour).
+
+
+      if (nday>0) then
+         fnday=nday
+      else
+         fnday=-nday/float(day_step)
+      endif
+      print *,'fnday=',fnday
+!     start_time doit etre en FRACTION DE JOUR
+      start_time=time_ini/24.
+
+      annee_ref = anneeref
+      mois = 1
+      day_ref = dayref
+      heure = 0.
+      itau_dyn = 0
+      itau_phy = 0
+      call ymds2ju(annee_ref,mois,day_ref,heure,day)
+      day_ini = int(day)
+      day_end = day_ini + int(fnday)
+
+! Convert the initial date to Julian day
+      day_ini_cas=day_deb
+      print*,'time case',year_ini_cas,mth_ini_cas,day_ini_cas
+      call ymds2ju                                                         &
+     & (year_ini_cas,mth_ini_cas,day_ini_cas,heure_ini_cas*3600            &
+     & ,day_ju_ini_cas)
+      print*,'time case 2',day_ini_cas,day_ju_ini_cas
+      daytime = day + heure_ini_cas/24. ! 1st day and initial time of the simulation 
+
+! Print out the actual date of the beginning of the simulation :
+      call ju2ymds(daytime,year_print, month_print,day_print,sec_print)
+      print *,' Time of beginning : ',                                      &
+     &        year_print, month_print, day_print, sec_print
+
+!---------------------------------------------------------------------
+! Initialization of dimensions, geometry and initial state
+!---------------------------------------------------------------------
+!     call init_phys_lmdz(1,1,llm,1,(/1/)) ! job now done via iniphysiq
+!     but we still need to initialize dimphy module (klon,klev,etc.)  here.
+      call init_dimphy1D(1,llm)
+      call suphel
+      call init_infotrac
+
+      if (nqtot>nqmx) STOP 'Augmenter nqmx dans lmdz1d.F'
+      allocate(q(llm,nqtot)) ; q(:,:)=0.
+      allocate(dq(llm,nqtot)) 
+      allocate(d_q_vert_adv(llm,nqtot)) 
+      allocate(d_q_adv(llm,nqtot)) 
+      allocate(d_q_nudge(llm,nqtot)) 
+!      allocate(d_th_adv(llm)) 
+
+      q(:,:) = 0.
+      dq(:,:) = 0.
+      d_q_vert_adv(:,:) = 0.
+      d_q_adv(:,:) = 0.
+      d_q_nudge(:,:) = 0.
+
+!
+!   No ozone climatology need be read in this pre-initialization
+!          (phys_state_var_init is called again in physiq)
+      read_climoz = 0
+      nsw=6
+
+      call phys_state_var_init(read_climoz)
+
+      if (ngrid.ne.klon) then
+         print*,'stop in inifis'
+         print*,'Probleme de dimensions :'
+         print*,'ngrid = ',ngrid
+         print*,'klon  = ',klon
+         stop
+      endif
+!!!=====================================================================
+!!! Feedback forcing values for Gateaux differentiation (al1)
+!!!=====================================================================
+!!
+      qsol = qsolinp
+      qsurf = fq_sat(tsurf,psurf/100.)
+      beta_aridity(:,:) = beta_surf
+      day1= day_ini
+      time=daytime-day
+      ts_toga(1)=tsurf ! needed by read_tsurf1d.F
+      rho(1)=psurf/(rd*tsurf*(1.+(rv/rd-1.)*qsurf)) 
+
+!
+!! mpl et jyg le 22/08/2012 : 
+!!  pour que les cas a flux de surface imposes marchent
+      IF(.NOT.ok_flux_surf.or.max(abs(wtsurf),abs(wqsurf))>0.) THEN
+       fsens=-wtsurf*rcpd*rho(1)
+       flat=-wqsurf*rlvtt*rho(1)
+       print *,'Flux: ok_flux wtsurf wqsurf',ok_flux_surf,wtsurf,wqsurf
+      ENDIF
+      print*,'Flux sol ',fsens,flat
+
+! Vertical discretization and pressure levels at half and mid levels:
+
+      pa   = 5e4
+!!      preff= 1.01325e5
+      preff = psurf
+      IF (ok_old_disvert) THEN
+        call disvert0(pa,preff,ap,bp,dpres,presnivs,nivsigs,nivsig)
+        print *,'On utilise disvert0'
+        aps(1:llm)=0.5*(ap(1:llm)+ap(2:llm+1))
+        bps(1:llm)=0.5*(bp(1:llm)+bp(2:llm+1))
+        scaleheight=8.
+        pseudoalt(1:llm)=-scaleheight*log(presnivs(1:llm)/preff)
+      ELSE
+        call disvert()
+        print *,'On utilise disvert'
+!       Nouvelle version disvert permettant d imposer ap,bp (modif L.Guez) MPL 18092012
+!       Dans ce cas, on lit ap,bp dans le fichier hybrid.txt
+      ENDIF
+
+      sig_s=presnivs/preff
+      plev =ap+bp*psurf
+      play = 0.5*(plev(1:llm)+plev(2:llm+1))
+      zlay=-rd*300.*log(play/psurf)/rg ! moved after reading profiles. 
+
+      IF (forcing_type .eq. 59) THEN
+! pour forcing_sandu, on cherche l'indice le plus proche de 700hpa#3000m
+      write(*,*) '***********************'
+      do l = 1, llm
+       write(*,*) 'l,play(l),presnivs(l): ',l,play(l),presnivs(l)
+       if (trouve_700 .and. play(l).le.70000) then
+         llm700=l
+         print *,'llm700,play=',llm700,play(l)/100.
+         trouve_700= .false.
+       endif
+      enddo
+      write(*,*) '***********************'
+      ENDIF
+
+!
+!=====================================================================
+! EVENTUALLY, READ FORCING DATA :
+!=====================================================================
+
+      INCLUDE "1D_read_forc_cases.h"
+   print*,'A d_t_adv ',d_t_adv(1:20)*86400
+
+      if (forcing_GCM2SCM) then
+        write (*,*) 'forcing_GCM2SCM not yet implemented'
+        stop 'in initialization'
+      endif ! forcing_GCM2SCM
+
+
+!=====================================================================
+! Initialisation de la physique : 
+!=====================================================================
+
+!  Rq: conf_phys.F90 lit tous les flags de physiq.def; conf_phys appele depuis physiq.F
+!
+! day_step, iphysiq lus dans gcm.def ci-dessus
+! timestep: calcule ci-dessous from rday et day_step
+! ngrid=1
+! llm: defini dans .../modipsl/modeles/LMDZ4/libf/grid/dimension
+! rday: defini dans suphel.F (86400.)
+! day_ini: lu dans run.def (dayref)
+! rlat_rad,rlon-rad: transformes en radian de rlat,rlon lus dans lmdz1d.def (en degres)
+! airefi,zcufi,zcvfi initialises au debut de ce programme
+! rday,ra,rg,rd,rcpd declares dans YOMCST.h et calcules dans suphel.F
+
+
+      day_step = float(nsplit_phys)*day_step/float(iphysiq)
+      write (*,*) 'Time step divided by nsplit_phys (=',nsplit_phys,')'
+      timestep =rday/day_step
+      dtime_frcg = timestep
+!
+      zcufi=airefi
+      zcvfi=airefi
+!
+      rlat_rad(1)=xlat*rpi/180.
+      rlon_rad(1)=xlon*rpi/180.
+
+     ! iniphysiq will call iniaqua who needs year_len from phys_cal_mod
+     year_len_phys_cal_mod=year_len
+           
+     ! Ehouarn: iniphysiq requires arrays related to (3D) dynamics grid,
+     ! e.g. for cell boundaries, which are meaningless in 1D; so pad these 
+     ! with '0.' when necessary
+
+      call iniphysiq(iim,jjm,llm, &
+           1,comm_lmdz, &
+           rday,day_ini,timestep,  &
+           (/rlat_rad(1),0./),(/0./), &
+           (/0.,0./),(/rlon_rad(1),0./),  &
+           (/ (/airefi,0./),(/0.,0./) /), &
+           (/zcufi,0.,0.,0./), &
+           (/zcvfi,0./), &
+           ra,rg,rd,rcpd,1)
+      print*,'apres iniphysiq'
+
+! 2 PARAMETRES QUI DEVRAIENT ETRE LUS DANS run.def MAIS NE LE SONT PAS ICI:
+      co2_ppm= 330.0
+      solaire=1370.0
+
+! Ecriture du startphy avant le premier appel a la physique.
+! On le met juste avant pour avoir acces a tous les champs
+
+      if (ok_writedem) then
+
+!--------------------------------------------------------------------------
+! pbl_surface_init (called here) and pbl_surface_final (called by phyredem)
+! need : qsol fder snow qsurf evap rugos agesno ftsoil
+!--------------------------------------------------------------------------
+
+        type_ocean = "force"
+        run_off_lic_0(1) = restart_runoff 
+        call fonte_neige_init(run_off_lic_0)
+
+        fder=0.
+        snsrf(1,:)=snowmass ! masse de neige des sous surface
+        qsurfsrf(1,:)=qsurf ! humidite de l'air des sous surface
+        fevap=0.
+        z0m(1,:)=rugos     ! couverture de neige des sous surface
+        z0h(1,:)=rugosh    ! couverture de neige des sous surface
+        agesno  = xagesno
+        tsoil(:,:,:)=tsurf
+!------ AMMA 2e run avec modele sol et rayonnement actif (MPL 23052012)
+!       tsoil(1,1,1)=299.18
+!       tsoil(1,2,1)=300.08
+!       tsoil(1,3,1)=301.88
+!       tsoil(1,4,1)=305.48
+!       tsoil(1,5,1)=308.00
+!       tsoil(1,6,1)=308.00
+!       tsoil(1,7,1)=308.00
+!       tsoil(1,8,1)=308.00
+!       tsoil(1,9,1)=308.00
+!       tsoil(1,10,1)=308.00
+!       tsoil(1,11,1)=308.00
+!-----------------------------------------------------------------------
+        call pbl_surface_init(fder, snsrf, qsurfsrf, tsoil)
+
+!------------------ prepare limit conditions for limit.nc -----------------
+!--   Ocean force
+
+        print*,'avant phyredem'
+        pctsrf(1,:)=0.
+          if (nat_surf.eq.0.) then
+          pctsrf(1,is_oce)=1.
+          pctsrf(1,is_ter)=0.
+          pctsrf(1,is_lic)=0.
+          pctsrf(1,is_sic)=0.
+        else if (nat_surf .eq. 1) then 
+          pctsrf(1,is_oce)=0.
+          pctsrf(1,is_ter)=1.
+          pctsrf(1,is_lic)=0.
+          pctsrf(1,is_sic)=0.
+        else if (nat_surf .eq. 2) then 
+          pctsrf(1,is_oce)=0.
+          pctsrf(1,is_ter)=0.
+          pctsrf(1,is_lic)=1.
+          pctsrf(1,is_sic)=0.
+        else if (nat_surf .eq. 3) then 
+          pctsrf(1,is_oce)=0.
+          pctsrf(1,is_ter)=0.
+          pctsrf(1,is_lic)=0.
+          pctsrf(1,is_sic)=1.
+
+     end if
+
+
+        print*,'nat_surf,pctsrf(1,is_oce),pctsrf(1,is_ter)',nat_surf         &
+     &        ,pctsrf(1,is_oce),pctsrf(1,is_ter)
+
+        zmasq=pctsrf(1,is_ter)+pctsrf(1,is_lic)
+        zpic = zpicinp
+        ftsol=tsurf
+        falb_dir=albedo
+        falb_dif=albedo
+        rugoro=rugos 
+        t_ancien(1,:)=temp(:)
+        q_ancien(1,:)=q(:,1)
+        ql_ancien = 0.
+        qs_ancien = 0.
+        prlw_ancien = 0.
+        prsw_ancien = 0.
+        prw_ancien = 0.
+        IF ( ok_bs ) THEN
+           qbs_ancien = 0.
+           prbsw_ancien = 0.
+        ENDIF
+        IF ( ok_ice_supersat ) THEN
+          cf_ancien = 0.
+          rvc_ancien = 0.
+        ENDIF
+!jyg<
+! Etienne: comment those lines since now the TKE is inialized in 1D_read_forc_cases
+!!      pbl_tke(:,:,:)=1.e-8
+!        pbl_tke(:,:,:)=0.
+!        pbl_tke(:,2,:)=1.e-2
+!>jyg
+        rain_fall=0.
+        snow_fall=0.
+        solsw=0.
+        solswfdiff=0.
+        sollw=0.
+        sollwdown=rsigma*tsurf**4
+        radsol=0.
+        rnebcon=0.
+        ratqs=0.
+        clwcon=0.
+        zmax0 = 0.
+        zmea=zsurf
+        zstd=0.
+        zsig=0.
+        zgam=0.
+        zval=0. 
+        zthe=0. 
+        sig1=0.
+        w01=0.
+!
+        wake_deltaq = 0.
+        wake_deltat = 0.
+        wake_delta_pbl_TKE(:,:,:) = 0.
+        delta_tsurf = 0.
+        wake_fip = 0.
+        wake_pe = 0.
+        wake_s = 0.
+        awake_s = 0.
+        wake_dens = 0.
+        awake_dens = 0.
+        cv_gen = 0.
+        wake_cstar = 0.
+        ale_bl = 0.
+        ale_bl_trig = 0.
+        alp_bl = 0.
+        IF (ALLOCATED(du_gwd_rando)) du_gwd_rando = 0.
+        IF (ALLOCATED(du_gwd_front)) du_gwd_front = 0.
+        entr_therm = 0.
+        detr_therm = 0.
+        f0 = 0.
+        fm_therm = 0.
+        u_ancien(1,:)=u(:)
+        v_ancien(1,:)=v(:)
+ 
+        u10m=0.
+        v10m=0.
+        ale_wake=0.
+        ale_bl_stat=0.
+        ratqs_inter_(:,:)= 0.002
+
+!------------------------------------------------------------------------
+! Make file containing restart for the physics (startphy.nc)
+!
+! NB: List of the variables to be written by phyredem (via put_field):
+! rlon,rlat,zmasq,pctsrf(:,is_ter),pctsrf(:,is_lic),pctsrf(:,is_oce)
+! pctsrf(:,is_sic),ftsol(:,nsrf),tsoil(:,isoil,nsrf),qsurf(:,nsrf)
+! qsol,falb_dir(:,nsrf),falb_dif(:,nsrf),evap(:,nsrf),snow(:,nsrf)
+! radsol,solsw,solswfdiff,sollw, sollwdown,fder,rain_fall,snow_fall,frugs(:,nsrf)
+! agesno(:,nsrf),zmea,zstd,zsig,zgam,zthe,zpic,zval,rugoro
+! t_ancien,q_ancien,,frugs(:,is_oce),clwcon(:,1),rnebcon(:,1),ratqs(:,1)
+! run_off_lic_0,pbl_tke(:,1:klev,nsrf), zmax0,f0,sig1,w01
+! wake_deltat,wake_deltaq,wake_s,awake_s,wake_dens,awake_dens,cv_gen,wake_cstar,
+! wake_fip,wake_delta_pbl_tke(:,1:klev,nsrf)
+!
+! NB2: The content of the startphy.nc file depends on some flags defined in
+! the ".def" files. However, since conf_phys is not called in lmdz1d.F90, these flags have 
+! to be set at some arbitratry convenient values.
+!------------------------------------------------------------------------
+!Al1 =============== restart option ======================================
+        iflag_physiq=0
+        call getin('iflag_physiq',iflag_physiq)
+
+        if (.not.restart) then
+          iflag_pbl = 5
+          call phyredem ("startphy.nc")
+        else
+! (desallocations)
+        print*,'callin surf final'
+          call pbl_surface_final( fder, snsrf, qsurfsrf, tsoil)
+        print*,'after surf final'
+          CALL fonte_neige_final(run_off_lic_0)
+        endif
+
+        ok_writedem=.false.
+        print*,'apres phyredem'
+
+      endif ! ok_writedem
+      
+!------------------------------------------------------------------------
+! Make file containing boundary conditions (limit.nc) **Al1->restartdyn***
+! --------------------------------------------------
+! NB: List of the variables to be written in limit.nc 
+!     (by writelim.F, subroutine of 1DUTILS.h):
+!        phy_nat,phy_alb,phy_sst,phy_bil,phy_rug,phy_ice,
+!        phy_fter,phy_foce,phy_flic,phy_fsic)
+!------------------------------------------------------------------------
+      do i=1,year_len
+        phy_nat(i)  = nat_surf
+        phy_alb(i)  = albedo
+        phy_sst(i)  = tsurf ! read_tsurf1d will be used instead
+        phy_rug(i)  = rugos
+        phy_fter(i) = pctsrf(1,is_ter)
+        phy_foce(i) = pctsrf(1,is_oce)
+        phy_fsic(i) = pctsrf(1,is_sic)
+        phy_flic(i) = pctsrf(1,is_lic)
+      enddo
+
+! fabrication de limit.nc
+      call writelim (1,phy_nat,phy_alb,phy_sst,phy_bil,phy_rug,             &
+     &               phy_ice,phy_fter,phy_foce,phy_flic,phy_fsic)
+
+
+      call phys_state_var_end
+!Al1
+      if (restart) then
+        print*,'call to restart dyn 1d'
+        Call dyn1deta0("start1dyn.nc",plev,play,phi,phis,presnivs,          &
+     &              u,v,temp,q,omega2)
+
+       print*,'fnday,annee_ref,day_ref,day_ini',                            &
+     &     fnday,annee_ref,day_ref,day_ini
+!**      call ymds2ju(annee_ref,mois,day_ini,heure,day)
+       day = day_ini
+       day_end = day_ini + nday
+       daytime = day + time_ini/24. ! 1st day and initial time of the simulation 
+
+! Print out the actual date of the beginning of the simulation :
+       call ju2ymds(daytime, an, mois, jour, heure)
+       print *,' Time of beginning : y m d h',an, mois,jour,heure/3600.
+
+       day = int(daytime)
+       time=daytime-day
+  
+       print*,'****** intialised fields from restart1dyn *******'
+       print*,'plev,play,phi,phis,presnivs,u,v,temp,q,omega2'
+       print*,'temp(1),q(1,1),u(1),v(1),plev(1),phis :'
+       print*,temp(1),q(1,1),u(1),v(1),plev(1),phis(1)
+! raz for safety
+       do l=1,llm
+         d_q_vert_adv(l,1) = 0.
+       enddo
+      endif
+!======================  end restart =================================
+      IF (ecrit_slab_oc.eq.1) then
+         open(97,file='div_slab.dat',STATUS='UNKNOWN')
+       elseif (ecrit_slab_oc.eq.0) then
+         open(97,file='div_slab.dat',STATUS='OLD')
+       endif
+!
+!=====================================================================
+IF (CPPKEY_OUTPUTPHYSSCM) THEN
+       CALL iophys_ini(timestep)
+END IF
+
+!=====================================================================
+! START OF THE TEMPORAL LOOP :
+!=====================================================================
+           
+      it_end = nint(fnday*day_step)
+      do while(it.le.it_end)
+
+       if (prt_level.ge.1) then
+         print*,'XXXXXXXXXXXXXXXXXXX ITAP,day,time=',                       &
+     &             it,day,time,it_end,day_step
+         print*,'PAS DE TEMPS ',timestep
+       endif
+       if (it.eq.it_end) lastcall=.True.
+
+!---------------------------------------------------------------------
+! Interpolation of forcings in time and onto model levels
+!---------------------------------------------------------------------
+
+      INCLUDE "1D_interp_cases.h"
+
+!---------------------------------------------------------------------
+!  Geopotential :
+!---------------------------------------------------------------------
+        phis(1)=zsurf*RG
+!        phi(1)=phis(1)+RD*temp(1)*(plev(1)-play(1))/(.5*(plev(1)+play(1)))
+
+        ! Calculate geopotential from the ground surface since phi and phis are added in physiq_mod
+        phi(1)=RD*temp(1)*(plev(1)-play(1))/(.5*(plev(1)+play(1)))
+
+        do l = 1, llm-1
+          phi(l+1)=phi(l)+RD*(temp(l)+temp(l+1))*                           &
+     &    (play(l)-play(l+1))/(play(l)+play(l+1))
+        enddo
+
+!---------------------------------------------------------------------
+!  Vertical advection
+!---------------------------------------------------------------------
+
+   IF ( forc_w+forc_omega > 0 ) THEN
+
+      IF ( forc_w == 1 ) THEN
+         w_adv=w_mod_cas
+         z_adv=phi/RG
+      ELSE
+         w_adv=omega
+         z_adv=play
+      ENDIF
+
+      teta=temp*(pzero/play)**rkappa
+      do l=2,llm-1
+        ! vertical tendencies computed as d X / d t = -W  d X / d z
+        d_u_vert_adv(l)=-w_adv(l)*(u(l+1)-u(l-1))/(z_adv(l+1)-z_adv(l-1))
+        d_v_vert_adv(l)=-w_adv(l)*(v(l+1)-v(l-1))/(z_adv(l+1)-z_adv(l-1))
+        ! d theta / dt = -W d theta / d z, transformed into d temp / d t dividing by (pzero/play(l))**rkappa
+        d_t_vert_adv(l)=-w_adv(l)*(teta(l+1)-teta(l-1))/(z_adv(l+1)-z_adv(l-1)) / (pzero/play(l))**rkappa
+        d_q_vert_adv(l,1)=-w_adv(l)*(q(l+1,1)-q(l-1,1))/(z_adv(l+1)-z_adv(l-1))
+      enddo
+      d_u_adv(:)=d_u_adv(:)+d_u_vert_adv(:)
+      d_v_adv(:)=d_v_adv(:)+d_v_vert_adv(:)
+      d_t_adv(:)=d_t_adv(:)+d_t_vert_adv(:)
+      d_q_adv(:,1)=d_q_adv(:,1)+d_q_vert_adv(:,1)
+   
+   ENDIF
+
+!---------------------------------------------------------------------
+! Listing output for debug prt_level>=1
+!---------------------------------------------------------------------
+       if (prt_level>=1) then
+         print *,' avant physiq : -------- day time ',day,time
+         write(*,*) 'firstcall,lastcall,phis',                               &
+     &               firstcall,lastcall,phis
+       end if
+       if (prt_level>=5) then
+         write(*,'(a10,2a4,4a13)') 'BEFOR1 IT=','it','l',                   &
+     &        'presniv','plev','play','phi'
+         write(*,'(a10,2i4,4f13.2)') ('BEFOR1 IT= ',it,l,                   &
+     &         presnivs(l),plev(l),play(l),phi(l),l=1,llm)
+         write(*,'(a11,2a4,a11,6a8)') 'BEFOR2','it','l',                    &
+     &         'presniv','u','v','temp','q1','q2','omega2'
+         write(*,'(a11,2i4,f11.2,5f8.2,e10.2)') ('BEFOR2 IT= ',it,l,         &
+     &   presnivs(l),u(l),v(l),temp(l),q(l,1),q(l,2),omega2(l),l=1,llm)
+       endif
+
+!---------------------------------------------------------------------
+!   Call physiq :
+!---------------------------------------------------------------------
+       call physiq(ngrid,llm, &
+                    firstcall,lastcall,timestep, &
+                    plev,play,phi,phis,presnivs, &
+                    u,v, rot, temp,q,omega2, &
+                    du_phys,dv_phys,dt_phys,dq,dpsrf)
+                firstcall=.false.
+
+!---------------------------------------------------------------------
+! Listing output for debug
+!---------------------------------------------------------------------
+        if (prt_level>=5) then
+          write(*,'(a11,2a4,4a13)') 'AFTER1 IT=','it','l',                  &
+     &        'presniv','plev','play','phi'
+          write(*,'(a11,2i4,4f13.2)') ('AFTER1 it= ',it,l,                  &
+     &    presnivs(l),plev(l),play(l),phi(l),l=1,llm)
+          write(*,'(a11,2a4,a11,6a8)') 'AFTER2','it','l',                   &
+     &         'presniv','u','v','temp','q1','q2','omega2'
+          write(*,'(a11,2i4,f11.2,5f8.2,e10.2)') ('AFTER2 it= ',it,l,       &
+     &    presnivs(l),u(l),v(l),temp(l),q(l,1),q(l,2),omega2(l),l=1,llm)
+          write(*,'(a11,2a4,a11,5a8)') 'AFTER3','it','l',                   &
+     &         'presniv','du_phys','dv_phys','dt_phys','dq1','dq2'    
+           write(*,'(a11,2i4,f11.2,5f8.2)') ('AFTER3 it= ',it,l,            &
+     &      presnivs(l),86400*du_phys(l),86400*dv_phys(l),                   &
+     &       86400*dt_phys(l),86400*dq(l,1),dq(l,2),l=1,llm)
+          write(*,*) 'dpsrf',dpsrf
+        endif
+!---------------------------------------------------------------------
+!   Add physical tendencies :
+!---------------------------------------------------------------------
+
+       fcoriolis=2.*sin(rpi*xlat/180.)*romega
+
+      IF (prt_level >= 5) print*, 'fcoriolis, xlat,mxcalc ', &
+                                   fcoriolis, xlat,mxcalc
+
+!---------------------------------------------------------------------
+! Geostrophic forcing 
+!---------------------------------------------------------------------
+
+      IF ( forc_geo == 0 ) THEN
+              d_u_age(1:mxcalc)=0.
+              d_v_age(1:mxcalc)=0.
+      ELSE
+       sfdt = sin(0.5*fcoriolis*timestep)
+       cfdt = cos(0.5*fcoriolis*timestep)
+
+        d_u_age(1:mxcalc)= -2.*sfdt/timestep*                                &
+     &          (sfdt*(u(1:mxcalc)-ug(1:mxcalc)) -                          &
+     &           cfdt*(v(1:mxcalc)-vg(1:mxcalc))  )
+!!     : fcoriolis*(v(1:mxcalc)-vg(1:mxcalc))
+!
+       d_v_age(1:mxcalc)= -2.*sfdt/timestep*                                 &
+     &          (cfdt*(u(1:mxcalc)-ug(1:mxcalc)) +                           &
+     &           sfdt*(v(1:mxcalc)-vg(1:mxcalc))  )
+!!     : -fcoriolis*(u(1:mxcalc)-ug(1:mxcalc))
+      ENDIF
+!
+!---------------------------------------------------------------------
+!  Nudging
+!  EV: rewrite the section to account for a time- and height-varying
+!  nudging
+!---------------------------------------------------------------------
+      d_t_nudge(:) = 0.
+      d_u_nudge(:) = 0.
+      d_v_nudge(:) = 0.
+      d_q_nudge(:,:) = 0.
+
+      DO l=1,llm
+
+         IF (nudging_u .LT. 0) THEN
+              
+             d_u_nudge(l)=(u_nudg_mod_cas(l)-u(l))*invtau_u_nudg_mod_cas(l)
+       
+         ELSE
+
+             IF ( play(l) < p_nudging_u .AND. nint(nudging_u) /= 0 ) &
+             & d_u_nudge(l)=(u_nudg_mod_cas(l)-u(l))/nudging_u
+
+         ENDIF 
+
+
+         IF (nudging_v .LT. 0) THEN
+              
+             d_v_nudge(l)=(v_nudg_mod_cas(l)-v(l))*invtau_v_nudg_mod_cas(l)
+       
+         ELSE
+
+
+             IF ( play(l) < p_nudging_v .AND. nint(nudging_v) /= 0 ) &
+             & d_v_nudge(l)=(v_nudg_mod_cas(l)-v(l))/nudging_v
+
+         ENDIF
+
+
+         IF (nudging_t .LT. 0) THEN
+              
+             d_t_nudge(l)=(temp_nudg_mod_cas(l)-temp(l))*invtau_temp_nudg_mod_cas(l)
+       
+         ELSE
+
+
+             IF ( play(l) < p_nudging_t .AND. nint(nudging_t) /= 0 ) &
+             & d_t_nudge(l)=(temp_nudg_mod_cas(l)-temp(l))/nudging_t
+
+          ENDIF
+
+
+         IF (nudging_qv .LT. 0) THEN
+              
+             d_q_nudge(l,1)=(qv_nudg_mod_cas(l)-q(l,1))*invtau_qv_nudg_mod_cas(l)
+       
+         ELSE
+
+             IF ( play(l) < p_nudging_qv .AND. nint(nudging_qv) /= 0 ) &
+             & d_q_nudge(l,1)=(qv_nudg_mod_cas(l)-q(l,1))/nudging_qv
+
+         ENDIF
+
+      ENDDO
+
+!---------------------------------------------------------------------
+!  Optional outputs
+!---------------------------------------------------------------------
+
+IF (CPPKEY_OUTPUTPHYSSCM) THEN
+      CALL iophys_ecrit('w_adv',klev,'w_adv','K/day',w_adv)
+      CALL iophys_ecrit('z_adv',klev,'z_adv','K/day',z_adv)
+      CALL iophys_ecrit('dtadv',klev,'dtadv','K/day',86400*d_t_adv)
+      CALL iophys_ecrit('dtdyn',klev,'dtdyn','K/day',86400*d_t_vert_adv)
+      CALL iophys_ecrit('qv',klev,'qv','g/kg',1000*q(:,1))
+      CALL iophys_ecrit('qvnud',klev,'qvnud','g/kg',1000*u_nudg_mod_cas)
+      CALL iophys_ecrit('u',klev,'u','m/s',u)
+      CALL iophys_ecrit('unud',klev,'unud','m/s',u_nudg_mod_cas)
+      CALL iophys_ecrit('v',klev,'v','m/s',v)
+      CALL iophys_ecrit('vnud',klev,'vnud','m/s',v_nudg_mod_cas)
+      CALL iophys_ecrit('temp',klev,'temp','K',temp)
+      CALL iophys_ecrit('tempnud',klev,'temp_nudg_mod_cas','K',temp_nudg_mod_cas)
+      CALL iophys_ecrit('dtnud',klev,'dtnud','K/day',86400*d_t_nudge)
+      CALL iophys_ecrit('dqnud',klev,'dqnud','K/day',1000*86400*d_q_nudge(:,1))
+END IF
+
+    IF (flag_inhib_forcing == 0) then ! if tendency of forcings should be added
+
+        u(1:mxcalc)=u(1:mxcalc) + timestep*(                                &
+     &              du_phys(1:mxcalc)                                       &
+     &             +d_u_age(1:mxcalc)+d_u_adv(1:mxcalc)                       &
+     &             +d_u_nudge(1:mxcalc) )            
+        v(1:mxcalc)=v(1:mxcalc) + timestep*(                                 &
+     &              dv_phys(1:mxcalc)                                       &
+     &             +d_v_age(1:mxcalc)+d_v_adv(1:mxcalc)                       &
+     &             +d_v_nudge(1:mxcalc) )
+        q(1:mxcalc,:)=q(1:mxcalc,:)+timestep*(                              &
+     &                dq(1:mxcalc,:)                                        &
+     &               +d_q_adv(1:mxcalc,:)                                   &
+     &               +d_q_nudge(1:mxcalc,:) )
+
+        if (prt_level.ge.3) then
+          print *,                                                          &
+     &    'physiq-> temp(1),dt_phys(1),d_t_adv(1),dt_cooling(1) ',         &
+     &              temp(1),dt_phys(1),d_t_adv(1),dt_cooling(1)
+           print* ,'dv_phys=',dv_phys
+           print* ,'d_v_age=',d_v_age
+           print* ,'d_v_adv=',d_v_adv
+           print* ,'d_v_nudge=',d_v_nudge
+           print*, v
+           print*, vg
+        endif
+
+        temp(1:mxcalc)=temp(1:mxcalc)+timestep*(                            &
+     &              dt_phys(1:mxcalc)                                       &
+     &             +d_t_adv(1:mxcalc)                                       &
+     &             +d_t_nudge(1:mxcalc)                                     &
+     &             +dt_cooling(1:mxcalc))  ! Taux de chauffage ou refroid.
+
+
+!=======================================================================
+!! CONSERVE EN ATTENDANT QUE LE CAS EN QUESTION FONCTIONNE EN STD !!
+!=======================================================================
+
+        teta=temp*(pzero/play)**rkappa
+
+!---------------------------------------------------------------------
+!   Nudge soil temperature if requested
+!---------------------------------------------------------------------
+
+      IF (nudge_tsoil .AND. .NOT. lastcall) THEN
+       ftsoil(1,isoil_nudge,:) = ftsoil(1,isoil_nudge,:)                     &
+     &  -timestep/tau_soil_nudge*(ftsoil(1,isoil_nudge,:)-Tsoil_nudge)
+      ENDIF
+
+!---------------------------------------------------------------------
+!   Add large-scale tendencies (advection, etc) :
+!---------------------------------------------------------------------
+
+!cc nrlmd
+!cc        tmpvar=teta
+!cc        call advect_vert(llm,omega,timestep,tmpvar,plev)
+!cc
+!cc        teta(1:mxcalc)=tmpvar(1:mxcalc)
+!cc        tmpvar(:)=q(:,1)
+!cc        call advect_vert(llm,omega,timestep,tmpvar,plev)
+!cc        q(1:mxcalc,1)=tmpvar(1:mxcalc)
+!cc        tmpvar(:)=q(:,2)
+!cc        call advect_vert(llm,omega,timestep,tmpvar,plev)
+!cc        q(1:mxcalc,2)=tmpvar(1:mxcalc)
+
+   END IF ! end if tendency of tendency should be added
+
+!---------------------------------------------------------------------
+!   Air temperature :
+!---------------------------------------------------------------------        
+        if (lastcall) then
+          print*,'Pas de temps final ',it
+          call ju2ymds(daytime, an, mois, jour, heure)
+          print*,'a la date : a m j h',an, mois, jour ,heure/3600.
+        endif
+
+!  incremente day time
+        daytime = daytime+1./day_step
+        day = int(daytime+0.1/day_step)
+!        time = max(daytime-day,0.0)
+!Al1&jyg: correction de bug
+!cc        time = real(mod(it,day_step))/day_step
+        time = time_ini/24.+real(mod(it,day_step))/day_step
+        it=it+1
+
+      enddo
+
+      if (ecrit_slab_oc.ne.-1) close(97)
+
+!Al1 Call to 1D equivalent of dynredem (an,mois,jour,heure ?)
+! ---------------------------------------------------------------------------
+       call dyn1dredem("restart1dyn.nc",                                    &
+     &              plev,play,phi,phis,presnivs,                            &
+     &              u,v,temp,q,omega2)
+
+        CALL abort_gcm ('lmdz1d   ','The End  ',0)
+
+END SUBROUTINE scm
Index: DZ6/trunk/libf/phylmd/dyn1d/serre_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/dyn1d/serre_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../../dyn3d_common/serre_mod.F90
Index: /LMDZ6/trunk/libf/phylmd/dyn1d/serre_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/dyn1d/serre_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/dyn1d/serre_mod.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../../dyn3d_common/serre_mod.f90
Index: DZ6/trunk/libf/phylmd/dyn1d/temps_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/dyn1d/temps_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../../dyn3d/temps_mod.F90
Index: /LMDZ6/trunk/libf/phylmd/dyn1d/temps_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/dyn1d/temps_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/dyn1d/temps_mod.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../../dyn3d/temps_mod.f90
Index: DZ6/trunk/libf/phylmd/ecrad/lmdz/aeropt_5wv_ecrad.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/ecrad/lmdz/aeropt_5wv_ecrad.F90	(revision 5267)
+++ 	(revision )
@@ -1,100 +1,0 @@
-!aeropt_5wv_ecrad.F90 2022-09-20 A. Idelkadi et O. Boucher 
-!
-     SUBROUTINE AEROPT_5WV_ECRAD(istartcol,iendcol,istartlev,iendlev, &
-                                 config,thermodynamics,aerosol)
-
-
-      USE DIMPHY
-      USE aero_mod
-      USE phys_local_var_mod, ONLY: od443aer,od550aer,od865aer
-!                                      dryod550aer, 
-!                                      ec550aer,od550lt1aer,abs550aer
-!        USE phys_output_var_mod, ONLY: dryaod_diag
-!        USE YOMCST, ONLY: RD,RG
-      USE phys_local_var_mod, ONLY: rhcl
-
-      use parkind1,                      only : jprb
-      use radiation_config,              only : config_type
-      use radiation_thermodynamics,      only : thermodynamics_type
-      use radiation_aerosol,             only : aerosol_type
-      use radiation_constants,           only : AccelDueToGravity
-      use radiation_aerosol_optics_data, only : aerosol_optics_type, &
-         &  IAerosolClassUndefined,   IAerosolClassIgnored, &
-         &  IAerosolClassHydrophobic, IAerosolClassHydrophilic
-
-      IMPLICIT NONE
-
-      !---ATTENTION n_mono est a redéfinir proprement
-
-      ! Range of levels over which aerosols are present
-      integer, intent(in) :: istartlev, iendlev, istartcol,iendcol
-      type(config_type), intent(in), target :: config
-      type(thermodynamics_type),intent(in)  :: thermodynamics
-      type(aerosol_type),       intent(in)  :: aerosol
-      type(aerosol_optics_type), pointer :: ao
-
-      ! Loop indices for column, level, g point, band and aerosol type, and relative humidity
-      integer :: jcol, jlev, jtype, irh
-      ! indice wavelength in aerosol_optics_lmdz.nc
-      INTEGER, PARAMETER :: la443 = 1
-      INTEGER, PARAMETER :: la550 = 2
-!      INTEGER, PARAMETER :: la670 = 3
-!      INTEGER, PARAMETER :: la765 = 4
-      INTEGER, PARAMETER :: la865 = 5
-      real(jprb) :: factor
-      ! n_bands_sw
-      real(jprb), dimension(config%aerosol_optics%n_mono_wl) :: od_aerosol_mono, local_od_mono
-
-      !--initialization
-      od443aer = 0.0_jprb
-      od550aer = 0.0_jprb
-      od865aer = 0.0_jprb
-
-      ao => config%aerosol_optics
-
-      ! Loop over level
-     do jlev = istartlev,iendlev
-
-        ! Loop over column
-        do jcol = istartcol,iendcol
-
-          ! Compute relative humidity with respect to liquid
-          ! saturation and the index to the relative-humidity index of
-          ! hydrophilic-aerosol data
-          irh = ao%calc_rh_index(rhcl(jcol,jlev))
-
-          factor = ( thermodynamics%pressure_hl(jcol,jlev+1) &
-               &    -thermodynamics%pressure_hl(jcol,jlev  )  ) &
-               &   / AccelDueToGravity
-
-          ! Reset temporary arrays
-          od_aerosol_mono = 0.0_jprb
-
-          do jtype = 1,config%n_aerosol_types
-            ! Add the optical depth for this aerosol type to the total for all aerosols.  
-            ! Note that the following expressions are array-wise
-            if (ao%iclass(jtype) == IAerosolClassHydrophobic) then
-              local_od_mono = factor * aerosol%mixing_ratio(jcol,jlev,jtype) &
-                   &  * ao%mass_ext_mono_phobic(:,ao%itype(jtype))
-              od_aerosol_mono = od_aerosol_mono + local_od_mono
-            else if (ao%iclass(jtype) == IAerosolClassHydrophilic) then
-              ! Hydrophilic aerosols require the look-up tables to
-              ! be indexed with irh
-              local_od_mono = factor * aerosol%mixing_ratio(jcol,jlev,jtype) &
-                   &  * ao%mass_ext_mono_philic(:,irh,ao%itype(jtype))
-              od_aerosol_mono = od_aerosol_mono + local_od_mono
-            end if
-
-          end do ! Loop over aerosol type
-
-          !--ATTENTION A BIEN FAIRE CORRESPONDRE LES INDICES
-          od443aer(jcol) = od443aer(jcol) + od_aerosol_mono(la443)
-          od550aer(jcol) = od550aer(jcol) + od_aerosol_mono(la550)
-          od865aer(jcol) = od865aer(jcol) + od_aerosol_mono(la865)
-
-        end do ! Loop over column
-
-      end do ! Loop over level
-
-     END SUBROUTINE AEROPT_5WV_ECRAD
-
Index: /LMDZ6/trunk/libf/phylmd/ecrad/lmdz/aeropt_5wv_ecrad.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/ecrad/lmdz/aeropt_5wv_ecrad.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/ecrad/lmdz/aeropt_5wv_ecrad.f90	(revision 5268)
@@ -0,0 +1,100 @@
+!aeropt_5wv_ecrad.F90 2022-09-20 A. Idelkadi et O. Boucher 
+!
+     SUBROUTINE AEROPT_5WV_ECRAD(istartcol,iendcol,istartlev,iendlev, &
+                                 config,thermodynamics,aerosol)
+
+
+      USE DIMPHY
+      USE aero_mod
+      USE phys_local_var_mod, ONLY: od443aer,od550aer,od865aer
+!                                      dryod550aer, 
+!                                      ec550aer,od550lt1aer,abs550aer
+!        USE phys_output_var_mod, ONLY: dryaod_diag
+!        USE YOMCST, ONLY: RD,RG
+      USE phys_local_var_mod, ONLY: rhcl
+
+      use parkind1,                      only : jprb
+      use radiation_config,              only : config_type
+      use radiation_thermodynamics,      only : thermodynamics_type
+      use radiation_aerosol,             only : aerosol_type
+      use radiation_constants,           only : AccelDueToGravity
+      use radiation_aerosol_optics_data, only : aerosol_optics_type, &
+         &  IAerosolClassUndefined,   IAerosolClassIgnored, &
+         &  IAerosolClassHydrophobic, IAerosolClassHydrophilic
+
+      IMPLICIT NONE
+
+      !---ATTENTION n_mono est a redéfinir proprement
+
+      ! Range of levels over which aerosols are present
+      integer, intent(in) :: istartlev, iendlev, istartcol,iendcol
+      type(config_type), intent(in), target :: config
+      type(thermodynamics_type),intent(in)  :: thermodynamics
+      type(aerosol_type),       intent(in)  :: aerosol
+      type(aerosol_optics_type), pointer :: ao
+
+      ! Loop indices for column, level, g point, band and aerosol type, and relative humidity
+      integer :: jcol, jlev, jtype, irh
+      ! indice wavelength in aerosol_optics_lmdz.nc
+      INTEGER, PARAMETER :: la443 = 1
+      INTEGER, PARAMETER :: la550 = 2
+!      INTEGER, PARAMETER :: la670 = 3
+!      INTEGER, PARAMETER :: la765 = 4
+      INTEGER, PARAMETER :: la865 = 5
+      real(jprb) :: factor
+      ! n_bands_sw
+      real(jprb), dimension(config%aerosol_optics%n_mono_wl) :: od_aerosol_mono, local_od_mono
+
+      !--initialization
+      od443aer = 0.0_jprb
+      od550aer = 0.0_jprb
+      od865aer = 0.0_jprb
+
+      ao => config%aerosol_optics
+
+      ! Loop over level
+     do jlev = istartlev,iendlev
+
+        ! Loop over column
+        do jcol = istartcol,iendcol
+
+          ! Compute relative humidity with respect to liquid
+          ! saturation and the index to the relative-humidity index of
+          ! hydrophilic-aerosol data
+          irh = ao%calc_rh_index(rhcl(jcol,jlev))
+
+          factor = ( thermodynamics%pressure_hl(jcol,jlev+1) &
+               &    -thermodynamics%pressure_hl(jcol,jlev  )  ) &
+               &   / AccelDueToGravity
+
+          ! Reset temporary arrays
+          od_aerosol_mono = 0.0_jprb
+
+          do jtype = 1,config%n_aerosol_types
+            ! Add the optical depth for this aerosol type to the total for all aerosols.  
+            ! Note that the following expressions are array-wise
+            if (ao%iclass(jtype) == IAerosolClassHydrophobic) then
+              local_od_mono = factor * aerosol%mixing_ratio(jcol,jlev,jtype) &
+                   &  * ao%mass_ext_mono_phobic(:,ao%itype(jtype))
+              od_aerosol_mono = od_aerosol_mono + local_od_mono
+            else if (ao%iclass(jtype) == IAerosolClassHydrophilic) then
+              ! Hydrophilic aerosols require the look-up tables to
+              ! be indexed with irh
+              local_od_mono = factor * aerosol%mixing_ratio(jcol,jlev,jtype) &
+                   &  * ao%mass_ext_mono_philic(:,irh,ao%itype(jtype))
+              od_aerosol_mono = od_aerosol_mono + local_od_mono
+            end if
+
+          end do ! Loop over aerosol type
+
+          !--ATTENTION A BIEN FAIRE CORRESPONDRE LES INDICES
+          od443aer(jcol) = od443aer(jcol) + od_aerosol_mono(la443)
+          od550aer(jcol) = od550aer(jcol) + od_aerosol_mono(la550)
+          od865aer(jcol) = od865aer(jcol) + od_aerosol_mono(la865)
+
+        end do ! Loop over column
+
+      end do ! Loop over level
+
+     END SUBROUTINE AEROPT_5WV_ECRAD
+
Index: DZ6/trunk/libf/phylmd/ecrad/lmdz/calcul_cloud_overlap_decorr_len.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/ecrad/lmdz/calcul_cloud_overlap_decorr_len.F90	(revision 5267)
+++ 	(revision )
@@ -1,155 +1,0 @@
-SUBROUTINE CALCUL_CLOUD_OVERLAP_DECORR_LEN &
-     & (KIDIA, KFDIA, KLON, KLEV, &
-     &  driver_config, &
-     &  pressure_hl, &
-     &  PDECORR_LEN_EDGES_M, PDECORR_LEN_WATER_M, PDECORR_LEN_RATIO)
-
-! A Idelkadi ! -------------
-! 04 2024
-! Depart de la routine de l' IFS
-! But : calcul de la Ld (longueur de decorrelation)
-! Dans le cas overlap_scheme_name=="Exp-Ran"
-! 3 cas en fonction de kdecolat (namelist_ecrad) :
-! 0 => Ld=overlap_decorr_length (namelist_ecrad)
-! 1 => Ld=f(latitude) Shonk et al. (2010) Eq. 13 formula
-! 2 => Ld=f(latitude) Shonk et al. (2010) lissee a l equateur
-! 3 => Ld=f(pres) : 
-!      Ld=low_decorrelation_length si pres >= 680hPa 
-!      Ld=mid_decorrelation_length si pres entre [440,680]
-!      Ld=high_decorrelation_length si pres < 440hPa
-!
-! TO DO 
-! Que faire de PDECORR_LEN_WATER_M ?
-! -------------------------------------------------------------------
-
-USE PARKIND1 , ONLY : JPIM, JPRB
-USE YOMHOOK  , ONLY : LHOOK, DR_HOOK, JPHOOK
-USE YOMCST   , ONLY : RPI
-USE geometry_mod, ONLY: latitude_deg
-USE lmdz_cloud_optics_prop_ini , ONLY : prmhc, prlmc
-USE setup_config_from_lmdz,   ONLY : driver_config_type
-USE write_field_phy
-! -------------------------------------------------------------------
-
-IMPLICIT NONE
-
-! INPUT ARGUMENTS
-
-! *** Array dimensions and ranges
-INTEGER(KIND=JPIM),INTENT(IN) :: KIDIA    ! Start column to process
-INTEGER(KIND=JPIM),INTENT(IN) :: KFDIA    ! End column to process
-INTEGER(KIND=JPIM),INTENT(IN) :: KLON     ! Number of columns
-! AI 04 2024
-INTEGER(KIND=JPIM),INTENT(IN) :: KLEV
-
-! *** Single-level variables 
-!AI 04 2024
-REAL(KIND=JPRB), intent(in)   :: pressure_hl(KLON,KLEV+1)
-type(driver_config_type),intent(in)   :: driver_config
-
-! OUTPUT ARGUMENTS
-
-! *** Decorrelation lengths for cloud edges and cloud water content, in m
-! A.I 04 2024
-REAL(KIND=JPRB), INTENT(OUT)           :: PDECORR_LEN_EDGES_M(KLON,KLEV)
-REAL(KIND=JPRB), INTENT(OUT), OPTIONAL :: PDECORR_LEN_WATER_M(KLON,KLEV)
-  
-! Ratio of water-content to cloud-edge decorrelation lengths
-REAL(KIND=JPRB), INTENT(OUT), OPTIONAL :: PDECORR_LEN_RATIO
-
-! LOCAL VARIABLES
-
-REAL(KIND=JPRB) :: ZRADIANS_TO_DEGREES, ZABS_LAT_DEG, ZCOS_LAT
-
-! AI 04 2024
-REAL(KIND=JPRB) :: PGEMU(KLON) ! Sine of latitude
-REAL(KIND=JPRB) :: RDECORR_CF
-REAL(KIND=JPRB) :: RDECORR_CW = 1.0_JPRB
-
-INTEGER(KIND=JPIM) :: JL, JK
-
-REAL(KIND=JPHOOK) :: ZHOOK_HANDLE
-
-! -------------------------------------------------------------------
-
-IF (LHOOK) CALL DR_HOOK('CLOUD_OVERLAP_DECORR_LEN',0,ZHOOK_HANDLE)
-  
-! -------------------------------------------------------------------
-print*,'driver_config%kdecolat = ', driver_config%kdecolat
-
-IF (driver_config%kdecolat == 0) THEN
-
-  ! Decorrelation lengths are constant values
-  ! overlap_decorr_length lu dans namelist en m
-  RDECORR_CF = driver_config%overlap_decorr_length / 1000.0_JPRB
-  PDECORR_LEN_EDGES_M(KIDIA:KFDIA,:) = driver_config%overlap_decorr_length
-!  IF (PRESENT(PDECORR_LEN_WATER_M)) THEN
-!    PDECORR_LEN_WATER_M = RDECORR_CW * 1000.0_JPRB
-!  ENDIF
-!  IF (PRESENT(PDECORR_LEN_RATIO)) THEN
-!    PDECORR_LEN_RATIO = RDECORR_CW / RDECORR_CF
-!  ENDIF
-
-ELSE
-
-  ZRADIANS_TO_DEGREES = 180.0_JPRB / RPI
-  PGEMU = SIN(latitude_deg)
-
-  IF (driver_config%kdecolat == 1) THEN
-    ! Shonk et al. (2010) Eq. 13 formula
-    DO JL = KIDIA,KFDIA
-      ZABS_LAT_DEG = ABS(ASIN(PGEMU(JL)) * ZRADIANS_TO_DEGREES)
-      PDECORR_LEN_EDGES_M(JL,:) = (2.899_JPRB - 0.02759_JPRB * ZABS_LAT_DEG) * 1000.0_JPRB
-    ENDDO
-  ELSE ! KDECOLAT == 2
-    DO JL = KIDIA,KFDIA
-      ! Shonk et al. (2010) but smoothed over the equator
-      ZCOS_LAT = COS(ASIN(PGEMU(JL)))
-      PDECORR_LEN_EDGES_M(JL,:) = (0.75_JPRB + 2.149_JPRB * ZCOS_LAT*ZCOS_LAT) * 1000.0_JPRB
-    ENDDO
-  ENDIF
-
-
-  ! Both KDECOLAT = 1 and 2 assume that the decorrelation length for
-  ! cloud water content is half that for cloud edges
-!  IF (PRESENT(PDECORR_LEN_WATER_M)) THEN
-!    PDECORR_LEN_WATER_M(KIDIA:KFDIA,:) = PDECORR_LEN_EDGES_M(KIDIA:KFDIA,:) * 0.5_JPRB 
-!  ENDIF
-
-!  IF (PRESENT(PDECORR_LEN_RATIO)) THEN
-!    PDECORR_LEN_RATIO = 0.5_JPRB
-!  ENDIF
-
-ENDIF
-
-!AI 04 2024
-IF (driver_config%kdecolat == 3) THEN
-  DO jk = 1, klev
-      DO JL = 1, klon
-        IF (pressure_hl(JL,jk)<prmhc) THEN
-          PDECORR_LEN_EDGES_M(JL,jk) = driver_config%high_decorrelation_length
-        ELSE IF (pressure_hl(JL,jk)>=prmhc .AND. pressure_hl(JL,jk)<prlmc) THEN
-          PDECORR_LEN_EDGES_M(JL,jk) = driver_config%mid_decorrelation_length
-        ELSE IF (pressure_hl(JL,jk)>=prlmc) THEN
-          PDECORR_LEN_EDGES_M(JL,jk) = driver_config%low_decorrelation_length
-        ENDIF
-      ENDDO
-  ENDDO
-  
-  ! Both KDECOLAT = 1 and 2 assume that the decorrelation length for
-  ! cloud water content is half that for cloud edges
-!  IF (PRESENT(PDECORR_LEN_WATER_M)) THEN
-!    PDECORR_LEN_WATER_M(KIDIA:KFDIA,:) = PDECORR_LEN_EDGES_M(KIDIA:KFDIA,:) * 0.5_JPRB 
-!  ENDIF
-!  IF (PRESENT(PDECORR_LEN_RATIO)) THEN
-!    PDECORR_LEN_RATIO = 0.5_JPRB
-!  ENDIF
-ENDIF
-!CALL writefield_phy('latitude',latitude_deg,1)
-!CALL writefield_phy('pressure_hl',pressure_hl,klev+1)
-!CALL writefield_phy('Ldecorel',PDECORR_LEN_EDGES_M,klev)
-! -------------------------------------------------------------------
-
-IF (LHOOK) CALL DR_HOOK('CLOUD_OVERLAP_DECORR_LEN',1,ZHOOK_HANDLE)
-
-END SUBROUTINE CALCUL_CLOUD_OVERLAP_DECORR_LEN
Index: /LMDZ6/trunk/libf/phylmd/ecrad/lmdz/calcul_cloud_overlap_decorr_len.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/ecrad/lmdz/calcul_cloud_overlap_decorr_len.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/ecrad/lmdz/calcul_cloud_overlap_decorr_len.f90	(revision 5268)
@@ -0,0 +1,155 @@
+SUBROUTINE CALCUL_CLOUD_OVERLAP_DECORR_LEN &
+     & (KIDIA, KFDIA, KLON, KLEV, &
+     &  driver_config, &
+     &  pressure_hl, &
+     &  PDECORR_LEN_EDGES_M, PDECORR_LEN_WATER_M, PDECORR_LEN_RATIO)
+
+! A Idelkadi ! -------------
+! 04 2024
+! Depart de la routine de l' IFS
+! But : calcul de la Ld (longueur de decorrelation)
+! Dans le cas overlap_scheme_name=="Exp-Ran"
+! 3 cas en fonction de kdecolat (namelist_ecrad) :
+! 0 => Ld=overlap_decorr_length (namelist_ecrad)
+! 1 => Ld=f(latitude) Shonk et al. (2010) Eq. 13 formula
+! 2 => Ld=f(latitude) Shonk et al. (2010) lissee a l equateur
+! 3 => Ld=f(pres) : 
+!      Ld=low_decorrelation_length si pres >= 680hPa 
+!      Ld=mid_decorrelation_length si pres entre [440,680]
+!      Ld=high_decorrelation_length si pres < 440hPa
+!
+! TO DO 
+! Que faire de PDECORR_LEN_WATER_M ?
+! -------------------------------------------------------------------
+
+USE PARKIND1 , ONLY : JPIM, JPRB
+USE YOMHOOK  , ONLY : LHOOK, DR_HOOK, JPHOOK
+USE YOMCST   , ONLY : RPI
+USE geometry_mod, ONLY: latitude_deg
+USE lmdz_cloud_optics_prop_ini , ONLY : prmhc, prlmc
+USE setup_config_from_lmdz,   ONLY : driver_config_type
+USE write_field_phy
+! -------------------------------------------------------------------
+
+IMPLICIT NONE
+
+! INPUT ARGUMENTS
+
+! *** Array dimensions and ranges
+INTEGER(KIND=JPIM),INTENT(IN) :: KIDIA    ! Start column to process
+INTEGER(KIND=JPIM),INTENT(IN) :: KFDIA    ! End column to process
+INTEGER(KIND=JPIM),INTENT(IN) :: KLON     ! Number of columns
+! AI 04 2024
+INTEGER(KIND=JPIM),INTENT(IN) :: KLEV
+
+! *** Single-level variables 
+!AI 04 2024
+REAL(KIND=JPRB), intent(in)   :: pressure_hl(KLON,KLEV+1)
+type(driver_config_type),intent(in)   :: driver_config
+
+! OUTPUT ARGUMENTS
+
+! *** Decorrelation lengths for cloud edges and cloud water content, in m
+! A.I 04 2024
+REAL(KIND=JPRB), INTENT(OUT)           :: PDECORR_LEN_EDGES_M(KLON,KLEV)
+REAL(KIND=JPRB), INTENT(OUT), OPTIONAL :: PDECORR_LEN_WATER_M(KLON,KLEV)
+  
+! Ratio of water-content to cloud-edge decorrelation lengths
+REAL(KIND=JPRB), INTENT(OUT), OPTIONAL :: PDECORR_LEN_RATIO
+
+! LOCAL VARIABLES
+
+REAL(KIND=JPRB) :: ZRADIANS_TO_DEGREES, ZABS_LAT_DEG, ZCOS_LAT
+
+! AI 04 2024
+REAL(KIND=JPRB) :: PGEMU(KLON) ! Sine of latitude
+REAL(KIND=JPRB) :: RDECORR_CF
+REAL(KIND=JPRB) :: RDECORR_CW = 1.0_JPRB
+
+INTEGER(KIND=JPIM) :: JL, JK
+
+REAL(KIND=JPHOOK) :: ZHOOK_HANDLE
+
+! -------------------------------------------------------------------
+
+IF (LHOOK) CALL DR_HOOK('CLOUD_OVERLAP_DECORR_LEN',0,ZHOOK_HANDLE)
+  
+! -------------------------------------------------------------------
+print*,'driver_config%kdecolat = ', driver_config%kdecolat
+
+IF (driver_config%kdecolat == 0) THEN
+
+  ! Decorrelation lengths are constant values
+  ! overlap_decorr_length lu dans namelist en m
+  RDECORR_CF = driver_config%overlap_decorr_length / 1000.0_JPRB
+  PDECORR_LEN_EDGES_M(KIDIA:KFDIA,:) = driver_config%overlap_decorr_length
+!  IF (PRESENT(PDECORR_LEN_WATER_M)) THEN
+!    PDECORR_LEN_WATER_M = RDECORR_CW * 1000.0_JPRB
+!  ENDIF
+!  IF (PRESENT(PDECORR_LEN_RATIO)) THEN
+!    PDECORR_LEN_RATIO = RDECORR_CW / RDECORR_CF
+!  ENDIF
+
+ELSE
+
+  ZRADIANS_TO_DEGREES = 180.0_JPRB / RPI
+  PGEMU = SIN(latitude_deg)
+
+  IF (driver_config%kdecolat == 1) THEN
+    ! Shonk et al. (2010) Eq. 13 formula
+    DO JL = KIDIA,KFDIA
+      ZABS_LAT_DEG = ABS(ASIN(PGEMU(JL)) * ZRADIANS_TO_DEGREES)
+      PDECORR_LEN_EDGES_M(JL,:) = (2.899_JPRB - 0.02759_JPRB * ZABS_LAT_DEG) * 1000.0_JPRB
+    ENDDO
+  ELSE ! KDECOLAT == 2
+    DO JL = KIDIA,KFDIA
+      ! Shonk et al. (2010) but smoothed over the equator
+      ZCOS_LAT = COS(ASIN(PGEMU(JL)))
+      PDECORR_LEN_EDGES_M(JL,:) = (0.75_JPRB + 2.149_JPRB * ZCOS_LAT*ZCOS_LAT) * 1000.0_JPRB
+    ENDDO
+  ENDIF
+
+
+  ! Both KDECOLAT = 1 and 2 assume that the decorrelation length for
+  ! cloud water content is half that for cloud edges
+!  IF (PRESENT(PDECORR_LEN_WATER_M)) THEN
+!    PDECORR_LEN_WATER_M(KIDIA:KFDIA,:) = PDECORR_LEN_EDGES_M(KIDIA:KFDIA,:) * 0.5_JPRB 
+!  ENDIF
+
+!  IF (PRESENT(PDECORR_LEN_RATIO)) THEN
+!    PDECORR_LEN_RATIO = 0.5_JPRB
+!  ENDIF
+
+ENDIF
+
+!AI 04 2024
+IF (driver_config%kdecolat == 3) THEN
+  DO jk = 1, klev
+      DO JL = 1, klon
+        IF (pressure_hl(JL,jk)<prmhc) THEN
+          PDECORR_LEN_EDGES_M(JL,jk) = driver_config%high_decorrelation_length
+        ELSE IF (pressure_hl(JL,jk)>=prmhc .AND. pressure_hl(JL,jk)<prlmc) THEN
+          PDECORR_LEN_EDGES_M(JL,jk) = driver_config%mid_decorrelation_length
+        ELSE IF (pressure_hl(JL,jk)>=prlmc) THEN
+          PDECORR_LEN_EDGES_M(JL,jk) = driver_config%low_decorrelation_length
+        ENDIF
+      ENDDO
+  ENDDO
+  
+  ! Both KDECOLAT = 1 and 2 assume that the decorrelation length for
+  ! cloud water content is half that for cloud edges
+!  IF (PRESENT(PDECORR_LEN_WATER_M)) THEN
+!    PDECORR_LEN_WATER_M(KIDIA:KFDIA,:) = PDECORR_LEN_EDGES_M(KIDIA:KFDIA,:) * 0.5_JPRB 
+!  ENDIF
+!  IF (PRESENT(PDECORR_LEN_RATIO)) THEN
+!    PDECORR_LEN_RATIO = 0.5_JPRB
+!  ENDIF
+ENDIF
+!CALL writefield_phy('latitude',latitude_deg,1)
+!CALL writefield_phy('pressure_hl',pressure_hl,klev+1)
+!CALL writefield_phy('Ldecorel',PDECORR_LEN_EDGES_M,klev)
+! -------------------------------------------------------------------
+
+IF (LHOOK) CALL DR_HOOK('CLOUD_OVERLAP_DECORR_LEN',1,ZHOOK_HANDLE)
+
+END SUBROUTINE CALCUL_CLOUD_OVERLAP_DECORR_LEN
Index: DZ6/trunk/libf/phylmd/ecrad/lmdz/radiation_scheme_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/ecrad/lmdz/radiation_scheme_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,1359 +1,0 @@
-! AI mars 2021
-! ====================== Interface between ECRAD and LMDZ ====================
-! Depart de la version IFS R.H 
-! radiation_scheme.F90 appelee dans radlwsw_m.F90 si iflag_rttm = 2
-! revoir toutes les parties avec "AI ATTENTION" 
-! Mars 2021 :
-!             - Revoir toutes les parties commentees AI ATTENTION
-!             1. Traitement des aerosols
-!             2. Verifier les parametres times issus de LMDZ (calcul issed)
-!             3. Configuration a partir de namelist
-!             4. frac_std = 0.75      
-! Juillet 2023 :
-!             
-! ============================================================================
-module interface_lmdz_ecrad
-
-IMPLICIT NONE        
-
-contains
-
-SUBROUTINE RADIATION_SCHEME &
-! Inputs
-     & (KIDIA, KFDIA, KLON, KLEV, KAEROSOL, NSW, &
-     &  namelist_file, ok_3Deffect, &
-     &  debut, ok_volcan, flag_aerosol_strat, &
-     &  IDAY, TIME, &
-     &  PSOLAR_IRRADIANCE, &
-     &  PMU0, PTEMPERATURE_SKIN, &
-     &  PALBEDO_DIF, PALBEDO_DIR, &
-     &  PEMIS, PEMIS_WINDOW, &
-     &  PGELAM, PGEMU, &
-     &  PPRESSURE_H, PTEMPERATURE_H, PQ, PQSAT, &
-     &  PCO2, PCH4, PN2O, PNO2, PCFC11, PCFC12, PHCFC22, &
-     &  PCCL4, PO3, PO2, &
-     &  PCLOUD_FRAC, PQ_LIQUID, PQ_ICE, PQ_SNOW, &
-     &  ZRE_LIQUID_UM, ZRE_ICE_UM, &
-     &  PAEROSOL_OLD, PAEROSOL, &
-! Outputs
-     &  PFLUX_SW, PFLUX_LW, PFLUX_SW_CLEAR, PFLUX_LW_CLEAR, &
-     &  PFLUX_SW_DN, PFLUX_LW_DN, PFLUX_SW_DN_CLEAR, PFLUX_LW_DN_CLEAR, &
-     &  PFLUX_SW_UP, PFLUX_LW_UP, PFLUX_SW_UP_CLEAR, PFLUX_LW_UP_CLEAR, &
-     &  PFLUX_DIR, PFLUX_DIR_CLEAR, PFLUX_DIR_INTO_SUN, &
-     &  PFLUX_UV, PFLUX_PAR, PFLUX_PAR_CLEAR, &
-     &  PEMIS_OUT, PLWDERIVATIVE, &
-     &  PSWDIFFUSEBAND, PSWDIRECTBAND, &
-     &  ecrad_cloud_cover_sw)
-
-!-----------------------------------------------------------------------
-
-! Modules from ifs or ifsaux libraries
-USE PARKIND1 , ONLY : JPIM, JPRB
-USE YOMHOOK  , ONLY : LHOOK, DR_HOOK
-USE RADIATION_SETUP
-USE YOMCST   , ONLY : RSIGMA ! Stefan-Boltzmann constant
-
-! Modules from radiation library
-USE radiation_single_level,   ONLY : single_level_type
-USE radiation_thermodynamics, ONLY : thermodynamics_type
-USE radiation_gas
-USE radiation_cloud,          ONLY : cloud_type
-USE radiation_aerosol,        ONLY : aerosol_type
-USE radiation_flux,           ONLY : flux_type
-USE radiation_interface,      ONLY : radiation, set_gas_units
-USE radiation_save,           ONLY : save_inputs
-
-USE mod_phys_lmdz_para
-
-IMPLICIT NONE
-
-! INPUT ARGUMENTS
-! *** Array dimensions and ranges
-INTEGER(KIND=JPIM),INTENT(IN) :: KIDIA    ! Start column to process
-INTEGER(KIND=JPIM),INTENT(IN) :: KFDIA    ! End column to process
-INTEGER(KIND=JPIM),INTENT(IN) :: KLON     ! Number of columns
-INTEGER(KIND=JPIM),INTENT(IN) :: KLEV     ! Number of levels
-INTEGER(KIND=JPIM),INTENT(IN) :: KAEROSOL
-INTEGER(KIND=JPIM),INTENT(IN) :: NSW ! Numbe of bands
-
-! AI ATTENTION
-!INTEGER, PARAMETER :: KAEROSOL = 12
-
-! *** Single-level fields
-REAL(KIND=JPRB),   INTENT(IN) :: PSOLAR_IRRADIANCE ! (W m-2)
-REAL(KIND=JPRB),   INTENT(IN) :: PMU0(KLON) ! Cosine of solar zenith ang
-REAL(KIND=JPRB),   INTENT(IN) :: PTEMPERATURE_SKIN(KLON) ! (K)
-! Diffuse and direct components of surface shortwave albedo
-!REAL(KIND=JPRB),   INTENT(IN) :: PALBEDO_DIF(KLON,YRERAD%NSW)
-!REAL(KIND=JPRB),   INTENT(IN) :: PALBEDO_DIR(KLON,YRERAD%NSW)
-REAL(KIND=JPRB),   INTENT(IN) :: PALBEDO_DIF(KLON,NSW)
-REAL(KIND=JPRB),   INTENT(IN) :: PALBEDO_DIR(KLON,NSW)
-! Longwave emissivity outside and inside the window region
-REAL(KIND=JPRB),   INTENT(IN) :: PEMIS(KLON)
-REAL(KIND=JPRB),   INTENT(IN) :: PEMIS_WINDOW(KLON)
-! Longitude (radians), sine of latitude
-REAL(KIND=JPRB),   INTENT(IN) :: PGELAM(KLON)
-REAL(KIND=JPRB),   INTENT(IN) :: PGEMU(KLON)
-! Land-sea mask
-!REAL(KIND=JPRB),   INTENT(IN) :: PLAND_SEA_MASK(KLON) 
-
-! *** Variables on half levels
-REAL(KIND=JPRB),   INTENT(IN) :: PPRESSURE_H(KLON,KLEV+1)    ! (Pa)
-REAL(KIND=JPRB),   INTENT(IN) :: PTEMPERATURE_H(KLON,KLEV+1) ! (K)
-
-! *** Gas mass mixing ratios on full levels
-REAL(KIND=JPRB),   INTENT(IN) :: PQ(KLON,KLEV) 
-! AI
-REAL(KIND=JPRB),   INTENT(IN) :: PQSAT(KLON,KLEV)
-REAL(KIND=JPRB),   INTENT(IN) :: PCO2
-REAL(KIND=JPRB),   INTENT(IN) :: PCH4 
-REAL(KIND=JPRB),   INTENT(IN) :: PN2O 
-REAL(KIND=JPRB),   INTENT(IN) :: PNO2 
-REAL(KIND=JPRB),   INTENT(IN) :: PCFC11
-REAL(KIND=JPRB),   INTENT(IN) :: PCFC12
-REAL(KIND=JPRB),   INTENT(IN) :: PHCFC22
-REAL(KIND=JPRB),   INTENT(IN) :: PCCL4
-REAL(KIND=JPRB),   INTENT(IN) :: PO3(KLON,KLEV) ! AI (kg/kg) ATTENTION (Pa*kg/kg) 
-REAL(KIND=JPRB),   INTENT(IN) :: PO2
-
-! *** Cloud fraction and hydrometeor mass mixing ratios
-REAL(KIND=JPRB),   INTENT(IN) :: PCLOUD_FRAC(KLON,KLEV)
-REAL(KIND=JPRB),   INTENT(IN) :: PQ_LIQUID(KLON,KLEV)
-REAL(KIND=JPRB),   INTENT(IN) :: PQ_ICE(KLON,KLEV)
-!REAL(KIND=JPRB),   INTENT(IN) :: PQ_RAIN(KLON,KLEV)
-REAL(KIND=JPRB),   INTENT(IN) :: PQ_SNOW(KLON,KLEV)
-
-! *** Aerosol mass mixing ratios
-REAL(KIND=JPRB),   INTENT(IN) :: PAEROSOL_OLD(KLON,6,KLEV)
-REAL(KIND=JPRB),   INTENT(IN) :: PAEROSOL(KLON,KLEV,KAEROSOL)
-
-!REAL(KIND=JPRB),   INTENT(IN) :: PCCN_LAND(KLON) 
-!REAL(KIND=JPRB),   INTENT(IN) :: PCCN_SEA(KLON) 
-
-!AI mars 2021
-INTEGER(KIND=JPIM), INTENT(IN) :: IDAY
-REAL(KIND=JPRB), INTENT(IN)    :: TIME
-
-! Name of file names specified on command line
-character(len=512), INTENT(IN) :: namelist_file
-logical, INTENT(IN)            :: ok_3Deffect, debut, ok_volcan
-INTEGER(KIND=JPIM), INTENT(IN) :: flag_aerosol_strat
-
-
-! OUTPUT ARGUMENTS
-
-! *** Net fluxes on half-levels (W m-2)
-REAL(KIND=JPRB),  INTENT(OUT) :: PFLUX_SW(KLON,KLEV+1) 
-REAL(KIND=JPRB),  INTENT(OUT) :: PFLUX_LW(KLON,KLEV+1) 
-REAL(KIND=JPRB),  INTENT(OUT) :: PFLUX_SW_CLEAR(KLON,KLEV+1) 
-REAL(KIND=JPRB),  INTENT(OUT) :: PFLUX_LW_CLEAR(KLON,KLEV+1) 
-
-!*** DN and UP flux on half-levels (W m-2)
-REAL(KIND=JPRB),  INTENT(OUT) :: PFLUX_SW_DN(KLON,KLEV+1)
-REAL(KIND=JPRB),  INTENT(OUT) :: PFLUX_LW_DN(KLON,KLEV+1)
-REAL(KIND=JPRB),  INTENT(OUT) :: PFLUX_SW_DN_CLEAR(KLON,KLEV+1)
-REAL(KIND=JPRB),  INTENT(OUT) :: PFLUX_LW_DN_CLEAR(KLON,KLEV+1)
-REAL(KIND=JPRB),  INTENT(OUT) :: PFLUX_SW_UP(KLON,KLEV+1)
-REAL(KIND=JPRB),  INTENT(OUT) :: PFLUX_LW_UP(KLON,KLEV+1)
-REAL(KIND=JPRB),  INTENT(OUT) :: PFLUX_SW_UP_CLEAR(KLON,KLEV+1)
-REAL(KIND=JPRB),  INTENT(OUT) :: PFLUX_LW_UP_CLEAR(KLON,KLEV+1)
-
-! Direct component of surface flux into horizontal plane
-REAL(KIND=JPRB),  INTENT(OUT) :: PFLUX_DIR(KLON)
-REAL(KIND=JPRB),  INTENT(OUT) :: PFLUX_DIR_CLEAR(KLON)
-! As PFLUX_DIR but into a plane perpendicular to the sun
-REAL(KIND=JPRB),  INTENT(OUT) :: PFLUX_DIR_INTO_SUN(KLON)
-
-! *** Ultraviolet and photosynthetically active radiation (W m-2)
-REAL(KIND=JPRB),  INTENT(OUT) :: PFLUX_UV(KLON)
-REAL(KIND=JPRB),  INTENT(OUT) :: PFLUX_PAR(KLON)
-REAL(KIND=JPRB),  INTENT(OUT) :: PFLUX_PAR_CLEAR(KLON)
-
-! Diagnosed longwave surface emissivity across the whole spectrum
-REAL(KIND=JPRB),  INTENT(OUT) :: PEMIS_OUT(KLON)   
-
-! Partial derivative of total-sky longwave upward flux at each level
-! with respect to upward flux at surface, used to correct heating
-! rates at gridpoints/timesteps between calls to the full radiation
-! scheme.  Note that this version uses the convention of level index
-! increasing downwards, unlike the local variable ZLwDerivative that
-! is returned from the LW radiation scheme.
-REAL(KIND=JPRB),  INTENT(OUT) :: PLWDERIVATIVE(KLON,KLEV+1)
-
-! Surface diffuse and direct downwelling shortwave flux in each
-! shortwave albedo band, used in RADINTG to update the surface fluxes
-! accounting for high-resolution albedo information
-REAL(KIND=JPRB),  INTENT(OUT) :: PSWDIFFUSEBAND(KLON,NSW)
-REAL(KIND=JPRB),  INTENT(OUT) :: PSWDIRECTBAND (KLON,NSW)
-
-!AI Nov 2023
-REAL(KIND=JPRB),  INTENT(OUT) :: ecrad_cloud_cover_sw(KLON)
-
-! LOCAL VARIABLES
-! AI ATTENTION
-type(config_type),save         :: rad_config
-!!$OMP THREADPRIVATE(rad_config)
-type(driver_config_type),save  :: driver_config
-!!$OMP THREADPRIVATE(driver_config)
-TYPE(single_level_type)   :: single_level
-TYPE(thermodynamics_type) :: thermodynamics
-TYPE(gas_type)            :: gas
-TYPE(cloud_type)          :: cloud
-TYPE(aerosol_type)        :: aerosol
-TYPE(flux_type)           :: flux
-
-! Mass mixing ratio of ozone (kg/kg)
-REAL(KIND=JPRB)           :: ZO3(KLON,KLEV)
-
-! Cloud effective radii in microns
-REAL(KIND=JPRB)           :: ZRE_LIQUID_UM(KLON,KLEV)
-REAL(KIND=JPRB)           :: ZRE_ICE_UM(KLON,KLEV)
-
-! Cloud overlap decorrelation length for cloud boundaries in km
-REAL(KIND=JPRB)           :: ZDECORR_LEN_M
-REAL(KIND=JPRB)           :: ZDECORR_LEN_M_1D(KLON)
-REAL(KIND=JPRB)           :: ZDECORR_LEN_M_2D(KLON,KLEV)
-
-! Ratio of cloud overlap decorrelation length for cloud water
-! inhomogeneities to that for cloud boundaries (typically 0.5)
-!REAL(KIND=JPRB)           :: ZDECORR_LEN_RATIO = 0.5_jprb
-
-! The surface net longwave flux if the surface was a black body, used
-! to compute the effective broadband surface emissivity
-REAL(KIND=JPRB)           :: ZBLACK_BODY_NET_LW(KIDIA:KFDIA)
-
-! Layer mass in kg m-2
-REAL(KIND=JPRB)           :: ZLAYER_MASS(KIDIA:KFDIA,KLEV)
-
-! Time integers
-INTEGER :: ITIM
-
-! Loop indices
-INTEGER :: JLON, JLEV, JBAND, JB_ALBEDO, JAER
-
-REAL(KIND=JPRB) :: ZHOOK_HANDLE
-
-! AI ATTENTION traitement aerosols
-INTEGER, PARAMETER :: NAERMACC = 1
-
-logical :: loutput=.true.
-logical :: lprint_input=.false.
-logical :: lprint_config=.false.
-logical, save :: debut_ecrad=.true.
-!$OMP THREADPRIVATE(debut_ecrad)
-integer, save :: itap_ecrad=0
-!$OMP THREADPRIVATE(itap_ecrad)
-
-REAL(KIND=JPRB) ::  inv_cloud_effective_size(KLON,KLEV)
-REAL(KIND=JPRB) ::  inv_inhom_effective_size(KLON,KLEV)
-
-integer :: irang
-
-
-IF (LHOOK) CALL DR_HOOK('RADIATION_SCHEME',0,ZHOOK_HANDLE)
-
-  print*,'Entree radiation_scheme, ok_3Deffect, namelist_file = ', &
-          ok_3Deffect, namelist_file
-! A.I juillet 2023 : 
-! Initialisation dans radiation_setup au 1er passage dans Ecrad
-!$OMP MASTER
-  if (debut_ecrad) then
-   call SETUP_RADIATION_SCHEME(loutput,namelist_file,rad_config,driver_config)
-   debut_ecrad=.false. 
-  endif 
-!$OMP END MASTER
-!$OMP BARRIER 
-! Fin partie initialisation et configuration 
-
-!AI print fichiers namelist utilise
-!if (is_omp_root) then
-! itap_ecrad=itap_ecrad+1
-! print*,'Dans radiation_scheme itap_ecrad, mpi_rank, omp_rank, namelist_file : ', &
-!         itap_ecrad, mpi_rank, omp_rank, namelist_file
-!else
-! print*,'mpi_rank omp_rank, namelist_file :', mpi_rank, omp_rank, namelist_file
-!endif
-
-! AI 11 23 Allocates depplaces au debut
-print*,'*********** ALLOCATES *******************************'
-! AI ATTENTION
-! Allocate memory in radiation objects
-! emissivite avec une seule bande
-CALL single_level%allocate(KLON, NSW, 1, &
-     &                     use_sw_albedo_direct=.TRUE.)
-CALL thermodynamics%allocate(KLON, KLEV, use_h2o_sat=.true.)
-CALL cloud%allocate(KLON, KLEV)
-CALL aerosol%allocate(KLON, 1, KLEV, KAEROSOL)
-CALL gas%allocate(KLON, KLEV)
-CALL flux%allocate(rad_config, 1, KLON, KLEV)
-
-print*,'************* THERMO (input) ************************************'
-! AI
-! pressure_hl > paprs
-! temperature_hl calculee dans radlsw de la meme facon que pour RRTM
-thermodynamics%pressure_hl   (KIDIA:KFDIA,:) = PPRESSURE_H   (KIDIA:KFDIA,:)
-thermodynamics%temperature_hl(KIDIA:KFDIA,:) = PTEMPERATURE_H(KIDIA:KFDIA,:)
-!print*,'Compute saturation specific humidity'
-! Compute saturation specific humidity, used to hydrate aerosols. The
-! "2" for the last argument indicates that the routine is not being
-! called from within the convection scheme.
-!CALL SATUR(KIDIA, KFDIA, KLON, 1, KLEV, &
-!     &  PPRESSURE, PTEMPERATURE, thermodynamics%h2o_sat_liq, 2)
-! Alternative approximate version using temperature and pressure from
-! the thermodynamics structure
-!CALL thermodynamics%calc_saturation_wrt_liquid(KIDIA, KFDIA)
-!AI ATTENTION
-thermodynamics%h2o_sat_liq = PQSAT
-
-print*,'********** SINGLE LEVEL VARS **********************************'
-!AI ATTENTION
-! Set single-level fileds
-single_level%solar_irradiance              = PSOLAR_IRRADIANCE
-single_level%cos_sza(KIDIA:KFDIA)          = PMU0(KIDIA:KFDIA)
-single_level%skin_temperature(KIDIA:KFDIA) = PTEMPERATURE_SKIN(KIDIA:KFDIA)
-single_level%sw_albedo(KIDIA:KFDIA,:)      = PALBEDO_DIF(KIDIA:KFDIA,:)
-single_level%sw_albedo_direct(KIDIA:KFDIA,:)=PALBEDO_DIR(KIDIA:KFDIA,:)
-single_level%lw_emissivity(KIDIA:KFDIA,1)  = PEMIS(KIDIA:KFDIA)
-!single_level%lw_emissivity(KIDIA:KFDIA,2)  = PEMIS_WINDOW(KIDIA:KFDIA)
-
-! Create the relevant seed from date and time get the starting day
-! and number of minutes since start
-!IDAY = NDD(NINDAT)
-!cur_day
-!ITIM = NINT(NSTEP * YRRIP%TSTEP / 60.0_JPRB)
-!ITIM = NINT(TIME / 60.0_JPRB)
-!current_time
-!allocate(single_level%iseed(KIDIA:KFDIA))
-!DO JLON = KIDIA, KFDIA
-  ! This method gives a unique value for roughly every 1-km square
-  ! on the globe and every minute.  ASIN(PGEMU)*60 gives rough
-  ! latitude in degrees, which we multiply by 100 to give a unique
-  ! value for roughly every km. PGELAM*60*100 gives a unique number
-  ! for roughly every km of longitude around the equator, which we
-  ! multiply by 180*100 so there is no overlap with the latitude
-  ! values.  The result can be contained in a 32-byte integer (but
-  ! since random numbers are generated with the help of integer
-  ! overflow, it should not matter if the number did overflow).
-!  single_level%iseed(JLON) = ITIM + IDAY & 
-!       &  +  NINT(PGELAM(JLON)*108000000.0_JPRB &
-!       &          + ASIN(PGEMU(JLON))*6000.0_JPRB)
-!ENDDO
-!AI Nov 23
-! Simple initialization of the seeds for the Monte Carlo scheme
-call single_level%init_seed_simple(kidia, kfdia)
-
-print*,'********** CLOUDS (allocate + input) *******************************************'
-!print*,'Appel Allocate clouds'
-! Set cloud fields
-cloud%q_liq(KIDIA:KFDIA,:)    = PQ_LIQUID(KIDIA:KFDIA,:)
-cloud%q_ice(KIDIA:KFDIA,:)    = PQ_ICE(KIDIA:KFDIA,:) + PQ_SNOW(KIDIA:KFDIA,:)
-cloud%fraction(KIDIA:KFDIA,:) = PCLOUD_FRAC(KIDIA:KFDIA,:)
-!!! ok AI ATTENTION a voir avec JL
-! Compute effective radi and convert to metres
-! AI. : on passe directement les champs de LMDZ
-cloud%re_liq(KIDIA:KFDIA,:) = ZRE_LIQUID_UM(KIDIA:KFDIA,:)
-cloud%re_ice(KIDIA:KFDIA,:) = ZRE_ICE_UM(KIDIA:KFDIA,:)
-! Get the cloud overlap decorrelation length (for cloud boundaries),
-! in km, according to the parameterization specified by NDECOLAT,
-! and insert into the "cloud" object. Also get the ratio of
-! decorrelation lengths for cloud water content inhomogeneities and
-! cloud boundaries, and set it in the "rad_config" object.
-! IFS :
-!CALL CLOUD_OVERLAP_DECORR_LEN(KIDIA, KFDIA, KLON, PGEMU, YRERAD%NDECOLAT, &
-!     &    ZDECORR_LEN_KM, PDECORR_LEN_RATIO=ZDECORR_LEN_RATIO)
-CALL CALCUL_CLOUD_OVERLAP_DECORR_LEN &
-     & (KIDIA, KFDIA, KLON, KLEV, &
-     &  driver_config, &
-     &  thermodynamics%pressure_hl, &
-     &  ZDECORR_LEN_M_2D)
-
- if (driver_config%kdecolat.eq.0) then
-  ZDECORR_LEN_M = ZDECORR_LEN_M_2D(1,1)       
-  DO JLON = KIDIA,KFDIA
-   CALL cloud%set_overlap_param(thermodynamics, &
-       &                 ZDECORR_LEN_M, &
-       &                 istartcol=JLON, iendcol=JLON)
-  ENDDO
- else if (driver_config%kdecolat.eq.1.or.driver_config%kdecolat.eq.2) then
-  ZDECORR_LEN_M_1D = ZDECORR_LEN_M_2D(:,1)
-  DO JLON = KIDIA,KFDIA
-   CALL cloud%set_overlap_param(thermodynamics, &
-       &                 ZDECORR_LEN_M_1D, &
-       &                 istartcol=JLON, iendcol=JLON)
-  ENDDO
- else if (driver_config%kdecolat.eq.3) then
-  DO JLON = KIDIA,KFDIA
-   CALL cloud%set_overlap_param_var2D(thermodynamics, &
-       &                 ZDECORR_LEN_M_2D, KLEV, &
-       &                 istartcol=JLON, iendcol=JLON)
-  ENDDO
- endif
-
-
-
-! IFS :
-! Cloud water content fractional standard deviation is configurable
-! from namelist NAERAD but must be globally constant. Before it was
-! hard coded at 1.0.
-!CALL cloud%create_fractional_std(KLON, KLEV, YRERAD%RCLOUD_FRAC_STD)
-! AI ATTENTION frac_std=0.75 meme valeur que dans la version offline
-CALL cloud%create_fractional_std(KLON, KLEV, driver_config%frac_std)
-
-!if (ok_3Deffect) then
-! if (driver_config%ok_effective_size) then
-!     call cloud%create_inv_cloud_effective_size_eta(klon, klev, &
-!               &  thermodynamics%pressure_hl, &
-!               &  driver_config%low_inv_effective_size, &
-!               &  driver_config%middle_inv_effective_size, &
-!               &  driver_config%high_inv_effective_size, 0.8_jprb, 0.45_jprb, &
-!               &  KIDIA, KFDIA)
-!   else if (driver_config%ok_separation) then
-!     call cloud%param_cloud_effective_separation_eta(klon, klev, &
-!               &  thermodynamics%pressure_hl, &
-!               &  driver_config%cloud_separation_scale_surface, &
-!               &  driver_config%cloud_separation_scale_toa, &
-!               &  driver_config%cloud_separation_scale_power, &
-!               &  driver_config%cloud_inhom_separation_factor, &
-!               &  KIDIA, KFDIA)
-!   endif     
-! else  
- if (rad_config%i_solver_sw == ISolverSPARTACUS &
-      & .or.   rad_config%i_solver_lw == ISolverSPARTACUS) then
-   ! AI ! Read cloud properties needed by SPARTACUS
-   if (driver_config%ok_effective_size) then
-     call cloud%create_inv_cloud_effective_size_eta(klon, klev, &
-               &  thermodynamics%pressure_hl, &
-               &  driver_config%low_inv_effective_size, &
-               &  driver_config%middle_inv_effective_size, &
-               &  driver_config%high_inv_effective_size, 0.8_jprb, 0.45_jprb, &
-               &  KIDIA, KFDIA)
-   else if (driver_config%ok_separation) then
-     call cloud%param_cloud_effective_separation_eta(klon, klev, &
-               &  thermodynamics%pressure_hl, &
-               &  driver_config%cloud_separation_scale_surface, &
-               &  driver_config%cloud_separation_scale_toa, &
-               &  driver_config%cloud_separation_scale_power, &
-               &  driver_config%cloud_inhom_separation_factor, &
-               &  KIDIA, KFDIA)
-   endif
- endif  
-!endif
-
-print*,'******** AEROSOLS (input) **************************************'
-!IF (NAERMACC > 0) THEN
-!ELSE
-!  CALL aerosol%allocate(KLON, 1, KLEV, 6) ! Tegen climatology
-!ENDIF
-! Compute the dry mass of each layer neglecting humidity effects, in
-! kg m-2, needed to scale some of the aerosol inputs
-! AI commente ATTENTION
-!CALL thermodynamics%get_layer_mass(ZLAYER_MASS)
-
-! Copy over aerosol mass mixing ratio
-!IF (NAERMACC > 0) THEN
-
-  ! MACC aerosol climatology - this is already in mass mixing ratio
-  ! units with the required array orientation so we can copy it over
-  ! directly
-  aerosol%mixing_ratio(KIDIA:KFDIA,:,:) = PAEROSOL(KIDIA:KFDIA,:,:)
-
-  ! Add the tropospheric and stratospheric backgrounds contained in the
-  ! old Tegen arrays - this is very ugly!
-! AI ATTENTION
-!  IF (TROP_BG_AER_MASS_EXT > 0.0_JPRB) THEN
-!    aerosol%mixing_ratio(KIDIA:KFDIA,:,ITYPE_TROP_BG_AER) &
-!         &  = aerosol%mixing_ratio(KIDIA:KFDIA,:,ITYPE_TROP_BG_AER) &
-!         &  + PAEROSOL_OLD(KIDIA:KFDIA,1,:) &
-!         &  / (ZLAYER_MASS * TROP_BG_AER_MASS_EXT)
-!  ENDIF
-!  IF (STRAT_BG_AER_MASS_EXT > 0.0_JPRB) THEN
-!    aerosol%mixing_ratio(KIDIA:KFDIA,:,ITYPE_STRAT_BG_AER) &
-!         &  = aerosol%mixing_ratio(KIDIA:KFDIA,:,ITYPE_STRAT_BG_AER) &
-!         &  + PAEROSOL_OLD(KIDIA:KFDIA,6,:) &
-!         &  / (ZLAYER_MASS * STRAT_BG_AER_MASS_EXT)
-!  ENDIF
-
-!ELSE
-
-  ! Tegen aerosol climatology - the array PAEROSOL_OLD contains the
-  ! 550-nm optical depth in each layer. The optics data file
-  ! aerosol_ifs_rrtm_tegen.nc does not contain mass extinction
-  ! coefficient, but a scaling factor that the 550-nm optical depth
-  ! should be multiplied by to obtain the optical depth in each
-  ! spectral band.  Therefore, in order for the units to work out, we
-  ! need to divide by the layer mass (in kg m-2) to obtain the 550-nm
-  ! cross-section per unit mass of dry air (so in m2 kg-1).  We also
-  ! need to permute the array.
-!  DO JLEV = 1,KLEV
-!    DO JAER = 1,6
-!      aerosol%mixing_ratio(KIDIA:KFDIA,JLEV,JAER) &
-!         &  = PAEROSOL_OLD(KIDIA:KFDIA,JAER,JLEV) &
-!         &  / ZLAYER_MASS(KIDIA:KFDIA,JLEV)
-!    ENDDO
-!  ENDDO
-!ENDIF
-
-print*,'********** GAS (input) ************************************************'
-!print*,'Appel Allocate gas'
-! Convert ozone Pa*kg/kg to kg/kg
-! AI ATTENTION
-!DO JLEV = 1,KLEV
-!  DO JLON = KIDIA,KFDIA
-!    ZO3(JLON,JLEV) = PO3_DP(JLON,JLEV) &
-!         &         / (PPRESSURE_H(JLON,JLEV+1)-PPRESSURE_H(JLON,JLEV))
-!  ENDDO
-!ENDDO
-!  Insert gas mixing ratios
-!print*,'Insert gas mixing ratios'
-CALL gas%put(IH2O,    IMassMixingRatio, PQ)
-CALL gas%put(IO3,     IMassMixingRatio, PO3)
-CALL gas%put_well_mixed(ICO2,    IMAssMixingRatio, PCO2)
-CALL gas%put_well_mixed(ICH4,    IMassMixingRatio, PCH4)
-CALL gas%put_well_mixed(IN2O,    IMassMixingRatio, PN2O)
-CALL gas%put_well_mixed(ICFC11,  IMassMixingRatio, PCFC11)
-CALL gas%put_well_mixed(ICFC12,  IMassMixingRatio, PCFC12)
-CALL gas%put_well_mixed(IHCFC22, IMassMixingRatio, PHCFC22)
-CALL gas%put_well_mixed(ICCL4,   IMassMixingRatio, PCCL4)
-CALL gas%put_well_mixed(IO2,     IMassMixingRatio, PO2)
-! Ensure the units of the gas mixing ratios are what is required by
-! the gas absorption model
-call set_gas_units(rad_config, gas)
-
-! Call radiation scheme
-!print*,'*** Appel radiation *** namelist **** omp_rank ****', &
-!         omp_rank, namelist_file
-!   if (rad_config%i_solver_sw == ISolverSPARTACUS) then 
-!    if (driver_config%ok_separation) then
-!      print*,'Avant radiation, mpi_rank, omp_rank, size, chape inv_cloud = ',&
-!              mpi_rank, omp_rank, &
-!              shape(cloud%inv_cloud_effective_size), &
-!              size(cloud%inv_cloud_effective_size)      
-!      do jlon=KIDIA, KFDIA      
-!        do jlev=1,klev
-!         print*,' Avant radiation mpi_rank, omp_rank, jlon, jlev, &
-!            &     cloud%inv_cloud_effective_size =', mpi_rank, &
-!            &     omp_rank, jlon, jlev, &
-!            &     cloud%inv_cloud_effective_size(jlon,jlev)
-!        enddo
-!      enddo
-!       cloud%inv_cloud_effective_size=inv_cloud_effective_size
-!       cloud%inv_inhom_effective_size=inv_inhom_effective_size
-!    endif
-!   endif
-CALL radiation(KLON, KLEV, KIDIA, KFDIA, rad_config, &
-     &  single_level, thermodynamics, gas, cloud, aerosol, flux)
-
- if (rad_config%use_aerosols) then
-    if (rad_config%i_gas_model_sw == IGasModelIFSRRTMG .or. &
-     &  rad_config%i_gas_model_lw == IGasModelIFSRRTMG) then     
-       CALL aeropt_5wv_ecrad(kidia, kfdia, 1, klev,     &
-     &                       rad_config,thermodynamics, aerosol)
-    endif                 
-
-    if (flag_aerosol_strat.eq.2) then
-       CALL readaerosolstrato_ecrad(rad_config, debut, ok_volcan)
-    endif
- endif               
-
-print*,'*********** Sortie flux ****************'
-! Cloud cover
-ecrad_cloud_cover_sw = flux%cloud_cover_sw
-! Compute required output fluxes
-! DN and UP flux
-PFLUX_SW_DN(KIDIA:KFDIA,:) = flux%sw_dn(KIDIA:KFDIA,:)
-PFLUX_SW_UP(KIDIA:KFDIA,:) = flux%sw_up(KIDIA:KFDIA,:)
-PFLUX_LW_DN(KIDIA:KFDIA,:) = flux%lw_dn(KIDIA:KFDIA,:)
-PFLUX_LW_UP(KIDIA:KFDIA,:) = flux%lw_up(KIDIA:KFDIA,:)
-PFLUX_SW_DN_CLEAR(KIDIA:KFDIA,:) = flux%sw_dn_clear(KIDIA:KFDIA,:)
-PFLUX_SW_UP_CLEAR(KIDIA:KFDIA,:) = flux%sw_up_clear(KIDIA:KFDIA,:)
-PFLUX_LW_DN_CLEAR(KIDIA:KFDIA,:) = flux%lw_dn_clear(KIDIA:KFDIA,:)
-PFLUX_LW_UP_CLEAR(KIDIA:KFDIA,:) = flux%lw_up_clear(KIDIA:KFDIA,:)
-! First the net fluxes
-PFLUX_SW(KIDIA:KFDIA,:) = flux%sw_dn(KIDIA:KFDIA,:) - flux%sw_up(KIDIA:KFDIA,:)
-PFLUX_LW(KIDIA:KFDIA,:) = flux%lw_dn(KIDIA:KFDIA,:) - flux%lw_up(KIDIA:KFDIA,:)
-PFLUX_SW_CLEAR(KIDIA:KFDIA,:) &
-     &  = flux%sw_dn_clear(KIDIA:KFDIA,:) - flux%sw_up_clear(KIDIA:KFDIA,:)
-PFLUX_LW_CLEAR(KIDIA:KFDIA,:) &
-     &  = flux%lw_dn_clear(KIDIA:KFDIA,:) - flux%lw_up_clear(KIDIA:KFDIA,:)
-! Now the surface fluxes
-!PFLUX_SW_DN_SURF(KIDIA:KFDIA) = flux%sw_dn(KIDIA:KFDIA,KLEV+1)
-!PFLUX_LW_DN_SURF(KIDIA:KFDIA) = flux%lw_dn(KIDIA:KFDIA,KLEV+1)
-!PFLUX_SW_UP_SURF(KIDIA:KFDIA) = flux%sw_up(KIDIA:KFDIA,KLEV+1)
-!PFLUX_LW_UP_SURF(KIDIA:KFDIA) = flux%lw_up(KIDIA:KFDIA,KLEV+1)
-!PFLUX_SW_DN_CLEAR_SURF(KIDIA:KFDIA) = flux%sw_dn_clear(KIDIA:KFDIA,KLEV+1)
-!PFLUX_LW_DN_CLEAR_SURF(KIDIA:KFDIA) = flux%lw_dn_clear(KIDIA:KFDIA,KLEV+1)
-!PFLUX_SW_UP_CLEAR_SURF(KIDIA:KFDIA) = flux%sw_up_clear(KIDIA:KFDIA,KLEV+1)
-!PFLUX_LW_UP_CLEAR_SURF(KIDIA:KFDIA) = flux%lw_up_clear(KIDIA:KFDIA,KLEV+1)
-PFLUX_DIR(KIDIA:KFDIA) = flux%sw_dn_direct(KIDIA:KFDIA,KLEV+1)
-PFLUX_DIR_CLEAR(KIDIA:KFDIA) = flux%sw_dn_direct_clear(KIDIA:KFDIA,KLEV+1)
-PFLUX_DIR_INTO_SUN(KIDIA:KFDIA) = 0.0_JPRB
-WHERE (PMU0(KIDIA:KFDIA) > EPSILON(1.0_JPRB))
-  PFLUX_DIR_INTO_SUN(KIDIA:KFDIA) = PFLUX_DIR(KIDIA:KFDIA) / PMU0(KIDIA:KFDIA)
-END WHERE
-! Top-of-atmosphere downwelling flux
-!PFLUX_SW_DN_TOA(KIDIA:KFDIA) = flux%sw_dn(KIDIA:KFDIA,1)
-!PFLUX_SW_UP_TOA(KIDIA:KFDIA) = flux%sw_up(KIDIA:KFDIA,1)
-!PFLUX_LW_DN_TOA(KIDIA:KFDIA) = flux%lw_dn(KIDIA:KFDIA,1)
-!PFLUX_LW_UP_TOA(KIDIA:KFDIA) = flux%lw_up(KIDIA:KFDIA,1)
-!AI ATTENTION
-if (0.eq.1) then
-PFLUX_UV       (KIDIA:KFDIA) = 0.0_JPRB
-DO JBAND = 1,NWEIGHT_UV
-  PFLUX_UV(KIDIA:KFDIA) = PFLUX_UV(KIDIA:KFDIA) + WEIGHT_UV(JBAND) &
-       &  * flux%sw_dn_surf_band(IBAND_UV(JBAND),KIDIA:KFDIA)
-ENDDO
-! Compute photosynthetically active radiation similarly
-PFLUX_PAR      (KIDIA:KFDIA) = 0.0_JPRB
-PFLUX_PAR_CLEAR(KIDIA:KFDIA) = 0.0_JPRB
-DO JBAND = 1,NWEIGHT_PAR
-  PFLUX_PAR(KIDIA:KFDIA) = PFLUX_PAR(KIDIA:KFDIA) + WEIGHT_PAR(JBAND) &
-       &  * flux%sw_dn_surf_band(IBAND_PAR(JBAND),KIDIA:KFDIA)
-  PFLUX_PAR_CLEAR(KIDIA:KFDIA) = PFLUX_PAR_CLEAR(KIDIA:KFDIA) &
-       &  + WEIGHT_PAR(JBAND) &
-       &  * flux%sw_dn_surf_clear_band(IBAND_PAR(JBAND),KIDIA:KFDIA)
-ENDDO
-endif
-! Compute effective broadband emissivity
-ZBLACK_BODY_NET_LW = flux%lw_dn(KIDIA:KFDIA,KLEV+1) &
-     &  - RSIGMA*PTEMPERATURE_SKIN(KIDIA:KFDIA)**4
-PEMIS_OUT(KIDIA:KFDIA) = PEMIS(KIDIA:KFDIA)
-WHERE (ABS(ZBLACK_BODY_NET_LW) > 1.0E-5) 
-  PEMIS_OUT(KIDIA:KFDIA) = PFLUX_LW(KIDIA:KFDIA,KLEV+1) / ZBLACK_BODY_NET_LW
-END WHERE
-! Copy longwave derivatives
-! AI ATTENTION
-!IF (YRERAD%LAPPROXLWUPDATE) THEN
-IF (rad_config%do_lw_derivatives) THEN
-  PLWDERIVATIVE(KIDIA:KFDIA,:) = flux%lw_derivatives(KIDIA:KFDIA,:)
-END IF
-! Store the shortwave downwelling fluxes in each albedo band
-!AI ATTENTION
-!IF (YRERAD%LAPPROXSWUPDATE) THEN
-if (0.eq.1) then
-IF (rad_config%do_surface_sw_spectral_flux) THEN
-  PSWDIFFUSEBAND(KIDIA:KFDIA,:) = 0.0_JPRB
-  PSWDIRECTBAND (KIDIA:KFDIA,:) = 0.0_JPRB
-  DO JBAND = 1,rad_config%n_bands_sw
-    JB_ALBEDO = rad_config%i_albedo_from_band_sw(JBAND)
-    DO JLON = KIDIA,KFDIA
-      PSWDIFFUSEBAND(JLON,JB_ALBEDO) = PSWDIFFUSEBAND(JLON,JB_ALBEDO) &
-           &  + flux%sw_dn_surf_band(JBAND,JLON) &
-           &  - flux%sw_dn_direct_surf_band(JBAND,JLON)
-      PSWDIRECTBAND(JLON,JB_ALBEDO)  = PSWDIRECTBAND(JLON,JB_ALBEDO) &
-           &  + flux%sw_dn_direct_surf_band(JBAND,JLON)
-    ENDDO
-  ENDDO
-ENDIF
-endif
-
-print*,'********** DEALLOCATIONS ************************'
-CALL single_level%deallocate
-CALL thermodynamics%deallocate
-CALL gas%deallocate
-CALL cloud%deallocate
-CALL aerosol%deallocate
-CALL flux%deallocate
-
-IF (LHOOK) CALL DR_HOOK('RADIATION_SCHEME',1,ZHOOK_HANDLE)
-
-END SUBROUTINE RADIATION_SCHEME
-
-SUBROUTINE RADIATION_SCHEME_S2 &
-! Inputs
-     & (KIDIA, KFDIA, KLON, KLEV, KAEROSOL, NSW, &
-     &  namelist_file, ok_3Deffect, &
-     &  debut, ok_volcan, flag_aerosol_strat, &
-     &  IDAY, TIME, &
-     &  PSOLAR_IRRADIANCE, &
-     &  PMU0, PTEMPERATURE_SKIN, &
-     &  PALBEDO_DIF, PALBEDO_DIR, &
-     &  PEMIS, PEMIS_WINDOW, &
-     &  PGELAM, PGEMU, &
-     &  PPRESSURE_H, PTEMPERATURE_H, PQ, PQSAT, &
-     &  PCO2, PCH4, PN2O, PNO2, PCFC11, PCFC12, PHCFC22, &
-     &  PCCL4, PO3, PO2, &
-     &  PCLOUD_FRAC, PQ_LIQUID, PQ_ICE, PQ_SNOW, &
-     &  ZRE_LIQUID_UM, ZRE_ICE_UM, &
-     &  PAEROSOL_OLD, PAEROSOL, &
-! Outputs
-     &  PFLUX_SW, PFLUX_LW, PFLUX_SW_CLEAR, PFLUX_LW_CLEAR, &
-     &  PFLUX_SW_DN, PFLUX_LW_DN, PFLUX_SW_DN_CLEAR, PFLUX_LW_DN_CLEAR, &
-     &  PFLUX_SW_UP, PFLUX_LW_UP, PFLUX_SW_UP_CLEAR, PFLUX_LW_UP_CLEAR, &
-     &  PFLUX_DIR, PFLUX_DIR_CLEAR, PFLUX_DIR_INTO_SUN, &
-     &  PFLUX_UV, PFLUX_PAR, PFLUX_PAR_CLEAR, &
-     &  PEMIS_OUT, PLWDERIVATIVE, &
-     &  PSWDIFFUSEBAND, PSWDIRECTBAND, &
-     &  ecrad_cloud_cover_sw)
-
-! RADIATION_SCHEME - Interface to modular radiation scheme
-!
-! (C) Copyright 2015- ECMWF.
-!
-! This software is licensed under the terms of the Apache Licence Version 2.0
-! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0.
-!
-! In applying this licence, ECMWF does not waive the privileges and immunities
-! granted to it by virtue of its status as an intergovernmental organisation
-! nor does it submit to any jurisdiction.
-!
-! PURPOSE
-! -------
-!   The modular radiation scheme is contained in a separate
-!   library. This routine puts the the IFS arrays into appropriate
-!   objects, computing the additional data that is required, and sends
-!   it to the radiation scheme.  It returns net fluxes and surface
-!   flux components needed by the rest of the model. 
-!
-!   Lower case is used for variables and types taken from the
-!   radiation library
-!
-! INTERFACE
-! ---------
-!    RADIATION_SCHEME is called from RADLSWR. The
-!    SETUP_RADIATION_SCHEME routine (in the RADIATION_SETUP module)
-!    should have been run first.
-!
-! AUTHOR
-! ------
-!   Robin Hogan, ECMWF
-!   Original: 2015-09-16
-!
-! MODIFICATIONS
-! -------------
-!
-! TO DO
-! -----
-!
-!-----------------------------------------------------------------------
-
-! Modules from ifs or ifsaux libraries
-USE PARKIND1 , ONLY : JPIM, JPRB
-USE YOMHOOK  , ONLY : LHOOK, DR_HOOK
-USE RADIATION_SETUP
-USE YOMCST   , ONLY : RSIGMA ! Stefan-Boltzmann constant
-!USE RADIATION_SETUP, ONLY : SETUP_RADIATION_SCHEME, &
-!                         &  config_type, driver_config_type, &
-!                         &  NWEIGHT_UV,  IBAND_UV,  WEIGHT_UV, &
-!                         &  NWEIGHT_PAR, IBAND_PAR, WEIGHT_PAR, &
-!                         &  ITYPE_TROP_BG_AER,  TROP_BG_AER_MASS_EXT, &
-!                         &  ITYPE_STRAT_BG_AER, STRAT_BG_AER_MASS_EXT, &
-!                         &  ISolverSpartacus
-
-! Modules from radiation library
-USE radiation_single_level,   ONLY : single_level_type
-USE radiation_thermodynamics, ONLY : thermodynamics_type
-USE radiation_gas
-USE radiation_cloud,          ONLY : cloud_type
-USE radiation_aerosol,        ONLY : aerosol_type
-USE radiation_flux,           ONLY : flux_type
-USE radiation_interface,      ONLY : radiation, set_gas_units
-USE radiation_save,           ONLY : save_inputs
-
-USE mod_phys_lmdz_para
-
-IMPLICIT NONE
-
-! INPUT ARGUMENTS
-! *** Array dimensions and ranges
-INTEGER(KIND=JPIM),INTENT(IN) :: KIDIA    ! Start column to process
-INTEGER(KIND=JPIM),INTENT(IN) :: KFDIA    ! End column to process
-!INTEGER, INTENT(IN) :: KIDIA, KFDIA
-INTEGER(KIND=JPIM),INTENT(IN) :: KLON     ! Number of columns
-INTEGER(KIND=JPIM),INTENT(IN) :: KLEV     ! Number of levels
-!INTEGER, INTENT(IN) :: KLON, KLEV
-!INTEGER(KIND=JPIM),INTENT(IN) :: KAEROLMDZ ! Number of aerosol types
-INTEGER(KIND=JPIM),INTENT(IN) :: KAEROSOL
-INTEGER(KIND=JPIM),INTENT(IN) :: NSW ! Numbe of bands
-
-! AI ATTENTION
-!INTEGER, PARAMETER :: KAEROSOL = 12
-
-! *** Single-level fields
-REAL(KIND=JPRB),   INTENT(IN) :: PSOLAR_IRRADIANCE ! (W m-2)
-REAL(KIND=JPRB),   INTENT(IN) :: PMU0(KLON) ! Cosine of solar zenith ang
-REAL(KIND=JPRB),   INTENT(IN) :: PTEMPERATURE_SKIN(KLON) ! (K)
-! Diffuse and direct components of surface shortwave albedo
-!REAL(KIND=JPRB),   INTENT(IN) :: PALBEDO_DIF(KLON,YRERAD%NSW)
-!REAL(KIND=JPRB),   INTENT(IN) :: PALBEDO_DIR(KLON,YRERAD%NSW)
-REAL(KIND=JPRB),   INTENT(IN) :: PALBEDO_DIF(KLON,NSW)
-REAL(KIND=JPRB),   INTENT(IN) :: PALBEDO_DIR(KLON,NSW)
-! Longwave emissivity outside and inside the window region
-REAL(KIND=JPRB),   INTENT(IN) :: PEMIS(KLON)
-REAL(KIND=JPRB),   INTENT(IN) :: PEMIS_WINDOW(KLON)
-! Longitude (radians), sine of latitude
-REAL(KIND=JPRB),   INTENT(IN) :: PGELAM(KLON)
-REAL(KIND=JPRB),   INTENT(IN) :: PGEMU(KLON)
-! Land-sea mask
-!REAL(KIND=JPRB),   INTENT(IN) :: PLAND_SEA_MASK(KLON) 
-
-! *** Variables on half levels
-REAL(KIND=JPRB),   INTENT(IN) :: PPRESSURE_H(KLON,KLEV+1)    ! (Pa)
-REAL(KIND=JPRB),   INTENT(IN) :: PTEMPERATURE_H(KLON,KLEV+1) ! (K)
-
-! *** Gas mass mixing ratios on full levels
-REAL(KIND=JPRB),   INTENT(IN) :: PQ(KLON,KLEV) 
-! AI
-REAL(KIND=JPRB),   INTENT(IN) :: PQSAT(KLON,KLEV)
-REAL(KIND=JPRB),   INTENT(IN) :: PCO2
-REAL(KIND=JPRB),   INTENT(IN) :: PCH4 
-REAL(KIND=JPRB),   INTENT(IN) :: PN2O 
-REAL(KIND=JPRB),   INTENT(IN) :: PNO2 
-REAL(KIND=JPRB),   INTENT(IN) :: PCFC11
-REAL(KIND=JPRB),   INTENT(IN) :: PCFC12
-REAL(KIND=JPRB),   INTENT(IN) :: PHCFC22
-REAL(KIND=JPRB),   INTENT(IN) :: PCCL4
-REAL(KIND=JPRB),   INTENT(IN) :: PO3(KLON,KLEV) ! AI (kg/kg) ATTENTION (Pa*kg/kg) 
-REAL(KIND=JPRB),   INTENT(IN) :: PO2
-
-! *** Cloud fraction and hydrometeor mass mixing ratios
-REAL(KIND=JPRB),   INTENT(IN) :: PCLOUD_FRAC(KLON,KLEV)
-REAL(KIND=JPRB),   INTENT(IN) :: PQ_LIQUID(KLON,KLEV)
-REAL(KIND=JPRB),   INTENT(IN) :: PQ_ICE(KLON,KLEV)
-!REAL(KIND=JPRB),   INTENT(IN) :: PQ_RAIN(KLON,KLEV)
-REAL(KIND=JPRB),   INTENT(IN) :: PQ_SNOW(KLON,KLEV)
-
-! *** Aerosol mass mixing ratios
-REAL(KIND=JPRB),   INTENT(IN) :: PAEROSOL_OLD(KLON,6,KLEV)
-REAL(KIND=JPRB),   INTENT(IN) :: PAEROSOL(KLON,KLEV,KAEROSOL)
-
-!REAL(KIND=JPRB),   INTENT(IN) :: PCCN_LAND(KLON) 
-!REAL(KIND=JPRB),   INTENT(IN) :: PCCN_SEA(KLON) 
-
-!AI mars 2021
-INTEGER(KIND=JPIM), INTENT(IN) :: IDAY
-REAL(KIND=JPRB), INTENT(IN)    :: TIME
-
-! Name of file names specified on command line
-character(len=512), INTENT(IN) :: namelist_file
-logical, INTENT(IN)            :: ok_3Deffect, debut, ok_volcan
-INTEGER(KIND=JPIM), INTENT(IN) :: flag_aerosol_strat
-
-
-! OUTPUT ARGUMENTS
-
-! *** Net fluxes on half-levels (W m-2)
-REAL(KIND=JPRB),  INTENT(OUT) :: PFLUX_SW(KLON,KLEV+1) 
-REAL(KIND=JPRB),  INTENT(OUT) :: PFLUX_LW(KLON,KLEV+1) 
-REAL(KIND=JPRB),  INTENT(OUT) :: PFLUX_SW_CLEAR(KLON,KLEV+1) 
-REAL(KIND=JPRB),  INTENT(OUT) :: PFLUX_LW_CLEAR(KLON,KLEV+1) 
-
-!*** DN and UP flux on half-levels (W m-2)
-REAL(KIND=JPRB),  INTENT(OUT) :: PFLUX_SW_DN(KLON,KLEV+1)
-REAL(KIND=JPRB),  INTENT(OUT) :: PFLUX_LW_DN(KLON,KLEV+1)
-REAL(KIND=JPRB),  INTENT(OUT) :: PFLUX_SW_DN_CLEAR(KLON,KLEV+1)
-REAL(KIND=JPRB),  INTENT(OUT) :: PFLUX_LW_DN_CLEAR(KLON,KLEV+1)
-REAL(KIND=JPRB),  INTENT(OUT) :: PFLUX_SW_UP(KLON,KLEV+1)
-REAL(KIND=JPRB),  INTENT(OUT) :: PFLUX_LW_UP(KLON,KLEV+1)
-REAL(KIND=JPRB),  INTENT(OUT) :: PFLUX_SW_UP_CLEAR(KLON,KLEV+1)
-REAL(KIND=JPRB),  INTENT(OUT) :: PFLUX_LW_UP_CLEAR(KLON,KLEV+1)
-
-! Direct component of surface flux into horizontal plane
-REAL(KIND=JPRB),  INTENT(OUT) :: PFLUX_DIR(KLON)
-REAL(KIND=JPRB),  INTENT(OUT) :: PFLUX_DIR_CLEAR(KLON)
-! As PFLUX_DIR but into a plane perpendicular to the sun
-REAL(KIND=JPRB),  INTENT(OUT) :: PFLUX_DIR_INTO_SUN(KLON)
-
-! *** Ultraviolet and photosynthetically active radiation (W m-2)
-REAL(KIND=JPRB),  INTENT(OUT) :: PFLUX_UV(KLON)
-REAL(KIND=JPRB),  INTENT(OUT) :: PFLUX_PAR(KLON)
-REAL(KIND=JPRB),  INTENT(OUT) :: PFLUX_PAR_CLEAR(KLON)
-
-! Diagnosed longwave surface emissivity across the whole spectrum
-REAL(KIND=JPRB),  INTENT(OUT) :: PEMIS_OUT(KLON)   
-
-! Partial derivative of total-sky longwave upward flux at each level
-! with respect to upward flux at surface, used to correct heating
-! rates at gridpoints/timesteps between calls to the full radiation
-! scheme.  Note that this version uses the convention of level index
-! increasing downwards, unlike the local variable ZLwDerivative that
-! is returned from the LW radiation scheme.
-REAL(KIND=JPRB),  INTENT(OUT) :: PLWDERIVATIVE(KLON,KLEV+1)
-
-! Surface diffuse and direct downwelling shortwave flux in each
-! shortwave albedo band, used in RADINTG to update the surface fluxes
-! accounting for high-resolution albedo information
-REAL(KIND=JPRB),  INTENT(OUT) :: PSWDIFFUSEBAND(KLON,NSW)
-REAL(KIND=JPRB),  INTENT(OUT) :: PSWDIRECTBAND (KLON,NSW)
-
-!AI Nov 2023
-REAL(KIND=JPRB),  INTENT(OUT) :: ecrad_cloud_cover_sw(KLON)
-
-! LOCAL VARIABLES
-! AI ATTENTION
-type(config_type),save         :: rad_config
-!!$OMP THREADPRIVATE(rad_config)
-type(driver_config_type),save  :: driver_config
-!!$OMP THREADPRIVATE(driver_config)
-!type(config_type)        :: rad_config
-!type(driver_config_type)  :: driver_config
-TYPE(single_level_type)   :: single_level
-TYPE(thermodynamics_type) :: thermodynamics
-TYPE(gas_type)            :: gas
-TYPE(cloud_type)          :: cloud
-TYPE(aerosol_type)        :: aerosol
-TYPE(flux_type)           :: flux
-
-! Mass mixing ratio of ozone (kg/kg)
-REAL(KIND=JPRB)           :: ZO3(KLON,KLEV)
-
-! Cloud effective radii in microns
-REAL(KIND=JPRB)           :: ZRE_LIQUID_UM(KLON,KLEV)
-REAL(KIND=JPRB)           :: ZRE_ICE_UM(KLON,KLEV)
-
-! Cloud overlap decorrelation length for cloud boundaries in km
-REAL(KIND=JPRB)           :: ZDECORR_LEN_M
-REAL(KIND=JPRB)           :: ZDECORR_LEN_M_1D(KLON)
-REAL(KIND=JPRB)           :: ZDECORR_LEN_M_2D(KLON,KLEV)
-
-! Ratio of cloud overlap decorrelation length for cloud water
-! inhomogeneities to that for cloud boundaries (typically 0.5)
-!REAL(KIND=JPRB)           :: ZDECORR_LEN_RATIO = 0.5_jprb
-
-! The surface net longwave flux if the surface was a black body, used
-! to compute the effective broadband surface emissivity
-REAL(KIND=JPRB)           :: ZBLACK_BODY_NET_LW(KIDIA:KFDIA)
-
-! Layer mass in kg m-2
-REAL(KIND=JPRB)           :: ZLAYER_MASS(KIDIA:KFDIA,KLEV)
-
-! Time integers
-INTEGER :: ITIM
-
-! Loop indices
-INTEGER :: JLON, JLEV, JBAND, JB_ALBEDO, JAER
-
-REAL(KIND=JPRB) :: ZHOOK_HANDLE
-
-! AI ATTENTION traitement aerosols
-INTEGER, PARAMETER :: NAERMACC = 1
-
-logical :: loutput=.true.
-logical :: lprint_input=.false.
-logical :: lprint_config=.false.
-logical, save :: debut_ecrad=.true.
-!$OMP THREADPRIVATE(debut_ecrad)
-integer, save :: itap_ecrad=0
-!$OMP THREADPRIVATE(itap_ecrad)
-
-REAL(KIND=JPRB) ::  inv_cloud_effective_size(KLON,KLEV)
-REAL(KIND=JPRB) ::  inv_inhom_effective_size(KLON,KLEV)
-
-integer :: irang
-
-
-IF (LHOOK) CALL DR_HOOK('RADIATION_SCHEME',0,ZHOOK_HANDLE)
-
-   print*,'Entree radiation_scheme_s2, ok_3Deffect, namelist_file = ', &
-          ok_3Deffect, namelist_file
-! A.I juillet 2023 : 
-! Initialisation dans radiation_setup au 1er passage dans Ecrad
-!$OMP MASTER
-!if (.not.ok_3Deffect) then
-  if (debut_ecrad) then
-   call SETUP_RADIATION_SCHEME(loutput,namelist_file,rad_config,driver_config)
-   debut_ecrad=.false. 
-  endif 
-!else
-!   call SETUP_RADIATION_SCHEME(loutput,namelist_file,rad_config,driver_config)
-!endif
-!$OMP END MASTER
-!$OMP BARRIER 
-! Fin partie initialisation et configuration 
-
-!AI print fichiers namelist utilise
-!if (is_omp_root) then
-! itap_ecrad=itap_ecrad+1
-! print*,'Dans radiation_scheme itap_ecrad, mpi_rank, omp_rank, namelist_file : ', &
-!         itap_ecrad, mpi_rank, omp_rank, namelist_file
-!else
-! print*,'mpi_rank omp_rank, namelist_file :', mpi_rank, omp_rank, namelist_file
-!endif
-
-! AI 11 23 Allocates depplaces au debut
-print*,'*********** ALLOCATES *******************************'
-! AI ATTENTION
-! Allocate memory in radiation objects
-! emissivite avec une seule bande
-CALL single_level%allocate(KLON, NSW, 1, &
-     &                     use_sw_albedo_direct=.TRUE.)
-CALL thermodynamics%allocate(KLON, KLEV, use_h2o_sat=.true.)
-CALL cloud%allocate(KLON, KLEV)
-CALL aerosol%allocate(KLON, 1, KLEV, KAEROSOL)
-CALL gas%allocate(KLON, KLEV)
-CALL flux%allocate(rad_config, 1, KLON, KLEV)
-
-print*,'************* THERMO (input) ************************************'
-! Set thermodynamic profiles: simply copy over the half-level
-! pressure and temperature
-! AI
-! pressure_hl > paprs
-! temperature_hl calculee dans radlsw de la meme facon que pour RRTM
-thermodynamics%pressure_hl   (KIDIA:KFDIA,:) = PPRESSURE_H   (KIDIA:KFDIA,:)
-thermodynamics%temperature_hl(KIDIA:KFDIA,:) = PTEMPERATURE_H(KIDIA:KFDIA,:)
-!print*,'Compute saturation specific humidity'
-! Compute saturation specific humidity, used to hydrate aerosols. The
-! "2" for the last argument indicates that the routine is not being
-! called from within the convection scheme.
-!CALL SATUR(KIDIA, KFDIA, KLON, 1, KLEV, &
-!     &  PPRESSURE, PTEMPERATURE, thermodynamics%h2o_sat_liq, 2)
-! Alternative approximate version using temperature and pressure from
-! the thermodynamics structure
-!CALL thermodynamics%calc_saturation_wrt_liquid(KIDIA, KFDIA)
-!AI ATTENTION
-thermodynamics%h2o_sat_liq = PQSAT
-
-print*,'********** SINGLE LEVEL VARS **********************************'
-!AI ATTENTION
-! Set single-level fileds
-single_level%solar_irradiance              = PSOLAR_IRRADIANCE
-single_level%cos_sza(KIDIA:KFDIA)          = PMU0(KIDIA:KFDIA)
-single_level%skin_temperature(KIDIA:KFDIA) = PTEMPERATURE_SKIN(KIDIA:KFDIA)
-single_level%sw_albedo(KIDIA:KFDIA,:)      = PALBEDO_DIF(KIDIA:KFDIA,:)
-single_level%sw_albedo_direct(KIDIA:KFDIA,:)=PALBEDO_DIR(KIDIA:KFDIA,:)
-single_level%lw_emissivity(KIDIA:KFDIA,1)  = PEMIS(KIDIA:KFDIA)
-!single_level%lw_emissivity(KIDIA:KFDIA,2)  = PEMIS_WINDOW(KIDIA:KFDIA)
-
-! Create the relevant seed from date and time get the starting day
-! and number of minutes since start
-!IDAY = NDD(NINDAT)
-!cur_day
-!ITIM = NINT(NSTEP * YRRIP%TSTEP / 60.0_JPRB)
-!ITIM = NINT(TIME / 60.0_JPRB)
-!current_time
-!allocate(single_level%iseed(KIDIA:KFDIA))
-!DO JLON = KIDIA, KFDIA
-  ! This method gives a unique value for roughly every 1-km square
-  ! on the globe and every minute.  ASIN(PGEMU)*60 gives rough
-  ! latitude in degrees, which we multiply by 100 to give a unique
-  ! value for roughly every km. PGELAM*60*100 gives a unique number
-  ! for roughly every km of longitude around the equator, which we
-  ! multiply by 180*100 so there is no overlap with the latitude
-  ! values.  The result can be contained in a 32-byte integer (but
-  ! since random numbers are generated with the help of integer
-  ! overflow, it should not matter if the number did overflow).
-!  single_level%iseed(JLON) = ITIM + IDAY & 
-!       &  +  NINT(PGELAM(JLON)*108000000.0_JPRB &
-!       &          + ASIN(PGEMU(JLON))*6000.0_JPRB)
-!ENDDO
-!AI Nov 23
-! Simple initialization of the seeds for the Monte Carlo scheme
-call single_level%init_seed_simple(kidia, kfdia)
-
-print*,'********** CLOUDS (allocate + input) *******************************************'
-!print*,'Appel Allocate clouds'
-! Set cloud fields
-cloud%q_liq(KIDIA:KFDIA,:)    = PQ_LIQUID(KIDIA:KFDIA,:)
-cloud%q_ice(KIDIA:KFDIA,:)    = PQ_ICE(KIDIA:KFDIA,:) + PQ_SNOW(KIDIA:KFDIA,:)
-cloud%fraction(KIDIA:KFDIA,:) = PCLOUD_FRAC(KIDIA:KFDIA,:)
-!!! ok AI ATTENTION a voir avec JL
-! Compute effective radi and convert to metres
-! AI. : on passe directement les champs de LMDZ
-cloud%re_liq(KIDIA:KFDIA,:) = ZRE_LIQUID_UM(KIDIA:KFDIA,:)
-cloud%re_ice(KIDIA:KFDIA,:) = ZRE_ICE_UM(KIDIA:KFDIA,:)
-! Get the cloud overlap decorrelation length (for cloud boundaries),
-! in km, according to the parameterization specified by NDECOLAT,
-! and insert into the "cloud" object. Also get the ratio of
-! decorrelation lengths for cloud water content inhomogeneities and
-! cloud boundaries, and set it in the "rad_config" object.
-! IFS :
-!CALL CLOUD_OVERLAP_DECORR_LEN(KIDIA, KFDIA, KLON, PGEMU, YRERAD%NDECOLAT, &
-!     &    ZDECORR_LEN_KM, PDECORR_LEN_RATIO=ZDECORR_LEN_RATIO)
-! AI valeur dans namelist
-! rad_config%cloud_inhom_decorr_scaling = ZDECORR_LEN_RATIO
-!AI ATTENTION meme valeur que dans offline
-! A mettre dans namelist
-   CALL CALCUL_CLOUD_OVERLAP_DECORR_LEN &
-     & (KIDIA, KFDIA, KLON, KLEV, &
-     &  driver_config, &
-     &  thermodynamics%pressure_hl , &
-     &  ZDECORR_LEN_M_2D)
-
- if (driver_config%kdecolat.eq.0) then
-  ZDECORR_LEN_M = ZDECORR_LEN_M_2D(1,1)
-  DO JLON = KIDIA,KFDIA
-   CALL cloud%set_overlap_param(thermodynamics, &
-       &                 ZDECORR_LEN_M, &
-       &                 istartcol=JLON, iendcol=JLON)
-  ENDDO
- else if (driver_config%kdecolat.eq.1.or.driver_config%kdecolat.eq.2) then
-  ZDECORR_LEN_M_1D = ZDECORR_LEN_M_2D(:,1)
-  DO JLON = KIDIA,KFDIA
-   CALL cloud%set_overlap_param(thermodynamics, &
-       &                 ZDECORR_LEN_M_1D, &
-       &                 istartcol=JLON, iendcol=JLON)
-  ENDDO
- else if (driver_config%kdecolat.eq.3) then
-  DO JLON = KIDIA,KFDIA
-   CALL cloud%set_overlap_param_var2D(thermodynamics, &
-       &                 ZDECORR_LEN_M_2D, KLEV, &
-       &                 istartcol=JLON, iendcol=JLON)
-  ENDDO
- endif
-   
-! IFS :
-! Cloud water content fractional standard deviation is configurable
-! from namelist NAERAD but must be globally constant. Before it was
-! hard coded at 1.0.
-!CALL cloud%create_fractional_std(KLON, KLEV, YRERAD%RCLOUD_FRAC_STD)
-! AI ATTENTION frac_std=0.75 meme valeur que dans la version offline
-CALL cloud%create_fractional_std(KLON, KLEV, driver_config%frac_std)
-
-!if (ok_3Deffect) then
-! if (driver_config%ok_effective_size) then
-!     call cloud%create_inv_cloud_effective_size_eta(klon, klev, &
-!               &  thermodynamics%pressure_hl, &
-!               &  driver_config%low_inv_effective_size, &
-!               &  driver_config%middle_inv_effective_size, &
-!               &  driver_config%high_inv_effective_size, 0.8_jprb, 0.45_jprb, &
-!               &  KIDIA, KFDIA)
-!   else if (driver_config%ok_separation) then
-!     call cloud%param_cloud_effective_separation_eta(klon, klev, &
-!               &  thermodynamics%pressure_hl, &
-!               &  driver_config%cloud_separation_scale_surface, &
-!               &  driver_config%cloud_separation_scale_toa, &
-!               &  driver_config%cloud_separation_scale_power, &
-!               &  driver_config%cloud_inhom_separation_factor, &
-!               &  KIDIA, KFDIA)
-!   endif     
-! else  
- if (rad_config%i_solver_sw == ISolverSPARTACUS &
-      & .or.   rad_config%i_solver_lw == ISolverSPARTACUS) then
-   ! AI ! Read cloud properties needed by SPARTACUS
-   if (driver_config%ok_effective_size) then
-     call cloud%create_inv_cloud_effective_size_eta(klon, klev, &
-               &  thermodynamics%pressure_hl, &
-               &  driver_config%low_inv_effective_size, &
-               &  driver_config%middle_inv_effective_size, &
-               &  driver_config%high_inv_effective_size, 0.8_jprb, 0.45_jprb, &
-               &  KIDIA, KFDIA)
-   else if (driver_config%ok_separation) then
-     call cloud%param_cloud_effective_separation_eta(klon, klev, &
-               &  thermodynamics%pressure_hl, &
-               &  driver_config%cloud_separation_scale_surface, &
-               &  driver_config%cloud_separation_scale_toa, &
-               &  driver_config%cloud_separation_scale_power, &
-               &  driver_config%cloud_inhom_separation_factor, &
-               &  KIDIA, KFDIA)
-   endif
- endif  
-!endif
-
-print*,'******** AEROSOLS (input) **************************************'
-!IF (NAERMACC > 0) THEN
-!ELSE
-!  CALL aerosol%allocate(KLON, 1, KLEV, 6) ! Tegen climatology
-!ENDIF
-! Compute the dry mass of each layer neglecting humidity effects, in
-! kg m-2, needed to scale some of the aerosol inputs
-! AI commente ATTENTION
-!CALL thermodynamics%get_layer_mass(ZLAYER_MASS)
-
-! Copy over aerosol mass mixing ratio
-!IF (NAERMACC > 0) THEN
-
-  ! MACC aerosol climatology - this is already in mass mixing ratio
-  ! units with the required array orientation so we can copy it over
-  ! directly
-  aerosol%mixing_ratio(KIDIA:KFDIA,:,:) = PAEROSOL(KIDIA:KFDIA,:,:)
-
-  ! Add the tropospheric and stratospheric backgrounds contained in the
-  ! old Tegen arrays - this is very ugly!
-! AI ATTENTION
-!  IF (TROP_BG_AER_MASS_EXT > 0.0_JPRB) THEN
-!    aerosol%mixing_ratio(KIDIA:KFDIA,:,ITYPE_TROP_BG_AER) &
-!         &  = aerosol%mixing_ratio(KIDIA:KFDIA,:,ITYPE_TROP_BG_AER) &
-!         &  + PAEROSOL_OLD(KIDIA:KFDIA,1,:) &
-!         &  / (ZLAYER_MASS * TROP_BG_AER_MASS_EXT)
-!  ENDIF
-!  IF (STRAT_BG_AER_MASS_EXT > 0.0_JPRB) THEN
-!    aerosol%mixing_ratio(KIDIA:KFDIA,:,ITYPE_STRAT_BG_AER) &
-!         &  = aerosol%mixing_ratio(KIDIA:KFDIA,:,ITYPE_STRAT_BG_AER) &
-!         &  + PAEROSOL_OLD(KIDIA:KFDIA,6,:) &
-!         &  / (ZLAYER_MASS * STRAT_BG_AER_MASS_EXT)
-!  ENDIF
-
-!ELSE
-
-  ! Tegen aerosol climatology - the array PAEROSOL_OLD contains the
-  ! 550-nm optical depth in each layer. The optics data file
-  ! aerosol_ifs_rrtm_tegen.nc does not contain mass extinction
-  ! coefficient, but a scaling factor that the 550-nm optical depth
-  ! should be multiplied by to obtain the optical depth in each
-  ! spectral band.  Therefore, in order for the units to work out, we
-  ! need to divide by the layer mass (in kg m-2) to obtain the 550-nm
-  ! cross-section per unit mass of dry air (so in m2 kg-1).  We also
-  ! need to permute the array.
-!  DO JLEV = 1,KLEV
-!    DO JAER = 1,6
-!      aerosol%mixing_ratio(KIDIA:KFDIA,JLEV,JAER) &
-!         &  = PAEROSOL_OLD(KIDIA:KFDIA,JAER,JLEV) &
-!         &  / ZLAYER_MASS(KIDIA:KFDIA,JLEV)
-!    ENDDO
-!  ENDDO
-!ENDIF
-
-print*,'********** GAS (input) ************************************************'
-!print*,'Appel Allocate gas'
-! Convert ozone Pa*kg/kg to kg/kg
-! AI ATTENTION
-!DO JLEV = 1,KLEV
-!  DO JLON = KIDIA,KFDIA
-!    ZO3(JLON,JLEV) = PO3_DP(JLON,JLEV) &
-!         &         / (PPRESSURE_H(JLON,JLEV+1)-PPRESSURE_H(JLON,JLEV))
-!  ENDDO
-!ENDDO
-!  Insert gas mixing ratios
-!print*,'Insert gas mixing ratios'
-CALL gas%put(IH2O,    IMassMixingRatio, PQ)
-CALL gas%put(IO3,     IMassMixingRatio, PO3)
-CALL gas%put_well_mixed(ICO2,    IMAssMixingRatio, PCO2)
-CALL gas%put_well_mixed(ICH4,    IMassMixingRatio, PCH4)
-CALL gas%put_well_mixed(IN2O,    IMassMixingRatio, PN2O)
-CALL gas%put_well_mixed(ICFC11,  IMassMixingRatio, PCFC11)
-CALL gas%put_well_mixed(ICFC12,  IMassMixingRatio, PCFC12)
-CALL gas%put_well_mixed(IHCFC22, IMassMixingRatio, PHCFC22)
-CALL gas%put_well_mixed(ICCL4,   IMassMixingRatio, PCCL4)
-CALL gas%put_well_mixed(IO2,     IMassMixingRatio, PO2)
-! Ensure the units of the gas mixing ratios are what is required by
-! the gas absorption model
-call set_gas_units(rad_config, gas)
-
-! Call radiation scheme
-!print*,'*** Appel radiation *** namelist **** omp_rank ****', &
-!         omp_rank, namelist_file
-!   if (rad_config%i_solver_sw == ISolverSPARTACUS) then 
-!    if (driver_config%ok_separation) then
-!      print*,'Avant radiation, mpi_rank, omp_rank, size, chape inv_cloud = ',&
-!              mpi_rank, omp_rank, &
-!              shape(cloud%inv_cloud_effective_size), &
-!              size(cloud%inv_cloud_effective_size)      
-!      do jlon=KIDIA, KFDIA      
-!        do jlev=1,klev
-!         print*,' Avant radiation mpi_rank, omp_rank, jlon, jlev, &
-!            &     cloud%inv_cloud_effective_size =', mpi_rank, &
-!            &     omp_rank, jlon, jlev, &
-!            &     cloud%inv_cloud_effective_size(jlon,jlev)
-!        enddo
-!      enddo
-!       cloud%inv_cloud_effective_size=inv_cloud_effective_size
-!       cloud%inv_inhom_effective_size=inv_inhom_effective_size
-!    endif
-!   endif
-CALL radiation(KLON, KLEV, KIDIA, KFDIA, rad_config, &
-     &  single_level, thermodynamics, gas, cloud, aerosol, flux)
-
- if (rad_config%use_aerosols) then
-    if (rad_config%i_gas_model_sw == IGasModelIFSRRTMG .or. &
-     &    rad_config%i_gas_model_lw == IGasModelIFSRRTMG) then     
-       CALL aeropt_5wv_ecrad(kidia, kfdia, 1, klev, &
-                             rad_config,thermodynamics,aerosol)
-    endif                 
-    if (flag_aerosol_strat.eq.2) then
-       CALL readaerosolstrato_ecrad(rad_config, debut, ok_volcan)
-    endif
- endif               
-
-print*,'*********** Sortie flux ****************'
-! Cloud cover
-ecrad_cloud_cover_sw = flux%cloud_cover_sw
-! Compute required output fluxes
-! DN and UP flux
-PFLUX_SW_DN(KIDIA:KFDIA,:) = flux%sw_dn(KIDIA:KFDIA,:)
-PFLUX_SW_UP(KIDIA:KFDIA,:) = flux%sw_up(KIDIA:KFDIA,:)
-PFLUX_LW_DN(KIDIA:KFDIA,:) = flux%lw_dn(KIDIA:KFDIA,:)
-PFLUX_LW_UP(KIDIA:KFDIA,:) = flux%lw_up(KIDIA:KFDIA,:)
-PFLUX_SW_DN_CLEAR(KIDIA:KFDIA,:) = flux%sw_dn_clear(KIDIA:KFDIA,:)
-PFLUX_SW_UP_CLEAR(KIDIA:KFDIA,:) = flux%sw_up_clear(KIDIA:KFDIA,:)
-PFLUX_LW_DN_CLEAR(KIDIA:KFDIA,:) = flux%lw_dn_clear(KIDIA:KFDIA,:)
-PFLUX_LW_UP_CLEAR(KIDIA:KFDIA,:) = flux%lw_up_clear(KIDIA:KFDIA,:)
-! First the net fluxes
-PFLUX_SW(KIDIA:KFDIA,:) = flux%sw_dn(KIDIA:KFDIA,:) - flux%sw_up(KIDIA:KFDIA,:)
-PFLUX_LW(KIDIA:KFDIA,:) = flux%lw_dn(KIDIA:KFDIA,:) - flux%lw_up(KIDIA:KFDIA,:)
-PFLUX_SW_CLEAR(KIDIA:KFDIA,:) &
-     &  = flux%sw_dn_clear(KIDIA:KFDIA,:) - flux%sw_up_clear(KIDIA:KFDIA,:)
-PFLUX_LW_CLEAR(KIDIA:KFDIA,:) &
-     &  = flux%lw_dn_clear(KIDIA:KFDIA,:) - flux%lw_up_clear(KIDIA:KFDIA,:)
-! Now the surface fluxes
-!PFLUX_SW_DN_SURF(KIDIA:KFDIA) = flux%sw_dn(KIDIA:KFDIA,KLEV+1)
-!PFLUX_LW_DN_SURF(KIDIA:KFDIA) = flux%lw_dn(KIDIA:KFDIA,KLEV+1)
-!PFLUX_SW_UP_SURF(KIDIA:KFDIA) = flux%sw_up(KIDIA:KFDIA,KLEV+1)
-!PFLUX_LW_UP_SURF(KIDIA:KFDIA) = flux%lw_up(KIDIA:KFDIA,KLEV+1)
-!PFLUX_SW_DN_CLEAR_SURF(KIDIA:KFDIA) = flux%sw_dn_clear(KIDIA:KFDIA,KLEV+1)
-!PFLUX_LW_DN_CLEAR_SURF(KIDIA:KFDIA) = flux%lw_dn_clear(KIDIA:KFDIA,KLEV+1)
-!PFLUX_SW_UP_CLEAR_SURF(KIDIA:KFDIA) = flux%sw_up_clear(KIDIA:KFDIA,KLEV+1)
-!PFLUX_LW_UP_CLEAR_SURF(KIDIA:KFDIA) = flux%lw_up_clear(KIDIA:KFDIA,KLEV+1)
-PFLUX_DIR(KIDIA:KFDIA) = flux%sw_dn_direct(KIDIA:KFDIA,KLEV+1)
-PFLUX_DIR_CLEAR(KIDIA:KFDIA) = flux%sw_dn_direct_clear(KIDIA:KFDIA,KLEV+1)
-PFLUX_DIR_INTO_SUN(KIDIA:KFDIA) = 0.0_JPRB
-WHERE (PMU0(KIDIA:KFDIA) > EPSILON(1.0_JPRB))
-  PFLUX_DIR_INTO_SUN(KIDIA:KFDIA) = PFLUX_DIR(KIDIA:KFDIA) / PMU0(KIDIA:KFDIA)
-END WHERE
-! Top-of-atmosphere downwelling flux
-!PFLUX_SW_DN_TOA(KIDIA:KFDIA) = flux%sw_dn(KIDIA:KFDIA,1)
-!PFLUX_SW_UP_TOA(KIDIA:KFDIA) = flux%sw_up(KIDIA:KFDIA,1)
-!PFLUX_LW_DN_TOA(KIDIA:KFDIA) = flux%lw_dn(KIDIA:KFDIA,1)
-!PFLUX_LW_UP_TOA(KIDIA:KFDIA) = flux%lw_up(KIDIA:KFDIA,1)
-!AI ATTENTION
-if (0.eq.1) then
-PFLUX_UV       (KIDIA:KFDIA) = 0.0_JPRB
-DO JBAND = 1,NWEIGHT_UV
-  PFLUX_UV(KIDIA:KFDIA) = PFLUX_UV(KIDIA:KFDIA) + WEIGHT_UV(JBAND) &
-       &  * flux%sw_dn_surf_band(IBAND_UV(JBAND),KIDIA:KFDIA)
-ENDDO
-! Compute photosynthetically active radiation similarly
-PFLUX_PAR      (KIDIA:KFDIA) = 0.0_JPRB
-PFLUX_PAR_CLEAR(KIDIA:KFDIA) = 0.0_JPRB
-DO JBAND = 1,NWEIGHT_PAR
-  PFLUX_PAR(KIDIA:KFDIA) = PFLUX_PAR(KIDIA:KFDIA) + WEIGHT_PAR(JBAND) &
-       &  * flux%sw_dn_surf_band(IBAND_PAR(JBAND),KIDIA:KFDIA)
-  PFLUX_PAR_CLEAR(KIDIA:KFDIA) = PFLUX_PAR_CLEAR(KIDIA:KFDIA) &
-       &  + WEIGHT_PAR(JBAND) &
-       &  * flux%sw_dn_surf_clear_band(IBAND_PAR(JBAND),KIDIA:KFDIA)
-ENDDO
-endif
-! Compute effective broadband emissivity
-ZBLACK_BODY_NET_LW = flux%lw_dn(KIDIA:KFDIA,KLEV+1) &
-     &  - RSIGMA*PTEMPERATURE_SKIN(KIDIA:KFDIA)**4
-PEMIS_OUT(KIDIA:KFDIA) = PEMIS(KIDIA:KFDIA)
-WHERE (ABS(ZBLACK_BODY_NET_LW) > 1.0E-5) 
-  PEMIS_OUT(KIDIA:KFDIA) = PFLUX_LW(KIDIA:KFDIA,KLEV+1) / ZBLACK_BODY_NET_LW
-END WHERE
-! Copy longwave derivatives
-! AI ATTENTION
-!IF (YRERAD%LAPPROXLWUPDATE) THEN
-IF (rad_config%do_lw_derivatives) THEN
-  PLWDERIVATIVE(KIDIA:KFDIA,:) = flux%lw_derivatives(KIDIA:KFDIA,:)
-END IF
-! Store the shortwave downwelling fluxes in each albedo band
-!AI ATTENTION
-!IF (YRERAD%LAPPROXSWUPDATE) THEN
-if (0.eq.1) then
-IF (rad_config%do_surface_sw_spectral_flux) THEN
-  PSWDIFFUSEBAND(KIDIA:KFDIA,:) = 0.0_JPRB
-  PSWDIRECTBAND (KIDIA:KFDIA,:) = 0.0_JPRB
-  DO JBAND = 1,rad_config%n_bands_sw
-    JB_ALBEDO = rad_config%i_albedo_from_band_sw(JBAND)
-    DO JLON = KIDIA,KFDIA
-      PSWDIFFUSEBAND(JLON,JB_ALBEDO) = PSWDIFFUSEBAND(JLON,JB_ALBEDO) &
-           &  + flux%sw_dn_surf_band(JBAND,JLON) &
-           &  - flux%sw_dn_direct_surf_band(JBAND,JLON)
-      PSWDIRECTBAND(JLON,JB_ALBEDO)  = PSWDIRECTBAND(JLON,JB_ALBEDO) &
-           &  + flux%sw_dn_direct_surf_band(JBAND,JLON)
-    ENDDO
-  ENDDO
-ENDIF
-endif
-
-print*,'********** DEALLOCATIONS ************************'
-CALL single_level%deallocate
-CALL thermodynamics%deallocate
-CALL gas%deallocate
-CALL cloud%deallocate
-CALL aerosol%deallocate
-CALL flux%deallocate
-
-IF (LHOOK) CALL DR_HOOK('RADIATION_SCHEME',1,ZHOOK_HANDLE)
-
-END SUBROUTINE RADIATION_SCHEME_S2
-
-end module interface_lmdz_ecrad
Index: /LMDZ6/trunk/libf/phylmd/ecrad/lmdz/radiation_scheme_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/ecrad/lmdz/radiation_scheme_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/ecrad/lmdz/radiation_scheme_mod.f90	(revision 5268)
@@ -0,0 +1,1359 @@
+! AI mars 2021
+! ====================== Interface between ECRAD and LMDZ ====================
+! Depart de la version IFS R.H 
+! radiation_scheme.F90 appelee dans radlwsw_m.F90 si iflag_rttm = 2
+! revoir toutes les parties avec "AI ATTENTION" 
+! Mars 2021 :
+!             - Revoir toutes les parties commentees AI ATTENTION
+!             1. Traitement des aerosols
+!             2. Verifier les parametres times issus de LMDZ (calcul issed)
+!             3. Configuration a partir de namelist
+!             4. frac_std = 0.75      
+! Juillet 2023 :
+!             
+! ============================================================================
+module interface_lmdz_ecrad
+
+IMPLICIT NONE        
+
+contains
+
+SUBROUTINE RADIATION_SCHEME &
+! Inputs
+     & (KIDIA, KFDIA, KLON, KLEV, KAEROSOL, NSW, &
+     &  namelist_file, ok_3Deffect, &
+     &  debut, ok_volcan, flag_aerosol_strat, &
+     &  IDAY, TIME, &
+     &  PSOLAR_IRRADIANCE, &
+     &  PMU0, PTEMPERATURE_SKIN, &
+     &  PALBEDO_DIF, PALBEDO_DIR, &
+     &  PEMIS, PEMIS_WINDOW, &
+     &  PGELAM, PGEMU, &
+     &  PPRESSURE_H, PTEMPERATURE_H, PQ, PQSAT, &
+     &  PCO2, PCH4, PN2O, PNO2, PCFC11, PCFC12, PHCFC22, &
+     &  PCCL4, PO3, PO2, &
+     &  PCLOUD_FRAC, PQ_LIQUID, PQ_ICE, PQ_SNOW, &
+     &  ZRE_LIQUID_UM, ZRE_ICE_UM, &
+     &  PAEROSOL_OLD, PAEROSOL, &
+! Outputs
+     &  PFLUX_SW, PFLUX_LW, PFLUX_SW_CLEAR, PFLUX_LW_CLEAR, &
+     &  PFLUX_SW_DN, PFLUX_LW_DN, PFLUX_SW_DN_CLEAR, PFLUX_LW_DN_CLEAR, &
+     &  PFLUX_SW_UP, PFLUX_LW_UP, PFLUX_SW_UP_CLEAR, PFLUX_LW_UP_CLEAR, &
+     &  PFLUX_DIR, PFLUX_DIR_CLEAR, PFLUX_DIR_INTO_SUN, &
+     &  PFLUX_UV, PFLUX_PAR, PFLUX_PAR_CLEAR, &
+     &  PEMIS_OUT, PLWDERIVATIVE, &
+     &  PSWDIFFUSEBAND, PSWDIRECTBAND, &
+     &  ecrad_cloud_cover_sw)
+
+!-----------------------------------------------------------------------
+
+! Modules from ifs or ifsaux libraries
+USE PARKIND1 , ONLY : JPIM, JPRB
+USE YOMHOOK  , ONLY : LHOOK, DR_HOOK
+USE RADIATION_SETUP
+USE YOMCST   , ONLY : RSIGMA ! Stefan-Boltzmann constant
+
+! Modules from radiation library
+USE radiation_single_level,   ONLY : single_level_type
+USE radiation_thermodynamics, ONLY : thermodynamics_type
+USE radiation_gas
+USE radiation_cloud,          ONLY : cloud_type
+USE radiation_aerosol,        ONLY : aerosol_type
+USE radiation_flux,           ONLY : flux_type
+USE radiation_interface,      ONLY : radiation, set_gas_units
+USE radiation_save,           ONLY : save_inputs
+
+USE mod_phys_lmdz_para
+
+IMPLICIT NONE
+
+! INPUT ARGUMENTS
+! *** Array dimensions and ranges
+INTEGER(KIND=JPIM),INTENT(IN) :: KIDIA    ! Start column to process
+INTEGER(KIND=JPIM),INTENT(IN) :: KFDIA    ! End column to process
+INTEGER(KIND=JPIM),INTENT(IN) :: KLON     ! Number of columns
+INTEGER(KIND=JPIM),INTENT(IN) :: KLEV     ! Number of levels
+INTEGER(KIND=JPIM),INTENT(IN) :: KAEROSOL
+INTEGER(KIND=JPIM),INTENT(IN) :: NSW ! Numbe of bands
+
+! AI ATTENTION
+!INTEGER, PARAMETER :: KAEROSOL = 12
+
+! *** Single-level fields
+REAL(KIND=JPRB),   INTENT(IN) :: PSOLAR_IRRADIANCE ! (W m-2)
+REAL(KIND=JPRB),   INTENT(IN) :: PMU0(KLON) ! Cosine of solar zenith ang
+REAL(KIND=JPRB),   INTENT(IN) :: PTEMPERATURE_SKIN(KLON) ! (K)
+! Diffuse and direct components of surface shortwave albedo
+!REAL(KIND=JPRB),   INTENT(IN) :: PALBEDO_DIF(KLON,YRERAD%NSW)
+!REAL(KIND=JPRB),   INTENT(IN) :: PALBEDO_DIR(KLON,YRERAD%NSW)
+REAL(KIND=JPRB),   INTENT(IN) :: PALBEDO_DIF(KLON,NSW)
+REAL(KIND=JPRB),   INTENT(IN) :: PALBEDO_DIR(KLON,NSW)
+! Longwave emissivity outside and inside the window region
+REAL(KIND=JPRB),   INTENT(IN) :: PEMIS(KLON)
+REAL(KIND=JPRB),   INTENT(IN) :: PEMIS_WINDOW(KLON)
+! Longitude (radians), sine of latitude
+REAL(KIND=JPRB),   INTENT(IN) :: PGELAM(KLON)
+REAL(KIND=JPRB),   INTENT(IN) :: PGEMU(KLON)
+! Land-sea mask
+!REAL(KIND=JPRB),   INTENT(IN) :: PLAND_SEA_MASK(KLON) 
+
+! *** Variables on half levels
+REAL(KIND=JPRB),   INTENT(IN) :: PPRESSURE_H(KLON,KLEV+1)    ! (Pa)
+REAL(KIND=JPRB),   INTENT(IN) :: PTEMPERATURE_H(KLON,KLEV+1) ! (K)
+
+! *** Gas mass mixing ratios on full levels
+REAL(KIND=JPRB),   INTENT(IN) :: PQ(KLON,KLEV) 
+! AI
+REAL(KIND=JPRB),   INTENT(IN) :: PQSAT(KLON,KLEV)
+REAL(KIND=JPRB),   INTENT(IN) :: PCO2
+REAL(KIND=JPRB),   INTENT(IN) :: PCH4 
+REAL(KIND=JPRB),   INTENT(IN) :: PN2O 
+REAL(KIND=JPRB),   INTENT(IN) :: PNO2 
+REAL(KIND=JPRB),   INTENT(IN) :: PCFC11
+REAL(KIND=JPRB),   INTENT(IN) :: PCFC12
+REAL(KIND=JPRB),   INTENT(IN) :: PHCFC22
+REAL(KIND=JPRB),   INTENT(IN) :: PCCL4
+REAL(KIND=JPRB),   INTENT(IN) :: PO3(KLON,KLEV) ! AI (kg/kg) ATTENTION (Pa*kg/kg) 
+REAL(KIND=JPRB),   INTENT(IN) :: PO2
+
+! *** Cloud fraction and hydrometeor mass mixing ratios
+REAL(KIND=JPRB),   INTENT(IN) :: PCLOUD_FRAC(KLON,KLEV)
+REAL(KIND=JPRB),   INTENT(IN) :: PQ_LIQUID(KLON,KLEV)
+REAL(KIND=JPRB),   INTENT(IN) :: PQ_ICE(KLON,KLEV)
+!REAL(KIND=JPRB),   INTENT(IN) :: PQ_RAIN(KLON,KLEV)
+REAL(KIND=JPRB),   INTENT(IN) :: PQ_SNOW(KLON,KLEV)
+
+! *** Aerosol mass mixing ratios
+REAL(KIND=JPRB),   INTENT(IN) :: PAEROSOL_OLD(KLON,6,KLEV)
+REAL(KIND=JPRB),   INTENT(IN) :: PAEROSOL(KLON,KLEV,KAEROSOL)
+
+!REAL(KIND=JPRB),   INTENT(IN) :: PCCN_LAND(KLON) 
+!REAL(KIND=JPRB),   INTENT(IN) :: PCCN_SEA(KLON) 
+
+!AI mars 2021
+INTEGER(KIND=JPIM), INTENT(IN) :: IDAY
+REAL(KIND=JPRB), INTENT(IN)    :: TIME
+
+! Name of file names specified on command line
+character(len=512), INTENT(IN) :: namelist_file
+logical, INTENT(IN)            :: ok_3Deffect, debut, ok_volcan
+INTEGER(KIND=JPIM), INTENT(IN) :: flag_aerosol_strat
+
+
+! OUTPUT ARGUMENTS
+
+! *** Net fluxes on half-levels (W m-2)
+REAL(KIND=JPRB),  INTENT(OUT) :: PFLUX_SW(KLON,KLEV+1) 
+REAL(KIND=JPRB),  INTENT(OUT) :: PFLUX_LW(KLON,KLEV+1) 
+REAL(KIND=JPRB),  INTENT(OUT) :: PFLUX_SW_CLEAR(KLON,KLEV+1) 
+REAL(KIND=JPRB),  INTENT(OUT) :: PFLUX_LW_CLEAR(KLON,KLEV+1) 
+
+!*** DN and UP flux on half-levels (W m-2)
+REAL(KIND=JPRB),  INTENT(OUT) :: PFLUX_SW_DN(KLON,KLEV+1)
+REAL(KIND=JPRB),  INTENT(OUT) :: PFLUX_LW_DN(KLON,KLEV+1)
+REAL(KIND=JPRB),  INTENT(OUT) :: PFLUX_SW_DN_CLEAR(KLON,KLEV+1)
+REAL(KIND=JPRB),  INTENT(OUT) :: PFLUX_LW_DN_CLEAR(KLON,KLEV+1)
+REAL(KIND=JPRB),  INTENT(OUT) :: PFLUX_SW_UP(KLON,KLEV+1)
+REAL(KIND=JPRB),  INTENT(OUT) :: PFLUX_LW_UP(KLON,KLEV+1)
+REAL(KIND=JPRB),  INTENT(OUT) :: PFLUX_SW_UP_CLEAR(KLON,KLEV+1)
+REAL(KIND=JPRB),  INTENT(OUT) :: PFLUX_LW_UP_CLEAR(KLON,KLEV+1)
+
+! Direct component of surface flux into horizontal plane
+REAL(KIND=JPRB),  INTENT(OUT) :: PFLUX_DIR(KLON)
+REAL(KIND=JPRB),  INTENT(OUT) :: PFLUX_DIR_CLEAR(KLON)
+! As PFLUX_DIR but into a plane perpendicular to the sun
+REAL(KIND=JPRB),  INTENT(OUT) :: PFLUX_DIR_INTO_SUN(KLON)
+
+! *** Ultraviolet and photosynthetically active radiation (W m-2)
+REAL(KIND=JPRB),  INTENT(OUT) :: PFLUX_UV(KLON)
+REAL(KIND=JPRB),  INTENT(OUT) :: PFLUX_PAR(KLON)
+REAL(KIND=JPRB),  INTENT(OUT) :: PFLUX_PAR_CLEAR(KLON)
+
+! Diagnosed longwave surface emissivity across the whole spectrum
+REAL(KIND=JPRB),  INTENT(OUT) :: PEMIS_OUT(KLON)   
+
+! Partial derivative of total-sky longwave upward flux at each level
+! with respect to upward flux at surface, used to correct heating
+! rates at gridpoints/timesteps between calls to the full radiation
+! scheme.  Note that this version uses the convention of level index
+! increasing downwards, unlike the local variable ZLwDerivative that
+! is returned from the LW radiation scheme.
+REAL(KIND=JPRB),  INTENT(OUT) :: PLWDERIVATIVE(KLON,KLEV+1)
+
+! Surface diffuse and direct downwelling shortwave flux in each
+! shortwave albedo band, used in RADINTG to update the surface fluxes
+! accounting for high-resolution albedo information
+REAL(KIND=JPRB),  INTENT(OUT) :: PSWDIFFUSEBAND(KLON,NSW)
+REAL(KIND=JPRB),  INTENT(OUT) :: PSWDIRECTBAND (KLON,NSW)
+
+!AI Nov 2023
+REAL(KIND=JPRB),  INTENT(OUT) :: ecrad_cloud_cover_sw(KLON)
+
+! LOCAL VARIABLES
+! AI ATTENTION
+type(config_type),save         :: rad_config
+!!$OMP THREADPRIVATE(rad_config)
+type(driver_config_type),save  :: driver_config
+!!$OMP THREADPRIVATE(driver_config)
+TYPE(single_level_type)   :: single_level
+TYPE(thermodynamics_type) :: thermodynamics
+TYPE(gas_type)            :: gas
+TYPE(cloud_type)          :: cloud
+TYPE(aerosol_type)        :: aerosol
+TYPE(flux_type)           :: flux
+
+! Mass mixing ratio of ozone (kg/kg)
+REAL(KIND=JPRB)           :: ZO3(KLON,KLEV)
+
+! Cloud effective radii in microns
+REAL(KIND=JPRB)           :: ZRE_LIQUID_UM(KLON,KLEV)
+REAL(KIND=JPRB)           :: ZRE_ICE_UM(KLON,KLEV)
+
+! Cloud overlap decorrelation length for cloud boundaries in km
+REAL(KIND=JPRB)           :: ZDECORR_LEN_M
+REAL(KIND=JPRB)           :: ZDECORR_LEN_M_1D(KLON)
+REAL(KIND=JPRB)           :: ZDECORR_LEN_M_2D(KLON,KLEV)
+
+! Ratio of cloud overlap decorrelation length for cloud water
+! inhomogeneities to that for cloud boundaries (typically 0.5)
+!REAL(KIND=JPRB)           :: ZDECORR_LEN_RATIO = 0.5_jprb
+
+! The surface net longwave flux if the surface was a black body, used
+! to compute the effective broadband surface emissivity
+REAL(KIND=JPRB)           :: ZBLACK_BODY_NET_LW(KIDIA:KFDIA)
+
+! Layer mass in kg m-2
+REAL(KIND=JPRB)           :: ZLAYER_MASS(KIDIA:KFDIA,KLEV)
+
+! Time integers
+INTEGER :: ITIM
+
+! Loop indices
+INTEGER :: JLON, JLEV, JBAND, JB_ALBEDO, JAER
+
+REAL(KIND=JPRB) :: ZHOOK_HANDLE
+
+! AI ATTENTION traitement aerosols
+INTEGER, PARAMETER :: NAERMACC = 1
+
+logical :: loutput=.true.
+logical :: lprint_input=.false.
+logical :: lprint_config=.false.
+logical, save :: debut_ecrad=.true.
+!$OMP THREADPRIVATE(debut_ecrad)
+integer, save :: itap_ecrad=0
+!$OMP THREADPRIVATE(itap_ecrad)
+
+REAL(KIND=JPRB) ::  inv_cloud_effective_size(KLON,KLEV)
+REAL(KIND=JPRB) ::  inv_inhom_effective_size(KLON,KLEV)
+
+integer :: irang
+
+
+IF (LHOOK) CALL DR_HOOK('RADIATION_SCHEME',0,ZHOOK_HANDLE)
+
+  print*,'Entree radiation_scheme, ok_3Deffect, namelist_file = ', &
+          ok_3Deffect, namelist_file
+! A.I juillet 2023 : 
+! Initialisation dans radiation_setup au 1er passage dans Ecrad
+!$OMP MASTER
+  if (debut_ecrad) then
+   call SETUP_RADIATION_SCHEME(loutput,namelist_file,rad_config,driver_config)
+   debut_ecrad=.false. 
+  endif 
+!$OMP END MASTER
+!$OMP BARRIER 
+! Fin partie initialisation et configuration 
+
+!AI print fichiers namelist utilise
+!if (is_omp_root) then
+! itap_ecrad=itap_ecrad+1
+! print*,'Dans radiation_scheme itap_ecrad, mpi_rank, omp_rank, namelist_file : ', &
+!         itap_ecrad, mpi_rank, omp_rank, namelist_file
+!else
+! print*,'mpi_rank omp_rank, namelist_file :', mpi_rank, omp_rank, namelist_file
+!endif
+
+! AI 11 23 Allocates depplaces au debut
+print*,'*********** ALLOCATES *******************************'
+! AI ATTENTION
+! Allocate memory in radiation objects
+! emissivite avec une seule bande
+CALL single_level%allocate(KLON, NSW, 1, &
+     &                     use_sw_albedo_direct=.TRUE.)
+CALL thermodynamics%allocate(KLON, KLEV, use_h2o_sat=.true.)
+CALL cloud%allocate(KLON, KLEV)
+CALL aerosol%allocate(KLON, 1, KLEV, KAEROSOL)
+CALL gas%allocate(KLON, KLEV)
+CALL flux%allocate(rad_config, 1, KLON, KLEV)
+
+print*,'************* THERMO (input) ************************************'
+! AI
+! pressure_hl > paprs
+! temperature_hl calculee dans radlsw de la meme facon que pour RRTM
+thermodynamics%pressure_hl   (KIDIA:KFDIA,:) = PPRESSURE_H   (KIDIA:KFDIA,:)
+thermodynamics%temperature_hl(KIDIA:KFDIA,:) = PTEMPERATURE_H(KIDIA:KFDIA,:)
+!print*,'Compute saturation specific humidity'
+! Compute saturation specific humidity, used to hydrate aerosols. The
+! "2" for the last argument indicates that the routine is not being
+! called from within the convection scheme.
+!CALL SATUR(KIDIA, KFDIA, KLON, 1, KLEV, &
+!     &  PPRESSURE, PTEMPERATURE, thermodynamics%h2o_sat_liq, 2)
+! Alternative approximate version using temperature and pressure from
+! the thermodynamics structure
+!CALL thermodynamics%calc_saturation_wrt_liquid(KIDIA, KFDIA)
+!AI ATTENTION
+thermodynamics%h2o_sat_liq = PQSAT
+
+print*,'********** SINGLE LEVEL VARS **********************************'
+!AI ATTENTION
+! Set single-level fileds
+single_level%solar_irradiance              = PSOLAR_IRRADIANCE
+single_level%cos_sza(KIDIA:KFDIA)          = PMU0(KIDIA:KFDIA)
+single_level%skin_temperature(KIDIA:KFDIA) = PTEMPERATURE_SKIN(KIDIA:KFDIA)
+single_level%sw_albedo(KIDIA:KFDIA,:)      = PALBEDO_DIF(KIDIA:KFDIA,:)
+single_level%sw_albedo_direct(KIDIA:KFDIA,:)=PALBEDO_DIR(KIDIA:KFDIA,:)
+single_level%lw_emissivity(KIDIA:KFDIA,1)  = PEMIS(KIDIA:KFDIA)
+!single_level%lw_emissivity(KIDIA:KFDIA,2)  = PEMIS_WINDOW(KIDIA:KFDIA)
+
+! Create the relevant seed from date and time get the starting day
+! and number of minutes since start
+!IDAY = NDD(NINDAT)
+!cur_day
+!ITIM = NINT(NSTEP * YRRIP%TSTEP / 60.0_JPRB)
+!ITIM = NINT(TIME / 60.0_JPRB)
+!current_time
+!allocate(single_level%iseed(KIDIA:KFDIA))
+!DO JLON = KIDIA, KFDIA
+  ! This method gives a unique value for roughly every 1-km square
+  ! on the globe and every minute.  ASIN(PGEMU)*60 gives rough
+  ! latitude in degrees, which we multiply by 100 to give a unique
+  ! value for roughly every km. PGELAM*60*100 gives a unique number
+  ! for roughly every km of longitude around the equator, which we
+  ! multiply by 180*100 so there is no overlap with the latitude
+  ! values.  The result can be contained in a 32-byte integer (but
+  ! since random numbers are generated with the help of integer
+  ! overflow, it should not matter if the number did overflow).
+!  single_level%iseed(JLON) = ITIM + IDAY & 
+!       &  +  NINT(PGELAM(JLON)*108000000.0_JPRB &
+!       &          + ASIN(PGEMU(JLON))*6000.0_JPRB)
+!ENDDO
+!AI Nov 23
+! Simple initialization of the seeds for the Monte Carlo scheme
+call single_level%init_seed_simple(kidia, kfdia)
+
+print*,'********** CLOUDS (allocate + input) *******************************************'
+!print*,'Appel Allocate clouds'
+! Set cloud fields
+cloud%q_liq(KIDIA:KFDIA,:)    = PQ_LIQUID(KIDIA:KFDIA,:)
+cloud%q_ice(KIDIA:KFDIA,:)    = PQ_ICE(KIDIA:KFDIA,:) + PQ_SNOW(KIDIA:KFDIA,:)
+cloud%fraction(KIDIA:KFDIA,:) = PCLOUD_FRAC(KIDIA:KFDIA,:)
+!!! ok AI ATTENTION a voir avec JL
+! Compute effective radi and convert to metres
+! AI. : on passe directement les champs de LMDZ
+cloud%re_liq(KIDIA:KFDIA,:) = ZRE_LIQUID_UM(KIDIA:KFDIA,:)
+cloud%re_ice(KIDIA:KFDIA,:) = ZRE_ICE_UM(KIDIA:KFDIA,:)
+! Get the cloud overlap decorrelation length (for cloud boundaries),
+! in km, according to the parameterization specified by NDECOLAT,
+! and insert into the "cloud" object. Also get the ratio of
+! decorrelation lengths for cloud water content inhomogeneities and
+! cloud boundaries, and set it in the "rad_config" object.
+! IFS :
+!CALL CLOUD_OVERLAP_DECORR_LEN(KIDIA, KFDIA, KLON, PGEMU, YRERAD%NDECOLAT, &
+!     &    ZDECORR_LEN_KM, PDECORR_LEN_RATIO=ZDECORR_LEN_RATIO)
+CALL CALCUL_CLOUD_OVERLAP_DECORR_LEN &
+     & (KIDIA, KFDIA, KLON, KLEV, &
+     &  driver_config, &
+     &  thermodynamics%pressure_hl, &
+     &  ZDECORR_LEN_M_2D)
+
+ if (driver_config%kdecolat.eq.0) then
+  ZDECORR_LEN_M = ZDECORR_LEN_M_2D(1,1)       
+  DO JLON = KIDIA,KFDIA
+   CALL cloud%set_overlap_param(thermodynamics, &
+       &                 ZDECORR_LEN_M, &
+       &                 istartcol=JLON, iendcol=JLON)
+  ENDDO
+ else if (driver_config%kdecolat.eq.1.or.driver_config%kdecolat.eq.2) then
+  ZDECORR_LEN_M_1D = ZDECORR_LEN_M_2D(:,1)
+  DO JLON = KIDIA,KFDIA
+   CALL cloud%set_overlap_param(thermodynamics, &
+       &                 ZDECORR_LEN_M_1D, &
+       &                 istartcol=JLON, iendcol=JLON)
+  ENDDO
+ else if (driver_config%kdecolat.eq.3) then
+  DO JLON = KIDIA,KFDIA
+   CALL cloud%set_overlap_param_var2D(thermodynamics, &
+       &                 ZDECORR_LEN_M_2D, KLEV, &
+       &                 istartcol=JLON, iendcol=JLON)
+  ENDDO
+ endif
+
+
+
+! IFS :
+! Cloud water content fractional standard deviation is configurable
+! from namelist NAERAD but must be globally constant. Before it was
+! hard coded at 1.0.
+!CALL cloud%create_fractional_std(KLON, KLEV, YRERAD%RCLOUD_FRAC_STD)
+! AI ATTENTION frac_std=0.75 meme valeur que dans la version offline
+CALL cloud%create_fractional_std(KLON, KLEV, driver_config%frac_std)
+
+!if (ok_3Deffect) then
+! if (driver_config%ok_effective_size) then
+!     call cloud%create_inv_cloud_effective_size_eta(klon, klev, &
+!               &  thermodynamics%pressure_hl, &
+!               &  driver_config%low_inv_effective_size, &
+!               &  driver_config%middle_inv_effective_size, &
+!               &  driver_config%high_inv_effective_size, 0.8_jprb, 0.45_jprb, &
+!               &  KIDIA, KFDIA)
+!   else if (driver_config%ok_separation) then
+!     call cloud%param_cloud_effective_separation_eta(klon, klev, &
+!               &  thermodynamics%pressure_hl, &
+!               &  driver_config%cloud_separation_scale_surface, &
+!               &  driver_config%cloud_separation_scale_toa, &
+!               &  driver_config%cloud_separation_scale_power, &
+!               &  driver_config%cloud_inhom_separation_factor, &
+!               &  KIDIA, KFDIA)
+!   endif     
+! else  
+ if (rad_config%i_solver_sw == ISolverSPARTACUS &
+      & .or.   rad_config%i_solver_lw == ISolverSPARTACUS) then
+   ! AI ! Read cloud properties needed by SPARTACUS
+   if (driver_config%ok_effective_size) then
+     call cloud%create_inv_cloud_effective_size_eta(klon, klev, &
+               &  thermodynamics%pressure_hl, &
+               &  driver_config%low_inv_effective_size, &
+               &  driver_config%middle_inv_effective_size, &
+               &  driver_config%high_inv_effective_size, 0.8_jprb, 0.45_jprb, &
+               &  KIDIA, KFDIA)
+   else if (driver_config%ok_separation) then
+     call cloud%param_cloud_effective_separation_eta(klon, klev, &
+               &  thermodynamics%pressure_hl, &
+               &  driver_config%cloud_separation_scale_surface, &
+               &  driver_config%cloud_separation_scale_toa, &
+               &  driver_config%cloud_separation_scale_power, &
+               &  driver_config%cloud_inhom_separation_factor, &
+               &  KIDIA, KFDIA)
+   endif
+ endif  
+!endif
+
+print*,'******** AEROSOLS (input) **************************************'
+!IF (NAERMACC > 0) THEN
+!ELSE
+!  CALL aerosol%allocate(KLON, 1, KLEV, 6) ! Tegen climatology
+!ENDIF
+! Compute the dry mass of each layer neglecting humidity effects, in
+! kg m-2, needed to scale some of the aerosol inputs
+! AI commente ATTENTION
+!CALL thermodynamics%get_layer_mass(ZLAYER_MASS)
+
+! Copy over aerosol mass mixing ratio
+!IF (NAERMACC > 0) THEN
+
+  ! MACC aerosol climatology - this is already in mass mixing ratio
+  ! units with the required array orientation so we can copy it over
+  ! directly
+  aerosol%mixing_ratio(KIDIA:KFDIA,:,:) = PAEROSOL(KIDIA:KFDIA,:,:)
+
+  ! Add the tropospheric and stratospheric backgrounds contained in the
+  ! old Tegen arrays - this is very ugly!
+! AI ATTENTION
+!  IF (TROP_BG_AER_MASS_EXT > 0.0_JPRB) THEN
+!    aerosol%mixing_ratio(KIDIA:KFDIA,:,ITYPE_TROP_BG_AER) &
+!         &  = aerosol%mixing_ratio(KIDIA:KFDIA,:,ITYPE_TROP_BG_AER) &
+!         &  + PAEROSOL_OLD(KIDIA:KFDIA,1,:) &
+!         &  / (ZLAYER_MASS * TROP_BG_AER_MASS_EXT)
+!  ENDIF
+!  IF (STRAT_BG_AER_MASS_EXT > 0.0_JPRB) THEN
+!    aerosol%mixing_ratio(KIDIA:KFDIA,:,ITYPE_STRAT_BG_AER) &
+!         &  = aerosol%mixing_ratio(KIDIA:KFDIA,:,ITYPE_STRAT_BG_AER) &
+!         &  + PAEROSOL_OLD(KIDIA:KFDIA,6,:) &
+!         &  / (ZLAYER_MASS * STRAT_BG_AER_MASS_EXT)
+!  ENDIF
+
+!ELSE
+
+  ! Tegen aerosol climatology - the array PAEROSOL_OLD contains the
+  ! 550-nm optical depth in each layer. The optics data file
+  ! aerosol_ifs_rrtm_tegen.nc does not contain mass extinction
+  ! coefficient, but a scaling factor that the 550-nm optical depth
+  ! should be multiplied by to obtain the optical depth in each
+  ! spectral band.  Therefore, in order for the units to work out, we
+  ! need to divide by the layer mass (in kg m-2) to obtain the 550-nm
+  ! cross-section per unit mass of dry air (so in m2 kg-1).  We also
+  ! need to permute the array.
+!  DO JLEV = 1,KLEV
+!    DO JAER = 1,6
+!      aerosol%mixing_ratio(KIDIA:KFDIA,JLEV,JAER) &
+!         &  = PAEROSOL_OLD(KIDIA:KFDIA,JAER,JLEV) &
+!         &  / ZLAYER_MASS(KIDIA:KFDIA,JLEV)
+!    ENDDO
+!  ENDDO
+!ENDIF
+
+print*,'********** GAS (input) ************************************************'
+!print*,'Appel Allocate gas'
+! Convert ozone Pa*kg/kg to kg/kg
+! AI ATTENTION
+!DO JLEV = 1,KLEV
+!  DO JLON = KIDIA,KFDIA
+!    ZO3(JLON,JLEV) = PO3_DP(JLON,JLEV) &
+!         &         / (PPRESSURE_H(JLON,JLEV+1)-PPRESSURE_H(JLON,JLEV))
+!  ENDDO
+!ENDDO
+!  Insert gas mixing ratios
+!print*,'Insert gas mixing ratios'
+CALL gas%put(IH2O,    IMassMixingRatio, PQ)
+CALL gas%put(IO3,     IMassMixingRatio, PO3)
+CALL gas%put_well_mixed(ICO2,    IMAssMixingRatio, PCO2)
+CALL gas%put_well_mixed(ICH4,    IMassMixingRatio, PCH4)
+CALL gas%put_well_mixed(IN2O,    IMassMixingRatio, PN2O)
+CALL gas%put_well_mixed(ICFC11,  IMassMixingRatio, PCFC11)
+CALL gas%put_well_mixed(ICFC12,  IMassMixingRatio, PCFC12)
+CALL gas%put_well_mixed(IHCFC22, IMassMixingRatio, PHCFC22)
+CALL gas%put_well_mixed(ICCL4,   IMassMixingRatio, PCCL4)
+CALL gas%put_well_mixed(IO2,     IMassMixingRatio, PO2)
+! Ensure the units of the gas mixing ratios are what is required by
+! the gas absorption model
+call set_gas_units(rad_config, gas)
+
+! Call radiation scheme
+!print*,'*** Appel radiation *** namelist **** omp_rank ****', &
+!         omp_rank, namelist_file
+!   if (rad_config%i_solver_sw == ISolverSPARTACUS) then 
+!    if (driver_config%ok_separation) then
+!      print*,'Avant radiation, mpi_rank, omp_rank, size, chape inv_cloud = ',&
+!              mpi_rank, omp_rank, &
+!              shape(cloud%inv_cloud_effective_size), &
+!              size(cloud%inv_cloud_effective_size)      
+!      do jlon=KIDIA, KFDIA      
+!        do jlev=1,klev
+!         print*,' Avant radiation mpi_rank, omp_rank, jlon, jlev, &
+!            &     cloud%inv_cloud_effective_size =', mpi_rank, &
+!            &     omp_rank, jlon, jlev, &
+!            &     cloud%inv_cloud_effective_size(jlon,jlev)
+!        enddo
+!      enddo
+!       cloud%inv_cloud_effective_size=inv_cloud_effective_size
+!       cloud%inv_inhom_effective_size=inv_inhom_effective_size
+!    endif
+!   endif
+CALL radiation(KLON, KLEV, KIDIA, KFDIA, rad_config, &
+     &  single_level, thermodynamics, gas, cloud, aerosol, flux)
+
+ if (rad_config%use_aerosols) then
+    if (rad_config%i_gas_model_sw == IGasModelIFSRRTMG .or. &
+     &  rad_config%i_gas_model_lw == IGasModelIFSRRTMG) then     
+       CALL aeropt_5wv_ecrad(kidia, kfdia, 1, klev,     &
+     &                       rad_config,thermodynamics, aerosol)
+    endif                 
+
+    if (flag_aerosol_strat.eq.2) then
+       CALL readaerosolstrato_ecrad(rad_config, debut, ok_volcan)
+    endif
+ endif               
+
+print*,'*********** Sortie flux ****************'
+! Cloud cover
+ecrad_cloud_cover_sw = flux%cloud_cover_sw
+! Compute required output fluxes
+! DN and UP flux
+PFLUX_SW_DN(KIDIA:KFDIA,:) = flux%sw_dn(KIDIA:KFDIA,:)
+PFLUX_SW_UP(KIDIA:KFDIA,:) = flux%sw_up(KIDIA:KFDIA,:)
+PFLUX_LW_DN(KIDIA:KFDIA,:) = flux%lw_dn(KIDIA:KFDIA,:)
+PFLUX_LW_UP(KIDIA:KFDIA,:) = flux%lw_up(KIDIA:KFDIA,:)
+PFLUX_SW_DN_CLEAR(KIDIA:KFDIA,:) = flux%sw_dn_clear(KIDIA:KFDIA,:)
+PFLUX_SW_UP_CLEAR(KIDIA:KFDIA,:) = flux%sw_up_clear(KIDIA:KFDIA,:)
+PFLUX_LW_DN_CLEAR(KIDIA:KFDIA,:) = flux%lw_dn_clear(KIDIA:KFDIA,:)
+PFLUX_LW_UP_CLEAR(KIDIA:KFDIA,:) = flux%lw_up_clear(KIDIA:KFDIA,:)
+! First the net fluxes
+PFLUX_SW(KIDIA:KFDIA,:) = flux%sw_dn(KIDIA:KFDIA,:) - flux%sw_up(KIDIA:KFDIA,:)
+PFLUX_LW(KIDIA:KFDIA,:) = flux%lw_dn(KIDIA:KFDIA,:) - flux%lw_up(KIDIA:KFDIA,:)
+PFLUX_SW_CLEAR(KIDIA:KFDIA,:) &
+     &  = flux%sw_dn_clear(KIDIA:KFDIA,:) - flux%sw_up_clear(KIDIA:KFDIA,:)
+PFLUX_LW_CLEAR(KIDIA:KFDIA,:) &
+     &  = flux%lw_dn_clear(KIDIA:KFDIA,:) - flux%lw_up_clear(KIDIA:KFDIA,:)
+! Now the surface fluxes
+!PFLUX_SW_DN_SURF(KIDIA:KFDIA) = flux%sw_dn(KIDIA:KFDIA,KLEV+1)
+!PFLUX_LW_DN_SURF(KIDIA:KFDIA) = flux%lw_dn(KIDIA:KFDIA,KLEV+1)
+!PFLUX_SW_UP_SURF(KIDIA:KFDIA) = flux%sw_up(KIDIA:KFDIA,KLEV+1)
+!PFLUX_LW_UP_SURF(KIDIA:KFDIA) = flux%lw_up(KIDIA:KFDIA,KLEV+1)
+!PFLUX_SW_DN_CLEAR_SURF(KIDIA:KFDIA) = flux%sw_dn_clear(KIDIA:KFDIA,KLEV+1)
+!PFLUX_LW_DN_CLEAR_SURF(KIDIA:KFDIA) = flux%lw_dn_clear(KIDIA:KFDIA,KLEV+1)
+!PFLUX_SW_UP_CLEAR_SURF(KIDIA:KFDIA) = flux%sw_up_clear(KIDIA:KFDIA,KLEV+1)
+!PFLUX_LW_UP_CLEAR_SURF(KIDIA:KFDIA) = flux%lw_up_clear(KIDIA:KFDIA,KLEV+1)
+PFLUX_DIR(KIDIA:KFDIA) = flux%sw_dn_direct(KIDIA:KFDIA,KLEV+1)
+PFLUX_DIR_CLEAR(KIDIA:KFDIA) = flux%sw_dn_direct_clear(KIDIA:KFDIA,KLEV+1)
+PFLUX_DIR_INTO_SUN(KIDIA:KFDIA) = 0.0_JPRB
+WHERE (PMU0(KIDIA:KFDIA) > EPSILON(1.0_JPRB))
+  PFLUX_DIR_INTO_SUN(KIDIA:KFDIA) = PFLUX_DIR(KIDIA:KFDIA) / PMU0(KIDIA:KFDIA)
+END WHERE
+! Top-of-atmosphere downwelling flux
+!PFLUX_SW_DN_TOA(KIDIA:KFDIA) = flux%sw_dn(KIDIA:KFDIA,1)
+!PFLUX_SW_UP_TOA(KIDIA:KFDIA) = flux%sw_up(KIDIA:KFDIA,1)
+!PFLUX_LW_DN_TOA(KIDIA:KFDIA) = flux%lw_dn(KIDIA:KFDIA,1)
+!PFLUX_LW_UP_TOA(KIDIA:KFDIA) = flux%lw_up(KIDIA:KFDIA,1)
+!AI ATTENTION
+if (0.eq.1) then
+PFLUX_UV       (KIDIA:KFDIA) = 0.0_JPRB
+DO JBAND = 1,NWEIGHT_UV
+  PFLUX_UV(KIDIA:KFDIA) = PFLUX_UV(KIDIA:KFDIA) + WEIGHT_UV(JBAND) &
+       &  * flux%sw_dn_surf_band(IBAND_UV(JBAND),KIDIA:KFDIA)
+ENDDO
+! Compute photosynthetically active radiation similarly
+PFLUX_PAR      (KIDIA:KFDIA) = 0.0_JPRB
+PFLUX_PAR_CLEAR(KIDIA:KFDIA) = 0.0_JPRB
+DO JBAND = 1,NWEIGHT_PAR
+  PFLUX_PAR(KIDIA:KFDIA) = PFLUX_PAR(KIDIA:KFDIA) + WEIGHT_PAR(JBAND) &
+       &  * flux%sw_dn_surf_band(IBAND_PAR(JBAND),KIDIA:KFDIA)
+  PFLUX_PAR_CLEAR(KIDIA:KFDIA) = PFLUX_PAR_CLEAR(KIDIA:KFDIA) &
+       &  + WEIGHT_PAR(JBAND) &
+       &  * flux%sw_dn_surf_clear_band(IBAND_PAR(JBAND),KIDIA:KFDIA)
+ENDDO
+endif
+! Compute effective broadband emissivity
+ZBLACK_BODY_NET_LW = flux%lw_dn(KIDIA:KFDIA,KLEV+1) &
+     &  - RSIGMA*PTEMPERATURE_SKIN(KIDIA:KFDIA)**4
+PEMIS_OUT(KIDIA:KFDIA) = PEMIS(KIDIA:KFDIA)
+WHERE (ABS(ZBLACK_BODY_NET_LW) > 1.0E-5) 
+  PEMIS_OUT(KIDIA:KFDIA) = PFLUX_LW(KIDIA:KFDIA,KLEV+1) / ZBLACK_BODY_NET_LW
+END WHERE
+! Copy longwave derivatives
+! AI ATTENTION
+!IF (YRERAD%LAPPROXLWUPDATE) THEN
+IF (rad_config%do_lw_derivatives) THEN
+  PLWDERIVATIVE(KIDIA:KFDIA,:) = flux%lw_derivatives(KIDIA:KFDIA,:)
+END IF
+! Store the shortwave downwelling fluxes in each albedo band
+!AI ATTENTION
+!IF (YRERAD%LAPPROXSWUPDATE) THEN
+if (0.eq.1) then
+IF (rad_config%do_surface_sw_spectral_flux) THEN
+  PSWDIFFUSEBAND(KIDIA:KFDIA,:) = 0.0_JPRB
+  PSWDIRECTBAND (KIDIA:KFDIA,:) = 0.0_JPRB
+  DO JBAND = 1,rad_config%n_bands_sw
+    JB_ALBEDO = rad_config%i_albedo_from_band_sw(JBAND)
+    DO JLON = KIDIA,KFDIA
+      PSWDIFFUSEBAND(JLON,JB_ALBEDO) = PSWDIFFUSEBAND(JLON,JB_ALBEDO) &
+           &  + flux%sw_dn_surf_band(JBAND,JLON) &
+           &  - flux%sw_dn_direct_surf_band(JBAND,JLON)
+      PSWDIRECTBAND(JLON,JB_ALBEDO)  = PSWDIRECTBAND(JLON,JB_ALBEDO) &
+           &  + flux%sw_dn_direct_surf_band(JBAND,JLON)
+    ENDDO
+  ENDDO
+ENDIF
+endif
+
+print*,'********** DEALLOCATIONS ************************'
+CALL single_level%deallocate
+CALL thermodynamics%deallocate
+CALL gas%deallocate
+CALL cloud%deallocate
+CALL aerosol%deallocate
+CALL flux%deallocate
+
+IF (LHOOK) CALL DR_HOOK('RADIATION_SCHEME',1,ZHOOK_HANDLE)
+
+END SUBROUTINE RADIATION_SCHEME
+
+SUBROUTINE RADIATION_SCHEME_S2 &
+! Inputs
+     & (KIDIA, KFDIA, KLON, KLEV, KAEROSOL, NSW, &
+     &  namelist_file, ok_3Deffect, &
+     &  debut, ok_volcan, flag_aerosol_strat, &
+     &  IDAY, TIME, &
+     &  PSOLAR_IRRADIANCE, &
+     &  PMU0, PTEMPERATURE_SKIN, &
+     &  PALBEDO_DIF, PALBEDO_DIR, &
+     &  PEMIS, PEMIS_WINDOW, &
+     &  PGELAM, PGEMU, &
+     &  PPRESSURE_H, PTEMPERATURE_H, PQ, PQSAT, &
+     &  PCO2, PCH4, PN2O, PNO2, PCFC11, PCFC12, PHCFC22, &
+     &  PCCL4, PO3, PO2, &
+     &  PCLOUD_FRAC, PQ_LIQUID, PQ_ICE, PQ_SNOW, &
+     &  ZRE_LIQUID_UM, ZRE_ICE_UM, &
+     &  PAEROSOL_OLD, PAEROSOL, &
+! Outputs
+     &  PFLUX_SW, PFLUX_LW, PFLUX_SW_CLEAR, PFLUX_LW_CLEAR, &
+     &  PFLUX_SW_DN, PFLUX_LW_DN, PFLUX_SW_DN_CLEAR, PFLUX_LW_DN_CLEAR, &
+     &  PFLUX_SW_UP, PFLUX_LW_UP, PFLUX_SW_UP_CLEAR, PFLUX_LW_UP_CLEAR, &
+     &  PFLUX_DIR, PFLUX_DIR_CLEAR, PFLUX_DIR_INTO_SUN, &
+     &  PFLUX_UV, PFLUX_PAR, PFLUX_PAR_CLEAR, &
+     &  PEMIS_OUT, PLWDERIVATIVE, &
+     &  PSWDIFFUSEBAND, PSWDIRECTBAND, &
+     &  ecrad_cloud_cover_sw)
+
+! RADIATION_SCHEME - Interface to modular radiation scheme
+!
+! (C) Copyright 2015- ECMWF.
+!
+! This software is licensed under the terms of the Apache Licence Version 2.0
+! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0.
+!
+! In applying this licence, ECMWF does not waive the privileges and immunities
+! granted to it by virtue of its status as an intergovernmental organisation
+! nor does it submit to any jurisdiction.
+!
+! PURPOSE
+! -------
+!   The modular radiation scheme is contained in a separate
+!   library. This routine puts the the IFS arrays into appropriate
+!   objects, computing the additional data that is required, and sends
+!   it to the radiation scheme.  It returns net fluxes and surface
+!   flux components needed by the rest of the model. 
+!
+!   Lower case is used for variables and types taken from the
+!   radiation library
+!
+! INTERFACE
+! ---------
+!    RADIATION_SCHEME is called from RADLSWR. The
+!    SETUP_RADIATION_SCHEME routine (in the RADIATION_SETUP module)
+!    should have been run first.
+!
+! AUTHOR
+! ------
+!   Robin Hogan, ECMWF
+!   Original: 2015-09-16
+!
+! MODIFICATIONS
+! -------------
+!
+! TO DO
+! -----
+!
+!-----------------------------------------------------------------------
+
+! Modules from ifs or ifsaux libraries
+USE PARKIND1 , ONLY : JPIM, JPRB
+USE YOMHOOK  , ONLY : LHOOK, DR_HOOK
+USE RADIATION_SETUP
+USE YOMCST   , ONLY : RSIGMA ! Stefan-Boltzmann constant
+!USE RADIATION_SETUP, ONLY : SETUP_RADIATION_SCHEME, &
+!                         &  config_type, driver_config_type, &
+!                         &  NWEIGHT_UV,  IBAND_UV,  WEIGHT_UV, &
+!                         &  NWEIGHT_PAR, IBAND_PAR, WEIGHT_PAR, &
+!                         &  ITYPE_TROP_BG_AER,  TROP_BG_AER_MASS_EXT, &
+!                         &  ITYPE_STRAT_BG_AER, STRAT_BG_AER_MASS_EXT, &
+!                         &  ISolverSpartacus
+
+! Modules from radiation library
+USE radiation_single_level,   ONLY : single_level_type
+USE radiation_thermodynamics, ONLY : thermodynamics_type
+USE radiation_gas
+USE radiation_cloud,          ONLY : cloud_type
+USE radiation_aerosol,        ONLY : aerosol_type
+USE radiation_flux,           ONLY : flux_type
+USE radiation_interface,      ONLY : radiation, set_gas_units
+USE radiation_save,           ONLY : save_inputs
+
+USE mod_phys_lmdz_para
+
+IMPLICIT NONE
+
+! INPUT ARGUMENTS
+! *** Array dimensions and ranges
+INTEGER(KIND=JPIM),INTENT(IN) :: KIDIA    ! Start column to process
+INTEGER(KIND=JPIM),INTENT(IN) :: KFDIA    ! End column to process
+!INTEGER, INTENT(IN) :: KIDIA, KFDIA
+INTEGER(KIND=JPIM),INTENT(IN) :: KLON     ! Number of columns
+INTEGER(KIND=JPIM),INTENT(IN) :: KLEV     ! Number of levels
+!INTEGER, INTENT(IN) :: KLON, KLEV
+!INTEGER(KIND=JPIM),INTENT(IN) :: KAEROLMDZ ! Number of aerosol types
+INTEGER(KIND=JPIM),INTENT(IN) :: KAEROSOL
+INTEGER(KIND=JPIM),INTENT(IN) :: NSW ! Numbe of bands
+
+! AI ATTENTION
+!INTEGER, PARAMETER :: KAEROSOL = 12
+
+! *** Single-level fields
+REAL(KIND=JPRB),   INTENT(IN) :: PSOLAR_IRRADIANCE ! (W m-2)
+REAL(KIND=JPRB),   INTENT(IN) :: PMU0(KLON) ! Cosine of solar zenith ang
+REAL(KIND=JPRB),   INTENT(IN) :: PTEMPERATURE_SKIN(KLON) ! (K)
+! Diffuse and direct components of surface shortwave albedo
+!REAL(KIND=JPRB),   INTENT(IN) :: PALBEDO_DIF(KLON,YRERAD%NSW)
+!REAL(KIND=JPRB),   INTENT(IN) :: PALBEDO_DIR(KLON,YRERAD%NSW)
+REAL(KIND=JPRB),   INTENT(IN) :: PALBEDO_DIF(KLON,NSW)
+REAL(KIND=JPRB),   INTENT(IN) :: PALBEDO_DIR(KLON,NSW)
+! Longwave emissivity outside and inside the window region
+REAL(KIND=JPRB),   INTENT(IN) :: PEMIS(KLON)
+REAL(KIND=JPRB),   INTENT(IN) :: PEMIS_WINDOW(KLON)
+! Longitude (radians), sine of latitude
+REAL(KIND=JPRB),   INTENT(IN) :: PGELAM(KLON)
+REAL(KIND=JPRB),   INTENT(IN) :: PGEMU(KLON)
+! Land-sea mask
+!REAL(KIND=JPRB),   INTENT(IN) :: PLAND_SEA_MASK(KLON) 
+
+! *** Variables on half levels
+REAL(KIND=JPRB),   INTENT(IN) :: PPRESSURE_H(KLON,KLEV+1)    ! (Pa)
+REAL(KIND=JPRB),   INTENT(IN) :: PTEMPERATURE_H(KLON,KLEV+1) ! (K)
+
+! *** Gas mass mixing ratios on full levels
+REAL(KIND=JPRB),   INTENT(IN) :: PQ(KLON,KLEV) 
+! AI
+REAL(KIND=JPRB),   INTENT(IN) :: PQSAT(KLON,KLEV)
+REAL(KIND=JPRB),   INTENT(IN) :: PCO2
+REAL(KIND=JPRB),   INTENT(IN) :: PCH4 
+REAL(KIND=JPRB),   INTENT(IN) :: PN2O 
+REAL(KIND=JPRB),   INTENT(IN) :: PNO2 
+REAL(KIND=JPRB),   INTENT(IN) :: PCFC11
+REAL(KIND=JPRB),   INTENT(IN) :: PCFC12
+REAL(KIND=JPRB),   INTENT(IN) :: PHCFC22
+REAL(KIND=JPRB),   INTENT(IN) :: PCCL4
+REAL(KIND=JPRB),   INTENT(IN) :: PO3(KLON,KLEV) ! AI (kg/kg) ATTENTION (Pa*kg/kg) 
+REAL(KIND=JPRB),   INTENT(IN) :: PO2
+
+! *** Cloud fraction and hydrometeor mass mixing ratios
+REAL(KIND=JPRB),   INTENT(IN) :: PCLOUD_FRAC(KLON,KLEV)
+REAL(KIND=JPRB),   INTENT(IN) :: PQ_LIQUID(KLON,KLEV)
+REAL(KIND=JPRB),   INTENT(IN) :: PQ_ICE(KLON,KLEV)
+!REAL(KIND=JPRB),   INTENT(IN) :: PQ_RAIN(KLON,KLEV)
+REAL(KIND=JPRB),   INTENT(IN) :: PQ_SNOW(KLON,KLEV)
+
+! *** Aerosol mass mixing ratios
+REAL(KIND=JPRB),   INTENT(IN) :: PAEROSOL_OLD(KLON,6,KLEV)
+REAL(KIND=JPRB),   INTENT(IN) :: PAEROSOL(KLON,KLEV,KAEROSOL)
+
+!REAL(KIND=JPRB),   INTENT(IN) :: PCCN_LAND(KLON) 
+!REAL(KIND=JPRB),   INTENT(IN) :: PCCN_SEA(KLON) 
+
+!AI mars 2021
+INTEGER(KIND=JPIM), INTENT(IN) :: IDAY
+REAL(KIND=JPRB), INTENT(IN)    :: TIME
+
+! Name of file names specified on command line
+character(len=512), INTENT(IN) :: namelist_file
+logical, INTENT(IN)            :: ok_3Deffect, debut, ok_volcan
+INTEGER(KIND=JPIM), INTENT(IN) :: flag_aerosol_strat
+
+
+! OUTPUT ARGUMENTS
+
+! *** Net fluxes on half-levels (W m-2)
+REAL(KIND=JPRB),  INTENT(OUT) :: PFLUX_SW(KLON,KLEV+1) 
+REAL(KIND=JPRB),  INTENT(OUT) :: PFLUX_LW(KLON,KLEV+1) 
+REAL(KIND=JPRB),  INTENT(OUT) :: PFLUX_SW_CLEAR(KLON,KLEV+1) 
+REAL(KIND=JPRB),  INTENT(OUT) :: PFLUX_LW_CLEAR(KLON,KLEV+1) 
+
+!*** DN and UP flux on half-levels (W m-2)
+REAL(KIND=JPRB),  INTENT(OUT) :: PFLUX_SW_DN(KLON,KLEV+1)
+REAL(KIND=JPRB),  INTENT(OUT) :: PFLUX_LW_DN(KLON,KLEV+1)
+REAL(KIND=JPRB),  INTENT(OUT) :: PFLUX_SW_DN_CLEAR(KLON,KLEV+1)
+REAL(KIND=JPRB),  INTENT(OUT) :: PFLUX_LW_DN_CLEAR(KLON,KLEV+1)
+REAL(KIND=JPRB),  INTENT(OUT) :: PFLUX_SW_UP(KLON,KLEV+1)
+REAL(KIND=JPRB),  INTENT(OUT) :: PFLUX_LW_UP(KLON,KLEV+1)
+REAL(KIND=JPRB),  INTENT(OUT) :: PFLUX_SW_UP_CLEAR(KLON,KLEV+1)
+REAL(KIND=JPRB),  INTENT(OUT) :: PFLUX_LW_UP_CLEAR(KLON,KLEV+1)
+
+! Direct component of surface flux into horizontal plane
+REAL(KIND=JPRB),  INTENT(OUT) :: PFLUX_DIR(KLON)
+REAL(KIND=JPRB),  INTENT(OUT) :: PFLUX_DIR_CLEAR(KLON)
+! As PFLUX_DIR but into a plane perpendicular to the sun
+REAL(KIND=JPRB),  INTENT(OUT) :: PFLUX_DIR_INTO_SUN(KLON)
+
+! *** Ultraviolet and photosynthetically active radiation (W m-2)
+REAL(KIND=JPRB),  INTENT(OUT) :: PFLUX_UV(KLON)
+REAL(KIND=JPRB),  INTENT(OUT) :: PFLUX_PAR(KLON)
+REAL(KIND=JPRB),  INTENT(OUT) :: PFLUX_PAR_CLEAR(KLON)
+
+! Diagnosed longwave surface emissivity across the whole spectrum
+REAL(KIND=JPRB),  INTENT(OUT) :: PEMIS_OUT(KLON)   
+
+! Partial derivative of total-sky longwave upward flux at each level
+! with respect to upward flux at surface, used to correct heating
+! rates at gridpoints/timesteps between calls to the full radiation
+! scheme.  Note that this version uses the convention of level index
+! increasing downwards, unlike the local variable ZLwDerivative that
+! is returned from the LW radiation scheme.
+REAL(KIND=JPRB),  INTENT(OUT) :: PLWDERIVATIVE(KLON,KLEV+1)
+
+! Surface diffuse and direct downwelling shortwave flux in each
+! shortwave albedo band, used in RADINTG to update the surface fluxes
+! accounting for high-resolution albedo information
+REAL(KIND=JPRB),  INTENT(OUT) :: PSWDIFFUSEBAND(KLON,NSW)
+REAL(KIND=JPRB),  INTENT(OUT) :: PSWDIRECTBAND (KLON,NSW)
+
+!AI Nov 2023
+REAL(KIND=JPRB),  INTENT(OUT) :: ecrad_cloud_cover_sw(KLON)
+
+! LOCAL VARIABLES
+! AI ATTENTION
+type(config_type),save         :: rad_config
+!!$OMP THREADPRIVATE(rad_config)
+type(driver_config_type),save  :: driver_config
+!!$OMP THREADPRIVATE(driver_config)
+!type(config_type)        :: rad_config
+!type(driver_config_type)  :: driver_config
+TYPE(single_level_type)   :: single_level
+TYPE(thermodynamics_type) :: thermodynamics
+TYPE(gas_type)            :: gas
+TYPE(cloud_type)          :: cloud
+TYPE(aerosol_type)        :: aerosol
+TYPE(flux_type)           :: flux
+
+! Mass mixing ratio of ozone (kg/kg)
+REAL(KIND=JPRB)           :: ZO3(KLON,KLEV)
+
+! Cloud effective radii in microns
+REAL(KIND=JPRB)           :: ZRE_LIQUID_UM(KLON,KLEV)
+REAL(KIND=JPRB)           :: ZRE_ICE_UM(KLON,KLEV)
+
+! Cloud overlap decorrelation length for cloud boundaries in km
+REAL(KIND=JPRB)           :: ZDECORR_LEN_M
+REAL(KIND=JPRB)           :: ZDECORR_LEN_M_1D(KLON)
+REAL(KIND=JPRB)           :: ZDECORR_LEN_M_2D(KLON,KLEV)
+
+! Ratio of cloud overlap decorrelation length for cloud water
+! inhomogeneities to that for cloud boundaries (typically 0.5)
+!REAL(KIND=JPRB)           :: ZDECORR_LEN_RATIO = 0.5_jprb
+
+! The surface net longwave flux if the surface was a black body, used
+! to compute the effective broadband surface emissivity
+REAL(KIND=JPRB)           :: ZBLACK_BODY_NET_LW(KIDIA:KFDIA)
+
+! Layer mass in kg m-2
+REAL(KIND=JPRB)           :: ZLAYER_MASS(KIDIA:KFDIA,KLEV)
+
+! Time integers
+INTEGER :: ITIM
+
+! Loop indices
+INTEGER :: JLON, JLEV, JBAND, JB_ALBEDO, JAER
+
+REAL(KIND=JPRB) :: ZHOOK_HANDLE
+
+! AI ATTENTION traitement aerosols
+INTEGER, PARAMETER :: NAERMACC = 1
+
+logical :: loutput=.true.
+logical :: lprint_input=.false.
+logical :: lprint_config=.false.
+logical, save :: debut_ecrad=.true.
+!$OMP THREADPRIVATE(debut_ecrad)
+integer, save :: itap_ecrad=0
+!$OMP THREADPRIVATE(itap_ecrad)
+
+REAL(KIND=JPRB) ::  inv_cloud_effective_size(KLON,KLEV)
+REAL(KIND=JPRB) ::  inv_inhom_effective_size(KLON,KLEV)
+
+integer :: irang
+
+
+IF (LHOOK) CALL DR_HOOK('RADIATION_SCHEME',0,ZHOOK_HANDLE)
+
+   print*,'Entree radiation_scheme_s2, ok_3Deffect, namelist_file = ', &
+          ok_3Deffect, namelist_file
+! A.I juillet 2023 : 
+! Initialisation dans radiation_setup au 1er passage dans Ecrad
+!$OMP MASTER
+!if (.not.ok_3Deffect) then
+  if (debut_ecrad) then
+   call SETUP_RADIATION_SCHEME(loutput,namelist_file,rad_config,driver_config)
+   debut_ecrad=.false. 
+  endif 
+!else
+!   call SETUP_RADIATION_SCHEME(loutput,namelist_file,rad_config,driver_config)
+!endif
+!$OMP END MASTER
+!$OMP BARRIER 
+! Fin partie initialisation et configuration 
+
+!AI print fichiers namelist utilise
+!if (is_omp_root) then
+! itap_ecrad=itap_ecrad+1
+! print*,'Dans radiation_scheme itap_ecrad, mpi_rank, omp_rank, namelist_file : ', &
+!         itap_ecrad, mpi_rank, omp_rank, namelist_file
+!else
+! print*,'mpi_rank omp_rank, namelist_file :', mpi_rank, omp_rank, namelist_file
+!endif
+
+! AI 11 23 Allocates depplaces au debut
+print*,'*********** ALLOCATES *******************************'
+! AI ATTENTION
+! Allocate memory in radiation objects
+! emissivite avec une seule bande
+CALL single_level%allocate(KLON, NSW, 1, &
+     &                     use_sw_albedo_direct=.TRUE.)
+CALL thermodynamics%allocate(KLON, KLEV, use_h2o_sat=.true.)
+CALL cloud%allocate(KLON, KLEV)
+CALL aerosol%allocate(KLON, 1, KLEV, KAEROSOL)
+CALL gas%allocate(KLON, KLEV)
+CALL flux%allocate(rad_config, 1, KLON, KLEV)
+
+print*,'************* THERMO (input) ************************************'
+! Set thermodynamic profiles: simply copy over the half-level
+! pressure and temperature
+! AI
+! pressure_hl > paprs
+! temperature_hl calculee dans radlsw de la meme facon que pour RRTM
+thermodynamics%pressure_hl   (KIDIA:KFDIA,:) = PPRESSURE_H   (KIDIA:KFDIA,:)
+thermodynamics%temperature_hl(KIDIA:KFDIA,:) = PTEMPERATURE_H(KIDIA:KFDIA,:)
+!print*,'Compute saturation specific humidity'
+! Compute saturation specific humidity, used to hydrate aerosols. The
+! "2" for the last argument indicates that the routine is not being
+! called from within the convection scheme.
+!CALL SATUR(KIDIA, KFDIA, KLON, 1, KLEV, &
+!     &  PPRESSURE, PTEMPERATURE, thermodynamics%h2o_sat_liq, 2)
+! Alternative approximate version using temperature and pressure from
+! the thermodynamics structure
+!CALL thermodynamics%calc_saturation_wrt_liquid(KIDIA, KFDIA)
+!AI ATTENTION
+thermodynamics%h2o_sat_liq = PQSAT
+
+print*,'********** SINGLE LEVEL VARS **********************************'
+!AI ATTENTION
+! Set single-level fileds
+single_level%solar_irradiance              = PSOLAR_IRRADIANCE
+single_level%cos_sza(KIDIA:KFDIA)          = PMU0(KIDIA:KFDIA)
+single_level%skin_temperature(KIDIA:KFDIA) = PTEMPERATURE_SKIN(KIDIA:KFDIA)
+single_level%sw_albedo(KIDIA:KFDIA,:)      = PALBEDO_DIF(KIDIA:KFDIA,:)
+single_level%sw_albedo_direct(KIDIA:KFDIA,:)=PALBEDO_DIR(KIDIA:KFDIA,:)
+single_level%lw_emissivity(KIDIA:KFDIA,1)  = PEMIS(KIDIA:KFDIA)
+!single_level%lw_emissivity(KIDIA:KFDIA,2)  = PEMIS_WINDOW(KIDIA:KFDIA)
+
+! Create the relevant seed from date and time get the starting day
+! and number of minutes since start
+!IDAY = NDD(NINDAT)
+!cur_day
+!ITIM = NINT(NSTEP * YRRIP%TSTEP / 60.0_JPRB)
+!ITIM = NINT(TIME / 60.0_JPRB)
+!current_time
+!allocate(single_level%iseed(KIDIA:KFDIA))
+!DO JLON = KIDIA, KFDIA
+  ! This method gives a unique value for roughly every 1-km square
+  ! on the globe and every minute.  ASIN(PGEMU)*60 gives rough
+  ! latitude in degrees, which we multiply by 100 to give a unique
+  ! value for roughly every km. PGELAM*60*100 gives a unique number
+  ! for roughly every km of longitude around the equator, which we
+  ! multiply by 180*100 so there is no overlap with the latitude
+  ! values.  The result can be contained in a 32-byte integer (but
+  ! since random numbers are generated with the help of integer
+  ! overflow, it should not matter if the number did overflow).
+!  single_level%iseed(JLON) = ITIM + IDAY & 
+!       &  +  NINT(PGELAM(JLON)*108000000.0_JPRB &
+!       &          + ASIN(PGEMU(JLON))*6000.0_JPRB)
+!ENDDO
+!AI Nov 23
+! Simple initialization of the seeds for the Monte Carlo scheme
+call single_level%init_seed_simple(kidia, kfdia)
+
+print*,'********** CLOUDS (allocate + input) *******************************************'
+!print*,'Appel Allocate clouds'
+! Set cloud fields
+cloud%q_liq(KIDIA:KFDIA,:)    = PQ_LIQUID(KIDIA:KFDIA,:)
+cloud%q_ice(KIDIA:KFDIA,:)    = PQ_ICE(KIDIA:KFDIA,:) + PQ_SNOW(KIDIA:KFDIA,:)
+cloud%fraction(KIDIA:KFDIA,:) = PCLOUD_FRAC(KIDIA:KFDIA,:)
+!!! ok AI ATTENTION a voir avec JL
+! Compute effective radi and convert to metres
+! AI. : on passe directement les champs de LMDZ
+cloud%re_liq(KIDIA:KFDIA,:) = ZRE_LIQUID_UM(KIDIA:KFDIA,:)
+cloud%re_ice(KIDIA:KFDIA,:) = ZRE_ICE_UM(KIDIA:KFDIA,:)
+! Get the cloud overlap decorrelation length (for cloud boundaries),
+! in km, according to the parameterization specified by NDECOLAT,
+! and insert into the "cloud" object. Also get the ratio of
+! decorrelation lengths for cloud water content inhomogeneities and
+! cloud boundaries, and set it in the "rad_config" object.
+! IFS :
+!CALL CLOUD_OVERLAP_DECORR_LEN(KIDIA, KFDIA, KLON, PGEMU, YRERAD%NDECOLAT, &
+!     &    ZDECORR_LEN_KM, PDECORR_LEN_RATIO=ZDECORR_LEN_RATIO)
+! AI valeur dans namelist
+! rad_config%cloud_inhom_decorr_scaling = ZDECORR_LEN_RATIO
+!AI ATTENTION meme valeur que dans offline
+! A mettre dans namelist
+   CALL CALCUL_CLOUD_OVERLAP_DECORR_LEN &
+     & (KIDIA, KFDIA, KLON, KLEV, &
+     &  driver_config, &
+     &  thermodynamics%pressure_hl , &
+     &  ZDECORR_LEN_M_2D)
+
+ if (driver_config%kdecolat.eq.0) then
+  ZDECORR_LEN_M = ZDECORR_LEN_M_2D(1,1)
+  DO JLON = KIDIA,KFDIA
+   CALL cloud%set_overlap_param(thermodynamics, &
+       &                 ZDECORR_LEN_M, &
+       &                 istartcol=JLON, iendcol=JLON)
+  ENDDO
+ else if (driver_config%kdecolat.eq.1.or.driver_config%kdecolat.eq.2) then
+  ZDECORR_LEN_M_1D = ZDECORR_LEN_M_2D(:,1)
+  DO JLON = KIDIA,KFDIA
+   CALL cloud%set_overlap_param(thermodynamics, &
+       &                 ZDECORR_LEN_M_1D, &
+       &                 istartcol=JLON, iendcol=JLON)
+  ENDDO
+ else if (driver_config%kdecolat.eq.3) then
+  DO JLON = KIDIA,KFDIA
+   CALL cloud%set_overlap_param_var2D(thermodynamics, &
+       &                 ZDECORR_LEN_M_2D, KLEV, &
+       &                 istartcol=JLON, iendcol=JLON)
+  ENDDO
+ endif
+   
+! IFS :
+! Cloud water content fractional standard deviation is configurable
+! from namelist NAERAD but must be globally constant. Before it was
+! hard coded at 1.0.
+!CALL cloud%create_fractional_std(KLON, KLEV, YRERAD%RCLOUD_FRAC_STD)
+! AI ATTENTION frac_std=0.75 meme valeur que dans la version offline
+CALL cloud%create_fractional_std(KLON, KLEV, driver_config%frac_std)
+
+!if (ok_3Deffect) then
+! if (driver_config%ok_effective_size) then
+!     call cloud%create_inv_cloud_effective_size_eta(klon, klev, &
+!               &  thermodynamics%pressure_hl, &
+!               &  driver_config%low_inv_effective_size, &
+!               &  driver_config%middle_inv_effective_size, &
+!               &  driver_config%high_inv_effective_size, 0.8_jprb, 0.45_jprb, &
+!               &  KIDIA, KFDIA)
+!   else if (driver_config%ok_separation) then
+!     call cloud%param_cloud_effective_separation_eta(klon, klev, &
+!               &  thermodynamics%pressure_hl, &
+!               &  driver_config%cloud_separation_scale_surface, &
+!               &  driver_config%cloud_separation_scale_toa, &
+!               &  driver_config%cloud_separation_scale_power, &
+!               &  driver_config%cloud_inhom_separation_factor, &
+!               &  KIDIA, KFDIA)
+!   endif     
+! else  
+ if (rad_config%i_solver_sw == ISolverSPARTACUS &
+      & .or.   rad_config%i_solver_lw == ISolverSPARTACUS) then
+   ! AI ! Read cloud properties needed by SPARTACUS
+   if (driver_config%ok_effective_size) then
+     call cloud%create_inv_cloud_effective_size_eta(klon, klev, &
+               &  thermodynamics%pressure_hl, &
+               &  driver_config%low_inv_effective_size, &
+               &  driver_config%middle_inv_effective_size, &
+               &  driver_config%high_inv_effective_size, 0.8_jprb, 0.45_jprb, &
+               &  KIDIA, KFDIA)
+   else if (driver_config%ok_separation) then
+     call cloud%param_cloud_effective_separation_eta(klon, klev, &
+               &  thermodynamics%pressure_hl, &
+               &  driver_config%cloud_separation_scale_surface, &
+               &  driver_config%cloud_separation_scale_toa, &
+               &  driver_config%cloud_separation_scale_power, &
+               &  driver_config%cloud_inhom_separation_factor, &
+               &  KIDIA, KFDIA)
+   endif
+ endif  
+!endif
+
+print*,'******** AEROSOLS (input) **************************************'
+!IF (NAERMACC > 0) THEN
+!ELSE
+!  CALL aerosol%allocate(KLON, 1, KLEV, 6) ! Tegen climatology
+!ENDIF
+! Compute the dry mass of each layer neglecting humidity effects, in
+! kg m-2, needed to scale some of the aerosol inputs
+! AI commente ATTENTION
+!CALL thermodynamics%get_layer_mass(ZLAYER_MASS)
+
+! Copy over aerosol mass mixing ratio
+!IF (NAERMACC > 0) THEN
+
+  ! MACC aerosol climatology - this is already in mass mixing ratio
+  ! units with the required array orientation so we can copy it over
+  ! directly
+  aerosol%mixing_ratio(KIDIA:KFDIA,:,:) = PAEROSOL(KIDIA:KFDIA,:,:)
+
+  ! Add the tropospheric and stratospheric backgrounds contained in the
+  ! old Tegen arrays - this is very ugly!
+! AI ATTENTION
+!  IF (TROP_BG_AER_MASS_EXT > 0.0_JPRB) THEN
+!    aerosol%mixing_ratio(KIDIA:KFDIA,:,ITYPE_TROP_BG_AER) &
+!         &  = aerosol%mixing_ratio(KIDIA:KFDIA,:,ITYPE_TROP_BG_AER) &
+!         &  + PAEROSOL_OLD(KIDIA:KFDIA,1,:) &
+!         &  / (ZLAYER_MASS * TROP_BG_AER_MASS_EXT)
+!  ENDIF
+!  IF (STRAT_BG_AER_MASS_EXT > 0.0_JPRB) THEN
+!    aerosol%mixing_ratio(KIDIA:KFDIA,:,ITYPE_STRAT_BG_AER) &
+!         &  = aerosol%mixing_ratio(KIDIA:KFDIA,:,ITYPE_STRAT_BG_AER) &
+!         &  + PAEROSOL_OLD(KIDIA:KFDIA,6,:) &
+!         &  / (ZLAYER_MASS * STRAT_BG_AER_MASS_EXT)
+!  ENDIF
+
+!ELSE
+
+  ! Tegen aerosol climatology - the array PAEROSOL_OLD contains the
+  ! 550-nm optical depth in each layer. The optics data file
+  ! aerosol_ifs_rrtm_tegen.nc does not contain mass extinction
+  ! coefficient, but a scaling factor that the 550-nm optical depth
+  ! should be multiplied by to obtain the optical depth in each
+  ! spectral band.  Therefore, in order for the units to work out, we
+  ! need to divide by the layer mass (in kg m-2) to obtain the 550-nm
+  ! cross-section per unit mass of dry air (so in m2 kg-1).  We also
+  ! need to permute the array.
+!  DO JLEV = 1,KLEV
+!    DO JAER = 1,6
+!      aerosol%mixing_ratio(KIDIA:KFDIA,JLEV,JAER) &
+!         &  = PAEROSOL_OLD(KIDIA:KFDIA,JAER,JLEV) &
+!         &  / ZLAYER_MASS(KIDIA:KFDIA,JLEV)
+!    ENDDO
+!  ENDDO
+!ENDIF
+
+print*,'********** GAS (input) ************************************************'
+!print*,'Appel Allocate gas'
+! Convert ozone Pa*kg/kg to kg/kg
+! AI ATTENTION
+!DO JLEV = 1,KLEV
+!  DO JLON = KIDIA,KFDIA
+!    ZO3(JLON,JLEV) = PO3_DP(JLON,JLEV) &
+!         &         / (PPRESSURE_H(JLON,JLEV+1)-PPRESSURE_H(JLON,JLEV))
+!  ENDDO
+!ENDDO
+!  Insert gas mixing ratios
+!print*,'Insert gas mixing ratios'
+CALL gas%put(IH2O,    IMassMixingRatio, PQ)
+CALL gas%put(IO3,     IMassMixingRatio, PO3)
+CALL gas%put_well_mixed(ICO2,    IMAssMixingRatio, PCO2)
+CALL gas%put_well_mixed(ICH4,    IMassMixingRatio, PCH4)
+CALL gas%put_well_mixed(IN2O,    IMassMixingRatio, PN2O)
+CALL gas%put_well_mixed(ICFC11,  IMassMixingRatio, PCFC11)
+CALL gas%put_well_mixed(ICFC12,  IMassMixingRatio, PCFC12)
+CALL gas%put_well_mixed(IHCFC22, IMassMixingRatio, PHCFC22)
+CALL gas%put_well_mixed(ICCL4,   IMassMixingRatio, PCCL4)
+CALL gas%put_well_mixed(IO2,     IMassMixingRatio, PO2)
+! Ensure the units of the gas mixing ratios are what is required by
+! the gas absorption model
+call set_gas_units(rad_config, gas)
+
+! Call radiation scheme
+!print*,'*** Appel radiation *** namelist **** omp_rank ****', &
+!         omp_rank, namelist_file
+!   if (rad_config%i_solver_sw == ISolverSPARTACUS) then 
+!    if (driver_config%ok_separation) then
+!      print*,'Avant radiation, mpi_rank, omp_rank, size, chape inv_cloud = ',&
+!              mpi_rank, omp_rank, &
+!              shape(cloud%inv_cloud_effective_size), &
+!              size(cloud%inv_cloud_effective_size)      
+!      do jlon=KIDIA, KFDIA      
+!        do jlev=1,klev
+!         print*,' Avant radiation mpi_rank, omp_rank, jlon, jlev, &
+!            &     cloud%inv_cloud_effective_size =', mpi_rank, &
+!            &     omp_rank, jlon, jlev, &
+!            &     cloud%inv_cloud_effective_size(jlon,jlev)
+!        enddo
+!      enddo
+!       cloud%inv_cloud_effective_size=inv_cloud_effective_size
+!       cloud%inv_inhom_effective_size=inv_inhom_effective_size
+!    endif
+!   endif
+CALL radiation(KLON, KLEV, KIDIA, KFDIA, rad_config, &
+     &  single_level, thermodynamics, gas, cloud, aerosol, flux)
+
+ if (rad_config%use_aerosols) then
+    if (rad_config%i_gas_model_sw == IGasModelIFSRRTMG .or. &
+     &    rad_config%i_gas_model_lw == IGasModelIFSRRTMG) then     
+       CALL aeropt_5wv_ecrad(kidia, kfdia, 1, klev, &
+                             rad_config,thermodynamics,aerosol)
+    endif                 
+    if (flag_aerosol_strat.eq.2) then
+       CALL readaerosolstrato_ecrad(rad_config, debut, ok_volcan)
+    endif
+ endif               
+
+print*,'*********** Sortie flux ****************'
+! Cloud cover
+ecrad_cloud_cover_sw = flux%cloud_cover_sw
+! Compute required output fluxes
+! DN and UP flux
+PFLUX_SW_DN(KIDIA:KFDIA,:) = flux%sw_dn(KIDIA:KFDIA,:)
+PFLUX_SW_UP(KIDIA:KFDIA,:) = flux%sw_up(KIDIA:KFDIA,:)
+PFLUX_LW_DN(KIDIA:KFDIA,:) = flux%lw_dn(KIDIA:KFDIA,:)
+PFLUX_LW_UP(KIDIA:KFDIA,:) = flux%lw_up(KIDIA:KFDIA,:)
+PFLUX_SW_DN_CLEAR(KIDIA:KFDIA,:) = flux%sw_dn_clear(KIDIA:KFDIA,:)
+PFLUX_SW_UP_CLEAR(KIDIA:KFDIA,:) = flux%sw_up_clear(KIDIA:KFDIA,:)
+PFLUX_LW_DN_CLEAR(KIDIA:KFDIA,:) = flux%lw_dn_clear(KIDIA:KFDIA,:)
+PFLUX_LW_UP_CLEAR(KIDIA:KFDIA,:) = flux%lw_up_clear(KIDIA:KFDIA,:)
+! First the net fluxes
+PFLUX_SW(KIDIA:KFDIA,:) = flux%sw_dn(KIDIA:KFDIA,:) - flux%sw_up(KIDIA:KFDIA,:)
+PFLUX_LW(KIDIA:KFDIA,:) = flux%lw_dn(KIDIA:KFDIA,:) - flux%lw_up(KIDIA:KFDIA,:)
+PFLUX_SW_CLEAR(KIDIA:KFDIA,:) &
+     &  = flux%sw_dn_clear(KIDIA:KFDIA,:) - flux%sw_up_clear(KIDIA:KFDIA,:)
+PFLUX_LW_CLEAR(KIDIA:KFDIA,:) &
+     &  = flux%lw_dn_clear(KIDIA:KFDIA,:) - flux%lw_up_clear(KIDIA:KFDIA,:)
+! Now the surface fluxes
+!PFLUX_SW_DN_SURF(KIDIA:KFDIA) = flux%sw_dn(KIDIA:KFDIA,KLEV+1)
+!PFLUX_LW_DN_SURF(KIDIA:KFDIA) = flux%lw_dn(KIDIA:KFDIA,KLEV+1)
+!PFLUX_SW_UP_SURF(KIDIA:KFDIA) = flux%sw_up(KIDIA:KFDIA,KLEV+1)
+!PFLUX_LW_UP_SURF(KIDIA:KFDIA) = flux%lw_up(KIDIA:KFDIA,KLEV+1)
+!PFLUX_SW_DN_CLEAR_SURF(KIDIA:KFDIA) = flux%sw_dn_clear(KIDIA:KFDIA,KLEV+1)
+!PFLUX_LW_DN_CLEAR_SURF(KIDIA:KFDIA) = flux%lw_dn_clear(KIDIA:KFDIA,KLEV+1)
+!PFLUX_SW_UP_CLEAR_SURF(KIDIA:KFDIA) = flux%sw_up_clear(KIDIA:KFDIA,KLEV+1)
+!PFLUX_LW_UP_CLEAR_SURF(KIDIA:KFDIA) = flux%lw_up_clear(KIDIA:KFDIA,KLEV+1)
+PFLUX_DIR(KIDIA:KFDIA) = flux%sw_dn_direct(KIDIA:KFDIA,KLEV+1)
+PFLUX_DIR_CLEAR(KIDIA:KFDIA) = flux%sw_dn_direct_clear(KIDIA:KFDIA,KLEV+1)
+PFLUX_DIR_INTO_SUN(KIDIA:KFDIA) = 0.0_JPRB
+WHERE (PMU0(KIDIA:KFDIA) > EPSILON(1.0_JPRB))
+  PFLUX_DIR_INTO_SUN(KIDIA:KFDIA) = PFLUX_DIR(KIDIA:KFDIA) / PMU0(KIDIA:KFDIA)
+END WHERE
+! Top-of-atmosphere downwelling flux
+!PFLUX_SW_DN_TOA(KIDIA:KFDIA) = flux%sw_dn(KIDIA:KFDIA,1)
+!PFLUX_SW_UP_TOA(KIDIA:KFDIA) = flux%sw_up(KIDIA:KFDIA,1)
+!PFLUX_LW_DN_TOA(KIDIA:KFDIA) = flux%lw_dn(KIDIA:KFDIA,1)
+!PFLUX_LW_UP_TOA(KIDIA:KFDIA) = flux%lw_up(KIDIA:KFDIA,1)
+!AI ATTENTION
+if (0.eq.1) then
+PFLUX_UV       (KIDIA:KFDIA) = 0.0_JPRB
+DO JBAND = 1,NWEIGHT_UV
+  PFLUX_UV(KIDIA:KFDIA) = PFLUX_UV(KIDIA:KFDIA) + WEIGHT_UV(JBAND) &
+       &  * flux%sw_dn_surf_band(IBAND_UV(JBAND),KIDIA:KFDIA)
+ENDDO
+! Compute photosynthetically active radiation similarly
+PFLUX_PAR      (KIDIA:KFDIA) = 0.0_JPRB
+PFLUX_PAR_CLEAR(KIDIA:KFDIA) = 0.0_JPRB
+DO JBAND = 1,NWEIGHT_PAR
+  PFLUX_PAR(KIDIA:KFDIA) = PFLUX_PAR(KIDIA:KFDIA) + WEIGHT_PAR(JBAND) &
+       &  * flux%sw_dn_surf_band(IBAND_PAR(JBAND),KIDIA:KFDIA)
+  PFLUX_PAR_CLEAR(KIDIA:KFDIA) = PFLUX_PAR_CLEAR(KIDIA:KFDIA) &
+       &  + WEIGHT_PAR(JBAND) &
+       &  * flux%sw_dn_surf_clear_band(IBAND_PAR(JBAND),KIDIA:KFDIA)
+ENDDO
+endif
+! Compute effective broadband emissivity
+ZBLACK_BODY_NET_LW = flux%lw_dn(KIDIA:KFDIA,KLEV+1) &
+     &  - RSIGMA*PTEMPERATURE_SKIN(KIDIA:KFDIA)**4
+PEMIS_OUT(KIDIA:KFDIA) = PEMIS(KIDIA:KFDIA)
+WHERE (ABS(ZBLACK_BODY_NET_LW) > 1.0E-5) 
+  PEMIS_OUT(KIDIA:KFDIA) = PFLUX_LW(KIDIA:KFDIA,KLEV+1) / ZBLACK_BODY_NET_LW
+END WHERE
+! Copy longwave derivatives
+! AI ATTENTION
+!IF (YRERAD%LAPPROXLWUPDATE) THEN
+IF (rad_config%do_lw_derivatives) THEN
+  PLWDERIVATIVE(KIDIA:KFDIA,:) = flux%lw_derivatives(KIDIA:KFDIA,:)
+END IF
+! Store the shortwave downwelling fluxes in each albedo band
+!AI ATTENTION
+!IF (YRERAD%LAPPROXSWUPDATE) THEN
+if (0.eq.1) then
+IF (rad_config%do_surface_sw_spectral_flux) THEN
+  PSWDIFFUSEBAND(KIDIA:KFDIA,:) = 0.0_JPRB
+  PSWDIRECTBAND (KIDIA:KFDIA,:) = 0.0_JPRB
+  DO JBAND = 1,rad_config%n_bands_sw
+    JB_ALBEDO = rad_config%i_albedo_from_band_sw(JBAND)
+    DO JLON = KIDIA,KFDIA
+      PSWDIFFUSEBAND(JLON,JB_ALBEDO) = PSWDIFFUSEBAND(JLON,JB_ALBEDO) &
+           &  + flux%sw_dn_surf_band(JBAND,JLON) &
+           &  - flux%sw_dn_direct_surf_band(JBAND,JLON)
+      PSWDIRECTBAND(JLON,JB_ALBEDO)  = PSWDIRECTBAND(JLON,JB_ALBEDO) &
+           &  + flux%sw_dn_direct_surf_band(JBAND,JLON)
+    ENDDO
+  ENDDO
+ENDIF
+endif
+
+print*,'********** DEALLOCATIONS ************************'
+CALL single_level%deallocate
+CALL thermodynamics%deallocate
+CALL gas%deallocate
+CALL cloud%deallocate
+CALL aerosol%deallocate
+CALL flux%deallocate
+
+IF (LHOOK) CALL DR_HOOK('RADIATION_SCHEME',1,ZHOOK_HANDLE)
+
+END SUBROUTINE RADIATION_SCHEME_S2
+
+end module interface_lmdz_ecrad
Index: DZ6/trunk/libf/phylmd/ecrad/lmdz/radiation_setup.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/ecrad/lmdz/radiation_setup.F90	(revision 5267)
+++ 	(revision )
@@ -1,149 +1,0 @@
-MODULE RADIATION_SETUP
-
-! RADIATION_SETUP - Setting up modular radiation scheme
-!
-! AUTHOR
-! ------
-!   Robin Hogan, ECMWF
-!   Original: 2015-09-16
-!
-! MODIFICATIONS
-! -------------
-!   Abderrahmane Idelkadi LMD, juillet 2023
-!
-!-----------------------------------------------------------------------
-
-  USE PARKIND1,         ONLY : JPRB
-  USE radiation_config, ONLY : config_type, &
-       &                       ISolverMcICA, ISolverSpartacus, &
-       &                       ILiquidModelSlingo, ILiquidModelSOCRATES, &
-       &                       IIceModelFu, IIceModelBaran, IGasModelECCKD, &
-       &                       IGasModelIFSRRTMG, IOverlapExponentialRandom
-
-  USE radiation_interface,      ONLY : setup_radiation
-  USE setup_config_from_lmdz,   ONLY : driver_config_type
-
-  IMPLICIT NONE
-
-
-  ! Ultraviolet weightings
-  INTEGER         :: NWEIGHT_UV
-  INTEGER         :: IBAND_UV(100)
-  REAL(KIND=JPRB) :: WEIGHT_UV(100)
-  ! Photosynthetically active radiation weightings
-  INTEGER         :: NWEIGHT_PAR
-  INTEGER         :: IBAND_PAR(100)
-  REAL(KIND=JPRB) :: WEIGHT_PAR(100)
-
-  ! Background aerosol is specified in an ugly way: using the old
-  ! Tegen fields that are in terms of optical depth, and converted to
-  ! mass mixing ratio via the relevant mass-extinction coefficient
-  INTEGER, PARAMETER :: ITYPE_TROP_BG_AER = 8 ! hydrophobic organic
-  INTEGER, PARAMETER :: ITYPE_STRAT_BG_AER=12 ! non-absorbing sulphate
-  REAL(KIND=JPRB)    :: TROP_BG_AER_MASS_EXT
-  REAL(KIND=JPRB)    :: STRAT_BG_AER_MASS_EXT
-
-CONTAINS
-
-  ! This routine copies information between the LMDZ radiation
-  ! configuration (stored in global variables) and the radiation
-  ! configuration of the modular radiation scheme (stored in
-  ! rad_config).  The optional input logical LOUTPUT controls whether
-  ! to print lots of information during the setup stage (default is
-  ! no).
-! AI At the end of the routine, the parameters are read in namelist
-!    
-  SUBROUTINE SETUP_RADIATION_SCHEME(LOUTPUT,file_name,rad_config,driver_config)
-
-!    USE radiation_config, ONLY : config_type, &
-!        &                       ISolverMcICA, ISolverSpartacus, &
-!        &                       ILiquidModelSlingo, ILiquidModelSOCRATES, &
-!        &                       IIceModelFu, IIceModelBaran, &
-!        &                       IOverlapExponentialRandom
-    USE mod_phys_lmdz_para
-      
-    USE YOMHOOK,  ONLY : LHOOK, DR_HOOK
-    USE YOMLUN,   ONLY : NULOUT, NULERR
-    USE YOESRTWN, ONLY : NMPSRTM
-
- !   USE radiation_interface,      ONLY : setup_radiation
- !   USE setup_config_from_lmdz,   ONLY : driver_config_type
-
-    ! Whether or not to provide information on the radiation scheme
-    ! configuration
-    LOGICAL, INTENT(IN), OPTIONAL :: LOUTPUT
-
-    REAL(KIND=JPRB) :: ZHOOK_HANDLE
-
-    character(len=512) :: file_name
-
-    logical :: lprint_setp=.TRUE.
-
-    ! Store configuration information for the radiation scheme in a
-    ! global variable
-    type(config_type) :: rad_config
-    type(driver_config_type) :: driver_config
-
-    IF (LHOOK) CALL DR_HOOK('RADIATION_SETUP:SETUP_RADIATION_SCHEME',0,ZHOOK_HANDLE)
-
-    ! *** GENERAL SETUP ***
-
-    ! Configure verbosity of setup of radiation scheme
- 
-    print*,'********** Dans radiation_setup *****************'
-
-! AI ATTENTION (parameters read in namelist file)
-!    file_name="namelist_ecrad"
-    call rad_config%read(file_name=file_name)
-    call driver_config%read(file_name)
-
-    ! Use configuration data to set-up radiation scheme, including
-    ! reading scattering datafiles
-    CALL setup_radiation(rad_config)
-
-    ! Populate the mapping between the 14 RRTM shortwave bands and the
-    ! 6 albedo inputs. The mapping according to the stated wavelength
-    ! ranges of the 6-band model does not match the hard-wired mapping
-    ! in NMPSRTM, but only the hard-wired values produce sensible
-    ! results...
-    ! Note that NMPSRTM(:)=(/  6, 6, 5, 5, 5, 5, 5, 4, 4, 3, 2, 2, 1, 6 /)
-! AI (6 albedo SW bands) 
-    call rad_config%define_sw_albedo_intervals(6, &
-       &  [0.25e-6_jprb, 0.44e-6_jprb, 0.69e-6_jprb, &
-       &   1.19e-6_jprb, 2.38e-6_jprb], [1,2,3,4,5,6])
-    ! Likewise between the 16 RRTM longwave bands and the 2 emissivity
-    ! inputs (info taken from rrtm_ecrt_140gp_mcica.F90) representing
-    ! outside and inside the window region of the spectrum
-!     rad_config%i_emiss_from_band_lw = (/ 1,1,1,1,1,2,2,2,1,1,1,1,1,1,1,1 /)
-! AI ATTENTION ?????
-!!    call rad_config%define_lw_emiss_intervals(3, &
-!!         &  (/ 8.0e-6_jprb,13.0e-6_jprb /),  (/ 1,2,1 /))
-
-!    ! Get spectral weightings for UV and PAR
-    call rad_config%get_sw_weights(0.2e-6_jprb, 0.4415e-6_jprb, &
-         &  NWEIGHT_UV, IBAND_UV, WEIGHT_UV, 'ultraviolet')
-    call rad_config%get_sw_weights(0.4e-6_jprb, 0.7e-6_jprb, &
-         &  NWEIGHT_PAR, IBAND_PAR, WEIGHT_PAR, &
-         &  'photosynthetically active radiation, PAR')
-
-     rad_config%i_aerosol_type_map(1:13) = (/ &
-           &  -1, & 
-           &  -2, & 
-           &  -3, & 
-           &  -4, & 
-           &  -5, & 
-           &  -6, &
-           &  -7, &
-           &   1, &
-           &   2, &
-           &   3, &
-           &  -8, &
-           &  -9, &
-           &   4 /)
-
-
-    IF (LHOOK) CALL DR_HOOK('RADIATION_SETUP:SETUP_RADIATION_SCHEME',1,ZHOOK_HANDLE)
-
-  END SUBROUTINE SETUP_RADIATION_SCHEME
-
-END MODULE RADIATION_SETUP
Index: /LMDZ6/trunk/libf/phylmd/ecrad/lmdz/radiation_setup.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/ecrad/lmdz/radiation_setup.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/ecrad/lmdz/radiation_setup.f90	(revision 5268)
@@ -0,0 +1,149 @@
+MODULE RADIATION_SETUP
+
+! RADIATION_SETUP - Setting up modular radiation scheme
+!
+! AUTHOR
+! ------
+!   Robin Hogan, ECMWF
+!   Original: 2015-09-16
+!
+! MODIFICATIONS
+! -------------
+!   Abderrahmane Idelkadi LMD, juillet 2023
+!
+!-----------------------------------------------------------------------
+
+  USE PARKIND1,         ONLY : JPRB
+  USE radiation_config, ONLY : config_type, &
+       &                       ISolverMcICA, ISolverSpartacus, &
+       &                       ILiquidModelSlingo, ILiquidModelSOCRATES, &
+       &                       IIceModelFu, IIceModelBaran, IGasModelECCKD, &
+       &                       IGasModelIFSRRTMG, IOverlapExponentialRandom
+
+  USE radiation_interface,      ONLY : setup_radiation
+  USE setup_config_from_lmdz,   ONLY : driver_config_type
+
+  IMPLICIT NONE
+
+
+  ! Ultraviolet weightings
+  INTEGER         :: NWEIGHT_UV
+  INTEGER         :: IBAND_UV(100)
+  REAL(KIND=JPRB) :: WEIGHT_UV(100)
+  ! Photosynthetically active radiation weightings
+  INTEGER         :: NWEIGHT_PAR
+  INTEGER         :: IBAND_PAR(100)
+  REAL(KIND=JPRB) :: WEIGHT_PAR(100)
+
+  ! Background aerosol is specified in an ugly way: using the old
+  ! Tegen fields that are in terms of optical depth, and converted to
+  ! mass mixing ratio via the relevant mass-extinction coefficient
+  INTEGER, PARAMETER :: ITYPE_TROP_BG_AER = 8 ! hydrophobic organic
+  INTEGER, PARAMETER :: ITYPE_STRAT_BG_AER=12 ! non-absorbing sulphate
+  REAL(KIND=JPRB)    :: TROP_BG_AER_MASS_EXT
+  REAL(KIND=JPRB)    :: STRAT_BG_AER_MASS_EXT
+
+CONTAINS
+
+  ! This routine copies information between the LMDZ radiation
+  ! configuration (stored in global variables) and the radiation
+  ! configuration of the modular radiation scheme (stored in
+  ! rad_config).  The optional input logical LOUTPUT controls whether
+  ! to print lots of information during the setup stage (default is
+  ! no).
+! AI At the end of the routine, the parameters are read in namelist
+!    
+  SUBROUTINE SETUP_RADIATION_SCHEME(LOUTPUT,file_name,rad_config,driver_config)
+
+!    USE radiation_config, ONLY : config_type, &
+!        &                       ISolverMcICA, ISolverSpartacus, &
+!        &                       ILiquidModelSlingo, ILiquidModelSOCRATES, &
+!        &                       IIceModelFu, IIceModelBaran, &
+!        &                       IOverlapExponentialRandom
+    USE mod_phys_lmdz_para
+      
+    USE YOMHOOK,  ONLY : LHOOK, DR_HOOK
+    USE YOMLUN,   ONLY : NULOUT, NULERR
+    USE YOESRTWN, ONLY : NMPSRTM
+
+ !   USE radiation_interface,      ONLY : setup_radiation
+ !   USE setup_config_from_lmdz,   ONLY : driver_config_type
+
+    ! Whether or not to provide information on the radiation scheme
+    ! configuration
+    LOGICAL, INTENT(IN), OPTIONAL :: LOUTPUT
+
+    REAL(KIND=JPRB) :: ZHOOK_HANDLE
+
+    character(len=512) :: file_name
+
+    logical :: lprint_setp=.TRUE.
+
+    ! Store configuration information for the radiation scheme in a
+    ! global variable
+    type(config_type) :: rad_config
+    type(driver_config_type) :: driver_config
+
+    IF (LHOOK) CALL DR_HOOK('RADIATION_SETUP:SETUP_RADIATION_SCHEME',0,ZHOOK_HANDLE)
+
+    ! *** GENERAL SETUP ***
+
+    ! Configure verbosity of setup of radiation scheme
+ 
+    print*,'********** Dans radiation_setup *****************'
+
+! AI ATTENTION (parameters read in namelist file)
+!    file_name="namelist_ecrad"
+    call rad_config%read(file_name=file_name)
+    call driver_config%read(file_name)
+
+    ! Use configuration data to set-up radiation scheme, including
+    ! reading scattering datafiles
+    CALL setup_radiation(rad_config)
+
+    ! Populate the mapping between the 14 RRTM shortwave bands and the
+    ! 6 albedo inputs. The mapping according to the stated wavelength
+    ! ranges of the 6-band model does not match the hard-wired mapping
+    ! in NMPSRTM, but only the hard-wired values produce sensible
+    ! results...
+    ! Note that NMPSRTM(:)=(/  6, 6, 5, 5, 5, 5, 5, 4, 4, 3, 2, 2, 1, 6 /)
+! AI (6 albedo SW bands) 
+    call rad_config%define_sw_albedo_intervals(6, &
+       &  [0.25e-6_jprb, 0.44e-6_jprb, 0.69e-6_jprb, &
+       &   1.19e-6_jprb, 2.38e-6_jprb], [1,2,3,4,5,6])
+    ! Likewise between the 16 RRTM longwave bands and the 2 emissivity
+    ! inputs (info taken from rrtm_ecrt_140gp_mcica.F90) representing
+    ! outside and inside the window region of the spectrum
+!     rad_config%i_emiss_from_band_lw = (/ 1,1,1,1,1,2,2,2,1,1,1,1,1,1,1,1 /)
+! AI ATTENTION ?????
+!!    call rad_config%define_lw_emiss_intervals(3, &
+!!         &  (/ 8.0e-6_jprb,13.0e-6_jprb /),  (/ 1,2,1 /))
+
+!    ! Get spectral weightings for UV and PAR
+    call rad_config%get_sw_weights(0.2e-6_jprb, 0.4415e-6_jprb, &
+         &  NWEIGHT_UV, IBAND_UV, WEIGHT_UV, 'ultraviolet')
+    call rad_config%get_sw_weights(0.4e-6_jprb, 0.7e-6_jprb, &
+         &  NWEIGHT_PAR, IBAND_PAR, WEIGHT_PAR, &
+         &  'photosynthetically active radiation, PAR')
+
+     rad_config%i_aerosol_type_map(1:13) = (/ &
+           &  -1, & 
+           &  -2, & 
+           &  -3, & 
+           &  -4, & 
+           &  -5, & 
+           &  -6, &
+           &  -7, &
+           &   1, &
+           &   2, &
+           &   3, &
+           &  -8, &
+           &  -9, &
+           &   4 /)
+
+
+    IF (LHOOK) CALL DR_HOOK('RADIATION_SETUP:SETUP_RADIATION_SCHEME',1,ZHOOK_HANDLE)
+
+  END SUBROUTINE SETUP_RADIATION_SCHEME
+
+END MODULE RADIATION_SETUP
Index: DZ6/trunk/libf/phylmd/ecrad/lmdz/readaerosol_optic_ecrad.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/ecrad/lmdz/readaerosol_optic_ecrad.F90	(revision 5267)
+++ 	(revision )
@@ -1,314 +1,0 @@
-! $Id: readaerosol_optic_ecrad.F90
-!
-SUBROUTINE readaerosol_optic_ecrad(debut, aerosol_couple, ok_alw, ok_volcan, &
-     flag_aerosol, flag_bc_internal_mixture, itap, rjourvrai, &
-     pdtphys, pplay, paprs, t_seri, rhcl, presnivs, &
-     tr_seri, mass_solu_aero, mass_solu_aero_pi, m_allaer) 
-!     tau_aero, piz_aero, cg_aero, &
-!     tausum_aero, drytausum_aero, tau3d_aero )
-
-  ! This routine will :
-  ! 1) recevie the aerosols(already read and interpolated) corresponding to flag_aerosol
-  ! 2) calculate the optical properties for the aerosols
-  !
-
-  USE dimphy
-  USE aero_mod
-  USE phys_local_var_mod, only: sconcso4,sconcno3,sconcoa,sconcbc,sconcss,sconcdust, &
-       concso4,concno3,concoa,concbc,concss,concdust,loadso4,loadoa,loadbc,loadss,loaddust, &
-       loadno3,load_tmp1,load_tmp2,load_tmp3,load_tmp4,load_tmp5,load_tmp6,load_tmp7, & 
-       load_tmp8,load_tmp9,load_tmp10
-
-  USE infotrac_phy, ONLY: tracers, nqtot, nbtr
-  USE YOMCST
-
-  IMPLICIT NONE
-
-  include "clesphys.h"
-
-  ! Input arguments
-  !****************************************************************************************
-  LOGICAL, INTENT(IN)                      :: debut
-  LOGICAL, INTENT(IN)                      :: aerosol_couple
-  LOGICAL, INTENT(IN)                      :: ok_alw
-  LOGICAL, INTENT(IN)                      :: ok_volcan
-  INTEGER, INTENT(IN)                      :: flag_aerosol
-  LOGICAL, INTENT(IN)                      :: flag_bc_internal_mixture
-  INTEGER, INTENT(IN)                      :: itap
-  REAL, INTENT(IN)                         :: rjourvrai
-  REAL, INTENT(IN)                         :: pdtphys
-  REAL, DIMENSION(klon,klev), INTENT(IN)   :: pplay
-  REAL, DIMENSION(klon,klev+1), INTENT(IN) :: paprs
-  REAL, DIMENSION(klon,klev), INTENT(IN)   :: t_seri
-  REAL, DIMENSION(klon,klev), INTENT(IN)   :: rhcl   ! humidite relative ciel clair
-  REAL, DIMENSION(klev), INTENT(IN)        :: presnivs
-  REAL, DIMENSION(klon,klev,nbtr), INTENT(IN) :: tr_seri ! concentration tracer
-
-  ! Output arguments
-  !****************************************************************************************
-  REAL, DIMENSION(klon,klev), INTENT(OUT)     :: mass_solu_aero    ! Total mass for all soluble aerosols
-  REAL, DIMENSION(klon,klev), INTENT(OUT)     :: mass_solu_aero_pi !     -"-     preindustrial values
-  REAL, DIMENSION(klon,klev,naero_tot), INTENT(OUT) :: m_allaer
-  ! AI a passer par la suite en argument si besoin pour ecrad
-  !REAL, DIMENSION(klon,klev,naero_tot), INTENT(OUT) :: m_allaer_pi !RAF
-
-!  REAL, DIMENSION(klon,klev,2,NSW), INTENT(OUT) :: tau_aero    ! Aerosol optical thickness
-!  REAL, DIMENSION(klon,klev,2,NSW), INTENT(OUT) :: piz_aero    ! Single scattering albedo aerosol
-!  REAL, DIMENSION(klon,klev,2,NSW), INTENT(OUT) :: cg_aero     ! asymmetry parameter aerosol
-!  REAL, DIMENSION(klon,nwave,naero_tot), INTENT(OUT)       :: tausum_aero
-!  REAL, DIMENSION(klon,naero_tot), INTENT(OUT)             :: drytausum_aero
-!  REAL, DIMENSION(klon,klev,nwave,naero_tot), INTENT(OUT)  :: tau3d_aero
-
-  ! Local variables
-  !****************************************************************************************
-  REAL, DIMENSION(klon)        :: aerindex      ! POLDER aerosol index 
-  REAL, DIMENSION(klon,klev)   :: sulfacc       ! SO4 accumulation concentration [ug/m3]
-  REAL, DIMENSION(klon,klev)   :: sulfcoarse    ! SO4 coarse concentration [ug/m3]
-  REAL, DIMENSION(klon,klev)   :: bcsol         ! BC soluble concentration [ug/m3]
-  REAL, DIMENSION(klon,klev)   :: bcins         ! BC insoluble concentration [ug/m3]
-  REAL, DIMENSION(klon,klev)   :: pomsol        ! POM soluble concentration [ug/m3]
-  REAL, DIMENSION(klon,klev)   :: pomins        ! POM insoluble concentration [ug/m3]
-  REAL, DIMENSION(klon,klev)   :: cidust        ! DUST aerosol concentration  [ug/m3]
-  REAL, DIMENSION(klon,klev)   :: sscoarse      ! SS Coarse concentration [ug/m3]
-  REAL, DIMENSION(klon,klev)   :: sssupco       ! SS Super Coarse concentration [ug/m3]
-  REAL, DIMENSION(klon,klev)   :: ssacu         ! SS Acumulation concentration [ug/m3]
-  REAL, DIMENSION(klon,klev)   :: nitracc       ! nitrate accumulation concentration [ug/m3]
-  REAL, DIMENSION(klon,klev)   :: nitrcoarse    ! nitrate coarse concentration [ug/m3]
-  REAL, DIMENSION(klon,klev)   :: nitrinscoarse ! nitrate insoluble coarse concentration [ug/m3]
-  REAL, DIMENSION(klon,klev)   :: sulfacc_pi
-  REAL, DIMENSION(klon,klev)   :: sulfcoarse_pi
-  REAL, DIMENSION(klon,klev)   :: bcsol_pi
-  REAL, DIMENSION(klon,klev)   :: bcins_pi
-  REAL, DIMENSION(klon,klev)   :: pomsol_pi
-  REAL, DIMENSION(klon,klev)   :: pomins_pi
-  REAL, DIMENSION(klon,klev)   :: cidust_pi
-  REAL, DIMENSION(klon,klev)   :: sscoarse_pi
-  REAL, DIMENSION(klon,klev)   :: sssupco_pi
-  REAL, DIMENSION(klon,klev)   :: ssacu_pi
-  REAL, DIMENSION(klon,klev)   :: nitracc_pi
-  REAL, DIMENSION(klon,klev)   :: nitrcoarse_pi
-  REAL, DIMENSION(klon,klev)   :: nitrinscoarse_pi
-  REAL, DIMENSION(klon,klev)   :: pdel, zrho
-  REAL, DIMENSION(klon,klev,naero_tot) :: m_allaer_pi
-
-  integer :: id_ASBCM, id_ASPOMM, id_ASSO4M, id_ASMSAM, id_CSSO4M, id_CSMSAM, id_SSSSM
-  integer :: id_CSSSM, id_ASSSM, id_CIDUSTM, id_AIBCM, id_AIPOMM, id_ASNO3M, id_CSNO3M, id_CINO3M
-  INTEGER :: k, i, iq, itr
-
-  !--air density
-  zrho(:,:)=pplay(:,:)/t_seri(:,:)/RD                     !--kg/m3
-
-  !****************************************************************************************
-  ! 1) Get aerosol mass
-  !    
-  !****************************************************************************************
-  !
-  !
-  IF (aerosol_couple) THEN   !--we get aerosols from tr_seri array from INCA
-     !
-     !--copy fields from INCA tr_seri 
-     !--convert to ug m-3 unit for consistency with offline fields
-     !
-     itr = 0
-     DO iq = 1,nqtot
-        IF(.NOT. tracers(iq)%isInPhysics) CYCLE
-        itr = itr+1
-        SELECT CASE(trim(tracers(iq)%name))
-           CASE ("ASBCM");  id_ASBCM  = itr
-           CASE ("ASPOMM"); id_ASPOMM = itr
-           CASE ("ASSO4M"); id_ASSO4M = itr
-           CASE ("ASMSAM"); id_ASMSAM = itr
-           CASE ("CSSO4M"); id_CSSO4M = itr
-           CASE ("CSMSAM"); id_CSMSAM = itr
-           CASE ("SSSSM");  id_SSSSM  = itr
-           CASE ("CSSSM");  id_CSSSM  = itr
-           CASE ("ASSSM");  id_ASSSM  = itr
-           CASE ("CIDUSTM");id_CIDUSTM= itr
-           CASE ("AIBCM");  id_AIBCM  = itr
-           CASE ("AIPOMM"); id_AIPOMM = itr
-           CASE ("ASNO3M"); id_ASNO3M = itr
-           CASE ("CSNO3M"); id_CSNO3M = itr
-           CASE ("CINO3M"); id_CINO3M = itr
-        END SELECT
-     END DO
-
-     bcsol(:,:)        =   tr_seri(:,:,id_ASBCM)                         *zrho(:,:)*1.e9  ! ASBCM
-     pomsol(:,:)       =   tr_seri(:,:,id_ASPOMM)                        *zrho(:,:)*1.e9  ! ASPOMM
-     sulfacc(:,:)      =  (tr_seri(:,:,id_ASSO4M)+tr_seri(:,:,id_ASMSAM))*zrho(:,:)*1.e9  ! ASSO4M (=SO4) + ASMSAM (=MSA)
-     sulfcoarse(:,:)   =  (tr_seri(:,:,id_CSSO4M)+tr_seri(:,:,id_CSMSAM))*zrho(:,:)*1.e9  ! CSSO4M (=SO4) + CSMSAM (=MSA)
-     sssupco(:,:)      =   tr_seri(:,:,id_SSSSM)                         *zrho(:,:)*1.e9  ! SSSSM
-     sscoarse(:,:)     =   tr_seri(:,:,id_CSSSM)                         *zrho(:,:)*1.e9  ! CSSSM
-     ssacu(:,:)        =   tr_seri(:,:,id_ASSSM)                         *zrho(:,:)*1.e9  ! ASSSM
-     cidust(:,:)       =   tr_seri(:,:,id_CIDUSTM)                       *zrho(:,:)*1.e9  ! CIDUSTM
-     bcins(:,:)        =   tr_seri(:,:,id_AIBCM)                         *zrho(:,:)*1.e9  ! AIBCM
-     pomins(:,:)       =   tr_seri(:,:,id_AIPOMM)                        *zrho(:,:)*1.e9  ! AIPOMM
-     nitracc(:,:)      =   tr_seri(:,:,id_ASNO3M)                        *zrho(:,:)*1.e9  ! ASNO3M
-     nitrcoarse(:,:)   =   tr_seri(:,:,id_CSNO3M)                        *zrho(:,:)*1.e9  ! CSNO3M
-     nitrinscoarse(:,:)=   tr_seri(:,:,id_CINO3M)                        *zrho(:,:)*1.e9  ! CINO3M
-     !
-     bcsol_pi(:,:)        =   0.0 ! ASBCM pre-ind
-     pomsol_pi(:,:)       =   0.0 ! ASPOMM pre-ind
-     sulfacc_pi(:,:)      =   0.0 ! ASSO4M (=SO4) + ASMSAM (=MSA) pre-ind
-     sulfcoarse_pi(:,:)   =   0.0 ! CSSO4M (=SO4) + CSMSAM (=MSA) pre-ind
-     sssupco_pi(:,:)      =   0.0 ! SSSSM pre-ind
-     sscoarse_pi(:,:)     =   0.0 ! CSSSM pre-ind
-     ssacu_pi(:,:)        =   0.0 ! ASSSM pre-ind
-     cidust_pi(:,:)       =   0.0 ! CIDUSTM pre-ind
-     bcins_pi(:,:)        =   0.0 ! AIBCM pre-ind
-     pomins_pi(:,:)       =   0.0 ! AIPOMM pre-ind
-     nitracc_pi(:,:)      =   0.0 ! ASNO3M pre-ind
-     nitrcoarse_pi(:,:)   =   0.0 ! CSNO3M pre-ind
-     nitrinscoarse_pi(:,:)=   0.0 ! CINO3M
-     !
-  ELSE !--not aerosol_couple
-     !
-     ! Read and interpolate sulfate
-     IF ( flag_aerosol .EQ. 1 .OR. flag_aerosol .EQ. 6 .OR. flag_aerosol .EQ. 7 ) THEN 
-
-        CALL readaerosol_interp(id_ASSO4M_phy, itap, pdtphys, rjourvrai, debut, pplay, paprs, t_seri, sulfacc, sulfacc_pi,loadso4)
-     ELSE
-        sulfacc(:,:) = 0. ; sulfacc_pi(:,:) = 0.
-        loadso4=0.
-     ENDIF
-
-     ! Read and interpolate bcsol and bcins
-     IF ( flag_aerosol .EQ. 2 .OR. flag_aerosol .EQ. 6 .OR. flag_aerosol .EQ. 7 ) THEN 
-
-        ! Get bc aerosol distribution 
-        CALL readaerosol_interp(id_ASBCM_phy, itap, pdtphys, rjourvrai, debut, pplay, paprs, t_seri, bcsol, bcsol_pi, load_tmp1 )
-        CALL readaerosol_interp(id_AIBCM_phy, itap, pdtphys, rjourvrai, debut, pplay, paprs, t_seri, bcins, bcins_pi, load_tmp2 )
-        loadbc(:)=load_tmp1(:)+load_tmp2(:)
-     ELSE
-        bcsol(:,:) = 0. ; bcsol_pi(:,:) = 0.
-        bcins(:,:) = 0. ; bcins_pi(:,:) = 0.
-        loadbc=0.
-     ENDIF
-
-     ! Read and interpolate pomsol and pomins
-     IF ( flag_aerosol .EQ. 3 .OR. flag_aerosol .EQ. 6 .OR. flag_aerosol .EQ. 7 ) THEN
-
-        CALL readaerosol_interp(id_ASPOMM_phy, itap, pdtphys, rjourvrai, debut, pplay, paprs, t_seri, pomsol, pomsol_pi, load_tmp3)
-        CALL readaerosol_interp(id_AIPOMM_phy, itap, pdtphys, rjourvrai, debut, pplay, paprs, t_seri, pomins, pomins_pi, load_tmp4)
-        loadoa(:)=load_tmp3(:)+load_tmp4(:)
-     ELSE
-        pomsol(:,:) = 0. ; pomsol_pi(:,:) = 0.
-        pomins(:,:) = 0. ; pomins_pi(:,:) = 0.
-        loadoa=0.
-     ENDIF
-
-     ! Read and interpolate csssm, ssssm, assssm
-     IF (flag_aerosol .EQ. 4 .OR. flag_aerosol .EQ. 6 .OR. flag_aerosol .EQ. 7 ) THEN 
-
-        CALL readaerosol_interp(id_SSSSM_phy ,itap, pdtphys,rjourvrai, &
-        debut, pplay, paprs, t_seri, sssupco, sssupco_pi, load_tmp5) 
-        CALL readaerosol_interp(id_CSSSM_phy ,itap, pdtphys,rjourvrai, &
-        debut, pplay, paprs, t_seri, sscoarse,sscoarse_pi, load_tmp6) 
-        CALL readaerosol_interp(id_ASSSM_phy ,itap, pdtphys,rjourvrai, &
-        debut, pplay, paprs, t_seri, ssacu, ssacu_pi, load_tmp7) 
-        loadss(:)=load_tmp5(:)+load_tmp6(:)+load_tmp7(:)
-     ELSE
-        sscoarse(:,:) = 0. ; sscoarse_pi(:,:) = 0. 
-        ssacu(:,:)    = 0. ; ssacu_pi(:,:) = 0. 
-        sssupco(:,:)  = 0. ; sssupco_pi = 0. 
-        loadss=0.
-     ENDIF
-
-     ! Read and interpolate cidustm
-     IF (flag_aerosol .EQ. 5 .OR. flag_aerosol .EQ. 6 .OR. flag_aerosol .EQ. 7 ) THEN 
-
-        CALL readaerosol_interp(id_CIDUSTM_phy, itap, pdtphys, rjourvrai, debut, pplay, paprs, t_seri, cidust, cidust_pi, loaddust) 
-
-     ELSE
-        cidust(:,:) = 0. ; cidust_pi(:,:) = 0. 
-        loaddust=0.
-     ENDIF
-     !
-     ! Read and interpolate asno3m, csno3m, cino3m
-     IF (flag_aerosol .EQ. 6 .OR. flag_aerosol .EQ. 7 ) THEN 
-
-        CALL readaerosol_interp(id_ASNO3M_phy, itap, pdtphys, rjourvrai, & 
-        debut, pplay, paprs, t_seri, nitracc, nitracc_pi, load_tmp8) 
-        CALL readaerosol_interp(id_CSNO3M_phy, itap, pdtphys, rjourvrai, & 
-        debut, pplay, paprs, t_seri, nitrcoarse, nitrcoarse_pi, load_tmp9) 
-        CALL readaerosol_interp(id_CINO3M_phy, itap, pdtphys, rjourvrai, & 
-        debut, pplay, paprs, t_seri, nitrinscoarse, nitrinscoarse_pi, load_tmp10) 
-        loadno3(:)=load_tmp8(:)+load_tmp9(:)+load_tmp10(:)
-
-     ELSE
-        nitracc(:,:)         =   0.0 ; nitracc_pi(:,:)      =   0.0 
-        nitrcoarse(:,:)      =   0.0 ; nitrcoarse_pi(:,:)   =   0.0
-        nitrinscoarse(:,:)   =   0.0 ; nitrinscoarse_pi(:,:)=   0.0
-        loadno3(:)=0.0
-     ENDIF
-     !
-     ! CSSO4M is set to 0 as not reliable
-     sulfcoarse(:,:)      =   0.0 ! CSSO4M (=SO4) + CSMSAM (=MSA) 
-     sulfcoarse_pi(:,:)   =   0.0 ! CSSO4M (=SO4) + CSMSAM (=MSA) pre-ind
-
-  ENDIF !--not aerosol_couple
-
-  !
-  ! Store all aerosols mixing ratios in one variable for radiation scheme (unit kg/kg for ECRAD)
-  ! present-day values
-  m_allaer(:,:,id_ASBCM_phy)  = bcsol(:,:)        /1.e9/zrho(:,:) ! ASBCM
-  m_allaer(:,:,id_ASPOMM_phy) = pomsol(:,:)       /1.e9/zrho(:,:) ! ASPOMM
-  m_allaer(:,:,id_ASSO4M_phy) = sulfacc(:,:)      /1.e9/zrho(:,:) ! ASSO4M (= SO4) 
-  m_allaer(:,:,id_CSSO4M_phy) = sulfcoarse(:,:)   /1.e9/zrho(:,:) ! CSSO4M 
-  m_allaer(:,:,id_SSSSM_phy)  = sssupco(:,:)      /1.e9/zrho(:,:) ! SSSSM
-  m_allaer(:,:,id_CSSSM_phy)  = sscoarse(:,:)     /1.e9/zrho(:,:) ! CSSSM
-  m_allaer(:,:,id_ASSSM_phy)  = ssacu(:,:)        /1.e9/zrho(:,:) ! ASSSM
-  m_allaer(:,:,id_CIDUSTM_phy)= cidust(:,:)       /1.e9/zrho(:,:) ! CIDUSTM
-  m_allaer(:,:,id_AIBCM_phy)  = bcins(:,:)        /1.e9/zrho(:,:) ! AIBCM
-  m_allaer(:,:,id_ASNO3M_phy) = nitracc(:,:)      /1.e9/zrho(:,:) ! ASNO3M
-  m_allaer(:,:,id_CSNO3M_phy) = nitrcoarse(:,:)   /1.e9/zrho(:,:) ! CSNO3M
-  m_allaer(:,:,id_CINO3M_phy) = nitrinscoarse(:,:)/1.e9/zrho(:,:) ! CINO3M
-  m_allaer(:,:,id_AIPOMM_phy) = pomins(:,:)       /1.e9/zrho(:,:) ! AIPOMM
-  m_allaer(:,:,id_STRAT_phy)  = 0.0
-
-  !  pre-industrial (pi) values
-  m_allaer_pi(:,:,id_ASBCM_phy)  = bcsol_pi(:,:)        /1.e9/zrho(:,:) ! ASBCM pre-ind
-  m_allaer_pi(:,:,id_ASPOMM_phy) = pomsol_pi(:,:)       /1.e9/zrho(:,:) ! ASPOMM pre-ind
-  m_allaer_pi(:,:,id_ASSO4M_phy) = sulfacc_pi(:,:)      /1.e9/zrho(:,:) ! ASSO4M (= SO4) pre-ind
-  m_allaer_pi(:,:,id_CSSO4M_phy) = sulfcoarse_pi(:,:)   /1.e9/zrho(:,:) ! CSSO4M pre-ind
-  m_allaer_pi(:,:,id_SSSSM_phy)  = sssupco_pi(:,:)      /1.e9/zrho(:,:) ! SSSSM pre-ind
-  m_allaer_pi(:,:,id_CSSSM_phy)  = sscoarse_pi(:,:)     /1.e9/zrho(:,:) ! CSSSM pre-ind
-  m_allaer_pi(:,:,id_ASSSM_phy)  = ssacu_pi(:,:)        /1.e9/zrho(:,:) ! ASSSM pre-ind
-  m_allaer_pi(:,:,id_CIDUSTM_phy)= cidust_pi(:,:)       /1.e9/zrho(:,:) ! CIDUSTM pre-ind
-  m_allaer_pi(:,:,id_AIBCM_phy)  = bcins_pi(:,:)        /1.e9/zrho(:,:) ! AIBCM pre-ind
-  m_allaer_pi(:,:,id_ASNO3M_phy) = nitracc_pi(:,:)      /1.e9/zrho(:,:) ! ASNO3M pre-ind
-  m_allaer_pi(:,:,id_CSNO3M_phy) = nitrcoarse_pi(:,:)   /1.e9/zrho(:,:) ! CSNO3M pre-ind
-  m_allaer_pi(:,:,id_CINO3M_phy) = nitrinscoarse_pi(:,:)/1.e9/zrho(:,:) ! CINO3M pre-ind
-  m_allaer_pi(:,:,id_AIPOMM_phy) = pomins_pi(:,:)       /1.e9/zrho(:,:) ! AIPOMM pre-ind
-  m_allaer_pi(:,:,id_STRAT_phy)  = 0.0
-
-  !
-  ! Calculate the total mass of all soluble aersosols (in unit ug /m3)
-  ! to be revisited for AR6
-  mass_solu_aero(:,:)    = sulfacc(:,:)    + bcsol(:,:)    + pomsol(:,:)    + nitracc(:,:)    + ssacu(:,:)
-  mass_solu_aero_pi(:,:) = sulfacc_pi(:,:) + bcsol_pi(:,:) + pomsol_pi(:,:) + nitracc_pi(:,:) + ssacu_pi(:,:)
-
-  !****************************************************************************************
-  ! 2) Calculate optical properties for the aerosols
-  !
-  !****************************************************************************************
-  DO k = 1, klev
-     DO i = 1, klon
-        pdel(i,k) = paprs(i,k) - paprs (i,k+1)
-     ENDDO
-  ENDDO
-
-  ! Diagnostics calculation for CMIP5 protocol unit (in unit kg/m3)
-  sconcso4(:)  =m_allaer(:,1,id_ASSO4M_phy)*1.e-9
-  sconcno3(:)  =(m_allaer(:,1,id_ASNO3M_phy)+m_allaer(:,1,id_CSNO3M_phy)+m_allaer(:,1,id_CINO3M_phy))*1.e-9
-  sconcoa(:)   =(m_allaer(:,1,id_ASPOMM_phy)+m_allaer(:,1,id_AIPOMM_phy))*1.e-9
-  sconcbc(:)   =(m_allaer(:,1,id_ASBCM_phy)+m_allaer(:,1,id_AIBCM_phy))*1.e-9
-  sconcss(:)   =(m_allaer(:,1,id_ASSSM_phy)+m_allaer(:,1,id_CSSSM_phy)+m_allaer(:,1,id_SSSSM_phy))*1.e-9
-  sconcdust(:) =m_allaer(:,1,id_CIDUSTM_phy)*1.e-9
-  concso4(:,:) =m_allaer(:,:,id_ASSO4M_phy)*1.e-9
-  concno3(:,:) =(m_allaer(:,:,id_ASNO3M_phy)+m_allaer(:,:,id_CSNO3M_phy)+m_allaer(:,:,id_CINO3M_phy))*1.e-9
-  concoa(:,:)  =(m_allaer(:,:,id_ASPOMM_phy)+m_allaer(:,:,id_AIPOMM_phy))*1.e-9
-  concbc(:,:)  =(m_allaer(:,:,id_ASBCM_phy)+m_allaer(:,:,id_AIBCM_phy))*1.e-9
-  concss(:,:)  =(m_allaer(:,:,id_ASSSM_phy)+m_allaer(:,:,id_CSSSM_phy)+m_allaer(:,:,id_SSSSM_phy))*1.e-9
-  concdust(:,:)=m_allaer(:,:,id_CIDUSTM_phy)*1.e-9
-
-END SUBROUTINE readaerosol_optic_ecrad
Index: /LMDZ6/trunk/libf/phylmd/ecrad/lmdz/readaerosol_optic_ecrad.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/ecrad/lmdz/readaerosol_optic_ecrad.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/ecrad/lmdz/readaerosol_optic_ecrad.f90	(revision 5268)
@@ -0,0 +1,314 @@
+! $Id: readaerosol_optic_ecrad.F90
+!
+SUBROUTINE readaerosol_optic_ecrad(debut, aerosol_couple, ok_alw, ok_volcan, &
+     flag_aerosol, flag_bc_internal_mixture, itap, rjourvrai, &
+     pdtphys, pplay, paprs, t_seri, rhcl, presnivs, &
+     tr_seri, mass_solu_aero, mass_solu_aero_pi, m_allaer) 
+!     tau_aero, piz_aero, cg_aero, &
+!     tausum_aero, drytausum_aero, tau3d_aero )
+
+  ! This routine will :
+  ! 1) recevie the aerosols(already read and interpolated) corresponding to flag_aerosol
+  ! 2) calculate the optical properties for the aerosols
+  !
+
+  USE dimphy
+  USE aero_mod
+  USE phys_local_var_mod, only: sconcso4,sconcno3,sconcoa,sconcbc,sconcss,sconcdust, &
+       concso4,concno3,concoa,concbc,concss,concdust,loadso4,loadoa,loadbc,loadss,loaddust, &
+       loadno3,load_tmp1,load_tmp2,load_tmp3,load_tmp4,load_tmp5,load_tmp6,load_tmp7, & 
+       load_tmp8,load_tmp9,load_tmp10
+
+  USE infotrac_phy, ONLY: tracers, nqtot, nbtr
+  USE YOMCST
+
+  IMPLICIT NONE
+
+  include "clesphys.h"
+
+  ! Input arguments
+  !****************************************************************************************
+  LOGICAL, INTENT(IN)                      :: debut
+  LOGICAL, INTENT(IN)                      :: aerosol_couple
+  LOGICAL, INTENT(IN)                      :: ok_alw
+  LOGICAL, INTENT(IN)                      :: ok_volcan
+  INTEGER, INTENT(IN)                      :: flag_aerosol
+  LOGICAL, INTENT(IN)                      :: flag_bc_internal_mixture
+  INTEGER, INTENT(IN)                      :: itap
+  REAL, INTENT(IN)                         :: rjourvrai
+  REAL, INTENT(IN)                         :: pdtphys
+  REAL, DIMENSION(klon,klev), INTENT(IN)   :: pplay
+  REAL, DIMENSION(klon,klev+1), INTENT(IN) :: paprs
+  REAL, DIMENSION(klon,klev), INTENT(IN)   :: t_seri
+  REAL, DIMENSION(klon,klev), INTENT(IN)   :: rhcl   ! humidite relative ciel clair
+  REAL, DIMENSION(klev), INTENT(IN)        :: presnivs
+  REAL, DIMENSION(klon,klev,nbtr), INTENT(IN) :: tr_seri ! concentration tracer
+
+  ! Output arguments
+  !****************************************************************************************
+  REAL, DIMENSION(klon,klev), INTENT(OUT)     :: mass_solu_aero    ! Total mass for all soluble aerosols
+  REAL, DIMENSION(klon,klev), INTENT(OUT)     :: mass_solu_aero_pi !     -"-     preindustrial values
+  REAL, DIMENSION(klon,klev,naero_tot), INTENT(OUT) :: m_allaer
+  ! AI a passer par la suite en argument si besoin pour ecrad
+  !REAL, DIMENSION(klon,klev,naero_tot), INTENT(OUT) :: m_allaer_pi !RAF
+
+!  REAL, DIMENSION(klon,klev,2,NSW), INTENT(OUT) :: tau_aero    ! Aerosol optical thickness
+!  REAL, DIMENSION(klon,klev,2,NSW), INTENT(OUT) :: piz_aero    ! Single scattering albedo aerosol
+!  REAL, DIMENSION(klon,klev,2,NSW), INTENT(OUT) :: cg_aero     ! asymmetry parameter aerosol
+!  REAL, DIMENSION(klon,nwave,naero_tot), INTENT(OUT)       :: tausum_aero
+!  REAL, DIMENSION(klon,naero_tot), INTENT(OUT)             :: drytausum_aero
+!  REAL, DIMENSION(klon,klev,nwave,naero_tot), INTENT(OUT)  :: tau3d_aero
+
+  ! Local variables
+  !****************************************************************************************
+  REAL, DIMENSION(klon)        :: aerindex      ! POLDER aerosol index 
+  REAL, DIMENSION(klon,klev)   :: sulfacc       ! SO4 accumulation concentration [ug/m3]
+  REAL, DIMENSION(klon,klev)   :: sulfcoarse    ! SO4 coarse concentration [ug/m3]
+  REAL, DIMENSION(klon,klev)   :: bcsol         ! BC soluble concentration [ug/m3]
+  REAL, DIMENSION(klon,klev)   :: bcins         ! BC insoluble concentration [ug/m3]
+  REAL, DIMENSION(klon,klev)   :: pomsol        ! POM soluble concentration [ug/m3]
+  REAL, DIMENSION(klon,klev)   :: pomins        ! POM insoluble concentration [ug/m3]
+  REAL, DIMENSION(klon,klev)   :: cidust        ! DUST aerosol concentration  [ug/m3]
+  REAL, DIMENSION(klon,klev)   :: sscoarse      ! SS Coarse concentration [ug/m3]
+  REAL, DIMENSION(klon,klev)   :: sssupco       ! SS Super Coarse concentration [ug/m3]
+  REAL, DIMENSION(klon,klev)   :: ssacu         ! SS Acumulation concentration [ug/m3]
+  REAL, DIMENSION(klon,klev)   :: nitracc       ! nitrate accumulation concentration [ug/m3]
+  REAL, DIMENSION(klon,klev)   :: nitrcoarse    ! nitrate coarse concentration [ug/m3]
+  REAL, DIMENSION(klon,klev)   :: nitrinscoarse ! nitrate insoluble coarse concentration [ug/m3]
+  REAL, DIMENSION(klon,klev)   :: sulfacc_pi
+  REAL, DIMENSION(klon,klev)   :: sulfcoarse_pi
+  REAL, DIMENSION(klon,klev)   :: bcsol_pi
+  REAL, DIMENSION(klon,klev)   :: bcins_pi
+  REAL, DIMENSION(klon,klev)   :: pomsol_pi
+  REAL, DIMENSION(klon,klev)   :: pomins_pi
+  REAL, DIMENSION(klon,klev)   :: cidust_pi
+  REAL, DIMENSION(klon,klev)   :: sscoarse_pi
+  REAL, DIMENSION(klon,klev)   :: sssupco_pi
+  REAL, DIMENSION(klon,klev)   :: ssacu_pi
+  REAL, DIMENSION(klon,klev)   :: nitracc_pi
+  REAL, DIMENSION(klon,klev)   :: nitrcoarse_pi
+  REAL, DIMENSION(klon,klev)   :: nitrinscoarse_pi
+  REAL, DIMENSION(klon,klev)   :: pdel, zrho
+  REAL, DIMENSION(klon,klev,naero_tot) :: m_allaer_pi
+
+  integer :: id_ASBCM, id_ASPOMM, id_ASSO4M, id_ASMSAM, id_CSSO4M, id_CSMSAM, id_SSSSM
+  integer :: id_CSSSM, id_ASSSM, id_CIDUSTM, id_AIBCM, id_AIPOMM, id_ASNO3M, id_CSNO3M, id_CINO3M
+  INTEGER :: k, i, iq, itr
+
+  !--air density
+  zrho(:,:)=pplay(:,:)/t_seri(:,:)/RD                     !--kg/m3
+
+  !****************************************************************************************
+  ! 1) Get aerosol mass
+  !    
+  !****************************************************************************************
+  !
+  !
+  IF (aerosol_couple) THEN   !--we get aerosols from tr_seri array from INCA
+     !
+     !--copy fields from INCA tr_seri 
+     !--convert to ug m-3 unit for consistency with offline fields
+     !
+     itr = 0
+     DO iq = 1,nqtot
+        IF(.NOT. tracers(iq)%isInPhysics) CYCLE
+        itr = itr+1
+        SELECT CASE(trim(tracers(iq)%name))
+           CASE ("ASBCM");  id_ASBCM  = itr
+           CASE ("ASPOMM"); id_ASPOMM = itr
+           CASE ("ASSO4M"); id_ASSO4M = itr
+           CASE ("ASMSAM"); id_ASMSAM = itr
+           CASE ("CSSO4M"); id_CSSO4M = itr
+           CASE ("CSMSAM"); id_CSMSAM = itr
+           CASE ("SSSSM");  id_SSSSM  = itr
+           CASE ("CSSSM");  id_CSSSM  = itr
+           CASE ("ASSSM");  id_ASSSM  = itr
+           CASE ("CIDUSTM");id_CIDUSTM= itr
+           CASE ("AIBCM");  id_AIBCM  = itr
+           CASE ("AIPOMM"); id_AIPOMM = itr
+           CASE ("ASNO3M"); id_ASNO3M = itr
+           CASE ("CSNO3M"); id_CSNO3M = itr
+           CASE ("CINO3M"); id_CINO3M = itr
+        END SELECT
+     END DO
+
+     bcsol(:,:)        =   tr_seri(:,:,id_ASBCM)                         *zrho(:,:)*1.e9  ! ASBCM
+     pomsol(:,:)       =   tr_seri(:,:,id_ASPOMM)                        *zrho(:,:)*1.e9  ! ASPOMM
+     sulfacc(:,:)      =  (tr_seri(:,:,id_ASSO4M)+tr_seri(:,:,id_ASMSAM))*zrho(:,:)*1.e9  ! ASSO4M (=SO4) + ASMSAM (=MSA)
+     sulfcoarse(:,:)   =  (tr_seri(:,:,id_CSSO4M)+tr_seri(:,:,id_CSMSAM))*zrho(:,:)*1.e9  ! CSSO4M (=SO4) + CSMSAM (=MSA)
+     sssupco(:,:)      =   tr_seri(:,:,id_SSSSM)                         *zrho(:,:)*1.e9  ! SSSSM
+     sscoarse(:,:)     =   tr_seri(:,:,id_CSSSM)                         *zrho(:,:)*1.e9  ! CSSSM
+     ssacu(:,:)        =   tr_seri(:,:,id_ASSSM)                         *zrho(:,:)*1.e9  ! ASSSM
+     cidust(:,:)       =   tr_seri(:,:,id_CIDUSTM)                       *zrho(:,:)*1.e9  ! CIDUSTM
+     bcins(:,:)        =   tr_seri(:,:,id_AIBCM)                         *zrho(:,:)*1.e9  ! AIBCM
+     pomins(:,:)       =   tr_seri(:,:,id_AIPOMM)                        *zrho(:,:)*1.e9  ! AIPOMM
+     nitracc(:,:)      =   tr_seri(:,:,id_ASNO3M)                        *zrho(:,:)*1.e9  ! ASNO3M
+     nitrcoarse(:,:)   =   tr_seri(:,:,id_CSNO3M)                        *zrho(:,:)*1.e9  ! CSNO3M
+     nitrinscoarse(:,:)=   tr_seri(:,:,id_CINO3M)                        *zrho(:,:)*1.e9  ! CINO3M
+     !
+     bcsol_pi(:,:)        =   0.0 ! ASBCM pre-ind
+     pomsol_pi(:,:)       =   0.0 ! ASPOMM pre-ind
+     sulfacc_pi(:,:)      =   0.0 ! ASSO4M (=SO4) + ASMSAM (=MSA) pre-ind
+     sulfcoarse_pi(:,:)   =   0.0 ! CSSO4M (=SO4) + CSMSAM (=MSA) pre-ind
+     sssupco_pi(:,:)      =   0.0 ! SSSSM pre-ind
+     sscoarse_pi(:,:)     =   0.0 ! CSSSM pre-ind
+     ssacu_pi(:,:)        =   0.0 ! ASSSM pre-ind
+     cidust_pi(:,:)       =   0.0 ! CIDUSTM pre-ind
+     bcins_pi(:,:)        =   0.0 ! AIBCM pre-ind
+     pomins_pi(:,:)       =   0.0 ! AIPOMM pre-ind
+     nitracc_pi(:,:)      =   0.0 ! ASNO3M pre-ind
+     nitrcoarse_pi(:,:)   =   0.0 ! CSNO3M pre-ind
+     nitrinscoarse_pi(:,:)=   0.0 ! CINO3M
+     !
+  ELSE !--not aerosol_couple
+     !
+     ! Read and interpolate sulfate
+     IF ( flag_aerosol .EQ. 1 .OR. flag_aerosol .EQ. 6 .OR. flag_aerosol .EQ. 7 ) THEN 
+
+        CALL readaerosol_interp(id_ASSO4M_phy, itap, pdtphys, rjourvrai, debut, pplay, paprs, t_seri, sulfacc, sulfacc_pi,loadso4)
+     ELSE
+        sulfacc(:,:) = 0. ; sulfacc_pi(:,:) = 0.
+        loadso4=0.
+     ENDIF
+
+     ! Read and interpolate bcsol and bcins
+     IF ( flag_aerosol .EQ. 2 .OR. flag_aerosol .EQ. 6 .OR. flag_aerosol .EQ. 7 ) THEN 
+
+        ! Get bc aerosol distribution 
+        CALL readaerosol_interp(id_ASBCM_phy, itap, pdtphys, rjourvrai, debut, pplay, paprs, t_seri, bcsol, bcsol_pi, load_tmp1 )
+        CALL readaerosol_interp(id_AIBCM_phy, itap, pdtphys, rjourvrai, debut, pplay, paprs, t_seri, bcins, bcins_pi, load_tmp2 )
+        loadbc(:)=load_tmp1(:)+load_tmp2(:)
+     ELSE
+        bcsol(:,:) = 0. ; bcsol_pi(:,:) = 0.
+        bcins(:,:) = 0. ; bcins_pi(:,:) = 0.
+        loadbc=0.
+     ENDIF
+
+     ! Read and interpolate pomsol and pomins
+     IF ( flag_aerosol .EQ. 3 .OR. flag_aerosol .EQ. 6 .OR. flag_aerosol .EQ. 7 ) THEN
+
+        CALL readaerosol_interp(id_ASPOMM_phy, itap, pdtphys, rjourvrai, debut, pplay, paprs, t_seri, pomsol, pomsol_pi, load_tmp3)
+        CALL readaerosol_interp(id_AIPOMM_phy, itap, pdtphys, rjourvrai, debut, pplay, paprs, t_seri, pomins, pomins_pi, load_tmp4)
+        loadoa(:)=load_tmp3(:)+load_tmp4(:)
+     ELSE
+        pomsol(:,:) = 0. ; pomsol_pi(:,:) = 0.
+        pomins(:,:) = 0. ; pomins_pi(:,:) = 0.
+        loadoa=0.
+     ENDIF
+
+     ! Read and interpolate csssm, ssssm, assssm
+     IF (flag_aerosol .EQ. 4 .OR. flag_aerosol .EQ. 6 .OR. flag_aerosol .EQ. 7 ) THEN 
+
+        CALL readaerosol_interp(id_SSSSM_phy ,itap, pdtphys,rjourvrai, &
+        debut, pplay, paprs, t_seri, sssupco, sssupco_pi, load_tmp5) 
+        CALL readaerosol_interp(id_CSSSM_phy ,itap, pdtphys,rjourvrai, &
+        debut, pplay, paprs, t_seri, sscoarse,sscoarse_pi, load_tmp6) 
+        CALL readaerosol_interp(id_ASSSM_phy ,itap, pdtphys,rjourvrai, &
+        debut, pplay, paprs, t_seri, ssacu, ssacu_pi, load_tmp7) 
+        loadss(:)=load_tmp5(:)+load_tmp6(:)+load_tmp7(:)
+     ELSE
+        sscoarse(:,:) = 0. ; sscoarse_pi(:,:) = 0. 
+        ssacu(:,:)    = 0. ; ssacu_pi(:,:) = 0. 
+        sssupco(:,:)  = 0. ; sssupco_pi = 0. 
+        loadss=0.
+     ENDIF
+
+     ! Read and interpolate cidustm
+     IF (flag_aerosol .EQ. 5 .OR. flag_aerosol .EQ. 6 .OR. flag_aerosol .EQ. 7 ) THEN 
+
+        CALL readaerosol_interp(id_CIDUSTM_phy, itap, pdtphys, rjourvrai, debut, pplay, paprs, t_seri, cidust, cidust_pi, loaddust) 
+
+     ELSE
+        cidust(:,:) = 0. ; cidust_pi(:,:) = 0. 
+        loaddust=0.
+     ENDIF
+     !
+     ! Read and interpolate asno3m, csno3m, cino3m
+     IF (flag_aerosol .EQ. 6 .OR. flag_aerosol .EQ. 7 ) THEN 
+
+        CALL readaerosol_interp(id_ASNO3M_phy, itap, pdtphys, rjourvrai, & 
+        debut, pplay, paprs, t_seri, nitracc, nitracc_pi, load_tmp8) 
+        CALL readaerosol_interp(id_CSNO3M_phy, itap, pdtphys, rjourvrai, & 
+        debut, pplay, paprs, t_seri, nitrcoarse, nitrcoarse_pi, load_tmp9) 
+        CALL readaerosol_interp(id_CINO3M_phy, itap, pdtphys, rjourvrai, & 
+        debut, pplay, paprs, t_seri, nitrinscoarse, nitrinscoarse_pi, load_tmp10) 
+        loadno3(:)=load_tmp8(:)+load_tmp9(:)+load_tmp10(:)
+
+     ELSE
+        nitracc(:,:)         =   0.0 ; nitracc_pi(:,:)      =   0.0 
+        nitrcoarse(:,:)      =   0.0 ; nitrcoarse_pi(:,:)   =   0.0
+        nitrinscoarse(:,:)   =   0.0 ; nitrinscoarse_pi(:,:)=   0.0
+        loadno3(:)=0.0
+     ENDIF
+     !
+     ! CSSO4M is set to 0 as not reliable
+     sulfcoarse(:,:)      =   0.0 ! CSSO4M (=SO4) + CSMSAM (=MSA) 
+     sulfcoarse_pi(:,:)   =   0.0 ! CSSO4M (=SO4) + CSMSAM (=MSA) pre-ind
+
+  ENDIF !--not aerosol_couple
+
+  !
+  ! Store all aerosols mixing ratios in one variable for radiation scheme (unit kg/kg for ECRAD)
+  ! present-day values
+  m_allaer(:,:,id_ASBCM_phy)  = bcsol(:,:)        /1.e9/zrho(:,:) ! ASBCM
+  m_allaer(:,:,id_ASPOMM_phy) = pomsol(:,:)       /1.e9/zrho(:,:) ! ASPOMM
+  m_allaer(:,:,id_ASSO4M_phy) = sulfacc(:,:)      /1.e9/zrho(:,:) ! ASSO4M (= SO4) 
+  m_allaer(:,:,id_CSSO4M_phy) = sulfcoarse(:,:)   /1.e9/zrho(:,:) ! CSSO4M 
+  m_allaer(:,:,id_SSSSM_phy)  = sssupco(:,:)      /1.e9/zrho(:,:) ! SSSSM
+  m_allaer(:,:,id_CSSSM_phy)  = sscoarse(:,:)     /1.e9/zrho(:,:) ! CSSSM
+  m_allaer(:,:,id_ASSSM_phy)  = ssacu(:,:)        /1.e9/zrho(:,:) ! ASSSM
+  m_allaer(:,:,id_CIDUSTM_phy)= cidust(:,:)       /1.e9/zrho(:,:) ! CIDUSTM
+  m_allaer(:,:,id_AIBCM_phy)  = bcins(:,:)        /1.e9/zrho(:,:) ! AIBCM
+  m_allaer(:,:,id_ASNO3M_phy) = nitracc(:,:)      /1.e9/zrho(:,:) ! ASNO3M
+  m_allaer(:,:,id_CSNO3M_phy) = nitrcoarse(:,:)   /1.e9/zrho(:,:) ! CSNO3M
+  m_allaer(:,:,id_CINO3M_phy) = nitrinscoarse(:,:)/1.e9/zrho(:,:) ! CINO3M
+  m_allaer(:,:,id_AIPOMM_phy) = pomins(:,:)       /1.e9/zrho(:,:) ! AIPOMM
+  m_allaer(:,:,id_STRAT_phy)  = 0.0
+
+  !  pre-industrial (pi) values
+  m_allaer_pi(:,:,id_ASBCM_phy)  = bcsol_pi(:,:)        /1.e9/zrho(:,:) ! ASBCM pre-ind
+  m_allaer_pi(:,:,id_ASPOMM_phy) = pomsol_pi(:,:)       /1.e9/zrho(:,:) ! ASPOMM pre-ind
+  m_allaer_pi(:,:,id_ASSO4M_phy) = sulfacc_pi(:,:)      /1.e9/zrho(:,:) ! ASSO4M (= SO4) pre-ind
+  m_allaer_pi(:,:,id_CSSO4M_phy) = sulfcoarse_pi(:,:)   /1.e9/zrho(:,:) ! CSSO4M pre-ind
+  m_allaer_pi(:,:,id_SSSSM_phy)  = sssupco_pi(:,:)      /1.e9/zrho(:,:) ! SSSSM pre-ind
+  m_allaer_pi(:,:,id_CSSSM_phy)  = sscoarse_pi(:,:)     /1.e9/zrho(:,:) ! CSSSM pre-ind
+  m_allaer_pi(:,:,id_ASSSM_phy)  = ssacu_pi(:,:)        /1.e9/zrho(:,:) ! ASSSM pre-ind
+  m_allaer_pi(:,:,id_CIDUSTM_phy)= cidust_pi(:,:)       /1.e9/zrho(:,:) ! CIDUSTM pre-ind
+  m_allaer_pi(:,:,id_AIBCM_phy)  = bcins_pi(:,:)        /1.e9/zrho(:,:) ! AIBCM pre-ind
+  m_allaer_pi(:,:,id_ASNO3M_phy) = nitracc_pi(:,:)      /1.e9/zrho(:,:) ! ASNO3M pre-ind
+  m_allaer_pi(:,:,id_CSNO3M_phy) = nitrcoarse_pi(:,:)   /1.e9/zrho(:,:) ! CSNO3M pre-ind
+  m_allaer_pi(:,:,id_CINO3M_phy) = nitrinscoarse_pi(:,:)/1.e9/zrho(:,:) ! CINO3M pre-ind
+  m_allaer_pi(:,:,id_AIPOMM_phy) = pomins_pi(:,:)       /1.e9/zrho(:,:) ! AIPOMM pre-ind
+  m_allaer_pi(:,:,id_STRAT_phy)  = 0.0
+
+  !
+  ! Calculate the total mass of all soluble aersosols (in unit ug /m3)
+  ! to be revisited for AR6
+  mass_solu_aero(:,:)    = sulfacc(:,:)    + bcsol(:,:)    + pomsol(:,:)    + nitracc(:,:)    + ssacu(:,:)
+  mass_solu_aero_pi(:,:) = sulfacc_pi(:,:) + bcsol_pi(:,:) + pomsol_pi(:,:) + nitracc_pi(:,:) + ssacu_pi(:,:)
+
+  !****************************************************************************************
+  ! 2) Calculate optical properties for the aerosols
+  !
+  !****************************************************************************************
+  DO k = 1, klev
+     DO i = 1, klon
+        pdel(i,k) = paprs(i,k) - paprs (i,k+1)
+     ENDDO
+  ENDDO
+
+  ! Diagnostics calculation for CMIP5 protocol unit (in unit kg/m3)
+  sconcso4(:)  =m_allaer(:,1,id_ASSO4M_phy)*1.e-9
+  sconcno3(:)  =(m_allaer(:,1,id_ASNO3M_phy)+m_allaer(:,1,id_CSNO3M_phy)+m_allaer(:,1,id_CINO3M_phy))*1.e-9
+  sconcoa(:)   =(m_allaer(:,1,id_ASPOMM_phy)+m_allaer(:,1,id_AIPOMM_phy))*1.e-9
+  sconcbc(:)   =(m_allaer(:,1,id_ASBCM_phy)+m_allaer(:,1,id_AIBCM_phy))*1.e-9
+  sconcss(:)   =(m_allaer(:,1,id_ASSSM_phy)+m_allaer(:,1,id_CSSSM_phy)+m_allaer(:,1,id_SSSSM_phy))*1.e-9
+  sconcdust(:) =m_allaer(:,1,id_CIDUSTM_phy)*1.e-9
+  concso4(:,:) =m_allaer(:,:,id_ASSO4M_phy)*1.e-9
+  concno3(:,:) =(m_allaer(:,:,id_ASNO3M_phy)+m_allaer(:,:,id_CSNO3M_phy)+m_allaer(:,:,id_CINO3M_phy))*1.e-9
+  concoa(:,:)  =(m_allaer(:,:,id_ASPOMM_phy)+m_allaer(:,:,id_AIPOMM_phy))*1.e-9
+  concbc(:,:)  =(m_allaer(:,:,id_ASBCM_phy)+m_allaer(:,:,id_AIBCM_phy))*1.e-9
+  concss(:,:)  =(m_allaer(:,:,id_ASSSM_phy)+m_allaer(:,:,id_CSSSM_phy)+m_allaer(:,:,id_SSSSM_phy))*1.e-9
+  concdust(:,:)=m_allaer(:,:,id_CIDUSTM_phy)*1.e-9
+
+END SUBROUTINE readaerosol_optic_ecrad
Index: DZ6/trunk/libf/phylmd/ecrad/lmdz/setup_aerosol_optics_lmdz_m.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/ecrad/lmdz/setup_aerosol_optics_lmdz_m.F90	(revision 5267)
+++ 	(revision )
@@ -1,124 +1,0 @@
-module setup_aerosol_optics_lmdz_m
-
-  implicit none
-
-contains
-
-  subroutine setup_aerosol_optics_lmdz(ao, file_name)
-
-    ! Read aerosol optical properties. Note differences with
-    ! "radiation_aerosol_optics_data::setup_aerosol_optics":
-
-    ! -- The input NetCDF file is not flat, it contains NetCDF groups.
-
-    ! -- We do not define ao%ssa_mono_phobic, ao%g_mono_phobic,
-    ! ao%lidar_ratio_mono_phobic, ao%ssa_mono_philic,
-    ! ao%g_mono_philic, ao%lidar_ratio_mono_philic. They are not in
-    ! the input NetCDF file and they are not used by ECRad.
-
-    ! -- We do not define ao%description_phobic_str and
-    ! ao%description_philic_str. We just leave the initialization
-    ! value, which is a blank.
-
-    ! -- We have to cshift the shortwave fields because the the
-    ! shortwave bands are in ascending order in the NetCDF file while
-    ! they are not in ECRad.
-
-    use radiation_aerosol_optics_data, only: aerosol_optics_type, &
-         IAerosolClassUndefined
-    use netcdf95, only: nf95_open, nf95_inq_grp_full_ncid, nf95_close, &
-         nf95_inq_dimid, nf95_inq_varid, nf95_inquire_dimension, &
-         nf95_get_var, nf95_gw_var, nf95_nowrite
-
-    type(aerosol_optics_type), intent(out):: ao
-
-    character(len=*), intent(in):: file_name
-    ! NetCDF file containing the aerosol optics data
-
-    ! Local:
-    integer ncid, grpid, dimid, varid
-
-    !-----------------------------------------------------------------------
-
-    ao%use_hydrophilic = .true.
-    ao%use_monochromatic = .true.
-    call nf95_open(file_name, nf95_nowrite, ncid)
-    call nf95_inq_grp_full_ncid(ncid, "Hydrophilic", grpid)
-    call nf95_inq_dimid(grpid, "hur", dimid)
-    call nf95_inquire_dimension(grpid, dimid, nclen = ao%nrh)
-    allocate(ao%rh_lower(ao%nrh))
-    call nf95_inq_varid(grpid, "hur_bounds", varid)
-    call nf95_get_var(grpid, varid, ao%rh_lower, count_nc = [1, ao%nrh])
-
-    ! Hydrophilic/LW_bands:
-    call nf95_inq_grp_full_ncid(ncid, "Hydrophilic/LW_bands", grpid)
-    call nf95_inq_varid(grpid, "asymmetry", varid)
-    call nf95_gw_var(grpid, varid, ao%g_lw_philic)
-    call nf95_inq_varid(grpid, "single_scat_alb", varid)
-    call nf95_gw_var(grpid, varid, ao%ssa_lw_philic)
-    call nf95_inq_varid(grpid, "mass_ext", varid)
-    call nf95_gw_var(grpid, varid, ao%mass_ext_lw_philic)
-
-    ! Hydrophilic/SW_bands:
-    call nf95_inq_grp_full_ncid(ncid, "Hydrophilic/SW_bands", grpid)
-    call nf95_inq_varid(grpid, "asymmetry", varid)
-    call nf95_gw_var(grpid, varid, ao%g_sw_philic)
-    ao%g_sw_philic = cshift(ao%g_sw_philic, 1)
-    call nf95_inq_varid(grpid, "single_scat_alb", varid)
-    call nf95_gw_var(grpid, varid, ao%ssa_sw_philic)
-    ao%ssa_sw_philic = cshift(ao%ssa_sw_philic, 1)
-    call nf95_inq_varid(grpid, "mass_ext", varid)
-    call nf95_gw_var(grpid, varid, ao%mass_ext_sw_philic)
-    ao%mass_ext_sw_philic = cshift(ao%mass_ext_sw_philic, 1)
-
-    ! Hydrophilic/Monochromatic:
-    call nf95_inq_grp_full_ncid(ncid, "Hydrophilic/Monochromatic", grpid)
-    call nf95_inq_varid(grpid, "mass_ext", varid)
-    call nf95_gw_var(grpid, varid, ao%mass_ext_mono_philic)
-
-    ! Hydrophobic/LW_bands:
-    call nf95_inq_grp_full_ncid(ncid, "Hydrophobic/LW_bands", grpid)
-    call nf95_inq_varid(grpid, "asymmetry", varid)
-    call nf95_gw_var(grpid, varid, ao%g_lw_phobic)
-    call nf95_inq_varid(grpid, "single_scat_alb", varid)
-    call nf95_gw_var(grpid, varid, ao%ssa_lw_phobic)
-    call nf95_inq_varid(grpid, "mass_ext", varid)
-    call nf95_gw_var(grpid, varid, ao%mass_ext_lw_phobic)
-
-    ! Hydrophobic/SW_bands:
-    call nf95_inq_grp_full_ncid(ncid, "Hydrophobic/SW_bands", grpid)
-    call nf95_inq_varid(grpid, "asymmetry", varid)
-    call nf95_gw_var(grpid, varid, ao%g_sw_phobic)
-    ao%g_sw_phobic = cshift(ao%g_sw_phobic, 1)
-    call nf95_inq_varid(grpid, "single_scat_alb", varid)
-    call nf95_gw_var(grpid, varid, ao%ssa_sw_phobic)
-    ao%ssa_sw_phobic = cshift(ao%ssa_sw_phobic, 1)
-    call nf95_inq_varid(grpid, "mass_ext", varid)
-    call nf95_gw_var(grpid, varid, ao%mass_ext_sw_phobic)
-    ao%mass_ext_sw_phobic = cshift(ao%mass_ext_sw_phobic, 1)
-
-    ! Hydrophobic/Monochromatic:
-    call nf95_inq_grp_full_ncid(ncid, "Hydrophobic/Monochromatic", grpid)
-    call nf95_inq_varid(grpid, "mass_ext", varid)
-    call nf95_gw_var(grpid, varid, ao%mass_ext_mono_phobic)
-
-    call nf95_close(ncid)
-
-    ! Get array sizes
-    ao%n_bands_lw = size(ao%mass_ext_lw_phobic, 1)
-    ao%n_bands_sw = size(ao%mass_ext_sw_phobic, 1)
-    ao%n_mono_wl = size(ao%mass_ext_mono_phobic, 1)
-    ao%n_type_phobic = size(ao%mass_ext_lw_phobic, 2)
-    ao%n_type_philic = size(ao%mass_ext_lw_philic, 3)
-
-    ! Allocate memory for mapping arrays
-    ao%ntype = ao%n_type_phobic + ao%n_type_philic
-    allocate(ao%iclass(ao%ntype))
-    allocate(ao%itype(ao%ntype))
-
-    ao%iclass = IAerosolClassUndefined
-    ao%itype  = 0
-
-  end subroutine setup_aerosol_optics_lmdz
-
-end module setup_aerosol_optics_lmdz_m
Index: /LMDZ6/trunk/libf/phylmd/ecrad/lmdz/setup_aerosol_optics_lmdz_m.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/ecrad/lmdz/setup_aerosol_optics_lmdz_m.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/ecrad/lmdz/setup_aerosol_optics_lmdz_m.f90	(revision 5268)
@@ -0,0 +1,124 @@
+module setup_aerosol_optics_lmdz_m
+
+  implicit none
+
+contains
+
+  subroutine setup_aerosol_optics_lmdz(ao, file_name)
+
+    ! Read aerosol optical properties. Note differences with
+    ! "radiation_aerosol_optics_data::setup_aerosol_optics":
+
+    ! -- The input NetCDF file is not flat, it contains NetCDF groups.
+
+    ! -- We do not define ao%ssa_mono_phobic, ao%g_mono_phobic,
+    ! ao%lidar_ratio_mono_phobic, ao%ssa_mono_philic,
+    ! ao%g_mono_philic, ao%lidar_ratio_mono_philic. They are not in
+    ! the input NetCDF file and they are not used by ECRad.
+
+    ! -- We do not define ao%description_phobic_str and
+    ! ao%description_philic_str. We just leave the initialization
+    ! value, which is a blank.
+
+    ! -- We have to cshift the shortwave fields because the the
+    ! shortwave bands are in ascending order in the NetCDF file while
+    ! they are not in ECRad.
+
+    use radiation_aerosol_optics_data, only: aerosol_optics_type, &
+         IAerosolClassUndefined
+    use netcdf95, only: nf95_open, nf95_inq_grp_full_ncid, nf95_close, &
+         nf95_inq_dimid, nf95_inq_varid, nf95_inquire_dimension, &
+         nf95_get_var, nf95_gw_var, nf95_nowrite
+
+    type(aerosol_optics_type), intent(out):: ao
+
+    character(len=*), intent(in):: file_name
+    ! NetCDF file containing the aerosol optics data
+
+    ! Local:
+    integer ncid, grpid, dimid, varid
+
+    !-----------------------------------------------------------------------
+
+    ao%use_hydrophilic = .true.
+    ao%use_monochromatic = .true.
+    call nf95_open(file_name, nf95_nowrite, ncid)
+    call nf95_inq_grp_full_ncid(ncid, "Hydrophilic", grpid)
+    call nf95_inq_dimid(grpid, "hur", dimid)
+    call nf95_inquire_dimension(grpid, dimid, nclen = ao%nrh)
+    allocate(ao%rh_lower(ao%nrh))
+    call nf95_inq_varid(grpid, "hur_bounds", varid)
+    call nf95_get_var(grpid, varid, ao%rh_lower, count_nc = [1, ao%nrh])
+
+    ! Hydrophilic/LW_bands:
+    call nf95_inq_grp_full_ncid(ncid, "Hydrophilic/LW_bands", grpid)
+    call nf95_inq_varid(grpid, "asymmetry", varid)
+    call nf95_gw_var(grpid, varid, ao%g_lw_philic)
+    call nf95_inq_varid(grpid, "single_scat_alb", varid)
+    call nf95_gw_var(grpid, varid, ao%ssa_lw_philic)
+    call nf95_inq_varid(grpid, "mass_ext", varid)
+    call nf95_gw_var(grpid, varid, ao%mass_ext_lw_philic)
+
+    ! Hydrophilic/SW_bands:
+    call nf95_inq_grp_full_ncid(ncid, "Hydrophilic/SW_bands", grpid)
+    call nf95_inq_varid(grpid, "asymmetry", varid)
+    call nf95_gw_var(grpid, varid, ao%g_sw_philic)
+    ao%g_sw_philic = cshift(ao%g_sw_philic, 1)
+    call nf95_inq_varid(grpid, "single_scat_alb", varid)
+    call nf95_gw_var(grpid, varid, ao%ssa_sw_philic)
+    ao%ssa_sw_philic = cshift(ao%ssa_sw_philic, 1)
+    call nf95_inq_varid(grpid, "mass_ext", varid)
+    call nf95_gw_var(grpid, varid, ao%mass_ext_sw_philic)
+    ao%mass_ext_sw_philic = cshift(ao%mass_ext_sw_philic, 1)
+
+    ! Hydrophilic/Monochromatic:
+    call nf95_inq_grp_full_ncid(ncid, "Hydrophilic/Monochromatic", grpid)
+    call nf95_inq_varid(grpid, "mass_ext", varid)
+    call nf95_gw_var(grpid, varid, ao%mass_ext_mono_philic)
+
+    ! Hydrophobic/LW_bands:
+    call nf95_inq_grp_full_ncid(ncid, "Hydrophobic/LW_bands", grpid)
+    call nf95_inq_varid(grpid, "asymmetry", varid)
+    call nf95_gw_var(grpid, varid, ao%g_lw_phobic)
+    call nf95_inq_varid(grpid, "single_scat_alb", varid)
+    call nf95_gw_var(grpid, varid, ao%ssa_lw_phobic)
+    call nf95_inq_varid(grpid, "mass_ext", varid)
+    call nf95_gw_var(grpid, varid, ao%mass_ext_lw_phobic)
+
+    ! Hydrophobic/SW_bands:
+    call nf95_inq_grp_full_ncid(ncid, "Hydrophobic/SW_bands", grpid)
+    call nf95_inq_varid(grpid, "asymmetry", varid)
+    call nf95_gw_var(grpid, varid, ao%g_sw_phobic)
+    ao%g_sw_phobic = cshift(ao%g_sw_phobic, 1)
+    call nf95_inq_varid(grpid, "single_scat_alb", varid)
+    call nf95_gw_var(grpid, varid, ao%ssa_sw_phobic)
+    ao%ssa_sw_phobic = cshift(ao%ssa_sw_phobic, 1)
+    call nf95_inq_varid(grpid, "mass_ext", varid)
+    call nf95_gw_var(grpid, varid, ao%mass_ext_sw_phobic)
+    ao%mass_ext_sw_phobic = cshift(ao%mass_ext_sw_phobic, 1)
+
+    ! Hydrophobic/Monochromatic:
+    call nf95_inq_grp_full_ncid(ncid, "Hydrophobic/Monochromatic", grpid)
+    call nf95_inq_varid(grpid, "mass_ext", varid)
+    call nf95_gw_var(grpid, varid, ao%mass_ext_mono_phobic)
+
+    call nf95_close(ncid)
+
+    ! Get array sizes
+    ao%n_bands_lw = size(ao%mass_ext_lw_phobic, 1)
+    ao%n_bands_sw = size(ao%mass_ext_sw_phobic, 1)
+    ao%n_mono_wl = size(ao%mass_ext_mono_phobic, 1)
+    ao%n_type_phobic = size(ao%mass_ext_lw_phobic, 2)
+    ao%n_type_philic = size(ao%mass_ext_lw_philic, 3)
+
+    ! Allocate memory for mapping arrays
+    ao%ntype = ao%n_type_phobic + ao%n_type_philic
+    allocate(ao%iclass(ao%ntype))
+    allocate(ao%itype(ao%ntype))
+
+    ao%iclass = IAerosolClassUndefined
+    ao%itype  = 0
+
+  end subroutine setup_aerosol_optics_lmdz
+
+end module setup_aerosol_optics_lmdz_m
Index: DZ6/trunk/libf/phylmd/ecrad/lmdz/setup_config_from_lmdz.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/ecrad/lmdz/setup_config_from_lmdz.F90	(revision 5267)
+++ 	(revision )
@@ -1,123 +1,0 @@
-module setup_config_from_lmdz
-
-  use parkind1, only : jprb
-
-  implicit none
-
-  public
-
-  type driver_config_type
-     logical    :: ok_effective_size  = .true.
-     logical    :: ok_separation = .false.   
-     real(jprb) :: high_inv_effective_size   = -1.0_jprb ! m-1
-     real(jprb) :: middle_inv_effective_size = -1.0_jprb ! m-1
-     real(jprb) :: low_inv_effective_size    = -1.0_jprb ! m-1
-     real(jprb) :: cloud_inhom_separation_factor  = -1.0_jprb
-     real(jprb) :: cloud_separation_scale_surface = -1.0_jprb
-     real(jprb) :: cloud_separation_scale_toa     = -1.0_jprb
-     real(jprb) :: cloud_separation_scale_power   = -1.0_jprb
-     real(jprb) :: frac_std = 0.75_jprb
-     real(jprb) :: overlap_decorr_length = 2000.0_jprb
-     ! KDECOLAT : 0 > cste, 1 > Shonk et al. (2010) 2 > 1 lisse a l'equateur
-     !            3 : 1+variation sur la verticale
-     !            4 : 2+variation sur la verticale
-     integer    :: kdecolat = 0
-     real(jprb) :: low_decorrelation_length = 2000.0_jprb 
-     real(jprb) :: mid_decorrelation_length = 2000.0_jprb
-     real(jprb) :: high_decorrelation_length = 2000.0_jprb
-
- contains
- procedure :: read => read_config_from_namelist
-
-  end type driver_config_type
-
-contains
-
-  !---------------------------------------------------------------------
-  subroutine read_config_from_namelist(this, file_name, is_success)
-
-    use radiation_io, only : nulerr, radiation_abort       
-
-    class(driver_config_type), intent(inout) :: this
-    character(*), intent(in)          :: file_name
-    logical, intent(out), optional    :: is_success
-    logical    :: ok_effective_size, ok_separation
-    integer    :: iosopen ! Status after calling open
-    real(jprb) :: high_inv_effective_size 
-    real(jprb) :: middle_inv_effective_size
-    real(jprb) :: low_inv_effective_size
-    real(jprb) :: cloud_inhom_separation_factor 
-    real(jprb) :: cloud_separation_scale_surface
-    real(jprb) :: cloud_separation_scale_toa
-    real(jprb) :: cloud_separation_scale_power
-    real(jprb) :: frac_std
-    real(jprb) :: overlap_decorr_length
-    integer    :: kdecolat 
-    real(jprb) :: low_decorrelation_length
-    real(jprb) :: mid_decorrelation_length 
-    real(jprb) :: high_decorrelation_length 
-
-    namelist /radiation_driver/ ok_effective_size, ok_separation, &
-         &  frac_std, overlap_decorr_length, kdecolat, &
-         &  low_decorrelation_length, mid_decorrelation_length, high_decorrelation_length, &
-         &  high_inv_effective_size, middle_inv_effective_size, low_inv_effective_size, &
-         &  cloud_inhom_separation_factor, cloud_separation_scale_surface, &
-         &  cloud_separation_scale_toa, cloud_separation_scale_power 
-
-    ok_effective_size = .false.
-    ok_separation = .false.
-    high_inv_effective_size   = -1.0_jprb 
-    middle_inv_effective_size = -1.0_jprb 
-    low_inv_effective_size    = -1.0_jprb 
-    cloud_inhom_separation_factor  = -1.0_jprb
-    cloud_separation_scale_surface = -1.0_jprb
-    cloud_separation_scale_toa     = -1.0_jprb
-    cloud_separation_scale_power   = -1.0_jprb
-    frac_std = 0.75_jprb
-    overlap_decorr_length = 2000.0_jprb
-    kdecolat = 0
-    low_decorrelation_length = 2000.0_jprb
-    mid_decorrelation_length = 2000.0_jprb
-    high_decorrelation_length = 2000.0_jprb
-
-    ! Open the namelist file and read the radiation_driver namelist
-    open(unit=10, iostat=iosopen, file=trim(file_name))
-    if (iosopen /= 0) then
-      ! An error occurred
-      if (present(is_success)) then
-        is_success = .false.
-        ! We now continue the subroutine so that the default values
-        ! are placed in the config structure
-      else
-        write(nulerr,'(a,a,a)') '*** Error: namelist file "', &
-             &                trim(file_name), '" not found'
-        call radiation_abort('Driver configuration error')
-      end if
-    else
-      ! Read the radiation_driver namelist, noting that it is not an
-      ! error if this namelist is not present, provided all the required
-      ! variables are present in the NetCDF data file instead
-      read(unit=10, nml=radiation_driver)
-      close(unit=10)
-    end if
-
-    ! Copy namelist data into configuration object
-    this%ok_effective_size = ok_effective_size 
-    this%ok_separation = ok_separation
-    this%frac_std = frac_std
-    this%overlap_decorr_length = overlap_decorr_length
-    this%kdecolat = kdecolat
-    this%low_decorrelation_length = low_decorrelation_length
-    this%mid_decorrelation_length = mid_decorrelation_length
-    this%high_decorrelation_length = high_decorrelation_length
-    this%cloud_inhom_separation_factor = cloud_inhom_separation_factor
-    this%cloud_separation_scale_surface = cloud_separation_scale_surface
-    this%cloud_separation_scale_toa = cloud_separation_scale_toa
-    this%cloud_separation_scale_power = cloud_separation_scale_power
-    this%high_inv_effective_size = high_inv_effective_size
-    this%middle_inv_effective_size = middle_inv_effective_size
-    this%low_inv_effective_size = low_inv_effective_size
-
-  end subroutine read_config_from_namelist          
-
-end module setup_config_from_lmdz
Index: /LMDZ6/trunk/libf/phylmd/ecrad/lmdz/setup_config_from_lmdz.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/ecrad/lmdz/setup_config_from_lmdz.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/ecrad/lmdz/setup_config_from_lmdz.f90	(revision 5268)
@@ -0,0 +1,123 @@
+module setup_config_from_lmdz
+
+  use parkind1, only : jprb
+
+  implicit none
+
+  public
+
+  type driver_config_type
+     logical    :: ok_effective_size  = .true.
+     logical    :: ok_separation = .false.   
+     real(jprb) :: high_inv_effective_size   = -1.0_jprb ! m-1
+     real(jprb) :: middle_inv_effective_size = -1.0_jprb ! m-1
+     real(jprb) :: low_inv_effective_size    = -1.0_jprb ! m-1
+     real(jprb) :: cloud_inhom_separation_factor  = -1.0_jprb
+     real(jprb) :: cloud_separation_scale_surface = -1.0_jprb
+     real(jprb) :: cloud_separation_scale_toa     = -1.0_jprb
+     real(jprb) :: cloud_separation_scale_power   = -1.0_jprb
+     real(jprb) :: frac_std = 0.75_jprb
+     real(jprb) :: overlap_decorr_length = 2000.0_jprb
+     ! KDECOLAT : 0 > cste, 1 > Shonk et al. (2010) 2 > 1 lisse a l'equateur
+     !            3 : 1+variation sur la verticale
+     !            4 : 2+variation sur la verticale
+     integer    :: kdecolat = 0
+     real(jprb) :: low_decorrelation_length = 2000.0_jprb 
+     real(jprb) :: mid_decorrelation_length = 2000.0_jprb
+     real(jprb) :: high_decorrelation_length = 2000.0_jprb
+
+ contains
+ procedure :: read => read_config_from_namelist
+
+  end type driver_config_type
+
+contains
+
+  !---------------------------------------------------------------------
+  subroutine read_config_from_namelist(this, file_name, is_success)
+
+    use radiation_io, only : nulerr, radiation_abort       
+
+    class(driver_config_type), intent(inout) :: this
+    character(*), intent(in)          :: file_name
+    logical, intent(out), optional    :: is_success
+    logical    :: ok_effective_size, ok_separation
+    integer    :: iosopen ! Status after calling open
+    real(jprb) :: high_inv_effective_size 
+    real(jprb) :: middle_inv_effective_size
+    real(jprb) :: low_inv_effective_size
+    real(jprb) :: cloud_inhom_separation_factor 
+    real(jprb) :: cloud_separation_scale_surface
+    real(jprb) :: cloud_separation_scale_toa
+    real(jprb) :: cloud_separation_scale_power
+    real(jprb) :: frac_std
+    real(jprb) :: overlap_decorr_length
+    integer    :: kdecolat 
+    real(jprb) :: low_decorrelation_length
+    real(jprb) :: mid_decorrelation_length 
+    real(jprb) :: high_decorrelation_length 
+
+    namelist /radiation_driver/ ok_effective_size, ok_separation, &
+         &  frac_std, overlap_decorr_length, kdecolat, &
+         &  low_decorrelation_length, mid_decorrelation_length, high_decorrelation_length, &
+         &  high_inv_effective_size, middle_inv_effective_size, low_inv_effective_size, &
+         &  cloud_inhom_separation_factor, cloud_separation_scale_surface, &
+         &  cloud_separation_scale_toa, cloud_separation_scale_power 
+
+    ok_effective_size = .false.
+    ok_separation = .false.
+    high_inv_effective_size   = -1.0_jprb 
+    middle_inv_effective_size = -1.0_jprb 
+    low_inv_effective_size    = -1.0_jprb 
+    cloud_inhom_separation_factor  = -1.0_jprb
+    cloud_separation_scale_surface = -1.0_jprb
+    cloud_separation_scale_toa     = -1.0_jprb
+    cloud_separation_scale_power   = -1.0_jprb
+    frac_std = 0.75_jprb
+    overlap_decorr_length = 2000.0_jprb
+    kdecolat = 0
+    low_decorrelation_length = 2000.0_jprb
+    mid_decorrelation_length = 2000.0_jprb
+    high_decorrelation_length = 2000.0_jprb
+
+    ! Open the namelist file and read the radiation_driver namelist
+    open(unit=10, iostat=iosopen, file=trim(file_name))
+    if (iosopen /= 0) then
+      ! An error occurred
+      if (present(is_success)) then
+        is_success = .false.
+        ! We now continue the subroutine so that the default values
+        ! are placed in the config structure
+      else
+        write(nulerr,'(a,a,a)') '*** Error: namelist file "', &
+             &                trim(file_name), '" not found'
+        call radiation_abort('Driver configuration error')
+      end if
+    else
+      ! Read the radiation_driver namelist, noting that it is not an
+      ! error if this namelist is not present, provided all the required
+      ! variables are present in the NetCDF data file instead
+      read(unit=10, nml=radiation_driver)
+      close(unit=10)
+    end if
+
+    ! Copy namelist data into configuration object
+    this%ok_effective_size = ok_effective_size 
+    this%ok_separation = ok_separation
+    this%frac_std = frac_std
+    this%overlap_decorr_length = overlap_decorr_length
+    this%kdecolat = kdecolat
+    this%low_decorrelation_length = low_decorrelation_length
+    this%mid_decorrelation_length = mid_decorrelation_length
+    this%high_decorrelation_length = high_decorrelation_length
+    this%cloud_inhom_separation_factor = cloud_inhom_separation_factor
+    this%cloud_separation_scale_surface = cloud_separation_scale_surface
+    this%cloud_separation_scale_toa = cloud_separation_scale_toa
+    this%cloud_separation_scale_power = cloud_separation_scale_power
+    this%high_inv_effective_size = high_inv_effective_size
+    this%middle_inv_effective_size = middle_inv_effective_size
+    this%low_inv_effective_size = low_inv_effective_size
+
+  end subroutine read_config_from_namelist          
+
+end module setup_config_from_lmdz
Index: DZ6/trunk/libf/phylmd/ecumev6_flux.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/ecumev6_flux.F90	(revision 5267)
+++ 	(revision )
@@ -1,777 +1,0 @@
-!SFX_LIC Copyright 1994-2014 CNRS, Meteo-France and Universite Paul Sabatier
-!SFX_LIC This is part of the SURFEX software governed by the CeCILL-C licence
-!SFX_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt  
-!SFX_LIC for details. version 1.
-!     #########
-    SUBROUTINE ECUMEV6_FLUX(PZ0SEA,PTA,PSST,PQA,PQSAT,PVMOD, &
-                            PZREF,PSSS,PUREF,PPS,PPA,OPRECIP,OPWEBB,        &
-                            PSFTH,PSFTQ,PUSTAR,PCD,PCDN,PCH,PCE,        &
-                            PRI,PRESA,PRAIN,PZ0HSEA,OPERTFLUX,coeffs   )
-!###############################################################################
-!!
-!!****  *ECUMEV6_FLUX*
-!!
-!!    PURPOSE
-!!    -------
-!       Calculate the surface turbulent fluxes of heat, moisture, and momentum 
-!       over sea surface + corrections due to rainfall & Webb effect.
-!!
-!!**  METHOD
-!!    ------
-!       The estimation of the transfer coefficients relies on the iterative 
-!       computation of the scaling parameters U*/Teta*/q*. The convergence is
-!       supposed to be reached in NITERFL iterations maximum.
-!       Neutral transfer coefficients for momentum/temperature/humidity
-!       are computed as a function of the 10m-height neutral wind speed using
-!       the ECUME_V6 formulation based on the multi-campaign (POMME,FETCH,CATCH,
-!       SEMAPHORE,EQUALANT) ALBATROS dataset.
-!!
-!!    EXTERNAL
-!!    --------
-!!
-!!    IMPLICIT ARGUMENTS
-!!    ------------------
-!!
-!!    REFERENCE
-!!    ---------
-!!      Fairall et al (1996), JGR, 3747-3764
-!!      Gosnell et al (1995), JGR, 437-442
-!!      Fairall et al (1996), JGR, 1295-1308
-!!
-!!    AUTHOR
-!!    ------
-!!      C. Lebeaupin  *Météo-France* (adapted from S. Belamari's code)
-!!
-!!    MODIFICATIONS
-!!    -------------
-!!      Original     15/03/2005
-!!      Modified        01/2006  C. Lebeaupin (adapted from  A. Pirani's code)
-!!      Modified        08/2009  B. Decharme: limitation of Ri
-!!      Modified        09/2012  B. Decharme: CD correction
-!!      Modified        09/2012  B. Decharme: limitation of Ri in surface_ri.F90
-!!      Modified        10/2012  P. Le Moigne: extra inputs for FLake use
-!!      Modified        06/2013  B. Decharme: bug in z0 (output) computation 
-!!      Modified        12/2013  S. Belamari: ZRF computation updated:
-!!                                1. ZP00/PPA in ZDWAT, ZLVA in ZDQSDT/ZBULB/ZRF
-!!                                2. ZDWAT/ZDTMP in ZBULB/ZRF (Gosnell et al 95)
-!!                                3. cool skin correction included
-!!      Modified        01/2014  S. Belamari: salinity impact on latent heat of
-!!                                vaporization of seawater included
-!!      Modified        01/2014  S. Belamari: new formulation for pure water
-!!                                specific heat (ZCPWA)
-!!      Modified        01/2014  S. Belamari: 4 choices for PZ0SEA computation
-!!      Modified        12/2015  S. Belamari: ECUME now provides parameterisations
-!!                                for:  U10n*sqrt(CDN)          instead of CDN
-!!                                      U10n*CHN/sqrt(CDN)         "       CHN
-!!                                      U10n*CEN/sqrt(CDN)         "       CEN
-!!      Modified        01/2016  S. Belamari: New ECUME formulation
-!!
-!!      To be done:
-!!      include gustiness computation following Mondon & Redelsperger (1998)
-!!!
-!-------------------------------------------------------------------------------
-!!
-!!    MODIFICATIONS RELATED TO SST CORRECTION COMPUTATION
-!!    ---------------------------------------------------
-!!      Modified        09/2013  S. Belamari: use 0.98 for the ocean emissivity
-!!                                following up to date satellite measurements in
-!!                                the 8-14 μm range (obtained values range from
-!!                                0.98 to 0.99).
-!!!
-!-------------------------------------------------------------------------------
-!
-!       0.   DECLARATIONS
-!            ------------
-!
-USE dimphy
-USE indice_sol_mod
-USE MODD_CSTS,             ONLY : XPI, XDAY, XKARMAN, XG, XP00, XSTEFAN, XRD, XRV,   &
-                                  XCPD, XCPV, XCL, XTT, XLVTT
-
-
-!USE MODD_SURF_PAR,         ONLY : XUNDEF
-!USE MODD_SURF_ATM,         ONLY : XVCHRNK, XVZ0CM
-!USE MODD_REPROD_OPER,      ONLY : CCHARNOCK
-!
-!USE MODE_THERMOS
-!USE MODI_WIND_THRESHOLD
-!USE MODI_SURFACE_RI
-!
-!USE YOMHOOK,   ONLY : LHOOK,   DR_HOOK
-!USE PARKIND1,  ONLY : JPRB
-!
-!USE MODI_ABOR1_SFX
-!
-IMPLICIT NONE
-!
-!       0.1. Declarations of arguments
-!
-REAL, DIMENSION(klon), INTENT(IN)    :: PVMOD      ! module of wind at atm level (m/s)
-REAL, DIMENSION(klon), INTENT(IN)    :: PTA        ! air temperature at atm level (K)
-REAL, DIMENSION(klon), INTENT(IN)    :: PQA        ! air spec. hum. at atm level (kg/kg)
-REAL, DIMENSION(klon), INTENT(IN)    :: PQSAT      ! sea surface spec. hum. (kg/kg)
-REAL, DIMENSION(klon), INTENT(IN)    :: PPA        ! air pressure at atm level (Pa)
-!REAL, DIMENSION(:), INTENT(IN)    :: PRHOA      ! air density at atm level (kg/m3)
-!REAL, DIMENSION(:), INTENT(IN)    :: PEXNA      ! Exner function at atm level
-REAL, DIMENSION(klon), INTENT(IN)    :: PUREF      ! atm level for wind (m)
-REAL, DIMENSION(klon), INTENT(IN)    :: PZREF      ! atm level for temp./hum. (m)
-REAL, DIMENSION(klon), INTENT(IN)    :: PSSS       ! Sea Surface Salinity (g/kg)
-REAL, DIMENSION(klon), INTENT(IN)    :: PPS        ! air pressure at sea surface (Pa)
-!REAL, DIMENSION(:), INTENT(IN)    :: PEXNS      ! Exner function at sea surface
-!REAL, DIMENSION(:), INTENT(IN)    :: PPERTFLUX  ! stochastic flux perturbation pattern
-! for correction
-!REAL,               INTENT(IN)    :: PICHCE    !
-LOGICAL,            INTENT(IN)    :: OPRECIP   !
-LOGICAL,            INTENT(IN)    :: OPWEBB    !
-LOGICAL,            INTENT(IN)    :: OPERTFLUX
-REAL, DIMENSION(klon), INTENT(IN)    :: PRAIN     ! precipitation rate (kg/s/m2)
-!
-!INTEGER,            INTENT(IN)    :: KZ0
-!
-REAL, DIMENSION(klon), INTENT(INOUT) :: PSST       ! Sea Surface Temperature (K)
-REAL, DIMENSION(klon), INTENT(INOUT) :: PZ0SEA     ! roughness length over sea
-REAL, DIMENSION(klon), INTENT(OUT)   :: PZ0HSEA    ! heat roughness length over sea
-
-! surface fluxes : latent heat, sensible heat, friction fluxes
-REAL, DIMENSION(klon), INTENT(OUT)   :: PUSTAR     ! friction velocity (m/s)
-REAL, DIMENSION(klon), INTENT(OUT)   :: PSFTH      ! heat flux (W/m2)
-REAL, DIMENSION(klon), INTENT(OUT)   :: PSFTQ      ! water flux (kg/m2/s)
-
-! diagnostics
-REAL, DIMENSION(klon), INTENT(OUT)   :: PCD        ! transfer coef. for momentum
-REAL, DIMENSION(klon), INTENT(OUT)   :: PCH        ! transfer coef. for temperature
-REAL, DIMENSION(klon), INTENT(OUT)   :: PCE        ! transfer coef. for humidity
-REAL, DIMENSION(klon), INTENT(OUT)   :: PCDN       ! neutral coef. for momentum
-REAL, DIMENSION(klon), INTENT(OUT)   :: PRI        ! Richardson number
-REAL, DIMENSION(klon), INTENT(OUT)   :: PRESA      ! aerodynamical resistance
-real, dimension(3), intent(out)   :: coeffs
-
-!       0.2. Declarations of local variables
-!
-! specif SB
-INTEGER, DIMENSION(SIZE(PTA))     :: JCV        ! convergence index
-INTEGER, DIMENSION(SIZE(PTA))     :: JITER      ! nb of iterations to converge
-!rajout
-REAL, DIMENSION(SIZE(PTA))        :: PEXNA      ! Exner function at atm level
-REAL, DIMENSION(SIZE(PTA))       :: PEXNS      ! Exner function at atm level
-!
-REAL, DIMENSION(SIZE(PTA))        :: ZTAU       ! momentum flux (N/m2)
-REAL, DIMENSION(SIZE(PTA))        :: ZHF        ! sensible heat flux (W/m2)
-REAL, DIMENSION(SIZE(PTA))        :: ZEF        ! latent heat flux (W/m2)
-REAL, DIMENSION(SIZE(PTA))        :: ZTAUR      ! momentum flx due to rain (N/m2)
-REAL, DIMENSION(SIZE(PTA))        :: ZRF        ! sensible flx due to rain (W/m2)
-REAL, DIMENSION(SIZE(PTA))        :: ZEFWEBB    ! Webb corr. on latent flx (W/m2)
-
-REAL, DIMENSION(SIZE(PTA))        :: ZVMOD      ! wind intensity at atm level (m/s)
-REAL, DIMENSION(SIZE(PTA))        :: ZQSATA     ! sat.spec.hum. at atm level (kg/kg)
-REAL, DIMENSION(SIZE(PTA))        :: ZLVA       ! vap.heat of pure water at atm level (J/kg)
-REAL, DIMENSION(SIZE(PTA))        :: ZLVS       ! vap.heat of seawater at sea surface (J/kg)
-REAL, DIMENSION(SIZE(PTA))        :: ZCPA       ! specif.heat moist air (J/kg/K)
-REAL, DIMENSION(SIZE(PTA))        :: ZVISA      ! kinemat.visc. of dry air (m2/s)
-REAL, DIMENSION(SIZE(PTA))        :: ZDU        ! U   vert.grad. (real atm)
-REAL, DIMENSION(SIZE(PTA))        :: ZDT,ZDQ    ! T,Q vert.grad. (real atm)
-REAL, DIMENSION(SIZE(PTA))        :: ZDDU       ! U   vert.grad. (real atm + gust)
-REAL, DIMENSION(SIZE(PTA))        :: ZDDT,ZDDQ  ! T,Q vert.grad. (real atm + WL/CS)
-REAL, DIMENSION(SIZE(PTA))        :: ZUSR       ! velocity scaling param. (m/s)
-                                                ! =friction velocity
-REAL, DIMENSION(SIZE(PTA))        :: ZTSR       ! temperature scaling param. (K)
-REAL, DIMENSION(SIZE(PTA))        :: ZQSR       ! humidity scaling param. (kg/kg)
-REAL, DIMENSION(SIZE(PTA))        :: ZDELTAU10N,ZDELTAT10N,ZDELTAQ10N
-                                                ! U,T,Q vert.grad. (10m, neutral atm)
-REAL, DIMENSION(SIZE(PTA))        :: ZUSR0,ZTSR0,ZQSR0    ! ITERATIVE PROCESS
-REAL, DIMENSION(SIZE(PTA))        :: ZDUSTO,ZDTSTO,ZDQSTO ! ITERATIVE PROCESS
-REAL, DIMENSION(SIZE(PTA))        :: ZPSIU,ZPSIT! PSI funct for U, T/Q (Z0 comp)
-REAL, DIMENSION(SIZE(PTA))        :: ZCHARN     ! Charnock parameter   (Z0 comp)
-
-REAL, DIMENSION(SIZE(PTA))        :: ZUSTAR2    ! square of friction velocity
-REAL, DIMENSION(SIZE(PTA))        :: ZAC        ! aerodynamical conductance
-REAL, DIMENSION(SIZE(PTA))        :: ZDIRCOSZW  ! orography slope cosine
-                                                ! (=1 on water!)
-REAL, DIMENSION(SIZE(PTA))        :: ZPARUN,ZPARTN,ZPARQN ! neutral parameter for U,T,Q
-
-!-- rajout pour la pression saturante
-REAL, DIMENSION(SIZE(PPA))        :: ZFOES                                 ! [OPWEBB]
-REAL, DIMENSION(SIZE(PPA))        :: ZWORK1
-REAL, DIMENSION(SIZE(PPA))        :: ZWORK2  
-REAL, DIMENSION(SIZE(PPS))        :: ZWORK1A
-REAL, DIMENSION(SIZE(PPS))        :: ZWORK2A
-!#####################
-
-REAL, DIMENSION(0:5)              :: ZCOEFU,ZCOEFT,ZCOEFQ
-
-!--------- Modif Olive -----------------
-REAL, DIMENSION(SIZE(PTA))        :: PRHOA
-REAL, PARAMETER                   :: XUNDEF = 1.E+20
-
-
-REAL       :: XVCHRNK = 0.021
-REAL       :: XVZ0CM = 1.0E-5 
-!REAL       :: XRIMAX
-
-CHARACTER  :: CCHARNOCK = 'NEW'
-
-
-!--------------------------------------
-
-
-! local constants
-LOGICAL :: OPCVFLX              ! to force convergence
-INTEGER :: NITERMAX             ! nb of iterations to get free convergence
-INTEGER :: NITERSUP             ! nb of additional iterations if OPCVFLX=.TRUE.
-INTEGER :: NITERFL              ! maximum number of iterations
-REAL    :: ZETV,ZRDSRV          ! thermodynamic constants
-REAL    :: ZSQR3
-REAL    :: ZLMOMIN,ZLMOMAX      ! min/max value of Obukhovs stability param. z/l
-REAL    :: ZBTA,ZGMA            ! parameters of the stability functions
-REAL    :: ZDUSR0,ZDTSR0,ZDQSR0 ! maximum gap for USR/TSR/QSR between 2 steps
-REAL    :: ZP00                 ! [OPRECIP] - water vap. diffusiv.ref.press.(Pa)
-REAL    :: ZUTU,ZUTT,ZUTQ       ! U10n threshold in ECUME parameterisation
-REAL    :: ZCDIRU,ZCDIRT,ZCDIRQ ! coef directeur pour fonction affine U,T,Q
-REAL    :: ZORDOU,ZORDOT,ZORDOQ ! ordonnee a l'origine pour fonction affine U,T,Q
-
-INTEGER :: JJ                                   ! for ITERATIVE PROCESS
-INTEGER :: JLON,JK
-REAL    :: ZLMOU,ZLMOT                          ! Obukhovs param. z/l for U, T/Q
-REAL    :: ZPSI_U,ZPSI_T                        ! PSI funct. for U, T/Q
-REAL    :: Z0TSEA,Z0QSEA                        ! roughness length for T, Q
-REAL    :: ZCHIC,ZCHIK,ZPSIC,ZPSIK,ZLOGUS10,ZLOGTS10
-REAL    :: ZTAC,ZCPWA,ZDQSDT,ZDWAT,ZDTMP,ZBULB  ! [OPRECIP]
-REAL    :: ZWW                                  ! [OPWEBB]
-
-
-INTEGER :: PREF             ! reference pressure for exner function
-REAL, DIMENSION(klon)    :: PQSATA      ! sea surface spec. hum. (kg/kg)
-
-REAL    :: qsat_seawater2,qsat_seawater
-
-INCLUDE "YOMCST.h"
-INCLUDE "clesphys.h"
-
-!REAL(KIND=JPRB) :: ZHOOK_HANDLE
-!
-!-------------------------------------------------------------------------------
-!----------------------- Modif Olive calcul de PRHOA ---------------------------
-
-!write(*,*) "PZ0SEA ",PZ0SEA
-!write(*,*) "PTA ",PTA
-!write(*,*) "PSST ",PSST
-!write(*,*) "PQA ",PQA
-!write(*,*) "PVMOD ",PVMOD
-!write(*,*) "PZREF ",PZREF
-!write(*,*) "PUREF ",PUREF
-!write(*,*) "PPS ",PPS
-!write(*,*) "PPA ",PPA
-!write(*,*) "OPRECIP ",OPRECIP
-!write(*,*) "PZ0HSEA ",PZ0HSEA
-!write(*,*) "PRAIN ",PRAIN
-
-
-PRHOA(:) = PPS(:) / (287.1 * PTA(:) * (1.+.61*PQA(:)))
-!write(*,*) "klon klon ",klon,PTA
-!write(*,*) "PRHOA ",SIZE(PRHOA),PRHOA
-
-PREF = 100900.                    ! = 1000 hPa
-
-!PEXNA = (PPA/PPS)**RKAPPA
-!PEXNS = (PPS/PPS)**RKAPPA
-
-PEXNA = (PPA/PREF)**(RD/RCPD)
-PEXNS = (PPS/PREF)**(RD/RCPD)
-
-!IF (LHOOK) CALL DR_HOOK('ECUMEV6_FLUX',0,ZHOOK_HANDLE)
-!
-ZDUSR0   = 1.E-06
-ZDTSR0   = 1.E-06
-ZDQSR0   = 1.E-09
-!
-NITERMAX = 5
-NITERSUP = 5
-OPCVFLX  = .TRUE.
-!
-NITERFL = NITERMAX
-IF (OPCVFLX) NITERFL = NITERMAX+NITERSUP
-!
-ZCOEFU = (/ 1.00E-03, 3.66E-02, -1.92E-03, 2.32E-04, -7.02E-06,  6.40E-08 /)
-ZCOEFT = (/ 5.36E-03, 2.90E-02, -1.24E-03, 4.50E-04, -2.06E-05,       0.0 /)
-ZCOEFQ = (/ 1.00E-03, 3.59E-02, -2.87E-04,      0.0,       0.0,       0.0 /)
-!
-ZUTU = 40.0
-ZUTT = 14.4
-ZUTQ = 10.0
-!
-ZCDIRU = ZCOEFU(1) + 2.0*ZCOEFU(2)*ZUTU + 3.0*ZCOEFU(3)*ZUTU**2   &
-                   + 4.0*ZCOEFU(4)*ZUTU**3 + 5.0*ZCOEFU(5)*ZUTU**4
-ZCDIRT = ZCOEFT(1) + 2.0*ZCOEFT(2)*ZUTT + 3.0*ZCOEFT(3)*ZUTT**2   &
-                   + 4.0*ZCOEFT(4)*ZUTT**3
-ZCDIRQ = ZCOEFQ(1) + 2.0*ZCOEFQ(2)*ZUTQ
-!
-ZORDOU = ZCOEFU(0) + ZCOEFU(1)*ZUTU + ZCOEFU(2)*ZUTU**2 + ZCOEFU(3)*ZUTU**3   &
-                   + ZCOEFU(4)*ZUTU**4 + ZCOEFU(5)*ZUTU**5
-ZORDOT = ZCOEFT(0) + ZCOEFT(1)*ZUTT + ZCOEFT(2)*ZUTT**2 + ZCOEFT(3)*ZUTT**3   &
-                   + ZCOEFT(4)*ZUTT**4
-ZORDOQ = ZCOEFQ(0) + ZCOEFQ(1)*ZUTQ + ZCOEFQ(2)*ZUTQ**2
-!
-!-------------------------------------------------------------------------------
-!
-!       1.   AUXILIARY CONSTANTS & ARRAY INITIALISATION BY UNDEFINED VALUES.
-!       --------------------------------------------------------------------
-!
-ZDIRCOSZW(:) = 1.0
-!
-ZETV    = XRV/XRD-1.0   !~0.61 (cf Liu et al. 1979)
-ZRDSRV  = XRD/XRV       !~0.622
-ZSQR3   = SQRT(3.0)
-ZLMOMIN = -200.0
-ZLMOMAX = 0.25
-ZBTA    = 16.0
-ZGMA    = 7.0           !initially =4.7, modified to 7.0 following G. Caniaux
-!
-ZP00    = 1013.25E+02
-!
-PCD  = XUNDEF
-PCH  = XUNDEF
-PCE  = XUNDEF
-PCDN = XUNDEF
-ZUSR = XUNDEF
-ZTSR = XUNDEF
-ZQSR = XUNDEF
-ZTAU = XUNDEF
-ZHF  = XUNDEF
-ZEF  = XUNDEF
-!
-PSFTH  = XUNDEF
-PSFTQ  = XUNDEF
-PUSTAR = XUNDEF
-PRESA  = XUNDEF
-PRI    = XUNDEF
-!
-ZTAUR   = 0.0
-ZRF     = 0.0
-ZEFWEBB = 0.0
-!
-!-------------------------------------------------------------------------------
-!
-!       2.   INITIALISATIONS BEFORE ITERATIVE LOOP.
-!       -------------------------------------------
-!
-!ZVMOD(:) = WIND_THRESHOLD(PVMOD(:),PUREF(:))    !set a minimum value to wind
-ZVMOD = MAX(PVMOD , 0.1 * MIN(10.,PUREF) )    !set a minimum value to wind
-
-write(*,*) "ZVMOD ",SIZE(ZVMOD)
-
-!
-!       2.0. Radiative fluxes - For warm layer & cool skin
-!
-!       2.0b. Warm Layer correction
-!
-!       2.1. Specific humidity at saturation
-!
-WHERE(PSSS(:)>0.0.AND.PSSS(:)/=XUNDEF)
-  PQSATA = QSAT_SEAWATER2 (PSST(:),PPS(:),PSSS(:))    !at sea surface
-ELSEWHERE
-  PQSATA (:) = QSAT_SEAWATER (PSST(:),PPS(:))            !at sea surface
-ENDWHERE
-
-!ZQSATA(:) = QSAT(PTA(:),PPA(:))                         !at atm level
-
-!### OLIVIER POUR PRESSION SATURANTE #####
-!-------------------------------------------------------------------------------
-!
-ZFOES  = 1 !PSAT(PT(:))
-ZFOES  = 0.98*ZFOES
-!
-ZWORK1    = ZFOES/PPS
-ZWORK2    = XRD/XRV
-
-ZWORK1A    = ZFOES/PPA
-ZWORK2A    = XRD/XRV
-
-!write(*,*) "ZFOES ",ZFOES
-!write(*,*) "PPS ",PPS
-!write(*,*) "ZWORK1 ",ZWORK1
-!write(*,*) "XRD ",XRD
-!write(*,*) "XRV ",XRV
-!write(*,*) "PPA ",PPA
-!write(*,*) "ZWORK1A ",ZWORK1A
-
-write(*,*) "PQSAT : ",PQSAT
-write(*,*) "PQSATA : ",PQSATA
-
-
-!
-!*       2.    COMPUTE SATURATION HUMIDITY
-!              ---------------------------
-!
-!PQSAT  = ZWORK2*ZWORK1 / (1.+(ZWORK2-1.)*ZWORK1)
-!ZQSATA = ZWORK2A*ZWORK1A / (1.+(ZWORK2A-1.)*ZWORK1A)
-ZQSATA = QSAT_SEAWATER (PTA(:),PPA(:))            !at sea surface
-
-
-!
-!       2.2. Gradients at the air-sea interface
-!
-ZDU(:) = ZVMOD(:)               !one assumes u is measured / sea surface current
-ZDT(:) = PTA(:)/PEXNA(:)-PSST(:)/PEXNS(:)
-ZDQ(:) = PQA(:)-PQSATA(:)
-
-write(*,*) "PQA ",PQA(:)
-write(*,*) "PQSAT",PQSAT(:)
-write(*,*) "ZDQ",ZDQ(:)
-!
-!       2.3. Latent heat of vaporisation
-!
-ZLVA(:) = XLVTT+(XCPV-XCL)*(PTA (:)-XTT)                !of pure water at atm level
-ZLVS(:) = XLVTT+(XCPV-XCL)*(PSST(:)-XTT)                !of pure water at sea surface
-
-
-
-write(*,*) "ZLVA ",ZLVA
-write(*,*) "ZLVS ",ZLVS
-
-
-WHERE(PSSS(:)>0.0.AND.PSSS(:)/=XUNDEF)
-  ZLVS(:) = ZLVS(:)*(1.0-1.00472E-3*PSSS(:))            !of seawater at sea surface
-ENDWHERE
-!
-!       2.4. Specific heat of moist air (Businger 1982)
-!
-!ZCPA(:) = XCPD*(1.0+(XCPV/XCPD-1.0)*PQA(:))
-ZCPA(:) = XCPD
-!
-!       2.4b Kinematic viscosity of dry air (Andreas 1989, CRREL Rep. 89-11)
-!
-ZVISA(:) = 1.326E-05*(1.0+6.542E-03*(PTA(:)-XTT)+8.301E-06*(PTA(:)-XTT)**2   &
-           -4.84E-09*(PTA(:)-XTT)**3)
-!
-!       2.4c Coefficients for warm layer and/or cool skin correction
-!
-!       2.5. Initial guess
-!
-ZDDU(:) = ZDU(:)
-ZDDT(:) = ZDT(:)
-ZDDQ(:) = ZDQ(:)
-ZDDU(:) = SIGN(MAX(ABS(ZDDU(:)),10.0*ZDUSR0),ZDDU(:))
-ZDDT(:) = SIGN(MAX(ABS(ZDDT(:)),10.0*ZDTSR0),ZDDT(:))
-ZDDQ(:) = SIGN(MAX(ABS(ZDDQ(:)),10.0*ZDQSR0),ZDDQ(:))
-
-write(*,*) "ZDDU ",ZDDU
-write(*,*) "ZDDQ ",ZDDQ
-write(*,*) "ZDDT ",ZDDT
-
-!
-JCV (:) = -1
-ZUSR(:) = 0.04*ZDDU(:)
-ZTSR(:) = 0.04*ZDDT(:)
-ZQSR(:) = 0.04*ZDDQ(:)
-ZDELTAU10N(:) = ZDDU(:)
-ZDELTAT10N(:) = ZDDT(:)
-ZDELTAQ10N(:) = ZDDQ(:)
-JITER(:) = 99
-!
-! In the following, we suppose that Richardson number PRI < XRIMAX
-! If not true, Monin-Obukhov theory can't (and therefore shouldn't) be applied !
-!-------------------------------------------------------------------------------
-!
-!       3.   ITERATIVE LOOP TO COMPUTE U*, T*, Q*.
-!       ------------------------------------------
-!
-DO JJ=1,NITERFL
-  DO JLON=1,SIZE(PTA)
-!
-  IF (JCV(JLON) == -1) THEN
-    ZUSR0(JLON)=ZUSR(JLON)
-    ZTSR0(JLON)=ZTSR(JLON)
-    ZQSR0(JLON)=ZQSR(JLON)
-    IF (JJ == NITERMAX+1 .OR. JJ == NITERMAX+NITERSUP) THEN
-      ZDELTAU10N(JLON) = 0.5*(ZDUSTO(JLON)+ZDELTAU10N(JLON))    !forced convergence
-      ZDELTAT10N(JLON) = 0.5*(ZDTSTO(JLON)+ZDELTAT10N(JLON))
-      ZDELTAQ10N(JLON) = 0.5*(ZDQSTO(JLON)+ZDELTAQ10N(JLON))
-      IF (JJ == NITERMAX+NITERSUP) JCV(JLON)=3
-    ENDIF
-    ZDUSTO(JLON) = ZDELTAU10N(JLON)
-    ZDTSTO(JLON) = ZDELTAT10N(JLON)
-    ZDQSTO(JLON) = ZDELTAQ10N(JLON)
-!
-!       3.1. Neutral parameter for wind speed (ECUME_V6 formulation)
-!
-    IF (ZDELTAU10N(JLON) <= ZUTU) THEN
-      ZPARUN(JLON) = ZCOEFU(0) + ZCOEFU(1)*ZDELTAU10N(JLON)      &
-                               + ZCOEFU(2)*ZDELTAU10N(JLON)**2   &
-                               + ZCOEFU(3)*ZDELTAU10N(JLON)**3   &
-                               + ZCOEFU(4)*ZDELTAU10N(JLON)**4   &
-                               + ZCOEFU(5)*ZDELTAU10N(JLON)**5
-    ELSE
-      ZPARUN(JLON) = ZCDIRU*(ZDELTAU10N(JLON)-ZUTU) + ZORDOU
-    ENDIF
-    PCDN(JLON) = (ZPARUN(JLON)/ZDELTAU10N(JLON))**2
-!
-!       3.2. Neutral parameter for temperature (ECUME_V6 formulation)
-!
-    IF (ZDELTAU10N(JLON) <= ZUTT) THEN
-      ZPARTN(JLON) = ZCOEFT(0) + ZCOEFT(1)*ZDELTAU10N(JLON)      &
-                               + ZCOEFT(2)*ZDELTAU10N(JLON)**2   &
-                               + ZCOEFT(3)*ZDELTAU10N(JLON)**3   &
-                               + ZCOEFT(4)*ZDELTAU10N(JLON)**4
-    ELSE
-      ZPARTN(JLON) = ZCDIRT*(ZDELTAU10N(JLON)-ZUTT) + ZORDOT
-    ENDIF
-!
-!       3.3. Neutral parameter for humidity (ECUME_V6 formulation)
-!
-    IF (ZDELTAU10N(JLON) <= ZUTQ) THEN
-      ZPARQN(JLON) = ZCOEFQ(0) + ZCOEFQ(1)*ZDELTAU10N(JLON)      &
-                               + ZCOEFQ(2)*ZDELTAU10N(JLON)**2
-    ELSE
-      ZPARQN(JLON) = ZCDIRQ*(ZDELTAU10N(JLON)-ZUTQ) + ZORDOQ
-    ENDIF
-!
-!       3.4. Scaling parameters U*, T*, Q*
-!
-    ZUSR(JLON) = ZPARUN(JLON)
-    ZTSR(JLON) = ZPARTN(JLON)*ZDELTAT10N(JLON)/ZDELTAU10N(JLON)
-    ZQSR(JLON) = ZPARQN(JLON)*ZDELTAQ10N(JLON)/ZDELTAU10N(JLON)
-!
-!       3.4b Gustiness factor (Deardorff 1970)
-!
-!       3.4c Cool skin correction
-!
-!       3.5. Obukhovs stability param. z/l following Liu et al. (JAS, 1979)
-!
-! For U
-    ZLMOU = PUREF(JLON)*XG*XKARMAN*(ZTSR(JLON)/PTA(JLON)   &
-            +ZETV*ZQSR(JLON)/(1.0+ZETV*PQA(JLON)))/ZUSR(JLON)**2
-! For T/Q
-    ZLMOT = ZLMOU*(PZREF(JLON)/PUREF(JLON))
-    ZLMOU = MAX(MIN(ZLMOU,ZLMOMAX),ZLMOMIN)
-    ZLMOT = MAX(MIN(ZLMOT,ZLMOMAX),ZLMOMIN)
-!
-!       3.6. Stability function psi (see Liu et al, 1979 ; Dyer and Hicks, 1970)
-!            Modified to include convective form following Fairall (unpublished)
-!
-! For U
-    IF (ZLMOU == 0.0) THEN
-      ZPSI_U = 0.0
-    ELSEIF (ZLMOU > 0.0) THEN
-      ZPSI_U = -ZGMA*ZLMOU
-    ELSE
-      ZCHIK  = (1.0-ZBTA*ZLMOU)**0.25
-      ZPSIK  = 2.0*LOG((1.0+ZCHIK)/2.0)  &
-                +LOG((1.0+ZCHIK**2)/2.0) &
-                -2.0*ATAN(ZCHIK)+0.5*XPI
-      ZCHIC  = (1.0-12.87*ZLMOU)**(1.0/3.0)       !for very unstable conditions
-      ZPSIC  = 1.5*LOG((ZCHIC**2+ZCHIC+1.0)/3.0)   &
-                -ZSQR3*ATAN((2.0*ZCHIC+1.0)/ZSQR3) &
-                +XPI/ZSQR3
-      ZPSI_U = ZPSIC+(ZPSIK-ZPSIC)/(1.0+ZLMOU**2) !match Kansas & free-conv. forms
-    ENDIF
-    ZPSIU(JLON) = ZPSI_U
-! For T/Q
-    IF (ZLMOT == 0.0) THEN
-      ZPSI_T = 0.0
-    ELSEIF (ZLMOT > 0.0) THEN
-      ZPSI_T = -ZGMA*ZLMOT
-    ELSE
-      ZCHIK  = (1.0-ZBTA*ZLMOT)**0.25
-      ZPSIK  = 2.0*LOG((1.0+ZCHIK**2)/2.0)
-      ZCHIC  = (1.0-12.87*ZLMOT)**(1.0/3.0)       !for very unstable conditions
-      ZPSIC  = 1.5*LOG((ZCHIC**2+ZCHIC+1.0)/3.0)   &
-                -ZSQR3*ATAN((2.0*ZCHIC+1.0)/ZSQR3) &
-                +XPI/ZSQR3
-      ZPSI_T = ZPSIC+(ZPSIK-ZPSIC)/(1.0+ZLMOT**2) !match Kansas & free-conv. forms
-    ENDIF
-    ZPSIT(JLON) = ZPSI_T
-!
-!       3.7. Update air-sea gradients
-!
-    ZDDU(JLON) = ZDU(JLON)
-    ZDDT(JLON) = ZDT(JLON)
-    ZDDQ(JLON) = ZDQ(JLON)
-    ZDDU(JLON) = SIGN(MAX(ABS(ZDDU(JLON)),10.0*ZDUSR0),ZDDU(JLON))
-    ZDDT(JLON) = SIGN(MAX(ABS(ZDDT(JLON)),10.0*ZDTSR0),ZDDT(JLON))
-    ZDDQ(JLON) = SIGN(MAX(ABS(ZDDQ(JLON)),10.0*ZDQSR0),ZDDQ(JLON))
-    ZLOGUS10   = LOG(PUREF(JLON)/10.0)
-    ZLOGTS10   = LOG(PZREF(JLON)/10.0)
-    ZDELTAU10N(JLON) = ZDDU(JLON)-ZUSR(JLON)*(ZLOGUS10-ZPSI_U)/XKARMAN
-    ZDELTAT10N(JLON) = ZDDT(JLON)-ZTSR(JLON)*(ZLOGTS10-ZPSI_T)/XKARMAN
-    ZDELTAQ10N(JLON) = ZDDQ(JLON)-ZQSR(JLON)*(ZLOGTS10-ZPSI_T)/XKARMAN
-    ZDELTAU10N(JLON) = SIGN(MAX(ABS(ZDELTAU10N(JLON)),10.0*ZDUSR0),   &
-                            ZDELTAU10N(JLON))
-    ZDELTAT10N(JLON) = SIGN(MAX(ABS(ZDELTAT10N(JLON)),10.0*ZDTSR0),   &
-                            ZDELTAT10N(JLON))
-    ZDELTAQ10N(JLON) = SIGN(MAX(ABS(ZDELTAQ10N(JLON)),10.0*ZDQSR0),   &
-                            ZDELTAQ10N(JLON))
-!
-!       3.8. Test convergence for U*, T*, Q*
-!
-    IF (ABS(ZUSR(JLON)-ZUSR0(JLON)) < ZDUSR0 .AND.   &
-        ABS(ZTSR(JLON)-ZTSR0(JLON)) < ZDTSR0 .AND.   &
-        ABS(ZQSR(JLON)-ZQSR0(JLON)) < ZDQSR0) THEN
-      JCV(JLON) = 1                                     !free convergence
-      IF (JJ >= NITERMAX+1) JCV(JLON) = 2               !leaded convergence
-    ENDIF
-    JITER(JLON) = JJ
-  ENDIF
-!
-  ENDDO
-ENDDO
-!
-!-------------------------------------------------------------------------------
-!
-!       4.   COMPUTATION OF TURBULENT FLUXES AND EXCHANGE COEFFICIENTS.
-!       ---------------------------------------------------------------
-!
-DO JLON=1,SIZE(PTA)
-!
-!       4.1. Surface turbulent fluxes
-!            (ATM CONV.: ZTAU<<0 ; ZHF,ZEF<0 if atm looses heat)
-!
-  ZTAU(JLON) = -PRHOA(JLON)*ZUSR(JLON)**2
-  ZHF(JLON)  = -PRHOA(JLON)*ZCPA(JLON)*ZUSR(JLON)*ZTSR(JLON)
-  ZEF(JLON)  = -PRHOA(JLON)*ZLVS(JLON)*ZUSR(JLON)*ZQSR(JLON)
-
-  write(*,*) "ZTAU = ",ZTAU(JLON)
-  write(*,*) "SENS = ",ZHF(JLON)
-  write(*,*) "LAT = ",ZEF(JLON)
-
-!
-!       4.2. Exchange coefficients PCD, PCH, PCE
-!
-  PCD(JLON) = (ZUSR(JLON)/ZDDU(JLON))**2
-  PCH(JLON) = (ZUSR(JLON)*ZTSR(JLON))/(ZDDU(JLON)*ZDDT(JLON))
-  PCE(JLON) = (ZUSR(JLON)*ZQSR(JLON))/(ZDDU(JLON)*ZDDQ(JLON))
-
-  write(*,*) "ZUSR = ",ZUSR(JLON)
-  write(*,*) "ZTSR = ",ZTSR(JLON)
-  write(*,*) "ZQSR = ",ZQSR(JLON)
-
-!
-!       4.3. Stochastic perturbation of turbulent fluxes
-!
-!  IF( OPERTFLUX )THEN
-!    ZTAU(JLON) = ZTAU(JLON)* ( 1. + PPERTFLUX(JLON) / 2. )
-!    ZHF (JLON) = ZHF(JLON)*  ( 1. + PPERTFLUX(JLON) / 2. )
-!    ZEF (JLON) = ZEF(JLON)*  ( 1. + PPERTFLUX(JLON) / 2. )
-!  ENDIF
-!
-ENDDO
-!
-!-------------------------------------------------------------------------------
-!
-!       5.   COMPUTATION OF FLUX CORRECTIONS DUE TO RAINFALL.
-!            (ATM conv: ZRF<0 if atm. looses heat, ZTAUR<<0)
-!       -----------------------------------------------------
-!
-IF (OPRECIP) THEN
-  DO JLON=1,SIZE(PTA)
-!
-!       5.1. Momentum flux due to rainfall (ZTAUR, N/m2)
-!
-! See pp3752 in FBR96.
-    ZTAUR(JLON) = -0.85*PRAIN(JLON)*PVMOD(JLON)
-!
-!       5.2. Sensible heat flux due to rainfall (ZRF, W/m2)
-!
-! See Eq.12 in GoF95 with ZCPWA as specific heat of water at atm level (J/kg/K),
-! ZDQSDT from Clausius-Clapeyron relation, ZDWAT as water vapor diffusivity 
-! (Eq.13-3 of Pruppacher and Klett, 1978), ZDTMP as heat diffusivity, and ZBULB
-! as wet-bulb factor (Eq.11 in GoF95).
-!
-    ZTAC   = PTA(JLON)-XTT
-    ZCPWA  = 4217.51 -3.65566*ZTAC +0.1381*ZTAC**2       &
-              -2.8309E-03*ZTAC**3 +3.42061E-05*ZTAC**4   &
-              -2.18107E-07*ZTAC**5 +5.74535E-10*ZTAC**6
-    ZDQSDT = (ZLVA(JLON)*ZQSATA(JLON))/(XRV*PTA(JLON)**2)
-    ZDWAT  = 2.11E-05*(ZP00/PPA(JLON))*(PTA(JLON)/XTT)**1.94
-    ZDTMP  = (1.0+3.309E-03*ZTAC-1.44E-06*ZTAC**2)   &
-              *0.02411/(PRHOA(JLON)*ZCPA(JLON))
-    ZBULB  = 1.0/(1.0+ZDQSDT*(ZLVA(JLON)*ZDWAT)/(ZCPA(JLON)*ZDTMP))
-    ZRF(JLON) = PRAIN(JLON)*ZCPWA*ZBULB*((PSST(JLON)-PTA(JLON))   &
-                +(PQSATA(JLON)-PQA(JLON))*(ZLVA(JLON)*ZDWAT)/(ZCPA(JLON)*ZDTMP))
-!
-  ENDDO
-ENDIF
-!
-!-------------------------------------------------------------------------------
-!
-!       6.   COMPUTATION OF WEBB CORRECTION TO LATENT HEAT FLUX (ZEFWEBB, W/m2).
-!       ------------------------------------------------------------------------
-!
-! See Eq.21 and Eq.22 in FBR96.
-IF (OPWEBB) THEN
-  DO JLON=1,SIZE(PTA)
-    ZWW = (1.0+ZETV)*(ZUSR(JLON)*ZQSR(JLON))   &
-           +(1.0+(1.0+ZETV)*PQA(JLON))*(ZUSR(JLON)*ZTSR(JLON))/PTA(JLON)
-    ZEFWEBB(JLON) = -PRHOA(JLON)*ZLVS(JLON)*ZWW*PQA(JLON)
-  ENDDO
-ENDIF
-!
-!-------------------------------------------------------------------------------
-!
-!       7.   FINAL STEP : TOTAL SURFACE FLUXES AND DERIVED DIAGNOSTICS. 
-!       ---------------------------------------------------------------
-!
-!       7.1. Richardson number
-!
-! CALL SURFACE_RI(PSST,PQSAT,PEXNS,PEXNA,PTA,PQA,   &
-!                PZREF,PUREF,ZDIRCOSZW,PVMOD,PRI)
-!
-!       7.2. Friction velocity which contains correction due to rain
-!
-ZUSTAR2(:) = -(ZTAU(:)+ZTAUR(:))/PRHOA(:)       !>>0 as ZTAU<<0 & ZTAUR<=0
-!
-IF (OPRECIP) THEN
-  PCD(:) = ZUSTAR2(:)/ZDDU(:)**2
-ENDIF
-!
-PUSTAR(:) = SQRT(ZUSTAR2(:))                    !>>0
-!
-!       7.3. Aerodynamical conductance and resistance
-!
-ZAC  (:) = PCH(:)*ZDDU(:)
-PRESA(:) = 1.0/ZAC(:)
-!
-!       7.4. Total surface fluxes
-!
-PSFTH(:) =  ZHF(:)+ZRF(:)
-PSFTQ(:) = (ZEF(:)+ZEFWEBB(:))/ZLVS(:)
-!
-!       7.5. Charnock number
-!
-IF (CCHARNOCK == 'OLD') THEN
-  ZCHARN(:) = XVCHRNK
-ELSE            !modified for moderate wind speed as in COARE3.0
-  ZCHARN(:) = MIN(0.018,MAX(0.011,0.011+(0.007/8.0)*(ZDDU(:)-10.0)))
-ENDIF
-!
-!       7.6. Roughness lengths Z0 and Z0H over sea
-!
-!IF (KZ0 == 0) THEN      ! ARPEGE formulation
-!  PZ0SEA (:) = (ZCHARN(:)/XG)*ZUSTAR2(:) + XVZ0CM*PCD(:)/PCDN(:)
-!  PZ0HSEA(:) = PZ0SEA (:)
-!ELSEIF (KZ0 == 1) THEN  ! Smith (1988) formulation
-!  PZ0SEA (:) = (ZCHARN(:)/XG)*ZUSTAR2(:) + 0.11*ZVISA(:)/PUSTAR(:)
-!  PZ0HSEA(:) = PZ0SEA (:)
-!ELSEIF (KZ0 == 2) THEN  ! Direct computation using the stability functions
-!  DO JLON=1,SIZE(PTA)
-!    PZ0SEA (JLON) = PUREF(JLON)/EXP(XKARMAN*ZDDU(JLON)/PUSTAR(JLON)+ZPSIU(JLON))
-!    Z0TSEA        = PZREF(JLON)/EXP(XKARMAN*ZDDT(JLON)/ZTSR  (JLON)+ZPSIT(JLON))
-!    Z0QSEA        = PZREF(JLON)/EXP(XKARMAN*ZDDQ(JLON)/ZQSR  (JLON)+ZPSIT(JLON))
-!    PZ0HSEA(JLON) = 0.5*(Z0TSEA+Z0QSEA)
-!  ENDDO
-!ENDIF
-
-write(*,*) "JLON ",JLON
-write(*,*) "PTA ",klon,PTA
-write(*,*) "PCD ",SIZE(PCD),PCD
-write(*,*) "PCQ ",SIZE(PCE),PCE
-write(*,*) "PCH ",SIZE(PCH),PCH
-
-coeffs = [PCD,&
-       PCE,&
-       PCH]
-!
-!
-!IF (LHOOK) CALL DR_HOOK('ECUMEV6_FLUX',1,ZHOOK_HANDLE)
-!
-!-------------------------------------------------------------------------------
-   END SUBROUTINE ECUMEV6_FLUX
Index: /LMDZ6/trunk/libf/phylmd/ecumev6_flux.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/ecumev6_flux.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/ecumev6_flux.f90	(revision 5268)
@@ -0,0 +1,777 @@
+!SFX_LIC Copyright 1994-2014 CNRS, Meteo-France and Universite Paul Sabatier
+!SFX_LIC This is part of the SURFEX software governed by the CeCILL-C licence
+!SFX_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt  
+!SFX_LIC for details. version 1.
+!     #########
+    SUBROUTINE ECUMEV6_FLUX(PZ0SEA,PTA,PSST,PQA,PQSAT,PVMOD, &
+                            PZREF,PSSS,PUREF,PPS,PPA,OPRECIP,OPWEBB,        &
+                            PSFTH,PSFTQ,PUSTAR,PCD,PCDN,PCH,PCE,        &
+                            PRI,PRESA,PRAIN,PZ0HSEA,OPERTFLUX,coeffs   )
+!###############################################################################
+!!
+!!****  *ECUMEV6_FLUX*
+!!
+!!    PURPOSE
+!!    -------
+!       Calculate the surface turbulent fluxes of heat, moisture, and momentum 
+!       over sea surface + corrections due to rainfall & Webb effect.
+!!
+!!**  METHOD
+!!    ------
+!       The estimation of the transfer coefficients relies on the iterative 
+!       computation of the scaling parameters U*/Teta*/q*. The convergence is
+!       supposed to be reached in NITERFL iterations maximum.
+!       Neutral transfer coefficients for momentum/temperature/humidity
+!       are computed as a function of the 10m-height neutral wind speed using
+!       the ECUME_V6 formulation based on the multi-campaign (POMME,FETCH,CATCH,
+!       SEMAPHORE,EQUALANT) ALBATROS dataset.
+!!
+!!    EXTERNAL
+!!    --------
+!!
+!!    IMPLICIT ARGUMENTS
+!!    ------------------
+!!
+!!    REFERENCE
+!!    ---------
+!!      Fairall et al (1996), JGR, 3747-3764
+!!      Gosnell et al (1995), JGR, 437-442
+!!      Fairall et al (1996), JGR, 1295-1308
+!!
+!!    AUTHOR
+!!    ------
+!!      C. Lebeaupin  *Météo-France* (adapted from S. Belamari's code)
+!!
+!!    MODIFICATIONS
+!!    -------------
+!!      Original     15/03/2005
+!!      Modified        01/2006  C. Lebeaupin (adapted from  A. Pirani's code)
+!!      Modified        08/2009  B. Decharme: limitation of Ri
+!!      Modified        09/2012  B. Decharme: CD correction
+!!      Modified        09/2012  B. Decharme: limitation of Ri in surface_ri.F90
+!!      Modified        10/2012  P. Le Moigne: extra inputs for FLake use
+!!      Modified        06/2013  B. Decharme: bug in z0 (output) computation 
+!!      Modified        12/2013  S. Belamari: ZRF computation updated:
+!!                                1. ZP00/PPA in ZDWAT, ZLVA in ZDQSDT/ZBULB/ZRF
+!!                                2. ZDWAT/ZDTMP in ZBULB/ZRF (Gosnell et al 95)
+!!                                3. cool skin correction included
+!!      Modified        01/2014  S. Belamari: salinity impact on latent heat of
+!!                                vaporization of seawater included
+!!      Modified        01/2014  S. Belamari: new formulation for pure water
+!!                                specific heat (ZCPWA)
+!!      Modified        01/2014  S. Belamari: 4 choices for PZ0SEA computation
+!!      Modified        12/2015  S. Belamari: ECUME now provides parameterisations
+!!                                for:  U10n*sqrt(CDN)          instead of CDN
+!!                                      U10n*CHN/sqrt(CDN)         "       CHN
+!!                                      U10n*CEN/sqrt(CDN)         "       CEN
+!!      Modified        01/2016  S. Belamari: New ECUME formulation
+!!
+!!      To be done:
+!!      include gustiness computation following Mondon & Redelsperger (1998)
+!!!
+!-------------------------------------------------------------------------------
+!!
+!!    MODIFICATIONS RELATED TO SST CORRECTION COMPUTATION
+!!    ---------------------------------------------------
+!!      Modified        09/2013  S. Belamari: use 0.98 for the ocean emissivity
+!!                                following up to date satellite measurements in
+!!                                the 8-14 μm range (obtained values range from
+!!                                0.98 to 0.99).
+!!!
+!-------------------------------------------------------------------------------
+!
+!       0.   DECLARATIONS
+!            ------------
+!
+USE dimphy
+USE indice_sol_mod
+USE MODD_CSTS,             ONLY : XPI, XDAY, XKARMAN, XG, XP00, XSTEFAN, XRD, XRV,   &
+                                  XCPD, XCPV, XCL, XTT, XLVTT
+
+
+!USE MODD_SURF_PAR,         ONLY : XUNDEF
+!USE MODD_SURF_ATM,         ONLY : XVCHRNK, XVZ0CM
+!USE MODD_REPROD_OPER,      ONLY : CCHARNOCK
+!
+!USE MODE_THERMOS
+!USE MODI_WIND_THRESHOLD
+!USE MODI_SURFACE_RI
+!
+!USE YOMHOOK,   ONLY : LHOOK,   DR_HOOK
+!USE PARKIND1,  ONLY : JPRB
+!
+!USE MODI_ABOR1_SFX
+!
+IMPLICIT NONE
+!
+!       0.1. Declarations of arguments
+!
+REAL, DIMENSION(klon), INTENT(IN)    :: PVMOD      ! module of wind at atm level (m/s)
+REAL, DIMENSION(klon), INTENT(IN)    :: PTA        ! air temperature at atm level (K)
+REAL, DIMENSION(klon), INTENT(IN)    :: PQA        ! air spec. hum. at atm level (kg/kg)
+REAL, DIMENSION(klon), INTENT(IN)    :: PQSAT      ! sea surface spec. hum. (kg/kg)
+REAL, DIMENSION(klon), INTENT(IN)    :: PPA        ! air pressure at atm level (Pa)
+!REAL, DIMENSION(:), INTENT(IN)    :: PRHOA      ! air density at atm level (kg/m3)
+!REAL, DIMENSION(:), INTENT(IN)    :: PEXNA      ! Exner function at atm level
+REAL, DIMENSION(klon), INTENT(IN)    :: PUREF      ! atm level for wind (m)
+REAL, DIMENSION(klon), INTENT(IN)    :: PZREF      ! atm level for temp./hum. (m)
+REAL, DIMENSION(klon), INTENT(IN)    :: PSSS       ! Sea Surface Salinity (g/kg)
+REAL, DIMENSION(klon), INTENT(IN)    :: PPS        ! air pressure at sea surface (Pa)
+!REAL, DIMENSION(:), INTENT(IN)    :: PEXNS      ! Exner function at sea surface
+!REAL, DIMENSION(:), INTENT(IN)    :: PPERTFLUX  ! stochastic flux perturbation pattern
+! for correction
+!REAL,               INTENT(IN)    :: PICHCE    !
+LOGICAL,            INTENT(IN)    :: OPRECIP   !
+LOGICAL,            INTENT(IN)    :: OPWEBB    !
+LOGICAL,            INTENT(IN)    :: OPERTFLUX
+REAL, DIMENSION(klon), INTENT(IN)    :: PRAIN     ! precipitation rate (kg/s/m2)
+!
+!INTEGER,            INTENT(IN)    :: KZ0
+!
+REAL, DIMENSION(klon), INTENT(INOUT) :: PSST       ! Sea Surface Temperature (K)
+REAL, DIMENSION(klon), INTENT(INOUT) :: PZ0SEA     ! roughness length over sea
+REAL, DIMENSION(klon), INTENT(OUT)   :: PZ0HSEA    ! heat roughness length over sea
+
+! surface fluxes : latent heat, sensible heat, friction fluxes
+REAL, DIMENSION(klon), INTENT(OUT)   :: PUSTAR     ! friction velocity (m/s)
+REAL, DIMENSION(klon), INTENT(OUT)   :: PSFTH      ! heat flux (W/m2)
+REAL, DIMENSION(klon), INTENT(OUT)   :: PSFTQ      ! water flux (kg/m2/s)
+
+! diagnostics
+REAL, DIMENSION(klon), INTENT(OUT)   :: PCD        ! transfer coef. for momentum
+REAL, DIMENSION(klon), INTENT(OUT)   :: PCH        ! transfer coef. for temperature
+REAL, DIMENSION(klon), INTENT(OUT)   :: PCE        ! transfer coef. for humidity
+REAL, DIMENSION(klon), INTENT(OUT)   :: PCDN       ! neutral coef. for momentum
+REAL, DIMENSION(klon), INTENT(OUT)   :: PRI        ! Richardson number
+REAL, DIMENSION(klon), INTENT(OUT)   :: PRESA      ! aerodynamical resistance
+real, dimension(3), intent(out)   :: coeffs
+
+!       0.2. Declarations of local variables
+!
+! specif SB
+INTEGER, DIMENSION(SIZE(PTA))     :: JCV        ! convergence index
+INTEGER, DIMENSION(SIZE(PTA))     :: JITER      ! nb of iterations to converge
+!rajout
+REAL, DIMENSION(SIZE(PTA))        :: PEXNA      ! Exner function at atm level
+REAL, DIMENSION(SIZE(PTA))       :: PEXNS      ! Exner function at atm level
+!
+REAL, DIMENSION(SIZE(PTA))        :: ZTAU       ! momentum flux (N/m2)
+REAL, DIMENSION(SIZE(PTA))        :: ZHF        ! sensible heat flux (W/m2)
+REAL, DIMENSION(SIZE(PTA))        :: ZEF        ! latent heat flux (W/m2)
+REAL, DIMENSION(SIZE(PTA))        :: ZTAUR      ! momentum flx due to rain (N/m2)
+REAL, DIMENSION(SIZE(PTA))        :: ZRF        ! sensible flx due to rain (W/m2)
+REAL, DIMENSION(SIZE(PTA))        :: ZEFWEBB    ! Webb corr. on latent flx (W/m2)
+
+REAL, DIMENSION(SIZE(PTA))        :: ZVMOD      ! wind intensity at atm level (m/s)
+REAL, DIMENSION(SIZE(PTA))        :: ZQSATA     ! sat.spec.hum. at atm level (kg/kg)
+REAL, DIMENSION(SIZE(PTA))        :: ZLVA       ! vap.heat of pure water at atm level (J/kg)
+REAL, DIMENSION(SIZE(PTA))        :: ZLVS       ! vap.heat of seawater at sea surface (J/kg)
+REAL, DIMENSION(SIZE(PTA))        :: ZCPA       ! specif.heat moist air (J/kg/K)
+REAL, DIMENSION(SIZE(PTA))        :: ZVISA      ! kinemat.visc. of dry air (m2/s)
+REAL, DIMENSION(SIZE(PTA))        :: ZDU        ! U   vert.grad. (real atm)
+REAL, DIMENSION(SIZE(PTA))        :: ZDT,ZDQ    ! T,Q vert.grad. (real atm)
+REAL, DIMENSION(SIZE(PTA))        :: ZDDU       ! U   vert.grad. (real atm + gust)
+REAL, DIMENSION(SIZE(PTA))        :: ZDDT,ZDDQ  ! T,Q vert.grad. (real atm + WL/CS)
+REAL, DIMENSION(SIZE(PTA))        :: ZUSR       ! velocity scaling param. (m/s)
+                                                ! =friction velocity
+REAL, DIMENSION(SIZE(PTA))        :: ZTSR       ! temperature scaling param. (K)
+REAL, DIMENSION(SIZE(PTA))        :: ZQSR       ! humidity scaling param. (kg/kg)
+REAL, DIMENSION(SIZE(PTA))        :: ZDELTAU10N,ZDELTAT10N,ZDELTAQ10N
+                                                ! U,T,Q vert.grad. (10m, neutral atm)
+REAL, DIMENSION(SIZE(PTA))        :: ZUSR0,ZTSR0,ZQSR0    ! ITERATIVE PROCESS
+REAL, DIMENSION(SIZE(PTA))        :: ZDUSTO,ZDTSTO,ZDQSTO ! ITERATIVE PROCESS
+REAL, DIMENSION(SIZE(PTA))        :: ZPSIU,ZPSIT! PSI funct for U, T/Q (Z0 comp)
+REAL, DIMENSION(SIZE(PTA))        :: ZCHARN     ! Charnock parameter   (Z0 comp)
+
+REAL, DIMENSION(SIZE(PTA))        :: ZUSTAR2    ! square of friction velocity
+REAL, DIMENSION(SIZE(PTA))        :: ZAC        ! aerodynamical conductance
+REAL, DIMENSION(SIZE(PTA))        :: ZDIRCOSZW  ! orography slope cosine
+                                                ! (=1 on water!)
+REAL, DIMENSION(SIZE(PTA))        :: ZPARUN,ZPARTN,ZPARQN ! neutral parameter for U,T,Q
+
+!-- rajout pour la pression saturante
+REAL, DIMENSION(SIZE(PPA))        :: ZFOES                                 ! [OPWEBB]
+REAL, DIMENSION(SIZE(PPA))        :: ZWORK1
+REAL, DIMENSION(SIZE(PPA))        :: ZWORK2  
+REAL, DIMENSION(SIZE(PPS))        :: ZWORK1A
+REAL, DIMENSION(SIZE(PPS))        :: ZWORK2A
+!#####################
+
+REAL, DIMENSION(0:5)              :: ZCOEFU,ZCOEFT,ZCOEFQ
+
+!--------- Modif Olive -----------------
+REAL, DIMENSION(SIZE(PTA))        :: PRHOA
+REAL, PARAMETER                   :: XUNDEF = 1.E+20
+
+
+REAL       :: XVCHRNK = 0.021
+REAL       :: XVZ0CM = 1.0E-5 
+!REAL       :: XRIMAX
+
+CHARACTER  :: CCHARNOCK = 'NEW'
+
+
+!--------------------------------------
+
+
+! local constants
+LOGICAL :: OPCVFLX              ! to force convergence
+INTEGER :: NITERMAX             ! nb of iterations to get free convergence
+INTEGER :: NITERSUP             ! nb of additional iterations if OPCVFLX=.TRUE.
+INTEGER :: NITERFL              ! maximum number of iterations
+REAL    :: ZETV,ZRDSRV          ! thermodynamic constants
+REAL    :: ZSQR3
+REAL    :: ZLMOMIN,ZLMOMAX      ! min/max value of Obukhovs stability param. z/l
+REAL    :: ZBTA,ZGMA            ! parameters of the stability functions
+REAL    :: ZDUSR0,ZDTSR0,ZDQSR0 ! maximum gap for USR/TSR/QSR between 2 steps
+REAL    :: ZP00                 ! [OPRECIP] - water vap. diffusiv.ref.press.(Pa)
+REAL    :: ZUTU,ZUTT,ZUTQ       ! U10n threshold in ECUME parameterisation
+REAL    :: ZCDIRU,ZCDIRT,ZCDIRQ ! coef directeur pour fonction affine U,T,Q
+REAL    :: ZORDOU,ZORDOT,ZORDOQ ! ordonnee a l'origine pour fonction affine U,T,Q
+
+INTEGER :: JJ                                   ! for ITERATIVE PROCESS
+INTEGER :: JLON,JK
+REAL    :: ZLMOU,ZLMOT                          ! Obukhovs param. z/l for U, T/Q
+REAL    :: ZPSI_U,ZPSI_T                        ! PSI funct. for U, T/Q
+REAL    :: Z0TSEA,Z0QSEA                        ! roughness length for T, Q
+REAL    :: ZCHIC,ZCHIK,ZPSIC,ZPSIK,ZLOGUS10,ZLOGTS10
+REAL    :: ZTAC,ZCPWA,ZDQSDT,ZDWAT,ZDTMP,ZBULB  ! [OPRECIP]
+REAL    :: ZWW                                  ! [OPWEBB]
+
+
+INTEGER :: PREF             ! reference pressure for exner function
+REAL, DIMENSION(klon)    :: PQSATA      ! sea surface spec. hum. (kg/kg)
+
+REAL    :: qsat_seawater2,qsat_seawater
+
+INCLUDE "YOMCST.h"
+INCLUDE "clesphys.h"
+
+!REAL(KIND=JPRB) :: ZHOOK_HANDLE
+!
+!-------------------------------------------------------------------------------
+!----------------------- Modif Olive calcul de PRHOA ---------------------------
+
+!write(*,*) "PZ0SEA ",PZ0SEA
+!write(*,*) "PTA ",PTA
+!write(*,*) "PSST ",PSST
+!write(*,*) "PQA ",PQA
+!write(*,*) "PVMOD ",PVMOD
+!write(*,*) "PZREF ",PZREF
+!write(*,*) "PUREF ",PUREF
+!write(*,*) "PPS ",PPS
+!write(*,*) "PPA ",PPA
+!write(*,*) "OPRECIP ",OPRECIP
+!write(*,*) "PZ0HSEA ",PZ0HSEA
+!write(*,*) "PRAIN ",PRAIN
+
+
+PRHOA(:) = PPS(:) / (287.1 * PTA(:) * (1.+.61*PQA(:)))
+!write(*,*) "klon klon ",klon,PTA
+!write(*,*) "PRHOA ",SIZE(PRHOA),PRHOA
+
+PREF = 100900.                    ! = 1000 hPa
+
+!PEXNA = (PPA/PPS)**RKAPPA
+!PEXNS = (PPS/PPS)**RKAPPA
+
+PEXNA = (PPA/PREF)**(RD/RCPD)
+PEXNS = (PPS/PREF)**(RD/RCPD)
+
+!IF (LHOOK) CALL DR_HOOK('ECUMEV6_FLUX',0,ZHOOK_HANDLE)
+!
+ZDUSR0   = 1.E-06
+ZDTSR0   = 1.E-06
+ZDQSR0   = 1.E-09
+!
+NITERMAX = 5
+NITERSUP = 5
+OPCVFLX  = .TRUE.
+!
+NITERFL = NITERMAX
+IF (OPCVFLX) NITERFL = NITERMAX+NITERSUP
+!
+ZCOEFU = (/ 1.00E-03, 3.66E-02, -1.92E-03, 2.32E-04, -7.02E-06,  6.40E-08 /)
+ZCOEFT = (/ 5.36E-03, 2.90E-02, -1.24E-03, 4.50E-04, -2.06E-05,       0.0 /)
+ZCOEFQ = (/ 1.00E-03, 3.59E-02, -2.87E-04,      0.0,       0.0,       0.0 /)
+!
+ZUTU = 40.0
+ZUTT = 14.4
+ZUTQ = 10.0
+!
+ZCDIRU = ZCOEFU(1) + 2.0*ZCOEFU(2)*ZUTU + 3.0*ZCOEFU(3)*ZUTU**2   &
+                   + 4.0*ZCOEFU(4)*ZUTU**3 + 5.0*ZCOEFU(5)*ZUTU**4
+ZCDIRT = ZCOEFT(1) + 2.0*ZCOEFT(2)*ZUTT + 3.0*ZCOEFT(3)*ZUTT**2   &
+                   + 4.0*ZCOEFT(4)*ZUTT**3
+ZCDIRQ = ZCOEFQ(1) + 2.0*ZCOEFQ(2)*ZUTQ
+!
+ZORDOU = ZCOEFU(0) + ZCOEFU(1)*ZUTU + ZCOEFU(2)*ZUTU**2 + ZCOEFU(3)*ZUTU**3   &
+                   + ZCOEFU(4)*ZUTU**4 + ZCOEFU(5)*ZUTU**5
+ZORDOT = ZCOEFT(0) + ZCOEFT(1)*ZUTT + ZCOEFT(2)*ZUTT**2 + ZCOEFT(3)*ZUTT**3   &
+                   + ZCOEFT(4)*ZUTT**4
+ZORDOQ = ZCOEFQ(0) + ZCOEFQ(1)*ZUTQ + ZCOEFQ(2)*ZUTQ**2
+!
+!-------------------------------------------------------------------------------
+!
+!       1.   AUXILIARY CONSTANTS & ARRAY INITIALISATION BY UNDEFINED VALUES.
+!       --------------------------------------------------------------------
+!
+ZDIRCOSZW(:) = 1.0
+!
+ZETV    = XRV/XRD-1.0   !~0.61 (cf Liu et al. 1979)
+ZRDSRV  = XRD/XRV       !~0.622
+ZSQR3   = SQRT(3.0)
+ZLMOMIN = -200.0
+ZLMOMAX = 0.25
+ZBTA    = 16.0
+ZGMA    = 7.0           !initially =4.7, modified to 7.0 following G. Caniaux
+!
+ZP00    = 1013.25E+02
+!
+PCD  = XUNDEF
+PCH  = XUNDEF
+PCE  = XUNDEF
+PCDN = XUNDEF
+ZUSR = XUNDEF
+ZTSR = XUNDEF
+ZQSR = XUNDEF
+ZTAU = XUNDEF
+ZHF  = XUNDEF
+ZEF  = XUNDEF
+!
+PSFTH  = XUNDEF
+PSFTQ  = XUNDEF
+PUSTAR = XUNDEF
+PRESA  = XUNDEF
+PRI    = XUNDEF
+!
+ZTAUR   = 0.0
+ZRF     = 0.0
+ZEFWEBB = 0.0
+!
+!-------------------------------------------------------------------------------
+!
+!       2.   INITIALISATIONS BEFORE ITERATIVE LOOP.
+!       -------------------------------------------
+!
+!ZVMOD(:) = WIND_THRESHOLD(PVMOD(:),PUREF(:))    !set a minimum value to wind
+ZVMOD = MAX(PVMOD , 0.1 * MIN(10.,PUREF) )    !set a minimum value to wind
+
+write(*,*) "ZVMOD ",SIZE(ZVMOD)
+
+!
+!       2.0. Radiative fluxes - For warm layer & cool skin
+!
+!       2.0b. Warm Layer correction
+!
+!       2.1. Specific humidity at saturation
+!
+WHERE(PSSS(:)>0.0.AND.PSSS(:)/=XUNDEF)
+  PQSATA = QSAT_SEAWATER2 (PSST(:),PPS(:),PSSS(:))    !at sea surface
+ELSEWHERE
+  PQSATA (:) = QSAT_SEAWATER (PSST(:),PPS(:))            !at sea surface
+ENDWHERE
+
+!ZQSATA(:) = QSAT(PTA(:),PPA(:))                         !at atm level
+
+!### OLIVIER POUR PRESSION SATURANTE #####
+!-------------------------------------------------------------------------------
+!
+ZFOES  = 1 !PSAT(PT(:))
+ZFOES  = 0.98*ZFOES
+!
+ZWORK1    = ZFOES/PPS
+ZWORK2    = XRD/XRV
+
+ZWORK1A    = ZFOES/PPA
+ZWORK2A    = XRD/XRV
+
+!write(*,*) "ZFOES ",ZFOES
+!write(*,*) "PPS ",PPS
+!write(*,*) "ZWORK1 ",ZWORK1
+!write(*,*) "XRD ",XRD
+!write(*,*) "XRV ",XRV
+!write(*,*) "PPA ",PPA
+!write(*,*) "ZWORK1A ",ZWORK1A
+
+write(*,*) "PQSAT : ",PQSAT
+write(*,*) "PQSATA : ",PQSATA
+
+
+!
+!*       2.    COMPUTE SATURATION HUMIDITY
+!              ---------------------------
+!
+!PQSAT  = ZWORK2*ZWORK1 / (1.+(ZWORK2-1.)*ZWORK1)
+!ZQSATA = ZWORK2A*ZWORK1A / (1.+(ZWORK2A-1.)*ZWORK1A)
+ZQSATA = QSAT_SEAWATER (PTA(:),PPA(:))            !at sea surface
+
+
+!
+!       2.2. Gradients at the air-sea interface
+!
+ZDU(:) = ZVMOD(:)               !one assumes u is measured / sea surface current
+ZDT(:) = PTA(:)/PEXNA(:)-PSST(:)/PEXNS(:)
+ZDQ(:) = PQA(:)-PQSATA(:)
+
+write(*,*) "PQA ",PQA(:)
+write(*,*) "PQSAT",PQSAT(:)
+write(*,*) "ZDQ",ZDQ(:)
+!
+!       2.3. Latent heat of vaporisation
+!
+ZLVA(:) = XLVTT+(XCPV-XCL)*(PTA (:)-XTT)                !of pure water at atm level
+ZLVS(:) = XLVTT+(XCPV-XCL)*(PSST(:)-XTT)                !of pure water at sea surface
+
+
+
+write(*,*) "ZLVA ",ZLVA
+write(*,*) "ZLVS ",ZLVS
+
+
+WHERE(PSSS(:)>0.0.AND.PSSS(:)/=XUNDEF)
+  ZLVS(:) = ZLVS(:)*(1.0-1.00472E-3*PSSS(:))            !of seawater at sea surface
+ENDWHERE
+!
+!       2.4. Specific heat of moist air (Businger 1982)
+!
+!ZCPA(:) = XCPD*(1.0+(XCPV/XCPD-1.0)*PQA(:))
+ZCPA(:) = XCPD
+!
+!       2.4b Kinematic viscosity of dry air (Andreas 1989, CRREL Rep. 89-11)
+!
+ZVISA(:) = 1.326E-05*(1.0+6.542E-03*(PTA(:)-XTT)+8.301E-06*(PTA(:)-XTT)**2   &
+           -4.84E-09*(PTA(:)-XTT)**3)
+!
+!       2.4c Coefficients for warm layer and/or cool skin correction
+!
+!       2.5. Initial guess
+!
+ZDDU(:) = ZDU(:)
+ZDDT(:) = ZDT(:)
+ZDDQ(:) = ZDQ(:)
+ZDDU(:) = SIGN(MAX(ABS(ZDDU(:)),10.0*ZDUSR0),ZDDU(:))
+ZDDT(:) = SIGN(MAX(ABS(ZDDT(:)),10.0*ZDTSR0),ZDDT(:))
+ZDDQ(:) = SIGN(MAX(ABS(ZDDQ(:)),10.0*ZDQSR0),ZDDQ(:))
+
+write(*,*) "ZDDU ",ZDDU
+write(*,*) "ZDDQ ",ZDDQ
+write(*,*) "ZDDT ",ZDDT
+
+!
+JCV (:) = -1
+ZUSR(:) = 0.04*ZDDU(:)
+ZTSR(:) = 0.04*ZDDT(:)
+ZQSR(:) = 0.04*ZDDQ(:)
+ZDELTAU10N(:) = ZDDU(:)
+ZDELTAT10N(:) = ZDDT(:)
+ZDELTAQ10N(:) = ZDDQ(:)
+JITER(:) = 99
+!
+! In the following, we suppose that Richardson number PRI < XRIMAX
+! If not true, Monin-Obukhov theory can't (and therefore shouldn't) be applied !
+!-------------------------------------------------------------------------------
+!
+!       3.   ITERATIVE LOOP TO COMPUTE U*, T*, Q*.
+!       ------------------------------------------
+!
+DO JJ=1,NITERFL
+  DO JLON=1,SIZE(PTA)
+!
+  IF (JCV(JLON) == -1) THEN
+    ZUSR0(JLON)=ZUSR(JLON)
+    ZTSR0(JLON)=ZTSR(JLON)
+    ZQSR0(JLON)=ZQSR(JLON)
+    IF (JJ == NITERMAX+1 .OR. JJ == NITERMAX+NITERSUP) THEN
+      ZDELTAU10N(JLON) = 0.5*(ZDUSTO(JLON)+ZDELTAU10N(JLON))    !forced convergence
+      ZDELTAT10N(JLON) = 0.5*(ZDTSTO(JLON)+ZDELTAT10N(JLON))
+      ZDELTAQ10N(JLON) = 0.5*(ZDQSTO(JLON)+ZDELTAQ10N(JLON))
+      IF (JJ == NITERMAX+NITERSUP) JCV(JLON)=3
+    ENDIF
+    ZDUSTO(JLON) = ZDELTAU10N(JLON)
+    ZDTSTO(JLON) = ZDELTAT10N(JLON)
+    ZDQSTO(JLON) = ZDELTAQ10N(JLON)
+!
+!       3.1. Neutral parameter for wind speed (ECUME_V6 formulation)
+!
+    IF (ZDELTAU10N(JLON) <= ZUTU) THEN
+      ZPARUN(JLON) = ZCOEFU(0) + ZCOEFU(1)*ZDELTAU10N(JLON)      &
+                               + ZCOEFU(2)*ZDELTAU10N(JLON)**2   &
+                               + ZCOEFU(3)*ZDELTAU10N(JLON)**3   &
+                               + ZCOEFU(4)*ZDELTAU10N(JLON)**4   &
+                               + ZCOEFU(5)*ZDELTAU10N(JLON)**5
+    ELSE
+      ZPARUN(JLON) = ZCDIRU*(ZDELTAU10N(JLON)-ZUTU) + ZORDOU
+    ENDIF
+    PCDN(JLON) = (ZPARUN(JLON)/ZDELTAU10N(JLON))**2
+!
+!       3.2. Neutral parameter for temperature (ECUME_V6 formulation)
+!
+    IF (ZDELTAU10N(JLON) <= ZUTT) THEN
+      ZPARTN(JLON) = ZCOEFT(0) + ZCOEFT(1)*ZDELTAU10N(JLON)      &
+                               + ZCOEFT(2)*ZDELTAU10N(JLON)**2   &
+                               + ZCOEFT(3)*ZDELTAU10N(JLON)**3   &
+                               + ZCOEFT(4)*ZDELTAU10N(JLON)**4
+    ELSE
+      ZPARTN(JLON) = ZCDIRT*(ZDELTAU10N(JLON)-ZUTT) + ZORDOT
+    ENDIF
+!
+!       3.3. Neutral parameter for humidity (ECUME_V6 formulation)
+!
+    IF (ZDELTAU10N(JLON) <= ZUTQ) THEN
+      ZPARQN(JLON) = ZCOEFQ(0) + ZCOEFQ(1)*ZDELTAU10N(JLON)      &
+                               + ZCOEFQ(2)*ZDELTAU10N(JLON)**2
+    ELSE
+      ZPARQN(JLON) = ZCDIRQ*(ZDELTAU10N(JLON)-ZUTQ) + ZORDOQ
+    ENDIF
+!
+!       3.4. Scaling parameters U*, T*, Q*
+!
+    ZUSR(JLON) = ZPARUN(JLON)
+    ZTSR(JLON) = ZPARTN(JLON)*ZDELTAT10N(JLON)/ZDELTAU10N(JLON)
+    ZQSR(JLON) = ZPARQN(JLON)*ZDELTAQ10N(JLON)/ZDELTAU10N(JLON)
+!
+!       3.4b Gustiness factor (Deardorff 1970)
+!
+!       3.4c Cool skin correction
+!
+!       3.5. Obukhovs stability param. z/l following Liu et al. (JAS, 1979)
+!
+! For U
+    ZLMOU = PUREF(JLON)*XG*XKARMAN*(ZTSR(JLON)/PTA(JLON)   &
+            +ZETV*ZQSR(JLON)/(1.0+ZETV*PQA(JLON)))/ZUSR(JLON)**2
+! For T/Q
+    ZLMOT = ZLMOU*(PZREF(JLON)/PUREF(JLON))
+    ZLMOU = MAX(MIN(ZLMOU,ZLMOMAX),ZLMOMIN)
+    ZLMOT = MAX(MIN(ZLMOT,ZLMOMAX),ZLMOMIN)
+!
+!       3.6. Stability function psi (see Liu et al, 1979 ; Dyer and Hicks, 1970)
+!            Modified to include convective form following Fairall (unpublished)
+!
+! For U
+    IF (ZLMOU == 0.0) THEN
+      ZPSI_U = 0.0
+    ELSEIF (ZLMOU > 0.0) THEN
+      ZPSI_U = -ZGMA*ZLMOU
+    ELSE
+      ZCHIK  = (1.0-ZBTA*ZLMOU)**0.25
+      ZPSIK  = 2.0*LOG((1.0+ZCHIK)/2.0)  &
+                +LOG((1.0+ZCHIK**2)/2.0) &
+                -2.0*ATAN(ZCHIK)+0.5*XPI
+      ZCHIC  = (1.0-12.87*ZLMOU)**(1.0/3.0)       !for very unstable conditions
+      ZPSIC  = 1.5*LOG((ZCHIC**2+ZCHIC+1.0)/3.0)   &
+                -ZSQR3*ATAN((2.0*ZCHIC+1.0)/ZSQR3) &
+                +XPI/ZSQR3
+      ZPSI_U = ZPSIC+(ZPSIK-ZPSIC)/(1.0+ZLMOU**2) !match Kansas & free-conv. forms
+    ENDIF
+    ZPSIU(JLON) = ZPSI_U
+! For T/Q
+    IF (ZLMOT == 0.0) THEN
+      ZPSI_T = 0.0
+    ELSEIF (ZLMOT > 0.0) THEN
+      ZPSI_T = -ZGMA*ZLMOT
+    ELSE
+      ZCHIK  = (1.0-ZBTA*ZLMOT)**0.25
+      ZPSIK  = 2.0*LOG((1.0+ZCHIK**2)/2.0)
+      ZCHIC  = (1.0-12.87*ZLMOT)**(1.0/3.0)       !for very unstable conditions
+      ZPSIC  = 1.5*LOG((ZCHIC**2+ZCHIC+1.0)/3.0)   &
+                -ZSQR3*ATAN((2.0*ZCHIC+1.0)/ZSQR3) &
+                +XPI/ZSQR3
+      ZPSI_T = ZPSIC+(ZPSIK-ZPSIC)/(1.0+ZLMOT**2) !match Kansas & free-conv. forms
+    ENDIF
+    ZPSIT(JLON) = ZPSI_T
+!
+!       3.7. Update air-sea gradients
+!
+    ZDDU(JLON) = ZDU(JLON)
+    ZDDT(JLON) = ZDT(JLON)
+    ZDDQ(JLON) = ZDQ(JLON)
+    ZDDU(JLON) = SIGN(MAX(ABS(ZDDU(JLON)),10.0*ZDUSR0),ZDDU(JLON))
+    ZDDT(JLON) = SIGN(MAX(ABS(ZDDT(JLON)),10.0*ZDTSR0),ZDDT(JLON))
+    ZDDQ(JLON) = SIGN(MAX(ABS(ZDDQ(JLON)),10.0*ZDQSR0),ZDDQ(JLON))
+    ZLOGUS10   = LOG(PUREF(JLON)/10.0)
+    ZLOGTS10   = LOG(PZREF(JLON)/10.0)
+    ZDELTAU10N(JLON) = ZDDU(JLON)-ZUSR(JLON)*(ZLOGUS10-ZPSI_U)/XKARMAN
+    ZDELTAT10N(JLON) = ZDDT(JLON)-ZTSR(JLON)*(ZLOGTS10-ZPSI_T)/XKARMAN
+    ZDELTAQ10N(JLON) = ZDDQ(JLON)-ZQSR(JLON)*(ZLOGTS10-ZPSI_T)/XKARMAN
+    ZDELTAU10N(JLON) = SIGN(MAX(ABS(ZDELTAU10N(JLON)),10.0*ZDUSR0),   &
+                            ZDELTAU10N(JLON))
+    ZDELTAT10N(JLON) = SIGN(MAX(ABS(ZDELTAT10N(JLON)),10.0*ZDTSR0),   &
+                            ZDELTAT10N(JLON))
+    ZDELTAQ10N(JLON) = SIGN(MAX(ABS(ZDELTAQ10N(JLON)),10.0*ZDQSR0),   &
+                            ZDELTAQ10N(JLON))
+!
+!       3.8. Test convergence for U*, T*, Q*
+!
+    IF (ABS(ZUSR(JLON)-ZUSR0(JLON)) < ZDUSR0 .AND.   &
+        ABS(ZTSR(JLON)-ZTSR0(JLON)) < ZDTSR0 .AND.   &
+        ABS(ZQSR(JLON)-ZQSR0(JLON)) < ZDQSR0) THEN
+      JCV(JLON) = 1                                     !free convergence
+      IF (JJ >= NITERMAX+1) JCV(JLON) = 2               !leaded convergence
+    ENDIF
+    JITER(JLON) = JJ
+  ENDIF
+!
+  ENDDO
+ENDDO
+!
+!-------------------------------------------------------------------------------
+!
+!       4.   COMPUTATION OF TURBULENT FLUXES AND EXCHANGE COEFFICIENTS.
+!       ---------------------------------------------------------------
+!
+DO JLON=1,SIZE(PTA)
+!
+!       4.1. Surface turbulent fluxes
+!            (ATM CONV.: ZTAU<<0 ; ZHF,ZEF<0 if atm looses heat)
+!
+  ZTAU(JLON) = -PRHOA(JLON)*ZUSR(JLON)**2
+  ZHF(JLON)  = -PRHOA(JLON)*ZCPA(JLON)*ZUSR(JLON)*ZTSR(JLON)
+  ZEF(JLON)  = -PRHOA(JLON)*ZLVS(JLON)*ZUSR(JLON)*ZQSR(JLON)
+
+  write(*,*) "ZTAU = ",ZTAU(JLON)
+  write(*,*) "SENS = ",ZHF(JLON)
+  write(*,*) "LAT = ",ZEF(JLON)
+
+!
+!       4.2. Exchange coefficients PCD, PCH, PCE
+!
+  PCD(JLON) = (ZUSR(JLON)/ZDDU(JLON))**2
+  PCH(JLON) = (ZUSR(JLON)*ZTSR(JLON))/(ZDDU(JLON)*ZDDT(JLON))
+  PCE(JLON) = (ZUSR(JLON)*ZQSR(JLON))/(ZDDU(JLON)*ZDDQ(JLON))
+
+  write(*,*) "ZUSR = ",ZUSR(JLON)
+  write(*,*) "ZTSR = ",ZTSR(JLON)
+  write(*,*) "ZQSR = ",ZQSR(JLON)
+
+!
+!       4.3. Stochastic perturbation of turbulent fluxes
+!
+!  IF( OPERTFLUX )THEN
+!    ZTAU(JLON) = ZTAU(JLON)* ( 1. + PPERTFLUX(JLON) / 2. )
+!    ZHF (JLON) = ZHF(JLON)*  ( 1. + PPERTFLUX(JLON) / 2. )
+!    ZEF (JLON) = ZEF(JLON)*  ( 1. + PPERTFLUX(JLON) / 2. )
+!  ENDIF
+!
+ENDDO
+!
+!-------------------------------------------------------------------------------
+!
+!       5.   COMPUTATION OF FLUX CORRECTIONS DUE TO RAINFALL.
+!            (ATM conv: ZRF<0 if atm. looses heat, ZTAUR<<0)
+!       -----------------------------------------------------
+!
+IF (OPRECIP) THEN
+  DO JLON=1,SIZE(PTA)
+!
+!       5.1. Momentum flux due to rainfall (ZTAUR, N/m2)
+!
+! See pp3752 in FBR96.
+    ZTAUR(JLON) = -0.85*PRAIN(JLON)*PVMOD(JLON)
+!
+!       5.2. Sensible heat flux due to rainfall (ZRF, W/m2)
+!
+! See Eq.12 in GoF95 with ZCPWA as specific heat of water at atm level (J/kg/K),
+! ZDQSDT from Clausius-Clapeyron relation, ZDWAT as water vapor diffusivity 
+! (Eq.13-3 of Pruppacher and Klett, 1978), ZDTMP as heat diffusivity, and ZBULB
+! as wet-bulb factor (Eq.11 in GoF95).
+!
+    ZTAC   = PTA(JLON)-XTT
+    ZCPWA  = 4217.51 -3.65566*ZTAC +0.1381*ZTAC**2       &
+              -2.8309E-03*ZTAC**3 +3.42061E-05*ZTAC**4   &
+              -2.18107E-07*ZTAC**5 +5.74535E-10*ZTAC**6
+    ZDQSDT = (ZLVA(JLON)*ZQSATA(JLON))/(XRV*PTA(JLON)**2)
+    ZDWAT  = 2.11E-05*(ZP00/PPA(JLON))*(PTA(JLON)/XTT)**1.94
+    ZDTMP  = (1.0+3.309E-03*ZTAC-1.44E-06*ZTAC**2)   &
+              *0.02411/(PRHOA(JLON)*ZCPA(JLON))
+    ZBULB  = 1.0/(1.0+ZDQSDT*(ZLVA(JLON)*ZDWAT)/(ZCPA(JLON)*ZDTMP))
+    ZRF(JLON) = PRAIN(JLON)*ZCPWA*ZBULB*((PSST(JLON)-PTA(JLON))   &
+                +(PQSATA(JLON)-PQA(JLON))*(ZLVA(JLON)*ZDWAT)/(ZCPA(JLON)*ZDTMP))
+!
+  ENDDO
+ENDIF
+!
+!-------------------------------------------------------------------------------
+!
+!       6.   COMPUTATION OF WEBB CORRECTION TO LATENT HEAT FLUX (ZEFWEBB, W/m2).
+!       ------------------------------------------------------------------------
+!
+! See Eq.21 and Eq.22 in FBR96.
+IF (OPWEBB) THEN
+  DO JLON=1,SIZE(PTA)
+    ZWW = (1.0+ZETV)*(ZUSR(JLON)*ZQSR(JLON))   &
+           +(1.0+(1.0+ZETV)*PQA(JLON))*(ZUSR(JLON)*ZTSR(JLON))/PTA(JLON)
+    ZEFWEBB(JLON) = -PRHOA(JLON)*ZLVS(JLON)*ZWW*PQA(JLON)
+  ENDDO
+ENDIF
+!
+!-------------------------------------------------------------------------------
+!
+!       7.   FINAL STEP : TOTAL SURFACE FLUXES AND DERIVED DIAGNOSTICS. 
+!       ---------------------------------------------------------------
+!
+!       7.1. Richardson number
+!
+! CALL SURFACE_RI(PSST,PQSAT,PEXNS,PEXNA,PTA,PQA,   &
+!                PZREF,PUREF,ZDIRCOSZW,PVMOD,PRI)
+!
+!       7.2. Friction velocity which contains correction due to rain
+!
+ZUSTAR2(:) = -(ZTAU(:)+ZTAUR(:))/PRHOA(:)       !>>0 as ZTAU<<0 & ZTAUR<=0
+!
+IF (OPRECIP) THEN
+  PCD(:) = ZUSTAR2(:)/ZDDU(:)**2
+ENDIF
+!
+PUSTAR(:) = SQRT(ZUSTAR2(:))                    !>>0
+!
+!       7.3. Aerodynamical conductance and resistance
+!
+ZAC  (:) = PCH(:)*ZDDU(:)
+PRESA(:) = 1.0/ZAC(:)
+!
+!       7.4. Total surface fluxes
+!
+PSFTH(:) =  ZHF(:)+ZRF(:)
+PSFTQ(:) = (ZEF(:)+ZEFWEBB(:))/ZLVS(:)
+!
+!       7.5. Charnock number
+!
+IF (CCHARNOCK == 'OLD') THEN
+  ZCHARN(:) = XVCHRNK
+ELSE            !modified for moderate wind speed as in COARE3.0
+  ZCHARN(:) = MIN(0.018,MAX(0.011,0.011+(0.007/8.0)*(ZDDU(:)-10.0)))
+ENDIF
+!
+!       7.6. Roughness lengths Z0 and Z0H over sea
+!
+!IF (KZ0 == 0) THEN      ! ARPEGE formulation
+!  PZ0SEA (:) = (ZCHARN(:)/XG)*ZUSTAR2(:) + XVZ0CM*PCD(:)/PCDN(:)
+!  PZ0HSEA(:) = PZ0SEA (:)
+!ELSEIF (KZ0 == 1) THEN  ! Smith (1988) formulation
+!  PZ0SEA (:) = (ZCHARN(:)/XG)*ZUSTAR2(:) + 0.11*ZVISA(:)/PUSTAR(:)
+!  PZ0HSEA(:) = PZ0SEA (:)
+!ELSEIF (KZ0 == 2) THEN  ! Direct computation using the stability functions
+!  DO JLON=1,SIZE(PTA)
+!    PZ0SEA (JLON) = PUREF(JLON)/EXP(XKARMAN*ZDDU(JLON)/PUSTAR(JLON)+ZPSIU(JLON))
+!    Z0TSEA        = PZREF(JLON)/EXP(XKARMAN*ZDDT(JLON)/ZTSR  (JLON)+ZPSIT(JLON))
+!    Z0QSEA        = PZREF(JLON)/EXP(XKARMAN*ZDDQ(JLON)/ZQSR  (JLON)+ZPSIT(JLON))
+!    PZ0HSEA(JLON) = 0.5*(Z0TSEA+Z0QSEA)
+!  ENDDO
+!ENDIF
+
+write(*,*) "JLON ",JLON
+write(*,*) "PTA ",klon,PTA
+write(*,*) "PCD ",SIZE(PCD),PCD
+write(*,*) "PCQ ",SIZE(PCE),PCE
+write(*,*) "PCH ",SIZE(PCH),PCH
+
+coeffs = [PCD,&
+       PCE,&
+       PCH]
+!
+!
+!IF (LHOOK) CALL DR_HOOK('ECUMEV6_FLUX',1,ZHOOK_HANDLE)
+!
+!-------------------------------------------------------------------------------
+   END SUBROUTINE ECUMEV6_FLUX
Index: DZ6/trunk/libf/phylmd/ener_conserv.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/ener_conserv.F90	(revision 5267)
+++ 	(revision )
@@ -1,268 +1,0 @@
-subroutine ener_conserv(klon,klev,pdtphys, &
- &                      puo,pvo,pto,qx,ivap,iliq,isol, &
- &                      pun,pvn,ptn,pqn,pqln,pqsn,dtke,masse,exner,d_t_ec)
-
-!=============================================================
-! Energy conservation
-! Based on the TKE equation
-! The M2 and N2 terms at the origin of TKE production are
-! concerted into heating in the d_t_ec term
-! Option 1 is the standard
-!        101 is for M2 term only
-!        101 for N2 term only
-!         -1 is a previours treatment for kinetic energy only
-!  FH (hourdin@lmd.jussieu.fr), 2013/04/25
-!=============================================================
-
-!=============================================================
-! Declarations
-!=============================================================
-
-! From module
-USE phys_local_var_mod, ONLY : d_u_vdf,d_v_vdf,d_t_vdf,d_u_ajs,d_v_ajs,d_t_ajs, &
- &                             d_u_con,d_v_con,d_t_con,d_t_diss
-USE phys_local_var_mod, ONLY : d_t_eva,d_t_lsc,d_q_eva,d_q_lsc
-USE phys_local_var_mod, ONLY : d_u_oro,d_v_oro,d_u_lif,d_v_lif
-USE phys_local_var_mod, ONLY : du_gwd_hines,dv_gwd_hines,dv_gwd_front,dv_gwd_rando
-USE phys_state_var_mod, ONLY : du_gwd_front,du_gwd_rando
-USE phys_output_var_mod, ONLY : bils_ec,bils_ech,bils_tke,bils_kinetic,bils_enthalp,bils_latent,bils_diss
-USE add_phys_tend_mod, ONLY : fl_cor_ebil 
-USE infotrac_phy, ONLY: nqtot
-
-
-IMPLICIT none
-INCLUDE "YOMCST.h"
-INCLUDE "YOETHF.h"
-INCLUDE "clesphys.h"
-INCLUDE "compbl.h"
-
-! Arguments
-INTEGER, INTENT(IN) :: klon,klev
-REAL, INTENT(IN) :: pdtphys
-REAL, DIMENSION(klon,klev), INTENT(IN)      :: puo,pvo,pto
-REAL, DIMENSION(klon,klev,nqtot), INTENT(IN):: qx
-INTEGER, INTENT(IN)                         :: ivap, iliq, isol
-REAL, DIMENSION(klon,klev), INTENT(IN)      :: pun,pvn,ptn,pqn,pqln,pqsn
-REAL, DIMENSION(klon,klev), INTENT(IN)      :: masse,exner
-REAL, DIMENSION(klon,klev+1), INTENT(IN)    :: dtke
-!
-REAL, DIMENSION(klon,klev), INTENT(OUT)     :: d_t_ec
-
-! Local
-      integer k,i
-REAL, DIMENSION(klon,klev+1) :: fluxu,fluxv,fluxt
-REAL, DIMENSION(klon,klev+1) :: dddu,dddv,dddt
-REAL, DIMENSION(klon,klev) :: d_u,d_v,d_t,zv,zu,d_t_ech, pqo, pql0, pqs0
-REAL ZRCPD
-
-character*80 abort_message
-character*20 :: modname
-
-
-modname='ener_conser'
-d_t_ec(:,:)=0.
-
-IF(ivap == 0) CALL abort_physic (modname,'can''t run without water vapour',1)
-IF(iliq == 0) CALL abort_physic (modname,'can''t run without liquid water',1)
-pqo  = qx(:,:,ivap)
-pql0 = qx(:,:,iliq)
-IF(isol /= 0) pqs0 = qx(:,:,isol)
-
-IF (iflag_ener_conserv==-1) THEN
-!+jld ec_conser
-   DO k = 1, klev
-   DO i = 1, klon
-     IF (fl_cor_ebil .GT. 0) then
-       ZRCPD = RCPD*(1.0+RVTMP2*(pqn(i,k)+pqln(i,k)+pqsn(i,k)))
-     ELSE
-       ZRCPD = RCPD*(1.0+RVTMP2*pqn(i,k))
-     ENDIF
-     d_t_ec(i,k)=0.5/ZRCPD &
- &     *(puo(i,k)**2+pvo(i,k)**2-pun(i,k)**2-pvn(i,k)**2)
-   ENDDO
-   ENDDO
-!-jld ec_conser
-
-
-
-ELSEIF (iflag_ener_conserv>=1) THEN
-
-   IF (iflag_ener_conserv<=2) THEN
-!     print*,'ener_conserv pbl=',iflag_pbl
-      IF (iflag_pbl>=20 .AND. iflag_pbl<=27) THEN !d_t_diss accounts for conserv
-         d_t(:,:)=d_t_ajs(:,:)   ! d_t_ajs = adjust + thermals
-         d_u(:,:)=d_u_ajs(:,:)+d_u_con(:,:)
-         d_v(:,:)=d_v_ajs(:,:)+d_v_con(:,:)
-      ELSE
-         d_t(:,:)=d_t_vdf(:,:)+d_t_ajs(:,:)   ! d_t_ajs = adjust + thermals
-         d_u(:,:)=d_u_vdf(:,:)+d_u_ajs(:,:)+d_u_con(:,:)
-         d_v(:,:)=d_v_vdf(:,:)+d_v_ajs(:,:)+d_v_con(:,:)
-      ENDIF
-   ELSEIF (iflag_ener_conserv==101) THEN
-      d_t(:,:)=0.
-      d_u(:,:)=d_u_vdf(:,:)+d_u_ajs(:,:)+d_u_con(:,:)
-      d_v(:,:)=d_v_vdf(:,:)+d_v_ajs(:,:)+d_v_con(:,:)
-   ELSEIF (iflag_ener_conserv==110) THEN
-      d_t(:,:)=d_t_vdf(:,:)+d_t_ajs(:,:)
-      d_u(:,:)=0.
-      d_v(:,:)=0.
-
-   ELSEIF (iflag_ener_conserv==3) THEN
-      d_t(:,:)=0.
-      d_u(:,:)=0.
-      d_v(:,:)=0.
-   ELSEIF (iflag_ener_conserv==4) THEN
-      d_t(:,:)=0.
-      d_u(:,:)=d_u_vdf(:,:)
-      d_v(:,:)=d_v_vdf(:,:)
-   ELSEIF (iflag_ener_conserv==5) THEN
-      d_t(:,:)=d_t_vdf(:,:)
-      d_u(:,:)=d_u_vdf(:,:)
-      d_v(:,:)=d_v_vdf(:,:)
-   ELSEIF (iflag_ener_conserv==6) THEN
-      d_t(:,:)=d_t_vdf(:,:)
-      d_u(:,:)=d_u_vdf(:,:)+d_u_ajs(:,:)
-      d_v(:,:)=d_v_vdf(:,:)+d_v_ajs(:,:)
-   ELSEIF (iflag_ener_conserv==7) THEN
-      d_t(:,:)=d_t_vdf(:,:)+d_t_ajs(:,:)
-      d_u(:,:)=d_u_vdf(:,:)+d_u_ajs(:,:)
-      d_v(:,:)=d_v_vdf(:,:)+d_v_ajs(:,:)
-   ELSEIF (iflag_ener_conserv==8) THEN
-      d_t(:,:)=d_t_vdf(:,:)
-      d_u(:,:)=d_u_vdf(:,:)+d_u_ajs(:,:)+d_u_con(:,:)
-      d_v(:,:)=d_v_vdf(:,:)+d_v_ajs(:,:)+d_v_con(:,:)
-   ELSEIF (iflag_ener_conserv==9) THEN
-      d_t(:,:)=d_t_vdf(:,:)
-      d_u(:,:)=d_u_vdf(:,:)+d_u_ajs(:,:)+d_u_con(:,:)+d_u_oro(:,:)
-      d_v(:,:)=d_v_vdf(:,:)+d_v_ajs(:,:)+d_v_con(:,:)+d_v_oro(:,:)
-   ELSEIF (iflag_ener_conserv==10) THEN
-      d_t(:,:)=d_t_vdf(:,:)
-      d_u(:,:)=d_u_vdf(:,:)+d_u_ajs(:,:)+d_u_con(:,:)+d_u_oro(:,:)+d_u_lif(:,:)
-      d_v(:,:)=d_v_vdf(:,:)+d_v_ajs(:,:)+d_v_con(:,:)+d_v_oro(:,:)+d_v_lif(:,:)
-   ELSEIF (iflag_ener_conserv==11) THEN
-      d_t(:,:)=d_t_vdf(:,:)
-      d_u(:,:)=d_u_vdf(:,:)+d_u_ajs(:,:)+d_u_con(:,:)+d_u_oro(:,:)+d_u_lif(:,:)
-      d_v(:,:)=d_v_vdf(:,:)+d_v_ajs(:,:)+d_v_con(:,:)+d_v_oro(:,:)+d_v_lif(:,:) 
-      IF (ok_hines) THEN
-         d_u_vdf(:,:)=d_u_vdf(:,:)+du_gwd_hines(:,:)
-         d_v_vdf(:,:)=d_v_vdf(:,:)+dv_gwd_hines(:,:)
-      ENDIF
-      IF (.not. ok_hines .and. ok_gwd_rando) THEN
-         d_u_vdf(:,:)=d_u_vdf(:,:)+du_gwd_front(:,:)
-         d_v_vdf(:,:)=d_v_vdf(:,:)+dv_gwd_front(:,:)
-      ENDIF
-      IF (ok_gwd_rando) THEN
-         d_u_vdf(:,:)=d_u_vdf(:,:)+du_gwd_rando(:,:)
-         d_v_vdf(:,:)=d_v_vdf(:,:)+dv_gwd_rando(:,:)
-      ENDIF
-   ELSE
-      abort_message = 'iflag_ener_conserv non prevu'
-      CALL abort_physic (modname,abort_message,1)
-   ENDIF
-
-!----------------------------------------------------------------------------
-! Two options wether we consider time integration in the energy conservation
-!----------------------------------------------------------------------------
-
-   if (iflag_ener_conserv==2) then
-      zu(:,:)=puo(:,:)
-      zv(:,:)=pvo(:,:)
-   else
-      IF (iflag_pbl>=20 .AND. iflag_pbl<=27) THEN
-         zu(:,:)=puo(:,:)+d_u_vdf(:,:)+0.5*d_u(:,:)
-         zv(:,:)=pvo(:,:)+d_v_vdf(:,:)+0.5*d_v(:,:)
-      ELSE
-         zu(:,:)=puo(:,:)+0.5*d_u(:,:)
-         zv(:,:)=pvo(:,:)+0.5*d_v(:,:)
-      ENDIF
-   endif
-
-   fluxu(:,klev+1)=0.
-   fluxv(:,klev+1)=0.
-   fluxt(:,klev+1)=0.
-
-   do k=klev,1,-1
-      fluxu(:,k)=fluxu(:,k+1)+masse(:,k)*d_u(:,k)
-      fluxv(:,k)=fluxv(:,k+1)+masse(:,k)*d_v(:,k)
-      fluxt(:,k)=fluxt(:,k+1)+masse(:,k)*d_t(:,k)/exner(:,k)
-   enddo
-
-   dddu(:,1)=2*zu(:,1)*fluxu(:,1)
-   dddv(:,1)=2*zv(:,1)*fluxv(:,1)
-   dddt(:,1)=(exner(:,1)-1.)*fluxt(:,1)
-
-   do k=2,klev
-      dddu(:,k)=(zu(:,k)-zu(:,k-1))*fluxu(:,k)
-      dddv(:,k)=(zv(:,k)-zv(:,k-1))*fluxv(:,k)
-      dddt(:,k)=(exner(:,k)-exner(:,k-1))*fluxt(:,k)
-   enddo
-   dddu(:,klev+1)=0.
-   dddv(:,klev+1)=0.
-   dddt(:,klev+1)=0.
-
-   do k=1,klev
-      d_t_ech(:,k)=-(rcpd*(dddt(:,k)+dddt(:,k+1)))/(2.*rcpd*masse(:,k))
-      d_t_ec(:,k)=-(dddu(:,k)+dddu(:,k+1)+dddv(:,k)+dddv(:,k+1))/(2.*rcpd*masse(:,k))+d_t_ech(:,k)
-   enddo
-
-ENDIF
-
-!================================================================
-!  Computation of integrated enthalpie and kinetic energy variation
-!  FH (hourdin@lmd.jussieu.fr), 2013/04/25
-!  bils_ec : energie conservation term
-!  bils_ech : part of this term linked to temperature
-!  bils_tke : change of TKE
-!  bils_diss : dissipation of TKE (when activated)
-!  bils_kinetic : change of kinetic energie of the column
-!  bils_enthalp : change of enthalpie
-!  bils_latent  : change of latent heat. Computed between
-!          after reevaporation (at the beginning of the physics)
-!          and before large scale condensation (fisrtilp)
-!================================================================
-
-      bils_ec(:)=0.
-      bils_ech(:)=0.
-      bils_tke(:)=0.
-      bils_diss(:)=0.
-      bils_kinetic(:)=0.
-      bils_enthalp(:)=0.
-      bils_latent(:)=0.
-      DO k=1,klev
-        bils_ec(:)=bils_ec(:)-d_t_ec(:,k)*masse(:,k)
-        bils_diss(:)=bils_diss(:)-d_t_diss(:,k)*masse(:,k)
-        bils_kinetic(:)=bils_kinetic(:)+masse(:,k)* &
-     &           (pun(:,k)*pun(:,k)+pvn(:,k)*pvn(:,k) &
-     &            -puo(:,k)*puo(:,k)-pvo(:,k)*pvo(:,k))
-        bils_enthalp(:)= &
-     &  bils_enthalp(:)+masse(:,k)*(ptn(:,k)-pto(:,k)+d_t_ec(:,k)-d_t_eva(:,k)-d_t_lsc(:,k))
-!    &  bils_enthalp(:)+masse(:,k)*(ptn(:,k)-pto(:,k)+d_t_ec(:,k))
-        bils_latent(:)=bils_latent(:)+masse(:,k)* &
-!    &             (pqn(:,k)-pqo(:,k))
-     &             (pqn(:,k)-pqo(:,k)-d_q_eva(:,k)-d_q_lsc(:,k))
-      ENDDO
-      bils_ec(:)=rcpd*bils_ec(:)/pdtphys
-      bils_diss(:)=rcpd*bils_diss(:)/pdtphys
-      bils_kinetic(:)= 0.5*bils_kinetic(:)/pdtphys
-      bils_enthalp(:)=rcpd*bils_enthalp(:)/pdtphys
-      bils_latent(:)=rlvtt*bils_latent(:)/pdtphys
-!jyg<
-      IF (iflag_pbl > 1) THEN
-        DO k=1,klev
-          bils_tke(:)=bils_tke(:)+0.5*(dtke(:,k)+dtke(:,k+1))*masse(:,k)
-        ENDDO
-        bils_tke(:)=bils_tke(:)/pdtphys
-      ENDIF  ! (iflag_pbl > 1)
-!>jyg
-
-IF (iflag_ener_conserv>=1) THEN
-      bils_ech(:)=0.
-      DO k=1,klev
-        bils_ech(:)=bils_ech(:)-d_t_ech(:,k)*masse(:,k)
-      ENDDO
-      bils_ech(:)=rcpd*bils_ech(:)/pdtphys
-ENDIF
-
-RETURN
-
-END
Index: /LMDZ6/trunk/libf/phylmd/ener_conserv.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/ener_conserv.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/ener_conserv.f90	(revision 5268)
@@ -0,0 +1,268 @@
+subroutine ener_conserv(klon,klev,pdtphys, &
+ &                      puo,pvo,pto,qx,ivap,iliq,isol, &
+ &                      pun,pvn,ptn,pqn,pqln,pqsn,dtke,masse,exner,d_t_ec)
+
+!=============================================================
+! Energy conservation
+! Based on the TKE equation
+! The M2 and N2 terms at the origin of TKE production are
+! concerted into heating in the d_t_ec term
+! Option 1 is the standard
+!        101 is for M2 term only
+!        101 for N2 term only
+!         -1 is a previours treatment for kinetic energy only
+!  FH (hourdin@lmd.jussieu.fr), 2013/04/25
+!=============================================================
+
+!=============================================================
+! Declarations
+!=============================================================
+
+! From module
+USE phys_local_var_mod, ONLY : d_u_vdf,d_v_vdf,d_t_vdf,d_u_ajs,d_v_ajs,d_t_ajs, &
+ &                             d_u_con,d_v_con,d_t_con,d_t_diss
+USE phys_local_var_mod, ONLY : d_t_eva,d_t_lsc,d_q_eva,d_q_lsc
+USE phys_local_var_mod, ONLY : d_u_oro,d_v_oro,d_u_lif,d_v_lif
+USE phys_local_var_mod, ONLY : du_gwd_hines,dv_gwd_hines,dv_gwd_front,dv_gwd_rando
+USE phys_state_var_mod, ONLY : du_gwd_front,du_gwd_rando
+USE phys_output_var_mod, ONLY : bils_ec,bils_ech,bils_tke,bils_kinetic,bils_enthalp,bils_latent,bils_diss
+USE add_phys_tend_mod, ONLY : fl_cor_ebil 
+USE infotrac_phy, ONLY: nqtot
+
+
+IMPLICIT none
+INCLUDE "YOMCST.h"
+INCLUDE "YOETHF.h"
+INCLUDE "clesphys.h"
+INCLUDE "compbl.h"
+
+! Arguments
+INTEGER, INTENT(IN) :: klon,klev
+REAL, INTENT(IN) :: pdtphys
+REAL, DIMENSION(klon,klev), INTENT(IN)      :: puo,pvo,pto
+REAL, DIMENSION(klon,klev,nqtot), INTENT(IN):: qx
+INTEGER, INTENT(IN)                         :: ivap, iliq, isol
+REAL, DIMENSION(klon,klev), INTENT(IN)      :: pun,pvn,ptn,pqn,pqln,pqsn
+REAL, DIMENSION(klon,klev), INTENT(IN)      :: masse,exner
+REAL, DIMENSION(klon,klev+1), INTENT(IN)    :: dtke
+!
+REAL, DIMENSION(klon,klev), INTENT(OUT)     :: d_t_ec
+
+! Local
+      integer k,i
+REAL, DIMENSION(klon,klev+1) :: fluxu,fluxv,fluxt
+REAL, DIMENSION(klon,klev+1) :: dddu,dddv,dddt
+REAL, DIMENSION(klon,klev) :: d_u,d_v,d_t,zv,zu,d_t_ech, pqo, pql0, pqs0
+REAL ZRCPD
+
+character*80 abort_message
+character*20 :: modname
+
+
+modname='ener_conser'
+d_t_ec(:,:)=0.
+
+IF(ivap == 0) CALL abort_physic (modname,'can''t run without water vapour',1)
+IF(iliq == 0) CALL abort_physic (modname,'can''t run without liquid water',1)
+pqo  = qx(:,:,ivap)
+pql0 = qx(:,:,iliq)
+IF(isol /= 0) pqs0 = qx(:,:,isol)
+
+IF (iflag_ener_conserv==-1) THEN
+!+jld ec_conser
+   DO k = 1, klev
+   DO i = 1, klon
+     IF (fl_cor_ebil .GT. 0) then
+       ZRCPD = RCPD*(1.0+RVTMP2*(pqn(i,k)+pqln(i,k)+pqsn(i,k)))
+     ELSE
+       ZRCPD = RCPD*(1.0+RVTMP2*pqn(i,k))
+     ENDIF
+     d_t_ec(i,k)=0.5/ZRCPD &
+ &     *(puo(i,k)**2+pvo(i,k)**2-pun(i,k)**2-pvn(i,k)**2)
+   ENDDO
+   ENDDO
+!-jld ec_conser
+
+
+
+ELSEIF (iflag_ener_conserv>=1) THEN
+
+   IF (iflag_ener_conserv<=2) THEN
+!     print*,'ener_conserv pbl=',iflag_pbl
+      IF (iflag_pbl>=20 .AND. iflag_pbl<=27) THEN !d_t_diss accounts for conserv
+         d_t(:,:)=d_t_ajs(:,:)   ! d_t_ajs = adjust + thermals
+         d_u(:,:)=d_u_ajs(:,:)+d_u_con(:,:)
+         d_v(:,:)=d_v_ajs(:,:)+d_v_con(:,:)
+      ELSE
+         d_t(:,:)=d_t_vdf(:,:)+d_t_ajs(:,:)   ! d_t_ajs = adjust + thermals
+         d_u(:,:)=d_u_vdf(:,:)+d_u_ajs(:,:)+d_u_con(:,:)
+         d_v(:,:)=d_v_vdf(:,:)+d_v_ajs(:,:)+d_v_con(:,:)
+      ENDIF
+   ELSEIF (iflag_ener_conserv==101) THEN
+      d_t(:,:)=0.
+      d_u(:,:)=d_u_vdf(:,:)+d_u_ajs(:,:)+d_u_con(:,:)
+      d_v(:,:)=d_v_vdf(:,:)+d_v_ajs(:,:)+d_v_con(:,:)
+   ELSEIF (iflag_ener_conserv==110) THEN
+      d_t(:,:)=d_t_vdf(:,:)+d_t_ajs(:,:)
+      d_u(:,:)=0.
+      d_v(:,:)=0.
+
+   ELSEIF (iflag_ener_conserv==3) THEN
+      d_t(:,:)=0.
+      d_u(:,:)=0.
+      d_v(:,:)=0.
+   ELSEIF (iflag_ener_conserv==4) THEN
+      d_t(:,:)=0.
+      d_u(:,:)=d_u_vdf(:,:)
+      d_v(:,:)=d_v_vdf(:,:)
+   ELSEIF (iflag_ener_conserv==5) THEN
+      d_t(:,:)=d_t_vdf(:,:)
+      d_u(:,:)=d_u_vdf(:,:)
+      d_v(:,:)=d_v_vdf(:,:)
+   ELSEIF (iflag_ener_conserv==6) THEN
+      d_t(:,:)=d_t_vdf(:,:)
+      d_u(:,:)=d_u_vdf(:,:)+d_u_ajs(:,:)
+      d_v(:,:)=d_v_vdf(:,:)+d_v_ajs(:,:)
+   ELSEIF (iflag_ener_conserv==7) THEN
+      d_t(:,:)=d_t_vdf(:,:)+d_t_ajs(:,:)
+      d_u(:,:)=d_u_vdf(:,:)+d_u_ajs(:,:)
+      d_v(:,:)=d_v_vdf(:,:)+d_v_ajs(:,:)
+   ELSEIF (iflag_ener_conserv==8) THEN
+      d_t(:,:)=d_t_vdf(:,:)
+      d_u(:,:)=d_u_vdf(:,:)+d_u_ajs(:,:)+d_u_con(:,:)
+      d_v(:,:)=d_v_vdf(:,:)+d_v_ajs(:,:)+d_v_con(:,:)
+   ELSEIF (iflag_ener_conserv==9) THEN
+      d_t(:,:)=d_t_vdf(:,:)
+      d_u(:,:)=d_u_vdf(:,:)+d_u_ajs(:,:)+d_u_con(:,:)+d_u_oro(:,:)
+      d_v(:,:)=d_v_vdf(:,:)+d_v_ajs(:,:)+d_v_con(:,:)+d_v_oro(:,:)
+   ELSEIF (iflag_ener_conserv==10) THEN
+      d_t(:,:)=d_t_vdf(:,:)
+      d_u(:,:)=d_u_vdf(:,:)+d_u_ajs(:,:)+d_u_con(:,:)+d_u_oro(:,:)+d_u_lif(:,:)
+      d_v(:,:)=d_v_vdf(:,:)+d_v_ajs(:,:)+d_v_con(:,:)+d_v_oro(:,:)+d_v_lif(:,:)
+   ELSEIF (iflag_ener_conserv==11) THEN
+      d_t(:,:)=d_t_vdf(:,:)
+      d_u(:,:)=d_u_vdf(:,:)+d_u_ajs(:,:)+d_u_con(:,:)+d_u_oro(:,:)+d_u_lif(:,:)
+      d_v(:,:)=d_v_vdf(:,:)+d_v_ajs(:,:)+d_v_con(:,:)+d_v_oro(:,:)+d_v_lif(:,:) 
+      IF (ok_hines) THEN
+         d_u_vdf(:,:)=d_u_vdf(:,:)+du_gwd_hines(:,:)
+         d_v_vdf(:,:)=d_v_vdf(:,:)+dv_gwd_hines(:,:)
+      ENDIF
+      IF (.not. ok_hines .and. ok_gwd_rando) THEN
+         d_u_vdf(:,:)=d_u_vdf(:,:)+du_gwd_front(:,:)
+         d_v_vdf(:,:)=d_v_vdf(:,:)+dv_gwd_front(:,:)
+      ENDIF
+      IF (ok_gwd_rando) THEN
+         d_u_vdf(:,:)=d_u_vdf(:,:)+du_gwd_rando(:,:)
+         d_v_vdf(:,:)=d_v_vdf(:,:)+dv_gwd_rando(:,:)
+      ENDIF
+   ELSE
+      abort_message = 'iflag_ener_conserv non prevu'
+      CALL abort_physic (modname,abort_message,1)
+   ENDIF
+
+!----------------------------------------------------------------------------
+! Two options wether we consider time integration in the energy conservation
+!----------------------------------------------------------------------------
+
+   if (iflag_ener_conserv==2) then
+      zu(:,:)=puo(:,:)
+      zv(:,:)=pvo(:,:)
+   else
+      IF (iflag_pbl>=20 .AND. iflag_pbl<=27) THEN
+         zu(:,:)=puo(:,:)+d_u_vdf(:,:)+0.5*d_u(:,:)
+         zv(:,:)=pvo(:,:)+d_v_vdf(:,:)+0.5*d_v(:,:)
+      ELSE
+         zu(:,:)=puo(:,:)+0.5*d_u(:,:)
+         zv(:,:)=pvo(:,:)+0.5*d_v(:,:)
+      ENDIF
+   endif
+
+   fluxu(:,klev+1)=0.
+   fluxv(:,klev+1)=0.
+   fluxt(:,klev+1)=0.
+
+   do k=klev,1,-1
+      fluxu(:,k)=fluxu(:,k+1)+masse(:,k)*d_u(:,k)
+      fluxv(:,k)=fluxv(:,k+1)+masse(:,k)*d_v(:,k)
+      fluxt(:,k)=fluxt(:,k+1)+masse(:,k)*d_t(:,k)/exner(:,k)
+   enddo
+
+   dddu(:,1)=2*zu(:,1)*fluxu(:,1)
+   dddv(:,1)=2*zv(:,1)*fluxv(:,1)
+   dddt(:,1)=(exner(:,1)-1.)*fluxt(:,1)
+
+   do k=2,klev
+      dddu(:,k)=(zu(:,k)-zu(:,k-1))*fluxu(:,k)
+      dddv(:,k)=(zv(:,k)-zv(:,k-1))*fluxv(:,k)
+      dddt(:,k)=(exner(:,k)-exner(:,k-1))*fluxt(:,k)
+   enddo
+   dddu(:,klev+1)=0.
+   dddv(:,klev+1)=0.
+   dddt(:,klev+1)=0.
+
+   do k=1,klev
+      d_t_ech(:,k)=-(rcpd*(dddt(:,k)+dddt(:,k+1)))/(2.*rcpd*masse(:,k))
+      d_t_ec(:,k)=-(dddu(:,k)+dddu(:,k+1)+dddv(:,k)+dddv(:,k+1))/(2.*rcpd*masse(:,k))+d_t_ech(:,k)
+   enddo
+
+ENDIF
+
+!================================================================
+!  Computation of integrated enthalpie and kinetic energy variation
+!  FH (hourdin@lmd.jussieu.fr), 2013/04/25
+!  bils_ec : energie conservation term
+!  bils_ech : part of this term linked to temperature
+!  bils_tke : change of TKE
+!  bils_diss : dissipation of TKE (when activated)
+!  bils_kinetic : change of kinetic energie of the column
+!  bils_enthalp : change of enthalpie
+!  bils_latent  : change of latent heat. Computed between
+!          after reevaporation (at the beginning of the physics)
+!          and before large scale condensation (fisrtilp)
+!================================================================
+
+      bils_ec(:)=0.
+      bils_ech(:)=0.
+      bils_tke(:)=0.
+      bils_diss(:)=0.
+      bils_kinetic(:)=0.
+      bils_enthalp(:)=0.
+      bils_latent(:)=0.
+      DO k=1,klev
+        bils_ec(:)=bils_ec(:)-d_t_ec(:,k)*masse(:,k)
+        bils_diss(:)=bils_diss(:)-d_t_diss(:,k)*masse(:,k)
+        bils_kinetic(:)=bils_kinetic(:)+masse(:,k)* &
+     &           (pun(:,k)*pun(:,k)+pvn(:,k)*pvn(:,k) &
+     &            -puo(:,k)*puo(:,k)-pvo(:,k)*pvo(:,k))
+        bils_enthalp(:)= &
+     &  bils_enthalp(:)+masse(:,k)*(ptn(:,k)-pto(:,k)+d_t_ec(:,k)-d_t_eva(:,k)-d_t_lsc(:,k))
+!    &  bils_enthalp(:)+masse(:,k)*(ptn(:,k)-pto(:,k)+d_t_ec(:,k))
+        bils_latent(:)=bils_latent(:)+masse(:,k)* &
+!    &             (pqn(:,k)-pqo(:,k))
+     &             (pqn(:,k)-pqo(:,k)-d_q_eva(:,k)-d_q_lsc(:,k))
+      ENDDO
+      bils_ec(:)=rcpd*bils_ec(:)/pdtphys
+      bils_diss(:)=rcpd*bils_diss(:)/pdtphys
+      bils_kinetic(:)= 0.5*bils_kinetic(:)/pdtphys
+      bils_enthalp(:)=rcpd*bils_enthalp(:)/pdtphys
+      bils_latent(:)=rlvtt*bils_latent(:)/pdtphys
+!jyg<
+      IF (iflag_pbl > 1) THEN
+        DO k=1,klev
+          bils_tke(:)=bils_tke(:)+0.5*(dtke(:,k)+dtke(:,k+1))*masse(:,k)
+        ENDDO
+        bils_tke(:)=bils_tke(:)/pdtphys
+      ENDIF  ! (iflag_pbl > 1)
+!>jyg
+
+IF (iflag_ener_conserv>=1) THEN
+      bils_ech(:)=0.
+      DO k=1,klev
+        bils_ech(:)=bils_ech(:)-d_t_ech(:,k)*masse(:,k)
+      ENDDO
+      bils_ech(:)=rcpd*bils_ech(:)/pdtphys
+ENDIF
+
+RETURN
+
+END
Index: DZ6/trunk/libf/phylmd/evappot.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/evappot.F90	(revision 5267)
+++ 	(revision )
@@ -1,42 +1,0 @@
-SUBROUTINE evappot(klon,nbsrf,ftsol,pplay,cdragh,  &
-       &    t_seri,q_seri,u_seri,v_seri,evap_pot)
-
-IMPLICIT NONE
-
-INCLUDE "YOMCST.h"
-INCLUDE "YOETHF.h"
-INCLUDE "FCTTRE.h"
-
-
-INTEGER :: klon, nbsrf
-REAL, DIMENSION(klon,nbsrf) :: ftsol,evap_pot
-REAL, DIMENSION(klon) :: pplay,t_seri,wind,q_seri,u_seri,v_seri,cdragh
-
-INTEGER :: nsrf,i
-REAL, DIMENSION(klon,nbsrf) :: qsat_ftsol
-REAL, DIMENSION(klon) :: rhos, norme_u
-REAL :: t_coup
-
-      t_coup=234.   ! Quelle horreur !!!!!
-
-DO nsrf = 1, nbsrf
-   DO i = 1, klon
-      IF (ftsol(i,nsrf).LT.t_coup) THEN
-         qsat_ftsol(i,nsrf) = qsats(ftsol(i,nsrf))/pplay(i)
-      ELSE
-         qsat_ftsol(i,nsrf) = qsatl(ftsol(i,nsrf))/pplay(i)
-      ENDIF
-   ENDDO
-ENDDO
-! ========================================================== c
-! Calcul de l'evaporation Potentielle
-
-
-rhos(:) = pplay(:)/(RD*t_seri(:))
-norme_u(:)=1.+sqrt(u_seri(:)*u_seri(:)+v_seri(:)*v_seri(:))
-DO nsrf = 1, nbsrf
-  evap_pot(:,nsrf)=rhos(:)*cdragh(:)*norme_u(:)*(qsat_ftsol(:,nsrf)-q_seri(:))
-ENDDO
-RETURN
-
-END
Index: /LMDZ6/trunk/libf/phylmd/evappot.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/evappot.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/evappot.f90	(revision 5268)
@@ -0,0 +1,42 @@
+SUBROUTINE evappot(klon,nbsrf,ftsol,pplay,cdragh,  &
+       &    t_seri,q_seri,u_seri,v_seri,evap_pot)
+
+IMPLICIT NONE
+
+INCLUDE "YOMCST.h"
+INCLUDE "YOETHF.h"
+INCLUDE "FCTTRE.h"
+
+
+INTEGER :: klon, nbsrf
+REAL, DIMENSION(klon,nbsrf) :: ftsol,evap_pot
+REAL, DIMENSION(klon) :: pplay,t_seri,wind,q_seri,u_seri,v_seri,cdragh
+
+INTEGER :: nsrf,i
+REAL, DIMENSION(klon,nbsrf) :: qsat_ftsol
+REAL, DIMENSION(klon) :: rhos, norme_u
+REAL :: t_coup
+
+      t_coup=234.   ! Quelle horreur !!!!!
+
+DO nsrf = 1, nbsrf
+   DO i = 1, klon
+      IF (ftsol(i,nsrf).LT.t_coup) THEN
+         qsat_ftsol(i,nsrf) = qsats(ftsol(i,nsrf))/pplay(i)
+      ELSE
+         qsat_ftsol(i,nsrf) = qsatl(ftsol(i,nsrf))/pplay(i)
+      ENDIF
+   ENDDO
+ENDDO
+! ========================================================== c
+! Calcul de l'evaporation Potentielle
+
+
+rhos(:) = pplay(:)/(RD*t_seri(:))
+norme_u(:)=1.+sqrt(u_seri(:)*u_seri(:)+v_seri(:)*v_seri(:))
+DO nsrf = 1, nbsrf
+  evap_pot(:,nsrf)=rhos(:)*cdragh(:)*norme_u(:)*(qsat_ftsol(:,nsrf)-q_seri(:))
+ENDDO
+RETURN
+
+END
Index: DZ6/trunk/libf/phylmd/fisrtilp_tr.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/fisrtilp_tr.F90	(revision 5267)
+++ 	(revision )
@@ -1,429 +1,0 @@
-
-! $Id$
-
-
-SUBROUTINE fisrtilp_tr(dtime, paprs, pplay, t, q, ratqs, d_t, d_q, d_ql, &
-    rneb, radliq, rain, snow, pfrac_impa, pfrac_nucl, pfrac_1nucl, frac_impa, &
-    frac_nucl, prfl, psfl, rhcl) ! relative humidity in clear sky (needed for aer optical
-  ! properties; aeropt.F)
-
-
-  USE dimphy
-  USE print_control_mod, ONLY: lunout
-  IMPLICIT NONE
-  ! ======================================================================
-  ! Auteur(s): Z.X. Li (LMD/CNRS)
-  ! Date: le 20 mars 1995
-  ! Objet: condensation et precipitation stratiforme.
-  ! schema de nuage
-  ! ======================================================================
-  ! ======================================================================
-  include "YOMCST.h"
-
-  ! Arguments:
-
-  REAL dtime ! intervalle du temps (s)
-  REAL paprs(klon, klev+1) ! pression a inter-couche
-  REAL pplay(klon, klev) ! pression au milieu de couche
-  REAL t(klon, klev) ! temperature (K)
-  REAL q(klon, klev) ! humidite specifique (kg/kg)
-  REAL d_t(klon, klev) ! incrementation de la temperature (K)
-  REAL d_q(klon, klev) ! incrementation de la vapeur d'eau
-  REAL d_ql(klon, klev) ! incrementation de l'eau liquide
-  REAL rneb(klon, klev) ! fraction nuageuse
-  REAL radliq(klon, klev) ! eau liquide utilisee dans rayonnements
-  REAL rain(klon) ! pluies (mm/s)
-  REAL snow(klon) ! neige (mm/s)
-  REAL prfl(klon, klev+1) ! flux d'eau precipitante aux interfaces (kg/m2/s)
-  REAL psfl(klon, klev+1) ! flux d'eau precipitante aux interfaces (kg/m2/s)
-
-  ! jq   For aerosol opt properties needed (see aeropt.F)
-  REAL rhcl(klon, klev)
-
-  ! AA
-  ! Coeffients de fraction lessivee : pour OFF-LINE
-
-  REAL pfrac_nucl(klon, klev)
-  REAL pfrac_1nucl(klon, klev)
-  REAL pfrac_impa(klon, klev)
-
-  ! Fraction d'aerosols lessivee par impaction et par nucleation
-  ! POur ON-LINE
-
-  REAL frac_impa(klon, klev)
-  REAL frac_nucl(klon, klev)
-  ! AA
-
-  ! Options du programme:
-
-  REAL seuil_neb ! un nuage existe vraiment au-dela
-  PARAMETER (seuil_neb=0.001)
-  REAL ct ! inverse du temps pour qu'un nuage precipite
-  PARAMETER (ct=1./1800.)
-  REAL cl ! seuil de precipitation
-  PARAMETER (cl=2.6E-4)
-  ! cc      PARAMETER (cl=2.3e-4)
-  ! cc      PARAMETER (cl=2.0e-4)
-  INTEGER ninter ! sous-intervals pour la precipitation
-  PARAMETER (ninter=5)
-  LOGICAL evap_prec ! evaporation de la pluie
-  PARAMETER (evap_prec=.TRUE.)
-  REAL coef_eva
-  PARAMETER (coef_eva=2.0E-05)
-  LOGICAL calcrat ! calculer ratqs au lieu de fixer sa valeur
-  REAL ratqs(klon, klev) ! determine la largeur de distribution de vapeur
-  PARAMETER (calcrat=.TRUE.)
-  REAL zx_min, rat_max
-  PARAMETER (zx_min=1.0, rat_max=0.01)
-  REAL zx_max, rat_min
-  PARAMETER (zx_max=0.1, rat_min=0.3)
-  REAL zx
-
-  LOGICAL cpartiel ! condensation partielle
-  PARAMETER (cpartiel=.TRUE.)
-  REAL t_coup
-  PARAMETER (t_coup=234.0)
-
-  ! Variables locales:
-
-  INTEGER i, k, n, kk
-  REAL zqs(klon), zdqs(klon), zdelta, zcor, zcvm5
-  REAL zrfl(klon), zrfln(klon), zqev, zqevt
-  REAL zoliq(klon), zcond(klon), zq(klon), zqn(klon), zdelq
-  REAL ztglace, zt(klon)
-  INTEGER nexpo ! exponentiel pour glace/eau
-  REAL zdz(klon), zrho(klon), ztot(klon), zrhol(klon)
-  REAL zchau(klon), zfroi(klon), zfice(klon), zneb(klon)
-
-  LOGICAL appel1er
-  SAVE appel1er
-  !$OMP THREADPRIVATE(appel1er)
-
-  ! ---------------------------------------------------------------
-
-  ! AA Variables traceurs:
-  ! AA  Provisoire !!! Parametres alpha du lessivage
-  ! AA  A priori on a 4 scavenging # possibles
-
-  REAL a_tr_sca(4)
-  SAVE a_tr_sca
-  !$OMP THREADPRIVATE(a_tr_sca)
-
-  ! Variables intermediaires
-
-  REAL zalpha_tr
-  REAL zfrac_lessi
-  REAL zprec_cond(klon)
-  ! AA
-  ! ---------------------------------------------------------------
-
-  ! Fonctions en ligne:
-
-  REAL fallv ! vitesse de chute pour crystaux de glace
-  REAL zzz
-  include "YOETHF.h"
-  include "FCTTRE.h"
-  fallv(zzz) = 3.29/2.0*((zzz)**0.16)
-  ! cc      fallv (zzz) = 3.29/3.0 * ((zzz)**0.16)
-  ! cc      fallv (zzz) = 3.29 * ((zzz)**0.16)
-
-  DATA appel1er/.TRUE./
-
-  IF (appel1er) THEN
-
-    WRITE (lunout, *) 'fisrtilp, calcrat:', calcrat
-    WRITE (lunout, *) 'fisrtilp, ninter:', ninter
-    WRITE (lunout, *) 'fisrtilp, evap_prec:', evap_prec
-    WRITE (lunout, *) 'fisrtilp, cpartiel:', cpartiel
-    IF (abs(dtime/real(ninter)-360.0)>0.001) THEN
-      WRITE (lunout, *) 'fisrtilp: Ce n est pas prevu, voir Z.X.Li', dtime
-      WRITE (lunout, *) 'Je prefere un sous-intervalle de 6 minutes'
-      CALL abort
-    END IF
-    appel1er = .FALSE.
-
-    ! AA initialiation provisoire
-    a_tr_sca(1) = -0.5
-    a_tr_sca(2) = -0.5
-    a_tr_sca(3) = -0.5
-    a_tr_sca(4) = -0.5
-
-    ! AA Initialisation a 1 des coefs des fractions lessivees
-
-    DO k = 1, klev
-      DO i = 1, klon
-        pfrac_nucl(i, k) = 1.
-        pfrac_1nucl(i, k) = 1.
-        pfrac_impa(i, k) = 1.
-      END DO
-    END DO
-
-  END IF !  test sur appel1er
-
-  ! MAf Initialisation a 0 de zoliq
-  DO i = 1, klon
-    zoliq(i) = 0.
-  END DO
-  ! Determiner les nuages froids par leur temperature
-
-  ztglace = rtt - 15.0
-  nexpo = 6
-  ! cc      nexpo = 1
-
-  ! Initialiser les sorties:
-
-  DO k = 1, klev + 1
-    DO i = 1, klon
-      prfl(i, k) = 0.0
-      psfl(i, k) = 0.0
-    END DO
-  END DO
-
-  DO k = 1, klev
-    DO i = 1, klon
-      d_t(i, k) = 0.0
-      d_q(i, k) = 0.0
-      d_ql(i, k) = 0.0
-      rneb(i, k) = 0.0
-      radliq(i, k) = 0.0
-      frac_nucl(i, k) = 1.
-      frac_impa(i, k) = 1.
-    END DO
-  END DO
-  DO i = 1, klon
-    rain(i) = 0.0
-    snow(i) = 0.0
-  END DO
-
-  ! Initialiser le flux de precipitation a zero
-
-  DO i = 1, klon
-    zrfl(i) = 0.0
-    zneb(i) = seuil_neb
-  END DO
-
-
-  ! AA Pour plus de securite
-
-  zalpha_tr = 0.
-  zfrac_lessi = 0.
-
-  ! AA----------------------------------------------------------
-
-  ! Boucle verticale (du haut vers le bas)
-
-  DO k = klev, 1, -1
-
-    ! AA----------------------------------------------------------
-
-    DO i = 1, klon
-      zt(i) = t(i, k)
-      zq(i) = q(i, k)
-    END DO
-
-    ! Calculer l'evaporation de la precipitation
-
-    IF (evap_prec) THEN
-      DO i = 1, klon
-        IF (zrfl(i)>0.) THEN
-          IF (thermcep) THEN
-            zdelta = max(0., sign(1.,rtt-zt(i)))
-            zqs(i) = r2es*foeew(zt(i), zdelta)/pplay(i, k)
-            zqs(i) = min(0.5, zqs(i))
-            zcor = 1./(1.-retv*zqs(i))
-            zqs(i) = zqs(i)*zcor
-          ELSE
-            IF (zt(i)<t_coup) THEN
-              zqs(i) = qsats(zt(i))/pplay(i, k)
-            ELSE
-              zqs(i) = qsatl(zt(i))/pplay(i, k)
-            END IF
-          END IF
-          zqev = max(0.0, (zqs(i)-zq(i))*zneb(i))
-          zqevt = coef_eva*(1.0-zq(i)/zqs(i))*sqrt(zrfl(i))* &
-            (paprs(i,k)-paprs(i,k+1))/pplay(i, k)*zt(i)*rd/rg
-          zqevt = max(0.0, min(zqevt,zrfl(i)))*rg*dtime/ &
-            (paprs(i,k)-paprs(i,k+1))
-          zqev = min(zqev, zqevt)
-          zrfln(i) = zrfl(i) - zqev*(paprs(i,k)-paprs(i,k+1))/rg/dtime
-          zq(i) = zq(i) - (zrfln(i)-zrfl(i))*(rg/(paprs(i,k)-paprs(i, &
-            k+1)))*dtime
-          zt(i) = zt(i) + (zrfln(i)-zrfl(i))*(rg/(paprs(i,k)-paprs(i, &
-            k+1)))*dtime*rlvtt/rcpd/(1.0+rvtmp2*zq(i))
-          zrfl(i) = zrfln(i)
-        END IF
-      END DO
-    END IF
-
-    ! Calculer Qs et L/Cp*dQs/dT:
-
-    IF (thermcep) THEN
-      DO i = 1, klon
-        zdelta = max(0., sign(1.,rtt-zt(i)))
-        zcvm5 = r5les*rlvtt*(1.-zdelta) + r5ies*rlstt*zdelta
-        zcvm5 = zcvm5/rcpd/(1.0+rvtmp2*zq(i))
-        zqs(i) = r2es*foeew(zt(i), zdelta)/pplay(i, k)
-        zqs(i) = min(0.5, zqs(i))
-        zcor = 1./(1.-retv*zqs(i))
-        zqs(i) = zqs(i)*zcor
-        zdqs(i) = foede(zt(i), zdelta, zcvm5, zqs(i), zcor)
-      END DO
-    ELSE
-      DO i = 1, klon
-        IF (zt(i)<t_coup) THEN
-          zqs(i) = qsats(zt(i))/pplay(i, k)
-          zdqs(i) = dqsats(zt(i), zqs(i))
-        ELSE
-          zqs(i) = qsatl(zt(i))/pplay(i, k)
-          zdqs(i) = dqsatl(zt(i), zqs(i))
-        END IF
-      END DO
-    END IF
-
-    ! Determiner la condensation partielle et calculer la quantite
-    ! de l'eau condensee:
-
-    IF (cpartiel) THEN
-      DO i = 1, klon
-
-        zdelq = ratqs(i, k)*zq(i)
-        rneb(i, k) = (zq(i)+zdelq-zqs(i))/(2.0*zdelq)
-        zqn(i) = (zq(i)+zdelq+zqs(i))/2.0
-        IF (rneb(i,k)<=0.0) zqn(i) = 0.0
-        IF (rneb(i,k)>=1.0) zqn(i) = zq(i)
-        rneb(i, k) = max(0.0, min(1.0,rneb(i,k)))
-        zcond(i) = max(0.0, zqn(i)-zqs(i))*rneb(i, k)/(1.+zdqs(i))
-
-        ! --Olivier
-        rhcl(i, k) = (zqs(i)+zq(i)-zdelq)/2./zqs(i)
-        IF (rneb(i,k)<=0.0) rhcl(i, k) = zq(i)/zqs(i)
-        IF (rneb(i,k)>=1.0) rhcl(i, k) = 1.0
-        ! --fin
-
-      END DO
-    ELSE
-      DO i = 1, klon
-        IF (zq(i)>zqs(i)) THEN
-          rneb(i, k) = 1.0
-        ELSE
-          rneb(i, k) = 0.0
-        END IF
-        zcond(i) = max(0.0, zq(i)-zqs(i))/(1.+zdqs(i))
-      END DO
-    END IF
-
-    DO i = 1, klon
-      zq(i) = zq(i) - zcond(i)
-      zt(i) = zt(i) + zcond(i)*rlvtt/rcpd
-    END DO
-
-    ! Partager l'eau condensee en precipitation et eau liquide nuageuse
-
-    DO i = 1, klon
-      IF (rneb(i,k)>0.0) THEN
-        zoliq(i) = zcond(i)
-        zrho(i) = pplay(i, k)/zt(i)/rd
-        zdz(i) = (paprs(i,k)-paprs(i,k+1))/(zrho(i)*rg)
-        zfice(i) = 1.0 - (zt(i)-ztglace)/(273.13-ztglace)
-        zfice(i) = min(max(zfice(i),0.0), 1.0)
-        zfice(i) = zfice(i)**nexpo
-        zneb(i) = max(rneb(i,k), seuil_neb)
-        radliq(i, k) = zoliq(i)/real(ninter+1)
-      END IF
-    END DO
-
-    DO n = 1, ninter
-      DO i = 1, klon
-        IF (rneb(i,k)>0.0) THEN
-          zchau(i) = ct*dtime/real(ninter)*zoliq(i)* &
-            (1.0-exp(-(zoliq(i)/zneb(i)/cl)**2))*(1.-zfice(i))
-          zrhol(i) = zrho(i)*zoliq(i)/zneb(i)
-          zfroi(i) = dtime/real(ninter)/zdz(i)*zoliq(i)*fallv(zrhol(i))* &
-            zfice(i)
-          ztot(i) = zchau(i) + zfroi(i)
-          IF (zneb(i)==seuil_neb) ztot(i) = 0.0
-          ztot(i) = min(max(ztot(i),0.0), zoliq(i))
-          zoliq(i) = max(zoliq(i)-ztot(i), 0.0)
-          radliq(i, k) = radliq(i, k) + zoliq(i)/real(ninter+1)
-        END IF
-      END DO
-    END DO
-
-    DO i = 1, klon
-      IF (rneb(i,k)>0.0) THEN
-        d_ql(i, k) = zoliq(i)
-        zrfl(i) = zrfl(i) + max(zcond(i)-zoliq(i), 0.0)*(paprs(i,k)-paprs(i,k &
-          +1))/(rg*dtime)
-      END IF
-      IF (zt(i)<rtt) THEN
-        psfl(i, k) = zrfl(i)
-      ELSE
-        prfl(i, k) = zrfl(i)
-      END IF
-    END DO
-
-    ! Calculer les tendances de q et de t:
-
-    DO i = 1, klon
-      d_q(i, k) = zq(i) - q(i, k)
-      d_t(i, k) = zt(i) - t(i, k)
-    END DO
-
-    ! AA--------------- Calcul du lessivage stratiforme  -------------
-
-    DO i = 1, klon
-
-      zprec_cond(i) = max(zcond(i)-zoliq(i), 0.0)*(paprs(i,k)-paprs(i,k+1))/ &
-        rg
-      IF (rneb(i,k)>0.0 .AND. zprec_cond(i)>0.) THEN
-        ! AA lessivage nucleation LMD5 dans la couche elle-meme
-        IF (t(i,k)>=ztglace) THEN
-          zalpha_tr = a_tr_sca(3)
-        ELSE
-          zalpha_tr = a_tr_sca(4)
-        END IF
-        zfrac_lessi = 1. - exp(zalpha_tr*zprec_cond(i)/zneb(i))
-        pfrac_nucl(i, k) = pfrac_nucl(i, k)*(1.-zneb(i)*zfrac_lessi)
-        frac_nucl(i, k) = 1. - zneb(i)*zfrac_lessi
-
-        ! nucleation avec un facteur -1 au lieu de -0.5
-        zfrac_lessi = 1. - exp(-zprec_cond(i)/zneb(i))
-        pfrac_1nucl(i, k) = pfrac_1nucl(i, k)*(1.-zneb(i)*zfrac_lessi)
-      END IF
-
-    END DO ! boucle sur i
-
-    ! AA Lessivage par impaction dans les couches en-dessous
-    DO kk = k - 1, 1, -1
-      DO i = 1, klon
-        IF (rneb(i,k)>0.0 .AND. zprec_cond(i)>0.) THEN
-          IF (t(i,kk)>=ztglace) THEN
-            zalpha_tr = a_tr_sca(1)
-          ELSE
-            zalpha_tr = a_tr_sca(2)
-          END IF
-          zfrac_lessi = 1. - exp(zalpha_tr*zprec_cond(i)/zneb(i))
-          pfrac_impa(i, kk) = pfrac_impa(i, kk)*(1.-zneb(i)*zfrac_lessi)
-          frac_impa(i, kk) = 1. - zneb(i)*zfrac_lessi
-        END IF
-      END DO
-    END DO
-
-    ! AA----------------------------------------------------------
-    ! FIN DE BOUCLE SUR K
-  END DO
-
-  ! AA-----------------------------------------------------------
-
-  ! Pluie ou neige au sol selon la temperature de la 1ere couche
-
-  DO i = 1, klon
-    IF ((t(i,1)+d_t(i,1))<rtt) THEN
-      snow(i) = zrfl(i)
-    ELSE
-      rain(i) = zrfl(i)
-    END IF
-  END DO
-
-  RETURN
-END SUBROUTINE fisrtilp_tr
Index: /LMDZ6/trunk/libf/phylmd/fisrtilp_tr.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/fisrtilp_tr.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/fisrtilp_tr.f90	(revision 5268)
@@ -0,0 +1,429 @@
+
+! $Id$
+
+
+SUBROUTINE fisrtilp_tr(dtime, paprs, pplay, t, q, ratqs, d_t, d_q, d_ql, &
+    rneb, radliq, rain, snow, pfrac_impa, pfrac_nucl, pfrac_1nucl, frac_impa, &
+    frac_nucl, prfl, psfl, rhcl) ! relative humidity in clear sky (needed for aer optical
+  ! properties; aeropt.F)
+
+
+  USE dimphy
+  USE print_control_mod, ONLY: lunout
+  IMPLICIT NONE
+  ! ======================================================================
+  ! Auteur(s): Z.X. Li (LMD/CNRS)
+  ! Date: le 20 mars 1995
+  ! Objet: condensation et precipitation stratiforme.
+  ! schema de nuage
+  ! ======================================================================
+  ! ======================================================================
+  include "YOMCST.h"
+
+  ! Arguments:
+
+  REAL dtime ! intervalle du temps (s)
+  REAL paprs(klon, klev+1) ! pression a inter-couche
+  REAL pplay(klon, klev) ! pression au milieu de couche
+  REAL t(klon, klev) ! temperature (K)
+  REAL q(klon, klev) ! humidite specifique (kg/kg)
+  REAL d_t(klon, klev) ! incrementation de la temperature (K)
+  REAL d_q(klon, klev) ! incrementation de la vapeur d'eau
+  REAL d_ql(klon, klev) ! incrementation de l'eau liquide
+  REAL rneb(klon, klev) ! fraction nuageuse
+  REAL radliq(klon, klev) ! eau liquide utilisee dans rayonnements
+  REAL rain(klon) ! pluies (mm/s)
+  REAL snow(klon) ! neige (mm/s)
+  REAL prfl(klon, klev+1) ! flux d'eau precipitante aux interfaces (kg/m2/s)
+  REAL psfl(klon, klev+1) ! flux d'eau precipitante aux interfaces (kg/m2/s)
+
+  ! jq   For aerosol opt properties needed (see aeropt.F)
+  REAL rhcl(klon, klev)
+
+  ! AA
+  ! Coeffients de fraction lessivee : pour OFF-LINE
+
+  REAL pfrac_nucl(klon, klev)
+  REAL pfrac_1nucl(klon, klev)
+  REAL pfrac_impa(klon, klev)
+
+  ! Fraction d'aerosols lessivee par impaction et par nucleation
+  ! POur ON-LINE
+
+  REAL frac_impa(klon, klev)
+  REAL frac_nucl(klon, klev)
+  ! AA
+
+  ! Options du programme:
+
+  REAL seuil_neb ! un nuage existe vraiment au-dela
+  PARAMETER (seuil_neb=0.001)
+  REAL ct ! inverse du temps pour qu'un nuage precipite
+  PARAMETER (ct=1./1800.)
+  REAL cl ! seuil de precipitation
+  PARAMETER (cl=2.6E-4)
+  ! cc      PARAMETER (cl=2.3e-4)
+  ! cc      PARAMETER (cl=2.0e-4)
+  INTEGER ninter ! sous-intervals pour la precipitation
+  PARAMETER (ninter=5)
+  LOGICAL evap_prec ! evaporation de la pluie
+  PARAMETER (evap_prec=.TRUE.)
+  REAL coef_eva
+  PARAMETER (coef_eva=2.0E-05)
+  LOGICAL calcrat ! calculer ratqs au lieu de fixer sa valeur
+  REAL ratqs(klon, klev) ! determine la largeur de distribution de vapeur
+  PARAMETER (calcrat=.TRUE.)
+  REAL zx_min, rat_max
+  PARAMETER (zx_min=1.0, rat_max=0.01)
+  REAL zx_max, rat_min
+  PARAMETER (zx_max=0.1, rat_min=0.3)
+  REAL zx
+
+  LOGICAL cpartiel ! condensation partielle
+  PARAMETER (cpartiel=.TRUE.)
+  REAL t_coup
+  PARAMETER (t_coup=234.0)
+
+  ! Variables locales:
+
+  INTEGER i, k, n, kk
+  REAL zqs(klon), zdqs(klon), zdelta, zcor, zcvm5
+  REAL zrfl(klon), zrfln(klon), zqev, zqevt
+  REAL zoliq(klon), zcond(klon), zq(klon), zqn(klon), zdelq
+  REAL ztglace, zt(klon)
+  INTEGER nexpo ! exponentiel pour glace/eau
+  REAL zdz(klon), zrho(klon), ztot(klon), zrhol(klon)
+  REAL zchau(klon), zfroi(klon), zfice(klon), zneb(klon)
+
+  LOGICAL appel1er
+  SAVE appel1er
+  !$OMP THREADPRIVATE(appel1er)
+
+  ! ---------------------------------------------------------------
+
+  ! AA Variables traceurs:
+  ! AA  Provisoire !!! Parametres alpha du lessivage
+  ! AA  A priori on a 4 scavenging # possibles
+
+  REAL a_tr_sca(4)
+  SAVE a_tr_sca
+  !$OMP THREADPRIVATE(a_tr_sca)
+
+  ! Variables intermediaires
+
+  REAL zalpha_tr
+  REAL zfrac_lessi
+  REAL zprec_cond(klon)
+  ! AA
+  ! ---------------------------------------------------------------
+
+  ! Fonctions en ligne:
+
+  REAL fallv ! vitesse de chute pour crystaux de glace
+  REAL zzz
+  include "YOETHF.h"
+  include "FCTTRE.h"
+  fallv(zzz) = 3.29/2.0*((zzz)**0.16)
+  ! cc      fallv (zzz) = 3.29/3.0 * ((zzz)**0.16)
+  ! cc      fallv (zzz) = 3.29 * ((zzz)**0.16)
+
+  DATA appel1er/.TRUE./
+
+  IF (appel1er) THEN
+
+    WRITE (lunout, *) 'fisrtilp, calcrat:', calcrat
+    WRITE (lunout, *) 'fisrtilp, ninter:', ninter
+    WRITE (lunout, *) 'fisrtilp, evap_prec:', evap_prec
+    WRITE (lunout, *) 'fisrtilp, cpartiel:', cpartiel
+    IF (abs(dtime/real(ninter)-360.0)>0.001) THEN
+      WRITE (lunout, *) 'fisrtilp: Ce n est pas prevu, voir Z.X.Li', dtime
+      WRITE (lunout, *) 'Je prefere un sous-intervalle de 6 minutes'
+      CALL abort
+    END IF
+    appel1er = .FALSE.
+
+    ! AA initialiation provisoire
+    a_tr_sca(1) = -0.5
+    a_tr_sca(2) = -0.5
+    a_tr_sca(3) = -0.5
+    a_tr_sca(4) = -0.5
+
+    ! AA Initialisation a 1 des coefs des fractions lessivees
+
+    DO k = 1, klev
+      DO i = 1, klon
+        pfrac_nucl(i, k) = 1.
+        pfrac_1nucl(i, k) = 1.
+        pfrac_impa(i, k) = 1.
+      END DO
+    END DO
+
+  END IF !  test sur appel1er
+
+  ! MAf Initialisation a 0 de zoliq
+  DO i = 1, klon
+    zoliq(i) = 0.
+  END DO
+  ! Determiner les nuages froids par leur temperature
+
+  ztglace = rtt - 15.0
+  nexpo = 6
+  ! cc      nexpo = 1
+
+  ! Initialiser les sorties:
+
+  DO k = 1, klev + 1
+    DO i = 1, klon
+      prfl(i, k) = 0.0
+      psfl(i, k) = 0.0
+    END DO
+  END DO
+
+  DO k = 1, klev
+    DO i = 1, klon
+      d_t(i, k) = 0.0
+      d_q(i, k) = 0.0
+      d_ql(i, k) = 0.0
+      rneb(i, k) = 0.0
+      radliq(i, k) = 0.0
+      frac_nucl(i, k) = 1.
+      frac_impa(i, k) = 1.
+    END DO
+  END DO
+  DO i = 1, klon
+    rain(i) = 0.0
+    snow(i) = 0.0
+  END DO
+
+  ! Initialiser le flux de precipitation a zero
+
+  DO i = 1, klon
+    zrfl(i) = 0.0
+    zneb(i) = seuil_neb
+  END DO
+
+
+  ! AA Pour plus de securite
+
+  zalpha_tr = 0.
+  zfrac_lessi = 0.
+
+  ! AA----------------------------------------------------------
+
+  ! Boucle verticale (du haut vers le bas)
+
+  DO k = klev, 1, -1
+
+    ! AA----------------------------------------------------------
+
+    DO i = 1, klon
+      zt(i) = t(i, k)
+      zq(i) = q(i, k)
+    END DO
+
+    ! Calculer l'evaporation de la precipitation
+
+    IF (evap_prec) THEN
+      DO i = 1, klon
+        IF (zrfl(i)>0.) THEN
+          IF (thermcep) THEN
+            zdelta = max(0., sign(1.,rtt-zt(i)))
+            zqs(i) = r2es*foeew(zt(i), zdelta)/pplay(i, k)
+            zqs(i) = min(0.5, zqs(i))
+            zcor = 1./(1.-retv*zqs(i))
+            zqs(i) = zqs(i)*zcor
+          ELSE
+            IF (zt(i)<t_coup) THEN
+              zqs(i) = qsats(zt(i))/pplay(i, k)
+            ELSE
+              zqs(i) = qsatl(zt(i))/pplay(i, k)
+            END IF
+          END IF
+          zqev = max(0.0, (zqs(i)-zq(i))*zneb(i))
+          zqevt = coef_eva*(1.0-zq(i)/zqs(i))*sqrt(zrfl(i))* &
+            (paprs(i,k)-paprs(i,k+1))/pplay(i, k)*zt(i)*rd/rg
+          zqevt = max(0.0, min(zqevt,zrfl(i)))*rg*dtime/ &
+            (paprs(i,k)-paprs(i,k+1))
+          zqev = min(zqev, zqevt)
+          zrfln(i) = zrfl(i) - zqev*(paprs(i,k)-paprs(i,k+1))/rg/dtime
+          zq(i) = zq(i) - (zrfln(i)-zrfl(i))*(rg/(paprs(i,k)-paprs(i, &
+            k+1)))*dtime
+          zt(i) = zt(i) + (zrfln(i)-zrfl(i))*(rg/(paprs(i,k)-paprs(i, &
+            k+1)))*dtime*rlvtt/rcpd/(1.0+rvtmp2*zq(i))
+          zrfl(i) = zrfln(i)
+        END IF
+      END DO
+    END IF
+
+    ! Calculer Qs et L/Cp*dQs/dT:
+
+    IF (thermcep) THEN
+      DO i = 1, klon
+        zdelta = max(0., sign(1.,rtt-zt(i)))
+        zcvm5 = r5les*rlvtt*(1.-zdelta) + r5ies*rlstt*zdelta
+        zcvm5 = zcvm5/rcpd/(1.0+rvtmp2*zq(i))
+        zqs(i) = r2es*foeew(zt(i), zdelta)/pplay(i, k)
+        zqs(i) = min(0.5, zqs(i))
+        zcor = 1./(1.-retv*zqs(i))
+        zqs(i) = zqs(i)*zcor
+        zdqs(i) = foede(zt(i), zdelta, zcvm5, zqs(i), zcor)
+      END DO
+    ELSE
+      DO i = 1, klon
+        IF (zt(i)<t_coup) THEN
+          zqs(i) = qsats(zt(i))/pplay(i, k)
+          zdqs(i) = dqsats(zt(i), zqs(i))
+        ELSE
+          zqs(i) = qsatl(zt(i))/pplay(i, k)
+          zdqs(i) = dqsatl(zt(i), zqs(i))
+        END IF
+      END DO
+    END IF
+
+    ! Determiner la condensation partielle et calculer la quantite
+    ! de l'eau condensee:
+
+    IF (cpartiel) THEN
+      DO i = 1, klon
+
+        zdelq = ratqs(i, k)*zq(i)
+        rneb(i, k) = (zq(i)+zdelq-zqs(i))/(2.0*zdelq)
+        zqn(i) = (zq(i)+zdelq+zqs(i))/2.0
+        IF (rneb(i,k)<=0.0) zqn(i) = 0.0
+        IF (rneb(i,k)>=1.0) zqn(i) = zq(i)
+        rneb(i, k) = max(0.0, min(1.0,rneb(i,k)))
+        zcond(i) = max(0.0, zqn(i)-zqs(i))*rneb(i, k)/(1.+zdqs(i))
+
+        ! --Olivier
+        rhcl(i, k) = (zqs(i)+zq(i)-zdelq)/2./zqs(i)
+        IF (rneb(i,k)<=0.0) rhcl(i, k) = zq(i)/zqs(i)
+        IF (rneb(i,k)>=1.0) rhcl(i, k) = 1.0
+        ! --fin
+
+      END DO
+    ELSE
+      DO i = 1, klon
+        IF (zq(i)>zqs(i)) THEN
+          rneb(i, k) = 1.0
+        ELSE
+          rneb(i, k) = 0.0
+        END IF
+        zcond(i) = max(0.0, zq(i)-zqs(i))/(1.+zdqs(i))
+      END DO
+    END IF
+
+    DO i = 1, klon
+      zq(i) = zq(i) - zcond(i)
+      zt(i) = zt(i) + zcond(i)*rlvtt/rcpd
+    END DO
+
+    ! Partager l'eau condensee en precipitation et eau liquide nuageuse
+
+    DO i = 1, klon
+      IF (rneb(i,k)>0.0) THEN
+        zoliq(i) = zcond(i)
+        zrho(i) = pplay(i, k)/zt(i)/rd
+        zdz(i) = (paprs(i,k)-paprs(i,k+1))/(zrho(i)*rg)
+        zfice(i) = 1.0 - (zt(i)-ztglace)/(273.13-ztglace)
+        zfice(i) = min(max(zfice(i),0.0), 1.0)
+        zfice(i) = zfice(i)**nexpo
+        zneb(i) = max(rneb(i,k), seuil_neb)
+        radliq(i, k) = zoliq(i)/real(ninter+1)
+      END IF
+    END DO
+
+    DO n = 1, ninter
+      DO i = 1, klon
+        IF (rneb(i,k)>0.0) THEN
+          zchau(i) = ct*dtime/real(ninter)*zoliq(i)* &
+            (1.0-exp(-(zoliq(i)/zneb(i)/cl)**2))*(1.-zfice(i))
+          zrhol(i) = zrho(i)*zoliq(i)/zneb(i)
+          zfroi(i) = dtime/real(ninter)/zdz(i)*zoliq(i)*fallv(zrhol(i))* &
+            zfice(i)
+          ztot(i) = zchau(i) + zfroi(i)
+          IF (zneb(i)==seuil_neb) ztot(i) = 0.0
+          ztot(i) = min(max(ztot(i),0.0), zoliq(i))
+          zoliq(i) = max(zoliq(i)-ztot(i), 0.0)
+          radliq(i, k) = radliq(i, k) + zoliq(i)/real(ninter+1)
+        END IF
+      END DO
+    END DO
+
+    DO i = 1, klon
+      IF (rneb(i,k)>0.0) THEN
+        d_ql(i, k) = zoliq(i)
+        zrfl(i) = zrfl(i) + max(zcond(i)-zoliq(i), 0.0)*(paprs(i,k)-paprs(i,k &
+          +1))/(rg*dtime)
+      END IF
+      IF (zt(i)<rtt) THEN
+        psfl(i, k) = zrfl(i)
+      ELSE
+        prfl(i, k) = zrfl(i)
+      END IF
+    END DO
+
+    ! Calculer les tendances de q et de t:
+
+    DO i = 1, klon
+      d_q(i, k) = zq(i) - q(i, k)
+      d_t(i, k) = zt(i) - t(i, k)
+    END DO
+
+    ! AA--------------- Calcul du lessivage stratiforme  -------------
+
+    DO i = 1, klon
+
+      zprec_cond(i) = max(zcond(i)-zoliq(i), 0.0)*(paprs(i,k)-paprs(i,k+1))/ &
+        rg
+      IF (rneb(i,k)>0.0 .AND. zprec_cond(i)>0.) THEN
+        ! AA lessivage nucleation LMD5 dans la couche elle-meme
+        IF (t(i,k)>=ztglace) THEN
+          zalpha_tr = a_tr_sca(3)
+        ELSE
+          zalpha_tr = a_tr_sca(4)
+        END IF
+        zfrac_lessi = 1. - exp(zalpha_tr*zprec_cond(i)/zneb(i))
+        pfrac_nucl(i, k) = pfrac_nucl(i, k)*(1.-zneb(i)*zfrac_lessi)
+        frac_nucl(i, k) = 1. - zneb(i)*zfrac_lessi
+
+        ! nucleation avec un facteur -1 au lieu de -0.5
+        zfrac_lessi = 1. - exp(-zprec_cond(i)/zneb(i))
+        pfrac_1nucl(i, k) = pfrac_1nucl(i, k)*(1.-zneb(i)*zfrac_lessi)
+      END IF
+
+    END DO ! boucle sur i
+
+    ! AA Lessivage par impaction dans les couches en-dessous
+    DO kk = k - 1, 1, -1
+      DO i = 1, klon
+        IF (rneb(i,k)>0.0 .AND. zprec_cond(i)>0.) THEN
+          IF (t(i,kk)>=ztglace) THEN
+            zalpha_tr = a_tr_sca(1)
+          ELSE
+            zalpha_tr = a_tr_sca(2)
+          END IF
+          zfrac_lessi = 1. - exp(zalpha_tr*zprec_cond(i)/zneb(i))
+          pfrac_impa(i, kk) = pfrac_impa(i, kk)*(1.-zneb(i)*zfrac_lessi)
+          frac_impa(i, kk) = 1. - zneb(i)*zfrac_lessi
+        END IF
+      END DO
+    END DO
+
+    ! AA----------------------------------------------------------
+    ! FIN DE BOUCLE SUR K
+  END DO
+
+  ! AA-----------------------------------------------------------
+
+  ! Pluie ou neige au sol selon la temperature de la 1ere couche
+
+  DO i = 1, klon
+    IF ((t(i,1)+d_t(i,1))<rtt) THEN
+      snow(i) = zrfl(i)
+    ELSE
+      rain(i) = zrfl(i)
+    END IF
+  END DO
+
+  RETURN
+END SUBROUTINE fisrtilp_tr
Index: DZ6/trunk/libf/phylmd/flott_gwd_rando_m.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/flott_gwd_rando_m.F90	(revision 5267)
+++ 	(revision )
@@ -1,460 +1,0 @@
-!
-! $Id$
-!
-module FLOTT_GWD_rando_m
-
-  implicit none
-
-contains
-
-  SUBROUTINE FLOTT_GWD_rando(DTIME, pp, tt, uu, vv, prec, zustr, zvstr, d_u, &
-       d_v,east_gwstress,west_gwstress)
-
-    ! Parametrization of the momentum flux deposition due to a discrete
-    ! number of gravity waves. 
-    ! Author: F. Lott
-    ! July, 12th, 2012
-    ! Gaussian distribution of the source, source is precipitation
-    ! Reference: Lott (JGR, vol 118, page 8897, 2013)
-
-    !ONLINE:
-      use dimphy, only: klon, klev
-      use assert_m, only: assert
-      USE ioipsl_getin_p_mod, ONLY : getin_p
-      USE vertical_layers_mod, ONLY : presnivs
-      CHARACTER (LEN=20) :: modname='flott_gwd_rando'
-      CHARACTER (LEN=80) :: abort_message
-
-      include "YOMCST.h"
-      include "clesphys.h"
-    ! OFFLINE:
-    ! include "dimensions.h"
-    ! include "dimphy.h"
-    ! END OF DIFFERENCE ONLINE-OFFLINE
-    include "YOEGWD.h"
-
-    ! 0. DECLARATIONS:
-
-    ! 0.1 INPUTS
-    REAL, intent(in)::DTIME ! Time step of the Physics
-    REAL, intent(in):: pp(:, :) ! (KLON, KLEV) Pressure at full levels
-    REAL, intent(in):: prec(:) ! (klon) Precipitation (kg/m^2/s) 
-    REAL, intent(in):: TT(:, :) ! (KLON, KLEV) Temp at full levels 
-    REAL, intent(in):: UU(:, :) ! (KLON, KLEV) Zonal wind at full levels
-    REAL, intent(in):: VV(:, :) ! (KLON, KLEV) Merid wind at full levels
-
-    ! 0.2 OUTPUTS
-    REAL, intent(out):: zustr(:), zvstr(:) ! (KLON) Surface Stresses
-
-    REAL, intent(inout):: d_u(:, :), d_v(:, :) 
-    REAL, intent(inout):: east_gwstress(:, :) !  Profile of eastward stress
-    REAL, intent(inout):: west_gwstress(:, :) !  Profile of westward stress 
-
-    ! (KLON, KLEV) tendencies on winds
-
-    ! O.3 INTERNAL ARRAYS
-    REAL BVLOW(klon)
-    REAL DZ   !  Characteristic depth of the Source
-
-    INTEGER II, JJ, LL
-
-    ! 0.3.0 TIME SCALE OF THE LIFE CYCLE OF THE WAVES PARAMETERIZED
-
-    REAL DELTAT
-
-    ! 0.3.1 GRAVITY-WAVES SPECIFICATIONS
-
-    INTEGER, PARAMETER:: NK = 2, NP = 2, NO = 2, NW = NK * NP * NO
-    INTEGER JK, JP, JO, JW
-    INTEGER, PARAMETER:: NA = 5  !number of realizations to get the phase speed
-    REAL KMIN, KMAX ! Min and Max horizontal wavenumbers
-    REAL CMAX ! standard deviation of the phase speed distribution
-    REAL RUWMAX,SAT  ! ONLINE SPECIFIED IN run.def
-    REAL CPHA ! absolute PHASE VELOCITY frequency
-    REAL ZK(NW, KLON) ! Horizontal wavenumber amplitude
-    REAL ZP(NW, KLON) ! Horizontal wavenumber angle 
-    REAL ZO(NW, KLON) ! Absolute frequency !
-
-    ! Waves Intr. freq. at the 1/2 lev surrounding the full level
-    REAL ZOM(NW, KLON), ZOP(NW, KLON)
-
-    ! Wave EP-fluxes at the 2 semi levels surrounding the full level
-    REAL WWM(NW, KLON), WWP(NW, KLON)
-
-    REAL RUW0(NW, KLON) ! Fluxes at launching level
-
-    REAL RUWP(NW, KLON), RVWP(NW, KLON)
-    ! Fluxes X and Y for each waves at 1/2 Levels
-
-    INTEGER LAUNCH, LTROP ! Launching altitude and tropo altitude
-
-    REAL XLAUNCH ! Controle the launching altitude
-    REAL XTROP ! SORT of Tropopause altitude 
-    REAL RUW(KLON, KLEV + 1) ! Flux x at semi levels
-    REAL RVW(KLON, KLEV + 1) ! Flux y at semi levels
-
-    REAL PRMAX ! Maximum value of PREC, and for which our linear formula
-    ! for GWs parameterisation apply
-
-    ! 0.3.2 PARAMETERS OF WAVES DISSIPATIONS
-
-    REAL RDISS, ZOISEC ! COEFF DE DISSIPATION, SECURITY FOR INTRINSIC FREQ
-
-    ! 0.3.3 BACKGROUND FLOW AT 1/2 LEVELS AND VERTICAL COORDINATE
-
-    REAL H0 ! Characteristic Height of the atmosphere
-    REAL PR, TR ! Reference Pressure and Temperature
-
-    REAL ZH(KLON, KLEV + 1) ! Log-pressure altitude
-
-    REAL UH(KLON, KLEV + 1), VH(KLON, KLEV + 1) ! Winds at 1/2 levels
-    REAL PH(KLON, KLEV + 1) ! Pressure at 1/2 levels
-    REAL PSEC ! Security to avoid division by 0 pressure
-    REAL BV(KLON, KLEV + 1) ! Brunt Vaisala freq. (BVF) at 1/2 levels
-    REAL BVSEC ! Security to avoid negative BVF
-    REAL RAN_NUM_1,RAN_NUM_2,RAN_NUM_3
-
-    REAL, DIMENSION(klev+1) ::HREF
-
-    LOGICAL, SAVE :: gwd_reproductibilite_mpiomp=.true.
-    LOGICAL, SAVE :: firstcall = .TRUE.
-  !$OMP THREADPRIVATE(firstcall,gwd_reproductibilite_mpiomp)
-
-
-  IF (firstcall) THEN
-    ! Cle introduite pour resoudre un probleme de non reproductibilite
-    ! Le but est de pouvoir tester de revenir a la version precedenete
-    ! A eliminer rapidement
-    CALL getin_p('gwd_reproductibilite_mpiomp',gwd_reproductibilite_mpiomp)
-    IF (NW+3*NA>=KLEV) THEN
-       abort_message = 'NW+3*NA>=KLEV Probleme pour generation des ondes'
-       CALL abort_physic (modname,abort_message,1)
-    ENDIF
-    firstcall=.false.
-  ENDIF
-
-
-    !-----------------------------------------------------------------
-
-    ! 1. INITIALISATIONS
-
-    ! 1.1 Basic parameter
-
-    ! Are provided from elsewhere (latent heat of vaporization, dry
-    ! gaz constant for air, gravity constant, heat capacity of dry air
-    ! at constant pressure, earth rotation rate, pi).
-
-    ! 1.2 Tuning parameters of V14
-
-    
-    RDISS = 0.5 ! Diffusion parameter
-    ! ONLINE 
-      RUWMAX=GWD_RANDO_RUWMAX
-      SAT=gwd_rando_sat
-    !END ONLINE
-    ! OFFLINE
-    ! RUWMAX= 1.75    ! Launched flux
-    ! SAT=0.25     ! Saturation parameter
-    ! END OFFLINE
-
-    PRMAX = 20. / 24. /3600.
-    ! maximum of rain for which our theory applies (in kg/m^2/s)
-
- ! Characteristic depth of the source
-    DZ = 1000.
-    XLAUNCH=0.5 ! Parameter that control launching altitude
-    XTROP=0.2 ! Parameter that control tropopause altitude
-    DELTAT=24.*3600. ! Time scale of the waves (first introduced in 9b)
-    !  OFFLINE
-    !  DELTAT=DTIME
-    !  END OFFLINE
-
-    KMIN = 2.E-5
-    ! minimum horizontal wavenumber (inverse of the subgrid scale resolution)
-
-    KMAX = 1.E-3 ! Max horizontal wavenumber
-    CMAX = 30. ! Max phase speed velocity
-
-    TR = 240. ! Reference Temperature
-    PR = 101300. ! Reference pressure
-    H0 = RD * TR / RG ! Characteristic vertical scale height
-
-    BVSEC = 5.E-3 ! Security to avoid negative BVF 
-    PSEC = 1.E-6 ! Security to avoid division by 0 pressure
-    ZOISEC = 1.E-6 ! Security FOR 0 INTRINSIC FREQ
-
-IF (1==0) THEN
-    !ONLINE
-        call assert(klon == (/size(pp, 1), size(tt, 1), size(uu, 1), &
-         size(vv, 1), size(zustr), size(zvstr), size(d_u, 1), &
-         size(d_v, 1), &
-         size(east_gwstress, 1), size(west_gwstress, 1) /), &
-         "FLOTT_GWD_RANDO klon")
-     call assert(klev == (/size(pp, 2), size(tt, 2), size(uu, 2), &
-          size(vv, 2), size(d_u, 2), size(d_v, 2), &
-          size(east_gwstress,2), size(west_gwstress,2) /), &
-          "FLOTT_GWD_RANDO klev")
-    !END ONLINE
-ENDIF
-
-    IF(DELTAT < DTIME)THEN
-       abort_message='flott_gwd_rando: deltat < dtime!'
-       CALL abort_physic(modname,abort_message,1)
-    ENDIF
-
-    IF (KLEV < NW) THEN
-       abort_message='flott_gwd_rando: you will have problem with random numbers'
-       CALL abort_physic(modname,abort_message,1)
-    ENDIF
-
-    ! 2. EVALUATION OF THE BACKGROUND FLOW AT SEMI-LEVELS
-
-    ! Pressure and Inv of pressure
-    DO LL = 2, KLEV
-       PH(:, LL) = EXP((LOG(PP(:, LL)) + LOG(PP(:, LL - 1))) / 2.)
-    end DO
-    PH(:, KLEV + 1) = 0. 
-    PH(:, 1) = 2. * PP(:, 1) - PH(:, 2)
-
-    ! Launching altitude
-
-    !Pour revenir a la version non reproductible en changeant le nombre de process
-    IF (gwd_reproductibilite_mpiomp) THEN
-       ! Reprend la formule qui calcule PH en fonction de PP=play
-       DO LL = 2, KLEV
-          HREF(LL) = EXP((LOG(presnivs(LL)) + LOG(presnivs(LL - 1))) / 2.)
-       end DO
-       HREF(KLEV + 1) = 0.
-       HREF(1) = 2. * presnivs(1) - HREF(2)
-    ELSE
-       HREF(1:KLEV)=PH(KLON/2,1:KLEV)
-    ENDIF
-
-    LAUNCH=0
-    LTROP =0
-    DO LL = 1, KLEV
-       IF (HREF(LL) / HREF(1) > XLAUNCH) LAUNCH = LL
-    ENDDO
-    DO LL = 1, KLEV
-       IF (HREF(LL) / HREF(1) > XTROP) LTROP = LL
-    ENDDO
-    !LAUNCH=22 ; LTROP=33
-!   print*,'LAUNCH=',LAUNCH,'LTROP=',LTROP
-
-    ! Log pressure vert. coordinate
-    DO LL = 1, KLEV + 1 
-       ZH(:, LL) = H0 * LOG(PR / (PH(:, LL) + PSEC))
-    end DO
-
-    ! BV frequency
-    DO LL = 2, KLEV
-       ! BVSEC: BV Frequency (UH USED IS AS A TEMPORARY ARRAY DOWN TO WINDS)
-       UH(:, LL) = 0.5 * (TT(:, LL) + TT(:, LL - 1)) &
-            * RD**2 / RCPD / H0**2 + (TT(:, LL) &
-            - TT(:, LL - 1)) / (ZH(:, LL) - ZH(:, LL - 1)) * RD / H0
-    end DO
-    BVLOW(:) = 0.5 * (TT(:, LTROP )+ TT(:, LAUNCH)) &
-         * RD**2 / RCPD / H0**2 + (TT(:, LTROP ) &
-         - TT(:, LAUNCH))/(ZH(:, LTROP )- ZH(:, LAUNCH)) * RD / H0
-
-    UH(:, 1) = UH(:, 2)
-    UH(:, KLEV + 1) = UH(:, KLEV)
-    BV(:, 1) = UH(:, 2)
-    BV(:, KLEV + 1) = UH(:, KLEV)
-    ! SMOOTHING THE BV HELPS
-    DO LL = 2, KLEV
-       BV(:, LL)=(UH(:, LL+1)+2.*UH(:, LL)+UH(:, LL-1))/4.
-    end DO
-
-    BV=MAX(SQRT(MAX(BV, 0.)), BVSEC)
-    BVLOW=MAX(SQRT(MAX(BVLOW, 0.)), BVSEC)
-
-
-    ! WINDS
-    DO LL = 2, KLEV
-       UH(:, LL) = 0.5 * (UU(:, LL) + UU(:, LL - 1)) ! Zonal wind
-       VH(:, LL) = 0.5 * (VV(:, LL) + VV(:, LL - 1)) ! Meridional wind
-    end DO
-    UH(:, 1) = 0.
-    VH(:, 1) = 0.
-    UH(:, KLEV + 1) = UU(:, KLEV)
-    VH(:, KLEV + 1) = VV(:, KLEV)
-
-    ! 3 WAVES CHARACTERISTICS CHOSEN RANDOMLY AT THE LAUNCH ALTITUDE
-
-    ! The mod functions of weird arguments are used to produce the
-    ! waves characteristics in an almost stochastic way
-
-    DO JW = 1, NW
-             ! Angle
-             DO II = 1, KLON
-                ! Angle (0 or PI so far)
-                RAN_NUM_1=MOD(TT(II, JW) * 10., 1.)
-                RAN_NUM_2= MOD(TT(II, JW) * 100., 1.)
-                ZP(JW, II) = (SIGN(1., 0.5 - RAN_NUM_1) + 1.) &
-                     * RPI / 2.
-                ! Horizontal wavenumber amplitude
-                ZK(JW, II) = KMIN + (KMAX - KMIN) *RAN_NUM_2
-                ! Horizontal phase speed
-                CPHA = 0.
-                DO JJ = 1, NA
-                    RAN_NUM_3=MOD(TT(II, JW+3*JJ)**2, 1.)
-                    CPHA = CPHA + &
-                    CMAX*2.*(RAN_NUM_3 -0.5)*SQRT(3.)/SQRT(NA*1.)
-                END DO
-                IF (CPHA.LT.0.)  THEN
-                   CPHA = -1.*CPHA
-                   ZP(JW,II) = ZP(JW,II) + RPI
-                ENDIF
-                ! Absolute frequency is imposed
-                ZO(JW, II) = CPHA * ZK(JW, II) 
-                ! Intrinsic frequency is imposed
-                ZO(JW, II) = ZO(JW, II) &
-                     + ZK(JW, II) * COS(ZP(JW, II)) * UH(II, LAUNCH) &
-                     + ZK(JW, II) * SIN(ZP(JW, II)) * VH(II, LAUNCH)
-                ! Momentum flux at launch lev 
-                RUW0(JW, II) = RUWMAX
-             ENDDO
-    ENDDO
-
-    ! 4. COMPUTE THE FLUXES
-
-    ! 4.1 Vertical velocity at launching altitude to ensure 
-    ! the correct value to the imposed fluxes.
-
-    DO JW = 1, NW
-
-       ! Evaluate intrinsic frequency at launching altitude:
-       ZOP(JW, :) = ZO(JW, :) &
-            - ZK(JW, :) * COS(ZP(JW, :)) * UH(:, LAUNCH) &
-            - ZK(JW, :) * SIN(ZP(JW, :)) * VH(:, LAUNCH) 
-
-       ! VERSION WITH CONVECTIVE SOURCE
-
-       ! Vertical velocity at launch level, value to ensure the
-       ! imposed factor related to the convective forcing:
-       ! precipitations.
-
-       ! tanh limitation to values above prmax:
-       WWP(JW, :) = RUW0(JW, :) &
-            * (RD / RCPD / H0 * RLVTT * PRMAX * TANH(PREC(:) / PRMAX))**2
-
-       ! Factor related to the characteristics of the waves:
-       WWP(JW, :) = WWP(JW, :) * ZK(JW, :)**3 / KMIN / BVLOW(:)  &
-            / MAX(ABS(ZOP(JW, :)), ZOISEC)**3 
-
-       ! Moderation by the depth of the source (dz here):
-       WWP(JW, :) = WWP(JW, :) &
-            * EXP(- BVLOW(:)**2 / MAX(ABS(ZOP(JW, :)), ZOISEC)**2 * ZK(JW, :)**2 &
-            * DZ**2)
-
-       ! Put the stress in the right direction:
-       RUWP(JW, :) = ZOP(JW, :) / MAX(ABS(ZOP(JW, :)), ZOISEC)**2 &
-            * BV(:, LAUNCH) * COS(ZP(JW, :)) * WWP(JW, :)**2
-       RVWP(JW, :) = ZOP(JW, :) / MAX(ABS(ZOP(JW, :)), ZOISEC)**2 &
-            * BV(:, LAUNCH) * SIN(ZP(JW, :)) * WWP(JW, :)**2
-    end DO
-
-
-    ! 4.2 Uniform values below the launching altitude
-
-    DO LL = 1, LAUNCH
-       RUW(:, LL) = 0
-       RVW(:, LL) = 0
-       DO JW = 1, NW
-          RUW(:, LL) = RUW(:, LL) + RUWP(JW, :)
-          RVW(:, LL) = RVW(:, LL) + RVWP(JW, :)
-       end DO
-    end DO
-
-    ! 4.3 Loop over altitudes, with passage from one level to the next
-    ! done by i) conserving the EP flux, ii) dissipating a little,
-    ! iii) testing critical levels, and vi) testing the breaking.
-
-    DO LL = LAUNCH, KLEV - 1
-       ! Warning: all the physics is here (passage from one level
-       ! to the next)
-       DO JW = 1, NW
-          ZOM(JW, :) = ZOP(JW, :)
-          WWM(JW, :) = WWP(JW, :)
-          ! Intrinsic Frequency
-          ZOP(JW, :) = ZO(JW, :) - ZK(JW, :) * COS(ZP(JW, :)) * UH(:, LL + 1) &
-               - ZK(JW, :) * SIN(ZP(JW, :)) * VH(:, LL + 1) 
-
-          ! No breaking (Eq.6)
-          ! Dissipation (Eq. 8)
-          WWP(JW, :) = WWM(JW, :) * EXP(- 4. * RDISS * PR / (PH(:, LL + 1) &
-               + PH(:, LL)) * ((BV(:, LL + 1) + BV(:, LL)) / 2.)**3 &
-               / MAX(ABS(ZOP(JW, :) + ZOM(JW, :)) / 2., ZOISEC)**4 &
-               * ZK(JW, :)**3 * (ZH(:, LL + 1) - ZH(:, LL)))
-
-          ! Critical levels (forced to zero if intrinsic frequency changes sign)
-          ! Saturation (Eq. 12)
-          WWP(JW, :) = min(WWP(JW, :), MAX(0., &
-               SIGN(1., ZOP(JW, :) * ZOM(JW, :))) * ABS(ZOP(JW, :))**3 &
-               / BV(:, LL + 1) * EXP(- ZH(:, LL + 1) / H0) * KMIN**2  &
-               * SAT**2 / ZK(JW, :)**4)
-       end DO
-
-       ! Evaluate EP-flux from Eq. 7 and give the right orientation to
-       ! the stress
-
-       DO JW = 1, NW
-          RUWP(JW, :) = SIGN(1., ZOP(JW, :))*COS(ZP(JW, :)) * WWP(JW, :)
-          RVWP(JW, :) = SIGN(1., ZOP(JW, :))*SIN(ZP(JW, :)) * WWP(JW, :)
-       end DO
-
-       RUW(:, LL + 1) = 0.
-       RVW(:, LL + 1) = 0.
-
-       DO JW = 1, NW
-          RUW(:, LL + 1) = RUW(:, LL + 1) + RUWP(JW, :) 
-          RVW(:, LL + 1) = RVW(:, LL + 1) + RVWP(JW, :) 
-          EAST_GWSTRESS(:, LL)=EAST_GWSTRESS(:, LL)+MAX(0.,RUWP(JW,:))/FLOAT(NW)
-          WEST_GWSTRESS(:, LL)=WEST_GWSTRESS(:, LL)+MIN(0.,RUWP(JW,:))/FLOAT(NW)
-       end DO
-    end DO
-! OFFLINE ONLY
-!   PRINT *,'SAT PROFILE:'
-!   DO LL=1,KLEV
-!   PRINT *,ZH(KLON/2,LL)/1000.,SAT*(2.+TANH(ZH(KLON/2,LL)/H0-8.))
-!   ENDDO
-
-    ! 5 CALCUL DES TENDANCES:
-
-    ! 5.1 Rectification des flux au sommet et dans les basses couches
-
-    RUW(:, KLEV + 1) = 0.
-    RVW(:, KLEV + 1) = 0.
-    RUW(:, 1) = RUW(:, LAUNCH)
-    RVW(:, 1) = RVW(:, LAUNCH)
-    DO LL = 1, LAUNCH
-       RUW(:, LL) = RUW(:, LAUNCH+1)
-       RVW(:, LL) = RVW(:, LAUNCH+1)
-       EAST_GWSTRESS(:, LL)  = EAST_GWSTRESS(:, LAUNCH)
-       WEST_GWSTRESS(:, LL)  = WEST_GWSTRESS(:, LAUNCH)
-    end DO
-
-    ! AR-1 RECURSIVE FORMULA (13) IN VERSION 4
-    DO LL = 1, KLEV
-       D_U(:, LL) = (1.-DTIME/DELTAT) * D_U(:, LL) + DTIME/DELTAT/REAL(NW) * &
-            RG * (RUW(:, LL + 1) - RUW(:, LL)) &
-            / (PH(:, LL + 1) - PH(:, LL)) * DTIME
-       ! NO AR-1 FOR MERIDIONAL TENDENCIES
-       D_V(:, LL) =                                            1./REAL(NW) * &
-            RG * (RVW(:, LL + 1) - RVW(:, LL)) &
-            / (PH(:, LL + 1) - PH(:, LL)) * DTIME
-    ENDDO
-
-    ! Cosmetic: evaluation of the cumulated stress
-    ZUSTR = 0.
-    ZVSTR = 0.
-    DO LL = 1, KLEV
-       ZUSTR = ZUSTR + D_U(:, LL) / RG * (PH(:, LL + 1) - PH(:, LL))/DTIME
-       ZVSTR = ZVSTR + D_V(:, LL) / RG * (PH(:, LL + 1) - PH(:, LL))/DTIME
-    ENDDO
-
-
-  END SUBROUTINE FLOTT_GWD_RANDO
-
-end module FLOTT_GWD_rando_m
Index: /LMDZ6/trunk/libf/phylmd/flott_gwd_rando_m.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/flott_gwd_rando_m.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/flott_gwd_rando_m.f90	(revision 5268)
@@ -0,0 +1,460 @@
+!
+! $Id$
+!
+module FLOTT_GWD_rando_m
+
+  implicit none
+
+contains
+
+  SUBROUTINE FLOTT_GWD_rando(DTIME, pp, tt, uu, vv, prec, zustr, zvstr, d_u, &
+       d_v,east_gwstress,west_gwstress)
+
+    ! Parametrization of the momentum flux deposition due to a discrete
+    ! number of gravity waves. 
+    ! Author: F. Lott
+    ! July, 12th, 2012
+    ! Gaussian distribution of the source, source is precipitation
+    ! Reference: Lott (JGR, vol 118, page 8897, 2013)
+
+    !ONLINE:
+      use dimphy, only: klon, klev
+      use assert_m, only: assert
+      USE ioipsl_getin_p_mod, ONLY : getin_p
+      USE vertical_layers_mod, ONLY : presnivs
+      CHARACTER (LEN=20) :: modname='flott_gwd_rando'
+      CHARACTER (LEN=80) :: abort_message
+
+      include "YOMCST.h"
+      include "clesphys.h"
+    ! OFFLINE:
+    ! include "dimensions.h"
+    ! include "dimphy.h"
+    ! END OF DIFFERENCE ONLINE-OFFLINE
+    include "YOEGWD.h"
+
+    ! 0. DECLARATIONS:
+
+    ! 0.1 INPUTS
+    REAL, intent(in)::DTIME ! Time step of the Physics
+    REAL, intent(in):: pp(:, :) ! (KLON, KLEV) Pressure at full levels
+    REAL, intent(in):: prec(:) ! (klon) Precipitation (kg/m^2/s) 
+    REAL, intent(in):: TT(:, :) ! (KLON, KLEV) Temp at full levels 
+    REAL, intent(in):: UU(:, :) ! (KLON, KLEV) Zonal wind at full levels
+    REAL, intent(in):: VV(:, :) ! (KLON, KLEV) Merid wind at full levels
+
+    ! 0.2 OUTPUTS
+    REAL, intent(out):: zustr(:), zvstr(:) ! (KLON) Surface Stresses
+
+    REAL, intent(inout):: d_u(:, :), d_v(:, :) 
+    REAL, intent(inout):: east_gwstress(:, :) !  Profile of eastward stress
+    REAL, intent(inout):: west_gwstress(:, :) !  Profile of westward stress 
+
+    ! (KLON, KLEV) tendencies on winds
+
+    ! O.3 INTERNAL ARRAYS
+    REAL BVLOW(klon)
+    REAL DZ   !  Characteristic depth of the Source
+
+    INTEGER II, JJ, LL
+
+    ! 0.3.0 TIME SCALE OF THE LIFE CYCLE OF THE WAVES PARAMETERIZED
+
+    REAL DELTAT
+
+    ! 0.3.1 GRAVITY-WAVES SPECIFICATIONS
+
+    INTEGER, PARAMETER:: NK = 2, NP = 2, NO = 2, NW = NK * NP * NO
+    INTEGER JK, JP, JO, JW
+    INTEGER, PARAMETER:: NA = 5  !number of realizations to get the phase speed
+    REAL KMIN, KMAX ! Min and Max horizontal wavenumbers
+    REAL CMAX ! standard deviation of the phase speed distribution
+    REAL RUWMAX,SAT  ! ONLINE SPECIFIED IN run.def
+    REAL CPHA ! absolute PHASE VELOCITY frequency
+    REAL ZK(NW, KLON) ! Horizontal wavenumber amplitude
+    REAL ZP(NW, KLON) ! Horizontal wavenumber angle 
+    REAL ZO(NW, KLON) ! Absolute frequency !
+
+    ! Waves Intr. freq. at the 1/2 lev surrounding the full level
+    REAL ZOM(NW, KLON), ZOP(NW, KLON)
+
+    ! Wave EP-fluxes at the 2 semi levels surrounding the full level
+    REAL WWM(NW, KLON), WWP(NW, KLON)
+
+    REAL RUW0(NW, KLON) ! Fluxes at launching level
+
+    REAL RUWP(NW, KLON), RVWP(NW, KLON)
+    ! Fluxes X and Y for each waves at 1/2 Levels
+
+    INTEGER LAUNCH, LTROP ! Launching altitude and tropo altitude
+
+    REAL XLAUNCH ! Controle the launching altitude
+    REAL XTROP ! SORT of Tropopause altitude 
+    REAL RUW(KLON, KLEV + 1) ! Flux x at semi levels
+    REAL RVW(KLON, KLEV + 1) ! Flux y at semi levels
+
+    REAL PRMAX ! Maximum value of PREC, and for which our linear formula
+    ! for GWs parameterisation apply
+
+    ! 0.3.2 PARAMETERS OF WAVES DISSIPATIONS
+
+    REAL RDISS, ZOISEC ! COEFF DE DISSIPATION, SECURITY FOR INTRINSIC FREQ
+
+    ! 0.3.3 BACKGROUND FLOW AT 1/2 LEVELS AND VERTICAL COORDINATE
+
+    REAL H0 ! Characteristic Height of the atmosphere
+    REAL PR, TR ! Reference Pressure and Temperature
+
+    REAL ZH(KLON, KLEV + 1) ! Log-pressure altitude
+
+    REAL UH(KLON, KLEV + 1), VH(KLON, KLEV + 1) ! Winds at 1/2 levels
+    REAL PH(KLON, KLEV + 1) ! Pressure at 1/2 levels
+    REAL PSEC ! Security to avoid division by 0 pressure
+    REAL BV(KLON, KLEV + 1) ! Brunt Vaisala freq. (BVF) at 1/2 levels
+    REAL BVSEC ! Security to avoid negative BVF
+    REAL RAN_NUM_1,RAN_NUM_2,RAN_NUM_3
+
+    REAL, DIMENSION(klev+1) ::HREF
+
+    LOGICAL, SAVE :: gwd_reproductibilite_mpiomp=.true.
+    LOGICAL, SAVE :: firstcall = .TRUE.
+  !$OMP THREADPRIVATE(firstcall,gwd_reproductibilite_mpiomp)
+
+
+  IF (firstcall) THEN
+    ! Cle introduite pour resoudre un probleme de non reproductibilite
+    ! Le but est de pouvoir tester de revenir a la version precedenete
+    ! A eliminer rapidement
+    CALL getin_p('gwd_reproductibilite_mpiomp',gwd_reproductibilite_mpiomp)
+    IF (NW+3*NA>=KLEV) THEN
+       abort_message = 'NW+3*NA>=KLEV Probleme pour generation des ondes'
+       CALL abort_physic (modname,abort_message,1)
+    ENDIF
+    firstcall=.false.
+  ENDIF
+
+
+    !-----------------------------------------------------------------
+
+    ! 1. INITIALISATIONS
+
+    ! 1.1 Basic parameter
+
+    ! Are provided from elsewhere (latent heat of vaporization, dry
+    ! gaz constant for air, gravity constant, heat capacity of dry air
+    ! at constant pressure, earth rotation rate, pi).
+
+    ! 1.2 Tuning parameters of V14
+
+    
+    RDISS = 0.5 ! Diffusion parameter
+    ! ONLINE 
+      RUWMAX=GWD_RANDO_RUWMAX
+      SAT=gwd_rando_sat
+    !END ONLINE
+    ! OFFLINE
+    ! RUWMAX= 1.75    ! Launched flux
+    ! SAT=0.25     ! Saturation parameter
+    ! END OFFLINE
+
+    PRMAX = 20. / 24. /3600.
+    ! maximum of rain for which our theory applies (in kg/m^2/s)
+
+ ! Characteristic depth of the source
+    DZ = 1000.
+    XLAUNCH=0.5 ! Parameter that control launching altitude
+    XTROP=0.2 ! Parameter that control tropopause altitude
+    DELTAT=24.*3600. ! Time scale of the waves (first introduced in 9b)
+    !  OFFLINE
+    !  DELTAT=DTIME
+    !  END OFFLINE
+
+    KMIN = 2.E-5
+    ! minimum horizontal wavenumber (inverse of the subgrid scale resolution)
+
+    KMAX = 1.E-3 ! Max horizontal wavenumber
+    CMAX = 30. ! Max phase speed velocity
+
+    TR = 240. ! Reference Temperature
+    PR = 101300. ! Reference pressure
+    H0 = RD * TR / RG ! Characteristic vertical scale height
+
+    BVSEC = 5.E-3 ! Security to avoid negative BVF 
+    PSEC = 1.E-6 ! Security to avoid division by 0 pressure
+    ZOISEC = 1.E-6 ! Security FOR 0 INTRINSIC FREQ
+
+IF (1==0) THEN
+    !ONLINE
+        call assert(klon == (/size(pp, 1), size(tt, 1), size(uu, 1), &
+         size(vv, 1), size(zustr), size(zvstr), size(d_u, 1), &
+         size(d_v, 1), &
+         size(east_gwstress, 1), size(west_gwstress, 1) /), &
+         "FLOTT_GWD_RANDO klon")
+     call assert(klev == (/size(pp, 2), size(tt, 2), size(uu, 2), &
+          size(vv, 2), size(d_u, 2), size(d_v, 2), &
+          size(east_gwstress,2), size(west_gwstress,2) /), &
+          "FLOTT_GWD_RANDO klev")
+    !END ONLINE
+ENDIF
+
+    IF(DELTAT < DTIME)THEN
+       abort_message='flott_gwd_rando: deltat < dtime!'
+       CALL abort_physic(modname,abort_message,1)
+    ENDIF
+
+    IF (KLEV < NW) THEN
+       abort_message='flott_gwd_rando: you will have problem with random numbers'
+       CALL abort_physic(modname,abort_message,1)
+    ENDIF
+
+    ! 2. EVALUATION OF THE BACKGROUND FLOW AT SEMI-LEVELS
+
+    ! Pressure and Inv of pressure
+    DO LL = 2, KLEV
+       PH(:, LL) = EXP((LOG(PP(:, LL)) + LOG(PP(:, LL - 1))) / 2.)
+    end DO
+    PH(:, KLEV + 1) = 0. 
+    PH(:, 1) = 2. * PP(:, 1) - PH(:, 2)
+
+    ! Launching altitude
+
+    !Pour revenir a la version non reproductible en changeant le nombre de process
+    IF (gwd_reproductibilite_mpiomp) THEN
+       ! Reprend la formule qui calcule PH en fonction de PP=play
+       DO LL = 2, KLEV
+          HREF(LL) = EXP((LOG(presnivs(LL)) + LOG(presnivs(LL - 1))) / 2.)
+       end DO
+       HREF(KLEV + 1) = 0.
+       HREF(1) = 2. * presnivs(1) - HREF(2)
+    ELSE
+       HREF(1:KLEV)=PH(KLON/2,1:KLEV)
+    ENDIF
+
+    LAUNCH=0
+    LTROP =0
+    DO LL = 1, KLEV
+       IF (HREF(LL) / HREF(1) > XLAUNCH) LAUNCH = LL
+    ENDDO
+    DO LL = 1, KLEV
+       IF (HREF(LL) / HREF(1) > XTROP) LTROP = LL
+    ENDDO
+    !LAUNCH=22 ; LTROP=33
+!   print*,'LAUNCH=',LAUNCH,'LTROP=',LTROP
+
+    ! Log pressure vert. coordinate
+    DO LL = 1, KLEV + 1 
+       ZH(:, LL) = H0 * LOG(PR / (PH(:, LL) + PSEC))
+    end DO
+
+    ! BV frequency
+    DO LL = 2, KLEV
+       ! BVSEC: BV Frequency (UH USED IS AS A TEMPORARY ARRAY DOWN TO WINDS)
+       UH(:, LL) = 0.5 * (TT(:, LL) + TT(:, LL - 1)) &
+            * RD**2 / RCPD / H0**2 + (TT(:, LL) &
+            - TT(:, LL - 1)) / (ZH(:, LL) - ZH(:, LL - 1)) * RD / H0
+    end DO
+    BVLOW(:) = 0.5 * (TT(:, LTROP )+ TT(:, LAUNCH)) &
+         * RD**2 / RCPD / H0**2 + (TT(:, LTROP ) &
+         - TT(:, LAUNCH))/(ZH(:, LTROP )- ZH(:, LAUNCH)) * RD / H0
+
+    UH(:, 1) = UH(:, 2)
+    UH(:, KLEV + 1) = UH(:, KLEV)
+    BV(:, 1) = UH(:, 2)
+    BV(:, KLEV + 1) = UH(:, KLEV)
+    ! SMOOTHING THE BV HELPS
+    DO LL = 2, KLEV
+       BV(:, LL)=(UH(:, LL+1)+2.*UH(:, LL)+UH(:, LL-1))/4.
+    end DO
+
+    BV=MAX(SQRT(MAX(BV, 0.)), BVSEC)
+    BVLOW=MAX(SQRT(MAX(BVLOW, 0.)), BVSEC)
+
+
+    ! WINDS
+    DO LL = 2, KLEV
+       UH(:, LL) = 0.5 * (UU(:, LL) + UU(:, LL - 1)) ! Zonal wind
+       VH(:, LL) = 0.5 * (VV(:, LL) + VV(:, LL - 1)) ! Meridional wind
+    end DO
+    UH(:, 1) = 0.
+    VH(:, 1) = 0.
+    UH(:, KLEV + 1) = UU(:, KLEV)
+    VH(:, KLEV + 1) = VV(:, KLEV)
+
+    ! 3 WAVES CHARACTERISTICS CHOSEN RANDOMLY AT THE LAUNCH ALTITUDE
+
+    ! The mod functions of weird arguments are used to produce the
+    ! waves characteristics in an almost stochastic way
+
+    DO JW = 1, NW
+             ! Angle
+             DO II = 1, KLON
+                ! Angle (0 or PI so far)
+                RAN_NUM_1=MOD(TT(II, JW) * 10., 1.)
+                RAN_NUM_2= MOD(TT(II, JW) * 100., 1.)
+                ZP(JW, II) = (SIGN(1., 0.5 - RAN_NUM_1) + 1.) &
+                     * RPI / 2.
+                ! Horizontal wavenumber amplitude
+                ZK(JW, II) = KMIN + (KMAX - KMIN) *RAN_NUM_2
+                ! Horizontal phase speed
+                CPHA = 0.
+                DO JJ = 1, NA
+                    RAN_NUM_3=MOD(TT(II, JW+3*JJ)**2, 1.)
+                    CPHA = CPHA + &
+                    CMAX*2.*(RAN_NUM_3 -0.5)*SQRT(3.)/SQRT(NA*1.)
+                END DO
+                IF (CPHA.LT.0.)  THEN
+                   CPHA = -1.*CPHA
+                   ZP(JW,II) = ZP(JW,II) + RPI
+                ENDIF
+                ! Absolute frequency is imposed
+                ZO(JW, II) = CPHA * ZK(JW, II) 
+                ! Intrinsic frequency is imposed
+                ZO(JW, II) = ZO(JW, II) &
+                     + ZK(JW, II) * COS(ZP(JW, II)) * UH(II, LAUNCH) &
+                     + ZK(JW, II) * SIN(ZP(JW, II)) * VH(II, LAUNCH)
+                ! Momentum flux at launch lev 
+                RUW0(JW, II) = RUWMAX
+             ENDDO
+    ENDDO
+
+    ! 4. COMPUTE THE FLUXES
+
+    ! 4.1 Vertical velocity at launching altitude to ensure 
+    ! the correct value to the imposed fluxes.
+
+    DO JW = 1, NW
+
+       ! Evaluate intrinsic frequency at launching altitude:
+       ZOP(JW, :) = ZO(JW, :) &
+            - ZK(JW, :) * COS(ZP(JW, :)) * UH(:, LAUNCH) &
+            - ZK(JW, :) * SIN(ZP(JW, :)) * VH(:, LAUNCH) 
+
+       ! VERSION WITH CONVECTIVE SOURCE
+
+       ! Vertical velocity at launch level, value to ensure the
+       ! imposed factor related to the convective forcing:
+       ! precipitations.
+
+       ! tanh limitation to values above prmax:
+       WWP(JW, :) = RUW0(JW, :) &
+            * (RD / RCPD / H0 * RLVTT * PRMAX * TANH(PREC(:) / PRMAX))**2
+
+       ! Factor related to the characteristics of the waves:
+       WWP(JW, :) = WWP(JW, :) * ZK(JW, :)**3 / KMIN / BVLOW(:)  &
+            / MAX(ABS(ZOP(JW, :)), ZOISEC)**3 
+
+       ! Moderation by the depth of the source (dz here):
+       WWP(JW, :) = WWP(JW, :) &
+            * EXP(- BVLOW(:)**2 / MAX(ABS(ZOP(JW, :)), ZOISEC)**2 * ZK(JW, :)**2 &
+            * DZ**2)
+
+       ! Put the stress in the right direction:
+       RUWP(JW, :) = ZOP(JW, :) / MAX(ABS(ZOP(JW, :)), ZOISEC)**2 &
+            * BV(:, LAUNCH) * COS(ZP(JW, :)) * WWP(JW, :)**2
+       RVWP(JW, :) = ZOP(JW, :) / MAX(ABS(ZOP(JW, :)), ZOISEC)**2 &
+            * BV(:, LAUNCH) * SIN(ZP(JW, :)) * WWP(JW, :)**2
+    end DO
+
+
+    ! 4.2 Uniform values below the launching altitude
+
+    DO LL = 1, LAUNCH
+       RUW(:, LL) = 0
+       RVW(:, LL) = 0
+       DO JW = 1, NW
+          RUW(:, LL) = RUW(:, LL) + RUWP(JW, :)
+          RVW(:, LL) = RVW(:, LL) + RVWP(JW, :)
+       end DO
+    end DO
+
+    ! 4.3 Loop over altitudes, with passage from one level to the next
+    ! done by i) conserving the EP flux, ii) dissipating a little,
+    ! iii) testing critical levels, and vi) testing the breaking.
+
+    DO LL = LAUNCH, KLEV - 1
+       ! Warning: all the physics is here (passage from one level
+       ! to the next)
+       DO JW = 1, NW
+          ZOM(JW, :) = ZOP(JW, :)
+          WWM(JW, :) = WWP(JW, :)
+          ! Intrinsic Frequency
+          ZOP(JW, :) = ZO(JW, :) - ZK(JW, :) * COS(ZP(JW, :)) * UH(:, LL + 1) &
+               - ZK(JW, :) * SIN(ZP(JW, :)) * VH(:, LL + 1) 
+
+          ! No breaking (Eq.6)
+          ! Dissipation (Eq. 8)
+          WWP(JW, :) = WWM(JW, :) * EXP(- 4. * RDISS * PR / (PH(:, LL + 1) &
+               + PH(:, LL)) * ((BV(:, LL + 1) + BV(:, LL)) / 2.)**3 &
+               / MAX(ABS(ZOP(JW, :) + ZOM(JW, :)) / 2., ZOISEC)**4 &
+               * ZK(JW, :)**3 * (ZH(:, LL + 1) - ZH(:, LL)))
+
+          ! Critical levels (forced to zero if intrinsic frequency changes sign)
+          ! Saturation (Eq. 12)
+          WWP(JW, :) = min(WWP(JW, :), MAX(0., &
+               SIGN(1., ZOP(JW, :) * ZOM(JW, :))) * ABS(ZOP(JW, :))**3 &
+               / BV(:, LL + 1) * EXP(- ZH(:, LL + 1) / H0) * KMIN**2  &
+               * SAT**2 / ZK(JW, :)**4)
+       end DO
+
+       ! Evaluate EP-flux from Eq. 7 and give the right orientation to
+       ! the stress
+
+       DO JW = 1, NW
+          RUWP(JW, :) = SIGN(1., ZOP(JW, :))*COS(ZP(JW, :)) * WWP(JW, :)
+          RVWP(JW, :) = SIGN(1., ZOP(JW, :))*SIN(ZP(JW, :)) * WWP(JW, :)
+       end DO
+
+       RUW(:, LL + 1) = 0.
+       RVW(:, LL + 1) = 0.
+
+       DO JW = 1, NW
+          RUW(:, LL + 1) = RUW(:, LL + 1) + RUWP(JW, :) 
+          RVW(:, LL + 1) = RVW(:, LL + 1) + RVWP(JW, :) 
+          EAST_GWSTRESS(:, LL)=EAST_GWSTRESS(:, LL)+MAX(0.,RUWP(JW,:))/FLOAT(NW)
+          WEST_GWSTRESS(:, LL)=WEST_GWSTRESS(:, LL)+MIN(0.,RUWP(JW,:))/FLOAT(NW)
+       end DO
+    end DO
+! OFFLINE ONLY
+!   PRINT *,'SAT PROFILE:'
+!   DO LL=1,KLEV
+!   PRINT *,ZH(KLON/2,LL)/1000.,SAT*(2.+TANH(ZH(KLON/2,LL)/H0-8.))
+!   ENDDO
+
+    ! 5 CALCUL DES TENDANCES:
+
+    ! 5.1 Rectification des flux au sommet et dans les basses couches
+
+    RUW(:, KLEV + 1) = 0.
+    RVW(:, KLEV + 1) = 0.
+    RUW(:, 1) = RUW(:, LAUNCH)
+    RVW(:, 1) = RVW(:, LAUNCH)
+    DO LL = 1, LAUNCH
+       RUW(:, LL) = RUW(:, LAUNCH+1)
+       RVW(:, LL) = RVW(:, LAUNCH+1)
+       EAST_GWSTRESS(:, LL)  = EAST_GWSTRESS(:, LAUNCH)
+       WEST_GWSTRESS(:, LL)  = WEST_GWSTRESS(:, LAUNCH)
+    end DO
+
+    ! AR-1 RECURSIVE FORMULA (13) IN VERSION 4
+    DO LL = 1, KLEV
+       D_U(:, LL) = (1.-DTIME/DELTAT) * D_U(:, LL) + DTIME/DELTAT/REAL(NW) * &
+            RG * (RUW(:, LL + 1) - RUW(:, LL)) &
+            / (PH(:, LL + 1) - PH(:, LL)) * DTIME
+       ! NO AR-1 FOR MERIDIONAL TENDENCIES
+       D_V(:, LL) =                                            1./REAL(NW) * &
+            RG * (RVW(:, LL + 1) - RVW(:, LL)) &
+            / (PH(:, LL + 1) - PH(:, LL)) * DTIME
+    ENDDO
+
+    ! Cosmetic: evaluation of the cumulated stress
+    ZUSTR = 0.
+    ZVSTR = 0.
+    DO LL = 1, KLEV
+       ZUSTR = ZUSTR + D_U(:, LL) / RG * (PH(:, LL + 1) - PH(:, LL))/DTIME
+       ZVSTR = ZVSTR + D_V(:, LL) / RG * (PH(:, LL + 1) - PH(:, LL))/DTIME
+    ENDDO
+
+
+  END SUBROUTINE FLOTT_GWD_RANDO
+
+end module FLOTT_GWD_rando_m
Index: DZ6/trunk/libf/phylmd/flxtr.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/flxtr.F90	(revision 5267)
+++ 	(revision )
@@ -1,202 +1,0 @@
-
-! $Header$
-
-SUBROUTINE flxtr(pdtime, pmfu, pmfd, pen_u, pde_u, pen_d, pde_d, pt, pplay, &
-    paprs, kcbot, kctop, kdtop, x, dx)
-  USE dimphy
-  IMPLICIT NONE
-  ! =====================================================================
-  ! Objet : Melange convectif de traceurs a partir des flux de masse
-  ! Date : 13/12/1996 -- 13/01/97
-  ! Auteur: O. Boucher (LOA) sur inspiration de Z. X. Li (LMD),
-  ! Brinkop et Sausen (1996) et Boucher et al. (1996).
-  ! ATTENTION : meme si cette routine se veut la plus generale possible,
-  ! elle a herite de certaines notations et conventions du
-  ! schema de Tiedtke (1993).
-  ! --En particulier, les couches sont numerotees de haut en bas !!!
-  ! Ceci est valable pour les flux, kcbot, kctop et kdtop
-  ! mais pas pour les entrees x, pplay, paprs !!!!
-  ! --Un schema amont est choisi pour calculer les flux pour s'assurer
-  ! de la positivite des valeurs de traceurs, cela implique des eqs
-  ! differentes pour les flux de traceurs montants et descendants.
-  ! --pmfu est positif, pmfd est negatif
-  ! --Tous les flux d'entrainements et de detrainements sont positifs
-  ! contrairement au schema de Tiedtke d'ou les changements de signe!!!!
-  ! =====================================================================
-
-  include "YOMCST.h"
-  include "YOECUMF.h"
-
-  REAL pdtime
-  ! --les flux sont definis au 1/2 niveaux
-  ! --pmfu(klev+1) et pmfd(klev+1) sont implicitement nuls
-  REAL pmfu(klon, klev) ! flux de masse dans le panache montant
-  REAL pmfd(klon, klev) ! flux de masse dans le panache descendant
-  REAL pen_u(klon, klev) ! flux entraine dans le panache montant
-  REAL pde_u(klon, klev) ! flux detraine dans le panache montant
-  REAL pen_d(klon, klev) ! flux entraine dans le panache descendant
-  REAL pde_d(klon, klev) ! flux detraine dans le panache descendant
-  ! --idem mais en variables locales
-  REAL zpen_u(klon, klev)
-  REAL zpde_u(klon, klev)
-  REAL zpen_d(klon, klev)
-  REAL zpde_d(klon, klev)
-
-  REAL pplay(klon, klev) ! pression aux couches (bas en haut)
-  REAL pap(klon, klev) ! pression aux couches (haut en bas)
-  REAL pt(klon, klev) ! temperature aux couches (bas en haut)
-  REAL zt(klon, klev) ! temperature aux couches (haut en bas)
-  REAL paprs(klon, klev+1) ! pression aux 1/2 couches (bas en haut)
-  REAL paph(klon, klev+1) ! pression aux 1/2 couches (haut en bas)
-  INTEGER kcbot(klon) ! niveau de base de la convection
-  INTEGER kctop(klon) ! niveau du sommet de la convection +1
-  INTEGER kdtop(klon) ! niveau de sommet du panache descendant
-  REAL x(klon, klev) ! q de traceur (bas en haut)
-  REAL zx(klon, klev) ! q de traceur (haut en bas)
-  REAL dx(klon, klev) ! tendance de traceur  (bas en haut)
-
-  ! --variables locales
-  ! --les flux de x sont definis aux 1/2 niveaux
-  ! --xu et xd sont definis aux niveaux complets
-  REAL xu(klon, klev) ! q de traceurs dans le panache montant
-  REAL xd(klon, klev) ! q de traceurs dans le panache descendant
-  REAL xe(klon, klev) ! q de traceurs dans l'environnement
-  REAL zmfux(klon, klev+1) ! flux de x dans le panache montant
-  REAL zmfdx(klon, klev+1) ! flux de x dans le panache descendant
-  REAL zmfex(klon, klev+1) ! flux de x dans l'environnement
-  INTEGER i, k
-  REAL zmfmin
-  PARAMETER (zmfmin=1.E-10)
-
-  ! On remet les taux d'entrainement et de detrainement dans le panache
-  ! descendant a des valeurs positives.
-  ! On ajuste les valeurs de pen_u, pen_d pde_u et pde_d pour que la
-  ! conservation de la masse soit realisee a chaque niveau dans les 2
-  ! panaches.
-  DO k = 1, klev
-    DO i = 1, klon
-      zpen_u(i, k) = pen_u(i, k)
-      zpde_u(i, k) = pde_u(i, k)
-    END DO
-  END DO
-
-  DO k = 1, klev - 1
-    DO i = 1, klon
-      zpen_d(i, k) = -pen_d(i, k+1)
-      zpde_d(i, k) = -pde_d(i, k+1)
-    END DO
-  END DO
-
-  DO i = 1, klon
-    zpen_d(i, klev) = 0.0
-    zpde_d(i, klev) = -pmfd(i, klev)
-    ! Correction 03 11 97
-    ! zpen_d(i,kdtop(i)-1) = pmfd(i,kdtop(i)-1)-pmfd(i,kdtop(i))
-    IF (kdtop(i)==klev+1) THEN
-      zpen_d(i, kdtop(i)-1) = pmfd(i, kdtop(i)-1)
-    ELSE
-      zpen_d(i, kdtop(i)-1) = pmfd(i, kdtop(i)-1) - pmfd(i, kdtop(i))
-    END IF
-
-    zpde_u(i, kctop(i)-2) = pmfu(i, kctop(i)-1)
-    zpen_u(i, klev) = pmfu(i, klev)
-  END DO
-
-  DO i = 1, klon
-    DO k = kcbot(i), klev - 1
-      zpen_u(i, k) = pmfu(i, k) - pmfu(i, k+1)
-    END DO
-  END DO
-
-  ! conversion des sens de notations bas-haut et haut-bas
-
-  DO k = 1, klev + 1
-    DO i = 1, klon
-      paph(i, klev+2-k) = paprs(i, k)
-    END DO
-  END DO
-
-  DO i = 1, klon
-    DO k = 1, klev
-      pap(i, klev+1-k) = pplay(i, k)
-      zt(i, klev+1-k) = pt(i, k)
-      zx(i, klev+1-k) = x(i, k)
-    END DO
-  END DO
-
-  ! --initialisations des flux de traceurs aux extremites de la colonne
-
-  DO i = 1, klon
-    zmfux(i, klev+1) = 0.0
-    zmfdx(i, 1) = 0.0
-    zmfex(i, 1) = 0.0
-  END DO
-
-  ! --calcul des flux dans le panache montant
-
-  DO k = klev, 1, -1
-    DO i = 1, klon
-      IF (k>=kcbot(i)) THEN
-        xu(i, k) = zx(i, k)
-        zmfux(i, k) = pmfu(i, k)*xu(i, k)
-      ELSE
-        zmfux(i, k) = (zmfux(i,k+1)+zpen_u(i,k)*zx(i,k))/ &
-          (1.+zpde_u(i,k)/max(zmfmin,pmfu(i,k)))
-        xu(i, k) = zmfux(i, k)/max(zmfmin, pmfu(i,k))
-      END IF
-    END DO
-  END DO
-
-  ! --calcul des flux dans le panache descendant
-
-  DO k = 1, klev - 1
-    DO i = 1, klon
-      IF (k<=kdtop(i)-1) THEN
-        xd(i, k) = (zx(i,k)+xu(i,k))/2.
-        zmfdx(i, k+1) = pmfd(i, k+1)*xd(i, k)
-      ELSE
-        zmfdx(i, k+1) = (zmfdx(i,k)-zpen_d(i,k)*zx(i,k))/ &
-          (1.-zpde_d(i,k)/min(-zmfmin,pmfd(i,k+1)))
-        xd(i, k) = zmfdx(i, k+1)/min(-zmfmin, pmfd(i,k+1))
-      END IF
-    END DO
-  END DO
-  DO i = 1, klon
-    zmfdx(i, klev+1) = 0.0
-    xd(i, klev) = (zpen_d(i,klev)*zx(i,klev)-zmfdx(i,klev))/ &
-      max(zmfmin, zpde_d(i,klev))
-  END DO
-
-  ! --introduction du flux de retour dans l'environnement
-
-  DO k = 1, klev - 1
-    DO i = 1, klon
-      IF (k<=kctop(i)-3) THEN
-        xe(i, k) = zx(i, k)
-        zmfex(i, k+1) = -(pmfu(i,k+1)+pmfd(i,k+1))*xe(i, k)
-      ELSE
-        zmfex(i, k+1) = (zmfex(i,k)-(zpde_u(i,k)*xu(i,k)+zpde_d(i,k)*xd(i, &
-          k)))/(1.-(zpen_d(i,k)+zpen_u(i,k))/min(-zmfmin,-pmfu(i,k+1)-pmfd(i, &
-          k+1)))
-        xe(i, k) = zmfex(i, k+1)/min(-zmfmin, -pmfu(i,k+1)-pmfd(i,k+1))
-      END IF
-    END DO
-  END DO
-  DO i = 1, klon
-    zmfex(i, klev+1) = 0.0
-    xe(i, klev) = (zpde_u(i,klev)*xu(i,klev)+zpde_d(i,klev)*xd(i,klev)-zmfex( &
-      i,klev))/max(zmfmin, zpen_u(i,klev)+zpen_d(i,klev))
-  END DO
-
-  ! --calcul final des tendances
-
-  DO k = 1, klev
-    DO i = 1, klon
-      dx(i, klev+1-k) = rg/(paph(i,k+1)-paph(i,k))*pdtime* &
-        (zmfux(i,k+1)-zmfux(i,k)+zmfdx(i,k+1)-zmfdx(i,k)+zmfex(i,k+1)- &
-        zmfex(i,k))
-    END DO
-  END DO
-
-  RETURN
-END SUBROUTINE flxtr
Index: /LMDZ6/trunk/libf/phylmd/flxtr.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/flxtr.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/flxtr.f90	(revision 5268)
@@ -0,0 +1,202 @@
+
+! $Header$
+
+SUBROUTINE flxtr(pdtime, pmfu, pmfd, pen_u, pde_u, pen_d, pde_d, pt, pplay, &
+    paprs, kcbot, kctop, kdtop, x, dx)
+  USE dimphy
+  IMPLICIT NONE
+  ! =====================================================================
+  ! Objet : Melange convectif de traceurs a partir des flux de masse
+  ! Date : 13/12/1996 -- 13/01/97
+  ! Auteur: O. Boucher (LOA) sur inspiration de Z. X. Li (LMD),
+  ! Brinkop et Sausen (1996) et Boucher et al. (1996).
+  ! ATTENTION : meme si cette routine se veut la plus generale possible,
+  ! elle a herite de certaines notations et conventions du
+  ! schema de Tiedtke (1993).
+  ! --En particulier, les couches sont numerotees de haut en bas !!!
+  ! Ceci est valable pour les flux, kcbot, kctop et kdtop
+  ! mais pas pour les entrees x, pplay, paprs !!!!
+  ! --Un schema amont est choisi pour calculer les flux pour s'assurer
+  ! de la positivite des valeurs de traceurs, cela implique des eqs
+  ! differentes pour les flux de traceurs montants et descendants.
+  ! --pmfu est positif, pmfd est negatif
+  ! --Tous les flux d'entrainements et de detrainements sont positifs
+  ! contrairement au schema de Tiedtke d'ou les changements de signe!!!!
+  ! =====================================================================
+
+  include "YOMCST.h"
+  include "YOECUMF.h"
+
+  REAL pdtime
+  ! --les flux sont definis au 1/2 niveaux
+  ! --pmfu(klev+1) et pmfd(klev+1) sont implicitement nuls
+  REAL pmfu(klon, klev) ! flux de masse dans le panache montant
+  REAL pmfd(klon, klev) ! flux de masse dans le panache descendant
+  REAL pen_u(klon, klev) ! flux entraine dans le panache montant
+  REAL pde_u(klon, klev) ! flux detraine dans le panache montant
+  REAL pen_d(klon, klev) ! flux entraine dans le panache descendant
+  REAL pde_d(klon, klev) ! flux detraine dans le panache descendant
+  ! --idem mais en variables locales
+  REAL zpen_u(klon, klev)
+  REAL zpde_u(klon, klev)
+  REAL zpen_d(klon, klev)
+  REAL zpde_d(klon, klev)
+
+  REAL pplay(klon, klev) ! pression aux couches (bas en haut)
+  REAL pap(klon, klev) ! pression aux couches (haut en bas)
+  REAL pt(klon, klev) ! temperature aux couches (bas en haut)
+  REAL zt(klon, klev) ! temperature aux couches (haut en bas)
+  REAL paprs(klon, klev+1) ! pression aux 1/2 couches (bas en haut)
+  REAL paph(klon, klev+1) ! pression aux 1/2 couches (haut en bas)
+  INTEGER kcbot(klon) ! niveau de base de la convection
+  INTEGER kctop(klon) ! niveau du sommet de la convection +1
+  INTEGER kdtop(klon) ! niveau de sommet du panache descendant
+  REAL x(klon, klev) ! q de traceur (bas en haut)
+  REAL zx(klon, klev) ! q de traceur (haut en bas)
+  REAL dx(klon, klev) ! tendance de traceur  (bas en haut)
+
+  ! --variables locales
+  ! --les flux de x sont definis aux 1/2 niveaux
+  ! --xu et xd sont definis aux niveaux complets
+  REAL xu(klon, klev) ! q de traceurs dans le panache montant
+  REAL xd(klon, klev) ! q de traceurs dans le panache descendant
+  REAL xe(klon, klev) ! q de traceurs dans l'environnement
+  REAL zmfux(klon, klev+1) ! flux de x dans le panache montant
+  REAL zmfdx(klon, klev+1) ! flux de x dans le panache descendant
+  REAL zmfex(klon, klev+1) ! flux de x dans l'environnement
+  INTEGER i, k
+  REAL zmfmin
+  PARAMETER (zmfmin=1.E-10)
+
+  ! On remet les taux d'entrainement et de detrainement dans le panache
+  ! descendant a des valeurs positives.
+  ! On ajuste les valeurs de pen_u, pen_d pde_u et pde_d pour que la
+  ! conservation de la masse soit realisee a chaque niveau dans les 2
+  ! panaches.
+  DO k = 1, klev
+    DO i = 1, klon
+      zpen_u(i, k) = pen_u(i, k)
+      zpde_u(i, k) = pde_u(i, k)
+    END DO
+  END DO
+
+  DO k = 1, klev - 1
+    DO i = 1, klon
+      zpen_d(i, k) = -pen_d(i, k+1)
+      zpde_d(i, k) = -pde_d(i, k+1)
+    END DO
+  END DO
+
+  DO i = 1, klon
+    zpen_d(i, klev) = 0.0
+    zpde_d(i, klev) = -pmfd(i, klev)
+    ! Correction 03 11 97
+    ! zpen_d(i,kdtop(i)-1) = pmfd(i,kdtop(i)-1)-pmfd(i,kdtop(i))
+    IF (kdtop(i)==klev+1) THEN
+      zpen_d(i, kdtop(i)-1) = pmfd(i, kdtop(i)-1)
+    ELSE
+      zpen_d(i, kdtop(i)-1) = pmfd(i, kdtop(i)-1) - pmfd(i, kdtop(i))
+    END IF
+
+    zpde_u(i, kctop(i)-2) = pmfu(i, kctop(i)-1)
+    zpen_u(i, klev) = pmfu(i, klev)
+  END DO
+
+  DO i = 1, klon
+    DO k = kcbot(i), klev - 1
+      zpen_u(i, k) = pmfu(i, k) - pmfu(i, k+1)
+    END DO
+  END DO
+
+  ! conversion des sens de notations bas-haut et haut-bas
+
+  DO k = 1, klev + 1
+    DO i = 1, klon
+      paph(i, klev+2-k) = paprs(i, k)
+    END DO
+  END DO
+
+  DO i = 1, klon
+    DO k = 1, klev
+      pap(i, klev+1-k) = pplay(i, k)
+      zt(i, klev+1-k) = pt(i, k)
+      zx(i, klev+1-k) = x(i, k)
+    END DO
+  END DO
+
+  ! --initialisations des flux de traceurs aux extremites de la colonne
+
+  DO i = 1, klon
+    zmfux(i, klev+1) = 0.0
+    zmfdx(i, 1) = 0.0
+    zmfex(i, 1) = 0.0
+  END DO
+
+  ! --calcul des flux dans le panache montant
+
+  DO k = klev, 1, -1
+    DO i = 1, klon
+      IF (k>=kcbot(i)) THEN
+        xu(i, k) = zx(i, k)
+        zmfux(i, k) = pmfu(i, k)*xu(i, k)
+      ELSE
+        zmfux(i, k) = (zmfux(i,k+1)+zpen_u(i,k)*zx(i,k))/ &
+          (1.+zpde_u(i,k)/max(zmfmin,pmfu(i,k)))
+        xu(i, k) = zmfux(i, k)/max(zmfmin, pmfu(i,k))
+      END IF
+    END DO
+  END DO
+
+  ! --calcul des flux dans le panache descendant
+
+  DO k = 1, klev - 1
+    DO i = 1, klon
+      IF (k<=kdtop(i)-1) THEN
+        xd(i, k) = (zx(i,k)+xu(i,k))/2.
+        zmfdx(i, k+1) = pmfd(i, k+1)*xd(i, k)
+      ELSE
+        zmfdx(i, k+1) = (zmfdx(i,k)-zpen_d(i,k)*zx(i,k))/ &
+          (1.-zpde_d(i,k)/min(-zmfmin,pmfd(i,k+1)))
+        xd(i, k) = zmfdx(i, k+1)/min(-zmfmin, pmfd(i,k+1))
+      END IF
+    END DO
+  END DO
+  DO i = 1, klon
+    zmfdx(i, klev+1) = 0.0
+    xd(i, klev) = (zpen_d(i,klev)*zx(i,klev)-zmfdx(i,klev))/ &
+      max(zmfmin, zpde_d(i,klev))
+  END DO
+
+  ! --introduction du flux de retour dans l'environnement
+
+  DO k = 1, klev - 1
+    DO i = 1, klon
+      IF (k<=kctop(i)-3) THEN
+        xe(i, k) = zx(i, k)
+        zmfex(i, k+1) = -(pmfu(i,k+1)+pmfd(i,k+1))*xe(i, k)
+      ELSE
+        zmfex(i, k+1) = (zmfex(i,k)-(zpde_u(i,k)*xu(i,k)+zpde_d(i,k)*xd(i, &
+          k)))/(1.-(zpen_d(i,k)+zpen_u(i,k))/min(-zmfmin,-pmfu(i,k+1)-pmfd(i, &
+          k+1)))
+        xe(i, k) = zmfex(i, k+1)/min(-zmfmin, -pmfu(i,k+1)-pmfd(i,k+1))
+      END IF
+    END DO
+  END DO
+  DO i = 1, klon
+    zmfex(i, klev+1) = 0.0
+    xe(i, klev) = (zpde_u(i,klev)*xu(i,klev)+zpde_d(i,klev)*xd(i,klev)-zmfex( &
+      i,klev))/max(zmfmin, zpen_u(i,klev)+zpen_d(i,klev))
+  END DO
+
+  ! --calcul final des tendances
+
+  DO k = 1, klev
+    DO i = 1, klon
+      dx(i, klev+1-k) = rg/(paph(i,k+1)-paph(i,k))*pdtime* &
+        (zmfux(i,k+1)-zmfux(i,k)+zmfdx(i,k+1)-zmfdx(i,k)+zmfex(i,k+1)- &
+        zmfex(i,k))
+    END DO
+  END DO
+
+  RETURN
+END SUBROUTINE flxtr
Index: DZ6/trunk/libf/phylmd/freinage.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/freinage.F90	(revision 5267)
+++ 	(revision )
@@ -1,134 +1,0 @@
-!
-! $Id$
-!
-  SUBROUTINE freinage(knon, uu, vv,  &
-       tt,veget,lai, height,ypaprs,ypplay,drag_pro,d_u,d_v)
-
-    !ONLINE:
-    use dimphy, only: klon, klev
-!    USE control, ONLY: nvm
-!    USE indice_sol_mod, only : nvm_orch
-
-    IMPLICIT NONE
-
-
-    include "YOMCST.h"
-    include "clesphys.h"
-    include "YOEGWD.h"
-!FC 
-    include "dimpft.h"
-    include "compbl.h"
-
-    ! 0. DECLARATIONS:
-
-    ! 0.1 INPUTS
-
-    REAL, DIMENSION(klon,klev), INTENT(IN)         :: ypplay
-    REAL, DIMENSION(klon,klev+1), INTENT(IN)       :: ypaprs
-
-
-     REAL, DIMENSION(klon, klev), INTENT(IN)     :: uu
-     REAL, DIMENSION(klon, klev), INTENT(IN)     :: vv
-     REAL, DIMENSION(klon, klev), INTENT(IN)     :: tt
-     REAL, DIMENSION(klon,nvm_lmdz), INTENT(IN)          :: veget,lai
-     REAL, DIMENSION(klon,nvm_lmdz), INTENT(IN)          :: height
-
-     REAL, DIMENSION(klon,klev)         :: wind
-     REAL, DIMENSION(klon, klev)        :: yzlay
-     INTEGER knon
-
-    ! 0.2 OUTPUTS
-
-      REAL, DIMENSION(klon, klev),  INTENT(OUT)       :: d_v        ! change in v
-      REAL, DIMENSION(klon, klev),  INTENT(OUT)       :: d_u        ! change in v
-    !knon nombre de points concernes 
-      REAL, DIMENSION(klon,klev)         :: sumveg        ! change in v
-    
-     REAL,  DIMENSION(klon,klev), INTENT(OUT)          :: drag_pro
-    ! (KLON, KLEV) tendencies on winds
-
-
-    INTEGER k,jv,i
-
-
-!FCCCC    REAL Cd_frein
-
-    ! 0.3.1 LOCAL VARIABLE
-
-
-    !-----------------------------------------------------------------
-
-    ! 1. INITIALISATIONS
-
-    
-!    Cd_frein = 7.5E-2 ! (0.075) ! Drag from MASSON 2009
-!FC ESSAI
-!    Cd_frein = 1.5E-2 ! (0.075) ! Drag from MASSON 2009
-!    Cd_frein = 0.005 ! (0.075) ! Drag from MASSON 2009
-
-! initialisation 
-      d_u(:,:) =0.
-      d_v(:,:) =0.
-      drag_pro(:,:) =0.
-      sumveg(:,:) =0.
-!!        print*, "Cd_frein" , Cd_frein
-      
-       wind(:,:)= sqrt(uu(:,:)*uu(:,:)+vv(:,:)*vv(:,:))
-
-       yzlay(1:knon,1)= &
-            RD*tt(1:knon,1)/(0.5*(ypaprs(1:knon,1)+ypplay(1:knon,1))) &
-            *(ypaprs(1:knon,1)-ypplay(1:knon,1))/RG
-       DO k=2,klev
-             yzlay(1:knon,k)= &
-                  yzlay(1:knon,k-1)+RD*0.5*(tt(1:knon,k-1)+tt(1:knon,k)) &
-                  /ypaprs(1:knon,k)*(ypplay(1:knon,k-1)-ypplay(1:knon,k))/RG
-       END DO
-
-!    verifier les indexes ..... 
-!!       print*, " calcul de drag_pro FC "
-   
-      do k= 1,klev
-
-      do jv=2,nvm_lmdz   !   (on peut faire 9 ?)
-
-      do i=1,knon
-
-      sumveg(i,k)= sumveg(i,k)+ veget(i,jv)
-
-!      if  ( (height(i,jv) .gt. yzlay(i,k)) .AND. (height(i,jv) .gt. 0.1) .and. LAI(i,jv).gt.0. ) then                     
-      if  ( (height(i,jv) .gt. yzlay(i,k)) .AND. (height(i,jv) .gt. 0.1) ) then                     
-!FC attention veut on le test sur le LAI ?
-         if (ifl_pbltree.eq.1) then
-      drag_pro(i,k)= drag_pro(i,k)+ &
-      veget(i,jv)
-          elseif (ifl_pbltree.eq.2) then
-      drag_pro(i,k)= drag_pro(i,k)+ &
-      6*LAI(i,jv)*veget(i,jv)*( yzlay(i,k)*(height(i,jv)-yzlay(i,k))/(height(i,jv)*height(i,jv)+ 0.01))
-          elseif (ifl_pbltree.eq.3) then
-      drag_pro(i,k)= drag_pro(i,k)+ &
-      veget(i,jv)*( yzlay(i,k)*(height(i,jv)-yzlay(i,k))/(height(i,jv)*height(i,jv)+ 0.01))
-          elseif (ifl_pbltree.eq.0) then
-          drag_pro(i,k)=0.0
-           endif
-      else
-      drag_pro(i,k)= drag_pro(i,k)
-      endif
-
-
-      enddo
-      enddo
-     enddo 
-      do k=1,klev
-        where (sumveg(1:knon,k) > 0.05 ) 
-!        drag_pro(1:knon,k)=Cd_frein*drag_pro(1:knon,k)/sumveg(1:knon,k)
-        drag_pro(1:knon,k)=Cd_frein*drag_pro(1:knon,k)
-        elsewhere
-        drag_pro(1:knon,k)=0.0
-       endwhere
-        d_u(1:knon,k) =(-1)*drag_pro(1:knon,k)*uu(1:knon,k)*wind(1:knon,k)
-        d_v(1:knon,k) =(-1)*drag_pro(1:knon,k)*vv(1:knon,k)*wind(1:knon,k)
-      enddo
-      return
-
- END SUBROUTINE freinage
-
Index: /LMDZ6/trunk/libf/phylmd/freinage.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/freinage.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/freinage.f90	(revision 5268)
@@ -0,0 +1,134 @@
+!
+! $Id$
+!
+  SUBROUTINE freinage(knon, uu, vv,  &
+       tt,veget,lai, height,ypaprs,ypplay,drag_pro,d_u,d_v)
+
+    !ONLINE:
+    use dimphy, only: klon, klev
+!    USE control, ONLY: nvm
+!    USE indice_sol_mod, only : nvm_orch
+
+    IMPLICIT NONE
+
+
+    include "YOMCST.h"
+    include "clesphys.h"
+    include "YOEGWD.h"
+!FC 
+    include "dimpft.h"
+    include "compbl.h"
+
+    ! 0. DECLARATIONS:
+
+    ! 0.1 INPUTS
+
+    REAL, DIMENSION(klon,klev), INTENT(IN)         :: ypplay
+    REAL, DIMENSION(klon,klev+1), INTENT(IN)       :: ypaprs
+
+
+     REAL, DIMENSION(klon, klev), INTENT(IN)     :: uu
+     REAL, DIMENSION(klon, klev), INTENT(IN)     :: vv
+     REAL, DIMENSION(klon, klev), INTENT(IN)     :: tt
+     REAL, DIMENSION(klon,nvm_lmdz), INTENT(IN)          :: veget,lai
+     REAL, DIMENSION(klon,nvm_lmdz), INTENT(IN)          :: height
+
+     REAL, DIMENSION(klon,klev)         :: wind
+     REAL, DIMENSION(klon, klev)        :: yzlay
+     INTEGER knon
+
+    ! 0.2 OUTPUTS
+
+      REAL, DIMENSION(klon, klev),  INTENT(OUT)       :: d_v        ! change in v
+      REAL, DIMENSION(klon, klev),  INTENT(OUT)       :: d_u        ! change in v
+    !knon nombre de points concernes 
+      REAL, DIMENSION(klon,klev)         :: sumveg        ! change in v
+    
+     REAL,  DIMENSION(klon,klev), INTENT(OUT)          :: drag_pro
+    ! (KLON, KLEV) tendencies on winds
+
+
+    INTEGER k,jv,i
+
+
+!FCCCC    REAL Cd_frein
+
+    ! 0.3.1 LOCAL VARIABLE
+
+
+    !-----------------------------------------------------------------
+
+    ! 1. INITIALISATIONS
+
+    
+!    Cd_frein = 7.5E-2 ! (0.075) ! Drag from MASSON 2009
+!FC ESSAI
+!    Cd_frein = 1.5E-2 ! (0.075) ! Drag from MASSON 2009
+!    Cd_frein = 0.005 ! (0.075) ! Drag from MASSON 2009
+
+! initialisation 
+      d_u(:,:) =0.
+      d_v(:,:) =0.
+      drag_pro(:,:) =0.
+      sumveg(:,:) =0.
+!!        print*, "Cd_frein" , Cd_frein
+      
+       wind(:,:)= sqrt(uu(:,:)*uu(:,:)+vv(:,:)*vv(:,:))
+
+       yzlay(1:knon,1)= &
+            RD*tt(1:knon,1)/(0.5*(ypaprs(1:knon,1)+ypplay(1:knon,1))) &
+            *(ypaprs(1:knon,1)-ypplay(1:knon,1))/RG
+       DO k=2,klev
+             yzlay(1:knon,k)= &
+                  yzlay(1:knon,k-1)+RD*0.5*(tt(1:knon,k-1)+tt(1:knon,k)) &
+                  /ypaprs(1:knon,k)*(ypplay(1:knon,k-1)-ypplay(1:knon,k))/RG
+       END DO
+
+!    verifier les indexes ..... 
+!!       print*, " calcul de drag_pro FC "
+   
+      do k= 1,klev
+
+      do jv=2,nvm_lmdz   !   (on peut faire 9 ?)
+
+      do i=1,knon
+
+      sumveg(i,k)= sumveg(i,k)+ veget(i,jv)
+
+!      if  ( (height(i,jv) .gt. yzlay(i,k)) .AND. (height(i,jv) .gt. 0.1) .and. LAI(i,jv).gt.0. ) then                     
+      if  ( (height(i,jv) .gt. yzlay(i,k)) .AND. (height(i,jv) .gt. 0.1) ) then                     
+!FC attention veut on le test sur le LAI ?
+         if (ifl_pbltree.eq.1) then
+      drag_pro(i,k)= drag_pro(i,k)+ &
+      veget(i,jv)
+          elseif (ifl_pbltree.eq.2) then
+      drag_pro(i,k)= drag_pro(i,k)+ &
+      6*LAI(i,jv)*veget(i,jv)*( yzlay(i,k)*(height(i,jv)-yzlay(i,k))/(height(i,jv)*height(i,jv)+ 0.01))
+          elseif (ifl_pbltree.eq.3) then
+      drag_pro(i,k)= drag_pro(i,k)+ &
+      veget(i,jv)*( yzlay(i,k)*(height(i,jv)-yzlay(i,k))/(height(i,jv)*height(i,jv)+ 0.01))
+          elseif (ifl_pbltree.eq.0) then
+          drag_pro(i,k)=0.0
+           endif
+      else
+      drag_pro(i,k)= drag_pro(i,k)
+      endif
+
+
+      enddo
+      enddo
+     enddo 
+      do k=1,klev
+        where (sumveg(1:knon,k) > 0.05 ) 
+!        drag_pro(1:knon,k)=Cd_frein*drag_pro(1:knon,k)/sumveg(1:knon,k)
+        drag_pro(1:knon,k)=Cd_frein*drag_pro(1:knon,k)
+        elsewhere
+        drag_pro(1:knon,k)=0.0
+       endwhere
+        d_u(1:knon,k) =(-1)*drag_pro(1:knon,k)*uu(1:knon,k)*wind(1:knon,k)
+        d_v(1:knon,k) =(-1)*drag_pro(1:knon,k)*vv(1:knon,k)*wind(1:knon,k)
+      enddo
+      return
+
+ END SUBROUTINE freinage
+
Index: DZ6/trunk/libf/phylmd/geo2atm.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/geo2atm.F90	(revision 5267)
+++ 	(revision )
@@ -1,80 +1,0 @@
-!
-! $Header: /home/cvsroot/LMDZ4/libf/phylmd/geo2atm.F90,v 1.1 2008-12-05 17:56:40 lsce Exp $
-!
-SUBROUTINE geo2atm(im, jm, px, py, pz, plon, plat, pu, pv, pr)
-  USE dimphy
-  USE mod_phys_lmdz_para
-  USE mod_grid_phy_lmdz, only: grid_type, unstructured, regular_lonlat
-  IMPLICIT NONE
-  INCLUDE 'YOMCST.h'
-  CHARACTER (len = 6)                :: clmodnam
-  CHARACTER (len = 20)               :: modname = 'geo2atm'
-  CHARACTER (len = 80)               :: abort_message
-
-! Change wind coordinates from cartesian geocentric to local spherical
-! NB! Fonctionne probablement uniquement en MPI seul (sans OpenMP)
-!
-! Geocentric :
-  ! axe x is eastward : crosses (0N,90E) point.
-  ! axe y  crosses (0N,180E) point.
-  ! axe z is 'up' : crosses north pole.
-!
-! NB! Aux poles, fonctionne probablement uniquement en MPI seul (sans OpenMP)
-
-  INTEGER, INTENT (IN)                 :: im, jm
-  REAL, DIMENSION (im,jm), INTENT(IN)  :: px, py, pz
-  REAL, DIMENSION (im,jm), INTENT(IN)  :: plon, plat
-  REAL, DIMENSION (im,jm), INTENT(OUT) :: pu, pv, pr
-
-  REAL :: rad,reps
-
-
-  rad = rpi / 180.0E0
-  reps = 1.0e-5
-
-  pu(:,:) = &
-       - px(:,:) * SIN(rad * plon(:,:)) &
-       + py(:,:) * COS(rad * plon(:,:))
-
-  pv(:,:) = &
-       - px(:,:) * SIN(rad * plat(:,:)) * COS(rad * plon(:,:)) &
-       - py(:,:) * SIN(rad * plat(:,:)) * SIN(rad * plon(:,:)) &
-       + pz(:,:) * COS(rad * plat(:,:))  
-
-  pr(:,:) = &
-       + px(:,:) * COS(rad * plat(:,:)) * COS(rad * plon(:,:)) &
-       + py(:,:) * COS(rad * plat(:,:)) * SIN(rad * plon(:,:)) &
-       + pz(:,:) * SIN(rad * plat(:,:))
-
-  IF (grid_type==regular_lonlat) THEN
-    ! Value at North Pole
-    IF (is_north_pole_dyn) THEN
-       pu(:, 1) = -px (1,1)
-       pv(:, 1) = -py (1,1)
-       pr(:, 1) = 0.0
-    ENDIF
-  
-    ! Value at South Pole     
-    IF (is_south_pole_dyn) THEN
-       pu(:,jm) = -px (1,jm)
-       pv(:,jm) = -py (1,jm)
-       pr(:,jm) = 0.0
-    ENDIF
-
-  ELSE IF (grid_type==unstructured) THEN
-     ! Pole nord pour Dynamico
-     WHERE ( plat(:,:) >= 90.0-reps )
-        pu(:,:) =  py(:,:)
-        pv(:,:) = -px(:,:)
-        pr(:,:) = 0.0e0
-     END WHERE
-
-  ELSE
-     abort_message='Problem: unknown grid type'
-     CALL abort_physic(modname,abort_message,1)
-  END IF
-
-  
-  
-  
-END SUBROUTINE geo2atm
Index: /LMDZ6/trunk/libf/phylmd/geo2atm.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/geo2atm.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/geo2atm.f90	(revision 5268)
@@ -0,0 +1,80 @@
+!
+! $Header: /home/cvsroot/LMDZ4/libf/phylmd/geo2atm.F90,v 1.1 2008-12-05 17:56:40 lsce Exp $
+!
+SUBROUTINE geo2atm(im, jm, px, py, pz, plon, plat, pu, pv, pr)
+  USE dimphy
+  USE mod_phys_lmdz_para
+  USE mod_grid_phy_lmdz, only: grid_type, unstructured, regular_lonlat
+  IMPLICIT NONE
+  INCLUDE 'YOMCST.h'
+  CHARACTER (len = 6)                :: clmodnam
+  CHARACTER (len = 20)               :: modname = 'geo2atm'
+  CHARACTER (len = 80)               :: abort_message
+
+! Change wind coordinates from cartesian geocentric to local spherical
+! NB! Fonctionne probablement uniquement en MPI seul (sans OpenMP)
+!
+! Geocentric :
+  ! axe x is eastward : crosses (0N,90E) point.
+  ! axe y  crosses (0N,180E) point.
+  ! axe z is 'up' : crosses north pole.
+!
+! NB! Aux poles, fonctionne probablement uniquement en MPI seul (sans OpenMP)
+
+  INTEGER, INTENT (IN)                 :: im, jm
+  REAL, DIMENSION (im,jm), INTENT(IN)  :: px, py, pz
+  REAL, DIMENSION (im,jm), INTENT(IN)  :: plon, plat
+  REAL, DIMENSION (im,jm), INTENT(OUT) :: pu, pv, pr
+
+  REAL :: rad,reps
+
+
+  rad = rpi / 180.0E0
+  reps = 1.0e-5
+
+  pu(:,:) = &
+       - px(:,:) * SIN(rad * plon(:,:)) &
+       + py(:,:) * COS(rad * plon(:,:))
+
+  pv(:,:) = &
+       - px(:,:) * SIN(rad * plat(:,:)) * COS(rad * plon(:,:)) &
+       - py(:,:) * SIN(rad * plat(:,:)) * SIN(rad * plon(:,:)) &
+       + pz(:,:) * COS(rad * plat(:,:))  
+
+  pr(:,:) = &
+       + px(:,:) * COS(rad * plat(:,:)) * COS(rad * plon(:,:)) &
+       + py(:,:) * COS(rad * plat(:,:)) * SIN(rad * plon(:,:)) &
+       + pz(:,:) * SIN(rad * plat(:,:))
+
+  IF (grid_type==regular_lonlat) THEN
+    ! Value at North Pole
+    IF (is_north_pole_dyn) THEN
+       pu(:, 1) = -px (1,1)
+       pv(:, 1) = -py (1,1)
+       pr(:, 1) = 0.0
+    ENDIF
+  
+    ! Value at South Pole     
+    IF (is_south_pole_dyn) THEN
+       pu(:,jm) = -px (1,jm)
+       pv(:,jm) = -py (1,jm)
+       pr(:,jm) = 0.0
+    ENDIF
+
+  ELSE IF (grid_type==unstructured) THEN
+     ! Pole nord pour Dynamico
+     WHERE ( plat(:,:) >= 90.0-reps )
+        pu(:,:) =  py(:,:)
+        pv(:,:) = -px(:,:)
+        pr(:,:) = 0.0e0
+     END WHERE
+
+  ELSE
+     abort_message='Problem: unknown grid type'
+     CALL abort_physic(modname,abort_message,1)
+  END IF
+
+  
+  
+  
+END SUBROUTINE geo2atm
Index: DZ6/trunk/libf/phylmd/global_mean.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/global_mean.F90	(revision 5267)
+++ 	(revision )
@@ -1,63 +1,0 @@
-  subroutine global_mean(field,airephy,laire,mfield)
-!
-! I.Musat: 05.2011
-! calcul moyenne globale d'un champ pondere par l'aire de la maille
-! (laire=.TRUE.) ou somme globale du champ (laire=.FALSE.)
-!
-  USE dimphy
-  USE mod_phys_lmdz_para, only: is_sequential
-  USE mod_phys_lmdz_transfert_para, only: reduce_sum
-  use mod_phys_lmdz_mpi_data, only: is_mpi_root
-  USE ioipsl
-  implicit none
-
-  real,dimension(klon),intent(in) :: field
-  real,dimension(klon),intent(in) :: airephy
-  LOGICAL, intent(in) :: laire
-  REAL, intent(out) :: mfield
-  REAL :: airetot     ! Total area the earth
-  REAL :: sumtmp
-  INTEGER :: i
-
-  if (is_sequential) then
-
-   airetot = 0.
-   sumtmp = 0.
-   DO i=1, klon
-    airetot = airetot + airephy(i)
-    sumtmp = sumtmp + field(i)
-   END DO
-   if (laire) THEN
-    if(airetot.NE.0.) THEN
-     mfield=sumtmp/airetot
-    endif
-   else
-    mfield=sumtmp
-   endif
-
-  else
-
-   CALL reduce_sum(SUM(airephy),airetot)
-   CALL reduce_sum(SUM(field),sumtmp)
-
-!$OMP MASTER
-  if (is_mpi_root) THEN
-  if (laire) THEN
-!  print*,'gmean airetot=',airetot
-   if(airetot.NE.0.) THEN
-    mfield=sumtmp/airetot
-!  else
-!   mfield=sumtmp
-   endif
-  else
-   mfield=sumtmp
-  endif
-
-! print*,'gmean sumtmp mfield=',sumtmp,mfield
-
-  endif !(is_mpi_root) THEN
-!$OMP END MASTER
-
-  endif
-
-  end subroutine global_mean
Index: /LMDZ6/trunk/libf/phylmd/global_mean.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/global_mean.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/global_mean.f90	(revision 5268)
@@ -0,0 +1,63 @@
+  subroutine global_mean(field,airephy,laire,mfield)
+!
+! I.Musat: 05.2011
+! calcul moyenne globale d'un champ pondere par l'aire de la maille
+! (laire=.TRUE.) ou somme globale du champ (laire=.FALSE.)
+!
+  USE dimphy
+  USE mod_phys_lmdz_para, only: is_sequential
+  USE mod_phys_lmdz_transfert_para, only: reduce_sum
+  use mod_phys_lmdz_mpi_data, only: is_mpi_root
+  USE ioipsl
+  implicit none
+
+  real,dimension(klon),intent(in) :: field
+  real,dimension(klon),intent(in) :: airephy
+  LOGICAL, intent(in) :: laire
+  REAL, intent(out) :: mfield
+  REAL :: airetot     ! Total area the earth
+  REAL :: sumtmp
+  INTEGER :: i
+
+  if (is_sequential) then
+
+   airetot = 0.
+   sumtmp = 0.
+   DO i=1, klon
+    airetot = airetot + airephy(i)
+    sumtmp = sumtmp + field(i)
+   END DO
+   if (laire) THEN
+    if(airetot.NE.0.) THEN
+     mfield=sumtmp/airetot
+    endif
+   else
+    mfield=sumtmp
+   endif
+
+  else
+
+   CALL reduce_sum(SUM(airephy),airetot)
+   CALL reduce_sum(SUM(field),sumtmp)
+
+!$OMP MASTER
+  if (is_mpi_root) THEN
+  if (laire) THEN
+!  print*,'gmean airetot=',airetot
+   if(airetot.NE.0.) THEN
+    mfield=sumtmp/airetot
+!  else
+!   mfield=sumtmp
+   endif
+  else
+   mfield=sumtmp
+  endif
+
+! print*,'gmean sumtmp mfield=',sumtmp,mfield
+
+  endif !(is_mpi_root) THEN
+!$OMP END MASTER
+
+  endif
+
+  end subroutine global_mean
Index: DZ6/trunk/libf/phylmd/gr_fi_ecrit.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/gr_fi_ecrit.F90	(revision 5267)
+++ 	(revision )
@@ -1,24 +1,0 @@
-SUBROUTINE gr_fi_ecrit(nfield,nlon,iim,jjmp1,fi,ecrit)
-  IMPLICIT none
-  !
-  ! Tranformer une variable de la grille physique a
-  ! la grille d'ecriture
-  !
-  ! WARNING: This only works on the full global grid
-  !          (ie for GCM in serial mode)
-  INTEGER nfield,nlon,iim,jjmp1, jjm
-  REAL fi(nlon,nfield), ecrit(iim*jjmp1,nfield)
-  !
-  INTEGER i, n, ig
-  !
-  jjm = jjmp1 - 1
-  DO n = 1, nfield
-     DO i=1,iim
-        ecrit(i,n) = fi(1,n)
-        ecrit(i+jjm*iim,n) = fi(nlon,n)
-     ENDDO
-     DO ig = 1, nlon - 2
-        ecrit(iim+ig,n) = fi(1+ig,n)
-     ENDDO
-  ENDDO
-END SUBROUTINE gr_fi_ecrit
Index: /LMDZ6/trunk/libf/phylmd/gr_fi_ecrit.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/gr_fi_ecrit.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/gr_fi_ecrit.f90	(revision 5268)
@@ -0,0 +1,24 @@
+SUBROUTINE gr_fi_ecrit(nfield,nlon,iim,jjmp1,fi,ecrit)
+  IMPLICIT none
+  !
+  ! Tranformer une variable de la grille physique a
+  ! la grille d'ecriture
+  !
+  ! WARNING: This only works on the full global grid
+  !          (ie for GCM in serial mode)
+  INTEGER nfield,nlon,iim,jjmp1, jjm
+  REAL fi(nlon,nfield), ecrit(iim*jjmp1,nfield)
+  !
+  INTEGER i, n, ig
+  !
+  jjm = jjmp1 - 1
+  DO n = 1, nfield
+     DO i=1,iim
+        ecrit(i,n) = fi(1,n)
+        ecrit(i+jjm*iim,n) = fi(nlon,n)
+     ENDDO
+     DO ig = 1, nlon - 2
+        ecrit(iim+ig,n) = fi(1+ig,n)
+     ENDDO
+  ENDDO
+END SUBROUTINE gr_fi_ecrit
Index: DZ6/trunk/libf/phylmd/grid_index.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/grid_index.F90	(revision 5267)
+++ 	(revision )
@@ -1,21 +1,0 @@
-function grid_index(lon_deg,lat_deg)
-!--------------------------------------------------------------------------------
-! Get local index of grid point of longitude,latitude lon_deg,lat_deg
-! Author : FH 2024/07/18
-! Please do not put this function in a m*odule not to complexify the replay script
-!--------------------------------------------------------------------------------
-USE dimphy, only : klon
-USE geometry_mod, ONLY: latitude_deg, longitude_deg
-implicit none
-real, intent(in) :: lon_deg,lat_deg
-integer :: grid_index
-integer i
-grid_index=0
-do i=1,klon
-   if ( abs(lon_deg-longitude_deg(i)) < 0.02 .and.  abs(lat_deg-latitude_deg(i)) < 0.02 ) then
-        grid_index=i
-        exit
-   endif
-enddo
-return
-end
Index: /LMDZ6/trunk/libf/phylmd/grid_index.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/grid_index.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/grid_index.f90	(revision 5268)
@@ -0,0 +1,21 @@
+function grid_index(lon_deg,lat_deg)
+!--------------------------------------------------------------------------------
+! Get local index of grid point of longitude,latitude lon_deg,lat_deg
+! Author : FH 2024/07/18
+! Please do not put this function in a m*odule not to complexify the replay script
+!--------------------------------------------------------------------------------
+USE dimphy, only : klon
+USE geometry_mod, ONLY: latitude_deg, longitude_deg
+implicit none
+real, intent(in) :: lon_deg,lat_deg
+integer :: grid_index
+integer i
+grid_index=0
+do i=1,klon
+   if ( abs(lon_deg-longitude_deg(i)) < 0.02 .and.  abs(lat_deg-latitude_deg(i)) < 0.02 ) then
+        grid_index=i
+        exit
+   endif
+enddo
+return
+end
Index: DZ6/trunk/libf/phylmd/grid_noro_m.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/grid_noro_m.F90	(revision 5267)
+++ 	(revision )
@@ -1,579 +1,0 @@
-!
-! $Id$
-!
-MODULE grid_noro_m
-!
-!*******************************************************************************
-
-  USE print_control_mod, ONLY: lunout
-  USE assert_eq_m,       ONLY: assert_eq
-  PRIVATE
-  PUBLIC :: grid_noro, grid_noro0, read_noro
-
-
-CONTAINS
-
-
-!-------------------------------------------------------------------------------
-!
-SUBROUTINE grid_noro(xd,yd,zd,x,y,zphi,zmea,zstd,zsig,zgam,zthe,zpic,zval,mask)
-!
-!-------------------------------------------------------------------------------
-! Author: F. Lott (see also Z.X. Li, A. Harzallah et L. Fairhead)
-!-------------------------------------------------------------------------------
-! Purpose: Compute the Parameters of the SSO scheme as described in LOTT &MILLER
-!         (1997) and LOTT(1999).
-!-------------------------------------------------------------------------------
-! Comments:
-!  * Target points are on a rectangular grid:
-!      iim+1 latitudes including North and South Poles;
-!      jjm+1 longitudes, with periodicity jjm+1=1.
-!  * At the poles, the fields value is repeated jjm+1 time.
-!  * The parameters a,b,c,d represent the limits of the target gridpoint region.
-!    The means over this region are calculated from USN data, ponderated by a
-!    weight proportional to the surface occupated by the data inside the model
-!    gridpoint area. In most circumstances, this weight is the ratio between the
-!    surfaces of the USN gridpoint area and the model gridpoint area. 
-!
-!           (c)
-!        ----d-----
-!        | . . . .|
-!        |        |
-!     (b)a . * . .b(a)
-!        |        |
-!        | . . . .|
-!        ----c-----
-!           (d)
-!  * Hard-coded US Navy dataset dimensions (imdp=2160 ; jmdp=1080) have been
-!    removed (ALLOCATABLE used).
-!  * iext (currently 10% of imdp) represents the margin to ensure output cells
-!    on the edge are contained in input cells.
-!===============================================================================
-  IMPLICIT NONE
-!-------------------------------------------------------------------------------
-! Arguments:
-  REAL, INTENT(IN)  :: xd(:), yd(:)  !--- INPUT  COORDINATES     (imdp) (jmdp)
-  REAL, INTENT(IN)  :: zd(:,:)       !--- INPUT  FIELD           (imdp,jmdp)
-  REAL, INTENT(IN)  :: x(:), y(:)    !--- OUTPUT COORDINATES     (imar+1) (jmar)
-  REAL, INTENT(OUT) :: zphi(:,:)     !--- GEOPOTENTIAL           (imar+1,jmar)
-  REAL, INTENT(OUT) :: zmea(:,:)     !--- MEAN OROGRAPHY         (imar+1,jmar)
-  REAL, INTENT(OUT) :: zstd(:,:)     !--- STANDARD DEVIATION     (imar+1,jmar)
-  REAL, INTENT(OUT) :: zsig(:,:)     !--- SLOPE                  (imar+1,jmar)
-  REAL, INTENT(OUT) :: zgam(:,:)     !--- ANISOTROPY             (imar+1,jmar)
-  REAL, INTENT(OUT) :: zthe(:,:)     !--- SMALL AXIS ORIENTATION (imar+1,jmar)
-  REAL, INTENT(OUT) :: zpic(:,:)     !--- MAXIMUM ALTITITUDE     (imar+1,jmar)
-  REAL, INTENT(OUT) :: zval(:,:)     !--- MINIMUM ALTITITUDE     (imar+1,jmar)
-  REAL, INTENT(OUT) :: mask(:,:)     !--- MASK                   (imar+1,jmar)
-!-------------------------------------------------------------------------------
-! Local variables:
-  CHARACTER(LEN=256) :: modname="grid_noro"
-  REAL, ALLOCATABLE :: xusn(:), yusn(:)           ! dim (imdp+2*iext) (jmdp+2)
-  REAL, ALLOCATABLE :: zusn(:,:)                  ! dim (imdp+2*iext,jmdp+2)
-! CORRELATIONS OF OROGRAPHY GRADIENT              ! dim (imar+1,jmar)
-  REAL, ALLOCATABLE :: ztz(:,:), zxtzx(:,:), zytzy(:,:), zxtzy(:,:), weight(:,:)
-! CORRELATIONS OF USN OROGRAPHY GRADIENTS         ! dim (imar+2*iext,jmdp+2)
-  REAL, ALLOCATABLE :: zxtzxusn(:,:), zytzyusn(:,:), zxtzyusn(:,:)
-  REAL, ALLOCATABLE :: num_tot(:,:), num_lan(:,:) ! dim (imar+1,jmar)
-  REAL, ALLOCATABLE :: a(:), b(:)                 ! dim (imar+1)
-  REAL, ALLOCATABLE :: c(:), d(:)                 ! dim (jmar)
-  LOGICAL :: masque_lu
-  INTEGER :: i, ii, imdp, imar, iext
-  INTEGER :: j, jj, jmdp, jmar, nn
-  REAL    :: xpi, zdeltax, zlenx, weighx, xincr,  zweinor, xk, xl, xm
-  REAL    :: rad, zdeltay, zleny, weighy, masque, zweisud, xp, xq, xw
-
-
-
-!-------------------------------------------------------------------------------
-  imdp=assert_eq(SIZE(xd),SIZE(zd,1),TRIM(modname)//" imdp")
-  jmdp=assert_eq(SIZE(yd),SIZE(zd,2),TRIM(modname)//" jmdp")
-  imar=assert_eq([SIZE(x),SIZE(zphi,1),SIZE(zmea,1),SIZE(zstd,1),SIZE(zsig,1), &
-                          SIZE(zgam,1),SIZE(zthe,1),SIZE(zpic,1),SIZE(zval,1), &
-                          SIZE(mask,1)],TRIM(modname)//" imar")-1
-  jmar=assert_eq([SIZE(y),SIZE(zphi,2),SIZE(zmea,2),SIZE(zstd,2),SIZE(zsig,2), &
-                          SIZE(zgam,2),SIZE(zthe,2),SIZE(zpic,2),SIZE(zval,2), &
-                          SIZE(mask,2)],TRIM(modname)//" jmar")
-!  IF(imar/=iim)   CALL abort_physic(TRIM(modname),'imar/=iim'  ,1)
-!  IF(jmar/=jjm+1) CALL abort_physic(TRIM(modname),'jmar/=jjm+1',1)
-  iext=imdp/10                                !--- OK up to 36 degrees cell
-  xpi = ACOS(-1.)
-  rad = 6371229.
-  zdeltay=2.*xpi/REAL(jmdp)*rad
-  WRITE(lunout,*)"*** Orography parameters at sub-cell scale ***"
-
-!--- ARE WE USING A READ MASK ?
-  masque_lu=ANY(mask/=-99999.); IF(.NOT.masque_lu) mask=0.0
-  WRITE(lunout,*)'Masque lu: ',masque_lu
-
-!--- EXTENSION OF THE INPUT DATABASE TO PROCEED COMPUTATIONS AT BOUNDARIES:
-  ALLOCATE(xusn(imdp+2*iext))
-  xusn(1     +iext:imdp  +iext)=xd(:)
-  xusn(1          :       iext)=xd(1+imdp-iext:imdp)-2.*xpi
-  xusn(1+imdp+iext:imdp+2*iext)=xd(1          :iext)+2.*xpi
-
-  ALLOCATE(yusn(jmdp+2))
-  yusn(1       )=yd(1)   +(yd(1)   -yd(2))
-  yusn(2:jmdp+1)=yd(:)
-  yusn(  jmdp+2)=yd(jmdp)+(yd(jmdp)-yd(jmdp-1))
-
-  ALLOCATE(zusn(imdp+2*iext,jmdp+2))
-  zusn(1       +iext:imdp  +iext,2:jmdp+1)=zd  (:                   ,     :)
-  zusn(1            :       iext,2:jmdp+1)=zd  (imdp-iext+1:imdp    ,     :)
-  zusn(1+imdp  +iext:imdp+2*iext,2:jmdp+1)=zd  (1:iext              ,     :)
-  zusn(1            :imdp/2+iext,       1)=zusn(1+imdp/2:imdp  +iext,     2)
-  zusn(1+imdp/2+iext:imdp+2*iext,       1)=zusn(1       :imdp/2+iext,     2)
-  zusn(1            :imdp/2+iext,  jmdp+2)=zusn(1+imdp/2:imdp  +iext,jmdp+1)
-  zusn(1+imdp/2+iext:imdp+2*iext,  jmdp+2)=zusn(1       :imdp/2+iext,jmdp+1)
-
-!--- COMPUTE LIMITS OF MODEL GRIDPOINT AREA (REGULAR GRID)
-  ALLOCATE(a(imar+1),b(imar+1))
-  b(1:imar)=(x(1:imar  )+ x(2:imar+1))/2.0
-  b(imar+1)= x(  imar+1)+(x(  imar+1)-x(imar))/2.0
-  a(1)=x(1)-(x(2)-x(1))/2.0
-  a(2:imar+1)= b(1:imar)
-
-  ALLOCATE(c(jmar),d(jmar))
-  d(1:jmar-1)=(y(1:jmar-1)+ y(2:jmar))/2.0
-  d(  jmar  )= y(  jmar  )+(y(  jmar)-y(jmar-1))/2.0
-  c(1)=y(1)-(y(2)-y(1))/2.0
-  c(2:jmar)=d(1:jmar-1)
-
-!--- INITIALIZATIONS:
-  ALLOCATE(weight(imar+1,jmar)); weight(:,:)= 0.0
-  ALLOCATE(zxtzx (imar+1,jmar)); zxtzx (:,:)= 0.0
-  ALLOCATE(zytzy (imar+1,jmar)); zytzy (:,:)= 0.0
-  ALLOCATE(zxtzy (imar+1,jmar)); zxtzy (:,:)= 0.0
-  ALLOCATE(ztz   (imar+1,jmar)); ztz   (:,:)= 0.0
-  zmea(:,:)= 0.0
-  zpic(:,:)=-1.E+10
-  zval(:,:)= 1.E+10
-
-!--- COMPUTE SLOPES CORRELATIONS ON USN GRID
-! CORRELATIONS OF USN OROGRAPHY GRADIENTS  ! dim (imdp+2*iext,jmdp+2)
-  ALLOCATE(zytzyusn(imdp+2*iext,jmdp+2)); zytzyusn(:,:)=0.0
-  ALLOCATE(zxtzxusn(imdp+2*iext,jmdp+2)); zxtzxusn(:,:)=0.0
-  ALLOCATE(zxtzyusn(imdp+2*iext,jmdp+2)); zxtzyusn(:,:)=0.0
-  DO j = 2, jmdp+1
-    zdeltax=zdeltay*cos(yusn(j))
-    DO i = 2, imdp+2*iext-1
-      zytzyusn(i,j)=(zusn(i,j+1)-zusn(i,j-1))**2/zdeltay**2
-      zxtzxusn(i,j)=(zusn(i+1,j)-zusn(i-1,j))**2/zdeltax**2
-      zxtzyusn(i,j)=(zusn(i,j+1)-zusn(i,j-1))   /zdeltay  &
-     &             *(zusn(i+1,j)-zusn(i-1,j))   /zdeltax
-    END DO
-  END DO
-
-!--- SUMMATION OVER GRIDPOINT AREA
-  zleny=xpi/REAL(jmdp)*rad
-  xincr=xpi/REAL(jmdp)/2.
-  ALLOCATE(num_tot(imar+1,jmar)); num_tot(:,:)=0.
-  ALLOCATE(num_lan(imar+1,jmar)); num_lan(:,:)=0.
-  DO ii = 1, imar+1
-    DO jj = 1, jmar
-      DO j = 2,jmdp+1 
-        zlenx=zleny*COS(yusn(j))
-        zdeltax=zdeltay*COS(yusn(j))
-        weighy=(xincr+AMIN1(c(jj)-yusn(j),yusn(j)-d(jj)))*rad
-        weighy=AMAX1(0.,AMIN1(weighy,zleny))
-
-        IF(weighy==0.) CYCLE
-        DO i = 2, imdp+2*iext-1
-          weighx=(xincr+AMIN1(xusn(i)-a(ii),b(ii)-xusn(i)))*rad*COS(yusn(j))
-          weighx=AMAX1(0.,AMIN1(weighx,zlenx))
-
-          IF(weighx==0.) CYCLE
-          num_tot(ii,jj)=num_tot(ii,jj)+1.0
-          IF(zusn(i,j)>=1.)num_lan(ii,jj)=num_lan(ii,jj)+1.0
-          weight(ii,jj)=weight(ii,jj)+weighx*weighy
-          zxtzx(ii,jj)=zxtzx(ii,jj)+zxtzxusn(i,j)*weighx*weighy
-          zytzy(ii,jj)=zytzy(ii,jj)+zytzyusn(i,j)*weighx*weighy
-          zxtzy(ii,jj)=zxtzy(ii,jj)+zxtzyusn(i,j)*weighx*weighy
-          ztz  (ii,jj)=  ztz(ii,jj)+zusn(i,j)*zusn(i,j)*weighx*weighy
-          zmea (ii,jj)= zmea(ii,jj)+zusn(i,j)*weighx*weighy !--- MEAN
-          zpic (ii,jj)=AMAX1(zpic(ii,jj),zusn(i,j))         !--- PEAKS
-          zval (ii,jj)=AMIN1(zval(ii,jj),zusn(i,j))         !--- VALLEYS
-        END DO
-      END DO
-    END DO
-  END DO
-
-!--- COMPUTE PARAMETERS NEEDED BY LOTT & MILLER (1997) AND LOTT (1999) SSO SCHEME
-  IF(.NOT.masque_lu) THEN
-    WHERE(weight(:,:)/=0.0) mask=num_lan(:,:)/num_tot(:,:)
-  END IF
-  nn=COUNT(weight(:,:)==0.0)
-  IF(nn/=0) WRITE(lunout,*)'Problem with weight ; vanishing occurrences: ',nn
-  WHERE(weight(:,:)/=0.0)
-    zmea (:,:)=zmea (:,:)/weight(:,:)
-    zxtzx(:,:)=zxtzx(:,:)/weight(:,:)
-    zytzy(:,:)=zytzy(:,:)/weight(:,:)
-    zxtzy(:,:)=zxtzy(:,:)/weight(:,:)
-    ztz  (:,:)=ztz  (:,:)/weight(:,:)
-    zstd (:,:)=ztz  (:,:)-zmea(:,:)**2
-  END WHERE
-  WHERE(zstd(:,:)<0) zstd(:,:)=0.
-  zstd (:,:)=SQRT(zstd(:,:))
-
-!--- CORRECT VALUES OF HORIZONTAL SLOPE NEAR THE POLES:
-  zxtzx(:,   1)=zxtzx(:,     2)
-  zxtzx(:,jmar)=zxtzx(:,jmar-1)
-  zxtzy(:,   1)=zxtzy(:,     2)
-  zxtzy(:,jmar)=zxtzy(:,jmar-1)
-  zytzy(:,   1)=zytzy(:,     2)
-  zytzy(:,jmar)=zytzy(:,jmar-1)
-
-!=== FILTERS TO SMOOTH OUT FIELDS FOR INPUT INTO SSO SCHEME.
-!--- FIRST FILTER, MOVING AVERAGE OVER 9 POINTS.
-!-------------------------------------------------------------------------------
-  zphi(:,:)=zmea(:,:)                           ! GK211005 (CG) UNSMOOTHED TOPO
-
-  CALL MVA9(zmea);  CALL MVA9(zstd);  CALL MVA9(zpic);  CALL MVA9(zval)
-  CALL MVA9(zxtzx); CALL MVA9(zxtzy); CALL MVA9(zytzy)
-
-!--- MASK BASED ON GROUND MAXIMUM, 10% THRESHOLD. (SURFACE PARAMS MEANINGLESS)
-  WHERE(weight(:,:)==0.0.OR.mask<0.1)
-    zphi(:,:)=0.0; zmea(:,:)=0.0; zpic(:,:)=0.0; zval(:,:)=0.0; zstd(:,:)=0.0
-  END WHERE
-  DO ii = 1, imar
-    DO jj = 1, jmar
-      IF(weight(ii,jj)==0.0) CYCLE
-    !--- Coefficients K, L et M:
-      xk=(zxtzx(ii,jj)+zytzy(ii,jj))/2.
-      xl=(zxtzx(ii,jj)-zytzy(ii,jj))/2.
-      xm=zxtzy(ii,jj)
-      xp=xk-SQRT(xl**2+xm**2)
-      xq=xk+SQRT(xl**2+xm**2)
-      xw=1.e-8
-      IF(xp<=xw) xp=0.
-      IF(xq<=xw) xq=xw
-      IF(ABS(xm)<=xw) xm=xw*SIGN(1.,xm)
-    !--- SLOPE, ANISOTROPY AND THETA ANGLE
-      zsig(ii,jj)=SQRT(xq)
-      zgam(ii,jj)=xp/xq
-      zthe(ii,jj)=90.*ATAN2(xm,xl)/xpi
-    END DO
-  END DO
-  WHERE(weight(:,:)==0.0.OR.mask<0.1)
-    zsig(:,:)=0.0; zgam(:,:)=0.0; zthe(:,:)=0.0
-  END WHERE
-
-  WRITE(lunout,*)'  MEAN ORO:' ,MAXVAL(zmea)
-  WRITE(lunout,*)'  ST. DEV.:' ,MAXVAL(zstd)
-  WRITE(lunout,*)'  PENTE:'    ,MAXVAL(zsig)
-  WRITE(lunout,*)'  ANISOTROP:',MAXVAL(zgam)
-  WRITE(lunout,*)'  ANGLE:'    ,MINVAL(zthe),MAXVAL(zthe)
-  WRITE(lunout,*)'  pic:'      ,MAXVAL(zpic)
-  WRITE(lunout,*)'  val:'      ,MAXVAL(zval)
-      
-!--- Values at redundant longitude
-  zmea(imar+1,:)=zmea(1,:)
-  zphi(imar+1,:)=zphi(1,:)
-  zpic(imar+1,:)=zpic(1,:)
-  zval(imar+1,:)=zval(1,:)
-  zstd(imar+1,:)=zstd(1,:)
-  zsig(imar+1,:)=zsig(1,:)
-  zgam(imar+1,:)=zgam(1,:)
-  zthe(imar+1,:)=zthe(1,:)
-
-!--- Values at north pole
-  zweinor  =SUM(weight(1:imar,1))
-  zmea(:,1)=SUM(weight(1:imar,1)*zmea(1:imar,1))/zweinor
-  zphi(:,1)=SUM(weight(1:imar,1)*zphi(1:imar,1))/zweinor
-  zpic(:,1)=SUM(weight(1:imar,1)*zpic(1:imar,1))/zweinor
-  zval(:,1)=SUM(weight(1:imar,1)*zval(1:imar,1))/zweinor
-  zstd(:,1)=SUM(weight(1:imar,1)*zstd(1:imar,1))/zweinor
-  zsig(:,1)=SUM(weight(1:imar,1)*zsig(1:imar,1))/zweinor
-  zgam(:,1)=1.; zthe(:,1)=0.
-
-!--- Values at south pole
-  zweisud     =SUM(weight(1:imar,jmar),DIM=1)
-  zmea(:,jmar)=SUM(weight(1:imar,jmar)*zmea(1:imar,jmar))/zweisud
-  zphi(:,jmar)=SUM(weight(1:imar,jmar)*zphi(1:imar,jmar))/zweisud
-  zpic(:,jmar)=SUM(weight(1:imar,jmar)*zpic(1:imar,jmar))/zweisud
-  zval(:,jmar)=SUM(weight(1:imar,jmar)*zval(1:imar,jmar))/zweisud
-  zstd(:,jmar)=SUM(weight(1:imar,jmar)*zstd(1:imar,jmar))/zweisud
-  zsig(:,jmar)=SUM(weight(1:imar,jmar)*zsig(1:imar,jmar))/zweisud
-  zgam(:,jmar)=1.; zthe(:,jmar)=0.
-
-END SUBROUTINE grid_noro
-!
-!-------------------------------------------------------------------------------
-
-
-!-------------------------------------------------------------------------------
-!
-SUBROUTINE grid_noro0(xd,yd,zd,x,y,zphi,mask)
-!
-!===============================================================================
-! Purpose: Extracted from grid_noro to provide geopotential height for dynamics
-!          without any call to physics subroutines.
-!===============================================================================
-  IMPLICIT NONE 
-!-------------------------------------------------------------------------------
-! Arguments:
-  REAL, INTENT(IN)  :: xd(:), yd(:) !--- INPUT  COORDINATES     (imdp) (jmdp)
-  REAL, INTENT(IN)  :: zd(:,:)      !--- INPUT  FIELD           (imdp,  jmdp)
-  REAL, INTENT(IN)  :: x(:), y(:)   !--- OUTPUT COORDINATES     (imar+1) (jmar)
-  REAL, INTENT(OUT) :: zphi(:,:)    !--- GEOPOTENTIAL           (imar+1,jmar)
-  REAL, INTENT(OUT) :: mask(:,:)    !--- MASK                   (imar+1,jmar)
-!-------------------------------------------------------------------------------
-! Local variables:
-  CHARACTER(LEN=256) :: modname="grid_noro0"
-  REAL, ALLOCATABLE :: xusn(:), yusn(:)           ! dim (imdp+2*iext) (jmdp+2)
-  REAL, ALLOCATABLE :: zusn(:,:)                  ! dim (imdp+2*iext,  jmdp+2)
-  REAL, ALLOCATABLE :: weight(:,:)                ! dim (imar+1,jmar)
-  REAL, ALLOCATABLE :: num_tot(:,:), num_lan(:,:) ! dim (imar+1,jmar)
-  REAL, ALLOCATABLE :: a(:), b(:)                 ! dim (imar+1)
-  REAL, ALLOCATABLE :: c(:), d(:)                 ! dim (jmar)
-
-  LOGICAL :: masque_lu
-  INTEGER :: i, ii, imdp, imar, iext
-  INTEGER :: j, jj, jmdp, jmar, nn
-  REAL    :: xpi, zlenx, zleny, weighx, weighy, xincr, masque, rad
-
-!-------------------------------------------------------------------------------
-  imdp=assert_eq(SIZE(xd),SIZE(zd,1),TRIM(modname)//" imdp")
-  jmdp=assert_eq(SIZE(yd),SIZE(zd,2),TRIM(modname)//" jmdp")
-  imar=assert_eq(SIZE(x),SIZE(zphi,1),SIZE(mask,1),TRIM(modname)//" imar")-1
-  jmar=assert_eq(SIZE(y),SIZE(zphi,2),SIZE(mask,2),TRIM(modname)//" jmar")
-  iext=imdp/10
-  xpi = ACOS(-1.)
-  rad = 6371229.
-
-!--- ARE WE USING A READ MASK ?
-  masque_lu=ANY(mask/=-99999.); IF(.NOT.masque_lu) mask=0.0
-  WRITE(lunout,*)'Masque lu: ',masque_lu
-
-!--- EXTENSION OF THE INPUT DATABASE TO PROCEED COMPUTATIONS AT BOUNDARIES:
-  ALLOCATE(xusn(imdp+2*iext))
-  xusn(1     +iext:imdp  +iext)=xd(:)
-  xusn(1          :       iext)=xd(1+imdp-iext:imdp)-2.*xpi
-  xusn(1+imdp+iext:imdp+2*iext)=xd(1          :iext)+2.*xpi
-
-  ALLOCATE(yusn(jmdp+2))
-  yusn(1       )=yd(1)   +(yd(1)   -yd(2))
-  yusn(2:jmdp+1)=yd(:)
-  yusn(  jmdp+2)=yd(jmdp)+(yd(jmdp)-yd(jmdp-1))
-
-  ALLOCATE(zusn(imdp+2*iext,jmdp+2))
-  zusn(1       +iext:imdp  +iext,2:jmdp+1)=zd  (:                   ,     :)
-  zusn(1            :       iext,2:jmdp+1)=zd  (imdp-iext+1:imdp    ,     :)
-  zusn(1+imdp  +iext:imdp+2*iext,2:jmdp+1)=zd  (1:iext              ,     :)
-  zusn(1            :imdp/2+iext,       1)=zusn(1+imdp/2:imdp  +iext,     2)
-  zusn(1+imdp/2+iext:imdp+2*iext,       1)=zusn(1       :imdp/2+iext,     2)
-  zusn(1            :imdp/2+iext,  jmdp+2)=zusn(1+imdp/2:imdp  +iext,jmdp+1)
-  zusn(1+imdp/2+iext:imdp+2*iext,  jmdp+2)=zusn(1       :imdp/2+iext,jmdp+1)
-
-!--- COMPUTE LIMITS OF MODEL GRIDPOINT AREA (REGULAR GRID)
-  ALLOCATE(a(imar+1),b(imar+1))
-  b(1:imar)=(x(1:imar  )+ x(2:imar+1))/2.0
-  b(imar+1)= x(  imar+1)+(x(  imar+1)-x(imar))/2.0
-  a(1)=x(1)-(x(2)-x(1))/2.0
-  a(2:imar+1)= b(1:imar)
-
-  ALLOCATE(c(jmar),d(jmar))
-  d(1:jmar-1)=(y(1:jmar-1)+ y(2:jmar))/2.0
-  d(  jmar  )= y(  jmar  )+(y(  jmar)-y(jmar-1))/2.0
-  c(1)=y(1)-(y(2)-y(1))/2.0
-  c(2:jmar)=d(1:jmar-1)
-
-!--- INITIALIZATIONS:
-  ALLOCATE(weight(imar+1,jmar)); weight(:,:)=0.0; zphi(:,:)=0.0
-
-!--- SUMMATION OVER GRIDPOINT AREA
-  zleny=xpi/REAL(jmdp)*rad
-  xincr=xpi/REAL(jmdp)/2.
-  ALLOCATE(num_tot(imar+1,jmar)); num_tot(:,:)=0.
-  ALLOCATE(num_lan(imar+1,jmar)); num_lan(:,:)=0.
-  DO ii = 1, imar+1
-    DO jj = 1, jmar
-      DO j = 2,jmdp+1 
-        zlenx=zleny*COS(yusn(j))
-        weighy=(xincr+AMIN1(c(jj)-yusn(j),yusn(j)-d(jj)))*rad
-        weighy=AMAX1(0.,AMIN1(weighy,zleny))
-        IF(weighy/=0) CYCLE
-        DO i = 2, imdp+2*iext-1
-          weighx=(xincr+AMIN1(xusn(i)-a(ii),b(ii)-xusn(i)))*rad*COS(yusn(j))
-          weighx=AMAX1(0.,AMIN1(weighx,zlenx))
-          IF(weighx/=0) CYCLE
-          num_tot(ii,jj)=num_tot(ii,jj)+1.0
-          IF(zusn(i,j)>=1.)num_lan(ii,jj)=num_lan(ii,jj)+1.0
-          weight(ii,jj)=weight(ii,jj)+weighx*weighy
-          zphi  (ii,jj)=zphi  (ii,jj)+zusn(i,j)*weighx*weighy !--- MEAN
-        END DO
-      END DO
-    END DO
-  END DO
-
-!--- COMPUTE PARAMETERS NEEDED BY LOTT & MILLER (1997) AND LOTT (1999) SSO SCHEME
-  IF(.NOT.masque_lu) THEN
-    WHERE(weight(:,:)/=0.0) mask=num_lan(:,:)/num_tot(:,:)
-  END IF
-  nn=COUNT(weight(:,:)==0.0)
-  IF(nn/=0) WRITE(lunout,*)'Problem with weight ; vanishing occurrences: ',nn
-  WHERE(weight/=0.0) zphi(:,:)=zphi(:,:)/weight(:,:)
-
-!--- MASK BASED ON GROUND MAXIMUM, 10% THRESHOLD (<10%: SURF PARAMS MEANINGLESS)
-  WHERE(weight(:,:)==0.0.OR.mask<0.1) zphi(:,:)=0.0
-  WRITE(lunout,*)'  MEAN ORO:' ,MAXVAL(zphi)
-
-!--- Values at redundant longitude and at poles
-  zphi(imar+1,:)=zphi(1,:)
-  zphi(:,   1)=SUM(weight(1:imar,   1)*zphi(1:imar,   1))/SUM(weight(1:imar,   1))
-  zphi(:,jmar)=SUM(weight(1:imar,jmar)*zphi(1:imar,jmar))/SUM(weight(1:imar,jmar))
-
-END SUBROUTINE grid_noro0
-!
-!-------------------------------------------------------------------------------
-
-
-!-------------------------------------------------------------------------------
-!
-SUBROUTINE read_noro(x,y,fname,zphi,zmea,zstd,zsig,zgam,zthe,zpic,zval,mask)
-!
-!-------------------------------------------------------------------------------
-! Purpose: Read parameters usually determined with grid_noro from a file.
-!===============================================================================
-  USE netcdf, ONLY: NF90_OPEN,  NF90_INQ_DIMID, NF90_INQUIRE_DIMENSION,        &
-        NF90_NOERR, NF90_CLOSE, NF90_INQ_VARID, NF90_GET_VAR, NF90_STRERROR,   &
-        NF90_NOWRITE
-  IMPLICIT NONE 
-!-------------------------------------------------------------------------------
-! Arguments:
-  REAL, INTENT(IN)  :: x(:), y(:)    !--- OUTPUT COORDINATES     (imar+1) (jmar)
-  CHARACTER(LEN=*), INTENT(IN) :: fname ! PARAMETERS FILE NAME
-  REAL, INTENT(OUT) :: zphi(:,:)     !--- GEOPOTENTIAL           (imar+1,jmar)
-  REAL, INTENT(OUT) :: zmea(:,:)     !--- MEAN OROGRAPHY         (imar+1,jmar)
-  REAL, INTENT(OUT) :: zstd(:,:)     !--- STANDARD DEVIATION     (imar+1,jmar)
-  REAL, INTENT(OUT) :: zsig(:,:)     !--- SLOPE                  (imar+1,jmar)
-  REAL, INTENT(OUT) :: zgam(:,:)     !--- ANISOTROPY             (imar+1,jmar)
-  REAL, INTENT(OUT) :: zthe(:,:)     !--- SMALL AXIS ORIENTATION (imar+1,jmar)
-  REAL, INTENT(OUT) :: zpic(:,:)     !--- MAXIMUM ALTITUDE       (imar+1,jmar)
-  REAL, INTENT(OUT) :: zval(:,:)     !--- MINIMUM ALTITUDE       (imar+1,jmar)
-  REAL, INTENT(OUT) :: mask(:,:)     !--- MASK                   (imar+1,jmar)
-!-------------------------------------------------------------------------------
-! Local variables:
-  CHARACTER(LEN=256) :: modname="read_noro"
-  INTEGER :: imar, jmar, fid, did, vid
-  LOGICAL :: masque_lu
-  REAL :: xpi, d2r
-!-------------------------------------------------------------------------------
-  imar=assert_eq([SIZE(x),SIZE(zphi,1),SIZE(zmea,1),SIZE(zstd,1),SIZE(zsig,1), &
-                          SIZE(zgam,1),SIZE(zthe,1),SIZE(zpic,1),SIZE(zval,1), &
-                          SIZE(mask,1)],TRIM(modname)//" imar")-1
-  jmar=assert_eq([SIZE(y),SIZE(zphi,2),SIZE(zmea,2),SIZE(zstd,2),SIZE(zsig,2), &
-                          SIZE(zgam,2),SIZE(zthe,2),SIZE(zpic,2),SIZE(zval,2), &
-                          SIZE(mask,2)],TRIM(modname)//" jmar")
-  xpi=ACOS(-1.0); d2r=xpi/180.
-  WRITE(lunout,*)"*** Orography parameters at sub-cell scale from file ***"
-
-!--- ARE WE USING A READ MASK ?
-  masque_lu=ANY(mask/=-99999.); IF(.NOT.masque_lu) mask=0.0
-  WRITE(lunout,*)'Masque lu: ',masque_lu
-  CALL ncerr(NF90_OPEN(fname,NF90_NOWRITE,fid))
-  CALL check_dim('x','longitude',x(1:imar))
-  CALL check_dim('y','latitude' ,y(1:jmar))
-  IF(.NOT.masque_lu) CALL get_fld('mask',mask)
-  CALL get_fld('Zphi',zphi)
-  CALL get_fld('Zmea',zmea)
-  CALL get_fld('mu'  ,zstd)
-  CALL get_fld('Zsig',zsig)
-  CALL get_fld('Zgam',zgam)
-  CALL get_fld('Zthe',zthe)
-  zpic=zmea+2*zstd
-  zval=MAX(0.,zmea-2.*zstd)
-  CALL ncerr(NF90_CLOSE(fid))
-  WRITE(lunout,*)'  MEAN ORO:' ,MAXVAL(zmea)
-  WRITE(lunout,*)'  ST. DEV.:' ,MAXVAL(zstd)
-  WRITE(lunout,*)'  PENTE:'    ,MAXVAL(zsig)
-  WRITE(lunout,*)'  ANISOTROP:',MAXVAL(zgam)
-  WRITE(lunout,*)'  ANGLE:'    ,MINVAL(zthe),MAXVAL(zthe)
-  WRITE(lunout,*)'  pic:'      ,MAXVAL(zpic)
-  WRITE(lunout,*)'  val:'      ,MAXVAL(zval)
-
-CONTAINS
-
-
-SUBROUTINE get_fld(var,fld)
-  CHARACTER(LEN=*), INTENT(IN)    :: var
-  REAL,             INTENT(INOUT) :: fld(:,:)
-  CALL ncerr(NF90_INQ_VARID(fid,var,vid),var)
-  CALL ncerr(NF90_GET_VAR(fid,vid,fld(1:imar,:)),var)
-  fld(imar+1,:)=fld(1,:)
-END SUBROUTINE get_fld
-
-SUBROUTINE check_dim(dimd,nam,dimv)
-  CHARACTER(LEN=*), INTENT(IN) :: dimd
-  CHARACTER(LEN=*), INTENT(IN) :: nam
-  REAL,             INTENT(IN) :: dimv(:)
-  REAL, ALLOCATABLE :: tmp(:)
-  INTEGER :: n
-  CALL ncerr(NF90_INQ_DIMID(fid,dimd,did))
-  CALL ncerr(NF90_INQUIRE_DIMENSION(fid,did,len=n)); ALLOCATE(tmp(n))
-  CALL ncerr(NF90_INQ_VARID(fid,dimd,did))
-  CALL ncerr(NF90_GET_VAR(fid,did,tmp))
-  IF(MAXVAL(tmp)>xpi) tmp=tmp*d2r
-  IF(n/=SIZE(dimv).OR.ANY(ABS(tmp-dimv)>1E-6)) THEN
-    WRITE(lunout,*)'Problem with file "'//TRIM(fname)//'".'
-    CALL abort_physic(modname,'Grid differs from LMDZ for '//TRIM(nam)//'.',1)
-  END IF
-END SUBROUTINE check_dim
-
-SUBROUTINE ncerr(ncres,var)
-  IMPLICIT NONE
-  INTEGER,          INTENT(IN) :: ncres
-  CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: var
-  CHARACTER(LEN=256) :: mess
-  IF(ncres/=NF90_NOERR) THEN
-    mess='Problem with file "'//TRIM(fname)//'"'
-    IF(PRESENT(var)) mess=TRIM(mess)//' and variable "'//TRIM(var)//'"'
-    WRITE(lunout,*)TRIM(mess)//'.'
-    CALL abort_physic(modname,NF90_STRERROR(ncres),1)
-  END IF
-END SUBROUTINE ncerr
-
-END SUBROUTINE read_noro
-!
-!-------------------------------------------------------------------------------
-
-
-!-------------------------------------------------------------------------------
-!
-SUBROUTINE MVA9(x)
-!
-!-------------------------------------------------------------------------------
-  IMPLICIT NONE
-! MAKE A MOVING AVERAGE OVER 9 GRIDPOINTS OF THE X FIELDS
-!-------------------------------------------------------------------------------
-! Arguments:
-  REAL, INTENT(INOUT) :: x(:,:)
-!-------------------------------------------------------------------------------
-! Local variables:
-  REAL    :: xf(SIZE(x,DIM=1),SIZE(x,DIM=2)), WEIGHTpb(-1:1,-1:1)
-  INTEGER :: i, j, imar, jmar
-!-------------------------------------------------------------------------------
-  WEIGHTpb=RESHAPE([((1./REAL((1+i**2)*(1+j**2)),i=-1,1),j=-1,1)],SHAPE=[3,3])
-  WEIGHTpb=WEIGHTpb/SUM(WEIGHTpb)
-  imar=SIZE(X,DIM=1); jmar=SIZE(X,DIM=2)
-  DO j=2,jmar-1
-    DO i=2,imar-1
-      xf(i,j)=SUM(x(i-1:i+1,j-1:j+1)*WEIGHTpb(:,:))
-    END DO
-  END DO
-  DO j=2,jmar-1
-    xf(1,j)=SUM(x(imar-1,j-1:j+1)*WEIGHTpb(-1,:))
-    xf(1,j)=xf(1,j)+SUM(x(1:2,j-1:j+1)*WEIGHTpb(0:1,-1:1))
-    xf(imar,j)=xf(1,j)
-  END DO
-  xf(:,   1)=xf(:,     2)
-  xf(:,jmar)=xf(:,jmar-1)
-  x(:,:)=xf(:,:)
-
-END SUBROUTINE MVA9
-!
-!-------------------------------------------------------------------------------
-
-
-END MODULE grid_noro_m
-
-
Index: /LMDZ6/trunk/libf/phylmd/grid_noro_m.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/grid_noro_m.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/grid_noro_m.f90	(revision 5268)
@@ -0,0 +1,579 @@
+!
+! $Id$
+!
+MODULE grid_noro_m
+!
+!*******************************************************************************
+
+  USE print_control_mod, ONLY: lunout
+  USE assert_eq_m,       ONLY: assert_eq
+  PRIVATE
+  PUBLIC :: grid_noro, grid_noro0, read_noro
+
+
+CONTAINS
+
+
+!-------------------------------------------------------------------------------
+!
+SUBROUTINE grid_noro(xd,yd,zd,x,y,zphi,zmea,zstd,zsig,zgam,zthe,zpic,zval,mask)
+!
+!-------------------------------------------------------------------------------
+! Author: F. Lott (see also Z.X. Li, A. Harzallah et L. Fairhead)
+!-------------------------------------------------------------------------------
+! Purpose: Compute the Parameters of the SSO scheme as described in LOTT &MILLER
+!         (1997) and LOTT(1999).
+!-------------------------------------------------------------------------------
+! Comments:
+!  * Target points are on a rectangular grid:
+!      iim+1 latitudes including North and South Poles;
+!      jjm+1 longitudes, with periodicity jjm+1=1.
+!  * At the poles, the fields value is repeated jjm+1 time.
+!  * The parameters a,b,c,d represent the limits of the target gridpoint region.
+!    The means over this region are calculated from USN data, ponderated by a
+!    weight proportional to the surface occupated by the data inside the model
+!    gridpoint area. In most circumstances, this weight is the ratio between the
+!    surfaces of the USN gridpoint area and the model gridpoint area. 
+!
+!           (c)
+!        ----d-----
+!        | . . . .|
+!        |        |
+!     (b)a . * . .b(a)
+!        |        |
+!        | . . . .|
+!        ----c-----
+!           (d)
+!  * Hard-coded US Navy dataset dimensions (imdp=2160 ; jmdp=1080) have been
+!    removed (ALLOCATABLE used).
+!  * iext (currently 10% of imdp) represents the margin to ensure output cells
+!    on the edge are contained in input cells.
+!===============================================================================
+  IMPLICIT NONE
+!-------------------------------------------------------------------------------
+! Arguments:
+  REAL, INTENT(IN)  :: xd(:), yd(:)  !--- INPUT  COORDINATES     (imdp) (jmdp)
+  REAL, INTENT(IN)  :: zd(:,:)       !--- INPUT  FIELD           (imdp,jmdp)
+  REAL, INTENT(IN)  :: x(:), y(:)    !--- OUTPUT COORDINATES     (imar+1) (jmar)
+  REAL, INTENT(OUT) :: zphi(:,:)     !--- GEOPOTENTIAL           (imar+1,jmar)
+  REAL, INTENT(OUT) :: zmea(:,:)     !--- MEAN OROGRAPHY         (imar+1,jmar)
+  REAL, INTENT(OUT) :: zstd(:,:)     !--- STANDARD DEVIATION     (imar+1,jmar)
+  REAL, INTENT(OUT) :: zsig(:,:)     !--- SLOPE                  (imar+1,jmar)
+  REAL, INTENT(OUT) :: zgam(:,:)     !--- ANISOTROPY             (imar+1,jmar)
+  REAL, INTENT(OUT) :: zthe(:,:)     !--- SMALL AXIS ORIENTATION (imar+1,jmar)
+  REAL, INTENT(OUT) :: zpic(:,:)     !--- MAXIMUM ALTITITUDE     (imar+1,jmar)
+  REAL, INTENT(OUT) :: zval(:,:)     !--- MINIMUM ALTITITUDE     (imar+1,jmar)
+  REAL, INTENT(OUT) :: mask(:,:)     !--- MASK                   (imar+1,jmar)
+!-------------------------------------------------------------------------------
+! Local variables:
+  CHARACTER(LEN=256) :: modname="grid_noro"
+  REAL, ALLOCATABLE :: xusn(:), yusn(:)           ! dim (imdp+2*iext) (jmdp+2)
+  REAL, ALLOCATABLE :: zusn(:,:)                  ! dim (imdp+2*iext,jmdp+2)
+! CORRELATIONS OF OROGRAPHY GRADIENT              ! dim (imar+1,jmar)
+  REAL, ALLOCATABLE :: ztz(:,:), zxtzx(:,:), zytzy(:,:), zxtzy(:,:), weight(:,:)
+! CORRELATIONS OF USN OROGRAPHY GRADIENTS         ! dim (imar+2*iext,jmdp+2)
+  REAL, ALLOCATABLE :: zxtzxusn(:,:), zytzyusn(:,:), zxtzyusn(:,:)
+  REAL, ALLOCATABLE :: num_tot(:,:), num_lan(:,:) ! dim (imar+1,jmar)
+  REAL, ALLOCATABLE :: a(:), b(:)                 ! dim (imar+1)
+  REAL, ALLOCATABLE :: c(:), d(:)                 ! dim (jmar)
+  LOGICAL :: masque_lu
+  INTEGER :: i, ii, imdp, imar, iext
+  INTEGER :: j, jj, jmdp, jmar, nn
+  REAL    :: xpi, zdeltax, zlenx, weighx, xincr,  zweinor, xk, xl, xm
+  REAL    :: rad, zdeltay, zleny, weighy, masque, zweisud, xp, xq, xw
+
+
+
+!-------------------------------------------------------------------------------
+  imdp=assert_eq(SIZE(xd),SIZE(zd,1),TRIM(modname)//" imdp")
+  jmdp=assert_eq(SIZE(yd),SIZE(zd,2),TRIM(modname)//" jmdp")
+  imar=assert_eq([SIZE(x),SIZE(zphi,1),SIZE(zmea,1),SIZE(zstd,1),SIZE(zsig,1), &
+                          SIZE(zgam,1),SIZE(zthe,1),SIZE(zpic,1),SIZE(zval,1), &
+                          SIZE(mask,1)],TRIM(modname)//" imar")-1
+  jmar=assert_eq([SIZE(y),SIZE(zphi,2),SIZE(zmea,2),SIZE(zstd,2),SIZE(zsig,2), &
+                          SIZE(zgam,2),SIZE(zthe,2),SIZE(zpic,2),SIZE(zval,2), &
+                          SIZE(mask,2)],TRIM(modname)//" jmar")
+!  IF(imar/=iim)   CALL abort_physic(TRIM(modname),'imar/=iim'  ,1)
+!  IF(jmar/=jjm+1) CALL abort_physic(TRIM(modname),'jmar/=jjm+1',1)
+  iext=imdp/10                                !--- OK up to 36 degrees cell
+  xpi = ACOS(-1.)
+  rad = 6371229.
+  zdeltay=2.*xpi/REAL(jmdp)*rad
+  WRITE(lunout,*)"*** Orography parameters at sub-cell scale ***"
+
+!--- ARE WE USING A READ MASK ?
+  masque_lu=ANY(mask/=-99999.); IF(.NOT.masque_lu) mask=0.0
+  WRITE(lunout,*)'Masque lu: ',masque_lu
+
+!--- EXTENSION OF THE INPUT DATABASE TO PROCEED COMPUTATIONS AT BOUNDARIES:
+  ALLOCATE(xusn(imdp+2*iext))
+  xusn(1     +iext:imdp  +iext)=xd(:)
+  xusn(1          :       iext)=xd(1+imdp-iext:imdp)-2.*xpi
+  xusn(1+imdp+iext:imdp+2*iext)=xd(1          :iext)+2.*xpi
+
+  ALLOCATE(yusn(jmdp+2))
+  yusn(1       )=yd(1)   +(yd(1)   -yd(2))
+  yusn(2:jmdp+1)=yd(:)
+  yusn(  jmdp+2)=yd(jmdp)+(yd(jmdp)-yd(jmdp-1))
+
+  ALLOCATE(zusn(imdp+2*iext,jmdp+2))
+  zusn(1       +iext:imdp  +iext,2:jmdp+1)=zd  (:                   ,     :)
+  zusn(1            :       iext,2:jmdp+1)=zd  (imdp-iext+1:imdp    ,     :)
+  zusn(1+imdp  +iext:imdp+2*iext,2:jmdp+1)=zd  (1:iext              ,     :)
+  zusn(1            :imdp/2+iext,       1)=zusn(1+imdp/2:imdp  +iext,     2)
+  zusn(1+imdp/2+iext:imdp+2*iext,       1)=zusn(1       :imdp/2+iext,     2)
+  zusn(1            :imdp/2+iext,  jmdp+2)=zusn(1+imdp/2:imdp  +iext,jmdp+1)
+  zusn(1+imdp/2+iext:imdp+2*iext,  jmdp+2)=zusn(1       :imdp/2+iext,jmdp+1)
+
+!--- COMPUTE LIMITS OF MODEL GRIDPOINT AREA (REGULAR GRID)
+  ALLOCATE(a(imar+1),b(imar+1))
+  b(1:imar)=(x(1:imar  )+ x(2:imar+1))/2.0
+  b(imar+1)= x(  imar+1)+(x(  imar+1)-x(imar))/2.0
+  a(1)=x(1)-(x(2)-x(1))/2.0
+  a(2:imar+1)= b(1:imar)
+
+  ALLOCATE(c(jmar),d(jmar))
+  d(1:jmar-1)=(y(1:jmar-1)+ y(2:jmar))/2.0
+  d(  jmar  )= y(  jmar  )+(y(  jmar)-y(jmar-1))/2.0
+  c(1)=y(1)-(y(2)-y(1))/2.0
+  c(2:jmar)=d(1:jmar-1)
+
+!--- INITIALIZATIONS:
+  ALLOCATE(weight(imar+1,jmar)); weight(:,:)= 0.0
+  ALLOCATE(zxtzx (imar+1,jmar)); zxtzx (:,:)= 0.0
+  ALLOCATE(zytzy (imar+1,jmar)); zytzy (:,:)= 0.0
+  ALLOCATE(zxtzy (imar+1,jmar)); zxtzy (:,:)= 0.0
+  ALLOCATE(ztz   (imar+1,jmar)); ztz   (:,:)= 0.0
+  zmea(:,:)= 0.0
+  zpic(:,:)=-1.E+10
+  zval(:,:)= 1.E+10
+
+!--- COMPUTE SLOPES CORRELATIONS ON USN GRID
+! CORRELATIONS OF USN OROGRAPHY GRADIENTS  ! dim (imdp+2*iext,jmdp+2)
+  ALLOCATE(zytzyusn(imdp+2*iext,jmdp+2)); zytzyusn(:,:)=0.0
+  ALLOCATE(zxtzxusn(imdp+2*iext,jmdp+2)); zxtzxusn(:,:)=0.0
+  ALLOCATE(zxtzyusn(imdp+2*iext,jmdp+2)); zxtzyusn(:,:)=0.0
+  DO j = 2, jmdp+1
+    zdeltax=zdeltay*cos(yusn(j))
+    DO i = 2, imdp+2*iext-1
+      zytzyusn(i,j)=(zusn(i,j+1)-zusn(i,j-1))**2/zdeltay**2
+      zxtzxusn(i,j)=(zusn(i+1,j)-zusn(i-1,j))**2/zdeltax**2
+      zxtzyusn(i,j)=(zusn(i,j+1)-zusn(i,j-1))   /zdeltay  &
+     &             *(zusn(i+1,j)-zusn(i-1,j))   /zdeltax
+    END DO
+  END DO
+
+!--- SUMMATION OVER GRIDPOINT AREA
+  zleny=xpi/REAL(jmdp)*rad
+  xincr=xpi/REAL(jmdp)/2.
+  ALLOCATE(num_tot(imar+1,jmar)); num_tot(:,:)=0.
+  ALLOCATE(num_lan(imar+1,jmar)); num_lan(:,:)=0.
+  DO ii = 1, imar+1
+    DO jj = 1, jmar
+      DO j = 2,jmdp+1 
+        zlenx=zleny*COS(yusn(j))
+        zdeltax=zdeltay*COS(yusn(j))
+        weighy=(xincr+AMIN1(c(jj)-yusn(j),yusn(j)-d(jj)))*rad
+        weighy=AMAX1(0.,AMIN1(weighy,zleny))
+
+        IF(weighy==0.) CYCLE
+        DO i = 2, imdp+2*iext-1
+          weighx=(xincr+AMIN1(xusn(i)-a(ii),b(ii)-xusn(i)))*rad*COS(yusn(j))
+          weighx=AMAX1(0.,AMIN1(weighx,zlenx))
+
+          IF(weighx==0.) CYCLE
+          num_tot(ii,jj)=num_tot(ii,jj)+1.0
+          IF(zusn(i,j)>=1.)num_lan(ii,jj)=num_lan(ii,jj)+1.0
+          weight(ii,jj)=weight(ii,jj)+weighx*weighy
+          zxtzx(ii,jj)=zxtzx(ii,jj)+zxtzxusn(i,j)*weighx*weighy
+          zytzy(ii,jj)=zytzy(ii,jj)+zytzyusn(i,j)*weighx*weighy
+          zxtzy(ii,jj)=zxtzy(ii,jj)+zxtzyusn(i,j)*weighx*weighy
+          ztz  (ii,jj)=  ztz(ii,jj)+zusn(i,j)*zusn(i,j)*weighx*weighy
+          zmea (ii,jj)= zmea(ii,jj)+zusn(i,j)*weighx*weighy !--- MEAN
+          zpic (ii,jj)=AMAX1(zpic(ii,jj),zusn(i,j))         !--- PEAKS
+          zval (ii,jj)=AMIN1(zval(ii,jj),zusn(i,j))         !--- VALLEYS
+        END DO
+      END DO
+    END DO
+  END DO
+
+!--- COMPUTE PARAMETERS NEEDED BY LOTT & MILLER (1997) AND LOTT (1999) SSO SCHEME
+  IF(.NOT.masque_lu) THEN
+    WHERE(weight(:,:)/=0.0) mask=num_lan(:,:)/num_tot(:,:)
+  END IF
+  nn=COUNT(weight(:,:)==0.0)
+  IF(nn/=0) WRITE(lunout,*)'Problem with weight ; vanishing occurrences: ',nn
+  WHERE(weight(:,:)/=0.0)
+    zmea (:,:)=zmea (:,:)/weight(:,:)
+    zxtzx(:,:)=zxtzx(:,:)/weight(:,:)
+    zytzy(:,:)=zytzy(:,:)/weight(:,:)
+    zxtzy(:,:)=zxtzy(:,:)/weight(:,:)
+    ztz  (:,:)=ztz  (:,:)/weight(:,:)
+    zstd (:,:)=ztz  (:,:)-zmea(:,:)**2
+  END WHERE
+  WHERE(zstd(:,:)<0) zstd(:,:)=0.
+  zstd (:,:)=SQRT(zstd(:,:))
+
+!--- CORRECT VALUES OF HORIZONTAL SLOPE NEAR THE POLES:
+  zxtzx(:,   1)=zxtzx(:,     2)
+  zxtzx(:,jmar)=zxtzx(:,jmar-1)
+  zxtzy(:,   1)=zxtzy(:,     2)
+  zxtzy(:,jmar)=zxtzy(:,jmar-1)
+  zytzy(:,   1)=zytzy(:,     2)
+  zytzy(:,jmar)=zytzy(:,jmar-1)
+
+!=== FILTERS TO SMOOTH OUT FIELDS FOR INPUT INTO SSO SCHEME.
+!--- FIRST FILTER, MOVING AVERAGE OVER 9 POINTS.
+!-------------------------------------------------------------------------------
+  zphi(:,:)=zmea(:,:)                           ! GK211005 (CG) UNSMOOTHED TOPO
+
+  CALL MVA9(zmea);  CALL MVA9(zstd);  CALL MVA9(zpic);  CALL MVA9(zval)
+  CALL MVA9(zxtzx); CALL MVA9(zxtzy); CALL MVA9(zytzy)
+
+!--- MASK BASED ON GROUND MAXIMUM, 10% THRESHOLD. (SURFACE PARAMS MEANINGLESS)
+  WHERE(weight(:,:)==0.0.OR.mask<0.1)
+    zphi(:,:)=0.0; zmea(:,:)=0.0; zpic(:,:)=0.0; zval(:,:)=0.0; zstd(:,:)=0.0
+  END WHERE
+  DO ii = 1, imar
+    DO jj = 1, jmar
+      IF(weight(ii,jj)==0.0) CYCLE
+    !--- Coefficients K, L et M:
+      xk=(zxtzx(ii,jj)+zytzy(ii,jj))/2.
+      xl=(zxtzx(ii,jj)-zytzy(ii,jj))/2.
+      xm=zxtzy(ii,jj)
+      xp=xk-SQRT(xl**2+xm**2)
+      xq=xk+SQRT(xl**2+xm**2)
+      xw=1.e-8
+      IF(xp<=xw) xp=0.
+      IF(xq<=xw) xq=xw
+      IF(ABS(xm)<=xw) xm=xw*SIGN(1.,xm)
+    !--- SLOPE, ANISOTROPY AND THETA ANGLE
+      zsig(ii,jj)=SQRT(xq)
+      zgam(ii,jj)=xp/xq
+      zthe(ii,jj)=90.*ATAN2(xm,xl)/xpi
+    END DO
+  END DO
+  WHERE(weight(:,:)==0.0.OR.mask<0.1)
+    zsig(:,:)=0.0; zgam(:,:)=0.0; zthe(:,:)=0.0
+  END WHERE
+
+  WRITE(lunout,*)'  MEAN ORO:' ,MAXVAL(zmea)
+  WRITE(lunout,*)'  ST. DEV.:' ,MAXVAL(zstd)
+  WRITE(lunout,*)'  PENTE:'    ,MAXVAL(zsig)
+  WRITE(lunout,*)'  ANISOTROP:',MAXVAL(zgam)
+  WRITE(lunout,*)'  ANGLE:'    ,MINVAL(zthe),MAXVAL(zthe)
+  WRITE(lunout,*)'  pic:'      ,MAXVAL(zpic)
+  WRITE(lunout,*)'  val:'      ,MAXVAL(zval)
+      
+!--- Values at redundant longitude
+  zmea(imar+1,:)=zmea(1,:)
+  zphi(imar+1,:)=zphi(1,:)
+  zpic(imar+1,:)=zpic(1,:)
+  zval(imar+1,:)=zval(1,:)
+  zstd(imar+1,:)=zstd(1,:)
+  zsig(imar+1,:)=zsig(1,:)
+  zgam(imar+1,:)=zgam(1,:)
+  zthe(imar+1,:)=zthe(1,:)
+
+!--- Values at north pole
+  zweinor  =SUM(weight(1:imar,1))
+  zmea(:,1)=SUM(weight(1:imar,1)*zmea(1:imar,1))/zweinor
+  zphi(:,1)=SUM(weight(1:imar,1)*zphi(1:imar,1))/zweinor
+  zpic(:,1)=SUM(weight(1:imar,1)*zpic(1:imar,1))/zweinor
+  zval(:,1)=SUM(weight(1:imar,1)*zval(1:imar,1))/zweinor
+  zstd(:,1)=SUM(weight(1:imar,1)*zstd(1:imar,1))/zweinor
+  zsig(:,1)=SUM(weight(1:imar,1)*zsig(1:imar,1))/zweinor
+  zgam(:,1)=1.; zthe(:,1)=0.
+
+!--- Values at south pole
+  zweisud     =SUM(weight(1:imar,jmar),DIM=1)
+  zmea(:,jmar)=SUM(weight(1:imar,jmar)*zmea(1:imar,jmar))/zweisud
+  zphi(:,jmar)=SUM(weight(1:imar,jmar)*zphi(1:imar,jmar))/zweisud
+  zpic(:,jmar)=SUM(weight(1:imar,jmar)*zpic(1:imar,jmar))/zweisud
+  zval(:,jmar)=SUM(weight(1:imar,jmar)*zval(1:imar,jmar))/zweisud
+  zstd(:,jmar)=SUM(weight(1:imar,jmar)*zstd(1:imar,jmar))/zweisud
+  zsig(:,jmar)=SUM(weight(1:imar,jmar)*zsig(1:imar,jmar))/zweisud
+  zgam(:,jmar)=1.; zthe(:,jmar)=0.
+
+END SUBROUTINE grid_noro
+!
+!-------------------------------------------------------------------------------
+
+
+!-------------------------------------------------------------------------------
+!
+SUBROUTINE grid_noro0(xd,yd,zd,x,y,zphi,mask)
+!
+!===============================================================================
+! Purpose: Extracted from grid_noro to provide geopotential height for dynamics
+!          without any call to physics subroutines.
+!===============================================================================
+  IMPLICIT NONE 
+!-------------------------------------------------------------------------------
+! Arguments:
+  REAL, INTENT(IN)  :: xd(:), yd(:) !--- INPUT  COORDINATES     (imdp) (jmdp)
+  REAL, INTENT(IN)  :: zd(:,:)      !--- INPUT  FIELD           (imdp,  jmdp)
+  REAL, INTENT(IN)  :: x(:), y(:)   !--- OUTPUT COORDINATES     (imar+1) (jmar)
+  REAL, INTENT(OUT) :: zphi(:,:)    !--- GEOPOTENTIAL           (imar+1,jmar)
+  REAL, INTENT(OUT) :: mask(:,:)    !--- MASK                   (imar+1,jmar)
+!-------------------------------------------------------------------------------
+! Local variables:
+  CHARACTER(LEN=256) :: modname="grid_noro0"
+  REAL, ALLOCATABLE :: xusn(:), yusn(:)           ! dim (imdp+2*iext) (jmdp+2)
+  REAL, ALLOCATABLE :: zusn(:,:)                  ! dim (imdp+2*iext,  jmdp+2)
+  REAL, ALLOCATABLE :: weight(:,:)                ! dim (imar+1,jmar)
+  REAL, ALLOCATABLE :: num_tot(:,:), num_lan(:,:) ! dim (imar+1,jmar)
+  REAL, ALLOCATABLE :: a(:), b(:)                 ! dim (imar+1)
+  REAL, ALLOCATABLE :: c(:), d(:)                 ! dim (jmar)
+
+  LOGICAL :: masque_lu
+  INTEGER :: i, ii, imdp, imar, iext
+  INTEGER :: j, jj, jmdp, jmar, nn
+  REAL    :: xpi, zlenx, zleny, weighx, weighy, xincr, masque, rad
+
+!-------------------------------------------------------------------------------
+  imdp=assert_eq(SIZE(xd),SIZE(zd,1),TRIM(modname)//" imdp")
+  jmdp=assert_eq(SIZE(yd),SIZE(zd,2),TRIM(modname)//" jmdp")
+  imar=assert_eq(SIZE(x),SIZE(zphi,1),SIZE(mask,1),TRIM(modname)//" imar")-1
+  jmar=assert_eq(SIZE(y),SIZE(zphi,2),SIZE(mask,2),TRIM(modname)//" jmar")
+  iext=imdp/10
+  xpi = ACOS(-1.)
+  rad = 6371229.
+
+!--- ARE WE USING A READ MASK ?
+  masque_lu=ANY(mask/=-99999.); IF(.NOT.masque_lu) mask=0.0
+  WRITE(lunout,*)'Masque lu: ',masque_lu
+
+!--- EXTENSION OF THE INPUT DATABASE TO PROCEED COMPUTATIONS AT BOUNDARIES:
+  ALLOCATE(xusn(imdp+2*iext))
+  xusn(1     +iext:imdp  +iext)=xd(:)
+  xusn(1          :       iext)=xd(1+imdp-iext:imdp)-2.*xpi
+  xusn(1+imdp+iext:imdp+2*iext)=xd(1          :iext)+2.*xpi
+
+  ALLOCATE(yusn(jmdp+2))
+  yusn(1       )=yd(1)   +(yd(1)   -yd(2))
+  yusn(2:jmdp+1)=yd(:)
+  yusn(  jmdp+2)=yd(jmdp)+(yd(jmdp)-yd(jmdp-1))
+
+  ALLOCATE(zusn(imdp+2*iext,jmdp+2))
+  zusn(1       +iext:imdp  +iext,2:jmdp+1)=zd  (:                   ,     :)
+  zusn(1            :       iext,2:jmdp+1)=zd  (imdp-iext+1:imdp    ,     :)
+  zusn(1+imdp  +iext:imdp+2*iext,2:jmdp+1)=zd  (1:iext              ,     :)
+  zusn(1            :imdp/2+iext,       1)=zusn(1+imdp/2:imdp  +iext,     2)
+  zusn(1+imdp/2+iext:imdp+2*iext,       1)=zusn(1       :imdp/2+iext,     2)
+  zusn(1            :imdp/2+iext,  jmdp+2)=zusn(1+imdp/2:imdp  +iext,jmdp+1)
+  zusn(1+imdp/2+iext:imdp+2*iext,  jmdp+2)=zusn(1       :imdp/2+iext,jmdp+1)
+
+!--- COMPUTE LIMITS OF MODEL GRIDPOINT AREA (REGULAR GRID)
+  ALLOCATE(a(imar+1),b(imar+1))
+  b(1:imar)=(x(1:imar  )+ x(2:imar+1))/2.0
+  b(imar+1)= x(  imar+1)+(x(  imar+1)-x(imar))/2.0
+  a(1)=x(1)-(x(2)-x(1))/2.0
+  a(2:imar+1)= b(1:imar)
+
+  ALLOCATE(c(jmar),d(jmar))
+  d(1:jmar-1)=(y(1:jmar-1)+ y(2:jmar))/2.0
+  d(  jmar  )= y(  jmar  )+(y(  jmar)-y(jmar-1))/2.0
+  c(1)=y(1)-(y(2)-y(1))/2.0
+  c(2:jmar)=d(1:jmar-1)
+
+!--- INITIALIZATIONS:
+  ALLOCATE(weight(imar+1,jmar)); weight(:,:)=0.0; zphi(:,:)=0.0
+
+!--- SUMMATION OVER GRIDPOINT AREA
+  zleny=xpi/REAL(jmdp)*rad
+  xincr=xpi/REAL(jmdp)/2.
+  ALLOCATE(num_tot(imar+1,jmar)); num_tot(:,:)=0.
+  ALLOCATE(num_lan(imar+1,jmar)); num_lan(:,:)=0.
+  DO ii = 1, imar+1
+    DO jj = 1, jmar
+      DO j = 2,jmdp+1 
+        zlenx=zleny*COS(yusn(j))
+        weighy=(xincr+AMIN1(c(jj)-yusn(j),yusn(j)-d(jj)))*rad
+        weighy=AMAX1(0.,AMIN1(weighy,zleny))
+        IF(weighy/=0) CYCLE
+        DO i = 2, imdp+2*iext-1
+          weighx=(xincr+AMIN1(xusn(i)-a(ii),b(ii)-xusn(i)))*rad*COS(yusn(j))
+          weighx=AMAX1(0.,AMIN1(weighx,zlenx))
+          IF(weighx/=0) CYCLE
+          num_tot(ii,jj)=num_tot(ii,jj)+1.0
+          IF(zusn(i,j)>=1.)num_lan(ii,jj)=num_lan(ii,jj)+1.0
+          weight(ii,jj)=weight(ii,jj)+weighx*weighy
+          zphi  (ii,jj)=zphi  (ii,jj)+zusn(i,j)*weighx*weighy !--- MEAN
+        END DO
+      END DO
+    END DO
+  END DO
+
+!--- COMPUTE PARAMETERS NEEDED BY LOTT & MILLER (1997) AND LOTT (1999) SSO SCHEME
+  IF(.NOT.masque_lu) THEN
+    WHERE(weight(:,:)/=0.0) mask=num_lan(:,:)/num_tot(:,:)
+  END IF
+  nn=COUNT(weight(:,:)==0.0)
+  IF(nn/=0) WRITE(lunout,*)'Problem with weight ; vanishing occurrences: ',nn
+  WHERE(weight/=0.0) zphi(:,:)=zphi(:,:)/weight(:,:)
+
+!--- MASK BASED ON GROUND MAXIMUM, 10% THRESHOLD (<10%: SURF PARAMS MEANINGLESS)
+  WHERE(weight(:,:)==0.0.OR.mask<0.1) zphi(:,:)=0.0
+  WRITE(lunout,*)'  MEAN ORO:' ,MAXVAL(zphi)
+
+!--- Values at redundant longitude and at poles
+  zphi(imar+1,:)=zphi(1,:)
+  zphi(:,   1)=SUM(weight(1:imar,   1)*zphi(1:imar,   1))/SUM(weight(1:imar,   1))
+  zphi(:,jmar)=SUM(weight(1:imar,jmar)*zphi(1:imar,jmar))/SUM(weight(1:imar,jmar))
+
+END SUBROUTINE grid_noro0
+!
+!-------------------------------------------------------------------------------
+
+
+!-------------------------------------------------------------------------------
+!
+SUBROUTINE read_noro(x,y,fname,zphi,zmea,zstd,zsig,zgam,zthe,zpic,zval,mask)
+!
+!-------------------------------------------------------------------------------
+! Purpose: Read parameters usually determined with grid_noro from a file.
+!===============================================================================
+  USE netcdf, ONLY: NF90_OPEN,  NF90_INQ_DIMID, NF90_INQUIRE_DIMENSION,        &
+        NF90_NOERR, NF90_CLOSE, NF90_INQ_VARID, NF90_GET_VAR, NF90_STRERROR,   &
+        NF90_NOWRITE
+  IMPLICIT NONE 
+!-------------------------------------------------------------------------------
+! Arguments:
+  REAL, INTENT(IN)  :: x(:), y(:)    !--- OUTPUT COORDINATES     (imar+1) (jmar)
+  CHARACTER(LEN=*), INTENT(IN) :: fname ! PARAMETERS FILE NAME
+  REAL, INTENT(OUT) :: zphi(:,:)     !--- GEOPOTENTIAL           (imar+1,jmar)
+  REAL, INTENT(OUT) :: zmea(:,:)     !--- MEAN OROGRAPHY         (imar+1,jmar)
+  REAL, INTENT(OUT) :: zstd(:,:)     !--- STANDARD DEVIATION     (imar+1,jmar)
+  REAL, INTENT(OUT) :: zsig(:,:)     !--- SLOPE                  (imar+1,jmar)
+  REAL, INTENT(OUT) :: zgam(:,:)     !--- ANISOTROPY             (imar+1,jmar)
+  REAL, INTENT(OUT) :: zthe(:,:)     !--- SMALL AXIS ORIENTATION (imar+1,jmar)
+  REAL, INTENT(OUT) :: zpic(:,:)     !--- MAXIMUM ALTITUDE       (imar+1,jmar)
+  REAL, INTENT(OUT) :: zval(:,:)     !--- MINIMUM ALTITUDE       (imar+1,jmar)
+  REAL, INTENT(OUT) :: mask(:,:)     !--- MASK                   (imar+1,jmar)
+!-------------------------------------------------------------------------------
+! Local variables:
+  CHARACTER(LEN=256) :: modname="read_noro"
+  INTEGER :: imar, jmar, fid, did, vid
+  LOGICAL :: masque_lu
+  REAL :: xpi, d2r
+!-------------------------------------------------------------------------------
+  imar=assert_eq([SIZE(x),SIZE(zphi,1),SIZE(zmea,1),SIZE(zstd,1),SIZE(zsig,1), &
+                          SIZE(zgam,1),SIZE(zthe,1),SIZE(zpic,1),SIZE(zval,1), &
+                          SIZE(mask,1)],TRIM(modname)//" imar")-1
+  jmar=assert_eq([SIZE(y),SIZE(zphi,2),SIZE(zmea,2),SIZE(zstd,2),SIZE(zsig,2), &
+                          SIZE(zgam,2),SIZE(zthe,2),SIZE(zpic,2),SIZE(zval,2), &
+                          SIZE(mask,2)],TRIM(modname)//" jmar")
+  xpi=ACOS(-1.0); d2r=xpi/180.
+  WRITE(lunout,*)"*** Orography parameters at sub-cell scale from file ***"
+
+!--- ARE WE USING A READ MASK ?
+  masque_lu=ANY(mask/=-99999.); IF(.NOT.masque_lu) mask=0.0
+  WRITE(lunout,*)'Masque lu: ',masque_lu
+  CALL ncerr(NF90_OPEN(fname,NF90_NOWRITE,fid))
+  CALL check_dim('x','longitude',x(1:imar))
+  CALL check_dim('y','latitude' ,y(1:jmar))
+  IF(.NOT.masque_lu) CALL get_fld('mask',mask)
+  CALL get_fld('Zphi',zphi)
+  CALL get_fld('Zmea',zmea)
+  CALL get_fld('mu'  ,zstd)
+  CALL get_fld('Zsig',zsig)
+  CALL get_fld('Zgam',zgam)
+  CALL get_fld('Zthe',zthe)
+  zpic=zmea+2*zstd
+  zval=MAX(0.,zmea-2.*zstd)
+  CALL ncerr(NF90_CLOSE(fid))
+  WRITE(lunout,*)'  MEAN ORO:' ,MAXVAL(zmea)
+  WRITE(lunout,*)'  ST. DEV.:' ,MAXVAL(zstd)
+  WRITE(lunout,*)'  PENTE:'    ,MAXVAL(zsig)
+  WRITE(lunout,*)'  ANISOTROP:',MAXVAL(zgam)
+  WRITE(lunout,*)'  ANGLE:'    ,MINVAL(zthe),MAXVAL(zthe)
+  WRITE(lunout,*)'  pic:'      ,MAXVAL(zpic)
+  WRITE(lunout,*)'  val:'      ,MAXVAL(zval)
+
+CONTAINS
+
+
+SUBROUTINE get_fld(var,fld)
+  CHARACTER(LEN=*), INTENT(IN)    :: var
+  REAL,             INTENT(INOUT) :: fld(:,:)
+  CALL ncerr(NF90_INQ_VARID(fid,var,vid),var)
+  CALL ncerr(NF90_GET_VAR(fid,vid,fld(1:imar,:)),var)
+  fld(imar+1,:)=fld(1,:)
+END SUBROUTINE get_fld
+
+SUBROUTINE check_dim(dimd,nam,dimv)
+  CHARACTER(LEN=*), INTENT(IN) :: dimd
+  CHARACTER(LEN=*), INTENT(IN) :: nam
+  REAL,             INTENT(IN) :: dimv(:)
+  REAL, ALLOCATABLE :: tmp(:)
+  INTEGER :: n
+  CALL ncerr(NF90_INQ_DIMID(fid,dimd,did))
+  CALL ncerr(NF90_INQUIRE_DIMENSION(fid,did,len=n)); ALLOCATE(tmp(n))
+  CALL ncerr(NF90_INQ_VARID(fid,dimd,did))
+  CALL ncerr(NF90_GET_VAR(fid,did,tmp))
+  IF(MAXVAL(tmp)>xpi) tmp=tmp*d2r
+  IF(n/=SIZE(dimv).OR.ANY(ABS(tmp-dimv)>1E-6)) THEN
+    WRITE(lunout,*)'Problem with file "'//TRIM(fname)//'".'
+    CALL abort_physic(modname,'Grid differs from LMDZ for '//TRIM(nam)//'.',1)
+  END IF
+END SUBROUTINE check_dim
+
+SUBROUTINE ncerr(ncres,var)
+  IMPLICIT NONE
+  INTEGER,          INTENT(IN) :: ncres
+  CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: var
+  CHARACTER(LEN=256) :: mess
+  IF(ncres/=NF90_NOERR) THEN
+    mess='Problem with file "'//TRIM(fname)//'"'
+    IF(PRESENT(var)) mess=TRIM(mess)//' and variable "'//TRIM(var)//'"'
+    WRITE(lunout,*)TRIM(mess)//'.'
+    CALL abort_physic(modname,NF90_STRERROR(ncres),1)
+  END IF
+END SUBROUTINE ncerr
+
+END SUBROUTINE read_noro
+!
+!-------------------------------------------------------------------------------
+
+
+!-------------------------------------------------------------------------------
+!
+SUBROUTINE MVA9(x)
+!
+!-------------------------------------------------------------------------------
+  IMPLICIT NONE
+! MAKE A MOVING AVERAGE OVER 9 GRIDPOINTS OF THE X FIELDS
+!-------------------------------------------------------------------------------
+! Arguments:
+  REAL, INTENT(INOUT) :: x(:,:)
+!-------------------------------------------------------------------------------
+! Local variables:
+  REAL    :: xf(SIZE(x,DIM=1),SIZE(x,DIM=2)), WEIGHTpb(-1:1,-1:1)
+  INTEGER :: i, j, imar, jmar
+!-------------------------------------------------------------------------------
+  WEIGHTpb=RESHAPE([((1./REAL((1+i**2)*(1+j**2)),i=-1,1),j=-1,1)],SHAPE=[3,3])
+  WEIGHTpb=WEIGHTpb/SUM(WEIGHTpb)
+  imar=SIZE(X,DIM=1); jmar=SIZE(X,DIM=2)
+  DO j=2,jmar-1
+    DO i=2,imar-1
+      xf(i,j)=SUM(x(i-1:i+1,j-1:j+1)*WEIGHTpb(:,:))
+    END DO
+  END DO
+  DO j=2,jmar-1
+    xf(1,j)=SUM(x(imar-1,j-1:j+1)*WEIGHTpb(-1,:))
+    xf(1,j)=xf(1,j)+SUM(x(1:2,j-1:j+1)*WEIGHTpb(0:1,-1:1))
+    xf(imar,j)=xf(1,j)
+  END DO
+  xf(:,   1)=xf(:,     2)
+  xf(:,jmar)=xf(:,jmar-1)
+  x(:,:)=xf(:,:)
+
+END SUBROUTINE MVA9
+!
+!-------------------------------------------------------------------------------
+
+
+END MODULE grid_noro_m
+
+
Index: DZ6/trunk/libf/phylmd/haut2bas.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/haut2bas.F90	(revision 5267)
+++ 	(revision )
@@ -1,19 +1,0 @@
-
-! $Header$
-
-SUBROUTINE haut2bas(klon, klev, varb2h, varh2b)
-  IMPLICIT NONE
-
-  INTEGER klon, klev
-  REAL varb2h(klon, klev), varh2b(klon, klev)
-  INTEGER i, k, kinv
-
-  DO k = 1, klev
-    kinv = klev - k + 1
-    DO i = 1, klon
-      varh2b(i, k) = varb2h(i, kinv)
-    END DO
-  END DO
-
-  RETURN
-END SUBROUTINE haut2bas
Index: /LMDZ6/trunk/libf/phylmd/haut2bas.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/haut2bas.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/haut2bas.f90	(revision 5268)
@@ -0,0 +1,19 @@
+
+! $Header$
+
+SUBROUTINE haut2bas(klon, klev, varb2h, varh2b)
+  IMPLICIT NONE
+
+  INTEGER klon, klev
+  REAL varb2h(klon, klev), varh2b(klon, klev)
+  INTEGER i, k, kinv
+
+  DO k = 1, klev
+    kinv = klev - k + 1
+    DO i = 1, klon
+      varh2b(i, k) = varb2h(i, kinv)
+    END DO
+  END DO
+
+  RETURN
+END SUBROUTINE haut2bas
Index: DZ6/trunk/libf/phylmd/hbtm2l.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/hbtm2l.F90	(revision 5267)
+++ 	(revision )
@@ -1,700 +1,0 @@
-
-! $Header$
-
-SUBROUTINE hbtm2l(knon, paprs, pplay, t2m, t10m, q2m, q10m, ustar, flux_t, flux_q, u, v, t, q, pblh, therm, plcl, cape, &
-    cin, eauliq, ctei, d_qt, d_thv, dlt_2, xhis, posint, omega, diagok)
-  USE dimphy
-  IMPLICIT NONE
-
-  ! ***************************************************************
-  ! *                                                             *
-  ! * HBTM2L   D'apres Holstag&Boville et Troen&Mahrt             *
-  ! *                 JAS 47              BLM                     *
-  ! * Algorithmes These Anne Mathieu                              *
-  ! * Critere d'Entrainement Peter Duynkerke (JAS 50)             *
-  ! * written by  : Anne MATHIEU & Alain LAHELLEC, 22/11/99       *
-  ! * features : implem. exces Mathieu                            *
-  ! ***************************************************************
-  ! * mods : decembre 99 passage th a niveau plus bas. voir fixer *
-  ! ***************************************************************
-  ! * fin therm a la HBTM passage a forme Mathieu 12/09/2001      *
-  ! ***************************************************************
-  ! AM Fev 2003 Adaptation a LMDZ version couplee                 *
-  ! *
-  ! Pour le moment on fait passer en argument les grdeurs de surface :
-  ! flux, t,q2m, t,q10m, on va utiliser systematiquement les grdeurs a 2m ms
-  ! on garde la possibilite de changer si besoin est (jusqu'a present la
-  ! forme de HB avec le 1er niveau modele etait conservee)       *
-  ! ***************************************************************
-  ! * re-ecriture complete Alain Mars 2012 dans LMDZ5V5           *
-  ! ***************************************************************
-  include "YOMCST.h"
-  REAL rlvcp, reps
-  ! Arguments:
-
-  INTEGER knon ! nombre de points a calculer
-  ! AM
-  REAL t2m(klon), t10m(klon) ! temperature a 2 et 10m
-  REAL q2m(klon), q10m(klon) ! q a 2 et 10m
-  REAL ustar(klon)
-  REAL paprs(klon, klev+1) ! pression a inter-couche (Pa)
-  REAL pplay(klon, klev) ! pression au milieu de couche (Pa)
-  REAL flux_t(klon, klev), flux_q(klon, klev) ! Flux
-  REAL u(klon, klev) ! vitesse U (m/s)
-  REAL v(klon, klev) ! vitesse V (m/s)
-  REAL t(klon, klev) ! temperature (K)
-  REAL q(klon, klev) ! vapeur d'eau (kg/kg)
-
-  INTEGER isommet
-  REAL vk
-  PARAMETER (vk=0.35) ! Von Karman => passer a .41 ! cf U.Olgstrom
-  REAL ricr
-  PARAMETER (ricr=0.4)
-  REAL fak
-  PARAMETER (fak=8.5) ! b calcul du Prandtl et de dTetas
-  REAL fakn
-  PARAMETER (fakn=7.2) ! a
-  REAL onet
-  PARAMETER (onet=1.0/3.0)
-  REAL betam
-  PARAMETER (betam=15.0) ! pour Phim / h dans la S.L stable
-  REAL betah
-  PARAMETER (betah=15.0)
-  REAL betas
-  PARAMETER (betas=5.0) ! Phit dans la S.L. stable (mais 2 formes / z/OBL<>1
-  REAL sffrac
-  PARAMETER (sffrac=0.1) ! S.L. = z/h < .1
-  REAL binm
-  PARAMETER (binm=betam*sffrac)
-  REAL binh
-  PARAMETER (binh=betah*sffrac)
-
-  REAL q_star, t_star
-  REAL b1, b2, b212, b2sr ! Lambert correlations T' q' avec T* q*
-  PARAMETER (b1=70., b2=20.) ! b1 entre 70 et 100
-
-  REAL z(klon, klev)
-  ! AM
-  REAL zref, dt0
-  PARAMETER (zref=2.) ! Niveau de ref a 2m
-  PARAMETER (dt0=0.1) ! convergence do while
-
-  INTEGER i, k, j
-  REAL khfs(klon) ! surface kinematic heat flux [mK/s]
-  REAL kqfs(klon) ! sfc kinematic constituent flux [m/s]
-  REAL heatv(klon) ! surface virtual heat flux
-  REAL rhino(klon, klev) ! bulk Richardon no. mais en Theta_v
-  LOGICAL unstbl(klon) ! pts w/unstbl pbl (positive virtual ht flx)
-  LOGICAL check(klon) ! True=>chk if Richardson no.>critcal
-  LOGICAL omegafl(klon) ! flag de prolongement cape pour pt Omega
-  REAL obklen(klon) ! Monin-Obukhov lengh
-
-  REAL pblh(klon) ! PBL H               (m)
-  REAL therm(klon) ! exces du thermique  (K)
-  REAL plcl(klon) ! Lifted Cnd Level (Pa)
-  REAL cape(klon) ! Cape
-  REAL cin(klon) ! Inhibition
-  REAL eauliq(klon) ! Eau Liqu integree
-  REAL ctei(klon) ! Cld Top Entr. Instab.
-  REAL d_qt(klon) ! Saut de qT a l'inversion
-  REAL d_thv(klon) !         Theta_e
-  REAL dlt_2(klon) ! Ordonnee a gauche de courbe de melange
-  REAL xhis(klon) ! fraction de melange pour flottab nulle
-  REAL posint(klon) ! partie positive de l'int. de Peter
-  REAL omega(klon) ! point ultime de l'ascention du thermique
-  REAL diagok(klon) ! pour traiter les sous-mailles sans info
-  ! Algorithme thermique
-  REAL s(klon, klev) ! [P/Po]^Kappa milieux couches
-  REAL th_th(klon) ! potential temperature of thermal
-  REAL the_th(klon) ! equivalent potential temperature of thermal
-  REAL qt_th(klon) ! total water of thermal
-  REAL tbef(klon) ! T thermique niveau ou calcul precedent
-  LOGICAL zsat(klon) ! le thermique est sature
-  LOGICAL zcin(klon) ! calcul d'inhibition
-  REAL kape(klon) ! Cape locale
-  REAL kin(klon) ! Cin locale
-  ! calcul de CTEI etc
-  REAL the1, the2, aa, bb, zthvd, zthvu, qsat, chi, rh, zxt, zdu2
-  REAL rnum, denom, th1, th2, tv1, tv2, thv1, thv2, ql1, ql2, dt
-  REAL dqsat_dt, qsat2, qt1, q1, q2, t1, t2, tl1, te2, xnull, delt_the
-  REAL delt_qt, quadsat, spblh, reduc
-  ! diag      REAL dTv21(klon,klev)
-
-  REAL phiminv(klon) ! inverse phi function for momentum
-  REAL phihinv(klon) ! inverse phi function for heat
-  REAL wm(klon) ! turbulent velocity scale for momentum
-  REAL zm(klon) ! current level height
-  REAL zp(klon) ! current level height + one level up
-  REAL zcor, zdelta, zcvm5
-  REAL fac, pblmin
-  REAL missing_val
-
-  include "YOETHF.h"
-  include "FCTTRE.h"
-
-  ! c      missing_val=nf90_fill_real (avec include netcdf)
-  missing_val = 0.
-
-  ! initialisations (Anne)
-  isommet = klev
-  b212 = sqrt(b1*b2)
-  b2sr = sqrt(b2)
-
-  ! Initialisation thermo
-  rlvcp = rlvtt/rcpd
-  reps = rd/rv
-  ! raz
-  q_star = 0.
-  t_star = 0.
-  cape(:) = missing_val
-  kape(:) = 0.
-  cin(:) = missing_val
-  eauliq(:) = missing_val
-  ctei(:) = missing_val
-  d_qt(:) = missing_val
-  d_thv(:) = missing_val
-  dlt_2(:) = missing_val
-  xhis(:) = missing_val
-  posint(:) = missing_val
-  kin(:) = missing_val
-  omega(:) = missing_val
-  diagok(:) = 0.
-  ! diag      dTv21(:,:)= missing_val
-
-  ! Calculer les hauteurs de chaque couche
-  DO i = 1, knon
-    z(i, 1) = rd*t(i, 1)/(0.5*(paprs(i,1)+pplay(i,1)))*(paprs(i,1)-pplay(i,1))/rg
-    s(i, 1) = (pplay(i,1)/paprs(i,1))**rkappa
-  END DO
-  ! s(k) = [pplay(k)/ps]^kappa
-  ! + + + + + + + + + pplay  <-> s(k)   t  dp=pplay(k-1)-pplay(k)
-
-  ! -----------------  paprs <-> sig(k)
-
-  ! + + + + + + + + + pplay  <-> s(k-1)
-
-
-  ! + + + + + + + + + pplay  <-> s(1)   t  dp=paprs-pplay   z(1)
-
-  ! -----------------  paprs <-> sig(1)
-
-  DO k = 2, klev
-    DO i = 1, knon
-      z(i, k) = z(i, k-1) + rd*0.5*(t(i,k-1)+t(i,k))/paprs(i, k)*(pplay(i,k-1)-pplay(i,k))/rg
-      s(i, k) = (pplay(i,k)/paprs(i,1))**rkappa
-    END DO
-  END DO
-  ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-  ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-  ! +++  Determination des grandeurs de surface  +++++++++++++++++++++
-  ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-  ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-  DO i = 1, knon
-    ! AM Niveau de ref choisi a 2m
-    zxt = t2m(i)
-
-    ! ***************************************************
-    ! attention, il doit s'agir de <w'theta'>
-    ! ;Calcul de tcls virtuel et de w'theta'virtuel
-    ! ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-    ! tcls=tcls*(1+.608*qcls)
-
-    ! ;Pour avoir w'theta',
-    ! ; il faut diviser par ro.Cp
-    ! Cp=Cpd*(1+0.84*qcls)
-    ! fcs=fcs/(ro_surf*Cp)
-    ! ;On transforme w'theta' en w'thetav'
-    ! Lv=(2.501-0.00237*(tcls-273.15))*1.E6
-    ! xle=xle/(ro_surf*Lv)
-    ! fcsv=fcs+.608*xle*tcls
-    ! ***************************************************
-    ! dif khfs est deja w't'_v / heatv(i) = khfs(i) + RETV*zxt*kqfs(i)
-    ! AM calcul de Ro = paprs(i,1)/Rd zxt
-    ! AM convention >0 vers le bas ds lmdz
-    khfs(i) = -flux_t(i, 1)*zxt*rd/(rcpd*paprs(i,1))
-    kqfs(i) = -flux_q(i, 1)*zxt*rd/(paprs(i,1))
-    ! AM   verifier que khfs et kqfs sont bien de la forme w'l'
-    heatv(i) = khfs(i) + retv*zxt*kqfs(i)
-    ! a comparer aussi aux sorties de clqh : flux_T/RoCp et flux_q/RoLv
-    ! AM ustar est en entree (calcul dans stdlevvar avec t2m q2m)
-    ! Theta et qT du thermique sans exces
-    qt_th(i) = q2m(i)
-    ! Al1 Th_th restera la Theta du thermique sans exces jusqu'au 3eme calcul
-    th_th(i) = t2m(i)
-  END DO
-
-  DO i = 1, knon
-    rhino(i, 1) = 0.0 ! Global Richardson
-    check(i) = .TRUE.
-    pblh(i) = z(i, 1) ! on initialise pblh a l'altitude du 1er niveau
-    ! Attention Plcl est pression ou altitude ?
-    ! plcl(i) = 6000. ! m
-    plcl(i) = 200. ! hPa
-    IF (heatv(i)>0.0001) THEN
-      ! Lambda = -u*^3 / (alpha.g.kvon.<w'Theta'v>
-      obklen(i) = -t(i, 1)*ustar(i)**3/(rg*vk*heatv(i))
-    ELSE
-      ! set pblh to the friction high (cf + bas)
-      pblh(i) = 700.0*ustar(i)
-      check(i) = .FALSE.
-    END IF
-  END DO
-
-
-  ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-  ! PBL height calculation:
-  ! Search for level of pbl. Scan upward until the Richardson number between
-  ! the first level and the current level exceeds the "critical" value.
-  ! (bonne idee Nu de separer le Ric et l'exces de temp du thermique)
-  ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-  fac = 100.0
-  DO k = 2, isommet
-    DO i = 1, knon
-      IF (check(i)) THEN
-        zdu2 = u(i, k)**2 + v(i, k)**2
-        zdu2 = max(zdu2, 1.0E-20)
-        ! Theta_v environnement
-        zthvd = t(i, k)/s(i, k)*(1.+retv*q(i,k))
-        zthvu = th_th(i)*(1.+retv*qt_th(i))
-        ! Le Ri bulk par Theta_v
-        rhino(i, k) = (z(i,k)-zref)*rg*(zthvd-zthvu)/(zdu2*0.5*(zthvd+zthvu))
-
-        IF (rhino(i,k)>=ricr) THEN
-          pblh(i) = z(i, k-1) + (z(i,k-1)-z(i,k))*(ricr-rhino(i,k-1))/(rhino(i,k-1)-rhino(i,k))
-          ! test04 (la pblh est encore ici sous-estime'e)
-          pblh(i) = pblh(i) + 100.
-          ! pblT(i) = t(i,k-1) + (t(i,k)-t(i,k-1)) *
-          ! .              (pblh(i)-z(i,k-1))/(z(i,k)-z(i,k-1))
-          check(i) = .FALSE.
-        END IF
-      END IF
-    END DO
-  END DO
-
-
-  ! Set pbl height to maximum value where computation exceeds number of
-  ! layers allowed
-
-  DO i = 1, knon
-    IF (check(i)) pblh(i) = z(i, isommet)
-  END DO
-
-  ! Improve estimate of pbl height for the unstable points.
-  ! Find unstable points (sensible heat flux is upward):
-
-  DO i = 1, knon
-    IF (heatv(i)>0.) THEN
-      unstbl(i) = .TRUE.
-      check(i) = .TRUE.
-    ELSE
-      unstbl(i) = .FALSE.
-      check(i) = .FALSE.
-    END IF
-  END DO
-
-  ! For the unstable case, compute velocity scale and the
-  ! convective temperature excess:
-
-  DO i = 1, knon
-    IF (check(i)) THEN
-      phiminv(i) = (1.-binm*pblh(i)/obklen(i))**onet
-      ! ***************************************************
-      ! Wm ? et W* ? c'est la formule pour z/h < .1
-      ! ;Calcul de w* ;;
-      ! ;;;;;;;;;;;;;;;;
-      ! w_star=((g/tcls)*fcsv*z(ind))^(1/3.) [ou prendre la premiere approx de h)
-      ! ;; CALCUL DE wm ;;
-      ! ;;;;;;;;;;;;;;;;;;
-      ! ; Ici on considerera que l'on est dans la couche de surf jusqu'a 100m
-      ! ; On prend svt couche de surface=0.1*h mais on ne connait pas h
-      ! ;;;;;;;;;;;Dans la couche de surface
-      ! if (z(ind) le 20) then begin
-      ! Phim=(1.-15.*(z(ind)/L))^(-1/3.)
-      ! wm=u_star/Phim
-      ! ;;;;;;;;;;;En dehors de la couche de surface
-      ! endif else if (z(ind) gt 20) then begin
-      ! wm=(u_star^3+c1*w_star^3)^(1/3.)
-      ! endif
-      ! ***************************************************
-      wm(i) = ustar(i)*phiminv(i)
-      ! ======================================================================
-      ! valeurs de Dominique Lambert de la campagne SEMAPHORE :
-      ! <T'^2> = 100.T*^2; <q'^2> = 20.q*^2 a 10m
-      ! <Tv'^2> = (1+1.2q).100.T* + 1.2Tv.sqrt(20*100).T*.q* + (.608*Tv)^2*20.q*^2;
-      ! et dTetavS = sqrt(<Tv'^2>) ainsi calculee.
-      ! avec : T*=<w'T'>_s/w* et q*=<w'q'>/w*
-      ! !!! on peut donc utiliser w* pour les fluctuations <-> Lambert
-      ! (leur corellation pourrait dependre de beta par ex)
-      ! if fcsv(i,j) gt 0 then begin
-      ! dTetavs=b1*(1.+2.*.608*q_10(i,j))*(fcs(i,j)/wm(i,j))^2+$
-      ! (.608*Thetav_10(i,j))^2*b2*(xle(i,j)/wm(i,j))^2+$
-      ! 2.*.608*thetav_10(i,j)*sqrt(b1*b2)*(xle(i,j)/wm(i,j))*(fcs(i,j)/wm(i,j))
-      ! dqs=b2*(xle(i,j)/wm(i,j))^2
-      ! theta_s(i,j)=thetav_10(i,j)+sqrt(dTetavs)
-      ! q_s(i,j)=q_10(i,j)+sqrt(dqs)
-      ! endif else begin
-      ! Theta_s(i,j)=thetav_10(i,j)
-      ! q_s(i,j)=q_10(i,j)
-      ! endelse
-      ! leur reference est le niveau a 10m, mais on prend 2m ici.
-      ! ======================================================================
-      ! Premier calcul de l'exces tu thermique
-      ! ======================================================================
-      ! HBTM        therm(i) = heatv(i)*fak/wm(i)
-      ! forme Mathieu :
-      q_star = max(0., kqfs(i)/wm(i))
-      t_star = max(0., khfs(i)/wm(i))
-      ! Al1 Houston, we have a problem : il arrive en effet que heatv soit
-      ! positif (=thermique instable) mais pas t_star : avec evaporation
-      ! importante, il se peut qu'on refroidisse la 2m Que faire alors ?
-      ! Garder le seul terme en q_star^2 ? ou rendre negatif le t_star^2 ?
-      therm(i) = sqrt(b1*(1.+2.*retv*qt_th(i))*t_star**2+(retv*th_th(i))**2*b2*q_star*q_star+2.*retv*th_th(i)*b212* &
-        q_star*t_star)
-
-      ! Theta et qT du thermique (forme H&B) avec exces
-      ! (attention, on ajoute therm(i) qui est virtuelle ...)
-      ! pourquoi pas sqrt(b1)*t_star ?
-      ! dqs = b2sr*kqfs(i)/wm(i)
-      qt_th(i) = qt_th(i) + b2sr*q_star
-      rhino(i, 1) = 0.0
-    END IF
-  END DO
-
-  ! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-  ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-  ! ++ Improve pblh estimate for unstable conditions using the +++++++
-  ! ++          convective temperature excess :                +++++++
-  ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-  ! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-
-  DO k = 2, isommet
-    DO i = 1, knon
-      IF (check(i)) THEN
-        ! test     zdu2 = (u(i,k)-u(i,1))**2+(v(i,k)-v(i,1))**2+fac*ustar(i)**2
-        zdu2 = u(i, k)**2 + v(i, k)**2
-        zdu2 = max(zdu2, 1.0E-20)
-        ! Theta_v environnement
-        zthvd = t(i, k)/s(i, k)*(1.+retv*q(i,k))
-
-        ! et therm Theta_v (avec hypothese de constance de H&B,
-        ! qui assimile qT a vapeur)
-        zthvu = th_th(i)*(1.+retv*qt_th(i)) + therm(i)
-
-
-        ! Le Ri par Theta_v
-        ! AM Niveau de ref 2m
-        rhino(i, k) = (z(i,k)-zref)*rg*(zthvd-zthvu)/(zdu2*0.5*(zthvd+zthvu))
-
-        ! Niveau critique atteint
-        IF (rhino(i,k)>=ricr) THEN
-          pblh(i) = z(i, k-1) + (z(i,k-1)-z(i,k))*(ricr-rhino(i,k-1))/(rhino(i,k-1)-rhino(i,k))
-          ! test04
-          pblh(i) = pblh(i) + 100.
-          ! pblT(i) = t(i,k-1) + (t(i,k)-t(i,k-1)) *
-          ! .              (pblh(i)-z(i,k-1))/(z(i,k)-z(i,k-1))
-          check(i) = .FALSE.
-        END IF
-      END IF
-    END DO
-  END DO
-
-  ! Set pbl height to maximum value where computation exceeds number of
-  ! layers allowed (H&B)
-
-  DO i = 1, knon
-    IF (check(i)) pblh(i) = z(i, isommet)
-  END DO
-
-  ! PBL height must be greater than some minimum mechanical mixing depth
-  ! Several investigators have proposed minimum mechanical mixing depth
-  ! relationships as a function of the local friction velocity, u*.  We
-  ! make use of a linear relationship of the form h = c u* where c=700.
-  ! The scaling arguments that give rise to this relationship most often
-  ! represent the coefficient c as some constant over the local coriolis
-  ! parameter.  Here we make use of the experimental results of Koracin
-  ! and Berkowicz (1988) [BLM, Vol 43] for wich they recommend 0.07/f
-  ! where f was evaluated at 39.5 N and 52 N.  Thus we use a typical mid
-  ! latitude value for f so that c = 0.07/f = 700.  (H&B)
-  ! Al1 calcul de pblT dans ce cas
-  DO i = 1, knon
-    pblmin = 700.0*ustar(i)
-    IF (pblh(i)<pblmin) check(i) = .TRUE.
-  END DO
-  DO i = 1, knon
-    IF (check(i)) THEN
-      pblh(i) = 700.0*ustar(i)
-      ! et par exemple :
-      ! pblT(i) = t(i,2) + (t(i,3)-t(i,2)) *
-      ! .              (pblh(i)-z(i,2))/(z(i,3)-z(i,2))
-    END IF
-  END DO
-
-  ! ********************************************************************
-  ! pblh is now available; do preparation for final calculations :
-  ! ********************************************************************
-  DO i = 1, knon
-    check(i) = .TRUE.
-    zsat(i) = .FALSE.
-    zcin(i) = .FALSE.
-    ! omegafl utilise pour prolongement CAPE
-    omegafl(i) = .FALSE.
-
-    ! Do additional preparation for unstable cases only, set temperature
-    ! and moisture perturbations depending on stability.
-    ! Rq: les formules sont prises dans leur forme Couche de Surface
-    IF (unstbl(i)) THEN
-      ! Al pblh a change', on recalcule :
-      zxt = (th_th(i)-zref*0.5*rg/rcpd/(1.+rvtmp2*qt_th(i)))*(1.+retv*qt_th(i))
-      phiminv(i) = (1.-binm*pblh(i)/obklen(i))**onet
-      phihinv(i) = sqrt(1.-binh*pblh(i)/obklen(i))
-      wm(i) = ustar(i)*phiminv(i)
-    END IF
-  END DO
-
-
-  ! =======================================================
-  ! last upward integration
-  ! For all unstable layers, compute integral info and CTEI
-  ! =======================================================
-
-  ! 1/Recompute surface characteristics with the improved pblh
-  ! ----------------------------------------------------------
-  DO i = 1, knon
-    IF (unstbl(i)) THEN
-      diagok(i) = 1.
-      ! from missing_value to zero
-      cape(i) = 0.
-      cin(i) = 0.
-      eauliq(i) = 0.
-      ctei(i) = 0.
-      d_qt(i) = 0.
-      d_thv(i) = 0.
-      dlt_2(i) = 0.
-      xhis(i) = 0.
-      posint(i) = 0.
-      kin(i) = 0.
-      omega(i) = 0.
-
-      phiminv(i) = (1.-binm*pblh(i)/obklen(i))**onet
-      wm(i) = ustar(i)*phiminv(i)
-      q_star = max(0., kqfs(i)/wm(i))
-      t_star = max(0., khfs(i)/wm(i))
-      therm(i) = sqrt(b1*(1.+2.*retv*qt_th(i))*t_star**2+(retv*th_th(i))**2*b2*q_star*q_star+2.*retv*th_th(i)*b212* &
-        q_star*t_star)
-      ! Al1diag
-      ! trmb1(i) = b1*(1.+2.*RETV*qT_th(i))*t_star**2
-      ! trmb2(i) = (RETV*Th_th(i))**2*b2*q_star*q_star
-      ! trmb3(i) = 2.*RETV*Th_th(i)*b212*q_star*t_star
-
-      ! Th_th will now be the thermal-theta (including exces)
-      ! c         Th_th(i) = Th_th(i)+sqrt(b1)*max(0.,khfs(i)/wm(i))
-      th_th(i) = th_th(i) + therm(i)
-      ! al1diag
-      ! trmb2(i) = wm(i)
-      ! trmb3(i) = phiminv(i)
-      ! and computes Theta_e for thermal
-      the_th(i) = th_th(i) + rlvcp*qt_th(i)
-    END IF ! unstbl
-    ! Al1 compute a first guess of Plcl with the Bolton/Emanuel formula
-    t2 = th_th(i)
-    ! thermodyn functions
-    zdelta = max(0., sign(1.,rtt-t2))
-    qsat = r2es*foeew(t2, zdelta)/paprs(i, 1)
-    qsat = min(0.5, qsat)
-    zcor = 1./(1.-retv*qsat)
-    qsat = qsat*zcor
-    ! relative humidity of thermal at 2m
-    rh = qt_th(i)/qsat
-    chi = t2/(1669.0-122.0*rh-t2)
-    plcl(i) = paprs(i, 1)*(rh**chi)
-    ! al1diag
-    ! ctei(i) = Plcl(i)
-    ! cape(i) = T2
-    ! trmb1(i)= Chi
-    ! select unstable columns (=thermals)
-    check(i) = .FALSE.
-    IF (heatv(i)>0.) check(i) = .TRUE.
-    ! diag
-    ! dTv21(i,1) = T2*(1+RETV*qT_th(i))-t(i,1)*(1+RETV*q(i,1))
-  END DO
-  ! ----------------------------------
-  ! 2/ upward integration for thermals
-  ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ k loop
-  DO k = 2, isommet
-    DO i = 1, knon
-      IF (check(i) .OR. omegafl(i)) THEN
-        ! CC         if (pplay(i,k) .le. plcl(i)) then
-        zm(i) = z(i, k-1)
-        zp(i) = z(i, k)
-        ! Environnement : calcul de Tv1 a partir de t(:,:)== T liquide
-        ! ==============
-        tl1 = t(i, k)
-        t1 = tl1
-        zdelta = max(0., sign(1.,rtt-t1))
-        qsat = r2es*foeew(t1, zdelta)/pplay(i, k)
-        qsat = min(0.5, qsat)
-        zcor = 1./(1.-retv*qsat)
-        qsat = qsat*zcor
-        q1 = min(q(i,k), qsat)
-        ql1 = max(0., q(i,k)-q1)
-        ! thermodyn function (Tl2Tql)
-        dt = rlvcp*ql1
-        DO WHILE (abs(dt)>=dt0)
-          t1 = t1 + dt
-          zdelta = max(0., sign(1.,rtt-t1))
-          zcvm5 = r5les*(1.-zdelta) + r5ies*zdelta
-          qsat = r2es*foeew(t1, zdelta)/pplay(i, k)
-          qsat = min(0.5, qsat)
-          zcor = 1./(1.-retv*qsat)
-          qsat = qsat*zcor
-          dqsat_dt = foede(t1, zdelta, zcvm5, qsat, zcor)
-          ! correction lineaire pour conserver Tl env
-          ! << Tl = T1 + DT - RLvCp*(ql1 - dqsat/dT*DT >>
-          denom = 1. + rlvcp*dqsat_dt
-          q1 = min(q(i,k), qsat)
-          ql1 = q(i, k) - q1 ! can be negative
-          rnum = tl1 - t1 + rlvcp*ql1
-          dt = rnum/denom
-        END DO
-        ql1 = max(0., ql1)
-        tv1 = t1*(1.+retv*q1-ql1)
-        ! Thermique    : on atteint le seuil B/E de condensation
-        ! ==============
-
-        IF (.NOT. zsat(i)) THEN
-          ! first guess from The_th(i) = Th_th(i) + RLvCp* [qv=qT_th(i)]
-          t2 = s(i, k)*the_th(i) - rlvcp*qt_th(i)
-          zdelta = max(0., sign(1.,rtt-t2))
-          qsat = r2es*foeew(t2, zdelta)/pplay(i, k)
-          qsat = min(0.5, qsat)
-          zcor = 1./(1.-retv*qsat)
-          qsat = qsat*zcor
-          q2 = min(qt_th(i), qsat)
-          ql2 = max(0., qt_th(i)-q2)
-          IF (ql2>0.0001) zsat(i) = .TRUE.
-          tbef(i) = t2
-          ! a PBLH non sature
-          IF (zm(i)<pblh(i) .AND. zp(i)>=pblh(i)) THEN
-            reduc = (pblh(i)-zm(i))/(zp(i)-zm(i))
-            spblh = s(i, k-1) + reduc*(s(i,k)-s(i,k-1))
-            ! lmdz : qT1 et Thv1
-            t1 = (t(i,k-1)+reduc*(t(i,k)-t(i,k-1)))
-            thv1 = t1*(1.+retv*q(i,k))/spblh
-            ! on calcule pour le cas sans nuage un ctei en Delta Thv
-            thv2 = t2/spblh*(1.+retv*qt_th(i))
-            ctei(i) = thv1 - thv2
-            tv2 = t2*(1.+retv*q2-ql2)
-            ! diag
-            ! dTv21(i,k) = Tv2-Tv1
-            check(i) = .FALSE.
-            omegafl(i) = .TRUE.
-          END IF
-        END IF
-
-        IF (zsat(i)) THEN
-          ! thermodyn functions (Te2Tqsat)
-          t2 = tbef(i)
-          dt = 1.
-          te2 = s(i, k)*the_th(i)
-          DO WHILE (abs(dt)>=dt0)
-            zdelta = max(0., sign(1.,rtt-t2))
-            zcvm5 = r5les*(1.-zdelta) + r5ies*zdelta
-            qsat = r2es*foeew(t2, zdelta)/pplay(i, k)
-            qsat = min(0.5, qsat)
-            zcor = 1./(1.-retv*qsat)
-            qsat = qsat*zcor
-            dqsat_dt = foede(t2, zdelta, zcvm5, qsat, zcor)
-            ! correction lineaire pour conserver Te_th
-            ! << Te = T2 + DT + RLvCp*(qsatbef + dq/dT*DT >>
-            denom = 1. + rlvcp*dqsat_dt
-            rnum = te2 - t2 - rlvcp*qsat
-            dt = rnum/denom
-            t2 = t2 + dt
-          END DO
-          q2 = min(qt_th(i), qsat)
-          ql2 = max(0., qt_th(i)-q2)
-          ! jusqu'a PBLH y compris
-          IF (zm(i)<pblh(i)) THEN
-
-            ! mais a PBLH, interpolation et complements
-            IF (zp(i)>=pblh(i)) THEN
-              reduc = (pblh(i)-zm(i))/(zp(i)-zm(i))
-              spblh = s(i, k-1) + reduc*(s(i,k)-s(i,k-1))
-              ! CAPE et EauLiq a pblH
-              cape(i) = kape(i) + reduc*(zp(i)-zm(i))*rg*.5/(tv2+tv1)*max(0., (tv2-tv1))
-              eauliq(i) = eauliq(i) + reduc*(paprs(i,k-1)-paprs(i,k))*ql2/rg
-              ! CTEI
-              the2 = (t2+rlvcp*q2)/spblh
-              ! T1 est en realite la Tl env (on a donc strict The1)
-              t1 = (t(i,k-1)+reduc*(t(i,k)-t(i,k-1)))
-              the1 = (t1+rlvcp*q(i,k))/spblh
-              ! Calcul de la Cloud Top Entrainement Instability
-              ! cf Mathieu Lahellec QJRMS (2005) Comments to DYCOMS-II
-              ! saut a l'inversion :
-              delt_the = the1 - the2 ! negatif
-              delt_qt = q(i, k) - qt_th(i) ! negatif
-              d_qt(i) = -delt_qt
-              dlt_2(i) = .63*delt_the - the2*delt_qt
-              ! init ctei(i)
-              ctei(i) = dlt_2(i)
-              IF (dlt_2(i)<-0.1) THEN
-                ! integrale de Peter :
-                aa = delt_the - delt_qt*(rlvcp-retv*the2)
-                bb = (rlvcp-(1.+retv)*the2)*ql2
-                d_thv(i) = aa - bb
-                ! approx de Xhi_s et de l'integrale Xint=ctei(i)
-                xhis(i) = bb/(aa-dlt_2(i))
-                ! trmb1(i) = xhis
-                ! trmb3(i) = dlt_2
-                xnull = bb/aa
-                IF (xhis(i)>0.1) THEN
-                  ctei(i) = dlt_2(i)*xhis(i) + aa*(1.-xhis(i)) + bb*alog(xhis(i))
-                ELSE
-                  ctei(i) = .5*(dlt_2(i)+aa-bb)
-                END IF
-                IF (xnull>0.) THEN
-                  posint(i) = aa - bb + bb*alog(xnull)
-                ELSE
-                  posint(i) = 0.
-                END IF
-              ELSE
-                ctei(i) = 1.
-                posint(i) = 1.
-              END IF
-              check(i) = .FALSE.
-              omegafl(i) = .TRUE.
-            END IF ! end a pblh
-            IF (check(i)) eauliq(i) = eauliq(i) + (paprs(i,k)-paprs(i,k+1))*ql2/rg
-          END IF
-
-        END IF ! Zsat
-
-        ! KAPE : thermique / environnement
-        tv2 = t2*(1.+retv*q2-ql2)
-        ! diag
-        ! dTv21(i,k) = Tv2-Tv1
-        ! Kape courante
-        kape(i) = kape(i) + (zp(i)-zm(i))*rg*.5/(tv2+tv1)*max(0., (tv2-tv1))
-        ! Cin
-        IF (zcin(i) .AND. tv2-tv1>0.) THEN
-          zcin(i) = .FALSE.
-          cin(i) = kin(i)
-        END IF
-        IF (.NOT. zcin(i) .AND. tv2-tv1<0.) THEN
-          zcin(i) = .TRUE.
-          kin(i) = kin(i) + (zp(i)-zm(i))*rg*.5/(tv2+tv1)*min(0., (tv2-tv1))
-        END IF
-        IF (kape(i)+kin(i)<0.) THEN
-          omega(i) = zm(i)
-          ! trmb3(i) = paprs(i,k)
-          omegafl(i) = .FALSE.
-          ! diag
-          ! print*,'Tv2-Tv1 (k): ',i,(dTv21(i,j),j=1,k)
-        END IF
-        ! CC         EndIf !plcl
-      END IF ! check(i)
-    END DO
-  END DO ! end of level loop
-  ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ end k loop
-  RETURN
-END SUBROUTINE hbtm2l
Index: /LMDZ6/trunk/libf/phylmd/hbtm2l.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/hbtm2l.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/hbtm2l.f90	(revision 5268)
@@ -0,0 +1,700 @@
+
+! $Header$
+
+SUBROUTINE hbtm2l(knon, paprs, pplay, t2m, t10m, q2m, q10m, ustar, flux_t, flux_q, u, v, t, q, pblh, therm, plcl, cape, &
+    cin, eauliq, ctei, d_qt, d_thv, dlt_2, xhis, posint, omega, diagok)
+  USE dimphy
+  IMPLICIT NONE
+
+  ! ***************************************************************
+  ! *                                                             *
+  ! * HBTM2L   D'apres Holstag&Boville et Troen&Mahrt             *
+  ! *                 JAS 47              BLM                     *
+  ! * Algorithmes These Anne Mathieu                              *
+  ! * Critere d'Entrainement Peter Duynkerke (JAS 50)             *
+  ! * written by  : Anne MATHIEU & Alain LAHELLEC, 22/11/99       *
+  ! * features : implem. exces Mathieu                            *
+  ! ***************************************************************
+  ! * mods : decembre 99 passage th a niveau plus bas. voir fixer *
+  ! ***************************************************************
+  ! * fin therm a la HBTM passage a forme Mathieu 12/09/2001      *
+  ! ***************************************************************
+  ! AM Fev 2003 Adaptation a LMDZ version couplee                 *
+  ! *
+  ! Pour le moment on fait passer en argument les grdeurs de surface :
+  ! flux, t,q2m, t,q10m, on va utiliser systematiquement les grdeurs a 2m ms
+  ! on garde la possibilite de changer si besoin est (jusqu'a present la
+  ! forme de HB avec le 1er niveau modele etait conservee)       *
+  ! ***************************************************************
+  ! * re-ecriture complete Alain Mars 2012 dans LMDZ5V5           *
+  ! ***************************************************************
+  include "YOMCST.h"
+  REAL rlvcp, reps
+  ! Arguments:
+
+  INTEGER knon ! nombre de points a calculer
+  ! AM
+  REAL t2m(klon), t10m(klon) ! temperature a 2 et 10m
+  REAL q2m(klon), q10m(klon) ! q a 2 et 10m
+  REAL ustar(klon)
+  REAL paprs(klon, klev+1) ! pression a inter-couche (Pa)
+  REAL pplay(klon, klev) ! pression au milieu de couche (Pa)
+  REAL flux_t(klon, klev), flux_q(klon, klev) ! Flux
+  REAL u(klon, klev) ! vitesse U (m/s)
+  REAL v(klon, klev) ! vitesse V (m/s)
+  REAL t(klon, klev) ! temperature (K)
+  REAL q(klon, klev) ! vapeur d'eau (kg/kg)
+
+  INTEGER isommet
+  REAL vk
+  PARAMETER (vk=0.35) ! Von Karman => passer a .41 ! cf U.Olgstrom
+  REAL ricr
+  PARAMETER (ricr=0.4)
+  REAL fak
+  PARAMETER (fak=8.5) ! b calcul du Prandtl et de dTetas
+  REAL fakn
+  PARAMETER (fakn=7.2) ! a
+  REAL onet
+  PARAMETER (onet=1.0/3.0)
+  REAL betam
+  PARAMETER (betam=15.0) ! pour Phim / h dans la S.L stable
+  REAL betah
+  PARAMETER (betah=15.0)
+  REAL betas
+  PARAMETER (betas=5.0) ! Phit dans la S.L. stable (mais 2 formes / z/OBL<>1
+  REAL sffrac
+  PARAMETER (sffrac=0.1) ! S.L. = z/h < .1
+  REAL binm
+  PARAMETER (binm=betam*sffrac)
+  REAL binh
+  PARAMETER (binh=betah*sffrac)
+
+  REAL q_star, t_star
+  REAL b1, b2, b212, b2sr ! Lambert correlations T' q' avec T* q*
+  PARAMETER (b1=70., b2=20.) ! b1 entre 70 et 100
+
+  REAL z(klon, klev)
+  ! AM
+  REAL zref, dt0
+  PARAMETER (zref=2.) ! Niveau de ref a 2m
+  PARAMETER (dt0=0.1) ! convergence do while
+
+  INTEGER i, k, j
+  REAL khfs(klon) ! surface kinematic heat flux [mK/s]
+  REAL kqfs(klon) ! sfc kinematic constituent flux [m/s]
+  REAL heatv(klon) ! surface virtual heat flux
+  REAL rhino(klon, klev) ! bulk Richardon no. mais en Theta_v
+  LOGICAL unstbl(klon) ! pts w/unstbl pbl (positive virtual ht flx)
+  LOGICAL check(klon) ! True=>chk if Richardson no.>critcal
+  LOGICAL omegafl(klon) ! flag de prolongement cape pour pt Omega
+  REAL obklen(klon) ! Monin-Obukhov lengh
+
+  REAL pblh(klon) ! PBL H               (m)
+  REAL therm(klon) ! exces du thermique  (K)
+  REAL plcl(klon) ! Lifted Cnd Level (Pa)
+  REAL cape(klon) ! Cape
+  REAL cin(klon) ! Inhibition
+  REAL eauliq(klon) ! Eau Liqu integree
+  REAL ctei(klon) ! Cld Top Entr. Instab.
+  REAL d_qt(klon) ! Saut de qT a l'inversion
+  REAL d_thv(klon) !         Theta_e
+  REAL dlt_2(klon) ! Ordonnee a gauche de courbe de melange
+  REAL xhis(klon) ! fraction de melange pour flottab nulle
+  REAL posint(klon) ! partie positive de l'int. de Peter
+  REAL omega(klon) ! point ultime de l'ascention du thermique
+  REAL diagok(klon) ! pour traiter les sous-mailles sans info
+  ! Algorithme thermique
+  REAL s(klon, klev) ! [P/Po]^Kappa milieux couches
+  REAL th_th(klon) ! potential temperature of thermal
+  REAL the_th(klon) ! equivalent potential temperature of thermal
+  REAL qt_th(klon) ! total water of thermal
+  REAL tbef(klon) ! T thermique niveau ou calcul precedent
+  LOGICAL zsat(klon) ! le thermique est sature
+  LOGICAL zcin(klon) ! calcul d'inhibition
+  REAL kape(klon) ! Cape locale
+  REAL kin(klon) ! Cin locale
+  ! calcul de CTEI etc
+  REAL the1, the2, aa, bb, zthvd, zthvu, qsat, chi, rh, zxt, zdu2
+  REAL rnum, denom, th1, th2, tv1, tv2, thv1, thv2, ql1, ql2, dt
+  REAL dqsat_dt, qsat2, qt1, q1, q2, t1, t2, tl1, te2, xnull, delt_the
+  REAL delt_qt, quadsat, spblh, reduc
+  ! diag      REAL dTv21(klon,klev)
+
+  REAL phiminv(klon) ! inverse phi function for momentum
+  REAL phihinv(klon) ! inverse phi function for heat
+  REAL wm(klon) ! turbulent velocity scale for momentum
+  REAL zm(klon) ! current level height
+  REAL zp(klon) ! current level height + one level up
+  REAL zcor, zdelta, zcvm5
+  REAL fac, pblmin
+  REAL missing_val
+
+  include "YOETHF.h"
+  include "FCTTRE.h"
+
+  ! c      missing_val=nf90_fill_real (avec include netcdf)
+  missing_val = 0.
+
+  ! initialisations (Anne)
+  isommet = klev
+  b212 = sqrt(b1*b2)
+  b2sr = sqrt(b2)
+
+  ! Initialisation thermo
+  rlvcp = rlvtt/rcpd
+  reps = rd/rv
+  ! raz
+  q_star = 0.
+  t_star = 0.
+  cape(:) = missing_val
+  kape(:) = 0.
+  cin(:) = missing_val
+  eauliq(:) = missing_val
+  ctei(:) = missing_val
+  d_qt(:) = missing_val
+  d_thv(:) = missing_val
+  dlt_2(:) = missing_val
+  xhis(:) = missing_val
+  posint(:) = missing_val
+  kin(:) = missing_val
+  omega(:) = missing_val
+  diagok(:) = 0.
+  ! diag      dTv21(:,:)= missing_val
+
+  ! Calculer les hauteurs de chaque couche
+  DO i = 1, knon
+    z(i, 1) = rd*t(i, 1)/(0.5*(paprs(i,1)+pplay(i,1)))*(paprs(i,1)-pplay(i,1))/rg
+    s(i, 1) = (pplay(i,1)/paprs(i,1))**rkappa
+  END DO
+  ! s(k) = [pplay(k)/ps]^kappa
+  ! + + + + + + + + + pplay  <-> s(k)   t  dp=pplay(k-1)-pplay(k)
+
+  ! -----------------  paprs <-> sig(k)
+
+  ! + + + + + + + + + pplay  <-> s(k-1)
+
+
+  ! + + + + + + + + + pplay  <-> s(1)   t  dp=paprs-pplay   z(1)
+
+  ! -----------------  paprs <-> sig(1)
+
+  DO k = 2, klev
+    DO i = 1, knon
+      z(i, k) = z(i, k-1) + rd*0.5*(t(i,k-1)+t(i,k))/paprs(i, k)*(pplay(i,k-1)-pplay(i,k))/rg
+      s(i, k) = (pplay(i,k)/paprs(i,1))**rkappa
+    END DO
+  END DO
+  ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+  ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+  ! +++  Determination des grandeurs de surface  +++++++++++++++++++++
+  ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+  ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+  DO i = 1, knon
+    ! AM Niveau de ref choisi a 2m
+    zxt = t2m(i)
+
+    ! ***************************************************
+    ! attention, il doit s'agir de <w'theta'>
+    ! ;Calcul de tcls virtuel et de w'theta'virtuel
+    ! ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+    ! tcls=tcls*(1+.608*qcls)
+
+    ! ;Pour avoir w'theta',
+    ! ; il faut diviser par ro.Cp
+    ! Cp=Cpd*(1+0.84*qcls)
+    ! fcs=fcs/(ro_surf*Cp)
+    ! ;On transforme w'theta' en w'thetav'
+    ! Lv=(2.501-0.00237*(tcls-273.15))*1.E6
+    ! xle=xle/(ro_surf*Lv)
+    ! fcsv=fcs+.608*xle*tcls
+    ! ***************************************************
+    ! dif khfs est deja w't'_v / heatv(i) = khfs(i) + RETV*zxt*kqfs(i)
+    ! AM calcul de Ro = paprs(i,1)/Rd zxt
+    ! AM convention >0 vers le bas ds lmdz
+    khfs(i) = -flux_t(i, 1)*zxt*rd/(rcpd*paprs(i,1))
+    kqfs(i) = -flux_q(i, 1)*zxt*rd/(paprs(i,1))
+    ! AM   verifier que khfs et kqfs sont bien de la forme w'l'
+    heatv(i) = khfs(i) + retv*zxt*kqfs(i)
+    ! a comparer aussi aux sorties de clqh : flux_T/RoCp et flux_q/RoLv
+    ! AM ustar est en entree (calcul dans stdlevvar avec t2m q2m)
+    ! Theta et qT du thermique sans exces
+    qt_th(i) = q2m(i)
+    ! Al1 Th_th restera la Theta du thermique sans exces jusqu'au 3eme calcul
+    th_th(i) = t2m(i)
+  END DO
+
+  DO i = 1, knon
+    rhino(i, 1) = 0.0 ! Global Richardson
+    check(i) = .TRUE.
+    pblh(i) = z(i, 1) ! on initialise pblh a l'altitude du 1er niveau
+    ! Attention Plcl est pression ou altitude ?
+    ! plcl(i) = 6000. ! m
+    plcl(i) = 200. ! hPa
+    IF (heatv(i)>0.0001) THEN
+      ! Lambda = -u*^3 / (alpha.g.kvon.<w'Theta'v>
+      obklen(i) = -t(i, 1)*ustar(i)**3/(rg*vk*heatv(i))
+    ELSE
+      ! set pblh to the friction high (cf + bas)
+      pblh(i) = 700.0*ustar(i)
+      check(i) = .FALSE.
+    END IF
+  END DO
+
+
+  ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+  ! PBL height calculation:
+  ! Search for level of pbl. Scan upward until the Richardson number between
+  ! the first level and the current level exceeds the "critical" value.
+  ! (bonne idee Nu de separer le Ric et l'exces de temp du thermique)
+  ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+  fac = 100.0
+  DO k = 2, isommet
+    DO i = 1, knon
+      IF (check(i)) THEN
+        zdu2 = u(i, k)**2 + v(i, k)**2
+        zdu2 = max(zdu2, 1.0E-20)
+        ! Theta_v environnement
+        zthvd = t(i, k)/s(i, k)*(1.+retv*q(i,k))
+        zthvu = th_th(i)*(1.+retv*qt_th(i))
+        ! Le Ri bulk par Theta_v
+        rhino(i, k) = (z(i,k)-zref)*rg*(zthvd-zthvu)/(zdu2*0.5*(zthvd+zthvu))
+
+        IF (rhino(i,k)>=ricr) THEN
+          pblh(i) = z(i, k-1) + (z(i,k-1)-z(i,k))*(ricr-rhino(i,k-1))/(rhino(i,k-1)-rhino(i,k))
+          ! test04 (la pblh est encore ici sous-estime'e)
+          pblh(i) = pblh(i) + 100.
+          ! pblT(i) = t(i,k-1) + (t(i,k)-t(i,k-1)) *
+          ! .              (pblh(i)-z(i,k-1))/(z(i,k)-z(i,k-1))
+          check(i) = .FALSE.
+        END IF
+      END IF
+    END DO
+  END DO
+
+
+  ! Set pbl height to maximum value where computation exceeds number of
+  ! layers allowed
+
+  DO i = 1, knon
+    IF (check(i)) pblh(i) = z(i, isommet)
+  END DO
+
+  ! Improve estimate of pbl height for the unstable points.
+  ! Find unstable points (sensible heat flux is upward):
+
+  DO i = 1, knon
+    IF (heatv(i)>0.) THEN
+      unstbl(i) = .TRUE.
+      check(i) = .TRUE.
+    ELSE
+      unstbl(i) = .FALSE.
+      check(i) = .FALSE.
+    END IF
+  END DO
+
+  ! For the unstable case, compute velocity scale and the
+  ! convective temperature excess:
+
+  DO i = 1, knon
+    IF (check(i)) THEN
+      phiminv(i) = (1.-binm*pblh(i)/obklen(i))**onet
+      ! ***************************************************
+      ! Wm ? et W* ? c'est la formule pour z/h < .1
+      ! ;Calcul de w* ;;
+      ! ;;;;;;;;;;;;;;;;
+      ! w_star=((g/tcls)*fcsv*z(ind))^(1/3.) [ou prendre la premiere approx de h)
+      ! ;; CALCUL DE wm ;;
+      ! ;;;;;;;;;;;;;;;;;;
+      ! ; Ici on considerera que l'on est dans la couche de surf jusqu'a 100m
+      ! ; On prend svt couche de surface=0.1*h mais on ne connait pas h
+      ! ;;;;;;;;;;;Dans la couche de surface
+      ! if (z(ind) le 20) then begin
+      ! Phim=(1.-15.*(z(ind)/L))^(-1/3.)
+      ! wm=u_star/Phim
+      ! ;;;;;;;;;;;En dehors de la couche de surface
+      ! endif else if (z(ind) gt 20) then begin
+      ! wm=(u_star^3+c1*w_star^3)^(1/3.)
+      ! endif
+      ! ***************************************************
+      wm(i) = ustar(i)*phiminv(i)
+      ! ======================================================================
+      ! valeurs de Dominique Lambert de la campagne SEMAPHORE :
+      ! <T'^2> = 100.T*^2; <q'^2> = 20.q*^2 a 10m
+      ! <Tv'^2> = (1+1.2q).100.T* + 1.2Tv.sqrt(20*100).T*.q* + (.608*Tv)^2*20.q*^2;
+      ! et dTetavS = sqrt(<Tv'^2>) ainsi calculee.
+      ! avec : T*=<w'T'>_s/w* et q*=<w'q'>/w*
+      ! !!! on peut donc utiliser w* pour les fluctuations <-> Lambert
+      ! (leur corellation pourrait dependre de beta par ex)
+      ! if fcsv(i,j) gt 0 then begin
+      ! dTetavs=b1*(1.+2.*.608*q_10(i,j))*(fcs(i,j)/wm(i,j))^2+$
+      ! (.608*Thetav_10(i,j))^2*b2*(xle(i,j)/wm(i,j))^2+$
+      ! 2.*.608*thetav_10(i,j)*sqrt(b1*b2)*(xle(i,j)/wm(i,j))*(fcs(i,j)/wm(i,j))
+      ! dqs=b2*(xle(i,j)/wm(i,j))^2
+      ! theta_s(i,j)=thetav_10(i,j)+sqrt(dTetavs)
+      ! q_s(i,j)=q_10(i,j)+sqrt(dqs)
+      ! endif else begin
+      ! Theta_s(i,j)=thetav_10(i,j)
+      ! q_s(i,j)=q_10(i,j)
+      ! endelse
+      ! leur reference est le niveau a 10m, mais on prend 2m ici.
+      ! ======================================================================
+      ! Premier calcul de l'exces tu thermique
+      ! ======================================================================
+      ! HBTM        therm(i) = heatv(i)*fak/wm(i)
+      ! forme Mathieu :
+      q_star = max(0., kqfs(i)/wm(i))
+      t_star = max(0., khfs(i)/wm(i))
+      ! Al1 Houston, we have a problem : il arrive en effet que heatv soit
+      ! positif (=thermique instable) mais pas t_star : avec evaporation
+      ! importante, il se peut qu'on refroidisse la 2m Que faire alors ?
+      ! Garder le seul terme en q_star^2 ? ou rendre negatif le t_star^2 ?
+      therm(i) = sqrt(b1*(1.+2.*retv*qt_th(i))*t_star**2+(retv*th_th(i))**2*b2*q_star*q_star+2.*retv*th_th(i)*b212* &
+        q_star*t_star)
+
+      ! Theta et qT du thermique (forme H&B) avec exces
+      ! (attention, on ajoute therm(i) qui est virtuelle ...)
+      ! pourquoi pas sqrt(b1)*t_star ?
+      ! dqs = b2sr*kqfs(i)/wm(i)
+      qt_th(i) = qt_th(i) + b2sr*q_star
+      rhino(i, 1) = 0.0
+    END IF
+  END DO
+
+  ! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+  ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+  ! ++ Improve pblh estimate for unstable conditions using the +++++++
+  ! ++          convective temperature excess :                +++++++
+  ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+  ! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+  DO k = 2, isommet
+    DO i = 1, knon
+      IF (check(i)) THEN
+        ! test     zdu2 = (u(i,k)-u(i,1))**2+(v(i,k)-v(i,1))**2+fac*ustar(i)**2
+        zdu2 = u(i, k)**2 + v(i, k)**2
+        zdu2 = max(zdu2, 1.0E-20)
+        ! Theta_v environnement
+        zthvd = t(i, k)/s(i, k)*(1.+retv*q(i,k))
+
+        ! et therm Theta_v (avec hypothese de constance de H&B,
+        ! qui assimile qT a vapeur)
+        zthvu = th_th(i)*(1.+retv*qt_th(i)) + therm(i)
+
+
+        ! Le Ri par Theta_v
+        ! AM Niveau de ref 2m
+        rhino(i, k) = (z(i,k)-zref)*rg*(zthvd-zthvu)/(zdu2*0.5*(zthvd+zthvu))
+
+        ! Niveau critique atteint
+        IF (rhino(i,k)>=ricr) THEN
+          pblh(i) = z(i, k-1) + (z(i,k-1)-z(i,k))*(ricr-rhino(i,k-1))/(rhino(i,k-1)-rhino(i,k))
+          ! test04
+          pblh(i) = pblh(i) + 100.
+          ! pblT(i) = t(i,k-1) + (t(i,k)-t(i,k-1)) *
+          ! .              (pblh(i)-z(i,k-1))/(z(i,k)-z(i,k-1))
+          check(i) = .FALSE.
+        END IF
+      END IF
+    END DO
+  END DO
+
+  ! Set pbl height to maximum value where computation exceeds number of
+  ! layers allowed (H&B)
+
+  DO i = 1, knon
+    IF (check(i)) pblh(i) = z(i, isommet)
+  END DO
+
+  ! PBL height must be greater than some minimum mechanical mixing depth
+  ! Several investigators have proposed minimum mechanical mixing depth
+  ! relationships as a function of the local friction velocity, u*.  We
+  ! make use of a linear relationship of the form h = c u* where c=700.
+  ! The scaling arguments that give rise to this relationship most often
+  ! represent the coefficient c as some constant over the local coriolis
+  ! parameter.  Here we make use of the experimental results of Koracin
+  ! and Berkowicz (1988) [BLM, Vol 43] for wich they recommend 0.07/f
+  ! where f was evaluated at 39.5 N and 52 N.  Thus we use a typical mid
+  ! latitude value for f so that c = 0.07/f = 700.  (H&B)
+  ! Al1 calcul de pblT dans ce cas
+  DO i = 1, knon
+    pblmin = 700.0*ustar(i)
+    IF (pblh(i)<pblmin) check(i) = .TRUE.
+  END DO
+  DO i = 1, knon
+    IF (check(i)) THEN
+      pblh(i) = 700.0*ustar(i)
+      ! et par exemple :
+      ! pblT(i) = t(i,2) + (t(i,3)-t(i,2)) *
+      ! .              (pblh(i)-z(i,2))/(z(i,3)-z(i,2))
+    END IF
+  END DO
+
+  ! ********************************************************************
+  ! pblh is now available; do preparation for final calculations :
+  ! ********************************************************************
+  DO i = 1, knon
+    check(i) = .TRUE.
+    zsat(i) = .FALSE.
+    zcin(i) = .FALSE.
+    ! omegafl utilise pour prolongement CAPE
+    omegafl(i) = .FALSE.
+
+    ! Do additional preparation for unstable cases only, set temperature
+    ! and moisture perturbations depending on stability.
+    ! Rq: les formules sont prises dans leur forme Couche de Surface
+    IF (unstbl(i)) THEN
+      ! Al pblh a change', on recalcule :
+      zxt = (th_th(i)-zref*0.5*rg/rcpd/(1.+rvtmp2*qt_th(i)))*(1.+retv*qt_th(i))
+      phiminv(i) = (1.-binm*pblh(i)/obklen(i))**onet
+      phihinv(i) = sqrt(1.-binh*pblh(i)/obklen(i))
+      wm(i) = ustar(i)*phiminv(i)
+    END IF
+  END DO
+
+
+  ! =======================================================
+  ! last upward integration
+  ! For all unstable layers, compute integral info and CTEI
+  ! =======================================================
+
+  ! 1/Recompute surface characteristics with the improved pblh
+  ! ----------------------------------------------------------
+  DO i = 1, knon
+    IF (unstbl(i)) THEN
+      diagok(i) = 1.
+      ! from missing_value to zero
+      cape(i) = 0.
+      cin(i) = 0.
+      eauliq(i) = 0.
+      ctei(i) = 0.
+      d_qt(i) = 0.
+      d_thv(i) = 0.
+      dlt_2(i) = 0.
+      xhis(i) = 0.
+      posint(i) = 0.
+      kin(i) = 0.
+      omega(i) = 0.
+
+      phiminv(i) = (1.-binm*pblh(i)/obklen(i))**onet
+      wm(i) = ustar(i)*phiminv(i)
+      q_star = max(0., kqfs(i)/wm(i))
+      t_star = max(0., khfs(i)/wm(i))
+      therm(i) = sqrt(b1*(1.+2.*retv*qt_th(i))*t_star**2+(retv*th_th(i))**2*b2*q_star*q_star+2.*retv*th_th(i)*b212* &
+        q_star*t_star)
+      ! Al1diag
+      ! trmb1(i) = b1*(1.+2.*RETV*qT_th(i))*t_star**2
+      ! trmb2(i) = (RETV*Th_th(i))**2*b2*q_star*q_star
+      ! trmb3(i) = 2.*RETV*Th_th(i)*b212*q_star*t_star
+
+      ! Th_th will now be the thermal-theta (including exces)
+      ! c         Th_th(i) = Th_th(i)+sqrt(b1)*max(0.,khfs(i)/wm(i))
+      th_th(i) = th_th(i) + therm(i)
+      ! al1diag
+      ! trmb2(i) = wm(i)
+      ! trmb3(i) = phiminv(i)
+      ! and computes Theta_e for thermal
+      the_th(i) = th_th(i) + rlvcp*qt_th(i)
+    END IF ! unstbl
+    ! Al1 compute a first guess of Plcl with the Bolton/Emanuel formula
+    t2 = th_th(i)
+    ! thermodyn functions
+    zdelta = max(0., sign(1.,rtt-t2))
+    qsat = r2es*foeew(t2, zdelta)/paprs(i, 1)
+    qsat = min(0.5, qsat)
+    zcor = 1./(1.-retv*qsat)
+    qsat = qsat*zcor
+    ! relative humidity of thermal at 2m
+    rh = qt_th(i)/qsat
+    chi = t2/(1669.0-122.0*rh-t2)
+    plcl(i) = paprs(i, 1)*(rh**chi)
+    ! al1diag
+    ! ctei(i) = Plcl(i)
+    ! cape(i) = T2
+    ! trmb1(i)= Chi
+    ! select unstable columns (=thermals)
+    check(i) = .FALSE.
+    IF (heatv(i)>0.) check(i) = .TRUE.
+    ! diag
+    ! dTv21(i,1) = T2*(1+RETV*qT_th(i))-t(i,1)*(1+RETV*q(i,1))
+  END DO
+  ! ----------------------------------
+  ! 2/ upward integration for thermals
+  ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ k loop
+  DO k = 2, isommet
+    DO i = 1, knon
+      IF (check(i) .OR. omegafl(i)) THEN
+        ! CC         if (pplay(i,k) .le. plcl(i)) then
+        zm(i) = z(i, k-1)
+        zp(i) = z(i, k)
+        ! Environnement : calcul de Tv1 a partir de t(:,:)== T liquide
+        ! ==============
+        tl1 = t(i, k)
+        t1 = tl1
+        zdelta = max(0., sign(1.,rtt-t1))
+        qsat = r2es*foeew(t1, zdelta)/pplay(i, k)
+        qsat = min(0.5, qsat)
+        zcor = 1./(1.-retv*qsat)
+        qsat = qsat*zcor
+        q1 = min(q(i,k), qsat)
+        ql1 = max(0., q(i,k)-q1)
+        ! thermodyn function (Tl2Tql)
+        dt = rlvcp*ql1
+        DO WHILE (abs(dt)>=dt0)
+          t1 = t1 + dt
+          zdelta = max(0., sign(1.,rtt-t1))
+          zcvm5 = r5les*(1.-zdelta) + r5ies*zdelta
+          qsat = r2es*foeew(t1, zdelta)/pplay(i, k)
+          qsat = min(0.5, qsat)
+          zcor = 1./(1.-retv*qsat)
+          qsat = qsat*zcor
+          dqsat_dt = foede(t1, zdelta, zcvm5, qsat, zcor)
+          ! correction lineaire pour conserver Tl env
+          ! << Tl = T1 + DT - RLvCp*(ql1 - dqsat/dT*DT >>
+          denom = 1. + rlvcp*dqsat_dt
+          q1 = min(q(i,k), qsat)
+          ql1 = q(i, k) - q1 ! can be negative
+          rnum = tl1 - t1 + rlvcp*ql1
+          dt = rnum/denom
+        END DO
+        ql1 = max(0., ql1)
+        tv1 = t1*(1.+retv*q1-ql1)
+        ! Thermique    : on atteint le seuil B/E de condensation
+        ! ==============
+
+        IF (.NOT. zsat(i)) THEN
+          ! first guess from The_th(i) = Th_th(i) + RLvCp* [qv=qT_th(i)]
+          t2 = s(i, k)*the_th(i) - rlvcp*qt_th(i)
+          zdelta = max(0., sign(1.,rtt-t2))
+          qsat = r2es*foeew(t2, zdelta)/pplay(i, k)
+          qsat = min(0.5, qsat)
+          zcor = 1./(1.-retv*qsat)
+          qsat = qsat*zcor
+          q2 = min(qt_th(i), qsat)
+          ql2 = max(0., qt_th(i)-q2)
+          IF (ql2>0.0001) zsat(i) = .TRUE.
+          tbef(i) = t2
+          ! a PBLH non sature
+          IF (zm(i)<pblh(i) .AND. zp(i)>=pblh(i)) THEN
+            reduc = (pblh(i)-zm(i))/(zp(i)-zm(i))
+            spblh = s(i, k-1) + reduc*(s(i,k)-s(i,k-1))
+            ! lmdz : qT1 et Thv1
+            t1 = (t(i,k-1)+reduc*(t(i,k)-t(i,k-1)))
+            thv1 = t1*(1.+retv*q(i,k))/spblh
+            ! on calcule pour le cas sans nuage un ctei en Delta Thv
+            thv2 = t2/spblh*(1.+retv*qt_th(i))
+            ctei(i) = thv1 - thv2
+            tv2 = t2*(1.+retv*q2-ql2)
+            ! diag
+            ! dTv21(i,k) = Tv2-Tv1
+            check(i) = .FALSE.
+            omegafl(i) = .TRUE.
+          END IF
+        END IF
+
+        IF (zsat(i)) THEN
+          ! thermodyn functions (Te2Tqsat)
+          t2 = tbef(i)
+          dt = 1.
+          te2 = s(i, k)*the_th(i)
+          DO WHILE (abs(dt)>=dt0)
+            zdelta = max(0., sign(1.,rtt-t2))
+            zcvm5 = r5les*(1.-zdelta) + r5ies*zdelta
+            qsat = r2es*foeew(t2, zdelta)/pplay(i, k)
+            qsat = min(0.5, qsat)
+            zcor = 1./(1.-retv*qsat)
+            qsat = qsat*zcor
+            dqsat_dt = foede(t2, zdelta, zcvm5, qsat, zcor)
+            ! correction lineaire pour conserver Te_th
+            ! << Te = T2 + DT + RLvCp*(qsatbef + dq/dT*DT >>
+            denom = 1. + rlvcp*dqsat_dt
+            rnum = te2 - t2 - rlvcp*qsat
+            dt = rnum/denom
+            t2 = t2 + dt
+          END DO
+          q2 = min(qt_th(i), qsat)
+          ql2 = max(0., qt_th(i)-q2)
+          ! jusqu'a PBLH y compris
+          IF (zm(i)<pblh(i)) THEN
+
+            ! mais a PBLH, interpolation et complements
+            IF (zp(i)>=pblh(i)) THEN
+              reduc = (pblh(i)-zm(i))/(zp(i)-zm(i))
+              spblh = s(i, k-1) + reduc*(s(i,k)-s(i,k-1))
+              ! CAPE et EauLiq a pblH
+              cape(i) = kape(i) + reduc*(zp(i)-zm(i))*rg*.5/(tv2+tv1)*max(0., (tv2-tv1))
+              eauliq(i) = eauliq(i) + reduc*(paprs(i,k-1)-paprs(i,k))*ql2/rg
+              ! CTEI
+              the2 = (t2+rlvcp*q2)/spblh
+              ! T1 est en realite la Tl env (on a donc strict The1)
+              t1 = (t(i,k-1)+reduc*(t(i,k)-t(i,k-1)))
+              the1 = (t1+rlvcp*q(i,k))/spblh
+              ! Calcul de la Cloud Top Entrainement Instability
+              ! cf Mathieu Lahellec QJRMS (2005) Comments to DYCOMS-II
+              ! saut a l'inversion :
+              delt_the = the1 - the2 ! negatif
+              delt_qt = q(i, k) - qt_th(i) ! negatif
+              d_qt(i) = -delt_qt
+              dlt_2(i) = .63*delt_the - the2*delt_qt
+              ! init ctei(i)
+              ctei(i) = dlt_2(i)
+              IF (dlt_2(i)<-0.1) THEN
+                ! integrale de Peter :
+                aa = delt_the - delt_qt*(rlvcp-retv*the2)
+                bb = (rlvcp-(1.+retv)*the2)*ql2
+                d_thv(i) = aa - bb
+                ! approx de Xhi_s et de l'integrale Xint=ctei(i)
+                xhis(i) = bb/(aa-dlt_2(i))
+                ! trmb1(i) = xhis
+                ! trmb3(i) = dlt_2
+                xnull = bb/aa
+                IF (xhis(i)>0.1) THEN
+                  ctei(i) = dlt_2(i)*xhis(i) + aa*(1.-xhis(i)) + bb*alog(xhis(i))
+                ELSE
+                  ctei(i) = .5*(dlt_2(i)+aa-bb)
+                END IF
+                IF (xnull>0.) THEN
+                  posint(i) = aa - bb + bb*alog(xnull)
+                ELSE
+                  posint(i) = 0.
+                END IF
+              ELSE
+                ctei(i) = 1.
+                posint(i) = 1.
+              END IF
+              check(i) = .FALSE.
+              omegafl(i) = .TRUE.
+            END IF ! end a pblh
+            IF (check(i)) eauliq(i) = eauliq(i) + (paprs(i,k)-paprs(i,k+1))*ql2/rg
+          END IF
+
+        END IF ! Zsat
+
+        ! KAPE : thermique / environnement
+        tv2 = t2*(1.+retv*q2-ql2)
+        ! diag
+        ! dTv21(i,k) = Tv2-Tv1
+        ! Kape courante
+        kape(i) = kape(i) + (zp(i)-zm(i))*rg*.5/(tv2+tv1)*max(0., (tv2-tv1))
+        ! Cin
+        IF (zcin(i) .AND. tv2-tv1>0.) THEN
+          zcin(i) = .FALSE.
+          cin(i) = kin(i)
+        END IF
+        IF (.NOT. zcin(i) .AND. tv2-tv1<0.) THEN
+          zcin(i) = .TRUE.
+          kin(i) = kin(i) + (zp(i)-zm(i))*rg*.5/(tv2+tv1)*min(0., (tv2-tv1))
+        END IF
+        IF (kape(i)+kin(i)<0.) THEN
+          omega(i) = zm(i)
+          ! trmb3(i) = paprs(i,k)
+          omegafl(i) = .FALSE.
+          ! diag
+          ! print*,'Tv2-Tv1 (k): ',i,(dTv21(i,j),j=1,k)
+        END IF
+        ! CC         EndIf !plcl
+      END IF ! check(i)
+    END DO
+  END DO ! end of level loop
+  ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ end k loop
+  RETURN
+END SUBROUTINE hbtm2l
Index: DZ6/trunk/libf/phylmd/hbtm_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/hbtm_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,769 +1,0 @@
-module hbtm_mod
-
-  IMPLICIT NONE
-
-contains
-
-  SUBROUTINE hbtm(knon, paprs, pplay, t2m, t10m, q2m, q10m, ustar, wstar, &
-       flux_t, flux_q, u, v, t, q, pblh, cape, eauliq, ctei, pblt, therm, &
-       trmb1, trmb2, trmb3, plcl)
-    USE dimphy
-
-    ! ***************************************************************
-    ! *                                                             *
-    ! * HBTM2   D'apres Holstag&Boville et Troen&Mahrt              *
-    ! *                 JAS 47              BLM                     *
-    ! * Algorithme These Anne Mathieu                               *
-    ! * Critere d'Entrainement Peter Duynkerke (JAS 50)             *
-    ! * written by  : Anne MATHIEU & Alain LAHELLEC, 22/11/99       *
-    ! * features : implem. exces Mathieu                            *
-    ! ***************************************************************
-    ! * mods : decembre 99 passage th a niveau plus bas. voir fixer *
-    ! * la prise du th a z/Lambda = -.2 (max Ray)                   *
-    ! * Autre algo : entrainement ~ Theta+v =cste mais comment=>The?*
-    ! * on peut fixer q a .7qsat(cf non adiab)=>T2 et The2          *
-    ! * voir aussi //KE pblh = niveau The_e ou l = env.             *
-    ! ***************************************************************
-    ! * fin therm a la HBTM passage a forme Mathieu 12/09/2001      *
-    ! ***************************************************************
-    ! *
-
-
-    ! AM Fev 2003
-    ! Adaptation a LMDZ version couplee
-
-    ! Pour le moment on fait passer en argument les grdeurs de surface :
-    ! flux, t,q2m, t,q10m, on va utiliser systematiquement les grdeurs a 2m ms
-    ! on garde la possibilite de changer si besoin est (jusqu'a present la
-    ! forme de HB avec le 1er niveau modele etait conservee)
-
-
-
-
-
-    include "YOMCST.h"
-    REAL rlvcp, reps
-    ! Arguments:
-
-    INTEGER knon ! nombre de points a calculer
-    ! AM
-    REAL t2m(klon), t10m(klon) ! temperature a 2 et 10m
-    REAL q2m(klon), q10m(klon) ! q a 2 et 10m
-    REAL ustar(klon)
-    REAL wstar(klon) ! w*, convective velocity scale
-    REAL paprs(klon, klev+1) ! pression a inter-couche (Pa)
-    REAL pplay(klon, klev) ! pression au milieu de couche (Pa)
-    REAL flux_t(klon, klev), flux_q(klon, klev) ! Flux
-    REAL u(klon, klev) ! vitesse U (m/s)
-    REAL v(klon, klev) ! vitesse V (m/s)
-    REAL t(klon, klev) ! temperature (K)
-    REAL q(klon, klev) ! vapeur d'eau (kg/kg)
-    ! AM      REAL cd_h(klon) ! coefficient de friction au sol pour chaleur
-    ! AM      REAL cd_m(klon) ! coefficient de friction au sol pour vitesse
-
-    INTEGER isommet
-    ! um      PARAMETER (isommet=klev) ! limite max sommet pbl
-    REAL, PARAMETER :: vk = 0.35 ! Von Karman => passer a .41 ! cf U.Olgstrom
-    REAL, PARAMETER :: ricr = 0.4
-    REAL, PARAMETER :: fak = 8.5 ! b calcul du Prandtl et de dTetas
-    REAL, PARAMETER :: fakn = 7.2 ! a
-    REAL, PARAMETER :: onet = 1.0/3.0
-    REAL, PARAMETER :: t_coup = 273.15
-    REAL, PARAMETER :: zkmin = 0.01
-    REAL, PARAMETER :: betam = 15.0 ! pour Phim / h dans la S.L stable
-    REAL, PARAMETER :: betah = 15.0
-
-    REAL, PARAMETER :: betas = 5.0
-    ! Phit dans la S.L. stable (mais 2 formes / z/OBL<>1
-
-    REAL, PARAMETER :: sffrac = 0.1 ! S.L. = z/h < .1
-    REAL, PARAMETER :: usmin = 1.E-12
-    REAL, PARAMETER :: binm = betam*sffrac
-    REAL, PARAMETER :: binh = betah*sffrac
-    REAL, PARAMETER :: ccon = fak*sffrac*vk
-    REAL, PARAMETER :: b1 = 70., b2 = 20.
-    REAL, PARAMETER :: zref = 2. ! Niveau de ref a 2m peut eventuellement
-    ! etre choisi a 10m
-    REAL q_star, t_star
-    REAL b212, b2sr ! Lambert correlations T' q' avec T* q*
-
-    REAL z(klon, klev)
-    ! AM      REAL pcfm(klon,klev), pcfh(klon,klev)
-    INTEGER i, k, j
-    REAL zxt
-    ! AM      REAL zxt, zxq, zxu, zxv, zxmod, taux, tauy
-    ! AM      REAL zx_alf1, zx_alf2 ! parametres pour extrapolation
-    REAL khfs(klon) ! surface kinematic heat flux [mK/s]
-    REAL kqfs(klon) ! sfc kinematic constituent flux [m/s]
-    REAL heatv(klon) ! surface virtual heat flux
-    REAL rhino(klon, klev) ! bulk Richardon no. mais en Theta_v
-    LOGICAL unstbl(klon) ! pts w/unstbl pbl (positive virtual ht flx)
-    LOGICAL stblev(klon) ! stable pbl with levels within pbl
-    LOGICAL unslev(klon) ! unstbl pbl with levels within pbl
-    LOGICAL unssrf(klon) ! unstb pbl w/lvls within srf pbl lyr
-    LOGICAL unsout(klon) ! unstb pbl w/lvls in outer pbl lyr
-    LOGICAL check(klon) ! True=>chk if Richardson no.>critcal
-    LOGICAL omegafl(klon) ! flag de prolongerment cape pour pt Omega
-    REAL pblh(klon)
-    REAL pblt(klon)
-    REAL plcl(klon)
-    ! AM      REAL cgh(klon,2:klev) ! counter-gradient term for heat [K/m]
-    ! AM      REAL cgq(klon,2:klev) ! counter-gradient term for constituents
-    ! AM      REAL cgs(klon,2:klev) ! counter-gradient star (cg/flux)
-    REAL unsobklen(klon) ! Monin-Obukhov lengh
-    ! AM      REAL ztvd, ztvu,
-    REAL zdu2
-    REAL, intent(out):: therm(:) ! (klon) thermal virtual temperature excess
-    REAL trmb1(klon), trmb2(klon), trmb3(klon)
-    ! Algorithme thermique
-    REAL s(klon, klev) ! [P/Po]^Kappa milieux couches
-    REAL th_th(klon) ! potential temperature of thermal
-    REAL the_th(klon) ! equivalent potential temperature of thermal
-    REAL qt_th(klon) ! total water  of thermal
-    REAL tbef(klon) ! T thermique niveau precedent
-    REAL qsatbef(klon)
-    LOGICAL zsat(klon) ! le thermique est sature
-    REAL cape(klon) ! Cape du thermique
-    REAL kape(klon) ! Cape locale
-    REAL eauliq(klon) ! Eau liqu integr du thermique
-    REAL ctei(klon) ! Critere d'instab d'entrainmt des nuages de CL
-    REAL the1, the2, aa, bb, zthvd, zthvu, xintpos, qqsat
-    ! IM 091204 BEG
-    REAL a1, a2, a3
-    ! IM 091204 END
-    REAL xhis, rnum, denom, th1, th2, thv1, thv2, ql2
-    REAL dqsat_dt, qsat2, qt1, q2, t1, t2, xnull, delt_the
-    REAL delt_qt, delt_2, quadsat, spblh, reduc
-
-    REAL phiminv(klon) ! inverse phi function for momentum
-    REAL phihinv(klon) ! inverse phi function for heat
-    REAL wm(klon) ! turbulent velocity scale for momentum
-    REAL fak1(klon) ! k*ustar*pblh
-    REAL fak2(klon) ! k*wm*pblh
-    REAL fak3(klon) ! fakn*wstar/wm
-    REAL pblk(klon) ! level eddy diffusivity for momentum
-    REAL pr(klon) ! Prandtl number for eddy diffusivities
-    REAL zl(klon) ! zmzp / Obukhov length
-    REAL zh(klon) ! zmzp / pblh
-    REAL zzh(klon) ! (1-(zmzp/pblh))**2
-    REAL zm(klon) ! current level height
-    REAL zp(klon) ! current level height + one level up
-    REAL zcor, zdelta, zcvm5
-    ! AM      REAL zxqs
-    REAL fac, pblmin, zmzp, term
-
-    include "YOETHF.h"
-    include "FCTTRE.h"
-
-
-
-    ! initialisations (Anne)
-    isommet = klev
-    th_th(:) = 0.
-    q_star = 0
-    t_star = 0
-    therm = 0.
-
-    b212 = sqrt(b1*b2)
-    b2sr = sqrt(b2)
-
-    ! ============================================================
-    ! Fonctions thermo implicites
-    ! ============================================================
-    ! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-    ! Tetens : pression partielle de vap d'eau e_sat(T)
-    ! =================================================
-    ! ++ e_sat(T) = r2*exp( r3*(T-Tf)/(T-r4) ) id a r2*FOEWE
-    ! ++ avec :
-    ! ++ Tf = 273.16 K  (Temp de fusion de la glace)
-    ! ++ r2 = 611.14 Pa
-    ! ++ r3 = 17.269 (liquide) 21.875 (solide) adim
-    ! ++ r4 = 35.86             7.66           Kelvin
-    ! ++  q_sat = eps*e_sat/(p-(1-eps)*e_sat)
-    ! ++ deriv� :
-    ! ++ =========
-    ! ++                   r3*(Tf-r4)*q_sat(T,p)
-    ! ++ d_qsat_dT = --------------------------------
-    ! ++             (T-r4)^2*( 1-(1-eps)*e_sat(T)/p )
-    ! ++ pour zcvm5=Lv, c'est FOEDE
-    ! ++ Rq :(1.-REPS)*esarg/Parg id a RETV*Qsat
-    ! ------------------------------------------------------------------
-
-    ! Initialisation
-    rlvcp = rlvtt/rcpd
-    reps = rd/rv
-
-
-    ! DO i = 1, klon
-    ! pcfh(i,1) = cd_h(i)
-    ! pcfm(i,1) = cd_m(i)
-    ! ENDDO
-    ! DO k = 2, klev
-    ! DO i = 1, klon
-    ! pcfh(i,k) = zkmin
-    ! pcfm(i,k) = zkmin
-    ! cgs(i,k) = 0.0
-    ! cgh(i,k) = 0.0
-    ! cgq(i,k) = 0.0
-    ! ENDDO
-    ! ENDDO
-
-    ! Calculer les hauteurs de chaque couche
-    ! (geopotentielle Int_dp/ro = Int_[Rd.T.dp/p] z = geop/g)
-    ! pourquoi ne pas utiliser Phi/RG ?
-    DO i = 1, knon
-       z(i, 1) = rd*t(i, 1)/(0.5*(paprs(i,1)+pplay(i,1)))&
-            *(paprs(i,1)-pplay(i,1))/rg
-       s(i, 1) = (pplay(i,1)/paprs(i,1))**rkappa
-    END DO
-    ! s(k) = [pplay(k)/ps]^kappa
-    ! + + + + + + + + + pplay  <-> s(k)   t  dp=pplay(k-1)-pplay(k)
-
-    ! -----------------  paprs <-> sig(k)
-
-    ! + + + + + + + + + pplay  <-> s(k-1)
-
-
-    ! + + + + + + + + + pplay  <-> s(1)   t  dp=paprs-pplay   z(1)
-
-    ! -----------------  paprs <-> sig(1)
-
-    DO k = 2, klev
-       DO i = 1, knon
-          z(i, k) = z(i, k-1) + rd*0.5*(t(i,k-1)+t(i,k))/paprs(i, k)&
-               *(pplay(i,k-1)-pplay(i,k))/rg
-          s(i, k) = (pplay(i,k)/paprs(i,1))**rkappa
-       END DO
-    END DO
-    ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-    ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-    ! +++  Determination des grandeurs de surface  +++++++++++++++++++++
-    ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-    ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-    DO i = 1, knon
-       ! AM         IF (thermcep) THEN
-       ! AM           zdelta=MAX(0.,SIGN(1.,RTT-tsol(i)))
-       ! zcvm5 = R5LES*RLVTT*(1.-zdelta) + R5IES*RLSTT*zdelta
-       ! zcvm5 = zcvm5 / RCPD / (1.0+RVTMP2*q(i,1))
-       ! AM           zxqs= r2es * FOEEW(tsol(i),zdelta)/paprs(i,1)
-       ! AM           zxqs=MIN(0.5,zxqs)
-       ! AM           zcor=1./(1.-retv*zxqs)
-       ! AM           zxqs=zxqs*zcor
-       ! AM         ELSE
-       ! AM           IF (tsol(i).LT.t_coup) THEN
-       ! AM              zxqs = qsats(tsol(i)) / paprs(i,1)
-       ! AM           ELSE
-       ! AM              zxqs = qsatl(tsol(i)) / paprs(i,1)
-       ! AM           ENDIF
-       ! AM         ENDIF
-       ! niveau de reference bulk; mais ici, c,a pourrait etre le niveau de ref
-       ! du thermique
-       ! AM        zx_alf1 = 1.0
-       ! AM        zx_alf2 = 1.0 - zx_alf1
-       ! AM        zxt = (t(i,1)+z(i,1)*RG/RCPD/(1.+RVTMP2*q(i,1)))
-       ! AM     .        *(1.+RETV*q(i,1))*zx_alf1
-       ! AM     .      + (t(i,2)+z(i,2)*RG/RCPD/(1.+RVTMP2*q(i,2)))
-       ! AM     .        *(1.+RETV*q(i,2))*zx_alf2
-       ! AM        zxu = u(i,1)*zx_alf1+u(i,2)*zx_alf2
-       ! AM        zxv = v(i,1)*zx_alf1+v(i,2)*zx_alf2
-       ! AM        zxq = q(i,1)*zx_alf1+q(i,2)*zx_alf2
-       ! AM
-       ! AMAM           zxu = u10m(i)
-       ! AMAM           zxv = v10m(i)
-       ! AMAM           zxmod = 1.0+SQRT(zxu**2+zxv**2)
-       ! AM Niveau de ref choisi a 2m
-       zxt = t2m(i)
-
-       ! ***************************************************
-       ! attention, il doit s'agir de <w'theta'>
-       ! ;Calcul de tcls virtuel et de w'theta'virtuel
-       ! ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-       ! tcls=tcls*(1+.608*qcls)
-
-       ! ;Pour avoir w'theta',
-       ! ; il faut diviser par ro.Cp
-       ! Cp=Cpd*(1+0.84*qcls)
-       ! fcs=fcs/(ro_surf*Cp)
-       ! ;On transforme w'theta' en w'thetav'
-       ! Lv=(2.501-0.00237*(tcls-273.15))*1.E6
-       ! xle=xle/(ro_surf*Lv)
-       ! fcsv=fcs+.608*xle*tcls
-       ! ***************************************************
-       ! AM        khfs(i) = (tsol(i)*(1.+RETV*q(i,1))-zxt) *zxmod*cd_h(i)
-       ! AM        kqfs(i) = (zxqs-zxq) *zxmod*cd_h(i) * beta(i)
-       ! AM
-       ! dif khfs est deja w't'_v / heatv(i) = khfs(i) + RETV*zxt*kqfs(i)
-       ! AM calcule de Ro = paprs(i,1)/Rd zxt
-       ! AM convention >0 vers le bas ds lmdz
-       khfs(i) = -flux_t(i, 1)*zxt*rd/(rcpd*paprs(i,1))
-       kqfs(i) = -flux_q(i, 1)*zxt*rd/(paprs(i,1))
-       ! AM   verifier que khfs et kqfs sont bien de la forme w'l'
-       heatv(i) = khfs(i) + 0.608*zxt*kqfs(i)
-       ! a comparer aussi aux sorties de clqh : flux_T/RoCp et flux_q/RoLv
-       ! AM        heatv(i) = khfs(i)
-       ! AM ustar est en entree
-       ! AM        taux = zxu *zxmod*cd_m(i)
-       ! AM        tauy = zxv *zxmod*cd_m(i)
-       ! AM        ustar(i) = SQRT(taux**2+tauy**2)
-       ! AM        ustar(i) = MAX(SQRT(ustar(i)),0.01)
-       ! Theta et qT du thermique sans exces (interpolin vers surf)
-       ! chgt de niveau du thermique (jeudi 30/12/1999)
-       ! (interpolation lineaire avant integration phi_h)
-       ! AM        qT_th(i) = zxqs*beta(i) + 4./z(i,1)*(q(i,1)-zxqs*beta(i))
-       ! AM        qT_th(i) = max(qT_th(i),q(i,1))
-       qt_th(i) = q2m(i)
-       ! n The_th restera la Theta du thermique sans exces jusqu'a 2eme calcul
-       ! n reste a regler convention P) pour Theta
-       ! The_th(i) = tsol(i) + 4./z(i,1)*(t(i,1)-tsol(i))
-       ! -                      + RLvCp*qT_th(i)
-       ! AM        Th_th(i) = tsol(i) + 4./z(i,1)*(t(i,1)-tsol(i))
-       th_th(i) = t2m(i)
-    END DO
-
-    DO i = 1, knon
-       rhino(i, 1) = 0.0 ! Global Richardson
-       check(i) = .TRUE.
-       pblh(i) = z(i, 1) ! on initialise pblh a l'altitude du 1er niveau
-       plcl(i) = 6000.
-       ! Lambda = -u*^3 / (alpha.g.kvon.<w'Theta'v>
-       unsobklen(i) = -rg*vk*heatv(i)/(t(i,1)*max(ustar(i),usmin)**3)
-       trmb1(i) = 0.
-       trmb2(i) = 0.
-       trmb3(i) = 0.
-    END DO
-
-
-    ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-    ! PBL height calculation:
-    ! Search for level of pbl. Scan upward until the Richardson number between
-    ! the first level and the current level exceeds the "critical" value.
-    ! (bonne idee Nu de separer le Ric et l'exces de temp du thermique)
-    ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-    fac = 100.0
-    DO k = 2, isommet
-       DO i = 1, knon
-          IF (check(i)) THEN
-             ! pourquoi / niveau 1 (au lieu du sol) et le terme en u*^2 ?
-             ! test     zdu2 =
-             ! (u(i,k)-u(i,1))**2+(v(i,k)-v(i,1))**2+fac*ustar(i)**2
-             zdu2 = u(i, k)**2 + v(i, k)**2
-             zdu2 = max(zdu2, 1.0E-20)
-             ! Theta_v environnement
-             zthvd = t(i, k)/s(i, k)*(1.+retv*q(i,k))
-
-             ! therm Theta_v sans exces (avec hypothese fausse de H&B, sinon,
-             ! passer par Theta_e et virpot)
-             ! zthvu=t(i,1)/s(i,1)*(1.+RETV*q(i,1))
-             ! AM         zthvu = Th_th(i)*(1.+RETV*q(i,1))
-             zthvu = th_th(i)*(1.+retv*qt_th(i))
-             ! Le Ri par Theta_v
-             ! AM         rhino(i,k) = (z(i,k)-z(i,1))*RG*(zthvd-zthvu)
-             ! AM     .               /(zdu2*0.5*(zthvd+zthvu))
-             ! AM On a nveau de ref a 2m ???
-             rhino(i, k) = (z(i,k)-zref)*rg*(zthvd-zthvu)/(zdu2*0.5&
-                  *(zthvd+zthvu))
-
-             IF (rhino(i,k)>=ricr) THEN
-                pblh(i) = z(i, k-1) + (z(i,k-1)-z(i,k))*(ricr-rhino(i,k-1))&
-                     /(rhino(i,k-1)-rhino(i,k))
-                ! test04
-                pblh(i) = pblh(i) + 100.
-                pblt(i) = t(i, k-1) + (t(i,k)-t(i,k-1))*(pblh(i)-z(i,k-1))&
-                     /(z(i,k)- z(i,k-1))
-                check(i) = .FALSE.
-             END IF
-          END IF
-       END DO
-    END DO
-
-
-    ! Set pbl height to maximum value where computation exceeds number of
-    ! layers allowed
-
-    DO i = 1, knon
-       IF (check(i)) pblh(i) = z(i, isommet)
-    END DO
-
-    ! Improve estimate of pbl height for the unstable points.
-    ! Find unstable points (sensible heat flux is upward):
-
-    DO i = 1, knon
-       IF (heatv(i)>0.) THEN
-          unstbl(i) = .TRUE.
-          check(i) = .TRUE.
-       ELSE
-          unstbl(i) = .FALSE.
-          check(i) = .FALSE.
-       END IF
-    END DO
-
-    ! For the unstable case, compute velocity scale and the
-    ! convective temperature excess:
-
-    DO i = 1, knon
-       IF (check(i)) THEN
-          phiminv(i) = (1.-binm*pblh(i)*unsobklen(i))**onet
-          ! ***************************************************
-          ! Wm ? et W* ? c'est la formule pour z/h < .1
-          ! ;Calcul de w* ;;
-          ! ;;;;;;;;;;;;;;;;
-          ! w_star=((g/tcls)*fcsv*z(ind))^(1/3.) [ou prendre la premiere approx
-          ! de h)
-          ! ;; CALCUL DE wm ;;
-          ! ;;;;;;;;;;;;;;;;;;
-          ! ; Ici on considerera que l'on est dans la couche de surf jusqu'a
-          ! 100 m
-          ! ; On prend svt couche de surface=0.1*h mais on ne connait pas h
-          ! ;;;;;;;;;;;Dans la couche de surface
-          ! if (z(ind) le 20) then begin
-          ! Phim=(1.-15.*(z(ind)/L))^(-1/3.)
-          ! wm=u_star/Phim
-          ! ;;;;;;;;;;;En dehors de la couche de surface
-          ! endif else if (z(ind) gt 20) then begin
-          ! wm=(u_star^3+c1*w_star^3)^(1/3.)
-          ! endif
-          ! ***************************************************
-          wm(i) = ustar(i)*phiminv(i)
-          ! ===================================================================
-          ! valeurs de Dominique Lambert de la campagne SEMAPHORE :
-          ! <T'^2> = 100.T*^2; <q'^2> = 20.q*^2 a 10m
-          ! <Tv'^2> = (1+1.2q).100.T* + 1.2Tv.sqrt(20*100).T*.q* +
-          ! (.608*Tv)^2*20.q*^2;
-          ! et dTetavS = sqrt(<Tv'^2>) ainsi calculee.
-          ! avec : T*=<w'T'>_s/w* et q*=<w'q'>/w*
-          ! !!! on peut donc utiliser w* pour les fluctuations <-> Lambert
-          ! (leur corellation pourrait dependre de beta par ex)
-          ! if fcsv(i,j) gt 0 then begin
-          ! dTetavs=b1*(1.+2.*.608*q_10(i,j))*(fcs(i,j)/wm(i,j))^2+$
-          ! (.608*Thetav_10(i,j))^2*b2*(xle(i,j)/wm(i,j))^2+$
-          ! 2.*.608*thetav_10(i,j)*sqrt(b1*b2)*(xle(i,j)/wm(i,j))*(fcs(i,j)
-          ! /wm(i,j))
-          ! dqs=b2*(xle(i,j)/wm(i,j))^2
-          ! theta_s(i,j)=thetav_10(i,j)+sqrt(dTetavs)
-          ! q_s(i,j)=q_10(i,j)+sqrt(dqs)
-          ! endif else begin
-          ! Theta_s(i,j)=thetav_10(i,j)
-          ! q_s(i,j)=q_10(i,j)
-          ! endelse
-          ! ===================================================================
-
-          ! HBTM        therm(i) = heatv(i)*fak/wm(i)
-          ! forme Mathieu :
-          q_star = kqfs(i)/wm(i)
-          t_star = khfs(i)/wm(i)
-          ! IM 091204 BEG
-          IF (1==0) THEN
-             IF (t_star<0. .OR. q_star<0.) THEN
-                PRINT *, 'i t_star q_star khfs kqfs wm', i, t_star, q_star, &
-                     khfs(i), kqfs(i), wm(i)
-             END IF
-          END IF
-          ! IM 091204 END
-          ! AM Nveau cde ref 2m =>
-          ! AM        therm(i) = sqrt( b1*(1.+2.*RETV*q(i,1))*t_star**2
-          ! AM     +             + (RETV*T(i,1))**2*b2*q_star**2
-          ! AM     +             + 2.*RETV*T(i,1)*b212*q_star*t_star
-          ! AM     +                 )
-          ! IM 091204 BEG
-          a1 = b1*(1.+2.*retv*qt_th(i))*t_star**2
-          a2 = (retv*th_th(i))**2*b2*q_star*q_star
-          a3 = 2.*retv*th_th(i)*b212*q_star*t_star
-          aa = a1 + a2 + a3
-          IF (1==0) THEN
-             IF (aa<0.) THEN
-                PRINT *, 'i a1 a2 a3 aa', i, a1, a2, a3, aa
-                PRINT *, 'i qT_th Th_th t_star q_star RETV b1 b2 b212', i, &
-                     qt_th(i), th_th(i), t_star, q_star, retv, b1, b2, b212
-             END IF
-          END IF
-          ! IM 091204 END
-          therm(i) = sqrt(b1*(1.+2.*retv*qt_th(i))*t_star**2+(retv*th_th( &
-               i))**2*b2*q_star*q_star &  ! IM 101204  +             +
-                                ! 2.*RETV*Th_th(i)*b212*q_star*t_star
-               +max(0.,2.*retv*th_th(i)*b212*q_star*t_star))
-
-          ! Theta et qT du thermique (forme H&B) avec exces
-          ! (attention, on ajoute therm(i) qui est virtuelle ...)
-          ! pourquoi pas sqrt(b1)*t_star ?
-          ! dqs = b2sr*kqfs(i)/wm(i)
-          qt_th(i) = qt_th(i) + b2sr*q_star
-          ! new on differre le calcul de Theta_e
-          ! The_th(i) = The_th(i) + therm(i) + RLvCp*qT_th(i)
-          ! ou:    The_th(i) = The_th(i) + sqrt(b1)*khfs(i)/wm(i) +
-          ! RLvCp*qT_th(i)
-          rhino(i, 1) = 0.0
-       END IF
-    END DO
-
-    ! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-    ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-    ! ++ Improve pblh estimate for unstable conditions using the +++++++
-    ! ++          convective temperature excess :                +++++++
-    ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-    ! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-
-    DO k = 2, isommet
-       DO i = 1, knon
-          IF (check(i)) THEN
-             ! test     zdu2 =
-             ! (u(i,k)-u(i,1))**2+(v(i,k)-v(i,1))**2+fac*ustar(i)**2
-             zdu2 = u(i, k)**2 + v(i, k)**2
-             zdu2 = max(zdu2, 1.0E-20)
-             ! Theta_v environnement
-             zthvd = t(i, k)/s(i, k)*(1.+retv*q(i,k))
-
-             ! et therm Theta_v (avec hypothese de constance de H&B,
-             ! zthvu=(t(i,1)+therm(i))/s(i,1)*(1.+RETV*q(i,1))
-             zthvu = th_th(i)*(1.+retv*qt_th(i)) + therm(i)
-
-
-             ! Le Ri par Theta_v
-             ! AM Niveau de ref 2m
-             ! AM         rhino(i,k) = (z(i,k)-z(i,1))*RG*(zthvd-zthvu)
-             ! AM     .               /(zdu2*0.5*(zthvd+zthvu))
-             rhino(i, k) = (z(i,k)-zref)*rg*(zthvd-zthvu)/(zdu2*0.5&
-                  *(zthvd+zthvu))
-
-
-             IF (rhino(i,k)>=ricr) THEN
-                pblh(i) = z(i, k-1) + (z(i,k-1)-z(i,k))*(ricr-rhino(i,k-1))&
-                     /(rhino(i,k-1)-rhino(i,k))
-                ! test04
-                pblh(i) = pblh(i) + 100.
-                pblt(i) = t(i, k-1) + (t(i,k)-t(i,k-1))*(pblh(i)-z(i,k-1))&
-                     /(z(i,k)- z(i,k-1))
-                check(i) = .FALSE.
-                ! IM 170305 BEG
-                IF (1==0) THEN
-                   ! debug print -120;34       -34-        58 et    0;26 wamp
-                   IF (i==950 .OR. i==192 .OR. i==624 .OR. i==118) THEN
-                      PRINT *, ' i,Th_th,Therm,qT :', i, th_th(i), therm(i), &
-                           qt_th(i)
-                      q_star = kqfs(i)/wm(i)
-                      t_star = khfs(i)/wm(i)
-                      PRINT *, 'q* t*, b1,b2,b212 ', q_star, t_star, &
-                           b1*(1.+2.*retv*qt_th(i))*t_star**2, &
-                           (retv*th_th(i))**2*b2*q_star**2, 2.*retv*th_th(i)&
-                           *b212*q_star *t_star
-                      PRINT *, 'zdu2 ,100.*ustar(i)**2', zdu2, fac*ustar(i)**2
-                   END IF
-                END IF !(1.EQ.0) THEN
-                ! IM 170305 END
-                ! q_star = kqfs(i)/wm(i)
-                ! t_star = khfs(i)/wm(i)
-                ! trmb1(i) = b1*(1.+2.*RETV*q(i,1))*t_star**2
-                ! trmb2(i) = (RETV*T(i,1))**2*b2*q_star**2
-                ! Omega now   trmb3(i) = 2.*RETV*T(i,1)*b212*q_star*t_star
-             END IF
-          END IF
-       END DO
-    END DO
-
-    ! Set pbl height to maximum value where computation exceeds number of
-    ! layers allowed
-
-    DO i = 1, knon
-       IF (check(i)) pblh(i) = z(i, isommet)
-    END DO
-
-    ! PBL height must be greater than some minimum mechanical mixing depth
-    ! Several investigators have proposed minimum mechanical mixing depth
-    ! relationships as a function of the local friction velocity, u*.  We
-    ! make use of a linear relationship of the form h = c u* where c=700.
-    ! The scaling arguments that give rise to this relationship most often
-    ! represent the coefficient c as some constant over the local coriolis
-    ! parameter.  Here we make use of the experimental results of Koracin
-    ! and Berkowicz (1988) [BLM, Vol 43] for wich they recommend 0.07/f
-    ! where f was evaluated at 39.5 N and 52 N.  Thus we use a typical mid
-    ! latitude value for f so that c = 0.07/f = 700.
-
-    DO i = 1, knon
-       pblmin = 700.0*ustar(i)
-       pblh(i) = max(pblh(i), pblmin)
-       ! par exemple :
-       pblt(i) = t(i, 2) + (t(i,3)-t(i,2))*(pblh(i)-z(i,2))/(z(i,3)-z(i,2))
-    END DO
-
-    ! ********************************************************************
-    ! pblh is now available; do preparation for diffusivity calculation :
-    ! ********************************************************************
-    DO i = 1, knon
-       check(i) = .TRUE.
-       zsat(i) = .FALSE.
-       ! omegafl utilise pour prolongement CAPE
-       omegafl(i) = .FALSE.
-       cape(i) = 0.
-       kape(i) = 0.
-       eauliq(i) = 0.
-       ctei(i) = 0.
-       pblk(i) = 0.0
-       fak1(i) = ustar(i)*pblh(i)*vk
-
-       ! Do additional preparation for unstable cases only, set temperature
-       ! and moisture perturbations depending on stability.
-       ! *** Rq: les formule sont prises dans leur forme CS ***
-       IF (unstbl(i)) THEN
-          ! AM Niveau de ref du thermique
-          ! AM          zxt=(t(i,1)-z(i,1)*0.5*RG/RCPD/(1.+RVTMP2*q(i,1)))
-          ! AM     .         *(1.+RETV*q(i,1))
-          zxt = (th_th(i)-zref*0.5*rg/rcpd/(1.+rvtmp2*qt_th(i)))* &
-               (1.+retv*qt_th(i))
-          phiminv(i) = (1.-binm*pblh(i)*unsobklen(i))**onet
-          phihinv(i) = sqrt(1.-binh*pblh(i)*unsobklen(i))
-          wm(i) = ustar(i)*phiminv(i)
-          fak2(i) = wm(i)*pblh(i)*vk
-          wstar(i) = (heatv(i)*rg*pblh(i)/zxt)**onet
-          fak3(i) = fakn*wstar(i)/wm(i)
-       ELSE
-          wstar(i) = 0.
-       END IF
-       ! Computes Theta_e for thermal (all cases : to be modified)
-       ! attention ajout therm(i) = virtuelle
-       the_th(i) = th_th(i) + therm(i) + rlvcp*qt_th(i)
-       ! ou:    The_th(i) = Th_th(i) + sqrt(b1)*khfs(i)/wm(i) + RLvCp*qT_th(i)
-    END DO
-
-    ! Main level loop to compute the diffusivities and
-    ! counter-gradient terms:
-
-    DO k = 2, isommet
-
-       ! Find levels within boundary layer:
-
-       DO i = 1, knon
-          unslev(i) = .FALSE.
-          stblev(i) = .FALSE.
-          zm(i) = z(i, k-1)
-          zp(i) = z(i, k)
-          IF (zkmin==0.0 .AND. zp(i)>pblh(i)) zp(i) = pblh(i)
-          IF (zm(i)<pblh(i)) THEN
-             zmzp = 0.5*(zm(i)+zp(i))
-             ! debug
-             ! if (i.EQ.1864) then
-             ! print*,'i,pblh(1864),obklen(1864)',i,pblh(i),obklen(i)
-             ! endif
-
-             zh(i) = zmzp/pblh(i)
-             zl(i) = zmzp*unsobklen(i)
-             zzh(i) = 0.
-             IF (zh(i)<=1.0) zzh(i) = (1.-zh(i))**2
-
-             ! stblev for points zm < plbh and stable and neutral
-             ! unslev for points zm < plbh and unstable
-
-             IF (unstbl(i)) THEN
-                unslev(i) = .TRUE.
-             ELSE
-                stblev(i) = .TRUE.
-             END IF
-          END IF
-       END DO
-       ! print*,'fin calcul niveaux'
-
-       ! Stable and neutral points; set diffusivities; counter-gradient
-       ! terms zero for stable case:
-
-       DO i = 1, knon
-          IF (stblev(i)) THEN
-             IF (zl(i)<=1.) THEN
-                pblk(i) = fak1(i)*zh(i)*zzh(i)/(1.+betas*zl(i))
-             ELSE
-                pblk(i) = fak1(i)*zh(i)*zzh(i)/(betas+zl(i))
-             END IF
-             ! pcfm(i,k) = pblk(i)
-             ! pcfh(i,k) = pcfm(i,k)
-          END IF
-       END DO
-
-       ! unssrf, unstable within surface layer of pbl
-       ! unsout, unstable within outer   layer of pbl
-
-       DO i = 1, knon
-          unssrf(i) = .FALSE.
-          unsout(i) = .FALSE.
-          IF (unslev(i)) THEN
-             IF (zh(i)<sffrac) THEN
-                unssrf(i) = .TRUE.
-             ELSE
-                unsout(i) = .TRUE.
-             END IF
-          END IF
-       END DO
-
-       ! Unstable for surface layer; counter-gradient terms zero
-
-       DO i = 1, knon
-          IF (unssrf(i)) THEN
-             term = (1.-betam*zl(i))**onet
-             pblk(i) = fak1(i)*zh(i)*zzh(i)*term
-             pr(i) = term/sqrt(1.-betah*zl(i))
-          END IF
-       END DO
-       ! print*,'fin counter-gradient terms zero'
-
-       ! Unstable for outer layer; counter-gradient terms non-zero:
-
-       DO i = 1, knon
-          IF (unsout(i)) THEN
-             pblk(i) = fak2(i)*zh(i)*zzh(i)
-             ! cgs(i,k) = fak3(i)/(pblh(i)*wm(i))
-             ! cgh(i,k) = khfs(i)*cgs(i,k)
-             pr(i) = phiminv(i)/phihinv(i) + ccon*fak3(i)/fak
-             ! cgq(i,k) = kqfs(i)*cgs(i,k)
-          END IF
-       END DO
-       ! print*,'fin counter-gradient terms non zero'
-
-       ! For all unstable layers, compute diffusivities and ctrgrad ter m
-
-       ! DO i = 1, knon
-       ! IF (unslev(i)) THEN
-       ! pcfm(i,k) = pblk(i)
-       ! pcfh(i,k) = pblk(i)/pr(i)
-       ! etc cf original
-       ! ENDIF
-       ! ENDDO
-
-       ! For all layers, compute integral info and CTEI
-
-       DO i = 1, knon
-          IF (check(i) .OR. omegafl(i)) THEN
-             IF (.NOT. zsat(i)) THEN
-                ! Th2 = The_th(i) - RLvCp*qT_th(i)
-                th2 = th_th(i)
-                t2 = th2*s(i, k)
-                ! thermodyn functions
-                zdelta = max(0., sign(1.,rtt-t2))
-                qqsat = r2es*foeew(t2, zdelta)/pplay(i, k)
-                qqsat = min(0.5, qqsat)
-                zcor = 1./(1.-retv*qqsat)
-                qqsat = qqsat*zcor
-
-                IF (qqsat<qt_th(i)) THEN
-                   ! on calcule lcl
-                   IF (k==2) THEN
-                      plcl(i) = z(i, k)
-                   ELSE
-                      plcl(i) = z(i, k-1) + (z(i,k-1)-z(i,k))*(qt_th(i)&
-                           -qsatbef(i))/(qsatbef(i)-qqsat)
-                   END IF
-                   zsat(i) = .TRUE.
-                   tbef(i) = t2
-                END IF
-
-                qsatbef(i) = qqsat ! bug dans la version orig ???
-             END IF
-             ! amn ???? cette ligne a deja ete faite normalement ?
-          END IF
-          ! print*,'hbtm2 i,k=',i,k
-       END DO
-    END DO ! end of level loop
-    ! IM 170305 BEG
-    IF (1==0) THEN
-       PRINT *, 'hbtm2  ok'
-    END IF !(1.EQ.0) THEN
-    ! IM 170305 END
-
-  END SUBROUTINE hbtm
-
-end module hbtm_mod
Index: /LMDZ6/trunk/libf/phylmd/hbtm_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/hbtm_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/hbtm_mod.f90	(revision 5268)
@@ -0,0 +1,769 @@
+module hbtm_mod
+
+  IMPLICIT NONE
+
+contains
+
+  SUBROUTINE hbtm(knon, paprs, pplay, t2m, t10m, q2m, q10m, ustar, wstar, &
+       flux_t, flux_q, u, v, t, q, pblh, cape, eauliq, ctei, pblt, therm, &
+       trmb1, trmb2, trmb3, plcl)
+    USE dimphy
+
+    ! ***************************************************************
+    ! *                                                             *
+    ! * HBTM2   D'apres Holstag&Boville et Troen&Mahrt              *
+    ! *                 JAS 47              BLM                     *
+    ! * Algorithme These Anne Mathieu                               *
+    ! * Critere d'Entrainement Peter Duynkerke (JAS 50)             *
+    ! * written by  : Anne MATHIEU & Alain LAHELLEC, 22/11/99       *
+    ! * features : implem. exces Mathieu                            *
+    ! ***************************************************************
+    ! * mods : decembre 99 passage th a niveau plus bas. voir fixer *
+    ! * la prise du th a z/Lambda = -.2 (max Ray)                   *
+    ! * Autre algo : entrainement ~ Theta+v =cste mais comment=>The?*
+    ! * on peut fixer q a .7qsat(cf non adiab)=>T2 et The2          *
+    ! * voir aussi //KE pblh = niveau The_e ou l = env.             *
+    ! ***************************************************************
+    ! * fin therm a la HBTM passage a forme Mathieu 12/09/2001      *
+    ! ***************************************************************
+    ! *
+
+
+    ! AM Fev 2003
+    ! Adaptation a LMDZ version couplee
+
+    ! Pour le moment on fait passer en argument les grdeurs de surface :
+    ! flux, t,q2m, t,q10m, on va utiliser systematiquement les grdeurs a 2m ms
+    ! on garde la possibilite de changer si besoin est (jusqu'a present la
+    ! forme de HB avec le 1er niveau modele etait conservee)
+
+
+
+
+
+    include "YOMCST.h"
+    REAL rlvcp, reps
+    ! Arguments:
+
+    INTEGER knon ! nombre de points a calculer
+    ! AM
+    REAL t2m(klon), t10m(klon) ! temperature a 2 et 10m
+    REAL q2m(klon), q10m(klon) ! q a 2 et 10m
+    REAL ustar(klon)
+    REAL wstar(klon) ! w*, convective velocity scale
+    REAL paprs(klon, klev+1) ! pression a inter-couche (Pa)
+    REAL pplay(klon, klev) ! pression au milieu de couche (Pa)
+    REAL flux_t(klon, klev), flux_q(klon, klev) ! Flux
+    REAL u(klon, klev) ! vitesse U (m/s)
+    REAL v(klon, klev) ! vitesse V (m/s)
+    REAL t(klon, klev) ! temperature (K)
+    REAL q(klon, klev) ! vapeur d'eau (kg/kg)
+    ! AM      REAL cd_h(klon) ! coefficient de friction au sol pour chaleur
+    ! AM      REAL cd_m(klon) ! coefficient de friction au sol pour vitesse
+
+    INTEGER isommet
+    ! um      PARAMETER (isommet=klev) ! limite max sommet pbl
+    REAL, PARAMETER :: vk = 0.35 ! Von Karman => passer a .41 ! cf U.Olgstrom
+    REAL, PARAMETER :: ricr = 0.4
+    REAL, PARAMETER :: fak = 8.5 ! b calcul du Prandtl et de dTetas
+    REAL, PARAMETER :: fakn = 7.2 ! a
+    REAL, PARAMETER :: onet = 1.0/3.0
+    REAL, PARAMETER :: t_coup = 273.15
+    REAL, PARAMETER :: zkmin = 0.01
+    REAL, PARAMETER :: betam = 15.0 ! pour Phim / h dans la S.L stable
+    REAL, PARAMETER :: betah = 15.0
+
+    REAL, PARAMETER :: betas = 5.0
+    ! Phit dans la S.L. stable (mais 2 formes / z/OBL<>1
+
+    REAL, PARAMETER :: sffrac = 0.1 ! S.L. = z/h < .1
+    REAL, PARAMETER :: usmin = 1.E-12
+    REAL, PARAMETER :: binm = betam*sffrac
+    REAL, PARAMETER :: binh = betah*sffrac
+    REAL, PARAMETER :: ccon = fak*sffrac*vk
+    REAL, PARAMETER :: b1 = 70., b2 = 20.
+    REAL, PARAMETER :: zref = 2. ! Niveau de ref a 2m peut eventuellement
+    ! etre choisi a 10m
+    REAL q_star, t_star
+    REAL b212, b2sr ! Lambert correlations T' q' avec T* q*
+
+    REAL z(klon, klev)
+    ! AM      REAL pcfm(klon,klev), pcfh(klon,klev)
+    INTEGER i, k, j
+    REAL zxt
+    ! AM      REAL zxt, zxq, zxu, zxv, zxmod, taux, tauy
+    ! AM      REAL zx_alf1, zx_alf2 ! parametres pour extrapolation
+    REAL khfs(klon) ! surface kinematic heat flux [mK/s]
+    REAL kqfs(klon) ! sfc kinematic constituent flux [m/s]
+    REAL heatv(klon) ! surface virtual heat flux
+    REAL rhino(klon, klev) ! bulk Richardon no. mais en Theta_v
+    LOGICAL unstbl(klon) ! pts w/unstbl pbl (positive virtual ht flx)
+    LOGICAL stblev(klon) ! stable pbl with levels within pbl
+    LOGICAL unslev(klon) ! unstbl pbl with levels within pbl
+    LOGICAL unssrf(klon) ! unstb pbl w/lvls within srf pbl lyr
+    LOGICAL unsout(klon) ! unstb pbl w/lvls in outer pbl lyr
+    LOGICAL check(klon) ! True=>chk if Richardson no.>critcal
+    LOGICAL omegafl(klon) ! flag de prolongerment cape pour pt Omega
+    REAL pblh(klon)
+    REAL pblt(klon)
+    REAL plcl(klon)
+    ! AM      REAL cgh(klon,2:klev) ! counter-gradient term for heat [K/m]
+    ! AM      REAL cgq(klon,2:klev) ! counter-gradient term for constituents
+    ! AM      REAL cgs(klon,2:klev) ! counter-gradient star (cg/flux)
+    REAL unsobklen(klon) ! Monin-Obukhov lengh
+    ! AM      REAL ztvd, ztvu,
+    REAL zdu2
+    REAL, intent(out):: therm(:) ! (klon) thermal virtual temperature excess
+    REAL trmb1(klon), trmb2(klon), trmb3(klon)
+    ! Algorithme thermique
+    REAL s(klon, klev) ! [P/Po]^Kappa milieux couches
+    REAL th_th(klon) ! potential temperature of thermal
+    REAL the_th(klon) ! equivalent potential temperature of thermal
+    REAL qt_th(klon) ! total water  of thermal
+    REAL tbef(klon) ! T thermique niveau precedent
+    REAL qsatbef(klon)
+    LOGICAL zsat(klon) ! le thermique est sature
+    REAL cape(klon) ! Cape du thermique
+    REAL kape(klon) ! Cape locale
+    REAL eauliq(klon) ! Eau liqu integr du thermique
+    REAL ctei(klon) ! Critere d'instab d'entrainmt des nuages de CL
+    REAL the1, the2, aa, bb, zthvd, zthvu, xintpos, qqsat
+    ! IM 091204 BEG
+    REAL a1, a2, a3
+    ! IM 091204 END
+    REAL xhis, rnum, denom, th1, th2, thv1, thv2, ql2
+    REAL dqsat_dt, qsat2, qt1, q2, t1, t2, xnull, delt_the
+    REAL delt_qt, delt_2, quadsat, spblh, reduc
+
+    REAL phiminv(klon) ! inverse phi function for momentum
+    REAL phihinv(klon) ! inverse phi function for heat
+    REAL wm(klon) ! turbulent velocity scale for momentum
+    REAL fak1(klon) ! k*ustar*pblh
+    REAL fak2(klon) ! k*wm*pblh
+    REAL fak3(klon) ! fakn*wstar/wm
+    REAL pblk(klon) ! level eddy diffusivity for momentum
+    REAL pr(klon) ! Prandtl number for eddy diffusivities
+    REAL zl(klon) ! zmzp / Obukhov length
+    REAL zh(klon) ! zmzp / pblh
+    REAL zzh(klon) ! (1-(zmzp/pblh))**2
+    REAL zm(klon) ! current level height
+    REAL zp(klon) ! current level height + one level up
+    REAL zcor, zdelta, zcvm5
+    ! AM      REAL zxqs
+    REAL fac, pblmin, zmzp, term
+
+    include "YOETHF.h"
+    include "FCTTRE.h"
+
+
+
+    ! initialisations (Anne)
+    isommet = klev
+    th_th(:) = 0.
+    q_star = 0
+    t_star = 0
+    therm = 0.
+
+    b212 = sqrt(b1*b2)
+    b2sr = sqrt(b2)
+
+    ! ============================================================
+    ! Fonctions thermo implicites
+    ! ============================================================
+    ! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+    ! Tetens : pression partielle de vap d'eau e_sat(T)
+    ! =================================================
+    ! ++ e_sat(T) = r2*exp( r3*(T-Tf)/(T-r4) ) id a r2*FOEWE
+    ! ++ avec :
+    ! ++ Tf = 273.16 K  (Temp de fusion de la glace)
+    ! ++ r2 = 611.14 Pa
+    ! ++ r3 = 17.269 (liquide) 21.875 (solide) adim
+    ! ++ r4 = 35.86             7.66           Kelvin
+    ! ++  q_sat = eps*e_sat/(p-(1-eps)*e_sat)
+    ! ++ deriv� :
+    ! ++ =========
+    ! ++                   r3*(Tf-r4)*q_sat(T,p)
+    ! ++ d_qsat_dT = --------------------------------
+    ! ++             (T-r4)^2*( 1-(1-eps)*e_sat(T)/p )
+    ! ++ pour zcvm5=Lv, c'est FOEDE
+    ! ++ Rq :(1.-REPS)*esarg/Parg id a RETV*Qsat
+    ! ------------------------------------------------------------------
+
+    ! Initialisation
+    rlvcp = rlvtt/rcpd
+    reps = rd/rv
+
+
+    ! DO i = 1, klon
+    ! pcfh(i,1) = cd_h(i)
+    ! pcfm(i,1) = cd_m(i)
+    ! ENDDO
+    ! DO k = 2, klev
+    ! DO i = 1, klon
+    ! pcfh(i,k) = zkmin
+    ! pcfm(i,k) = zkmin
+    ! cgs(i,k) = 0.0
+    ! cgh(i,k) = 0.0
+    ! cgq(i,k) = 0.0
+    ! ENDDO
+    ! ENDDO
+
+    ! Calculer les hauteurs de chaque couche
+    ! (geopotentielle Int_dp/ro = Int_[Rd.T.dp/p] z = geop/g)
+    ! pourquoi ne pas utiliser Phi/RG ?
+    DO i = 1, knon
+       z(i, 1) = rd*t(i, 1)/(0.5*(paprs(i,1)+pplay(i,1)))&
+            *(paprs(i,1)-pplay(i,1))/rg
+       s(i, 1) = (pplay(i,1)/paprs(i,1))**rkappa
+    END DO
+    ! s(k) = [pplay(k)/ps]^kappa
+    ! + + + + + + + + + pplay  <-> s(k)   t  dp=pplay(k-1)-pplay(k)
+
+    ! -----------------  paprs <-> sig(k)
+
+    ! + + + + + + + + + pplay  <-> s(k-1)
+
+
+    ! + + + + + + + + + pplay  <-> s(1)   t  dp=paprs-pplay   z(1)
+
+    ! -----------------  paprs <-> sig(1)
+
+    DO k = 2, klev
+       DO i = 1, knon
+          z(i, k) = z(i, k-1) + rd*0.5*(t(i,k-1)+t(i,k))/paprs(i, k)&
+               *(pplay(i,k-1)-pplay(i,k))/rg
+          s(i, k) = (pplay(i,k)/paprs(i,1))**rkappa
+       END DO
+    END DO
+    ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+    ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+    ! +++  Determination des grandeurs de surface  +++++++++++++++++++++
+    ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+    ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+    DO i = 1, knon
+       ! AM         IF (thermcep) THEN
+       ! AM           zdelta=MAX(0.,SIGN(1.,RTT-tsol(i)))
+       ! zcvm5 = R5LES*RLVTT*(1.-zdelta) + R5IES*RLSTT*zdelta
+       ! zcvm5 = zcvm5 / RCPD / (1.0+RVTMP2*q(i,1))
+       ! AM           zxqs= r2es * FOEEW(tsol(i),zdelta)/paprs(i,1)
+       ! AM           zxqs=MIN(0.5,zxqs)
+       ! AM           zcor=1./(1.-retv*zxqs)
+       ! AM           zxqs=zxqs*zcor
+       ! AM         ELSE
+       ! AM           IF (tsol(i).LT.t_coup) THEN
+       ! AM              zxqs = qsats(tsol(i)) / paprs(i,1)
+       ! AM           ELSE
+       ! AM              zxqs = qsatl(tsol(i)) / paprs(i,1)
+       ! AM           ENDIF
+       ! AM         ENDIF
+       ! niveau de reference bulk; mais ici, c,a pourrait etre le niveau de ref
+       ! du thermique
+       ! AM        zx_alf1 = 1.0
+       ! AM        zx_alf2 = 1.0 - zx_alf1
+       ! AM        zxt = (t(i,1)+z(i,1)*RG/RCPD/(1.+RVTMP2*q(i,1)))
+       ! AM     .        *(1.+RETV*q(i,1))*zx_alf1
+       ! AM     .      + (t(i,2)+z(i,2)*RG/RCPD/(1.+RVTMP2*q(i,2)))
+       ! AM     .        *(1.+RETV*q(i,2))*zx_alf2
+       ! AM        zxu = u(i,1)*zx_alf1+u(i,2)*zx_alf2
+       ! AM        zxv = v(i,1)*zx_alf1+v(i,2)*zx_alf2
+       ! AM        zxq = q(i,1)*zx_alf1+q(i,2)*zx_alf2
+       ! AM
+       ! AMAM           zxu = u10m(i)
+       ! AMAM           zxv = v10m(i)
+       ! AMAM           zxmod = 1.0+SQRT(zxu**2+zxv**2)
+       ! AM Niveau de ref choisi a 2m
+       zxt = t2m(i)
+
+       ! ***************************************************
+       ! attention, il doit s'agir de <w'theta'>
+       ! ;Calcul de tcls virtuel et de w'theta'virtuel
+       ! ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+       ! tcls=tcls*(1+.608*qcls)
+
+       ! ;Pour avoir w'theta',
+       ! ; il faut diviser par ro.Cp
+       ! Cp=Cpd*(1+0.84*qcls)
+       ! fcs=fcs/(ro_surf*Cp)
+       ! ;On transforme w'theta' en w'thetav'
+       ! Lv=(2.501-0.00237*(tcls-273.15))*1.E6
+       ! xle=xle/(ro_surf*Lv)
+       ! fcsv=fcs+.608*xle*tcls
+       ! ***************************************************
+       ! AM        khfs(i) = (tsol(i)*(1.+RETV*q(i,1))-zxt) *zxmod*cd_h(i)
+       ! AM        kqfs(i) = (zxqs-zxq) *zxmod*cd_h(i) * beta(i)
+       ! AM
+       ! dif khfs est deja w't'_v / heatv(i) = khfs(i) + RETV*zxt*kqfs(i)
+       ! AM calcule de Ro = paprs(i,1)/Rd zxt
+       ! AM convention >0 vers le bas ds lmdz
+       khfs(i) = -flux_t(i, 1)*zxt*rd/(rcpd*paprs(i,1))
+       kqfs(i) = -flux_q(i, 1)*zxt*rd/(paprs(i,1))
+       ! AM   verifier que khfs et kqfs sont bien de la forme w'l'
+       heatv(i) = khfs(i) + 0.608*zxt*kqfs(i)
+       ! a comparer aussi aux sorties de clqh : flux_T/RoCp et flux_q/RoLv
+       ! AM        heatv(i) = khfs(i)
+       ! AM ustar est en entree
+       ! AM        taux = zxu *zxmod*cd_m(i)
+       ! AM        tauy = zxv *zxmod*cd_m(i)
+       ! AM        ustar(i) = SQRT(taux**2+tauy**2)
+       ! AM        ustar(i) = MAX(SQRT(ustar(i)),0.01)
+       ! Theta et qT du thermique sans exces (interpolin vers surf)
+       ! chgt de niveau du thermique (jeudi 30/12/1999)
+       ! (interpolation lineaire avant integration phi_h)
+       ! AM        qT_th(i) = zxqs*beta(i) + 4./z(i,1)*(q(i,1)-zxqs*beta(i))
+       ! AM        qT_th(i) = max(qT_th(i),q(i,1))
+       qt_th(i) = q2m(i)
+       ! n The_th restera la Theta du thermique sans exces jusqu'a 2eme calcul
+       ! n reste a regler convention P) pour Theta
+       ! The_th(i) = tsol(i) + 4./z(i,1)*(t(i,1)-tsol(i))
+       ! -                      + RLvCp*qT_th(i)
+       ! AM        Th_th(i) = tsol(i) + 4./z(i,1)*(t(i,1)-tsol(i))
+       th_th(i) = t2m(i)
+    END DO
+
+    DO i = 1, knon
+       rhino(i, 1) = 0.0 ! Global Richardson
+       check(i) = .TRUE.
+       pblh(i) = z(i, 1) ! on initialise pblh a l'altitude du 1er niveau
+       plcl(i) = 6000.
+       ! Lambda = -u*^3 / (alpha.g.kvon.<w'Theta'v>
+       unsobklen(i) = -rg*vk*heatv(i)/(t(i,1)*max(ustar(i),usmin)**3)
+       trmb1(i) = 0.
+       trmb2(i) = 0.
+       trmb3(i) = 0.
+    END DO
+
+
+    ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+    ! PBL height calculation:
+    ! Search for level of pbl. Scan upward until the Richardson number between
+    ! the first level and the current level exceeds the "critical" value.
+    ! (bonne idee Nu de separer le Ric et l'exces de temp du thermique)
+    ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+    fac = 100.0
+    DO k = 2, isommet
+       DO i = 1, knon
+          IF (check(i)) THEN
+             ! pourquoi / niveau 1 (au lieu du sol) et le terme en u*^2 ?
+             ! test     zdu2 =
+             ! (u(i,k)-u(i,1))**2+(v(i,k)-v(i,1))**2+fac*ustar(i)**2
+             zdu2 = u(i, k)**2 + v(i, k)**2
+             zdu2 = max(zdu2, 1.0E-20)
+             ! Theta_v environnement
+             zthvd = t(i, k)/s(i, k)*(1.+retv*q(i,k))
+
+             ! therm Theta_v sans exces (avec hypothese fausse de H&B, sinon,
+             ! passer par Theta_e et virpot)
+             ! zthvu=t(i,1)/s(i,1)*(1.+RETV*q(i,1))
+             ! AM         zthvu = Th_th(i)*(1.+RETV*q(i,1))
+             zthvu = th_th(i)*(1.+retv*qt_th(i))
+             ! Le Ri par Theta_v
+             ! AM         rhino(i,k) = (z(i,k)-z(i,1))*RG*(zthvd-zthvu)
+             ! AM     .               /(zdu2*0.5*(zthvd+zthvu))
+             ! AM On a nveau de ref a 2m ???
+             rhino(i, k) = (z(i,k)-zref)*rg*(zthvd-zthvu)/(zdu2*0.5&
+                  *(zthvd+zthvu))
+
+             IF (rhino(i,k)>=ricr) THEN
+                pblh(i) = z(i, k-1) + (z(i,k-1)-z(i,k))*(ricr-rhino(i,k-1))&
+                     /(rhino(i,k-1)-rhino(i,k))
+                ! test04
+                pblh(i) = pblh(i) + 100.
+                pblt(i) = t(i, k-1) + (t(i,k)-t(i,k-1))*(pblh(i)-z(i,k-1))&
+                     /(z(i,k)- z(i,k-1))
+                check(i) = .FALSE.
+             END IF
+          END IF
+       END DO
+    END DO
+
+
+    ! Set pbl height to maximum value where computation exceeds number of
+    ! layers allowed
+
+    DO i = 1, knon
+       IF (check(i)) pblh(i) = z(i, isommet)
+    END DO
+
+    ! Improve estimate of pbl height for the unstable points.
+    ! Find unstable points (sensible heat flux is upward):
+
+    DO i = 1, knon
+       IF (heatv(i)>0.) THEN
+          unstbl(i) = .TRUE.
+          check(i) = .TRUE.
+       ELSE
+          unstbl(i) = .FALSE.
+          check(i) = .FALSE.
+       END IF
+    END DO
+
+    ! For the unstable case, compute velocity scale and the
+    ! convective temperature excess:
+
+    DO i = 1, knon
+       IF (check(i)) THEN
+          phiminv(i) = (1.-binm*pblh(i)*unsobklen(i))**onet
+          ! ***************************************************
+          ! Wm ? et W* ? c'est la formule pour z/h < .1
+          ! ;Calcul de w* ;;
+          ! ;;;;;;;;;;;;;;;;
+          ! w_star=((g/tcls)*fcsv*z(ind))^(1/3.) [ou prendre la premiere approx
+          ! de h)
+          ! ;; CALCUL DE wm ;;
+          ! ;;;;;;;;;;;;;;;;;;
+          ! ; Ici on considerera que l'on est dans la couche de surf jusqu'a
+          ! 100 m
+          ! ; On prend svt couche de surface=0.1*h mais on ne connait pas h
+          ! ;;;;;;;;;;;Dans la couche de surface
+          ! if (z(ind) le 20) then begin
+          ! Phim=(1.-15.*(z(ind)/L))^(-1/3.)
+          ! wm=u_star/Phim
+          ! ;;;;;;;;;;;En dehors de la couche de surface
+          ! endif else if (z(ind) gt 20) then begin
+          ! wm=(u_star^3+c1*w_star^3)^(1/3.)
+          ! endif
+          ! ***************************************************
+          wm(i) = ustar(i)*phiminv(i)
+          ! ===================================================================
+          ! valeurs de Dominique Lambert de la campagne SEMAPHORE :
+          ! <T'^2> = 100.T*^2; <q'^2> = 20.q*^2 a 10m
+          ! <Tv'^2> = (1+1.2q).100.T* + 1.2Tv.sqrt(20*100).T*.q* +
+          ! (.608*Tv)^2*20.q*^2;
+          ! et dTetavS = sqrt(<Tv'^2>) ainsi calculee.
+          ! avec : T*=<w'T'>_s/w* et q*=<w'q'>/w*
+          ! !!! on peut donc utiliser w* pour les fluctuations <-> Lambert
+          ! (leur corellation pourrait dependre de beta par ex)
+          ! if fcsv(i,j) gt 0 then begin
+          ! dTetavs=b1*(1.+2.*.608*q_10(i,j))*(fcs(i,j)/wm(i,j))^2+$
+          ! (.608*Thetav_10(i,j))^2*b2*(xle(i,j)/wm(i,j))^2+$
+          ! 2.*.608*thetav_10(i,j)*sqrt(b1*b2)*(xle(i,j)/wm(i,j))*(fcs(i,j)
+          ! /wm(i,j))
+          ! dqs=b2*(xle(i,j)/wm(i,j))^2
+          ! theta_s(i,j)=thetav_10(i,j)+sqrt(dTetavs)
+          ! q_s(i,j)=q_10(i,j)+sqrt(dqs)
+          ! endif else begin
+          ! Theta_s(i,j)=thetav_10(i,j)
+          ! q_s(i,j)=q_10(i,j)
+          ! endelse
+          ! ===================================================================
+
+          ! HBTM        therm(i) = heatv(i)*fak/wm(i)
+          ! forme Mathieu :
+          q_star = kqfs(i)/wm(i)
+          t_star = khfs(i)/wm(i)
+          ! IM 091204 BEG
+          IF (1==0) THEN
+             IF (t_star<0. .OR. q_star<0.) THEN
+                PRINT *, 'i t_star q_star khfs kqfs wm', i, t_star, q_star, &
+                     khfs(i), kqfs(i), wm(i)
+             END IF
+          END IF
+          ! IM 091204 END
+          ! AM Nveau cde ref 2m =>
+          ! AM        therm(i) = sqrt( b1*(1.+2.*RETV*q(i,1))*t_star**2
+          ! AM     +             + (RETV*T(i,1))**2*b2*q_star**2
+          ! AM     +             + 2.*RETV*T(i,1)*b212*q_star*t_star
+          ! AM     +                 )
+          ! IM 091204 BEG
+          a1 = b1*(1.+2.*retv*qt_th(i))*t_star**2
+          a2 = (retv*th_th(i))**2*b2*q_star*q_star
+          a3 = 2.*retv*th_th(i)*b212*q_star*t_star
+          aa = a1 + a2 + a3
+          IF (1==0) THEN
+             IF (aa<0.) THEN
+                PRINT *, 'i a1 a2 a3 aa', i, a1, a2, a3, aa
+                PRINT *, 'i qT_th Th_th t_star q_star RETV b1 b2 b212', i, &
+                     qt_th(i), th_th(i), t_star, q_star, retv, b1, b2, b212
+             END IF
+          END IF
+          ! IM 091204 END
+          therm(i) = sqrt(b1*(1.+2.*retv*qt_th(i))*t_star**2+(retv*th_th( &
+               i))**2*b2*q_star*q_star &  ! IM 101204  +             +
+                                ! 2.*RETV*Th_th(i)*b212*q_star*t_star
+               +max(0.,2.*retv*th_th(i)*b212*q_star*t_star))
+
+          ! Theta et qT du thermique (forme H&B) avec exces
+          ! (attention, on ajoute therm(i) qui est virtuelle ...)
+          ! pourquoi pas sqrt(b1)*t_star ?
+          ! dqs = b2sr*kqfs(i)/wm(i)
+          qt_th(i) = qt_th(i) + b2sr*q_star
+          ! new on differre le calcul de Theta_e
+          ! The_th(i) = The_th(i) + therm(i) + RLvCp*qT_th(i)
+          ! ou:    The_th(i) = The_th(i) + sqrt(b1)*khfs(i)/wm(i) +
+          ! RLvCp*qT_th(i)
+          rhino(i, 1) = 0.0
+       END IF
+    END DO
+
+    ! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+    ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+    ! ++ Improve pblh estimate for unstable conditions using the +++++++
+    ! ++          convective temperature excess :                +++++++
+    ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+    ! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+    DO k = 2, isommet
+       DO i = 1, knon
+          IF (check(i)) THEN
+             ! test     zdu2 =
+             ! (u(i,k)-u(i,1))**2+(v(i,k)-v(i,1))**2+fac*ustar(i)**2
+             zdu2 = u(i, k)**2 + v(i, k)**2
+             zdu2 = max(zdu2, 1.0E-20)
+             ! Theta_v environnement
+             zthvd = t(i, k)/s(i, k)*(1.+retv*q(i,k))
+
+             ! et therm Theta_v (avec hypothese de constance de H&B,
+             ! zthvu=(t(i,1)+therm(i))/s(i,1)*(1.+RETV*q(i,1))
+             zthvu = th_th(i)*(1.+retv*qt_th(i)) + therm(i)
+
+
+             ! Le Ri par Theta_v
+             ! AM Niveau de ref 2m
+             ! AM         rhino(i,k) = (z(i,k)-z(i,1))*RG*(zthvd-zthvu)
+             ! AM     .               /(zdu2*0.5*(zthvd+zthvu))
+             rhino(i, k) = (z(i,k)-zref)*rg*(zthvd-zthvu)/(zdu2*0.5&
+                  *(zthvd+zthvu))
+
+
+             IF (rhino(i,k)>=ricr) THEN
+                pblh(i) = z(i, k-1) + (z(i,k-1)-z(i,k))*(ricr-rhino(i,k-1))&
+                     /(rhino(i,k-1)-rhino(i,k))
+                ! test04
+                pblh(i) = pblh(i) + 100.
+                pblt(i) = t(i, k-1) + (t(i,k)-t(i,k-1))*(pblh(i)-z(i,k-1))&
+                     /(z(i,k)- z(i,k-1))
+                check(i) = .FALSE.
+                ! IM 170305 BEG
+                IF (1==0) THEN
+                   ! debug print -120;34       -34-        58 et    0;26 wamp
+                   IF (i==950 .OR. i==192 .OR. i==624 .OR. i==118) THEN
+                      PRINT *, ' i,Th_th,Therm,qT :', i, th_th(i), therm(i), &
+                           qt_th(i)
+                      q_star = kqfs(i)/wm(i)
+                      t_star = khfs(i)/wm(i)
+                      PRINT *, 'q* t*, b1,b2,b212 ', q_star, t_star, &
+                           b1*(1.+2.*retv*qt_th(i))*t_star**2, &
+                           (retv*th_th(i))**2*b2*q_star**2, 2.*retv*th_th(i)&
+                           *b212*q_star *t_star
+                      PRINT *, 'zdu2 ,100.*ustar(i)**2', zdu2, fac*ustar(i)**2
+                   END IF
+                END IF !(1.EQ.0) THEN
+                ! IM 170305 END
+                ! q_star = kqfs(i)/wm(i)
+                ! t_star = khfs(i)/wm(i)
+                ! trmb1(i) = b1*(1.+2.*RETV*q(i,1))*t_star**2
+                ! trmb2(i) = (RETV*T(i,1))**2*b2*q_star**2
+                ! Omega now   trmb3(i) = 2.*RETV*T(i,1)*b212*q_star*t_star
+             END IF
+          END IF
+       END DO
+    END DO
+
+    ! Set pbl height to maximum value where computation exceeds number of
+    ! layers allowed
+
+    DO i = 1, knon
+       IF (check(i)) pblh(i) = z(i, isommet)
+    END DO
+
+    ! PBL height must be greater than some minimum mechanical mixing depth
+    ! Several investigators have proposed minimum mechanical mixing depth
+    ! relationships as a function of the local friction velocity, u*.  We
+    ! make use of a linear relationship of the form h = c u* where c=700.
+    ! The scaling arguments that give rise to this relationship most often
+    ! represent the coefficient c as some constant over the local coriolis
+    ! parameter.  Here we make use of the experimental results of Koracin
+    ! and Berkowicz (1988) [BLM, Vol 43] for wich they recommend 0.07/f
+    ! where f was evaluated at 39.5 N and 52 N.  Thus we use a typical mid
+    ! latitude value for f so that c = 0.07/f = 700.
+
+    DO i = 1, knon
+       pblmin = 700.0*ustar(i)
+       pblh(i) = max(pblh(i), pblmin)
+       ! par exemple :
+       pblt(i) = t(i, 2) + (t(i,3)-t(i,2))*(pblh(i)-z(i,2))/(z(i,3)-z(i,2))
+    END DO
+
+    ! ********************************************************************
+    ! pblh is now available; do preparation for diffusivity calculation :
+    ! ********************************************************************
+    DO i = 1, knon
+       check(i) = .TRUE.
+       zsat(i) = .FALSE.
+       ! omegafl utilise pour prolongement CAPE
+       omegafl(i) = .FALSE.
+       cape(i) = 0.
+       kape(i) = 0.
+       eauliq(i) = 0.
+       ctei(i) = 0.
+       pblk(i) = 0.0
+       fak1(i) = ustar(i)*pblh(i)*vk
+
+       ! Do additional preparation for unstable cases only, set temperature
+       ! and moisture perturbations depending on stability.
+       ! *** Rq: les formule sont prises dans leur forme CS ***
+       IF (unstbl(i)) THEN
+          ! AM Niveau de ref du thermique
+          ! AM          zxt=(t(i,1)-z(i,1)*0.5*RG/RCPD/(1.+RVTMP2*q(i,1)))
+          ! AM     .         *(1.+RETV*q(i,1))
+          zxt = (th_th(i)-zref*0.5*rg/rcpd/(1.+rvtmp2*qt_th(i)))* &
+               (1.+retv*qt_th(i))
+          phiminv(i) = (1.-binm*pblh(i)*unsobklen(i))**onet
+          phihinv(i) = sqrt(1.-binh*pblh(i)*unsobklen(i))
+          wm(i) = ustar(i)*phiminv(i)
+          fak2(i) = wm(i)*pblh(i)*vk
+          wstar(i) = (heatv(i)*rg*pblh(i)/zxt)**onet
+          fak3(i) = fakn*wstar(i)/wm(i)
+       ELSE
+          wstar(i) = 0.
+       END IF
+       ! Computes Theta_e for thermal (all cases : to be modified)
+       ! attention ajout therm(i) = virtuelle
+       the_th(i) = th_th(i) + therm(i) + rlvcp*qt_th(i)
+       ! ou:    The_th(i) = Th_th(i) + sqrt(b1)*khfs(i)/wm(i) + RLvCp*qT_th(i)
+    END DO
+
+    ! Main level loop to compute the diffusivities and
+    ! counter-gradient terms:
+
+    DO k = 2, isommet
+
+       ! Find levels within boundary layer:
+
+       DO i = 1, knon
+          unslev(i) = .FALSE.
+          stblev(i) = .FALSE.
+          zm(i) = z(i, k-1)
+          zp(i) = z(i, k)
+          IF (zkmin==0.0 .AND. zp(i)>pblh(i)) zp(i) = pblh(i)
+          IF (zm(i)<pblh(i)) THEN
+             zmzp = 0.5*(zm(i)+zp(i))
+             ! debug
+             ! if (i.EQ.1864) then
+             ! print*,'i,pblh(1864),obklen(1864)',i,pblh(i),obklen(i)
+             ! endif
+
+             zh(i) = zmzp/pblh(i)
+             zl(i) = zmzp*unsobklen(i)
+             zzh(i) = 0.
+             IF (zh(i)<=1.0) zzh(i) = (1.-zh(i))**2
+
+             ! stblev for points zm < plbh and stable and neutral
+             ! unslev for points zm < plbh and unstable
+
+             IF (unstbl(i)) THEN
+                unslev(i) = .TRUE.
+             ELSE
+                stblev(i) = .TRUE.
+             END IF
+          END IF
+       END DO
+       ! print*,'fin calcul niveaux'
+
+       ! Stable and neutral points; set diffusivities; counter-gradient
+       ! terms zero for stable case:
+
+       DO i = 1, knon
+          IF (stblev(i)) THEN
+             IF (zl(i)<=1.) THEN
+                pblk(i) = fak1(i)*zh(i)*zzh(i)/(1.+betas*zl(i))
+             ELSE
+                pblk(i) = fak1(i)*zh(i)*zzh(i)/(betas+zl(i))
+             END IF
+             ! pcfm(i,k) = pblk(i)
+             ! pcfh(i,k) = pcfm(i,k)
+          END IF
+       END DO
+
+       ! unssrf, unstable within surface layer of pbl
+       ! unsout, unstable within outer   layer of pbl
+
+       DO i = 1, knon
+          unssrf(i) = .FALSE.
+          unsout(i) = .FALSE.
+          IF (unslev(i)) THEN
+             IF (zh(i)<sffrac) THEN
+                unssrf(i) = .TRUE.
+             ELSE
+                unsout(i) = .TRUE.
+             END IF
+          END IF
+       END DO
+
+       ! Unstable for surface layer; counter-gradient terms zero
+
+       DO i = 1, knon
+          IF (unssrf(i)) THEN
+             term = (1.-betam*zl(i))**onet
+             pblk(i) = fak1(i)*zh(i)*zzh(i)*term
+             pr(i) = term/sqrt(1.-betah*zl(i))
+          END IF
+       END DO
+       ! print*,'fin counter-gradient terms zero'
+
+       ! Unstable for outer layer; counter-gradient terms non-zero:
+
+       DO i = 1, knon
+          IF (unsout(i)) THEN
+             pblk(i) = fak2(i)*zh(i)*zzh(i)
+             ! cgs(i,k) = fak3(i)/(pblh(i)*wm(i))
+             ! cgh(i,k) = khfs(i)*cgs(i,k)
+             pr(i) = phiminv(i)/phihinv(i) + ccon*fak3(i)/fak
+             ! cgq(i,k) = kqfs(i)*cgs(i,k)
+          END IF
+       END DO
+       ! print*,'fin counter-gradient terms non zero'
+
+       ! For all unstable layers, compute diffusivities and ctrgrad ter m
+
+       ! DO i = 1, knon
+       ! IF (unslev(i)) THEN
+       ! pcfm(i,k) = pblk(i)
+       ! pcfh(i,k) = pblk(i)/pr(i)
+       ! etc cf original
+       ! ENDIF
+       ! ENDDO
+
+       ! For all layers, compute integral info and CTEI
+
+       DO i = 1, knon
+          IF (check(i) .OR. omegafl(i)) THEN
+             IF (.NOT. zsat(i)) THEN
+                ! Th2 = The_th(i) - RLvCp*qT_th(i)
+                th2 = th_th(i)
+                t2 = th2*s(i, k)
+                ! thermodyn functions
+                zdelta = max(0., sign(1.,rtt-t2))
+                qqsat = r2es*foeew(t2, zdelta)/pplay(i, k)
+                qqsat = min(0.5, qqsat)
+                zcor = 1./(1.-retv*qqsat)
+                qqsat = qqsat*zcor
+
+                IF (qqsat<qt_th(i)) THEN
+                   ! on calcule lcl
+                   IF (k==2) THEN
+                      plcl(i) = z(i, k)
+                   ELSE
+                      plcl(i) = z(i, k-1) + (z(i,k-1)-z(i,k))*(qt_th(i)&
+                           -qsatbef(i))/(qsatbef(i)-qqsat)
+                   END IF
+                   zsat(i) = .TRUE.
+                   tbef(i) = t2
+                END IF
+
+                qsatbef(i) = qqsat ! bug dans la version orig ???
+             END IF
+             ! amn ???? cette ligne a deja ete faite normalement ?
+          END IF
+          ! print*,'hbtm2 i,k=',i,k
+       END DO
+    END DO ! end of level loop
+    ! IM 170305 BEG
+    IF (1==0) THEN
+       PRINT *, 'hbtm2  ok'
+    END IF !(1.EQ.0) THEN
+    ! IM 170305 END
+
+  END SUBROUTINE hbtm
+
+end module hbtm_mod
Index: DZ6/trunk/libf/phylmd/hines_gwd.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/hines_gwd.F90	(revision 5267)
+++ 	(revision )
@@ -1,2019 +1,0 @@
-
-! $Id$
-
-SUBROUTINE hines_gwd(nlon, nlev, dtime, paphm1x, papm1x, rlat, tx, ux, vx, &
-    zustrhi, zvstrhi, d_t_hin, d_u_hin, d_v_hin)
-
-  ! ########################################################################
-  ! Parametrization of the momentum flux deposition due to a broad band
-  ! spectrum of gravity waves, following Hines (1997a,b), as coded by
-  ! McLANDRESS (1995). Modified by McFARLANE and MANZINI (1995-1997)
-  ! MAECHAM model stand alone version
-  ! ########################################################################
-
-
-  USE dimphy
-  IMPLICIT NONE
-
-  include "YOEGWD.h"
-  include "YOMCST.h"
-
-  INTEGER nazmth
-  PARAMETER (nazmth=8)
-
-  ! INPUT ARGUMENTS.
-  ! ----- ----------
-
-  ! - 2D
-  ! PAPHM1   : HALF LEVEL PRESSURE (T-DT)
-  ! PAPM1    : FULL LEVEL PRESSURE (T-DT)
-  ! PTM1     : TEMPERATURE (T-DT)
-  ! PUM1     : ZONAL WIND (T-DT)
-  ! PVM1     : MERIDIONAL WIND (T-DT)
-
-
-  ! REFERENCE.
-  ! ----------
-  ! SEE MODEL DOCUMENTATION
-
-  ! AUTHOR.
-  ! -------
-
-  ! N. MCFARLANE   DKRZ-HAMBURG   MAY 1995
-  ! STAND ALONE E. MANZINI MPI-HAMBURG FEBRUARY 1997
-
-  ! BASED ON A COMBINATION OF THE OROGRAPHIC SCHEME BY N.MCFARLANE 1987
-  ! AND THE HINES SCHEME AS CODED BY C. MCLANDRESS 1995.
-
-
-
-  ! ym      INTEGER KLEVM1
-
-  REAL paphm1(klon, klev+1), papm1(klon, klev)
-  REAL ptm1(klon, klev), pum1(klon, klev), pvm1(klon, klev)
-  REAL prflux(klon)
-  ! 1
-  ! 1
-  ! 1
-  REAL rlat(klon), coslat(klon)
-
-  REAL th(klon, klev), utendgw(klon, klev), vtendgw(klon, klev), &
-    pressg(klon), uhs(klon, klev), vhs(klon, klev), zpr(klon)
-
-  ! * VERTICAL POSITIONING ARRAYS.
-
-  REAL sgj(klon, klev), shj(klon, klev), shxkj(klon, klev), dsgj(klon, klev)
-
-  ! * LOGICAL SWITCHES TO CONTROL ROOF DRAG, ENVELOP GW DRAG AND
-  ! * HINES' DOPPLER SPREADING EXTROWAVE GW DRAG.
-  ! * LOZPR IS TRUE FOR ZPR ENHANCEMENT
-
-
-  ! * WORK ARRAYS.
-
-  REAL m_alpha(klon, klev, nazmth), v_alpha(klon, klev, nazmth), &
-    sigma_alpha(klon, klev, nazmth), sigsqh_alpha(klon, klev, nazmth), &
-    drag_u(klon, klev), drag_v(klon, klev), flux_u(klon, klev), &
-    flux_v(klon, klev), heat(klon, klev), diffco(klon, klev), &
-    bvfreq(klon, klev), density(klon, klev), sigma_t(klon, klev), &
-    visc_mol(klon, klev), alt(klon, klev), sigsqmcw(klon, klev, nazmth), &
-    sigmatm(klon, klev), ak_alpha(klon, nazmth), k_alpha(klon, nazmth), &
-    mmin_alpha(klon, nazmth), i_alpha(klon, nazmth), rmswind(klon), &
-    bvfbot(klon), densbot(klon)
-  REAL smoothr1(klon, klev), smoothr2(klon, klev)
-  REAL sigalpmc(klon, klev, nazmth)
-  REAL f2mod(klon, klev)
-
-  ! * THES ARE THE INPUT PARAMETERS FOR HINES ROUTINE AND
-  ! * ARE SPECIFIED IN ROUTINE HINES_SETUP. SINCE THIS IS CALLED
-  ! * ONLY AT FIRST CALL TO THIS ROUTINE THESE VARIABLES MUST BE SAVED
-  ! * FOR USE AT SUBSEQUENT CALLS. THIS CAN BE AVOIDED BY CALLING
-  ! * HINES_SETUP IN MAIN PROGRAM AND PASSING THE PARAMETERS AS
-  ! * SUBROUTINE ARGUEMENTS.
-
-
-  REAL rmscon
-  INTEGER nmessg, iprint, ilrms
-  INTEGER ifl
-
-  INTEGER naz, icutoff, nsmax, iheatcal
-  REAL slope, f1, f2, f3, f5, f6, kstar(klon), alt_cutoff, smco
-
-  ! PROVIDED AS INPUT
-
-  INTEGER nlon, nlev
-
-  REAL dtime
-  REAL paphm1x(nlon, nlev+1), papm1x(nlon, nlev)
-  REAL ux(nlon, nlev), vx(nlon, nlev), tx(nlon, nlev)
-
-  ! VARIABLES FOR OUTPUT
-
-
-  REAL d_t_hin(nlon, nlev), d_u_hin(nlon, nlev), d_v_hin(nlon, nlev)
-  REAL zustrhi(nlon), zvstrhi(nlon)
-
-
-  ! * LOGICAL SWITCHES TO CONTROL PRECIP ENHANCEMENT AND
-  ! * HINES' DOPPLER SPREADING EXTROWAVE GW DRAG.
-  ! * LOZPR IS TRUE FOR ZPR ENHANCEMENT
-
-  LOGICAL lozpr, lorms(klon)
-
-  ! LOCAL PARAMETERS TO MAKE THINGS WORK (TEMPORARY VARIABLE)
-
-  REAL rhoh2o, zpcons, rgocp, zlat, dttdsf, ratio, hscal
-  INTEGER i, j, l, jl, jk, le, lref, lrefp, levbot
-
-  ! DATA PARAMETERS NEEDED, EXPLAINED LATER
-
-  REAL v0, vmin, dmpscal, taufac, hmin, apibt, cpart, fcrit
-  REAL pcrit, pcons
-  INTEGER iplev, ierror
-
-
-
-  ! PRINT *,' IT IS STARTED HINES GOING ON...'
-
-
-
-
-  ! *    COMPUTATIONAL CONSTANTS.
-  ! ------------- ----------
-
-
-  d_t_hin(:, :) = 0.
-
-  rhoh2o = 1000.
-  zpcons = (1000.*86400.)/rhoh2o
-  ! ym      KLEVM1=KLEV-1
-
-
-  DO jl = kidia, kfdia
-    paphm1(jl, 1) = paphm1x(jl, klev+1)
-    DO jk = 1, klev
-      le = klev + 1 - jk
-      paphm1(jl, jk+1) = paphm1x(jl, le)
-      papm1(jl, jk) = papm1x(jl, le)
-      ptm1(jl, jk) = tx(jl, le)
-      pum1(jl, jk) = ux(jl, le)
-      pvm1(jl, jk) = vx(jl, le)
-    END DO
-  END DO
-
-  ! Define constants and arrays needed for the ccc/mam gwd scheme
-  ! *Constants:
-
-  rgocp = rd/rcpd
-  lrefp = klev - 1
-  lref = klev - 2
-  ! 1
-  ! 1    *Arrays
-  ! 1
-  DO jk = 1, klev
-    DO jl = kidia, kfdia
-      shj(jl, jk) = papm1(jl, jk)/paphm1(jl, klev+1)
-      sgj(jl, jk) = papm1(jl, jk)/paphm1(jl, klev+1)
-      dsgj(jl, jk) = (paphm1(jl,jk+1)-paphm1(jl,jk))/paphm1(jl, klev+1)
-      shxkj(jl, jk) = (papm1(jl,jk)/paphm1(jl,klev+1))**rgocp
-      th(jl, jk) = ptm1(jl, jk)
-    END DO
-  END DO
-
-  ! C
-  DO jl = kidia, kfdia
-    pressg(jl) = paphm1(jl, klev+1)
-  END DO
-
-
-  DO jl = kidia, kfdia
-    prflux(jl) = 0.0
-    zpr(jl) = zpcons*prflux(jl)
-    zlat = (rlat(jl)/180.)*rpi
-    coslat(jl) = cos(zlat)
-  END DO
-
-  ! /#########################################################################
-  ! /
-  ! /
-
-  ! * AUG. 14/95 - C. MCLANDRESS.
-  ! * SEP.    95   N. MCFARLANE.
-
-  ! * THIS ROUTINE CALCULATES THE HORIZONTAL WIND TENDENCIES
-  ! * DUE TO MCFARLANE'S OROGRAPHIC GW DRAG SCHEME, HINES'
-  ! * DOPPLER SPREAD SCHEME FOR "EXTROWAVES" AND ADDS ON
-  ! * ROOF DRAG. IT IS BASED ON THE ROUTINE GWDFLX8.
-
-  ! * LREFP IS THE INDEX OF THE MODEL LEVEL BELOW THE REFERENCE LEVEL
-  ! * I/O ARRAYS PASSED FROM MAIN.
-  ! * (PRESSG = SURFACE PRESSURE)
-
-
-
-
-  ! * CONSTANTS VALUES DEFINED IN DATA STATEMENT ARE :
-  ! * VMIN     = MIMINUM WIND IN THE DIRECTION OF REFERENCE LEVEL
-  ! *            WIND BEFORE WE CONSIDER BREAKING TO HAVE OCCURED.
-  ! * DMPSCAL  = DAMPING TIME FOR GW DRAG IN SECONDS.
-  ! * TAUFAC   = 1/(LENGTH SCALE).
-  ! * HMIN     = MIMINUM ENVELOPE HEIGHT REQUIRED TO PRODUCE GW DRAG.
-  ! * V0       = VALUE OF WIND THAT APPROXIMATES ZERO.
-
-
-  DATA vmin/5.0/, v0/1.E-10/, taufac/5.E-6/, hmin/40000./, dmpscal/6.5E+6/, &
-    apibt/1.5708/, cpart/0.7/, fcrit/1./
-
-  ! * HINES EXTROWAVE GWD CONSTANTS DEFINED IN DATA STATEMENT ARE:
-  ! * RMSCON = ROOT MEAN SQUARE GRAVITY WAVE WIND AT LOWEST LEVEL (M/S).
-  ! * NMESSG  = UNIT NUMBER FOR PRINTED MESSAGES.
-  ! * IPRINT  = 1 TO DO PRINT OUT SOME HINES ARRAYS.
-  ! * IFL     = FIRST CALL FLAG TO HINES_SETUP ("SAVE" IT)
-  ! * PCRIT = CRITICAL VALUE OF ZPR (MM/D)
-  ! * IPLEV = LEVEL OF APPLICATION OF PRCIT
-  ! * PCONS = FACTOR OF ZPR ENHANCEMENT
-
-
-  DATA pcrit/5./, pcons/4.75/
-
-  iplev = lrefp - 1
-
-  DATA rmscon/1.00/iprint/2/, nmessg/6/
-  DATA ifl/0/
-
-  lozpr = .FALSE.
-
-  ! -----------------------------------------------------------------------
-
-
-
-  ! * SET ERROR FLAG
-
-  ierror = 0
-
-  ! * SPECIFY VARIOUS PARAMETERS FOR HINES ROUTINE AT VERY FIRST CALL.
-  ! * (NOTE THAT ARRAY K_ALPHA IS SPECIFIED SO MAKE SURE THAT
-  ! * IT IS NOT OVERWRITTEN LATER ON).
-
-  CALL hines_setup(naz, slope, f1, f2, f3, f5, f6, kstar, icutoff, &
-    alt_cutoff, smco, nsmax, iheatcal, k_alpha, ierror, nmessg, klon, nazmth, &
-    coslat)
-  IF (ierror/=0) GO TO 999
-
-  ! * START GWD CALCULATIONS.
-
-  lref = lrefp - 1
-
-
-  DO j = 1, nazmth
-    DO l = 1, klev
-      DO i = kidia, klon
-        sigsqmcw(i, l, j) = 0.
-      END DO
-    END DO
-  END DO
-
-
-
-  ! * INITIALIZE NECESSARY ARRAYS.
-
-  DO l = 1, klev
-    DO i = kidia, kfdia
-      utendgw(i, l) = 0.
-      vtendgw(i, l) = 0.
-
-      uhs(i, l) = 0.
-      vhs(i, l) = 0.
-
-    END DO
-  END DO
-
-  ! * IF USING HINES SCHEME THEN CALCULATE B V FREQUENCY AT ALL POINTS
-  ! * AND SMOOTH BVFREQ.
-
-  DO l = 2, klev
-    DO i = kidia, kfdia
-      dttdsf = (th(i,l)/shxkj(i,l)-th(i,l-1)/shxkj(i,l-1))/ &
-        (shj(i,l)-shj(i,l-1))
-      dttdsf = min(dttdsf, -5./sgj(i,l))
-      bvfreq(i, l) = sqrt(-dttdsf*sgj(i,l)*(sgj(i,l)**rgocp)/rd)*rg/ptm1(i, l &
-        )
-    END DO
-  END DO
-  DO l = 1, klev
-    DO i = kidia, kfdia
-      IF (l==1) THEN
-        bvfreq(i, l) = bvfreq(i, l+1)
-      END IF
-      IF (l>1) THEN
-        ratio = 5.*log(sgj(i,l)/sgj(i,l-1))
-        bvfreq(i, l) = (bvfreq(i,l-1)+ratio*bvfreq(i,l))/(1.+ratio)
-      END IF
-    END DO
-  END DO
-
-  ! * CALCULATE GW DRAG DUE TO HINES' EXTROWAVES
-  ! * SET MOLECULAR VISCOSITY TO A VERY SMALL VALUE.
-  ! * IF THE MODEL TOP IS GREATER THAN 100 KM THEN THE ACTUAL
-  ! * VISCOSITY COEFFICIENT COULD BE SPECIFIED HERE.
-
-  DO l = 1, klev
-    DO i = kidia, kfdia
-      visc_mol(i, l) = 1.5E-5
-      drag_u(i, l) = 0.
-      drag_v(i, l) = 0.
-      flux_u(i, l) = 0.
-      flux_v(i, l) = 0.
-      heat(i, l) = 0.
-      diffco(i, l) = 0.
-    END DO
-  END DO
-
-  ! * ALTITUDE AND DENSITY AT BOTTOM.
-
-  DO i = kidia, kfdia
-    hscal = rd*ptm1(i, klev)/rg
-    density(i, klev) = sgj(i, klev)*pressg(i)/(rg*hscal)
-    alt(i, klev) = 0.
-  END DO
-
-  ! * ALTITUDE AND DENSITY AT REMAINING LEVELS.
-
-  DO l = klev - 1, 1, -1
-    DO i = kidia, kfdia
-      hscal = rd*ptm1(i, l)/rg
-      alt(i, l) = alt(i, l+1) + hscal*dsgj(i, l)/sgj(i, l)
-      density(i, l) = sgj(i, l)*pressg(i)/(rg*hscal)
-    END DO
-  END DO
-
-
-  ! * INITIALIZE SWITCHES FOR HINES GWD CALCULATION
-
-  ilrms = 0
-
-  DO i = kidia, kfdia
-    lorms(i) = .FALSE.
-  END DO
-
-
-  ! * DEFILE BOTTOM LAUNCH LEVEL
-
-  levbot = iplev
-
-  ! * BACKGROUND WIND MINUS VALUE AT BOTTOM LAUNCH LEVEL.
-
-  DO l = 1, levbot
-    DO i = kidia, kfdia
-      uhs(i, l) = pum1(i, l) - pum1(i, levbot)
-      vhs(i, l) = pvm1(i, l) - pvm1(i, levbot)
-    END DO
-  END DO
-
-  ! * SPECIFY ROOT MEAN SQUARE WIND AT BOTTOM LAUNCH LEVEL.
-
-  DO i = kidia, kfdia
-    rmswind(i) = rmscon
-  END DO
-
-  IF (lozpr) THEN
-    DO i = kidia, kfdia
-      IF (zpr(i)>pcrit) THEN
-        rmswind(i) = rmscon + ((zpr(i)-pcrit)/zpr(i))*pcons
-      END IF
-    END DO
-  END IF
-
-  DO i = kidia, kfdia
-    IF (rmswind(i)>0.0) THEN
-      ilrms = ilrms + 1
-      lorms(i) = .TRUE.
-    END IF
-  END DO
-
-  ! * CALCULATE GWD (NOTE THAT DIFFUSION COEFFICIENT AND
-  ! * HEATING RATE ONLY CALCULATED IF IHEATCAL = 1).
-
-  IF (ilrms>0) THEN
-
-    CALL hines_extro0(drag_u, drag_v, heat, diffco, flux_u, flux_v, uhs, vhs, &
-      bvfreq, density, visc_mol, alt, rmswind, k_alpha, m_alpha, v_alpha, &
-      sigma_alpha, sigsqh_alpha, ak_alpha, mmin_alpha, i_alpha, sigma_t, &
-      densbot, bvfbot, 1, iheatcal, icutoff, iprint, nsmax, smco, alt_cutoff, &
-      kstar, slope, f1, f2, f3, f5, f6, naz, sigsqmcw, sigmatm, kidia, klon, &
-      1, levbot, klon, klev, nazmth, lorms, smoothr1, smoothr2, sigalpmc, &
-      f2mod)
-
-    ! * ADD ON HINES' GWD TENDENCIES TO OROGRAPHIC TENDENCIES AND
-    ! * APPLY HINES' GW DRAG ON (UROW,VROW) WORK ARRAYS.
-
-    DO l = 1, klev
-      DO i = kidia, kfdia
-        utendgw(i, l) = utendgw(i, l) + drag_u(i, l)
-        vtendgw(i, l) = vtendgw(i, l) + drag_v(i, l)
-      END DO
-    END DO
-
-
-    ! * END OF HINES CALCULATIONS.
-
-  END IF
-
-  ! -----------------------------------------------------------------------
-
-  DO jl = kidia, kfdia
-    zustrhi(jl) = flux_u(jl, 1)
-    zvstrhi(jl) = flux_v(jl, 1)
-    DO jk = 1, klev
-      le = klev - jk + 1
-      d_u_hin(jl, jk) = utendgw(jl, le)*dtime
-      d_v_hin(jl, jk) = vtendgw(jl, le)*dtime
-    END DO
-  END DO
-
-  ! PRINT *,'UTENDGW:',UTENDGW
-
-  ! PRINT *,' HINES HAS BEEN COMPLETED (LONG ISNT IT...)'
-
-  RETURN
-999 CONTINUE
-
-  ! * IF ERROR DETECTED THEN ABORT.
-
-  WRITE (nmessg, 6000)
-  WRITE (nmessg, 6010) ierror
-6000 FORMAT (/' EXECUTION ABORTED IN GWDOREXV')
-6010 FORMAT ('     ERROR FLAG =', I4)
-
-
-  RETURN
-END SUBROUTINE hines_gwd
-! /
-! /
-
-
-SUBROUTINE hines_extro0(drag_u, drag_v, heat, diffco, flux_u, flux_v, vel_u, &
-    vel_v, bvfreq, density, visc_mol, alt, rmswind, k_alpha, m_alpha, &
-    v_alpha, sigma_alpha, sigsqh_alpha, ak_alpha, mmin_alpha, i_alpha, &
-    sigma_t, densb, bvfb, iorder, iheatcal, icutoff, iprint, nsmax, smco, &
-    alt_cutoff, kstar, slope, f1, f2, f3, f5, f6, naz, sigsqmcw, sigmatm, &
-    il1, il2, lev1, lev2, nlons, nlevs, nazmth, lorms, smoothr1, smoothr2, &
-    sigalpmc, f2mod)
-
-  IMPLICIT NONE
-
-  ! Main routine for Hines' "extrowave" gravity wave parameterization based
-  ! on Hines' Doppler spread theory. This routine calculates zonal
-  ! and meridional components of gravity wave drag, heating rates
-  ! and diffusion coefficient on a longitude by altitude grid.
-  ! No "mythical" lower boundary region calculation is made so it
-  ! is assumed that lowest level winds are weak (i.e, approximately zero).
-
-  ! Aug. 13/95 - C. McLandress
-  ! SEPT. /95  - N.McFarlane
-
-  ! Modifications:
-
-  ! Output arguements:
-
-  ! * DRAG_U = zonal component of gravity wave drag (m/s^2).
-  ! * DRAG_V = meridional component of gravity wave drag (m/s^2).
-  ! * HEAT   = gravity wave heating (K/sec).
-  ! * DIFFCO = diffusion coefficient (m^2/sec)
-  ! * FLUX_U = zonal component of vertical momentum flux (Pascals)
-  ! * FLUX_V = meridional component of vertical momentum flux (Pascals)
-
-  ! Input arguements:
-
-  ! * VEL_U      = background zonal wind component (m/s).
-  ! * VEL_V      = background meridional wind component (m/s).
-  ! * BVFREQ     = background Brunt Vassala frequency (radians/sec).
-  ! * DENSITY    = background density (kg/m^3)
-  ! * VISC_MOL   = molecular viscosity (m^2/s)
-  ! * ALT        = altitude of momentum, density, buoyancy levels (m)
-  ! *              (NOTE: levels ordered so that ALT(I,1) > ALT(I,2), etc.)
-  ! * RMSWIND   = root mean square gravity wave wind at lowest level (m/s).
-  ! * K_ALPHA    = horizontal wavenumber of each azimuth (1/m).
-  ! * IORDER	   = 1 means vertical levels are indexed from top down
-  ! *              (i.e., highest level indexed 1 and lowest level NLEVS);
-  ! *           .NE. 1 highest level is index NLEVS.
-  ! * IHEATCAL   = 1 to calculate heating rates and diffusion coefficient.
-  ! * IPRINT     = 1 to print out various arrays.
-  ! * ICUTOFF    = 1 to exponentially damp GWD, heating and diffusion
-  ! *              arrays above ALT_CUTOFF; otherwise arrays not modified.
-  ! * ALT_CUTOFF = altitude in meters above which exponential decay applied.
-  ! * SMCO       = smoothing factor used to smooth cutoff vertical
-  ! *              wavenumbers and total rms winds in vertical direction
-  ! *              before calculating drag or heating
-  ! *              (SMCO >= 1 ==> 1:SMCO:1 stencil used).
-  ! * NSMAX      = number of times smoother applied ( >= 1),
-  ! *            = 0 means no smoothing performed.
-  ! * KSTAR      = typical gravity wave horizontal wavenumber (1/m).
-  ! * SLOPE      = slope of incident vertical wavenumber spectrum
-  ! *              (SLOPE must equal 1., 1.5 or 2.).
-  ! * F1 to F6   = Hines's fudge factors (F4 not needed since used for
-  ! *              vertical flux of vertical momentum).
-  ! * NAZ        = actual number of horizontal azimuths used.
-  ! * IL1        = first longitudinal index to use (IL1 >= 1).
-  ! * IL2        = last longitudinal index to use (IL1 <= IL2 <= NLONS).
-  ! * LEV1       = index of first level for drag calculation.
-  ! * LEV2       = index of last level for drag calculation
-  ! *              (i.e., LEV1 < LEV2 <= NLEVS).
-  ! * NLONS      = number of longitudes.
-  ! * NLEVS      = number of vertical levels.
-  ! * NAZMTH     = azimuthal array dimension (NAZMTH >= NAZ).
-
-  ! Work arrays.
-
-  ! * M_ALPHA      = cutoff vertical wavenumber (1/m).
-  ! * V_ALPHA      = wind component at each azimuth (m/s) and if IHEATCAL=1
-  ! *                holds vertical derivative of cutoff wavenumber.
-  ! * SIGMA_ALPHA  = total rms wind in each azimuth (m/s).
-  ! * SIGSQH_ALPHA = portion of wind variance from waves having wave
-  ! *                normals in the alpha azimuth (m/s).
-  ! * SIGMA_T      = total rms horizontal wind (m/s).
-  ! * AK_ALPHA     = spectral amplitude factor at each azimuth
-  ! *                (i.e.,{AjKj}) in m^4/s^2.
-  ! * I_ALPHA      = Hines' integral.
-  ! * MMIN_ALPHA   = minimum value of cutoff wavenumber.
-  ! * DENSB        = background density at bottom level.
-  ! * BVFB         = buoyancy frequency at bottom level and
-  ! *                work array for ICUTOFF = 1.
-
-  ! * LORMS       = .TRUE. for drag computation
-
-  INTEGER naz, nlons, nlevs, nazmth, il1, il2, lev1, lev2
-  INTEGER icutoff, nsmax, iorder, iheatcal, iprint
-  REAL kstar(nlons), f1, f2, f3, f5, f6, slope
-  REAL alt_cutoff, smco
-  REAL drag_u(nlons, nlevs), drag_v(nlons, nlevs)
-  REAL heat(nlons, nlevs), diffco(nlons, nlevs)
-  REAL flux_u(nlons, nlevs), flux_v(nlons, nlevs)
-  REAL vel_u(nlons, nlevs), vel_v(nlons, nlevs)
-  REAL bvfreq(nlons, nlevs), density(nlons, nlevs)
-  REAL visc_mol(nlons, nlevs), alt(nlons, nlevs)
-  REAL rmswind(nlons), bvfb(nlons), densb(nlons)
-  REAL sigma_t(nlons, nlevs), sigsqmcw(nlons, nlevs, nazmth)
-  REAL sigma_alpha(nlons, nlevs, nazmth), sigmatm(nlons, nlevs)
-  REAL sigsqh_alpha(nlons, nlevs, nazmth)
-  REAL m_alpha(nlons, nlevs, nazmth), v_alpha(nlons, nlevs, nazmth)
-  REAL ak_alpha(nlons, nazmth), k_alpha(nlons, nazmth)
-  REAL mmin_alpha(nlons, nazmth), i_alpha(nlons, nazmth)
-  REAL smoothr1(nlons, nlevs), smoothr2(nlons, nlevs)
-  REAL sigalpmc(nlons, nlevs, nazmth)
-  REAL f2mod(nlons, nlevs)
-
-  LOGICAL lorms(nlons)
-
-  ! Internal variables.
-
-  INTEGER levbot, levtop, i, n, l, lev1p, lev2m
-  INTEGER ilprt1, ilprt2
-  ! -----------------------------------------------------------------------
-
-  ! PRINT *,' IN HINES_EXTRO0'
-  lev1p = lev1 + 1
-  lev2m = lev2 - 1
-
-  ! Index of lowest altitude level (bottom of drag calculation).
-
-  levbot = lev2
-  levtop = lev1
-  IF (iorder/=1) THEN
-    WRITE (6, 1)
-1   FORMAT (2X, ' error: IORDER NOT ONE! ')
-  END IF
-
-  ! Buoyancy and density at bottom level.
-
-  DO i = il1, il2
-    bvfb(i) = bvfreq(i, levbot)
-    densb(i) = density(i, levbot)
-  END DO
-
-  ! initialize some variables
-
-  DO n = 1, naz
-    DO l = lev1, lev2
-      DO i = il1, il2
-        m_alpha(i, l, n) = 0.0
-      END DO
-    END DO
-  END DO
-  DO l = lev1, lev2
-    DO i = il1, il2
-      sigma_t(i, l) = 0.0
-    END DO
-  END DO
-  DO n = 1, naz
-    DO i = il1, il2
-      i_alpha(i, n) = 0.0
-    END DO
-  END DO
-
-  ! Compute azimuthal wind components from zonal and meridional winds.
-
-  CALL hines_wind(v_alpha, vel_u, vel_v, naz, il1, il2, lev1, lev2, nlons, &
-    nlevs, nazmth)
-
-  ! Calculate cutoff vertical wavenumber and velocity variances.
-
-  CALL hines_wavnum(m_alpha, sigma_alpha, sigsqh_alpha, sigma_t, ak_alpha, &
-    v_alpha, visc_mol, density, densb, bvfreq, bvfb, rmswind, i_alpha, &
-    mmin_alpha, kstar, slope, f1, f2, f3, naz, levbot, levtop, il1, il2, &
-    nlons, nlevs, nazmth, sigsqmcw, sigmatm, lorms, sigalpmc, f2mod)
-  ! Smooth cutoff wavenumbers and total rms velocity in the vertical
-  ! direction NSMAX times, using FLUX_U as temporary work array.
-
-  IF (nsmax>0) THEN
-    DO n = 1, naz
-      DO l = lev1, lev2
-        DO i = il1, il2
-          smoothr1(i, l) = m_alpha(i, l, n)
-        END DO
-      END DO
-      CALL vert_smooth(smoothr1, smoothr2, smco, nsmax, il1, il2, lev1, lev2, &
-        nlons, nlevs)
-      DO l = lev1, lev2
-        DO i = il1, il2
-          m_alpha(i, l, n) = smoothr1(i, l)
-        END DO
-      END DO
-    END DO
-    CALL vert_smooth(sigma_t, smoothr2, smco, nsmax, il1, il2, lev1, lev2, &
-      nlons, nlevs)
-  END IF
-
-  ! Calculate zonal and meridional components of the
-  ! momentum flux and drag.
-
-  CALL hines_flux(flux_u, flux_v, drag_u, drag_v, alt, density, densb, &
-    m_alpha, ak_alpha, k_alpha, slope, naz, il1, il2, lev1, lev2, nlons, &
-    nlevs, nazmth, lorms)
-
-  ! Cutoff drag above ALT_CUTOFF, using BVFB as temporary work array.
-
-  IF (icutoff==1) THEN
-    CALL hines_exp(drag_u, bvfb, alt, alt_cutoff, iorder, il1, il2, lev1, &
-      lev2, nlons, nlevs)
-    CALL hines_exp(drag_v, bvfb, alt, alt_cutoff, iorder, il1, il2, lev1, &
-      lev2, nlons, nlevs)
-  END IF
-
-  ! Print out various arrays for diagnostic purposes.
-
-  IF (iprint==1) THEN
-    ilprt1 = 15
-    ilprt2 = 16
-    CALL hines_print(flux_u, flux_v, drag_u, drag_v, alt, sigma_t, &
-      sigma_alpha, v_alpha, m_alpha, 1, 1, 6, ilprt1, ilprt2, lev1, lev2, &
-      naz, nlons, nlevs, nazmth)
-  END IF
-
-  ! If not calculating heating rate and diffusion coefficient then finished.
-
-  IF (iheatcal/=1) RETURN
-
-  ! Calculate vertical derivative of cutoff wavenumber (store
-  ! in array V_ALPHA) using centered differences at interior gridpoints
-  ! and one-sided differences at first and last levels.
-
-  DO n = 1, naz
-    DO l = lev1p, lev2m
-      DO i = il1, il2
-        v_alpha(i, l, n) = (m_alpha(i,l+1,n)-m_alpha(i,l-1,n))/ &
-          (alt(i,l+1)-alt(i,l-1))
-      END DO
-    END DO
-    DO i = il1, il2
-      v_alpha(i, lev1, n) = (m_alpha(i,lev1p,n)-m_alpha(i,lev1,n))/ &
-        (alt(i,lev1p)-alt(i,lev1))
-    END DO
-    DO i = il1, il2
-      v_alpha(i, lev2, n) = (m_alpha(i,lev2,n)-m_alpha(i,lev2m,n))/ &
-        (alt(i,lev2)-alt(i,lev2m))
-    END DO
-  END DO
-
-  ! Heating rate and diffusion coefficient.
-
-  CALL hines_heat(heat, diffco, m_alpha, v_alpha, ak_alpha, k_alpha, bvfreq, &
-    density, densb, sigma_t, visc_mol, kstar, slope, f2, f3, f5, f6, naz, &
-    il1, il2, lev1, lev2, nlons, nlevs, nazmth)
-
-  ! Finished.
-
-  RETURN
-  ! -----------------------------------------------------------------------
-END SUBROUTINE hines_extro0
-
-SUBROUTINE hines_wavnum(m_alpha, sigma_alpha, sigsqh_alpha, sigma_t, &
-    ak_alpha, v_alpha, visc_mol, density, densb, bvfreq, bvfb, rms_wind, &
-    i_alpha, mmin_alpha, kstar, slope, f1, f2, f3, naz, levbot, levtop, il1, &
-    il2, nlons, nlevs, nazmth, sigsqmcw, sigmatm, lorms, sigalpmc, f2mod)
-  IMPLICIT NONE
-  ! This routine calculates the cutoff vertical wavenumber and velocity
-  ! variances on a longitude by altitude grid for the Hines' Doppler
-  ! spread gravity wave drag parameterization scheme.
-  ! NOTE: (1) only values of four or eight can be used for # azimuths (NAZ).
-  ! (2) only values of 1.0, 1.5 or 2.0 can be used for slope (SLOPE).
-
-  ! Aug. 10/95 - C. McLandress
-
-  ! Output arguements:
-
-  ! * M_ALPHA      = cutoff wavenumber at each azimuth (1/m).
-  ! * SIGMA_ALPHA  = total rms wind in each azimuth (m/s).
-  ! * SIGSQH_ALPHA = portion of wind variance from waves having wave
-  ! *                normals in the alpha azimuth (m/s).
-  ! * SIGMA_T      = total rms horizontal wind (m/s).
-  ! * AK_ALPHA     = spectral amplitude factor at each azimuth
-  ! *                (i.e.,{AjKj}) in m^4/s^2.
-
-  ! Input arguements:
-
-  ! * V_ALPHA  = wind component at each azimuth (m/s).
-  ! * VISC_MOL = molecular viscosity (m^2/s)
-  ! * DENSITY  = background density (kg/m^3).
-  ! * DENSB    = background density at model bottom (kg/m^3).
-  ! * BVFREQ   = background Brunt Vassala frequency (radians/sec).
-  ! * BVFB     = background Brunt Vassala frequency at model bottom.
-  ! * RMS_WIND = root mean square gravity wave wind at lowest level (m/s).
-  ! * KSTAR    = typical gravity wave horizontal wavenumber (1/m).
-  ! * SLOPE    = slope of incident vertical wavenumber spectrum
-  ! *            (SLOPE = 1., 1.5 or 2.).
-  ! * F1,F2,F3 = Hines's fudge factors.
-  ! * NAZ      = actual number of horizontal azimuths used (4 or 8).
-  ! * LEVBOT   = index of lowest vertical level.
-  ! * LEVTOP   = index of highest vertical level
-  ! *            (NOTE: if LEVTOP < LEVBOT then level index
-  ! *             increases from top down).
-  ! * IL1      = first longitudinal index to use (IL1 >= 1).
-  ! * IL2      = last longitudinal index to use (IL1 <= IL2 <= NLONS).
-  ! * NLONS    = number of longitudes.
-  ! * NLEVS    = number of vertical levels.
-  ! * NAZMTH   = azimuthal array dimension (NAZMTH >= NAZ).
-
-  ! * LORMS       = .TRUE. for drag computation
-
-  ! Input work arrays:
-
-  ! * I_ALPHA    = Hines' integral at a single level.
-  ! * MMIN_ALPHA = minimum value of cutoff wavenumber.
-
-  INTEGER naz, levbot, levtop, il1, il2, nlons, nlevs, nazmth
-  REAL slope, kstar(nlons), f1, f2, f3, f2mfac
-  REAL m_alpha(nlons, nlevs, nazmth)
-  REAL sigma_alpha(nlons, nlevs, nazmth)
-  REAL sigalpmc(nlons, nlevs, nazmth)
-  REAL sigsqh_alpha(nlons, nlevs, nazmth)
-  REAL sigsqmcw(nlons, nlevs, nazmth)
-  REAL sigma_t(nlons, nlevs)
-  REAL sigmatm(nlons, nlevs)
-  REAL ak_alpha(nlons, nazmth)
-  REAL v_alpha(nlons, nlevs, nazmth)
-  REAL visc_mol(nlons, nlevs)
-  REAL f2mod(nlons, nlevs)
-  REAL density(nlons, nlevs), densb(nlons)
-  REAL bvfreq(nlons, nlevs), bvfb(nlons), rms_wind(nlons)
-  REAL i_alpha(nlons, nazmth), mmin_alpha(nlons, nazmth)
-
-  LOGICAL lorms(nlons)
-
-  ! Internal variables.
-
-  INTEGER i, l, n, lstart, lend, lincr, lbelow
-  REAL m_sub_m_turb, m_sub_m_mol, m_trial
-  REAL visc, visc_min, azfac, sp1
-
-  ! c      REAL  N_OVER_M(1000), SIGFAC(1000)
-
-  REAL n_over_m(nlons), sigfac(nlons)
-  DATA visc_min/1.E-10/
-  ! -----------------------------------------------------------------------
-
-
-  ! PRINT *,'IN HINES_WAVNUM'
-  sp1 = slope + 1.
-
-  ! Indices of levels to process.
-
-  IF (levbot>levtop) THEN
-    lstart = levbot - 1
-    lend = levtop
-    lincr = -1
-  ELSE
-    WRITE (6, 1)
-1   FORMAT (2X, ' error: IORDER NOT ONE! ')
-  END IF
-
-  ! Use horizontal isotropy to calculate azimuthal variances at bottom level.
-
-  azfac = 1./real(naz)
-  DO n = 1, naz
-    DO i = il1, il2
-      sigsqh_alpha(i, levbot, n) = azfac*rms_wind(i)**2
-    END DO
-  END DO
-
-  ! Velocity variances at bottom level.
-
-  CALL hines_sigma(sigma_t, sigma_alpha, sigsqh_alpha, naz, levbot, il1, il2, &
-    nlons, nlevs, nazmth)
-
-  CALL hines_sigma(sigmatm, sigalpmc, sigsqmcw, naz, levbot, il1, il2, nlons, &
-    nlevs, nazmth)
-
-  ! Calculate cutoff wavenumber and spectral amplitude factor
-  ! at bottom level where it is assumed that background winds vanish
-  ! and also initialize minimum value of cutoff wavnumber.
-
-  DO n = 1, naz
-    DO i = il1, il2
-      IF (lorms(i)) THEN
-        m_alpha(i, levbot, n) = bvfb(i)/(f1*sigma_alpha(i,levbot,n)+f2* &
-          sigma_t(i,levbot))
-        ak_alpha(i, n) = sigsqh_alpha(i, levbot, n)/ &
-          (m_alpha(i,levbot,n)**sp1/sp1)
-        mmin_alpha(i, n) = m_alpha(i, levbot, n)
-      END IF
-    END DO
-  END DO
-
-  ! Calculate quantities from the bottom upwards,
-  ! starting one level above bottom.
-
-  DO l = lstart, lend, lincr
-
-    ! Level beneath present level.
-
-    lbelow = l - lincr
-
-    ! Calculate N/m_M where m_M is maximum permissible value of the vertical
-    ! wavenumber (i.e., m > m_M are obliterated) and N is buoyancy frequency.
-    ! m_M is taken as the smaller of the instability-induced
-    ! wavenumber (M_SUB_M_TURB) and that imposed by molecular viscosity
-    ! (M_SUB_M_MOL). Since variance at this level is not yet known
-    ! use value at level below.
-
-    DO i = il1, il2
-      IF (lorms(i)) THEN
-
-        f2mfac = sigmatm(i, lbelow)**2
-        f2mod(i, lbelow) = 1. + 2.*f2mfac/(f2mfac+sigma_t(i,lbelow)**2)
-
-        visc = amax1(visc_mol(i,l), visc_min)
-        m_sub_m_turb = bvfreq(i, l)/(f2*f2mod(i,lbelow)*sigma_t(i,lbelow))
-        m_sub_m_mol = (bvfreq(i,l)*kstar(i)/visc)**0.33333333/f3
-        IF (m_sub_m_turb<m_sub_m_mol) THEN
-          n_over_m(i) = f2*f2mod(i, lbelow)*sigma_t(i, lbelow)
-        ELSE
-          n_over_m(i) = bvfreq(i, l)/m_sub_m_mol
-        END IF
-      END IF
-    END DO
-
-    ! Calculate cutoff wavenumber at this level.
-
-    DO n = 1, naz
-      DO i = il1, il2
-        IF (lorms(i)) THEN
-
-          ! Calculate trial value (since variance at this level is not yet
-          ! known
-          ! use value at level below). If trial value is negative or if it
-          ! exceeds
-          ! minimum value (not permitted) then set it to minimum value.
-
-          m_trial = bvfb(i)/(f1*(sigma_alpha(i,lbelow,n)+sigalpmc(i,lbelow, &
-            n))+n_over_m(i)+v_alpha(i,l,n))
-          IF (m_trial<=0. .OR. m_trial>mmin_alpha(i,n)) THEN
-            m_trial = mmin_alpha(i, n)
-          END IF
-          m_alpha(i, l, n) = m_trial
-
-          ! Reset minimum value of cutoff wavenumber if necessary.
-
-          IF (m_alpha(i,l,n)<mmin_alpha(i,n)) THEN
-            mmin_alpha(i, n) = m_alpha(i, l, n)
-          END IF
-
-        END IF
-      END DO
-    END DO
-
-    ! Calculate the Hines integral at this level.
-
-    CALL hines_intgrl(i_alpha, v_alpha, m_alpha, bvfb, slope, naz, l, il1, &
-      il2, nlons, nlevs, nazmth, lorms)
-
-
-    ! Calculate the velocity variances at this level.
-
-    DO i = il1, il2
-      sigfac(i) = densb(i)/density(i, l)*bvfreq(i, l)/bvfb(i)
-    END DO
-    DO n = 1, naz
-      DO i = il1, il2
-        sigsqh_alpha(i, l, n) = sigfac(i)*ak_alpha(i, n)*i_alpha(i, n)
-      END DO
-    END DO
-    CALL hines_sigma(sigma_t, sigma_alpha, sigsqh_alpha, naz, l, il1, il2, &
-      nlons, nlevs, nazmth)
-
-    CALL hines_sigma(sigmatm, sigalpmc, sigsqmcw, naz, l, il1, il2, nlons, &
-      nlevs, nazmth)
-
-    ! End of level loop.
-
-  END DO
-
-  RETURN
-  ! -----------------------------------------------------------------------
-END SUBROUTINE hines_wavnum
-
-SUBROUTINE hines_wind(v_alpha, vel_u, vel_v, naz, il1, il2, lev1, lev2, &
-    nlons, nlevs, nazmth)
-    IMPLICIT NONE
-  ! This routine calculates the azimuthal horizontal background wind
-  ! components
-  ! on a longitude by altitude grid for the case of 4 or 8 azimuths for
-  ! the Hines' Doppler spread GWD parameterization scheme.
-
-  ! Aug. 7/95 - C. McLandress
-
-  ! Output arguement:
-
-  ! * V_ALPHA   = background wind component at each azimuth (m/s).
-  ! *             (note: first azimuth is in eastward direction
-  ! *              and rotate in counterclockwise direction.)
-
-  ! Input arguements:
-
-  ! * VEL_U     = background zonal wind component (m/s).
-  ! * VEL_V     = background meridional wind component (m/s).
-  ! * NAZ       = actual number of horizontal azimuths used (must be 4 or 8).
-  ! * IL1       = first longitudinal index to use (IL1 >= 1).
-  ! * IL2       = last longitudinal index to use (IL1 <= IL2 <= NLONS).
-  ! * LEV1      = first altitude level to use (LEV1 >=1).
-  ! * LEV2      = last altitude level to use (LEV1 < LEV2 <= NLEVS).
-  ! * NLONS     = number of longitudes.
-  ! * NLEVS     = number of vertical levels.
-  ! * NAZMTH    = azimuthal array dimension (NAZMTH >= NAZ).
-
-  ! Constants in DATA statements.
-
-  ! * COS45 = cosine of 45 degrees.
-  ! * UMIN  = minimum allowable value for zonal or meridional
-  ! *         wind component (m/s).
-
-  ! Subroutine arguements.
-
-  INTEGER naz, il1, il2, lev1, lev2
-  INTEGER nlons, nlevs, nazmth
-  REAL v_alpha(nlons, nlevs, nazmth)
-  REAL vel_u(nlons, nlevs), vel_v(nlons, nlevs)
-
-  ! Internal variables.
-
-  INTEGER i, l
-  REAL u, v, cos45, umin
-
-  DATA cos45/0.7071068/
-  DATA umin/0.001/
-  ! -----------------------------------------------------------------------
-
-  ! Case with 4 azimuths.
-
-
-  ! PRINT *,'IN HINES_WIND'
-  IF (naz==4) THEN
-    DO l = lev1, lev2
-      DO i = il1, il2
-        u = vel_u(i, l)
-        v = vel_v(i, l)
-        IF (abs(u)<umin) u = umin
-        IF (abs(v)<umin) v = umin
-        v_alpha(i, l, 1) = u
-        v_alpha(i, l, 2) = v
-        v_alpha(i, l, 3) = -u
-        v_alpha(i, l, 4) = -v
-      END DO
-    END DO
-  END IF
-
-  ! Case with 8 azimuths.
-
-  IF (naz==8) THEN
-    DO l = lev1, lev2
-      DO i = il1, il2
-        u = vel_u(i, l)
-        v = vel_v(i, l)
-        IF (abs(u)<umin) u = umin
-        IF (abs(v)<umin) v = umin
-        v_alpha(i, l, 1) = u
-        v_alpha(i, l, 2) = cos45*(v+u)
-        v_alpha(i, l, 3) = v
-        v_alpha(i, l, 4) = cos45*(v-u)
-        v_alpha(i, l, 5) = -u
-        v_alpha(i, l, 6) = -v_alpha(i, l, 2)
-        v_alpha(i, l, 7) = -v
-        v_alpha(i, l, 8) = -v_alpha(i, l, 4)
-      END DO
-    END DO
-  END IF
-
-  RETURN
-  ! -----------------------------------------------------------------------
-END SUBROUTINE hines_wind
-
-SUBROUTINE hines_flux(flux_u, flux_v, drag_u, drag_v, alt, density, densb, &
-    m_alpha, ak_alpha, k_alpha, slope, naz, il1, il2, lev1, lev2, nlons, &
-    nlevs, nazmth, lorms)
-    IMPLICIT NONE
-  ! Calculate zonal and meridional components of the vertical flux
-  ! of horizontal momentum and corresponding wave drag (force per unit mass)
-  ! on a longitude by altitude grid for the Hines' Doppler spread
-  ! GWD parameterization scheme.
-  ! NOTE: only 4 or 8 azimuths can be used.
-
-  ! Aug. 6/95 - C. McLandress
-
-  ! Output arguements:
-
-  ! * FLUX_U = zonal component of vertical momentum flux (Pascals)
-  ! * FLUX_V = meridional component of vertical momentum flux (Pascals)
-  ! * DRAG_U = zonal component of drag (m/s^2).
-  ! * DRAG_V = meridional component of drag (m/s^2).
-
-  ! Input arguements:
-
-  ! * ALT       = altitudes (m).
-  ! * DENSITY   = background density (kg/m^3).
-  ! * DENSB     = background density at bottom level (kg/m^3).
-  ! * M_ALPHA   = cutoff vertical wavenumber (1/m).
-  ! * AK_ALPHA  = spectral amplitude factor (i.e., {AjKj} in m^4/s^2).
-  ! * K_ALPHA   = horizontal wavenumber (1/m).
-  ! * SLOPE     = slope of incident vertical wavenumber spectrum.
-  ! * NAZ       = actual number of horizontal azimuths used (must be 4 or 8).
-  ! * IL1       = first longitudinal index to use (IL1 >= 1).
-  ! * IL2       = last longitudinal index to use (IL1 <= IL2 <= NLONS).
-  ! * LEV1      = first altitude level to use (LEV1 >=1).
-  ! * LEV2      = last altitude level to use (LEV1 < LEV2 <= NLEVS).
-  ! * NLONS     = number of longitudes.
-  ! * NLEVS     = number of vertical levels.
-  ! * NAZMTH    = azimuthal array dimension (NAZMTH >= NAZ).
-
-  ! * LORMS       = .TRUE. for drag computation
-
-  ! Constant in DATA statement.
-
-  ! * COS45 = cosine of 45 degrees.
-
-  ! Subroutine arguements.
-
-  INTEGER naz, il1, il2, lev1, lev2
-  INTEGER nlons, nlevs, nazmth
-  REAL slope
-  REAL flux_u(nlons, nlevs), flux_v(nlons, nlevs)
-  REAL drag_u(nlons, nlevs), drag_v(nlons, nlevs)
-  REAL alt(nlons, nlevs), density(nlons, nlevs), densb(nlons)
-  REAL m_alpha(nlons, nlevs, nazmth)
-  REAL ak_alpha(nlons, nazmth), k_alpha(nlons, nazmth)
-
-  LOGICAL lorms(nlons)
-
-  ! Internal variables.
-
-  INTEGER i, l, lev1p, lev2m, lev2p
-  REAL cos45, prod2, prod4, prod6, prod8, dendz, dendz2
-  DATA cos45/0.7071068/
-  ! -----------------------------------------------------------------------
-
-  lev1p = lev1 + 1
-  lev2m = lev2 - 1
-  lev2p = lev2 + 1
-
-  ! Sum over azimuths for case where SLOPE = 1.
-
-  IF (slope==1.) THEN
-
-    ! Case with 4 azimuths.
-
-    IF (naz==4) THEN
-      DO l = lev1, lev2
-        DO i = il1, il2
-          flux_u(i, l) = ak_alpha(i, 1)*k_alpha(i, 1)*m_alpha(i, l, 1) - &
-            ak_alpha(i, 3)*k_alpha(i, 3)*m_alpha(i, l, 3)
-          flux_v(i, l) = ak_alpha(i, 2)*k_alpha(i, 2)*m_alpha(i, l, 2) - &
-            ak_alpha(i, 4)*k_alpha(i, 4)*m_alpha(i, l, 4)
-        END DO
-      END DO
-    END IF
-
-    ! Case with 8 azimuths.
-
-    IF (naz==8) THEN
-      DO l = lev1, lev2
-        DO i = il1, il2
-          prod2 = ak_alpha(i, 2)*k_alpha(i, 2)*m_alpha(i, l, 2)
-          prod4 = ak_alpha(i, 4)*k_alpha(i, 4)*m_alpha(i, l, 4)
-          prod6 = ak_alpha(i, 6)*k_alpha(i, 6)*m_alpha(i, l, 6)
-          prod8 = ak_alpha(i, 8)*k_alpha(i, 8)*m_alpha(i, l, 8)
-          flux_u(i, l) = ak_alpha(i, 1)*k_alpha(i, 1)*m_alpha(i, l, 1) - &
-            ak_alpha(i, 5)*k_alpha(i, 5)*m_alpha(i, l, 5) + &
-            cos45*(prod2-prod4-prod6+prod8)
-          flux_v(i, l) = ak_alpha(i, 3)*k_alpha(i, 3)*m_alpha(i, l, 3) - &
-            ak_alpha(i, 7)*k_alpha(i, 7)*m_alpha(i, l, 7) + &
-            cos45*(prod2+prod4-prod6-prod8)
-        END DO
-      END DO
-    END IF
-
-  END IF
-
-  ! Sum over azimuths for case where SLOPE not equal to 1.
-
-  IF (slope/=1.) THEN
-
-    ! Case with 4 azimuths.
-
-    IF (naz==4) THEN
-      DO l = lev1, lev2
-        DO i = il1, il2
-          flux_u(i, l) = ak_alpha(i, 1)*k_alpha(i, 1)* &
-            m_alpha(i, l, 1)**slope - ak_alpha(i, 3)*k_alpha(i, 3)*m_alpha(i, &
-            l, 3)**slope
-          flux_v(i, l) = ak_alpha(i, 2)*k_alpha(i, 2)* &
-            m_alpha(i, l, 2)**slope - ak_alpha(i, 4)*k_alpha(i, 4)*m_alpha(i, &
-            l, 4)**slope
-        END DO
-      END DO
-    END IF
-
-    ! Case with 8 azimuths.
-
-    IF (naz==8) THEN
-      DO l = lev1, lev2
-        DO i = il1, il2
-          prod2 = ak_alpha(i, 2)*k_alpha(i, 2)*m_alpha(i, l, 2)**slope
-          prod4 = ak_alpha(i, 4)*k_alpha(i, 4)*m_alpha(i, l, 4)**slope
-          prod6 = ak_alpha(i, 6)*k_alpha(i, 6)*m_alpha(i, l, 6)**slope
-          prod8 = ak_alpha(i, 8)*k_alpha(i, 8)*m_alpha(i, l, 8)**slope
-          flux_u(i, l) = ak_alpha(i, 1)*k_alpha(i, 1)* &
-            m_alpha(i, l, 1)**slope - ak_alpha(i, 5)*k_alpha(i, 5)*m_alpha(i, &
-            l, 5)**slope + cos45*(prod2-prod4-prod6+prod8)
-          flux_v(i, l) = ak_alpha(i, 3)*k_alpha(i, 3)* &
-            m_alpha(i, l, 3)**slope - ak_alpha(i, 7)*k_alpha(i, 7)*m_alpha(i, &
-            l, 7)**slope + cos45*(prod2+prod4-prod6-prod8)
-        END DO
-      END DO
-    END IF
-
-  END IF
-
-  ! Calculate flux from sum.
-
-  DO l = lev1, lev2
-    DO i = il1, il2
-      flux_u(i, l) = flux_u(i, l)*densb(i)/slope
-      flux_v(i, l) = flux_v(i, l)*densb(i)/slope
-    END DO
-  END DO
-
-  ! Calculate drag at intermediate levels using centered differences
-
-  DO l = lev1p, lev2m
-    DO i = il1, il2
-      IF (lorms(i)) THEN
-        ! cc       DENDZ2 = DENSITY(I,L) * ( ALT(I,L+1) - ALT(I,L-1) )
-        dendz2 = density(i, l)*(alt(i,l-1)-alt(i,l))
-        ! cc       DRAG_U(I,L) = - ( FLUX_U(I,L+1) - FLUX_U(I,L-1) ) / DENDZ2
-        drag_u(i, l) = -(flux_u(i,l-1)-flux_u(i,l))/dendz2
-        ! cc       DRAG_V(I,L) = - ( FLUX_V(I,L+1) - FLUX_V(I,L-1) ) / DENDZ2
-        drag_v(i, l) = -(flux_v(i,l-1)-flux_v(i,l))/dendz2
-
-      END IF
-    END DO
-  END DO
-
-  ! Drag at first and last levels using one-side differences.
-
-  DO i = il1, il2
-    IF (lorms(i)) THEN
-      dendz = density(i, lev1)*(alt(i,lev1)-alt(i,lev1p))
-      drag_u(i, lev1) = flux_u(i, lev1)/dendz
-      drag_v(i, lev1) = flux_v(i, lev1)/dendz
-    END IF
-  END DO
-  DO i = il1, il2
-    IF (lorms(i)) THEN
-      dendz = density(i, lev2)*(alt(i,lev2m)-alt(i,lev2))
-      drag_u(i, lev2) = -(flux_u(i,lev2m)-flux_u(i,lev2))/dendz
-      drag_v(i, lev2) = -(flux_v(i,lev2m)-flux_v(i,lev2))/dendz
-    END IF
-  END DO
-  IF (nlevs>lev2) THEN
-    DO i = il1, il2
-      IF (lorms(i)) THEN
-        dendz = density(i, lev2p)*(alt(i,lev2)-alt(i,lev2p))
-        drag_u(i, lev2p) = -flux_u(i, lev2)/dendz
-        drag_v(i, lev2p) = -flux_v(i, lev2)/dendz
-      END IF
-    END DO
-  END IF
-
-  RETURN
-  ! -----------------------------------------------------------------------
-END SUBROUTINE hines_flux
-
-SUBROUTINE hines_heat(heat, diffco, m_alpha, dmdz_alpha, ak_alpha, k_alpha, &
-    bvfreq, density, densb, sigma_t, visc_mol, kstar, slope, f2, f3, f5, f6, &
-    naz, il1, il2, lev1, lev2, nlons, nlevs, nazmth)
-  IMPLICIT NONE
-  ! This routine calculates the gravity wave induced heating and
-  ! diffusion coefficient on a longitude by altitude grid for
-  ! the Hines' Doppler spread gravity wave drag parameterization scheme.
-
-  ! Aug. 6/95 - C. McLandress
-
-  ! Output arguements:
-
-  ! * HEAT   = gravity wave heating (K/sec).
-  ! * DIFFCO = diffusion coefficient (m^2/sec)
-
-  ! Input arguements:
-
-  ! * M_ALPHA     = cutoff vertical wavenumber (1/m).
-  ! * DMDZ_ALPHA  = vertical derivative of cutoff wavenumber.
-  ! * AK_ALPHA    = spectral amplitude factor of each azimuth
-  ! (i.e., {AjKj} in m^4/s^2).
-  ! * K_ALPHA     = horizontal wavenumber of each azimuth (1/m).
-  ! * BVFREQ      = background Brunt Vassala frequency (rad/sec).
-  ! * DENSITY     = background density (kg/m^3).
-  ! * DENSB       = background density at bottom level (kg/m^3).
-  ! * SIGMA_T     = total rms horizontal wind (m/s).
-  ! * VISC_MOL    = molecular viscosity (m^2/s).
-  ! * KSTAR       = typical gravity wave horizontal wavenumber (1/m).
-  ! * SLOPE       = slope of incident vertical wavenumber spectrum.
-  ! * F2,F3,F5,F6 = Hines's fudge factors.
-  ! * NAZ         = actual number of horizontal azimuths used.
-  ! * IL1         = first longitudinal index to use (IL1 >= 1).
-  ! * IL2         = last longitudinal index to use (IL1 <= IL2 <= NLONS).
-  ! * LEV1        = first altitude level to use (LEV1 >=1).
-  ! * LEV2        = last altitude level to use (LEV1 < LEV2 <= NLEVS).
-  ! * NLONS       = number of longitudes.
-  ! * NLEVS       = number of vertical levels.
-  ! * NAZMTH      = azimuthal array dimension (NAZMTH >= NAZ).
-
-  INTEGER naz, il1, il2, lev1, lev2, nlons, nlevs, nazmth
-  REAL kstar(nlons), slope, f2, f3, f5, f6
-  REAL heat(nlons, nlevs), diffco(nlons, nlevs)
-  REAL m_alpha(nlons, nlevs, nazmth), dmdz_alpha(nlons, nlevs, nazmth)
-  REAL ak_alpha(nlons, nazmth), k_alpha(nlons, nazmth)
-  REAL bvfreq(nlons, nlevs), density(nlons, nlevs), densb(nlons)
-  REAL sigma_t(nlons, nlevs), visc_mol(nlons, nlevs)
-
-  ! Internal variables.
-
-  INTEGER i, l, n
-  REAL m_sub_m_turb, m_sub_m_mol, m_sub_m, heatng
-  REAL visc, visc_min, cpgas, sm1
-
-  ! specific heat at constant pressure
-
-  DATA cpgas/1004./
-
-  ! minimum permissible viscosity
-
-  DATA visc_min/1.E-10/
-  ! -----------------------------------------------------------------------
-
-  ! Initialize heating array.
-
-  DO l = 1, nlevs
-    DO i = 1, nlons
-      heat(i, l) = 0.
-    END DO
-  END DO
-
-  ! Perform sum over azimuths for case where SLOPE = 1.
-
-  IF (slope==1.) THEN
-    DO n = 1, naz
-      DO l = lev1, lev2
-        DO i = il1, il2
-          heat(i, l) = heat(i, l) + ak_alpha(i, n)*k_alpha(i, n)*dmdz_alpha(i &
-            , l, n)
-        END DO
-      END DO
-    END DO
-  END IF
-
-  ! Perform sum over azimuths for case where SLOPE not 1.
-
-  IF (slope/=1.) THEN
-    sm1 = slope - 1.
-    DO n = 1, naz
-      DO l = lev1, lev2
-        DO i = il1, il2
-          heat(i, l) = heat(i, l) + ak_alpha(i, n)*k_alpha(i, n)*m_alpha(i, l &
-            , n)**sm1*dmdz_alpha(i, l, n)
-        END DO
-      END DO
-    END DO
-  END IF
-
-  ! Heating and diffusion.
-
-  DO l = lev1, lev2
-    DO i = il1, il2
-
-      ! Maximum permissible value of cutoff wavenumber is the smaller
-      ! of the instability-induced wavenumber (M_SUB_M_TURB) and
-      ! that imposed by molecular viscosity (M_SUB_M_MOL).
-
-      visc = amax1(visc_mol(i,l), visc_min)
-      m_sub_m_turb = bvfreq(i, l)/(f2*sigma_t(i,l))
-      m_sub_m_mol = (bvfreq(i,l)*kstar(i)/visc)**0.33333333/f3
-      m_sub_m = amin1(m_sub_m_turb, m_sub_m_mol)
-
-      heatng = -heat(i, l)*f5*bvfreq(i, l)/m_sub_m*densb(i)/density(i, l)
-      diffco(i, l) = f6*heatng**0.33333333/m_sub_m**1.33333333
-      heat(i, l) = heatng/cpgas
-
-    END DO
-  END DO
-
-  RETURN
-  ! -----------------------------------------------------------------------
-END SUBROUTINE hines_heat
-
-SUBROUTINE hines_sigma(sigma_t, sigma_alpha, sigsqh_alpha, naz, lev, il1, &
-    il2, nlons, nlevs, nazmth)
-  IMPLICIT NONE
-  ! This routine calculates the total rms and azimuthal rms horizontal
-  ! velocities at a given level on a longitude by altitude grid for
-  ! the Hines' Doppler spread GWD parameterization scheme.
-  ! NOTE: only four or eight azimuths can be used.
-
-  ! Aug. 7/95 - C. McLandress
-
-  ! Output arguements:
-
-  ! * SIGMA_T      = total rms horizontal wind (m/s).
-  ! * SIGMA_ALPHA  = total rms wind in each azimuth (m/s).
-
-  ! Input arguements:
-
-  ! * SIGSQH_ALPHA = portion of wind variance from waves having wave
-  ! *                normals in the alpha azimuth (m/s).
-  ! * NAZ       = actual number of horizontal azimuths used (must be 4 or 8).
-  ! * LEV       = altitude level to process.
-  ! * IL1       = first longitudinal index to use (IL1 >= 1).
-  ! * IL2       = last longitudinal index to use (IL1 <= IL2 <= NLONS).
-  ! * NLONS     = number of longitudes.
-  ! * NLEVS     = number of vertical levels.
-  ! * NAZMTH    = azimuthal array dimension (NAZMTH >= NAZ).
-
-  ! Subroutine arguements.
-
-  INTEGER lev, naz, il1, il2
-  INTEGER nlons, nlevs, nazmth
-  REAL sigma_t(nlons, nlevs)
-  REAL sigma_alpha(nlons, nlevs, nazmth)
-  REAL sigsqh_alpha(nlons, nlevs, nazmth)
-
-  ! Internal variables.
-
-  INTEGER i, n
-  REAL sum_even, sum_odd
-  ! -----------------------------------------------------------------------
-
-  ! Calculate azimuthal rms velocity for the 4 azimuth case.
-
-  IF (naz==4) THEN
-    DO i = il1, il2
-      sigma_alpha(i, lev, 1) = sqrt(sigsqh_alpha(i,lev,1)+sigsqh_alpha(i,lev, &
-        3))
-      sigma_alpha(i, lev, 2) = sqrt(sigsqh_alpha(i,lev,2)+sigsqh_alpha(i,lev, &
-        4))
-      sigma_alpha(i, lev, 3) = sigma_alpha(i, lev, 1)
-      sigma_alpha(i, lev, 4) = sigma_alpha(i, lev, 2)
-    END DO
-  END IF
-
-  ! Calculate azimuthal rms velocity for the 8 azimuth case.
-
-  IF (naz==8) THEN
-    DO i = il1, il2
-      sum_odd = (sigsqh_alpha(i,lev,1)+sigsqh_alpha(i,lev,3)+ &
-        sigsqh_alpha(i,lev,5)+sigsqh_alpha(i,lev,7))/2.
-      sum_even = (sigsqh_alpha(i,lev,2)+sigsqh_alpha(i,lev,4)+ &
-        sigsqh_alpha(i,lev,6)+sigsqh_alpha(i,lev,8))/2.
-      sigma_alpha(i, lev, 1) = sqrt(sigsqh_alpha(i,lev,1)+sigsqh_alpha(i,lev, &
-        5)+sum_even)
-      sigma_alpha(i, lev, 2) = sqrt(sigsqh_alpha(i,lev,2)+sigsqh_alpha(i,lev, &
-        6)+sum_odd)
-      sigma_alpha(i, lev, 3) = sqrt(sigsqh_alpha(i,lev,3)+sigsqh_alpha(i,lev, &
-        7)+sum_even)
-      sigma_alpha(i, lev, 4) = sqrt(sigsqh_alpha(i,lev,4)+sigsqh_alpha(i,lev, &
-        8)+sum_odd)
-      sigma_alpha(i, lev, 5) = sigma_alpha(i, lev, 1)
-      sigma_alpha(i, lev, 6) = sigma_alpha(i, lev, 2)
-      sigma_alpha(i, lev, 7) = sigma_alpha(i, lev, 3)
-      sigma_alpha(i, lev, 8) = sigma_alpha(i, lev, 4)
-    END DO
-  END IF
-
-  ! Calculate total rms velocity.
-
-  DO i = il1, il2
-    sigma_t(i, lev) = 0.
-  END DO
-  DO n = 1, naz
-    DO i = il1, il2
-      sigma_t(i, lev) = sigma_t(i, lev) + sigsqh_alpha(i, lev, n)
-    END DO
-  END DO
-  DO i = il1, il2
-    sigma_t(i, lev) = sqrt(sigma_t(i,lev))
-  END DO
-
-  RETURN
-  ! -----------------------------------------------------------------------
-END SUBROUTINE hines_sigma
-
-SUBROUTINE hines_intgrl(i_alpha, v_alpha, m_alpha, bvfb, slope, naz, lev, &
-    il1, il2, nlons, nlevs, nazmth, lorms)
-  IMPLICIT NONE
-  ! This routine calculates the vertical wavenumber integral
-  ! for a single vertical level at each azimuth on a longitude grid
-  ! for the Hines' Doppler spread GWD parameterization scheme.
-  ! NOTE: (1) only spectral slopes of 1, 1.5 or 2 are permitted.
-  ! (2) the integral is written in terms of the product QM
-  ! which by construction is always less than 1. Series
-  ! solutions are used for small |QM| and analytical solutions
-  ! for remaining values.
-
-  ! Aug. 8/95 - C. McLandress
-
-  ! Output arguement:
-
-  ! * I_ALPHA = Hines' integral.
-
-  ! Input arguements:
-
-  ! * V_ALPHA = azimuthal wind component (m/s).
-  ! * M_ALPHA = azimuthal cutoff vertical wavenumber (1/m).
-  ! * BVFB    = background Brunt Vassala frequency at model bottom.
-  ! * SLOPE   = slope of initial vertical wavenumber spectrum
-  ! *           (must use SLOPE = 1., 1.5 or 2.)
-  ! * NAZ     = actual number of horizontal azimuths used.
-  ! * LEV     = altitude level to process.
-  ! * IL1     = first longitudinal index to use (IL1 >= 1).
-  ! * IL2     = last longitudinal index to use (IL1 <= IL2 <= NLONS).
-  ! * NLONS   = number of longitudes.
-  ! * NLEVS   = number of vertical levels.
-  ! * NAZMTH  = azimuthal array dimension (NAZMTH >= NAZ).
-
-  ! * LORMS       = .TRUE. for drag computation
-
-  ! Constants in DATA statements:
-
-  ! * QMIN = minimum value of Q_ALPHA (avoids indeterminant form of integral)
-  ! * QM_MIN = minimum value of Q_ALPHA * M_ALPHA (used to avoid numerical
-  ! *          problems).
-
-  INTEGER lev, naz, il1, il2, nlons, nlevs, nazmth
-  REAL i_alpha(nlons, nazmth)
-  REAL v_alpha(nlons, nlevs, nazmth)
-  REAL m_alpha(nlons, nlevs, nazmth)
-  REAL bvfb(nlons), slope
-
-  LOGICAL lorms(nlons)
-
-  ! Internal variables.
-
-  INTEGER i, n
-  REAL q_alpha, qm, sqrtqm, q_min, qm_min
-
-  DATA q_min/1.0/, qm_min/0.01/
-  ! -----------------------------------------------------------------------
-
-  ! For integer value SLOPE = 1.
-
-  IF (slope==1.) THEN
-
-    DO n = 1, naz
-      DO i = il1, il2
-        IF (lorms(i)) THEN
-
-          q_alpha = v_alpha(i, lev, n)/bvfb(i)
-          qm = q_alpha*m_alpha(i, lev, n)
-
-          ! If |QM| is small then use first 4 terms series of Taylor series
-          ! expansion of integral in order to avoid indeterminate form of
-          ! integral,
-          ! otherwise use analytical form of integral.
-
-          IF (abs(q_alpha)<q_min .OR. abs(qm)<qm_min) THEN
-            IF (q_alpha==0.) THEN
-              i_alpha(i, n) = m_alpha(i, lev, n)**2/2.
-            ELSE
-              i_alpha(i, n) = (qm**2/2.+qm**3/3.+qm**4/4.+qm**5/5.)/ &
-                q_alpha**2
-            END IF
-          ELSE
-            i_alpha(i, n) = -(alog(1.-qm)+qm)/q_alpha**2
-          END IF
-
-        END IF
-      END DO
-    END DO
-
-  END IF
-
-  ! For integer value SLOPE = 2.
-
-  IF (slope==2.) THEN
-
-    DO n = 1, naz
-      DO i = il1, il2
-        IF (lorms(i)) THEN
-
-          q_alpha = v_alpha(i, lev, n)/bvfb(i)
-          qm = q_alpha*m_alpha(i, lev, n)
-
-          ! If |QM| is small then use first 4 terms series of Taylor series
-          ! expansion of integral in order to avoid indeterminate form of
-          ! integral,
-          ! otherwise use analytical form of integral.
-
-          IF (abs(q_alpha)<q_min .OR. abs(qm)<qm_min) THEN
-            IF (q_alpha==0.) THEN
-              i_alpha(i, n) = m_alpha(i, lev, n)**3/3.
-            ELSE
-              i_alpha(i, n) = (qm**3/3.+qm**4/4.+qm**5/5.+qm**6/6.)/ &
-                q_alpha**3
-            END IF
-          ELSE
-            i_alpha(i, n) = -(alog(1.-qm)+qm+qm**2/2.)/q_alpha**3
-          END IF
-
-        END IF
-      END DO
-    END DO
-
-  END IF
-
-  ! For real value SLOPE = 1.5
-
-  IF (slope==1.5) THEN
-
-    DO n = 1, naz
-      DO i = il1, il2
-        IF (lorms(i)) THEN
-
-          q_alpha = v_alpha(i, lev, n)/bvfb(i)
-          qm = q_alpha*m_alpha(i, lev, n)
-
-          ! If |QM| is small then use first 4 terms series of Taylor series
-          ! expansion of integral in order to avoid indeterminate form of
-          ! integral,
-          ! otherwise use analytical form of integral.
-
-          IF (abs(q_alpha)<q_min .OR. abs(qm)<qm_min) THEN
-            IF (q_alpha==0.) THEN
-              i_alpha(i, n) = m_alpha(i, lev, n)**2.5/2.5
-            ELSE
-              i_alpha(i, n) = (qm/2.5+qm**2/3.5+qm**3/4.5+qm**4/5.5)* &
-                m_alpha(i, lev, n)**1.5/q_alpha
-            END IF
-          ELSE
-            qm = abs(qm)
-            sqrtqm = sqrt(qm)
-            IF (q_alpha>=0.) THEN
-              i_alpha(i, n) = (alog((1.+sqrtqm)/(1.-sqrtqm))-2.*sqrtqm*(1.+qm &
-                /3.))/q_alpha**2.5
-            ELSE
-              i_alpha(i, n) = 2.*(atan(sqrtqm)+sqrtqm*(qm/3.-1.))/ &
-                abs(q_alpha)**2.5
-            END IF
-          END IF
-
-        END IF
-      END DO
-    END DO
-
-  END IF
-
-  ! If integral is negative (which in principal should not happen) then
-  ! print a message and some info since execution will abort when calculating
-  ! the variances.
-
-  ! DO 80 N = 1,NAZ
-  ! DO 70 I = IL1,IL2
-  ! IF (I_ALPHA(I,N).LT.0.)  THEN
-  ! WRITE (6,*)
-  ! WRITE (6,*) '******************************'
-  ! WRITE (6,*) 'Hines integral I_ALPHA < 0 '
-  ! WRITE (6,*) '  longitude I=',I
-  ! WRITE (6,*) '  azimuth   N=',N
-  ! WRITE (6,*) '  level   LEV=',LEV
-  ! WRITE (6,*) '  I_ALPHA =',I_ALPHA(I,N)
-  ! WRITE (6,*) '  V_ALPHA =',V_ALPHA(I,LEV,N)
-  ! WRITE (6,*) '  M_ALPHA =',M_ALPHA(I,LEV,N)
-  ! WRITE (6,*) '  Q_ALPHA =',V_ALPHA(I,LEV,N) / BVFB(I)
-  ! WRITE (6,*) '  QM      =',V_ALPHA(I,LEV,N) / BVFB(I)
-  ! ^                                * M_ALPHA(I,LEV,N)
-  ! WRITE (6,*) '******************************'
-  ! END IF
-  ! 70     CONTINUE
-  ! 80   CONTINUE
-
-  RETURN
-  ! -----------------------------------------------------------------------
-END SUBROUTINE hines_intgrl
-
-SUBROUTINE hines_setup(naz, slope, f1, f2, f3, f5, f6, kstar, icutoff, &
-    alt_cutoff, smco, nsmax, iheatcal, k_alpha, ierror, nmessg, nlons, &
-    nazmth, coslat)
-  IMPLICIT NONE
-  ! This routine specifies various parameters needed for the
-  ! the Hines' Doppler spread gravity wave drag parameterization scheme.
-
-  ! Aug. 8/95 - C. McLandress
-
-  ! Output arguements:
-
-  ! * NAZ        = actual number of horizontal azimuths used
-  ! *              (code set up presently for only NAZ = 4 or 8).
-  ! * SLOPE      = slope of incident vertical wavenumber spectrum
-  ! *              (code set up presently for SLOPE 1., 1.5 or 2.).
-  ! * F1         = "fudge factor" used in calculation of trial value of
-  ! *              azimuthal cutoff wavenumber M_ALPHA (1.2 <= F1 <= 1.9).
-  ! * F2         = "fudge factor" used in calculation of maximum
-  ! *              permissible instabiliy-induced cutoff wavenumber
-  ! *              M_SUB_M_TURB (0.1 <= F2 <= 1.4).
-  ! * F3         = "fudge factor" used in calculation of maximum
-  ! *              permissible molecular viscosity-induced cutoff wavenumber
-  ! *              M_SUB_M_MOL (0.1 <= F2 <= 1.4).
-  ! * F5         = "fudge factor" used in calculation of heating rate
-  ! *              (1 <= F5 <= 3).
-  ! * F6         = "fudge factor" used in calculation of turbulent
-  ! *              diffusivity coefficient.
-  ! * KSTAR      = typical gravity wave horizontal wavenumber (1/m)
-  ! *              used in calculation of M_SUB_M_TURB.
-  ! * ICUTOFF    = 1 to exponentially damp off GWD, heating and diffusion
-  ! *              arrays above ALT_CUTOFF; otherwise arrays not modified.
-  ! * ALT_CUTOFF = altitude in meters above which exponential decay applied.
-  ! * SMCO       = smoother used to smooth cutoff vertical wavenumbers
-  ! *              and total rms winds before calculating drag or heating.
-  ! *              (==> a 1:SMCO:1 stencil used; SMCO >= 1.).
-  ! * NSMAX      = number of times smoother applied ( >= 1),
-  ! *            = 0 means no smoothing performed.
-  ! * IHEATCAL   = 1 to calculate heating rates and diffusion coefficient.
-  ! *            = 0 means only drag and flux calculated.
-  ! * K_ALPHA    = horizontal wavenumber of each azimuth (1/m) which
-  ! *              is set here to KSTAR.
-  ! * IERROR     = error flag.
-  ! *            = 0 no errors.
-  ! *            = 10 ==> NAZ > NAZMTH
-  ! *            = 20 ==> invalid number of azimuths (NAZ must be 4 or 8).
-  ! *            = 30 ==> invalid slope (SLOPE must be 1., 1.5 or 2.).
-  ! *            = 40 ==> invalid smoother (SMCO must be >= 1.)
-
-  ! Input arguements:
-
-  ! * NMESSG  = output unit number where messages to be printed.
-  ! * NLONS   = number of longitudes.
-  ! * NAZMTH  = azimuthal array dimension (NAZMTH >= NAZ).
-
-  INTEGER naz, nlons, nazmth, iheatcal, icutoff
-  INTEGER nmessg, nsmax, ierror
-  REAL kstar(nlons), slope, f1, f2, f3, f5, f6, alt_cutoff, smco
-  REAL k_alpha(nlons, nazmth), coslat(nlons)
-  REAL ksmin, ksmax
-
-  ! Internal variables.
-
-  INTEGER i, n
-  ! -----------------------------------------------------------------------
-
-  ! Specify constants.
-
-  naz = 8
-  slope = 1.
-  f1 = 1.5
-  f2 = 0.3
-  f3 = 1.0
-  f5 = 3.0
-  f6 = 1.0
-  ksmin = 1.E-5
-  ksmax = 1.E-4
-  DO i = 1, nlons
-    kstar(i) = ksmin/(coslat(i)+(ksmin/ksmax))
-  END DO
-  icutoff = 1
-  alt_cutoff = 105.E3
-  smco = 2.0
-  ! SMCO       = 1.0
-  nsmax = 5
-  ! NSMAX      = 2
-  iheatcal = 0
-
-  ! Print information to output file.
-
-  ! WRITE (NMESSG,6000)
-  ! 6000 FORMAT (/' Subroutine HINES_SETUP:')
-  ! WRITE (NMESSG,*)  '  SLOPE = ', SLOPE
-  ! WRITE (NMESSG,*)  '  NAZ = ', NAZ
-  ! WRITE (NMESSG,*)  '  F1,F2,F3  = ', F1, F2, F3
-  ! WRITE (NMESSG,*)  '  F5,F6     = ', F5, F6
-  ! WRITE (NMESSG,*)  '  KSTAR     = ', KSTAR
-  ! >           ,'  COSLAT     = ', COSLAT
-  ! IF (ICUTOFF .EQ. 1)  THEN
-  ! WRITE (NMESSG,*) '  Drag exponentially damped above ',
-  ! &                       ALT_CUTOFF/1.E3
-  ! END IF
-  ! IF (NSMAX.LT.1 )  THEN
-  ! WRITE (NMESSG,*) '  No smoothing of cutoff wavenumbers, etc'
-  ! ELSE
-  ! WRITE (NMESSG,*) '  Cutoff wavenumbers and sig_t smoothed:'
-  ! WRITE (NMESSG,*) '    SMCO  =', SMCO
-  ! WRITE (NMESSG,*) '    NSMAX =', NSMAX
-  ! END IF
-
-  ! Check that things are setup correctly and log error if not
-
-  ierror = 0
-  IF (naz>nazmth) ierror = 10
-  IF (naz/=4 .AND. naz/=8) ierror = 20
-  IF (slope/=1. .AND. slope/=1.5 .AND. slope/=2.) ierror = 30
-  IF (smco<1.) ierror = 40
-
-  ! Use single value for azimuthal-dependent horizontal wavenumber.
-
-  DO n = 1, naz
-    DO i = 1, nlons
-      k_alpha(i, n) = kstar(i)
-    END DO
-  END DO
-
-  RETURN
-  ! -----------------------------------------------------------------------
-END SUBROUTINE hines_setup
-
-SUBROUTINE hines_print(flux_u, flux_v, drag_u, drag_v, alt, sigma_t, &
-    sigma_alpha, v_alpha, m_alpha, iu_print, iv_print, nmessg, ilprt1, &
-    ilprt2, levprt1, levprt2, naz, nlons, nlevs, nazmth)
-  IMPLICIT NONE
-  ! Print out altitude profiles of various quantities from
-  ! Hines' Doppler spread gravity wave drag parameterization scheme.
-  ! (NOTE: only for NAZ = 4 or 8).
-
-  ! Aug. 8/95 - C. McLandress
-
-  ! Input arguements:
-
-  ! * IU_PRINT = 1 to print out values in east-west direction.
-  ! * IV_PRINT = 1 to print out values in north-south direction.
-  ! * NMESSG   = unit number for printed output.
-  ! * ILPRT1   = first longitudinal index to print.
-  ! * ILPRT2   = last longitudinal index to print.
-  ! * LEVPRT1  = first altitude level to print.
-  ! * LEVPRT2  = last altitude level to print.
-
-  INTEGER naz, ilprt1, ilprt2, levprt1, levprt2
-  INTEGER nlons, nlevs, nazmth
-  INTEGER iu_print, iv_print, nmessg
-  REAL flux_u(nlons, nlevs), flux_v(nlons, nlevs)
-  REAL drag_u(nlons, nlevs), drag_v(nlons, nlevs)
-  REAL alt(nlons, nlevs), sigma_t(nlons, nlevs)
-  REAL sigma_alpha(nlons, nlevs, nazmth)
-  REAL v_alpha(nlons, nlevs, nazmth), m_alpha(nlons, nlevs, nazmth)
-
-  ! Internal variables.
-
-  INTEGER n_east, n_west, n_north, n_south
-  INTEGER i, l
-  ! -----------------------------------------------------------------------
-
-  ! Azimuthal indices of cardinal directions.
-
-  n_east = 1
-  IF (naz==4) THEN
-    n_west = 3
-    n_north = 2
-    n_south = 4
-  ELSE IF (naz==8) THEN
-    n_west = 5
-    n_north = 3
-    n_south = 7
-  END IF
-
-  ! Print out values for range of longitudes.
-
-  DO i = ilprt1, ilprt2
-
-    ! Print east-west wind, sigmas, cutoff wavenumbers, flux and drag.
-
-    IF (iu_print==1) THEN
-      WRITE (nmessg, *)
-      WRITE (nmessg, 6001) i
-      WRITE (nmessg, 6005)
-6001  FORMAT ('Hines GW (east-west) at longitude I =', I3)
-6005  FORMAT (15X, ' U ', 2X, 'sig_E', 2X, 'sig_T', 3X, 'm_E', 4X, 'm_W', 4X, &
-        'fluxU', 5X, 'gwdU')
-      DO l = levprt1, levprt2
-        WRITE (nmessg, 6701) alt(i, l)/1.E3, v_alpha(i, l, n_east), &
-          sigma_alpha(i, l, n_east), sigma_t(i, l), &
-          m_alpha(i, l, n_east)*1.E3, m_alpha(i, l, n_west)*1.E3, &
-          flux_u(i, l)*1.E5, drag_u(i, l)*24.*3600.
-      END DO
-6701  FORMAT (' z=', F7.2, 1X, 3F7.1, 2F7.3, F9.4, F9.3)
-    END IF
-
-    ! Print north-south winds, sigmas, cutoff wavenumbers, flux and drag.
-
-    IF (iv_print==1) THEN
-      WRITE (nmessg, *)
-      WRITE (nmessg, 6002) i
-6002  FORMAT ('Hines GW (north-south) at longitude I =', I3)
-      WRITE (nmessg, 6006)
-6006  FORMAT (15X, ' V ', 2X, 'sig_N', 2X, 'sig_T', 3X, 'm_N', 4X, 'm_S', 4X, &
-        'fluxV', 5X, 'gwdV')
-      DO l = levprt1, levprt2
-        WRITE (nmessg, 6701) alt(i, l)/1.E3, v_alpha(i, l, n_north), &
-          sigma_alpha(i, l, n_north), sigma_t(i, l), &
-          m_alpha(i, l, n_north)*1.E3, m_alpha(i, l, n_south)*1.E3, &
-          flux_v(i, l)*1.E5, drag_v(i, l)*24.*3600.
-      END DO
-    END IF
-
-  END DO
-
-  RETURN
-  ! -----------------------------------------------------------------------
-END SUBROUTINE hines_print
-
-SUBROUTINE hines_exp(data, data_zmax, alt, alt_exp, iorder, il1, il2, lev1, &
-    lev2, nlons, nlevs)
-  IMPLICIT NONE
-  ! This routine exponentially damps a longitude by altitude array
-  ! of data above a specified altitude.
-
-  ! Aug. 13/95 - C. McLandress
-
-  ! Output arguements:
-
-  ! * DATA = modified data array.
-
-  ! Input arguements:
-
-  ! * DATA    = original data array.
-  ! * ALT     = altitudes.
-  ! * ALT_EXP = altitude above which exponential decay applied.
-  ! * IORDER	= 1 means vertical levels are indexed from top down
-  ! *           (i.e., highest level indexed 1 and lowest level NLEVS);
-  ! *           .NE. 1 highest level is index NLEVS.
-  ! * IL1     = first longitudinal index to use (IL1 >= 1).
-  ! * IL2     = last longitudinal index to use (IL1 <= IL2 <= NLONS).
-  ! * LEV1    = first altitude level to use (LEV1 >=1).
-  ! * LEV2    = last altitude level to use (LEV1 < LEV2 <= NLEVS).
-  ! * NLONS   = number of longitudes.
-  ! * NLEVS   = number of vertical
-
-  ! Input work arrays:
-
-  ! * DATA_ZMAX = data values just above altitude ALT_EXP.
-
-  INTEGER iorder, il1, il2, lev1, lev2, nlons, nlevs
-  REAL alt_exp
-  REAL data(nlons, nlevs), data_zmax(nlons), alt(nlons, nlevs)
-
-  ! Internal variables.
-
-  INTEGER levbot, levtop, lincr, i, l
-  REAL hscale
-  DATA hscale/5.E3/
-  ! -----------------------------------------------------------------------
-
-  ! Index of lowest altitude level (bottom of drag calculation).
-
-  levbot = lev2
-  levtop = lev1
-  lincr = 1
-  IF (iorder/=1) THEN
-    levbot = lev1
-    levtop = lev2
-    lincr = -1
-  END IF
-
-  ! Data values at first level above ALT_EXP.
-
-  DO i = il1, il2
-    DO l = levtop, levbot, lincr
-      IF (alt(i,l)>=alt_exp) THEN
-        data_zmax(i) = data(i, l)
-      END IF
-    END DO
-  END DO
-
-  ! Exponentially damp field above ALT_EXP to model top at L=1.
-
-  DO l = 1, lev2
-    DO i = il1, il2
-      IF (alt(i,l)>=alt_exp) THEN
-        data(i, l) = data_zmax(i)*exp((alt_exp-alt(i,l))/hscale)
-      END IF
-    END DO
-  END DO
-
-  RETURN
-  ! -----------------------------------------------------------------------
-END SUBROUTINE hines_exp
-
-SUBROUTINE vert_smooth(data, work, coeff, nsmooth, il1, il2, lev1, lev2, &
-    nlons, nlevs)
-  IMPLICIT NONE
-  ! Smooth a longitude by altitude array in the vertical over a
-  ! specified number of levels using a three point smoother.
-
-  ! NOTE: input array DATA is modified on output!
-
-  ! Aug. 3/95 - C. McLandress
-
-  ! Output arguement:
-
-  ! * DATA    = smoothed array (on output).
-
-  ! Input arguements:
-
-  ! * DATA    = unsmoothed array of data (on input).
-  ! * WORK    = work array of same dimension as DATA.
-  ! * COEFF   = smoothing coefficient for a 1:COEFF:1 stencil.
-  ! *           (e.g., COEFF = 2 will result in a smoother which
-  ! *           weights the level L gridpoint by two and the two
-  ! *           adjecent levels (L+1 and L-1) by one).
-  ! * NSMOOTH = number of times to smooth in vertical.
-  ! *           (e.g., NSMOOTH=1 means smoothed only once,
-  ! *           NSMOOTH=2 means smoothing repeated twice, etc.)
-  ! * IL1     = first longitudinal index to use (IL1 >= 1).
-  ! * IL2     = last longitudinal index to use (IL1 <= IL2 <= NLONS).
-  ! * LEV1    = first altitude level to use (LEV1 >=1).
-  ! * LEV2    = last altitude level to use (LEV1 < LEV2 <= NLEVS).
-  ! * NLONS   = number of longitudes.
-  ! * NLEVS   = number of vertical levels.
-
-  ! Subroutine arguements.
-
-  INTEGER nsmooth, il1, il2, lev1, lev2, nlons, nlevs
-  REAL coeff
-  REAL data(nlons, nlevs), work(nlons, nlevs)
-
-  ! Internal variables.
-
-  INTEGER i, l, ns, lev1p, lev2m
-  REAL sum_wts
-  ! -----------------------------------------------------------------------
-
-  ! Calculate sum of weights.
-
-  sum_wts = coeff + 2.
-
-  lev1p = lev1 + 1
-  lev2m = lev2 - 1
-
-  ! Smooth NSMOOTH times
-
-  DO ns = 1, nsmooth
-
-    ! Copy data into work array.
-
-    DO l = lev1, lev2
-      DO i = il1, il2
-        work(i, l) = data(i, l)
-      END DO
-    END DO
-
-    ! Smooth array WORK in vertical direction and put into DATA.
-
-    DO l = lev1p, lev2m
-      DO i = il1, il2
-        data(i, l) = (work(i,l+1)+coeff*work(i,l)+work(i,l-1))/sum_wts
-      END DO
-    END DO
-
-  END DO
-
-  RETURN
-  ! -----------------------------------------------------------------------
-END SUBROUTINE vert_smooth
-
-
-
-
-
-
Index: /LMDZ6/trunk/libf/phylmd/hines_gwd.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/hines_gwd.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/hines_gwd.f90	(revision 5268)
@@ -0,0 +1,2019 @@
+
+! $Id$
+
+SUBROUTINE hines_gwd(nlon, nlev, dtime, paphm1x, papm1x, rlat, tx, ux, vx, &
+    zustrhi, zvstrhi, d_t_hin, d_u_hin, d_v_hin)
+
+  ! ########################################################################
+  ! Parametrization of the momentum flux deposition due to a broad band
+  ! spectrum of gravity waves, following Hines (1997a,b), as coded by
+  ! McLANDRESS (1995). Modified by McFARLANE and MANZINI (1995-1997)
+  ! MAECHAM model stand alone version
+  ! ########################################################################
+
+
+  USE dimphy
+  IMPLICIT NONE
+
+  include "YOEGWD.h"
+  include "YOMCST.h"
+
+  INTEGER nazmth
+  PARAMETER (nazmth=8)
+
+  ! INPUT ARGUMENTS.
+  ! ----- ----------
+
+  ! - 2D
+  ! PAPHM1   : HALF LEVEL PRESSURE (T-DT)
+  ! PAPM1    : FULL LEVEL PRESSURE (T-DT)
+  ! PTM1     : TEMPERATURE (T-DT)
+  ! PUM1     : ZONAL WIND (T-DT)
+  ! PVM1     : MERIDIONAL WIND (T-DT)
+
+
+  ! REFERENCE.
+  ! ----------
+  ! SEE MODEL DOCUMENTATION
+
+  ! AUTHOR.
+  ! -------
+
+  ! N. MCFARLANE   DKRZ-HAMBURG   MAY 1995
+  ! STAND ALONE E. MANZINI MPI-HAMBURG FEBRUARY 1997
+
+  ! BASED ON A COMBINATION OF THE OROGRAPHIC SCHEME BY N.MCFARLANE 1987
+  ! AND THE HINES SCHEME AS CODED BY C. MCLANDRESS 1995.
+
+
+
+  ! ym      INTEGER KLEVM1
+
+  REAL paphm1(klon, klev+1), papm1(klon, klev)
+  REAL ptm1(klon, klev), pum1(klon, klev), pvm1(klon, klev)
+  REAL prflux(klon)
+  ! 1
+  ! 1
+  ! 1
+  REAL rlat(klon), coslat(klon)
+
+  REAL th(klon, klev), utendgw(klon, klev), vtendgw(klon, klev), &
+    pressg(klon), uhs(klon, klev), vhs(klon, klev), zpr(klon)
+
+  ! * VERTICAL POSITIONING ARRAYS.
+
+  REAL sgj(klon, klev), shj(klon, klev), shxkj(klon, klev), dsgj(klon, klev)
+
+  ! * LOGICAL SWITCHES TO CONTROL ROOF DRAG, ENVELOP GW DRAG AND
+  ! * HINES' DOPPLER SPREADING EXTROWAVE GW DRAG.
+  ! * LOZPR IS TRUE FOR ZPR ENHANCEMENT
+
+
+  ! * WORK ARRAYS.
+
+  REAL m_alpha(klon, klev, nazmth), v_alpha(klon, klev, nazmth), &
+    sigma_alpha(klon, klev, nazmth), sigsqh_alpha(klon, klev, nazmth), &
+    drag_u(klon, klev), drag_v(klon, klev), flux_u(klon, klev), &
+    flux_v(klon, klev), heat(klon, klev), diffco(klon, klev), &
+    bvfreq(klon, klev), density(klon, klev), sigma_t(klon, klev), &
+    visc_mol(klon, klev), alt(klon, klev), sigsqmcw(klon, klev, nazmth), &
+    sigmatm(klon, klev), ak_alpha(klon, nazmth), k_alpha(klon, nazmth), &
+    mmin_alpha(klon, nazmth), i_alpha(klon, nazmth), rmswind(klon), &
+    bvfbot(klon), densbot(klon)
+  REAL smoothr1(klon, klev), smoothr2(klon, klev)
+  REAL sigalpmc(klon, klev, nazmth)
+  REAL f2mod(klon, klev)
+
+  ! * THES ARE THE INPUT PARAMETERS FOR HINES ROUTINE AND
+  ! * ARE SPECIFIED IN ROUTINE HINES_SETUP. SINCE THIS IS CALLED
+  ! * ONLY AT FIRST CALL TO THIS ROUTINE THESE VARIABLES MUST BE SAVED
+  ! * FOR USE AT SUBSEQUENT CALLS. THIS CAN BE AVOIDED BY CALLING
+  ! * HINES_SETUP IN MAIN PROGRAM AND PASSING THE PARAMETERS AS
+  ! * SUBROUTINE ARGUEMENTS.
+
+
+  REAL rmscon
+  INTEGER nmessg, iprint, ilrms
+  INTEGER ifl
+
+  INTEGER naz, icutoff, nsmax, iheatcal
+  REAL slope, f1, f2, f3, f5, f6, kstar(klon), alt_cutoff, smco
+
+  ! PROVIDED AS INPUT
+
+  INTEGER nlon, nlev
+
+  REAL dtime
+  REAL paphm1x(nlon, nlev+1), papm1x(nlon, nlev)
+  REAL ux(nlon, nlev), vx(nlon, nlev), tx(nlon, nlev)
+
+  ! VARIABLES FOR OUTPUT
+
+
+  REAL d_t_hin(nlon, nlev), d_u_hin(nlon, nlev), d_v_hin(nlon, nlev)
+  REAL zustrhi(nlon), zvstrhi(nlon)
+
+
+  ! * LOGICAL SWITCHES TO CONTROL PRECIP ENHANCEMENT AND
+  ! * HINES' DOPPLER SPREADING EXTROWAVE GW DRAG.
+  ! * LOZPR IS TRUE FOR ZPR ENHANCEMENT
+
+  LOGICAL lozpr, lorms(klon)
+
+  ! LOCAL PARAMETERS TO MAKE THINGS WORK (TEMPORARY VARIABLE)
+
+  REAL rhoh2o, zpcons, rgocp, zlat, dttdsf, ratio, hscal
+  INTEGER i, j, l, jl, jk, le, lref, lrefp, levbot
+
+  ! DATA PARAMETERS NEEDED, EXPLAINED LATER
+
+  REAL v0, vmin, dmpscal, taufac, hmin, apibt, cpart, fcrit
+  REAL pcrit, pcons
+  INTEGER iplev, ierror
+
+
+
+  ! PRINT *,' IT IS STARTED HINES GOING ON...'
+
+
+
+
+  ! *    COMPUTATIONAL CONSTANTS.
+  ! ------------- ----------
+
+
+  d_t_hin(:, :) = 0.
+
+  rhoh2o = 1000.
+  zpcons = (1000.*86400.)/rhoh2o
+  ! ym      KLEVM1=KLEV-1
+
+
+  DO jl = kidia, kfdia
+    paphm1(jl, 1) = paphm1x(jl, klev+1)
+    DO jk = 1, klev
+      le = klev + 1 - jk
+      paphm1(jl, jk+1) = paphm1x(jl, le)
+      papm1(jl, jk) = papm1x(jl, le)
+      ptm1(jl, jk) = tx(jl, le)
+      pum1(jl, jk) = ux(jl, le)
+      pvm1(jl, jk) = vx(jl, le)
+    END DO
+  END DO
+
+  ! Define constants and arrays needed for the ccc/mam gwd scheme
+  ! *Constants:
+
+  rgocp = rd/rcpd
+  lrefp = klev - 1
+  lref = klev - 2
+  ! 1
+  ! 1    *Arrays
+  ! 1
+  DO jk = 1, klev
+    DO jl = kidia, kfdia
+      shj(jl, jk) = papm1(jl, jk)/paphm1(jl, klev+1)
+      sgj(jl, jk) = papm1(jl, jk)/paphm1(jl, klev+1)
+      dsgj(jl, jk) = (paphm1(jl,jk+1)-paphm1(jl,jk))/paphm1(jl, klev+1)
+      shxkj(jl, jk) = (papm1(jl,jk)/paphm1(jl,klev+1))**rgocp
+      th(jl, jk) = ptm1(jl, jk)
+    END DO
+  END DO
+
+  ! C
+  DO jl = kidia, kfdia
+    pressg(jl) = paphm1(jl, klev+1)
+  END DO
+
+
+  DO jl = kidia, kfdia
+    prflux(jl) = 0.0
+    zpr(jl) = zpcons*prflux(jl)
+    zlat = (rlat(jl)/180.)*rpi
+    coslat(jl) = cos(zlat)
+  END DO
+
+  ! /#########################################################################
+  ! /
+  ! /
+
+  ! * AUG. 14/95 - C. MCLANDRESS.
+  ! * SEP.    95   N. MCFARLANE.
+
+  ! * THIS ROUTINE CALCULATES THE HORIZONTAL WIND TENDENCIES
+  ! * DUE TO MCFARLANE'S OROGRAPHIC GW DRAG SCHEME, HINES'
+  ! * DOPPLER SPREAD SCHEME FOR "EXTROWAVES" AND ADDS ON
+  ! * ROOF DRAG. IT IS BASED ON THE ROUTINE GWDFLX8.
+
+  ! * LREFP IS THE INDEX OF THE MODEL LEVEL BELOW THE REFERENCE LEVEL
+  ! * I/O ARRAYS PASSED FROM MAIN.
+  ! * (PRESSG = SURFACE PRESSURE)
+
+
+
+
+  ! * CONSTANTS VALUES DEFINED IN DATA STATEMENT ARE :
+  ! * VMIN     = MIMINUM WIND IN THE DIRECTION OF REFERENCE LEVEL
+  ! *            WIND BEFORE WE CONSIDER BREAKING TO HAVE OCCURED.
+  ! * DMPSCAL  = DAMPING TIME FOR GW DRAG IN SECONDS.
+  ! * TAUFAC   = 1/(LENGTH SCALE).
+  ! * HMIN     = MIMINUM ENVELOPE HEIGHT REQUIRED TO PRODUCE GW DRAG.
+  ! * V0       = VALUE OF WIND THAT APPROXIMATES ZERO.
+
+
+  DATA vmin/5.0/, v0/1.E-10/, taufac/5.E-6/, hmin/40000./, dmpscal/6.5E+6/, &
+    apibt/1.5708/, cpart/0.7/, fcrit/1./
+
+  ! * HINES EXTROWAVE GWD CONSTANTS DEFINED IN DATA STATEMENT ARE:
+  ! * RMSCON = ROOT MEAN SQUARE GRAVITY WAVE WIND AT LOWEST LEVEL (M/S).
+  ! * NMESSG  = UNIT NUMBER FOR PRINTED MESSAGES.
+  ! * IPRINT  = 1 TO DO PRINT OUT SOME HINES ARRAYS.
+  ! * IFL     = FIRST CALL FLAG TO HINES_SETUP ("SAVE" IT)
+  ! * PCRIT = CRITICAL VALUE OF ZPR (MM/D)
+  ! * IPLEV = LEVEL OF APPLICATION OF PRCIT
+  ! * PCONS = FACTOR OF ZPR ENHANCEMENT
+
+
+  DATA pcrit/5./, pcons/4.75/
+
+  iplev = lrefp - 1
+
+  DATA rmscon/1.00/iprint/2/, nmessg/6/
+  DATA ifl/0/
+
+  lozpr = .FALSE.
+
+  ! -----------------------------------------------------------------------
+
+
+
+  ! * SET ERROR FLAG
+
+  ierror = 0
+
+  ! * SPECIFY VARIOUS PARAMETERS FOR HINES ROUTINE AT VERY FIRST CALL.
+  ! * (NOTE THAT ARRAY K_ALPHA IS SPECIFIED SO MAKE SURE THAT
+  ! * IT IS NOT OVERWRITTEN LATER ON).
+
+  CALL hines_setup(naz, slope, f1, f2, f3, f5, f6, kstar, icutoff, &
+    alt_cutoff, smco, nsmax, iheatcal, k_alpha, ierror, nmessg, klon, nazmth, &
+    coslat)
+  IF (ierror/=0) GO TO 999
+
+  ! * START GWD CALCULATIONS.
+
+  lref = lrefp - 1
+
+
+  DO j = 1, nazmth
+    DO l = 1, klev
+      DO i = kidia, klon
+        sigsqmcw(i, l, j) = 0.
+      END DO
+    END DO
+  END DO
+
+
+
+  ! * INITIALIZE NECESSARY ARRAYS.
+
+  DO l = 1, klev
+    DO i = kidia, kfdia
+      utendgw(i, l) = 0.
+      vtendgw(i, l) = 0.
+
+      uhs(i, l) = 0.
+      vhs(i, l) = 0.
+
+    END DO
+  END DO
+
+  ! * IF USING HINES SCHEME THEN CALCULATE B V FREQUENCY AT ALL POINTS
+  ! * AND SMOOTH BVFREQ.
+
+  DO l = 2, klev
+    DO i = kidia, kfdia
+      dttdsf = (th(i,l)/shxkj(i,l)-th(i,l-1)/shxkj(i,l-1))/ &
+        (shj(i,l)-shj(i,l-1))
+      dttdsf = min(dttdsf, -5./sgj(i,l))
+      bvfreq(i, l) = sqrt(-dttdsf*sgj(i,l)*(sgj(i,l)**rgocp)/rd)*rg/ptm1(i, l &
+        )
+    END DO
+  END DO
+  DO l = 1, klev
+    DO i = kidia, kfdia
+      IF (l==1) THEN
+        bvfreq(i, l) = bvfreq(i, l+1)
+      END IF
+      IF (l>1) THEN
+        ratio = 5.*log(sgj(i,l)/sgj(i,l-1))
+        bvfreq(i, l) = (bvfreq(i,l-1)+ratio*bvfreq(i,l))/(1.+ratio)
+      END IF
+    END DO
+  END DO
+
+  ! * CALCULATE GW DRAG DUE TO HINES' EXTROWAVES
+  ! * SET MOLECULAR VISCOSITY TO A VERY SMALL VALUE.
+  ! * IF THE MODEL TOP IS GREATER THAN 100 KM THEN THE ACTUAL
+  ! * VISCOSITY COEFFICIENT COULD BE SPECIFIED HERE.
+
+  DO l = 1, klev
+    DO i = kidia, kfdia
+      visc_mol(i, l) = 1.5E-5
+      drag_u(i, l) = 0.
+      drag_v(i, l) = 0.
+      flux_u(i, l) = 0.
+      flux_v(i, l) = 0.
+      heat(i, l) = 0.
+      diffco(i, l) = 0.
+    END DO
+  END DO
+
+  ! * ALTITUDE AND DENSITY AT BOTTOM.
+
+  DO i = kidia, kfdia
+    hscal = rd*ptm1(i, klev)/rg
+    density(i, klev) = sgj(i, klev)*pressg(i)/(rg*hscal)
+    alt(i, klev) = 0.
+  END DO
+
+  ! * ALTITUDE AND DENSITY AT REMAINING LEVELS.
+
+  DO l = klev - 1, 1, -1
+    DO i = kidia, kfdia
+      hscal = rd*ptm1(i, l)/rg
+      alt(i, l) = alt(i, l+1) + hscal*dsgj(i, l)/sgj(i, l)
+      density(i, l) = sgj(i, l)*pressg(i)/(rg*hscal)
+    END DO
+  END DO
+
+
+  ! * INITIALIZE SWITCHES FOR HINES GWD CALCULATION
+
+  ilrms = 0
+
+  DO i = kidia, kfdia
+    lorms(i) = .FALSE.
+  END DO
+
+
+  ! * DEFILE BOTTOM LAUNCH LEVEL
+
+  levbot = iplev
+
+  ! * BACKGROUND WIND MINUS VALUE AT BOTTOM LAUNCH LEVEL.
+
+  DO l = 1, levbot
+    DO i = kidia, kfdia
+      uhs(i, l) = pum1(i, l) - pum1(i, levbot)
+      vhs(i, l) = pvm1(i, l) - pvm1(i, levbot)
+    END DO
+  END DO
+
+  ! * SPECIFY ROOT MEAN SQUARE WIND AT BOTTOM LAUNCH LEVEL.
+
+  DO i = kidia, kfdia
+    rmswind(i) = rmscon
+  END DO
+
+  IF (lozpr) THEN
+    DO i = kidia, kfdia
+      IF (zpr(i)>pcrit) THEN
+        rmswind(i) = rmscon + ((zpr(i)-pcrit)/zpr(i))*pcons
+      END IF
+    END DO
+  END IF
+
+  DO i = kidia, kfdia
+    IF (rmswind(i)>0.0) THEN
+      ilrms = ilrms + 1
+      lorms(i) = .TRUE.
+    END IF
+  END DO
+
+  ! * CALCULATE GWD (NOTE THAT DIFFUSION COEFFICIENT AND
+  ! * HEATING RATE ONLY CALCULATED IF IHEATCAL = 1).
+
+  IF (ilrms>0) THEN
+
+    CALL hines_extro0(drag_u, drag_v, heat, diffco, flux_u, flux_v, uhs, vhs, &
+      bvfreq, density, visc_mol, alt, rmswind, k_alpha, m_alpha, v_alpha, &
+      sigma_alpha, sigsqh_alpha, ak_alpha, mmin_alpha, i_alpha, sigma_t, &
+      densbot, bvfbot, 1, iheatcal, icutoff, iprint, nsmax, smco, alt_cutoff, &
+      kstar, slope, f1, f2, f3, f5, f6, naz, sigsqmcw, sigmatm, kidia, klon, &
+      1, levbot, klon, klev, nazmth, lorms, smoothr1, smoothr2, sigalpmc, &
+      f2mod)
+
+    ! * ADD ON HINES' GWD TENDENCIES TO OROGRAPHIC TENDENCIES AND
+    ! * APPLY HINES' GW DRAG ON (UROW,VROW) WORK ARRAYS.
+
+    DO l = 1, klev
+      DO i = kidia, kfdia
+        utendgw(i, l) = utendgw(i, l) + drag_u(i, l)
+        vtendgw(i, l) = vtendgw(i, l) + drag_v(i, l)
+      END DO
+    END DO
+
+
+    ! * END OF HINES CALCULATIONS.
+
+  END IF
+
+  ! -----------------------------------------------------------------------
+
+  DO jl = kidia, kfdia
+    zustrhi(jl) = flux_u(jl, 1)
+    zvstrhi(jl) = flux_v(jl, 1)
+    DO jk = 1, klev
+      le = klev - jk + 1
+      d_u_hin(jl, jk) = utendgw(jl, le)*dtime
+      d_v_hin(jl, jk) = vtendgw(jl, le)*dtime
+    END DO
+  END DO
+
+  ! PRINT *,'UTENDGW:',UTENDGW
+
+  ! PRINT *,' HINES HAS BEEN COMPLETED (LONG ISNT IT...)'
+
+  RETURN
+999 CONTINUE
+
+  ! * IF ERROR DETECTED THEN ABORT.
+
+  WRITE (nmessg, 6000)
+  WRITE (nmessg, 6010) ierror
+6000 FORMAT (/' EXECUTION ABORTED IN GWDOREXV')
+6010 FORMAT ('     ERROR FLAG =', I4)
+
+
+  RETURN
+END SUBROUTINE hines_gwd
+! /
+! /
+
+
+SUBROUTINE hines_extro0(drag_u, drag_v, heat, diffco, flux_u, flux_v, vel_u, &
+    vel_v, bvfreq, density, visc_mol, alt, rmswind, k_alpha, m_alpha, &
+    v_alpha, sigma_alpha, sigsqh_alpha, ak_alpha, mmin_alpha, i_alpha, &
+    sigma_t, densb, bvfb, iorder, iheatcal, icutoff, iprint, nsmax, smco, &
+    alt_cutoff, kstar, slope, f1, f2, f3, f5, f6, naz, sigsqmcw, sigmatm, &
+    il1, il2, lev1, lev2, nlons, nlevs, nazmth, lorms, smoothr1, smoothr2, &
+    sigalpmc, f2mod)
+
+  IMPLICIT NONE
+
+  ! Main routine for Hines' "extrowave" gravity wave parameterization based
+  ! on Hines' Doppler spread theory. This routine calculates zonal
+  ! and meridional components of gravity wave drag, heating rates
+  ! and diffusion coefficient on a longitude by altitude grid.
+  ! No "mythical" lower boundary region calculation is made so it
+  ! is assumed that lowest level winds are weak (i.e, approximately zero).
+
+  ! Aug. 13/95 - C. McLandress
+  ! SEPT. /95  - N.McFarlane
+
+  ! Modifications:
+
+  ! Output arguements:
+
+  ! * DRAG_U = zonal component of gravity wave drag (m/s^2).
+  ! * DRAG_V = meridional component of gravity wave drag (m/s^2).
+  ! * HEAT   = gravity wave heating (K/sec).
+  ! * DIFFCO = diffusion coefficient (m^2/sec)
+  ! * FLUX_U = zonal component of vertical momentum flux (Pascals)
+  ! * FLUX_V = meridional component of vertical momentum flux (Pascals)
+
+  ! Input arguements:
+
+  ! * VEL_U      = background zonal wind component (m/s).
+  ! * VEL_V      = background meridional wind component (m/s).
+  ! * BVFREQ     = background Brunt Vassala frequency (radians/sec).
+  ! * DENSITY    = background density (kg/m^3)
+  ! * VISC_MOL   = molecular viscosity (m^2/s)
+  ! * ALT        = altitude of momentum, density, buoyancy levels (m)
+  ! *              (NOTE: levels ordered so that ALT(I,1) > ALT(I,2), etc.)
+  ! * RMSWIND   = root mean square gravity wave wind at lowest level (m/s).
+  ! * K_ALPHA    = horizontal wavenumber of each azimuth (1/m).
+  ! * IORDER	   = 1 means vertical levels are indexed from top down
+  ! *              (i.e., highest level indexed 1 and lowest level NLEVS);
+  ! *           .NE. 1 highest level is index NLEVS.
+  ! * IHEATCAL   = 1 to calculate heating rates and diffusion coefficient.
+  ! * IPRINT     = 1 to print out various arrays.
+  ! * ICUTOFF    = 1 to exponentially damp GWD, heating and diffusion
+  ! *              arrays above ALT_CUTOFF; otherwise arrays not modified.
+  ! * ALT_CUTOFF = altitude in meters above which exponential decay applied.
+  ! * SMCO       = smoothing factor used to smooth cutoff vertical
+  ! *              wavenumbers and total rms winds in vertical direction
+  ! *              before calculating drag or heating
+  ! *              (SMCO >= 1 ==> 1:SMCO:1 stencil used).
+  ! * NSMAX      = number of times smoother applied ( >= 1),
+  ! *            = 0 means no smoothing performed.
+  ! * KSTAR      = typical gravity wave horizontal wavenumber (1/m).
+  ! * SLOPE      = slope of incident vertical wavenumber spectrum
+  ! *              (SLOPE must equal 1., 1.5 or 2.).
+  ! * F1 to F6   = Hines's fudge factors (F4 not needed since used for
+  ! *              vertical flux of vertical momentum).
+  ! * NAZ        = actual number of horizontal azimuths used.
+  ! * IL1        = first longitudinal index to use (IL1 >= 1).
+  ! * IL2        = last longitudinal index to use (IL1 <= IL2 <= NLONS).
+  ! * LEV1       = index of first level for drag calculation.
+  ! * LEV2       = index of last level for drag calculation
+  ! *              (i.e., LEV1 < LEV2 <= NLEVS).
+  ! * NLONS      = number of longitudes.
+  ! * NLEVS      = number of vertical levels.
+  ! * NAZMTH     = azimuthal array dimension (NAZMTH >= NAZ).
+
+  ! Work arrays.
+
+  ! * M_ALPHA      = cutoff vertical wavenumber (1/m).
+  ! * V_ALPHA      = wind component at each azimuth (m/s) and if IHEATCAL=1
+  ! *                holds vertical derivative of cutoff wavenumber.
+  ! * SIGMA_ALPHA  = total rms wind in each azimuth (m/s).
+  ! * SIGSQH_ALPHA = portion of wind variance from waves having wave
+  ! *                normals in the alpha azimuth (m/s).
+  ! * SIGMA_T      = total rms horizontal wind (m/s).
+  ! * AK_ALPHA     = spectral amplitude factor at each azimuth
+  ! *                (i.e.,{AjKj}) in m^4/s^2.
+  ! * I_ALPHA      = Hines' integral.
+  ! * MMIN_ALPHA   = minimum value of cutoff wavenumber.
+  ! * DENSB        = background density at bottom level.
+  ! * BVFB         = buoyancy frequency at bottom level and
+  ! *                work array for ICUTOFF = 1.
+
+  ! * LORMS       = .TRUE. for drag computation
+
+  INTEGER naz, nlons, nlevs, nazmth, il1, il2, lev1, lev2
+  INTEGER icutoff, nsmax, iorder, iheatcal, iprint
+  REAL kstar(nlons), f1, f2, f3, f5, f6, slope
+  REAL alt_cutoff, smco
+  REAL drag_u(nlons, nlevs), drag_v(nlons, nlevs)
+  REAL heat(nlons, nlevs), diffco(nlons, nlevs)
+  REAL flux_u(nlons, nlevs), flux_v(nlons, nlevs)
+  REAL vel_u(nlons, nlevs), vel_v(nlons, nlevs)
+  REAL bvfreq(nlons, nlevs), density(nlons, nlevs)
+  REAL visc_mol(nlons, nlevs), alt(nlons, nlevs)
+  REAL rmswind(nlons), bvfb(nlons), densb(nlons)
+  REAL sigma_t(nlons, nlevs), sigsqmcw(nlons, nlevs, nazmth)
+  REAL sigma_alpha(nlons, nlevs, nazmth), sigmatm(nlons, nlevs)
+  REAL sigsqh_alpha(nlons, nlevs, nazmth)
+  REAL m_alpha(nlons, nlevs, nazmth), v_alpha(nlons, nlevs, nazmth)
+  REAL ak_alpha(nlons, nazmth), k_alpha(nlons, nazmth)
+  REAL mmin_alpha(nlons, nazmth), i_alpha(nlons, nazmth)
+  REAL smoothr1(nlons, nlevs), smoothr2(nlons, nlevs)
+  REAL sigalpmc(nlons, nlevs, nazmth)
+  REAL f2mod(nlons, nlevs)
+
+  LOGICAL lorms(nlons)
+
+  ! Internal variables.
+
+  INTEGER levbot, levtop, i, n, l, lev1p, lev2m
+  INTEGER ilprt1, ilprt2
+  ! -----------------------------------------------------------------------
+
+  ! PRINT *,' IN HINES_EXTRO0'
+  lev1p = lev1 + 1
+  lev2m = lev2 - 1
+
+  ! Index of lowest altitude level (bottom of drag calculation).
+
+  levbot = lev2
+  levtop = lev1
+  IF (iorder/=1) THEN
+    WRITE (6, 1)
+1   FORMAT (2X, ' error: IORDER NOT ONE! ')
+  END IF
+
+  ! Buoyancy and density at bottom level.
+
+  DO i = il1, il2
+    bvfb(i) = bvfreq(i, levbot)
+    densb(i) = density(i, levbot)
+  END DO
+
+  ! initialize some variables
+
+  DO n = 1, naz
+    DO l = lev1, lev2
+      DO i = il1, il2
+        m_alpha(i, l, n) = 0.0
+      END DO
+    END DO
+  END DO
+  DO l = lev1, lev2
+    DO i = il1, il2
+      sigma_t(i, l) = 0.0
+    END DO
+  END DO
+  DO n = 1, naz
+    DO i = il1, il2
+      i_alpha(i, n) = 0.0
+    END DO
+  END DO
+
+  ! Compute azimuthal wind components from zonal and meridional winds.
+
+  CALL hines_wind(v_alpha, vel_u, vel_v, naz, il1, il2, lev1, lev2, nlons, &
+    nlevs, nazmth)
+
+  ! Calculate cutoff vertical wavenumber and velocity variances.
+
+  CALL hines_wavnum(m_alpha, sigma_alpha, sigsqh_alpha, sigma_t, ak_alpha, &
+    v_alpha, visc_mol, density, densb, bvfreq, bvfb, rmswind, i_alpha, &
+    mmin_alpha, kstar, slope, f1, f2, f3, naz, levbot, levtop, il1, il2, &
+    nlons, nlevs, nazmth, sigsqmcw, sigmatm, lorms, sigalpmc, f2mod)
+  ! Smooth cutoff wavenumbers and total rms velocity in the vertical
+  ! direction NSMAX times, using FLUX_U as temporary work array.
+
+  IF (nsmax>0) THEN
+    DO n = 1, naz
+      DO l = lev1, lev2
+        DO i = il1, il2
+          smoothr1(i, l) = m_alpha(i, l, n)
+        END DO
+      END DO
+      CALL vert_smooth(smoothr1, smoothr2, smco, nsmax, il1, il2, lev1, lev2, &
+        nlons, nlevs)
+      DO l = lev1, lev2
+        DO i = il1, il2
+          m_alpha(i, l, n) = smoothr1(i, l)
+        END DO
+      END DO
+    END DO
+    CALL vert_smooth(sigma_t, smoothr2, smco, nsmax, il1, il2, lev1, lev2, &
+      nlons, nlevs)
+  END IF
+
+  ! Calculate zonal and meridional components of the
+  ! momentum flux and drag.
+
+  CALL hines_flux(flux_u, flux_v, drag_u, drag_v, alt, density, densb, &
+    m_alpha, ak_alpha, k_alpha, slope, naz, il1, il2, lev1, lev2, nlons, &
+    nlevs, nazmth, lorms)
+
+  ! Cutoff drag above ALT_CUTOFF, using BVFB as temporary work array.
+
+  IF (icutoff==1) THEN
+    CALL hines_exp(drag_u, bvfb, alt, alt_cutoff, iorder, il1, il2, lev1, &
+      lev2, nlons, nlevs)
+    CALL hines_exp(drag_v, bvfb, alt, alt_cutoff, iorder, il1, il2, lev1, &
+      lev2, nlons, nlevs)
+  END IF
+
+  ! Print out various arrays for diagnostic purposes.
+
+  IF (iprint==1) THEN
+    ilprt1 = 15
+    ilprt2 = 16
+    CALL hines_print(flux_u, flux_v, drag_u, drag_v, alt, sigma_t, &
+      sigma_alpha, v_alpha, m_alpha, 1, 1, 6, ilprt1, ilprt2, lev1, lev2, &
+      naz, nlons, nlevs, nazmth)
+  END IF
+
+  ! If not calculating heating rate and diffusion coefficient then finished.
+
+  IF (iheatcal/=1) RETURN
+
+  ! Calculate vertical derivative of cutoff wavenumber (store
+  ! in array V_ALPHA) using centered differences at interior gridpoints
+  ! and one-sided differences at first and last levels.
+
+  DO n = 1, naz
+    DO l = lev1p, lev2m
+      DO i = il1, il2
+        v_alpha(i, l, n) = (m_alpha(i,l+1,n)-m_alpha(i,l-1,n))/ &
+          (alt(i,l+1)-alt(i,l-1))
+      END DO
+    END DO
+    DO i = il1, il2
+      v_alpha(i, lev1, n) = (m_alpha(i,lev1p,n)-m_alpha(i,lev1,n))/ &
+        (alt(i,lev1p)-alt(i,lev1))
+    END DO
+    DO i = il1, il2
+      v_alpha(i, lev2, n) = (m_alpha(i,lev2,n)-m_alpha(i,lev2m,n))/ &
+        (alt(i,lev2)-alt(i,lev2m))
+    END DO
+  END DO
+
+  ! Heating rate and diffusion coefficient.
+
+  CALL hines_heat(heat, diffco, m_alpha, v_alpha, ak_alpha, k_alpha, bvfreq, &
+    density, densb, sigma_t, visc_mol, kstar, slope, f2, f3, f5, f6, naz, &
+    il1, il2, lev1, lev2, nlons, nlevs, nazmth)
+
+  ! Finished.
+
+  RETURN
+  ! -----------------------------------------------------------------------
+END SUBROUTINE hines_extro0
+
+SUBROUTINE hines_wavnum(m_alpha, sigma_alpha, sigsqh_alpha, sigma_t, &
+    ak_alpha, v_alpha, visc_mol, density, densb, bvfreq, bvfb, rms_wind, &
+    i_alpha, mmin_alpha, kstar, slope, f1, f2, f3, naz, levbot, levtop, il1, &
+    il2, nlons, nlevs, nazmth, sigsqmcw, sigmatm, lorms, sigalpmc, f2mod)
+  IMPLICIT NONE
+  ! This routine calculates the cutoff vertical wavenumber and velocity
+  ! variances on a longitude by altitude grid for the Hines' Doppler
+  ! spread gravity wave drag parameterization scheme.
+  ! NOTE: (1) only values of four or eight can be used for # azimuths (NAZ).
+  ! (2) only values of 1.0, 1.5 or 2.0 can be used for slope (SLOPE).
+
+  ! Aug. 10/95 - C. McLandress
+
+  ! Output arguements:
+
+  ! * M_ALPHA      = cutoff wavenumber at each azimuth (1/m).
+  ! * SIGMA_ALPHA  = total rms wind in each azimuth (m/s).
+  ! * SIGSQH_ALPHA = portion of wind variance from waves having wave
+  ! *                normals in the alpha azimuth (m/s).
+  ! * SIGMA_T      = total rms horizontal wind (m/s).
+  ! * AK_ALPHA     = spectral amplitude factor at each azimuth
+  ! *                (i.e.,{AjKj}) in m^4/s^2.
+
+  ! Input arguements:
+
+  ! * V_ALPHA  = wind component at each azimuth (m/s).
+  ! * VISC_MOL = molecular viscosity (m^2/s)
+  ! * DENSITY  = background density (kg/m^3).
+  ! * DENSB    = background density at model bottom (kg/m^3).
+  ! * BVFREQ   = background Brunt Vassala frequency (radians/sec).
+  ! * BVFB     = background Brunt Vassala frequency at model bottom.
+  ! * RMS_WIND = root mean square gravity wave wind at lowest level (m/s).
+  ! * KSTAR    = typical gravity wave horizontal wavenumber (1/m).
+  ! * SLOPE    = slope of incident vertical wavenumber spectrum
+  ! *            (SLOPE = 1., 1.5 or 2.).
+  ! * F1,F2,F3 = Hines's fudge factors.
+  ! * NAZ      = actual number of horizontal azimuths used (4 or 8).
+  ! * LEVBOT   = index of lowest vertical level.
+  ! * LEVTOP   = index of highest vertical level
+  ! *            (NOTE: if LEVTOP < LEVBOT then level index
+  ! *             increases from top down).
+  ! * IL1      = first longitudinal index to use (IL1 >= 1).
+  ! * IL2      = last longitudinal index to use (IL1 <= IL2 <= NLONS).
+  ! * NLONS    = number of longitudes.
+  ! * NLEVS    = number of vertical levels.
+  ! * NAZMTH   = azimuthal array dimension (NAZMTH >= NAZ).
+
+  ! * LORMS       = .TRUE. for drag computation
+
+  ! Input work arrays:
+
+  ! * I_ALPHA    = Hines' integral at a single level.
+  ! * MMIN_ALPHA = minimum value of cutoff wavenumber.
+
+  INTEGER naz, levbot, levtop, il1, il2, nlons, nlevs, nazmth
+  REAL slope, kstar(nlons), f1, f2, f3, f2mfac
+  REAL m_alpha(nlons, nlevs, nazmth)
+  REAL sigma_alpha(nlons, nlevs, nazmth)
+  REAL sigalpmc(nlons, nlevs, nazmth)
+  REAL sigsqh_alpha(nlons, nlevs, nazmth)
+  REAL sigsqmcw(nlons, nlevs, nazmth)
+  REAL sigma_t(nlons, nlevs)
+  REAL sigmatm(nlons, nlevs)
+  REAL ak_alpha(nlons, nazmth)
+  REAL v_alpha(nlons, nlevs, nazmth)
+  REAL visc_mol(nlons, nlevs)
+  REAL f2mod(nlons, nlevs)
+  REAL density(nlons, nlevs), densb(nlons)
+  REAL bvfreq(nlons, nlevs), bvfb(nlons), rms_wind(nlons)
+  REAL i_alpha(nlons, nazmth), mmin_alpha(nlons, nazmth)
+
+  LOGICAL lorms(nlons)
+
+  ! Internal variables.
+
+  INTEGER i, l, n, lstart, lend, lincr, lbelow
+  REAL m_sub_m_turb, m_sub_m_mol, m_trial
+  REAL visc, visc_min, azfac, sp1
+
+  ! c      REAL  N_OVER_M(1000), SIGFAC(1000)
+
+  REAL n_over_m(nlons), sigfac(nlons)
+  DATA visc_min/1.E-10/
+  ! -----------------------------------------------------------------------
+
+
+  ! PRINT *,'IN HINES_WAVNUM'
+  sp1 = slope + 1.
+
+  ! Indices of levels to process.
+
+  IF (levbot>levtop) THEN
+    lstart = levbot - 1
+    lend = levtop
+    lincr = -1
+  ELSE
+    WRITE (6, 1)
+1   FORMAT (2X, ' error: IORDER NOT ONE! ')
+  END IF
+
+  ! Use horizontal isotropy to calculate azimuthal variances at bottom level.
+
+  azfac = 1./real(naz)
+  DO n = 1, naz
+    DO i = il1, il2
+      sigsqh_alpha(i, levbot, n) = azfac*rms_wind(i)**2
+    END DO
+  END DO
+
+  ! Velocity variances at bottom level.
+
+  CALL hines_sigma(sigma_t, sigma_alpha, sigsqh_alpha, naz, levbot, il1, il2, &
+    nlons, nlevs, nazmth)
+
+  CALL hines_sigma(sigmatm, sigalpmc, sigsqmcw, naz, levbot, il1, il2, nlons, &
+    nlevs, nazmth)
+
+  ! Calculate cutoff wavenumber and spectral amplitude factor
+  ! at bottom level where it is assumed that background winds vanish
+  ! and also initialize minimum value of cutoff wavnumber.
+
+  DO n = 1, naz
+    DO i = il1, il2
+      IF (lorms(i)) THEN
+        m_alpha(i, levbot, n) = bvfb(i)/(f1*sigma_alpha(i,levbot,n)+f2* &
+          sigma_t(i,levbot))
+        ak_alpha(i, n) = sigsqh_alpha(i, levbot, n)/ &
+          (m_alpha(i,levbot,n)**sp1/sp1)
+        mmin_alpha(i, n) = m_alpha(i, levbot, n)
+      END IF
+    END DO
+  END DO
+
+  ! Calculate quantities from the bottom upwards,
+  ! starting one level above bottom.
+
+  DO l = lstart, lend, lincr
+
+    ! Level beneath present level.
+
+    lbelow = l - lincr
+
+    ! Calculate N/m_M where m_M is maximum permissible value of the vertical
+    ! wavenumber (i.e., m > m_M are obliterated) and N is buoyancy frequency.
+    ! m_M is taken as the smaller of the instability-induced
+    ! wavenumber (M_SUB_M_TURB) and that imposed by molecular viscosity
+    ! (M_SUB_M_MOL). Since variance at this level is not yet known
+    ! use value at level below.
+
+    DO i = il1, il2
+      IF (lorms(i)) THEN
+
+        f2mfac = sigmatm(i, lbelow)**2
+        f2mod(i, lbelow) = 1. + 2.*f2mfac/(f2mfac+sigma_t(i,lbelow)**2)
+
+        visc = amax1(visc_mol(i,l), visc_min)
+        m_sub_m_turb = bvfreq(i, l)/(f2*f2mod(i,lbelow)*sigma_t(i,lbelow))
+        m_sub_m_mol = (bvfreq(i,l)*kstar(i)/visc)**0.33333333/f3
+        IF (m_sub_m_turb<m_sub_m_mol) THEN
+          n_over_m(i) = f2*f2mod(i, lbelow)*sigma_t(i, lbelow)
+        ELSE
+          n_over_m(i) = bvfreq(i, l)/m_sub_m_mol
+        END IF
+      END IF
+    END DO
+
+    ! Calculate cutoff wavenumber at this level.
+
+    DO n = 1, naz
+      DO i = il1, il2
+        IF (lorms(i)) THEN
+
+          ! Calculate trial value (since variance at this level is not yet
+          ! known
+          ! use value at level below). If trial value is negative or if it
+          ! exceeds
+          ! minimum value (not permitted) then set it to minimum value.
+
+          m_trial = bvfb(i)/(f1*(sigma_alpha(i,lbelow,n)+sigalpmc(i,lbelow, &
+            n))+n_over_m(i)+v_alpha(i,l,n))
+          IF (m_trial<=0. .OR. m_trial>mmin_alpha(i,n)) THEN
+            m_trial = mmin_alpha(i, n)
+          END IF
+          m_alpha(i, l, n) = m_trial
+
+          ! Reset minimum value of cutoff wavenumber if necessary.
+
+          IF (m_alpha(i,l,n)<mmin_alpha(i,n)) THEN
+            mmin_alpha(i, n) = m_alpha(i, l, n)
+          END IF
+
+        END IF
+      END DO
+    END DO
+
+    ! Calculate the Hines integral at this level.
+
+    CALL hines_intgrl(i_alpha, v_alpha, m_alpha, bvfb, slope, naz, l, il1, &
+      il2, nlons, nlevs, nazmth, lorms)
+
+
+    ! Calculate the velocity variances at this level.
+
+    DO i = il1, il2
+      sigfac(i) = densb(i)/density(i, l)*bvfreq(i, l)/bvfb(i)
+    END DO
+    DO n = 1, naz
+      DO i = il1, il2
+        sigsqh_alpha(i, l, n) = sigfac(i)*ak_alpha(i, n)*i_alpha(i, n)
+      END DO
+    END DO
+    CALL hines_sigma(sigma_t, sigma_alpha, sigsqh_alpha, naz, l, il1, il2, &
+      nlons, nlevs, nazmth)
+
+    CALL hines_sigma(sigmatm, sigalpmc, sigsqmcw, naz, l, il1, il2, nlons, &
+      nlevs, nazmth)
+
+    ! End of level loop.
+
+  END DO
+
+  RETURN
+  ! -----------------------------------------------------------------------
+END SUBROUTINE hines_wavnum
+
+SUBROUTINE hines_wind(v_alpha, vel_u, vel_v, naz, il1, il2, lev1, lev2, &
+    nlons, nlevs, nazmth)
+    IMPLICIT NONE
+  ! This routine calculates the azimuthal horizontal background wind
+  ! components
+  ! on a longitude by altitude grid for the case of 4 or 8 azimuths for
+  ! the Hines' Doppler spread GWD parameterization scheme.
+
+  ! Aug. 7/95 - C. McLandress
+
+  ! Output arguement:
+
+  ! * V_ALPHA   = background wind component at each azimuth (m/s).
+  ! *             (note: first azimuth is in eastward direction
+  ! *              and rotate in counterclockwise direction.)
+
+  ! Input arguements:
+
+  ! * VEL_U     = background zonal wind component (m/s).
+  ! * VEL_V     = background meridional wind component (m/s).
+  ! * NAZ       = actual number of horizontal azimuths used (must be 4 or 8).
+  ! * IL1       = first longitudinal index to use (IL1 >= 1).
+  ! * IL2       = last longitudinal index to use (IL1 <= IL2 <= NLONS).
+  ! * LEV1      = first altitude level to use (LEV1 >=1).
+  ! * LEV2      = last altitude level to use (LEV1 < LEV2 <= NLEVS).
+  ! * NLONS     = number of longitudes.
+  ! * NLEVS     = number of vertical levels.
+  ! * NAZMTH    = azimuthal array dimension (NAZMTH >= NAZ).
+
+  ! Constants in DATA statements.
+
+  ! * COS45 = cosine of 45 degrees.
+  ! * UMIN  = minimum allowable value for zonal or meridional
+  ! *         wind component (m/s).
+
+  ! Subroutine arguements.
+
+  INTEGER naz, il1, il2, lev1, lev2
+  INTEGER nlons, nlevs, nazmth
+  REAL v_alpha(nlons, nlevs, nazmth)
+  REAL vel_u(nlons, nlevs), vel_v(nlons, nlevs)
+
+  ! Internal variables.
+
+  INTEGER i, l
+  REAL u, v, cos45, umin
+
+  DATA cos45/0.7071068/
+  DATA umin/0.001/
+  ! -----------------------------------------------------------------------
+
+  ! Case with 4 azimuths.
+
+
+  ! PRINT *,'IN HINES_WIND'
+  IF (naz==4) THEN
+    DO l = lev1, lev2
+      DO i = il1, il2
+        u = vel_u(i, l)
+        v = vel_v(i, l)
+        IF (abs(u)<umin) u = umin
+        IF (abs(v)<umin) v = umin
+        v_alpha(i, l, 1) = u
+        v_alpha(i, l, 2) = v
+        v_alpha(i, l, 3) = -u
+        v_alpha(i, l, 4) = -v
+      END DO
+    END DO
+  END IF
+
+  ! Case with 8 azimuths.
+
+  IF (naz==8) THEN
+    DO l = lev1, lev2
+      DO i = il1, il2
+        u = vel_u(i, l)
+        v = vel_v(i, l)
+        IF (abs(u)<umin) u = umin
+        IF (abs(v)<umin) v = umin
+        v_alpha(i, l, 1) = u
+        v_alpha(i, l, 2) = cos45*(v+u)
+        v_alpha(i, l, 3) = v
+        v_alpha(i, l, 4) = cos45*(v-u)
+        v_alpha(i, l, 5) = -u
+        v_alpha(i, l, 6) = -v_alpha(i, l, 2)
+        v_alpha(i, l, 7) = -v
+        v_alpha(i, l, 8) = -v_alpha(i, l, 4)
+      END DO
+    END DO
+  END IF
+
+  RETURN
+  ! -----------------------------------------------------------------------
+END SUBROUTINE hines_wind
+
+SUBROUTINE hines_flux(flux_u, flux_v, drag_u, drag_v, alt, density, densb, &
+    m_alpha, ak_alpha, k_alpha, slope, naz, il1, il2, lev1, lev2, nlons, &
+    nlevs, nazmth, lorms)
+    IMPLICIT NONE
+  ! Calculate zonal and meridional components of the vertical flux
+  ! of horizontal momentum and corresponding wave drag (force per unit mass)
+  ! on a longitude by altitude grid for the Hines' Doppler spread
+  ! GWD parameterization scheme.
+  ! NOTE: only 4 or 8 azimuths can be used.
+
+  ! Aug. 6/95 - C. McLandress
+
+  ! Output arguements:
+
+  ! * FLUX_U = zonal component of vertical momentum flux (Pascals)
+  ! * FLUX_V = meridional component of vertical momentum flux (Pascals)
+  ! * DRAG_U = zonal component of drag (m/s^2).
+  ! * DRAG_V = meridional component of drag (m/s^2).
+
+  ! Input arguements:
+
+  ! * ALT       = altitudes (m).
+  ! * DENSITY   = background density (kg/m^3).
+  ! * DENSB     = background density at bottom level (kg/m^3).
+  ! * M_ALPHA   = cutoff vertical wavenumber (1/m).
+  ! * AK_ALPHA  = spectral amplitude factor (i.e., {AjKj} in m^4/s^2).
+  ! * K_ALPHA   = horizontal wavenumber (1/m).
+  ! * SLOPE     = slope of incident vertical wavenumber spectrum.
+  ! * NAZ       = actual number of horizontal azimuths used (must be 4 or 8).
+  ! * IL1       = first longitudinal index to use (IL1 >= 1).
+  ! * IL2       = last longitudinal index to use (IL1 <= IL2 <= NLONS).
+  ! * LEV1      = first altitude level to use (LEV1 >=1).
+  ! * LEV2      = last altitude level to use (LEV1 < LEV2 <= NLEVS).
+  ! * NLONS     = number of longitudes.
+  ! * NLEVS     = number of vertical levels.
+  ! * NAZMTH    = azimuthal array dimension (NAZMTH >= NAZ).
+
+  ! * LORMS       = .TRUE. for drag computation
+
+  ! Constant in DATA statement.
+
+  ! * COS45 = cosine of 45 degrees.
+
+  ! Subroutine arguements.
+
+  INTEGER naz, il1, il2, lev1, lev2
+  INTEGER nlons, nlevs, nazmth
+  REAL slope
+  REAL flux_u(nlons, nlevs), flux_v(nlons, nlevs)
+  REAL drag_u(nlons, nlevs), drag_v(nlons, nlevs)
+  REAL alt(nlons, nlevs), density(nlons, nlevs), densb(nlons)
+  REAL m_alpha(nlons, nlevs, nazmth)
+  REAL ak_alpha(nlons, nazmth), k_alpha(nlons, nazmth)
+
+  LOGICAL lorms(nlons)
+
+  ! Internal variables.
+
+  INTEGER i, l, lev1p, lev2m, lev2p
+  REAL cos45, prod2, prod4, prod6, prod8, dendz, dendz2
+  DATA cos45/0.7071068/
+  ! -----------------------------------------------------------------------
+
+  lev1p = lev1 + 1
+  lev2m = lev2 - 1
+  lev2p = lev2 + 1
+
+  ! Sum over azimuths for case where SLOPE = 1.
+
+  IF (slope==1.) THEN
+
+    ! Case with 4 azimuths.
+
+    IF (naz==4) THEN
+      DO l = lev1, lev2
+        DO i = il1, il2
+          flux_u(i, l) = ak_alpha(i, 1)*k_alpha(i, 1)*m_alpha(i, l, 1) - &
+            ak_alpha(i, 3)*k_alpha(i, 3)*m_alpha(i, l, 3)
+          flux_v(i, l) = ak_alpha(i, 2)*k_alpha(i, 2)*m_alpha(i, l, 2) - &
+            ak_alpha(i, 4)*k_alpha(i, 4)*m_alpha(i, l, 4)
+        END DO
+      END DO
+    END IF
+
+    ! Case with 8 azimuths.
+
+    IF (naz==8) THEN
+      DO l = lev1, lev2
+        DO i = il1, il2
+          prod2 = ak_alpha(i, 2)*k_alpha(i, 2)*m_alpha(i, l, 2)
+          prod4 = ak_alpha(i, 4)*k_alpha(i, 4)*m_alpha(i, l, 4)
+          prod6 = ak_alpha(i, 6)*k_alpha(i, 6)*m_alpha(i, l, 6)
+          prod8 = ak_alpha(i, 8)*k_alpha(i, 8)*m_alpha(i, l, 8)
+          flux_u(i, l) = ak_alpha(i, 1)*k_alpha(i, 1)*m_alpha(i, l, 1) - &
+            ak_alpha(i, 5)*k_alpha(i, 5)*m_alpha(i, l, 5) + &
+            cos45*(prod2-prod4-prod6+prod8)
+          flux_v(i, l) = ak_alpha(i, 3)*k_alpha(i, 3)*m_alpha(i, l, 3) - &
+            ak_alpha(i, 7)*k_alpha(i, 7)*m_alpha(i, l, 7) + &
+            cos45*(prod2+prod4-prod6-prod8)
+        END DO
+      END DO
+    END IF
+
+  END IF
+
+  ! Sum over azimuths for case where SLOPE not equal to 1.
+
+  IF (slope/=1.) THEN
+
+    ! Case with 4 azimuths.
+
+    IF (naz==4) THEN
+      DO l = lev1, lev2
+        DO i = il1, il2
+          flux_u(i, l) = ak_alpha(i, 1)*k_alpha(i, 1)* &
+            m_alpha(i, l, 1)**slope - ak_alpha(i, 3)*k_alpha(i, 3)*m_alpha(i, &
+            l, 3)**slope
+          flux_v(i, l) = ak_alpha(i, 2)*k_alpha(i, 2)* &
+            m_alpha(i, l, 2)**slope - ak_alpha(i, 4)*k_alpha(i, 4)*m_alpha(i, &
+            l, 4)**slope
+        END DO
+      END DO
+    END IF
+
+    ! Case with 8 azimuths.
+
+    IF (naz==8) THEN
+      DO l = lev1, lev2
+        DO i = il1, il2
+          prod2 = ak_alpha(i, 2)*k_alpha(i, 2)*m_alpha(i, l, 2)**slope
+          prod4 = ak_alpha(i, 4)*k_alpha(i, 4)*m_alpha(i, l, 4)**slope
+          prod6 = ak_alpha(i, 6)*k_alpha(i, 6)*m_alpha(i, l, 6)**slope
+          prod8 = ak_alpha(i, 8)*k_alpha(i, 8)*m_alpha(i, l, 8)**slope
+          flux_u(i, l) = ak_alpha(i, 1)*k_alpha(i, 1)* &
+            m_alpha(i, l, 1)**slope - ak_alpha(i, 5)*k_alpha(i, 5)*m_alpha(i, &
+            l, 5)**slope + cos45*(prod2-prod4-prod6+prod8)
+          flux_v(i, l) = ak_alpha(i, 3)*k_alpha(i, 3)* &
+            m_alpha(i, l, 3)**slope - ak_alpha(i, 7)*k_alpha(i, 7)*m_alpha(i, &
+            l, 7)**slope + cos45*(prod2+prod4-prod6-prod8)
+        END DO
+      END DO
+    END IF
+
+  END IF
+
+  ! Calculate flux from sum.
+
+  DO l = lev1, lev2
+    DO i = il1, il2
+      flux_u(i, l) = flux_u(i, l)*densb(i)/slope
+      flux_v(i, l) = flux_v(i, l)*densb(i)/slope
+    END DO
+  END DO
+
+  ! Calculate drag at intermediate levels using centered differences
+
+  DO l = lev1p, lev2m
+    DO i = il1, il2
+      IF (lorms(i)) THEN
+        ! cc       DENDZ2 = DENSITY(I,L) * ( ALT(I,L+1) - ALT(I,L-1) )
+        dendz2 = density(i, l)*(alt(i,l-1)-alt(i,l))
+        ! cc       DRAG_U(I,L) = - ( FLUX_U(I,L+1) - FLUX_U(I,L-1) ) / DENDZ2
+        drag_u(i, l) = -(flux_u(i,l-1)-flux_u(i,l))/dendz2
+        ! cc       DRAG_V(I,L) = - ( FLUX_V(I,L+1) - FLUX_V(I,L-1) ) / DENDZ2
+        drag_v(i, l) = -(flux_v(i,l-1)-flux_v(i,l))/dendz2
+
+      END IF
+    END DO
+  END DO
+
+  ! Drag at first and last levels using one-side differences.
+
+  DO i = il1, il2
+    IF (lorms(i)) THEN
+      dendz = density(i, lev1)*(alt(i,lev1)-alt(i,lev1p))
+      drag_u(i, lev1) = flux_u(i, lev1)/dendz
+      drag_v(i, lev1) = flux_v(i, lev1)/dendz
+    END IF
+  END DO
+  DO i = il1, il2
+    IF (lorms(i)) THEN
+      dendz = density(i, lev2)*(alt(i,lev2m)-alt(i,lev2))
+      drag_u(i, lev2) = -(flux_u(i,lev2m)-flux_u(i,lev2))/dendz
+      drag_v(i, lev2) = -(flux_v(i,lev2m)-flux_v(i,lev2))/dendz
+    END IF
+  END DO
+  IF (nlevs>lev2) THEN
+    DO i = il1, il2
+      IF (lorms(i)) THEN
+        dendz = density(i, lev2p)*(alt(i,lev2)-alt(i,lev2p))
+        drag_u(i, lev2p) = -flux_u(i, lev2)/dendz
+        drag_v(i, lev2p) = -flux_v(i, lev2)/dendz
+      END IF
+    END DO
+  END IF
+
+  RETURN
+  ! -----------------------------------------------------------------------
+END SUBROUTINE hines_flux
+
+SUBROUTINE hines_heat(heat, diffco, m_alpha, dmdz_alpha, ak_alpha, k_alpha, &
+    bvfreq, density, densb, sigma_t, visc_mol, kstar, slope, f2, f3, f5, f6, &
+    naz, il1, il2, lev1, lev2, nlons, nlevs, nazmth)
+  IMPLICIT NONE
+  ! This routine calculates the gravity wave induced heating and
+  ! diffusion coefficient on a longitude by altitude grid for
+  ! the Hines' Doppler spread gravity wave drag parameterization scheme.
+
+  ! Aug. 6/95 - C. McLandress
+
+  ! Output arguements:
+
+  ! * HEAT   = gravity wave heating (K/sec).
+  ! * DIFFCO = diffusion coefficient (m^2/sec)
+
+  ! Input arguements:
+
+  ! * M_ALPHA     = cutoff vertical wavenumber (1/m).
+  ! * DMDZ_ALPHA  = vertical derivative of cutoff wavenumber.
+  ! * AK_ALPHA    = spectral amplitude factor of each azimuth
+  ! (i.e., {AjKj} in m^4/s^2).
+  ! * K_ALPHA     = horizontal wavenumber of each azimuth (1/m).
+  ! * BVFREQ      = background Brunt Vassala frequency (rad/sec).
+  ! * DENSITY     = background density (kg/m^3).
+  ! * DENSB       = background density at bottom level (kg/m^3).
+  ! * SIGMA_T     = total rms horizontal wind (m/s).
+  ! * VISC_MOL    = molecular viscosity (m^2/s).
+  ! * KSTAR       = typical gravity wave horizontal wavenumber (1/m).
+  ! * SLOPE       = slope of incident vertical wavenumber spectrum.
+  ! * F2,F3,F5,F6 = Hines's fudge factors.
+  ! * NAZ         = actual number of horizontal azimuths used.
+  ! * IL1         = first longitudinal index to use (IL1 >= 1).
+  ! * IL2         = last longitudinal index to use (IL1 <= IL2 <= NLONS).
+  ! * LEV1        = first altitude level to use (LEV1 >=1).
+  ! * LEV2        = last altitude level to use (LEV1 < LEV2 <= NLEVS).
+  ! * NLONS       = number of longitudes.
+  ! * NLEVS       = number of vertical levels.
+  ! * NAZMTH      = azimuthal array dimension (NAZMTH >= NAZ).
+
+  INTEGER naz, il1, il2, lev1, lev2, nlons, nlevs, nazmth
+  REAL kstar(nlons), slope, f2, f3, f5, f6
+  REAL heat(nlons, nlevs), diffco(nlons, nlevs)
+  REAL m_alpha(nlons, nlevs, nazmth), dmdz_alpha(nlons, nlevs, nazmth)
+  REAL ak_alpha(nlons, nazmth), k_alpha(nlons, nazmth)
+  REAL bvfreq(nlons, nlevs), density(nlons, nlevs), densb(nlons)
+  REAL sigma_t(nlons, nlevs), visc_mol(nlons, nlevs)
+
+  ! Internal variables.
+
+  INTEGER i, l, n
+  REAL m_sub_m_turb, m_sub_m_mol, m_sub_m, heatng
+  REAL visc, visc_min, cpgas, sm1
+
+  ! specific heat at constant pressure
+
+  DATA cpgas/1004./
+
+  ! minimum permissible viscosity
+
+  DATA visc_min/1.E-10/
+  ! -----------------------------------------------------------------------
+
+  ! Initialize heating array.
+
+  DO l = 1, nlevs
+    DO i = 1, nlons
+      heat(i, l) = 0.
+    END DO
+  END DO
+
+  ! Perform sum over azimuths for case where SLOPE = 1.
+
+  IF (slope==1.) THEN
+    DO n = 1, naz
+      DO l = lev1, lev2
+        DO i = il1, il2
+          heat(i, l) = heat(i, l) + ak_alpha(i, n)*k_alpha(i, n)*dmdz_alpha(i &
+            , l, n)
+        END DO
+      END DO
+    END DO
+  END IF
+
+  ! Perform sum over azimuths for case where SLOPE not 1.
+
+  IF (slope/=1.) THEN
+    sm1 = slope - 1.
+    DO n = 1, naz
+      DO l = lev1, lev2
+        DO i = il1, il2
+          heat(i, l) = heat(i, l) + ak_alpha(i, n)*k_alpha(i, n)*m_alpha(i, l &
+            , n)**sm1*dmdz_alpha(i, l, n)
+        END DO
+      END DO
+    END DO
+  END IF
+
+  ! Heating and diffusion.
+
+  DO l = lev1, lev2
+    DO i = il1, il2
+
+      ! Maximum permissible value of cutoff wavenumber is the smaller
+      ! of the instability-induced wavenumber (M_SUB_M_TURB) and
+      ! that imposed by molecular viscosity (M_SUB_M_MOL).
+
+      visc = amax1(visc_mol(i,l), visc_min)
+      m_sub_m_turb = bvfreq(i, l)/(f2*sigma_t(i,l))
+      m_sub_m_mol = (bvfreq(i,l)*kstar(i)/visc)**0.33333333/f3
+      m_sub_m = amin1(m_sub_m_turb, m_sub_m_mol)
+
+      heatng = -heat(i, l)*f5*bvfreq(i, l)/m_sub_m*densb(i)/density(i, l)
+      diffco(i, l) = f6*heatng**0.33333333/m_sub_m**1.33333333
+      heat(i, l) = heatng/cpgas
+
+    END DO
+  END DO
+
+  RETURN
+  ! -----------------------------------------------------------------------
+END SUBROUTINE hines_heat
+
+SUBROUTINE hines_sigma(sigma_t, sigma_alpha, sigsqh_alpha, naz, lev, il1, &
+    il2, nlons, nlevs, nazmth)
+  IMPLICIT NONE
+  ! This routine calculates the total rms and azimuthal rms horizontal
+  ! velocities at a given level on a longitude by altitude grid for
+  ! the Hines' Doppler spread GWD parameterization scheme.
+  ! NOTE: only four or eight azimuths can be used.
+
+  ! Aug. 7/95 - C. McLandress
+
+  ! Output arguements:
+
+  ! * SIGMA_T      = total rms horizontal wind (m/s).
+  ! * SIGMA_ALPHA  = total rms wind in each azimuth (m/s).
+
+  ! Input arguements:
+
+  ! * SIGSQH_ALPHA = portion of wind variance from waves having wave
+  ! *                normals in the alpha azimuth (m/s).
+  ! * NAZ       = actual number of horizontal azimuths used (must be 4 or 8).
+  ! * LEV       = altitude level to process.
+  ! * IL1       = first longitudinal index to use (IL1 >= 1).
+  ! * IL2       = last longitudinal index to use (IL1 <= IL2 <= NLONS).
+  ! * NLONS     = number of longitudes.
+  ! * NLEVS     = number of vertical levels.
+  ! * NAZMTH    = azimuthal array dimension (NAZMTH >= NAZ).
+
+  ! Subroutine arguements.
+
+  INTEGER lev, naz, il1, il2
+  INTEGER nlons, nlevs, nazmth
+  REAL sigma_t(nlons, nlevs)
+  REAL sigma_alpha(nlons, nlevs, nazmth)
+  REAL sigsqh_alpha(nlons, nlevs, nazmth)
+
+  ! Internal variables.
+
+  INTEGER i, n
+  REAL sum_even, sum_odd
+  ! -----------------------------------------------------------------------
+
+  ! Calculate azimuthal rms velocity for the 4 azimuth case.
+
+  IF (naz==4) THEN
+    DO i = il1, il2
+      sigma_alpha(i, lev, 1) = sqrt(sigsqh_alpha(i,lev,1)+sigsqh_alpha(i,lev, &
+        3))
+      sigma_alpha(i, lev, 2) = sqrt(sigsqh_alpha(i,lev,2)+sigsqh_alpha(i,lev, &
+        4))
+      sigma_alpha(i, lev, 3) = sigma_alpha(i, lev, 1)
+      sigma_alpha(i, lev, 4) = sigma_alpha(i, lev, 2)
+    END DO
+  END IF
+
+  ! Calculate azimuthal rms velocity for the 8 azimuth case.
+
+  IF (naz==8) THEN
+    DO i = il1, il2
+      sum_odd = (sigsqh_alpha(i,lev,1)+sigsqh_alpha(i,lev,3)+ &
+        sigsqh_alpha(i,lev,5)+sigsqh_alpha(i,lev,7))/2.
+      sum_even = (sigsqh_alpha(i,lev,2)+sigsqh_alpha(i,lev,4)+ &
+        sigsqh_alpha(i,lev,6)+sigsqh_alpha(i,lev,8))/2.
+      sigma_alpha(i, lev, 1) = sqrt(sigsqh_alpha(i,lev,1)+sigsqh_alpha(i,lev, &
+        5)+sum_even)
+      sigma_alpha(i, lev, 2) = sqrt(sigsqh_alpha(i,lev,2)+sigsqh_alpha(i,lev, &
+        6)+sum_odd)
+      sigma_alpha(i, lev, 3) = sqrt(sigsqh_alpha(i,lev,3)+sigsqh_alpha(i,lev, &
+        7)+sum_even)
+      sigma_alpha(i, lev, 4) = sqrt(sigsqh_alpha(i,lev,4)+sigsqh_alpha(i,lev, &
+        8)+sum_odd)
+      sigma_alpha(i, lev, 5) = sigma_alpha(i, lev, 1)
+      sigma_alpha(i, lev, 6) = sigma_alpha(i, lev, 2)
+      sigma_alpha(i, lev, 7) = sigma_alpha(i, lev, 3)
+      sigma_alpha(i, lev, 8) = sigma_alpha(i, lev, 4)
+    END DO
+  END IF
+
+  ! Calculate total rms velocity.
+
+  DO i = il1, il2
+    sigma_t(i, lev) = 0.
+  END DO
+  DO n = 1, naz
+    DO i = il1, il2
+      sigma_t(i, lev) = sigma_t(i, lev) + sigsqh_alpha(i, lev, n)
+    END DO
+  END DO
+  DO i = il1, il2
+    sigma_t(i, lev) = sqrt(sigma_t(i,lev))
+  END DO
+
+  RETURN
+  ! -----------------------------------------------------------------------
+END SUBROUTINE hines_sigma
+
+SUBROUTINE hines_intgrl(i_alpha, v_alpha, m_alpha, bvfb, slope, naz, lev, &
+    il1, il2, nlons, nlevs, nazmth, lorms)
+  IMPLICIT NONE
+  ! This routine calculates the vertical wavenumber integral
+  ! for a single vertical level at each azimuth on a longitude grid
+  ! for the Hines' Doppler spread GWD parameterization scheme.
+  ! NOTE: (1) only spectral slopes of 1, 1.5 or 2 are permitted.
+  ! (2) the integral is written in terms of the product QM
+  ! which by construction is always less than 1. Series
+  ! solutions are used for small |QM| and analytical solutions
+  ! for remaining values.
+
+  ! Aug. 8/95 - C. McLandress
+
+  ! Output arguement:
+
+  ! * I_ALPHA = Hines' integral.
+
+  ! Input arguements:
+
+  ! * V_ALPHA = azimuthal wind component (m/s).
+  ! * M_ALPHA = azimuthal cutoff vertical wavenumber (1/m).
+  ! * BVFB    = background Brunt Vassala frequency at model bottom.
+  ! * SLOPE   = slope of initial vertical wavenumber spectrum
+  ! *           (must use SLOPE = 1., 1.5 or 2.)
+  ! * NAZ     = actual number of horizontal azimuths used.
+  ! * LEV     = altitude level to process.
+  ! * IL1     = first longitudinal index to use (IL1 >= 1).
+  ! * IL2     = last longitudinal index to use (IL1 <= IL2 <= NLONS).
+  ! * NLONS   = number of longitudes.
+  ! * NLEVS   = number of vertical levels.
+  ! * NAZMTH  = azimuthal array dimension (NAZMTH >= NAZ).
+
+  ! * LORMS       = .TRUE. for drag computation
+
+  ! Constants in DATA statements:
+
+  ! * QMIN = minimum value of Q_ALPHA (avoids indeterminant form of integral)
+  ! * QM_MIN = minimum value of Q_ALPHA * M_ALPHA (used to avoid numerical
+  ! *          problems).
+
+  INTEGER lev, naz, il1, il2, nlons, nlevs, nazmth
+  REAL i_alpha(nlons, nazmth)
+  REAL v_alpha(nlons, nlevs, nazmth)
+  REAL m_alpha(nlons, nlevs, nazmth)
+  REAL bvfb(nlons), slope
+
+  LOGICAL lorms(nlons)
+
+  ! Internal variables.
+
+  INTEGER i, n
+  REAL q_alpha, qm, sqrtqm, q_min, qm_min
+
+  DATA q_min/1.0/, qm_min/0.01/
+  ! -----------------------------------------------------------------------
+
+  ! For integer value SLOPE = 1.
+
+  IF (slope==1.) THEN
+
+    DO n = 1, naz
+      DO i = il1, il2
+        IF (lorms(i)) THEN
+
+          q_alpha = v_alpha(i, lev, n)/bvfb(i)
+          qm = q_alpha*m_alpha(i, lev, n)
+
+          ! If |QM| is small then use first 4 terms series of Taylor series
+          ! expansion of integral in order to avoid indeterminate form of
+          ! integral,
+          ! otherwise use analytical form of integral.
+
+          IF (abs(q_alpha)<q_min .OR. abs(qm)<qm_min) THEN
+            IF (q_alpha==0.) THEN
+              i_alpha(i, n) = m_alpha(i, lev, n)**2/2.
+            ELSE
+              i_alpha(i, n) = (qm**2/2.+qm**3/3.+qm**4/4.+qm**5/5.)/ &
+                q_alpha**2
+            END IF
+          ELSE
+            i_alpha(i, n) = -(alog(1.-qm)+qm)/q_alpha**2
+          END IF
+
+        END IF
+      END DO
+    END DO
+
+  END IF
+
+  ! For integer value SLOPE = 2.
+
+  IF (slope==2.) THEN
+
+    DO n = 1, naz
+      DO i = il1, il2
+        IF (lorms(i)) THEN
+
+          q_alpha = v_alpha(i, lev, n)/bvfb(i)
+          qm = q_alpha*m_alpha(i, lev, n)
+
+          ! If |QM| is small then use first 4 terms series of Taylor series
+          ! expansion of integral in order to avoid indeterminate form of
+          ! integral,
+          ! otherwise use analytical form of integral.
+
+          IF (abs(q_alpha)<q_min .OR. abs(qm)<qm_min) THEN
+            IF (q_alpha==0.) THEN
+              i_alpha(i, n) = m_alpha(i, lev, n)**3/3.
+            ELSE
+              i_alpha(i, n) = (qm**3/3.+qm**4/4.+qm**5/5.+qm**6/6.)/ &
+                q_alpha**3
+            END IF
+          ELSE
+            i_alpha(i, n) = -(alog(1.-qm)+qm+qm**2/2.)/q_alpha**3
+          END IF
+
+        END IF
+      END DO
+    END DO
+
+  END IF
+
+  ! For real value SLOPE = 1.5
+
+  IF (slope==1.5) THEN
+
+    DO n = 1, naz
+      DO i = il1, il2
+        IF (lorms(i)) THEN
+
+          q_alpha = v_alpha(i, lev, n)/bvfb(i)
+          qm = q_alpha*m_alpha(i, lev, n)
+
+          ! If |QM| is small then use first 4 terms series of Taylor series
+          ! expansion of integral in order to avoid indeterminate form of
+          ! integral,
+          ! otherwise use analytical form of integral.
+
+          IF (abs(q_alpha)<q_min .OR. abs(qm)<qm_min) THEN
+            IF (q_alpha==0.) THEN
+              i_alpha(i, n) = m_alpha(i, lev, n)**2.5/2.5
+            ELSE
+              i_alpha(i, n) = (qm/2.5+qm**2/3.5+qm**3/4.5+qm**4/5.5)* &
+                m_alpha(i, lev, n)**1.5/q_alpha
+            END IF
+          ELSE
+            qm = abs(qm)
+            sqrtqm = sqrt(qm)
+            IF (q_alpha>=0.) THEN
+              i_alpha(i, n) = (alog((1.+sqrtqm)/(1.-sqrtqm))-2.*sqrtqm*(1.+qm &
+                /3.))/q_alpha**2.5
+            ELSE
+              i_alpha(i, n) = 2.*(atan(sqrtqm)+sqrtqm*(qm/3.-1.))/ &
+                abs(q_alpha)**2.5
+            END IF
+          END IF
+
+        END IF
+      END DO
+    END DO
+
+  END IF
+
+  ! If integral is negative (which in principal should not happen) then
+  ! print a message and some info since execution will abort when calculating
+  ! the variances.
+
+  ! DO 80 N = 1,NAZ
+  ! DO 70 I = IL1,IL2
+  ! IF (I_ALPHA(I,N).LT.0.)  THEN
+  ! WRITE (6,*)
+  ! WRITE (6,*) '******************************'
+  ! WRITE (6,*) 'Hines integral I_ALPHA < 0 '
+  ! WRITE (6,*) '  longitude I=',I
+  ! WRITE (6,*) '  azimuth   N=',N
+  ! WRITE (6,*) '  level   LEV=',LEV
+  ! WRITE (6,*) '  I_ALPHA =',I_ALPHA(I,N)
+  ! WRITE (6,*) '  V_ALPHA =',V_ALPHA(I,LEV,N)
+  ! WRITE (6,*) '  M_ALPHA =',M_ALPHA(I,LEV,N)
+  ! WRITE (6,*) '  Q_ALPHA =',V_ALPHA(I,LEV,N) / BVFB(I)
+  ! WRITE (6,*) '  QM      =',V_ALPHA(I,LEV,N) / BVFB(I)
+  ! ^                                * M_ALPHA(I,LEV,N)
+  ! WRITE (6,*) '******************************'
+  ! END IF
+  ! 70     CONTINUE
+  ! 80   CONTINUE
+
+  RETURN
+  ! -----------------------------------------------------------------------
+END SUBROUTINE hines_intgrl
+
+SUBROUTINE hines_setup(naz, slope, f1, f2, f3, f5, f6, kstar, icutoff, &
+    alt_cutoff, smco, nsmax, iheatcal, k_alpha, ierror, nmessg, nlons, &
+    nazmth, coslat)
+  IMPLICIT NONE
+  ! This routine specifies various parameters needed for the
+  ! the Hines' Doppler spread gravity wave drag parameterization scheme.
+
+  ! Aug. 8/95 - C. McLandress
+
+  ! Output arguements:
+
+  ! * NAZ        = actual number of horizontal azimuths used
+  ! *              (code set up presently for only NAZ = 4 or 8).
+  ! * SLOPE      = slope of incident vertical wavenumber spectrum
+  ! *              (code set up presently for SLOPE 1., 1.5 or 2.).
+  ! * F1         = "fudge factor" used in calculation of trial value of
+  ! *              azimuthal cutoff wavenumber M_ALPHA (1.2 <= F1 <= 1.9).
+  ! * F2         = "fudge factor" used in calculation of maximum
+  ! *              permissible instabiliy-induced cutoff wavenumber
+  ! *              M_SUB_M_TURB (0.1 <= F2 <= 1.4).
+  ! * F3         = "fudge factor" used in calculation of maximum
+  ! *              permissible molecular viscosity-induced cutoff wavenumber
+  ! *              M_SUB_M_MOL (0.1 <= F2 <= 1.4).
+  ! * F5         = "fudge factor" used in calculation of heating rate
+  ! *              (1 <= F5 <= 3).
+  ! * F6         = "fudge factor" used in calculation of turbulent
+  ! *              diffusivity coefficient.
+  ! * KSTAR      = typical gravity wave horizontal wavenumber (1/m)
+  ! *              used in calculation of M_SUB_M_TURB.
+  ! * ICUTOFF    = 1 to exponentially damp off GWD, heating and diffusion
+  ! *              arrays above ALT_CUTOFF; otherwise arrays not modified.
+  ! * ALT_CUTOFF = altitude in meters above which exponential decay applied.
+  ! * SMCO       = smoother used to smooth cutoff vertical wavenumbers
+  ! *              and total rms winds before calculating drag or heating.
+  ! *              (==> a 1:SMCO:1 stencil used; SMCO >= 1.).
+  ! * NSMAX      = number of times smoother applied ( >= 1),
+  ! *            = 0 means no smoothing performed.
+  ! * IHEATCAL   = 1 to calculate heating rates and diffusion coefficient.
+  ! *            = 0 means only drag and flux calculated.
+  ! * K_ALPHA    = horizontal wavenumber of each azimuth (1/m) which
+  ! *              is set here to KSTAR.
+  ! * IERROR     = error flag.
+  ! *            = 0 no errors.
+  ! *            = 10 ==> NAZ > NAZMTH
+  ! *            = 20 ==> invalid number of azimuths (NAZ must be 4 or 8).
+  ! *            = 30 ==> invalid slope (SLOPE must be 1., 1.5 or 2.).
+  ! *            = 40 ==> invalid smoother (SMCO must be >= 1.)
+
+  ! Input arguements:
+
+  ! * NMESSG  = output unit number where messages to be printed.
+  ! * NLONS   = number of longitudes.
+  ! * NAZMTH  = azimuthal array dimension (NAZMTH >= NAZ).
+
+  INTEGER naz, nlons, nazmth, iheatcal, icutoff
+  INTEGER nmessg, nsmax, ierror
+  REAL kstar(nlons), slope, f1, f2, f3, f5, f6, alt_cutoff, smco
+  REAL k_alpha(nlons, nazmth), coslat(nlons)
+  REAL ksmin, ksmax
+
+  ! Internal variables.
+
+  INTEGER i, n
+  ! -----------------------------------------------------------------------
+
+  ! Specify constants.
+
+  naz = 8
+  slope = 1.
+  f1 = 1.5
+  f2 = 0.3
+  f3 = 1.0
+  f5 = 3.0
+  f6 = 1.0
+  ksmin = 1.E-5
+  ksmax = 1.E-4
+  DO i = 1, nlons
+    kstar(i) = ksmin/(coslat(i)+(ksmin/ksmax))
+  END DO
+  icutoff = 1
+  alt_cutoff = 105.E3
+  smco = 2.0
+  ! SMCO       = 1.0
+  nsmax = 5
+  ! NSMAX      = 2
+  iheatcal = 0
+
+  ! Print information to output file.
+
+  ! WRITE (NMESSG,6000)
+  ! 6000 FORMAT (/' Subroutine HINES_SETUP:')
+  ! WRITE (NMESSG,*)  '  SLOPE = ', SLOPE
+  ! WRITE (NMESSG,*)  '  NAZ = ', NAZ
+  ! WRITE (NMESSG,*)  '  F1,F2,F3  = ', F1, F2, F3
+  ! WRITE (NMESSG,*)  '  F5,F6     = ', F5, F6
+  ! WRITE (NMESSG,*)  '  KSTAR     = ', KSTAR
+  ! >           ,'  COSLAT     = ', COSLAT
+  ! IF (ICUTOFF .EQ. 1)  THEN
+  ! WRITE (NMESSG,*) '  Drag exponentially damped above ',
+  ! &                       ALT_CUTOFF/1.E3
+  ! END IF
+  ! IF (NSMAX.LT.1 )  THEN
+  ! WRITE (NMESSG,*) '  No smoothing of cutoff wavenumbers, etc'
+  ! ELSE
+  ! WRITE (NMESSG,*) '  Cutoff wavenumbers and sig_t smoothed:'
+  ! WRITE (NMESSG,*) '    SMCO  =', SMCO
+  ! WRITE (NMESSG,*) '    NSMAX =', NSMAX
+  ! END IF
+
+  ! Check that things are setup correctly and log error if not
+
+  ierror = 0
+  IF (naz>nazmth) ierror = 10
+  IF (naz/=4 .AND. naz/=8) ierror = 20
+  IF (slope/=1. .AND. slope/=1.5 .AND. slope/=2.) ierror = 30
+  IF (smco<1.) ierror = 40
+
+  ! Use single value for azimuthal-dependent horizontal wavenumber.
+
+  DO n = 1, naz
+    DO i = 1, nlons
+      k_alpha(i, n) = kstar(i)
+    END DO
+  END DO
+
+  RETURN
+  ! -----------------------------------------------------------------------
+END SUBROUTINE hines_setup
+
+SUBROUTINE hines_print(flux_u, flux_v, drag_u, drag_v, alt, sigma_t, &
+    sigma_alpha, v_alpha, m_alpha, iu_print, iv_print, nmessg, ilprt1, &
+    ilprt2, levprt1, levprt2, naz, nlons, nlevs, nazmth)
+  IMPLICIT NONE
+  ! Print out altitude profiles of various quantities from
+  ! Hines' Doppler spread gravity wave drag parameterization scheme.
+  ! (NOTE: only for NAZ = 4 or 8).
+
+  ! Aug. 8/95 - C. McLandress
+
+  ! Input arguements:
+
+  ! * IU_PRINT = 1 to print out values in east-west direction.
+  ! * IV_PRINT = 1 to print out values in north-south direction.
+  ! * NMESSG   = unit number for printed output.
+  ! * ILPRT1   = first longitudinal index to print.
+  ! * ILPRT2   = last longitudinal index to print.
+  ! * LEVPRT1  = first altitude level to print.
+  ! * LEVPRT2  = last altitude level to print.
+
+  INTEGER naz, ilprt1, ilprt2, levprt1, levprt2
+  INTEGER nlons, nlevs, nazmth
+  INTEGER iu_print, iv_print, nmessg
+  REAL flux_u(nlons, nlevs), flux_v(nlons, nlevs)
+  REAL drag_u(nlons, nlevs), drag_v(nlons, nlevs)
+  REAL alt(nlons, nlevs), sigma_t(nlons, nlevs)
+  REAL sigma_alpha(nlons, nlevs, nazmth)
+  REAL v_alpha(nlons, nlevs, nazmth), m_alpha(nlons, nlevs, nazmth)
+
+  ! Internal variables.
+
+  INTEGER n_east, n_west, n_north, n_south
+  INTEGER i, l
+  ! -----------------------------------------------------------------------
+
+  ! Azimuthal indices of cardinal directions.
+
+  n_east = 1
+  IF (naz==4) THEN
+    n_west = 3
+    n_north = 2
+    n_south = 4
+  ELSE IF (naz==8) THEN
+    n_west = 5
+    n_north = 3
+    n_south = 7
+  END IF
+
+  ! Print out values for range of longitudes.
+
+  DO i = ilprt1, ilprt2
+
+    ! Print east-west wind, sigmas, cutoff wavenumbers, flux and drag.
+
+    IF (iu_print==1) THEN
+      WRITE (nmessg, *)
+      WRITE (nmessg, 6001) i
+      WRITE (nmessg, 6005)
+6001  FORMAT ('Hines GW (east-west) at longitude I =', I3)
+6005  FORMAT (15X, ' U ', 2X, 'sig_E', 2X, 'sig_T', 3X, 'm_E', 4X, 'm_W', 4X, &
+        'fluxU', 5X, 'gwdU')
+      DO l = levprt1, levprt2
+        WRITE (nmessg, 6701) alt(i, l)/1.E3, v_alpha(i, l, n_east), &
+          sigma_alpha(i, l, n_east), sigma_t(i, l), &
+          m_alpha(i, l, n_east)*1.E3, m_alpha(i, l, n_west)*1.E3, &
+          flux_u(i, l)*1.E5, drag_u(i, l)*24.*3600.
+      END DO
+6701  FORMAT (' z=', F7.2, 1X, 3F7.1, 2F7.3, F9.4, F9.3)
+    END IF
+
+    ! Print north-south winds, sigmas, cutoff wavenumbers, flux and drag.
+
+    IF (iv_print==1) THEN
+      WRITE (nmessg, *)
+      WRITE (nmessg, 6002) i
+6002  FORMAT ('Hines GW (north-south) at longitude I =', I3)
+      WRITE (nmessg, 6006)
+6006  FORMAT (15X, ' V ', 2X, 'sig_N', 2X, 'sig_T', 3X, 'm_N', 4X, 'm_S', 4X, &
+        'fluxV', 5X, 'gwdV')
+      DO l = levprt1, levprt2
+        WRITE (nmessg, 6701) alt(i, l)/1.E3, v_alpha(i, l, n_north), &
+          sigma_alpha(i, l, n_north), sigma_t(i, l), &
+          m_alpha(i, l, n_north)*1.E3, m_alpha(i, l, n_south)*1.E3, &
+          flux_v(i, l)*1.E5, drag_v(i, l)*24.*3600.
+      END DO
+    END IF
+
+  END DO
+
+  RETURN
+  ! -----------------------------------------------------------------------
+END SUBROUTINE hines_print
+
+SUBROUTINE hines_exp(data, data_zmax, alt, alt_exp, iorder, il1, il2, lev1, &
+    lev2, nlons, nlevs)
+  IMPLICIT NONE
+  ! This routine exponentially damps a longitude by altitude array
+  ! of data above a specified altitude.
+
+  ! Aug. 13/95 - C. McLandress
+
+  ! Output arguements:
+
+  ! * DATA = modified data array.
+
+  ! Input arguements:
+
+  ! * DATA    = original data array.
+  ! * ALT     = altitudes.
+  ! * ALT_EXP = altitude above which exponential decay applied.
+  ! * IORDER	= 1 means vertical levels are indexed from top down
+  ! *           (i.e., highest level indexed 1 and lowest level NLEVS);
+  ! *           .NE. 1 highest level is index NLEVS.
+  ! * IL1     = first longitudinal index to use (IL1 >= 1).
+  ! * IL2     = last longitudinal index to use (IL1 <= IL2 <= NLONS).
+  ! * LEV1    = first altitude level to use (LEV1 >=1).
+  ! * LEV2    = last altitude level to use (LEV1 < LEV2 <= NLEVS).
+  ! * NLONS   = number of longitudes.
+  ! * NLEVS   = number of vertical
+
+  ! Input work arrays:
+
+  ! * DATA_ZMAX = data values just above altitude ALT_EXP.
+
+  INTEGER iorder, il1, il2, lev1, lev2, nlons, nlevs
+  REAL alt_exp
+  REAL data(nlons, nlevs), data_zmax(nlons), alt(nlons, nlevs)
+
+  ! Internal variables.
+
+  INTEGER levbot, levtop, lincr, i, l
+  REAL hscale
+  DATA hscale/5.E3/
+  ! -----------------------------------------------------------------------
+
+  ! Index of lowest altitude level (bottom of drag calculation).
+
+  levbot = lev2
+  levtop = lev1
+  lincr = 1
+  IF (iorder/=1) THEN
+    levbot = lev1
+    levtop = lev2
+    lincr = -1
+  END IF
+
+  ! Data values at first level above ALT_EXP.
+
+  DO i = il1, il2
+    DO l = levtop, levbot, lincr
+      IF (alt(i,l)>=alt_exp) THEN
+        data_zmax(i) = data(i, l)
+      END IF
+    END DO
+  END DO
+
+  ! Exponentially damp field above ALT_EXP to model top at L=1.
+
+  DO l = 1, lev2
+    DO i = il1, il2
+      IF (alt(i,l)>=alt_exp) THEN
+        data(i, l) = data_zmax(i)*exp((alt_exp-alt(i,l))/hscale)
+      END IF
+    END DO
+  END DO
+
+  RETURN
+  ! -----------------------------------------------------------------------
+END SUBROUTINE hines_exp
+
+SUBROUTINE vert_smooth(data, work, coeff, nsmooth, il1, il2, lev1, lev2, &
+    nlons, nlevs)
+  IMPLICIT NONE
+  ! Smooth a longitude by altitude array in the vertical over a
+  ! specified number of levels using a three point smoother.
+
+  ! NOTE: input array DATA is modified on output!
+
+  ! Aug. 3/95 - C. McLandress
+
+  ! Output arguement:
+
+  ! * DATA    = smoothed array (on output).
+
+  ! Input arguements:
+
+  ! * DATA    = unsmoothed array of data (on input).
+  ! * WORK    = work array of same dimension as DATA.
+  ! * COEFF   = smoothing coefficient for a 1:COEFF:1 stencil.
+  ! *           (e.g., COEFF = 2 will result in a smoother which
+  ! *           weights the level L gridpoint by two and the two
+  ! *           adjecent levels (L+1 and L-1) by one).
+  ! * NSMOOTH = number of times to smooth in vertical.
+  ! *           (e.g., NSMOOTH=1 means smoothed only once,
+  ! *           NSMOOTH=2 means smoothing repeated twice, etc.)
+  ! * IL1     = first longitudinal index to use (IL1 >= 1).
+  ! * IL2     = last longitudinal index to use (IL1 <= IL2 <= NLONS).
+  ! * LEV1    = first altitude level to use (LEV1 >=1).
+  ! * LEV2    = last altitude level to use (LEV1 < LEV2 <= NLEVS).
+  ! * NLONS   = number of longitudes.
+  ! * NLEVS   = number of vertical levels.
+
+  ! Subroutine arguements.
+
+  INTEGER nsmooth, il1, il2, lev1, lev2, nlons, nlevs
+  REAL coeff
+  REAL data(nlons, nlevs), work(nlons, nlevs)
+
+  ! Internal variables.
+
+  INTEGER i, l, ns, lev1p, lev2m
+  REAL sum_wts
+  ! -----------------------------------------------------------------------
+
+  ! Calculate sum of weights.
+
+  sum_wts = coeff + 2.
+
+  lev1p = lev1 + 1
+  lev2m = lev2 - 1
+
+  ! Smooth NSMOOTH times
+
+  DO ns = 1, nsmooth
+
+    ! Copy data into work array.
+
+    DO l = lev1, lev2
+      DO i = il1, il2
+        work(i, l) = data(i, l)
+      END DO
+    END DO
+
+    ! Smooth array WORK in vertical direction and put into DATA.
+
+    DO l = lev1p, lev2m
+      DO i = il1, il2
+        data(i, l) = (work(i,l+1)+coeff*work(i,l)+work(i,l-1))/sum_wts
+      END DO
+    END DO
+
+  END DO
+
+  RETURN
+  ! -----------------------------------------------------------------------
+END SUBROUTINE vert_smooth
+
+
+
+
+
+
Index: DZ6/trunk/libf/phylmd/histo_o500_pctau.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/histo_o500_pctau.F90	(revision 5267)
+++ 	(revision )
@@ -1,65 +1,0 @@
-
-! $Header$
-
-SUBROUTINE histo_o500_pctau(nbreg, pct_ocean, w, histo, histow, nhisto)
-  USE dimphy
-  IMPLICIT NONE
-
-  INTEGER :: ij, k, l, nw
-  INTEGER :: nreg, nbreg
-  INTEGER, PARAMETER :: kmax = 8, lmax = 8
-  INTEGER, PARAMETER :: kmaxm1 = kmax - 1, lmaxm1 = lmax - 1
-  INTEGER, PARAMETER :: iwmax = 40
-
-  INTEGER, DIMENSION (klon) :: iw
-  REAL, DIMENSION (klon) :: w
-  REAL, PARAMETER :: wmin = -200., pas_w = 10.
-  REAL, DIMENSION (kmaxm1, lmaxm1, iwmax, nbreg) :: histow, nhisto
-  REAL, DIMENSION (klon, kmaxm1, lmaxm1) :: histo
-
-  ! LOGICAL, dimension(klon,nbreg) :: pct_ocean
-  INTEGER, DIMENSION (klon, nbreg) :: pct_ocean
-
-  ! initialisation
-  histow(:, :, :, :) = 0.
-  nhisto(:, :, :, :) = 0.
-
-  ! calcul de l'histogramme de chaque regime dynamique
-  DO nreg = 1, nbreg
-    DO ij = 1, klon
-      iw(ij) = int((w(ij)-wmin)/pas_w) + 1
-      ! IF(pct_ocean(ij,nreg)) THEN
-      ! IF(pct_ocean(ij,nreg).EQ.1) THEN
-      IF (iw(ij)>=1 .AND. iw(ij)<=iwmax) THEN
-        DO l = 1, lmaxm1
-          DO k = 1, kmaxm1
-            IF (histo(ij,k,l)>0.) THEN
-              histow(k, l, iw(ij), nreg) = histow(k, l, iw(ij), nreg) + &
-                histo(ij, k, l)*pct_ocean(ij, nreg)
-              nhisto(k, l, iw(ij), nreg) = nhisto(k, l, iw(ij), nreg) + &
-                pct_ocean(ij, nreg)
-            END IF
-          END DO !k
-        END DO !l
-        ! ELSE IF (iw(ij).LE.0.OR.iw(ij).GT.iwmax) THEN !iw
-        ! PRINT*,'ij,iw=',ij,iw(ij)
-      END IF !iw
-      ! ENDIF !pct_ocean
-    END DO !ij
-    ! normalisation
-    DO nw = 1, iwmax
-      DO l = 1, lmaxm1
-        DO k = 1, kmaxm1
-          IF (nhisto(k,l,nw,nreg)/=0.) THEN
-            histow(k, l, nw, nreg) = 100.*histow(k, l, nw, nreg)/ &
-              nhisto(k, l, nw, nreg)
-            ! PRINT*,'k,l,nw,nreg,histoW',k,l,nw,nreg,
-            ! &     histoW(k,l,nw,nreg)
-          END IF
-        END DO !k
-      END DO !l
-    END DO !nw
-  END DO !nreg
-
-  RETURN
-END SUBROUTINE histo_o500_pctau
Index: /LMDZ6/trunk/libf/phylmd/histo_o500_pctau.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/histo_o500_pctau.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/histo_o500_pctau.f90	(revision 5268)
@@ -0,0 +1,65 @@
+
+! $Header$
+
+SUBROUTINE histo_o500_pctau(nbreg, pct_ocean, w, histo, histow, nhisto)
+  USE dimphy
+  IMPLICIT NONE
+
+  INTEGER :: ij, k, l, nw
+  INTEGER :: nreg, nbreg
+  INTEGER, PARAMETER :: kmax = 8, lmax = 8
+  INTEGER, PARAMETER :: kmaxm1 = kmax - 1, lmaxm1 = lmax - 1
+  INTEGER, PARAMETER :: iwmax = 40
+
+  INTEGER, DIMENSION (klon) :: iw
+  REAL, DIMENSION (klon) :: w
+  REAL, PARAMETER :: wmin = -200., pas_w = 10.
+  REAL, DIMENSION (kmaxm1, lmaxm1, iwmax, nbreg) :: histow, nhisto
+  REAL, DIMENSION (klon, kmaxm1, lmaxm1) :: histo
+
+  ! LOGICAL, dimension(klon,nbreg) :: pct_ocean
+  INTEGER, DIMENSION (klon, nbreg) :: pct_ocean
+
+  ! initialisation
+  histow(:, :, :, :) = 0.
+  nhisto(:, :, :, :) = 0.
+
+  ! calcul de l'histogramme de chaque regime dynamique
+  DO nreg = 1, nbreg
+    DO ij = 1, klon
+      iw(ij) = int((w(ij)-wmin)/pas_w) + 1
+      ! IF(pct_ocean(ij,nreg)) THEN
+      ! IF(pct_ocean(ij,nreg).EQ.1) THEN
+      IF (iw(ij)>=1 .AND. iw(ij)<=iwmax) THEN
+        DO l = 1, lmaxm1
+          DO k = 1, kmaxm1
+            IF (histo(ij,k,l)>0.) THEN
+              histow(k, l, iw(ij), nreg) = histow(k, l, iw(ij), nreg) + &
+                histo(ij, k, l)*pct_ocean(ij, nreg)
+              nhisto(k, l, iw(ij), nreg) = nhisto(k, l, iw(ij), nreg) + &
+                pct_ocean(ij, nreg)
+            END IF
+          END DO !k
+        END DO !l
+        ! ELSE IF (iw(ij).LE.0.OR.iw(ij).GT.iwmax) THEN !iw
+        ! PRINT*,'ij,iw=',ij,iw(ij)
+      END IF !iw
+      ! ENDIF !pct_ocean
+    END DO !ij
+    ! normalisation
+    DO nw = 1, iwmax
+      DO l = 1, lmaxm1
+        DO k = 1, kmaxm1
+          IF (nhisto(k,l,nw,nreg)/=0.) THEN
+            histow(k, l, nw, nreg) = 100.*histow(k, l, nw, nreg)/ &
+              nhisto(k, l, nw, nreg)
+            ! PRINT*,'k,l,nw,nreg,histoW',k,l,nw,nreg,
+            ! &     histoW(k,l,nw,nreg)
+          END IF
+        END DO !k
+      END DO !l
+    END DO !nw
+  END DO !nreg
+
+  RETURN
+END SUBROUTINE histo_o500_pctau
Index: DZ6/trunk/libf/phylmd/homogene.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/homogene.F90	(revision 5267)
+++ 	(revision )
@@ -1,98 +1,0 @@
-
-! $Header$
-
-SUBROUTINE homogene(paprs, q, dq, u, v, du, dv)
-  USE dimphy
-  IMPLICIT NONE
-  ! ==============================================================
-  ! Schema ad hoc du melange vertical pour les vitesses u et v,
-  ! a appliquer apres le schema de convection (fiajc et fiajh).
-
-  ! paprs:input, pression demi-couche (inter-couche)
-  ! q:    input, vapeur d'eau (kg/kg)
-  ! dq:   input, incrementation de vapeur d'eau (de la convection)
-  ! u:    input, vitesse u
-  ! v:    input, vitesse v
-
-  ! du:   output, incrementation pour u
-  ! dv:   output, incrementation pour v
-  ! ==============================================================
-
-  REAL paprs(klon, klev+1)
-  REAL q(klon, klev), dq(klon, klev)
-  REAL u(klon, klev), du(klon, klev)
-  REAL v(klon, klev), dv(klon, klev)
-
-  REAL zm_dq(klon) ! quantite totale de l'eau deplacee
-  REAL zm_q(klon) ! quantite totale de la vapeur d'eau
-  REAL zm_u(klon) ! moyenne de u (brassage parfait et total)
-  REAL zm_v(klon) ! moyenne de v (brassage parfait et total)
-  REAL z_frac(klon) ! fraction du brassage parfait et total
-  REAL zm_dp(klon)
-
-  REAL zx
-  INTEGER i, k
-  REAL frac_max
-  PARAMETER (frac_max=0.1)
-  REAL seuil
-  PARAMETER (seuil=1.0E-10)
-  LOGICAL faisrien
-  PARAMETER (faisrien=.TRUE.)
-
-  DO k = 1, klev
-    DO i = 1, klon
-      du(i, k) = 0.0
-      dv(i, k) = 0.0
-    END DO
-  END DO
-
-  IF (faisrien) RETURN
-
-  DO i = 1, klon
-    zm_dq(i) = 0.
-    zm_q(i) = 0.
-    zm_u(i) = 0.
-    zm_v(i) = 0.
-    zm_dp(i) = 0.
-  END DO
-  DO k = 1, klev
-    DO i = 1, klon
-      IF (abs(dq(i,k))>seuil) THEN
-        zx = paprs(i, k) - paprs(i, k+1)
-        zm_dq(i) = zm_dq(i) + abs(dq(i,k))*zx
-        zm_q(i) = zm_q(i) + q(i, k)*zx
-        zm_dp(i) = zm_dp(i) + zx
-        zm_u(i) = zm_u(i) + u(i, k)*zx
-        zm_v(i) = zm_v(i) + v(i, k)*zx
-      END IF
-    END DO
-  END DO
-
-  ! Hypothese principale: apres la convection, la vitesse de chaque
-  ! couche est composee de deux parties: celle (1-z_frac) de la vitesse
-  ! original et celle (z_frac) de la vitesse moyenne qui serait la
-  ! vitesse de chaque couche si le brassage etait parfait et total.
-  ! La fraction du brassage est calculee par le rapport entre la quantite
-  ! totale de la vapeur d'eau deplacee (ou condensee) et la quantite
-  ! totale de la vapeur d'eau. Et cette fraction est limitee a frac_max
-  ! (Est-ce vraiment raisonnable ? Z.X. Li, le 07-09-1995).
-
-  DO i = 1, klon
-    IF (zm_dp(i)>=1.0E-15 .AND. zm_q(i)>=1.0E-15) THEN
-      z_frac(i) = min(frac_max, zm_dq(i)/zm_q(i))
-      zm_u(i) = zm_u(i)/zm_dp(i)
-      zm_v(i) = zm_v(i)/zm_dp(i)
-    END IF
-  END DO
-  DO k = 1, klev
-    DO i = 1, klon
-      IF (zm_dp(i)>=1.E-15 .AND. zm_q(i)>=1.E-15 .AND. abs(dq(i, &
-          k))>seuil) THEN
-        du(i, k) = u(i, k)*(1.-z_frac(i)) + zm_u(i)*z_frac(i) - u(i, k)
-        dv(i, k) = v(i, k)*(1.-z_frac(i)) + zm_v(i)*z_frac(i) - v(i, k)
-      END IF
-    END DO
-  END DO
-
-  RETURN
-END SUBROUTINE homogene
Index: /LMDZ6/trunk/libf/phylmd/homogene.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/homogene.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/homogene.f90	(revision 5268)
@@ -0,0 +1,98 @@
+
+! $Header$
+
+SUBROUTINE homogene(paprs, q, dq, u, v, du, dv)
+  USE dimphy
+  IMPLICIT NONE
+  ! ==============================================================
+  ! Schema ad hoc du melange vertical pour les vitesses u et v,
+  ! a appliquer apres le schema de convection (fiajc et fiajh).
+
+  ! paprs:input, pression demi-couche (inter-couche)
+  ! q:    input, vapeur d'eau (kg/kg)
+  ! dq:   input, incrementation de vapeur d'eau (de la convection)
+  ! u:    input, vitesse u
+  ! v:    input, vitesse v
+
+  ! du:   output, incrementation pour u
+  ! dv:   output, incrementation pour v
+  ! ==============================================================
+
+  REAL paprs(klon, klev+1)
+  REAL q(klon, klev), dq(klon, klev)
+  REAL u(klon, klev), du(klon, klev)
+  REAL v(klon, klev), dv(klon, klev)
+
+  REAL zm_dq(klon) ! quantite totale de l'eau deplacee
+  REAL zm_q(klon) ! quantite totale de la vapeur d'eau
+  REAL zm_u(klon) ! moyenne de u (brassage parfait et total)
+  REAL zm_v(klon) ! moyenne de v (brassage parfait et total)
+  REAL z_frac(klon) ! fraction du brassage parfait et total
+  REAL zm_dp(klon)
+
+  REAL zx
+  INTEGER i, k
+  REAL frac_max
+  PARAMETER (frac_max=0.1)
+  REAL seuil
+  PARAMETER (seuil=1.0E-10)
+  LOGICAL faisrien
+  PARAMETER (faisrien=.TRUE.)
+
+  DO k = 1, klev
+    DO i = 1, klon
+      du(i, k) = 0.0
+      dv(i, k) = 0.0
+    END DO
+  END DO
+
+  IF (faisrien) RETURN
+
+  DO i = 1, klon
+    zm_dq(i) = 0.
+    zm_q(i) = 0.
+    zm_u(i) = 0.
+    zm_v(i) = 0.
+    zm_dp(i) = 0.
+  END DO
+  DO k = 1, klev
+    DO i = 1, klon
+      IF (abs(dq(i,k))>seuil) THEN
+        zx = paprs(i, k) - paprs(i, k+1)
+        zm_dq(i) = zm_dq(i) + abs(dq(i,k))*zx
+        zm_q(i) = zm_q(i) + q(i, k)*zx
+        zm_dp(i) = zm_dp(i) + zx
+        zm_u(i) = zm_u(i) + u(i, k)*zx
+        zm_v(i) = zm_v(i) + v(i, k)*zx
+      END IF
+    END DO
+  END DO
+
+  ! Hypothese principale: apres la convection, la vitesse de chaque
+  ! couche est composee de deux parties: celle (1-z_frac) de la vitesse
+  ! original et celle (z_frac) de la vitesse moyenne qui serait la
+  ! vitesse de chaque couche si le brassage etait parfait et total.
+  ! La fraction du brassage est calculee par le rapport entre la quantite
+  ! totale de la vapeur d'eau deplacee (ou condensee) et la quantite
+  ! totale de la vapeur d'eau. Et cette fraction est limitee a frac_max
+  ! (Est-ce vraiment raisonnable ? Z.X. Li, le 07-09-1995).
+
+  DO i = 1, klon
+    IF (zm_dp(i)>=1.0E-15 .AND. zm_q(i)>=1.0E-15) THEN
+      z_frac(i) = min(frac_max, zm_dq(i)/zm_q(i))
+      zm_u(i) = zm_u(i)/zm_dp(i)
+      zm_v(i) = zm_v(i)/zm_dp(i)
+    END IF
+  END DO
+  DO k = 1, klev
+    DO i = 1, klon
+      IF (zm_dp(i)>=1.E-15 .AND. zm_q(i)>=1.E-15 .AND. abs(dq(i, &
+          k))>seuil) THEN
+        du(i, k) = u(i, k)*(1.-z_frac(i)) + zm_u(i)*z_frac(i) - u(i, k)
+        dv(i, k) = v(i, k)*(1.-z_frac(i)) + zm_v(i)*z_frac(i) - v(i, k)
+      END IF
+    END DO
+  END DO
+
+  RETURN
+END SUBROUTINE homogene
Index: DZ6/trunk/libf/phylmd/hydrol.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/hydrol.F90	(revision 5267)
+++ 	(revision )
@@ -1,118 +1,0 @@
-
-! $Header$
-
-
-
-SUBROUTINE hydrol(dtime, pctsrf, rain_fall, snow_fall, evap, agesno, tsol, &
-    qsol, snow, runoff)
-  USE dimphy
-  USE indice_sol_mod
-
-  IMPLICIT NONE
-  ! ======================================================================
-  ! Auteur(s): Z.X. Li (LMD/CNRS)
-  ! date: 19940414
-  ! ======================================================================
-
-  ! Traitement de l'hydrologie du sol
-  ! ---------------------------------
-  ! rain_fall: taux de pluie
-  ! snow_fall: taux de neige
-  ! agesno: age de la neige
-  ! evap: taux d'evaporation
-  ! tsol: temperature du sol
-  ! qsol: humidite du sol
-  ! snow: couverture neigeuse
-
-  include "YOMCST.h"
-
-  REAL chasno ! epaisseur du sol: 0.15 m
-  PARAMETER (chasno=3.334E+05/(2.3867E+06*0.15))
-  REAL mx_eau_sol
-  PARAMETER (mx_eau_sol=150.0)
-
-  REAL dtime
-  REAL pctsrf(klon, nbsrf)
-  REAL snow(klon, nbsrf), tsol(klon, nbsrf), qsol(klon, nbsrf)
-  REAL snow_fall(klon), rain_fall(klon), evap(klon)
-  REAL runoff(klon), agesno(klon)
-
-  INTEGER i, is
-  REAL subli, fsno
-  ! -----------------------------------------------------------------------
-  DO i = 1, klon
-
-    runoff(i) = 0.0
-
-    is = is_ter
-    snow(i, is) = snow(i, is) + snow_fall(i)*dtime*pctsrf(i, is)
-    IF (pctsrf(i,is)>epsfra) THEN
-      subli = min(evap(i)*dtime, snow(i,is))
-      snow(i, is) = snow(i, is) - subli
-      fsno = min(max((tsol(i,is)-rtt)/chasno,0.0), snow(i,is))
-      snow(i, is) = snow(i, is) - fsno
-      tsol(i, is) = tsol(i, is) - fsno*chasno
-      qsol(i, is) = qsol(i, is) + (rain_fall(i)-evap(i))*dtime + subli + fsno
-      qsol(i, is) = max(qsol(i,is), 0.0)
-      runoff(i) = runoff(i) + max(qsol(i,is)-mx_eau_sol, 0.0)*pctsrf(i, is)
-      qsol(i, is) = min(qsol(i,is), mx_eau_sol)
-      ! cc         ELSE
-      ! cc            snow(i,is) = 0.0
-      ! cc            qsol(i,is) = 0.0
-      ! cc            tsol(i,is) = 0.0
-    END IF
-
-    is = is_lic
-    snow(i, is) = snow(i, is) + snow_fall(i)*dtime*pctsrf(i, is)
-    IF (pctsrf(i,is)>epsfra) THEN
-      subli = min(evap(i)*dtime, snow(i,is))
-      snow(i, is) = snow(i, is) - subli
-      fsno = min(max((tsol(i,is)-rtt)/chasno,0.0), snow(i,is))
-      snow(i, is) = snow(i, is) - fsno
-      tsol(i, is) = tsol(i, is) - fsno*chasno
-      qsol(i, is) = qsol(i, is) + (rain_fall(i)-evap(i))*dtime + subli + fsno
-      qsol(i, is) = max(qsol(i,is), 0.0)
-      runoff(i) = runoff(i) + max(qsol(i,is)-mx_eau_sol, 0.0)*pctsrf(i, is)
-      qsol(i, is) = min(qsol(i,is), mx_eau_sol)
-      ! je limite la temperature a RTT-1.8 (il faudrait aussi prendre l'eau
-      ! de
-      ! la fonte) (Laurent Li, le 14mars98):
-      ! IM cf GK   tsol(i,is) = MIN(tsol(i,is),RTT-1.8)
-      ! IM cf GK : la glace fond a 0C, non pas a -1.8
-      tsol(i, is) = min(tsol(i,is), rtt)
-
-      ! cc         ELSE
-      ! cc            snow(i,is) = 0.0
-      ! cc            qsol(i,is) = 0.0
-      ! cc            tsol(i,is) = 0.0
-    END IF
-
-    is = is_sic
-    qsol(i, is) = 0.0
-    snow(i, is) = snow(i, is) + snow_fall(i)*dtime*pctsrf(i, is)
-    IF (pctsrf(i,is)>epsfra) THEN
-      subli = min(evap(i)*dtime, snow(i,is))
-      snow(i, is) = snow(i, is) - subli
-      fsno = min(max((tsol(i,is)-rtt)/chasno,0.0), snow(i,is))
-      snow(i, is) = snow(i, is) - fsno
-      tsol(i, is) = tsol(i, is) - fsno*chasno
-      ! je limite la temperature a RTT-1.8 (il faudrait aussi prendre l'eau
-      ! de
-      ! la fonte) (Laurent Li, le 14mars98):
-      ! IM cf GK   tsol(i,is) = MIN(tsol(i,is),RTT-1.8)
-      ! IM cf GK : la glace fond a 0C, non pas a -1.8
-      tsol(i, is) = min(tsol(i,is), rtt)
-
-      ! cc         ELSE
-      ! cc            snow(i,is) = 0.0
-      ! cc            tsol(i,is) = 0.0
-    END IF
-
-    agesno(i) = (agesno(i)+(1.-agesno(i)/50.)*dtime/86400.)* &
-      exp(-1.*max(0.0,snow_fall(i))*dtime/0.3)
-    agesno(i) = max(agesno(i), 0.0)
-
-  END DO
-
-  RETURN
-END SUBROUTINE hydrol
Index: /LMDZ6/trunk/libf/phylmd/hydrol.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/hydrol.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/hydrol.f90	(revision 5268)
@@ -0,0 +1,118 @@
+
+! $Header$
+
+
+
+SUBROUTINE hydrol(dtime, pctsrf, rain_fall, snow_fall, evap, agesno, tsol, &
+    qsol, snow, runoff)
+  USE dimphy
+  USE indice_sol_mod
+
+  IMPLICIT NONE
+  ! ======================================================================
+  ! Auteur(s): Z.X. Li (LMD/CNRS)
+  ! date: 19940414
+  ! ======================================================================
+
+  ! Traitement de l'hydrologie du sol
+  ! ---------------------------------
+  ! rain_fall: taux de pluie
+  ! snow_fall: taux de neige
+  ! agesno: age de la neige
+  ! evap: taux d'evaporation
+  ! tsol: temperature du sol
+  ! qsol: humidite du sol
+  ! snow: couverture neigeuse
+
+  include "YOMCST.h"
+
+  REAL chasno ! epaisseur du sol: 0.15 m
+  PARAMETER (chasno=3.334E+05/(2.3867E+06*0.15))
+  REAL mx_eau_sol
+  PARAMETER (mx_eau_sol=150.0)
+
+  REAL dtime
+  REAL pctsrf(klon, nbsrf)
+  REAL snow(klon, nbsrf), tsol(klon, nbsrf), qsol(klon, nbsrf)
+  REAL snow_fall(klon), rain_fall(klon), evap(klon)
+  REAL runoff(klon), agesno(klon)
+
+  INTEGER i, is
+  REAL subli, fsno
+  ! -----------------------------------------------------------------------
+  DO i = 1, klon
+
+    runoff(i) = 0.0
+
+    is = is_ter
+    snow(i, is) = snow(i, is) + snow_fall(i)*dtime*pctsrf(i, is)
+    IF (pctsrf(i,is)>epsfra) THEN
+      subli = min(evap(i)*dtime, snow(i,is))
+      snow(i, is) = snow(i, is) - subli
+      fsno = min(max((tsol(i,is)-rtt)/chasno,0.0), snow(i,is))
+      snow(i, is) = snow(i, is) - fsno
+      tsol(i, is) = tsol(i, is) - fsno*chasno
+      qsol(i, is) = qsol(i, is) + (rain_fall(i)-evap(i))*dtime + subli + fsno
+      qsol(i, is) = max(qsol(i,is), 0.0)
+      runoff(i) = runoff(i) + max(qsol(i,is)-mx_eau_sol, 0.0)*pctsrf(i, is)
+      qsol(i, is) = min(qsol(i,is), mx_eau_sol)
+      ! cc         ELSE
+      ! cc            snow(i,is) = 0.0
+      ! cc            qsol(i,is) = 0.0
+      ! cc            tsol(i,is) = 0.0
+    END IF
+
+    is = is_lic
+    snow(i, is) = snow(i, is) + snow_fall(i)*dtime*pctsrf(i, is)
+    IF (pctsrf(i,is)>epsfra) THEN
+      subli = min(evap(i)*dtime, snow(i,is))
+      snow(i, is) = snow(i, is) - subli
+      fsno = min(max((tsol(i,is)-rtt)/chasno,0.0), snow(i,is))
+      snow(i, is) = snow(i, is) - fsno
+      tsol(i, is) = tsol(i, is) - fsno*chasno
+      qsol(i, is) = qsol(i, is) + (rain_fall(i)-evap(i))*dtime + subli + fsno
+      qsol(i, is) = max(qsol(i,is), 0.0)
+      runoff(i) = runoff(i) + max(qsol(i,is)-mx_eau_sol, 0.0)*pctsrf(i, is)
+      qsol(i, is) = min(qsol(i,is), mx_eau_sol)
+      ! je limite la temperature a RTT-1.8 (il faudrait aussi prendre l'eau
+      ! de
+      ! la fonte) (Laurent Li, le 14mars98):
+      ! IM cf GK   tsol(i,is) = MIN(tsol(i,is),RTT-1.8)
+      ! IM cf GK : la glace fond a 0C, non pas a -1.8
+      tsol(i, is) = min(tsol(i,is), rtt)
+
+      ! cc         ELSE
+      ! cc            snow(i,is) = 0.0
+      ! cc            qsol(i,is) = 0.0
+      ! cc            tsol(i,is) = 0.0
+    END IF
+
+    is = is_sic
+    qsol(i, is) = 0.0
+    snow(i, is) = snow(i, is) + snow_fall(i)*dtime*pctsrf(i, is)
+    IF (pctsrf(i,is)>epsfra) THEN
+      subli = min(evap(i)*dtime, snow(i,is))
+      snow(i, is) = snow(i, is) - subli
+      fsno = min(max((tsol(i,is)-rtt)/chasno,0.0), snow(i,is))
+      snow(i, is) = snow(i, is) - fsno
+      tsol(i, is) = tsol(i, is) - fsno*chasno
+      ! je limite la temperature a RTT-1.8 (il faudrait aussi prendre l'eau
+      ! de
+      ! la fonte) (Laurent Li, le 14mars98):
+      ! IM cf GK   tsol(i,is) = MIN(tsol(i,is),RTT-1.8)
+      ! IM cf GK : la glace fond a 0C, non pas a -1.8
+      tsol(i, is) = min(tsol(i,is), rtt)
+
+      ! cc         ELSE
+      ! cc            snow(i,is) = 0.0
+      ! cc            tsol(i,is) = 0.0
+    END IF
+
+    agesno(i) = (agesno(i)+(1.-agesno(i)/50.)*dtime/86400.)* &
+      exp(-1.*max(0.0,snow_fall(i))*dtime/0.3)
+    agesno(i) = max(agesno(i), 0.0)
+
+  END DO
+
+  RETURN
+END SUBROUTINE hydrol
Index: DZ6/trunk/libf/phylmd/icefrac_lsc_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/icefrac_lsc_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,58 +1,0 @@
-!
-! $Header$
-!
-MODULE icefrac_lsc_mod
-
-IMPLICIT NONE
-
-CONTAINS
-!*******************************************************************
-
-SUBROUTINE icefrac_lsc(np,temp, sig, icefrac)
-  !
-  ! Compute the ice fraction 1-xliq (see e.g.
-  ! Doutriaux-Boucher & Quaas 2004, section 2.2.)
-  !
-  ! (JBM 3/14 8/14 5/16)
-  
-  USE print_control_mod, ONLY: lunout, prt_level
-  USE lmdz_lscp_ini, ONLY: t_glace_min, t_glace_max, exposant_glace, iflag_t_glace
-  ! lscp_ini contains:
-  ! t_glace_min: if T < Tmin, the cloud is only made of water ice
-  ! t_glace_max: if T > Tmax, the cloud is only made of liquid water
-  ! exposant_glace: controls the sharpness of the transition
-  INTEGER :: np
-  REAL, DIMENSION(np), INTENT(IN) :: temp ! temperature
-  REAL, DIMENSION(np), INTENT(IN) :: sig
-  REAL, DIMENSION(np), INTENT(OUT) :: icefrac
-
-  REAL :: sig0,www,tmin_tmp,liqfrac_tmp
-  INTEGER :: ip
-
-  sig0=0.8
-
-  DO ip=1,np
-     IF (iflag_t_glace.EQ.1) THEN
-       ! Transition to ice close to surface for T<Tmax
-       ! w=1 at the surface and 0 for sig < sig0
-       www=(max(sig(ip)-sig0,0.))/(1.-sig0) 
-     ELSEIF (iflag_t_glace.GE.2) THEN
-       ! No convertion to ice close to surface
-       www = 0.
-     ENDIF
-     tmin_tmp=www*t_glace_max+(1.-www)*t_glace_min
-     liqfrac_tmp=  (temp(ip)-tmin_tmp) / (t_glace_max-tmin_tmp)
-     liqfrac_tmp = MIN(MAX(liqfrac_tmp,0.0),1.0)
-     IF (iflag_t_glace.GE.3) THEN
-       icefrac(ip) = 1.0-liqfrac_tmp**exposant_glace
-     ELSE
-       icefrac(ip) = (1.0-liqfrac_tmp)**exposant_glace
-     ENDIF
-  ENDDO
-
-  RETURN
-END SUBROUTINE icefrac_lsc
-
-!*******************************************************************
-!
-END MODULE icefrac_lsc_mod
Index: /LMDZ6/trunk/libf/phylmd/icefrac_lsc_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/icefrac_lsc_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/icefrac_lsc_mod.f90	(revision 5268)
@@ -0,0 +1,58 @@
+!
+! $Header$
+!
+MODULE icefrac_lsc_mod
+
+IMPLICIT NONE
+
+CONTAINS
+!*******************************************************************
+
+SUBROUTINE icefrac_lsc(np,temp, sig, icefrac)
+  !
+  ! Compute the ice fraction 1-xliq (see e.g.
+  ! Doutriaux-Boucher & Quaas 2004, section 2.2.)
+  !
+  ! (JBM 3/14 8/14 5/16)
+  
+  USE print_control_mod, ONLY: lunout, prt_level
+  USE lmdz_lscp_ini, ONLY: t_glace_min, t_glace_max, exposant_glace, iflag_t_glace
+  ! lscp_ini contains:
+  ! t_glace_min: if T < Tmin, the cloud is only made of water ice
+  ! t_glace_max: if T > Tmax, the cloud is only made of liquid water
+  ! exposant_glace: controls the sharpness of the transition
+  INTEGER :: np
+  REAL, DIMENSION(np), INTENT(IN) :: temp ! temperature
+  REAL, DIMENSION(np), INTENT(IN) :: sig
+  REAL, DIMENSION(np), INTENT(OUT) :: icefrac
+
+  REAL :: sig0,www,tmin_tmp,liqfrac_tmp
+  INTEGER :: ip
+
+  sig0=0.8
+
+  DO ip=1,np
+     IF (iflag_t_glace.EQ.1) THEN
+       ! Transition to ice close to surface for T<Tmax
+       ! w=1 at the surface and 0 for sig < sig0
+       www=(max(sig(ip)-sig0,0.))/(1.-sig0) 
+     ELSEIF (iflag_t_glace.GE.2) THEN
+       ! No convertion to ice close to surface
+       www = 0.
+     ENDIF
+     tmin_tmp=www*t_glace_max+(1.-www)*t_glace_min
+     liqfrac_tmp=  (temp(ip)-tmin_tmp) / (t_glace_max-tmin_tmp)
+     liqfrac_tmp = MIN(MAX(liqfrac_tmp,0.0),1.0)
+     IF (iflag_t_glace.GE.3) THEN
+       icefrac(ip) = 1.0-liqfrac_tmp**exposant_glace
+     ELSE
+       icefrac(ip) = (1.0-liqfrac_tmp)**exposant_glace
+     ENDIF
+  ENDDO
+
+  RETURN
+END SUBROUTINE icefrac_lsc
+
+!*******************************************************************
+!
+END MODULE icefrac_lsc_mod
Index: DZ6/trunk/libf/phylmd/indice_sol_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/indice_sol_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,18 +1,0 @@
-      MODULE indice_sol_mod
-
-            IMPLICIT NONE
-
-            INTEGER, PARAMETER :: nbsrf = 4 ! nombre de sous-fractions pour une maille
-            INTEGER, PARAMETER :: is_ter=1, is_lic=2, is_oce = 3, is_sic=4
-                              ! terre ! ocean ! glacier continental ! glace de mer
-
-            INTEGER, PARAMETER :: is_ave=nbsrf+1 ! valeur moyenne sur l'ensemble des surfaces
-            REAL, PARAMETER :: epsfra=1.0E-05
-
-            CHARACTER(len=3), DIMENSION(nbsrf), PARAMETER :: clnsurf = (/'ter', 'lic', 'oce', 'sic'/)
-!FC 
-           INTEGER, SAVE    :: nvm_orch ! Nombre de type de vegetation ds ORCHIDEE                 
-           !$OMP THREADPRIVATE(nvm_orch)
-
-      END MODULE indice_sol_mod
-
Index: /LMDZ6/trunk/libf/phylmd/indice_sol_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/indice_sol_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/indice_sol_mod.f90	(revision 5268)
@@ -0,0 +1,18 @@
+      MODULE indice_sol_mod
+
+            IMPLICIT NONE
+
+            INTEGER, PARAMETER :: nbsrf = 4 ! nombre de sous-fractions pour une maille
+            INTEGER, PARAMETER :: is_ter=1, is_lic=2, is_oce = 3, is_sic=4
+                              ! terre ! ocean ! glacier continental ! glace de mer
+
+            INTEGER, PARAMETER :: is_ave=nbsrf+1 ! valeur moyenne sur l'ensemble des surfaces
+            REAL, PARAMETER :: epsfra=1.0E-05
+
+            CHARACTER(len=3), DIMENSION(nbsrf), PARAMETER :: clnsurf = (/'ter', 'lic', 'oce', 'sic'/)
+!FC 
+           INTEGER, SAVE    :: nvm_orch ! Nombre de type de vegetation ds ORCHIDEE                 
+           !$OMP THREADPRIVATE(nvm_orch)
+
+      END MODULE indice_sol_mod
+
Index: DZ6/trunk/libf/phylmd/ini_COSP.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/ini_COSP.F90	(revision 5267)
+++ 	(revision )
@@ -1,36 +1,0 @@
-!  A.I avril 2023
-
-  subroutine ini_COSP(ref_liq_cosp0,ref_ice_cosp0,pctsrf_cosp0,zu10m_cosp0,zv10m_cosp0, &
-                      zxtsol_cosp0,zx_rh_cosp0,cldfra_cosp0,rnebcon_cosp0,flwc_cosp0, &
-                      fiwc_cosp0,prfl_cosp0,psfl_cosp0,pmflxr_cosp0,pmflxs_cosp0, &
-                      mr_ozone_cosp0,cldtau_cosp0,cldemi_cosp0,JrNt_cosp0)
-
-! Routine pour initialiser les champs input pour Cosp au  1er appel de celui-ci
-!         Ce 1er appel sert uniquement a definir les axes verticaux pour les 
-!         sortie Cosp
-
-      use dimphy
-      include "ini_COSP.h"
-
-      ! Initialisations pour le 1er passage a Cosp
-        ref_liq_cosp0=1.
-        ref_ice_cosp0=1.
-        pctsrf_cosp0=0.5
-        zu10m_cosp0=1.
-        zv10m_cosp0=1.
-        zxtsol_cosp0=288.
-        zx_rh_cosp0=1.
-        cldfra_cosp0=1.
-        rnebcon_cosp0=0.
-        flwc_cosp0=0.
-        fiwc_cosp0=0.
-        prfl_cosp0(:,1:klev)=0.
-        psfl_cosp0(:,1:klev)=0.
-        pmflxr_cosp0(:,1:klev)=0.
-        pmflxs_cosp0(:,1:klev)=0.
-        mr_ozone_cosp0=0.
-        cldtau_cosp0=0.
-        cldemi_cosp0=0.
-        JrNt_cosp0=0.
-
-     end subroutine ini_COSP
Index: /LMDZ6/trunk/libf/phylmd/ini_COSP.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/ini_COSP.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/ini_COSP.f90	(revision 5268)
@@ -0,0 +1,36 @@
+!  A.I avril 2023
+
+  subroutine ini_COSP(ref_liq_cosp0,ref_ice_cosp0,pctsrf_cosp0,zu10m_cosp0,zv10m_cosp0, &
+                      zxtsol_cosp0,zx_rh_cosp0,cldfra_cosp0,rnebcon_cosp0,flwc_cosp0, &
+                      fiwc_cosp0,prfl_cosp0,psfl_cosp0,pmflxr_cosp0,pmflxs_cosp0, &
+                      mr_ozone_cosp0,cldtau_cosp0,cldemi_cosp0,JrNt_cosp0)
+
+! Routine pour initialiser les champs input pour Cosp au  1er appel de celui-ci
+!         Ce 1er appel sert uniquement a definir les axes verticaux pour les 
+!         sortie Cosp
+
+      use dimphy
+      include "ini_COSP.h"
+
+      ! Initialisations pour le 1er passage a Cosp
+        ref_liq_cosp0=1.
+        ref_ice_cosp0=1.
+        pctsrf_cosp0=0.5
+        zu10m_cosp0=1.
+        zv10m_cosp0=1.
+        zxtsol_cosp0=288.
+        zx_rh_cosp0=1.
+        cldfra_cosp0=1.
+        rnebcon_cosp0=0.
+        flwc_cosp0=0.
+        fiwc_cosp0=0.
+        prfl_cosp0(:,1:klev)=0.
+        psfl_cosp0(:,1:klev)=0.
+        pmflxr_cosp0(:,1:klev)=0.
+        pmflxs_cosp0(:,1:klev)=0.
+        mr_ozone_cosp0=0.
+        cldtau_cosp0=0.
+        cldemi_cosp0=0.
+        JrNt_cosp0=0.
+
+     end subroutine ini_COSP
Index: DZ6/trunk/libf/phylmd/ini_csts.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/ini_csts.F90	(revision 5267)
+++ 	(revision )
@@ -1,187 +1,0 @@
-!SFX_LIC Copyright 1994-2014 CNRS, Meteo-France and Universite Paul Sabatier
-!SFX_LIC This is part of the SURFEX software governed by the CeCILL-C licence
-!SFX_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt  
-!SFX_LIC for details. version 1.
-!     #########
-      SUBROUTINE INI_CSTS 
-!     ##################
-!
-!!****  *INI_CSTS * - routine to initialize the module MODD_CST
-!!
-!!    PURPOSE
-!!    -------
-!       The purpose of this routine is to initialize  the physical constants
-!     stored in  module MODD_CST.
-!      
-!
-!!**  METHOD
-!!    ------
-!!      The physical constants are set to their numerical values 
-!!     
-!!
-!!    EXTERNAL
-!!    --------
-!!      FMLOOK : to retrieve logical unit number associated to a file
-!!
-!!    IMPLICIT ARGUMENTS
-!!    ------------------
-!!      Module MODD_CST     : contains physical constants
-!!
-!!    REFERENCE
-!!    ---------
-!!      Book2 of the documentation (module MODD_CST, routine INI_CSTS)
-!!      
-!!
-!!    AUTHOR
-!!    ------
-!!      V. Ducrocq       * Meteo France *
-!!
-!!    MODIFICATIONS
-!!    -------------
-!!      Original    18/05/94 
-!!      J. Stein    02/01/95  add the volumic mass of liquid water
-!!      J.-P. Pinty 13/12/95  add the water vapor pressure over solid ice
-!!      J. Stein    29/06/97  add XTH00
-!!      V. Masson   05/10/98  add XRHOLI
-!!      C. Mari     31/10/00  add NDAYSEC
-!!      V. Masson   01/03/03  add XCONDI
-!!      A. Voldoire 01/12/09  add XTTSI, XICEC, XTTS for ESM
-!!      J. Escobar  28/03/2014 for pb with emissivity/aerosol reset XSURF_TINY=1.0e-80 in real8 case
-!!
-!-------------------------------------------------------------------------------
-!
-!*       0.    DECLARATIONS
-!              ------------
-!
-USE MODD_CSTS
-!
-!
-!USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK
-!USE PARKIND1  ,ONLY : JPRB
-!
-!USE MODI_INI_CTURBS
-!
-!USE MODI_INI_OCEAN_CSTS
-!
-!USE MODI_INI_SURF_CSTS
-!
-IMPLICIT NONE
-!  
-!-------------------------------------------------------------------------------
-!
-!*       1.     FUNDAMENTAL CONSTANTS
-!               ---------------------
-!
-
-!REAL(KIND=JPRB) :: ZHOOK_HANDLE
-
-!IF (LHOOK) CALL DR_HOOK('INI_CSTS',0,ZHOOK_HANDLE)
-
-!#ifdef SFX_MNH
-!#ifdef MNH_MPI_DOUBLE_PRECISION
-XSURF_TINY    = 1.0e-80
-!#else
-!XSURF_TINY    = TINY    (XSURF_TINY    )
-!#endif
-!#else
-XSURF_TINY    = 1.0e-80
-!#endif
-XSURF_TINY_12 = SQRT    (XSURF_TINY    )
-XSURF_EPSILON = EPSILON (XSURF_EPSILON ) * 10.0
-
-XPI         = 2.*ASIN(1.)
-XKARMAN     = 0.4
-XBOLTZ      = 1.380658E-23
-XLIGHTSPEED = 299792458.
-XPLANCK     = 6.6260755E-34
-XAVOGADRO   = 6.0221367E+23
-!
-!-------------------------------------------------------------------------------
-!
-!*       2.     ASTRONOMICAL CONSTANTS
-!               ----------------------
-!
-XDAY   = 86400.
-XSIYEA = 365.25*XDAY*2.*XPI/ 6.283076
-XSIDAY = XDAY/(1.+XDAY/XSIYEA)
-XOMEGA = 2.*XPI/XSIDAY
-NDAYSEC = 24*3600 ! Number of seconds in a day
-!
-!-------------------------------------------------------------------------------!
-!
-!
-!*       3.     TERRESTRIAL GEOIDE CONSTANTS
-!               ----------------------------
-!
-XRADIUS = 6371229.
-XG      = 9.80665
-!
-!-------------------------------------------------------------------------------
-!
-!*       4.     REFERENCE PRESSURE
-!               -------------------
-!
-XP00 = 1.E5
-XTH00 = 300.
-!-------------------------------------------------------------------------------
-!
-!*       5.     RADIATION CONSTANTS
-!               -------------------
-!
-!JUAN OVERFLOW XSTEFAN = 2.* XPI**5 * XBOLTZ**4 / (15.* XLIGHTSPEED**2 * XPLANCK**3)
-XSTEFAN = ( 2.* XPI**5 / 15. ) * ( (XBOLTZ / XPLANCK)* XBOLTZ ) * (XBOLTZ/(XLIGHTSPEED*XPLANCK))**2 
-XI0     = 1370.
-!
-!-------------------------------------------------------------------------------
-!
-!*       6.     THERMODYNAMIC CONSTANTS
-!               -----------------------
-!
-XMD    = 28.9644E-3
-XMV    = 18.0153E-3
-XRD    = XAVOGADRO * XBOLTZ / XMD
-XRV    = XAVOGADRO * XBOLTZ / XMV
-XCPD   = 7.* XRD /2.
-XCPV   = 4.* XRV
-XRHOLW = 1000.
-XRHOLI = 917.
-XCONDI = 2.22
-XCL    = 4.218E+3
-XCI    = 2.106E+3
-XTT    = 273.16
-XTTSI  = XTT - 1.8
-XICEC  = 0.5
-XTTS   = XTT*(1-XICEC) + XTTSI*XICEC
-XLVTT  = 2.5008E+6
-XLSTT  = 2.8345E+6
-XLMTT  = XLSTT - XLVTT
-XESTT  = 611.14
-XGAMW  = (XCL - XCPV) / XRV
-XBETAW = (XLVTT/XRV) + (XGAMW * XTT)
-XALPW  = LOG(XESTT) + (XBETAW /XTT) + (XGAMW *LOG(XTT))
-XGAMI  = (XCI - XCPV) / XRV
-XBETAI = (XLSTT/XRV) + (XGAMI * XTT)
-XALPI  = LOG(XESTT) + (XBETAI /XTT) + (XGAMI *LOG(XTT))
-!
-!-------------------------------------------------------------------------------
-!
-!*       7.     TURBULENCE CONSTANTS
-!               --------------------
-!
-! CALL INI_CTURBS
-!-------------------------------------------------------------------------------
-!
-!*       8.     OCEAN CONSTANTS
-!               ---------------
-!
-! CALL INI_OCEAN_CSTS
-!
-!*       9.     SURFACE CONSTANTS
-!               -----------------
-!
-! CALL INI_SURF_CSTS
-!IF (LHOOK) CALL DR_HOOK('INI_CSTS',1,ZHOOK_HANDLE)
-!
-!-------------------------------------------------------------------------------
-!
-END SUBROUTINE INI_CSTS 
Index: /LMDZ6/trunk/libf/phylmd/ini_csts.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/ini_csts.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/ini_csts.f90	(revision 5268)
@@ -0,0 +1,187 @@
+!SFX_LIC Copyright 1994-2014 CNRS, Meteo-France and Universite Paul Sabatier
+!SFX_LIC This is part of the SURFEX software governed by the CeCILL-C licence
+!SFX_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt  
+!SFX_LIC for details. version 1.
+!     #########
+      SUBROUTINE INI_CSTS 
+!     ##################
+!
+!!****  *INI_CSTS * - routine to initialize the module MODD_CST
+!!
+!!    PURPOSE
+!!    -------
+!       The purpose of this routine is to initialize  the physical constants
+!     stored in  module MODD_CST.
+!      
+!
+!!**  METHOD
+!!    ------
+!!      The physical constants are set to their numerical values 
+!!     
+!!
+!!    EXTERNAL
+!!    --------
+!!      FMLOOK : to retrieve logical unit number associated to a file
+!!
+!!    IMPLICIT ARGUMENTS
+!!    ------------------
+!!      Module MODD_CST     : contains physical constants
+!!
+!!    REFERENCE
+!!    ---------
+!!      Book2 of the documentation (module MODD_CST, routine INI_CSTS)
+!!      
+!!
+!!    AUTHOR
+!!    ------
+!!      V. Ducrocq       * Meteo France *
+!!
+!!    MODIFICATIONS
+!!    -------------
+!!      Original    18/05/94 
+!!      J. Stein    02/01/95  add the volumic mass of liquid water
+!!      J.-P. Pinty 13/12/95  add the water vapor pressure over solid ice
+!!      J. Stein    29/06/97  add XTH00
+!!      V. Masson   05/10/98  add XRHOLI
+!!      C. Mari     31/10/00  add NDAYSEC
+!!      V. Masson   01/03/03  add XCONDI
+!!      A. Voldoire 01/12/09  add XTTSI, XICEC, XTTS for ESM
+!!      J. Escobar  28/03/2014 for pb with emissivity/aerosol reset XSURF_TINY=1.0e-80 in real8 case
+!!
+!-------------------------------------------------------------------------------
+!
+!*       0.    DECLARATIONS
+!              ------------
+!
+USE MODD_CSTS
+!
+!
+!USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK
+!USE PARKIND1  ,ONLY : JPRB
+!
+!USE MODI_INI_CTURBS
+!
+!USE MODI_INI_OCEAN_CSTS
+!
+!USE MODI_INI_SURF_CSTS
+!
+IMPLICIT NONE
+!  
+!-------------------------------------------------------------------------------
+!
+!*       1.     FUNDAMENTAL CONSTANTS
+!               ---------------------
+!
+
+!REAL(KIND=JPRB) :: ZHOOK_HANDLE
+
+!IF (LHOOK) CALL DR_HOOK('INI_CSTS',0,ZHOOK_HANDLE)
+
+!#ifdef SFX_MNH
+!#ifdef MNH_MPI_DOUBLE_PRECISION
+XSURF_TINY    = 1.0e-80
+!#else
+!XSURF_TINY    = TINY    (XSURF_TINY    )
+!#endif
+!#else
+XSURF_TINY    = 1.0e-80
+!#endif
+XSURF_TINY_12 = SQRT    (XSURF_TINY    )
+XSURF_EPSILON = EPSILON (XSURF_EPSILON ) * 10.0
+
+XPI         = 2.*ASIN(1.)
+XKARMAN     = 0.4
+XBOLTZ      = 1.380658E-23
+XLIGHTSPEED = 299792458.
+XPLANCK     = 6.6260755E-34
+XAVOGADRO   = 6.0221367E+23
+!
+!-------------------------------------------------------------------------------
+!
+!*       2.     ASTRONOMICAL CONSTANTS
+!               ----------------------
+!
+XDAY   = 86400.
+XSIYEA = 365.25*XDAY*2.*XPI/ 6.283076
+XSIDAY = XDAY/(1.+XDAY/XSIYEA)
+XOMEGA = 2.*XPI/XSIDAY
+NDAYSEC = 24*3600 ! Number of seconds in a day
+!
+!-------------------------------------------------------------------------------!
+!
+!
+!*       3.     TERRESTRIAL GEOIDE CONSTANTS
+!               ----------------------------
+!
+XRADIUS = 6371229.
+XG      = 9.80665
+!
+!-------------------------------------------------------------------------------
+!
+!*       4.     REFERENCE PRESSURE
+!               -------------------
+!
+XP00 = 1.E5
+XTH00 = 300.
+!-------------------------------------------------------------------------------
+!
+!*       5.     RADIATION CONSTANTS
+!               -------------------
+!
+!JUAN OVERFLOW XSTEFAN = 2.* XPI**5 * XBOLTZ**4 / (15.* XLIGHTSPEED**2 * XPLANCK**3)
+XSTEFAN = ( 2.* XPI**5 / 15. ) * ( (XBOLTZ / XPLANCK)* XBOLTZ ) * (XBOLTZ/(XLIGHTSPEED*XPLANCK))**2 
+XI0     = 1370.
+!
+!-------------------------------------------------------------------------------
+!
+!*       6.     THERMODYNAMIC CONSTANTS
+!               -----------------------
+!
+XMD    = 28.9644E-3
+XMV    = 18.0153E-3
+XRD    = XAVOGADRO * XBOLTZ / XMD
+XRV    = XAVOGADRO * XBOLTZ / XMV
+XCPD   = 7.* XRD /2.
+XCPV   = 4.* XRV
+XRHOLW = 1000.
+XRHOLI = 917.
+XCONDI = 2.22
+XCL    = 4.218E+3
+XCI    = 2.106E+3
+XTT    = 273.16
+XTTSI  = XTT - 1.8
+XICEC  = 0.5
+XTTS   = XTT*(1-XICEC) + XTTSI*XICEC
+XLVTT  = 2.5008E+6
+XLSTT  = 2.8345E+6
+XLMTT  = XLSTT - XLVTT
+XESTT  = 611.14
+XGAMW  = (XCL - XCPV) / XRV
+XBETAW = (XLVTT/XRV) + (XGAMW * XTT)
+XALPW  = LOG(XESTT) + (XBETAW /XTT) + (XGAMW *LOG(XTT))
+XGAMI  = (XCI - XCPV) / XRV
+XBETAI = (XLSTT/XRV) + (XGAMI * XTT)
+XALPI  = LOG(XESTT) + (XBETAI /XTT) + (XGAMI *LOG(XTT))
+!
+!-------------------------------------------------------------------------------
+!
+!*       7.     TURBULENCE CONSTANTS
+!               --------------------
+!
+! CALL INI_CTURBS
+!-------------------------------------------------------------------------------
+!
+!*       8.     OCEAN CONSTANTS
+!               ---------------
+!
+! CALL INI_OCEAN_CSTS
+!
+!*       9.     SURFACE CONSTANTS
+!               -----------------
+!
+! CALL INI_SURF_CSTS
+!IF (LHOOK) CALL DR_HOOK('INI_CSTS',1,ZHOOK_HANDLE)
+!
+!-------------------------------------------------------------------------------
+!
+END SUBROUTINE INI_CSTS 
Index: DZ6/trunk/libf/phylmd/ini_undefSTD.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/ini_undefSTD.F90	(revision 5267)
+++ 	(revision )
@@ -1,85 +1,0 @@
-
-! $Id$
-
-
-SUBROUTINE ini_undefstd(itap, itapm1)
-  USE dimphy
-  USE phys_state_var_mod ! Variables sauvegardees de la physique
-  USE phys_cal_mod, ONLY: mth_len
-  IMPLICIT NONE
-  include "clesphys.h"
-
-  ! ====================================================================
-
-  ! I. Musat : 09.2004
-
-  ! Initialisation - a des frequences differentes :
-
-  ! 1) des variables moyennees sur la journee "day" ou sur le mois "mth"
-  ! calculees a partir des valeurs "instantannees" de la physique
-
-  ! 2) des variables moyennes mensuelles "NMC" calculees a partir des val.
-  ! toutes les 6 heures
-
-  ! nout=1 !var. journaliere "day" moyenne sur tous les pas de temps
-  ! ! de la physique
-  ! nout=2 !var. mensuelle "mth" moyennee sur tous les pas de temps
-  ! ! de la physique
-  ! nout=3 !var. mensuelle "NMC" moyennee toutes les 6heures
-
-  ! NB: mettre "inst(X)" dans le write_hist*NMC.h !
-  ! ====================================================================
-
-  ! ym INCLUDE "dimphy.h"
-  ! variables Input/Output
-  ! INTEGER nlevSTD, klevSTD, itap
-  INTEGER itap, itapm1
-  ! PARAMETER(klevSTD=17)
-  ! REAL dtime
-
-  ! variables locales
-  ! INTEGER i, k, nout, n
-  INTEGER i, k, n
-  ! PARAMETER(nout=3) !nout=1 day/nout=2 mth/nout=3 NMC
-  ! REAL freq_outNMC(nout)
-  REAL un_jour
-  PARAMETER (un_jour=86400.)
-
-  ! variables Output
-  ! REAL tnondef(klon,klevSTD,nout)
-  ! REAL tsumSTD(klon,klevSTD,nout)
-
-  DO n = 1, nout
-
-    ! initialisation variables en debut du mois, de la journee ou des 6h
-
-    IF (n==1 .AND. itap-itapm1==1 .OR. n>1 .AND. mod(itap,nint( &
-        freq_outnmc(n)/phys_tstep))==1) THEN
-      ! print*,'ini_undefSTD n itap',n,itap
-      DO k = 1, nlevstd
-        DO i = 1, klon
-          tnondef(i, k, n) = 0.
-          tsumstd(i, k, n) = 0.
-          usumstd(i, k, n) = 0.
-          vsumstd(i, k, n) = 0.
-          wsumstd(i, k, n) = 0.
-          phisumstd(i, k, n) = 0.
-          qsumstd(i, k, n) = 0.
-          rhsumstd(i, k, n) = 0.
-          uvsumstd(i, k, n) = 0.
-          vqsumstd(i, k, n) = 0.
-          vtsumstd(i, k, n) = 0.
-          wqsumstd(i, k, n) = 0.
-          vphisumstd(i, k, n) = 0.
-          wtsumstd(i, k, n) = 0.
-          u2sumstd(i, k, n) = 0.
-          v2sumstd(i, k, n) = 0.
-          t2sumstd(i, k, n) = 0.
-          o3sumstd(i, k, n) = 0.
-          o3daysumstd(i, k, n) = 0.
-        END DO !i
-      END DO !k
-    END IF !
-  END DO !n
-  RETURN
-END SUBROUTINE ini_undefstd
Index: /LMDZ6/trunk/libf/phylmd/ini_undefSTD.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/ini_undefSTD.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/ini_undefSTD.f90	(revision 5268)
@@ -0,0 +1,85 @@
+
+! $Id$
+
+
+SUBROUTINE ini_undefstd(itap, itapm1)
+  USE dimphy
+  USE phys_state_var_mod ! Variables sauvegardees de la physique
+  USE phys_cal_mod, ONLY: mth_len
+  IMPLICIT NONE
+  include "clesphys.h"
+
+  ! ====================================================================
+
+  ! I. Musat : 09.2004
+
+  ! Initialisation - a des frequences differentes :
+
+  ! 1) des variables moyennees sur la journee "day" ou sur le mois "mth"
+  ! calculees a partir des valeurs "instantannees" de la physique
+
+  ! 2) des variables moyennes mensuelles "NMC" calculees a partir des val.
+  ! toutes les 6 heures
+
+  ! nout=1 !var. journaliere "day" moyenne sur tous les pas de temps
+  ! ! de la physique
+  ! nout=2 !var. mensuelle "mth" moyennee sur tous les pas de temps
+  ! ! de la physique
+  ! nout=3 !var. mensuelle "NMC" moyennee toutes les 6heures
+
+  ! NB: mettre "inst(X)" dans le write_hist*NMC.h !
+  ! ====================================================================
+
+  ! ym INCLUDE "dimphy.h"
+  ! variables Input/Output
+  ! INTEGER nlevSTD, klevSTD, itap
+  INTEGER itap, itapm1
+  ! PARAMETER(klevSTD=17)
+  ! REAL dtime
+
+  ! variables locales
+  ! INTEGER i, k, nout, n
+  INTEGER i, k, n
+  ! PARAMETER(nout=3) !nout=1 day/nout=2 mth/nout=3 NMC
+  ! REAL freq_outNMC(nout)
+  REAL un_jour
+  PARAMETER (un_jour=86400.)
+
+  ! variables Output
+  ! REAL tnondef(klon,klevSTD,nout)
+  ! REAL tsumSTD(klon,klevSTD,nout)
+
+  DO n = 1, nout
+
+    ! initialisation variables en debut du mois, de la journee ou des 6h
+
+    IF (n==1 .AND. itap-itapm1==1 .OR. n>1 .AND. mod(itap,nint( &
+        freq_outnmc(n)/phys_tstep))==1) THEN
+      ! print*,'ini_undefSTD n itap',n,itap
+      DO k = 1, nlevstd
+        DO i = 1, klon
+          tnondef(i, k, n) = 0.
+          tsumstd(i, k, n) = 0.
+          usumstd(i, k, n) = 0.
+          vsumstd(i, k, n) = 0.
+          wsumstd(i, k, n) = 0.
+          phisumstd(i, k, n) = 0.
+          qsumstd(i, k, n) = 0.
+          rhsumstd(i, k, n) = 0.
+          uvsumstd(i, k, n) = 0.
+          vqsumstd(i, k, n) = 0.
+          vtsumstd(i, k, n) = 0.
+          wqsumstd(i, k, n) = 0.
+          vphisumstd(i, k, n) = 0.
+          wtsumstd(i, k, n) = 0.
+          u2sumstd(i, k, n) = 0.
+          v2sumstd(i, k, n) = 0.
+          t2sumstd(i, k, n) = 0.
+          o3sumstd(i, k, n) = 0.
+          o3daysumstd(i, k, n) = 0.
+        END DO !i
+      END DO !k
+    END IF !
+  END DO !n
+  RETURN
+END SUBROUTINE ini_undefstd
Index: DZ6/trunk/libf/phylmd/ini_wake.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/ini_wake.F90	(revision 5267)
+++ 	(revision )
@@ -1,88 +1,0 @@
-
-! $Id$
-
-SUBROUTINE ini_wake(wape, fip, it_wape_prescr, wape_prescr, fip_prescr, &
-    alp_bl_prescr, ale_bl_prescr)
-  USE print_control_mod, ONLY: lunout
-  IMPLICIT NONE
-  ! **************************************************************
-  ! *
-  ! INI_WAKE : variables d'initialisation de la poche    *
-  ! froide, necessaires au declenchement      *
-  ! de la convection.                         *
-  ! *
-  ! *
-  ! **************************************************************
-  ! Arguments
-  ! =========
-  ! Input
-  ! -----
-  ! wape           : valeur de l'energie potentielle de la poche (WAPE)
-  ! dans l'etat initial
-  ! fip            : valeur de la puissance incidente sur le front (FIP)
-  ! dans l'etat initial
-  ! Output
-  ! ------
-  ! it_wape_prescr : nombre de pas de temps pendant lesquels la WAPE
-  ! doit etre imposee.
-  ! wape_prescr    : valeur prescrite de la WAPE.
-  ! fip_prescr     : valeur prescrite de la FIP.
-  ! ale_bl_prescr  : valeur prescrite de la Ale de PBL.
-  ! alp_bl_prescr  : valeur prescrite de la Alp de PBL.
-
-  ! Variables internes
-  ! ==================
-  ! it = nbre de pas de temps lu
-  ! w  = WAPE lue
-  ! f  = FIP lue
-  ! alebl  = Ale de PBL lue
-  ! alpbl  = Alp de PBL lue
-
-  ! declarations
-  REAL wape, fip, wape_prescr, fip_prescr
-  INTEGER it_wape_prescr
-  REAL ale_bl_prescr
-  REAL alp_bl_prescr
-  REAL it
-  REAL w,f,alebl,alpbl
-
-  ! FH A mettre si besoin dans physiq.def
-  ! FH : voir avec JYG
-  it = 0.
-  w = 4.
-  f = 0.1
-  alebl = 4.
-  alpbl = 0.1
-
-  ! CR: on rajoute ale et alp de la PBL precrits
-  OPEN (99, FILE='ini_wake_param.data', FORM='formatted', STATUS='old', &
-    ERR=902)
-  READ (99, *) it
-  READ (99, *) w
-  READ (99, *) f
-  READ (99, *, END=901) alebl
-  READ (99, *, END=901) alpbl
-901 CLOSE (99)
-902 CONTINUE
-
-  WRITE (lunout, *) ' it,wape ', it, wape
-  it_wape_prescr = it
-  IF (w<0) THEN
-    wape_prescr = wape
-    fip_prescr = fip
-  ELSE
-    wape_prescr = w
-    fip_prescr = f
-  END IF
-
-  WRITE (lunout, *) ' alebl, alpbl ', alebl, alpbl
-  ale_bl_prescr = alebl
-  alp_bl_prescr = alpbl
-  PRINT *, 'Initialisation de la poche : WAPE, FIP imposees =', wape_prescr, &
-    fip_prescr
-  PRINT *, '                   pendant ', it_wape_prescr, ' steps'
-
-  PRINT *, 'Initialisation de la BL: ALP, ALE imposees =', alp_bl_prescr, &
-    ale_bl_prescr
-  RETURN
-END SUBROUTINE ini_wake
Index: /LMDZ6/trunk/libf/phylmd/ini_wake.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/ini_wake.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/ini_wake.f90	(revision 5268)
@@ -0,0 +1,88 @@
+
+! $Id$
+
+SUBROUTINE ini_wake(wape, fip, it_wape_prescr, wape_prescr, fip_prescr, &
+    alp_bl_prescr, ale_bl_prescr)
+  USE print_control_mod, ONLY: lunout
+  IMPLICIT NONE
+  ! **************************************************************
+  ! *
+  ! INI_WAKE : variables d'initialisation de la poche    *
+  ! froide, necessaires au declenchement      *
+  ! de la convection.                         *
+  ! *
+  ! *
+  ! **************************************************************
+  ! Arguments
+  ! =========
+  ! Input
+  ! -----
+  ! wape           : valeur de l'energie potentielle de la poche (WAPE)
+  ! dans l'etat initial
+  ! fip            : valeur de la puissance incidente sur le front (FIP)
+  ! dans l'etat initial
+  ! Output
+  ! ------
+  ! it_wape_prescr : nombre de pas de temps pendant lesquels la WAPE
+  ! doit etre imposee.
+  ! wape_prescr    : valeur prescrite de la WAPE.
+  ! fip_prescr     : valeur prescrite de la FIP.
+  ! ale_bl_prescr  : valeur prescrite de la Ale de PBL.
+  ! alp_bl_prescr  : valeur prescrite de la Alp de PBL.
+
+  ! Variables internes
+  ! ==================
+  ! it = nbre de pas de temps lu
+  ! w  = WAPE lue
+  ! f  = FIP lue
+  ! alebl  = Ale de PBL lue
+  ! alpbl  = Alp de PBL lue
+
+  ! declarations
+  REAL wape, fip, wape_prescr, fip_prescr
+  INTEGER it_wape_prescr
+  REAL ale_bl_prescr
+  REAL alp_bl_prescr
+  REAL it
+  REAL w,f,alebl,alpbl
+
+  ! FH A mettre si besoin dans physiq.def
+  ! FH : voir avec JYG
+  it = 0.
+  w = 4.
+  f = 0.1
+  alebl = 4.
+  alpbl = 0.1
+
+  ! CR: on rajoute ale et alp de la PBL precrits
+  OPEN (99, FILE='ini_wake_param.data', FORM='formatted', STATUS='old', &
+    ERR=902)
+  READ (99, *) it
+  READ (99, *) w
+  READ (99, *) f
+  READ (99, *, END=901) alebl
+  READ (99, *, END=901) alpbl
+901 CLOSE (99)
+902 CONTINUE
+
+  WRITE (lunout, *) ' it,wape ', it, wape
+  it_wape_prescr = it
+  IF (w<0) THEN
+    wape_prescr = wape
+    fip_prescr = fip
+  ELSE
+    wape_prescr = w
+    fip_prescr = f
+  END IF
+
+  WRITE (lunout, *) ' alebl, alpbl ', alebl, alpbl
+  ale_bl_prescr = alebl
+  alp_bl_prescr = alpbl
+  PRINT *, 'Initialisation de la poche : WAPE, FIP imposees =', wape_prescr, &
+    fip_prescr
+  PRINT *, '                   pendant ', it_wape_prescr, ' steps'
+
+  PRINT *, 'Initialisation de la BL: ALP, ALE imposees =', alp_bl_prescr, &
+    ale_bl_prescr
+  RETURN
+END SUBROUTINE ini_wake
Index: DZ6/trunk/libf/phylmd/inifis_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/inifis_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,81 +1,0 @@
-! $Id$
-MODULE inifis_mod
-
-CONTAINS
-
-  SUBROUTINE inifis(punjours, prad, pg, pr, pcpp)
-  ! Initialize some physical constants and settings
-  USE init_print_control_mod, ONLY : init_print_control
-  USE print_control_mod, ONLY: lunout
-  IMPLICIT NONE
-
-  include "YOMCST.h"
-  REAL,INTENT(IN) :: prad, pg, pr, pcpp, punjours
-
-  CHARACTER (LEN=20) :: modname = 'inifis'
-  CHARACTER (LEN=80) :: abort_message
-
-  ! Initialize flags lunout, prt_level, debug
-  CALL init_print_control
-
-  ! suphel => initialize some physical constants (orbital parameters,
-  !           geoid, gravity, thermodynamical constants, etc.) in the
-  !           physics
-  CALL suphel
-
-  ! check that physical constants set in 'suphel' are coherent
-  ! with values set in the dynamics:
-  IF (rday/=punjours) THEN
-    WRITE (lunout, *) 'inifis: length of day discrepancy!!!'
-    WRITE (lunout, *) '  in the dynamics punjours=', punjours
-    WRITE (lunout, *) '   but in the physics RDAY=', rday
-    IF (abs(rday-punjours)>0.01*punjours) THEN
-        ! stop here if the relative difference is more than 1%
-      abort_message = 'length of day discrepancy'
-      CALL abort_physic(modname, abort_message, 1)
-    END IF
-  END IF
-  IF (rg/=pg) THEN
-    WRITE (lunout, *) 'inifis: gravity discrepancy !!!'
-    WRITE (lunout, *) '     in the dynamics pg=', pg
-    WRITE (lunout, *) '  but in the physics RG=', rg
-    IF (abs(rg-pg)>0.01*pg) THEN
-        ! stop here if the relative difference is more than 1%
-      abort_message = 'gravity discrepancy'
-      CALL abort_physic(modname, abort_message, 1)
-    END IF
-  END IF
-  IF (ra/=prad) THEN
-    WRITE (lunout, *) 'inifis: planet radius discrepancy !!!'
-    WRITE (lunout, *) '   in the dynamics prad=', prad
-    WRITE (lunout, *) '  but in the physics RA=', ra
-    IF (abs(ra-prad)>0.01*prad) THEN
-        ! stop here if the relative difference is more than 1%
-      abort_message = 'planet radius discrepancy'
-      CALL abort_physic(modname, abort_message, 1)
-    END IF
-  END IF
-  IF (rd/=pr) THEN
-    WRITE (lunout, *) 'inifis: reduced gas constant discrepancy !!!'
-    WRITE (lunout, *) '     in the dynamics pr=', pr
-    WRITE (lunout, *) '  but in the physics RD=', rd
-    IF (abs(rd-pr)>0.01*pr) THEN
-        ! stop here if the relative difference is more than 1%
-      abort_message = 'reduced gas constant discrepancy'
-      CALL abort_physic(modname, abort_message, 1)
-    END IF
-  END IF
-  IF (rcpd/=pcpp) THEN
-    WRITE (lunout, *) 'inifis: specific heat discrepancy !!!'
-    WRITE (lunout, *) '     in the dynamics pcpp=', pcpp
-    WRITE (lunout, *) '  but in the physics RCPD=', rcpd
-    IF (abs(rcpd-pcpp)>0.01*pcpp) THEN
-        ! stop here if the relative difference is more than 1%
-      abort_message = 'specific heat discrepancy'
-      CALL abort_physic(modname, abort_message, 1)
-    END IF
-  END IF
-
-  END SUBROUTINE inifis
-  
-END MODULE inifis_mod
Index: /LMDZ6/trunk/libf/phylmd/inifis_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/inifis_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/inifis_mod.f90	(revision 5268)
@@ -0,0 +1,81 @@
+! $Id$
+MODULE inifis_mod
+
+CONTAINS
+
+  SUBROUTINE inifis(punjours, prad, pg, pr, pcpp)
+  ! Initialize some physical constants and settings
+  USE init_print_control_mod, ONLY : init_print_control
+  USE print_control_mod, ONLY: lunout
+  IMPLICIT NONE
+
+  include "YOMCST.h"
+  REAL,INTENT(IN) :: prad, pg, pr, pcpp, punjours
+
+  CHARACTER (LEN=20) :: modname = 'inifis'
+  CHARACTER (LEN=80) :: abort_message
+
+  ! Initialize flags lunout, prt_level, debug
+  CALL init_print_control
+
+  ! suphel => initialize some physical constants (orbital parameters,
+  !           geoid, gravity, thermodynamical constants, etc.) in the
+  !           physics
+  CALL suphel
+
+  ! check that physical constants set in 'suphel' are coherent
+  ! with values set in the dynamics:
+  IF (rday/=punjours) THEN
+    WRITE (lunout, *) 'inifis: length of day discrepancy!!!'
+    WRITE (lunout, *) '  in the dynamics punjours=', punjours
+    WRITE (lunout, *) '   but in the physics RDAY=', rday
+    IF (abs(rday-punjours)>0.01*punjours) THEN
+        ! stop here if the relative difference is more than 1%
+      abort_message = 'length of day discrepancy'
+      CALL abort_physic(modname, abort_message, 1)
+    END IF
+  END IF
+  IF (rg/=pg) THEN
+    WRITE (lunout, *) 'inifis: gravity discrepancy !!!'
+    WRITE (lunout, *) '     in the dynamics pg=', pg
+    WRITE (lunout, *) '  but in the physics RG=', rg
+    IF (abs(rg-pg)>0.01*pg) THEN
+        ! stop here if the relative difference is more than 1%
+      abort_message = 'gravity discrepancy'
+      CALL abort_physic(modname, abort_message, 1)
+    END IF
+  END IF
+  IF (ra/=prad) THEN
+    WRITE (lunout, *) 'inifis: planet radius discrepancy !!!'
+    WRITE (lunout, *) '   in the dynamics prad=', prad
+    WRITE (lunout, *) '  but in the physics RA=', ra
+    IF (abs(ra-prad)>0.01*prad) THEN
+        ! stop here if the relative difference is more than 1%
+      abort_message = 'planet radius discrepancy'
+      CALL abort_physic(modname, abort_message, 1)
+    END IF
+  END IF
+  IF (rd/=pr) THEN
+    WRITE (lunout, *) 'inifis: reduced gas constant discrepancy !!!'
+    WRITE (lunout, *) '     in the dynamics pr=', pr
+    WRITE (lunout, *) '  but in the physics RD=', rd
+    IF (abs(rd-pr)>0.01*pr) THEN
+        ! stop here if the relative difference is more than 1%
+      abort_message = 'reduced gas constant discrepancy'
+      CALL abort_physic(modname, abort_message, 1)
+    END IF
+  END IF
+  IF (rcpd/=pcpp) THEN
+    WRITE (lunout, *) 'inifis: specific heat discrepancy !!!'
+    WRITE (lunout, *) '     in the dynamics pcpp=', pcpp
+    WRITE (lunout, *) '  but in the physics RCPD=', rcpd
+    IF (abs(rcpd-pcpp)>0.01*pcpp) THEN
+        ! stop here if the relative difference is more than 1%
+      abort_message = 'specific heat discrepancy'
+      CALL abort_physic(modname, abort_message, 1)
+    END IF
+  END IF
+
+  END SUBROUTINE inifis
+  
+END MODULE inifis_mod
Index: DZ6/trunk/libf/phylmd/iniorbit.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/iniorbit.F90	(revision 5267)
+++ 	(revision )
@@ -1,103 +1,0 @@
-SUBROUTINE iniorbit(paphelie, pperiheli, pyear_day, pperi_day, pobliq)
-  IMPLICIT NONE
-
-  ! =======================================================================
-
-  ! Auteur:
-  ! -------
-  ! Frederic Hourdin      22 Fevrier 1991
-
-  ! Objet:
-  ! ------
-  ! Initialisation du sous programme orbite qui calcule
-  ! a une date donnee de l'annee de duree year_day commencant
-  ! a l'equinoxe de printemps et dont le perihelie se situe
-  ! a la date peri_day, la distance au soleil et la declinaison.
-
-  ! Interface:
-  ! ----------
-  ! - Doit etre appele avant d'utiliser orbite.
-  ! - initialise une partie du common planete.h
-
-  ! Arguments:
-  ! ----------
-
-  ! Input:
-  ! ------
-  ! aphelie       \   aphelie et perihelie de l'orbite
-  ! periheli      /   en millions de kilometres.
-
-  ! =======================================================================
-
-  ! -----------------------------------------------------------------------
-  ! Declarations:
-  ! -------------
-
-  include "planete.h"
-  include "YOMCST.h"
-
-  ! Arguments:
-  ! ----------
-
-  REAL paphelie, pperiheli, pyear_day, pperi_day, pobliq
-
-  ! Local:
-  ! ------
-
-  REAL zxref, zanom, zz, zx0, zdx, pi
-  INTEGER iter
-
-  ! -----------------------------------------------------------------------
-
-  pi = 2.*asin(1.)
-
-  aphelie = paphelie
-  periheli = pperiheli
-  year_day = pyear_day
-  obliquit = pobliq
-  peri_day = pperi_day
-
-  PRINT *, 'Perihelie en Mkm  ', periheli
-  PRINT *, 'Aphelie  en Mkm   ', aphelie
-  PRINT *, 'obliquite en degres  :', obliquit
-  PRINT *, 'Jours dans l annee : ', year_day
-  PRINT *, 'Date perihelie : ', peri_day
-  unitastr = 149.597870
-  e_elips = (aphelie-periheli)/(periheli+aphelie)
-  p_elips = 0.5*(periheli+aphelie)*(1-e_elips*e_elips)/unitastr
-
-  PRINT *, 'e_elips', e_elips
-  PRINT *, 'p_elips', p_elips
-
-  ! -----------------------------------------------------------------------
-  ! calcul de l'angle polaire et de la distance au soleil :
-  ! -------------------------------------------------------
-
-  ! calcul de l'zanomalie moyenne
-
-  zz = (year_day-pperi_day)/year_day
-  zanom = 2.*pi*(zz-nint(zz))
-  zxref = abs(zanom)
-  PRINT *, 'zanom  ', zanom
-
-  ! resolution de l'equation horaire  zx0 - e * sin (zx0) = zxref
-  ! methode de Newton
-
-  zx0 = zxref + r_ecc*sin(zxref)
-  DO iter = 1, 100
-    zdx = -(zx0-r_ecc*sin(zx0)-zxref)/(1.-r_ecc*cos(zx0))
-    IF (abs(zdx)<=(1.E-12)) GO TO 120
-    zx0 = zx0 + zdx
-  END DO
-120 CONTINUE
-  zx0 = zx0 + zdx
-  IF (zanom<0.) zx0 = -zx0
-  PRINT *, 'zx0   ', zx0
-
-  ! zteta est la longitude solaire
-
-  timeperi = 2.*atan(sqrt((1.+r_ecc)/(1.-r_ecc))*tan(zx0/2.))
-  PRINT *, 'longitude solaire du perihelie timeperi = ', timeperi
-
-  RETURN
-END SUBROUTINE iniorbit
Index: /LMDZ6/trunk/libf/phylmd/iniorbit.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/iniorbit.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/iniorbit.f90	(revision 5268)
@@ -0,0 +1,103 @@
+SUBROUTINE iniorbit(paphelie, pperiheli, pyear_day, pperi_day, pobliq)
+  IMPLICIT NONE
+
+  ! =======================================================================
+
+  ! Auteur:
+  ! -------
+  ! Frederic Hourdin      22 Fevrier 1991
+
+  ! Objet:
+  ! ------
+  ! Initialisation du sous programme orbite qui calcule
+  ! a une date donnee de l'annee de duree year_day commencant
+  ! a l'equinoxe de printemps et dont le perihelie se situe
+  ! a la date peri_day, la distance au soleil et la declinaison.
+
+  ! Interface:
+  ! ----------
+  ! - Doit etre appele avant d'utiliser orbite.
+  ! - initialise une partie du common planete.h
+
+  ! Arguments:
+  ! ----------
+
+  ! Input:
+  ! ------
+  ! aphelie       \   aphelie et perihelie de l'orbite
+  ! periheli      /   en millions de kilometres.
+
+  ! =======================================================================
+
+  ! -----------------------------------------------------------------------
+  ! Declarations:
+  ! -------------
+
+  include "planete.h"
+  include "YOMCST.h"
+
+  ! Arguments:
+  ! ----------
+
+  REAL paphelie, pperiheli, pyear_day, pperi_day, pobliq
+
+  ! Local:
+  ! ------
+
+  REAL zxref, zanom, zz, zx0, zdx, pi
+  INTEGER iter
+
+  ! -----------------------------------------------------------------------
+
+  pi = 2.*asin(1.)
+
+  aphelie = paphelie
+  periheli = pperiheli
+  year_day = pyear_day
+  obliquit = pobliq
+  peri_day = pperi_day
+
+  PRINT *, 'Perihelie en Mkm  ', periheli
+  PRINT *, 'Aphelie  en Mkm   ', aphelie
+  PRINT *, 'obliquite en degres  :', obliquit
+  PRINT *, 'Jours dans l annee : ', year_day
+  PRINT *, 'Date perihelie : ', peri_day
+  unitastr = 149.597870
+  e_elips = (aphelie-periheli)/(periheli+aphelie)
+  p_elips = 0.5*(periheli+aphelie)*(1-e_elips*e_elips)/unitastr
+
+  PRINT *, 'e_elips', e_elips
+  PRINT *, 'p_elips', p_elips
+
+  ! -----------------------------------------------------------------------
+  ! calcul de l'angle polaire et de la distance au soleil :
+  ! -------------------------------------------------------
+
+  ! calcul de l'zanomalie moyenne
+
+  zz = (year_day-pperi_day)/year_day
+  zanom = 2.*pi*(zz-nint(zz))
+  zxref = abs(zanom)
+  PRINT *, 'zanom  ', zanom
+
+  ! resolution de l'equation horaire  zx0 - e * sin (zx0) = zxref
+  ! methode de Newton
+
+  zx0 = zxref + r_ecc*sin(zxref)
+  DO iter = 1, 100
+    zdx = -(zx0-r_ecc*sin(zx0)-zxref)/(1.-r_ecc*cos(zx0))
+    IF (abs(zdx)<=(1.E-12)) GO TO 120
+    zx0 = zx0 + zdx
+  END DO
+120 CONTINUE
+  zx0 = zx0 + zdx
+  IF (zanom<0.) zx0 = -zx0
+  PRINT *, 'zx0   ', zx0
+
+  ! zteta est la longitude solaire
+
+  timeperi = 2.*atan(sqrt((1.+r_ecc)/(1.-r_ecc))*tan(zx0/2.))
+  PRINT *, 'longitude solaire du perihelie timeperi = ', timeperi
+
+  RETURN
+END SUBROUTINE iniorbit
Index: DZ6/trunk/libf/phylmd/init_be.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/init_be.F90	(revision 5267)
+++ 	(revision )
@@ -1,564 +1,0 @@
-!$Id $
-
-SUBROUTINE init_be(pctsrf,pplay,masktr,tautr,vdeptr,scavtr,srcbe)
-!!!SUBROUTINE init_be(pctsrf,masktr,tautr,vdeptr,scavtr,srcbe)
-
-  USE dimphy
-  USE indice_sol_mod
-  USE geometry_mod, ONLY : longitude, latitude
-    
-  IMPLICIT NONE 
-!=====================================================================
-! Objet : prescription d'une source de Beryllium 7 
-!         pour 19 niveaux verticaux
-!        (d'apres le diagramme de Lal and Peters, 1967)
-!
-!
-! written by : O. Coindreau (CEA/LDG) 05/2005
-! last modified by : A. Jamelot (LMD/CEA)  04/03/2009 
-!=====================================================================
-
-  INCLUDE "YOMCST.h"
-  INCLUDE "YOECUMF.h" 
-
-!
-! Input Arguments
-!
-  REAL,DIMENSION(klon,nbsrf),INTENT(IN) :: pctsrf !Pourcentage de sol (f(nature du sol))
-  REAL,DIMENSION(klon,klev), INTENT(IN) :: pplay  ! Pressions en milieu de couches
-!
-! Output Arguments
-!
-  REAL,DIMENSION(klon),INTENT(OUT)      :: masktr ! Masque de l'echange avec la surface (possible => 1 )
-  REAL,INTENT(OUT)                      :: tautr  ! Constante de decroissance radioactive
-  REAL,INTENT(OUT)                      :: vdeptr ! Vitesse de depot sec dans la couche Brownienne
-  REAL,INTENT(OUT)                      :: scavtr ! Coefficient de lessivage
-  REAL,DIMENSION(klon,klev),INTENT(OUT) :: srcbe  ! source volumique de 7Be      
-!
-! Local Variables
-!
-!!!  INTEGER              :: iref      ! numero d'un point oceanique donnant la grille de pression de reference
-  REAL,DIMENSION(klon) :: rlatgeo   ! latitudes geomagnetiques de la grille
-  REAL                 :: glt       ! latitude du pole geomagnetique
-  REAL                 :: glg       ! longitude du pole geomagnetique
-  REAL                 :: latgeo,qcos
-  INTEGER              :: k,i, kref, k2
-  INTEGER              :: nref
-  PARAMETER (nref=39)
-  REAL,DIMENSION(nref), SAVE :: pref      ! grille de pression de reference (bas des couches)
-  DATA pref  /   &
-      101249.99999999994, 100387.17261011522, 99447.35334189111,  98357.43412194174,   &
-      97046.47707771382,  95447.1116450629,   93496.85259615642,  91139.46548240296,   &
-      88326.55568744117,  85019.60710580258,  81192.7404556645,   76836.48366938648,   &
-      71962.81275769137,  66611.56331321516,  60857.914829743604, 54819.84484441629,   &
-      48663.06257114699,  42598.95465845692,  36869.104365898806, 31709.927925633147,  &
-      27296.757208636915, 23682.282929080895, 20766.025578936627, 18336.105961406534,  &
-      16178.04816768436,  14168.286905562818, 12275.719926478887, 10507.798835225762,  &
-      8876.585404909414,  7391.283929569539,  6057.514475749798,  4877.165909157005,   &
-      3848.34936408203,   2965.444753540027,  2219.2391544640013, 1597.15366044666,    &
-      1083.5531161631498, 660.1311067852655,  306.36072267002805 / 
-!$OMP THREADPRIVATE(pref)
-
-  WRITE(*,*)'PASSAGE init_be ...'
-
-! la source est maintenant définie independemment de la valeur de klev.
-!!! Source actuellement definie pour klev = 19 et klev >= 39
-!!  IF (klev /= 19 .AND. klev<39) CALL abort_physic("init_be","Source du be7 necessite klev=19 ou klev>=39",1)
-!!!
-! Definition des constantes
-! -------------------------
-  tautr = 6645000.
-  vdeptr = 1.E-3 
-  scavtr = 0.5 
-!!!!!jyg le 13/03/2013; puis 20/03/2013 : pref est maintenant une table.
-!!!
-!!!   Recherche d'un point rlat=0., rlon=180.
-!!      iref=(klon+1)/2
-!!      DO i = 1,klon
-!!        IF (abs(rlatd(i)) .LT. 0.15 .AND. cos(rlond(i)) .LT. -0.85) iref=i
-!!      ENDDO
-!!!
-!!!   Grille de pression de reference (= approx de sommets de couches)
-!!      pref(1) = pplay(iref,1)+0.5*(pplay(iref,1)-pplay(iref,2))
-!!      DO k = 2,klev
-!!        pref(k) = 0.5*(pplay(iref,k-1)+pplay(iref,k))
-!!      ENDDO
-!!!
-
-  WRITE(*,*) '-------------- SOURCE DE BERYLLIUM ------------------- '
-  WRITE(*,*)'Decroissance (s): ', tautr
-  WRITE(*,*)'Vitesse de depot sec: ',vdeptr
-  WRITE(*,*)'Facteur de lessivage: ',scavtr
-
-  DO i = 1,klon
-     masktr(i) = 0.
-     IF ( NINT(pctsrf(i,1)) .EQ. 1 ) masktr(i) = 1.
-  END DO
-
-! Premiers niveaux: source nulle
-! ------------------------------
-  DO k = 1,6
-     DO i = 1,klon
-        srcbe(i,k) = 0.
-     END DO
-  END DO
-!
-! Pour les autres niveaux:
-! 1-passer des coordonnees geographiques a la latitude geomagnetique
-! 2-prescrire la source de Be (en 10exp5 at/g/s) dans ce repere
-! 3-mettre la source de Be ds la bonne unite (en at/kgA/s)
-!
-  glt =  78.5*rpi/180.
-  glg = -69.0*rpi/180.
-
-  DO i = 1,klon
-     qcos=sin(glt)*sin(latitude(i))
-!!jyg
-!!     qcos=qcos+cos(glt)*cos(latitude(i))*cos(longitude(i)+glg)
-     qcos=qcos+cos(glt)*cos(latitude(i))*cos(longitude(i)-glg)
-!!jyg end
-     IF ( qcos .LT. -1.) qcos = -1.
-     IF ( qcos .GT. 1.)  qcos = 1.
-     rlatgeo(i)=rpi/2.-acos(qcos)
-  ENDDO
-
-!!!===========================
-!!!  Cas 19 niveaux verticaux
-!!!===========================
-!!  IF (klev.eq.19) then
-!!     DO k = 1,klev
-!!        DO i = 1,klon
-!!!!!jyg le 13/03/2013
-!!!
-!!! k est le niveau dans la grille locale
-!!! Determination du niveau kref dans la grille de refernce
-!!      kref = 1
-!!      DO k2 = 1,klev
-!!        IF (pref(k2) .GT. pplay(i,k)) kref=k2
-!!      ENDDO
-!!!!!
-!!           latgeo=(180./rpi)*abs(rlatgeo(i))
-!!           IF ( kref .EQ. 1 ) THEN
-!!              IF (latgeo.GE.50.0) srcbe(i,k)=0.1
-!!              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=0.09
-!!              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=0.07
-!!           END IF
-!!           IF ( kref .EQ. 2 ) THEN
-!!              IF (latgeo.GE.50.0) srcbe(i,k)=0.12
-!!              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=0.1
-!!              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=0.09
-!!              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=0.07
-!!           END IF
-!!           IF ( kref .EQ. 3 ) THEN
-!!              IF (latgeo.GE.50.0) srcbe(i,k)=0.14
-!!              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=0.12
-!!              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=0.1
-!!              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=0.09
-!!              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=0.07
-!!           END IF
-!!           IF ( kref .EQ. 4 ) THEN
-!!              IF (latgeo.GE.50.0) srcbe(i,k)=0.175
-!!              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=0.16
-!!              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=0.14
-!!              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=0.12
-!!              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=0.1
-!!              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=0.09
-!!           END IF
-!!           IF ( kref .EQ. 5 ) THEN
-!!              IF (latgeo.GE.50.0) srcbe(i,k)=0.28
-!!              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=0.26
-!!              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=0.23
-!!              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=0.175
-!!              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=0.14
-!!              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=0.12
-!!           END IF
-!!           IF ( kref .EQ. 6 ) THEN
-!!              IF (latgeo.GE.50.0) srcbe(i,k)=0.56
-!!              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=0.49
-!!              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=0.42
-!!              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=0.28
-!!              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=0.26
-!!              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=0.245
-!!           END IF
-!!           IF ( kref .EQ. 7 ) THEN
-!!              IF (latgeo.GE.50.0) srcbe(i,k)=1.05
-!!              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=0.875
-!!              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=0.7
-!!              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=0.52
-!!              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=0.44
-!!              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=0.385
-!!           END IF
-!!           IF ( kref .EQ. 8 ) THEN
-!!              IF (latgeo.GE.50.0) srcbe(i,k)=2.
-!!              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=1.8
-!!              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=1.5
-!!              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=1.
-!!              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=0.8
-!!              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=0.75
-!!           END IF
-!!           IF ( kref .EQ. 9 ) THEN
-!!              IF (latgeo.GE.50.0) srcbe(i,k)=4.
-!!              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=3.5
-!!              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=3.
-!!              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=2.5
-!!              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=1.8
-!!              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=1.4
-!!           END IF
-!!           IF ( kref .EQ. 10 ) THEN
-!!              IF (latgeo.GE.50.0) srcbe(i,k)=8.5
-!!              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=8.
-!!              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=7.
-!!              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=4.5
-!!              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=3.5
-!!              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=3.
-!!           END IF
-!!           IF ( kref .EQ. 11 ) THEN
-!!              IF (latgeo.GE.50.0) srcbe(i,k)=17.
-!!              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=15.
-!!              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=11.
-!!              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=8.
-!!              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=5.
-!!              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=4.
-!!           END IF
-!!           IF ( kref .EQ. 12 ) THEN
-!!              IF (latgeo.GE.50.0) srcbe(i,k)=25.
-!!              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=22.
-!!              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=17.
-!!              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=11.
-!!              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=7.5
-!!              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=7.
-!!           END IF
-!!           IF ( kref .EQ. 13 ) THEN
-!!              IF (latgeo.GE.60.0) srcbe(i,k)=33.
-!!              IF (latgeo.GE.50.0 .and. latgeo.LT.60.0) srcbe(i,k)=32.
-!!              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=30.
-!!              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=22.
-!!              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=15.
-!!              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=11.
-!!              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=8.
-!!           END IF
-!!           IF ( kref .EQ. 14 ) THEN
-!!              IF (latgeo.GE.60.0) srcbe(i,k)=48.
-!!              IF (latgeo.GE.50.0 .and. latgeo.LT.60.0) srcbe(i,k)=45.
-!!              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=36.
-!!              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=26.
-!!              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=17.5
-!!              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=12.5
-!!              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=10.
-!!           END IF
-!!           IF ( kref .EQ. 15 ) THEN
-!!              IF (latgeo.GE.70.0) srcbe(i,k)=58.
-!!              IF (latgeo.GE.60.0 .and. latgeo.LT.70.0) srcbe(i,k)=57.
-!!              IF (latgeo.GE.50.0 .and. latgeo.LT.60.0) srcbe(i,k)=50.
-!!              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=38.
-!!              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=25.
-!!              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=15.
-!!              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=12.5
-!!              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=10.
-!!           END IF
-!!           IF ( kref .EQ. 16 ) THEN
-!!              IF (latgeo.GE.70.0) srcbe(i,k)=70.
-!!              IF (latgeo.GE.60.0 .and. latgeo.LT.70.0) srcbe(i,k)=65.
-!!              IF (latgeo.GE.50.0 .and. latgeo.LT.60.0) srcbe(i,k)=50.
-!!              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=32.
-!!              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=20.
-!!              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=13.
-!!              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=9.
-!!              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=7.5
-!!           END IF
-!!           IF ( kref .GE. 17 ) THEN
-!!              IF (latgeo.GE.70.0) srcbe(i,k)=80.
-!!              IF (latgeo.GE.60.0 .and. latgeo.LT.70.0) srcbe(i,k)=70.
-!!              IF (latgeo.GE.50.0 .and. latgeo.LT.60.0) srcbe(i,k)=45.
-!!              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=27.
-!!              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=17.5
-!!              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=12.
-!!              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=8.
-!!              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=7.
-!!           END IF
-!!        END DO
-!!     END DO
-!!  END IF ! fin de 19 niveaux verticaux
-!!
-!!!!!!  IF (klev .ge. 39) then
-     DO k = 1,klev
-        DO i = 1,klon
-!!!jyg le 13/03/2013
-!
-! k est le niveau dans la grille locale
-! Determination du niveau kref dans la grille de refernce
-      kref = 1
-      DO k2 = 1,nref
-        IF (pref(k2) .GT. pplay(i,k)) kref=k2
-      ENDDO
-!!!
-           latgeo=(180./rpi)*abs(rlatgeo(i))
-           IF ( kref .LE. 4 ) THEN
-              IF (latgeo.GE.50.0) srcbe(i,k)=0.07
-           END IF
-           IF ( kref .EQ. 5 ) THEN
-              IF (latgeo.GE.50.0) srcbe(i,k)=0.1
-              IF (latgeo.GE.20.0 .and. latgeo.LT.50.0) srcbe(i,k)=0.09
-              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=0.07
-           END IF
-           IF ( kref .EQ. 6 ) THEN
-              IF (latgeo.GE.50.0) srcbe(i,k)=0.14
-              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=0.12
-              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=0.1
-              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=0.09
-              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=0.07
-           END IF
-           IF ( kref .EQ. 7 ) THEN
-              IF (latgeo.GE.50.0) srcbe(i,k)=0.16
-              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=0.16
-              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=0.14
-              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=0.12
-              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=0.1
-              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=0.09
-           END IF
-           IF ( kref .EQ. 8 ) THEN
-              IF (latgeo.GE.50.0) srcbe(i,k)=0.175
-              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=0.16
-              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=0.14
-              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=0.12
-              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=0.1
-              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=0.1
-           END IF
-           IF ( kref .EQ. 9 ) THEN
-              IF (latgeo.GE.50.0) srcbe(i,k)=0.245
-              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=0.21
-              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=0.175
-              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=0.14
-              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=0.12
-              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=0.12
-           END IF
-           IF ( kref .EQ. 10 ) THEN
-              IF (latgeo.GE.50.0) srcbe(i,k)=0.31
-              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=0.28
-              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=0.245
-              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=0.21
-              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=0.16
-              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=0.14
-           END IF
-           IF ( kref .EQ. 11 ) THEN
-              IF (latgeo.GE.50.0) srcbe(i,k)=0.35
-              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=0.3
-              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=0.3
-              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=0.2
-              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=0.18
-              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=0.16
-           END IF
-           IF ( kref .EQ. 12 ) THEN
-              IF (latgeo.GE.40.0) srcbe(i,k)=0.5
-              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=0.4
-              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=0.35
-              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=0.3
-              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=0.25
-           END IF
-           IF ( kref .EQ. 13 ) THEN
-              IF (latgeo.GE.50.0) srcbe(i,k)=0.8
-              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=0.7
-              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=0.6
-              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=0.5
-              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=0.4
-              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=0.35
-           END IF
-           IF ( kref .EQ. 14 ) THEN
-              IF (latgeo.GE.50.0) srcbe(i,k)=1.2
-              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=1.
-              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=0.75
-              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=0.6
-              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=0.5
-              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=0.4
-           END IF
-           IF ( kref .EQ. 15 ) THEN
-              IF (latgeo.GE.60.0) srcbe(i,k)=1.75
-              IF (latgeo.GE.50.0 .and. latgeo.LT.60.0) srcbe(i,k)=1.8 
-              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=1.6
-              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=1.4
-              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=0.9
-              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=0.75
-              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=0.65
-           END IF
-           IF ( kref .EQ. 16 ) THEN
-              IF (latgeo.GE.50.0) srcbe(i,k)=3.
-              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=2.5
-              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=1.8
-              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=1.5
-              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=1.2
-              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=0.9
-           END IF
-           IF ( kref .EQ. 17 ) THEN
-              IF (latgeo.GE.50.0) srcbe(i,k)=4.
-              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=3.
-              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=2.5
-              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=2.
-              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=1.6
-              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=1.4
-           END IF
-           IF ( kref .EQ. 18 ) THEN
-              IF (latgeo.GE.50.0) srcbe(i,k)=7.
-              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=6.
-              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=4.5
-              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=3.5
-              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=3.
-              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=2.
-           END IF
-           IF ( kref .EQ. 19 ) THEN
-              IF (latgeo.GE.50.0) srcbe(i,k)=8.5
-              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=8.
-              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=7.
-              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=4.
-              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=3.5
-              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=3.
-           END IF
-           IF ( kref .EQ. 20 ) THEN
-              IF (latgeo.GE.50.0) srcbe(i,k)=12.5
-              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=12.
-              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=8.
-              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=6.
-              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=4.
-              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=3.5
-           END IF
-           IF ( kref .EQ. 21 ) THEN
-              IF (latgeo.GE.50.0) srcbe(i,k)=16.
-              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=13.
-              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=10.
-              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=7.5
-              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=4.5
-              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=4.
-           END IF
-           IF ( kref .EQ. 22 ) THEN
-              IF (latgeo.GE.50.0) srcbe(i,k)=20.
-              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=17.5
-              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=12.5
-              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=9.
-              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=6.
-              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=4.5
-           END IF
-           IF ( kref .EQ. 23 ) THEN
-              IF (latgeo.GE.50.0) srcbe(i,k)=25.
-              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=22.
-              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=15.
-              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=10.
-              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=7.5
-              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=6.
-           END IF
-           IF ( kref .EQ. 24 ) THEN
-              IF (latgeo.GE.50.0) srcbe(i,k)=28.
-              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=26.
-              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=18.
-              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=12.
-              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=8.5
-              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=7.
-           END IF
-           IF ( kref .EQ. 25 ) THEN
-              IF (latgeo.GE.50.0) srcbe(i,k)=33.
-              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=28.
-              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=20.
-              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=14.
-              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=10.
-              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=8.5
-           END IF
-           IF ( kref .EQ. 26 ) THEN
-              IF (latgeo.GE.60.0) srcbe(i,k)=38.
-              IF (latgeo.GE.50.0 .and. latgeo.LT.60.0) srcbe(i,k)=36.
-              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=32.
-              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=24.
-              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=15.
-              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=11.5
-              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=10.
-!!jyg
-!!              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=6.
-!!jyg end
-           END IF
-           IF ( kref .EQ. 27 ) THEN
-              IF (latgeo.GE.60.0) srcbe(i,k)=46.
-              IF (latgeo.GE.50.0 .and. latgeo.LT.60.0) srcbe(i,k)=44.
-              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=35.
-              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=25.
-              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=16.
-              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=12.5
-              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=10.
-           END IF
-           IF ( kref .EQ. 28 ) THEN
-              IF (latgeo.GE.60.0) srcbe(i,k)=53.
-              IF (latgeo.GE.50.0 .and. latgeo.LT.60.0) srcbe(i,k)=48.
-              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=37.
-              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=25.
-              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=16.
-              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=12.5
-              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=10.
-           END IF
-           IF ( kref .EQ. 29 ) THEN
-              IF (latgeo.GE.70.0) srcbe(i,k)=58.
-              IF (latgeo.GE.60.0 .and. latgeo.LT.70.0) srcbe(i,k)=56.
-              IF (latgeo.GE.50.0 .and. latgeo.LT.60.0) srcbe(i,k)=50.
-              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=36.
-              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=24.
-              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=15.
-              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=11.5
-              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=10.
-           END IF
-           IF ( kref .EQ. 30 ) THEN
-              IF (latgeo.GE.70.0) srcbe(i,k)=65.
-              IF (latgeo.GE.60.0 .and. latgeo.LT.70.0) srcbe(i,k)=60.
-              IF (latgeo.GE.50.0 .and. latgeo.LT.60.0) srcbe(i,k)=50.
-              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=35.
-              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=22.
-              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=14.
-              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=10.
-              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=9.
-           END IF
-           IF ( kref .EQ. 31 ) THEN
-              IF (latgeo.GE.70.0) srcbe(i,k)=70.
-              IF (latgeo.GE.60.0 .and. latgeo.LT.70.0) srcbe(i,k)=62.
-              IF (latgeo.GE.50.0 .and. latgeo.LT.60.0) srcbe(i,k)=48.
-              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=32.
-              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=21.
-              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=13.
-              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=9.
-              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=7.6
-           END IF
-           IF ( kref .EQ. 32 ) THEN
-              IF (latgeo.GE.70.0) srcbe(i,k)=80.
-              IF (latgeo.GE.60.0 .and. latgeo.LT.70.0) srcbe(i,k)=60.
-              IF (latgeo.GE.50.0 .and. latgeo.LT.60.0) srcbe(i,k)=46.
-              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=30.
-              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=17.5
-              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=11.
-              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=8.
-              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=7.4
-           END IF
-           IF ( kref .GE. 33 ) THEN
-              IF (latgeo.GE.70.0) srcbe(i,k)=80.
-              IF (latgeo.GE.60.0 .and. latgeo.LT.70.0) srcbe(i,k)=70.
-              IF (latgeo.GE.50.0 .and. latgeo.LT.60.0) srcbe(i,k)=45.
-              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=27.
-              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=15.
-              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=10.
-              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=7.6
-              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=7.
-           END IF
-        END DO
-     END DO
-!!!!!!  END IF ! fin de 39 niveaux verticaux
-
-
-!====================================
-! Conversion de la source en U/s/kgA
-!====================================
-  DO k = 1,klev
-     DO i = 1,klon
-       ! La source est  at/min/m3 -> at/s/kgA
-       ! avec une masse volumique de l'air = 1.295 kg/m3
-       ! 1/(60*1.295) = 0.01287
-       srcbe(i,k)=srcbe(i,k)*0.01287
-!!       print *,'  k, srcbe(i,k) ',   &
-!!                  k, srcbe(i,k)
-       ! La source est  at/min/m3 -> at/s/m3
-       ! srcbe(i,k)=srcbe(i,k)*0.0166667
-    END DO
- END DO
-
-END SUBROUTINE init_be
Index: /LMDZ6/trunk/libf/phylmd/init_be.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/init_be.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/init_be.f90	(revision 5268)
@@ -0,0 +1,564 @@
+!$Id $
+
+SUBROUTINE init_be(pctsrf,pplay,masktr,tautr,vdeptr,scavtr,srcbe)
+!!!SUBROUTINE init_be(pctsrf,masktr,tautr,vdeptr,scavtr,srcbe)
+
+  USE dimphy
+  USE indice_sol_mod
+  USE geometry_mod, ONLY : longitude, latitude
+    
+  IMPLICIT NONE 
+!=====================================================================
+! Objet : prescription d'une source de Beryllium 7 
+!         pour 19 niveaux verticaux
+!        (d'apres le diagramme de Lal and Peters, 1967)
+!
+!
+! written by : O. Coindreau (CEA/LDG) 05/2005
+! last modified by : A. Jamelot (LMD/CEA)  04/03/2009 
+!=====================================================================
+
+  INCLUDE "YOMCST.h"
+  INCLUDE "YOECUMF.h" 
+
+!
+! Input Arguments
+!
+  REAL,DIMENSION(klon,nbsrf),INTENT(IN) :: pctsrf !Pourcentage de sol (f(nature du sol))
+  REAL,DIMENSION(klon,klev), INTENT(IN) :: pplay  ! Pressions en milieu de couches
+!
+! Output Arguments
+!
+  REAL,DIMENSION(klon),INTENT(OUT)      :: masktr ! Masque de l'echange avec la surface (possible => 1 )
+  REAL,INTENT(OUT)                      :: tautr  ! Constante de decroissance radioactive
+  REAL,INTENT(OUT)                      :: vdeptr ! Vitesse de depot sec dans la couche Brownienne
+  REAL,INTENT(OUT)                      :: scavtr ! Coefficient de lessivage
+  REAL,DIMENSION(klon,klev),INTENT(OUT) :: srcbe  ! source volumique de 7Be      
+!
+! Local Variables
+!
+!!!  INTEGER              :: iref      ! numero d'un point oceanique donnant la grille de pression de reference
+  REAL,DIMENSION(klon) :: rlatgeo   ! latitudes geomagnetiques de la grille
+  REAL                 :: glt       ! latitude du pole geomagnetique
+  REAL                 :: glg       ! longitude du pole geomagnetique
+  REAL                 :: latgeo,qcos
+  INTEGER              :: k,i, kref, k2
+  INTEGER              :: nref
+  PARAMETER (nref=39)
+  REAL,DIMENSION(nref), SAVE :: pref      ! grille de pression de reference (bas des couches)
+  DATA pref  /   &
+      101249.99999999994, 100387.17261011522, 99447.35334189111,  98357.43412194174,   &
+      97046.47707771382,  95447.1116450629,   93496.85259615642,  91139.46548240296,   &
+      88326.55568744117,  85019.60710580258,  81192.7404556645,   76836.48366938648,   &
+      71962.81275769137,  66611.56331321516,  60857.914829743604, 54819.84484441629,   &
+      48663.06257114699,  42598.95465845692,  36869.104365898806, 31709.927925633147,  &
+      27296.757208636915, 23682.282929080895, 20766.025578936627, 18336.105961406534,  &
+      16178.04816768436,  14168.286905562818, 12275.719926478887, 10507.798835225762,  &
+      8876.585404909414,  7391.283929569539,  6057.514475749798,  4877.165909157005,   &
+      3848.34936408203,   2965.444753540027,  2219.2391544640013, 1597.15366044666,    &
+      1083.5531161631498, 660.1311067852655,  306.36072267002805 / 
+!$OMP THREADPRIVATE(pref)
+
+  WRITE(*,*)'PASSAGE init_be ...'
+
+! la source est maintenant définie independemment de la valeur de klev.
+!!! Source actuellement definie pour klev = 19 et klev >= 39
+!!  IF (klev /= 19 .AND. klev<39) CALL abort_physic("init_be","Source du be7 necessite klev=19 ou klev>=39",1)
+!!!
+! Definition des constantes
+! -------------------------
+  tautr = 6645000.
+  vdeptr = 1.E-3 
+  scavtr = 0.5 
+!!!!!jyg le 13/03/2013; puis 20/03/2013 : pref est maintenant une table.
+!!!
+!!!   Recherche d'un point rlat=0., rlon=180.
+!!      iref=(klon+1)/2
+!!      DO i = 1,klon
+!!        IF (abs(rlatd(i)) .LT. 0.15 .AND. cos(rlond(i)) .LT. -0.85) iref=i
+!!      ENDDO
+!!!
+!!!   Grille de pression de reference (= approx de sommets de couches)
+!!      pref(1) = pplay(iref,1)+0.5*(pplay(iref,1)-pplay(iref,2))
+!!      DO k = 2,klev
+!!        pref(k) = 0.5*(pplay(iref,k-1)+pplay(iref,k))
+!!      ENDDO
+!!!
+
+  WRITE(*,*) '-------------- SOURCE DE BERYLLIUM ------------------- '
+  WRITE(*,*)'Decroissance (s): ', tautr
+  WRITE(*,*)'Vitesse de depot sec: ',vdeptr
+  WRITE(*,*)'Facteur de lessivage: ',scavtr
+
+  DO i = 1,klon
+     masktr(i) = 0.
+     IF ( NINT(pctsrf(i,1)) .EQ. 1 ) masktr(i) = 1.
+  END DO
+
+! Premiers niveaux: source nulle
+! ------------------------------
+  DO k = 1,6
+     DO i = 1,klon
+        srcbe(i,k) = 0.
+     END DO
+  END DO
+!
+! Pour les autres niveaux:
+! 1-passer des coordonnees geographiques a la latitude geomagnetique
+! 2-prescrire la source de Be (en 10exp5 at/g/s) dans ce repere
+! 3-mettre la source de Be ds la bonne unite (en at/kgA/s)
+!
+  glt =  78.5*rpi/180.
+  glg = -69.0*rpi/180.
+
+  DO i = 1,klon
+     qcos=sin(glt)*sin(latitude(i))
+!!jyg
+!!     qcos=qcos+cos(glt)*cos(latitude(i))*cos(longitude(i)+glg)
+     qcos=qcos+cos(glt)*cos(latitude(i))*cos(longitude(i)-glg)
+!!jyg end
+     IF ( qcos .LT. -1.) qcos = -1.
+     IF ( qcos .GT. 1.)  qcos = 1.
+     rlatgeo(i)=rpi/2.-acos(qcos)
+  ENDDO
+
+!!!===========================
+!!!  Cas 19 niveaux verticaux
+!!!===========================
+!!  IF (klev.eq.19) then
+!!     DO k = 1,klev
+!!        DO i = 1,klon
+!!!!!jyg le 13/03/2013
+!!!
+!!! k est le niveau dans la grille locale
+!!! Determination du niveau kref dans la grille de refernce
+!!      kref = 1
+!!      DO k2 = 1,klev
+!!        IF (pref(k2) .GT. pplay(i,k)) kref=k2
+!!      ENDDO
+!!!!!
+!!           latgeo=(180./rpi)*abs(rlatgeo(i))
+!!           IF ( kref .EQ. 1 ) THEN
+!!              IF (latgeo.GE.50.0) srcbe(i,k)=0.1
+!!              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=0.09
+!!              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=0.07
+!!           END IF
+!!           IF ( kref .EQ. 2 ) THEN
+!!              IF (latgeo.GE.50.0) srcbe(i,k)=0.12
+!!              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=0.1
+!!              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=0.09
+!!              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=0.07
+!!           END IF
+!!           IF ( kref .EQ. 3 ) THEN
+!!              IF (latgeo.GE.50.0) srcbe(i,k)=0.14
+!!              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=0.12
+!!              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=0.1
+!!              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=0.09
+!!              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=0.07
+!!           END IF
+!!           IF ( kref .EQ. 4 ) THEN
+!!              IF (latgeo.GE.50.0) srcbe(i,k)=0.175
+!!              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=0.16
+!!              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=0.14
+!!              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=0.12
+!!              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=0.1
+!!              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=0.09
+!!           END IF
+!!           IF ( kref .EQ. 5 ) THEN
+!!              IF (latgeo.GE.50.0) srcbe(i,k)=0.28
+!!              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=0.26
+!!              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=0.23
+!!              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=0.175
+!!              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=0.14
+!!              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=0.12
+!!           END IF
+!!           IF ( kref .EQ. 6 ) THEN
+!!              IF (latgeo.GE.50.0) srcbe(i,k)=0.56
+!!              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=0.49
+!!              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=0.42
+!!              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=0.28
+!!              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=0.26
+!!              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=0.245
+!!           END IF
+!!           IF ( kref .EQ. 7 ) THEN
+!!              IF (latgeo.GE.50.0) srcbe(i,k)=1.05
+!!              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=0.875
+!!              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=0.7
+!!              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=0.52
+!!              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=0.44
+!!              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=0.385
+!!           END IF
+!!           IF ( kref .EQ. 8 ) THEN
+!!              IF (latgeo.GE.50.0) srcbe(i,k)=2.
+!!              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=1.8
+!!              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=1.5
+!!              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=1.
+!!              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=0.8
+!!              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=0.75
+!!           END IF
+!!           IF ( kref .EQ. 9 ) THEN
+!!              IF (latgeo.GE.50.0) srcbe(i,k)=4.
+!!              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=3.5
+!!              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=3.
+!!              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=2.5
+!!              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=1.8
+!!              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=1.4
+!!           END IF
+!!           IF ( kref .EQ. 10 ) THEN
+!!              IF (latgeo.GE.50.0) srcbe(i,k)=8.5
+!!              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=8.
+!!              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=7.
+!!              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=4.5
+!!              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=3.5
+!!              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=3.
+!!           END IF
+!!           IF ( kref .EQ. 11 ) THEN
+!!              IF (latgeo.GE.50.0) srcbe(i,k)=17.
+!!              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=15.
+!!              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=11.
+!!              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=8.
+!!              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=5.
+!!              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=4.
+!!           END IF
+!!           IF ( kref .EQ. 12 ) THEN
+!!              IF (latgeo.GE.50.0) srcbe(i,k)=25.
+!!              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=22.
+!!              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=17.
+!!              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=11.
+!!              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=7.5
+!!              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=7.
+!!           END IF
+!!           IF ( kref .EQ. 13 ) THEN
+!!              IF (latgeo.GE.60.0) srcbe(i,k)=33.
+!!              IF (latgeo.GE.50.0 .and. latgeo.LT.60.0) srcbe(i,k)=32.
+!!              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=30.
+!!              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=22.
+!!              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=15.
+!!              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=11.
+!!              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=8.
+!!           END IF
+!!           IF ( kref .EQ. 14 ) THEN
+!!              IF (latgeo.GE.60.0) srcbe(i,k)=48.
+!!              IF (latgeo.GE.50.0 .and. latgeo.LT.60.0) srcbe(i,k)=45.
+!!              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=36.
+!!              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=26.
+!!              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=17.5
+!!              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=12.5
+!!              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=10.
+!!           END IF
+!!           IF ( kref .EQ. 15 ) THEN
+!!              IF (latgeo.GE.70.0) srcbe(i,k)=58.
+!!              IF (latgeo.GE.60.0 .and. latgeo.LT.70.0) srcbe(i,k)=57.
+!!              IF (latgeo.GE.50.0 .and. latgeo.LT.60.0) srcbe(i,k)=50.
+!!              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=38.
+!!              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=25.
+!!              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=15.
+!!              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=12.5
+!!              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=10.
+!!           END IF
+!!           IF ( kref .EQ. 16 ) THEN
+!!              IF (latgeo.GE.70.0) srcbe(i,k)=70.
+!!              IF (latgeo.GE.60.0 .and. latgeo.LT.70.0) srcbe(i,k)=65.
+!!              IF (latgeo.GE.50.0 .and. latgeo.LT.60.0) srcbe(i,k)=50.
+!!              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=32.
+!!              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=20.
+!!              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=13.
+!!              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=9.
+!!              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=7.5
+!!           END IF
+!!           IF ( kref .GE. 17 ) THEN
+!!              IF (latgeo.GE.70.0) srcbe(i,k)=80.
+!!              IF (latgeo.GE.60.0 .and. latgeo.LT.70.0) srcbe(i,k)=70.
+!!              IF (latgeo.GE.50.0 .and. latgeo.LT.60.0) srcbe(i,k)=45.
+!!              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=27.
+!!              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=17.5
+!!              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=12.
+!!              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=8.
+!!              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=7.
+!!           END IF
+!!        END DO
+!!     END DO
+!!  END IF ! fin de 19 niveaux verticaux
+!!
+!!!!!!  IF (klev .ge. 39) then
+     DO k = 1,klev
+        DO i = 1,klon
+!!!jyg le 13/03/2013
+!
+! k est le niveau dans la grille locale
+! Determination du niveau kref dans la grille de refernce
+      kref = 1
+      DO k2 = 1,nref
+        IF (pref(k2) .GT. pplay(i,k)) kref=k2
+      ENDDO
+!!!
+           latgeo=(180./rpi)*abs(rlatgeo(i))
+           IF ( kref .LE. 4 ) THEN
+              IF (latgeo.GE.50.0) srcbe(i,k)=0.07
+           END IF
+           IF ( kref .EQ. 5 ) THEN
+              IF (latgeo.GE.50.0) srcbe(i,k)=0.1
+              IF (latgeo.GE.20.0 .and. latgeo.LT.50.0) srcbe(i,k)=0.09
+              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=0.07
+           END IF
+           IF ( kref .EQ. 6 ) THEN
+              IF (latgeo.GE.50.0) srcbe(i,k)=0.14
+              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=0.12
+              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=0.1
+              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=0.09
+              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=0.07
+           END IF
+           IF ( kref .EQ. 7 ) THEN
+              IF (latgeo.GE.50.0) srcbe(i,k)=0.16
+              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=0.16
+              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=0.14
+              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=0.12
+              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=0.1
+              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=0.09
+           END IF
+           IF ( kref .EQ. 8 ) THEN
+              IF (latgeo.GE.50.0) srcbe(i,k)=0.175
+              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=0.16
+              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=0.14
+              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=0.12
+              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=0.1
+              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=0.1
+           END IF
+           IF ( kref .EQ. 9 ) THEN
+              IF (latgeo.GE.50.0) srcbe(i,k)=0.245
+              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=0.21
+              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=0.175
+              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=0.14
+              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=0.12
+              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=0.12
+           END IF
+           IF ( kref .EQ. 10 ) THEN
+              IF (latgeo.GE.50.0) srcbe(i,k)=0.31
+              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=0.28
+              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=0.245
+              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=0.21
+              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=0.16
+              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=0.14
+           END IF
+           IF ( kref .EQ. 11 ) THEN
+              IF (latgeo.GE.50.0) srcbe(i,k)=0.35
+              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=0.3
+              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=0.3
+              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=0.2
+              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=0.18
+              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=0.16
+           END IF
+           IF ( kref .EQ. 12 ) THEN
+              IF (latgeo.GE.40.0) srcbe(i,k)=0.5
+              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=0.4
+              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=0.35
+              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=0.3
+              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=0.25
+           END IF
+           IF ( kref .EQ. 13 ) THEN
+              IF (latgeo.GE.50.0) srcbe(i,k)=0.8
+              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=0.7
+              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=0.6
+              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=0.5
+              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=0.4
+              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=0.35
+           END IF
+           IF ( kref .EQ. 14 ) THEN
+              IF (latgeo.GE.50.0) srcbe(i,k)=1.2
+              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=1.
+              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=0.75
+              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=0.6
+              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=0.5
+              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=0.4
+           END IF
+           IF ( kref .EQ. 15 ) THEN
+              IF (latgeo.GE.60.0) srcbe(i,k)=1.75
+              IF (latgeo.GE.50.0 .and. latgeo.LT.60.0) srcbe(i,k)=1.8 
+              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=1.6
+              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=1.4
+              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=0.9
+              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=0.75
+              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=0.65
+           END IF
+           IF ( kref .EQ. 16 ) THEN
+              IF (latgeo.GE.50.0) srcbe(i,k)=3.
+              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=2.5
+              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=1.8
+              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=1.5
+              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=1.2
+              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=0.9
+           END IF
+           IF ( kref .EQ. 17 ) THEN
+              IF (latgeo.GE.50.0) srcbe(i,k)=4.
+              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=3.
+              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=2.5
+              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=2.
+              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=1.6
+              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=1.4
+           END IF
+           IF ( kref .EQ. 18 ) THEN
+              IF (latgeo.GE.50.0) srcbe(i,k)=7.
+              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=6.
+              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=4.5
+              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=3.5
+              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=3.
+              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=2.
+           END IF
+           IF ( kref .EQ. 19 ) THEN
+              IF (latgeo.GE.50.0) srcbe(i,k)=8.5
+              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=8.
+              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=7.
+              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=4.
+              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=3.5
+              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=3.
+           END IF
+           IF ( kref .EQ. 20 ) THEN
+              IF (latgeo.GE.50.0) srcbe(i,k)=12.5
+              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=12.
+              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=8.
+              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=6.
+              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=4.
+              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=3.5
+           END IF
+           IF ( kref .EQ. 21 ) THEN
+              IF (latgeo.GE.50.0) srcbe(i,k)=16.
+              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=13.
+              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=10.
+              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=7.5
+              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=4.5
+              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=4.
+           END IF
+           IF ( kref .EQ. 22 ) THEN
+              IF (latgeo.GE.50.0) srcbe(i,k)=20.
+              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=17.5
+              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=12.5
+              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=9.
+              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=6.
+              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=4.5
+           END IF
+           IF ( kref .EQ. 23 ) THEN
+              IF (latgeo.GE.50.0) srcbe(i,k)=25.
+              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=22.
+              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=15.
+              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=10.
+              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=7.5
+              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=6.
+           END IF
+           IF ( kref .EQ. 24 ) THEN
+              IF (latgeo.GE.50.0) srcbe(i,k)=28.
+              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=26.
+              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=18.
+              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=12.
+              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=8.5
+              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=7.
+           END IF
+           IF ( kref .EQ. 25 ) THEN
+              IF (latgeo.GE.50.0) srcbe(i,k)=33.
+              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=28.
+              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=20.
+              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=14.
+              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=10.
+              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=8.5
+           END IF
+           IF ( kref .EQ. 26 ) THEN
+              IF (latgeo.GE.60.0) srcbe(i,k)=38.
+              IF (latgeo.GE.50.0 .and. latgeo.LT.60.0) srcbe(i,k)=36.
+              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=32.
+              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=24.
+              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=15.
+              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=11.5
+              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=10.
+!!jyg
+!!              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=6.
+!!jyg end
+           END IF
+           IF ( kref .EQ. 27 ) THEN
+              IF (latgeo.GE.60.0) srcbe(i,k)=46.
+              IF (latgeo.GE.50.0 .and. latgeo.LT.60.0) srcbe(i,k)=44.
+              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=35.
+              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=25.
+              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=16.
+              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=12.5
+              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=10.
+           END IF
+           IF ( kref .EQ. 28 ) THEN
+              IF (latgeo.GE.60.0) srcbe(i,k)=53.
+              IF (latgeo.GE.50.0 .and. latgeo.LT.60.0) srcbe(i,k)=48.
+              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=37.
+              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=25.
+              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=16.
+              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=12.5
+              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=10.
+           END IF
+           IF ( kref .EQ. 29 ) THEN
+              IF (latgeo.GE.70.0) srcbe(i,k)=58.
+              IF (latgeo.GE.60.0 .and. latgeo.LT.70.0) srcbe(i,k)=56.
+              IF (latgeo.GE.50.0 .and. latgeo.LT.60.0) srcbe(i,k)=50.
+              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=36.
+              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=24.
+              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=15.
+              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=11.5
+              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=10.
+           END IF
+           IF ( kref .EQ. 30 ) THEN
+              IF (latgeo.GE.70.0) srcbe(i,k)=65.
+              IF (latgeo.GE.60.0 .and. latgeo.LT.70.0) srcbe(i,k)=60.
+              IF (latgeo.GE.50.0 .and. latgeo.LT.60.0) srcbe(i,k)=50.
+              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=35.
+              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=22.
+              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=14.
+              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=10.
+              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=9.
+           END IF
+           IF ( kref .EQ. 31 ) THEN
+              IF (latgeo.GE.70.0) srcbe(i,k)=70.
+              IF (latgeo.GE.60.0 .and. latgeo.LT.70.0) srcbe(i,k)=62.
+              IF (latgeo.GE.50.0 .and. latgeo.LT.60.0) srcbe(i,k)=48.
+              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=32.
+              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=21.
+              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=13.
+              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=9.
+              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=7.6
+           END IF
+           IF ( kref .EQ. 32 ) THEN
+              IF (latgeo.GE.70.0) srcbe(i,k)=80.
+              IF (latgeo.GE.60.0 .and. latgeo.LT.70.0) srcbe(i,k)=60.
+              IF (latgeo.GE.50.0 .and. latgeo.LT.60.0) srcbe(i,k)=46.
+              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=30.
+              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=17.5
+              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=11.
+              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=8.
+              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=7.4
+           END IF
+           IF ( kref .GE. 33 ) THEN
+              IF (latgeo.GE.70.0) srcbe(i,k)=80.
+              IF (latgeo.GE.60.0 .and. latgeo.LT.70.0) srcbe(i,k)=70.
+              IF (latgeo.GE.50.0 .and. latgeo.LT.60.0) srcbe(i,k)=45.
+              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=27.
+              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=15.
+              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=10.
+              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=7.6
+              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=7.
+           END IF
+        END DO
+     END DO
+!!!!!!  END IF ! fin de 39 niveaux verticaux
+
+
+!====================================
+! Conversion de la source en U/s/kgA
+!====================================
+  DO k = 1,klev
+     DO i = 1,klon
+       ! La source est  at/min/m3 -> at/s/kgA
+       ! avec une masse volumique de l'air = 1.295 kg/m3
+       ! 1/(60*1.295) = 0.01287
+       srcbe(i,k)=srcbe(i,k)*0.01287
+!!       print *,'  k, srcbe(i,k) ',   &
+!!                  k, srcbe(i,k)
+       ! La source est  at/min/m3 -> at/s/m3
+       ! srcbe(i,k)=srcbe(i,k)*0.0166667
+    END DO
+ END DO
+
+END SUBROUTINE init_be
Index: DZ6/trunk/libf/phylmd/initphysto.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/initphysto.F90	(revision 5267)
+++ 	(revision )
@@ -1,206 +1,0 @@
-!
-! $Id$
-!
-SUBROUTINE initphysto(infile,tstep,t_ops,t_wrt,fileid)
-  
-  USE dimphy
-  USE mod_phys_lmdz_para
-  USE IOIPSL
-  USE iophy
-  USE indice_sol_mod
-  USE mod_grid_phy_lmdz, ONLY: nbp_lon, nbp_lat, nbp_lev
-  USE time_phylmdz_mod, ONLY: day_ref, annee_ref
-  
-  IMPLICIT NONE
-
-!
-!   Routine d'initialisation des ecritures des fichiers histoires LMDZ
-!   au format IOIPSL
-!
-!   Appels succesifs des routines: histbeg
-!                                  histhori
-!                                  histver
-!                                  histdef
-!                                  histend
-!
-!   Entree:
-!
-!      infile: nom du fichier histoire a creer
-!      day0,anne0: date de reference
-!      tstep: duree du pas de temps en seconde
-!      t_ops: frequence de l'operation pour IOIPSL
-!      t_wrt: frequence d'ecriture sur le fichier
-!
-!   Sortie:
-!      fileid: ID du fichier netcdf cree
-!
-!   L. Fairhead, LMD, 03/99
-!
-! =====================================================================
-
-!   Arguments
-  CHARACTER(len=*), INTENT(IN) :: infile
-  REAL, INTENT(IN)             :: tstep
-  REAL, INTENT(IN)             :: t_ops
-  REAL, INTENT(IN)             :: t_wrt
-  INTEGER, INTENT(OUT)         :: fileid
-
-! Variables locales
-  INTEGER nhoriid, i
-  INTEGER l,k
-  REAL nivsigs(nbp_lev)
-  INTEGER tau0
-  REAL zjulian
-  INTEGER iq
-  INTEGER uhoriid, vhoriid, thoriid, zvertiid
-  INTEGER ii,jj
-  INTEGER zan, idayref
-  LOGICAL ok_sync
-  REAL zx_lon(nbp_lon,nbp_lat), zx_lat(nbp_lon,nbp_lat)
-  CHARACTER(len=12) :: nvar
-
-!  Initialisations
-!
-  ok_sync= .TRUE.
-!
-!  Appel a histbeg: creation du fichier netcdf et initialisations diverses
-!         
-
-  zan = annee_ref
-  idayref = day_ref
-  CALL ymds2ju(zan, 1, idayref, 0.0, zjulian)
-  tau0 = 0
-  
-  CALL histbeg_phy(infile,tau0, zjulian, tstep, &
-       nhoriid, fileid)
-
-!$OMP MASTER	
-!  Appel a histvert pour la grille verticale
-!
-  DO l=1,nbp_lev
-     nivsigs(l)=REAL(l)
-  ENDDO
-  
-  CALL histvert(fileid, 'sig_s', 'Niveaux sigma', &
-       'sigma_level', &
-       nbp_lev, nivsigs, zvertiid)
-!
-!  Appels a histdef pour la definition des variables a sauvegarder
-!
-  CALL histdef(fileid, "phis", "Surface geop. height", "-", &
-       nbp_lon,jj_nb,nhoriid, 1,1,1, -99, 32, &
-       "once", t_ops, t_wrt)
-  
-  CALL histdef(fileid, "aire", "Grid area", "-", &
-       nbp_lon,jj_nb,nhoriid, 1,1,1, -99, 32, &
-       "once", t_ops, t_wrt)
-
-  CALL histdef(fileid, "longitudes", "longitudes", "-", &
-       nbp_lon,jj_nb,nhoriid, 1,1,1, -99, 32, &
-       "once", t_ops, t_wrt)
-
-  CALL histdef(fileid, "latitudes", "latitudes", "-", &
-       nbp_lon,jj_nb,nhoriid, 1,1,1, -99, 32, &
-       "once", t_ops, t_wrt)
-! T 
-  CALL histdef(fileid, 't', 'Temperature', 'K', nbp_lon, jj_nb, nhoriid, &
-       nbp_lev, 1, nbp_lev, zvertiid, 32, 'inst(X)', t_ops, t_wrt)
-! mfu 
-  CALL histdef(fileid, 'mfu', 'flx m. pan. mt', 'kg m/s',nbp_lon, jj_nb, nhoriid, &
-       nbp_lev, 1, nbp_lev, zvertiid,32, 'inst(X)', t_ops, t_wrt)
-! mfd 
-  CALL histdef(fileid, 'mfd', 'flx m. pan. des', 'kg m/s',nbp_lon, jj_nb, nhoriid, &
-       nbp_lev, 1, nbp_lev, zvertiid, 32, 'inst(X)', t_ops, t_wrt)
-! en_u 
-  CALL histdef(fileid, 'en_u', 'flx ent pan mt', 'kg m/s', nbp_lon, jj_nb, nhoriid, &
-       nbp_lev, 1, nbp_lev, zvertiid,32, 'inst(X)', t_ops, t_wrt)
-! de_u 
-  CALL histdef(fileid, 'de_u', 'flx det pan mt', 'kg m/s',nbp_lon, jj_nb, nhoriid, &
-       nbp_lev, 1, nbp_lev, zvertiid,32, 'inst(X)', t_ops, t_wrt)
-! en_d 
-  CALL histdef(fileid, 'en_d', 'flx ent pan dt', 'kg m/s', nbp_lon, jj_nb, nhoriid, &
-       nbp_lev, 1, nbp_lev, zvertiid,32, 'inst(X)', t_ops, t_wrt)
-! de_d 
-  CALL histdef(fileid, 'de_d', 'flx det pan dt', 'kg m/s', nbp_lon, jj_nb, nhoriid, &
-       nbp_lev, 1, nbp_lev, zvertiid, 32, 'inst(X)', t_ops, t_wrt)
-! coefh
-  CALL histdef(fileid, "coefh", " ", " ", nbp_lon, jj_nb, nhoriid, &
-       nbp_lev, 1, nbp_lev, zvertiid,32, "inst(X)", t_ops, t_wrt)
-! fm_th
-  CALL histdef(fileid, "fm_th", " ", " ",nbp_lon, jj_nb, nhoriid, &
-       nbp_lev, 1, nbp_lev, zvertiid,32, "inst(X)", t_ops, t_wrt)
-! en_th
-  CALL histdef(fileid, "en_th", " ", " ",nbp_lon, jj_nb, nhoriid, &
-       nbp_lev, 1, nbp_lev, zvertiid,32, "inst(X)", t_ops, t_wrt)
-! frac_impa
-  CALL histdef(fileid, 'frac_impa', ' ', ' ',nbp_lon, jj_nb, nhoriid, &
-       nbp_lev, 1, nbp_lev, zvertiid,32, 'inst(X)', t_ops, t_wrt)
-! frac_nucl
-  CALL histdef(fileid, 'frac_nucl', ' ', ' ',nbp_lon, jj_nb, nhoriid, &
-       nbp_lev, 1, nbp_lev, zvertiid,32, 'inst(X)', t_ops, t_wrt)
-! pyu1
-  CALL histdef(fileid, "pyu1", " ", " ", nbp_lon,jj_nb,nhoriid, &
-       1,1,1, -99, 32, "inst(X)", t_ops, t_wrt)
-! pyv1
-  CALL histdef(fileid, "pyv1", " ", " ", nbp_lon,jj_nb,nhoriid, &
-       1,1,1, -99, 32,"inst(X)", t_ops, t_wrt)    
-! ftsol1
-  CALL histdef(fileid, "ftsol1", " ", " ",nbp_lon, jj_nb, nhoriid, &
-       1, 1,1, -99,32, "inst(X)", t_ops, t_wrt)
-! ftsol2
-  CALL histdef(fileid, "ftsol2", " ", " ",nbp_lon, jj_nb, nhoriid, &
-       1, 1,1, -99,32, "inst(X)", t_ops, t_wrt)
-! ftsol3
-  CALL histdef(fileid, "ftsol3", " ", " ", nbp_lon, jj_nb, nhoriid, &
-       1, 1,1, -99,32, "inst(X)", t_ops, t_wrt)
-! ftsol4
-  CALL histdef(fileid, "ftsol4", " ", " ",nbp_lon, jj_nb, nhoriid, &
-       1, 1,1, -99, 32, "inst(X)", t_ops, t_wrt)
-! psrf1
-  CALL histdef(fileid, "psrf1", " ", " ",nbp_lon, jj_nb, nhoriid, &
-       1, 1, 1, -99,32, "inst(X)", t_ops, t_wrt)
-! psrf2
-  CALL histdef(fileid, "psrf2", " ", " ",nbp_lon, jj_nb, nhoriid, &
-       1, 1, 1, -99, 32, "inst(X)", t_ops, t_wrt)
-! psrf3
-  CALL histdef(fileid, "psrf3", " ", " ",nbp_lon, jj_nb, nhoriid, &
-       1, 1, 1, -99, 32, "inst(X)", t_ops, t_wrt)
-! psrf4
-  CALL histdef(fileid, "psrf4", " ", " ", nbp_lon, jj_nb, nhoriid, &
-       1, 1, 1, -99,32, "inst(X)", t_ops, t_wrt)
-! sh
-  CALL histdef(fileid, 'sh', '', '', nbp_lon, jj_nb, nhoriid, &
-       nbp_lev, 1, nbp_lev, zvertiid, 32, 'inst(X)', t_ops, t_wrt)
-! da
-  CALL histdef(fileid, 'da', '', '', nbp_lon, jj_nb, nhoriid, &
-       nbp_lev, 1, nbp_lev, zvertiid, 32, 'inst(X)', t_ops, t_wrt)
-! mp
-  CALL histdef(fileid, 'mp', '', '', nbp_lon, jj_nb, nhoriid, &
-       nbp_lev, 1, nbp_lev, zvertiid, 32, 'inst(X)', t_ops, t_wrt)
-! upwd
-  CALL histdef(fileid, 'upwd', '', '', nbp_lon, jj_nb, nhoriid, &
-       nbp_lev, 1, nbp_lev, zvertiid, 32, 'inst(X)', t_ops, t_wrt)
-! dnwd
-  CALL histdef(fileid, 'dnwd', '', '', nbp_lon, jj_nb, nhoriid, &
-       nbp_lev, 1, nbp_lev, zvertiid, 32, 'inst(X)', t_ops, t_wrt)
-
-! phi
-  DO k=1,nbp_lev
-     IF (k<10) THEN
-        WRITE(nvar,'(i1)') k
-     ELSE IF (k<100) THEN
-        WRITE(nvar,'(i2)') k
-     ELSE
-        WRITE(nvar,'(i3)') k
-     END IF
-     nvar='phi_lev'//trim(nvar)
-     
-     CALL histdef(fileid, nvar, '', '', nbp_lon, jj_nb, nhoriid, &
-          nbp_lev, 1, nbp_lev, zvertiid, 32, 'inst(X)', t_ops, t_wrt)
-  END DO
-
-  CALL histend(fileid)
-  IF (ok_sync) CALL histsync
-!$OMP END MASTER
-	
-END SUBROUTINE initphysto
Index: /LMDZ6/trunk/libf/phylmd/initphysto.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/initphysto.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/initphysto.f90	(revision 5268)
@@ -0,0 +1,206 @@
+!
+! $Id$
+!
+SUBROUTINE initphysto(infile,tstep,t_ops,t_wrt,fileid)
+  
+  USE dimphy
+  USE mod_phys_lmdz_para
+  USE IOIPSL
+  USE iophy
+  USE indice_sol_mod
+  USE mod_grid_phy_lmdz, ONLY: nbp_lon, nbp_lat, nbp_lev
+  USE time_phylmdz_mod, ONLY: day_ref, annee_ref
+  
+  IMPLICIT NONE
+
+!
+!   Routine d'initialisation des ecritures des fichiers histoires LMDZ
+!   au format IOIPSL
+!
+!   Appels succesifs des routines: histbeg
+!                                  histhori
+!                                  histver
+!                                  histdef
+!                                  histend
+!
+!   Entree:
+!
+!      infile: nom du fichier histoire a creer
+!      day0,anne0: date de reference
+!      tstep: duree du pas de temps en seconde
+!      t_ops: frequence de l'operation pour IOIPSL
+!      t_wrt: frequence d'ecriture sur le fichier
+!
+!   Sortie:
+!      fileid: ID du fichier netcdf cree
+!
+!   L. Fairhead, LMD, 03/99
+!
+! =====================================================================
+
+!   Arguments
+  CHARACTER(len=*), INTENT(IN) :: infile
+  REAL, INTENT(IN)             :: tstep
+  REAL, INTENT(IN)             :: t_ops
+  REAL, INTENT(IN)             :: t_wrt
+  INTEGER, INTENT(OUT)         :: fileid
+
+! Variables locales
+  INTEGER nhoriid, i
+  INTEGER l,k
+  REAL nivsigs(nbp_lev)
+  INTEGER tau0
+  REAL zjulian
+  INTEGER iq
+  INTEGER uhoriid, vhoriid, thoriid, zvertiid
+  INTEGER ii,jj
+  INTEGER zan, idayref
+  LOGICAL ok_sync
+  REAL zx_lon(nbp_lon,nbp_lat), zx_lat(nbp_lon,nbp_lat)
+  CHARACTER(len=12) :: nvar
+
+!  Initialisations
+!
+  ok_sync= .TRUE.
+!
+!  Appel a histbeg: creation du fichier netcdf et initialisations diverses
+!         
+
+  zan = annee_ref
+  idayref = day_ref
+  CALL ymds2ju(zan, 1, idayref, 0.0, zjulian)
+  tau0 = 0
+  
+  CALL histbeg_phy(infile,tau0, zjulian, tstep, &
+       nhoriid, fileid)
+
+!$OMP MASTER	
+!  Appel a histvert pour la grille verticale
+!
+  DO l=1,nbp_lev
+     nivsigs(l)=REAL(l)
+  ENDDO
+  
+  CALL histvert(fileid, 'sig_s', 'Niveaux sigma', &
+       'sigma_level', &
+       nbp_lev, nivsigs, zvertiid)
+!
+!  Appels a histdef pour la definition des variables a sauvegarder
+!
+  CALL histdef(fileid, "phis", "Surface geop. height", "-", &
+       nbp_lon,jj_nb,nhoriid, 1,1,1, -99, 32, &
+       "once", t_ops, t_wrt)
+  
+  CALL histdef(fileid, "aire", "Grid area", "-", &
+       nbp_lon,jj_nb,nhoriid, 1,1,1, -99, 32, &
+       "once", t_ops, t_wrt)
+
+  CALL histdef(fileid, "longitudes", "longitudes", "-", &
+       nbp_lon,jj_nb,nhoriid, 1,1,1, -99, 32, &
+       "once", t_ops, t_wrt)
+
+  CALL histdef(fileid, "latitudes", "latitudes", "-", &
+       nbp_lon,jj_nb,nhoriid, 1,1,1, -99, 32, &
+       "once", t_ops, t_wrt)
+! T 
+  CALL histdef(fileid, 't', 'Temperature', 'K', nbp_lon, jj_nb, nhoriid, &
+       nbp_lev, 1, nbp_lev, zvertiid, 32, 'inst(X)', t_ops, t_wrt)
+! mfu 
+  CALL histdef(fileid, 'mfu', 'flx m. pan. mt', 'kg m/s',nbp_lon, jj_nb, nhoriid, &
+       nbp_lev, 1, nbp_lev, zvertiid,32, 'inst(X)', t_ops, t_wrt)
+! mfd 
+  CALL histdef(fileid, 'mfd', 'flx m. pan. des', 'kg m/s',nbp_lon, jj_nb, nhoriid, &
+       nbp_lev, 1, nbp_lev, zvertiid, 32, 'inst(X)', t_ops, t_wrt)
+! en_u 
+  CALL histdef(fileid, 'en_u', 'flx ent pan mt', 'kg m/s', nbp_lon, jj_nb, nhoriid, &
+       nbp_lev, 1, nbp_lev, zvertiid,32, 'inst(X)', t_ops, t_wrt)
+! de_u 
+  CALL histdef(fileid, 'de_u', 'flx det pan mt', 'kg m/s',nbp_lon, jj_nb, nhoriid, &
+       nbp_lev, 1, nbp_lev, zvertiid,32, 'inst(X)', t_ops, t_wrt)
+! en_d 
+  CALL histdef(fileid, 'en_d', 'flx ent pan dt', 'kg m/s', nbp_lon, jj_nb, nhoriid, &
+       nbp_lev, 1, nbp_lev, zvertiid,32, 'inst(X)', t_ops, t_wrt)
+! de_d 
+  CALL histdef(fileid, 'de_d', 'flx det pan dt', 'kg m/s', nbp_lon, jj_nb, nhoriid, &
+       nbp_lev, 1, nbp_lev, zvertiid, 32, 'inst(X)', t_ops, t_wrt)
+! coefh
+  CALL histdef(fileid, "coefh", " ", " ", nbp_lon, jj_nb, nhoriid, &
+       nbp_lev, 1, nbp_lev, zvertiid,32, "inst(X)", t_ops, t_wrt)
+! fm_th
+  CALL histdef(fileid, "fm_th", " ", " ",nbp_lon, jj_nb, nhoriid, &
+       nbp_lev, 1, nbp_lev, zvertiid,32, "inst(X)", t_ops, t_wrt)
+! en_th
+  CALL histdef(fileid, "en_th", " ", " ",nbp_lon, jj_nb, nhoriid, &
+       nbp_lev, 1, nbp_lev, zvertiid,32, "inst(X)", t_ops, t_wrt)
+! frac_impa
+  CALL histdef(fileid, 'frac_impa', ' ', ' ',nbp_lon, jj_nb, nhoriid, &
+       nbp_lev, 1, nbp_lev, zvertiid,32, 'inst(X)', t_ops, t_wrt)
+! frac_nucl
+  CALL histdef(fileid, 'frac_nucl', ' ', ' ',nbp_lon, jj_nb, nhoriid, &
+       nbp_lev, 1, nbp_lev, zvertiid,32, 'inst(X)', t_ops, t_wrt)
+! pyu1
+  CALL histdef(fileid, "pyu1", " ", " ", nbp_lon,jj_nb,nhoriid, &
+       1,1,1, -99, 32, "inst(X)", t_ops, t_wrt)
+! pyv1
+  CALL histdef(fileid, "pyv1", " ", " ", nbp_lon,jj_nb,nhoriid, &
+       1,1,1, -99, 32,"inst(X)", t_ops, t_wrt)    
+! ftsol1
+  CALL histdef(fileid, "ftsol1", " ", " ",nbp_lon, jj_nb, nhoriid, &
+       1, 1,1, -99,32, "inst(X)", t_ops, t_wrt)
+! ftsol2
+  CALL histdef(fileid, "ftsol2", " ", " ",nbp_lon, jj_nb, nhoriid, &
+       1, 1,1, -99,32, "inst(X)", t_ops, t_wrt)
+! ftsol3
+  CALL histdef(fileid, "ftsol3", " ", " ", nbp_lon, jj_nb, nhoriid, &
+       1, 1,1, -99,32, "inst(X)", t_ops, t_wrt)
+! ftsol4
+  CALL histdef(fileid, "ftsol4", " ", " ",nbp_lon, jj_nb, nhoriid, &
+       1, 1,1, -99, 32, "inst(X)", t_ops, t_wrt)
+! psrf1
+  CALL histdef(fileid, "psrf1", " ", " ",nbp_lon, jj_nb, nhoriid, &
+       1, 1, 1, -99,32, "inst(X)", t_ops, t_wrt)
+! psrf2
+  CALL histdef(fileid, "psrf2", " ", " ",nbp_lon, jj_nb, nhoriid, &
+       1, 1, 1, -99, 32, "inst(X)", t_ops, t_wrt)
+! psrf3
+  CALL histdef(fileid, "psrf3", " ", " ",nbp_lon, jj_nb, nhoriid, &
+       1, 1, 1, -99, 32, "inst(X)", t_ops, t_wrt)
+! psrf4
+  CALL histdef(fileid, "psrf4", " ", " ", nbp_lon, jj_nb, nhoriid, &
+       1, 1, 1, -99,32, "inst(X)", t_ops, t_wrt)
+! sh
+  CALL histdef(fileid, 'sh', '', '', nbp_lon, jj_nb, nhoriid, &
+       nbp_lev, 1, nbp_lev, zvertiid, 32, 'inst(X)', t_ops, t_wrt)
+! da
+  CALL histdef(fileid, 'da', '', '', nbp_lon, jj_nb, nhoriid, &
+       nbp_lev, 1, nbp_lev, zvertiid, 32, 'inst(X)', t_ops, t_wrt)
+! mp
+  CALL histdef(fileid, 'mp', '', '', nbp_lon, jj_nb, nhoriid, &
+       nbp_lev, 1, nbp_lev, zvertiid, 32, 'inst(X)', t_ops, t_wrt)
+! upwd
+  CALL histdef(fileid, 'upwd', '', '', nbp_lon, jj_nb, nhoriid, &
+       nbp_lev, 1, nbp_lev, zvertiid, 32, 'inst(X)', t_ops, t_wrt)
+! dnwd
+  CALL histdef(fileid, 'dnwd', '', '', nbp_lon, jj_nb, nhoriid, &
+       nbp_lev, 1, nbp_lev, zvertiid, 32, 'inst(X)', t_ops, t_wrt)
+
+! phi
+  DO k=1,nbp_lev
+     IF (k<10) THEN
+        WRITE(nvar,'(i1)') k
+     ELSE IF (k<100) THEN
+        WRITE(nvar,'(i2)') k
+     ELSE
+        WRITE(nvar,'(i3)') k
+     END IF
+     nvar='phi_lev'//trim(nvar)
+     
+     CALL histdef(fileid, nvar, '', '', nbp_lon, jj_nb, nhoriid, &
+          nbp_lev, 1, nbp_lev, zvertiid, 32, 'inst(X)', t_ops, t_wrt)
+  END DO
+
+  CALL histend(fileid)
+  IF (ok_sync) CALL histsync
+!$OMP END MASTER
+	
+END SUBROUTINE initphysto
Index: DZ6/trunk/libf/phylmd/initrrnpb.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/initrrnpb.F90	(revision 5267)
+++ 	(revision )
@@ -1,95 +1,0 @@
-!
-! $Id$
-!
-SUBROUTINE  initrrnpb(ftsol,pctsrf,masktr,fshtr,hsoltr,tautr,vdeptr,scavtr)
-  USE dimphy
-  USE infotrac_phy, ONLY : nbtr
-  USE traclmdz_mod, ONLY : id_rn, id_pb
-  USE indice_sol_mod
-  IMPLICIT NONE
-!======================================================================
-! Auteur(s): AA + CG (LGGE/CNRS) Date 24-06-94
-! Objet: initialisation des constantes des traceurs
-! id_rn : identificateur du traceur radon
-! id_pb : identificateur du traceur plomb
-!======================================================================
-! Arguments:
-! nbtr.............. nombre de vrais traceurs (sans l'eau)
-! ftsol....input-R-  Temperature du sol (Kelvin)
-! pctsrf...input-R-  Nature de sol (pourcentage de sol)
-! masktr...output-R- Masque reservoir de sol traceur (1 = reservoir)
-! fshtr....output-R- Flux surfacique de production dans le reservoir de sol
-! hsoltr...output-R- Epaisseur equivalente du reservoir de sol
-! tautr....output-R- Constante de decroissance radioactive du traceur
-! vdeptr...output-R- Vitesse de depot sec dans la couche Brownienne
-! scavtr...output-R- Coefficient de lessivage
-!======================================================================
- 
-  REAL,DIMENSION(klon,nbsrf),INTENT(IN) :: pctsrf
-  REAL,DIMENSION(klon,nbsrf),INTENT(IN) :: ftsol
-  REAL,DIMENSION(klon,nbtr),INTENT(OUT) :: masktr
-  REAL,DIMENSION(klon,nbtr),INTENT(OUT) :: fshtr
-  REAL,DIMENSION(nbtr),INTENT(OUT)      :: hsoltr
-  REAL,DIMENSION(nbtr),INTENT(OUT)      :: tautr
-  REAL,DIMENSION(nbtr),INTENT(OUT)      :: vdeptr
-  REAL,DIMENSION(nbtr),INTENT(OUT)      :: scavtr
-  INTEGER                               :: i, it
-  REAL                                  :: s
-
-  CHARACTER (LEN=20) :: modname='initrrnpb'
-  CHARACTER (LEN=80) :: abort_message
-
-!
-! Radon it = id_rn
-!----------------
-  IF (id_rn /= 0) THEN
-     it = id_rn
-     s = 1.E4             ! Source: atome par m2
-     hsoltr(it) = 0.1     ! Hauteur equivalente du reservoir : 
-                          ! 1 m * porosite 0.1
-     tautr(it) = 4.765E5  ! Decroissance du radon, secondes
-     vdeptr(it) = 0.      ! Pas de depot sec pour le radon
-     scavtr(it) = 0.      ! Pas de lessivage pour le radon
-     
-     WRITE(*,*)'-------------- SOURCE DU RADON ------------------------ '
-     WRITE(*,*)'it = ',it
-     WRITE(*,*)'Source : ', s
-     WRITE(*,*)'Hauteur equivalente du reservoir de sol: ',hsoltr(it) 
-     WRITE(*,*)'Decroissance (s): ', tautr(it)
-     WRITE(*,*)'Vitesse de depot sec: ',vdeptr(it) 
-     WRITE(*,*)'Facteur de lessivage: ',scavtr(it)
-
-     DO i = 1,klon
-        masktr(i,it) = 0.
-        IF ( NINT(pctsrf(i,1)) .EQ. 1 ) masktr(i,it) = 1.
-        fshtr(i,it) = s * masktr(i,it)
-     END DO
-
-  END IF ! id_rn /= 0
-
-!
-! 210Pb it = id_pb
-!----------------
-  IF (id_pb /= 0) THEN
-     it = id_pb
-     s = 0.                ! Pas de source 
-     hsoltr(it) = 10.      ! Hauteur equivalente du reservoir 
-                           ! a partir duquel le depot Brownien a lieu
-     tautr(it) = 1.028E9   ! Decroissance du Pb210, secondes
-     vdeptr(it) = 1.E-3    ! 1 mm/s pour le 210Pb
-     scavtr(it) =  .5      ! Lessivage du Pb210
-     DO i = 1,klon
-        masktr(i,it) = 1.  ! Le depot sec peut avoir lieu partout
-        fshtr(i,it) = s * masktr(i,it)
-     END DO
-     WRITE(*,*)'-------------- SOURCE DU PLOMB ------------------------ '
-     WRITE(*,*)'it = ',it
-     WRITE(*,*)'Source : ', s
-     WRITE(*,*)'Hauteur equivalente du reservoir : ',hsoltr(it) 
-     WRITE(*,*)'Decroissance (s): ', tautr(it)
-     WRITE(*,*)'Vitesse de depot sec: ',vdeptr(it) 
-     WRITE(*,*)'Facteur de lessivage: ',scavtr(it)
-     
-  END IF
-     
-END SUBROUTINE initrrnpb
Index: /LMDZ6/trunk/libf/phylmd/initrrnpb.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/initrrnpb.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/initrrnpb.f90	(revision 5268)
@@ -0,0 +1,95 @@
+!
+! $Id$
+!
+SUBROUTINE  initrrnpb(ftsol,pctsrf,masktr,fshtr,hsoltr,tautr,vdeptr,scavtr)
+  USE dimphy
+  USE infotrac_phy, ONLY : nbtr
+  USE traclmdz_mod, ONLY : id_rn, id_pb
+  USE indice_sol_mod
+  IMPLICIT NONE
+!======================================================================
+! Auteur(s): AA + CG (LGGE/CNRS) Date 24-06-94
+! Objet: initialisation des constantes des traceurs
+! id_rn : identificateur du traceur radon
+! id_pb : identificateur du traceur plomb
+!======================================================================
+! Arguments:
+! nbtr.............. nombre de vrais traceurs (sans l'eau)
+! ftsol....input-R-  Temperature du sol (Kelvin)
+! pctsrf...input-R-  Nature de sol (pourcentage de sol)
+! masktr...output-R- Masque reservoir de sol traceur (1 = reservoir)
+! fshtr....output-R- Flux surfacique de production dans le reservoir de sol
+! hsoltr...output-R- Epaisseur equivalente du reservoir de sol
+! tautr....output-R- Constante de decroissance radioactive du traceur
+! vdeptr...output-R- Vitesse de depot sec dans la couche Brownienne
+! scavtr...output-R- Coefficient de lessivage
+!======================================================================
+ 
+  REAL,DIMENSION(klon,nbsrf),INTENT(IN) :: pctsrf
+  REAL,DIMENSION(klon,nbsrf),INTENT(IN) :: ftsol
+  REAL,DIMENSION(klon,nbtr),INTENT(OUT) :: masktr
+  REAL,DIMENSION(klon,nbtr),INTENT(OUT) :: fshtr
+  REAL,DIMENSION(nbtr),INTENT(OUT)      :: hsoltr
+  REAL,DIMENSION(nbtr),INTENT(OUT)      :: tautr
+  REAL,DIMENSION(nbtr),INTENT(OUT)      :: vdeptr
+  REAL,DIMENSION(nbtr),INTENT(OUT)      :: scavtr
+  INTEGER                               :: i, it
+  REAL                                  :: s
+
+  CHARACTER (LEN=20) :: modname='initrrnpb'
+  CHARACTER (LEN=80) :: abort_message
+
+!
+! Radon it = id_rn
+!----------------
+  IF (id_rn /= 0) THEN
+     it = id_rn
+     s = 1.E4             ! Source: atome par m2
+     hsoltr(it) = 0.1     ! Hauteur equivalente du reservoir : 
+                          ! 1 m * porosite 0.1
+     tautr(it) = 4.765E5  ! Decroissance du radon, secondes
+     vdeptr(it) = 0.      ! Pas de depot sec pour le radon
+     scavtr(it) = 0.      ! Pas de lessivage pour le radon
+     
+     WRITE(*,*)'-------------- SOURCE DU RADON ------------------------ '
+     WRITE(*,*)'it = ',it
+     WRITE(*,*)'Source : ', s
+     WRITE(*,*)'Hauteur equivalente du reservoir de sol: ',hsoltr(it) 
+     WRITE(*,*)'Decroissance (s): ', tautr(it)
+     WRITE(*,*)'Vitesse de depot sec: ',vdeptr(it) 
+     WRITE(*,*)'Facteur de lessivage: ',scavtr(it)
+
+     DO i = 1,klon
+        masktr(i,it) = 0.
+        IF ( NINT(pctsrf(i,1)) .EQ. 1 ) masktr(i,it) = 1.
+        fshtr(i,it) = s * masktr(i,it)
+     END DO
+
+  END IF ! id_rn /= 0
+
+!
+! 210Pb it = id_pb
+!----------------
+  IF (id_pb /= 0) THEN
+     it = id_pb
+     s = 0.                ! Pas de source 
+     hsoltr(it) = 10.      ! Hauteur equivalente du reservoir 
+                           ! a partir duquel le depot Brownien a lieu
+     tautr(it) = 1.028E9   ! Decroissance du Pb210, secondes
+     vdeptr(it) = 1.E-3    ! 1 mm/s pour le 210Pb
+     scavtr(it) =  .5      ! Lessivage du Pb210
+     DO i = 1,klon
+        masktr(i,it) = 1.  ! Le depot sec peut avoir lieu partout
+        fshtr(i,it) = s * masktr(i,it)
+     END DO
+     WRITE(*,*)'-------------- SOURCE DU PLOMB ------------------------ '
+     WRITE(*,*)'it = ',it
+     WRITE(*,*)'Source : ', s
+     WRITE(*,*)'Hauteur equivalente du reservoir : ',hsoltr(it) 
+     WRITE(*,*)'Decroissance (s): ', tautr(it)
+     WRITE(*,*)'Vitesse de depot sec: ',vdeptr(it) 
+     WRITE(*,*)'Facteur de lessivage: ',scavtr(it)
+     
+  END IF
+     
+END SUBROUTINE initrrnpb
Index: DZ6/trunk/libf/phylmd/inlandsis/VAR0SV.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/inlandsis/VAR0SV.F90	(revision 5267)
+++ 	(revision )
@@ -1,33 +1,0 @@
-MODULE VAR0SV
-
-USE VAR_SV, only : nsol, nsno 
-USE VARdSV, only : nsot
-
-IMPLICIT NONE
-                                                  
-      INTEGER    :: islpSV(-nsol:0)                                           
-      INTEGER    :: isnpSV(      nsno)                                        
-      INTEGER    :: islmSV(-nsol:0)    
-                                      
-      INTEGER,PARAMETER :: nkhy=50                                            
-      REAL       :: Implic,Explic                                             
-      REAL       :: dzmiSV(-nsol:0)          ! dz_(i-1/2)                     
-      REAL       :: dzi_SV(-nsol:0)          ! dz_(i-1)/(dz_(i)+dz_(i-1))     
-      REAL       :: dziiSV(-nsol:0)          ! dz_(i)  /(dz_(i)+dz_(i-1))     
-      REAL       :: dtz_SV(-nsol:0)          ! dt / dz             
-      REAL       :: dtz_SV2(-nsol:0)          ! dt / dz             
-      REAL       :: dz78SV(-nsol:0)          ! 7/8 (dz)                       
-      REAL       :: dz34SV(-nsol:0)          ! 3/4 (dz)                       
-      REAL       :: dz_8SV(-nsol:0)          ! 1/8 (dz)                       
-      REAL       :: dzAvSV(-nsol:0)          ! 1/8dz_(-1)+3/4dz+1/8dz_(+1)    
-      REAL       :: OcndSV                   ! Swab Ocean / Soil Ratio        
-      REAL       :: rocsSV( 0:nsot)          ! Soil Contribution to (ro c)_s  
-      REAL       :: etamSV( 0:nsot)          ! Soil Minimum Humidity          
-      REAL       :: s1__SV( 0:nsot)          ! ... X eta**( b+2), DR97(3.36)  
-      REAL       :: s2__SV( 0:nsot)          ! ... X eta**(2b+3), DR97(3.35)  
-      REAL       :: aKdtSV( 0:nsot, 0:nkhy)  ! Khyd=a*eta+b: a * dt           
-      REAL       :: bKdtSV( 0:nsot, 0:nkhy)  ! Khyd=a*eta+b: b * dt     
-      REAL       :: aKdtSV2( 0:nsot, 0:nkhy)  ! Khyd=a*eta+b: a * dt           
-      REAL       :: bKdtSV2( 0:nsot, 0:nkhy)  ! Khyd=a*eta+b: b * dt                 
-
-END MODULE VAR0SV
Index: /LMDZ6/trunk/libf/phylmd/inlandsis/VAR0SV.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/inlandsis/VAR0SV.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/inlandsis/VAR0SV.f90	(revision 5268)
@@ -0,0 +1,33 @@
+MODULE VAR0SV
+
+USE VAR_SV, only : nsol, nsno 
+USE VARdSV, only : nsot
+
+IMPLICIT NONE
+                                                  
+      INTEGER    :: islpSV(-nsol:0)                                           
+      INTEGER    :: isnpSV(      nsno)                                        
+      INTEGER    :: islmSV(-nsol:0)    
+                                      
+      INTEGER,PARAMETER :: nkhy=50                                            
+      REAL       :: Implic,Explic                                             
+      REAL       :: dzmiSV(-nsol:0)          ! dz_(i-1/2)                     
+      REAL       :: dzi_SV(-nsol:0)          ! dz_(i-1)/(dz_(i)+dz_(i-1))     
+      REAL       :: dziiSV(-nsol:0)          ! dz_(i)  /(dz_(i)+dz_(i-1))     
+      REAL       :: dtz_SV(-nsol:0)          ! dt / dz             
+      REAL       :: dtz_SV2(-nsol:0)          ! dt / dz             
+      REAL       :: dz78SV(-nsol:0)          ! 7/8 (dz)                       
+      REAL       :: dz34SV(-nsol:0)          ! 3/4 (dz)                       
+      REAL       :: dz_8SV(-nsol:0)          ! 1/8 (dz)                       
+      REAL       :: dzAvSV(-nsol:0)          ! 1/8dz_(-1)+3/4dz+1/8dz_(+1)    
+      REAL       :: OcndSV                   ! Swab Ocean / Soil Ratio        
+      REAL       :: rocsSV( 0:nsot)          ! Soil Contribution to (ro c)_s  
+      REAL       :: etamSV( 0:nsot)          ! Soil Minimum Humidity          
+      REAL       :: s1__SV( 0:nsot)          ! ... X eta**( b+2), DR97(3.36)  
+      REAL       :: s2__SV( 0:nsot)          ! ... X eta**(2b+3), DR97(3.35)  
+      REAL       :: aKdtSV( 0:nsot, 0:nkhy)  ! Khyd=a*eta+b: a * dt           
+      REAL       :: bKdtSV( 0:nsot, 0:nkhy)  ! Khyd=a*eta+b: b * dt     
+      REAL       :: aKdtSV2( 0:nsot, 0:nkhy)  ! Khyd=a*eta+b: a * dt           
+      REAL       :: bKdtSV2( 0:nsot, 0:nkhy)  ! Khyd=a*eta+b: b * dt                 
+
+END MODULE VAR0SV
Index: DZ6/trunk/libf/phylmd/inlandsis/VAR_SV.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/inlandsis/VAR_SV.F90	(revision 5267)
+++ 	(revision )
@@ -1,26 +1,0 @@
-MODULE VAR_SV
-
-
-IMPLICIT NONE
-
-INCLUDE "dimsoil.h"
-
-! +
-! +   LMDZ_SV dims
-! +   ===================
-! +
-!      INTEGER,PARAMETER :: nsol=nsoilmx-1
-!      INTEGER,PARAMETER :: nsno=nsnowmx
-     
-      INTEGER, PARAMETER    :: nsol=nsoilmx-1
-      INTEGER, PARAMETER    :: nsot=nsoilmx+1
-      INTEGER, PARAMETER    :: nsno=nsnowmx
-      INTEGER, PARAMETER    :: nb_wri=1
-      INTEGER,SAVE      :: klonv
-!$OMP THREADPRIVATE(klonv)
-      INTEGER,SAVE      :: knonv
-!$OMP THREADPRIVATE(knonv)
-
-
-
-END MODULE VAR_SV
Index: /LMDZ6/trunk/libf/phylmd/inlandsis/VAR_SV.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/inlandsis/VAR_SV.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/inlandsis/VAR_SV.f90	(revision 5268)
@@ -0,0 +1,26 @@
+MODULE VAR_SV
+
+
+IMPLICIT NONE
+
+INCLUDE "dimsoil.h"
+
+! +
+! +   LMDZ_SV dims
+! +   ===================
+! +
+!      INTEGER,PARAMETER :: nsol=nsoilmx-1
+!      INTEGER,PARAMETER :: nsno=nsnowmx
+     
+      INTEGER, PARAMETER    :: nsol=nsoilmx-1
+      INTEGER, PARAMETER    :: nsot=nsoilmx+1
+      INTEGER, PARAMETER    :: nsno=nsnowmx
+      INTEGER, PARAMETER    :: nb_wri=1
+      INTEGER,SAVE      :: klonv
+!$OMP THREADPRIVATE(klonv)
+      INTEGER,SAVE      :: knonv
+!$OMP THREADPRIVATE(knonv)
+
+
+
+END MODULE VAR_SV
Index: DZ6/trunk/libf/phylmd/inlandsis/VARdSV.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/inlandsis/VARdSV.F90	(revision 5267)
+++ 	(revision )
@@ -1,101 +1,0 @@
-MODULE VARdSV
-
-USE VAR_SV
-
-IMPLICIT NONE
-
-
-! +--SISVAT Global Variables
-! +  =======================
-
-      LOGICAL           ::   INI_SV=.false.          ! Initialisation Switch     
-      REAL,PARAMETER    ::   eps_21=1.e-21           ! Arbitrary  very small value
-
-
-! +--Snow
-! +  ----
-
-      INTEGER,PARAMETER,DIMENSION(5) ::   istdSV(1:5)=(/1,2,3,4,5/)  ! Snow History
-
-      REAL,PARAMETER    ::   Cn_dSV= 2105.           ! Snow Heat Capacity          [J/kg/K]
-      REAL,PARAMETER    ::   SMndSV= 1.00            ! Minimum Thickness of new Layers
-      REAL,PARAMETER    ::   G1_dSV= 99.             ! Conversion 0/99-->0/1 
-      REAL,PARAMETER    ::   DDcdSV= 1.,DFcdSV= 4.,DScdSV= 3.   
-                                                     ! Snow Grains Optical Diameter [1e-4m]
-      REAL,PARAMETER    ::   ADSdSV= 4.              ! Snow Grains Actual  Diameter [1e-4m]
-      REAL,PARAMETER    ::   So1dSV= 0.580,So2dSV= 0.320,So3dSV= 0.100
-                                                     ! Total Solar Irradiance Fractions [-]
-                                                     ! Tuning ETH camp 0.3--0.8mim Interval
-                                                     ! Tuning ETH camp 0.8--1.5mim Interval
-                                                     ! Tuning ETH camp 1.5--2.8mim Interval
-                                                     ! So1dSV=0.606,So2dSV=0.301,So3dSV=0.093
-      REAL,PARAMETER    ::   aI1dSV= 0.40,aI2dSV= 0.45,aI3dSV= 0.65
-                                                     ! Bare Ice Albedo                  [-]
-                                                     ! Minimum/Maximum/ICE lense albedo at 
-                                                     ! 800 kg/m3 and minimum pure snow albedo
-      REAL,PARAMETER    ::   ws0dSV= 0.07            ! Irreducible Water Saturation in Snow
-      REAL,PARAMETER    ::   roCdSV= 800.            ! Pore Hole Close OFF Density  [kg/m3]
-      REAL,PARAMETER    ::   roBdSV= 450.            ! Max blowing snow Density [kg/m3]
-      REAL,PARAMETER    ::   roSdSV= 450.            ! Max pure    snow Density [kg/m3]
-      REAL,PARAMETER    ::   ru_dSV= 200.            ! Surficial Water Scale Factor [kg/m2]
-
-!C +--Ice
-!C +  ---
-
-      REAL,PARAMETER    ::   CdidSV= 2.1
-
-
-
-!C +--Soil
-!C +  ----
-
-      REAL,PARAMETER    ::   rcwdSV = 4.180e+6    ! Density * Water Specific Heat
-      REAL              ::   dz_dSV(-nsol:0)      ! Vertical  Discretization MARSV:
-                                                  !/0.72,0.20,0.060,0.019,0.001/ 
-                                                  ! Layer's Thickness
-      REAL              ::   zz_dSV               ! Soil      Thickness
-
-      REAL,PARAMETER    ::   etadSV(0:nsot) = (/ 1.000,0.395,0.410,     &
-     &     0.435,0.485,0.451,0.420,0.477,0.476,0.426,0.492,0.482,0.001 /)      
-                                                  ! Water Content at Saturation  [m3/m3]
-
-      REAL,PARAMETER    ::   psidSV(0:nsot) = (/ 1.000,0.121,0.090,     &
-     &     0.218,0.786,0.478,0.299,0.356,0.630,0.153,0.490,0.405,0.001 /)
-                                                  ! Water Succion at Saturation      [m]
-
-      REAL,PARAMETER    ::   Ks_dSV(0:nsot) = (/ 0.e00, 176.0e-6,       &
-     &          156.3e-6,  34.1e-6,   7.2e-6,   7.0e-6,   6.3e-6,       &
-     &            1.7e-6,   2.5e-6,   2.2e-6,   1.0e-6,   1.3e-6,0.0e0 /)
-                                                  ! Hydraulic Conductivity
-                                                  !               at Saturation    [m/s]
-      REAL,PARAMETER    ::   bCHdSV(0:nsot) = (/ 1.00, 4.05, 4.38,      &
-     &      4.90, 5.30, 5.39, 7.12, 7.75, 8.52,10.40,10.40,11.40, 0.02 /)
-                                                  ! Clapp-Hornberger Coefficient b   [-]
-
- !     etadSV,   psidSV,   Ks_dSV    bCHdSV  
- !     /1.000,    1.000,   0.0e00,     1.00,      !  0 WATER
- !      0.395,    0.121, 176.0e-6,     4.05,      !  1 SAND
- !      0.410,    0.090, 156.3e-6,     4.38,      !  2 LOAMY      SAND
- !      0.435,    0.218,  34.1e-6,     4.90,      !  3 SANDY      LOAM
- !      0.485,    0.786,   7.2e-6,     5.30,      !  4 SILT       LOAM
- !      0.451,    0.478,   7.0e-6,     5.39,      !  5            LOAM
- !      0.420,    0.299,   6.3e-6,     7.12,      !  6 SANDY CLAY LOAM
- !      0.477,    0.356,   1.7e-6,     7.75,      !  7 SILTY CLAY LOAM 
- !      0.476,    0.630,   2.5e-6,     8.52,      !  8       CLAY LOAM
- !      0.426,    0.153,   2.2e-6,    10.40,      !  9 SANDY CLAY
- !      0.492,    0.490,   1.0e-6,    10.40,      ! 10 SILTY CLAY
- !      0.482,    0.405,   1.3e-6,    11.40,      ! 11       CLAY
- !      0.001,    0.001,   0.0e00,     0.02/      ! 12       ICE 
-
-
-!C +--Water Bodies
-!C +  ------------
-
-      REAL,PARAMETER    ::   vK_dSV = 1000.       ! Diffusivity in Water          [m2/s]
-      REAL,PARAMETER    ::   TSIdSV = 0.50        ! Sea-Ice Fraction: SST Scale      [K]
-
-      INTEGER ::  iso1  !rajout hjp for ini - check if ivg,iso is possible
-
-!
-
-END MODULE VARdSV
Index: /LMDZ6/trunk/libf/phylmd/inlandsis/VARdSV.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/inlandsis/VARdSV.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/inlandsis/VARdSV.f90	(revision 5268)
@@ -0,0 +1,101 @@
+MODULE VARdSV
+
+USE VAR_SV
+
+IMPLICIT NONE
+
+
+! +--SISVAT Global Variables
+! +  =======================
+
+      LOGICAL           ::   INI_SV=.false.          ! Initialisation Switch     
+      REAL,PARAMETER    ::   eps_21=1.e-21           ! Arbitrary  very small value
+
+
+! +--Snow
+! +  ----
+
+      INTEGER,PARAMETER,DIMENSION(5) ::   istdSV(1:5)=(/1,2,3,4,5/)  ! Snow History
+
+      REAL,PARAMETER    ::   Cn_dSV= 2105.           ! Snow Heat Capacity          [J/kg/K]
+      REAL,PARAMETER    ::   SMndSV= 1.00            ! Minimum Thickness of new Layers
+      REAL,PARAMETER    ::   G1_dSV= 99.             ! Conversion 0/99-->0/1 
+      REAL,PARAMETER    ::   DDcdSV= 1.,DFcdSV= 4.,DScdSV= 3.   
+                                                     ! Snow Grains Optical Diameter [1e-4m]
+      REAL,PARAMETER    ::   ADSdSV= 4.              ! Snow Grains Actual  Diameter [1e-4m]
+      REAL,PARAMETER    ::   So1dSV= 0.580,So2dSV= 0.320,So3dSV= 0.100
+                                                     ! Total Solar Irradiance Fractions [-]
+                                                     ! Tuning ETH camp 0.3--0.8mim Interval
+                                                     ! Tuning ETH camp 0.8--1.5mim Interval
+                                                     ! Tuning ETH camp 1.5--2.8mim Interval
+                                                     ! So1dSV=0.606,So2dSV=0.301,So3dSV=0.093
+      REAL,PARAMETER    ::   aI1dSV= 0.40,aI2dSV= 0.45,aI3dSV= 0.65
+                                                     ! Bare Ice Albedo                  [-]
+                                                     ! Minimum/Maximum/ICE lense albedo at 
+                                                     ! 800 kg/m3 and minimum pure snow albedo
+      REAL,PARAMETER    ::   ws0dSV= 0.07            ! Irreducible Water Saturation in Snow
+      REAL,PARAMETER    ::   roCdSV= 800.            ! Pore Hole Close OFF Density  [kg/m3]
+      REAL,PARAMETER    ::   roBdSV= 450.            ! Max blowing snow Density [kg/m3]
+      REAL,PARAMETER    ::   roSdSV= 450.            ! Max pure    snow Density [kg/m3]
+      REAL,PARAMETER    ::   ru_dSV= 200.            ! Surficial Water Scale Factor [kg/m2]
+
+!C +--Ice
+!C +  ---
+
+      REAL,PARAMETER    ::   CdidSV= 2.1
+
+
+
+!C +--Soil
+!C +  ----
+
+      REAL,PARAMETER    ::   rcwdSV = 4.180e+6    ! Density * Water Specific Heat
+      REAL              ::   dz_dSV(-nsol:0)      ! Vertical  Discretization MARSV:
+                                                  !/0.72,0.20,0.060,0.019,0.001/ 
+                                                  ! Layer's Thickness
+      REAL              ::   zz_dSV               ! Soil      Thickness
+
+      REAL,PARAMETER    ::   etadSV(0:nsot) = (/ 1.000,0.395,0.410,     &
+     &     0.435,0.485,0.451,0.420,0.477,0.476,0.426,0.492,0.482,0.001 /)      
+                                                  ! Water Content at Saturation  [m3/m3]
+
+      REAL,PARAMETER    ::   psidSV(0:nsot) = (/ 1.000,0.121,0.090,     &
+     &     0.218,0.786,0.478,0.299,0.356,0.630,0.153,0.490,0.405,0.001 /)
+                                                  ! Water Succion at Saturation      [m]
+
+      REAL,PARAMETER    ::   Ks_dSV(0:nsot) = (/ 0.e00, 176.0e-6,       &
+     &          156.3e-6,  34.1e-6,   7.2e-6,   7.0e-6,   6.3e-6,       &
+     &            1.7e-6,   2.5e-6,   2.2e-6,   1.0e-6,   1.3e-6,0.0e0 /)
+                                                  ! Hydraulic Conductivity
+                                                  !               at Saturation    [m/s]
+      REAL,PARAMETER    ::   bCHdSV(0:nsot) = (/ 1.00, 4.05, 4.38,      &
+     &      4.90, 5.30, 5.39, 7.12, 7.75, 8.52,10.40,10.40,11.40, 0.02 /)
+                                                  ! Clapp-Hornberger Coefficient b   [-]
+
+ !     etadSV,   psidSV,   Ks_dSV    bCHdSV  
+ !     /1.000,    1.000,   0.0e00,     1.00,      !  0 WATER
+ !      0.395,    0.121, 176.0e-6,     4.05,      !  1 SAND
+ !      0.410,    0.090, 156.3e-6,     4.38,      !  2 LOAMY      SAND
+ !      0.435,    0.218,  34.1e-6,     4.90,      !  3 SANDY      LOAM
+ !      0.485,    0.786,   7.2e-6,     5.30,      !  4 SILT       LOAM
+ !      0.451,    0.478,   7.0e-6,     5.39,      !  5            LOAM
+ !      0.420,    0.299,   6.3e-6,     7.12,      !  6 SANDY CLAY LOAM
+ !      0.477,    0.356,   1.7e-6,     7.75,      !  7 SILTY CLAY LOAM 
+ !      0.476,    0.630,   2.5e-6,     8.52,      !  8       CLAY LOAM
+ !      0.426,    0.153,   2.2e-6,    10.40,      !  9 SANDY CLAY
+ !      0.492,    0.490,   1.0e-6,    10.40,      ! 10 SILTY CLAY
+ !      0.482,    0.405,   1.3e-6,    11.40,      ! 11       CLAY
+ !      0.001,    0.001,   0.0e00,     0.02/      ! 12       ICE 
+
+
+!C +--Water Bodies
+!C +  ------------
+
+      REAL,PARAMETER    ::   vK_dSV = 1000.       ! Diffusivity in Water          [m2/s]
+      REAL,PARAMETER    ::   TSIdSV = 0.50        ! Sea-Ice Fraction: SST Scale      [K]
+
+      INTEGER ::  iso1  !rajout hjp for ini - check if ivg,iso is possible
+
+!
+
+END MODULE VARdSV
Index: DZ6/trunk/libf/phylmd/inlandsis/VARphy.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/inlandsis/VARphy.F90	(revision 5267)
+++ 	(revision )
@@ -1,103 +1,0 @@
-MODULE VARphy
-
-
-IMPLICIT NONE
-
-
-
-! Etienne, 08112020: merging YOMCST_SISVAT,  PHY_SV and VARphy
-! but redundancies remain
-!
-!  ATTENTION!!!!: ce fichier include est compatible format fixe/format libre
-!                 veillez à n'utiliser que des ! pour les commentaires
-!                 et à bien positionner les & des lignes de continuation
-!                 (les placer en colonne 6 et en colonne 73)
-!
-!
-! A1.0 Fundamental constants
-!----------------------------
-! Constants
-                                                                              
-      CHARACTER(LEN=1), PARAMETER :: labnum(0:9) =                            &
-              (/'0','1','2','3','4','5','6','7','8','9'/)             
-!C +...                labnum: Alphanumeric Character      
-     
-                                                                               
-      INTEGER, PARAMETER ::  iun=1                                             
-      REAL, PARAMETER    ::  zer0 = 0.0e+0, half = 0.5e+0, un_1 = 1.0e+0,     &
-     &                       eps6 = 1.0e-6, R_1000=1.e3   
-      REAL, PARAMETER    ::  zero = 0.0e+0, demi = 0.5e+0, unun = 1.0e+0,     &
-     &                       epsi = 1.0e-6, eps9 = 1.0e-9         
-      REAL               ::  ea_MAX,ea_MIN                                                                               
-      REAL, PARAMETER    ::  pi = 3.141592653589793238462643e0
-     
-! A1.2 Geoide
-!-------------
-      REAL, PARAMETER    ::  Grav_F = 9.81e0, Grav_I = 1./Grav_F                       
-!C +                   Grav_F:  Gravitational  Force         =  9.81    m/s2           
-!C +                   Grav_I: 1 / Grav_F                    = 1 /9.81    s2/m    
-
-                                                                               
-      REAL, PARAMETER    ::  gravit = 9.81e0,      gravi2 = gravit**2 ,       &
-     &                       grvinv = 1./gravit                       
-!C +                   gravit: Earth Gravity Acceleration    = 9.81    m/s2    
-!C +                   gravi2: idem (squared)                                  
-!C +                   grvinv: idem (inverse)                 
-! A1.3 Radiation
-!----------------
-      REAL,PARAMETER :: StefBo=5.67e-8  
-!C +                   StefBo: Stefan-Boltzman Constant       =    5.67d-8 W/m2/K4
-
-! A1.4 Thermodynamic 
-!-----------------------------
-     
-      REAL, PARAMETER    ::  cp=1004.708845
-                                                       
-      REAL, PARAMETER    ::  RVapor=461.e0, Lv_H2O=2.5008e+6,&
-     &                       Ls_H2O=2.8345e+6, r_LvCp=2490.04,r_LcCp=332.27,  &
-     &                       r_LsCp=2822.31            
-!C +                   cp    : dry air specific heat at constant p (1004 J/kg/K) 
-
-      REAL, PARAMETER    ::  LhfH2O=3.34e+5, LhvH2O=2.5008e+6,&
-     &                       LhsH2O=2.8345e+6     
-      REAL, PARAMETER    ::  rhoWat=1000.00e0    
-!C +                   rhoWat: Water Specific Mass            = 1000.00d+0 kg/m3 
-
-      REAL, PARAMETER    ::  rhoIce=920.e0, BSnoRo=3.30e+2, frsno=300.0                             
-!C +...                rhoIce:  Density      of Pure Ice      =  920.00d+0 kg/m3
-!C +                   BSnoRo : Blowed Snow Density           =  255.00d+0 kg/m3 
-                                                                                
-      REAL, PARAMETER    ::  Tf_Sno=273.16e+0 
-!C +...                Tf_Sno: Snow  Melting  Point           =  273.16    K     
-
-
-      REAL, PARAMETER    ::  ro_Wat=1000.00e0, C__Wat=4186.00e0
-!C +                   ro_Wat: Density       of Water         = 1000.00d+0 kg/m3 
-!C +                   C__Wat: Heat Capacity of Water         = 4186.00d+0 J/kg/K
-                                                                                
-      REAL, PARAMETER    ::  ro_Ice=920.e0, cdice=2.10e0                                 
-!C +...                ro_Ice:  Density      of Pure Ice       =  920.00d+0 kg/m3
-!C +                   cdice :  Conductivity of Pure Ice       =    2.51d+0 W/m/K
-                                                                                
-      REAL, PARAMETER    ::  TfSnow=273.15e+0,csnow=2105.00e+0,r0sno=3.00e+1, &
-     &                       blsno=3.30e+2,   Lf_H2O=3.337e+5                          
-!C +...                TfSnow:        Snow melting Temperature=  273.15d+0 K     
-!C +                    csnow:Heat Capacity of Snow             2105      J/kg/K 
-!C +                         (Loth et al. 1993, JGR 98 D6, 2.2.2 2e para p.10453)
-!C +                   r0sno : Fresh  Snow Density                50.00d+0 kg/m3 
-!C +                   blsno : Blowed Snow Density               330.00d+0 kg/m3 
-!C +                   Lf_H2O: Latent Heat of Fusion of Snow  =    3.34d+5 J/kg  
-
-! A1.6 Turbulent and molecular diffusion
-!----------------------------------------
-      REAL, PARAMETER    ::  A_MolV = 1.35e-5, vonKrm = 0.40e0, r_turb=3.0
-      REAL, PARAMETER    ::  A_turb=5.8, akmol=1.35e-5
-!C +...                A_MolV: Air Viscosity                 = 1.35d-5 m2/s   
-!C +                   vonKrm: von Karman constant           = 0.4            
-!C +                   r_turb:   Turbulent Diffusivities Ratio K*/Km        
-!C +                   A_turb:    Stability  Coefficient Moment                                 
-!C +                   Air Viscosity                 = 1.35d-5 m2/s                 
-
-
-
-END MODULE VARphy
Index: /LMDZ6/trunk/libf/phylmd/inlandsis/VARphy.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/inlandsis/VARphy.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/inlandsis/VARphy.f90	(revision 5268)
@@ -0,0 +1,103 @@
+MODULE VARphy
+
+
+IMPLICIT NONE
+
+
+
+! Etienne, 08112020: merging YOMCST_SISVAT,  PHY_SV and VARphy
+! but redundancies remain
+!
+!  ATTENTION!!!!: ce fichier include est compatible format fixe/format libre
+!                 veillez à n'utiliser que des ! pour les commentaires
+!                 et à bien positionner les & des lignes de continuation
+!                 (les placer en colonne 6 et en colonne 73)
+!
+!
+! A1.0 Fundamental constants
+!----------------------------
+! Constants
+                                                                              
+      CHARACTER(LEN=1), PARAMETER :: labnum(0:9) =                            &
+              (/'0','1','2','3','4','5','6','7','8','9'/)             
+!C +...                labnum: Alphanumeric Character      
+     
+                                                                               
+      INTEGER, PARAMETER ::  iun=1                                             
+      REAL, PARAMETER    ::  zer0 = 0.0e+0, half = 0.5e+0, un_1 = 1.0e+0,     &
+     &                       eps6 = 1.0e-6, R_1000=1.e3   
+      REAL, PARAMETER    ::  zero = 0.0e+0, demi = 0.5e+0, unun = 1.0e+0,     &
+     &                       epsi = 1.0e-6, eps9 = 1.0e-9         
+      REAL               ::  ea_MAX,ea_MIN                                                                               
+      REAL, PARAMETER    ::  pi = 3.141592653589793238462643e0
+     
+! A1.2 Geoide
+!-------------
+      REAL, PARAMETER    ::  Grav_F = 9.81e0, Grav_I = 1./Grav_F                       
+!C +                   Grav_F:  Gravitational  Force         =  9.81    m/s2           
+!C +                   Grav_I: 1 / Grav_F                    = 1 /9.81    s2/m    
+
+                                                                               
+      REAL, PARAMETER    ::  gravit = 9.81e0,      gravi2 = gravit**2 ,       &
+     &                       grvinv = 1./gravit                       
+!C +                   gravit: Earth Gravity Acceleration    = 9.81    m/s2    
+!C +                   gravi2: idem (squared)                                  
+!C +                   grvinv: idem (inverse)                 
+! A1.3 Radiation
+!----------------
+      REAL,PARAMETER :: StefBo=5.67e-8  
+!C +                   StefBo: Stefan-Boltzman Constant       =    5.67d-8 W/m2/K4
+
+! A1.4 Thermodynamic 
+!-----------------------------
+     
+      REAL, PARAMETER    ::  cp=1004.708845
+                                                       
+      REAL, PARAMETER    ::  RVapor=461.e0, Lv_H2O=2.5008e+6,&
+     &                       Ls_H2O=2.8345e+6, r_LvCp=2490.04,r_LcCp=332.27,  &
+     &                       r_LsCp=2822.31            
+!C +                   cp    : dry air specific heat at constant p (1004 J/kg/K) 
+
+      REAL, PARAMETER    ::  LhfH2O=3.34e+5, LhvH2O=2.5008e+6,&
+     &                       LhsH2O=2.8345e+6     
+      REAL, PARAMETER    ::  rhoWat=1000.00e0    
+!C +                   rhoWat: Water Specific Mass            = 1000.00d+0 kg/m3 
+
+      REAL, PARAMETER    ::  rhoIce=920.e0, BSnoRo=3.30e+2, frsno=300.0                             
+!C +...                rhoIce:  Density      of Pure Ice      =  920.00d+0 kg/m3
+!C +                   BSnoRo : Blowed Snow Density           =  255.00d+0 kg/m3 
+                                                                                
+      REAL, PARAMETER    ::  Tf_Sno=273.16e+0 
+!C +...                Tf_Sno: Snow  Melting  Point           =  273.16    K     
+
+
+      REAL, PARAMETER    ::  ro_Wat=1000.00e0, C__Wat=4186.00e0
+!C +                   ro_Wat: Density       of Water         = 1000.00d+0 kg/m3 
+!C +                   C__Wat: Heat Capacity of Water         = 4186.00d+0 J/kg/K
+                                                                                
+      REAL, PARAMETER    ::  ro_Ice=920.e0, cdice=2.10e0                                 
+!C +...                ro_Ice:  Density      of Pure Ice       =  920.00d+0 kg/m3
+!C +                   cdice :  Conductivity of Pure Ice       =    2.51d+0 W/m/K
+                                                                                
+      REAL, PARAMETER    ::  TfSnow=273.15e+0,csnow=2105.00e+0,r0sno=3.00e+1, &
+     &                       blsno=3.30e+2,   Lf_H2O=3.337e+5                          
+!C +...                TfSnow:        Snow melting Temperature=  273.15d+0 K     
+!C +                    csnow:Heat Capacity of Snow             2105      J/kg/K 
+!C +                         (Loth et al. 1993, JGR 98 D6, 2.2.2 2e para p.10453)
+!C +                   r0sno : Fresh  Snow Density                50.00d+0 kg/m3 
+!C +                   blsno : Blowed Snow Density               330.00d+0 kg/m3 
+!C +                   Lf_H2O: Latent Heat of Fusion of Snow  =    3.34d+5 J/kg  
+
+! A1.6 Turbulent and molecular diffusion
+!----------------------------------------
+      REAL, PARAMETER    ::  A_MolV = 1.35e-5, vonKrm = 0.40e0, r_turb=3.0
+      REAL, PARAMETER    ::  A_turb=5.8, akmol=1.35e-5
+!C +...                A_MolV: Air Viscosity                 = 1.35d-5 m2/s   
+!C +                   vonKrm: von Karman constant           = 0.4            
+!C +                   r_turb:   Turbulent Diffusivities Ratio K*/Km        
+!C +                   A_turb:    Stability  Coefficient Moment                                 
+!C +                   Air Viscosity                 = 1.35d-5 m2/s                 
+
+
+
+END MODULE VARphy
Index: DZ6/trunk/libf/phylmd/inlandsis/VARtSV.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/inlandsis/VARtSV.F90	(revision 5267)
+++ 	(revision )
@@ -1,92 +1,0 @@
-MODULE VARtSV
-
-USE VAR_SV, only : nsol, nsno, klonv
-
-IMPLICIT NONE
-! +
-      INTEGER, PARAMETER      ::   ntaver = 4
-! +
-      REAL,ALLOCATABLE,SAVE                ::   toicSV(:)    ! Snow to ice balance    
-!$OMP THREADPRIVATE(toicSV)
-
-      REAL,ALLOCATABLE,SAVE                ::   dz1_SV(:,:) ! "inverse" layer thicknes
-!$OMP THREADPRIVATE(dz1_SV)
-      REAL,ALLOCATABLE,SAVE                ::   dz2_SV(:,:) ! layer thickness
-!$OMP THREADPRIVATE(dz2_SV)
-
-
-      REAL, DIMENSION(:),ALLOCATABLE,SAVE  ::   Tsf_SV  ! surface temperature !hj12032010
-!$OMP THREADPRIVATE(Tsf_SV)
-      REAL, DIMENSION(:),ALLOCATABLE,SAVE  ::   TsfnSV  ! new surface temperature 
-!$OMP THREADPRIVATE(TsfnSV)
-      REAL, DIMENSION(:),ALLOCATABLE,SAVE  ::   AcoHSV, BcoHSV ! coefficients for Enthalpy
-!$OMP THREADPRIVATE(AcoHSV, BcoHSV)                             ! evolution,from atmosphere
-      REAL, DIMENSION(:),ALLOCATABLE,SAVE  ::   AcoQSV, BcoQSV ! coefficients for Humidity
-!$OMP THREADPRIVATE( AcoQSV, BcoQSV)                            ! evolution,from atmosphere
-      REAL, DIMENSION(:),ALLOCATABLE,SAVE  ::   ps__SV  ! surface pressure 
-!$OMP THREADPRIVATE(ps__SV)
-      REAL, DIMENSION(:),ALLOCATABLE,SAVE  ::   p1l_SV  ! 1st layer pressure 
-!$OMP THREADPRIVATE(p1l_SV)
-      REAL, DIMENSION(:),ALLOCATABLE,SAVE  ::   cdH_SV  ! drag coeff Energy (?)
-!$OMP THREADPRIVATE(cdH_SV)
-      REAL, DIMENSION(:),ALLOCATABLE,SAVE  ::   cdM_SV  ! drag coeff momentum (?)
-!$OMP THREADPRIVATE(cdM_SV)
-      REAL, DIMENSION(:),ALLOCATABLE,SAVE  ::   rsolSV  ! Radiation balance surface
-!$OMP THREADPRIVATE(rsolSV)
-      REAL,SAVE                            ::   lambSV  ! coefficient soil layers
-!$OMP THREADPRIVATE(lambSV)
-
- 
-CONTAINS
-
-  SUBROUTINE INIT_VARtSV
-  
-  IMPLICIT NONE
-
-  INTEGER ikl
-
-
-
-
-
-
-
-      ALLOCATE(toicSV(klonv))
-
-      ALLOCATE(dz1_SV(klonv,-nsol:nsno))     ! "inverse" layer thicknes
-      ALLOCATE(dz2_SV(klonv,-nsol:nsno))     ! layer thickness
-      ALLOCATE(Tsf_SV(klonv))                ! surface temperature !hj12032010
-      ALLOCATE(TsfnSV(klonv))                ! new surface temperature 
-      ALLOCATE(AcoHSV(klonv), BcoHSV(klonv)) ! coefficients for Enthalpy
-                                             ! evolution,from atmosphere
-      ALLOCATE(AcoQSV(klonv), BcoQSV(klonv)) ! coefficients for Humidity
-                                             ! evolution,from atmosphere                                                                                   
-      ALLOCATE(ps__SV(klonv))                ! surface pressure 
-      ALLOCATE(p1l_SV(klonv))                ! 1st layer pressure 
-      ALLOCATE(cdH_SV(klonv))                ! drag coeff Energy (?)
-      ALLOCATE(cdM_SV(klonv))                ! drag coeff momentum (?)
-      ALLOCATE(rsolSV(klonv))                ! Radiation balance surface
-
-      DO ikl=1,klonv        
-           
-         toicSV(ikl)   = 0.
-         dz1_SV(ikl,:) = 0.
-         dz2_SV(ikl,:) = 0.
-         Tsf_SV(ikl)   = 0.
-         TsfnSV(ikl)   = 0.
-         AcoHSV(ikl)   = 0.
-         BcoHSV(ikl)   = 0.
-         AcoQSV(ikl)   = 0.
-         ps__SV(ikl)   = 0.
-         p1l_SV(ikl)   = 0.
-         cdH_SV(ikl)   = 0.
-         cdM_SV(ikl)   = 0.
-         rsolSV(ikl)   = 0.
-      END DO
-
-
-
-  END SUBROUTINE INIT_VARtSV
-
-END MODULE VARtSV
-
Index: /LMDZ6/trunk/libf/phylmd/inlandsis/VARtSV.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/inlandsis/VARtSV.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/inlandsis/VARtSV.f90	(revision 5268)
@@ -0,0 +1,92 @@
+MODULE VARtSV
+
+USE VAR_SV, only : nsol, nsno, klonv
+
+IMPLICIT NONE
+! +
+      INTEGER, PARAMETER      ::   ntaver = 4
+! +
+      REAL,ALLOCATABLE,SAVE                ::   toicSV(:)    ! Snow to ice balance    
+!$OMP THREADPRIVATE(toicSV)
+
+      REAL,ALLOCATABLE,SAVE                ::   dz1_SV(:,:) ! "inverse" layer thicknes
+!$OMP THREADPRIVATE(dz1_SV)
+      REAL,ALLOCATABLE,SAVE                ::   dz2_SV(:,:) ! layer thickness
+!$OMP THREADPRIVATE(dz2_SV)
+
+
+      REAL, DIMENSION(:),ALLOCATABLE,SAVE  ::   Tsf_SV  ! surface temperature !hj12032010
+!$OMP THREADPRIVATE(Tsf_SV)
+      REAL, DIMENSION(:),ALLOCATABLE,SAVE  ::   TsfnSV  ! new surface temperature 
+!$OMP THREADPRIVATE(TsfnSV)
+      REAL, DIMENSION(:),ALLOCATABLE,SAVE  ::   AcoHSV, BcoHSV ! coefficients for Enthalpy
+!$OMP THREADPRIVATE(AcoHSV, BcoHSV)                             ! evolution,from atmosphere
+      REAL, DIMENSION(:),ALLOCATABLE,SAVE  ::   AcoQSV, BcoQSV ! coefficients for Humidity
+!$OMP THREADPRIVATE( AcoQSV, BcoQSV)                            ! evolution,from atmosphere
+      REAL, DIMENSION(:),ALLOCATABLE,SAVE  ::   ps__SV  ! surface pressure 
+!$OMP THREADPRIVATE(ps__SV)
+      REAL, DIMENSION(:),ALLOCATABLE,SAVE  ::   p1l_SV  ! 1st layer pressure 
+!$OMP THREADPRIVATE(p1l_SV)
+      REAL, DIMENSION(:),ALLOCATABLE,SAVE  ::   cdH_SV  ! drag coeff Energy (?)
+!$OMP THREADPRIVATE(cdH_SV)
+      REAL, DIMENSION(:),ALLOCATABLE,SAVE  ::   cdM_SV  ! drag coeff momentum (?)
+!$OMP THREADPRIVATE(cdM_SV)
+      REAL, DIMENSION(:),ALLOCATABLE,SAVE  ::   rsolSV  ! Radiation balance surface
+!$OMP THREADPRIVATE(rsolSV)
+      REAL,SAVE                            ::   lambSV  ! coefficient soil layers
+!$OMP THREADPRIVATE(lambSV)
+
+ 
+CONTAINS
+
+  SUBROUTINE INIT_VARtSV
+  
+  IMPLICIT NONE
+
+  INTEGER ikl
+
+
+
+
+
+
+
+      ALLOCATE(toicSV(klonv))
+
+      ALLOCATE(dz1_SV(klonv,-nsol:nsno))     ! "inverse" layer thicknes
+      ALLOCATE(dz2_SV(klonv,-nsol:nsno))     ! layer thickness
+      ALLOCATE(Tsf_SV(klonv))                ! surface temperature !hj12032010
+      ALLOCATE(TsfnSV(klonv))                ! new surface temperature 
+      ALLOCATE(AcoHSV(klonv), BcoHSV(klonv)) ! coefficients for Enthalpy
+                                             ! evolution,from atmosphere
+      ALLOCATE(AcoQSV(klonv), BcoQSV(klonv)) ! coefficients for Humidity
+                                             ! evolution,from atmosphere                                                                                   
+      ALLOCATE(ps__SV(klonv))                ! surface pressure 
+      ALLOCATE(p1l_SV(klonv))                ! 1st layer pressure 
+      ALLOCATE(cdH_SV(klonv))                ! drag coeff Energy (?)
+      ALLOCATE(cdM_SV(klonv))                ! drag coeff momentum (?)
+      ALLOCATE(rsolSV(klonv))                ! Radiation balance surface
+
+      DO ikl=1,klonv        
+           
+         toicSV(ikl)   = 0.
+         dz1_SV(ikl,:) = 0.
+         dz2_SV(ikl,:) = 0.
+         Tsf_SV(ikl)   = 0.
+         TsfnSV(ikl)   = 0.
+         AcoHSV(ikl)   = 0.
+         BcoHSV(ikl)   = 0.
+         AcoQSV(ikl)   = 0.
+         ps__SV(ikl)   = 0.
+         p1l_SV(ikl)   = 0.
+         cdH_SV(ikl)   = 0.
+         cdM_SV(ikl)   = 0.
+         rsolSV(ikl)   = 0.
+      END DO
+
+
+
+  END SUBROUTINE INIT_VARtSV
+
+END MODULE VARtSV
+
Index: DZ6/trunk/libf/phylmd/inlandsis/VARxSV.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/inlandsis/VARxSV.F90	(revision 5267)
+++ 	(revision )
@@ -1,417 +1,0 @@
-MODULE VARxSV                      
-
-USE VAR_SV, only : klonv, nsol, nsno, nb_wri
-                                                          
-IMPLICIT NONE                                                                                
-! +--SISVAT INPUT        Variables                                              
-! +  -----------------------------                                              
-  
-      INTEGER, DIMENSION(:),ALLOCATABLE,SAVE ::   LSmask  ! Land-Sea   Mask                 
-!$OMP THREADPRIVATE(LSmask)
-      INTEGER, DIMENSION(:),ALLOCATABLE,SAVE ::   isotSV  ! Soil       Type                 
-!$OMP THREADPRIVATE(isotSV)
-      INTEGER, DIMENSION(:),ALLOCATABLE,SAVE ::   iWaFSV  ! Soil       Drainage:(1,0)=(y,n) 
-!$OMP THREADPRIVATE(iWaFSV)                                                                              
-      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   coszSV  ! Cosine of Sun zenithal Angle    
-!$OMP THREADPRIVATE(coszSV)
-      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   sol_SV  ! Downward  Solar    Radiation    
-!$OMP THREADPRIVATE(sol_SV)
-      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   IRd_SV  ! Downward  Longwave Radiation    
-!$OMP THREADPRIVATE(IRd_SV)
-                                                                                
-      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   drr_SV  ! Rain  Intensity       [kg/m2/s] 
-!$OMP THREADPRIVATE(drr_SV)
-      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   dsn_SV  ! Snow  Intensity       [kg/m2/s] 
-!$OMP THREADPRIVATE(dsn_SV)
-      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   dsnbSV  ! Idem, fraction, from Drift  [-] 
-!$OMP THREADPRIVATE(dsnbSV)
-      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   esnbSV  ! Idem, fraction, from Drift  [-]
-!$OMP THREADPRIVATE(esnbSV)
-      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   dbs_SV  ! Drift Amount            [kg/m2] 
-!$OMP THREADPRIVATE(dbs_SV)
-      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   dbs_Er  ! BS Erosion              [kg/m2]
-!$OMP THREADPRIVATE(dbs_Er)
-      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   dbs_Ac  !  BS Accumulation         [kg/m2]
-!$OMP THREADPRIVATE(dbs_Ac)
-      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   BrosSV  ! Buffer Snow Layer Density
-!$OMP THREADPRIVATE(BrosSV)
-      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   BG1sSV  ! Buffer Snow Layer Dendr/Sphe[-]
-!$OMP THREADPRIVATE(BG1sSV)
-      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   BG2sSV  ! Buffer Snow Layer Spher/Size[-][0.0001m]
-!$OMP THREADPRIVATE(BG2sSV)
-      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   dz0_SV  ! dz0(Sastrugi dh)            [m] 
-!$OMP THREADPRIVATE(dz0_SV)
-                                                                               
-      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   cld_SV  ! Cloudiness (seen from SBL)      
-!$OMP THREADPRIVATE(cld_SV)
-      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   za__SV  ! SBL Height                      
-!$OMP THREADPRIVATE(za__SV)
-      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   VV__SV  !(SBL Top)  Wind Velocity         
-!$OMP THREADPRIVATE(VV__SV)
-      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   VVs_SV  !(Sastr,V)  Relevance
-!$OMP THREADPRIVATE(VVs_SV)
-      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   RRs_SV  !(Sastr,V)  Counter
-!$OMP THREADPRIVATE(RRs_SV)
-      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   DDs_SV  !(Sastr,V)  Angle
-!$OMP THREADPRIVATE(DDs_SV)
-      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   TaT_SV  ! SBL Top   Temperature           
-!$OMP THREADPRIVATE(TaT_SV)
-      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   ExnrSV  ! Exner     Potential             
-!$OMP THREADPRIVATE(ExnrSV)
-      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   dSdTSV  ! Sensible Heat Flux T Derivat.   
-!$OMP THREADPRIVATE(dSdTSV)
-      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   dLdTSV  ! Latent   Heat Flux T Derivat.   
-!$OMP THREADPRIVATE(dLdTSV)
-      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   rhT_SV  ! SBL Top   Air  Density          
-!$OMP THREADPRIVATE(rhT_SV)
-      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   QaT_SV  ! SBL Top   Specific Humidity     
-!$OMP THREADPRIVATE(QaT_SV)
-      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   QsT_SV  ! SBL Top   Specific Humidity
-!$OMP THREADPRIVATE(QsT_SV)
-      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   dQa_SV  ! SBL Flux  Limitation of Qa      
-!$OMP THREADPRIVATE(dQa_SV)
-      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   qsnoSV  ! SBL Mean  Snow       Content    
-!$OMP THREADPRIVATE(qsnoSV)                                                                   
-                                                                               
-      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   alb0SV  ! Soil    Albedo                  
-!$OMP THREADPRIVATE(alb0SV)
-      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   slopSV  ! Snow/Ice/Soil-Water Surf. Slope 
-!$OMP THREADPRIVATE(slopSV)
-
-                                                              
-      REAL,SAVE                      ::   dt__SV  ! Time Step                       
-!$OMP THREADPRIVATE(dt__SV)
-      CHARACTER (len=18),SAVE        ::   daHost  ! Date Host Model                 
-!$OMP THREADPRIVATE(daHost)
-                                                                               
-                                                                               
-! +--SISVAT INPUT/OUTPUT Variables                                             
-! +  -----------------------------                                             
-                                                                               
-      INTEGER, DIMENSION(:),ALLOCATABLE,SAVE ::   isnoSV  ! Nb of Ice/Snow Layers           
-!$OMP THREADPRIVATE(isnoSV)
-      INTEGER, DIMENSION(:),ALLOCATABLE,SAVE ::   ispiSV  ! Uppermost superimposed ice      
-!$OMP THREADPRIVATE(ispiSV)
-      INTEGER, DIMENSION(:),ALLOCATABLE,SAVE ::   iiceSV  ! Nb of Ice      Layers           
-!$OMP THREADPRIVATE(iiceSV)
-      INTEGER ,ALLOCATABLE,SAVE              ::   istoSV(:,:)  ! Snow Layer     History          
-!$OMP THREADPRIVATE(istoSV)                                                                              
-      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   alb_SV  ! Surface Albedo           
-!$OMP THREADPRIVATE(alb_SV)
-      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   emi_SV  ! Surface Emissivity       
-!$OMP THREADPRIVATE(emi_SV)
-      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   IRs_SV  ! Soil           IR Flux          
-!$OMP THREADPRIVATE(IRs_SV)
-      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   LMO_SV  ! Monin-Obukhov  Scale            
-!$OMP THREADPRIVATE(LMO_SV)
-      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   us__SV  ! Friction       Velocity         
-!$OMP THREADPRIVATE(us__SV)
-      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   uts_SV  ! Temperature Turbulent Scale     
-!$OMP THREADPRIVATE(uts_SV)
-      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   cutsSV  ! Temperature Turbulent Scale C.  
-!$OMP THREADPRIVATE(cutsSV)
-      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   uqs_SV  ! Spec.Humid. Turbulent Scale     
-!$OMP THREADPRIVATE(uqs_SV)
-      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   uss_SV  ! Blow.Snow   Turbulent Scale     
-!$OMP THREADPRIVATE(uss_SV)
-      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   usthSV  ! Blowing Snow Erosion Thresh.    
-!$OMP THREADPRIVATE(usthSV)
-      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   rCDmSV  ! Square  Root Contribut. Drag_m  
-!$OMP THREADPRIVATE(rCDmSV)
-      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   rCDhSV  ! Square  Root Contribut. Drag_h  
-!$OMP THREADPRIVATE(rCDhSV)
-      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   Z0m_SV  ! Momentum     Roughness Length   
-!$OMP THREADPRIVATE(Z0m_SV)
-      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   Z0mmSV  !  z0(Momentum,    Time Mean) [m] 
-!$OMP THREADPRIVATE(Z0mmSV)
-      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   Z0mnSV  !  z0(Momentum,    instanta.) [m] 
-!$OMP THREADPRIVATE(Z0mnSV)
-      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   Z0roSV  ! Subgrid Topo Roughness Length   
-!$OMP THREADPRIVATE(Z0roSV)
-      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   Z0SaSV  !  z0(Sastrugi  h)            [m] 
-!$OMP THREADPRIVATE(Z0SaSV)
-      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   Z0e_SV  !  z0(Snow eroded)            [m] 
-!$OMP THREADPRIVATE(Z0e_SV)
-      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   Z0emSV  !  z0(Snow eroded, Time Mean) [m] 
-!$OMP THREADPRIVATE(Z0emSV)
-      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   Z0enSV  !  z0(Snow eroded, instanta.) [m] 
-!$OMP THREADPRIVATE(Z0enSV)
-      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   Z0h_SV  ! Heat         Roughness Length   
-!$OMP THREADPRIVATE(Z0h_SV)
-      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   Z0hmSV  !  z0(Heat,        Time Mean) [m] 
-!$OMP THREADPRIVATE(Z0hmSV)
-      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   Z0hnSV  !  z0(Heat,        instanta.) [m] 
-!$OMP THREADPRIVATE(Z0hnSV)
-                                                                         
-
-                                                                        
-      REAL ,ALLOCATABLE,SAVE   ::   TsisSV(:,:)  ! Snow/Ice/Soil-Water Temperature 
-!$OMP THREADPRIVATE(TsisSV)
-      REAL ,ALLOCATABLE,SAVE   ::   ro__SV(:,:)  ! Snow/Ice/Soil-Water VolumicMass 
-!$OMP THREADPRIVATE(ro__SV)
-      REAL,ALLOCATABLE,SAVE    ::   eta_SV(:,:)  ! Snow/Ice/Soil     Water Content 
-!$OMP THREADPRIVATE(eta_SV)
-      REAL,ALLOCATABLE,SAVE    ::   G1snSV(:,:)  ! Snow Dendricity/Sphericity      
-!$OMP THREADPRIVATE(G1snSV)
-      REAL,ALLOCATABLE,SAVE    ::   G2snSV(:,:)  ! Snow Sphericity/Size            
-!$OMP THREADPRIVATE(G2snSV)
-      REAL,ALLOCATABLE,SAVE    ::   dzsnSV(:,:)  ! Snow Layer  Thickness           
-!$OMP THREADPRIVATE(dzsnSV)
-      REAL,ALLOCATABLE,SAVE    ::   agsnSV(:,:)  ! Snow Age                        
-!$OMP THREADPRIVATE(agsnSV)
-      REAL,ALLOCATABLE,SAVE    ::   DOPsnSV(:,:)  ! Snow optical diameter [m]
-!$OMP THREADPRIVATE(DOPsnSV)
-      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   BufsSV  ! Snow Buffer Layer               
-!$OMP THREADPRIVATE(BufsSV)
-      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   rusnSV  ! Surficial   Water               
-!$OMP THREADPRIVATE(rusnSV)
-      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   SWf_SV  ! Normalized  Decay               
-!$OMP THREADPRIVATE(SWf_SV)
-      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   SWS_SV  ! Surficial Water Status          
-!$OMP THREADPRIVATE(SWS_SV)
-      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   HFraSV  ! Frazil      Thickness           
-!$OMP THREADPRIVATE(HFraSV)
-                                                                            
-      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   zWE_SV  ! Current   Snow Thickness [mmWE] 
-!$OMP THREADPRIVATE(zWE_SV)
-      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   zWEcSV  ! Compacted Snow Thickness [mmWE] 
-!$OMP THREADPRIVATE(zWEcSV)
-      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   wem_SV  ! Only Melting             [mmWE] 
-!$OMP THREADPRIVATE(wem_SV)
-      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   wer_SV  ! Refreezing               [mmWE] 
-!$OMP THREADPRIVATE(wer_SV)
-      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   wes_SV  ! Sublimation              [mmWE] 
-!$OMP THREADPRIVATE(wes_SV)
-      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   zn4_SV  ! snowheight change         [mm]
-!$OMP THREADPRIVATE(zn4_SV)
-      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   zn5_SV  ! snowheight change         [mm]
-!$OMP THREADPRIVATE(zn5_SV)                                                                            
-                                                                              
-! +--SISVAT OUTPUT       Variables                                            
-! +  -----------------------------                                            
-                                                                               
-      INTEGER,DIMENSION(nb_wri),SAVE ::   no__SV  ! OUTPUT file Unit Number         
-!$OMP THREADPRIVATE(no__SV)
-      INTEGER,DIMENSION(nb_wri),SAVE ::   i___SV  ! OUTPUT point   i Coordinate    
-!$OMP THREADPRIVATE(i___SV)
-      INTEGER,DIMENSION(nb_wri),SAVE ::   j___SV  ! OUTPUT point   j Coordinate     
-!$OMP THREADPRIVATE(j___SV)
-      INTEGER,DIMENSION(nb_wri),SAVE ::   n___SV  ! OUTPUT point   n Coordinate     
-!$OMP THREADPRIVATE(n___SV)
-      INTEGER,DIMENSION(nb_wri),SAVE ::   lwriSV  ! OUTPUT point vec Index          
-!$OMP THREADPRIVATE(lwriSV)
-!                                                                              
-      INTEGER, DIMENSION(:),ALLOCATABLE,SAVE ::   ii__SV  ! WORK   point   i Coordinate     
-!$OMP THREADPRIVATE(ii__SV)
-      INTEGER, DIMENSION(:),ALLOCATABLE,SAVE ::   jj__SV  ! WORK   point   j Coordinate     
-!$OMP THREADPRIVATE(jj__SV)
-      INTEGER, DIMENSION(:),ALLOCATABLE,SAVE ::   nn__SV  ! WORK   point   n Coordinate     
-!$OMP THREADPRIVATE(nn__SV)
-                                                                               
-      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   IRu_SV  ! UPward    IR Flux (effective)   
-!$OMP THREADPRIVATE(IRu_SV)
-      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   hSalSV  ! Saltating Layer Height          
-!$OMP THREADPRIVATE(hSalSV)
-      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   qSalSV  ! Saltating Snow  Concentration   
-!$OMP THREADPRIVATE(qSalSV)
-      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   RnofSV  ! RunOFF    Intensity             
-!$OMP THREADPRIVATE(RnofSV)
-      REAL, DIMENSION(:,:),ALLOCATABLE,SAVE    ::   RuofSV  ! RunOFF    Intensity             
-!$OMP THREADPRIVATE(RuofSV)
-
-
-
-                  
-CONTAINS
-
-
-
-  SUBROUTINE INIT_VARxSV
-  IMPLICIT NONE
-
-      INTEGER                                :: ikl
-
-      ALLOCATE(LSmask(klonv))  ! Land-Sea   Mask                 
-      ALLOCATE(isotSV(klonv))  ! Soil       Type                 
-      ALLOCATE(iWaFSV(klonv))  ! Soil       Drainage:(1,0)=(y,n)                                                                               
-      ALLOCATE(coszSV(klonv))  ! Cosine of Sun zenithal Angle    
-      ALLOCATE(sol_SV(klonv))  ! Downward  Solar    Radiation    
-      ALLOCATE(IRd_SV(klonv))  ! Downward  Longwave Radiation    
-                                                                                
-      ALLOCATE(drr_SV(klonv))  ! Rain  Intensity       [kg/m2/s] 
-      ALLOCATE(dsn_SV(klonv))  ! Snow  Intensity       [kg/m2/s] 
-      ALLOCATE(dsnbSV(klonv))  ! Idem, from Drift        [kg/m2] 
-      ALLOCATE(esnbSV(klonv))  ! Idem, from Drift        [kg/m2] 
-      ALLOCATE(dbs_SV(klonv))  ! Drift Amount            [kg/m2] 
-      ALLOCATE(dbs_er(klonv))  ! Drift erosion           [kg/m2] 
-      ALLOCATE(dbs_ac(klonv))  ! Drift accumulation      [kg/m2] 
-      ALLOCATE(BrosSV(klonv))
-      ALLOCATE(BG1sSV(klonv))          
-      ALLOCATE(BG2sSV(klonv))
-      ALLOCATE(dz0_SV(klonv))  ! dz0(Sastrugi dh)            [m] 
-                                                                               
-      ALLOCATE(cld_SV(klonv))  ! Cloudiness (seen from SBL)      
-      ALLOCATE(za__SV(klonv))  ! SBL Height                      
-      ALLOCATE(VV__SV(klonv))  !(SBL Top)  Wind Velocity         
-      ALLOCATE(VVs_SV(klonv))
-      ALLOCATE(RRs_SV(klonv))
-      ALLOCATE(DDs_SV(klonv))
-      ALLOCATE(TaT_SV(klonv))  ! SBL Top   Temperature           
-      ALLOCATE(ExnrSV(klonv))  ! Exner     Potential             
-      ALLOCATE(dSdTSV(klonv))  ! Sensible Heat Flux T Derivat.   
-      ALLOCATE(dLdTSV(klonv))  ! Latent   Heat Flux T Derivat.   
-      ALLOCATE(rhT_SV(klonv))  ! SBL Top   Air  Density          
-      ALLOCATE(QaT_SV(klonv))  ! SBL Top   Specific Humidity    
-      ALLOCATE(QsT_SV(klonv))  ! surface   Specific Humidity 
-      ALLOCATE(dQa_SV(klonv))  ! SBL Flux  Limitation of Qa      
-      ALLOCATE(qsnoSV(klonv))  ! SBL Mean  Snow       Content    
-                                                                               
-      ALLOCATE(alb0SV(klonv))  ! Soil    Albedo                  
-      ALLOCATE(slopSV(klonv))  ! Snow/Ice/Soil-Water Surf. Slope 
-
-                                                                               
-                                                                               
-! +--SISVAT INPUT/OUTPUT Variables                                             
-! +  -----------------------------                                             
-                                                                               
-      ALLOCATE(isnoSV(klonv))  ! Nb of Ice/Snow Layers           
-      ALLOCATE(ispiSV(klonv))  ! Uppermost superimposed ice      
-      ALLOCATE(iiceSV(klonv))  ! Nb of Ice      Layers           
-      ALLOCATE(istoSV(klonv,0:nsno))  ! Snow Layer     History          
-                                                                               
-      ALLOCATE(alb_SV(klonv))  ! Surface-Canopy Albedo           
-      ALLOCATE(emi_SV(klonv))  ! Surface-Canopy Emissivity       
-      ALLOCATE(IRs_SV(klonv))  ! Soil           IR Flux          
-      ALLOCATE(LMO_SV(klonv))  ! Monin-Obukhov  Scale            
-      ALLOCATE(us__SV(klonv))  ! Friction       Velocity         
-      ALLOCATE(uts_SV(klonv))  ! Temperature Turbulent Scale     
-      ALLOCATE(cutsSV(klonv))  ! Temperature Turbulent Scale C.  
-      ALLOCATE(uqs_SV(klonv))  ! Spec.Humid. Turbulent Scale     
-      ALLOCATE(uss_SV(klonv))  ! Blow.Snow   Turbulent Scale     
-      ALLOCATE(usthSV(klonv))  ! Blowing Snow Erosion Thresh.    
-      ALLOCATE(rCDmSV(klonv))  ! Square  Root Contribut. Drag_m  
-      ALLOCATE(rCDhSV(klonv))  ! Square  Root Contribut. Drag_h  
-      ALLOCATE(Z0m_SV(klonv))  ! Momentum     Roughness Length   
-      ALLOCATE(Z0mmSV(klonv))  !  z0(Momentum,    Time Mean) [m] 
-      ALLOCATE(Z0mnSV(klonv))  !  z0(Momentum,    instanta.) [m] 
-      ALLOCATE(Z0roSV(klonv))  ! Subgrid Topo Roughness Length   
-      ALLOCATE(Z0SaSV(klonv))  !  z0(Sastrugi  h)            [m] 
-      ALLOCATE(Z0e_SV(klonv))  !  z0(Snow eroded)            [m] 
-      ALLOCATE(Z0emSV(klonv))  !  z0(Snow eroded, Time Mean) [m] 
-      ALLOCATE(Z0enSV(klonv))  !  z0(Snow eroded, instanta.) [m] 
-      ALLOCATE(Z0h_SV(klonv))  !  Heat         Roughness Length   
-      ALLOCATE(Z0hmSV(klonv))  !  z0(Heat,        Time Mean) [m] 
-      ALLOCATE(Z0hnSV(klonv))  !  z0(Heat,        instanta.) [m] 
-                                                                          
-                                                                        
-      ALLOCATE(TsisSV(klonv,-nsol:nsno))  ! Snow/Ice/Soil-Water Temperature 
-      ALLOCATE(ro__SV(klonv,-nsol:nsno))  ! Snow/Ice/Soil-Water VolumicMass 
-      ALLOCATE(eta_SV(klonv,-nsol:nsno))  ! Snow/Ice/Soil     Water Content 
-      ALLOCATE(G1snSV(klonv,    0:nsno))  ! Snow Dendricity/Sphericity      
-      ALLOCATE(G2snSV(klonv,    0:nsno))  ! Snow Sphericity/Size            
-      ALLOCATE(dzsnSV(klonv,    0:nsno))  ! Snow Layer  Thickness           
-      ALLOCATE(agsnSV(klonv,    0:nsno))  ! Snow Age                        
-      ALLOCATE(DOPsnSV(klonv,    0:nsno))  ! Snow Optical diameter                        
-      ALLOCATE(BufsSV(klonv))  ! Snow Buffer Layer               
-      ALLOCATE(rusnSV(klonv))  ! Surficial   Water               
-      ALLOCATE(SWf_SV(klonv))  ! Normalized  Decay               
-      ALLOCATE(SWS_SV(klonv))  ! Surficial Water Status          
-      ALLOCATE(HFraSV(klonv))  ! Frazil      Thickness           
-                                                                            
-      ALLOCATE(zWE_SV(klonv))  ! Current   Snow Thickness [mmWE] 
-      ALLOCATE(zWEcSV(klonv))  ! Compacted Snow Thickness [mmWE] 
-      ALLOCATE(wem_SV(klonv)) ! Only Melting             [mmWE] 
-      ALLOCATE(wer_SV(klonv)) ! Refreezing               [mmWE] 
-      ALLOCATE(wes_SV(klonv))  ! Sublimation              [mmWE] 
-      ALLOCATE(zn4_SV(klonv))  ! snow height change       [mm] 
-      ALLOCATE(zn5_SV(klonv))  ! snow height change       [mm]                                                                             
-                                                                              
-! +--SISVAT OUTPUT       Variables                                            
-! +  -----------------------------                                            
-                                                                               
-!                                                                              
-      ALLOCATE(ii__SV(klonv))  ! WORK   point   i Coordinate     
-      ALLOCATE(jj__SV(klonv))  ! WORK   point   j Coordinate     
-      ALLOCATE(nn__SV(klonv))  ! WORK   point   n Coordinate     
-                                                                               
-      ALLOCATE(IRu_SV(klonv))  ! UPward    IR Flux (effective)   
-      ALLOCATE(hSalSV(klonv))  ! Saltating Layer Height          
-      ALLOCATE(qSalSV(klonv))  ! Saltating Snow  Concentration   
-      ALLOCATE(RnofSV(klonv))  ! RunOFF    Intensity      
-      ALLOCATE(RuofSV(klonv,4))  ! RunOFF    Intensity      
-
-
-      DO ikl=1,klonv        
-
-
-      isnoSV(ikl)  =0.        
-      ispiSV(ikl)  =0.   
-      iiceSV(ikl)  =0.        
-      istoSV(ikl,:)=0.                                                                        
-      alb_SV(ikl)  =0.      
-      emi_SV(ikl)  =0.    
-      IRs_SV(ikl)  =0.      
-      LMO_SV(ikl)  =0.
-      us__SV(ikl)  =0.
-      uts_SV(ikl)  =0.
-      cutsSV(ikl)  =0.
-      uqs_SV(ikl)  =0.
-      uss_SV(ikl)  =0.
-      usthSV(ikl)  =0.
-      rCDmSV(ikl)  =0.
-      rCDhSV(ikl)  =0.
-      Z0m_SV(ikl)  =0.
-      Z0mmSV(ikl)  =0.
-      Z0mnSV(ikl)  =0.
-      Z0roSV(ikl)  =0.
-      Z0SaSV(ikl)  =0.
-      Z0e_SV(ikl)  =0.
-      Z0emSV(ikl)  =0.
-      Z0enSV(ikl)  =0.
-      Z0h_SV(ikl)  =0.
-      Z0hmSV(ikl)  =0.
-      Z0hnSV(ikl)  =0.
-                                                                          
-                                                                        
-      TsisSV(ikl,:)  =0.
-      ro__SV(ikl,:)  =0.
-      eta_SV(ikl,:)  =0.
-      G1snSV(ikl,:)  =0.  
-      G2snSV(ikl,:)  =0.          
-      dzsnSV(ikl,:)  =0.      
-      agsnSV(ikl,:)  =0.              
-      DOPsnSV(ikl,:) =0.                  
-      BufsSV(ikl)  =0.         
-      rusnSV(ikl)  =0.     
-      SWf_SV(ikl)  =0.        
-      SWS_SV(ikl)  =0.
-      HFraSV(ikl)  =0.       
-                                                                            
-      zWE_SV(ikl)  =0.
-      zWEcSV(ikl)  =0.
-      wem_SV(ikl)  =0.
-      wer_SV(ikl)  =0.
-      wes_SV(ikl)  =0.
-      zn4_SV(ikl)  =0.
-      zn5_SV(ikl)  =0.                                                        
-                                       
-                                                                                                                                                          
-      ii__SV(ikl)  =0. 
-      jj__SV(ikl)  =0.
-      nn__SV(ikl)  =0.
-                                                                               
-      IRu_SV(ikl)  =0. 
-      hSalSV(ikl)  =0.     
-      qSalSV(ikl)  =0.
-      RnofSV(ikl)  =0.    
-      RuofSV(ikl,:)  =0.
-
-
-
-
-      END DO
-  END SUBROUTINE INIT_VARxSV
-
-
-                                               
-END MODULE VARxSV
Index: /LMDZ6/trunk/libf/phylmd/inlandsis/VARxSV.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/inlandsis/VARxSV.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/inlandsis/VARxSV.f90	(revision 5268)
@@ -0,0 +1,417 @@
+MODULE VARxSV                      
+
+USE VAR_SV, only : klonv, nsol, nsno, nb_wri
+                                                          
+IMPLICIT NONE                                                                                
+! +--SISVAT INPUT        Variables                                              
+! +  -----------------------------                                              
+  
+      INTEGER, DIMENSION(:),ALLOCATABLE,SAVE ::   LSmask  ! Land-Sea   Mask                 
+!$OMP THREADPRIVATE(LSmask)
+      INTEGER, DIMENSION(:),ALLOCATABLE,SAVE ::   isotSV  ! Soil       Type                 
+!$OMP THREADPRIVATE(isotSV)
+      INTEGER, DIMENSION(:),ALLOCATABLE,SAVE ::   iWaFSV  ! Soil       Drainage:(1,0)=(y,n) 
+!$OMP THREADPRIVATE(iWaFSV)                                                                              
+      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   coszSV  ! Cosine of Sun zenithal Angle    
+!$OMP THREADPRIVATE(coszSV)
+      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   sol_SV  ! Downward  Solar    Radiation    
+!$OMP THREADPRIVATE(sol_SV)
+      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   IRd_SV  ! Downward  Longwave Radiation    
+!$OMP THREADPRIVATE(IRd_SV)
+                                                                                
+      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   drr_SV  ! Rain  Intensity       [kg/m2/s] 
+!$OMP THREADPRIVATE(drr_SV)
+      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   dsn_SV  ! Snow  Intensity       [kg/m2/s] 
+!$OMP THREADPRIVATE(dsn_SV)
+      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   dsnbSV  ! Idem, fraction, from Drift  [-] 
+!$OMP THREADPRIVATE(dsnbSV)
+      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   esnbSV  ! Idem, fraction, from Drift  [-]
+!$OMP THREADPRIVATE(esnbSV)
+      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   dbs_SV  ! Drift Amount            [kg/m2] 
+!$OMP THREADPRIVATE(dbs_SV)
+      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   dbs_Er  ! BS Erosion              [kg/m2]
+!$OMP THREADPRIVATE(dbs_Er)
+      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   dbs_Ac  !  BS Accumulation         [kg/m2]
+!$OMP THREADPRIVATE(dbs_Ac)
+      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   BrosSV  ! Buffer Snow Layer Density
+!$OMP THREADPRIVATE(BrosSV)
+      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   BG1sSV  ! Buffer Snow Layer Dendr/Sphe[-]
+!$OMP THREADPRIVATE(BG1sSV)
+      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   BG2sSV  ! Buffer Snow Layer Spher/Size[-][0.0001m]
+!$OMP THREADPRIVATE(BG2sSV)
+      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   dz0_SV  ! dz0(Sastrugi dh)            [m] 
+!$OMP THREADPRIVATE(dz0_SV)
+                                                                               
+      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   cld_SV  ! Cloudiness (seen from SBL)      
+!$OMP THREADPRIVATE(cld_SV)
+      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   za__SV  ! SBL Height                      
+!$OMP THREADPRIVATE(za__SV)
+      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   VV__SV  !(SBL Top)  Wind Velocity         
+!$OMP THREADPRIVATE(VV__SV)
+      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   VVs_SV  !(Sastr,V)  Relevance
+!$OMP THREADPRIVATE(VVs_SV)
+      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   RRs_SV  !(Sastr,V)  Counter
+!$OMP THREADPRIVATE(RRs_SV)
+      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   DDs_SV  !(Sastr,V)  Angle
+!$OMP THREADPRIVATE(DDs_SV)
+      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   TaT_SV  ! SBL Top   Temperature           
+!$OMP THREADPRIVATE(TaT_SV)
+      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   ExnrSV  ! Exner     Potential             
+!$OMP THREADPRIVATE(ExnrSV)
+      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   dSdTSV  ! Sensible Heat Flux T Derivat.   
+!$OMP THREADPRIVATE(dSdTSV)
+      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   dLdTSV  ! Latent   Heat Flux T Derivat.   
+!$OMP THREADPRIVATE(dLdTSV)
+      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   rhT_SV  ! SBL Top   Air  Density          
+!$OMP THREADPRIVATE(rhT_SV)
+      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   QaT_SV  ! SBL Top   Specific Humidity     
+!$OMP THREADPRIVATE(QaT_SV)
+      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   QsT_SV  ! SBL Top   Specific Humidity
+!$OMP THREADPRIVATE(QsT_SV)
+      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   dQa_SV  ! SBL Flux  Limitation of Qa      
+!$OMP THREADPRIVATE(dQa_SV)
+      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   qsnoSV  ! SBL Mean  Snow       Content    
+!$OMP THREADPRIVATE(qsnoSV)                                                                   
+                                                                               
+      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   alb0SV  ! Soil    Albedo                  
+!$OMP THREADPRIVATE(alb0SV)
+      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   slopSV  ! Snow/Ice/Soil-Water Surf. Slope 
+!$OMP THREADPRIVATE(slopSV)
+
+                                                              
+      REAL,SAVE                      ::   dt__SV  ! Time Step                       
+!$OMP THREADPRIVATE(dt__SV)
+      CHARACTER (len=18),SAVE        ::   daHost  ! Date Host Model                 
+!$OMP THREADPRIVATE(daHost)
+                                                                               
+                                                                               
+! +--SISVAT INPUT/OUTPUT Variables                                             
+! +  -----------------------------                                             
+                                                                               
+      INTEGER, DIMENSION(:),ALLOCATABLE,SAVE ::   isnoSV  ! Nb of Ice/Snow Layers           
+!$OMP THREADPRIVATE(isnoSV)
+      INTEGER, DIMENSION(:),ALLOCATABLE,SAVE ::   ispiSV  ! Uppermost superimposed ice      
+!$OMP THREADPRIVATE(ispiSV)
+      INTEGER, DIMENSION(:),ALLOCATABLE,SAVE ::   iiceSV  ! Nb of Ice      Layers           
+!$OMP THREADPRIVATE(iiceSV)
+      INTEGER ,ALLOCATABLE,SAVE              ::   istoSV(:,:)  ! Snow Layer     History          
+!$OMP THREADPRIVATE(istoSV)                                                                              
+      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   alb_SV  ! Surface Albedo           
+!$OMP THREADPRIVATE(alb_SV)
+      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   emi_SV  ! Surface Emissivity       
+!$OMP THREADPRIVATE(emi_SV)
+      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   IRs_SV  ! Soil           IR Flux          
+!$OMP THREADPRIVATE(IRs_SV)
+      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   LMO_SV  ! Monin-Obukhov  Scale            
+!$OMP THREADPRIVATE(LMO_SV)
+      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   us__SV  ! Friction       Velocity         
+!$OMP THREADPRIVATE(us__SV)
+      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   uts_SV  ! Temperature Turbulent Scale     
+!$OMP THREADPRIVATE(uts_SV)
+      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   cutsSV  ! Temperature Turbulent Scale C.  
+!$OMP THREADPRIVATE(cutsSV)
+      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   uqs_SV  ! Spec.Humid. Turbulent Scale     
+!$OMP THREADPRIVATE(uqs_SV)
+      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   uss_SV  ! Blow.Snow   Turbulent Scale     
+!$OMP THREADPRIVATE(uss_SV)
+      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   usthSV  ! Blowing Snow Erosion Thresh.    
+!$OMP THREADPRIVATE(usthSV)
+      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   rCDmSV  ! Square  Root Contribut. Drag_m  
+!$OMP THREADPRIVATE(rCDmSV)
+      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   rCDhSV  ! Square  Root Contribut. Drag_h  
+!$OMP THREADPRIVATE(rCDhSV)
+      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   Z0m_SV  ! Momentum     Roughness Length   
+!$OMP THREADPRIVATE(Z0m_SV)
+      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   Z0mmSV  !  z0(Momentum,    Time Mean) [m] 
+!$OMP THREADPRIVATE(Z0mmSV)
+      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   Z0mnSV  !  z0(Momentum,    instanta.) [m] 
+!$OMP THREADPRIVATE(Z0mnSV)
+      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   Z0roSV  ! Subgrid Topo Roughness Length   
+!$OMP THREADPRIVATE(Z0roSV)
+      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   Z0SaSV  !  z0(Sastrugi  h)            [m] 
+!$OMP THREADPRIVATE(Z0SaSV)
+      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   Z0e_SV  !  z0(Snow eroded)            [m] 
+!$OMP THREADPRIVATE(Z0e_SV)
+      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   Z0emSV  !  z0(Snow eroded, Time Mean) [m] 
+!$OMP THREADPRIVATE(Z0emSV)
+      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   Z0enSV  !  z0(Snow eroded, instanta.) [m] 
+!$OMP THREADPRIVATE(Z0enSV)
+      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   Z0h_SV  ! Heat         Roughness Length   
+!$OMP THREADPRIVATE(Z0h_SV)
+      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   Z0hmSV  !  z0(Heat,        Time Mean) [m] 
+!$OMP THREADPRIVATE(Z0hmSV)
+      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   Z0hnSV  !  z0(Heat,        instanta.) [m] 
+!$OMP THREADPRIVATE(Z0hnSV)
+                                                                         
+
+                                                                        
+      REAL ,ALLOCATABLE,SAVE   ::   TsisSV(:,:)  ! Snow/Ice/Soil-Water Temperature 
+!$OMP THREADPRIVATE(TsisSV)
+      REAL ,ALLOCATABLE,SAVE   ::   ro__SV(:,:)  ! Snow/Ice/Soil-Water VolumicMass 
+!$OMP THREADPRIVATE(ro__SV)
+      REAL,ALLOCATABLE,SAVE    ::   eta_SV(:,:)  ! Snow/Ice/Soil     Water Content 
+!$OMP THREADPRIVATE(eta_SV)
+      REAL,ALLOCATABLE,SAVE    ::   G1snSV(:,:)  ! Snow Dendricity/Sphericity      
+!$OMP THREADPRIVATE(G1snSV)
+      REAL,ALLOCATABLE,SAVE    ::   G2snSV(:,:)  ! Snow Sphericity/Size            
+!$OMP THREADPRIVATE(G2snSV)
+      REAL,ALLOCATABLE,SAVE    ::   dzsnSV(:,:)  ! Snow Layer  Thickness           
+!$OMP THREADPRIVATE(dzsnSV)
+      REAL,ALLOCATABLE,SAVE    ::   agsnSV(:,:)  ! Snow Age                        
+!$OMP THREADPRIVATE(agsnSV)
+      REAL,ALLOCATABLE,SAVE    ::   DOPsnSV(:,:)  ! Snow optical diameter [m]
+!$OMP THREADPRIVATE(DOPsnSV)
+      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   BufsSV  ! Snow Buffer Layer               
+!$OMP THREADPRIVATE(BufsSV)
+      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   rusnSV  ! Surficial   Water               
+!$OMP THREADPRIVATE(rusnSV)
+      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   SWf_SV  ! Normalized  Decay               
+!$OMP THREADPRIVATE(SWf_SV)
+      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   SWS_SV  ! Surficial Water Status          
+!$OMP THREADPRIVATE(SWS_SV)
+      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   HFraSV  ! Frazil      Thickness           
+!$OMP THREADPRIVATE(HFraSV)
+                                                                            
+      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   zWE_SV  ! Current   Snow Thickness [mmWE] 
+!$OMP THREADPRIVATE(zWE_SV)
+      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   zWEcSV  ! Compacted Snow Thickness [mmWE] 
+!$OMP THREADPRIVATE(zWEcSV)
+      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   wem_SV  ! Only Melting             [mmWE] 
+!$OMP THREADPRIVATE(wem_SV)
+      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   wer_SV  ! Refreezing               [mmWE] 
+!$OMP THREADPRIVATE(wer_SV)
+      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   wes_SV  ! Sublimation              [mmWE] 
+!$OMP THREADPRIVATE(wes_SV)
+      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   zn4_SV  ! snowheight change         [mm]
+!$OMP THREADPRIVATE(zn4_SV)
+      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   zn5_SV  ! snowheight change         [mm]
+!$OMP THREADPRIVATE(zn5_SV)                                                                            
+                                                                              
+! +--SISVAT OUTPUT       Variables                                            
+! +  -----------------------------                                            
+                                                                               
+      INTEGER,DIMENSION(nb_wri),SAVE ::   no__SV  ! OUTPUT file Unit Number         
+!$OMP THREADPRIVATE(no__SV)
+      INTEGER,DIMENSION(nb_wri),SAVE ::   i___SV  ! OUTPUT point   i Coordinate    
+!$OMP THREADPRIVATE(i___SV)
+      INTEGER,DIMENSION(nb_wri),SAVE ::   j___SV  ! OUTPUT point   j Coordinate     
+!$OMP THREADPRIVATE(j___SV)
+      INTEGER,DIMENSION(nb_wri),SAVE ::   n___SV  ! OUTPUT point   n Coordinate     
+!$OMP THREADPRIVATE(n___SV)
+      INTEGER,DIMENSION(nb_wri),SAVE ::   lwriSV  ! OUTPUT point vec Index          
+!$OMP THREADPRIVATE(lwriSV)
+!                                                                              
+      INTEGER, DIMENSION(:),ALLOCATABLE,SAVE ::   ii__SV  ! WORK   point   i Coordinate     
+!$OMP THREADPRIVATE(ii__SV)
+      INTEGER, DIMENSION(:),ALLOCATABLE,SAVE ::   jj__SV  ! WORK   point   j Coordinate     
+!$OMP THREADPRIVATE(jj__SV)
+      INTEGER, DIMENSION(:),ALLOCATABLE,SAVE ::   nn__SV  ! WORK   point   n Coordinate     
+!$OMP THREADPRIVATE(nn__SV)
+                                                                               
+      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   IRu_SV  ! UPward    IR Flux (effective)   
+!$OMP THREADPRIVATE(IRu_SV)
+      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   hSalSV  ! Saltating Layer Height          
+!$OMP THREADPRIVATE(hSalSV)
+      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   qSalSV  ! Saltating Snow  Concentration   
+!$OMP THREADPRIVATE(qSalSV)
+      REAL, DIMENSION(:),ALLOCATABLE,SAVE    ::   RnofSV  ! RunOFF    Intensity             
+!$OMP THREADPRIVATE(RnofSV)
+      REAL, DIMENSION(:,:),ALLOCATABLE,SAVE    ::   RuofSV  ! RunOFF    Intensity             
+!$OMP THREADPRIVATE(RuofSV)
+
+
+
+                  
+CONTAINS
+
+
+
+  SUBROUTINE INIT_VARxSV
+  IMPLICIT NONE
+
+      INTEGER                                :: ikl
+
+      ALLOCATE(LSmask(klonv))  ! Land-Sea   Mask                 
+      ALLOCATE(isotSV(klonv))  ! Soil       Type                 
+      ALLOCATE(iWaFSV(klonv))  ! Soil       Drainage:(1,0)=(y,n)                                                                               
+      ALLOCATE(coszSV(klonv))  ! Cosine of Sun zenithal Angle    
+      ALLOCATE(sol_SV(klonv))  ! Downward  Solar    Radiation    
+      ALLOCATE(IRd_SV(klonv))  ! Downward  Longwave Radiation    
+                                                                                
+      ALLOCATE(drr_SV(klonv))  ! Rain  Intensity       [kg/m2/s] 
+      ALLOCATE(dsn_SV(klonv))  ! Snow  Intensity       [kg/m2/s] 
+      ALLOCATE(dsnbSV(klonv))  ! Idem, from Drift        [kg/m2] 
+      ALLOCATE(esnbSV(klonv))  ! Idem, from Drift        [kg/m2] 
+      ALLOCATE(dbs_SV(klonv))  ! Drift Amount            [kg/m2] 
+      ALLOCATE(dbs_er(klonv))  ! Drift erosion           [kg/m2] 
+      ALLOCATE(dbs_ac(klonv))  ! Drift accumulation      [kg/m2] 
+      ALLOCATE(BrosSV(klonv))
+      ALLOCATE(BG1sSV(klonv))          
+      ALLOCATE(BG2sSV(klonv))
+      ALLOCATE(dz0_SV(klonv))  ! dz0(Sastrugi dh)            [m] 
+                                                                               
+      ALLOCATE(cld_SV(klonv))  ! Cloudiness (seen from SBL)      
+      ALLOCATE(za__SV(klonv))  ! SBL Height                      
+      ALLOCATE(VV__SV(klonv))  !(SBL Top)  Wind Velocity         
+      ALLOCATE(VVs_SV(klonv))
+      ALLOCATE(RRs_SV(klonv))
+      ALLOCATE(DDs_SV(klonv))
+      ALLOCATE(TaT_SV(klonv))  ! SBL Top   Temperature           
+      ALLOCATE(ExnrSV(klonv))  ! Exner     Potential             
+      ALLOCATE(dSdTSV(klonv))  ! Sensible Heat Flux T Derivat.   
+      ALLOCATE(dLdTSV(klonv))  ! Latent   Heat Flux T Derivat.   
+      ALLOCATE(rhT_SV(klonv))  ! SBL Top   Air  Density          
+      ALLOCATE(QaT_SV(klonv))  ! SBL Top   Specific Humidity    
+      ALLOCATE(QsT_SV(klonv))  ! surface   Specific Humidity 
+      ALLOCATE(dQa_SV(klonv))  ! SBL Flux  Limitation of Qa      
+      ALLOCATE(qsnoSV(klonv))  ! SBL Mean  Snow       Content    
+                                                                               
+      ALLOCATE(alb0SV(klonv))  ! Soil    Albedo                  
+      ALLOCATE(slopSV(klonv))  ! Snow/Ice/Soil-Water Surf. Slope 
+
+                                                                               
+                                                                               
+! +--SISVAT INPUT/OUTPUT Variables                                             
+! +  -----------------------------                                             
+                                                                               
+      ALLOCATE(isnoSV(klonv))  ! Nb of Ice/Snow Layers           
+      ALLOCATE(ispiSV(klonv))  ! Uppermost superimposed ice      
+      ALLOCATE(iiceSV(klonv))  ! Nb of Ice      Layers           
+      ALLOCATE(istoSV(klonv,0:nsno))  ! Snow Layer     History          
+                                                                               
+      ALLOCATE(alb_SV(klonv))  ! Surface-Canopy Albedo           
+      ALLOCATE(emi_SV(klonv))  ! Surface-Canopy Emissivity       
+      ALLOCATE(IRs_SV(klonv))  ! Soil           IR Flux          
+      ALLOCATE(LMO_SV(klonv))  ! Monin-Obukhov  Scale            
+      ALLOCATE(us__SV(klonv))  ! Friction       Velocity         
+      ALLOCATE(uts_SV(klonv))  ! Temperature Turbulent Scale     
+      ALLOCATE(cutsSV(klonv))  ! Temperature Turbulent Scale C.  
+      ALLOCATE(uqs_SV(klonv))  ! Spec.Humid. Turbulent Scale     
+      ALLOCATE(uss_SV(klonv))  ! Blow.Snow   Turbulent Scale     
+      ALLOCATE(usthSV(klonv))  ! Blowing Snow Erosion Thresh.    
+      ALLOCATE(rCDmSV(klonv))  ! Square  Root Contribut. Drag_m  
+      ALLOCATE(rCDhSV(klonv))  ! Square  Root Contribut. Drag_h  
+      ALLOCATE(Z0m_SV(klonv))  ! Momentum     Roughness Length   
+      ALLOCATE(Z0mmSV(klonv))  !  z0(Momentum,    Time Mean) [m] 
+      ALLOCATE(Z0mnSV(klonv))  !  z0(Momentum,    instanta.) [m] 
+      ALLOCATE(Z0roSV(klonv))  ! Subgrid Topo Roughness Length   
+      ALLOCATE(Z0SaSV(klonv))  !  z0(Sastrugi  h)            [m] 
+      ALLOCATE(Z0e_SV(klonv))  !  z0(Snow eroded)            [m] 
+      ALLOCATE(Z0emSV(klonv))  !  z0(Snow eroded, Time Mean) [m] 
+      ALLOCATE(Z0enSV(klonv))  !  z0(Snow eroded, instanta.) [m] 
+      ALLOCATE(Z0h_SV(klonv))  !  Heat         Roughness Length   
+      ALLOCATE(Z0hmSV(klonv))  !  z0(Heat,        Time Mean) [m] 
+      ALLOCATE(Z0hnSV(klonv))  !  z0(Heat,        instanta.) [m] 
+                                                                          
+                                                                        
+      ALLOCATE(TsisSV(klonv,-nsol:nsno))  ! Snow/Ice/Soil-Water Temperature 
+      ALLOCATE(ro__SV(klonv,-nsol:nsno))  ! Snow/Ice/Soil-Water VolumicMass 
+      ALLOCATE(eta_SV(klonv,-nsol:nsno))  ! Snow/Ice/Soil     Water Content 
+      ALLOCATE(G1snSV(klonv,    0:nsno))  ! Snow Dendricity/Sphericity      
+      ALLOCATE(G2snSV(klonv,    0:nsno))  ! Snow Sphericity/Size            
+      ALLOCATE(dzsnSV(klonv,    0:nsno))  ! Snow Layer  Thickness           
+      ALLOCATE(agsnSV(klonv,    0:nsno))  ! Snow Age                        
+      ALLOCATE(DOPsnSV(klonv,    0:nsno))  ! Snow Optical diameter                        
+      ALLOCATE(BufsSV(klonv))  ! Snow Buffer Layer               
+      ALLOCATE(rusnSV(klonv))  ! Surficial   Water               
+      ALLOCATE(SWf_SV(klonv))  ! Normalized  Decay               
+      ALLOCATE(SWS_SV(klonv))  ! Surficial Water Status          
+      ALLOCATE(HFraSV(klonv))  ! Frazil      Thickness           
+                                                                            
+      ALLOCATE(zWE_SV(klonv))  ! Current   Snow Thickness [mmWE] 
+      ALLOCATE(zWEcSV(klonv))  ! Compacted Snow Thickness [mmWE] 
+      ALLOCATE(wem_SV(klonv)) ! Only Melting             [mmWE] 
+      ALLOCATE(wer_SV(klonv)) ! Refreezing               [mmWE] 
+      ALLOCATE(wes_SV(klonv))  ! Sublimation              [mmWE] 
+      ALLOCATE(zn4_SV(klonv))  ! snow height change       [mm] 
+      ALLOCATE(zn5_SV(klonv))  ! snow height change       [mm]                                                                             
+                                                                              
+! +--SISVAT OUTPUT       Variables                                            
+! +  -----------------------------                                            
+                                                                               
+!                                                                              
+      ALLOCATE(ii__SV(klonv))  ! WORK   point   i Coordinate     
+      ALLOCATE(jj__SV(klonv))  ! WORK   point   j Coordinate     
+      ALLOCATE(nn__SV(klonv))  ! WORK   point   n Coordinate     
+                                                                               
+      ALLOCATE(IRu_SV(klonv))  ! UPward    IR Flux (effective)   
+      ALLOCATE(hSalSV(klonv))  ! Saltating Layer Height          
+      ALLOCATE(qSalSV(klonv))  ! Saltating Snow  Concentration   
+      ALLOCATE(RnofSV(klonv))  ! RunOFF    Intensity      
+      ALLOCATE(RuofSV(klonv,4))  ! RunOFF    Intensity      
+
+
+      DO ikl=1,klonv        
+
+
+      isnoSV(ikl)  =0.        
+      ispiSV(ikl)  =0.   
+      iiceSV(ikl)  =0.        
+      istoSV(ikl,:)=0.                                                                        
+      alb_SV(ikl)  =0.      
+      emi_SV(ikl)  =0.    
+      IRs_SV(ikl)  =0.      
+      LMO_SV(ikl)  =0.
+      us__SV(ikl)  =0.
+      uts_SV(ikl)  =0.
+      cutsSV(ikl)  =0.
+      uqs_SV(ikl)  =0.
+      uss_SV(ikl)  =0.
+      usthSV(ikl)  =0.
+      rCDmSV(ikl)  =0.
+      rCDhSV(ikl)  =0.
+      Z0m_SV(ikl)  =0.
+      Z0mmSV(ikl)  =0.
+      Z0mnSV(ikl)  =0.
+      Z0roSV(ikl)  =0.
+      Z0SaSV(ikl)  =0.
+      Z0e_SV(ikl)  =0.
+      Z0emSV(ikl)  =0.
+      Z0enSV(ikl)  =0.
+      Z0h_SV(ikl)  =0.
+      Z0hmSV(ikl)  =0.
+      Z0hnSV(ikl)  =0.
+                                                                          
+                                                                        
+      TsisSV(ikl,:)  =0.
+      ro__SV(ikl,:)  =0.
+      eta_SV(ikl,:)  =0.
+      G1snSV(ikl,:)  =0.  
+      G2snSV(ikl,:)  =0.          
+      dzsnSV(ikl,:)  =0.      
+      agsnSV(ikl,:)  =0.              
+      DOPsnSV(ikl,:) =0.                  
+      BufsSV(ikl)  =0.         
+      rusnSV(ikl)  =0.     
+      SWf_SV(ikl)  =0.        
+      SWS_SV(ikl)  =0.
+      HFraSV(ikl)  =0.       
+                                                                            
+      zWE_SV(ikl)  =0.
+      zWEcSV(ikl)  =0.
+      wem_SV(ikl)  =0.
+      wer_SV(ikl)  =0.
+      wes_SV(ikl)  =0.
+      zn4_SV(ikl)  =0.
+      zn5_SV(ikl)  =0.                                                        
+                                       
+                                                                                                                                                          
+      ii__SV(ikl)  =0. 
+      jj__SV(ikl)  =0.
+      nn__SV(ikl)  =0.
+                                                                               
+      IRu_SV(ikl)  =0. 
+      hSalSV(ikl)  =0.     
+      qSalSV(ikl)  =0.
+      RnofSV(ikl)  =0.    
+      RuofSV(ikl,:)  =0.
+
+
+
+
+      END DO
+  END SUBROUTINE INIT_VARxSV
+
+
+                                               
+END MODULE VARxSV
Index: DZ6/trunk/libf/phylmd/inlandsis/VARySV.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/inlandsis/VARySV.F90	(revision 5267)
+++ 	(revision )
@@ -1,153 +1,0 @@
-MODULE VARySV
-
-USE VAR_SV, only : klonv, nsol, nsno
-
-
-IMPLICIT NONE
-
-! +
-      INTEGER, DIMENSION(:),SAVE,ALLOCATABLE ::   NLaysv  ! New   Snow     Layer   Switch   
-!$OMP THREADPRIVATE(NLaysv)
-      INTEGER, DIMENSION(:),SAVE,ALLOCATABLE ::   i_thin  ! Index of the thinest Layer      
-!$OMP THREADPRIVATE(i_thin)
-      INTEGER, DIMENSION(:),SAVE,ALLOCATABLE ::   LIndsv  ! Contiguous Layer relative Index
-!$OMP THREADPRIVATE(LIndsv)
-      REAL, DIMENSION(:),SAVE,ALLOCATABLE    ::   albisv  ! Integrated Surface Albedo
-!$OMP THREADPRIVATE(albisv)
-      !hj prelim                                            
-      REAL, DIMENSION(:),SAVE,ALLOCATABLE    ::   alb1sv  ! Surface Albedo VIS      
-!$OMP THREADPRIVATE(alb1sv)
-      REAL, DIMENSION(:),SAVE,ALLOCATABLE    ::   alb2sv  ! Surface Albedo NIR      
-!$OMP THREADPRIVATE(alb2sv)
-      REAL, DIMENSION(:),SAVE,ALLOCATABLE    ::   alb3sv  ! Surface Albedo FIR      
-!$OMP THREADPRIVATE(alb3sv)
-      REAL, DIMENSION(:,:),SAVE,ALLOCATABLE  ::   alb6sv  ! 6 band-albedo    
-!$OMP THREADPRIVATE(alb6sv)
-      REAL, DIMENSION(:),SAVE,ALLOCATABLE    ::   albssv  ! Soil               Albedo [-]   
-!$OMP THREADPRIVATE(albssv)
-      REAL, DIMENSION(:),SAVE,ALLOCATABLE    ::   SoSosv  !? Surface Absorbed Solar Radiat.  
-!$OMP THREADPRIVATE(SoSosv)
-      REAL, DIMENSION(:),SAVE,ALLOCATABLE    ::   Eso_sv  !? Emissivity of       Soil+Snow   
-!$OMP THREADPRIVATE(Eso_sv)
-      REAL, DIMENSION(:),SAVE,ALLOCATABLE    ::   HSv_sv  ! Sensible Heat Flux  [W/m2]      
-!$OMP THREADPRIVATE(HSv_sv)
-      REAL, DIMENSION(:),SAVE,ALLOCATABLE    ::   HLv_sv  ! Latent   Heat Flux  [W/m2]      
-!$OMP THREADPRIVATE(HLv_sv)
-      REAL, DIMENSION(:),SAVE,ALLOCATABLE    ::   HSs_sv  !? Sensible Heat Flux (t)          
-!$OMP THREADPRIVATE(HSs_sv)
-      REAL, DIMENSION(:),SAVE,ALLOCATABLE    ::   HLs_sv  !? Latent   Heat Flux (t)          
-!$OMP THREADPRIVATE(HLs_sv) 
-      REAL, DIMENSION(:),SAVE,ALLOCATABLE    ::   sqrCm0  ! in Neutral Drag Coef.Moment.    
-!$OMP THREADPRIVATE(sqrCm0)
-      REAL, DIMENSION(:),SAVE,ALLOCATABLE    ::   sqrCh0  ! in Neutral Drag Coef.Heat       
-!$OMP THREADPRIVATE(sqrCh0)
-      REAL, DIMENSION(:),SAVE,ALLOCATABLE    ::   Lx_H2O  ! Latent Heat of Vaporiz./Sublim. 
-!$OMP THREADPRIVATE(Lx_H2O)
-      REAL, DIMENSION(:),SAVE,ALLOCATABLE    ::   ram_sv  ! Aerodyn.Resistance (Moment.)    
-!$OMP THREADPRIVATE(ram_sv)
-      REAL, DIMENSION(:),SAVE,ALLOCATABLE    ::   rah_sv  ! Aerodyn.Resistance (Heat)       
-!$OMP THREADPRIVATE(rah_sv)
-      REAL, DIMENSION(:),SAVE,ALLOCATABLE    ::   Fh__sv  ! Stability Function              
-!$OMP THREADPRIVATE(Fh__sv)
-      REAL, DIMENSION(:),SAVE,ALLOCATABLE    ::   dFh_sv  ! Stability Function (Deriv.)     
-!$OMP THREADPRIVATE(dFh_sv)
-      REAL, DIMENSION(:),SAVE,ALLOCATABLE    ::   Evp_sv  !x Evaporation        [kg/m2]      
-!$OMP THREADPRIVATE(Evp_sv)
-      REAL, DIMENSION(:),SAVE,ALLOCATABLE    ::   EvT_sv  !x Evapotranspiration [kg/m2]      
-!$OMP THREADPRIVATE(EvT_sv)
-      REAL, DIMENSION(:),SAVE,ALLOCATABLE    ::   LSdzsv  ! Land/Sea Vert. Discretiz. Fact. 
-!$OMP THREADPRIVATE(LSdzsv)
-      REAL, DIMENSION(:),SAVE,ALLOCATABLE    ::   Tsrfsv  ! Surface    Temperature          
-!$OMP THREADPRIVATE(Tsrfsv)
-      REAL,SAVE,ALLOCATABLE  ::   sEX_sv(:,:)  ! Verticaly Integr.Extinct.Coef.  
-!$OMP THREADPRIVATE(sEX_sv)
-      REAL,SAVE,ALLOCATABLE  ::   zzsnsv(:,:)    ! Snow  Pack Thickness      [m]   
-!$OMP THREADPRIVATE(zzsnsv)
-      REAL,SAVE,ALLOCATABLE  ::   psi_sv(:,:)    ! Soil   Water        Potential   
-!$OMP THREADPRIVATE(psi_sv)
-      REAL,SAVE,ALLOCATABLE  ::   Khydsv(:,:)    ! Soil   Hydraulic    Conductiv.  
-!$OMP THREADPRIVATE(Khydsv)
-      REAL, DIMENSION(:),SAVE,ALLOCATABLE    ::   EExcsv  ! Energy in Excess, current       
-!$OMP THREADPRIVATE(EExcsv)
-
-CONTAINS
-  SUBROUTINE INIT_VARySV
-  IMPLICIT NONE
-      INTEGER                ::   ikl
-
-      ALLOCATE(NLaysv(klonv))  ! New   Snow     Layer   Switch   
-      ALLOCATE(i_thin(klonv))  ! Index of the thinest Layer      
-      ALLOCATE(LIndsv(klonv))  ! Contiguous Layer relative Index
-      ALLOCATE(albisv(klonv))  ! Integrated Surface Albedo
-      !hj prelim                                            
-      ALLOCATE(alb1sv(klonv))  ! Surface Albedo VIS      
-      ALLOCATE(alb2sv(klonv))  ! Surface Albedo NIR      
-      ALLOCATE(alb3sv(klonv))  ! Surface Albedo FIR       
-      ALLOCATE(alb6sv(klonv,6))! 6-band  Albedo      
-
-      !
-      ALLOCATE(albssv(klonv))  ! Soil               Albedo [-]   
-      ALLOCATE(SoSosv(klonv))  !? Surface Absorbed Solar Radiat.  
-      ALLOCATE(Eso_sv(klonv))  !? Emissivity of       Soil+Snow   
-      ALLOCATE(HSv_sv(klonv))  ! Sensible Heat Flux  [W/m2]      
-      ALLOCATE(HLv_sv(klonv))  ! Latent   Heat Flux  [W/m2]      
-      ALLOCATE(HSs_sv(klonv))  !? Sensible Heat Flux (t)          
-      ALLOCATE(HLs_sv(klonv))  !? Latent   Heat Flux (t)     
-      ALLOCATE(sqrCm0(klonv))  ! in Neutral Drag Coef.Moment.    
-      ALLOCATE(sqrCh0(klonv))  ! in Neutral Drag Coef.Heat       
-      ALLOCATE(Lx_H2O(klonv))  ! Latent Heat of Vaporiz./Sublim. 
-      ALLOCATE(ram_sv(klonv))  ! Aerodyn.Resistance (Moment.)    
-      ALLOCATE(rah_sv(klonv))  ! Aerodyn.Resistance (Heat)       
-      ALLOCATE(Fh__sv(klonv))  ! Stability Function              
-      ALLOCATE(dFh_sv(klonv))  ! Stability Function (Deriv.)     
-      ALLOCATE(Evp_sv(klonv))  !x Evaporation        [kg/m2]      
-      ALLOCATE(EvT_sv(klonv))  !x Evapotranspiration [kg/m2]      
-      ALLOCATE(LSdzsv(klonv))  ! Land/Sea Vert. Discretiz. Fact. 
-      ALLOCATE(Tsrfsv(klonv))  ! Surface    Temperature          
-      ALLOCATE(sEX_sv(klonv,-nsol:nsno+1))  ! Verticaly Integr.Extinct.Coef.  
-      ALLOCATE(zzsnsv(klonv,    0:nsno))    ! Snow  Pack Thickness      [m]   
-      ALLOCATE(psi_sv(klonv,-nsol:0   ))    ! Soil   Water        Potential   
-      ALLOCATE(Khydsv(klonv,-nsol:0   ))    ! Soil   Hydraulic    Conductiv.  
-      ALLOCATE(EExcsv(klonv))  ! Energy in Excess, current         
-
-      DO ikl=1,klonv
-
-      NLaysv(ikl) =0.
-      i_thin(ikl) =0.
-      LIndsv(ikl) =0.
-      albisv(ikl) =0.
-      alb1sv(ikl) =0. 
-      alb2sv(ikl) =0.   
-      alb3sv(ikl) =0.
-      alb6sv(ikl,:)=0.
-      albssv(ikl) =0.
-      SoSosv(ikl) =0.
-      Eso_sv(ikl) =0.
-      HSv_sv(ikl) =0.   
-      HLv_sv(ikl) =0.
-      HSs_sv(ikl) =0.       
-      HLs_sv(ikl) =0.
-      sqrCm0(ikl) =0.   
-      sqrCh0(ikl) =0.    
-      Lx_H2O(ikl) =0.
-      ram_sv(ikl) =0.
-      rah_sv(ikl) =0.
-      Fh__sv(ikl) =0.      
-      dFh_sv(ikl) =0.
-      Evp_sv(ikl) =0.
-      EvT_sv(ikl) =0.
-      LSdzsv(ikl) =0.
-      Tsrfsv(ikl) =0.
-      sEX_sv(ikl,:)  =0.
-      zzsnsv(ikl,:)  =0.
-      psi_sv(ikl,:)  =0. 
-      Khydsv(ikl,:)  =0. 
-      EExcsv(ikl)  =0.    
-
-
-      END DO
-
-  END SUBROUTINE INIT_VARySV
-
-END MODULE VARySV
-
Index: /LMDZ6/trunk/libf/phylmd/inlandsis/VARySV.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/inlandsis/VARySV.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/inlandsis/VARySV.f90	(revision 5268)
@@ -0,0 +1,153 @@
+MODULE VARySV
+
+USE VAR_SV, only : klonv, nsol, nsno
+
+
+IMPLICIT NONE
+
+! +
+      INTEGER, DIMENSION(:),SAVE,ALLOCATABLE ::   NLaysv  ! New   Snow     Layer   Switch   
+!$OMP THREADPRIVATE(NLaysv)
+      INTEGER, DIMENSION(:),SAVE,ALLOCATABLE ::   i_thin  ! Index of the thinest Layer      
+!$OMP THREADPRIVATE(i_thin)
+      INTEGER, DIMENSION(:),SAVE,ALLOCATABLE ::   LIndsv  ! Contiguous Layer relative Index
+!$OMP THREADPRIVATE(LIndsv)
+      REAL, DIMENSION(:),SAVE,ALLOCATABLE    ::   albisv  ! Integrated Surface Albedo
+!$OMP THREADPRIVATE(albisv)
+      !hj prelim                                            
+      REAL, DIMENSION(:),SAVE,ALLOCATABLE    ::   alb1sv  ! Surface Albedo VIS      
+!$OMP THREADPRIVATE(alb1sv)
+      REAL, DIMENSION(:),SAVE,ALLOCATABLE    ::   alb2sv  ! Surface Albedo NIR      
+!$OMP THREADPRIVATE(alb2sv)
+      REAL, DIMENSION(:),SAVE,ALLOCATABLE    ::   alb3sv  ! Surface Albedo FIR      
+!$OMP THREADPRIVATE(alb3sv)
+      REAL, DIMENSION(:,:),SAVE,ALLOCATABLE  ::   alb6sv  ! 6 band-albedo    
+!$OMP THREADPRIVATE(alb6sv)
+      REAL, DIMENSION(:),SAVE,ALLOCATABLE    ::   albssv  ! Soil               Albedo [-]   
+!$OMP THREADPRIVATE(albssv)
+      REAL, DIMENSION(:),SAVE,ALLOCATABLE    ::   SoSosv  !? Surface Absorbed Solar Radiat.  
+!$OMP THREADPRIVATE(SoSosv)
+      REAL, DIMENSION(:),SAVE,ALLOCATABLE    ::   Eso_sv  !? Emissivity of       Soil+Snow   
+!$OMP THREADPRIVATE(Eso_sv)
+      REAL, DIMENSION(:),SAVE,ALLOCATABLE    ::   HSv_sv  ! Sensible Heat Flux  [W/m2]      
+!$OMP THREADPRIVATE(HSv_sv)
+      REAL, DIMENSION(:),SAVE,ALLOCATABLE    ::   HLv_sv  ! Latent   Heat Flux  [W/m2]      
+!$OMP THREADPRIVATE(HLv_sv)
+      REAL, DIMENSION(:),SAVE,ALLOCATABLE    ::   HSs_sv  !? Sensible Heat Flux (t)          
+!$OMP THREADPRIVATE(HSs_sv)
+      REAL, DIMENSION(:),SAVE,ALLOCATABLE    ::   HLs_sv  !? Latent   Heat Flux (t)          
+!$OMP THREADPRIVATE(HLs_sv) 
+      REAL, DIMENSION(:),SAVE,ALLOCATABLE    ::   sqrCm0  ! in Neutral Drag Coef.Moment.    
+!$OMP THREADPRIVATE(sqrCm0)
+      REAL, DIMENSION(:),SAVE,ALLOCATABLE    ::   sqrCh0  ! in Neutral Drag Coef.Heat       
+!$OMP THREADPRIVATE(sqrCh0)
+      REAL, DIMENSION(:),SAVE,ALLOCATABLE    ::   Lx_H2O  ! Latent Heat of Vaporiz./Sublim. 
+!$OMP THREADPRIVATE(Lx_H2O)
+      REAL, DIMENSION(:),SAVE,ALLOCATABLE    ::   ram_sv  ! Aerodyn.Resistance (Moment.)    
+!$OMP THREADPRIVATE(ram_sv)
+      REAL, DIMENSION(:),SAVE,ALLOCATABLE    ::   rah_sv  ! Aerodyn.Resistance (Heat)       
+!$OMP THREADPRIVATE(rah_sv)
+      REAL, DIMENSION(:),SAVE,ALLOCATABLE    ::   Fh__sv  ! Stability Function              
+!$OMP THREADPRIVATE(Fh__sv)
+      REAL, DIMENSION(:),SAVE,ALLOCATABLE    ::   dFh_sv  ! Stability Function (Deriv.)     
+!$OMP THREADPRIVATE(dFh_sv)
+      REAL, DIMENSION(:),SAVE,ALLOCATABLE    ::   Evp_sv  !x Evaporation        [kg/m2]      
+!$OMP THREADPRIVATE(Evp_sv)
+      REAL, DIMENSION(:),SAVE,ALLOCATABLE    ::   EvT_sv  !x Evapotranspiration [kg/m2]      
+!$OMP THREADPRIVATE(EvT_sv)
+      REAL, DIMENSION(:),SAVE,ALLOCATABLE    ::   LSdzsv  ! Land/Sea Vert. Discretiz. Fact. 
+!$OMP THREADPRIVATE(LSdzsv)
+      REAL, DIMENSION(:),SAVE,ALLOCATABLE    ::   Tsrfsv  ! Surface    Temperature          
+!$OMP THREADPRIVATE(Tsrfsv)
+      REAL,SAVE,ALLOCATABLE  ::   sEX_sv(:,:)  ! Verticaly Integr.Extinct.Coef.  
+!$OMP THREADPRIVATE(sEX_sv)
+      REAL,SAVE,ALLOCATABLE  ::   zzsnsv(:,:)    ! Snow  Pack Thickness      [m]   
+!$OMP THREADPRIVATE(zzsnsv)
+      REAL,SAVE,ALLOCATABLE  ::   psi_sv(:,:)    ! Soil   Water        Potential   
+!$OMP THREADPRIVATE(psi_sv)
+      REAL,SAVE,ALLOCATABLE  ::   Khydsv(:,:)    ! Soil   Hydraulic    Conductiv.  
+!$OMP THREADPRIVATE(Khydsv)
+      REAL, DIMENSION(:),SAVE,ALLOCATABLE    ::   EExcsv  ! Energy in Excess, current       
+!$OMP THREADPRIVATE(EExcsv)
+
+CONTAINS
+  SUBROUTINE INIT_VARySV
+  IMPLICIT NONE
+      INTEGER                ::   ikl
+
+      ALLOCATE(NLaysv(klonv))  ! New   Snow     Layer   Switch   
+      ALLOCATE(i_thin(klonv))  ! Index of the thinest Layer      
+      ALLOCATE(LIndsv(klonv))  ! Contiguous Layer relative Index
+      ALLOCATE(albisv(klonv))  ! Integrated Surface Albedo
+      !hj prelim                                            
+      ALLOCATE(alb1sv(klonv))  ! Surface Albedo VIS      
+      ALLOCATE(alb2sv(klonv))  ! Surface Albedo NIR      
+      ALLOCATE(alb3sv(klonv))  ! Surface Albedo FIR       
+      ALLOCATE(alb6sv(klonv,6))! 6-band  Albedo      
+
+      !
+      ALLOCATE(albssv(klonv))  ! Soil               Albedo [-]   
+      ALLOCATE(SoSosv(klonv))  !? Surface Absorbed Solar Radiat.  
+      ALLOCATE(Eso_sv(klonv))  !? Emissivity of       Soil+Snow   
+      ALLOCATE(HSv_sv(klonv))  ! Sensible Heat Flux  [W/m2]      
+      ALLOCATE(HLv_sv(klonv))  ! Latent   Heat Flux  [W/m2]      
+      ALLOCATE(HSs_sv(klonv))  !? Sensible Heat Flux (t)          
+      ALLOCATE(HLs_sv(klonv))  !? Latent   Heat Flux (t)     
+      ALLOCATE(sqrCm0(klonv))  ! in Neutral Drag Coef.Moment.    
+      ALLOCATE(sqrCh0(klonv))  ! in Neutral Drag Coef.Heat       
+      ALLOCATE(Lx_H2O(klonv))  ! Latent Heat of Vaporiz./Sublim. 
+      ALLOCATE(ram_sv(klonv))  ! Aerodyn.Resistance (Moment.)    
+      ALLOCATE(rah_sv(klonv))  ! Aerodyn.Resistance (Heat)       
+      ALLOCATE(Fh__sv(klonv))  ! Stability Function              
+      ALLOCATE(dFh_sv(klonv))  ! Stability Function (Deriv.)     
+      ALLOCATE(Evp_sv(klonv))  !x Evaporation        [kg/m2]      
+      ALLOCATE(EvT_sv(klonv))  !x Evapotranspiration [kg/m2]      
+      ALLOCATE(LSdzsv(klonv))  ! Land/Sea Vert. Discretiz. Fact. 
+      ALLOCATE(Tsrfsv(klonv))  ! Surface    Temperature          
+      ALLOCATE(sEX_sv(klonv,-nsol:nsno+1))  ! Verticaly Integr.Extinct.Coef.  
+      ALLOCATE(zzsnsv(klonv,    0:nsno))    ! Snow  Pack Thickness      [m]   
+      ALLOCATE(psi_sv(klonv,-nsol:0   ))    ! Soil   Water        Potential   
+      ALLOCATE(Khydsv(klonv,-nsol:0   ))    ! Soil   Hydraulic    Conductiv.  
+      ALLOCATE(EExcsv(klonv))  ! Energy in Excess, current         
+
+      DO ikl=1,klonv
+
+      NLaysv(ikl) =0.
+      i_thin(ikl) =0.
+      LIndsv(ikl) =0.
+      albisv(ikl) =0.
+      alb1sv(ikl) =0. 
+      alb2sv(ikl) =0.   
+      alb3sv(ikl) =0.
+      alb6sv(ikl,:)=0.
+      albssv(ikl) =0.
+      SoSosv(ikl) =0.
+      Eso_sv(ikl) =0.
+      HSv_sv(ikl) =0.   
+      HLv_sv(ikl) =0.
+      HSs_sv(ikl) =0.       
+      HLs_sv(ikl) =0.
+      sqrCm0(ikl) =0.   
+      sqrCh0(ikl) =0.    
+      Lx_H2O(ikl) =0.
+      ram_sv(ikl) =0.
+      rah_sv(ikl) =0.
+      Fh__sv(ikl) =0.      
+      dFh_sv(ikl) =0.
+      Evp_sv(ikl) =0.
+      EvT_sv(ikl) =0.
+      LSdzsv(ikl) =0.
+      Tsrfsv(ikl) =0.
+      sEX_sv(ikl,:)  =0.
+      zzsnsv(ikl,:)  =0.
+      psi_sv(ikl,:)  =0. 
+      Khydsv(ikl,:)  =0. 
+      EExcsv(ikl)  =0.    
+
+
+      END DO
+
+  END SUBROUTINE INIT_VARySV
+
+END MODULE VARySV
+
Index: DZ6/trunk/libf/phylmd/inlandsis/surf_inlandsis_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/inlandsis/surf_inlandsis_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,1495 +1,0 @@
-MODULE surf_inlandsis_mod
-
-    IMPLICIT NONE
-
-CONTAINS
-
-
-SUBROUTINE surf_inlandsis(knon, rlon, rlat, ikl2i, itime, dtime, debut, lafin, &
-            rmu0, swdown, lwdown, albedo_old, pexner, ps, p1lay, &
-            precip_rain, precip_snow, &
-            zsl_height, wind_velo, ustar, temp_air, dens_air, spechum, tsurf, &
-            rugos, snow_cont_air, alb_soil, alt, slope, cloudf, &
-            radsol, qsol, tsoil, snow, zfra, snowhgt, qsnow, to_ice, sissnow, agesno, &
-            AcoefH, AcoefQ, BcoefH, BcoefQ, cdragm, cdragh, &
-            runoff_lic, fqfonte, ffonte, evap, erod, fluxsens, fluxlat, dflux_s,dflux_l, &
-            tsurf_new, alb1, alb2, alb3, alb6, emis_new, z0m, z0h, qsurf)
-
-        ! |                                                                        |
-        ! |   SubRoutine surf_inlandsis: Interfacing Lmdz AND Sisvat's Ice and Snow|
-        ! |                              (INLANDSIS)                               |
-        ! |   SISVAT (Soil/Ice Snow Vegetation Atmosphere Transfer Scheme)         |
-        ! |   surface scheme of the Modele Atmospherique Regional (MAR)            |
-        ! |   Author: Heinz Juergen Punge, LSCE                June 2009           |
-        ! |     based on the MAR-SISVAT interface by Hubert Gallee                 |
-        ! |   Updated by Etienne Vignon, Cecile Agosta                             |
-        ! |                                                                        |
-        ! +------------------------------------------------------------------------+
-        ! |
-        ! |   In the current setup, SISVAT is used only to model the land ice      |
-        ! |   part of the surface; hence it is called with the compressed variables|
-        ! |   from pbl_surface, and only by the surf_landice routine.              |
-        ! |                                                                        |
-        ! |   In this interface it is assumed that the partitioning of the soil,   |
-        ! |   and hence the number of grid points is constant during a simulation, |
-        ! |   hence eg. snow properties remain stored in the global SISVAT         |
-        ! |   variables between the calls and don't need to be handed over as      |
-        ! |   arguments. When the partitioning is supposed to change, make sure to |
-        ! |   update the variables.                                                |
-        ! |                                                                        |
-        ! |   INPUT    (via MODULES VARxSV, VARySV, VARtSV ...)                    |
-        ! |   ^^^^^     xxxxSV: SISVAT/LMDZ interfacing variables                  |
-        ! |                                                                        |
-        ! +------------------------------------------------------------------------+
-
-        USE dimphy
-        USE VAR_SV
-        USE VARdSV
-        USE VARxSV
-        USE VARySV
-        USE VARtSV
-        USE VARphy
-        USE surface_data, only : iflag_tsurf_inlandsis, SnoMod, BloMod, ok_outfor
-
-        IMPLICIT NONE
-
-        ! +--INTERFACE Variables
-        ! +  ===================
-        !    include  "dimsoil.h"
-
-        ! +--Global Variables
-        ! +  ================
-        ! Input Variables for SISVAT
-        INTEGER, INTENT(IN) :: knon
-        INTEGER, INTENT(IN) :: itime
-        REAL, INTENT(IN) :: dtime
-        LOGICAL, INTENT(IN) :: debut     ! true if first step
-        LOGICAL, INTENT(IN) :: lafin     ! true if last step
-
-        INTEGER, DIMENSION(klon), INTENT(IN) :: ikl2i     ! Index Decompression
-        REAL, DIMENSION(klon), INTENT(IN) :: rlon, rlat
-        REAL, DIMENSION(klon), INTENT(IN) :: rmu0      ! cos sol. zenith angle
-        REAL, DIMENSION(klon), INTENT(IN) :: swdown    !
-        REAL, DIMENSION(klon), INTENT(IN) :: lwdown    !
-        REAL, DIMENSION(klon), INTENT(IN) :: albedo_old
-        REAL, DIMENSION(klon), INTENT(IN) :: pexner    ! Exner potential
-        REAL, DIMENSION(klon), INTENT(IN) :: precip_rain, precip_snow
-        REAL, DIMENSION(klon), INTENT(IN) :: zsl_height, wind_velo
-        REAL, DIMENSION(klon), INTENT(IN) :: temp_air, spechum, ps, p1lay
-        REAL, DIMENSION(klon), INTENT(IN) :: dens_air, tsurf
-        REAL, DIMENSION(klon), INTENT(IN) :: rugos
-        REAL, DIMENSION(klon), INTENT(IN) :: snow_cont_air
-        REAL, DIMENSION(klon), INTENT(IN) :: alb_soil, slope
-        REAL, DIMENSION(klon), INTENT(IN) :: alt       ! surface elevation
-        REAL, DIMENSION(klon), INTENT(IN) :: cloudf
-        REAL, DIMENSION(klon), INTENT(IN) :: AcoefH, AcoefQ
-        REAL, DIMENSION(klon), INTENT(IN) :: BcoefH, BcoefQ
-        REAL, DIMENSION(klon), INTENT(IN) :: cdragm, cdragh
-        REAL, DIMENSION(klon), INTENT(IN) :: ustar   ! friction velocity
-
-        ! Variables exchanged between LMDZ and SISVAT
-        REAL, DIMENSION(klon), INTENT(IN) :: radsol    ! Surface absorbed rad.
-        REAL, DIMENSION(klon), INTENT(INOUT) :: snow      ! Tot snow mass [kg/m2]
-        REAL, DIMENSION(klon), INTENT(INOUT) :: zfra      ! snwo surface fraction [0-1]
-        REAL, DIMENSION(klon, nsoilmx), INTENT(OUT) :: tsoil ! Soil Temperature
-        REAL, DIMENSION(klon), INTENT(OUT) :: qsol      ! Soil Water Content
-        REAL, DIMENSION(klon), INTENT(INOUT) :: z0m    ! Momentum Roughn Lgt
-        REAL, DIMENSION(klon), INTENT(INOUT) :: z0h    ! Momentum Roughn Lgt
-
-        ! Output Variables for LMDZ
-        REAL, DIMENSION(klon), INTENT(OUT) :: alb1      ! Albedo SW
-        REAL, DIMENSION(klon), INTENT(OUT) :: alb2, alb3 ! Albedo NIR and LW
-        REAL, DIMENSION(klon,6), INTENT(OUT) :: alb6 ! 6 band Albedo
-        REAL, DIMENSION(klon), INTENT(OUT) :: emis_new  ! Surface Emissivity
-        REAL, DIMENSION(klon), INTENT(OUT) :: runoff_lic ! Runoff
-        REAL, DIMENSION(klon), INTENT(OUT) :: ffonte    ! enthalpy flux due to surface melting
-        REAL, DIMENSION(klon), INTENT(OUT) :: fqfonte   ! water flux due to surface melting
-        REAL, DIMENSION(klon), INTENT(OUT) :: dflux_s   ! d/dT sens. ht flux
-        REAL, DIMENSION(klon), INTENT(OUT) :: dflux_l   ! d/dT latent ht flux
-        REAL, DIMENSION(klon), INTENT(OUT) :: fluxsens  ! Sensible ht flux
-        REAL, DIMENSION(klon), INTENT(OUT) :: fluxlat   ! Latent heat flux
-        REAL, DIMENSION(klon), INTENT(OUT) :: evap      ! Evaporation
-        REAL, DIMENSION(klon), INTENT(OUT) :: erod      ! Erosion of surface snow (flux)
-        REAL, DIMENSION(klon), INTENT(OUT) :: agesno    ! Snow age (top layer)
-        REAL, DIMENSION(klon), INTENT(OUT) :: tsurf_new ! Surface Temperature
-        REAL, DIMENSION(klon), INTENT(OUT) :: qsurf     ! Surface Humidity
-
-        ! Specific INLANDIS outputs
-        REAL, DIMENSION(klon), INTENT(OUT) :: qsnow     ! Total H2O snow[kg/m2]
-        REAL, DIMENSION(klon), INTENT(OUT) :: snowhgt   ! Snow height (m)
-        REAL, DIMENSION(klon), INTENT(OUT) :: to_ice    ! Snow passed to ice
-        REAL, DIMENSION(klon), INTENT(OUT) :: sissnow   ! Snow in model (kg/m2)
-
-        ! +--Internal  Variables
-        ! +  ===================
-
-        CHARACTER(len = 20) :: fn_outfor ! Name for output file
-        CHARACTER (len = 80)              :: abort_message
-        CHARACTER (len = 20)              :: modname = 'surf_inlandsis_mod'
-
-        INTEGER :: i, ig, ikl, isl, isn, nt
-        INTEGER :: gp_outfor, un_outfor
-        REAL, PARAMETER :: f1 = 0.5
-        REAL, PARAMETER :: sn_upp = 10000., sn_low = 500.
-        REAL, PARAMETER :: sn_add = 400., sn_div = 2.
-        ! snow mass upper,lower limit,
-        ! added mass/division lowest layer
-        REAL, PARAMETER :: c1_zuo = 12.960e+4, c2_zuo = 2.160e+6
-        REAL, PARAMETER :: c3_zuo = 1.400e+2, czemin = 1.e-3
-        ! Parameters for drainage
-        ! c1_zuo/ 2.796e+4/,c2_zuo/2.160e+6/,c3_zuo/1.400e+2/ !     Tuning
-        ! +...        Run Off Parameters
-        ! +           86400*1.5 day     ...*25 days (Modif. ETH Camp: 86400*0.3day)
-        ! +           (Zuo and Oerlemans 1996, J.Glacio. 42, 305--317)
-
-        REAL, DIMENSION(klon) :: eps0SL          ! surface Emissivity
-        REAL :: zsigma, Ua_min, Us_min, lati
-        REAL, PARAMETER :: cdmax=0.05
-        REAL :: lambda          ! Par. soil discret.
-        REAL, DIMENSION(nsoilmx), SAVE :: dz1, dz2         ! Soil layer thicknesses
-        !$OMP THREADPRIVATE(dz1,dz2)
-        LOGICAL, SAVE :: firstcall
-        !$OMP THREADPRIVATE(firstcall)
-
-        INTEGER :: iso
-        LOGICAL :: file_exists
-        CHARACTER(len = 20) :: fichnom
-        LOGICAL :: is_init_domec
-        ! CA initialization
-        ! dz_profil_15 : 1 m in 15 layers [m]
-        real, parameter :: dz_profil_15(15) = (/0.005, 0.01, 0.015, 0.02, 0.03, 0.04, 0.05, &
-                                                0.06, 0.07, 0.08, 0.09, 0.1, 0.12, 0.14, 0.17/)
-        ! mean_temp : mean annual surface temperature [K]
-        real, dimension(klon) :: mean_temp
-        ! mean_dens : mean surface density [kg/m3]
-        real, dimension(klon) :: mean_dens
-        ! lat_scale : temperature lapse rate against latitude [K degree-1]
-        real :: lat_scale
-        ! sh_scale : temperature lapse rate against altitude [K km-1]
-        real :: sh_scale
-        ! variables for density profile
-        ! E0, E1 : exponent
-        real :: E0, E1
-        ! depth at which 550 kg m-3 is reached [m]
-        real :: z550
-        ! depths of snow layers
-        real :: depth, snow_depth, distup
-        ! number of initial snow layers
-        integer :: nb_snow_layer
-        ! For density calc.
-        real :: alpha0, alpha1, ln_smb
-        ! theoritical densities [kg m-3]
-        real :: rho0, rho1, rho1_550
-        ! constants for density profile
-        ! C0, C1 : constant, 0.07 for z <= 550 kg m-3
-        real, parameter :: C0 = 0.07
-        real, parameter :: C1 = 0.03
-        ! rho_i : ice density [kg m-3]
-        real, parameter :: rho_ice = 917.
-        ! E_c : activation energy [J mol-1]
-        real, parameter :: E_c = 60000.
-        ! E_g : activation energy [J mol-1]
-        real, parameter :: E_g = 42400.
-        ! R : gas constant [J mol-1 K-1]
-        real, parameter :: R = 8.3144621
-
-      
-     
-
-
-        ! + PROGRAM START
-        ! + -----------------------------------------
-
-        zsigma = 1000.
-        dt__SV = dtime
-
-        IF (debut) THEN
-            firstcall = .TRUE.
-            INI_SV = .false.
-        ELSE
-            firstcall = .false.
-            INI_SV = .true.
-        END IF
-
-        IF (ok_outfor) THEN
-            un_outfor = 51    ! unit number for point output file
-            gp_outfor = 1    ! grid point number for point output 1 for 1D, 273 for zoom-nudg DC
-            fn_outfor = 'outfor_SV.dat'
-        END IF
-
-        ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-        ! + INITIALISATION: BEGIN +++
-        ! + -----------------------------------------
-        IF (firstcall) THEN
-
-            ! +--Array size
-            ! +  -----------------------
-
-            klonv = klon
-            knonv = knon
-                write(*, *) 'ikl, lon and lat in INLANDSIS'
-
-            DO ikl = 1, knon
-                i=ikl2i(ikl)
-                write(*, *) 'ikl=', ikl, 'rlon=', rlon(i), 'rlat=', rlat(i)
-            END DO
-
-            ! +--Variables initizialisation
-            ! +  ---------------------------
-
-            CALL INIT_VARtSV
-            CALL INIT_VARxSV
-            CALL INIT_VARySV
-
-
-
-            ! +--Surface Fall Line Slope
-            ! +  -----------------------
-            IF (SnoMod)  THEN
-                DO ikl = 1, knon
-                    slopSV(ikl) = slope(ikl)
-                    SWf_SV(ikl) = &   ! Normalized Decay of the
-                            exp(-dt__SV             &   ! Surficial Water Content
-                                    / (c1_zuo                &   !(Zuo and Oerlemans 1996,
-                                            + c2_zuo * exp(-c3_zuo * abs(slopSV(ikl)))))  ! J.Glacio. 42, 305--317)
-                END DO
-            END IF
-
-
-
-            ! +--Soil layer thickness . Compute soil discretization (as for LMDZ)
-            ! +  ----------------------------------------------------------------
-            !        write(*,'(/a)') 'Start SISVAT init: soil discretization ', nsoilmx
-            CALL get_soil_levels(dz1, dz2, lambda)
-
-            lambSV = lambda
-            dz1_SV(1:knon, 1:) = 0.
-            dz2_SV(1:knon, 1:) = 0.
-
-            DO isl = -nsol, 0
-                dz_dSV(isl) = 0.5e-3 * dz2(1 - isl)           ! Soil layer thickness
-                DO ikl = 1, knon
-                    dz1_SV(ikl, isl) = dz1(1 - isl)    !1.e-3*
-                    dz2_SV(ikl, isl) = dz2(1 - isl)    !1.e-3*
-                END DO
-            END DO
-
-
-            ! Set variables
-            ! =============
-            DO ikl = 1, knon
-                ! LSmask : Land/Sea Mask
-                LSmask(ikl) = 1
-                ! isotSV : Soil Type -> 12 = ice
-                isotSV(ikl) = 12
-                ! iWaFSV : Soil Drainage (1,0)=(y,n)
-                iWaFSV(ikl) = 1
-                ! eps0SL : Surface Emissivity
-                eps0SL(ikl) = 1.
-                ! alb0SV : Soil Albedo
-                alb0SV(ikl) = alb_soil(ikl)
-                ! Tsf_SV : Surface Temperature, must be bellow freezing
-                Tsf_SV(ikl) = min(temp_air(ikl), TfSnow)
-            END DO
-
-            ! +--Initialization of soil and snow variables in case startsis is not read
-            ! +  ----------------------------------------------------------------------
-
-            is_init_domec=.FALSE.
-
-
-            IF (is_init_domec) THEN
-            ! Coarse initilization inspired from vertcical profiles at Dome C,
-            ! Antarctic Plateaui (10m of snow, 19 levels)
-
-                 DO ikl = 1,knon
-! + Soil
-                 DO isl =   -nsol,0    
-                   TsisSV(ikl,isl) = min(tsoil(ikl,1+nsol),TfSnow-0.2)   !temp_air(ikl)
-                   !tsoil(ikl,1-isl)   Soil Temperature
-                   !TsisSV(ikl,isl) = min(temp_air(ikl),TfSnow-0.2)
-                   eta_SV(ikl,isl) = epsi           !etasoil(ikl,1-isl) Soil Water[m3/m3]
-                   ro__SV(ikl,isl) = rhoIce         !rosoil(ikl,1-isl) volumic mass
-                 END DO   
-
-
-           ! Snow
-                 isnoSV(ikl) = 19
-                 istoSV(ikl, 1:isnoSV(ikl)) = 100
-                 ro__SV(ikl, 1:isnoSV(ikl)) = 350.
-                 eta_SV(ikl, 1:isnoSV(ikl)) = epsi
-                 TsisSV(ikl, 1:isnoSV(ikl)) = min(tsoil(ikl, 1), TfSnow - 0.2)
-                 G1snSV(ikl, 1:isnoSV(ikl)) = 99.
-                 G2snSV(ikl, 1:isnoSV(ikl)) = 2.
-                 agsnSV(ikl, 1:isnoSV(ikl)) = 50.
-                 dzsnSV(ikl, 19) = 0.015
-                 dzsnSV(ikl, 18) = 0.015
-                 dzsnSV(ikl, 17) = 0.020
-                 dzsnSV(ikl, 16) = 0.030
-                 dzsnSV(ikl, 15) = 0.040
-                 dzsnSV(ikl, 14) = 0.060
-                 dzsnSV(ikl, 13) = 0.080
-                 dzsnSV(ikl, 12) = 0.110
-                 dzsnSV(ikl, 11) = 0.150
-                 dzsnSV(ikl, 10) = 0.200
-                 dzsnSV(ikl, 9) = 0.300
-                 dzsnSV(ikl, 8) = 0.420
-                 dzsnSV(ikl, 7) = 0.780
-                 dzsnSV(ikl, 6) = 1.020
-                 dzsnSV(ikl, 5) = 0.980
-                 dzsnSV(ikl, 4) = 1.020
-                 dzsnSV(ikl, 3) = 3.970
-                 dzsnSV(ikl, 2) = 1.020
-                 dzsnSV(ikl, 1) = 1.020
-
-                 END DO
-            ELSE
-
-            ! Initilialisation with climatological temperature and density
-            ! profiles as in MAR. Methodology developed by Cecile Agosta
-  
-            ! initialize with 0., for unused snow layers
-            dzsnSV = 0.
-            G1snSV = 0.
-            G2snSV = 0.
-            istoSV = 0
-            TsisSV = 0.
-
-
-            ! initialize mean variables (unrealistic)
-            mean_temp = TfSnow
-            mean_dens = 300.
-            ! loop on grid cells
-            DO ikl = 1, knon
-            	lati=rlat(ikl2i(ikl))
-                ! approximations for mean_temp and mean_dens
-                ! from Feulner et al., 2013 (DOI: 10.1175/JCLI-D-12-00636.1)
-                ! Fig. 3 and 5 : the lapse rate vs. latitude at high latitude is about 0.55 °C °lat-1
-                ! with a moist-adiabatic lapse rate of 5 °C km-1 everywhere except for Antarctica,
-                ! for Antarctica, a dry-adiabatic lapse rate of 9.8 °C km-1 is assumed.
-                if (lati > 60.) then
-                    ! CA todo : add longitude bounds
-                    ! Greenland mean temperature : function of altitude and latitude
-                    ! for altitudes 0. to 1000. m, lat_scale varies from 0.9 to 0.75 °C °lat-1
-                    lat_scale = (0.75 - 0.9) / 1000. * alt(ikl) + 0.9
-                    lat_scale = max(min(lat_scale, 0.9), 0.75)
-                    ! sh_scale equals the environmental lapse rate : 6.5 °C km-1
-                    sh_scale = 6.5
-                    mean_temp(ikl) = TfSnow + 1.5 - sh_scale * alt(ikl) / 1000. - lat_scale * (lati - 60.)
-                    ! surface density: Fausto et al. 2018, https://doi.org/10.3389/feart.2018.00051
-                    mean_dens(ikl) = 315.
-                else if (lati < -60.) then
-                    ! Antarctica mean temperature : function of altitude and latitude
-                    ! for altitudes 0. to 500. m, lat_scale varies from 1.3 to 0.6 °C °lat-1
-                    lat_scale = (0.6 - 1.3) / 500. * alt(ikl) + 1.3
-                    lat_scale = max(min(lat_scale, 1.3), 0.6)
-                    ! for altitudes 0. to 500. m, sh_scale varies from 6.5 to 9.8 °C km-1
-                    sh_scale = (9.8 - 6.5) / 500. * alt(ikl) + 6.5
-                    sh_scale = max(min(sh_scale, 9.8), 6.5)
-                    mean_temp(ikl) = TfSnow - 7. - sh_scale * alt(ikl) / 1000. + lat_scale * (lati + 60.)
-                    ! Antarctica surface density : function of mean annual temperature
-                    ! surface density of 350. kg m-3 at Dome C and 450. kg m-3 at Prud'homme (Agosta et al. 2013)
-                    ! 350 kg m-3 is a typical value for the Antarctic plateau around 3200 m.
-                    ! Weinhart et al 2020  https://doi.org/10.5194/tc-14-3663-2020 and Sugiyama et al. 2011 oi: 10.3189/2012JoG11J201
-                    ! 320 kg m-3 is reached at Dome A, 4100 m a.s.l.
-                    ! Dome C : st_ant_param(3233, -75.1) = -47.7
-                    ! Dumont d'Urville : st_ant_param(0, -66.66) = -15.7
-                    mean_dens(ikl) =  (450. - 320.) / (-15.7 + 47.7) * (mean_temp(ikl) - TfSnow + 15.7) + 450.
-                    mean_dens(ikl) = min(450., max(320., mean_dens(ikl)))
-                else
-
-                !    write(*, *) 'Attention: temperature initialization is only defined for Greenland and Antarctica'
-
-                     mean_dens(ikl) =350.
-                     mean_temp(ikl) = min(tsoil(ikl,1),TfSnow-0.2)
-
-                !abort_message='temperature initialization is only defined for Greenland and Antarctica'
-                !CALL abort_physic(modname,abort_message,1)
-
-                end if
- 
-                ! mean_temp is defined for ice ground only
-                mean_temp(ikl) = min(mean_temp(ikl), TfSnow - 0.2)
-
-                ! Soil layers
-                ! ===========
-                DO isl = -nsol, 0
-                    ! TsisSV : Temperature [K]
-                    TsisSV(ikl, isl) = mean_temp(ikl)
-                    ! eta_SV : Soil Water [m3/m3]
-                    eta_SV(ikl, isl) = epsi
-                    ! ro__SV : Volumic Mass [kg/m3]
-                    ro__SV(ikl, isl) = rhoIce
-                END DO
-
-                ! Snow layers
-                ! ===========
-                ! snow_depth : initial snow depth
-                snow_depth = 20.
-                ! nb_snow_layer : initial nb of snow layers
-                nb_snow_layer = 15
-                ! isnoSV : total nb of snow layers
-                isnoSV(ikl) = nb_snow_layer
-                ! depth : depth of each layer
-                depth = snow_depth
-                do isl = 1, nb_snow_layer
-                    ! dzsnSV : snow layer thickness
-                    dzsnSV(ikl, isl) = max(0.01, snow_depth * dz_profil_15(nb_snow_layer - isl + 1))
-                    ! G1snSV : dendricity (<0) or sphericity (>0) : 99. = sperical
-                    G1snSV(ikl, isl) = 99.
-                    ! G2snSV : Sphericity (>0) or Size [1/10 mm] : 2. = small grain size
-                    G2snSV(ikl, isl) = 3.
-                    agsnSV(ikl, isl) = 0.
-                    istoSV(ikl, isl) = 0
-                    ! eta_SV : Liquid Water Content [m3/m3]
-                    eta_SV(ikl, isl) = 0.
-                    ! distance to surface
-                    depth = depth - dzsnSV(ikl,isl) / 2.
-                    distup = min(1., max(0., depth / snow_depth))
-                    ! TsisSV : Temperature [K], square interpolation between Tsf_SV (surface) and mean_temp (bottom)
-                    TsisSV(ikl, isl) = Tsf_SV(ikl) * (1. - distup**2) + mean_temp(ikl) * distup**2
-                    ! firn density : densification formulas from :
-                    ! Ligtenberg et al 2011 eq. (6) (www.the-cryosphere.net/5/809/2011/)
-                    ! equivalent to Arthern et al. 2010 eq. (4) "Nabarro-Herring" (doi:10.1029/2009JF001306)
-                    ! Integration of the steady state equation
-                    ! ln_smb approximated as a function of temperature
-                    ln_smb = max((mean_temp(ikl) - TfSnow) * 5. / 60. + 8., 3.)
-                    ! alpha0, alpha1 : correction coefficient as a function of ln_SMB from Ligtenberg 2011, adjusted for alpha1
-                    alpha0 = max(1.435 - 0.151 * ln_smb, 0.25)
-                    alpha1 = max(2.0111 - 0.2051 * ln_smb, 0.25)
-                    E0 = C0 * gravit * exp((E_g - E_c)/(R * mean_temp(ikl))) * rho_ice * alpha0
-                    E1 = C1 * gravit * exp((E_g - E_c)/(R * mean_temp(ikl))) * rho_ice * alpha1
-                    z550 = log((rho_ice/mean_dens(ikl) - 1.)/(rho_ice/550. - 1.)) / E0
-                    rho0 = exp(E0 * depth) / (rho_ice / mean_dens(ikl) - 1 + exp(E0 * depth)) * rho_ice
-                    rho1 = exp(E1 * depth) / (rho_ice / mean_dens(ikl) - 1 + exp(E1 * depth)) * rho_ice
-                    if (depth <= z550) then
-                        ro__SV(ikl, isl) = exp(E0 * depth) / (rho_ice / mean_dens(ikl) - 1 + exp(E0 * depth)) * rho_ice
-                    else
-                        ro__SV(ikl, isl) = exp(E1 * (depth - z550)) / (rho_ice / 550. - 1 + exp(E1 * (depth - z550))) * rho_ice
-                    end if
-                    depth = depth - dzsnSV(ikl,isl) / 2.
-                    
-                end do
-
-            END DO
-
-            END IF
-
-
-            ! + Numerics paramaters, SISVAT_ini 
-            ! +  ----------------------
-            CALL SISVAT_ini(knon)
-
-
-            ! +--Read restart file
-            ! +  =================================================
-
-            INQUIRE(FILE = "startsis.nc", EXIST = file_exists)
-            IF (file_exists) THEN
-                CALL sisvatetat0("startsis.nc", ikl2i)
-            END IF
-
-
-
-            ! +--Output ascii file
-            ! +  =================================================
-
-            ! open output file
-            IF (ok_outfor) THEN
-                open(unit = un_outfor, status = 'replace', file = fn_outfor)
-                ikl = gp_outfor     ! index sur la grille land ice
-                write(un_outfor, *) fn_outfor, ikl, dt__SV, rlon(ikl2i(ikl)), rlat(ikl2i(ikl))
-                write(un_outfor, *) 'nsnow - albedo - z0m - z0h , dz [m,30], temp [K,41], rho [kg/m3,41], eta [kg/kg,41] &
-                        & G1 [-,30], G2 [-,30], agesnow [d,30], history [-,30], DOP [m,30]'
-            END IF
-
-        END IF  ! firstcall
-        ! +
-        ! +  +++  INITIALISATION:  END  +++
-        ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-
-
-
-        ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-        ! + READ FORCINGS
-        ! + ------------------------
-
-        ! + Update Forcings for SISVAT given by the LMDZ model.
-        ! +
-        DO ikl = 1, knon
-
-            ! +--Atmospheric Forcing                                    (INPUT)
-            ! +  ^^^^^^^^^^^^^^^^^^^                                     ^^^^^
-            za__SV(ikl) = zsl_height(ikl)               ! surface layer height (fisr model level) [m]
-            Ua_min = 0.2 * sqrt(za__SV(ikl))            !
-            VV__SV(ikl) = max(Ua_min, wind_velo(ikl))   ! Wind velocity       [m/s]
-            TaT_SV(ikl) = temp_air(ikl)                 ! BL top Temperature    [K]
-            ExnrSV(ikl) = pexner(ikl)                   ! Exner potential
-            rhT_SV(ikl) = dens_air(ikl)                 ! Air density
-            QaT_SV(ikl) = spechum(ikl)                  ! Specific humidity
-            ps__SV(ikl) = ps(ikl)                       ! surface pressure     [Pa]
-            p1l_SV(ikl) = p1lay(ikl)                    ! lowest atm. layer press[Pa]
-
-            ! +--Surface properties
-            ! +  ^^^^^^^^^^^^^^^^^^
-
-            Z0m_SV(ikl) = z0m(ikl)                      ! Moment.Roughn.L.
-            Z0h_SV(ikl) = z0h(ikl)                      ! Moment.Roughn.L.
-
-            ! +--Energy Fluxes                                          (INPUT)
-            ! +  ^^^^^^^^^^^^^                                           ^^^^^
-            coszSV(ikl) = max(czemin, rmu0(ikl))         ! cos(zenith.Dist.)
-            sol_SV(ikl) = swdown(ikl)                   ! downward Solar
-            IRd_SV(ikl) = lwdown(ikl)                   ! downward IR
-            rsolSV(ikl) = radsol(ikl)                   ! surface absorbed rad.
-
-            ! +--Water  Fluxes                                          (INPUT)
-            ! +  ^^^^^^^^^^^^^                                           ^^^^^
-            drr_SV(ikl) = precip_rain(ikl)              ! Rain fall rate  [kg/m2/s]
-            dsn_SV(ikl) = precip_snow(ikl)              ! Snow fall rate  [kg/m2/s]
-
-            ! #BS    dbs_SV(ikl) = blowSN(i,j,n)
-            ! dbs_SV = Maximum potential erosion amount [kg/m2]
-            ! => Upper bound for eroded snow mass
-            !        uss_SV(ikl) = SLussl(i,j,n) ! u*qs* (only for Tv in sisvatesbl.f)
-            ! #BS  if(dsn_SV(ikl)>eps12.and.erprev(i,j,n).gt.eps9) then
-            ! #BS    dsnbSV(ikl) =1.0-min(qsHY(i,j,kB)     !BS neglib. at kb ~100 magl)
-            ! #BS.                        /max(qshy(i,j,mz),eps9),unun)
-            ! #BS    dsnbSV(ikl) = max(dsnbSV(ikl),erprev(i,j,n)/dsn_SV(ikl))
-            ! #BS    dsnbSV(ikl) = max(0.,min(1.,dsnbSV(ikl)))
-            ! #BS  else
-            ! #BS    dsnbSV(ikl) = 0.
-            ! #BS  endif
-            !      dsnbSV is the drift fraction of deposited snow updated in sisvat.f
-            !      will be used for characterizing the Buffer Layer
-            !      (see update of  Bros_N, G1same, G2same, zroOLD, zroNEW)
-            ! #BS  if(n==1) qbs_HY(i,j) = dsnbSV(ikl)
-            qsnoSV(ikl) = snow_cont_air(ikl)
-
-
-
-            ! +--Soil/BL                                      (INPUT)
-            ! +  ^^^^^^^                                       ^^^^^
-            alb0SV(ikl) = alb_soil(ikl)                 ! Soil background Albedo
-            AcoHSV(ikl) = AcoefH(ikl)
-            BcoHSV(ikl) = BcoefH(ikl)
-            AcoQSV(ikl) = AcoefQ(ikl)
-            BcoQSV(ikl) = BcoefQ(ikl)
-            cdH_SV(ikl) = min(cdragh(ikl),cdmax)
-            cdM_SV(ikl) = min(cdragm(ikl),cdmax)
-            rcdmSV(ikl) = sqrt(cdM_SV(ikl))
-            Us_min = 0.01
-            us__SV(ikl) = max(Us_min, ustar(ikl))
-            ram_sv(ikl) = 1. / (cdM_SV(ikl) * max(VV__SV(ikl), eps6))
-            rah_sv(ikl) = 1. / (cdH_SV(ikl) * max(VV__SV(ikl), eps6))
-
-            ! +--Energy Fluxes                                          (INPUT/OUTPUT)
-            ! +  ^^^^^^^^^^^^^                                           ^^^^^^^^^^^^
-            !IF (.not.firstcall) THEN
-            Tsrfsv(ikl)  = tsurf(ikl)                     !hj 12 03 2010
-            cld_SV(ikl) = cloudf(ikl)                    ! Cloudiness
-            !END IF
-
-         END DO
-
-        !
-        ! +  +++  READ FORCINGS:  END  +++
-        ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
- 
-
-        ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-        ! +--SISVAT EXECUTION
-        ! +  ----------------
-
-        call  INLANDSIS(SnoMod, BloMod, 1)
-
-
-       
-        ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-        ! + RETURN RESULTS
-        ! + --------------
-        ! + Return (compressed) SISVAT variables to LMDZ
-        ! +
-        DO  ikl = 1, knon                  ! use only 1:knon (actual ice sheet..)
-            dflux_s(ikl) = dSdTSV(ikl)         ! Sens.H.Flux T-Der.
-            dflux_l(ikl) = dLdTSV(ikl)         ! Latn.H.Flux T-Der.
-            fluxsens(ikl) = HSs_sv(ikl)         ! HS
-            fluxlat(ikl) = HLs_sv(ikl)         ! HL
-            evap(ikl) = -1*HLs_sv(ikl) / LHvH2O  ! Evaporation
-            erod(ikl) = 0.
-
-            IF (BloMod) THEN
-                ! + Blowing snow
-
-                !       SLussl(i,j,n)= 0.
-                ! #BS   SLussl(i,j,n)=                     !Effective erosion
-                ! #BS. (- dbs_ER(ikl))/(dt*rhT_SV(ikl))    !~u*qs* from previous time step
-                ! #BS   blowSN(i,j,n)=  dt*uss_SV(ikl)     !New max. pot. Erosion [kg/m2]
-                ! #BS.                    *rhT_SV(ikl)     !(further bounded in sisvat_bsn.f)
-                ! #BS  erprev(i,j,n) =     dbs_Er(ikl)/dt__SV
-                erod(ikl) = dbs_Er(ikl) / dt__SV
-            ENDIF
-
-            ! +   Check snow thickness,  substract if too thick, add if too thin
-
-            sissnow(ikl) = 0.  !()
-            DO  isn = 1, isnoSV(ikl)
-                sissnow(ikl) = sissnow(ikl) + dzsnSV(ikl, isn) * ro__SV(ikl, isn)
-            END DO
-
-            IF (sissnow(ikl) .LE. sn_low) THEN  !add snow
-                IF (isnoSV(ikl).GE.1) THEN
-                    dzsnSV(ikl, 1) = dzsnSV(ikl, 1) + sn_add / max(ro__SV(ikl, 1), epsi)
-                    toicSV(ikl) = toicSV(ikl) - sn_add
-                ELSE
-                    write(*, *) 'Attention, bare ice... point ', ikl
-                    isnoSV(ikl) = 1
-                    istoSV(ikl, 1) = 0
-                    ro__SV(ikl, 1) = 350.
-                    dzsnSV(ikl, 1) = sn_add / max(ro__SV(ikl, 1), epsi)  ! 1.
-                    eta_SV(ikl, 1) = epsi
-                    TsisSV(ikl, 1) = min(TsisSV(ikl, 0), TfSnow - 0.2)
-                    G1snSV(ikl, 1) = 0.
-                    G2snSV(ikl, 1) = 0.3
-                    agsnSV(ikl, 1) = 10.
-                    toicSV(ikl) = toicSV(ikl) - sn_add
-                END IF
-            END IF
-
-            IF (sissnow(ikl) .ge. sn_upp) THEN  !thinnen snow layer below
-                dzsnSV(ikl, 1) = dzsnSV(ikl, 1) / sn_div
-                toicSV(ikl) = toicSV(ikl) + dzsnSV(ikl, 1) * ro__SV(ikl, 1) / sn_div
-            END IF
-
-            sissnow(ikl) = 0.
-            qsnow(ikl) = 0.
-            snow(ikl) = 0.
-            snowhgt(ikl) = 0.
-
-            DO  isn = 1, isnoSV(ikl)
-                sissnow(ikl) = sissnow(ikl) + dzsnSV(ikl, isn) * ro__SV(ikl, isn)
-                snowhgt(ikl) = snowhgt(ikl) + dzsnSV(ikl, isn)
-                ! Etienne: check calc qsnow
-                qsnow(ikl) = qsnow(ikl) + rhoWat * eta_SV(ikl, isn) * dzsnSV(ikl, isn)
-            END DO
-
-            zfra(ikl) = max(min(isnoSV(ikl) - iiceSV(ikl), 1), 0)
-            ! Etienne: comment following line
-            ! snow(ikl)    = sissnow(ikl)+toicSV(ikl)
-            snow(ikl) = sissnow(ikl)
-
-            to_ice(ikl) = toicSV(ikl)
-            runoff_lic(ikl) = RnofSV(ikl)    ! RunOFF: intensity (flux due to melting + liquid precip)
-            fqfonte(ikl)= max(0., (wem_SV(ikl)-wer_SV(ikl))/dtime) ! net melting = melting - refreezing
-            ffonte(ikl)=fqfonte(ikl)*Lf_H2O
-
-            qsol(ikl) = 0.
-            DO  isl = -nsol, 0
-                tsoil(ikl, 1 - isl) = TsisSV(ikl, isl)       ! Soil Temperature
-                ! Etienne: check calc qsol
-                qsol(ikl) = qsol(ikl)                      &
-                        + eta_SV(ikl, isl) * dz_dSV(isl)
-            END DO
-            agesno(ikl) = agsnSV(ikl, isnoSV(ikl))        !          [day]
-
-            alb1(ikl) = alb1sv(ikl)             ! Albedo VIS
-!            alb2(ikl) = ((So1dSV - f1) * alb1sv(ikl)                   &
-!                    & + So2dSV * alb2sv(ikl) + So3dSV * alb3sv(ikl)) / f1
-            alb2(ikl)=alb2sv(ikl)
-            ! Albedo NIR
-            alb3(ikl) = alb3sv(ikl)             ! Albedo FIR
-            ! 6 band Albedo
-            alb6(ikl,:)=alb6sv(ikl,:)
-
-            tsurf_new(ikl) = Tsrfsv(ikl)
-
-            qsurf(ikl) = QsT_SV(ikl)
-            emis_new(ikl) = eps0SL(ikl)
-            z0m(ikl) = Z0m_SV(ikl)
-            z0h(ikl) = Z0h_SV(ikl)
-
-
-        END DO
-
-            IF (ok_outfor) THEN
-             ikl= gp_outfor
-            write(un_outfor, *) '+++++++++++', rlon(ikl2i(ikl)), rlat(ikl2i(ikl)),alt(ikl),'+++++++++++'
-            write(un_outfor, *) isnoSV(ikl), alb_SV(ikl), Z0m_SV(ikl), Z0h_SV(ikl),HSs_sv(ikl),HLs_sv(ikl),alb1(ikl),alb2(ikl)
-            write(un_outfor, *) dzsnSV(ikl, :)
-            write(un_outfor, *) TsisSV(ikl, :)
-            write(un_outfor, *) ro__SV(ikl, :)
-            write(un_outfor, *) eta_SV(ikl, :)
-            write(un_outfor, *) G1snSV(ikl, :)
-            write(un_outfor, *) G2snSV(ikl, :)
-            write(un_outfor, *) agsnSV(ikl, :)
-            write(un_outfor, *) istoSV(ikl, :)
-            write(un_outfor, *) DOPsnSV(ikl, :)
-        ENDIF
-
-
-
-        ! +  -----------------------------
-        ! +  END --- RETURN RESULTS
-        ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-        IF (lafin) THEN
-            fichnom = "restartsis.nc"
-            CALL sisvatredem("restartsis.nc", ikl2i, rlon, rlat)
-
-            IF (ok_outfor) THEN
-                close(unit = un_outfor)
-            END IF
-        END IF
-
-    END SUBROUTINE surf_inlandsis
-
-
-    !=======================================================================
-
-    SUBROUTINE get_soil_levels(dz1, dz2, lambda)
-        ! ======================================================================
-        ! Routine to compute the vertical discretization of the soil in analogy
-        ! to LMDZ. In LMDZ it is done in soil.F, which is not used in the case
-        ! of SISVAT, therefore it's needed here.
-        !
-        USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root
-        USE mod_phys_lmdz_para
-        USE VAR_SV
-
-
-        !    INCLUDE "dimsoil.h"
-
-        REAL, DIMENSION(nsoilmx), INTENT(OUT) :: dz2, dz1
-        REAL, INTENT(OUT) :: lambda
-
-
-        !-----------------------------------------------------------------------
-        !   Depthts:
-        !   --------
-        REAL fz, rk, fz1, rk1, rk2
-        REAL min_period, dalph_soil
-        INTEGER ierr, jk
-
-        fz(rk) = fz1 * (dalph_soil**rk - 1.) / (dalph_soil - 1.)
-
-        !    write(*,*)'Start soil level computation'
-        !-----------------------------------------------------------------------
-        ! Calculation of some constants
-        ! NB! These constants do not depend on the sub-surfaces
-        !-----------------------------------------------------------------------
-        !-----------------------------------------------------------------------
-        !   ground levels
-        !   grnd=z/l where l is the skin depth of the diurnal cycle:
-        !-----------------------------------------------------------------------
-
-        min_period = 1800. ! en secondes
-        dalph_soil = 2.    ! rapport entre les epaisseurs de 2 couches succ.
-        ! !$OMP MASTER
-        !     IF (is_mpi_root) THEN
-        !        OPEN(99,file='soil.def',status='old',form='formatted',iostat=ierr)
-        !        IF (ierr == 0) THEN ! Read file only if it exists
-        !           READ(99,*) min_period
-        !           READ(99,*) dalph_soil
-        !           PRINT*,'Discretization for the soil model'
-        !           PRINT*,'First level e-folding depth',min_period, &
-        !                '   dalph',dalph_soil
-        !           CLOSE(99)
-        !        END IF
-        !     ENDIF
-        ! !$OMP END MASTER
-        !     CALL bcast(min_period)
-        !     CALL bcast(dalph_soil)
-
-        !   la premiere couche represente un dixieme de cycle diurne
-        fz1 = SQRT(min_period / 3.14)
-
-        DO jk = 1, nsoilmx
-            rk1 = jk
-            rk2 = jk - 1
-            dz2(jk) = fz(rk1) - fz(rk2)
-        ENDDO
-        DO jk = 1, nsoilmx - 1
-            rk1 = jk + .5
-            rk2 = jk - .5
-            dz1(jk) = 1. / (fz(rk1) - fz(rk2))
-        ENDDO
-        lambda = fz(.5) * dz1(1)
-        DO jk = 1, nsoilmx
-            rk = jk
-            rk1 = jk + .5
-            rk2 = jk - .5
-        ENDDO
-
-    END SUBROUTINE get_soil_levels
-
-
-    !===========================================================================
-
-    SUBROUTINE SISVAT_ini(knon)
-
-        !C +------------------------------------------------------------------------+
-        !C | MAR          SISVAT_ini                             Jd 11-10-2007  MAR |
-        !C |   SubRoutine SISVAT_ini generates non time dependant SISVAT parameters |
-        !C +------------------------------------------------------------------------+
-        !C |   PARAMETERS:  klonv: Total Number of columns =                        |
-        !C |   ^^^^^^^^^^        = Total Number of continental     grid boxes       |
-        !C |                     X       Number of Mosaic Cell per grid box         |
-        !C |                                                                        |
-        !C |   INPUT:   dt__SV   : Time  Step                                   [s] |
-        !C |   ^^^^^    dz_dSV   : Layer Thickness                              [m] |
-        !C |                                                                        |
-        !C |   OUTPUT:             [-] |
-        !C |   ^^^^^^   rocsSV   : Soil Contrib. to (ro c)_s exclud.Water  [J/kg/K] |
-        !C |            etamSV   : Soil Minimum Humidity                    [m3/m3] |
-        !C |                      (based on a prescribed Soil Relative Humidity)    |
-        !C |            s1__SV   : Factor of eta**( b+2) in Hydraul.Diffusiv.       |
-        !C |            s2__SV   : Factor of eta**( b+2) in Hydraul.Conduct.        |
-        !C |            aKdtSV   : KHyd: Piecewise Linear Profile:  a * dt    [m]   |
-        !C |            bKdtSV   : KHyd: Piecewise Linear Profile:  b * dt    [m/s] |
-        !C |            dzsnSV(0): Soil first Layer Thickness                   [m] |
-        !C |            dzmiSV   : Distance between two contiguous levels       [m] |
-        !C |            dz78SV   : 7/8 (Layer Thickness)                        [m] |
-        !C |            dz34SV   : 3/4 (Layer Thickness)                        [m] |
-        !C |            dz_8SV   : 1/8 (Layer Thickness)                        [m] |
-        !C |            dzAvSV   : 1/8  dz_(i-1) + 3/4 dz_(i) + 1/8 dz_(i+1)    [m] |
-        !C |            dtz_SV   : dt/dz                                      [s/m] |
-        !C |            OcndSV   : Swab Ocean / Soil Ratio                      [-] |
-        !C |            Implic   : Implicit Parameter  (0.5:  Crank-Nicholson)      |
-        !C |            Explic   : Explicit Parameter = 1.0 - Implic                |
-        !C |                                                                        |
-        !C | # OPTIONS: #ER: Richards Equation is not smoothed                      |
-        !C | # ^^^^^^^  #kd: De Ridder   Discretization                             |
-        !C | #          #SH: Hapex-Sahel Values                                     !
-        !C |                                                                        |
-        !C +------------------------------------------------------------------------+
-        !
-        !
-
-        !C +--Global Variables
-        !C +  ================
-
-        USE dimphy
-        USE VARphy
-        USE VAR_SV
-        USE VARdSV
-        USE VAR0SV
-        USE VARxSV
-        USE VARtSV
-        USE VARxSV
-        USE VARySV
-        IMPLICIT NONE
-
-
-
-        !C +--Arguments
-        !C +  ==================
-        INTEGER, INTENT(IN) :: knon
-
-        !C +--Internal Variables
-        !C +  ==================
-
-        INTEGER :: ivt, ist, ikl, isl, isn, ikh
-        INTEGER :: misl_2, nisl_2
-        REAL :: d__eta, eta__1, eta__2, Khyd_1, Khyd_2
-        REAL, PARAMETER :: RHsMin = 0.001        ! Min.Soil Relative Humidity
-        REAL :: PsiMax                        ! Max.Soil Water    Potential
-        REAL :: a_Khyd, b_Khyd                 ! Water conductivity
-
-
-        !c #WR REAL    ::  Khyd_x,Khyd_y
-
-
-
-        !C +--Non Time Dependant SISVAT parameters
-        !C +  ====================================
-
-        !C +--Soil Discretization
-        !C +  -------------------
-
-        !C +--Numerical Scheme Parameters
-        !C +  ^^^^^^^^^^^^^^^^^^^^^^^^^^^
-        Implic = 0.75                           ! 0.5  <==> Crank-Nicholson  
-        Explic = 1.00 - Implic                  !                            
-
-        !C +--Soil/Snow Layers Indices
-        !C +  ^^^^^^^^^^^^^^^^^^^^^^^^
-        DO  isl = -nsol, 0
-            islpSV(isl) = isl + 1
-            islpSV(isl) = min(islpSV(isl), 0)
-            islmSV(isl) = isl - 1
-            islmSV(isl) = max(-nsol, islmSV(isl))
-        END DO
-
-        DO  isn = 1, nsno
-            isnpSV(isn) = isn + 1
-            isnpSV(isn) = min(isnpSV(isn), nsno)
-        END DO
-
-        !C +--Soil      Layers Thicknesses
-        !C +  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-        ! Not used here as LMDZ method is applied, see SUBROUTINE get_soil_levels!
-        !c #kd IF (nsol.gt.4)                                              THEN
-        !c #kd   DO isl=-5,-nsol,-1
-        !c #kd     dz_dSV(isl)=   1.
-        !c #kd   END DO
-        !c #kd END IF
-        !
-        !      IF (nsol.ne.4)                                              THEN
-        !        DO isl= 0,-nsol,-1
-        !          misl_2 =     -mod(isl,2)
-        !          nisl_2 =         -isl/2
-        !          dz_dSV(isl)=(((1-misl_2) * 0.001
-        !     .                  +  misl_2  * 0.003) * 10**(nisl_2)) * 4.
-        !C +...    dz_dSV(0)  =         Hapex-Sahel Calibration:       4 mm
-        !
-        !c +SH     dz_dSV(isl)=(((1-misl_2) * 0.001
-        !c +SH.                  +  misl_2  * 0.003) * 10**(nisl_2)) * 1.
-        !
-        !c #05     dz_dSV(isl)=(((1-misl_2) * 0.001
-        !c #05.                  +  misl_2  * 0.008) * 10**(nisl_2)) * 0.5
-        !        END DO
-        !          dz_dSV(0)  =               0.001
-        !          dz_dSV(-1) = dz_dSV(-1)  - dz_dSV(0)              + 0.004
-        !      END IF
-
-        zz_dSV = 0.
-        DO  isl = -nsol, 0
-            dzmiSV(isl) = 0.500 * (dz_dSV(isl) + dz_dSV(islmSV(isl)))
-            dziiSV(isl) = 0.500 * dz_dSV(isl) / dzmiSV(isl)
-            dzi_SV(isl) = 0.500 * dz_dSV(islmSV(isl)) / dzmiSV(isl)
-            dtz_SV(isl) = dt__SV / dz_dSV(isl)
-            dtz_SV2(isl) = 1. / dz_dSV(isl)
-            dz78SV(isl) = 0.875 * dz_dSV(isl)
-            dz34SV(isl) = 0.750 * dz_dSV(isl)
-            dz_8SV(isl) = 0.125 * dz_dSV(isl)
-            dzAvSV(isl) = 0.125 * dz_dSV(islmSV(isl))                        &
-                    & + 0.750 * dz_dSV(isl)                                &
-                    & + 0.125 * dz_dSV(islpSV(isl))
-            zz_dSV = zz_dSV + dz_dSV(isl)
-        END DO
-        DO ikl = 1, knon !v
-            dzsnSV(ikl, 0) = dz_dSV(0)
-        END DO
-
-        !C +--Conversion to a 50 m Swab Ocean Discretization
-        !C +  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-        OcndSV = 0.
-        DO isl = -nsol, 0
-            OcndSV = OcndSV + dz_dSV(isl)
-        END DO
-        OcndSV = 50. / OcndSV
-
-
-        !C +--Secondary Soil       Parameters
-        !C +  -------------------------------
-
-        DO  ist = 0, nsot
-            rocsSV(ist) = (1.0 - etadSV(ist)) * 1.2E+6   ! Soil Contrib. to (ro c)_s
-            s1__SV(ist) = bCHdSV(ist)          & ! Factor of (eta)**(b+2)
-                    & * psidSV(ist) * Ks_dSV(ist)          & !    in DR97, Eqn.(3.36)
-                    & / (etadSV(ist)**(bCHdSV(ist) + 3.))     !
-            s2__SV(ist) = Ks_dSV(ist)          & ! Factor of (eta)**(2b+3)
-                    & / (etadSV(ist)**(2. * bCHdSV(ist) + 3.))     !    in DR97, Eqn.(3.35)
-
-            !C +--Soil Minimum Humidity (from a prescribed minimum relative Humidity)
-            !C +  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-            Psimax = -(log(RHsMin)) / 7.2E-5        ! DR97, Eqn 3.15 Inversion
-            etamSV(ist) = etadSV(ist)                                      &
-                    & * (PsiMax / psidSV(ist))**(-min(10., 1. / bCHdSV(ist)))
-        END DO
-        etamSV(12) = 0.
-
-        !C +--Piecewise Hydraulic Conductivity Profiles
-        !C +  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-        DO   ist = 0, nsot
-
-            d__eta = etadSV(ist) / nkhy
-            eta__1 = 0.
-            eta__2 = d__eta
-            DO ikh = 0, nkhy
-                Khyd_1 = s2__SV(ist)             & ! DR97, Eqn.(3.35)
-                        & * (eta__1      **(2. * bCHdSV(ist) + 3.))        !
-                Khyd_2 = s2__SV(ist)             &!
-                        & * (eta__2      **(2. * bCHdSV(ist) + 3.))        !
-
-                a_Khyd = (Khyd_2 - Khyd_1) / d__eta   !
-                b_Khyd = Khyd_1 - a_Khyd * eta__1   !
-                !c #WR     Khyd_x          =  a_Khyd*eta__1 +b_Khyd   !
-                !c #WR     Khyd_y          =  a_Khyd*eta__2 +b_Khyd   !
-                aKdtSV(ist, ikh) = a_Khyd * dt__SV   !
-                bKdtSV(ist, ikh) = b_Khyd * dt__SV   !
-
-                eta__1 = eta__1 + d__eta
-                eta__2 = eta__2 + d__eta
-            END DO
-        END DO
-
-        return
-
-    END SUBROUTINE SISVAT_ini
-
-
-    !***************************************************************************
-
-    SUBROUTINE sisvatetat0 (fichnom, ikl2i)
-
-        USE dimphy
-        USE mod_grid_phy_lmdz
-        USE mod_phys_lmdz_para
-
-        USE iostart
-        USE VAR_SV
-        USE VARdSV
-        USE VARxSV
-        USE VARtSV
-        USE indice_sol_mod
-
-        IMPLICIT none
-        !======================================================================
-        ! Auteur(s) HJ PUNGE (LSCE) date: 07/2009
-        ! Objet: Lecture du fichier de conditions initiales pour SISVAT
-        !======================================================================
-        include "netcdf.inc"
-        !    include "indicesol.h"
-
-        !    include "dimsoil.h"
-        include "clesphys.h"
-        include "compbl.h"
-
-        !======================================================================
-        CHARACTER(LEN = *) :: fichnom
-
-        INTEGER, DIMENSION(klon), INTENT(IN) :: ikl2i
-        REAL, DIMENSION(klon) :: rlon
-        REAL, DIMENSION(klon) :: rlat
-
-        ! les variables globales ecrites dans le fichier restart
-        REAL, DIMENSION(klon) :: isno
-        REAL, DIMENSION(klon) :: ispi
-        REAL, DIMENSION(klon) :: iice
-        REAL, DIMENSION(klon) :: rusn
-        REAL, DIMENSION(klon, nsno) :: isto
-
-        REAL, DIMENSION(klon, nsismx) :: Tsis
-        REAL, DIMENSION(klon, nsismx) :: eta
-        REAL, DIMENSION(klon, nsismx) :: ro
-
-        REAL, DIMENSION(klon, nsno) :: dzsn
-        REAL, DIMENSION(klon, nsno) :: G1sn
-        REAL, DIMENSION(klon, nsno) :: G2sn
-        REAL, DIMENSION(klon, nsno) :: agsn
-
-        REAL, DIMENSION(klon) :: toic
-
-        INTEGER :: isl, ikl, i, isn, errT, erreta, errro, errdz, snopts
-        CHARACTER (len = 2) :: str2
-        LOGICAL :: found
-
-        errT = 0
-        errro = 0
-        erreta = 0
-        errdz = 0
-        snopts = 0
-        ! Ouvrir le fichier contenant l'etat initial:
-
-        CALL open_startphy(fichnom)
-
-        ! Lecture des latitudes, longitudes (coordonnees):
-
-        CALL get_field("latitude", rlat, found)
-        CALL get_field("longitude", rlon, found)
-
-        CALL get_field("n_snows", isno, found)
-        IF (.NOT. found) THEN
-            PRINT*, 'phyetat0: Le champ <n_snows> est absent'
-            PRINT *, 'fichier startsisvat non compatible avec sisvatetat0'
-        ENDIF
-
-        CALL get_field("n_ice_top", ispi, found)
-        CALL get_field("n_ice", iice, found)
-        CALL get_field("surf_water", rusn, found)
-
-
-        CALL get_field("to_ice", toic, found)
-        IF (.NOT. found) THEN
-            PRINT*, 'phyetat0: Le champ <to_ice> est absent'
-            toic(:) = 0.
-        ENDIF
-
-        DO isn = 1, nsno
-            IF (isn.LE.99) THEN
-                WRITE(str2, '(i2.2)') isn
-                CALL get_field("AGESNOW" // str2, &
-                        agsn(:, isn), found)
-            ELSE
-                PRINT*, "Trop de couches"
-                CALL abort
-            ENDIF
-        ENDDO
-        DO isn = 1, nsno
-            IF (isn.LE.99) THEN
-                WRITE(str2, '(i2.2)') isn
-                CALL get_field("DZSNOW" // str2, &
-                        dzsn(:, isn), found)
-            ELSE
-                PRINT*, "Trop de couches"
-                CALL abort
-            ENDIF
-        ENDDO
-        DO isn = 1, nsno
-            IF (isn.LE.99) THEN
-                WRITE(str2, '(i2.2)') isn
-                CALL get_field("G2SNOW" // str2, &
-                        G2sn(:, isn), found)
-            ELSE
-                PRINT*, "Trop de couches"
-                CALL abort
-            ENDIF
-        ENDDO
-        DO isn = 1, nsno
-            IF (isn.LE.99) THEN
-                WRITE(str2, '(i2.2)') isn
-                CALL get_field("G1SNOW" // str2, &
-                        G1sn(:, isn), found)
-            ELSE
-                PRINT*, "Trop de couches"
-                CALL abort
-            ENDIF
-        ENDDO
-        DO isn = 1, nsismx
-            IF (isn.LE.99) THEN
-                WRITE(str2, '(i2.2)') isn
-                CALL get_field("ETA" // str2, &
-                        eta(:, isn), found)
-            ELSE
-                PRINT*, "Trop de couches"
-                CALL abort
-            ENDIF
-        ENDDO
-        DO isn = 1, nsismx
-            IF (isn.LE.99) THEN
-                WRITE(str2, '(i2.2)') isn
-                CALL get_field("RO" // str2, &
-                        ro(:, isn), found)
-            ELSE
-                PRINT*, "Trop de couches"
-                CALL abort
-            ENDIF
-        ENDDO
-        DO isn = 1, nsismx
-            IF (isn.LE.99) THEN
-                WRITE(str2, '(i2.2)') isn
-                CALL get_field("TSS" // str2, &
-                        Tsis(:, isn), found)
-            ELSE
-                PRINT*, "Trop de couches"
-                CALL abort
-            ENDIF
-        ENDDO
-        DO isn = 1, nsno
-            IF (isn.LE.99) THEN
-                WRITE(str2, '(i2.2)') isn
-                CALL get_field("HISTORY" // str2, &
-                        isto(:, isn), found)
-            ELSE
-                PRINT*, "Trop de couches"
-                CALL abort
-            ENDIF
-        ENDDO
-        write(*, *)'Read ', fichnom, ' finished!!'
-
-        !*********************************************************************************
-        ! Compress restart file variables for SISVAT
-
-        DO  ikl = 1, klon
-            i = ikl2i(ikl)
-            IF (i > 0) THEN
-                isnoSV(ikl) = INT(isno(i))          ! Nb Snow/Ice Lay.
-                ispiSV(ikl) = INT(ispi(i))          ! Nb Supr.Ice Lay.
-                iiceSV(ikl) = INT(iice(i))          ! Nb      Ice Lay.
-
-                DO isl = -nsol, 0
-                    ro__SV(ikl, isl) = ro(i, nsno + 1 - isl)       !
-                    eta_SV(ikl, isl) = eta(i, nsno + 1 - isl)         ! Soil Humidity
-                    !hjp 15/10/2010
-                    IF (eta_SV(ikl, isl) <= 1.e-6) THEN          !hj check
-                        eta_SV(ikl, isl) = 1.e-6
-                    ENDIF
-                    TsisSV(ikl, isl) = Tsis(i, nsno + 1 - isl)        ! Soil Temperature
-                    IF (TsisSV(ikl, isl) <= 1.) THEN             !hj check
-                        !                errT=errT+1
-                        TsisSV(ikl, isl) = 273.15 - 0.2              ! Etienne: negative temperature since soil is ice
-                    ENDIF
-
-                END DO
-                write(*, *)'Copy histo', ikl
-
-                DO  isn = 1, isnoSV(ikl) !nsno
-                    snopts = snopts + 1
-                    IF (isto(i, isn) > 10.) THEN          !hj check
-                        write(*, *)'Irregular isto', ikl, i, isn, isto(i, isn)
-                        isto(i, isn) = 1.
-                    ENDIF
-
-                    istoSV(ikl, isn) = INT(isto(i, isn))     ! Snow     History
-                    ro__SV(ikl, isn) = ro(i, isn)            !        [kg/m3]
-                    eta_SV(ikl, isn) = eta(i, isn)           !        [m3/m3]
-                    TsisSV(ikl, isn) = Tsis(i, isn)          !            [K]
-
-                    IF (TsisSV(ikl, isn) <= 1.) THEN          !hj check
-                        errT = errT + 1
-                        TsisSV(ikl, isn) = TsisSV(ikl, 0)
-                    ENDIF
-                    IF (TsisSV(ikl, isn) <= 1.) THEN          !hj check
-                        TsisSV(ikl, isn) = 263.15
-                    ENDIF
-                    IF (eta_SV(ikl, isn) < 1.e-9) THEN          !hj check
-                        eta_SV(ikl, isn) = 1.e-6
-                        erreta = erreta + 1
-                    ENDIF
-                    IF (ro__SV(ikl, isn) <= 10.) THEN          !hj check
-                        ro__SV(ikl, isn) = 11.
-                        errro = errro + 1
-                    ENDIF
-                    write(*, *)ikl, i, isn, Tsis(i, isn), G1sn(i, isn)
-                    G1snSV(ikl, isn) = G1sn(i, isn)          ! [-]        [-]
-                    G2snSV(ikl, isn) = G2sn(i, isn)          ! [-] [0.0001 m]
-                    dzsnSV(ikl, isn) = dzsn(i, isn)          !            [m]
-                    agsnSV(ikl, isn) = agsn(i, isn)          !          [day]
-                END DO
-                rusnSV(ikl) = rusn(i)              ! Surficial Water
-                toicSV(ikl) = toic(i)              ! bilan snow to ice
-            END IF
-        END DO
-
-    END SUBROUTINE sisvatetat0
-
-
-    !======================================================================
-    SUBROUTINE sisvatredem (fichnom, ikl2i, rlon, rlat)
-
-
-
-        !======================================================================
-        ! Auteur(s) HJ PUNGE (LSCE) date: 07/2009
-        ! Objet: Ecriture de l'etat de redemarrage pour SISVAT
-        !======================================================================
-        USE mod_grid_phy_lmdz
-        USE mod_phys_lmdz_para
-        USE iostart
-        USE VAR_SV
-        USE VARxSV
-        USE VARySV !hj tmp 12 03 2010
-        USE VARtSV
-        USE indice_sol_mod
-        USE dimphy
-
-        IMPLICIT none
-
-        include "netcdf.inc"
-        include "clesphys.h"
-        include "compbl.h"
-
-        !======================================================================
-
-        CHARACTER(LEN = *) :: fichnom
-        INTEGER, DIMENSION(klon), INTENT(IN) :: ikl2i
-        REAL, DIMENSION(klon), INTENT(IN) :: rlon
-        REAL, DIMENSION(klon), INTENT(IN) :: rlat
-
-        ! les variables globales ecrites dans le fichier restart
-        REAL, DIMENSION(klon) :: isno
-        REAL, DIMENSION(klon) :: ispi
-        REAL, DIMENSION(klon) :: iice
-        REAL, DIMENSION(klon, nsnowmx) :: isto
-
-        REAL, DIMENSION(klon, nsismx) :: Tsis
-        REAL, DIMENSION(klon, nsismx) :: eta
-        REAL, DIMENSION(klon, nsnowmx) :: dzsn
-        REAL, DIMENSION(klon, nsismx) :: ro
-        REAL, DIMENSION(klon, nsnowmx) :: G1sn
-        REAL, DIMENSION(klon, nsnowmx) :: G2sn
-        REAL, DIMENSION(klon, nsnowmx) :: agsn
-        REAL, DIMENSION(klon) :: IRs
-        REAL, DIMENSION(klon) :: LMO
-        REAL, DIMENSION(klon) :: rusn
-        REAL, DIMENSION(klon) :: toic
-        REAL, DIMENSION(klon) :: Bufs
-        REAL, DIMENSION(klon) :: alb1, alb2, alb3
-
-        INTEGER isl, ikl, i, isn, ierr
-        CHARACTER (len = 2) :: str2
-        INTEGER :: pass
-
-        isno(:) = 0
-        ispi(:) = 0
-        iice(:) = 0
-        IRs(:) = 0.
-        LMO(:) = 0.
-        eta(:, :) = 0.
-        Tsis(:, :) = 0.
-        isto(:, :) = 0
-        ro(:, :) = 0.
-        G1sn(:, :) = 0.
-        G2sn(:, :) = 0.
-        dzsn(:, :) = 0.
-        agsn(:, :) = 0.
-        rusn(:) = 0.
-        toic(:) = 0.
-        Bufs(:) = 0.
-        alb1(:) = 0.
-        alb2(:) = 0.
-        alb3(:) = 0.
-
-        !***************************************************************************
-        ! Uncompress SISVAT output variables for storage
-
-        DO  ikl = 1, klon
-            i = ikl2i(ikl)
-            IF (i > 0) THEN
-                isno(i) = 1. * isnoSV(ikl)               ! Nb Snow/Ice Lay.
-                ispi(i) = 1. * ispiSV(ikl)               ! Nb Supr.Ice Lay.
-                iice(i) = 1. * iiceSV(ikl)               ! Nb      Ice Lay.
-
-                !        IRs(i)        = IRs_SV(ikl)
-                !        LMO(i)        = LMO_SV(ikl)
-
-                DO isl = -nsol, 0                           !
-                    eta(i, nsno + 1 - isl) = eta_SV(ikl, isl)            ! Soil Humidity
-                    Tsis(i, nsno + 1 - isl) = TsisSV(ikl, isl)            ! Soil Temperature
-                    ro(i, nsno + 1 - isl) = ro__SV(ikl, isl)            !        [kg/m3]
-                END DO
-
-                DO  isn = 1, nsno
-                    isto(i, isn) = 1. * istoSV(ikl, isn)         ! Snow     History
-                    ro(i, isn) = ro__SV(ikl, isn)            !        [kg/m3]
-                    eta(i, isn) = eta_SV(ikl, isn)            !        [m3/m3]
-                    Tsis(i, isn) = TsisSV(ikl, isn)            !            [K]
-                    G1sn(i, isn) = G1snSV(ikl, isn)            ! [-]        [-]
-                    G2sn(i, isn) = G2snSV(ikl, isn)            ! [-] [0.0001 m]
-                    dzsn(i, isn) = dzsnSV(ikl, isn)            !            [m]
-                    agsn(i, isn) = agsnSV(ikl, isn)            !          [day]
-                END DO
-                rusn(i) = rusnSV(ikl)                  ! Surficial Water
-                toic(i) = toicSV(ikl)                  ! to ice
-                alb1(i) = alb1sv(ikl)
-                alb2(i) = alb2sv(ikl)
-                alb3(i) = alb3sv(ikl)
-                !        Bufs(i)       = BufsSV(ikl)
-            END IF
-        END DO
-
-        CALL open_restartphy(fichnom)
-
-        DO pass = 1, 2
-            CALL put_field(pass, "longitude", &
-                    "Longitudes de la grille physique", rlon)
-            CALL put_field(pass, "latitude", "Latitudes de la grille physique", rlat)
-
-            CALL put_field(pass, "n_snows", "number of snow/ice layers", isno)
-            CALL put_field(pass, "n_ice_top", "number of top ice layers", ispi)
-            CALL put_field(pass, "n_ice", "number of ice layers", iice)
-            CALL put_field(pass, "IR_soil", "Soil IR flux", IRs)
-            CALL put_field(pass, "LMO", "Monin-Obukhov Scale", LMO)
-            CALL put_field(pass, "surf_water", "Surficial water", rusn)
-            CALL put_field(pass, "snow_buffer", "Snow buffer layer", Bufs)
-            CALL put_field(pass, "alb_1", "albedo sw", alb1)
-            CALL put_field(pass, "alb_2", "albedo nIR", alb2)
-            CALL put_field(pass, "alb_3", "albedo fIR", alb3)
-            CALL put_field(pass, "to_ice", "Snow passed to ice", toic)
-
-            DO isn = 1, nsno
-                IF (isn.LE.99) THEN
-                    WRITE(str2, '(i2.2)') isn
-                    CALL put_field(pass, "AGESNOW" // str2, &
-                            "Age de la neige layer No." // str2, &
-                            agsn(:, isn))
-                ELSE
-                    PRINT*, "Trop de couches"
-                    CALL abort
-                ENDIF
-            ENDDO
-            DO isn = 1, nsno
-                IF (isn.LE.99) THEN
-                    WRITE(str2, '(i2.2)') isn
-                    CALL put_field(pass, "DZSNOW" // str2, &
-                            "Snow/ice thickness layer No." // str2, &
-                            dzsn(:, isn))
-                ELSE
-                    PRINT*, "Trop de couches"
-                    CALL abort
-                ENDIF
-            ENDDO
-            DO isn = 1, nsno
-                IF (isn.LE.99) THEN
-                    WRITE(str2, '(i2.2)') isn
-                    CALL put_field(pass, "G2SNOW" // str2, &
-                            "Snow Property 2, layer No." // str2, &
-                            G2sn(:, isn))
-                ELSE
-                    PRINT*, "Trop de couches"
-                    CALL abort
-                ENDIF
-            ENDDO
-            DO isn = 1, nsno
-                IF (isn.LE.99) THEN
-                    WRITE(str2, '(i2.2)') isn
-                    CALL put_field(pass, "G1SNOW" // str2, &
-                            "Snow Property 1, layer No." // str2, &
-                            G1sn(:, isn))
-                ELSE
-                    PRINT*, "Trop de couches"
-                    CALL abort
-                ENDIF
-            ENDDO
-            DO isn = 1, nsismx
-                IF (isn.LE.99) THEN
-                    WRITE(str2, '(i2.2)') isn
-                    CALL put_field(pass, "ETA" // str2, &
-                            "Soil/snow water content layer No." // str2, &
-                            eta(:, isn))
-                ELSE
-                    PRINT*, "Trop de couches"
-                    CALL abort
-                ENDIF
-            ENDDO
-            DO isn = 1, nsismx   !nsno
-                IF (isn.LE.99) THEN
-                    WRITE(str2, '(i2.2)') isn
-                    CALL put_field(pass, "RO" // str2, &
-                            "Snow density layer No." // str2, &
-                            ro(:, isn))
-                ELSE
-                    PRINT*, "Trop de couches"
-                    CALL abort
-                ENDIF
-            ENDDO
-            DO isn = 1, nsismx
-                IF (isn.LE.99) THEN
-                    WRITE(str2, '(i2.2)') isn
-                    CALL put_field(pass, "TSS" // str2, &
-                            "Soil/snow temperature layer No." // str2, &
-                            Tsis(:, isn))
-                ELSE
-                    PRINT*, "Trop de couches"
-                    CALL abort
-                ENDIF
-            ENDDO
-            DO isn = 1, nsno
-                IF (isn.LE.99) THEN
-                    WRITE(str2, '(i2.2)') isn
-                    CALL put_field(pass, "HISTORY" // str2, &
-                            "Snow history layer No." // str2, &
-                            isto(:, isn))
-                ELSE
-                    PRINT*, "Trop de couches"
-                    CALL abort
-                ENDIF
-            ENDDO
-
-            CALL enddef_restartphy
-        ENDDO
-        CALL close_restartphy
-
-    END SUBROUTINE sisvatredem
-
-END MODULE surf_inlandsis_mod
Index: /LMDZ6/trunk/libf/phylmd/inlandsis/surf_inlandsis_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/inlandsis/surf_inlandsis_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/inlandsis/surf_inlandsis_mod.f90	(revision 5268)
@@ -0,0 +1,1495 @@
+MODULE surf_inlandsis_mod
+
+    IMPLICIT NONE
+
+CONTAINS
+
+
+SUBROUTINE surf_inlandsis(knon, rlon, rlat, ikl2i, itime, dtime, debut, lafin, &
+            rmu0, swdown, lwdown, albedo_old, pexner, ps, p1lay, &
+            precip_rain, precip_snow, &
+            zsl_height, wind_velo, ustar, temp_air, dens_air, spechum, tsurf, &
+            rugos, snow_cont_air, alb_soil, alt, slope, cloudf, &
+            radsol, qsol, tsoil, snow, zfra, snowhgt, qsnow, to_ice, sissnow, agesno, &
+            AcoefH, AcoefQ, BcoefH, BcoefQ, cdragm, cdragh, &
+            runoff_lic, fqfonte, ffonte, evap, erod, fluxsens, fluxlat, dflux_s,dflux_l, &
+            tsurf_new, alb1, alb2, alb3, alb6, emis_new, z0m, z0h, qsurf)
+
+        ! |                                                                        |
+        ! |   SubRoutine surf_inlandsis: Interfacing Lmdz AND Sisvat's Ice and Snow|
+        ! |                              (INLANDSIS)                               |
+        ! |   SISVAT (Soil/Ice Snow Vegetation Atmosphere Transfer Scheme)         |
+        ! |   surface scheme of the Modele Atmospherique Regional (MAR)            |
+        ! |   Author: Heinz Juergen Punge, LSCE                June 2009           |
+        ! |     based on the MAR-SISVAT interface by Hubert Gallee                 |
+        ! |   Updated by Etienne Vignon, Cecile Agosta                             |
+        ! |                                                                        |
+        ! +------------------------------------------------------------------------+
+        ! |
+        ! |   In the current setup, SISVAT is used only to model the land ice      |
+        ! |   part of the surface; hence it is called with the compressed variables|
+        ! |   from pbl_surface, and only by the surf_landice routine.              |
+        ! |                                                                        |
+        ! |   In this interface it is assumed that the partitioning of the soil,   |
+        ! |   and hence the number of grid points is constant during a simulation, |
+        ! |   hence eg. snow properties remain stored in the global SISVAT         |
+        ! |   variables between the calls and don't need to be handed over as      |
+        ! |   arguments. When the partitioning is supposed to change, make sure to |
+        ! |   update the variables.                                                |
+        ! |                                                                        |
+        ! |   INPUT    (via MODULES VARxSV, VARySV, VARtSV ...)                    |
+        ! |   ^^^^^     xxxxSV: SISVAT/LMDZ interfacing variables                  |
+        ! |                                                                        |
+        ! +------------------------------------------------------------------------+
+
+        USE dimphy
+        USE VAR_SV
+        USE VARdSV
+        USE VARxSV
+        USE VARySV
+        USE VARtSV
+        USE VARphy
+        USE surface_data, only : iflag_tsurf_inlandsis, SnoMod, BloMod, ok_outfor
+
+        IMPLICIT NONE
+
+        ! +--INTERFACE Variables
+        ! +  ===================
+        !    include  "dimsoil.h"
+
+        ! +--Global Variables
+        ! +  ================
+        ! Input Variables for SISVAT
+        INTEGER, INTENT(IN) :: knon
+        INTEGER, INTENT(IN) :: itime
+        REAL, INTENT(IN) :: dtime
+        LOGICAL, INTENT(IN) :: debut     ! true if first step
+        LOGICAL, INTENT(IN) :: lafin     ! true if last step
+
+        INTEGER, DIMENSION(klon), INTENT(IN) :: ikl2i     ! Index Decompression
+        REAL, DIMENSION(klon), INTENT(IN) :: rlon, rlat
+        REAL, DIMENSION(klon), INTENT(IN) :: rmu0      ! cos sol. zenith angle
+        REAL, DIMENSION(klon), INTENT(IN) :: swdown    !
+        REAL, DIMENSION(klon), INTENT(IN) :: lwdown    !
+        REAL, DIMENSION(klon), INTENT(IN) :: albedo_old
+        REAL, DIMENSION(klon), INTENT(IN) :: pexner    ! Exner potential
+        REAL, DIMENSION(klon), INTENT(IN) :: precip_rain, precip_snow
+        REAL, DIMENSION(klon), INTENT(IN) :: zsl_height, wind_velo
+        REAL, DIMENSION(klon), INTENT(IN) :: temp_air, spechum, ps, p1lay
+        REAL, DIMENSION(klon), INTENT(IN) :: dens_air, tsurf
+        REAL, DIMENSION(klon), INTENT(IN) :: rugos
+        REAL, DIMENSION(klon), INTENT(IN) :: snow_cont_air
+        REAL, DIMENSION(klon), INTENT(IN) :: alb_soil, slope
+        REAL, DIMENSION(klon), INTENT(IN) :: alt       ! surface elevation
+        REAL, DIMENSION(klon), INTENT(IN) :: cloudf
+        REAL, DIMENSION(klon), INTENT(IN) :: AcoefH, AcoefQ
+        REAL, DIMENSION(klon), INTENT(IN) :: BcoefH, BcoefQ
+        REAL, DIMENSION(klon), INTENT(IN) :: cdragm, cdragh
+        REAL, DIMENSION(klon), INTENT(IN) :: ustar   ! friction velocity
+
+        ! Variables exchanged between LMDZ and SISVAT
+        REAL, DIMENSION(klon), INTENT(IN) :: radsol    ! Surface absorbed rad.
+        REAL, DIMENSION(klon), INTENT(INOUT) :: snow      ! Tot snow mass [kg/m2]
+        REAL, DIMENSION(klon), INTENT(INOUT) :: zfra      ! snwo surface fraction [0-1]
+        REAL, DIMENSION(klon, nsoilmx), INTENT(OUT) :: tsoil ! Soil Temperature
+        REAL, DIMENSION(klon), INTENT(OUT) :: qsol      ! Soil Water Content
+        REAL, DIMENSION(klon), INTENT(INOUT) :: z0m    ! Momentum Roughn Lgt
+        REAL, DIMENSION(klon), INTENT(INOUT) :: z0h    ! Momentum Roughn Lgt
+
+        ! Output Variables for LMDZ
+        REAL, DIMENSION(klon), INTENT(OUT) :: alb1      ! Albedo SW
+        REAL, DIMENSION(klon), INTENT(OUT) :: alb2, alb3 ! Albedo NIR and LW
+        REAL, DIMENSION(klon,6), INTENT(OUT) :: alb6 ! 6 band Albedo
+        REAL, DIMENSION(klon), INTENT(OUT) :: emis_new  ! Surface Emissivity
+        REAL, DIMENSION(klon), INTENT(OUT) :: runoff_lic ! Runoff
+        REAL, DIMENSION(klon), INTENT(OUT) :: ffonte    ! enthalpy flux due to surface melting
+        REAL, DIMENSION(klon), INTENT(OUT) :: fqfonte   ! water flux due to surface melting
+        REAL, DIMENSION(klon), INTENT(OUT) :: dflux_s   ! d/dT sens. ht flux
+        REAL, DIMENSION(klon), INTENT(OUT) :: dflux_l   ! d/dT latent ht flux
+        REAL, DIMENSION(klon), INTENT(OUT) :: fluxsens  ! Sensible ht flux
+        REAL, DIMENSION(klon), INTENT(OUT) :: fluxlat   ! Latent heat flux
+        REAL, DIMENSION(klon), INTENT(OUT) :: evap      ! Evaporation
+        REAL, DIMENSION(klon), INTENT(OUT) :: erod      ! Erosion of surface snow (flux)
+        REAL, DIMENSION(klon), INTENT(OUT) :: agesno    ! Snow age (top layer)
+        REAL, DIMENSION(klon), INTENT(OUT) :: tsurf_new ! Surface Temperature
+        REAL, DIMENSION(klon), INTENT(OUT) :: qsurf     ! Surface Humidity
+
+        ! Specific INLANDIS outputs
+        REAL, DIMENSION(klon), INTENT(OUT) :: qsnow     ! Total H2O snow[kg/m2]
+        REAL, DIMENSION(klon), INTENT(OUT) :: snowhgt   ! Snow height (m)
+        REAL, DIMENSION(klon), INTENT(OUT) :: to_ice    ! Snow passed to ice
+        REAL, DIMENSION(klon), INTENT(OUT) :: sissnow   ! Snow in model (kg/m2)
+
+        ! +--Internal  Variables
+        ! +  ===================
+
+        CHARACTER(len = 20) :: fn_outfor ! Name for output file
+        CHARACTER (len = 80)              :: abort_message
+        CHARACTER (len = 20)              :: modname = 'surf_inlandsis_mod'
+
+        INTEGER :: i, ig, ikl, isl, isn, nt
+        INTEGER :: gp_outfor, un_outfor
+        REAL, PARAMETER :: f1 = 0.5
+        REAL, PARAMETER :: sn_upp = 10000., sn_low = 500.
+        REAL, PARAMETER :: sn_add = 400., sn_div = 2.
+        ! snow mass upper,lower limit,
+        ! added mass/division lowest layer
+        REAL, PARAMETER :: c1_zuo = 12.960e+4, c2_zuo = 2.160e+6
+        REAL, PARAMETER :: c3_zuo = 1.400e+2, czemin = 1.e-3
+        ! Parameters for drainage
+        ! c1_zuo/ 2.796e+4/,c2_zuo/2.160e+6/,c3_zuo/1.400e+2/ !     Tuning
+        ! +...        Run Off Parameters
+        ! +           86400*1.5 day     ...*25 days (Modif. ETH Camp: 86400*0.3day)
+        ! +           (Zuo and Oerlemans 1996, J.Glacio. 42, 305--317)
+
+        REAL, DIMENSION(klon) :: eps0SL          ! surface Emissivity
+        REAL :: zsigma, Ua_min, Us_min, lati
+        REAL, PARAMETER :: cdmax=0.05
+        REAL :: lambda          ! Par. soil discret.
+        REAL, DIMENSION(nsoilmx), SAVE :: dz1, dz2         ! Soil layer thicknesses
+        !$OMP THREADPRIVATE(dz1,dz2)
+        LOGICAL, SAVE :: firstcall
+        !$OMP THREADPRIVATE(firstcall)
+
+        INTEGER :: iso
+        LOGICAL :: file_exists
+        CHARACTER(len = 20) :: fichnom
+        LOGICAL :: is_init_domec
+        ! CA initialization
+        ! dz_profil_15 : 1 m in 15 layers [m]
+        real, parameter :: dz_profil_15(15) = (/0.005, 0.01, 0.015, 0.02, 0.03, 0.04, 0.05, &
+                                                0.06, 0.07, 0.08, 0.09, 0.1, 0.12, 0.14, 0.17/)
+        ! mean_temp : mean annual surface temperature [K]
+        real, dimension(klon) :: mean_temp
+        ! mean_dens : mean surface density [kg/m3]
+        real, dimension(klon) :: mean_dens
+        ! lat_scale : temperature lapse rate against latitude [K degree-1]
+        real :: lat_scale
+        ! sh_scale : temperature lapse rate against altitude [K km-1]
+        real :: sh_scale
+        ! variables for density profile
+        ! E0, E1 : exponent
+        real :: E0, E1
+        ! depth at which 550 kg m-3 is reached [m]
+        real :: z550
+        ! depths of snow layers
+        real :: depth, snow_depth, distup
+        ! number of initial snow layers
+        integer :: nb_snow_layer
+        ! For density calc.
+        real :: alpha0, alpha1, ln_smb
+        ! theoritical densities [kg m-3]
+        real :: rho0, rho1, rho1_550
+        ! constants for density profile
+        ! C0, C1 : constant, 0.07 for z <= 550 kg m-3
+        real, parameter :: C0 = 0.07
+        real, parameter :: C1 = 0.03
+        ! rho_i : ice density [kg m-3]
+        real, parameter :: rho_ice = 917.
+        ! E_c : activation energy [J mol-1]
+        real, parameter :: E_c = 60000.
+        ! E_g : activation energy [J mol-1]
+        real, parameter :: E_g = 42400.
+        ! R : gas constant [J mol-1 K-1]
+        real, parameter :: R = 8.3144621
+
+      
+     
+
+
+        ! + PROGRAM START
+        ! + -----------------------------------------
+
+        zsigma = 1000.
+        dt__SV = dtime
+
+        IF (debut) THEN
+            firstcall = .TRUE.
+            INI_SV = .false.
+        ELSE
+            firstcall = .false.
+            INI_SV = .true.
+        END IF
+
+        IF (ok_outfor) THEN
+            un_outfor = 51    ! unit number for point output file
+            gp_outfor = 1    ! grid point number for point output 1 for 1D, 273 for zoom-nudg DC
+            fn_outfor = 'outfor_SV.dat'
+        END IF
+
+        ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+        ! + INITIALISATION: BEGIN +++
+        ! + -----------------------------------------
+        IF (firstcall) THEN
+
+            ! +--Array size
+            ! +  -----------------------
+
+            klonv = klon
+            knonv = knon
+                write(*, *) 'ikl, lon and lat in INLANDSIS'
+
+            DO ikl = 1, knon
+                i=ikl2i(ikl)
+                write(*, *) 'ikl=', ikl, 'rlon=', rlon(i), 'rlat=', rlat(i)
+            END DO
+
+            ! +--Variables initizialisation
+            ! +  ---------------------------
+
+            CALL INIT_VARtSV
+            CALL INIT_VARxSV
+            CALL INIT_VARySV
+
+
+
+            ! +--Surface Fall Line Slope
+            ! +  -----------------------
+            IF (SnoMod)  THEN
+                DO ikl = 1, knon
+                    slopSV(ikl) = slope(ikl)
+                    SWf_SV(ikl) = &   ! Normalized Decay of the
+                            exp(-dt__SV             &   ! Surficial Water Content
+                                    / (c1_zuo                &   !(Zuo and Oerlemans 1996,
+                                            + c2_zuo * exp(-c3_zuo * abs(slopSV(ikl)))))  ! J.Glacio. 42, 305--317)
+                END DO
+            END IF
+
+
+
+            ! +--Soil layer thickness . Compute soil discretization (as for LMDZ)
+            ! +  ----------------------------------------------------------------
+            !        write(*,'(/a)') 'Start SISVAT init: soil discretization ', nsoilmx
+            CALL get_soil_levels(dz1, dz2, lambda)
+
+            lambSV = lambda
+            dz1_SV(1:knon, 1:) = 0.
+            dz2_SV(1:knon, 1:) = 0.
+
+            DO isl = -nsol, 0
+                dz_dSV(isl) = 0.5e-3 * dz2(1 - isl)           ! Soil layer thickness
+                DO ikl = 1, knon
+                    dz1_SV(ikl, isl) = dz1(1 - isl)    !1.e-3*
+                    dz2_SV(ikl, isl) = dz2(1 - isl)    !1.e-3*
+                END DO
+            END DO
+
+
+            ! Set variables
+            ! =============
+            DO ikl = 1, knon
+                ! LSmask : Land/Sea Mask
+                LSmask(ikl) = 1
+                ! isotSV : Soil Type -> 12 = ice
+                isotSV(ikl) = 12
+                ! iWaFSV : Soil Drainage (1,0)=(y,n)
+                iWaFSV(ikl) = 1
+                ! eps0SL : Surface Emissivity
+                eps0SL(ikl) = 1.
+                ! alb0SV : Soil Albedo
+                alb0SV(ikl) = alb_soil(ikl)
+                ! Tsf_SV : Surface Temperature, must be bellow freezing
+                Tsf_SV(ikl) = min(temp_air(ikl), TfSnow)
+            END DO
+
+            ! +--Initialization of soil and snow variables in case startsis is not read
+            ! +  ----------------------------------------------------------------------
+
+            is_init_domec=.FALSE.
+
+
+            IF (is_init_domec) THEN
+            ! Coarse initilization inspired from vertcical profiles at Dome C,
+            ! Antarctic Plateaui (10m of snow, 19 levels)
+
+                 DO ikl = 1,knon
+! + Soil
+                 DO isl =   -nsol,0    
+                   TsisSV(ikl,isl) = min(tsoil(ikl,1+nsol),TfSnow-0.2)   !temp_air(ikl)
+                   !tsoil(ikl,1-isl)   Soil Temperature
+                   !TsisSV(ikl,isl) = min(temp_air(ikl),TfSnow-0.2)
+                   eta_SV(ikl,isl) = epsi           !etasoil(ikl,1-isl) Soil Water[m3/m3]
+                   ro__SV(ikl,isl) = rhoIce         !rosoil(ikl,1-isl) volumic mass
+                 END DO   
+
+
+           ! Snow
+                 isnoSV(ikl) = 19
+                 istoSV(ikl, 1:isnoSV(ikl)) = 100
+                 ro__SV(ikl, 1:isnoSV(ikl)) = 350.
+                 eta_SV(ikl, 1:isnoSV(ikl)) = epsi
+                 TsisSV(ikl, 1:isnoSV(ikl)) = min(tsoil(ikl, 1), TfSnow - 0.2)
+                 G1snSV(ikl, 1:isnoSV(ikl)) = 99.
+                 G2snSV(ikl, 1:isnoSV(ikl)) = 2.
+                 agsnSV(ikl, 1:isnoSV(ikl)) = 50.
+                 dzsnSV(ikl, 19) = 0.015
+                 dzsnSV(ikl, 18) = 0.015
+                 dzsnSV(ikl, 17) = 0.020
+                 dzsnSV(ikl, 16) = 0.030
+                 dzsnSV(ikl, 15) = 0.040
+                 dzsnSV(ikl, 14) = 0.060
+                 dzsnSV(ikl, 13) = 0.080
+                 dzsnSV(ikl, 12) = 0.110
+                 dzsnSV(ikl, 11) = 0.150
+                 dzsnSV(ikl, 10) = 0.200
+                 dzsnSV(ikl, 9) = 0.300
+                 dzsnSV(ikl, 8) = 0.420
+                 dzsnSV(ikl, 7) = 0.780
+                 dzsnSV(ikl, 6) = 1.020
+                 dzsnSV(ikl, 5) = 0.980
+                 dzsnSV(ikl, 4) = 1.020
+                 dzsnSV(ikl, 3) = 3.970
+                 dzsnSV(ikl, 2) = 1.020
+                 dzsnSV(ikl, 1) = 1.020
+
+                 END DO
+            ELSE
+
+            ! Initilialisation with climatological temperature and density
+            ! profiles as in MAR. Methodology developed by Cecile Agosta
+  
+            ! initialize with 0., for unused snow layers
+            dzsnSV = 0.
+            G1snSV = 0.
+            G2snSV = 0.
+            istoSV = 0
+            TsisSV = 0.
+
+
+            ! initialize mean variables (unrealistic)
+            mean_temp = TfSnow
+            mean_dens = 300.
+            ! loop on grid cells
+            DO ikl = 1, knon
+            	lati=rlat(ikl2i(ikl))
+                ! approximations for mean_temp and mean_dens
+                ! from Feulner et al., 2013 (DOI: 10.1175/JCLI-D-12-00636.1)
+                ! Fig. 3 and 5 : the lapse rate vs. latitude at high latitude is about 0.55 °C °lat-1
+                ! with a moist-adiabatic lapse rate of 5 °C km-1 everywhere except for Antarctica,
+                ! for Antarctica, a dry-adiabatic lapse rate of 9.8 °C km-1 is assumed.
+                if (lati > 60.) then
+                    ! CA todo : add longitude bounds
+                    ! Greenland mean temperature : function of altitude and latitude
+                    ! for altitudes 0. to 1000. m, lat_scale varies from 0.9 to 0.75 °C °lat-1
+                    lat_scale = (0.75 - 0.9) / 1000. * alt(ikl) + 0.9
+                    lat_scale = max(min(lat_scale, 0.9), 0.75)
+                    ! sh_scale equals the environmental lapse rate : 6.5 °C km-1
+                    sh_scale = 6.5
+                    mean_temp(ikl) = TfSnow + 1.5 - sh_scale * alt(ikl) / 1000. - lat_scale * (lati - 60.)
+                    ! surface density: Fausto et al. 2018, https://doi.org/10.3389/feart.2018.00051
+                    mean_dens(ikl) = 315.
+                else if (lati < -60.) then
+                    ! Antarctica mean temperature : function of altitude and latitude
+                    ! for altitudes 0. to 500. m, lat_scale varies from 1.3 to 0.6 °C °lat-1
+                    lat_scale = (0.6 - 1.3) / 500. * alt(ikl) + 1.3
+                    lat_scale = max(min(lat_scale, 1.3), 0.6)
+                    ! for altitudes 0. to 500. m, sh_scale varies from 6.5 to 9.8 °C km-1
+                    sh_scale = (9.8 - 6.5) / 500. * alt(ikl) + 6.5
+                    sh_scale = max(min(sh_scale, 9.8), 6.5)
+                    mean_temp(ikl) = TfSnow - 7. - sh_scale * alt(ikl) / 1000. + lat_scale * (lati + 60.)
+                    ! Antarctica surface density : function of mean annual temperature
+                    ! surface density of 350. kg m-3 at Dome C and 450. kg m-3 at Prud'homme (Agosta et al. 2013)
+                    ! 350 kg m-3 is a typical value for the Antarctic plateau around 3200 m.
+                    ! Weinhart et al 2020  https://doi.org/10.5194/tc-14-3663-2020 and Sugiyama et al. 2011 oi: 10.3189/2012JoG11J201
+                    ! 320 kg m-3 is reached at Dome A, 4100 m a.s.l.
+                    ! Dome C : st_ant_param(3233, -75.1) = -47.7
+                    ! Dumont d'Urville : st_ant_param(0, -66.66) = -15.7
+                    mean_dens(ikl) =  (450. - 320.) / (-15.7 + 47.7) * (mean_temp(ikl) - TfSnow + 15.7) + 450.
+                    mean_dens(ikl) = min(450., max(320., mean_dens(ikl)))
+                else
+
+                !    write(*, *) 'Attention: temperature initialization is only defined for Greenland and Antarctica'
+
+                     mean_dens(ikl) =350.
+                     mean_temp(ikl) = min(tsoil(ikl,1),TfSnow-0.2)
+
+                !abort_message='temperature initialization is only defined for Greenland and Antarctica'
+                !CALL abort_physic(modname,abort_message,1)
+
+                end if
+ 
+                ! mean_temp is defined for ice ground only
+                mean_temp(ikl) = min(mean_temp(ikl), TfSnow - 0.2)
+
+                ! Soil layers
+                ! ===========
+                DO isl = -nsol, 0
+                    ! TsisSV : Temperature [K]
+                    TsisSV(ikl, isl) = mean_temp(ikl)
+                    ! eta_SV : Soil Water [m3/m3]
+                    eta_SV(ikl, isl) = epsi
+                    ! ro__SV : Volumic Mass [kg/m3]
+                    ro__SV(ikl, isl) = rhoIce
+                END DO
+
+                ! Snow layers
+                ! ===========
+                ! snow_depth : initial snow depth
+                snow_depth = 20.
+                ! nb_snow_layer : initial nb of snow layers
+                nb_snow_layer = 15
+                ! isnoSV : total nb of snow layers
+                isnoSV(ikl) = nb_snow_layer
+                ! depth : depth of each layer
+                depth = snow_depth
+                do isl = 1, nb_snow_layer
+                    ! dzsnSV : snow layer thickness
+                    dzsnSV(ikl, isl) = max(0.01, snow_depth * dz_profil_15(nb_snow_layer - isl + 1))
+                    ! G1snSV : dendricity (<0) or sphericity (>0) : 99. = sperical
+                    G1snSV(ikl, isl) = 99.
+                    ! G2snSV : Sphericity (>0) or Size [1/10 mm] : 2. = small grain size
+                    G2snSV(ikl, isl) = 3.
+                    agsnSV(ikl, isl) = 0.
+                    istoSV(ikl, isl) = 0
+                    ! eta_SV : Liquid Water Content [m3/m3]
+                    eta_SV(ikl, isl) = 0.
+                    ! distance to surface
+                    depth = depth - dzsnSV(ikl,isl) / 2.
+                    distup = min(1., max(0., depth / snow_depth))
+                    ! TsisSV : Temperature [K], square interpolation between Tsf_SV (surface) and mean_temp (bottom)
+                    TsisSV(ikl, isl) = Tsf_SV(ikl) * (1. - distup**2) + mean_temp(ikl) * distup**2
+                    ! firn density : densification formulas from :
+                    ! Ligtenberg et al 2011 eq. (6) (www.the-cryosphere.net/5/809/2011/)
+                    ! equivalent to Arthern et al. 2010 eq. (4) "Nabarro-Herring" (doi:10.1029/2009JF001306)
+                    ! Integration of the steady state equation
+                    ! ln_smb approximated as a function of temperature
+                    ln_smb = max((mean_temp(ikl) - TfSnow) * 5. / 60. + 8., 3.)
+                    ! alpha0, alpha1 : correction coefficient as a function of ln_SMB from Ligtenberg 2011, adjusted for alpha1
+                    alpha0 = max(1.435 - 0.151 * ln_smb, 0.25)
+                    alpha1 = max(2.0111 - 0.2051 * ln_smb, 0.25)
+                    E0 = C0 * gravit * exp((E_g - E_c)/(R * mean_temp(ikl))) * rho_ice * alpha0
+                    E1 = C1 * gravit * exp((E_g - E_c)/(R * mean_temp(ikl))) * rho_ice * alpha1
+                    z550 = log((rho_ice/mean_dens(ikl) - 1.)/(rho_ice/550. - 1.)) / E0
+                    rho0 = exp(E0 * depth) / (rho_ice / mean_dens(ikl) - 1 + exp(E0 * depth)) * rho_ice
+                    rho1 = exp(E1 * depth) / (rho_ice / mean_dens(ikl) - 1 + exp(E1 * depth)) * rho_ice
+                    if (depth <= z550) then
+                        ro__SV(ikl, isl) = exp(E0 * depth) / (rho_ice / mean_dens(ikl) - 1 + exp(E0 * depth)) * rho_ice
+                    else
+                        ro__SV(ikl, isl) = exp(E1 * (depth - z550)) / (rho_ice / 550. - 1 + exp(E1 * (depth - z550))) * rho_ice
+                    end if
+                    depth = depth - dzsnSV(ikl,isl) / 2.
+                    
+                end do
+
+            END DO
+
+            END IF
+
+
+            ! + Numerics paramaters, SISVAT_ini 
+            ! +  ----------------------
+            CALL SISVAT_ini(knon)
+
+
+            ! +--Read restart file
+            ! +  =================================================
+
+            INQUIRE(FILE = "startsis.nc", EXIST = file_exists)
+            IF (file_exists) THEN
+                CALL sisvatetat0("startsis.nc", ikl2i)
+            END IF
+
+
+
+            ! +--Output ascii file
+            ! +  =================================================
+
+            ! open output file
+            IF (ok_outfor) THEN
+                open(unit = un_outfor, status = 'replace', file = fn_outfor)
+                ikl = gp_outfor     ! index sur la grille land ice
+                write(un_outfor, *) fn_outfor, ikl, dt__SV, rlon(ikl2i(ikl)), rlat(ikl2i(ikl))
+                write(un_outfor, *) 'nsnow - albedo - z0m - z0h , dz [m,30], temp [K,41], rho [kg/m3,41], eta [kg/kg,41] &
+                        & G1 [-,30], G2 [-,30], agesnow [d,30], history [-,30], DOP [m,30]'
+            END IF
+
+        END IF  ! firstcall
+        ! +
+        ! +  +++  INITIALISATION:  END  +++
+        ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+
+        ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+        ! + READ FORCINGS
+        ! + ------------------------
+
+        ! + Update Forcings for SISVAT given by the LMDZ model.
+        ! +
+        DO ikl = 1, knon
+
+            ! +--Atmospheric Forcing                                    (INPUT)
+            ! +  ^^^^^^^^^^^^^^^^^^^                                     ^^^^^
+            za__SV(ikl) = zsl_height(ikl)               ! surface layer height (fisr model level) [m]
+            Ua_min = 0.2 * sqrt(za__SV(ikl))            !
+            VV__SV(ikl) = max(Ua_min, wind_velo(ikl))   ! Wind velocity       [m/s]
+            TaT_SV(ikl) = temp_air(ikl)                 ! BL top Temperature    [K]
+            ExnrSV(ikl) = pexner(ikl)                   ! Exner potential
+            rhT_SV(ikl) = dens_air(ikl)                 ! Air density
+            QaT_SV(ikl) = spechum(ikl)                  ! Specific humidity
+            ps__SV(ikl) = ps(ikl)                       ! surface pressure     [Pa]
+            p1l_SV(ikl) = p1lay(ikl)                    ! lowest atm. layer press[Pa]
+
+            ! +--Surface properties
+            ! +  ^^^^^^^^^^^^^^^^^^
+
+            Z0m_SV(ikl) = z0m(ikl)                      ! Moment.Roughn.L.
+            Z0h_SV(ikl) = z0h(ikl)                      ! Moment.Roughn.L.
+
+            ! +--Energy Fluxes                                          (INPUT)
+            ! +  ^^^^^^^^^^^^^                                           ^^^^^
+            coszSV(ikl) = max(czemin, rmu0(ikl))         ! cos(zenith.Dist.)
+            sol_SV(ikl) = swdown(ikl)                   ! downward Solar
+            IRd_SV(ikl) = lwdown(ikl)                   ! downward IR
+            rsolSV(ikl) = radsol(ikl)                   ! surface absorbed rad.
+
+            ! +--Water  Fluxes                                          (INPUT)
+            ! +  ^^^^^^^^^^^^^                                           ^^^^^
+            drr_SV(ikl) = precip_rain(ikl)              ! Rain fall rate  [kg/m2/s]
+            dsn_SV(ikl) = precip_snow(ikl)              ! Snow fall rate  [kg/m2/s]
+
+            ! #BS    dbs_SV(ikl) = blowSN(i,j,n)
+            ! dbs_SV = Maximum potential erosion amount [kg/m2]
+            ! => Upper bound for eroded snow mass
+            !        uss_SV(ikl) = SLussl(i,j,n) ! u*qs* (only for Tv in sisvatesbl.f)
+            ! #BS  if(dsn_SV(ikl)>eps12.and.erprev(i,j,n).gt.eps9) then
+            ! #BS    dsnbSV(ikl) =1.0-min(qsHY(i,j,kB)     !BS neglib. at kb ~100 magl)
+            ! #BS.                        /max(qshy(i,j,mz),eps9),unun)
+            ! #BS    dsnbSV(ikl) = max(dsnbSV(ikl),erprev(i,j,n)/dsn_SV(ikl))
+            ! #BS    dsnbSV(ikl) = max(0.,min(1.,dsnbSV(ikl)))
+            ! #BS  else
+            ! #BS    dsnbSV(ikl) = 0.
+            ! #BS  endif
+            !      dsnbSV is the drift fraction of deposited snow updated in sisvat.f
+            !      will be used for characterizing the Buffer Layer
+            !      (see update of  Bros_N, G1same, G2same, zroOLD, zroNEW)
+            ! #BS  if(n==1) qbs_HY(i,j) = dsnbSV(ikl)
+            qsnoSV(ikl) = snow_cont_air(ikl)
+
+
+
+            ! +--Soil/BL                                      (INPUT)
+            ! +  ^^^^^^^                                       ^^^^^
+            alb0SV(ikl) = alb_soil(ikl)                 ! Soil background Albedo
+            AcoHSV(ikl) = AcoefH(ikl)
+            BcoHSV(ikl) = BcoefH(ikl)
+            AcoQSV(ikl) = AcoefQ(ikl)
+            BcoQSV(ikl) = BcoefQ(ikl)
+            cdH_SV(ikl) = min(cdragh(ikl),cdmax)
+            cdM_SV(ikl) = min(cdragm(ikl),cdmax)
+            rcdmSV(ikl) = sqrt(cdM_SV(ikl))
+            Us_min = 0.01
+            us__SV(ikl) = max(Us_min, ustar(ikl))
+            ram_sv(ikl) = 1. / (cdM_SV(ikl) * max(VV__SV(ikl), eps6))
+            rah_sv(ikl) = 1. / (cdH_SV(ikl) * max(VV__SV(ikl), eps6))
+
+            ! +--Energy Fluxes                                          (INPUT/OUTPUT)
+            ! +  ^^^^^^^^^^^^^                                           ^^^^^^^^^^^^
+            !IF (.not.firstcall) THEN
+            Tsrfsv(ikl)  = tsurf(ikl)                     !hj 12 03 2010
+            cld_SV(ikl) = cloudf(ikl)                    ! Cloudiness
+            !END IF
+
+         END DO
+
+        !
+        ! +  +++  READ FORCINGS:  END  +++
+        ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+ 
+
+        ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+        ! +--SISVAT EXECUTION
+        ! +  ----------------
+
+        call  INLANDSIS(SnoMod, BloMod, 1)
+
+
+       
+        ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+        ! + RETURN RESULTS
+        ! + --------------
+        ! + Return (compressed) SISVAT variables to LMDZ
+        ! +
+        DO  ikl = 1, knon                  ! use only 1:knon (actual ice sheet..)
+            dflux_s(ikl) = dSdTSV(ikl)         ! Sens.H.Flux T-Der.
+            dflux_l(ikl) = dLdTSV(ikl)         ! Latn.H.Flux T-Der.
+            fluxsens(ikl) = HSs_sv(ikl)         ! HS
+            fluxlat(ikl) = HLs_sv(ikl)         ! HL
+            evap(ikl) = -1*HLs_sv(ikl) / LHvH2O  ! Evaporation
+            erod(ikl) = 0.
+
+            IF (BloMod) THEN
+                ! + Blowing snow
+
+                !       SLussl(i,j,n)= 0.
+                ! #BS   SLussl(i,j,n)=                     !Effective erosion
+                ! #BS. (- dbs_ER(ikl))/(dt*rhT_SV(ikl))    !~u*qs* from previous time step
+                ! #BS   blowSN(i,j,n)=  dt*uss_SV(ikl)     !New max. pot. Erosion [kg/m2]
+                ! #BS.                    *rhT_SV(ikl)     !(further bounded in sisvat_bsn.f)
+                ! #BS  erprev(i,j,n) =     dbs_Er(ikl)/dt__SV
+                erod(ikl) = dbs_Er(ikl) / dt__SV
+            ENDIF
+
+            ! +   Check snow thickness,  substract if too thick, add if too thin
+
+            sissnow(ikl) = 0.  !()
+            DO  isn = 1, isnoSV(ikl)
+                sissnow(ikl) = sissnow(ikl) + dzsnSV(ikl, isn) * ro__SV(ikl, isn)
+            END DO
+
+            IF (sissnow(ikl) .LE. sn_low) THEN  !add snow
+                IF (isnoSV(ikl).GE.1) THEN
+                    dzsnSV(ikl, 1) = dzsnSV(ikl, 1) + sn_add / max(ro__SV(ikl, 1), epsi)
+                    toicSV(ikl) = toicSV(ikl) - sn_add
+                ELSE
+                    write(*, *) 'Attention, bare ice... point ', ikl
+                    isnoSV(ikl) = 1
+                    istoSV(ikl, 1) = 0
+                    ro__SV(ikl, 1) = 350.
+                    dzsnSV(ikl, 1) = sn_add / max(ro__SV(ikl, 1), epsi)  ! 1.
+                    eta_SV(ikl, 1) = epsi
+                    TsisSV(ikl, 1) = min(TsisSV(ikl, 0), TfSnow - 0.2)
+                    G1snSV(ikl, 1) = 0.
+                    G2snSV(ikl, 1) = 0.3
+                    agsnSV(ikl, 1) = 10.
+                    toicSV(ikl) = toicSV(ikl) - sn_add
+                END IF
+            END IF
+
+            IF (sissnow(ikl) .ge. sn_upp) THEN  !thinnen snow layer below
+                dzsnSV(ikl, 1) = dzsnSV(ikl, 1) / sn_div
+                toicSV(ikl) = toicSV(ikl) + dzsnSV(ikl, 1) * ro__SV(ikl, 1) / sn_div
+            END IF
+
+            sissnow(ikl) = 0.
+            qsnow(ikl) = 0.
+            snow(ikl) = 0.
+            snowhgt(ikl) = 0.
+
+            DO  isn = 1, isnoSV(ikl)
+                sissnow(ikl) = sissnow(ikl) + dzsnSV(ikl, isn) * ro__SV(ikl, isn)
+                snowhgt(ikl) = snowhgt(ikl) + dzsnSV(ikl, isn)
+                ! Etienne: check calc qsnow
+                qsnow(ikl) = qsnow(ikl) + rhoWat * eta_SV(ikl, isn) * dzsnSV(ikl, isn)
+            END DO
+
+            zfra(ikl) = max(min(isnoSV(ikl) - iiceSV(ikl), 1), 0)
+            ! Etienne: comment following line
+            ! snow(ikl)    = sissnow(ikl)+toicSV(ikl)
+            snow(ikl) = sissnow(ikl)
+
+            to_ice(ikl) = toicSV(ikl)
+            runoff_lic(ikl) = RnofSV(ikl)    ! RunOFF: intensity (flux due to melting + liquid precip)
+            fqfonte(ikl)= max(0., (wem_SV(ikl)-wer_SV(ikl))/dtime) ! net melting = melting - refreezing
+            ffonte(ikl)=fqfonte(ikl)*Lf_H2O
+
+            qsol(ikl) = 0.
+            DO  isl = -nsol, 0
+                tsoil(ikl, 1 - isl) = TsisSV(ikl, isl)       ! Soil Temperature
+                ! Etienne: check calc qsol
+                qsol(ikl) = qsol(ikl)                      &
+                        + eta_SV(ikl, isl) * dz_dSV(isl)
+            END DO
+            agesno(ikl) = agsnSV(ikl, isnoSV(ikl))        !          [day]
+
+            alb1(ikl) = alb1sv(ikl)             ! Albedo VIS
+!            alb2(ikl) = ((So1dSV - f1) * alb1sv(ikl)                   &
+!                    & + So2dSV * alb2sv(ikl) + So3dSV * alb3sv(ikl)) / f1
+            alb2(ikl)=alb2sv(ikl)
+            ! Albedo NIR
+            alb3(ikl) = alb3sv(ikl)             ! Albedo FIR
+            ! 6 band Albedo
+            alb6(ikl,:)=alb6sv(ikl,:)
+
+            tsurf_new(ikl) = Tsrfsv(ikl)
+
+            qsurf(ikl) = QsT_SV(ikl)
+            emis_new(ikl) = eps0SL(ikl)
+            z0m(ikl) = Z0m_SV(ikl)
+            z0h(ikl) = Z0h_SV(ikl)
+
+
+        END DO
+
+            IF (ok_outfor) THEN
+             ikl= gp_outfor
+            write(un_outfor, *) '+++++++++++', rlon(ikl2i(ikl)), rlat(ikl2i(ikl)),alt(ikl),'+++++++++++'
+            write(un_outfor, *) isnoSV(ikl), alb_SV(ikl), Z0m_SV(ikl), Z0h_SV(ikl),HSs_sv(ikl),HLs_sv(ikl),alb1(ikl),alb2(ikl)
+            write(un_outfor, *) dzsnSV(ikl, :)
+            write(un_outfor, *) TsisSV(ikl, :)
+            write(un_outfor, *) ro__SV(ikl, :)
+            write(un_outfor, *) eta_SV(ikl, :)
+            write(un_outfor, *) G1snSV(ikl, :)
+            write(un_outfor, *) G2snSV(ikl, :)
+            write(un_outfor, *) agsnSV(ikl, :)
+            write(un_outfor, *) istoSV(ikl, :)
+            write(un_outfor, *) DOPsnSV(ikl, :)
+        ENDIF
+
+
+
+        ! +  -----------------------------
+        ! +  END --- RETURN RESULTS
+        ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+        IF (lafin) THEN
+            fichnom = "restartsis.nc"
+            CALL sisvatredem("restartsis.nc", ikl2i, rlon, rlat)
+
+            IF (ok_outfor) THEN
+                close(unit = un_outfor)
+            END IF
+        END IF
+
+    END SUBROUTINE surf_inlandsis
+
+
+    !=======================================================================
+
+    SUBROUTINE get_soil_levels(dz1, dz2, lambda)
+        ! ======================================================================
+        ! Routine to compute the vertical discretization of the soil in analogy
+        ! to LMDZ. In LMDZ it is done in soil.F, which is not used in the case
+        ! of SISVAT, therefore it's needed here.
+        !
+        USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root
+        USE mod_phys_lmdz_para
+        USE VAR_SV
+
+
+        !    INCLUDE "dimsoil.h"
+
+        REAL, DIMENSION(nsoilmx), INTENT(OUT) :: dz2, dz1
+        REAL, INTENT(OUT) :: lambda
+
+
+        !-----------------------------------------------------------------------
+        !   Depthts:
+        !   --------
+        REAL fz, rk, fz1, rk1, rk2
+        REAL min_period, dalph_soil
+        INTEGER ierr, jk
+
+        fz(rk) = fz1 * (dalph_soil**rk - 1.) / (dalph_soil - 1.)
+
+        !    write(*,*)'Start soil level computation'
+        !-----------------------------------------------------------------------
+        ! Calculation of some constants
+        ! NB! These constants do not depend on the sub-surfaces
+        !-----------------------------------------------------------------------
+        !-----------------------------------------------------------------------
+        !   ground levels
+        !   grnd=z/l where l is the skin depth of the diurnal cycle:
+        !-----------------------------------------------------------------------
+
+        min_period = 1800. ! en secondes
+        dalph_soil = 2.    ! rapport entre les epaisseurs de 2 couches succ.
+        ! !$OMP MASTER
+        !     IF (is_mpi_root) THEN
+        !        OPEN(99,file='soil.def',status='old',form='formatted',iostat=ierr)
+        !        IF (ierr == 0) THEN ! Read file only if it exists
+        !           READ(99,*) min_period
+        !           READ(99,*) dalph_soil
+        !           PRINT*,'Discretization for the soil model'
+        !           PRINT*,'First level e-folding depth',min_period, &
+        !                '   dalph',dalph_soil
+        !           CLOSE(99)
+        !        END IF
+        !     ENDIF
+        ! !$OMP END MASTER
+        !     CALL bcast(min_period)
+        !     CALL bcast(dalph_soil)
+
+        !   la premiere couche represente un dixieme de cycle diurne
+        fz1 = SQRT(min_period / 3.14)
+
+        DO jk = 1, nsoilmx
+            rk1 = jk
+            rk2 = jk - 1
+            dz2(jk) = fz(rk1) - fz(rk2)
+        ENDDO
+        DO jk = 1, nsoilmx - 1
+            rk1 = jk + .5
+            rk2 = jk - .5
+            dz1(jk) = 1. / (fz(rk1) - fz(rk2))
+        ENDDO
+        lambda = fz(.5) * dz1(1)
+        DO jk = 1, nsoilmx
+            rk = jk
+            rk1 = jk + .5
+            rk2 = jk - .5
+        ENDDO
+
+    END SUBROUTINE get_soil_levels
+
+
+    !===========================================================================
+
+    SUBROUTINE SISVAT_ini(knon)
+
+        !C +------------------------------------------------------------------------+
+        !C | MAR          SISVAT_ini                             Jd 11-10-2007  MAR |
+        !C |   SubRoutine SISVAT_ini generates non time dependant SISVAT parameters |
+        !C +------------------------------------------------------------------------+
+        !C |   PARAMETERS:  klonv: Total Number of columns =                        |
+        !C |   ^^^^^^^^^^        = Total Number of continental     grid boxes       |
+        !C |                     X       Number of Mosaic Cell per grid box         |
+        !C |                                                                        |
+        !C |   INPUT:   dt__SV   : Time  Step                                   [s] |
+        !C |   ^^^^^    dz_dSV   : Layer Thickness                              [m] |
+        !C |                                                                        |
+        !C |   OUTPUT:             [-] |
+        !C |   ^^^^^^   rocsSV   : Soil Contrib. to (ro c)_s exclud.Water  [J/kg/K] |
+        !C |            etamSV   : Soil Minimum Humidity                    [m3/m3] |
+        !C |                      (based on a prescribed Soil Relative Humidity)    |
+        !C |            s1__SV   : Factor of eta**( b+2) in Hydraul.Diffusiv.       |
+        !C |            s2__SV   : Factor of eta**( b+2) in Hydraul.Conduct.        |
+        !C |            aKdtSV   : KHyd: Piecewise Linear Profile:  a * dt    [m]   |
+        !C |            bKdtSV   : KHyd: Piecewise Linear Profile:  b * dt    [m/s] |
+        !C |            dzsnSV(0): Soil first Layer Thickness                   [m] |
+        !C |            dzmiSV   : Distance between two contiguous levels       [m] |
+        !C |            dz78SV   : 7/8 (Layer Thickness)                        [m] |
+        !C |            dz34SV   : 3/4 (Layer Thickness)                        [m] |
+        !C |            dz_8SV   : 1/8 (Layer Thickness)                        [m] |
+        !C |            dzAvSV   : 1/8  dz_(i-1) + 3/4 dz_(i) + 1/8 dz_(i+1)    [m] |
+        !C |            dtz_SV   : dt/dz                                      [s/m] |
+        !C |            OcndSV   : Swab Ocean / Soil Ratio                      [-] |
+        !C |            Implic   : Implicit Parameter  (0.5:  Crank-Nicholson)      |
+        !C |            Explic   : Explicit Parameter = 1.0 - Implic                |
+        !C |                                                                        |
+        !C | # OPTIONS: #ER: Richards Equation is not smoothed                      |
+        !C | # ^^^^^^^  #kd: De Ridder   Discretization                             |
+        !C | #          #SH: Hapex-Sahel Values                                     !
+        !C |                                                                        |
+        !C +------------------------------------------------------------------------+
+        !
+        !
+
+        !C +--Global Variables
+        !C +  ================
+
+        USE dimphy
+        USE VARphy
+        USE VAR_SV
+        USE VARdSV
+        USE VAR0SV
+        USE VARxSV
+        USE VARtSV
+        USE VARxSV
+        USE VARySV
+        IMPLICIT NONE
+
+
+
+        !C +--Arguments
+        !C +  ==================
+        INTEGER, INTENT(IN) :: knon
+
+        !C +--Internal Variables
+        !C +  ==================
+
+        INTEGER :: ivt, ist, ikl, isl, isn, ikh
+        INTEGER :: misl_2, nisl_2
+        REAL :: d__eta, eta__1, eta__2, Khyd_1, Khyd_2
+        REAL, PARAMETER :: RHsMin = 0.001        ! Min.Soil Relative Humidity
+        REAL :: PsiMax                        ! Max.Soil Water    Potential
+        REAL :: a_Khyd, b_Khyd                 ! Water conductivity
+
+
+        !c #WR REAL    ::  Khyd_x,Khyd_y
+
+
+
+        !C +--Non Time Dependant SISVAT parameters
+        !C +  ====================================
+
+        !C +--Soil Discretization
+        !C +  -------------------
+
+        !C +--Numerical Scheme Parameters
+        !C +  ^^^^^^^^^^^^^^^^^^^^^^^^^^^
+        Implic = 0.75                           ! 0.5  <==> Crank-Nicholson  
+        Explic = 1.00 - Implic                  !                            
+
+        !C +--Soil/Snow Layers Indices
+        !C +  ^^^^^^^^^^^^^^^^^^^^^^^^
+        DO  isl = -nsol, 0
+            islpSV(isl) = isl + 1
+            islpSV(isl) = min(islpSV(isl), 0)
+            islmSV(isl) = isl - 1
+            islmSV(isl) = max(-nsol, islmSV(isl))
+        END DO
+
+        DO  isn = 1, nsno
+            isnpSV(isn) = isn + 1
+            isnpSV(isn) = min(isnpSV(isn), nsno)
+        END DO
+
+        !C +--Soil      Layers Thicknesses
+        !C +  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+        ! Not used here as LMDZ method is applied, see SUBROUTINE get_soil_levels!
+        !c #kd IF (nsol.gt.4)                                              THEN
+        !c #kd   DO isl=-5,-nsol,-1
+        !c #kd     dz_dSV(isl)=   1.
+        !c #kd   END DO
+        !c #kd END IF
+        !
+        !      IF (nsol.ne.4)                                              THEN
+        !        DO isl= 0,-nsol,-1
+        !          misl_2 =     -mod(isl,2)
+        !          nisl_2 =         -isl/2
+        !          dz_dSV(isl)=(((1-misl_2) * 0.001
+        !     .                  +  misl_2  * 0.003) * 10**(nisl_2)) * 4.
+        !C +...    dz_dSV(0)  =         Hapex-Sahel Calibration:       4 mm
+        !
+        !c +SH     dz_dSV(isl)=(((1-misl_2) * 0.001
+        !c +SH.                  +  misl_2  * 0.003) * 10**(nisl_2)) * 1.
+        !
+        !c #05     dz_dSV(isl)=(((1-misl_2) * 0.001
+        !c #05.                  +  misl_2  * 0.008) * 10**(nisl_2)) * 0.5
+        !        END DO
+        !          dz_dSV(0)  =               0.001
+        !          dz_dSV(-1) = dz_dSV(-1)  - dz_dSV(0)              + 0.004
+        !      END IF
+
+        zz_dSV = 0.
+        DO  isl = -nsol, 0
+            dzmiSV(isl) = 0.500 * (dz_dSV(isl) + dz_dSV(islmSV(isl)))
+            dziiSV(isl) = 0.500 * dz_dSV(isl) / dzmiSV(isl)
+            dzi_SV(isl) = 0.500 * dz_dSV(islmSV(isl)) / dzmiSV(isl)
+            dtz_SV(isl) = dt__SV / dz_dSV(isl)
+            dtz_SV2(isl) = 1. / dz_dSV(isl)
+            dz78SV(isl) = 0.875 * dz_dSV(isl)
+            dz34SV(isl) = 0.750 * dz_dSV(isl)
+            dz_8SV(isl) = 0.125 * dz_dSV(isl)
+            dzAvSV(isl) = 0.125 * dz_dSV(islmSV(isl))                        &
+                    & + 0.750 * dz_dSV(isl)                                &
+                    & + 0.125 * dz_dSV(islpSV(isl))
+            zz_dSV = zz_dSV + dz_dSV(isl)
+        END DO
+        DO ikl = 1, knon !v
+            dzsnSV(ikl, 0) = dz_dSV(0)
+        END DO
+
+        !C +--Conversion to a 50 m Swab Ocean Discretization
+        !C +  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+        OcndSV = 0.
+        DO isl = -nsol, 0
+            OcndSV = OcndSV + dz_dSV(isl)
+        END DO
+        OcndSV = 50. / OcndSV
+
+
+        !C +--Secondary Soil       Parameters
+        !C +  -------------------------------
+
+        DO  ist = 0, nsot
+            rocsSV(ist) = (1.0 - etadSV(ist)) * 1.2E+6   ! Soil Contrib. to (ro c)_s
+            s1__SV(ist) = bCHdSV(ist)          & ! Factor of (eta)**(b+2)
+                    & * psidSV(ist) * Ks_dSV(ist)          & !    in DR97, Eqn.(3.36)
+                    & / (etadSV(ist)**(bCHdSV(ist) + 3.))     !
+            s2__SV(ist) = Ks_dSV(ist)          & ! Factor of (eta)**(2b+3)
+                    & / (etadSV(ist)**(2. * bCHdSV(ist) + 3.))     !    in DR97, Eqn.(3.35)
+
+            !C +--Soil Minimum Humidity (from a prescribed minimum relative Humidity)
+            !C +  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+            Psimax = -(log(RHsMin)) / 7.2E-5        ! DR97, Eqn 3.15 Inversion
+            etamSV(ist) = etadSV(ist)                                      &
+                    & * (PsiMax / psidSV(ist))**(-min(10., 1. / bCHdSV(ist)))
+        END DO
+        etamSV(12) = 0.
+
+        !C +--Piecewise Hydraulic Conductivity Profiles
+        !C +  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+        DO   ist = 0, nsot
+
+            d__eta = etadSV(ist) / nkhy
+            eta__1 = 0.
+            eta__2 = d__eta
+            DO ikh = 0, nkhy
+                Khyd_1 = s2__SV(ist)             & ! DR97, Eqn.(3.35)
+                        & * (eta__1      **(2. * bCHdSV(ist) + 3.))        !
+                Khyd_2 = s2__SV(ist)             &!
+                        & * (eta__2      **(2. * bCHdSV(ist) + 3.))        !
+
+                a_Khyd = (Khyd_2 - Khyd_1) / d__eta   !
+                b_Khyd = Khyd_1 - a_Khyd * eta__1   !
+                !c #WR     Khyd_x          =  a_Khyd*eta__1 +b_Khyd   !
+                !c #WR     Khyd_y          =  a_Khyd*eta__2 +b_Khyd   !
+                aKdtSV(ist, ikh) = a_Khyd * dt__SV   !
+                bKdtSV(ist, ikh) = b_Khyd * dt__SV   !
+
+                eta__1 = eta__1 + d__eta
+                eta__2 = eta__2 + d__eta
+            END DO
+        END DO
+
+        return
+
+    END SUBROUTINE SISVAT_ini
+
+
+    !***************************************************************************
+
+    SUBROUTINE sisvatetat0 (fichnom, ikl2i)
+
+        USE dimphy
+        USE mod_grid_phy_lmdz
+        USE mod_phys_lmdz_para
+
+        USE iostart
+        USE VAR_SV
+        USE VARdSV
+        USE VARxSV
+        USE VARtSV
+        USE indice_sol_mod
+
+        IMPLICIT none
+        !======================================================================
+        ! Auteur(s) HJ PUNGE (LSCE) date: 07/2009
+        ! Objet: Lecture du fichier de conditions initiales pour SISVAT
+        !======================================================================
+        include "netcdf.inc"
+        !    include "indicesol.h"
+
+        !    include "dimsoil.h"
+        include "clesphys.h"
+        include "compbl.h"
+
+        !======================================================================
+        CHARACTER(LEN = *) :: fichnom
+
+        INTEGER, DIMENSION(klon), INTENT(IN) :: ikl2i
+        REAL, DIMENSION(klon) :: rlon
+        REAL, DIMENSION(klon) :: rlat
+
+        ! les variables globales ecrites dans le fichier restart
+        REAL, DIMENSION(klon) :: isno
+        REAL, DIMENSION(klon) :: ispi
+        REAL, DIMENSION(klon) :: iice
+        REAL, DIMENSION(klon) :: rusn
+        REAL, DIMENSION(klon, nsno) :: isto
+
+        REAL, DIMENSION(klon, nsismx) :: Tsis
+        REAL, DIMENSION(klon, nsismx) :: eta
+        REAL, DIMENSION(klon, nsismx) :: ro
+
+        REAL, DIMENSION(klon, nsno) :: dzsn
+        REAL, DIMENSION(klon, nsno) :: G1sn
+        REAL, DIMENSION(klon, nsno) :: G2sn
+        REAL, DIMENSION(klon, nsno) :: agsn
+
+        REAL, DIMENSION(klon) :: toic
+
+        INTEGER :: isl, ikl, i, isn, errT, erreta, errro, errdz, snopts
+        CHARACTER (len = 2) :: str2
+        LOGICAL :: found
+
+        errT = 0
+        errro = 0
+        erreta = 0
+        errdz = 0
+        snopts = 0
+        ! Ouvrir le fichier contenant l'etat initial:
+
+        CALL open_startphy(fichnom)
+
+        ! Lecture des latitudes, longitudes (coordonnees):
+
+        CALL get_field("latitude", rlat, found)
+        CALL get_field("longitude", rlon, found)
+
+        CALL get_field("n_snows", isno, found)
+        IF (.NOT. found) THEN
+            PRINT*, 'phyetat0: Le champ <n_snows> est absent'
+            PRINT *, 'fichier startsisvat non compatible avec sisvatetat0'
+        ENDIF
+
+        CALL get_field("n_ice_top", ispi, found)
+        CALL get_field("n_ice", iice, found)
+        CALL get_field("surf_water", rusn, found)
+
+
+        CALL get_field("to_ice", toic, found)
+        IF (.NOT. found) THEN
+            PRINT*, 'phyetat0: Le champ <to_ice> est absent'
+            toic(:) = 0.
+        ENDIF
+
+        DO isn = 1, nsno
+            IF (isn.LE.99) THEN
+                WRITE(str2, '(i2.2)') isn
+                CALL get_field("AGESNOW" // str2, &
+                        agsn(:, isn), found)
+            ELSE
+                PRINT*, "Trop de couches"
+                CALL abort
+            ENDIF
+        ENDDO
+        DO isn = 1, nsno
+            IF (isn.LE.99) THEN
+                WRITE(str2, '(i2.2)') isn
+                CALL get_field("DZSNOW" // str2, &
+                        dzsn(:, isn), found)
+            ELSE
+                PRINT*, "Trop de couches"
+                CALL abort
+            ENDIF
+        ENDDO
+        DO isn = 1, nsno
+            IF (isn.LE.99) THEN
+                WRITE(str2, '(i2.2)') isn
+                CALL get_field("G2SNOW" // str2, &
+                        G2sn(:, isn), found)
+            ELSE
+                PRINT*, "Trop de couches"
+                CALL abort
+            ENDIF
+        ENDDO
+        DO isn = 1, nsno
+            IF (isn.LE.99) THEN
+                WRITE(str2, '(i2.2)') isn
+                CALL get_field("G1SNOW" // str2, &
+                        G1sn(:, isn), found)
+            ELSE
+                PRINT*, "Trop de couches"
+                CALL abort
+            ENDIF
+        ENDDO
+        DO isn = 1, nsismx
+            IF (isn.LE.99) THEN
+                WRITE(str2, '(i2.2)') isn
+                CALL get_field("ETA" // str2, &
+                        eta(:, isn), found)
+            ELSE
+                PRINT*, "Trop de couches"
+                CALL abort
+            ENDIF
+        ENDDO
+        DO isn = 1, nsismx
+            IF (isn.LE.99) THEN
+                WRITE(str2, '(i2.2)') isn
+                CALL get_field("RO" // str2, &
+                        ro(:, isn), found)
+            ELSE
+                PRINT*, "Trop de couches"
+                CALL abort
+            ENDIF
+        ENDDO
+        DO isn = 1, nsismx
+            IF (isn.LE.99) THEN
+                WRITE(str2, '(i2.2)') isn
+                CALL get_field("TSS" // str2, &
+                        Tsis(:, isn), found)
+            ELSE
+                PRINT*, "Trop de couches"
+                CALL abort
+            ENDIF
+        ENDDO
+        DO isn = 1, nsno
+            IF (isn.LE.99) THEN
+                WRITE(str2, '(i2.2)') isn
+                CALL get_field("HISTORY" // str2, &
+                        isto(:, isn), found)
+            ELSE
+                PRINT*, "Trop de couches"
+                CALL abort
+            ENDIF
+        ENDDO
+        write(*, *)'Read ', fichnom, ' finished!!'
+
+        !*********************************************************************************
+        ! Compress restart file variables for SISVAT
+
+        DO  ikl = 1, klon
+            i = ikl2i(ikl)
+            IF (i > 0) THEN
+                isnoSV(ikl) = INT(isno(i))          ! Nb Snow/Ice Lay.
+                ispiSV(ikl) = INT(ispi(i))          ! Nb Supr.Ice Lay.
+                iiceSV(ikl) = INT(iice(i))          ! Nb      Ice Lay.
+
+                DO isl = -nsol, 0
+                    ro__SV(ikl, isl) = ro(i, nsno + 1 - isl)       !
+                    eta_SV(ikl, isl) = eta(i, nsno + 1 - isl)         ! Soil Humidity
+                    !hjp 15/10/2010
+                    IF (eta_SV(ikl, isl) <= 1.e-6) THEN          !hj check
+                        eta_SV(ikl, isl) = 1.e-6
+                    ENDIF
+                    TsisSV(ikl, isl) = Tsis(i, nsno + 1 - isl)        ! Soil Temperature
+                    IF (TsisSV(ikl, isl) <= 1.) THEN             !hj check
+                        !                errT=errT+1
+                        TsisSV(ikl, isl) = 273.15 - 0.2              ! Etienne: negative temperature since soil is ice
+                    ENDIF
+
+                END DO
+                write(*, *)'Copy histo', ikl
+
+                DO  isn = 1, isnoSV(ikl) !nsno
+                    snopts = snopts + 1
+                    IF (isto(i, isn) > 10.) THEN          !hj check
+                        write(*, *)'Irregular isto', ikl, i, isn, isto(i, isn)
+                        isto(i, isn) = 1.
+                    ENDIF
+
+                    istoSV(ikl, isn) = INT(isto(i, isn))     ! Snow     History
+                    ro__SV(ikl, isn) = ro(i, isn)            !        [kg/m3]
+                    eta_SV(ikl, isn) = eta(i, isn)           !        [m3/m3]
+                    TsisSV(ikl, isn) = Tsis(i, isn)          !            [K]
+
+                    IF (TsisSV(ikl, isn) <= 1.) THEN          !hj check
+                        errT = errT + 1
+                        TsisSV(ikl, isn) = TsisSV(ikl, 0)
+                    ENDIF
+                    IF (TsisSV(ikl, isn) <= 1.) THEN          !hj check
+                        TsisSV(ikl, isn) = 263.15
+                    ENDIF
+                    IF (eta_SV(ikl, isn) < 1.e-9) THEN          !hj check
+                        eta_SV(ikl, isn) = 1.e-6
+                        erreta = erreta + 1
+                    ENDIF
+                    IF (ro__SV(ikl, isn) <= 10.) THEN          !hj check
+                        ro__SV(ikl, isn) = 11.
+                        errro = errro + 1
+                    ENDIF
+                    write(*, *)ikl, i, isn, Tsis(i, isn), G1sn(i, isn)
+                    G1snSV(ikl, isn) = G1sn(i, isn)          ! [-]        [-]
+                    G2snSV(ikl, isn) = G2sn(i, isn)          ! [-] [0.0001 m]
+                    dzsnSV(ikl, isn) = dzsn(i, isn)          !            [m]
+                    agsnSV(ikl, isn) = agsn(i, isn)          !          [day]
+                END DO
+                rusnSV(ikl) = rusn(i)              ! Surficial Water
+                toicSV(ikl) = toic(i)              ! bilan snow to ice
+            END IF
+        END DO
+
+    END SUBROUTINE sisvatetat0
+
+
+    !======================================================================
+    SUBROUTINE sisvatredem (fichnom, ikl2i, rlon, rlat)
+
+
+
+        !======================================================================
+        ! Auteur(s) HJ PUNGE (LSCE) date: 07/2009
+        ! Objet: Ecriture de l'etat de redemarrage pour SISVAT
+        !======================================================================
+        USE mod_grid_phy_lmdz
+        USE mod_phys_lmdz_para
+        USE iostart
+        USE VAR_SV
+        USE VARxSV
+        USE VARySV !hj tmp 12 03 2010
+        USE VARtSV
+        USE indice_sol_mod
+        USE dimphy
+
+        IMPLICIT none
+
+        include "netcdf.inc"
+        include "clesphys.h"
+        include "compbl.h"
+
+        !======================================================================
+
+        CHARACTER(LEN = *) :: fichnom
+        INTEGER, DIMENSION(klon), INTENT(IN) :: ikl2i
+        REAL, DIMENSION(klon), INTENT(IN) :: rlon
+        REAL, DIMENSION(klon), INTENT(IN) :: rlat
+
+        ! les variables globales ecrites dans le fichier restart
+        REAL, DIMENSION(klon) :: isno
+        REAL, DIMENSION(klon) :: ispi
+        REAL, DIMENSION(klon) :: iice
+        REAL, DIMENSION(klon, nsnowmx) :: isto
+
+        REAL, DIMENSION(klon, nsismx) :: Tsis
+        REAL, DIMENSION(klon, nsismx) :: eta
+        REAL, DIMENSION(klon, nsnowmx) :: dzsn
+        REAL, DIMENSION(klon, nsismx) :: ro
+        REAL, DIMENSION(klon, nsnowmx) :: G1sn
+        REAL, DIMENSION(klon, nsnowmx) :: G2sn
+        REAL, DIMENSION(klon, nsnowmx) :: agsn
+        REAL, DIMENSION(klon) :: IRs
+        REAL, DIMENSION(klon) :: LMO
+        REAL, DIMENSION(klon) :: rusn
+        REAL, DIMENSION(klon) :: toic
+        REAL, DIMENSION(klon) :: Bufs
+        REAL, DIMENSION(klon) :: alb1, alb2, alb3
+
+        INTEGER isl, ikl, i, isn, ierr
+        CHARACTER (len = 2) :: str2
+        INTEGER :: pass
+
+        isno(:) = 0
+        ispi(:) = 0
+        iice(:) = 0
+        IRs(:) = 0.
+        LMO(:) = 0.
+        eta(:, :) = 0.
+        Tsis(:, :) = 0.
+        isto(:, :) = 0
+        ro(:, :) = 0.
+        G1sn(:, :) = 0.
+        G2sn(:, :) = 0.
+        dzsn(:, :) = 0.
+        agsn(:, :) = 0.
+        rusn(:) = 0.
+        toic(:) = 0.
+        Bufs(:) = 0.
+        alb1(:) = 0.
+        alb2(:) = 0.
+        alb3(:) = 0.
+
+        !***************************************************************************
+        ! Uncompress SISVAT output variables for storage
+
+        DO  ikl = 1, klon
+            i = ikl2i(ikl)
+            IF (i > 0) THEN
+                isno(i) = 1. * isnoSV(ikl)               ! Nb Snow/Ice Lay.
+                ispi(i) = 1. * ispiSV(ikl)               ! Nb Supr.Ice Lay.
+                iice(i) = 1. * iiceSV(ikl)               ! Nb      Ice Lay.
+
+                !        IRs(i)        = IRs_SV(ikl)
+                !        LMO(i)        = LMO_SV(ikl)
+
+                DO isl = -nsol, 0                           !
+                    eta(i, nsno + 1 - isl) = eta_SV(ikl, isl)            ! Soil Humidity
+                    Tsis(i, nsno + 1 - isl) = TsisSV(ikl, isl)            ! Soil Temperature
+                    ro(i, nsno + 1 - isl) = ro__SV(ikl, isl)            !        [kg/m3]
+                END DO
+
+                DO  isn = 1, nsno
+                    isto(i, isn) = 1. * istoSV(ikl, isn)         ! Snow     History
+                    ro(i, isn) = ro__SV(ikl, isn)            !        [kg/m3]
+                    eta(i, isn) = eta_SV(ikl, isn)            !        [m3/m3]
+                    Tsis(i, isn) = TsisSV(ikl, isn)            !            [K]
+                    G1sn(i, isn) = G1snSV(ikl, isn)            ! [-]        [-]
+                    G2sn(i, isn) = G2snSV(ikl, isn)            ! [-] [0.0001 m]
+                    dzsn(i, isn) = dzsnSV(ikl, isn)            !            [m]
+                    agsn(i, isn) = agsnSV(ikl, isn)            !          [day]
+                END DO
+                rusn(i) = rusnSV(ikl)                  ! Surficial Water
+                toic(i) = toicSV(ikl)                  ! to ice
+                alb1(i) = alb1sv(ikl)
+                alb2(i) = alb2sv(ikl)
+                alb3(i) = alb3sv(ikl)
+                !        Bufs(i)       = BufsSV(ikl)
+            END IF
+        END DO
+
+        CALL open_restartphy(fichnom)
+
+        DO pass = 1, 2
+            CALL put_field(pass, "longitude", &
+                    "Longitudes de la grille physique", rlon)
+            CALL put_field(pass, "latitude", "Latitudes de la grille physique", rlat)
+
+            CALL put_field(pass, "n_snows", "number of snow/ice layers", isno)
+            CALL put_field(pass, "n_ice_top", "number of top ice layers", ispi)
+            CALL put_field(pass, "n_ice", "number of ice layers", iice)
+            CALL put_field(pass, "IR_soil", "Soil IR flux", IRs)
+            CALL put_field(pass, "LMO", "Monin-Obukhov Scale", LMO)
+            CALL put_field(pass, "surf_water", "Surficial water", rusn)
+            CALL put_field(pass, "snow_buffer", "Snow buffer layer", Bufs)
+            CALL put_field(pass, "alb_1", "albedo sw", alb1)
+            CALL put_field(pass, "alb_2", "albedo nIR", alb2)
+            CALL put_field(pass, "alb_3", "albedo fIR", alb3)
+            CALL put_field(pass, "to_ice", "Snow passed to ice", toic)
+
+            DO isn = 1, nsno
+                IF (isn.LE.99) THEN
+                    WRITE(str2, '(i2.2)') isn
+                    CALL put_field(pass, "AGESNOW" // str2, &
+                            "Age de la neige layer No." // str2, &
+                            agsn(:, isn))
+                ELSE
+                    PRINT*, "Trop de couches"
+                    CALL abort
+                ENDIF
+            ENDDO
+            DO isn = 1, nsno
+                IF (isn.LE.99) THEN
+                    WRITE(str2, '(i2.2)') isn
+                    CALL put_field(pass, "DZSNOW" // str2, &
+                            "Snow/ice thickness layer No." // str2, &
+                            dzsn(:, isn))
+                ELSE
+                    PRINT*, "Trop de couches"
+                    CALL abort
+                ENDIF
+            ENDDO
+            DO isn = 1, nsno
+                IF (isn.LE.99) THEN
+                    WRITE(str2, '(i2.2)') isn
+                    CALL put_field(pass, "G2SNOW" // str2, &
+                            "Snow Property 2, layer No." // str2, &
+                            G2sn(:, isn))
+                ELSE
+                    PRINT*, "Trop de couches"
+                    CALL abort
+                ENDIF
+            ENDDO
+            DO isn = 1, nsno
+                IF (isn.LE.99) THEN
+                    WRITE(str2, '(i2.2)') isn
+                    CALL put_field(pass, "G1SNOW" // str2, &
+                            "Snow Property 1, layer No." // str2, &
+                            G1sn(:, isn))
+                ELSE
+                    PRINT*, "Trop de couches"
+                    CALL abort
+                ENDIF
+            ENDDO
+            DO isn = 1, nsismx
+                IF (isn.LE.99) THEN
+                    WRITE(str2, '(i2.2)') isn
+                    CALL put_field(pass, "ETA" // str2, &
+                            "Soil/snow water content layer No." // str2, &
+                            eta(:, isn))
+                ELSE
+                    PRINT*, "Trop de couches"
+                    CALL abort
+                ENDIF
+            ENDDO
+            DO isn = 1, nsismx   !nsno
+                IF (isn.LE.99) THEN
+                    WRITE(str2, '(i2.2)') isn
+                    CALL put_field(pass, "RO" // str2, &
+                            "Snow density layer No." // str2, &
+                            ro(:, isn))
+                ELSE
+                    PRINT*, "Trop de couches"
+                    CALL abort
+                ENDIF
+            ENDDO
+            DO isn = 1, nsismx
+                IF (isn.LE.99) THEN
+                    WRITE(str2, '(i2.2)') isn
+                    CALL put_field(pass, "TSS" // str2, &
+                            "Soil/snow temperature layer No." // str2, &
+                            Tsis(:, isn))
+                ELSE
+                    PRINT*, "Trop de couches"
+                    CALL abort
+                ENDIF
+            ENDDO
+            DO isn = 1, nsno
+                IF (isn.LE.99) THEN
+                    WRITE(str2, '(i2.2)') isn
+                    CALL put_field(pass, "HISTORY" // str2, &
+                            "Snow history layer No." // str2, &
+                            isto(:, isn))
+                ELSE
+                    PRINT*, "Trop de couches"
+                    CALL abort
+                ENDIF
+            ENDDO
+
+            CALL enddef_restartphy
+        ENDDO
+        CALL close_restartphy
+
+    END SUBROUTINE sisvatredem
+
+END MODULE surf_inlandsis_mod
Index: DZ6/trunk/libf/phylmd/interfoce_lim.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/interfoce_lim.F90	(revision 5267)
+++ 	(revision )
@@ -1,266 +1,0 @@
-!
-! $Header$
-!
-SUBROUTINE interfoce_lim(itime, dtime, jour, &
-     knon, knindex, &
-     debut,  &
-     lmt_sst_p, pctsrf_new_p)
-  
-  USE mod_grid_phy_lmdz
-  USE mod_phys_lmdz_para
-  USE indice_sol_mod
-  USE netcdf, ONLY: nf90_get_var
-  
-  IMPLICIT NONE
-  
-  INCLUDE "netcdf.inc"
-
-! Cette routine sert d'interface entre le modele atmospherique et un fichier
-! de conditions aux limites
-!
-! L. Fairhead 02/2000
-!
-! input:
-!   itime        numero du pas de temps courant
-!   dtime        pas de temps de la physique (en s)
-!   jour         jour a lire dans l'annee
-!   nisurf       index de la surface a traiter (1 = sol continental)
-!   knon         nombre de points dans le domaine a traiter
-!   knindex      index des points de la surface a traiter
-!   klon         taille de la grille
-!   debut        logical: 1er appel a la physique (initialisation)
-!
-! output:
-!   lmt_sst_p      SST lues dans le fichier de CL
-!   pctsrf_new-p   sous-maille fractionnelle
-!
-
-
-! Parametres d'entree
-!****************************************************************************************
-  INTEGER, INTENT(IN)                       :: itime
-  INTEGER, INTENT(IN)                       :: jour
-  INTEGER, INTENT(IN)                       :: knon
-  INTEGER, DIMENSION(klon_loc), INTENT(IN)  :: knindex
-  REAL   , INTENT(IN)                       :: dtime
-  LOGICAL, INTENT(IN)                       :: debut
-  
-! Parametres de sortie
-!****************************************************************************************
-  REAL, INTENT(OUT), DIMENSION(klon_loc)       :: lmt_sst_p
-  REAL, INTENT(OUT), DIMENSION(klon_loc,nbsrf) :: pctsrf_new_p
-
-
-! Variables locales avec l'attribut SAVE
-!****************************************************************************************
-! frequence de lecture des conditions limites (en pas de physique) 
-  INTEGER,SAVE                              :: lmt_pas   
-  !$OMP THREADPRIVATE(lmt_pas)
-! pour indiquer que le jour a lire est deja lu pour une surface precedente
-  LOGICAL,SAVE                              :: deja_lu   
-  !$OMP THREADPRIVATE(deja_lu)
-  INTEGER,SAVE                              :: jour_lu 
-  !$OMP THREADPRIVATE(jour_lu)
-  CHARACTER (len = 20),SAVE                 :: fich ='limit.nc'
-  !$OMP THREADPRIVATE(fich)
-  LOGICAL, SAVE                             :: newlmt = .TRUE.
-  !$OMP THREADPRIVATE(newlmt)
-  LOGICAL, SAVE                             :: check = .FALSE.
-  !$OMP THREADPRIVATE(check)
-  REAL, ALLOCATABLE , SAVE, DIMENSION(:)    :: sst_lu_p
-  !$OMP THREADPRIVATE(sst_lu_p)
-  REAL, ALLOCATABLE , SAVE, DIMENSION(:,:)  :: pct_tmp_p
-  !$OMP THREADPRIVATE(pct_tmp_p)
-
-! Variables locales 
-!****************************************************************************************
-  INTEGER                                   :: nid, nvarid
-  INTEGER                                   :: ii
-  INTEGER                                   :: ierr
-  INTEGER, DIMENSION(2)                     :: start, epais
-  CHARACTER (len = 20)                      :: modname = 'interfoce_lim'
-  CHARACTER (len = 80)                      :: abort_message
-  REAL, DIMENSION(klon_glo,nbsrf)           :: pctsrf_new
-  REAL, DIMENSION(klon_glo,nbsrf)           :: pct_tmp
-  REAL, DIMENSION(klon_glo)                 :: sst_lu
-  REAL, DIMENSION(klon_glo)                 :: nat_lu
-!
-! Fin declaration
-!****************************************************************************************
-
-!****************************************************************************************
-! Start calculation
-!
-!****************************************************************************************
-  IF (debut .AND. .NOT. ALLOCATED(sst_lu_p)) THEN
-     lmt_pas = NINT(86400./dtime * 1.0) ! pour une lecture une fois par jour
-     jour_lu = jour - 1
-     ALLOCATE(sst_lu_p(klon_loc))
-     ALLOCATE(pct_tmp_p(klon_loc,nbsrf))
-  ENDIF
-  
-  IF ((jour - jour_lu) /= 0) deja_lu = .FALSE.
-  
-  IF (check) WRITE(*,*) modname, ' :: jour, jour_lu, deja_lu', jour, jour_lu, deja_lu 
-  IF (check) WRITE(*,*) modname, ' :: itime, lmt_pas ', itime, lmt_pas,dtime
-
-!****************************************************************************************
-! Ouverture et lecture du fichier pour le master process si c'est le bon moment
-!
-!****************************************************************************************
-! Tester d'abord si c'est le moment de lire le fichier
-  IF (MOD(itime-1, lmt_pas) == 0 .AND. .NOT. deja_lu) THEN
-
-!$OMP MASTER
-     IF (is_mpi_root) THEN
-
-        fich = TRIM(fich)
-        ierr = NF_OPEN (fich, NF_NOWRITE,nid)
-        IF (ierr.NE.NF_NOERR) THEN
-           abort_message = 'Pb d''ouverture du fichier de conditions aux limites'
-           CALL abort_physic(modname,abort_message,1)
-        ENDIF
-
-        ! La tranche de donnees a lire:
-
-        start(1) = 1
-        start(2) = jour
-        epais(1) = klon_glo
-        epais(2) = 1
-
-        IF (newlmt) THEN
-           !
-           ! Fraction "ocean" 
-           !
-           ierr = NF_INQ_VARID(nid, 'FOCE', nvarid)
-           IF (ierr /= NF_NOERR) THEN
-              abort_message = 'Le champ <FOCE> est absent'
-              CALL abort_physic(modname,abort_message,1)
-           ENDIF
-           ierr = nf90_get_var(nid,nvarid,pct_tmp(:,is_oce),start,epais)
-           IF (ierr /= NF_NOERR) THEN
-              abort_message = 'Lecture echouee pour <FOCE>'
-              CALL abort_physic(modname,abort_message,1)
-           ENDIF
-           !
-           ! Fraction "glace de mer" 
-           !
-           ierr = NF_INQ_VARID(nid, 'FSIC', nvarid)
-           IF (ierr /= NF_NOERR) THEN
-              abort_message = 'Le champ <FSIC> est absent'
-              CALL abort_physic(modname,abort_message,1)
-           ENDIF
-           ierr = nf90_get_var(nid,nvarid,pct_tmp(:,is_sic),start,epais)
-           IF (ierr /= NF_NOERR) THEN
-              abort_message = 'Lecture echouee pour <FSIC>'
-              CALL abort_physic(modname,abort_message,1)
-           ENDIF
-           !
-           ! Fraction "terre" 
-           !
-           ierr = NF_INQ_VARID(nid, 'FTER', nvarid)
-           IF (ierr /= NF_NOERR) THEN
-              abort_message = 'Le champ <FTER> est absent'
-              CALL abort_physic(modname,abort_message,1)
-           ENDIF
-           ierr = nf90_get_var(nid,nvarid,pct_tmp(:,is_ter),start,epais)
-           IF (ierr /= NF_NOERR) THEN
-              abort_message = 'Lecture echouee pour <FTER>'
-              CALL abort_physic(modname,abort_message,1)
-           ENDIF
-           !
-           ! Fraction "glacier terre" 
-           !
-           ierr = NF_INQ_VARID(nid, 'FLIC', nvarid)
-           IF (ierr /= NF_NOERR) THEN
-              abort_message = 'Le champ <FLIC> est absent'
-              CALL abort_physic(modname,abort_message,1)
-           ENDIF
-           ierr = nf90_get_var(nid,nvarid,pct_tmp(:,is_lic),start,epais)
-           IF (ierr /= NF_NOERR) THEN
-              abort_message = 'Lecture echouee pour <FLIC>'
-              CALL abort_physic(modname,abort_message,1)
-           ENDIF
-           !
-        ELSE  ! on en est toujours a rnatur
-           ! 
-           ierr = NF_INQ_VARID(nid, 'NAT', nvarid)
-           IF (ierr /= NF_NOERR) THEN
-              abort_message = 'Le champ <NAT> est absent'
-              CALL abort_physic(modname,abort_message,1)
-           ENDIF
-           ierr = nf90_get_var(nid,nvarid,nat_lu,start,epais)
-           IF (ierr /= NF_NOERR) THEN
-              abort_message = 'Lecture echouee pour <NAT>'
-              CALL abort_physic(modname,abort_message,1)
-           ENDIF
-!
-! Remplissage des fractions de surface
-! nat = 0, 1, 2, 3 pour ocean, terre, glacier, seaice
-! 
-           pct_tmp = 0.0
-           DO ii = 1, klon_glo
-              pct_tmp(ii,NINT(nat_lu(ii)) + 1) = 1.
-           ENDDO
-
-!
-!  On se retrouve avec ocean en 1 et terre en 2 alors qu'on veut le contraire
-!
-           pctsrf_new = pct_tmp
-           pctsrf_new (:,2)= pct_tmp (:,1)
-           pctsrf_new (:,1)= pct_tmp (:,2)
-           pct_tmp = pctsrf_new 
-        ENDIF ! fin test sur newlmt
-!
-! Lecture SST
-!
-        ierr = NF_INQ_VARID(nid, 'SST', nvarid)
-        IF (ierr /= NF_NOERR) THEN
-           abort_message = 'Le champ <SST> est absent'
-           CALL abort_physic(modname,abort_message,1)
-        ENDIF
-        ierr = nf90_get_var(nid,nvarid,sst_lu,start,epais)
-        IF (ierr /= NF_NOERR) THEN
-           abort_message = 'Lecture echouee pour <SST>'
-           CALL abort_physic(modname,abort_message,1)
-        ENDIF
-          
-!****************************************************************************************
-! Fin de lecture, fermeture de fichier
-!
-!****************************************************************************************
-        ierr = NF_CLOSE(nid)
-     ENDIF ! is_mpi_root
-
-!$OMP END MASTER
-!$OMP BARRIER
-
-
-!****************************************************************************************
-! Distribue les variables sur tous les processus
-!
-!****************************************************************************************
-     CALL Scatter(sst_lu,sst_lu_p)
-     CALL Scatter(pct_tmp(:,is_oce),pct_tmp_p(:,is_oce))
-     CALL Scatter(pct_tmp(:,is_sic),pct_tmp_p(:,is_sic))
-     deja_lu = .TRUE.
-     jour_lu = jour
-  ENDIF
-
-!****************************************************************************************
-! Recopie des variables dans les champs de sortie
-!
-!****************************************************************************************
-  lmt_sst_p = 999999999.
-  
-  DO ii = 1, knon
-     lmt_sst_p(ii) = sst_lu_p(knindex(ii))
-  ENDDO
-  
-  DO ii=1,klon_loc
-     pctsrf_new_p(ii,is_oce)=pct_tmp_p(ii,is_oce)
-     pctsrf_new_p(ii,is_sic)=pct_tmp_p(ii,is_sic)
-  ENDDO
-  
-  
-END SUBROUTINE interfoce_lim
Index: /LMDZ6/trunk/libf/phylmd/interfoce_lim.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/interfoce_lim.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/interfoce_lim.f90	(revision 5268)
@@ -0,0 +1,266 @@
+!
+! $Header$
+!
+SUBROUTINE interfoce_lim(itime, dtime, jour, &
+     knon, knindex, &
+     debut,  &
+     lmt_sst_p, pctsrf_new_p)
+  
+  USE mod_grid_phy_lmdz
+  USE mod_phys_lmdz_para
+  USE indice_sol_mod
+  USE netcdf, ONLY: nf90_get_var
+  
+  IMPLICIT NONE
+  
+  INCLUDE "netcdf.inc"
+
+! Cette routine sert d'interface entre le modele atmospherique et un fichier
+! de conditions aux limites
+!
+! L. Fairhead 02/2000
+!
+! input:
+!   itime        numero du pas de temps courant
+!   dtime        pas de temps de la physique (en s)
+!   jour         jour a lire dans l'annee
+!   nisurf       index de la surface a traiter (1 = sol continental)
+!   knon         nombre de points dans le domaine a traiter
+!   knindex      index des points de la surface a traiter
+!   klon         taille de la grille
+!   debut        logical: 1er appel a la physique (initialisation)
+!
+! output:
+!   lmt_sst_p      SST lues dans le fichier de CL
+!   pctsrf_new-p   sous-maille fractionnelle
+!
+
+
+! Parametres d'entree
+!****************************************************************************************
+  INTEGER, INTENT(IN)                       :: itime
+  INTEGER, INTENT(IN)                       :: jour
+  INTEGER, INTENT(IN)                       :: knon
+  INTEGER, DIMENSION(klon_loc), INTENT(IN)  :: knindex
+  REAL   , INTENT(IN)                       :: dtime
+  LOGICAL, INTENT(IN)                       :: debut
+  
+! Parametres de sortie
+!****************************************************************************************
+  REAL, INTENT(OUT), DIMENSION(klon_loc)       :: lmt_sst_p
+  REAL, INTENT(OUT), DIMENSION(klon_loc,nbsrf) :: pctsrf_new_p
+
+
+! Variables locales avec l'attribut SAVE
+!****************************************************************************************
+! frequence de lecture des conditions limites (en pas de physique) 
+  INTEGER,SAVE                              :: lmt_pas   
+  !$OMP THREADPRIVATE(lmt_pas)
+! pour indiquer que le jour a lire est deja lu pour une surface precedente
+  LOGICAL,SAVE                              :: deja_lu   
+  !$OMP THREADPRIVATE(deja_lu)
+  INTEGER,SAVE                              :: jour_lu 
+  !$OMP THREADPRIVATE(jour_lu)
+  CHARACTER (len = 20),SAVE                 :: fich ='limit.nc'
+  !$OMP THREADPRIVATE(fich)
+  LOGICAL, SAVE                             :: newlmt = .TRUE.
+  !$OMP THREADPRIVATE(newlmt)
+  LOGICAL, SAVE                             :: check = .FALSE.
+  !$OMP THREADPRIVATE(check)
+  REAL, ALLOCATABLE , SAVE, DIMENSION(:)    :: sst_lu_p
+  !$OMP THREADPRIVATE(sst_lu_p)
+  REAL, ALLOCATABLE , SAVE, DIMENSION(:,:)  :: pct_tmp_p
+  !$OMP THREADPRIVATE(pct_tmp_p)
+
+! Variables locales 
+!****************************************************************************************
+  INTEGER                                   :: nid, nvarid
+  INTEGER                                   :: ii
+  INTEGER                                   :: ierr
+  INTEGER, DIMENSION(2)                     :: start, epais
+  CHARACTER (len = 20)                      :: modname = 'interfoce_lim'
+  CHARACTER (len = 80)                      :: abort_message
+  REAL, DIMENSION(klon_glo,nbsrf)           :: pctsrf_new
+  REAL, DIMENSION(klon_glo,nbsrf)           :: pct_tmp
+  REAL, DIMENSION(klon_glo)                 :: sst_lu
+  REAL, DIMENSION(klon_glo)                 :: nat_lu
+!
+! Fin declaration
+!****************************************************************************************
+
+!****************************************************************************************
+! Start calculation
+!
+!****************************************************************************************
+  IF (debut .AND. .NOT. ALLOCATED(sst_lu_p)) THEN
+     lmt_pas = NINT(86400./dtime * 1.0) ! pour une lecture une fois par jour
+     jour_lu = jour - 1
+     ALLOCATE(sst_lu_p(klon_loc))
+     ALLOCATE(pct_tmp_p(klon_loc,nbsrf))
+  ENDIF
+  
+  IF ((jour - jour_lu) /= 0) deja_lu = .FALSE.
+  
+  IF (check) WRITE(*,*) modname, ' :: jour, jour_lu, deja_lu', jour, jour_lu, deja_lu 
+  IF (check) WRITE(*,*) modname, ' :: itime, lmt_pas ', itime, lmt_pas,dtime
+
+!****************************************************************************************
+! Ouverture et lecture du fichier pour le master process si c'est le bon moment
+!
+!****************************************************************************************
+! Tester d'abord si c'est le moment de lire le fichier
+  IF (MOD(itime-1, lmt_pas) == 0 .AND. .NOT. deja_lu) THEN
+
+!$OMP MASTER
+     IF (is_mpi_root) THEN
+
+        fich = TRIM(fich)
+        ierr = NF_OPEN (fich, NF_NOWRITE,nid)
+        IF (ierr.NE.NF_NOERR) THEN
+           abort_message = 'Pb d''ouverture du fichier de conditions aux limites'
+           CALL abort_physic(modname,abort_message,1)
+        ENDIF
+
+        ! La tranche de donnees a lire:
+
+        start(1) = 1
+        start(2) = jour
+        epais(1) = klon_glo
+        epais(2) = 1
+
+        IF (newlmt) THEN
+           !
+           ! Fraction "ocean" 
+           !
+           ierr = NF_INQ_VARID(nid, 'FOCE', nvarid)
+           IF (ierr /= NF_NOERR) THEN
+              abort_message = 'Le champ <FOCE> est absent'
+              CALL abort_physic(modname,abort_message,1)
+           ENDIF
+           ierr = nf90_get_var(nid,nvarid,pct_tmp(:,is_oce),start,epais)
+           IF (ierr /= NF_NOERR) THEN
+              abort_message = 'Lecture echouee pour <FOCE>'
+              CALL abort_physic(modname,abort_message,1)
+           ENDIF
+           !
+           ! Fraction "glace de mer" 
+           !
+           ierr = NF_INQ_VARID(nid, 'FSIC', nvarid)
+           IF (ierr /= NF_NOERR) THEN
+              abort_message = 'Le champ <FSIC> est absent'
+              CALL abort_physic(modname,abort_message,1)
+           ENDIF
+           ierr = nf90_get_var(nid,nvarid,pct_tmp(:,is_sic),start,epais)
+           IF (ierr /= NF_NOERR) THEN
+              abort_message = 'Lecture echouee pour <FSIC>'
+              CALL abort_physic(modname,abort_message,1)
+           ENDIF
+           !
+           ! Fraction "terre" 
+           !
+           ierr = NF_INQ_VARID(nid, 'FTER', nvarid)
+           IF (ierr /= NF_NOERR) THEN
+              abort_message = 'Le champ <FTER> est absent'
+              CALL abort_physic(modname,abort_message,1)
+           ENDIF
+           ierr = nf90_get_var(nid,nvarid,pct_tmp(:,is_ter),start,epais)
+           IF (ierr /= NF_NOERR) THEN
+              abort_message = 'Lecture echouee pour <FTER>'
+              CALL abort_physic(modname,abort_message,1)
+           ENDIF
+           !
+           ! Fraction "glacier terre" 
+           !
+           ierr = NF_INQ_VARID(nid, 'FLIC', nvarid)
+           IF (ierr /= NF_NOERR) THEN
+              abort_message = 'Le champ <FLIC> est absent'
+              CALL abort_physic(modname,abort_message,1)
+           ENDIF
+           ierr = nf90_get_var(nid,nvarid,pct_tmp(:,is_lic),start,epais)
+           IF (ierr /= NF_NOERR) THEN
+              abort_message = 'Lecture echouee pour <FLIC>'
+              CALL abort_physic(modname,abort_message,1)
+           ENDIF
+           !
+        ELSE  ! on en est toujours a rnatur
+           ! 
+           ierr = NF_INQ_VARID(nid, 'NAT', nvarid)
+           IF (ierr /= NF_NOERR) THEN
+              abort_message = 'Le champ <NAT> est absent'
+              CALL abort_physic(modname,abort_message,1)
+           ENDIF
+           ierr = nf90_get_var(nid,nvarid,nat_lu,start,epais)
+           IF (ierr /= NF_NOERR) THEN
+              abort_message = 'Lecture echouee pour <NAT>'
+              CALL abort_physic(modname,abort_message,1)
+           ENDIF
+!
+! Remplissage des fractions de surface
+! nat = 0, 1, 2, 3 pour ocean, terre, glacier, seaice
+! 
+           pct_tmp = 0.0
+           DO ii = 1, klon_glo
+              pct_tmp(ii,NINT(nat_lu(ii)) + 1) = 1.
+           ENDDO
+
+!
+!  On se retrouve avec ocean en 1 et terre en 2 alors qu'on veut le contraire
+!
+           pctsrf_new = pct_tmp
+           pctsrf_new (:,2)= pct_tmp (:,1)
+           pctsrf_new (:,1)= pct_tmp (:,2)
+           pct_tmp = pctsrf_new 
+        ENDIF ! fin test sur newlmt
+!
+! Lecture SST
+!
+        ierr = NF_INQ_VARID(nid, 'SST', nvarid)
+        IF (ierr /= NF_NOERR) THEN
+           abort_message = 'Le champ <SST> est absent'
+           CALL abort_physic(modname,abort_message,1)
+        ENDIF
+        ierr = nf90_get_var(nid,nvarid,sst_lu,start,epais)
+        IF (ierr /= NF_NOERR) THEN
+           abort_message = 'Lecture echouee pour <SST>'
+           CALL abort_physic(modname,abort_message,1)
+        ENDIF
+          
+!****************************************************************************************
+! Fin de lecture, fermeture de fichier
+!
+!****************************************************************************************
+        ierr = NF_CLOSE(nid)
+     ENDIF ! is_mpi_root
+
+!$OMP END MASTER
+!$OMP BARRIER
+
+
+!****************************************************************************************
+! Distribue les variables sur tous les processus
+!
+!****************************************************************************************
+     CALL Scatter(sst_lu,sst_lu_p)
+     CALL Scatter(pct_tmp(:,is_oce),pct_tmp_p(:,is_oce))
+     CALL Scatter(pct_tmp(:,is_sic),pct_tmp_p(:,is_sic))
+     deja_lu = .TRUE.
+     jour_lu = jour
+  ENDIF
+
+!****************************************************************************************
+! Recopie des variables dans les champs de sortie
+!
+!****************************************************************************************
+  lmt_sst_p = 999999999.
+  
+  DO ii = 1, knon
+     lmt_sst_p(ii) = sst_lu_p(knindex(ii))
+  ENDDO
+  
+  DO ii=1,klon_loc
+     pctsrf_new_p(ii,is_oce)=pct_tmp_p(ii,is_oce)
+     pctsrf_new_p(ii,is_sic)=pct_tmp_p(ii,is_sic)
+  ENDDO
+  
+  
+END SUBROUTINE interfoce_lim
Index: DZ6/trunk/libf/phylmd/iostart.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/iostart.F90	(revision 5267)
+++ 	(revision )
@@ -1,549 +1,0 @@
-MODULE iostart
-
-PRIVATE
-    INTEGER,SAVE :: nid_start 
-    INTEGER,SAVE :: nid_restart
-    
-    INTEGER,SAVE :: idim1,idim2,idim3,idim4
-    INTEGER,PARAMETER :: length=100
-    
-    INTERFACE get_field
-      MODULE PROCEDURE Get_field_r1,Get_field_r2,Get_field_r3
-    END INTERFACE get_field
-    
-    INTERFACE get_var
-      MODULE PROCEDURE get_var_r0,Get_var_r1,Get_var_r2,Get_var_r3
-    END INTERFACE get_var
-
-    INTERFACE put_field
-      MODULE PROCEDURE put_field_r1,put_field_r2,put_field_r3
-    END INTERFACE put_field
-
-    INTERFACE put_var
-      MODULE PROCEDURE put_var_r0,put_var_r1,put_var_r2,put_var_r3
-    END INTERFACE put_var
-
-    PUBLIC get_field,get_var,put_field,put_var
-    PUBLIC Open_startphy,close_startphy,open_restartphy,close_restartphy, enddef_restartphy
-    
-CONTAINS
-
-  SUBROUTINE Open_startphy(filename)
-  USE netcdf
-  USE mod_phys_lmdz_para
-  IMPLICIT NONE
-    CHARACTER(LEN=*) :: filename
-    INTEGER          :: ierr
-
-    IF (is_mpi_root .AND. is_omp_root) THEN
-      ierr = NF90_OPEN (filename, NF90_NOWRITE,nid_start)
-      IF (ierr.NE.NF90_NOERR) THEN
-        write(6,*)' Pb d''ouverture du fichier '//filename
-        write(6,*)' ierr = ', ierr
-        CALL abort_physic("", "", 1)
-      ENDIF
-    ENDIF
-   
-  END SUBROUTINE Open_startphy
-
-  SUBROUTINE Close_startphy
-  USE netcdf
-  USE mod_phys_lmdz_para
-  IMPLICIT NONE
-    INTEGER          :: ierr
-
-    IF (is_mpi_root .AND. is_omp_root) THEN
-        ierr = NF90_CLOSE (nid_start)
-    ENDIF
-
-  END SUBROUTINE close_startphy
-
-
-  FUNCTION Inquire_Field(Field_name)
-  USE netcdf
-  USE mod_phys_lmdz_para
-  IMPLICIT NONE
-    CHARACTER(LEN=*) :: Field_name
-    LOGICAL :: inquire_field
-    INTEGER :: varid
-    INTEGER :: ierr
-    
-    IF (is_mpi_root .AND. is_omp_root) THEN
-      ierr=NF90_INQ_VARID(nid_start,Field_name,varid)
-      IF (ierr==NF90_NOERR) THEN
-        Inquire_field=.TRUE.
-      ELSE
-        Inquire_field=.FALSE.
-      ENDIF
-    ENDIF
-
-    CALL bcast(Inquire_field)
-
-  END FUNCTION Inquire_Field
-  
- 
-  SUBROUTINE Get_Field_r1(field_name,field,found)
-  IMPLICIT NONE
-    CHARACTER(LEN=*),INTENT(IN)    :: Field_name
-    REAL,INTENT(INOUT)               :: Field(:)
-    LOGICAL,INTENT(OUT),OPTIONAL   :: found 
-
-    CALL Get_field_rgen(field_name,field,1,found)
-      
-  END SUBROUTINE Get_Field_r1
-  
-  SUBROUTINE Get_Field_r2(field_name,field,found)
-  IMPLICIT NONE
-    CHARACTER(LEN=*),INTENT(IN)    :: Field_name
-    REAL,INTENT(INOUT)               :: Field(:,:)
-    LOGICAL,INTENT(OUT),OPTIONAL   :: found 
-
-    CALL Get_field_rgen(field_name,field,size(field,2),found)
-
-      
-  END SUBROUTINE Get_Field_r2
-  
-  SUBROUTINE Get_Field_r3(field_name,field,found)
-  IMPLICIT NONE
-    CHARACTER(LEN=*),INTENT(IN)    :: Field_name
-    REAL,INTENT(INOUT)               :: Field(:,:,:)
-    LOGICAL,INTENT(OUT),OPTIONAL   :: found 
-
-    CALL Get_field_rgen(field_name,field,size(field,2)*size(field,3),found)
-      
-  END SUBROUTINE Get_Field_r3
-  
-  SUBROUTINE Get_field_rgen(field_name,field,field_size,found)
-  USE netcdf
-  USE dimphy
-  USE geometry_mod
-  USE mod_grid_phy_lmdz
-  USE mod_phys_lmdz_para
-  IMPLICIT NONE
-    CHARACTER(LEN=*) :: Field_name
-    INTEGER          :: field_size
-    REAL             :: field(klon,field_size)
-    LOGICAL,OPTIONAL :: found
-    
-    REAL,ALLOCATABLE    :: field_glo(:,:)
-    REAL,ALLOCATABLE    :: field_glo_tmp(:,:)
-    INTEGER,ALLOCATABLE :: ind_cell_glo_glo(:)
-    LOGICAL :: tmp_found
-    INTEGER :: varid
-    INTEGER :: ierr,i
-
-    IF (is_master) THEN 
-      ALLOCATE(ind_cell_glo_glo(klon_glo))
-      ALLOCATE(field_glo(klon_glo,field_size))
-      ALLOCATE(field_glo_tmp(klon_glo,field_size))
-    ELSE
-      ALLOCATE(ind_cell_glo_glo(0))
-      ALLOCATE(field_glo(0,0))
-    ENDIF
-    
-    CALL gather(ind_cell_glo,ind_cell_glo_glo)
-    
-    IF (is_master) THEN
-  
-      ierr=NF90_INQ_VARID(nid_start,Field_name,varid)
-      
-      IF (ierr==NF90_NOERR) THEN
-        CALL body(field_glo_tmp)
-        tmp_found=.TRUE.
-      ELSE
-        tmp_found=.FALSE.
-      ENDIF
-    
-    ENDIF
-    
-    CALL bcast(tmp_found)
-
-    IF (tmp_found) THEN
-      IF (is_master) THEN  
-        DO i=1,klon_glo
-         field_glo(i,:)=field_glo_tmp(ind_cell_glo_glo(i),:)
-        ENDDO
-      ENDIF
-      CALL scatter(field_glo,field)
-    ENDIF
-    
-    IF (PRESENT(found)) THEN
-      found=tmp_found
-    ELSE
-      IF (.NOT. tmp_found) THEN
-        PRINT*, 'phyetat0: Le champ <'//field_name//'> est absent'
-        call abort_physic("", "", 1)
-      ENDIF
-    ENDIF
- 
-    
-    CONTAINS
-     
-     SUBROUTINE body(field_glo)
-       REAL :: field_glo(klon_glo*field_size)
-         ierr=NF90_GET_VAR(nid_start,varid,field_glo)
-         IF (ierr/=NF90_NOERR) THEN
-           ! La variable exist dans le fichier mais la lecture a echouee. 
-           PRINT*, 'phyetat0: Lecture echouee pour <'//field_name//'>'
-
-           IF (field_name=='CLWCON' .OR. field_name=='RNEBCON' .OR. field_name=='RATQS') THEN
-              ! Essaye de lire le variable sur surface uniqument, comme fait avant
-              field_glo(:)=0.
-              ierr=NF90_GET_VAR(nid_start,varid,field_glo(1:klon_glo))
-              IF (ierr/=NF90_NOERR) THEN
-                 PRINT*, 'phyetat0: Lecture echouee aussi en 2D pour <'//field_name//'>'
-                 call abort_physic("", "", 1)
-              ELSE
-                 PRINT*, 'phyetat0: La variable <'//field_name//'> lu sur surface seulement'!, selon ancien format, le reste mis a zero'
-              END IF
-           ELSE
-              call abort_physic("", "", 1)
-           ENDIF
-         ENDIF
-
-     END SUBROUTINE body
-
-  END SUBROUTINE Get_field_rgen
-  
-
-  SUBROUTINE get_var_r0(var_name,var,found)
-  IMPLICIT NONE  
-    CHARACTER(LEN=*),INTENT(IN)  :: var_name
-    REAL,INTENT(INOUT)             :: var
-    LOGICAL,OPTIONAL,INTENT(OUT) :: found
-
-    REAL                         :: varout(1)
-    
-    CALL Get_var_rgen(var_name,varout,size(varout),found)
-    var=varout(1)
- 
-  END SUBROUTINE get_var_r0
-
-  SUBROUTINE get_var_r1(var_name,var,found)
-  IMPLICIT NONE  
-    CHARACTER(LEN=*),INTENT(IN)  :: var_name
-    REAL,INTENT(INOUT)             :: var(:)
-    LOGICAL,OPTIONAL,INTENT(OUT) :: found
-    
-    CALL Get_var_rgen(var_name,var,size(var),found)
-  
-  END SUBROUTINE get_var_r1
-
-  SUBROUTINE get_var_r2(var_name,var,found)
-  IMPLICIT NONE  
-    CHARACTER(LEN=*),INTENT(IN)  :: var_name
-    REAL,INTENT(OUT)             :: var(:,:)
-    LOGICAL,OPTIONAL,INTENT(OUT) :: found
-    
-    CALL Get_var_rgen(var_name,var,size(var),found)
-  
-  END SUBROUTINE get_var_r2
-
-  SUBROUTINE get_var_r3(var_name,var,found)
-  IMPLICIT NONE  
-    CHARACTER(LEN=*),INTENT(IN)  :: var_name
-    REAL,INTENT(INOUT)             :: var(:,:,:)
-    LOGICAL,OPTIONAL,INTENT(OUT) :: found
-    
-    CALL Get_var_rgen(var_name,var,size(var),found)
-  
-  END SUBROUTINE get_var_r3
-
-  SUBROUTINE Get_var_rgen(var_name,var,var_size,found)
-  USE netcdf
-  USE dimphy
-  USE mod_grid_phy_lmdz
-  USE mod_phys_lmdz_para
-  IMPLICIT NONE
-    CHARACTER(LEN=*) :: var_name
-    INTEGER          :: var_size
-    REAL             :: var(var_size)
-    LOGICAL,OPTIONAL :: found
-    
-    LOGICAL :: tmp_found
-    INTEGER :: varid
-    INTEGER :: ierr
-    
-    IF (is_mpi_root .AND. is_omp_root) THEN
-  
-      ierr=NF90_INQ_VARID(nid_start,var_name,varid)
-      
-      IF (ierr==NF90_NOERR) THEN
-        ierr=NF90_GET_VAR(nid_start,varid,var)
-        IF (ierr/=NF90_NOERR) THEN
-          PRINT*, 'phyetat0: Lecture echouee pour <'//var_name//'>'
-          call abort_physic("", "", 1)
-        ENDIF
-        tmp_found=.TRUE.
-      ELSE
-        tmp_found=.FALSE.
-      ENDIF
-    
-    ENDIF
-    
-    CALL bcast(tmp_found)
-
-    IF (tmp_found) THEN
-      CALL bcast(var)
-    ENDIF
-    
-    IF (PRESENT(found)) THEN
-      found=tmp_found
-    ELSE
-      IF (.NOT. tmp_found) THEN
-        PRINT*, 'phyetat0: La variable champ <'//var_name//'> est absente'
-        call abort_physic("", "", 1)
-      ENDIF
-    ENDIF
-
-  END SUBROUTINE Get_var_rgen
-
-
-  SUBROUTINE open_restartphy(filename)
-  USE netcdf
-  USE mod_phys_lmdz_para, ONLY: is_master
-  USE mod_grid_phy_lmdz, ONLY: klon_glo
-  USE dimphy, ONLY: klev, klevp1
-  USE print_control_mod, ONLY: lunout
-  IMPLICIT NONE
-    CHARACTER(LEN=*),INTENT(IN) :: filename
-    INTEGER                     :: ierr
-    
-    IF (is_master) THEN
-      ierr = NF90_CREATE(filename, IOR(NF90_CLOBBER,NF90_64BIT_OFFSET), &
-                          nid_restart)
-      IF (ierr/=NF90_NOERR) THEN
-        write(lunout,*)'open_restartphy: problem creating file '//trim(filename)
-        write(lunout,*)trim(nf90_strerror(ierr))
-        CALL abort_physic("open_restartphy", trim(nf90_strerror(ierr)), 1)
-      ENDIF
-
-      ierr = NF90_PUT_ATT (nid_restart, NF90_GLOBAL, "title","Fichier redemmarage physique")
-
-      ierr = NF90_DEF_DIM (nid_restart, "index", length, idim1)
-      ierr = NF90_DEF_DIM (nid_restart, "points_physiques", klon_glo, idim2)
-      ierr = NF90_DEF_DIM (nid_restart, "horizon_vertical", klon_glo*klev, idim3)
-      ierr = NF90_DEF_DIM (nid_restart, "horizon_klevp1", klon_glo*klevp1, idim4)
-
-!      ierr = NF90_ENDDEF(nid_restart)
-    ENDIF
-
-  END SUBROUTINE open_restartphy
-  
-  SUBROUTINE enddef_restartphy
-  USE netcdf
-  USE mod_phys_lmdz_para
-  IMPLICIT NONE
-    INTEGER          :: ierr
-
-    IF (is_master) ierr = NF90_ENDDEF(nid_restart)
- 
-  END SUBROUTINE enddef_restartphy
-
-  SUBROUTINE close_restartphy
-  USE netcdf
-  USE mod_phys_lmdz_para
-  IMPLICIT NONE
-    INTEGER          :: ierr
-
-    IF (is_master) ierr = NF90_CLOSE (nid_restart)
- 
-  END SUBROUTINE close_restartphy
-
-  
-  SUBROUTINE put_field_r1(pass, field_name,title,field)
-  IMPLICIT NONE
-  INTEGER, INTENT(IN)            :: pass
-  CHARACTER(LEN=*),INTENT(IN)    :: field_name
-  CHARACTER(LEN=*),INTENT(IN)    :: title
-  REAL,INTENT(IN)                :: field(:)
-    CALL put_field_rgen(pass, field_name,title,field,1)
-  
-  END SUBROUTINE put_field_r1
-
-  SUBROUTINE put_field_r2(pass, field_name,title,field)
-  IMPLICIT NONE
-  INTEGER, INTENT(IN)            :: pass
-  CHARACTER(LEN=*),INTENT(IN)    :: field_name
-  CHARACTER(LEN=*),INTENT(IN)    :: title
-  REAL,INTENT(IN)                :: field(:,:)
-  
-    CALL put_field_rgen(pass, field_name,title,field,size(field,2))
-  
-  END SUBROUTINE put_field_r2
-
-  SUBROUTINE put_field_r3(pass, field_name,title,field)
-  IMPLICIT NONE
-  INTEGER, INTENT(IN)            :: pass
-  CHARACTER(LEN=*),INTENT(IN)    :: field_name
-  CHARACTER(LEN=*),INTENT(IN)    :: title
-  REAL,INTENT(IN)                :: field(:,:,:)
-  
-    CALL put_field_rgen(pass, field_name,title,field,size(field,2)*size(field,3))
-  
-  END SUBROUTINE put_field_r3
-  
-  SUBROUTINE put_field_rgen(pass, field_name,title,field,field_size)
-  USE netcdf
-  USE dimphy
-  USE geometry_mod
-  USE mod_grid_phy_lmdz
-  USE mod_phys_lmdz_para
-  USE lmdz_cppkeys_wrapper, ONLY: nf90_format
-  IMPLICIT NONE
-  INTEGER, INTENT(IN)            :: pass
-  CHARACTER(LEN=*),INTENT(IN)    :: field_name
-  CHARACTER(LEN=*),INTENT(IN)    :: title
-  INTEGER,INTENT(IN)             :: field_size
-  REAL,INTENT(IN)                :: field(klon,field_size)
-  
-!  REAL                           :: field_glo(klon_glo,field_size)
-!  REAL                           :: field_glo_tmp(klon_glo,field_size)
-  REAL ,ALLOCATABLE              :: field_glo(:,:)
-  REAL ,ALLOCATABLE              :: field_glo_tmp(:,:)
-  INTEGER,ALLOCATABLE            :: ind_cell_glo_glo(:)
-!  INTEGER                        :: ind_cell_glo_glo(klon_glo)
-  INTEGER                        :: ierr,i
-  INTEGER                        :: nvarid
-  INTEGER                        :: idim
-   
-! first pass : definition   
-  IF (pass==1) THEN
-    
-    IF (is_master) THEN
-
-      IF (field_size==1) THEN
-        idim=idim2
-      ELSE IF (field_size==klev) THEN
-        idim=idim3
-      ELSE IF (field_size==klevp1) THEN
-        idim=idim4
-      ELSE
-        PRINT *, "erreur phyredem : probleme de dimension"
-        CALL abort_physic("", "", 1)
-      ENDIF
-         
-!      ierr = NF90_REDEF (nid_restart)
-      ierr = NF90_DEF_VAR (nid_restart, field_name, nf90_format,(/ idim /),nvarid)
-      IF (LEN_TRIM(title) > 0) ierr = NF90_PUT_ATT (nid_restart,nvarid,"title", title)
-!      ierr = NF90_ENDDEF(nid_restart)
-     ENDIF
-
-! second pass : write     
-   ELSE IF (pass==2) THEN 
-    
-     IF (is_master) THEN
-       ALLOCATE(ind_cell_glo_glo(klon_glo))
-       ALLOCATE(field_glo(klon_glo,field_size))
-       ALLOCATE(field_glo_tmp(klon_glo,field_size))
-     ELSE
-       ALLOCATE(ind_cell_glo_glo(0))
-       ALLOCATE(field_glo_tmp(0,0))
-     ENDIF
-     
-     CALL gather(ind_cell_glo,ind_cell_glo_glo) 
-
-     CALL gather(field,field_glo_tmp)
-    
-     IF (is_master) THEN
-
-       DO i=1,klon_glo
-         field_glo(ind_cell_glo_glo(i),:)=field_glo_tmp(i,:)
-       ENDDO
-
-       ierr = NF90_INQ_VARID(nid_restart, field_name, nvarid)
-       ierr = NF90_PUT_VAR(nid_restart,nvarid,RESHAPE(field_glo,(/klon_glo*field_size/)))
-      ENDIF
-   ENDIF
-    
- END SUBROUTINE put_field_rgen  
-  
-
- SUBROUTINE put_var_r0(pass, var_name,title,var)
-   IMPLICIT NONE
-     INTEGER, INTENT(IN)            :: pass
-     CHARACTER(LEN=*),INTENT(IN) :: var_name
-     CHARACTER(LEN=*),INTENT(IN) :: title
-     REAL,INTENT(IN)             :: var
-     REAL                        :: varin(1)
-     
-     varin(1)=var
-     
-     CALL put_var_rgen(pass, var_name,title,varin,size(varin))
-
-  END SUBROUTINE put_var_r0
-
-
-   SUBROUTINE put_var_r1(pass, var_name,title,var)
-   IMPLICIT NONE
-     INTEGER, INTENT(IN)            :: pass
-     CHARACTER(LEN=*),INTENT(IN) :: var_name
-     CHARACTER(LEN=*),INTENT(IN) :: title
-     REAL,INTENT(IN)             :: var(:)
-     
-     CALL put_var_rgen(pass, var_name,title,var,size(var))
-
-  END SUBROUTINE put_var_r1
- 
-  SUBROUTINE put_var_r2(pass, var_name,title,var)
-   IMPLICIT NONE
-     INTEGER, INTENT(IN)            :: pass
-     CHARACTER(LEN=*),INTENT(IN) :: var_name
-     CHARACTER(LEN=*),INTENT(IN) :: title
-     REAL,INTENT(IN)             :: var(:,:)
-     
-     CALL put_var_rgen(pass, var_name,title,var,size(var))
-
-  END SUBROUTINE put_var_r2     
-  
-  SUBROUTINE put_var_r3(pass, var_name,title,var)
-   IMPLICIT NONE
-     INTEGER, INTENT(IN)            :: pass
-     CHARACTER(LEN=*),INTENT(IN) :: var_name
-     CHARACTER(LEN=*),INTENT(IN) :: title
-     REAL,INTENT(IN)             :: var(:,:,:)
-     
-     CALL put_var_rgen(pass, var_name,title,var,size(var))
-
-  END SUBROUTINE put_var_r3
-
-  SUBROUTINE put_var_rgen(pass, var_name,title,var,var_size)
-  USE netcdf
-  USE dimphy
-  USE mod_phys_lmdz_para
-  USE lmdz_cppkeys_wrapper, ONLY: nf90_format
-  IMPLICIT NONE
-    INTEGER, INTENT(IN)         :: pass
-    CHARACTER(LEN=*),INTENT(IN) :: var_name
-    CHARACTER(LEN=*),INTENT(IN) :: title
-    INTEGER,INTENT(IN)          :: var_size
-    REAL,INTENT(IN)             :: var(var_size)
-    
-    INTEGER :: ierr
-    INTEGER :: nvarid
-         
-    IF (is_master) THEN
-
-      IF (var_size/=length) THEN
-        PRINT *, "erreur phyredem : probleme de dimension"
-        call abort_physic("", "", 1)
-      ENDIF
-
-     ! first pass : definition   
-      IF (pass==1) THEN
-        
-!      ierr = NF90_REDEF (nid_restart)
-        ierr = NF90_DEF_VAR (nid_restart, var_name, nf90_format,(/ idim1 /),nvarid)
-        IF (LEN_TRIM(title)>0) ierr = NF90_PUT_ATT (nid_restart,nvarid,"title", title)
-!      ierr = NF90_ENDDEF(nid_restart)
-
-    ! second pass : write     
-      ELSE IF (pass==2) THEN 
-        ierr = NF90_INQ_VARID(nid_restart, var_name, nvarid)
-        ierr = NF90_PUT_VAR(nid_restart,nvarid,var)
-      ENDIF
-    ENDIF
-    
-  END SUBROUTINE put_var_rgen     
-    
-END MODULE iostart
Index: /LMDZ6/trunk/libf/phylmd/iostart.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/iostart.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/iostart.f90	(revision 5268)
@@ -0,0 +1,549 @@
+MODULE iostart
+
+PRIVATE
+    INTEGER,SAVE :: nid_start 
+    INTEGER,SAVE :: nid_restart
+    
+    INTEGER,SAVE :: idim1,idim2,idim3,idim4
+    INTEGER,PARAMETER :: length=100
+    
+    INTERFACE get_field
+      MODULE PROCEDURE Get_field_r1,Get_field_r2,Get_field_r3
+    END INTERFACE get_field
+    
+    INTERFACE get_var
+      MODULE PROCEDURE get_var_r0,Get_var_r1,Get_var_r2,Get_var_r3
+    END INTERFACE get_var
+
+    INTERFACE put_field
+      MODULE PROCEDURE put_field_r1,put_field_r2,put_field_r3
+    END INTERFACE put_field
+
+    INTERFACE put_var
+      MODULE PROCEDURE put_var_r0,put_var_r1,put_var_r2,put_var_r3
+    END INTERFACE put_var
+
+    PUBLIC get_field,get_var,put_field,put_var
+    PUBLIC Open_startphy,close_startphy,open_restartphy,close_restartphy, enddef_restartphy
+    
+CONTAINS
+
+  SUBROUTINE Open_startphy(filename)
+  USE netcdf
+  USE mod_phys_lmdz_para
+  IMPLICIT NONE
+    CHARACTER(LEN=*) :: filename
+    INTEGER          :: ierr
+
+    IF (is_mpi_root .AND. is_omp_root) THEN
+      ierr = NF90_OPEN (filename, NF90_NOWRITE,nid_start)
+      IF (ierr.NE.NF90_NOERR) THEN
+        write(6,*)' Pb d''ouverture du fichier '//filename
+        write(6,*)' ierr = ', ierr
+        CALL abort_physic("", "", 1)
+      ENDIF
+    ENDIF
+   
+  END SUBROUTINE Open_startphy
+
+  SUBROUTINE Close_startphy
+  USE netcdf
+  USE mod_phys_lmdz_para
+  IMPLICIT NONE
+    INTEGER          :: ierr
+
+    IF (is_mpi_root .AND. is_omp_root) THEN
+        ierr = NF90_CLOSE (nid_start)
+    ENDIF
+
+  END SUBROUTINE close_startphy
+
+
+  FUNCTION Inquire_Field(Field_name)
+  USE netcdf
+  USE mod_phys_lmdz_para
+  IMPLICIT NONE
+    CHARACTER(LEN=*) :: Field_name
+    LOGICAL :: inquire_field
+    INTEGER :: varid
+    INTEGER :: ierr
+    
+    IF (is_mpi_root .AND. is_omp_root) THEN
+      ierr=NF90_INQ_VARID(nid_start,Field_name,varid)
+      IF (ierr==NF90_NOERR) THEN
+        Inquire_field=.TRUE.
+      ELSE
+        Inquire_field=.FALSE.
+      ENDIF
+    ENDIF
+
+    CALL bcast(Inquire_field)
+
+  END FUNCTION Inquire_Field
+  
+ 
+  SUBROUTINE Get_Field_r1(field_name,field,found)
+  IMPLICIT NONE
+    CHARACTER(LEN=*),INTENT(IN)    :: Field_name
+    REAL,INTENT(INOUT)               :: Field(:)
+    LOGICAL,INTENT(OUT),OPTIONAL   :: found 
+
+    CALL Get_field_rgen(field_name,field,1,found)
+      
+  END SUBROUTINE Get_Field_r1
+  
+  SUBROUTINE Get_Field_r2(field_name,field,found)
+  IMPLICIT NONE
+    CHARACTER(LEN=*),INTENT(IN)    :: Field_name
+    REAL,INTENT(INOUT)               :: Field(:,:)
+    LOGICAL,INTENT(OUT),OPTIONAL   :: found 
+
+    CALL Get_field_rgen(field_name,field,size(field,2),found)
+
+      
+  END SUBROUTINE Get_Field_r2
+  
+  SUBROUTINE Get_Field_r3(field_name,field,found)
+  IMPLICIT NONE
+    CHARACTER(LEN=*),INTENT(IN)    :: Field_name
+    REAL,INTENT(INOUT)               :: Field(:,:,:)
+    LOGICAL,INTENT(OUT),OPTIONAL   :: found 
+
+    CALL Get_field_rgen(field_name,field,size(field,2)*size(field,3),found)
+      
+  END SUBROUTINE Get_Field_r3
+  
+  SUBROUTINE Get_field_rgen(field_name,field,field_size,found)
+  USE netcdf
+  USE dimphy
+  USE geometry_mod
+  USE mod_grid_phy_lmdz
+  USE mod_phys_lmdz_para
+  IMPLICIT NONE
+    CHARACTER(LEN=*) :: Field_name
+    INTEGER          :: field_size
+    REAL             :: field(klon,field_size)
+    LOGICAL,OPTIONAL :: found
+    
+    REAL,ALLOCATABLE    :: field_glo(:,:)
+    REAL,ALLOCATABLE    :: field_glo_tmp(:,:)
+    INTEGER,ALLOCATABLE :: ind_cell_glo_glo(:)
+    LOGICAL :: tmp_found
+    INTEGER :: varid
+    INTEGER :: ierr,i
+
+    IF (is_master) THEN 
+      ALLOCATE(ind_cell_glo_glo(klon_glo))
+      ALLOCATE(field_glo(klon_glo,field_size))
+      ALLOCATE(field_glo_tmp(klon_glo,field_size))
+    ELSE
+      ALLOCATE(ind_cell_glo_glo(0))
+      ALLOCATE(field_glo(0,0))
+    ENDIF
+    
+    CALL gather(ind_cell_glo,ind_cell_glo_glo)
+    
+    IF (is_master) THEN
+  
+      ierr=NF90_INQ_VARID(nid_start,Field_name,varid)
+      
+      IF (ierr==NF90_NOERR) THEN
+        CALL body(field_glo_tmp)
+        tmp_found=.TRUE.
+      ELSE
+        tmp_found=.FALSE.
+      ENDIF
+    
+    ENDIF
+    
+    CALL bcast(tmp_found)
+
+    IF (tmp_found) THEN
+      IF (is_master) THEN  
+        DO i=1,klon_glo
+         field_glo(i,:)=field_glo_tmp(ind_cell_glo_glo(i),:)
+        ENDDO
+      ENDIF
+      CALL scatter(field_glo,field)
+    ENDIF
+    
+    IF (PRESENT(found)) THEN
+      found=tmp_found
+    ELSE
+      IF (.NOT. tmp_found) THEN
+        PRINT*, 'phyetat0: Le champ <'//field_name//'> est absent'
+        call abort_physic("", "", 1)
+      ENDIF
+    ENDIF
+ 
+    
+    CONTAINS
+     
+     SUBROUTINE body(field_glo)
+       REAL :: field_glo(klon_glo*field_size)
+         ierr=NF90_GET_VAR(nid_start,varid,field_glo)
+         IF (ierr/=NF90_NOERR) THEN
+           ! La variable exist dans le fichier mais la lecture a echouee. 
+           PRINT*, 'phyetat0: Lecture echouee pour <'//field_name//'>'
+
+           IF (field_name=='CLWCON' .OR. field_name=='RNEBCON' .OR. field_name=='RATQS') THEN
+              ! Essaye de lire le variable sur surface uniqument, comme fait avant
+              field_glo(:)=0.
+              ierr=NF90_GET_VAR(nid_start,varid,field_glo(1:klon_glo))
+              IF (ierr/=NF90_NOERR) THEN
+                 PRINT*, 'phyetat0: Lecture echouee aussi en 2D pour <'//field_name//'>'
+                 call abort_physic("", "", 1)
+              ELSE
+                 PRINT*, 'phyetat0: La variable <'//field_name//'> lu sur surface seulement'!, selon ancien format, le reste mis a zero'
+              END IF
+           ELSE
+              call abort_physic("", "", 1)
+           ENDIF
+         ENDIF
+
+     END SUBROUTINE body
+
+  END SUBROUTINE Get_field_rgen
+  
+
+  SUBROUTINE get_var_r0(var_name,var,found)
+  IMPLICIT NONE  
+    CHARACTER(LEN=*),INTENT(IN)  :: var_name
+    REAL,INTENT(INOUT)             :: var
+    LOGICAL,OPTIONAL,INTENT(OUT) :: found
+
+    REAL                         :: varout(1)
+    
+    CALL Get_var_rgen(var_name,varout,size(varout),found)
+    var=varout(1)
+ 
+  END SUBROUTINE get_var_r0
+
+  SUBROUTINE get_var_r1(var_name,var,found)
+  IMPLICIT NONE  
+    CHARACTER(LEN=*),INTENT(IN)  :: var_name
+    REAL,INTENT(INOUT)             :: var(:)
+    LOGICAL,OPTIONAL,INTENT(OUT) :: found
+    
+    CALL Get_var_rgen(var_name,var,size(var),found)
+  
+  END SUBROUTINE get_var_r1
+
+  SUBROUTINE get_var_r2(var_name,var,found)
+  IMPLICIT NONE  
+    CHARACTER(LEN=*),INTENT(IN)  :: var_name
+    REAL,INTENT(OUT)             :: var(:,:)
+    LOGICAL,OPTIONAL,INTENT(OUT) :: found
+    
+    CALL Get_var_rgen(var_name,var,size(var),found)
+  
+  END SUBROUTINE get_var_r2
+
+  SUBROUTINE get_var_r3(var_name,var,found)
+  IMPLICIT NONE  
+    CHARACTER(LEN=*),INTENT(IN)  :: var_name
+    REAL,INTENT(INOUT)             :: var(:,:,:)
+    LOGICAL,OPTIONAL,INTENT(OUT) :: found
+    
+    CALL Get_var_rgen(var_name,var,size(var),found)
+  
+  END SUBROUTINE get_var_r3
+
+  SUBROUTINE Get_var_rgen(var_name,var,var_size,found)
+  USE netcdf
+  USE dimphy
+  USE mod_grid_phy_lmdz
+  USE mod_phys_lmdz_para
+  IMPLICIT NONE
+    CHARACTER(LEN=*) :: var_name
+    INTEGER          :: var_size
+    REAL             :: var(var_size)
+    LOGICAL,OPTIONAL :: found
+    
+    LOGICAL :: tmp_found
+    INTEGER :: varid
+    INTEGER :: ierr
+    
+    IF (is_mpi_root .AND. is_omp_root) THEN
+  
+      ierr=NF90_INQ_VARID(nid_start,var_name,varid)
+      
+      IF (ierr==NF90_NOERR) THEN
+        ierr=NF90_GET_VAR(nid_start,varid,var)
+        IF (ierr/=NF90_NOERR) THEN
+          PRINT*, 'phyetat0: Lecture echouee pour <'//var_name//'>'
+          call abort_physic("", "", 1)
+        ENDIF
+        tmp_found=.TRUE.
+      ELSE
+        tmp_found=.FALSE.
+      ENDIF
+    
+    ENDIF
+    
+    CALL bcast(tmp_found)
+
+    IF (tmp_found) THEN
+      CALL bcast(var)
+    ENDIF
+    
+    IF (PRESENT(found)) THEN
+      found=tmp_found
+    ELSE
+      IF (.NOT. tmp_found) THEN
+        PRINT*, 'phyetat0: La variable champ <'//var_name//'> est absente'
+        call abort_physic("", "", 1)
+      ENDIF
+    ENDIF
+
+  END SUBROUTINE Get_var_rgen
+
+
+  SUBROUTINE open_restartphy(filename)
+  USE netcdf
+  USE mod_phys_lmdz_para, ONLY: is_master
+  USE mod_grid_phy_lmdz, ONLY: klon_glo
+  USE dimphy, ONLY: klev, klevp1
+  USE print_control_mod, ONLY: lunout
+  IMPLICIT NONE
+    CHARACTER(LEN=*),INTENT(IN) :: filename
+    INTEGER                     :: ierr
+    
+    IF (is_master) THEN
+      ierr = NF90_CREATE(filename, IOR(NF90_CLOBBER,NF90_64BIT_OFFSET), &
+                          nid_restart)
+      IF (ierr/=NF90_NOERR) THEN
+        write(lunout,*)'open_restartphy: problem creating file '//trim(filename)
+        write(lunout,*)trim(nf90_strerror(ierr))
+        CALL abort_physic("open_restartphy", trim(nf90_strerror(ierr)), 1)
+      ENDIF
+
+      ierr = NF90_PUT_ATT (nid_restart, NF90_GLOBAL, "title","Fichier redemmarage physique")
+
+      ierr = NF90_DEF_DIM (nid_restart, "index", length, idim1)
+      ierr = NF90_DEF_DIM (nid_restart, "points_physiques", klon_glo, idim2)
+      ierr = NF90_DEF_DIM (nid_restart, "horizon_vertical", klon_glo*klev, idim3)
+      ierr = NF90_DEF_DIM (nid_restart, "horizon_klevp1", klon_glo*klevp1, idim4)
+
+!      ierr = NF90_ENDDEF(nid_restart)
+    ENDIF
+
+  END SUBROUTINE open_restartphy
+  
+  SUBROUTINE enddef_restartphy
+  USE netcdf
+  USE mod_phys_lmdz_para
+  IMPLICIT NONE
+    INTEGER          :: ierr
+
+    IF (is_master) ierr = NF90_ENDDEF(nid_restart)
+ 
+  END SUBROUTINE enddef_restartphy
+
+  SUBROUTINE close_restartphy
+  USE netcdf
+  USE mod_phys_lmdz_para
+  IMPLICIT NONE
+    INTEGER          :: ierr
+
+    IF (is_master) ierr = NF90_CLOSE (nid_restart)
+ 
+  END SUBROUTINE close_restartphy
+
+  
+  SUBROUTINE put_field_r1(pass, field_name,title,field)
+  IMPLICIT NONE
+  INTEGER, INTENT(IN)            :: pass
+  CHARACTER(LEN=*),INTENT(IN)    :: field_name
+  CHARACTER(LEN=*),INTENT(IN)    :: title
+  REAL,INTENT(IN)                :: field(:)
+    CALL put_field_rgen(pass, field_name,title,field,1)
+  
+  END SUBROUTINE put_field_r1
+
+  SUBROUTINE put_field_r2(pass, field_name,title,field)
+  IMPLICIT NONE
+  INTEGER, INTENT(IN)            :: pass
+  CHARACTER(LEN=*),INTENT(IN)    :: field_name
+  CHARACTER(LEN=*),INTENT(IN)    :: title
+  REAL,INTENT(IN)                :: field(:,:)
+  
+    CALL put_field_rgen(pass, field_name,title,field,size(field,2))
+  
+  END SUBROUTINE put_field_r2
+
+  SUBROUTINE put_field_r3(pass, field_name,title,field)
+  IMPLICIT NONE
+  INTEGER, INTENT(IN)            :: pass
+  CHARACTER(LEN=*),INTENT(IN)    :: field_name
+  CHARACTER(LEN=*),INTENT(IN)    :: title
+  REAL,INTENT(IN)                :: field(:,:,:)
+  
+    CALL put_field_rgen(pass, field_name,title,field,size(field,2)*size(field,3))
+  
+  END SUBROUTINE put_field_r3
+  
+  SUBROUTINE put_field_rgen(pass, field_name,title,field,field_size)
+  USE netcdf
+  USE dimphy
+  USE geometry_mod
+  USE mod_grid_phy_lmdz
+  USE mod_phys_lmdz_para
+  USE lmdz_cppkeys_wrapper, ONLY: nf90_format
+  IMPLICIT NONE
+  INTEGER, INTENT(IN)            :: pass
+  CHARACTER(LEN=*),INTENT(IN)    :: field_name
+  CHARACTER(LEN=*),INTENT(IN)    :: title
+  INTEGER,INTENT(IN)             :: field_size
+  REAL,INTENT(IN)                :: field(klon,field_size)
+  
+!  REAL                           :: field_glo(klon_glo,field_size)
+!  REAL                           :: field_glo_tmp(klon_glo,field_size)
+  REAL ,ALLOCATABLE              :: field_glo(:,:)
+  REAL ,ALLOCATABLE              :: field_glo_tmp(:,:)
+  INTEGER,ALLOCATABLE            :: ind_cell_glo_glo(:)
+!  INTEGER                        :: ind_cell_glo_glo(klon_glo)
+  INTEGER                        :: ierr,i
+  INTEGER                        :: nvarid
+  INTEGER                        :: idim
+   
+! first pass : definition   
+  IF (pass==1) THEN
+    
+    IF (is_master) THEN
+
+      IF (field_size==1) THEN
+        idim=idim2
+      ELSE IF (field_size==klev) THEN
+        idim=idim3
+      ELSE IF (field_size==klevp1) THEN
+        idim=idim4
+      ELSE
+        PRINT *, "erreur phyredem : probleme de dimension"
+        CALL abort_physic("", "", 1)
+      ENDIF
+         
+!      ierr = NF90_REDEF (nid_restart)
+      ierr = NF90_DEF_VAR (nid_restart, field_name, nf90_format,(/ idim /),nvarid)
+      IF (LEN_TRIM(title) > 0) ierr = NF90_PUT_ATT (nid_restart,nvarid,"title", title)
+!      ierr = NF90_ENDDEF(nid_restart)
+     ENDIF
+
+! second pass : write     
+   ELSE IF (pass==2) THEN 
+    
+     IF (is_master) THEN
+       ALLOCATE(ind_cell_glo_glo(klon_glo))
+       ALLOCATE(field_glo(klon_glo,field_size))
+       ALLOCATE(field_glo_tmp(klon_glo,field_size))
+     ELSE
+       ALLOCATE(ind_cell_glo_glo(0))
+       ALLOCATE(field_glo_tmp(0,0))
+     ENDIF
+     
+     CALL gather(ind_cell_glo,ind_cell_glo_glo) 
+
+     CALL gather(field,field_glo_tmp)
+    
+     IF (is_master) THEN
+
+       DO i=1,klon_glo
+         field_glo(ind_cell_glo_glo(i),:)=field_glo_tmp(i,:)
+       ENDDO
+
+       ierr = NF90_INQ_VARID(nid_restart, field_name, nvarid)
+       ierr = NF90_PUT_VAR(nid_restart,nvarid,RESHAPE(field_glo,(/klon_glo*field_size/)))
+      ENDIF
+   ENDIF
+    
+ END SUBROUTINE put_field_rgen  
+  
+
+ SUBROUTINE put_var_r0(pass, var_name,title,var)
+   IMPLICIT NONE
+     INTEGER, INTENT(IN)            :: pass
+     CHARACTER(LEN=*),INTENT(IN) :: var_name
+     CHARACTER(LEN=*),INTENT(IN) :: title
+     REAL,INTENT(IN)             :: var
+     REAL                        :: varin(1)
+     
+     varin(1)=var
+     
+     CALL put_var_rgen(pass, var_name,title,varin,size(varin))
+
+  END SUBROUTINE put_var_r0
+
+
+   SUBROUTINE put_var_r1(pass, var_name,title,var)
+   IMPLICIT NONE
+     INTEGER, INTENT(IN)            :: pass
+     CHARACTER(LEN=*),INTENT(IN) :: var_name
+     CHARACTER(LEN=*),INTENT(IN) :: title
+     REAL,INTENT(IN)             :: var(:)
+     
+     CALL put_var_rgen(pass, var_name,title,var,size(var))
+
+  END SUBROUTINE put_var_r1
+ 
+  SUBROUTINE put_var_r2(pass, var_name,title,var)
+   IMPLICIT NONE
+     INTEGER, INTENT(IN)            :: pass
+     CHARACTER(LEN=*),INTENT(IN) :: var_name
+     CHARACTER(LEN=*),INTENT(IN) :: title
+     REAL,INTENT(IN)             :: var(:,:)
+     
+     CALL put_var_rgen(pass, var_name,title,var,size(var))
+
+  END SUBROUTINE put_var_r2     
+  
+  SUBROUTINE put_var_r3(pass, var_name,title,var)
+   IMPLICIT NONE
+     INTEGER, INTENT(IN)            :: pass
+     CHARACTER(LEN=*),INTENT(IN) :: var_name
+     CHARACTER(LEN=*),INTENT(IN) :: title
+     REAL,INTENT(IN)             :: var(:,:,:)
+     
+     CALL put_var_rgen(pass, var_name,title,var,size(var))
+
+  END SUBROUTINE put_var_r3
+
+  SUBROUTINE put_var_rgen(pass, var_name,title,var,var_size)
+  USE netcdf
+  USE dimphy
+  USE mod_phys_lmdz_para
+  USE lmdz_cppkeys_wrapper, ONLY: nf90_format
+  IMPLICIT NONE
+    INTEGER, INTENT(IN)         :: pass
+    CHARACTER(LEN=*),INTENT(IN) :: var_name
+    CHARACTER(LEN=*),INTENT(IN) :: title
+    INTEGER,INTENT(IN)          :: var_size
+    REAL,INTENT(IN)             :: var(var_size)
+    
+    INTEGER :: ierr
+    INTEGER :: nvarid
+         
+    IF (is_master) THEN
+
+      IF (var_size/=length) THEN
+        PRINT *, "erreur phyredem : probleme de dimension"
+        call abort_physic("", "", 1)
+      ENDIF
+
+     ! first pass : definition   
+      IF (pass==1) THEN
+        
+!      ierr = NF90_REDEF (nid_restart)
+        ierr = NF90_DEF_VAR (nid_restart, var_name, nf90_format,(/ idim1 /),nvarid)
+        IF (LEN_TRIM(title)>0) ierr = NF90_PUT_ATT (nid_restart,nvarid,"title", title)
+!      ierr = NF90_ENDDEF(nid_restart)
+
+    ! second pass : write     
+      ELSE IF (pass==2) THEN 
+        ierr = NF90_INQ_VARID(nid_restart, var_name, nvarid)
+        ierr = NF90_PUT_VAR(nid_restart,nvarid,var)
+      ENDIF
+    ENDIF
+    
+  END SUBROUTINE put_var_rgen     
+    
+END MODULE iostart
Index: DZ6/trunk/libf/phylmd/iotd_ecrit.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/iotd_ecrit.F90	(revision 5267)
+++ 	(revision )
@@ -1,184 +1,0 @@
-      subroutine iotd_ecrit(nom,llm,titre,unite,px)
-
-
-!=======================================================================
-!
-!   Auteur:  F. Hourdin
-!   -------
-!
-!   Objet:
-!   ------
-!   Light interface for netcdf outputs. can be used outside LMDZ
-!
-!=======================================================================
-!-----------------------------------------------------------------------
-!  ----------
-!      nom  : nom de la variable a sortir (chaine de caracteres)
-!      llm  : nombre de couches
-!      titre: titre de la variable (chaine de caracteres)
-!      unite : unite de la variable (chaine de caracteres)
-!      px : variable a sortir
-!
-!=================================================================
- 
-      use netcdf, only: nf90_put_var
-      implicit none
-
-! Commons
-
-      INCLUDE "netcdf.inc"
-      INCLUDE "iotd.h"
-
-
-! Arguments on input:
-      integer llm
-      character (len=*) :: nom,titre,unite
-      integer imjmax
-      parameter (imjmax=100000)
-      real px(imjmax*llm)
-
-! Local variables:
-
-      real*4 date
-      real*4 zx(imjmax*llm)
-
-
-      integer ierr,ndim,dim_cc(4)
-      integer iq
-      integer i,j,l
-
-      integer zitau
-      character firstnom*20
-      SAVE firstnom
-      SAVE zitau
-      SAVE date
-      data firstnom /'1234567890'/
-      data zitau /0/
-
-! Ajouts
-      integer, save :: ntime=0
-      integer :: idim,varid
-      character (len =50):: fichnom
-      integer, dimension(4) :: id
-      integer, dimension(4) :: edges,corner
-      
-
-
-       if (n_names_iotd_def>0 .and..not.any(names_iotd_def==nom)) return
-!***************************************************************
-! Initialisation of 'firstnom' and create/open the "diagfi.nc" NetCDF file
-! ------------------------------------------------------------------------
-! (Au tout premier appel de la subroutine durant le run.)
-
-
-!--------------------------------------------------------
-! Write the variables to output file if it's time to do so
-!--------------------------------------------------------
-
-
-! Compute/write/extend 'time' coordinate (date given in days)
-! (done every "first call" (at given time level) to writediagfi)
-! Note: date is incremented as 1 step ahead of physics time
-!--------------------------------------------------------
-
-        zx(1:imax*jmax*llm)=px(1:imax*jmax*llm)
-        if (firstnom =='1234567890') then
-            firstnom=nom
-        endif
-
-       !print*,'nom ',nom,firstnom
-
-!! Quand on tombe sur la premiere variable on ajoute un pas de temps
-        if (nom.eq.firstnom) then
-        ! We have identified a "first call" (at given date)
-
-           ntime=ntime+1 ! increment # of stored time steps
-
-!!          print*,'ntime ',ntime
-           date=iotd_t0+ntime*iotd_ts
-           !print*,'iotd_ecrit ',iotd_ts,ntime, date
-!          date= float (zitau +1)/float (day_step)
-
-           ! compute corresponding date (in days and fractions thereof)
-           ! Get NetCDF ID of 'time' variable
-
-           ierr=NF_SYNC(nid)
-
-           ierr= NF_INQ_VARID(nid,"time",varid)
-           ! Write (append) the new date to the 'time' array
-
-
-           ierr= NF90_PUT_VAR(nid,varid,date,[ntime])
-
-!          print*,'date ',date,ierr,nid
-!        print*,'IOTD Date ,varid,nid,ntime,date',varid,nid,ntime,date
-
-           if (ierr.ne.NF_NOERR) then
-              write(*,*) "***** PUT_VAR matter in writediagfi_nc"
-              write(*,*) "***** with time"
-              write(*,*) 'ierr=', ierr   
-           endif
-
-!          write(6,*)'WRITEDIAGFI: date= ', date
-        end if ! of if (nom.eq.firstnom)
-
-
-!Case of a 3D variable
-!---------------------
-        if (llm==lmax) then
-           ndim=4
-           corner(1)=1
-           corner(2)=1
-           corner(3)=1
-           corner(4)=ntime
-           edges(1)=imax
-           edges(2)=jmax
-           edges(3)=llm
-           edges(4)=1
-           dim_cc=dim_coord
-
-
-!Case of a 2D variable
-!---------------------
-
-        else if (llm==1) then
-           ndim=3
-           corner(1)=1
-           corner(2)=1
-           corner(3)=ntime
-           corner(4)=1
-           edges(1)=imax
-           edges(2)=jmax
-           edges(3)=1
-           edges(4)=1
-           dim_cc(1:2)=dim_coord(1:2)
-           dim_cc(3)=dim_coord(4)
-
-        endif ! of if llm=1 ou llm
-
-! AU premier pas de temps, on crée les variables
-!-----------------------------------------------
-
-      if (ntime==1) then
-          ierr = NF_REDEF (nid)
-          ierr = NF_DEF_VAR(nid,nom,NF_FLOAT,ndim,dim_cc,varid)
-          !print*,'DEF ',nom,nid,varid
-          ierr = NF_ENDDEF(nid)
-      else
-         ierr= NF_INQ_VARID(nid,nom,varid)
-          !print*,'INQ ',nom,nid,varid
-! Commandes pour recuperer automatiquement les coordonnees
-!             ierr= NF_INQ_DIMID(nid,"longitude",id(1))
-      endif
-
-
-      ierr= NF90_PUT_VAR(nid,varid,zx,corner,edges)
-
-      if (ierr.ne.NF_NOERR) then
-           write(*,*) "***** PUT_VAR problem in writediagfi"
-           write(*,*) "***** with ",nom
-           write(*,*) 'ierr=', ierr
-      endif 
-
-
-      end
Index: /LMDZ6/trunk/libf/phylmd/iotd_ecrit.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/iotd_ecrit.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/iotd_ecrit.f90	(revision 5268)
@@ -0,0 +1,184 @@
+      subroutine iotd_ecrit(nom,llm,titre,unite,px)
+
+
+!=======================================================================
+!
+!   Auteur:  F. Hourdin
+!   -------
+!
+!   Objet:
+!   ------
+!   Light interface for netcdf outputs. can be used outside LMDZ
+!
+!=======================================================================
+!-----------------------------------------------------------------------
+!  ----------
+!      nom  : nom de la variable a sortir (chaine de caracteres)
+!      llm  : nombre de couches
+!      titre: titre de la variable (chaine de caracteres)
+!      unite : unite de la variable (chaine de caracteres)
+!      px : variable a sortir
+!
+!=================================================================
+ 
+      use netcdf, only: nf90_put_var
+      implicit none
+
+! Commons
+
+      INCLUDE "netcdf.inc"
+      INCLUDE "iotd.h"
+
+
+! Arguments on input:
+      integer llm
+      character (len=*) :: nom,titre,unite
+      integer imjmax
+      parameter (imjmax=100000)
+      real px(imjmax*llm)
+
+! Local variables:
+
+      real*4 date
+      real*4 zx(imjmax*llm)
+
+
+      integer ierr,ndim,dim_cc(4)
+      integer iq
+      integer i,j,l
+
+      integer zitau
+      character firstnom*20
+      SAVE firstnom
+      SAVE zitau
+      SAVE date
+      data firstnom /'1234567890'/
+      data zitau /0/
+
+! Ajouts
+      integer, save :: ntime=0
+      integer :: idim,varid
+      character (len =50):: fichnom
+      integer, dimension(4) :: id
+      integer, dimension(4) :: edges,corner
+      
+
+
+       if (n_names_iotd_def>0 .and..not.any(names_iotd_def==nom)) return
+!***************************************************************
+! Initialisation of 'firstnom' and create/open the "diagfi.nc" NetCDF file
+! ------------------------------------------------------------------------
+! (Au tout premier appel de la subroutine durant le run.)
+
+
+!--------------------------------------------------------
+! Write the variables to output file if it's time to do so
+!--------------------------------------------------------
+
+
+! Compute/write/extend 'time' coordinate (date given in days)
+! (done every "first call" (at given time level) to writediagfi)
+! Note: date is incremented as 1 step ahead of physics time
+!--------------------------------------------------------
+
+        zx(1:imax*jmax*llm)=px(1:imax*jmax*llm)
+        if (firstnom =='1234567890') then
+            firstnom=nom
+        endif
+
+       !print*,'nom ',nom,firstnom
+
+!! Quand on tombe sur la premiere variable on ajoute un pas de temps
+        if (nom.eq.firstnom) then
+        ! We have identified a "first call" (at given date)
+
+           ntime=ntime+1 ! increment # of stored time steps
+
+!!          print*,'ntime ',ntime
+           date=iotd_t0+ntime*iotd_ts
+           !print*,'iotd_ecrit ',iotd_ts,ntime, date
+!          date= float (zitau +1)/float (day_step)
+
+           ! compute corresponding date (in days and fractions thereof)
+           ! Get NetCDF ID of 'time' variable
+
+           ierr=NF_SYNC(nid)
+
+           ierr= NF_INQ_VARID(nid,"time",varid)
+           ! Write (append) the new date to the 'time' array
+
+
+           ierr= NF90_PUT_VAR(nid,varid,date,[ntime])
+
+!          print*,'date ',date,ierr,nid
+!        print*,'IOTD Date ,varid,nid,ntime,date',varid,nid,ntime,date
+
+           if (ierr.ne.NF_NOERR) then
+              write(*,*) "***** PUT_VAR matter in writediagfi_nc"
+              write(*,*) "***** with time"
+              write(*,*) 'ierr=', ierr   
+           endif
+
+!          write(6,*)'WRITEDIAGFI: date= ', date
+        end if ! of if (nom.eq.firstnom)
+
+
+!Case of a 3D variable
+!---------------------
+        if (llm==lmax) then
+           ndim=4
+           corner(1)=1
+           corner(2)=1
+           corner(3)=1
+           corner(4)=ntime
+           edges(1)=imax
+           edges(2)=jmax
+           edges(3)=llm
+           edges(4)=1
+           dim_cc=dim_coord
+
+
+!Case of a 2D variable
+!---------------------
+
+        else if (llm==1) then
+           ndim=3
+           corner(1)=1
+           corner(2)=1
+           corner(3)=ntime
+           corner(4)=1
+           edges(1)=imax
+           edges(2)=jmax
+           edges(3)=1
+           edges(4)=1
+           dim_cc(1:2)=dim_coord(1:2)
+           dim_cc(3)=dim_coord(4)
+
+        endif ! of if llm=1 ou llm
+
+! AU premier pas de temps, on crée les variables
+!-----------------------------------------------
+
+      if (ntime==1) then
+          ierr = NF_REDEF (nid)
+          ierr = NF_DEF_VAR(nid,nom,NF_FLOAT,ndim,dim_cc,varid)
+          !print*,'DEF ',nom,nid,varid
+          ierr = NF_ENDDEF(nid)
+      else
+         ierr= NF_INQ_VARID(nid,nom,varid)
+          !print*,'INQ ',nom,nid,varid
+! Commandes pour recuperer automatiquement les coordonnees
+!             ierr= NF_INQ_DIMID(nid,"longitude",id(1))
+      endif
+
+
+      ierr= NF90_PUT_VAR(nid,varid,zx,corner,edges)
+
+      if (ierr.ne.NF_NOERR) then
+           write(*,*) "***** PUT_VAR problem in writediagfi"
+           write(*,*) "***** with ",nom
+           write(*,*) 'ierr=', ierr
+      endif 
+
+
+      end
Index: DZ6/trunk/libf/phylmd/iotd_fin.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/iotd_fin.F90	(revision 5267)
+++ 	(revision )
@@ -1,25 +1,0 @@
-      SUBROUTINE iotd_fin
-      IMPLICIT NONE
-
-!=======================================================================
-!
-!   Auteur:  F. Hourdin
-!   -------
-!
-!   Objet:
-!   ------
-!   Light interface for netcdf outputs. can be used outside LMDZ
-!
-!=======================================================================
-
-
-      INCLUDE "netcdf.inc"
-      INCLUDE "iotd.h"
-      integer ierr
-
-!   Arguments:
-!   ----------
-
-      ierr=NF_close(nid)
-
-      END
Index: /LMDZ6/trunk/libf/phylmd/iotd_fin.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/iotd_fin.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/iotd_fin.f90	(revision 5268)
@@ -0,0 +1,25 @@
+      SUBROUTINE iotd_fin
+      IMPLICIT NONE
+
+!=======================================================================
+!
+!   Auteur:  F. Hourdin
+!   -------
+!
+!   Objet:
+!   ------
+!   Light interface for netcdf outputs. can be used outside LMDZ
+!
+!=======================================================================
+
+
+      INCLUDE "netcdf.inc"
+      INCLUDE "iotd.h"
+      integer ierr
+
+!   Arguments:
+!   ----------
+
+      ierr=NF_close(nid)
+
+      END
Index: DZ6/trunk/libf/phylmd/iotd_ini.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/iotd_ini.F90	(revision 5267)
+++ 	(revision )
@@ -1,160 +1,0 @@
-      SUBROUTINE iotd_ini(fichnom,iim,jjm,llm,prlon,prlat,pcoordv,jour0,mois0,an0,t0,timestep,calendrier)
-      IMPLICIT NONE
-
-!=======================================================================
-!
-!   Auteur:  F. Hourdin
-!   -------
-!
-!   Objet:
-!   ------
-!   Light interface for netcdf outputs. can be used outside LMDZ
-!
-!=======================================================================
-!-----------------------------------------------------------------------
-!   Declarations:
-!   -------------
-
-      INCLUDE "netcdf.inc"
-      INCLUDE "iotd.h"
-
-!   Arguments:
-!   ----------
-
-      integer iim,jjm,llm
-      real prlon(iim),prlat(jjm),pcoordv(llm),timestep,t0
-      INTEGER id_FOCE
-      INTEGER jour0,mois0,an0
-      CHARACTER*(*) calendrier
-
-      integer corner(4),edges(4),ndim
-      real  px(1000)
-      character (len=10) :: nom
-      real*4 rlon(iim),rlat(jjm),coordv(llm)
-
-!   Local:
-!   ------
-      CHARACTER*3,DIMENSION(12) :: cmois=(/'JAN','FEB','MAR','APR','MAY','JUN','JUL','AUG','SEP','OCT','NOV','DEC'/)
-      CHARACTER*10 date0
-      CHARACTER*11 date0b
-
-      INTEGER :: ierr
-
-      integer :: nvarid
-      integer, dimension(2) :: id  
-
-      character*(*) fichnom
-
-      real pi
-
-      iotd_ts=timestep
-      iotd_t0=t0
-      print*,'iotd_ini, ',timestep,iotd_ts
-      imax=iim
-      jmax=jjm
-      lmax=llm
-      ! Utile pour passer en real*4 pour les ecritures
-      rlon=prlon
-      rlat=prlat
-      coordv=pcoordv
-
-
-      !-----------------------------------------------------------------------
-      ! Possibilité de spécifier une liste de variables à sortir
-      ! dans iotd.def
-      ! Si iotd.def existe et est non vide,
-      ! seules les variables faisant à la fois l'objet d'un call iotd_ecrit
-      ! et étant spécifiées dans iotd.def sont sorties.
-      ! Sinon, toutes les variables faisant l'objet d'un call iotd_ecrit
-      ! sont sorties
-      !-----------------------------------------------------------------------
-      n_names_iotd_def=0
-      open(99,file='iotd.def',form='formatted',status='old',iostat=ierr)
-         if ( ierr.eq.0 ) then
-            ierr=0
-            do while (ierr==0)
-               read(99,*,iostat=ierr) un_nom
-               if (ierr==0) then
-                  n_names_iotd_def=n_names_iotd_def+1
-                  names_iotd_def(n_names_iotd_def)=un_nom
-               endif
-            enddo
-         endif
-         print*,n_names_iotd_def,names_iotd_def(1:n_names_iotd_def)
-      close(99)
-
-
-      pi=2.*asin(1.)
-
-! Define dimensions
-    
-      ! Create the NetCDF file
-      ierr=NF_CREATE(fichnom, NF_CLOBBER, nid)
-      ierr=NF_DEF_DIM(nid, "lon", iim, dim_coord(1))
-      ierr=NF_DEF_DIM(nid, "lat", jjm, dim_coord(2))
-      ierr=NF_DEF_DIM(nid, "lev", llm, dim_coord(3))
-      ierr=NF_DEF_DIM(nid,"time",NF_UNLIMITED,dim_coord(4))
-      ierr = NF_PUT_ATT_TEXT(nid,NF_GLOBAL,'Conventions',6,"CF-1.1")
-      !ierr = NF_PUT_ATT_TEXT(nid,NF_GLOBAL,'file_name',TRIM(fname))
-      ierr=NF_ENDDEF(nid)
-
-      ! Switch out of NetCDF Define mode
-
-
-      ierr=NF_ENDDEF(nid)
-!
-!  Contol parameters for this run
-! ---- longitude -----------
-
-      ierr=NF_REDEF(nid)
-      ierr=NF_DEF_VAR(nid,"lon", NF_FLOAT, 1, dim_coord(1),nvarid)
-      ierr = NF_PUT_ATT_TEXT(nid,nvarid,'axis',1,'X')
-      ierr=NF_PUT_ATT_TEXT(nid,nvarid,'units',12,"degrees_east")
-      ierr=NF_ENDDEF(nid)
-      ierr=NF_PUT_VAR_REAL(nid,nvarid,rlon)
-       print*,ierr
-
-! ---- latitude ------------
-      ierr=NF_REDEF(nid)
-      ierr=NF_DEF_VAR(nid, "lat", NF_FLOAT, 1, dim_coord(2),nvarid)
-      ierr = NF_PUT_ATT_TEXT(nid,nvarid,'axis',1,'Y')
-      ierr=NF_PUT_ATT_TEXT(nid,nvarid,'units',13,"degrees_north")
-      ierr=NF_ENDDEF(nid)
-      ierr=NF_PUT_VAR_REAL(nid,nvarid,rlat)
-!
-! ---- vertical ------------
-      ierr=NF_REDEF(nid)
-      ierr=NF_DEF_VAR(nid, "lev", NF_FLOAT, 1,dim_coord(3),nvarid)
-      ierr=NF_PUT_ATT_TEXT(nid,nvarid,"long_name",10,"vert level")
-      if ( coordv(2)>coordv(1) ) then
-         ierr=NF_PUT_ATT_TEXT(nid,nvarid,"long_name",10,"pseudo-alt")
-         ierr=NF_PUT_ATT_TEXT(nid,nvarid,'positive',2,"up")
-      else
-         ierr=NF_PUT_ATT_TEXT(nid,nvarid,"long_name",8,"pressure")
-         ierr = NF_PUT_ATT_TEXT (nid,nvarid,'positive',4,"down")
-      endif
-      ierr=NF_ENDDEF(nid)
-      ierr=NF_PUT_VAR_REAL(nid,nvarid,coordv)
-
-!
-! ---- time ----------------
-      ierr=NF_REDEF(nid)
-      ! Define the 'time' variable
-      ierr=NF_DEF_VAR(nid, "time", NF_FLOAT, 1, dim_coord(4),nvarid)
-!     ! Add attributes
-      ierr = NF_PUT_ATT_TEXT(nid,nvarid,'axis',1,'T')
-      ierr = NF_PUT_ATT_TEXT(nid,nvarid,'standard_name',4,'time')
-      WRITE(date0,'(i4.4,"-",i2.2,"-",i2.2)') an0,mois0,jour0
-      ierr=NF_PUT_ATT_TEXT(nid, nvarid,'units',33, &
-     & "seconds since "//date0//" 00:00:00")
-      ierr = NF_PUT_ATT_TEXT(nid,nvarid,'calendar',9,calendrier)
-      !ierr = NF_PUT_ATT_TEXT(nid,nvarid,'calendar',4,'360d')
-      ierr = NF_PUT_ATT_TEXT(nid,nvarid,'title',4,'Time')
-      ierr = NF_PUT_ATT_TEXT(nid,nvarid,'long_name',9,'Time axis')
-      WRITE(date0b,'(i4.4,"-",a3,"-",i2.2)') an0,cmois(mois0),jour0
-      ierr = NF_PUT_ATT_TEXT(nid,nvarid,'time_origin',20, &
-     &        date0b//' 00:00:00')
-      ierr=NF_ENDDEF(nid)
-
-
-      END
Index: /LMDZ6/trunk/libf/phylmd/iotd_ini.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/iotd_ini.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/iotd_ini.f90	(revision 5268)
@@ -0,0 +1,160 @@
+      SUBROUTINE iotd_ini(fichnom,iim,jjm,llm,prlon,prlat,pcoordv,jour0,mois0,an0,t0,timestep,calendrier)
+      IMPLICIT NONE
+
+!=======================================================================
+!
+!   Auteur:  F. Hourdin
+!   -------
+!
+!   Objet:
+!   ------
+!   Light interface for netcdf outputs. can be used outside LMDZ
+!
+!=======================================================================
+!-----------------------------------------------------------------------
+!   Declarations:
+!   -------------
+
+      INCLUDE "netcdf.inc"
+      INCLUDE "iotd.h"
+
+!   Arguments:
+!   ----------
+
+      integer iim,jjm,llm
+      real prlon(iim),prlat(jjm),pcoordv(llm),timestep,t0
+      INTEGER id_FOCE
+      INTEGER jour0,mois0,an0
+      CHARACTER*(*) calendrier
+
+      integer corner(4),edges(4),ndim
+      real  px(1000)
+      character (len=10) :: nom
+      real*4 rlon(iim),rlat(jjm),coordv(llm)
+
+!   Local:
+!   ------
+      CHARACTER*3,DIMENSION(12) :: cmois=(/'JAN','FEB','MAR','APR','MAY','JUN','JUL','AUG','SEP','OCT','NOV','DEC'/)
+      CHARACTER*10 date0
+      CHARACTER*11 date0b
+
+      INTEGER :: ierr
+
+      integer :: nvarid
+      integer, dimension(2) :: id  
+
+      character*(*) fichnom
+
+      real pi
+
+      iotd_ts=timestep
+      iotd_t0=t0
+      print*,'iotd_ini, ',timestep,iotd_ts
+      imax=iim
+      jmax=jjm
+      lmax=llm
+      ! Utile pour passer en real*4 pour les ecritures
+      rlon=prlon
+      rlat=prlat
+      coordv=pcoordv
+
+
+      !-----------------------------------------------------------------------
+      ! Possibilité de spécifier une liste de variables à sortir
+      ! dans iotd.def
+      ! Si iotd.def existe et est non vide,
+      ! seules les variables faisant à la fois l'objet d'un call iotd_ecrit
+      ! et étant spécifiées dans iotd.def sont sorties.
+      ! Sinon, toutes les variables faisant l'objet d'un call iotd_ecrit
+      ! sont sorties
+      !-----------------------------------------------------------------------
+      n_names_iotd_def=0
+      open(99,file='iotd.def',form='formatted',status='old',iostat=ierr)
+         if ( ierr.eq.0 ) then
+            ierr=0
+            do while (ierr==0)
+               read(99,*,iostat=ierr) un_nom
+               if (ierr==0) then
+                  n_names_iotd_def=n_names_iotd_def+1
+                  names_iotd_def(n_names_iotd_def)=un_nom
+               endif
+            enddo
+         endif
+         print*,n_names_iotd_def,names_iotd_def(1:n_names_iotd_def)
+      close(99)
+
+
+      pi=2.*asin(1.)
+
+! Define dimensions
+    
+      ! Create the NetCDF file
+      ierr=NF_CREATE(fichnom, NF_CLOBBER, nid)
+      ierr=NF_DEF_DIM(nid, "lon", iim, dim_coord(1))
+      ierr=NF_DEF_DIM(nid, "lat", jjm, dim_coord(2))
+      ierr=NF_DEF_DIM(nid, "lev", llm, dim_coord(3))
+      ierr=NF_DEF_DIM(nid,"time",NF_UNLIMITED,dim_coord(4))
+      ierr = NF_PUT_ATT_TEXT(nid,NF_GLOBAL,'Conventions',6,"CF-1.1")
+      !ierr = NF_PUT_ATT_TEXT(nid,NF_GLOBAL,'file_name',TRIM(fname))
+      ierr=NF_ENDDEF(nid)
+
+      ! Switch out of NetCDF Define mode
+
+
+      ierr=NF_ENDDEF(nid)
+!
+!  Contol parameters for this run
+! ---- longitude -----------
+
+      ierr=NF_REDEF(nid)
+      ierr=NF_DEF_VAR(nid,"lon", NF_FLOAT, 1, dim_coord(1),nvarid)
+      ierr = NF_PUT_ATT_TEXT(nid,nvarid,'axis',1,'X')
+      ierr=NF_PUT_ATT_TEXT(nid,nvarid,'units',12,"degrees_east")
+      ierr=NF_ENDDEF(nid)
+      ierr=NF_PUT_VAR_REAL(nid,nvarid,rlon)
+       print*,ierr
+
+! ---- latitude ------------
+      ierr=NF_REDEF(nid)
+      ierr=NF_DEF_VAR(nid, "lat", NF_FLOAT, 1, dim_coord(2),nvarid)
+      ierr = NF_PUT_ATT_TEXT(nid,nvarid,'axis',1,'Y')
+      ierr=NF_PUT_ATT_TEXT(nid,nvarid,'units',13,"degrees_north")
+      ierr=NF_ENDDEF(nid)
+      ierr=NF_PUT_VAR_REAL(nid,nvarid,rlat)
+!
+! ---- vertical ------------
+      ierr=NF_REDEF(nid)
+      ierr=NF_DEF_VAR(nid, "lev", NF_FLOAT, 1,dim_coord(3),nvarid)
+      ierr=NF_PUT_ATT_TEXT(nid,nvarid,"long_name",10,"vert level")
+      if ( coordv(2)>coordv(1) ) then
+         ierr=NF_PUT_ATT_TEXT(nid,nvarid,"long_name",10,"pseudo-alt")
+         ierr=NF_PUT_ATT_TEXT(nid,nvarid,'positive',2,"up")
+      else
+         ierr=NF_PUT_ATT_TEXT(nid,nvarid,"long_name",8,"pressure")
+         ierr = NF_PUT_ATT_TEXT (nid,nvarid,'positive',4,"down")
+      endif
+      ierr=NF_ENDDEF(nid)
+      ierr=NF_PUT_VAR_REAL(nid,nvarid,coordv)
+
+!
+! ---- time ----------------
+      ierr=NF_REDEF(nid)
+      ! Define the 'time' variable
+      ierr=NF_DEF_VAR(nid, "time", NF_FLOAT, 1, dim_coord(4),nvarid)
+!     ! Add attributes
+      ierr = NF_PUT_ATT_TEXT(nid,nvarid,'axis',1,'T')
+      ierr = NF_PUT_ATT_TEXT(nid,nvarid,'standard_name',4,'time')
+      WRITE(date0,'(i4.4,"-",i2.2,"-",i2.2)') an0,mois0,jour0
+      ierr=NF_PUT_ATT_TEXT(nid, nvarid,'units',33, &
+     & "seconds since "//date0//" 00:00:00")
+      ierr = NF_PUT_ATT_TEXT(nid,nvarid,'calendar',9,calendrier)
+      !ierr = NF_PUT_ATT_TEXT(nid,nvarid,'calendar',4,'360d')
+      ierr = NF_PUT_ATT_TEXT(nid,nvarid,'title',4,'Time')
+      ierr = NF_PUT_ATT_TEXT(nid,nvarid,'long_name',9,'Time axis')
+      WRITE(date0b,'(i4.4,"-",a3,"-",i2.2)') an0,cmois(mois0),jour0
+      ierr = NF_PUT_ATT_TEXT(nid,nvarid,'time_origin',20, &
+     &        date0b//' 00:00:00')
+      ierr=NF_ENDDEF(nid)
+
+
+      END
Index: DZ6/trunk/libf/phylmd/isccp_cloud_types.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/isccp_cloud_types.F90	(revision 5267)
+++ 	(revision )
@@ -1,1611 +1,0 @@
-
-! $Id $
-
-SUBROUTINE isccp_cloud_types(debug, debugcol, npoints, sunlit, nlev, ncol, &
-    seed, pfull, phalf, qv, cc, conv, dtau_s, dtau_c, top_height, overlap, &
-    tautab, invtau, skt, emsfc_lw, at, dem_s, dem_c, fq_isccp, totalcldarea, &
-    meanptop, meantaucld, boxtau, boxptop)
-
-
-  ! Copyright Steve Klein and Mark Webb 2002 - all rights reserved.
-
-  ! This code is available without charge with the following conditions:
-
-  ! 1. The code is available for scientific purposes and is not for
-  ! commercial use.
-  ! 2. Any improvements you make to the code should be made available
-  ! to the to the authors for incorporation into a future release.
-  ! 3. The code should not be used in any way that brings the authors
-  ! or their employers into disrepute.
-
-  IMPLICIT NONE
-
-  ! NOTE:   the maximum number of levels and columns is set by
-  ! the following parameter statement
-
-  INTEGER ncolprint
-
-  ! -----
-  ! Input
-  ! -----
-
-  INTEGER npoints !  number of model points in the horizontal
-  ! PARAMETER(npoints=6722)
-  INTEGER nlev !  number of model levels in column
-  INTEGER ncol !  number of subcolumns
-
-  INTEGER sunlit(npoints) !  1 for day points, 0 for night time
-
-  INTEGER seed(npoints) !  seed value for random number generator
-  ! !  ( see Numerical Recipes Chapter 7)
-  ! !  It is recommended that the seed is set
-  ! !  to a different value for each model
-  ! !  gridbox it is called on, as it is
-  ! !  possible that the choice of the samec
-  ! !  seed value every time may introduce some
-  ! !  statistical bias in the results, particularly
-  ! !  for low values of NCOL.
-
-  REAL pfull(npoints, nlev) !  pressure of full model levels (Pascals)
-  ! !  pfull(npoints,1)    is    top level of model
-  ! !  pfull(npoints,nlev) is bottom level of model
-
-  REAL phalf(npoints, nlev+1) !  pressure of half model levels (Pascals)
-  ! !  phalf(npoints,1)    is    top       of model
-  ! !  phalf(npoints,nlev+1) is the surface pressure
-
-  REAL qv(npoints, nlev) !  water vapor specific humidity (kg vapor/ kg air)
-  ! !         on full model levels
-
-  REAL cc(npoints, nlev) !  input cloud cover in each model level (fraction)
-  ! !  NOTE:  This is the HORIZONTAL area of each
-  ! !         grid box covered by clouds
-
-  REAL conv(npoints, nlev) !  input convective cloud cover in each model level (fraction)
-  ! !  NOTE:  This is the HORIZONTAL area of each
-  ! !         grid box covered by convective clouds
-
-  REAL dtau_s(npoints, nlev) !  mean 0.67 micron optical depth of stratiform
-  ! !  clouds in each model level
-  ! !  NOTE:  this the cloud optical depth of only the
-  ! !         cloudy part of the grid box, it is not weighted
-  ! !         with the 0 cloud optical depth of the clear
-  ! !         part of the grid box
-
-  REAL dtau_c(npoints, nlev) !  mean 0.67 micron optical depth of convective
-  ! !  clouds in each
-  ! !  model level.  Same note applies as in dtau_s.
-
-  INTEGER overlap !  overlap type
-
-  ! 1=max
-
-  ! 2=rand
-  ! 3=max/rand
-
-  INTEGER top_height !  1 = adjust top height using both a computed
-  ! !  infrared brightness temperature and the visible
-  ! !  optical depth to adjust cloud top pressure. Note
-  ! !  that this calculation is most appropriate to compare
-  ! !  to ISCCP data during sunlit hours.
-  ! !  2 = do not adjust top height, that is cloud top
-  ! !  pressure is the actual cloud top pressure
-  ! !  in the model
-  ! !  3 = adjust top height using only the computed
-  ! !  infrared brightness temperature. Note that this
-  ! !  calculation is most appropriate to compare to ISCCP
-  ! !  IR only algortihm (i.e. you can compare to nighttime
-  ! !  ISCCP data with this option)
-
-  REAL tautab(0:255) !  ISCCP table for converting count value to
-  ! !  optical thickness
-
-  INTEGER invtau(-20:45000) !  ISCCP table for converting optical thickness
-  ! !  to count value
-
-  ! The following input variables are used only if top_height = 1 or
-  ! top_height = 3
-
-  REAL skt(npoints) !  skin Temperature (K)
-  REAL emsfc_lw !  10.5 micron emissivity of surface (fraction)
-  REAL at(npoints, nlev) !  temperature in each model level (K)
-  REAL dem_s(npoints, nlev) !  10.5 micron longwave emissivity of stratiform
-  ! !  clouds in each
-  ! !  model level.  Same note applies as in dtau_s.
-  REAL dem_c(npoints, nlev) !  10.5 micron longwave emissivity of convective
-  ! !  clouds in each
-  ! !  model level.  Same note applies as in dtau_s.
-  ! IM reg.dyn BEG
-  REAL t1, t2
-  ! REAL w(npoints)                   !vertical wind at 500 hPa
-  ! LOGICAL pct_ocean(npoints)        !TRUE if oceanic point, FALSE otherway
-  ! INTEGER iw(npoints) , nw
-  ! REAL wmin, pas_w
-  ! INTEGER k, l, iwmx
-  ! PARAMETER(wmin=-100.,pas_w=10.,iwmx=30)
-  ! REAL fq_dynreg(7,7,iwmx)
-  ! REAL nfq_dynreg(7,7,iwmx)
-  ! LOGICAL pctj(7,7,iwmx)
-  ! IM reg.dyn END
-  ! ------
-  ! Output
-  ! ------
-
-  REAL fq_isccp(npoints, 7, 7) !  the fraction of the model grid box covered by
-  ! !  each of the 49 ISCCP D level cloud types
-
-  REAL totalcldarea(npoints) !  the fraction of model grid box columns
-  ! !  with cloud somewhere in them.  This should
-  ! !  equal the sum over all entries of fq_isccp
-
-
-  ! ! The following three means are averages over the cloudy areas only.  If
-  ! no
-  ! ! clouds are in grid box all three quantities should equal zero.
-
-  REAL meanptop(npoints) !  mean cloud top pressure (mb) - linear averaging
-  ! !  in cloud top pressure.
-
-  REAL meantaucld(npoints) !  mean optical thickness
-  ! !  linear averaging in albedo performed.
-
-  REAL boxtau(npoints, ncol) !  optical thickness in each column
-
-  REAL boxptop(npoints, ncol) !  cloud top pressure (mb) in each column
-
-
-
-  ! ------
-  ! Working variables added when program updated to mimic Mark Webb's PV-Wave
-  ! code
-  ! ------
-
-  REAL frac_out(npoints, ncol, nlev) ! boxes gridbox divided up into
-  ! ! Equivalent of BOX in original version, but
-  ! ! indexed by column then row, rather than
-  ! ! by row then column
-
-  REAL tca(npoints, 0:nlev) ! total cloud cover in each model level (fraction)
-  ! ! with extra layer of zeroes on top
-  ! ! in this version this just contains the values input
-  ! ! from cc but with an extra level
-  REAL cca(npoints, nlev) ! convective cloud cover in each model level (fraction)
-  ! ! from conv
-
-  REAL threshold(npoints, ncol) ! pointer to position in gridbox
-  REAL maxocc(npoints, ncol) ! Flag for max overlapped conv cld
-  REAL maxosc(npoints, ncol) ! Flag for max overlapped strat cld
-
-  REAL boxpos(npoints, ncol) ! ordered pointer to position in gridbox
-
-  REAL threshold_min(npoints, ncol) ! minimum value to define range in with new threshold
-  ! ! is chosen
-
-  REAL dem(npoints, ncol), bb(npoints) !  working variables for 10.5 micron longwave
-  ! !  emissivity in part of
-  ! !  gridbox under consideration
-
-  REAL ran(npoints) ! vector of random numbers
-  REAL ptrop(npoints)
-  REAL attrop(npoints)
-  REAL attropmin(npoints)
-  REAL atmax(npoints)
-  REAL atmin(npoints)
-  REAL btcmin(npoints)
-  REAL transmax(npoints)
-
-  INTEGER i, j, ilev, ibox, itrop(npoints)
-  INTEGER ipres(npoints)
-  INTEGER itau(npoints), ilev2
-  INTEGER acc(nlev, ncol)
-  INTEGER match(npoints, nlev-1)
-  INTEGER nmatch(npoints)
-  INTEGER levmatch(npoints, ncol)
-
-  ! !variables needed for water vapor continuum absorption
-  REAL fluxtop_clrsky(npoints), trans_layers_above_clrsky(npoints)
-  REAL taumin(npoints)
-  REAL dem_wv(npoints, nlev), wtmair, wtmh20, navo, grav, pstd, t0
-  REAL press(npoints), dpress(npoints), atmden(npoints)
-  REAL rvh20(npoints), wk(npoints), rhoave(npoints)
-  REAL rh20s(npoints), rfrgn(npoints)
-  REAL tmpexp(npoints), tauwv(npoints)
-
-  CHARACTER *1 cchar(6), cchar_realtops(6)
-  INTEGER icycle
-  REAL tau(npoints, ncol)
-  LOGICAL box_cloudy(npoints, ncol)
-  REAL tb(npoints, ncol)
-  REAL ptop(npoints, ncol)
-  REAL emcld(npoints, ncol)
-  REAL fluxtop(npoints, ncol)
-  REAL trans_layers_above(npoints, ncol)
-  REAL isccp_taumin, fluxtopinit(npoints), tauir(npoints)
-  REAL meanalbedocld(npoints)
-  REAL albedocld(npoints, ncol)
-  REAL boxarea
-  INTEGER debug ! set to non-zero value to print out inputs
-  ! ! with step debug
-  INTEGER debugcol ! set to non-zero value to print out column
-  ! ! decomposition with step debugcol
-
-  INTEGER index1(npoints), num1, jj
-  REAL rec2p13, tauchk
-
-  CHARACTER *10 ftn09
-
-  DATA isccp_taumin/0.3/
-  DATA cchar/' ', '-', '1', '+', 'I', '+'/
-  DATA cchar_realtops/' ', ' ', '1', '1', 'I', 'I'/
-
-  tauchk = -1.*log(0.9999999)
-  rec2p13 = 1./2.13
-
-  ncolprint = 0
-
-  ! IM
-  ! PRINT*,' isccp_cloud_types npoints=',npoints
-
-  ! if ( debug.ne.0 ) then
-  ! j=1
-  ! write(6,'(a10)') 'j='
-  ! write(6,'(8I10)') j
-  ! write(6,'(a10)') 'debug='
-  ! write(6,'(8I10)') debug
-  ! write(6,'(a10)') 'debugcol='
-  ! write(6,'(8I10)') debugcol
-  ! write(6,'(a10)') 'npoints='
-  ! write(6,'(8I10)') npoints
-  ! write(6,'(a10)') 'nlev='
-  ! write(6,'(8I10)') nlev
-  ! write(6,'(a10)') 'ncol='
-  ! write(6,'(8I10)') ncol
-  ! write(6,'(a10)') 'top_height='
-  ! write(6,'(8I10)') top_height
-  ! write(6,'(a10)') 'overlap='
-  ! write(6,'(8I10)') overlap
-  ! write(6,'(a10)') 'emsfc_lw='
-  ! write(6,'(8f10.2)') emsfc_lw
-  ! write(6,'(a10)') 'tautab='
-  ! write(6,'(8f10.2)') tautab
-  ! write(6,'(a10)') 'invtau(1:100)='
-  ! write(6,'(8i10)') (invtau(i),i=1,100)
-  ! do j=1,npoints,debug
-  ! write(6,'(a10)') 'j='
-  ! write(6,'(8I10)') j
-  ! write(6,'(a10)') 'sunlit='
-  ! write(6,'(8I10)') sunlit(j)
-  ! write(6,'(a10)') 'seed='
-  ! write(6,'(8I10)') seed(j)
-  ! write(6,'(a10)') 'pfull='
-  ! write(6,'(8f10.2)') (pfull(j,i),i=1,nlev)
-  ! write(6,'(a10)') 'phalf='
-  ! write(6,'(8f10.2)') (phalf(j,i),i=1,nlev+1)
-  ! write(6,'(a10)') 'qv='
-  ! write(6,'(8f10.3)') (qv(j,i),i=1,nlev)
-  ! write(6,'(a10)') 'cc='
-  ! write(6,'(8f10.3)') (cc(j,i),i=1,nlev)
-  ! write(6,'(a10)') 'conv='
-  ! write(6,'(8f10.2)') (conv(j,i),i=1,nlev)
-  ! write(6,'(a10)') 'dtau_s='
-  ! write(6,'(8g12.5)') (dtau_s(j,i),i=1,nlev)
-  ! write(6,'(a10)') 'dtau_c='
-  ! write(6,'(8f10.2)') (dtau_c(j,i),i=1,nlev)
-  ! write(6,'(a10)') 'skt='
-  ! write(6,'(8f10.2)') skt(j)
-  ! write(6,'(a10)') 'at='
-  ! write(6,'(8f10.2)') (at(j,i),i=1,nlev)
-  ! write(6,'(a10)') 'dem_s='
-  ! write(6,'(8f10.3)') (dem_s(j,i),i=1,nlev)
-  ! write(6,'(a10)') 'dem_c='
-  ! write(6,'(8f10.2)') (dem_c(j,i),i=1,nlev)
-  ! enddo
-  ! endif
-
-  ! ---------------------------------------------------!
-
-  ! assign 2d tca array using 1d input array cc
-
-  DO j = 1, npoints
-    tca(j, 0) = 0
-  END DO
-
-  DO ilev = 1, nlev
-    DO j = 1, npoints
-      tca(j, ilev) = cc(j, ilev)
-    END DO
-  END DO
-
-  ! assign 2d cca array using 1d input array conv
-
-  DO ilev = 1, nlev
-    ! IM pas besoin        do ibox=1,ncol
-    DO j = 1, npoints
-      cca(j, ilev) = conv(j, ilev)
-    END DO
-    ! IM        enddo
-  END DO
-
-  ! IM
-  ! do j=1, iwmx
-  ! do l=1, 7
-  ! do k=1, 7
-  ! fq_dynreg(k,l,j) =0.
-  ! nfq_dynreg(k,l,j) =0.
-  ! enddo !k
-  ! enddo !l
-  ! enddo !j
-  ! IM
-  ! IM
-  ! if (ncolprint.ne.0) then
-  ! do j=1,npoints,1000
-  ! write(6,'(a10)') 'j='
-  ! write(6,'(8I10)') j
-  ! write (6,'(a)') 'seed:'
-  ! write (6,'(I3.2)') seed(j)
-
-  ! write (6,'(a)') 'tca_pp_rev:'
-  ! write (6,'(8f5.2)')
-  ! &   ((tca(j,ilev)),
-  ! &      ilev=1,nlev)
-
-  ! write (6,'(a)') 'cca_pp_rev:'
-  ! write (6,'(8f5.2)')
-  ! &   ((cca(j,ilev),ibox=1,ncolprint),ilev=1,nlev)
-  ! enddo
-  ! endif
-
-  IF (top_height==1 .OR. top_height==3) THEN
-
-    DO j = 1, npoints
-      ptrop(j) = 5000.
-      atmin(j) = 400.
-      attropmin(j) = 400.
-      atmax(j) = 0.
-      attrop(j) = 120.
-      itrop(j) = 1
-    END DO
-
-    DO ilev = 1, nlev
-      DO j = 1, npoints
-        IF (pfull(j,ilev)<40000. .AND. pfull(j,ilev)>5000. .AND. &
-            at(j,ilev)<attropmin(j)) THEN
-          ptrop(j) = pfull(j, ilev)
-          attropmin(j) = at(j, ilev)
-          attrop(j) = attropmin(j)
-          itrop(j) = ilev
-        END IF
-        IF (at(j,ilev)>atmax(j)) atmax(j) = at(j, ilev)
-        IF (at(j,ilev)<atmin(j)) atmin(j) = at(j, ilev)
-      END DO
-    END DO
-
-  END IF
-
-  ! -----------------------------------------------------!
-
-  ! ---------------------------------------------------!
-
-  ! IM
-  ! do 13 ilev=1,nlev
-  ! num1=0
-  ! do j=1,npoints
-  ! if (cc(j,ilev) .lt. 0. .or. cc(j,ilev) .gt. 1.) then
-  ! num1=num1+1
-  ! index1(num1)=j
-  ! end if
-  ! enddo
-  ! do jj=1,num1
-  ! j=index1(jj)
-  ! write(6,*)  ' error = cloud fraction less than zero'
-  ! write(6,*) ' or '
-  ! write(6,*)  ' error = cloud fraction greater than 1'
-  ! write(6,*) 'value at point ',j,' is ',cc(j,ilev)
-  ! write(6,*) 'level ',ilev
-  ! STOP
-  ! enddo
-  ! num1=0
-  ! do j=1,npoints
-  ! if (conv(j,ilev) .lt. 0. .or. conv(j,ilev) .gt. 1.) then
-  ! num1=num1+1
-  ! index1(num1)=j
-  ! end if
-  ! enddo
-  ! do jj=1,num1
-  ! j=index1(jj)
-  ! write(6,*)
-  ! &           ' error = convective cloud fraction less than zero'
-  ! write(6,*) ' or '
-  ! write(6,*)
-  ! &           ' error = convective cloud fraction greater than 1'
-  ! write(6,*) 'value at point ',j,' is ',conv(j,ilev)
-  ! write(6,*) 'level ',ilev
-  ! STOP
-  ! enddo
-
-  ! num1=0
-  ! do j=1,npoints
-  ! if (dtau_s(j,ilev) .lt. 0.) then
-  ! num1=num1+1
-  ! index1(num1)=j
-  ! end if
-  ! enddo
-  ! do jj=1,num1
-  ! j=index1(jj)
-  ! write(6,*)
-  ! &           ' error = stratiform cloud opt. depth less than zero'
-  ! write(6,*) 'value at point ',j,' is ',dtau_s(j,ilev)
-  ! write(6,*) 'level ',ilev
-  ! STOP
-  ! enddo
-  ! num1=0
-  ! do j=1,npoints
-  ! if (dtau_c(j,ilev) .lt. 0.) then
-  ! num1=num1+1
-  ! index1(num1)=j
-  ! end if
-  ! enddo
-  ! do jj=1,num1
-  ! j=index1(jj)
-  ! write(6,*)
-  ! &           ' error = convective cloud opt. depth less than zero'
-  ! write(6,*) 'value at point ',j,' is ',dtau_c(j,ilev)
-  ! write(6,*) 'level ',ilev
-  ! STOP
-  ! enddo
-
-  ! num1=0
-  ! do j=1,npoints
-  ! if (dem_s(j,ilev) .lt. 0. .or. dem_s(j,ilev) .gt. 1.) then
-  ! num1=num1+1
-  ! index1(num1)=j
-  ! end if
-  ! enddo
-  ! do jj=1,num1
-  ! j=index1(jj)
-  ! write(6,*)
-  ! &           ' error = stratiform cloud emissivity less than zero'
-  ! write(6,*)'or'
-  ! write(6,*)
-  ! &           ' error = stratiform cloud emissivity greater than 1'
-  ! write(6,*) 'value at point ',j,' is ',dem_s(j,ilev)
-  ! write(6,*) 'level ',ilev
-  ! STOP
-  ! enddo
-
-  ! num1=0
-  ! do j=1,npoints
-  ! if (dem_c(j,ilev) .lt. 0. .or. dem_c(j,ilev) .gt. 1.) then
-  ! num1=num1+1
-  ! index1(num1)=j
-  ! end if
-  ! enddo
-  ! do jj=1,num1
-  ! j=index1(jj)
-  ! write(6,*)
-  ! &           ' error = convective cloud emissivity less than zero'
-  ! write(6,*)'or'
-  ! write(6,*)
-  ! &           ' error = convective cloud emissivity greater than 1'
-  ! write (6,*)
-  ! &          'j=',j,'ilev=',ilev,'dem_c(j,ilev) =',dem_c(j,ilev)
-  ! STOP
-  ! enddo
-  ! 13    continue
-
-
-  DO ibox = 1, ncol
-    DO j = 1, npoints
-      boxpos(j, ibox) = (ibox-.5)/ncol
-    END DO
-  END DO
-
-  ! ---------------------------------------------------!
-  ! Initialise working variables
-  ! ---------------------------------------------------!
-
-  ! Initialised frac_out to zero
-
-  DO ilev = 1, nlev
-    DO ibox = 1, ncol
-      DO j = 1, npoints
-        frac_out(j, ibox, ilev) = 0.0
-      END DO
-    END DO
-  END DO
-
-  ! IM
-  ! if (ncolprint.ne.0) then
-  ! write (6,'(a)') 'frac_out_pp_rev:'
-  ! do j=1,npoints,1000
-  ! write(6,'(a10)') 'j='
-  ! write(6,'(8I10)') j
-  ! write (6,'(8f5.2)')
-  ! &     ((frac_out(j,ibox,ilev),ibox=1,ncolprint),ilev=1,nlev)
-
-  ! enddo
-  ! write (6,'(a)') 'ncol:'
-  ! write (6,'(I3)') ncol
-  ! endif
-  ! if (ncolprint.ne.0) then
-  ! write (6,'(a)') 'last_frac_pp:'
-  ! do j=1,npoints,1000
-  ! write(6,'(a10)') 'j='
-  ! write(6,'(8I10)') j
-  ! write (6,'(8f5.2)') (tca(j,0))
-  ! enddo
-  ! endif
-
-  ! ---------------------------------------------------!
-  ! ALLOCATE CLOUD INTO BOXES, FOR NCOLUMNS, NLEVELS
-  ! frac_out is the array that contains the information
-  ! where 0 is no cloud, 1 is a stratiform cloud and 2 is a
-  ! convective cloud
-
-    !loop over vertical levels
-  DO ilev = 1, nlev
-
-    ! Initialise threshold
-
-    IF (ilev==1) THEN
-        ! If max overlap
-      IF (overlap==1) THEN
-          ! select pixels spread evenly
-          ! across the gridbox
-        DO ibox = 1, ncol
-          DO j = 1, npoints
-            threshold(j, ibox) = boxpos(j, ibox)
-          END DO
-        END DO
-      ELSE
-        DO ibox = 1, ncol
-          CALL ran0_vec(npoints, seed, ran)
-            ! select random pixels from the non-convective
-            ! part the gridbox ( some will be converted into
-            ! convective pixels below )
-          DO j = 1, npoints
-            threshold(j, ibox) = cca(j, ilev) + (1-cca(j,ilev))*ran(j)
-          END DO
-        END DO
-      END IF
-      ! IM
-      ! IF (ncolprint.ne.0) then
-      ! write (6,'(a)') 'threshold_nsf2:'
-      ! do j=1,npoints,1000
-      ! write(6,'(a10)') 'j='
-      ! write(6,'(8I10)') j
-      ! write (6,'(8f5.2)') (threshold(j,ibox),ibox=1,ncolprint)
-      ! enddo
-      ! ENDIF
-    END IF
-
-    ! IF (ncolprint.ne.0) then
-    ! write (6,'(a)') 'ilev:'
-    ! write (6,'(I2)') ilev
-    ! ENDIF
-
-    DO ibox = 1, ncol
-
-        ! All versions
-      DO j = 1, npoints
-        IF (boxpos(j,ibox)<=cca(j,ilev)) THEN
-          ! IM REAL           maxocc(j,ibox) = 1
-          maxocc(j, ibox) = 1.0
-        ELSE
-          ! IM REAL           maxocc(j,ibox) = 0
-          maxocc(j, ibox) = 0.0
-        END IF
-      END DO
-
-        ! Max overlap
-      IF (overlap==1) THEN
-        DO j = 1, npoints
-          threshold_min(j, ibox) = cca(j, ilev)
-          ! IM REAL           maxosc(j,ibox)=1
-          maxosc(j, ibox) = 1.0
-        END DO
-      END IF
-
-        ! Random overlap
-      IF (overlap==2) THEN
-        DO j = 1, npoints
-          threshold_min(j, ibox) = cca(j, ilev)
-          ! IM REAL           maxosc(j,ibox)=0
-          maxosc(j, ibox) = 0.0
-        END DO
-      END IF
-
-        ! Max/Random overlap
-      IF (overlap==3) THEN
-        DO j = 1, npoints
-          threshold_min(j, ibox) = max(cca(j,ilev), min(tca(j,ilev-1),tca(j, &
-            ilev)))
-          IF (threshold(j,ibox)<min(tca(j,ilev-1),tca(j, &
-              ilev)) .AND. (threshold(j,ibox)>cca(j,ilev))) THEN
-            ! IM REAL                maxosc(j,ibox)= 1
-            maxosc(j, ibox) = 1.0
-          ELSE
-            ! IM REAL                 maxosc(j,ibox)= 0
-            maxosc(j, ibox) = 0.0
-          END IF
-        END DO
-      END IF
-
-        ! Reset threshold
-      CALL ran0_vec(npoints, seed, ran)
-
-      DO j = 1, npoints
-        threshold(j, ibox) = &       !if max overlapped conv cloud
-          maxocc(j, ibox)*(boxpos(j,ibox)) + &   !else
-          (1-maxocc(j,ibox))*( &     !if max overlapped strat cloud
-          (maxosc(j,ibox))*( &       !threshold=boxpos
-          threshold(j,ibox))+ &      !else
-          (1-maxosc(j,ibox))*( &     !threshold_min=random[thrmin,1]
-          threshold_min(j,ibox)+(1-threshold_min(j,ibox))*ran(j)))
-      END DO
-
-    END DO ! ibox
-
-    ! Fill frac_out with 1's where tca is greater than the threshold
-
-    DO ibox = 1, ncol
-      DO j = 1, npoints
-        IF (tca(j,ilev)>threshold(j,ibox)) THEN
-          ! IM REAL             frac_out(j,ibox,ilev)=1
-          frac_out(j, ibox, ilev) = 1.0
-        ELSE
-          ! IM REAL             frac_out(j,ibox,ilev)=0
-          frac_out(j, ibox, ilev) = 0.0
-        END IF
-      END DO
-    END DO
-
-    ! Code to partition boxes into startiform and convective parts
-    ! goes here
-
-    DO ibox = 1, ncol
-      DO j = 1, npoints
-        IF (threshold(j,ibox)<=cca(j,ilev)) THEN
-            ! = 2 IF threshold le cca(j)
-          ! IM REAL                  frac_out(j,ibox,ilev) = 2
-          frac_out(j, ibox, ilev) = 2.0
-        ELSE
-            ! = the same IF NOT threshold le cca(j)
-          frac_out(j, ibox, ilev) = frac_out(j, ibox, ilev)
-        END IF
-      END DO
-    END DO
-
-    ! Set last_frac to tca at this level, so as to be tca
-    ! from last level next time round
-
-    ! IM
-    ! if (ncolprint.ne.0) then
-
-    ! do j=1,npoints ,1000
-    ! write(6,'(a10)') 'j='
-    ! write(6,'(8I10)') j
-    ! write (6,'(a)') 'last_frac:'
-    ! write (6,'(8f5.2)') (tca(j,ilev-1))
-
-    ! write (6,'(a)') 'cca:'
-    ! write (6,'(8f5.2)') (cca(j,ilev),ibox=1,ncolprint)
-
-    ! write (6,'(a)') 'max_overlap_cc:'
-    ! write (6,'(8f5.2)') (maxocc(j,ibox),ibox=1,ncolprint)
-
-    ! write (6,'(a)') 'max_overlap_sc:'
-    ! write (6,'(8f5.2)') (maxosc(j,ibox),ibox=1,ncolprint)
-
-    ! write (6,'(a)') 'threshold_min_nsf2:'
-    ! write (6,'(8f5.2)') (threshold_min(j,ibox),ibox=1,ncolprint)
-
-    ! write (6,'(a)') 'threshold_nsf2:'
-    ! write (6,'(8f5.2)') (threshold(j,ibox),ibox=1,ncolprint)
-
-    ! write (6,'(a)') 'frac_out_pp_rev:'
-    ! write (6,'(8f5.2)')
-    ! &       ((frac_out(j,ibox,ilev2),ibox=1,ncolprint),ilev2=1,nlev)
-    ! enddo
-    ! endif
-
-
-  END DO
-
-  ! ---------------------------------------------------!
-
-
-
-  ! ---------------------------------------------------!
-  ! COMPUTE CLOUD OPTICAL DEPTH FOR EACH COLUMN and
-  ! put into vector tau
-
-    !initialize tau and albedocld to zero
-  ! loop over nlev
-  DO ibox = 1, ncol
-    DO j = 1, npoints
-      tau(j, ibox) = 0.
-      albedocld(j, ibox) = 0.
-      boxtau(j, ibox) = 0.
-      boxptop(j, ibox) = 0.
-      box_cloudy(j, ibox) = .FALSE.
-    END DO
-  END DO
-
-    !compute total cloud optical depth for each column
-  DO ilev = 1, nlev
-      !increment tau for each of the boxes
-    DO ibox = 1, ncol
-      DO j = 1, npoints
-        ! IM REAL              if (frac_out(j,ibox,ilev).eq.1) then
-        IF (frac_out(j,ibox,ilev)==1.0) THEN
-          tau(j, ibox) = tau(j, ibox) + dtau_s(j, ilev)
-        END IF
-        ! IM REAL              if (frac_out(j,ibox,ilev).eq.2) then
-        IF (frac_out(j,ibox,ilev)==2.0) THEN
-          tau(j, ibox) = tau(j, ibox) + dtau_c(j, ilev)
-        END IF
-      END DO
-    END DO ! ibox
-  END DO ! ilev
-  ! IM
-  ! if (ncolprint.ne.0) then
-
-  ! do j=1,npoints ,1000
-  ! write(6,'(a10)') 'j='
-  ! write(6,'(8I10)') j
-  ! write(6,'(i2,1X,8(f7.2,1X))')
-  ! &          ilev,
-  ! &          (tau(j,ibox),ibox=1,ncolprint)
-  ! enddo
-  ! endif
-
-  ! ---------------------------------------------------!
-
-
-
-
-  ! ---------------------------------------------------!
-  ! COMPUTE INFRARED BRIGHTNESS TEMPERUATRES
-  ! AND CLOUD TOP TEMPERATURE SATELLITE SHOULD SEE
-
-  ! again this is only done if top_height = 1 or 3
-
-  ! fluxtop is the 10.5 micron radiance at the top of the
-  ! atmosphere
-  ! trans_layers_above is the total transmissivity in the layers
-  ! above the current layer
-  ! fluxtop_clrsky(j) and trans_layers_above_clrsky(j) are the clear
-  ! sky versions of these quantities.
-
-  IF (top_height==1 .OR. top_height==3) THEN
-
-
-      !----------------------------------------------------------------------
-      !
-      !             DO CLEAR SKY RADIANCE CALCULATION FIRST
-      !
-      !compute water vapor continuum emissivity
-      !this treatment follows Schwarkzopf and Ramasamy
-      !JGR 1999,vol 104, pages 9467-9499.
-      !the emissivity is calculated at a wavenumber of 955 cm-1,
-      !or 10.47 microns
-    wtmair = 28.9644
-    wtmh20 = 18.01534
-    navo = 6.023E+23
-    grav = 9.806650E+02
-    pstd = 1.013250E+06
-    t0 = 296.
-    ! IM
-    ! if (ncolprint .ne. 0)
-    ! &         write(6,*)  'ilev   pw (kg/m2)   tauwv(j)      dem_wv'
-    DO ilev = 1, nlev
-      DO j = 1, npoints
-          !press and dpress are dyne/cm2 = Pascals *10
-        press(j) = pfull(j, ilev)*10.
-        dpress(j) = (phalf(j,ilev+1)-phalf(j,ilev))*10
-          !atmden = g/cm2 = kg/m2 / 10
-        atmden(j) = dpress(j)/grav
-        rvh20(j) = qv(j, ilev)*wtmair/wtmh20
-        wk(j) = rvh20(j)*navo*atmden(j)/wtmair
-        rhoave(j) = (press(j)/pstd)*(t0/at(j,ilev))
-        rh20s(j) = rvh20(j)*rhoave(j)
-        rfrgn(j) = rhoave(j) - rh20s(j)
-        tmpexp(j) = exp(-0.02*(at(j,ilev)-t0))
-        tauwv(j) = wk(j)*1.E-20*((0.0224697*rh20s(j)*tmpexp(j))+(3.41817E-7* &
-          rfrgn(j)))*0.98
-        dem_wv(j, ilev) = 1. - exp(-1.*tauwv(j))
-      END DO
-      ! IM
-      ! if (ncolprint .ne. 0) then
-      ! do j=1,npoints ,1000
-      ! write(6,'(a10)') 'j='
-      ! write(6,'(8I10)') j
-      ! write(6,'(i2,1X,3(f8.3,3X))') ilev,
-      ! &           qv(j,ilev)*(phalf(j,ilev+1)-phalf(j,ilev))/(grav/100.),
-      ! &           tauwv(j),dem_wv(j,ilev)
-      ! enddo
-      ! endif
-    END DO
-
-      !initialize variables
-    DO j = 1, npoints
-      fluxtop_clrsky(j) = 0.
-      trans_layers_above_clrsky(j) = 1.
-    END DO
-
-    DO ilev = 1, nlev
-      DO j = 1, npoints
-
-          ! Black body emission at temperature of the layer
-
-        bb(j) = 1/(exp(1307.27/at(j,ilev))-1.)
-          !bb(j)= 5.67e-8*at(j,ilev)**4
-
-          ! increase TOA flux by flux emitted from layer
-          ! times total transmittance in layers above
-
-        fluxtop_clrsky(j) = fluxtop_clrsky(j) + dem_wv(j, ilev)*bb(j)* &
-          trans_layers_above_clrsky(j)
-
-          ! update trans_layers_above with transmissivity
-          ! from this layer for next time around loop
-
-        trans_layers_above_clrsky(j) = trans_layers_above_clrsky(j)* &
-          (1.-dem_wv(j,ilev))
-
-
-      END DO
-      ! IM
-      ! if (ncolprint.ne.0) then
-      ! do j=1,npoints ,1000
-      ! write(6,'(a10)') 'j='
-      ! write(6,'(8I10)') j
-      ! write (6,'(a)') 'ilev:'
-      ! write (6,'(I2)') ilev
-
-      ! write (6,'(a)')
-      ! &        'emiss_layer,100.*bb(j),100.*f,total_trans:'
-      ! write (6,'(4(f7.2,1X))') dem_wv(j,ilev),100.*bb(j),
-      ! &             100.*fluxtop_clrsky(j),trans_layers_above_clrsky(j)
-      ! enddo
-      ! endif
-
-    END DO !loop over level
-
-    DO j = 1, npoints
-        !add in surface emission
-      bb(j) = 1/(exp(1307.27/skt(j))-1.)
-        !bb(j)=5.67e-8*skt(j)**4
-
-      fluxtop_clrsky(j) = fluxtop_clrsky(j) + emsfc_lw*bb(j)* &
-        trans_layers_above_clrsky(j)
-    END DO
-
-    ! IM
-    ! if (ncolprint.ne.0) then
-    ! do j=1,npoints ,1000
-    ! write(6,'(a10)') 'j='
-    ! write(6,'(8I10)') j
-    ! write (6,'(a)') 'id:'
-    ! write (6,'(a)') 'surface'
-
-    ! write (6,'(a)') 'emsfc,100.*bb(j),100.*f,total_trans:'
-    ! write (6,'(4(f7.2,1X))') emsfc_lw,100.*bb(j),
-    ! &      100.*fluxtop_clrsky(j),
-    ! &       trans_layers_above_clrsky(j)
-    ! enddo
-    ! endif
-
-
-      !
-      !           END OF CLEAR SKY CALCULATION
-      !
-      !----------------------------------------------------------------
-
-
-    ! IM
-    ! if (ncolprint.ne.0) then
-
-    ! do j=1,npoints ,1000
-    ! write(6,'(a10)') 'j='
-    ! write(6,'(8I10)') j
-    ! write (6,'(a)') 'ts:'
-    ! write (6,'(8f7.2)') (skt(j),ibox=1,ncolprint)
-
-    ! write (6,'(a)') 'ta_rev:'
-    ! write (6,'(8f7.2)')
-    ! &       ((at(j,ilev2),ibox=1,ncolprint),ilev2=1,nlev)
-
-    ! enddo
-    ! endif
-      !loop over columns
-    DO ibox = 1, ncol
-      DO j = 1, npoints
-        fluxtop(j, ibox) = 0.
-        trans_layers_above(j, ibox) = 1.
-      END DO
-    END DO
-
-    DO ilev = 1, nlev
-      DO j = 1, npoints
-          ! Black body emission at temperature of the layer
-
-        bb(j) = 1/(exp(1307.27/at(j,ilev))-1.)
-          !bb(j)= 5.67e-8*at(j,ilev)**4
-      END DO
-
-      DO ibox = 1, ncol
-        DO j = 1, npoints
-
-            ! emissivity for point in this layer
-          ! IM REAL             if (frac_out(j,ibox,ilev).eq.1) then
-          IF (frac_out(j,ibox,ilev)==1.0) THEN
-            dem(j, ibox) = 1. - ((1.-dem_wv(j,ilev))*(1.-dem_s(j,ilev)))
-            ! IM REAL             else if (frac_out(j,ibox,ilev).eq.2) then
-          ELSE IF (frac_out(j,ibox,ilev)==2.0) THEN
-            dem(j, ibox) = 1. - ((1.-dem_wv(j,ilev))*(1.-dem_c(j,ilev)))
-          ELSE
-            dem(j, ibox) = dem_wv(j, ilev)
-          END IF
-
-
-            ! increase TOA flux by flux emitted from layer
-            ! times total transmittance in layers above
-
-          fluxtop(j, ibox) = fluxtop(j, ibox) + dem(j, ibox)*bb(j)* &
-            trans_layers_above(j, ibox)
-
-            ! update trans_layers_above with transmissivity
-            ! from this layer for next time around loop
-
-          trans_layers_above(j, ibox) = trans_layers_above(j, ibox)* &
-            (1.-dem(j,ibox))
-
-        END DO ! j
-      END DO ! ibox
-
-      ! IM
-      ! if (ncolprint.ne.0) then
-      ! do j=1,npoints,1000
-      ! write (6,'(a)') 'ilev:'
-      ! write (6,'(I2)') ilev
-
-      ! write(6,'(a10)') 'j='
-      ! write(6,'(8I10)') j
-      ! write (6,'(a)') 'emiss_layer:'
-      ! write (6,'(8f7.2)') (dem(j,ibox),ibox=1,ncolprint)
-
-      ! write (6,'(a)') '100.*bb(j):'
-      ! write (6,'(8f7.2)') (100.*bb(j),ibox=1,ncolprint)
-
-      ! write (6,'(a)') '100.*f:'
-      ! write (6,'(8f7.2)')
-      ! &         (100.*fluxtop(j,ibox),ibox=1,ncolprint)
-
-      ! write (6,'(a)') 'total_trans:'
-      ! write (6,'(8f7.2)')
-      ! &          (trans_layers_above(j,ibox),ibox=1,ncolprint)
-      ! enddo
-      ! endif
-
-    END DO ! ilev
-
-
-    DO j = 1, npoints
-        !add in surface emission
-      bb(j) = 1/(exp(1307.27/skt(j))-1.)
-        !bb(j)=5.67e-8*skt(j)**4
-    END DO
-
-    DO ibox = 1, ncol
-      DO j = 1, npoints
-
-          !add in surface emission
-
-        fluxtop(j, ibox) = fluxtop(j, ibox) + emsfc_lw*bb(j)* &
-          trans_layers_above(j, ibox)
-
-      END DO
-    END DO
-
-    ! IM
-    ! if (ncolprint.ne.0) then
-
-    ! do j=1,npoints ,1000
-    ! write(6,'(a10)') 'j='
-    ! write(6,'(8I10)') j
-    ! write (6,'(a)') 'id:'
-    ! write (6,'(a)') 'surface'
-
-    ! write (6,'(a)') 'emiss_layer:'
-    ! write (6,'(8f7.2)') (dem(1,ibox),ibox=1,ncolprint)
-
-    ! write (6,'(a)') '100.*bb(j):'
-    ! write (6,'(8f7.2)') (100.*bb(j),ibox=1,ncolprint)
-
-    ! write (6,'(a)') '100.*f:'
-    ! write (6,'(8f7.2)') (100.*fluxtop(j,ibox),ibox=1,ncolprint)
-    ! end do
-    ! endif
-
-      !now that you have the top of atmosphere radiance account
-      !for ISCCP procedures to determine cloud top temperature
-
-      !account for partially transmitting cloud recompute flux
-      !ISCCP would see assuming a single layer cloud
-      !note choice here of 2.13, as it is primarily ice
-      !clouds which have partial emissivity and need the
-      !adjustment performed in this section
-      !
-      !If it turns out that the cloud brightness temperature
-      !is greater than 260K, then the liquid cloud conversion
-      !factor of 2.56 is used.
-      !
-      !Note that this is discussed on pages 85-87 of
-      !the ISCCP D level documentation (Rossow et al. 1996)
-
-    DO j = 1, npoints
-        !compute minimum brightness temperature and optical depth
-      btcmin(j) = 1./(exp(1307.27/(attrop(j)-5.))-1.)
-    END DO
-    DO ibox = 1, ncol
-      DO j = 1, npoints
-        transmax(j) = (fluxtop(j,ibox)-btcmin(j))/(fluxtop_clrsky(j)-btcmin(j &
-          ))
-          !note that the initial setting of tauir(j) is needed so that
-          !tauir(j) has a realistic value should the next if block be
-          !bypassed
-        tauir(j) = tau(j, ibox)*rec2p13
-        taumin(j) = -1.*log(max(min(transmax(j),0.9999999),0.001))
-
-      END DO
-
-      IF (top_height==1) THEN
-        DO j = 1, npoints
-          IF (transmax(j)>0.001 .AND. transmax(j)<=0.9999999) THEN
-            fluxtopinit(j) = fluxtop(j, ibox)
-            tauir(j) = tau(j, ibox)*rec2p13
-          END IF
-        END DO
-        DO icycle = 1, 2
-          DO j = 1, npoints
-            IF (tau(j,ibox)>(tauchk)) THEN
-              IF (transmax(j)>0.001 .AND. transmax(j)<=0.9999999) THEN
-                emcld(j, ibox) = 1. - exp(-1.*tauir(j))
-                fluxtop(j, ibox) = fluxtopinit(j) - ((1.-emcld(j, &
-                  ibox))*fluxtop_clrsky(j))
-                fluxtop(j, ibox) = max(1.E-06, (fluxtop(j,ibox)/emcld(j, &
-                  ibox)))
-                tb(j, ibox) = 1307.27/(log(1.+(1./fluxtop(j,ibox))))
-                IF (tb(j,ibox)>260.) THEN
-                  tauir(j) = tau(j, ibox)/2.56
-                END IF
-              END IF
-            END IF
-          END DO
-        END DO
-
-      END IF
-
-      DO j = 1, npoints
-        IF (tau(j,ibox)>(tauchk)) THEN
-            !cloudy box
-          tb(j, ibox) = 1307.27/(log(1.+(1./fluxtop(j,ibox))))
-          IF (top_height==1 .AND. tauir(j)<taumin(j)) THEN
-            tb(j, ibox) = attrop(j) - 5.
-            tau(j, ibox) = 2.13*taumin(j)
-          END IF
-        ELSE
-            !clear sky brightness temperature
-          tb(j, ibox) = 1307.27/(log(1.+(1./fluxtop_clrsky(j))))
-        END IF
-      END DO ! j
-    END DO ! ibox
-
-    ! IM
-    ! if (ncolprint.ne.0) then
-
-    ! do j=1,npoints,1000
-    ! write(6,'(a10)') 'j='
-    ! write(6,'(8I10)') j
-
-    ! write (6,'(a)') 'attrop:'
-    ! write (6,'(8f7.2)') (attrop(j))
-
-    ! write (6,'(a)') 'btcmin:'
-    ! write (6,'(8f7.2)') (btcmin(j))
-
-    ! write (6,'(a)') 'fluxtop_clrsky*100:'
-    ! write (6,'(8f7.2)')
-    ! &      (100.*fluxtop_clrsky(j))
-
-    ! write (6,'(a)') '100.*f_adj:'
-    ! write (6,'(8f7.2)') (100.*fluxtop(j,ibox),ibox=1,ncolprint)
-
-    ! write (6,'(a)') 'transmax:'
-    ! write (6,'(8f7.2)') (transmax(ibox),ibox=1,ncolprint)
-
-    ! write (6,'(a)') 'tau:'
-    ! write (6,'(8f7.2)') (tau(j,ibox),ibox=1,ncolprint)
-
-    ! write (6,'(a)') 'emcld:'
-    ! write (6,'(8f7.2)') (emcld(j,ibox),ibox=1,ncolprint)
-
-    ! write (6,'(a)') 'total_trans:'
-    ! write (6,'(8f7.2)')
-    ! &          (trans_layers_above(j,ibox),ibox=1,ncolprint)
-
-    ! write (6,'(a)') 'total_emiss:'
-    ! write (6,'(8f7.2)')
-    ! &          (1.0-trans_layers_above(j,ibox),ibox=1,ncolprint)
-
-    ! write (6,'(a)') 'total_trans:'
-    ! write (6,'(8f7.2)')
-    ! &          (trans_layers_above(j,ibox),ibox=1,ncolprint)
-
-    ! write (6,'(a)') 'ppout:'
-    ! write (6,'(8f7.2)') (tb(j,ibox),ibox=1,ncolprint)
-    ! enddo ! j
-    ! endif
-
-  END IF
-
-  ! ---------------------------------------------------!
-
-
-  ! ---------------------------------------------------!
-  ! DETERMINE CLOUD TOP PRESSURE
-
-  ! again the 2 methods differ according to whether
-  ! or not you use the physical cloud top pressure (top_height = 2)
-  ! or the radiatively determined cloud top pressure (top_height = 1 or 3)
-
-
-    !compute cloud top pressure
-  DO ibox = 1, ncol
-      !segregate according to optical thickness
-    IF (top_height==1 .OR. top_height==3) THEN
-        !find level whose temperature
-        !most closely matches brightness temperature
-      DO j = 1, npoints
-        nmatch(j) = 0
-      END DO
-      DO ilev = 1, nlev - 1
-        ! cdir nodep
-        DO j = 1, npoints
-          IF ((at(j,ilev)>=tb(j,ibox) .AND. at(j,ilev+1)<tb(j, &
-              ibox)) .OR. (at(j,ilev)<=tb(j,ibox) .AND. at(j,ilev+1)>tb(j, &
-              ibox))) THEN
-
-            nmatch(j) = nmatch(j) + 1
-            IF (abs(at(j,ilev)-tb(j,ibox))<abs(at(j,ilev+1)-tb(j,ibox))) THEN
-              match(j, nmatch(j)) = ilev
-            ELSE
-              match(j, nmatch(j)) = ilev + 1
-            END IF
-          END IF
-        END DO
-      END DO
-
-      DO j = 1, npoints
-        IF (nmatch(j)>=1) THEN
-          ptop(j, ibox) = pfull(j, match(j,nmatch(j)))
-          levmatch(j, ibox) = match(j, nmatch(j))
-        ELSE
-          IF (tb(j,ibox)<atmin(j)) THEN
-            ptop(j, ibox) = ptrop(j)
-            levmatch(j, ibox) = itrop(j)
-          END IF
-          IF (tb(j,ibox)>atmax(j)) THEN
-            ptop(j, ibox) = pfull(j, nlev)
-            levmatch(j, ibox) = nlev
-          END IF
-        END IF
-      END DO ! j
-
-    ELSE ! if (top_height .eq. 1 .or. top_height .eq. 3)
-
-      DO j = 1, npoints
-        ptop(j, ibox) = 0.
-      END DO
-      DO ilev = 1, nlev
-        DO j = 1, npoints
-          IF ((ptop(j,ibox)==0.) & ! IM  &
-                                   ! .and.(frac_out(j,ibox,ilev) .ne. 0))
-                                   ! then
-              .AND. (frac_out(j,ibox,ilev)/=0.0)) THEN
-            ptop(j, ibox) = pfull(j, ilev)
-            levmatch(j, ibox) = ilev
-          END IF
-        END DO
-      END DO
-    END IF
-
-    DO j = 1, npoints
-      IF (tau(j,ibox)<=(tauchk)) THEN
-        ptop(j, ibox) = 0.
-        levmatch(j, ibox) = 0
-      END IF
-    END DO
-
-  END DO
-
-
-
-  ! ---------------------------------------------------!
-
-
-
-  ! ---------------------------------------------------!
-  ! DETERMINE ISCCP CLOUD TYPE FREQUENCIES
-
-  ! Now that ptop and tau have been determined,
-  ! determine amount of each of the 49 ISCCP cloud
-  ! types
-
-  ! Also compute grid box mean cloud top pressure and
-  ! optical thickness.  The mean cloud top pressure and
-  ! optical thickness are averages over the cloudy
-  ! area only. The mean cloud top pressure is a linear
-  ! average of the cloud top pressures.  The mean cloud
-  ! optical thickness is computed by converting optical
-  ! thickness to an albedo, averaging in albedo units,
-  ! then converting the average albedo back to a mean
-  ! optical thickness.
-
-
-    !compute isccp frequencies
-
-    !reset frequencies
-  DO ilev = 1, 7
-    DO ilev2 = 1, 7
-      DO j = 1, npoints !
-        fq_isccp(j, ilev, ilev2) = 0.
-      END DO
-    END DO
-  END DO
-
-    !reset variables need for averaging cloud properties
-  DO j = 1, npoints
-    totalcldarea(j) = 0.
-    meanalbedocld(j) = 0.
-    meanptop(j) = 0.
-    meantaucld(j) = 0.
-  END DO ! j
-
-  boxarea = 1./real(ncol)
-
-    !determine optical depth category
-  ! IM       do 39 j=1,npoints
-  ! IM       do ibox=1,ncol
-  DO ibox = 1, ncol
-    DO j = 1, npoints
-
-      ! IM
-      ! CALL CPU_time(t1)
-      ! IM
-
-      IF (tau(j,ibox)>(tauchk) .AND. ptop(j,ibox)>0.) THEN
-        box_cloudy(j, ibox) = .TRUE.
-      END IF
-
-      ! IM
-      ! CALL CPU_time(t2)
-      ! print*,'IF tau t2 - t1',t2 - t1
-
-      ! CALL CPU_time(t1)
-      ! IM
-
-      IF (box_cloudy(j,ibox)) THEN
-
-          ! totalcldarea always diagnosed day or night
-        totalcldarea(j) = totalcldarea(j) + boxarea
-
-        IF (sunlit(j)==1) THEN
-
-            ! tau diagnostics only with sunlight
-
-          boxtau(j, ibox) = tau(j, ibox)
-
-            !convert optical thickness to albedo
-          albedocld(j, ibox) = real(invtau(min(nint(100.*tau(j,ibox)), &
-            45000)))
-
-            !contribute to averaging
-          meanalbedocld(j) = meanalbedocld(j) + albedocld(j, ibox)*boxarea
-
-        END IF
-
-      END IF
-
-      ! IM
-      ! CALL CPU_time(t2)
-      ! print*,'IF box_cloudy t2 - t1',t2 - t1
-
-      ! CALL CPU_time(t1)
-      ! IM BEG
-      ! IM           !convert ptop to millibars
-      ptop(j, ibox) = ptop(j, ibox)/100.
-
-      ! IM           !save for output cloud top pressure and optical
-      ! thickness
-      boxptop(j, ibox) = ptop(j, ibox)
-      ! IM END
-
-      ! IM BEG
-        !reset itau(j), ipres(j)
-      itau(j) = 0
-      ipres(j) = 0
-
-      IF (tau(j,ibox)<isccp_taumin) THEN
-        itau(j) = 1
-      ELSE IF (tau(j,ibox)>=isccp_taumin .AND. tau(j,ibox)<1.3) THEN
-        itau(j) = 2
-      ELSE IF (tau(j,ibox)>=1.3 .AND. tau(j,ibox)<3.6) THEN
-        itau(j) = 3
-      ELSE IF (tau(j,ibox)>=3.6 .AND. tau(j,ibox)<9.4) THEN
-        itau(j) = 4
-      ELSE IF (tau(j,ibox)>=9.4 .AND. tau(j,ibox)<23.) THEN
-        itau(j) = 5
-      ELSE IF (tau(j,ibox)>=23. .AND. tau(j,ibox)<60.) THEN
-        itau(j) = 6
-      ELSE IF (tau(j,ibox)>=60.) THEN
-        itau(j) = 7
-      END IF
-
-        !determine cloud top pressure category
-      IF (ptop(j,ibox)>0. .AND. ptop(j,ibox)<180.) THEN
-        ipres(j) = 1
-      ELSE IF (ptop(j,ibox)>=180. .AND. ptop(j,ibox)<310.) THEN
-        ipres(j) = 2
-      ELSE IF (ptop(j,ibox)>=310. .AND. ptop(j,ibox)<440.) THEN
-        ipres(j) = 3
-      ELSE IF (ptop(j,ibox)>=440. .AND. ptop(j,ibox)<560.) THEN
-        ipres(j) = 4
-      ELSE IF (ptop(j,ibox)>=560. .AND. ptop(j,ibox)<680.) THEN
-        ipres(j) = 5
-      ELSE IF (ptop(j,ibox)>=680. .AND. ptop(j,ibox)<800.) THEN
-        ipres(j) = 6
-      ELSE IF (ptop(j,ibox)>=800.) THEN
-        ipres(j) = 7
-      END IF
-      ! IM END
-
-      IF (sunlit(j)==1 .OR. top_height==3) THEN
-
-        ! IM         !convert ptop to millibars
-        ! IM           ptop(j,ibox)=ptop(j,ibox) / 100.
-
-        ! IM         !save for output cloud top pressure and optical
-        ! thickness
-        ! IM             boxptop(j,ibox) = ptop(j,ibox)
-
-        IF (box_cloudy(j,ibox)) THEN
-
-          meanptop(j) = meanptop(j) + ptop(j, ibox)*boxarea
-
-          ! IM             !reset itau(j), ipres(j)
-          ! IM           itau(j) = 0
-          ! IM           ipres(j) = 0
-
-          ! if (tau(j,ibox) .lt. isccp_taumin) then
-          ! itau(j)=1
-          ! else if (tau(j,ibox) .ge. isccp_taumin
-          ! &
-          ! &          .and. tau(j,ibox) .lt. 1.3) then
-          ! itau(j)=2
-          ! else if (tau(j,ibox) .ge. 1.3
-          ! &          .and. tau(j,ibox) .lt. 3.6) then
-          ! itau(j)=3
-          ! else if (tau(j,ibox) .ge. 3.6
-          ! &          .and. tau(j,ibox) .lt. 9.4) then
-          ! itau(j)=4
-          ! else if (tau(j,ibox) .ge. 9.4
-          ! &          .and. tau(j,ibox) .lt. 23.) then
-          ! itau(j)=5
-          ! else if (tau(j,ibox) .ge. 23.
-          ! &          .and. tau(j,ibox) .lt. 60.) then
-          ! itau(j)=6
-          ! else if (tau(j,ibox) .ge. 60.) then
-          ! itau(j)=7
-          ! end if
-
-          ! !determine cloud top pressure category
-          ! if (    ptop(j,ibox) .gt. 0.
-          ! &          .and.ptop(j,ibox) .lt. 180.) then
-          ! ipres(j)=1
-          ! else if(ptop(j,ibox) .ge. 180.
-          ! &          .and.ptop(j,ibox) .lt. 310.) then
-          ! ipres(j)=2
-          ! else if(ptop(j,ibox) .ge. 310.
-          ! &          .and.ptop(j,ibox) .lt. 440.) then
-          ! ipres(j)=3
-          ! else if(ptop(j,ibox) .ge. 440.
-          ! &          .and.ptop(j,ibox) .lt. 560.) then
-          ! ipres(j)=4
-          ! else if(ptop(j,ibox) .ge. 560.
-          ! &          .and.ptop(j,ibox) .lt. 680.) then
-          ! ipres(j)=5
-          ! else if(ptop(j,ibox) .ge. 680.
-          ! &          .and.ptop(j,ibox) .lt. 800.) then
-          ! ipres(j)=6
-          ! else if(ptop(j,ibox) .ge. 800.) then
-          ! ipres(j)=7
-          ! end if
-
-            !update frequencies
-          IF (ipres(j)>0 .AND. itau(j)>0) THEN
-            fq_isccp(j, itau(j), ipres(j)) = fq_isccp(j, itau(j), ipres(j)) + &
-              boxarea
-          END IF
-
-          ! IM calcul stats regime dynamique BEG
-          ! iw(j) = int((w(j)-wmin)/pas_w) +1
-          ! pctj(itau(j),ipres(j),iw(j))=.FALSE.
-          ! !update frequencies W500
-          ! if (pct_ocean(j)) then
-          ! if (ipres(j) .gt. 0.and.itau(j) .gt. 0) then
-          ! if (iw(j) .gt. int(wmin).and.iw(j) .le. iwmx) then
-          ! print*,' ISCCP iw=',iw(j),j
-          ! fq_dynreg(itau(j),ipres(j),iw(j))=
-          ! &          fq_dynreg(itau(j),ipres(j),iw(j))+
-          ! &          boxarea
-          ! &          fq_isccp(j,itau(j),ipres(j))
-          ! pctj(itau(j),ipres(j),iw(j))=.TRUE.
-          ! nfq_dynreg(itau(j),ipres(j),iw(j))=
-          ! &          nfq_dynreg(itau(j),ipres(j),iw(j))+1.
-          ! end if
-          ! end if
-          ! end if
-          ! IM calcul stats regime dynamique END
-        END IF !IM boxcloudy
-
-      END IF !IM sunlit
-
-      ! IM
-      ! CALL CPU_time(t2)
-      ! print*,'IF sunlit boxcloudy t2 - t1',t2 - t1
-      ! IM
-    END DO !IM ibox/j
-
-
-    ! IM ajout stats s/ W500 BEG
-    ! IM ajout stats s/ W500 END
-
-    ! if(j.EQ.6722) then
-    ! print*,' ISCCP',w(j),iw(j),ipres(j),itau(j)
-    ! endif
-
-    ! if (pct_ocean(j)) then
-    ! if (ipres(j) .gt. 0.and.itau(j) .gt. 0) then
-    ! if (iw(j) .gt. int(wmin).and.iw(j) .le. iwmx) then
-    ! if(pctj(itau(j),ipres(j),iw(j))) THEN
-    ! nfq_dynreg(itau(j),ipres(j),iw(j))=
-    ! &    nfq_dynreg(itau(j),ipres(j),iw(j))+1.
-    ! if(itau(j).EQ.4.AND.ipres(j).EQ.2.AND.
-    ! &    iw(j).EQ.10) then
-    ! PRINT*,' isccp AVANT',
-    ! &    nfq_dynreg(itau(j),ipres(j),iw(j)),
-    ! &    fq_dynreg(itau(j),ipres(j),iw(j))
-    ! endif
-    ! endif
-    ! endif
-    ! endif
-    ! endif
-
-  END DO
-    !compute mean cloud properties
-  ! IM j/ibox
-  DO j = 1, npoints
-    IF (totalcldarea(j)>0.) THEN
-      meanptop(j) = meanptop(j)/totalcldarea(j)
-      IF (sunlit(j)==1) THEN
-        meanalbedocld(j) = meanalbedocld(j)/totalcldarea(j)
-        meantaucld(j) = tautab(min(255,max(1,nint(meanalbedocld(j)))))
-      END IF
-    END IF
-  END DO ! j
-
-  ! IM ajout stats s/ W500 BEG
-  ! do nw = 1, iwmx
-  ! do l = 1, 7
-  ! do k = 1, 7
-  ! if (nfq_dynreg(k,l,nw).GT.0.) then
-  ! fq_dynreg(k,l,nw) = fq_dynreg(k,l,nw)/nfq_dynreg(k,l,nw)
-  ! if(k.EQ.4.AND.l.EQ.2.AND.nw.EQ.10) then
-  ! print*,' isccp APRES',nfq_dynreg(k,l,nw),
-  ! &   fq_dynreg(k,l,nw)
-  ! endif
-  ! else
-  ! if(fq_dynreg(k,l,nw).NE.0.) then
-  ! print*,'nfq_dynreg = 0 tau,pc,nw',k,l,nw,fq_dynreg(k,l,nw)
-  ! endif
-  ! fq_dynreg(k,l,nw) = -1.E+20
-  ! nfq_dynreg(k,l,nw) = 1.E+20
-  ! end if
-  ! enddo !k
-  ! enddo !l
-  ! enddo !nw
-  ! IM ajout stats s/ W500 END
-  ! ---------------------------------------------------!
-
-  ! ---------------------------------------------------!
-  ! OPTIONAL PRINTOUT OF DATA TO CHECK PROGRAM
-
-  ! cIM
-  ! if (debugcol.ne.0) then
-
-  ! do j=1,npoints,debugcol
-
-  ! !produce character output
-  ! do ilev=1,nlev
-  ! do ibox=1,ncol
-  ! acc(ilev,ibox)=0
-  ! enddo
-  ! enddo
-
-  ! do ilev=1,nlev
-  ! do ibox=1,ncol
-  ! acc(ilev,ibox)=frac_out(j,ibox,ilev)*2
-  ! if (levmatch(j,ibox) .eq. ilev)
-  ! &                 acc(ilev,ibox)=acc(ilev,ibox)+1
-  ! enddo
-  ! enddo
-
-    !print test
-
-  ! write(ftn09,11) j
-  ! 11        format('ftn09.',i4.4)
-  ! open(9, FILE=ftn09, FORM='FORMATTED')
-
-  ! write(9,'(a1)') ' '
-  ! write(9,'(10i5)')
-  ! &                  (ilev,ilev=5,nlev,5)
-  ! write(9,'(a1)') ' '
-
-  ! do ibox=1,ncol
-  ! write(9,'(40(a1),1x,40(a1))')
-  ! &           (cchar_realtops(acc(ilev,ibox)+1),ilev=1,nlev)
-  ! &           ,(cchar(acc(ilev,ibox)+1),ilev=1,nlev)
-  ! end do
-  ! close(9)
-
-  ! IM
-  ! if (ncolprint.ne.0) then
-  ! write(6,'(a1)') ' '
-  ! write(6,'(a2,1X,5(a7,1X),a50)')
-  ! &                  'ilev',
-  ! &                  'pfull','at',
-  ! &                  'cc*100','dem_s','dtau_s',
-  ! &                  'cchar'
-
-  ! do 4012 ilev=1,nlev
-  ! write(6,'(60i2)') (box(i,ilev),i=1,ncolprint)
-  ! write(6,'(i2,1X,5(f7.2,1X),50(a1))')
-  ! &                  ilev,
-  ! &                  pfull(j,ilev)/100.,at(j,ilev),
-  ! &                  cc(j,ilev)*100.0,dem_s(j,ilev),dtau_s(j,ilev)
-  ! &                  ,(cchar(acc(ilev,ibox)+1),ibox=1,ncolprint)
-  ! 4012           continue
-  ! write (6,'(a)') 'skt(j):'
-  ! write (6,'(8f7.2)') skt(j)
-
-  ! write (6,'(8I7)') (ibox,ibox=1,ncolprint)
-
-  ! write (6,'(a)') 'tau:'
-  ! write (6,'(8f7.2)') (tau(j,ibox),ibox=1,ncolprint)
-
-  ! write (6,'(a)') 'tb:'
-  ! write (6,'(8f7.2)') (tb(j,ibox),ibox=1,ncolprint)
-
-  ! write (6,'(a)') 'ptop:'
-  ! write (6,'(8f7.2)') (ptop(j,ibox),ibox=1,ncolprint)
-  ! endif
-
-  ! enddo
-
-  ! end if
-
-  RETURN
-END SUBROUTINE isccp_cloud_types
Index: /LMDZ6/trunk/libf/phylmd/isccp_cloud_types.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/isccp_cloud_types.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/isccp_cloud_types.f90	(revision 5268)
@@ -0,0 +1,1611 @@
+
+! $Id $
+
+SUBROUTINE isccp_cloud_types(debug, debugcol, npoints, sunlit, nlev, ncol, &
+    seed, pfull, phalf, qv, cc, conv, dtau_s, dtau_c, top_height, overlap, &
+    tautab, invtau, skt, emsfc_lw, at, dem_s, dem_c, fq_isccp, totalcldarea, &
+    meanptop, meantaucld, boxtau, boxptop)
+
+
+  ! Copyright Steve Klein and Mark Webb 2002 - all rights reserved.
+
+  ! This code is available without charge with the following conditions:
+
+  ! 1. The code is available for scientific purposes and is not for
+  ! commercial use.
+  ! 2. Any improvements you make to the code should be made available
+  ! to the to the authors for incorporation into a future release.
+  ! 3. The code should not be used in any way that brings the authors
+  ! or their employers into disrepute.
+
+  IMPLICIT NONE
+
+  ! NOTE:   the maximum number of levels and columns is set by
+  ! the following parameter statement
+
+  INTEGER ncolprint
+
+  ! -----
+  ! Input
+  ! -----
+
+  INTEGER npoints !  number of model points in the horizontal
+  ! PARAMETER(npoints=6722)
+  INTEGER nlev !  number of model levels in column
+  INTEGER ncol !  number of subcolumns
+
+  INTEGER sunlit(npoints) !  1 for day points, 0 for night time
+
+  INTEGER seed(npoints) !  seed value for random number generator
+  ! !  ( see Numerical Recipes Chapter 7)
+  ! !  It is recommended that the seed is set
+  ! !  to a different value for each model
+  ! !  gridbox it is called on, as it is
+  ! !  possible that the choice of the samec
+  ! !  seed value every time may introduce some
+  ! !  statistical bias in the results, particularly
+  ! !  for low values of NCOL.
+
+  REAL pfull(npoints, nlev) !  pressure of full model levels (Pascals)
+  ! !  pfull(npoints,1)    is    top level of model
+  ! !  pfull(npoints,nlev) is bottom level of model
+
+  REAL phalf(npoints, nlev+1) !  pressure of half model levels (Pascals)
+  ! !  phalf(npoints,1)    is    top       of model
+  ! !  phalf(npoints,nlev+1) is the surface pressure
+
+  REAL qv(npoints, nlev) !  water vapor specific humidity (kg vapor/ kg air)
+  ! !         on full model levels
+
+  REAL cc(npoints, nlev) !  input cloud cover in each model level (fraction)
+  ! !  NOTE:  This is the HORIZONTAL area of each
+  ! !         grid box covered by clouds
+
+  REAL conv(npoints, nlev) !  input convective cloud cover in each model level (fraction)
+  ! !  NOTE:  This is the HORIZONTAL area of each
+  ! !         grid box covered by convective clouds
+
+  REAL dtau_s(npoints, nlev) !  mean 0.67 micron optical depth of stratiform
+  ! !  clouds in each model level
+  ! !  NOTE:  this the cloud optical depth of only the
+  ! !         cloudy part of the grid box, it is not weighted
+  ! !         with the 0 cloud optical depth of the clear
+  ! !         part of the grid box
+
+  REAL dtau_c(npoints, nlev) !  mean 0.67 micron optical depth of convective
+  ! !  clouds in each
+  ! !  model level.  Same note applies as in dtau_s.
+
+  INTEGER overlap !  overlap type
+
+  ! 1=max
+
+  ! 2=rand
+  ! 3=max/rand
+
+  INTEGER top_height !  1 = adjust top height using both a computed
+  ! !  infrared brightness temperature and the visible
+  ! !  optical depth to adjust cloud top pressure. Note
+  ! !  that this calculation is most appropriate to compare
+  ! !  to ISCCP data during sunlit hours.
+  ! !  2 = do not adjust top height, that is cloud top
+  ! !  pressure is the actual cloud top pressure
+  ! !  in the model
+  ! !  3 = adjust top height using only the computed
+  ! !  infrared brightness temperature. Note that this
+  ! !  calculation is most appropriate to compare to ISCCP
+  ! !  IR only algortihm (i.e. you can compare to nighttime
+  ! !  ISCCP data with this option)
+
+  REAL tautab(0:255) !  ISCCP table for converting count value to
+  ! !  optical thickness
+
+  INTEGER invtau(-20:45000) !  ISCCP table for converting optical thickness
+  ! !  to count value
+
+  ! The following input variables are used only if top_height = 1 or
+  ! top_height = 3
+
+  REAL skt(npoints) !  skin Temperature (K)
+  REAL emsfc_lw !  10.5 micron emissivity of surface (fraction)
+  REAL at(npoints, nlev) !  temperature in each model level (K)
+  REAL dem_s(npoints, nlev) !  10.5 micron longwave emissivity of stratiform
+  ! !  clouds in each
+  ! !  model level.  Same note applies as in dtau_s.
+  REAL dem_c(npoints, nlev) !  10.5 micron longwave emissivity of convective
+  ! !  clouds in each
+  ! !  model level.  Same note applies as in dtau_s.
+  ! IM reg.dyn BEG
+  REAL t1, t2
+  ! REAL w(npoints)                   !vertical wind at 500 hPa
+  ! LOGICAL pct_ocean(npoints)        !TRUE if oceanic point, FALSE otherway
+  ! INTEGER iw(npoints) , nw
+  ! REAL wmin, pas_w
+  ! INTEGER k, l, iwmx
+  ! PARAMETER(wmin=-100.,pas_w=10.,iwmx=30)
+  ! REAL fq_dynreg(7,7,iwmx)
+  ! REAL nfq_dynreg(7,7,iwmx)
+  ! LOGICAL pctj(7,7,iwmx)
+  ! IM reg.dyn END
+  ! ------
+  ! Output
+  ! ------
+
+  REAL fq_isccp(npoints, 7, 7) !  the fraction of the model grid box covered by
+  ! !  each of the 49 ISCCP D level cloud types
+
+  REAL totalcldarea(npoints) !  the fraction of model grid box columns
+  ! !  with cloud somewhere in them.  This should
+  ! !  equal the sum over all entries of fq_isccp
+
+
+  ! ! The following three means are averages over the cloudy areas only.  If
+  ! no
+  ! ! clouds are in grid box all three quantities should equal zero.
+
+  REAL meanptop(npoints) !  mean cloud top pressure (mb) - linear averaging
+  ! !  in cloud top pressure.
+
+  REAL meantaucld(npoints) !  mean optical thickness
+  ! !  linear averaging in albedo performed.
+
+  REAL boxtau(npoints, ncol) !  optical thickness in each column
+
+  REAL boxptop(npoints, ncol) !  cloud top pressure (mb) in each column
+
+
+
+  ! ------
+  ! Working variables added when program updated to mimic Mark Webb's PV-Wave
+  ! code
+  ! ------
+
+  REAL frac_out(npoints, ncol, nlev) ! boxes gridbox divided up into
+  ! ! Equivalent of BOX in original version, but
+  ! ! indexed by column then row, rather than
+  ! ! by row then column
+
+  REAL tca(npoints, 0:nlev) ! total cloud cover in each model level (fraction)
+  ! ! with extra layer of zeroes on top
+  ! ! in this version this just contains the values input
+  ! ! from cc but with an extra level
+  REAL cca(npoints, nlev) ! convective cloud cover in each model level (fraction)
+  ! ! from conv
+
+  REAL threshold(npoints, ncol) ! pointer to position in gridbox
+  REAL maxocc(npoints, ncol) ! Flag for max overlapped conv cld
+  REAL maxosc(npoints, ncol) ! Flag for max overlapped strat cld
+
+  REAL boxpos(npoints, ncol) ! ordered pointer to position in gridbox
+
+  REAL threshold_min(npoints, ncol) ! minimum value to define range in with new threshold
+  ! ! is chosen
+
+  REAL dem(npoints, ncol), bb(npoints) !  working variables for 10.5 micron longwave
+  ! !  emissivity in part of
+  ! !  gridbox under consideration
+
+  REAL ran(npoints) ! vector of random numbers
+  REAL ptrop(npoints)
+  REAL attrop(npoints)
+  REAL attropmin(npoints)
+  REAL atmax(npoints)
+  REAL atmin(npoints)
+  REAL btcmin(npoints)
+  REAL transmax(npoints)
+
+  INTEGER i, j, ilev, ibox, itrop(npoints)
+  INTEGER ipres(npoints)
+  INTEGER itau(npoints), ilev2
+  INTEGER acc(nlev, ncol)
+  INTEGER match(npoints, nlev-1)
+  INTEGER nmatch(npoints)
+  INTEGER levmatch(npoints, ncol)
+
+  ! !variables needed for water vapor continuum absorption
+  REAL fluxtop_clrsky(npoints), trans_layers_above_clrsky(npoints)
+  REAL taumin(npoints)
+  REAL dem_wv(npoints, nlev), wtmair, wtmh20, navo, grav, pstd, t0
+  REAL press(npoints), dpress(npoints), atmden(npoints)
+  REAL rvh20(npoints), wk(npoints), rhoave(npoints)
+  REAL rh20s(npoints), rfrgn(npoints)
+  REAL tmpexp(npoints), tauwv(npoints)
+
+  CHARACTER *1 cchar(6), cchar_realtops(6)
+  INTEGER icycle
+  REAL tau(npoints, ncol)
+  LOGICAL box_cloudy(npoints, ncol)
+  REAL tb(npoints, ncol)
+  REAL ptop(npoints, ncol)
+  REAL emcld(npoints, ncol)
+  REAL fluxtop(npoints, ncol)
+  REAL trans_layers_above(npoints, ncol)
+  REAL isccp_taumin, fluxtopinit(npoints), tauir(npoints)
+  REAL meanalbedocld(npoints)
+  REAL albedocld(npoints, ncol)
+  REAL boxarea
+  INTEGER debug ! set to non-zero value to print out inputs
+  ! ! with step debug
+  INTEGER debugcol ! set to non-zero value to print out column
+  ! ! decomposition with step debugcol
+
+  INTEGER index1(npoints), num1, jj
+  REAL rec2p13, tauchk
+
+  CHARACTER *10 ftn09
+
+  DATA isccp_taumin/0.3/
+  DATA cchar/' ', '-', '1', '+', 'I', '+'/
+  DATA cchar_realtops/' ', ' ', '1', '1', 'I', 'I'/
+
+  tauchk = -1.*log(0.9999999)
+  rec2p13 = 1./2.13
+
+  ncolprint = 0
+
+  ! IM
+  ! PRINT*,' isccp_cloud_types npoints=',npoints
+
+  ! if ( debug.ne.0 ) then
+  ! j=1
+  ! write(6,'(a10)') 'j='
+  ! write(6,'(8I10)') j
+  ! write(6,'(a10)') 'debug='
+  ! write(6,'(8I10)') debug
+  ! write(6,'(a10)') 'debugcol='
+  ! write(6,'(8I10)') debugcol
+  ! write(6,'(a10)') 'npoints='
+  ! write(6,'(8I10)') npoints
+  ! write(6,'(a10)') 'nlev='
+  ! write(6,'(8I10)') nlev
+  ! write(6,'(a10)') 'ncol='
+  ! write(6,'(8I10)') ncol
+  ! write(6,'(a10)') 'top_height='
+  ! write(6,'(8I10)') top_height
+  ! write(6,'(a10)') 'overlap='
+  ! write(6,'(8I10)') overlap
+  ! write(6,'(a10)') 'emsfc_lw='
+  ! write(6,'(8f10.2)') emsfc_lw
+  ! write(6,'(a10)') 'tautab='
+  ! write(6,'(8f10.2)') tautab
+  ! write(6,'(a10)') 'invtau(1:100)='
+  ! write(6,'(8i10)') (invtau(i),i=1,100)
+  ! do j=1,npoints,debug
+  ! write(6,'(a10)') 'j='
+  ! write(6,'(8I10)') j
+  ! write(6,'(a10)') 'sunlit='
+  ! write(6,'(8I10)') sunlit(j)
+  ! write(6,'(a10)') 'seed='
+  ! write(6,'(8I10)') seed(j)
+  ! write(6,'(a10)') 'pfull='
+  ! write(6,'(8f10.2)') (pfull(j,i),i=1,nlev)
+  ! write(6,'(a10)') 'phalf='
+  ! write(6,'(8f10.2)') (phalf(j,i),i=1,nlev+1)
+  ! write(6,'(a10)') 'qv='
+  ! write(6,'(8f10.3)') (qv(j,i),i=1,nlev)
+  ! write(6,'(a10)') 'cc='
+  ! write(6,'(8f10.3)') (cc(j,i),i=1,nlev)
+  ! write(6,'(a10)') 'conv='
+  ! write(6,'(8f10.2)') (conv(j,i),i=1,nlev)
+  ! write(6,'(a10)') 'dtau_s='
+  ! write(6,'(8g12.5)') (dtau_s(j,i),i=1,nlev)
+  ! write(6,'(a10)') 'dtau_c='
+  ! write(6,'(8f10.2)') (dtau_c(j,i),i=1,nlev)
+  ! write(6,'(a10)') 'skt='
+  ! write(6,'(8f10.2)') skt(j)
+  ! write(6,'(a10)') 'at='
+  ! write(6,'(8f10.2)') (at(j,i),i=1,nlev)
+  ! write(6,'(a10)') 'dem_s='
+  ! write(6,'(8f10.3)') (dem_s(j,i),i=1,nlev)
+  ! write(6,'(a10)') 'dem_c='
+  ! write(6,'(8f10.2)') (dem_c(j,i),i=1,nlev)
+  ! enddo
+  ! endif
+
+  ! ---------------------------------------------------!
+
+  ! assign 2d tca array using 1d input array cc
+
+  DO j = 1, npoints
+    tca(j, 0) = 0
+  END DO
+
+  DO ilev = 1, nlev
+    DO j = 1, npoints
+      tca(j, ilev) = cc(j, ilev)
+    END DO
+  END DO
+
+  ! assign 2d cca array using 1d input array conv
+
+  DO ilev = 1, nlev
+    ! IM pas besoin        do ibox=1,ncol
+    DO j = 1, npoints
+      cca(j, ilev) = conv(j, ilev)
+    END DO
+    ! IM        enddo
+  END DO
+
+  ! IM
+  ! do j=1, iwmx
+  ! do l=1, 7
+  ! do k=1, 7
+  ! fq_dynreg(k,l,j) =0.
+  ! nfq_dynreg(k,l,j) =0.
+  ! enddo !k
+  ! enddo !l
+  ! enddo !j
+  ! IM
+  ! IM
+  ! if (ncolprint.ne.0) then
+  ! do j=1,npoints,1000
+  ! write(6,'(a10)') 'j='
+  ! write(6,'(8I10)') j
+  ! write (6,'(a)') 'seed:'
+  ! write (6,'(I3.2)') seed(j)
+
+  ! write (6,'(a)') 'tca_pp_rev:'
+  ! write (6,'(8f5.2)')
+  ! &   ((tca(j,ilev)),
+  ! &      ilev=1,nlev)
+
+  ! write (6,'(a)') 'cca_pp_rev:'
+  ! write (6,'(8f5.2)')
+  ! &   ((cca(j,ilev),ibox=1,ncolprint),ilev=1,nlev)
+  ! enddo
+  ! endif
+
+  IF (top_height==1 .OR. top_height==3) THEN
+
+    DO j = 1, npoints
+      ptrop(j) = 5000.
+      atmin(j) = 400.
+      attropmin(j) = 400.
+      atmax(j) = 0.
+      attrop(j) = 120.
+      itrop(j) = 1
+    END DO
+
+    DO ilev = 1, nlev
+      DO j = 1, npoints
+        IF (pfull(j,ilev)<40000. .AND. pfull(j,ilev)>5000. .AND. &
+            at(j,ilev)<attropmin(j)) THEN
+          ptrop(j) = pfull(j, ilev)
+          attropmin(j) = at(j, ilev)
+          attrop(j) = attropmin(j)
+          itrop(j) = ilev
+        END IF
+        IF (at(j,ilev)>atmax(j)) atmax(j) = at(j, ilev)
+        IF (at(j,ilev)<atmin(j)) atmin(j) = at(j, ilev)
+      END DO
+    END DO
+
+  END IF
+
+  ! -----------------------------------------------------!
+
+  ! ---------------------------------------------------!
+
+  ! IM
+  ! do 13 ilev=1,nlev
+  ! num1=0
+  ! do j=1,npoints
+  ! if (cc(j,ilev) .lt. 0. .or. cc(j,ilev) .gt. 1.) then
+  ! num1=num1+1
+  ! index1(num1)=j
+  ! end if
+  ! enddo
+  ! do jj=1,num1
+  ! j=index1(jj)
+  ! write(6,*)  ' error = cloud fraction less than zero'
+  ! write(6,*) ' or '
+  ! write(6,*)  ' error = cloud fraction greater than 1'
+  ! write(6,*) 'value at point ',j,' is ',cc(j,ilev)
+  ! write(6,*) 'level ',ilev
+  ! STOP
+  ! enddo
+  ! num1=0
+  ! do j=1,npoints
+  ! if (conv(j,ilev) .lt. 0. .or. conv(j,ilev) .gt. 1.) then
+  ! num1=num1+1
+  ! index1(num1)=j
+  ! end if
+  ! enddo
+  ! do jj=1,num1
+  ! j=index1(jj)
+  ! write(6,*)
+  ! &           ' error = convective cloud fraction less than zero'
+  ! write(6,*) ' or '
+  ! write(6,*)
+  ! &           ' error = convective cloud fraction greater than 1'
+  ! write(6,*) 'value at point ',j,' is ',conv(j,ilev)
+  ! write(6,*) 'level ',ilev
+  ! STOP
+  ! enddo
+
+  ! num1=0
+  ! do j=1,npoints
+  ! if (dtau_s(j,ilev) .lt. 0.) then
+  ! num1=num1+1
+  ! index1(num1)=j
+  ! end if
+  ! enddo
+  ! do jj=1,num1
+  ! j=index1(jj)
+  ! write(6,*)
+  ! &           ' error = stratiform cloud opt. depth less than zero'
+  ! write(6,*) 'value at point ',j,' is ',dtau_s(j,ilev)
+  ! write(6,*) 'level ',ilev
+  ! STOP
+  ! enddo
+  ! num1=0
+  ! do j=1,npoints
+  ! if (dtau_c(j,ilev) .lt. 0.) then
+  ! num1=num1+1
+  ! index1(num1)=j
+  ! end if
+  ! enddo
+  ! do jj=1,num1
+  ! j=index1(jj)
+  ! write(6,*)
+  ! &           ' error = convective cloud opt. depth less than zero'
+  ! write(6,*) 'value at point ',j,' is ',dtau_c(j,ilev)
+  ! write(6,*) 'level ',ilev
+  ! STOP
+  ! enddo
+
+  ! num1=0
+  ! do j=1,npoints
+  ! if (dem_s(j,ilev) .lt. 0. .or. dem_s(j,ilev) .gt. 1.) then
+  ! num1=num1+1
+  ! index1(num1)=j
+  ! end if
+  ! enddo
+  ! do jj=1,num1
+  ! j=index1(jj)
+  ! write(6,*)
+  ! &           ' error = stratiform cloud emissivity less than zero'
+  ! write(6,*)'or'
+  ! write(6,*)
+  ! &           ' error = stratiform cloud emissivity greater than 1'
+  ! write(6,*) 'value at point ',j,' is ',dem_s(j,ilev)
+  ! write(6,*) 'level ',ilev
+  ! STOP
+  ! enddo
+
+  ! num1=0
+  ! do j=1,npoints
+  ! if (dem_c(j,ilev) .lt. 0. .or. dem_c(j,ilev) .gt. 1.) then
+  ! num1=num1+1
+  ! index1(num1)=j
+  ! end if
+  ! enddo
+  ! do jj=1,num1
+  ! j=index1(jj)
+  ! write(6,*)
+  ! &           ' error = convective cloud emissivity less than zero'
+  ! write(6,*)'or'
+  ! write(6,*)
+  ! &           ' error = convective cloud emissivity greater than 1'
+  ! write (6,*)
+  ! &          'j=',j,'ilev=',ilev,'dem_c(j,ilev) =',dem_c(j,ilev)
+  ! STOP
+  ! enddo
+  ! 13    continue
+
+
+  DO ibox = 1, ncol
+    DO j = 1, npoints
+      boxpos(j, ibox) = (ibox-.5)/ncol
+    END DO
+  END DO
+
+  ! ---------------------------------------------------!
+  ! Initialise working variables
+  ! ---------------------------------------------------!
+
+  ! Initialised frac_out to zero
+
+  DO ilev = 1, nlev
+    DO ibox = 1, ncol
+      DO j = 1, npoints
+        frac_out(j, ibox, ilev) = 0.0
+      END DO
+    END DO
+  END DO
+
+  ! IM
+  ! if (ncolprint.ne.0) then
+  ! write (6,'(a)') 'frac_out_pp_rev:'
+  ! do j=1,npoints,1000
+  ! write(6,'(a10)') 'j='
+  ! write(6,'(8I10)') j
+  ! write (6,'(8f5.2)')
+  ! &     ((frac_out(j,ibox,ilev),ibox=1,ncolprint),ilev=1,nlev)
+
+  ! enddo
+  ! write (6,'(a)') 'ncol:'
+  ! write (6,'(I3)') ncol
+  ! endif
+  ! if (ncolprint.ne.0) then
+  ! write (6,'(a)') 'last_frac_pp:'
+  ! do j=1,npoints,1000
+  ! write(6,'(a10)') 'j='
+  ! write(6,'(8I10)') j
+  ! write (6,'(8f5.2)') (tca(j,0))
+  ! enddo
+  ! endif
+
+  ! ---------------------------------------------------!
+  ! ALLOCATE CLOUD INTO BOXES, FOR NCOLUMNS, NLEVELS
+  ! frac_out is the array that contains the information
+  ! where 0 is no cloud, 1 is a stratiform cloud and 2 is a
+  ! convective cloud
+
+    !loop over vertical levels
+  DO ilev = 1, nlev
+
+    ! Initialise threshold
+
+    IF (ilev==1) THEN
+        ! If max overlap
+      IF (overlap==1) THEN
+          ! select pixels spread evenly
+          ! across the gridbox
+        DO ibox = 1, ncol
+          DO j = 1, npoints
+            threshold(j, ibox) = boxpos(j, ibox)
+          END DO
+        END DO
+      ELSE
+        DO ibox = 1, ncol
+          CALL ran0_vec(npoints, seed, ran)
+            ! select random pixels from the non-convective
+            ! part the gridbox ( some will be converted into
+            ! convective pixels below )
+          DO j = 1, npoints
+            threshold(j, ibox) = cca(j, ilev) + (1-cca(j,ilev))*ran(j)
+          END DO
+        END DO
+      END IF
+      ! IM
+      ! IF (ncolprint.ne.0) then
+      ! write (6,'(a)') 'threshold_nsf2:'
+      ! do j=1,npoints,1000
+      ! write(6,'(a10)') 'j='
+      ! write(6,'(8I10)') j
+      ! write (6,'(8f5.2)') (threshold(j,ibox),ibox=1,ncolprint)
+      ! enddo
+      ! ENDIF
+    END IF
+
+    ! IF (ncolprint.ne.0) then
+    ! write (6,'(a)') 'ilev:'
+    ! write (6,'(I2)') ilev
+    ! ENDIF
+
+    DO ibox = 1, ncol
+
+        ! All versions
+      DO j = 1, npoints
+        IF (boxpos(j,ibox)<=cca(j,ilev)) THEN
+          ! IM REAL           maxocc(j,ibox) = 1
+          maxocc(j, ibox) = 1.0
+        ELSE
+          ! IM REAL           maxocc(j,ibox) = 0
+          maxocc(j, ibox) = 0.0
+        END IF
+      END DO
+
+        ! Max overlap
+      IF (overlap==1) THEN
+        DO j = 1, npoints
+          threshold_min(j, ibox) = cca(j, ilev)
+          ! IM REAL           maxosc(j,ibox)=1
+          maxosc(j, ibox) = 1.0
+        END DO
+      END IF
+
+        ! Random overlap
+      IF (overlap==2) THEN
+        DO j = 1, npoints
+          threshold_min(j, ibox) = cca(j, ilev)
+          ! IM REAL           maxosc(j,ibox)=0
+          maxosc(j, ibox) = 0.0
+        END DO
+      END IF
+
+        ! Max/Random overlap
+      IF (overlap==3) THEN
+        DO j = 1, npoints
+          threshold_min(j, ibox) = max(cca(j,ilev), min(tca(j,ilev-1),tca(j, &
+            ilev)))
+          IF (threshold(j,ibox)<min(tca(j,ilev-1),tca(j, &
+              ilev)) .AND. (threshold(j,ibox)>cca(j,ilev))) THEN
+            ! IM REAL                maxosc(j,ibox)= 1
+            maxosc(j, ibox) = 1.0
+          ELSE
+            ! IM REAL                 maxosc(j,ibox)= 0
+            maxosc(j, ibox) = 0.0
+          END IF
+        END DO
+      END IF
+
+        ! Reset threshold
+      CALL ran0_vec(npoints, seed, ran)
+
+      DO j = 1, npoints
+        threshold(j, ibox) = &       !if max overlapped conv cloud
+          maxocc(j, ibox)*(boxpos(j,ibox)) + &   !else
+          (1-maxocc(j,ibox))*( &     !if max overlapped strat cloud
+          (maxosc(j,ibox))*( &       !threshold=boxpos
+          threshold(j,ibox))+ &      !else
+          (1-maxosc(j,ibox))*( &     !threshold_min=random[thrmin,1]
+          threshold_min(j,ibox)+(1-threshold_min(j,ibox))*ran(j)))
+      END DO
+
+    END DO ! ibox
+
+    ! Fill frac_out with 1's where tca is greater than the threshold
+
+    DO ibox = 1, ncol
+      DO j = 1, npoints
+        IF (tca(j,ilev)>threshold(j,ibox)) THEN
+          ! IM REAL             frac_out(j,ibox,ilev)=1
+          frac_out(j, ibox, ilev) = 1.0
+        ELSE
+          ! IM REAL             frac_out(j,ibox,ilev)=0
+          frac_out(j, ibox, ilev) = 0.0
+        END IF
+      END DO
+    END DO
+
+    ! Code to partition boxes into startiform and convective parts
+    ! goes here
+
+    DO ibox = 1, ncol
+      DO j = 1, npoints
+        IF (threshold(j,ibox)<=cca(j,ilev)) THEN
+            ! = 2 IF threshold le cca(j)
+          ! IM REAL                  frac_out(j,ibox,ilev) = 2
+          frac_out(j, ibox, ilev) = 2.0
+        ELSE
+            ! = the same IF NOT threshold le cca(j)
+          frac_out(j, ibox, ilev) = frac_out(j, ibox, ilev)
+        END IF
+      END DO
+    END DO
+
+    ! Set last_frac to tca at this level, so as to be tca
+    ! from last level next time round
+
+    ! IM
+    ! if (ncolprint.ne.0) then
+
+    ! do j=1,npoints ,1000
+    ! write(6,'(a10)') 'j='
+    ! write(6,'(8I10)') j
+    ! write (6,'(a)') 'last_frac:'
+    ! write (6,'(8f5.2)') (tca(j,ilev-1))
+
+    ! write (6,'(a)') 'cca:'
+    ! write (6,'(8f5.2)') (cca(j,ilev),ibox=1,ncolprint)
+
+    ! write (6,'(a)') 'max_overlap_cc:'
+    ! write (6,'(8f5.2)') (maxocc(j,ibox),ibox=1,ncolprint)
+
+    ! write (6,'(a)') 'max_overlap_sc:'
+    ! write (6,'(8f5.2)') (maxosc(j,ibox),ibox=1,ncolprint)
+
+    ! write (6,'(a)') 'threshold_min_nsf2:'
+    ! write (6,'(8f5.2)') (threshold_min(j,ibox),ibox=1,ncolprint)
+
+    ! write (6,'(a)') 'threshold_nsf2:'
+    ! write (6,'(8f5.2)') (threshold(j,ibox),ibox=1,ncolprint)
+
+    ! write (6,'(a)') 'frac_out_pp_rev:'
+    ! write (6,'(8f5.2)')
+    ! &       ((frac_out(j,ibox,ilev2),ibox=1,ncolprint),ilev2=1,nlev)
+    ! enddo
+    ! endif
+
+
+  END DO
+
+  ! ---------------------------------------------------!
+
+
+
+  ! ---------------------------------------------------!
+  ! COMPUTE CLOUD OPTICAL DEPTH FOR EACH COLUMN and
+  ! put into vector tau
+
+    !initialize tau and albedocld to zero
+  ! loop over nlev
+  DO ibox = 1, ncol
+    DO j = 1, npoints
+      tau(j, ibox) = 0.
+      albedocld(j, ibox) = 0.
+      boxtau(j, ibox) = 0.
+      boxptop(j, ibox) = 0.
+      box_cloudy(j, ibox) = .FALSE.
+    END DO
+  END DO
+
+    !compute total cloud optical depth for each column
+  DO ilev = 1, nlev
+      !increment tau for each of the boxes
+    DO ibox = 1, ncol
+      DO j = 1, npoints
+        ! IM REAL              if (frac_out(j,ibox,ilev).eq.1) then
+        IF (frac_out(j,ibox,ilev)==1.0) THEN
+          tau(j, ibox) = tau(j, ibox) + dtau_s(j, ilev)
+        END IF
+        ! IM REAL              if (frac_out(j,ibox,ilev).eq.2) then
+        IF (frac_out(j,ibox,ilev)==2.0) THEN
+          tau(j, ibox) = tau(j, ibox) + dtau_c(j, ilev)
+        END IF
+      END DO
+    END DO ! ibox
+  END DO ! ilev
+  ! IM
+  ! if (ncolprint.ne.0) then
+
+  ! do j=1,npoints ,1000
+  ! write(6,'(a10)') 'j='
+  ! write(6,'(8I10)') j
+  ! write(6,'(i2,1X,8(f7.2,1X))')
+  ! &          ilev,
+  ! &          (tau(j,ibox),ibox=1,ncolprint)
+  ! enddo
+  ! endif
+
+  ! ---------------------------------------------------!
+
+
+
+
+  ! ---------------------------------------------------!
+  ! COMPUTE INFRARED BRIGHTNESS TEMPERUATRES
+  ! AND CLOUD TOP TEMPERATURE SATELLITE SHOULD SEE
+
+  ! again this is only done if top_height = 1 or 3
+
+  ! fluxtop is the 10.5 micron radiance at the top of the
+  ! atmosphere
+  ! trans_layers_above is the total transmissivity in the layers
+  ! above the current layer
+  ! fluxtop_clrsky(j) and trans_layers_above_clrsky(j) are the clear
+  ! sky versions of these quantities.
+
+  IF (top_height==1 .OR. top_height==3) THEN
+
+
+      !----------------------------------------------------------------------
+      !
+      !             DO CLEAR SKY RADIANCE CALCULATION FIRST
+      !
+      !compute water vapor continuum emissivity
+      !this treatment follows Schwarkzopf and Ramasamy
+      !JGR 1999,vol 104, pages 9467-9499.
+      !the emissivity is calculated at a wavenumber of 955 cm-1,
+      !or 10.47 microns
+    wtmair = 28.9644
+    wtmh20 = 18.01534
+    navo = 6.023E+23
+    grav = 9.806650E+02
+    pstd = 1.013250E+06
+    t0 = 296.
+    ! IM
+    ! if (ncolprint .ne. 0)
+    ! &         write(6,*)  'ilev   pw (kg/m2)   tauwv(j)      dem_wv'
+    DO ilev = 1, nlev
+      DO j = 1, npoints
+          !press and dpress are dyne/cm2 = Pascals *10
+        press(j) = pfull(j, ilev)*10.
+        dpress(j) = (phalf(j,ilev+1)-phalf(j,ilev))*10
+          !atmden = g/cm2 = kg/m2 / 10
+        atmden(j) = dpress(j)/grav
+        rvh20(j) = qv(j, ilev)*wtmair/wtmh20
+        wk(j) = rvh20(j)*navo*atmden(j)/wtmair
+        rhoave(j) = (press(j)/pstd)*(t0/at(j,ilev))
+        rh20s(j) = rvh20(j)*rhoave(j)
+        rfrgn(j) = rhoave(j) - rh20s(j)
+        tmpexp(j) = exp(-0.02*(at(j,ilev)-t0))
+        tauwv(j) = wk(j)*1.E-20*((0.0224697*rh20s(j)*tmpexp(j))+(3.41817E-7* &
+          rfrgn(j)))*0.98
+        dem_wv(j, ilev) = 1. - exp(-1.*tauwv(j))
+      END DO
+      ! IM
+      ! if (ncolprint .ne. 0) then
+      ! do j=1,npoints ,1000
+      ! write(6,'(a10)') 'j='
+      ! write(6,'(8I10)') j
+      ! write(6,'(i2,1X,3(f8.3,3X))') ilev,
+      ! &           qv(j,ilev)*(phalf(j,ilev+1)-phalf(j,ilev))/(grav/100.),
+      ! &           tauwv(j),dem_wv(j,ilev)
+      ! enddo
+      ! endif
+    END DO
+
+      !initialize variables
+    DO j = 1, npoints
+      fluxtop_clrsky(j) = 0.
+      trans_layers_above_clrsky(j) = 1.
+    END DO
+
+    DO ilev = 1, nlev
+      DO j = 1, npoints
+
+          ! Black body emission at temperature of the layer
+
+        bb(j) = 1/(exp(1307.27/at(j,ilev))-1.)
+          !bb(j)= 5.67e-8*at(j,ilev)**4
+
+          ! increase TOA flux by flux emitted from layer
+          ! times total transmittance in layers above
+
+        fluxtop_clrsky(j) = fluxtop_clrsky(j) + dem_wv(j, ilev)*bb(j)* &
+          trans_layers_above_clrsky(j)
+
+          ! update trans_layers_above with transmissivity
+          ! from this layer for next time around loop
+
+        trans_layers_above_clrsky(j) = trans_layers_above_clrsky(j)* &
+          (1.-dem_wv(j,ilev))
+
+
+      END DO
+      ! IM
+      ! if (ncolprint.ne.0) then
+      ! do j=1,npoints ,1000
+      ! write(6,'(a10)') 'j='
+      ! write(6,'(8I10)') j
+      ! write (6,'(a)') 'ilev:'
+      ! write (6,'(I2)') ilev
+
+      ! write (6,'(a)')
+      ! &        'emiss_layer,100.*bb(j),100.*f,total_trans:'
+      ! write (6,'(4(f7.2,1X))') dem_wv(j,ilev),100.*bb(j),
+      ! &             100.*fluxtop_clrsky(j),trans_layers_above_clrsky(j)
+      ! enddo
+      ! endif
+
+    END DO !loop over level
+
+    DO j = 1, npoints
+        !add in surface emission
+      bb(j) = 1/(exp(1307.27/skt(j))-1.)
+        !bb(j)=5.67e-8*skt(j)**4
+
+      fluxtop_clrsky(j) = fluxtop_clrsky(j) + emsfc_lw*bb(j)* &
+        trans_layers_above_clrsky(j)
+    END DO
+
+    ! IM
+    ! if (ncolprint.ne.0) then
+    ! do j=1,npoints ,1000
+    ! write(6,'(a10)') 'j='
+    ! write(6,'(8I10)') j
+    ! write (6,'(a)') 'id:'
+    ! write (6,'(a)') 'surface'
+
+    ! write (6,'(a)') 'emsfc,100.*bb(j),100.*f,total_trans:'
+    ! write (6,'(4(f7.2,1X))') emsfc_lw,100.*bb(j),
+    ! &      100.*fluxtop_clrsky(j),
+    ! &       trans_layers_above_clrsky(j)
+    ! enddo
+    ! endif
+
+
+      !
+      !           END OF CLEAR SKY CALCULATION
+      !
+      !----------------------------------------------------------------
+
+
+    ! IM
+    ! if (ncolprint.ne.0) then
+
+    ! do j=1,npoints ,1000
+    ! write(6,'(a10)') 'j='
+    ! write(6,'(8I10)') j
+    ! write (6,'(a)') 'ts:'
+    ! write (6,'(8f7.2)') (skt(j),ibox=1,ncolprint)
+
+    ! write (6,'(a)') 'ta_rev:'
+    ! write (6,'(8f7.2)')
+    ! &       ((at(j,ilev2),ibox=1,ncolprint),ilev2=1,nlev)
+
+    ! enddo
+    ! endif
+      !loop over columns
+    DO ibox = 1, ncol
+      DO j = 1, npoints
+        fluxtop(j, ibox) = 0.
+        trans_layers_above(j, ibox) = 1.
+      END DO
+    END DO
+
+    DO ilev = 1, nlev
+      DO j = 1, npoints
+          ! Black body emission at temperature of the layer
+
+        bb(j) = 1/(exp(1307.27/at(j,ilev))-1.)
+          !bb(j)= 5.67e-8*at(j,ilev)**4
+      END DO
+
+      DO ibox = 1, ncol
+        DO j = 1, npoints
+
+            ! emissivity for point in this layer
+          ! IM REAL             if (frac_out(j,ibox,ilev).eq.1) then
+          IF (frac_out(j,ibox,ilev)==1.0) THEN
+            dem(j, ibox) = 1. - ((1.-dem_wv(j,ilev))*(1.-dem_s(j,ilev)))
+            ! IM REAL             else if (frac_out(j,ibox,ilev).eq.2) then
+          ELSE IF (frac_out(j,ibox,ilev)==2.0) THEN
+            dem(j, ibox) = 1. - ((1.-dem_wv(j,ilev))*(1.-dem_c(j,ilev)))
+          ELSE
+            dem(j, ibox) = dem_wv(j, ilev)
+          END IF
+
+
+            ! increase TOA flux by flux emitted from layer
+            ! times total transmittance in layers above
+
+          fluxtop(j, ibox) = fluxtop(j, ibox) + dem(j, ibox)*bb(j)* &
+            trans_layers_above(j, ibox)
+
+            ! update trans_layers_above with transmissivity
+            ! from this layer for next time around loop
+
+          trans_layers_above(j, ibox) = trans_layers_above(j, ibox)* &
+            (1.-dem(j,ibox))
+
+        END DO ! j
+      END DO ! ibox
+
+      ! IM
+      ! if (ncolprint.ne.0) then
+      ! do j=1,npoints,1000
+      ! write (6,'(a)') 'ilev:'
+      ! write (6,'(I2)') ilev
+
+      ! write(6,'(a10)') 'j='
+      ! write(6,'(8I10)') j
+      ! write (6,'(a)') 'emiss_layer:'
+      ! write (6,'(8f7.2)') (dem(j,ibox),ibox=1,ncolprint)
+
+      ! write (6,'(a)') '100.*bb(j):'
+      ! write (6,'(8f7.2)') (100.*bb(j),ibox=1,ncolprint)
+
+      ! write (6,'(a)') '100.*f:'
+      ! write (6,'(8f7.2)')
+      ! &         (100.*fluxtop(j,ibox),ibox=1,ncolprint)
+
+      ! write (6,'(a)') 'total_trans:'
+      ! write (6,'(8f7.2)')
+      ! &          (trans_layers_above(j,ibox),ibox=1,ncolprint)
+      ! enddo
+      ! endif
+
+    END DO ! ilev
+
+
+    DO j = 1, npoints
+        !add in surface emission
+      bb(j) = 1/(exp(1307.27/skt(j))-1.)
+        !bb(j)=5.67e-8*skt(j)**4
+    END DO
+
+    DO ibox = 1, ncol
+      DO j = 1, npoints
+
+          !add in surface emission
+
+        fluxtop(j, ibox) = fluxtop(j, ibox) + emsfc_lw*bb(j)* &
+          trans_layers_above(j, ibox)
+
+      END DO
+    END DO
+
+    ! IM
+    ! if (ncolprint.ne.0) then
+
+    ! do j=1,npoints ,1000
+    ! write(6,'(a10)') 'j='
+    ! write(6,'(8I10)') j
+    ! write (6,'(a)') 'id:'
+    ! write (6,'(a)') 'surface'
+
+    ! write (6,'(a)') 'emiss_layer:'
+    ! write (6,'(8f7.2)') (dem(1,ibox),ibox=1,ncolprint)
+
+    ! write (6,'(a)') '100.*bb(j):'
+    ! write (6,'(8f7.2)') (100.*bb(j),ibox=1,ncolprint)
+
+    ! write (6,'(a)') '100.*f:'
+    ! write (6,'(8f7.2)') (100.*fluxtop(j,ibox),ibox=1,ncolprint)
+    ! end do
+    ! endif
+
+      !now that you have the top of atmosphere radiance account
+      !for ISCCP procedures to determine cloud top temperature
+
+      !account for partially transmitting cloud recompute flux
+      !ISCCP would see assuming a single layer cloud
+      !note choice here of 2.13, as it is primarily ice
+      !clouds which have partial emissivity and need the
+      !adjustment performed in this section
+      !
+      !If it turns out that the cloud brightness temperature
+      !is greater than 260K, then the liquid cloud conversion
+      !factor of 2.56 is used.
+      !
+      !Note that this is discussed on pages 85-87 of
+      !the ISCCP D level documentation (Rossow et al. 1996)
+
+    DO j = 1, npoints
+        !compute minimum brightness temperature and optical depth
+      btcmin(j) = 1./(exp(1307.27/(attrop(j)-5.))-1.)
+    END DO
+    DO ibox = 1, ncol
+      DO j = 1, npoints
+        transmax(j) = (fluxtop(j,ibox)-btcmin(j))/(fluxtop_clrsky(j)-btcmin(j &
+          ))
+          !note that the initial setting of tauir(j) is needed so that
+          !tauir(j) has a realistic value should the next if block be
+          !bypassed
+        tauir(j) = tau(j, ibox)*rec2p13
+        taumin(j) = -1.*log(max(min(transmax(j),0.9999999),0.001))
+
+      END DO
+
+      IF (top_height==1) THEN
+        DO j = 1, npoints
+          IF (transmax(j)>0.001 .AND. transmax(j)<=0.9999999) THEN
+            fluxtopinit(j) = fluxtop(j, ibox)
+            tauir(j) = tau(j, ibox)*rec2p13
+          END IF
+        END DO
+        DO icycle = 1, 2
+          DO j = 1, npoints
+            IF (tau(j,ibox)>(tauchk)) THEN
+              IF (transmax(j)>0.001 .AND. transmax(j)<=0.9999999) THEN
+                emcld(j, ibox) = 1. - exp(-1.*tauir(j))
+                fluxtop(j, ibox) = fluxtopinit(j) - ((1.-emcld(j, &
+                  ibox))*fluxtop_clrsky(j))
+                fluxtop(j, ibox) = max(1.E-06, (fluxtop(j,ibox)/emcld(j, &
+                  ibox)))
+                tb(j, ibox) = 1307.27/(log(1.+(1./fluxtop(j,ibox))))
+                IF (tb(j,ibox)>260.) THEN
+                  tauir(j) = tau(j, ibox)/2.56
+                END IF
+              END IF
+            END IF
+          END DO
+        END DO
+
+      END IF
+
+      DO j = 1, npoints
+        IF (tau(j,ibox)>(tauchk)) THEN
+            !cloudy box
+          tb(j, ibox) = 1307.27/(log(1.+(1./fluxtop(j,ibox))))
+          IF (top_height==1 .AND. tauir(j)<taumin(j)) THEN
+            tb(j, ibox) = attrop(j) - 5.
+            tau(j, ibox) = 2.13*taumin(j)
+          END IF
+        ELSE
+            !clear sky brightness temperature
+          tb(j, ibox) = 1307.27/(log(1.+(1./fluxtop_clrsky(j))))
+        END IF
+      END DO ! j
+    END DO ! ibox
+
+    ! IM
+    ! if (ncolprint.ne.0) then
+
+    ! do j=1,npoints,1000
+    ! write(6,'(a10)') 'j='
+    ! write(6,'(8I10)') j
+
+    ! write (6,'(a)') 'attrop:'
+    ! write (6,'(8f7.2)') (attrop(j))
+
+    ! write (6,'(a)') 'btcmin:'
+    ! write (6,'(8f7.2)') (btcmin(j))
+
+    ! write (6,'(a)') 'fluxtop_clrsky*100:'
+    ! write (6,'(8f7.2)')
+    ! &      (100.*fluxtop_clrsky(j))
+
+    ! write (6,'(a)') '100.*f_adj:'
+    ! write (6,'(8f7.2)') (100.*fluxtop(j,ibox),ibox=1,ncolprint)
+
+    ! write (6,'(a)') 'transmax:'
+    ! write (6,'(8f7.2)') (transmax(ibox),ibox=1,ncolprint)
+
+    ! write (6,'(a)') 'tau:'
+    ! write (6,'(8f7.2)') (tau(j,ibox),ibox=1,ncolprint)
+
+    ! write (6,'(a)') 'emcld:'
+    ! write (6,'(8f7.2)') (emcld(j,ibox),ibox=1,ncolprint)
+
+    ! write (6,'(a)') 'total_trans:'
+    ! write (6,'(8f7.2)')
+    ! &          (trans_layers_above(j,ibox),ibox=1,ncolprint)
+
+    ! write (6,'(a)') 'total_emiss:'
+    ! write (6,'(8f7.2)')
+    ! &          (1.0-trans_layers_above(j,ibox),ibox=1,ncolprint)
+
+    ! write (6,'(a)') 'total_trans:'
+    ! write (6,'(8f7.2)')
+    ! &          (trans_layers_above(j,ibox),ibox=1,ncolprint)
+
+    ! write (6,'(a)') 'ppout:'
+    ! write (6,'(8f7.2)') (tb(j,ibox),ibox=1,ncolprint)
+    ! enddo ! j
+    ! endif
+
+  END IF
+
+  ! ---------------------------------------------------!
+
+
+  ! ---------------------------------------------------!
+  ! DETERMINE CLOUD TOP PRESSURE
+
+  ! again the 2 methods differ according to whether
+  ! or not you use the physical cloud top pressure (top_height = 2)
+  ! or the radiatively determined cloud top pressure (top_height = 1 or 3)
+
+
+    !compute cloud top pressure
+  DO ibox = 1, ncol
+      !segregate according to optical thickness
+    IF (top_height==1 .OR. top_height==3) THEN
+        !find level whose temperature
+        !most closely matches brightness temperature
+      DO j = 1, npoints
+        nmatch(j) = 0
+      END DO
+      DO ilev = 1, nlev - 1
+        ! cdir nodep
+        DO j = 1, npoints
+          IF ((at(j,ilev)>=tb(j,ibox) .AND. at(j,ilev+1)<tb(j, &
+              ibox)) .OR. (at(j,ilev)<=tb(j,ibox) .AND. at(j,ilev+1)>tb(j, &
+              ibox))) THEN
+
+            nmatch(j) = nmatch(j) + 1
+            IF (abs(at(j,ilev)-tb(j,ibox))<abs(at(j,ilev+1)-tb(j,ibox))) THEN
+              match(j, nmatch(j)) = ilev
+            ELSE
+              match(j, nmatch(j)) = ilev + 1
+            END IF
+          END IF
+        END DO
+      END DO
+
+      DO j = 1, npoints
+        IF (nmatch(j)>=1) THEN
+          ptop(j, ibox) = pfull(j, match(j,nmatch(j)))
+          levmatch(j, ibox) = match(j, nmatch(j))
+        ELSE
+          IF (tb(j,ibox)<atmin(j)) THEN
+            ptop(j, ibox) = ptrop(j)
+            levmatch(j, ibox) = itrop(j)
+          END IF
+          IF (tb(j,ibox)>atmax(j)) THEN
+            ptop(j, ibox) = pfull(j, nlev)
+            levmatch(j, ibox) = nlev
+          END IF
+        END IF
+      END DO ! j
+
+    ELSE ! if (top_height .eq. 1 .or. top_height .eq. 3)
+
+      DO j = 1, npoints
+        ptop(j, ibox) = 0.
+      END DO
+      DO ilev = 1, nlev
+        DO j = 1, npoints
+          IF ((ptop(j,ibox)==0.) & ! IM  &
+                                   ! .and.(frac_out(j,ibox,ilev) .ne. 0))
+                                   ! then
+              .AND. (frac_out(j,ibox,ilev)/=0.0)) THEN
+            ptop(j, ibox) = pfull(j, ilev)
+            levmatch(j, ibox) = ilev
+          END IF
+        END DO
+      END DO
+    END IF
+
+    DO j = 1, npoints
+      IF (tau(j,ibox)<=(tauchk)) THEN
+        ptop(j, ibox) = 0.
+        levmatch(j, ibox) = 0
+      END IF
+    END DO
+
+  END DO
+
+
+
+  ! ---------------------------------------------------!
+
+
+
+  ! ---------------------------------------------------!
+  ! DETERMINE ISCCP CLOUD TYPE FREQUENCIES
+
+  ! Now that ptop and tau have been determined,
+  ! determine amount of each of the 49 ISCCP cloud
+  ! types
+
+  ! Also compute grid box mean cloud top pressure and
+  ! optical thickness.  The mean cloud top pressure and
+  ! optical thickness are averages over the cloudy
+  ! area only. The mean cloud top pressure is a linear
+  ! average of the cloud top pressures.  The mean cloud
+  ! optical thickness is computed by converting optical
+  ! thickness to an albedo, averaging in albedo units,
+  ! then converting the average albedo back to a mean
+  ! optical thickness.
+
+
+    !compute isccp frequencies
+
+    !reset frequencies
+  DO ilev = 1, 7
+    DO ilev2 = 1, 7
+      DO j = 1, npoints !
+        fq_isccp(j, ilev, ilev2) = 0.
+      END DO
+    END DO
+  END DO
+
+    !reset variables need for averaging cloud properties
+  DO j = 1, npoints
+    totalcldarea(j) = 0.
+    meanalbedocld(j) = 0.
+    meanptop(j) = 0.
+    meantaucld(j) = 0.
+  END DO ! j
+
+  boxarea = 1./real(ncol)
+
+    !determine optical depth category
+  ! IM       do 39 j=1,npoints
+  ! IM       do ibox=1,ncol
+  DO ibox = 1, ncol
+    DO j = 1, npoints
+
+      ! IM
+      ! CALL CPU_time(t1)
+      ! IM
+
+      IF (tau(j,ibox)>(tauchk) .AND. ptop(j,ibox)>0.) THEN
+        box_cloudy(j, ibox) = .TRUE.
+      END IF
+
+      ! IM
+      ! CALL CPU_time(t2)
+      ! print*,'IF tau t2 - t1',t2 - t1
+
+      ! CALL CPU_time(t1)
+      ! IM
+
+      IF (box_cloudy(j,ibox)) THEN
+
+          ! totalcldarea always diagnosed day or night
+        totalcldarea(j) = totalcldarea(j) + boxarea
+
+        IF (sunlit(j)==1) THEN
+
+            ! tau diagnostics only with sunlight
+
+          boxtau(j, ibox) = tau(j, ibox)
+
+            !convert optical thickness to albedo
+          albedocld(j, ibox) = real(invtau(min(nint(100.*tau(j,ibox)), &
+            45000)))
+
+            !contribute to averaging
+          meanalbedocld(j) = meanalbedocld(j) + albedocld(j, ibox)*boxarea
+
+        END IF
+
+      END IF
+
+      ! IM
+      ! CALL CPU_time(t2)
+      ! print*,'IF box_cloudy t2 - t1',t2 - t1
+
+      ! CALL CPU_time(t1)
+      ! IM BEG
+      ! IM           !convert ptop to millibars
+      ptop(j, ibox) = ptop(j, ibox)/100.
+
+      ! IM           !save for output cloud top pressure and optical
+      ! thickness
+      boxptop(j, ibox) = ptop(j, ibox)
+      ! IM END
+
+      ! IM BEG
+        !reset itau(j), ipres(j)
+      itau(j) = 0
+      ipres(j) = 0
+
+      IF (tau(j,ibox)<isccp_taumin) THEN
+        itau(j) = 1
+      ELSE IF (tau(j,ibox)>=isccp_taumin .AND. tau(j,ibox)<1.3) THEN
+        itau(j) = 2
+      ELSE IF (tau(j,ibox)>=1.3 .AND. tau(j,ibox)<3.6) THEN
+        itau(j) = 3
+      ELSE IF (tau(j,ibox)>=3.6 .AND. tau(j,ibox)<9.4) THEN
+        itau(j) = 4
+      ELSE IF (tau(j,ibox)>=9.4 .AND. tau(j,ibox)<23.) THEN
+        itau(j) = 5
+      ELSE IF (tau(j,ibox)>=23. .AND. tau(j,ibox)<60.) THEN
+        itau(j) = 6
+      ELSE IF (tau(j,ibox)>=60.) THEN
+        itau(j) = 7
+      END IF
+
+        !determine cloud top pressure category
+      IF (ptop(j,ibox)>0. .AND. ptop(j,ibox)<180.) THEN
+        ipres(j) = 1
+      ELSE IF (ptop(j,ibox)>=180. .AND. ptop(j,ibox)<310.) THEN
+        ipres(j) = 2
+      ELSE IF (ptop(j,ibox)>=310. .AND. ptop(j,ibox)<440.) THEN
+        ipres(j) = 3
+      ELSE IF (ptop(j,ibox)>=440. .AND. ptop(j,ibox)<560.) THEN
+        ipres(j) = 4
+      ELSE IF (ptop(j,ibox)>=560. .AND. ptop(j,ibox)<680.) THEN
+        ipres(j) = 5
+      ELSE IF (ptop(j,ibox)>=680. .AND. ptop(j,ibox)<800.) THEN
+        ipres(j) = 6
+      ELSE IF (ptop(j,ibox)>=800.) THEN
+        ipres(j) = 7
+      END IF
+      ! IM END
+
+      IF (sunlit(j)==1 .OR. top_height==3) THEN
+
+        ! IM         !convert ptop to millibars
+        ! IM           ptop(j,ibox)=ptop(j,ibox) / 100.
+
+        ! IM         !save for output cloud top pressure and optical
+        ! thickness
+        ! IM             boxptop(j,ibox) = ptop(j,ibox)
+
+        IF (box_cloudy(j,ibox)) THEN
+
+          meanptop(j) = meanptop(j) + ptop(j, ibox)*boxarea
+
+          ! IM             !reset itau(j), ipres(j)
+          ! IM           itau(j) = 0
+          ! IM           ipres(j) = 0
+
+          ! if (tau(j,ibox) .lt. isccp_taumin) then
+          ! itau(j)=1
+          ! else if (tau(j,ibox) .ge. isccp_taumin
+          ! &
+          ! &          .and. tau(j,ibox) .lt. 1.3) then
+          ! itau(j)=2
+          ! else if (tau(j,ibox) .ge. 1.3
+          ! &          .and. tau(j,ibox) .lt. 3.6) then
+          ! itau(j)=3
+          ! else if (tau(j,ibox) .ge. 3.6
+          ! &          .and. tau(j,ibox) .lt. 9.4) then
+          ! itau(j)=4
+          ! else if (tau(j,ibox) .ge. 9.4
+          ! &          .and. tau(j,ibox) .lt. 23.) then
+          ! itau(j)=5
+          ! else if (tau(j,ibox) .ge. 23.
+          ! &          .and. tau(j,ibox) .lt. 60.) then
+          ! itau(j)=6
+          ! else if (tau(j,ibox) .ge. 60.) then
+          ! itau(j)=7
+          ! end if
+
+          ! !determine cloud top pressure category
+          ! if (    ptop(j,ibox) .gt. 0.
+          ! &          .and.ptop(j,ibox) .lt. 180.) then
+          ! ipres(j)=1
+          ! else if(ptop(j,ibox) .ge. 180.
+          ! &          .and.ptop(j,ibox) .lt. 310.) then
+          ! ipres(j)=2
+          ! else if(ptop(j,ibox) .ge. 310.
+          ! &          .and.ptop(j,ibox) .lt. 440.) then
+          ! ipres(j)=3
+          ! else if(ptop(j,ibox) .ge. 440.
+          ! &          .and.ptop(j,ibox) .lt. 560.) then
+          ! ipres(j)=4
+          ! else if(ptop(j,ibox) .ge. 560.
+          ! &          .and.ptop(j,ibox) .lt. 680.) then
+          ! ipres(j)=5
+          ! else if(ptop(j,ibox) .ge. 680.
+          ! &          .and.ptop(j,ibox) .lt. 800.) then
+          ! ipres(j)=6
+          ! else if(ptop(j,ibox) .ge. 800.) then
+          ! ipres(j)=7
+          ! end if
+
+            !update frequencies
+          IF (ipres(j)>0 .AND. itau(j)>0) THEN
+            fq_isccp(j, itau(j), ipres(j)) = fq_isccp(j, itau(j), ipres(j)) + &
+              boxarea
+          END IF
+
+          ! IM calcul stats regime dynamique BEG
+          ! iw(j) = int((w(j)-wmin)/pas_w) +1
+          ! pctj(itau(j),ipres(j),iw(j))=.FALSE.
+          ! !update frequencies W500
+          ! if (pct_ocean(j)) then
+          ! if (ipres(j) .gt. 0.and.itau(j) .gt. 0) then
+          ! if (iw(j) .gt. int(wmin).and.iw(j) .le. iwmx) then
+          ! print*,' ISCCP iw=',iw(j),j
+          ! fq_dynreg(itau(j),ipres(j),iw(j))=
+          ! &          fq_dynreg(itau(j),ipres(j),iw(j))+
+          ! &          boxarea
+          ! &          fq_isccp(j,itau(j),ipres(j))
+          ! pctj(itau(j),ipres(j),iw(j))=.TRUE.
+          ! nfq_dynreg(itau(j),ipres(j),iw(j))=
+          ! &          nfq_dynreg(itau(j),ipres(j),iw(j))+1.
+          ! end if
+          ! end if
+          ! end if
+          ! IM calcul stats regime dynamique END
+        END IF !IM boxcloudy
+
+      END IF !IM sunlit
+
+      ! IM
+      ! CALL CPU_time(t2)
+      ! print*,'IF sunlit boxcloudy t2 - t1',t2 - t1
+      ! IM
+    END DO !IM ibox/j
+
+
+    ! IM ajout stats s/ W500 BEG
+    ! IM ajout stats s/ W500 END
+
+    ! if(j.EQ.6722) then
+    ! print*,' ISCCP',w(j),iw(j),ipres(j),itau(j)
+    ! endif
+
+    ! if (pct_ocean(j)) then
+    ! if (ipres(j) .gt. 0.and.itau(j) .gt. 0) then
+    ! if (iw(j) .gt. int(wmin).and.iw(j) .le. iwmx) then
+    ! if(pctj(itau(j),ipres(j),iw(j))) THEN
+    ! nfq_dynreg(itau(j),ipres(j),iw(j))=
+    ! &    nfq_dynreg(itau(j),ipres(j),iw(j))+1.
+    ! if(itau(j).EQ.4.AND.ipres(j).EQ.2.AND.
+    ! &    iw(j).EQ.10) then
+    ! PRINT*,' isccp AVANT',
+    ! &    nfq_dynreg(itau(j),ipres(j),iw(j)),
+    ! &    fq_dynreg(itau(j),ipres(j),iw(j))
+    ! endif
+    ! endif
+    ! endif
+    ! endif
+    ! endif
+
+  END DO
+    !compute mean cloud properties
+  ! IM j/ibox
+  DO j = 1, npoints
+    IF (totalcldarea(j)>0.) THEN
+      meanptop(j) = meanptop(j)/totalcldarea(j)
+      IF (sunlit(j)==1) THEN
+        meanalbedocld(j) = meanalbedocld(j)/totalcldarea(j)
+        meantaucld(j) = tautab(min(255,max(1,nint(meanalbedocld(j)))))
+      END IF
+    END IF
+  END DO ! j
+
+  ! IM ajout stats s/ W500 BEG
+  ! do nw = 1, iwmx
+  ! do l = 1, 7
+  ! do k = 1, 7
+  ! if (nfq_dynreg(k,l,nw).GT.0.) then
+  ! fq_dynreg(k,l,nw) = fq_dynreg(k,l,nw)/nfq_dynreg(k,l,nw)
+  ! if(k.EQ.4.AND.l.EQ.2.AND.nw.EQ.10) then
+  ! print*,' isccp APRES',nfq_dynreg(k,l,nw),
+  ! &   fq_dynreg(k,l,nw)
+  ! endif
+  ! else
+  ! if(fq_dynreg(k,l,nw).NE.0.) then
+  ! print*,'nfq_dynreg = 0 tau,pc,nw',k,l,nw,fq_dynreg(k,l,nw)
+  ! endif
+  ! fq_dynreg(k,l,nw) = -1.E+20
+  ! nfq_dynreg(k,l,nw) = 1.E+20
+  ! end if
+  ! enddo !k
+  ! enddo !l
+  ! enddo !nw
+  ! IM ajout stats s/ W500 END
+  ! ---------------------------------------------------!
+
+  ! ---------------------------------------------------!
+  ! OPTIONAL PRINTOUT OF DATA TO CHECK PROGRAM
+
+  ! cIM
+  ! if (debugcol.ne.0) then
+
+  ! do j=1,npoints,debugcol
+
+  ! !produce character output
+  ! do ilev=1,nlev
+  ! do ibox=1,ncol
+  ! acc(ilev,ibox)=0
+  ! enddo
+  ! enddo
+
+  ! do ilev=1,nlev
+  ! do ibox=1,ncol
+  ! acc(ilev,ibox)=frac_out(j,ibox,ilev)*2
+  ! if (levmatch(j,ibox) .eq. ilev)
+  ! &                 acc(ilev,ibox)=acc(ilev,ibox)+1
+  ! enddo
+  ! enddo
+
+    !print test
+
+  ! write(ftn09,11) j
+  ! 11        format('ftn09.',i4.4)
+  ! open(9, FILE=ftn09, FORM='FORMATTED')
+
+  ! write(9,'(a1)') ' '
+  ! write(9,'(10i5)')
+  ! &                  (ilev,ilev=5,nlev,5)
+  ! write(9,'(a1)') ' '
+
+  ! do ibox=1,ncol
+  ! write(9,'(40(a1),1x,40(a1))')
+  ! &           (cchar_realtops(acc(ilev,ibox)+1),ilev=1,nlev)
+  ! &           ,(cchar(acc(ilev,ibox)+1),ilev=1,nlev)
+  ! end do
+  ! close(9)
+
+  ! IM
+  ! if (ncolprint.ne.0) then
+  ! write(6,'(a1)') ' '
+  ! write(6,'(a2,1X,5(a7,1X),a50)')
+  ! &                  'ilev',
+  ! &                  'pfull','at',
+  ! &                  'cc*100','dem_s','dtau_s',
+  ! &                  'cchar'
+
+  ! do 4012 ilev=1,nlev
+  ! write(6,'(60i2)') (box(i,ilev),i=1,ncolprint)
+  ! write(6,'(i2,1X,5(f7.2,1X),50(a1))')
+  ! &                  ilev,
+  ! &                  pfull(j,ilev)/100.,at(j,ilev),
+  ! &                  cc(j,ilev)*100.0,dem_s(j,ilev),dtau_s(j,ilev)
+  ! &                  ,(cchar(acc(ilev,ibox)+1),ibox=1,ncolprint)
+  ! 4012           continue
+  ! write (6,'(a)') 'skt(j):'
+  ! write (6,'(8f7.2)') skt(j)
+
+  ! write (6,'(8I7)') (ibox,ibox=1,ncolprint)
+
+  ! write (6,'(a)') 'tau:'
+  ! write (6,'(8f7.2)') (tau(j,ibox),ibox=1,ncolprint)
+
+  ! write (6,'(a)') 'tb:'
+  ! write (6,'(8f7.2)') (tb(j,ibox),ibox=1,ncolprint)
+
+  ! write (6,'(a)') 'ptop:'
+  ! write (6,'(8f7.2)') (ptop(j,ibox),ibox=1,ncolprint)
+  ! endif
+
+  ! enddo
+
+  ! end if
+
+  RETURN
+END SUBROUTINE isccp_cloud_types
Index: DZ6/trunk/libf/phylmd/limit_read_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/limit_read_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,455 +1,0 @@
-!
-! $Id$
-!
-MODULE limit_read_mod
-!
-! This module reads the fichier "limit.nc" containing fields for surface forcing.
-!
-! Module subroutines :
-!  limit_read_frac    : call limit_read_tot and return the fractions
-!  limit_read_rug_alb : return rugosity and albedo, if coupled ocean call limit_read_tot first
-!  limit_read_sst     : return sea ice temperature   
-!  limit_read_tot     : read limit.nc and store the fields in local modules variables
-!
-  IMPLICIT NONE
-
-  REAL, ALLOCATABLE, DIMENSION(:,:), SAVE, PRIVATE :: pctsrf
-!$OMP THREADPRIVATE(pctsrf)
-  REAL, ALLOCATABLE, DIMENSION(:),   SAVE, PRIVATE :: rugos
-!$OMP THREADPRIVATE(rugos)
-  REAL, ALLOCATABLE, DIMENSION(:),   SAVE, PRIVATE :: albedo
-!$OMP THREADPRIVATE(albedo)  
-  REAL, ALLOCATABLE, DIMENSION(:),   SAVE, PRIVATE :: sst
-!$OMP THREADPRIVATE(sst)  
-  LOGICAL,SAVE :: read_continents=.FALSE.
-!$OMP THREADPRIVATE(read_continents) 
-
-CONTAINS
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!!
-!! Public subroutines :
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-
-  SUBROUTINE init_limit_read(first_day)
-  USE mod_grid_phy_lmdz
-  USE surface_data
-  USE mod_phys_lmdz_para
-  USE lmdz_xios
-
-  IMPLICIT NONE
-    INTEGER, INTENT(IN) :: first_day
-    
-    
-    IF ( type_ocean /= 'couple') THEN
-      IF (grid_type==unstructured) THEN
-        IF (is_omp_master) CALL xios_set_file_attr("limit_read",enabled=.TRUE.,record_offset=first_day)
-      ENDIF  
-    ENDIF
-
-  END SUBROUTINE init_limit_read
-  
-  SUBROUTINE limit_read_frac(itime, dtime, jour, pctsrf_new, is_modified)
-!
-! This subroutine is called from "change_srf_frac" for case of 
-! ocean=force or from ocean_slab_frac for ocean=slab.
-! The fraction for all sub-surfaces at actual time step is returned.
-
-    USE dimphy
-    USE indice_sol_mod
-
-! Input arguments
-!****************************************************************************************
-    INTEGER, INTENT(IN) :: itime   ! time step
-    INTEGER, INTENT(IN) :: jour    ! current day
-    REAL   , INTENT(IN) :: dtime   ! length of time step
-  
-! Output arguments
-!****************************************************************************************
-    REAL, DIMENSION(klon,nbsrf), INTENT(OUT) :: pctsrf_new  ! sub surface fractions
-    LOGICAL, INTENT(OUT)                     :: is_modified ! true if pctsrf is modified at this time step
-
-! End declaration
-!****************************************************************************************
-
-! 1) Read file limit.nc
-    CALL limit_read_tot(itime, dtime, jour, is_modified)
-
-! 2) Return the fraction read in limit_read_tot
-    pctsrf_new(:,:) = pctsrf(:,:)
-    
-  END SUBROUTINE limit_read_frac
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-  SUBROUTINE limit_read_rug_alb(itime, dtime, jour, &
-       knon, knindex, &
-       rugos_out, alb_out)
-!
-! This subroutine is called from surf_land_bucket. 
-! The flag "ok_veget" must can not be true. If coupled run, "ocean=couple"
-! then this routine will call limit_read_tot.
-!
-    USE dimphy
-    USE surface_data
-
-! Input arguments
-!****************************************************************************************
-    INTEGER, INTENT(IN) :: itime                     ! numero du pas de temps courant
-    INTEGER, INTENT(IN) :: jour                      ! jour a lire dans l'annee
-    REAL   , INTENT(IN) :: dtime                     ! pas de temps de la physique (en s)
-    INTEGER, INTENT(IN) :: knon                      ! nomber of points on compressed grid
-    INTEGER, DIMENSION(klon), INTENT(IN) :: knindex  ! grid point number for compressed grid
-! Output arguments
-!****************************************************************************************
-    REAL, DIMENSION(klon), INTENT(OUT) :: rugos_out
-    REAL, DIMENSION(klon), INTENT(OUT) :: alb_out
-    
-! Local variables
-!****************************************************************************************
-    INTEGER :: i
-    LOGICAL :: is_modified
-!****************************************************************************************
-
-IF (type_ocean == 'couple'.OR. &
-         (type_ocean == 'slab' .AND. version_ocean == 'sicINT')) THEN
-       ! limit.nc has not yet been read. Do it now!
-       CALL limit_read_tot(itime, dtime, jour, is_modified)
-    END IF
-
-    DO i=1,knon
-       rugos_out(i) = rugos(knindex(i))
-       alb_out(i)  = albedo(knindex(i))
-    END DO
-
-  END SUBROUTINE limit_read_rug_alb
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-  SUBROUTINE limit_read_sst(knon, knindex, sst_out)
-!
-! This subroutine returns the sea surface temperature already read from limit.nc.
-!
-    USE dimphy, ONLY : klon
-
-    INTEGER, INTENT(IN)                  :: knon     ! nomber of points on compressed grid
-    INTEGER, DIMENSION(klon), INTENT(IN) :: knindex  ! grid point number for compressed grid
-    REAL, DIMENSION(klon), INTENT(OUT)   :: sst_out
-
-    INTEGER :: i
-
-    DO i = 1, knon
-       sst_out(i) = sst(knindex(i))
-    END DO
-
-  END SUBROUTINE limit_read_sst
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!!
-!! Private subroutine :
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-  SUBROUTINE limit_read_tot(itime, dtime, jour, is_modified)
-!
-! Read everything needed from limit.nc
-!
-! 0) Initialize
-! 1) Open the file limit.nc, if it is time
-! 2) Read fraction, if not type_ocean=couple
-! 3) Read sea surface temperature, if not type_ocean=couple
-! 4) Read albedo and rugosity for land surface, only in case of no vegetation model
-! 5) Close file and distribuate variables to all processus
-
-    USE dimphy
-    USE mod_grid_phy_lmdz
-    USE mod_phys_lmdz_para
-    USE surface_data, ONLY : type_ocean, ok_veget
-    USE netcdf
-    USE indice_sol_mod
-    USE phys_cal_mod, ONLY : calend, year_len
-    USE print_control_mod, ONLY: lunout, prt_level
-    USE lmdz_xios, ONLY: xios_recv_field, using_xios
-    
-    IMPLICIT NONE
-    
-! In- and ouput arguments
-!****************************************************************************************
-    INTEGER, INTENT(IN) :: itime   ! numero du pas de temps courant
-    INTEGER, INTENT(IN) :: jour    ! jour a lire dans l'annee
-    REAL   , INTENT(IN) :: dtime   ! pas de temps de la physique (en s)
-
-    LOGICAL, INTENT(OUT) :: is_modified  ! true if pctsrf is modified at this time step
-
-! Locals variables with attribute SAVE
-!****************************************************************************************
-! frequence de lecture des conditions limites (en pas de physique) 
-    INTEGER,SAVE                              :: lmt_pas
-!$OMP THREADPRIVATE(lmt_pas) 
-    LOGICAL, SAVE                             :: first_call=.TRUE.
-!$OMP THREADPRIVATE(first_call)  
-    INTEGER, SAVE                             :: jour_lu = -1
-!$OMP THREADPRIVATE(jour_lu)  
-! Locals variables
-!****************************************************************************************
-    INTEGER                                   :: nid, nvarid, ndimid, nn
-    INTEGER                                   :: ii, ierr
-    INTEGER, DIMENSION(2)                     :: start, epais
-    REAL, DIMENSION(klon_glo,nbsrf)           :: pct_glo  ! fraction at global grid
-    REAL, DIMENSION(klon_glo)                 :: sst_glo  ! sea-surface temperature at global grid
-    REAL, DIMENSION(klon_glo)                 :: rug_glo  ! rugosity at global grid
-    REAL, DIMENSION(klon_glo)                 :: alb_glo  ! albedo at global grid
-
-    REAL, DIMENSION(klon_mpi,nbsrf)           :: pct_mpi  ! fraction at global grid
-    REAL, DIMENSION(klon_mpi)                 :: sst_mpi  ! sea-surface temperature at global grid
-    REAL, DIMENSION(klon_mpi)                 :: rug_mpi  ! rugosity at global grid
-    REAL, DIMENSION(klon_mpi)                 :: alb_mpi  ! albedo at global grid
-
-    CHARACTER(len=20)                         :: modname='limit_read_mod'     
-    CHARACTER(LEN=99)                         :: abort_message, calendar, str
-
-! End declaration
-!****************************************************************************************
-
-!****************************************************************************************
-! 0) Initialization
-!
-!****************************************************************************************
-    IF (first_call) THEN
-       first_call=.FALSE.
-       ! calculate number of time steps for one day
-       lmt_pas = NINT(86400./dtime * 1.0)
-       
-       ! Allocate module save variables
-       IF ( type_ocean /= 'couple' ) THEN
-          ALLOCATE(pctsrf(klon,nbsrf), sst(klon), stat=ierr)
-          IF (ierr /= 0) CALL abort_physic(modname, 'PB in allocating pctsrf and sst',1)
-       END IF
-
-       IF ( .NOT. ok_veget ) THEN
-          ALLOCATE(rugos(klon), albedo(klon), stat=ierr)
-          IF (ierr /= 0) CALL abort_physic(modname, 'PB in allocating rugos and albedo',1)
-       END IF
-
-!$OMP MASTER  ! Only master thread
-       IF (is_mpi_root) THEN ! Only master processus
-          ierr = NF90_OPEN ('limit.nc', NF90_NOWRITE, nid)
-          IF (ierr /= NF90_NOERR) CALL abort_physic(modname,&
-               'Pb d''ouverture du fichier de conditions aux limites',1)
-
-          !--- WARNING IF CALENDAR IS KNOWN AND DOES NOT MATCH THE ONE OF LMDZ
-          ierr=NF90_INQ_VARID(nid, 'TEMPS', nvarid)
-          ierr=NF90_GET_ATT(nid, nvarid, 'calendar', calendar)
-          IF(ierr==NF90_NOERR.AND.calendar/=calend.AND.prt_level>=1) THEN
-             WRITE(lunout,*)'BEWARE: gcm and limit.nc calendars differ: '
-             WRITE(lunout,*)'  '//TRIM(calend)//' for gcm'
-             WRITE(lunout,*)'  '//TRIM(calendar)//' for limit.nc file'
-          END IF
-
-          !--- ERROR IF FILE RECORDS NUMBER IS NOT EQUAL TO EXPECTED NUMBER OF DAYS          
-          IF (grid_type==unstructured) THEN
-            ierr=NF90_INQ_DIMID(nid,"time_year",ndimid)
-          ELSE
-            ierr=NF90_INQUIRE(nid, UnlimitedDimID=ndimid)
-          ENDIF
-          ierr=NF90_INQUIRE_DIMENSION(nid, ndimid, len=nn)
-          WRITE(abort_message,'(a,2(i0,a))')'limit.nc records number (',nn,') does no'//&
-            't match year length (',year_len,')'
-          IF(nn/=year_len) CALL abort_physic(modname,abort_message,1)
-
-          !--- ERROR IF FILES AND LMDZ HORIZONTAL RESOLUTIONS DO NOT MATCH
-          IF (grid_type==unstructured) THEN
-            ierr=NF90_INQ_DIMID(nid, 'cell', ndimid)
-          ELSE
-            ierr=NF90_INQ_DIMID(nid, 'points_physiques', ndimid)
-          ENDIF
-          ierr=NF90_INQUIRE_DIMENSION(nid, ndimid, len=nn)
-          WRITE(abort_message,'(a,2(i0,a))')'limit.nc horizontal number of cells (',nn, &
-            ') does not match LMDZ klon_glo (',klon_glo,')'
-          IF(nn/=klon_glo) CALL abort_physic(modname,abort_message,1)
-
-          ierr = NF90_CLOSE(nid)
-          IF (ierr /= NF90_NOERR) CALL abort_physic(modname,'Pb when closing file', 1)
-       END IF ! is_mpi_root
-!$OMP END MASTER
-!$OMP BARRIER
-    END IF
-
-!****************************************************************************************
-! 1) Open the file limit.nc if it is the right moment to read, once a day.
-!    The file is read only by the master thread of the master mpi process(is_mpi_root)
-!    Check by the way if the number of records is correct.
-!
-!****************************************************************************************
-
-    is_modified = .FALSE.
-!ym    IF (MOD(itime-1, lmt_pas) == 0 .OR. jour_lu /= jour ) THEN   ! time to read
-!  not REALLY PERIODIC
-    IF (MOD(itime-1, lmt_pas) == 0 .OR. (jour_lu /= jour .AND. grid_type /= unstructured)) THEN   ! time to read
-!    IF (MOD(itime-1, lmt_pas) == 0) THEN   ! time to read
-       jour_lu = jour
-       is_modified = .TRUE.
-
-      IF (grid_type==unstructured) THEN
-
-        IF ( type_ocean /= 'couple') THEN
-
-           IF (is_omp_master) CALL xios_recv_field("foce_limin",pct_mpi(:,is_oce))
-           IF (is_omp_master) CALL xios_recv_field("fsic_limin",pct_mpi(:,is_sic))
-  !         IF (read_continents .OR. itime == 1) THEN
-           IF (is_omp_master) CALL xios_recv_field("fter_limin",pct_mpi(:,is_ter))
-           IF (is_omp_master) CALL xios_recv_field("flic_limin",pct_mpi(:,is_lic))
-  !         ENDIF
-         ENDIF! type_ocean /= couple
-         
-         IF ( type_ocean /= 'couple') THEN                    
-             IF (is_omp_master) CALL xios_recv_field("sst_limin",sst_mpi)
-         ENDIF
-       
-         IF (.NOT. ok_veget) THEN
-           IF (is_omp_master) CALL xios_recv_field("alb_limin",alb_mpi)
-           IF (is_omp_master) CALL xios_recv_field("rug_limin",rug_mpi)
-         ENDIF
-
-       IF ( type_ocean /= 'couple') THEN
-          CALL Scatter_omp(sst_mpi,sst)
-          CALL Scatter_omp(pct_mpi(:,is_oce),pctsrf(:,is_oce))
-          CALL Scatter_omp(pct_mpi(:,is_sic),pctsrf(:,is_sic))
-!          IF (read_continents .OR. itime == 1) THEN
-             CALL Scatter_omp(pct_mpi(:,is_ter),pctsrf(:,is_ter))
-             CALL Scatter_omp(pct_mpi(:,is_lic),pctsrf(:,is_lic))
-!          END IF
-       END IF
-
-       IF (.NOT. ok_veget) THEN
-          CALL Scatter_omp(alb_mpi, albedo)
-          CALL Scatter_omp(rug_mpi, rugos)
-       END IF
- 
-     ELSE      ! grid_type==regular
-
-!$OMP MASTER  ! Only master thread
-       IF (is_mpi_root) THEN ! Only master processus!
-
-          ierr = NF90_OPEN ('limit.nc', NF90_NOWRITE, nid)
-          IF (ierr /= NF90_NOERR) CALL abort_physic(modname,&
-               'Pb d''ouverture du fichier de conditions aux limites',1)
-
-          ! La tranche de donnees a lire:
-          start(1) = 1
-          start(2) = jour
-          epais(1) = klon_glo
-          epais(2) = 1
-
-
-!****************************************************************************************
-! 2) Read fraction if not type_ocean=couple
-!
-!****************************************************************************************
-
-          IF ( type_ocean /= 'couple') THEN
-!
-! Ocean fraction
-             ierr = NF90_INQ_VARID(nid, 'FOCE', nvarid)
-             IF (ierr /= NF90_NOERR) CALL abort_physic(modname, 'Le champ <FOCE> est absent',1)
-             
-             ierr = NF90_GET_VAR(nid,nvarid,pct_glo(:,is_oce),start,epais)
-             IF (ierr /= NF90_NOERR) CALL abort_physic(modname,'Lecture echouee pour <FOCE>' ,1)
-!
-! Sea-ice fraction
-             ierr = NF90_INQ_VARID(nid, 'FSIC', nvarid)
-             IF (ierr /= NF90_NOERR) CALL abort_physic(modname,'Le champ <FSIC> est absent',1)
-
-             ierr = NF90_GET_VAR(nid,nvarid,pct_glo(:,is_sic),start,epais)
-             IF (ierr /= NF90_NOERR) CALL abort_physic(modname,'Lecture echouee pour <FSIC>' ,1)
-
-
-! Read land and continentals fraction only if asked for
-             IF (read_continents .OR. itime == 1) THEN
-!
-! Land fraction
-                ierr = NF90_INQ_VARID(nid, 'FTER', nvarid)
-                IF (ierr /= NF90_NOERR) CALL abort_physic(modname,'Le champ <FTER> est absent',1)
-                
-                ierr = NF90_GET_VAR(nid,nvarid,pct_glo(:,is_ter),start,epais)
-                IF (ierr /= NF90_NOERR) CALL abort_physic(modname,'Lecture echouee pour <FTER>',1)
-!
-! Continentale ice fraction
-                ierr = NF90_INQ_VARID(nid, 'FLIC', nvarid)
-                IF (ierr /= NF90_NOERR) CALL abort_physic(modname,'Le champ <FLIC> est absent',1)
-
-                ierr = NF90_GET_VAR(nid,nvarid,pct_glo(:,is_lic),start,epais)
-                IF (ierr /= NF90_NOERR) CALL abort_physic(modname,'Lecture echouee pour <FLIC>',1)
-             END IF
-
-          END IF ! type_ocean /= couple
-
-!****************************************************************************************
-! 3) Read sea-surface temperature, if not coupled ocean
-!
-!****************************************************************************************
-          IF ( type_ocean /= 'couple') THEN
-
-             ierr = NF90_INQ_VARID(nid, 'SST', nvarid)
-             IF (ierr /= NF90_NOERR) CALL abort_physic(modname,'Le champ <SST> est absent',1)
-
-             ierr = NF90_GET_VAR(nid,nvarid,sst_glo,start,epais)
-             IF (ierr /= NF90_NOERR) CALL abort_physic(modname,'Lecture echouee pour <SST>',1)
-          
-          END IF
-
-!****************************************************************************************
-! 4) Read albedo and rugosity for land surface, only in case of no vegetation model
-!
-!****************************************************************************************
-
-          IF (.NOT. ok_veget) THEN
-!
-! Read albedo
-             ierr = NF90_INQ_VARID(nid, 'ALB', nvarid)
-             IF (ierr /= NF90_NOERR) CALL abort_physic(modname,'Le champ <ALB> est absent',1)
-
-             ierr = NF90_GET_VAR(nid,nvarid,alb_glo,start,epais)
-             IF (ierr /= NF90_NOERR) CALL abort_physic(modname,'Lecture echouee pour <ALB>',1)
-!
-! Read rugosity
-             ierr = NF90_INQ_VARID(nid, 'RUG', nvarid)
-             IF (ierr /= NF90_NOERR) CALL abort_physic(modname,'Le champ <RUG> est absent',1)
-
-             ierr = NF90_GET_VAR(nid,nvarid,rug_glo,start,epais)
-             IF (ierr /= NF90_NOERR) CALL abort_physic(modname,'Lecture echouee pour <RUG>',1)
-
-          END IF
-
-!****************************************************************************************
-! 5) Close file and distribuate variables to all processus
-!
-!****************************************************************************************
-          ierr = NF90_CLOSE(nid)
-          IF (ierr /= NF90_NOERR) CALL abort_physic(modname,'Pb when closing file', 1)
-       ENDIF ! is_mpi_root
-
-!$OMP END MASTER
-!$OMP BARRIER
-
-       IF ( type_ocean /= 'couple') THEN
-          CALL Scatter(sst_glo,sst)
-          CALL Scatter(pct_glo(:,is_oce),pctsrf(:,is_oce))
-          CALL Scatter(pct_glo(:,is_sic),pctsrf(:,is_sic))
-          IF (read_continents .OR. itime == 1) THEN
-             CALL Scatter(pct_glo(:,is_ter),pctsrf(:,is_ter))
-             CALL Scatter(pct_glo(:,is_lic),pctsrf(:,is_lic))
-          END IF
-       END IF
-
-       IF (.NOT. ok_veget) THEN
-          CALL Scatter(alb_glo, albedo)
-          CALL Scatter(rug_glo, rugos)
-       END IF
-
-      ENDIF ! Grid type
-
-    ENDIF ! time to read
-
-  END SUBROUTINE limit_read_tot
-
-END MODULE limit_read_mod
Index: /LMDZ6/trunk/libf/phylmd/limit_read_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/limit_read_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/limit_read_mod.f90	(revision 5268)
@@ -0,0 +1,455 @@
+!
+! $Id$
+!
+MODULE limit_read_mod
+!
+! This module reads the fichier "limit.nc" containing fields for surface forcing.
+!
+! Module subroutines :
+!  limit_read_frac    : call limit_read_tot and return the fractions
+!  limit_read_rug_alb : return rugosity and albedo, if coupled ocean call limit_read_tot first
+!  limit_read_sst     : return sea ice temperature   
+!  limit_read_tot     : read limit.nc and store the fields in local modules variables
+!
+  IMPLICIT NONE
+
+  REAL, ALLOCATABLE, DIMENSION(:,:), SAVE, PRIVATE :: pctsrf
+!$OMP THREADPRIVATE(pctsrf)
+  REAL, ALLOCATABLE, DIMENSION(:),   SAVE, PRIVATE :: rugos
+!$OMP THREADPRIVATE(rugos)
+  REAL, ALLOCATABLE, DIMENSION(:),   SAVE, PRIVATE :: albedo
+!$OMP THREADPRIVATE(albedo)  
+  REAL, ALLOCATABLE, DIMENSION(:),   SAVE, PRIVATE :: sst
+!$OMP THREADPRIVATE(sst)  
+  LOGICAL,SAVE :: read_continents=.FALSE.
+!$OMP THREADPRIVATE(read_continents) 
+
+CONTAINS
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!
+!! Public subroutines :
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+
+  SUBROUTINE init_limit_read(first_day)
+  USE mod_grid_phy_lmdz
+  USE surface_data
+  USE mod_phys_lmdz_para
+  USE lmdz_xios
+
+  IMPLICIT NONE
+    INTEGER, INTENT(IN) :: first_day
+    
+    
+    IF ( type_ocean /= 'couple') THEN
+      IF (grid_type==unstructured) THEN
+        IF (is_omp_master) CALL xios_set_file_attr("limit_read",enabled=.TRUE.,record_offset=first_day)
+      ENDIF  
+    ENDIF
+
+  END SUBROUTINE init_limit_read
+  
+  SUBROUTINE limit_read_frac(itime, dtime, jour, pctsrf_new, is_modified)
+!
+! This subroutine is called from "change_srf_frac" for case of 
+! ocean=force or from ocean_slab_frac for ocean=slab.
+! The fraction for all sub-surfaces at actual time step is returned.
+
+    USE dimphy
+    USE indice_sol_mod
+
+! Input arguments
+!****************************************************************************************
+    INTEGER, INTENT(IN) :: itime   ! time step
+    INTEGER, INTENT(IN) :: jour    ! current day
+    REAL   , INTENT(IN) :: dtime   ! length of time step
+  
+! Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon,nbsrf), INTENT(OUT) :: pctsrf_new  ! sub surface fractions
+    LOGICAL, INTENT(OUT)                     :: is_modified ! true if pctsrf is modified at this time step
+
+! End declaration
+!****************************************************************************************
+
+! 1) Read file limit.nc
+    CALL limit_read_tot(itime, dtime, jour, is_modified)
+
+! 2) Return the fraction read in limit_read_tot
+    pctsrf_new(:,:) = pctsrf(:,:)
+    
+  END SUBROUTINE limit_read_frac
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+  SUBROUTINE limit_read_rug_alb(itime, dtime, jour, &
+       knon, knindex, &
+       rugos_out, alb_out)
+!
+! This subroutine is called from surf_land_bucket. 
+! The flag "ok_veget" must can not be true. If coupled run, "ocean=couple"
+! then this routine will call limit_read_tot.
+!
+    USE dimphy
+    USE surface_data
+
+! Input arguments
+!****************************************************************************************
+    INTEGER, INTENT(IN) :: itime                     ! numero du pas de temps courant
+    INTEGER, INTENT(IN) :: jour                      ! jour a lire dans l'annee
+    REAL   , INTENT(IN) :: dtime                     ! pas de temps de la physique (en s)
+    INTEGER, INTENT(IN) :: knon                      ! nomber of points on compressed grid
+    INTEGER, DIMENSION(klon), INTENT(IN) :: knindex  ! grid point number for compressed grid
+! Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(OUT) :: rugos_out
+    REAL, DIMENSION(klon), INTENT(OUT) :: alb_out
+    
+! Local variables
+!****************************************************************************************
+    INTEGER :: i
+    LOGICAL :: is_modified
+!****************************************************************************************
+
+IF (type_ocean == 'couple'.OR. &
+         (type_ocean == 'slab' .AND. version_ocean == 'sicINT')) THEN
+       ! limit.nc has not yet been read. Do it now!
+       CALL limit_read_tot(itime, dtime, jour, is_modified)
+    END IF
+
+    DO i=1,knon
+       rugos_out(i) = rugos(knindex(i))
+       alb_out(i)  = albedo(knindex(i))
+    END DO
+
+  END SUBROUTINE limit_read_rug_alb
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+  SUBROUTINE limit_read_sst(knon, knindex, sst_out)
+!
+! This subroutine returns the sea surface temperature already read from limit.nc.
+!
+    USE dimphy, ONLY : klon
+
+    INTEGER, INTENT(IN)                  :: knon     ! nomber of points on compressed grid
+    INTEGER, DIMENSION(klon), INTENT(IN) :: knindex  ! grid point number for compressed grid
+    REAL, DIMENSION(klon), INTENT(OUT)   :: sst_out
+
+    INTEGER :: i
+
+    DO i = 1, knon
+       sst_out(i) = sst(knindex(i))
+    END DO
+
+  END SUBROUTINE limit_read_sst
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!
+!! Private subroutine :
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+  SUBROUTINE limit_read_tot(itime, dtime, jour, is_modified)
+!
+! Read everything needed from limit.nc
+!
+! 0) Initialize
+! 1) Open the file limit.nc, if it is time
+! 2) Read fraction, if not type_ocean=couple
+! 3) Read sea surface temperature, if not type_ocean=couple
+! 4) Read albedo and rugosity for land surface, only in case of no vegetation model
+! 5) Close file and distribuate variables to all processus
+
+    USE dimphy
+    USE mod_grid_phy_lmdz
+    USE mod_phys_lmdz_para
+    USE surface_data, ONLY : type_ocean, ok_veget
+    USE netcdf
+    USE indice_sol_mod
+    USE phys_cal_mod, ONLY : calend, year_len
+    USE print_control_mod, ONLY: lunout, prt_level
+    USE lmdz_xios, ONLY: xios_recv_field, using_xios
+    
+    IMPLICIT NONE
+    
+! In- and ouput arguments
+!****************************************************************************************
+    INTEGER, INTENT(IN) :: itime   ! numero du pas de temps courant
+    INTEGER, INTENT(IN) :: jour    ! jour a lire dans l'annee
+    REAL   , INTENT(IN) :: dtime   ! pas de temps de la physique (en s)
+
+    LOGICAL, INTENT(OUT) :: is_modified  ! true if pctsrf is modified at this time step
+
+! Locals variables with attribute SAVE
+!****************************************************************************************
+! frequence de lecture des conditions limites (en pas de physique) 
+    INTEGER,SAVE                              :: lmt_pas
+!$OMP THREADPRIVATE(lmt_pas) 
+    LOGICAL, SAVE                             :: first_call=.TRUE.
+!$OMP THREADPRIVATE(first_call)  
+    INTEGER, SAVE                             :: jour_lu = -1
+!$OMP THREADPRIVATE(jour_lu)  
+! Locals variables
+!****************************************************************************************
+    INTEGER                                   :: nid, nvarid, ndimid, nn
+    INTEGER                                   :: ii, ierr
+    INTEGER, DIMENSION(2)                     :: start, epais
+    REAL, DIMENSION(klon_glo,nbsrf)           :: pct_glo  ! fraction at global grid
+    REAL, DIMENSION(klon_glo)                 :: sst_glo  ! sea-surface temperature at global grid
+    REAL, DIMENSION(klon_glo)                 :: rug_glo  ! rugosity at global grid
+    REAL, DIMENSION(klon_glo)                 :: alb_glo  ! albedo at global grid
+
+    REAL, DIMENSION(klon_mpi,nbsrf)           :: pct_mpi  ! fraction at global grid
+    REAL, DIMENSION(klon_mpi)                 :: sst_mpi  ! sea-surface temperature at global grid
+    REAL, DIMENSION(klon_mpi)                 :: rug_mpi  ! rugosity at global grid
+    REAL, DIMENSION(klon_mpi)                 :: alb_mpi  ! albedo at global grid
+
+    CHARACTER(len=20)                         :: modname='limit_read_mod'     
+    CHARACTER(LEN=99)                         :: abort_message, calendar, str
+
+! End declaration
+!****************************************************************************************
+
+!****************************************************************************************
+! 0) Initialization
+!
+!****************************************************************************************
+    IF (first_call) THEN
+       first_call=.FALSE.
+       ! calculate number of time steps for one day
+       lmt_pas = NINT(86400./dtime * 1.0)
+       
+       ! Allocate module save variables
+       IF ( type_ocean /= 'couple' ) THEN
+          ALLOCATE(pctsrf(klon,nbsrf), sst(klon), stat=ierr)
+          IF (ierr /= 0) CALL abort_physic(modname, 'PB in allocating pctsrf and sst',1)
+       END IF
+
+       IF ( .NOT. ok_veget ) THEN
+          ALLOCATE(rugos(klon), albedo(klon), stat=ierr)
+          IF (ierr /= 0) CALL abort_physic(modname, 'PB in allocating rugos and albedo',1)
+       END IF
+
+!$OMP MASTER  ! Only master thread
+       IF (is_mpi_root) THEN ! Only master processus
+          ierr = NF90_OPEN ('limit.nc', NF90_NOWRITE, nid)
+          IF (ierr /= NF90_NOERR) CALL abort_physic(modname,&
+               'Pb d''ouverture du fichier de conditions aux limites',1)
+
+          !--- WARNING IF CALENDAR IS KNOWN AND DOES NOT MATCH THE ONE OF LMDZ
+          ierr=NF90_INQ_VARID(nid, 'TEMPS', nvarid)
+          ierr=NF90_GET_ATT(nid, nvarid, 'calendar', calendar)
+          IF(ierr==NF90_NOERR.AND.calendar/=calend.AND.prt_level>=1) THEN
+             WRITE(lunout,*)'BEWARE: gcm and limit.nc calendars differ: '
+             WRITE(lunout,*)'  '//TRIM(calend)//' for gcm'
+             WRITE(lunout,*)'  '//TRIM(calendar)//' for limit.nc file'
+          END IF
+
+          !--- ERROR IF FILE RECORDS NUMBER IS NOT EQUAL TO EXPECTED NUMBER OF DAYS          
+          IF (grid_type==unstructured) THEN
+            ierr=NF90_INQ_DIMID(nid,"time_year",ndimid)
+          ELSE
+            ierr=NF90_INQUIRE(nid, UnlimitedDimID=ndimid)
+          ENDIF
+          ierr=NF90_INQUIRE_DIMENSION(nid, ndimid, len=nn)
+          WRITE(abort_message,'(a,2(i0,a))')'limit.nc records number (',nn,') does no'//&
+            't match year length (',year_len,')'
+          IF(nn/=year_len) CALL abort_physic(modname,abort_message,1)
+
+          !--- ERROR IF FILES AND LMDZ HORIZONTAL RESOLUTIONS DO NOT MATCH
+          IF (grid_type==unstructured) THEN
+            ierr=NF90_INQ_DIMID(nid, 'cell', ndimid)
+          ELSE
+            ierr=NF90_INQ_DIMID(nid, 'points_physiques', ndimid)
+          ENDIF
+          ierr=NF90_INQUIRE_DIMENSION(nid, ndimid, len=nn)
+          WRITE(abort_message,'(a,2(i0,a))')'limit.nc horizontal number of cells (',nn, &
+            ') does not match LMDZ klon_glo (',klon_glo,')'
+          IF(nn/=klon_glo) CALL abort_physic(modname,abort_message,1)
+
+          ierr = NF90_CLOSE(nid)
+          IF (ierr /= NF90_NOERR) CALL abort_physic(modname,'Pb when closing file', 1)
+       END IF ! is_mpi_root
+!$OMP END MASTER
+!$OMP BARRIER
+    END IF
+
+!****************************************************************************************
+! 1) Open the file limit.nc if it is the right moment to read, once a day.
+!    The file is read only by the master thread of the master mpi process(is_mpi_root)
+!    Check by the way if the number of records is correct.
+!
+!****************************************************************************************
+
+    is_modified = .FALSE.
+!ym    IF (MOD(itime-1, lmt_pas) == 0 .OR. jour_lu /= jour ) THEN   ! time to read
+!  not REALLY PERIODIC
+    IF (MOD(itime-1, lmt_pas) == 0 .OR. (jour_lu /= jour .AND. grid_type /= unstructured)) THEN   ! time to read
+!    IF (MOD(itime-1, lmt_pas) == 0) THEN   ! time to read
+       jour_lu = jour
+       is_modified = .TRUE.
+
+      IF (grid_type==unstructured) THEN
+
+        IF ( type_ocean /= 'couple') THEN
+
+           IF (is_omp_master) CALL xios_recv_field("foce_limin",pct_mpi(:,is_oce))
+           IF (is_omp_master) CALL xios_recv_field("fsic_limin",pct_mpi(:,is_sic))
+  !         IF (read_continents .OR. itime == 1) THEN
+           IF (is_omp_master) CALL xios_recv_field("fter_limin",pct_mpi(:,is_ter))
+           IF (is_omp_master) CALL xios_recv_field("flic_limin",pct_mpi(:,is_lic))
+  !         ENDIF
+         ENDIF! type_ocean /= couple
+         
+         IF ( type_ocean /= 'couple') THEN                    
+             IF (is_omp_master) CALL xios_recv_field("sst_limin",sst_mpi)
+         ENDIF
+       
+         IF (.NOT. ok_veget) THEN
+           IF (is_omp_master) CALL xios_recv_field("alb_limin",alb_mpi)
+           IF (is_omp_master) CALL xios_recv_field("rug_limin",rug_mpi)
+         ENDIF
+
+       IF ( type_ocean /= 'couple') THEN
+          CALL Scatter_omp(sst_mpi,sst)
+          CALL Scatter_omp(pct_mpi(:,is_oce),pctsrf(:,is_oce))
+          CALL Scatter_omp(pct_mpi(:,is_sic),pctsrf(:,is_sic))
+!          IF (read_continents .OR. itime == 1) THEN
+             CALL Scatter_omp(pct_mpi(:,is_ter),pctsrf(:,is_ter))
+             CALL Scatter_omp(pct_mpi(:,is_lic),pctsrf(:,is_lic))
+!          END IF
+       END IF
+
+       IF (.NOT. ok_veget) THEN
+          CALL Scatter_omp(alb_mpi, albedo)
+          CALL Scatter_omp(rug_mpi, rugos)
+       END IF
+ 
+     ELSE      ! grid_type==regular
+
+!$OMP MASTER  ! Only master thread
+       IF (is_mpi_root) THEN ! Only master processus!
+
+          ierr = NF90_OPEN ('limit.nc', NF90_NOWRITE, nid)
+          IF (ierr /= NF90_NOERR) CALL abort_physic(modname,&
+               'Pb d''ouverture du fichier de conditions aux limites',1)
+
+          ! La tranche de donnees a lire:
+          start(1) = 1
+          start(2) = jour
+          epais(1) = klon_glo
+          epais(2) = 1
+
+
+!****************************************************************************************
+! 2) Read fraction if not type_ocean=couple
+!
+!****************************************************************************************
+
+          IF ( type_ocean /= 'couple') THEN
+!
+! Ocean fraction
+             ierr = NF90_INQ_VARID(nid, 'FOCE', nvarid)
+             IF (ierr /= NF90_NOERR) CALL abort_physic(modname, 'Le champ <FOCE> est absent',1)
+             
+             ierr = NF90_GET_VAR(nid,nvarid,pct_glo(:,is_oce),start,epais)
+             IF (ierr /= NF90_NOERR) CALL abort_physic(modname,'Lecture echouee pour <FOCE>' ,1)
+!
+! Sea-ice fraction
+             ierr = NF90_INQ_VARID(nid, 'FSIC', nvarid)
+             IF (ierr /= NF90_NOERR) CALL abort_physic(modname,'Le champ <FSIC> est absent',1)
+
+             ierr = NF90_GET_VAR(nid,nvarid,pct_glo(:,is_sic),start,epais)
+             IF (ierr /= NF90_NOERR) CALL abort_physic(modname,'Lecture echouee pour <FSIC>' ,1)
+
+
+! Read land and continentals fraction only if asked for
+             IF (read_continents .OR. itime == 1) THEN
+!
+! Land fraction
+                ierr = NF90_INQ_VARID(nid, 'FTER', nvarid)
+                IF (ierr /= NF90_NOERR) CALL abort_physic(modname,'Le champ <FTER> est absent',1)
+                
+                ierr = NF90_GET_VAR(nid,nvarid,pct_glo(:,is_ter),start,epais)
+                IF (ierr /= NF90_NOERR) CALL abort_physic(modname,'Lecture echouee pour <FTER>',1)
+!
+! Continentale ice fraction
+                ierr = NF90_INQ_VARID(nid, 'FLIC', nvarid)
+                IF (ierr /= NF90_NOERR) CALL abort_physic(modname,'Le champ <FLIC> est absent',1)
+
+                ierr = NF90_GET_VAR(nid,nvarid,pct_glo(:,is_lic),start,epais)
+                IF (ierr /= NF90_NOERR) CALL abort_physic(modname,'Lecture echouee pour <FLIC>',1)
+             END IF
+
+          END IF ! type_ocean /= couple
+
+!****************************************************************************************
+! 3) Read sea-surface temperature, if not coupled ocean
+!
+!****************************************************************************************
+          IF ( type_ocean /= 'couple') THEN
+
+             ierr = NF90_INQ_VARID(nid, 'SST', nvarid)
+             IF (ierr /= NF90_NOERR) CALL abort_physic(modname,'Le champ <SST> est absent',1)
+
+             ierr = NF90_GET_VAR(nid,nvarid,sst_glo,start,epais)
+             IF (ierr /= NF90_NOERR) CALL abort_physic(modname,'Lecture echouee pour <SST>',1)
+          
+          END IF
+
+!****************************************************************************************
+! 4) Read albedo and rugosity for land surface, only in case of no vegetation model
+!
+!****************************************************************************************
+
+          IF (.NOT. ok_veget) THEN
+!
+! Read albedo
+             ierr = NF90_INQ_VARID(nid, 'ALB', nvarid)
+             IF (ierr /= NF90_NOERR) CALL abort_physic(modname,'Le champ <ALB> est absent',1)
+
+             ierr = NF90_GET_VAR(nid,nvarid,alb_glo,start,epais)
+             IF (ierr /= NF90_NOERR) CALL abort_physic(modname,'Lecture echouee pour <ALB>',1)
+!
+! Read rugosity
+             ierr = NF90_INQ_VARID(nid, 'RUG', nvarid)
+             IF (ierr /= NF90_NOERR) CALL abort_physic(modname,'Le champ <RUG> est absent',1)
+
+             ierr = NF90_GET_VAR(nid,nvarid,rug_glo,start,epais)
+             IF (ierr /= NF90_NOERR) CALL abort_physic(modname,'Lecture echouee pour <RUG>',1)
+
+          END IF
+
+!****************************************************************************************
+! 5) Close file and distribuate variables to all processus
+!
+!****************************************************************************************
+          ierr = NF90_CLOSE(nid)
+          IF (ierr /= NF90_NOERR) CALL abort_physic(modname,'Pb when closing file', 1)
+       ENDIF ! is_mpi_root
+
+!$OMP END MASTER
+!$OMP BARRIER
+
+       IF ( type_ocean /= 'couple') THEN
+          CALL Scatter(sst_glo,sst)
+          CALL Scatter(pct_glo(:,is_oce),pctsrf(:,is_oce))
+          CALL Scatter(pct_glo(:,is_sic),pctsrf(:,is_sic))
+          IF (read_continents .OR. itime == 1) THEN
+             CALL Scatter(pct_glo(:,is_ter),pctsrf(:,is_ter))
+             CALL Scatter(pct_glo(:,is_lic),pctsrf(:,is_lic))
+          END IF
+       END IF
+
+       IF (.NOT. ok_veget) THEN
+          CALL Scatter(alb_glo, albedo)
+          CALL Scatter(rug_glo, rugos)
+       END IF
+
+      ENDIF ! Grid type
+
+    ENDIF ! time to read
+
+  END SUBROUTINE limit_read_tot
+
+END MODULE limit_read_mod
Index: DZ6/trunk/libf/phylmd/limit_slab.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/limit_slab.F90	(revision 5267)
+++ 	(revision )
@@ -1,195 +1,0 @@
-! $Header$
-
-SUBROUTINE limit_slab(itime, dtime, jour, lmt_bils, diff_sst, diff_siv)
-
-  USE dimphy
-  USE mod_grid_phy_lmdz, ONLY: klon_glo
-  USE mod_phys_lmdz_para
-  USE netcdf 
-  USE indice_sol_mod
-  USE ocean_slab_mod, ONLY: nslay
-
-  IMPLICIT NONE
-
-  INCLUDE "clesphys.h"
-
-! In- and ouput arguments
-!****************************************************************************************
-  INTEGER, INTENT(IN) :: itime   ! numero du pas de temps courant
-  INTEGER, INTENT(IN) :: jour    ! jour a lire dans l'annee
-  REAL   , INTENT(IN) :: dtime   ! pas de temps de la physique (en s)
-  REAL, DIMENSION(klon), INTENT(OUT) ::  diff_sst, diff_siv
-  REAL, DIMENSION(klon,nslay), INTENT(OUT) :: lmt_bils
-
-! Locals variables with attribute SAVE
-!****************************************************************************************
-  REAL, DIMENSION(:), ALLOCATABLE, SAVE :: diff_siv_save, diff_sst_save
-  REAL, DIMENSION(:,:), ALLOCATABLE, SAVE :: bils_save
-!$OMP THREADPRIVATE(bils_save, diff_sst_save, diff_siv_save)
-
-! Locals variables
-!****************************************************************************************
-  INTEGER                  :: lmt_pas   
-  INTEGER                  :: nvarid, nid, ierr, i
-  INTEGER, DIMENSION(2)    :: start, epais 
-  REAL, DIMENSION(klon_glo):: sst_l_glo, sst_lp1_glo, diff_sst_glo
-  REAL, DIMENSION(klon_glo):: siv_l_glo, siv_lp1_glo, diff_siv_glo
-  REAL, DIMENSION(klon_glo,nslay):: bils_glo
-  CHARACTER (len = 20)     :: modname = 'limit_slab'
-  CHARACTER*2 str2
-  LOGICAL                  :: read_bils,read_sst,read_siv
-
-! End declaration
-!****************************************************************************************
-
-  ! calculate number of time steps for one day
-  lmt_pas = NINT(86400./dtime)
-  
-! Initialize saved variables
-     IF (.NOT. ALLOCATED(bils_save)) THEN
-        ALLOCATE(bils_save(klon,nslay), diff_sst_save(klon), diff_siv_save(klon), stat=ierr)
-        IF (ierr /= 0) CALL abort_physic('limit_slab', 'pb in allocation',1)
-     END IF
-
-  ! F. Codron 5/14: add defaults for bils, diff_sst (0)
-  IF (MOD(itime-1, lmt_pas) == 0) THEN   ! time to read
-!$OMP MASTER  ! Only master thread
-     IF (is_mpi_root) THEN ! Only master processus
-        print*,'in limit_slab time to read, itime=',itime
-        read_bils=.TRUE.
-        read_sst=.TRUE.
-        read_siv=.TRUE.
-        
-        ierr = NF90_OPEN ('limit_slab.nc', NF90_NOWRITE, nid)
-        IF (ierr /= NF90_NOERR) THEN
-            PRINT *,'LIMIT_SLAB file not found'
-            read_bils=.FALSE.
-            read_sst=.FALSE.
-            read_siv=.FALSE.
-        ELSE ! read file
-        
-        ! La tranche de donnees a lire:
-        start(1) = 1
-        start(2) = jour
-        epais(1) = klon_glo
-        epais(2) = 1
-
-!****************************************************************************************
-! 2) Read bils and SST/ ice volume tendency
-!
-!****************************************************************************************
-!
-! Read bils_glo
-        bils_glo(:,:)=0.
-        ! First read first layer
-        ! try first "BILS_OCE01"
-        ierr = NF90_INQ_VARID(nid, 'BILS_OCE01', nvarid)
-        IF (ierr /= NF90_NOERR) THEN
-            ! Else BILS_OCE
-            ierr = NF90_INQ_VARID(nid, 'BILS_OCE', nvarid)
-            IF (ierr /= NF90_NOERR) THEN
-              read_bils=.FALSE.
-            ELSE
-              ierr = NF90_GET_VAR(nid,nvarid,bils_glo(:,1),start,epais)
-              IF (ierr /= NF90_NOERR) read_bils=.FALSE.
-            ENDIF
-        ELSE
-            ierr = NF90_GET_VAR(nid,nvarid,bils_glo(:,1),start,epais)
-            IF (ierr /= NF90_NOERR) read_bils=.FALSE.
-        END IF
-        ! Try next layers if more than 1
-        IF ((nslay.GT.1).AND.read_bils) THEN
-          DO i=2,nslay
-            WRITE(str2,'(i2.2)') i
-            ierr = NF90_INQ_VARID(nid,'BILS_OCE'//str2, nvarid)
-            IF (ierr.EQ.NF90_NOERR) THEN
-              ierr = NF90_GET_VAR(nid,nvarid,bils_glo(:,i),start,epais)
-            ENDIF
-            IF (ierr /= NF90_NOERR) THEN
-              print *,'WARNING : BILS_OCE not found for layer 2'
-            ENDIF
-          ENDDO
-        ENDIF
-
-! Read sst_glo for this day
-        ierr = NF90_INQ_VARID(nid, 'SST', nvarid)
-        IF (ierr /= NF90_NOERR)  THEN
-            read_sst=.FALSE.
-        ELSE
-            ierr = NF90_GET_VAR(nid,nvarid,sst_l_glo,start,epais)
-            IF (ierr /= NF90_NOERR) read_sst=.FALSE.
-! Read sst_glo for one day ahead
-            start(2) = jour + 1
-            IF (start(2) > 360) start(2)=1
-            ierr = NF90_GET_VAR(nid,nvarid,sst_lp1_glo,start,epais)
-            IF (ierr /= NF90_NOERR) read_sst=.FALSE.
-        END IF
-
-! Read siv_glo for this day
-        ierr = NF90_INQ_VARID(nid, 'SICV', nvarid)
-        IF (ierr /= NF90_NOERR)  THEN
-            read_siv=.FALSE.
-        ELSE
-            start(2) = jour
-            ierr = NF90_GET_VAR(nid,nvarid,siv_l_glo,start,epais)
-            IF (ierr /= NF90_NOERR) read_siv=.FALSE.
-! Read siv_glo for one day ahead
-            start(2) = jour + 1
-            IF (start(2) > 360) start(2)=1
-            ierr = NF90_GET_VAR(nid,nvarid,siv_lp1_glo,start,epais)
-            IF (ierr /= NF90_NOERR) read_siv=.FALSE.
-        END IF
-
-!****************************************************************************************
-! 5) Close file and distribute variables to all processus
-!
-!****************************************************************************************
-        ierr = NF90_CLOSE(nid)
-        IF (ierr /= NF90_NOERR) CALL abort_physic(modname,'Pb when closing file', 1)
-        END IF ! Read File 
-        IF (read_sst) THEN
-! Calculate difference in temperature between this day and one ahead
-            DO i=1, klon_glo
-               diff_sst_glo(i) = sst_lp1_glo(i) - sst_l_glo(i)
-            END DO
-        END IF !read_sst
-        IF (read_siv) THEN
-! Calculate difference in temperature between this day and one ahead
-            DO i=1, klon_glo
-               diff_siv_glo(i) = siv_lp1_glo(i) - siv_l_glo(i)
-            END DO
-        END IF !read_siv
-     ENDIF ! is_mpi_root
-
-!$OMP END MASTER
-!$OMP BARRIER
-       
-! Send fields to all processes
-! Give default values if needed
-     CALL bcast(read_bils)
-     CALL bcast(read_sst)
-     CALL bcast(read_siv)
-     PRINT *,'limit_slab sst',read_sst,'siv',read_siv,'qflux',read_bils
-     IF (read_bils) THEN
-         CALL Scatter(bils_glo, bils_save)
-     ELSE
-         bils_save(:,:)=0.
-     END IF
-     IF (read_sst) THEN
-         CALL Scatter(diff_sst_glo, diff_sst_save)
-     ELSE
-         diff_sst_save(:)=0.
-     END IF
-     IF (read_siv) THEN
-         CALL Scatter(diff_siv_glo, diff_siv_save)
-     ELSE
-         diff_siv_save(:)=0.
-     END IF
-     
-  ENDIF ! time to read
-
-  lmt_bils(:,:) = bils_save(:,:)
-  diff_sst(:) = diff_sst_save(:)
-  diff_siv(:) = diff_siv_save(:)
-
-END SUBROUTINE limit_slab
Index: /LMDZ6/trunk/libf/phylmd/limit_slab.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/limit_slab.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/limit_slab.f90	(revision 5268)
@@ -0,0 +1,195 @@
+! $Header$
+
+SUBROUTINE limit_slab(itime, dtime, jour, lmt_bils, diff_sst, diff_siv)
+
+  USE dimphy
+  USE mod_grid_phy_lmdz, ONLY: klon_glo
+  USE mod_phys_lmdz_para
+  USE netcdf 
+  USE indice_sol_mod
+  USE ocean_slab_mod, ONLY: nslay
+
+  IMPLICIT NONE
+
+  INCLUDE "clesphys.h"
+
+! In- and ouput arguments
+!****************************************************************************************
+  INTEGER, INTENT(IN) :: itime   ! numero du pas de temps courant
+  INTEGER, INTENT(IN) :: jour    ! jour a lire dans l'annee
+  REAL   , INTENT(IN) :: dtime   ! pas de temps de la physique (en s)
+  REAL, DIMENSION(klon), INTENT(OUT) ::  diff_sst, diff_siv
+  REAL, DIMENSION(klon,nslay), INTENT(OUT) :: lmt_bils
+
+! Locals variables with attribute SAVE
+!****************************************************************************************
+  REAL, DIMENSION(:), ALLOCATABLE, SAVE :: diff_siv_save, diff_sst_save
+  REAL, DIMENSION(:,:), ALLOCATABLE, SAVE :: bils_save
+!$OMP THREADPRIVATE(bils_save, diff_sst_save, diff_siv_save)
+
+! Locals variables
+!****************************************************************************************
+  INTEGER                  :: lmt_pas   
+  INTEGER                  :: nvarid, nid, ierr, i
+  INTEGER, DIMENSION(2)    :: start, epais 
+  REAL, DIMENSION(klon_glo):: sst_l_glo, sst_lp1_glo, diff_sst_glo
+  REAL, DIMENSION(klon_glo):: siv_l_glo, siv_lp1_glo, diff_siv_glo
+  REAL, DIMENSION(klon_glo,nslay):: bils_glo
+  CHARACTER (len = 20)     :: modname = 'limit_slab'
+  CHARACTER*2 str2
+  LOGICAL                  :: read_bils,read_sst,read_siv
+
+! End declaration
+!****************************************************************************************
+
+  ! calculate number of time steps for one day
+  lmt_pas = NINT(86400./dtime)
+  
+! Initialize saved variables
+     IF (.NOT. ALLOCATED(bils_save)) THEN
+        ALLOCATE(bils_save(klon,nslay), diff_sst_save(klon), diff_siv_save(klon), stat=ierr)
+        IF (ierr /= 0) CALL abort_physic('limit_slab', 'pb in allocation',1)
+     END IF
+
+  ! F. Codron 5/14: add defaults for bils, diff_sst (0)
+  IF (MOD(itime-1, lmt_pas) == 0) THEN   ! time to read
+!$OMP MASTER  ! Only master thread
+     IF (is_mpi_root) THEN ! Only master processus
+        print*,'in limit_slab time to read, itime=',itime
+        read_bils=.TRUE.
+        read_sst=.TRUE.
+        read_siv=.TRUE.
+        
+        ierr = NF90_OPEN ('limit_slab.nc', NF90_NOWRITE, nid)
+        IF (ierr /= NF90_NOERR) THEN
+            PRINT *,'LIMIT_SLAB file not found'
+            read_bils=.FALSE.
+            read_sst=.FALSE.
+            read_siv=.FALSE.
+        ELSE ! read file
+        
+        ! La tranche de donnees a lire:
+        start(1) = 1
+        start(2) = jour
+        epais(1) = klon_glo
+        epais(2) = 1
+
+!****************************************************************************************
+! 2) Read bils and SST/ ice volume tendency
+!
+!****************************************************************************************
+!
+! Read bils_glo
+        bils_glo(:,:)=0.
+        ! First read first layer
+        ! try first "BILS_OCE01"
+        ierr = NF90_INQ_VARID(nid, 'BILS_OCE01', nvarid)
+        IF (ierr /= NF90_NOERR) THEN
+            ! Else BILS_OCE
+            ierr = NF90_INQ_VARID(nid, 'BILS_OCE', nvarid)
+            IF (ierr /= NF90_NOERR) THEN
+              read_bils=.FALSE.
+            ELSE
+              ierr = NF90_GET_VAR(nid,nvarid,bils_glo(:,1),start,epais)
+              IF (ierr /= NF90_NOERR) read_bils=.FALSE.
+            ENDIF
+        ELSE
+            ierr = NF90_GET_VAR(nid,nvarid,bils_glo(:,1),start,epais)
+            IF (ierr /= NF90_NOERR) read_bils=.FALSE.
+        END IF
+        ! Try next layers if more than 1
+        IF ((nslay.GT.1).AND.read_bils) THEN
+          DO i=2,nslay
+            WRITE(str2,'(i2.2)') i
+            ierr = NF90_INQ_VARID(nid,'BILS_OCE'//str2, nvarid)
+            IF (ierr.EQ.NF90_NOERR) THEN
+              ierr = NF90_GET_VAR(nid,nvarid,bils_glo(:,i),start,epais)
+            ENDIF
+            IF (ierr /= NF90_NOERR) THEN
+              print *,'WARNING : BILS_OCE not found for layer 2'
+            ENDIF
+          ENDDO
+        ENDIF
+
+! Read sst_glo for this day
+        ierr = NF90_INQ_VARID(nid, 'SST', nvarid)
+        IF (ierr /= NF90_NOERR)  THEN
+            read_sst=.FALSE.
+        ELSE
+            ierr = NF90_GET_VAR(nid,nvarid,sst_l_glo,start,epais)
+            IF (ierr /= NF90_NOERR) read_sst=.FALSE.
+! Read sst_glo for one day ahead
+            start(2) = jour + 1
+            IF (start(2) > 360) start(2)=1
+            ierr = NF90_GET_VAR(nid,nvarid,sst_lp1_glo,start,epais)
+            IF (ierr /= NF90_NOERR) read_sst=.FALSE.
+        END IF
+
+! Read siv_glo for this day
+        ierr = NF90_INQ_VARID(nid, 'SICV', nvarid)
+        IF (ierr /= NF90_NOERR)  THEN
+            read_siv=.FALSE.
+        ELSE
+            start(2) = jour
+            ierr = NF90_GET_VAR(nid,nvarid,siv_l_glo,start,epais)
+            IF (ierr /= NF90_NOERR) read_siv=.FALSE.
+! Read siv_glo for one day ahead
+            start(2) = jour + 1
+            IF (start(2) > 360) start(2)=1
+            ierr = NF90_GET_VAR(nid,nvarid,siv_lp1_glo,start,epais)
+            IF (ierr /= NF90_NOERR) read_siv=.FALSE.
+        END IF
+
+!****************************************************************************************
+! 5) Close file and distribute variables to all processus
+!
+!****************************************************************************************
+        ierr = NF90_CLOSE(nid)
+        IF (ierr /= NF90_NOERR) CALL abort_physic(modname,'Pb when closing file', 1)
+        END IF ! Read File 
+        IF (read_sst) THEN
+! Calculate difference in temperature between this day and one ahead
+            DO i=1, klon_glo
+               diff_sst_glo(i) = sst_lp1_glo(i) - sst_l_glo(i)
+            END DO
+        END IF !read_sst
+        IF (read_siv) THEN
+! Calculate difference in temperature between this day and one ahead
+            DO i=1, klon_glo
+               diff_siv_glo(i) = siv_lp1_glo(i) - siv_l_glo(i)
+            END DO
+        END IF !read_siv
+     ENDIF ! is_mpi_root
+
+!$OMP END MASTER
+!$OMP BARRIER
+       
+! Send fields to all processes
+! Give default values if needed
+     CALL bcast(read_bils)
+     CALL bcast(read_sst)
+     CALL bcast(read_siv)
+     PRINT *,'limit_slab sst',read_sst,'siv',read_siv,'qflux',read_bils
+     IF (read_bils) THEN
+         CALL Scatter(bils_glo, bils_save)
+     ELSE
+         bils_save(:,:)=0.
+     END IF
+     IF (read_sst) THEN
+         CALL Scatter(diff_sst_glo, diff_sst_save)
+     ELSE
+         diff_sst_save(:)=0.
+     END IF
+     IF (read_siv) THEN
+         CALL Scatter(diff_siv_glo, diff_siv_save)
+     ELSE
+         diff_siv_save(:)=0.
+     END IF
+     
+  ENDIF ! time to read
+
+  lmt_bils(:,:) = bils_save(:,:)
+  diff_sst(:) = diff_sst_save(:)
+  diff_siv(:) = diff_siv_save(:)
+
+END SUBROUTINE limit_slab
Index: DZ6/trunk/libf/phylmd/lmdz_atke_exchange_coeff.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/lmdz_atke_exchange_coeff.F90	(revision 5267)
+++ 	(revision )
@@ -1,512 +1,0 @@
-module lmdz_atke_exchange_coeff
-
-implicit none
-
-contains 
-
-subroutine atke_compute_km_kh(ngrid,nlay,dtime, &
-                        wind_u,wind_v,temp,qvap,play,pinterf,cdrag_uv, &
-                        tke,eps,tke_shear,tke_buoy,tke_trans,Km_out,Kh_out)
-
-!========================================================================
-! Routine that computes turbulent Km / Kh coefficients with a
-! 1.5 order closure scheme (TKE) with or without stationarity assumption
-!
-! This parameterization has been constructed in the framework of a
-! collective and collaborative workshop, 
-! the so-called 'Atelier TKE (ATKE)' with
-! K. Arjdal, L. Raillard, C. Dehondt, P. Tiengou, A. Spiga, F. Cheruy, T Dubos, 
-! M. Coulon-Decorzens, S. Fromang, G. Riviere, A. Sima, F. Hourdin, E. Vignon
-!
-! Main assumptions of the model :
-! (1) horizontal homogeneity (Dx=Dy=0.)
-!=======================================================================
-
-USE lmdz_atke_turbulence_ini, ONLY : iflag_atke, kappa, l0, ric, cinf, rpi, rcpd, atke_ok_virtual, ri0, ri1
-USE lmdz_atke_turbulence_ini, ONLY : cepsilon, pr_slope, pr_asym, pr_neut, ctkes, rg, rd, rv, atke_ok_vdiff
-USE lmdz_atke_turbulence_ini, ONLY : viscom, viscoh, clmix, clmixshear, iflag_atke_lmix, lmin, smmin, cn
-
-!!-------------------------------------------------------------------------------------------------------------
-! integer :: iflag_atke        ! flag that controls options in atke_compute_km_kh
-! integer :: iflag_atke_lmix   ! flag that controls the calculation of mixing length in atke
-! integer :: iflag_num_atke    ! flag that controls the numerical treatment of diffusion coeffiient calculation
-
-! logical :: atke_ok_vdiff    ! activate vertical diffusion of TKE or not
-! logical :: atke_ok_virtual  ! account for vapor for flottability
-
-! real :: kappa = 0.4         ! Von Karman constant
-! real :: cn                  ! Sm value at Ri=0
-! real :: cinf                ! Sm value at Ri=-Inf
-! real :: ri0                 ! Richardson number near zero to guarantee continuity in slope of Sm (stability function) at Ri=0
-! real :: ri1                 ! Richardson number near zero to guarantee continuity in slope of Pr (Prandlt's number) at Ri=0
-! real :: lmin                ! minimum mixing length corresponding to the Kolmogov dissipation scale  in planetary atmospheres (Chen et al 2016, JGR Atmos)
-! real :: ctkes               ! coefficient for surface TKE
-! real :: clmixshear          ! coefficient for mixing length depending on local wind shear
-
-! Tunable parameters for the ATKE scheme and their range of values
-!!-------------------------------------------------------------------------------------------------------------
-! real :: cepsilon            ! controls the value of the dissipation length scale, range [1.2 - 10]
-! real :: cke                 ! controls the value of the diffusion coefficient of TKE, range [1 - 5]
-! real :: l0                  ! asymptotic mixing length far from the ground [m] (Sun et al 2011, JAMC), range [15 - 75]
-! real :: clmix               ! controls the value of the mixing length in stratified conditions, range [0.1 - 2]
-! real :: ric                 ! critical Richardson number controlling the slope of Sm in stable conditions, range [0.19 - 0.25]
-! real :: smmin               ! minimum value of Sm in very stable conditions (defined here as minsqrt(Ez/Ek)) at large Ri, range [0.025 - 0.1]
-! real :: pr_neut             ! neutral value of the Prandtl number (Ri=0), range [0.7 - 1]
-! real :: pr_slope            ! linear slope of Pr with Ri in the very stable regime, range [3 - 5]
-! real :: cinffac             ! ratio between cinf and cn controlling the convective limit of Sm, range [1.2 - 5.0]
-! real :: pr_asym             ! value of Prandlt in the convective limit(Ri=-Inf), range [0.3 - 0.5]
-!!-------------------------------------------------------------------------------------------------------------
-
-implicit none
-
-
-! Declarations:
-!=============
-
-INTEGER, INTENT(IN) :: ngrid ! number of horizontal index (flat grid)
-INTEGER, INTENT(IN) :: nlay  ! number of vertical index  
-
-REAL, INTENT(IN)    :: dtime ! physics time step (s)
-REAL, DIMENSION(ngrid,nlay), INTENT(IN)       :: wind_u   ! zonal velocity (m/s)
-REAL, DIMENSION(ngrid,nlay), INTENT(IN)       :: wind_v   ! meridional velocity (m/s)
-REAL, DIMENSION(ngrid,nlay), INTENT(IN)       :: temp     ! temperature (K)
-REAL, DIMENSION(ngrid,nlay), INTENT(IN)       :: qvap     ! specific humidity (kg/kg)
-REAL, DIMENSION(ngrid,nlay), INTENT(IN)       :: play     ! pressure (Pa)
-REAL, DIMENSION(ngrid,nlay+1), INTENT(IN)     :: pinterf  ! pressure at interfaces(Pa)
-REAL, DIMENSION(ngrid), INTENT(IN)            :: cdrag_uv ! surface drag coefficient for momentum
-
-REAL, DIMENSION(ngrid,nlay+1), INTENT(INOUT)  :: tke      ! turbulent kinetic energy at interface between layers (m2/s2)
-
-REAL, DIMENSION(ngrid,nlay+1), INTENT(OUT)    :: eps      ! output: TKE dissipation rate at interface between layers (m2/s3)
-REAL, DIMENSION(ngrid,nlay+1), INTENT(OUT)    :: tke_shear! output: TKE shear production rate (m2/s3)
-REAL, DIMENSION(ngrid,nlay+1), INTENT(OUT)    :: tke_buoy ! output: TKE buoyancy production rate (m2/s3)
-REAL, DIMENSION(ngrid,nlay+1), INTENT(OUT)    :: tke_trans! output: TKE transport (diffusion) term (m2/s3)
-REAL, DIMENSION(ngrid,nlay), INTENT(OUT)      :: Km_out   ! output: Exchange coefficient for momentum at interface between layers (m2/s)
-REAL, DIMENSION(ngrid,nlay), INTENT(OUT)      :: Kh_out   ! output: Exchange coefficient for heat flux at interface between layers (m2/s)
-
-! Local variables
-REAL, DIMENSION(ngrid,nlay+1) :: Km          ! Exchange coefficient for momentum at interface between layers
-REAL, DIMENSION(ngrid,nlay+1) :: Kh          ! Exchange coefficient for heat flux at interface between layers
-REAL, DIMENSION(ngrid,nlay)   :: theta       ! Potential temperature
-REAL, DIMENSION(ngrid,nlay+1) :: l_exchange  ! Length of exchange (at interface)
-REAL, DIMENSION(ngrid,nlay+1) :: z_interf    ! Altitude at the interface
-REAL, DIMENSION(ngrid,nlay)   :: z_lay       ! Altitude of layers
-REAL, DIMENSION(ngrid,nlay)   :: dz_interf   ! distance between two consecutive interfaces
-REAL, DIMENSION(ngrid,nlay)   :: dz_lay      ! distance between two layer middles (NB: first and last are half layers)
-REAL, DIMENSION(ngrid,nlay+1) :: N2          ! square of Brunt Vaisala pulsation (at interface)
-REAL, DIMENSION(ngrid,nlay+1) :: shear2      ! square of wind shear (at interface)
-REAL, DIMENSION(ngrid,nlay+1) :: Ri          ! Richardson's number (at interface)
-REAL, DIMENSION(ngrid,nlay+1) :: Prandtl     ! Turbulent Prandtl's number (at interface)
-REAL, DIMENSION(ngrid,nlay+1) :: Sm          ! Stability function for momentum (at interface)
-REAL, DIMENSION(ngrid,nlay+1) :: Sh          ! Stability function for heat (at interface)
-
-INTEGER :: igrid,ilay ! horizontal,vertical index (flat grid)
-REAL    :: preff      ! reference pressure for potential temperature calculations
-REAL    :: thetam     ! mean potential temperature at interface
-REAL    :: delta      ! discriminant of the second order polynomial
-REAL    :: qq         ! tke=qq**2/2
-REAL    :: shear      ! wind shear
-REAL    :: lstrat     ! mixing length depending on local stratification
-REAL    :: taustrat   ! caracteristic timescale for turbulence in very stable conditions
-REAL    :: netloss    ! net loss term of tke
-REAL    :: netsource  ! net source term of tke
-REAL    :: ustar      ! friction velocity estimation
-REAL    :: invtau     
-REAL    :: rvap
-
-! Initializations:
-!================
-
-DO igrid=1,ngrid
-    dz_interf(igrid,1) = 0.0
-    z_interf(igrid,1) = 0.0
-END DO
-
-! Calculation of potential temperature: (if vapor -> virtual potential temperature)
-!=====================================
-
-preff=100000.
-! results should not depend on the choice of preff
-DO ilay=1,nlay
-    DO igrid = 1, ngrid
-        theta(igrid,ilay)=temp(igrid,ilay)*(preff/play(igrid,ilay))**(rd/rcpd)
-    END DO
-END DO
-
-! account for water vapor mass for buoyancy calculation
-IF (atke_ok_virtual) THEN
-    DO ilay=1,nlay
-        DO igrid = 1, ngrid
-            rvap=max(0.,qvap(igrid,ilay)/(1.-qvap(igrid,ilay)))
-            theta(igrid,ilay)=theta(igrid,ilay)*(1.+rvap/(RD/RV))/(1.+rvap)
-        END DO
-    END DO
-ENDIF
-
-
-! Calculation of altitude of layers' middle and bottom interfaces:
-!=================================================================
-
-DO ilay=2,nlay+1
-    DO igrid=1,ngrid
-        dz_interf(igrid,ilay-1) = rd*temp(igrid,ilay-1)/rg/play(igrid,ilay-1)*(pinterf(igrid,ilay-1)-pinterf(igrid,ilay))
-        z_interf(igrid,ilay) = z_interf(igrid,ilay-1) + dz_interf(igrid,ilay-1)
-    ENDDO
-ENDDO
-
-DO ilay=1,nlay
-    DO igrid=1,ngrid 
-        z_lay(igrid,ilay)=0.5*(z_interf(igrid, ilay+1) + z_interf(igrid, ilay))
-    ENDDO
-ENDDO
-
-
-! Computes the gradient Richardson's number and stability functions:
-!===================================================================
-
-DO ilay=2,nlay
-    DO igrid=1,ngrid
-        dz_lay(igrid,ilay)=z_lay(igrid,ilay)-z_lay(igrid,ilay-1)
-        thetam=0.5*(theta(igrid,ilay) + theta(igrid,ilay-1))
-        N2(igrid,ilay) = rg * (theta(igrid,ilay) - theta(igrid,ilay-1))/thetam / dz_lay(igrid,ilay)
-        shear2(igrid,ilay)= (((wind_u(igrid,ilay) - wind_u(igrid,ilay-1)) / dz_lay(igrid,ilay))**2 + &
-            ((wind_v(igrid,ilay) - wind_v(igrid,ilay-1)) / dz_lay(igrid,ilay))**2 )
-        Ri(igrid,ilay) = N2(igrid,ilay) / MAX(shear2(igrid,ilay),1E-10) 
-        
-        IF (Ri(igrid,ilay) < 0.) THEN ! unstable cases
-            Sm(igrid,ilay) = 2./rpi * (cinf-cn) * atan(-Ri(igrid,ilay)/Ri0) + cn
-            Prandtl(igrid,ilay) = -2./rpi * (pr_asym - pr_neut) * atan(Ri(igrid,ilay)/Ri1) + pr_neut 
-        ELSE ! stable cases
-            Sm(igrid,ilay) = max(smmin,cn*(1.-Ri(igrid,ilay)/Ric))
-            ! prandlt expression from venayagamoorthy and stretch 2010, Li et al 2019
-            Prandtl(igrid,ilay) = pr_neut*exp(-pr_slope/pr_neut*Ri(igrid,ilay)+Ri(igrid,ilay)/pr_neut) &
-                                + Ri(igrid,ilay) * pr_slope
-            IF (Ri(igrid,ilay) .GE. Prandtl(igrid,ilay)) THEN
-                call abort_physic("atke_compute_km_kh", &
-                'Ri>=Pr in stable conditions -> violates energy conservation principles, change pr_neut or slope', 1)
-            ENDIF
-        END IF
-        
-        Sh(igrid,ilay) = Sm(igrid,ilay) / Prandtl(igrid,ilay)
-
-    ENDDO
-ENDDO
-
-
-! Computing the mixing length:
-!==============================================================
-
-
-IF (iflag_atke_lmix .EQ. 1 ) THEN
-    ! Blackadar formulation (~kappa l) + buoyancy length scale (Deardoff 1980) for very stable conditions
-        DO ilay=2,nlay
-            DO igrid=1,ngrid
-                l_exchange(igrid,ilay) = kappa*l0*z_interf(igrid,ilay) / (kappa*z_interf(igrid,ilay) + l0)
-                IF (N2(igrid,ilay) .GT. 0.) THEN
-                    lstrat=clmix*sqrt(tke(igrid,ilay))/sqrt(N2(igrid,ilay))
-                    lstrat=max(lstrat,lmin)
-                    !Inverse interpolation, Van de Wiel et al. 2010
-                    l_exchange(igrid,ilay)=(1./(l_exchange(igrid,ilay))+1./(lstrat))**(-1.0)
-                ENDIF 
-            ENDDO
-        ENDDO
-
-    ELSE IF (iflag_atke_lmix .EQ. 2 ) THEN
-    ! add effect of wind shear on lstrat following grisogono and belusic 2008, qjrms
-    ! implies 2 tuning coefficients clmix and clmixshear
-    DO ilay=2,nlay
-        DO igrid=1,ngrid
-            l_exchange(igrid,ilay) = kappa*l0*z_interf(igrid,ilay) / (kappa*z_interf(igrid,ilay) + l0)
-            IF (N2(igrid,ilay) .GT. 0. .AND. shear2(igrid,ilay) .GT. 0.) THEN
-                lstrat=min(clmix*sqrt(tke(igrid,ilay))/sqrt(N2(igrid,ilay)), &
-                    clmixshear*sqrt(tke(igrid,ilay))/sqrt(shear2(igrid,ilay)))
-                lstrat=max(lstrat,lmin)
-                !Inverse interpolation, Van de Wiel et al. 2010   
-                l_exchange(igrid,ilay)=(1./(l_exchange(igrid,ilay))+1./(lstrat))**(-1.0)
-            ENDIF
-        ENDDO
-    ENDDO
-
-    ELSE IF (iflag_atke_lmix .EQ. 3 ) THEN
-    ! add effect of wind shear on lstrat following grisogono 2010, qjrms
-    ! keeping a single tuning coefficient clmix
-    DO ilay=2,nlay
-        DO igrid=1,ngrid
-            l_exchange(igrid,ilay) = kappa*l0*z_interf(igrid,ilay) / (kappa*z_interf(igrid,ilay) + l0)
-            IF (N2(igrid,ilay) .GT. 0. .AND. shear2(igrid,ilay) .GT. 0.) THEN
-                lstrat=clmix*sqrt(tke(igrid,ilay))/sqrt(shear2(igrid,ilay))*(1.0+Ri(igrid,ilay)/(2.*Prandtl(igrid,ilay)))
-                lstrat=max(lstrat,lmin)
-                !Inverse interpolation, Van de Wiel et al. 2010   
-                l_exchange(igrid,ilay)=(1./(l_exchange(igrid,ilay))+1./(lstrat))**(-1.0)
-            ENDIF
-        ENDDO
-    ENDDO
-
-ELSE
-    ! default Blackadar formulation: neglect effect of local stratification and shear
-    DO ilay=2,nlay+1
-        DO igrid=1,ngrid
-            l_exchange(igrid,ilay) = kappa*l0*z_interf(igrid,ilay) / (kappa*z_interf(igrid,ilay) + l0)
-        ENDDO
-    ENDDO
-ENDIF
-
-
-! Computing the TKE k>=2:
-!========================
-IF (iflag_atke == 0) THEN
-
-    ! stationary solution (dtke/dt=0)
-
-    DO ilay=2,nlay
-            DO igrid=1,ngrid
-                tke(igrid,ilay) = cepsilon * l_exchange(igrid,ilay)**2 * Sm(igrid,ilay) * &
-                shear2(igrid,ilay) * (1. - Ri(igrid,ilay) / Prandtl(igrid,ilay))
-                eps(igrid,ilay) = (tke(igrid,ilay)**(3./2))/(cepsilon*l_exchange(igrid,ilay))
-                tke_shear(igrid,ilay)=l_exchange(igrid,ilay)*Sm(igrid,ilay)*sqrt(tke(igrid,ilay))*shear2(igrid,ilay) 
-                tke_buoy(igrid,ilay)=-l_exchange(igrid,ilay)*Sm(igrid,ilay)*sqrt(tke(igrid,ilay))*shear2(igrid,ilay) &
-                                    *(Ri(igrid,ilay) / Prandtl(igrid,ilay))
-            ENDDO
-        ENDDO
-
-ELSE IF (iflag_atke == 1) THEN
-
-    ! full implicit scheme resolved with a second order polynomial equation
-    ! default solution which shows fair convergence properties
-        DO ilay=2,nlay
-            DO igrid=1,ngrid
-            qq=max(sqrt(2.*tke(igrid,ilay)),1.e-10)
-            delta=(2.*sqrt(2.)*cepsilon*l_exchange(igrid,ilay)/dtime)**2. &
-                    +4.*(2.*sqrt(2.)*cepsilon*l_exchange(igrid,ilay)/dtime*qq + &
-                    2.*l_exchange(igrid,ilay)*l_exchange(igrid,ilay)*cepsilon*Sm(igrid,ilay) &
-                    *shear2(igrid,ilay) * (1. - Ri(igrid,ilay) / Prandtl(igrid,ilay)))
-            qq=(-2.*sqrt(2.)*cepsilon*l_exchange(igrid,ilay)/dtime + sqrt(delta))/2.
-            qq=max(0.,qq)
-            tke(igrid,ilay)=0.5*(qq**2)
-            eps(igrid,ilay) = (tke(igrid,ilay)**(3./2))/(cepsilon*l_exchange(igrid,ilay))
-            tke_shear(igrid,ilay)=l_exchange(igrid,ilay)*Sm(igrid,ilay)*sqrt(tke(igrid,ilay))*shear2(igrid,ilay)
-            tke_buoy(igrid,ilay)=-l_exchange(igrid,ilay)*Sm(igrid,ilay)*sqrt(tke(igrid,ilay))*shear2(igrid,ilay) &
-                                *(Ri(igrid,ilay) / Prandtl(igrid,ilay)) 
-            ENDDO
-        ENDDO
-
-
-ELSE IF (iflag_atke == 2) THEN
-
-    ! semi implicit scheme when l does not depend on tke
-    ! positive-guaranteed if pr slope in stable condition >1
-
-    DO ilay=2,nlay
-            DO igrid=1,ngrid
-            qq=max(sqrt(2.*tke(igrid,ilay)),1.e-10)
-            qq=(qq+l_exchange(igrid,ilay)*Sm(igrid,ilay)*dtime/sqrt(2.)      & 
-                *shear2(igrid,ilay)*(1.-Ri(igrid,ilay)/Prandtl(igrid,ilay))) &
-                /(1.+qq*dtime/(cepsilon*l_exchange(igrid,ilay)*2.*sqrt(2.)))
-            tke_shear(igrid,ilay)=l_exchange(igrid,ilay)*Sm(igrid,ilay)*qq/sqrt(2.)*shear2(igrid,ilay)
-            tke_buoy(igrid,ilay)=-l_exchange(igrid,ilay)*Sm(igrid,ilay)*qq/sqrt(2.)*shear2(igrid,ilay) &
-                                *(Ri(igrid,ilay) / Prandtl(igrid,ilay)) 
-            tke(igrid,ilay)=0.5*(qq**2) 
-            eps(igrid,ilay) = (tke(igrid,ilay)**(3./2))/(cepsilon*l_exchange(igrid,ilay))
-            ENDDO
-        ENDDO
-
-
-ELSE IF (iflag_atke == 3) THEN
-    ! numerical resolution adapted from that in MAR (Deleersnijder 1992)
-    ! positively defined by construction
-
-        DO ilay=2,nlay
-            DO igrid=1,ngrid
-            eps(igrid,ilay) = (tke(igrid,ilay)**(3./2))/(cepsilon*l_exchange(igrid,ilay))
-            qq=max(sqrt(2.*tke(igrid,ilay)),1.e-10)
-            tke_shear(igrid,ilay)=l_exchange(igrid,ilay)*Sm(igrid,ilay)*qq/sqrt(2.)*shear2(igrid,ilay)
-            tke_buoy(igrid,ilay)=-l_exchange(igrid,ilay)*Sm(igrid,ilay)*qq/sqrt(2.)*shear2(igrid,ilay) &
-                                *(Ri(igrid,ilay) / Prandtl(igrid,ilay))
-            IF (Ri(igrid,ilay) .LT. 0.) THEN
-                netloss=qq/(2.*sqrt(2.)*cepsilon*l_exchange(igrid,ilay))
-                netsource=l_exchange(igrid,ilay)*Sm(igrid,ilay)/sqrt(2.)*shear2(igrid,ilay)*(1.-Ri(igrid,ilay)/Prandtl(igrid,ilay))
-            ELSE
-                netloss=qq/(2.*sqrt(2.)*cepsilon*l_exchange(igrid,ilay))+ &
-                        l_exchange(igrid,ilay)*Sm(igrid,ilay)/sqrt(2.)*N2(igrid,ilay)/Prandtl(igrid,ilay)
-                netsource=l_exchange(igrid,ilay)*Sm(igrid,ilay)/sqrt(2.)*shear2(igrid,ilay)
-            ENDIF
-            qq=((qq**2)/dtime+qq*netsource)/(qq/dtime+netloss)
-            tke(igrid,ilay)=0.5*(qq**2)
-            ENDDO
-        ENDDO
-
-ELSE IF (iflag_atke == 4) THEN
-    ! semi implicit scheme from Arpege (V. Masson methodology with 
-    ! Taylor expansion of the dissipation term)
-        DO ilay=2,nlay
-            DO igrid=1,ngrid
-            qq=max(sqrt(2.*tke(igrid,ilay)),1.e-10)
-            tke_shear(igrid,ilay)=l_exchange(igrid,ilay)*Sm(igrid,ilay)*qq/sqrt(2.)*shear2(igrid,ilay)
-            tke_buoy(igrid,ilay)=-l_exchange(igrid,ilay)*Sm(igrid,ilay)*qq/sqrt(2.)*shear2(igrid,ilay) &
-                                *(Ri(igrid,ilay) / Prandtl(igrid,ilay))
-            qq=(l_exchange(igrid,ilay)*Sm(igrid,ilay)/sqrt(2.)*shear2(igrid,ilay)*(1.-Ri(igrid,ilay)/Prandtl(igrid,ilay)) &
-                +qq*(1.+dtime*qq/(cepsilon*l_exchange(igrid,ilay)*2.*sqrt(2.)))) &
-                /(1.+2.*qq*dtime/(cepsilon*l_exchange(igrid,ilay)*2.*sqrt(2.)))
-            qq=max(0.,qq)
-            tke(igrid,ilay)=0.5*(qq**2)
-            eps(igrid,ilay) = (tke(igrid,ilay)**(3./2))/(cepsilon*l_exchange(igrid,ilay))
-            ENDDO
-        ENDDO
-
-
-ELSE
-    call abort_physic("atke_compute_km_kh", &
-        'numerical treatment of TKE not possible yet', 1)
-
-END IF
-
-! We impose a 0 tke at nlay+1
-!==============================
-
-DO igrid=1,ngrid
-    tke(igrid,nlay+1)=0.
-    eps(igrid,nlay+1)=0.
-    tke_shear(igrid,nlay+1)=0.
-    tke_buoy(igrid,nlay+1)=0.
-END DO
-
-
-! Calculation of surface TKE (k=1)
-!=================================
-! surface TKE calculation inspired from what is done in Arpege (see E. Bazile note)
-DO igrid=1,ngrid
-    ustar=sqrt(cdrag_uv(igrid)*(wind_u(igrid,1)**2+wind_v(igrid,1)**2))
-    tke(igrid,1)=ctkes*(ustar**2)
-    eps(igrid,1)=0. ! arbitrary as TKE is not properly defined at the surface
-    tke_shear(igrid,1)=0.
-    tke_buoy(igrid,1)=0.
-END DO
-
-
-! vertical diffusion of TKE 
-!==========================
-tke_trans(:,:)=0.
-IF (atke_ok_vdiff) THEN
-    CALL atke_vdiff_tke(ngrid,nlay,dtime,z_lay,z_interf,temp,play,l_exchange,Sm,tke,tke_trans)
-ENDIF
-
-
-! Computing eddy diffusivity coefficients:
-!========================================
-DO ilay=2,nlay ! TODO: also calculate for nlay+1 ?
-    DO igrid=1,ngrid
-        ! we add the molecular viscosity to Km,h 
-        Km(igrid,ilay) = viscom + l_exchange(igrid,ilay) * Sm(igrid,ilay) * tke(igrid,ilay)**0.5
-        Kh(igrid,ilay) = viscoh + l_exchange(igrid,ilay) * Sh(igrid,ilay) * tke(igrid,ilay)**0.5
-    END DO
-END DO
-
-! for output:
-!===========
-Km_out(1:ngrid,2:nlay)=Km(1:ngrid,2:nlay)
-Kh_out(1:ngrid,2:nlay)=Kh(1:ngrid,2:nlay)
-
-end subroutine atke_compute_km_kh
-
-!===============================================================================================
-subroutine atke_vdiff_tke(ngrid,nlay,dtime,z_lay,z_interf,temp,play,l_exchange,Sm,tke,tke_trans)
-
-! routine that computes the vertical diffusion of TKE by the turbulence
-! using an implicit resolution (See note by Dufresne and Ghattas (2009))
-! E Vignon, July 2023
-
-USE lmdz_atke_turbulence_ini, ONLY : rd, cke, viscom
-
-
-INTEGER, INTENT(IN) :: ngrid ! number of horizontal index (flat grid)
-INTEGER, INTENT(IN) :: nlay  ! number of vertical index  
-
-REAL, INTENT(IN)    :: dtime ! physics time step (s)
-REAL, DIMENSION(ngrid,nlay), INTENT(IN)       :: z_lay   ! altitude of mid-layers (m)
-REAL, DIMENSION(ngrid,nlay+1), INTENT(IN)       :: z_interf   ! altitude of bottom interfaces (m)
-REAL, DIMENSION(ngrid,nlay), INTENT(IN)       :: temp   ! temperature (K)
-REAL, DIMENSION(ngrid,nlay), INTENT(IN)       :: play   ! pressure (Pa)
-REAL, DIMENSION(ngrid,nlay+1), INTENT(IN)     :: l_exchange     ! mixing length at interfaces between layers
-REAL, DIMENSION(ngrid,nlay+1), INTENT(IN)     :: Sm     ! stability function for eddy diffusivity for momentum at interface between layers
-
-REAL, DIMENSION(ngrid,nlay+1), INTENT(INOUT)  :: tke    ! turbulent kinetic energy at interface between layers
-REAL, DIMENSION(ngrid,nlay+1), INTENT(INOUT)  :: tke_trans ! turbulent kinetic energy transport term (m2/s3)
-
-
-INTEGER                                       :: igrid,ilay
-REAL, DIMENSION(ngrid,nlay+1)                 :: Ke     ! eddy diffusivity for TKE
-REAL, DIMENSION(ngrid,nlay+1)                 :: dtke
-REAL, DIMENSION(ngrid,nlay+1)                 :: ak, bk, ck, CCK, DDK
-REAL                                          :: gammak,Kem,KKb,KKt
-
-
-! Few initialisations
-CCK(:,:)=0.
-DDK(:,:)=0.
-dtke(:,:)=0.
-
-
-! Eddy diffusivity for TKE
-
-DO ilay=2,nlay
-    DO igrid=1,ngrid
-        Ke(igrid,ilay)=(viscom+l_exchange(igrid,ilay)*Sm(igrid,ilay)*sqrt(tke(igrid,ilay)))*cke 
-    ENDDO
-ENDDO
-! at the top of the atmosphere set to 0
-Ke(:,nlay+1)=0.
-! at the surface, set it equal to that at the first model level
-Ke(:,1)=Ke(:,2)
-
-
-! calculate intermediary variables
-
-DO ilay=2,nlay 
-    DO igrid=1,ngrid
-    Kem=0.5*(Ke(igrid,ilay+1)+Ke(igrid,ilay))    
-    KKt=Kem*play(igrid,ilay)/rd/temp(igrid,ilay)/(z_interf(igrid,ilay+1)-z_interf(igrid,ilay))
-    Kem=0.5*(Ke(igrid,ilay)+Ke(igrid,ilay-1))
-    KKb=Kem*play(igrid,ilay-1)/rd/temp(igrid,ilay-1)/(z_interf(igrid,ilay)-z_interf(igrid,ilay-1))
-    gammak=1./(z_lay(igrid,ilay)-z_lay(igrid,ilay-1))
-    ak(igrid,ilay)=-gammak*dtime*KKb
-    ck(igrid,ilay)=-gammak*dtime*KKt
-    bk(igrid,ilay)=1.+gammak*dtime*(KKt+KKb)
-    ENDDO
-ENDDO
-
-! calculate CCK and DDK coefficients
-! downhill phase
-
-DO igrid=1,ngrid
-    CCK(igrid,nlay)=tke(igrid,nlay)/bk(igrid,nlay)
-    DDK(igrid,nlay)=-ak(igrid,nlay)/bk(igrid,nlay)
-ENDDO
-
-
-DO ilay=nlay-1,2,-1
-    DO igrid=1,ngrid
-        CCK(igrid,ilay)=(tke(igrid,ilay)/bk(igrid,ilay)-ck(igrid,ilay)/bk(igrid,ilay)*CCK(igrid,ilay+1)) &
-                        / (1.+ck(igrid,ilay)/bk(igrid,ilay)*DDK(igrid,ilay+1))
-        DDK(igrid,ilay)=-ak(igrid,ilay)/bk(igrid,ilay)/(1+ck(igrid,ilay)/bk(igrid,ilay)*DDK(igrid,ilay+1))
-    ENDDO
-ENDDO
-
-! calculate TKE
-! uphill phase
-
-DO ilay=2,nlay+1
-    DO igrid=1,ngrid
-        dtke(igrid,ilay)=CCK(igrid,ilay)+DDK(igrid,ilay)*tke(igrid,ilay-1)-tke(igrid,ilay)
-    ENDDO
-ENDDO
-
-! update TKE
-tke(:,:)=tke(:,:)+dtke(:,:)
-tke_trans(:,:)=dtke(:,:)/dtime
-
-
-end subroutine atke_vdiff_tke
-
-
-
-end module lmdz_atke_exchange_coeff
Index: /LMDZ6/trunk/libf/phylmd/lmdz_atke_exchange_coeff.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/lmdz_atke_exchange_coeff.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/lmdz_atke_exchange_coeff.f90	(revision 5268)
@@ -0,0 +1,512 @@
+module lmdz_atke_exchange_coeff
+
+implicit none
+
+contains 
+
+subroutine atke_compute_km_kh(ngrid,nlay,dtime, &
+                        wind_u,wind_v,temp,qvap,play,pinterf,cdrag_uv, &
+                        tke,eps,tke_shear,tke_buoy,tke_trans,Km_out,Kh_out)
+
+!========================================================================
+! Routine that computes turbulent Km / Kh coefficients with a
+! 1.5 order closure scheme (TKE) with or without stationarity assumption
+!
+! This parameterization has been constructed in the framework of a
+! collective and collaborative workshop, 
+! the so-called 'Atelier TKE (ATKE)' with
+! K. Arjdal, L. Raillard, C. Dehondt, P. Tiengou, A. Spiga, F. Cheruy, T Dubos, 
+! M. Coulon-Decorzens, S. Fromang, G. Riviere, A. Sima, F. Hourdin, E. Vignon
+!
+! Main assumptions of the model :
+! (1) horizontal homogeneity (Dx=Dy=0.)
+!=======================================================================
+
+USE lmdz_atke_turbulence_ini, ONLY : iflag_atke, kappa, l0, ric, cinf, rpi, rcpd, atke_ok_virtual, ri0, ri1
+USE lmdz_atke_turbulence_ini, ONLY : cepsilon, pr_slope, pr_asym, pr_neut, ctkes, rg, rd, rv, atke_ok_vdiff
+USE lmdz_atke_turbulence_ini, ONLY : viscom, viscoh, clmix, clmixshear, iflag_atke_lmix, lmin, smmin, cn
+
+!!-------------------------------------------------------------------------------------------------------------
+! integer :: iflag_atke        ! flag that controls options in atke_compute_km_kh
+! integer :: iflag_atke_lmix   ! flag that controls the calculation of mixing length in atke
+! integer :: iflag_num_atke    ! flag that controls the numerical treatment of diffusion coeffiient calculation
+
+! logical :: atke_ok_vdiff    ! activate vertical diffusion of TKE or not
+! logical :: atke_ok_virtual  ! account for vapor for flottability
+
+! real :: kappa = 0.4         ! Von Karman constant
+! real :: cn                  ! Sm value at Ri=0
+! real :: cinf                ! Sm value at Ri=-Inf
+! real :: ri0                 ! Richardson number near zero to guarantee continuity in slope of Sm (stability function) at Ri=0
+! real :: ri1                 ! Richardson number near zero to guarantee continuity in slope of Pr (Prandlt's number) at Ri=0
+! real :: lmin                ! minimum mixing length corresponding to the Kolmogov dissipation scale  in planetary atmospheres (Chen et al 2016, JGR Atmos)
+! real :: ctkes               ! coefficient for surface TKE
+! real :: clmixshear          ! coefficient for mixing length depending on local wind shear
+
+! Tunable parameters for the ATKE scheme and their range of values
+!!-------------------------------------------------------------------------------------------------------------
+! real :: cepsilon            ! controls the value of the dissipation length scale, range [1.2 - 10]
+! real :: cke                 ! controls the value of the diffusion coefficient of TKE, range [1 - 5]
+! real :: l0                  ! asymptotic mixing length far from the ground [m] (Sun et al 2011, JAMC), range [15 - 75]
+! real :: clmix               ! controls the value of the mixing length in stratified conditions, range [0.1 - 2]
+! real :: ric                 ! critical Richardson number controlling the slope of Sm in stable conditions, range [0.19 - 0.25]
+! real :: smmin               ! minimum value of Sm in very stable conditions (defined here as minsqrt(Ez/Ek)) at large Ri, range [0.025 - 0.1]
+! real :: pr_neut             ! neutral value of the Prandtl number (Ri=0), range [0.7 - 1]
+! real :: pr_slope            ! linear slope of Pr with Ri in the very stable regime, range [3 - 5]
+! real :: cinffac             ! ratio between cinf and cn controlling the convective limit of Sm, range [1.2 - 5.0]
+! real :: pr_asym             ! value of Prandlt in the convective limit(Ri=-Inf), range [0.3 - 0.5]
+!!-------------------------------------------------------------------------------------------------------------
+
+implicit none
+
+
+! Declarations:
+!=============
+
+INTEGER, INTENT(IN) :: ngrid ! number of horizontal index (flat grid)
+INTEGER, INTENT(IN) :: nlay  ! number of vertical index  
+
+REAL, INTENT(IN)    :: dtime ! physics time step (s)
+REAL, DIMENSION(ngrid,nlay), INTENT(IN)       :: wind_u   ! zonal velocity (m/s)
+REAL, DIMENSION(ngrid,nlay), INTENT(IN)       :: wind_v   ! meridional velocity (m/s)
+REAL, DIMENSION(ngrid,nlay), INTENT(IN)       :: temp     ! temperature (K)
+REAL, DIMENSION(ngrid,nlay), INTENT(IN)       :: qvap     ! specific humidity (kg/kg)
+REAL, DIMENSION(ngrid,nlay), INTENT(IN)       :: play     ! pressure (Pa)
+REAL, DIMENSION(ngrid,nlay+1), INTENT(IN)     :: pinterf  ! pressure at interfaces(Pa)
+REAL, DIMENSION(ngrid), INTENT(IN)            :: cdrag_uv ! surface drag coefficient for momentum
+
+REAL, DIMENSION(ngrid,nlay+1), INTENT(INOUT)  :: tke      ! turbulent kinetic energy at interface between layers (m2/s2)
+
+REAL, DIMENSION(ngrid,nlay+1), INTENT(OUT)    :: eps      ! output: TKE dissipation rate at interface between layers (m2/s3)
+REAL, DIMENSION(ngrid,nlay+1), INTENT(OUT)    :: tke_shear! output: TKE shear production rate (m2/s3)
+REAL, DIMENSION(ngrid,nlay+1), INTENT(OUT)    :: tke_buoy ! output: TKE buoyancy production rate (m2/s3)
+REAL, DIMENSION(ngrid,nlay+1), INTENT(OUT)    :: tke_trans! output: TKE transport (diffusion) term (m2/s3)
+REAL, DIMENSION(ngrid,nlay), INTENT(OUT)      :: Km_out   ! output: Exchange coefficient for momentum at interface between layers (m2/s)
+REAL, DIMENSION(ngrid,nlay), INTENT(OUT)      :: Kh_out   ! output: Exchange coefficient for heat flux at interface between layers (m2/s)
+
+! Local variables
+REAL, DIMENSION(ngrid,nlay+1) :: Km          ! Exchange coefficient for momentum at interface between layers
+REAL, DIMENSION(ngrid,nlay+1) :: Kh          ! Exchange coefficient for heat flux at interface between layers
+REAL, DIMENSION(ngrid,nlay)   :: theta       ! Potential temperature
+REAL, DIMENSION(ngrid,nlay+1) :: l_exchange  ! Length of exchange (at interface)
+REAL, DIMENSION(ngrid,nlay+1) :: z_interf    ! Altitude at the interface
+REAL, DIMENSION(ngrid,nlay)   :: z_lay       ! Altitude of layers
+REAL, DIMENSION(ngrid,nlay)   :: dz_interf   ! distance between two consecutive interfaces
+REAL, DIMENSION(ngrid,nlay)   :: dz_lay      ! distance between two layer middles (NB: first and last are half layers)
+REAL, DIMENSION(ngrid,nlay+1) :: N2          ! square of Brunt Vaisala pulsation (at interface)
+REAL, DIMENSION(ngrid,nlay+1) :: shear2      ! square of wind shear (at interface)
+REAL, DIMENSION(ngrid,nlay+1) :: Ri          ! Richardson's number (at interface)
+REAL, DIMENSION(ngrid,nlay+1) :: Prandtl     ! Turbulent Prandtl's number (at interface)
+REAL, DIMENSION(ngrid,nlay+1) :: Sm          ! Stability function for momentum (at interface)
+REAL, DIMENSION(ngrid,nlay+1) :: Sh          ! Stability function for heat (at interface)
+
+INTEGER :: igrid,ilay ! horizontal,vertical index (flat grid)
+REAL    :: preff      ! reference pressure for potential temperature calculations
+REAL    :: thetam     ! mean potential temperature at interface
+REAL    :: delta      ! discriminant of the second order polynomial
+REAL    :: qq         ! tke=qq**2/2
+REAL    :: shear      ! wind shear
+REAL    :: lstrat     ! mixing length depending on local stratification
+REAL    :: taustrat   ! caracteristic timescale for turbulence in very stable conditions
+REAL    :: netloss    ! net loss term of tke
+REAL    :: netsource  ! net source term of tke
+REAL    :: ustar      ! friction velocity estimation
+REAL    :: invtau     
+REAL    :: rvap
+
+! Initializations:
+!================
+
+DO igrid=1,ngrid
+    dz_interf(igrid,1) = 0.0
+    z_interf(igrid,1) = 0.0
+END DO
+
+! Calculation of potential temperature: (if vapor -> virtual potential temperature)
+!=====================================
+
+preff=100000.
+! results should not depend on the choice of preff
+DO ilay=1,nlay
+    DO igrid = 1, ngrid
+        theta(igrid,ilay)=temp(igrid,ilay)*(preff/play(igrid,ilay))**(rd/rcpd)
+    END DO
+END DO
+
+! account for water vapor mass for buoyancy calculation
+IF (atke_ok_virtual) THEN
+    DO ilay=1,nlay
+        DO igrid = 1, ngrid
+            rvap=max(0.,qvap(igrid,ilay)/(1.-qvap(igrid,ilay)))
+            theta(igrid,ilay)=theta(igrid,ilay)*(1.+rvap/(RD/RV))/(1.+rvap)
+        END DO
+    END DO
+ENDIF
+
+
+! Calculation of altitude of layers' middle and bottom interfaces:
+!=================================================================
+
+DO ilay=2,nlay+1
+    DO igrid=1,ngrid
+        dz_interf(igrid,ilay-1) = rd*temp(igrid,ilay-1)/rg/play(igrid,ilay-1)*(pinterf(igrid,ilay-1)-pinterf(igrid,ilay))
+        z_interf(igrid,ilay) = z_interf(igrid,ilay-1) + dz_interf(igrid,ilay-1)
+    ENDDO
+ENDDO
+
+DO ilay=1,nlay
+    DO igrid=1,ngrid 
+        z_lay(igrid,ilay)=0.5*(z_interf(igrid, ilay+1) + z_interf(igrid, ilay))
+    ENDDO
+ENDDO
+
+
+! Computes the gradient Richardson's number and stability functions:
+!===================================================================
+
+DO ilay=2,nlay
+    DO igrid=1,ngrid
+        dz_lay(igrid,ilay)=z_lay(igrid,ilay)-z_lay(igrid,ilay-1)
+        thetam=0.5*(theta(igrid,ilay) + theta(igrid,ilay-1))
+        N2(igrid,ilay) = rg * (theta(igrid,ilay) - theta(igrid,ilay-1))/thetam / dz_lay(igrid,ilay)
+        shear2(igrid,ilay)= (((wind_u(igrid,ilay) - wind_u(igrid,ilay-1)) / dz_lay(igrid,ilay))**2 + &
+            ((wind_v(igrid,ilay) - wind_v(igrid,ilay-1)) / dz_lay(igrid,ilay))**2 )
+        Ri(igrid,ilay) = N2(igrid,ilay) / MAX(shear2(igrid,ilay),1E-10) 
+        
+        IF (Ri(igrid,ilay) < 0.) THEN ! unstable cases
+            Sm(igrid,ilay) = 2./rpi * (cinf-cn) * atan(-Ri(igrid,ilay)/Ri0) + cn
+            Prandtl(igrid,ilay) = -2./rpi * (pr_asym - pr_neut) * atan(Ri(igrid,ilay)/Ri1) + pr_neut 
+        ELSE ! stable cases
+            Sm(igrid,ilay) = max(smmin,cn*(1.-Ri(igrid,ilay)/Ric))
+            ! prandlt expression from venayagamoorthy and stretch 2010, Li et al 2019
+            Prandtl(igrid,ilay) = pr_neut*exp(-pr_slope/pr_neut*Ri(igrid,ilay)+Ri(igrid,ilay)/pr_neut) &
+                                + Ri(igrid,ilay) * pr_slope
+            IF (Ri(igrid,ilay) .GE. Prandtl(igrid,ilay)) THEN
+                call abort_physic("atke_compute_km_kh", &
+                'Ri>=Pr in stable conditions -> violates energy conservation principles, change pr_neut or slope', 1)
+            ENDIF
+        END IF
+        
+        Sh(igrid,ilay) = Sm(igrid,ilay) / Prandtl(igrid,ilay)
+
+    ENDDO
+ENDDO
+
+
+! Computing the mixing length:
+!==============================================================
+
+
+IF (iflag_atke_lmix .EQ. 1 ) THEN
+    ! Blackadar formulation (~kappa l) + buoyancy length scale (Deardoff 1980) for very stable conditions
+        DO ilay=2,nlay
+            DO igrid=1,ngrid
+                l_exchange(igrid,ilay) = kappa*l0*z_interf(igrid,ilay) / (kappa*z_interf(igrid,ilay) + l0)
+                IF (N2(igrid,ilay) .GT. 0.) THEN
+                    lstrat=clmix*sqrt(tke(igrid,ilay))/sqrt(N2(igrid,ilay))
+                    lstrat=max(lstrat,lmin)
+                    !Inverse interpolation, Van de Wiel et al. 2010
+                    l_exchange(igrid,ilay)=(1./(l_exchange(igrid,ilay))+1./(lstrat))**(-1.0)
+                ENDIF 
+            ENDDO
+        ENDDO
+
+    ELSE IF (iflag_atke_lmix .EQ. 2 ) THEN
+    ! add effect of wind shear on lstrat following grisogono and belusic 2008, qjrms
+    ! implies 2 tuning coefficients clmix and clmixshear
+    DO ilay=2,nlay
+        DO igrid=1,ngrid
+            l_exchange(igrid,ilay) = kappa*l0*z_interf(igrid,ilay) / (kappa*z_interf(igrid,ilay) + l0)
+            IF (N2(igrid,ilay) .GT. 0. .AND. shear2(igrid,ilay) .GT. 0.) THEN
+                lstrat=min(clmix*sqrt(tke(igrid,ilay))/sqrt(N2(igrid,ilay)), &
+                    clmixshear*sqrt(tke(igrid,ilay))/sqrt(shear2(igrid,ilay)))
+                lstrat=max(lstrat,lmin)
+                !Inverse interpolation, Van de Wiel et al. 2010   
+                l_exchange(igrid,ilay)=(1./(l_exchange(igrid,ilay))+1./(lstrat))**(-1.0)
+            ENDIF
+        ENDDO
+    ENDDO
+
+    ELSE IF (iflag_atke_lmix .EQ. 3 ) THEN
+    ! add effect of wind shear on lstrat following grisogono 2010, qjrms
+    ! keeping a single tuning coefficient clmix
+    DO ilay=2,nlay
+        DO igrid=1,ngrid
+            l_exchange(igrid,ilay) = kappa*l0*z_interf(igrid,ilay) / (kappa*z_interf(igrid,ilay) + l0)
+            IF (N2(igrid,ilay) .GT. 0. .AND. shear2(igrid,ilay) .GT. 0.) THEN
+                lstrat=clmix*sqrt(tke(igrid,ilay))/sqrt(shear2(igrid,ilay))*(1.0+Ri(igrid,ilay)/(2.*Prandtl(igrid,ilay)))
+                lstrat=max(lstrat,lmin)
+                !Inverse interpolation, Van de Wiel et al. 2010   
+                l_exchange(igrid,ilay)=(1./(l_exchange(igrid,ilay))+1./(lstrat))**(-1.0)
+            ENDIF
+        ENDDO
+    ENDDO
+
+ELSE
+    ! default Blackadar formulation: neglect effect of local stratification and shear
+    DO ilay=2,nlay+1
+        DO igrid=1,ngrid
+            l_exchange(igrid,ilay) = kappa*l0*z_interf(igrid,ilay) / (kappa*z_interf(igrid,ilay) + l0)
+        ENDDO
+    ENDDO
+ENDIF
+
+
+! Computing the TKE k>=2:
+!========================
+IF (iflag_atke == 0) THEN
+
+    ! stationary solution (dtke/dt=0)
+
+    DO ilay=2,nlay
+            DO igrid=1,ngrid
+                tke(igrid,ilay) = cepsilon * l_exchange(igrid,ilay)**2 * Sm(igrid,ilay) * &
+                shear2(igrid,ilay) * (1. - Ri(igrid,ilay) / Prandtl(igrid,ilay))
+                eps(igrid,ilay) = (tke(igrid,ilay)**(3./2))/(cepsilon*l_exchange(igrid,ilay))
+                tke_shear(igrid,ilay)=l_exchange(igrid,ilay)*Sm(igrid,ilay)*sqrt(tke(igrid,ilay))*shear2(igrid,ilay) 
+                tke_buoy(igrid,ilay)=-l_exchange(igrid,ilay)*Sm(igrid,ilay)*sqrt(tke(igrid,ilay))*shear2(igrid,ilay) &
+                                    *(Ri(igrid,ilay) / Prandtl(igrid,ilay))
+            ENDDO
+        ENDDO
+
+ELSE IF (iflag_atke == 1) THEN
+
+    ! full implicit scheme resolved with a second order polynomial equation
+    ! default solution which shows fair convergence properties
+        DO ilay=2,nlay
+            DO igrid=1,ngrid
+            qq=max(sqrt(2.*tke(igrid,ilay)),1.e-10)
+            delta=(2.*sqrt(2.)*cepsilon*l_exchange(igrid,ilay)/dtime)**2. &
+                    +4.*(2.*sqrt(2.)*cepsilon*l_exchange(igrid,ilay)/dtime*qq + &
+                    2.*l_exchange(igrid,ilay)*l_exchange(igrid,ilay)*cepsilon*Sm(igrid,ilay) &
+                    *shear2(igrid,ilay) * (1. - Ri(igrid,ilay) / Prandtl(igrid,ilay)))
+            qq=(-2.*sqrt(2.)*cepsilon*l_exchange(igrid,ilay)/dtime + sqrt(delta))/2.
+            qq=max(0.,qq)
+            tke(igrid,ilay)=0.5*(qq**2)
+            eps(igrid,ilay) = (tke(igrid,ilay)**(3./2))/(cepsilon*l_exchange(igrid,ilay))
+            tke_shear(igrid,ilay)=l_exchange(igrid,ilay)*Sm(igrid,ilay)*sqrt(tke(igrid,ilay))*shear2(igrid,ilay)
+            tke_buoy(igrid,ilay)=-l_exchange(igrid,ilay)*Sm(igrid,ilay)*sqrt(tke(igrid,ilay))*shear2(igrid,ilay) &
+                                *(Ri(igrid,ilay) / Prandtl(igrid,ilay)) 
+            ENDDO
+        ENDDO
+
+
+ELSE IF (iflag_atke == 2) THEN
+
+    ! semi implicit scheme when l does not depend on tke
+    ! positive-guaranteed if pr slope in stable condition >1
+
+    DO ilay=2,nlay
+            DO igrid=1,ngrid
+            qq=max(sqrt(2.*tke(igrid,ilay)),1.e-10)
+            qq=(qq+l_exchange(igrid,ilay)*Sm(igrid,ilay)*dtime/sqrt(2.)      & 
+                *shear2(igrid,ilay)*(1.-Ri(igrid,ilay)/Prandtl(igrid,ilay))) &
+                /(1.+qq*dtime/(cepsilon*l_exchange(igrid,ilay)*2.*sqrt(2.)))
+            tke_shear(igrid,ilay)=l_exchange(igrid,ilay)*Sm(igrid,ilay)*qq/sqrt(2.)*shear2(igrid,ilay)
+            tke_buoy(igrid,ilay)=-l_exchange(igrid,ilay)*Sm(igrid,ilay)*qq/sqrt(2.)*shear2(igrid,ilay) &
+                                *(Ri(igrid,ilay) / Prandtl(igrid,ilay)) 
+            tke(igrid,ilay)=0.5*(qq**2) 
+            eps(igrid,ilay) = (tke(igrid,ilay)**(3./2))/(cepsilon*l_exchange(igrid,ilay))
+            ENDDO
+        ENDDO
+
+
+ELSE IF (iflag_atke == 3) THEN
+    ! numerical resolution adapted from that in MAR (Deleersnijder 1992)
+    ! positively defined by construction
+
+        DO ilay=2,nlay
+            DO igrid=1,ngrid
+            eps(igrid,ilay) = (tke(igrid,ilay)**(3./2))/(cepsilon*l_exchange(igrid,ilay))
+            qq=max(sqrt(2.*tke(igrid,ilay)),1.e-10)
+            tke_shear(igrid,ilay)=l_exchange(igrid,ilay)*Sm(igrid,ilay)*qq/sqrt(2.)*shear2(igrid,ilay)
+            tke_buoy(igrid,ilay)=-l_exchange(igrid,ilay)*Sm(igrid,ilay)*qq/sqrt(2.)*shear2(igrid,ilay) &
+                                *(Ri(igrid,ilay) / Prandtl(igrid,ilay))
+            IF (Ri(igrid,ilay) .LT. 0.) THEN
+                netloss=qq/(2.*sqrt(2.)*cepsilon*l_exchange(igrid,ilay))
+                netsource=l_exchange(igrid,ilay)*Sm(igrid,ilay)/sqrt(2.)*shear2(igrid,ilay)*(1.-Ri(igrid,ilay)/Prandtl(igrid,ilay))
+            ELSE
+                netloss=qq/(2.*sqrt(2.)*cepsilon*l_exchange(igrid,ilay))+ &
+                        l_exchange(igrid,ilay)*Sm(igrid,ilay)/sqrt(2.)*N2(igrid,ilay)/Prandtl(igrid,ilay)
+                netsource=l_exchange(igrid,ilay)*Sm(igrid,ilay)/sqrt(2.)*shear2(igrid,ilay)
+            ENDIF
+            qq=((qq**2)/dtime+qq*netsource)/(qq/dtime+netloss)
+            tke(igrid,ilay)=0.5*(qq**2)
+            ENDDO
+        ENDDO
+
+ELSE IF (iflag_atke == 4) THEN
+    ! semi implicit scheme from Arpege (V. Masson methodology with 
+    ! Taylor expansion of the dissipation term)
+        DO ilay=2,nlay
+            DO igrid=1,ngrid
+            qq=max(sqrt(2.*tke(igrid,ilay)),1.e-10)
+            tke_shear(igrid,ilay)=l_exchange(igrid,ilay)*Sm(igrid,ilay)*qq/sqrt(2.)*shear2(igrid,ilay)
+            tke_buoy(igrid,ilay)=-l_exchange(igrid,ilay)*Sm(igrid,ilay)*qq/sqrt(2.)*shear2(igrid,ilay) &
+                                *(Ri(igrid,ilay) / Prandtl(igrid,ilay))
+            qq=(l_exchange(igrid,ilay)*Sm(igrid,ilay)/sqrt(2.)*shear2(igrid,ilay)*(1.-Ri(igrid,ilay)/Prandtl(igrid,ilay)) &
+                +qq*(1.+dtime*qq/(cepsilon*l_exchange(igrid,ilay)*2.*sqrt(2.)))) &
+                /(1.+2.*qq*dtime/(cepsilon*l_exchange(igrid,ilay)*2.*sqrt(2.)))
+            qq=max(0.,qq)
+            tke(igrid,ilay)=0.5*(qq**2)
+            eps(igrid,ilay) = (tke(igrid,ilay)**(3./2))/(cepsilon*l_exchange(igrid,ilay))
+            ENDDO
+        ENDDO
+
+
+ELSE
+    call abort_physic("atke_compute_km_kh", &
+        'numerical treatment of TKE not possible yet', 1)
+
+END IF
+
+! We impose a 0 tke at nlay+1
+!==============================
+
+DO igrid=1,ngrid
+    tke(igrid,nlay+1)=0.
+    eps(igrid,nlay+1)=0.
+    tke_shear(igrid,nlay+1)=0.
+    tke_buoy(igrid,nlay+1)=0.
+END DO
+
+
+! Calculation of surface TKE (k=1)
+!=================================
+! surface TKE calculation inspired from what is done in Arpege (see E. Bazile note)
+DO igrid=1,ngrid
+    ustar=sqrt(cdrag_uv(igrid)*(wind_u(igrid,1)**2+wind_v(igrid,1)**2))
+    tke(igrid,1)=ctkes*(ustar**2)
+    eps(igrid,1)=0. ! arbitrary as TKE is not properly defined at the surface
+    tke_shear(igrid,1)=0.
+    tke_buoy(igrid,1)=0.
+END DO
+
+
+! vertical diffusion of TKE 
+!==========================
+tke_trans(:,:)=0.
+IF (atke_ok_vdiff) THEN
+    CALL atke_vdiff_tke(ngrid,nlay,dtime,z_lay,z_interf,temp,play,l_exchange,Sm,tke,tke_trans)
+ENDIF
+
+
+! Computing eddy diffusivity coefficients:
+!========================================
+DO ilay=2,nlay ! TODO: also calculate for nlay+1 ?
+    DO igrid=1,ngrid
+        ! we add the molecular viscosity to Km,h 
+        Km(igrid,ilay) = viscom + l_exchange(igrid,ilay) * Sm(igrid,ilay) * tke(igrid,ilay)**0.5
+        Kh(igrid,ilay) = viscoh + l_exchange(igrid,ilay) * Sh(igrid,ilay) * tke(igrid,ilay)**0.5
+    END DO
+END DO
+
+! for output:
+!===========
+Km_out(1:ngrid,2:nlay)=Km(1:ngrid,2:nlay)
+Kh_out(1:ngrid,2:nlay)=Kh(1:ngrid,2:nlay)
+
+end subroutine atke_compute_km_kh
+
+!===============================================================================================
+subroutine atke_vdiff_tke(ngrid,nlay,dtime,z_lay,z_interf,temp,play,l_exchange,Sm,tke,tke_trans)
+
+! routine that computes the vertical diffusion of TKE by the turbulence
+! using an implicit resolution (See note by Dufresne and Ghattas (2009))
+! E Vignon, July 2023
+
+USE lmdz_atke_turbulence_ini, ONLY : rd, cke, viscom
+
+
+INTEGER, INTENT(IN) :: ngrid ! number of horizontal index (flat grid)
+INTEGER, INTENT(IN) :: nlay  ! number of vertical index  
+
+REAL, INTENT(IN)    :: dtime ! physics time step (s)
+REAL, DIMENSION(ngrid,nlay), INTENT(IN)       :: z_lay   ! altitude of mid-layers (m)
+REAL, DIMENSION(ngrid,nlay+1), INTENT(IN)       :: z_interf   ! altitude of bottom interfaces (m)
+REAL, DIMENSION(ngrid,nlay), INTENT(IN)       :: temp   ! temperature (K)
+REAL, DIMENSION(ngrid,nlay), INTENT(IN)       :: play   ! pressure (Pa)
+REAL, DIMENSION(ngrid,nlay+1), INTENT(IN)     :: l_exchange     ! mixing length at interfaces between layers
+REAL, DIMENSION(ngrid,nlay+1), INTENT(IN)     :: Sm     ! stability function for eddy diffusivity for momentum at interface between layers
+
+REAL, DIMENSION(ngrid,nlay+1), INTENT(INOUT)  :: tke    ! turbulent kinetic energy at interface between layers
+REAL, DIMENSION(ngrid,nlay+1), INTENT(INOUT)  :: tke_trans ! turbulent kinetic energy transport term (m2/s3)
+
+
+INTEGER                                       :: igrid,ilay
+REAL, DIMENSION(ngrid,nlay+1)                 :: Ke     ! eddy diffusivity for TKE
+REAL, DIMENSION(ngrid,nlay+1)                 :: dtke
+REAL, DIMENSION(ngrid,nlay+1)                 :: ak, bk, ck, CCK, DDK
+REAL                                          :: gammak,Kem,KKb,KKt
+
+
+! Few initialisations
+CCK(:,:)=0.
+DDK(:,:)=0.
+dtke(:,:)=0.
+
+
+! Eddy diffusivity for TKE
+
+DO ilay=2,nlay
+    DO igrid=1,ngrid
+        Ke(igrid,ilay)=(viscom+l_exchange(igrid,ilay)*Sm(igrid,ilay)*sqrt(tke(igrid,ilay)))*cke 
+    ENDDO
+ENDDO
+! at the top of the atmosphere set to 0
+Ke(:,nlay+1)=0.
+! at the surface, set it equal to that at the first model level
+Ke(:,1)=Ke(:,2)
+
+
+! calculate intermediary variables
+
+DO ilay=2,nlay 
+    DO igrid=1,ngrid
+    Kem=0.5*(Ke(igrid,ilay+1)+Ke(igrid,ilay))    
+    KKt=Kem*play(igrid,ilay)/rd/temp(igrid,ilay)/(z_interf(igrid,ilay+1)-z_interf(igrid,ilay))
+    Kem=0.5*(Ke(igrid,ilay)+Ke(igrid,ilay-1))
+    KKb=Kem*play(igrid,ilay-1)/rd/temp(igrid,ilay-1)/(z_interf(igrid,ilay)-z_interf(igrid,ilay-1))
+    gammak=1./(z_lay(igrid,ilay)-z_lay(igrid,ilay-1))
+    ak(igrid,ilay)=-gammak*dtime*KKb
+    ck(igrid,ilay)=-gammak*dtime*KKt
+    bk(igrid,ilay)=1.+gammak*dtime*(KKt+KKb)
+    ENDDO
+ENDDO
+
+! calculate CCK and DDK coefficients
+! downhill phase
+
+DO igrid=1,ngrid
+    CCK(igrid,nlay)=tke(igrid,nlay)/bk(igrid,nlay)
+    DDK(igrid,nlay)=-ak(igrid,nlay)/bk(igrid,nlay)
+ENDDO
+
+
+DO ilay=nlay-1,2,-1
+    DO igrid=1,ngrid
+        CCK(igrid,ilay)=(tke(igrid,ilay)/bk(igrid,ilay)-ck(igrid,ilay)/bk(igrid,ilay)*CCK(igrid,ilay+1)) &
+                        / (1.+ck(igrid,ilay)/bk(igrid,ilay)*DDK(igrid,ilay+1))
+        DDK(igrid,ilay)=-ak(igrid,ilay)/bk(igrid,ilay)/(1+ck(igrid,ilay)/bk(igrid,ilay)*DDK(igrid,ilay+1))
+    ENDDO
+ENDDO
+
+! calculate TKE
+! uphill phase
+
+DO ilay=2,nlay+1
+    DO igrid=1,ngrid
+        dtke(igrid,ilay)=CCK(igrid,ilay)+DDK(igrid,ilay)*tke(igrid,ilay-1)-tke(igrid,ilay)
+    ENDDO
+ENDDO
+
+! update TKE
+tke(:,:)=tke(:,:)+dtke(:,:)
+tke_trans(:,:)=dtke(:,:)/dtime
+
+
+end subroutine atke_vdiff_tke
+
+
+
+end module lmdz_atke_exchange_coeff
Index: DZ6/trunk/libf/phylmd/lmdz_atke_turbulence_ini.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/lmdz_atke_turbulence_ini.F90	(revision 5267)
+++ 	(revision )
@@ -1,181 +1,0 @@
-MODULE lmdz_atke_turbulence_ini
-
-implicit none
-
-! declaration of constants and parameters
-
-real, save, protected  :: rg, rd, rpi, rcpd, rv, viscom, viscoh        
-!$OMP THREADPRIVATE(rg, rd, rpi, rcpd, rv, viscom, viscoh)     
-
-integer, save, protected :: iflag_atke        ! flag that controls options in atke_compute_km_kh
-integer, save, protected :: iflag_atke_lmix   ! flag that controls the calculation of mixing length in atke
-integer, save, protected :: iflag_num_atke    ! flag that controls the numerical treatment of diffusion coeffiient calculation
-!$OMP THREADPRIVATE(iflag_atke, iflag_atke_lmix, iflag_num_atke)
-
-logical, save, protected :: atke_ok_vdiff    ! activate vertical diffusion of TKE or not
-logical, save, protected :: atke_ok_virtual  ! account for vapor for flottability
-!$OMP THREADPRIVATE(atke_ok_vdiff, atke_ok_virtual)
-
-real, save, protected :: kappa = 0.4         ! Von Karman constant
-real, save, protected :: cn                  ! Sm value at Ri=0
-real, save, protected :: cinf                ! Sm value at Ri=-Inf
-real, save, protected :: ri0                 ! Richardson number near zero to guarantee continuity in slope of Sm (stability function) at Ri=0
-real, save, protected :: ri1                 ! Richardson number near zero to guarantee continuity in slope of Pr (Prandlt's number) at Ri=0
-real, save, protected :: lmin = 0.01         ! minimum mixing length corresponding to the Kolmogov dissipation scale  in planetary atmospheres (Chen et al 2016, JGR Atmos)
-real, save, protected :: ctkes               ! coefficient for surface TKE
-real, save, protected :: clmixshear          ! coefficient for mixing length depending on local wind shear
-!$OMP THREADPRIVATE(kappa, cn, cinf, ri0, ri1, lmin, ctkes, clmixshear)
-
-
-! Tunable parameters for the ATKE scheme and their range of values
-!!-------------------------------------------------------------------------------------------------------------
-real, save, protected :: cepsilon            ! controls the value of the dissipation length scale, range [1.2 - 10]
-real, save, protected :: cke                 ! controls the value of the diffusion coefficient of TKE, range [1 - 5]
-real, save, protected :: l0                  ! asymptotic mixing length far from the ground [m] (Sun et al 2011, JAMC), range [15 - 75]
-real, save, protected :: clmix               ! controls the value of the mixing length in stratified conditions, range [0.1 - 2]
-real, save, protected :: ric                 ! critical Richardson number controlling the slope of Sm in stable conditions, range [0.19 - 0.25]
-real, save, protected :: smmin               ! minimum value of Sm in very stable conditions (defined here as minsqrt(Ez/Ek)) at large Ri, range [0.025 - 0.1]
-real, save, protected :: pr_neut             ! neutral value of the Prandtl number (Ri=0), range [0.7 - 1]
-real, save, protected :: pr_slope            ! linear slope of Pr with Ri in the very stable regime, range [3 - 5]
-real, save, protected :: cinffac             ! ratio between cinf and cn controlling the convective limit of Sm, range [1.2 - 5.0]
-real, save, protected :: pr_asym             ! value of Prandlt in the convective limit(Ri=-Inf), range [0.3 - 0.5]
-!$OMP THREADPRIVATE(cepsilon, cke, l0, clmix, ric, smmin, pr_neut, pr_slope, cinffac, pr_asym)
-!!-------------------------------------------------------------------------------------------------------------
-
-CONTAINS
-
-SUBROUTINE atke_ini(rg_in, rd_in, rpi_in, rcpd_in, rv_in, viscom_in, viscoh_in)
-      !!----------------------------------------------------------------------
-      !!                  ***  ROUTINE  atke_ini  ***
-      !!
-      !! ** Purpose :   Initialization of the atke module and choice of some constants
-      !!                Default values correspond to the  'best' configuration
-      !!                from tuning on GABLS1 in Vignon et al. 2024, JAMES
-      !!----------------------------------------------------------------------
-
-        USE ioipsl_getin_p_mod, ONLY : getin_p                                                                                                      
-
-      ! input arguments (universal constants for planet)
-      !-------------------------------------------------
-      real, intent(in) :: rg_in, rd_in, rpi_in, rcpd_in, rv_in, viscom_in, viscoh_in
-      !!----------------------------------------------------------------------
-      
-      rg=rg_in          ! gravity acceleration
-      rd=rd_in          ! dry gas constant (R/M, R=perfect gas constant and M is the molar mass of the fluid)
-      rpi=rpi_in        ! Pi number
-      rcpd=rcpd_in      ! cp per unit mass of the gas
-      rv=rv_in          ! water vapor constant (for simulations in Earth's atmosphere)
-      viscom=viscom_in  ! kinematic molecular viscosity for momentum
-      viscoh=viscoh_in  ! kinematic molecular viscosity for heat
-
-
-      ! Read flag values in .def files
-      !-------------------------------
-
-      ! flag that controls options in atke_compute_km_kh
-      iflag_atke=1
-      CALL getin_p('iflag_atke',iflag_atke)
-
-      ! flag that controls the calculation of mixing length in atke
-      iflag_atke_lmix=3
-      CALL getin_p('iflag_atke_lmix',iflag_atke_lmix)
-
-      if (iflag_atke .eq. 0 .and. iflag_atke_lmix>0) then
-            call abort_physic("atke_turbulence_ini", &
-            'stationary scheme must use mixing length formulation not depending on tke', 1)
-      endif
-
-      ! activate vertical diffusion of TKE or not
-      atke_ok_vdiff=.true.
-      CALL getin_p('atke_ok_vdiff',atke_ok_vdiff)
-
-      ! account for vapor for flottability
-      atke_ok_virtual=.true.
-      CALL getin_p('atke_ok_virtual',atke_ok_virtual)
-
-
-      ! flag that controls the numerical treatment of diffusion coeffiient calculation
-      iflag_num_atke=0
-      CALL getin_p('iflag_num_atke',iflag_num_atke)
-
-      ! asymptotic mixing length in neutral conditions [m]
-      ! Sun et al 2011, JAMC 
-      ! between 10 and 40
-      l0=42.5279652116005 
-      CALL getin_p('atke_l0',l0)
-
-      ! critical Richardson number 
-      ric=0.190537327781655
-      CALL getin_p('atke_ric',ric)
-
-      ! constant for tke dissipation calculation
-      cepsilon=8.89273387537601
-      CALL getin_p('atke_cepsilon',cepsilon)
-
-      ! calculation of cn = Sm value at Ri=0
-      ! direct dependance on cepsilon to guarantee Fm=1 (first-order like stability function) at Ri=0
-      cn=(1./sqrt(cepsilon))**(2/3)
-
-      ! asymptotic value of Sm for Ri=-Inf
-      cinffac=2.0
-      CALL getin_p('atke_cinffac',cinffac)
-      cinf=cinffac*cn
-      if (cinf .le. cn) then
-            call abort_physic("atke_turbulence_ini", &
-            'cinf cannot be lower than cn', 1)
-      endif
-
-      ! coefficient for surface TKE 
-      ! following Lenderink & Holtslag 2004, ctkes=(cepsilon)**(2/3)
-      ! (provided by limit condition in neutral conditions)
-      ctkes=(cepsilon)**(2./3.)
-
-      ! slope of Pr=f(Ri) for stable conditions
-      pr_slope=4.67885738180385
-      CALL getin_p('atke_pr_slope',pr_slope)
-      if (pr_slope .le. 1) then
-            call abort_physic("atke_turbulence_ini", &
-            'pr_slope has to be greater than 1 for consistency of the tke scheme', 1)
-      endif
-
-      ! value of turbulent prandtl number in neutral conditions (Ri=0)
-      pr_neut=0.837372701768868
-      CALL getin_p('atke_pr_neut',pr_neut)
-
-      ! asymptotic turbulent prandt number value for Ri=-Inf
-      pr_asym=0.4
-      CALL getin_p('atke_pr_asym',pr_asym)
-      if (pr_asym .ge. pr_neut) then
-            call abort_physic("atke_turbulence_ini", &
-            'pr_asym must be be lower than pr_neut', 1)
-      endif
-
-      ! coefficient for mixing length depending on local stratification
-      clmix=0.648055235325291
-      CALL getin_p('atke_clmix',clmix)
-
-      ! coefficient for mixing length depending on local wind shear
-      clmixshear=0.5
-      CALL getin_p('atke_clmixshear',clmixshear)
-
-      ! minimum anisotropy coefficient (defined here as minsqrt(Ez/Ek)) at large Ri. 
-      ! From Zilitinkevich et al. 2013, it equals sqrt(0.03)~0.17  
-      smmin=0.0960838631869678
-      CALL getin_p('atke_smmin',smmin)
-
-      ! ratio between the eddy diffusivity coeff for tke wrt that for momentum
-      ! default value from Lenderink et al. 2004
-      cke=2.47069655134662
-      CALL getin_p('atke_cke',cke)
-
-      ! calculation of Ri0 such that continuity in slope of Sm at Ri=0
-      ri0=2./rpi*(cinf - cn)*ric/cn
-
-      ! calculation of Ri1 to guarantee continuity in slope of Prandlt number at Ri=0
-      ri1 = -2./rpi * (pr_asym - pr_neut)
-
-RETURN
-
-END SUBROUTINE atke_ini
-
-END MODULE  lmdz_atke_turbulence_ini
Index: /LMDZ6/trunk/libf/phylmd/lmdz_atke_turbulence_ini.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/lmdz_atke_turbulence_ini.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/lmdz_atke_turbulence_ini.f90	(revision 5268)
@@ -0,0 +1,181 @@
+MODULE lmdz_atke_turbulence_ini
+
+implicit none
+
+! declaration of constants and parameters
+
+real, save, protected  :: rg, rd, rpi, rcpd, rv, viscom, viscoh        
+!$OMP THREADPRIVATE(rg, rd, rpi, rcpd, rv, viscom, viscoh)     
+
+integer, save, protected :: iflag_atke        ! flag that controls options in atke_compute_km_kh
+integer, save, protected :: iflag_atke_lmix   ! flag that controls the calculation of mixing length in atke
+integer, save, protected :: iflag_num_atke    ! flag that controls the numerical treatment of diffusion coeffiient calculation
+!$OMP THREADPRIVATE(iflag_atke, iflag_atke_lmix, iflag_num_atke)
+
+logical, save, protected :: atke_ok_vdiff    ! activate vertical diffusion of TKE or not
+logical, save, protected :: atke_ok_virtual  ! account for vapor for flottability
+!$OMP THREADPRIVATE(atke_ok_vdiff, atke_ok_virtual)
+
+real, save, protected :: kappa = 0.4         ! Von Karman constant
+real, save, protected :: cn                  ! Sm value at Ri=0
+real, save, protected :: cinf                ! Sm value at Ri=-Inf
+real, save, protected :: ri0                 ! Richardson number near zero to guarantee continuity in slope of Sm (stability function) at Ri=0
+real, save, protected :: ri1                 ! Richardson number near zero to guarantee continuity in slope of Pr (Prandlt's number) at Ri=0
+real, save, protected :: lmin = 0.01         ! minimum mixing length corresponding to the Kolmogov dissipation scale  in planetary atmospheres (Chen et al 2016, JGR Atmos)
+real, save, protected :: ctkes               ! coefficient for surface TKE
+real, save, protected :: clmixshear          ! coefficient for mixing length depending on local wind shear
+!$OMP THREADPRIVATE(kappa, cn, cinf, ri0, ri1, lmin, ctkes, clmixshear)
+
+
+! Tunable parameters for the ATKE scheme and their range of values
+!!-------------------------------------------------------------------------------------------------------------
+real, save, protected :: cepsilon            ! controls the value of the dissipation length scale, range [1.2 - 10]
+real, save, protected :: cke                 ! controls the value of the diffusion coefficient of TKE, range [1 - 5]
+real, save, protected :: l0                  ! asymptotic mixing length far from the ground [m] (Sun et al 2011, JAMC), range [15 - 75]
+real, save, protected :: clmix               ! controls the value of the mixing length in stratified conditions, range [0.1 - 2]
+real, save, protected :: ric                 ! critical Richardson number controlling the slope of Sm in stable conditions, range [0.19 - 0.25]
+real, save, protected :: smmin               ! minimum value of Sm in very stable conditions (defined here as minsqrt(Ez/Ek)) at large Ri, range [0.025 - 0.1]
+real, save, protected :: pr_neut             ! neutral value of the Prandtl number (Ri=0), range [0.7 - 1]
+real, save, protected :: pr_slope            ! linear slope of Pr with Ri in the very stable regime, range [3 - 5]
+real, save, protected :: cinffac             ! ratio between cinf and cn controlling the convective limit of Sm, range [1.2 - 5.0]
+real, save, protected :: pr_asym             ! value of Prandlt in the convective limit(Ri=-Inf), range [0.3 - 0.5]
+!$OMP THREADPRIVATE(cepsilon, cke, l0, clmix, ric, smmin, pr_neut, pr_slope, cinffac, pr_asym)
+!!-------------------------------------------------------------------------------------------------------------
+
+CONTAINS
+
+SUBROUTINE atke_ini(rg_in, rd_in, rpi_in, rcpd_in, rv_in, viscom_in, viscoh_in)
+      !!----------------------------------------------------------------------
+      !!                  ***  ROUTINE  atke_ini  ***
+      !!
+      !! ** Purpose :   Initialization of the atke module and choice of some constants
+      !!                Default values correspond to the  'best' configuration
+      !!                from tuning on GABLS1 in Vignon et al. 2024, JAMES
+      !!----------------------------------------------------------------------
+
+        USE ioipsl_getin_p_mod, ONLY : getin_p                                                                                                      
+
+      ! input arguments (universal constants for planet)
+      !-------------------------------------------------
+      real, intent(in) :: rg_in, rd_in, rpi_in, rcpd_in, rv_in, viscom_in, viscoh_in
+      !!----------------------------------------------------------------------
+      
+      rg=rg_in          ! gravity acceleration
+      rd=rd_in          ! dry gas constant (R/M, R=perfect gas constant and M is the molar mass of the fluid)
+      rpi=rpi_in        ! Pi number
+      rcpd=rcpd_in      ! cp per unit mass of the gas
+      rv=rv_in          ! water vapor constant (for simulations in Earth's atmosphere)
+      viscom=viscom_in  ! kinematic molecular viscosity for momentum
+      viscoh=viscoh_in  ! kinematic molecular viscosity for heat
+
+
+      ! Read flag values in .def files
+      !-------------------------------
+
+      ! flag that controls options in atke_compute_km_kh
+      iflag_atke=1
+      CALL getin_p('iflag_atke',iflag_atke)
+
+      ! flag that controls the calculation of mixing length in atke
+      iflag_atke_lmix=3
+      CALL getin_p('iflag_atke_lmix',iflag_atke_lmix)
+
+      if (iflag_atke .eq. 0 .and. iflag_atke_lmix>0) then
+            call abort_physic("atke_turbulence_ini", &
+            'stationary scheme must use mixing length formulation not depending on tke', 1)
+      endif
+
+      ! activate vertical diffusion of TKE or not
+      atke_ok_vdiff=.true.
+      CALL getin_p('atke_ok_vdiff',atke_ok_vdiff)
+
+      ! account for vapor for flottability
+      atke_ok_virtual=.true.
+      CALL getin_p('atke_ok_virtual',atke_ok_virtual)
+
+
+      ! flag that controls the numerical treatment of diffusion coeffiient calculation
+      iflag_num_atke=0
+      CALL getin_p('iflag_num_atke',iflag_num_atke)
+
+      ! asymptotic mixing length in neutral conditions [m]
+      ! Sun et al 2011, JAMC 
+      ! between 10 and 40
+      l0=42.5279652116005 
+      CALL getin_p('atke_l0',l0)
+
+      ! critical Richardson number 
+      ric=0.190537327781655
+      CALL getin_p('atke_ric',ric)
+
+      ! constant for tke dissipation calculation
+      cepsilon=8.89273387537601
+      CALL getin_p('atke_cepsilon',cepsilon)
+
+      ! calculation of cn = Sm value at Ri=0
+      ! direct dependance on cepsilon to guarantee Fm=1 (first-order like stability function) at Ri=0
+      cn=(1./sqrt(cepsilon))**(2/3)
+
+      ! asymptotic value of Sm for Ri=-Inf
+      cinffac=2.0
+      CALL getin_p('atke_cinffac',cinffac)
+      cinf=cinffac*cn
+      if (cinf .le. cn) then
+            call abort_physic("atke_turbulence_ini", &
+            'cinf cannot be lower than cn', 1)
+      endif
+
+      ! coefficient for surface TKE 
+      ! following Lenderink & Holtslag 2004, ctkes=(cepsilon)**(2/3)
+      ! (provided by limit condition in neutral conditions)
+      ctkes=(cepsilon)**(2./3.)
+
+      ! slope of Pr=f(Ri) for stable conditions
+      pr_slope=4.67885738180385
+      CALL getin_p('atke_pr_slope',pr_slope)
+      if (pr_slope .le. 1) then
+            call abort_physic("atke_turbulence_ini", &
+            'pr_slope has to be greater than 1 for consistency of the tke scheme', 1)
+      endif
+
+      ! value of turbulent prandtl number in neutral conditions (Ri=0)
+      pr_neut=0.837372701768868
+      CALL getin_p('atke_pr_neut',pr_neut)
+
+      ! asymptotic turbulent prandt number value for Ri=-Inf
+      pr_asym=0.4
+      CALL getin_p('atke_pr_asym',pr_asym)
+      if (pr_asym .ge. pr_neut) then
+            call abort_physic("atke_turbulence_ini", &
+            'pr_asym must be be lower than pr_neut', 1)
+      endif
+
+      ! coefficient for mixing length depending on local stratification
+      clmix=0.648055235325291
+      CALL getin_p('atke_clmix',clmix)
+
+      ! coefficient for mixing length depending on local wind shear
+      clmixshear=0.5
+      CALL getin_p('atke_clmixshear',clmixshear)
+
+      ! minimum anisotropy coefficient (defined here as minsqrt(Ez/Ek)) at large Ri. 
+      ! From Zilitinkevich et al. 2013, it equals sqrt(0.03)~0.17  
+      smmin=0.0960838631869678
+      CALL getin_p('atke_smmin',smmin)
+
+      ! ratio between the eddy diffusivity coeff for tke wrt that for momentum
+      ! default value from Lenderink et al. 2004
+      cke=2.47069655134662
+      CALL getin_p('atke_cke',cke)
+
+      ! calculation of Ri0 such that continuity in slope of Sm at Ri=0
+      ri0=2./rpi*(cinf - cn)*ric/cn
+
+      ! calculation of Ri1 to guarantee continuity in slope of Prandlt number at Ri=0
+      ri1 = -2./rpi * (pr_asym - pr_neut)
+
+RETURN
+
+END SUBROUTINE atke_ini
+
+END MODULE  lmdz_atke_turbulence_ini
Index: DZ6/trunk/libf/phylmd/lmdz_blowing_snow_ini.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/lmdz_blowing_snow_ini.F90	(revision 5267)
+++ 	(revision )
@@ -1,86 +1,0 @@
-module lmdz_blowing_snow_ini
-
-implicit none
-
-   real, save, protected :: RCPD, RV, RLSTT, RLVTT, RLMLT, RVTMP2, RTT,RD,RG, RPI
-   real, save, protected :: coef_sub_bs, fallv_bs, zeta_bs, c_esalt_bs
-   real, save, protected :: prt_bs, pbst_bs, qbst_bs, r_bs
-   integer, save, protected :: iflag_saltation_bs, iflag_sedim_bs, iflag_sublim_bs
-
-   !$OMP THREADPRIVATE(RCPD, RV, RLSTT, RLVTT, RLMLT, RVTMP2, RTT,RD,RG, RPI)
-   !$OMP THREADPRIVATE(coef_sub_bs, fallv_bs, r_bs, zeta_bs, c_esalt_bs)
-   !$OMP THREADPRIVATE(pbst_bs, prt_bs, qbst_bs)
-   !$OMP THREADPRIVATE(iflag_sedim_bs, iflag_sublim_bs)
-
-   real, save, protected :: tbsmelt=278.15    ! parameter to calculate melting fraction of BS sedimentation
-   real, save, protected :: taumeltbs0=600.0  ! Melting time scale of blowing snow at 273.15K
-   real, save, protected :: qbmin=1.E-10      ! Minimum blowing snow specific content
-   !$OMP THREADPRIVATE(tbsmelt, taumeltbs0, qbmin)
-
-   real, save, protected :: tau_dens0_bs=864000.      ! 10 days by default, in s
-   real, save, protected :: tau_densmin_bs= 21600.    ! 1/4 days according to in situ obs by C. Amory during blowing snow +
-                                                      ! Marshall et al. 1999 (snow densification during rain)
-   real, save, protected :: tau_eqsalt_bs= 10.        ! Nemoto and Nishimura 2004 show that steady-state saltation is achieved within a time tau_eqsalt of about 10s
-   real, save, protected :: rhofresh_bs = 300.0       ! fresh snow density kg/m3
-   real, save, protected :: rhohard_bs = 450.0       ! hard snow density kg/m3
-   real, save, protected :: rhoice_bs = 920.0         ! ice density kg/m3
-   real, save, protected :: rhobs=900.0               ! blowing snow density (kg/m3) following Bintanja et al. 2001 part I
-   !$OMP THREADPRIVATE(rhoice_bs, rhofresh_bs, rhohard_bs, tau_dens0_bs, tau_densmin_bs, tau_eqsalt_bs, rhobs)
-
-
-    contains
-
-   subroutine blowing_snow_ini(RCPD_in, RLSTT_in, RLVTT_in, RLMLT_in,&
-                                  RVTMP2_in, RTT_in,RD_in,RG_in, RV_in, RPI_in)
-
-         USE ioipsl_getin_p_mod, ONLY : getin_p
-
-         real, intent(in) :: RCPD_in, RLSTT_in, RLVTT_in, RLMLT_in, RPI_in
-         real, intent(in) ::  RVTMP2_in, RTT_in, RD_in, RG_in, RV_in
-
-
-         RG=RG_in
-         RD=RD_in
-         RV=RV_in
-         RCPD=RCPD_in
-         RLVTT=RLVTT_in
-         RLSTT=RLSTT_in
-         RLMLT=RLMLT_in
-         RTT=RTT_in
-         RG=RG_in
-         RVTMP2=RVTMP2_in
-         RPI=RPI_in
-
-         c_esalt_bs= 3.25
-         CALL getin_p('c_esalt_bs',c_esalt_bs)
-
-         qbst_bs= 0.001
-         CALL getin_p('qbst_bs',qbst_bs)
-
-         pbst_bs= 0.0003
-         CALL getin_p('pbst_bs',pbst_bs)
-
-         prt_bs= 0.0003
-         CALL getin_p('prt_bs',prt_bs)
-
-         zeta_bs= 3.
-         CALL getin_p('zeta_bs',zeta_bs)
-
-         fallv_bs = 0.1
-         CALL getin_p('fallv_bs',fallv_bs)
-
-         coef_sub_bs =  0.1 
-         CALL getin_p('coef_sub_bs',coef_sub_bs)
-
-         iflag_sublim_bs=1
-         CALL getin_p('iflag_sublim_bs',iflag_sublim_bs)
-
-         iflag_sedim_bs=1
-         CALL getin_p('iflag_sedim_bs',iflag_sedim_bs)
-
-         r_bs=150.0e-6
-         CALL getin_p('r_bs',r_bs)
-
-      end subroutine blowing_snow_ini
-
-end module lmdz_blowing_snow_ini
Index: /LMDZ6/trunk/libf/phylmd/lmdz_blowing_snow_ini.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/lmdz_blowing_snow_ini.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/lmdz_blowing_snow_ini.f90	(revision 5268)
@@ -0,0 +1,86 @@
+module lmdz_blowing_snow_ini
+
+implicit none
+
+   real, save, protected :: RCPD, RV, RLSTT, RLVTT, RLMLT, RVTMP2, RTT,RD,RG, RPI
+   real, save, protected :: coef_sub_bs, fallv_bs, zeta_bs, c_esalt_bs
+   real, save, protected :: prt_bs, pbst_bs, qbst_bs, r_bs
+   integer, save, protected :: iflag_saltation_bs, iflag_sedim_bs, iflag_sublim_bs
+
+   !$OMP THREADPRIVATE(RCPD, RV, RLSTT, RLVTT, RLMLT, RVTMP2, RTT,RD,RG, RPI)
+   !$OMP THREADPRIVATE(coef_sub_bs, fallv_bs, r_bs, zeta_bs, c_esalt_bs)
+   !$OMP THREADPRIVATE(pbst_bs, prt_bs, qbst_bs)
+   !$OMP THREADPRIVATE(iflag_sedim_bs, iflag_sublim_bs)
+
+   real, save, protected :: tbsmelt=278.15    ! parameter to calculate melting fraction of BS sedimentation
+   real, save, protected :: taumeltbs0=600.0  ! Melting time scale of blowing snow at 273.15K
+   real, save, protected :: qbmin=1.E-10      ! Minimum blowing snow specific content
+   !$OMP THREADPRIVATE(tbsmelt, taumeltbs0, qbmin)
+
+   real, save, protected :: tau_dens0_bs=864000.      ! 10 days by default, in s
+   real, save, protected :: tau_densmin_bs= 21600.    ! 1/4 days according to in situ obs by C. Amory during blowing snow +
+                                                      ! Marshall et al. 1999 (snow densification during rain)
+   real, save, protected :: tau_eqsalt_bs= 10.        ! Nemoto and Nishimura 2004 show that steady-state saltation is achieved within a time tau_eqsalt of about 10s
+   real, save, protected :: rhofresh_bs = 300.0       ! fresh snow density kg/m3
+   real, save, protected :: rhohard_bs = 450.0       ! hard snow density kg/m3
+   real, save, protected :: rhoice_bs = 920.0         ! ice density kg/m3
+   real, save, protected :: rhobs=900.0               ! blowing snow density (kg/m3) following Bintanja et al. 2001 part I
+   !$OMP THREADPRIVATE(rhoice_bs, rhofresh_bs, rhohard_bs, tau_dens0_bs, tau_densmin_bs, tau_eqsalt_bs, rhobs)
+
+
+    contains
+
+   subroutine blowing_snow_ini(RCPD_in, RLSTT_in, RLVTT_in, RLMLT_in,&
+                                  RVTMP2_in, RTT_in,RD_in,RG_in, RV_in, RPI_in)
+
+         USE ioipsl_getin_p_mod, ONLY : getin_p
+
+         real, intent(in) :: RCPD_in, RLSTT_in, RLVTT_in, RLMLT_in, RPI_in
+         real, intent(in) ::  RVTMP2_in, RTT_in, RD_in, RG_in, RV_in
+
+
+         RG=RG_in
+         RD=RD_in
+         RV=RV_in
+         RCPD=RCPD_in
+         RLVTT=RLVTT_in
+         RLSTT=RLSTT_in
+         RLMLT=RLMLT_in
+         RTT=RTT_in
+         RG=RG_in
+         RVTMP2=RVTMP2_in
+         RPI=RPI_in
+
+         c_esalt_bs= 3.25
+         CALL getin_p('c_esalt_bs',c_esalt_bs)
+
+         qbst_bs= 0.001
+         CALL getin_p('qbst_bs',qbst_bs)
+
+         pbst_bs= 0.0003
+         CALL getin_p('pbst_bs',pbst_bs)
+
+         prt_bs= 0.0003
+         CALL getin_p('prt_bs',prt_bs)
+
+         zeta_bs= 3.
+         CALL getin_p('zeta_bs',zeta_bs)
+
+         fallv_bs = 0.1
+         CALL getin_p('fallv_bs',fallv_bs)
+
+         coef_sub_bs =  0.1 
+         CALL getin_p('coef_sub_bs',coef_sub_bs)
+
+         iflag_sublim_bs=1
+         CALL getin_p('iflag_sublim_bs',iflag_sublim_bs)
+
+         iflag_sedim_bs=1
+         CALL getin_p('iflag_sedim_bs',iflag_sedim_bs)
+
+         r_bs=150.0e-6
+         CALL getin_p('r_bs',r_bs)
+
+      end subroutine blowing_snow_ini
+
+end module lmdz_blowing_snow_ini
Index: DZ6/trunk/libf/phylmd/lmdz_blowing_snow_sublim_sedim.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/lmdz_blowing_snow_sublim_sedim.F90	(revision 5267)
+++ 	(revision )
@@ -1,295 +1,0 @@
-module lmdz_blowing_snow_sublim_sedim
-
-contains
-subroutine blowing_snow_sublim_sedim(ngrid,nlay,dtime,temp,qv,qb,pplay,paprs,dtemp_bs,dqv_bs,dqb_bs,bsfl,precip_bs)
-
-!==============================================================================
-! Routine that calculates the evaporation and sedimentation of blowing snow
-! inspired by what is done in lscp_mod
-! Etienne Vignon, October 2022
-!==============================================================================
-
-
-use lmdz_blowing_snow_ini, only : iflag_sublim_bs, iflag_sedim_bs, coef_sub_bs,RTT,RD,RG,fallv_bs
-use lmdz_blowing_snow_ini, only : qbmin, RCPD, RLSTT, RLMLT, RLVTT, RVTMP2, RV, RPI, tbsmelt, taumeltbs0, rhobs, r_bs
-USE lmdz_lscp_tools, only : calc_qsat_ecmwf
-
-implicit none
-
-
-!++++++++++++++++++++++++++++++++++++++++++++++++++++
-! Declarations
-!++++++++++++++++++++++++++++++++++++++++++++++++++++
-
-!INPUT
-!=====
-
-integer, intent(in)                     :: ngrid,nlay
-real, intent(in)                        :: dtime
-real, intent(in), dimension(ngrid,nlay) :: temp
-real, intent(in), dimension(ngrid,nlay) :: qv
-real, intent(in), dimension(ngrid,nlay) :: qb
-real, intent(in), dimension(ngrid,nlay) :: pplay
-real, intent(in), dimension(ngrid,nlay+1) :: paprs
-
-
-
-! OUTPUT
-!========
-
-
-real, intent(out), dimension(ngrid,nlay) :: dtemp_bs
-real, intent(out), dimension(ngrid,nlay) :: dqv_bs
-real, intent(out), dimension(ngrid,nlay) :: dqb_bs
-real, intent(out), dimension(ngrid,nlay+1) :: bsfl
-real, intent(out), dimension(ngrid)      :: precip_bs
-
-
-! LOCAL
-!======
-
-
-integer                                  :: k,i,n
-real                                     :: cpd, cpw, dqbsub, maxdqbsub, dqbmelt, zmair
-real                                     :: dqsedim,precbs, dqvmelt, zmelt, taumeltbs
-real                                     :: maxdqvmelt, rhoair, dz, dqbsedim
-real                                     :: delta_p, b_p, a_p, c_p, c_sub, qvsub
-real                                     :: p0, T0, Dv, Aprime, Bprime, Ka
-real, dimension(ngrid)                   :: ztemp,zqv,zqb,zpres,qsi,dqsi,qsl,dqsl,qzero,sedim
-real, dimension(ngrid)                   :: zpaprsup, zpaprsdn, ztemp_up, zqb_up, zvelo
-real, dimension(ngrid,nlay)              :: temp_seri, qb_seri, qv_seri
-
-!++++++++++++++++++++++++++++++++++++++++++++++++++
-! Initialisation
-!++++++++++++++++++++++++++++++++++++++++++++++++++
-
-qzero(:)=0.
-dtemp_bs(:,:)=0.
-dqv_bs(:,:)=0.
-dqb_bs(:,:)=0.
-zvelo(:)=0.
-sedim(:)=0.
-precip_bs(:)=0.
-bsfl(:,:)=0.
-
-
-p0=101325.0    ! ref pressure
-
-
-DO k=1,nlay
-   DO i=1,ngrid
-      temp_seri(i,k)=temp(i,k)
-      qv_seri(i,k)=qv(i,k)
-      qb_seri(i,k)=qb(i,k)
-   ENDDO
-ENDDO
-
-
-! Sedimentation scheme
-!----------------------
-
-IF (iflag_sedim_bs .GT. 0) THEN
-! begin of top-down loop
-DO k = nlay, 1, -1
-    
-    DO i=1,ngrid
-        ztemp(i)=temp_seri(i,k)
-        zqv(i)=qv_seri(i,k)
-        zqb(i)=qb_seri(i,k)
-        zpres(i)=pplay(i,k)
-        zpaprsup(i)=paprs(i,k+1)
-        zpaprsdn(i)=paprs(i,k)
-    ENDDO
-
-    ! thermalization of blowing snow precip coming from above     
-    IF (k.LE.nlay-1) THEN
-
-        DO i = 1, ngrid
-            zmair=(zpaprsdn(i)-zpaprsup(i))/RG
-            ! RVTMP2=rcpv/rcpd-1
-            cpd=RCPD*(1.0+RVTMP2*zqv(i))
-            cpw=RCPD*RVTMP2
-            ! zqb_up: blowing snow mass that has to be thermalized with 
-            ! layer's air so that precipitation at the ground has the
-            ! same temperature as the lowermost layer
-            zqb_up(i) = sedim(i)*dtime/zmair
-            ztemp_up(i)=temp_seri(i,k+1)
-
-            ! t(i,k+1)+d_t(i,k+1): new temperature of the overlying layer
-            ztemp(i) = ( ztemp_up(i)*zqb_up(i)*cpw + cpd*ztemp(i) ) &
-                  / (cpd + zqb_up(i)*cpw)
-        ENDDO
-
-     ENDIF
-
-     DO i = 1, ngrid
-
-       rhoair  = zpres(i) / ztemp(i) / RD
-       dz      = (zpaprsdn(i)-zpaprsup(i)) / (rhoair*RG)
-       ! BS fall velocity assumed to be constant for now
-       zvelo(i) = fallv_bs
-       ! dqb/dt_sedim=1/rho(sedim/dz - rho w qb/dz)
-       ! implicit resolution 
-       dqbsedim = (sedim(i)/rhoair/dz*dtime+zqb(i))/(1.+zvelo(i)*dtime/dz) - zqb(i)
-       ! flux and dqb update
-       zqb(i)=zqb(i)+dqbsedim
-       !sedim(i) = sedim(i)-dqbsedim/dtime*rhoair*dz
-       sedim(i)=rhoair*zvelo(i)*zqb(i)
-
-
-       ! variables update:
-       bsfl(i,k)=sedim(i)
-
-       qb_seri(i,k) = zqb(i)
-       qv_seri(i,k) = zqv(i) 
-       temp_seri(i,k) = ztemp(i) 
-
-     ENDDO ! Loop on ngrid
-
-
-ENDDO ! vertical loop
-
-
-!surface bs flux
-DO i = 1, ngrid
-  precip_bs(i) = sedim(i)
-ENDDO
-
-ENDIF
-
-
-
-
-!+++++++++++++++++++++++++++++++++++++++++++++++
-! Sublimation and melting
-!++++++++++++++++++++++++++++++++++++++++++++++
-IF (iflag_sublim_bs .GT. 0) THEN
-
-DO k = 1, nlay
-
-    DO i=1,ngrid
-        ztemp(i)=temp_seri(i,k)
-        zqv(i)=qv_seri(i,k)
-        zqb(i)=qb_seri(i,k)
-        zpres(i)=pplay(i,k)
-        zpaprsup(i)=paprs(i,k+1)
-        zpaprsdn(i)=paprs(i,k)
-    ENDDO
-
-   ! calulation saturation specific humidity
-    CALL CALC_QSAT_ECMWF(ngrid,ztemp(:),qzero(:),zpres(:),RTT,2,.false.,qsi(:),dqsi(:))
-
-
-    DO i = 1, ngrid
-
-          rhoair  = zpres(i) / ztemp(i) / RD
-          dz      = (zpaprsdn(i)-zpaprsup(i)) / (rhoair*RG)
-          ! BS fall velocity assumed to be constant for now
-          zvelo(i) = fallv_bs
-
-
-          IF (ztemp(i) .GT. RTT) THEN
-
-             ! if temperature is positive, we assume that part of the blowing snow 
-             ! already present  melts and evaporates with a typical time 
-             ! constant taumeltbs
-
-             taumeltbs=taumeltbs0*exp(-max(0.,(ztemp(i)-RTT)/(tbsmelt-RTT)))
-             dqvmelt=min(zqb(i),-1.*zqb(i)*(exp(-dtime/taumeltbs)-1.))
-             maxdqvmelt= max(RCPD*(1.0+RVTMP2*(zqv(i)+zqb(i)))*(ztemp(i)-RTT)/(RLMLT+RLVTT),0.)
-             dqvmelt=min(dqvmelt,maxdqvmelt)
-             ! qv update, melting + evaporation
-             zqv(i) = zqv(i) + dqvmelt
-             ! temp update melting + evaporation
-             ztemp(i) = ztemp(i) - dqvmelt * (RLMLT+RLVTT)/RCPD/(1.0+RVTMP2*(zqv(i)+zqb(i)))
-             ! qb update melting + evaporation
-             zqb(i)=zqb(i)-dqvmelt
-
-          ELSE
-              ! negative celcius temperature     
-              ! Sublimation scheme   
-
-
-              ! Sublimation formulation for ice crystals from Pruppacher & Klett, Rutledge & Hobbs 1983
-              ! assuming monodispered crystal distrib
-              ! dqb/dt_sub=-coef_sub_bs*(1-qv/qsi)*nc*8*r_bs/(Aprime+Bprime)
-              ! assuming Mi=rhobs*4/3*pi*r_bs**3 
-              ! rhoair qb=nc*Mi -> nc=rhoair qb/Mi
-              ! dqb/dt_sub=-coef_sub_bs*(1-qv/qsi)*6*rhoair*qb/(rhobs*pi*r_bs**2)/(Aprime+Bprime)
-              ! dqb/dt_sub=-c_sub(1-qv/qsi)*qb
-              ! c_sub=coef_sub_bs*6*rhoair/(rhobs*pi*r_bs**2)/(Aprime+Bprime)
-              ! 
-              ! Note the strong coupling between specific contents of water vapor and blowing snow during sublimation
-              ! equations dqv/dt_sub and dqb/dt_sub must be solved jointly to prevent irrealistic increase of water vapor
-              ! at typical physics time steps
-              ! we thus solve the differential equation using an implicit scheme for both qb and qv
- 
-              ! we do not consider deposition, only sublimation
-              IF (zqv(i) .LT. qsi(i)) THEN
-                 rhoair=zpres(i)/ztemp(i)/RD
-                 Dv=0.0001*0.211*(p0/zpres(i))*((ztemp(i)/RTT)**1.94) ! water vapor diffusivity in air, SI
-                 Ka=(5.69+0.017*(ztemp(i)-RTT))*1.e-5*100.*4.184                ! thermal conductivity of the air, SI
-                 Aprime=RLSTT/Ka/ztemp(i)*(RLSTT/RV/ztemp(i) -1.)
-                 Bprime=1./(rhoair*Dv*qsi(i)) 
-                 c_sub=coef_sub_bs*6.*rhoair/(rhobs*RPI*r_bs**2)/(Aprime+Bprime)
-                 c_p=-zqb(i)
-                 b_p=1.+c_sub*dtime-c_sub*dtime/qsi(i)*zqb(i)-c_sub*dtime/qsi(i)*zqv(i)
-                 a_p=c_sub*dtime/qsi(i)
-                 delta_p=(b_p**2)-4.*a_p*c_p  
-                 dqbsub=(-b_p+sqrt(delta_p))/(2.*a_p) - zqb(i)       
-                 dqbsub = MIN(0.0,MAX(dqbsub,-zqb(i)))
-                 ! Sublimation limit: we ensure that the whole mesh does not exceed saturation wrt ice
-                 maxdqbsub = MAX(0.0, qsi(i)-zqv(i))
-                 dqbsub = MAX(dqbsub,-maxdqbsub)
-              ELSE
-                 dqbsub=0.
-              ENDIF
-
-              ! vapor, temperature, precip fluxes update following sublimation
-              zqv(i) = zqv(i) - dqbsub
-              zqb(i) = zqb(i) + dqbsub
-              ztemp(i) = ztemp(i) + dqbsub*RLSTT/RCPD/(1.0+RVTMP2*(zqv(i)+zqb(i)))
-
-          ENDIF
-
-          ! if qb<qbmin, sublimate or melt and evaporate qb
-          ! see Gerber et al. 2023, JGR Atmos for the choice of qbmin
-
-          IF (zqb(i) .LT. qbmin) THEN
-              zqv(i) = zqv(i)+zqb(i)
-              IF (ztemp(i) .LT. RTT) THEN
-                 ztemp(i) = ztemp(i) - zqb(i) * RLSTT/RCPD/(1.0+RVTMP2*(zqv(i)))
-              ELSE
-                 ztemp(i) = ztemp(i) - zqb(i) * (RLVTT+RLMLT)/RCPD/(1.0+RVTMP2*(zqv(i)))
-              ENDIF
-              zqb(i)=0.
-          ENDIF
-
-     ! variables update
-     temp_seri(i,k)=ztemp(i)
-     qv_seri(i,k)=zqv(i)
-     qb_seri(i,k)=zqb(i)
-     ENDDO
-ENDDO
-
-ENDIF
-
-
-! OUTPUTS
-!++++++++++
-
-! 3D variables
-DO k=1,nlay
-   DO i=1,ngrid
-        dqb_bs(i,k) = qb_seri(i,k) - qb(i,k)
-        dqv_bs(i,k) = qv_seri(i,k) - qv(i,k)
-        dtemp_bs(i,k) = temp_seri(i,k) - temp(i,k)
-   ENDDO
-ENDDO
-
-
-
-return
-
-end subroutine blowing_snow_sublim_sedim
-end module lmdz_blowing_snow_sublim_sedim
Index: /LMDZ6/trunk/libf/phylmd/lmdz_blowing_snow_sublim_sedim.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/lmdz_blowing_snow_sublim_sedim.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/lmdz_blowing_snow_sublim_sedim.f90	(revision 5268)
@@ -0,0 +1,295 @@
+module lmdz_blowing_snow_sublim_sedim
+
+contains
+subroutine blowing_snow_sublim_sedim(ngrid,nlay,dtime,temp,qv,qb,pplay,paprs,dtemp_bs,dqv_bs,dqb_bs,bsfl,precip_bs)
+
+!==============================================================================
+! Routine that calculates the evaporation and sedimentation of blowing snow
+! inspired by what is done in lscp_mod
+! Etienne Vignon, October 2022
+!==============================================================================
+
+
+use lmdz_blowing_snow_ini, only : iflag_sublim_bs, iflag_sedim_bs, coef_sub_bs,RTT,RD,RG,fallv_bs
+use lmdz_blowing_snow_ini, only : qbmin, RCPD, RLSTT, RLMLT, RLVTT, RVTMP2, RV, RPI, tbsmelt, taumeltbs0, rhobs, r_bs
+USE lmdz_lscp_tools, only : calc_qsat_ecmwf
+
+implicit none
+
+
+!++++++++++++++++++++++++++++++++++++++++++++++++++++
+! Declarations
+!++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+!INPUT
+!=====
+
+integer, intent(in)                     :: ngrid,nlay
+real, intent(in)                        :: dtime
+real, intent(in), dimension(ngrid,nlay) :: temp
+real, intent(in), dimension(ngrid,nlay) :: qv
+real, intent(in), dimension(ngrid,nlay) :: qb
+real, intent(in), dimension(ngrid,nlay) :: pplay
+real, intent(in), dimension(ngrid,nlay+1) :: paprs
+
+
+
+! OUTPUT
+!========
+
+
+real, intent(out), dimension(ngrid,nlay) :: dtemp_bs
+real, intent(out), dimension(ngrid,nlay) :: dqv_bs
+real, intent(out), dimension(ngrid,nlay) :: dqb_bs
+real, intent(out), dimension(ngrid,nlay+1) :: bsfl
+real, intent(out), dimension(ngrid)      :: precip_bs
+
+
+! LOCAL
+!======
+
+
+integer                                  :: k,i,n
+real                                     :: cpd, cpw, dqbsub, maxdqbsub, dqbmelt, zmair
+real                                     :: dqsedim,precbs, dqvmelt, zmelt, taumeltbs
+real                                     :: maxdqvmelt, rhoair, dz, dqbsedim
+real                                     :: delta_p, b_p, a_p, c_p, c_sub, qvsub
+real                                     :: p0, T0, Dv, Aprime, Bprime, Ka
+real, dimension(ngrid)                   :: ztemp,zqv,zqb,zpres,qsi,dqsi,qsl,dqsl,qzero,sedim
+real, dimension(ngrid)                   :: zpaprsup, zpaprsdn, ztemp_up, zqb_up, zvelo
+real, dimension(ngrid,nlay)              :: temp_seri, qb_seri, qv_seri
+
+!++++++++++++++++++++++++++++++++++++++++++++++++++
+! Initialisation
+!++++++++++++++++++++++++++++++++++++++++++++++++++
+
+qzero(:)=0.
+dtemp_bs(:,:)=0.
+dqv_bs(:,:)=0.
+dqb_bs(:,:)=0.
+zvelo(:)=0.
+sedim(:)=0.
+precip_bs(:)=0.
+bsfl(:,:)=0.
+
+
+p0=101325.0    ! ref pressure
+
+
+DO k=1,nlay
+   DO i=1,ngrid
+      temp_seri(i,k)=temp(i,k)
+      qv_seri(i,k)=qv(i,k)
+      qb_seri(i,k)=qb(i,k)
+   ENDDO
+ENDDO
+
+
+! Sedimentation scheme
+!----------------------
+
+IF (iflag_sedim_bs .GT. 0) THEN
+! begin of top-down loop
+DO k = nlay, 1, -1
+    
+    DO i=1,ngrid
+        ztemp(i)=temp_seri(i,k)
+        zqv(i)=qv_seri(i,k)
+        zqb(i)=qb_seri(i,k)
+        zpres(i)=pplay(i,k)
+        zpaprsup(i)=paprs(i,k+1)
+        zpaprsdn(i)=paprs(i,k)
+    ENDDO
+
+    ! thermalization of blowing snow precip coming from above     
+    IF (k.LE.nlay-1) THEN
+
+        DO i = 1, ngrid
+            zmair=(zpaprsdn(i)-zpaprsup(i))/RG
+            ! RVTMP2=rcpv/rcpd-1
+            cpd=RCPD*(1.0+RVTMP2*zqv(i))
+            cpw=RCPD*RVTMP2
+            ! zqb_up: blowing snow mass that has to be thermalized with 
+            ! layer's air so that precipitation at the ground has the
+            ! same temperature as the lowermost layer
+            zqb_up(i) = sedim(i)*dtime/zmair
+            ztemp_up(i)=temp_seri(i,k+1)
+
+            ! t(i,k+1)+d_t(i,k+1): new temperature of the overlying layer
+            ztemp(i) = ( ztemp_up(i)*zqb_up(i)*cpw + cpd*ztemp(i) ) &
+                  / (cpd + zqb_up(i)*cpw)
+        ENDDO
+
+     ENDIF
+
+     DO i = 1, ngrid
+
+       rhoair  = zpres(i) / ztemp(i) / RD
+       dz      = (zpaprsdn(i)-zpaprsup(i)) / (rhoair*RG)
+       ! BS fall velocity assumed to be constant for now
+       zvelo(i) = fallv_bs
+       ! dqb/dt_sedim=1/rho(sedim/dz - rho w qb/dz)
+       ! implicit resolution 
+       dqbsedim = (sedim(i)/rhoair/dz*dtime+zqb(i))/(1.+zvelo(i)*dtime/dz) - zqb(i)
+       ! flux and dqb update
+       zqb(i)=zqb(i)+dqbsedim
+       !sedim(i) = sedim(i)-dqbsedim/dtime*rhoair*dz
+       sedim(i)=rhoair*zvelo(i)*zqb(i)
+
+
+       ! variables update:
+       bsfl(i,k)=sedim(i)
+
+       qb_seri(i,k) = zqb(i)
+       qv_seri(i,k) = zqv(i) 
+       temp_seri(i,k) = ztemp(i) 
+
+     ENDDO ! Loop on ngrid
+
+
+ENDDO ! vertical loop
+
+
+!surface bs flux
+DO i = 1, ngrid
+  precip_bs(i) = sedim(i)
+ENDDO
+
+ENDIF
+
+
+
+
+!+++++++++++++++++++++++++++++++++++++++++++++++
+! Sublimation and melting
+!++++++++++++++++++++++++++++++++++++++++++++++
+IF (iflag_sublim_bs .GT. 0) THEN
+
+DO k = 1, nlay
+
+    DO i=1,ngrid
+        ztemp(i)=temp_seri(i,k)
+        zqv(i)=qv_seri(i,k)
+        zqb(i)=qb_seri(i,k)
+        zpres(i)=pplay(i,k)
+        zpaprsup(i)=paprs(i,k+1)
+        zpaprsdn(i)=paprs(i,k)
+    ENDDO
+
+   ! calulation saturation specific humidity
+    CALL CALC_QSAT_ECMWF(ngrid,ztemp(:),qzero(:),zpres(:),RTT,2,.false.,qsi(:),dqsi(:))
+
+
+    DO i = 1, ngrid
+
+          rhoair  = zpres(i) / ztemp(i) / RD
+          dz      = (zpaprsdn(i)-zpaprsup(i)) / (rhoair*RG)
+          ! BS fall velocity assumed to be constant for now
+          zvelo(i) = fallv_bs
+
+
+          IF (ztemp(i) .GT. RTT) THEN
+
+             ! if temperature is positive, we assume that part of the blowing snow 
+             ! already present  melts and evaporates with a typical time 
+             ! constant taumeltbs
+
+             taumeltbs=taumeltbs0*exp(-max(0.,(ztemp(i)-RTT)/(tbsmelt-RTT)))
+             dqvmelt=min(zqb(i),-1.*zqb(i)*(exp(-dtime/taumeltbs)-1.))
+             maxdqvmelt= max(RCPD*(1.0+RVTMP2*(zqv(i)+zqb(i)))*(ztemp(i)-RTT)/(RLMLT+RLVTT),0.)
+             dqvmelt=min(dqvmelt,maxdqvmelt)
+             ! qv update, melting + evaporation
+             zqv(i) = zqv(i) + dqvmelt
+             ! temp update melting + evaporation
+             ztemp(i) = ztemp(i) - dqvmelt * (RLMLT+RLVTT)/RCPD/(1.0+RVTMP2*(zqv(i)+zqb(i)))
+             ! qb update melting + evaporation
+             zqb(i)=zqb(i)-dqvmelt
+
+          ELSE
+              ! negative celcius temperature     
+              ! Sublimation scheme   
+
+
+              ! Sublimation formulation for ice crystals from Pruppacher & Klett, Rutledge & Hobbs 1983
+              ! assuming monodispered crystal distrib
+              ! dqb/dt_sub=-coef_sub_bs*(1-qv/qsi)*nc*8*r_bs/(Aprime+Bprime)
+              ! assuming Mi=rhobs*4/3*pi*r_bs**3 
+              ! rhoair qb=nc*Mi -> nc=rhoair qb/Mi
+              ! dqb/dt_sub=-coef_sub_bs*(1-qv/qsi)*6*rhoair*qb/(rhobs*pi*r_bs**2)/(Aprime+Bprime)
+              ! dqb/dt_sub=-c_sub(1-qv/qsi)*qb
+              ! c_sub=coef_sub_bs*6*rhoair/(rhobs*pi*r_bs**2)/(Aprime+Bprime)
+              ! 
+              ! Note the strong coupling between specific contents of water vapor and blowing snow during sublimation
+              ! equations dqv/dt_sub and dqb/dt_sub must be solved jointly to prevent irrealistic increase of water vapor
+              ! at typical physics time steps
+              ! we thus solve the differential equation using an implicit scheme for both qb and qv
+ 
+              ! we do not consider deposition, only sublimation
+              IF (zqv(i) .LT. qsi(i)) THEN
+                 rhoair=zpres(i)/ztemp(i)/RD
+                 Dv=0.0001*0.211*(p0/zpres(i))*((ztemp(i)/RTT)**1.94) ! water vapor diffusivity in air, SI
+                 Ka=(5.69+0.017*(ztemp(i)-RTT))*1.e-5*100.*4.184                ! thermal conductivity of the air, SI
+                 Aprime=RLSTT/Ka/ztemp(i)*(RLSTT/RV/ztemp(i) -1.)
+                 Bprime=1./(rhoair*Dv*qsi(i)) 
+                 c_sub=coef_sub_bs*6.*rhoair/(rhobs*RPI*r_bs**2)/(Aprime+Bprime)
+                 c_p=-zqb(i)
+                 b_p=1.+c_sub*dtime-c_sub*dtime/qsi(i)*zqb(i)-c_sub*dtime/qsi(i)*zqv(i)
+                 a_p=c_sub*dtime/qsi(i)
+                 delta_p=(b_p**2)-4.*a_p*c_p  
+                 dqbsub=(-b_p+sqrt(delta_p))/(2.*a_p) - zqb(i)       
+                 dqbsub = MIN(0.0,MAX(dqbsub,-zqb(i)))
+                 ! Sublimation limit: we ensure that the whole mesh does not exceed saturation wrt ice
+                 maxdqbsub = MAX(0.0, qsi(i)-zqv(i))
+                 dqbsub = MAX(dqbsub,-maxdqbsub)
+              ELSE
+                 dqbsub=0.
+              ENDIF
+
+              ! vapor, temperature, precip fluxes update following sublimation
+              zqv(i) = zqv(i) - dqbsub
+              zqb(i) = zqb(i) + dqbsub
+              ztemp(i) = ztemp(i) + dqbsub*RLSTT/RCPD/(1.0+RVTMP2*(zqv(i)+zqb(i)))
+
+          ENDIF
+
+          ! if qb<qbmin, sublimate or melt and evaporate qb
+          ! see Gerber et al. 2023, JGR Atmos for the choice of qbmin
+
+          IF (zqb(i) .LT. qbmin) THEN
+              zqv(i) = zqv(i)+zqb(i)
+              IF (ztemp(i) .LT. RTT) THEN
+                 ztemp(i) = ztemp(i) - zqb(i) * RLSTT/RCPD/(1.0+RVTMP2*(zqv(i)))
+              ELSE
+                 ztemp(i) = ztemp(i) - zqb(i) * (RLVTT+RLMLT)/RCPD/(1.0+RVTMP2*(zqv(i)))
+              ENDIF
+              zqb(i)=0.
+          ENDIF
+
+     ! variables update
+     temp_seri(i,k)=ztemp(i)
+     qv_seri(i,k)=zqv(i)
+     qb_seri(i,k)=zqb(i)
+     ENDDO
+ENDDO
+
+ENDIF
+
+
+! OUTPUTS
+!++++++++++
+
+! 3D variables
+DO k=1,nlay
+   DO i=1,ngrid
+        dqb_bs(i,k) = qb_seri(i,k) - qb(i,k)
+        dqv_bs(i,k) = qv_seri(i,k) - qv(i,k)
+        dtemp_bs(i,k) = temp_seri(i,k) - temp(i,k)
+   ENDDO
+ENDDO
+
+
+
+return
+
+end subroutine blowing_snow_sublim_sedim
+end module lmdz_blowing_snow_sublim_sedim
Index: DZ6/trunk/libf/phylmd/lmdz_call_atke.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/lmdz_call_atke.F90	(revision 5267)
+++ 	(revision )
@@ -1,174 +1,0 @@
-module lmdz_call_atke
-
-USE lmdz_atke_exchange_coeff, ONLY :  atke_compute_km_kh
-
-implicit none
-
-
-contains
-
-subroutine call_atke(dtime,ngrid,nlay,nsrf,ni,cdrag_uv,cdrag_t,u_surf,v_surf,temp_surf, &
-                        wind_u,wind_v,temp,qvap,play,pinterf, &
-                        tke,eps,Km_out,Kh_out)
-
-
-
-
-USE lmdz_atke_turbulence_ini, ONLY : iflag_num_atke, rg, rd
-USE phys_local_var_mod, ONLY: tke_shear, tke_buoy, tke_trans
-
-implicit none
-
-
-! Declarations:
-!=============
-
-REAL, INTENT(IN)    :: dtime ! timestep (s)
-INTEGER, INTENT(IN) :: ngrid ! number of horizontal index (flat grid)
-INTEGER, INTENT(IN) :: nlay ! number of vertical index  
-INTEGER, INTENT(IN) :: nsrf ! surface tile index
-INTEGER, DIMENSION(ngrid), INTENT(IN) :: ni ! array of indices to move from knon to klon arrays
-
-
-REAL, DIMENSION(ngrid), INTENT(IN)       :: cdrag_uv  ! drag coefficient for wind
-REAL, DIMENSION(ngrid), INTENT(IN)       :: cdrag_t   ! drag coefficient for temperature
-
-REAL, DIMENSION(ngrid), INTENT(IN)       :: u_surf    ! x wind velocity at the surface
-REAL, DIMENSION(ngrid), INTENT(IN)       :: v_surf    ! y wind velocity at the surface
-REAL, DIMENSION(ngrid), INTENT(IN)       :: temp_surf ! surface temperature
-
-REAL, DIMENSION(ngrid,nlay), INTENT(IN)       :: wind_u   ! zonal velocity (m/s)
-REAL, DIMENSION(ngrid,nlay), INTENT(IN)       :: wind_v   ! meridional velocity (m/s)
-REAL, DIMENSION(ngrid,nlay), INTENT(IN)       :: temp   ! temperature (K)
-REAL, DIMENSION(ngrid,nlay), INTENT(IN)       :: qvap   ! specific humidity (kg/kg)
-REAL, DIMENSION(ngrid,nlay), INTENT(IN)       :: play   ! pressure (Pa)
-REAL, DIMENSION(ngrid,nlay+1), INTENT(IN)     :: pinterf   ! pressure at interfaces(Pa)
-
-
-REAL, DIMENSION(ngrid,nlay+1), INTENT(INOUT)  :: tke      ! turbulent kinetic energy at interface between layers
-
-REAL, DIMENSION(ngrid,nlay+1), INTENT(OUT)    :: eps      ! output: tke dissipation rate at interface between layers
-REAL, DIMENSION(ngrid,nlay), INTENT(OUT)      :: Km_out   ! output: Exchange coefficient for momentum at interface between layers
-REAL, DIMENSION(ngrid,nlay), INTENT(OUT)      :: Kh_out   ! output: Exchange coefficient for heat flux at interface between layers
-
-
-REAL, DIMENSION(ngrid,nlay+1) :: tke_shear_term,tke_buoy_term,tke_trans_term
-REAL, DIMENSION(ngrid,nlay) :: wind_u_predict, wind_v_predict
-REAL, DIMENSION(ngrid) ::  wind1
-INTEGER i,j,k
-
-
-call atke_compute_km_kh(ngrid,nlay,dtime,&
-                        wind_u,wind_v,temp,qvap,play,pinterf,cdrag_uv,&
-                        tke,eps,tke_shear_term,tke_buoy_term,tke_trans_term,Km_out,Kh_out)
-
-
-                               
-if (iflag_num_atke .EQ. 1) then
-   !! In this case, we make an explicit prediction of the wind shear to calculate the tke in a
-   !! forward backward way
-   !! pay attention that the treatment of the TKE
-   !! has to be adapted when solving the TKE with a prognostic equation
-
-   do i=1,ngrid
-      wind1(i)=sqrt(wind_u(i,1)**2+wind_v(i,1)**2)
-   enddo
-   call atke_explicit_prediction(ngrid,nlay,rg,rd,dtime,pinterf,play,temp,wind1,wind_u,Km_out,u_surf,cdrag_uv,wind_u_predict)  
-   call atke_explicit_prediction(ngrid,nlay,rg,rd,dtime,pinterf,play,temp,wind1,wind_v,Km_out,v_surf,cdrag_uv,wind_v_predict)
-
-
-   call atke_compute_km_kh(ngrid,nlay,dtime,&
-                        wind_u_predict,wind_v_predict,temp,qvap,play,pinterf,cdrag_uv, &
-                        tke,eps,tke_shear_term,tke_buoy_term,tke_trans_term,Km_out,Kh_out)
-
-end if
-
-
-! Diagnostics of tke loss/source terms
-
- DO k=1,nlay+1
-    DO i=1,ngrid
-       j=ni(i)
-       tke_shear(j,k,nsrf)=tke_shear_term(i,k)
-       tke_buoy(j,k,nsrf)=tke_buoy_term(i,k)
-       tke_trans(j,k,nsrf)=tke_trans_term(i,k)
-    ENDDO
- ENDDO
-
-
-
-end subroutine call_atke
-
-!----------------------------------------------------------------------------------------
-
-subroutine atke_explicit_prediction(ngrid,nlay,rg,rd,dtime,pinterf,play,temp,wind1,x_in,K_in,x_surf,cdrag,x_predict)
-
-INTEGER, INTENT(IN) :: ngrid ! number of horizontal index (flat grid)
-INTEGER, INTENT(IN) :: nlay ! number of vertical index  
-REAL, INTENT(IN) :: rg,rd,dtime ! gravity, R dry air and timestep
-REAL, DIMENSION(ngrid,nlay),   INTENT(IN)  :: play      ! pressure middle of layers (Pa)
-REAL, DIMENSION(ngrid,nlay),   INTENT(IN)  :: temp      ! temperature (K)
-REAL, DIMENSION(ngrid),        INTENT(IN)  :: wind1     ! wind speed first level (m/s)
-REAL, DIMENSION(ngrid,nlay+1), INTENT(IN)  :: pinterf ! pressure at interfaces(Pa)
-REAL, DIMENSION(ngrid,nlay),   INTENT(IN)  :: x_in    ! variable at the beginning of timestep
-REAL, DIMENSION(ngrid,nlay+1), INTENT(IN)  :: K_in    ! eddy diffusivity coef at the beginning of time step
-REAL, DIMENSION(ngrid),        INTENT(IN)  :: x_surf  ! surface variable
-REAL, DIMENSION(ngrid),        INTENT(IN)  :: cdrag  ! drag coefficient
-REAL, DIMENSION(ngrid,nlay),   INTENT(OUT) :: x_predict  ! variable at the end of time step after explicit prediction
-
-
-integer i,k
-real ml,F1,rho
-real, dimension(ngrid) :: play1,temp1
-real, dimension(ngrid,nlay+1) :: K_big
-
-! computation of K_big
-
-play1(:)=play(:,1)
-temp1(:)=temp(:,1)
-
-! "big K" calculation
-do  k=2,nlay-1
-   do i=1,ngrid
-      rho=pinterf(i,k)/rd/(0.5*(temp(i,k-1)+temp(i,k)))
-      K_big(i,k)=rg*K_in(i,k)/(play(i,k)-play(i,k+1))*(rho**2)
-   enddo
-enddo
-! speficic treatment for k=nlay
-do i=1,ngrid
-   rho=pinterf(i,nlay)/rd/temp(i,nlay)
-   K_big(i,nlay)=rg*K_in(i,nlay)/(2*(play(i,nlay)-pinterf(i,nlay+1)))*(rho**2)
-enddo
-
-
-
-! x_predict calculation for 2<=k<=nlay-1
-do  k=2,nlay-1
-   do i=1,ngrid
-      ml=(pinterf(i,k)-pinterf(i,k+1))/rg
-      x_predict(i,k)=x_in(i,k)-dtime/ml*(-K_big(i,k+1)*x_in(i,k+1) &
-                  + (K_big(i,k)+K_big(i,k+1))*x_in(i,k) &
-                  - K_big(i,k)*x_in(i,k-1))
-   enddo
-enddo
-
-! Specific treatment for k=1 
-do i=1,ngrid
-   ml=(pinterf(i,1)-pinterf(i,2))/rg
-   F1=-play1(i)/rd/temp1(i)*wind1(i)*cdrag(i)*(x_in(i,1)-x_surf(i)) ! attention convention sens du flux
-   x_predict(i,1)=x_in(i,1)-dtime/ml*(-K_big(i,2)*(x_in(i,2) - x_in(i,1))-F1)
-enddo
-
-! Specific treatment for k=nlay
-! flux at the top of the atmosphere=0
-do i=1,ngrid
-   ml=0.5*(pinterf(i,nlay)-pinterf(i,nlay+1))/rg
-   x_predict(i,nlay)=x_in(i,nlay)+dtime/ml*(K_big(i,nlay)*(x_in(i,nlay)-x_in(i,nlay-1)))
-enddo
-
-
-end subroutine atke_explicit_prediction
-
-
-
-end module lmdz_call_atke
Index: /LMDZ6/trunk/libf/phylmd/lmdz_call_atke.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/lmdz_call_atke.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/lmdz_call_atke.f90	(revision 5268)
@@ -0,0 +1,174 @@
+module lmdz_call_atke
+
+USE lmdz_atke_exchange_coeff, ONLY :  atke_compute_km_kh
+
+implicit none
+
+
+contains
+
+subroutine call_atke(dtime,ngrid,nlay,nsrf,ni,cdrag_uv,cdrag_t,u_surf,v_surf,temp_surf, &
+                        wind_u,wind_v,temp,qvap,play,pinterf, &
+                        tke,eps,Km_out,Kh_out)
+
+
+
+
+USE lmdz_atke_turbulence_ini, ONLY : iflag_num_atke, rg, rd
+USE phys_local_var_mod, ONLY: tke_shear, tke_buoy, tke_trans
+
+implicit none
+
+
+! Declarations:
+!=============
+
+REAL, INTENT(IN)    :: dtime ! timestep (s)
+INTEGER, INTENT(IN) :: ngrid ! number of horizontal index (flat grid)
+INTEGER, INTENT(IN) :: nlay ! number of vertical index  
+INTEGER, INTENT(IN) :: nsrf ! surface tile index
+INTEGER, DIMENSION(ngrid), INTENT(IN) :: ni ! array of indices to move from knon to klon arrays
+
+
+REAL, DIMENSION(ngrid), INTENT(IN)       :: cdrag_uv  ! drag coefficient for wind
+REAL, DIMENSION(ngrid), INTENT(IN)       :: cdrag_t   ! drag coefficient for temperature
+
+REAL, DIMENSION(ngrid), INTENT(IN)       :: u_surf    ! x wind velocity at the surface
+REAL, DIMENSION(ngrid), INTENT(IN)       :: v_surf    ! y wind velocity at the surface
+REAL, DIMENSION(ngrid), INTENT(IN)       :: temp_surf ! surface temperature
+
+REAL, DIMENSION(ngrid,nlay), INTENT(IN)       :: wind_u   ! zonal velocity (m/s)
+REAL, DIMENSION(ngrid,nlay), INTENT(IN)       :: wind_v   ! meridional velocity (m/s)
+REAL, DIMENSION(ngrid,nlay), INTENT(IN)       :: temp   ! temperature (K)
+REAL, DIMENSION(ngrid,nlay), INTENT(IN)       :: qvap   ! specific humidity (kg/kg)
+REAL, DIMENSION(ngrid,nlay), INTENT(IN)       :: play   ! pressure (Pa)
+REAL, DIMENSION(ngrid,nlay+1), INTENT(IN)     :: pinterf   ! pressure at interfaces(Pa)
+
+
+REAL, DIMENSION(ngrid,nlay+1), INTENT(INOUT)  :: tke      ! turbulent kinetic energy at interface between layers
+
+REAL, DIMENSION(ngrid,nlay+1), INTENT(OUT)    :: eps      ! output: tke dissipation rate at interface between layers
+REAL, DIMENSION(ngrid,nlay), INTENT(OUT)      :: Km_out   ! output: Exchange coefficient for momentum at interface between layers
+REAL, DIMENSION(ngrid,nlay), INTENT(OUT)      :: Kh_out   ! output: Exchange coefficient for heat flux at interface between layers
+
+
+REAL, DIMENSION(ngrid,nlay+1) :: tke_shear_term,tke_buoy_term,tke_trans_term
+REAL, DIMENSION(ngrid,nlay) :: wind_u_predict, wind_v_predict
+REAL, DIMENSION(ngrid) ::  wind1
+INTEGER i,j,k
+
+
+call atke_compute_km_kh(ngrid,nlay,dtime,&
+                        wind_u,wind_v,temp,qvap,play,pinterf,cdrag_uv,&
+                        tke,eps,tke_shear_term,tke_buoy_term,tke_trans_term,Km_out,Kh_out)
+
+
+                               
+if (iflag_num_atke .EQ. 1) then
+   !! In this case, we make an explicit prediction of the wind shear to calculate the tke in a
+   !! forward backward way
+   !! pay attention that the treatment of the TKE
+   !! has to be adapted when solving the TKE with a prognostic equation
+
+   do i=1,ngrid
+      wind1(i)=sqrt(wind_u(i,1)**2+wind_v(i,1)**2)
+   enddo
+   call atke_explicit_prediction(ngrid,nlay,rg,rd,dtime,pinterf,play,temp,wind1,wind_u,Km_out,u_surf,cdrag_uv,wind_u_predict)  
+   call atke_explicit_prediction(ngrid,nlay,rg,rd,dtime,pinterf,play,temp,wind1,wind_v,Km_out,v_surf,cdrag_uv,wind_v_predict)
+
+
+   call atke_compute_km_kh(ngrid,nlay,dtime,&
+                        wind_u_predict,wind_v_predict,temp,qvap,play,pinterf,cdrag_uv, &
+                        tke,eps,tke_shear_term,tke_buoy_term,tke_trans_term,Km_out,Kh_out)
+
+end if
+
+
+! Diagnostics of tke loss/source terms
+
+ DO k=1,nlay+1
+    DO i=1,ngrid
+       j=ni(i)
+       tke_shear(j,k,nsrf)=tke_shear_term(i,k)
+       tke_buoy(j,k,nsrf)=tke_buoy_term(i,k)
+       tke_trans(j,k,nsrf)=tke_trans_term(i,k)
+    ENDDO
+ ENDDO
+
+
+
+end subroutine call_atke
+
+!----------------------------------------------------------------------------------------
+
+subroutine atke_explicit_prediction(ngrid,nlay,rg,rd,dtime,pinterf,play,temp,wind1,x_in,K_in,x_surf,cdrag,x_predict)
+
+INTEGER, INTENT(IN) :: ngrid ! number of horizontal index (flat grid)
+INTEGER, INTENT(IN) :: nlay ! number of vertical index  
+REAL, INTENT(IN) :: rg,rd,dtime ! gravity, R dry air and timestep
+REAL, DIMENSION(ngrid,nlay),   INTENT(IN)  :: play      ! pressure middle of layers (Pa)
+REAL, DIMENSION(ngrid,nlay),   INTENT(IN)  :: temp      ! temperature (K)
+REAL, DIMENSION(ngrid),        INTENT(IN)  :: wind1     ! wind speed first level (m/s)
+REAL, DIMENSION(ngrid,nlay+1), INTENT(IN)  :: pinterf ! pressure at interfaces(Pa)
+REAL, DIMENSION(ngrid,nlay),   INTENT(IN)  :: x_in    ! variable at the beginning of timestep
+REAL, DIMENSION(ngrid,nlay+1), INTENT(IN)  :: K_in    ! eddy diffusivity coef at the beginning of time step
+REAL, DIMENSION(ngrid),        INTENT(IN)  :: x_surf  ! surface variable
+REAL, DIMENSION(ngrid),        INTENT(IN)  :: cdrag  ! drag coefficient
+REAL, DIMENSION(ngrid,nlay),   INTENT(OUT) :: x_predict  ! variable at the end of time step after explicit prediction
+
+
+integer i,k
+real ml,F1,rho
+real, dimension(ngrid) :: play1,temp1
+real, dimension(ngrid,nlay+1) :: K_big
+
+! computation of K_big
+
+play1(:)=play(:,1)
+temp1(:)=temp(:,1)
+
+! "big K" calculation
+do  k=2,nlay-1
+   do i=1,ngrid
+      rho=pinterf(i,k)/rd/(0.5*(temp(i,k-1)+temp(i,k)))
+      K_big(i,k)=rg*K_in(i,k)/(play(i,k)-play(i,k+1))*(rho**2)
+   enddo
+enddo
+! speficic treatment for k=nlay
+do i=1,ngrid
+   rho=pinterf(i,nlay)/rd/temp(i,nlay)
+   K_big(i,nlay)=rg*K_in(i,nlay)/(2*(play(i,nlay)-pinterf(i,nlay+1)))*(rho**2)
+enddo
+
+
+
+! x_predict calculation for 2<=k<=nlay-1
+do  k=2,nlay-1
+   do i=1,ngrid
+      ml=(pinterf(i,k)-pinterf(i,k+1))/rg
+      x_predict(i,k)=x_in(i,k)-dtime/ml*(-K_big(i,k+1)*x_in(i,k+1) &
+                  + (K_big(i,k)+K_big(i,k+1))*x_in(i,k) &
+                  - K_big(i,k)*x_in(i,k-1))
+   enddo
+enddo
+
+! Specific treatment for k=1 
+do i=1,ngrid
+   ml=(pinterf(i,1)-pinterf(i,2))/rg
+   F1=-play1(i)/rd/temp1(i)*wind1(i)*cdrag(i)*(x_in(i,1)-x_surf(i)) ! attention convention sens du flux
+   x_predict(i,1)=x_in(i,1)-dtime/ml*(-K_big(i,2)*(x_in(i,2) - x_in(i,1))-F1)
+enddo
+
+! Specific treatment for k=nlay
+! flux at the top of the atmosphere=0
+do i=1,ngrid
+   ml=0.5*(pinterf(i,nlay)-pinterf(i,nlay+1))/rg
+   x_predict(i,nlay)=x_in(i,nlay)+dtime/ml*(K_big(i,nlay)*(x_in(i,nlay)-x_in(i,nlay-1)))
+enddo
+
+
+end subroutine atke_explicit_prediction
+
+
+
+end module lmdz_call_atke
Index: DZ6/trunk/libf/phylmd/lmdz_call_blowing_snow.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/lmdz_call_blowing_snow.F90	(revision 5267)
+++ 	(revision )
@@ -1,45 +1,0 @@
-module lmdz_call_blowing_snow
-
-contains
-
-subroutine call_blowing_snow_sublim_sedim(ngrid,nlay,dtime,temp,q,qbs,pplay,paprs, &
-                                  dtemp_bs,dq_bs,dqbs_bs,bsfl,precip_bs)
-
-use lmdz_blowing_snow_sublim_sedim, only : blowing_snow_sublim_sedim
-implicit none
-
-!INPUT
-!=====
-
-integer, intent(in)                     :: ngrid,nlay
-real, intent(in)                        :: dtime
-real, intent(in), dimension(ngrid,nlay) :: temp
-real, intent(in), dimension(ngrid,nlay) :: q
-real, intent(in), dimension(ngrid,nlay) :: qbs
-real, intent(in), dimension(ngrid,nlay) :: pplay
-real, intent(in), dimension(ngrid,nlay+1) :: paprs
-
-
-! OUTPUT
-!========
-
-
-real, intent(out), dimension(ngrid,nlay) :: dtemp_bs
-real, intent(out), dimension(ngrid,nlay) :: dq_bs
-real, intent(out), dimension(ngrid,nlay) :: dqbs_bs
-real, intent(out), dimension(ngrid,nlay+1) :: bsfl
-real, intent(out), dimension(ngrid)      :: precip_bs
-
-      
-
-
-call blowing_snow_sublim_sedim(ngrid,nlay,dtime,temp,q,qbs,pplay,paprs, &
-                                  dtemp_bs,dq_bs,dqbs_bs,bsfl,precip_bs)
-
-
-
-
-
-end subroutine call_blowing_snow_sublim_sedim
-
-end module lmdz_call_blowing_snow
Index: /LMDZ6/trunk/libf/phylmd/lmdz_call_blowing_snow.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/lmdz_call_blowing_snow.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/lmdz_call_blowing_snow.f90	(revision 5268)
@@ -0,0 +1,45 @@
+module lmdz_call_blowing_snow
+
+contains
+
+subroutine call_blowing_snow_sublim_sedim(ngrid,nlay,dtime,temp,q,qbs,pplay,paprs, &
+                                  dtemp_bs,dq_bs,dqbs_bs,bsfl,precip_bs)
+
+use lmdz_blowing_snow_sublim_sedim, only : blowing_snow_sublim_sedim
+implicit none
+
+!INPUT
+!=====
+
+integer, intent(in)                     :: ngrid,nlay
+real, intent(in)                        :: dtime
+real, intent(in), dimension(ngrid,nlay) :: temp
+real, intent(in), dimension(ngrid,nlay) :: q
+real, intent(in), dimension(ngrid,nlay) :: qbs
+real, intent(in), dimension(ngrid,nlay) :: pplay
+real, intent(in), dimension(ngrid,nlay+1) :: paprs
+
+
+! OUTPUT
+!========
+
+
+real, intent(out), dimension(ngrid,nlay) :: dtemp_bs
+real, intent(out), dimension(ngrid,nlay) :: dq_bs
+real, intent(out), dimension(ngrid,nlay) :: dqbs_bs
+real, intent(out), dimension(ngrid,nlay+1) :: bsfl
+real, intent(out), dimension(ngrid)      :: precip_bs
+
+      
+
+
+call blowing_snow_sublim_sedim(ngrid,nlay,dtime,temp,q,qbs,pplay,paprs, &
+                                  dtemp_bs,dq_bs,dqbs_bs,bsfl,precip_bs)
+
+
+
+
+
+end subroutine call_blowing_snow_sublim_sedim
+
+end module lmdz_call_blowing_snow
Index: DZ6/trunk/libf/phylmd/lmdz_call_cloud_optics_prop.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/lmdz_call_cloud_optics_prop.F90	(revision 5267)
+++ 	(revision )
@@ -1,132 +1,0 @@
-! $Id$
-MODULE lmdz_call_cloud_optics_prop
-
-CONTAINS
-
-  SUBROUTINE call_cloud_optics_prop(klon, klev, ok_newmicro,&
-       paprs, pplay, temp, radocond, picefra, pclc, &
-    pcltau, pclemi, pch, pcl, pcm, pct, radocondwp, xflwp, xfiwp, xflwc, xfiwc, ok_aie, &
-    mass_solu_aero, mass_solu_aero_pi, pcldtaupi, distcltop, temp_cltop, re, fl, reliq, reice, &
-    reliq_pi, reice_pi, scdnc, cldncl, reffclwtop, lcc, reffclws, &
-    reffclwc, cldnvi, lcc3d, lcc3dcon, lcc3dstra, icc3dcon, icc3dstra,  & 
-    icefrac_optics, dNovrN, ptconv,rnebcon, ccwcon)
-
-  ! Interface between the LMDZ physics monitor and the cloud properties calculation routines
-  ! 2023/10/02: L. Raillard, M. Coulon--Decorzens, A. Idelkadi, L. Fairhead
-  ! (E. Vignon and J.-B. Madeleine in spirit)
-  ! List of arguments
-  !------------------
-
-  USE lmdz_cloud_optics_prop_ini , ONLY : ok_cdnc
-  USE lmdz_cloud_optics_prop_ini , ONLY : bl95_b0, bl95_b1
-  USE lmdz_cloud_optics_prop_ini , ONLY : iflag_ice_thermo, ok_new_lscp, iflag_t_glace
-  USE lmdz_cloud_optics_prop, ONLY : cloud_optics_prop
-  
-  USE icefrac_lsc_mod ! computes ice fraction (JBM 3/14)  
-  USE lmdz_lscp_tools, only: icefrac_lscp
-
-  IMPLICIT NONE
-  
-  ! input:
-  INTEGER, INTENT(IN) :: klon, klev      ! number of horizontal and vertical grid points
-  REAL, INTENT(IN) :: paprs(klon, klev+1)! pressure at bottom interfaces [Pa]
-  REAL, INTENT(IN) :: pplay(klon, klev)  ! pressure at the middle of layers [Pa]
-  REAL, INTENT(IN) :: temp(klon, klev)   ! temperature [K]
-  REAL, INTENT(IN) :: radocond(klon, klev) ! cloud condensed water seen by radiation [kg/kg]
-  REAL, INTENT(IN) :: picefra(klon,klev) ! ice fraction in clouds from large scale condensation scheme [-]
-  REAL, INTENT(IN) :: rnebcon(klon,klev) ! convection cloud fraction [-]
-  REAL, INTENT(IN) :: ccwcon(klon,klev)  ! condensed water from deep convection [kg/kg]
-  ! jq for the aerosol indirect effect
-  ! jq introduced by Johannes Quaas (quaas@lmd.jussieu.fr), 27/11/2003
-  REAL, INTENT(IN) :: mass_solu_aero(klon, klev)    ! total mass concentration for all soluble aerosols [ug m-3]
-  REAL, INTENT(IN) :: mass_solu_aero_pi(klon, klev) ! - (pre-industrial value)
-  REAL, INTENT(IN)  :: dNovrN(klon)         ! enhancement factor for cdnc
-  REAL, INTENT(OUT) :: distcltop(klon,klev) ! distance from large scale cloud top [m]
-  REAL, INTENT(OUT) :: temp_cltop(klon,klev)!temperature at large scale cloud top [K]
-
-  LOGICAL, INTENT(IN) :: ptconv(klon, klev) ! flag for grid points affected by deep convection
-  LOGICAL, INTENT(IN) :: ok_newmicro, ok_aie
-
-  ! inout:
-  REAL, INTENT(INOUT) :: pclc(klon, klev) ! cloud fraction for radiation [-]
-
-  ! out:
-  REAL, INTENT(OUT) :: pct(klon)      ! 2D total cloud cover [-]
-  REAL, INTENT(OUT) :: pcl(klon)      ! 2D low cloud cover [-]
-  REAL, INTENT(OUT) :: pcm(klon)      ! 2D mid cloud cover [-]
-  REAL, INTENT(OUT) :: pch(klon)      ! 2D high cloud cover [-]
-  REAL, INTENT(OUT) :: radocondwp(klon) ! total condensed water path (seen by radiation) [kg/m2]
-  REAL, INTENT(OUT) :: xflwp(klon)    ! liquid water path (seen by radiation) [kg/m2]
-  REAL, INTENT(OUT) :: xfiwp(klon)    ! ice water path (seen by radiation) [kg/m2]
-  REAL, INTENT(OUT) :: xflwc(klon, klev) ! liquid water content seen by radiation [kg/kg]
-  REAL, INTENT(OUT) :: xfiwc(klon, klev) ! ice water content seen by radiation [kg/kg]
-  REAL, INTENT(OUT) :: re(klon, klev) ! cloud droplet effective radius multiplied by fl
-  REAL, INTENT(OUT) :: fl(klon, klev) ! xliq * rneb, denominator to re; fraction of liquid water clouds
-                                      ! introduced to avoid problems in the averaging of the output
-                                      ! water clouds within a grid cell
-
-  REAL, INTENT(OUT) :: pcltau(klon, klev) ! cloud optical depth [m]
-  REAL, INTENT(OUT) :: pclemi(klon, klev) ! cloud emissivity [-]
-  REAL, INTENT(OUT) :: pcldtaupi(klon, klev) ! pre-industrial value of cloud optical thickness, ie.
-                                             ! values of optical thickness that does not account
-                                             ! for aerosol effects on cloud droplet radius [m]
-
-  REAL, INTENT(OUT) :: reliq(klon, klev)   ! liquid droplet effective radius [m] 
-  REAL, INTENT(OUT) :: reice(klon, klev)   ! ice effective radius [m]
-  REAL, INTENT(OUT) :: reliq_pi(klon, klev)! liquid droplet effective radius [m], pre-industrial
-  REAL, INTENT(OUT) :: reice_pi(klon, klev)! ice effective radius [m], pre-industrial
-  REAL, INTENT(OUT) :: scdnc(klon, klev)   ! cloud droplet number concentration, mean over the whole mesh [m-3]
-  REAL, INTENT(OUT) :: cldncl(klon)        ! cloud droplet number concentration at top of cloud [m-3]
-  REAL, INTENT(OUT) :: reffclwtop(klon)    ! effective radius of cloud droplet at top of cloud [m] 
-  REAL, INTENT(OUT) :: lcc(klon)           ! liquid Cloud Content at top of cloud [kg/kg]
-  REAL, INTENT(OUT) :: reffclws(klon, klev)! stratiform cloud droplet effective radius 
-  REAL, INTENT(OUT) :: reffclwc(klon, klev)! convective cloud droplet effective radius 
-  REAL, INTENT(OUT) :: cldnvi(klon)        ! column Integrated cloud droplet Number [/m2]
-  REAL, INTENT(OUT) :: lcc3d(klon, klev)   ! cloud fraction for liquid part only [-]
-  REAL, INTENT(OUT) :: lcc3dcon(klon, klev)! cloud fraction for liquid part only, convective clouds [-]
-  REAL, INTENT(OUT) :: lcc3dstra(klon, klev)!cloud fraction for liquid part only, stratiform clouds [-]
-  REAL, INTENT(OUT) :: icc3dcon(klon, klev)! cloud fraction for liquid part only, convective clouds [-]
-  REAL, INTENT(OUT) :: icc3dstra(klon, klev)! cloud fraction for ice part only, stratiform clouds [-] 
-  REAL, INTENT(INOUT) :: icefrac_optics(klon, klev)! ice fraction in clouds seen by radiation [-]
-
-  ! Local variables
-  !----------------
-  INTEGER :: k
-  REAL :: dzfice(klon, klev)
-
-  IF (iflag_t_glace .EQ. 0) THEN
-     icefrac_optics(:, :) = 0.
-  ELSE
-     DO k = 1, klev
-        IF (ok_new_lscp) THEN
-          CALL icefrac_lscp(klon,temp(:,k),iflag_ice_thermo,distcltop(:,k),temp_cltop(:,k), &
-   &         icefrac_optics(:,k),dzfice(:,k))
-        ELSE
-          CALL icefrac_lsc(klon,temp(:,k),pplay(1:klon,k)/paprs(1:klon,1),icefrac_optics(:,k))
-        ENDIF
-     ENDDO
-  ENDIF
-  
-
-
-  IF (ok_newmicro) THEN       
-    CALL cloud_optics_prop(klon, klev, paprs, pplay, temp, radocond, picefra, pclc, &
-    pcltau, pclemi, pch, pcl, pcm, pct, radocondwp, xflwp, xfiwp, xflwc, xfiwc, &
-    mass_solu_aero, mass_solu_aero_pi, pcldtaupi, distcltop, temp_cltop, re, fl, reliq, reice, &
-    reliq_pi, reice_pi, scdnc, cldncl, reffclwtop, lcc, reffclws, &
-    reffclwc, cldnvi, lcc3d, lcc3dcon, lcc3dstra, icc3dcon, icc3dstra,  & 
-    icefrac_optics, dNovrN, ptconv,rnebcon, ccwcon)
-  ELSE
-    CALL nuage (paprs, pplay, &
-               temp, radocond, picefra, pclc, pcltau, pclemi, &
-               pch, pcl,pcm, pct, radocondwp, &
-               ok_aie, &
-               mass_solu_aero, mass_solu_aero_pi, &
-               bl95_b0, bl95_b1, distcltop, temp_cltop, &
-               pcldtaupi, re, fl)
-  ENDIF
-  RETURN
-
-END SUBROUTINE call_cloud_optics_prop
-
-END MODULE lmdz_call_cloud_optics_prop
Index: /LMDZ6/trunk/libf/phylmd/lmdz_call_cloud_optics_prop.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/lmdz_call_cloud_optics_prop.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/lmdz_call_cloud_optics_prop.f90	(revision 5268)
@@ -0,0 +1,132 @@
+! $Id$
+MODULE lmdz_call_cloud_optics_prop
+
+CONTAINS
+
+  SUBROUTINE call_cloud_optics_prop(klon, klev, ok_newmicro,&
+       paprs, pplay, temp, radocond, picefra, pclc, &
+    pcltau, pclemi, pch, pcl, pcm, pct, radocondwp, xflwp, xfiwp, xflwc, xfiwc, ok_aie, &
+    mass_solu_aero, mass_solu_aero_pi, pcldtaupi, distcltop, temp_cltop, re, fl, reliq, reice, &
+    reliq_pi, reice_pi, scdnc, cldncl, reffclwtop, lcc, reffclws, &
+    reffclwc, cldnvi, lcc3d, lcc3dcon, lcc3dstra, icc3dcon, icc3dstra,  & 
+    icefrac_optics, dNovrN, ptconv,rnebcon, ccwcon)
+
+  ! Interface between the LMDZ physics monitor and the cloud properties calculation routines
+  ! 2023/10/02: L. Raillard, M. Coulon--Decorzens, A. Idelkadi, L. Fairhead
+  ! (E. Vignon and J.-B. Madeleine in spirit)
+  ! List of arguments
+  !------------------
+
+  USE lmdz_cloud_optics_prop_ini , ONLY : ok_cdnc
+  USE lmdz_cloud_optics_prop_ini , ONLY : bl95_b0, bl95_b1
+  USE lmdz_cloud_optics_prop_ini , ONLY : iflag_ice_thermo, ok_new_lscp, iflag_t_glace
+  USE lmdz_cloud_optics_prop, ONLY : cloud_optics_prop
+  
+  USE icefrac_lsc_mod ! computes ice fraction (JBM 3/14)  
+  USE lmdz_lscp_tools, only: icefrac_lscp
+
+  IMPLICIT NONE
+  
+  ! input:
+  INTEGER, INTENT(IN) :: klon, klev      ! number of horizontal and vertical grid points
+  REAL, INTENT(IN) :: paprs(klon, klev+1)! pressure at bottom interfaces [Pa]
+  REAL, INTENT(IN) :: pplay(klon, klev)  ! pressure at the middle of layers [Pa]
+  REAL, INTENT(IN) :: temp(klon, klev)   ! temperature [K]
+  REAL, INTENT(IN) :: radocond(klon, klev) ! cloud condensed water seen by radiation [kg/kg]
+  REAL, INTENT(IN) :: picefra(klon,klev) ! ice fraction in clouds from large scale condensation scheme [-]
+  REAL, INTENT(IN) :: rnebcon(klon,klev) ! convection cloud fraction [-]
+  REAL, INTENT(IN) :: ccwcon(klon,klev)  ! condensed water from deep convection [kg/kg]
+  ! jq for the aerosol indirect effect
+  ! jq introduced by Johannes Quaas (quaas@lmd.jussieu.fr), 27/11/2003
+  REAL, INTENT(IN) :: mass_solu_aero(klon, klev)    ! total mass concentration for all soluble aerosols [ug m-3]
+  REAL, INTENT(IN) :: mass_solu_aero_pi(klon, klev) ! - (pre-industrial value)
+  REAL, INTENT(IN)  :: dNovrN(klon)         ! enhancement factor for cdnc
+  REAL, INTENT(OUT) :: distcltop(klon,klev) ! distance from large scale cloud top [m]
+  REAL, INTENT(OUT) :: temp_cltop(klon,klev)!temperature at large scale cloud top [K]
+
+  LOGICAL, INTENT(IN) :: ptconv(klon, klev) ! flag for grid points affected by deep convection
+  LOGICAL, INTENT(IN) :: ok_newmicro, ok_aie
+
+  ! inout:
+  REAL, INTENT(INOUT) :: pclc(klon, klev) ! cloud fraction for radiation [-]
+
+  ! out:
+  REAL, INTENT(OUT) :: pct(klon)      ! 2D total cloud cover [-]
+  REAL, INTENT(OUT) :: pcl(klon)      ! 2D low cloud cover [-]
+  REAL, INTENT(OUT) :: pcm(klon)      ! 2D mid cloud cover [-]
+  REAL, INTENT(OUT) :: pch(klon)      ! 2D high cloud cover [-]
+  REAL, INTENT(OUT) :: radocondwp(klon) ! total condensed water path (seen by radiation) [kg/m2]
+  REAL, INTENT(OUT) :: xflwp(klon)    ! liquid water path (seen by radiation) [kg/m2]
+  REAL, INTENT(OUT) :: xfiwp(klon)    ! ice water path (seen by radiation) [kg/m2]
+  REAL, INTENT(OUT) :: xflwc(klon, klev) ! liquid water content seen by radiation [kg/kg]
+  REAL, INTENT(OUT) :: xfiwc(klon, klev) ! ice water content seen by radiation [kg/kg]
+  REAL, INTENT(OUT) :: re(klon, klev) ! cloud droplet effective radius multiplied by fl
+  REAL, INTENT(OUT) :: fl(klon, klev) ! xliq * rneb, denominator to re; fraction of liquid water clouds
+                                      ! introduced to avoid problems in the averaging of the output
+                                      ! water clouds within a grid cell
+
+  REAL, INTENT(OUT) :: pcltau(klon, klev) ! cloud optical depth [m]
+  REAL, INTENT(OUT) :: pclemi(klon, klev) ! cloud emissivity [-]
+  REAL, INTENT(OUT) :: pcldtaupi(klon, klev) ! pre-industrial value of cloud optical thickness, ie.
+                                             ! values of optical thickness that does not account
+                                             ! for aerosol effects on cloud droplet radius [m]
+
+  REAL, INTENT(OUT) :: reliq(klon, klev)   ! liquid droplet effective radius [m] 
+  REAL, INTENT(OUT) :: reice(klon, klev)   ! ice effective radius [m]
+  REAL, INTENT(OUT) :: reliq_pi(klon, klev)! liquid droplet effective radius [m], pre-industrial
+  REAL, INTENT(OUT) :: reice_pi(klon, klev)! ice effective radius [m], pre-industrial
+  REAL, INTENT(OUT) :: scdnc(klon, klev)   ! cloud droplet number concentration, mean over the whole mesh [m-3]
+  REAL, INTENT(OUT) :: cldncl(klon)        ! cloud droplet number concentration at top of cloud [m-3]
+  REAL, INTENT(OUT) :: reffclwtop(klon)    ! effective radius of cloud droplet at top of cloud [m] 
+  REAL, INTENT(OUT) :: lcc(klon)           ! liquid Cloud Content at top of cloud [kg/kg]
+  REAL, INTENT(OUT) :: reffclws(klon, klev)! stratiform cloud droplet effective radius 
+  REAL, INTENT(OUT) :: reffclwc(klon, klev)! convective cloud droplet effective radius 
+  REAL, INTENT(OUT) :: cldnvi(klon)        ! column Integrated cloud droplet Number [/m2]
+  REAL, INTENT(OUT) :: lcc3d(klon, klev)   ! cloud fraction for liquid part only [-]
+  REAL, INTENT(OUT) :: lcc3dcon(klon, klev)! cloud fraction for liquid part only, convective clouds [-]
+  REAL, INTENT(OUT) :: lcc3dstra(klon, klev)!cloud fraction for liquid part only, stratiform clouds [-]
+  REAL, INTENT(OUT) :: icc3dcon(klon, klev)! cloud fraction for liquid part only, convective clouds [-]
+  REAL, INTENT(OUT) :: icc3dstra(klon, klev)! cloud fraction for ice part only, stratiform clouds [-] 
+  REAL, INTENT(INOUT) :: icefrac_optics(klon, klev)! ice fraction in clouds seen by radiation [-]
+
+  ! Local variables
+  !----------------
+  INTEGER :: k
+  REAL :: dzfice(klon, klev)
+
+  IF (iflag_t_glace .EQ. 0) THEN
+     icefrac_optics(:, :) = 0.
+  ELSE
+     DO k = 1, klev
+        IF (ok_new_lscp) THEN
+          CALL icefrac_lscp(klon,temp(:,k),iflag_ice_thermo,distcltop(:,k),temp_cltop(:,k), &
+   &         icefrac_optics(:,k),dzfice(:,k))
+        ELSE
+          CALL icefrac_lsc(klon,temp(:,k),pplay(1:klon,k)/paprs(1:klon,1),icefrac_optics(:,k))
+        ENDIF
+     ENDDO
+  ENDIF
+  
+
+
+  IF (ok_newmicro) THEN       
+    CALL cloud_optics_prop(klon, klev, paprs, pplay, temp, radocond, picefra, pclc, &
+    pcltau, pclemi, pch, pcl, pcm, pct, radocondwp, xflwp, xfiwp, xflwc, xfiwc, &
+    mass_solu_aero, mass_solu_aero_pi, pcldtaupi, distcltop, temp_cltop, re, fl, reliq, reice, &
+    reliq_pi, reice_pi, scdnc, cldncl, reffclwtop, lcc, reffclws, &
+    reffclwc, cldnvi, lcc3d, lcc3dcon, lcc3dstra, icc3dcon, icc3dstra,  & 
+    icefrac_optics, dNovrN, ptconv,rnebcon, ccwcon)
+  ELSE
+    CALL nuage (paprs, pplay, &
+               temp, radocond, picefra, pclc, pcltau, pclemi, &
+               pch, pcl,pcm, pct, radocondwp, &
+               ok_aie, &
+               mass_solu_aero, mass_solu_aero_pi, &
+               bl95_b0, bl95_b1, distcltop, temp_cltop, &
+               pcldtaupi, re, fl)
+  ENDIF
+  RETURN
+
+END SUBROUTINE call_cloud_optics_prop
+
+END MODULE lmdz_call_cloud_optics_prop
Index: DZ6/trunk/libf/phylmd/lmdz_cloud_optics_prop.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/lmdz_cloud_optics_prop.F90	(revision 5267)
+++ 	(revision )
@@ -1,736 +1,0 @@
-! $Id$
-MODULE lmdz_cloud_optics_prop
-
-CONTAINS
-
-SUBROUTINE cloud_optics_prop(klon, klev, paprs, pplay, temp, radocond, picefra, pclc, &
-    pcltau, pclemi, pch, pcl, pcm, pct, radocondwp, xflwp, xfiwp, xflwc, xfiwc, &
-    mass_solu_aero, mass_solu_aero_pi, pcldtaupi, distcltop, temp_cltop, re, fl, reliq, reice, &
-    reliq_pi, reice_pi, scdnc, cldncl, reffclwtop, lcc, reffclws, &
-    reffclwc, cldnvi, lcc3d, lcc3dcon, lcc3dstra, icc3dcon, icc3dstra,  & 
-    icefrac_optics, dNovrN, ptconv,rnebcon, ccwcon)
-
-  USE lmdz_cloud_optics_prop_ini , ONLY : flag_aerosol, ok_cdnc
-  USE lmdz_cloud_optics_prop_ini , ONLY : lunout
-  USE lmdz_cloud_optics_prop_ini , ONLY : bl95_b0, bl95_b1
-  USE lmdz_cloud_optics_prop_ini , ONLY : latitude_deg
-  USE lmdz_cloud_optics_prop_ini , ONLY : iflag_t_glace
-  USE lmdz_cloud_optics_prop_ini , ONLY : cdnc_max, cdnc_max_m3
-  USE lmdz_cloud_optics_prop_ini , ONLY : cdnc_min, cdnc_min_m3
-  USE lmdz_cloud_optics_prop_ini , ONLY : thres_tau, thres_neb
-  USE lmdz_cloud_optics_prop_ini , ONLY : prmhc, prlmc
-  USE lmdz_cloud_optics_prop_ini , ONLY : coef_froi, coef_chau
-  USE lmdz_cloud_optics_prop_ini , ONLY : seuil_neb
-  USE lmdz_cloud_optics_prop_ini , ONLY : t_glace_min_old, t_glace_max_old
-  USE lmdz_cloud_optics_prop_ini , ONLY : k_ice0, df
-  USE lmdz_cloud_optics_prop_ini , ONLY : rg, rd, rpi
-  USE lmdz_cloud_optics_prop_ini , ONLY : rad_chau1, rad_chau2, rad_froid, iflag_rei
-  USE lmdz_cloud_optics_prop_ini , ONLY : ok_icefra_lscp, rei_max, rei_min
-  USE lmdz_cloud_optics_prop_ini , ONLY : zepsec, novlp, iflag_ice_thermo, ok_new_lscp
-  
-
-
-
-  IMPLICIT NONE
-  ! ======================================================================
-  ! Authors: Z.X. Li (LMD/CNRS) date: 19930910
-  !          O.Boucher (LMD/CNRS) mise a jour en 201212
-  !          I. Musat (LMD/CNRS) : prise en compte de la meme hypothese 
-  !                              de recouvrement pour les nuages que pour 
-  !                              le rayonnement rrtm via le parametre
-  !                               novlp de radopt.h : 20160721
-  !          L.Fairheard, E.Vignon, JB Madeleine, L. Raillard, A. Idelkadi
-  !          M. Coulon-Decorzens: replayisation of the routine + cleaning
-  !                               and commentaries
-  !
-  ! Aim: compute condensate optical properties,
-  !      cloud optical depth and emissivity
-  ! ======================================================================
-  
-  ! List of arguments
-  !------------------
-
-  ! input:
-  INTEGER, INTENT(IN) :: klon, klev      ! number of horizontal and vertical grid points
-  REAL, INTENT(IN) :: paprs(klon, klev+1)! pressure at bottom interfaces [Pa]
-  REAL, INTENT(IN) :: pplay(klon, klev)  ! pressure at the middle of layers [Pa]
-  REAL, INTENT(IN) :: temp(klon, klev)   ! temperature [K]
-  REAL, INTENT(IN) :: radocond(klon, klev) ! cloud condensed water seen by radiation [kg/kg]
-  REAL, INTENT(IN) :: picefra(klon,klev) ! ice fraction in clouds from large scale condensation scheme [-]
-  REAL, INTENT(IN) :: rnebcon(klon,klev) ! convection cloud fraction [-]
-  REAL, INTENT(IN) :: ccwcon(klon,klev)  ! condensed water from deep convection [kg/kg]
-  ! jq for the aerosol indirect effect
-  ! jq introduced by Johannes Quaas (quaas@lmd.jussieu.fr), 27/11/2003
-  REAL, INTENT(IN) :: mass_solu_aero(klon, klev)    ! total mass concentration for all soluble aerosols [ug m-3]
-  REAL, INTENT(IN) :: mass_solu_aero_pi(klon, klev) ! - (pre-industrial value)
-  REAL, INTENT(IN)  :: dNovrN(klon)         ! enhancement factor for cdnc
-  REAL, INTENT(OUT) :: distcltop(klon,klev) ! distance from large scale cloud top [m]
-  REAL, INTENT(OUT) :: temp_cltop(klon,klev)!temperature at large scale cloud top [K]
-
-  LOGICAL, INTENT(IN) :: ptconv(klon, klev) ! flag for grid points affected by deep convection
-
-  ! inout:
-  REAL, INTENT(INOUT) :: pclc(klon, klev) ! cloud fraction for radiation [-]
-
-  ! out:
-  REAL, INTENT(OUT) :: pct(klon)      ! 2D total cloud cover [-]
-  REAL, INTENT(OUT) :: pcl(klon)      ! 2D low cloud cover [-]
-  REAL, INTENT(OUT) :: pcm(klon)      ! 2D mid cloud cover [-]
-  REAL, INTENT(OUT) :: pch(klon)      ! 2D high cloud cover [-]
-  REAL, INTENT(OUT) :: radocondwp(klon) ! total condensed water path (seen by radiation) [kg/m2]
-  REAL, INTENT(OUT) :: xflwp(klon)    ! liquid water path (seen by radiation) [kg/m2]
-  REAL, INTENT(OUT) :: xfiwp(klon)    ! ice water path (seen by radiation) [kg/m2]
-  REAL, INTENT(OUT) :: xflwc(klon, klev) ! liquid water content seen by radiation [kg/kg]
-  REAL, INTENT(OUT) :: xfiwc(klon, klev) ! ice water content seen by radiation [kg/kg]
-  REAL, INTENT(OUT) :: re(klon, klev) ! cloud droplet effective radius multiplied by fl
-  REAL, INTENT(OUT) :: fl(klon, klev) ! xliq * rneb, denominator to re; fraction of liquid water clouds
-                                      ! introduced to avoid problems in the averaging of the output
-                                      ! water clouds within a grid cell
-
-  REAL, INTENT(OUT) :: pcltau(klon, klev) ! cloud optical depth [m]
-  REAL, INTENT(OUT) :: pclemi(klon, klev) ! cloud emissivity [-]
-  REAL, INTENT(OUT) :: pcldtaupi(klon, klev) ! pre-industrial value of cloud optical thickness, ie.
-                                             ! values of optical thickness that does not account
-                                             ! for aerosol effects on cloud droplet radius [m]
-
-  REAL, INTENT(OUT) :: reliq(klon, klev)   ! liquid droplet effective radius [m] 
-  REAL, INTENT(OUT) :: reice(klon, klev)   ! ice effective radius [m]
-  REAL, INTENT(OUT) :: reliq_pi(klon, klev)! liquid droplet effective radius [m], pre-industrial
-  REAL, INTENT(OUT) :: reice_pi(klon, klev)! ice effective radius [m], pre-industrial
-  REAL, INTENT(OUT) :: scdnc(klon, klev)   ! cloud droplet number concentration, mean over the whole mesh [m-3]
-  REAL, INTENT(OUT) :: cldncl(klon)        ! cloud droplet number concentration at top of cloud [m-3]
-  REAL, INTENT(OUT) :: reffclwtop(klon)    ! effective radius of cloud droplet at top of cloud [m] 
-  REAL, INTENT(OUT) :: lcc(klon)           ! liquid Cloud Content at top of cloud [kg/kg]
-  REAL, INTENT(OUT) :: reffclws(klon, klev)! stratiform cloud droplet effective radius 
-  REAL, INTENT(OUT) :: reffclwc(klon, klev)! convective cloud droplet effective radius 
-  REAL, INTENT(OUT) :: cldnvi(klon)        ! column Integrated cloud droplet Number [/m2]
-  REAL, INTENT(OUT) :: lcc3d(klon, klev)   ! cloud fraction for liquid part only [-]
-  REAL, INTENT(OUT) :: lcc3dcon(klon, klev)! cloud fraction for liquid part only, convective clouds [-]
-  REAL, INTENT(OUT) :: lcc3dstra(klon, klev)!cloud fraction for liquid part only, stratiform clouds [-]
-  REAL, INTENT(OUT) :: icc3dcon(klon, klev)! cloud fraction for liquid part only, convective clouds [-]
-  REAL, INTENT(OUT) :: icc3dstra(klon, klev)! cloud fraction for ice part only, stratiform clouds [-] 
-  REAL, INTENT(INOUT) :: icefrac_optics(klon, klev)! ice fraction in clouds seen by radiation [-]
-
-  ! Local variables
-  !----------------
-
-  LOGICAL, SAVE :: first = .TRUE.
-  !$OMP THREADPRIVATE(FIRST)
-  INTEGER flag_max
-
-  ! threshold PARAMETERs
-  REAL phase3d(klon, klev)
-  REAL tcc(klon), ftmp(klon), lcc_integrat(klon), height(klon)
-  LOGICAL lo
-  INTEGER i, k
-  REAL radius
-
-
-  REAL rel, tc, rei, iwc, dei, deimin, deimax
-  REAL k_ice
-
-  ! jq for the aerosol indirect effect
-  ! jq introduced by Johannes Quaas (quaas@lmd.jussieu.fr), 27/11/2003
-  REAL cdnc(klon, klev) ! cloud droplet number concentration [m-3]
-  REAL cdnc_pi(klon, klev) ! cloud droplet number concentration [m-3] (pi value)
-  REAL re_pi(klon, klev) ! cloud droplet effective radius [um] (pi value)
-
-  ! IM cf. CR:parametres supplementaires
-  REAL dzfice(klon,klev)
-  REAL zclear(klon)
-  REAL zcloud(klon)
-  REAL zcloudh(klon)
-  REAL zcloudm(klon)
-  REAL zcloudl(klon)
-  REAL rhodz(klon, klev) !--rho*dz pour la couche
-  REAL zrho(klon, klev) !--rho pour la couche
-  REAL dh(klon, klev) !--dz pour la couche
-  REAL rad_chaud(klon, klev) !--rayon pour les nuages chauds
-  REAL rad_chaud_pi(klon, klev) !--rayon pour les nuages chauds pre-industriels
-  REAL zflwp_var, zfiwp_var
-  REAL d_rei_dt
-
-
-  ! FH : 2011/05/24
-  ! rei = ( rei_max - rei_min ) * T(°C) / 81.4 + rei_max
-  ! to be used for a temperature in celcius T(°C) < 0
-  ! rei=rei_min for T(°C) < -81.4
-  ! Calcul de la pente de la relation entre rayon effective des cristaux
-  ! et la température Pour retrouver les résultats numériques de la version d'origine,
-  ! on impose 0.71 quand on est proche de 0.71
-  d_rei_dt = (rei_max-rei_min)/81.4
-  IF (abs(d_rei_dt-0.71)<1.E-4) d_rei_dt = 0.71
-
-  ! Calculer l'epaisseur optique et l'emmissivite des nuages
-  ! IM inversion des DO
-
-  xflwp = 0.D0
-  xfiwp = 0.D0
-  xflwc = 0.D0
-  xfiwc = 0.D0
-
-  reliq = 0.
-  reice = 0.
-  reliq_pi = 0.
-  reice_pi = 0.
-
-  IF (iflag_t_glace.EQ.0) THEN
-    DO k = 1, klev
-      DO i = 1, klon
-        ! -layer calculation
-        rhodz(i, k) = (paprs(i,k)-paprs(i,k+1))/rg ! kg/m2
-        zrho(i, k) = pplay(i, k)/temp(i, k)/rd ! kg/m3
-        dh(i, k) = rhodz(i, k)/zrho(i, k) ! m
-        ! -Fraction of ice in cloud using a linear transition
-        icefrac_optics(i, k) = 1.0 - (temp(i,k)-t_glace_min_old)/(t_glace_max_old-t_glace_min_old)
-        icefrac_optics(i, k) = min(max(icefrac_optics(i,k),0.0), 1.0)
-        ! -IM Total Liquid/Ice water content
-        xflwc(i, k) = (1.-icefrac_optics(i,k))*radocond(i, k)
-        xfiwc(i, k) = icefrac_optics(i, k)*radocond(i, k)
-      ENDDO
-    ENDDO
-  ELSE ! of IF (iflag_t_glace.EQ.0)
-    DO k = 1, klev
-
-
-!!$      IF (ok_new_lscp) THEN
-!!$          CALL icefrac_lscp(klon,temp(:,k),iflag_ice_thermo,distcltop(:,k),temp_cltop(:,k),icefrac_optics(:,k),dzfice(:,k))
-!!$      ELSE
-!!$          CALL icefrac_lsc(klon,temp(:,k),pplay(:,k)/paprs(:,1),icefrac_optics(:,k))
-!!$      ENDIF
-
-      DO i = 1, klon
-        
-        IF ((.NOT. ptconv(i,k)) .AND. ok_new_lscp .AND. ok_icefra_lscp) THEN
-        ! EV: take the ice fraction directly from the lscp code
-        ! consistent only for non convective grid points
-        ! critical for mixed phase clouds
-            icefrac_optics(i,k)=picefra(i,k)
-        ENDIF
-
-        ! -layer calculation
-        rhodz(i, k) = (paprs(i,k)-paprs(i,k+1))/rg ! kg/m2
-        zrho(i, k) = pplay(i, k)/temp(i, k)/rd ! kg/m3
-        dh(i, k) = rhodz(i, k)/zrho(i, k) ! m
-        ! -IM Total Liquid/Ice water content
-        xflwc(i, k) = (1.-icefrac_optics(i,k))*radocond(i, k)
-        xfiwc(i, k) = icefrac_optics(i, k)*radocond(i, k)
-      ENDDO
-    ENDDO
-  ENDIF
-
-
-
-
-
-
-  IF (ok_cdnc) THEN
-
-    ! --we compute cloud properties as a function of the aerosol load
-
-    DO k = 1, klev
-      DO i = 1, klon
-        ! Formula "D" of Boucher and Lohmann, Tellus, 1995
-        ! Cloud droplet number concentration (CDNC) is restricted
-        ! to be within [20, 1000 cm^3]
-
-        ! --pre-industrial case
-        cdnc_pi(i, k) = 10.**(bl95_b0+bl95_b1*log(max(mass_solu_aero_pi(i,k), &
-          1.E-4))/log(10.))*1.E6 !-m-3
-        cdnc_pi(i, k) = min(cdnc_max_m3, max(cdnc_min_m3,cdnc_pi(i,k)))
-
-      ENDDO
-    ENDDO
-
-    !--flag_aerosol=7 => MACv2SP climatology 
-    !--in this case there is an enhancement factor
-    IF (flag_aerosol .EQ. 7) THEN 
-
-      !--present-day
-      DO k = 1, klev
-        DO i = 1, klon
-          cdnc(i, k) = cdnc_pi(i,k)*dNovrN(i)
-        ENDDO
-      ENDDO
-
-    !--standard case
-    ELSE
-
-      DO k = 1, klev
-        DO i = 1, klon
-
-          ! Formula "D" of Boucher and Lohmann, Tellus, 1995
-          ! Cloud droplet number concentration (CDNC) is restricted
-          ! to be within [20, 1000 cm^3]
-
-          ! --present-day case
-          cdnc(i, k) = 10.**(bl95_b0+bl95_b1*log(max(mass_solu_aero(i,k), &
-            1.E-4))/log(10.))*1.E6 !-m-3
-          cdnc(i, k) = min(cdnc_max_m3, max(cdnc_min_m3,cdnc(i,k)))
-
-        ENDDO
-      ENDDO
-
-    ENDIF !--flag_aerosol
-
-    !--computing cloud droplet size
-    DO k = 1, klev
-      DO i = 1, klon
-
-        ! --present-day case
-        rad_chaud(i, k) = 1.1*((radocond(i,k)*pplay(i, &
-          k)/(rd*temp(i,k)))/(4./3*rpi*1000.*cdnc(i,k)))**(1./3.)
-        rad_chaud(i, k) = max(rad_chaud(i,k)*1.E6, 5.)
-
-        ! --pre-industrial case
-        rad_chaud_pi(i, k) = 1.1*((radocond(i,k)*pplay(i, &
-          k)/(rd*temp(i,k)))/(4./3.*rpi*1000.*cdnc_pi(i,k)))**(1./3.)
-        rad_chaud_pi(i, k) = max(rad_chaud_pi(i,k)*1.E6, 5.)
-
-        ! --pre-industrial case
-        ! --liquid/ice cloud water paths:
-        IF (pclc(i,k)<=seuil_neb) THEN
-
-          pcldtaupi(i, k) = 0.0
-
-        ELSE
-
-          zflwp_var = 1000.*(1.-icefrac_optics(i,k))*radocond(i, k)/pclc(i, k)* &
-            rhodz(i, k)
-          zfiwp_var = 1000.*icefrac_optics(i, k)*radocond(i, k)/pclc(i, k)*rhodz(i, k)
-          ! Calculation of ice cloud effective radius in micron
-          IF (iflag_rei .EQ. 1) THEN
-            ! when we account for precipitation in the radiation scheme,
-            ! It is recommended to use the rei formula from Sun and Rikkus 1999 with a revision
-            ! from Sun 2001 (as in the IFS model)
-            iwc=icefrac_optics(i, k)*radocond(i, k)/pclc(i,k)*zrho(i,k)*1000. !in cloud ice water content in g/m3
-            dei=(1.2351+0.0105*(temp(i,k)-273.15))*(45.8966*(iwc**0.2214) + &
-               & 0.7957*(iwc**0.2535)*(temp(i,k)-83.15))
-            !deimax=155.0
-            !deimin=20.+40*cos(abs(latitude_deg(i))/180.*RPI)
-            !Etienne: deimax and deimin controled by rei_max and rei_min in physiq.def
-            deimax=rei_max*2.0
-            deimin=2.0*rei_min+40*cos(abs(latitude_deg(i))/180.*RPI) 
-            dei=min(dei,deimax)
-            dei=max(dei,deimin)
-            rei=3.*sqrt(3.)/8.*dei
-           ELSE
-            ! Default
-            ! for ice clouds: as a function of the ambiant temperature
-            ! [formula used by Iacobellis and Somerville (2000), with an
-            ! asymptotical value of 3.5 microns at T<-81.4 C added to be
-            ! consistent with observations of Heymsfield et al. 1986]:
-            ! 2011/05/24 : rei_min = 3.5 becomes a free PARAMETER as well as
-            ! rei_max=61.29
-            tc = temp(i, k) - 273.15
-            rei = d_rei_dt*tc + rei_max
-            IF (tc<=-81.4) rei = rei_min
-           ENDIF
-
-          ! -- cloud optical thickness :
-          ! [for liquid clouds, traditional formula,
-          ! for ice clouds, Ebert & Curry (1992)]
-
-          IF (zfiwp_var==0. .OR. rei<=0.) rei = 1.
-          pcldtaupi(i, k) = 3.0/2.0*zflwp_var/rad_chaud_pi(i, k) + &
-            zfiwp_var*(3.448E-03+2.431/rei)
-
-        ENDIF
-
-      ENDDO
-    ENDDO
-
-  ELSE !--not ok_cdnc
-
-    ! -prescribed cloud droplet radius
-
-    DO k = 1, min(3, klev)
-      DO i = 1, klon
-        rad_chaud(i, k) = rad_chau2
-        rad_chaud_pi(i, k) = rad_chau2
-      ENDDO
-    ENDDO
-    DO k = min(3, klev) + 1, klev
-      DO i = 1, klon
-        rad_chaud(i, k) = rad_chau1
-        rad_chaud_pi(i, k) = rad_chau1
-      ENDDO
-    ENDDO
-
-  ENDIF !--ok_cdnc
-
-  ! --computation of cloud optical depth and emissivity
-  ! --in the general case
-
-  DO k = 1, klev
-    DO i = 1, klon
-
-      IF (pclc(i,k)<=seuil_neb) THEN
-
-        ! effective cloud droplet radius (microns) for liquid water clouds:
-        ! For output diagnostics cloud droplet effective radius [um]
-        ! we multiply here with f * xl (fraction of liquid water
-        ! clouds in the grid cell) to avoid problems in the averaging of the
-        ! output.
-        ! In the output of IOIPSL, derive the REAL cloud droplet
-        ! effective radius as re/fl
-
-        fl(i, k) = seuil_neb*(1.-icefrac_optics(i,k))
-        re(i, k) = rad_chaud(i, k)*fl(i, k)
-        rel = 0.
-        rei = 0.
-        pclc(i, k) = 0.0
-        pcltau(i, k) = 0.0
-        pclemi(i, k) = 0.0
-
-      ELSE
-
-        ! -- liquid/ice cloud water paths:
-
-        zflwp_var = 1000.*(1.-icefrac_optics(i,k))*radocond(i, k)/pclc(i, k)*rhodz(i, k)
-        zfiwp_var = 1000.*icefrac_optics(i, k)*radocond(i, k)/pclc(i, k)*rhodz(i, k)
-
-        ! effective cloud droplet radius (microns) for liquid water clouds:
-        ! For output diagnostics cloud droplet effective radius [um]
-        ! we multiply here with f Effective radius of cloud droplet at top of cloud (m)* xl (fraction of liquid water
-        ! clouds in the grid cell) to avoid problems in the averaging of the
-        ! output.
-        ! In the output of IOIPSL, derive the REAL cloud droplet
-        ! effective radius as re/fl
-
-        fl(i, k) = pclc(i, k)*(1.-icefrac_optics(i,k))
-        re(i, k) = rad_chaud(i, k)*fl(i, k)
-
-        rel = rad_chaud(i, k)
-
-        ! Calculation of ice cloud effective radius in micron
-
-
-        IF (iflag_rei .GT. 0) THEN
-
-            ! when we account for precipitation in the radiation scheme,
-            ! we use the rei formula from Sun and Rikkus 1999 with a revision
-            ! from Sun 2001 (as in the IFS model)
-            iwc=icefrac_optics(i, k)*radocond(i, k)/pclc(i,k)*zrho(i,k)*1000. !in cloud ice water content in g/m3
-            dei=(1.2351+0.0105*(temp(i,k)-273.15))*(45.8966*(iwc**0.2214) + &
-               &0.7957*(iwc**0.2535)*(temp(i,k)-83.15))
-            !deimax=155.0
-            !deimin=20.+40*cos(abs(latitude_deg(i))/180.*RPI)
-            !Etienne: deimax and deimin controled by rei_max and rei_min in physiq.def
-            deimax=rei_max*2.0
-            deimin=2.0*rei_min+40*cos(abs(latitude_deg(i))/180.*RPI) 
-            dei=min(dei,deimax)
-            dei=max(dei,deimin)
-            rei=3.*sqrt(3.)/8.*dei
-       
-        ELSE
-            ! Default
-            ! for ice clouds: as a function of the ambiant temperature
-            ! [formula used by Iacobellis and Somerville (2000), with an
-            ! asymptotical value of 3.5 microns at T<-81.4 C added to be
-            ! consistent with observations of Heymsfield et al. 1986]:
-            ! 2011/05/24 : rei_min = 3.5 becomes a free PARAMETER as well as
-            ! rei_max=61.29
-            tc = temp(i, k) - 273.15
-            rei = d_rei_dt*tc + rei_max
-            IF (tc<=-81.4) rei = rei_min
-        ENDIF
-        ! -- cloud optical thickness :
-        ! [for liquid clouds, traditional formula,
-        ! for ice clouds, Ebert & Curry (1992)]
-
-        IF (zflwp_var==0.) rel = 1.
-        IF (zfiwp_var==0. .OR. rei<=0.) rei = 1.
-        pcltau(i, k) = 3.0/2.0*(zflwp_var/rel) + zfiwp_var*(3.448E-03+2.431/ &
-          rei)
-
-        ! -- cloud infrared emissivity:
-        ! [the broadband infrared absorption coefficient is PARAMETERized
-        ! as a function of the effective cld droplet radius]
-        ! Ebert and Curry (1992) formula as used by Kiehl & Zender (1995):
-
-        k_ice = k_ice0 + 1.0/rei
-
-        pclemi(i, k) = 1.0 - exp(-coef_chau*zflwp_var-df*k_ice*zfiwp_var)
-
-      ENDIF
-
-      reice(i, k) = rei
-
-      xflwp(i) = xflwp(i) + xflwc(i, k)*rhodz(i, k)
-      xfiwp(i) = xfiwp(i) + xfiwc(i, k)*rhodz(i, k)
-
-    ENDDO
-  ENDDO
-
-  ! --if cloud droplet radius is fixed, then pcldtaupi=pcltau
-
-  IF (.NOT. ok_cdnc) THEN
-    DO k = 1, klev
-      DO i = 1, klon
-        pcldtaupi(i, k) = pcltau(i, k)
-        reice_pi(i, k) = reice(i, k)
-      ENDDO
-    ENDDO
-  ENDIF
-
-  DO k = 1, klev
-    DO i = 1, klon
-      reliq(i, k) = rad_chaud(i, k)
-      reliq_pi(i, k) = rad_chaud_pi(i, k)
-      reice_pi(i, k) = reice(i, k)
-    ENDDO
-  ENDDO
-
-  ! COMPUTE CLOUD LIQUID PATH AND TOTAL CLOUDINESS
-  ! IM cf. CR:test: calcul prenant ou non en compte le recouvrement
-  ! initialisations
-
-  DO i = 1, klon
-    zclear(i) = 1.
-    zcloud(i) = 0.
-    zcloudh(i) = 0.
-    zcloudm(i) = 0.
-    zcloudl(i) = 0.
-    pch(i) = 1.0
-    pcm(i) = 1.0
-    pcl(i) = 1.0
-    radocondwp(i) = 0.0
-  ENDDO
-
-  ! --calculation of liquid water path
-
-  DO k = klev, 1, -1
-    DO i = 1, klon
-      radocondwp(i) = radocondwp(i) + radocond(i, k)*rhodz(i, k)
-    ENDDO
-  ENDDO
-
-  ! --calculation of cloud properties with cloud overlap
-  ! choix de l'hypothese de recouvrement nuageuse via radopt.h (IM, 19.07.2016)
-  ! !novlp=1: max-random
-  ! !novlp=2: maximum
-  ! !novlp=3: random
-
-
-  IF (novlp==1) THEN
-    DO k = klev, 1, -1
-      DO i = 1, klon
-        zclear(i) = zclear(i)*(1.-max(pclc(i,k),zcloud(i)))/(1.-min(real( &
-          zcloud(i),kind=8),1.-zepsec))
-        pct(i) = 1. - zclear(i)
-        IF (paprs(i,k)<prmhc) THEN
-          pch(i) = pch(i)*(1.-max(pclc(i,k),zcloudh(i)))/(1.-min(real(zcloudh &
-            (i),kind=8),1.-zepsec))
-          zcloudh(i) = pclc(i, k)
-        ELSE IF (paprs(i,k)>=prmhc .AND. paprs(i,k)<prlmc) THEN
-          pcm(i) = pcm(i)*(1.-max(pclc(i,k),zcloudm(i)))/(1.-min(real(zcloudm &
-            (i),kind=8),1.-zepsec))
-          zcloudm(i) = pclc(i, k)
-        ELSE IF (paprs(i,k)>=prlmc) THEN
-          pcl(i) = pcl(i)*(1.-max(pclc(i,k),zcloudl(i)))/(1.-min(real(zcloudl &
-            (i),kind=8),1.-zepsec))
-          zcloudl(i) = pclc(i, k)
-        ENDIF
-        zcloud(i) = pclc(i, k)
-      ENDDO
-    ENDDO
-  ELSE IF (novlp==2) THEN
-    DO k = klev, 1, -1
-      DO i = 1, klon
-        zcloud(i) = max(pclc(i,k), zcloud(i))
-        pct(i) = zcloud(i)
-        IF (paprs(i,k)<prmhc) THEN
-          pch(i) = min(pclc(i,k), pch(i))
-        ELSE IF (paprs(i,k)>=prmhc .AND. paprs(i,k)<prlmc) THEN
-          pcm(i) = min(pclc(i,k), pcm(i))
-        ELSE IF (paprs(i,k)>=prlmc) THEN
-          pcl(i) = min(pclc(i,k), pcl(i))
-        ENDIF
-      ENDDO
-    ENDDO
-  ELSE IF (novlp==3) THEN
-    DO k = klev, 1, -1
-      DO i = 1, klon
-        zclear(i) = zclear(i)*(1.-pclc(i,k))
-        pct(i) = 1 - zclear(i)
-        IF (paprs(i,k)<prmhc) THEN
-          pch(i) = pch(i)*(1.0-pclc(i,k))
-        ELSE IF (paprs(i,k)>=prmhc .AND. paprs(i,k)<prlmc) THEN
-          pcm(i) = pcm(i)*(1.0-pclc(i,k))
-        ELSE IF (paprs(i,k)>=prlmc) THEN
-          pcl(i) = pcl(i)*(1.0-pclc(i,k))
-        ENDIF
-      ENDDO
-    ENDDO
-  ENDIF
-
-  DO i = 1, klon
-    pch(i) = 1. - pch(i)
-    pcm(i) = 1. - pcm(i)
-    pcl(i) = 1. - pcl(i)
-  ENDDO
-
-  ! ========================================================
-  ! DIAGNOSTICS CALCULATION FOR CMIP5 PROTOCOL
-  ! ========================================================
-  ! change by Nicolas Yan (LSCE)
-  ! Cloud Droplet Number Concentration (CDNC) : 3D variable
-  ! Fractionnal cover by liquid water cloud (LCC3D) : 3D variable
-  ! Cloud Droplet Number Concentration at top of cloud (CLDNCL) : 2D variable
-  ! Droplet effective radius at top of cloud (REFFCLWTOP) : 2D variable
-  ! Fractionnal cover by liquid water at top of clouds (LCC) : 2D variable
-
-  IF (ok_cdnc) THEN
-
-    DO k = 1, klev
-      DO i = 1, klon
-        phase3d(i, k) = 1 - icefrac_optics(i, k)
-        IF (pclc(i,k)<=seuil_neb) THEN
-          lcc3d(i, k) = seuil_neb*phase3d(i, k)
-        ELSE
-          lcc3d(i, k) = pclc(i, k)*phase3d(i, k)
-        ENDIF
-        scdnc(i, k) = lcc3d(i, k)*cdnc(i, k) ! m-3
-      ENDDO
-    ENDDO
-
-    DO i = 1, klon
-      lcc(i) = 0.
-      reffclwtop(i) = 0.
-      cldncl(i) = 0.
-      IF (novlp.EQ.3 .OR. novlp.EQ.1) tcc(i) = 1.
-      IF (novlp.EQ.2) tcc(i) = 0.
-    ENDDO
-
-    DO i = 1, klon
-      DO k = klev - 1, 1, -1 !From TOA down
-
-          ! Test, if the cloud optical depth exceeds the necessary
-          ! threshold:
-
-        IF (pcltau(i,k)>thres_tau .AND. pclc(i,k)>thres_neb) THEN
-
-          IF (novlp.EQ.2) THEN
-            IF (first) THEN
-              WRITE (*, *) 'Hypothese de recouvrement: MAXIMUM'
-              first = .FALSE.
-            ENDIF
-            flag_max = -1.
-            ftmp(i) = max(tcc(i), pclc(i,k))
-          ENDIF
-
-          IF (novlp.EQ.3) THEN
-            IF (first) THEN
-              WRITE (*, *) 'Hypothese de recouvrement: RANDOM'
-              first = .FALSE.
-            ENDIF
-            flag_max = 1.
-            ftmp(i) = tcc(i)*(1-pclc(i,k))
-          ENDIF
-
-          IF (novlp.EQ.1) THEN
-            IF (first) THEN
-              WRITE (*, *) 'Hypothese de recouvrement: MAXIMUM_ &
-                &                                             &
-                &                                          RANDOM'
-              first = .FALSE.
-            ENDIF
-            flag_max = 1.
-            ftmp(i) = tcc(i)*(1.-max(pclc(i,k),pclc(i,k+1)))/(1.-min(pclc(i, &
-              k+1),1.-thres_neb))
-          ENDIF
-          ! Effective radius of cloud droplet at top of cloud (m)
-          reffclwtop(i) = reffclwtop(i) + rad_chaud(i, k)*1.0E-06*phase3d(i, &
-            k)*(tcc(i)-ftmp(i))*flag_max
-          ! CDNC at top of cloud (m-3)
-          cldncl(i) = cldncl(i) + cdnc(i, k)*phase3d(i, k)*(tcc(i)-ftmp(i))* &
-            flag_max
-          ! Liquid Cloud Content at top of cloud
-          lcc(i) = lcc(i) + phase3d(i, k)*(tcc(i)-ftmp(i))*flag_max
-          ! Total Cloud Content at top of cloud
-          tcc(i) = ftmp(i)
-
-        ENDIF ! is there a visible, not-too-small cloud?
-      ENDDO ! loop over k
-
-      IF (novlp.EQ.3 .OR. novlp.EQ.1) tcc(i) = 1. - tcc(i)
-
-    ENDDO ! loop over i
-
-    ! ! Convective and Stratiform Cloud Droplet Effective Radius (REFFCLWC
-    ! REFFCLWS)
-    DO i = 1, klon
-      DO k = 1, klev
-        ! Weight to be used for outputs: eau_liquide*couverture nuageuse
-        lcc3dcon(i, k) = rnebcon(i, k)*phase3d(i, k)*ccwcon(i, k) ! eau liquide convective
-        lcc3dstra(i, k) = pclc(i, k)*radocond(i, k)*phase3d(i, k)
-        lcc3dstra(i, k) = lcc3dstra(i, k) - lcc3dcon(i, k) ! eau liquide stratiforme
-        lcc3dstra(i, k) = max(lcc3dstra(i,k), 0.0)
-        !FC pour la glace (CAUSES)
-        icc3dcon(i, k) = rnebcon(i, k)*(1-phase3d(i, k))*ccwcon(i, k) !  glace convective
-        icc3dstra(i, k)= pclc(i, k)*radocond(i, k)*(1-phase3d(i, k))
-        icc3dstra(i, k) = icc3dstra(i, k) - icc3dcon(i, k) ! glace stratiforme
-        icc3dstra(i, k) = max( icc3dstra(i, k), 0.0)
-        !FC (CAUSES)
-
-        ! Compute cloud droplet radius as above in meter
-        radius = 1.1*((radocond(i,k)*pplay(i,k)/(rd*temp(i,k)))/(4./3*rpi*1000.* &
-          cdnc(i,k)))**(1./3.)
-        radius = max(radius, 5.E-6)
-        ! Convective Cloud Droplet Effective Radius (REFFCLWC) : variable 3D
-        reffclwc(i, k) = radius
-        reffclwc(i, k) = reffclwc(i, k)*lcc3dcon(i, k)
-        ! Stratiform Cloud Droplet Effective Radius (REFFCLWS) : variable 3D
-        reffclws(i, k) = radius
-        reffclws(i, k) = reffclws(i, k)*lcc3dstra(i, k)
-      ENDDO !klev
-    ENDDO !klon
-
-    ! Column Integrated Cloud Droplet Number (CLDNVI) : variable 2D
-
-    DO i = 1, klon
-      cldnvi(i) = 0.
-      lcc_integrat(i) = 0.
-      height(i) = 0.
-      DO k = 1, klev
-        cldnvi(i) = cldnvi(i) + cdnc(i, k)*lcc3d(i, k)*dh(i, k)
-        lcc_integrat(i) = lcc_integrat(i) + lcc3d(i, k)*dh(i, k)
-        height(i) = height(i) + dh(i, k)
-      ENDDO ! klev
-      lcc_integrat(i) = lcc_integrat(i)/height(i)
-      IF (lcc_integrat(i)<=1.0E-03) THEN
-        cldnvi(i) = cldnvi(i)*lcc(i)/seuil_neb
-      ELSE
-        cldnvi(i) = cldnvi(i)*lcc(i)/lcc_integrat(i)
-      ENDIF
-    ENDDO ! klon
-
-    DO i = 1, klon
-      DO k = 1, klev
-        IF (scdnc(i,k)<=0.0) scdnc(i, k) = 0.0
-        IF (reffclws(i,k)<=0.0) reffclws(i, k) = 0.0
-        IF (reffclwc(i,k)<=0.0) reffclwc(i, k) = 0.0
-        IF (lcc3d(i,k)<=0.0) lcc3d(i, k) = 0.0
-        IF (lcc3dcon(i,k)<=0.0) lcc3dcon(i, k) = 0.0
-        IF (lcc3dstra(i,k)<=0.0) lcc3dstra(i, k) = 0.0
-!FC (CAUSES)
-        IF (icc3dcon(i,k)<=0.0) icc3dcon(i, k) = 0.0
-        IF (icc3dstra(i,k)<=0.0) icc3dstra(i, k) = 0.0
-!FC (CAUSES)
-      ENDDO
-      IF (reffclwtop(i)<=0.0) reffclwtop(i) = 0.0
-      IF (cldncl(i)<=0.0) cldncl(i) = 0.0
-      IF (cldnvi(i)<=0.0) cldnvi(i) = 0.0
-      IF (lcc(i)<=0.0) lcc(i) = 0.0
-    ENDDO
-
-  ENDIF !ok_cdnc
-
-  first=.false. !to be sure
-
-  RETURN
-
-END SUBROUTINE cloud_optics_prop
-
-END MODULE lmdz_cloud_optics_prop
Index: /LMDZ6/trunk/libf/phylmd/lmdz_cloud_optics_prop.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/lmdz_cloud_optics_prop.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/lmdz_cloud_optics_prop.f90	(revision 5268)
@@ -0,0 +1,736 @@
+! $Id$
+MODULE lmdz_cloud_optics_prop
+
+CONTAINS
+
+SUBROUTINE cloud_optics_prop(klon, klev, paprs, pplay, temp, radocond, picefra, pclc, &
+    pcltau, pclemi, pch, pcl, pcm, pct, radocondwp, xflwp, xfiwp, xflwc, xfiwc, &
+    mass_solu_aero, mass_solu_aero_pi, pcldtaupi, distcltop, temp_cltop, re, fl, reliq, reice, &
+    reliq_pi, reice_pi, scdnc, cldncl, reffclwtop, lcc, reffclws, &
+    reffclwc, cldnvi, lcc3d, lcc3dcon, lcc3dstra, icc3dcon, icc3dstra,  & 
+    icefrac_optics, dNovrN, ptconv,rnebcon, ccwcon)
+
+  USE lmdz_cloud_optics_prop_ini , ONLY : flag_aerosol, ok_cdnc
+  USE lmdz_cloud_optics_prop_ini , ONLY : lunout
+  USE lmdz_cloud_optics_prop_ini , ONLY : bl95_b0, bl95_b1
+  USE lmdz_cloud_optics_prop_ini , ONLY : latitude_deg
+  USE lmdz_cloud_optics_prop_ini , ONLY : iflag_t_glace
+  USE lmdz_cloud_optics_prop_ini , ONLY : cdnc_max, cdnc_max_m3
+  USE lmdz_cloud_optics_prop_ini , ONLY : cdnc_min, cdnc_min_m3
+  USE lmdz_cloud_optics_prop_ini , ONLY : thres_tau, thres_neb
+  USE lmdz_cloud_optics_prop_ini , ONLY : prmhc, prlmc
+  USE lmdz_cloud_optics_prop_ini , ONLY : coef_froi, coef_chau
+  USE lmdz_cloud_optics_prop_ini , ONLY : seuil_neb
+  USE lmdz_cloud_optics_prop_ini , ONLY : t_glace_min_old, t_glace_max_old
+  USE lmdz_cloud_optics_prop_ini , ONLY : k_ice0, df
+  USE lmdz_cloud_optics_prop_ini , ONLY : rg, rd, rpi
+  USE lmdz_cloud_optics_prop_ini , ONLY : rad_chau1, rad_chau2, rad_froid, iflag_rei
+  USE lmdz_cloud_optics_prop_ini , ONLY : ok_icefra_lscp, rei_max, rei_min
+  USE lmdz_cloud_optics_prop_ini , ONLY : zepsec, novlp, iflag_ice_thermo, ok_new_lscp
+  
+
+
+
+  IMPLICIT NONE
+  ! ======================================================================
+  ! Authors: Z.X. Li (LMD/CNRS) date: 19930910
+  !          O.Boucher (LMD/CNRS) mise a jour en 201212
+  !          I. Musat (LMD/CNRS) : prise en compte de la meme hypothese 
+  !                              de recouvrement pour les nuages que pour 
+  !                              le rayonnement rrtm via le parametre
+  !                               novlp de radopt.h : 20160721
+  !          L.Fairheard, E.Vignon, JB Madeleine, L. Raillard, A. Idelkadi
+  !          M. Coulon-Decorzens: replayisation of the routine + cleaning
+  !                               and commentaries
+  !
+  ! Aim: compute condensate optical properties,
+  !      cloud optical depth and emissivity
+  ! ======================================================================
+  
+  ! List of arguments
+  !------------------
+
+  ! input:
+  INTEGER, INTENT(IN) :: klon, klev      ! number of horizontal and vertical grid points
+  REAL, INTENT(IN) :: paprs(klon, klev+1)! pressure at bottom interfaces [Pa]
+  REAL, INTENT(IN) :: pplay(klon, klev)  ! pressure at the middle of layers [Pa]
+  REAL, INTENT(IN) :: temp(klon, klev)   ! temperature [K]
+  REAL, INTENT(IN) :: radocond(klon, klev) ! cloud condensed water seen by radiation [kg/kg]
+  REAL, INTENT(IN) :: picefra(klon,klev) ! ice fraction in clouds from large scale condensation scheme [-]
+  REAL, INTENT(IN) :: rnebcon(klon,klev) ! convection cloud fraction [-]
+  REAL, INTENT(IN) :: ccwcon(klon,klev)  ! condensed water from deep convection [kg/kg]
+  ! jq for the aerosol indirect effect
+  ! jq introduced by Johannes Quaas (quaas@lmd.jussieu.fr), 27/11/2003
+  REAL, INTENT(IN) :: mass_solu_aero(klon, klev)    ! total mass concentration for all soluble aerosols [ug m-3]
+  REAL, INTENT(IN) :: mass_solu_aero_pi(klon, klev) ! - (pre-industrial value)
+  REAL, INTENT(IN)  :: dNovrN(klon)         ! enhancement factor for cdnc
+  REAL, INTENT(OUT) :: distcltop(klon,klev) ! distance from large scale cloud top [m]
+  REAL, INTENT(OUT) :: temp_cltop(klon,klev)!temperature at large scale cloud top [K]
+
+  LOGICAL, INTENT(IN) :: ptconv(klon, klev) ! flag for grid points affected by deep convection
+
+  ! inout:
+  REAL, INTENT(INOUT) :: pclc(klon, klev) ! cloud fraction for radiation [-]
+
+  ! out:
+  REAL, INTENT(OUT) :: pct(klon)      ! 2D total cloud cover [-]
+  REAL, INTENT(OUT) :: pcl(klon)      ! 2D low cloud cover [-]
+  REAL, INTENT(OUT) :: pcm(klon)      ! 2D mid cloud cover [-]
+  REAL, INTENT(OUT) :: pch(klon)      ! 2D high cloud cover [-]
+  REAL, INTENT(OUT) :: radocondwp(klon) ! total condensed water path (seen by radiation) [kg/m2]
+  REAL, INTENT(OUT) :: xflwp(klon)    ! liquid water path (seen by radiation) [kg/m2]
+  REAL, INTENT(OUT) :: xfiwp(klon)    ! ice water path (seen by radiation) [kg/m2]
+  REAL, INTENT(OUT) :: xflwc(klon, klev) ! liquid water content seen by radiation [kg/kg]
+  REAL, INTENT(OUT) :: xfiwc(klon, klev) ! ice water content seen by radiation [kg/kg]
+  REAL, INTENT(OUT) :: re(klon, klev) ! cloud droplet effective radius multiplied by fl
+  REAL, INTENT(OUT) :: fl(klon, klev) ! xliq * rneb, denominator to re; fraction of liquid water clouds
+                                      ! introduced to avoid problems in the averaging of the output
+                                      ! water clouds within a grid cell
+
+  REAL, INTENT(OUT) :: pcltau(klon, klev) ! cloud optical depth [m]
+  REAL, INTENT(OUT) :: pclemi(klon, klev) ! cloud emissivity [-]
+  REAL, INTENT(OUT) :: pcldtaupi(klon, klev) ! pre-industrial value of cloud optical thickness, ie.
+                                             ! values of optical thickness that does not account
+                                             ! for aerosol effects on cloud droplet radius [m]
+
+  REAL, INTENT(OUT) :: reliq(klon, klev)   ! liquid droplet effective radius [m] 
+  REAL, INTENT(OUT) :: reice(klon, klev)   ! ice effective radius [m]
+  REAL, INTENT(OUT) :: reliq_pi(klon, klev)! liquid droplet effective radius [m], pre-industrial
+  REAL, INTENT(OUT) :: reice_pi(klon, klev)! ice effective radius [m], pre-industrial
+  REAL, INTENT(OUT) :: scdnc(klon, klev)   ! cloud droplet number concentration, mean over the whole mesh [m-3]
+  REAL, INTENT(OUT) :: cldncl(klon)        ! cloud droplet number concentration at top of cloud [m-3]
+  REAL, INTENT(OUT) :: reffclwtop(klon)    ! effective radius of cloud droplet at top of cloud [m] 
+  REAL, INTENT(OUT) :: lcc(klon)           ! liquid Cloud Content at top of cloud [kg/kg]
+  REAL, INTENT(OUT) :: reffclws(klon, klev)! stratiform cloud droplet effective radius 
+  REAL, INTENT(OUT) :: reffclwc(klon, klev)! convective cloud droplet effective radius 
+  REAL, INTENT(OUT) :: cldnvi(klon)        ! column Integrated cloud droplet Number [/m2]
+  REAL, INTENT(OUT) :: lcc3d(klon, klev)   ! cloud fraction for liquid part only [-]
+  REAL, INTENT(OUT) :: lcc3dcon(klon, klev)! cloud fraction for liquid part only, convective clouds [-]
+  REAL, INTENT(OUT) :: lcc3dstra(klon, klev)!cloud fraction for liquid part only, stratiform clouds [-]
+  REAL, INTENT(OUT) :: icc3dcon(klon, klev)! cloud fraction for liquid part only, convective clouds [-]
+  REAL, INTENT(OUT) :: icc3dstra(klon, klev)! cloud fraction for ice part only, stratiform clouds [-] 
+  REAL, INTENT(INOUT) :: icefrac_optics(klon, klev)! ice fraction in clouds seen by radiation [-]
+
+  ! Local variables
+  !----------------
+
+  LOGICAL, SAVE :: first = .TRUE.
+  !$OMP THREADPRIVATE(FIRST)
+  INTEGER flag_max
+
+  ! threshold PARAMETERs
+  REAL phase3d(klon, klev)
+  REAL tcc(klon), ftmp(klon), lcc_integrat(klon), height(klon)
+  LOGICAL lo
+  INTEGER i, k
+  REAL radius
+
+
+  REAL rel, tc, rei, iwc, dei, deimin, deimax
+  REAL k_ice
+
+  ! jq for the aerosol indirect effect
+  ! jq introduced by Johannes Quaas (quaas@lmd.jussieu.fr), 27/11/2003
+  REAL cdnc(klon, klev) ! cloud droplet number concentration [m-3]
+  REAL cdnc_pi(klon, klev) ! cloud droplet number concentration [m-3] (pi value)
+  REAL re_pi(klon, klev) ! cloud droplet effective radius [um] (pi value)
+
+  ! IM cf. CR:parametres supplementaires
+  REAL dzfice(klon,klev)
+  REAL zclear(klon)
+  REAL zcloud(klon)
+  REAL zcloudh(klon)
+  REAL zcloudm(klon)
+  REAL zcloudl(klon)
+  REAL rhodz(klon, klev) !--rho*dz pour la couche
+  REAL zrho(klon, klev) !--rho pour la couche
+  REAL dh(klon, klev) !--dz pour la couche
+  REAL rad_chaud(klon, klev) !--rayon pour les nuages chauds
+  REAL rad_chaud_pi(klon, klev) !--rayon pour les nuages chauds pre-industriels
+  REAL zflwp_var, zfiwp_var
+  REAL d_rei_dt
+
+
+  ! FH : 2011/05/24
+  ! rei = ( rei_max - rei_min ) * T(°C) / 81.4 + rei_max
+  ! to be used for a temperature in celcius T(°C) < 0
+  ! rei=rei_min for T(°C) < -81.4
+  ! Calcul de la pente de la relation entre rayon effective des cristaux
+  ! et la température Pour retrouver les résultats numériques de la version d'origine,
+  ! on impose 0.71 quand on est proche de 0.71
+  d_rei_dt = (rei_max-rei_min)/81.4
+  IF (abs(d_rei_dt-0.71)<1.E-4) d_rei_dt = 0.71
+
+  ! Calculer l'epaisseur optique et l'emmissivite des nuages
+  ! IM inversion des DO
+
+  xflwp = 0.D0
+  xfiwp = 0.D0
+  xflwc = 0.D0
+  xfiwc = 0.D0
+
+  reliq = 0.
+  reice = 0.
+  reliq_pi = 0.
+  reice_pi = 0.
+
+  IF (iflag_t_glace.EQ.0) THEN
+    DO k = 1, klev
+      DO i = 1, klon
+        ! -layer calculation
+        rhodz(i, k) = (paprs(i,k)-paprs(i,k+1))/rg ! kg/m2
+        zrho(i, k) = pplay(i, k)/temp(i, k)/rd ! kg/m3
+        dh(i, k) = rhodz(i, k)/zrho(i, k) ! m
+        ! -Fraction of ice in cloud using a linear transition
+        icefrac_optics(i, k) = 1.0 - (temp(i,k)-t_glace_min_old)/(t_glace_max_old-t_glace_min_old)
+        icefrac_optics(i, k) = min(max(icefrac_optics(i,k),0.0), 1.0)
+        ! -IM Total Liquid/Ice water content
+        xflwc(i, k) = (1.-icefrac_optics(i,k))*radocond(i, k)
+        xfiwc(i, k) = icefrac_optics(i, k)*radocond(i, k)
+      ENDDO
+    ENDDO
+  ELSE ! of IF (iflag_t_glace.EQ.0)
+    DO k = 1, klev
+
+
+!!$      IF (ok_new_lscp) THEN
+!!$          CALL icefrac_lscp(klon,temp(:,k),iflag_ice_thermo,distcltop(:,k),temp_cltop(:,k),icefrac_optics(:,k),dzfice(:,k))
+!!$      ELSE
+!!$          CALL icefrac_lsc(klon,temp(:,k),pplay(:,k)/paprs(:,1),icefrac_optics(:,k))
+!!$      ENDIF
+
+      DO i = 1, klon
+        
+        IF ((.NOT. ptconv(i,k)) .AND. ok_new_lscp .AND. ok_icefra_lscp) THEN
+        ! EV: take the ice fraction directly from the lscp code
+        ! consistent only for non convective grid points
+        ! critical for mixed phase clouds
+            icefrac_optics(i,k)=picefra(i,k)
+        ENDIF
+
+        ! -layer calculation
+        rhodz(i, k) = (paprs(i,k)-paprs(i,k+1))/rg ! kg/m2
+        zrho(i, k) = pplay(i, k)/temp(i, k)/rd ! kg/m3
+        dh(i, k) = rhodz(i, k)/zrho(i, k) ! m
+        ! -IM Total Liquid/Ice water content
+        xflwc(i, k) = (1.-icefrac_optics(i,k))*radocond(i, k)
+        xfiwc(i, k) = icefrac_optics(i, k)*radocond(i, k)
+      ENDDO
+    ENDDO
+  ENDIF
+
+
+
+
+
+
+  IF (ok_cdnc) THEN
+
+    ! --we compute cloud properties as a function of the aerosol load
+
+    DO k = 1, klev
+      DO i = 1, klon
+        ! Formula "D" of Boucher and Lohmann, Tellus, 1995
+        ! Cloud droplet number concentration (CDNC) is restricted
+        ! to be within [20, 1000 cm^3]
+
+        ! --pre-industrial case
+        cdnc_pi(i, k) = 10.**(bl95_b0+bl95_b1*log(max(mass_solu_aero_pi(i,k), &
+          1.E-4))/log(10.))*1.E6 !-m-3
+        cdnc_pi(i, k) = min(cdnc_max_m3, max(cdnc_min_m3,cdnc_pi(i,k)))
+
+      ENDDO
+    ENDDO
+
+    !--flag_aerosol=7 => MACv2SP climatology 
+    !--in this case there is an enhancement factor
+    IF (flag_aerosol .EQ. 7) THEN 
+
+      !--present-day
+      DO k = 1, klev
+        DO i = 1, klon
+          cdnc(i, k) = cdnc_pi(i,k)*dNovrN(i)
+        ENDDO
+      ENDDO
+
+    !--standard case
+    ELSE
+
+      DO k = 1, klev
+        DO i = 1, klon
+
+          ! Formula "D" of Boucher and Lohmann, Tellus, 1995
+          ! Cloud droplet number concentration (CDNC) is restricted
+          ! to be within [20, 1000 cm^3]
+
+          ! --present-day case
+          cdnc(i, k) = 10.**(bl95_b0+bl95_b1*log(max(mass_solu_aero(i,k), &
+            1.E-4))/log(10.))*1.E6 !-m-3
+          cdnc(i, k) = min(cdnc_max_m3, max(cdnc_min_m3,cdnc(i,k)))
+
+        ENDDO
+      ENDDO
+
+    ENDIF !--flag_aerosol
+
+    !--computing cloud droplet size
+    DO k = 1, klev
+      DO i = 1, klon
+
+        ! --present-day case
+        rad_chaud(i, k) = 1.1*((radocond(i,k)*pplay(i, &
+          k)/(rd*temp(i,k)))/(4./3*rpi*1000.*cdnc(i,k)))**(1./3.)
+        rad_chaud(i, k) = max(rad_chaud(i,k)*1.E6, 5.)
+
+        ! --pre-industrial case
+        rad_chaud_pi(i, k) = 1.1*((radocond(i,k)*pplay(i, &
+          k)/(rd*temp(i,k)))/(4./3.*rpi*1000.*cdnc_pi(i,k)))**(1./3.)
+        rad_chaud_pi(i, k) = max(rad_chaud_pi(i,k)*1.E6, 5.)
+
+        ! --pre-industrial case
+        ! --liquid/ice cloud water paths:
+        IF (pclc(i,k)<=seuil_neb) THEN
+
+          pcldtaupi(i, k) = 0.0
+
+        ELSE
+
+          zflwp_var = 1000.*(1.-icefrac_optics(i,k))*radocond(i, k)/pclc(i, k)* &
+            rhodz(i, k)
+          zfiwp_var = 1000.*icefrac_optics(i, k)*radocond(i, k)/pclc(i, k)*rhodz(i, k)
+          ! Calculation of ice cloud effective radius in micron
+          IF (iflag_rei .EQ. 1) THEN
+            ! when we account for precipitation in the radiation scheme,
+            ! It is recommended to use the rei formula from Sun and Rikkus 1999 with a revision
+            ! from Sun 2001 (as in the IFS model)
+            iwc=icefrac_optics(i, k)*radocond(i, k)/pclc(i,k)*zrho(i,k)*1000. !in cloud ice water content in g/m3
+            dei=(1.2351+0.0105*(temp(i,k)-273.15))*(45.8966*(iwc**0.2214) + &
+               & 0.7957*(iwc**0.2535)*(temp(i,k)-83.15))
+            !deimax=155.0
+            !deimin=20.+40*cos(abs(latitude_deg(i))/180.*RPI)
+            !Etienne: deimax and deimin controled by rei_max and rei_min in physiq.def
+            deimax=rei_max*2.0
+            deimin=2.0*rei_min+40*cos(abs(latitude_deg(i))/180.*RPI) 
+            dei=min(dei,deimax)
+            dei=max(dei,deimin)
+            rei=3.*sqrt(3.)/8.*dei
+           ELSE
+            ! Default
+            ! for ice clouds: as a function of the ambiant temperature
+            ! [formula used by Iacobellis and Somerville (2000), with an
+            ! asymptotical value of 3.5 microns at T<-81.4 C added to be
+            ! consistent with observations of Heymsfield et al. 1986]:
+            ! 2011/05/24 : rei_min = 3.5 becomes a free PARAMETER as well as
+            ! rei_max=61.29
+            tc = temp(i, k) - 273.15
+            rei = d_rei_dt*tc + rei_max
+            IF (tc<=-81.4) rei = rei_min
+           ENDIF
+
+          ! -- cloud optical thickness :
+          ! [for liquid clouds, traditional formula,
+          ! for ice clouds, Ebert & Curry (1992)]
+
+          IF (zfiwp_var==0. .OR. rei<=0.) rei = 1.
+          pcldtaupi(i, k) = 3.0/2.0*zflwp_var/rad_chaud_pi(i, k) + &
+            zfiwp_var*(3.448E-03+2.431/rei)
+
+        ENDIF
+
+      ENDDO
+    ENDDO
+
+  ELSE !--not ok_cdnc
+
+    ! -prescribed cloud droplet radius
+
+    DO k = 1, min(3, klev)
+      DO i = 1, klon
+        rad_chaud(i, k) = rad_chau2
+        rad_chaud_pi(i, k) = rad_chau2
+      ENDDO
+    ENDDO
+    DO k = min(3, klev) + 1, klev
+      DO i = 1, klon
+        rad_chaud(i, k) = rad_chau1
+        rad_chaud_pi(i, k) = rad_chau1
+      ENDDO
+    ENDDO
+
+  ENDIF !--ok_cdnc
+
+  ! --computation of cloud optical depth and emissivity
+  ! --in the general case
+
+  DO k = 1, klev
+    DO i = 1, klon
+
+      IF (pclc(i,k)<=seuil_neb) THEN
+
+        ! effective cloud droplet radius (microns) for liquid water clouds:
+        ! For output diagnostics cloud droplet effective radius [um]
+        ! we multiply here with f * xl (fraction of liquid water
+        ! clouds in the grid cell) to avoid problems in the averaging of the
+        ! output.
+        ! In the output of IOIPSL, derive the REAL cloud droplet
+        ! effective radius as re/fl
+
+        fl(i, k) = seuil_neb*(1.-icefrac_optics(i,k))
+        re(i, k) = rad_chaud(i, k)*fl(i, k)
+        rel = 0.
+        rei = 0.
+        pclc(i, k) = 0.0
+        pcltau(i, k) = 0.0
+        pclemi(i, k) = 0.0
+
+      ELSE
+
+        ! -- liquid/ice cloud water paths:
+
+        zflwp_var = 1000.*(1.-icefrac_optics(i,k))*radocond(i, k)/pclc(i, k)*rhodz(i, k)
+        zfiwp_var = 1000.*icefrac_optics(i, k)*radocond(i, k)/pclc(i, k)*rhodz(i, k)
+
+        ! effective cloud droplet radius (microns) for liquid water clouds:
+        ! For output diagnostics cloud droplet effective radius [um]
+        ! we multiply here with f Effective radius of cloud droplet at top of cloud (m)* xl (fraction of liquid water
+        ! clouds in the grid cell) to avoid problems in the averaging of the
+        ! output.
+        ! In the output of IOIPSL, derive the REAL cloud droplet
+        ! effective radius as re/fl
+
+        fl(i, k) = pclc(i, k)*(1.-icefrac_optics(i,k))
+        re(i, k) = rad_chaud(i, k)*fl(i, k)
+
+        rel = rad_chaud(i, k)
+
+        ! Calculation of ice cloud effective radius in micron
+
+
+        IF (iflag_rei .GT. 0) THEN
+
+            ! when we account for precipitation in the radiation scheme,
+            ! we use the rei formula from Sun and Rikkus 1999 with a revision
+            ! from Sun 2001 (as in the IFS model)
+            iwc=icefrac_optics(i, k)*radocond(i, k)/pclc(i,k)*zrho(i,k)*1000. !in cloud ice water content in g/m3
+            dei=(1.2351+0.0105*(temp(i,k)-273.15))*(45.8966*(iwc**0.2214) + &
+               &0.7957*(iwc**0.2535)*(temp(i,k)-83.15))
+            !deimax=155.0
+            !deimin=20.+40*cos(abs(latitude_deg(i))/180.*RPI)
+            !Etienne: deimax and deimin controled by rei_max and rei_min in physiq.def
+            deimax=rei_max*2.0
+            deimin=2.0*rei_min+40*cos(abs(latitude_deg(i))/180.*RPI) 
+            dei=min(dei,deimax)
+            dei=max(dei,deimin)
+            rei=3.*sqrt(3.)/8.*dei
+       
+        ELSE
+            ! Default
+            ! for ice clouds: as a function of the ambiant temperature
+            ! [formula used by Iacobellis and Somerville (2000), with an
+            ! asymptotical value of 3.5 microns at T<-81.4 C added to be
+            ! consistent with observations of Heymsfield et al. 1986]:
+            ! 2011/05/24 : rei_min = 3.5 becomes a free PARAMETER as well as
+            ! rei_max=61.29
+            tc = temp(i, k) - 273.15
+            rei = d_rei_dt*tc + rei_max
+            IF (tc<=-81.4) rei = rei_min
+        ENDIF
+        ! -- cloud optical thickness :
+        ! [for liquid clouds, traditional formula,
+        ! for ice clouds, Ebert & Curry (1992)]
+
+        IF (zflwp_var==0.) rel = 1.
+        IF (zfiwp_var==0. .OR. rei<=0.) rei = 1.
+        pcltau(i, k) = 3.0/2.0*(zflwp_var/rel) + zfiwp_var*(3.448E-03+2.431/ &
+          rei)
+
+        ! -- cloud infrared emissivity:
+        ! [the broadband infrared absorption coefficient is PARAMETERized
+        ! as a function of the effective cld droplet radius]
+        ! Ebert and Curry (1992) formula as used by Kiehl & Zender (1995):
+
+        k_ice = k_ice0 + 1.0/rei
+
+        pclemi(i, k) = 1.0 - exp(-coef_chau*zflwp_var-df*k_ice*zfiwp_var)
+
+      ENDIF
+
+      reice(i, k) = rei
+
+      xflwp(i) = xflwp(i) + xflwc(i, k)*rhodz(i, k)
+      xfiwp(i) = xfiwp(i) + xfiwc(i, k)*rhodz(i, k)
+
+    ENDDO
+  ENDDO
+
+  ! --if cloud droplet radius is fixed, then pcldtaupi=pcltau
+
+  IF (.NOT. ok_cdnc) THEN
+    DO k = 1, klev
+      DO i = 1, klon
+        pcldtaupi(i, k) = pcltau(i, k)
+        reice_pi(i, k) = reice(i, k)
+      ENDDO
+    ENDDO
+  ENDIF
+
+  DO k = 1, klev
+    DO i = 1, klon
+      reliq(i, k) = rad_chaud(i, k)
+      reliq_pi(i, k) = rad_chaud_pi(i, k)
+      reice_pi(i, k) = reice(i, k)
+    ENDDO
+  ENDDO
+
+  ! COMPUTE CLOUD LIQUID PATH AND TOTAL CLOUDINESS
+  ! IM cf. CR:test: calcul prenant ou non en compte le recouvrement
+  ! initialisations
+
+  DO i = 1, klon
+    zclear(i) = 1.
+    zcloud(i) = 0.
+    zcloudh(i) = 0.
+    zcloudm(i) = 0.
+    zcloudl(i) = 0.
+    pch(i) = 1.0
+    pcm(i) = 1.0
+    pcl(i) = 1.0
+    radocondwp(i) = 0.0
+  ENDDO
+
+  ! --calculation of liquid water path
+
+  DO k = klev, 1, -1
+    DO i = 1, klon
+      radocondwp(i) = radocondwp(i) + radocond(i, k)*rhodz(i, k)
+    ENDDO
+  ENDDO
+
+  ! --calculation of cloud properties with cloud overlap
+  ! choix de l'hypothese de recouvrement nuageuse via radopt.h (IM, 19.07.2016)
+  ! !novlp=1: max-random
+  ! !novlp=2: maximum
+  ! !novlp=3: random
+
+
+  IF (novlp==1) THEN
+    DO k = klev, 1, -1
+      DO i = 1, klon
+        zclear(i) = zclear(i)*(1.-max(pclc(i,k),zcloud(i)))/(1.-min(real( &
+          zcloud(i),kind=8),1.-zepsec))
+        pct(i) = 1. - zclear(i)
+        IF (paprs(i,k)<prmhc) THEN
+          pch(i) = pch(i)*(1.-max(pclc(i,k),zcloudh(i)))/(1.-min(real(zcloudh &
+            (i),kind=8),1.-zepsec))
+          zcloudh(i) = pclc(i, k)
+        ELSE IF (paprs(i,k)>=prmhc .AND. paprs(i,k)<prlmc) THEN
+          pcm(i) = pcm(i)*(1.-max(pclc(i,k),zcloudm(i)))/(1.-min(real(zcloudm &
+            (i),kind=8),1.-zepsec))
+          zcloudm(i) = pclc(i, k)
+        ELSE IF (paprs(i,k)>=prlmc) THEN
+          pcl(i) = pcl(i)*(1.-max(pclc(i,k),zcloudl(i)))/(1.-min(real(zcloudl &
+            (i),kind=8),1.-zepsec))
+          zcloudl(i) = pclc(i, k)
+        ENDIF
+        zcloud(i) = pclc(i, k)
+      ENDDO
+    ENDDO
+  ELSE IF (novlp==2) THEN
+    DO k = klev, 1, -1
+      DO i = 1, klon
+        zcloud(i) = max(pclc(i,k), zcloud(i))
+        pct(i) = zcloud(i)
+        IF (paprs(i,k)<prmhc) THEN
+          pch(i) = min(pclc(i,k), pch(i))
+        ELSE IF (paprs(i,k)>=prmhc .AND. paprs(i,k)<prlmc) THEN
+          pcm(i) = min(pclc(i,k), pcm(i))
+        ELSE IF (paprs(i,k)>=prlmc) THEN
+          pcl(i) = min(pclc(i,k), pcl(i))
+        ENDIF
+      ENDDO
+    ENDDO
+  ELSE IF (novlp==3) THEN
+    DO k = klev, 1, -1
+      DO i = 1, klon
+        zclear(i) = zclear(i)*(1.-pclc(i,k))
+        pct(i) = 1 - zclear(i)
+        IF (paprs(i,k)<prmhc) THEN
+          pch(i) = pch(i)*(1.0-pclc(i,k))
+        ELSE IF (paprs(i,k)>=prmhc .AND. paprs(i,k)<prlmc) THEN
+          pcm(i) = pcm(i)*(1.0-pclc(i,k))
+        ELSE IF (paprs(i,k)>=prlmc) THEN
+          pcl(i) = pcl(i)*(1.0-pclc(i,k))
+        ENDIF
+      ENDDO
+    ENDDO
+  ENDIF
+
+  DO i = 1, klon
+    pch(i) = 1. - pch(i)
+    pcm(i) = 1. - pcm(i)
+    pcl(i) = 1. - pcl(i)
+  ENDDO
+
+  ! ========================================================
+  ! DIAGNOSTICS CALCULATION FOR CMIP5 PROTOCOL
+  ! ========================================================
+  ! change by Nicolas Yan (LSCE)
+  ! Cloud Droplet Number Concentration (CDNC) : 3D variable
+  ! Fractionnal cover by liquid water cloud (LCC3D) : 3D variable
+  ! Cloud Droplet Number Concentration at top of cloud (CLDNCL) : 2D variable
+  ! Droplet effective radius at top of cloud (REFFCLWTOP) : 2D variable
+  ! Fractionnal cover by liquid water at top of clouds (LCC) : 2D variable
+
+  IF (ok_cdnc) THEN
+
+    DO k = 1, klev
+      DO i = 1, klon
+        phase3d(i, k) = 1 - icefrac_optics(i, k)
+        IF (pclc(i,k)<=seuil_neb) THEN
+          lcc3d(i, k) = seuil_neb*phase3d(i, k)
+        ELSE
+          lcc3d(i, k) = pclc(i, k)*phase3d(i, k)
+        ENDIF
+        scdnc(i, k) = lcc3d(i, k)*cdnc(i, k) ! m-3
+      ENDDO
+    ENDDO
+
+    DO i = 1, klon
+      lcc(i) = 0.
+      reffclwtop(i) = 0.
+      cldncl(i) = 0.
+      IF (novlp.EQ.3 .OR. novlp.EQ.1) tcc(i) = 1.
+      IF (novlp.EQ.2) tcc(i) = 0.
+    ENDDO
+
+    DO i = 1, klon
+      DO k = klev - 1, 1, -1 !From TOA down
+
+          ! Test, if the cloud optical depth exceeds the necessary
+          ! threshold:
+
+        IF (pcltau(i,k)>thres_tau .AND. pclc(i,k)>thres_neb) THEN
+
+          IF (novlp.EQ.2) THEN
+            IF (first) THEN
+              WRITE (*, *) 'Hypothese de recouvrement: MAXIMUM'
+              first = .FALSE.
+            ENDIF
+            flag_max = -1.
+            ftmp(i) = max(tcc(i), pclc(i,k))
+          ENDIF
+
+          IF (novlp.EQ.3) THEN
+            IF (first) THEN
+              WRITE (*, *) 'Hypothese de recouvrement: RANDOM'
+              first = .FALSE.
+            ENDIF
+            flag_max = 1.
+            ftmp(i) = tcc(i)*(1-pclc(i,k))
+          ENDIF
+
+          IF (novlp.EQ.1) THEN
+            IF (first) THEN
+              WRITE (*, *) 'Hypothese de recouvrement: MAXIMUM_ &
+                &                                             &
+                &                                          RANDOM'
+              first = .FALSE.
+            ENDIF
+            flag_max = 1.
+            ftmp(i) = tcc(i)*(1.-max(pclc(i,k),pclc(i,k+1)))/(1.-min(pclc(i, &
+              k+1),1.-thres_neb))
+          ENDIF
+          ! Effective radius of cloud droplet at top of cloud (m)
+          reffclwtop(i) = reffclwtop(i) + rad_chaud(i, k)*1.0E-06*phase3d(i, &
+            k)*(tcc(i)-ftmp(i))*flag_max
+          ! CDNC at top of cloud (m-3)
+          cldncl(i) = cldncl(i) + cdnc(i, k)*phase3d(i, k)*(tcc(i)-ftmp(i))* &
+            flag_max
+          ! Liquid Cloud Content at top of cloud
+          lcc(i) = lcc(i) + phase3d(i, k)*(tcc(i)-ftmp(i))*flag_max
+          ! Total Cloud Content at top of cloud
+          tcc(i) = ftmp(i)
+
+        ENDIF ! is there a visible, not-too-small cloud?
+      ENDDO ! loop over k
+
+      IF (novlp.EQ.3 .OR. novlp.EQ.1) tcc(i) = 1. - tcc(i)
+
+    ENDDO ! loop over i
+
+    ! ! Convective and Stratiform Cloud Droplet Effective Radius (REFFCLWC
+    ! REFFCLWS)
+    DO i = 1, klon
+      DO k = 1, klev
+        ! Weight to be used for outputs: eau_liquide*couverture nuageuse
+        lcc3dcon(i, k) = rnebcon(i, k)*phase3d(i, k)*ccwcon(i, k) ! eau liquide convective
+        lcc3dstra(i, k) = pclc(i, k)*radocond(i, k)*phase3d(i, k)
+        lcc3dstra(i, k) = lcc3dstra(i, k) - lcc3dcon(i, k) ! eau liquide stratiforme
+        lcc3dstra(i, k) = max(lcc3dstra(i,k), 0.0)
+        !FC pour la glace (CAUSES)
+        icc3dcon(i, k) = rnebcon(i, k)*(1-phase3d(i, k))*ccwcon(i, k) !  glace convective
+        icc3dstra(i, k)= pclc(i, k)*radocond(i, k)*(1-phase3d(i, k))
+        icc3dstra(i, k) = icc3dstra(i, k) - icc3dcon(i, k) ! glace stratiforme
+        icc3dstra(i, k) = max( icc3dstra(i, k), 0.0)
+        !FC (CAUSES)
+
+        ! Compute cloud droplet radius as above in meter
+        radius = 1.1*((radocond(i,k)*pplay(i,k)/(rd*temp(i,k)))/(4./3*rpi*1000.* &
+          cdnc(i,k)))**(1./3.)
+        radius = max(radius, 5.E-6)
+        ! Convective Cloud Droplet Effective Radius (REFFCLWC) : variable 3D
+        reffclwc(i, k) = radius
+        reffclwc(i, k) = reffclwc(i, k)*lcc3dcon(i, k)
+        ! Stratiform Cloud Droplet Effective Radius (REFFCLWS) : variable 3D
+        reffclws(i, k) = radius
+        reffclws(i, k) = reffclws(i, k)*lcc3dstra(i, k)
+      ENDDO !klev
+    ENDDO !klon
+
+    ! Column Integrated Cloud Droplet Number (CLDNVI) : variable 2D
+
+    DO i = 1, klon
+      cldnvi(i) = 0.
+      lcc_integrat(i) = 0.
+      height(i) = 0.
+      DO k = 1, klev
+        cldnvi(i) = cldnvi(i) + cdnc(i, k)*lcc3d(i, k)*dh(i, k)
+        lcc_integrat(i) = lcc_integrat(i) + lcc3d(i, k)*dh(i, k)
+        height(i) = height(i) + dh(i, k)
+      ENDDO ! klev
+      lcc_integrat(i) = lcc_integrat(i)/height(i)
+      IF (lcc_integrat(i)<=1.0E-03) THEN
+        cldnvi(i) = cldnvi(i)*lcc(i)/seuil_neb
+      ELSE
+        cldnvi(i) = cldnvi(i)*lcc(i)/lcc_integrat(i)
+      ENDIF
+    ENDDO ! klon
+
+    DO i = 1, klon
+      DO k = 1, klev
+        IF (scdnc(i,k)<=0.0) scdnc(i, k) = 0.0
+        IF (reffclws(i,k)<=0.0) reffclws(i, k) = 0.0
+        IF (reffclwc(i,k)<=0.0) reffclwc(i, k) = 0.0
+        IF (lcc3d(i,k)<=0.0) lcc3d(i, k) = 0.0
+        IF (lcc3dcon(i,k)<=0.0) lcc3dcon(i, k) = 0.0
+        IF (lcc3dstra(i,k)<=0.0) lcc3dstra(i, k) = 0.0
+!FC (CAUSES)
+        IF (icc3dcon(i,k)<=0.0) icc3dcon(i, k) = 0.0
+        IF (icc3dstra(i,k)<=0.0) icc3dstra(i, k) = 0.0
+!FC (CAUSES)
+      ENDDO
+      IF (reffclwtop(i)<=0.0) reffclwtop(i) = 0.0
+      IF (cldncl(i)<=0.0) cldncl(i) = 0.0
+      IF (cldnvi(i)<=0.0) cldnvi(i) = 0.0
+      IF (lcc(i)<=0.0) lcc(i) = 0.0
+    ENDDO
+
+  ENDIF !ok_cdnc
+
+  first=.false. !to be sure
+
+  RETURN
+
+END SUBROUTINE cloud_optics_prop
+
+END MODULE lmdz_cloud_optics_prop
Index: DZ6/trunk/libf/phylmd/lmdz_cloud_optics_prop_ini.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/lmdz_cloud_optics_prop_ini.F90	(revision 5267)
+++ 	(revision )
@@ -1,104 +1,0 @@
-MODULE lmdz_cloud_optics_prop_ini
-  IMPLICIT NONE
-
-  SAVE
-
-  INTEGER, PROTECTED :: prt_level, lunout
-  INTEGER, PROTECTED :: flag_aerosol
-  INTEGER, PROTECTED :: iflag_t_glace=0
-  INTEGER, PROTECTED :: iflag_rei
-  INTEGER, PROTECTED :: novlp, iflag_ice_thermo
-  LOGICAL, PROTECTED :: ok_cdnc
-  LOGICAL, PROTECTED :: ok_icefra_lscp, ok_new_lscp
-  REAL, PROTECTED :: bl95_b0, bl95_b1 ! Parameter in B&L 95-Formula
-  REAL, ALLOCATABLE :: latitude_deg(:)
-  !$OMP THREADPRIVATE(latitude_deg)
-  REAL, PROTECTED :: cdnc_max=-1.
-  REAL, PROTECTED :: cdnc_max_m3=-1.
-  REAL, PROTECTED :: cdnc_min=-1.
-  REAL, PROTECTED :: cdnc_min_m3=-1.
-  REAL, PROTECTED :: rpi, rg, rd
-  REAL, PROTECTED :: rad_chau1, rad_chau2, rad_froid
-  REAL, PROTECTED :: rei_max, rei_min
-  REAL, PROTECTED :: zepsec
-  REAL, PARAMETER :: thres_tau=0.3, thres_neb=0.001
-  REAL, PARAMETER :: prmhc=440.*100. ! Pressure between medium and high level cloud in Pa
-  REAL, PARAMETER :: prlmc=680.*100. ! Pressure between low and medium level cloud in Pa
-  REAL, PARAMETER :: coef_froi=0.09, coef_chau =0.13
-  REAL, PARAMETER :: seuil_neb=0.001
-! if iflag_t_glace=0, old values are used for liquid/ice partitionning:
-  REAL, PARAMETER :: t_glace_min_old = 258.
-  REAL, PARAMETER :: t_glace_max_old = 273.13
-  REAL, PARAMETER :: k_ice0=0.005 ! units=m2/g
-  REAL, PARAMETER :: df=1.66 ! diffusivity factor
-!$OMP THREADPRIVATE(prt_level, lunout, flag_aerosol, iflag_t_glace)
-!$OMP THREADPRIVATE(iflag_rei, novlp, iflag_ice_thermo)  
-!$OMP THREADPRIVATE(ok_cdnc, ok_icefra_lscp)
-!$OMP THREADPRIVATE(bl95_b0, bl95_b1, cdnc_max, cdnc_max_m3)
-!$OMP THREADPRIVATE(cdnc_min, cdnc_min_m3, rpi, rg, rd)
-!$OMP THREADPRIVATE(rad_chau1, rad_chau2, rad_froid, rei_max, rei_min)
-!$OMP THREADPRIVATE(zepsec) 
-
-  
-CONTAINS
-
-  SUBROUTINE cloud_optics_prop_ini(klon, prt_level_in, lunout_in, flag_aerosol_in, &
-       & ok_cdnc_in, bl95_b0_in, &
-       & bl95_b1_in, latitude_deg_in, rpi_in, rg_in, rd_in, zepsec_in, novlp_in, &
-       & iflag_ice_thermo_in, ok_new_lscp_in)
-
-    USE ioipsl_getin_p_mod, ONLY : getin_p
-
-    IMPLICIT NONE
-    INTEGER, INTENT(IN) :: klon
-    INTEGER, INTENT(IN) :: prt_level_in, lunout_in
-    INTEGER, INTENT(IN) :: flag_aerosol_in
-    INTEGER, INTENT(IN) :: novlp_in, iflag_ice_thermo_in
-    LOGICAL, INTENT(IN) :: ok_cdnc_in, ok_new_lscp_in
-    REAL, INTENT(IN) :: bl95_b0_in, bl95_b1_in
-    REAL, INTENT(IN) :: latitude_deg_in(klon)
-    REAL, INTENT(IN) :: rpi_in, rg_in, rd_in
-    REAL, INTENT(IN) :: zepsec_in
-
-    ALLOCATE(latitude_deg(klon))
-
-    prt_level = prt_level_in
-    lunout = lunout_in
-    flag_aerosol = flag_aerosol_in
-    ok_cdnc = ok_cdnc_in
-    bl95_b0 = bl95_b0_in
-    bl95_b1 = bl95_b1_in
-    latitude_deg(:) = latitude_deg_in(:)
-    rpi = rpi_in
-    rg = rg_in
-    rd = rd_in
-    zepsec = zepsec_in
-    novlp = novlp_in
-    iflag_ice_thermo = iflag_ice_thermo_in
-    ok_new_lscp = ok_new_lscp_in
-    
-    call getin_p('cdnc_min',cdnc_min)
-    cdnc_min_m3=cdnc_min*1.E6
-    IF (cdnc_min_m3<0.) cdnc_min_m3=20.E6 ! astuce pour retrocompatibilite
-    write(lunout,*)'cdnc_min=', cdnc_min_m3/1.E6
-    call getin_p('cdnc_max',cdnc_max)
-    cdnc_max_m3=cdnc_max*1.E6
-    IF (cdnc_max_m3<0.) cdnc_max_m3=1000.E6 ! astuce pour retrocompatibilite
-    write(lunout,*)'cdnc_max=', cdnc_max_m3/1.E6
-    CALL getin_p('iflag_t_glace',iflag_t_glace)      
-    write(lunout,*)'iflag_t_glace= ',iflag_t_glace
-    CALL getin_p('rad_chau1',rad_chau1)
-    CALL getin_p('rad_chau2',rad_chau2)
-    CALL getin_p('rad_froid ',rad_froid)
-    CALL getin_p('ok_icefra_lscp', ok_icefra_lscp)
-    iflag_rei = 0
-    CALL getin_p('iflag_rei',iflag_rei)
-    rei_min = 3.5
-    CALL getin_p('rei_min',rei_min)
-    rei_max = 61.29
-    CALL getin_p('rei_max',rei_max)
-
-   
-  END SUBROUTINE cloud_optics_prop_ini
-
-END MODULE lmdz_cloud_optics_prop_ini
Index: /LMDZ6/trunk/libf/phylmd/lmdz_cloud_optics_prop_ini.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/lmdz_cloud_optics_prop_ini.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/lmdz_cloud_optics_prop_ini.f90	(revision 5268)
@@ -0,0 +1,104 @@
+MODULE lmdz_cloud_optics_prop_ini
+  IMPLICIT NONE
+
+  SAVE
+
+  INTEGER, PROTECTED :: prt_level, lunout
+  INTEGER, PROTECTED :: flag_aerosol
+  INTEGER, PROTECTED :: iflag_t_glace=0
+  INTEGER, PROTECTED :: iflag_rei
+  INTEGER, PROTECTED :: novlp, iflag_ice_thermo
+  LOGICAL, PROTECTED :: ok_cdnc
+  LOGICAL, PROTECTED :: ok_icefra_lscp, ok_new_lscp
+  REAL, PROTECTED :: bl95_b0, bl95_b1 ! Parameter in B&L 95-Formula
+  REAL, ALLOCATABLE :: latitude_deg(:)
+  !$OMP THREADPRIVATE(latitude_deg)
+  REAL, PROTECTED :: cdnc_max=-1.
+  REAL, PROTECTED :: cdnc_max_m3=-1.
+  REAL, PROTECTED :: cdnc_min=-1.
+  REAL, PROTECTED :: cdnc_min_m3=-1.
+  REAL, PROTECTED :: rpi, rg, rd
+  REAL, PROTECTED :: rad_chau1, rad_chau2, rad_froid
+  REAL, PROTECTED :: rei_max, rei_min
+  REAL, PROTECTED :: zepsec
+  REAL, PARAMETER :: thres_tau=0.3, thres_neb=0.001
+  REAL, PARAMETER :: prmhc=440.*100. ! Pressure between medium and high level cloud in Pa
+  REAL, PARAMETER :: prlmc=680.*100. ! Pressure between low and medium level cloud in Pa
+  REAL, PARAMETER :: coef_froi=0.09, coef_chau =0.13
+  REAL, PARAMETER :: seuil_neb=0.001
+! if iflag_t_glace=0, old values are used for liquid/ice partitionning:
+  REAL, PARAMETER :: t_glace_min_old = 258.
+  REAL, PARAMETER :: t_glace_max_old = 273.13
+  REAL, PARAMETER :: k_ice0=0.005 ! units=m2/g
+  REAL, PARAMETER :: df=1.66 ! diffusivity factor
+!$OMP THREADPRIVATE(prt_level, lunout, flag_aerosol, iflag_t_glace)
+!$OMP THREADPRIVATE(iflag_rei, novlp, iflag_ice_thermo)  
+!$OMP THREADPRIVATE(ok_cdnc, ok_icefra_lscp)
+!$OMP THREADPRIVATE(bl95_b0, bl95_b1, cdnc_max, cdnc_max_m3)
+!$OMP THREADPRIVATE(cdnc_min, cdnc_min_m3, rpi, rg, rd)
+!$OMP THREADPRIVATE(rad_chau1, rad_chau2, rad_froid, rei_max, rei_min)
+!$OMP THREADPRIVATE(zepsec) 
+
+  
+CONTAINS
+
+  SUBROUTINE cloud_optics_prop_ini(klon, prt_level_in, lunout_in, flag_aerosol_in, &
+       & ok_cdnc_in, bl95_b0_in, &
+       & bl95_b1_in, latitude_deg_in, rpi_in, rg_in, rd_in, zepsec_in, novlp_in, &
+       & iflag_ice_thermo_in, ok_new_lscp_in)
+
+    USE ioipsl_getin_p_mod, ONLY : getin_p
+
+    IMPLICIT NONE
+    INTEGER, INTENT(IN) :: klon
+    INTEGER, INTENT(IN) :: prt_level_in, lunout_in
+    INTEGER, INTENT(IN) :: flag_aerosol_in
+    INTEGER, INTENT(IN) :: novlp_in, iflag_ice_thermo_in
+    LOGICAL, INTENT(IN) :: ok_cdnc_in, ok_new_lscp_in
+    REAL, INTENT(IN) :: bl95_b0_in, bl95_b1_in
+    REAL, INTENT(IN) :: latitude_deg_in(klon)
+    REAL, INTENT(IN) :: rpi_in, rg_in, rd_in
+    REAL, INTENT(IN) :: zepsec_in
+
+    ALLOCATE(latitude_deg(klon))
+
+    prt_level = prt_level_in
+    lunout = lunout_in
+    flag_aerosol = flag_aerosol_in
+    ok_cdnc = ok_cdnc_in
+    bl95_b0 = bl95_b0_in
+    bl95_b1 = bl95_b1_in
+    latitude_deg(:) = latitude_deg_in(:)
+    rpi = rpi_in
+    rg = rg_in
+    rd = rd_in
+    zepsec = zepsec_in
+    novlp = novlp_in
+    iflag_ice_thermo = iflag_ice_thermo_in
+    ok_new_lscp = ok_new_lscp_in
+    
+    call getin_p('cdnc_min',cdnc_min)
+    cdnc_min_m3=cdnc_min*1.E6
+    IF (cdnc_min_m3<0.) cdnc_min_m3=20.E6 ! astuce pour retrocompatibilite
+    write(lunout,*)'cdnc_min=', cdnc_min_m3/1.E6
+    call getin_p('cdnc_max',cdnc_max)
+    cdnc_max_m3=cdnc_max*1.E6
+    IF (cdnc_max_m3<0.) cdnc_max_m3=1000.E6 ! astuce pour retrocompatibilite
+    write(lunout,*)'cdnc_max=', cdnc_max_m3/1.E6
+    CALL getin_p('iflag_t_glace',iflag_t_glace)      
+    write(lunout,*)'iflag_t_glace= ',iflag_t_glace
+    CALL getin_p('rad_chau1',rad_chau1)
+    CALL getin_p('rad_chau2',rad_chau2)
+    CALL getin_p('rad_froid ',rad_froid)
+    CALL getin_p('ok_icefra_lscp', ok_icefra_lscp)
+    iflag_rei = 0
+    CALL getin_p('iflag_rei',iflag_rei)
+    rei_min = 3.5
+    CALL getin_p('rei_min',rei_min)
+    rei_max = 61.29
+    CALL getin_p('rei_max',rei_max)
+
+   
+  END SUBROUTINE cloud_optics_prop_ini
+
+END MODULE lmdz_cloud_optics_prop_ini
Index: DZ6/trunk/libf/phylmd/lmdz_cloudth.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/lmdz_cloudth.F90	(revision 5267)
+++ 	(revision )
@@ -1,2260 +1,0 @@
-MODULE lmdz_cloudth
-
-
-  IMPLICIT NONE
-
-CONTAINS
-
-       SUBROUTINE cloudth(ngrid,klev,ind2,  &
-     &           ztv,po,zqta,fraca, & 
-     &           qcloud,ctot,zpspsk,paprs,pplay,ztla,zthl, &
-     &           ratqs,zqs,t, &
-     &           cloudth_sth,cloudth_senv,cloudth_sigmath,cloudth_sigmaenv)
-
-
-      use lmdz_cloudth_ini, only: iflag_cloudth_vert,iflag_ratqs
-
-      IMPLICIT NONE
-
-
-!===========================================================================
-! Auteur : Arnaud Octavio Jam (LMD/CNRS)
-! Date : 25 Mai 2010
-! Objet : calcule les valeurs de qc et rneb dans les thermiques
-!===========================================================================
-
-
-      INCLUDE "YOMCST.h"
-      INCLUDE "YOETHF.h"
-      INCLUDE "FCTTRE.h"
-
-      INTEGER itap,ind1,ind2
-      INTEGER ngrid,klev,klon,l,ig 
-      real, dimension(ngrid,klev), intent(out) :: cloudth_sth,cloudth_senv,cloudth_sigmath,cloudth_sigmaenv
-      
-      REAL ztv(ngrid,klev)
-      REAL po(ngrid)
-      REAL zqenv(ngrid)   
-      REAL zqta(ngrid,klev)
-          
-      REAL fraca(ngrid,klev+1)
-      REAL zpspsk(ngrid,klev)
-      REAL paprs(ngrid,klev+1)
-      REAL pplay(ngrid,klev)
-      REAL ztla(ngrid,klev)
-      REAL zthl(ngrid,klev)
-
-      REAL zqsatth(ngrid,klev)
-      REAL zqsatenv(ngrid,klev)
-      
-      
-      REAL sigma1(ngrid,klev)
-      REAL sigma2(ngrid,klev)
-      REAL qlth(ngrid,klev)
-      REAL qlenv(ngrid,klev)
-      REAL qltot(ngrid,klev) 
-      REAL cth(ngrid,klev)  
-      REAL cenv(ngrid,klev)   
-      REAL ctot(ngrid,klev)
-      REAL rneb(ngrid,klev)
-      REAL t(ngrid,klev)
-      REAL qsatmmussig1,qsatmmussig2,sqrt2pi,pi
-      REAL rdd,cppd,Lv
-      REAL alth,alenv,ath,aenv
-      REAL sth,senv,sigma1s,sigma2s,xth,xenv
-      REAL Tbef,zdelta,qsatbef,zcor
-      REAL qlbef  
-      REAL ratqs(ngrid,klev) ! determine la largeur de distribution de vapeur
-      
-      REAL zpdf_sig(ngrid),zpdf_k(ngrid),zpdf_delta(ngrid)
-      REAL zpdf_a(ngrid),zpdf_b(ngrid),zpdf_e1(ngrid),zpdf_e2(ngrid) 
-      REAL zqs(ngrid), qcloud(ngrid)
-      REAL erf
-
-
-
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! Gestion de deux versions de cloudth
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-      IF (iflag_cloudth_vert.GE.1) THEN
-      CALL cloudth_vert(ngrid,klev,ind2,  &
-     &           ztv,po,zqta,fraca, & 
-     &           qcloud,ctot,zpspsk,paprs,pplay,ztla,zthl, &
-     &           ratqs,zqs,t)
-      RETURN
-      ENDIF
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-
-!-------------------------------------------------------------------------------
-! Initialisation des variables r?elles
-!-------------------------------------------------------------------------------
-      sigma1(:,:)=0.
-      sigma2(:,:)=0.
-      qlth(:,:)=0.
-      qlenv(:,:)=0.  
-      qltot(:,:)=0.
-      rneb(:,:)=0.
-      qcloud(:)=0.
-      cth(:,:)=0.
-      cenv(:,:)=0.
-      ctot(:,:)=0.
-      qsatmmussig1=0.
-      qsatmmussig2=0.
-      rdd=287.04
-      cppd=1005.7
-      pi=3.14159 
-      Lv=2.5e6
-      sqrt2pi=sqrt(2.*pi)
-
-
-
-!-------------------------------------------------------------------------------
-! Calcul de la fraction du thermique et des ?cart-types des distributions
-!-------------------------------------------------------------------------------                 
-      do ind1=1,ngrid
-
-      if ((ztv(ind1,1).gt.ztv(ind1,2)).and.(fraca(ind1,ind2).gt.1.e-10)) then 
-
-      zqenv(ind1)=(po(ind1)-fraca(ind1,ind2)*zqta(ind1,ind2))/(1.-fraca(ind1,ind2))
-
-
-!      zqenv(ind1)=po(ind1)
-      Tbef=zthl(ind1,ind2)*zpspsk(ind1,ind2)
-      zdelta=MAX(0.,SIGN(1.,RTT-Tbef))
-      qsatbef= R2ES * FOEEW(Tbef,zdelta)/paprs(ind1,ind2)
-      qsatbef=MIN(0.5,qsatbef)
-      zcor=1./(1.-retv*qsatbef)
-      qsatbef=qsatbef*zcor
-      zqsatenv(ind1,ind2)=qsatbef
-
-
-
-
-      alenv=(0.622*Lv*zqsatenv(ind1,ind2))/(rdd*zthl(ind1,ind2)**2)  
-      aenv=1./(1.+(alenv*Lv/cppd))
-      senv=aenv*(po(ind1)-zqsatenv(ind1,ind2)) 
-
-
-
-
-      Tbef=ztla(ind1,ind2)*zpspsk(ind1,ind2)
-      zdelta=MAX(0.,SIGN(1.,RTT-Tbef))
-      qsatbef= R2ES * FOEEW(Tbef,zdelta)/paprs(ind1,ind2)
-      qsatbef=MIN(0.5,qsatbef)
-      zcor=1./(1.-retv*qsatbef)
-      qsatbef=qsatbef*zcor
-      zqsatth(ind1,ind2)=qsatbef
-            
-      alth=(0.622*Lv*zqsatth(ind1,ind2))/(rdd*ztla(ind1,ind2)**2)   
-      ath=1./(1.+(alth*Lv/cppd))
-      sth=ath*(zqta(ind1,ind2)-zqsatth(ind1,ind2)) 
-      
-      
-
-!------------------------------------------------------------------------------
-! Calcul des ?cart-types pour s
-!------------------------------------------------------------------------------
-
-!      sigma1s=(1.1**0.5)*(fraca(ind1,ind2)**0.6)/(1-fraca(ind1,ind2))*((sth-senv)**2)**0.5+ratqs(ind1,ind2)*po(ind1)
-!      sigma2s=0.11*((sth-senv)**2)**0.5/(fraca(ind1,ind2)+0.02)**0.4+0.002*zqta(ind1,ind2) 
-!       if (paprs(ind1,ind2).gt.90000) then
-!       ratqs(ind1,ind2)=0.002
-!       else 
-!       ratqs(ind1,ind2)=0.002+0.0*(90000-paprs(ind1,ind2))/20000
-!       endif
-       sigma1s=(1.1**0.5)*(fraca(ind1,ind2)**0.6)/(1-fraca(ind1,ind2))*((sth-senv)**2)**0.5+0.002*po(ind1)
-       sigma2s=0.11*((sth-senv)**2)**0.5/(fraca(ind1,ind2)+0.01)**0.4+0.002*zqta(ind1,ind2) 
-!       sigma1s=ratqs(ind1,ind2)*po(ind1)
-!      sigma2s=0.11*((sth-senv)**2)**0.5/(fraca(ind1,ind2)+0.02)**0.4+0.00003  
- 
-!------------------------------------------------------------------------------
-! Calcul de l'eau condens?e et de la couverture nuageuse
-!------------------------------------------------------------------------------
-      sqrt2pi=sqrt(2.*pi)
-      xth=sth/(sqrt(2.)*sigma2s)
-      xenv=senv/(sqrt(2.)*sigma1s)
-      cth(ind1,ind2)=0.5*(1.+1.*erf(xth))
-      cenv(ind1,ind2)=0.5*(1.+1.*erf(xenv)) 
-      ctot(ind1,ind2)=fraca(ind1,ind2)*cth(ind1,ind2)+(1.-1.*fraca(ind1,ind2))*cenv(ind1,ind2)   
-
-      qlth(ind1,ind2)=sigma2s*((exp(-1.*xth**2)/sqrt2pi)+xth*sqrt(2.)*cth(ind1,ind2))
-      qlenv(ind1,ind2)=sigma1s*((exp(-1.*xenv**2)/sqrt2pi)+xenv*sqrt(2.)*cenv(ind1,ind2))   
-      qltot(ind1,ind2)=fraca(ind1,ind2)*qlth(ind1,ind2)+(1.-1.*fraca(ind1,ind2))*qlenv(ind1,ind2)
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-      if (ctot(ind1,ind2).lt.1.e-10) then
-      ctot(ind1,ind2)=0.
-      qcloud(ind1)=zqsatenv(ind1,ind2) 
-
-      else   
-                
-      ctot(ind1,ind2)=ctot(ind1,ind2) 
-      qcloud(ind1)=qltot(ind1,ind2)/ctot(ind1,ind2)+zqs(ind1)
-
-      endif                           
-      
-          
-!     print*,sth,sigma2s,qlth(ind1,ind2),ctot(ind1,ind2),qltot(ind1,ind2),'verif'
-
-
-      else  ! gaussienne environnement seule
-      
-      zqenv(ind1)=po(ind1)
-      Tbef=t(ind1,ind2)
-      zdelta=MAX(0.,SIGN(1.,RTT-Tbef))
-      qsatbef= R2ES * FOEEW(Tbef,zdelta)/paprs(ind1,ind2)
-      qsatbef=MIN(0.5,qsatbef)
-      zcor=1./(1.-retv*qsatbef)
-      qsatbef=qsatbef*zcor
-      zqsatenv(ind1,ind2)=qsatbef
-      
-
-!      qlbef=Max(po(ind1)-zqsatenv(ind1,ind2),0.)
-      zthl(ind1,ind2)=t(ind1,ind2)*(101325/paprs(ind1,ind2))**(rdd/cppd)
-      alenv=(0.622*Lv*zqsatenv(ind1,ind2))/(rdd*zthl(ind1,ind2)**2)  
-      aenv=1./(1.+(alenv*Lv/cppd))
-      senv=aenv*(po(ind1)-zqsatenv(ind1,ind2)) 
-      
-
-      sigma1s=ratqs(ind1,ind2)*zqenv(ind1)
-
-      sqrt2pi=sqrt(2.*pi)
-      xenv=senv/(sqrt(2.)*sigma1s)
-      ctot(ind1,ind2)=0.5*(1.+1.*erf(xenv))
-      qltot(ind1,ind2)=sigma1s*((exp(-1.*xenv**2)/sqrt2pi)+xenv*sqrt(2.)*cenv(ind1,ind2))
-      
-      if (ctot(ind1,ind2).lt.1.e-3) then
-      ctot(ind1,ind2)=0.
-      qcloud(ind1)=zqsatenv(ind1,ind2) 
-
-      else   
-                
-      ctot(ind1,ind2)=ctot(ind1,ind2) 
-      qcloud(ind1)=qltot(ind1,ind2)/ctot(ind1,ind2)+zqsatenv(ind1,ind2)
-
-      endif    
- 
- 
- 
- 
- 
- 
-      endif   
-      enddo
-     
-      return
-!     end
-END SUBROUTINE cloudth
-
-
-
-!===========================================================================
-     SUBROUTINE cloudth_vert(ngrid,klev,ind2,  &
-     &           ztv,po,zqta,fraca, & 
-     &           qcloud,ctot,zpspsk,paprs,pplay,ztla,zthl, &
-     &           ratqs,zqs,t)
-
-!===========================================================================
-! Auteur : Arnaud Octavio Jam (LMD/CNRS)
-! Date : 25 Mai 2010
-! Objet : calcule les valeurs de qc et rneb dans les thermiques
-!===========================================================================
-
-
-      use lmdz_cloudth_ini, only: iflag_cloudth_vert, vert_alpha
-
-      IMPLICIT NONE
-
-      INCLUDE "YOMCST.h"
-      INCLUDE "YOETHF.h"
-      INCLUDE "FCTTRE.h"
-      
-      INTEGER itap,ind1,ind2
-      INTEGER ngrid,klev,klon,l,ig 
-      
-      REAL ztv(ngrid,klev)
-      REAL po(ngrid)
-      REAL zqenv(ngrid)   
-      REAL zqta(ngrid,klev)
-          
-      REAL fraca(ngrid,klev+1)
-      REAL zpspsk(ngrid,klev)
-      REAL paprs(ngrid,klev+1)
-      REAL pplay(ngrid,klev)
-      REAL ztla(ngrid,klev)
-      REAL zthl(ngrid,klev)
-
-      REAL zqsatth(ngrid,klev)
-      REAL zqsatenv(ngrid,klev)
-      
-      
-      REAL sigma1(ngrid,klev)                                                         
-      REAL sigma2(ngrid,klev)
-      REAL qlth(ngrid,klev)
-      REAL qlenv(ngrid,klev)
-      REAL qltot(ngrid,klev) 
-      REAL cth(ngrid,klev)  
-      REAL cenv(ngrid,klev)   
-      REAL ctot(ngrid,klev)
-      REAL rneb(ngrid,klev)
-      REAL t(ngrid,klev)                                                                  
-      REAL qsatmmussig1,qsatmmussig2,sqrt2pi,pi
-      REAL rdd,cppd,Lv,sqrt2,sqrtpi
-      REAL alth,alenv,ath,aenv
-      REAL sth,senv,sigma1s,sigma2s,xth,xenv
-      REAL xth1,xth2,xenv1,xenv2,deltasth, deltasenv
-      REAL IntJ,IntI1,IntI2,IntI3,coeffqlenv,coeffqlth
-      REAL Tbef,zdelta,qsatbef,zcor
-      REAL qlbef  
-      REAL ratqs(ngrid,klev) ! determine la largeur de distribution de vapeur
-      ! Change the width of the PDF used for vertical subgrid scale heterogeneity
-      ! (J Jouhaud, JL Dufresne, JB Madeleine)
-      
-      REAL zpdf_sig(ngrid),zpdf_k(ngrid),zpdf_delta(ngrid)
-      REAL zpdf_a(ngrid),zpdf_b(ngrid),zpdf_e1(ngrid),zpdf_e2(ngrid) 
-      REAL zqs(ngrid), qcloud(ngrid)
-      REAL erf
-
-!------------------------------------------------------------------------------
-! Initialisation des variables r?elles
-!------------------------------------------------------------------------------
-      sigma1(:,:)=0.
-      sigma2(:,:)=0.
-      qlth(:,:)=0.
-      qlenv(:,:)=0.  
-      qltot(:,:)=0.
-      rneb(:,:)=0.
-      qcloud(:)=0.
-      cth(:,:)=0.
-      cenv(:,:)=0.
-      ctot(:,:)=0.
-      qsatmmussig1=0.
-      qsatmmussig2=0.
-      rdd=287.04
-      cppd=1005.7
-      pi=3.14159 
-      Lv=2.5e6
-      sqrt2pi=sqrt(2.*pi)
-      sqrt2=sqrt(2.)
-      sqrtpi=sqrt(pi)
-
-!-------------------------------------------------------------------------------
-! Calcul de la fraction du thermique et des ?cart-types des distributions
-!-------------------------------------------------------------------------------                 
-      do ind1=1,ngrid
-
-      if ((ztv(ind1,1).gt.ztv(ind1,2)).and.(fraca(ind1,ind2).gt.1.e-10)) then 
-
-      zqenv(ind1)=(po(ind1)-fraca(ind1,ind2)*zqta(ind1,ind2))/(1.-fraca(ind1,ind2))
-
-
-!      zqenv(ind1)=po(ind1)
-      Tbef=zthl(ind1,ind2)*zpspsk(ind1,ind2)
-      zdelta=MAX(0.,SIGN(1.,RTT-Tbef))
-      qsatbef= R2ES * FOEEW(Tbef,zdelta)/paprs(ind1,ind2)
-      qsatbef=MIN(0.5,qsatbef)
-      zcor=1./(1.-retv*qsatbef)
-      qsatbef=qsatbef*zcor
-      zqsatenv(ind1,ind2)=qsatbef
-
-
-
-
-      alenv=(0.622*Lv*zqsatenv(ind1,ind2))/(rdd*zthl(ind1,ind2)**2)  
-      aenv=1./(1.+(alenv*Lv/cppd))
-      senv=aenv*(po(ind1)-zqsatenv(ind1,ind2)) 
-
-
-
-
-      Tbef=ztla(ind1,ind2)*zpspsk(ind1,ind2)
-      zdelta=MAX(0.,SIGN(1.,RTT-Tbef))
-      qsatbef= R2ES * FOEEW(Tbef,zdelta)/paprs(ind1,ind2)
-      qsatbef=MIN(0.5,qsatbef)
-      zcor=1./(1.-retv*qsatbef)
-      qsatbef=qsatbef*zcor
-      zqsatth(ind1,ind2)=qsatbef
-            
-      alth=(0.622*Lv*zqsatth(ind1,ind2))/(rdd*ztla(ind1,ind2)**2)   
-      ath=1./(1.+(alth*Lv/cppd))
-      sth=ath*(zqta(ind1,ind2)-zqsatth(ind1,ind2)) 
-      
-      
-
-!------------------------------------------------------------------------------
-! Calcul des ?cart-types pour s
-!------------------------------------------------------------------------------
-
-      sigma1s=(0.92**0.5)*(fraca(ind1,ind2)**0.5)/(1-fraca(ind1,ind2))*((sth-senv)**2)**0.5+ratqs(ind1,ind2)*po(ind1)
-      sigma2s=0.09*((sth-senv)**2)**0.5/(fraca(ind1,ind2)+0.02)**0.5+0.002*zqta(ind1,ind2) 
-!       if (paprs(ind1,ind2).gt.90000) then
-!       ratqs(ind1,ind2)=0.002
-!       else 
-!       ratqs(ind1,ind2)=0.002+0.0*(90000-paprs(ind1,ind2))/20000
-!       endif
-!       sigma1s=(1.1**0.5)*(fraca(ind1,ind2)**0.6)/(1-fraca(ind1,ind2))*((sth-senv)**2)**0.5+0.002*po(ind1)
-!       sigma2s=0.11*((sth-senv)**2)**0.5/(fraca(ind1,ind2)+0.01)**0.4+0.002*zqta(ind1,ind2) 
-!       sigma1s=ratqs(ind1,ind2)*po(ind1)
-!      sigma2s=0.11*((sth-senv)**2)**0.5/(fraca(ind1,ind2)+0.02)**0.4+0.00003  
- 
-!------------------------------------------------------------------------------
-! Calcul de l'eau condens?e et de la couverture nuageuse
-!------------------------------------------------------------------------------
-      sqrt2pi=sqrt(2.*pi)
-      xth=sth/(sqrt(2.)*sigma2s)
-      xenv=senv/(sqrt(2.)*sigma1s)
-      cth(ind1,ind2)=0.5*(1.+1.*erf(xth))
-      cenv(ind1,ind2)=0.5*(1.+1.*erf(xenv)) 
-      ctot(ind1,ind2)=fraca(ind1,ind2)*cth(ind1,ind2)+(1.-1.*fraca(ind1,ind2))*cenv(ind1,ind2)   
-
-      qlth(ind1,ind2)=sigma2s*((exp(-1.*xth**2)/sqrt2pi)+xth*sqrt(2.)*cth(ind1,ind2))
-      qlenv(ind1,ind2)=sigma1s*((exp(-1.*xenv**2)/sqrt2pi)+xenv*sqrt(2.)*cenv(ind1,ind2))   
-      qltot(ind1,ind2)=fraca(ind1,ind2)*qlth(ind1,ind2)+(1.-1.*fraca(ind1,ind2))*qlenv(ind1,ind2)
-     
-       IF (iflag_cloudth_vert == 1) THEN
-!-------------------------------------------------------------------------------
-!  Version 2: Modification selon J.-Louis. On condense ?? partir de qsat-ratqs
-!-------------------------------------------------------------------------------
-!      deltasenv=aenv*ratqs(ind1,ind2)*po(ind1)
-!      deltasth=ath*ratqs(ind1,ind2)*zqta(ind1,ind2)
-      deltasenv=aenv*ratqs(ind1,ind2)*zqsatenv(ind1,ind2)
-      deltasth=ath*ratqs(ind1,ind2)*zqsatth(ind1,ind2)
-!      deltasenv=aenv*0.01*po(ind1)
-!     deltasth=ath*0.01*zqta(ind1,ind2)    
-      xenv1=(senv-deltasenv)/(sqrt(2.)*sigma1s)
-      xenv2=(senv+deltasenv)/(sqrt(2.)*sigma1s)
-      xth1=(sth-deltasth)/(sqrt(2.)*sigma2s)
-      xth2=(sth+deltasth)/(sqrt(2.)*sigma2s)
-      coeffqlenv=(sigma1s)**2/(2*sqrtpi*deltasenv)
-      coeffqlth=(sigma2s)**2/(2*sqrtpi*deltasth)
-      
-      cth(ind1,ind2)=0.5*(1.+1.*erf(xth2))
-      cenv(ind1,ind2)=0.5*(1.+1.*erf(xenv2)) 
-      ctot(ind1,ind2)=fraca(ind1,ind2)*cth(ind1,ind2)+(1.-1.*fraca(ind1,ind2))*cenv(ind1,ind2)   
-
-      IntJ=sigma1s*(exp(-1.*xenv1**2)/sqrt2pi)+0.5*senv*(1+erf(xenv1))
-      IntI1=coeffqlenv*0.5*(0.5*sqrtpi*(erf(xenv2)-erf(xenv1))+xenv1*exp(-1.*xenv1**2)-xenv2*exp(-1.*xenv2**2))
-      IntI2=coeffqlenv*xenv2*(exp(-1.*xenv2**2)-exp(-1.*xenv1**2))
-      IntI3=coeffqlenv*0.5*sqrtpi*xenv2**2*(erf(xenv2)-erf(xenv1))
-
-      qlenv(ind1,ind2)=IntJ+IntI1+IntI2+IntI3
-!      qlenv(ind1,ind2)=IntJ 
-!      print*, qlenv(ind1,ind2),'VERIF EAU'
-
-
-      IntJ=sigma2s*(exp(-1.*xth1**2)/sqrt2pi)+0.5*sth*(1+erf(xth1))
-!      IntI1=coeffqlth*((0.5*xth1-xth2)*exp(-1.*xth1**2)+0.5*xth2*exp(-1.*xth2**2))
-!      IntI2=coeffqlth*0.5*sqrtpi*(0.5+xth2**2)*(erf(xth2)-erf(xth1))
-      IntI1=coeffqlth*0.5*(0.5*sqrtpi*(erf(xth2)-erf(xth1))+xth1*exp(-1.*xth1**2)-xth2*exp(-1.*xth2**2))
-      IntI2=coeffqlth*xth2*(exp(-1.*xth2**2)-exp(-1.*xth1**2))
-      IntI3=coeffqlth*0.5*sqrtpi*xth2**2*(erf(xth2)-erf(xth1))
-      qlth(ind1,ind2)=IntJ+IntI1+IntI2+IntI3
-!      qlth(ind1,ind2)=IntJ
-!      print*, IntJ,IntI1,IntI2,IntI3,qlth(ind1,ind2),'VERIF EAU2'
-      qltot(ind1,ind2)=fraca(ind1,ind2)*qlth(ind1,ind2)+(1.-1.*fraca(ind1,ind2))*qlenv(ind1,ind2)
-
-      ELSE IF (iflag_cloudth_vert == 2) THEN
-
-!-------------------------------------------------------------------------------
-!  Version 3: Modification Jean Jouhaud. On condense a partir de -delta s
-!-------------------------------------------------------------------------------
-!      deltasenv=aenv*ratqs(ind1,ind2)*po(ind1)
-!      deltasth=ath*ratqs(ind1,ind2)*zqta(ind1,ind2)
-!      deltasenv=aenv*ratqs(ind1,ind2)*zqsatenv(ind1,ind2)
-!      deltasth=ath*ratqs(ind1,ind2)*zqsatth(ind1,ind2)
-      deltasenv=aenv*vert_alpha*sigma1s
-      deltasth=ath*vert_alpha*sigma2s
-      
-      xenv1=-(senv+deltasenv)/(sqrt(2.)*sigma1s)
-      xenv2=-(senv-deltasenv)/(sqrt(2.)*sigma1s)
-      xth1=-(sth+deltasth)/(sqrt(2.)*sigma2s)
-      xth2=-(sth-deltasth)/(sqrt(2.)*sigma2s)
-!     coeffqlenv=(sigma1s)**2/(2*sqrtpi*deltasenv)
-!     coeffqlth=(sigma2s)**2/(2*sqrtpi*deltasth)
-      
-      cth(ind1,ind2)=0.5*(1.-1.*erf(xth1))
-      cenv(ind1,ind2)=0.5*(1.-1.*erf(xenv1))
-      ctot(ind1,ind2)=fraca(ind1,ind2)*cth(ind1,ind2)+(1.-1.*fraca(ind1,ind2))*cenv(ind1,ind2)
-
-      IntJ=0.5*senv*(1-erf(xenv2))+(sigma1s/sqrt2pi)*exp(-1.*xenv2**2)
-      IntI1=(((senv+deltasenv)**2+(sigma1s)**2)/(8*deltasenv))*(erf(xenv2)-erf(xenv1))
-      IntI2=(sigma1s**2/(4*deltasenv*sqrtpi))*(xenv1*exp(-1.*xenv1**2)-xenv2*exp(-1.*xenv2**2))
-      IntI3=((sqrt2*sigma1s*(senv+deltasenv))/(4*sqrtpi*deltasenv))*(exp(-1.*xenv1**2)-exp(-1.*xenv2**2))
-
-!      IntI1=0.5*(0.5*sqrtpi*(erf(xenv2)-erf(xenv1))+xenv1*exp(-1.*xenv1**2)-xenv2*exp(-1.*xenv2**2))
-!      IntI2=xenv2*(exp(-1.*xenv2**2)-exp(-1.*xenv1**2))
-!      IntI3=0.5*sqrtpi*xenv2**2*(erf(xenv2)-erf(xenv1))
-
-      qlenv(ind1,ind2)=IntJ+IntI1+IntI2+IntI3
-!      qlenv(ind1,ind2)=IntJ 
-!      print*, qlenv(ind1,ind2),'VERIF EAU'
-
-      IntJ=0.5*sth*(1-erf(xth2))+(sigma2s/sqrt2pi)*exp(-1.*xth2**2)
-      IntI1=(((sth+deltasth)**2+(sigma2s)**2)/(8*deltasth))*(erf(xth2)-erf(xth1))
-      IntI2=(sigma2s**2/(4*deltasth*sqrtpi))*(xth1*exp(-1.*xth1**2)-xth2*exp(-1.*xth2**2))
-      IntI3=((sqrt2*sigma2s*(sth+deltasth))/(4*sqrtpi*deltasth))*(exp(-1.*xth1**2)-exp(-1.*xth2**2))
-      
-      qlth(ind1,ind2)=IntJ+IntI1+IntI2+IntI3
-!      qlth(ind1,ind2)=IntJ
-!      print*, IntJ,IntI1,IntI2,IntI3,qlth(ind1,ind2),'VERIF EAU2'
-      qltot(ind1,ind2)=fraca(ind1,ind2)*qlth(ind1,ind2)+(1.-1.*fraca(ind1,ind2))*qlenv(ind1,ind2)
-      
-
-
-
-      ENDIF ! of if (iflag_cloudth_vert==1 or 2)
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-      if (cenv(ind1,ind2).lt.1.e-10.or.cth(ind1,ind2).lt.1.e-10) then
-      ctot(ind1,ind2)=0.
-      qcloud(ind1)=zqsatenv(ind1,ind2) 
-
-      else 
-                
-      ctot(ind1,ind2)=ctot(ind1,ind2) 
-      qcloud(ind1)=qltot(ind1,ind2)/ctot(ind1,ind2)+zqs(ind1)
-!      qcloud(ind1)=fraca(ind1,ind2)*qlth(ind1,ind2)/cth(ind1,ind2) &
-!    &             +(1.-1.*fraca(ind1,ind2))*qlenv(ind1,ind2)/cenv(ind1,ind2)+zqs(ind1) 
-
-      endif  
-                       
-      
-          
-!     print*,sth,sigma2s,qlth(ind1,ind2),ctot(ind1,ind2),qltot(ind1,ind2),'verif'
-
-
-      else  ! gaussienne environnement seule
-      
-      zqenv(ind1)=po(ind1)
-      Tbef=t(ind1,ind2)
-      zdelta=MAX(0.,SIGN(1.,RTT-Tbef))
-      qsatbef= R2ES * FOEEW(Tbef,zdelta)/paprs(ind1,ind2)
-      qsatbef=MIN(0.5,qsatbef)
-      zcor=1./(1.-retv*qsatbef)
-      qsatbef=qsatbef*zcor
-      zqsatenv(ind1,ind2)=qsatbef
-      
-
-!      qlbef=Max(po(ind1)-zqsatenv(ind1,ind2),0.)
-      zthl(ind1,ind2)=t(ind1,ind2)*(101325/paprs(ind1,ind2))**(rdd/cppd)
-      alenv=(0.622*Lv*zqsatenv(ind1,ind2))/(rdd*zthl(ind1,ind2)**2)  
-      aenv=1./(1.+(alenv*Lv/cppd))
-      senv=aenv*(po(ind1)-zqsatenv(ind1,ind2)) 
-      
-
-      sigma1s=ratqs(ind1,ind2)*zqenv(ind1)
-
-      sqrt2pi=sqrt(2.*pi)
-      xenv=senv/(sqrt(2.)*sigma1s)
-      ctot(ind1,ind2)=0.5*(1.+1.*erf(xenv))
-      qltot(ind1,ind2)=sigma1s*((exp(-1.*xenv**2)/sqrt2pi)+xenv*sqrt(2.)*cenv(ind1,ind2))
-      
-      if (ctot(ind1,ind2).lt.1.e-3) then
-      ctot(ind1,ind2)=0.
-      qcloud(ind1)=zqsatenv(ind1,ind2) 
-
-      else   
-                
-      ctot(ind1,ind2)=ctot(ind1,ind2) 
-      qcloud(ind1)=qltot(ind1,ind2)/ctot(ind1,ind2)+zqsatenv(ind1,ind2)
-
-      endif    
- 
- 
- 
- 
- 
- 
-      endif   
-      enddo
-     
-      return
-!     end
-END SUBROUTINE cloudth_vert
-
-
-
-
-       SUBROUTINE cloudth_v3(ngrid,klev,ind2,  &
-     &           ztv,po,zqta,fraca, & 
-     &           qcloud,ctot,ctot_vol,zpspsk,paprs,pplay,ztla,zthl, &
-     &           ratqs,sigma_qtherm,zqs,t, &
-     &           cloudth_sth,cloudth_senv,cloudth_sigmath,cloudth_sigmaenv)
-
-      use lmdz_cloudth_ini, only: iflag_cloudth_vert
-
-      IMPLICIT NONE
-
-
-!===========================================================================
-! Author : Arnaud Octavio Jam (LMD/CNRS)
-! Date : 25 Mai 2010
-! Objet : calcule les valeurs de qc et rneb dans les thermiques
-!===========================================================================
-
-
-      INCLUDE "YOMCST.h"
-      INCLUDE "YOETHF.h"
-      INCLUDE "FCTTRE.h"
-
-      integer, intent(in) :: ind2
-      integer, intent(in) :: ngrid,klev
-      
-      real, dimension(ngrid,klev), intent(in) :: ztv
-      real, dimension(ngrid), intent(in) :: po
-      real, dimension(ngrid,klev), intent(in) :: zqta
-      real, dimension(ngrid,klev+1), intent(in) :: fraca
-      real, dimension(ngrid), intent(out) :: qcloud
-      real, dimension(ngrid,klev), intent(out) :: ctot
-      real, dimension(ngrid,klev), intent(out) :: ctot_vol
-      real, dimension(ngrid,klev), intent(in) :: zpspsk
-      real, dimension(ngrid,klev+1), intent(in) :: paprs
-      real, dimension(ngrid,klev), intent(in) :: pplay
-      real, dimension(ngrid,klev), intent(in) :: ztla
-      real, dimension(ngrid,klev), intent(inout) :: zthl
-      real, dimension(ngrid,klev), intent(in) :: ratqs,sigma_qtherm
-      real, dimension(ngrid), intent(in) :: zqs
-      real, dimension(ngrid,klev), intent(in) :: t
-      real, dimension(ngrid,klev), intent(out) :: cloudth_sth,cloudth_senv,cloudth_sigmath,cloudth_sigmaenv
-
-
-      REAL zqenv(ngrid)   
-      REAL zqsatth(ngrid,klev)
-      REAL zqsatenv(ngrid,klev)
-      
-      REAL sigma1(ngrid,klev)                                                         
-      REAL sigma2(ngrid,klev)
-      REAL qlth(ngrid,klev)
-      REAL qlenv(ngrid,klev)
-      REAL qltot(ngrid,klev) 
-      REAL cth(ngrid,klev)
-      REAL cenv(ngrid,klev)   
-      REAL cth_vol(ngrid,klev)
-      REAL cenv_vol(ngrid,klev)
-      REAL rneb(ngrid,klev)      
-      REAL qsatmmussig1,qsatmmussig2,sqrt2pi,sqrt2,sqrtpi,pi
-      REAL rdd,cppd,Lv
-      REAL alth,alenv,ath,aenv
-      REAL sth,senv,sigma1s,sigma2s,xth,xenv, exp_xenv1, exp_xenv2,exp_xth1,exp_xth2
-      REAL inverse_rho,beta,a_Brooks,b_Brooks,A_Maj_Brooks,Dx_Brooks,f_Brooks
-      REAL Tbef,zdelta,qsatbef,zcor
-      REAL qlbef  
-      REAL zpdf_sig(ngrid),zpdf_k(ngrid),zpdf_delta(ngrid)
-      REAL zpdf_a(ngrid),zpdf_b(ngrid),zpdf_e1(ngrid),zpdf_e2(ngrid) 
-      REAL erf
-
-
-      INTEGER :: ind1,l, ig
-
-      IF (iflag_cloudth_vert.GE.1) THEN
-      CALL cloudth_vert_v3(ngrid,klev,ind2,  &
-     &           ztv,po,zqta,fraca, & 
-     &           qcloud,ctot,ctot_vol,zpspsk,paprs,pplay,ztla,zthl, &
-     &           ratqs,sigma_qtherm,zqs,t, &
-     &           cloudth_sth,cloudth_senv,cloudth_sigmath,cloudth_sigmaenv)
-      RETURN
-      ENDIF
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-
-!-------------------------------------------------------------------------------
-! Initialisation des variables r?elles
-!-------------------------------------------------------------------------------
-      sigma1(:,:)=0.
-      sigma2(:,:)=0.
-      qlth(:,:)=0.
-      qlenv(:,:)=0.  
-      qltot(:,:)=0.
-      rneb(:,:)=0.
-      qcloud(:)=0.
-      cth(:,:)=0.
-      cenv(:,:)=0.
-      ctot(:,:)=0.
-      cth_vol(:,:)=0.
-      cenv_vol(:,:)=0.
-      ctot_vol(:,:)=0.
-      qsatmmussig1=0.
-      qsatmmussig2=0.
-      rdd=287.04
-      cppd=1005.7
-      pi=3.14159 
-      Lv=2.5e6
-      sqrt2pi=sqrt(2.*pi)
-      sqrt2=sqrt(2.)
-      sqrtpi=sqrt(pi)
-
-
-!-------------------------------------------------------------------------------
-! Cloud fraction in the thermals and standard deviation of the PDFs
-!-------------------------------------------------------------------------------                 
-      do ind1=1,ngrid
-
-      if ((ztv(ind1,1).gt.ztv(ind1,2)).and.(fraca(ind1,ind2).gt.1.e-10)) then 
-
-      zqenv(ind1)=(po(ind1)-fraca(ind1,ind2)*zqta(ind1,ind2))/(1.-fraca(ind1,ind2))
-
-      Tbef=zthl(ind1,ind2)*zpspsk(ind1,ind2)
-      zdelta=MAX(0.,SIGN(1.,RTT-Tbef))
-      qsatbef= R2ES*FOEEW(Tbef,zdelta)/paprs(ind1,ind2)
-      qsatbef=MIN(0.5,qsatbef)
-      zcor=1./(1.-retv*qsatbef)
-      qsatbef=qsatbef*zcor
-      zqsatenv(ind1,ind2)=qsatbef
-
-
-      alenv=(0.622*Lv*zqsatenv(ind1,ind2))/(rdd*zthl(ind1,ind2)**2)     !qsl, p84
-      aenv=1./(1.+(alenv*Lv/cppd))                                      !al, p84
-      senv=aenv*(po(ind1)-zqsatenv(ind1,ind2))                          !s, p84
-
-!po = qt de l'environnement ET des thermique
-!zqenv = qt environnement
-!zqsatenv = qsat environnement
-!zthl = Tl environnement
-
-
-      Tbef=ztla(ind1,ind2)*zpspsk(ind1,ind2)
-      zdelta=MAX(0.,SIGN(1.,RTT-Tbef))
-      qsatbef= R2ES * FOEEW(Tbef,zdelta)/paprs(ind1,ind2)
-      qsatbef=MIN(0.5,qsatbef)
-      zcor=1./(1.-retv*qsatbef)
-      qsatbef=qsatbef*zcor
-      zqsatth(ind1,ind2)=qsatbef
-            
-      alth=(0.622*Lv*zqsatth(ind1,ind2))/(rdd*ztla(ind1,ind2)**2)       !qsl, p84
-      ath=1./(1.+(alth*Lv/cppd))                                        !al, p84
-      sth=ath*(zqta(ind1,ind2)-zqsatth(ind1,ind2))                      !s, p84
-      
-!zqta = qt thermals
-!zqsatth = qsat thermals
-!ztla = Tl thermals
-
-!------------------------------------------------------------------------------
-! s standard deviations
-!------------------------------------------------------------------------------
-
-!     tests
-!     sigma1s=(1.1**0.5)*(fraca(ind1,ind2)**0.6)/(1-fraca(ind1,ind2))*((sth-senv)**2)**0.5+0.002*po(ind1)
-!     sigma1s=(0.92*(fraca(ind1,ind2)**0.5)/(1-fraca(ind1,ind2))*(((sth-senv)**2)**0.5))+ratqs(ind1,ind2)*po(ind1)
-!     sigma2s=(0.09*(((sth-senv)**2)**0.5)/((fraca(ind1,ind2)+0.02)**0.5))+0.002*zqta(ind1,ind2)
-!     final option
-      sigma1s=(1.1**0.5)*(fraca(ind1,ind2)**0.6)/(1-fraca(ind1,ind2))*((sth-senv)**2)**0.5+ratqs(ind1,ind2)*po(ind1)
-      sigma2s=0.11*((sth-senv)**2)**0.5/(fraca(ind1,ind2)+0.01)**0.4+0.002*zqta(ind1,ind2)
- 
-!------------------------------------------------------------------------------
-! Condensed water and cloud cover
-!------------------------------------------------------------------------------
-      xth=sth/(sqrt2*sigma2s)
-      xenv=senv/(sqrt2*sigma1s)
-      cth(ind1,ind2)=0.5*(1.+1.*erf(xth))       !4.18 p 111, l.7 p115 & 4.20 p 119 thesis Arnaud Jam
-      cenv(ind1,ind2)=0.5*(1.+1.*erf(xenv))     !4.18 p 111, l.7 p115 & 4.20 p 119 thesis Arnaud Jam
-      ctot(ind1,ind2)=fraca(ind1,ind2)*cth(ind1,ind2)+(1.-1.*fraca(ind1,ind2))*cenv(ind1,ind2)
-      ctot_vol(ind1,ind2)=ctot(ind1,ind2)
-
-      qlth(ind1,ind2)=sigma2s*((exp(-1.*xth**2)/sqrt2pi)+xth*sqrt2*cth(ind1,ind2))
-      qlenv(ind1,ind2)=sigma1s*((exp(-1.*xenv**2)/sqrt2pi)+xenv*sqrt2*cenv(ind1,ind2))
-      qltot(ind1,ind2)=fraca(ind1,ind2)*qlth(ind1,ind2)+(1.-1.*fraca(ind1,ind2))*qlenv(ind1,ind2)
-
-      if (ctot(ind1,ind2).lt.1.e-10) then
-      ctot(ind1,ind2)=0.
-      qcloud(ind1)=zqsatenv(ind1,ind2) 
-      else
-      qcloud(ind1)=qltot(ind1,ind2)/ctot(ind1,ind2)+zqs(ind1)
-      endif
-
-      else  ! Environnement only, follow the if l.110
-      
-      zqenv(ind1)=po(ind1)
-      Tbef=t(ind1,ind2)
-      zdelta=MAX(0.,SIGN(1.,RTT-Tbef))
-      qsatbef= R2ES * FOEEW(Tbef,zdelta)/paprs(ind1,ind2)
-      qsatbef=MIN(0.5,qsatbef)
-      zcor=1./(1.-retv*qsatbef)
-      qsatbef=qsatbef*zcor
-      zqsatenv(ind1,ind2)=qsatbef
-
-!     qlbef=Max(po(ind1)-zqsatenv(ind1,ind2),0.)
-      zthl(ind1,ind2)=t(ind1,ind2)*(101325/paprs(ind1,ind2))**(rdd/cppd)
-      alenv=(0.622*Lv*zqsatenv(ind1,ind2))/(rdd*zthl(ind1,ind2)**2)  
-      aenv=1./(1.+(alenv*Lv/cppd))
-      senv=aenv*(po(ind1)-zqsatenv(ind1,ind2))
-      
-      sigma1s=ratqs(ind1,ind2)*zqenv(ind1)
-
-      xenv=senv/(sqrt2*sigma1s)
-      ctot(ind1,ind2)=0.5*(1.+1.*erf(xenv))
-      ctot_vol(ind1,ind2)=ctot(ind1,ind2)
-      qltot(ind1,ind2)=sigma1s*((exp(-1.*xenv**2)/sqrt2pi)+xenv*sqrt2*cenv(ind1,ind2))
-
-      if (ctot(ind1,ind2).lt.1.e-3) then
-      ctot(ind1,ind2)=0.
-      qcloud(ind1)=zqsatenv(ind1,ind2)
-      else   
-      qcloud(ind1)=qltot(ind1,ind2)/ctot(ind1,ind2)+zqsatenv(ind1,ind2)
-      endif
-
-
-      endif       ! From the separation (thermal/envrionnement) et (environnement) only, l.110 et l.183
-      enddo       ! from the loop on ngrid l.108
-      return
-!     end
-END SUBROUTINE cloudth_v3
-
-
-
-!===========================================================================
-     SUBROUTINE cloudth_vert_v3(ngrid,klev,ind2,  &
-     &           ztv,po,zqta,fraca, & 
-     &           qcloud,ctot,ctot_vol,zpspsk,paprs,pplay,ztla,zthl, &
-     &           ratqs,sigma_qtherm,zqs,t, &
-     &           cloudth_sth,cloudth_senv,cloudth_sigmath,cloudth_sigmaenv)
-
-!===========================================================================
-! Auteur : Arnaud Octavio Jam (LMD/CNRS)
-! Date : 25 Mai 2010
-! Objet : calcule les valeurs de qc et rneb dans les thermiques
-!===========================================================================
-
-      use lmdz_cloudth_ini, only : iflag_cloudth_vert,iflag_ratqs
-      use lmdz_cloudth_ini, only : vert_alpha,vert_alpha_th, sigma1s_factor, sigma1s_power , sigma2s_factor , sigma2s_power , cloudth_ratqsmin , iflag_cloudth_vert_noratqs
-
-      IMPLICIT NONE
-
-
-
-      INCLUDE "YOMCST.h"
-      INCLUDE "YOETHF.h"
-      INCLUDE "FCTTRE.h"
-      
-      INTEGER itap,ind1,ind2
-      INTEGER ngrid,klev,klon,l,ig 
-      real, dimension(ngrid,klev), intent(out) :: cloudth_sth,cloudth_senv,cloudth_sigmath,cloudth_sigmaenv
-      
-      REAL ztv(ngrid,klev)
-      REAL po(ngrid)
-      REAL zqenv(ngrid)   
-      REAL zqta(ngrid,klev)
-          
-      REAL fraca(ngrid,klev+1)
-      REAL zpspsk(ngrid,klev)
-      REAL paprs(ngrid,klev+1)
-      REAL pplay(ngrid,klev)
-      REAL ztla(ngrid,klev)
-      REAL zthl(ngrid,klev)
-
-      REAL zqsatth(ngrid,klev)
-      REAL zqsatenv(ngrid,klev)
-      
-      REAL sigma1(ngrid,klev)                                                         
-      REAL sigma2(ngrid,klev)
-      REAL qlth(ngrid,klev)
-      REAL qlenv(ngrid,klev)
-      REAL qltot(ngrid,klev) 
-      REAL cth(ngrid,klev)
-      REAL cenv(ngrid,klev)   
-      REAL ctot(ngrid,klev)
-      REAL cth_vol(ngrid,klev)
-      REAL cenv_vol(ngrid,klev)
-      REAL ctot_vol(ngrid,klev)
-      REAL rneb(ngrid,klev)
-      REAL t(ngrid,klev)                                                                  
-      REAL qsatmmussig1,qsatmmussig2,sqrtpi,sqrt2,sqrt2pi,pi
-      REAL rdd,cppd,Lv
-      REAL alth,alenv,ath,aenv
-      REAL sth,senv,sigma1s,sigma2s,sigma1s_fraca,sigma1s_ratqs
-      REAL inverse_rho,beta,a_Brooks,b_Brooks,A_Maj_Brooks,Dx_Brooks,f_Brooks
-      REAL xth,xenv,exp_xenv1,exp_xenv2,exp_xth1,exp_xth2
-      REAL xth1,xth2,xenv1,xenv2,deltasth, deltasenv
-      REAL IntJ,IntI1,IntI2,IntI3,IntJ_CF,IntI1_CF,IntI3_CF,coeffqlenv,coeffqlth
-      REAL Tbef,zdelta,qsatbef,zcor
-      REAL qlbef  
-      REAL ratqs(ngrid,klev),sigma_qtherm(ngrid,klev) ! determine la largeur de distribution de vapeur
-      ! Change the width of the PDF used for vertical subgrid scale heterogeneity
-      ! (J Jouhaud, JL Dufresne, JB Madeleine)
-
-      REAL zpdf_sig(ngrid),zpdf_k(ngrid),zpdf_delta(ngrid)
-      REAL zpdf_a(ngrid),zpdf_b(ngrid),zpdf_e1(ngrid),zpdf_e2(ngrid) 
-      REAL zqs(ngrid), qcloud(ngrid)
-      REAL erf
-
-      REAL rhodz(ngrid,klev)
-      REAL zrho(ngrid,klev)
-      REAL dz(ngrid,klev)
-
-      DO ind1 = 1, ngrid
-        !Layer calculation
-        rhodz(ind1,ind2) = (paprs(ind1,ind2)-paprs(ind1,ind2+1))/rg !kg/m2
-        zrho(ind1,ind2) = pplay(ind1,ind2)/t(ind1,ind2)/rd !kg/m3
-        dz(ind1,ind2) = rhodz(ind1,ind2)/zrho(ind1,ind2) !m : epaisseur de la couche en metre
-      END DO
-
-!------------------------------------------------------------------------------
-! Initialize
-!------------------------------------------------------------------------------
-
-      sigma1(:,:)=0.
-      sigma2(:,:)=0.
-      qlth(:,:)=0.
-      qlenv(:,:)=0.  
-      qltot(:,:)=0.
-      rneb(:,:)=0.
-      qcloud(:)=0.
-      cth(:,:)=0.
-      cenv(:,:)=0.
-      ctot(:,:)=0.
-      cth_vol(:,:)=0.
-      cenv_vol(:,:)=0.
-      ctot_vol(:,:)=0.
-      qsatmmussig1=0.
-      qsatmmussig2=0.
-      rdd=287.04
-      cppd=1005.7
-      pi=3.14159 
-      Lv=2.5e6
-      sqrt2pi=sqrt(2.*pi)
-      sqrt2=sqrt(2.)
-      sqrtpi=sqrt(pi)
-
-
-
-!-------------------------------------------------------------------------------
-! Calcul de la fraction du thermique et des ecart-types des distributions
-!-------------------------------------------------------------------------------                 
-      do ind1=1,ngrid
-
-      if ((ztv(ind1,1).gt.ztv(ind1,2)).and.(fraca(ind1,ind2).gt.1.e-10)) then !Thermal and environnement
-
-      zqenv(ind1)=(po(ind1)-fraca(ind1,ind2)*zqta(ind1,ind2))/(1.-fraca(ind1,ind2)) !qt = a*qtth + (1-a)*qtenv
-
-
-      Tbef=zthl(ind1,ind2)*zpspsk(ind1,ind2)
-      zdelta=MAX(0.,SIGN(1.,RTT-Tbef))
-      qsatbef= R2ES*FOEEW(Tbef,zdelta)/paprs(ind1,ind2)
-      qsatbef=MIN(0.5,qsatbef)
-      zcor=1./(1.-retv*qsatbef)
-      qsatbef=qsatbef*zcor
-      zqsatenv(ind1,ind2)=qsatbef
-
-
-      alenv=(0.622*Lv*zqsatenv(ind1,ind2))/(rdd*zthl(ind1,ind2)**2)     !qsl, p84
-      aenv=1./(1.+(alenv*Lv/cppd))                                      !al, p84
-      senv=aenv*(po(ind1)-zqsatenv(ind1,ind2))                          !s, p84
-
-!zqenv = qt environnement
-!zqsatenv = qsat environnement
-!zthl = Tl environnement
-
-
-      Tbef=ztla(ind1,ind2)*zpspsk(ind1,ind2)
-      zdelta=MAX(0.,SIGN(1.,RTT-Tbef))
-      qsatbef= R2ES * FOEEW(Tbef,zdelta)/paprs(ind1,ind2)
-      qsatbef=MIN(0.5,qsatbef)
-      zcor=1./(1.-retv*qsatbef)
-      qsatbef=qsatbef*zcor
-      zqsatth(ind1,ind2)=qsatbef
-            
-      alth=(0.622*Lv*zqsatth(ind1,ind2))/(rdd*ztla(ind1,ind2)**2)       !qsl, p84
-      ath=1./(1.+(alth*Lv/cppd))                                        !al, p84
-      sth=ath*(zqta(ind1,ind2)-zqsatth(ind1,ind2))                      !s, p84
-      
-      
-!zqta = qt thermals
-!zqsatth = qsat thermals
-!ztla = Tl thermals
-!------------------------------------------------------------------------------
-! s standard deviation
-!------------------------------------------------------------------------------
-
-      sigma1s_fraca = (sigma1s_factor**0.5)*(fraca(ind1,ind2)**sigma1s_power) / &
-     &                (1-fraca(ind1,ind2))*((sth-senv)**2)**0.5
-!     sigma1s_fraca = (1.1**0.5)*(fraca(ind1,ind2)**0.6)/(1-fraca(ind1,ind2))*((sth-senv)**2)**0.5
-      IF (cloudth_ratqsmin>0.) THEN
-         sigma1s_ratqs = cloudth_ratqsmin*po(ind1)
-      ELSE
-         sigma1s_ratqs = ratqs(ind1,ind2)*po(ind1)
-      ENDIF
-      sigma1s = sigma1s_fraca + sigma1s_ratqs
-      sigma2s=(sigma2s_factor*(((sth-senv)**2)**0.5)/((fraca(ind1,ind2)+0.02)**sigma2s_power))+0.002*zqta(ind1,ind2)
-      IF (iflag_ratqs.eq.10.or.iflag_ratqs.eq.11) then
-         sigma1s = ratqs(ind1,ind2)*po(ind1)*aenv
-         IF (iflag_ratqs.eq.10.and.sigma_qtherm(ind1,ind2).ne.0) then
-            sigma2s = sigma_qtherm(ind1,ind2)*ath
-         ENDIF
-      ENDIF
-      
-!      tests
-!      sigma1s=(0.92**0.5)*(fraca(ind1,ind2)**0.5)/(1-fraca(ind1,ind2))*((sth-senv)**2)**0.5+ratqs(ind1,ind2)*po(ind1)
-!      sigma1s=(0.92*(fraca(ind1,ind2)**0.5)/(1-fraca(ind1,ind2))*(((sth-senv)**2)**0.5))+0.002*zqenv(ind1)
-!      sigma2s=0.09*((sth-senv)**2)**0.5/(fraca(ind1,ind2)+0.02)**0.5+0.002*zqta(ind1,ind2) 
-!      sigma2s=(0.09*(((sth-senv)**2)**0.5)/((fraca(ind1,ind2)+0.02)**0.5))+ratqs(ind1,ind2)*zqta(ind1,ind2)
-!       if (paprs(ind1,ind2).gt.90000) then
-!       ratqs(ind1,ind2)=0.002
-!       else 
-!       ratqs(ind1,ind2)=0.002+0.0*(90000-paprs(ind1,ind2))/20000
-!       endif
-!       sigma1s=(1.1**0.5)*(fraca(ind1,ind2)**0.6)/(1-fraca(ind1,ind2))*((sth-senv)**2)**0.5+0.002*po(ind1)
-!       sigma2s=0.11*((sth-senv)**2)**0.5/(fraca(ind1,ind2)+0.01)**0.4+0.002*zqta(ind1,ind2) 
-!       sigma1s=ratqs(ind1,ind2)*po(ind1)
-!      sigma2s=0.11*((sth-senv)**2)**0.5/(fraca(ind1,ind2)+0.02)**0.4+0.00003  
- 
-       IF (iflag_cloudth_vert == 1) THEN
-!-------------------------------------------------------------------------------
-!  Version 2: Modification from Arnaud Jam according to JL Dufrense. Condensate from qsat-ratqs
-!-------------------------------------------------------------------------------
-
-      deltasenv=aenv*ratqs(ind1,ind2)*zqsatenv(ind1,ind2)
-      deltasth=ath*ratqs(ind1,ind2)*zqsatth(ind1,ind2)
-
-      xenv1=(senv-deltasenv)/(sqrt(2.)*sigma1s)
-      xenv2=(senv+deltasenv)/(sqrt(2.)*sigma1s)
-      xth1=(sth-deltasth)/(sqrt(2.)*sigma2s)
-      xth2=(sth+deltasth)/(sqrt(2.)*sigma2s)
-      coeffqlenv=(sigma1s)**2/(2*sqrtpi*deltasenv)
-      coeffqlth=(sigma2s)**2/(2*sqrtpi*deltasth)
-      
-      cth(ind1,ind2)=0.5*(1.+1.*erf(xth2))
-      cenv(ind1,ind2)=0.5*(1.+1.*erf(xenv2)) 
-      ctot(ind1,ind2)=fraca(ind1,ind2)*cth(ind1,ind2)+(1.-1.*fraca(ind1,ind2))*cenv(ind1,ind2)   
-
-      ! Environment
-      IntJ=sigma1s*(exp(-1.*xenv1**2)/sqrt2pi)+0.5*senv*(1+erf(xenv1))
-      IntI1=coeffqlenv*0.5*(0.5*sqrtpi*(erf(xenv2)-erf(xenv1))+xenv1*exp(-1.*xenv1**2)-xenv2*exp(-1.*xenv2**2))
-      IntI2=coeffqlenv*xenv2*(exp(-1.*xenv2**2)-exp(-1.*xenv1**2))
-      IntI3=coeffqlenv*0.5*sqrtpi*xenv2**2*(erf(xenv2)-erf(xenv1))
-
-      qlenv(ind1,ind2)=IntJ+IntI1+IntI2+IntI3
-
-      ! Thermal
-      IntJ=sigma2s*(exp(-1.*xth1**2)/sqrt2pi)+0.5*sth*(1+erf(xth1))
-      IntI1=coeffqlth*0.5*(0.5*sqrtpi*(erf(xth2)-erf(xth1))+xth1*exp(-1.*xth1**2)-xth2*exp(-1.*xth2**2))
-      IntI2=coeffqlth*xth2*(exp(-1.*xth2**2)-exp(-1.*xth1**2))
-      IntI3=coeffqlth*0.5*sqrtpi*xth2**2*(erf(xth2)-erf(xth1))
-      qlth(ind1,ind2)=IntJ+IntI1+IntI2+IntI3
-      qltot(ind1,ind2)=fraca(ind1,ind2)*qlth(ind1,ind2)+(1.-1.*fraca(ind1,ind2))*qlenv(ind1,ind2)
-
-      ELSE IF (iflag_cloudth_vert >= 3) THEN
-      IF (iflag_cloudth_vert < 5) THEN
-!-------------------------------------------------------------------------------
-!  Version 3: Changes by J. Jouhaud; condensation for q > -delta s
-!-------------------------------------------------------------------------------
-!      deltasenv=aenv*ratqs(ind1,ind2)*po(ind1)
-!      deltasth=ath*ratqs(ind1,ind2)*zqta(ind1,ind2)
-!      deltasenv=aenv*ratqs(ind1,ind2)*zqsatenv(ind1,ind2)
-!      deltasth=ath*ratqs(ind1,ind2)*zqsatth(ind1,ind2)
-      IF (iflag_cloudth_vert == 3) THEN
-        deltasenv=aenv*vert_alpha*sigma1s
-        deltasth=ath*vert_alpha_th*sigma2s
-      ELSE IF (iflag_cloudth_vert == 4) THEN
-        IF (iflag_cloudth_vert_noratqs == 1) THEN
-          deltasenv=vert_alpha*max(sigma1s_fraca,1e-10)
-          deltasth=vert_alpha_th*sigma2s
-        ELSE
-          deltasenv=vert_alpha*sigma1s
-          deltasth=vert_alpha_th*sigma2s
-        ENDIF
-      ENDIF
-      
-      xenv1=-(senv+deltasenv)/(sqrt(2.)*sigma1s)
-      xenv2=-(senv-deltasenv)/(sqrt(2.)*sigma1s)
-      exp_xenv1 = exp(-1.*xenv1**2)
-      exp_xenv2 = exp(-1.*xenv2**2)
-      xth1=-(sth+deltasth)/(sqrt(2.)*sigma2s)
-      xth2=-(sth-deltasth)/(sqrt(2.)*sigma2s)
-      exp_xth1 = exp(-1.*xth1**2)
-      exp_xth2 = exp(-1.*xth2**2)
-      
-      !CF_surfacique
-      cth(ind1,ind2)=0.5*(1.-1.*erf(xth1))
-      cenv(ind1,ind2)=0.5*(1.-1.*erf(xenv1))
-      ctot(ind1,ind2)=fraca(ind1,ind2)*cth(ind1,ind2)+(1.-1.*fraca(ind1,ind2))*cenv(ind1,ind2) 
-
-
-      !CF_volumique & eau condense
-      !environnement
-      IntJ=0.5*senv*(1-erf(xenv2))+(sigma1s/sqrt2pi)*exp_xenv2
-      IntJ_CF=0.5*(1.-1.*erf(xenv2))
-      if (deltasenv .lt. 1.e-10) then 
-      qlenv(ind1,ind2)=IntJ
-      cenv_vol(ind1,ind2)=IntJ_CF
-      else
-      IntI1=(((senv+deltasenv)**2+(sigma1s)**2)/(8*deltasenv))*(erf(xenv2)-erf(xenv1))
-      IntI2=(sigma1s**2/(4*deltasenv*sqrtpi))*(xenv1*exp_xenv1-xenv2*exp_xenv2)
-      IntI3=((sqrt2*sigma1s*(senv+deltasenv))/(4*sqrtpi*deltasenv))*(exp_xenv1-exp_xenv2)
-      IntI1_CF=((senv+deltasenv)*(erf(xenv2)-erf(xenv1)))/(4*deltasenv)
-      IntI3_CF=(sqrt2*sigma1s*(exp_xenv1-exp_xenv2))/(4*sqrtpi*deltasenv)
-      qlenv(ind1,ind2)=IntJ+IntI1+IntI2+IntI3
-      cenv_vol(ind1,ind2)=IntJ_CF+IntI1_CF+IntI3_CF
-      endif
-
-      !thermique
-      IntJ=0.5*sth*(1-erf(xth2))+(sigma2s/sqrt2pi)*exp_xth2
-      IntJ_CF=0.5*(1.-1.*erf(xth2))
-      if (deltasth .lt. 1.e-10) then
-      qlth(ind1,ind2)=IntJ
-      cth_vol(ind1,ind2)=IntJ_CF
-      else
-      IntI1=(((sth+deltasth)**2+(sigma2s)**2)/(8*deltasth))*(erf(xth2)-erf(xth1))
-      IntI2=(sigma2s**2/(4*deltasth*sqrtpi))*(xth1*exp_xth1-xth2*exp_xth2)
-      IntI3=((sqrt2*sigma2s*(sth+deltasth))/(4*sqrtpi*deltasth))*(exp_xth1-exp_xth2)
-      IntI1_CF=((sth+deltasth)*(erf(xth2)-erf(xth1)))/(4*deltasth)
-      IntI3_CF=(sqrt2*sigma2s*(exp_xth1-exp_xth2))/(4*sqrtpi*deltasth)
-      qlth(ind1,ind2)=IntJ+IntI1+IntI2+IntI3
-      cth_vol(ind1,ind2)=IntJ_CF+IntI1_CF+IntI3_CF
-      endif
-
-      qltot(ind1,ind2)=fraca(ind1,ind2)*qlth(ind1,ind2)+(1.-1.*fraca(ind1,ind2))*qlenv(ind1,ind2)
-      ctot_vol(ind1,ind2)=fraca(ind1,ind2)*cth_vol(ind1,ind2)+(1.-1.*fraca(ind1,ind2))*cenv_vol(ind1,ind2)
-
-      ELSE IF (iflag_cloudth_vert == 5) THEN
-         sigma1s=(0.71794+0.000498239*dz(ind1,ind2))*(fraca(ind1,ind2)**0.5) &
-              /(1-fraca(ind1,ind2))*(((sth-senv)**2)**0.5) &
-              +ratqs(ind1,ind2)*po(ind1) !Environment
-      sigma2s=(0.03218+0.000092655*dz(ind1,ind2))/((fraca(ind1,ind2)+0.02)**0.5)*(((sth-senv)**2)**0.5)+0.002*zqta(ind1,ind2)                   !Thermals
-      !sigma1s=(1.1**0.5)*(fraca(ind1,ind2)**0.6)/(1-fraca(ind1,ind2))*((sth-senv)**2)**0.5+0.002*po(ind1)
-      !sigma2s=0.11*((sth-senv)**2)**0.5/(fraca(ind1,ind2)+0.01)**0.4+0.002*zqta(ind1,ind2) 
-      xth=sth/(sqrt(2.)*sigma2s)
-      xenv=senv/(sqrt(2.)*sigma1s)
-
-      !Volumique
-      cth_vol(ind1,ind2)=0.5*(1.+1.*erf(xth))
-      cenv_vol(ind1,ind2)=0.5*(1.+1.*erf(xenv))
-      ctot_vol(ind1,ind2)=fraca(ind1,ind2)*cth_vol(ind1,ind2)+(1.-1.*fraca(ind1,ind2))*cenv_vol(ind1,ind2)
-      !print *,'jeanjean_CV=',ctot_vol(ind1,ind2)
-
-      qlth(ind1,ind2)=sigma2s*((exp(-1.*xth**2)/sqrt2pi)+xth*sqrt(2.)*cth_vol(ind1,ind2))
-      qlenv(ind1,ind2)=sigma1s*((exp(-1.*xenv**2)/sqrt2pi)+xenv*sqrt(2.)*cenv_vol(ind1,ind2))  
-      qltot(ind1,ind2)=fraca(ind1,ind2)*qlth(ind1,ind2)+(1.-1.*fraca(ind1,ind2))*qlenv(ind1,ind2)
-
-      !Surfacique
-      !Neggers
-      !beta=0.0044
-      !inverse_rho=1.+beta*dz(ind1,ind2)
-      !print *,'jeanjean : beta=',beta
-      !cth(ind1,ind2)=cth_vol(ind1,ind2)*inverse_rho
-      !cenv(ind1,ind2)=cenv_vol(ind1,ind2)*inverse_rho
-      !ctot(ind1,ind2)=fraca(ind1,ind2)*cth(ind1,ind2)+(1.-1.*fraca(ind1,ind2))*cenv(ind1,ind2)
-
-      !Brooks
-      a_Brooks=0.6694
-      b_Brooks=0.1882
-      A_Maj_Brooks=0.1635 !-- sans shear
-      !A_Maj_Brooks=0.17   !-- ARM LES
-      !A_Maj_Brooks=0.18   !-- RICO LES
-      !A_Maj_Brooks=0.19   !-- BOMEX LES
-      Dx_Brooks=200000.
-      f_Brooks=A_Maj_Brooks*(dz(ind1,ind2)**(a_Brooks))*(Dx_Brooks**(-b_Brooks))
-      !print *,'jeanjean_f=',f_Brooks
-
-      cth(ind1,ind2)=1./(1.+exp(-1.*f_Brooks)*((1./max(1.e-15,min(cth_vol(ind1,ind2),1.)))- 1.))
-      cenv(ind1,ind2)=1./(1.+exp(-1.*f_Brooks)*((1./max(1.e-15,min(cenv_vol(ind1,ind2),1.)))- 1.))
-      ctot(ind1,ind2)=1./(1.+exp(-1.*f_Brooks)*((1./max(1.e-15,min(ctot_vol(ind1,ind2),1.)))- 1.))
-      !print *,'JJ_ctot_1',ctot(ind1,ind2)
-
-
-
-
-
-      ENDIF ! of if (iflag_cloudth_vert<5)
-      ENDIF ! of if (iflag_cloudth_vert==1 or 3 or 4)
-
-!      if (ctot(ind1,ind2).lt.1.e-10) then
-      if (cenv(ind1,ind2).lt.1.e-10.or.cth(ind1,ind2).lt.1.e-10) then
-      ctot(ind1,ind2)=0.
-      ctot_vol(ind1,ind2)=0.
-      qcloud(ind1)=zqsatenv(ind1,ind2)
-
-      else
-                
-      qcloud(ind1)=qltot(ind1,ind2)/ctot(ind1,ind2)+zqs(ind1)
-!      qcloud(ind1)=fraca(ind1,ind2)*qlth(ind1,ind2)/cth(ind1,ind2) &
-!    &             +(1.-1.*fraca(ind1,ind2))*qlenv(ind1,ind2)/cenv(ind1,ind2)+zqs(ind1) 
-
-      endif  
-
-      else  ! gaussienne environnement seule
-      
-
-      zqenv(ind1)=po(ind1)
-      Tbef=t(ind1,ind2)
-      zdelta=MAX(0.,SIGN(1.,RTT-Tbef))
-      qsatbef= R2ES * FOEEW(Tbef,zdelta)/paprs(ind1,ind2)
-      qsatbef=MIN(0.5,qsatbef)
-      zcor=1./(1.-retv*qsatbef)
-      qsatbef=qsatbef*zcor
-      zqsatenv(ind1,ind2)=qsatbef
-      
-
-!      qlbef=Max(po(ind1)-zqsatenv(ind1,ind2),0.)
-      zthl(ind1,ind2)=t(ind1,ind2)*(101325/paprs(ind1,ind2))**(rdd/cppd)
-      alenv=(0.622*Lv*zqsatenv(ind1,ind2))/(rdd*zthl(ind1,ind2)**2)
-      aenv=1./(1.+(alenv*Lv/cppd))
-      senv=aenv*(po(ind1)-zqsatenv(ind1,ind2))
-      sth=0.
-      
-
-      sigma1s=ratqs(ind1,ind2)*zqenv(ind1)
-      sigma2s=0.
-
-      sqrt2pi=sqrt(2.*pi)
-      xenv=senv/(sqrt(2.)*sigma1s)
-      ctot(ind1,ind2)=0.5*(1.+1.*erf(xenv))
-      ctot_vol(ind1,ind2)=ctot(ind1,ind2)
-      qltot(ind1,ind2)=sigma1s*((exp(-1.*xenv**2)/sqrt2pi)+xenv*sqrt(2.)*cenv(ind1,ind2))
-      
-      if (ctot(ind1,ind2).lt.1.e-3) then
-      ctot(ind1,ind2)=0.
-      qcloud(ind1)=zqsatenv(ind1,ind2)
-
-      else   
-                
-!      ctot(ind1,ind2)=ctot(ind1,ind2) 
-      qcloud(ind1)=qltot(ind1,ind2)/ctot(ind1,ind2)+zqsatenv(ind1,ind2)
-
-      endif  
- 
-
-
-
-      endif       ! From the separation (thermal/envrionnement) et (environnement) only, l.335 et l.492
-      ! Outputs used to check the PDFs
-      cloudth_senv(ind1,ind2) = senv
-      cloudth_sth(ind1,ind2) = sth
-      cloudth_sigmaenv(ind1,ind2) = sigma1s
-      cloudth_sigmath(ind1,ind2) = sigma2s
-
-      enddo       ! from the loop on ngrid l.333
-      return
-!     end
-END SUBROUTINE cloudth_vert_v3
-!
-
-
-
-
-
-
-
-
-
-
-
-       SUBROUTINE cloudth_v6(ngrid,klev,ind2,  &
-     &           ztv,po,zqta,fraca, & 
-     &           qcloud,ctot_surf,ctot_vol,zpspsk,paprs,pplay,ztla,zthl, &
-     &           ratqs,zqs,T, &
-     &           cloudth_sth,cloudth_senv,cloudth_sigmath,cloudth_sigmaenv)
-
-      use lmdz_cloudth_ini, only: iflag_cloudth_vert
-
-      IMPLICIT NONE
-
-
-      INCLUDE "YOMCST.h"
-      INCLUDE "YOETHF.h"
-      INCLUDE "FCTTRE.h"
-
-
-        !Domain variables
-      INTEGER ngrid !indice Max lat-lon
-      INTEGER klev  !indice Max alt
-      real, dimension(ngrid,klev), intent(out) :: cloudth_sth,cloudth_senv,cloudth_sigmath,cloudth_sigmaenv
-      INTEGER ind1  !indice in [1:ngrid]
-      INTEGER ind2  !indice in [1:klev]
-        !thermal plume fraction
-      REAL fraca(ngrid,klev+1)   !thermal plumes fraction in the gridbox
-        !temperatures
-      REAL T(ngrid,klev)       !temperature
-      REAL zpspsk(ngrid,klev)  !factor (p/p0)**kappa (used for potential variables)
-      REAL ztv(ngrid,klev)     !potential temperature (voir thermcell_env.F90)
-      REAL ztla(ngrid,klev)    !liquid temperature in the thermals (Tl_th)
-      REAL zthl(ngrid,klev)    !liquid temperature in the environment (Tl_env)
-        !pressure
-      REAL paprs(ngrid,klev+1)   !pressure at the interface of levels
-      REAL pplay(ngrid,klev)     !pressure at the middle of the level
-        !humidity
-      REAL ratqs(ngrid,klev)   !width of the total water subgrid-scale distribution
-      REAL po(ngrid)           !total water (qt)
-      REAL zqenv(ngrid)        !total water in the environment (qt_env)
-      REAL zqta(ngrid,klev)    !total water in the thermals (qt_th)
-      REAL zqsatth(ngrid,klev)   !water saturation level in the thermals (q_sat_th)
-      REAL zqsatenv(ngrid,klev)  !water saturation level in the environment (q_sat_env)
-      REAL qlth(ngrid,klev)    !condensed water in the thermals
-      REAL qlenv(ngrid,klev)   !condensed water in the environment
-      REAL qltot(ngrid,klev)   !condensed water in the gridbox
-        !cloud fractions
-      REAL cth_vol(ngrid,klev)   !cloud fraction by volume in the thermals
-      REAL cenv_vol(ngrid,klev)  !cloud fraction by volume in the environment
-      REAL ctot_vol(ngrid,klev)  !cloud fraction by volume in the gridbox
-      REAL cth_surf(ngrid,klev)  !cloud fraction by surface in the thermals
-      REAL cenv_surf(ngrid,klev) !cloud fraction by surface in the environment  
-      REAL ctot_surf(ngrid,klev) !cloud fraction by surface in the gridbox
-        !PDF of saturation deficit variables
-      REAL rdd,cppd,Lv
-      REAL Tbef,zdelta,qsatbef,zcor
-      REAL alth,alenv,ath,aenv
-      REAL sth,senv              !saturation deficits in the thermals and environment
-      REAL sigma_env,sigma_th    !standard deviations of the biGaussian PDF
-        !cloud fraction variables
-      REAL xth,xenv
-      REAL inverse_rho,beta                                  !Neggers et al. (2011) method
-      REAL a_Brooks,b_Brooks,A_Maj_Brooks,Dx_Brooks,f_Brooks !Brooks et al. (2005) method
-        !Incloud total water variables
-      REAL zqs(ngrid)    !q_sat
-      REAL qcloud(ngrid) !eau totale dans le nuage
-        !Some arithmetic variables
-      REAL erf,pi,sqrt2,sqrt2pi
-        !Depth of the layer
-      REAL dz(ngrid,klev)    !epaisseur de la couche en metre
-      REAL rhodz(ngrid,klev)
-      REAL zrho(ngrid,klev)
-      DO ind1 = 1, ngrid
-        rhodz(ind1,ind2) = (paprs(ind1,ind2)-paprs(ind1,ind2+1))/rg ![kg/m2]
-        zrho(ind1,ind2) = pplay(ind1,ind2)/T(ind1,ind2)/rd          ![kg/m3]
-        dz(ind1,ind2) = rhodz(ind1,ind2)/zrho(ind1,ind2)            ![m]
-      END DO
-
-!------------------------------------------------------------------------------
-! Initialization
-!------------------------------------------------------------------------------
-      qlth(:,:)=0.
-      qlenv(:,:)=0.  
-      qltot(:,:)=0.
-      cth_vol(:,:)=0.
-      cenv_vol(:,:)=0.
-      ctot_vol(:,:)=0.
-      cth_surf(:,:)=0.
-      cenv_surf(:,:)=0.
-      ctot_surf(:,:)=0.
-      qcloud(:)=0.
-      rdd=287.04
-      cppd=1005.7
-      pi=3.14159 
-      Lv=2.5e6
-      sqrt2=sqrt(2.)
-      sqrt2pi=sqrt(2.*pi)
-
-
-      DO ind1=1,ngrid
-!-------------------------------------------------------------------------------
-!Both thermal and environment in the gridbox
-!-------------------------------------------------------------------------------
-      IF ((ztv(ind1,1).gt.ztv(ind1,2)).and.(fraca(ind1,ind2).gt.1.e-10)) THEN
-        !--------------------------------------------
-        !calcul de qsat_env
-        !--------------------------------------------
-      Tbef=zthl(ind1,ind2)*zpspsk(ind1,ind2)
-      zdelta=MAX(0.,SIGN(1.,RTT-Tbef))
-      qsatbef= R2ES*FOEEW(Tbef,zdelta)/paprs(ind1,ind2)
-      qsatbef=MIN(0.5,qsatbef)
-      zcor=1./(1.-retv*qsatbef)
-      qsatbef=qsatbef*zcor
-      zqsatenv(ind1,ind2)=qsatbef
-        !--------------------------------------------
-        !calcul de s_env
-        !--------------------------------------------
-      alenv=(0.622*Lv*zqsatenv(ind1,ind2))/(rdd*zthl(ind1,ind2)**2)     !qsl, p84 these Arnaud Jam
-      aenv=1./(1.+(alenv*Lv/cppd))                                      !al, p84 these Arnaud Jam
-      senv=aenv*(po(ind1)-zqsatenv(ind1,ind2))                          !s, p84 these Arnaud Jam
-        !--------------------------------------------
-        !calcul de qsat_th
-        !--------------------------------------------
-      Tbef=ztla(ind1,ind2)*zpspsk(ind1,ind2)
-      zdelta=MAX(0.,SIGN(1.,RTT-Tbef))
-      qsatbef= R2ES * FOEEW(Tbef,zdelta)/paprs(ind1,ind2)
-      qsatbef=MIN(0.5,qsatbef)
-      zcor=1./(1.-retv*qsatbef)
-      qsatbef=qsatbef*zcor
-      zqsatth(ind1,ind2)=qsatbef
-        !--------------------------------------------
-        !calcul de s_th  
-        !--------------------------------------------
-      alth=(0.622*Lv*zqsatth(ind1,ind2))/(rdd*ztla(ind1,ind2)**2)       !qsl, p84 these Arnaud Jam
-      ath=1./(1.+(alth*Lv/cppd))                                        !al, p84 these Arnaud Jam
-      sth=ath*(zqta(ind1,ind2)-zqsatth(ind1,ind2))                      !s, p84 these Arnaud Jam
-        !--------------------------------------------
-        !calcul standard deviations bi-Gaussian PDF
-        !--------------------------------------------
-      sigma_th=(0.03218+0.000092655*dz(ind1,ind2))/((fraca(ind1,ind2)+0.01)**0.5)*(((sth-senv)**2)**0.5)+0.002*zqta(ind1,ind2)
-      sigma_env=(0.71794+0.000498239*dz(ind1,ind2))*(fraca(ind1,ind2)**0.5) &
-           /(1-fraca(ind1,ind2))*(((sth-senv)**2)**0.5) &
-           +ratqs(ind1,ind2)*po(ind1)
-      xth=sth/(sqrt2*sigma_th)
-      xenv=senv/(sqrt2*sigma_env)
-        !--------------------------------------------
-        !Cloud fraction by volume CF_vol
-        !--------------------------------------------
-      cth_vol(ind1,ind2)=0.5*(1.+1.*erf(xth))
-      cenv_vol(ind1,ind2)=0.5*(1.+1.*erf(xenv))
-      ctot_vol(ind1,ind2)=fraca(ind1,ind2)*cth_vol(ind1,ind2)+(1.-1.*fraca(ind1,ind2))*cenv_vol(ind1,ind2)
-        !-------------------------------------------- 
-        !Condensed water qc
-        !--------------------------------------------
-      qlth(ind1,ind2)=sigma_th*((exp(-1.*xth**2)/sqrt2pi)+xth*sqrt2*cth_vol(ind1,ind2))
-      qlenv(ind1,ind2)=sigma_env*((exp(-1.*xenv**2)/sqrt2pi)+xenv*sqrt2*cenv_vol(ind1,ind2))  
-      qltot(ind1,ind2)=fraca(ind1,ind2)*qlth(ind1,ind2)+(1.-1.*fraca(ind1,ind2))*qlenv(ind1,ind2)
-        !--------------------------------------------
-        !Cloud fraction by surface CF_surf
-        !--------------------------------------------
-        !Method Neggers et al. (2011) : ok for cumulus clouds only
-      !beta=0.0044 (Jouhaud et al.2018)
-      !inverse_rho=1.+beta*dz(ind1,ind2)
-      !ctot_surf(ind1,ind2)=ctot_vol(ind1,ind2)*inverse_rho
-        !Method Brooks et al. (2005) : ok for all types of clouds
-      a_Brooks=0.6694
-      b_Brooks=0.1882
-      A_Maj_Brooks=0.1635 !-- sans dependence au cisaillement de vent
-      Dx_Brooks=200000.   !-- si l'on considere des mailles de 200km de cote
-      f_Brooks=A_Maj_Brooks*(dz(ind1,ind2)**(a_Brooks))*(Dx_Brooks**(-b_Brooks))
-      ctot_surf(ind1,ind2)=1./(1.+exp(-1.*f_Brooks)*((1./max(1.e-15,min(ctot_vol(ind1,ind2),1.)))- 1.))
-        !--------------------------------------------
-        !Incloud Condensed water qcloud
-        !--------------------------------------------
-      if (ctot_surf(ind1,ind2) .lt. 1.e-10) then
-      ctot_vol(ind1,ind2)=0.
-      ctot_surf(ind1,ind2)=0.
-      qcloud(ind1)=zqsatenv(ind1,ind2)
-      else
-      qcloud(ind1)=qltot(ind1,ind2)/ctot_vol(ind1,ind2)+zqs(ind1)
-      endif
-
-
-
-!-------------------------------------------------------------------------------
-!Environment only in the gridbox
-!-------------------------------------------------------------------------------
-      ELSE
-        !--------------------------------------------
-        !calcul de qsat_env
-        !--------------------------------------------
-      Tbef=zthl(ind1,ind2)*zpspsk(ind1,ind2)
-      zdelta=MAX(0.,SIGN(1.,RTT-Tbef))
-      qsatbef= R2ES * FOEEW(Tbef,zdelta)/paprs(ind1,ind2)
-      qsatbef=MIN(0.5,qsatbef)
-      zcor=1./(1.-retv*qsatbef)
-      qsatbef=qsatbef*zcor
-      zqsatenv(ind1,ind2)=qsatbef
-        !--------------------------------------------
-        !calcul de s_env
-        !--------------------------------------------
-      alenv=(0.622*Lv*zqsatenv(ind1,ind2))/(rdd*zthl(ind1,ind2)**2)     !qsl, p84 these Arnaud Jam
-      aenv=1./(1.+(alenv*Lv/cppd))                                      !al, p84 these Arnaud Jam
-      senv=aenv*(po(ind1)-zqsatenv(ind1,ind2))                          !s, p84 these Arnaud Jam 
-        !--------------------------------------------
-        !calcul standard deviations Gaussian PDF
-        !--------------------------------------------
-      zqenv(ind1)=po(ind1)
-      sigma_env=ratqs(ind1,ind2)*zqenv(ind1)
-      xenv=senv/(sqrt2*sigma_env)
-        !--------------------------------------------
-        !Cloud fraction by volume CF_vol
-        !--------------------------------------------
-      ctot_vol(ind1,ind2)=0.5*(1.+1.*erf(xenv))
-        !--------------------------------------------
-        !Condensed water qc
-        !--------------------------------------------
-      qltot(ind1,ind2)=sigma_env*((exp(-1.*xenv**2)/sqrt2pi)+xenv*sqrt2*ctot_vol(ind1,ind2))
-        !--------------------------------------------
-        !Cloud fraction by surface CF_surf
-        !--------------------------------------------
-        !Method Neggers et al. (2011) : ok for cumulus clouds only
-      !beta=0.0044 (Jouhaud et al.2018)
-      !inverse_rho=1.+beta*dz(ind1,ind2)
-      !ctot_surf(ind1,ind2)=ctot_vol(ind1,ind2)*inverse_rho
-        !Method Brooks et al. (2005) : ok for all types of clouds
-      a_Brooks=0.6694
-      b_Brooks=0.1882
-      A_Maj_Brooks=0.1635 !-- sans dependence au shear
-      Dx_Brooks=200000.
-      f_Brooks=A_Maj_Brooks*(dz(ind1,ind2)**(a_Brooks))*(Dx_Brooks**(-b_Brooks))
-      ctot_surf(ind1,ind2)=1./(1.+exp(-1.*f_Brooks)*((1./max(1.e-15,min(ctot_vol(ind1,ind2),1.)))- 1.))
-        !--------------------------------------------
-        !Incloud Condensed water qcloud
-        !--------------------------------------------
-      if (ctot_surf(ind1,ind2) .lt. 1.e-8) then
-      ctot_vol(ind1,ind2)=0.
-      ctot_surf(ind1,ind2)=0.
-      qcloud(ind1)=zqsatenv(ind1,ind2)
-      else
-      qcloud(ind1)=qltot(ind1,ind2)/ctot_vol(ind1,ind2)+zqsatenv(ind1,ind2)
-      endif
-
-
-      END IF  ! From the separation (thermal/envrionnement) et (environnement only)
-
-      ! Outputs used to check the PDFs
-      cloudth_senv(ind1,ind2) = senv
-      cloudth_sth(ind1,ind2) = sth
-      cloudth_sigmaenv(ind1,ind2) = sigma_env
-      cloudth_sigmath(ind1,ind2) = sigma_th
-
-      END DO  ! From the loop on ngrid
-      return
-
-END SUBROUTINE cloudth_v6
-
-
-
-
-
-!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-SUBROUTINE cloudth_mpc(klon,klev,ind2,mpc_bl_points,                        &
-&           temp,qt,qt_th,frac_th,zpspsk,paprsup, paprsdn,play,thetal_th,   &
-&           ratqs,qcloud,qincloud,icefrac,ctot,ctot_vol,                    &
-&           cloudth_sth,cloudth_senv,cloudth_sigmath,cloudth_sigmaenv)
-!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-! Author : Etienne Vignon (LMDZ/CNRS)
-! Date: April 2024
-! Date: Adapted from cloudth_vert_v3 in 2023 by Arnaud Otavio Jam
-! IMPORTANT NOTE: we assume iflag_cloudth_vert=7
-!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-
-      use lmdz_cloudth_ini, only: iflag_cloudth_vert,iflag_ratqs
-      use lmdz_cloudth_ini, only: C_mpc ,Ni,C_cap,Ei,d_top ,vert_alpha, vert_alpha_th ,sigma1s_factor,sigma1s_power,sigma2s_factor,sigma2s_power,cloudth_ratqsmin ,iflag_cloudth_vert_noratqs
-      use lmdz_lscp_tools,  only: CALC_QSAT_ECMWF
-      use lmdz_lscp_ini,    only: RTT, RG, RPI, RD, RCPD, RLVTT, RLSTT, temp_nowater, min_frac_th_cld, min_neb_th
-
-      IMPLICIT NONE
-
-
-!------------------------------------------------------------------------------
-! Declaration
-!------------------------------------------------------------------------------
-
-! INPUT/OUTPUT
-
-      INTEGER, INTENT(IN)                         :: klon,klev,ind2
-      
-
-      REAL, DIMENSION(klon),      INTENT(IN)      ::  temp          ! Temperature (liquid temperature) in the mesh [K] : has seen evap of precip
-      REAL, DIMENSION(klon),      INTENT(IN)      ::  qt            ! total water specific humidity in the mesh [kg/kg]: has seen evap of precip
-      REAL, DIMENSION(klon),      INTENT(IN)      ::  qt_th         ! total water specific humidity in thermals [kg/kg]: has not seen evap of precip
-      REAL, DIMENSION(klon),      INTENT(IN)      ::  thetal_th     ! Liquid potential temperature in thermals [K]: has not seen the evap of precip
-      REAL, DIMENSION(klon),      INTENT(IN)      ::  frac_th       ! Fraction of the mesh covered by thermals [0-1] 
-      REAL, DIMENSION(klon),      INTENT(IN)      ::  zpspsk        ! Exner potential
-      REAL, DIMENSION(klon),      INTENT(IN)      ::  paprsup       ! Pressure at top layer interface [Pa]
-      REAL, DIMENSION(klon),      INTENT(IN)      ::  paprsdn       ! Pressure at bottom layer interface [Pa]
-      REAL, DIMENSION(klon),      INTENT(IN)      ::  play          ! Pressure of layers [Pa]
-      REAL, DIMENSION(klon),      INTENT(IN)      ::  ratqs         ! Parameter that determines the width of the total water distrib.
-
-
-      INTEGER, DIMENSION(klon,klev), INTENT(INOUT) :: mpc_bl_points  ! grid points with convective (thermals) mixed phase clouds
-      
-      REAL, DIMENSION(klon),      INTENT(OUT)      ::  ctot         ! Cloud fraction [0-1]
-      REAL, DIMENSION(klon),      INTENT(OUT)      ::  ctot_vol     ! Volume cloud fraction [0-1]
-      REAL, DIMENSION(klon),      INTENT(OUT)      ::  qcloud       ! In cloud total water content [kg/kg] 
-      REAL, DIMENSION(klon),      INTENT(OUT)      ::  qincloud     ! In cloud condensed water content [kg/kg] 
-      REAL, DIMENSION(klon),      INTENT(OUT)      ::  icefrac      ! Fraction of ice in clouds [0-1]
-      REAL, DIMENSION(klon),      INTENT(OUT)      ::  cloudth_sth  ! mean saturation deficit in thermals
-      REAL, DIMENSION(klon),      INTENT(OUT)      ::  cloudth_senv ! mean saturation deficit in environment
-      REAL, DIMENSION(klon),      INTENT(OUT)      ::  cloudth_sigmath ! std of saturation deficit in thermals
-      REAL, DIMENSION(klon),      INTENT(OUT)      ::  cloudth_sigmaenv ! std of saturation deficit in environment
-
-
-! LOCAL VARIABLES
-
-      INTEGER itap,ind1,l,ig,iter,k 
-      INTEGER iflag_topthermals, niter
-
-      REAL qcth(klon)
-      REAL qcenv(klon)
-      REAL qctot(klon) 
-      REAL cth(klon)
-      REAL cenv(klon)   
-      REAL cth_vol(klon)
-      REAL cenv_vol(klon)
-      REAL qt_env(klon), thetal_env(klon)
-      REAL icefracenv(klon), icefracth(klon)
-      REAL sqrtpi,sqrt2,sqrt2pi
-      REAL alth,alenv,ath,aenv
-      REAL sth,senv,sigma1s,sigma2s,sigma1s_fraca,sigma1s_ratqs
-      REAL inverse_rho,beta,a_Brooks,b_Brooks,A_Maj_Brooks,Dx_Brooks,f_Brooks
-      REAL xth,xenv,exp_xenv1,exp_xenv2,exp_xth1,exp_xth2
-      REAL xth1,xth2,xenv1,xenv2,deltasth, deltasenv
-      REAL IntJ,IntI1,IntI2,IntI3,IntJ_CF,IntI1_CF,IntI3_CF,coeffqlenv,coeffqlth
-      REAL zdelta,qsatbef,zcor
-      REAL Tbefth(klon), Tbefenv(klon), zrho(klon), rhoth(klon)
-      REAL qlbef
-      REAL dqsatenv(klon), dqsatth(klon)
-      REAL erf
-      REAL zpdf_sig(klon),zpdf_k(klon),zpdf_delta(klon)
-      REAL zpdf_a(klon),zpdf_b(klon),zpdf_e1(klon),zpdf_e2(klon) 
-      REAL rhodz(klon)
-      REAL rho(klon)
-      REAL dz(klon)
-      REAL qslenv(klon), qslth(klon), qsienv(klon), qsith(klon)  
-      REAL alenvl, aenvl
-      REAL sthi, sthl, sthil, althl, athl, althi, athi, sthlc, deltasthc, sigma2sc
-      REAL senvi, senvl, qbase, sbase, qliqth, qiceth
-      REAL qmax, ttarget, stmp, cout, coutref, fraci
-      REAL maxi, mini, pas
-
-      ! Modifty the saturation deficit PDF in thermals 
-      ! in the presence of ice crystals
-      CHARACTER (len = 80) :: abort_message
-      CHARACTER (len = 20) :: routname = 'cloudth_mpc'
-
-
-!------------------------------------------------------------------------------
-! Initialisation
-!------------------------------------------------------------------------------
-
-
-! Few initial checksS
-
-      DO k = 1,klev
-      DO ind1 = 1, klon
-        rhodz(ind1) = (paprsdn(ind1)-paprsup(ind1))/rg !kg/m2
-        zrho(ind1)  = play(ind1)/temp(ind1)/rd !kg/m3
-        dz(ind1)    = rhodz(ind1)/zrho(ind1) !m : epaisseur de la couche en metre
-      END DO
-      END DO
-
-
-      icefracth(:)=0.
-      icefracenv(:)=0.
-      sqrt2pi=sqrt(2.*rpi)
-      sqrt2=sqrt(2.)
-      sqrtpi=sqrt(rpi)
-      icefrac(:)=0.
-
-!-------------------------------------------------------------------------------
-! Identify grid points with potential mixed-phase conditions
-!-------------------------------------------------------------------------------
-
-
-      DO ind1=1,klon
-            IF ((temp(ind1) .LT. RTT) .AND. (temp(ind1) .GT. temp_nowater) &
-            .AND. (ind2<=klev-2)  &
-            .AND. (frac_th(ind1).GT.min_frac_th_cld)) THEN
-                mpc_bl_points(ind1,ind2)=1
-            ELSE
-                mpc_bl_points(ind1,ind2)=0
-            ENDIF
-      ENDDO
-
-
-!-------------------------------------------------------------------------------
-! Thermal fraction calculation and standard deviation of the distribution
-!-------------------------------------------------------------------------------  
-
-! initialisations and calculation of temperature, humidity and saturation specific humidity
-
-DO ind1=1,klon
-  
-   rhodz(ind1)   = (paprsdn(ind1)-paprsup(ind1))/rg  ! kg/m2
-   rho(ind1)     = play(ind1)/temp(ind1)/rd          ! kg/m3
-   dz(ind1)      = rhodz(ind1)/rho(ind1)             ! m : epaisseur de la couche en metre
-   Tbefenv(ind1) = temp(ind1)
-   thetal_env(ind1) = Tbefenv(ind1)/zpspsk(ind1)
-   Tbefth(ind1)  = thetal_th(ind1)*zpspsk(ind1)
-   rhoth(ind1)   = play(ind1)/Tbefth(ind1)/RD
-   qt_env(ind1)  = (qt(ind1)-frac_th(ind1)*qt_th(ind1))/(1.-frac_th(ind1)) !qt = a*qtth + (1-a)*qtenv 
-
-ENDDO
-
-! Calculation of saturation specific humidity
-CALL CALC_QSAT_ECMWF(klon,Tbefenv,qt_env,play,RTT,1,.false.,qslenv,dqsatenv)
-CALL CALC_QSAT_ECMWF(klon,Tbefenv,qt_env,play,RTT,2,.false.,qsienv,dqsatenv)
-CALL CALC_QSAT_ECMWF(klon,Tbefth,qt_th,play,RTT,1,.false.,qslth,dqsatth)
-
-
-DO ind1=1,klon
-
-
-    IF (frac_th(ind1).GT.min_frac_th_cld) THEN !Thermal and environnement
-
-! unlike in the other cloudth routine, 
-! We consider distributions of the saturation deficit WRT liquid 
-! at positive AND negative celcius temperature
-! subsequently, cloud fraction corresponds to the part of the pdf corresponding
-! to superstauration with respect to liquid WHATEVER the temperature
-
-! Environment:
-
-
-        alenv=(0.622*RLVTT*qslenv(ind1))/(rd*thetal_env(ind1)**2)     
-        aenv=1./(1.+(alenv*RLVTT/rcpd))                             
-        senv=aenv*(qt_env(ind1)-qslenv(ind1))                           
-     
-
-! Thermals:
-
-
-        alth=(0.622*RLVTT*qslth(ind1))/(rd*thetal_th(ind1)**2)       
-        ath=1./(1.+(alth*RLVTT/rcpd))                                                         
-        sth=ath*(qt_th(ind1)-qslth(ind1))                      
-
-
-!       IF (mpc_bl_points(ind1,ind2) .EQ. 0) THEN ! No BL MPC
-
-
-! Standard deviation of the distributions
-
-           sigma1s_fraca = (sigma1s_factor**0.5)*(frac_th(ind1)**sigma1s_power) / &
-           &                (1-frac_th(ind1))*((sth-senv)**2)**0.5
-
-           IF (cloudth_ratqsmin>0.) THEN
-             sigma1s_ratqs = cloudth_ratqsmin*qt(ind1)
-           ELSE
-             sigma1s_ratqs = ratqs(ind1)*qt(ind1)
-           ENDIF
- 
-           sigma1s = sigma1s_fraca + sigma1s_ratqs
-           IF (iflag_ratqs.eq.11) then
-              sigma1s = ratqs(ind1)*qt(ind1)*aenv
-           ENDIF
-           sigma2s=(sigma2s_factor*(((sth-senv)**2)**0.5)/((frac_th(ind1)+0.02)**sigma2s_power))+0.002*qt_th(ind1)
-
-
-           deltasenv=aenv*vert_alpha*sigma1s
-           deltasth=ath*vert_alpha_th*sigma2s
-
-           xenv1=-(senv+deltasenv)/(sqrt(2.)*sigma1s)
-           xenv2=-(senv-deltasenv)/(sqrt(2.)*sigma1s)
-           exp_xenv1 = exp(-1.*xenv1**2)
-           exp_xenv2 = exp(-1.*xenv2**2)
-           xth1=-(sth+deltasth)/(sqrt(2.)*sigma2s)
-           xth2=-(sth-deltasth)/(sqrt(2.)*sigma2s)
-           exp_xth1 = exp(-1.*xth1**2)
-           exp_xth2 = exp(-1.*xth2**2)
-      
-!surface CF
-
-           cth(ind1)=0.5*(1.-1.*erf(xth1))
-           cenv(ind1)=0.5*(1.-1.*erf(xenv1))
-           ctot(ind1)=frac_th(ind1)*cth(ind1)+(1.-1.*frac_th(ind1))*cenv(ind1) 
-
-
-!volume CF, condensed water and ice fraction
-
-            !environnement
-
-            IntJ=0.5*senv*(1-erf(xenv2))+(sigma1s/sqrt2pi)*exp_xenv2
-            IntJ_CF=0.5*(1.-1.*erf(xenv2))
-
-            IF (deltasenv .LT. 1.e-10) THEN 
-              qcenv(ind1)=IntJ
-              cenv_vol(ind1)=IntJ_CF
-            ELSE
-              IntI1=(((senv+deltasenv)**2+(sigma1s)**2)/(8*deltasenv))*(erf(xenv2)-erf(xenv1))
-              IntI2=(sigma1s**2/(4*deltasenv*sqrtpi))*(xenv1*exp_xenv1-xenv2*exp_xenv2)
-              IntI3=((sqrt2*sigma1s*(senv+deltasenv))/(4*sqrtpi*deltasenv))*(exp_xenv1-exp_xenv2)
-              IntI1_CF=((senv+deltasenv)*(erf(xenv2)-erf(xenv1)))/(4*deltasenv)
-              IntI3_CF=(sqrt2*sigma1s*(exp_xenv1-exp_xenv2))/(4*sqrtpi*deltasenv)
-              qcenv(ind1)=IntJ+IntI1+IntI2+IntI3
-              cenv_vol(ind1)=IntJ_CF+IntI1_CF+IntI3_CF
-              IF (Tbefenv(ind1) .LT. temp_nowater) THEN
-                  ! freeze all droplets in cirrus temperature regime
-                  icefracenv(ind1)=1. 
-              ENDIF
-            ENDIF
-             
-
-
-            !thermals
-
-            IntJ=0.5*sth*(1-erf(xth2))+(sigma2s/sqrt2pi)*exp_xth2
-            IntJ_CF=0.5*(1.-1.*erf(xth2))
-     
-            IF (deltasth .LT. 1.e-10) THEN
-              qcth(ind1)=IntJ
-              cth_vol(ind1)=IntJ_CF
-            ELSE
-              IntI1=(((sth+deltasth)**2+(sigma2s)**2)/(8*deltasth))*(erf(xth2)-erf(xth1))
-              IntI2=(sigma2s**2/(4*deltasth*sqrtpi))*(xth1*exp_xth1-xth2*exp_xth2)
-              IntI3=((sqrt2*sigma2s*(sth+deltasth))/(4*sqrtpi*deltasth))*(exp_xth1-exp_xth2)
-              IntI1_CF=((sth+deltasth)*(erf(xth2)-erf(xth1)))/(4*deltasth)
-              IntI3_CF=(sqrt2*sigma2s*(exp_xth1-exp_xth2))/(4*sqrtpi*deltasth)
-              qcth(ind1)=IntJ+IntI1+IntI2+IntI3
-              cth_vol(ind1)=IntJ_CF+IntI1_CF+IntI3_CF
-              IF (Tbefth(ind1) .LT. temp_nowater) THEN
-                  ! freeze all droplets in cirrus temperature regime
-                  icefracth(ind1)=1.
-              ENDIF
-
-            ENDIF
-
-            qctot(ind1)=frac_th(ind1)*qcth(ind1)+(1.-1.*frac_th(ind1))*qcenv(ind1)
-            ctot_vol(ind1)=frac_th(ind1)*cth_vol(ind1)+(1.-1.*frac_th(ind1))*cenv_vol(ind1)
-
-            IF (cenv(ind1).LT.min_neb_th.and.cth(ind1).LT.min_neb_th) THEN
-                ctot(ind1)=0.
-                ctot_vol(ind1)=0.
-                qcloud(ind1)=qslenv(ind1)
-                qincloud(ind1)=0.
-                icefrac(ind1)=0.
-            ELSE               
-                qcloud(ind1)=qctot(ind1)/ctot(ind1)+qslenv(ind1)
-                qincloud(ind1)=qctot(ind1)/ctot(ind1)
-                IF (qctot(ind1) .GT. 0) THEN
-                  icefrac(ind1)=(frac_th(ind1)*qcth(ind1)*icefracth(ind1)+(1.-1.*frac_th(ind1))*qcenv(ind1)*icefracenv(ind1))/qctot(ind1)
-                  icefrac(ind1)=max(min(1.,icefrac(ind1)), 0.)
-                ENDIF
-            ENDIF 
-
-
-!        ELSE ! mpc_bl_points>0
-
-    ELSE  ! gaussian for environment only
-
-      
-        alenv=(0.622*RLVTT*qslenv(ind1))/(rd*thetal_env(ind1)**2)
-        aenv=1./(1.+(alenv*RLVTT/rcpd))
-        senv=aenv*(qt_env(ind1)-qslenv(ind1))
-        sth=0.
-        sigma1s=ratqs(ind1)*qt_env(ind1)
-        sigma2s=0.
-
-        xenv=senv/(sqrt(2.)*sigma1s)
-        cenv(ind1)=0.5*(1.-1.*erf(xenv))
-        ctot(ind1)=0.5*(1.+1.*erf(xenv))
-        ctot_vol(ind1)=ctot(ind1)
-        qctot(ind1)=sigma1s*((exp(-1.*xenv**2)/sqrt2pi)+xenv*sqrt(2.)*cenv(ind1))
-
-
-        IF (ctot(ind1).LT.min_neb_th) THEN
-          ctot(ind1)=0.
-          qcloud(ind1)=qslenv(ind1)
-          qincloud(ind1)=0.
-        ELSE 
-          qcloud(ind1)=qctot(ind1)/ctot(ind1)+qslenv(ind1)
-          qincloud(ind1)=MAX(qctot(ind1)/ctot(ind1),0.)
-        ENDIF
- 
-
-    ENDIF       ! From the separation (thermal/envrionnement) and (environnement only,) l.335 et l.492
-
-    ! Outputs used to check the PDFs
-    cloudth_senv(ind1) = senv
-    cloudth_sth(ind1) = sth
-    cloudth_sigmaenv(ind1) = sigma1s
-    cloudth_sigmath(ind1) = sigma2s
-
-
-    ENDDO       !loop on klon
-
-
-RETURN
-
-
-END SUBROUTINE cloudth_mpc
-
-
-
-!        ELSE ! mpc_bl_points>0
-!
-!            ! Treat boundary layer mixed phase clouds
-!            
-!            ! thermals
-!            !=========
-!
-!           ! ice phase
-!           !...........
-!
-!            qiceth=0.
-!            deltazlev_mpc=dz(ind1,:)
-!            temp_mpc=ztla(ind1,:)*zpspsk(ind1,:)
-!            pres_mpc=pplay(ind1,:)
-!            fraca_mpc=fraca(ind1,:)
-!            snowf_mpc=snowflux(ind1,:)
-!            iflag_topthermals=0
-!            IF ((mpc_bl_points(ind1,ind2) .EQ. 1) .AND. (mpc_bl_points(ind1,ind2+1) .EQ. 0))  THEN
-!                iflag_topthermals = 1
-!            ELSE IF ((mpc_bl_points(ind1,ind2) .EQ. 1) .AND. (mpc_bl_points(ind1,ind2+1) .EQ. 1) & 
-!                    .AND. (mpc_bl_points(ind1,ind2+2) .EQ. 0) ) THEN
-!                iflag_topthermals = 2
-!            ELSE 
-!                iflag_topthermals = 0
-!            ENDIF
-!
-!            CALL ICE_MPC_BL_CLOUDS(ind1,ind2,klev,Ni,Ei,C_cap,d_top,iflag_topthermals,temp_mpc,pres_mpc,zqta(ind1,:), &
-!                                   qsith(ind1,:),qlth(ind1,:),deltazlev_mpc,wiceth(ind1,:),fraca_mpc,qith(ind1,:))
-!
-!            ! qmax calculation
-!            sigma2s=(sigma2s_factor*((MAX((sthl-senvl),0.)**2)**0.5)/((fraca(ind1,ind2)+0.02)**sigma2s_power))+0.002*zqta(ind1,ind2)
-!            deltasth=athl*vert_alpha_th*sigma2s
-!            xth1=-(sthl+deltasth)/(sqrt(2.)*sigma2s)
-!            xth2=-(sthl-deltasth)/(sqrt(2.)*sigma2s)
-!            exp_xth1 = exp(-1.*xth1**2)
-!            exp_xth2 = exp(-1.*xth2**2)
-!            IntJ=0.5*sthl*(1-erf(xth2))+(sigma2s/sqrt2pi)*exp_xth2
-!            IntJ_CF=0.5*(1.-1.*erf(xth2))
-!            IntI1=(((sthl+deltasth)**2+(sigma2s)**2)/(8*deltasth))*(erf(xth2)-erf(xth1))
-!            IntI2=(sigma2s**2/(4*deltasth*sqrtpi))*(xth1*exp_xth1-xth2*exp_xth2)
-!            IntI3=((sqrt2*sigma2s*(sthl+deltasth))/(4*sqrtpi*deltasth))*(exp_xth1-exp_xth2)
-!            IntI1_CF=((sthl+deltasth)*(erf(xth2)-erf(xth1)))/(4*deltasth)
-!            IntI3_CF=(sqrt2*sigma2s*(exp_xth1-exp_xth2))/(4*sqrtpi*deltasth)
-!            qmax=MAX(IntJ+IntI1+IntI2+IntI3,0.)
-!
-!
-!            ! Liquid phase
-!            !................
-!            ! We account for the effect of ice crystals in thermals on sthl
-!            ! and on the width of the distribution
-!
-!            sthlc=sthl*1./(1.+C_mpc*qith(ind1,ind2))  &
-!                + (1.-1./(1.+C_mpc*qith(ind1,ind2))) * athl*(qsith(ind1,ind2)-qslth(ind1))  
-!
-!            sigma2sc=(sigma2s_factor*((MAX((sthlc-senvl),0.)**2)**0.5) &
-!                 /((fraca(ind1,ind2)+0.02)**sigma2s_power)) &
-!                 +0.002*zqta(ind1,ind2)
-!            deltasthc=athl*vert_alpha_th*sigma2sc
-!     
-!            
-!            xth1=-(sthlc+deltasthc)/(sqrt(2.)*sigma2sc)
-!            xth2=-(sthlc-deltasthc)/(sqrt(2.)*sigma2sc)           
-!            exp_xth1 = exp(-1.*xth1**2)
-!            exp_xth2 = exp(-1.*xth2**2)
-!            IntJ=0.5*sthlc*(1-erf(xth2))+(sigma2sc/sqrt2pi)*exp_xth2
-!            IntJ_CF=0.5*(1.-1.*erf(xth2))
-!            IntI1=(((sthlc+deltasthc)**2+(sigma2sc)**2)/(8*deltasthc))*(erf(xth2)-erf(xth1))
-!            IntI2=(sigma2sc**2/(4*deltasthc*sqrtpi))*(xth1*exp_xth1-xth2*exp_xth2)
-!            IntI3=((sqrt2*sigma2sc*(sthlc+deltasthc))/(4*sqrtpi*deltasthc))*(exp_xth1-exp_xth2)
-!            IntI1_CF=((sthlc+deltasthc)*(erf(xth2)-erf(xth1)))/(4*deltasthc)
-!            IntI3_CF=(sqrt2*sigma2sc*(exp_xth1-exp_xth2))/(4*sqrtpi*deltasthc)
-!            qliqth=IntJ+IntI1+IntI2+IntI3
-!            
-!            qlth(ind1,ind2)=MAX(0.,qliqth)
-!
-!            ! Condensed water
-!            
-!            qcth(ind1,ind2)=qlth(ind1,ind2)+qith(ind1,ind2)
-!
-!
-!            ! consistency with subgrid distribution
-!           
-!             IF ((qcth(ind1,ind2) .GT. qmax) .AND. (qcth(ind1,ind2) .GT. 0)) THEN
-!                 fraci=qith(ind1,ind2)/qcth(ind1,ind2)
-!                 qcth(ind1,ind2)=qmax
-!                 qith(ind1,ind2)=fraci*qmax
-!                 qlth(ind1,ind2)=(1.-fraci)*qmax
-!             ENDIF
-!
-!            ! Cloud Fraction
-!            !...............
-!            ! calculation of qbase which is the value of the water vapor within mixed phase clouds
-!            ! such that the total water in cloud = qbase+qliqth+qiceth
-!            ! sbase is the value of s such that int_sbase^\intfy s ds = cloud fraction
-!            ! sbase and qbase calculation (note that sbase is wrt liq so negative)
-!            ! look for an approximate solution with iteration
-!            
-!            ttarget=qcth(ind1,ind2)
-!            mini= athl*(qsith(ind1,ind2)-qslth(ind1))
-!            maxi= 0. !athl*(3.*sqrt(sigma2s))
-!            niter=20
-!            pas=(maxi-mini)/niter
-!            stmp=mini
-!            sbase=stmp
-!            coutref=1.E6
-!            DO iter=1,niter
-!                cout=ABS(sigma2s/SQRT(2.*RPI)*EXP(-((sthl-stmp)/sigma2s)**2)+(sthl-stmp)/SQRT(2.)*(1.-erf(-(sthl-stmp)/sigma2s)) &
-!                     + stmp/2.*(1.-erf(-(sthl-stmp)/sigma2s)) -ttarget)
-!               IF (cout .LT. coutref) THEN
-!                     sbase=stmp
-!                     coutref=cout
-!                ELSE
-!                     stmp=stmp+pas
-!                ENDIF
-!            ENDDO
-!            qbase=MAX(0., sbase/athl+qslth(ind1))
-!
-!            ! surface cloud fraction in thermals
-!            cth(ind1,ind2)=0.5*(1.-erf((sbase-sthl)/sqrt(2.)/sigma2s))
-!            cth(ind1,ind2)=MIN(MAX(cth(ind1,ind2),0.),1.)
-!
-!
-!            !volume cloud fraction in thermals
-!            !to be checked
-!            xth1=-(sthl+deltasth-sbase)/(sqrt(2.)*sigma2s)
-!            xth2=-(sthl-deltasth-sbase)/(sqrt(2.)*sigma2s)           
-!            exp_xth1 = exp(-1.*xth1**2)
-!            exp_xth2 = exp(-1.*xth2**2)
-!
-!            IntJ=0.5*sthl*(1-erf(xth2))+(sigma2s/sqrt2pi)*exp_xth2
-!            IntJ_CF=0.5*(1.-1.*erf(xth2))
-!     
-!            IF (deltasth .LT. 1.e-10) THEN
-!              cth_vol(ind1,ind2)=IntJ_CF
-!            ELSE
-!              IntI1=(((sthl+deltasth-sbase)**2+(sigma2s)**2)/(8*deltasth))*(erf(xth2)-erf(xth1))
-!              IntI2=(sigma2s**2/(4*deltasth*sqrtpi))*(xth1*exp_xth1-xth2*exp_xth2)
-!              IntI3=((sqrt2*sigma2s*(sthl+deltasth))/(4*sqrtpi*deltasth))*(exp_xth1-exp_xth2)
-!              IntI1_CF=((sthl-sbase+deltasth)*(erf(xth2)-erf(xth1)))/(4*deltasth)
-!              IntI3_CF=(sqrt2*sigma2s*(exp_xth1-exp_xth2))/(4*sqrtpi*deltasth)
-!              cth_vol(ind1,ind2)=IntJ_CF+IntI1_CF+IntI3_CF
-!            ENDIF
-!              cth_vol(ind1,ind2)=MIN(MAX(0.,cth_vol(ind1,ind2)),1.)
-!
-!
-!
-!            ! Environment
-!            !=============
-!            ! In the environment/downdrafts, only liquid clouds
-!            ! See Shupe et al. 2008, JAS
-!
-!            ! standard deviation of the distribution in the environment
-!            sth=sthl
-!            senv=senvl
-!            sigma1s_fraca = (sigma1s_factor**0.5)*(fraca(ind1,ind2)**sigma1s_power) / &
-!                          &                (1-fraca(ind1,ind2))*(MAX((sth-senv),0.)**2)**0.5
-!            ! for mixed phase clouds, there is no contribution from large scale ratqs to the distribution
-!            ! in the environement
-!
-!            sigma1s_ratqs=1E-10
-!            IF (cloudth_ratqsmin>0.) THEN
-!                sigma1s_ratqs = cloudth_ratqsmin*po(ind1)
-!            ENDIF
-!
-!            sigma1s = sigma1s_fraca + sigma1s_ratqs
-!            IF (iflag_ratqs.eq.11) then
-!               sigma1s = ratqs(ind1,ind2)*po(ind1)*aenv
-!            ENDIF
-!            IF (iflag_ratqs.eq.11) then
-!              sigma1s = ratqs(ind1,ind2)*po(ind1)*aenvl
-!            ENDIF
-!            deltasenv=aenvl*vert_alpha*sigma1s
-!            xenv1=-(senvl+deltasenv)/(sqrt(2.)*sigma1s)
-!            xenv2=-(senvl-deltasenv)/(sqrt(2.)*sigma1s)
-!            exp_xenv1 = exp(-1.*xenv1**2)
-!            exp_xenv2 = exp(-1.*xenv2**2)
-!
-!            !surface CF
-!            cenv(ind1,ind2)=0.5*(1.-1.*erf(xenv1))
-!
-!            !volume CF and condensed water
-!            IntJ=0.5*senvl*(1-erf(xenv2))+(sigma1s/sqrt2pi)*exp_xenv2
-!            IntJ_CF=0.5*(1.-1.*erf(xenv2))
-!
-!            IF (deltasenv .LT. 1.e-10) THEN
-!              qcenv(ind1,ind2)=IntJ
-!              cenv_vol(ind1,ind2)=IntJ_CF
-!            ELSE
-!              IntI1=(((senvl+deltasenv)**2+(sigma1s)**2)/(8*deltasenv))*(erf(xenv2)-erf(xenv1))
-!              IntI2=(sigma1s**2/(4*deltasenv*sqrtpi))*(xenv1*exp_xenv1-xenv2*exp_xenv2)
-!              IntI3=((sqrt2*sigma1s*(senv+deltasenv))/(4*sqrtpi*deltasenv))*(exp_xenv1-exp_xenv2)
-!              IntI1_CF=((senvl+deltasenv)*(erf(xenv2)-erf(xenv1)))/(4*deltasenv)
-!              IntI3_CF=(sqrt2*sigma1s*(exp_xenv1-exp_xenv2))/(4*sqrtpi*deltasenv)
-!              qcenv(ind1,ind2)=IntJ+IntI1+IntI2+IntI3 ! only liquid water in environment
-!              cenv_vol(ind1,ind2)=IntJ_CF+IntI1_CF+IntI3_CF
-!            ENDIF
-!
-!            qcenv(ind1,ind2)=MAX(qcenv(ind1,ind2),0.)
-!            cenv_vol(ind1,ind2)=MIN(MAX(cenv_vol(ind1,ind2),0.),1.)
-!
-!
-!            
-!            ! Thermals + environment
-!            ! ======================= 
-!            ctot(ind1,ind2)=fraca(ind1,ind2)*cth(ind1,ind2)+(1.-1.*fraca(ind1,ind2))*cenv(ind1,ind2) 
-!            qctot(ind1,ind2)=fraca(ind1,ind2)*qcth(ind1,ind2)+(1.-1.*fraca(ind1,ind2))*qcenv(ind1,ind2)
-!            ctot_vol(ind1,ind2)=fraca(ind1,ind2)*cth_vol(ind1,ind2)+(1.-1.*fraca(ind1,ind2))*cenv_vol(ind1,ind2)
-!            IF (qcth(ind1,ind2) .GT. 0) THEN
-!               icefrac(ind1,ind2)=fraca(ind1,ind2)*qith(ind1,ind2) &
-!                    /(fraca(ind1,ind2)*qcth(ind1,ind2) &
-!                    +(1.-1.*fraca(ind1,ind2))*qcenv(ind1,ind2))
-!                icefrac(ind1,ind2)=MAX(MIN(1.,icefrac(ind1,ind2)),0.)
-!            ELSE
-!                icefrac(ind1,ind2)=0.
-!            ENDIF
-!
-!            IF (cenv(ind1,ind2).LT.1.e-10.or.cth(ind1,ind2).LT.1.e-10) THEN
-!                ctot(ind1,ind2)=0.
-!                ctot_vol(ind1,ind2)=0.
-!                qincloud(ind1)=0.
-!                qcloud(ind1)=zqsatenv(ind1)
-!            ELSE               
-!                qcloud(ind1)=fraca(ind1,ind2)*(qcth(ind1,ind2)/cth(ind1,ind2)+qbase) &
-!                            +(1.-1.*fraca(ind1,ind2))*(qcenv(ind1,ind2)/cenv(ind1,ind2)+qslenv(ind1))
-!                qincloud(ind1)=MAX(fraca(ind1,ind2)*(qcth(ind1,ind2)/cth(ind1,ind2)) &
-!                            +(1.-1.*fraca(ind1,ind2))*(qcenv(ind1,ind2)/cenv(ind1,ind2)),0.)
-!            ENDIF 
-!
-!        ENDIF ! mpc_bl_points
-
-
-
-!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-SUBROUTINE ICE_MPC_BL_CLOUDS(ind1,ind2,klev,Ni,Ei,C_cap,d_top,iflag_topthermals,temp,pres,qth,qsith,qlth,deltazlev,vith,fraca,qith)
-
-! parameterization of ice for boundary
-! layer mixed-phase clouds assuming a stationary system
-!
-! Note that vapor deposition on ice crystals and riming of liquid droplets
-! depend on the ice number concentration Ni
-! One could assume that Ni depends on qi, e.g.,  Ni=beta*(qi*rho)**xi
-! and use values from Hong et al. 2004, MWR for instance
-! One may also estimate Ni as a function of T, as in Meyers 1922 or Fletcher 1962 
-! One could also think of a more complex expression of Ni;
-! function of qi, T, the concentration in aerosols or INP ..
-! Here we prefer fixing Ni to a tuning parameter
-! By default we take 2.0L-1=2.0e3m-3, median value from measured vertical profiles near Svalbard
-! in Mioche et al. 2017
-!
-!
-! References:
-!------------
-! This parameterization is thoroughly described in Vignon et al. 
-!
-! More specifically
-! for the Water vapor deposition process:
-!
-! Rotstayn, L. D., 1997: A physically based scheme for the treat-
-! ment of stratiform cloudfs and precipitation in large-scale
-! models. I: Description and evaluation of the microphysical
-! processes. Quart. J. Roy. Meteor. Soc., 123, 1227–1282.
-!
-!  Morrison, H., and A. Gettelman, 2008: A new two-moment bulk
-!  stratiform cloud microphysics scheme in the NCAR Com-
-!  munity Atmosphere Model (CAM3). Part I: Description and
-!  numerical tests. J. Climate, 21, 3642–3659
-!
-! for the Riming process:
-!
-! Rutledge, S. A., and P. V. Hobbs, 1983: The mesoscale and micro-
-! scale structure and organization of clouds and precipitation in
-! midlatitude cyclones. VII: A model for the ‘‘seeder-feeder’’
-! process in warm-frontal rainbands. J. Atmos. Sci., 40, 1185–1206
-!
-! Thompson, G., R. M. Rasmussen, and K. Manning, 004: Explicit
-! forecasts of winter precipitation using an improved bulk
-! microphysics scheme. Part I: Description and sensitivityThompson, G., R. M. Rasmussen, and K. Manning, 2004: Explicit
-! forecasts of winter precipitation using an improved bulk
-! microphysics scheme. Part I: Description and sensitivity analysis. Mon. Wea. Rev., 132, 519–542
-!
-! For the formation of clouds by thermals:
-!
-! Rio, C., & Hourdin, F. (2008). A thermal plume model for the convective boundary layer : Representation of cumulus clouds. Journal of
-! the Atmospheric Sciences, 65, 407–425.
-!
-! Jam, A., Hourdin, F., Rio, C., & Couvreux, F. (2013). Resolved versus parametrized boundary-layer plumes. Part III: Derivation of a
-! statistical scheme for cumulus clouds. Boundary-layer Meteorology, 147, 421–441. https://doi.org/10.1007/s10546-012-9789-3
-!
-!
-!
-! Contact: Etienne Vignon, etienne.vignon@lmd.ipsl.fr
-!=============================================================================
-
-    use phys_state_var_mod, ONLY : fm_therm, detr_therm, entr_therm
-
-    IMPLICIT none
-
-    INCLUDE "YOMCST.h"
-
-    INTEGER, INTENT(IN) :: ind1,ind2, klev           ! horizontal and vertical indices and dimensions
-    INTEGER, INTENT(IN) :: iflag_topthermals         ! uppermost layer of thermals ?
-    REAL, INTENT(IN)    :: Ni                        ! ice number concentration [m-3]
-    REAL, INTENT(IN)    :: Ei                        ! ice-droplet collision efficiency
-    REAL, INTENT(IN)    :: C_cap                     ! ice crystal capacitance
-    REAL, INTENT(IN)    :: d_top                     ! cloud-top ice crystal mixing parameter
-    REAL,  DIMENSION(klev), INTENT(IN) :: temp       ! temperature [K] within thermals
-    REAL,  DIMENSION(klev), INTENT(IN) :: pres       ! pressure [Pa]
-    REAL,  DIMENSION(klev), INTENT(IN) :: qth        ! mean specific water content in thermals [kg/kg]
-    REAL,  DIMENSION(klev), INTENT(IN) :: qsith        ! saturation specific humidity wrt ice in thermals [kg/kg]
-    REAL,  DIMENSION(klev), INTENT(IN) :: qlth       ! condensed liquid water in thermals, approximated value [kg/kg]
-    REAL,  DIMENSION(klev), INTENT(IN) :: deltazlev  ! layer thickness [m]
-    REAL,  DIMENSION(klev), INTENT(IN) :: vith       ! ice crystal fall velocity [m/s]
-    REAL,  DIMENSION(klev+1), INTENT(IN) :: fraca      ! fraction of the mesh covered by thermals
-    REAL,  DIMENSION(klev), INTENT(INOUT) :: qith       ! condensed ice water , thermals [kg/kg]
-
-
-    INTEGER ind2p1,ind2p2
-    REAL rho(klev)
-    REAL unsurtaudet, unsurtaustardep, unsurtaurim
-    REAL qi, AA, BB, Ka, Dv, rhoi
-    REAL p0, t0, fp1, fp2
-    REAL alpha, flux_term
-    REAL det_term, precip_term, rim_term, dep_term
-
-
-    ind2p1=ind2+1
-    ind2p2=ind2+2
-
-    rho=pres/temp/RD  ! air density kg/m3
-
-    Ka=2.4e-2      ! thermal conductivity of the air, SI
-    p0=101325.0    ! ref pressure
-    T0=273.15      ! ref temp
-    rhoi=500.0     ! cloud ice density following Reisner et al. 1998
-    alpha=700.     ! fallvelocity param
-
-
-    IF (iflag_topthermals .GT. 0) THEN ! uppermost thermals levels
-
-    Dv=0.0001*0.211*(p0/pres(ind2))*((temp(ind2)/T0)**1.94) ! water vapor diffusivity in air, SI
-
-    ! Detrainment term:
-
-    unsurtaudet=detr_therm(ind1,ind2)/rho(ind2)/deltazlev(ind2)
- 
-
-    ! Deposition term
-    AA=RLSTT/Ka/temp(ind2)*(RLSTT/RV/temp(ind2)-1.)
-    BB=1./(rho(ind2)*Dv*qsith(ind2))
-    unsurtaustardep=C_cap*(Ni**0.66)*(qth(ind2)-qsith(ind2))/qsith(ind2) &
-                    *4.*RPI/(AA+BB)*(6.*rho(ind2)/rhoi/RPI/Gamma(4.))**(0.33)
-
-    ! Riming term  neglected at this level
-    !unsurtaurim=rho(ind2)*alpha*3./rhoi/2.*Ei*qlth(ind2)*((p0/pres(ind2))**0.4)
-
-    qi=fraca(ind2)*unsurtaustardep/MAX((d_top*unsurtaudet),1E-12)
-    qi=MAX(qi,0.)**(3./2.)
-
-    ELSE ! other levels, estimate qi(k) from variables at k+1 and k+2
-
-    Dv=0.0001*0.211*(p0/pres(ind2p1))*((temp(ind2p1)/T0)**1.94) ! water vapor diffusivity in air, SI
-
-    ! Detrainment term:
-
-    unsurtaudet=detr_therm(ind1,ind2p1)/rho(ind2p1)/deltazlev(ind2p1)
-    det_term=-unsurtaudet*qith(ind2p1)*rho(ind2p1)
-    
-    
-    ! Deposition term
-
-    AA=RLSTT/Ka/temp(ind2p1)*(RLSTT/RV/temp(ind2p1)-1.)
-    BB=1./(rho(ind2p1)*Dv*qsith(ind2p1))
-    unsurtaustardep=C_cap*(Ni**0.66)*(qth(ind2p1)-qsith(ind2p1)) &
-         /qsith(ind2p1)*4.*RPI/(AA+BB) &
-         *(6.*rho(ind2p1)/rhoi/RPI/Gamma(4.))**(0.33)
-    dep_term=rho(ind2p1)*fraca(ind2p1)*(qith(ind2p1)**0.33)*unsurtaustardep
- 
-    ! Riming term
-
-    unsurtaurim=rho(ind2p1)*alpha*3./rhoi/2.*Ei*qlth(ind2p1)*((p0/pres(ind2p1))**0.4)
-    rim_term=rho(ind2p1)*fraca(ind2p1)*qith(ind2p1)*unsurtaurim
-
-    ! Precip term
-
-    ! We assume that there is no solid precipitation outside thermals 
-    ! so the precipitation flux within thermals is equal to the precipitation flux
-    ! at mesh-scale divided by  thermals fraction
-    
-    fp2=0.
-    fp1=0.
-    IF (fraca(ind2p1) .GT. 0.) THEN
-    fp2=-qith(ind2p2)*rho(ind2p2)*vith(ind2p2)*fraca(ind2p2)! flux defined positive upward
-    fp1=-qith(ind2p1)*rho(ind2p1)*vith(ind2p1)*fraca(ind2p1)
-    ENDIF
-
-    precip_term=-1./deltazlev(ind2p1)*(fp2-fp1)
-
-    ! Calculation in a top-to-bottom loop
-
-    IF (fm_therm(ind1,ind2p1) .GT. 0.) THEN
-          qi= 1./fm_therm(ind1,ind2p1)* &
-              (deltazlev(ind2p1)*(-rim_term-dep_term-det_term-precip_term) + &
-              fm_therm(ind1,ind2p2)*(qith(ind2p1)))
-    END IF
-
-    ENDIF ! top thermals
-
-    qith(ind2)=MAX(0.,qi)
-
-    RETURN
-
-END SUBROUTINE ICE_MPC_BL_CLOUDS
-
-END MODULE lmdz_cloudth
Index: /LMDZ6/trunk/libf/phylmd/lmdz_cloudth.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/lmdz_cloudth.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/lmdz_cloudth.f90	(revision 5268)
@@ -0,0 +1,2260 @@
+MODULE lmdz_cloudth
+
+
+  IMPLICIT NONE
+
+CONTAINS
+
+       SUBROUTINE cloudth(ngrid,klev,ind2,  &
+     &           ztv,po,zqta,fraca, & 
+     &           qcloud,ctot,zpspsk,paprs,pplay,ztla,zthl, &
+     &           ratqs,zqs,t, &
+     &           cloudth_sth,cloudth_senv,cloudth_sigmath,cloudth_sigmaenv)
+
+
+      use lmdz_cloudth_ini, only: iflag_cloudth_vert,iflag_ratqs
+
+      IMPLICIT NONE
+
+
+!===========================================================================
+! Auteur : Arnaud Octavio Jam (LMD/CNRS)
+! Date : 25 Mai 2010
+! Objet : calcule les valeurs de qc et rneb dans les thermiques
+!===========================================================================
+
+
+      INCLUDE "YOMCST.h"
+      INCLUDE "YOETHF.h"
+      INCLUDE "FCTTRE.h"
+
+      INTEGER itap,ind1,ind2
+      INTEGER ngrid,klev,klon,l,ig 
+      real, dimension(ngrid,klev), intent(out) :: cloudth_sth,cloudth_senv,cloudth_sigmath,cloudth_sigmaenv
+      
+      REAL ztv(ngrid,klev)
+      REAL po(ngrid)
+      REAL zqenv(ngrid)   
+      REAL zqta(ngrid,klev)
+          
+      REAL fraca(ngrid,klev+1)
+      REAL zpspsk(ngrid,klev)
+      REAL paprs(ngrid,klev+1)
+      REAL pplay(ngrid,klev)
+      REAL ztla(ngrid,klev)
+      REAL zthl(ngrid,klev)
+
+      REAL zqsatth(ngrid,klev)
+      REAL zqsatenv(ngrid,klev)
+      
+      
+      REAL sigma1(ngrid,klev)
+      REAL sigma2(ngrid,klev)
+      REAL qlth(ngrid,klev)
+      REAL qlenv(ngrid,klev)
+      REAL qltot(ngrid,klev) 
+      REAL cth(ngrid,klev)  
+      REAL cenv(ngrid,klev)   
+      REAL ctot(ngrid,klev)
+      REAL rneb(ngrid,klev)
+      REAL t(ngrid,klev)
+      REAL qsatmmussig1,qsatmmussig2,sqrt2pi,pi
+      REAL rdd,cppd,Lv
+      REAL alth,alenv,ath,aenv
+      REAL sth,senv,sigma1s,sigma2s,xth,xenv
+      REAL Tbef,zdelta,qsatbef,zcor
+      REAL qlbef  
+      REAL ratqs(ngrid,klev) ! determine la largeur de distribution de vapeur
+      
+      REAL zpdf_sig(ngrid),zpdf_k(ngrid),zpdf_delta(ngrid)
+      REAL zpdf_a(ngrid),zpdf_b(ngrid),zpdf_e1(ngrid),zpdf_e2(ngrid) 
+      REAL zqs(ngrid), qcloud(ngrid)
+      REAL erf
+
+
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! Gestion de deux versions de cloudth
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+      IF (iflag_cloudth_vert.GE.1) THEN
+      CALL cloudth_vert(ngrid,klev,ind2,  &
+     &           ztv,po,zqta,fraca, & 
+     &           qcloud,ctot,zpspsk,paprs,pplay,ztla,zthl, &
+     &           ratqs,zqs,t)
+      RETURN
+      ENDIF
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+
+!-------------------------------------------------------------------------------
+! Initialisation des variables r?elles
+!-------------------------------------------------------------------------------
+      sigma1(:,:)=0.
+      sigma2(:,:)=0.
+      qlth(:,:)=0.
+      qlenv(:,:)=0.  
+      qltot(:,:)=0.
+      rneb(:,:)=0.
+      qcloud(:)=0.
+      cth(:,:)=0.
+      cenv(:,:)=0.
+      ctot(:,:)=0.
+      qsatmmussig1=0.
+      qsatmmussig2=0.
+      rdd=287.04
+      cppd=1005.7
+      pi=3.14159 
+      Lv=2.5e6
+      sqrt2pi=sqrt(2.*pi)
+
+
+
+!-------------------------------------------------------------------------------
+! Calcul de la fraction du thermique et des ?cart-types des distributions
+!-------------------------------------------------------------------------------                 
+      do ind1=1,ngrid
+
+      if ((ztv(ind1,1).gt.ztv(ind1,2)).and.(fraca(ind1,ind2).gt.1.e-10)) then 
+
+      zqenv(ind1)=(po(ind1)-fraca(ind1,ind2)*zqta(ind1,ind2))/(1.-fraca(ind1,ind2))
+
+
+!      zqenv(ind1)=po(ind1)
+      Tbef=zthl(ind1,ind2)*zpspsk(ind1,ind2)
+      zdelta=MAX(0.,SIGN(1.,RTT-Tbef))
+      qsatbef= R2ES * FOEEW(Tbef,zdelta)/paprs(ind1,ind2)
+      qsatbef=MIN(0.5,qsatbef)
+      zcor=1./(1.-retv*qsatbef)
+      qsatbef=qsatbef*zcor
+      zqsatenv(ind1,ind2)=qsatbef
+
+
+
+
+      alenv=(0.622*Lv*zqsatenv(ind1,ind2))/(rdd*zthl(ind1,ind2)**2)  
+      aenv=1./(1.+(alenv*Lv/cppd))
+      senv=aenv*(po(ind1)-zqsatenv(ind1,ind2)) 
+
+
+
+
+      Tbef=ztla(ind1,ind2)*zpspsk(ind1,ind2)
+      zdelta=MAX(0.,SIGN(1.,RTT-Tbef))
+      qsatbef= R2ES * FOEEW(Tbef,zdelta)/paprs(ind1,ind2)
+      qsatbef=MIN(0.5,qsatbef)
+      zcor=1./(1.-retv*qsatbef)
+      qsatbef=qsatbef*zcor
+      zqsatth(ind1,ind2)=qsatbef
+            
+      alth=(0.622*Lv*zqsatth(ind1,ind2))/(rdd*ztla(ind1,ind2)**2)   
+      ath=1./(1.+(alth*Lv/cppd))
+      sth=ath*(zqta(ind1,ind2)-zqsatth(ind1,ind2)) 
+      
+      
+
+!------------------------------------------------------------------------------
+! Calcul des ?cart-types pour s
+!------------------------------------------------------------------------------
+
+!      sigma1s=(1.1**0.5)*(fraca(ind1,ind2)**0.6)/(1-fraca(ind1,ind2))*((sth-senv)**2)**0.5+ratqs(ind1,ind2)*po(ind1)
+!      sigma2s=0.11*((sth-senv)**2)**0.5/(fraca(ind1,ind2)+0.02)**0.4+0.002*zqta(ind1,ind2) 
+!       if (paprs(ind1,ind2).gt.90000) then
+!       ratqs(ind1,ind2)=0.002
+!       else 
+!       ratqs(ind1,ind2)=0.002+0.0*(90000-paprs(ind1,ind2))/20000
+!       endif
+       sigma1s=(1.1**0.5)*(fraca(ind1,ind2)**0.6)/(1-fraca(ind1,ind2))*((sth-senv)**2)**0.5+0.002*po(ind1)
+       sigma2s=0.11*((sth-senv)**2)**0.5/(fraca(ind1,ind2)+0.01)**0.4+0.002*zqta(ind1,ind2) 
+!       sigma1s=ratqs(ind1,ind2)*po(ind1)
+!      sigma2s=0.11*((sth-senv)**2)**0.5/(fraca(ind1,ind2)+0.02)**0.4+0.00003  
+ 
+!------------------------------------------------------------------------------
+! Calcul de l'eau condens?e et de la couverture nuageuse
+!------------------------------------------------------------------------------
+      sqrt2pi=sqrt(2.*pi)
+      xth=sth/(sqrt(2.)*sigma2s)
+      xenv=senv/(sqrt(2.)*sigma1s)
+      cth(ind1,ind2)=0.5*(1.+1.*erf(xth))
+      cenv(ind1,ind2)=0.5*(1.+1.*erf(xenv)) 
+      ctot(ind1,ind2)=fraca(ind1,ind2)*cth(ind1,ind2)+(1.-1.*fraca(ind1,ind2))*cenv(ind1,ind2)   
+
+      qlth(ind1,ind2)=sigma2s*((exp(-1.*xth**2)/sqrt2pi)+xth*sqrt(2.)*cth(ind1,ind2))
+      qlenv(ind1,ind2)=sigma1s*((exp(-1.*xenv**2)/sqrt2pi)+xenv*sqrt(2.)*cenv(ind1,ind2))   
+      qltot(ind1,ind2)=fraca(ind1,ind2)*qlth(ind1,ind2)+(1.-1.*fraca(ind1,ind2))*qlenv(ind1,ind2)
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+      if (ctot(ind1,ind2).lt.1.e-10) then
+      ctot(ind1,ind2)=0.
+      qcloud(ind1)=zqsatenv(ind1,ind2) 
+
+      else   
+                
+      ctot(ind1,ind2)=ctot(ind1,ind2) 
+      qcloud(ind1)=qltot(ind1,ind2)/ctot(ind1,ind2)+zqs(ind1)
+
+      endif                           
+      
+          
+!     print*,sth,sigma2s,qlth(ind1,ind2),ctot(ind1,ind2),qltot(ind1,ind2),'verif'
+
+
+      else  ! gaussienne environnement seule
+      
+      zqenv(ind1)=po(ind1)
+      Tbef=t(ind1,ind2)
+      zdelta=MAX(0.,SIGN(1.,RTT-Tbef))
+      qsatbef= R2ES * FOEEW(Tbef,zdelta)/paprs(ind1,ind2)
+      qsatbef=MIN(0.5,qsatbef)
+      zcor=1./(1.-retv*qsatbef)
+      qsatbef=qsatbef*zcor
+      zqsatenv(ind1,ind2)=qsatbef
+      
+
+!      qlbef=Max(po(ind1)-zqsatenv(ind1,ind2),0.)
+      zthl(ind1,ind2)=t(ind1,ind2)*(101325/paprs(ind1,ind2))**(rdd/cppd)
+      alenv=(0.622*Lv*zqsatenv(ind1,ind2))/(rdd*zthl(ind1,ind2)**2)  
+      aenv=1./(1.+(alenv*Lv/cppd))
+      senv=aenv*(po(ind1)-zqsatenv(ind1,ind2)) 
+      
+
+      sigma1s=ratqs(ind1,ind2)*zqenv(ind1)
+
+      sqrt2pi=sqrt(2.*pi)
+      xenv=senv/(sqrt(2.)*sigma1s)
+      ctot(ind1,ind2)=0.5*(1.+1.*erf(xenv))
+      qltot(ind1,ind2)=sigma1s*((exp(-1.*xenv**2)/sqrt2pi)+xenv*sqrt(2.)*cenv(ind1,ind2))
+      
+      if (ctot(ind1,ind2).lt.1.e-3) then
+      ctot(ind1,ind2)=0.
+      qcloud(ind1)=zqsatenv(ind1,ind2) 
+
+      else   
+                
+      ctot(ind1,ind2)=ctot(ind1,ind2) 
+      qcloud(ind1)=qltot(ind1,ind2)/ctot(ind1,ind2)+zqsatenv(ind1,ind2)
+
+      endif    
+ 
+ 
+ 
+ 
+ 
+ 
+      endif   
+      enddo
+     
+      return
+!     end
+END SUBROUTINE cloudth
+
+
+
+!===========================================================================
+     SUBROUTINE cloudth_vert(ngrid,klev,ind2,  &
+     &           ztv,po,zqta,fraca, & 
+     &           qcloud,ctot,zpspsk,paprs,pplay,ztla,zthl, &
+     &           ratqs,zqs,t)
+
+!===========================================================================
+! Auteur : Arnaud Octavio Jam (LMD/CNRS)
+! Date : 25 Mai 2010
+! Objet : calcule les valeurs de qc et rneb dans les thermiques
+!===========================================================================
+
+
+      use lmdz_cloudth_ini, only: iflag_cloudth_vert, vert_alpha
+
+      IMPLICIT NONE
+
+      INCLUDE "YOMCST.h"
+      INCLUDE "YOETHF.h"
+      INCLUDE "FCTTRE.h"
+      
+      INTEGER itap,ind1,ind2
+      INTEGER ngrid,klev,klon,l,ig 
+      
+      REAL ztv(ngrid,klev)
+      REAL po(ngrid)
+      REAL zqenv(ngrid)   
+      REAL zqta(ngrid,klev)
+          
+      REAL fraca(ngrid,klev+1)
+      REAL zpspsk(ngrid,klev)
+      REAL paprs(ngrid,klev+1)
+      REAL pplay(ngrid,klev)
+      REAL ztla(ngrid,klev)
+      REAL zthl(ngrid,klev)
+
+      REAL zqsatth(ngrid,klev)
+      REAL zqsatenv(ngrid,klev)
+      
+      
+      REAL sigma1(ngrid,klev)                                                         
+      REAL sigma2(ngrid,klev)
+      REAL qlth(ngrid,klev)
+      REAL qlenv(ngrid,klev)
+      REAL qltot(ngrid,klev) 
+      REAL cth(ngrid,klev)  
+      REAL cenv(ngrid,klev)   
+      REAL ctot(ngrid,klev)
+      REAL rneb(ngrid,klev)
+      REAL t(ngrid,klev)                                                                  
+      REAL qsatmmussig1,qsatmmussig2,sqrt2pi,pi
+      REAL rdd,cppd,Lv,sqrt2,sqrtpi
+      REAL alth,alenv,ath,aenv
+      REAL sth,senv,sigma1s,sigma2s,xth,xenv
+      REAL xth1,xth2,xenv1,xenv2,deltasth, deltasenv
+      REAL IntJ,IntI1,IntI2,IntI3,coeffqlenv,coeffqlth
+      REAL Tbef,zdelta,qsatbef,zcor
+      REAL qlbef  
+      REAL ratqs(ngrid,klev) ! determine la largeur de distribution de vapeur
+      ! Change the width of the PDF used for vertical subgrid scale heterogeneity
+      ! (J Jouhaud, JL Dufresne, JB Madeleine)
+      
+      REAL zpdf_sig(ngrid),zpdf_k(ngrid),zpdf_delta(ngrid)
+      REAL zpdf_a(ngrid),zpdf_b(ngrid),zpdf_e1(ngrid),zpdf_e2(ngrid) 
+      REAL zqs(ngrid), qcloud(ngrid)
+      REAL erf
+
+!------------------------------------------------------------------------------
+! Initialisation des variables r?elles
+!------------------------------------------------------------------------------
+      sigma1(:,:)=0.
+      sigma2(:,:)=0.
+      qlth(:,:)=0.
+      qlenv(:,:)=0.  
+      qltot(:,:)=0.
+      rneb(:,:)=0.
+      qcloud(:)=0.
+      cth(:,:)=0.
+      cenv(:,:)=0.
+      ctot(:,:)=0.
+      qsatmmussig1=0.
+      qsatmmussig2=0.
+      rdd=287.04
+      cppd=1005.7
+      pi=3.14159 
+      Lv=2.5e6
+      sqrt2pi=sqrt(2.*pi)
+      sqrt2=sqrt(2.)
+      sqrtpi=sqrt(pi)
+
+!-------------------------------------------------------------------------------
+! Calcul de la fraction du thermique et des ?cart-types des distributions
+!-------------------------------------------------------------------------------                 
+      do ind1=1,ngrid
+
+      if ((ztv(ind1,1).gt.ztv(ind1,2)).and.(fraca(ind1,ind2).gt.1.e-10)) then 
+
+      zqenv(ind1)=(po(ind1)-fraca(ind1,ind2)*zqta(ind1,ind2))/(1.-fraca(ind1,ind2))
+
+
+!      zqenv(ind1)=po(ind1)
+      Tbef=zthl(ind1,ind2)*zpspsk(ind1,ind2)
+      zdelta=MAX(0.,SIGN(1.,RTT-Tbef))
+      qsatbef= R2ES * FOEEW(Tbef,zdelta)/paprs(ind1,ind2)
+      qsatbef=MIN(0.5,qsatbef)
+      zcor=1./(1.-retv*qsatbef)
+      qsatbef=qsatbef*zcor
+      zqsatenv(ind1,ind2)=qsatbef
+
+
+
+
+      alenv=(0.622*Lv*zqsatenv(ind1,ind2))/(rdd*zthl(ind1,ind2)**2)  
+      aenv=1./(1.+(alenv*Lv/cppd))
+      senv=aenv*(po(ind1)-zqsatenv(ind1,ind2)) 
+
+
+
+
+      Tbef=ztla(ind1,ind2)*zpspsk(ind1,ind2)
+      zdelta=MAX(0.,SIGN(1.,RTT-Tbef))
+      qsatbef= R2ES * FOEEW(Tbef,zdelta)/paprs(ind1,ind2)
+      qsatbef=MIN(0.5,qsatbef)
+      zcor=1./(1.-retv*qsatbef)
+      qsatbef=qsatbef*zcor
+      zqsatth(ind1,ind2)=qsatbef
+            
+      alth=(0.622*Lv*zqsatth(ind1,ind2))/(rdd*ztla(ind1,ind2)**2)   
+      ath=1./(1.+(alth*Lv/cppd))
+      sth=ath*(zqta(ind1,ind2)-zqsatth(ind1,ind2)) 
+      
+      
+
+!------------------------------------------------------------------------------
+! Calcul des ?cart-types pour s
+!------------------------------------------------------------------------------
+
+      sigma1s=(0.92**0.5)*(fraca(ind1,ind2)**0.5)/(1-fraca(ind1,ind2))*((sth-senv)**2)**0.5+ratqs(ind1,ind2)*po(ind1)
+      sigma2s=0.09*((sth-senv)**2)**0.5/(fraca(ind1,ind2)+0.02)**0.5+0.002*zqta(ind1,ind2) 
+!       if (paprs(ind1,ind2).gt.90000) then
+!       ratqs(ind1,ind2)=0.002
+!       else 
+!       ratqs(ind1,ind2)=0.002+0.0*(90000-paprs(ind1,ind2))/20000
+!       endif
+!       sigma1s=(1.1**0.5)*(fraca(ind1,ind2)**0.6)/(1-fraca(ind1,ind2))*((sth-senv)**2)**0.5+0.002*po(ind1)
+!       sigma2s=0.11*((sth-senv)**2)**0.5/(fraca(ind1,ind2)+0.01)**0.4+0.002*zqta(ind1,ind2) 
+!       sigma1s=ratqs(ind1,ind2)*po(ind1)
+!      sigma2s=0.11*((sth-senv)**2)**0.5/(fraca(ind1,ind2)+0.02)**0.4+0.00003  
+ 
+!------------------------------------------------------------------------------
+! Calcul de l'eau condens?e et de la couverture nuageuse
+!------------------------------------------------------------------------------
+      sqrt2pi=sqrt(2.*pi)
+      xth=sth/(sqrt(2.)*sigma2s)
+      xenv=senv/(sqrt(2.)*sigma1s)
+      cth(ind1,ind2)=0.5*(1.+1.*erf(xth))
+      cenv(ind1,ind2)=0.5*(1.+1.*erf(xenv)) 
+      ctot(ind1,ind2)=fraca(ind1,ind2)*cth(ind1,ind2)+(1.-1.*fraca(ind1,ind2))*cenv(ind1,ind2)   
+
+      qlth(ind1,ind2)=sigma2s*((exp(-1.*xth**2)/sqrt2pi)+xth*sqrt(2.)*cth(ind1,ind2))
+      qlenv(ind1,ind2)=sigma1s*((exp(-1.*xenv**2)/sqrt2pi)+xenv*sqrt(2.)*cenv(ind1,ind2))   
+      qltot(ind1,ind2)=fraca(ind1,ind2)*qlth(ind1,ind2)+(1.-1.*fraca(ind1,ind2))*qlenv(ind1,ind2)
+     
+       IF (iflag_cloudth_vert == 1) THEN
+!-------------------------------------------------------------------------------
+!  Version 2: Modification selon J.-Louis. On condense ?? partir de qsat-ratqs
+!-------------------------------------------------------------------------------
+!      deltasenv=aenv*ratqs(ind1,ind2)*po(ind1)
+!      deltasth=ath*ratqs(ind1,ind2)*zqta(ind1,ind2)
+      deltasenv=aenv*ratqs(ind1,ind2)*zqsatenv(ind1,ind2)
+      deltasth=ath*ratqs(ind1,ind2)*zqsatth(ind1,ind2)
+!      deltasenv=aenv*0.01*po(ind1)
+!     deltasth=ath*0.01*zqta(ind1,ind2)    
+      xenv1=(senv-deltasenv)/(sqrt(2.)*sigma1s)
+      xenv2=(senv+deltasenv)/(sqrt(2.)*sigma1s)
+      xth1=(sth-deltasth)/(sqrt(2.)*sigma2s)
+      xth2=(sth+deltasth)/(sqrt(2.)*sigma2s)
+      coeffqlenv=(sigma1s)**2/(2*sqrtpi*deltasenv)
+      coeffqlth=(sigma2s)**2/(2*sqrtpi*deltasth)
+      
+      cth(ind1,ind2)=0.5*(1.+1.*erf(xth2))
+      cenv(ind1,ind2)=0.5*(1.+1.*erf(xenv2)) 
+      ctot(ind1,ind2)=fraca(ind1,ind2)*cth(ind1,ind2)+(1.-1.*fraca(ind1,ind2))*cenv(ind1,ind2)   
+
+      IntJ=sigma1s*(exp(-1.*xenv1**2)/sqrt2pi)+0.5*senv*(1+erf(xenv1))
+      IntI1=coeffqlenv*0.5*(0.5*sqrtpi*(erf(xenv2)-erf(xenv1))+xenv1*exp(-1.*xenv1**2)-xenv2*exp(-1.*xenv2**2))
+      IntI2=coeffqlenv*xenv2*(exp(-1.*xenv2**2)-exp(-1.*xenv1**2))
+      IntI3=coeffqlenv*0.5*sqrtpi*xenv2**2*(erf(xenv2)-erf(xenv1))
+
+      qlenv(ind1,ind2)=IntJ+IntI1+IntI2+IntI3
+!      qlenv(ind1,ind2)=IntJ 
+!      print*, qlenv(ind1,ind2),'VERIF EAU'
+
+
+      IntJ=sigma2s*(exp(-1.*xth1**2)/sqrt2pi)+0.5*sth*(1+erf(xth1))
+!      IntI1=coeffqlth*((0.5*xth1-xth2)*exp(-1.*xth1**2)+0.5*xth2*exp(-1.*xth2**2))
+!      IntI2=coeffqlth*0.5*sqrtpi*(0.5+xth2**2)*(erf(xth2)-erf(xth1))
+      IntI1=coeffqlth*0.5*(0.5*sqrtpi*(erf(xth2)-erf(xth1))+xth1*exp(-1.*xth1**2)-xth2*exp(-1.*xth2**2))
+      IntI2=coeffqlth*xth2*(exp(-1.*xth2**2)-exp(-1.*xth1**2))
+      IntI3=coeffqlth*0.5*sqrtpi*xth2**2*(erf(xth2)-erf(xth1))
+      qlth(ind1,ind2)=IntJ+IntI1+IntI2+IntI3
+!      qlth(ind1,ind2)=IntJ
+!      print*, IntJ,IntI1,IntI2,IntI3,qlth(ind1,ind2),'VERIF EAU2'
+      qltot(ind1,ind2)=fraca(ind1,ind2)*qlth(ind1,ind2)+(1.-1.*fraca(ind1,ind2))*qlenv(ind1,ind2)
+
+      ELSE IF (iflag_cloudth_vert == 2) THEN
+
+!-------------------------------------------------------------------------------
+!  Version 3: Modification Jean Jouhaud. On condense a partir de -delta s
+!-------------------------------------------------------------------------------
+!      deltasenv=aenv*ratqs(ind1,ind2)*po(ind1)
+!      deltasth=ath*ratqs(ind1,ind2)*zqta(ind1,ind2)
+!      deltasenv=aenv*ratqs(ind1,ind2)*zqsatenv(ind1,ind2)
+!      deltasth=ath*ratqs(ind1,ind2)*zqsatth(ind1,ind2)
+      deltasenv=aenv*vert_alpha*sigma1s
+      deltasth=ath*vert_alpha*sigma2s
+      
+      xenv1=-(senv+deltasenv)/(sqrt(2.)*sigma1s)
+      xenv2=-(senv-deltasenv)/(sqrt(2.)*sigma1s)
+      xth1=-(sth+deltasth)/(sqrt(2.)*sigma2s)
+      xth2=-(sth-deltasth)/(sqrt(2.)*sigma2s)
+!     coeffqlenv=(sigma1s)**2/(2*sqrtpi*deltasenv)
+!     coeffqlth=(sigma2s)**2/(2*sqrtpi*deltasth)
+      
+      cth(ind1,ind2)=0.5*(1.-1.*erf(xth1))
+      cenv(ind1,ind2)=0.5*(1.-1.*erf(xenv1))
+      ctot(ind1,ind2)=fraca(ind1,ind2)*cth(ind1,ind2)+(1.-1.*fraca(ind1,ind2))*cenv(ind1,ind2)
+
+      IntJ=0.5*senv*(1-erf(xenv2))+(sigma1s/sqrt2pi)*exp(-1.*xenv2**2)
+      IntI1=(((senv+deltasenv)**2+(sigma1s)**2)/(8*deltasenv))*(erf(xenv2)-erf(xenv1))
+      IntI2=(sigma1s**2/(4*deltasenv*sqrtpi))*(xenv1*exp(-1.*xenv1**2)-xenv2*exp(-1.*xenv2**2))
+      IntI3=((sqrt2*sigma1s*(senv+deltasenv))/(4*sqrtpi*deltasenv))*(exp(-1.*xenv1**2)-exp(-1.*xenv2**2))
+
+!      IntI1=0.5*(0.5*sqrtpi*(erf(xenv2)-erf(xenv1))+xenv1*exp(-1.*xenv1**2)-xenv2*exp(-1.*xenv2**2))
+!      IntI2=xenv2*(exp(-1.*xenv2**2)-exp(-1.*xenv1**2))
+!      IntI3=0.5*sqrtpi*xenv2**2*(erf(xenv2)-erf(xenv1))
+
+      qlenv(ind1,ind2)=IntJ+IntI1+IntI2+IntI3
+!      qlenv(ind1,ind2)=IntJ 
+!      print*, qlenv(ind1,ind2),'VERIF EAU'
+
+      IntJ=0.5*sth*(1-erf(xth2))+(sigma2s/sqrt2pi)*exp(-1.*xth2**2)
+      IntI1=(((sth+deltasth)**2+(sigma2s)**2)/(8*deltasth))*(erf(xth2)-erf(xth1))
+      IntI2=(sigma2s**2/(4*deltasth*sqrtpi))*(xth1*exp(-1.*xth1**2)-xth2*exp(-1.*xth2**2))
+      IntI3=((sqrt2*sigma2s*(sth+deltasth))/(4*sqrtpi*deltasth))*(exp(-1.*xth1**2)-exp(-1.*xth2**2))
+      
+      qlth(ind1,ind2)=IntJ+IntI1+IntI2+IntI3
+!      qlth(ind1,ind2)=IntJ
+!      print*, IntJ,IntI1,IntI2,IntI3,qlth(ind1,ind2),'VERIF EAU2'
+      qltot(ind1,ind2)=fraca(ind1,ind2)*qlth(ind1,ind2)+(1.-1.*fraca(ind1,ind2))*qlenv(ind1,ind2)
+      
+
+
+
+      ENDIF ! of if (iflag_cloudth_vert==1 or 2)
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+      if (cenv(ind1,ind2).lt.1.e-10.or.cth(ind1,ind2).lt.1.e-10) then
+      ctot(ind1,ind2)=0.
+      qcloud(ind1)=zqsatenv(ind1,ind2) 
+
+      else 
+                
+      ctot(ind1,ind2)=ctot(ind1,ind2) 
+      qcloud(ind1)=qltot(ind1,ind2)/ctot(ind1,ind2)+zqs(ind1)
+!      qcloud(ind1)=fraca(ind1,ind2)*qlth(ind1,ind2)/cth(ind1,ind2) &
+!    &             +(1.-1.*fraca(ind1,ind2))*qlenv(ind1,ind2)/cenv(ind1,ind2)+zqs(ind1) 
+
+      endif  
+                       
+      
+          
+!     print*,sth,sigma2s,qlth(ind1,ind2),ctot(ind1,ind2),qltot(ind1,ind2),'verif'
+
+
+      else  ! gaussienne environnement seule
+      
+      zqenv(ind1)=po(ind1)
+      Tbef=t(ind1,ind2)
+      zdelta=MAX(0.,SIGN(1.,RTT-Tbef))
+      qsatbef= R2ES * FOEEW(Tbef,zdelta)/paprs(ind1,ind2)
+      qsatbef=MIN(0.5,qsatbef)
+      zcor=1./(1.-retv*qsatbef)
+      qsatbef=qsatbef*zcor
+      zqsatenv(ind1,ind2)=qsatbef
+      
+
+!      qlbef=Max(po(ind1)-zqsatenv(ind1,ind2),0.)
+      zthl(ind1,ind2)=t(ind1,ind2)*(101325/paprs(ind1,ind2))**(rdd/cppd)
+      alenv=(0.622*Lv*zqsatenv(ind1,ind2))/(rdd*zthl(ind1,ind2)**2)  
+      aenv=1./(1.+(alenv*Lv/cppd))
+      senv=aenv*(po(ind1)-zqsatenv(ind1,ind2)) 
+      
+
+      sigma1s=ratqs(ind1,ind2)*zqenv(ind1)
+
+      sqrt2pi=sqrt(2.*pi)
+      xenv=senv/(sqrt(2.)*sigma1s)
+      ctot(ind1,ind2)=0.5*(1.+1.*erf(xenv))
+      qltot(ind1,ind2)=sigma1s*((exp(-1.*xenv**2)/sqrt2pi)+xenv*sqrt(2.)*cenv(ind1,ind2))
+      
+      if (ctot(ind1,ind2).lt.1.e-3) then
+      ctot(ind1,ind2)=0.
+      qcloud(ind1)=zqsatenv(ind1,ind2) 
+
+      else   
+                
+      ctot(ind1,ind2)=ctot(ind1,ind2) 
+      qcloud(ind1)=qltot(ind1,ind2)/ctot(ind1,ind2)+zqsatenv(ind1,ind2)
+
+      endif    
+ 
+ 
+ 
+ 
+ 
+ 
+      endif   
+      enddo
+     
+      return
+!     end
+END SUBROUTINE cloudth_vert
+
+
+
+
+       SUBROUTINE cloudth_v3(ngrid,klev,ind2,  &
+     &           ztv,po,zqta,fraca, & 
+     &           qcloud,ctot,ctot_vol,zpspsk,paprs,pplay,ztla,zthl, &
+     &           ratqs,sigma_qtherm,zqs,t, &
+     &           cloudth_sth,cloudth_senv,cloudth_sigmath,cloudth_sigmaenv)
+
+      use lmdz_cloudth_ini, only: iflag_cloudth_vert
+
+      IMPLICIT NONE
+
+
+!===========================================================================
+! Author : Arnaud Octavio Jam (LMD/CNRS)
+! Date : 25 Mai 2010
+! Objet : calcule les valeurs de qc et rneb dans les thermiques
+!===========================================================================
+
+
+      INCLUDE "YOMCST.h"
+      INCLUDE "YOETHF.h"
+      INCLUDE "FCTTRE.h"
+
+      integer, intent(in) :: ind2
+      integer, intent(in) :: ngrid,klev
+      
+      real, dimension(ngrid,klev), intent(in) :: ztv
+      real, dimension(ngrid), intent(in) :: po
+      real, dimension(ngrid,klev), intent(in) :: zqta
+      real, dimension(ngrid,klev+1), intent(in) :: fraca
+      real, dimension(ngrid), intent(out) :: qcloud
+      real, dimension(ngrid,klev), intent(out) :: ctot
+      real, dimension(ngrid,klev), intent(out) :: ctot_vol
+      real, dimension(ngrid,klev), intent(in) :: zpspsk
+      real, dimension(ngrid,klev+1), intent(in) :: paprs
+      real, dimension(ngrid,klev), intent(in) :: pplay
+      real, dimension(ngrid,klev), intent(in) :: ztla
+      real, dimension(ngrid,klev), intent(inout) :: zthl
+      real, dimension(ngrid,klev), intent(in) :: ratqs,sigma_qtherm
+      real, dimension(ngrid), intent(in) :: zqs
+      real, dimension(ngrid,klev), intent(in) :: t
+      real, dimension(ngrid,klev), intent(out) :: cloudth_sth,cloudth_senv,cloudth_sigmath,cloudth_sigmaenv
+
+
+      REAL zqenv(ngrid)   
+      REAL zqsatth(ngrid,klev)
+      REAL zqsatenv(ngrid,klev)
+      
+      REAL sigma1(ngrid,klev)                                                         
+      REAL sigma2(ngrid,klev)
+      REAL qlth(ngrid,klev)
+      REAL qlenv(ngrid,klev)
+      REAL qltot(ngrid,klev) 
+      REAL cth(ngrid,klev)
+      REAL cenv(ngrid,klev)   
+      REAL cth_vol(ngrid,klev)
+      REAL cenv_vol(ngrid,klev)
+      REAL rneb(ngrid,klev)      
+      REAL qsatmmussig1,qsatmmussig2,sqrt2pi,sqrt2,sqrtpi,pi
+      REAL rdd,cppd,Lv
+      REAL alth,alenv,ath,aenv
+      REAL sth,senv,sigma1s,sigma2s,xth,xenv, exp_xenv1, exp_xenv2,exp_xth1,exp_xth2
+      REAL inverse_rho,beta,a_Brooks,b_Brooks,A_Maj_Brooks,Dx_Brooks,f_Brooks
+      REAL Tbef,zdelta,qsatbef,zcor
+      REAL qlbef  
+      REAL zpdf_sig(ngrid),zpdf_k(ngrid),zpdf_delta(ngrid)
+      REAL zpdf_a(ngrid),zpdf_b(ngrid),zpdf_e1(ngrid),zpdf_e2(ngrid) 
+      REAL erf
+
+
+      INTEGER :: ind1,l, ig
+
+      IF (iflag_cloudth_vert.GE.1) THEN
+      CALL cloudth_vert_v3(ngrid,klev,ind2,  &
+     &           ztv,po,zqta,fraca, & 
+     &           qcloud,ctot,ctot_vol,zpspsk,paprs,pplay,ztla,zthl, &
+     &           ratqs,sigma_qtherm,zqs,t, &
+     &           cloudth_sth,cloudth_senv,cloudth_sigmath,cloudth_sigmaenv)
+      RETURN
+      ENDIF
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+
+!-------------------------------------------------------------------------------
+! Initialisation des variables r?elles
+!-------------------------------------------------------------------------------
+      sigma1(:,:)=0.
+      sigma2(:,:)=0.
+      qlth(:,:)=0.
+      qlenv(:,:)=0.  
+      qltot(:,:)=0.
+      rneb(:,:)=0.
+      qcloud(:)=0.
+      cth(:,:)=0.
+      cenv(:,:)=0.
+      ctot(:,:)=0.
+      cth_vol(:,:)=0.
+      cenv_vol(:,:)=0.
+      ctot_vol(:,:)=0.
+      qsatmmussig1=0.
+      qsatmmussig2=0.
+      rdd=287.04
+      cppd=1005.7
+      pi=3.14159 
+      Lv=2.5e6
+      sqrt2pi=sqrt(2.*pi)
+      sqrt2=sqrt(2.)
+      sqrtpi=sqrt(pi)
+
+
+!-------------------------------------------------------------------------------
+! Cloud fraction in the thermals and standard deviation of the PDFs
+!-------------------------------------------------------------------------------                 
+      do ind1=1,ngrid
+
+      if ((ztv(ind1,1).gt.ztv(ind1,2)).and.(fraca(ind1,ind2).gt.1.e-10)) then 
+
+      zqenv(ind1)=(po(ind1)-fraca(ind1,ind2)*zqta(ind1,ind2))/(1.-fraca(ind1,ind2))
+
+      Tbef=zthl(ind1,ind2)*zpspsk(ind1,ind2)
+      zdelta=MAX(0.,SIGN(1.,RTT-Tbef))
+      qsatbef= R2ES*FOEEW(Tbef,zdelta)/paprs(ind1,ind2)
+      qsatbef=MIN(0.5,qsatbef)
+      zcor=1./(1.-retv*qsatbef)
+      qsatbef=qsatbef*zcor
+      zqsatenv(ind1,ind2)=qsatbef
+
+
+      alenv=(0.622*Lv*zqsatenv(ind1,ind2))/(rdd*zthl(ind1,ind2)**2)     !qsl, p84
+      aenv=1./(1.+(alenv*Lv/cppd))                                      !al, p84
+      senv=aenv*(po(ind1)-zqsatenv(ind1,ind2))                          !s, p84
+
+!po = qt de l'environnement ET des thermique
+!zqenv = qt environnement
+!zqsatenv = qsat environnement
+!zthl = Tl environnement
+
+
+      Tbef=ztla(ind1,ind2)*zpspsk(ind1,ind2)
+      zdelta=MAX(0.,SIGN(1.,RTT-Tbef))
+      qsatbef= R2ES * FOEEW(Tbef,zdelta)/paprs(ind1,ind2)
+      qsatbef=MIN(0.5,qsatbef)
+      zcor=1./(1.-retv*qsatbef)
+      qsatbef=qsatbef*zcor
+      zqsatth(ind1,ind2)=qsatbef
+            
+      alth=(0.622*Lv*zqsatth(ind1,ind2))/(rdd*ztla(ind1,ind2)**2)       !qsl, p84
+      ath=1./(1.+(alth*Lv/cppd))                                        !al, p84
+      sth=ath*(zqta(ind1,ind2)-zqsatth(ind1,ind2))                      !s, p84
+      
+!zqta = qt thermals
+!zqsatth = qsat thermals
+!ztla = Tl thermals
+
+!------------------------------------------------------------------------------
+! s standard deviations
+!------------------------------------------------------------------------------
+
+!     tests
+!     sigma1s=(1.1**0.5)*(fraca(ind1,ind2)**0.6)/(1-fraca(ind1,ind2))*((sth-senv)**2)**0.5+0.002*po(ind1)
+!     sigma1s=(0.92*(fraca(ind1,ind2)**0.5)/(1-fraca(ind1,ind2))*(((sth-senv)**2)**0.5))+ratqs(ind1,ind2)*po(ind1)
+!     sigma2s=(0.09*(((sth-senv)**2)**0.5)/((fraca(ind1,ind2)+0.02)**0.5))+0.002*zqta(ind1,ind2)
+!     final option
+      sigma1s=(1.1**0.5)*(fraca(ind1,ind2)**0.6)/(1-fraca(ind1,ind2))*((sth-senv)**2)**0.5+ratqs(ind1,ind2)*po(ind1)
+      sigma2s=0.11*((sth-senv)**2)**0.5/(fraca(ind1,ind2)+0.01)**0.4+0.002*zqta(ind1,ind2)
+ 
+!------------------------------------------------------------------------------
+! Condensed water and cloud cover
+!------------------------------------------------------------------------------
+      xth=sth/(sqrt2*sigma2s)
+      xenv=senv/(sqrt2*sigma1s)
+      cth(ind1,ind2)=0.5*(1.+1.*erf(xth))       !4.18 p 111, l.7 p115 & 4.20 p 119 thesis Arnaud Jam
+      cenv(ind1,ind2)=0.5*(1.+1.*erf(xenv))     !4.18 p 111, l.7 p115 & 4.20 p 119 thesis Arnaud Jam
+      ctot(ind1,ind2)=fraca(ind1,ind2)*cth(ind1,ind2)+(1.-1.*fraca(ind1,ind2))*cenv(ind1,ind2)
+      ctot_vol(ind1,ind2)=ctot(ind1,ind2)
+
+      qlth(ind1,ind2)=sigma2s*((exp(-1.*xth**2)/sqrt2pi)+xth*sqrt2*cth(ind1,ind2))
+      qlenv(ind1,ind2)=sigma1s*((exp(-1.*xenv**2)/sqrt2pi)+xenv*sqrt2*cenv(ind1,ind2))
+      qltot(ind1,ind2)=fraca(ind1,ind2)*qlth(ind1,ind2)+(1.-1.*fraca(ind1,ind2))*qlenv(ind1,ind2)
+
+      if (ctot(ind1,ind2).lt.1.e-10) then
+      ctot(ind1,ind2)=0.
+      qcloud(ind1)=zqsatenv(ind1,ind2) 
+      else
+      qcloud(ind1)=qltot(ind1,ind2)/ctot(ind1,ind2)+zqs(ind1)
+      endif
+
+      else  ! Environnement only, follow the if l.110
+      
+      zqenv(ind1)=po(ind1)
+      Tbef=t(ind1,ind2)
+      zdelta=MAX(0.,SIGN(1.,RTT-Tbef))
+      qsatbef= R2ES * FOEEW(Tbef,zdelta)/paprs(ind1,ind2)
+      qsatbef=MIN(0.5,qsatbef)
+      zcor=1./(1.-retv*qsatbef)
+      qsatbef=qsatbef*zcor
+      zqsatenv(ind1,ind2)=qsatbef
+
+!     qlbef=Max(po(ind1)-zqsatenv(ind1,ind2),0.)
+      zthl(ind1,ind2)=t(ind1,ind2)*(101325/paprs(ind1,ind2))**(rdd/cppd)
+      alenv=(0.622*Lv*zqsatenv(ind1,ind2))/(rdd*zthl(ind1,ind2)**2)  
+      aenv=1./(1.+(alenv*Lv/cppd))
+      senv=aenv*(po(ind1)-zqsatenv(ind1,ind2))
+      
+      sigma1s=ratqs(ind1,ind2)*zqenv(ind1)
+
+      xenv=senv/(sqrt2*sigma1s)
+      ctot(ind1,ind2)=0.5*(1.+1.*erf(xenv))
+      ctot_vol(ind1,ind2)=ctot(ind1,ind2)
+      qltot(ind1,ind2)=sigma1s*((exp(-1.*xenv**2)/sqrt2pi)+xenv*sqrt2*cenv(ind1,ind2))
+
+      if (ctot(ind1,ind2).lt.1.e-3) then
+      ctot(ind1,ind2)=0.
+      qcloud(ind1)=zqsatenv(ind1,ind2)
+      else   
+      qcloud(ind1)=qltot(ind1,ind2)/ctot(ind1,ind2)+zqsatenv(ind1,ind2)
+      endif
+
+
+      endif       ! From the separation (thermal/envrionnement) et (environnement) only, l.110 et l.183
+      enddo       ! from the loop on ngrid l.108
+      return
+!     end
+END SUBROUTINE cloudth_v3
+
+
+
+!===========================================================================
+     SUBROUTINE cloudth_vert_v3(ngrid,klev,ind2,  &
+     &           ztv,po,zqta,fraca, & 
+     &           qcloud,ctot,ctot_vol,zpspsk,paprs,pplay,ztla,zthl, &
+     &           ratqs,sigma_qtherm,zqs,t, &
+     &           cloudth_sth,cloudth_senv,cloudth_sigmath,cloudth_sigmaenv)
+
+!===========================================================================
+! Auteur : Arnaud Octavio Jam (LMD/CNRS)
+! Date : 25 Mai 2010
+! Objet : calcule les valeurs de qc et rneb dans les thermiques
+!===========================================================================
+
+      use lmdz_cloudth_ini, only : iflag_cloudth_vert,iflag_ratqs
+      use lmdz_cloudth_ini, only : vert_alpha,vert_alpha_th, sigma1s_factor, sigma1s_power , sigma2s_factor , sigma2s_power , cloudth_ratqsmin , iflag_cloudth_vert_noratqs
+
+      IMPLICIT NONE
+
+
+
+      INCLUDE "YOMCST.h"
+      INCLUDE "YOETHF.h"
+      INCLUDE "FCTTRE.h"
+      
+      INTEGER itap,ind1,ind2
+      INTEGER ngrid,klev,klon,l,ig 
+      real, dimension(ngrid,klev), intent(out) :: cloudth_sth,cloudth_senv,cloudth_sigmath,cloudth_sigmaenv
+      
+      REAL ztv(ngrid,klev)
+      REAL po(ngrid)
+      REAL zqenv(ngrid)   
+      REAL zqta(ngrid,klev)
+          
+      REAL fraca(ngrid,klev+1)
+      REAL zpspsk(ngrid,klev)
+      REAL paprs(ngrid,klev+1)
+      REAL pplay(ngrid,klev)
+      REAL ztla(ngrid,klev)
+      REAL zthl(ngrid,klev)
+
+      REAL zqsatth(ngrid,klev)
+      REAL zqsatenv(ngrid,klev)
+      
+      REAL sigma1(ngrid,klev)                                                         
+      REAL sigma2(ngrid,klev)
+      REAL qlth(ngrid,klev)
+      REAL qlenv(ngrid,klev)
+      REAL qltot(ngrid,klev) 
+      REAL cth(ngrid,klev)
+      REAL cenv(ngrid,klev)   
+      REAL ctot(ngrid,klev)
+      REAL cth_vol(ngrid,klev)
+      REAL cenv_vol(ngrid,klev)
+      REAL ctot_vol(ngrid,klev)
+      REAL rneb(ngrid,klev)
+      REAL t(ngrid,klev)                                                                  
+      REAL qsatmmussig1,qsatmmussig2,sqrtpi,sqrt2,sqrt2pi,pi
+      REAL rdd,cppd,Lv
+      REAL alth,alenv,ath,aenv
+      REAL sth,senv,sigma1s,sigma2s,sigma1s_fraca,sigma1s_ratqs
+      REAL inverse_rho,beta,a_Brooks,b_Brooks,A_Maj_Brooks,Dx_Brooks,f_Brooks
+      REAL xth,xenv,exp_xenv1,exp_xenv2,exp_xth1,exp_xth2
+      REAL xth1,xth2,xenv1,xenv2,deltasth, deltasenv
+      REAL IntJ,IntI1,IntI2,IntI3,IntJ_CF,IntI1_CF,IntI3_CF,coeffqlenv,coeffqlth
+      REAL Tbef,zdelta,qsatbef,zcor
+      REAL qlbef  
+      REAL ratqs(ngrid,klev),sigma_qtherm(ngrid,klev) ! determine la largeur de distribution de vapeur
+      ! Change the width of the PDF used for vertical subgrid scale heterogeneity
+      ! (J Jouhaud, JL Dufresne, JB Madeleine)
+
+      REAL zpdf_sig(ngrid),zpdf_k(ngrid),zpdf_delta(ngrid)
+      REAL zpdf_a(ngrid),zpdf_b(ngrid),zpdf_e1(ngrid),zpdf_e2(ngrid) 
+      REAL zqs(ngrid), qcloud(ngrid)
+      REAL erf
+
+      REAL rhodz(ngrid,klev)
+      REAL zrho(ngrid,klev)
+      REAL dz(ngrid,klev)
+
+      DO ind1 = 1, ngrid
+        !Layer calculation
+        rhodz(ind1,ind2) = (paprs(ind1,ind2)-paprs(ind1,ind2+1))/rg !kg/m2
+        zrho(ind1,ind2) = pplay(ind1,ind2)/t(ind1,ind2)/rd !kg/m3
+        dz(ind1,ind2) = rhodz(ind1,ind2)/zrho(ind1,ind2) !m : epaisseur de la couche en metre
+      END DO
+
+!------------------------------------------------------------------------------
+! Initialize
+!------------------------------------------------------------------------------
+
+      sigma1(:,:)=0.
+      sigma2(:,:)=0.
+      qlth(:,:)=0.
+      qlenv(:,:)=0.  
+      qltot(:,:)=0.
+      rneb(:,:)=0.
+      qcloud(:)=0.
+      cth(:,:)=0.
+      cenv(:,:)=0.
+      ctot(:,:)=0.
+      cth_vol(:,:)=0.
+      cenv_vol(:,:)=0.
+      ctot_vol(:,:)=0.
+      qsatmmussig1=0.
+      qsatmmussig2=0.
+      rdd=287.04
+      cppd=1005.7
+      pi=3.14159 
+      Lv=2.5e6
+      sqrt2pi=sqrt(2.*pi)
+      sqrt2=sqrt(2.)
+      sqrtpi=sqrt(pi)
+
+
+
+!-------------------------------------------------------------------------------
+! Calcul de la fraction du thermique et des ecart-types des distributions
+!-------------------------------------------------------------------------------                 
+      do ind1=1,ngrid
+
+      if ((ztv(ind1,1).gt.ztv(ind1,2)).and.(fraca(ind1,ind2).gt.1.e-10)) then !Thermal and environnement
+
+      zqenv(ind1)=(po(ind1)-fraca(ind1,ind2)*zqta(ind1,ind2))/(1.-fraca(ind1,ind2)) !qt = a*qtth + (1-a)*qtenv
+
+
+      Tbef=zthl(ind1,ind2)*zpspsk(ind1,ind2)
+      zdelta=MAX(0.,SIGN(1.,RTT-Tbef))
+      qsatbef= R2ES*FOEEW(Tbef,zdelta)/paprs(ind1,ind2)
+      qsatbef=MIN(0.5,qsatbef)
+      zcor=1./(1.-retv*qsatbef)
+      qsatbef=qsatbef*zcor
+      zqsatenv(ind1,ind2)=qsatbef
+
+
+      alenv=(0.622*Lv*zqsatenv(ind1,ind2))/(rdd*zthl(ind1,ind2)**2)     !qsl, p84
+      aenv=1./(1.+(alenv*Lv/cppd))                                      !al, p84
+      senv=aenv*(po(ind1)-zqsatenv(ind1,ind2))                          !s, p84
+
+!zqenv = qt environnement
+!zqsatenv = qsat environnement
+!zthl = Tl environnement
+
+
+      Tbef=ztla(ind1,ind2)*zpspsk(ind1,ind2)
+      zdelta=MAX(0.,SIGN(1.,RTT-Tbef))
+      qsatbef= R2ES * FOEEW(Tbef,zdelta)/paprs(ind1,ind2)
+      qsatbef=MIN(0.5,qsatbef)
+      zcor=1./(1.-retv*qsatbef)
+      qsatbef=qsatbef*zcor
+      zqsatth(ind1,ind2)=qsatbef
+            
+      alth=(0.622*Lv*zqsatth(ind1,ind2))/(rdd*ztla(ind1,ind2)**2)       !qsl, p84
+      ath=1./(1.+(alth*Lv/cppd))                                        !al, p84
+      sth=ath*(zqta(ind1,ind2)-zqsatth(ind1,ind2))                      !s, p84
+      
+      
+!zqta = qt thermals
+!zqsatth = qsat thermals
+!ztla = Tl thermals
+!------------------------------------------------------------------------------
+! s standard deviation
+!------------------------------------------------------------------------------
+
+      sigma1s_fraca = (sigma1s_factor**0.5)*(fraca(ind1,ind2)**sigma1s_power) / &
+     &                (1-fraca(ind1,ind2))*((sth-senv)**2)**0.5
+!     sigma1s_fraca = (1.1**0.5)*(fraca(ind1,ind2)**0.6)/(1-fraca(ind1,ind2))*((sth-senv)**2)**0.5
+      IF (cloudth_ratqsmin>0.) THEN
+         sigma1s_ratqs = cloudth_ratqsmin*po(ind1)
+      ELSE
+         sigma1s_ratqs = ratqs(ind1,ind2)*po(ind1)
+      ENDIF
+      sigma1s = sigma1s_fraca + sigma1s_ratqs
+      sigma2s=(sigma2s_factor*(((sth-senv)**2)**0.5)/((fraca(ind1,ind2)+0.02)**sigma2s_power))+0.002*zqta(ind1,ind2)
+      IF (iflag_ratqs.eq.10.or.iflag_ratqs.eq.11) then
+         sigma1s = ratqs(ind1,ind2)*po(ind1)*aenv
+         IF (iflag_ratqs.eq.10.and.sigma_qtherm(ind1,ind2).ne.0) then
+            sigma2s = sigma_qtherm(ind1,ind2)*ath
+         ENDIF
+      ENDIF
+      
+!      tests
+!      sigma1s=(0.92**0.5)*(fraca(ind1,ind2)**0.5)/(1-fraca(ind1,ind2))*((sth-senv)**2)**0.5+ratqs(ind1,ind2)*po(ind1)
+!      sigma1s=(0.92*(fraca(ind1,ind2)**0.5)/(1-fraca(ind1,ind2))*(((sth-senv)**2)**0.5))+0.002*zqenv(ind1)
+!      sigma2s=0.09*((sth-senv)**2)**0.5/(fraca(ind1,ind2)+0.02)**0.5+0.002*zqta(ind1,ind2) 
+!      sigma2s=(0.09*(((sth-senv)**2)**0.5)/((fraca(ind1,ind2)+0.02)**0.5))+ratqs(ind1,ind2)*zqta(ind1,ind2)
+!       if (paprs(ind1,ind2).gt.90000) then
+!       ratqs(ind1,ind2)=0.002
+!       else 
+!       ratqs(ind1,ind2)=0.002+0.0*(90000-paprs(ind1,ind2))/20000
+!       endif
+!       sigma1s=(1.1**0.5)*(fraca(ind1,ind2)**0.6)/(1-fraca(ind1,ind2))*((sth-senv)**2)**0.5+0.002*po(ind1)
+!       sigma2s=0.11*((sth-senv)**2)**0.5/(fraca(ind1,ind2)+0.01)**0.4+0.002*zqta(ind1,ind2) 
+!       sigma1s=ratqs(ind1,ind2)*po(ind1)
+!      sigma2s=0.11*((sth-senv)**2)**0.5/(fraca(ind1,ind2)+0.02)**0.4+0.00003  
+ 
+       IF (iflag_cloudth_vert == 1) THEN
+!-------------------------------------------------------------------------------
+!  Version 2: Modification from Arnaud Jam according to JL Dufrense. Condensate from qsat-ratqs
+!-------------------------------------------------------------------------------
+
+      deltasenv=aenv*ratqs(ind1,ind2)*zqsatenv(ind1,ind2)
+      deltasth=ath*ratqs(ind1,ind2)*zqsatth(ind1,ind2)
+
+      xenv1=(senv-deltasenv)/(sqrt(2.)*sigma1s)
+      xenv2=(senv+deltasenv)/(sqrt(2.)*sigma1s)
+      xth1=(sth-deltasth)/(sqrt(2.)*sigma2s)
+      xth2=(sth+deltasth)/(sqrt(2.)*sigma2s)
+      coeffqlenv=(sigma1s)**2/(2*sqrtpi*deltasenv)
+      coeffqlth=(sigma2s)**2/(2*sqrtpi*deltasth)
+      
+      cth(ind1,ind2)=0.5*(1.+1.*erf(xth2))
+      cenv(ind1,ind2)=0.5*(1.+1.*erf(xenv2)) 
+      ctot(ind1,ind2)=fraca(ind1,ind2)*cth(ind1,ind2)+(1.-1.*fraca(ind1,ind2))*cenv(ind1,ind2)   
+
+      ! Environment
+      IntJ=sigma1s*(exp(-1.*xenv1**2)/sqrt2pi)+0.5*senv*(1+erf(xenv1))
+      IntI1=coeffqlenv*0.5*(0.5*sqrtpi*(erf(xenv2)-erf(xenv1))+xenv1*exp(-1.*xenv1**2)-xenv2*exp(-1.*xenv2**2))
+      IntI2=coeffqlenv*xenv2*(exp(-1.*xenv2**2)-exp(-1.*xenv1**2))
+      IntI3=coeffqlenv*0.5*sqrtpi*xenv2**2*(erf(xenv2)-erf(xenv1))
+
+      qlenv(ind1,ind2)=IntJ+IntI1+IntI2+IntI3
+
+      ! Thermal
+      IntJ=sigma2s*(exp(-1.*xth1**2)/sqrt2pi)+0.5*sth*(1+erf(xth1))
+      IntI1=coeffqlth*0.5*(0.5*sqrtpi*(erf(xth2)-erf(xth1))+xth1*exp(-1.*xth1**2)-xth2*exp(-1.*xth2**2))
+      IntI2=coeffqlth*xth2*(exp(-1.*xth2**2)-exp(-1.*xth1**2))
+      IntI3=coeffqlth*0.5*sqrtpi*xth2**2*(erf(xth2)-erf(xth1))
+      qlth(ind1,ind2)=IntJ+IntI1+IntI2+IntI3
+      qltot(ind1,ind2)=fraca(ind1,ind2)*qlth(ind1,ind2)+(1.-1.*fraca(ind1,ind2))*qlenv(ind1,ind2)
+
+      ELSE IF (iflag_cloudth_vert >= 3) THEN
+      IF (iflag_cloudth_vert < 5) THEN
+!-------------------------------------------------------------------------------
+!  Version 3: Changes by J. Jouhaud; condensation for q > -delta s
+!-------------------------------------------------------------------------------
+!      deltasenv=aenv*ratqs(ind1,ind2)*po(ind1)
+!      deltasth=ath*ratqs(ind1,ind2)*zqta(ind1,ind2)
+!      deltasenv=aenv*ratqs(ind1,ind2)*zqsatenv(ind1,ind2)
+!      deltasth=ath*ratqs(ind1,ind2)*zqsatth(ind1,ind2)
+      IF (iflag_cloudth_vert == 3) THEN
+        deltasenv=aenv*vert_alpha*sigma1s
+        deltasth=ath*vert_alpha_th*sigma2s
+      ELSE IF (iflag_cloudth_vert == 4) THEN
+        IF (iflag_cloudth_vert_noratqs == 1) THEN
+          deltasenv=vert_alpha*max(sigma1s_fraca,1e-10)
+          deltasth=vert_alpha_th*sigma2s
+        ELSE
+          deltasenv=vert_alpha*sigma1s
+          deltasth=vert_alpha_th*sigma2s
+        ENDIF
+      ENDIF
+      
+      xenv1=-(senv+deltasenv)/(sqrt(2.)*sigma1s)
+      xenv2=-(senv-deltasenv)/(sqrt(2.)*sigma1s)
+      exp_xenv1 = exp(-1.*xenv1**2)
+      exp_xenv2 = exp(-1.*xenv2**2)
+      xth1=-(sth+deltasth)/(sqrt(2.)*sigma2s)
+      xth2=-(sth-deltasth)/(sqrt(2.)*sigma2s)
+      exp_xth1 = exp(-1.*xth1**2)
+      exp_xth2 = exp(-1.*xth2**2)
+      
+      !CF_surfacique
+      cth(ind1,ind2)=0.5*(1.-1.*erf(xth1))
+      cenv(ind1,ind2)=0.5*(1.-1.*erf(xenv1))
+      ctot(ind1,ind2)=fraca(ind1,ind2)*cth(ind1,ind2)+(1.-1.*fraca(ind1,ind2))*cenv(ind1,ind2) 
+
+
+      !CF_volumique & eau condense
+      !environnement
+      IntJ=0.5*senv*(1-erf(xenv2))+(sigma1s/sqrt2pi)*exp_xenv2
+      IntJ_CF=0.5*(1.-1.*erf(xenv2))
+      if (deltasenv .lt. 1.e-10) then 
+      qlenv(ind1,ind2)=IntJ
+      cenv_vol(ind1,ind2)=IntJ_CF
+      else
+      IntI1=(((senv+deltasenv)**2+(sigma1s)**2)/(8*deltasenv))*(erf(xenv2)-erf(xenv1))
+      IntI2=(sigma1s**2/(4*deltasenv*sqrtpi))*(xenv1*exp_xenv1-xenv2*exp_xenv2)
+      IntI3=((sqrt2*sigma1s*(senv+deltasenv))/(4*sqrtpi*deltasenv))*(exp_xenv1-exp_xenv2)
+      IntI1_CF=((senv+deltasenv)*(erf(xenv2)-erf(xenv1)))/(4*deltasenv)
+      IntI3_CF=(sqrt2*sigma1s*(exp_xenv1-exp_xenv2))/(4*sqrtpi*deltasenv)
+      qlenv(ind1,ind2)=IntJ+IntI1+IntI2+IntI3
+      cenv_vol(ind1,ind2)=IntJ_CF+IntI1_CF+IntI3_CF
+      endif
+
+      !thermique
+      IntJ=0.5*sth*(1-erf(xth2))+(sigma2s/sqrt2pi)*exp_xth2
+      IntJ_CF=0.5*(1.-1.*erf(xth2))
+      if (deltasth .lt. 1.e-10) then
+      qlth(ind1,ind2)=IntJ
+      cth_vol(ind1,ind2)=IntJ_CF
+      else
+      IntI1=(((sth+deltasth)**2+(sigma2s)**2)/(8*deltasth))*(erf(xth2)-erf(xth1))
+      IntI2=(sigma2s**2/(4*deltasth*sqrtpi))*(xth1*exp_xth1-xth2*exp_xth2)
+      IntI3=((sqrt2*sigma2s*(sth+deltasth))/(4*sqrtpi*deltasth))*(exp_xth1-exp_xth2)
+      IntI1_CF=((sth+deltasth)*(erf(xth2)-erf(xth1)))/(4*deltasth)
+      IntI3_CF=(sqrt2*sigma2s*(exp_xth1-exp_xth2))/(4*sqrtpi*deltasth)
+      qlth(ind1,ind2)=IntJ+IntI1+IntI2+IntI3
+      cth_vol(ind1,ind2)=IntJ_CF+IntI1_CF+IntI3_CF
+      endif
+
+      qltot(ind1,ind2)=fraca(ind1,ind2)*qlth(ind1,ind2)+(1.-1.*fraca(ind1,ind2))*qlenv(ind1,ind2)
+      ctot_vol(ind1,ind2)=fraca(ind1,ind2)*cth_vol(ind1,ind2)+(1.-1.*fraca(ind1,ind2))*cenv_vol(ind1,ind2)
+
+      ELSE IF (iflag_cloudth_vert == 5) THEN
+         sigma1s=(0.71794+0.000498239*dz(ind1,ind2))*(fraca(ind1,ind2)**0.5) &
+              /(1-fraca(ind1,ind2))*(((sth-senv)**2)**0.5) &
+              +ratqs(ind1,ind2)*po(ind1) !Environment
+      sigma2s=(0.03218+0.000092655*dz(ind1,ind2))/((fraca(ind1,ind2)+0.02)**0.5)*(((sth-senv)**2)**0.5)+0.002*zqta(ind1,ind2)                   !Thermals
+      !sigma1s=(1.1**0.5)*(fraca(ind1,ind2)**0.6)/(1-fraca(ind1,ind2))*((sth-senv)**2)**0.5+0.002*po(ind1)
+      !sigma2s=0.11*((sth-senv)**2)**0.5/(fraca(ind1,ind2)+0.01)**0.4+0.002*zqta(ind1,ind2) 
+      xth=sth/(sqrt(2.)*sigma2s)
+      xenv=senv/(sqrt(2.)*sigma1s)
+
+      !Volumique
+      cth_vol(ind1,ind2)=0.5*(1.+1.*erf(xth))
+      cenv_vol(ind1,ind2)=0.5*(1.+1.*erf(xenv))
+      ctot_vol(ind1,ind2)=fraca(ind1,ind2)*cth_vol(ind1,ind2)+(1.-1.*fraca(ind1,ind2))*cenv_vol(ind1,ind2)
+      !print *,'jeanjean_CV=',ctot_vol(ind1,ind2)
+
+      qlth(ind1,ind2)=sigma2s*((exp(-1.*xth**2)/sqrt2pi)+xth*sqrt(2.)*cth_vol(ind1,ind2))
+      qlenv(ind1,ind2)=sigma1s*((exp(-1.*xenv**2)/sqrt2pi)+xenv*sqrt(2.)*cenv_vol(ind1,ind2))  
+      qltot(ind1,ind2)=fraca(ind1,ind2)*qlth(ind1,ind2)+(1.-1.*fraca(ind1,ind2))*qlenv(ind1,ind2)
+
+      !Surfacique
+      !Neggers
+      !beta=0.0044
+      !inverse_rho=1.+beta*dz(ind1,ind2)
+      !print *,'jeanjean : beta=',beta
+      !cth(ind1,ind2)=cth_vol(ind1,ind2)*inverse_rho
+      !cenv(ind1,ind2)=cenv_vol(ind1,ind2)*inverse_rho
+      !ctot(ind1,ind2)=fraca(ind1,ind2)*cth(ind1,ind2)+(1.-1.*fraca(ind1,ind2))*cenv(ind1,ind2)
+
+      !Brooks
+      a_Brooks=0.6694
+      b_Brooks=0.1882
+      A_Maj_Brooks=0.1635 !-- sans shear
+      !A_Maj_Brooks=0.17   !-- ARM LES
+      !A_Maj_Brooks=0.18   !-- RICO LES
+      !A_Maj_Brooks=0.19   !-- BOMEX LES
+      Dx_Brooks=200000.
+      f_Brooks=A_Maj_Brooks*(dz(ind1,ind2)**(a_Brooks))*(Dx_Brooks**(-b_Brooks))
+      !print *,'jeanjean_f=',f_Brooks
+
+      cth(ind1,ind2)=1./(1.+exp(-1.*f_Brooks)*((1./max(1.e-15,min(cth_vol(ind1,ind2),1.)))- 1.))
+      cenv(ind1,ind2)=1./(1.+exp(-1.*f_Brooks)*((1./max(1.e-15,min(cenv_vol(ind1,ind2),1.)))- 1.))
+      ctot(ind1,ind2)=1./(1.+exp(-1.*f_Brooks)*((1./max(1.e-15,min(ctot_vol(ind1,ind2),1.)))- 1.))
+      !print *,'JJ_ctot_1',ctot(ind1,ind2)
+
+
+
+
+
+      ENDIF ! of if (iflag_cloudth_vert<5)
+      ENDIF ! of if (iflag_cloudth_vert==1 or 3 or 4)
+
+!      if (ctot(ind1,ind2).lt.1.e-10) then
+      if (cenv(ind1,ind2).lt.1.e-10.or.cth(ind1,ind2).lt.1.e-10) then
+      ctot(ind1,ind2)=0.
+      ctot_vol(ind1,ind2)=0.
+      qcloud(ind1)=zqsatenv(ind1,ind2)
+
+      else
+                
+      qcloud(ind1)=qltot(ind1,ind2)/ctot(ind1,ind2)+zqs(ind1)
+!      qcloud(ind1)=fraca(ind1,ind2)*qlth(ind1,ind2)/cth(ind1,ind2) &
+!    &             +(1.-1.*fraca(ind1,ind2))*qlenv(ind1,ind2)/cenv(ind1,ind2)+zqs(ind1) 
+
+      endif  
+
+      else  ! gaussienne environnement seule
+      
+
+      zqenv(ind1)=po(ind1)
+      Tbef=t(ind1,ind2)
+      zdelta=MAX(0.,SIGN(1.,RTT-Tbef))
+      qsatbef= R2ES * FOEEW(Tbef,zdelta)/paprs(ind1,ind2)
+      qsatbef=MIN(0.5,qsatbef)
+      zcor=1./(1.-retv*qsatbef)
+      qsatbef=qsatbef*zcor
+      zqsatenv(ind1,ind2)=qsatbef
+      
+
+!      qlbef=Max(po(ind1)-zqsatenv(ind1,ind2),0.)
+      zthl(ind1,ind2)=t(ind1,ind2)*(101325/paprs(ind1,ind2))**(rdd/cppd)
+      alenv=(0.622*Lv*zqsatenv(ind1,ind2))/(rdd*zthl(ind1,ind2)**2)
+      aenv=1./(1.+(alenv*Lv/cppd))
+      senv=aenv*(po(ind1)-zqsatenv(ind1,ind2))
+      sth=0.
+      
+
+      sigma1s=ratqs(ind1,ind2)*zqenv(ind1)
+      sigma2s=0.
+
+      sqrt2pi=sqrt(2.*pi)
+      xenv=senv/(sqrt(2.)*sigma1s)
+      ctot(ind1,ind2)=0.5*(1.+1.*erf(xenv))
+      ctot_vol(ind1,ind2)=ctot(ind1,ind2)
+      qltot(ind1,ind2)=sigma1s*((exp(-1.*xenv**2)/sqrt2pi)+xenv*sqrt(2.)*cenv(ind1,ind2))
+      
+      if (ctot(ind1,ind2).lt.1.e-3) then
+      ctot(ind1,ind2)=0.
+      qcloud(ind1)=zqsatenv(ind1,ind2)
+
+      else   
+                
+!      ctot(ind1,ind2)=ctot(ind1,ind2) 
+      qcloud(ind1)=qltot(ind1,ind2)/ctot(ind1,ind2)+zqsatenv(ind1,ind2)
+
+      endif  
+ 
+
+
+
+      endif       ! From the separation (thermal/envrionnement) et (environnement) only, l.335 et l.492
+      ! Outputs used to check the PDFs
+      cloudth_senv(ind1,ind2) = senv
+      cloudth_sth(ind1,ind2) = sth
+      cloudth_sigmaenv(ind1,ind2) = sigma1s
+      cloudth_sigmath(ind1,ind2) = sigma2s
+
+      enddo       ! from the loop on ngrid l.333
+      return
+!     end
+END SUBROUTINE cloudth_vert_v3
+!
+
+
+
+
+
+
+
+
+
+
+
+       SUBROUTINE cloudth_v6(ngrid,klev,ind2,  &
+     &           ztv,po,zqta,fraca, & 
+     &           qcloud,ctot_surf,ctot_vol,zpspsk,paprs,pplay,ztla,zthl, &
+     &           ratqs,zqs,T, &
+     &           cloudth_sth,cloudth_senv,cloudth_sigmath,cloudth_sigmaenv)
+
+      use lmdz_cloudth_ini, only: iflag_cloudth_vert
+
+      IMPLICIT NONE
+
+
+      INCLUDE "YOMCST.h"
+      INCLUDE "YOETHF.h"
+      INCLUDE "FCTTRE.h"
+
+
+        !Domain variables
+      INTEGER ngrid !indice Max lat-lon
+      INTEGER klev  !indice Max alt
+      real, dimension(ngrid,klev), intent(out) :: cloudth_sth,cloudth_senv,cloudth_sigmath,cloudth_sigmaenv
+      INTEGER ind1  !indice in [1:ngrid]
+      INTEGER ind2  !indice in [1:klev]
+        !thermal plume fraction
+      REAL fraca(ngrid,klev+1)   !thermal plumes fraction in the gridbox
+        !temperatures
+      REAL T(ngrid,klev)       !temperature
+      REAL zpspsk(ngrid,klev)  !factor (p/p0)**kappa (used for potential variables)
+      REAL ztv(ngrid,klev)     !potential temperature (voir thermcell_env.F90)
+      REAL ztla(ngrid,klev)    !liquid temperature in the thermals (Tl_th)
+      REAL zthl(ngrid,klev)    !liquid temperature in the environment (Tl_env)
+        !pressure
+      REAL paprs(ngrid,klev+1)   !pressure at the interface of levels
+      REAL pplay(ngrid,klev)     !pressure at the middle of the level
+        !humidity
+      REAL ratqs(ngrid,klev)   !width of the total water subgrid-scale distribution
+      REAL po(ngrid)           !total water (qt)
+      REAL zqenv(ngrid)        !total water in the environment (qt_env)
+      REAL zqta(ngrid,klev)    !total water in the thermals (qt_th)
+      REAL zqsatth(ngrid,klev)   !water saturation level in the thermals (q_sat_th)
+      REAL zqsatenv(ngrid,klev)  !water saturation level in the environment (q_sat_env)
+      REAL qlth(ngrid,klev)    !condensed water in the thermals
+      REAL qlenv(ngrid,klev)   !condensed water in the environment
+      REAL qltot(ngrid,klev)   !condensed water in the gridbox
+        !cloud fractions
+      REAL cth_vol(ngrid,klev)   !cloud fraction by volume in the thermals
+      REAL cenv_vol(ngrid,klev)  !cloud fraction by volume in the environment
+      REAL ctot_vol(ngrid,klev)  !cloud fraction by volume in the gridbox
+      REAL cth_surf(ngrid,klev)  !cloud fraction by surface in the thermals
+      REAL cenv_surf(ngrid,klev) !cloud fraction by surface in the environment  
+      REAL ctot_surf(ngrid,klev) !cloud fraction by surface in the gridbox
+        !PDF of saturation deficit variables
+      REAL rdd,cppd,Lv
+      REAL Tbef,zdelta,qsatbef,zcor
+      REAL alth,alenv,ath,aenv
+      REAL sth,senv              !saturation deficits in the thermals and environment
+      REAL sigma_env,sigma_th    !standard deviations of the biGaussian PDF
+        !cloud fraction variables
+      REAL xth,xenv
+      REAL inverse_rho,beta                                  !Neggers et al. (2011) method
+      REAL a_Brooks,b_Brooks,A_Maj_Brooks,Dx_Brooks,f_Brooks !Brooks et al. (2005) method
+        !Incloud total water variables
+      REAL zqs(ngrid)    !q_sat
+      REAL qcloud(ngrid) !eau totale dans le nuage
+        !Some arithmetic variables
+      REAL erf,pi,sqrt2,sqrt2pi
+        !Depth of the layer
+      REAL dz(ngrid,klev)    !epaisseur de la couche en metre
+      REAL rhodz(ngrid,klev)
+      REAL zrho(ngrid,klev)
+      DO ind1 = 1, ngrid
+        rhodz(ind1,ind2) = (paprs(ind1,ind2)-paprs(ind1,ind2+1))/rg ![kg/m2]
+        zrho(ind1,ind2) = pplay(ind1,ind2)/T(ind1,ind2)/rd          ![kg/m3]
+        dz(ind1,ind2) = rhodz(ind1,ind2)/zrho(ind1,ind2)            ![m]
+      END DO
+
+!------------------------------------------------------------------------------
+! Initialization
+!------------------------------------------------------------------------------
+      qlth(:,:)=0.
+      qlenv(:,:)=0.  
+      qltot(:,:)=0.
+      cth_vol(:,:)=0.
+      cenv_vol(:,:)=0.
+      ctot_vol(:,:)=0.
+      cth_surf(:,:)=0.
+      cenv_surf(:,:)=0.
+      ctot_surf(:,:)=0.
+      qcloud(:)=0.
+      rdd=287.04
+      cppd=1005.7
+      pi=3.14159 
+      Lv=2.5e6
+      sqrt2=sqrt(2.)
+      sqrt2pi=sqrt(2.*pi)
+
+
+      DO ind1=1,ngrid
+!-------------------------------------------------------------------------------
+!Both thermal and environment in the gridbox
+!-------------------------------------------------------------------------------
+      IF ((ztv(ind1,1).gt.ztv(ind1,2)).and.(fraca(ind1,ind2).gt.1.e-10)) THEN
+        !--------------------------------------------
+        !calcul de qsat_env
+        !--------------------------------------------
+      Tbef=zthl(ind1,ind2)*zpspsk(ind1,ind2)
+      zdelta=MAX(0.,SIGN(1.,RTT-Tbef))
+      qsatbef= R2ES*FOEEW(Tbef,zdelta)/paprs(ind1,ind2)
+      qsatbef=MIN(0.5,qsatbef)
+      zcor=1./(1.-retv*qsatbef)
+      qsatbef=qsatbef*zcor
+      zqsatenv(ind1,ind2)=qsatbef
+        !--------------------------------------------
+        !calcul de s_env
+        !--------------------------------------------
+      alenv=(0.622*Lv*zqsatenv(ind1,ind2))/(rdd*zthl(ind1,ind2)**2)     !qsl, p84 these Arnaud Jam
+      aenv=1./(1.+(alenv*Lv/cppd))                                      !al, p84 these Arnaud Jam
+      senv=aenv*(po(ind1)-zqsatenv(ind1,ind2))                          !s, p84 these Arnaud Jam
+        !--------------------------------------------
+        !calcul de qsat_th
+        !--------------------------------------------
+      Tbef=ztla(ind1,ind2)*zpspsk(ind1,ind2)
+      zdelta=MAX(0.,SIGN(1.,RTT-Tbef))
+      qsatbef= R2ES * FOEEW(Tbef,zdelta)/paprs(ind1,ind2)
+      qsatbef=MIN(0.5,qsatbef)
+      zcor=1./(1.-retv*qsatbef)
+      qsatbef=qsatbef*zcor
+      zqsatth(ind1,ind2)=qsatbef
+        !--------------------------------------------
+        !calcul de s_th  
+        !--------------------------------------------
+      alth=(0.622*Lv*zqsatth(ind1,ind2))/(rdd*ztla(ind1,ind2)**2)       !qsl, p84 these Arnaud Jam
+      ath=1./(1.+(alth*Lv/cppd))                                        !al, p84 these Arnaud Jam
+      sth=ath*(zqta(ind1,ind2)-zqsatth(ind1,ind2))                      !s, p84 these Arnaud Jam
+        !--------------------------------------------
+        !calcul standard deviations bi-Gaussian PDF
+        !--------------------------------------------
+      sigma_th=(0.03218+0.000092655*dz(ind1,ind2))/((fraca(ind1,ind2)+0.01)**0.5)*(((sth-senv)**2)**0.5)+0.002*zqta(ind1,ind2)
+      sigma_env=(0.71794+0.000498239*dz(ind1,ind2))*(fraca(ind1,ind2)**0.5) &
+           /(1-fraca(ind1,ind2))*(((sth-senv)**2)**0.5) &
+           +ratqs(ind1,ind2)*po(ind1)
+      xth=sth/(sqrt2*sigma_th)
+      xenv=senv/(sqrt2*sigma_env)
+        !--------------------------------------------
+        !Cloud fraction by volume CF_vol
+        !--------------------------------------------
+      cth_vol(ind1,ind2)=0.5*(1.+1.*erf(xth))
+      cenv_vol(ind1,ind2)=0.5*(1.+1.*erf(xenv))
+      ctot_vol(ind1,ind2)=fraca(ind1,ind2)*cth_vol(ind1,ind2)+(1.-1.*fraca(ind1,ind2))*cenv_vol(ind1,ind2)
+        !-------------------------------------------- 
+        !Condensed water qc
+        !--------------------------------------------
+      qlth(ind1,ind2)=sigma_th*((exp(-1.*xth**2)/sqrt2pi)+xth*sqrt2*cth_vol(ind1,ind2))
+      qlenv(ind1,ind2)=sigma_env*((exp(-1.*xenv**2)/sqrt2pi)+xenv*sqrt2*cenv_vol(ind1,ind2))  
+      qltot(ind1,ind2)=fraca(ind1,ind2)*qlth(ind1,ind2)+(1.-1.*fraca(ind1,ind2))*qlenv(ind1,ind2)
+        !--------------------------------------------
+        !Cloud fraction by surface CF_surf
+        !--------------------------------------------
+        !Method Neggers et al. (2011) : ok for cumulus clouds only
+      !beta=0.0044 (Jouhaud et al.2018)
+      !inverse_rho=1.+beta*dz(ind1,ind2)
+      !ctot_surf(ind1,ind2)=ctot_vol(ind1,ind2)*inverse_rho
+        !Method Brooks et al. (2005) : ok for all types of clouds
+      a_Brooks=0.6694
+      b_Brooks=0.1882
+      A_Maj_Brooks=0.1635 !-- sans dependence au cisaillement de vent
+      Dx_Brooks=200000.   !-- si l'on considere des mailles de 200km de cote
+      f_Brooks=A_Maj_Brooks*(dz(ind1,ind2)**(a_Brooks))*(Dx_Brooks**(-b_Brooks))
+      ctot_surf(ind1,ind2)=1./(1.+exp(-1.*f_Brooks)*((1./max(1.e-15,min(ctot_vol(ind1,ind2),1.)))- 1.))
+        !--------------------------------------------
+        !Incloud Condensed water qcloud
+        !--------------------------------------------
+      if (ctot_surf(ind1,ind2) .lt. 1.e-10) then
+      ctot_vol(ind1,ind2)=0.
+      ctot_surf(ind1,ind2)=0.
+      qcloud(ind1)=zqsatenv(ind1,ind2)
+      else
+      qcloud(ind1)=qltot(ind1,ind2)/ctot_vol(ind1,ind2)+zqs(ind1)
+      endif
+
+
+
+!-------------------------------------------------------------------------------
+!Environment only in the gridbox
+!-------------------------------------------------------------------------------
+      ELSE
+        !--------------------------------------------
+        !calcul de qsat_env
+        !--------------------------------------------
+      Tbef=zthl(ind1,ind2)*zpspsk(ind1,ind2)
+      zdelta=MAX(0.,SIGN(1.,RTT-Tbef))
+      qsatbef= R2ES * FOEEW(Tbef,zdelta)/paprs(ind1,ind2)
+      qsatbef=MIN(0.5,qsatbef)
+      zcor=1./(1.-retv*qsatbef)
+      qsatbef=qsatbef*zcor
+      zqsatenv(ind1,ind2)=qsatbef
+        !--------------------------------------------
+        !calcul de s_env
+        !--------------------------------------------
+      alenv=(0.622*Lv*zqsatenv(ind1,ind2))/(rdd*zthl(ind1,ind2)**2)     !qsl, p84 these Arnaud Jam
+      aenv=1./(1.+(alenv*Lv/cppd))                                      !al, p84 these Arnaud Jam
+      senv=aenv*(po(ind1)-zqsatenv(ind1,ind2))                          !s, p84 these Arnaud Jam 
+        !--------------------------------------------
+        !calcul standard deviations Gaussian PDF
+        !--------------------------------------------
+      zqenv(ind1)=po(ind1)
+      sigma_env=ratqs(ind1,ind2)*zqenv(ind1)
+      xenv=senv/(sqrt2*sigma_env)
+        !--------------------------------------------
+        !Cloud fraction by volume CF_vol
+        !--------------------------------------------
+      ctot_vol(ind1,ind2)=0.5*(1.+1.*erf(xenv))
+        !--------------------------------------------
+        !Condensed water qc
+        !--------------------------------------------
+      qltot(ind1,ind2)=sigma_env*((exp(-1.*xenv**2)/sqrt2pi)+xenv*sqrt2*ctot_vol(ind1,ind2))
+        !--------------------------------------------
+        !Cloud fraction by surface CF_surf
+        !--------------------------------------------
+        !Method Neggers et al. (2011) : ok for cumulus clouds only
+      !beta=0.0044 (Jouhaud et al.2018)
+      !inverse_rho=1.+beta*dz(ind1,ind2)
+      !ctot_surf(ind1,ind2)=ctot_vol(ind1,ind2)*inverse_rho
+        !Method Brooks et al. (2005) : ok for all types of clouds
+      a_Brooks=0.6694
+      b_Brooks=0.1882
+      A_Maj_Brooks=0.1635 !-- sans dependence au shear
+      Dx_Brooks=200000.
+      f_Brooks=A_Maj_Brooks*(dz(ind1,ind2)**(a_Brooks))*(Dx_Brooks**(-b_Brooks))
+      ctot_surf(ind1,ind2)=1./(1.+exp(-1.*f_Brooks)*((1./max(1.e-15,min(ctot_vol(ind1,ind2),1.)))- 1.))
+        !--------------------------------------------
+        !Incloud Condensed water qcloud
+        !--------------------------------------------
+      if (ctot_surf(ind1,ind2) .lt. 1.e-8) then
+      ctot_vol(ind1,ind2)=0.
+      ctot_surf(ind1,ind2)=0.
+      qcloud(ind1)=zqsatenv(ind1,ind2)
+      else
+      qcloud(ind1)=qltot(ind1,ind2)/ctot_vol(ind1,ind2)+zqsatenv(ind1,ind2)
+      endif
+
+
+      END IF  ! From the separation (thermal/envrionnement) et (environnement only)
+
+      ! Outputs used to check the PDFs
+      cloudth_senv(ind1,ind2) = senv
+      cloudth_sth(ind1,ind2) = sth
+      cloudth_sigmaenv(ind1,ind2) = sigma_env
+      cloudth_sigmath(ind1,ind2) = sigma_th
+
+      END DO  ! From the loop on ngrid
+      return
+
+END SUBROUTINE cloudth_v6
+
+
+
+
+
+!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+SUBROUTINE cloudth_mpc(klon,klev,ind2,mpc_bl_points,                        &
+&           temp,qt,qt_th,frac_th,zpspsk,paprsup, paprsdn,play,thetal_th,   &
+&           ratqs,qcloud,qincloud,icefrac,ctot,ctot_vol,                    &
+&           cloudth_sth,cloudth_senv,cloudth_sigmath,cloudth_sigmaenv)
+!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+! Author : Etienne Vignon (LMDZ/CNRS)
+! Date: April 2024
+! Date: Adapted from cloudth_vert_v3 in 2023 by Arnaud Otavio Jam
+! IMPORTANT NOTE: we assume iflag_cloudth_vert=7
+!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+      use lmdz_cloudth_ini, only: iflag_cloudth_vert,iflag_ratqs
+      use lmdz_cloudth_ini, only: C_mpc ,Ni,C_cap,Ei,d_top ,vert_alpha, vert_alpha_th ,sigma1s_factor,sigma1s_power,sigma2s_factor,sigma2s_power,cloudth_ratqsmin ,iflag_cloudth_vert_noratqs
+      use lmdz_lscp_tools,  only: CALC_QSAT_ECMWF
+      use lmdz_lscp_ini,    only: RTT, RG, RPI, RD, RCPD, RLVTT, RLSTT, temp_nowater, min_frac_th_cld, min_neb_th
+
+      IMPLICIT NONE
+
+
+!------------------------------------------------------------------------------
+! Declaration
+!------------------------------------------------------------------------------
+
+! INPUT/OUTPUT
+
+      INTEGER, INTENT(IN)                         :: klon,klev,ind2
+      
+
+      REAL, DIMENSION(klon),      INTENT(IN)      ::  temp          ! Temperature (liquid temperature) in the mesh [K] : has seen evap of precip
+      REAL, DIMENSION(klon),      INTENT(IN)      ::  qt            ! total water specific humidity in the mesh [kg/kg]: has seen evap of precip
+      REAL, DIMENSION(klon),      INTENT(IN)      ::  qt_th         ! total water specific humidity in thermals [kg/kg]: has not seen evap of precip
+      REAL, DIMENSION(klon),      INTENT(IN)      ::  thetal_th     ! Liquid potential temperature in thermals [K]: has not seen the evap of precip
+      REAL, DIMENSION(klon),      INTENT(IN)      ::  frac_th       ! Fraction of the mesh covered by thermals [0-1] 
+      REAL, DIMENSION(klon),      INTENT(IN)      ::  zpspsk        ! Exner potential
+      REAL, DIMENSION(klon),      INTENT(IN)      ::  paprsup       ! Pressure at top layer interface [Pa]
+      REAL, DIMENSION(klon),      INTENT(IN)      ::  paprsdn       ! Pressure at bottom layer interface [Pa]
+      REAL, DIMENSION(klon),      INTENT(IN)      ::  play          ! Pressure of layers [Pa]
+      REAL, DIMENSION(klon),      INTENT(IN)      ::  ratqs         ! Parameter that determines the width of the total water distrib.
+
+
+      INTEGER, DIMENSION(klon,klev), INTENT(INOUT) :: mpc_bl_points  ! grid points with convective (thermals) mixed phase clouds
+      
+      REAL, DIMENSION(klon),      INTENT(OUT)      ::  ctot         ! Cloud fraction [0-1]
+      REAL, DIMENSION(klon),      INTENT(OUT)      ::  ctot_vol     ! Volume cloud fraction [0-1]
+      REAL, DIMENSION(klon),      INTENT(OUT)      ::  qcloud       ! In cloud total water content [kg/kg] 
+      REAL, DIMENSION(klon),      INTENT(OUT)      ::  qincloud     ! In cloud condensed water content [kg/kg] 
+      REAL, DIMENSION(klon),      INTENT(OUT)      ::  icefrac      ! Fraction of ice in clouds [0-1]
+      REAL, DIMENSION(klon),      INTENT(OUT)      ::  cloudth_sth  ! mean saturation deficit in thermals
+      REAL, DIMENSION(klon),      INTENT(OUT)      ::  cloudth_senv ! mean saturation deficit in environment
+      REAL, DIMENSION(klon),      INTENT(OUT)      ::  cloudth_sigmath ! std of saturation deficit in thermals
+      REAL, DIMENSION(klon),      INTENT(OUT)      ::  cloudth_sigmaenv ! std of saturation deficit in environment
+
+
+! LOCAL VARIABLES
+
+      INTEGER itap,ind1,l,ig,iter,k 
+      INTEGER iflag_topthermals, niter
+
+      REAL qcth(klon)
+      REAL qcenv(klon)
+      REAL qctot(klon) 
+      REAL cth(klon)
+      REAL cenv(klon)   
+      REAL cth_vol(klon)
+      REAL cenv_vol(klon)
+      REAL qt_env(klon), thetal_env(klon)
+      REAL icefracenv(klon), icefracth(klon)
+      REAL sqrtpi,sqrt2,sqrt2pi
+      REAL alth,alenv,ath,aenv
+      REAL sth,senv,sigma1s,sigma2s,sigma1s_fraca,sigma1s_ratqs
+      REAL inverse_rho,beta,a_Brooks,b_Brooks,A_Maj_Brooks,Dx_Brooks,f_Brooks
+      REAL xth,xenv,exp_xenv1,exp_xenv2,exp_xth1,exp_xth2
+      REAL xth1,xth2,xenv1,xenv2,deltasth, deltasenv
+      REAL IntJ,IntI1,IntI2,IntI3,IntJ_CF,IntI1_CF,IntI3_CF,coeffqlenv,coeffqlth
+      REAL zdelta,qsatbef,zcor
+      REAL Tbefth(klon), Tbefenv(klon), zrho(klon), rhoth(klon)
+      REAL qlbef
+      REAL dqsatenv(klon), dqsatth(klon)
+      REAL erf
+      REAL zpdf_sig(klon),zpdf_k(klon),zpdf_delta(klon)
+      REAL zpdf_a(klon),zpdf_b(klon),zpdf_e1(klon),zpdf_e2(klon) 
+      REAL rhodz(klon)
+      REAL rho(klon)
+      REAL dz(klon)
+      REAL qslenv(klon), qslth(klon), qsienv(klon), qsith(klon)  
+      REAL alenvl, aenvl
+      REAL sthi, sthl, sthil, althl, athl, althi, athi, sthlc, deltasthc, sigma2sc
+      REAL senvi, senvl, qbase, sbase, qliqth, qiceth
+      REAL qmax, ttarget, stmp, cout, coutref, fraci
+      REAL maxi, mini, pas
+
+      ! Modifty the saturation deficit PDF in thermals 
+      ! in the presence of ice crystals
+      CHARACTER (len = 80) :: abort_message
+      CHARACTER (len = 20) :: routname = 'cloudth_mpc'
+
+
+!------------------------------------------------------------------------------
+! Initialisation
+!------------------------------------------------------------------------------
+
+
+! Few initial checksS
+
+      DO k = 1,klev
+      DO ind1 = 1, klon
+        rhodz(ind1) = (paprsdn(ind1)-paprsup(ind1))/rg !kg/m2
+        zrho(ind1)  = play(ind1)/temp(ind1)/rd !kg/m3
+        dz(ind1)    = rhodz(ind1)/zrho(ind1) !m : epaisseur de la couche en metre
+      END DO
+      END DO
+
+
+      icefracth(:)=0.
+      icefracenv(:)=0.
+      sqrt2pi=sqrt(2.*rpi)
+      sqrt2=sqrt(2.)
+      sqrtpi=sqrt(rpi)
+      icefrac(:)=0.
+
+!-------------------------------------------------------------------------------
+! Identify grid points with potential mixed-phase conditions
+!-------------------------------------------------------------------------------
+
+
+      DO ind1=1,klon
+            IF ((temp(ind1) .LT. RTT) .AND. (temp(ind1) .GT. temp_nowater) &
+            .AND. (ind2<=klev-2)  &
+            .AND. (frac_th(ind1).GT.min_frac_th_cld)) THEN
+                mpc_bl_points(ind1,ind2)=1
+            ELSE
+                mpc_bl_points(ind1,ind2)=0
+            ENDIF
+      ENDDO
+
+
+!-------------------------------------------------------------------------------
+! Thermal fraction calculation and standard deviation of the distribution
+!-------------------------------------------------------------------------------  
+
+! initialisations and calculation of temperature, humidity and saturation specific humidity
+
+DO ind1=1,klon
+  
+   rhodz(ind1)   = (paprsdn(ind1)-paprsup(ind1))/rg  ! kg/m2
+   rho(ind1)     = play(ind1)/temp(ind1)/rd          ! kg/m3
+   dz(ind1)      = rhodz(ind1)/rho(ind1)             ! m : epaisseur de la couche en metre
+   Tbefenv(ind1) = temp(ind1)
+   thetal_env(ind1) = Tbefenv(ind1)/zpspsk(ind1)
+   Tbefth(ind1)  = thetal_th(ind1)*zpspsk(ind1)
+   rhoth(ind1)   = play(ind1)/Tbefth(ind1)/RD
+   qt_env(ind1)  = (qt(ind1)-frac_th(ind1)*qt_th(ind1))/(1.-frac_th(ind1)) !qt = a*qtth + (1-a)*qtenv 
+
+ENDDO
+
+! Calculation of saturation specific humidity
+CALL CALC_QSAT_ECMWF(klon,Tbefenv,qt_env,play,RTT,1,.false.,qslenv,dqsatenv)
+CALL CALC_QSAT_ECMWF(klon,Tbefenv,qt_env,play,RTT,2,.false.,qsienv,dqsatenv)
+CALL CALC_QSAT_ECMWF(klon,Tbefth,qt_th,play,RTT,1,.false.,qslth,dqsatth)
+
+
+DO ind1=1,klon
+
+
+    IF (frac_th(ind1).GT.min_frac_th_cld) THEN !Thermal and environnement
+
+! unlike in the other cloudth routine, 
+! We consider distributions of the saturation deficit WRT liquid 
+! at positive AND negative celcius temperature
+! subsequently, cloud fraction corresponds to the part of the pdf corresponding
+! to superstauration with respect to liquid WHATEVER the temperature
+
+! Environment:
+
+
+        alenv=(0.622*RLVTT*qslenv(ind1))/(rd*thetal_env(ind1)**2)     
+        aenv=1./(1.+(alenv*RLVTT/rcpd))                             
+        senv=aenv*(qt_env(ind1)-qslenv(ind1))                           
+     
+
+! Thermals:
+
+
+        alth=(0.622*RLVTT*qslth(ind1))/(rd*thetal_th(ind1)**2)       
+        ath=1./(1.+(alth*RLVTT/rcpd))                                                         
+        sth=ath*(qt_th(ind1)-qslth(ind1))                      
+
+
+!       IF (mpc_bl_points(ind1,ind2) .EQ. 0) THEN ! No BL MPC
+
+
+! Standard deviation of the distributions
+
+           sigma1s_fraca = (sigma1s_factor**0.5)*(frac_th(ind1)**sigma1s_power) / &
+           &                (1-frac_th(ind1))*((sth-senv)**2)**0.5
+
+           IF (cloudth_ratqsmin>0.) THEN
+             sigma1s_ratqs = cloudth_ratqsmin*qt(ind1)
+           ELSE
+             sigma1s_ratqs = ratqs(ind1)*qt(ind1)
+           ENDIF
+ 
+           sigma1s = sigma1s_fraca + sigma1s_ratqs
+           IF (iflag_ratqs.eq.11) then
+              sigma1s = ratqs(ind1)*qt(ind1)*aenv
+           ENDIF
+           sigma2s=(sigma2s_factor*(((sth-senv)**2)**0.5)/((frac_th(ind1)+0.02)**sigma2s_power))+0.002*qt_th(ind1)
+
+
+           deltasenv=aenv*vert_alpha*sigma1s
+           deltasth=ath*vert_alpha_th*sigma2s
+
+           xenv1=-(senv+deltasenv)/(sqrt(2.)*sigma1s)
+           xenv2=-(senv-deltasenv)/(sqrt(2.)*sigma1s)
+           exp_xenv1 = exp(-1.*xenv1**2)
+           exp_xenv2 = exp(-1.*xenv2**2)
+           xth1=-(sth+deltasth)/(sqrt(2.)*sigma2s)
+           xth2=-(sth-deltasth)/(sqrt(2.)*sigma2s)
+           exp_xth1 = exp(-1.*xth1**2)
+           exp_xth2 = exp(-1.*xth2**2)
+      
+!surface CF
+
+           cth(ind1)=0.5*(1.-1.*erf(xth1))
+           cenv(ind1)=0.5*(1.-1.*erf(xenv1))
+           ctot(ind1)=frac_th(ind1)*cth(ind1)+(1.-1.*frac_th(ind1))*cenv(ind1) 
+
+
+!volume CF, condensed water and ice fraction
+
+            !environnement
+
+            IntJ=0.5*senv*(1-erf(xenv2))+(sigma1s/sqrt2pi)*exp_xenv2
+            IntJ_CF=0.5*(1.-1.*erf(xenv2))
+
+            IF (deltasenv .LT. 1.e-10) THEN 
+              qcenv(ind1)=IntJ
+              cenv_vol(ind1)=IntJ_CF
+            ELSE
+              IntI1=(((senv+deltasenv)**2+(sigma1s)**2)/(8*deltasenv))*(erf(xenv2)-erf(xenv1))
+              IntI2=(sigma1s**2/(4*deltasenv*sqrtpi))*(xenv1*exp_xenv1-xenv2*exp_xenv2)
+              IntI3=((sqrt2*sigma1s*(senv+deltasenv))/(4*sqrtpi*deltasenv))*(exp_xenv1-exp_xenv2)
+              IntI1_CF=((senv+deltasenv)*(erf(xenv2)-erf(xenv1)))/(4*deltasenv)
+              IntI3_CF=(sqrt2*sigma1s*(exp_xenv1-exp_xenv2))/(4*sqrtpi*deltasenv)
+              qcenv(ind1)=IntJ+IntI1+IntI2+IntI3
+              cenv_vol(ind1)=IntJ_CF+IntI1_CF+IntI3_CF
+              IF (Tbefenv(ind1) .LT. temp_nowater) THEN
+                  ! freeze all droplets in cirrus temperature regime
+                  icefracenv(ind1)=1. 
+              ENDIF
+            ENDIF
+             
+
+
+            !thermals
+
+            IntJ=0.5*sth*(1-erf(xth2))+(sigma2s/sqrt2pi)*exp_xth2
+            IntJ_CF=0.5*(1.-1.*erf(xth2))
+     
+            IF (deltasth .LT. 1.e-10) THEN
+              qcth(ind1)=IntJ
+              cth_vol(ind1)=IntJ_CF
+            ELSE
+              IntI1=(((sth+deltasth)**2+(sigma2s)**2)/(8*deltasth))*(erf(xth2)-erf(xth1))
+              IntI2=(sigma2s**2/(4*deltasth*sqrtpi))*(xth1*exp_xth1-xth2*exp_xth2)
+              IntI3=((sqrt2*sigma2s*(sth+deltasth))/(4*sqrtpi*deltasth))*(exp_xth1-exp_xth2)
+              IntI1_CF=((sth+deltasth)*(erf(xth2)-erf(xth1)))/(4*deltasth)
+              IntI3_CF=(sqrt2*sigma2s*(exp_xth1-exp_xth2))/(4*sqrtpi*deltasth)
+              qcth(ind1)=IntJ+IntI1+IntI2+IntI3
+              cth_vol(ind1)=IntJ_CF+IntI1_CF+IntI3_CF
+              IF (Tbefth(ind1) .LT. temp_nowater) THEN
+                  ! freeze all droplets in cirrus temperature regime
+                  icefracth(ind1)=1.
+              ENDIF
+
+            ENDIF
+
+            qctot(ind1)=frac_th(ind1)*qcth(ind1)+(1.-1.*frac_th(ind1))*qcenv(ind1)
+            ctot_vol(ind1)=frac_th(ind1)*cth_vol(ind1)+(1.-1.*frac_th(ind1))*cenv_vol(ind1)
+
+            IF (cenv(ind1).LT.min_neb_th.and.cth(ind1).LT.min_neb_th) THEN
+                ctot(ind1)=0.
+                ctot_vol(ind1)=0.
+                qcloud(ind1)=qslenv(ind1)
+                qincloud(ind1)=0.
+                icefrac(ind1)=0.
+            ELSE               
+                qcloud(ind1)=qctot(ind1)/ctot(ind1)+qslenv(ind1)
+                qincloud(ind1)=qctot(ind1)/ctot(ind1)
+                IF (qctot(ind1) .GT. 0) THEN
+                  icefrac(ind1)=(frac_th(ind1)*qcth(ind1)*icefracth(ind1)+(1.-1.*frac_th(ind1))*qcenv(ind1)*icefracenv(ind1))/qctot(ind1)
+                  icefrac(ind1)=max(min(1.,icefrac(ind1)), 0.)
+                ENDIF
+            ENDIF 
+
+
+!        ELSE ! mpc_bl_points>0
+
+    ELSE  ! gaussian for environment only
+
+      
+        alenv=(0.622*RLVTT*qslenv(ind1))/(rd*thetal_env(ind1)**2)
+        aenv=1./(1.+(alenv*RLVTT/rcpd))
+        senv=aenv*(qt_env(ind1)-qslenv(ind1))
+        sth=0.
+        sigma1s=ratqs(ind1)*qt_env(ind1)
+        sigma2s=0.
+
+        xenv=senv/(sqrt(2.)*sigma1s)
+        cenv(ind1)=0.5*(1.-1.*erf(xenv))
+        ctot(ind1)=0.5*(1.+1.*erf(xenv))
+        ctot_vol(ind1)=ctot(ind1)
+        qctot(ind1)=sigma1s*((exp(-1.*xenv**2)/sqrt2pi)+xenv*sqrt(2.)*cenv(ind1))
+
+
+        IF (ctot(ind1).LT.min_neb_th) THEN
+          ctot(ind1)=0.
+          qcloud(ind1)=qslenv(ind1)
+          qincloud(ind1)=0.
+        ELSE 
+          qcloud(ind1)=qctot(ind1)/ctot(ind1)+qslenv(ind1)
+          qincloud(ind1)=MAX(qctot(ind1)/ctot(ind1),0.)
+        ENDIF
+ 
+
+    ENDIF       ! From the separation (thermal/envrionnement) and (environnement only,) l.335 et l.492
+
+    ! Outputs used to check the PDFs
+    cloudth_senv(ind1) = senv
+    cloudth_sth(ind1) = sth
+    cloudth_sigmaenv(ind1) = sigma1s
+    cloudth_sigmath(ind1) = sigma2s
+
+
+    ENDDO       !loop on klon
+
+
+RETURN
+
+
+END SUBROUTINE cloudth_mpc
+
+
+
+!        ELSE ! mpc_bl_points>0
+!
+!            ! Treat boundary layer mixed phase clouds
+!            
+!            ! thermals
+!            !=========
+!
+!           ! ice phase
+!           !...........
+!
+!            qiceth=0.
+!            deltazlev_mpc=dz(ind1,:)
+!            temp_mpc=ztla(ind1,:)*zpspsk(ind1,:)
+!            pres_mpc=pplay(ind1,:)
+!            fraca_mpc=fraca(ind1,:)
+!            snowf_mpc=snowflux(ind1,:)
+!            iflag_topthermals=0
+!            IF ((mpc_bl_points(ind1,ind2) .EQ. 1) .AND. (mpc_bl_points(ind1,ind2+1) .EQ. 0))  THEN
+!                iflag_topthermals = 1
+!            ELSE IF ((mpc_bl_points(ind1,ind2) .EQ. 1) .AND. (mpc_bl_points(ind1,ind2+1) .EQ. 1) & 
+!                    .AND. (mpc_bl_points(ind1,ind2+2) .EQ. 0) ) THEN
+!                iflag_topthermals = 2
+!            ELSE 
+!                iflag_topthermals = 0
+!            ENDIF
+!
+!            CALL ICE_MPC_BL_CLOUDS(ind1,ind2,klev,Ni,Ei,C_cap,d_top,iflag_topthermals,temp_mpc,pres_mpc,zqta(ind1,:), &
+!                                   qsith(ind1,:),qlth(ind1,:),deltazlev_mpc,wiceth(ind1,:),fraca_mpc,qith(ind1,:))
+!
+!            ! qmax calculation
+!            sigma2s=(sigma2s_factor*((MAX((sthl-senvl),0.)**2)**0.5)/((fraca(ind1,ind2)+0.02)**sigma2s_power))+0.002*zqta(ind1,ind2)
+!            deltasth=athl*vert_alpha_th*sigma2s
+!            xth1=-(sthl+deltasth)/(sqrt(2.)*sigma2s)
+!            xth2=-(sthl-deltasth)/(sqrt(2.)*sigma2s)
+!            exp_xth1 = exp(-1.*xth1**2)
+!            exp_xth2 = exp(-1.*xth2**2)
+!            IntJ=0.5*sthl*(1-erf(xth2))+(sigma2s/sqrt2pi)*exp_xth2
+!            IntJ_CF=0.5*(1.-1.*erf(xth2))
+!            IntI1=(((sthl+deltasth)**2+(sigma2s)**2)/(8*deltasth))*(erf(xth2)-erf(xth1))
+!            IntI2=(sigma2s**2/(4*deltasth*sqrtpi))*(xth1*exp_xth1-xth2*exp_xth2)
+!            IntI3=((sqrt2*sigma2s*(sthl+deltasth))/(4*sqrtpi*deltasth))*(exp_xth1-exp_xth2)
+!            IntI1_CF=((sthl+deltasth)*(erf(xth2)-erf(xth1)))/(4*deltasth)
+!            IntI3_CF=(sqrt2*sigma2s*(exp_xth1-exp_xth2))/(4*sqrtpi*deltasth)
+!            qmax=MAX(IntJ+IntI1+IntI2+IntI3,0.)
+!
+!
+!            ! Liquid phase
+!            !................
+!            ! We account for the effect of ice crystals in thermals on sthl
+!            ! and on the width of the distribution
+!
+!            sthlc=sthl*1./(1.+C_mpc*qith(ind1,ind2))  &
+!                + (1.-1./(1.+C_mpc*qith(ind1,ind2))) * athl*(qsith(ind1,ind2)-qslth(ind1))  
+!
+!            sigma2sc=(sigma2s_factor*((MAX((sthlc-senvl),0.)**2)**0.5) &
+!                 /((fraca(ind1,ind2)+0.02)**sigma2s_power)) &
+!                 +0.002*zqta(ind1,ind2)
+!            deltasthc=athl*vert_alpha_th*sigma2sc
+!     
+!            
+!            xth1=-(sthlc+deltasthc)/(sqrt(2.)*sigma2sc)
+!            xth2=-(sthlc-deltasthc)/(sqrt(2.)*sigma2sc)           
+!            exp_xth1 = exp(-1.*xth1**2)
+!            exp_xth2 = exp(-1.*xth2**2)
+!            IntJ=0.5*sthlc*(1-erf(xth2))+(sigma2sc/sqrt2pi)*exp_xth2
+!            IntJ_CF=0.5*(1.-1.*erf(xth2))
+!            IntI1=(((sthlc+deltasthc)**2+(sigma2sc)**2)/(8*deltasthc))*(erf(xth2)-erf(xth1))
+!            IntI2=(sigma2sc**2/(4*deltasthc*sqrtpi))*(xth1*exp_xth1-xth2*exp_xth2)
+!            IntI3=((sqrt2*sigma2sc*(sthlc+deltasthc))/(4*sqrtpi*deltasthc))*(exp_xth1-exp_xth2)
+!            IntI1_CF=((sthlc+deltasthc)*(erf(xth2)-erf(xth1)))/(4*deltasthc)
+!            IntI3_CF=(sqrt2*sigma2sc*(exp_xth1-exp_xth2))/(4*sqrtpi*deltasthc)
+!            qliqth=IntJ+IntI1+IntI2+IntI3
+!            
+!            qlth(ind1,ind2)=MAX(0.,qliqth)
+!
+!            ! Condensed water
+!            
+!            qcth(ind1,ind2)=qlth(ind1,ind2)+qith(ind1,ind2)
+!
+!
+!            ! consistency with subgrid distribution
+!           
+!             IF ((qcth(ind1,ind2) .GT. qmax) .AND. (qcth(ind1,ind2) .GT. 0)) THEN
+!                 fraci=qith(ind1,ind2)/qcth(ind1,ind2)
+!                 qcth(ind1,ind2)=qmax
+!                 qith(ind1,ind2)=fraci*qmax
+!                 qlth(ind1,ind2)=(1.-fraci)*qmax
+!             ENDIF
+!
+!            ! Cloud Fraction
+!            !...............
+!            ! calculation of qbase which is the value of the water vapor within mixed phase clouds
+!            ! such that the total water in cloud = qbase+qliqth+qiceth
+!            ! sbase is the value of s such that int_sbase^\intfy s ds = cloud fraction
+!            ! sbase and qbase calculation (note that sbase is wrt liq so negative)
+!            ! look for an approximate solution with iteration
+!            
+!            ttarget=qcth(ind1,ind2)
+!            mini= athl*(qsith(ind1,ind2)-qslth(ind1))
+!            maxi= 0. !athl*(3.*sqrt(sigma2s))
+!            niter=20
+!            pas=(maxi-mini)/niter
+!            stmp=mini
+!            sbase=stmp
+!            coutref=1.E6
+!            DO iter=1,niter
+!                cout=ABS(sigma2s/SQRT(2.*RPI)*EXP(-((sthl-stmp)/sigma2s)**2)+(sthl-stmp)/SQRT(2.)*(1.-erf(-(sthl-stmp)/sigma2s)) &
+!                     + stmp/2.*(1.-erf(-(sthl-stmp)/sigma2s)) -ttarget)
+!               IF (cout .LT. coutref) THEN
+!                     sbase=stmp
+!                     coutref=cout
+!                ELSE
+!                     stmp=stmp+pas
+!                ENDIF
+!            ENDDO
+!            qbase=MAX(0., sbase/athl+qslth(ind1))
+!
+!            ! surface cloud fraction in thermals
+!            cth(ind1,ind2)=0.5*(1.-erf((sbase-sthl)/sqrt(2.)/sigma2s))
+!            cth(ind1,ind2)=MIN(MAX(cth(ind1,ind2),0.),1.)
+!
+!
+!            !volume cloud fraction in thermals
+!            !to be checked
+!            xth1=-(sthl+deltasth-sbase)/(sqrt(2.)*sigma2s)
+!            xth2=-(sthl-deltasth-sbase)/(sqrt(2.)*sigma2s)           
+!            exp_xth1 = exp(-1.*xth1**2)
+!            exp_xth2 = exp(-1.*xth2**2)
+!
+!            IntJ=0.5*sthl*(1-erf(xth2))+(sigma2s/sqrt2pi)*exp_xth2
+!            IntJ_CF=0.5*(1.-1.*erf(xth2))
+!     
+!            IF (deltasth .LT. 1.e-10) THEN
+!              cth_vol(ind1,ind2)=IntJ_CF
+!            ELSE
+!              IntI1=(((sthl+deltasth-sbase)**2+(sigma2s)**2)/(8*deltasth))*(erf(xth2)-erf(xth1))
+!              IntI2=(sigma2s**2/(4*deltasth*sqrtpi))*(xth1*exp_xth1-xth2*exp_xth2)
+!              IntI3=((sqrt2*sigma2s*(sthl+deltasth))/(4*sqrtpi*deltasth))*(exp_xth1-exp_xth2)
+!              IntI1_CF=((sthl-sbase+deltasth)*(erf(xth2)-erf(xth1)))/(4*deltasth)
+!              IntI3_CF=(sqrt2*sigma2s*(exp_xth1-exp_xth2))/(4*sqrtpi*deltasth)
+!              cth_vol(ind1,ind2)=IntJ_CF+IntI1_CF+IntI3_CF
+!            ENDIF
+!              cth_vol(ind1,ind2)=MIN(MAX(0.,cth_vol(ind1,ind2)),1.)
+!
+!
+!
+!            ! Environment
+!            !=============
+!            ! In the environment/downdrafts, only liquid clouds
+!            ! See Shupe et al. 2008, JAS
+!
+!            ! standard deviation of the distribution in the environment
+!            sth=sthl
+!            senv=senvl
+!            sigma1s_fraca = (sigma1s_factor**0.5)*(fraca(ind1,ind2)**sigma1s_power) / &
+!                          &                (1-fraca(ind1,ind2))*(MAX((sth-senv),0.)**2)**0.5
+!            ! for mixed phase clouds, there is no contribution from large scale ratqs to the distribution
+!            ! in the environement
+!
+!            sigma1s_ratqs=1E-10
+!            IF (cloudth_ratqsmin>0.) THEN
+!                sigma1s_ratqs = cloudth_ratqsmin*po(ind1)
+!            ENDIF
+!
+!            sigma1s = sigma1s_fraca + sigma1s_ratqs
+!            IF (iflag_ratqs.eq.11) then
+!               sigma1s = ratqs(ind1,ind2)*po(ind1)*aenv
+!            ENDIF
+!            IF (iflag_ratqs.eq.11) then
+!              sigma1s = ratqs(ind1,ind2)*po(ind1)*aenvl
+!            ENDIF
+!            deltasenv=aenvl*vert_alpha*sigma1s
+!            xenv1=-(senvl+deltasenv)/(sqrt(2.)*sigma1s)
+!            xenv2=-(senvl-deltasenv)/(sqrt(2.)*sigma1s)
+!            exp_xenv1 = exp(-1.*xenv1**2)
+!            exp_xenv2 = exp(-1.*xenv2**2)
+!
+!            !surface CF
+!            cenv(ind1,ind2)=0.5*(1.-1.*erf(xenv1))
+!
+!            !volume CF and condensed water
+!            IntJ=0.5*senvl*(1-erf(xenv2))+(sigma1s/sqrt2pi)*exp_xenv2
+!            IntJ_CF=0.5*(1.-1.*erf(xenv2))
+!
+!            IF (deltasenv .LT. 1.e-10) THEN
+!              qcenv(ind1,ind2)=IntJ
+!              cenv_vol(ind1,ind2)=IntJ_CF
+!            ELSE
+!              IntI1=(((senvl+deltasenv)**2+(sigma1s)**2)/(8*deltasenv))*(erf(xenv2)-erf(xenv1))
+!              IntI2=(sigma1s**2/(4*deltasenv*sqrtpi))*(xenv1*exp_xenv1-xenv2*exp_xenv2)
+!              IntI3=((sqrt2*sigma1s*(senv+deltasenv))/(4*sqrtpi*deltasenv))*(exp_xenv1-exp_xenv2)
+!              IntI1_CF=((senvl+deltasenv)*(erf(xenv2)-erf(xenv1)))/(4*deltasenv)
+!              IntI3_CF=(sqrt2*sigma1s*(exp_xenv1-exp_xenv2))/(4*sqrtpi*deltasenv)
+!              qcenv(ind1,ind2)=IntJ+IntI1+IntI2+IntI3 ! only liquid water in environment
+!              cenv_vol(ind1,ind2)=IntJ_CF+IntI1_CF+IntI3_CF
+!            ENDIF
+!
+!            qcenv(ind1,ind2)=MAX(qcenv(ind1,ind2),0.)
+!            cenv_vol(ind1,ind2)=MIN(MAX(cenv_vol(ind1,ind2),0.),1.)
+!
+!
+!            
+!            ! Thermals + environment
+!            ! ======================= 
+!            ctot(ind1,ind2)=fraca(ind1,ind2)*cth(ind1,ind2)+(1.-1.*fraca(ind1,ind2))*cenv(ind1,ind2) 
+!            qctot(ind1,ind2)=fraca(ind1,ind2)*qcth(ind1,ind2)+(1.-1.*fraca(ind1,ind2))*qcenv(ind1,ind2)
+!            ctot_vol(ind1,ind2)=fraca(ind1,ind2)*cth_vol(ind1,ind2)+(1.-1.*fraca(ind1,ind2))*cenv_vol(ind1,ind2)
+!            IF (qcth(ind1,ind2) .GT. 0) THEN
+!               icefrac(ind1,ind2)=fraca(ind1,ind2)*qith(ind1,ind2) &
+!                    /(fraca(ind1,ind2)*qcth(ind1,ind2) &
+!                    +(1.-1.*fraca(ind1,ind2))*qcenv(ind1,ind2))
+!                icefrac(ind1,ind2)=MAX(MIN(1.,icefrac(ind1,ind2)),0.)
+!            ELSE
+!                icefrac(ind1,ind2)=0.
+!            ENDIF
+!
+!            IF (cenv(ind1,ind2).LT.1.e-10.or.cth(ind1,ind2).LT.1.e-10) THEN
+!                ctot(ind1,ind2)=0.
+!                ctot_vol(ind1,ind2)=0.
+!                qincloud(ind1)=0.
+!                qcloud(ind1)=zqsatenv(ind1)
+!            ELSE               
+!                qcloud(ind1)=fraca(ind1,ind2)*(qcth(ind1,ind2)/cth(ind1,ind2)+qbase) &
+!                            +(1.-1.*fraca(ind1,ind2))*(qcenv(ind1,ind2)/cenv(ind1,ind2)+qslenv(ind1))
+!                qincloud(ind1)=MAX(fraca(ind1,ind2)*(qcth(ind1,ind2)/cth(ind1,ind2)) &
+!                            +(1.-1.*fraca(ind1,ind2))*(qcenv(ind1,ind2)/cenv(ind1,ind2)),0.)
+!            ENDIF 
+!
+!        ENDIF ! mpc_bl_points
+
+
+
+!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+SUBROUTINE ICE_MPC_BL_CLOUDS(ind1,ind2,klev,Ni,Ei,C_cap,d_top,iflag_topthermals,temp,pres,qth,qsith,qlth,deltazlev,vith,fraca,qith)
+
+! parameterization of ice for boundary
+! layer mixed-phase clouds assuming a stationary system
+!
+! Note that vapor deposition on ice crystals and riming of liquid droplets
+! depend on the ice number concentration Ni
+! One could assume that Ni depends on qi, e.g.,  Ni=beta*(qi*rho)**xi
+! and use values from Hong et al. 2004, MWR for instance
+! One may also estimate Ni as a function of T, as in Meyers 1922 or Fletcher 1962 
+! One could also think of a more complex expression of Ni;
+! function of qi, T, the concentration in aerosols or INP ..
+! Here we prefer fixing Ni to a tuning parameter
+! By default we take 2.0L-1=2.0e3m-3, median value from measured vertical profiles near Svalbard
+! in Mioche et al. 2017
+!
+!
+! References:
+!------------
+! This parameterization is thoroughly described in Vignon et al. 
+!
+! More specifically
+! for the Water vapor deposition process:
+!
+! Rotstayn, L. D., 1997: A physically based scheme for the treat-
+! ment of stratiform cloudfs and precipitation in large-scale
+! models. I: Description and evaluation of the microphysical
+! processes. Quart. J. Roy. Meteor. Soc., 123, 1227–1282.
+!
+!  Morrison, H., and A. Gettelman, 2008: A new two-moment bulk
+!  stratiform cloud microphysics scheme in the NCAR Com-
+!  munity Atmosphere Model (CAM3). Part I: Description and
+!  numerical tests. J. Climate, 21, 3642–3659
+!
+! for the Riming process:
+!
+! Rutledge, S. A., and P. V. Hobbs, 1983: The mesoscale and micro-
+! scale structure and organization of clouds and precipitation in
+! midlatitude cyclones. VII: A model for the ‘‘seeder-feeder’’
+! process in warm-frontal rainbands. J. Atmos. Sci., 40, 1185–1206
+!
+! Thompson, G., R. M. Rasmussen, and K. Manning, 004: Explicit
+! forecasts of winter precipitation using an improved bulk
+! microphysics scheme. Part I: Description and sensitivityThompson, G., R. M. Rasmussen, and K. Manning, 2004: Explicit
+! forecasts of winter precipitation using an improved bulk
+! microphysics scheme. Part I: Description and sensitivity analysis. Mon. Wea. Rev., 132, 519–542
+!
+! For the formation of clouds by thermals:
+!
+! Rio, C., & Hourdin, F. (2008). A thermal plume model for the convective boundary layer : Representation of cumulus clouds. Journal of
+! the Atmospheric Sciences, 65, 407–425.
+!
+! Jam, A., Hourdin, F., Rio, C., & Couvreux, F. (2013). Resolved versus parametrized boundary-layer plumes. Part III: Derivation of a
+! statistical scheme for cumulus clouds. Boundary-layer Meteorology, 147, 421–441. https://doi.org/10.1007/s10546-012-9789-3
+!
+!
+!
+! Contact: Etienne Vignon, etienne.vignon@lmd.ipsl.fr
+!=============================================================================
+
+    use phys_state_var_mod, ONLY : fm_therm, detr_therm, entr_therm
+
+    IMPLICIT none
+
+    INCLUDE "YOMCST.h"
+
+    INTEGER, INTENT(IN) :: ind1,ind2, klev           ! horizontal and vertical indices and dimensions
+    INTEGER, INTENT(IN) :: iflag_topthermals         ! uppermost layer of thermals ?
+    REAL, INTENT(IN)    :: Ni                        ! ice number concentration [m-3]
+    REAL, INTENT(IN)    :: Ei                        ! ice-droplet collision efficiency
+    REAL, INTENT(IN)    :: C_cap                     ! ice crystal capacitance
+    REAL, INTENT(IN)    :: d_top                     ! cloud-top ice crystal mixing parameter
+    REAL,  DIMENSION(klev), INTENT(IN) :: temp       ! temperature [K] within thermals
+    REAL,  DIMENSION(klev), INTENT(IN) :: pres       ! pressure [Pa]
+    REAL,  DIMENSION(klev), INTENT(IN) :: qth        ! mean specific water content in thermals [kg/kg]
+    REAL,  DIMENSION(klev), INTENT(IN) :: qsith        ! saturation specific humidity wrt ice in thermals [kg/kg]
+    REAL,  DIMENSION(klev), INTENT(IN) :: qlth       ! condensed liquid water in thermals, approximated value [kg/kg]
+    REAL,  DIMENSION(klev), INTENT(IN) :: deltazlev  ! layer thickness [m]
+    REAL,  DIMENSION(klev), INTENT(IN) :: vith       ! ice crystal fall velocity [m/s]
+    REAL,  DIMENSION(klev+1), INTENT(IN) :: fraca      ! fraction of the mesh covered by thermals
+    REAL,  DIMENSION(klev), INTENT(INOUT) :: qith       ! condensed ice water , thermals [kg/kg]
+
+
+    INTEGER ind2p1,ind2p2
+    REAL rho(klev)
+    REAL unsurtaudet, unsurtaustardep, unsurtaurim
+    REAL qi, AA, BB, Ka, Dv, rhoi
+    REAL p0, t0, fp1, fp2
+    REAL alpha, flux_term
+    REAL det_term, precip_term, rim_term, dep_term
+
+
+    ind2p1=ind2+1
+    ind2p2=ind2+2
+
+    rho=pres/temp/RD  ! air density kg/m3
+
+    Ka=2.4e-2      ! thermal conductivity of the air, SI
+    p0=101325.0    ! ref pressure
+    T0=273.15      ! ref temp
+    rhoi=500.0     ! cloud ice density following Reisner et al. 1998
+    alpha=700.     ! fallvelocity param
+
+
+    IF (iflag_topthermals .GT. 0) THEN ! uppermost thermals levels
+
+    Dv=0.0001*0.211*(p0/pres(ind2))*((temp(ind2)/T0)**1.94) ! water vapor diffusivity in air, SI
+
+    ! Detrainment term:
+
+    unsurtaudet=detr_therm(ind1,ind2)/rho(ind2)/deltazlev(ind2)
+ 
+
+    ! Deposition term
+    AA=RLSTT/Ka/temp(ind2)*(RLSTT/RV/temp(ind2)-1.)
+    BB=1./(rho(ind2)*Dv*qsith(ind2))
+    unsurtaustardep=C_cap*(Ni**0.66)*(qth(ind2)-qsith(ind2))/qsith(ind2) &
+                    *4.*RPI/(AA+BB)*(6.*rho(ind2)/rhoi/RPI/Gamma(4.))**(0.33)
+
+    ! Riming term  neglected at this level
+    !unsurtaurim=rho(ind2)*alpha*3./rhoi/2.*Ei*qlth(ind2)*((p0/pres(ind2))**0.4)
+
+    qi=fraca(ind2)*unsurtaustardep/MAX((d_top*unsurtaudet),1E-12)
+    qi=MAX(qi,0.)**(3./2.)
+
+    ELSE ! other levels, estimate qi(k) from variables at k+1 and k+2
+
+    Dv=0.0001*0.211*(p0/pres(ind2p1))*((temp(ind2p1)/T0)**1.94) ! water vapor diffusivity in air, SI
+
+    ! Detrainment term:
+
+    unsurtaudet=detr_therm(ind1,ind2p1)/rho(ind2p1)/deltazlev(ind2p1)
+    det_term=-unsurtaudet*qith(ind2p1)*rho(ind2p1)
+    
+    
+    ! Deposition term
+
+    AA=RLSTT/Ka/temp(ind2p1)*(RLSTT/RV/temp(ind2p1)-1.)
+    BB=1./(rho(ind2p1)*Dv*qsith(ind2p1))
+    unsurtaustardep=C_cap*(Ni**0.66)*(qth(ind2p1)-qsith(ind2p1)) &
+         /qsith(ind2p1)*4.*RPI/(AA+BB) &
+         *(6.*rho(ind2p1)/rhoi/RPI/Gamma(4.))**(0.33)
+    dep_term=rho(ind2p1)*fraca(ind2p1)*(qith(ind2p1)**0.33)*unsurtaustardep
+ 
+    ! Riming term
+
+    unsurtaurim=rho(ind2p1)*alpha*3./rhoi/2.*Ei*qlth(ind2p1)*((p0/pres(ind2p1))**0.4)
+    rim_term=rho(ind2p1)*fraca(ind2p1)*qith(ind2p1)*unsurtaurim
+
+    ! Precip term
+
+    ! We assume that there is no solid precipitation outside thermals 
+    ! so the precipitation flux within thermals is equal to the precipitation flux
+    ! at mesh-scale divided by  thermals fraction
+    
+    fp2=0.
+    fp1=0.
+    IF (fraca(ind2p1) .GT. 0.) THEN
+    fp2=-qith(ind2p2)*rho(ind2p2)*vith(ind2p2)*fraca(ind2p2)! flux defined positive upward
+    fp1=-qith(ind2p1)*rho(ind2p1)*vith(ind2p1)*fraca(ind2p1)
+    ENDIF
+
+    precip_term=-1./deltazlev(ind2p1)*(fp2-fp1)
+
+    ! Calculation in a top-to-bottom loop
+
+    IF (fm_therm(ind1,ind2p1) .GT. 0.) THEN
+          qi= 1./fm_therm(ind1,ind2p1)* &
+              (deltazlev(ind2p1)*(-rim_term-dep_term-det_term-precip_term) + &
+              fm_therm(ind1,ind2p2)*(qith(ind2p1)))
+    END IF
+
+    ENDIF ! top thermals
+
+    qith(ind2)=MAX(0.,qi)
+
+    RETURN
+
+END SUBROUTINE ICE_MPC_BL_CLOUDS
+
+END MODULE lmdz_cloudth
Index: DZ6/trunk/libf/phylmd/lmdz_cloudth_ini.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/lmdz_cloudth_ini.F90	(revision 5267)
+++ 	(revision )
@@ -1,53 +1,0 @@
-module lmdz_cloudth_ini
-
-real, save, protected :: C_cap ,cloudth_ratqsmin ,sigma1s_factor ,sigma1s_power ,sigma2s_factor ,sigma2s_power ,vert_alpha_th ,vert_alpha ,C_mpc , d_top , Ei , Ni
-integer, save, protected :: iflag_cloudth_vert_noratqs,iflag_cloudth_vert,iflag_ratqs
-
-!$OMP THREADPRIVATE(C_cap ,cloudth_ratqsmin ,sigma1s_factor ,sigma1s_power ,sigma2s_factor ,sigma2s_power ,vert_alpha_th ,vert_alpha ,C_mpc , d_top , Ei , Ni)
-!$OMP THREADPRIVATE(iflag_cloudth_vert_noratqs,iflag_cloudth_vert,iflag_ratqs)
-
-
-contains
-
-subroutine cloudth_ini(iflag_cloudth_vert_in,iflag_ratqs_in)
-
-use ioipsl_getin_p_mod, ONLY : getin_p
-implicit none
-integer, intent(in) :: iflag_cloudth_vert_in,iflag_ratqs_in
-
-
-        iflag_cloudth_vert=iflag_cloudth_vert_in
-        iflag_ratqs=iflag_ratqs_in
-
-        vert_alpha=0.5
-        sigma1s_factor=1.1
-        sigma1s_power=0.6
-        sigma2s_factor=0.09
-        sigma2s_power=0.5
-        cloudth_ratqsmin=-1.
-        iflag_cloudth_vert_noratqs=0
-        C_mpc=1.e4
-        Ni=2.0e3
-        Ei=0.5
-        C_cap=0.5
-        d_top=1.2
-
-
-        CALL getin_p('C_cap', C_cap)
-        CALL getin_p('cloudth_ratqsmin',cloudth_ratqsmin)
-        CALL getin_p('cloudth_sigma1s_factor',sigma1s_factor)
-        CALL getin_p('cloudth_sigma1s_power',sigma1s_power)
-        CALL getin_p('cloudth_sigma2s_factor',sigma2s_factor)
-        CALL getin_p('cloudth_sigma2s_power',sigma2s_power)
-        CALL getin_p('cloudth_vert_alpha',vert_alpha)
-        vert_alpha_th=vert_alpha
-        CALL getin_p('cloudth_vert_alpha_th',vert_alpha_th)
-        CALL getin_p('C_mpc',C_mpc)
-        CALL getin_p('d_top', d_top)
-        CALL getin_p('Ei', Ei)
-        CALL getin_p('iflag_cloudth_vert_noratqs',iflag_cloudth_vert_noratqs)
-        CALL getin_p('Ni', Ni)
-
-end subroutine cloudth_ini
-
-end module lmdz_cloudth_ini
Index: /LMDZ6/trunk/libf/phylmd/lmdz_cloudth_ini.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/lmdz_cloudth_ini.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/lmdz_cloudth_ini.f90	(revision 5268)
@@ -0,0 +1,53 @@
+module lmdz_cloudth_ini
+
+real, save, protected :: C_cap ,cloudth_ratqsmin ,sigma1s_factor ,sigma1s_power ,sigma2s_factor ,sigma2s_power ,vert_alpha_th ,vert_alpha ,C_mpc , d_top , Ei , Ni
+integer, save, protected :: iflag_cloudth_vert_noratqs,iflag_cloudth_vert,iflag_ratqs
+
+!$OMP THREADPRIVATE(C_cap ,cloudth_ratqsmin ,sigma1s_factor ,sigma1s_power ,sigma2s_factor ,sigma2s_power ,vert_alpha_th ,vert_alpha ,C_mpc , d_top , Ei , Ni)
+!$OMP THREADPRIVATE(iflag_cloudth_vert_noratqs,iflag_cloudth_vert,iflag_ratqs)
+
+
+contains
+
+subroutine cloudth_ini(iflag_cloudth_vert_in,iflag_ratqs_in)
+
+use ioipsl_getin_p_mod, ONLY : getin_p
+implicit none
+integer, intent(in) :: iflag_cloudth_vert_in,iflag_ratqs_in
+
+
+        iflag_cloudth_vert=iflag_cloudth_vert_in
+        iflag_ratqs=iflag_ratqs_in
+
+        vert_alpha=0.5
+        sigma1s_factor=1.1
+        sigma1s_power=0.6
+        sigma2s_factor=0.09
+        sigma2s_power=0.5
+        cloudth_ratqsmin=-1.
+        iflag_cloudth_vert_noratqs=0
+        C_mpc=1.e4
+        Ni=2.0e3
+        Ei=0.5
+        C_cap=0.5
+        d_top=1.2
+
+
+        CALL getin_p('C_cap', C_cap)
+        CALL getin_p('cloudth_ratqsmin',cloudth_ratqsmin)
+        CALL getin_p('cloudth_sigma1s_factor',sigma1s_factor)
+        CALL getin_p('cloudth_sigma1s_power',sigma1s_power)
+        CALL getin_p('cloudth_sigma2s_factor',sigma2s_factor)
+        CALL getin_p('cloudth_sigma2s_power',sigma2s_power)
+        CALL getin_p('cloudth_vert_alpha',vert_alpha)
+        vert_alpha_th=vert_alpha
+        CALL getin_p('cloudth_vert_alpha_th',vert_alpha_th)
+        CALL getin_p('C_mpc',C_mpc)
+        CALL getin_p('d_top', d_top)
+        CALL getin_p('Ei', Ei)
+        CALL getin_p('iflag_cloudth_vert_noratqs',iflag_cloudth_vert_noratqs)
+        CALL getin_p('Ni', Ni)
+
+end subroutine cloudth_ini
+
+end module lmdz_cloudth_ini
Index: DZ6/trunk/libf/phylmd/lmdz_lscp.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/lmdz_lscp.F90	(revision 5267)
+++ 	(revision )
@@ -1,1635 +1,0 @@
-MODULE lmdz_lscp
-
-IMPLICIT NONE
-
-CONTAINS
-
-!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-SUBROUTINE lscp(klon,klev,dtime,missing_val,            &
-     paprs,pplay,temp,qt,qice_save,ptconv,ratqs,sigma_qtherm, &
-     d_t, d_q, d_ql, d_qi, rneb, rneblsvol,             &
-     pfraclr, pfracld,                                  &
-     cldfraliq, sigma2_icefracturb,mean_icefracturb,    &
-     radocond, radicefrac, rain, snow,                  &
-     frac_impa, frac_nucl, beta,                        &
-     prfl, psfl, rhcl, qta, fraca,                      &
-     tv, pspsk, tla, thl, iflag_cld_th,                 &
-     iflag_ice_thermo, distcltop, temp_cltop,           &
-     tke, tke_dissip,                                   &
-     cell_area,                                         &
-     cf_seri, rvc_seri, u_seri, v_seri,                 &
-     qsub, qissr, qcld, subfra, issrfra, gamma_cond,    &
-     ratio_qi_qtot, dcf_sub, dcf_con, dcf_mix,          &
-     dqi_adj, dqi_sub, dqi_con, dqi_mix, dqvc_adj,      &
-     dqvc_sub, dqvc_con, dqvc_mix, qsatl, qsati,        &
-     Tcontr, qcontr, qcontr2, fcontrN, fcontrP, dcf_avi,&
-     dqi_avi, dqvc_avi, flight_dist, flight_h2o,        &
-     cloudth_sth,cloudth_senv,cloudth_sigmath,cloudth_sigmaenv, &
-     qraindiag, qsnowdiag, dqreva, dqssub, dqrauto,     &
-     dqrcol, dqrmelt, dqrfreez, dqsauto, dqsagg, dqsrim,&
-     dqsmelt, dqsfreez)
-
-!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-! Authors: Z.X. Li (LMD), J-L Dufresne (LMD), C. Rio (LMD), J-Y Grandpeix (LMD)
-!          A. JAM (LMD), J-B Madeleine (LMD), E. Vignon (LMD), L. Touzze-Peiffert (LMD)
-!--------------------------------------------------------------------------------
-! Date: 01/2021
-!--------------------------------------------------------------------------------
-! Aim: Large Scale Clouds and Precipitation (LSCP)
-!
-! This code is a new version of the fisrtilp.F90 routine, which is itself a 
-! merge of 'first' (superrsaturation physics, P. LeVan K. Laval)
-! and 'ilp' (il pleut, L. Li)
-!
-! Compared to the original fisrtilp code, lscp
-! -> assumes thermcep = .TRUE. all the time (fisrtilp inconsistent when .FALSE.)
-! -> consider always precipitation thermalisation (fl_cor_ebil>0)
-! -> option iflag_fisrtilp_qsat<0 no longer possible (qsat does not evolve with T) 
-! -> option "oldbug" by JYG has been removed
-! -> iflag_t_glace >0 always
-! -> the 'all or nothing' cloud approach is no longer available (cpartiel=T always)
-! -> rectangular distribution from L. Li no longer available
-! -> We always account for the Wegener-Findeisen-Bergeron process (iflag_bergeron = 2 in fisrt) 
-!--------------------------------------------------------------------------------
-! References: 
-!
-! - Bony, S., & Emanuel, K. A. 2001, JAS, doi: 10.1175/1520-0469(2001)058<3158:APOTCA>2.0.CO;2
-! - Hourdin et al. 2013, Clim Dyn, doi:10.1007/s00382-012-1343-y
-! - Jam et al. 2013, Boundary-Layer Meteorol, doi:10.1007/s10546-012-9789-3
-! - Jouhaud, et al. 2018. JAMES, doi:10.1029/2018MS001379
-! - Madeleine et al. 2020, JAMES, doi:10.1029/2020MS002046
-! - Touzze-Peifert Ludo, PhD thesis, p117-124
-! -------------------------------------------------------------------------------
-! Code structure:
-!
-! P0>     Thermalization of the precipitation coming from the overlying layer
-! P1>     Evaporation of the precipitation (falling from the k+1 level)
-! P2>     Cloud formation (at the k level) 
-! P2.A.1> With the PDFs, calculation of cloud properties using the inital
-!         values of T and Q
-! P2.A.2> Coupling between condensed water and temperature
-! P2.A.3> Calculation of final quantities associated with cloud formation
-! P2.B>   Release of Latent heat after cloud formation
-! P3>     Autoconversion to precipitation (k-level)
-! P4>     Wet scavenging
-!------------------------------------------------------------------------------
-! Some preliminary comments (JBM) :
-!
-! The cloud water that the radiation scheme sees is not the same that the cloud
-! water used in the physics and the dynamics 
-! 
-! During the autoconversion to precipitation (P3 step), radocond (cloud water used
-! by the radiation scheme) is calculated as an average of the water that remains
-! in the cloud during the precipitation and not the water remaining at the end
-! of the time step. The latter is used in the rest of the physics and advected
-! by the dynamics. 
-!
-! In summary:
-!
-! Radiation:
-! xflwc(newmicro)+xfiwc(newmicro) =
-!   radocond=lwcon(nc)+iwcon(nc)
-!
-! Notetheless, be aware of:
-!
-! radocond .NE. ocond(nc)
-! i.e.:
-! lwcon(nc)+iwcon(nc) .NE. ocond(nc)
-! but oliq+(ocond-oliq) .EQ. ocond
-! (which is not trivial)
-!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-!
-
-! USE de modules contenant des fonctions.
-USE lmdz_cloudth, ONLY : cloudth, cloudth_v3, cloudth_v6, cloudth_mpc 
-USE lmdz_lscp_tools, ONLY : calc_qsat_ecmwf, calc_gammasat
-USE lmdz_lscp_tools, ONLY : icefrac_lscp, icefrac_lscp_turb
-USE lmdz_lscp_tools, ONLY : fallice_velocity, distance_to_cloud_top
-!USE lmdz_lscp_condensation, ONLY : condensation_lognormal_test, condensation_ice_supersat
-USE lmdz_lscp_condensation, ONLY : condensation_lognormal, condensation_ice_supersat
-USE lmdz_lscp_poprecip, ONLY : poprecip_precld, poprecip_postcld
-
-! Use du module lmdz_lscp_ini contenant les constantes
-USE lmdz_lscp_ini, ONLY : prt_level, lunout, eps
-USE lmdz_lscp_ini, ONLY : seuil_neb, niter_lscp, iflag_evap_prec, t_coup, DDT0, ztfondue, rain_int_min
-USE lmdz_lscp_ini, ONLY : ok_radocond_snow, a_tr_sca, cld_expo_con, cld_expo_lsc
-USE lmdz_lscp_ini, ONLY : iflag_cloudth_vert, iflag_rain_incloud_vol, iflag_t_glace, t_glace_min 
-USE lmdz_lscp_ini, ONLY : coef_eva, coef_sub,cld_tau_lsc, cld_tau_con, cld_lc_lsc, cld_lc_con
-USE lmdz_lscp_ini, ONLY : iflag_bergeron, iflag_fisrtilp_qsat, iflag_vice, cice_velo, dice_velo
-USE lmdz_lscp_ini, ONLY : iflag_autoconversion, ffallv_con, ffallv_lsc, min_frac_th_cld
-USE lmdz_lscp_ini, ONLY : RCPD, RLSTT, RLVTT, RLMLT, RVTMP2, RTT, RD, RG
-USE lmdz_lscp_ini, ONLY : ok_poprecip
-USE lmdz_lscp_ini, ONLY : ok_ice_supersat, ok_unadjusted_clouds, iflag_icefrac
-
-IMPLICIT NONE
-
-!===============================================================================
-! VARIABLES DECLARATION
-!===============================================================================
-
-! INPUT VARIABLES:
-!-----------------
-
-  INTEGER,                         INTENT(IN)   :: klon,klev       ! number of horizontal grid points and vertical levels
-  REAL,                            INTENT(IN)   :: dtime           ! time step [s]
-  REAL,                            INTENT(IN)   :: missing_val     ! missing value for output
-
-  REAL, DIMENSION(klon,klev+1),    INTENT(IN)   :: paprs           ! inter-layer pressure [Pa]
-  REAL, DIMENSION(klon,klev),      INTENT(IN)   :: pplay           ! mid-layer pressure [Pa]
-  REAL, DIMENSION(klon,klev),      INTENT(IN)   :: temp            ! temperature (K)
-  REAL, DIMENSION(klon,klev),      INTENT(IN)   :: qt              ! total specific humidity (in vapor phase in input) [kg/kg] 
-  REAL, DIMENSION(klon,klev),      INTENT(IN)   :: qice_save       ! ice specific from previous time step [kg/kg]
-  INTEGER,                         INTENT(IN)   :: iflag_cld_th    ! flag that determines the distribution of convective clouds
-  INTEGER,                         INTENT(IN)   :: iflag_ice_thermo! flag to activate the ice thermodynamics
-                                                                   ! CR: if iflag_ice_thermo=2, only convection is active
-  LOGICAL, DIMENSION(klon,klev),   INTENT(IN)   :: ptconv          ! grid points where deep convection scheme is active
-
-  !Inputs associated with thermal plumes
-
-  REAL, DIMENSION(klon,klev),      INTENT(IN)   :: tv                  ! virtual potential temperature [K]
-  REAL, DIMENSION(klon,klev),      INTENT(IN)   :: qta                 ! specific humidity within thermals [kg/kg]
-  REAL, DIMENSION(klon,klev),      INTENT(IN)   :: fraca               ! fraction of thermals within the mesh [-]
-  REAL, DIMENSION(klon,klev),      INTENT(IN)   :: pspsk               ! exner potential (p/100000)**(R/cp) 
-  REAL, DIMENSION(klon,klev),      INTENT(IN)   :: tla                 ! liquid temperature within thermals [K]
-  REAL, DIMENSION(klon,klev+1),      INTENT(IN)   :: tke                 !--turbulent kinetic energy [m2/s2]
-  REAL, DIMENSION(klon,klev+1),      INTENT(IN)   :: tke_dissip          !--TKE dissipation [m2/s3]
-
-  ! INPUT/OUTPUT variables
-  !------------------------
-  
-  REAL, DIMENSION(klon,klev),      INTENT(INOUT)   :: thl          ! liquid potential temperature [K]
-  REAL, DIMENSION(klon,klev),      INTENT(INOUT)   :: ratqs,sigma_qtherm        ! function of pressure that sets the large-scale
-
-
-  ! INPUT/OUTPUT condensation and ice supersaturation
-  !--------------------------------------------------
-  REAL, DIMENSION(klon,klev),      INTENT(INOUT):: cf_seri          ! cloud fraction [-]
-  REAL, DIMENSION(klon,klev),      INTENT(INOUT):: ratio_qi_qtot    ! solid specific water to total specific water ratio [-]
-  REAL, DIMENSION(klon,klev),      INTENT(INOUT):: rvc_seri         ! cloudy water vapor to total water vapor ratio [-]
-  REAL, DIMENSION(klon,klev),      INTENT(IN)   :: u_seri           ! eastward wind [m/s]
-  REAL, DIMENSION(klon,klev),      INTENT(IN)   :: v_seri           ! northward wind [m/s]
-  REAL, DIMENSION(klon),           INTENT(IN)   :: cell_area        ! area of each cell [m2]
-
-  ! INPUT/OUTPUT aviation
-  !--------------------------------------------------
-  REAL, DIMENSION(klon,klev),      INTENT(IN)   :: flight_dist      ! Aviation distance flown within the mesh [m/s/mesh]
-  REAL, DIMENSION(klon,klev),      INTENT(IN)   :: flight_h2o       ! Aviation H2O emitted within the mesh [kg H2O/s/mesh]
-  
-  ! OUTPUT variables
-  !-----------------
-
-  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: d_t              ! temperature increment [K]
-  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: d_q              ! specific humidity increment [kg/kg]
-  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: d_ql             ! liquid water increment [kg/kg]
-  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: d_qi             ! cloud ice mass increment [kg/kg]
-  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: rneb             ! cloud fraction [-]
-  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: rneblsvol        ! cloud fraction per unit volume [-]  
-  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: pfraclr          ! precip fraction clear-sky part [-]
-  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: pfracld          ! precip fraction cloudy part [-]
-  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: cldfraliq           ! liquid fraction of cloud [-]
-  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: sigma2_icefracturb  ! Variance of the diagnostic supersaturation distribution (icefrac_turb) [-]
-  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: mean_icefracturb    ! Mean of the diagnostic supersaturation distribution (icefrac_turb) [-]
-  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: radocond         ! condensed water used in the radiation scheme [kg/kg]
-  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: radicefrac       ! ice fraction of condensed water for radiation scheme
-  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: rhcl             ! clear-sky relative humidity [-]
-  REAL, DIMENSION(klon),           INTENT(OUT)  :: rain             ! surface large-scale rainfall [kg/s/m2] 
-  REAL, DIMENSION(klon),           INTENT(OUT)  :: snow             ! surface large-scale snowfall [kg/s/m2]
-  REAL, DIMENSION(klon,klev+1),    INTENT(OUT)  :: prfl             ! large-scale rainfall flux in the column [kg/s/m2]
-  REAL, DIMENSION(klon,klev+1),    INTENT(OUT)  :: psfl             ! large-scale snowfall flux in the column [kg/s/m2]
-  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: distcltop        ! distance to cloud top [m]
-  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: temp_cltop       ! temperature of cloud top [K]
-  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: beta             ! conversion rate of condensed water
-
-  ! fraction of aerosol scavenging through impaction and nucleation    (for on-line)
-  
-  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: frac_impa           ! scavenging fraction due tu impaction [-]
-  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: frac_nucl           ! scavenging fraction due tu nucleation [-]
-  
-  ! for condensation and ice supersaturation
-
-  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: qsub           !--specific total water content in sub-saturated clear sky region [kg/kg]
-  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: qissr          !--specific total water content in supersat region [kg/kg]
-  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: qcld           !--specific total water content in cloudy region [kg/kg]
-  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: subfra         !--mesh fraction of subsaturated clear sky [-]   
-  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: issrfra        !--mesh fraction of ISSR [-]  
-  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: gamma_cond     !--coefficient governing the ice nucleation RHi threshold [-]      
-  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: dcf_sub        !--cloud fraction tendency because of sublimation [s-1]
-  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: dcf_con        !--cloud fraction tendency because of condensation [s-1]
-  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: dcf_mix        !--cloud fraction tendency because of cloud mixing [s-1]
-  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: dqi_adj        !--specific ice content tendency because of temperature adjustment [kg/kg/s]
-  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: dqi_sub        !--specific ice content tendency because of sublimation [kg/kg/s]
-  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: dqi_con        !--specific ice content tendency because of condensation [kg/kg/s]
-  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: dqi_mix        !--specific ice content tendency because of cloud mixing [kg/kg/s]
-  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: dqvc_adj       !--specific cloud water vapor tendency because of temperature adjustment [kg/kg/s]
-  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: dqvc_sub       !--specific cloud water vapor tendency because of sublimation [kg/kg/s]
-  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: dqvc_con       !--specific cloud water vapor tendency because of condensation [kg/kg/s]
-  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: dqvc_mix       !--specific cloud water vapor tendency because of cloud mixing [kg/kg/s]
-  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: qsatl          !--saturation specific humidity wrt liquid [kg/kg]
-  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: qsati          !--saturation specific humidity wrt ice [kg/kg]  
-
-  ! for contrails and aviation
-
-  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: Tcontr         !--threshold temperature for contrail formation [K]
-  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: qcontr         !--threshold humidity for contrail formation [kg/kg]
-  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: qcontr2        !--// (2nd expression more consistent with LMDZ expression of q)
-  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: fcontrN        !--fraction of grid favourable to non-persistent contrails
-  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: fcontrP        !--fraction of grid favourable to persistent contrails
-  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: dcf_avi        !--cloud fraction tendency because of aviation [s-1]
-  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: dqi_avi        !--specific ice content tendency because of aviation [kg/kg/s]
-  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: dqvc_avi       !--specific cloud water vapor tendency because of aviation [kg/kg/s]
-
-
-  ! for POPRECIP
-
-  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: qraindiag      !--DIAGNOSTIC specific rain content [kg/kg]
-  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: qsnowdiag      !--DIAGNOSTIC specific snow content [kg/kg]
-  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: dqreva         !--rain tendendy due to evaporation [kg/kg/s]
-  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: dqssub         !--snow tendency due to sublimation [kg/kg/s]
-  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: dqrcol         !--rain tendendy due to collection by rain of liquid cloud droplets [kg/kg/s]
-  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: dqsagg         !--snow tendency due to collection of lcoud ice by aggregation [kg/kg/s]
-  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: dqrauto        !--rain tendency due to autoconversion of cloud liquid [kg/kg/s]
-  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: dqsauto        !--snow tendency due to autoconversion of cloud ice [kg/kg/s]
-  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: dqsrim         !--snow tendency due to riming [kg/kg/s]
-  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: dqsmelt        !--snow tendency due to melting [kg/kg/s]
-  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: dqrmelt        !--rain tendency due to melting [kg/kg/s]
-  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: dqsfreez       !--snow tendency due to freezing [kg/kg/s]
-  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: dqrfreez       !--rain tendency due to freezing [kg/kg/s]
-
-  ! for thermals
-
-  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: cloudth_sth      !--mean saturation deficit in thermals
-  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: cloudth_senv     !--mean saturation deficit in environment
-  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: cloudth_sigmath  !--std of saturation deficit in thermals
-  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: cloudth_sigmaenv !--std of saturation deficit in environment
-
-
-  ! LOCAL VARIABLES:
-  !----------------
-  REAL,DIMENSION(klon) :: qsl, qsi                                ! saturation threshold at current vertical level
-  REAL :: zct, zcl,zexpo
-  REAL, DIMENSION(klon,klev) :: ctot
-  REAL, DIMENSION(klon,klev) :: ctot_vol
-  REAL, DIMENSION(klon) :: zqs, zdqs
-  REAL :: zdelta, zcor, zcvm5
-  REAL, DIMENSION(klon) :: zdqsdT_raw
-  REAL, DIMENSION(klon) :: gammasat,dgammasatdt                   ! coefficient to make cold condensation at the correct RH and derivative wrt T
-  REAL, DIMENSION(klon) :: Tbef,qlbef,DT                          ! temperature, humidity and temp. variation during lognormal iteration
-  REAL :: num,denom
-  REAL :: cste
-  REAL, DIMENSION(klon) :: zpdf_sig,zpdf_k,zpdf_delta             ! lognormal parameters
-  REAL, DIMENSION(klon) :: Zpdf_a,zpdf_b,zpdf_e1,zpdf_e2          ! lognormal intermediate variables
-  REAL :: erf
-  REAL, DIMENSION(klon) :: zfice_th
-  REAL, DIMENSION(klon) :: qcloud, qincloud_mpc
-  REAL, DIMENSION(klon) :: zrfl, zrfln
-  REAL :: zqev, zqevt 
-  REAL, DIMENSION(klon) :: zifl, zifln, ziflprev
-  REAL :: zqev0,zqevi, zqevti
-  REAL, DIMENSION(klon) :: zoliq, zcond, zq, zqn
-  REAL, DIMENSION(klon) :: zoliql, zoliqi
-  REAL, DIMENSION(klon) :: zt
-  REAL, DIMENSION(klon,klev) :: zrho
-  REAL, DIMENSION(klon) :: zdz,iwc
-  REAL :: zchau,zfroi
-  REAL, DIMENSION(klon) :: zfice,zneb,znebprecip
-  REAL :: zmelt,zrain,zsnow,zprecip
-  REAL, DIMENSION(klon) :: dzfice
-  REAL, DIMENSION(klon) :: zfice_turb, dzfice_turb
-  REAL :: zsolid
-  REAL, DIMENSION(klon) :: qtot, qzero
-  REAL, DIMENSION(klon) :: dqsl,dqsi
-  REAL :: smallestreal
-  !  Variables for Bergeron process
-  REAL :: zcp, coef1, DeltaT, Deltaq, Deltaqprecl
-  REAL, DIMENSION(klon) :: zqpreci, zqprecl
-  ! Variables precipitation energy conservation
-  REAL, DIMENSION(klon) :: zmqc
-  REAL :: zalpha_tr
-  REAL :: zfrac_lessi
-  REAL, DIMENSION(klon) :: zprec_cond
-  REAL :: zmair
-  REAL :: zcpair, zcpeau
-  REAL, DIMENSION(klon) :: zlh_solid
-  REAL, DIMENSION(klon) :: ztupnew
-  REAL, DIMENSION(klon) :: zqvapclr, zqupnew ! for poprecip evap / subl
-  REAL :: zm_solid         ! for liquid -> solid conversion
-  REAL, DIMENSION(klon) :: zrflclr, zrflcld
-  REAL, DIMENSION(klon) :: d_zrfl_clr_cld, d_zifl_clr_cld
-  REAL, DIMENSION(klon) :: d_zrfl_cld_clr, d_zifl_cld_clr 
-  REAL, DIMENSION(klon) :: ziflclr, ziflcld
-  REAL, DIMENSION(klon) :: znebprecipclr, znebprecipcld
-  REAL, DIMENSION(klon) :: tot_zneb, tot_znebn, d_tot_zneb
-  REAL, DIMENSION(klon) :: d_znebprecip_clr_cld, d_znebprecip_cld_clr
-  REAL, DIMENSION(klon,klev) :: velo
-  REAL :: vr, ffallv
-  REAL :: qlmpc, qimpc, rnebmpc
-  REAL, DIMENSION(klon,klev) :: radocondi, radocondl
-  REAL :: effective_zneb
-  REAL, DIMENSION(klon) :: zdistcltop, ztemp_cltop
-  REAL, DIMENSION(klon) :: zqliq, zqice, zqvapcl        ! for icefrac_lscp_turb
-  
-  ! for condensation and ice supersaturation
-  REAL, DIMENSION(klon) :: qvc, shear
-  REAL :: delta_z
-  !--Added for ice supersaturation (ok_ice_supersat) and contrails (ok_plane_contrails)
-  ! Constants used for calculating ratios that are advected (using a parent-child
-  ! formalism). This is not done in the dynamical core because at this moment,
-  ! only isotopes can use this parent-child formalism. Note that the two constants
-  ! are the same as the one use in the dynamical core, being also defined in
-  ! dyn3d_common/infotrac.F90
-  REAL :: min_qParent, min_ratio
-
-  INTEGER i, k, n, kk, iter
-  INTEGER, DIMENSION(klon) :: n_i
-  INTEGER ncoreczq
-  INTEGER, DIMENSION(klon,klev) :: mpc_bl_points
-  LOGICAL iftop
-
-  LOGICAL, DIMENSION(klon) :: lognormale
-  LOGICAL, DIMENSION(klon) :: keepgoing
-
-  CHARACTER (len = 20) :: modname = 'lscp'
-  CHARACTER (len = 80) :: abort_message
-  
-
-!===============================================================================
-! INITIALISATION
-!===============================================================================
-
-! Few initial checks
-
-
-IF (iflag_fisrtilp_qsat .LT. 0) THEN
-    abort_message = 'lscp cannot be used with iflag_fisrtilp<0'
-    CALL abort_physic(modname,abort_message,1)
-ENDIF
-
-! Few initialisations
-
-znebprecip(:)=0.0
-ctot_vol(1:klon,1:klev)=0.0
-rneblsvol(1:klon,1:klev)=0.0
-smallestreal=1.e-9
-znebprecipclr(:)=0.0
-znebprecipcld(:)=0.0
-mpc_bl_points(:,:)=0
-
-IF (prt_level>9) WRITE(lunout,*) 'NUAGES4 A. JAM'
-
-! AA for 'safety' reasons
-zalpha_tr   = 0.
-zfrac_lessi = 0.
-beta(:,:)= 0.
-
-! Initialisation of variables:
-
-prfl(:,:) = 0.0
-psfl(:,:) = 0.0
-d_t(:,:) = 0.0
-d_q(:,:) = 0.0
-d_ql(:,:) = 0.0
-d_qi(:,:) = 0.0
-rneb(:,:) = 0.0
-pfraclr(:,:)=0.0
-pfracld(:,:)=0.0
-cldfraliq(:,:)=0.
-sigma2_icefracturb(:,:)=0.
-mean_icefracturb(:,:)=0.
-radocond(:,:) = 0.0
-radicefrac(:,:) = 0.0
-frac_nucl(:,:) = 1.0 
-frac_impa(:,:) = 1.0 
-rain(:) = 0.0
-snow(:) = 0.0
-zoliq(:)=0.0
-zfice(:)=0.0
-dzfice(:)=0.0
-zfice_turb(:)=0.0
-dzfice_turb(:)=0.0
-zqprecl(:)=0.0
-zqpreci(:)=0.0
-zrfl(:) = 0.0
-zifl(:) = 0.0
-ziflprev(:)=0.0
-zneb(:) = seuil_neb
-zrflclr(:) = 0.0
-ziflclr(:) = 0.0
-zrflcld(:) = 0.0
-ziflcld(:) = 0.0
-tot_zneb(:) = 0.0
-tot_znebn(:) = 0.0
-d_tot_zneb(:) = 0.0
-qzero(:) = 0.0
-zdistcltop(:)=0.0
-ztemp_cltop(:) = 0.0
-ztupnew(:)=0.0
-
-distcltop(:,:)=0.
-temp_cltop(:,:)=0.
-
-!--Ice supersaturation
-gamma_cond(:,:) = 1.
-qissr(:,:)      = 0.
-issrfra(:,:)    = 0.
-dcf_sub(:,:)    = 0.
-dcf_con(:,:)    = 0.
-dcf_mix(:,:)    = 0.
-dqi_adj(:,:)    = 0.
-dqi_sub(:,:)    = 0.
-dqi_con(:,:)    = 0.
-dqi_mix(:,:)    = 0.
-dqvc_adj(:,:)   = 0.
-dqvc_sub(:,:)   = 0.
-dqvc_con(:,:)   = 0.
-dqvc_mix(:,:)   = 0.
-fcontrN(:,:)    = 0.
-fcontrP(:,:)    = 0.
-Tcontr(:,:)     = missing_val
-qcontr(:,:)     = missing_val
-qcontr2(:,:)    = missing_val
-dcf_avi(:,:)    = 0.
-dqi_avi(:,:)    = 0.
-dqvc_avi(:,:)   = 0.
-qvc(:)          = 0.
-shear(:)        = 0.
-min_qParent     = 1.e-30
-min_ratio       = 1.e-16
-
-!-- poprecip
-qraindiag(:,:)= 0.
-qsnowdiag(:,:)= 0.
-dqreva(:,:)   = 0.
-dqrauto(:,:)  = 0.
-dqrmelt(:,:)  = 0.
-dqrfreez(:,:) = 0.
-dqrcol(:,:)   = 0.
-dqssub(:,:)   = 0.
-dqsauto(:,:)  = 0.
-dqsrim(:,:)   = 0.
-dqsagg(:,:)   = 0.
-dqsfreez(:,:) = 0.
-dqsmelt(:,:)  = 0.
-zqupnew(:)    = 0.
-zqvapclr(:)   = 0.
-
-
-
-!c_iso: variable initialisation for iso 
-
-
-!===============================================================================
-!              BEGINNING OF VERTICAL LOOP FROM TOP TO BOTTOM
-!===============================================================================
-
-ncoreczq=0
-
-DO k = klev, 1, -1
-
-    IF (k.LE.klev-1) THEN
-       iftop=.false. 
-    ELSE 
-       iftop=.true.
-    ENDIF
-
-    ! Initialisation temperature and specific humidity
-    ! temp(klon,klev) is not modified by the routine, instead all changes in temperature are made on zt
-    ! at the end of the klon loop, a temperature incremtent d_t due to all processes
-    ! (thermalization, evap/sub incoming precip, cloud formation, precipitation processes) is calculated 
-    ! d_t = temperature tendency due to lscp
-    ! The temperature of the overlying layer is updated here because needed for thermalization
-    DO i = 1, klon
-        zt(i)=temp(i,k)
-        zq(i)=qt(i,k)
-        IF (.not. iftop) THEN
-           ztupnew(i)  = temp(i,k+1) + d_t(i,k+1)
-           zqupnew(i)  = qt(i,k+1) + d_q(i,k+1) + d_ql(i,k+1) + d_qi(i,k+1)
-           !--zqs(i) is the saturation specific humidity in the layer above
-           zqvapclr(i) = MAX(0., qt(i,k+1) + d_q(i,k+1) - rneb(i,k+1) * zqs(i))
-        ENDIF
-        !c_iso init of iso
-    ENDDO
-   
-    !================================================================
-    ! Flag for the new and more microphysical treatment of precipitation from Atelier Nuage (R)
-    IF (ok_poprecip) THEN
-
-            CALL poprecip_precld(klon, dtime, iftop, paprs(:,k), paprs(:,k+1), pplay(:,k), &
-                              zt, ztupnew, zq, zmqc, znebprecipclr, znebprecipcld, &
-                              zqvapclr, zqupnew, &
-                              zrfl, zrflclr, zrflcld, &
-                              zifl, ziflclr, ziflcld, &
-                              dqreva(:,k),dqssub(:,k) &
-                             )
-
-    !================================================================
-    ELSE
-
-    ! --------------------------------------------------------------------
-    ! P1> Thermalization of precipitation falling from the overlying layer
-    ! --------------------------------------------------------------------
-    ! Computes air temperature variation due to enthalpy transported by
-    ! precipitation. Precipitation is then thermalized with the air in the
-    ! layer. 
-    ! The precipitation should remain thermalized throughout the different
-    ! thermodynamical transformations. 
-    ! The corresponding water mass should
-    ! be added when calculating the layer's enthalpy change with 
-    ! temperature
-    ! See lmdzpedia page todoan
-    ! todoan: check consistency with ice phase
-    ! todoan: understand why several steps
-    ! ---------------------------------------------------------------------
-    
-    IF (iftop) THEN
-
-        DO i = 1, klon
-            zmqc(i) = 0.
-        ENDDO
-
-    ELSE
-
-        DO i = 1, klon
- 
-            zmair=(paprs(i,k)-paprs(i,k+1))/RG
-            ! no condensed water so cp=cp(vapor+dry air)
-            ! RVTMP2=rcpv/rcpd-1
-            zcpair=RCPD*(1.0+RVTMP2*zq(i)) 
-            zcpeau=RCPD*RVTMP2
-
-            ! zmqc: precipitation mass that has to be thermalized with 
-            ! layer's air so that precipitation at the ground has the
-            ! same temperature as the lowermost layer
-            zmqc(i) = (zrfl(i)+zifl(i))*dtime/zmair
-            ! t(i,k+1)+d_t(i,k+1): new temperature of the overlying layer
-            zt(i) = ( ztupnew(i)*zmqc(i)*zcpeau + zcpair*zt(i) ) &
-             / (zcpair + zmqc(i)*zcpeau)
-
-        ENDDO
- 
-    ENDIF
-
-    ! --------------------------------------------------------------------
-    ! P2> Precipitation evaporation/sublimation/melting
-    ! --------------------------------------------------------------------
-    ! A part of the precipitation coming from above is evaporated/sublimated/melted.
-    ! --------------------------------------------------------------------
-    
-    IF (iflag_evap_prec.GE.1) THEN 
-
-        ! Calculation of saturation specific humidity
-        ! depending on temperature:
-        CALL calc_qsat_ecmwf(klon,zt(:),qzero(:),pplay(:,k),RTT,0,.false.,zqs(:),zdqs(:))
-        ! wrt liquid water
-        CALL calc_qsat_ecmwf(klon,zt(:),qzero(:),pplay(:,k),RTT,1,.false.,qsl(:),dqsl(:))
-        ! wrt ice
-        CALL calc_qsat_ecmwf(klon,zt(:),qzero(:),pplay(:,k),RTT,2,.false.,qsi(:),dqsi(:))
-
-        DO i = 1, klon
-
-            ! if precipitation
-            IF (zrfl(i)+zifl(i).GT.0.) THEN
-
-            ! LudoTP: we only account for precipitation evaporation in the clear-sky (iflag_evap_prec>=4).
-            ! c_iso: likely important to distinguish cs from neb isotope precipitation
-
-                IF (iflag_evap_prec.GE.4) THEN
-                    zrfl(i) = zrflclr(i)
-                    zifl(i) = ziflclr(i)
-                ENDIF
-
-                IF (iflag_evap_prec.EQ.1) THEN
-                    znebprecip(i)=zneb(i)
-                ELSE
-                    znebprecip(i)=MAX(zneb(i),znebprecip(i))
-                ENDIF
-
-                IF (iflag_evap_prec.GT.4) THEN
-                ! Max evaporation not to saturate the clear sky precip fraction
-                ! i.e. the fraction where evaporation occurs
-                    zqev0 = MAX(0.0, (zqs(i)-zq(i))*znebprecipclr(i))
-                ELSEIF (iflag_evap_prec .EQ. 4) THEN
-                ! Max evaporation not to saturate the whole mesh
-                ! Pay attention -> lead to unrealistic and excessive evaporation
-                    zqev0 = MAX(0.0, zqs(i)-zq(i))
-                ELSE
-                ! Max evap not to saturate the fraction below the cloud
-                    zqev0 = MAX(0.0, (zqs(i)-zq(i))*znebprecip(i))
-                ENDIF
-
-                ! Evaporation of liquid precipitation coming from above
-                ! dP/dz=beta*(1-q/qsat)*sqrt(P)
-                ! formula from Sundquist 1988, Klemp & Wilhemson 1978
-                ! LTP: evaporation only in the clear sky part (iflag_evap_prec>=4)
-
-                IF (iflag_evap_prec.EQ.3) THEN
-                    zqevt = znebprecip(i)*coef_eva*(1.0-zq(i)/qsl(i)) &
-                    *SQRT(zrfl(i)/max(1.e-4,znebprecip(i)))        &
-                    *(paprs(i,k)-paprs(i,k+1))/pplay(i,k)*zt(i)*RD/RG
-                ELSE IF (iflag_evap_prec.GE.4) THEN
-                     zqevt = znebprecipclr(i)*coef_eva*(1.0-zq(i)/qsl(i)) &
-                    *SQRT(zrfl(i)/max(1.e-8,znebprecipclr(i))) &
-                    *(paprs(i,k)-paprs(i,k+1))/pplay(i,k)*zt(i)*RD/RG
-                ELSE
-                    zqevt = 1.*coef_eva*(1.0-zq(i)/qsl(i))*SQRT(zrfl(i)) &
-                    *(paprs(i,k)-paprs(i,k+1))/pplay(i,k)*zt(i)*RD/RG
-                ENDIF
-
-                zqevt = MAX(0.0,MIN(zqevt,zrfl(i))) &
-                    *RG*dtime/(paprs(i,k)-paprs(i,k+1)) 
-
-                ! sublimation of the solid precipitation coming from above
-                IF (iflag_evap_prec.EQ.3) THEN
-                    zqevti = znebprecip(i)*coef_sub*(1.0-zq(i)/qsi(i)) &
-                    *SQRT(zifl(i)/max(1.e-4,znebprecip(i))) &
-                    *(paprs(i,k)-paprs(i,k+1))/pplay(i,k)*zt(i)*RD/RG
-                ELSE IF (iflag_evap_prec.GE.4) THEN
-                     zqevti = znebprecipclr(i)*coef_sub*(1.0-zq(i)/qsi(i)) &
-                    *SQRT(zifl(i)/max(1.e-8,znebprecipclr(i))) &
-                    *(paprs(i,k)-paprs(i,k+1))/pplay(i,k)*zt(i)*RD/RG
-                ELSE
-                    zqevti = 1.*coef_sub*(1.0-zq(i)/qsi(i))*SQRT(zifl(i)) &
-                    *(paprs(i,k)-paprs(i,k+1))/pplay(i,k)*zt(i)*RD/RG
-                ENDIF
-
-                zqevti = MAX(0.0,MIN(zqevti,zifl(i))) &
-                *RG*dtime/(paprs(i,k)-paprs(i,k+1))
-
-                ! A. JAM
-                ! Evaporation limit: we ensure that the layer's fraction below
-                ! the cloud or the whole mesh (depending on iflag_evap_prec)
-                ! does not reach saturation. In this case, we 
-                ! redistribute zqev0 conserving the ratio liquid/ice 
-
-                IF (zqevt+zqevti.GT.zqev0) THEN
-                    zqev=zqev0*zqevt/(zqevt+zqevti)
-                    zqevi=zqev0*zqevti/(zqevt+zqevti)
-                ELSE
-                    zqev=zqevt
-                    zqevi=zqevti
-                ENDIF
-
-
-                ! New solid and liquid precipitation fluxes after evap and sublimation
-                zrfln(i) = Max(0.,zrfl(i) - zqev*(paprs(i,k)-paprs(i,k+1))  &
-                         /RG/dtime)
-                zifln(i) = Max(0.,zifl(i) - zqevi*(paprs(i,k)-paprs(i,k+1)) &
-                         /RG/dtime)
-
-
-                ! vapor, temperature, precip fluxes update
-                ! vapor is updated after evaporation/sublimation (it is increased)
-                zq(i) = zq(i) - (zrfln(i)+zifln(i)-zrfl(i)-zifl(i)) &
-                * (RG/(paprs(i,k)-paprs(i,k+1)))*dtime
-                ! zmqc is the total condensed water in the precip flux (it is decreased)
-                zmqc(i) = zmqc(i) + (zrfln(i)+zifln(i)-zrfl(i)-zifl(i)) &
-                * (RG/(paprs(i,k)-paprs(i,k+1)))*dtime
-                ! air and precip temperature (i.e., gridbox temperature)
-                ! is updated due to latent heat cooling
-                zt(i) = zt(i) + (zrfln(i)-zrfl(i))        &
-                * (RG/(paprs(i,k)-paprs(i,k+1)))*dtime    &
-                * RLVTT/RCPD/(1.0+RVTMP2*(zq(i)+zmqc(i))) &
-                + (zifln(i)-zifl(i))                      &
-                * (RG/(paprs(i,k)-paprs(i,k+1)))*dtime    &
-                * RLSTT/RCPD/(1.0+RVTMP2*(zq(i)+zmqc(i)))
-
-                ! New values of liquid and solid precipitation 
-                zrfl(i) = zrfln(i)
-                zifl(i) = zifln(i)
-
-                ! c_iso here call_reevap that updates isotopic zrfl, zifl (in inout)
-                !                         due to evap + sublim                                     
-                                           
-
-                IF (iflag_evap_prec.GE.4) THEN
-                    zrflclr(i) = zrfl(i)
-                    ziflclr(i) = zifl(i)
-                    IF(zrflclr(i) + ziflclr(i).LE.0) THEN
-                        znebprecipclr(i) = 0.0
-                    ENDIF
-                    zrfl(i) = zrflclr(i) + zrflcld(i)
-                    zifl(i) = ziflclr(i) + ziflcld(i)
-                ENDIF
-
-                ! c_iso duplicate for isotopes or loop on isotopes
-
-                ! Melting:
-                zmelt = ((zt(i)-RTT)/(ztfondue-RTT)) ! JYG
-                ! precip fraction that is melted
-                zmelt = MIN(MAX(zmelt,0.),1.)
-
-                ! update of rainfall and snowfall due to melting
-                IF (iflag_evap_prec.GE.4) THEN
-                    zrflclr(i)=zrflclr(i)+zmelt*ziflclr(i)
-                    zrflcld(i)=zrflcld(i)+zmelt*ziflcld(i)
-                    zrfl(i)=zrflclr(i)+zrflcld(i)
-                ELSE
-                    zrfl(i)=zrfl(i)+zmelt*zifl(i)
-                ENDIF
-
-
-                ! c_iso: melting of isotopic precipi with zmelt (no fractionation)
-
-                ! Latent heat of melting because of precipitation melting
-                ! NB: the air + precip temperature is simultaneously updated
-                zt(i)=zt(i)-zifl(i)*zmelt*(RG*dtime)/(paprs(i,k)-paprs(i,k+1)) &
-                *RLMLT/RCPD/(1.0+RVTMP2*(zq(i)+zmqc(i)))
-               
-                IF (iflag_evap_prec.GE.4) THEN
-                    ziflclr(i)=ziflclr(i)*(1.-zmelt)
-                    ziflcld(i)=ziflcld(i)*(1.-zmelt)
-                    zifl(i)=ziflclr(i)+ziflcld(i)
-                ELSE
-                    zifl(i)=zifl(i)*(1.-zmelt)
-                ENDIF
-
-            ELSE
-                ! if no precip, we reinitialize the cloud fraction used for the precip to 0 
-                znebprecip(i)=0.
-
-            ENDIF ! (zrfl(i)+zifl(i).GT.0.)
-
-        ENDDO ! loop on klon
-
-    ENDIF ! (iflag_evap_prec>=1)
-
-    ENDIF ! (ok_poprecip)
-
-    ! --------------------------------------------------------------------
-    ! End precip evaporation
-    ! --------------------------------------------------------------------
-    
-    ! Calculation of qsat, L/Cp*dqsat/dT and ncoreczq counter
-    !-------------------------------------------------------
-
-     qtot(:)=zq(:)+zmqc(:)
-     CALL calc_qsat_ecmwf(klon,zt(:),qtot(:),pplay(:,k),RTT,0,.false.,zqs(:),zdqs(:))
-     DO i = 1, klon
-            zdelta = MAX(0.,SIGN(1.,RTT-zt(i)))
-            zdqsdT_raw(i) = zdqs(i)*RCPD*(1.0+RVTMP2*zq(i)) / (RLVTT*(1.-zdelta) + RLSTT*zdelta)
-            IF (zq(i) .LT. 1.e-15) THEN
-                ncoreczq=ncoreczq+1
-                zq(i)=1.e-15
-            ENDIF
-            ! c_iso: do something similar for isotopes
-
-     ENDDO
-    
-    ! --------------------------------------------------------------------
-    ! P2> Cloud formation
-    !---------------------------------------------------------------------
-    !
-    ! Unlike fisrtilp, we always assume a 'fractional cloud' approach 
-    ! i.e. clouds occupy only a fraction of the mesh (the subgrid distribution
-    ! is prescribed and depends on large scale variables and boundary layer
-    ! properties)
-    ! The decrease in condensed part due tu latent heating is taken into
-    ! account
-    ! -------------------------------------------------------------------
-
-        ! P2.1> With the PDFs (log-normal, bigaussian) 
-        ! cloud properties calculation with the initial values of t and q
-        ! ----------------------------------------------------------------
-
-        ! initialise gammasat and qincloud_mpc
-        gammasat(:)=1.
-        qincloud_mpc(:)=0.
-
-        IF (iflag_cld_th.GE.5) THEN
-               ! Cloud cover and content in meshes affected by shallow convection, 
-               ! are retrieved from a bi-gaussian distribution of the saturation deficit
-               ! following Jam et al. 2013
-
-               IF (iflag_cloudth_vert.LE.2) THEN
-                  ! Old version of Arnaud Jam
-
-                    CALL cloudth(klon,klev,k,tv,                  &
-                         zq,qta,fraca,                            &
-                         qcloud,ctot,pspsk,paprs,pplay,tla,thl, &
-                         ratqs,zqs,temp,                              &
-                         cloudth_sth,cloudth_senv,cloudth_sigmath,cloudth_sigmaenv)
-
-
-                ELSEIF (iflag_cloudth_vert.GE.3 .AND. iflag_cloudth_vert.LE.5) THEN
-                   ! Default version of Arnaud Jam
-                        
-                    CALL cloudth_v3(klon,klev,k,tv,                        &
-                         zq,qta,fraca,                                     &
-                         qcloud,ctot,ctot_vol,pspsk,paprs,pplay,tla,thl, &
-                         ratqs,sigma_qtherm,zqs,temp, &
-                         cloudth_sth,cloudth_senv,cloudth_sigmath,cloudth_sigmaenv)
-
-
-                ELSEIF (iflag_cloudth_vert.EQ.6) THEN
-                   ! Jean Jouhaud's version, with specific separation between surface and volume
-                   ! cloud fraction Decembre 2018 
-
-                    CALL cloudth_v6(klon,klev,k,tv,                        &
-                         zq,qta,fraca,                                     &
-                         qcloud,ctot,ctot_vol,pspsk,paprs,pplay,tla,thl, &
-                         ratqs,zqs,temp, &
-                         cloudth_sth,cloudth_senv,cloudth_sigmath,cloudth_sigmaenv)
-
-                ELSEIF (iflag_cloudth_vert .EQ. 7) THEN
-                   ! Updated version of Arnaud Jam (correction by E. Vignon) + adapted treatment
-                   ! for boundary-layer mixed phase clouds 
-                    CALL cloudth_mpc(klon,klev,k,mpc_bl_points,zt,zq,qta(:,k),fraca(:,k), &
-                                     pspsk(:,k),paprs(:,k+1),paprs(:,k),pplay(:,k), tla(:,k), &
-                                     ratqs(:,k),qcloud,qincloud_mpc,zfice_th,ctot(:,k),ctot_vol(:,k), &
-                                     cloudth_sth(:,k),cloudth_senv(:,k),cloudth_sigmath(:,k),cloudth_sigmaenv(:,k))
-
-                ENDIF
-
-
-                DO i=1,klon
-                    rneb(i,k)=ctot(i,k)
-                    rneblsvol(i,k)=ctot_vol(i,k)
-                    zqn(i)=qcloud(i)
-                    !--AB grid-mean vapor in the cloud - we assume saturation adjustment
-                    qvc(i) = rneb(i,k) * zqs(i)
-                ENDDO
-
-        ENDIF
-
-        IF (iflag_cld_th .LE. 4) THEN
-            
-                ! lognormal 
-            lognormale(:) = .TRUE.
-
-        ELSEIF (iflag_cld_th .GE. 6) THEN
-            
-                ! lognormal distribution when no thermals 
-            lognormale(:) = fraca(:,k) < min_frac_th_cld
-
-        ELSE
-                ! When iflag_cld_th=5, we always assume
-                ! bi-gaussian distribution
-            lognormale(:) = .FALSE.
-        
-        ENDIF
-
-        DT(:) = 0.
-        n_i(:)=0
-        Tbef(:)=zt(:)
-        qlbef(:)=0.
-
-        ! Treatment of non-boundary layer clouds (lognormale)
-        ! condensation with qsat(T) variation (adaptation)
-        ! Iterative resolution to converge towards qsat
-        ! with update of temperature, ice fraction and qsat at 
-        ! each iteration
-
-        ! todoan -> sensitivity to iflag_fisrtilp_qsat
-        DO iter=1,iflag_fisrtilp_qsat+1
-
-                keepgoing(:) = .FALSE.
-
-                DO i=1,klon
-
-                    ! keepgoing = .true. while convergence is not satisfied
-
-                    IF (((ABS(DT(i)).GT.DDT0) .OR. (n_i(i) .EQ. 0)) .AND. lognormale(i)) THEN
-
-                        ! if not convergence:
-                        ! we calculate a new iteration
-                        keepgoing(i) = .TRUE.
-
-                        ! P2.2.1> cloud fraction and condensed water mass calculation
-                        ! Calculated variables: 
-                        ! rneb : cloud fraction
-                        ! zqn : total water within the cloud
-                        ! zcond: mean condensed water within the mesh
-                        ! rhcl: clear-sky relative humidity
-                        !---------------------------------------------------------------
-
-                        ! new temperature that only serves in the iteration process:
-                        Tbef(i)=Tbef(i)+DT(i)
-
-                        ! Rneb, qzn and zcond for lognormal PDFs
-                        qtot(i)=zq(i)+zmqc(i)
-
-                      ENDIF
-
-                  ENDDO
-
-                  ! Calculation of saturation specific humidity and ice fraction
-                  CALL calc_qsat_ecmwf(klon,Tbef(:),qtot(:),pplay(:,k),RTT,0,.false.,zqs(:),zdqs(:))
-                  CALL calc_gammasat(klon,Tbef(:),qtot(:),pplay(:,k),gammasat(:),dgammasatdt(:))
-                  ! saturation may occur at a humidity different from qsat (gamma qsat), so gamma correction for dqs
-                  zdqs(:) = gammasat(:)*zdqs(:)+zqs(:)*dgammasatdt(:)
-                  ! cloud phase determination
-                  IF (iflag_t_glace.GE.4) THEN
-                  ! For iflag_t_glace GE 4 the phase partition function dependends on temperature AND distance to cloud top
-                       CALL distance_to_cloud_top(klon,klev,k,temp,pplay,paprs,rneb,zdistcltop,ztemp_cltop)
-                  ENDIF
-
-                  CALL icefrac_lscp(klon, zt(:), iflag_ice_thermo, zdistcltop(:),ztemp_cltop(:),zfice(:),dzfice(:))
-
-                  !--AB Activates a condensation scheme that allows for
-                  !--ice supersaturation and contrails evolution from aviation
-                  IF (ok_ice_supersat) THEN
-
-                    !--Calculate the shear value (input for condensation and ice supersat)
-                    DO i = 1, klon
-                      !--Cell thickness [m]
-                      delta_z = ( paprs(i,k) - paprs(i,k+1) ) / RG / pplay(i,k) * Tbef(i) * RD
-                      IF ( iftop ) THEN
-                        ! top
-                        shear(i) = SQRT( ( (u_seri(i,k) - u_seri(i,k-1)) / delta_z )**2. &
-                                       + ( (v_seri(i,k) - v_seri(i,k-1)) / delta_z )**2. )
-                      ELSEIF ( k .EQ. 1 ) THEN
-                        ! surface
-                        shear(i) = SQRT( ( (u_seri(i,k+1) - u_seri(i,k)) / delta_z )**2. &
-                                       + ( (v_seri(i,k+1) - v_seri(i,k)) / delta_z )**2. )
-                      ELSE
-                        ! other layers
-                        shear(i) = SQRT( ( ( (u_seri(i,k+1) + u_seri(i,k)) / 2. &
-                                           - (u_seri(i,k) + u_seri(i,k-1)) / 2. ) / delta_z )**2. &
-                                       + ( ( (v_seri(i,k+1) + v_seri(i,k)) / 2. &
-                                           - (v_seri(i,k) + v_seri(i,k-1)) / 2. ) / delta_z )**2. )
-                      ENDIF
-                    ENDDO
-
-                    !---------------------------------------------
-                    !--   CONDENSATION AND ICE SUPERSATURATION  --
-                    !---------------------------------------------
-
-                    CALL condensation_ice_supersat( &
-                        klon, dtime, missing_val, &
-                        pplay(:,k), paprs(:,k), paprs(:,k+1), &
-                        cf_seri(:,k), rvc_seri(:,k), ratio_qi_qtot(:,k), &
-                        shear(:), tke_dissip(:,k), cell_area(:), &
-                        Tbef(:), zq(:), zqs(:), gammasat(:), ratqs(:,k), keepgoing(:), &
-                        rneb(:,k), zqn(:), qvc(:), issrfra(:,k), qissr(:,k), &
-                        dcf_sub(:,k), dcf_con(:,k), dcf_mix(:,k), &
-                        dqi_adj(:,k), dqi_sub(:,k), dqi_con(:,k), dqi_mix(:,k), &
-                        dqvc_adj(:,k), dqvc_sub(:,k), dqvc_con(:,k), dqvc_mix(:,k), &
-                        Tcontr(:,k), qcontr(:,k), qcontr2(:,k), fcontrN(:,k), fcontrP(:,k), &
-                        flight_dist(:,k), flight_h2o(:,k), &
-                        dcf_avi(:,k), dqi_avi(:,k), dqvc_avi(:,k))
-
-
-                  ELSE
-                  !--generalised lognormal condensation scheme (Bony and Emanuel 2001)
-
-                   CALL condensation_lognormal( &
-                       klon, Tbef, zq, zqs, gammasat, ratqs(:,k), &
-                       keepgoing, rneb(:,k), zqn, qvc)
-!                   CALL condensation_lognormal_test( &
-!                       klon, klev, k, keepgoing, ratqs, gammasat, zq, zqs, &
-!                       zqn, qvc, rneb)
-
-
-                  ENDIF ! .NOT. ok_ice_supersat
-
-                  DO i=1,klon
-                      IF (keepgoing(i)) THEN
-
-                        ! If vertical heterogeneity, change fraction by volume as well
-                        IF (iflag_cloudth_vert.GE.3) THEN
-                            ctot_vol(i,k)=rneb(i,k)
-                            rneblsvol(i,k)=ctot_vol(i,k)
-                        ENDIF
-
-
-                       ! P2.2.2> Approximative calculation of temperature variation DT 
-                       !           due to condensation.
-                       ! Calculated variables: 
-                       ! dT : temperature change due to condensation
-                       !---------------------------------------------------------------
-
-                
-                        IF (zfice(i).LT.1) THEN
-                            cste=RLVTT
-                        ELSE
-                            cste=RLSTT
-                        ENDIF
-                        
-                        ! LEA_R : check formule
-                        IF ( ok_unadjusted_clouds ) THEN
-                          !--AB We relax the saturation adjustment assumption
-                          !-- qvc (grid-mean vapor in cloud) is calculated by the condensation scheme
-                          IF ( rneb(i,k) .GT. eps ) THEN
-                            qlbef(i) = MAX(0., zqn(i) - qvc(i) / rneb(i,k))
-                          ELSE
-                            qlbef(i) = 0.
-                          ENDIF
-                        ELSE
-                          qlbef(i)=max(0.,zqn(i)-zqs(i))
-                        ENDIF
-
-                        num = -Tbef(i)+zt(i)+rneb(i,k)*((1-zfice(i))*RLVTT &
-                              +zfice(i)*RLSTT)/RCPD/(1.0+RVTMP2*(zq(i)+zmqc(i)))*qlbef(i)
-                        denom = 1.+rneb(i,k)*((1-zfice(i))*RLVTT+zfice(i)*RLSTT)/cste*zdqs(i) &
-                              -(RLSTT-RLVTT)/RCPD/(1.0+RVTMP2*(zq(i)+zmqc(i)))*rneb(i,k)      &
-                              *qlbef(i)*dzfice(i)
-                        ! here we update a provisory temperature variable that only serves in the iteration
-                        ! process
-                        DT(i)=num/denom
-                        n_i(i)=n_i(i)+1
-
-                    ENDIF ! end keepgoing
-
-                ENDDO     ! end loop on i
-
-        ENDDO         ! iter=1,iflag_fisrtilp_qsat+1
-
-        ! P2.3> Final quantities calculation 
-        ! Calculated variables: 
-        !   rneb : cloud fraction
-        !   zcond: mean condensed water in the mesh
-        !   zqn  : mean water vapor in the mesh
-        !   zfice: ice fraction in clouds
-        !   zt   : temperature
-        !   rhcl : clear-sky relative humidity
-        ! ----------------------------------------------------------------
-
-
-        ! For iflag_t_glace GE 4 the phase partition function dependends on temperature AND distance to cloud top
-        IF (iflag_t_glace.GE.4) THEN
-           CALL distance_to_cloud_top(klon,klev,k,temp,pplay,paprs,rneb,zdistcltop,ztemp_cltop)
-           distcltop(:,k)=zdistcltop(:)
-           temp_cltop(:,k)=ztemp_cltop(:)
-        ENDIF
-
-        ! Partition function depending on temperature
-        CALL icefrac_lscp(klon, zt, iflag_ice_thermo, zdistcltop, ztemp_cltop, zfice, dzfice)
-
-        ! Partition function depending on tke for non shallow-convective clouds 
-        IF (iflag_icefrac .GE. 1) THEN
-
-           CALL icefrac_lscp_turb(klon, dtime, Tbef, pplay(:,k), paprs(:,k), paprs(:,k+1), qice_save(:,k), ziflcld, zqn, &
-           rneb(:,k), tke(:,k), tke_dissip(:,k), zqliq, zqvapcl, zqice, zfice_turb, dzfice_turb, cldfraliq(:,k),sigma2_icefracturb(:,k), mean_icefracturb(:,k))
-
-        ENDIF
-
-        ! Water vapor update, Phase determination and subsequent latent heat exchange
-        DO i=1, klon
-            ! Overwrite phase partitioning in boundary layer mixed phase clouds when the 
-            ! iflag_cloudth_vert=7 and specific param is activated
-            IF (mpc_bl_points(i,k) .GT. 0) THEN
-                zcond(i) = MAX(0.0,qincloud_mpc(i))*rneb(i,k)
-                ! following line is very strange and probably wrong
-                rhcl(i,k)= (zqs(i)+zq(i))/2./zqs(i)
-                ! water vapor update and partition function if thermals
-                zq(i) = zq(i) - zcond(i)        
-                zfice(i)=zfice_th(i)
-            ELSE
-                ! Checks on rneb, rhcl and zqn
-                IF (rneb(i,k) .LE. 0.0) THEN
-                    zqn(i) = 0.0
-                    rneb(i,k) = 0.0
-                    zcond(i) = 0.0
-                    rhcl(i,k)=zq(i)/zqs(i)
-                ELSE IF (rneb(i,k) .GE. 1.0) THEN
-                    zqn(i) = zq(i)
-                    rneb(i,k) = 1.0
-                    IF ( ok_unadjusted_clouds ) THEN
-                      !--AB We relax the saturation adjustment assumption
-                      !-- qvc (grid-mean vapor in cloud) is calculated by the condensation scheme
-                      zcond(i) = MAX(0., zqn(i) - qvc(i))
-                    ELSE
-                      zcond(i) = MAX(0.0,zqn(i)-zqs(i))
-                    ENDIF
-                    rhcl(i,k)=1.0
-                ELSE
-                    IF ( ok_unadjusted_clouds ) THEN
-                      !--AB We relax the saturation adjustment assumption
-                      !-- qvc (grid-mean vapor in cloud) is calculated by the condensation scheme
-                      zcond(i) = MAX(0., zqn(i) * rneb(i,k) - qvc(i))
-                    ELSE
-                      zcond(i) = MAX(0.0,zqn(i)-zqs(i))*rneb(i,k)
-                    ENDIF
-                    ! following line is very strange and probably wrong:
-                    rhcl(i,k)=(zqs(i)+zq(i))/2./zqs(i)
-                    ! Overwrite partitioning for non shallow-convective clouds if iflag_icefrac>1 (icefrac turb param) 
-                    IF (iflag_icefrac .GE. 1) THEN
-                        IF (lognormale(i)) THEN  
-                           zcond(i)  = zqliq(i) + zqice(i)
-                           zfice(i)=zfice_turb(i)
-                           rhcl(i,k) = zqvapcl(i) * rneb(i,k) + (zq(i) - zqn(i)) * (1.-rneb(i,k))
-                        ENDIF
-                    ENDIF
-                ENDIF
-
-                ! water vapor update 
-                zq(i) = zq(i) - zcond(i)
-
-            ENDIF
-
-            ! c_iso : routine that computes in-cloud supersaturation
-            ! c_iso condensation of isotopes (zcond, zsursat, zfice, zq in input) 
-
-            ! temperature update due to phase change
-            zt(i) = zt(i) + (1.-zfice(i))*zcond(i) & 
-            &     * RLVTT/RCPD/(1.0+RVTMP2*(zq(i)+zmqc(i)+zcond(i))) &
-                  +zfice(i)*zcond(i) * RLSTT/RCPD/(1.0+RVTMP2*(zq(i)+zmqc(i)+zcond(i)))
-        ENDDO
-
-        ! If vertical heterogeneity, change volume fraction 
-        IF (iflag_cloudth_vert .GE. 3) THEN
-          ctot_vol(1:klon,k)=min(max(ctot_vol(1:klon,k),0.),1.)
-          rneblsvol(1:klon,k)=ctot_vol(1:klon,k)
-        ENDIF
-    
-    !--AB Write diagnostics and tracers for ice supersaturation
-    IF ( ok_ice_supersat ) THEN
-      CALL calc_qsat_ecmwf(klon,zt,qzero,pplay(:,k),RTT,1,.false.,qsatl(:,k),zdqs)
-      CALL calc_qsat_ecmwf(klon,zt,qzero,pplay(:,k),RTT,2,.false.,qsati(:,k),zdqs)
-
-      DO i = 1, klon
-
-        cf_seri(i,k) = rneb(i,k)
-
-        IF ( .NOT. ok_unadjusted_clouds ) THEN
-          qvc(i) = zqs(i) * rneb(i,k)
-        ENDIF
-        IF ( zq(i) .GT. min_qParent ) THEN
-          rvc_seri(i,k) = qvc(i) / zq(i)
-        ELSE
-          rvc_seri(i,k) = min_ratio
-        ENDIF
-        !--The MIN barrier is NEEDED because of:
-        !-- 1) very rare pathological cases of the lsc scheme (rvc = 1. + 1e-16 sometimes)
-        !-- 2) the thermal scheme does NOT guarantee that qvc <= qvap (or even qincld <= qtot)
-        !--The MAX barrier is a safeguard that should not be activated
-        rvc_seri(i,k) = MIN(MAX(rvc_seri(i,k), 0.), 1.)
-
-        !--Diagnostics
-        gamma_cond(i,k) = gammasat(i)
-        IF ( issrfra(i,k) .LT. eps ) THEN
-          issrfra(i,k) = 0.
-          qissr(i,k) = 0.
-        ENDIF
-        subfra(i,k) = 1. - cf_seri(i,k) - issrfra(i,k)
-        qsub(i,k) = zq(i) - qvc(i) - qissr(i,k)
-        IF ( subfra(i,k) .LT. eps ) THEN
-          subfra(i,k) = 0.
-          qsub(i,k) = 0.
-        ENDIF
-        qcld(i,k) = qvc(i) + zcond(i)
-        IF ( cf_seri(i,k) .LT. eps ) THEN
-          qcld(i,k) = 0.
-        ENDIF
-      ENDDO
-    ENDIF
-
-
-    ! ----------------------------------------------------------------
-    ! P3> Precipitation formation 
-    ! ----------------------------------------------------------------
-
-    !================================================================
-    IF (ok_poprecip) THEN
-
-      DO i = 1, klon
-        zoliql(i) = zcond(i) * ( 1. - zfice(i) )
-        zoliqi(i) = zcond(i) * zfice(i)
-      ENDDO
-
-      CALL poprecip_postcld(klon, dtime, paprs(:,k), paprs(:,k+1), pplay(:,k), &
-                            ctot_vol(:,k), ptconv(:,k), &
-                            zt, zq, zoliql, zoliqi, zfice, &
-                            rneb(:,k), znebprecipclr, znebprecipcld, &
-                            zrfl, zrflclr, zrflcld, &
-                            zifl, ziflclr, ziflcld, &
-                            qraindiag(:,k), qsnowdiag(:,k), dqrauto(:,k), &
-                            dqrcol(:,k), dqrmelt(:,k), dqrfreez(:,k), &
-                            dqsauto(:,k), dqsagg(:,k), dqsrim(:,k), &
-                            dqsmelt(:,k), dqsfreez(:,k) &
-                            )
-
-      DO i = 1, klon
-        zoliq(i) = zoliql(i) + zoliqi(i)
-        IF ( zoliq(i) .GT. 0. ) THEN 
-                zfice(i) = zoliqi(i)/zoliq(i) 
-        ELSE  
-                zfice(i) = 0.0
-        ENDIF
-
-        ! calculation of specific content of condensates seen by radiative scheme 
-        IF (ok_radocond_snow) THEN
-           radocond(i,k) = zoliq(i)
-           radocondl(i,k)= radocond(i,k)*(1.-zfice(i))
-           radocondi(i,k)= radocond(i,k)*zfice(i)+qsnowdiag(i,k)
-        ELSE
-           radocond(i,k) = zoliq(i)
-           radocondl(i,k)= radocond(i,k)*(1.-zfice(i))
-           radocondi(i,k)= radocond(i,k)*zfice(i)
-        ENDIF
-      ENDDO
-
-    !================================================================
-    ELSE
-
-    ! LTP:
-    IF (iflag_evap_prec .GE. 4) THEN
-
-        !Partitionning between precipitation coming from clouds and that coming from CS
-
-        !0) Calculate tot_zneb, total cloud fraction above the cloud
-        !assuming a maximum-random overlap (voir Jakob and Klein, 2000)
-        
-        DO i=1, klon
-                tot_znebn(i) = 1. - (1.-tot_zneb(i))*(1 - max(rneb(i,k),zneb(i))) &
-                        /(1.-min(zneb(i),1.-smallestreal))
-                d_tot_zneb(i) = tot_znebn(i) - tot_zneb(i)
-                tot_zneb(i) = tot_znebn(i)
-
-
-                !1) Cloudy to clear air
-                d_znebprecip_cld_clr(i) = znebprecipcld(i) - min(rneb(i,k),znebprecipcld(i)) 
-                IF (znebprecipcld(i) .GT. 0.) THEN
-                        d_zrfl_cld_clr(i) = d_znebprecip_cld_clr(i)/znebprecipcld(i)*zrflcld(i) 
-                        d_zifl_cld_clr(i) = d_znebprecip_cld_clr(i)/znebprecipcld(i)*ziflcld(i) 
-                ELSE 
-                        d_zrfl_cld_clr(i) = 0. 
-                        d_zifl_cld_clr(i) = 0. 
-                ENDIF
-
-                !2) Clear to cloudy air
-                d_znebprecip_clr_cld(i) = max(0., min(znebprecipclr(i), rneb(i,k) - d_tot_zneb(i) - zneb(i)))
-                IF (znebprecipclr(i) .GT. 0) THEN
-                        d_zrfl_clr_cld(i) = d_znebprecip_clr_cld(i)/znebprecipclr(i)*zrflclr(i) 
-                        d_zifl_clr_cld(i) = d_znebprecip_clr_cld(i)/znebprecipclr(i)*ziflclr(i)
-                ELSE
-                        d_zrfl_clr_cld(i) = 0. 
-                        d_zifl_clr_cld(i) = 0. 
-                ENDIF 
-
-                !Update variables
-                znebprecipcld(i) = znebprecipcld(i) + d_znebprecip_clr_cld(i) - d_znebprecip_cld_clr(i)
-                znebprecipclr(i) = znebprecipclr(i) + d_znebprecip_cld_clr(i) - d_znebprecip_clr_cld(i) 
-                zrflcld(i) = zrflcld(i) + d_zrfl_clr_cld(i) - d_zrfl_cld_clr(i) 
-                ziflcld(i) = ziflcld(i) + d_zifl_clr_cld(i) - d_zifl_cld_clr(i)
-                zrflclr(i) = zrflclr(i) + d_zrfl_cld_clr(i) - d_zrfl_clr_cld(i)
-                ziflclr(i) = ziflclr(i) + d_zifl_cld_clr(i) - d_zifl_clr_cld(i)
-
-                ! c_iso  do the same thing for isotopes precip
-        ENDDO
-    ENDIF
-
-
-    ! Autoconversion
-    ! -------------------------------------------------------------------------------
-
-
-    ! Initialisation of zoliq and radocond variables
-
-    DO i = 1, klon
-            zoliq(i) = zcond(i)
-            zoliqi(i)= zoliq(i)*zfice(i)
-            zoliql(i)= zoliq(i)*(1.-zfice(i))
-            ! c_iso : initialisation of zoliq* also for isotopes
-            zrho(i,k)  = pplay(i,k) / zt(i) / RD
-            zdz(i)   = (paprs(i,k)-paprs(i,k+1)) / (zrho(i,k)*RG)
-            iwc(i)   = 0. 
-            zneb(i)  = MAX(rneb(i,k),seuil_neb)
-            radocond(i,k) = zoliq(i)/REAL(niter_lscp+1)
-            radocondi(i,k)=zoliq(i)*zfice(i)/REAL(niter_lscp+1)
-            radocondl(i,k)=zoliq(i)*(1.-zfice(i))/REAL(niter_lscp+1)
-    ENDDO
-
-       
-    DO n = 1, niter_lscp
-
-        DO i=1,klon
-            IF (rneb(i,k).GT.0.0) THEN
-                iwc(i) = zrho(i,k) * zoliqi(i) / zneb(i) ! in-cloud ice condensate content
-            ENDIF
-        ENDDO
-
-        CALL fallice_velocity(klon,iwc(:),zt(:),zrho(:,k),pplay(:,k),ptconv(:,k),velo(:,k))
-
-        DO i = 1, klon
-
-            IF (rneb(i,k).GT.0.0) THEN
-
-                ! Initialization of zrain, zsnow and zprecip:
-                zrain=0.
-                zsnow=0.
-                zprecip=0.
-                ! c_iso same init for isotopes. Externalisation?
-
-                IF (zneb(i).EQ.seuil_neb) THEN
-                    zprecip = 0.0
-                    zsnow = 0.0
-                    zrain= 0.0
-                ELSE
-
-                    IF (ptconv(i,k)) THEN ! if convective point
-                        zcl=cld_lc_con
-                        zct=1./cld_tau_con
-                        zexpo=cld_expo_con
-                        ffallv=ffallv_con
-                    ELSE
-                        zcl=cld_lc_lsc
-                        zct=1./cld_tau_lsc
-                        zexpo=cld_expo_lsc
-                        ffallv=ffallv_lsc
-                    ENDIF
-
-
-                    ! if vertical heterogeneity is taken into account, we use
-                    ! the "true" volume fraction instead of a modified 
-                    ! surface fraction (which is larger and artificially
-                    ! reduces the in-cloud water).
-
-                    ! Liquid water quantity to remove: zchau (Sundqvist, 1978)
-                    ! dqliq/dt=-qliq/tau*(1-exp(-qcin/clw)**2)
-                    !.........................................................
-                    IF ((iflag_cloudth_vert.GE.3).AND.(iflag_rain_incloud_vol.EQ.1)) THEN
-
-                    ! if vertical heterogeneity is taken into account, we use
-                    ! the "true" volume fraction instead of a modified 
-                    ! surface fraction (which is larger and artificially
-                    ! reduces the in-cloud water).
-                        effective_zneb=ctot_vol(i,k)
-                    ELSE
-                        effective_zneb=zneb(i)
-                    ENDIF 
-
-
-                    IF (iflag_autoconversion .EQ. 2) THEN
-                    ! two-steps resolution with niter_lscp=1 sufficient
-                    ! we first treat the second term (with exponential) in an explicit way
-                    ! and then treat the first term (-q/tau) in an exact way
-                        zchau=zoliql(i)*(1.-exp(-dtime/REAL(niter_lscp)*zct &
-                        *(1.-exp(-(zoliql(i)/effective_zneb/zcl)**zexpo))))
-                    ELSE
-                    ! old explicit resolution with subtimesteps
-                        zchau = zct*dtime/REAL(niter_lscp)*zoliql(i) &
-                        *(1.0-EXP(-(zoliql(i)/effective_zneb/zcl)**zexpo))
-                    ENDIF
-
-
-                    ! Ice water quantity to remove (Zender & Kiehl, 1997)
-                    ! dqice/dt=1/rho*d(rho*wice*qice)/dz
-                    !....................................
-                    IF (iflag_autoconversion .EQ. 2) THEN
-                    ! exact resolution, niter_lscp=1 is sufficient but works only
-                    ! with iflag_vice=0
-                       IF (zoliqi(i) .GT. 0.) THEN
-                          zfroi=(zoliqi(i)-((zoliqi(i)**(-dice_velo)) & 
-                          +dice_velo*dtime/REAL(niter_lscp)*cice_velo/zdz(i)*ffallv)**(-1./dice_velo))
-                       ELSE
-                          zfroi=0.
-                       ENDIF
-                    ELSE
-                    ! old explicit resolution with subtimesteps
-                       zfroi = dtime/REAL(niter_lscp)/zdz(i)*zoliqi(i)*velo(i,k) 
-                    ENDIF
-
-                    zrain   = MIN(MAX(zchau,0.0),zoliql(i))
-                    zsnow   = MIN(MAX(zfroi,0.0),zoliqi(i)) 
-                    zprecip = MAX(zrain + zsnow,0.0)
-
-                ENDIF
-
-                IF (iflag_autoconversion .GE. 1) THEN
-                   ! debugged version with phase conservation through the autoconversion process
-                   zoliql(i) = MAX(zoliql(i)-1.*zrain  , 0.0)
-                   zoliqi(i) = MAX(zoliqi(i)-1.*zsnow  , 0.0)
-                   zoliq(i)  = MAX(zoliq(i)-zprecip , 0.0)
-                ELSE
-                   ! bugged version with phase resetting
-                   zoliql(i) = MAX(zoliq(i)*(1.-zfice(i))-1.*zrain  , 0.0)
-                   zoliqi(i) = MAX(zoliq(i)*zfice(i)-1.*zsnow  , 0.0)
-                   zoliq(i)  = MAX(zoliq(i)-zprecip , 0.0)
-                ENDIF
-
-                ! c_iso: call isotope_conversion (for readibility) or duplicate 
-
-                radocond(i,k) = radocond(i,k) + zoliq(i)/REAL(niter_lscp+1)
-                radocondl(i,k) = radocondl(i,k) + zoliql(i)/REAL(niter_lscp+1)
-                radocondi(i,k) = radocondi(i,k) + zoliqi(i)/REAL(niter_lscp+1)
-
-            ENDIF ! rneb >0
-
-        ENDDO  ! i = 1,klon
-
-    ENDDO      ! n = 1,niter
-
-    ! Precipitation flux calculation
-
-    DO i = 1, klon
-            
-            IF (iflag_evap_prec.GE.4) THEN
-                ziflprev(i)=ziflcld(i)
-            ELSE
-                ziflprev(i)=zifl(i)*zneb(i)
-            ENDIF
-
-            IF (rneb(i,k) .GT. 0.0) THEN
-
-               ! CR&JYG: We account for the Wegener-Findeisen-Bergeron process in the precipitation flux:
-               ! If T<0C, liquid precip are converted into ice, which leads to an increase in
-               ! temperature DeltaT. The effect of DeltaT on condensates and precipitation is roughly
-               ! taken into account through a linearization of the equations and by approximating
-               ! the liquid precipitation process with a "threshold" process. We assume that
-               ! condensates are not modified during this operation. Liquid precipitation is
-               ! removed (in the limit DeltaT<273.15-T). Solid precipitation increases.
-               ! Water vapor increases as well
-               ! Note that compared to fisrtilp, we always assume iflag_bergeron=2
-
-                    zqpreci(i)=(zcond(i)-zoliq(i))*zfice(i)
-                    zqprecl(i)=(zcond(i)-zoliq(i))*(1.-zfice(i))
-                    zcp=RCPD*(1.0+RVTMP2*(zq(i)+zmqc(i)+zcond(i)))
-                    coef1 = rneb(i,k)*RLSTT/zcp*zdqsdT_raw(i)
-                    ! Computation of DT if all the liquid precip freezes
-                    DeltaT = RLMLT*zqprecl(i) / (zcp*(1.+coef1))
-                    ! T should not exceed the freezing point
-                    ! that is Delta > RTT-zt(i)
-                    DeltaT = max( min( RTT-zt(i), DeltaT) , 0. )
-                    zt(i)  = zt(i) + DeltaT
-                    ! water vaporization due to temp. increase
-                    Deltaq = rneb(i,k)*zdqsdT_raw(i)*DeltaT
-                    ! we add this vaporized water to the total vapor and we remove it from the precip
-                    zq(i) = zq(i) +  Deltaq
-                    ! The three "max" lines herebelow protect from rounding errors
-                    zcond(i) = max( zcond(i)- Deltaq, 0. )
-                    ! liquid precipitation converted to ice precip 
-                    Deltaqprecl = -zcp/RLMLT*(1.+coef1)*DeltaT
-                    zqprecl(i) = max( zqprecl(i) + Deltaqprecl, 0. )
-                    ! iced water budget
-                    zqpreci(i) = max (zqpreci(i) - Deltaqprecl - Deltaq, 0.)
-
-                    ! c_iso : mv here condensation of isotopes + redispatchage en precip 
-
-                IF (iflag_evap_prec.GE.4) THEN
-                    zrflcld(i) = zrflcld(i)+zqprecl(i) &
-                    *(paprs(i,k)-paprs(i,k+1))/(RG*dtime)
-                    ziflcld(i) = ziflcld(i)+ zqpreci(i) &
-                        *(paprs(i,k)-paprs(i,k+1))/(RG*dtime)
-                    znebprecipcld(i) = rneb(i,k)
-                    zrfl(i) = zrflcld(i) + zrflclr(i)
-                    zifl(i) = ziflcld(i) + ziflclr(i)
-                ELSE
-                    zrfl(i) = zrfl(i)+ zqprecl(i)        &
-                    *(paprs(i,k)-paprs(i,k+1))/(RG*dtime) 
-                    zifl(i) = zifl(i)+ zqpreci(i)        &
-                   *(paprs(i,k)-paprs(i,k+1))/(RG*dtime)
-                ENDIF
-                ! c_iso : same for isotopes
- 
-           ENDIF ! rneb>0
-
-   ENDDO
-
-    ! LTP: limit of surface cloud fraction covered by precipitation when the local intensity of the flux is below rain_int_min
-    ! if iflag_evap_prec>=4
-    IF (iflag_evap_prec.GE.4) THEN
-
-        DO i=1,klon
-
-            IF ((zrflclr(i) + ziflclr(i)) .GT. 0. ) THEN
-                znebprecipclr(i) = min(znebprecipclr(i),max(zrflclr(i)/ &
-                (MAX(znebprecipclr(i),seuil_neb)*rain_int_min), ziflclr(i)/(MAX(znebprecipclr(i),seuil_neb)*rain_int_min)))
-            ELSE
-                znebprecipclr(i)=0.0
-            ENDIF
-
-            IF ((zrflcld(i) + ziflcld(i)) .GT. 0.) THEN
-                znebprecipcld(i) = min(znebprecipcld(i), max(zrflcld(i)/ &
-                (MAX(znebprecipcld(i),seuil_neb)*rain_int_min), ziflcld(i)/(MAX(znebprecipcld(i),seuil_neb)*rain_int_min)))
-            ELSE
-                znebprecipcld(i)=0.0
-            ENDIF
-        ENDDO
-
-    ENDIF
-
-
-    ENDIF ! ok_poprecip
-
-    ! End of precipitation formation
-    ! --------------------------------
-
-
-    ! Calculation of cloud condensates amount seen by radiative scheme
-    !-----------------------------------------------------------------
-
-    ! Calculation of the concentration of condensates seen by the radiation scheme
-    ! for liquid phase, we take radocondl
-    ! for ice phase, we take radocondi if we neglect snowfall, otherwise (ok_radocond_snow=true) 
-    ! we recalculate radocondi to account for contributions from the precipitation flux
-    ! TODO: for the moment, we deactivate this option when ok_poprecip=.true.
-
-    IF ((ok_radocond_snow) .AND. (k .LT. klev) .AND. (.NOT. ok_poprecip)) THEN
-        ! for the solid phase (crystals + snowflakes)
-        ! we recalculate radocondi by summing
-        ! the ice content calculated in the mesh
-        ! + the contribution of the non-evaporated snowfall 
-        ! from the overlying layer
-        DO i=1,klon
-           IF (ziflprev(i) .NE. 0.0) THEN
-              radocondi(i,k)=zoliq(i)*zfice(i)+zqpreci(i)+ziflprev(i)/zrho(i,k+1)/velo(i,k+1)
-           ELSE
-              radocondi(i,k)=zoliq(i)*zfice(i)+zqpreci(i)
-           ENDIF
-           radocond(i,k)=radocondl(i,k)+radocondi(i,k)
-        ENDDO
-    ENDIF
-
-    ! caculate the percentage of ice in "radocond" so cloud+precip seen by the radiation scheme
-    DO i=1,klon
-        IF (radocond(i,k) .GT. 0.) THEN
-            radicefrac(i,k)=MIN(MAX(radocondi(i,k)/radocond(i,k),0.),1.)
-        ENDIF
-    ENDDO
-
-    ! ----------------------------------------------------------------
-    ! P4> Wet scavenging
-    ! ----------------------------------------------------------------
-
-    !Scavenging through nucleation in the layer
-
-    DO i = 1,klon
-        
-        IF(zcond(i).GT.zoliq(i)+1.e-10) THEN
-            beta(i,k) = (zcond(i)-zoliq(i))/zcond(i)/dtime
-        ELSE
-            beta(i,k) = 0.
-        ENDIF
-
-        zprec_cond(i) = MAX(zcond(i)-zoliq(i),0.0)*(paprs(i,k)-paprs(i,k+1))/RG
-
-        IF (rneb(i,k).GT.0.0.AND.zprec_cond(i).GT.0.) THEN
-
-            IF (temp(i,k) .GE. t_glace_min) THEN
-                zalpha_tr = a_tr_sca(3)
-            ELSE
-                zalpha_tr = a_tr_sca(4)
-            ENDIF
-
-            zfrac_lessi = 1. - EXP(zalpha_tr*zprec_cond(i)/zneb(i))
-            frac_nucl(i,k)= 1.-zneb(i)*zfrac_lessi 
-
-            ! Nucleation with a factor of -1 instead of -0.5
-            zfrac_lessi = 1. - EXP(-zprec_cond(i)/zneb(i))
-
-        ENDIF
-
-    ENDDO
-
-    ! Scavenging through impaction in the underlying layer
-
-    DO kk = k-1, 1, -1
-
-        DO i = 1, klon
-
-            IF (rneb(i,k).GT.0.0.AND.zprec_cond(i).GT.0.) THEN
-
-                IF (temp(i,kk) .GE. t_glace_min) THEN
-                    zalpha_tr = a_tr_sca(1)
-                ELSE
-                    zalpha_tr = a_tr_sca(2)
-                ENDIF
-
-              zfrac_lessi = 1. - EXP(zalpha_tr*zprec_cond(i)/zneb(i))
-              frac_impa(i,kk)= 1.-zneb(i)*zfrac_lessi
-
-            ENDIF
-
-        ENDDO
-
-    ENDDO
-
-    ! Outputs:
-    !-------------------------------
-    ! Precipitation fluxes at layer interfaces
-    ! + precipitation fractions +
-    ! temperature and water species tendencies
-    DO i = 1, klon
-        psfl(i,k)=zifl(i)
-        prfl(i,k)=zrfl(i)
-        pfraclr(i,k)=znebprecipclr(i)
-        pfracld(i,k)=znebprecipcld(i)
-        d_ql(i,k) = (1-zfice(i))*zoliq(i)
-        d_qi(i,k) = zfice(i)*zoliq(i)
-        d_q(i,k) = zq(i) - qt(i,k)
-        ! c_iso: same for isotopes
-        d_t(i,k) = zt(i) - temp(i,k)
-    ENDDO
-
-
-ENDDO
-
-
-  ! Rain or snow at the surface (depending on the first layer temperature)
-  DO i = 1, klon
-      snow(i) = zifl(i)
-      rain(i) = zrfl(i)
-      ! c_iso final output
-  ENDDO
-
-  IF (ncoreczq>0) THEN
-      WRITE(lunout,*)'WARNING : ZQ in LSCP ',ncoreczq,' val < 1.e-15.'
-  ENDIF
-
-
-RETURN
-
-END SUBROUTINE lscp
-!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-
-END MODULE lmdz_lscp
Index: /LMDZ6/trunk/libf/phylmd/lmdz_lscp.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/lmdz_lscp.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/lmdz_lscp.f90	(revision 5268)
@@ -0,0 +1,1635 @@
+MODULE lmdz_lscp
+
+IMPLICIT NONE
+
+CONTAINS
+
+!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+SUBROUTINE lscp(klon,klev,dtime,missing_val,            &
+     paprs,pplay,temp,qt,qice_save,ptconv,ratqs,sigma_qtherm, &
+     d_t, d_q, d_ql, d_qi, rneb, rneblsvol,             &
+     pfraclr, pfracld,                                  &
+     cldfraliq, sigma2_icefracturb,mean_icefracturb,    &
+     radocond, radicefrac, rain, snow,                  &
+     frac_impa, frac_nucl, beta,                        &
+     prfl, psfl, rhcl, qta, fraca,                      &
+     tv, pspsk, tla, thl, iflag_cld_th,                 &
+     iflag_ice_thermo, distcltop, temp_cltop,           &
+     tke, tke_dissip,                                   &
+     cell_area,                                         &
+     cf_seri, rvc_seri, u_seri, v_seri,                 &
+     qsub, qissr, qcld, subfra, issrfra, gamma_cond,    &
+     ratio_qi_qtot, dcf_sub, dcf_con, dcf_mix,          &
+     dqi_adj, dqi_sub, dqi_con, dqi_mix, dqvc_adj,      &
+     dqvc_sub, dqvc_con, dqvc_mix, qsatl, qsati,        &
+     Tcontr, qcontr, qcontr2, fcontrN, fcontrP, dcf_avi,&
+     dqi_avi, dqvc_avi, flight_dist, flight_h2o,        &
+     cloudth_sth,cloudth_senv,cloudth_sigmath,cloudth_sigmaenv, &
+     qraindiag, qsnowdiag, dqreva, dqssub, dqrauto,     &
+     dqrcol, dqrmelt, dqrfreez, dqsauto, dqsagg, dqsrim,&
+     dqsmelt, dqsfreez)
+
+!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+! Authors: Z.X. Li (LMD), J-L Dufresne (LMD), C. Rio (LMD), J-Y Grandpeix (LMD)
+!          A. JAM (LMD), J-B Madeleine (LMD), E. Vignon (LMD), L. Touzze-Peiffert (LMD)
+!--------------------------------------------------------------------------------
+! Date: 01/2021
+!--------------------------------------------------------------------------------
+! Aim: Large Scale Clouds and Precipitation (LSCP)
+!
+! This code is a new version of the fisrtilp.F90 routine, which is itself a 
+! merge of 'first' (superrsaturation physics, P. LeVan K. Laval)
+! and 'ilp' (il pleut, L. Li)
+!
+! Compared to the original fisrtilp code, lscp
+! -> assumes thermcep = .TRUE. all the time (fisrtilp inconsistent when .FALSE.)
+! -> consider always precipitation thermalisation (fl_cor_ebil>0)
+! -> option iflag_fisrtilp_qsat<0 no longer possible (qsat does not evolve with T) 
+! -> option "oldbug" by JYG has been removed
+! -> iflag_t_glace >0 always
+! -> the 'all or nothing' cloud approach is no longer available (cpartiel=T always)
+! -> rectangular distribution from L. Li no longer available
+! -> We always account for the Wegener-Findeisen-Bergeron process (iflag_bergeron = 2 in fisrt) 
+!--------------------------------------------------------------------------------
+! References: 
+!
+! - Bony, S., & Emanuel, K. A. 2001, JAS, doi: 10.1175/1520-0469(2001)058<3158:APOTCA>2.0.CO;2
+! - Hourdin et al. 2013, Clim Dyn, doi:10.1007/s00382-012-1343-y
+! - Jam et al. 2013, Boundary-Layer Meteorol, doi:10.1007/s10546-012-9789-3
+! - Jouhaud, et al. 2018. JAMES, doi:10.1029/2018MS001379
+! - Madeleine et al. 2020, JAMES, doi:10.1029/2020MS002046
+! - Touzze-Peifert Ludo, PhD thesis, p117-124
+! -------------------------------------------------------------------------------
+! Code structure:
+!
+! P0>     Thermalization of the precipitation coming from the overlying layer
+! P1>     Evaporation of the precipitation (falling from the k+1 level)
+! P2>     Cloud formation (at the k level) 
+! P2.A.1> With the PDFs, calculation of cloud properties using the inital
+!         values of T and Q
+! P2.A.2> Coupling between condensed water and temperature
+! P2.A.3> Calculation of final quantities associated with cloud formation
+! P2.B>   Release of Latent heat after cloud formation
+! P3>     Autoconversion to precipitation (k-level)
+! P4>     Wet scavenging
+!------------------------------------------------------------------------------
+! Some preliminary comments (JBM) :
+!
+! The cloud water that the radiation scheme sees is not the same that the cloud
+! water used in the physics and the dynamics 
+! 
+! During the autoconversion to precipitation (P3 step), radocond (cloud water used
+! by the radiation scheme) is calculated as an average of the water that remains
+! in the cloud during the precipitation and not the water remaining at the end
+! of the time step. The latter is used in the rest of the physics and advected
+! by the dynamics. 
+!
+! In summary:
+!
+! Radiation:
+! xflwc(newmicro)+xfiwc(newmicro) =
+!   radocond=lwcon(nc)+iwcon(nc)
+!
+! Notetheless, be aware of:
+!
+! radocond .NE. ocond(nc)
+! i.e.:
+! lwcon(nc)+iwcon(nc) .NE. ocond(nc)
+! but oliq+(ocond-oliq) .EQ. ocond
+! (which is not trivial)
+!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+!
+
+! USE de modules contenant des fonctions.
+USE lmdz_cloudth, ONLY : cloudth, cloudth_v3, cloudth_v6, cloudth_mpc 
+USE lmdz_lscp_tools, ONLY : calc_qsat_ecmwf, calc_gammasat
+USE lmdz_lscp_tools, ONLY : icefrac_lscp, icefrac_lscp_turb
+USE lmdz_lscp_tools, ONLY : fallice_velocity, distance_to_cloud_top
+!USE lmdz_lscp_condensation, ONLY : condensation_lognormal_test, condensation_ice_supersat
+USE lmdz_lscp_condensation, ONLY : condensation_lognormal, condensation_ice_supersat
+USE lmdz_lscp_poprecip, ONLY : poprecip_precld, poprecip_postcld
+
+! Use du module lmdz_lscp_ini contenant les constantes
+USE lmdz_lscp_ini, ONLY : prt_level, lunout, eps
+USE lmdz_lscp_ini, ONLY : seuil_neb, niter_lscp, iflag_evap_prec, t_coup, DDT0, ztfondue, rain_int_min
+USE lmdz_lscp_ini, ONLY : ok_radocond_snow, a_tr_sca, cld_expo_con, cld_expo_lsc
+USE lmdz_lscp_ini, ONLY : iflag_cloudth_vert, iflag_rain_incloud_vol, iflag_t_glace, t_glace_min 
+USE lmdz_lscp_ini, ONLY : coef_eva, coef_sub,cld_tau_lsc, cld_tau_con, cld_lc_lsc, cld_lc_con
+USE lmdz_lscp_ini, ONLY : iflag_bergeron, iflag_fisrtilp_qsat, iflag_vice, cice_velo, dice_velo
+USE lmdz_lscp_ini, ONLY : iflag_autoconversion, ffallv_con, ffallv_lsc, min_frac_th_cld
+USE lmdz_lscp_ini, ONLY : RCPD, RLSTT, RLVTT, RLMLT, RVTMP2, RTT, RD, RG
+USE lmdz_lscp_ini, ONLY : ok_poprecip
+USE lmdz_lscp_ini, ONLY : ok_ice_supersat, ok_unadjusted_clouds, iflag_icefrac
+
+IMPLICIT NONE
+
+!===============================================================================
+! VARIABLES DECLARATION
+!===============================================================================
+
+! INPUT VARIABLES:
+!-----------------
+
+  INTEGER,                         INTENT(IN)   :: klon,klev       ! number of horizontal grid points and vertical levels
+  REAL,                            INTENT(IN)   :: dtime           ! time step [s]
+  REAL,                            INTENT(IN)   :: missing_val     ! missing value for output
+
+  REAL, DIMENSION(klon,klev+1),    INTENT(IN)   :: paprs           ! inter-layer pressure [Pa]
+  REAL, DIMENSION(klon,klev),      INTENT(IN)   :: pplay           ! mid-layer pressure [Pa]
+  REAL, DIMENSION(klon,klev),      INTENT(IN)   :: temp            ! temperature (K)
+  REAL, DIMENSION(klon,klev),      INTENT(IN)   :: qt              ! total specific humidity (in vapor phase in input) [kg/kg] 
+  REAL, DIMENSION(klon,klev),      INTENT(IN)   :: qice_save       ! ice specific from previous time step [kg/kg]
+  INTEGER,                         INTENT(IN)   :: iflag_cld_th    ! flag that determines the distribution of convective clouds
+  INTEGER,                         INTENT(IN)   :: iflag_ice_thermo! flag to activate the ice thermodynamics
+                                                                   ! CR: if iflag_ice_thermo=2, only convection is active
+  LOGICAL, DIMENSION(klon,klev),   INTENT(IN)   :: ptconv          ! grid points where deep convection scheme is active
+
+  !Inputs associated with thermal plumes
+
+  REAL, DIMENSION(klon,klev),      INTENT(IN)   :: tv                  ! virtual potential temperature [K]
+  REAL, DIMENSION(klon,klev),      INTENT(IN)   :: qta                 ! specific humidity within thermals [kg/kg]
+  REAL, DIMENSION(klon,klev),      INTENT(IN)   :: fraca               ! fraction of thermals within the mesh [-]
+  REAL, DIMENSION(klon,klev),      INTENT(IN)   :: pspsk               ! exner potential (p/100000)**(R/cp) 
+  REAL, DIMENSION(klon,klev),      INTENT(IN)   :: tla                 ! liquid temperature within thermals [K]
+  REAL, DIMENSION(klon,klev+1),      INTENT(IN)   :: tke                 !--turbulent kinetic energy [m2/s2]
+  REAL, DIMENSION(klon,klev+1),      INTENT(IN)   :: tke_dissip          !--TKE dissipation [m2/s3]
+
+  ! INPUT/OUTPUT variables
+  !------------------------
+  
+  REAL, DIMENSION(klon,klev),      INTENT(INOUT)   :: thl          ! liquid potential temperature [K]
+  REAL, DIMENSION(klon,klev),      INTENT(INOUT)   :: ratqs,sigma_qtherm        ! function of pressure that sets the large-scale
+
+
+  ! INPUT/OUTPUT condensation and ice supersaturation
+  !--------------------------------------------------
+  REAL, DIMENSION(klon,klev),      INTENT(INOUT):: cf_seri          ! cloud fraction [-]
+  REAL, DIMENSION(klon,klev),      INTENT(INOUT):: ratio_qi_qtot    ! solid specific water to total specific water ratio [-]
+  REAL, DIMENSION(klon,klev),      INTENT(INOUT):: rvc_seri         ! cloudy water vapor to total water vapor ratio [-]
+  REAL, DIMENSION(klon,klev),      INTENT(IN)   :: u_seri           ! eastward wind [m/s]
+  REAL, DIMENSION(klon,klev),      INTENT(IN)   :: v_seri           ! northward wind [m/s]
+  REAL, DIMENSION(klon),           INTENT(IN)   :: cell_area        ! area of each cell [m2]
+
+  ! INPUT/OUTPUT aviation
+  !--------------------------------------------------
+  REAL, DIMENSION(klon,klev),      INTENT(IN)   :: flight_dist      ! Aviation distance flown within the mesh [m/s/mesh]
+  REAL, DIMENSION(klon,klev),      INTENT(IN)   :: flight_h2o       ! Aviation H2O emitted within the mesh [kg H2O/s/mesh]
+  
+  ! OUTPUT variables
+  !-----------------
+
+  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: d_t              ! temperature increment [K]
+  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: d_q              ! specific humidity increment [kg/kg]
+  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: d_ql             ! liquid water increment [kg/kg]
+  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: d_qi             ! cloud ice mass increment [kg/kg]
+  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: rneb             ! cloud fraction [-]
+  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: rneblsvol        ! cloud fraction per unit volume [-]  
+  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: pfraclr          ! precip fraction clear-sky part [-]
+  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: pfracld          ! precip fraction cloudy part [-]
+  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: cldfraliq           ! liquid fraction of cloud [-]
+  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: sigma2_icefracturb  ! Variance of the diagnostic supersaturation distribution (icefrac_turb) [-]
+  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: mean_icefracturb    ! Mean of the diagnostic supersaturation distribution (icefrac_turb) [-]
+  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: radocond         ! condensed water used in the radiation scheme [kg/kg]
+  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: radicefrac       ! ice fraction of condensed water for radiation scheme
+  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: rhcl             ! clear-sky relative humidity [-]
+  REAL, DIMENSION(klon),           INTENT(OUT)  :: rain             ! surface large-scale rainfall [kg/s/m2] 
+  REAL, DIMENSION(klon),           INTENT(OUT)  :: snow             ! surface large-scale snowfall [kg/s/m2]
+  REAL, DIMENSION(klon,klev+1),    INTENT(OUT)  :: prfl             ! large-scale rainfall flux in the column [kg/s/m2]
+  REAL, DIMENSION(klon,klev+1),    INTENT(OUT)  :: psfl             ! large-scale snowfall flux in the column [kg/s/m2]
+  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: distcltop        ! distance to cloud top [m]
+  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: temp_cltop       ! temperature of cloud top [K]
+  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: beta             ! conversion rate of condensed water
+
+  ! fraction of aerosol scavenging through impaction and nucleation    (for on-line)
+  
+  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: frac_impa           ! scavenging fraction due tu impaction [-]
+  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: frac_nucl           ! scavenging fraction due tu nucleation [-]
+  
+  ! for condensation and ice supersaturation
+
+  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: qsub           !--specific total water content in sub-saturated clear sky region [kg/kg]
+  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: qissr          !--specific total water content in supersat region [kg/kg]
+  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: qcld           !--specific total water content in cloudy region [kg/kg]
+  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: subfra         !--mesh fraction of subsaturated clear sky [-]   
+  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: issrfra        !--mesh fraction of ISSR [-]  
+  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: gamma_cond     !--coefficient governing the ice nucleation RHi threshold [-]      
+  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: dcf_sub        !--cloud fraction tendency because of sublimation [s-1]
+  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: dcf_con        !--cloud fraction tendency because of condensation [s-1]
+  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: dcf_mix        !--cloud fraction tendency because of cloud mixing [s-1]
+  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: dqi_adj        !--specific ice content tendency because of temperature adjustment [kg/kg/s]
+  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: dqi_sub        !--specific ice content tendency because of sublimation [kg/kg/s]
+  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: dqi_con        !--specific ice content tendency because of condensation [kg/kg/s]
+  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: dqi_mix        !--specific ice content tendency because of cloud mixing [kg/kg/s]
+  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: dqvc_adj       !--specific cloud water vapor tendency because of temperature adjustment [kg/kg/s]
+  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: dqvc_sub       !--specific cloud water vapor tendency because of sublimation [kg/kg/s]
+  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: dqvc_con       !--specific cloud water vapor tendency because of condensation [kg/kg/s]
+  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: dqvc_mix       !--specific cloud water vapor tendency because of cloud mixing [kg/kg/s]
+  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: qsatl          !--saturation specific humidity wrt liquid [kg/kg]
+  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: qsati          !--saturation specific humidity wrt ice [kg/kg]  
+
+  ! for contrails and aviation
+
+  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: Tcontr         !--threshold temperature for contrail formation [K]
+  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: qcontr         !--threshold humidity for contrail formation [kg/kg]
+  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: qcontr2        !--// (2nd expression more consistent with LMDZ expression of q)
+  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: fcontrN        !--fraction of grid favourable to non-persistent contrails
+  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: fcontrP        !--fraction of grid favourable to persistent contrails
+  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: dcf_avi        !--cloud fraction tendency because of aviation [s-1]
+  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: dqi_avi        !--specific ice content tendency because of aviation [kg/kg/s]
+  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: dqvc_avi       !--specific cloud water vapor tendency because of aviation [kg/kg/s]
+
+
+  ! for POPRECIP
+
+  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: qraindiag      !--DIAGNOSTIC specific rain content [kg/kg]
+  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: qsnowdiag      !--DIAGNOSTIC specific snow content [kg/kg]
+  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: dqreva         !--rain tendendy due to evaporation [kg/kg/s]
+  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: dqssub         !--snow tendency due to sublimation [kg/kg/s]
+  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: dqrcol         !--rain tendendy due to collection by rain of liquid cloud droplets [kg/kg/s]
+  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: dqsagg         !--snow tendency due to collection of lcoud ice by aggregation [kg/kg/s]
+  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: dqrauto        !--rain tendency due to autoconversion of cloud liquid [kg/kg/s]
+  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: dqsauto        !--snow tendency due to autoconversion of cloud ice [kg/kg/s]
+  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: dqsrim         !--snow tendency due to riming [kg/kg/s]
+  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: dqsmelt        !--snow tendency due to melting [kg/kg/s]
+  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: dqrmelt        !--rain tendency due to melting [kg/kg/s]
+  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: dqsfreez       !--snow tendency due to freezing [kg/kg/s]
+  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: dqrfreez       !--rain tendency due to freezing [kg/kg/s]
+
+  ! for thermals
+
+  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: cloudth_sth      !--mean saturation deficit in thermals
+  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: cloudth_senv     !--mean saturation deficit in environment
+  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: cloudth_sigmath  !--std of saturation deficit in thermals
+  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: cloudth_sigmaenv !--std of saturation deficit in environment
+
+
+  ! LOCAL VARIABLES:
+  !----------------
+  REAL,DIMENSION(klon) :: qsl, qsi                                ! saturation threshold at current vertical level
+  REAL :: zct, zcl,zexpo
+  REAL, DIMENSION(klon,klev) :: ctot
+  REAL, DIMENSION(klon,klev) :: ctot_vol
+  REAL, DIMENSION(klon) :: zqs, zdqs
+  REAL :: zdelta, zcor, zcvm5
+  REAL, DIMENSION(klon) :: zdqsdT_raw
+  REAL, DIMENSION(klon) :: gammasat,dgammasatdt                   ! coefficient to make cold condensation at the correct RH and derivative wrt T
+  REAL, DIMENSION(klon) :: Tbef,qlbef,DT                          ! temperature, humidity and temp. variation during lognormal iteration
+  REAL :: num,denom
+  REAL :: cste
+  REAL, DIMENSION(klon) :: zpdf_sig,zpdf_k,zpdf_delta             ! lognormal parameters
+  REAL, DIMENSION(klon) :: Zpdf_a,zpdf_b,zpdf_e1,zpdf_e2          ! lognormal intermediate variables
+  REAL :: erf
+  REAL, DIMENSION(klon) :: zfice_th
+  REAL, DIMENSION(klon) :: qcloud, qincloud_mpc
+  REAL, DIMENSION(klon) :: zrfl, zrfln
+  REAL :: zqev, zqevt 
+  REAL, DIMENSION(klon) :: zifl, zifln, ziflprev
+  REAL :: zqev0,zqevi, zqevti
+  REAL, DIMENSION(klon) :: zoliq, zcond, zq, zqn
+  REAL, DIMENSION(klon) :: zoliql, zoliqi
+  REAL, DIMENSION(klon) :: zt
+  REAL, DIMENSION(klon,klev) :: zrho
+  REAL, DIMENSION(klon) :: zdz,iwc
+  REAL :: zchau,zfroi
+  REAL, DIMENSION(klon) :: zfice,zneb,znebprecip
+  REAL :: zmelt,zrain,zsnow,zprecip
+  REAL, DIMENSION(klon) :: dzfice
+  REAL, DIMENSION(klon) :: zfice_turb, dzfice_turb
+  REAL :: zsolid
+  REAL, DIMENSION(klon) :: qtot, qzero
+  REAL, DIMENSION(klon) :: dqsl,dqsi
+  REAL :: smallestreal
+  !  Variables for Bergeron process
+  REAL :: zcp, coef1, DeltaT, Deltaq, Deltaqprecl
+  REAL, DIMENSION(klon) :: zqpreci, zqprecl
+  ! Variables precipitation energy conservation
+  REAL, DIMENSION(klon) :: zmqc
+  REAL :: zalpha_tr
+  REAL :: zfrac_lessi
+  REAL, DIMENSION(klon) :: zprec_cond
+  REAL :: zmair
+  REAL :: zcpair, zcpeau
+  REAL, DIMENSION(klon) :: zlh_solid
+  REAL, DIMENSION(klon) :: ztupnew
+  REAL, DIMENSION(klon) :: zqvapclr, zqupnew ! for poprecip evap / subl
+  REAL :: zm_solid         ! for liquid -> solid conversion
+  REAL, DIMENSION(klon) :: zrflclr, zrflcld
+  REAL, DIMENSION(klon) :: d_zrfl_clr_cld, d_zifl_clr_cld
+  REAL, DIMENSION(klon) :: d_zrfl_cld_clr, d_zifl_cld_clr 
+  REAL, DIMENSION(klon) :: ziflclr, ziflcld
+  REAL, DIMENSION(klon) :: znebprecipclr, znebprecipcld
+  REAL, DIMENSION(klon) :: tot_zneb, tot_znebn, d_tot_zneb
+  REAL, DIMENSION(klon) :: d_znebprecip_clr_cld, d_znebprecip_cld_clr
+  REAL, DIMENSION(klon,klev) :: velo
+  REAL :: vr, ffallv
+  REAL :: qlmpc, qimpc, rnebmpc
+  REAL, DIMENSION(klon,klev) :: radocondi, radocondl
+  REAL :: effective_zneb
+  REAL, DIMENSION(klon) :: zdistcltop, ztemp_cltop
+  REAL, DIMENSION(klon) :: zqliq, zqice, zqvapcl        ! for icefrac_lscp_turb
+  
+  ! for condensation and ice supersaturation
+  REAL, DIMENSION(klon) :: qvc, shear
+  REAL :: delta_z
+  !--Added for ice supersaturation (ok_ice_supersat) and contrails (ok_plane_contrails)
+  ! Constants used for calculating ratios that are advected (using a parent-child
+  ! formalism). This is not done in the dynamical core because at this moment,
+  ! only isotopes can use this parent-child formalism. Note that the two constants
+  ! are the same as the one use in the dynamical core, being also defined in
+  ! dyn3d_common/infotrac.F90
+  REAL :: min_qParent, min_ratio
+
+  INTEGER i, k, n, kk, iter
+  INTEGER, DIMENSION(klon) :: n_i
+  INTEGER ncoreczq
+  INTEGER, DIMENSION(klon,klev) :: mpc_bl_points
+  LOGICAL iftop
+
+  LOGICAL, DIMENSION(klon) :: lognormale
+  LOGICAL, DIMENSION(klon) :: keepgoing
+
+  CHARACTER (len = 20) :: modname = 'lscp'
+  CHARACTER (len = 80) :: abort_message
+  
+
+!===============================================================================
+! INITIALISATION
+!===============================================================================
+
+! Few initial checks
+
+
+IF (iflag_fisrtilp_qsat .LT. 0) THEN
+    abort_message = 'lscp cannot be used with iflag_fisrtilp<0'
+    CALL abort_physic(modname,abort_message,1)
+ENDIF
+
+! Few initialisations
+
+znebprecip(:)=0.0
+ctot_vol(1:klon,1:klev)=0.0
+rneblsvol(1:klon,1:klev)=0.0
+smallestreal=1.e-9
+znebprecipclr(:)=0.0
+znebprecipcld(:)=0.0
+mpc_bl_points(:,:)=0
+
+IF (prt_level>9) WRITE(lunout,*) 'NUAGES4 A. JAM'
+
+! AA for 'safety' reasons
+zalpha_tr   = 0.
+zfrac_lessi = 0.
+beta(:,:)= 0.
+
+! Initialisation of variables:
+
+prfl(:,:) = 0.0
+psfl(:,:) = 0.0
+d_t(:,:) = 0.0
+d_q(:,:) = 0.0
+d_ql(:,:) = 0.0
+d_qi(:,:) = 0.0
+rneb(:,:) = 0.0
+pfraclr(:,:)=0.0
+pfracld(:,:)=0.0
+cldfraliq(:,:)=0.
+sigma2_icefracturb(:,:)=0.
+mean_icefracturb(:,:)=0.
+radocond(:,:) = 0.0
+radicefrac(:,:) = 0.0
+frac_nucl(:,:) = 1.0 
+frac_impa(:,:) = 1.0 
+rain(:) = 0.0
+snow(:) = 0.0
+zoliq(:)=0.0
+zfice(:)=0.0
+dzfice(:)=0.0
+zfice_turb(:)=0.0
+dzfice_turb(:)=0.0
+zqprecl(:)=0.0
+zqpreci(:)=0.0
+zrfl(:) = 0.0
+zifl(:) = 0.0
+ziflprev(:)=0.0
+zneb(:) = seuil_neb
+zrflclr(:) = 0.0
+ziflclr(:) = 0.0
+zrflcld(:) = 0.0
+ziflcld(:) = 0.0
+tot_zneb(:) = 0.0
+tot_znebn(:) = 0.0
+d_tot_zneb(:) = 0.0
+qzero(:) = 0.0
+zdistcltop(:)=0.0
+ztemp_cltop(:) = 0.0
+ztupnew(:)=0.0
+
+distcltop(:,:)=0.
+temp_cltop(:,:)=0.
+
+!--Ice supersaturation
+gamma_cond(:,:) = 1.
+qissr(:,:)      = 0.
+issrfra(:,:)    = 0.
+dcf_sub(:,:)    = 0.
+dcf_con(:,:)    = 0.
+dcf_mix(:,:)    = 0.
+dqi_adj(:,:)    = 0.
+dqi_sub(:,:)    = 0.
+dqi_con(:,:)    = 0.
+dqi_mix(:,:)    = 0.
+dqvc_adj(:,:)   = 0.
+dqvc_sub(:,:)   = 0.
+dqvc_con(:,:)   = 0.
+dqvc_mix(:,:)   = 0.
+fcontrN(:,:)    = 0.
+fcontrP(:,:)    = 0.
+Tcontr(:,:)     = missing_val
+qcontr(:,:)     = missing_val
+qcontr2(:,:)    = missing_val
+dcf_avi(:,:)    = 0.
+dqi_avi(:,:)    = 0.
+dqvc_avi(:,:)   = 0.
+qvc(:)          = 0.
+shear(:)        = 0.
+min_qParent     = 1.e-30
+min_ratio       = 1.e-16
+
+!-- poprecip
+qraindiag(:,:)= 0.
+qsnowdiag(:,:)= 0.
+dqreva(:,:)   = 0.
+dqrauto(:,:)  = 0.
+dqrmelt(:,:)  = 0.
+dqrfreez(:,:) = 0.
+dqrcol(:,:)   = 0.
+dqssub(:,:)   = 0.
+dqsauto(:,:)  = 0.
+dqsrim(:,:)   = 0.
+dqsagg(:,:)   = 0.
+dqsfreez(:,:) = 0.
+dqsmelt(:,:)  = 0.
+zqupnew(:)    = 0.
+zqvapclr(:)   = 0.
+
+
+
+!c_iso: variable initialisation for iso 
+
+
+!===============================================================================
+!              BEGINNING OF VERTICAL LOOP FROM TOP TO BOTTOM
+!===============================================================================
+
+ncoreczq=0
+
+DO k = klev, 1, -1
+
+    IF (k.LE.klev-1) THEN
+       iftop=.false. 
+    ELSE 
+       iftop=.true.
+    ENDIF
+
+    ! Initialisation temperature and specific humidity
+    ! temp(klon,klev) is not modified by the routine, instead all changes in temperature are made on zt
+    ! at the end of the klon loop, a temperature incremtent d_t due to all processes
+    ! (thermalization, evap/sub incoming precip, cloud formation, precipitation processes) is calculated 
+    ! d_t = temperature tendency due to lscp
+    ! The temperature of the overlying layer is updated here because needed for thermalization
+    DO i = 1, klon
+        zt(i)=temp(i,k)
+        zq(i)=qt(i,k)
+        IF (.not. iftop) THEN
+           ztupnew(i)  = temp(i,k+1) + d_t(i,k+1)
+           zqupnew(i)  = qt(i,k+1) + d_q(i,k+1) + d_ql(i,k+1) + d_qi(i,k+1)
+           !--zqs(i) is the saturation specific humidity in the layer above
+           zqvapclr(i) = MAX(0., qt(i,k+1) + d_q(i,k+1) - rneb(i,k+1) * zqs(i))
+        ENDIF
+        !c_iso init of iso
+    ENDDO
+   
+    !================================================================
+    ! Flag for the new and more microphysical treatment of precipitation from Atelier Nuage (R)
+    IF (ok_poprecip) THEN
+
+            CALL poprecip_precld(klon, dtime, iftop, paprs(:,k), paprs(:,k+1), pplay(:,k), &
+                              zt, ztupnew, zq, zmqc, znebprecipclr, znebprecipcld, &
+                              zqvapclr, zqupnew, &
+                              zrfl, zrflclr, zrflcld, &
+                              zifl, ziflclr, ziflcld, &
+                              dqreva(:,k),dqssub(:,k) &
+                             )
+
+    !================================================================
+    ELSE
+
+    ! --------------------------------------------------------------------
+    ! P1> Thermalization of precipitation falling from the overlying layer
+    ! --------------------------------------------------------------------
+    ! Computes air temperature variation due to enthalpy transported by
+    ! precipitation. Precipitation is then thermalized with the air in the
+    ! layer. 
+    ! The precipitation should remain thermalized throughout the different
+    ! thermodynamical transformations. 
+    ! The corresponding water mass should
+    ! be added when calculating the layer's enthalpy change with 
+    ! temperature
+    ! See lmdzpedia page todoan
+    ! todoan: check consistency with ice phase
+    ! todoan: understand why several steps
+    ! ---------------------------------------------------------------------
+    
+    IF (iftop) THEN
+
+        DO i = 1, klon
+            zmqc(i) = 0.
+        ENDDO
+
+    ELSE
+
+        DO i = 1, klon
+ 
+            zmair=(paprs(i,k)-paprs(i,k+1))/RG
+            ! no condensed water so cp=cp(vapor+dry air)
+            ! RVTMP2=rcpv/rcpd-1
+            zcpair=RCPD*(1.0+RVTMP2*zq(i)) 
+            zcpeau=RCPD*RVTMP2
+
+            ! zmqc: precipitation mass that has to be thermalized with 
+            ! layer's air so that precipitation at the ground has the
+            ! same temperature as the lowermost layer
+            zmqc(i) = (zrfl(i)+zifl(i))*dtime/zmair
+            ! t(i,k+1)+d_t(i,k+1): new temperature of the overlying layer
+            zt(i) = ( ztupnew(i)*zmqc(i)*zcpeau + zcpair*zt(i) ) &
+             / (zcpair + zmqc(i)*zcpeau)
+
+        ENDDO
+ 
+    ENDIF
+
+    ! --------------------------------------------------------------------
+    ! P2> Precipitation evaporation/sublimation/melting
+    ! --------------------------------------------------------------------
+    ! A part of the precipitation coming from above is evaporated/sublimated/melted.
+    ! --------------------------------------------------------------------
+    
+    IF (iflag_evap_prec.GE.1) THEN 
+
+        ! Calculation of saturation specific humidity
+        ! depending on temperature:
+        CALL calc_qsat_ecmwf(klon,zt(:),qzero(:),pplay(:,k),RTT,0,.false.,zqs(:),zdqs(:))
+        ! wrt liquid water
+        CALL calc_qsat_ecmwf(klon,zt(:),qzero(:),pplay(:,k),RTT,1,.false.,qsl(:),dqsl(:))
+        ! wrt ice
+        CALL calc_qsat_ecmwf(klon,zt(:),qzero(:),pplay(:,k),RTT,2,.false.,qsi(:),dqsi(:))
+
+        DO i = 1, klon
+
+            ! if precipitation
+            IF (zrfl(i)+zifl(i).GT.0.) THEN
+
+            ! LudoTP: we only account for precipitation evaporation in the clear-sky (iflag_evap_prec>=4).
+            ! c_iso: likely important to distinguish cs from neb isotope precipitation
+
+                IF (iflag_evap_prec.GE.4) THEN
+                    zrfl(i) = zrflclr(i)
+                    zifl(i) = ziflclr(i)
+                ENDIF
+
+                IF (iflag_evap_prec.EQ.1) THEN
+                    znebprecip(i)=zneb(i)
+                ELSE
+                    znebprecip(i)=MAX(zneb(i),znebprecip(i))
+                ENDIF
+
+                IF (iflag_evap_prec.GT.4) THEN
+                ! Max evaporation not to saturate the clear sky precip fraction
+                ! i.e. the fraction where evaporation occurs
+                    zqev0 = MAX(0.0, (zqs(i)-zq(i))*znebprecipclr(i))
+                ELSEIF (iflag_evap_prec .EQ. 4) THEN
+                ! Max evaporation not to saturate the whole mesh
+                ! Pay attention -> lead to unrealistic and excessive evaporation
+                    zqev0 = MAX(0.0, zqs(i)-zq(i))
+                ELSE
+                ! Max evap not to saturate the fraction below the cloud
+                    zqev0 = MAX(0.0, (zqs(i)-zq(i))*znebprecip(i))
+                ENDIF
+
+                ! Evaporation of liquid precipitation coming from above
+                ! dP/dz=beta*(1-q/qsat)*sqrt(P)
+                ! formula from Sundquist 1988, Klemp & Wilhemson 1978
+                ! LTP: evaporation only in the clear sky part (iflag_evap_prec>=4)
+
+                IF (iflag_evap_prec.EQ.3) THEN
+                    zqevt = znebprecip(i)*coef_eva*(1.0-zq(i)/qsl(i)) &
+                    *SQRT(zrfl(i)/max(1.e-4,znebprecip(i)))        &
+                    *(paprs(i,k)-paprs(i,k+1))/pplay(i,k)*zt(i)*RD/RG
+                ELSE IF (iflag_evap_prec.GE.4) THEN
+                     zqevt = znebprecipclr(i)*coef_eva*(1.0-zq(i)/qsl(i)) &
+                    *SQRT(zrfl(i)/max(1.e-8,znebprecipclr(i))) &
+                    *(paprs(i,k)-paprs(i,k+1))/pplay(i,k)*zt(i)*RD/RG
+                ELSE
+                    zqevt = 1.*coef_eva*(1.0-zq(i)/qsl(i))*SQRT(zrfl(i)) &
+                    *(paprs(i,k)-paprs(i,k+1))/pplay(i,k)*zt(i)*RD/RG
+                ENDIF
+
+                zqevt = MAX(0.0,MIN(zqevt,zrfl(i))) &
+                    *RG*dtime/(paprs(i,k)-paprs(i,k+1)) 
+
+                ! sublimation of the solid precipitation coming from above
+                IF (iflag_evap_prec.EQ.3) THEN
+                    zqevti = znebprecip(i)*coef_sub*(1.0-zq(i)/qsi(i)) &
+                    *SQRT(zifl(i)/max(1.e-4,znebprecip(i))) &
+                    *(paprs(i,k)-paprs(i,k+1))/pplay(i,k)*zt(i)*RD/RG
+                ELSE IF (iflag_evap_prec.GE.4) THEN
+                     zqevti = znebprecipclr(i)*coef_sub*(1.0-zq(i)/qsi(i)) &
+                    *SQRT(zifl(i)/max(1.e-8,znebprecipclr(i))) &
+                    *(paprs(i,k)-paprs(i,k+1))/pplay(i,k)*zt(i)*RD/RG
+                ELSE
+                    zqevti = 1.*coef_sub*(1.0-zq(i)/qsi(i))*SQRT(zifl(i)) &
+                    *(paprs(i,k)-paprs(i,k+1))/pplay(i,k)*zt(i)*RD/RG
+                ENDIF
+
+                zqevti = MAX(0.0,MIN(zqevti,zifl(i))) &
+                *RG*dtime/(paprs(i,k)-paprs(i,k+1))
+
+                ! A. JAM
+                ! Evaporation limit: we ensure that the layer's fraction below
+                ! the cloud or the whole mesh (depending on iflag_evap_prec)
+                ! does not reach saturation. In this case, we 
+                ! redistribute zqev0 conserving the ratio liquid/ice 
+
+                IF (zqevt+zqevti.GT.zqev0) THEN
+                    zqev=zqev0*zqevt/(zqevt+zqevti)
+                    zqevi=zqev0*zqevti/(zqevt+zqevti)
+                ELSE
+                    zqev=zqevt
+                    zqevi=zqevti
+                ENDIF
+
+
+                ! New solid and liquid precipitation fluxes after evap and sublimation
+                zrfln(i) = Max(0.,zrfl(i) - zqev*(paprs(i,k)-paprs(i,k+1))  &
+                         /RG/dtime)
+                zifln(i) = Max(0.,zifl(i) - zqevi*(paprs(i,k)-paprs(i,k+1)) &
+                         /RG/dtime)
+
+
+                ! vapor, temperature, precip fluxes update
+                ! vapor is updated after evaporation/sublimation (it is increased)
+                zq(i) = zq(i) - (zrfln(i)+zifln(i)-zrfl(i)-zifl(i)) &
+                * (RG/(paprs(i,k)-paprs(i,k+1)))*dtime
+                ! zmqc is the total condensed water in the precip flux (it is decreased)
+                zmqc(i) = zmqc(i) + (zrfln(i)+zifln(i)-zrfl(i)-zifl(i)) &
+                * (RG/(paprs(i,k)-paprs(i,k+1)))*dtime
+                ! air and precip temperature (i.e., gridbox temperature)
+                ! is updated due to latent heat cooling
+                zt(i) = zt(i) + (zrfln(i)-zrfl(i))        &
+                * (RG/(paprs(i,k)-paprs(i,k+1)))*dtime    &
+                * RLVTT/RCPD/(1.0+RVTMP2*(zq(i)+zmqc(i))) &
+                + (zifln(i)-zifl(i))                      &
+                * (RG/(paprs(i,k)-paprs(i,k+1)))*dtime    &
+                * RLSTT/RCPD/(1.0+RVTMP2*(zq(i)+zmqc(i)))
+
+                ! New values of liquid and solid precipitation 
+                zrfl(i) = zrfln(i)
+                zifl(i) = zifln(i)
+
+                ! c_iso here call_reevap that updates isotopic zrfl, zifl (in inout)
+                !                         due to evap + sublim                                     
+                                           
+
+                IF (iflag_evap_prec.GE.4) THEN
+                    zrflclr(i) = zrfl(i)
+                    ziflclr(i) = zifl(i)
+                    IF(zrflclr(i) + ziflclr(i).LE.0) THEN
+                        znebprecipclr(i) = 0.0
+                    ENDIF
+                    zrfl(i) = zrflclr(i) + zrflcld(i)
+                    zifl(i) = ziflclr(i) + ziflcld(i)
+                ENDIF
+
+                ! c_iso duplicate for isotopes or loop on isotopes
+
+                ! Melting:
+                zmelt = ((zt(i)-RTT)/(ztfondue-RTT)) ! JYG
+                ! precip fraction that is melted
+                zmelt = MIN(MAX(zmelt,0.),1.)
+
+                ! update of rainfall and snowfall due to melting
+                IF (iflag_evap_prec.GE.4) THEN
+                    zrflclr(i)=zrflclr(i)+zmelt*ziflclr(i)
+                    zrflcld(i)=zrflcld(i)+zmelt*ziflcld(i)
+                    zrfl(i)=zrflclr(i)+zrflcld(i)
+                ELSE
+                    zrfl(i)=zrfl(i)+zmelt*zifl(i)
+                ENDIF
+
+
+                ! c_iso: melting of isotopic precipi with zmelt (no fractionation)
+
+                ! Latent heat of melting because of precipitation melting
+                ! NB: the air + precip temperature is simultaneously updated
+                zt(i)=zt(i)-zifl(i)*zmelt*(RG*dtime)/(paprs(i,k)-paprs(i,k+1)) &
+                *RLMLT/RCPD/(1.0+RVTMP2*(zq(i)+zmqc(i)))
+               
+                IF (iflag_evap_prec.GE.4) THEN
+                    ziflclr(i)=ziflclr(i)*(1.-zmelt)
+                    ziflcld(i)=ziflcld(i)*(1.-zmelt)
+                    zifl(i)=ziflclr(i)+ziflcld(i)
+                ELSE
+                    zifl(i)=zifl(i)*(1.-zmelt)
+                ENDIF
+
+            ELSE
+                ! if no precip, we reinitialize the cloud fraction used for the precip to 0 
+                znebprecip(i)=0.
+
+            ENDIF ! (zrfl(i)+zifl(i).GT.0.)
+
+        ENDDO ! loop on klon
+
+    ENDIF ! (iflag_evap_prec>=1)
+
+    ENDIF ! (ok_poprecip)
+
+    ! --------------------------------------------------------------------
+    ! End precip evaporation
+    ! --------------------------------------------------------------------
+    
+    ! Calculation of qsat, L/Cp*dqsat/dT and ncoreczq counter
+    !-------------------------------------------------------
+
+     qtot(:)=zq(:)+zmqc(:)
+     CALL calc_qsat_ecmwf(klon,zt(:),qtot(:),pplay(:,k),RTT,0,.false.,zqs(:),zdqs(:))
+     DO i = 1, klon
+            zdelta = MAX(0.,SIGN(1.,RTT-zt(i)))
+            zdqsdT_raw(i) = zdqs(i)*RCPD*(1.0+RVTMP2*zq(i)) / (RLVTT*(1.-zdelta) + RLSTT*zdelta)
+            IF (zq(i) .LT. 1.e-15) THEN
+                ncoreczq=ncoreczq+1
+                zq(i)=1.e-15
+            ENDIF
+            ! c_iso: do something similar for isotopes
+
+     ENDDO
+    
+    ! --------------------------------------------------------------------
+    ! P2> Cloud formation
+    !---------------------------------------------------------------------
+    !
+    ! Unlike fisrtilp, we always assume a 'fractional cloud' approach 
+    ! i.e. clouds occupy only a fraction of the mesh (the subgrid distribution
+    ! is prescribed and depends on large scale variables and boundary layer
+    ! properties)
+    ! The decrease in condensed part due tu latent heating is taken into
+    ! account
+    ! -------------------------------------------------------------------
+
+        ! P2.1> With the PDFs (log-normal, bigaussian) 
+        ! cloud properties calculation with the initial values of t and q
+        ! ----------------------------------------------------------------
+
+        ! initialise gammasat and qincloud_mpc
+        gammasat(:)=1.
+        qincloud_mpc(:)=0.
+
+        IF (iflag_cld_th.GE.5) THEN
+               ! Cloud cover and content in meshes affected by shallow convection, 
+               ! are retrieved from a bi-gaussian distribution of the saturation deficit
+               ! following Jam et al. 2013
+
+               IF (iflag_cloudth_vert.LE.2) THEN
+                  ! Old version of Arnaud Jam
+
+                    CALL cloudth(klon,klev,k,tv,                  &
+                         zq,qta,fraca,                            &
+                         qcloud,ctot,pspsk,paprs,pplay,tla,thl, &
+                         ratqs,zqs,temp,                              &
+                         cloudth_sth,cloudth_senv,cloudth_sigmath,cloudth_sigmaenv)
+
+
+                ELSEIF (iflag_cloudth_vert.GE.3 .AND. iflag_cloudth_vert.LE.5) THEN
+                   ! Default version of Arnaud Jam
+                        
+                    CALL cloudth_v3(klon,klev,k,tv,                        &
+                         zq,qta,fraca,                                     &
+                         qcloud,ctot,ctot_vol,pspsk,paprs,pplay,tla,thl, &
+                         ratqs,sigma_qtherm,zqs,temp, &
+                         cloudth_sth,cloudth_senv,cloudth_sigmath,cloudth_sigmaenv)
+
+
+                ELSEIF (iflag_cloudth_vert.EQ.6) THEN
+                   ! Jean Jouhaud's version, with specific separation between surface and volume
+                   ! cloud fraction Decembre 2018 
+
+                    CALL cloudth_v6(klon,klev,k,tv,                        &
+                         zq,qta,fraca,                                     &
+                         qcloud,ctot,ctot_vol,pspsk,paprs,pplay,tla,thl, &
+                         ratqs,zqs,temp, &
+                         cloudth_sth,cloudth_senv,cloudth_sigmath,cloudth_sigmaenv)
+
+                ELSEIF (iflag_cloudth_vert .EQ. 7) THEN
+                   ! Updated version of Arnaud Jam (correction by E. Vignon) + adapted treatment
+                   ! for boundary-layer mixed phase clouds 
+                    CALL cloudth_mpc(klon,klev,k,mpc_bl_points,zt,zq,qta(:,k),fraca(:,k), &
+                                     pspsk(:,k),paprs(:,k+1),paprs(:,k),pplay(:,k), tla(:,k), &
+                                     ratqs(:,k),qcloud,qincloud_mpc,zfice_th,ctot(:,k),ctot_vol(:,k), &
+                                     cloudth_sth(:,k),cloudth_senv(:,k),cloudth_sigmath(:,k),cloudth_sigmaenv(:,k))
+
+                ENDIF
+
+
+                DO i=1,klon
+                    rneb(i,k)=ctot(i,k)
+                    rneblsvol(i,k)=ctot_vol(i,k)
+                    zqn(i)=qcloud(i)
+                    !--AB grid-mean vapor in the cloud - we assume saturation adjustment
+                    qvc(i) = rneb(i,k) * zqs(i)
+                ENDDO
+
+        ENDIF
+
+        IF (iflag_cld_th .LE. 4) THEN
+            
+                ! lognormal 
+            lognormale(:) = .TRUE.
+
+        ELSEIF (iflag_cld_th .GE. 6) THEN
+            
+                ! lognormal distribution when no thermals 
+            lognormale(:) = fraca(:,k) < min_frac_th_cld
+
+        ELSE
+                ! When iflag_cld_th=5, we always assume
+                ! bi-gaussian distribution
+            lognormale(:) = .FALSE.
+        
+        ENDIF
+
+        DT(:) = 0.
+        n_i(:)=0
+        Tbef(:)=zt(:)
+        qlbef(:)=0.
+
+        ! Treatment of non-boundary layer clouds (lognormale)
+        ! condensation with qsat(T) variation (adaptation)
+        ! Iterative resolution to converge towards qsat
+        ! with update of temperature, ice fraction and qsat at 
+        ! each iteration
+
+        ! todoan -> sensitivity to iflag_fisrtilp_qsat
+        DO iter=1,iflag_fisrtilp_qsat+1
+
+                keepgoing(:) = .FALSE.
+
+                DO i=1,klon
+
+                    ! keepgoing = .true. while convergence is not satisfied
+
+                    IF (((ABS(DT(i)).GT.DDT0) .OR. (n_i(i) .EQ. 0)) .AND. lognormale(i)) THEN
+
+                        ! if not convergence:
+                        ! we calculate a new iteration
+                        keepgoing(i) = .TRUE.
+
+                        ! P2.2.1> cloud fraction and condensed water mass calculation
+                        ! Calculated variables: 
+                        ! rneb : cloud fraction
+                        ! zqn : total water within the cloud
+                        ! zcond: mean condensed water within the mesh
+                        ! rhcl: clear-sky relative humidity
+                        !---------------------------------------------------------------
+
+                        ! new temperature that only serves in the iteration process:
+                        Tbef(i)=Tbef(i)+DT(i)
+
+                        ! Rneb, qzn and zcond for lognormal PDFs
+                        qtot(i)=zq(i)+zmqc(i)
+
+                      ENDIF
+
+                  ENDDO
+
+                  ! Calculation of saturation specific humidity and ice fraction
+                  CALL calc_qsat_ecmwf(klon,Tbef(:),qtot(:),pplay(:,k),RTT,0,.false.,zqs(:),zdqs(:))
+                  CALL calc_gammasat(klon,Tbef(:),qtot(:),pplay(:,k),gammasat(:),dgammasatdt(:))
+                  ! saturation may occur at a humidity different from qsat (gamma qsat), so gamma correction for dqs
+                  zdqs(:) = gammasat(:)*zdqs(:)+zqs(:)*dgammasatdt(:)
+                  ! cloud phase determination
+                  IF (iflag_t_glace.GE.4) THEN
+                  ! For iflag_t_glace GE 4 the phase partition function dependends on temperature AND distance to cloud top
+                       CALL distance_to_cloud_top(klon,klev,k,temp,pplay,paprs,rneb,zdistcltop,ztemp_cltop)
+                  ENDIF
+
+                  CALL icefrac_lscp(klon, zt(:), iflag_ice_thermo, zdistcltop(:),ztemp_cltop(:),zfice(:),dzfice(:))
+
+                  !--AB Activates a condensation scheme that allows for
+                  !--ice supersaturation and contrails evolution from aviation
+                  IF (ok_ice_supersat) THEN
+
+                    !--Calculate the shear value (input for condensation and ice supersat)
+                    DO i = 1, klon
+                      !--Cell thickness [m]
+                      delta_z = ( paprs(i,k) - paprs(i,k+1) ) / RG / pplay(i,k) * Tbef(i) * RD
+                      IF ( iftop ) THEN
+                        ! top
+                        shear(i) = SQRT( ( (u_seri(i,k) - u_seri(i,k-1)) / delta_z )**2. &
+                                       + ( (v_seri(i,k) - v_seri(i,k-1)) / delta_z )**2. )
+                      ELSEIF ( k .EQ. 1 ) THEN
+                        ! surface
+                        shear(i) = SQRT( ( (u_seri(i,k+1) - u_seri(i,k)) / delta_z )**2. &
+                                       + ( (v_seri(i,k+1) - v_seri(i,k)) / delta_z )**2. )
+                      ELSE
+                        ! other layers
+                        shear(i) = SQRT( ( ( (u_seri(i,k+1) + u_seri(i,k)) / 2. &
+                                           - (u_seri(i,k) + u_seri(i,k-1)) / 2. ) / delta_z )**2. &
+                                       + ( ( (v_seri(i,k+1) + v_seri(i,k)) / 2. &
+                                           - (v_seri(i,k) + v_seri(i,k-1)) / 2. ) / delta_z )**2. )
+                      ENDIF
+                    ENDDO
+
+                    !---------------------------------------------
+                    !--   CONDENSATION AND ICE SUPERSATURATION  --
+                    !---------------------------------------------
+
+                    CALL condensation_ice_supersat( &
+                        klon, dtime, missing_val, &
+                        pplay(:,k), paprs(:,k), paprs(:,k+1), &
+                        cf_seri(:,k), rvc_seri(:,k), ratio_qi_qtot(:,k), &
+                        shear(:), tke_dissip(:,k), cell_area(:), &
+                        Tbef(:), zq(:), zqs(:), gammasat(:), ratqs(:,k), keepgoing(:), &
+                        rneb(:,k), zqn(:), qvc(:), issrfra(:,k), qissr(:,k), &
+                        dcf_sub(:,k), dcf_con(:,k), dcf_mix(:,k), &
+                        dqi_adj(:,k), dqi_sub(:,k), dqi_con(:,k), dqi_mix(:,k), &
+                        dqvc_adj(:,k), dqvc_sub(:,k), dqvc_con(:,k), dqvc_mix(:,k), &
+                        Tcontr(:,k), qcontr(:,k), qcontr2(:,k), fcontrN(:,k), fcontrP(:,k), &
+                        flight_dist(:,k), flight_h2o(:,k), &
+                        dcf_avi(:,k), dqi_avi(:,k), dqvc_avi(:,k))
+
+
+                  ELSE
+                  !--generalised lognormal condensation scheme (Bony and Emanuel 2001)
+
+                   CALL condensation_lognormal( &
+                       klon, Tbef, zq, zqs, gammasat, ratqs(:,k), &
+                       keepgoing, rneb(:,k), zqn, qvc)
+!                   CALL condensation_lognormal_test( &
+!                       klon, klev, k, keepgoing, ratqs, gammasat, zq, zqs, &
+!                       zqn, qvc, rneb)
+
+
+                  ENDIF ! .NOT. ok_ice_supersat
+
+                  DO i=1,klon
+                      IF (keepgoing(i)) THEN
+
+                        ! If vertical heterogeneity, change fraction by volume as well
+                        IF (iflag_cloudth_vert.GE.3) THEN
+                            ctot_vol(i,k)=rneb(i,k)
+                            rneblsvol(i,k)=ctot_vol(i,k)
+                        ENDIF
+
+
+                       ! P2.2.2> Approximative calculation of temperature variation DT 
+                       !           due to condensation.
+                       ! Calculated variables: 
+                       ! dT : temperature change due to condensation
+                       !---------------------------------------------------------------
+
+                
+                        IF (zfice(i).LT.1) THEN
+                            cste=RLVTT
+                        ELSE
+                            cste=RLSTT
+                        ENDIF
+                        
+                        ! LEA_R : check formule
+                        IF ( ok_unadjusted_clouds ) THEN
+                          !--AB We relax the saturation adjustment assumption
+                          !-- qvc (grid-mean vapor in cloud) is calculated by the condensation scheme
+                          IF ( rneb(i,k) .GT. eps ) THEN
+                            qlbef(i) = MAX(0., zqn(i) - qvc(i) / rneb(i,k))
+                          ELSE
+                            qlbef(i) = 0.
+                          ENDIF
+                        ELSE
+                          qlbef(i)=max(0.,zqn(i)-zqs(i))
+                        ENDIF
+
+                        num = -Tbef(i)+zt(i)+rneb(i,k)*((1-zfice(i))*RLVTT &
+                              +zfice(i)*RLSTT)/RCPD/(1.0+RVTMP2*(zq(i)+zmqc(i)))*qlbef(i)
+                        denom = 1.+rneb(i,k)*((1-zfice(i))*RLVTT+zfice(i)*RLSTT)/cste*zdqs(i) &
+                              -(RLSTT-RLVTT)/RCPD/(1.0+RVTMP2*(zq(i)+zmqc(i)))*rneb(i,k)      &
+                              *qlbef(i)*dzfice(i)
+                        ! here we update a provisory temperature variable that only serves in the iteration
+                        ! process
+                        DT(i)=num/denom
+                        n_i(i)=n_i(i)+1
+
+                    ENDIF ! end keepgoing
+
+                ENDDO     ! end loop on i
+
+        ENDDO         ! iter=1,iflag_fisrtilp_qsat+1
+
+        ! P2.3> Final quantities calculation 
+        ! Calculated variables: 
+        !   rneb : cloud fraction
+        !   zcond: mean condensed water in the mesh
+        !   zqn  : mean water vapor in the mesh
+        !   zfice: ice fraction in clouds
+        !   zt   : temperature
+        !   rhcl : clear-sky relative humidity
+        ! ----------------------------------------------------------------
+
+
+        ! For iflag_t_glace GE 4 the phase partition function dependends on temperature AND distance to cloud top
+        IF (iflag_t_glace.GE.4) THEN
+           CALL distance_to_cloud_top(klon,klev,k,temp,pplay,paprs,rneb,zdistcltop,ztemp_cltop)
+           distcltop(:,k)=zdistcltop(:)
+           temp_cltop(:,k)=ztemp_cltop(:)
+        ENDIF
+
+        ! Partition function depending on temperature
+        CALL icefrac_lscp(klon, zt, iflag_ice_thermo, zdistcltop, ztemp_cltop, zfice, dzfice)
+
+        ! Partition function depending on tke for non shallow-convective clouds 
+        IF (iflag_icefrac .GE. 1) THEN
+
+           CALL icefrac_lscp_turb(klon, dtime, Tbef, pplay(:,k), paprs(:,k), paprs(:,k+1), qice_save(:,k), ziflcld, zqn, &
+           rneb(:,k), tke(:,k), tke_dissip(:,k), zqliq, zqvapcl, zqice, zfice_turb, dzfice_turb, cldfraliq(:,k),sigma2_icefracturb(:,k), mean_icefracturb(:,k))
+
+        ENDIF
+
+        ! Water vapor update, Phase determination and subsequent latent heat exchange
+        DO i=1, klon
+            ! Overwrite phase partitioning in boundary layer mixed phase clouds when the 
+            ! iflag_cloudth_vert=7 and specific param is activated
+            IF (mpc_bl_points(i,k) .GT. 0) THEN
+                zcond(i) = MAX(0.0,qincloud_mpc(i))*rneb(i,k)
+                ! following line is very strange and probably wrong
+                rhcl(i,k)= (zqs(i)+zq(i))/2./zqs(i)
+                ! water vapor update and partition function if thermals
+                zq(i) = zq(i) - zcond(i)        
+                zfice(i)=zfice_th(i)
+            ELSE
+                ! Checks on rneb, rhcl and zqn
+                IF (rneb(i,k) .LE. 0.0) THEN
+                    zqn(i) = 0.0
+                    rneb(i,k) = 0.0
+                    zcond(i) = 0.0
+                    rhcl(i,k)=zq(i)/zqs(i)
+                ELSE IF (rneb(i,k) .GE. 1.0) THEN
+                    zqn(i) = zq(i)
+                    rneb(i,k) = 1.0
+                    IF ( ok_unadjusted_clouds ) THEN
+                      !--AB We relax the saturation adjustment assumption
+                      !-- qvc (grid-mean vapor in cloud) is calculated by the condensation scheme
+                      zcond(i) = MAX(0., zqn(i) - qvc(i))
+                    ELSE
+                      zcond(i) = MAX(0.0,zqn(i)-zqs(i))
+                    ENDIF
+                    rhcl(i,k)=1.0
+                ELSE
+                    IF ( ok_unadjusted_clouds ) THEN
+                      !--AB We relax the saturation adjustment assumption
+                      !-- qvc (grid-mean vapor in cloud) is calculated by the condensation scheme
+                      zcond(i) = MAX(0., zqn(i) * rneb(i,k) - qvc(i))
+                    ELSE
+                      zcond(i) = MAX(0.0,zqn(i)-zqs(i))*rneb(i,k)
+                    ENDIF
+                    ! following line is very strange and probably wrong:
+                    rhcl(i,k)=(zqs(i)+zq(i))/2./zqs(i)
+                    ! Overwrite partitioning for non shallow-convective clouds if iflag_icefrac>1 (icefrac turb param) 
+                    IF (iflag_icefrac .GE. 1) THEN
+                        IF (lognormale(i)) THEN  
+                           zcond(i)  = zqliq(i) + zqice(i)
+                           zfice(i)=zfice_turb(i)
+                           rhcl(i,k) = zqvapcl(i) * rneb(i,k) + (zq(i) - zqn(i)) * (1.-rneb(i,k))
+                        ENDIF
+                    ENDIF
+                ENDIF
+
+                ! water vapor update 
+                zq(i) = zq(i) - zcond(i)
+
+            ENDIF
+
+            ! c_iso : routine that computes in-cloud supersaturation
+            ! c_iso condensation of isotopes (zcond, zsursat, zfice, zq in input) 
+
+            ! temperature update due to phase change
+            zt(i) = zt(i) + (1.-zfice(i))*zcond(i) & 
+            &     * RLVTT/RCPD/(1.0+RVTMP2*(zq(i)+zmqc(i)+zcond(i))) &
+                  +zfice(i)*zcond(i) * RLSTT/RCPD/(1.0+RVTMP2*(zq(i)+zmqc(i)+zcond(i)))
+        ENDDO
+
+        ! If vertical heterogeneity, change volume fraction 
+        IF (iflag_cloudth_vert .GE. 3) THEN
+          ctot_vol(1:klon,k)=min(max(ctot_vol(1:klon,k),0.),1.)
+          rneblsvol(1:klon,k)=ctot_vol(1:klon,k)
+        ENDIF
+    
+    !--AB Write diagnostics and tracers for ice supersaturation
+    IF ( ok_ice_supersat ) THEN
+      CALL calc_qsat_ecmwf(klon,zt,qzero,pplay(:,k),RTT,1,.false.,qsatl(:,k),zdqs)
+      CALL calc_qsat_ecmwf(klon,zt,qzero,pplay(:,k),RTT,2,.false.,qsati(:,k),zdqs)
+
+      DO i = 1, klon
+
+        cf_seri(i,k) = rneb(i,k)
+
+        IF ( .NOT. ok_unadjusted_clouds ) THEN
+          qvc(i) = zqs(i) * rneb(i,k)
+        ENDIF
+        IF ( zq(i) .GT. min_qParent ) THEN
+          rvc_seri(i,k) = qvc(i) / zq(i)
+        ELSE
+          rvc_seri(i,k) = min_ratio
+        ENDIF
+        !--The MIN barrier is NEEDED because of:
+        !-- 1) very rare pathological cases of the lsc scheme (rvc = 1. + 1e-16 sometimes)
+        !-- 2) the thermal scheme does NOT guarantee that qvc <= qvap (or even qincld <= qtot)
+        !--The MAX barrier is a safeguard that should not be activated
+        rvc_seri(i,k) = MIN(MAX(rvc_seri(i,k), 0.), 1.)
+
+        !--Diagnostics
+        gamma_cond(i,k) = gammasat(i)
+        IF ( issrfra(i,k) .LT. eps ) THEN
+          issrfra(i,k) = 0.
+          qissr(i,k) = 0.
+        ENDIF
+        subfra(i,k) = 1. - cf_seri(i,k) - issrfra(i,k)
+        qsub(i,k) = zq(i) - qvc(i) - qissr(i,k)
+        IF ( subfra(i,k) .LT. eps ) THEN
+          subfra(i,k) = 0.
+          qsub(i,k) = 0.
+        ENDIF
+        qcld(i,k) = qvc(i) + zcond(i)
+        IF ( cf_seri(i,k) .LT. eps ) THEN
+          qcld(i,k) = 0.
+        ENDIF
+      ENDDO
+    ENDIF
+
+
+    ! ----------------------------------------------------------------
+    ! P3> Precipitation formation 
+    ! ----------------------------------------------------------------
+
+    !================================================================
+    IF (ok_poprecip) THEN
+
+      DO i = 1, klon
+        zoliql(i) = zcond(i) * ( 1. - zfice(i) )
+        zoliqi(i) = zcond(i) * zfice(i)
+      ENDDO
+
+      CALL poprecip_postcld(klon, dtime, paprs(:,k), paprs(:,k+1), pplay(:,k), &
+                            ctot_vol(:,k), ptconv(:,k), &
+                            zt, zq, zoliql, zoliqi, zfice, &
+                            rneb(:,k), znebprecipclr, znebprecipcld, &
+                            zrfl, zrflclr, zrflcld, &
+                            zifl, ziflclr, ziflcld, &
+                            qraindiag(:,k), qsnowdiag(:,k), dqrauto(:,k), &
+                            dqrcol(:,k), dqrmelt(:,k), dqrfreez(:,k), &
+                            dqsauto(:,k), dqsagg(:,k), dqsrim(:,k), &
+                            dqsmelt(:,k), dqsfreez(:,k) &
+                            )
+
+      DO i = 1, klon
+        zoliq(i) = zoliql(i) + zoliqi(i)
+        IF ( zoliq(i) .GT. 0. ) THEN 
+                zfice(i) = zoliqi(i)/zoliq(i) 
+        ELSE  
+                zfice(i) = 0.0
+        ENDIF
+
+        ! calculation of specific content of condensates seen by radiative scheme 
+        IF (ok_radocond_snow) THEN
+           radocond(i,k) = zoliq(i)
+           radocondl(i,k)= radocond(i,k)*(1.-zfice(i))
+           radocondi(i,k)= radocond(i,k)*zfice(i)+qsnowdiag(i,k)
+        ELSE
+           radocond(i,k) = zoliq(i)
+           radocondl(i,k)= radocond(i,k)*(1.-zfice(i))
+           radocondi(i,k)= radocond(i,k)*zfice(i)
+        ENDIF
+      ENDDO
+
+    !================================================================
+    ELSE
+
+    ! LTP:
+    IF (iflag_evap_prec .GE. 4) THEN
+
+        !Partitionning between precipitation coming from clouds and that coming from CS
+
+        !0) Calculate tot_zneb, total cloud fraction above the cloud
+        !assuming a maximum-random overlap (voir Jakob and Klein, 2000)
+        
+        DO i=1, klon
+                tot_znebn(i) = 1. - (1.-tot_zneb(i))*(1 - max(rneb(i,k),zneb(i))) &
+                        /(1.-min(zneb(i),1.-smallestreal))
+                d_tot_zneb(i) = tot_znebn(i) - tot_zneb(i)
+                tot_zneb(i) = tot_znebn(i)
+
+
+                !1) Cloudy to clear air
+                d_znebprecip_cld_clr(i) = znebprecipcld(i) - min(rneb(i,k),znebprecipcld(i)) 
+                IF (znebprecipcld(i) .GT. 0.) THEN
+                        d_zrfl_cld_clr(i) = d_znebprecip_cld_clr(i)/znebprecipcld(i)*zrflcld(i) 
+                        d_zifl_cld_clr(i) = d_znebprecip_cld_clr(i)/znebprecipcld(i)*ziflcld(i) 
+                ELSE 
+                        d_zrfl_cld_clr(i) = 0. 
+                        d_zifl_cld_clr(i) = 0. 
+                ENDIF
+
+                !2) Clear to cloudy air
+                d_znebprecip_clr_cld(i) = max(0., min(znebprecipclr(i), rneb(i,k) - d_tot_zneb(i) - zneb(i)))
+                IF (znebprecipclr(i) .GT. 0) THEN
+                        d_zrfl_clr_cld(i) = d_znebprecip_clr_cld(i)/znebprecipclr(i)*zrflclr(i) 
+                        d_zifl_clr_cld(i) = d_znebprecip_clr_cld(i)/znebprecipclr(i)*ziflclr(i)
+                ELSE
+                        d_zrfl_clr_cld(i) = 0. 
+                        d_zifl_clr_cld(i) = 0. 
+                ENDIF 
+
+                !Update variables
+                znebprecipcld(i) = znebprecipcld(i) + d_znebprecip_clr_cld(i) - d_znebprecip_cld_clr(i)
+                znebprecipclr(i) = znebprecipclr(i) + d_znebprecip_cld_clr(i) - d_znebprecip_clr_cld(i) 
+                zrflcld(i) = zrflcld(i) + d_zrfl_clr_cld(i) - d_zrfl_cld_clr(i) 
+                ziflcld(i) = ziflcld(i) + d_zifl_clr_cld(i) - d_zifl_cld_clr(i)
+                zrflclr(i) = zrflclr(i) + d_zrfl_cld_clr(i) - d_zrfl_clr_cld(i)
+                ziflclr(i) = ziflclr(i) + d_zifl_cld_clr(i) - d_zifl_clr_cld(i)
+
+                ! c_iso  do the same thing for isotopes precip
+        ENDDO
+    ENDIF
+
+
+    ! Autoconversion
+    ! -------------------------------------------------------------------------------
+
+
+    ! Initialisation of zoliq and radocond variables
+
+    DO i = 1, klon
+            zoliq(i) = zcond(i)
+            zoliqi(i)= zoliq(i)*zfice(i)
+            zoliql(i)= zoliq(i)*(1.-zfice(i))
+            ! c_iso : initialisation of zoliq* also for isotopes
+            zrho(i,k)  = pplay(i,k) / zt(i) / RD
+            zdz(i)   = (paprs(i,k)-paprs(i,k+1)) / (zrho(i,k)*RG)
+            iwc(i)   = 0. 
+            zneb(i)  = MAX(rneb(i,k),seuil_neb)
+            radocond(i,k) = zoliq(i)/REAL(niter_lscp+1)
+            radocondi(i,k)=zoliq(i)*zfice(i)/REAL(niter_lscp+1)
+            radocondl(i,k)=zoliq(i)*(1.-zfice(i))/REAL(niter_lscp+1)
+    ENDDO
+
+       
+    DO n = 1, niter_lscp
+
+        DO i=1,klon
+            IF (rneb(i,k).GT.0.0) THEN
+                iwc(i) = zrho(i,k) * zoliqi(i) / zneb(i) ! in-cloud ice condensate content
+            ENDIF
+        ENDDO
+
+        CALL fallice_velocity(klon,iwc(:),zt(:),zrho(:,k),pplay(:,k),ptconv(:,k),velo(:,k))
+
+        DO i = 1, klon
+
+            IF (rneb(i,k).GT.0.0) THEN
+
+                ! Initialization of zrain, zsnow and zprecip:
+                zrain=0.
+                zsnow=0.
+                zprecip=0.
+                ! c_iso same init for isotopes. Externalisation?
+
+                IF (zneb(i).EQ.seuil_neb) THEN
+                    zprecip = 0.0
+                    zsnow = 0.0
+                    zrain= 0.0
+                ELSE
+
+                    IF (ptconv(i,k)) THEN ! if convective point
+                        zcl=cld_lc_con
+                        zct=1./cld_tau_con
+                        zexpo=cld_expo_con
+                        ffallv=ffallv_con
+                    ELSE
+                        zcl=cld_lc_lsc
+                        zct=1./cld_tau_lsc
+                        zexpo=cld_expo_lsc
+                        ffallv=ffallv_lsc
+                    ENDIF
+
+
+                    ! if vertical heterogeneity is taken into account, we use
+                    ! the "true" volume fraction instead of a modified 
+                    ! surface fraction (which is larger and artificially
+                    ! reduces the in-cloud water).
+
+                    ! Liquid water quantity to remove: zchau (Sundqvist, 1978)
+                    ! dqliq/dt=-qliq/tau*(1-exp(-qcin/clw)**2)
+                    !.........................................................
+                    IF ((iflag_cloudth_vert.GE.3).AND.(iflag_rain_incloud_vol.EQ.1)) THEN
+
+                    ! if vertical heterogeneity is taken into account, we use
+                    ! the "true" volume fraction instead of a modified 
+                    ! surface fraction (which is larger and artificially
+                    ! reduces the in-cloud water).
+                        effective_zneb=ctot_vol(i,k)
+                    ELSE
+                        effective_zneb=zneb(i)
+                    ENDIF 
+
+
+                    IF (iflag_autoconversion .EQ. 2) THEN
+                    ! two-steps resolution with niter_lscp=1 sufficient
+                    ! we first treat the second term (with exponential) in an explicit way
+                    ! and then treat the first term (-q/tau) in an exact way
+                        zchau=zoliql(i)*(1.-exp(-dtime/REAL(niter_lscp)*zct &
+                        *(1.-exp(-(zoliql(i)/effective_zneb/zcl)**zexpo))))
+                    ELSE
+                    ! old explicit resolution with subtimesteps
+                        zchau = zct*dtime/REAL(niter_lscp)*zoliql(i) &
+                        *(1.0-EXP(-(zoliql(i)/effective_zneb/zcl)**zexpo))
+                    ENDIF
+
+
+                    ! Ice water quantity to remove (Zender & Kiehl, 1997)
+                    ! dqice/dt=1/rho*d(rho*wice*qice)/dz
+                    !....................................
+                    IF (iflag_autoconversion .EQ. 2) THEN
+                    ! exact resolution, niter_lscp=1 is sufficient but works only
+                    ! with iflag_vice=0
+                       IF (zoliqi(i) .GT. 0.) THEN
+                          zfroi=(zoliqi(i)-((zoliqi(i)**(-dice_velo)) & 
+                          +dice_velo*dtime/REAL(niter_lscp)*cice_velo/zdz(i)*ffallv)**(-1./dice_velo))
+                       ELSE
+                          zfroi=0.
+                       ENDIF
+                    ELSE
+                    ! old explicit resolution with subtimesteps
+                       zfroi = dtime/REAL(niter_lscp)/zdz(i)*zoliqi(i)*velo(i,k) 
+                    ENDIF
+
+                    zrain   = MIN(MAX(zchau,0.0),zoliql(i))
+                    zsnow   = MIN(MAX(zfroi,0.0),zoliqi(i)) 
+                    zprecip = MAX(zrain + zsnow,0.0)
+
+                ENDIF
+
+                IF (iflag_autoconversion .GE. 1) THEN
+                   ! debugged version with phase conservation through the autoconversion process
+                   zoliql(i) = MAX(zoliql(i)-1.*zrain  , 0.0)
+                   zoliqi(i) = MAX(zoliqi(i)-1.*zsnow  , 0.0)
+                   zoliq(i)  = MAX(zoliq(i)-zprecip , 0.0)
+                ELSE
+                   ! bugged version with phase resetting
+                   zoliql(i) = MAX(zoliq(i)*(1.-zfice(i))-1.*zrain  , 0.0)
+                   zoliqi(i) = MAX(zoliq(i)*zfice(i)-1.*zsnow  , 0.0)
+                   zoliq(i)  = MAX(zoliq(i)-zprecip , 0.0)
+                ENDIF
+
+                ! c_iso: call isotope_conversion (for readibility) or duplicate 
+
+                radocond(i,k) = radocond(i,k) + zoliq(i)/REAL(niter_lscp+1)
+                radocondl(i,k) = radocondl(i,k) + zoliql(i)/REAL(niter_lscp+1)
+                radocondi(i,k) = radocondi(i,k) + zoliqi(i)/REAL(niter_lscp+1)
+
+            ENDIF ! rneb >0
+
+        ENDDO  ! i = 1,klon
+
+    ENDDO      ! n = 1,niter
+
+    ! Precipitation flux calculation
+
+    DO i = 1, klon
+            
+            IF (iflag_evap_prec.GE.4) THEN
+                ziflprev(i)=ziflcld(i)
+            ELSE
+                ziflprev(i)=zifl(i)*zneb(i)
+            ENDIF
+
+            IF (rneb(i,k) .GT. 0.0) THEN
+
+               ! CR&JYG: We account for the Wegener-Findeisen-Bergeron process in the precipitation flux:
+               ! If T<0C, liquid precip are converted into ice, which leads to an increase in
+               ! temperature DeltaT. The effect of DeltaT on condensates and precipitation is roughly
+               ! taken into account through a linearization of the equations and by approximating
+               ! the liquid precipitation process with a "threshold" process. We assume that
+               ! condensates are not modified during this operation. Liquid precipitation is
+               ! removed (in the limit DeltaT<273.15-T). Solid precipitation increases.
+               ! Water vapor increases as well
+               ! Note that compared to fisrtilp, we always assume iflag_bergeron=2
+
+                    zqpreci(i)=(zcond(i)-zoliq(i))*zfice(i)
+                    zqprecl(i)=(zcond(i)-zoliq(i))*(1.-zfice(i))
+                    zcp=RCPD*(1.0+RVTMP2*(zq(i)+zmqc(i)+zcond(i)))
+                    coef1 = rneb(i,k)*RLSTT/zcp*zdqsdT_raw(i)
+                    ! Computation of DT if all the liquid precip freezes
+                    DeltaT = RLMLT*zqprecl(i) / (zcp*(1.+coef1))
+                    ! T should not exceed the freezing point
+                    ! that is Delta > RTT-zt(i)
+                    DeltaT = max( min( RTT-zt(i), DeltaT) , 0. )
+                    zt(i)  = zt(i) + DeltaT
+                    ! water vaporization due to temp. increase
+                    Deltaq = rneb(i,k)*zdqsdT_raw(i)*DeltaT
+                    ! we add this vaporized water to the total vapor and we remove it from the precip
+                    zq(i) = zq(i) +  Deltaq
+                    ! The three "max" lines herebelow protect from rounding errors
+                    zcond(i) = max( zcond(i)- Deltaq, 0. )
+                    ! liquid precipitation converted to ice precip 
+                    Deltaqprecl = -zcp/RLMLT*(1.+coef1)*DeltaT
+                    zqprecl(i) = max( zqprecl(i) + Deltaqprecl, 0. )
+                    ! iced water budget
+                    zqpreci(i) = max (zqpreci(i) - Deltaqprecl - Deltaq, 0.)
+
+                    ! c_iso : mv here condensation of isotopes + redispatchage en precip 
+
+                IF (iflag_evap_prec.GE.4) THEN
+                    zrflcld(i) = zrflcld(i)+zqprecl(i) &
+                    *(paprs(i,k)-paprs(i,k+1))/(RG*dtime)
+                    ziflcld(i) = ziflcld(i)+ zqpreci(i) &
+                        *(paprs(i,k)-paprs(i,k+1))/(RG*dtime)
+                    znebprecipcld(i) = rneb(i,k)
+                    zrfl(i) = zrflcld(i) + zrflclr(i)
+                    zifl(i) = ziflcld(i) + ziflclr(i)
+                ELSE
+                    zrfl(i) = zrfl(i)+ zqprecl(i)        &
+                    *(paprs(i,k)-paprs(i,k+1))/(RG*dtime) 
+                    zifl(i) = zifl(i)+ zqpreci(i)        &
+                   *(paprs(i,k)-paprs(i,k+1))/(RG*dtime)
+                ENDIF
+                ! c_iso : same for isotopes
+ 
+           ENDIF ! rneb>0
+
+   ENDDO
+
+    ! LTP: limit of surface cloud fraction covered by precipitation when the local intensity of the flux is below rain_int_min
+    ! if iflag_evap_prec>=4
+    IF (iflag_evap_prec.GE.4) THEN
+
+        DO i=1,klon
+
+            IF ((zrflclr(i) + ziflclr(i)) .GT. 0. ) THEN
+                znebprecipclr(i) = min(znebprecipclr(i),max(zrflclr(i)/ &
+                (MAX(znebprecipclr(i),seuil_neb)*rain_int_min), ziflclr(i)/(MAX(znebprecipclr(i),seuil_neb)*rain_int_min)))
+            ELSE
+                znebprecipclr(i)=0.0
+            ENDIF
+
+            IF ((zrflcld(i) + ziflcld(i)) .GT. 0.) THEN
+                znebprecipcld(i) = min(znebprecipcld(i), max(zrflcld(i)/ &
+                (MAX(znebprecipcld(i),seuil_neb)*rain_int_min), ziflcld(i)/(MAX(znebprecipcld(i),seuil_neb)*rain_int_min)))
+            ELSE
+                znebprecipcld(i)=0.0
+            ENDIF
+        ENDDO
+
+    ENDIF
+
+
+    ENDIF ! ok_poprecip
+
+    ! End of precipitation formation
+    ! --------------------------------
+
+
+    ! Calculation of cloud condensates amount seen by radiative scheme
+    !-----------------------------------------------------------------
+
+    ! Calculation of the concentration of condensates seen by the radiation scheme
+    ! for liquid phase, we take radocondl
+    ! for ice phase, we take radocondi if we neglect snowfall, otherwise (ok_radocond_snow=true) 
+    ! we recalculate radocondi to account for contributions from the precipitation flux
+    ! TODO: for the moment, we deactivate this option when ok_poprecip=.true.
+
+    IF ((ok_radocond_snow) .AND. (k .LT. klev) .AND. (.NOT. ok_poprecip)) THEN
+        ! for the solid phase (crystals + snowflakes)
+        ! we recalculate radocondi by summing
+        ! the ice content calculated in the mesh
+        ! + the contribution of the non-evaporated snowfall 
+        ! from the overlying layer
+        DO i=1,klon
+           IF (ziflprev(i) .NE. 0.0) THEN
+              radocondi(i,k)=zoliq(i)*zfice(i)+zqpreci(i)+ziflprev(i)/zrho(i,k+1)/velo(i,k+1)
+           ELSE
+              radocondi(i,k)=zoliq(i)*zfice(i)+zqpreci(i)
+           ENDIF
+           radocond(i,k)=radocondl(i,k)+radocondi(i,k)
+        ENDDO
+    ENDIF
+
+    ! caculate the percentage of ice in "radocond" so cloud+precip seen by the radiation scheme
+    DO i=1,klon
+        IF (radocond(i,k) .GT. 0.) THEN
+            radicefrac(i,k)=MIN(MAX(radocondi(i,k)/radocond(i,k),0.),1.)
+        ENDIF
+    ENDDO
+
+    ! ----------------------------------------------------------------
+    ! P4> Wet scavenging
+    ! ----------------------------------------------------------------
+
+    !Scavenging through nucleation in the layer
+
+    DO i = 1,klon
+        
+        IF(zcond(i).GT.zoliq(i)+1.e-10) THEN
+            beta(i,k) = (zcond(i)-zoliq(i))/zcond(i)/dtime
+        ELSE
+            beta(i,k) = 0.
+        ENDIF
+
+        zprec_cond(i) = MAX(zcond(i)-zoliq(i),0.0)*(paprs(i,k)-paprs(i,k+1))/RG
+
+        IF (rneb(i,k).GT.0.0.AND.zprec_cond(i).GT.0.) THEN
+
+            IF (temp(i,k) .GE. t_glace_min) THEN
+                zalpha_tr = a_tr_sca(3)
+            ELSE
+                zalpha_tr = a_tr_sca(4)
+            ENDIF
+
+            zfrac_lessi = 1. - EXP(zalpha_tr*zprec_cond(i)/zneb(i))
+            frac_nucl(i,k)= 1.-zneb(i)*zfrac_lessi 
+
+            ! Nucleation with a factor of -1 instead of -0.5
+            zfrac_lessi = 1. - EXP(-zprec_cond(i)/zneb(i))
+
+        ENDIF
+
+    ENDDO
+
+    ! Scavenging through impaction in the underlying layer
+
+    DO kk = k-1, 1, -1
+
+        DO i = 1, klon
+
+            IF (rneb(i,k).GT.0.0.AND.zprec_cond(i).GT.0.) THEN
+
+                IF (temp(i,kk) .GE. t_glace_min) THEN
+                    zalpha_tr = a_tr_sca(1)
+                ELSE
+                    zalpha_tr = a_tr_sca(2)
+                ENDIF
+
+              zfrac_lessi = 1. - EXP(zalpha_tr*zprec_cond(i)/zneb(i))
+              frac_impa(i,kk)= 1.-zneb(i)*zfrac_lessi
+
+            ENDIF
+
+        ENDDO
+
+    ENDDO
+
+    ! Outputs:
+    !-------------------------------
+    ! Precipitation fluxes at layer interfaces
+    ! + precipitation fractions +
+    ! temperature and water species tendencies
+    DO i = 1, klon
+        psfl(i,k)=zifl(i)
+        prfl(i,k)=zrfl(i)
+        pfraclr(i,k)=znebprecipclr(i)
+        pfracld(i,k)=znebprecipcld(i)
+        d_ql(i,k) = (1-zfice(i))*zoliq(i)
+        d_qi(i,k) = zfice(i)*zoliq(i)
+        d_q(i,k) = zq(i) - qt(i,k)
+        ! c_iso: same for isotopes
+        d_t(i,k) = zt(i) - temp(i,k)
+    ENDDO
+
+
+ENDDO
+
+
+  ! Rain or snow at the surface (depending on the first layer temperature)
+  DO i = 1, klon
+      snow(i) = zifl(i)
+      rain(i) = zrfl(i)
+      ! c_iso final output
+  ENDDO
+
+  IF (ncoreczq>0) THEN
+      WRITE(lunout,*)'WARNING : ZQ in LSCP ',ncoreczq,' val < 1.e-15.'
+  ENDIF
+
+
+RETURN
+
+END SUBROUTINE lscp
+!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+END MODULE lmdz_lscp
Index: DZ6/trunk/libf/phylmd/lmdz_lscp_condensation.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/lmdz_lscp_condensation.F90	(revision 5267)
+++ 	(revision )
@@ -1,1105 +1,0 @@
-MODULE lmdz_lscp_condensation
-!----------------------------------------------------------------
-! Module for condensation of clouds routines
-! that are called in LSCP
-
-
-IMPLICIT NONE
-
-CONTAINS
-
-!*********************************************************************************
-SUBROUTINE condensation_lognormal_test(klon,klev,k,keepgoing,ratqs, gammasat,zq, zqs, zqn, qvc, rneb)
-
-
-IMPLICIT NONE
-
-INTEGER, INTENT(IN)   :: klon,klev,k
-LOGICAL,  INTENT(IN)   , DIMENSION(klon) :: keepgoing     ! .TRUE. if a new condensation loop should be computed
-REAL, INTENT(IN), DIMENSION(klon,klev)   :: ratqs
-REAL, INTENT(IN), DIMENSION(klon)        :: zq, zqs,gammasat
-REAL, INTENT(INOUT), DIMENSION(klon)     :: zqn, qvc
-REAL, INTENT(INOUT), DIMENSION(klon,klev) :: rneb
-
-REAL, DIMENSION(klon) :: zpdf_sig,zpdf_k,zpdf_delta             ! lognormal parameters
-REAL, DIMENSION(klon) :: Zpdf_a,zpdf_b,zpdf_e1,zpdf_e2          ! lognormal intermediate variables
-INTEGER               :: i
-
-
-DO i=1,klon !todoan : check if loop in i is needed
-
-    IF (keepgoing(i)) THEN
-
-    zpdf_sig(i)=ratqs(i,k)*zq(i)
-    zpdf_k(i)=-sqrt(log(1.+(zpdf_sig(i)/zq(i))**2))
-    zpdf_delta(i)=log(zq(i)/(gammasat(i)*zqs(i)))
-    zpdf_a(i)=zpdf_delta(i)/(zpdf_k(i)*sqrt(2.))
-    zpdf_b(i)=zpdf_k(i)/(2.*sqrt(2.))
-    zpdf_e1(i)=zpdf_a(i)-zpdf_b(i)
-    zpdf_e1(i)=sign(min(ABS(zpdf_e1(i)),5.),zpdf_e1(i))
-    zpdf_e1(i)=1.-erf(zpdf_e1(i))
-    zpdf_e2(i)=zpdf_a(i)+zpdf_b(i)
-    zpdf_e2(i)=sign(min(ABS(zpdf_e2(i)),5.),zpdf_e2(i))
-    zpdf_e2(i)=1.-erf(zpdf_e2(i))
-
-    IF (zpdf_e1(i).LT.1.e-10) THEN
-        rneb(i,k)=0.
-        zqn(i)=zqs(i)
-        !--AB grid-mean vapor in the cloud - we assume saturation adjustment
-        qvc(i) = 0.
-    ELSE
-        rneb(i,k)=0.5*zpdf_e1(i)
-        zqn(i)=zq(i)*zpdf_e2(i)/zpdf_e1(i)
-        !--AB grid-mean vapor in the cloud - we assume saturation adjustment
-        qvc(i) = rneb(i,k) * zqs(i)
-    ENDIF
-
-    ENDIF ! keepgoing
-ENDDO ! loop on klon
-
-
-END SUBROUTINE condensation_lognormal_test
-
-
-!**********************************************************************************
-SUBROUTINE condensation_lognormal( &
-      klon, temp, qtot, qsat, gamma_cond, ratqs, &
-      keepgoing, cldfra, qincld, qvc)
-
-!----------------------------------------------------------------------
-! This subroutine calculates the formation of clouds, using a
-! statistical cloud scheme. It uses a generalised lognormal distribution
-! of total water in the gridbox
-! See Bony and Emanuel, 2001
-!----------------------------------------------------------------------
-
-USE lmdz_lscp_ini, ONLY: eps
-
-IMPLICIT NONE
-
-!
-! Input
-!
-INTEGER,  INTENT(IN)                     :: klon          ! number of horizontal grid points
-!
-REAL,     INTENT(IN)   , DIMENSION(klon) :: temp          ! temperature [K]
-REAL,     INTENT(IN)   , DIMENSION(klon) :: qtot          ! total specific humidity (without precip) [kg/kg]
-REAL,     INTENT(IN)   , DIMENSION(klon) :: qsat          ! saturation specific humidity [kg/kg]
-REAL,     INTENT(IN)   , DIMENSION(klon) :: gamma_cond    ! condensation threshold w.r.t. qsat [-]
-REAL,     INTENT(IN)   , DIMENSION(klon) :: ratqs         ! ratio between the variance of the total water distribution and its average [-]
-LOGICAL,  INTENT(IN)   , DIMENSION(klon) :: keepgoing     ! .TRUE. if a new condensation loop should be computed
-!
-!  Output
-!  NB. those are in INOUT because of the convergence loop on temperature
-!      (in some cases, the values are not re-computed) but the values
-!      are never used explicitely
-!
-REAL,     INTENT(INOUT), DIMENSION(klon) :: cldfra   ! cloud fraction [-]
-REAL,     INTENT(INOUT), DIMENSION(klon) :: qincld   ! cloud-mean in-cloud total specific water [kg/kg]
-REAL,     INTENT(INOUT), DIMENSION(klon) :: qvc      ! gridbox-mean vapor in the cloud [kg/kg]
-!
-! Local
-!
-INTEGER :: i
-REAL :: pdf_std, pdf_k, pdf_delta
-REAL :: pdf_a, pdf_b, pdf_e1, pdf_e2
-!
-!--Loop on klon
-!
-DO i = 1, klon
-
-  !--If a new calculation of the condensation is needed,
-  !--i.e., temperature has not yet converged (or the cloud is
-  !--formed elsewhere)
-  IF (keepgoing(i)) THEN
-
-    pdf_std   = ratqs(i) * qtot(i)
-    pdf_k     = -SQRT( LOG( 1. + (pdf_std / qtot(i))**2 ) )
-    pdf_delta = LOG( qtot(i) / ( gamma_cond(i) * qsat(i) ) )
-    pdf_a     = pdf_delta / ( pdf_k * SQRT(2.) )
-    pdf_b     = pdf_k / (2. * SQRT(2.))
-    pdf_e1    = pdf_a - pdf_b
-    pdf_e1    = SIGN( MIN(ABS(pdf_e1), 5.), pdf_e1 )
-    pdf_e1    = 1. - ERF(pdf_e1)
-    pdf_e2    = pdf_a + pdf_b
-    pdf_e2    = SIGN( MIN(ABS(pdf_e2), 5.), pdf_e2 )
-    pdf_e2    = 1. - ERF(pdf_e2)
-
-
-    IF ( pdf_e1 .LT. eps ) THEN
-      cldfra(i) = 0.
-      qincld(i) = qsat(i)
-      !--AB grid-mean vapor in the cloud - we assume saturation adjustment
-      qvc(i) = 0.
-    ELSE
-      cldfra(i) = 0.5 * pdf_e1
-      qincld(i) = qtot(i) * pdf_e2 / pdf_e1
-      !--AB grid-mean vapor in the cloud - we assume saturation adjustment
-      qvc(i) = qsat(i) * cldfra(i)
-    ENDIF
-
-  ENDIF   ! end keepgoing
-
-ENDDO     ! end loop on i
-END SUBROUTINE condensation_lognormal
-!**********************************************************************************
-
-!**********************************************************************************
-SUBROUTINE condensation_ice_supersat( &
-      klon, dtime, missing_val, pplay, paprsdn, paprsup, &
-      cf_seri, rvc_seri, ratio_qi_qtot, shear, pbl_eps, cell_area, &
-      temp, qtot, qsat, gamma_cond, ratqs, keepgoing, &
-      cldfra, qincld, qvc, issrfra, qissr, dcf_sub, dcf_con, dcf_mix, &
-      dqi_adj, dqi_sub, dqi_con, dqi_mix, dqvc_adj, dqvc_sub, dqvc_con, dqvc_mix, &
-      Tcontr, qcontr, qcontr2, fcontrN, fcontrP, flight_dist, flight_h2o, &
-      dcf_avi, dqi_avi, dqvc_avi)
-
-!----------------------------------------------------------------------
-! This subroutine calculates the formation, evolution and dissipation
-! of clouds, using a process-oriented treatment of the cloud properties
-! (cloud fraction, vapor in the cloud, condensed water in the cloud).
-! It allows for ice supersaturation in cold regions, in clear sky.
-! If ok_unadjusted_clouds, it also allows for sub- and supersaturated
-! cloud water vapors.
-! It also allows for the formation and evolution of condensation trails
-! (contrails) from aviation.
-! Authors: Audran Borella, Etienne Vignon, Olivier Boucher
-! April 2024
-!----------------------------------------------------------------------
-
-USE lmdz_lscp_tools,      ONLY: calc_qsat_ecmwf, calc_gammasat, GAMMAINC
-USE lmdz_lscp_ini,        ONLY: RCPD, RLSTT, RLVTT, RLMLT, RVTMP2, RTT, RD, RG, RV, RPI, EPS_W
-USE lmdz_lscp_ini,        ONLY: eps, temp_nowater, ok_weibull_warm_clouds
-USE lmdz_lscp_ini,        ONLY: ok_unadjusted_clouds, iflag_cloud_sublim_pdf
-USE lmdz_lscp_ini,        ONLY: lunout
-
-USE lmdz_lscp_ini,        ONLY: depo_coef_cirrus, capa_cond_cirrus, &
-                                mu_subl_pdf_lscp, beta_pdf_lscp, temp_thresh_pdf_lscp, &
-                                rhlmid_pdf_lscp, k0_pdf_lscp, kappa_pdf_lscp, rhl0_pdf_lscp, &
-                                coef_mixing_lscp, coef_shear_lscp, & 
-                                chi_mixing_lscp, rho_ice
-
-IMPLICIT NONE
-
-!
-! Input
-!
-INTEGER,  INTENT(IN)                     :: klon          ! number of horizontal grid points
-REAL,     INTENT(IN)                     :: dtime         ! time step [s]
-REAL,     INTENT(IN)                     :: missing_val   ! missing value for output
-!
-REAL,     INTENT(IN)   , DIMENSION(klon) :: pplay         ! layer pressure [Pa]
-REAL,     INTENT(IN)   , DIMENSION(klon) :: paprsdn       ! pressure at the lower interface [Pa]
-REAL,     INTENT(IN)   , DIMENSION(klon) :: paprsup       ! pressure at the upper interface [Pa]
-REAL,     INTENT(IN)   , DIMENSION(klon) :: cf_seri       ! cloud fraction [-]
-REAL,     INTENT(IN)   , DIMENSION(klon) :: rvc_seri      ! gridbox-mean water vapor in cloud [kg/kg]
-REAL,     INTENT(IN)   , DIMENSION(klon) :: ratio_qi_qtot ! specific ice water content to total specific water ratio [-]
-REAL,     INTENT(IN)   , DIMENSION(klon) :: shear         ! vertical shear [s-1]
-REAL,     INTENT(IN)   , DIMENSION(klon) :: pbl_eps       ! 
-REAL,     INTENT(IN)   , DIMENSION(klon) :: cell_area     ! 
-REAL,     INTENT(IN)   , DIMENSION(klon) :: temp          ! temperature [K]
-REAL,     INTENT(IN)   , DIMENSION(klon) :: qtot          ! total specific humidity (without precip) [kg/kg]
-REAL,     INTENT(IN)   , DIMENSION(klon) :: qsat          ! saturation specific humidity [kg/kg]
-REAL,     INTENT(IN)   , DIMENSION(klon) :: gamma_cond    ! condensation threshold w.r.t. qsat [-]
-REAL,     INTENT(INOUT), DIMENSION(klon) :: ratqs         ! ratio between the variance of the total water distribution and its average [-]
-LOGICAL,  INTENT(IN)   , DIMENSION(klon) :: keepgoing     ! .TRUE. if a new condensation loop should be computed
-!
-! Input for aviation
-!
-REAL,     INTENT(IN),    DIMENSION(klon) :: flight_dist   ! 
-REAL,     INTENT(IN),    DIMENSION(klon) :: flight_h2o    ! 
-!
-!  Output
-!  NB. cldfra and qincld should be outputed as cf_seri and qi_seri,
-!      or as tendencies (maybe in the future)
-!  NB. those are in INOUT because of the convergence loop on temperature
-!      (in some cases, the values are not re-computed) but the values
-!      are never used explicitely
-!
-REAL,     INTENT(INOUT), DIMENSION(klon) :: cldfra   ! cloud fraction [-]
-REAL,     INTENT(INOUT), DIMENSION(klon) :: qincld   ! cloud-mean in-cloud total specific water [kg/kg]
-REAL,     INTENT(INOUT), DIMENSION(klon) :: qvc      ! gridbox-mean vapor in the cloud [kg/kg]
-REAL,     INTENT(INOUT), DIMENSION(klon) :: issrfra  ! ISSR fraction [-]
-REAL,     INTENT(INOUT), DIMENSION(klon) :: qissr    ! gridbox-mean ISSR specific water [kg/kg]
-!
-!  Diagnostics for condensation and ice supersaturation
-!  NB. idem for the INOUT
-!
-REAL,     INTENT(INOUT), DIMENSION(klon) :: dcf_sub  ! cloud fraction tendency because of sublimation [s-1]
-REAL,     INTENT(INOUT), DIMENSION(klon) :: dcf_con  ! cloud fraction tendency because of condensation [s-1]
-REAL,     INTENT(INOUT), DIMENSION(klon) :: dcf_mix  ! cloud fraction tendency because of cloud mixing [s-1]
-REAL,     INTENT(INOUT), DIMENSION(klon) :: dqi_adj  ! specific ice content tendency because of temperature adjustment [kg/kg/s]
-REAL,     INTENT(INOUT), DIMENSION(klon) :: dqi_sub  ! specific ice content tendency because of sublimation [kg/kg/s]
-REAL,     INTENT(INOUT), DIMENSION(klon) :: dqi_con  ! specific ice content tendency because of condensation [kg/kg/s]
-REAL,     INTENT(INOUT), DIMENSION(klon) :: dqi_mix  ! specific ice content tendency because of cloud mixing [kg/kg/s]
-REAL,     INTENT(INOUT), DIMENSION(klon) :: dqvc_adj ! specific cloud water vapor tendency because of temperature adjustment [kg/kg/s]
-REAL,     INTENT(INOUT), DIMENSION(klon) :: dqvc_sub ! specific cloud water vapor tendency because of sublimation [kg/kg/s]
-REAL,     INTENT(INOUT), DIMENSION(klon) :: dqvc_con ! specific cloud water vapor tendency because of condensation [kg/kg/s]
-REAL,     INTENT(INOUT), DIMENSION(klon) :: dqvc_mix ! specific cloud water vapor tendency because of cloud mixing [kg/kg/s]
-!
-!  Diagnostics for aviation
-!  NB. idem for the INOUT
-!
-REAL,     INTENT(INOUT), DIMENSION(klon) :: Tcontr   ! critical temperature for contrail formation (T_LM in Schumann 1996, Eq 31 in appendix 2) [K]
-REAL,     INTENT(INOUT), DIMENSION(klon) :: qcontr   ! 
-REAL,     INTENT(INOUT), DIMENSION(klon) :: qcontr2  ! 
-REAL,     INTENT(INOUT), DIMENSION(klon) :: fcontrN  ! 
-REAL,     INTENT(INOUT), DIMENSION(klon) :: fcontrP  ! 
-REAL,     INTENT(INOUT), DIMENSION(klon) :: dcf_avi  ! cloud fraction tendency because of aviation [s-1]
-REAL,     INTENT(INOUT), DIMENSION(klon) :: dqi_avi  ! specific ice content tendency because of aviation [kg/kg/s]
-REAL,     INTENT(INOUT), DIMENSION(klon) :: dqvc_avi ! specific cloud water vapor tendency because of aviation [kg/kg/s]
-!
-! Local
-!
-INTEGER :: i
-LOGICAL :: ok_warm_cloud
-REAL, DIMENSION(klon) :: qcld, qzero
-!
-! for lognormal
-REAL :: pdf_std, pdf_k, pdf_delta
-REAL :: pdf_a, pdf_b, pdf_e1, pdf_e2
-!
-! for unadjusted clouds
-REAL :: qvapincld, qvapincld_new
-REAL :: qiceincld, qice_ratio
-REAL :: pres_sat, kappa
-REAL :: air_thermal_conduct, water_vapor_diff
-REAL :: iwc
-REAL :: iwc_log_inf100, iwc_log_sup100
-REAL :: iwc_inf100, alpha_inf100, coef_inf100
-REAL :: mu_sup100, sigma_sup100, coef_sup100
-REAL :: Dm_ice, rm_ice
-!
-! for sublimation
-REAL :: pdf_alpha
-REAL :: dqt_sub
-!
-! for condensation
-REAL, DIMENSION(klon) :: qsatl, dqsatl
-REAL :: clrfra, qclr, sl_clr, rhl_clr
-REAL :: pdf_ratqs, pdf_skew, pdf_scale, pdf_loc
-REAL :: pdf_x, pdf_y, pdf_T
-REAL :: pdf_e3, pdf_e4
-REAL :: cf_cond, qt_cond, dqt_con
-!
-! for mixing
-REAL, DIMENSION(klon) :: subfra, qsub
-REAL :: dqt_mix_sub, dqt_mix_issr
-REAL :: dcf_mix_sub, dcf_mix_issr
-REAL :: dqvc_mix_sub, dqvc_mix_issr
-REAL :: dqt_mix
-REAL :: a_mix, bovera, N_cld_mix, L_mix
-REAL :: envfra_mix, cldfra_mix
-REAL :: L_shear, shear_fra
-REAL :: sigma_mix, issrfra_mix, subfra_mix, qvapinmix
-!
-! for cell properties
-REAL :: rho, rhodz, dz
-!REAL :: V_cell, M_cell
-!
-! for aviation and cell properties
-!REAL :: dqt_avi
-!REAL :: contrail_fra
-!
-!
-!--more local variables for diagnostics
-!--imported from YOMCST.h 
-!--eps_w = 0.622 = ratio of molecular masses of water and dry air (kg H2O kg air -1)
-!--RCPD = 1004 J kg air−1 K−1 = the isobaric heat capacity of air
-!--values from Schumann, Meteorol Zeitschrift, 1996
-!--EiH2O = 1.25 / 2.24 / 8.94 kg H2O / kg fuel for kerosene / methane / dihydrogen
-!--Qheat = 43.  /  50. / 120. MJ / kg fuel for kerosene / methane / dihydrogen
-!REAL, PARAMETER :: EiH2O=1.25  !--emission index of water vapour for kerosene (kg kg-1)
-!REAL, PARAMETER :: Qheat=43.E6 !--specific combustion heat for kerosene (J kg-1) 
-!REAL, PARAMETER :: eta=0.3     !--average propulsion efficiency of the aircraft
-!--Gcontr is the slope of the mean phase trajectory in the turbulent exhaust field on an absolute 
-!--temperature versus water vapor partial pressure diagram. G has the unit of Pa K−1. Rap et al JGR 2010.
-!REAL :: Gcontr
-!--Tcontr = critical temperature for contrail formation (T_LM in Schumann 1996, Eq 31 in appendix 2) 
-!--qsatliqcontr = e_L(T_LM) in Schumann 1996 but expressed in specific humidity (kg kg humid air-1)
-!REAL :: qsatliqcontr
-
-
-!-----------------------------------------------
-! Initialisations
-!-----------------------------------------------
-
-! Ajout des émissions de H2O dues à l'aviation
-! q is the specific humidity (kg/kg humid air) hence the complicated equation to update q
-! qnew = ( m_humid_air * qold + dm_H2O ) / ( m_humid_air + dm_H2O )  
-!      = ( m_dry_air * qold + dm_h2O * (1-qold) ) / (m_dry_air + dm_H2O * (1-qold) ) 
-! The equation is derived by writing m_humid_air = m_dry_air + m_H2O = m_dry_air / (1-q) 
-! flight_h2O is in kg H2O / s / cell
-!
-!IF (ok_plane_h2o) THEN 
-!  q = ( M_cell*q + flight_h2o(i,k)*dtime*(1.-q) ) / (M_cell + flight_h2o(i,k)*dtime*(1.-q) ) 
-!ENDIF
-
-
-qzero(:) = 0.
-
-!--Calculation of qsat w.r.t. liquid
-CALL calc_qsat_ecmwf(klon, temp, qzero, pplay, RTT, 1, .FALSE., qsatl, dqsatl)
-
-!
-!--Loop on klon
-!
-DO i = 1, klon
-
-  !--If a new calculation of the condensation is needed,
-  !--i.e., temperature has not yet converged (or the cloud is
-  !--formed elsewhere)
-  IF (keepgoing(i)) THEN
-
-    !--If the temperature is higher than the threshold below which
-    !--there is no liquid in the gridbox, we activate the usual scheme
-    !--(generalised lognormal from Bony and Emanuel 2001)
-    !--If ok_weibull_warm_clouds = .TRUE., the Weibull law is used for
-    !--all clouds, and the lognormal scheme is not activated
-    IF ( ( temp(i) .GT. temp_nowater ) .AND. .NOT. ok_weibull_warm_clouds ) THEN
-
-      pdf_std   = ratqs(i) * qtot(i)
-      pdf_k     = -SQRT( LOG( 1. + (pdf_std / qtot(i))**2. ) )
-      pdf_delta = LOG( qtot(i) / ( gamma_cond(i) * qsat(i) ) )
-      pdf_a     = pdf_delta / ( pdf_k * SQRT(2.) )
-      pdf_b     = pdf_k / (2. * SQRT(2.))
-      pdf_e1    = pdf_a - pdf_b
-      pdf_e1    = SIGN( MIN(ABS(pdf_e1), 5.), pdf_e1 )
-      pdf_e1    = 1. - ERF(pdf_e1)
-      pdf_e2    = pdf_a + pdf_b
-      pdf_e2    = SIGN( MIN(ABS(pdf_e2), 5.), pdf_e2 )
-      pdf_e2    = 1. - ERF(pdf_e2)
-
-
-      IF ( pdf_e1 .LT. eps ) THEN
-        cldfra(i) = 0.
-        qincld(i) = qsat(i)
-        qvc(i) = 0.
-      ELSE
-        cldfra(i) = 0.5 * pdf_e1
-        qincld(i) = qtot(i) * pdf_e2 / pdf_e1
-        qvc(i) = qsat(i) * cldfra(i)
-      ENDIF
-
-    !--If the temperature is lower than temp_nowater, we use the new
-    !--condensation scheme that allows for ice supersaturation
-    ELSE
-
-      !--Initialisation
-      IF ( temp(i) .GT. temp_nowater ) THEN
-        !--If the air mass is warm (liquid water can exist),
-        !--all the memory is lost and the scheme becomes statistical,
-        !--i.e., the sublimation and mixing processes are deactivated,
-        !--and the condensation process is slightly adapted
-        !--This can happen only if ok_weibull_warm_clouds = .TRUE.
-        cldfra(i) = 0.
-        qvc(i)    = 0.
-        qcld(i)   = 0.
-        ok_warm_cloud = .TRUE.
-      ELSE
-        !--The following barriers ensure that the traced cloud properties
-        !--are consistent. In some rare cases, i.e. the cloud water vapor
-        !--can be greater than the total water in the gridbox
-        cldfra(i) = MAX(0., MIN(1., cf_seri(i)))
-        qcld(i)   = MAX(0., MIN(qtot(i), ( ratio_qi_qtot(i) + rvc_seri(i) ) * qtot(i))) 
-        qvc(i)    = MAX(0., MIN(qcld(i), rvc_seri(i) * qtot(i)))
-        ok_warm_cloud = .FALSE.
-      ENDIF
-
-      dcf_sub(i)  = 0.
-      dqi_sub(i)  = 0.
-      dqvc_sub(i) = 0.
-      dqi_adj(i)  = 0.
-      dqvc_adj(i) = 0.
-      dcf_con(i)  = 0.
-      dqi_con(i)  = 0.
-      dqvc_con(i) = 0.
-      dcf_mix(i)  = 0.
-      dqi_mix(i)  = 0.
-      dqvc_mix(i) = 0.
-
-      issrfra(i)  = 0.
-      qissr(i)    = 0.
-      subfra(i)   = 0.
-      qsub(i)     = 0.
-
-      !--Initialisation of the cell properties
-      !--Dry density [kg/m3]
-      rho = pplay(i) / temp(i) / RD
-      !--Dry air mass [kg/m2]
-      rhodz = ( paprsdn(i) - paprsup(i) ) / RG
-      !--Cell thickness [m]
-      dz = rhodz / rho
-      !--Cell volume [m3]
-      !V_cell = dz * cell_area(i)
-      !--Cell dry air mass [kg]
-      !M_cell = rhodz * cell_area(i)
-
-
-      IF ( ok_unadjusted_clouds ) THEN
-        !--If ok_unadjusted_clouds is set to TRUE, then the saturation adjustment
-        !--hypothesis is lost, and the vapor in the cloud is purely prognostic.
-        !
-        !--The deposition equation is
-        !-- dmi/dt = alpha*4pi*C*Svi / ( R_v*T/esi/Dv + Ls/ka/T * (Ls/R_v/T - 1) )
-        !--from Lohmann et al. (2016), where
-        !--alpha is the deposition coefficient [-]
-        !--mi is the mass of one ice crystal [kg]
-        !--C is the capacitance of an ice crystal [m]
-        !--Svi is the supersaturation ratio equal to (qvc - qsat)/qsat [-]
-        !--R_v is the specific gas constant for humid air [J/kg/K]
-        !--T is the temperature [K]
-        !--esi is the saturation pressure w.r.t. ice [Pa]
-        !--Dv is the diffusivity of water vapor [m2/s]
-        !--Ls is the specific latent heat of sublimation [J/kg/K]
-        !--ka is the thermal conductivity of dry air [J/m/s/K]
-        !
-        !--alpha is a coefficient to take into account the fact that during deposition, a water
-        !--molecule cannot join the crystal from everywhere, it must do so that the crystal stays
-        !--coherent (with the same structure). It has no impact for sublimation.
-        !--We fix alpha = depo_coef_cirrus (=0.5 by default following Lohmann et al. (2016))
-        !--during deposition, and alpha = 1. during sublimation.
-        !--The capacitance of the ice crystals is proportional to a parameter capa_cond_cirrus
-        !-- C = capa_cond_cirrus * rm_ice
-        !
-        !--We have qice = Nice * mi, where Nice is the ice crystal
-        !--number concentration per kg of moist air
-        !--HYPOTHESIS 1: the ice crystals are spherical, therefore
-        !-- mi = 4/3 * pi * rm_ice**3 * rho_ice
-        !--HYPOTHESIS 2: the ice crystals are monodisperse with the
-        !--initial radius rm_ice_0.
-        !--NB. this is notably different than the assumption
-        !--of a distributed qice in the cloud made in the sublimation process;
-        !--should it be consistent?
-        !
-        !--As the deposition process does not create new ice crystals,
-        !--and because we assume a same rm_ice value for all crystals
-        !--therefore the sublimation process does not destroy ice crystals
-        !--(or, in a limit case, it destroys all ice crystals), then
-        !--Nice is a constant during the sublimation/deposition process.
-        !-- dmi = dqi, et Nice = qi_0 / ( 4/3 RPI rm_ice_0**3 rho_ice )
-        !
-        !--The deposition equation then reads:
-        !-- dqi/dt = alpha*4pi*capa_cond_cirrus*rm_ice*(qvc-qsat)/qsat / ( R_v*T/esi/Dv + Ls/ka/T * (Ls/R_v/T - 1) ) * Nice
-        !-- dqi/dt = alpha*4pi*capa_cond_cirrus* (qi / qi_0)**(1/3) *rm_ice_0*(qvc-qsat)/qsat &
-        !--             / ( R_v*T/esi/Dv + Ls/ka/T * (Ls*R_v/T - 1) ) &
-        !--                         * qi_0 / ( 4/3 RPI rm_ice_0**3 rho_ice )
-        !-- dqi/dt = qi**(1/3) * (qvc - qsat) * qi_0**(2/3) &
-        !--  *alpha/qsat*capa_cond_cirrus/ (R_v*T/esi/Dv + Ls/ka/T*(Ls*R_v/T - 1)) / ( 1/3 rm_ice_0**2 rho_ice )
-        !--and we have
-        !-- dqvc/dt = - qi**(1/3) * (qvc - qsat) / kappa * alpha * qi_0**(2/3) / rm_ice_0**2
-        !-- dqi/dt  =   qi**(1/3) * (qvc - qsat) / kappa * alpha * qi_0**(2/3) / rm_ice_0**2
-        !--where kappa = 1/3*rho_ice/capa_cond_cirrus*qsat*(R_v*T/esi/Dv + Ls/ka/T*(Ls/R_v/T - 1))
-        !
-        !--This system of equations can be resolved with an exact
-        !--explicit numerical integration, having one variable resolved
-        !--explicitly, the other exactly. The exactly resolved variable is
-        !--the one decreasing, so it is qvc if the process is
-        !--condensation, qi if it is sublimation.
-        !
-        !--kappa is computed as an initialisation constant, as it depends only
-        !--on temperature and other pre-computed values
-        pres_sat = qsat(i) / ( EPS_W + ( 1. - EPS_W ) * qsat(i) ) * pplay(i)
-        !--This formula for air thermal conductivity comes from Beard and Pruppacher (1971)
-        air_thermal_conduct = ( 5.69 + 0.017 * ( temp(i) - RTT ) ) * 1.e-3 * 4.184
-        !--This formula for water vapor diffusivity comes from Hall and Pruppacher (1976)
-        water_vapor_diff = 0.211 * ( temp(i) / RTT )**1.94 * ( 101325. / pplay(i) ) * 1.e-4
-        kappa = 1. / 3. * rho_ice / capa_cond_cirrus * qsat(i) &
-              * ( RV * temp(i) / water_vapor_diff / pres_sat &
-                + RLSTT / air_thermal_conduct / temp(i) * ( RLSTT / RV / temp(i) - 1. ) )
-        !--NB. the greater kappa, the lower the efficiency of the deposition/sublimation process
-      ENDIF
-
-
-      !-------------------------------------------------------------------
-      !--    SUBLIMATION OF ICE AND DEPOSITION OF VAPOR IN THE CLOUD    --
-      !-------------------------------------------------------------------
-      
-      !--If there is a cloud
-      IF ( cldfra(i) .GT. eps ) THEN
-        
-        qvapincld = qvc(i) / cldfra(i)
-        qiceincld = ( qcld(i) / cldfra(i) - qvapincld )
-        
-        !--If the ice water content is too low, the cloud is purely sublimated
-        !--Most probably, we advected a cloud with no ice water content (possible
-        !--if the entire cloud precipited for example)
-        IF ( qiceincld .LT. eps ) THEN
-          dcf_sub(i) = - cldfra(i)
-          dqvc_sub(i) = - qvc(i)
-          dqi_sub(i) = - ( qcld(i) - qvc(i) )
-
-          cldfra(i) = 0.
-          qcld(i) = 0.
-          qvc(i) = 0.
-
-        !--Else, the cloud is adjusted and sublimated
-        ELSE
-
-          !--The vapor in cloud cannot be higher than the
-          !--condensation threshold
-          qvapincld = MIN(qvapincld, gamma_cond(i) * qsat(i))
-          qiceincld = ( qcld(i) / cldfra(i) - qvapincld )
-
-          IF ( ok_unadjusted_clouds ) THEN
-            !--Here, the initial vapor in the cloud is qvapincld, and we compute
-            !--the new vapor qvapincld_new
-
-            !--rm_ice formula from McFarquhar and Heymsfield (1997)
-            iwc = qiceincld * rho * 1e3
-            iwc_inf100 = MIN(iwc, 0.252 * iwc**0.837)
-            iwc_log_inf100 = LOG10( MAX(eps, iwc_inf100) )
-            iwc_log_sup100 = LOG10( MAX(eps, iwc - iwc_inf100) )
-
-            alpha_inf100 = - 4.99E-3 - 0.0494 * iwc_log_inf100
-            coef_inf100 = iwc_inf100 * alpha_inf100**3. / 120.
-
-            mu_sup100 = ( 5.2 + 0.0013 * ( temp(i) - RTT ) ) &
-                      + ( 0.026 - 1.2E-3 * ( temp(i) - RTT ) ) * iwc_log_sup100
-            sigma_sup100 = ( 0.47 + 2.1E-3 * ( temp(i) - RTT ) ) &
-                         + ( 0.018 - 2.1E-4 * ( temp(i) - RTT ) ) * iwc_log_sup100
-            coef_sup100 = ( iwc - iwc_inf100 ) / EXP( 3 * mu_sup100 + 4.5 * sigma_sup100**2. )
-
-            Dm_ice = ( 2. / alpha_inf100 * coef_inf100 + EXP( mu_sup100 + 0.5 * sigma_sup100**2. ) &
-                   * coef_sup100 ) / ( coef_inf100 + coef_sup100 )
-            rm_ice = Dm_ice / 2. * 1.E-6
-
-            IF ( qvapincld .GE. qsat(i) ) THEN
-              !--If the cloud is initially supersaturated
-              !--Exact explicit integration (qvc exact, qice explicit)
-              qvapincld_new = qsat(i) + ( qvapincld - qsat(i) ) &
-                            * EXP( - depo_coef_cirrus * dtime * qiceincld / kappa / rm_ice**2. )
-            ELSE
-              !--If the cloud is initially subsaturated
-              !--Exact explicit integration (qice exact, qvc explicit)
-              !--The barrier is set so that the resulting vapor in cloud
-              !--cannot be greater than qsat
-              !--qice_ratio is the ratio between the new ice content and
-              !--the old one, it is comprised between 0 and 1
-              qice_ratio = ( 1. - 2. / 3. / kappa / rm_ice**2. * dtime * ( qsat(i) - qvapincld ) )
-
-              IF ( qice_ratio .LT. 0. ) THEN
-                !--If all the ice has been sublimated, we sublimate
-                !--completely the cloud and do not activate the sublimation
-                !--process
-                !--Tendencies and diagnostics
-                dcf_sub(i) = - cldfra(i)
-                dqvc_sub(i) = - qvc(i)
-                dqi_sub(i) = - ( qcld(i) - qvc(i) )
-
-                cldfra(i) = 0.
-                qcld(i) = 0.
-                qvc(i) = 0.
-
-                !--The new vapor in cloud is set to 0 so that the
-                !--sublimation process does not activate
-                qvapincld_new = 0.
-              ELSE
-                !--Else, the sublimation process is activated with the
-                !--diagnosed new cloud water vapor
-                !--The new vapor in the cloud is increased with the
-                !--sublimated ice
-                qvapincld_new = qvapincld + qiceincld * ( 1. - qice_ratio**(3./2.) )
-                !--The new vapor in the cloud cannot be greater than qsat
-                qvapincld_new = MIN(qvapincld_new, qsat(i))
-              ENDIF ! qice_ratio .LT. 0.
-            ENDIF ! qvapincld .GT. qsat(i)
-          ELSE
-            !--We keep the saturation adjustment hypothesis, and the vapor in the
-            !--cloud is set equal to the saturation vapor
-            qvapincld_new = qsat(i)
-          ENDIF ! ok_unadjusted_clouds
-          
-          !--Adjustment of the IWC to the new vapor in cloud
-          !--(this can be either positive or negative)
-          dqvc_adj(i) = ( qvapincld_new * cldfra(i) - qvc(i) )
-          dqi_adj(i) = - dqvc_adj(i)
-
-          !--Add tendencies
-          !--The vapor in the cloud is updated, but not qcld as it is constant
-          !--through this process, as well as cldfra which is unmodified
-          qvc(i) = MAX(0., MIN(qcld(i), qvc(i) + dqvc_adj(i)))
-          
-
-          !------------------------------------
-          !--    DISSIPATION OF THE CLOUD    --
-          !------------------------------------
-
-          !--If the vapor in cloud is below vapor needed for the cloud to survive
-          IF ( qvapincld .LT. qvapincld_new ) THEN
-            !--Sublimation of the subsaturated cloud
-            !--iflag_cloud_sublim_pdf selects the PDF of the ice water content
-            !--to use.
-            !--iflag = 1 --> uniform distribution
-            !--iflag = 2 --> exponential distribution
-            !--iflag = 3 --> gamma distribution (Karcher et al 2018)
-
-            IF ( iflag_cloud_sublim_pdf .EQ. 1 ) THEN
-              !--Uniform distribution starting at qvapincld
-              pdf_e1 = 1. / ( 2. * qiceincld )
-
-              dcf_sub(i) = - cldfra(i) * ( qvapincld_new - qvapincld ) * pdf_e1
-              dqt_sub    = - cldfra(i) * ( qvapincld_new**2. - qvapincld**2. ) &
-                                       * pdf_e1 / 2.
-
-            ELSEIF ( iflag_cloud_sublim_pdf .EQ. 2 ) THEN
-              !--Exponential distribution starting at qvapincld
-              pdf_alpha = 1. / qiceincld
-              pdf_e1 = EXP( - pdf_alpha * ( qvapincld_new - qvapincld ) )
-
-              dcf_sub(i) = - cldfra(i) * ( 1. - pdf_e1 )
-              dqt_sub    = - cldfra(i) * ( ( 1. - pdf_e1 ) / pdf_alpha &
-                                       + qvapincld - qvapincld_new * pdf_e1 )
-
-            ELSEIF ( iflag_cloud_sublim_pdf .GE. 3 ) THEN
-              !--Gamma distribution starting at qvapincld
-              pdf_alpha = ( mu_subl_pdf_lscp + 1. ) / qiceincld
-              pdf_y = pdf_alpha * ( qvapincld_new - qvapincld )
-              pdf_e1 = GAMMAINC ( mu_subl_pdf_lscp + 1. , pdf_y )
-              pdf_e2 = GAMMAINC ( mu_subl_pdf_lscp + 2. , pdf_y )
-
-              dcf_sub(i) = - cldfra(i) * pdf_e1
-              dqt_sub    = - cldfra(i) * ( pdf_e2 / pdf_alpha + qvapincld * pdf_e1 )
-            ENDIF
-
-            !--Tendencies and diagnostics
-            dqvc_sub(i) = dqt_sub
-
-            !--Add tendencies
-            cldfra(i) = MAX(0., cldfra(i) + dcf_sub(i))
-            qcld(i)   = MAX(0., qcld(i) + dqt_sub)
-            qvc(i)    = MAX(0., qvc(i) + dqvc_sub(i))
-
-          ENDIF ! qvapincld .LT. qvapincld_new
-
-        ENDIF   ! qiceincld .LT. eps
-      ENDIF ! cldfra(i) .GT. eps
-
-
-      !--------------------------------------------------------------------------
-      !--    CONDENSATION AND DIAGNOTICS OF SUB- AND SUPERSATURATED REGIONS    --
-      !--------------------------------------------------------------------------
-      !--This section relies on a distribution of water in the clear-sky region of
-      !--the mesh.
-
-      !--If there is a clear-sky region
-      IF ( ( 1. - cldfra(i) ) .GT. eps ) THEN
-
-        !--Water quantity in the clear-sky + potential liquid cloud (gridbox average)
-        qclr = qtot(i) - qcld(i)
-
-        !--New PDF
-        rhl_clr = qclr / ( 1. - cldfra(i) ) / qsatl(i) * 100.
-        rhl_clr = MIN(rhl_clr, 2. * rhlmid_pdf_lscp)
-
-        !--Calculation of the properties of the PDF
-        !--Parameterization from IAGOS observations
-        !--pdf_e1 and pdf_e2 will be reused below
-
-        !--Coefficient for standard deviation:
-        !--  tuning coef * (clear sky area**0.25) * (function of temperature)
-        pdf_e1 = beta_pdf_lscp &
-               * ( ( 1. - cldfra(i) ) * cell_area(i) )**( 1. / 4. ) &
-               * MAX( temp(i) - temp_thresh_pdf_lscp, 0. )
-        IF ( rhl_clr .GT. rhlmid_pdf_lscp ) THEN
-          pdf_std = pdf_e1 * ( 2. * rhlmid_pdf_lscp - rhl_clr ) / rhlmid_pdf_lscp
-        ELSE
-          pdf_std = pdf_e1 * rhl_clr / rhlmid_pdf_lscp
-        ENDIF
-        pdf_e3 = k0_pdf_lscp + kappa_pdf_lscp * MAX( temp_nowater - temp(i), 0. )
-        pdf_alpha = EXP( rhl_clr / rhl0_pdf_lscp ) * pdf_e3
-
-        pdf_e2 = GAMMA(1. + 1. / pdf_alpha)
-        pdf_scale = MAX(eps, pdf_std / SQRT( GAMMA(1. + 2. / pdf_alpha) - pdf_e2**2. ))
-        pdf_loc = rhl_clr - pdf_scale * pdf_e2
-
-        !--Diagnostics of ratqs
-        ratqs(i) = pdf_std / ( qclr / ( 1. - cldfra(i) ) / qsatl(i) * 100. )
-
-        !--Calculation of the newly condensed water and fraction (pronostic)
-        !--Integration of the clear sky PDF between gamma_cond*qsat and +inf
-        !--NB. the calculated values are clear-sky averaged
-
-        pdf_x = gamma_cond(i) * qsat(i) / qsatl(i) * 100.
-        pdf_y = ( MAX( pdf_x - pdf_loc, 0. ) / pdf_scale ) ** pdf_alpha
-        pdf_e3 = GAMMAINC ( 1. + 1. / pdf_alpha , pdf_y )
-        pdf_e3 = pdf_scale * ( 1. - pdf_e3 ) * pdf_e2
-        cf_cond = EXP( - pdf_y )
-        qt_cond = ( pdf_e3 + pdf_loc * cf_cond ) * qsatl(i) / 100.
-
-        IF ( ok_warm_cloud ) THEN
-          !--If the statistical scheme is activated, the calculated increase is equal
-          !--to the cloud fraction, we assume saturation adjustment, and the
-          !--condensation process stops
-          cldfra(i) = cf_cond
-          qcld(i) = qt_cond
-          qvc(i) = cldfra(i) * qsat(i)
-
-        ELSEIF ( cf_cond .GT. eps ) THEN
-
-          dcf_con(i) = ( 1. - cldfra(i) ) * cf_cond
-          dqt_con = ( 1. - cldfra(i) ) * qt_cond
-          
-          !--Barriers
-          dcf_con(i) = MIN(dcf_con(i), 1. - cldfra(i))
-          dqt_con = MIN(dqt_con, qclr)
-
-
-          IF ( ok_unadjusted_clouds ) THEN
-            !--Here, the initial vapor in the cloud is gamma_cond*qsat, and we compute
-            !--the new vapor qvapincld. The timestep is divided by two because we do not
-            !--know when the condensation occurs
-            qvapincld = gamma_cond(i) * qsat(i)
-            qiceincld = dqt_con / dcf_con(i) - gamma_cond(i) * qsat(i)
-
-            !--rm_ice formula from McFarquhar and Heymsfield (1997)
-            iwc = qiceincld * rho * 1e3
-            iwc_inf100 = MIN(iwc, 0.252 * iwc**0.837)
-            iwc_log_inf100 = LOG10( MAX(eps, iwc_inf100) )
-            iwc_log_sup100 = LOG10( MAX(eps, iwc - iwc_inf100) )
-
-            alpha_inf100 = - 4.99E-3 - 0.0494 * iwc_log_inf100
-            coef_inf100 = iwc_inf100 * alpha_inf100**3. / 120.
-
-            mu_sup100 = ( 5.2 + 0.0013 * ( temp(i) - RTT ) ) &
-                      + ( 0.026 - 1.2E-3 * ( temp(i) - RTT ) ) * iwc_log_sup100
-            sigma_sup100 = ( 0.47 + 2.1E-3 * ( temp(i) - RTT ) ) &
-                         + ( 0.018 - 2.1E-4 * ( temp(i) - RTT ) ) * iwc_log_sup100
-            coef_sup100 = ( iwc - iwc_inf100 ) / EXP( 3. * mu_sup100 + 4.5 * sigma_sup100**2. )
-
-            Dm_ice = ( 2. / alpha_inf100 * coef_inf100 + EXP( mu_sup100 + 0.5 * sigma_sup100**2. ) &
-                   * coef_sup100 ) / ( coef_inf100 + coef_sup100 )
-            rm_ice = Dm_ice / 2. * 1.E-6
-            !--As qvapincld is necessarily greater than qsat, we only
-            !--use the exact explicit formulation
-            !--Exact explicit version
-            qvapincld = qsat(i) + ( qvapincld - qsat(i) ) &
-                      * EXP( - depo_coef_cirrus * dtime / 2. * qiceincld / kappa / rm_ice**2. )
-          ELSE
-            !--We keep the saturation adjustment hypothesis, and the vapor in the
-            !--newly formed cloud is set equal to the saturation vapor.
-            qvapincld = qsat(i)
-          ENDIF
-
-          !--Tendency on cloud vapor and diagnostic
-          dqvc_con(i) = qvapincld * dcf_con(i)
-          dqi_con(i) = dqt_con - dqvc_con(i)
-
-          !--Note that the tendencies are NOT added because they are
-          !--added after the mixing process. In the following, the gridbox fraction is
-          !-- 1. - dcf_con(i), and the total water in the gridbox is
-          !-- qtot(i) - dqi_con(i) - dqvc_con(i)
-
-        ENDIF ! ok_warm_cloud, cf_cond .GT. eps
-      ENDIF ! ( 1. - cldfra(i) ) .GT. eps
-
-      !--If there is still clear sky, we diagnose the ISSR
-      !--We recalculte the PDF properties (after the condensation process)
-      IF ( ( ( 1. - dcf_con(i) - cldfra(i) ) .GT. eps ) .AND. .NOT. ok_warm_cloud ) THEN
-        !--Water quantity in the clear-sky + potential liquid cloud (gridbox average)
-        qclr = qtot(i) - dqi_con(i) - dqvc_con(i) - qcld(i)
-
-        !--New PDF
-        rhl_clr = qclr / ( 1. - dcf_con(i) - cldfra(i) ) / qsatl(i) * 100.
-        rhl_clr = MIN(rhl_clr, 2. * rhlmid_pdf_lscp)
-
-        !--Calculation of the properties of the PDF
-        !--Parameterization from IAGOS observations
-        !--pdf_e1 and pdf_e2 will be reused below
-
-        !--Coefficient for standard deviation:
-        !--  tuning coef * (clear sky area**0.25) * (function of temperature)
-        pdf_e1 = beta_pdf_lscp &
-               * ( ( 1. - dcf_con(i) - cldfra(i) ) * cell_area(i) )**( 1. / 4. ) &
-               * MAX( temp(i) - temp_thresh_pdf_lscp, 0. )
-        IF ( rhl_clr .GT. rhlmid_pdf_lscp ) THEN
-          pdf_std = pdf_e1 * ( 2. * rhlmid_pdf_lscp - rhl_clr ) / rhlmid_pdf_lscp
-        ELSE
-          pdf_std = pdf_e1 * rhl_clr / rhlmid_pdf_lscp
-        ENDIF
-        pdf_e3 = k0_pdf_lscp + kappa_pdf_lscp * MAX( temp_nowater - temp(i), 0. )
-        pdf_alpha = EXP( rhl_clr / rhl0_pdf_lscp ) * pdf_e3
-
-        pdf_e2 = GAMMA(1. + 1. / pdf_alpha)
-        pdf_scale = MAX(eps, pdf_std / SQRT( GAMMA(1. + 2. / pdf_alpha) - pdf_e2**2. ))
-        pdf_loc = rhl_clr - pdf_scale * pdf_e2
-
-        !--We then calculate the part that is greater than qsat
-        !--and consider it supersaturated
-
-        pdf_x = qsat(i) / qsatl(i) * 100.
-        pdf_y = ( MAX( pdf_x - pdf_loc, 0. ) / pdf_scale ) ** pdf_alpha
-        pdf_e3 = GAMMAINC ( 1. + 1. / pdf_alpha , pdf_y )
-        pdf_e3 = pdf_scale * ( 1. - pdf_e3 ) * pdf_e2
-        issrfra(i) = EXP( - pdf_y ) * ( 1. - dcf_con(i) - cldfra(i) )
-        qissr(i) = ( pdf_e3 * ( 1. - dcf_con(i) - cldfra(i) ) + pdf_loc * issrfra(i) ) * qsatl(i) / 100.
-      ENDIF
-
-      !--Calculation of the subsaturated clear sky fraction and water
-      subfra(i) = 1. - dcf_con(i) - cldfra(i) - issrfra(i)
-      qsub(i) = qtot(i) - dqi_con(i) - dqvc_con(i) - qcld(i) - qissr(i)
-
-
-      !--------------------------------------
-      !--           CLOUD MIXING           --
-      !--------------------------------------
-      !--This process mixes the cloud with its surroundings: the subsaturated clear sky,
-      !--and the supersaturated clear sky. It is activated if the cloud is big enough,
-      !--but does not cover the entire mesh.
-      !
-      IF ( ( cldfra(i) .LT. ( 1. - dcf_con(i) - eps ) ) .AND. ( cldfra(i) .GT. eps ) &
-           .AND. .NOT. ok_warm_cloud ) THEN
-
-        !--Initialisation
-        dcf_mix_sub   = 0.
-        dqt_mix_sub   = 0.
-        dqvc_mix_sub  = 0.
-        dcf_mix_issr  = 0.
-        dqt_mix_issr  = 0.
-        dqvc_mix_issr = 0.
-
-
-        !-- PART 1 - TURBULENT DIFFUSION
-
-        !--Clouds within the mesh are assumed to be ellipses. The length of the
-        !--semi-major axis is a and the length of the semi-minor axis is b.
-        !--N_cld_mix is the number of clouds within the mesh, and
-        !--clouds_perim is the total perimeter of the clouds within the mesh,
-        !--not considering interfaces with other meshes (only the interfaces with clear
-        !--sky are taken into account).
-        !--
-        !--The area of each cloud is A = a * b * RPI,
-        !--and the perimeter of each cloud is
-        !-- P ~= RPI * ( 3 * (a + b) - SQRT( (3 * a + b) * (a + 3 * b) ) )
-        !--
-        !--With cell_area the area of the cell, we have:
-        !-- cldfra = A * N_cld_mix / cell_area
-        !-- clouds_perim = P * N_cld_mix
-        !--
-        !--We assume that the ratio between b and a is a function of
-        !--cldfra such that it is 1 for cldfra = 1 and it is low for little cldfra, because
-        !--if cldfra is low the clouds are linear, and if cldfra is high, the clouds
-        !--are spherical.
-        !-- b / a = bovera = MAX(0.1, cldfra)
-        bovera = MAX(0.1, cldfra(i))
-        !--The clouds perimeter is imposed using the formula from Morcrette 2012,
-        !--based on observations.
-        !-- clouds_perim_normalized = alpha * cldfra * ( 1. - cldfra ) = clouds_perim / ( norm_constant * cell_area )
-        !--
-        !--With all this, we have
-        !-- a = SQRT( cell_area * cldfra / ( b / a * N_cld_mix * RPI ) )
-        !-- P = RPI * a * ( 3. * ( 1. + b / a ) - SQRT( (3. + b / a) * (1. + 3. * b / a) ) )
-        !--and therefore, using the perimeter
-        !-- alpha * cldfra * ( 1. - cldfra ) * norm_constant * cell_area
-        !--             = N_cld_mix * RPI &
-        !--             * SQRT( cell_area * cldfra / ( b / a * N_cld_mix * RPI ) ) &
-        !--             * ( 3. * ( 1. + b / a ) - SQRT( (3. + b / a) * (1. + 3. * b / a) ) )
-        !--and finally
-        N_cld_mix = coef_mixing_lscp * cldfra(i) * ( 1. - dcf_con(i) - cldfra(i) )**2. &
-                  * cell_area(i) * ( 1. - dcf_con(i) ) * bovera / RPI &
-                  / ( 3. * (1. + bovera) - SQRT( (3. + bovera) * (1. + 3. * bovera) ) )**2.
-        !--where coef_mix_lscp = ( alpha * norm_constant )**2.
-        !--N_cld_mix is the number of clouds in contact with clear sky, and can be non-integer
-        !--In particular, it is 0 if cldfra = 1
-        a_mix = SQRT( cell_area(i) * ( 1. - dcf_con(i) ) * cldfra(i) / bovera / N_cld_mix / RPI )
-
-        !--The time required for turbulent diffusion to homogenize a region of size
-        !--L_mix is defined as (L_mix**2./tke_dissip)**(1./3.) (Pope, 2000; Field et al., 2014)
-        !--We compute L_mix and assume that the cloud is mixed over this length
-        L_mix = SQRT( dtime**3. * pbl_eps(i) )
-        !--The mixing length cannot be greater than the semi-minor axis. In this case,
-        !--the entire cloud is mixed.
-        L_mix = MIN(L_mix, a_mix * bovera)
-
-        !--The fraction of clear sky mixed is
-        !-- N_cld_mix * ( (a + L_mix) * (b + L_mix) - a * b ) * RPI / cell_area
-        envfra_mix = N_cld_mix * RPI / cell_area(i) / ( 1. - dcf_con(i) ) &
-                   * ( a_mix * ( 1. + bovera ) * L_mix + L_mix**2. )
-        !--The fraction of cloudy sky mixed is
-        !-- N_cld_mix * ( a * b - (a - L_mix) * (b - L_mix) ) * RPI / cell_area
-        cldfra_mix = N_cld_mix * RPI / cell_area(i) / ( 1. - dcf_con(i) ) &
-                   * ( a_mix * ( 1. + bovera ) * L_mix - L_mix**2. )
-
-
-        !-- PART 2 - SHEARING
-
-        !--The clouds are then sheared. We keep the shape and number
-        !--assumptions from before. The clouds are sheared along their
-        !--semi-major axis (a_mix), on the entire cell heigh dz.
-        !--The increase in size is
-        L_shear = coef_shear_lscp * shear(i) * dz * dtime
-        !--therefore, the total increase in fraction is
-        !-- N_cld_mix * ( (a + L_shear) * b - a * b ) * RPI / 2. / cell_area
-        shear_fra = RPI * L_shear * a_mix * bovera / 2. * N_cld_mix &
-                  / cell_area(i) / ( 1. - dcf_con(i) )
-        !--and the environment and cloud mixed fractions are the same,
-        !--which we add to the previous calculated mixed fractions.
-        !--We therefore assume that the sheared clouds and the turbulent
-        !--mixed clouds are different.
-        envfra_mix = envfra_mix + shear_fra
-        cldfra_mix = cldfra_mix + shear_fra
-
-
-        !-- PART 3 - CALCULATION OF THE MIXING PROPERTIES
-
-        !--The environment fraction is allocated to subsaturated sky or supersaturated sky,
-        !--according to the factor sigma_mix. This is computed as the ratio of the
-        !--subsaturated sky fraction to the environment fraction, corrected by a factor
-        !--chi_mixing_lscp for the supersaturated part. If chi is greater than 1, the
-        !--supersaturated sky is favoured. Physically, this means that it is more likely
-        !--to have supersaturated sky around the cloud than subsaturated sky.
-        sigma_mix = subfra(i) / ( subfra(i) + chi_mixing_lscp * issrfra(i) )
-        subfra_mix = MIN( sigma_mix * envfra_mix, subfra(i) )
-        issrfra_mix = MIN( ( 1. - sigma_mix ) * envfra_mix, issrfra(i) )
-        cldfra_mix = MIN( cldfra_mix, cldfra(i) )
-
-        !--First, we mix the subsaturated sky (subfra_mix) and the cloud close
-        !--to this fraction (sigma_mix * cldfra_mix).
-        IF ( subfra(i) .GT. eps ) THEN
-
-          IF ( ok_unadjusted_clouds ) THEN
-            !--The subsaturated air is simply added to the cloud,
-            !--with the corresponding cloud fraction
-            !--If the cloud is too subsaturated, the sublimation process
-            !--activated in the following timestep will reduce the cloud
-            !--fraction
-            dcf_mix_sub = subfra_mix
-            dqt_mix_sub = dcf_mix_sub * qsub(i) / subfra(i)
-            dqvc_mix_sub = dqt_mix_sub
-
-          ELSE
-            !--We compute the total humidity in the mixed air, which
-            !--can be either sub- or supersaturated.
-            qvapinmix = ( qsub(i) * subfra_mix / subfra(i) &
-                      + qcld(i) * cldfra_mix * sigma_mix / cldfra(i) ) &
-                      / ( subfra_mix + cldfra_mix * sigma_mix )
-
-            IF ( qvapinmix .GT. qsat(i) ) THEN
-              !--If the mixed air is supersaturated, we condense the subsaturated
-              !--region which was mixed.
-              dcf_mix_sub = subfra_mix
-              dqt_mix_sub = dcf_mix_sub * qsub(i) / subfra(i)
-              dqvc_mix_sub = dcf_mix_sub * qsat(i)
-            ELSE
-              !--Else, we sublimate the cloud which was mixed.
-              dcf_mix_sub = - sigma_mix * cldfra_mix
-              dqt_mix_sub = dcf_mix_sub * qcld(i) / cldfra(i)
-              dqvc_mix_sub = dcf_mix_sub * qsat(i)
-            ENDIF
-          ENDIF ! ok_unadjusted_clouds
-        ENDIF ! subfra .GT. eps
-   
-        !--We then mix the supersaturated sky (issrfra_mix) and the cloud,
-        !--for which the mixed air is always supersatured, therefore
-        !--the cloud necessarily expands
-        IF ( issrfra(i) .GT. eps ) THEN
-
-          IF ( ok_unadjusted_clouds ) THEN
-            !--The ice supersaturated air is simply added to the
-            !--cloud, and supersaturated vapor will be deposited on the
-            !--cloud ice crystals by the deposition process in the
-            !--following timestep
-            dcf_mix_issr = issrfra_mix
-            dqt_mix_issr = dcf_mix_issr * qissr(i) / issrfra(i)
-            dqvc_mix_issr = dqt_mix_issr
-          ELSE
-            !--In this case, the additionnal vapor condenses
-            dcf_mix_issr = issrfra_mix
-            dqt_mix_issr = dcf_mix_issr * qissr(i) / issrfra(i)
-            dqvc_mix_issr = dcf_mix_issr * qsat(i)
-          ENDIF ! ok_unadjusted_clouds
-
-
-        ENDIF ! issrfra .GT. eps
-
-        !--Sum up the tendencies from subsaturated sky and supersaturated sky
-        dcf_mix(i)  = dcf_mix_sub  + dcf_mix_issr
-        dqt_mix     = dqt_mix_sub  + dqt_mix_issr
-        dqvc_mix(i) = dqvc_mix_sub + dqvc_mix_issr
-        dqi_mix(i)  = dqt_mix - dqvc_mix(i)
-
-        !--Add tendencies
-        issrfra(i) = MAX(0., issrfra(i) - dcf_mix_issr)
-        qissr(i)   = MAX(0., qissr(i) - dqt_mix_issr)
-        cldfra(i)  = MAX(0., MIN(1. - dcf_con(i), cldfra(i) + dcf_mix(i)))
-        qcld(i)    = MAX(0., MIN(qtot(i) - dqi_con(i) - dqvc_con(i), qcld(i) + dqt_mix))
-        qvc(i)     = MAX(0., MIN(qcld(i), qvc(i) + dqvc_mix(i)))
-
-      ENDIF ! ( ( cldfra(i) .LT. ( 1. - dcf_con(i) - eps ) ) .AND. ( cldfra(i) .GT. eps ) )
-
-      !--Finally, we add the tendencies of condensation
-      cldfra(i) = MIN(1., cldfra(i) + dcf_con(i))
-      qcld(i)   = MIN(qtot(i), qcld(i) + dqvc_con(i) + dqi_con(i))
-      qvc(i)    = MIN(qcld(i), qvc(i) + dqvc_con(i))
-
-
-      !----------------------------------------
-      !--       CONTRAILS AND AVIATION       --
-      !----------------------------------------
-
-      !--Add a source of cirrus from aviation contrails
-      !IF ( ok_plane_contrail ) THEN
-      !  dcf_avi(i) = 0.
-      !  dqi_avi(i) = 0.
-      !  dqvc_avi(i) = 0.
-      !  ! TODO implement ok_unadjusted_clouds
-      !  IF ( issrfra(i) .GT. eps ) THEN
-      !    contrail_fra = MIN(1., flight_m(i,k) * dtime * contrail_cross_section / V_cell)
-      !    dcf_avi(i) = issrfra(i) * contrail_fra
-      !    dqt_avi = dcf_avi(i) * qissr(i) / issrfra(i)
-      !    dqvc_avi(i) = qsat(i) * dcf_avi(i)
-      !    
-      !    !--Add tendencies
-      !    cldfra(i) = cldfra(i) + dcf_avi(i)
-      !    issrfra(i) = issrfra(i) - dcf_avi(i)
-      !    qcld(i) = qcld(i) + dqt_avi
-      !    qvc(i) = qvc(i) + dqvc_avi(i)
-      !    qissr(i) = qissr(i) - dqt_avi
-
-      !    !--Diagnostics
-      !    dqi_avi(i) = dqt_avi - qsat(i) * dcf_avi(i)
-      !  ENDIF
-      !  dcf_avi(i)  = dcf_avi(i)  / dtime
-      !  dqi_avi(i)  = dqi_avi(i)  / dtime
-      !  dqvc_avi(i) = dqvc_avi(i) / dtime
-      !ENDIF
-
-
-
-      !-------------------------------------------
-      !--       FINAL BARRIERS AND OUTPUTS      --
-      !-------------------------------------------
-
-      IF ( cldfra(i) .LT. eps ) THEN
-        !--If the cloud is too small, it is sublimated.
-        cldfra(i) = 0.
-        qcld(i)   = 0.
-        qvc(i)    = 0.
-        qincld(i) = qsat(i)
-      ELSE
-        qincld(i) = qcld(i) / cldfra(i)
-      ENDIF ! cldfra .LT. eps
-
-      !--Diagnostics
-      dcf_sub(i)  = dcf_sub(i)  / dtime
-      dcf_con(i)  = dcf_con(i)  / dtime 
-      dcf_mix(i)  = dcf_mix(i)  / dtime 
-      dqi_adj(i)  = dqi_adj(i)  / dtime 
-      dqi_sub(i)  = dqi_sub(i)  / dtime 
-      dqi_con(i)  = dqi_con(i)  / dtime 
-      dqi_mix(i)  = dqi_mix(i)  / dtime 
-      dqvc_adj(i) = dqvc_adj(i) / dtime
-      dqvc_sub(i) = dqvc_sub(i) / dtime
-      dqvc_con(i) = dqvc_con(i) / dtime
-      dqvc_mix(i) = dqvc_mix(i) / dtime
-
-    ENDIF ! ( temp(i) .GT. temp_nowater ) .AND. .NOT. ok_weibull_warm_clouds
-
-  ENDIF   ! end keepgoing
-
-ENDDO     ! end loop on i
-
-END SUBROUTINE condensation_ice_supersat
-!**********************************************************************************
-
-END MODULE lmdz_lscp_condensation
Index: /LMDZ6/trunk/libf/phylmd/lmdz_lscp_condensation.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/lmdz_lscp_condensation.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/lmdz_lscp_condensation.f90	(revision 5268)
@@ -0,0 +1,1105 @@
+MODULE lmdz_lscp_condensation
+!----------------------------------------------------------------
+! Module for condensation of clouds routines
+! that are called in LSCP
+
+
+IMPLICIT NONE
+
+CONTAINS
+
+!*********************************************************************************
+SUBROUTINE condensation_lognormal_test(klon,klev,k,keepgoing,ratqs, gammasat,zq, zqs, zqn, qvc, rneb)
+
+
+IMPLICIT NONE
+
+INTEGER, INTENT(IN)   :: klon,klev,k
+LOGICAL,  INTENT(IN)   , DIMENSION(klon) :: keepgoing     ! .TRUE. if a new condensation loop should be computed
+REAL, INTENT(IN), DIMENSION(klon,klev)   :: ratqs
+REAL, INTENT(IN), DIMENSION(klon)        :: zq, zqs,gammasat
+REAL, INTENT(INOUT), DIMENSION(klon)     :: zqn, qvc
+REAL, INTENT(INOUT), DIMENSION(klon,klev) :: rneb
+
+REAL, DIMENSION(klon) :: zpdf_sig,zpdf_k,zpdf_delta             ! lognormal parameters
+REAL, DIMENSION(klon) :: Zpdf_a,zpdf_b,zpdf_e1,zpdf_e2          ! lognormal intermediate variables
+INTEGER               :: i
+
+
+DO i=1,klon !todoan : check if loop in i is needed
+
+    IF (keepgoing(i)) THEN
+
+    zpdf_sig(i)=ratqs(i,k)*zq(i)
+    zpdf_k(i)=-sqrt(log(1.+(zpdf_sig(i)/zq(i))**2))
+    zpdf_delta(i)=log(zq(i)/(gammasat(i)*zqs(i)))
+    zpdf_a(i)=zpdf_delta(i)/(zpdf_k(i)*sqrt(2.))
+    zpdf_b(i)=zpdf_k(i)/(2.*sqrt(2.))
+    zpdf_e1(i)=zpdf_a(i)-zpdf_b(i)
+    zpdf_e1(i)=sign(min(ABS(zpdf_e1(i)),5.),zpdf_e1(i))
+    zpdf_e1(i)=1.-erf(zpdf_e1(i))
+    zpdf_e2(i)=zpdf_a(i)+zpdf_b(i)
+    zpdf_e2(i)=sign(min(ABS(zpdf_e2(i)),5.),zpdf_e2(i))
+    zpdf_e2(i)=1.-erf(zpdf_e2(i))
+
+    IF (zpdf_e1(i).LT.1.e-10) THEN
+        rneb(i,k)=0.
+        zqn(i)=zqs(i)
+        !--AB grid-mean vapor in the cloud - we assume saturation adjustment
+        qvc(i) = 0.
+    ELSE
+        rneb(i,k)=0.5*zpdf_e1(i)
+        zqn(i)=zq(i)*zpdf_e2(i)/zpdf_e1(i)
+        !--AB grid-mean vapor in the cloud - we assume saturation adjustment
+        qvc(i) = rneb(i,k) * zqs(i)
+    ENDIF
+
+    ENDIF ! keepgoing
+ENDDO ! loop on klon
+
+
+END SUBROUTINE condensation_lognormal_test
+
+
+!**********************************************************************************
+SUBROUTINE condensation_lognormal( &
+      klon, temp, qtot, qsat, gamma_cond, ratqs, &
+      keepgoing, cldfra, qincld, qvc)
+
+!----------------------------------------------------------------------
+! This subroutine calculates the formation of clouds, using a
+! statistical cloud scheme. It uses a generalised lognormal distribution
+! of total water in the gridbox
+! See Bony and Emanuel, 2001
+!----------------------------------------------------------------------
+
+USE lmdz_lscp_ini, ONLY: eps
+
+IMPLICIT NONE
+
+!
+! Input
+!
+INTEGER,  INTENT(IN)                     :: klon          ! number of horizontal grid points
+!
+REAL,     INTENT(IN)   , DIMENSION(klon) :: temp          ! temperature [K]
+REAL,     INTENT(IN)   , DIMENSION(klon) :: qtot          ! total specific humidity (without precip) [kg/kg]
+REAL,     INTENT(IN)   , DIMENSION(klon) :: qsat          ! saturation specific humidity [kg/kg]
+REAL,     INTENT(IN)   , DIMENSION(klon) :: gamma_cond    ! condensation threshold w.r.t. qsat [-]
+REAL,     INTENT(IN)   , DIMENSION(klon) :: ratqs         ! ratio between the variance of the total water distribution and its average [-]
+LOGICAL,  INTENT(IN)   , DIMENSION(klon) :: keepgoing     ! .TRUE. if a new condensation loop should be computed
+!
+!  Output
+!  NB. those are in INOUT because of the convergence loop on temperature
+!      (in some cases, the values are not re-computed) but the values
+!      are never used explicitely
+!
+REAL,     INTENT(INOUT), DIMENSION(klon) :: cldfra   ! cloud fraction [-]
+REAL,     INTENT(INOUT), DIMENSION(klon) :: qincld   ! cloud-mean in-cloud total specific water [kg/kg]
+REAL,     INTENT(INOUT), DIMENSION(klon) :: qvc      ! gridbox-mean vapor in the cloud [kg/kg]
+!
+! Local
+!
+INTEGER :: i
+REAL :: pdf_std, pdf_k, pdf_delta
+REAL :: pdf_a, pdf_b, pdf_e1, pdf_e2
+!
+!--Loop on klon
+!
+DO i = 1, klon
+
+  !--If a new calculation of the condensation is needed,
+  !--i.e., temperature has not yet converged (or the cloud is
+  !--formed elsewhere)
+  IF (keepgoing(i)) THEN
+
+    pdf_std   = ratqs(i) * qtot(i)
+    pdf_k     = -SQRT( LOG( 1. + (pdf_std / qtot(i))**2 ) )
+    pdf_delta = LOG( qtot(i) / ( gamma_cond(i) * qsat(i) ) )
+    pdf_a     = pdf_delta / ( pdf_k * SQRT(2.) )
+    pdf_b     = pdf_k / (2. * SQRT(2.))
+    pdf_e1    = pdf_a - pdf_b
+    pdf_e1    = SIGN( MIN(ABS(pdf_e1), 5.), pdf_e1 )
+    pdf_e1    = 1. - ERF(pdf_e1)
+    pdf_e2    = pdf_a + pdf_b
+    pdf_e2    = SIGN( MIN(ABS(pdf_e2), 5.), pdf_e2 )
+    pdf_e2    = 1. - ERF(pdf_e2)
+
+
+    IF ( pdf_e1 .LT. eps ) THEN
+      cldfra(i) = 0.
+      qincld(i) = qsat(i)
+      !--AB grid-mean vapor in the cloud - we assume saturation adjustment
+      qvc(i) = 0.
+    ELSE
+      cldfra(i) = 0.5 * pdf_e1
+      qincld(i) = qtot(i) * pdf_e2 / pdf_e1
+      !--AB grid-mean vapor in the cloud - we assume saturation adjustment
+      qvc(i) = qsat(i) * cldfra(i)
+    ENDIF
+
+  ENDIF   ! end keepgoing
+
+ENDDO     ! end loop on i
+END SUBROUTINE condensation_lognormal
+!**********************************************************************************
+
+!**********************************************************************************
+SUBROUTINE condensation_ice_supersat( &
+      klon, dtime, missing_val, pplay, paprsdn, paprsup, &
+      cf_seri, rvc_seri, ratio_qi_qtot, shear, pbl_eps, cell_area, &
+      temp, qtot, qsat, gamma_cond, ratqs, keepgoing, &
+      cldfra, qincld, qvc, issrfra, qissr, dcf_sub, dcf_con, dcf_mix, &
+      dqi_adj, dqi_sub, dqi_con, dqi_mix, dqvc_adj, dqvc_sub, dqvc_con, dqvc_mix, &
+      Tcontr, qcontr, qcontr2, fcontrN, fcontrP, flight_dist, flight_h2o, &
+      dcf_avi, dqi_avi, dqvc_avi)
+
+!----------------------------------------------------------------------
+! This subroutine calculates the formation, evolution and dissipation
+! of clouds, using a process-oriented treatment of the cloud properties
+! (cloud fraction, vapor in the cloud, condensed water in the cloud).
+! It allows for ice supersaturation in cold regions, in clear sky.
+! If ok_unadjusted_clouds, it also allows for sub- and supersaturated
+! cloud water vapors.
+! It also allows for the formation and evolution of condensation trails
+! (contrails) from aviation.
+! Authors: Audran Borella, Etienne Vignon, Olivier Boucher
+! April 2024
+!----------------------------------------------------------------------
+
+USE lmdz_lscp_tools,      ONLY: calc_qsat_ecmwf, calc_gammasat, GAMMAINC
+USE lmdz_lscp_ini,        ONLY: RCPD, RLSTT, RLVTT, RLMLT, RVTMP2, RTT, RD, RG, RV, RPI, EPS_W
+USE lmdz_lscp_ini,        ONLY: eps, temp_nowater, ok_weibull_warm_clouds
+USE lmdz_lscp_ini,        ONLY: ok_unadjusted_clouds, iflag_cloud_sublim_pdf
+USE lmdz_lscp_ini,        ONLY: lunout
+
+USE lmdz_lscp_ini,        ONLY: depo_coef_cirrus, capa_cond_cirrus, &
+                                mu_subl_pdf_lscp, beta_pdf_lscp, temp_thresh_pdf_lscp, &
+                                rhlmid_pdf_lscp, k0_pdf_lscp, kappa_pdf_lscp, rhl0_pdf_lscp, &
+                                coef_mixing_lscp, coef_shear_lscp, & 
+                                chi_mixing_lscp, rho_ice
+
+IMPLICIT NONE
+
+!
+! Input
+!
+INTEGER,  INTENT(IN)                     :: klon          ! number of horizontal grid points
+REAL,     INTENT(IN)                     :: dtime         ! time step [s]
+REAL,     INTENT(IN)                     :: missing_val   ! missing value for output
+!
+REAL,     INTENT(IN)   , DIMENSION(klon) :: pplay         ! layer pressure [Pa]
+REAL,     INTENT(IN)   , DIMENSION(klon) :: paprsdn       ! pressure at the lower interface [Pa]
+REAL,     INTENT(IN)   , DIMENSION(klon) :: paprsup       ! pressure at the upper interface [Pa]
+REAL,     INTENT(IN)   , DIMENSION(klon) :: cf_seri       ! cloud fraction [-]
+REAL,     INTENT(IN)   , DIMENSION(klon) :: rvc_seri      ! gridbox-mean water vapor in cloud [kg/kg]
+REAL,     INTENT(IN)   , DIMENSION(klon) :: ratio_qi_qtot ! specific ice water content to total specific water ratio [-]
+REAL,     INTENT(IN)   , DIMENSION(klon) :: shear         ! vertical shear [s-1]
+REAL,     INTENT(IN)   , DIMENSION(klon) :: pbl_eps       ! 
+REAL,     INTENT(IN)   , DIMENSION(klon) :: cell_area     ! 
+REAL,     INTENT(IN)   , DIMENSION(klon) :: temp          ! temperature [K]
+REAL,     INTENT(IN)   , DIMENSION(klon) :: qtot          ! total specific humidity (without precip) [kg/kg]
+REAL,     INTENT(IN)   , DIMENSION(klon) :: qsat          ! saturation specific humidity [kg/kg]
+REAL,     INTENT(IN)   , DIMENSION(klon) :: gamma_cond    ! condensation threshold w.r.t. qsat [-]
+REAL,     INTENT(INOUT), DIMENSION(klon) :: ratqs         ! ratio between the variance of the total water distribution and its average [-]
+LOGICAL,  INTENT(IN)   , DIMENSION(klon) :: keepgoing     ! .TRUE. if a new condensation loop should be computed
+!
+! Input for aviation
+!
+REAL,     INTENT(IN),    DIMENSION(klon) :: flight_dist   ! 
+REAL,     INTENT(IN),    DIMENSION(klon) :: flight_h2o    ! 
+!
+!  Output
+!  NB. cldfra and qincld should be outputed as cf_seri and qi_seri,
+!      or as tendencies (maybe in the future)
+!  NB. those are in INOUT because of the convergence loop on temperature
+!      (in some cases, the values are not re-computed) but the values
+!      are never used explicitely
+!
+REAL,     INTENT(INOUT), DIMENSION(klon) :: cldfra   ! cloud fraction [-]
+REAL,     INTENT(INOUT), DIMENSION(klon) :: qincld   ! cloud-mean in-cloud total specific water [kg/kg]
+REAL,     INTENT(INOUT), DIMENSION(klon) :: qvc      ! gridbox-mean vapor in the cloud [kg/kg]
+REAL,     INTENT(INOUT), DIMENSION(klon) :: issrfra  ! ISSR fraction [-]
+REAL,     INTENT(INOUT), DIMENSION(klon) :: qissr    ! gridbox-mean ISSR specific water [kg/kg]
+!
+!  Diagnostics for condensation and ice supersaturation
+!  NB. idem for the INOUT
+!
+REAL,     INTENT(INOUT), DIMENSION(klon) :: dcf_sub  ! cloud fraction tendency because of sublimation [s-1]
+REAL,     INTENT(INOUT), DIMENSION(klon) :: dcf_con  ! cloud fraction tendency because of condensation [s-1]
+REAL,     INTENT(INOUT), DIMENSION(klon) :: dcf_mix  ! cloud fraction tendency because of cloud mixing [s-1]
+REAL,     INTENT(INOUT), DIMENSION(klon) :: dqi_adj  ! specific ice content tendency because of temperature adjustment [kg/kg/s]
+REAL,     INTENT(INOUT), DIMENSION(klon) :: dqi_sub  ! specific ice content tendency because of sublimation [kg/kg/s]
+REAL,     INTENT(INOUT), DIMENSION(klon) :: dqi_con  ! specific ice content tendency because of condensation [kg/kg/s]
+REAL,     INTENT(INOUT), DIMENSION(klon) :: dqi_mix  ! specific ice content tendency because of cloud mixing [kg/kg/s]
+REAL,     INTENT(INOUT), DIMENSION(klon) :: dqvc_adj ! specific cloud water vapor tendency because of temperature adjustment [kg/kg/s]
+REAL,     INTENT(INOUT), DIMENSION(klon) :: dqvc_sub ! specific cloud water vapor tendency because of sublimation [kg/kg/s]
+REAL,     INTENT(INOUT), DIMENSION(klon) :: dqvc_con ! specific cloud water vapor tendency because of condensation [kg/kg/s]
+REAL,     INTENT(INOUT), DIMENSION(klon) :: dqvc_mix ! specific cloud water vapor tendency because of cloud mixing [kg/kg/s]
+!
+!  Diagnostics for aviation
+!  NB. idem for the INOUT
+!
+REAL,     INTENT(INOUT), DIMENSION(klon) :: Tcontr   ! critical temperature for contrail formation (T_LM in Schumann 1996, Eq 31 in appendix 2) [K]
+REAL,     INTENT(INOUT), DIMENSION(klon) :: qcontr   ! 
+REAL,     INTENT(INOUT), DIMENSION(klon) :: qcontr2  ! 
+REAL,     INTENT(INOUT), DIMENSION(klon) :: fcontrN  ! 
+REAL,     INTENT(INOUT), DIMENSION(klon) :: fcontrP  ! 
+REAL,     INTENT(INOUT), DIMENSION(klon) :: dcf_avi  ! cloud fraction tendency because of aviation [s-1]
+REAL,     INTENT(INOUT), DIMENSION(klon) :: dqi_avi  ! specific ice content tendency because of aviation [kg/kg/s]
+REAL,     INTENT(INOUT), DIMENSION(klon) :: dqvc_avi ! specific cloud water vapor tendency because of aviation [kg/kg/s]
+!
+! Local
+!
+INTEGER :: i
+LOGICAL :: ok_warm_cloud
+REAL, DIMENSION(klon) :: qcld, qzero
+!
+! for lognormal
+REAL :: pdf_std, pdf_k, pdf_delta
+REAL :: pdf_a, pdf_b, pdf_e1, pdf_e2
+!
+! for unadjusted clouds
+REAL :: qvapincld, qvapincld_new
+REAL :: qiceincld, qice_ratio
+REAL :: pres_sat, kappa
+REAL :: air_thermal_conduct, water_vapor_diff
+REAL :: iwc
+REAL :: iwc_log_inf100, iwc_log_sup100
+REAL :: iwc_inf100, alpha_inf100, coef_inf100
+REAL :: mu_sup100, sigma_sup100, coef_sup100
+REAL :: Dm_ice, rm_ice
+!
+! for sublimation
+REAL :: pdf_alpha
+REAL :: dqt_sub
+!
+! for condensation
+REAL, DIMENSION(klon) :: qsatl, dqsatl
+REAL :: clrfra, qclr, sl_clr, rhl_clr
+REAL :: pdf_ratqs, pdf_skew, pdf_scale, pdf_loc
+REAL :: pdf_x, pdf_y, pdf_T
+REAL :: pdf_e3, pdf_e4
+REAL :: cf_cond, qt_cond, dqt_con
+!
+! for mixing
+REAL, DIMENSION(klon) :: subfra, qsub
+REAL :: dqt_mix_sub, dqt_mix_issr
+REAL :: dcf_mix_sub, dcf_mix_issr
+REAL :: dqvc_mix_sub, dqvc_mix_issr
+REAL :: dqt_mix
+REAL :: a_mix, bovera, N_cld_mix, L_mix
+REAL :: envfra_mix, cldfra_mix
+REAL :: L_shear, shear_fra
+REAL :: sigma_mix, issrfra_mix, subfra_mix, qvapinmix
+!
+! for cell properties
+REAL :: rho, rhodz, dz
+!REAL :: V_cell, M_cell
+!
+! for aviation and cell properties
+!REAL :: dqt_avi
+!REAL :: contrail_fra
+!
+!
+!--more local variables for diagnostics
+!--imported from YOMCST.h 
+!--eps_w = 0.622 = ratio of molecular masses of water and dry air (kg H2O kg air -1)
+!--RCPD = 1004 J kg air−1 K−1 = the isobaric heat capacity of air
+!--values from Schumann, Meteorol Zeitschrift, 1996
+!--EiH2O = 1.25 / 2.24 / 8.94 kg H2O / kg fuel for kerosene / methane / dihydrogen
+!--Qheat = 43.  /  50. / 120. MJ / kg fuel for kerosene / methane / dihydrogen
+!REAL, PARAMETER :: EiH2O=1.25  !--emission index of water vapour for kerosene (kg kg-1)
+!REAL, PARAMETER :: Qheat=43.E6 !--specific combustion heat for kerosene (J kg-1) 
+!REAL, PARAMETER :: eta=0.3     !--average propulsion efficiency of the aircraft
+!--Gcontr is the slope of the mean phase trajectory in the turbulent exhaust field on an absolute 
+!--temperature versus water vapor partial pressure diagram. G has the unit of Pa K−1. Rap et al JGR 2010.
+!REAL :: Gcontr
+!--Tcontr = critical temperature for contrail formation (T_LM in Schumann 1996, Eq 31 in appendix 2) 
+!--qsatliqcontr = e_L(T_LM) in Schumann 1996 but expressed in specific humidity (kg kg humid air-1)
+!REAL :: qsatliqcontr
+
+
+!-----------------------------------------------
+! Initialisations
+!-----------------------------------------------
+
+! Ajout des émissions de H2O dues à l'aviation
+! q is the specific humidity (kg/kg humid air) hence the complicated equation to update q
+! qnew = ( m_humid_air * qold + dm_H2O ) / ( m_humid_air + dm_H2O )  
+!      = ( m_dry_air * qold + dm_h2O * (1-qold) ) / (m_dry_air + dm_H2O * (1-qold) ) 
+! The equation is derived by writing m_humid_air = m_dry_air + m_H2O = m_dry_air / (1-q) 
+! flight_h2O is in kg H2O / s / cell
+!
+!IF (ok_plane_h2o) THEN 
+!  q = ( M_cell*q + flight_h2o(i,k)*dtime*(1.-q) ) / (M_cell + flight_h2o(i,k)*dtime*(1.-q) ) 
+!ENDIF
+
+
+qzero(:) = 0.
+
+!--Calculation of qsat w.r.t. liquid
+CALL calc_qsat_ecmwf(klon, temp, qzero, pplay, RTT, 1, .FALSE., qsatl, dqsatl)
+
+!
+!--Loop on klon
+!
+DO i = 1, klon
+
+  !--If a new calculation of the condensation is needed,
+  !--i.e., temperature has not yet converged (or the cloud is
+  !--formed elsewhere)
+  IF (keepgoing(i)) THEN
+
+    !--If the temperature is higher than the threshold below which
+    !--there is no liquid in the gridbox, we activate the usual scheme
+    !--(generalised lognormal from Bony and Emanuel 2001)
+    !--If ok_weibull_warm_clouds = .TRUE., the Weibull law is used for
+    !--all clouds, and the lognormal scheme is not activated
+    IF ( ( temp(i) .GT. temp_nowater ) .AND. .NOT. ok_weibull_warm_clouds ) THEN
+
+      pdf_std   = ratqs(i) * qtot(i)
+      pdf_k     = -SQRT( LOG( 1. + (pdf_std / qtot(i))**2. ) )
+      pdf_delta = LOG( qtot(i) / ( gamma_cond(i) * qsat(i) ) )
+      pdf_a     = pdf_delta / ( pdf_k * SQRT(2.) )
+      pdf_b     = pdf_k / (2. * SQRT(2.))
+      pdf_e1    = pdf_a - pdf_b
+      pdf_e1    = SIGN( MIN(ABS(pdf_e1), 5.), pdf_e1 )
+      pdf_e1    = 1. - ERF(pdf_e1)
+      pdf_e2    = pdf_a + pdf_b
+      pdf_e2    = SIGN( MIN(ABS(pdf_e2), 5.), pdf_e2 )
+      pdf_e2    = 1. - ERF(pdf_e2)
+
+
+      IF ( pdf_e1 .LT. eps ) THEN
+        cldfra(i) = 0.
+        qincld(i) = qsat(i)
+        qvc(i) = 0.
+      ELSE
+        cldfra(i) = 0.5 * pdf_e1
+        qincld(i) = qtot(i) * pdf_e2 / pdf_e1
+        qvc(i) = qsat(i) * cldfra(i)
+      ENDIF
+
+    !--If the temperature is lower than temp_nowater, we use the new
+    !--condensation scheme that allows for ice supersaturation
+    ELSE
+
+      !--Initialisation
+      IF ( temp(i) .GT. temp_nowater ) THEN
+        !--If the air mass is warm (liquid water can exist),
+        !--all the memory is lost and the scheme becomes statistical,
+        !--i.e., the sublimation and mixing processes are deactivated,
+        !--and the condensation process is slightly adapted
+        !--This can happen only if ok_weibull_warm_clouds = .TRUE.
+        cldfra(i) = 0.
+        qvc(i)    = 0.
+        qcld(i)   = 0.
+        ok_warm_cloud = .TRUE.
+      ELSE
+        !--The following barriers ensure that the traced cloud properties
+        !--are consistent. In some rare cases, i.e. the cloud water vapor
+        !--can be greater than the total water in the gridbox
+        cldfra(i) = MAX(0., MIN(1., cf_seri(i)))
+        qcld(i)   = MAX(0., MIN(qtot(i), ( ratio_qi_qtot(i) + rvc_seri(i) ) * qtot(i))) 
+        qvc(i)    = MAX(0., MIN(qcld(i), rvc_seri(i) * qtot(i)))
+        ok_warm_cloud = .FALSE.
+      ENDIF
+
+      dcf_sub(i)  = 0.
+      dqi_sub(i)  = 0.
+      dqvc_sub(i) = 0.
+      dqi_adj(i)  = 0.
+      dqvc_adj(i) = 0.
+      dcf_con(i)  = 0.
+      dqi_con(i)  = 0.
+      dqvc_con(i) = 0.
+      dcf_mix(i)  = 0.
+      dqi_mix(i)  = 0.
+      dqvc_mix(i) = 0.
+
+      issrfra(i)  = 0.
+      qissr(i)    = 0.
+      subfra(i)   = 0.
+      qsub(i)     = 0.
+
+      !--Initialisation of the cell properties
+      !--Dry density [kg/m3]
+      rho = pplay(i) / temp(i) / RD
+      !--Dry air mass [kg/m2]
+      rhodz = ( paprsdn(i) - paprsup(i) ) / RG
+      !--Cell thickness [m]
+      dz = rhodz / rho
+      !--Cell volume [m3]
+      !V_cell = dz * cell_area(i)
+      !--Cell dry air mass [kg]
+      !M_cell = rhodz * cell_area(i)
+
+
+      IF ( ok_unadjusted_clouds ) THEN
+        !--If ok_unadjusted_clouds is set to TRUE, then the saturation adjustment
+        !--hypothesis is lost, and the vapor in the cloud is purely prognostic.
+        !
+        !--The deposition equation is
+        !-- dmi/dt = alpha*4pi*C*Svi / ( R_v*T/esi/Dv + Ls/ka/T * (Ls/R_v/T - 1) )
+        !--from Lohmann et al. (2016), where
+        !--alpha is the deposition coefficient [-]
+        !--mi is the mass of one ice crystal [kg]
+        !--C is the capacitance of an ice crystal [m]
+        !--Svi is the supersaturation ratio equal to (qvc - qsat)/qsat [-]
+        !--R_v is the specific gas constant for humid air [J/kg/K]
+        !--T is the temperature [K]
+        !--esi is the saturation pressure w.r.t. ice [Pa]
+        !--Dv is the diffusivity of water vapor [m2/s]
+        !--Ls is the specific latent heat of sublimation [J/kg/K]
+        !--ka is the thermal conductivity of dry air [J/m/s/K]
+        !
+        !--alpha is a coefficient to take into account the fact that during deposition, a water
+        !--molecule cannot join the crystal from everywhere, it must do so that the crystal stays
+        !--coherent (with the same structure). It has no impact for sublimation.
+        !--We fix alpha = depo_coef_cirrus (=0.5 by default following Lohmann et al. (2016))
+        !--during deposition, and alpha = 1. during sublimation.
+        !--The capacitance of the ice crystals is proportional to a parameter capa_cond_cirrus
+        !-- C = capa_cond_cirrus * rm_ice
+        !
+        !--We have qice = Nice * mi, where Nice is the ice crystal
+        !--number concentration per kg of moist air
+        !--HYPOTHESIS 1: the ice crystals are spherical, therefore
+        !-- mi = 4/3 * pi * rm_ice**3 * rho_ice
+        !--HYPOTHESIS 2: the ice crystals are monodisperse with the
+        !--initial radius rm_ice_0.
+        !--NB. this is notably different than the assumption
+        !--of a distributed qice in the cloud made in the sublimation process;
+        !--should it be consistent?
+        !
+        !--As the deposition process does not create new ice crystals,
+        !--and because we assume a same rm_ice value for all crystals
+        !--therefore the sublimation process does not destroy ice crystals
+        !--(or, in a limit case, it destroys all ice crystals), then
+        !--Nice is a constant during the sublimation/deposition process.
+        !-- dmi = dqi, et Nice = qi_0 / ( 4/3 RPI rm_ice_0**3 rho_ice )
+        !
+        !--The deposition equation then reads:
+        !-- dqi/dt = alpha*4pi*capa_cond_cirrus*rm_ice*(qvc-qsat)/qsat / ( R_v*T/esi/Dv + Ls/ka/T * (Ls/R_v/T - 1) ) * Nice
+        !-- dqi/dt = alpha*4pi*capa_cond_cirrus* (qi / qi_0)**(1/3) *rm_ice_0*(qvc-qsat)/qsat &
+        !--             / ( R_v*T/esi/Dv + Ls/ka/T * (Ls*R_v/T - 1) ) &
+        !--                         * qi_0 / ( 4/3 RPI rm_ice_0**3 rho_ice )
+        !-- dqi/dt = qi**(1/3) * (qvc - qsat) * qi_0**(2/3) &
+        !--  *alpha/qsat*capa_cond_cirrus/ (R_v*T/esi/Dv + Ls/ka/T*(Ls*R_v/T - 1)) / ( 1/3 rm_ice_0**2 rho_ice )
+        !--and we have
+        !-- dqvc/dt = - qi**(1/3) * (qvc - qsat) / kappa * alpha * qi_0**(2/3) / rm_ice_0**2
+        !-- dqi/dt  =   qi**(1/3) * (qvc - qsat) / kappa * alpha * qi_0**(2/3) / rm_ice_0**2
+        !--where kappa = 1/3*rho_ice/capa_cond_cirrus*qsat*(R_v*T/esi/Dv + Ls/ka/T*(Ls/R_v/T - 1))
+        !
+        !--This system of equations can be resolved with an exact
+        !--explicit numerical integration, having one variable resolved
+        !--explicitly, the other exactly. The exactly resolved variable is
+        !--the one decreasing, so it is qvc if the process is
+        !--condensation, qi if it is sublimation.
+        !
+        !--kappa is computed as an initialisation constant, as it depends only
+        !--on temperature and other pre-computed values
+        pres_sat = qsat(i) / ( EPS_W + ( 1. - EPS_W ) * qsat(i) ) * pplay(i)
+        !--This formula for air thermal conductivity comes from Beard and Pruppacher (1971)
+        air_thermal_conduct = ( 5.69 + 0.017 * ( temp(i) - RTT ) ) * 1.e-3 * 4.184
+        !--This formula for water vapor diffusivity comes from Hall and Pruppacher (1976)
+        water_vapor_diff = 0.211 * ( temp(i) / RTT )**1.94 * ( 101325. / pplay(i) ) * 1.e-4
+        kappa = 1. / 3. * rho_ice / capa_cond_cirrus * qsat(i) &
+              * ( RV * temp(i) / water_vapor_diff / pres_sat &
+                + RLSTT / air_thermal_conduct / temp(i) * ( RLSTT / RV / temp(i) - 1. ) )
+        !--NB. the greater kappa, the lower the efficiency of the deposition/sublimation process
+      ENDIF
+
+
+      !-------------------------------------------------------------------
+      !--    SUBLIMATION OF ICE AND DEPOSITION OF VAPOR IN THE CLOUD    --
+      !-------------------------------------------------------------------
+      
+      !--If there is a cloud
+      IF ( cldfra(i) .GT. eps ) THEN
+        
+        qvapincld = qvc(i) / cldfra(i)
+        qiceincld = ( qcld(i) / cldfra(i) - qvapincld )
+        
+        !--If the ice water content is too low, the cloud is purely sublimated
+        !--Most probably, we advected a cloud with no ice water content (possible
+        !--if the entire cloud precipited for example)
+        IF ( qiceincld .LT. eps ) THEN
+          dcf_sub(i) = - cldfra(i)
+          dqvc_sub(i) = - qvc(i)
+          dqi_sub(i) = - ( qcld(i) - qvc(i) )
+
+          cldfra(i) = 0.
+          qcld(i) = 0.
+          qvc(i) = 0.
+
+        !--Else, the cloud is adjusted and sublimated
+        ELSE
+
+          !--The vapor in cloud cannot be higher than the
+          !--condensation threshold
+          qvapincld = MIN(qvapincld, gamma_cond(i) * qsat(i))
+          qiceincld = ( qcld(i) / cldfra(i) - qvapincld )
+
+          IF ( ok_unadjusted_clouds ) THEN
+            !--Here, the initial vapor in the cloud is qvapincld, and we compute
+            !--the new vapor qvapincld_new
+
+            !--rm_ice formula from McFarquhar and Heymsfield (1997)
+            iwc = qiceincld * rho * 1e3
+            iwc_inf100 = MIN(iwc, 0.252 * iwc**0.837)
+            iwc_log_inf100 = LOG10( MAX(eps, iwc_inf100) )
+            iwc_log_sup100 = LOG10( MAX(eps, iwc - iwc_inf100) )
+
+            alpha_inf100 = - 4.99E-3 - 0.0494 * iwc_log_inf100
+            coef_inf100 = iwc_inf100 * alpha_inf100**3. / 120.
+
+            mu_sup100 = ( 5.2 + 0.0013 * ( temp(i) - RTT ) ) &
+                      + ( 0.026 - 1.2E-3 * ( temp(i) - RTT ) ) * iwc_log_sup100
+            sigma_sup100 = ( 0.47 + 2.1E-3 * ( temp(i) - RTT ) ) &
+                         + ( 0.018 - 2.1E-4 * ( temp(i) - RTT ) ) * iwc_log_sup100
+            coef_sup100 = ( iwc - iwc_inf100 ) / EXP( 3 * mu_sup100 + 4.5 * sigma_sup100**2. )
+
+            Dm_ice = ( 2. / alpha_inf100 * coef_inf100 + EXP( mu_sup100 + 0.5 * sigma_sup100**2. ) &
+                   * coef_sup100 ) / ( coef_inf100 + coef_sup100 )
+            rm_ice = Dm_ice / 2. * 1.E-6
+
+            IF ( qvapincld .GE. qsat(i) ) THEN
+              !--If the cloud is initially supersaturated
+              !--Exact explicit integration (qvc exact, qice explicit)
+              qvapincld_new = qsat(i) + ( qvapincld - qsat(i) ) &
+                            * EXP( - depo_coef_cirrus * dtime * qiceincld / kappa / rm_ice**2. )
+            ELSE
+              !--If the cloud is initially subsaturated
+              !--Exact explicit integration (qice exact, qvc explicit)
+              !--The barrier is set so that the resulting vapor in cloud
+              !--cannot be greater than qsat
+              !--qice_ratio is the ratio between the new ice content and
+              !--the old one, it is comprised between 0 and 1
+              qice_ratio = ( 1. - 2. / 3. / kappa / rm_ice**2. * dtime * ( qsat(i) - qvapincld ) )
+
+              IF ( qice_ratio .LT. 0. ) THEN
+                !--If all the ice has been sublimated, we sublimate
+                !--completely the cloud and do not activate the sublimation
+                !--process
+                !--Tendencies and diagnostics
+                dcf_sub(i) = - cldfra(i)
+                dqvc_sub(i) = - qvc(i)
+                dqi_sub(i) = - ( qcld(i) - qvc(i) )
+
+                cldfra(i) = 0.
+                qcld(i) = 0.
+                qvc(i) = 0.
+
+                !--The new vapor in cloud is set to 0 so that the
+                !--sublimation process does not activate
+                qvapincld_new = 0.
+              ELSE
+                !--Else, the sublimation process is activated with the
+                !--diagnosed new cloud water vapor
+                !--The new vapor in the cloud is increased with the
+                !--sublimated ice
+                qvapincld_new = qvapincld + qiceincld * ( 1. - qice_ratio**(3./2.) )
+                !--The new vapor in the cloud cannot be greater than qsat
+                qvapincld_new = MIN(qvapincld_new, qsat(i))
+              ENDIF ! qice_ratio .LT. 0.
+            ENDIF ! qvapincld .GT. qsat(i)
+          ELSE
+            !--We keep the saturation adjustment hypothesis, and the vapor in the
+            !--cloud is set equal to the saturation vapor
+            qvapincld_new = qsat(i)
+          ENDIF ! ok_unadjusted_clouds
+          
+          !--Adjustment of the IWC to the new vapor in cloud
+          !--(this can be either positive or negative)
+          dqvc_adj(i) = ( qvapincld_new * cldfra(i) - qvc(i) )
+          dqi_adj(i) = - dqvc_adj(i)
+
+          !--Add tendencies
+          !--The vapor in the cloud is updated, but not qcld as it is constant
+          !--through this process, as well as cldfra which is unmodified
+          qvc(i) = MAX(0., MIN(qcld(i), qvc(i) + dqvc_adj(i)))
+          
+
+          !------------------------------------
+          !--    DISSIPATION OF THE CLOUD    --
+          !------------------------------------
+
+          !--If the vapor in cloud is below vapor needed for the cloud to survive
+          IF ( qvapincld .LT. qvapincld_new ) THEN
+            !--Sublimation of the subsaturated cloud
+            !--iflag_cloud_sublim_pdf selects the PDF of the ice water content
+            !--to use.
+            !--iflag = 1 --> uniform distribution
+            !--iflag = 2 --> exponential distribution
+            !--iflag = 3 --> gamma distribution (Karcher et al 2018)
+
+            IF ( iflag_cloud_sublim_pdf .EQ. 1 ) THEN
+              !--Uniform distribution starting at qvapincld
+              pdf_e1 = 1. / ( 2. * qiceincld )
+
+              dcf_sub(i) = - cldfra(i) * ( qvapincld_new - qvapincld ) * pdf_e1
+              dqt_sub    = - cldfra(i) * ( qvapincld_new**2. - qvapincld**2. ) &
+                                       * pdf_e1 / 2.
+
+            ELSEIF ( iflag_cloud_sublim_pdf .EQ. 2 ) THEN
+              !--Exponential distribution starting at qvapincld
+              pdf_alpha = 1. / qiceincld
+              pdf_e1 = EXP( - pdf_alpha * ( qvapincld_new - qvapincld ) )
+
+              dcf_sub(i) = - cldfra(i) * ( 1. - pdf_e1 )
+              dqt_sub    = - cldfra(i) * ( ( 1. - pdf_e1 ) / pdf_alpha &
+                                       + qvapincld - qvapincld_new * pdf_e1 )
+
+            ELSEIF ( iflag_cloud_sublim_pdf .GE. 3 ) THEN
+              !--Gamma distribution starting at qvapincld
+              pdf_alpha = ( mu_subl_pdf_lscp + 1. ) / qiceincld
+              pdf_y = pdf_alpha * ( qvapincld_new - qvapincld )
+              pdf_e1 = GAMMAINC ( mu_subl_pdf_lscp + 1. , pdf_y )
+              pdf_e2 = GAMMAINC ( mu_subl_pdf_lscp + 2. , pdf_y )
+
+              dcf_sub(i) = - cldfra(i) * pdf_e1
+              dqt_sub    = - cldfra(i) * ( pdf_e2 / pdf_alpha + qvapincld * pdf_e1 )
+            ENDIF
+
+            !--Tendencies and diagnostics
+            dqvc_sub(i) = dqt_sub
+
+            !--Add tendencies
+            cldfra(i) = MAX(0., cldfra(i) + dcf_sub(i))
+            qcld(i)   = MAX(0., qcld(i) + dqt_sub)
+            qvc(i)    = MAX(0., qvc(i) + dqvc_sub(i))
+
+          ENDIF ! qvapincld .LT. qvapincld_new
+
+        ENDIF   ! qiceincld .LT. eps
+      ENDIF ! cldfra(i) .GT. eps
+
+
+      !--------------------------------------------------------------------------
+      !--    CONDENSATION AND DIAGNOTICS OF SUB- AND SUPERSATURATED REGIONS    --
+      !--------------------------------------------------------------------------
+      !--This section relies on a distribution of water in the clear-sky region of
+      !--the mesh.
+
+      !--If there is a clear-sky region
+      IF ( ( 1. - cldfra(i) ) .GT. eps ) THEN
+
+        !--Water quantity in the clear-sky + potential liquid cloud (gridbox average)
+        qclr = qtot(i) - qcld(i)
+
+        !--New PDF
+        rhl_clr = qclr / ( 1. - cldfra(i) ) / qsatl(i) * 100.
+        rhl_clr = MIN(rhl_clr, 2. * rhlmid_pdf_lscp)
+
+        !--Calculation of the properties of the PDF
+        !--Parameterization from IAGOS observations
+        !--pdf_e1 and pdf_e2 will be reused below
+
+        !--Coefficient for standard deviation:
+        !--  tuning coef * (clear sky area**0.25) * (function of temperature)
+        pdf_e1 = beta_pdf_lscp &
+               * ( ( 1. - cldfra(i) ) * cell_area(i) )**( 1. / 4. ) &
+               * MAX( temp(i) - temp_thresh_pdf_lscp, 0. )
+        IF ( rhl_clr .GT. rhlmid_pdf_lscp ) THEN
+          pdf_std = pdf_e1 * ( 2. * rhlmid_pdf_lscp - rhl_clr ) / rhlmid_pdf_lscp
+        ELSE
+          pdf_std = pdf_e1 * rhl_clr / rhlmid_pdf_lscp
+        ENDIF
+        pdf_e3 = k0_pdf_lscp + kappa_pdf_lscp * MAX( temp_nowater - temp(i), 0. )
+        pdf_alpha = EXP( rhl_clr / rhl0_pdf_lscp ) * pdf_e3
+
+        pdf_e2 = GAMMA(1. + 1. / pdf_alpha)
+        pdf_scale = MAX(eps, pdf_std / SQRT( GAMMA(1. + 2. / pdf_alpha) - pdf_e2**2. ))
+        pdf_loc = rhl_clr - pdf_scale * pdf_e2
+
+        !--Diagnostics of ratqs
+        ratqs(i) = pdf_std / ( qclr / ( 1. - cldfra(i) ) / qsatl(i) * 100. )
+
+        !--Calculation of the newly condensed water and fraction (pronostic)
+        !--Integration of the clear sky PDF between gamma_cond*qsat and +inf
+        !--NB. the calculated values are clear-sky averaged
+
+        pdf_x = gamma_cond(i) * qsat(i) / qsatl(i) * 100.
+        pdf_y = ( MAX( pdf_x - pdf_loc, 0. ) / pdf_scale ) ** pdf_alpha
+        pdf_e3 = GAMMAINC ( 1. + 1. / pdf_alpha , pdf_y )
+        pdf_e3 = pdf_scale * ( 1. - pdf_e3 ) * pdf_e2
+        cf_cond = EXP( - pdf_y )
+        qt_cond = ( pdf_e3 + pdf_loc * cf_cond ) * qsatl(i) / 100.
+
+        IF ( ok_warm_cloud ) THEN
+          !--If the statistical scheme is activated, the calculated increase is equal
+          !--to the cloud fraction, we assume saturation adjustment, and the
+          !--condensation process stops
+          cldfra(i) = cf_cond
+          qcld(i) = qt_cond
+          qvc(i) = cldfra(i) * qsat(i)
+
+        ELSEIF ( cf_cond .GT. eps ) THEN
+
+          dcf_con(i) = ( 1. - cldfra(i) ) * cf_cond
+          dqt_con = ( 1. - cldfra(i) ) * qt_cond
+          
+          !--Barriers
+          dcf_con(i) = MIN(dcf_con(i), 1. - cldfra(i))
+          dqt_con = MIN(dqt_con, qclr)
+
+
+          IF ( ok_unadjusted_clouds ) THEN
+            !--Here, the initial vapor in the cloud is gamma_cond*qsat, and we compute
+            !--the new vapor qvapincld. The timestep is divided by two because we do not
+            !--know when the condensation occurs
+            qvapincld = gamma_cond(i) * qsat(i)
+            qiceincld = dqt_con / dcf_con(i) - gamma_cond(i) * qsat(i)
+
+            !--rm_ice formula from McFarquhar and Heymsfield (1997)
+            iwc = qiceincld * rho * 1e3
+            iwc_inf100 = MIN(iwc, 0.252 * iwc**0.837)
+            iwc_log_inf100 = LOG10( MAX(eps, iwc_inf100) )
+            iwc_log_sup100 = LOG10( MAX(eps, iwc - iwc_inf100) )
+
+            alpha_inf100 = - 4.99E-3 - 0.0494 * iwc_log_inf100
+            coef_inf100 = iwc_inf100 * alpha_inf100**3. / 120.
+
+            mu_sup100 = ( 5.2 + 0.0013 * ( temp(i) - RTT ) ) &
+                      + ( 0.026 - 1.2E-3 * ( temp(i) - RTT ) ) * iwc_log_sup100
+            sigma_sup100 = ( 0.47 + 2.1E-3 * ( temp(i) - RTT ) ) &
+                         + ( 0.018 - 2.1E-4 * ( temp(i) - RTT ) ) * iwc_log_sup100
+            coef_sup100 = ( iwc - iwc_inf100 ) / EXP( 3. * mu_sup100 + 4.5 * sigma_sup100**2. )
+
+            Dm_ice = ( 2. / alpha_inf100 * coef_inf100 + EXP( mu_sup100 + 0.5 * sigma_sup100**2. ) &
+                   * coef_sup100 ) / ( coef_inf100 + coef_sup100 )
+            rm_ice = Dm_ice / 2. * 1.E-6
+            !--As qvapincld is necessarily greater than qsat, we only
+            !--use the exact explicit formulation
+            !--Exact explicit version
+            qvapincld = qsat(i) + ( qvapincld - qsat(i) ) &
+                      * EXP( - depo_coef_cirrus * dtime / 2. * qiceincld / kappa / rm_ice**2. )
+          ELSE
+            !--We keep the saturation adjustment hypothesis, and the vapor in the
+            !--newly formed cloud is set equal to the saturation vapor.
+            qvapincld = qsat(i)
+          ENDIF
+
+          !--Tendency on cloud vapor and diagnostic
+          dqvc_con(i) = qvapincld * dcf_con(i)
+          dqi_con(i) = dqt_con - dqvc_con(i)
+
+          !--Note that the tendencies are NOT added because they are
+          !--added after the mixing process. In the following, the gridbox fraction is
+          !-- 1. - dcf_con(i), and the total water in the gridbox is
+          !-- qtot(i) - dqi_con(i) - dqvc_con(i)
+
+        ENDIF ! ok_warm_cloud, cf_cond .GT. eps
+      ENDIF ! ( 1. - cldfra(i) ) .GT. eps
+
+      !--If there is still clear sky, we diagnose the ISSR
+      !--We recalculte the PDF properties (after the condensation process)
+      IF ( ( ( 1. - dcf_con(i) - cldfra(i) ) .GT. eps ) .AND. .NOT. ok_warm_cloud ) THEN
+        !--Water quantity in the clear-sky + potential liquid cloud (gridbox average)
+        qclr = qtot(i) - dqi_con(i) - dqvc_con(i) - qcld(i)
+
+        !--New PDF
+        rhl_clr = qclr / ( 1. - dcf_con(i) - cldfra(i) ) / qsatl(i) * 100.
+        rhl_clr = MIN(rhl_clr, 2. * rhlmid_pdf_lscp)
+
+        !--Calculation of the properties of the PDF
+        !--Parameterization from IAGOS observations
+        !--pdf_e1 and pdf_e2 will be reused below
+
+        !--Coefficient for standard deviation:
+        !--  tuning coef * (clear sky area**0.25) * (function of temperature)
+        pdf_e1 = beta_pdf_lscp &
+               * ( ( 1. - dcf_con(i) - cldfra(i) ) * cell_area(i) )**( 1. / 4. ) &
+               * MAX( temp(i) - temp_thresh_pdf_lscp, 0. )
+        IF ( rhl_clr .GT. rhlmid_pdf_lscp ) THEN
+          pdf_std = pdf_e1 * ( 2. * rhlmid_pdf_lscp - rhl_clr ) / rhlmid_pdf_lscp
+        ELSE
+          pdf_std = pdf_e1 * rhl_clr / rhlmid_pdf_lscp
+        ENDIF
+        pdf_e3 = k0_pdf_lscp + kappa_pdf_lscp * MAX( temp_nowater - temp(i), 0. )
+        pdf_alpha = EXP( rhl_clr / rhl0_pdf_lscp ) * pdf_e3
+
+        pdf_e2 = GAMMA(1. + 1. / pdf_alpha)
+        pdf_scale = MAX(eps, pdf_std / SQRT( GAMMA(1. + 2. / pdf_alpha) - pdf_e2**2. ))
+        pdf_loc = rhl_clr - pdf_scale * pdf_e2
+
+        !--We then calculate the part that is greater than qsat
+        !--and consider it supersaturated
+
+        pdf_x = qsat(i) / qsatl(i) * 100.
+        pdf_y = ( MAX( pdf_x - pdf_loc, 0. ) / pdf_scale ) ** pdf_alpha
+        pdf_e3 = GAMMAINC ( 1. + 1. / pdf_alpha , pdf_y )
+        pdf_e3 = pdf_scale * ( 1. - pdf_e3 ) * pdf_e2
+        issrfra(i) = EXP( - pdf_y ) * ( 1. - dcf_con(i) - cldfra(i) )
+        qissr(i) = ( pdf_e3 * ( 1. - dcf_con(i) - cldfra(i) ) + pdf_loc * issrfra(i) ) * qsatl(i) / 100.
+      ENDIF
+
+      !--Calculation of the subsaturated clear sky fraction and water
+      subfra(i) = 1. - dcf_con(i) - cldfra(i) - issrfra(i)
+      qsub(i) = qtot(i) - dqi_con(i) - dqvc_con(i) - qcld(i) - qissr(i)
+
+
+      !--------------------------------------
+      !--           CLOUD MIXING           --
+      !--------------------------------------
+      !--This process mixes the cloud with its surroundings: the subsaturated clear sky,
+      !--and the supersaturated clear sky. It is activated if the cloud is big enough,
+      !--but does not cover the entire mesh.
+      !
+      IF ( ( cldfra(i) .LT. ( 1. - dcf_con(i) - eps ) ) .AND. ( cldfra(i) .GT. eps ) &
+           .AND. .NOT. ok_warm_cloud ) THEN
+
+        !--Initialisation
+        dcf_mix_sub   = 0.
+        dqt_mix_sub   = 0.
+        dqvc_mix_sub  = 0.
+        dcf_mix_issr  = 0.
+        dqt_mix_issr  = 0.
+        dqvc_mix_issr = 0.
+
+
+        !-- PART 1 - TURBULENT DIFFUSION
+
+        !--Clouds within the mesh are assumed to be ellipses. The length of the
+        !--semi-major axis is a and the length of the semi-minor axis is b.
+        !--N_cld_mix is the number of clouds within the mesh, and
+        !--clouds_perim is the total perimeter of the clouds within the mesh,
+        !--not considering interfaces with other meshes (only the interfaces with clear
+        !--sky are taken into account).
+        !--
+        !--The area of each cloud is A = a * b * RPI,
+        !--and the perimeter of each cloud is
+        !-- P ~= RPI * ( 3 * (a + b) - SQRT( (3 * a + b) * (a + 3 * b) ) )
+        !--
+        !--With cell_area the area of the cell, we have:
+        !-- cldfra = A * N_cld_mix / cell_area
+        !-- clouds_perim = P * N_cld_mix
+        !--
+        !--We assume that the ratio between b and a is a function of
+        !--cldfra such that it is 1 for cldfra = 1 and it is low for little cldfra, because
+        !--if cldfra is low the clouds are linear, and if cldfra is high, the clouds
+        !--are spherical.
+        !-- b / a = bovera = MAX(0.1, cldfra)
+        bovera = MAX(0.1, cldfra(i))
+        !--The clouds perimeter is imposed using the formula from Morcrette 2012,
+        !--based on observations.
+        !-- clouds_perim_normalized = alpha * cldfra * ( 1. - cldfra ) = clouds_perim / ( norm_constant * cell_area )
+        !--
+        !--With all this, we have
+        !-- a = SQRT( cell_area * cldfra / ( b / a * N_cld_mix * RPI ) )
+        !-- P = RPI * a * ( 3. * ( 1. + b / a ) - SQRT( (3. + b / a) * (1. + 3. * b / a) ) )
+        !--and therefore, using the perimeter
+        !-- alpha * cldfra * ( 1. - cldfra ) * norm_constant * cell_area
+        !--             = N_cld_mix * RPI &
+        !--             * SQRT( cell_area * cldfra / ( b / a * N_cld_mix * RPI ) ) &
+        !--             * ( 3. * ( 1. + b / a ) - SQRT( (3. + b / a) * (1. + 3. * b / a) ) )
+        !--and finally
+        N_cld_mix = coef_mixing_lscp * cldfra(i) * ( 1. - dcf_con(i) - cldfra(i) )**2. &
+                  * cell_area(i) * ( 1. - dcf_con(i) ) * bovera / RPI &
+                  / ( 3. * (1. + bovera) - SQRT( (3. + bovera) * (1. + 3. * bovera) ) )**2.
+        !--where coef_mix_lscp = ( alpha * norm_constant )**2.
+        !--N_cld_mix is the number of clouds in contact with clear sky, and can be non-integer
+        !--In particular, it is 0 if cldfra = 1
+        a_mix = SQRT( cell_area(i) * ( 1. - dcf_con(i) ) * cldfra(i) / bovera / N_cld_mix / RPI )
+
+        !--The time required for turbulent diffusion to homogenize a region of size
+        !--L_mix is defined as (L_mix**2./tke_dissip)**(1./3.) (Pope, 2000; Field et al., 2014)
+        !--We compute L_mix and assume that the cloud is mixed over this length
+        L_mix = SQRT( dtime**3. * pbl_eps(i) )
+        !--The mixing length cannot be greater than the semi-minor axis. In this case,
+        !--the entire cloud is mixed.
+        L_mix = MIN(L_mix, a_mix * bovera)
+
+        !--The fraction of clear sky mixed is
+        !-- N_cld_mix * ( (a + L_mix) * (b + L_mix) - a * b ) * RPI / cell_area
+        envfra_mix = N_cld_mix * RPI / cell_area(i) / ( 1. - dcf_con(i) ) &
+                   * ( a_mix * ( 1. + bovera ) * L_mix + L_mix**2. )
+        !--The fraction of cloudy sky mixed is
+        !-- N_cld_mix * ( a * b - (a - L_mix) * (b - L_mix) ) * RPI / cell_area
+        cldfra_mix = N_cld_mix * RPI / cell_area(i) / ( 1. - dcf_con(i) ) &
+                   * ( a_mix * ( 1. + bovera ) * L_mix - L_mix**2. )
+
+
+        !-- PART 2 - SHEARING
+
+        !--The clouds are then sheared. We keep the shape and number
+        !--assumptions from before. The clouds are sheared along their
+        !--semi-major axis (a_mix), on the entire cell heigh dz.
+        !--The increase in size is
+        L_shear = coef_shear_lscp * shear(i) * dz * dtime
+        !--therefore, the total increase in fraction is
+        !-- N_cld_mix * ( (a + L_shear) * b - a * b ) * RPI / 2. / cell_area
+        shear_fra = RPI * L_shear * a_mix * bovera / 2. * N_cld_mix &
+                  / cell_area(i) / ( 1. - dcf_con(i) )
+        !--and the environment and cloud mixed fractions are the same,
+        !--which we add to the previous calculated mixed fractions.
+        !--We therefore assume that the sheared clouds and the turbulent
+        !--mixed clouds are different.
+        envfra_mix = envfra_mix + shear_fra
+        cldfra_mix = cldfra_mix + shear_fra
+
+
+        !-- PART 3 - CALCULATION OF THE MIXING PROPERTIES
+
+        !--The environment fraction is allocated to subsaturated sky or supersaturated sky,
+        !--according to the factor sigma_mix. This is computed as the ratio of the
+        !--subsaturated sky fraction to the environment fraction, corrected by a factor
+        !--chi_mixing_lscp for the supersaturated part. If chi is greater than 1, the
+        !--supersaturated sky is favoured. Physically, this means that it is more likely
+        !--to have supersaturated sky around the cloud than subsaturated sky.
+        sigma_mix = subfra(i) / ( subfra(i) + chi_mixing_lscp * issrfra(i) )
+        subfra_mix = MIN( sigma_mix * envfra_mix, subfra(i) )
+        issrfra_mix = MIN( ( 1. - sigma_mix ) * envfra_mix, issrfra(i) )
+        cldfra_mix = MIN( cldfra_mix, cldfra(i) )
+
+        !--First, we mix the subsaturated sky (subfra_mix) and the cloud close
+        !--to this fraction (sigma_mix * cldfra_mix).
+        IF ( subfra(i) .GT. eps ) THEN
+
+          IF ( ok_unadjusted_clouds ) THEN
+            !--The subsaturated air is simply added to the cloud,
+            !--with the corresponding cloud fraction
+            !--If the cloud is too subsaturated, the sublimation process
+            !--activated in the following timestep will reduce the cloud
+            !--fraction
+            dcf_mix_sub = subfra_mix
+            dqt_mix_sub = dcf_mix_sub * qsub(i) / subfra(i)
+            dqvc_mix_sub = dqt_mix_sub
+
+          ELSE
+            !--We compute the total humidity in the mixed air, which
+            !--can be either sub- or supersaturated.
+            qvapinmix = ( qsub(i) * subfra_mix / subfra(i) &
+                      + qcld(i) * cldfra_mix * sigma_mix / cldfra(i) ) &
+                      / ( subfra_mix + cldfra_mix * sigma_mix )
+
+            IF ( qvapinmix .GT. qsat(i) ) THEN
+              !--If the mixed air is supersaturated, we condense the subsaturated
+              !--region which was mixed.
+              dcf_mix_sub = subfra_mix
+              dqt_mix_sub = dcf_mix_sub * qsub(i) / subfra(i)
+              dqvc_mix_sub = dcf_mix_sub * qsat(i)
+            ELSE
+              !--Else, we sublimate the cloud which was mixed.
+              dcf_mix_sub = - sigma_mix * cldfra_mix
+              dqt_mix_sub = dcf_mix_sub * qcld(i) / cldfra(i)
+              dqvc_mix_sub = dcf_mix_sub * qsat(i)
+            ENDIF
+          ENDIF ! ok_unadjusted_clouds
+        ENDIF ! subfra .GT. eps
+   
+        !--We then mix the supersaturated sky (issrfra_mix) and the cloud,
+        !--for which the mixed air is always supersatured, therefore
+        !--the cloud necessarily expands
+        IF ( issrfra(i) .GT. eps ) THEN
+
+          IF ( ok_unadjusted_clouds ) THEN
+            !--The ice supersaturated air is simply added to the
+            !--cloud, and supersaturated vapor will be deposited on the
+            !--cloud ice crystals by the deposition process in the
+            !--following timestep
+            dcf_mix_issr = issrfra_mix
+            dqt_mix_issr = dcf_mix_issr * qissr(i) / issrfra(i)
+            dqvc_mix_issr = dqt_mix_issr
+          ELSE
+            !--In this case, the additionnal vapor condenses
+            dcf_mix_issr = issrfra_mix
+            dqt_mix_issr = dcf_mix_issr * qissr(i) / issrfra(i)
+            dqvc_mix_issr = dcf_mix_issr * qsat(i)
+          ENDIF ! ok_unadjusted_clouds
+
+
+        ENDIF ! issrfra .GT. eps
+
+        !--Sum up the tendencies from subsaturated sky and supersaturated sky
+        dcf_mix(i)  = dcf_mix_sub  + dcf_mix_issr
+        dqt_mix     = dqt_mix_sub  + dqt_mix_issr
+        dqvc_mix(i) = dqvc_mix_sub + dqvc_mix_issr
+        dqi_mix(i)  = dqt_mix - dqvc_mix(i)
+
+        !--Add tendencies
+        issrfra(i) = MAX(0., issrfra(i) - dcf_mix_issr)
+        qissr(i)   = MAX(0., qissr(i) - dqt_mix_issr)
+        cldfra(i)  = MAX(0., MIN(1. - dcf_con(i), cldfra(i) + dcf_mix(i)))
+        qcld(i)    = MAX(0., MIN(qtot(i) - dqi_con(i) - dqvc_con(i), qcld(i) + dqt_mix))
+        qvc(i)     = MAX(0., MIN(qcld(i), qvc(i) + dqvc_mix(i)))
+
+      ENDIF ! ( ( cldfra(i) .LT. ( 1. - dcf_con(i) - eps ) ) .AND. ( cldfra(i) .GT. eps ) )
+
+      !--Finally, we add the tendencies of condensation
+      cldfra(i) = MIN(1., cldfra(i) + dcf_con(i))
+      qcld(i)   = MIN(qtot(i), qcld(i) + dqvc_con(i) + dqi_con(i))
+      qvc(i)    = MIN(qcld(i), qvc(i) + dqvc_con(i))
+
+
+      !----------------------------------------
+      !--       CONTRAILS AND AVIATION       --
+      !----------------------------------------
+
+      !--Add a source of cirrus from aviation contrails
+      !IF ( ok_plane_contrail ) THEN
+      !  dcf_avi(i) = 0.
+      !  dqi_avi(i) = 0.
+      !  dqvc_avi(i) = 0.
+      !  ! TODO implement ok_unadjusted_clouds
+      !  IF ( issrfra(i) .GT. eps ) THEN
+      !    contrail_fra = MIN(1., flight_m(i,k) * dtime * contrail_cross_section / V_cell)
+      !    dcf_avi(i) = issrfra(i) * contrail_fra
+      !    dqt_avi = dcf_avi(i) * qissr(i) / issrfra(i)
+      !    dqvc_avi(i) = qsat(i) * dcf_avi(i)
+      !    
+      !    !--Add tendencies
+      !    cldfra(i) = cldfra(i) + dcf_avi(i)
+      !    issrfra(i) = issrfra(i) - dcf_avi(i)
+      !    qcld(i) = qcld(i) + dqt_avi
+      !    qvc(i) = qvc(i) + dqvc_avi(i)
+      !    qissr(i) = qissr(i) - dqt_avi
+
+      !    !--Diagnostics
+      !    dqi_avi(i) = dqt_avi - qsat(i) * dcf_avi(i)
+      !  ENDIF
+      !  dcf_avi(i)  = dcf_avi(i)  / dtime
+      !  dqi_avi(i)  = dqi_avi(i)  / dtime
+      !  dqvc_avi(i) = dqvc_avi(i) / dtime
+      !ENDIF
+
+
+
+      !-------------------------------------------
+      !--       FINAL BARRIERS AND OUTPUTS      --
+      !-------------------------------------------
+
+      IF ( cldfra(i) .LT. eps ) THEN
+        !--If the cloud is too small, it is sublimated.
+        cldfra(i) = 0.
+        qcld(i)   = 0.
+        qvc(i)    = 0.
+        qincld(i) = qsat(i)
+      ELSE
+        qincld(i) = qcld(i) / cldfra(i)
+      ENDIF ! cldfra .LT. eps
+
+      !--Diagnostics
+      dcf_sub(i)  = dcf_sub(i)  / dtime
+      dcf_con(i)  = dcf_con(i)  / dtime 
+      dcf_mix(i)  = dcf_mix(i)  / dtime 
+      dqi_adj(i)  = dqi_adj(i)  / dtime 
+      dqi_sub(i)  = dqi_sub(i)  / dtime 
+      dqi_con(i)  = dqi_con(i)  / dtime 
+      dqi_mix(i)  = dqi_mix(i)  / dtime 
+      dqvc_adj(i) = dqvc_adj(i) / dtime
+      dqvc_sub(i) = dqvc_sub(i) / dtime
+      dqvc_con(i) = dqvc_con(i) / dtime
+      dqvc_mix(i) = dqvc_mix(i) / dtime
+
+    ENDIF ! ( temp(i) .GT. temp_nowater ) .AND. .NOT. ok_weibull_warm_clouds
+
+  ENDIF   ! end keepgoing
+
+ENDDO     ! end loop on i
+
+END SUBROUTINE condensation_ice_supersat
+!**********************************************************************************
+
+END MODULE lmdz_lscp_condensation
Index: DZ6/trunk/libf/phylmd/lmdz_lscp_ini.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/lmdz_lscp_ini.F90	(revision 5267)
+++ 	(revision )
@@ -1,562 +1,0 @@
-MODULE lmdz_lscp_ini
-
-IMPLICIT NONE
-
-  ! PARAMETERS for lscp:
-  !--------------------
- 
-  REAL RCPD, RLSTT, RLVTT, RLMLT, RVTMP2, RTT, RD, RV, RG, RPI, EPS_W
-  !$OMP THREADPRIVATE(RCPD, RLSTT, RLVTT, RLMLT, RVTMP2, RTT, RD, RV, RG, RPI, EPS_W)
-  
-  REAL, SAVE, PROTECTED :: seuil_neb=0.001      ! cloud fraction threshold: a cloud can precipitate when exceeded
-  !$OMP THREADPRIVATE(seuil_neb)
-
-  REAL, SAVE, PROTECTED :: min_neb_th=1e-10      ! a cloud produced by bi-gaussian really exists when exceeded
-  !$OMP THREADPRIVATE(min_neb_th)
-
-  REAL, SAVE, PROTECTED :: min_frac_thermals=1.e-10   ! minimum thermals fraction for use of bigaussian distribution
-  !$OMP THREADPRIVATE(min_frac_thermals)
-
-  INTEGER, SAVE :: lunout, prt_level            ! Logical unit number and level for standard output
-  !$OMP THREADPRIVATE(lunout,prt_level)
-
-  INTEGER, SAVE, PROTECTED :: niter_lscp=5      ! number of iterations to calculate autoconversion to precipitation
-  !$OMP THREADPRIVATE(niter_lscp)
-
-  INTEGER, SAVE, PROTECTED :: iflag_evap_prec=1 ! precipitation evaporation flag. 0: nothing, 1: "old way", 
-                                                ! 2: Max cloud fraction above to calculate the max of reevaporation
-                                                ! >=4: LTP'method i.e. evaporation in the clear-sky fraction of the mesh only
-                                                ! pay attention that iflag_evap_prec=4 may lead to unrealistic and overestimated
-                                                ! evaporation. Use 5 instead
-  !$OMP THREADPRIVATE(iflag_evap_prec)
-
-  REAL, SAVE, PROTECTED :: t_coup=234.0         ! temperature threshold which determines the phase 
-                                                ! for which the saturation vapor pressure is calculated
-  !$OMP THREADPRIVATE(t_coup)
-  REAL, SAVE, PROTECTED :: DDT0=0.01            ! iteration parameter 
-  !$OMP THREADPRIVATE(DDT0)
-
-  REAL, SAVE, PROTECTED :: ztfondue=278.15      ! parameter to calculate melting fraction of precipitation
-  !$OMP THREADPRIVATE(ztfondue)
-
-  REAL, SAVE, PROTECTED :: temp_nowater=235.15  ! temperature below which liquid water no longer exists
-  !$OMP THREADPRIVATE(temp_nowater)
-
-  REAL, SAVE, PROTECTED :: a_tr_sca(4)          ! Variables for tracers temporary: alpha parameter for scavenging, 4 possible scavenging processes
-  !$OMP THREADPRIVATE(a_tr_sca)
-  
-  REAL, SAVE, PROTECTED ::  min_frac_th_cld=1.e-10   ! minimum thermal fraction to compute a thermal cloud fraction
-  !$OMP THREADPRIVATE(min_frac_th_cld)
-
-  LOGICAL, SAVE, PROTECTED :: ok_radocond_snow=.false. ! take into account the mass of ice precip in the cloud ice content seen by radiation
-  !$OMP THREADPRIVATE(ok_radocond_snow)
-
-  REAL, SAVE, PROTECTED :: t_glace_min=258.0    ! lower-bound temperature parameter for cloud phase determination
-  !$OMP THREADPRIVATE(t_glace_min)
-
-  REAL, SAVE, PROTECTED :: t_glace_max=273.15   ! upper-bound temperature parameter for cloud phase determination
-  !$OMP THREADPRIVATE(t_glace_max)
-
-  REAL, SAVE, PROTECTED :: exposant_glace=1.0   ! parameter for cloud phase determination
-  !$OMP THREADPRIVATE(exposant_glace)
-
-  INTEGER, SAVE, PROTECTED :: iflag_vice=0      ! which expression for ice crystall fall velocity
-  !$OMP THREADPRIVATE(iflag_vice)
-
-  INTEGER, SAVE, PROTECTED :: iflag_t_glace=0   ! which expression for cloud phase partitioning
-  !$OMP THREADPRIVATE(iflag_t_glace)
-
-  INTEGER, SAVE, PROTECTED :: iflag_cloudth_vert=0          ! option for determining cloud fraction and content in convective boundary layers
-  !$OMP THREADPRIVATE(iflag_cloudth_vert)
-
-  INTEGER, SAVE, PROTECTED :: iflag_gammasat=0              ! which threshold for homogeneous nucleation below -40oC
-  !$OMP THREADPRIVATE(iflag_gammasat)
-
-  INTEGER, SAVE, PROTECTED :: iflag_rain_incloud_vol=0      ! use of volume cloud fraction for rain autoconversion 
-  !$OMP THREADPRIVATE(iflag_rain_incloud_vol)
-
-  INTEGER, SAVE, PROTECTED :: iflag_bergeron=0              ! bergeron effect for liquid precipitation treatment  
-  !$OMP THREADPRIVATE(iflag_bergeron)
-
-  INTEGER, SAVE, PROTECTED :: iflag_fisrtilp_qsat=0         ! qsat adjustment (iterative) during autoconversion
-  !$OMP THREADPRIVATE(iflag_fisrtilp_qsat)
-
-  INTEGER, SAVE, PROTECTED :: iflag_pdf=0                   ! type of subgrid scale qtot pdf
-  !$OMP THREADPRIVATE(iflag_pdf)
-
-  INTEGER, SAVE, PROTECTED :: iflag_icefrac=0               ! which phase partitioning function to use
-  !$OMP THREADPRIVATE(iflag_icefrac)
-
-  INTEGER, SAVE, PROTECTED :: iflag_autoconversion=0        ! autoconversion option
-  !$OMP THREADPRIVATE(iflag_autoconversion)
-
-
-  LOGICAL, SAVE, PROTECTED :: reevap_ice=.false.            ! no liquid precip for T< threshold
-  !$OMP THREADPRIVATE(reevap_ice)
-
-  REAL, SAVE, PROTECTED :: cld_lc_lsc=2.6e-4                ! liquid autoconversion coefficient, stratiform rain
-  !$OMP THREADPRIVATE(cld_lc_lsc)
-
-  REAL, SAVE, PROTECTED :: cld_lc_con=2.6e-4                ! liquid autoconversion coefficient, convective rain
-  !$OMP THREADPRIVATE(cld_lc_con)
-
-  REAL, SAVE, PROTECTED :: cld_tau_lsc=3600.                ! liquid autoconversion timescale, stratiform rain
-  !$OMP THREADPRIVATE(cld_tau_lsc)
-
-  REAL, SAVE, PROTECTED :: cld_tau_con=3600.                ! liquid autoconversion timescale, convective rain
-  !$OMP THREADPRIVATE(cld_tau_con)
-
-  REAL, SAVE, PROTECTED :: cld_expo_lsc=2.                  ! liquid autoconversion threshold exponent, stratiform rain
-  !$OMP THREADPRIVATE(cld_expo_lsc)
-
-  REAL, SAVE, PROTECTED :: cld_expo_con=2.                  ! liquid autoconversion threshold exponent, convective rain
-  !$OMP THREADPRIVATE(cld_expo_con)
-
-  REAL, SAVE, PROTECTED :: ffallv_lsc=1.                    ! tuning coefficient crystal fall velocity, stratiform 
-  !$OMP THREADPRIVATE(ffallv_lsc)
-
-  REAL, SAVE, PROTECTED :: ffallv_con=1.                    ! tuning coefficient crystal fall velocity, convective
-  !$OMP THREADPRIVATE(ffallv_con)
-
-  REAL, SAVE, PROTECTED :: coef_eva=2e-5                    ! tuning coefficient liquid precip evaporation
-  !$OMP THREADPRIVATE(coef_eva)
-
-  REAL, SAVE, PROTECTED :: coef_sub                         ! tuning coefficient ice precip sublimation
-  !$OMP THREADPRIVATE(coef_sub)
-
-  REAL, SAVE, PROTECTED :: expo_eva=0.5                     ! tuning coefficient liquid precip evaporation
-  !$OMP THREADPRIVATE(expo_eva)
-
-  REAL, SAVE, PROTECTED :: expo_sub                         ! tuning coefficient ice precip sublimation
-  !$OMP THREADPRIVATE(expo_sub)
-
-  REAL, SAVE, PROTECTED :: cice_velo=1.645                  ! factor in the ice fall velocity formulation
-  !$OMP THREADPRIVATE(cice_velo)
-
-  REAL, SAVE, PROTECTED ::  dice_velo=0.16                  ! exponent in the ice fall velocity formulation
-  !$OMP THREADPRIVATE(dice_velo)
-
-  REAL, SAVE, PROTECTED :: dist_liq=300.                    ! typical deph of cloud-top liquid layer in mpcs
-  !$OMP THREADPRIVATE(dist_liq)
-
-  REAL, SAVE, PROTECTED  :: tresh_cl=0.0                  ! cloud fraction threshold for cloud top search
-  !$OMP THREADPRIVATE(tresh_cl)
-
-  !--Parameters for condensation and ice supersaturation
-
-  LOGICAL, SAVE, PROTECTED :: ok_ice_supersat=.FALSE.        ! activates the condensation scheme that allows for ice supersaturation
-  !$OMP THREADPRIVATE(ok_ice_supersat)
-
-  LOGICAL, SAVE, PROTECTED :: ok_unadjusted_clouds=.FALSE.   ! if True, relax the saturation adjustment assumption for ice clouds
-  !$OMP THREADPRIVATE(ok_unadjusted_clouds)
-
-  LOGICAL, SAVE, PROTECTED :: ok_weibull_warm_clouds=.FALSE. ! if True, the weibull condensation scheme replaces the lognormal condensation scheme at positive temperatures
-  !$OMP THREADPRIVATE(ok_weibull_warm_clouds)
-
-  INTEGER, SAVE, PROTECTED :: iflag_cloud_sublim_pdf=3       ! iflag for the distribution of water inside ice clouds
-  !$OMP THREADPRIVATE(iflag_cloud_sublim_pdf)
-
-  REAL, SAVE, PROTECTED :: depo_coef_cirrus=.5               ! [-] deposition coefficient for growth of ice crystals in cirrus clouds
-  !$OMP THREADPRIVATE(depo_coef_cirrus)
-
-  REAL, SAVE, PROTECTED :: capa_cond_cirrus=.5               ! [-] capacitance factor for growth/sublimation of ice crystals in cirrus clouds
-  !$OMP THREADPRIVATE(capa_cond_cirrus)
-
-  REAL, SAVE, PROTECTED :: mu_subl_pdf_lscp=1./3.            ! [-] shape factor of the gamma distribution of water inside ice clouds
-  !$OMP THREADPRIVATE(mu_subl_pdf_lscp)
-  
-  REAL, SAVE, PROTECTED :: beta_pdf_lscp=8.75E-4             ! [] tuning coefficient for the standard deviation of the PDF of water vapor in the clear sky region
-  !$OMP THREADPRIVATE(beta_pdf_lscp)
-  
-  REAL, SAVE, PROTECTED :: temp_thresh_pdf_lscp=188.         ! [K] factor for the PDF fit of water vapor in UTLS - below this temperature, water vapor is homogeneously distributed in the clear sky region
-  !$OMP THREADPRIVATE(temp_thresh_pdf_lscp)
-  
-  REAL, SAVE, PROTECTED :: rhlmid_pdf_lscp=52.8              ! [%] factor for the PDF fit of water vapor in UTLS - below this rel hum wrt liq, std increases with RHliq, above it decreases with RHliq
-  !$OMP THREADPRIVATE(rhlmid_pdf_lscp)
-  
-  REAL, SAVE, PROTECTED :: k0_pdf_lscp=2.80                  ! [-] factor for the PDF fit of water vapor in UTLS
-  !$OMP THREADPRIVATE(k0_pdf_lscp)
-  
-  REAL, SAVE, PROTECTED :: kappa_pdf_lscp=0.0236             ! [] factor for the PDF fit of water vapor in UTLS
-  !$OMP THREADPRIVATE(kappa_pdf_lscp)
-  
-  REAL, SAVE, PROTECTED :: rhl0_pdf_lscp=88.7                ! [%] factor for the PDF fit of water vapor in UTLS
-  !$OMP THREADPRIVATE(rhl0_pdf_lscp)
-  
-  REAL, SAVE, PROTECTED :: a_homofreez=2.349                 ! [-] factor for the Koop homogeneous freezing fit
-  !$OMP THREADPRIVATE(a_homofreez)
-  
-  REAL, SAVE, PROTECTED :: b_homofreez=259.                  ! [K] factor for the Koop homogeneous freezing fit
-  !$OMP THREADPRIVATE(b_homofreez)
-
-  REAL, SAVE, PROTECTED :: delta_hetfreez=1.                 ! [-] value between 0 and 1 to simulate for heterogeneous freezing.
-  !$OMP THREADPRIVATE(delta_hetfreez)
-  
-  REAL, SAVE, PROTECTED :: coef_mixing_lscp=1e-7             ! [-] tuning coefficient for the mixing process
-  !$OMP THREADPRIVATE(coef_mixing_lscp)
-  
-  REAL, SAVE, PROTECTED :: coef_shear_lscp=0.1               ! [-] additional coefficient for the shearing process (subprocess of the mixing process)
-  !$OMP THREADPRIVATE(coef_shear_lscp)
-  
-  REAL, SAVE, PROTECTED :: chi_mixing_lscp=1.1               ! [-] factor for the macro distribution of ISSRs wrt clouds in a gridbox
-  !$OMP THREADPRIVATE(chi_mixing_lscp)
-
-!  REAL, SAVE, PROTECTED :: contrail_cross_section=200000.
-!  !$OMP THREADPRIVATE(contrail_cross_section)
-  !--End of the parameters for condensation and ice supersaturation
-
-  !--Parameters for poprecip
-  LOGICAL, SAVE, PROTECTED :: ok_poprecip=.FALSE.           ! use the processes-oriented formulation of precipitations
-  !$OMP THREADPRIVATE(ok_poprecip)
-
-  LOGICAL, SAVE, PROTECTED :: ok_corr_vap_evasub=.FALSE.    ! use the corrected version of clear-sky water vapor for the evap / subl processes
-  !$OMP THREADPRIVATE(ok_corr_vap_evasub)
-
-  REAL, SAVE, PROTECTED :: cld_lc_lsc_snow=2.e-5            ! snow autoconversion coefficient, stratiform. default from  Chaboureau and PInty 2006
-  !$OMP THREADPRIVATE(cld_lc_lsc_snow)
-
-  REAL, SAVE, PROTECTED :: cld_lc_con_snow=2.e-5            ! snow autoconversion coefficient, convective 
-  !$OMP THREADPRIVATE(cld_lc_con_snow)
-
-  REAL, SAVE, PROTECTED :: rain_int_min=1.e-5               ! Minimum local rain intensity [mm/s] before the decrease in associated precipitation fraction
-  !$OMP THREADPRIVATE(rain_int_min)
-
-  REAL, SAVE, PROTECTED :: thresh_precip_frac=1.E-6         ! precipitation fraction threshold TODO [-]
-  !$OMP THREADPRIVATE(thresh_precip_frac)
-
-  REAL, SAVE, PROTECTED :: tau_mixenv=100000                ! Homogeneization time of mixed phase clouds [s]
-  !$OMP THREADPRIVATE(tau_mixenv)
-
-    REAL, SAVE, PROTECTED :: capa_crystal=1.                ! Sursaturation of ice part in mixed phase clouds [-]
-  !$OMP THREADPRIVATE(capa_crystal)
-
-  REAL, SAVE, PROTECTED :: lmix_mpc=1000                    ! Length of turbulent zones in Mixed Phase Clouds [m]
-  !$OMP THREADPRIVATE(lmix_mpc)
-
-  REAL, SAVE, PROTECTED :: naero5=0.5                       ! Number concentration of aerosol larger than 0.5 microns [scm-3]
-  !$OMP THREADPRIVATE(naero5)
-
-  REAL, SAVE, PROTECTED :: gamma_snwretro = 0.              ! Proportion of snow taken into account in ice retroaction in icefrac_turb [-]
-  !$OMP THREADPRIVATE(gamma_snwretro)
-
-  REAL, SAVE, PROTECTED :: gamma_taud = 1.                  ! Tuning coeff for tau_dissipturb [-]
-  !$OMP THREADPRIVATE(gamma_taud)
-
-  REAL, SAVE, PROTECTED :: gamma_col=1.                     ! A COMMENTER TODO [-]
-  !$OMP THREADPRIVATE(gamma_col)
-
-  REAL, SAVE, PROTECTED :: gamma_agg=1.                     ! A COMMENTER TODO [-]
-  !$OMP THREADPRIVATE(gamma_agg)
-
-  REAL, SAVE, PROTECTED :: gamma_rim=1.                     ! A COMMENTER TODO [-]
-  !$OMP THREADPRIVATE(gamma_rim)
-
-  REAL, SAVE, PROTECTED :: rho_rain=1000.                   ! Rain density [kg/m3]
-  !$OMP THREADPRIVATE(rho_rain)
-
-  REAL, SAVE, PROTECTED :: rho_ice=920.                     ! Ice density  [kg/m3]
-  !$OMP THREADPRIVATE(rho_ice)
-
-  REAL, SAVE, PROTECTED :: r_rain=500.E-6                   ! Rain droplets radius for POPRECIP [m]
-  !$OMP THREADPRIVATE(r_rain)
-
-  REAL, SAVE, PROTECTED :: r_snow=1.E-3                     ! Ice crystals radius for POPRECIP [m]
-  !$OMP THREADPRIVATE(r_snow)
-
-  REAL, SAVE, PROTECTED :: tau_auto_snow_min=100.           ! A COMMENTER TODO [s]
-  !$OMP THREADPRIVATE(tau_auto_snow_min)
-
-  REAL, SAVE, PROTECTED :: tau_auto_snow_max=1000.          ! A COMMENTER TODO [s]
-  !$OMP THREADPRIVATE(tau_auto_snow_max)
-
-  REAL, SAVE, PROTECTED :: eps=1.E-10                       ! A COMMENTER TODO [-]
-  !$OMP THREADPRIVATE(eps)
-
-  REAL, SAVE, PROTECTED :: gamma_melt=1.                    ! A COMMENTER TODO [-]
-  !$OMP THREADPRIVATE(gamma_melt)
-
-  REAL, SAVE, PROTECTED :: alpha_freez=4.                   ! A COMMENTER TODO [-]
-  !$OMP THREADPRIVATE(alpha_freez)
-
-  REAL, SAVE, PROTECTED :: beta_freez=0.1                   ! A COMMENTER TODO [m-3.s-1]
-  !$OMP THREADPRIVATE(beta_freez)
-
-  REAL, SAVE, PROTECTED :: gamma_freez=1.                   ! A COMMENTER TODO [-]
-  !$OMP THREADPRIVATE(gamma_freez)
-
-  REAL, SAVE, PROTECTED :: rain_fallspeed=4.                ! A COMMENTER TODO [m/s]
-  !$OMP THREADPRIVATE(rain_fallspeed)
-
-  REAL, SAVE, PROTECTED :: rain_fallspeed_clr                ! A COMMENTER TODO [m/s]
-  !$OMP THREADPRIVATE(rain_fallspeed_clr)
-
-  REAL, SAVE, PROTECTED :: rain_fallspeed_cld               ! A COMMENTER TODO [m/s]
-  !$OMP THREADPRIVATE(rain_fallspeed_cld)
-
-  REAL, SAVE, PROTECTED :: snow_fallspeed=1.               ! A COMMENTER TODO [m/s]
-  !$OMP THREADPRIVATE(snow_fallspeed)
-
-  REAL, SAVE, PROTECTED :: snow_fallspeed_clr               ! A COMMENTER TODO [m/s]
-  !$OMP THREADPRIVATE(snow_fallspeed_clr)
-
-  REAL, SAVE, PROTECTED :: snow_fallspeed_cld               ! A COMMENTER TODO [m/s]
-  !$OMP THREADPRIVATE(snow_fallspeed_cld)
-  !--End of the parameters for poprecip
-
-! Two parameters used for lmdz_lscp_old only
-  INTEGER, SAVE, PROTECTED :: iflag_oldbug_fisrtilp=0, fl_cor_ebil 
-  !$OMP THREADPRIVATE(iflag_oldbug_fisrtilp,fl_cor_ebil)
-
-CONTAINS
-
-SUBROUTINE lscp_ini(dtime,lunout_in,prt_level_in,ok_ice_supersat_in, iflag_ratqs, fl_cor_ebil_in, &
-                    RCPD_in, RLSTT_in, RLVTT_in, RLMLT_in, RVTMP2_in, &
-                    RTT_in, RD_in, RV_in, RG_in, RPI_in, EPS_W_in)
-
-
-   USE ioipsl_getin_p_mod, ONLY : getin_p
-   USE lmdz_cloudth_ini, ONLY : cloudth_ini
-
-   REAL, INTENT(IN)      :: dtime
-   INTEGER, INTENT(IN)   :: lunout_in,prt_level_in,iflag_ratqs,fl_cor_ebil_in
-   LOGICAL, INTENT(IN)   :: ok_ice_supersat_in
-
-   REAL, INTENT(IN)      :: RCPD_in, RLSTT_in, RLVTT_in, RLMLT_in
-   REAL, INTENT(IN)      :: RVTMP2_in, RTT_in, RD_in, RV_in, RG_in, RPI_in, EPS_W_in
-   character (len=20) :: modname='lscp_ini_mod'
-   character (len=80) :: abort_message
-
-
-    lunout=lunout_in
-    prt_level=prt_level_in
-    fl_cor_ebil=fl_cor_ebil_in
-
-    ok_ice_supersat=ok_ice_supersat_in
-
-    RG=RG_in
-    RD=RD_in
-    RV=RV_in
-    RCPD=RCPD_in
-    RLVTT=RLVTT_in
-    RLSTT=RLSTT_in
-    RLMLT=RLMLT_in
-    RTT=RTT_in
-    RV=RV_in
-    RVTMP2=RVTMP2_in
-    RPI=RPI_in
-    EPS_W=EPS_W_in
-
-
-
-    CALL getin_p('niter_lscp',niter_lscp)
-    CALL getin_p('iflag_evap_prec',iflag_evap_prec)
-    CALL getin_p('seuil_neb',seuil_neb)
-    CALL getin_p('ok_radocond_snow',ok_radocond_snow) 
-    CALL getin_p('t_glace_max',t_glace_max)
-    CALL getin_p('t_glace_min',t_glace_min)
-    CALL getin_p('exposant_glace',exposant_glace) 
-    CALL getin_p('iflag_vice',iflag_vice)
-    CALL getin_p('iflag_t_glace',iflag_t_glace)
-    CALL getin_p('iflag_cloudth_vert',iflag_cloudth_vert)
-    CALL getin_p('iflag_gammasat',iflag_gammasat)
-    CALL getin_p('iflag_rain_incloud_vol',iflag_rain_incloud_vol)
-    CALL getin_p('iflag_bergeron',iflag_bergeron)
-    CALL getin_p('iflag_fisrtilp_qsat',iflag_fisrtilp_qsat)
-    CALL getin_p('iflag_pdf',iflag_pdf)
-    CALL getin_p('iflag_icefrac',iflag_icefrac)
-    CALL getin_p('reevap_ice',reevap_ice)
-    CALL getin_p('cld_lc_lsc',cld_lc_lsc)
-    CALL getin_p('cld_lc_con',cld_lc_con)
-    CALL getin_p('cld_lc_lsc_snow',cld_lc_lsc_snow)
-    CALL getin_p('cld_lc_con_snow',cld_lc_con_snow)
-    CALL getin_p('cld_tau_lsc',cld_tau_lsc)
-    CALL getin_p('cld_tau_con',cld_tau_con)
-    CALL getin_p('cld_expo_lsc',cld_expo_lsc)
-    CALL getin_p('cld_expo_con',cld_expo_con)
-    CALL getin_p('ffallv_lsc',ffallv_lsc)
-    CALL getin_p('ffallv_lsc',ffallv_con)
-    CALL getin_p('coef_eva',coef_eva)
-    coef_sub=coef_eva
-    CALL getin_p('coef_eva_i',coef_sub)
-    CALL getin_p('coef_sub',coef_sub)
-    CALL getin_p('expo_eva',expo_eva)
-    expo_sub=expo_eva
-    CALL getin_p('expo_sub',expo_sub)
-    CALL getin_p('iflag_autoconversion',iflag_autoconversion)
-    CALL getin_p('dist_liq',dist_liq)
-    CALL getin_p('tresh_cl',tresh_cl)
-    CALL getin_p('tau_mixenv',tau_mixenv)
-    CALL getin_p('capa_crystal',capa_crystal)
-    CALL getin_p('lmix_mpc',lmix_mpc)
-    CALL getin_p('naero5',naero5)
-    CALL getin_p('gamma_snwretro',gamma_snwretro)
-    CALL getin_p('gamma_taud',gamma_taud)
-    CALL getin_p('iflag_oldbug_fisrtilp',iflag_oldbug_fisrtilp)
-    CALL getin_p('temp_nowater',temp_nowater)
-    ! for poprecip
-    CALL getin_p('ok_poprecip',ok_poprecip)
-    CALL getin_p('ok_corr_vap_evasub',ok_corr_vap_evasub)
-    CALL getin_p('rain_int_min',rain_int_min) 
-    CALL getin_p('gamma_agg',gamma_agg)
-    CALL getin_p('gamma_col',gamma_col)
-    CALL getin_p('gamma_rim',gamma_rim)
-    CALL getin_p('gamma_freez',gamma_freez)
-    CALL getin_p('gamma_melt',gamma_melt)
-    CALL getin_p('r_snow',r_snow)
-    CALL getin_p('rain_fallspeed',rain_fallspeed)
-    rain_fallspeed_clr=rain_fallspeed
-    rain_fallspeed_cld=rain_fallspeed
-    CALL getin_p('rain_fallspeed_clr',rain_fallspeed_clr)
-    CALL getin_p('rain_fallspeed_cld',rain_fallspeed_cld)
-    CALL getin_p('snow_fallspeed',snow_fallspeed)
-    snow_fallspeed_clr=snow_fallspeed
-    snow_fallspeed_cld=snow_fallspeed
-    CALL getin_p('snow_fallspeed_clr',snow_fallspeed_clr)
-    CALL getin_p('snow_fallspeed_cld',snow_fallspeed_cld)
-    ! for condensation and ice supersaturation
-    CALL getin_p('ok_unadjusted_clouds',ok_unadjusted_clouds)
-    CALL getin_p('ok_weibull_warm_clouds',ok_weibull_warm_clouds)
-    CALL getin_p('iflag_cloud_sublim_pdf',iflag_cloud_sublim_pdf)
-    CALL getin_p('depo_coef_cirrus',depo_coef_cirrus)
-    CALL getin_p('capa_cond_cirrus',capa_cond_cirrus)
-    CALL getin_p('mu_subl_pdf_lscp',mu_subl_pdf_lscp)
-    CALL getin_p('beta_pdf_lscp',beta_pdf_lscp)
-    CALL getin_p('temp_thresh_pdf_lscp',temp_thresh_pdf_lscp)
-    CALL getin_p('rhlmid_pdf_lscp',rhlmid_pdf_lscp)
-    CALL getin_p('k0_pdf_lscp',k0_pdf_lscp)
-    CALL getin_p('kappa_pdf_lscp',kappa_pdf_lscp)
-    CALL getin_p('rhl0_pdf_lscp',rhl0_pdf_lscp)
-    CALL getin_p('a_homofreez',a_homofreez)
-    CALL getin_p('b_homofreez',b_homofreez)
-    CALL getin_p('delta_hetfreez',delta_hetfreez)
-    CALL getin_p('coef_mixing_lscp',coef_mixing_lscp)
-    CALL getin_p('coef_shear_lscp',coef_shear_lscp)
-    CALL getin_p('chi_mixing_lscp',chi_mixing_lscp)
-    !CALL getin_p('contrail_cross_section',contrail_cross_section)
-
-
-
-    WRITE(lunout,*) 'lscp_ini, niter_lscp:', niter_lscp
-    WRITE(lunout,*) 'lscp_ini, iflag_evap_prec:', iflag_evap_prec
-    WRITE(lunout,*) 'lscp_ini, seuil_neb:', seuil_neb
-    WRITE(lunout,*) 'lscp_ini, ok_radocond_snow:', ok_radocond_snow
-    WRITE(lunout,*) 'lscp_ini, t_glace_max:', t_glace_max
-    WRITE(lunout,*) 'lscp_ini, t_glace_min:', t_glace_min
-    WRITE(lunout,*) 'lscp_ini, exposant_glace:', exposant_glace
-    WRITE(lunout,*) 'lscp_ini, iflag_vice:', iflag_vice
-    WRITE(lunout,*) 'lscp_ini, iflag_t_glace:', iflag_t_glace
-    WRITE(lunout,*) 'lscp_ini, iflag_cloudth_vert:', iflag_cloudth_vert
-    WRITE(lunout,*) 'lscp_ini, iflag_gammasat:', iflag_gammasat
-    WRITE(lunout,*) 'lscp_ini, iflag_rain_incloud_vol:', iflag_rain_incloud_vol
-    WRITE(lunout,*) 'lscp_ini, iflag_bergeron:', iflag_bergeron
-    WRITE(lunout,*) 'lscp_ini, iflag_fisrtilp_qsat:', iflag_fisrtilp_qsat
-    WRITE(lunout,*) 'lscp_ini, iflag_pdf', iflag_pdf
-    WRITE(lunout,*) 'lscp_ini, iflag_icefrac', iflag_icefrac
-    WRITE(lunout,*) 'lscp_ini, reevap_ice', reevap_ice
-    WRITE(lunout,*) 'lscp_ini, cld_lc_lsc', cld_lc_lsc
-    WRITE(lunout,*) 'lscp_ini, cld_lc_con', cld_lc_con
-    WRITE(lunout,*) 'lscp_ini, cld_lc_lsc_snow', cld_lc_lsc_snow
-    WRITE(lunout,*) 'lscp_ini, cld_lc_con_snow', cld_lc_con_snow
-    WRITE(lunout,*) 'lscp_ini, cld_tau_lsc', cld_tau_lsc
-    WRITE(lunout,*) 'lscp_ini, cld_tau_con', cld_tau_con
-    WRITE(lunout,*) 'lscp_ini, cld_expo_lsc', cld_expo_lsc
-    WRITE(lunout,*) 'lscp_ini, cld_expo_con', cld_expo_con
-    WRITE(lunout,*) 'lscp_ini, ffallv_lsc', ffallv_lsc
-    WRITE(lunout,*) 'lscp_ini, ffallv_con', ffallv_con
-    WRITE(lunout,*) 'lscp_ini, coef_eva', coef_eva
-    WRITE(lunout,*) 'lscp_ini, coef_sub', coef_sub
-    WRITE(lunout,*) 'lscp_ini, expo_eva', expo_eva
-    WRITE(lunout,*) 'lscp_ini, expo_sub', expo_sub
-    WRITE(lunout,*) 'lscp_ini, iflag_autoconversion', iflag_autoconversion
-    WRITE(lunout,*) 'lscp_ini, dist_liq', dist_liq
-    WRITE(lunout,*) 'lscp_ini, tresh_cl', tresh_cl
-    WRITE(lunout,*) 'lscp_ini, tau_mixenv', tau_mixenv
-    WRITE(lunout,*) 'lscp_ini, capa_crystal', capa_crystal
-    WRITE(lunout,*) 'lscp_ini, lmix_mpc', lmix_mpc
-    WRITE(lunout,*) 'lscp_ini, naero5', naero5
-    WRITE(lunout,*) 'lscp_ini, gamma_snwretro', gamma_snwretro
-    WRITE(lunout,*) 'lscp_ini, gamma_taud', gamma_taud
-    WRITE(lunout,*) 'lscp_ini, iflag_oldbug_fisrtilp', iflag_oldbug_fisrtilp
-    WRITE(lunout,*) 'lscp_ini, fl_cor_ebil', fl_cor_ebil
-    WRITE(lunout,*) 'lscp_ini, temp_nowater', temp_nowater
-    ! for poprecip
-    WRITE(lunout,*) 'lscp_ini, ok_poprecip', ok_poprecip
-    WRITE(lunout,*) 'lscp_ini, ok_corr_vap_evasub', ok_corr_vap_evasub
-    WRITE(lunout,*) 'lscp_ini, rain_int_min:', rain_int_min
-    WRITE(lunout,*) 'lscp_ini, gamma_agg:', gamma_agg
-    WRITE(lunout,*) 'lscp_ini, gamma_col:', gamma_col
-    WRITE(lunout,*) 'lscp_ini, gamma_rim:', gamma_rim
-    WRITE(lunout,*) 'lscp_ini, gamma_freez:', gamma_freez
-    WRITE(lunout,*) 'lscp_ini, gamma_melt:', gamma_melt
-    WRITE(lunout,*) 'lscp_ini, r_snow:', r_snow
-    WRITE(lunout,*) 'lscp_ini, rain_fallspeed_clr:', rain_fallspeed_clr
-    WRITE(lunout,*) 'lscp_ini, rain_fallspeed_cld:', rain_fallspeed_cld
-    WRITE(lunout,*) 'lscp_ini, snow_fallspeed_clr:', snow_fallspeed_clr
-    WRITE(lunout,*) 'lscp_ini, snow_fallspeed_cld:', snow_fallspeed_cld
-    ! for condensation and ice supersaturation
-    WRITE(lunout,*) 'lscp_ini, ok_ice_supersat:', ok_ice_supersat
-    WRITE(lunout,*) 'lscp_ini, ok_unadjusted_clouds:', ok_unadjusted_clouds
-    WRITE(lunout,*) 'lscp_ini, ok_weibull_warm_clouds:', ok_weibull_warm_clouds
-    WRITE(lunout,*) 'lscp_ini, iflag_cloud_sublim_pdf:', iflag_cloud_sublim_pdf
-    WRITE(lunout,*) 'lscp_ini, depo_coef_cirrus:', depo_coef_cirrus
-    WRITE(lunout,*) 'lscp_ini, capa_cond_cirrus:', capa_cond_cirrus
-    WRITE(lunout,*) 'lscp_ini, mu_subl_pdf_lscp:', mu_subl_pdf_lscp
-    WRITE(lunout,*) 'lscp_ini, beta_pdf_lscp:', beta_pdf_lscp
-    WRITE(lunout,*) 'lscp_ini, temp_thresh_pdf_lscp:', temp_thresh_pdf_lscp
-    WRITE(lunout,*) 'lscp_ini, rhlmid_pdf_lscp:', rhlmid_pdf_lscp
-    WRITE(lunout,*) 'lscp_ini, k0_pdf_lscp:', k0_pdf_lscp
-    WRITE(lunout,*) 'lscp_ini, kappa_pdf_lscp:', kappa_pdf_lscp
-    WRITE(lunout,*) 'lscp_ini, rhl0_pdf_lscp:', rhl0_pdf_lscp
-    WRITE(lunout,*) 'lscp_ini, a_homofreez:', a_homofreez
-    WRITE(lunout,*) 'lscp_ini, b_homofreez:', b_homofreez
-    WRITE(lunout,*) 'lscp_ini, delta_hetfreez', delta_hetfreez
-    WRITE(lunout,*) 'lscp_ini, coef_mixing_lscp:', coef_mixing_lscp
-    WRITE(lunout,*) 'lscp_ini, coef_shear_lscp:', coef_shear_lscp
-    WRITE(lunout,*) 'lscp_ini, chi_mixing_lscp:', chi_mixing_lscp
-!    WRITE(lunout,*) 'lscp_ini, contrail_cross_section:', contrail_cross_section
-
-
-
-
-
-    ! check for precipitation sub-time steps
-    IF (ABS(dtime/REAL(niter_lscp)-360.0).GT.0.001) THEN
-        WRITE(lunout,*) 'lscp: it is not expected, see Z.X.Li', dtime
-        WRITE(lunout,*) 'I would prefer a 6 min sub-timestep'
-    ENDIF
-
-    ! check consistency between numerical resolution of autoconversion 
-    ! and other options
-   
-    IF (iflag_autoconversion .EQ. 2) THEN
-        IF ((iflag_vice .NE. 0) .OR. (niter_lscp .GT. 1)) THEN
-           abort_message = 'in lscp, iflag_autoconversion=2 requires iflag_vice=0 and niter_lscp=1'
-           CALL abort_physic (modname,abort_message,1) 
-        ENDIF 
-    ENDIF
-
-
-    IF ( ok_weibull_warm_clouds .AND. .NOT. ok_ice_supersat ) THEN
-      abort_message = 'in lscp, ok_weibull_warm_clouds=y needs ok_ice_supersat=y'
-      CALL abort_physic (modname,abort_message,1)
-    ENDIF
-
-    IF ( ok_unadjusted_clouds .AND. .NOT. ok_ice_supersat ) THEN
-      abort_message = 'in lscp, ok_unadjusted_clouds=y needs ok_ice_supersat=y'
-      CALL abort_physic (modname,abort_message,1)
-    ENDIF
-
-
-    !AA Temporary initialisation
-    a_tr_sca(1) = -0.5
-    a_tr_sca(2) = -0.5
-    a_tr_sca(3) = -0.5
-    a_tr_sca(4) = -0.5
-    
-    CALL cloudth_ini(iflag_cloudth_vert,iflag_ratqs)
-
-RETURN
-
-END SUBROUTINE lscp_ini
-
-END MODULE lmdz_lscp_ini
Index: /LMDZ6/trunk/libf/phylmd/lmdz_lscp_ini.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/lmdz_lscp_ini.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/lmdz_lscp_ini.f90	(revision 5268)
@@ -0,0 +1,562 @@
+MODULE lmdz_lscp_ini
+
+IMPLICIT NONE
+
+  ! PARAMETERS for lscp:
+  !--------------------
+ 
+  REAL RCPD, RLSTT, RLVTT, RLMLT, RVTMP2, RTT, RD, RV, RG, RPI, EPS_W
+  !$OMP THREADPRIVATE(RCPD, RLSTT, RLVTT, RLMLT, RVTMP2, RTT, RD, RV, RG, RPI, EPS_W)
+  
+  REAL, SAVE, PROTECTED :: seuil_neb=0.001      ! cloud fraction threshold: a cloud can precipitate when exceeded
+  !$OMP THREADPRIVATE(seuil_neb)
+
+  REAL, SAVE, PROTECTED :: min_neb_th=1e-10      ! a cloud produced by bi-gaussian really exists when exceeded
+  !$OMP THREADPRIVATE(min_neb_th)
+
+  REAL, SAVE, PROTECTED :: min_frac_thermals=1.e-10   ! minimum thermals fraction for use of bigaussian distribution
+  !$OMP THREADPRIVATE(min_frac_thermals)
+
+  INTEGER, SAVE :: lunout, prt_level            ! Logical unit number and level for standard output
+  !$OMP THREADPRIVATE(lunout,prt_level)
+
+  INTEGER, SAVE, PROTECTED :: niter_lscp=5      ! number of iterations to calculate autoconversion to precipitation
+  !$OMP THREADPRIVATE(niter_lscp)
+
+  INTEGER, SAVE, PROTECTED :: iflag_evap_prec=1 ! precipitation evaporation flag. 0: nothing, 1: "old way", 
+                                                ! 2: Max cloud fraction above to calculate the max of reevaporation
+                                                ! >=4: LTP'method i.e. evaporation in the clear-sky fraction of the mesh only
+                                                ! pay attention that iflag_evap_prec=4 may lead to unrealistic and overestimated
+                                                ! evaporation. Use 5 instead
+  !$OMP THREADPRIVATE(iflag_evap_prec)
+
+  REAL, SAVE, PROTECTED :: t_coup=234.0         ! temperature threshold which determines the phase 
+                                                ! for which the saturation vapor pressure is calculated
+  !$OMP THREADPRIVATE(t_coup)
+  REAL, SAVE, PROTECTED :: DDT0=0.01            ! iteration parameter 
+  !$OMP THREADPRIVATE(DDT0)
+
+  REAL, SAVE, PROTECTED :: ztfondue=278.15      ! parameter to calculate melting fraction of precipitation
+  !$OMP THREADPRIVATE(ztfondue)
+
+  REAL, SAVE, PROTECTED :: temp_nowater=235.15  ! temperature below which liquid water no longer exists
+  !$OMP THREADPRIVATE(temp_nowater)
+
+  REAL, SAVE, PROTECTED :: a_tr_sca(4)          ! Variables for tracers temporary: alpha parameter for scavenging, 4 possible scavenging processes
+  !$OMP THREADPRIVATE(a_tr_sca)
+  
+  REAL, SAVE, PROTECTED ::  min_frac_th_cld=1.e-10   ! minimum thermal fraction to compute a thermal cloud fraction
+  !$OMP THREADPRIVATE(min_frac_th_cld)
+
+  LOGICAL, SAVE, PROTECTED :: ok_radocond_snow=.false. ! take into account the mass of ice precip in the cloud ice content seen by radiation
+  !$OMP THREADPRIVATE(ok_radocond_snow)
+
+  REAL, SAVE, PROTECTED :: t_glace_min=258.0    ! lower-bound temperature parameter for cloud phase determination
+  !$OMP THREADPRIVATE(t_glace_min)
+
+  REAL, SAVE, PROTECTED :: t_glace_max=273.15   ! upper-bound temperature parameter for cloud phase determination
+  !$OMP THREADPRIVATE(t_glace_max)
+
+  REAL, SAVE, PROTECTED :: exposant_glace=1.0   ! parameter for cloud phase determination
+  !$OMP THREADPRIVATE(exposant_glace)
+
+  INTEGER, SAVE, PROTECTED :: iflag_vice=0      ! which expression for ice crystall fall velocity
+  !$OMP THREADPRIVATE(iflag_vice)
+
+  INTEGER, SAVE, PROTECTED :: iflag_t_glace=0   ! which expression for cloud phase partitioning
+  !$OMP THREADPRIVATE(iflag_t_glace)
+
+  INTEGER, SAVE, PROTECTED :: iflag_cloudth_vert=0          ! option for determining cloud fraction and content in convective boundary layers
+  !$OMP THREADPRIVATE(iflag_cloudth_vert)
+
+  INTEGER, SAVE, PROTECTED :: iflag_gammasat=0              ! which threshold for homogeneous nucleation below -40oC
+  !$OMP THREADPRIVATE(iflag_gammasat)
+
+  INTEGER, SAVE, PROTECTED :: iflag_rain_incloud_vol=0      ! use of volume cloud fraction for rain autoconversion 
+  !$OMP THREADPRIVATE(iflag_rain_incloud_vol)
+
+  INTEGER, SAVE, PROTECTED :: iflag_bergeron=0              ! bergeron effect for liquid precipitation treatment  
+  !$OMP THREADPRIVATE(iflag_bergeron)
+
+  INTEGER, SAVE, PROTECTED :: iflag_fisrtilp_qsat=0         ! qsat adjustment (iterative) during autoconversion
+  !$OMP THREADPRIVATE(iflag_fisrtilp_qsat)
+
+  INTEGER, SAVE, PROTECTED :: iflag_pdf=0                   ! type of subgrid scale qtot pdf
+  !$OMP THREADPRIVATE(iflag_pdf)
+
+  INTEGER, SAVE, PROTECTED :: iflag_icefrac=0               ! which phase partitioning function to use
+  !$OMP THREADPRIVATE(iflag_icefrac)
+
+  INTEGER, SAVE, PROTECTED :: iflag_autoconversion=0        ! autoconversion option
+  !$OMP THREADPRIVATE(iflag_autoconversion)
+
+
+  LOGICAL, SAVE, PROTECTED :: reevap_ice=.false.            ! no liquid precip for T< threshold
+  !$OMP THREADPRIVATE(reevap_ice)
+
+  REAL, SAVE, PROTECTED :: cld_lc_lsc=2.6e-4                ! liquid autoconversion coefficient, stratiform rain
+  !$OMP THREADPRIVATE(cld_lc_lsc)
+
+  REAL, SAVE, PROTECTED :: cld_lc_con=2.6e-4                ! liquid autoconversion coefficient, convective rain
+  !$OMP THREADPRIVATE(cld_lc_con)
+
+  REAL, SAVE, PROTECTED :: cld_tau_lsc=3600.                ! liquid autoconversion timescale, stratiform rain
+  !$OMP THREADPRIVATE(cld_tau_lsc)
+
+  REAL, SAVE, PROTECTED :: cld_tau_con=3600.                ! liquid autoconversion timescale, convective rain
+  !$OMP THREADPRIVATE(cld_tau_con)
+
+  REAL, SAVE, PROTECTED :: cld_expo_lsc=2.                  ! liquid autoconversion threshold exponent, stratiform rain
+  !$OMP THREADPRIVATE(cld_expo_lsc)
+
+  REAL, SAVE, PROTECTED :: cld_expo_con=2.                  ! liquid autoconversion threshold exponent, convective rain
+  !$OMP THREADPRIVATE(cld_expo_con)
+
+  REAL, SAVE, PROTECTED :: ffallv_lsc=1.                    ! tuning coefficient crystal fall velocity, stratiform 
+  !$OMP THREADPRIVATE(ffallv_lsc)
+
+  REAL, SAVE, PROTECTED :: ffallv_con=1.                    ! tuning coefficient crystal fall velocity, convective
+  !$OMP THREADPRIVATE(ffallv_con)
+
+  REAL, SAVE, PROTECTED :: coef_eva=2e-5                    ! tuning coefficient liquid precip evaporation
+  !$OMP THREADPRIVATE(coef_eva)
+
+  REAL, SAVE, PROTECTED :: coef_sub                         ! tuning coefficient ice precip sublimation
+  !$OMP THREADPRIVATE(coef_sub)
+
+  REAL, SAVE, PROTECTED :: expo_eva=0.5                     ! tuning coefficient liquid precip evaporation
+  !$OMP THREADPRIVATE(expo_eva)
+
+  REAL, SAVE, PROTECTED :: expo_sub                         ! tuning coefficient ice precip sublimation
+  !$OMP THREADPRIVATE(expo_sub)
+
+  REAL, SAVE, PROTECTED :: cice_velo=1.645                  ! factor in the ice fall velocity formulation
+  !$OMP THREADPRIVATE(cice_velo)
+
+  REAL, SAVE, PROTECTED ::  dice_velo=0.16                  ! exponent in the ice fall velocity formulation
+  !$OMP THREADPRIVATE(dice_velo)
+
+  REAL, SAVE, PROTECTED :: dist_liq=300.                    ! typical deph of cloud-top liquid layer in mpcs
+  !$OMP THREADPRIVATE(dist_liq)
+
+  REAL, SAVE, PROTECTED  :: tresh_cl=0.0                  ! cloud fraction threshold for cloud top search
+  !$OMP THREADPRIVATE(tresh_cl)
+
+  !--Parameters for condensation and ice supersaturation
+
+  LOGICAL, SAVE, PROTECTED :: ok_ice_supersat=.FALSE.        ! activates the condensation scheme that allows for ice supersaturation
+  !$OMP THREADPRIVATE(ok_ice_supersat)
+
+  LOGICAL, SAVE, PROTECTED :: ok_unadjusted_clouds=.FALSE.   ! if True, relax the saturation adjustment assumption for ice clouds
+  !$OMP THREADPRIVATE(ok_unadjusted_clouds)
+
+  LOGICAL, SAVE, PROTECTED :: ok_weibull_warm_clouds=.FALSE. ! if True, the weibull condensation scheme replaces the lognormal condensation scheme at positive temperatures
+  !$OMP THREADPRIVATE(ok_weibull_warm_clouds)
+
+  INTEGER, SAVE, PROTECTED :: iflag_cloud_sublim_pdf=3       ! iflag for the distribution of water inside ice clouds
+  !$OMP THREADPRIVATE(iflag_cloud_sublim_pdf)
+
+  REAL, SAVE, PROTECTED :: depo_coef_cirrus=.5               ! [-] deposition coefficient for growth of ice crystals in cirrus clouds
+  !$OMP THREADPRIVATE(depo_coef_cirrus)
+
+  REAL, SAVE, PROTECTED :: capa_cond_cirrus=.5               ! [-] capacitance factor for growth/sublimation of ice crystals in cirrus clouds
+  !$OMP THREADPRIVATE(capa_cond_cirrus)
+
+  REAL, SAVE, PROTECTED :: mu_subl_pdf_lscp=1./3.            ! [-] shape factor of the gamma distribution of water inside ice clouds
+  !$OMP THREADPRIVATE(mu_subl_pdf_lscp)
+  
+  REAL, SAVE, PROTECTED :: beta_pdf_lscp=8.75E-4             ! [] tuning coefficient for the standard deviation of the PDF of water vapor in the clear sky region
+  !$OMP THREADPRIVATE(beta_pdf_lscp)
+  
+  REAL, SAVE, PROTECTED :: temp_thresh_pdf_lscp=188.         ! [K] factor for the PDF fit of water vapor in UTLS - below this temperature, water vapor is homogeneously distributed in the clear sky region
+  !$OMP THREADPRIVATE(temp_thresh_pdf_lscp)
+  
+  REAL, SAVE, PROTECTED :: rhlmid_pdf_lscp=52.8              ! [%] factor for the PDF fit of water vapor in UTLS - below this rel hum wrt liq, std increases with RHliq, above it decreases with RHliq
+  !$OMP THREADPRIVATE(rhlmid_pdf_lscp)
+  
+  REAL, SAVE, PROTECTED :: k0_pdf_lscp=2.80                  ! [-] factor for the PDF fit of water vapor in UTLS
+  !$OMP THREADPRIVATE(k0_pdf_lscp)
+  
+  REAL, SAVE, PROTECTED :: kappa_pdf_lscp=0.0236             ! [] factor for the PDF fit of water vapor in UTLS
+  !$OMP THREADPRIVATE(kappa_pdf_lscp)
+  
+  REAL, SAVE, PROTECTED :: rhl0_pdf_lscp=88.7                ! [%] factor for the PDF fit of water vapor in UTLS
+  !$OMP THREADPRIVATE(rhl0_pdf_lscp)
+  
+  REAL, SAVE, PROTECTED :: a_homofreez=2.349                 ! [-] factor for the Koop homogeneous freezing fit
+  !$OMP THREADPRIVATE(a_homofreez)
+  
+  REAL, SAVE, PROTECTED :: b_homofreez=259.                  ! [K] factor for the Koop homogeneous freezing fit
+  !$OMP THREADPRIVATE(b_homofreez)
+
+  REAL, SAVE, PROTECTED :: delta_hetfreez=1.                 ! [-] value between 0 and 1 to simulate for heterogeneous freezing.
+  !$OMP THREADPRIVATE(delta_hetfreez)
+  
+  REAL, SAVE, PROTECTED :: coef_mixing_lscp=1e-7             ! [-] tuning coefficient for the mixing process
+  !$OMP THREADPRIVATE(coef_mixing_lscp)
+  
+  REAL, SAVE, PROTECTED :: coef_shear_lscp=0.1               ! [-] additional coefficient for the shearing process (subprocess of the mixing process)
+  !$OMP THREADPRIVATE(coef_shear_lscp)
+  
+  REAL, SAVE, PROTECTED :: chi_mixing_lscp=1.1               ! [-] factor for the macro distribution of ISSRs wrt clouds in a gridbox
+  !$OMP THREADPRIVATE(chi_mixing_lscp)
+
+!  REAL, SAVE, PROTECTED :: contrail_cross_section=200000.
+!  !$OMP THREADPRIVATE(contrail_cross_section)
+  !--End of the parameters for condensation and ice supersaturation
+
+  !--Parameters for poprecip
+  LOGICAL, SAVE, PROTECTED :: ok_poprecip=.FALSE.           ! use the processes-oriented formulation of precipitations
+  !$OMP THREADPRIVATE(ok_poprecip)
+
+  LOGICAL, SAVE, PROTECTED :: ok_corr_vap_evasub=.FALSE.    ! use the corrected version of clear-sky water vapor for the evap / subl processes
+  !$OMP THREADPRIVATE(ok_corr_vap_evasub)
+
+  REAL, SAVE, PROTECTED :: cld_lc_lsc_snow=2.e-5            ! snow autoconversion coefficient, stratiform. default from  Chaboureau and PInty 2006
+  !$OMP THREADPRIVATE(cld_lc_lsc_snow)
+
+  REAL, SAVE, PROTECTED :: cld_lc_con_snow=2.e-5            ! snow autoconversion coefficient, convective 
+  !$OMP THREADPRIVATE(cld_lc_con_snow)
+
+  REAL, SAVE, PROTECTED :: rain_int_min=1.e-5               ! Minimum local rain intensity [mm/s] before the decrease in associated precipitation fraction
+  !$OMP THREADPRIVATE(rain_int_min)
+
+  REAL, SAVE, PROTECTED :: thresh_precip_frac=1.E-6         ! precipitation fraction threshold TODO [-]
+  !$OMP THREADPRIVATE(thresh_precip_frac)
+
+  REAL, SAVE, PROTECTED :: tau_mixenv=100000                ! Homogeneization time of mixed phase clouds [s]
+  !$OMP THREADPRIVATE(tau_mixenv)
+
+    REAL, SAVE, PROTECTED :: capa_crystal=1.                ! Sursaturation of ice part in mixed phase clouds [-]
+  !$OMP THREADPRIVATE(capa_crystal)
+
+  REAL, SAVE, PROTECTED :: lmix_mpc=1000                    ! Length of turbulent zones in Mixed Phase Clouds [m]
+  !$OMP THREADPRIVATE(lmix_mpc)
+
+  REAL, SAVE, PROTECTED :: naero5=0.5                       ! Number concentration of aerosol larger than 0.5 microns [scm-3]
+  !$OMP THREADPRIVATE(naero5)
+
+  REAL, SAVE, PROTECTED :: gamma_snwretro = 0.              ! Proportion of snow taken into account in ice retroaction in icefrac_turb [-]
+  !$OMP THREADPRIVATE(gamma_snwretro)
+
+  REAL, SAVE, PROTECTED :: gamma_taud = 1.                  ! Tuning coeff for tau_dissipturb [-]
+  !$OMP THREADPRIVATE(gamma_taud)
+
+  REAL, SAVE, PROTECTED :: gamma_col=1.                     ! A COMMENTER TODO [-]
+  !$OMP THREADPRIVATE(gamma_col)
+
+  REAL, SAVE, PROTECTED :: gamma_agg=1.                     ! A COMMENTER TODO [-]
+  !$OMP THREADPRIVATE(gamma_agg)
+
+  REAL, SAVE, PROTECTED :: gamma_rim=1.                     ! A COMMENTER TODO [-]
+  !$OMP THREADPRIVATE(gamma_rim)
+
+  REAL, SAVE, PROTECTED :: rho_rain=1000.                   ! Rain density [kg/m3]
+  !$OMP THREADPRIVATE(rho_rain)
+
+  REAL, SAVE, PROTECTED :: rho_ice=920.                     ! Ice density  [kg/m3]
+  !$OMP THREADPRIVATE(rho_ice)
+
+  REAL, SAVE, PROTECTED :: r_rain=500.E-6                   ! Rain droplets radius for POPRECIP [m]
+  !$OMP THREADPRIVATE(r_rain)
+
+  REAL, SAVE, PROTECTED :: r_snow=1.E-3                     ! Ice crystals radius for POPRECIP [m]
+  !$OMP THREADPRIVATE(r_snow)
+
+  REAL, SAVE, PROTECTED :: tau_auto_snow_min=100.           ! A COMMENTER TODO [s]
+  !$OMP THREADPRIVATE(tau_auto_snow_min)
+
+  REAL, SAVE, PROTECTED :: tau_auto_snow_max=1000.          ! A COMMENTER TODO [s]
+  !$OMP THREADPRIVATE(tau_auto_snow_max)
+
+  REAL, SAVE, PROTECTED :: eps=1.E-10                       ! A COMMENTER TODO [-]
+  !$OMP THREADPRIVATE(eps)
+
+  REAL, SAVE, PROTECTED :: gamma_melt=1.                    ! A COMMENTER TODO [-]
+  !$OMP THREADPRIVATE(gamma_melt)
+
+  REAL, SAVE, PROTECTED :: alpha_freez=4.                   ! A COMMENTER TODO [-]
+  !$OMP THREADPRIVATE(alpha_freez)
+
+  REAL, SAVE, PROTECTED :: beta_freez=0.1                   ! A COMMENTER TODO [m-3.s-1]
+  !$OMP THREADPRIVATE(beta_freez)
+
+  REAL, SAVE, PROTECTED :: gamma_freez=1.                   ! A COMMENTER TODO [-]
+  !$OMP THREADPRIVATE(gamma_freez)
+
+  REAL, SAVE, PROTECTED :: rain_fallspeed=4.                ! A COMMENTER TODO [m/s]
+  !$OMP THREADPRIVATE(rain_fallspeed)
+
+  REAL, SAVE, PROTECTED :: rain_fallspeed_clr                ! A COMMENTER TODO [m/s]
+  !$OMP THREADPRIVATE(rain_fallspeed_clr)
+
+  REAL, SAVE, PROTECTED :: rain_fallspeed_cld               ! A COMMENTER TODO [m/s]
+  !$OMP THREADPRIVATE(rain_fallspeed_cld)
+
+  REAL, SAVE, PROTECTED :: snow_fallspeed=1.               ! A COMMENTER TODO [m/s]
+  !$OMP THREADPRIVATE(snow_fallspeed)
+
+  REAL, SAVE, PROTECTED :: snow_fallspeed_clr               ! A COMMENTER TODO [m/s]
+  !$OMP THREADPRIVATE(snow_fallspeed_clr)
+
+  REAL, SAVE, PROTECTED :: snow_fallspeed_cld               ! A COMMENTER TODO [m/s]
+  !$OMP THREADPRIVATE(snow_fallspeed_cld)
+  !--End of the parameters for poprecip
+
+! Two parameters used for lmdz_lscp_old only
+  INTEGER, SAVE, PROTECTED :: iflag_oldbug_fisrtilp=0, fl_cor_ebil 
+  !$OMP THREADPRIVATE(iflag_oldbug_fisrtilp,fl_cor_ebil)
+
+CONTAINS
+
+SUBROUTINE lscp_ini(dtime,lunout_in,prt_level_in,ok_ice_supersat_in, iflag_ratqs, fl_cor_ebil_in, &
+                    RCPD_in, RLSTT_in, RLVTT_in, RLMLT_in, RVTMP2_in, &
+                    RTT_in, RD_in, RV_in, RG_in, RPI_in, EPS_W_in)
+
+
+   USE ioipsl_getin_p_mod, ONLY : getin_p
+   USE lmdz_cloudth_ini, ONLY : cloudth_ini
+
+   REAL, INTENT(IN)      :: dtime
+   INTEGER, INTENT(IN)   :: lunout_in,prt_level_in,iflag_ratqs,fl_cor_ebil_in
+   LOGICAL, INTENT(IN)   :: ok_ice_supersat_in
+
+   REAL, INTENT(IN)      :: RCPD_in, RLSTT_in, RLVTT_in, RLMLT_in
+   REAL, INTENT(IN)      :: RVTMP2_in, RTT_in, RD_in, RV_in, RG_in, RPI_in, EPS_W_in
+   character (len=20) :: modname='lscp_ini_mod'
+   character (len=80) :: abort_message
+
+
+    lunout=lunout_in
+    prt_level=prt_level_in
+    fl_cor_ebil=fl_cor_ebil_in
+
+    ok_ice_supersat=ok_ice_supersat_in
+
+    RG=RG_in
+    RD=RD_in
+    RV=RV_in
+    RCPD=RCPD_in
+    RLVTT=RLVTT_in
+    RLSTT=RLSTT_in
+    RLMLT=RLMLT_in
+    RTT=RTT_in
+    RV=RV_in
+    RVTMP2=RVTMP2_in
+    RPI=RPI_in
+    EPS_W=EPS_W_in
+
+
+
+    CALL getin_p('niter_lscp',niter_lscp)
+    CALL getin_p('iflag_evap_prec',iflag_evap_prec)
+    CALL getin_p('seuil_neb',seuil_neb)
+    CALL getin_p('ok_radocond_snow',ok_radocond_snow) 
+    CALL getin_p('t_glace_max',t_glace_max)
+    CALL getin_p('t_glace_min',t_glace_min)
+    CALL getin_p('exposant_glace',exposant_glace) 
+    CALL getin_p('iflag_vice',iflag_vice)
+    CALL getin_p('iflag_t_glace',iflag_t_glace)
+    CALL getin_p('iflag_cloudth_vert',iflag_cloudth_vert)
+    CALL getin_p('iflag_gammasat',iflag_gammasat)
+    CALL getin_p('iflag_rain_incloud_vol',iflag_rain_incloud_vol)
+    CALL getin_p('iflag_bergeron',iflag_bergeron)
+    CALL getin_p('iflag_fisrtilp_qsat',iflag_fisrtilp_qsat)
+    CALL getin_p('iflag_pdf',iflag_pdf)
+    CALL getin_p('iflag_icefrac',iflag_icefrac)
+    CALL getin_p('reevap_ice',reevap_ice)
+    CALL getin_p('cld_lc_lsc',cld_lc_lsc)
+    CALL getin_p('cld_lc_con',cld_lc_con)
+    CALL getin_p('cld_lc_lsc_snow',cld_lc_lsc_snow)
+    CALL getin_p('cld_lc_con_snow',cld_lc_con_snow)
+    CALL getin_p('cld_tau_lsc',cld_tau_lsc)
+    CALL getin_p('cld_tau_con',cld_tau_con)
+    CALL getin_p('cld_expo_lsc',cld_expo_lsc)
+    CALL getin_p('cld_expo_con',cld_expo_con)
+    CALL getin_p('ffallv_lsc',ffallv_lsc)
+    CALL getin_p('ffallv_lsc',ffallv_con)
+    CALL getin_p('coef_eva',coef_eva)
+    coef_sub=coef_eva
+    CALL getin_p('coef_eva_i',coef_sub)
+    CALL getin_p('coef_sub',coef_sub)
+    CALL getin_p('expo_eva',expo_eva)
+    expo_sub=expo_eva
+    CALL getin_p('expo_sub',expo_sub)
+    CALL getin_p('iflag_autoconversion',iflag_autoconversion)
+    CALL getin_p('dist_liq',dist_liq)
+    CALL getin_p('tresh_cl',tresh_cl)
+    CALL getin_p('tau_mixenv',tau_mixenv)
+    CALL getin_p('capa_crystal',capa_crystal)
+    CALL getin_p('lmix_mpc',lmix_mpc)
+    CALL getin_p('naero5',naero5)
+    CALL getin_p('gamma_snwretro',gamma_snwretro)
+    CALL getin_p('gamma_taud',gamma_taud)
+    CALL getin_p('iflag_oldbug_fisrtilp',iflag_oldbug_fisrtilp)
+    CALL getin_p('temp_nowater',temp_nowater)
+    ! for poprecip
+    CALL getin_p('ok_poprecip',ok_poprecip)
+    CALL getin_p('ok_corr_vap_evasub',ok_corr_vap_evasub)
+    CALL getin_p('rain_int_min',rain_int_min) 
+    CALL getin_p('gamma_agg',gamma_agg)
+    CALL getin_p('gamma_col',gamma_col)
+    CALL getin_p('gamma_rim',gamma_rim)
+    CALL getin_p('gamma_freez',gamma_freez)
+    CALL getin_p('gamma_melt',gamma_melt)
+    CALL getin_p('r_snow',r_snow)
+    CALL getin_p('rain_fallspeed',rain_fallspeed)
+    rain_fallspeed_clr=rain_fallspeed
+    rain_fallspeed_cld=rain_fallspeed
+    CALL getin_p('rain_fallspeed_clr',rain_fallspeed_clr)
+    CALL getin_p('rain_fallspeed_cld',rain_fallspeed_cld)
+    CALL getin_p('snow_fallspeed',snow_fallspeed)
+    snow_fallspeed_clr=snow_fallspeed
+    snow_fallspeed_cld=snow_fallspeed
+    CALL getin_p('snow_fallspeed_clr',snow_fallspeed_clr)
+    CALL getin_p('snow_fallspeed_cld',snow_fallspeed_cld)
+    ! for condensation and ice supersaturation
+    CALL getin_p('ok_unadjusted_clouds',ok_unadjusted_clouds)
+    CALL getin_p('ok_weibull_warm_clouds',ok_weibull_warm_clouds)
+    CALL getin_p('iflag_cloud_sublim_pdf',iflag_cloud_sublim_pdf)
+    CALL getin_p('depo_coef_cirrus',depo_coef_cirrus)
+    CALL getin_p('capa_cond_cirrus',capa_cond_cirrus)
+    CALL getin_p('mu_subl_pdf_lscp',mu_subl_pdf_lscp)
+    CALL getin_p('beta_pdf_lscp',beta_pdf_lscp)
+    CALL getin_p('temp_thresh_pdf_lscp',temp_thresh_pdf_lscp)
+    CALL getin_p('rhlmid_pdf_lscp',rhlmid_pdf_lscp)
+    CALL getin_p('k0_pdf_lscp',k0_pdf_lscp)
+    CALL getin_p('kappa_pdf_lscp',kappa_pdf_lscp)
+    CALL getin_p('rhl0_pdf_lscp',rhl0_pdf_lscp)
+    CALL getin_p('a_homofreez',a_homofreez)
+    CALL getin_p('b_homofreez',b_homofreez)
+    CALL getin_p('delta_hetfreez',delta_hetfreez)
+    CALL getin_p('coef_mixing_lscp',coef_mixing_lscp)
+    CALL getin_p('coef_shear_lscp',coef_shear_lscp)
+    CALL getin_p('chi_mixing_lscp',chi_mixing_lscp)
+    !CALL getin_p('contrail_cross_section',contrail_cross_section)
+
+
+
+    WRITE(lunout,*) 'lscp_ini, niter_lscp:', niter_lscp
+    WRITE(lunout,*) 'lscp_ini, iflag_evap_prec:', iflag_evap_prec
+    WRITE(lunout,*) 'lscp_ini, seuil_neb:', seuil_neb
+    WRITE(lunout,*) 'lscp_ini, ok_radocond_snow:', ok_radocond_snow
+    WRITE(lunout,*) 'lscp_ini, t_glace_max:', t_glace_max
+    WRITE(lunout,*) 'lscp_ini, t_glace_min:', t_glace_min
+    WRITE(lunout,*) 'lscp_ini, exposant_glace:', exposant_glace
+    WRITE(lunout,*) 'lscp_ini, iflag_vice:', iflag_vice
+    WRITE(lunout,*) 'lscp_ini, iflag_t_glace:', iflag_t_glace
+    WRITE(lunout,*) 'lscp_ini, iflag_cloudth_vert:', iflag_cloudth_vert
+    WRITE(lunout,*) 'lscp_ini, iflag_gammasat:', iflag_gammasat
+    WRITE(lunout,*) 'lscp_ini, iflag_rain_incloud_vol:', iflag_rain_incloud_vol
+    WRITE(lunout,*) 'lscp_ini, iflag_bergeron:', iflag_bergeron
+    WRITE(lunout,*) 'lscp_ini, iflag_fisrtilp_qsat:', iflag_fisrtilp_qsat
+    WRITE(lunout,*) 'lscp_ini, iflag_pdf', iflag_pdf
+    WRITE(lunout,*) 'lscp_ini, iflag_icefrac', iflag_icefrac
+    WRITE(lunout,*) 'lscp_ini, reevap_ice', reevap_ice
+    WRITE(lunout,*) 'lscp_ini, cld_lc_lsc', cld_lc_lsc
+    WRITE(lunout,*) 'lscp_ini, cld_lc_con', cld_lc_con
+    WRITE(lunout,*) 'lscp_ini, cld_lc_lsc_snow', cld_lc_lsc_snow
+    WRITE(lunout,*) 'lscp_ini, cld_lc_con_snow', cld_lc_con_snow
+    WRITE(lunout,*) 'lscp_ini, cld_tau_lsc', cld_tau_lsc
+    WRITE(lunout,*) 'lscp_ini, cld_tau_con', cld_tau_con
+    WRITE(lunout,*) 'lscp_ini, cld_expo_lsc', cld_expo_lsc
+    WRITE(lunout,*) 'lscp_ini, cld_expo_con', cld_expo_con
+    WRITE(lunout,*) 'lscp_ini, ffallv_lsc', ffallv_lsc
+    WRITE(lunout,*) 'lscp_ini, ffallv_con', ffallv_con
+    WRITE(lunout,*) 'lscp_ini, coef_eva', coef_eva
+    WRITE(lunout,*) 'lscp_ini, coef_sub', coef_sub
+    WRITE(lunout,*) 'lscp_ini, expo_eva', expo_eva
+    WRITE(lunout,*) 'lscp_ini, expo_sub', expo_sub
+    WRITE(lunout,*) 'lscp_ini, iflag_autoconversion', iflag_autoconversion
+    WRITE(lunout,*) 'lscp_ini, dist_liq', dist_liq
+    WRITE(lunout,*) 'lscp_ini, tresh_cl', tresh_cl
+    WRITE(lunout,*) 'lscp_ini, tau_mixenv', tau_mixenv
+    WRITE(lunout,*) 'lscp_ini, capa_crystal', capa_crystal
+    WRITE(lunout,*) 'lscp_ini, lmix_mpc', lmix_mpc
+    WRITE(lunout,*) 'lscp_ini, naero5', naero5
+    WRITE(lunout,*) 'lscp_ini, gamma_snwretro', gamma_snwretro
+    WRITE(lunout,*) 'lscp_ini, gamma_taud', gamma_taud
+    WRITE(lunout,*) 'lscp_ini, iflag_oldbug_fisrtilp', iflag_oldbug_fisrtilp
+    WRITE(lunout,*) 'lscp_ini, fl_cor_ebil', fl_cor_ebil
+    WRITE(lunout,*) 'lscp_ini, temp_nowater', temp_nowater
+    ! for poprecip
+    WRITE(lunout,*) 'lscp_ini, ok_poprecip', ok_poprecip
+    WRITE(lunout,*) 'lscp_ini, ok_corr_vap_evasub', ok_corr_vap_evasub
+    WRITE(lunout,*) 'lscp_ini, rain_int_min:', rain_int_min
+    WRITE(lunout,*) 'lscp_ini, gamma_agg:', gamma_agg
+    WRITE(lunout,*) 'lscp_ini, gamma_col:', gamma_col
+    WRITE(lunout,*) 'lscp_ini, gamma_rim:', gamma_rim
+    WRITE(lunout,*) 'lscp_ini, gamma_freez:', gamma_freez
+    WRITE(lunout,*) 'lscp_ini, gamma_melt:', gamma_melt
+    WRITE(lunout,*) 'lscp_ini, r_snow:', r_snow
+    WRITE(lunout,*) 'lscp_ini, rain_fallspeed_clr:', rain_fallspeed_clr
+    WRITE(lunout,*) 'lscp_ini, rain_fallspeed_cld:', rain_fallspeed_cld
+    WRITE(lunout,*) 'lscp_ini, snow_fallspeed_clr:', snow_fallspeed_clr
+    WRITE(lunout,*) 'lscp_ini, snow_fallspeed_cld:', snow_fallspeed_cld
+    ! for condensation and ice supersaturation
+    WRITE(lunout,*) 'lscp_ini, ok_ice_supersat:', ok_ice_supersat
+    WRITE(lunout,*) 'lscp_ini, ok_unadjusted_clouds:', ok_unadjusted_clouds
+    WRITE(lunout,*) 'lscp_ini, ok_weibull_warm_clouds:', ok_weibull_warm_clouds
+    WRITE(lunout,*) 'lscp_ini, iflag_cloud_sublim_pdf:', iflag_cloud_sublim_pdf
+    WRITE(lunout,*) 'lscp_ini, depo_coef_cirrus:', depo_coef_cirrus
+    WRITE(lunout,*) 'lscp_ini, capa_cond_cirrus:', capa_cond_cirrus
+    WRITE(lunout,*) 'lscp_ini, mu_subl_pdf_lscp:', mu_subl_pdf_lscp
+    WRITE(lunout,*) 'lscp_ini, beta_pdf_lscp:', beta_pdf_lscp
+    WRITE(lunout,*) 'lscp_ini, temp_thresh_pdf_lscp:', temp_thresh_pdf_lscp
+    WRITE(lunout,*) 'lscp_ini, rhlmid_pdf_lscp:', rhlmid_pdf_lscp
+    WRITE(lunout,*) 'lscp_ini, k0_pdf_lscp:', k0_pdf_lscp
+    WRITE(lunout,*) 'lscp_ini, kappa_pdf_lscp:', kappa_pdf_lscp
+    WRITE(lunout,*) 'lscp_ini, rhl0_pdf_lscp:', rhl0_pdf_lscp
+    WRITE(lunout,*) 'lscp_ini, a_homofreez:', a_homofreez
+    WRITE(lunout,*) 'lscp_ini, b_homofreez:', b_homofreez
+    WRITE(lunout,*) 'lscp_ini, delta_hetfreez', delta_hetfreez
+    WRITE(lunout,*) 'lscp_ini, coef_mixing_lscp:', coef_mixing_lscp
+    WRITE(lunout,*) 'lscp_ini, coef_shear_lscp:', coef_shear_lscp
+    WRITE(lunout,*) 'lscp_ini, chi_mixing_lscp:', chi_mixing_lscp
+!    WRITE(lunout,*) 'lscp_ini, contrail_cross_section:', contrail_cross_section
+
+
+
+
+
+    ! check for precipitation sub-time steps
+    IF (ABS(dtime/REAL(niter_lscp)-360.0).GT.0.001) THEN
+        WRITE(lunout,*) 'lscp: it is not expected, see Z.X.Li', dtime
+        WRITE(lunout,*) 'I would prefer a 6 min sub-timestep'
+    ENDIF
+
+    ! check consistency between numerical resolution of autoconversion 
+    ! and other options
+   
+    IF (iflag_autoconversion .EQ. 2) THEN
+        IF ((iflag_vice .NE. 0) .OR. (niter_lscp .GT. 1)) THEN
+           abort_message = 'in lscp, iflag_autoconversion=2 requires iflag_vice=0 and niter_lscp=1'
+           CALL abort_physic (modname,abort_message,1) 
+        ENDIF 
+    ENDIF
+
+
+    IF ( ok_weibull_warm_clouds .AND. .NOT. ok_ice_supersat ) THEN
+      abort_message = 'in lscp, ok_weibull_warm_clouds=y needs ok_ice_supersat=y'
+      CALL abort_physic (modname,abort_message,1)
+    ENDIF
+
+    IF ( ok_unadjusted_clouds .AND. .NOT. ok_ice_supersat ) THEN
+      abort_message = 'in lscp, ok_unadjusted_clouds=y needs ok_ice_supersat=y'
+      CALL abort_physic (modname,abort_message,1)
+    ENDIF
+
+
+    !AA Temporary initialisation
+    a_tr_sca(1) = -0.5
+    a_tr_sca(2) = -0.5
+    a_tr_sca(3) = -0.5
+    a_tr_sca(4) = -0.5
+    
+    CALL cloudth_ini(iflag_cloudth_vert,iflag_ratqs)
+
+RETURN
+
+END SUBROUTINE lscp_ini
+
+END MODULE lmdz_lscp_ini
Index: DZ6/trunk/libf/phylmd/lmdz_lscp_old.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/lmdz_lscp_old.F90	(revision 5267)
+++ 	(revision )
@@ -1,1682 +1,0 @@
-! $Id$
-!
-!
-MODULE lmdz_lscp_old
-CONTAINS
-SUBROUTINE fisrtilp(klon,klev,dtime,paprs,pplay,t,q,ptconv,ratqs,sigma_qtherm, &
-     d_t, d_q, d_ql, d_qi, rneb,rneblsvol,radliq, rain, snow,          &
-     pfrac_impa, pfrac_nucl, pfrac_1nucl,               &
-     frac_impa, frac_nucl, beta,                        &
-     prfl, psfl, rhcl, zqta, fraca,                     &
-     ztv, zpspsk, ztla, zthl, iflag_cld_th,             &
-     iflag_ice_thermo,                                  &
-     cloudth_sth,cloudth_senv,cloudth_sigmath,cloudth_sigmaenv)
-
-
-  !
-  USE icefrac_lsc_mod ! compute ice fraction (JBM 3/14)
-  USE lmdz_cloudth, only : cloudth, cloudth_v3, cloudth_v6
-
-  USE lmdz_lscp_ini, ONLY: prt_level, lunout
-  USE lmdz_lscp_ini, ONLY : fl_cor_ebil 
-  USE lmdz_lscp_ini, ONLY: iflag_t_glace,t_glace_min, t_glace_max, exposant_glace
-  USE lmdz_lscp_ini, ONLY : seuil_neb, rain_int_min, iflag_evap_prec, iflag_oldbug_fisrtilp,a_tr_sca
-  USE lmdz_lscp_ini, ONLY: iflag_cloudth_vert, iflag_rain_incloud_vol 
-  USE lmdz_lscp_ini, ONLY: coef_eva, ffallv_lsc, ffallv_con
-  USE lmdz_lscp_ini, ONLY: cld_tau_lsc, cld_tau_con, cld_lc_lsc, cld_lc_con
-  USE lmdz_lscp_ini, ONLY: reevap_ice, iflag_bergeron, iflag_fisrtilp_qsat, iflag_pdf 
-
-
-
-  IMPLICIT none
-  !======================================================================
-  ! Auteur(s): Z.X. Li (LMD/CNRS)
-  ! Date: le 20 mars 1995
-  ! Objet: condensation et precipitation stratiforme.
-  !        schema de nuage
-  ! Fusion de fisrt (physique sursaturation, P. LeVan K. Laval)
-  !             et ilp (il pleut, L. Li)
-  ! Principales parties:
-  ! P0> Thermalisation des precipitations venant de la couche du dessus
-  ! P1> Evaporation de la precipitation (qui vient du niveau k+1)
-  ! P2> Formation du nuage (en k) 
-  ! P2.A.0> Calcul des grandeurs nuageuses une pdf en creneau
-  ! P2.A.1> Avec les nouvelles PDFs, calcul des grandeurs nuageuses pour 
-  ! les valeurs de T et Q initiales
-  ! P2.A.2> Prise en compte du couplage entre eau condensee et T.
-  ! P2.A.3> Calcul des valeures finales associees a la formation des nuages
-  ! P2.B> Nuage "tout ou rien"
-  ! P2.C> Prise en compte de la Chaleur latente apres formation nuage
-  ! P3> Formation de la precipitation (en k)
-  !======================================================================
-  ! JLD: 
-  ! * Routine probablement fausse (au moins incoherente) si thermcep = .false.
-  ! * fl_cor_ebil doit etre > 0 ; 
-  !   fl_cor_ebil= 0 pour reproduire anciens bugs
-  !======================================================================
-  include "YOMCST.h"
-  include "YOETHF.h"
-  include "FCTTRE.h"
-  !
-  ! Principaux inputs:
-  !
-  REAL, INTENT(IN)                              :: dtime  ! intervalle du temps (s)
-  INTEGER, INTENT(IN)                           :: klon, klev
-  REAL, DIMENSION(klon,klev+1),    INTENT(IN)   :: paprs  ! pression a inter-couche
-  REAL, DIMENSION(klon,klev),      INTENT(IN)   :: pplay  ! pression au milieu de couche
-  REAL, DIMENSION(klon,klev),      INTENT(IN)   :: t      ! temperature (K)
-  REAL, DIMENSION(klon,klev),      INTENT(IN)   :: q      ! humidite specifique (kg/kg)
-  LOGICAL, DIMENSION(klon,klev),   INTENT(IN)   :: ptconv ! points ou le schema de conv. prof. est actif
-  INTEGER,                         INTENT(IN)   :: iflag_cld_th
-  INTEGER,                         INTENT(IN)   :: iflag_ice_thermo
-  !
-  ! Inputs lies aux thermiques
-  ! 
-  REAL, DIMENSION(klon,klev),      INTENT(IN)   :: ztv
-  REAL, DIMENSION(klon,klev),      INTENT(IN)   :: zqta, fraca 
-  REAL, DIMENSION(klon,klev),      INTENT(IN)   :: zpspsk, ztla
-  REAL, DIMENSION(klon,klev),      INTENT(INOUT)   :: zthl
-  !
-  !  Input/output
-  REAL, DIMENSION(klon,klev),      INTENT(INOUT):: ratqs,sigma_qtherm  ! determine la largeur de distribution de vapeur
-  !
-  ! Principaux outputs:
-  !
-  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: d_t  ! incrementation de la temperature (K)
-  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: d_q  ! incrementation de la vapeur d'eau
-  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: d_ql ! incrementation de l'eau liquide
-  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: d_qi ! incrementation de l'eau glace
-  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: rneb, rneblsvol ! fraction nuageuse
-  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: beta ! taux de conversion de l'eau cond
-  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: radliq ! eau liquide utilisee dans rayonnements
-  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: rhcl ! humidite relative en ciel clair
-  REAL, DIMENSION(klon),           INTENT(OUT)  :: rain
-  REAL, DIMENSION(klon),           INTENT(OUT)  :: snow
-  REAL, DIMENSION(klon,klev+1),    INTENT(OUT)  :: prfl
-  REAL, DIMENSION(klon,klev+1),    INTENT(OUT)  :: psfl 
-
-  !AA
-  ! Coeffients de fraction lessivee : pour OFF-LINE
-  !
-  REAL, DIMENSION(klon,klev),      INTENT(INOUT)  :: pfrac_nucl
-  REAL, DIMENSION(klon,klev),      INTENT(INOUT)  :: pfrac_1nucl
-  REAL, DIMENSION(klon,klev),      INTENT(INOUT)  :: pfrac_impa
-  !
-  ! Fraction d'aerosols lessivee par impaction et par nucleation
-  ! POur ON-LINE
-  !
-  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: frac_impa
-  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: frac_nucl
-  REAL, DIMENSION(klon,klev), INTENT(OUT) :: cloudth_sth,cloudth_senv
-  REAL, DIMENSION(klon,klev), INTENT(OUT) :: cloudth_sigmath,cloudth_sigmaenv
-  !AA
-  ! --------------------------------------------------------------------------------
-  !
-  ! Options du programme:
-  !
-
-  REAL :: smallestreal
-
-  INTEGER, PARAMETER :: ninter=5 ! sous-intervals pour la precipitation
-  LOGICAL, PARAMETER :: cpartiel=.TRUE. ! condensation partielle
-  REAL, PARAMETER :: t_coup=234.0
-  REAL, PARAMETER :: DDT0=.01
-  REAL, PARAMETER :: ztfondue=278.15
-  ! --------------------------------------------------------------------------------
-  !
-  ! Variables locales:
-  !
-  INTEGER :: i, k, n, kk
-  REAL :: qsl, qsi
-  REAL :: zct      ,zcl
-  INTEGER :: ncoreczq  
-  REAL, DIMENSION(klon,klev) :: ctot,ctot_vol
-  REAL, DIMENSION(klon) :: zqs, zdqs, zdqsdT_raw, Tbef,qlbef,DT
-  REAL :: zdelta, zcor, zcvm5  
-  REAL ::num,denom
-
-  LOGICAL, DIMENSION(klon) :: lognormale,convergence
-  LOGICAL :: ice_thermo
-  INTEGER, DIMENSION(klon) :: n_i
-  INTEGER :: iter
-  REAL :: cste
-
-  REAL, DIMENSION(klon) :: zpdf_sig,zpdf_k,zpdf_delta, Zpdf_a,zpdf_b,zpdf_e1,zpdf_e2, qcloud
-  REAL :: erf   
- 
-  REAL :: zqev, zqevt, zqev0,zqevi, zqevti, zdelq 
-  REAL, DIMENSION(klon) :: zrfl(klon), zrfln(klon), zrflclr(klon), zrflcld(klon), d_zrfl_clr_cld(klon), d_zifl_clr_cld(klon), d_zrfl_cld_clr(klon), d_zifl_cld_clr(klon) 
-
-  REAL, DIMENSION(klon) :: zifl, zifln, ziflclr, ziflcld, zoliq, zcond, zq, zqn, zoliqp, zoliqi, zt
-! JBM (3/14) nexpo is replaced by exposant_glace
-! REAL nexpo ! exponentiel pour glace/eau
-! INTEGER, PARAMETER :: nexpo=6
-  INTEGER :: exposant_glace_old
-  REAL :: t_glace_min_old, ztot
-  REAL, DIMENSION(klon) ::  zdz,zrho , zrhol, zfice,zneb,znebprecip
-  REAL :: zchau      ,zfroi      
-  REAL, DIMENSION(klon) :: znebprecipclr, znebprecipcld, tot_zneb, tot_znebn, d_tot_zneb, d_znebprecip_clr_cld, d_znebprecip_cld_clr, dzfice
-  REAL :: zmelt, zpluie, zice
-  REAL :: zsolid
-!!!!
-!  Variables pour Bergeron
-  REAL :: zcp, coef1, DeltaT, Deltaq, Deltaqprecl
-  REAL, DIMENSION(klon) :: zqpreci, zqprecl
-! Variable pour conservation enegie des precipitations
-  REAL, DIMENSION(klon) :: zmqc
-  !
-  LOGICAL, SAVE :: appel1er=.TRUE.
-  !$OMP THREADPRIVATE(appel1er)
-  !
-! iflag_oldbug_fisrtilp=0 enleve le BUG par JYG : tglace_min -> tglace_max
-! iflag_oldbug_fisrtilp=1 ajoute le BUG
-  !---------------------------------------------------------------
-  !
-  ! Fonctions en ligne:
-  !
-  REAL ::  fallvs,fallvc, zzz ! Vitesse de chute pour cristaux de glace
-                     ! (Heymsfield & Donner, 1990)
-  fallvc (zzz) = 3.29/2.0 * ((zzz)**0.16) * ffallv_con
-  fallvs (zzz) = 3.29/2.0 * ((zzz)**0.16) * ffallv_lsc
-  !
-  !---------------------------------------------------------------
-  !AA Variables traceurs:
-  !AA  Provisoire !!! Parametres alpha du lessivage
-  !AA  A priori on a 4 scavenging # possibles
-  !
-  ! Variables intermediaires
-  !
-  REAL :: zalpha_tr, zfrac_lessi
-  REAL, DIMENSION(klon) :: zprec_cond
-  !AA
-! RomP >>> 15 nov 2012
-! RomP <<<
-  REAL, DIMENSION(klon) :: zmair
-  REAL :: zcpair, zcpeau
-  !     Pour la conversion eau-neige
-  REAL, DIMENSION(klon) :: zlh_solid
-  REAL :: zm_solid
-
-
-  !
-  !ym
-!CR: pour iflag_ice_thermo=2, on active que la convection
-!  ice_thermo = iflag_ice_thermo .GE. 1
-
-  
-  znebprecip(:)=0.
-
-!<LTP
-  smallestreal=1.e-9
-  znebprecipclr(:)=0.
-  znebprecipcld(:)=0.
-!>LTP
-
-  ice_thermo = (iflag_ice_thermo .EQ. 1).OR.(iflag_ice_thermo .GE. 3)
-  zdelq=0.0
-  ctot_vol(1:klon,1:klev)=0.0
-  rneblsvol(1:klon,1:klev)=0.0
-
-  if (prt_level>9)write(lunout,*)'NUAGES4 A. JAM'
-  IF (appel1er) THEN
-     WRITE(lunout,*) 'fisrtilp, ninter:', ninter
-     WRITE(lunout,*) 'fisrtilp, cpartiel:', cpartiel
-     WRITE(lunout,*) 'FISRTILP VERSION LUDO'
-     
-     IF (ABS(dtime/REAL(ninter)-360.0).GT.0.001) THEN
-        WRITE(lunout,*) 'fisrtilp: Ce n est pas prevu, voir Z.X.Li', dtime
-        WRITE(lunout,*) 'Je prefere un sous-intervalle de 6 minutes'
-        !         CALL abort
-     ENDIF
-     appel1er = .FALSE.
-     !
-     !cdir collapse
-     DO k = 1, klev
-        DO i = 1, klon
-           pfrac_nucl(i,k)=1.
-           pfrac_1nucl(i,k)=1.
-           pfrac_impa(i,k)=1.
-           beta(i,k)=0.  !RomP initialisation
-        ENDDO
-     ENDDO
-
-  ENDIF          !  test sur appel1er
-  !
-  !MAf Initialisation a 0 de zoliq
-  !      DO i = 1, klon
-  !         zoliq(i)=0.
-  !      ENDDO 
-  ! Determiner les nuages froids par leur temperature
-  !  nexpo regle la raideur de la transition eau liquide / eau glace.
-  !
-!CR: on est oblige de definir des valeurs fisrt car les valeurs de newmicro ne sont pas les memes par defaut
-  IF (iflag_t_glace.EQ.0) THEN
-!   ztglace = RTT - 15.0
-    t_glace_min_old = RTT - 15.0
-    !AJ<
-    IF (ice_thermo) THEN
-!     nexpo = 2
-      exposant_glace_old = 2
-    ELSE
-!     nexpo = 6
-      exposant_glace_old = 6
-    ENDIF
-    
-  ENDIF
-  
-!!  RLVTT = 2.501e6 ! pas de redefinition des constantes physiques (jyg)
-!!  RLSTT = 2.834e6 ! pas de redefinition des constantes physiques (jyg)
-!>AJ
-  !cc      nexpo = 1
-  !
-  ! Initialiser les sorties:
-  !
-  !cdir collapse
-  DO k = 1, klev+1
-     DO i = 1, klon
-        prfl(i,k) = 0.0
-        psfl(i,k) = 0.0
-     ENDDO
-  ENDDO
-
-  !cdir collapse
-
-  DO k = 1, klev
-     DO i = 1, klon
-        d_t(i,k) = 0.0
-        d_q(i,k) = 0.0
-        d_ql(i,k) = 0.0
-        d_qi(i,k) = 0.0
-        rneb(i,k) = 0.0
-        radliq(i,k) = 0.0
-        frac_nucl(i,k) = 1. 
-        frac_impa(i,k) = 1. 
-     ENDDO
-  ENDDO
-  DO i = 1, klon
-     rain(i) = 0.0
-     snow(i) = 0.0
-     zoliq(i)=0.
-     !     ENDDO
-     !
-     ! Initialiser le flux de precipitation a zero
-     !
-     !     DO i = 1, klon
-     zrfl(i) = 0.0
-     zifl(i) = 0.0
-!<LTP
-     zrflclr(i) = 0.0
-     ziflclr(i) = 0.0
-     zrflcld(i) = 0.0
-     ziflcld(i) = 0.0
-     tot_zneb(i) = 0.0
-     tot_znebn(i) = 0.0
-     d_tot_zneb(i) = 0.0
-!>LTP
-
-     zneb(i) = seuil_neb
-  ENDDO
-  !
-  !
-  !AA Pour plus de securite 
-
-  zalpha_tr   = 0.
-  zfrac_lessi = 0.
-
-  !AA==================================================================
-  !
-  ncoreczq=0
-  ! BOUCLE VERTICALE (DU HAUT VERS LE BAS)
-  !
-  DO k = klev, 1, -1
-     !
-     !AA===============================================================
-     !
-     ! Initialisation temperature et vapeur
-     DO i = 1, klon
-        zt(i)=t(i,k)
-        zq(i)=q(i,k)
-     ENDDO
-     !
-     ! ----------------------------------------------------------------
-     ! P0> Thermalisation des precipitations venant de la couche du dessus
-     ! ----------------------------------------------------------------
-     ! Calculer la varition de temp. de l'air du a la chaleur sensible
-     ! transporter par la pluie. On thermalise la pluie avec l'air de la couche.
-     ! Cette quantite de pluie qui est thermalisee, et devra continue a l'etre lors
-     ! des differentes transformations thermodynamiques. Cette masse d'eau doit
-     ! donc etre ajoute a l'humidite de la couche lorsque l'on calcule la variation
-     ! de l'enthalpie  de la couche avec la temperature
-     ! Variables calculees ou modifiees:
-     !   -  zt: temperature de la cocuhe
-     !   - zmqc: masse de precip qui doit etre thermalisee
-     !
-     IF(k.LE.klev-1) THEN         
-        DO i = 1, klon
-           !IM
-           zmair(i)=(paprs(i,k)-paprs(i,k+1))/RG
-           ! il n'y a pas encore d'eau liquide ni glace dans la maiille, donc zq suffit
-           zcpair=RCPD*(1.0+RVTMP2*zq(i))
-           zcpeau=RCPD*RVTMP2
-         if (fl_cor_ebil .GT. 0) then
-           ! zmqc: masse de precip qui doit etre thermalisee avec l'air de la couche atm 
-           ! pour s'assurer que la precip arrivant au sol aura bien la temperature de la 
-           ! derniere couche
-           zmqc(i) = (zrfl(i)+zifl(i))*dtime/zmair(i)
-           ! t(i,k+1)+d_t(i,k+1): nouvelle temp de la couche au dessus
-           zt(i) = ( (t(i,k+1)+d_t(i,k+1))*zmqc(i)*zcpeau + zcpair*zt(i) ) &
-                 / (zcpair + zmqc(i)*zcpeau)
-         else ! si on maintient les anciennes erreurs
-           zt(i) = ( (t(i,k+1)+d_t(i,k+1))*zrfl(i)*dtime*zcpeau &
-                + zmair(i)*zcpair*zt(i) ) &
-                / (zmair(i)*zcpair + zrfl(i)*dtime*zcpeau)
-         end if
-        ENDDO
-     ELSE  ! IF(k.LE.klev-1) 
-        DO i = 1, klon 
-           zmair(i)=(paprs(i,k)-paprs(i,k+1))/RG 
-           zmqc(i) = 0.
-        ENDDO
-     ENDIF ! end IF(k.LE.klev-1)
-     !
-     ! ----------------------------------------------------------------
-     ! P1> Calcul de l'evaporation de la precipitation
-     ! ----------------------------------------------------------------
-     ! On evapore une partie des precipitations venant de la maille du dessus.
-     ! On calcule l'evaporation et la sublimation des precipitations, jusqu'a
-     ! ce que la fraction de cette couche qui est sous le nuage soit saturee.
-     ! Variables calculees ou modifiees:
-     !   - zrfl et zifl: flux de precip liquide et glace
-     !   - zq, zt: humidite et temperature de la cocuhe
-     !   - zmqc: masse de precip qui doit etre thermalisee
-     !
-     IF (iflag_evap_prec>=1) THEN
-        DO i = 1, klon
-!          S'il y a des precipitations
-           IF (zrfl(i)+zifl(i).GT.0.) THEN
-              ! Calcul du qsat
-              IF (thermcep) THEN
-                 zdelta=MAX(0.,SIGN(1.,RTT-zt(i)))
-                 zqs(i)= R2ES*FOEEW(zt(i),zdelta)/pplay(i,k)
-                 zqs(i)=MIN(0.5,zqs(i))
-                 zcor=1./(1.-RETV*zqs(i))
-                 zqs(i)=zqs(i)*zcor
-              ELSE
-                 IF (zt(i) .LT. t_coup) THEN
-                    zqs(i) = qsats(zt(i)) / pplay(i,k)
-                 ELSE
-                    zqs(i) = qsatl(zt(i)) / pplay(i,k)
-                 ENDIF
-              ENDIF
-           ENDIF ! (zrfl(i)+zifl(i).GT.0.)
-        ENDDO
-!AJ<
-
-       IF (.NOT. ice_thermo) THEN
-        DO i = 1, klon
-!          S'il y a des precipitations
-           IF (zrfl(i)+zifl(i).GT.0.) THEN
-                ! Evap max pour ne pas saturer la fraction sous le nuage
-                ! Evap max jusqu'à atteindre la saturation dans la partie
-                ! de la maille qui est sous le nuage de la couche du dessus
-                !!! On ne tient compte de cette fraction que sous une seule
-                !!! couche sous le nuage
-                zqev = MAX (0.0, (zqs(i)-zq(i))*zneb(i) )
-             ! Ajout de la prise en compte des precip a thermiser
-             ! avec petite reecriture 
-             if  (fl_cor_ebil .GT. 0) then ! nouveau
-                ! Calcul de l'evaporation du flux de precip herite
-                !   d'au-dessus
-                zqevt = coef_eva * (1.0-zq(i)/zqs(i)) * SQRT(zrfl(i)) &
-                     * zmair(i)/pplay(i,k)*zt(i)*RD
-                zqevt = MAX(0.0,MIN(zqevt,zrfl(i))) * dtime/zmair(i)
-
-                ! Seuil pour ne pas saturer la fraction sous le nuage
-                zqev = MIN (zqev, zqevt)
-                ! Nouveau flux de precip
-                zrfln(i) = zrfl(i) - zqev*zmair(i)/dtime
-                ! Aucun flux liquide pour T < t_coup, on reevapore tout.
-                IF (zt(i) .LT. t_coup.and.reevap_ice) THEN
-                  zrfln(i)=0.
-                  zqev = (zrfl(i)-zrfln(i))/zmair(i)*dtime
-                END IF
-                ! Nouvelle vapeur 
-                zq(i) = zq(i) + zqev
-                zmqc(i) = zmqc(i)-zqev
-                ! Nouvelle temperature (chaleur latente)
-                zt(i) = zt(i) - zqev &
-                     * RLVTT/RCPD/(1.0+RVTMP2*(zq(i)+zmqc(i)))
-!!JLD debut de partie a supprimer a terme
-            else ! if  (fl_cor_ebil .GT. 0)
-                ! Calcul de l'evaporation du flux de precip herite
-                !   d'au-dessus
-                zqevt = coef_eva * (1.0-zq(i)/zqs(i)) * SQRT(zrfl(i)) &
-                     * (paprs(i,k)-paprs(i,k+1))/pplay(i,k)*zt(i)*RD/RG
-                zqevt = MAX(0.0,MIN(zqevt,zrfl(i))) &
-                     * RG*dtime/(paprs(i,k)-paprs(i,k+1))
-                ! Seuil pour ne pas saturer la fraction sous le nuage
-                zqev = MIN (zqev, zqevt)
-                ! Nouveau flux de precip
-                zrfln(i) = zrfl(i) - zqev*(paprs(i,k)-paprs(i,k+1)) &
-                     /RG/dtime
-                ! Aucun flux liquide pour T < t_coup
-                IF (zt(i) .LT. t_coup.and.reevap_ice) zrfln(i)=0.
-                ! Nouvelle vapeur 
-                zq(i) = zq(i) - (zrfln(i)-zrfl(i)) &
-                     * (RG/(paprs(i,k)-paprs(i,k+1)))*dtime
-                ! Nouvelle temperature (chaleur latente)
-                zt(i) = zt(i) + (zrfln(i)-zrfl(i)) &
-                     * (RG/(paprs(i,k)-paprs(i,k+1)))*dtime &
-                     * RLVTT/RCPD/(1.0+RVTMP2*zq(i))
-              end if ! if  (fl_cor_ebil .GT. 0)
-!!JLD fin de partie a supprimer a terme
-                zrfl(i) = zrfln(i)
-                zifl(i) = 0.
-           ENDIF ! (zrfl(i)+zifl(i).GT.0.)
-        ENDDO
-!
-       ELSE ! (.NOT. ice_thermo) 
-!      ================================
-!      Avec thermodynamique de la glace
-!      ================================
-        DO i = 1, klon
-
-
-!AJ<
-!        S'il y a des precipitations
-         IF (zrfl(i)+zifl(i).GT.0.) THEN
-
-        !LTP<
-        !On ne tient compte que du flux de précipitation en ciel clair dans le calcul de l'évaporation.
-                IF (iflag_evap_prec==4) THEN
-                        zrfl(i) = zrflclr(i)
-                        zifl(i) = ziflclr(i)
-                ENDIF
-        
-        !>LTP
-
-         IF (iflag_evap_prec==1) THEN
-            znebprecip(i)=zneb(i)
-         ELSE
-            znebprecip(i)=MAX(zneb(i),znebprecip(i))
-         ENDIF
-         
-         IF (iflag_evap_prec==4) THEN
-        ! Evap max pour ne pas saturer toute la maille
-         zqev0 = MAX (0.0, zqs(i)-zq(i))
-         ELSE 
-        ! Evap max pour ne pas saturer la fraction sous le nuage
-         zqev0 = MAX (0.0, (zqs(i)-zq(i))*znebprecip(i) )
-         ENDIF
-
-         !JAM
-         ! On differencie qsat pour l'eau et la glace
-         ! Si zdelta=1. --> glace
-         ! Si zdelta=0. --> eau liquide
-        
-         ! Calcul du qsat par rapport a l'eau liquide
-         qsl= R2ES*FOEEW(zt(i),0.)/pplay(i,k)
-         qsl= MIN(0.5,qsl)
-         zcor= 1./(1.-RETV*qsl)
-         qsl= qsl*zcor
-         
-         ! Calcul de l'evaporation du flux de precip venant du dessus
-         ! Formulation en racine du flux de precip
-         ! (Klemp & Wilhelmson, 1978; Sundqvist, 1988)
-         IF (iflag_evap_prec==3) THEN
-         zqevt = znebprecip(i)*coef_eva*(1.0-zq(i)/qsl) &
-              *SQRT(zrfl(i)/max(1.e-4,znebprecip(i))) &
-              *(paprs(i,k)-paprs(i,k+1))/pplay(i,k)*zt(i)*RD/RG
-!<LTP
-         ELSE IF (iflag_evap_prec==4) THEN
-         zqevt = znebprecipclr(i)*coef_eva*(1.0-zq(i)/qsl) &
-              *SQRT(zrfl(i)/max(1.e-8,znebprecipclr(i))) &
-              *(paprs(i,k)-paprs(i,k+1))/pplay(i,k)*zt(i)*RD/RG
-!>LTP
-        ELSE 
-         zqevt = 1.*coef_eva*(1.0-zq(i)/qsl)*SQRT(zrfl(i)) &
-              *(paprs(i,k)-paprs(i,k+1))/pplay(i,k)*zt(i)*RD/RG
-         ENDIF
-
-
-         zqevt = MAX(0.0,MIN(zqevt,zrfl(i))) &
-              *RG*dtime/(paprs(i,k)-paprs(i,k+1)) 
-         
-         ! Calcul du qsat par rapport a la glace
-         qsi= R2ES*FOEEW(zt(i),1.)/pplay(i,k)
-         qsi= MIN(0.5,qsi)
-         zcor= 1./(1.-RETV*qsi)
-         qsi= qsi*zcor
-
-         ! Calcul de la sublimation du flux de precip solide herite
-         !   d'au-dessus
-         IF (iflag_evap_prec==3) THEN
-         zqevti = znebprecip(i)*coef_eva*(1.0-zq(i)/qsi) &
-              *SQRT(zifl(i)/max(1.e-4,znebprecip(i))) &
-              *(paprs(i,k)-paprs(i,k+1))/pplay(i,k)*zt(i)*RD/RG
-!<LTP
-         ELSE IF (iflag_evap_prec==4) THEN
-         zqevti = znebprecipclr(i)*coef_eva*(1.0-zq(i)/qsi) &
-              *SQRT(zifl(i)/max(1.e-8,znebprecipclr(i))) &
-              *(paprs(i,k)-paprs(i,k+1))/pplay(i,k)*zt(i)*RD/RG
-!>LTP
-         ELSE
-         zqevti = 1.*coef_eva*(1.0-zq(i)/qsi)*SQRT(zifl(i)) &
-              *(paprs(i,k)-paprs(i,k+1))/pplay(i,k)*zt(i)*RD/RG
-         ENDIF
-         zqevti = MAX(0.0,MIN(zqevti,zifl(i))) &
-              *RG*dtime/(paprs(i,k)-paprs(i,k+1))   
-
-       
-        !JAM
-        ! Limitation de l'evaporation. On s'assure qu'on ne sature pas 
-        ! la fraction de la couche sous le nuage sinon on repartit zqev0 
-        ! en conservant la proportion liquide / glace
-     
-         IF (zqevt+zqevti.GT.zqev0) THEN
-            zqev=zqev0*zqevt/(zqevt+zqevti)
-            zqevi=zqev0*zqevti/(zqevt+zqevti)
-         ELSE
-!JLD je ne comprends pas les lignes ci-dessous. On repartit les precips
-!       liquides et solides meme si on ne sature pas la couche. 
-!       A mon avis, le test est inutile, et il faudrait tout remplacer par:
-!            zqev=zqevt
-!            zqevi=zqevti
-             IF (zqevt+zqevti.GT.0.) THEN
-                zqev=MIN(zqev0*zqevt/(zqevt+zqevti),zqevt)
-                zqevi=MIN(zqev0*zqevti/(zqevt+zqevti),zqevti)
-             ELSE
-             zqev=0.
-             zqevi=0.
-             ENDIF
-         ENDIF
-
-         ! Nouveaux flux de precip liquide et solide 
-         zrfln(i) = Max(0.,zrfl(i) - zqev*(paprs(i,k)-paprs(i,k+1)) &
-                                 /RG/dtime)
-         zifln(i) = Max(0.,zifl(i) - zqevi*(paprs(i,k)-paprs(i,k+1)) &
-                                 /RG/dtime)
-
-         ! Mise a jour de la vapeur, temperature et flux de precip
-         zq(i) = zq(i) - (zrfln(i)+zifln(i)-zrfl(i)-zifl(i)) &
-                  * (RG/(paprs(i,k)-paprs(i,k+1)))*dtime
-       if (fl_cor_ebil .GT. 0) then ! avec correction thermalisation des precips
-         zmqc(i) = zmqc(i) + (zrfln(i)+zifln(i)-zrfl(i)-zifl(i)) &
-                  * (RG/(paprs(i,k)-paprs(i,k+1)))*dtime
-         zt(i) = zt(i) + (zrfln(i)-zrfl(i)) &
-                  * (RG/(paprs(i,k)-paprs(i,k+1)))*dtime &
-                  * RLVTT/RCPD/(1.0+RVTMP2*(zq(i)+zmqc(i))) &
-                  + (zifln(i)-zifl(i)) &
-                  * (RG/(paprs(i,k)-paprs(i,k+1)))*dtime &
-                  * RLSTT/RCPD/(1.0+RVTMP2*(zq(i)+zmqc(i)))
-       else ! sans correction thermalisation des precips
-         zt(i) = zt(i) + (zrfln(i)-zrfl(i)) &
-                  * (RG/(paprs(i,k)-paprs(i,k+1)))*dtime &
-                  * RLVTT/RCPD/(1.0+RVTMP2*zq(i)) &
-                  + (zifln(i)-zifl(i)) &
-                  * (RG/(paprs(i,k)-paprs(i,k+1)))*dtime &
-                  * RLSTT/RCPD/(1.0+RVTMP2*zq(i))
-       end if
-        ! Nouvelles vaeleurs des precips liquides et solides 
-         zrfl(i) = zrfln(i)
-         zifl(i) = zifln(i)
-
-!<LTP
-        IF (iflag_evap_prec==4) THEN
-                zrflclr(i) = zrfl(i)
-                ziflclr(i) = zifl(i)    
-                IF(zrflclr(i) + ziflclr(i) .LE. 0) THEN
-                        znebprecipclr(i) = 0.
-                ENDIF   
-                zrfl(i) = zrflclr(i) + zrflcld(i)
-                zifl(i) = ziflclr(i) + ziflcld(i) 
-        ENDIF
-!>LTP        
-
-
-!CR ATTENTION: deplacement de la fonte de la glace
-!jyg : Bug !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! jyg
-!!!        zmelt = ((zt(i)-273.15)/(ztfondue-273.15))**2  !!!!!!!!! jyg
-!jyg : Bug !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! jyg
-           zmelt = ((zt(i)-273.15)/(ztfondue-273.15))             ! jyg
-           ! fraction de la precip solide qui est fondue
-           zmelt = MIN(MAX(zmelt,0.),1.)
-           ! Fusion de la glace
-!<LTP
-           IF (iflag_evap_prec==4) THEN
-                   zrflclr(i)=zrflclr(i)+zmelt*ziflclr(i)
-                   zrflcld(i)=zrflcld(i)+zmelt*ziflcld(i)
-                   zrfl(i)=zrflclr(i)+zrflcld(i)
-!>LTP        
-           ELSE
-                   zrfl(i)=zrfl(i)+zmelt*zifl(i)
-           ENDIF
-           if (fl_cor_ebil .LE. 0) then
-             ! the following line should not be here. Indeed, if zifl is modified
-             ! now, zifl(i)*zmelt is no more the amount of ice that has melt
-             ! and therefore the change in temperature computed below is wrong
-             zifl(i)=zifl(i)*(1.-zmelt)
-           end if
-           ! Chaleur latente de fusion
-        if (fl_cor_ebil .GT. 0) then ! avec correction thermalisation des precips
-           zt(i)=zt(i)-zifl(i)*zmelt*(RG*dtime)/(paprs(i,k)-paprs(i,k+1)) &
-                      *RLMLT/RCPD/(1.0+RVTMP2*(zq(i)+zmqc(i)))
-        else ! sans correction thermalisation des precips
-           zt(i)=zt(i)-zifl(i)*zmelt*(RG*dtime)/(paprs(i,k)-paprs(i,k+1)) &
-                      *RLMLT/RCPD/(1.0+RVTMP2*zq(i))
-        end if
-           if (fl_cor_ebil .GT. 0) then ! correction bug, deplacement ligne precedente
-!<LTP
-             IF (iflag_evap_prec==4) THEN
-                   ziflclr(i)=ziflclr(i)*(1.-zmelt)
-                   ziflcld(i)=ziflcld(i)*(1.-zmelt)
-                   zifl(i)=ziflclr(i)+ziflcld(i)
-!>LTP        
-             ELSE
-                   zifl(i)=zifl(i)*(1.-zmelt)
-             ENDIF
-           end if
-
-           ELSE
-              ! Si on n'a plus de pluies, on reinitialise a 0 la farcion
-              ! sous nuageuse utilisee pour la pluie.
-              znebprecip(i)=0.
-           ENDIF ! (zrfl(i)+zifl(i).GT.0.)
-        ENDDO
-
-      ENDIF ! (.NOT. ice_thermo) 
-     
-     ! ----------------------------------------------------------------
-     ! Fin evaporation de la precipitation
-     ! ----------------------------------------------------------------
-     ENDIF ! (iflag_evap_prec>=1)
-     !
-     ! Calculer Qs et L/Cp*dQs/dT:
-     !
-     IF (thermcep) THEN
-        DO i = 1, klon
-           zdelta = MAX(0.,SIGN(1.,RTT-zt(i)))
-           zcvm5 = R5LES*RLVTT*(1.-zdelta) + R5IES*RLSTT*zdelta
-       if  (fl_cor_ebil .GT. 0) then ! nouveau
-           zcvm5 = zcvm5 /RCPD/(1.0+RVTMP2*(zq(i)+zmqc(i)))
-       else    
-           zcvm5 = zcvm5 /RCPD/(1.0+RVTMP2*zq(i))
-       endif
-           zqs(i) = R2ES*FOEEW(zt(i),zdelta)/pplay(i,k)
-           zqs(i) = MIN(0.5,zqs(i))
-           zcor = 1./(1.-RETV*zqs(i))
-           zqs(i) = zqs(i)*zcor
-           zdqs(i) = FOEDE(zt(i),zdelta,zcvm5,zqs(i),zcor)
-           zdqsdT_raw(i) = zdqs(i)*  &
-         &         RCPD*(1.0+RVTMP2*zq(i)) / (RLVTT*(1.-zdelta) + RLSTT*zdelta)
-        ENDDO
-     ELSE
-        DO i = 1, klon
-           IF (zt(i).LT.t_coup) THEN
-              zqs(i) = qsats(zt(i))/pplay(i,k)
-              zdqs(i) = dqsats(zt(i),zqs(i))
-           ELSE
-              zqs(i) = qsatl(zt(i))/pplay(i,k)
-              zdqs(i) = dqsatl(zt(i),zqs(i))
-           ENDIF
-        ENDDO
-     ENDIF
-     !
-     ! Determiner la condensation partielle et calculer la quantite
-     ! de l'eau condensee:
-     !
-!verification de la valeur de iflag_fisrtilp_qsat pour iflag_ice_thermo=1
-!       if ((iflag_ice_thermo.eq.1).and.(iflag_fisrtilp_qsat.ne.0)) then
-!         write(*,*) " iflag_ice_thermo==1 requires iflag_fisrtilp_qsat==0", &
-!        " but iflag_fisrtilp_qsat=",iflag_fisrtilp_qsat, ". Might as well stop here."
-!         stop
-!       endif
-
-     ! ----------------------------------------------------------------
-     ! P2> Formation du nuage
-     ! ----------------------------------------------------------------
-     ! Variables calculees:
-     !   rneb  : fraction nuageuse
-     !   zcond : eau condensee moyenne dans la maille.
-     !   rhcl: humidite relative ciel-clair
-     !   zt : temperature de la maille
-     ! ----------------------------------------------------------------
-     !
-     IF (cpartiel) THEN
-        ! -------------------------
-        ! P2.A> Nuage fractionnaire
-        ! -------------------------
-        !
-        !   Calcul de l'eau condensee et de la fraction nuageuse et de l'eau
-        !   nuageuse a partir des PDF de Sandrine Bony.
-        !   rneb  : fraction nuageuse
-        !   zqn   : eau totale dans le nuage
-        !   zcond : eau condensee moyenne dans la maille.
-        !  on prend en compte le réchauffement qui diminue la partie
-        ! condensee
-        !
-        !   Version avec les raqts
-
-        ! ----------------------------------------------------------------
-        ! P2.A.0> Calcul des grandeurs nuageuses une pdf en creneau
-        ! ----------------------------------------------------------------
-        if (iflag_pdf.eq.0) then
-
-           ! version creneau de (Li, 1998)
-           do i=1,klon
-              zdelq = min(ratqs(i,k),0.99) * zq(i)
-              rneb(i,k) = (zq(i)+zdelq-zqs(i)) / (2.0*zdelq)
-              zqn(i) = (zq(i)+zdelq+zqs(i))/2.0
-           enddo
-
-        else !  if (iflag_pdf.eq.0)
-           ! ----------------------------------------------------------------
-           ! P2.A.1> Avec les nouvelles PDFs, calcul des grandeurs nuageuses pour 
-           ! les valeurs de T et Q initiales
-           ! ----------------------------------------------------------------
-           do i=1,klon
-              if(zq(i).lt.1.e-15) then
-                 ncoreczq=ncoreczq+1
-                 zq(i)=1.e-15
-              endif
-           enddo
-
-           if (iflag_cld_th>=5) then
-
-              if (iflag_cloudth_vert<=2) then
-               call cloudth(klon,klev,k,ztv, &
-                   zq,zqta,fraca, &
-                   qcloud,ctot,zpspsk,paprs,pplay,ztla,zthl, &
-                   ratqs,zqs,t, &
-                   cloudth_sth,cloudth_senv,cloudth_sigmath,cloudth_sigmaenv)
-
-              elseif (iflag_cloudth_vert>=3 .and. iflag_cloudth_vert<=5) then
-               call cloudth_v3(klon,klev,k,ztv, &
-                   zq,zqta,fraca, &
-                   qcloud,ctot,ctot_vol,zpspsk,paprs,pplay,ztla,zthl, &
-                   ratqs,sigma_qtherm,zqs,t, &
-                   cloudth_sth,cloudth_senv,cloudth_sigmath,cloudth_sigmaenv)
-              !----------------------------------
-              !Version these Jean Jouhaud, Decembre 2018 
-              !----------------------------------              
-              elseif (iflag_cloudth_vert==6) then
-               call cloudth_v6(klon,klev,k,ztv, &
-                   zq,zqta,fraca, &
-                   qcloud,ctot,ctot_vol,zpspsk,paprs,pplay,ztla,zthl, &
-                   ratqs,zqs,t, &
-                   cloudth_sth,cloudth_senv,cloudth_sigmath,cloudth_sigmaenv)
-
-              endif
-              do i=1,klon
-                 rneb(i,k)=ctot(i,k)
-                 rneblsvol(i,k)=ctot_vol(i,k)
-                 zqn(i)=qcloud(i)
-              enddo
-
-           endif
-
-           if (iflag_cld_th <= 4) then
-              lognormale = .true.
-           elseif (iflag_cld_th >= 6) then
-              ! lognormale en l'absence des thermiques
-              lognormale = fraca(:,k) < 1e-10
-           else
-              ! Dans le cas iflag_cld_th=5, on prend systématiquement la
-              ! bi-gaussienne
-              lognormale = .false.
-           end if
-
-!CR: variation de qsat avec T en presence de glace ou non
-!initialisations
-           do i=1,klon
-              DT(i) = 0.
-              n_i(i)=0
-              Tbef(i)=zt(i)
-              qlbef(i)=0.
-           enddo
-
-        ! ----------------------------------------------------------------
-        ! P2.A.2> Prise en compte du couplage entre eau condensee et T.
-        ! Calcul des grandeurs nuageuses en tenant compte de l'effet de
-        ! la condensation sur T, et donc sur qsat et sur les grandeurs nuageuses
-        ! qui en dependent. Ce changement de temperature est provisoire, et
-        ! la valeur definitive sera calcule plus tard.
-        ! Variables calculees: 
-        !   rneb : nebulosite
-        !   zcond: eau condensee en moyenne dans la maille
-        ! note JLD: si on n'a pas de pdf lognormale, ce qui se passe ne me semble
-        ! pas clair, il n'y a probablement pas de prise en compte de l'effet de
-        ! T sur qsat
-        ! ----------------------------------------------------------------
-
-!Boucle iterative: ATTENTION, l'option -1 n'est plus activable ici
-           if (iflag_fisrtilp_qsat.ge.0) then
-             ! Iteration pour condensation avec variation de qsat(T) 
-             ! -----------------------------------------------------
-             do iter=1,iflag_fisrtilp_qsat+1
-                
-               do i=1,klon
-!                 do while ((abs(DT(i)).gt.DDT0).or.(n_i(i).eq.0))
-                 ! !! convergence = .true. tant que l'on n'a pas converge !!
-                 ! ------------------------------
-                 convergence(i)=abs(DT(i)).gt.DDT0
-                 if ((convergence(i).or.(n_i(i).eq.0)).and.lognormale(i)) then
-                 ! si on n'a pas converge
-                 !
-                 ! P2.A.2.1> Calcul de la fraction nuageuse et de la quantite d'eau condensee
-                 ! ---------------------------------------------------------------
-                 ! Variables calculees: 
-                 ! rneb : nebulosite
-                 ! zqn : eau condensee, dans le nuage (in cloud water content)
-                 ! zcond: eau condensee en moyenne dans la maille
-                 ! rhcl: humidite relative ciel-clair
-                 !
-                 Tbef(i)=Tbef(i)+DT(i) ! nouvelle temperature
-                 if (.not.ice_thermo) then   
-                    zdelta = MAX(0.,SIGN(1.,RTT-Tbef(i)))
-                 else
-                    if (iflag_t_glace.eq.0) then
-                    zdelta = MAX(0.,SIGN(1.,t_glace_min_old-Tbef(i)))
-                    else if (iflag_t_glace.ge.1) then
-                       if (iflag_oldbug_fisrtilp.EQ.0) then
-                          zdelta = MAX(0.,SIGN(1.,t_glace_max-Tbef(i)))
-                       else
-                          !avec bug : zdelta = MAX(0.,SIGN(1.,t_glace_min-Tbef(i)))
-                          zdelta = MAX(0.,SIGN(1.,t_glace_min-Tbef(i)))
-                       endif
-                    endif
-                 endif
-                 ! Calcul de rneb, qzn et zcond pour les PDF lognormales
-                 zcvm5 = R5LES*RLVTT*(1.-zdelta) + R5IES*RLSTT*zdelta
-               if (fl_cor_ebil .GT. 0) then
-                 zcvm5 = zcvm5 /RCPD/(1.0+RVTMP2*(zq(i)+zmqc(i)))
-               else
-                 zcvm5 = zcvm5 /RCPD/(1.0+RVTMP2*zq(i))
-               end if
-                 zqs(i) = R2ES*FOEEW(Tbef(i),zdelta)/pplay(i,k)
-                 zqs(i) = MIN(0.5,zqs(i))
-                 zcor = 1./(1.-RETV*zqs(i))
-                 zqs(i) = zqs(i)*zcor
-                 zdqs(i) = FOEDE(Tbef(i),zdelta,zcvm5,zqs(i),zcor)
-                 zpdf_sig(i)=ratqs(i,k)*zq(i)
-                 zpdf_k(i)=-sqrt(log(1.+(zpdf_sig(i)/zq(i))**2))
-                 zpdf_delta(i)=log(zq(i)/zqs(i))
-                 zpdf_a(i)=zpdf_delta(i)/(zpdf_k(i)*sqrt(2.))
-                 zpdf_b(i)=zpdf_k(i)/(2.*sqrt(2.))
-                 zpdf_e1(i)=zpdf_a(i)-zpdf_b(i)
-                 zpdf_e1(i)=sign(min(abs(zpdf_e1(i)),5.),zpdf_e1(i))
-                 zpdf_e1(i)=1.-erf(zpdf_e1(i))
-                 zpdf_e2(i)=zpdf_a(i)+zpdf_b(i)
-                 zpdf_e2(i)=sign(min(abs(zpdf_e2(i)),5.),zpdf_e2(i))
-                 zpdf_e2(i)=1.-erf(zpdf_e2(i))
-             
-                 if (zpdf_e1(i).lt.1.e-10) then
-                    rneb(i,k)=0.
-                    zqn(i)=zqs(i)
-                 else
-                    rneb(i,k)=0.5*zpdf_e1(i)
-                    zqn(i)=zq(i)*zpdf_e2(i)/zpdf_e1(i)
-                 endif
-
-                 ! If vertical heterogeneity, change fraction by volume as well
-                 if (iflag_cloudth_vert>=3) then
-                   ctot_vol(i,k)=rneb(i,k)
-                   rneblsvol(i,k)=ctot_vol(i,k)
-                 endif
-
-                 endif !convergence
-
-               enddo ! boucle en i
-
-                 ! P2.A.2.2> Calcul APPROCHE de la variation de temperature DT 
-                 !         due a la condensation.
-                 ! ---------------------------------------------------------------
-                 ! Variables calculees: 
-                 ! DT : variation de temperature due a la condensation 
-
-                 if (.not. ice_thermo) then
-                 ! --------------------------
-                 do i=1,klon
-                 if ((convergence(i).or.(n_i(i).eq.0)).and.lognormale(i)) then
-
-                 qlbef(i)=max(0.,zqn(i)-zqs(i))
-               if (fl_cor_ebil .GT. 0) then
-                 num=-Tbef(i)+zt(i)+rneb(i,k)*RLVTT/RCPD/(1.0+RVTMP2*(zq(i)+zmqc(i)))*qlbef(i)
-               else
-                 num=-Tbef(i)+zt(i)+rneb(i,k)*RLVTT/RCPD/(1.0+RVTMP2*zq(i))*qlbef(i)
-               end if
-                 denom=1.+rneb(i,k)*zdqs(i)
-                 DT(i)=num/denom
-                 n_i(i)=n_i(i)+1
-                 endif
-                 enddo
-
-                 else ! if (.not. ice_thermo)
-                 ! --------------------------
-                 if (iflag_t_glace.ge.1) then
-                 CALL icefrac_lsc(klon,zt(:),pplay(:,k)/paprs(:,1),zfice(:))
-                 endif
-
-                 do i=1,klon
-                 if ((convergence(i).or.(n_i(i).eq.0)).and.lognormale(i)) then
-                 
-                 if (iflag_t_glace.eq.0) then
-                    zfice(i) = 1.0 - (Tbef(i)-t_glace_min_old) / (RTT-t_glace_min_old)
-                    zfice(i) = MIN(MAX(zfice(i),0.0),1.0)
-                    zfice(i) = zfice(i)**exposant_glace_old
-                    dzfice(i)= exposant_glace_old * zfice(i)**(exposant_glace_old-1) &
-          &                     / (t_glace_min_old - RTT)
-                 endif
-                 
-                 if (iflag_t_glace.ge.1.and.zfice(i)>0.) then
-                 dzfice(i)= exposant_glace * zfice(i)**(exposant_glace-1) &
-          &                    / (t_glace_min - t_glace_max)
-                 endif
-               
-                 if ((zfice(i).eq.0).or.(zfice(i).eq.1)) then
-                    dzfice(i)=0.
-                 endif
-
-                 if (zfice(i).lt.1) then
-                    cste=RLVTT
-                 else
-                    cste=RLSTT
-                 endif
-
-                 qlbef(i)=max(0.,zqn(i)-zqs(i))
-               if (fl_cor_ebil .GT. 0) then
-                 num = -Tbef(i)+zt(i)+rneb(i,k)*((1-zfice(i))*RLVTT &
-           &          +zfice(i)*RLSTT)/RCPD/(1.0+RVTMP2*(zq(i)+zmqc(i)))*qlbef(i)
-                 denom = 1.+rneb(i,k)*((1-zfice(i))*RLVTT+zfice(i)*RLSTT)/cste*zdqs(i) &
-                         -(RLSTT-RLVTT)/RCPD/(1.0+RVTMP2*(zq(i)+zmqc(i)))*rneb(i,k)    &
-           &               *qlbef(i)*dzfice(i)
-               else
-                 num = -Tbef(i)+zt(i)+rneb(i,k)*((1-zfice(i))*RLVTT &
-           &         +zfice(i)*RLSTT)/RCPD/(1.0+RVTMP2*zq(i))*qlbef(i)
-                 denom = 1.+rneb(i,k)*((1-zfice(i))*RLVTT+zfice(i)*RLSTT)/cste*zdqs(i) &
-                         -(RLSTT-RLVTT)/RCPD/(1.0+RVTMP2*zq(i))*rneb(i,k)*qlbef(i)*dzfice(i)
-               end if
-                 DT(i)=num/denom
-                 n_i(i)=n_i(i)+1
-
-                 endif ! fin convergence
-                 enddo ! fin boucle i
-
-                 endif !ice_thermo
-
-             enddo ! iter=1,iflag_fisrtilp_qsat+1
-             ! Fin d'iteration pour condensation avec variation de qsat(T) 
-             ! -----------------------------------------------------------
-           endif !  if (iflag_fisrtilp_qsat.ge.0)
-     ! ----------------------------------------------------------------
-     ! Fin de P2.A.2> la prise en compte du couplage entre eau condensee et T
-     ! ----------------------------------------------------------------
-
-        endif ! iflag_pdf
-
-!        if (iflag_fisrtilp_qsat.eq.-1) then 
-!------------------------------------------
-!CR: ATTENTION option fausse mais a existe:
-! pour la re-activer, prendre iflag_fisrtilp_qsat=0 et
-! activer les lignes suivantes: 
-       IF (1.eq.0) THEN 
-       DO i=1,klon
-           IF (rneb(i,k) .LE. 0.0) THEN
-              zqn(i) = 0.0
-              rneb(i,k) = 0.0
-              zcond(i) = 0.0
-              rhcl(i,k)=zq(i)/zqs(i)
-           ELSE IF (rneb(i,k) .GE. 1.0) THEN
-              zqn(i) = zq(i)
-              rneb(i,k) = 1.0                 
-              zcond(i) = MAX(0.0,zqn(i)-zqs(i))/(1+zdqs(i))
-              rhcl(i,k)=1.0
-           ELSE
-              zcond(i) = MAX(0.0,zqn(i)-zqs(i))*rneb(i,k)/(1+zdqs(i))
-              rhcl(i,k)=(zqs(i)+zq(i)-zdelq)/2./zqs(i)
-           ENDIF
-       ENDDO
-       ENDIF
-!------------------------------------------
-
-!        ELSE
-        ! ----------------------------------------------------------------
-        ! P2.A.3> Calcul des valeures finales associees a la formation des nuages
-        ! Variables calculees: 
-        !   rneb : nebulosite
-        !   zcond: eau condensee en moyenne dans la maille
-        !   zq : eau vapeur dans la maille
-        !   zt : temperature de la maille
-        !   rhcl: humidite relative ciel-clair
-        ! ----------------------------------------------------------------
-        !
-        ! Bornage de l'eau in-cloud (zqn) et de la fraction nuageuse (rneb) 
-        ! Calcule de l'eau condensee moyenne dans la maille (zcond),
-        ! et de l'humidite relative ciel-clair (rhcl)
-        DO i=1,klon
-           IF (rneb(i,k) .LE. 0.0) THEN
-              zqn(i) = 0.0
-              rneb(i,k) = 0.0
-              zcond(i) = 0.0
-              rhcl(i,k)=zq(i)/zqs(i)
-           ELSE IF (rneb(i,k) .GE. 1.0) THEN
-              zqn(i) = zq(i)
-              rneb(i,k) = 1.0
-              zcond(i) = MAX(0.0,zqn(i)-zqs(i))
-              rhcl(i,k)=1.0
-           ELSE
-              zcond(i) = MAX(0.0,zqn(i)-zqs(i))*rneb(i,k)
-              rhcl(i,k)=(zqs(i)+zq(i)-zdelq)/2./zqs(i)
-           ENDIF
-        ENDDO
-
-       
-        ! If vertical heterogeneity, change fraction by volume as well
-        if (iflag_cloudth_vert>=3) then
-          ctot_vol(1:klon,k)=min(max(ctot_vol(1:klon,k),0.),1.)
-          rneblsvol(1:klon,k)=ctot_vol(1:klon,k)
-        endif
-
-!        ENDIF
-
-     ELSE ! de IF (cpartiel) 
-        ! -------------------------
-        ! P2.B> Nuage "tout ou rien"
-        ! -------------------------
-        ! note JLD: attention, rhcl non calcule. Ca peut avoir des consequences?
-        DO i = 1, klon
-           IF (zq(i).GT.zqs(i)) THEN
-              rneb(i,k) = 1.0
-           ELSE
-              rneb(i,k) = 0.0
-           ENDIF
-           zcond(i) = MAX(0.0,zq(i)-zqs(i))/(1.+zdqs(i))
-        ENDDO
-     ENDIF ! de IF (cpartiel) 
-     !
-     ! Mise a jour vapeur d'eau
-     ! -------------------------
-     DO i = 1, klon
-        zq(i) = zq(i) - zcond(i)
-        !         zt(i) = zt(i) + zcond(i) * RLVTT/RCPD
-     ENDDO
-!AJ<
-     ! ------------------------------------
-     ! P2.C> Prise en compte de la Chaleur latente apres formation nuage
-     ! -------------------------------------
-     ! Variable calcule:
-     !   zt : temperature de la maille
-     !
-     IF (.NOT. ice_thermo) THEN
-        if (iflag_fisrtilp_qsat.lt.1) then
-           DO i = 1, klon
-             zt(i) = zt(i) + zcond(i) * RLVTT/RCPD/(1.0+RVTMP2*zq(i))
-           ENDDO
-        else if (iflag_fisrtilp_qsat.gt.0) then
-           DO i= 1, klon
-    if (fl_cor_ebil .GT. 0) then
-             zt(i) = zt(i) + zcond(i) * RLVTT/RCPD/(1.0+RVTMP2*(zq(i)+zmqc(i)+zcond(i)))
-    else
-             zt(i) = zt(i) + zcond(i) * RLVTT/RCPD/(1.0+RVTMP2*(zq(i)+zcond(i)))
-    end if
-           ENDDO
-        endif
-     ELSE
-         if (iflag_t_glace.ge.1) then
-            CALL icefrac_lsc(klon,zt(:),pplay(:,k)/paprs(:,1),zfice(:))
-         endif
-         if (iflag_fisrtilp_qsat.lt.1) then
-           DO i = 1, klon
-! JBM: icefrac_lsc is now a function contained in icefrac_lsc_mod
-!              zfice(i) = icefrac_lsc(zt(i), t_glace_min, &
-!                                     t_glace_max, exposant_glace)
-              if (iflag_t_glace.eq.0) then
-                    zfice(i) = 1.0 - (zt(i)-t_glace_min_old) / (RTT-t_glace_min_old)
-                    zfice(i) = MIN(MAX(zfice(i),0.0),1.0)
-                    zfice(i) = zfice(i)**exposant_glace_old
-              endif
-              zt(i) = zt(i) + (1.-zfice(i))*zcond(i) * RLVTT/RCPD/(1.0+RVTMP2*zq(i)) &
-                       +zfice(i)*zcond(i) * RLSTT/RCPD/(1.0+RVTMP2*zq(i))
-           ENDDO
-         else
-           DO i=1, klon
-! JBM: icefrac_lsc is now a function contained in icefrac_lsc_mod
-!              zfice(i) = icefrac_lsc(zt(i), t_glace_min, &
-!                                     t_glace_max, exposant_glace)
-              if (iflag_t_glace.eq.0) then
-                    zfice(i) = 1.0 - (zt(i)-t_glace_min_old) / (RTT-t_glace_min_old)
-                    zfice(i) = MIN(MAX(zfice(i),0.0),1.0)
-                    zfice(i) = zfice(i)**exposant_glace_old
-              endif
-        if (fl_cor_ebil .GT. 0) then
-              zt(i) = zt(i) + (1.-zfice(i))*zcond(i) & 
-           &             * RLVTT/RCPD/(1.0+RVTMP2*(zq(i)+zmqc(i)+zcond(i))) &
-                      +zfice(i)*zcond(i) * RLSTT/RCPD/(1.0+RVTMP2*(zq(i)+zmqc(i)+zcond(i)))
-        else 
-              zt(i) = zt(i) + (1.-zfice(i))*zcond(i) * RLVTT/RCPD/(1.0+RVTMP2*(zq(i)+zcond(i))) &
-                      +zfice(i)*zcond(i) * RLSTT/RCPD/(1.0+RVTMP2*(zq(i)+zcond(i)))
-        end if
-           ENDDO
-         endif
-!         print*,zt(i),zrfl(i),zifl(i),'temp1'
-       ENDIF
-!>AJ
-
-     ! ----------------------------------------------------------------
-     ! P3> Formation des precipitations
-     ! ----------------------------------------------------------------
-     !
-     ! Partager l'eau condensee en precipitation et eau liquide nuageuse
-     !
-
-!<LTP
-
-IF (iflag_evap_prec==4) THEN
-        !Partitionnement des precipitations venant du dessus en précipitations nuageuses
-        !et précipitations ciel clair
-
-        !0) Calculate tot_zneb, la fraction nuageuse totale au-dessus du nuage
-        !en supposant un recouvrement maximum aléatoire (voir Jakob and Klein, 2000)
-        
-        DO i=1, klon
-                tot_znebn(i) = 1 - (1-tot_zneb(i))*(1 - max(rneb(i,k),zneb(i))) &
-                        /(1-min(zneb(i),1-smallestreal))
-                d_tot_zneb(i) = tot_znebn(i) - tot_zneb(i)
-                tot_zneb(i) = tot_znebn(i)
-
-
-                !1) Cloudy to clear air
-                d_znebprecip_cld_clr(i) = znebprecipcld(i) - min(rneb(i,k),znebprecipcld(i)) 
-                IF (znebprecipcld(i) .GT. 0) THEN
-                        d_zrfl_cld_clr(i) = d_znebprecip_cld_clr(i)/znebprecipcld(i)*zrflcld(i) 
-                        d_zifl_cld_clr(i) = d_znebprecip_cld_clr(i)/znebprecipcld(i)*ziflcld(i) 
-                ELSE 
-                        d_zrfl_cld_clr(i) = 0. 
-                        d_zifl_cld_clr(i) = 0. 
-                ENDIF
-
-                !2) Clear to cloudy air
-                d_znebprecip_clr_cld(i) = max(0., min(znebprecipclr(i), rneb(i,k) &
-                        - d_tot_zneb(i) - zneb(i)))
-                IF (znebprecipclr(i) .GT. 0) THEN
-                        d_zrfl_clr_cld(i) = d_znebprecip_clr_cld(i)/znebprecipclr(i)*zrflclr(i) 
-                        d_zifl_clr_cld(i) = d_znebprecip_clr_cld(i)/znebprecipclr(i)*ziflclr(i)
-                ELSE
-                        d_zrfl_clr_cld(i) = 0. 
-                        d_zifl_clr_cld(i) = 0. 
-                ENDIF 
-
-                !Update variables
-                znebprecipcld(i) = znebprecipcld(i) + d_znebprecip_clr_cld(i) - d_znebprecip_cld_clr(i)  
-                znebprecipclr(i) = znebprecipclr(i) + d_znebprecip_cld_clr(i) - d_znebprecip_clr_cld(i) 
-                zrflcld(i) = zrflcld(i) + d_zrfl_clr_cld(i) - d_zrfl_cld_clr(i) 
-                ziflcld(i) = ziflcld(i) + d_zifl_clr_cld(i) - d_zifl_cld_clr(i)
-                zrflclr(i) = zrflclr(i) + d_zrfl_cld_clr(i) - d_zrfl_clr_cld(i)
-                ziflclr(i) = ziflclr(i) + d_zifl_cld_clr(i) - d_zifl_clr_cld(i)
-
-        ENDDO
-ENDIF
-
-!>LTP
-
-
-
-     ! Initialisation de zoliq (eau condensee moyenne dans la maille)
-     DO i = 1, klon
-        IF (rneb(i,k).GT.0.0) THEN
-           zoliq(i) = zcond(i)
-           zrho(i) = pplay(i,k) / zt(i) / RD
-           zdz(i) = (paprs(i,k)-paprs(i,k+1)) / (zrho(i)*RG)
-        ENDIF
-     ENDDO
-!AJ<
-     IF (.NOT. ice_thermo) THEN
-       IF (iflag_t_glace.EQ.0) THEN
-         DO i = 1, klon
-            IF (rneb(i,k).GT.0.0) THEN
-               zfice(i) = 1.0 - (zt(i)-t_glace_min_old) / (273.13-t_glace_min_old)
-               zfice(i) = MIN(MAX(zfice(i),0.0),1.0)
-               zfice(i) = zfice(i)**exposant_glace_old
-!              zfice(i) = zfice(i)**nexpo
-         !!      zfice(i)=0.
-            ENDIF
-         ENDDO
-       ELSE ! of IF (iflag_t_glace.EQ.0)
-         CALL icefrac_lsc(klon,zt(:),pplay(:,k)/paprs(:,1),zfice(:))
-!         DO i = 1, klon
-!            IF (rneb(i,k).GT.0.0) THEN
-! JBM: icefrac_lsc is now a function contained in icefrac_lsc_mod
-!              zfice(i) = icefrac_lsc(zt(i), t_glace_min, &
-!                                     t_glace_max, exposant_glace)
-!            ENDIF
-!         ENDDO
-       ENDIF
-     ENDIF
-
-     ! Calcul de radliq (eau condensee pour le rayonnement)
-     ! Iteration pour realiser une moyenne de l'eau nuageuse lors de la precip
-     ! Remarque: ce n'est donc pas l'eau restante en fin de precip mais une
-     ! eau moyenne restante dans le nuage sur la duree du pas de temps qui est
-     ! transmise au rayonnement;
-     ! ----------------------------------------------------------------
-     DO i = 1, klon
-        IF (rneb(i,k).GT.0.0) THEN
-           zneb(i) = MAX(rneb(i,k), seuil_neb)
-     !      zt(i) = zt(i)+zcond(i)*zfice(i)*RLMLT/RCPD/(1.0+RVTMP2*zq(i))  
-!           print*,zt(i),'fractionglace'
-!>AJ
-           radliq(i,k) = zoliq(i)/REAL(ninter+1)
-        ENDIF
-     ENDDO
-     !
-     DO n = 1, ninter
-        DO i = 1, klon
-           IF (rneb(i,k).GT.0.0) THEN
-              zrhol(i) = zrho(i) * zoliq(i) / zneb(i)
-              ! Initialization of zpluie and zice:
-              zpluie=0
-              zice=0
-              IF (zneb(i).EQ.seuil_neb) THEN
-                 ztot = 0.0
-              ELSE
-                 !  quantite d'eau a eliminer: zchau (Sundqvist, 1978)
-                 !  meme chose pour la glace: zfroi (Zender & Kiehl, 1997)
-                 if (ptconv(i,k)) then
-                    zcl   =cld_lc_con
-                    zct   =1./cld_tau_con
-                    zfroi    = dtime/REAL(ninter)/zdz(i)*zoliq(i) &
-                         *fallvc(zrhol(i)) * zfice(i)
-                 else
-                    zcl   =cld_lc_lsc
-                    zct   =1./cld_tau_lsc
-                    zfroi    = dtime/REAL(ninter)/zdz(i)*zoliq(i) &
-                         *fallvs(zrhol(i)) * zfice(i)
-                 endif
-
-                 ! si l'heterogeneite verticale est active, on utilise 
-                 ! la fraction volumique "vraie" plutot que la fraction
-                 ! surfacique modifiee, qui est plus grande et reduit
-                 ! sinon l'eau in-cloud de facon artificielle
-                 if ((iflag_cloudth_vert>=3).AND.(iflag_rain_incloud_vol==1)) then
-                    zchau    = zct   *dtime/REAL(ninter) * zoliq(i) &
-                         *(1.0-EXP(-(zoliq(i)/ctot_vol(i,k)/zcl   )**2)) *(1.-zfice(i))
-                 else
-                    zchau    = zct   *dtime/REAL(ninter) * zoliq(i) &
-                         *(1.0-EXP(-(zoliq(i)/zneb(i)/zcl   )**2)) *(1.-zfice(i))
-                 endif
-!AJ<
-                 IF (.NOT. ice_thermo) THEN
-                   ztot    = zchau + zfroi
-                 ELSE
-                   zpluie = MIN(MAX(zchau,0.0),zoliq(i)*(1.-zfice(i)))
-                   zice = MIN(MAX(zfroi,0.0),zoliq(i)*zfice(i)) 
-                   ztot    = zpluie    + zice
-                 ENDIF
-!>AJ
-                 ztot    = MAX(ztot   ,0.0)
-              ENDIF
-              ztot    = MIN(ztot,zoliq(i))
-!AJ<
-     !         zoliqp = MAX(zoliq(i)*(1.-zfice(i))-1.*zpluie   , 0.0)
-     !         zoliqi = MAX(zoliq(i)*zfice(i)-1.*zice   , 0.0)
-!JLD : les 2 variables zoliqp et zoliqi crorresponent a des pseudo precip
-!      temporaires et ne doivent pas etre calcule (alors qu'elles le sont
-!      si iflag_bergeron <> 2
-!      A SUPPRIMER A TERME
-              zoliqp(i) = MAX(zoliq(i)*(1.-zfice(i))-1.*zpluie  , 0.0)
-              zoliqi(i) = MAX(zoliq(i)*zfice(i)-1.*zice  , 0.0)
-              zoliq(i) = MAX(zoliq(i)-ztot   , 0.0)
-!>AJ
-              radliq(i,k) = radliq(i,k) + zoliq(i)/REAL(ninter+1)
-           ENDIF
-        ENDDO  ! i = 1,klon
-     ENDDO     ! n = 1,ninter
-
-     ! ----------------------------------------------------------------
-     !
-     IF (.NOT. ice_thermo) THEN
-       DO i = 1, klon
-         IF (rneb(i,k).GT.0.0) THEN
-           d_ql(i,k) = zoliq(i)
-           zrfl(i) = zrfl(i)+ MAX(zcond(i)-zoliq(i),0.0) &
-                * (paprs(i,k)-paprs(i,k+1))/(RG*dtime)
-         ENDIF
-       ENDDO
-     ELSE
-!
-!CR&JYG<
-! On prend en compte l'effet Bergeron dans les flux de precipitation :
-! Si T < 0 C, alors les precipitations liquides sont converties en glace, ce qui
-! provoque un accroissement de temperature DeltaT. L'effet de DeltaT sur le condensat
-! et les precipitations est grossierement pris en compte en linearisant les equations 
-! et en approximant le processus de precipitation liquide par un processus a seuil.
-! On fait l'hypothese que le condensat nuageux n'est pas modifié dans cette opération.
-! Le condensat precipitant liquide est supprime (dans la limite DeltaT<273-T).
-! Le condensat precipitant solide est augmente.
-! La vapeur d'eau est augmentee.
-!
-       IF ((iflag_bergeron .EQ. 2)) THEN
-         DO i = 1, klon
-           IF (rneb(i,k) .GT. 0.0) THEN
-             zqpreci(i)=(zcond(i)-zoliq(i))*zfice(i)
-             zqprecl(i)=(zcond(i)-zoliq(i))*(1.-zfice(i))
-           if (fl_cor_ebil .GT. 0) then
-             zcp=RCPD*(1.0+RVTMP2*(zq(i)+zmqc(i)+zcond(i)))
-             coef1 = rneb(i,k)*RLSTT/zcp*zdqsdT_raw(i)
-!            Calcul de DT si toute les precips liquides congelent
-             DeltaT = RLMLT*zqprecl(i) / (zcp*(1.+coef1))
-!            On ne veut pas que T devienne superieur a la temp. de congelation.
-!            donc que Delta > RTT-zt(i
-             DeltaT = max( min( RTT-zt(i), DeltaT) , 0. )
-             zt(i)      = zt(i)      + DeltaT
-!            Eau vaporisee du fait de l'augmentation de T
-             Deltaq = rneb(i,k)*zdqsdT_raw(i)*DeltaT
-!            on reajoute cette eau vaporise a la vapeur et on l'enleve des precips
-             zq(i) = zq(i) +  Deltaq
-!            Les 3 max si dessous prtotegent uniquement des erreurs d'arrondies
-             zcond(i)   = max( zcond(i)- Deltaq, 0. )
-!            precip liquide qui congele ou qui s'evapore
-             Deltaqprecl = -zcp/RLMLT*(1.+coef1)*DeltaT
-             zqprecl(i) = max( zqprecl(i) + Deltaqprecl, 0. )
-!            bilan eau glacee
-             zqpreci(i) = max (zqpreci(i) - Deltaqprecl - Deltaq, 0.)
-           else ! if (fl_cor_ebil .GT. 0)
-!            ancien calcul
-             zcp=RCPD*(1.0+RVTMP2*(zq(i)+zcond(i)))
-             coef1 = RLMLT*zdqs(i)/RLVTT
-             DeltaT = max( min( RTT-zt(i), RLMLT*zqprecl(i)/zcp/(1.+coef1) ) , 0.)
-             zqpreci(i) = zqpreci(i) + zcp/RLMLT*DeltaT
-             zqprecl(i) = max( zqprecl(i) - zcp/RLMLT*(1.+coef1)*DeltaT, 0. )
-             zcond(i)   = max( zcond(i)   - zcp/RLVTT*zdqs(i)*DeltaT, 0. )
-             zq(i)      = zq(i)      + zcp/RLVTT*zdqs(i)*DeltaT
-             zt(i)      = zt(i)      + DeltaT
-           end if ! if (fl_cor_ebil .GT. 0)
-           ENDIF  ! rneb(i,k) .GT. 0.0
-         ENDDO
-         DO i = 1, klon
-           IF (rneb(i,k).GT.0.0) THEN
-             d_ql(i,k) = (1-zfice(i))*zoliq(i)
-             d_qi(i,k) = zfice(i)*zoliq(i)
-!<LTP
-             IF (iflag_evap_prec == 4) THEN
-                zrflcld(i) = zrflcld(i)+zqprecl(i) &
-                 *(paprs(i,k)-paprs(i,k+1))/(RG*dtime)
-                ziflcld(i) = ziflcld(i)+ zqpreci(i) &
-                      *(paprs(i,k)-paprs(i,k+1))/(RG*dtime)
-                znebprecipcld(i) = rneb(i,k)
-                zrfl(i) = zrflcld(i) + zrflclr(i)
-                zifl(i) = ziflcld(i) + ziflclr(i)        
-!>LTP
-             ELSE
-                zrfl(i) = zrfl(i)+ zqprecl(i) &
-                 *(paprs(i,k)-paprs(i,k+1))/(RG*dtime) 
-                zifl(i) = zifl(i)+ zqpreci(i) &
-                      *(paprs(i,k)-paprs(i,k+1))/(RG*dtime)  
-             
-             ENDIF !iflag_evap_prec==4
-
-           ENDIF                      
-         ENDDO
-!!
-       ELSE  ! iflag_bergeron
-!>CR&JYG
-!!
-       DO i = 1, klon
-         IF (rneb(i,k).GT.0.0) THEN
-!CR on prend en compte la phase glace
-!JLD inutile car on ne passe jamais ici si .not.ice_thermo
-!           if (.not.ice_thermo) then
-!           d_ql(i,k) = zoliq(i)
-!           d_qi(i,k) = 0.
-!           else
-           d_ql(i,k) = (1-zfice(i))*zoliq(i)
-           d_qi(i,k) = zfice(i)*zoliq(i)
-!           endif
-!<LTP
-             IF (iflag_evap_prec == 4) THEN
-                zrflcld(i) = zrflcld(i)+ MAX(zcond(i)*(1.-zfice(i))-zoliqp(i),0.0) &
-                       *(paprs(i,k)-paprs(i,k+1))/(RG*dtime) 
-                ziflcld(i) = ziflcld(i)+ MAX(zcond(i)*zfice(i)-zoliqi(i),0.0) &
-                        *(paprs(i,k)-paprs(i,k+1))/(RG*dtime)  
-                znebprecipcld(i) = rneb(i,k)
-                zrfl(i) = zrflcld(i) + zrflclr(i)
-                zifl(i) = ziflcld(i) + ziflclr(i)        
-!>LTP
-             ELSE
-!AJ<
-                   zrfl(i) = zrfl(i)+ MAX(zcond(i)*(1.-zfice(i))-zoliqp(i),0.0) &
-                       *(paprs(i,k)-paprs(i,k+1))/(RG*dtime) 
-                        zifl(i) = zifl(i)+ MAX(zcond(i)*zfice(i)-zoliqi(i),0.0) &
-                        *(paprs(i,k)-paprs(i,k+1))/(RG*dtime)  
-     !      zrfl(i) = zrfl(i)+  zpluie                         &
-     !          *(paprs(i,k)-paprs(i,k+1))/(RG*dtime) 
-     !      zifl(i) = zifl(i)+  zice                    &
-     !               *(paprs(i,k)-paprs(i,k+1))/(RG*dtime)                                    
-             ENDIF !iflag_evap_prec == 4             
-
-!CR : on prend en compte l'effet Bergeron dans les flux de precipitation
-           IF ((iflag_bergeron .EQ. 1) .AND. (zt(i) .LT. 273.15)) THEN
-!<LTP
-                IF (iflag_evap_prec == 4) THEN
-                     zsolid = zrfl(i)
-                     ziflclr(i) = ziflclr(i) +zrflclr(i)
-                     ziflcld(i) = ziflcld(i) +zrflcld(i)
-                     zifl(i) = ziflclr(i)+ziflcld(i)
-                     zrflcld(i)=0.
-                     zrflclr(i)=0.   
-                     zrfl(i) = zrflclr(i)+zrflcld(i)
-!>LTP
-                ELSE
-                     zsolid = zrfl(i)
-                     zifl(i) = zifl(i)+zrfl(i)
-                     zrfl(i) = 0.
-                 ENDIF!iflag_evap_prec==4
-
-           if (fl_cor_ebil .GT. 0) then
-              zt(i)=zt(i)+zsolid*(RG*dtime)/(paprs(i,k)-paprs(i,k+1)) &
-                      *(RLSTT-RLVTT)/RCPD/(1.0+RVTMP2*(zq(i)+zmqc(i)))
-           else
-              zt(i)=zt(i)+zsolid*(RG*dtime)/(paprs(i,k)-paprs(i,k+1)) &
-                      *(RLSTT-RLVTT)/RCPD/(1.0+RVTMP2*zq(i))
-           end if
-           ENDIF  ! (iflag_bergeron .EQ. 1) .AND. (zt(i) .LT. 273.15)
-!RC   
-
-         ENDIF ! rneb(i,k).GT.0.0
-       ENDDO
-
-       ENDIF  ! iflag_bergeron .EQ. 2
-     ENDIF  ! .NOT. ice_thermo
-
-!CR: la fonte est faite au debut
-!      IF (ice_thermo) THEN
-!       DO i = 1, klon
-!           zmelt = ((zt(i)-273.15)/(ztfondue-273.15))**2
-!           zmelt = MIN(MAX(zmelt,0.),1.)
-!           zrfl(i)=zrfl(i)+zmelt*zifl(i)
-!           zifl(i)=zifl(i)*(1.-zmelt)
-!           print*,zt(i),'octavio1'
-!           zt(i)=zt(i)-zifl(i)*zmelt*(RG*dtime)/(paprs(i,k)-paprs(i,k+1)) &
-!                      *RLMLT/RCPD/(1.0+RVTMP2*zq(i))
-!           print*,zt(i),zrfl(i),zifl(i),zmelt,'octavio2'
-!       ENDDO
-!     ENDIF
-
-
-!<LTP
-
-!Limitation de la fraction surfacique couverte par les précipitations lorsque l'intensité locale du flux de précipitation descend en
-!dessous de rain_int_min
-    IF (iflag_evap_prec==4) THEN
-        DO i=1, klon
-            IF (zrflclr(i) + ziflclr(i) .GT. 0 ) THEN
-               znebprecipclr(i) = min(znebprecipclr(i), max(zrflclr(i) &
-                    /(znebprecipclr(i)*rain_int_min), &
-                    ziflclr(i)/(znebprecipclr(i)*rain_int_min)))
-            ELSE
-                znebprecipclr(i)=0.
-            ENDIF
-
-            IF (zrflcld(i) + ziflcld(i) .GT. 0 ) THEN
-               znebprecipcld(i) = min(znebprecipcld(i), &
-                    max(zrflcld(i)/(znebprecipcld(i)*rain_int_min), &
-                    ziflcld(i)/(znebprecipcld(i)*rain_int_min)))
-            ELSE
-                znebprecipcld(i)=0.
-            ENDIF
-       ENDDO
-    ENDIf
-
-!>LTP
-
-
-
-
-       
-     IF (.NOT. ice_thermo) THEN
-       DO i = 1, klon
-         IF (zt(i).LT.RTT) THEN
-           psfl(i,k)=zrfl(i)
-         ELSE
-           prfl(i,k)=zrfl(i)
-         ENDIF
-       ENDDO
-     ELSE
-     ! JAM*************************************************
-     ! Revoir partie ci-dessous: a quoi servent psfl et prfl?
-     ! *****************************************************
-
-       DO i = 1, klon
-     !   IF (zt(i).LT.RTT) THEN
-           psfl(i,k)=zifl(i) 
-     !   ELSE
-           prfl(i,k)=zrfl(i)
-     !   ENDIF
-!>AJ
-       ENDDO
-     ENDIF
-     ! ----------------------------------------------------------------
-     ! Fin de formation des precipitations
-     ! ----------------------------------------------------------------
-     !
-     ! Calculer les tendances de q et de t:
-     !
-     DO i = 1, klon
-        d_q(i,k) = zq(i) - q(i,k)
-        d_t(i,k) = zt(i) - t(i,k)
-     ENDDO
-     !
-     !AA--------------- Calcul du lessivage stratiforme  -------------
-
-     DO i = 1,klon
-        !
-        if(zcond(i).gt.zoliq(i)+1.e-10) then
-         beta(i,k) = (zcond(i)-zoliq(i))/zcond(i)/dtime
-        else
-         beta(i,k) = 0.
-        endif
-        zprec_cond(i) = MAX(zcond(i)-zoliq(i),0.0) &
-             * (paprs(i,k)-paprs(i,k+1))/RG
-        IF (rneb(i,k).GT.0.0.and.zprec_cond(i).gt.0.) THEN
-           !AA lessivage nucleation LMD5 dans la couche elle-meme
-          IF (iflag_t_glace.EQ.0) THEN
-           if (t(i,k) .GE. t_glace_min_old) THEN
-              zalpha_tr = a_tr_sca(3)
-           else
-              zalpha_tr = a_tr_sca(4)
-           endif
-          ELSE ! of IF (iflag_t_glace.EQ.0)
-           if (t(i,k) .GE. t_glace_min) THEN
-              zalpha_tr = a_tr_sca(3)
-           else
-              zalpha_tr = a_tr_sca(4)
-           endif
-          ENDIF
-           zfrac_lessi = 1. - EXP(zalpha_tr*zprec_cond(i)/zneb(i))
-           pfrac_nucl(i,k)=pfrac_nucl(i,k)*(1.-zneb(i)*zfrac_lessi)
-           frac_nucl(i,k)= 1.-zneb(i)*zfrac_lessi 
-           !
-           ! nucleation avec un facteur -1 au lieu de -0.5
-           zfrac_lessi = 1. - EXP(-zprec_cond(i)/zneb(i))
-           pfrac_1nucl(i,k)=pfrac_1nucl(i,k)*(1.-zneb(i)*zfrac_lessi)
-        ENDIF
-        !
-     ENDDO      ! boucle sur i
-     !
-     !AA Lessivage par impaction dans les couches en-dessous
-     DO kk = k-1, 1, -1
-        DO i = 1, klon
-           IF (rneb(i,k).GT.0.0.and.zprec_cond(i).gt.0.) THEN
-             IF (iflag_t_glace.EQ.0) THEN
-              if (t(i,kk) .GE. t_glace_min_old) THEN
-                 zalpha_tr = a_tr_sca(1)
-              else
-                 zalpha_tr = a_tr_sca(2)
-              endif
-             ELSE ! of IF (iflag_t_glace.EQ.0)
-              if (t(i,kk) .GE. t_glace_min) THEN
-                 zalpha_tr = a_tr_sca(1)
-              else
-                 zalpha_tr = a_tr_sca(2)
-              endif
-             ENDIF
-              zfrac_lessi = 1. - EXP(zalpha_tr*zprec_cond(i)/zneb(i))
-              pfrac_impa(i,kk)=pfrac_impa(i,kk)*(1.-zneb(i)*zfrac_lessi)
-              frac_impa(i,kk)= 1.-zneb(i)*zfrac_lessi
-           ENDIF
-        ENDDO
-     ENDDO
-     !
-     !AA===============================================================
-     !                     FIN DE LA BOUCLE VERTICALE  
-  end DO
-  !
-  !AA==================================================================
-  !
-  ! Pluie ou neige au sol selon la temperature de la 1ere couche
-  !
-!CR: si la thermo de la glace est active, on calcule zifl directement
-  IF (.NOT.ice_thermo) THEN
-  DO i = 1, klon
-     IF ((t(i,1)+d_t(i,1)) .LT. RTT) THEN
-!AJ<
-!        snow(i) = zrfl(i)
-        snow(i) = zrfl(i)+zifl(i)
-!>AJ
-        zlh_solid(i) = RLSTT-RLVTT
-     ELSE
-        rain(i) = zrfl(i)
-        zlh_solid(i) = 0.
-     ENDIF
-  ENDDO
-
-  ELSE
-     DO i = 1, klon
-        snow(i) = zifl(i)
-        rain(i) = zrfl(i)
-     ENDDO
-   
-   ENDIF
-  !
-  ! For energy conservation : when snow is present, the solification
-  ! latent heat is considered.
-!CR: si thermo de la glace, neige deja prise en compte
-  IF (.not.ice_thermo) THEN
-  DO k = 1, klev
-     DO i = 1, klon
-        zcpair=RCPD*(1.0+RVTMP2*(q(i,k)+d_q(i,k)))
-        zmair(i)=(paprs(i,k)-paprs(i,k+1))/RG
-        zm_solid = (prfl(i,k)-prfl(i,k+1)+psfl(i,k)-psfl(i,k+1))*dtime
-        d_t(i,k) = d_t(i,k) + zlh_solid(i) *zm_solid / (zcpair*zmair(i))
-     END DO
-  END DO
-  ENDIF
-  !
-
-  if (ncoreczq>0) then
-     WRITE(lunout,*)'WARNING : ZQ dans fisrtilp ',ncoreczq,' val < 1.e-15.'
-  endif
-
-RETURN
-END SUBROUTINE fisrtilp
-END MODULE lmdz_lscp_old
Index: /LMDZ6/trunk/libf/phylmd/lmdz_lscp_old.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/lmdz_lscp_old.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/lmdz_lscp_old.f90	(revision 5268)
@@ -0,0 +1,1682 @@
+! $Id$
+!
+!
+MODULE lmdz_lscp_old
+CONTAINS
+SUBROUTINE fisrtilp(klon,klev,dtime,paprs,pplay,t,q,ptconv,ratqs,sigma_qtherm, &
+     d_t, d_q, d_ql, d_qi, rneb,rneblsvol,radliq, rain, snow,          &
+     pfrac_impa, pfrac_nucl, pfrac_1nucl,               &
+     frac_impa, frac_nucl, beta,                        &
+     prfl, psfl, rhcl, zqta, fraca,                     &
+     ztv, zpspsk, ztla, zthl, iflag_cld_th,             &
+     iflag_ice_thermo,                                  &
+     cloudth_sth,cloudth_senv,cloudth_sigmath,cloudth_sigmaenv)
+
+
+  !
+  USE icefrac_lsc_mod ! compute ice fraction (JBM 3/14)
+  USE lmdz_cloudth, only : cloudth, cloudth_v3, cloudth_v6
+
+  USE lmdz_lscp_ini, ONLY: prt_level, lunout
+  USE lmdz_lscp_ini, ONLY : fl_cor_ebil 
+  USE lmdz_lscp_ini, ONLY: iflag_t_glace,t_glace_min, t_glace_max, exposant_glace
+  USE lmdz_lscp_ini, ONLY : seuil_neb, rain_int_min, iflag_evap_prec, iflag_oldbug_fisrtilp,a_tr_sca
+  USE lmdz_lscp_ini, ONLY: iflag_cloudth_vert, iflag_rain_incloud_vol 
+  USE lmdz_lscp_ini, ONLY: coef_eva, ffallv_lsc, ffallv_con
+  USE lmdz_lscp_ini, ONLY: cld_tau_lsc, cld_tau_con, cld_lc_lsc, cld_lc_con
+  USE lmdz_lscp_ini, ONLY: reevap_ice, iflag_bergeron, iflag_fisrtilp_qsat, iflag_pdf 
+
+
+
+  IMPLICIT none
+  !======================================================================
+  ! Auteur(s): Z.X. Li (LMD/CNRS)
+  ! Date: le 20 mars 1995
+  ! Objet: condensation et precipitation stratiforme.
+  !        schema de nuage
+  ! Fusion de fisrt (physique sursaturation, P. LeVan K. Laval)
+  !             et ilp (il pleut, L. Li)
+  ! Principales parties:
+  ! P0> Thermalisation des precipitations venant de la couche du dessus
+  ! P1> Evaporation de la precipitation (qui vient du niveau k+1)
+  ! P2> Formation du nuage (en k) 
+  ! P2.A.0> Calcul des grandeurs nuageuses une pdf en creneau
+  ! P2.A.1> Avec les nouvelles PDFs, calcul des grandeurs nuageuses pour 
+  ! les valeurs de T et Q initiales
+  ! P2.A.2> Prise en compte du couplage entre eau condensee et T.
+  ! P2.A.3> Calcul des valeures finales associees a la formation des nuages
+  ! P2.B> Nuage "tout ou rien"
+  ! P2.C> Prise en compte de la Chaleur latente apres formation nuage
+  ! P3> Formation de la precipitation (en k)
+  !======================================================================
+  ! JLD: 
+  ! * Routine probablement fausse (au moins incoherente) si thermcep = .false.
+  ! * fl_cor_ebil doit etre > 0 ; 
+  !   fl_cor_ebil= 0 pour reproduire anciens bugs
+  !======================================================================
+  include "YOMCST.h"
+  include "YOETHF.h"
+  include "FCTTRE.h"
+  !
+  ! Principaux inputs:
+  !
+  REAL, INTENT(IN)                              :: dtime  ! intervalle du temps (s)
+  INTEGER, INTENT(IN)                           :: klon, klev
+  REAL, DIMENSION(klon,klev+1),    INTENT(IN)   :: paprs  ! pression a inter-couche
+  REAL, DIMENSION(klon,klev),      INTENT(IN)   :: pplay  ! pression au milieu de couche
+  REAL, DIMENSION(klon,klev),      INTENT(IN)   :: t      ! temperature (K)
+  REAL, DIMENSION(klon,klev),      INTENT(IN)   :: q      ! humidite specifique (kg/kg)
+  LOGICAL, DIMENSION(klon,klev),   INTENT(IN)   :: ptconv ! points ou le schema de conv. prof. est actif
+  INTEGER,                         INTENT(IN)   :: iflag_cld_th
+  INTEGER,                         INTENT(IN)   :: iflag_ice_thermo
+  !
+  ! Inputs lies aux thermiques
+  ! 
+  REAL, DIMENSION(klon,klev),      INTENT(IN)   :: ztv
+  REAL, DIMENSION(klon,klev),      INTENT(IN)   :: zqta, fraca 
+  REAL, DIMENSION(klon,klev),      INTENT(IN)   :: zpspsk, ztla
+  REAL, DIMENSION(klon,klev),      INTENT(INOUT)   :: zthl
+  !
+  !  Input/output
+  REAL, DIMENSION(klon,klev),      INTENT(INOUT):: ratqs,sigma_qtherm  ! determine la largeur de distribution de vapeur
+  !
+  ! Principaux outputs:
+  !
+  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: d_t  ! incrementation de la temperature (K)
+  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: d_q  ! incrementation de la vapeur d'eau
+  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: d_ql ! incrementation de l'eau liquide
+  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: d_qi ! incrementation de l'eau glace
+  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: rneb, rneblsvol ! fraction nuageuse
+  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: beta ! taux de conversion de l'eau cond
+  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: radliq ! eau liquide utilisee dans rayonnements
+  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: rhcl ! humidite relative en ciel clair
+  REAL, DIMENSION(klon),           INTENT(OUT)  :: rain
+  REAL, DIMENSION(klon),           INTENT(OUT)  :: snow
+  REAL, DIMENSION(klon,klev+1),    INTENT(OUT)  :: prfl
+  REAL, DIMENSION(klon,klev+1),    INTENT(OUT)  :: psfl 
+
+  !AA
+  ! Coeffients de fraction lessivee : pour OFF-LINE
+  !
+  REAL, DIMENSION(klon,klev),      INTENT(INOUT)  :: pfrac_nucl
+  REAL, DIMENSION(klon,klev),      INTENT(INOUT)  :: pfrac_1nucl
+  REAL, DIMENSION(klon,klev),      INTENT(INOUT)  :: pfrac_impa
+  !
+  ! Fraction d'aerosols lessivee par impaction et par nucleation
+  ! POur ON-LINE
+  !
+  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: frac_impa
+  REAL, DIMENSION(klon,klev),      INTENT(OUT)  :: frac_nucl
+  REAL, DIMENSION(klon,klev), INTENT(OUT) :: cloudth_sth,cloudth_senv
+  REAL, DIMENSION(klon,klev), INTENT(OUT) :: cloudth_sigmath,cloudth_sigmaenv
+  !AA
+  ! --------------------------------------------------------------------------------
+  !
+  ! Options du programme:
+  !
+
+  REAL :: smallestreal
+
+  INTEGER, PARAMETER :: ninter=5 ! sous-intervals pour la precipitation
+  LOGICAL, PARAMETER :: cpartiel=.TRUE. ! condensation partielle
+  REAL, PARAMETER :: t_coup=234.0
+  REAL, PARAMETER :: DDT0=.01
+  REAL, PARAMETER :: ztfondue=278.15
+  ! --------------------------------------------------------------------------------
+  !
+  ! Variables locales:
+  !
+  INTEGER :: i, k, n, kk
+  REAL :: qsl, qsi
+  REAL :: zct      ,zcl
+  INTEGER :: ncoreczq  
+  REAL, DIMENSION(klon,klev) :: ctot,ctot_vol
+  REAL, DIMENSION(klon) :: zqs, zdqs, zdqsdT_raw, Tbef,qlbef,DT
+  REAL :: zdelta, zcor, zcvm5  
+  REAL ::num,denom
+
+  LOGICAL, DIMENSION(klon) :: lognormale,convergence
+  LOGICAL :: ice_thermo
+  INTEGER, DIMENSION(klon) :: n_i
+  INTEGER :: iter
+  REAL :: cste
+
+  REAL, DIMENSION(klon) :: zpdf_sig,zpdf_k,zpdf_delta, Zpdf_a,zpdf_b,zpdf_e1,zpdf_e2, qcloud
+  REAL :: erf   
+ 
+  REAL :: zqev, zqevt, zqev0,zqevi, zqevti, zdelq 
+  REAL, DIMENSION(klon) :: zrfl(klon), zrfln(klon), zrflclr(klon), zrflcld(klon), d_zrfl_clr_cld(klon), d_zifl_clr_cld(klon), d_zrfl_cld_clr(klon), d_zifl_cld_clr(klon) 
+
+  REAL, DIMENSION(klon) :: zifl, zifln, ziflclr, ziflcld, zoliq, zcond, zq, zqn, zoliqp, zoliqi, zt
+! JBM (3/14) nexpo is replaced by exposant_glace
+! REAL nexpo ! exponentiel pour glace/eau
+! INTEGER, PARAMETER :: nexpo=6
+  INTEGER :: exposant_glace_old
+  REAL :: t_glace_min_old, ztot
+  REAL, DIMENSION(klon) ::  zdz,zrho , zrhol, zfice,zneb,znebprecip
+  REAL :: zchau      ,zfroi      
+  REAL, DIMENSION(klon) :: znebprecipclr, znebprecipcld, tot_zneb, tot_znebn, d_tot_zneb, d_znebprecip_clr_cld, d_znebprecip_cld_clr, dzfice
+  REAL :: zmelt, zpluie, zice
+  REAL :: zsolid
+!!!!
+!  Variables pour Bergeron
+  REAL :: zcp, coef1, DeltaT, Deltaq, Deltaqprecl
+  REAL, DIMENSION(klon) :: zqpreci, zqprecl
+! Variable pour conservation enegie des precipitations
+  REAL, DIMENSION(klon) :: zmqc
+  !
+  LOGICAL, SAVE :: appel1er=.TRUE.
+  !$OMP THREADPRIVATE(appel1er)
+  !
+! iflag_oldbug_fisrtilp=0 enleve le BUG par JYG : tglace_min -> tglace_max
+! iflag_oldbug_fisrtilp=1 ajoute le BUG
+  !---------------------------------------------------------------
+  !
+  ! Fonctions en ligne:
+  !
+  REAL ::  fallvs,fallvc, zzz ! Vitesse de chute pour cristaux de glace
+                     ! (Heymsfield & Donner, 1990)
+  fallvc (zzz) = 3.29/2.0 * ((zzz)**0.16) * ffallv_con
+  fallvs (zzz) = 3.29/2.0 * ((zzz)**0.16) * ffallv_lsc
+  !
+  !---------------------------------------------------------------
+  !AA Variables traceurs:
+  !AA  Provisoire !!! Parametres alpha du lessivage
+  !AA  A priori on a 4 scavenging # possibles
+  !
+  ! Variables intermediaires
+  !
+  REAL :: zalpha_tr, zfrac_lessi
+  REAL, DIMENSION(klon) :: zprec_cond
+  !AA
+! RomP >>> 15 nov 2012
+! RomP <<<
+  REAL, DIMENSION(klon) :: zmair
+  REAL :: zcpair, zcpeau
+  !     Pour la conversion eau-neige
+  REAL, DIMENSION(klon) :: zlh_solid
+  REAL :: zm_solid
+
+
+  !
+  !ym
+!CR: pour iflag_ice_thermo=2, on active que la convection
+!  ice_thermo = iflag_ice_thermo .GE. 1
+
+  
+  znebprecip(:)=0.
+
+!<LTP
+  smallestreal=1.e-9
+  znebprecipclr(:)=0.
+  znebprecipcld(:)=0.
+!>LTP
+
+  ice_thermo = (iflag_ice_thermo .EQ. 1).OR.(iflag_ice_thermo .GE. 3)
+  zdelq=0.0
+  ctot_vol(1:klon,1:klev)=0.0
+  rneblsvol(1:klon,1:klev)=0.0
+
+  if (prt_level>9)write(lunout,*)'NUAGES4 A. JAM'
+  IF (appel1er) THEN
+     WRITE(lunout,*) 'fisrtilp, ninter:', ninter
+     WRITE(lunout,*) 'fisrtilp, cpartiel:', cpartiel
+     WRITE(lunout,*) 'FISRTILP VERSION LUDO'
+     
+     IF (ABS(dtime/REAL(ninter)-360.0).GT.0.001) THEN
+        WRITE(lunout,*) 'fisrtilp: Ce n est pas prevu, voir Z.X.Li', dtime
+        WRITE(lunout,*) 'Je prefere un sous-intervalle de 6 minutes'
+        !         CALL abort
+     ENDIF
+     appel1er = .FALSE.
+     !
+     !cdir collapse
+     DO k = 1, klev
+        DO i = 1, klon
+           pfrac_nucl(i,k)=1.
+           pfrac_1nucl(i,k)=1.
+           pfrac_impa(i,k)=1.
+           beta(i,k)=0.  !RomP initialisation
+        ENDDO
+     ENDDO
+
+  ENDIF          !  test sur appel1er
+  !
+  !MAf Initialisation a 0 de zoliq
+  !      DO i = 1, klon
+  !         zoliq(i)=0.
+  !      ENDDO 
+  ! Determiner les nuages froids par leur temperature
+  !  nexpo regle la raideur de la transition eau liquide / eau glace.
+  !
+!CR: on est oblige de definir des valeurs fisrt car les valeurs de newmicro ne sont pas les memes par defaut
+  IF (iflag_t_glace.EQ.0) THEN
+!   ztglace = RTT - 15.0
+    t_glace_min_old = RTT - 15.0
+    !AJ<
+    IF (ice_thermo) THEN
+!     nexpo = 2
+      exposant_glace_old = 2
+    ELSE
+!     nexpo = 6
+      exposant_glace_old = 6
+    ENDIF
+    
+  ENDIF
+  
+!!  RLVTT = 2.501e6 ! pas de redefinition des constantes physiques (jyg)
+!!  RLSTT = 2.834e6 ! pas de redefinition des constantes physiques (jyg)
+!>AJ
+  !cc      nexpo = 1
+  !
+  ! Initialiser les sorties:
+  !
+  !cdir collapse
+  DO k = 1, klev+1
+     DO i = 1, klon
+        prfl(i,k) = 0.0
+        psfl(i,k) = 0.0
+     ENDDO
+  ENDDO
+
+  !cdir collapse
+
+  DO k = 1, klev
+     DO i = 1, klon
+        d_t(i,k) = 0.0
+        d_q(i,k) = 0.0
+        d_ql(i,k) = 0.0
+        d_qi(i,k) = 0.0
+        rneb(i,k) = 0.0
+        radliq(i,k) = 0.0
+        frac_nucl(i,k) = 1. 
+        frac_impa(i,k) = 1. 
+     ENDDO
+  ENDDO
+  DO i = 1, klon
+     rain(i) = 0.0
+     snow(i) = 0.0
+     zoliq(i)=0.
+     !     ENDDO
+     !
+     ! Initialiser le flux de precipitation a zero
+     !
+     !     DO i = 1, klon
+     zrfl(i) = 0.0
+     zifl(i) = 0.0
+!<LTP
+     zrflclr(i) = 0.0
+     ziflclr(i) = 0.0
+     zrflcld(i) = 0.0
+     ziflcld(i) = 0.0
+     tot_zneb(i) = 0.0
+     tot_znebn(i) = 0.0
+     d_tot_zneb(i) = 0.0
+!>LTP
+
+     zneb(i) = seuil_neb
+  ENDDO
+  !
+  !
+  !AA Pour plus de securite 
+
+  zalpha_tr   = 0.
+  zfrac_lessi = 0.
+
+  !AA==================================================================
+  !
+  ncoreczq=0
+  ! BOUCLE VERTICALE (DU HAUT VERS LE BAS)
+  !
+  DO k = klev, 1, -1
+     !
+     !AA===============================================================
+     !
+     ! Initialisation temperature et vapeur
+     DO i = 1, klon
+        zt(i)=t(i,k)
+        zq(i)=q(i,k)
+     ENDDO
+     !
+     ! ----------------------------------------------------------------
+     ! P0> Thermalisation des precipitations venant de la couche du dessus
+     ! ----------------------------------------------------------------
+     ! Calculer la varition de temp. de l'air du a la chaleur sensible
+     ! transporter par la pluie. On thermalise la pluie avec l'air de la couche.
+     ! Cette quantite de pluie qui est thermalisee, et devra continue a l'etre lors
+     ! des differentes transformations thermodynamiques. Cette masse d'eau doit
+     ! donc etre ajoute a l'humidite de la couche lorsque l'on calcule la variation
+     ! de l'enthalpie  de la couche avec la temperature
+     ! Variables calculees ou modifiees:
+     !   -  zt: temperature de la cocuhe
+     !   - zmqc: masse de precip qui doit etre thermalisee
+     !
+     IF(k.LE.klev-1) THEN         
+        DO i = 1, klon
+           !IM
+           zmair(i)=(paprs(i,k)-paprs(i,k+1))/RG
+           ! il n'y a pas encore d'eau liquide ni glace dans la maiille, donc zq suffit
+           zcpair=RCPD*(1.0+RVTMP2*zq(i))
+           zcpeau=RCPD*RVTMP2
+         if (fl_cor_ebil .GT. 0) then
+           ! zmqc: masse de precip qui doit etre thermalisee avec l'air de la couche atm 
+           ! pour s'assurer que la precip arrivant au sol aura bien la temperature de la 
+           ! derniere couche
+           zmqc(i) = (zrfl(i)+zifl(i))*dtime/zmair(i)
+           ! t(i,k+1)+d_t(i,k+1): nouvelle temp de la couche au dessus
+           zt(i) = ( (t(i,k+1)+d_t(i,k+1))*zmqc(i)*zcpeau + zcpair*zt(i) ) &
+                 / (zcpair + zmqc(i)*zcpeau)
+         else ! si on maintient les anciennes erreurs
+           zt(i) = ( (t(i,k+1)+d_t(i,k+1))*zrfl(i)*dtime*zcpeau &
+                + zmair(i)*zcpair*zt(i) ) &
+                / (zmair(i)*zcpair + zrfl(i)*dtime*zcpeau)
+         end if
+        ENDDO
+     ELSE  ! IF(k.LE.klev-1) 
+        DO i = 1, klon 
+           zmair(i)=(paprs(i,k)-paprs(i,k+1))/RG 
+           zmqc(i) = 0.
+        ENDDO
+     ENDIF ! end IF(k.LE.klev-1)
+     !
+     ! ----------------------------------------------------------------
+     ! P1> Calcul de l'evaporation de la precipitation
+     ! ----------------------------------------------------------------
+     ! On evapore une partie des precipitations venant de la maille du dessus.
+     ! On calcule l'evaporation et la sublimation des precipitations, jusqu'a
+     ! ce que la fraction de cette couche qui est sous le nuage soit saturee.
+     ! Variables calculees ou modifiees:
+     !   - zrfl et zifl: flux de precip liquide et glace
+     !   - zq, zt: humidite et temperature de la cocuhe
+     !   - zmqc: masse de precip qui doit etre thermalisee
+     !
+     IF (iflag_evap_prec>=1) THEN
+        DO i = 1, klon
+!          S'il y a des precipitations
+           IF (zrfl(i)+zifl(i).GT.0.) THEN
+              ! Calcul du qsat
+              IF (thermcep) THEN
+                 zdelta=MAX(0.,SIGN(1.,RTT-zt(i)))
+                 zqs(i)= R2ES*FOEEW(zt(i),zdelta)/pplay(i,k)
+                 zqs(i)=MIN(0.5,zqs(i))
+                 zcor=1./(1.-RETV*zqs(i))
+                 zqs(i)=zqs(i)*zcor
+              ELSE
+                 IF (zt(i) .LT. t_coup) THEN
+                    zqs(i) = qsats(zt(i)) / pplay(i,k)
+                 ELSE
+                    zqs(i) = qsatl(zt(i)) / pplay(i,k)
+                 ENDIF
+              ENDIF
+           ENDIF ! (zrfl(i)+zifl(i).GT.0.)
+        ENDDO
+!AJ<
+
+       IF (.NOT. ice_thermo) THEN
+        DO i = 1, klon
+!          S'il y a des precipitations
+           IF (zrfl(i)+zifl(i).GT.0.) THEN
+                ! Evap max pour ne pas saturer la fraction sous le nuage
+                ! Evap max jusqu'à atteindre la saturation dans la partie
+                ! de la maille qui est sous le nuage de la couche du dessus
+                !!! On ne tient compte de cette fraction que sous une seule
+                !!! couche sous le nuage
+                zqev = MAX (0.0, (zqs(i)-zq(i))*zneb(i) )
+             ! Ajout de la prise en compte des precip a thermiser
+             ! avec petite reecriture 
+             if  (fl_cor_ebil .GT. 0) then ! nouveau
+                ! Calcul de l'evaporation du flux de precip herite
+                !   d'au-dessus
+                zqevt = coef_eva * (1.0-zq(i)/zqs(i)) * SQRT(zrfl(i)) &
+                     * zmair(i)/pplay(i,k)*zt(i)*RD
+                zqevt = MAX(0.0,MIN(zqevt,zrfl(i))) * dtime/zmair(i)
+
+                ! Seuil pour ne pas saturer la fraction sous le nuage
+                zqev = MIN (zqev, zqevt)
+                ! Nouveau flux de precip
+                zrfln(i) = zrfl(i) - zqev*zmair(i)/dtime
+                ! Aucun flux liquide pour T < t_coup, on reevapore tout.
+                IF (zt(i) .LT. t_coup.and.reevap_ice) THEN
+                  zrfln(i)=0.
+                  zqev = (zrfl(i)-zrfln(i))/zmair(i)*dtime
+                END IF
+                ! Nouvelle vapeur 
+                zq(i) = zq(i) + zqev
+                zmqc(i) = zmqc(i)-zqev
+                ! Nouvelle temperature (chaleur latente)
+                zt(i) = zt(i) - zqev &
+                     * RLVTT/RCPD/(1.0+RVTMP2*(zq(i)+zmqc(i)))
+!!JLD debut de partie a supprimer a terme
+            else ! if  (fl_cor_ebil .GT. 0)
+                ! Calcul de l'evaporation du flux de precip herite
+                !   d'au-dessus
+                zqevt = coef_eva * (1.0-zq(i)/zqs(i)) * SQRT(zrfl(i)) &
+                     * (paprs(i,k)-paprs(i,k+1))/pplay(i,k)*zt(i)*RD/RG
+                zqevt = MAX(0.0,MIN(zqevt,zrfl(i))) &
+                     * RG*dtime/(paprs(i,k)-paprs(i,k+1))
+                ! Seuil pour ne pas saturer la fraction sous le nuage
+                zqev = MIN (zqev, zqevt)
+                ! Nouveau flux de precip
+                zrfln(i) = zrfl(i) - zqev*(paprs(i,k)-paprs(i,k+1)) &
+                     /RG/dtime
+                ! Aucun flux liquide pour T < t_coup
+                IF (zt(i) .LT. t_coup.and.reevap_ice) zrfln(i)=0.
+                ! Nouvelle vapeur 
+                zq(i) = zq(i) - (zrfln(i)-zrfl(i)) &
+                     * (RG/(paprs(i,k)-paprs(i,k+1)))*dtime
+                ! Nouvelle temperature (chaleur latente)
+                zt(i) = zt(i) + (zrfln(i)-zrfl(i)) &
+                     * (RG/(paprs(i,k)-paprs(i,k+1)))*dtime &
+                     * RLVTT/RCPD/(1.0+RVTMP2*zq(i))
+              end if ! if  (fl_cor_ebil .GT. 0)
+!!JLD fin de partie a supprimer a terme
+                zrfl(i) = zrfln(i)
+                zifl(i) = 0.
+           ENDIF ! (zrfl(i)+zifl(i).GT.0.)
+        ENDDO
+!
+       ELSE ! (.NOT. ice_thermo) 
+!      ================================
+!      Avec thermodynamique de la glace
+!      ================================
+        DO i = 1, klon
+
+
+!AJ<
+!        S'il y a des precipitations
+         IF (zrfl(i)+zifl(i).GT.0.) THEN
+
+        !LTP<
+        !On ne tient compte que du flux de précipitation en ciel clair dans le calcul de l'évaporation.
+                IF (iflag_evap_prec==4) THEN
+                        zrfl(i) = zrflclr(i)
+                        zifl(i) = ziflclr(i)
+                ENDIF
+        
+        !>LTP
+
+         IF (iflag_evap_prec==1) THEN
+            znebprecip(i)=zneb(i)
+         ELSE
+            znebprecip(i)=MAX(zneb(i),znebprecip(i))
+         ENDIF
+         
+         IF (iflag_evap_prec==4) THEN
+        ! Evap max pour ne pas saturer toute la maille
+         zqev0 = MAX (0.0, zqs(i)-zq(i))
+         ELSE 
+        ! Evap max pour ne pas saturer la fraction sous le nuage
+         zqev0 = MAX (0.0, (zqs(i)-zq(i))*znebprecip(i) )
+         ENDIF
+
+         !JAM
+         ! On differencie qsat pour l'eau et la glace
+         ! Si zdelta=1. --> glace
+         ! Si zdelta=0. --> eau liquide
+        
+         ! Calcul du qsat par rapport a l'eau liquide
+         qsl= R2ES*FOEEW(zt(i),0.)/pplay(i,k)
+         qsl= MIN(0.5,qsl)
+         zcor= 1./(1.-RETV*qsl)
+         qsl= qsl*zcor
+         
+         ! Calcul de l'evaporation du flux de precip venant du dessus
+         ! Formulation en racine du flux de precip
+         ! (Klemp & Wilhelmson, 1978; Sundqvist, 1988)
+         IF (iflag_evap_prec==3) THEN
+         zqevt = znebprecip(i)*coef_eva*(1.0-zq(i)/qsl) &
+              *SQRT(zrfl(i)/max(1.e-4,znebprecip(i))) &
+              *(paprs(i,k)-paprs(i,k+1))/pplay(i,k)*zt(i)*RD/RG
+!<LTP
+         ELSE IF (iflag_evap_prec==4) THEN
+         zqevt = znebprecipclr(i)*coef_eva*(1.0-zq(i)/qsl) &
+              *SQRT(zrfl(i)/max(1.e-8,znebprecipclr(i))) &
+              *(paprs(i,k)-paprs(i,k+1))/pplay(i,k)*zt(i)*RD/RG
+!>LTP
+        ELSE 
+         zqevt = 1.*coef_eva*(1.0-zq(i)/qsl)*SQRT(zrfl(i)) &
+              *(paprs(i,k)-paprs(i,k+1))/pplay(i,k)*zt(i)*RD/RG
+         ENDIF
+
+
+         zqevt = MAX(0.0,MIN(zqevt,zrfl(i))) &
+              *RG*dtime/(paprs(i,k)-paprs(i,k+1)) 
+         
+         ! Calcul du qsat par rapport a la glace
+         qsi= R2ES*FOEEW(zt(i),1.)/pplay(i,k)
+         qsi= MIN(0.5,qsi)
+         zcor= 1./(1.-RETV*qsi)
+         qsi= qsi*zcor
+
+         ! Calcul de la sublimation du flux de precip solide herite
+         !   d'au-dessus
+         IF (iflag_evap_prec==3) THEN
+         zqevti = znebprecip(i)*coef_eva*(1.0-zq(i)/qsi) &
+              *SQRT(zifl(i)/max(1.e-4,znebprecip(i))) &
+              *(paprs(i,k)-paprs(i,k+1))/pplay(i,k)*zt(i)*RD/RG
+!<LTP
+         ELSE IF (iflag_evap_prec==4) THEN
+         zqevti = znebprecipclr(i)*coef_eva*(1.0-zq(i)/qsi) &
+              *SQRT(zifl(i)/max(1.e-8,znebprecipclr(i))) &
+              *(paprs(i,k)-paprs(i,k+1))/pplay(i,k)*zt(i)*RD/RG
+!>LTP
+         ELSE
+         zqevti = 1.*coef_eva*(1.0-zq(i)/qsi)*SQRT(zifl(i)) &
+              *(paprs(i,k)-paprs(i,k+1))/pplay(i,k)*zt(i)*RD/RG
+         ENDIF
+         zqevti = MAX(0.0,MIN(zqevti,zifl(i))) &
+              *RG*dtime/(paprs(i,k)-paprs(i,k+1))   
+
+       
+        !JAM
+        ! Limitation de l'evaporation. On s'assure qu'on ne sature pas 
+        ! la fraction de la couche sous le nuage sinon on repartit zqev0 
+        ! en conservant la proportion liquide / glace
+     
+         IF (zqevt+zqevti.GT.zqev0) THEN
+            zqev=zqev0*zqevt/(zqevt+zqevti)
+            zqevi=zqev0*zqevti/(zqevt+zqevti)
+         ELSE
+!JLD je ne comprends pas les lignes ci-dessous. On repartit les precips
+!       liquides et solides meme si on ne sature pas la couche. 
+!       A mon avis, le test est inutile, et il faudrait tout remplacer par:
+!            zqev=zqevt
+!            zqevi=zqevti
+             IF (zqevt+zqevti.GT.0.) THEN
+                zqev=MIN(zqev0*zqevt/(zqevt+zqevti),zqevt)
+                zqevi=MIN(zqev0*zqevti/(zqevt+zqevti),zqevti)
+             ELSE
+             zqev=0.
+             zqevi=0.
+             ENDIF
+         ENDIF
+
+         ! Nouveaux flux de precip liquide et solide 
+         zrfln(i) = Max(0.,zrfl(i) - zqev*(paprs(i,k)-paprs(i,k+1)) &
+                                 /RG/dtime)
+         zifln(i) = Max(0.,zifl(i) - zqevi*(paprs(i,k)-paprs(i,k+1)) &
+                                 /RG/dtime)
+
+         ! Mise a jour de la vapeur, temperature et flux de precip
+         zq(i) = zq(i) - (zrfln(i)+zifln(i)-zrfl(i)-zifl(i)) &
+                  * (RG/(paprs(i,k)-paprs(i,k+1)))*dtime
+       if (fl_cor_ebil .GT. 0) then ! avec correction thermalisation des precips
+         zmqc(i) = zmqc(i) + (zrfln(i)+zifln(i)-zrfl(i)-zifl(i)) &
+                  * (RG/(paprs(i,k)-paprs(i,k+1)))*dtime
+         zt(i) = zt(i) + (zrfln(i)-zrfl(i)) &
+                  * (RG/(paprs(i,k)-paprs(i,k+1)))*dtime &
+                  * RLVTT/RCPD/(1.0+RVTMP2*(zq(i)+zmqc(i))) &
+                  + (zifln(i)-zifl(i)) &
+                  * (RG/(paprs(i,k)-paprs(i,k+1)))*dtime &
+                  * RLSTT/RCPD/(1.0+RVTMP2*(zq(i)+zmqc(i)))
+       else ! sans correction thermalisation des precips
+         zt(i) = zt(i) + (zrfln(i)-zrfl(i)) &
+                  * (RG/(paprs(i,k)-paprs(i,k+1)))*dtime &
+                  * RLVTT/RCPD/(1.0+RVTMP2*zq(i)) &
+                  + (zifln(i)-zifl(i)) &
+                  * (RG/(paprs(i,k)-paprs(i,k+1)))*dtime &
+                  * RLSTT/RCPD/(1.0+RVTMP2*zq(i))
+       end if
+        ! Nouvelles vaeleurs des precips liquides et solides 
+         zrfl(i) = zrfln(i)
+         zifl(i) = zifln(i)
+
+!<LTP
+        IF (iflag_evap_prec==4) THEN
+                zrflclr(i) = zrfl(i)
+                ziflclr(i) = zifl(i)    
+                IF(zrflclr(i) + ziflclr(i) .LE. 0) THEN
+                        znebprecipclr(i) = 0.
+                ENDIF   
+                zrfl(i) = zrflclr(i) + zrflcld(i)
+                zifl(i) = ziflclr(i) + ziflcld(i) 
+        ENDIF
+!>LTP        
+
+
+!CR ATTENTION: deplacement de la fonte de la glace
+!jyg : Bug !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! jyg
+!!!        zmelt = ((zt(i)-273.15)/(ztfondue-273.15))**2  !!!!!!!!! jyg
+!jyg : Bug !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! jyg
+           zmelt = ((zt(i)-273.15)/(ztfondue-273.15))             ! jyg
+           ! fraction de la precip solide qui est fondue
+           zmelt = MIN(MAX(zmelt,0.),1.)
+           ! Fusion de la glace
+!<LTP
+           IF (iflag_evap_prec==4) THEN
+                   zrflclr(i)=zrflclr(i)+zmelt*ziflclr(i)
+                   zrflcld(i)=zrflcld(i)+zmelt*ziflcld(i)
+                   zrfl(i)=zrflclr(i)+zrflcld(i)
+!>LTP        
+           ELSE
+                   zrfl(i)=zrfl(i)+zmelt*zifl(i)
+           ENDIF
+           if (fl_cor_ebil .LE. 0) then
+             ! the following line should not be here. Indeed, if zifl is modified
+             ! now, zifl(i)*zmelt is no more the amount of ice that has melt
+             ! and therefore the change in temperature computed below is wrong
+             zifl(i)=zifl(i)*(1.-zmelt)
+           end if
+           ! Chaleur latente de fusion
+        if (fl_cor_ebil .GT. 0) then ! avec correction thermalisation des precips
+           zt(i)=zt(i)-zifl(i)*zmelt*(RG*dtime)/(paprs(i,k)-paprs(i,k+1)) &
+                      *RLMLT/RCPD/(1.0+RVTMP2*(zq(i)+zmqc(i)))
+        else ! sans correction thermalisation des precips
+           zt(i)=zt(i)-zifl(i)*zmelt*(RG*dtime)/(paprs(i,k)-paprs(i,k+1)) &
+                      *RLMLT/RCPD/(1.0+RVTMP2*zq(i))
+        end if
+           if (fl_cor_ebil .GT. 0) then ! correction bug, deplacement ligne precedente
+!<LTP
+             IF (iflag_evap_prec==4) THEN
+                   ziflclr(i)=ziflclr(i)*(1.-zmelt)
+                   ziflcld(i)=ziflcld(i)*(1.-zmelt)
+                   zifl(i)=ziflclr(i)+ziflcld(i)
+!>LTP        
+             ELSE
+                   zifl(i)=zifl(i)*(1.-zmelt)
+             ENDIF
+           end if
+
+           ELSE
+              ! Si on n'a plus de pluies, on reinitialise a 0 la farcion
+              ! sous nuageuse utilisee pour la pluie.
+              znebprecip(i)=0.
+           ENDIF ! (zrfl(i)+zifl(i).GT.0.)
+        ENDDO
+
+      ENDIF ! (.NOT. ice_thermo) 
+     
+     ! ----------------------------------------------------------------
+     ! Fin evaporation de la precipitation
+     ! ----------------------------------------------------------------
+     ENDIF ! (iflag_evap_prec>=1)
+     !
+     ! Calculer Qs et L/Cp*dQs/dT:
+     !
+     IF (thermcep) THEN
+        DO i = 1, klon
+           zdelta = MAX(0.,SIGN(1.,RTT-zt(i)))
+           zcvm5 = R5LES*RLVTT*(1.-zdelta) + R5IES*RLSTT*zdelta
+       if  (fl_cor_ebil .GT. 0) then ! nouveau
+           zcvm5 = zcvm5 /RCPD/(1.0+RVTMP2*(zq(i)+zmqc(i)))
+       else    
+           zcvm5 = zcvm5 /RCPD/(1.0+RVTMP2*zq(i))
+       endif
+           zqs(i) = R2ES*FOEEW(zt(i),zdelta)/pplay(i,k)
+           zqs(i) = MIN(0.5,zqs(i))
+           zcor = 1./(1.-RETV*zqs(i))
+           zqs(i) = zqs(i)*zcor
+           zdqs(i) = FOEDE(zt(i),zdelta,zcvm5,zqs(i),zcor)
+           zdqsdT_raw(i) = zdqs(i)*  &
+         &         RCPD*(1.0+RVTMP2*zq(i)) / (RLVTT*(1.-zdelta) + RLSTT*zdelta)
+        ENDDO
+     ELSE
+        DO i = 1, klon
+           IF (zt(i).LT.t_coup) THEN
+              zqs(i) = qsats(zt(i))/pplay(i,k)
+              zdqs(i) = dqsats(zt(i),zqs(i))
+           ELSE
+              zqs(i) = qsatl(zt(i))/pplay(i,k)
+              zdqs(i) = dqsatl(zt(i),zqs(i))
+           ENDIF
+        ENDDO
+     ENDIF
+     !
+     ! Determiner la condensation partielle et calculer la quantite
+     ! de l'eau condensee:
+     !
+!verification de la valeur de iflag_fisrtilp_qsat pour iflag_ice_thermo=1
+!       if ((iflag_ice_thermo.eq.1).and.(iflag_fisrtilp_qsat.ne.0)) then
+!         write(*,*) " iflag_ice_thermo==1 requires iflag_fisrtilp_qsat==0", &
+!        " but iflag_fisrtilp_qsat=",iflag_fisrtilp_qsat, ". Might as well stop here."
+!         stop
+!       endif
+
+     ! ----------------------------------------------------------------
+     ! P2> Formation du nuage
+     ! ----------------------------------------------------------------
+     ! Variables calculees:
+     !   rneb  : fraction nuageuse
+     !   zcond : eau condensee moyenne dans la maille.
+     !   rhcl: humidite relative ciel-clair
+     !   zt : temperature de la maille
+     ! ----------------------------------------------------------------
+     !
+     IF (cpartiel) THEN
+        ! -------------------------
+        ! P2.A> Nuage fractionnaire
+        ! -------------------------
+        !
+        !   Calcul de l'eau condensee et de la fraction nuageuse et de l'eau
+        !   nuageuse a partir des PDF de Sandrine Bony.
+        !   rneb  : fraction nuageuse
+        !   zqn   : eau totale dans le nuage
+        !   zcond : eau condensee moyenne dans la maille.
+        !  on prend en compte le réchauffement qui diminue la partie
+        ! condensee
+        !
+        !   Version avec les raqts
+
+        ! ----------------------------------------------------------------
+        ! P2.A.0> Calcul des grandeurs nuageuses une pdf en creneau
+        ! ----------------------------------------------------------------
+        if (iflag_pdf.eq.0) then
+
+           ! version creneau de (Li, 1998)
+           do i=1,klon
+              zdelq = min(ratqs(i,k),0.99) * zq(i)
+              rneb(i,k) = (zq(i)+zdelq-zqs(i)) / (2.0*zdelq)
+              zqn(i) = (zq(i)+zdelq+zqs(i))/2.0
+           enddo
+
+        else !  if (iflag_pdf.eq.0)
+           ! ----------------------------------------------------------------
+           ! P2.A.1> Avec les nouvelles PDFs, calcul des grandeurs nuageuses pour 
+           ! les valeurs de T et Q initiales
+           ! ----------------------------------------------------------------
+           do i=1,klon
+              if(zq(i).lt.1.e-15) then
+                 ncoreczq=ncoreczq+1
+                 zq(i)=1.e-15
+              endif
+           enddo
+
+           if (iflag_cld_th>=5) then
+
+              if (iflag_cloudth_vert<=2) then
+               call cloudth(klon,klev,k,ztv, &
+                   zq,zqta,fraca, &
+                   qcloud,ctot,zpspsk,paprs,pplay,ztla,zthl, &
+                   ratqs,zqs,t, &
+                   cloudth_sth,cloudth_senv,cloudth_sigmath,cloudth_sigmaenv)
+
+              elseif (iflag_cloudth_vert>=3 .and. iflag_cloudth_vert<=5) then
+               call cloudth_v3(klon,klev,k,ztv, &
+                   zq,zqta,fraca, &
+                   qcloud,ctot,ctot_vol,zpspsk,paprs,pplay,ztla,zthl, &
+                   ratqs,sigma_qtherm,zqs,t, &
+                   cloudth_sth,cloudth_senv,cloudth_sigmath,cloudth_sigmaenv)
+              !----------------------------------
+              !Version these Jean Jouhaud, Decembre 2018 
+              !----------------------------------              
+              elseif (iflag_cloudth_vert==6) then
+               call cloudth_v6(klon,klev,k,ztv, &
+                   zq,zqta,fraca, &
+                   qcloud,ctot,ctot_vol,zpspsk,paprs,pplay,ztla,zthl, &
+                   ratqs,zqs,t, &
+                   cloudth_sth,cloudth_senv,cloudth_sigmath,cloudth_sigmaenv)
+
+              endif
+              do i=1,klon
+                 rneb(i,k)=ctot(i,k)
+                 rneblsvol(i,k)=ctot_vol(i,k)
+                 zqn(i)=qcloud(i)
+              enddo
+
+           endif
+
+           if (iflag_cld_th <= 4) then
+              lognormale = .true.
+           elseif (iflag_cld_th >= 6) then
+              ! lognormale en l'absence des thermiques
+              lognormale = fraca(:,k) < 1e-10
+           else
+              ! Dans le cas iflag_cld_th=5, on prend systématiquement la
+              ! bi-gaussienne
+              lognormale = .false.
+           end if
+
+!CR: variation de qsat avec T en presence de glace ou non
+!initialisations
+           do i=1,klon
+              DT(i) = 0.
+              n_i(i)=0
+              Tbef(i)=zt(i)
+              qlbef(i)=0.
+           enddo
+
+        ! ----------------------------------------------------------------
+        ! P2.A.2> Prise en compte du couplage entre eau condensee et T.
+        ! Calcul des grandeurs nuageuses en tenant compte de l'effet de
+        ! la condensation sur T, et donc sur qsat et sur les grandeurs nuageuses
+        ! qui en dependent. Ce changement de temperature est provisoire, et
+        ! la valeur definitive sera calcule plus tard.
+        ! Variables calculees: 
+        !   rneb : nebulosite
+        !   zcond: eau condensee en moyenne dans la maille
+        ! note JLD: si on n'a pas de pdf lognormale, ce qui se passe ne me semble
+        ! pas clair, il n'y a probablement pas de prise en compte de l'effet de
+        ! T sur qsat
+        ! ----------------------------------------------------------------
+
+!Boucle iterative: ATTENTION, l'option -1 n'est plus activable ici
+           if (iflag_fisrtilp_qsat.ge.0) then
+             ! Iteration pour condensation avec variation de qsat(T) 
+             ! -----------------------------------------------------
+             do iter=1,iflag_fisrtilp_qsat+1
+                
+               do i=1,klon
+!                 do while ((abs(DT(i)).gt.DDT0).or.(n_i(i).eq.0))
+                 ! !! convergence = .true. tant que l'on n'a pas converge !!
+                 ! ------------------------------
+                 convergence(i)=abs(DT(i)).gt.DDT0
+                 if ((convergence(i).or.(n_i(i).eq.0)).and.lognormale(i)) then
+                 ! si on n'a pas converge
+                 !
+                 ! P2.A.2.1> Calcul de la fraction nuageuse et de la quantite d'eau condensee
+                 ! ---------------------------------------------------------------
+                 ! Variables calculees: 
+                 ! rneb : nebulosite
+                 ! zqn : eau condensee, dans le nuage (in cloud water content)
+                 ! zcond: eau condensee en moyenne dans la maille
+                 ! rhcl: humidite relative ciel-clair
+                 !
+                 Tbef(i)=Tbef(i)+DT(i) ! nouvelle temperature
+                 if (.not.ice_thermo) then   
+                    zdelta = MAX(0.,SIGN(1.,RTT-Tbef(i)))
+                 else
+                    if (iflag_t_glace.eq.0) then
+                    zdelta = MAX(0.,SIGN(1.,t_glace_min_old-Tbef(i)))
+                    else if (iflag_t_glace.ge.1) then
+                       if (iflag_oldbug_fisrtilp.EQ.0) then
+                          zdelta = MAX(0.,SIGN(1.,t_glace_max-Tbef(i)))
+                       else
+                          !avec bug : zdelta = MAX(0.,SIGN(1.,t_glace_min-Tbef(i)))
+                          zdelta = MAX(0.,SIGN(1.,t_glace_min-Tbef(i)))
+                       endif
+                    endif
+                 endif
+                 ! Calcul de rneb, qzn et zcond pour les PDF lognormales
+                 zcvm5 = R5LES*RLVTT*(1.-zdelta) + R5IES*RLSTT*zdelta
+               if (fl_cor_ebil .GT. 0) then
+                 zcvm5 = zcvm5 /RCPD/(1.0+RVTMP2*(zq(i)+zmqc(i)))
+               else
+                 zcvm5 = zcvm5 /RCPD/(1.0+RVTMP2*zq(i))
+               end if
+                 zqs(i) = R2ES*FOEEW(Tbef(i),zdelta)/pplay(i,k)
+                 zqs(i) = MIN(0.5,zqs(i))
+                 zcor = 1./(1.-RETV*zqs(i))
+                 zqs(i) = zqs(i)*zcor
+                 zdqs(i) = FOEDE(Tbef(i),zdelta,zcvm5,zqs(i),zcor)
+                 zpdf_sig(i)=ratqs(i,k)*zq(i)
+                 zpdf_k(i)=-sqrt(log(1.+(zpdf_sig(i)/zq(i))**2))
+                 zpdf_delta(i)=log(zq(i)/zqs(i))
+                 zpdf_a(i)=zpdf_delta(i)/(zpdf_k(i)*sqrt(2.))
+                 zpdf_b(i)=zpdf_k(i)/(2.*sqrt(2.))
+                 zpdf_e1(i)=zpdf_a(i)-zpdf_b(i)
+                 zpdf_e1(i)=sign(min(abs(zpdf_e1(i)),5.),zpdf_e1(i))
+                 zpdf_e1(i)=1.-erf(zpdf_e1(i))
+                 zpdf_e2(i)=zpdf_a(i)+zpdf_b(i)
+                 zpdf_e2(i)=sign(min(abs(zpdf_e2(i)),5.),zpdf_e2(i))
+                 zpdf_e2(i)=1.-erf(zpdf_e2(i))
+             
+                 if (zpdf_e1(i).lt.1.e-10) then
+                    rneb(i,k)=0.
+                    zqn(i)=zqs(i)
+                 else
+                    rneb(i,k)=0.5*zpdf_e1(i)
+                    zqn(i)=zq(i)*zpdf_e2(i)/zpdf_e1(i)
+                 endif
+
+                 ! If vertical heterogeneity, change fraction by volume as well
+                 if (iflag_cloudth_vert>=3) then
+                   ctot_vol(i,k)=rneb(i,k)
+                   rneblsvol(i,k)=ctot_vol(i,k)
+                 endif
+
+                 endif !convergence
+
+               enddo ! boucle en i
+
+                 ! P2.A.2.2> Calcul APPROCHE de la variation de temperature DT 
+                 !         due a la condensation.
+                 ! ---------------------------------------------------------------
+                 ! Variables calculees: 
+                 ! DT : variation de temperature due a la condensation 
+
+                 if (.not. ice_thermo) then
+                 ! --------------------------
+                 do i=1,klon
+                 if ((convergence(i).or.(n_i(i).eq.0)).and.lognormale(i)) then
+
+                 qlbef(i)=max(0.,zqn(i)-zqs(i))
+               if (fl_cor_ebil .GT. 0) then
+                 num=-Tbef(i)+zt(i)+rneb(i,k)*RLVTT/RCPD/(1.0+RVTMP2*(zq(i)+zmqc(i)))*qlbef(i)
+               else
+                 num=-Tbef(i)+zt(i)+rneb(i,k)*RLVTT/RCPD/(1.0+RVTMP2*zq(i))*qlbef(i)
+               end if
+                 denom=1.+rneb(i,k)*zdqs(i)
+                 DT(i)=num/denom
+                 n_i(i)=n_i(i)+1
+                 endif
+                 enddo
+
+                 else ! if (.not. ice_thermo)
+                 ! --------------------------
+                 if (iflag_t_glace.ge.1) then
+                 CALL icefrac_lsc(klon,zt(:),pplay(:,k)/paprs(:,1),zfice(:))
+                 endif
+
+                 do i=1,klon
+                 if ((convergence(i).or.(n_i(i).eq.0)).and.lognormale(i)) then
+                 
+                 if (iflag_t_glace.eq.0) then
+                    zfice(i) = 1.0 - (Tbef(i)-t_glace_min_old) / (RTT-t_glace_min_old)
+                    zfice(i) = MIN(MAX(zfice(i),0.0),1.0)
+                    zfice(i) = zfice(i)**exposant_glace_old
+                    dzfice(i)= exposant_glace_old * zfice(i)**(exposant_glace_old-1) &
+          &                     / (t_glace_min_old - RTT)
+                 endif
+                 
+                 if (iflag_t_glace.ge.1.and.zfice(i)>0.) then
+                 dzfice(i)= exposant_glace * zfice(i)**(exposant_glace-1) &
+          &                    / (t_glace_min - t_glace_max)
+                 endif
+               
+                 if ((zfice(i).eq.0).or.(zfice(i).eq.1)) then
+                    dzfice(i)=0.
+                 endif
+
+                 if (zfice(i).lt.1) then
+                    cste=RLVTT
+                 else
+                    cste=RLSTT
+                 endif
+
+                 qlbef(i)=max(0.,zqn(i)-zqs(i))
+               if (fl_cor_ebil .GT. 0) then
+                 num = -Tbef(i)+zt(i)+rneb(i,k)*((1-zfice(i))*RLVTT &
+           &          +zfice(i)*RLSTT)/RCPD/(1.0+RVTMP2*(zq(i)+zmqc(i)))*qlbef(i)
+                 denom = 1.+rneb(i,k)*((1-zfice(i))*RLVTT+zfice(i)*RLSTT)/cste*zdqs(i) &
+                         -(RLSTT-RLVTT)/RCPD/(1.0+RVTMP2*(zq(i)+zmqc(i)))*rneb(i,k)    &
+           &               *qlbef(i)*dzfice(i)
+               else
+                 num = -Tbef(i)+zt(i)+rneb(i,k)*((1-zfice(i))*RLVTT &
+           &         +zfice(i)*RLSTT)/RCPD/(1.0+RVTMP2*zq(i))*qlbef(i)
+                 denom = 1.+rneb(i,k)*((1-zfice(i))*RLVTT+zfice(i)*RLSTT)/cste*zdqs(i) &
+                         -(RLSTT-RLVTT)/RCPD/(1.0+RVTMP2*zq(i))*rneb(i,k)*qlbef(i)*dzfice(i)
+               end if
+                 DT(i)=num/denom
+                 n_i(i)=n_i(i)+1
+
+                 endif ! fin convergence
+                 enddo ! fin boucle i
+
+                 endif !ice_thermo
+
+             enddo ! iter=1,iflag_fisrtilp_qsat+1
+             ! Fin d'iteration pour condensation avec variation de qsat(T) 
+             ! -----------------------------------------------------------
+           endif !  if (iflag_fisrtilp_qsat.ge.0)
+     ! ----------------------------------------------------------------
+     ! Fin de P2.A.2> la prise en compte du couplage entre eau condensee et T
+     ! ----------------------------------------------------------------
+
+        endif ! iflag_pdf
+
+!        if (iflag_fisrtilp_qsat.eq.-1) then 
+!------------------------------------------
+!CR: ATTENTION option fausse mais a existe:
+! pour la re-activer, prendre iflag_fisrtilp_qsat=0 et
+! activer les lignes suivantes: 
+       IF (1.eq.0) THEN 
+       DO i=1,klon
+           IF (rneb(i,k) .LE. 0.0) THEN
+              zqn(i) = 0.0
+              rneb(i,k) = 0.0
+              zcond(i) = 0.0
+              rhcl(i,k)=zq(i)/zqs(i)
+           ELSE IF (rneb(i,k) .GE. 1.0) THEN
+              zqn(i) = zq(i)
+              rneb(i,k) = 1.0                 
+              zcond(i) = MAX(0.0,zqn(i)-zqs(i))/(1+zdqs(i))
+              rhcl(i,k)=1.0
+           ELSE
+              zcond(i) = MAX(0.0,zqn(i)-zqs(i))*rneb(i,k)/(1+zdqs(i))
+              rhcl(i,k)=(zqs(i)+zq(i)-zdelq)/2./zqs(i)
+           ENDIF
+       ENDDO
+       ENDIF
+!------------------------------------------
+
+!        ELSE
+        ! ----------------------------------------------------------------
+        ! P2.A.3> Calcul des valeures finales associees a la formation des nuages
+        ! Variables calculees: 
+        !   rneb : nebulosite
+        !   zcond: eau condensee en moyenne dans la maille
+        !   zq : eau vapeur dans la maille
+        !   zt : temperature de la maille
+        !   rhcl: humidite relative ciel-clair
+        ! ----------------------------------------------------------------
+        !
+        ! Bornage de l'eau in-cloud (zqn) et de la fraction nuageuse (rneb) 
+        ! Calcule de l'eau condensee moyenne dans la maille (zcond),
+        ! et de l'humidite relative ciel-clair (rhcl)
+        DO i=1,klon
+           IF (rneb(i,k) .LE. 0.0) THEN
+              zqn(i) = 0.0
+              rneb(i,k) = 0.0
+              zcond(i) = 0.0
+              rhcl(i,k)=zq(i)/zqs(i)
+           ELSE IF (rneb(i,k) .GE. 1.0) THEN
+              zqn(i) = zq(i)
+              rneb(i,k) = 1.0
+              zcond(i) = MAX(0.0,zqn(i)-zqs(i))
+              rhcl(i,k)=1.0
+           ELSE
+              zcond(i) = MAX(0.0,zqn(i)-zqs(i))*rneb(i,k)
+              rhcl(i,k)=(zqs(i)+zq(i)-zdelq)/2./zqs(i)
+           ENDIF
+        ENDDO
+
+       
+        ! If vertical heterogeneity, change fraction by volume as well
+        if (iflag_cloudth_vert>=3) then
+          ctot_vol(1:klon,k)=min(max(ctot_vol(1:klon,k),0.),1.)
+          rneblsvol(1:klon,k)=ctot_vol(1:klon,k)
+        endif
+
+!        ENDIF
+
+     ELSE ! de IF (cpartiel) 
+        ! -------------------------
+        ! P2.B> Nuage "tout ou rien"
+        ! -------------------------
+        ! note JLD: attention, rhcl non calcule. Ca peut avoir des consequences?
+        DO i = 1, klon
+           IF (zq(i).GT.zqs(i)) THEN
+              rneb(i,k) = 1.0
+           ELSE
+              rneb(i,k) = 0.0
+           ENDIF
+           zcond(i) = MAX(0.0,zq(i)-zqs(i))/(1.+zdqs(i))
+        ENDDO
+     ENDIF ! de IF (cpartiel) 
+     !
+     ! Mise a jour vapeur d'eau
+     ! -------------------------
+     DO i = 1, klon
+        zq(i) = zq(i) - zcond(i)
+        !         zt(i) = zt(i) + zcond(i) * RLVTT/RCPD
+     ENDDO
+!AJ<
+     ! ------------------------------------
+     ! P2.C> Prise en compte de la Chaleur latente apres formation nuage
+     ! -------------------------------------
+     ! Variable calcule:
+     !   zt : temperature de la maille
+     !
+     IF (.NOT. ice_thermo) THEN
+        if (iflag_fisrtilp_qsat.lt.1) then
+           DO i = 1, klon
+             zt(i) = zt(i) + zcond(i) * RLVTT/RCPD/(1.0+RVTMP2*zq(i))
+           ENDDO
+        else if (iflag_fisrtilp_qsat.gt.0) then
+           DO i= 1, klon
+    if (fl_cor_ebil .GT. 0) then
+             zt(i) = zt(i) + zcond(i) * RLVTT/RCPD/(1.0+RVTMP2*(zq(i)+zmqc(i)+zcond(i)))
+    else
+             zt(i) = zt(i) + zcond(i) * RLVTT/RCPD/(1.0+RVTMP2*(zq(i)+zcond(i)))
+    end if
+           ENDDO
+        endif
+     ELSE
+         if (iflag_t_glace.ge.1) then
+            CALL icefrac_lsc(klon,zt(:),pplay(:,k)/paprs(:,1),zfice(:))
+         endif
+         if (iflag_fisrtilp_qsat.lt.1) then
+           DO i = 1, klon
+! JBM: icefrac_lsc is now a function contained in icefrac_lsc_mod
+!              zfice(i) = icefrac_lsc(zt(i), t_glace_min, &
+!                                     t_glace_max, exposant_glace)
+              if (iflag_t_glace.eq.0) then
+                    zfice(i) = 1.0 - (zt(i)-t_glace_min_old) / (RTT-t_glace_min_old)
+                    zfice(i) = MIN(MAX(zfice(i),0.0),1.0)
+                    zfice(i) = zfice(i)**exposant_glace_old
+              endif
+              zt(i) = zt(i) + (1.-zfice(i))*zcond(i) * RLVTT/RCPD/(1.0+RVTMP2*zq(i)) &
+                       +zfice(i)*zcond(i) * RLSTT/RCPD/(1.0+RVTMP2*zq(i))
+           ENDDO
+         else
+           DO i=1, klon
+! JBM: icefrac_lsc is now a function contained in icefrac_lsc_mod
+!              zfice(i) = icefrac_lsc(zt(i), t_glace_min, &
+!                                     t_glace_max, exposant_glace)
+              if (iflag_t_glace.eq.0) then
+                    zfice(i) = 1.0 - (zt(i)-t_glace_min_old) / (RTT-t_glace_min_old)
+                    zfice(i) = MIN(MAX(zfice(i),0.0),1.0)
+                    zfice(i) = zfice(i)**exposant_glace_old
+              endif
+        if (fl_cor_ebil .GT. 0) then
+              zt(i) = zt(i) + (1.-zfice(i))*zcond(i) & 
+           &             * RLVTT/RCPD/(1.0+RVTMP2*(zq(i)+zmqc(i)+zcond(i))) &
+                      +zfice(i)*zcond(i) * RLSTT/RCPD/(1.0+RVTMP2*(zq(i)+zmqc(i)+zcond(i)))
+        else 
+              zt(i) = zt(i) + (1.-zfice(i))*zcond(i) * RLVTT/RCPD/(1.0+RVTMP2*(zq(i)+zcond(i))) &
+                      +zfice(i)*zcond(i) * RLSTT/RCPD/(1.0+RVTMP2*(zq(i)+zcond(i)))
+        end if
+           ENDDO
+         endif
+!         print*,zt(i),zrfl(i),zifl(i),'temp1'
+       ENDIF
+!>AJ
+
+     ! ----------------------------------------------------------------
+     ! P3> Formation des precipitations
+     ! ----------------------------------------------------------------
+     !
+     ! Partager l'eau condensee en precipitation et eau liquide nuageuse
+     !
+
+!<LTP
+
+IF (iflag_evap_prec==4) THEN
+        !Partitionnement des precipitations venant du dessus en précipitations nuageuses
+        !et précipitations ciel clair
+
+        !0) Calculate tot_zneb, la fraction nuageuse totale au-dessus du nuage
+        !en supposant un recouvrement maximum aléatoire (voir Jakob and Klein, 2000)
+        
+        DO i=1, klon
+                tot_znebn(i) = 1 - (1-tot_zneb(i))*(1 - max(rneb(i,k),zneb(i))) &
+                        /(1-min(zneb(i),1-smallestreal))
+                d_tot_zneb(i) = tot_znebn(i) - tot_zneb(i)
+                tot_zneb(i) = tot_znebn(i)
+
+
+                !1) Cloudy to clear air
+                d_znebprecip_cld_clr(i) = znebprecipcld(i) - min(rneb(i,k),znebprecipcld(i)) 
+                IF (znebprecipcld(i) .GT. 0) THEN
+                        d_zrfl_cld_clr(i) = d_znebprecip_cld_clr(i)/znebprecipcld(i)*zrflcld(i) 
+                        d_zifl_cld_clr(i) = d_znebprecip_cld_clr(i)/znebprecipcld(i)*ziflcld(i) 
+                ELSE 
+                        d_zrfl_cld_clr(i) = 0. 
+                        d_zifl_cld_clr(i) = 0. 
+                ENDIF
+
+                !2) Clear to cloudy air
+                d_znebprecip_clr_cld(i) = max(0., min(znebprecipclr(i), rneb(i,k) &
+                        - d_tot_zneb(i) - zneb(i)))
+                IF (znebprecipclr(i) .GT. 0) THEN
+                        d_zrfl_clr_cld(i) = d_znebprecip_clr_cld(i)/znebprecipclr(i)*zrflclr(i) 
+                        d_zifl_clr_cld(i) = d_znebprecip_clr_cld(i)/znebprecipclr(i)*ziflclr(i)
+                ELSE
+                        d_zrfl_clr_cld(i) = 0. 
+                        d_zifl_clr_cld(i) = 0. 
+                ENDIF 
+
+                !Update variables
+                znebprecipcld(i) = znebprecipcld(i) + d_znebprecip_clr_cld(i) - d_znebprecip_cld_clr(i)  
+                znebprecipclr(i) = znebprecipclr(i) + d_znebprecip_cld_clr(i) - d_znebprecip_clr_cld(i) 
+                zrflcld(i) = zrflcld(i) + d_zrfl_clr_cld(i) - d_zrfl_cld_clr(i) 
+                ziflcld(i) = ziflcld(i) + d_zifl_clr_cld(i) - d_zifl_cld_clr(i)
+                zrflclr(i) = zrflclr(i) + d_zrfl_cld_clr(i) - d_zrfl_clr_cld(i)
+                ziflclr(i) = ziflclr(i) + d_zifl_cld_clr(i) - d_zifl_clr_cld(i)
+
+        ENDDO
+ENDIF
+
+!>LTP
+
+
+
+     ! Initialisation de zoliq (eau condensee moyenne dans la maille)
+     DO i = 1, klon
+        IF (rneb(i,k).GT.0.0) THEN
+           zoliq(i) = zcond(i)
+           zrho(i) = pplay(i,k) / zt(i) / RD
+           zdz(i) = (paprs(i,k)-paprs(i,k+1)) / (zrho(i)*RG)
+        ENDIF
+     ENDDO
+!AJ<
+     IF (.NOT. ice_thermo) THEN
+       IF (iflag_t_glace.EQ.0) THEN
+         DO i = 1, klon
+            IF (rneb(i,k).GT.0.0) THEN
+               zfice(i) = 1.0 - (zt(i)-t_glace_min_old) / (273.13-t_glace_min_old)
+               zfice(i) = MIN(MAX(zfice(i),0.0),1.0)
+               zfice(i) = zfice(i)**exposant_glace_old
+!              zfice(i) = zfice(i)**nexpo
+         !!      zfice(i)=0.
+            ENDIF
+         ENDDO
+       ELSE ! of IF (iflag_t_glace.EQ.0)
+         CALL icefrac_lsc(klon,zt(:),pplay(:,k)/paprs(:,1),zfice(:))
+!         DO i = 1, klon
+!            IF (rneb(i,k).GT.0.0) THEN
+! JBM: icefrac_lsc is now a function contained in icefrac_lsc_mod
+!              zfice(i) = icefrac_lsc(zt(i), t_glace_min, &
+!                                     t_glace_max, exposant_glace)
+!            ENDIF
+!         ENDDO
+       ENDIF
+     ENDIF
+
+     ! Calcul de radliq (eau condensee pour le rayonnement)
+     ! Iteration pour realiser une moyenne de l'eau nuageuse lors de la precip
+     ! Remarque: ce n'est donc pas l'eau restante en fin de precip mais une
+     ! eau moyenne restante dans le nuage sur la duree du pas de temps qui est
+     ! transmise au rayonnement;
+     ! ----------------------------------------------------------------
+     DO i = 1, klon
+        IF (rneb(i,k).GT.0.0) THEN
+           zneb(i) = MAX(rneb(i,k), seuil_neb)
+     !      zt(i) = zt(i)+zcond(i)*zfice(i)*RLMLT/RCPD/(1.0+RVTMP2*zq(i))  
+!           print*,zt(i),'fractionglace'
+!>AJ
+           radliq(i,k) = zoliq(i)/REAL(ninter+1)
+        ENDIF
+     ENDDO
+     !
+     DO n = 1, ninter
+        DO i = 1, klon
+           IF (rneb(i,k).GT.0.0) THEN
+              zrhol(i) = zrho(i) * zoliq(i) / zneb(i)
+              ! Initialization of zpluie and zice:
+              zpluie=0
+              zice=0
+              IF (zneb(i).EQ.seuil_neb) THEN
+                 ztot = 0.0
+              ELSE
+                 !  quantite d'eau a eliminer: zchau (Sundqvist, 1978)
+                 !  meme chose pour la glace: zfroi (Zender & Kiehl, 1997)
+                 if (ptconv(i,k)) then
+                    zcl   =cld_lc_con
+                    zct   =1./cld_tau_con
+                    zfroi    = dtime/REAL(ninter)/zdz(i)*zoliq(i) &
+                         *fallvc(zrhol(i)) * zfice(i)
+                 else
+                    zcl   =cld_lc_lsc
+                    zct   =1./cld_tau_lsc
+                    zfroi    = dtime/REAL(ninter)/zdz(i)*zoliq(i) &
+                         *fallvs(zrhol(i)) * zfice(i)
+                 endif
+
+                 ! si l'heterogeneite verticale est active, on utilise 
+                 ! la fraction volumique "vraie" plutot que la fraction
+                 ! surfacique modifiee, qui est plus grande et reduit
+                 ! sinon l'eau in-cloud de facon artificielle
+                 if ((iflag_cloudth_vert>=3).AND.(iflag_rain_incloud_vol==1)) then
+                    zchau    = zct   *dtime/REAL(ninter) * zoliq(i) &
+                         *(1.0-EXP(-(zoliq(i)/ctot_vol(i,k)/zcl   )**2)) *(1.-zfice(i))
+                 else
+                    zchau    = zct   *dtime/REAL(ninter) * zoliq(i) &
+                         *(1.0-EXP(-(zoliq(i)/zneb(i)/zcl   )**2)) *(1.-zfice(i))
+                 endif
+!AJ<
+                 IF (.NOT. ice_thermo) THEN
+                   ztot    = zchau + zfroi
+                 ELSE
+                   zpluie = MIN(MAX(zchau,0.0),zoliq(i)*(1.-zfice(i)))
+                   zice = MIN(MAX(zfroi,0.0),zoliq(i)*zfice(i)) 
+                   ztot    = zpluie    + zice
+                 ENDIF
+!>AJ
+                 ztot    = MAX(ztot   ,0.0)
+              ENDIF
+              ztot    = MIN(ztot,zoliq(i))
+!AJ<
+     !         zoliqp = MAX(zoliq(i)*(1.-zfice(i))-1.*zpluie   , 0.0)
+     !         zoliqi = MAX(zoliq(i)*zfice(i)-1.*zice   , 0.0)
+!JLD : les 2 variables zoliqp et zoliqi crorresponent a des pseudo precip
+!      temporaires et ne doivent pas etre calcule (alors qu'elles le sont
+!      si iflag_bergeron <> 2
+!      A SUPPRIMER A TERME
+              zoliqp(i) = MAX(zoliq(i)*(1.-zfice(i))-1.*zpluie  , 0.0)
+              zoliqi(i) = MAX(zoliq(i)*zfice(i)-1.*zice  , 0.0)
+              zoliq(i) = MAX(zoliq(i)-ztot   , 0.0)
+!>AJ
+              radliq(i,k) = radliq(i,k) + zoliq(i)/REAL(ninter+1)
+           ENDIF
+        ENDDO  ! i = 1,klon
+     ENDDO     ! n = 1,ninter
+
+     ! ----------------------------------------------------------------
+     !
+     IF (.NOT. ice_thermo) THEN
+       DO i = 1, klon
+         IF (rneb(i,k).GT.0.0) THEN
+           d_ql(i,k) = zoliq(i)
+           zrfl(i) = zrfl(i)+ MAX(zcond(i)-zoliq(i),0.0) &
+                * (paprs(i,k)-paprs(i,k+1))/(RG*dtime)
+         ENDIF
+       ENDDO
+     ELSE
+!
+!CR&JYG<
+! On prend en compte l'effet Bergeron dans les flux de precipitation :
+! Si T < 0 C, alors les precipitations liquides sont converties en glace, ce qui
+! provoque un accroissement de temperature DeltaT. L'effet de DeltaT sur le condensat
+! et les precipitations est grossierement pris en compte en linearisant les equations 
+! et en approximant le processus de precipitation liquide par un processus a seuil.
+! On fait l'hypothese que le condensat nuageux n'est pas modifié dans cette opération.
+! Le condensat precipitant liquide est supprime (dans la limite DeltaT<273-T).
+! Le condensat precipitant solide est augmente.
+! La vapeur d'eau est augmentee.
+!
+       IF ((iflag_bergeron .EQ. 2)) THEN
+         DO i = 1, klon
+           IF (rneb(i,k) .GT. 0.0) THEN
+             zqpreci(i)=(zcond(i)-zoliq(i))*zfice(i)
+             zqprecl(i)=(zcond(i)-zoliq(i))*(1.-zfice(i))
+           if (fl_cor_ebil .GT. 0) then
+             zcp=RCPD*(1.0+RVTMP2*(zq(i)+zmqc(i)+zcond(i)))
+             coef1 = rneb(i,k)*RLSTT/zcp*zdqsdT_raw(i)
+!            Calcul de DT si toute les precips liquides congelent
+             DeltaT = RLMLT*zqprecl(i) / (zcp*(1.+coef1))
+!            On ne veut pas que T devienne superieur a la temp. de congelation.
+!            donc que Delta > RTT-zt(i
+             DeltaT = max( min( RTT-zt(i), DeltaT) , 0. )
+             zt(i)      = zt(i)      + DeltaT
+!            Eau vaporisee du fait de l'augmentation de T
+             Deltaq = rneb(i,k)*zdqsdT_raw(i)*DeltaT
+!            on reajoute cette eau vaporise a la vapeur et on l'enleve des precips
+             zq(i) = zq(i) +  Deltaq
+!            Les 3 max si dessous prtotegent uniquement des erreurs d'arrondies
+             zcond(i)   = max( zcond(i)- Deltaq, 0. )
+!            precip liquide qui congele ou qui s'evapore
+             Deltaqprecl = -zcp/RLMLT*(1.+coef1)*DeltaT
+             zqprecl(i) = max( zqprecl(i) + Deltaqprecl, 0. )
+!            bilan eau glacee
+             zqpreci(i) = max (zqpreci(i) - Deltaqprecl - Deltaq, 0.)
+           else ! if (fl_cor_ebil .GT. 0)
+!            ancien calcul
+             zcp=RCPD*(1.0+RVTMP2*(zq(i)+zcond(i)))
+             coef1 = RLMLT*zdqs(i)/RLVTT
+             DeltaT = max( min( RTT-zt(i), RLMLT*zqprecl(i)/zcp/(1.+coef1) ) , 0.)
+             zqpreci(i) = zqpreci(i) + zcp/RLMLT*DeltaT
+             zqprecl(i) = max( zqprecl(i) - zcp/RLMLT*(1.+coef1)*DeltaT, 0. )
+             zcond(i)   = max( zcond(i)   - zcp/RLVTT*zdqs(i)*DeltaT, 0. )
+             zq(i)      = zq(i)      + zcp/RLVTT*zdqs(i)*DeltaT
+             zt(i)      = zt(i)      + DeltaT
+           end if ! if (fl_cor_ebil .GT. 0)
+           ENDIF  ! rneb(i,k) .GT. 0.0
+         ENDDO
+         DO i = 1, klon
+           IF (rneb(i,k).GT.0.0) THEN
+             d_ql(i,k) = (1-zfice(i))*zoliq(i)
+             d_qi(i,k) = zfice(i)*zoliq(i)
+!<LTP
+             IF (iflag_evap_prec == 4) THEN
+                zrflcld(i) = zrflcld(i)+zqprecl(i) &
+                 *(paprs(i,k)-paprs(i,k+1))/(RG*dtime)
+                ziflcld(i) = ziflcld(i)+ zqpreci(i) &
+                      *(paprs(i,k)-paprs(i,k+1))/(RG*dtime)
+                znebprecipcld(i) = rneb(i,k)
+                zrfl(i) = zrflcld(i) + zrflclr(i)
+                zifl(i) = ziflcld(i) + ziflclr(i)        
+!>LTP
+             ELSE
+                zrfl(i) = zrfl(i)+ zqprecl(i) &
+                 *(paprs(i,k)-paprs(i,k+1))/(RG*dtime) 
+                zifl(i) = zifl(i)+ zqpreci(i) &
+                      *(paprs(i,k)-paprs(i,k+1))/(RG*dtime)  
+             
+             ENDIF !iflag_evap_prec==4
+
+           ENDIF                      
+         ENDDO
+!!
+       ELSE  ! iflag_bergeron
+!>CR&JYG
+!!
+       DO i = 1, klon
+         IF (rneb(i,k).GT.0.0) THEN
+!CR on prend en compte la phase glace
+!JLD inutile car on ne passe jamais ici si .not.ice_thermo
+!           if (.not.ice_thermo) then
+!           d_ql(i,k) = zoliq(i)
+!           d_qi(i,k) = 0.
+!           else
+           d_ql(i,k) = (1-zfice(i))*zoliq(i)
+           d_qi(i,k) = zfice(i)*zoliq(i)
+!           endif
+!<LTP
+             IF (iflag_evap_prec == 4) THEN
+                zrflcld(i) = zrflcld(i)+ MAX(zcond(i)*(1.-zfice(i))-zoliqp(i),0.0) &
+                       *(paprs(i,k)-paprs(i,k+1))/(RG*dtime) 
+                ziflcld(i) = ziflcld(i)+ MAX(zcond(i)*zfice(i)-zoliqi(i),0.0) &
+                        *(paprs(i,k)-paprs(i,k+1))/(RG*dtime)  
+                znebprecipcld(i) = rneb(i,k)
+                zrfl(i) = zrflcld(i) + zrflclr(i)
+                zifl(i) = ziflcld(i) + ziflclr(i)        
+!>LTP
+             ELSE
+!AJ<
+                   zrfl(i) = zrfl(i)+ MAX(zcond(i)*(1.-zfice(i))-zoliqp(i),0.0) &
+                       *(paprs(i,k)-paprs(i,k+1))/(RG*dtime) 
+                        zifl(i) = zifl(i)+ MAX(zcond(i)*zfice(i)-zoliqi(i),0.0) &
+                        *(paprs(i,k)-paprs(i,k+1))/(RG*dtime)  
+     !      zrfl(i) = zrfl(i)+  zpluie                         &
+     !          *(paprs(i,k)-paprs(i,k+1))/(RG*dtime) 
+     !      zifl(i) = zifl(i)+  zice                    &
+     !               *(paprs(i,k)-paprs(i,k+1))/(RG*dtime)                                    
+             ENDIF !iflag_evap_prec == 4             
+
+!CR : on prend en compte l'effet Bergeron dans les flux de precipitation
+           IF ((iflag_bergeron .EQ. 1) .AND. (zt(i) .LT. 273.15)) THEN
+!<LTP
+                IF (iflag_evap_prec == 4) THEN
+                     zsolid = zrfl(i)
+                     ziflclr(i) = ziflclr(i) +zrflclr(i)
+                     ziflcld(i) = ziflcld(i) +zrflcld(i)
+                     zifl(i) = ziflclr(i)+ziflcld(i)
+                     zrflcld(i)=0.
+                     zrflclr(i)=0.   
+                     zrfl(i) = zrflclr(i)+zrflcld(i)
+!>LTP
+                ELSE
+                     zsolid = zrfl(i)
+                     zifl(i) = zifl(i)+zrfl(i)
+                     zrfl(i) = 0.
+                 ENDIF!iflag_evap_prec==4
+
+           if (fl_cor_ebil .GT. 0) then
+              zt(i)=zt(i)+zsolid*(RG*dtime)/(paprs(i,k)-paprs(i,k+1)) &
+                      *(RLSTT-RLVTT)/RCPD/(1.0+RVTMP2*(zq(i)+zmqc(i)))
+           else
+              zt(i)=zt(i)+zsolid*(RG*dtime)/(paprs(i,k)-paprs(i,k+1)) &
+                      *(RLSTT-RLVTT)/RCPD/(1.0+RVTMP2*zq(i))
+           end if
+           ENDIF  ! (iflag_bergeron .EQ. 1) .AND. (zt(i) .LT. 273.15)
+!RC   
+
+         ENDIF ! rneb(i,k).GT.0.0
+       ENDDO
+
+       ENDIF  ! iflag_bergeron .EQ. 2
+     ENDIF  ! .NOT. ice_thermo
+
+!CR: la fonte est faite au debut
+!      IF (ice_thermo) THEN
+!       DO i = 1, klon
+!           zmelt = ((zt(i)-273.15)/(ztfondue-273.15))**2
+!           zmelt = MIN(MAX(zmelt,0.),1.)
+!           zrfl(i)=zrfl(i)+zmelt*zifl(i)
+!           zifl(i)=zifl(i)*(1.-zmelt)
+!           print*,zt(i),'octavio1'
+!           zt(i)=zt(i)-zifl(i)*zmelt*(RG*dtime)/(paprs(i,k)-paprs(i,k+1)) &
+!                      *RLMLT/RCPD/(1.0+RVTMP2*zq(i))
+!           print*,zt(i),zrfl(i),zifl(i),zmelt,'octavio2'
+!       ENDDO
+!     ENDIF
+
+
+!<LTP
+
+!Limitation de la fraction surfacique couverte par les précipitations lorsque l'intensité locale du flux de précipitation descend en
+!dessous de rain_int_min
+    IF (iflag_evap_prec==4) THEN
+        DO i=1, klon
+            IF (zrflclr(i) + ziflclr(i) .GT. 0 ) THEN
+               znebprecipclr(i) = min(znebprecipclr(i), max(zrflclr(i) &
+                    /(znebprecipclr(i)*rain_int_min), &
+                    ziflclr(i)/(znebprecipclr(i)*rain_int_min)))
+            ELSE
+                znebprecipclr(i)=0.
+            ENDIF
+
+            IF (zrflcld(i) + ziflcld(i) .GT. 0 ) THEN
+               znebprecipcld(i) = min(znebprecipcld(i), &
+                    max(zrflcld(i)/(znebprecipcld(i)*rain_int_min), &
+                    ziflcld(i)/(znebprecipcld(i)*rain_int_min)))
+            ELSE
+                znebprecipcld(i)=0.
+            ENDIF
+       ENDDO
+    ENDIf
+
+!>LTP
+
+
+
+
+       
+     IF (.NOT. ice_thermo) THEN
+       DO i = 1, klon
+         IF (zt(i).LT.RTT) THEN
+           psfl(i,k)=zrfl(i)
+         ELSE
+           prfl(i,k)=zrfl(i)
+         ENDIF
+       ENDDO
+     ELSE
+     ! JAM*************************************************
+     ! Revoir partie ci-dessous: a quoi servent psfl et prfl?
+     ! *****************************************************
+
+       DO i = 1, klon
+     !   IF (zt(i).LT.RTT) THEN
+           psfl(i,k)=zifl(i) 
+     !   ELSE
+           prfl(i,k)=zrfl(i)
+     !   ENDIF
+!>AJ
+       ENDDO
+     ENDIF
+     ! ----------------------------------------------------------------
+     ! Fin de formation des precipitations
+     ! ----------------------------------------------------------------
+     !
+     ! Calculer les tendances de q et de t:
+     !
+     DO i = 1, klon
+        d_q(i,k) = zq(i) - q(i,k)
+        d_t(i,k) = zt(i) - t(i,k)
+     ENDDO
+     !
+     !AA--------------- Calcul du lessivage stratiforme  -------------
+
+     DO i = 1,klon
+        !
+        if(zcond(i).gt.zoliq(i)+1.e-10) then
+         beta(i,k) = (zcond(i)-zoliq(i))/zcond(i)/dtime
+        else
+         beta(i,k) = 0.
+        endif
+        zprec_cond(i) = MAX(zcond(i)-zoliq(i),0.0) &
+             * (paprs(i,k)-paprs(i,k+1))/RG
+        IF (rneb(i,k).GT.0.0.and.zprec_cond(i).gt.0.) THEN
+           !AA lessivage nucleation LMD5 dans la couche elle-meme
+          IF (iflag_t_glace.EQ.0) THEN
+           if (t(i,k) .GE. t_glace_min_old) THEN
+              zalpha_tr = a_tr_sca(3)
+           else
+              zalpha_tr = a_tr_sca(4)
+           endif
+          ELSE ! of IF (iflag_t_glace.EQ.0)
+           if (t(i,k) .GE. t_glace_min) THEN
+              zalpha_tr = a_tr_sca(3)
+           else
+              zalpha_tr = a_tr_sca(4)
+           endif
+          ENDIF
+           zfrac_lessi = 1. - EXP(zalpha_tr*zprec_cond(i)/zneb(i))
+           pfrac_nucl(i,k)=pfrac_nucl(i,k)*(1.-zneb(i)*zfrac_lessi)
+           frac_nucl(i,k)= 1.-zneb(i)*zfrac_lessi 
+           !
+           ! nucleation avec un facteur -1 au lieu de -0.5
+           zfrac_lessi = 1. - EXP(-zprec_cond(i)/zneb(i))
+           pfrac_1nucl(i,k)=pfrac_1nucl(i,k)*(1.-zneb(i)*zfrac_lessi)
+        ENDIF
+        !
+     ENDDO      ! boucle sur i
+     !
+     !AA Lessivage par impaction dans les couches en-dessous
+     DO kk = k-1, 1, -1
+        DO i = 1, klon
+           IF (rneb(i,k).GT.0.0.and.zprec_cond(i).gt.0.) THEN
+             IF (iflag_t_glace.EQ.0) THEN
+              if (t(i,kk) .GE. t_glace_min_old) THEN
+                 zalpha_tr = a_tr_sca(1)
+              else
+                 zalpha_tr = a_tr_sca(2)
+              endif
+             ELSE ! of IF (iflag_t_glace.EQ.0)
+              if (t(i,kk) .GE. t_glace_min) THEN
+                 zalpha_tr = a_tr_sca(1)
+              else
+                 zalpha_tr = a_tr_sca(2)
+              endif
+             ENDIF
+              zfrac_lessi = 1. - EXP(zalpha_tr*zprec_cond(i)/zneb(i))
+              pfrac_impa(i,kk)=pfrac_impa(i,kk)*(1.-zneb(i)*zfrac_lessi)
+              frac_impa(i,kk)= 1.-zneb(i)*zfrac_lessi
+           ENDIF
+        ENDDO
+     ENDDO
+     !
+     !AA===============================================================
+     !                     FIN DE LA BOUCLE VERTICALE  
+  end DO
+  !
+  !AA==================================================================
+  !
+  ! Pluie ou neige au sol selon la temperature de la 1ere couche
+  !
+!CR: si la thermo de la glace est active, on calcule zifl directement
+  IF (.NOT.ice_thermo) THEN
+  DO i = 1, klon
+     IF ((t(i,1)+d_t(i,1)) .LT. RTT) THEN
+!AJ<
+!        snow(i) = zrfl(i)
+        snow(i) = zrfl(i)+zifl(i)
+!>AJ
+        zlh_solid(i) = RLSTT-RLVTT
+     ELSE
+        rain(i) = zrfl(i)
+        zlh_solid(i) = 0.
+     ENDIF
+  ENDDO
+
+  ELSE
+     DO i = 1, klon
+        snow(i) = zifl(i)
+        rain(i) = zrfl(i)
+     ENDDO
+   
+   ENDIF
+  !
+  ! For energy conservation : when snow is present, the solification
+  ! latent heat is considered.
+!CR: si thermo de la glace, neige deja prise en compte
+  IF (.not.ice_thermo) THEN
+  DO k = 1, klev
+     DO i = 1, klon
+        zcpair=RCPD*(1.0+RVTMP2*(q(i,k)+d_q(i,k)))
+        zmair(i)=(paprs(i,k)-paprs(i,k+1))/RG
+        zm_solid = (prfl(i,k)-prfl(i,k+1)+psfl(i,k)-psfl(i,k+1))*dtime
+        d_t(i,k) = d_t(i,k) + zlh_solid(i) *zm_solid / (zcpair*zmair(i))
+     END DO
+  END DO
+  ENDIF
+  !
+
+  if (ncoreczq>0) then
+     WRITE(lunout,*)'WARNING : ZQ dans fisrtilp ',ncoreczq,' val < 1.e-15.'
+  endif
+
+RETURN
+END SUBROUTINE fisrtilp
+END MODULE lmdz_lscp_old
Index: DZ6/trunk/libf/phylmd/lmdz_lscp_poprecip.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/lmdz_lscp_poprecip.F90	(revision 5267)
+++ 	(revision )
@@ -1,980 +1,0 @@
-MODULE lmdz_lscp_poprecip
-!----------------------------------------------------------------
-! Module for the process-oriented treament of precipitation
-! that are called in LSCP
-! Authors: Atelier Nuage (G. Riviere, L. Raillard, M. Wimmer,
-! N. Dutrievoz, E. Vignon, A. Borella, et al.)
-! Jan. 2024
-
-
-IMPLICIT NONE
-
-CONTAINS
-
-!----------------------------------------------------------------
-! Computes the processes-oriented precipitation formulations for
-! evaporation and sublimation
-! 
-SUBROUTINE poprecip_precld( &
-           klon, dtime, iftop, paprsdn, paprsup, pplay, temp, tempupnew, qvap, &
-           qprecip, precipfracclr, precipfraccld, qvapclrup, qtotupnew, &
-           rain, rainclr, raincld, snow, snowclr, snowcld, dqreva, dqssub &
-           )
-
-USE lmdz_lscp_ini, ONLY : prt_level, lunout
-USE lmdz_lscp_ini, ONLY : coef_eva, coef_sub, expo_eva, expo_sub, thresh_precip_frac
-USE lmdz_lscp_ini, ONLY : RCPD, RLSTT, RLVTT, RLMLT, RVTMP2, RTT, RD, RG
-USE lmdz_lscp_ini, ONLY : ok_corr_vap_evasub
-USE lmdz_lscp_tools, ONLY : calc_qsat_ecmwf
-
-IMPLICIT NONE
-
-
-INTEGER, INTENT(IN)                     :: klon           !--number of horizontal grid points [-]
-REAL,    INTENT(IN)                     :: dtime          !--time step [s]
-LOGICAL, INTENT(IN)                     :: iftop          !--if top of the column
-
-
-REAL,    INTENT(IN),    DIMENSION(klon) :: paprsdn        !--pressure at the bottom interface of the layer [Pa]
-REAL,    INTENT(IN),    DIMENSION(klon) :: paprsup        !--pressure at the top interface of the layer [Pa]
-REAL,    INTENT(IN),    DIMENSION(klon) :: pplay          !--pressure in the middle of the layer [Pa]
-
-REAL,    INTENT(INOUT), DIMENSION(klon) :: temp           !--current temperature [K]
-REAL,    INTENT(INOUT), DIMENSION(klon) :: tempupnew      !--updated temperature of the overlying layer [K]
-
-REAL,    INTENT(INOUT), DIMENSION(klon) :: qvap           !--current water vapor specific humidity (includes evaporated qi and ql) [kg/kg]
-REAL,    INTENT(INOUT), DIMENSION(klon) :: qprecip        !--specific humidity in the precipitation falling from the upper layer [kg/kg]
-
-REAL,    INTENT(INOUT), DIMENSION(klon) :: precipfracclr  !--fraction of precipitation in the clear sky IN THE LAYER ABOVE [-]
-REAL,    INTENT(INOUT), DIMENSION(klon) :: precipfraccld  !--fraction of precipitation in the cloudy air IN THE LAYER ABOVE [-]
-
-REAL,    INTENT(IN),    DIMENSION(klon) :: qvapclrup      !--clear-sky specific humidity IN THE LAYER ABOVE [kg/kg]
-REAL,    INTENT(IN),    DIMENSION(klon) :: qtotupnew      !--total specific humidity IN THE LAYER ABOVE [kg/kg]
-
-REAL,    INTENT(INOUT), DIMENSION(klon) :: rain           !--flux of rain gridbox-mean coming from the layer above [kg/s/m2]
-REAL,    INTENT(INOUT), DIMENSION(klon) :: rainclr        !--flux of rain gridbox-mean in clear sky coming from the layer above [kg/s/m2]
-REAL,    INTENT(IN),    DIMENSION(klon) :: raincld        !--flux of rain gridbox-mean in cloudy air coming from the layer above [kg/s/m2]
-REAL,    INTENT(INOUT), DIMENSION(klon) :: snow           !--flux of snow gridbox-mean coming from the layer above [kg/s/m2]
-REAL,    INTENT(INOUT), DIMENSION(klon) :: snowclr        !--flux of snow gridbox-mean in clear sky coming from the layer above [kg/s/m2]
-REAL,    INTENT(IN),    DIMENSION(klon) :: snowcld        !--flux of snow gridbox-mean in cloudy air coming from the layer above [kg/s/m2]
-
-REAL,    INTENT(OUT),   DIMENSION(klon) :: dqreva         !--rain tendency due to evaporation [kg/kg/s]
-REAL,    INTENT(OUT),   DIMENSION(klon) :: dqssub         !--snow tendency due to sublimation [kg/kg/s]
-
-
-!--Integer for interating over klon
-INTEGER :: i
-!--dhum_to_dflux: coef to convert a specific quantity variation to a flux variation
-REAL, DIMENSION(klon) :: dhum_to_dflux
-!--
-REAL, DIMENSION(klon) :: rho, dz
-
-!--Saturation values
-REAL, DIMENSION(klon) :: qzero, qsat, dqsat, qsatl, dqsatl, qsati, dqsati
-!--Vapor in the clear sky
-REAL :: qvapclr
-!--Fluxes tendencies because of evaporation and sublimation
-REAL :: dprecip_evasub_max, draineva, dsnowsub, dprecip_evasub_tot
-!--Specific humidity tendencies because of evaporation and sublimation
-REAL :: dqrevap, dqssubl
-!--Specific heat constant
-REAL :: cpair, cpw
-
-!--Initialisation
-qzero(:)  = 0.
-dqreva(:) = 0.
-dqssub(:) = 0.
-dqrevap   = 0.
-dqssubl   = 0.
-
-!-- dhum_to_dflux = rho * dz/dt = 1 / g * dP/dt
-dhum_to_dflux(:) = ( paprsdn(:) - paprsup(:) ) / RG / dtime
-rho(:) = pplay(:) / temp(:) / RD
-dz(:) = ( paprsdn(:) - paprsup(:) ) / RG / rho(:)
-
-!--Calculation of saturation specific humidity
-!--depending on temperature:
-CALL calc_qsat_ecmwf(klon,temp(:),qzero(:),pplay(:),RTT,0,.false.,qsat(:),dqsat(:))
-!--wrt liquid water
-CALL calc_qsat_ecmwf(klon,temp(:),qzero(:),pplay(:),RTT,1,.false.,qsatl(:),dqsatl(:))
-!--wrt ice
-CALL calc_qsat_ecmwf(klon,temp(:),qzero(:),pplay(:),RTT,2,.false.,qsati(:),dqsati(:))
-
-
-
-!--First step consists in "thermalizing" the layer:
-!--as the flux of precip from layer above "advects" some heat (as the precip is at the temperature 
-!--of the overlying layer) we recalculate a mean temperature that both the air and the precip in the 
-!--layer have.
-
-IF (iftop) THEN
-
-  DO i = 1, klon
-    qprecip(i) = 0.
-  ENDDO
-
-ELSE
-
-  DO i = 1, klon
-    !--No condensed water so cp=cp(vapor+dry air)
-    !-- RVTMP2=rcpv/rcpd-1
-    cpair = RCPD * ( 1. + RVTMP2 * qvap(i) )
-    cpw = RCPD * RVTMP2
-    !--qprecip has to be thermalized with 
-    !--layer's air so that precipitation at the ground has the
-    !--same temperature as the lowermost layer
-    !--we convert the flux into a specific quantity qprecip
-    qprecip(i) = ( rain(i) + snow(i) ) / dhum_to_dflux(i)
-    !-- t(i,k+1) + d_t(i,k+1): new temperature of the overlying layer
-    temp(i) = ( tempupnew(i) * qprecip(i) * cpw + cpair * temp(i) ) &
-            / ( cpair + qprecip(i) * cpw )
-  ENDDO
-
-ENDIF
-
-! TODO Probleme : on utilise qvap total dans la maille pour l'evap / sub
-! alors qu'on n'evap / sub que dans le ciel clair
-! deux options pour cette routine :
-! - soit on diagnostique le nuage AVANT l'evap / sub et on estime donc
-! la fraction precipitante ciel clair dans la maille, ce qui permet de travailler
-! avec des fractions, des fluxs et surtout un qvap dans le ciel clair
-! - soit on pousse la param de Ludo au bout, et on prend un qvap de k+1
-! dans le ciel clair, avec un truc comme :
-!   qvapclr(k) = qvapclr(k+1)/qtot(k+1) * qtot(k)
-! UPDATE : on code la seconde version. A voir si on veut mettre la premiere version.
-
-
-DO i = 1, klon
-
-  !--If there is precipitation from the layer above
-  ! NOTE TODO here we could replace the condition on precipfracclr(i) by a condition
-  ! such as eps or thresh_precip_frac, to remove the senseless barrier in the formulas
-  ! of evap / sublim
-  IF ( ( ( rain(i) + snow(i) ) .GT. 0. ) .AND. ( precipfracclr(i) .GT. 0. ) ) THEN
-
-    IF ( ok_corr_vap_evasub ) THEN
-      !--Corrected version - we use the same water ratio between
-      !--the clear and the cloudy sky as in the layer above. This
-      !--extends the assumption that the cloud fraction is the same
-      !--as the layer above. This is assumed only for the evap / subl
-      !--process
-      !--Note that qvap(i) is the total water in the gridbox, and
-      !--precipfraccld(i) is the cloud fraction in the layer above
-      qvapclr = qvapclrup(i) / qtotupnew(i) * qvap(i) / ( 1. - precipfraccld(i) )
-    ELSE
-      !--Legacy version from Ludo - we use the total specific humidity
-      !--for the evap / subl process
-      qvapclr = qvap(i)
-    ENDIF
-
-    !--Evaporation of liquid precipitation coming from above
-    !--in the clear sky only
-    !--dprecip/dz = -beta*(1-qvap/qsat)*(precip**expo_eva)
-    !--formula from Sundqvist 1988, Klemp & Wilhemson 1978
-    !--Exact explicit formulation (rainclr is resolved exactly, qvap explicitly)
-    !--which does not need a barrier on rainclr, because included in the formula
-    draineva = precipfracclr(i) * ( MAX(0., &
-             - coef_eva * ( 1. - expo_eva ) * (1. - qvapclr / qsatl(i)) * dz(i) &
-             + ( rainclr(i) / MAX(thresh_precip_frac, precipfracclr(i)) )**( 1. - expo_eva ) &
-               ) )**( 1. / ( 1. - expo_eva ) ) - rainclr(i)
-             
-    !--Evaporation is limited by 0
-    draineva = MIN(0., draineva)
-
-
-    !--Sublimation of the solid precipitation coming from above
-    !--(same formula as for liquid precip)
-    !--Exact explicit formulation (snowclr is resolved exactly, qvap explicitly)
-    !--which does not need a barrier on snowclr, because included in the formula
-    dsnowsub = precipfracclr(i) * ( MAX(0., &
-             - coef_sub * ( 1. - expo_sub ) * (1. - qvapclr / qsati(i)) * dz(i) &
-             + ( snowclr(i) / MAX(thresh_precip_frac, precipfracclr(i)) )**( 1. - expo_sub ) &
-             ) )**( 1. / ( 1. - expo_sub ) ) - snowclr(i)
-
-    !--Sublimation is limited by 0
-    ! TODO: change max when we will allow for vapor deposition in supersaturated regions
-    dsnowsub = MIN(0., dsnowsub)
-
-    !--Evaporation limit: we ensure that the layer's fraction below
-    !--the clear sky does not reach saturation. In this case, we 
-    !--redistribute the maximum flux dprecip_evasub_max conserving the ratio liquid/ice 
-    !--Max evaporation is computed not to saturate the clear sky precip fraction
-    !--(i.e., the fraction where evaporation occurs)
-    !--It is expressed as a max flux dprecip_evasub_max
-    
-    dprecip_evasub_max = MIN(0., ( qvapclr - qsat(i) ) * precipfracclr(i)) &
-                     * dhum_to_dflux(i)
-    dprecip_evasub_tot = draineva + dsnowsub
-
-    !--Barriers
-    !--If activates if the total is LOWER than the max because
-    !--everything is negative
-    IF ( dprecip_evasub_tot .LT. dprecip_evasub_max ) THEN
-      draineva = dprecip_evasub_max * draineva / dprecip_evasub_tot
-      dsnowsub = dprecip_evasub_max * dsnowsub / dprecip_evasub_tot
-    ENDIF
-
-
-    !--New solid and liquid precipitation fluxes after evap and sublimation
-    dqrevap = draineva / dhum_to_dflux(i)
-    dqssubl = dsnowsub / dhum_to_dflux(i)
-
-
-    !--Vapor is updated after evaporation/sublimation (it is increased)
-    qvap(i) = qvap(i) - dqrevap - dqssubl
-    !--qprecip is the total condensed water in the precip flux (it is decreased)
-    qprecip(i) = qprecip(i) + dqrevap + dqssubl
-    !--Air and precip temperature (i.e., gridbox temperature)
-    !--is updated due to latent heat cooling
-    temp(i) = temp(i) &
-            + dqrevap * RLVTT / RCPD &
-            / ( 1. + RVTMP2 * ( qvap(i) + qprecip(i) ) ) &
-            + dqssubl * RLSTT / RCPD &
-            / ( 1. + RVTMP2 * ( qvap(i) + qprecip(i) ) )
-
-    !--Add tendencies
-    !--The MAX is needed because in some cases, the flux can be slightly negative (numerical precision)
-    rainclr(i) = MAX(0., rainclr(i) + draineva)
-    snowclr(i) = MAX(0., snowclr(i) + dsnowsub)
-
-    !--If there is no more precip fluxes, the precipitation fraction in clear
-    !--sky is set to 0
-    IF ( ( rainclr(i) + snowclr(i) ) .LE. 0. ) precipfracclr(i) = 0.
-
-    !--Calculation of the total fluxes
-    rain(i) = rainclr(i) + raincld(i)
-    snow(i) = snowclr(i) + snowcld(i)
-
-  ELSEIF ( ( rain(i) + snow(i) ) .LE. 0. ) THEN
-    !--If no precip, we reinitialize the cloud fraction used for the precip to 0 
-    precipfraccld(i) = 0.
-    precipfracclr(i) = 0.
-
-  ENDIF ! ( ( rain(i) + snow(i) ) .GT. 0. )
-
-  !--Diagnostic tendencies
-  dqssub(i) = dqssubl / dtime
-  dqreva(i) = dqrevap / dtime
-
-ENDDO ! loop on klon
-
-
-END SUBROUTINE poprecip_precld
-
-!----------------------------------------------------------------
-! Computes the processes-oriented precipitation formulations for
-! - autoconversion (auto) via a deposition process
-! - aggregation (agg)
-! - riming (rim)
-! - collection (col)
-! - melting (melt)
-! - freezing (freez)
-! 
-SUBROUTINE poprecip_postcld( &
-           klon, dtime, paprsdn, paprsup, pplay, ctot_vol, ptconv, &
-           temp, qvap, qliq, qice, icefrac, cldfra, &
-           precipfracclr, precipfraccld, &
-           rain, rainclr, raincld, snow, snowclr, snowcld, &
-           qraindiag, qsnowdiag, dqrauto, dqrcol, dqrmelt, dqrfreez, &
-           dqsauto, dqsagg, dqsrim, dqsmelt, dqsfreez)
-
-USE lmdz_lscp_ini, ONLY : prt_level, lunout
-USE lmdz_lscp_ini, ONLY : RCPD, RLSTT, RLVTT, RLMLT, RVTMP2, RTT, RD, RG, RPI
-USE lmdz_lscp_tools, ONLY : calc_qsat_ecmwf
-
-USE lmdz_lscp_ini, ONLY : cld_lc_con, cld_tau_con, cld_expo_con, seuil_neb,    &
-                          cld_lc_lsc, cld_tau_lsc, cld_expo_lsc, rain_int_min, & 
-                          thresh_precip_frac, gamma_col, gamma_agg, gamma_rim, &
-                          rho_rain, r_rain, r_snow, rho_ice,                   &
-                          tau_auto_snow_min, tau_auto_snow_max,                &
-                          thresh_precip_frac, eps,                             &
-                          gamma_melt, alpha_freez, beta_freez, temp_nowater,   &
-                          iflag_cloudth_vert, iflag_rain_incloud_vol,          &
-                          cld_lc_lsc_snow, cld_lc_con_snow, gamma_freez,       &
-                          rain_fallspeed_clr, rain_fallspeed_cld,              &
-                          snow_fallspeed_clr, snow_fallspeed_cld
-
-
-IMPLICIT NONE
-
-INTEGER, INTENT(IN)                     :: klon           !--number of horizontal grid points [-]
-REAL,    INTENT(IN)                     :: dtime          !--time step [s]
-
-REAL,    INTENT(IN),    DIMENSION(klon) :: paprsdn        !--pressure at the bottom interface of the layer [Pa]
-REAL,    INTENT(IN),    DIMENSION(klon) :: paprsup        !--pressure at the top interface of the layer [Pa]
-REAL,    INTENT(IN),    DIMENSION(klon) :: pplay          !--pressure in the middle of the layer [Pa]
-
-REAL,    INTENT(IN),    DIMENSION(klon) :: ctot_vol       !--volumic cloud fraction [-]
-LOGICAL, INTENT(IN),    DIMENSION(klon) :: ptconv         !--true if we are in a convective point
-
-REAL,    INTENT(INOUT), DIMENSION(klon) :: temp           !--current temperature [K]
-REAL,    INTENT(INOUT), DIMENSION(klon) :: qvap           !--current water vapor specific humidity [kg/kg]
-REAL,    INTENT(INOUT), DIMENSION(klon) :: qliq           !--current liquid water specific humidity [kg/kg]
-REAL,    INTENT(INOUT), DIMENSION(klon) :: qice           !--current ice water specific humidity [kg/kg]
-REAL,    INTENT(IN),    DIMENSION(klon) :: icefrac        !--ice fraction [-]
-REAL,    INTENT(IN),    DIMENSION(klon) :: cldfra         !--cloud fraction [-]
-
-REAL,    INTENT(INOUT), DIMENSION(klon) :: precipfracclr  !--fraction of precipitation in the clear sky IN THE LAYER ABOVE [-]
-REAL,    INTENT(INOUT), DIMENSION(klon) :: precipfraccld  !--fraction of precipitation in the cloudy air IN THE LAYER ABOVE [-]
-                                                          !--NB. at the end of the routine, becomes the fraction of precip
-                                                          !--in the current layer
-
-REAL,    INTENT(INOUT), DIMENSION(klon) :: rain           !--flux of rain gridbox-mean coming from the layer above [kg/s/m2]
-REAL,    INTENT(INOUT), DIMENSION(klon) :: rainclr        !--flux of rain gridbox-mean in clear sky coming from the layer above [kg/s/m2]
-REAL,    INTENT(INOUT), DIMENSION(klon) :: raincld        !--flux of rain gridbox-mean in cloudy air coming from the layer above [kg/s/m2]
-REAL,    INTENT(INOUT), DIMENSION(klon) :: snow           !--flux of snow gridbox-mean coming from the layer above [kg/s/m2]
-REAL,    INTENT(INOUT), DIMENSION(klon) :: snowclr        !--flux of snow gridbox-mean in clear sky coming from the layer above [kg/s/m2]
-REAL,    INTENT(INOUT), DIMENSION(klon) :: snowcld        !--flux of snow gridbox-mean in cloudy air coming from the layer above [kg/s/m2]
-
-REAL,    INTENT(OUT),   DIMENSION(klon) :: qraindiag      !--DIAGNOSTIC specific rain content [kg/kg]
-REAL,    INTENT(OUT),   DIMENSION(klon) :: qsnowdiag      !--DIAGNOSTIC specific snow content [kg/kg]
-REAL,    INTENT(OUT),   DIMENSION(klon) :: dqrcol         !--rain tendendy due to collection by rain of liquid cloud droplets [kg/kg/s]
-REAL,    INTENT(OUT),   DIMENSION(klon) :: dqsagg         !--snow tendency due to collection of lcoud ice by aggregation [kg/kg/s]
-REAL,    INTENT(OUT),   DIMENSION(klon) :: dqrauto        !--rain tendency due to autoconversion of cloud liquid [kg/kg/s]
-REAL,    INTENT(OUT),   DIMENSION(klon) :: dqsauto        !--snow tendency due to autoconversion of cloud ice [kg/kg/s]
-REAL,    INTENT(OUT),   DIMENSION(klon) :: dqsrim         !--snow tendency due to riming [kg/kg/s]
-REAL,    INTENT(OUT),   DIMENSION(klon) :: dqsmelt        !--snow tendency due to melting [kg/kg/s]
-REAL,    INTENT(OUT),   DIMENSION(klon) :: dqrmelt        !--rain tendency due to melting [kg/kg/s]
-REAL,    INTENT(OUT),   DIMENSION(klon) :: dqsfreez       !--snow tendency due to freezing [kg/kg/s]
-REAL,    INTENT(OUT),   DIMENSION(klon) :: dqrfreez       !--rain tendency due to freezing [kg/kg/s]
-
-
-
-!--Local variables
-
-INTEGER :: i
-!--dhum_to_dflux: coef to convert a specific quantity variation to a flux variation
-REAL, DIMENSION(klon) :: dhum_to_dflux
-REAL, DIMENSION(klon) :: qtot                             !--includes vap, liq, ice and precip
-
-!--Partition of the fluxes
-REAL :: dcldfra
-REAL :: precipfractot
-REAL :: dprecipfracclr, dprecipfraccld
-REAL :: drainclr, dsnowclr
-REAL :: draincld, dsnowcld
-
-!--Collection, aggregation and riming
-REAL :: eff_cldfra
-REAL :: coef_col, coef_agg, coef_rim, coef_tmp, qrain_tmp
-REAL :: Eff_rain_liq, Eff_snow_ice, Eff_snow_liq
-REAL :: rho_snow
-REAL :: dqlcol           !--loss of liquid cloud content due to collection by rain [kg/kg/s]
-REAL :: dqiagg           !--loss of ice cloud content due to collection by aggregation [kg/kg/s]
-REAL :: dqlrim           !--loss of liquid cloud content due to riming on snow [kg/kg/s]
-
-!--Autoconversion
-REAL :: qthresh_auto_rain, tau_auto_rain, expo_auto_rain
-REAL :: qthresh_auto_snow, tau_auto_snow, expo_auto_snow
-REAL :: dqlauto          !--loss of liquid cloud content due to autoconversion to rain [kg/kg/s]
-REAL :: dqiauto          !--loss of ice cloud content due to autoconversion to snow [kg/kg/s]
-
-!--Melting
-REAL :: dqsmelt_max, air_thermal_conduct
-REAL :: nb_snowflake_clr, nb_snowflake_cld
-REAL :: capa_snowflake, temp_wetbulb
-REAL :: rho, r_ice
-REAL :: dqsclrmelt, dqscldmelt, dqstotmelt
-REAL, DIMENSION(klon) :: qzero, qsat, dqsat
-
-!--Freezing
-REAL :: dqrfreez_max
-REAL :: tau_freez
-REAL :: dqrclrfreez, dqrcldfreez, dqrtotfreez, dqrtotfreez_step1, dqrtotfreez_step2
-REAL :: coef_freez
-REAL :: dqifreez        !--loss of ice cloud content due to collection of ice from rain [kg/kg/s]
-REAL :: Eff_rain_ice
-
-
-!--Initialisation of variables
-
-
-qzero(:)    = 0.
-
-dqrcol(:)   = 0.
-dqsagg(:)   = 0.
-dqsauto(:)  = 0.
-dqrauto(:)  = 0.
-dqsrim(:)   = 0.
-dqrmelt(:)  = 0.
-dqsmelt(:)  = 0.
-dqrfreez(:) = 0.
-dqsfreez(:) = 0.
-
-
-DO i = 1, klon
-
-  !--Variables initialisation
-  dqlcol  = 0.
-  dqiagg  = 0.
-  dqiauto = 0.
-  dqlauto = 0.
-  dqlrim  = 0.
-
-  !-- dhum_to_dflux = rho * dz/dt = 1 / g * dP/dt
-  dhum_to_dflux(i) = ( paprsdn(i) - paprsup(i) ) / RG / dtime
-  qtot(i) = qvap(i) + qliq(i) + qice(i) &
-          + ( raincld(i) + rainclr(i) + snowcld(i) + snowclr(i) ) / dhum_to_dflux(i)
-
-  !------------------------------------------------------------
-  !--     PRECIPITATION FRACTIONS UPDATE
-  !------------------------------------------------------------
-  !--The goal of this routine is to reattribute precipitation fractions
-  !--and fluxes to clear or cloudy air, depending on the variation of
-  !--the cloud fraction on the vertical dimension. We assume a
-  !--maximum-random overlap of the cloud cover (see Jakob and Klein, 2000,
-  !--and LTP thesis, 2021)
-  !--NB. in fact, we assume a maximum-random overlap of the total precip. frac
-
-  !--Initialisation
-  precipfractot = precipfracclr(i) + precipfraccld(i)
-
-  !--Instead of using the cloud cover which was use in LTP thesis, we use the
-  !--total precip. fraction to compute the maximum-random overlap. This is
-  !--because all the information of the cloud cover is embedded into
-  !--precipfractot, and this allows for taking into account the potential
-  !--reduction of the precipitation fraction because either the flux is too
-  !--small (see barrier at the end of poprecip_postcld) or the flux is completely
-  !--evaporated (see barrier at the end of poprecip_precld)
-  !--NB. precipfraccld(i) is here the cloud fraction of the layer above
-  !precipfractot = 1. - ( 1. - precipfractot ) * &
-  !               ( 1. - MAX( cldfra(i), precipfraccld(i) ) ) &
-  !             / ( 1. - MIN( precipfraccld(i), 1. - eps ) )
-
-
-  IF ( precipfraccld(i) .GT. ( 1. - eps ) ) THEN
-    precipfractot = 1.
-  ELSE
-    precipfractot = 1. - ( 1. - precipfractot ) * &
-                 ( 1. - MAX( cldfra(i), precipfraccld(i) ) ) &
-               / ( 1. - precipfraccld(i) )
-  ENDIF
-
-  !--precipfraccld(i) is here the cloud fraction of the layer above
-  dcldfra = cldfra(i) - precipfraccld(i)
-  !--Tendency of the clear-sky precipitation fraction. We add a MAX on the
-  !--calculation of the current CS precip. frac.
-  !dprecipfracclr = MAX( 0., ( precipfractot - cldfra(i) ) ) - precipfracclr(i)
-  !--We remove it, because precipfractot is guaranteed to be > cldfra (the MAX is activated
-  !--if precipfractot < cldfra)
-  dprecipfracclr = ( precipfractot - cldfra(i) ) - precipfracclr(i)
-  !--Tendency of the cloudy precipitation fraction. We add a MAX on the
-  !--calculation of the current CS precip. frac.
-  !dprecipfraccld = MAX( dcldfra , - precipfraccld(i) ) 
-  !--We remove it, because cldfra is guaranteed to be > 0 (the MAX is activated
-  !--if cldfra < 0)
-  dprecipfraccld = dcldfra
-
-
-  !--If the cloud extends
-  IF ( dprecipfraccld .GT. 0. ) THEN
-    !--If there is no CS precip, nothing happens.
-    !--If there is, we reattribute some of the CS precip flux
-    !--to the cloud precip flux, proportionnally to the
-    !--decrease of the CS precip fraction
-    IF ( precipfracclr(i) .LE. 0. ) THEN
-      drainclr = 0.
-      dsnowclr = 0.
-    ELSE
-      drainclr = dprecipfracclr / precipfracclr(i) * rainclr(i) 
-      dsnowclr = dprecipfracclr / precipfracclr(i) * snowclr(i) 
-    ENDIF
-  !--If the cloud narrows
-  ELSEIF ( dprecipfraccld .LT. 0. ) THEN
-    !--We reattribute some of the cloudy precip flux
-    !--to the CS precip flux, proportionnally to the
-    !--decrease of the cloud precip fraction
-    draincld = dprecipfraccld / precipfraccld(i) * raincld(i) 
-    dsnowcld = dprecipfraccld / precipfraccld(i) * snowcld(i) 
-    drainclr = - draincld
-    dsnowclr = - dsnowcld
-  !--If the cloud stays the same or if there is no cloud above and
-  !--in the current layer, nothing happens
-  ELSE
-    drainclr = 0.
-    dsnowclr = 0.
-  ENDIF
-
-  !--We add the tendencies
-  !--The MAX is needed because in some cases, the flux can be slightly negative (numerical precision)
-  precipfraccld(i) = precipfraccld(i) + dprecipfraccld
-  precipfracclr(i) = precipfracclr(i) + dprecipfracclr
-  rainclr(i) = MAX(0., rainclr(i) + drainclr)
-  snowclr(i) = MAX(0., snowclr(i) + dsnowclr)
-  raincld(i) = MAX(0., raincld(i) - drainclr)
-  snowcld(i) = MAX(0., snowcld(i) - dsnowclr)
-  
-  !--If vertical heterogeneity is taken into account, we use
-  !--the "true" volume fraction instead of a modified 
-  !--surface fraction (which is larger and artificially
-  !--reduces the in-cloud water).
-  IF ( ( iflag_cloudth_vert .GE. 3 ) .AND. ( iflag_rain_incloud_vol .EQ. 1 ) ) THEN
-    eff_cldfra = ctot_vol(i)
-  ELSE
-    eff_cldfra = cldfra(i)
-  ENDIF 
-
-
-  !--Start precipitation growth processes
-
-  !--If the cloud is big enough, the precipitation processes activate
-  ! TODO met on seuil_neb ici ?
-  IF ( cldfra(i) .GE. seuil_neb ) THEN
-
-    !---------------------------------------------------------
-    !--           COLLECTION AND AGGREGATION
-    !---------------------------------------------------------
-    !--Collection: processus through which rain collects small liquid droplets
-    !--in suspension, and add it to the rain flux
-    !--Aggregation: same for snow (precip flux) and ice crystals (in suspension)
-    !--Those processes are treated before autoconversion because we do not
-    !--want to collect/aggregate the newly formed fluxes, which already
-    !--"saw" the cloud as they come from it
-    !--The formulas come from Muench and Lohmann 2020
-
-    !--gamma_col: tuning coefficient [-]
-    !--rho_rain: volumic mass of rain [kg/m3]
-    !--r_rain: size of the rain droplets [m]
-    !--Eff_rain_liq: efficiency of the collection process [-] (between 0 and 1)
-    !--dqlcol is a gridbox-mean quantity, as is qliq and raincld. They are
-    !--divided by respectively eff_cldfra, eff_cldfra and precipfraccld to
-    !--get in-cloud mean quantities. The two divisions by eff_cldfra are
-    !--then simplified.
-
-    !--The collection efficiency is perfect.
-    Eff_rain_liq = 1.
-    coef_col = gamma_col * 3. / 4. / rho_rain / r_rain * Eff_rain_liq
-    IF ( raincld(i) .GT. 0. ) THEN
-      !--Exact explicit version, which does not need a barrier because of
-      !--the exponential decrease
-      dqlcol = qliq(i) * ( EXP( - dtime * coef_col * raincld(i) / precipfraccld(i) ) - 1. )
-
-      !--Add tendencies
-      qliq(i) = qliq(i) + dqlcol
-      raincld(i) = raincld(i) - dqlcol * dhum_to_dflux(i)
-
-      !--Diagnostic tendencies
-      dqrcol(i)  = - dqlcol  / dtime
-    ENDIF
-
-    !--Same as for aggregation
-    !--Eff_snow_liq formula:
-    !--it s a product of a collection efficiency and a sticking efficiency
-    ! Milbrandt and Yau formula that gives very low values:
-    ! Eff_snow_ice = 0.05 * EXP( 0.1 * ( temp(i) - RTT ) )
-    ! Lin 1983's formula 
-    Eff_snow_ice = EXP( 0.025 * MIN( ( temp(i) - RTT ), 0.) ) 
-    !--rho_snow formula follows Brandes et al. 2007 (JAMC)
-    rho_snow = 1.e3 * 0.178 * ( r_snow * 2. * 1000. )**(-0.922)
-    coef_agg = gamma_agg * 3. / 4. / rho_snow / r_snow * Eff_snow_ice
-    IF ( snowcld(i) .GT. 0. ) THEN
-      !--Exact explicit version, which does not need a barrier because of
-      !--the exponential decrease
-      dqiagg = qice(i) * ( EXP( - dtime * coef_agg * snowcld(i) / precipfraccld(i) ) - 1. )
-
-      !--Add tendencies
-      qice(i) = qice(i) + dqiagg
-      snowcld(i) = snowcld(i) - dqiagg * dhum_to_dflux(i)
-
-      !--Diagnostic tendencies
-      dqsagg(i)  = - dqiagg  / dtime
-    ENDIF
-
-
-    !---------------------------------------------------------
-    !--                  AUTOCONVERSION
-    !---------------------------------------------------------
-    !--Autoconversion converts liquid droplets/ice crystals into
-    !--rain drops/snowflakes. It relies on the formulations by
-    !--Sundqvist 1978.
-
-    !--If we are in a convective point, we have different parameters
-    !--for the autoconversion
-    IF ( ptconv(i) ) THEN
-        qthresh_auto_rain = cld_lc_con
-        qthresh_auto_snow = cld_lc_con_snow
-
-        tau_auto_rain = cld_tau_con
-        !--tau for snow depends on the ice fraction in mixed-phase clouds     
-        tau_auto_snow = tau_auto_snow_max &
-                      + ( tau_auto_snow_min - tau_auto_snow_max ) * ( 1. - icefrac(i) )
-
-        expo_auto_rain = cld_expo_con
-        expo_auto_snow = cld_expo_con
-    ELSE
-        qthresh_auto_rain = cld_lc_lsc
-        qthresh_auto_snow = cld_lc_lsc_snow
-
-        tau_auto_rain = cld_tau_lsc
-        !--tau for snow depends on the ice fraction in mixed-phase clouds     
-        tau_auto_snow = tau_auto_snow_max &
-                      + ( tau_auto_snow_min - tau_auto_snow_max ) * ( 1. - icefrac(i) )
-
-        expo_auto_rain = cld_expo_lsc
-        expo_auto_snow = cld_expo_lsc
-    ENDIF
-
-
-    ! Liquid water quantity to remove according to (Sundqvist, 1978)
-    ! dqliq/dt = -qliq/tau * ( 1-exp(-(qliqincld/qthresh)**2) )
-    !
-    !--And same formula for ice
-    !
-    !--We first treat the second term (with exponential) in an explicit way
-    !--and then treat the first term (-q/tau) in an exact way
-
-    dqlauto = - qliq(i) * ( 1. - exp( - dtime / tau_auto_rain * ( 1. - exp( &
-               - ( qliq(i) / eff_cldfra / qthresh_auto_rain ) ** expo_auto_rain ) ) ) )
-
-    dqiauto = - qice(i) * ( 1. - exp( - dtime / tau_auto_snow * ( 1. - exp( &
-               - ( qice(i) / eff_cldfra / qthresh_auto_snow ) ** expo_auto_snow ) ) ) )
-
-
-    !--Barriers so that we don't create more rain/snow
-    !--than there is liquid/ice
-    dqlauto = MAX( - qliq(i), dqlauto )
-    dqiauto = MAX( - qice(i), dqiauto )
-
-    !--Add tendencies
-    qliq(i) = qliq(i) + dqlauto
-    qice(i) = qice(i) + dqiauto
-    raincld(i) = raincld(i) - dqlauto * dhum_to_dflux(i)
-    snowcld(i) = snowcld(i) - dqiauto * dhum_to_dflux(i)
-
-    !--Diagnostic tendencies
-    dqsauto(i) = - dqiauto / dtime
-    dqrauto(i) = - dqlauto / dtime
-
-
-    !---------------------------------------------------------
-    !--                  RIMING
-    !---------------------------------------------------------
-    !--Process which converts liquid droplets in suspension into
-    !--snow because of the collision between
-    !--those and falling snowflakes.
-    !--The formula comes from Muench and Lohmann 2020
-    !--NB.: this process needs a temperature adjustment
-
-    !--Eff_snow_liq formula: following Ferrier 1994,
-    !--assuming 1
-    Eff_snow_liq = 1.0
-    !--rho_snow formula follows Brandes et al. 2007 (JAMC)
-    rho_snow = 1.e3 * 0.178 * ( r_snow * 2. * 1000. )**(-0.922)
-    coef_rim = gamma_rim * 3. / 4. / rho_snow / r_snow * Eff_snow_liq
-    IF ( snowcld(i) .GT. 0. ) THEN
-      !--Exact version, which does not need a barrier because of
-      !--the exponential decrease
-      dqlrim = qliq(i) * ( EXP( - dtime * coef_rim * snowcld(i) / precipfraccld(i) ) - 1. )
-
-      !--Add tendencies
-      !--The MAX is needed because in some cases, the flux can be slightly negative (numerical precision)
-      qliq(i) = qliq(i) + dqlrim
-      snowcld(i) = snowcld(i) - dqlrim * dhum_to_dflux(i)
-
-      !--Temperature adjustment with the release of latent
-      !--heat because of solid condensation
-      temp(i) = temp(i) - dqlrim * RLMLT / RCPD &
-                        / ( 1. + RVTMP2 * qtot(i) )
-
-      !--Diagnostic tendencies
-      dqsrim(i)  = - dqlrim  / dtime
-    ENDIF
-
-  ENDIF ! cldfra .GE. seuil_neb
-
-ENDDO ! loop on klon
-
-
-!--Re-calculation of saturation specific humidity
-!--because riming changed temperature
-CALL calc_qsat_ecmwf(klon, temp, qzero, pplay, RTT, 0, .FALSE., qsat, dqsat)
-
-DO i = 1, klon
-
-  !---------------------------------------------------------
-  !--                  MELTING
-  !---------------------------------------------------------
-  !--Process through which snow melts into rain. 
-  !--The formula is homemade.
-  !--NB.: this process needs a temperature adjustment
-
-  !--dqsmelt_max         : maximum snow melting so that temperature
-  !--                      stays higher than 273 K [kg/kg]
-  !--capa_snowflake      : capacitance of a snowflake, equal to
-  !--                      the radius if the snowflake is a sphere [m]
-  !--temp_wetbulb        : wet-bulb temperature [K]
-  !--snow_fallspeed      : snow fall velocity (in clear/cloudy sky) [m/s]
-  !--air_thermal_conduct : thermal conductivity of the air [J/m/K/s]
-  !--gamma_melt          : tuning parameter for melting [-]
-  !--nb_snowflake        : number of snowflakes (in clear/cloudy air) [-]
-
-  IF ( ( snowclr(i) + snowcld(i) ) .GT. 0. ) THEN
-    !--Computed according to
-    !--Cpdry * Delta T * (1 + (Cpvap/Cpdry - 1) * qtot) = Lfusion * Delta q
-    dqsmelt_max = MIN(0., ( RTT - temp(i) ) / RLMLT * RCPD &
-                        * ( 1. + RVTMP2 * qtot(i) ))
-   
-    !--Initialisation 
-    dqsclrmelt = 0.
-    dqscldmelt = 0.
-
-    !--We assume that the snowflakes are spherical
-    capa_snowflake = r_snow
-    !--Thermal conductivity of the air, empirical formula from Beard and Pruppacher (1971)
-    air_thermal_conduct = ( 5.69 + 0.017 * ( temp(i) - RTT ) ) * 1.e-3 * 4.184    
-    !--rho_snow formula follows Brandes et al. 2007 (JAMC)
-    rho_snow = 1.e3 * 0.178 * ( r_snow * 2. * 1000. )**(-0.922)
-
-    !--In clear air
-    IF ( ( snowclr(i) .GT. 0. ) .AND.  ( precipfracclr(i) .GT. 0. ) ) THEN
-      !--Formula for the wet-bulb temperature from ECMWF (IFS)
-      !--The vapor used is the vapor in the clear sky
-      temp_wetbulb = temp(i) &
-                   - ( qsat(i) - ( qvap(i) - cldfra(i) * qsat(i) ) / ( 1. - cldfra(i) ) ) &
-                   * ( 1329.31 + 0.0074615 * ( pplay(i) - 0.85e5 ) &
-                   - 40.637 * ( temp(i) - 275. ) )
-      !--Calculated according to
-      !-- flux = velocity_snowflakes * nb_snowflakes * volume_snowflakes * rho_snow
-      nb_snowflake_clr = snowclr(i) / precipfracclr(i) / snow_fallspeed_clr &
-                       / ( 4. / 3. * RPI * r_snow**3. * rho_snow )
-      dqsclrmelt = - nb_snowflake_clr * 4. * RPI * air_thermal_conduct &
-                   * capa_snowflake / RLMLT * gamma_melt &
-                   * MAX(0., temp_wetbulb - RTT) * dtime
-      
-      !--Barrier to limit the melting flux to the clr snow flux in the mesh
-      dqsclrmelt = MAX( dqsclrmelt , -snowclr(i) / dhum_to_dflux(i))
-    ENDIF
-
-
-    !--In cloudy air
-    IF ( ( snowcld(i) .GT. 0. ) .AND. ( precipfraccld(i) .GT. 0. ) ) THEN
-      !--As the air is saturated, the wet-bulb temperature is equal to the
-      !--temperature
-      temp_wetbulb = temp(i)
-      !--Calculated according to
-      !-- flux = velocity_snowflakes * nb_snowflakes * volume_snowflakes * rho_snow
-      nb_snowflake_cld = snowcld(i) / precipfraccld(i) / snow_fallspeed_cld &
-                       / ( 4. / 3. * RPI * r_snow**3. * rho_snow )
-      dqscldmelt = - nb_snowflake_cld * 4. * RPI * air_thermal_conduct &
-                   * capa_snowflake / RLMLT * gamma_melt &
-                   * MAX(0., temp_wetbulb - RTT) * dtime
-
-      !--Barrier to limit the melting flux to the cld snow flux in the mesh
-      dqscldmelt = MAX(dqscldmelt , - snowcld(i) / dhum_to_dflux(i))
-   ENDIF
-    
-
-    !--Barrier on temperature. If the total melting flux leads to a
-    !--positive temperature, it is limited to keep temperature above 0 degC.
-    !--It is activated if the total is LOWER than the max
-    !--because everything is negative
-    dqstotmelt = dqsclrmelt + dqscldmelt
-    IF ( dqstotmelt .LT. dqsmelt_max ) THEN
-      !--We redistribute the max melted snow keeping
-      !--the clear/cloud partition of the melted snow
-      dqsclrmelt = dqsmelt_max * dqsclrmelt / dqstotmelt
-      dqscldmelt = dqsmelt_max * dqscldmelt / dqstotmelt
-      dqstotmelt = dqsmelt_max
-
-    ENDIF
-
-    !--Add tendencies
-    !--The MAX is needed because in some cases, the flux can be slightly negative (numerical precision)
-    rainclr(i) = MAX(0., rainclr(i) - dqsclrmelt * dhum_to_dflux(i))
-    raincld(i) = MAX(0., raincld(i) - dqscldmelt * dhum_to_dflux(i))
-    snowclr(i) = MAX(0., snowclr(i) + dqsclrmelt * dhum_to_dflux(i))
-    snowcld(i) = MAX(0., snowcld(i) + dqscldmelt * dhum_to_dflux(i))
-
-    !--Temperature adjustment with the release of latent
-    !--heat because of melting
-    temp(i) = temp(i) + dqstotmelt * RLMLT / RCPD &
-                      / ( 1. + RVTMP2 * qtot(i) )
-
-    !--Diagnostic tendencies
-    dqrmelt(i) = - dqstotmelt / dtime
-    dqsmelt(i) = dqstotmelt / dtime
-
-  ENDIF
-
-
-  !---------------------------------------------------------
-  !--                  FREEZING
-  !---------------------------------------------------------
-  !--Process through which rain freezes into snow. 
-  !-- We parameterize it as a 2 step process:
-  !--first: freezing following collision with ice crystals
-  !--second: immersion freezing following (inspired by Bigg 1953)
-  !--the latter is parameterized as an exponential decrease of the rain
-  !--water content with a homemade formulya
-  !--This is based on a caracteritic time of freezing, which
-  !--exponentially depends on temperature so that it is
-  !--equal to 1 for temp_nowater (see below) and is close to
-  !--0 for RTT (=273.15 K).
-  !--NB.: this process needs a temperature adjustment
-  !--dqrfreez_max : maximum rain freezing so that temperature
-  !--              stays lower than 273 K [kg/kg]
-  !--tau_freez    : caracteristic time of freezing [s]
-  !--gamma_freez  : tuning parameter [s-1]
-  !--alpha_freez  : tuning parameter for the shape of the exponential curve [-]
-  !--temp_nowater : temperature below which no liquid water exists [K] (about -40 degC)
-
-  IF ( ( rainclr(i) + raincld(i) ) .GT. 0. ) THEN
-
- 
-    !--1st step: freezing following collision with ice crystals
-    !--Sub-process of freezing which quantifies the collision between
-    !--ice crystals in suspension and falling rain droplets.
-    !--The rain droplets freeze, becoming graupel, and carrying
-    !--the ice crystal (which acted as an ice nucleating particle).
-    !--The formula is adapted from the riming formula.
-    !--it works only in the cloudy part
-
-    dqifreez = 0.
-    dqrtotfreez_step1 = 0.
-
-    IF ( ( qice(i) .GT. 0. ) .AND. ( cldfra(i) .GT. 0. ) .AND. &
-         ( raincld(i) .GT. 0. ) .AND. ( precipfraccld(i) .GT. 0. ) ) THEN
-      dqrclrfreez = 0.
-      dqrcldfreez = 0.
-
-      !--Computed according to
-      !--Cpdry * Delta T * (1 + (Cpvap/Cpdry - 1) * qtot) = Lfusion * Delta q
-      dqrfreez_max = MIN(0., ( temp(i) - RTT ) / RLMLT * RCPD &
-                         * ( 1. + RVTMP2 * qtot(i) ))
- 
-
-      !--The collision efficiency is assumed unity 
-      Eff_rain_ice = 1.
-      coef_freez = gamma_freez * 3. / 4. / rho_rain / r_rain * Eff_rain_ice
-      !--Exact version, which does not need a barrier because of
-      !--the exponential decrease.
-      dqifreez = qice(i) * ( EXP( - dtime * coef_freez * raincld(i) / precipfraccld(i) ) - 1. )
-
-      !--We add the part of rain water that freezes, limited by a temperature barrier
-      !--This quantity is calculated assuming that the number of drop that freeze correspond to the number
-      !--of crystals collected (and assuming uniform distributions of ice crystals and rain drops)
-      !--The ice specific humidity that collide with rain is dqi = dNi 4/3 PI rho_ice r_ice**3
-      !--The rain that collide with ice is, similarly, dqr = dNr 4/3 PI rho_rain r_rain**3
-      !--The assumption above corresponds to dNi = dNr, i.e.,
-      !-- dqr = dqi * (4/3 PI rho_rain * r_rain**3) / (4/3 PI rho_ice * r_ice**3)
-      !--Dry density [kg/m3]
-      rho = pplay(i) / temp(i) / RD
-      !--r_ice formula from Sun and Rikus (1999)
-      r_ice = 1.e-6 * ( 45.8966 * ( qice(i) / cldfra(i) * rho * 1e3 )**0.2214 &
-            + 0.7957 * ( qice(i) / cldfra(i) * rho * 1e3 )**0.2535 * ( temp(i) - RTT + 190. ) ) / 2.
-      dqrcldfreez = dqifreez * rho_rain * r_rain**3. / ( rho_ice * r_ice**3. )
-      dqrcldfreez = MAX(dqrcldfreez, - raincld(i) / dhum_to_dflux(i))
-      dqrcldfreez = MAX(dqrcldfreez, dqrfreez_max) 
-      dqrtotfreez_step1 = dqrcldfreez
-
-      !--Add tendencies
-      !--The MAX is needed because in some cases, the flux can be slightly negative (numerical precision)
-      qice(i) = qice(i) + dqifreez
-      raincld(i) = MAX(0., raincld(i) + dqrcldfreez * dhum_to_dflux(i))
-      snowcld(i) = MAX(0., snowcld(i) - dqrcldfreez * dhum_to_dflux(i) - dqifreez * dhum_to_dflux(i))
-      temp(i) = temp(i) - dqrtotfreez_step1 * RLMLT / RCPD &
-                        / ( 1. + RVTMP2 * qtot(i) )
-
-    ENDIF
-    
-    !-- Second step immersion freezing of rain drops
-    !-- with a homemade timeconstant depending on temperature
-
-    dqrclrfreez = 0.
-    dqrcldfreez = 0.
-    dqrtotfreez_step2 = 0.
-    !--Computed according to
-    !--Cpdry * Delta T * (1 + (Cpvap/Cpdry - 1) * qtot) = Lfusion * Delta q
-
-    dqrfreez_max = MIN(0., ( temp(i) - RTT ) / RLMLT * RCPD &
-                         * ( 1. + RVTMP2 * qtot(i) ))
-
-    
-    tau_freez = 1. / ( beta_freez &
-              * EXP( - alpha_freez * ( temp(i) - temp_nowater ) / ( RTT - temp_nowater ) ) )
-
-
-    !--In clear air
-    IF ( rainclr(i) .GT. 0. ) THEN
-      !--Exact solution of dqrain/dt = -qrain/tau_freez
-      dqrclrfreez = rainclr(i) / dhum_to_dflux(i) * ( EXP( - dtime / tau_freez ) - 1. )
-    ENDIF
-
-    !--In cloudy air
-    IF ( raincld(i) .GT. 0. ) THEN
-      !--Exact solution of dqrain/dt = -qrain/tau_freez
-      dqrcldfreez = raincld(i) / dhum_to_dflux(i) * ( EXP( - dtime / tau_freez ) - 1. )
-    ENDIF
-
-    !--temperature barrier step 2
-    !--It is activated if the total is LOWER than the max
-    !--because everything is negative
-    dqrtotfreez_step2 = dqrclrfreez + dqrcldfreez
-  
-    IF ( dqrtotfreez_step2 .LT. dqrfreez_max ) THEN
-      !--We redistribute the max freezed rain keeping
-      !--the clear/cloud partition of the freezing rain
-      dqrclrfreez = dqrfreez_max * dqrclrfreez / dqrtotfreez_step2
-      dqrcldfreez = dqrfreez_max * dqrcldfreez / dqrtotfreez_step2
-      dqrtotfreez_step2 = dqrfreez_max
-    ENDIF
-
-
-    !--Add tendencies
-    !--The MAX is needed because in some cases, the flux can be slightly negative (numerical precision)
-    rainclr(i) = MAX(0., rainclr(i) + dqrclrfreez * dhum_to_dflux(i))
-    raincld(i) = MAX(0., raincld(i) + dqrcldfreez * dhum_to_dflux(i))
-    snowclr(i) = MAX(0., snowclr(i) - dqrclrfreez * dhum_to_dflux(i))
-    snowcld(i) = MAX(0., snowcld(i) - dqrcldfreez * dhum_to_dflux(i))
-
-
-    !--Temperature adjustment with the uptake of latent
-    !--heat because of freezing
-    temp(i) = temp(i) - dqrtotfreez_step2 * RLMLT / RCPD &
-                      / ( 1. + RVTMP2 * qtot(i) )
-
-    !--Diagnostic tendencies
-    dqrtotfreez = dqrtotfreez_step1 + dqrtotfreez_step2          
-    dqrfreez(i) = dqrtotfreez / dtime
-    dqsfreez(i) = -(dqrtotfreez + dqifreez) / dtime
-
-  ENDIF
-
-
-
-  !--If the local flux of rain+snow in clear/cloudy air is lower than rain_int_min,
-  !--we reduce the precipiration fraction in the clear/cloudy air so that the new
-  !--local flux of rain+snow is equal to rain_int_min.
-  !--Here, rain+snow is the gridbox-mean flux of precip.
-  !--Therefore, (rain+snow)/precipfrac is the local flux of precip.
-  !--If the local flux of precip is lower than rain_int_min, i.e.,
-  !-- (rain+snow)/precipfrac < rain_int_min , i.e., 
-  !-- (rain+snow)/rain_int_min < precipfrac , then we want to reduce
-  !--the precip fraction to the equality, i.e., precipfrac = (rain+snow)/rain_int_min.
-  !--Note that this is physically different than what is proposed in LTP thesis.
-  precipfracclr(i) = MIN( precipfracclr(i), ( rainclr(i) + snowclr(i) ) / rain_int_min )
-  precipfraccld(i) = MIN( precipfraccld(i), ( raincld(i) + snowcld(i) ) / rain_int_min )
-
-  !--Calculate outputs
-  rain(i) = rainclr(i) + raincld(i)
-  snow(i) = snowclr(i) + snowcld(i)
-
-  !--Diagnostics
-  !--BEWARE this is indeed a diagnostic: this is an estimation from
-  !--the value of the flux at the bottom interface of the mesh and
-  !--and assuming an upstream numerical calculation
-  !--If ok_radocond_snow is TRUE, then the diagnostic qsnowdiag is
-  !--used for computing the total ice water content in the mesh
-  !--for radiation only
-  qraindiag(i) = ( rainclr(i) / ( pplay(i) / RD / temp(i) ) / rain_fallspeed_clr &
-                 + raincld(i) / ( pplay(i) / RD / temp(i) ) / rain_fallspeed_cld )
-  qsnowdiag(i) = ( snowclr(i) / ( pplay(i) / RD / temp(i) ) / snow_fallspeed_clr &
-                 + snowcld(i) / ( pplay(i) / RD / temp(i) ) / snow_fallspeed_cld )
-
-
-ENDDO ! loop on klon
-
-
-END SUBROUTINE poprecip_postcld
-
-END MODULE lmdz_lscp_poprecip
Index: /LMDZ6/trunk/libf/phylmd/lmdz_lscp_poprecip.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/lmdz_lscp_poprecip.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/lmdz_lscp_poprecip.f90	(revision 5268)
@@ -0,0 +1,980 @@
+MODULE lmdz_lscp_poprecip
+!----------------------------------------------------------------
+! Module for the process-oriented treament of precipitation
+! that are called in LSCP
+! Authors: Atelier Nuage (G. Riviere, L. Raillard, M. Wimmer,
+! N. Dutrievoz, E. Vignon, A. Borella, et al.)
+! Jan. 2024
+
+
+IMPLICIT NONE
+
+CONTAINS
+
+!----------------------------------------------------------------
+! Computes the processes-oriented precipitation formulations for
+! evaporation and sublimation
+! 
+SUBROUTINE poprecip_precld( &
+           klon, dtime, iftop, paprsdn, paprsup, pplay, temp, tempupnew, qvap, &
+           qprecip, precipfracclr, precipfraccld, qvapclrup, qtotupnew, &
+           rain, rainclr, raincld, snow, snowclr, snowcld, dqreva, dqssub &
+           )
+
+USE lmdz_lscp_ini, ONLY : prt_level, lunout
+USE lmdz_lscp_ini, ONLY : coef_eva, coef_sub, expo_eva, expo_sub, thresh_precip_frac
+USE lmdz_lscp_ini, ONLY : RCPD, RLSTT, RLVTT, RLMLT, RVTMP2, RTT, RD, RG
+USE lmdz_lscp_ini, ONLY : ok_corr_vap_evasub
+USE lmdz_lscp_tools, ONLY : calc_qsat_ecmwf
+
+IMPLICIT NONE
+
+
+INTEGER, INTENT(IN)                     :: klon           !--number of horizontal grid points [-]
+REAL,    INTENT(IN)                     :: dtime          !--time step [s]
+LOGICAL, INTENT(IN)                     :: iftop          !--if top of the column
+
+
+REAL,    INTENT(IN),    DIMENSION(klon) :: paprsdn        !--pressure at the bottom interface of the layer [Pa]
+REAL,    INTENT(IN),    DIMENSION(klon) :: paprsup        !--pressure at the top interface of the layer [Pa]
+REAL,    INTENT(IN),    DIMENSION(klon) :: pplay          !--pressure in the middle of the layer [Pa]
+
+REAL,    INTENT(INOUT), DIMENSION(klon) :: temp           !--current temperature [K]
+REAL,    INTENT(INOUT), DIMENSION(klon) :: tempupnew      !--updated temperature of the overlying layer [K]
+
+REAL,    INTENT(INOUT), DIMENSION(klon) :: qvap           !--current water vapor specific humidity (includes evaporated qi and ql) [kg/kg]
+REAL,    INTENT(INOUT), DIMENSION(klon) :: qprecip        !--specific humidity in the precipitation falling from the upper layer [kg/kg]
+
+REAL,    INTENT(INOUT), DIMENSION(klon) :: precipfracclr  !--fraction of precipitation in the clear sky IN THE LAYER ABOVE [-]
+REAL,    INTENT(INOUT), DIMENSION(klon) :: precipfraccld  !--fraction of precipitation in the cloudy air IN THE LAYER ABOVE [-]
+
+REAL,    INTENT(IN),    DIMENSION(klon) :: qvapclrup      !--clear-sky specific humidity IN THE LAYER ABOVE [kg/kg]
+REAL,    INTENT(IN),    DIMENSION(klon) :: qtotupnew      !--total specific humidity IN THE LAYER ABOVE [kg/kg]
+
+REAL,    INTENT(INOUT), DIMENSION(klon) :: rain           !--flux of rain gridbox-mean coming from the layer above [kg/s/m2]
+REAL,    INTENT(INOUT), DIMENSION(klon) :: rainclr        !--flux of rain gridbox-mean in clear sky coming from the layer above [kg/s/m2]
+REAL,    INTENT(IN),    DIMENSION(klon) :: raincld        !--flux of rain gridbox-mean in cloudy air coming from the layer above [kg/s/m2]
+REAL,    INTENT(INOUT), DIMENSION(klon) :: snow           !--flux of snow gridbox-mean coming from the layer above [kg/s/m2]
+REAL,    INTENT(INOUT), DIMENSION(klon) :: snowclr        !--flux of snow gridbox-mean in clear sky coming from the layer above [kg/s/m2]
+REAL,    INTENT(IN),    DIMENSION(klon) :: snowcld        !--flux of snow gridbox-mean in cloudy air coming from the layer above [kg/s/m2]
+
+REAL,    INTENT(OUT),   DIMENSION(klon) :: dqreva         !--rain tendency due to evaporation [kg/kg/s]
+REAL,    INTENT(OUT),   DIMENSION(klon) :: dqssub         !--snow tendency due to sublimation [kg/kg/s]
+
+
+!--Integer for interating over klon
+INTEGER :: i
+!--dhum_to_dflux: coef to convert a specific quantity variation to a flux variation
+REAL, DIMENSION(klon) :: dhum_to_dflux
+!--
+REAL, DIMENSION(klon) :: rho, dz
+
+!--Saturation values
+REAL, DIMENSION(klon) :: qzero, qsat, dqsat, qsatl, dqsatl, qsati, dqsati
+!--Vapor in the clear sky
+REAL :: qvapclr
+!--Fluxes tendencies because of evaporation and sublimation
+REAL :: dprecip_evasub_max, draineva, dsnowsub, dprecip_evasub_tot
+!--Specific humidity tendencies because of evaporation and sublimation
+REAL :: dqrevap, dqssubl
+!--Specific heat constant
+REAL :: cpair, cpw
+
+!--Initialisation
+qzero(:)  = 0.
+dqreva(:) = 0.
+dqssub(:) = 0.
+dqrevap   = 0.
+dqssubl   = 0.
+
+!-- dhum_to_dflux = rho * dz/dt = 1 / g * dP/dt
+dhum_to_dflux(:) = ( paprsdn(:) - paprsup(:) ) / RG / dtime
+rho(:) = pplay(:) / temp(:) / RD
+dz(:) = ( paprsdn(:) - paprsup(:) ) / RG / rho(:)
+
+!--Calculation of saturation specific humidity
+!--depending on temperature:
+CALL calc_qsat_ecmwf(klon,temp(:),qzero(:),pplay(:),RTT,0,.false.,qsat(:),dqsat(:))
+!--wrt liquid water
+CALL calc_qsat_ecmwf(klon,temp(:),qzero(:),pplay(:),RTT,1,.false.,qsatl(:),dqsatl(:))
+!--wrt ice
+CALL calc_qsat_ecmwf(klon,temp(:),qzero(:),pplay(:),RTT,2,.false.,qsati(:),dqsati(:))
+
+
+
+!--First step consists in "thermalizing" the layer:
+!--as the flux of precip from layer above "advects" some heat (as the precip is at the temperature 
+!--of the overlying layer) we recalculate a mean temperature that both the air and the precip in the 
+!--layer have.
+
+IF (iftop) THEN
+
+  DO i = 1, klon
+    qprecip(i) = 0.
+  ENDDO
+
+ELSE
+
+  DO i = 1, klon
+    !--No condensed water so cp=cp(vapor+dry air)
+    !-- RVTMP2=rcpv/rcpd-1
+    cpair = RCPD * ( 1. + RVTMP2 * qvap(i) )
+    cpw = RCPD * RVTMP2
+    !--qprecip has to be thermalized with 
+    !--layer's air so that precipitation at the ground has the
+    !--same temperature as the lowermost layer
+    !--we convert the flux into a specific quantity qprecip
+    qprecip(i) = ( rain(i) + snow(i) ) / dhum_to_dflux(i)
+    !-- t(i,k+1) + d_t(i,k+1): new temperature of the overlying layer
+    temp(i) = ( tempupnew(i) * qprecip(i) * cpw + cpair * temp(i) ) &
+            / ( cpair + qprecip(i) * cpw )
+  ENDDO
+
+ENDIF
+
+! TODO Probleme : on utilise qvap total dans la maille pour l'evap / sub
+! alors qu'on n'evap / sub que dans le ciel clair
+! deux options pour cette routine :
+! - soit on diagnostique le nuage AVANT l'evap / sub et on estime donc
+! la fraction precipitante ciel clair dans la maille, ce qui permet de travailler
+! avec des fractions, des fluxs et surtout un qvap dans le ciel clair
+! - soit on pousse la param de Ludo au bout, et on prend un qvap de k+1
+! dans le ciel clair, avec un truc comme :
+!   qvapclr(k) = qvapclr(k+1)/qtot(k+1) * qtot(k)
+! UPDATE : on code la seconde version. A voir si on veut mettre la premiere version.
+
+
+DO i = 1, klon
+
+  !--If there is precipitation from the layer above
+  ! NOTE TODO here we could replace the condition on precipfracclr(i) by a condition
+  ! such as eps or thresh_precip_frac, to remove the senseless barrier in the formulas
+  ! of evap / sublim
+  IF ( ( ( rain(i) + snow(i) ) .GT. 0. ) .AND. ( precipfracclr(i) .GT. 0. ) ) THEN
+
+    IF ( ok_corr_vap_evasub ) THEN
+      !--Corrected version - we use the same water ratio between
+      !--the clear and the cloudy sky as in the layer above. This
+      !--extends the assumption that the cloud fraction is the same
+      !--as the layer above. This is assumed only for the evap / subl
+      !--process
+      !--Note that qvap(i) is the total water in the gridbox, and
+      !--precipfraccld(i) is the cloud fraction in the layer above
+      qvapclr = qvapclrup(i) / qtotupnew(i) * qvap(i) / ( 1. - precipfraccld(i) )
+    ELSE
+      !--Legacy version from Ludo - we use the total specific humidity
+      !--for the evap / subl process
+      qvapclr = qvap(i)
+    ENDIF
+
+    !--Evaporation of liquid precipitation coming from above
+    !--in the clear sky only
+    !--dprecip/dz = -beta*(1-qvap/qsat)*(precip**expo_eva)
+    !--formula from Sundqvist 1988, Klemp & Wilhemson 1978
+    !--Exact explicit formulation (rainclr is resolved exactly, qvap explicitly)
+    !--which does not need a barrier on rainclr, because included in the formula
+    draineva = precipfracclr(i) * ( MAX(0., &
+             - coef_eva * ( 1. - expo_eva ) * (1. - qvapclr / qsatl(i)) * dz(i) &
+             + ( rainclr(i) / MAX(thresh_precip_frac, precipfracclr(i)) )**( 1. - expo_eva ) &
+               ) )**( 1. / ( 1. - expo_eva ) ) - rainclr(i)
+             
+    !--Evaporation is limited by 0
+    draineva = MIN(0., draineva)
+
+
+    !--Sublimation of the solid precipitation coming from above
+    !--(same formula as for liquid precip)
+    !--Exact explicit formulation (snowclr is resolved exactly, qvap explicitly)
+    !--which does not need a barrier on snowclr, because included in the formula
+    dsnowsub = precipfracclr(i) * ( MAX(0., &
+             - coef_sub * ( 1. - expo_sub ) * (1. - qvapclr / qsati(i)) * dz(i) &
+             + ( snowclr(i) / MAX(thresh_precip_frac, precipfracclr(i)) )**( 1. - expo_sub ) &
+             ) )**( 1. / ( 1. - expo_sub ) ) - snowclr(i)
+
+    !--Sublimation is limited by 0
+    ! TODO: change max when we will allow for vapor deposition in supersaturated regions
+    dsnowsub = MIN(0., dsnowsub)
+
+    !--Evaporation limit: we ensure that the layer's fraction below
+    !--the clear sky does not reach saturation. In this case, we 
+    !--redistribute the maximum flux dprecip_evasub_max conserving the ratio liquid/ice 
+    !--Max evaporation is computed not to saturate the clear sky precip fraction
+    !--(i.e., the fraction where evaporation occurs)
+    !--It is expressed as a max flux dprecip_evasub_max
+    
+    dprecip_evasub_max = MIN(0., ( qvapclr - qsat(i) ) * precipfracclr(i)) &
+                     * dhum_to_dflux(i)
+    dprecip_evasub_tot = draineva + dsnowsub
+
+    !--Barriers
+    !--If activates if the total is LOWER than the max because
+    !--everything is negative
+    IF ( dprecip_evasub_tot .LT. dprecip_evasub_max ) THEN
+      draineva = dprecip_evasub_max * draineva / dprecip_evasub_tot
+      dsnowsub = dprecip_evasub_max * dsnowsub / dprecip_evasub_tot
+    ENDIF
+
+
+    !--New solid and liquid precipitation fluxes after evap and sublimation
+    dqrevap = draineva / dhum_to_dflux(i)
+    dqssubl = dsnowsub / dhum_to_dflux(i)
+
+
+    !--Vapor is updated after evaporation/sublimation (it is increased)
+    qvap(i) = qvap(i) - dqrevap - dqssubl
+    !--qprecip is the total condensed water in the precip flux (it is decreased)
+    qprecip(i) = qprecip(i) + dqrevap + dqssubl
+    !--Air and precip temperature (i.e., gridbox temperature)
+    !--is updated due to latent heat cooling
+    temp(i) = temp(i) &
+            + dqrevap * RLVTT / RCPD &
+            / ( 1. + RVTMP2 * ( qvap(i) + qprecip(i) ) ) &
+            + dqssubl * RLSTT / RCPD &
+            / ( 1. + RVTMP2 * ( qvap(i) + qprecip(i) ) )
+
+    !--Add tendencies
+    !--The MAX is needed because in some cases, the flux can be slightly negative (numerical precision)
+    rainclr(i) = MAX(0., rainclr(i) + draineva)
+    snowclr(i) = MAX(0., snowclr(i) + dsnowsub)
+
+    !--If there is no more precip fluxes, the precipitation fraction in clear
+    !--sky is set to 0
+    IF ( ( rainclr(i) + snowclr(i) ) .LE. 0. ) precipfracclr(i) = 0.
+
+    !--Calculation of the total fluxes
+    rain(i) = rainclr(i) + raincld(i)
+    snow(i) = snowclr(i) + snowcld(i)
+
+  ELSEIF ( ( rain(i) + snow(i) ) .LE. 0. ) THEN
+    !--If no precip, we reinitialize the cloud fraction used for the precip to 0 
+    precipfraccld(i) = 0.
+    precipfracclr(i) = 0.
+
+  ENDIF ! ( ( rain(i) + snow(i) ) .GT. 0. )
+
+  !--Diagnostic tendencies
+  dqssub(i) = dqssubl / dtime
+  dqreva(i) = dqrevap / dtime
+
+ENDDO ! loop on klon
+
+
+END SUBROUTINE poprecip_precld
+
+!----------------------------------------------------------------
+! Computes the processes-oriented precipitation formulations for
+! - autoconversion (auto) via a deposition process
+! - aggregation (agg)
+! - riming (rim)
+! - collection (col)
+! - melting (melt)
+! - freezing (freez)
+! 
+SUBROUTINE poprecip_postcld( &
+           klon, dtime, paprsdn, paprsup, pplay, ctot_vol, ptconv, &
+           temp, qvap, qliq, qice, icefrac, cldfra, &
+           precipfracclr, precipfraccld, &
+           rain, rainclr, raincld, snow, snowclr, snowcld, &
+           qraindiag, qsnowdiag, dqrauto, dqrcol, dqrmelt, dqrfreez, &
+           dqsauto, dqsagg, dqsrim, dqsmelt, dqsfreez)
+
+USE lmdz_lscp_ini, ONLY : prt_level, lunout
+USE lmdz_lscp_ini, ONLY : RCPD, RLSTT, RLVTT, RLMLT, RVTMP2, RTT, RD, RG, RPI
+USE lmdz_lscp_tools, ONLY : calc_qsat_ecmwf
+
+USE lmdz_lscp_ini, ONLY : cld_lc_con, cld_tau_con, cld_expo_con, seuil_neb,    &
+                          cld_lc_lsc, cld_tau_lsc, cld_expo_lsc, rain_int_min, & 
+                          thresh_precip_frac, gamma_col, gamma_agg, gamma_rim, &
+                          rho_rain, r_rain, r_snow, rho_ice,                   &
+                          tau_auto_snow_min, tau_auto_snow_max,                &
+                          thresh_precip_frac, eps,                             &
+                          gamma_melt, alpha_freez, beta_freez, temp_nowater,   &
+                          iflag_cloudth_vert, iflag_rain_incloud_vol,          &
+                          cld_lc_lsc_snow, cld_lc_con_snow, gamma_freez,       &
+                          rain_fallspeed_clr, rain_fallspeed_cld,              &
+                          snow_fallspeed_clr, snow_fallspeed_cld
+
+
+IMPLICIT NONE
+
+INTEGER, INTENT(IN)                     :: klon           !--number of horizontal grid points [-]
+REAL,    INTENT(IN)                     :: dtime          !--time step [s]
+
+REAL,    INTENT(IN),    DIMENSION(klon) :: paprsdn        !--pressure at the bottom interface of the layer [Pa]
+REAL,    INTENT(IN),    DIMENSION(klon) :: paprsup        !--pressure at the top interface of the layer [Pa]
+REAL,    INTENT(IN),    DIMENSION(klon) :: pplay          !--pressure in the middle of the layer [Pa]
+
+REAL,    INTENT(IN),    DIMENSION(klon) :: ctot_vol       !--volumic cloud fraction [-]
+LOGICAL, INTENT(IN),    DIMENSION(klon) :: ptconv         !--true if we are in a convective point
+
+REAL,    INTENT(INOUT), DIMENSION(klon) :: temp           !--current temperature [K]
+REAL,    INTENT(INOUT), DIMENSION(klon) :: qvap           !--current water vapor specific humidity [kg/kg]
+REAL,    INTENT(INOUT), DIMENSION(klon) :: qliq           !--current liquid water specific humidity [kg/kg]
+REAL,    INTENT(INOUT), DIMENSION(klon) :: qice           !--current ice water specific humidity [kg/kg]
+REAL,    INTENT(IN),    DIMENSION(klon) :: icefrac        !--ice fraction [-]
+REAL,    INTENT(IN),    DIMENSION(klon) :: cldfra         !--cloud fraction [-]
+
+REAL,    INTENT(INOUT), DIMENSION(klon) :: precipfracclr  !--fraction of precipitation in the clear sky IN THE LAYER ABOVE [-]
+REAL,    INTENT(INOUT), DIMENSION(klon) :: precipfraccld  !--fraction of precipitation in the cloudy air IN THE LAYER ABOVE [-]
+                                                          !--NB. at the end of the routine, becomes the fraction of precip
+                                                          !--in the current layer
+
+REAL,    INTENT(INOUT), DIMENSION(klon) :: rain           !--flux of rain gridbox-mean coming from the layer above [kg/s/m2]
+REAL,    INTENT(INOUT), DIMENSION(klon) :: rainclr        !--flux of rain gridbox-mean in clear sky coming from the layer above [kg/s/m2]
+REAL,    INTENT(INOUT), DIMENSION(klon) :: raincld        !--flux of rain gridbox-mean in cloudy air coming from the layer above [kg/s/m2]
+REAL,    INTENT(INOUT), DIMENSION(klon) :: snow           !--flux of snow gridbox-mean coming from the layer above [kg/s/m2]
+REAL,    INTENT(INOUT), DIMENSION(klon) :: snowclr        !--flux of snow gridbox-mean in clear sky coming from the layer above [kg/s/m2]
+REAL,    INTENT(INOUT), DIMENSION(klon) :: snowcld        !--flux of snow gridbox-mean in cloudy air coming from the layer above [kg/s/m2]
+
+REAL,    INTENT(OUT),   DIMENSION(klon) :: qraindiag      !--DIAGNOSTIC specific rain content [kg/kg]
+REAL,    INTENT(OUT),   DIMENSION(klon) :: qsnowdiag      !--DIAGNOSTIC specific snow content [kg/kg]
+REAL,    INTENT(OUT),   DIMENSION(klon) :: dqrcol         !--rain tendendy due to collection by rain of liquid cloud droplets [kg/kg/s]
+REAL,    INTENT(OUT),   DIMENSION(klon) :: dqsagg         !--snow tendency due to collection of lcoud ice by aggregation [kg/kg/s]
+REAL,    INTENT(OUT),   DIMENSION(klon) :: dqrauto        !--rain tendency due to autoconversion of cloud liquid [kg/kg/s]
+REAL,    INTENT(OUT),   DIMENSION(klon) :: dqsauto        !--snow tendency due to autoconversion of cloud ice [kg/kg/s]
+REAL,    INTENT(OUT),   DIMENSION(klon) :: dqsrim         !--snow tendency due to riming [kg/kg/s]
+REAL,    INTENT(OUT),   DIMENSION(klon) :: dqsmelt        !--snow tendency due to melting [kg/kg/s]
+REAL,    INTENT(OUT),   DIMENSION(klon) :: dqrmelt        !--rain tendency due to melting [kg/kg/s]
+REAL,    INTENT(OUT),   DIMENSION(klon) :: dqsfreez       !--snow tendency due to freezing [kg/kg/s]
+REAL,    INTENT(OUT),   DIMENSION(klon) :: dqrfreez       !--rain tendency due to freezing [kg/kg/s]
+
+
+
+!--Local variables
+
+INTEGER :: i
+!--dhum_to_dflux: coef to convert a specific quantity variation to a flux variation
+REAL, DIMENSION(klon) :: dhum_to_dflux
+REAL, DIMENSION(klon) :: qtot                             !--includes vap, liq, ice and precip
+
+!--Partition of the fluxes
+REAL :: dcldfra
+REAL :: precipfractot
+REAL :: dprecipfracclr, dprecipfraccld
+REAL :: drainclr, dsnowclr
+REAL :: draincld, dsnowcld
+
+!--Collection, aggregation and riming
+REAL :: eff_cldfra
+REAL :: coef_col, coef_agg, coef_rim, coef_tmp, qrain_tmp
+REAL :: Eff_rain_liq, Eff_snow_ice, Eff_snow_liq
+REAL :: rho_snow
+REAL :: dqlcol           !--loss of liquid cloud content due to collection by rain [kg/kg/s]
+REAL :: dqiagg           !--loss of ice cloud content due to collection by aggregation [kg/kg/s]
+REAL :: dqlrim           !--loss of liquid cloud content due to riming on snow [kg/kg/s]
+
+!--Autoconversion
+REAL :: qthresh_auto_rain, tau_auto_rain, expo_auto_rain
+REAL :: qthresh_auto_snow, tau_auto_snow, expo_auto_snow
+REAL :: dqlauto          !--loss of liquid cloud content due to autoconversion to rain [kg/kg/s]
+REAL :: dqiauto          !--loss of ice cloud content due to autoconversion to snow [kg/kg/s]
+
+!--Melting
+REAL :: dqsmelt_max, air_thermal_conduct
+REAL :: nb_snowflake_clr, nb_snowflake_cld
+REAL :: capa_snowflake, temp_wetbulb
+REAL :: rho, r_ice
+REAL :: dqsclrmelt, dqscldmelt, dqstotmelt
+REAL, DIMENSION(klon) :: qzero, qsat, dqsat
+
+!--Freezing
+REAL :: dqrfreez_max
+REAL :: tau_freez
+REAL :: dqrclrfreez, dqrcldfreez, dqrtotfreez, dqrtotfreez_step1, dqrtotfreez_step2
+REAL :: coef_freez
+REAL :: dqifreez        !--loss of ice cloud content due to collection of ice from rain [kg/kg/s]
+REAL :: Eff_rain_ice
+
+
+!--Initialisation of variables
+
+
+qzero(:)    = 0.
+
+dqrcol(:)   = 0.
+dqsagg(:)   = 0.
+dqsauto(:)  = 0.
+dqrauto(:)  = 0.
+dqsrim(:)   = 0.
+dqrmelt(:)  = 0.
+dqsmelt(:)  = 0.
+dqrfreez(:) = 0.
+dqsfreez(:) = 0.
+
+
+DO i = 1, klon
+
+  !--Variables initialisation
+  dqlcol  = 0.
+  dqiagg  = 0.
+  dqiauto = 0.
+  dqlauto = 0.
+  dqlrim  = 0.
+
+  !-- dhum_to_dflux = rho * dz/dt = 1 / g * dP/dt
+  dhum_to_dflux(i) = ( paprsdn(i) - paprsup(i) ) / RG / dtime
+  qtot(i) = qvap(i) + qliq(i) + qice(i) &
+          + ( raincld(i) + rainclr(i) + snowcld(i) + snowclr(i) ) / dhum_to_dflux(i)
+
+  !------------------------------------------------------------
+  !--     PRECIPITATION FRACTIONS UPDATE
+  !------------------------------------------------------------
+  !--The goal of this routine is to reattribute precipitation fractions
+  !--and fluxes to clear or cloudy air, depending on the variation of
+  !--the cloud fraction on the vertical dimension. We assume a
+  !--maximum-random overlap of the cloud cover (see Jakob and Klein, 2000,
+  !--and LTP thesis, 2021)
+  !--NB. in fact, we assume a maximum-random overlap of the total precip. frac
+
+  !--Initialisation
+  precipfractot = precipfracclr(i) + precipfraccld(i)
+
+  !--Instead of using the cloud cover which was use in LTP thesis, we use the
+  !--total precip. fraction to compute the maximum-random overlap. This is
+  !--because all the information of the cloud cover is embedded into
+  !--precipfractot, and this allows for taking into account the potential
+  !--reduction of the precipitation fraction because either the flux is too
+  !--small (see barrier at the end of poprecip_postcld) or the flux is completely
+  !--evaporated (see barrier at the end of poprecip_precld)
+  !--NB. precipfraccld(i) is here the cloud fraction of the layer above
+  !precipfractot = 1. - ( 1. - precipfractot ) * &
+  !               ( 1. - MAX( cldfra(i), precipfraccld(i) ) ) &
+  !             / ( 1. - MIN( precipfraccld(i), 1. - eps ) )
+
+
+  IF ( precipfraccld(i) .GT. ( 1. - eps ) ) THEN
+    precipfractot = 1.
+  ELSE
+    precipfractot = 1. - ( 1. - precipfractot ) * &
+                 ( 1. - MAX( cldfra(i), precipfraccld(i) ) ) &
+               / ( 1. - precipfraccld(i) )
+  ENDIF
+
+  !--precipfraccld(i) is here the cloud fraction of the layer above
+  dcldfra = cldfra(i) - precipfraccld(i)
+  !--Tendency of the clear-sky precipitation fraction. We add a MAX on the
+  !--calculation of the current CS precip. frac.
+  !dprecipfracclr = MAX( 0., ( precipfractot - cldfra(i) ) ) - precipfracclr(i)
+  !--We remove it, because precipfractot is guaranteed to be > cldfra (the MAX is activated
+  !--if precipfractot < cldfra)
+  dprecipfracclr = ( precipfractot - cldfra(i) ) - precipfracclr(i)
+  !--Tendency of the cloudy precipitation fraction. We add a MAX on the
+  !--calculation of the current CS precip. frac.
+  !dprecipfraccld = MAX( dcldfra , - precipfraccld(i) ) 
+  !--We remove it, because cldfra is guaranteed to be > 0 (the MAX is activated
+  !--if cldfra < 0)
+  dprecipfraccld = dcldfra
+
+
+  !--If the cloud extends
+  IF ( dprecipfraccld .GT. 0. ) THEN
+    !--If there is no CS precip, nothing happens.
+    !--If there is, we reattribute some of the CS precip flux
+    !--to the cloud precip flux, proportionnally to the
+    !--decrease of the CS precip fraction
+    IF ( precipfracclr(i) .LE. 0. ) THEN
+      drainclr = 0.
+      dsnowclr = 0.
+    ELSE
+      drainclr = dprecipfracclr / precipfracclr(i) * rainclr(i) 
+      dsnowclr = dprecipfracclr / precipfracclr(i) * snowclr(i) 
+    ENDIF
+  !--If the cloud narrows
+  ELSEIF ( dprecipfraccld .LT. 0. ) THEN
+    !--We reattribute some of the cloudy precip flux
+    !--to the CS precip flux, proportionnally to the
+    !--decrease of the cloud precip fraction
+    draincld = dprecipfraccld / precipfraccld(i) * raincld(i) 
+    dsnowcld = dprecipfraccld / precipfraccld(i) * snowcld(i) 
+    drainclr = - draincld
+    dsnowclr = - dsnowcld
+  !--If the cloud stays the same or if there is no cloud above and
+  !--in the current layer, nothing happens
+  ELSE
+    drainclr = 0.
+    dsnowclr = 0.
+  ENDIF
+
+  !--We add the tendencies
+  !--The MAX is needed because in some cases, the flux can be slightly negative (numerical precision)
+  precipfraccld(i) = precipfraccld(i) + dprecipfraccld
+  precipfracclr(i) = precipfracclr(i) + dprecipfracclr
+  rainclr(i) = MAX(0., rainclr(i) + drainclr)
+  snowclr(i) = MAX(0., snowclr(i) + dsnowclr)
+  raincld(i) = MAX(0., raincld(i) - drainclr)
+  snowcld(i) = MAX(0., snowcld(i) - dsnowclr)
+  
+  !--If vertical heterogeneity is taken into account, we use
+  !--the "true" volume fraction instead of a modified 
+  !--surface fraction (which is larger and artificially
+  !--reduces the in-cloud water).
+  IF ( ( iflag_cloudth_vert .GE. 3 ) .AND. ( iflag_rain_incloud_vol .EQ. 1 ) ) THEN
+    eff_cldfra = ctot_vol(i)
+  ELSE
+    eff_cldfra = cldfra(i)
+  ENDIF 
+
+
+  !--Start precipitation growth processes
+
+  !--If the cloud is big enough, the precipitation processes activate
+  ! TODO met on seuil_neb ici ?
+  IF ( cldfra(i) .GE. seuil_neb ) THEN
+
+    !---------------------------------------------------------
+    !--           COLLECTION AND AGGREGATION
+    !---------------------------------------------------------
+    !--Collection: processus through which rain collects small liquid droplets
+    !--in suspension, and add it to the rain flux
+    !--Aggregation: same for snow (precip flux) and ice crystals (in suspension)
+    !--Those processes are treated before autoconversion because we do not
+    !--want to collect/aggregate the newly formed fluxes, which already
+    !--"saw" the cloud as they come from it
+    !--The formulas come from Muench and Lohmann 2020
+
+    !--gamma_col: tuning coefficient [-]
+    !--rho_rain: volumic mass of rain [kg/m3]
+    !--r_rain: size of the rain droplets [m]
+    !--Eff_rain_liq: efficiency of the collection process [-] (between 0 and 1)
+    !--dqlcol is a gridbox-mean quantity, as is qliq and raincld. They are
+    !--divided by respectively eff_cldfra, eff_cldfra and precipfraccld to
+    !--get in-cloud mean quantities. The two divisions by eff_cldfra are
+    !--then simplified.
+
+    !--The collection efficiency is perfect.
+    Eff_rain_liq = 1.
+    coef_col = gamma_col * 3. / 4. / rho_rain / r_rain * Eff_rain_liq
+    IF ( raincld(i) .GT. 0. ) THEN
+      !--Exact explicit version, which does not need a barrier because of
+      !--the exponential decrease
+      dqlcol = qliq(i) * ( EXP( - dtime * coef_col * raincld(i) / precipfraccld(i) ) - 1. )
+
+      !--Add tendencies
+      qliq(i) = qliq(i) + dqlcol
+      raincld(i) = raincld(i) - dqlcol * dhum_to_dflux(i)
+
+      !--Diagnostic tendencies
+      dqrcol(i)  = - dqlcol  / dtime
+    ENDIF
+
+    !--Same as for aggregation
+    !--Eff_snow_liq formula:
+    !--it s a product of a collection efficiency and a sticking efficiency
+    ! Milbrandt and Yau formula that gives very low values:
+    ! Eff_snow_ice = 0.05 * EXP( 0.1 * ( temp(i) - RTT ) )
+    ! Lin 1983's formula 
+    Eff_snow_ice = EXP( 0.025 * MIN( ( temp(i) - RTT ), 0.) ) 
+    !--rho_snow formula follows Brandes et al. 2007 (JAMC)
+    rho_snow = 1.e3 * 0.178 * ( r_snow * 2. * 1000. )**(-0.922)
+    coef_agg = gamma_agg * 3. / 4. / rho_snow / r_snow * Eff_snow_ice
+    IF ( snowcld(i) .GT. 0. ) THEN
+      !--Exact explicit version, which does not need a barrier because of
+      !--the exponential decrease
+      dqiagg = qice(i) * ( EXP( - dtime * coef_agg * snowcld(i) / precipfraccld(i) ) - 1. )
+
+      !--Add tendencies
+      qice(i) = qice(i) + dqiagg
+      snowcld(i) = snowcld(i) - dqiagg * dhum_to_dflux(i)
+
+      !--Diagnostic tendencies
+      dqsagg(i)  = - dqiagg  / dtime
+    ENDIF
+
+
+    !---------------------------------------------------------
+    !--                  AUTOCONVERSION
+    !---------------------------------------------------------
+    !--Autoconversion converts liquid droplets/ice crystals into
+    !--rain drops/snowflakes. It relies on the formulations by
+    !--Sundqvist 1978.
+
+    !--If we are in a convective point, we have different parameters
+    !--for the autoconversion
+    IF ( ptconv(i) ) THEN
+        qthresh_auto_rain = cld_lc_con
+        qthresh_auto_snow = cld_lc_con_snow
+
+        tau_auto_rain = cld_tau_con
+        !--tau for snow depends on the ice fraction in mixed-phase clouds     
+        tau_auto_snow = tau_auto_snow_max &
+                      + ( tau_auto_snow_min - tau_auto_snow_max ) * ( 1. - icefrac(i) )
+
+        expo_auto_rain = cld_expo_con
+        expo_auto_snow = cld_expo_con
+    ELSE
+        qthresh_auto_rain = cld_lc_lsc
+        qthresh_auto_snow = cld_lc_lsc_snow
+
+        tau_auto_rain = cld_tau_lsc
+        !--tau for snow depends on the ice fraction in mixed-phase clouds     
+        tau_auto_snow = tau_auto_snow_max &
+                      + ( tau_auto_snow_min - tau_auto_snow_max ) * ( 1. - icefrac(i) )
+
+        expo_auto_rain = cld_expo_lsc
+        expo_auto_snow = cld_expo_lsc
+    ENDIF
+
+
+    ! Liquid water quantity to remove according to (Sundqvist, 1978)
+    ! dqliq/dt = -qliq/tau * ( 1-exp(-(qliqincld/qthresh)**2) )
+    !
+    !--And same formula for ice
+    !
+    !--We first treat the second term (with exponential) in an explicit way
+    !--and then treat the first term (-q/tau) in an exact way
+
+    dqlauto = - qliq(i) * ( 1. - exp( - dtime / tau_auto_rain * ( 1. - exp( &
+               - ( qliq(i) / eff_cldfra / qthresh_auto_rain ) ** expo_auto_rain ) ) ) )
+
+    dqiauto = - qice(i) * ( 1. - exp( - dtime / tau_auto_snow * ( 1. - exp( &
+               - ( qice(i) / eff_cldfra / qthresh_auto_snow ) ** expo_auto_snow ) ) ) )
+
+
+    !--Barriers so that we don't create more rain/snow
+    !--than there is liquid/ice
+    dqlauto = MAX( - qliq(i), dqlauto )
+    dqiauto = MAX( - qice(i), dqiauto )
+
+    !--Add tendencies
+    qliq(i) = qliq(i) + dqlauto
+    qice(i) = qice(i) + dqiauto
+    raincld(i) = raincld(i) - dqlauto * dhum_to_dflux(i)
+    snowcld(i) = snowcld(i) - dqiauto * dhum_to_dflux(i)
+
+    !--Diagnostic tendencies
+    dqsauto(i) = - dqiauto / dtime
+    dqrauto(i) = - dqlauto / dtime
+
+
+    !---------------------------------------------------------
+    !--                  RIMING
+    !---------------------------------------------------------
+    !--Process which converts liquid droplets in suspension into
+    !--snow because of the collision between
+    !--those and falling snowflakes.
+    !--The formula comes from Muench and Lohmann 2020
+    !--NB.: this process needs a temperature adjustment
+
+    !--Eff_snow_liq formula: following Ferrier 1994,
+    !--assuming 1
+    Eff_snow_liq = 1.0
+    !--rho_snow formula follows Brandes et al. 2007 (JAMC)
+    rho_snow = 1.e3 * 0.178 * ( r_snow * 2. * 1000. )**(-0.922)
+    coef_rim = gamma_rim * 3. / 4. / rho_snow / r_snow * Eff_snow_liq
+    IF ( snowcld(i) .GT. 0. ) THEN
+      !--Exact version, which does not need a barrier because of
+      !--the exponential decrease
+      dqlrim = qliq(i) * ( EXP( - dtime * coef_rim * snowcld(i) / precipfraccld(i) ) - 1. )
+
+      !--Add tendencies
+      !--The MAX is needed because in some cases, the flux can be slightly negative (numerical precision)
+      qliq(i) = qliq(i) + dqlrim
+      snowcld(i) = snowcld(i) - dqlrim * dhum_to_dflux(i)
+
+      !--Temperature adjustment with the release of latent
+      !--heat because of solid condensation
+      temp(i) = temp(i) - dqlrim * RLMLT / RCPD &
+                        / ( 1. + RVTMP2 * qtot(i) )
+
+      !--Diagnostic tendencies
+      dqsrim(i)  = - dqlrim  / dtime
+    ENDIF
+
+  ENDIF ! cldfra .GE. seuil_neb
+
+ENDDO ! loop on klon
+
+
+!--Re-calculation of saturation specific humidity
+!--because riming changed temperature
+CALL calc_qsat_ecmwf(klon, temp, qzero, pplay, RTT, 0, .FALSE., qsat, dqsat)
+
+DO i = 1, klon
+
+  !---------------------------------------------------------
+  !--                  MELTING
+  !---------------------------------------------------------
+  !--Process through which snow melts into rain. 
+  !--The formula is homemade.
+  !--NB.: this process needs a temperature adjustment
+
+  !--dqsmelt_max         : maximum snow melting so that temperature
+  !--                      stays higher than 273 K [kg/kg]
+  !--capa_snowflake      : capacitance of a snowflake, equal to
+  !--                      the radius if the snowflake is a sphere [m]
+  !--temp_wetbulb        : wet-bulb temperature [K]
+  !--snow_fallspeed      : snow fall velocity (in clear/cloudy sky) [m/s]
+  !--air_thermal_conduct : thermal conductivity of the air [J/m/K/s]
+  !--gamma_melt          : tuning parameter for melting [-]
+  !--nb_snowflake        : number of snowflakes (in clear/cloudy air) [-]
+
+  IF ( ( snowclr(i) + snowcld(i) ) .GT. 0. ) THEN
+    !--Computed according to
+    !--Cpdry * Delta T * (1 + (Cpvap/Cpdry - 1) * qtot) = Lfusion * Delta q
+    dqsmelt_max = MIN(0., ( RTT - temp(i) ) / RLMLT * RCPD &
+                        * ( 1. + RVTMP2 * qtot(i) ))
+   
+    !--Initialisation 
+    dqsclrmelt = 0.
+    dqscldmelt = 0.
+
+    !--We assume that the snowflakes are spherical
+    capa_snowflake = r_snow
+    !--Thermal conductivity of the air, empirical formula from Beard and Pruppacher (1971)
+    air_thermal_conduct = ( 5.69 + 0.017 * ( temp(i) - RTT ) ) * 1.e-3 * 4.184    
+    !--rho_snow formula follows Brandes et al. 2007 (JAMC)
+    rho_snow = 1.e3 * 0.178 * ( r_snow * 2. * 1000. )**(-0.922)
+
+    !--In clear air
+    IF ( ( snowclr(i) .GT. 0. ) .AND.  ( precipfracclr(i) .GT. 0. ) ) THEN
+      !--Formula for the wet-bulb temperature from ECMWF (IFS)
+      !--The vapor used is the vapor in the clear sky
+      temp_wetbulb = temp(i) &
+                   - ( qsat(i) - ( qvap(i) - cldfra(i) * qsat(i) ) / ( 1. - cldfra(i) ) ) &
+                   * ( 1329.31 + 0.0074615 * ( pplay(i) - 0.85e5 ) &
+                   - 40.637 * ( temp(i) - 275. ) )
+      !--Calculated according to
+      !-- flux = velocity_snowflakes * nb_snowflakes * volume_snowflakes * rho_snow
+      nb_snowflake_clr = snowclr(i) / precipfracclr(i) / snow_fallspeed_clr &
+                       / ( 4. / 3. * RPI * r_snow**3. * rho_snow )
+      dqsclrmelt = - nb_snowflake_clr * 4. * RPI * air_thermal_conduct &
+                   * capa_snowflake / RLMLT * gamma_melt &
+                   * MAX(0., temp_wetbulb - RTT) * dtime
+      
+      !--Barrier to limit the melting flux to the clr snow flux in the mesh
+      dqsclrmelt = MAX( dqsclrmelt , -snowclr(i) / dhum_to_dflux(i))
+    ENDIF
+
+
+    !--In cloudy air
+    IF ( ( snowcld(i) .GT. 0. ) .AND. ( precipfraccld(i) .GT. 0. ) ) THEN
+      !--As the air is saturated, the wet-bulb temperature is equal to the
+      !--temperature
+      temp_wetbulb = temp(i)
+      !--Calculated according to
+      !-- flux = velocity_snowflakes * nb_snowflakes * volume_snowflakes * rho_snow
+      nb_snowflake_cld = snowcld(i) / precipfraccld(i) / snow_fallspeed_cld &
+                       / ( 4. / 3. * RPI * r_snow**3. * rho_snow )
+      dqscldmelt = - nb_snowflake_cld * 4. * RPI * air_thermal_conduct &
+                   * capa_snowflake / RLMLT * gamma_melt &
+                   * MAX(0., temp_wetbulb - RTT) * dtime
+
+      !--Barrier to limit the melting flux to the cld snow flux in the mesh
+      dqscldmelt = MAX(dqscldmelt , - snowcld(i) / dhum_to_dflux(i))
+   ENDIF
+    
+
+    !--Barrier on temperature. If the total melting flux leads to a
+    !--positive temperature, it is limited to keep temperature above 0 degC.
+    !--It is activated if the total is LOWER than the max
+    !--because everything is negative
+    dqstotmelt = dqsclrmelt + dqscldmelt
+    IF ( dqstotmelt .LT. dqsmelt_max ) THEN
+      !--We redistribute the max melted snow keeping
+      !--the clear/cloud partition of the melted snow
+      dqsclrmelt = dqsmelt_max * dqsclrmelt / dqstotmelt
+      dqscldmelt = dqsmelt_max * dqscldmelt / dqstotmelt
+      dqstotmelt = dqsmelt_max
+
+    ENDIF
+
+    !--Add tendencies
+    !--The MAX is needed because in some cases, the flux can be slightly negative (numerical precision)
+    rainclr(i) = MAX(0., rainclr(i) - dqsclrmelt * dhum_to_dflux(i))
+    raincld(i) = MAX(0., raincld(i) - dqscldmelt * dhum_to_dflux(i))
+    snowclr(i) = MAX(0., snowclr(i) + dqsclrmelt * dhum_to_dflux(i))
+    snowcld(i) = MAX(0., snowcld(i) + dqscldmelt * dhum_to_dflux(i))
+
+    !--Temperature adjustment with the release of latent
+    !--heat because of melting
+    temp(i) = temp(i) + dqstotmelt * RLMLT / RCPD &
+                      / ( 1. + RVTMP2 * qtot(i) )
+
+    !--Diagnostic tendencies
+    dqrmelt(i) = - dqstotmelt / dtime
+    dqsmelt(i) = dqstotmelt / dtime
+
+  ENDIF
+
+
+  !---------------------------------------------------------
+  !--                  FREEZING
+  !---------------------------------------------------------
+  !--Process through which rain freezes into snow. 
+  !-- We parameterize it as a 2 step process:
+  !--first: freezing following collision with ice crystals
+  !--second: immersion freezing following (inspired by Bigg 1953)
+  !--the latter is parameterized as an exponential decrease of the rain
+  !--water content with a homemade formulya
+  !--This is based on a caracteritic time of freezing, which
+  !--exponentially depends on temperature so that it is
+  !--equal to 1 for temp_nowater (see below) and is close to
+  !--0 for RTT (=273.15 K).
+  !--NB.: this process needs a temperature adjustment
+  !--dqrfreez_max : maximum rain freezing so that temperature
+  !--              stays lower than 273 K [kg/kg]
+  !--tau_freez    : caracteristic time of freezing [s]
+  !--gamma_freez  : tuning parameter [s-1]
+  !--alpha_freez  : tuning parameter for the shape of the exponential curve [-]
+  !--temp_nowater : temperature below which no liquid water exists [K] (about -40 degC)
+
+  IF ( ( rainclr(i) + raincld(i) ) .GT. 0. ) THEN
+
+ 
+    !--1st step: freezing following collision with ice crystals
+    !--Sub-process of freezing which quantifies the collision between
+    !--ice crystals in suspension and falling rain droplets.
+    !--The rain droplets freeze, becoming graupel, and carrying
+    !--the ice crystal (which acted as an ice nucleating particle).
+    !--The formula is adapted from the riming formula.
+    !--it works only in the cloudy part
+
+    dqifreez = 0.
+    dqrtotfreez_step1 = 0.
+
+    IF ( ( qice(i) .GT. 0. ) .AND. ( cldfra(i) .GT. 0. ) .AND. &
+         ( raincld(i) .GT. 0. ) .AND. ( precipfraccld(i) .GT. 0. ) ) THEN
+      dqrclrfreez = 0.
+      dqrcldfreez = 0.
+
+      !--Computed according to
+      !--Cpdry * Delta T * (1 + (Cpvap/Cpdry - 1) * qtot) = Lfusion * Delta q
+      dqrfreez_max = MIN(0., ( temp(i) - RTT ) / RLMLT * RCPD &
+                         * ( 1. + RVTMP2 * qtot(i) ))
+ 
+
+      !--The collision efficiency is assumed unity 
+      Eff_rain_ice = 1.
+      coef_freez = gamma_freez * 3. / 4. / rho_rain / r_rain * Eff_rain_ice
+      !--Exact version, which does not need a barrier because of
+      !--the exponential decrease.
+      dqifreez = qice(i) * ( EXP( - dtime * coef_freez * raincld(i) / precipfraccld(i) ) - 1. )
+
+      !--We add the part of rain water that freezes, limited by a temperature barrier
+      !--This quantity is calculated assuming that the number of drop that freeze correspond to the number
+      !--of crystals collected (and assuming uniform distributions of ice crystals and rain drops)
+      !--The ice specific humidity that collide with rain is dqi = dNi 4/3 PI rho_ice r_ice**3
+      !--The rain that collide with ice is, similarly, dqr = dNr 4/3 PI rho_rain r_rain**3
+      !--The assumption above corresponds to dNi = dNr, i.e.,
+      !-- dqr = dqi * (4/3 PI rho_rain * r_rain**3) / (4/3 PI rho_ice * r_ice**3)
+      !--Dry density [kg/m3]
+      rho = pplay(i) / temp(i) / RD
+      !--r_ice formula from Sun and Rikus (1999)
+      r_ice = 1.e-6 * ( 45.8966 * ( qice(i) / cldfra(i) * rho * 1e3 )**0.2214 &
+            + 0.7957 * ( qice(i) / cldfra(i) * rho * 1e3 )**0.2535 * ( temp(i) - RTT + 190. ) ) / 2.
+      dqrcldfreez = dqifreez * rho_rain * r_rain**3. / ( rho_ice * r_ice**3. )
+      dqrcldfreez = MAX(dqrcldfreez, - raincld(i) / dhum_to_dflux(i))
+      dqrcldfreez = MAX(dqrcldfreez, dqrfreez_max) 
+      dqrtotfreez_step1 = dqrcldfreez
+
+      !--Add tendencies
+      !--The MAX is needed because in some cases, the flux can be slightly negative (numerical precision)
+      qice(i) = qice(i) + dqifreez
+      raincld(i) = MAX(0., raincld(i) + dqrcldfreez * dhum_to_dflux(i))
+      snowcld(i) = MAX(0., snowcld(i) - dqrcldfreez * dhum_to_dflux(i) - dqifreez * dhum_to_dflux(i))
+      temp(i) = temp(i) - dqrtotfreez_step1 * RLMLT / RCPD &
+                        / ( 1. + RVTMP2 * qtot(i) )
+
+    ENDIF
+    
+    !-- Second step immersion freezing of rain drops
+    !-- with a homemade timeconstant depending on temperature
+
+    dqrclrfreez = 0.
+    dqrcldfreez = 0.
+    dqrtotfreez_step2 = 0.
+    !--Computed according to
+    !--Cpdry * Delta T * (1 + (Cpvap/Cpdry - 1) * qtot) = Lfusion * Delta q
+
+    dqrfreez_max = MIN(0., ( temp(i) - RTT ) / RLMLT * RCPD &
+                         * ( 1. + RVTMP2 * qtot(i) ))
+
+    
+    tau_freez = 1. / ( beta_freez &
+              * EXP( - alpha_freez * ( temp(i) - temp_nowater ) / ( RTT - temp_nowater ) ) )
+
+
+    !--In clear air
+    IF ( rainclr(i) .GT. 0. ) THEN
+      !--Exact solution of dqrain/dt = -qrain/tau_freez
+      dqrclrfreez = rainclr(i) / dhum_to_dflux(i) * ( EXP( - dtime / tau_freez ) - 1. )
+    ENDIF
+
+    !--In cloudy air
+    IF ( raincld(i) .GT. 0. ) THEN
+      !--Exact solution of dqrain/dt = -qrain/tau_freez
+      dqrcldfreez = raincld(i) / dhum_to_dflux(i) * ( EXP( - dtime / tau_freez ) - 1. )
+    ENDIF
+
+    !--temperature barrier step 2
+    !--It is activated if the total is LOWER than the max
+    !--because everything is negative
+    dqrtotfreez_step2 = dqrclrfreez + dqrcldfreez
+  
+    IF ( dqrtotfreez_step2 .LT. dqrfreez_max ) THEN
+      !--We redistribute the max freezed rain keeping
+      !--the clear/cloud partition of the freezing rain
+      dqrclrfreez = dqrfreez_max * dqrclrfreez / dqrtotfreez_step2
+      dqrcldfreez = dqrfreez_max * dqrcldfreez / dqrtotfreez_step2
+      dqrtotfreez_step2 = dqrfreez_max
+    ENDIF
+
+
+    !--Add tendencies
+    !--The MAX is needed because in some cases, the flux can be slightly negative (numerical precision)
+    rainclr(i) = MAX(0., rainclr(i) + dqrclrfreez * dhum_to_dflux(i))
+    raincld(i) = MAX(0., raincld(i) + dqrcldfreez * dhum_to_dflux(i))
+    snowclr(i) = MAX(0., snowclr(i) - dqrclrfreez * dhum_to_dflux(i))
+    snowcld(i) = MAX(0., snowcld(i) - dqrcldfreez * dhum_to_dflux(i))
+
+
+    !--Temperature adjustment with the uptake of latent
+    !--heat because of freezing
+    temp(i) = temp(i) - dqrtotfreez_step2 * RLMLT / RCPD &
+                      / ( 1. + RVTMP2 * qtot(i) )
+
+    !--Diagnostic tendencies
+    dqrtotfreez = dqrtotfreez_step1 + dqrtotfreez_step2          
+    dqrfreez(i) = dqrtotfreez / dtime
+    dqsfreez(i) = -(dqrtotfreez + dqifreez) / dtime
+
+  ENDIF
+
+
+
+  !--If the local flux of rain+snow in clear/cloudy air is lower than rain_int_min,
+  !--we reduce the precipiration fraction in the clear/cloudy air so that the new
+  !--local flux of rain+snow is equal to rain_int_min.
+  !--Here, rain+snow is the gridbox-mean flux of precip.
+  !--Therefore, (rain+snow)/precipfrac is the local flux of precip.
+  !--If the local flux of precip is lower than rain_int_min, i.e.,
+  !-- (rain+snow)/precipfrac < rain_int_min , i.e., 
+  !-- (rain+snow)/rain_int_min < precipfrac , then we want to reduce
+  !--the precip fraction to the equality, i.e., precipfrac = (rain+snow)/rain_int_min.
+  !--Note that this is physically different than what is proposed in LTP thesis.
+  precipfracclr(i) = MIN( precipfracclr(i), ( rainclr(i) + snowclr(i) ) / rain_int_min )
+  precipfraccld(i) = MIN( precipfraccld(i), ( raincld(i) + snowcld(i) ) / rain_int_min )
+
+  !--Calculate outputs
+  rain(i) = rainclr(i) + raincld(i)
+  snow(i) = snowclr(i) + snowcld(i)
+
+  !--Diagnostics
+  !--BEWARE this is indeed a diagnostic: this is an estimation from
+  !--the value of the flux at the bottom interface of the mesh and
+  !--and assuming an upstream numerical calculation
+  !--If ok_radocond_snow is TRUE, then the diagnostic qsnowdiag is
+  !--used for computing the total ice water content in the mesh
+  !--for radiation only
+  qraindiag(i) = ( rainclr(i) / ( pplay(i) / RD / temp(i) ) / rain_fallspeed_clr &
+                 + raincld(i) / ( pplay(i) / RD / temp(i) ) / rain_fallspeed_cld )
+  qsnowdiag(i) = ( snowclr(i) / ( pplay(i) / RD / temp(i) ) / snow_fallspeed_clr &
+                 + snowcld(i) / ( pplay(i) / RD / temp(i) ) / snow_fallspeed_cld )
+
+
+ENDDO ! loop on klon
+
+
+END SUBROUTINE poprecip_postcld
+
+END MODULE lmdz_lscp_poprecip
Index: DZ6/trunk/libf/phylmd/lmdz_lscp_tools.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/lmdz_lscp_tools.F90	(revision 5267)
+++ 	(revision )
@@ -1,936 +1,0 @@
-MODULE lmdz_lscp_tools
-
-    IMPLICIT NONE
-
-CONTAINS
-
-!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-SUBROUTINE FALLICE_VELOCITY(klon,iwc,temp,rho,pres,ptconv,velo)
-
-    ! Ref:
-    ! Stubenrauch, C. J., Bonazzola, M.,
-    ! Protopapadaki, S. E., & Musat, I. (2019).
-    ! New cloud system metrics to assess bulk
-    ! ice cloud schemes in a GCM. Journal of
-    ! Advances in Modeling Earth Systems, 11,
-    ! 3212–3234. https://doi.org/10.1029/2019MS001642
-    
-    use lmdz_lscp_ini, only: iflag_vice, ffallv_con, ffallv_lsc
-    use lmdz_lscp_ini, only: cice_velo, dice_velo 
-
-    IMPLICIT NONE
-
-    INTEGER, INTENT(IN) :: klon
-    REAL, INTENT(IN), DIMENSION(klon) :: iwc       ! specific ice water content [kg/m3]
-    REAL, INTENT(IN), DIMENSION(klon) :: temp      ! temperature [K]
-    REAL, INTENT(IN), DIMENSION(klon) :: rho       ! dry air density [kg/m3]
-    REAL, INTENT(IN), DIMENSION(klon) :: pres      ! air pressure [Pa]
-    LOGICAL, INTENT(IN), DIMENSION(klon) :: ptconv    ! convective point  [-]
-
-    REAL, INTENT(OUT), DIMENSION(klon) :: velo    ! fallspeed velocity of crystals [m/s]
-
-
-    INTEGER i
-    REAL logvm,iwcg,tempc,phpa,fallv_tun
-    REAL m2ice, m2snow, vmice, vmsnow
-    REAL aice, bice, asnow, bsnow
-    
-
-    DO i=1,klon
-
-        IF (ptconv(i)) THEN
-            fallv_tun=ffallv_con
-        ELSE
-            fallv_tun=ffallv_lsc
-        ENDIF
-
-        tempc=temp(i)-273.15 ! celcius temp
-        iwcg=MAX(iwc(i)*1000.,1E-3) ! iwc in g/m3. We set a minimum value to prevent from division by 0
-        phpa=pres(i)/100.    ! pressure in hPa
-
-    IF (iflag_vice .EQ. 1) THEN
-        ! so-called 'empirical parameterization' in Stubenrauch et al. 2019
-        if (tempc .GE. -60.0) then
-
-            logvm= -0.0000414122*tempc*tempc*log(iwcg)-0.00538922*tempc*log(iwcg) &
-                    -0.0516344*log(iwcg)+0.00216078*tempc + 1.9714    
-            velo(i)=exp(logvm)
-        else
-            velo(i)=65.0*(iwcg**0.2)*(150./phpa)**0.15
-        endif
-        
-        velo(i)=fallv_tun*velo(i)/100.0 ! from cm/s to m/s
-
-    ELSE IF (iflag_vice .EQ. 2) THEN
-        ! so called  PSDM empirical coherent bulk ice scheme in Stubenrauch et al. 2019
-        aice=0.587
-        bice=2.45
-        asnow=0.0444
-        bsnow=2.1
-        
-        m2ice=((iwcg*0.001/aice)/(exp(13.6-bice*7.76+0.479*bice**2)* & 
-                exp((-0.0361+bice*0.0151+0.00149*bice**2)*tempc)))   &
-                **(1./(0.807+bice*0.00581+0.0457*bice**2))
-
-        vmice=100.*1042.4*exp(13.6-(bice+1)*7.76+0.479*(bice+1.)**2)*exp((-0.0361+ &
-                 (bice+1.)*0.0151+0.00149*(bice+1.)**2)*tempc) &
-                 *(m2ice**(0.807+(bice+1.)*0.00581+0.0457*(bice+1.)**2))/(iwcg*0.001/aice)
-
-       
-        vmice=vmice*((1000./phpa)**0.2)
-      
-        m2snow=((iwcg*0.001/asnow)/(exp(13.6-bsnow*7.76+0.479*bsnow**2)* &
-               exp((-0.0361+bsnow*0.0151+0.00149*bsnow**2)*tempc)))         &
-               **(1./(0.807+bsnow*0.00581+0.0457*bsnow**2))
-
-
-        vmsnow=100.*14.3*exp(13.6-(bsnow+.416)*7.76+0.479*(bsnow+.416)**2)&
-                  *exp((-0.0361+(bsnow+.416)*0.0151+0.00149*(bsnow+.416)**2)*tempc)&
-                  *(m2snow**(0.807+(bsnow+.416)*0.00581+0.0457*(bsnow+.416)**2))/(iwcg*0.001/asnow)
-
-        vmsnow=vmsnow*((1000./phpa)**0.35)
-        velo(i)=fallv_tun*min(vmsnow,vmice)/100. ! to m/s
-
-    ELSE
-        ! By default, fallspeed velocity of ice crystals according to Heymsfield & Donner 1990
-        velo(i) = fallv_tun*cice_velo*((iwcg/1000.)**dice_velo)
-    ENDIF
-    ENDDO
-
-END SUBROUTINE FALLICE_VELOCITY
-!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-
-!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-SUBROUTINE ICEFRAC_LSCP(klon, temp, iflag_ice_thermo, distcltop, temp_cltop, icefrac, dicefracdT)
-!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-  
-  ! Compute the ice fraction 1-xliq (see e.g.
-  ! Doutriaux-Boucher & Quaas 2004, section 2.2.)
-  ! as a function of temperature
-  ! see also Fig 3 of Madeleine et al. 2020, JAMES
-!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-
-
-    USE print_control_mod, ONLY: lunout, prt_level
-    USE lmdz_lscp_ini, ONLY: t_glace_min, t_glace_max, exposant_glace, iflag_t_glace
-    USE lmdz_lscp_ini, ONLY : RTT, dist_liq, temp_nowater
-
-    IMPLICIT NONE
-
-
-    INTEGER, INTENT(IN)                 :: klon              ! number of horizontal grid points
-    REAL, INTENT(IN), DIMENSION(klon)   :: temp              ! temperature
-    REAL, INTENT(IN), DIMENSION(klon)   :: distcltop         ! distance to cloud top
-    REAL, INTENT(IN), DIMENSION(klon)   :: temp_cltop        ! temperature of cloud top
-    INTEGER, INTENT(IN)                 :: iflag_ice_thermo
-    REAL, INTENT(OUT), DIMENSION(klon)  :: icefrac
-    REAL, INTENT(OUT), DIMENSION(klon)  :: dicefracdT
-
-
-    INTEGER i
-    REAL    liqfrac_tmp, dicefrac_tmp
-    REAL    Dv, denomdep,beta,qsi,dqsidt
-    LOGICAL ice_thermo
-
-    CHARACTER (len = 20) :: modname = 'lscp_tools'
-    CHARACTER (len = 80) :: abort_message
-
-    IF ((iflag_t_glace.LT.2)) THEN !.OR. (iflag_t_glace.GT.6)) THEN
-       abort_message = 'lscp cannot be used if iflag_t_glace<2 or >6'
-       CALL abort_physic(modname,abort_message,1)
-    ENDIF
-
-    IF (.NOT.((iflag_ice_thermo .EQ. 1).OR.(iflag_ice_thermo .GE. 3))) THEN
-       abort_message = 'lscp cannot be used without ice thermodynamics'
-       CALL abort_physic(modname,abort_message,1)
-    ENDIF
-
-
-    DO i=1,klon
- 
-        ! old function with sole dependence upon temperature
-        IF (iflag_t_glace .EQ. 2) THEN
-            liqfrac_tmp = (temp(i)-t_glace_min) / (t_glace_max-t_glace_min)
-            liqfrac_tmp = MIN(MAX(liqfrac_tmp,0.0),1.0)
-            icefrac(i) = (1.0-liqfrac_tmp)**exposant_glace
-            IF (icefrac(i) .GT.0.) THEN
-                 dicefracdT(i)= exposant_glace * (icefrac(i)**(exposant_glace-1.)) &
-                           / (t_glace_min - t_glace_max)
-            ENDIF
-
-            IF ((icefrac(i).EQ.0).OR.(icefrac(i).EQ.1)) THEN
-                 dicefracdT(i)=0.
-            ENDIF
-
-        ENDIF
-
-        ! function of temperature used in CMIP6 physics
-        IF (iflag_t_glace .EQ. 3) THEN
-            liqfrac_tmp = (temp(i)-t_glace_min) / (t_glace_max-t_glace_min)
-            liqfrac_tmp = MIN(MAX(liqfrac_tmp,0.0),1.0)
-            icefrac(i) = 1.0-liqfrac_tmp**exposant_glace
-            IF ((icefrac(i) .GT.0.) .AND. (liqfrac_tmp .GT. 0.)) THEN
-                dicefracdT(i)= exposant_glace * ((liqfrac_tmp)**(exposant_glace-1.)) &
-                          / (t_glace_min - t_glace_max)
-            ELSE
-                dicefracdT(i)=0.
-            ENDIF
-        ENDIF
-
-        ! for iflag_t_glace .GE. 4, the liquid fraction depends upon temperature at cloud top
-        ! and then decreases with decreasing height 
-
-        !with linear function of temperature at cloud top
-        IF (iflag_t_glace .EQ. 4) THEN  
-                liqfrac_tmp = (temp(i)-t_glace_min) / (t_glace_max-t_glace_min)
-                liqfrac_tmp = MIN(MAX(liqfrac_tmp,0.0),1.0)
-                icefrac(i)    =  MAX(MIN(1.,1.0 - liqfrac_tmp*exp(-distcltop(i)/dist_liq)),0.)
-                dicefrac_tmp = - temp(i)/(t_glace_max-t_glace_min)
-                dicefracdT(i) = dicefrac_tmp*exp(-distcltop(i)/dist_liq)
-                IF ((liqfrac_tmp .LE.0) .OR. (liqfrac_tmp .GE. 1)) THEN
-                        dicefracdT(i) = 0.
-                ENDIF
-        ENDIF
-
-        ! with CMIP6 function of temperature at cloud top
-        IF ((iflag_t_glace .EQ. 5) .OR. (iflag_t_glace .EQ. 7)) THEN 
-                liqfrac_tmp = (temp(i)-t_glace_min) / (t_glace_max-t_glace_min)
-                liqfrac_tmp =  MIN(MAX(liqfrac_tmp,0.0),1.0)
-                liqfrac_tmp = liqfrac_tmp**exposant_glace
-                icefrac(i)  =  MAX(MIN(1.,1.0 - liqfrac_tmp*exp(-distcltop(i)/dist_liq)),0.)
-                IF ((liqfrac_tmp .LE.0) .OR. (liqfrac_tmp .GE. 1)) THEN
-                        dicefracdT(i) = 0.
-                ELSE
-                        dicefracdT(i) = exposant_glace*((liqfrac_tmp)**(exposant_glace-1.))/(t_glace_min- t_glace_max) &
-                                        *exp(-distcltop(i)/dist_liq)
-                ENDIF
-        ENDIF
-
-        ! with modified function of temperature at cloud top 
-        ! to get largere values around 260 K, works well with t_glace_min = 241K
-        IF (iflag_t_glace .EQ. 6) THEN 
-                IF (temp(i) .GT. t_glace_max) THEN
-                        liqfrac_tmp = 1.
-                ELSE
-                        liqfrac_tmp = -((temp(i)-t_glace_max) / (t_glace_max-t_glace_min))**2+1.
-                ENDIF
-                liqfrac_tmp  = MIN(MAX(liqfrac_tmp,0.0),1.0)
-                icefrac(i)   = MAX(MIN(1.,1.0 - liqfrac_tmp*exp(-distcltop(i)/dist_liq)),0.)        
-                IF ((liqfrac_tmp .LE.0) .OR. (liqfrac_tmp .GE. 1)) THEN
-                        dicefracdT(i) = 0.
-                ELSE
-                        dicefracdT(i) = 2*((temp(i)-t_glace_max) / (t_glace_max-t_glace_min))/(t_glace_max-t_glace_min) &
-                                  *exp(-distcltop(i)/dist_liq)
-                ENDIF
-        ENDIF
-
-        ! if temperature of cloud top <-40°C, 
-        IF (iflag_t_glace .GE. 4) THEN
-                IF ((temp_cltop(i) .LE. temp_nowater) .AND. (temp(i) .LE. t_glace_max)) THEN 
-                        icefrac(i) = 1.
-                        dicefracdT(i) = 0.
-                ENDIF 
-        ENDIF
-      
-
-     ENDDO ! klon
-     RETURN
- 
-END SUBROUTINE ICEFRAC_LSCP
-!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-
-SUBROUTINE ICEFRAC_LSCP_TURB(klon, dtime, temp, pplay, paprsdn, paprsup, qice_ini, snowcld, qtot_incl, cldfra, tke, tke_dissip, qliq, qvap_cld, qice, icefrac, dicefracdT, cldfraliq, sigma2_icefracturb, mean_icefracturb)
-!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-  ! Compute the liquid, ice and vapour content (+ice fraction) based 
-  ! on turbulence (see Fields 2014, Furtado 2016, Raillard 2025)
-  ! L.Raillard (30/08/24)
-!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-
-
-   USE lmdz_lscp_ini, ONLY : prt_level, lunout
-   USE lmdz_lscp_ini, ONLY : RCPD, RLSTT, RLVTT, RLMLT, RVTMP2, RTT, RD, RG, RV, RPI
-   USE lmdz_lscp_ini, ONLY : seuil_neb, temp_nowater
-   USE lmdz_lscp_ini, ONLY : tau_mixenv, lmix_mpc, naero5, gamma_snwretro, gamma_taud, capa_crystal
-   USE lmdz_lscp_ini, ONLY : eps
-
-   IMPLICIT NONE
-
-   INTEGER,   INTENT(IN)                           :: klon              !--number of horizontal grid points
-   REAL,      INTENT(IN)                           :: dtime             !--time step [s]
-
-   REAL,      INTENT(IN),       DIMENSION(klon)    :: temp              !--temperature
-   REAL,      INTENT(IN),       DIMENSION(klon)    :: pplay             !--pressure in the middle of the layer       [Pa]
-   REAL,      INTENT(IN),       DIMENSION(klon)    :: paprsdn           !--pressure at the bottom interface of the layer [Pa]
-   REAL,      INTENT(IN),       DIMENSION(klon)    :: paprsup           !--pressure at the top interface of the layer [Pa]
-   REAL,      INTENT(IN),       DIMENSION(klon)    :: qtot_incl         !--specific total cloud water content, in-cloud content [kg/kg]
-   REAL,      INTENT(IN),       DIMENSION(klon)    :: cldfra            !--cloud fraction in gridbox [-]
-   REAL,      INTENT(IN),       DIMENSION(klon)    :: tke               !--turbulent kinetic energy [m2/s2]
-   REAL,      INTENT(IN),       DIMENSION(klon)    :: tke_dissip        !--TKE dissipation [m2/s3]
-
-   REAL,      INTENT(IN),       DIMENSION(klon)    :: qice_ini          !--initial specific ice content gridbox-mean [kg/kg]
-   REAL,      INTENT(IN),       DIMENSION(klon)    :: snowcld
-   REAL,      INTENT(OUT),      DIMENSION(klon)    :: qliq              !--specific liquid content gridbox-mean [kg/kg]
-   REAL,      INTENT(OUT),      DIMENSION(klon)    :: qvap_cld          !--specific cloud vapor content, gridbox-mean [kg/kg]
-   REAL,      INTENT(OUT),      DIMENSION(klon)    :: qice              !--specific ice content gridbox-mean [kg/kg]
-   REAL,      INTENT(OUT),      DIMENSION(klon)    :: icefrac           !--fraction of ice in condensed water [-]
-   REAL,      INTENT(OUT),      DIMENSION(klon)    :: dicefracdT
-
-   REAL,      INTENT(OUT),      DIMENSION(klon)    :: cldfraliq         !--fraction of cldfra which is liquid only
-   REAL,      INTENT(OUT),      DIMENSION(klon)    :: sigma2_icefracturb     !--Temporary 
-   REAL,      INTENT(OUT),      DIMENSION(klon)    :: mean_icefracturb      !--Temporary 
-
-   REAL, DIMENSION(klon) :: qzero, qsatl, dqsatl, qsati, dqsati         !--specific humidity saturation values
-   INTEGER :: i
-
-   REAL :: qvap_incl, qice_incl, qliq_incl, qiceini_incl                !--In-cloud specific quantities [kg/kg]
-   REAL :: qsnowcld_incl
-   !REAL :: capa_crystal                                                 !--Capacitance of ice crystals  [-]
-   REAL :: water_vapor_diff                                             !--Water-vapour diffusion coefficient in air [m2/s] (function of T&P)
-   REAL :: air_thermal_conduct                                          !--Thermal conductivity of air [J/m/K/s] (function of T)
-   REAL :: C0                                                           !--Lagrangian structure function [-]
-   REAL :: tau_mixingenv
-   REAL :: tau_dissipturb
-   REAL :: invtau_phaserelax
-   REAL :: sigma2_pdf, mean_pdf
-   REAL :: ai, bi, B0
-   REAL :: sursat_iceliq
-   REAL :: sursat_env
-   REAL :: liqfra_max
-   REAL :: sursat_iceext
-   REAL :: nb_crystals                                                  !--number concentration of ice crystals [#/m3]
-   REAL :: moment1_PSD                                                  !--1st moment of ice PSD 
-   REAL :: N0_PSD, lambda_PSD                                           !--parameters of the exponential PSD
-
-   REAL :: rho_ice                                                      !--ice density [kg/m3]
-   REAL :: cldfra1D
-   REAL :: deltaz, rho_air
-   REAL :: psati                                                        !--saturation vapor pressure wrt i [Pa]
-   
-   C0            = 10.                                                  !--value assumed in Field2014            
-   rho_ice       = 950.
-   sursat_iceext = -0.1
-   !capa_crystal  = 1. !r_ice                                       
-   qzero(:)      = 0.
-   cldfraliq(:)  = 0.
-   icefrac(:)    = 0.
-   dicefracdT(:) = 0.
-
-   sigma2_icefracturb(:) = 0.
-   mean_icefracturb(:)  = 0.
-
-   !--wrt liquid water
-   CALL calc_qsat_ecmwf(klon,temp(:),qzero(:),pplay(:),RTT,1,.false.,qsatl(:),dqsatl(:))
-   !--wrt ice
-   CALL calc_qsat_ecmwf(klon,temp(:),qzero(:),pplay(:),RTT,2,.false.,qsati(:),dqsati(:))
-
-
-    DO i=1,klon
-
-
-     rho_air  = pplay(i) / temp(i) / RD
-     !deltaz   = ( paprsdn(i) - paprsup(i) ) / RG / rho_air(i)
-     ! because cldfra is intent in, but can be locally modified due to test 
-     cldfra1D = cldfra(i)
-     IF (cldfra(i) .LE. 0.) THEN
-        qvap_cld(i)   = 0.
-        qliq(i)       = 0.
-        qice(i)       = 0.
-        cldfraliq(i)  = 0.
-        icefrac(i)    = 0.
-        dicefracdT(i) = 0.
-
-     ! If there is a cloud
-     ELSE
-        IF (cldfra(i) .GE. 1.0) THEN
-           cldfra1D = 1.0
-        END IF
-        
-        ! T>0°C, no ice allowed
-        IF ( temp(i) .GE. RTT ) THEN
-           qvap_cld(i)   = qsatl(i) * cldfra1D
-           qliq(i)       = MAX(0.0,qtot_incl(i)-qsatl(i))  * cldfra1D
-           qice(i)       = 0.
-           cldfraliq(i)  = 1.
-           icefrac(i)    = 0.
-           dicefracdT(i) = 0.
-        
-        ! T<-38°C, no liquid allowed
-        ELSE IF ( temp(i) .LE. temp_nowater) THEN
-           qvap_cld(i)   = qsati(i) * cldfra1D
-           qliq(i)       = 0.
-           qice(i)       = MAX(0.0,qtot_incl(i)-qsati(i)) * cldfra1D
-           cldfraliq(i)  = 0.
-           icefrac(i)    = 1.
-           dicefracdT(i) = 0.
-
-        ! MPC temperature
-        ELSE
-           ! Not enough TKE     
-           IF ( tke_dissip(i) .LE. eps )  THEN
-              qvap_cld(i)   = qsati(i) * cldfra1D
-              qliq(i)       = 0.
-              qice(i)       = MAX(0.,qtot_incl(i)-qsati(i)) * cldfra1D   
-              cldfraliq(i)  = 0.
-              icefrac(i)    = 1.
-              dicefracdT(i) = 0.
-           
-           ! Enough TKE   
-           ELSE  
-              print*,"MOUCHOIRACTIVE"
-              !---------------------------------------------------------
-              !--               ICE SUPERSATURATION PDF   
-              !--------------------------------------------------------- 
-              !--If -38°C< T <0°C and there is enough turbulence, 
-              !--we compute the cloud liquid properties with a Gaussian PDF 
-              !--of ice supersaturation F(Si) (Field2014, Furtado2016). 
-              !--Parameters of the PDF are function of turbulence and 
-              !--microphysics/existing ice.
-
-              sursat_iceliq = qsatl(i)/qsati(i) - 1.
-              psati         = qsati(i) * pplay(i) / (RD/RV)
-
-              !-------------- MICROPHYSICAL TERMS --------------
-              !--We assume an exponential ice PSD whose parameters 
-              !--are computed following Morrison&Gettelman 2008
-              !--Ice number density is assumed equals to INP density 
-              !--which is a function of temperature (DeMott 2010)  
-              !--bi and B0 are microphysical function characterizing 
-              !--vapor/ice interactions
-              !--tau_phase_relax is the typical time of vapor deposition
-              !--onto ice crystals
-              
-              qiceini_incl  = qice_ini(i) / cldfra1D
-              qsnowcld_incl = snowcld(i) * RG * dtime / ( paprsdn(i) - paprsup(i) ) / cldfra1D
-              sursat_env    = max(0., (qtot_incl(i) - qiceini_incl)/qsati(i) - 1.)
-              IF ( qiceini_incl .GT. eps ) THEN
-                nb_crystals = 1.e3 * 5.94e-5 * ( RTT - temp(i) )**3.33 * naero5**(0.0264*(RTT-temp(i))+0.0033)
-                lambda_PSD  = ( (RPI*rho_ice*nb_crystals) / (rho_air*(qiceini_incl + gamma_snwretro * qsnowcld_incl)) ) ** (1./3.)
-                N0_PSD      = nb_crystals * lambda_PSD
-                moment1_PSD = N0_PSD/lambda_PSD**2
-              ELSE
-                moment1_PSD = 0.
-              ENDIF
-
-              !--Formulae for air thermal conductivity and water vapor diffusivity 
-              !--comes respectively from Beard and Pruppacher (1971) 
-              !--and  Hall and Pruppacher (1976)
-
-              air_thermal_conduct = ( 5.69 + 0.017 * ( temp(i) - RTT ) ) * 1.e-3 * 4.184
-              water_vapor_diff    = 2.11*1e-5 * ( temp(i) / RTT )**1.94 * ( 101325 / pplay(i) )
-              
-              bi = 1./((qsati(i)+qsatl(i))/2.) + RLSTT**2 / RCPD / RV / temp(i)**2
-              B0 = 4. * RPI * capa_crystal * 1. / (  RLSTT**2 / air_thermal_conduct / RV / temp(i)**2  &
-                                                  +  RV * temp(i) / psati / water_vapor_diff  )
-
-              invtau_phaserelax  = (bi * B0 * moment1_PSD )
-
-!             Old way of estimating moment1 : spherical crystals + monodisperse PSD              
-!             nb_crystals = rho_air * qiceini_incl / ( 4. / 3. * RPI * r_ice**3. * rho_ice )
-!             moment1_PSD = nb_crystals * r_ice 
-
-              !----------------- TURBULENT SOURCE/SINK TERMS -----------------
-              !--Tau_mixingenv is the time needed to homogeneize the parcel 
-              !--with its environment by turbulent diffusion over the parcel
-              !--length scale
-              !--if lmix_mpc <0, tau_mixigenv value is prescribed
-              !--else tau_mixigenv value is derived from tke_dissip and lmix_mpc
-              !--Tau_dissipturb is the time needed turbulence to decay due to
-              !--viscosity
-
-              ai = RG / RD / temp(i) * ( RD * RLSTT / RCPD / RV / temp(i) - 1. )
-              IF ( lmix_mpc .GT. 0 ) THEN 
-                 tau_mixingenv = ( lmix_mpc**2. / tke_dissip(i) )**(1./3.)
-              ELSE 
-                 tau_mixingenv = tau_mixenv
-              ENDIF 
-              
-              tau_dissipturb = gamma_taud * 2. * 2./3. * tke(i) / tke_dissip(i) / C0
-
-              !--------------------- PDF COMPUTATIONS ---------------------
-              !--Formulae for sigma2_pdf (variance), mean of PDF in Furtado2016
-              !--cloud liquid fraction and in-cloud liquid content are given 
-              !--by integrating resp. F(Si) and Si*F(Si)
-              !--Liquid is limited by the available water vapor trough a 
-              !--maximal liquid fraction
-
-              liqfra_max = MAX(0., (MIN (1.,( qtot_incl(i) - qiceini_incl - qsati(i) * (1 + sursat_iceext ) ) / ( qsatl(i) - qsati(i) ) ) ) )
-              sigma2_pdf = 1./2. * ( ai**2 ) *  2./3. * tke(i) * tau_dissipturb / ( invtau_phaserelax + 1./tau_mixingenv )
-              mean_pdf   = sursat_env * 1./tau_mixingenv / ( invtau_phaserelax + 1./tau_mixingenv )
-              cldfraliq(i) = 0.5 * (1. - erf( ( sursat_iceliq - mean_pdf) / (SQRT(2.* sigma2_pdf) ) ) )
-              IF (cldfraliq(i) .GT. liqfra_max) THEN
-                  cldfraliq(i) = liqfra_max
-              ENDIF 
-              
-              qliq_incl = qsati(i) * SQRT(sigma2_pdf) / SQRT(2.*RPI) * EXP( -1.*(sursat_iceliq - mean_pdf)**2. / (2.*sigma2_pdf) )  &
-                        - qsati(i) * cldfraliq(i) * (sursat_iceliq - mean_pdf )
-              
-              sigma2_icefracturb(i)= sigma2_pdf
-              mean_icefracturb(i)  = mean_pdf 
-     
-              !------------ SPECIFIC VAPOR CONTENT AND WATER CONSERVATION  ------------
-
-              IF ( (qliq_incl .LE. eps) .OR. (cldfraliq(i) .LE. eps) ) THEN
-                  qliq_incl    = 0.
-                  cldfraliq(i) = 0.
-              END IF
-               
-              !--Specific humidity is the max between qsati and the weighted mean between 
-              !--qv in MPC patches and qv in ice-only parts. We assume that MPC parts are
-              !--always at qsatl and ice-only parts slightly subsaturated (qsati*sursat_iceext+1)
-              !--The whole cloud can therefore be supersaturated but never subsaturated.
-
-              qvap_incl = MAX(qsati(i), ( 1. - cldfraliq(i) ) * (sursat_iceext + 1.) * qsati(i) + cldfraliq(i) * qsatl(i) )
-
-
-              IF ( qvap_incl  .GE. qtot_incl(i) ) THEN
-                 qvap_incl = qsati(i)
-                 qliq_incl = qtot_incl(i) - qvap_incl
-                 qice_incl = 0.
-
-              ELSEIF ( (qvap_incl + qliq_incl) .GE. qtot_incl(i) ) THEN
-                 qliq_incl = MAX(0.0,qtot_incl(i) - qvap_incl)
-                 qice_incl = 0.
-              ELSE
-                 qice_incl = qtot_incl(i) - qvap_incl - qliq_incl
-              END IF
-
-              qvap_cld(i)   = qvap_incl * cldfra1D
-              qliq(i)       = qliq_incl * cldfra1D
-              qice(i)       = qice_incl * cldfra1D
-              icefrac(i)    = qice(i) / ( qice(i) + qliq(i) )
-              dicefracdT(i) = 0.
-              !print*,'MPC turb'
-
-           END IF ! Enough TKE
-
-        END IF ! ! MPC temperature
-
-     END IF ! cldfra
-   
-   ENDDO ! klon
-END SUBROUTINE ICEFRAC_LSCP_TURB
-!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-
-
-SUBROUTINE CALC_QSAT_ECMWF(klon,temp,qtot,pressure,tref,phase,flagth,qs,dqs)
-!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-    ! Calculate qsat following ECMWF method
-!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-
-
-    IMPLICIT NONE
-
-    include "YOMCST.h"
-    include "YOETHF.h"
-    include "FCTTRE.h"
-
-    INTEGER, INTENT(IN) :: klon  ! number of horizontal grid points
-    REAL, INTENT(IN), DIMENSION(klon) :: temp     ! temperature in K
-    REAL, INTENT(IN), DIMENSION(klon) :: qtot     ! total specific water in kg/kg
-    REAL, INTENT(IN), DIMENSION(klon) :: pressure ! pressure in Pa
-    REAL, INTENT(IN)                  :: tref     ! reference temperature in K
-    LOGICAL, INTENT(IN) :: flagth     ! flag for qsat calculation for thermals
-    INTEGER, INTENT(IN) :: phase 
-    ! phase: 0=depend on temperature sign (temp>tref -> liquid, temp<tref, solid)
-    !        1=liquid
-    !        2=solid
-
-    REAL, INTENT(OUT), DIMENSION(klon) :: qs      ! saturation specific humidity [kg/kg]
-    REAL, INTENT(OUT), DIMENSION(klon) :: dqs     ! derivation of saturation specific humidity wrt T
-
-    REAL delta, cor, cvm5
-    INTEGER i
-
-    DO i=1,klon
-
-    IF (phase .EQ. 1) THEN
-        delta=0.
-    ELSEIF (phase .EQ. 2) THEN
-        delta=1.
-    ELSE
-        delta=MAX(0.,SIGN(1.,tref-temp(i)))
-    ENDIF
-
-    IF (flagth) THEN
-    cvm5=R5LES*(1.-delta) + R5IES*delta
-    ELSE
-    cvm5 = R5LES*RLVTT*(1.-delta) + R5IES*RLSTT*delta
-    cvm5 = cvm5 /RCPD/(1.0+RVTMP2*(qtot(i)))
-    ENDIF
-
-    qs(i)= R2ES*FOEEW(temp(i),delta)/pressure(i)
-    qs(i)=MIN(0.5,qs(i))
-    cor=1./(1.-RETV*qs(i))
-    qs(i)=qs(i)*cor
-    dqs(i)= FOEDE(temp(i),delta,cvm5,qs(i),cor)
-
-    END DO
-
-END SUBROUTINE CALC_QSAT_ECMWF
-!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-
-
-!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-SUBROUTINE CALC_GAMMASAT(klon,temp,qtot,pressure,gammasat,dgammasatdt)
-
-!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-    ! programme that calculates the gammasat parameter that determines the
-    ! homogeneous condensation thresholds for cold (<0oC) clouds
-    ! condensation at q>gammasat*qsat
-    ! Etienne Vignon, March 2021
-!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-
-    use lmdz_lscp_ini, only: iflag_gammasat, temp_nowater, RTT
-    use lmdz_lscp_ini, only: a_homofreez, b_homofreez, delta_hetfreez
-
-    IMPLICIT NONE
-
-
-    INTEGER, INTENT(IN) :: klon                       ! number of horizontal grid points
-    REAL, INTENT(IN), DIMENSION(klon) :: temp         ! temperature in K
-    REAL, INTENT(IN), DIMENSION(klon) :: qtot         ! total specific water in kg/kg
-
-    REAL, INTENT(IN), DIMENSION(klon) :: pressure     ! pressure in Pa
-
-    REAL, INTENT(OUT), DIMENSION(klon) :: gammasat    ! coefficient to multiply qsat with to calculate saturation
-    REAL, INTENT(OUT), DIMENSION(klon) :: dgammasatdt ! derivative of gammasat wrt temperature
-
-    REAL, DIMENSION(klon) ::  qsi,qsl,dqsl,dqsi
-    REAL  f_homofreez, fac
-
-    INTEGER i
-    
-        CALL CALC_QSAT_ECMWF(klon,temp,qtot,pressure,RTT,1,.false.,qsl,dqsl)
-        CALL CALC_QSAT_ECMWF(klon,temp,qtot,pressure,RTT,2,.false.,qsi,dqsi)
-
-    DO i = 1, klon
-
-        IF ( temp(i) .GE. RTT ) THEN
-            ! warm clouds: condensation at saturation wrt liquid
-            gammasat(i) = 1.
-            dgammasatdt(i) = 0.
-
-        ELSE
-            ! cold clouds: qsi > qsl
-            
-            ! homogeneous freezing of aerosols, according to
-            ! Koop, 2000 and Ren and MacKenzie, 2005 (QJRMS)
-            ! 'Cirrus regime'
-            ! if f_homofreez > qsl / qsi, liquid nucleation
-            ! if f_homofreez < qsl / qsi, homogeneous freezing of aerosols
-            ! Note: f_homofreez = qsl / qsi for temp ~= -38degC
-            f_homofreez = a_homofreez - temp(i) / b_homofreez
-            
-            IF ( iflag_gammasat .GE. 3 ) THEN
-              ! condensation at homogeneous freezing threshold for temp < -38 degC
-              ! condensation at liquid saturation for temp > -38 degC
-              IF ( f_homofreez .LE. qsl(i) / qsi(i) ) THEN
-                gammasat(i) = f_homofreez
-                dgammasatdt(i) = - 1. / b_homofreez
-              ELSE
-                gammasat(i) = qsl(i) / qsi(i)
-                dgammasatdt(i) = ( dqsl(i) * qsi(i) - dqsi(i) * qsl(i) ) / qsi(i) / qsi(i)
-              ENDIF
-
-            ELSEIF ( iflag_gammasat .EQ. 2 ) THEN
-              ! condensation at homogeneous freezing threshold for temp < -38 degC
-              ! condensation at a threshold linearly decreasing between homogeneous
-              ! freezing and ice saturation for -38 degC < temp < temp_nowater
-              ! condensation at ice saturation for temp > temp_nowater
-              ! If temp_nowater = 235.15 K, this is equivalent to iflag_gammasat = 1
-              IF ( f_homofreez .LE. qsl(i) / qsi(i) ) THEN
-                gammasat(i) = f_homofreez
-                dgammasatdt(i) = - 1. / b_homofreez
-              ELSEIF ( temp(i) .LE. temp_nowater ) THEN
-                ! Here, we assume that f_homofreez = qsl / qsi for temp = -38 degC = 235.15 K
-                dgammasatdt(i) = ( a_homofreez - 235.15 / b_homofreez - 1. ) &
-                               / ( 235.15 - temp_nowater )
-                gammasat(i) = dgammasatdt(i) * ( temp(i) - temp_nowater ) + 1.
-              ELSE
-                gammasat(i) = 1.
-                dgammasatdt(i) = 0.
-              ENDIF
-
-            ELSEIF ( iflag_gammasat .EQ. 1 ) THEN
-              ! condensation at homogeneous freezing threshold for temp < -38 degC
-              ! condensation at ice saturation for temp > -38 degC
-              IF ( f_homofreez .LE. qsl(i) / qsi(i) ) THEN
-                gammasat(i) = f_homofreez
-                dgammasatdt(i) = - 1. / b_homofreez
-              ELSE
-                gammasat(i) = 1.
-                dgammasatdt(i) = 0.
-              ENDIF
-
-            ELSE
-              ! condensation at ice saturation for temp < -38 degC
-              ! condensation at ice saturation for temp > -38 degC
-              gammasat(i) = 1.
-              dgammasatdt(i) = 0.
-
-            ENDIF
-
-            ! Note that the delta_hetfreez parameter allows to linearly decrease the
-            ! condensation threshold between the calculated threshold and the ice saturation
-            ! for delta_hetfreez = 1, the threshold is the calculated condensation threshold
-            ! for delta_hetfreez = 0, the threshold is the ice saturation
-            gammasat(i) = ( 1. - delta_hetfreez ) + delta_hetfreez * gammasat(i)
-            dgammasatdt(i) = delta_hetfreez * dgammasatdt(i)
-
-        ENDIF
-   
-    END DO
-
-
-END SUBROUTINE CALC_GAMMASAT
-!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-
-
-!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-SUBROUTINE DISTANCE_TO_CLOUD_TOP(klon,klev,k,temp,pplay,paprs,rneb,distcltop1D,temp_cltop)
-!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-   
-   USE lmdz_lscp_ini, ONLY : rd,rg,tresh_cl
-
-   IMPLICIT NONE
-   
-   INTEGER, INTENT(IN) :: klon,klev                !number of horizontal and vertical grid points
-   INTEGER, INTENT(IN) :: k                        ! vertical index
-   REAL, INTENT(IN), DIMENSION(klon,klev) :: temp  ! temperature in K
-   REAL, INTENT(IN), DIMENSION(klon,klev) :: pplay ! pressure middle layer in Pa
-   REAL, INTENT(IN), DIMENSION(klon,klev+1) :: paprs ! pressure interfaces in Pa
-   REAL, INTENT(IN), DIMENSION(klon,klev) :: rneb  ! cloud fraction
-
-   REAL, INTENT(OUT), DIMENSION(klon) :: distcltop1D  ! distance from cloud top
-   REAL, INTENT(OUT), DIMENSION(klon) :: temp_cltop     ! temperature of cloud top
-   
-   REAL dzlay(klon,klev)
-   REAL zlay(klon,klev)
-   REAL dzinterf
-   INTEGER i,k_top, kvert
-   LOGICAL bool_cl
-
-
-   DO i=1,klon
-         ! Initialization height middle of first layer
-          dzlay(i,1) = Rd * temp(i,1) / rg * log(paprs(i,1)/paprs(i,2))
-          zlay(i,1) = dzlay(i,1)/2
-
-          DO kvert=2,klev
-                 IF (kvert.EQ.klev) THEN
-                       dzlay(i,kvert) = 2*(rd * temp(i,kvert) / rg * log(paprs(i,kvert)/pplay(i,kvert)))
-                 ELSE
-                       dzlay(i,kvert) = rd * temp(i,kvert) / rg * log(paprs(i,kvert)/paprs(i,kvert+1))
-                 ENDIF
-                       dzinterf       = rd * temp(i,kvert) / rg * log(pplay(i,kvert-1)/pplay(i,kvert))
-                       zlay(i,kvert)  = zlay(i,kvert-1) + dzinterf
-           ENDDO
-   ENDDO
-   
-   DO i=1,klon
-          k_top = k
-          IF (rneb(i,k) .LE. tresh_cl) THEN
-                 bool_cl = .FALSE.
-          ELSE
-                 bool_cl = .TRUE.
-          ENDIF
-
-          DO WHILE ((bool_cl) .AND. (k_top .LE. klev))
-          ! find cloud top
-                IF (rneb(i,k_top) .GT. tresh_cl) THEN
-                      k_top = k_top + 1
-                ELSE
-                      bool_cl = .FALSE.
-                      k_top   = k_top - 1
-                ENDIF
-          ENDDO
-          k_top=min(k_top,klev)
-
-          !dist to top is dist between current layer and layer of cloud top (from middle to middle) + dist middle to
-          !interf for layer of cloud top
-          distcltop1D(i) = zlay(i,k_top) - zlay(i,k) + dzlay(i,k_top)/2
-          temp_cltop(i)  = temp(i,k_top)
-   ENDDO ! klon
-
-END SUBROUTINE DISTANCE_TO_CLOUD_TOP
-!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-
-!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-FUNCTION GAMMAINC ( p, x )
-
-!*****************************************************************************80
-!
-!! GAMMAINC computes the regularized lower incomplete Gamma Integral
-!
-!  Modified:
-!
-!    20 January 2008
-!
-!  Author:
-!
-!    Original FORTRAN77 version by B Shea.
-!    FORTRAN90 version by John Burkardt.
-!
-!  Reference:
-!
-!    B Shea,
-!    Algorithm AS 239:
-!    Chi-squared and Incomplete Gamma Integral,
-!    Applied Statistics,
-!    Volume 37, Number 3, 1988, pages 466-473.
-!
-!  Parameters:
-!
-!    Input, real X, P, the parameters of the incomplete
-!    gamma ratio.  0 <= X, and 0 < P.
-!
-!    Output, real GAMMAINC, the value of the incomplete
-!    Gamma integral.
-!
-  IMPLICIT NONE
-
-  REAL A
-  REAL AN
-  REAL ARG
-  REAL B
-  REAL C
-  REAL, PARAMETER :: ELIMIT = - 88.0E+00
-  REAL GAMMAINC
-  REAL, PARAMETER :: OFLO = 1.0E+37
-  REAL P
-  REAL, PARAMETER :: PLIMIT = 1000.0E+00
-  REAL PN1
-  REAL PN2
-  REAL PN3
-  REAL PN4
-  REAL PN5
-  REAL PN6
-  REAL RN
-  REAL, PARAMETER :: TOL = 1.0E-14
-  REAL X
-  REAL, PARAMETER :: XBIG = 1.0E+08
-
-  GAMMAINC = 0.0E+00
-
-  IF ( X == 0.0E+00 ) THEN
-    GAMMAINC = 0.0E+00
-    RETURN
-  END IF
-!
-!  IF P IS LARGE, USE A NORMAL APPROXIMATION.
-!
-  IF ( PLIMIT < P ) THEN
-
-    PN1 = 3.0E+00 * SQRT ( P ) * ( ( X / P )**( 1.0E+00 / 3.0E+00 ) &
-    + 1.0E+00 / ( 9.0E+00 * P ) - 1.0E+00 )
-
-    GAMMAINC = 0.5E+00 * ( 1. + ERF ( PN1 ) )
-    RETURN
-
-  END IF
-!
-!  IF X IS LARGE SET GAMMAD = 1.
-!
-  IF ( XBIG < X ) THEN
-    GAMMAINC = 1.0E+00
-    RETURN
-  END IF
-!
-!  USE PEARSON'S SERIES EXPANSION.
-!  (NOTE THAT P IS NOT LARGE ENOUGH TO FORCE OVERFLOW IN ALOGAM).
-!
-  IF ( X <= 1.0E+00 .OR. X < P ) THEN
-
-    ARG = P * LOG ( X ) - X - LOG_GAMMA ( P + 1.0E+00 )
-    C = 1.0E+00
-    GAMMAINC = 1.0E+00
-    A = P
-
-    DO
-
-      A = A + 1.0E+00
-      C = C * X / A
-      GAMMAINC = GAMMAINC + C
-
-      IF ( C <= TOL ) THEN
-        EXIT
-      END IF
-
-    END DO
-
-    ARG = ARG + LOG ( GAMMAINC )
-
-    IF ( ELIMIT <= ARG ) THEN
-      GAMMAINC = EXP ( ARG )
-    ELSE
-      GAMMAINC = 0.0E+00
-    END IF
-!
-!  USE A CONTINUED FRACTION EXPANSION.
-!
-  ELSE
-
-    ARG = P * LOG ( X ) - X - LOG_GAMMA ( P )
-    A = 1.0E+00 - P
-    B = A + X + 1.0E+00
-    C = 0.0E+00
-    PN1 = 1.0E+00
-    PN2 = X
-    PN3 = X + 1.0E+00
-    PN4 = X * B
-    GAMMAINC = PN3 / PN4
-
-    DO
-
-      A = A + 1.0E+00
-      B = B + 2.0E+00
-      C = C + 1.0E+00
-      AN = A * C
-      PN5 = B * PN3 - AN * PN1
-      PN6 = B * PN4 - AN * PN2
-
-      IF ( PN6 /= 0.0E+00 ) THEN
-
-        RN = PN5 / PN6
-
-        IF ( ABS ( GAMMAINC - RN ) <= MIN ( TOL, TOL * RN ) ) THEN
-          EXIT
-        END IF
-
-        GAMMAINC = RN
-
-      END IF
-
-      PN1 = PN3
-      PN2 = PN4
-      PN3 = PN5
-      PN4 = PN6
-!
-!  RE-SCALE TERMS IN CONTINUED FRACTION IF TERMS ARE LARGE.
-!
-      IF ( OFLO <= ABS ( PN5 ) ) THEN
-        PN1 = PN1 / OFLO
-        PN2 = PN2 / OFLO
-        PN3 = PN3 / OFLO
-        PN4 = PN4 / OFLO
-      END IF
-
-    END DO
-
-    ARG = ARG + LOG ( GAMMAINC )
-
-    IF ( ELIMIT <= ARG ) THEN
-      GAMMAINC = 1.0E+00 - EXP ( ARG )
-    ELSE
-      GAMMAINC = 1.0E+00
-    END IF
-
-  END IF
-
-  RETURN
-END FUNCTION GAMMAINC
-!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-
-END MODULE lmdz_lscp_tools
-
-
Index: /LMDZ6/trunk/libf/phylmd/lmdz_lscp_tools.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/lmdz_lscp_tools.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/lmdz_lscp_tools.f90	(revision 5268)
@@ -0,0 +1,936 @@
+MODULE lmdz_lscp_tools
+
+    IMPLICIT NONE
+
+CONTAINS
+
+!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+SUBROUTINE FALLICE_VELOCITY(klon,iwc,temp,rho,pres,ptconv,velo)
+
+    ! Ref:
+    ! Stubenrauch, C. J., Bonazzola, M.,
+    ! Protopapadaki, S. E., & Musat, I. (2019).
+    ! New cloud system metrics to assess bulk
+    ! ice cloud schemes in a GCM. Journal of
+    ! Advances in Modeling Earth Systems, 11,
+    ! 3212–3234. https://doi.org/10.1029/2019MS001642
+    
+    use lmdz_lscp_ini, only: iflag_vice, ffallv_con, ffallv_lsc
+    use lmdz_lscp_ini, only: cice_velo, dice_velo 
+
+    IMPLICIT NONE
+
+    INTEGER, INTENT(IN) :: klon
+    REAL, INTENT(IN), DIMENSION(klon) :: iwc       ! specific ice water content [kg/m3]
+    REAL, INTENT(IN), DIMENSION(klon) :: temp      ! temperature [K]
+    REAL, INTENT(IN), DIMENSION(klon) :: rho       ! dry air density [kg/m3]
+    REAL, INTENT(IN), DIMENSION(klon) :: pres      ! air pressure [Pa]
+    LOGICAL, INTENT(IN), DIMENSION(klon) :: ptconv    ! convective point  [-]
+
+    REAL, INTENT(OUT), DIMENSION(klon) :: velo    ! fallspeed velocity of crystals [m/s]
+
+
+    INTEGER i
+    REAL logvm,iwcg,tempc,phpa,fallv_tun
+    REAL m2ice, m2snow, vmice, vmsnow
+    REAL aice, bice, asnow, bsnow
+    
+
+    DO i=1,klon
+
+        IF (ptconv(i)) THEN
+            fallv_tun=ffallv_con
+        ELSE
+            fallv_tun=ffallv_lsc
+        ENDIF
+
+        tempc=temp(i)-273.15 ! celcius temp
+        iwcg=MAX(iwc(i)*1000.,1E-3) ! iwc in g/m3. We set a minimum value to prevent from division by 0
+        phpa=pres(i)/100.    ! pressure in hPa
+
+    IF (iflag_vice .EQ. 1) THEN
+        ! so-called 'empirical parameterization' in Stubenrauch et al. 2019
+        if (tempc .GE. -60.0) then
+
+            logvm= -0.0000414122*tempc*tempc*log(iwcg)-0.00538922*tempc*log(iwcg) &
+                    -0.0516344*log(iwcg)+0.00216078*tempc + 1.9714    
+            velo(i)=exp(logvm)
+        else
+            velo(i)=65.0*(iwcg**0.2)*(150./phpa)**0.15
+        endif
+        
+        velo(i)=fallv_tun*velo(i)/100.0 ! from cm/s to m/s
+
+    ELSE IF (iflag_vice .EQ. 2) THEN
+        ! so called  PSDM empirical coherent bulk ice scheme in Stubenrauch et al. 2019
+        aice=0.587
+        bice=2.45
+        asnow=0.0444
+        bsnow=2.1
+        
+        m2ice=((iwcg*0.001/aice)/(exp(13.6-bice*7.76+0.479*bice**2)* & 
+                exp((-0.0361+bice*0.0151+0.00149*bice**2)*tempc)))   &
+                **(1./(0.807+bice*0.00581+0.0457*bice**2))
+
+        vmice=100.*1042.4*exp(13.6-(bice+1)*7.76+0.479*(bice+1.)**2)*exp((-0.0361+ &
+                 (bice+1.)*0.0151+0.00149*(bice+1.)**2)*tempc) &
+                 *(m2ice**(0.807+(bice+1.)*0.00581+0.0457*(bice+1.)**2))/(iwcg*0.001/aice)
+
+       
+        vmice=vmice*((1000./phpa)**0.2)
+      
+        m2snow=((iwcg*0.001/asnow)/(exp(13.6-bsnow*7.76+0.479*bsnow**2)* &
+               exp((-0.0361+bsnow*0.0151+0.00149*bsnow**2)*tempc)))         &
+               **(1./(0.807+bsnow*0.00581+0.0457*bsnow**2))
+
+
+        vmsnow=100.*14.3*exp(13.6-(bsnow+.416)*7.76+0.479*(bsnow+.416)**2)&
+                  *exp((-0.0361+(bsnow+.416)*0.0151+0.00149*(bsnow+.416)**2)*tempc)&
+                  *(m2snow**(0.807+(bsnow+.416)*0.00581+0.0457*(bsnow+.416)**2))/(iwcg*0.001/asnow)
+
+        vmsnow=vmsnow*((1000./phpa)**0.35)
+        velo(i)=fallv_tun*min(vmsnow,vmice)/100. ! to m/s
+
+    ELSE
+        ! By default, fallspeed velocity of ice crystals according to Heymsfield & Donner 1990
+        velo(i) = fallv_tun*cice_velo*((iwcg/1000.)**dice_velo)
+    ENDIF
+    ENDDO
+
+END SUBROUTINE FALLICE_VELOCITY
+!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+SUBROUTINE ICEFRAC_LSCP(klon, temp, iflag_ice_thermo, distcltop, temp_cltop, icefrac, dicefracdT)
+!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+  
+  ! Compute the ice fraction 1-xliq (see e.g.
+  ! Doutriaux-Boucher & Quaas 2004, section 2.2.)
+  ! as a function of temperature
+  ! see also Fig 3 of Madeleine et al. 2020, JAMES
+!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+    USE print_control_mod, ONLY: lunout, prt_level
+    USE lmdz_lscp_ini, ONLY: t_glace_min, t_glace_max, exposant_glace, iflag_t_glace
+    USE lmdz_lscp_ini, ONLY : RTT, dist_liq, temp_nowater
+
+    IMPLICIT NONE
+
+
+    INTEGER, INTENT(IN)                 :: klon              ! number of horizontal grid points
+    REAL, INTENT(IN), DIMENSION(klon)   :: temp              ! temperature
+    REAL, INTENT(IN), DIMENSION(klon)   :: distcltop         ! distance to cloud top
+    REAL, INTENT(IN), DIMENSION(klon)   :: temp_cltop        ! temperature of cloud top
+    INTEGER, INTENT(IN)                 :: iflag_ice_thermo
+    REAL, INTENT(OUT), DIMENSION(klon)  :: icefrac
+    REAL, INTENT(OUT), DIMENSION(klon)  :: dicefracdT
+
+
+    INTEGER i
+    REAL    liqfrac_tmp, dicefrac_tmp
+    REAL    Dv, denomdep,beta,qsi,dqsidt
+    LOGICAL ice_thermo
+
+    CHARACTER (len = 20) :: modname = 'lscp_tools'
+    CHARACTER (len = 80) :: abort_message
+
+    IF ((iflag_t_glace.LT.2)) THEN !.OR. (iflag_t_glace.GT.6)) THEN
+       abort_message = 'lscp cannot be used if iflag_t_glace<2 or >6'
+       CALL abort_physic(modname,abort_message,1)
+    ENDIF
+
+    IF (.NOT.((iflag_ice_thermo .EQ. 1).OR.(iflag_ice_thermo .GE. 3))) THEN
+       abort_message = 'lscp cannot be used without ice thermodynamics'
+       CALL abort_physic(modname,abort_message,1)
+    ENDIF
+
+
+    DO i=1,klon
+ 
+        ! old function with sole dependence upon temperature
+        IF (iflag_t_glace .EQ. 2) THEN
+            liqfrac_tmp = (temp(i)-t_glace_min) / (t_glace_max-t_glace_min)
+            liqfrac_tmp = MIN(MAX(liqfrac_tmp,0.0),1.0)
+            icefrac(i) = (1.0-liqfrac_tmp)**exposant_glace
+            IF (icefrac(i) .GT.0.) THEN
+                 dicefracdT(i)= exposant_glace * (icefrac(i)**(exposant_glace-1.)) &
+                           / (t_glace_min - t_glace_max)
+            ENDIF
+
+            IF ((icefrac(i).EQ.0).OR.(icefrac(i).EQ.1)) THEN
+                 dicefracdT(i)=0.
+            ENDIF
+
+        ENDIF
+
+        ! function of temperature used in CMIP6 physics
+        IF (iflag_t_glace .EQ. 3) THEN
+            liqfrac_tmp = (temp(i)-t_glace_min) / (t_glace_max-t_glace_min)
+            liqfrac_tmp = MIN(MAX(liqfrac_tmp,0.0),1.0)
+            icefrac(i) = 1.0-liqfrac_tmp**exposant_glace
+            IF ((icefrac(i) .GT.0.) .AND. (liqfrac_tmp .GT. 0.)) THEN
+                dicefracdT(i)= exposant_glace * ((liqfrac_tmp)**(exposant_glace-1.)) &
+                          / (t_glace_min - t_glace_max)
+            ELSE
+                dicefracdT(i)=0.
+            ENDIF
+        ENDIF
+
+        ! for iflag_t_glace .GE. 4, the liquid fraction depends upon temperature at cloud top
+        ! and then decreases with decreasing height 
+
+        !with linear function of temperature at cloud top
+        IF (iflag_t_glace .EQ. 4) THEN  
+                liqfrac_tmp = (temp(i)-t_glace_min) / (t_glace_max-t_glace_min)
+                liqfrac_tmp = MIN(MAX(liqfrac_tmp,0.0),1.0)
+                icefrac(i)    =  MAX(MIN(1.,1.0 - liqfrac_tmp*exp(-distcltop(i)/dist_liq)),0.)
+                dicefrac_tmp = - temp(i)/(t_glace_max-t_glace_min)
+                dicefracdT(i) = dicefrac_tmp*exp(-distcltop(i)/dist_liq)
+                IF ((liqfrac_tmp .LE.0) .OR. (liqfrac_tmp .GE. 1)) THEN
+                        dicefracdT(i) = 0.
+                ENDIF
+        ENDIF
+
+        ! with CMIP6 function of temperature at cloud top
+        IF ((iflag_t_glace .EQ. 5) .OR. (iflag_t_glace .EQ. 7)) THEN 
+                liqfrac_tmp = (temp(i)-t_glace_min) / (t_glace_max-t_glace_min)
+                liqfrac_tmp =  MIN(MAX(liqfrac_tmp,0.0),1.0)
+                liqfrac_tmp = liqfrac_tmp**exposant_glace
+                icefrac(i)  =  MAX(MIN(1.,1.0 - liqfrac_tmp*exp(-distcltop(i)/dist_liq)),0.)
+                IF ((liqfrac_tmp .LE.0) .OR. (liqfrac_tmp .GE. 1)) THEN
+                        dicefracdT(i) = 0.
+                ELSE
+                        dicefracdT(i) = exposant_glace*((liqfrac_tmp)**(exposant_glace-1.))/(t_glace_min- t_glace_max) &
+                                        *exp(-distcltop(i)/dist_liq)
+                ENDIF
+        ENDIF
+
+        ! with modified function of temperature at cloud top 
+        ! to get largere values around 260 K, works well with t_glace_min = 241K
+        IF (iflag_t_glace .EQ. 6) THEN 
+                IF (temp(i) .GT. t_glace_max) THEN
+                        liqfrac_tmp = 1.
+                ELSE
+                        liqfrac_tmp = -((temp(i)-t_glace_max) / (t_glace_max-t_glace_min))**2+1.
+                ENDIF
+                liqfrac_tmp  = MIN(MAX(liqfrac_tmp,0.0),1.0)
+                icefrac(i)   = MAX(MIN(1.,1.0 - liqfrac_tmp*exp(-distcltop(i)/dist_liq)),0.)        
+                IF ((liqfrac_tmp .LE.0) .OR. (liqfrac_tmp .GE. 1)) THEN
+                        dicefracdT(i) = 0.
+                ELSE
+                        dicefracdT(i) = 2*((temp(i)-t_glace_max) / (t_glace_max-t_glace_min))/(t_glace_max-t_glace_min) &
+                                  *exp(-distcltop(i)/dist_liq)
+                ENDIF
+        ENDIF
+
+        ! if temperature of cloud top <-40°C, 
+        IF (iflag_t_glace .GE. 4) THEN
+                IF ((temp_cltop(i) .LE. temp_nowater) .AND. (temp(i) .LE. t_glace_max)) THEN 
+                        icefrac(i) = 1.
+                        dicefracdT(i) = 0.
+                ENDIF 
+        ENDIF
+      
+
+     ENDDO ! klon
+     RETURN
+ 
+END SUBROUTINE ICEFRAC_LSCP
+!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+SUBROUTINE ICEFRAC_LSCP_TURB(klon, dtime, temp, pplay, paprsdn, paprsup, qice_ini, snowcld, qtot_incl, cldfra, tke, tke_dissip, qliq, qvap_cld, qice, icefrac, dicefracdT, cldfraliq, sigma2_icefracturb, mean_icefracturb)
+!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+  ! Compute the liquid, ice and vapour content (+ice fraction) based 
+  ! on turbulence (see Fields 2014, Furtado 2016, Raillard 2025)
+  ! L.Raillard (30/08/24)
+!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+   USE lmdz_lscp_ini, ONLY : prt_level, lunout
+   USE lmdz_lscp_ini, ONLY : RCPD, RLSTT, RLVTT, RLMLT, RVTMP2, RTT, RD, RG, RV, RPI
+   USE lmdz_lscp_ini, ONLY : seuil_neb, temp_nowater
+   USE lmdz_lscp_ini, ONLY : tau_mixenv, lmix_mpc, naero5, gamma_snwretro, gamma_taud, capa_crystal
+   USE lmdz_lscp_ini, ONLY : eps
+
+   IMPLICIT NONE
+
+   INTEGER,   INTENT(IN)                           :: klon              !--number of horizontal grid points
+   REAL,      INTENT(IN)                           :: dtime             !--time step [s]
+
+   REAL,      INTENT(IN),       DIMENSION(klon)    :: temp              !--temperature
+   REAL,      INTENT(IN),       DIMENSION(klon)    :: pplay             !--pressure in the middle of the layer       [Pa]
+   REAL,      INTENT(IN),       DIMENSION(klon)    :: paprsdn           !--pressure at the bottom interface of the layer [Pa]
+   REAL,      INTENT(IN),       DIMENSION(klon)    :: paprsup           !--pressure at the top interface of the layer [Pa]
+   REAL,      INTENT(IN),       DIMENSION(klon)    :: qtot_incl         !--specific total cloud water content, in-cloud content [kg/kg]
+   REAL,      INTENT(IN),       DIMENSION(klon)    :: cldfra            !--cloud fraction in gridbox [-]
+   REAL,      INTENT(IN),       DIMENSION(klon)    :: tke               !--turbulent kinetic energy [m2/s2]
+   REAL,      INTENT(IN),       DIMENSION(klon)    :: tke_dissip        !--TKE dissipation [m2/s3]
+
+   REAL,      INTENT(IN),       DIMENSION(klon)    :: qice_ini          !--initial specific ice content gridbox-mean [kg/kg]
+   REAL,      INTENT(IN),       DIMENSION(klon)    :: snowcld
+   REAL,      INTENT(OUT),      DIMENSION(klon)    :: qliq              !--specific liquid content gridbox-mean [kg/kg]
+   REAL,      INTENT(OUT),      DIMENSION(klon)    :: qvap_cld          !--specific cloud vapor content, gridbox-mean [kg/kg]
+   REAL,      INTENT(OUT),      DIMENSION(klon)    :: qice              !--specific ice content gridbox-mean [kg/kg]
+   REAL,      INTENT(OUT),      DIMENSION(klon)    :: icefrac           !--fraction of ice in condensed water [-]
+   REAL,      INTENT(OUT),      DIMENSION(klon)    :: dicefracdT
+
+   REAL,      INTENT(OUT),      DIMENSION(klon)    :: cldfraliq         !--fraction of cldfra which is liquid only
+   REAL,      INTENT(OUT),      DIMENSION(klon)    :: sigma2_icefracturb     !--Temporary 
+   REAL,      INTENT(OUT),      DIMENSION(klon)    :: mean_icefracturb      !--Temporary 
+
+   REAL, DIMENSION(klon) :: qzero, qsatl, dqsatl, qsati, dqsati         !--specific humidity saturation values
+   INTEGER :: i
+
+   REAL :: qvap_incl, qice_incl, qliq_incl, qiceini_incl                !--In-cloud specific quantities [kg/kg]
+   REAL :: qsnowcld_incl
+   !REAL :: capa_crystal                                                 !--Capacitance of ice crystals  [-]
+   REAL :: water_vapor_diff                                             !--Water-vapour diffusion coefficient in air [m2/s] (function of T&P)
+   REAL :: air_thermal_conduct                                          !--Thermal conductivity of air [J/m/K/s] (function of T)
+   REAL :: C0                                                           !--Lagrangian structure function [-]
+   REAL :: tau_mixingenv
+   REAL :: tau_dissipturb
+   REAL :: invtau_phaserelax
+   REAL :: sigma2_pdf, mean_pdf
+   REAL :: ai, bi, B0
+   REAL :: sursat_iceliq
+   REAL :: sursat_env
+   REAL :: liqfra_max
+   REAL :: sursat_iceext
+   REAL :: nb_crystals                                                  !--number concentration of ice crystals [#/m3]
+   REAL :: moment1_PSD                                                  !--1st moment of ice PSD 
+   REAL :: N0_PSD, lambda_PSD                                           !--parameters of the exponential PSD
+
+   REAL :: rho_ice                                                      !--ice density [kg/m3]
+   REAL :: cldfra1D
+   REAL :: deltaz, rho_air
+   REAL :: psati                                                        !--saturation vapor pressure wrt i [Pa]
+   
+   C0            = 10.                                                  !--value assumed in Field2014            
+   rho_ice       = 950.
+   sursat_iceext = -0.1
+   !capa_crystal  = 1. !r_ice                                       
+   qzero(:)      = 0.
+   cldfraliq(:)  = 0.
+   icefrac(:)    = 0.
+   dicefracdT(:) = 0.
+
+   sigma2_icefracturb(:) = 0.
+   mean_icefracturb(:)  = 0.
+
+   !--wrt liquid water
+   CALL calc_qsat_ecmwf(klon,temp(:),qzero(:),pplay(:),RTT,1,.false.,qsatl(:),dqsatl(:))
+   !--wrt ice
+   CALL calc_qsat_ecmwf(klon,temp(:),qzero(:),pplay(:),RTT,2,.false.,qsati(:),dqsati(:))
+
+
+    DO i=1,klon
+
+
+     rho_air  = pplay(i) / temp(i) / RD
+     !deltaz   = ( paprsdn(i) - paprsup(i) ) / RG / rho_air(i)
+     ! because cldfra is intent in, but can be locally modified due to test 
+     cldfra1D = cldfra(i)
+     IF (cldfra(i) .LE. 0.) THEN
+        qvap_cld(i)   = 0.
+        qliq(i)       = 0.
+        qice(i)       = 0.
+        cldfraliq(i)  = 0.
+        icefrac(i)    = 0.
+        dicefracdT(i) = 0.
+
+     ! If there is a cloud
+     ELSE
+        IF (cldfra(i) .GE. 1.0) THEN
+           cldfra1D = 1.0
+        END IF
+        
+        ! T>0°C, no ice allowed
+        IF ( temp(i) .GE. RTT ) THEN
+           qvap_cld(i)   = qsatl(i) * cldfra1D
+           qliq(i)       = MAX(0.0,qtot_incl(i)-qsatl(i))  * cldfra1D
+           qice(i)       = 0.
+           cldfraliq(i)  = 1.
+           icefrac(i)    = 0.
+           dicefracdT(i) = 0.
+        
+        ! T<-38°C, no liquid allowed
+        ELSE IF ( temp(i) .LE. temp_nowater) THEN
+           qvap_cld(i)   = qsati(i) * cldfra1D
+           qliq(i)       = 0.
+           qice(i)       = MAX(0.0,qtot_incl(i)-qsati(i)) * cldfra1D
+           cldfraliq(i)  = 0.
+           icefrac(i)    = 1.
+           dicefracdT(i) = 0.
+
+        ! MPC temperature
+        ELSE
+           ! Not enough TKE     
+           IF ( tke_dissip(i) .LE. eps )  THEN
+              qvap_cld(i)   = qsati(i) * cldfra1D
+              qliq(i)       = 0.
+              qice(i)       = MAX(0.,qtot_incl(i)-qsati(i)) * cldfra1D   
+              cldfraliq(i)  = 0.
+              icefrac(i)    = 1.
+              dicefracdT(i) = 0.
+           
+           ! Enough TKE   
+           ELSE  
+              print*,"MOUCHOIRACTIVE"
+              !---------------------------------------------------------
+              !--               ICE SUPERSATURATION PDF   
+              !--------------------------------------------------------- 
+              !--If -38°C< T <0°C and there is enough turbulence, 
+              !--we compute the cloud liquid properties with a Gaussian PDF 
+              !--of ice supersaturation F(Si) (Field2014, Furtado2016). 
+              !--Parameters of the PDF are function of turbulence and 
+              !--microphysics/existing ice.
+
+              sursat_iceliq = qsatl(i)/qsati(i) - 1.
+              psati         = qsati(i) * pplay(i) / (RD/RV)
+
+              !-------------- MICROPHYSICAL TERMS --------------
+              !--We assume an exponential ice PSD whose parameters 
+              !--are computed following Morrison&Gettelman 2008
+              !--Ice number density is assumed equals to INP density 
+              !--which is a function of temperature (DeMott 2010)  
+              !--bi and B0 are microphysical function characterizing 
+              !--vapor/ice interactions
+              !--tau_phase_relax is the typical time of vapor deposition
+              !--onto ice crystals
+              
+              qiceini_incl  = qice_ini(i) / cldfra1D
+              qsnowcld_incl = snowcld(i) * RG * dtime / ( paprsdn(i) - paprsup(i) ) / cldfra1D
+              sursat_env    = max(0., (qtot_incl(i) - qiceini_incl)/qsati(i) - 1.)
+              IF ( qiceini_incl .GT. eps ) THEN
+                nb_crystals = 1.e3 * 5.94e-5 * ( RTT - temp(i) )**3.33 * naero5**(0.0264*(RTT-temp(i))+0.0033)
+                lambda_PSD  = ( (RPI*rho_ice*nb_crystals) / (rho_air*(qiceini_incl + gamma_snwretro * qsnowcld_incl)) ) ** (1./3.)
+                N0_PSD      = nb_crystals * lambda_PSD
+                moment1_PSD = N0_PSD/lambda_PSD**2
+              ELSE
+                moment1_PSD = 0.
+              ENDIF
+
+              !--Formulae for air thermal conductivity and water vapor diffusivity 
+              !--comes respectively from Beard and Pruppacher (1971) 
+              !--and  Hall and Pruppacher (1976)
+
+              air_thermal_conduct = ( 5.69 + 0.017 * ( temp(i) - RTT ) ) * 1.e-3 * 4.184
+              water_vapor_diff    = 2.11*1e-5 * ( temp(i) / RTT )**1.94 * ( 101325 / pplay(i) )
+              
+              bi = 1./((qsati(i)+qsatl(i))/2.) + RLSTT**2 / RCPD / RV / temp(i)**2
+              B0 = 4. * RPI * capa_crystal * 1. / (  RLSTT**2 / air_thermal_conduct / RV / temp(i)**2  &
+                                                  +  RV * temp(i) / psati / water_vapor_diff  )
+
+              invtau_phaserelax  = (bi * B0 * moment1_PSD )
+
+!             Old way of estimating moment1 : spherical crystals + monodisperse PSD              
+!             nb_crystals = rho_air * qiceini_incl / ( 4. / 3. * RPI * r_ice**3. * rho_ice )
+!             moment1_PSD = nb_crystals * r_ice 
+
+              !----------------- TURBULENT SOURCE/SINK TERMS -----------------
+              !--Tau_mixingenv is the time needed to homogeneize the parcel 
+              !--with its environment by turbulent diffusion over the parcel
+              !--length scale
+              !--if lmix_mpc <0, tau_mixigenv value is prescribed
+              !--else tau_mixigenv value is derived from tke_dissip and lmix_mpc
+              !--Tau_dissipturb is the time needed turbulence to decay due to
+              !--viscosity
+
+              ai = RG / RD / temp(i) * ( RD * RLSTT / RCPD / RV / temp(i) - 1. )
+              IF ( lmix_mpc .GT. 0 ) THEN 
+                 tau_mixingenv = ( lmix_mpc**2. / tke_dissip(i) )**(1./3.)
+              ELSE 
+                 tau_mixingenv = tau_mixenv
+              ENDIF 
+              
+              tau_dissipturb = gamma_taud * 2. * 2./3. * tke(i) / tke_dissip(i) / C0
+
+              !--------------------- PDF COMPUTATIONS ---------------------
+              !--Formulae for sigma2_pdf (variance), mean of PDF in Furtado2016
+              !--cloud liquid fraction and in-cloud liquid content are given 
+              !--by integrating resp. F(Si) and Si*F(Si)
+              !--Liquid is limited by the available water vapor trough a 
+              !--maximal liquid fraction
+
+              liqfra_max = MAX(0., (MIN (1.,( qtot_incl(i) - qiceini_incl - qsati(i) * (1 + sursat_iceext ) ) / ( qsatl(i) - qsati(i) ) ) ) )
+              sigma2_pdf = 1./2. * ( ai**2 ) *  2./3. * tke(i) * tau_dissipturb / ( invtau_phaserelax + 1./tau_mixingenv )
+              mean_pdf   = sursat_env * 1./tau_mixingenv / ( invtau_phaserelax + 1./tau_mixingenv )
+              cldfraliq(i) = 0.5 * (1. - erf( ( sursat_iceliq - mean_pdf) / (SQRT(2.* sigma2_pdf) ) ) )
+              IF (cldfraliq(i) .GT. liqfra_max) THEN
+                  cldfraliq(i) = liqfra_max
+              ENDIF 
+              
+              qliq_incl = qsati(i) * SQRT(sigma2_pdf) / SQRT(2.*RPI) * EXP( -1.*(sursat_iceliq - mean_pdf)**2. / (2.*sigma2_pdf) )  &
+                        - qsati(i) * cldfraliq(i) * (sursat_iceliq - mean_pdf )
+              
+              sigma2_icefracturb(i)= sigma2_pdf
+              mean_icefracturb(i)  = mean_pdf 
+     
+              !------------ SPECIFIC VAPOR CONTENT AND WATER CONSERVATION  ------------
+
+              IF ( (qliq_incl .LE. eps) .OR. (cldfraliq(i) .LE. eps) ) THEN
+                  qliq_incl    = 0.
+                  cldfraliq(i) = 0.
+              END IF
+               
+              !--Specific humidity is the max between qsati and the weighted mean between 
+              !--qv in MPC patches and qv in ice-only parts. We assume that MPC parts are
+              !--always at qsatl and ice-only parts slightly subsaturated (qsati*sursat_iceext+1)
+              !--The whole cloud can therefore be supersaturated but never subsaturated.
+
+              qvap_incl = MAX(qsati(i), ( 1. - cldfraliq(i) ) * (sursat_iceext + 1.) * qsati(i) + cldfraliq(i) * qsatl(i) )
+
+
+              IF ( qvap_incl  .GE. qtot_incl(i) ) THEN
+                 qvap_incl = qsati(i)
+                 qliq_incl = qtot_incl(i) - qvap_incl
+                 qice_incl = 0.
+
+              ELSEIF ( (qvap_incl + qliq_incl) .GE. qtot_incl(i) ) THEN
+                 qliq_incl = MAX(0.0,qtot_incl(i) - qvap_incl)
+                 qice_incl = 0.
+              ELSE
+                 qice_incl = qtot_incl(i) - qvap_incl - qliq_incl
+              END IF
+
+              qvap_cld(i)   = qvap_incl * cldfra1D
+              qliq(i)       = qliq_incl * cldfra1D
+              qice(i)       = qice_incl * cldfra1D
+              icefrac(i)    = qice(i) / ( qice(i) + qliq(i) )
+              dicefracdT(i) = 0.
+              !print*,'MPC turb'
+
+           END IF ! Enough TKE
+
+        END IF ! ! MPC temperature
+
+     END IF ! cldfra
+   
+   ENDDO ! klon
+END SUBROUTINE ICEFRAC_LSCP_TURB
+!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+SUBROUTINE CALC_QSAT_ECMWF(klon,temp,qtot,pressure,tref,phase,flagth,qs,dqs)
+!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+    ! Calculate qsat following ECMWF method
+!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+    IMPLICIT NONE
+
+    include "YOMCST.h"
+    include "YOETHF.h"
+    include "FCTTRE.h"
+
+    INTEGER, INTENT(IN) :: klon  ! number of horizontal grid points
+    REAL, INTENT(IN), DIMENSION(klon) :: temp     ! temperature in K
+    REAL, INTENT(IN), DIMENSION(klon) :: qtot     ! total specific water in kg/kg
+    REAL, INTENT(IN), DIMENSION(klon) :: pressure ! pressure in Pa
+    REAL, INTENT(IN)                  :: tref     ! reference temperature in K
+    LOGICAL, INTENT(IN) :: flagth     ! flag for qsat calculation for thermals
+    INTEGER, INTENT(IN) :: phase 
+    ! phase: 0=depend on temperature sign (temp>tref -> liquid, temp<tref, solid)
+    !        1=liquid
+    !        2=solid
+
+    REAL, INTENT(OUT), DIMENSION(klon) :: qs      ! saturation specific humidity [kg/kg]
+    REAL, INTENT(OUT), DIMENSION(klon) :: dqs     ! derivation of saturation specific humidity wrt T
+
+    REAL delta, cor, cvm5
+    INTEGER i
+
+    DO i=1,klon
+
+    IF (phase .EQ. 1) THEN
+        delta=0.
+    ELSEIF (phase .EQ. 2) THEN
+        delta=1.
+    ELSE
+        delta=MAX(0.,SIGN(1.,tref-temp(i)))
+    ENDIF
+
+    IF (flagth) THEN
+    cvm5=R5LES*(1.-delta) + R5IES*delta
+    ELSE
+    cvm5 = R5LES*RLVTT*(1.-delta) + R5IES*RLSTT*delta
+    cvm5 = cvm5 /RCPD/(1.0+RVTMP2*(qtot(i)))
+    ENDIF
+
+    qs(i)= R2ES*FOEEW(temp(i),delta)/pressure(i)
+    qs(i)=MIN(0.5,qs(i))
+    cor=1./(1.-RETV*qs(i))
+    qs(i)=qs(i)*cor
+    dqs(i)= FOEDE(temp(i),delta,cvm5,qs(i),cor)
+
+    END DO
+
+END SUBROUTINE CALC_QSAT_ECMWF
+!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+SUBROUTINE CALC_GAMMASAT(klon,temp,qtot,pressure,gammasat,dgammasatdt)
+
+!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+    ! programme that calculates the gammasat parameter that determines the
+    ! homogeneous condensation thresholds for cold (<0oC) clouds
+    ! condensation at q>gammasat*qsat
+    ! Etienne Vignon, March 2021
+!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+    use lmdz_lscp_ini, only: iflag_gammasat, temp_nowater, RTT
+    use lmdz_lscp_ini, only: a_homofreez, b_homofreez, delta_hetfreez
+
+    IMPLICIT NONE
+
+
+    INTEGER, INTENT(IN) :: klon                       ! number of horizontal grid points
+    REAL, INTENT(IN), DIMENSION(klon) :: temp         ! temperature in K
+    REAL, INTENT(IN), DIMENSION(klon) :: qtot         ! total specific water in kg/kg
+
+    REAL, INTENT(IN), DIMENSION(klon) :: pressure     ! pressure in Pa
+
+    REAL, INTENT(OUT), DIMENSION(klon) :: gammasat    ! coefficient to multiply qsat with to calculate saturation
+    REAL, INTENT(OUT), DIMENSION(klon) :: dgammasatdt ! derivative of gammasat wrt temperature
+
+    REAL, DIMENSION(klon) ::  qsi,qsl,dqsl,dqsi
+    REAL  f_homofreez, fac
+
+    INTEGER i
+    
+        CALL CALC_QSAT_ECMWF(klon,temp,qtot,pressure,RTT,1,.false.,qsl,dqsl)
+        CALL CALC_QSAT_ECMWF(klon,temp,qtot,pressure,RTT,2,.false.,qsi,dqsi)
+
+    DO i = 1, klon
+
+        IF ( temp(i) .GE. RTT ) THEN
+            ! warm clouds: condensation at saturation wrt liquid
+            gammasat(i) = 1.
+            dgammasatdt(i) = 0.
+
+        ELSE
+            ! cold clouds: qsi > qsl
+            
+            ! homogeneous freezing of aerosols, according to
+            ! Koop, 2000 and Ren and MacKenzie, 2005 (QJRMS)
+            ! 'Cirrus regime'
+            ! if f_homofreez > qsl / qsi, liquid nucleation
+            ! if f_homofreez < qsl / qsi, homogeneous freezing of aerosols
+            ! Note: f_homofreez = qsl / qsi for temp ~= -38degC
+            f_homofreez = a_homofreez - temp(i) / b_homofreez
+            
+            IF ( iflag_gammasat .GE. 3 ) THEN
+              ! condensation at homogeneous freezing threshold for temp < -38 degC
+              ! condensation at liquid saturation for temp > -38 degC
+              IF ( f_homofreez .LE. qsl(i) / qsi(i) ) THEN
+                gammasat(i) = f_homofreez
+                dgammasatdt(i) = - 1. / b_homofreez
+              ELSE
+                gammasat(i) = qsl(i) / qsi(i)
+                dgammasatdt(i) = ( dqsl(i) * qsi(i) - dqsi(i) * qsl(i) ) / qsi(i) / qsi(i)
+              ENDIF
+
+            ELSEIF ( iflag_gammasat .EQ. 2 ) THEN
+              ! condensation at homogeneous freezing threshold for temp < -38 degC
+              ! condensation at a threshold linearly decreasing between homogeneous
+              ! freezing and ice saturation for -38 degC < temp < temp_nowater
+              ! condensation at ice saturation for temp > temp_nowater
+              ! If temp_nowater = 235.15 K, this is equivalent to iflag_gammasat = 1
+              IF ( f_homofreez .LE. qsl(i) / qsi(i) ) THEN
+                gammasat(i) = f_homofreez
+                dgammasatdt(i) = - 1. / b_homofreez
+              ELSEIF ( temp(i) .LE. temp_nowater ) THEN
+                ! Here, we assume that f_homofreez = qsl / qsi for temp = -38 degC = 235.15 K
+                dgammasatdt(i) = ( a_homofreez - 235.15 / b_homofreez - 1. ) &
+                               / ( 235.15 - temp_nowater )
+                gammasat(i) = dgammasatdt(i) * ( temp(i) - temp_nowater ) + 1.
+              ELSE
+                gammasat(i) = 1.
+                dgammasatdt(i) = 0.
+              ENDIF
+
+            ELSEIF ( iflag_gammasat .EQ. 1 ) THEN
+              ! condensation at homogeneous freezing threshold for temp < -38 degC
+              ! condensation at ice saturation for temp > -38 degC
+              IF ( f_homofreez .LE. qsl(i) / qsi(i) ) THEN
+                gammasat(i) = f_homofreez
+                dgammasatdt(i) = - 1. / b_homofreez
+              ELSE
+                gammasat(i) = 1.
+                dgammasatdt(i) = 0.
+              ENDIF
+
+            ELSE
+              ! condensation at ice saturation for temp < -38 degC
+              ! condensation at ice saturation for temp > -38 degC
+              gammasat(i) = 1.
+              dgammasatdt(i) = 0.
+
+            ENDIF
+
+            ! Note that the delta_hetfreez parameter allows to linearly decrease the
+            ! condensation threshold between the calculated threshold and the ice saturation
+            ! for delta_hetfreez = 1, the threshold is the calculated condensation threshold
+            ! for delta_hetfreez = 0, the threshold is the ice saturation
+            gammasat(i) = ( 1. - delta_hetfreez ) + delta_hetfreez * gammasat(i)
+            dgammasatdt(i) = delta_hetfreez * dgammasatdt(i)
+
+        ENDIF
+   
+    END DO
+
+
+END SUBROUTINE CALC_GAMMASAT
+!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+SUBROUTINE DISTANCE_TO_CLOUD_TOP(klon,klev,k,temp,pplay,paprs,rneb,distcltop1D,temp_cltop)
+!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+   
+   USE lmdz_lscp_ini, ONLY : rd,rg,tresh_cl
+
+   IMPLICIT NONE
+   
+   INTEGER, INTENT(IN) :: klon,klev                !number of horizontal and vertical grid points
+   INTEGER, INTENT(IN) :: k                        ! vertical index
+   REAL, INTENT(IN), DIMENSION(klon,klev) :: temp  ! temperature in K
+   REAL, INTENT(IN), DIMENSION(klon,klev) :: pplay ! pressure middle layer in Pa
+   REAL, INTENT(IN), DIMENSION(klon,klev+1) :: paprs ! pressure interfaces in Pa
+   REAL, INTENT(IN), DIMENSION(klon,klev) :: rneb  ! cloud fraction
+
+   REAL, INTENT(OUT), DIMENSION(klon) :: distcltop1D  ! distance from cloud top
+   REAL, INTENT(OUT), DIMENSION(klon) :: temp_cltop     ! temperature of cloud top
+   
+   REAL dzlay(klon,klev)
+   REAL zlay(klon,klev)
+   REAL dzinterf
+   INTEGER i,k_top, kvert
+   LOGICAL bool_cl
+
+
+   DO i=1,klon
+         ! Initialization height middle of first layer
+          dzlay(i,1) = Rd * temp(i,1) / rg * log(paprs(i,1)/paprs(i,2))
+          zlay(i,1) = dzlay(i,1)/2
+
+          DO kvert=2,klev
+                 IF (kvert.EQ.klev) THEN
+                       dzlay(i,kvert) = 2*(rd * temp(i,kvert) / rg * log(paprs(i,kvert)/pplay(i,kvert)))
+                 ELSE
+                       dzlay(i,kvert) = rd * temp(i,kvert) / rg * log(paprs(i,kvert)/paprs(i,kvert+1))
+                 ENDIF
+                       dzinterf       = rd * temp(i,kvert) / rg * log(pplay(i,kvert-1)/pplay(i,kvert))
+                       zlay(i,kvert)  = zlay(i,kvert-1) + dzinterf
+           ENDDO
+   ENDDO
+   
+   DO i=1,klon
+          k_top = k
+          IF (rneb(i,k) .LE. tresh_cl) THEN
+                 bool_cl = .FALSE.
+          ELSE
+                 bool_cl = .TRUE.
+          ENDIF
+
+          DO WHILE ((bool_cl) .AND. (k_top .LE. klev))
+          ! find cloud top
+                IF (rneb(i,k_top) .GT. tresh_cl) THEN
+                      k_top = k_top + 1
+                ELSE
+                      bool_cl = .FALSE.
+                      k_top   = k_top - 1
+                ENDIF
+          ENDDO
+          k_top=min(k_top,klev)
+
+          !dist to top is dist between current layer and layer of cloud top (from middle to middle) + dist middle to
+          !interf for layer of cloud top
+          distcltop1D(i) = zlay(i,k_top) - zlay(i,k) + dzlay(i,k_top)/2
+          temp_cltop(i)  = temp(i,k_top)
+   ENDDO ! klon
+
+END SUBROUTINE DISTANCE_TO_CLOUD_TOP
+!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+FUNCTION GAMMAINC ( p, x )
+
+!*****************************************************************************80
+!
+!! GAMMAINC computes the regularized lower incomplete Gamma Integral
+!
+!  Modified:
+!
+!    20 January 2008
+!
+!  Author:
+!
+!    Original FORTRAN77 version by B Shea.
+!    FORTRAN90 version by John Burkardt.
+!
+!  Reference:
+!
+!    B Shea,
+!    Algorithm AS 239:
+!    Chi-squared and Incomplete Gamma Integral,
+!    Applied Statistics,
+!    Volume 37, Number 3, 1988, pages 466-473.
+!
+!  Parameters:
+!
+!    Input, real X, P, the parameters of the incomplete
+!    gamma ratio.  0 <= X, and 0 < P.
+!
+!    Output, real GAMMAINC, the value of the incomplete
+!    Gamma integral.
+!
+  IMPLICIT NONE
+
+  REAL A
+  REAL AN
+  REAL ARG
+  REAL B
+  REAL C
+  REAL, PARAMETER :: ELIMIT = - 88.0E+00
+  REAL GAMMAINC
+  REAL, PARAMETER :: OFLO = 1.0E+37
+  REAL P
+  REAL, PARAMETER :: PLIMIT = 1000.0E+00
+  REAL PN1
+  REAL PN2
+  REAL PN3
+  REAL PN4
+  REAL PN5
+  REAL PN6
+  REAL RN
+  REAL, PARAMETER :: TOL = 1.0E-14
+  REAL X
+  REAL, PARAMETER :: XBIG = 1.0E+08
+
+  GAMMAINC = 0.0E+00
+
+  IF ( X == 0.0E+00 ) THEN
+    GAMMAINC = 0.0E+00
+    RETURN
+  END IF
+!
+!  IF P IS LARGE, USE A NORMAL APPROXIMATION.
+!
+  IF ( PLIMIT < P ) THEN
+
+    PN1 = 3.0E+00 * SQRT ( P ) * ( ( X / P )**( 1.0E+00 / 3.0E+00 ) &
+    + 1.0E+00 / ( 9.0E+00 * P ) - 1.0E+00 )
+
+    GAMMAINC = 0.5E+00 * ( 1. + ERF ( PN1 ) )
+    RETURN
+
+  END IF
+!
+!  IF X IS LARGE SET GAMMAD = 1.
+!
+  IF ( XBIG < X ) THEN
+    GAMMAINC = 1.0E+00
+    RETURN
+  END IF
+!
+!  USE PEARSON'S SERIES EXPANSION.
+!  (NOTE THAT P IS NOT LARGE ENOUGH TO FORCE OVERFLOW IN ALOGAM).
+!
+  IF ( X <= 1.0E+00 .OR. X < P ) THEN
+
+    ARG = P * LOG ( X ) - X - LOG_GAMMA ( P + 1.0E+00 )
+    C = 1.0E+00
+    GAMMAINC = 1.0E+00
+    A = P
+
+    DO
+
+      A = A + 1.0E+00
+      C = C * X / A
+      GAMMAINC = GAMMAINC + C
+
+      IF ( C <= TOL ) THEN
+        EXIT
+      END IF
+
+    END DO
+
+    ARG = ARG + LOG ( GAMMAINC )
+
+    IF ( ELIMIT <= ARG ) THEN
+      GAMMAINC = EXP ( ARG )
+    ELSE
+      GAMMAINC = 0.0E+00
+    END IF
+!
+!  USE A CONTINUED FRACTION EXPANSION.
+!
+  ELSE
+
+    ARG = P * LOG ( X ) - X - LOG_GAMMA ( P )
+    A = 1.0E+00 - P
+    B = A + X + 1.0E+00
+    C = 0.0E+00
+    PN1 = 1.0E+00
+    PN2 = X
+    PN3 = X + 1.0E+00
+    PN4 = X * B
+    GAMMAINC = PN3 / PN4
+
+    DO
+
+      A = A + 1.0E+00
+      B = B + 2.0E+00
+      C = C + 1.0E+00
+      AN = A * C
+      PN5 = B * PN3 - AN * PN1
+      PN6 = B * PN4 - AN * PN2
+
+      IF ( PN6 /= 0.0E+00 ) THEN
+
+        RN = PN5 / PN6
+
+        IF ( ABS ( GAMMAINC - RN ) <= MIN ( TOL, TOL * RN ) ) THEN
+          EXIT
+        END IF
+
+        GAMMAINC = RN
+
+      END IF
+
+      PN1 = PN3
+      PN2 = PN4
+      PN3 = PN5
+      PN4 = PN6
+!
+!  RE-SCALE TERMS IN CONTINUED FRACTION IF TERMS ARE LARGE.
+!
+      IF ( OFLO <= ABS ( PN5 ) ) THEN
+        PN1 = PN1 / OFLO
+        PN2 = PN2 / OFLO
+        PN3 = PN3 / OFLO
+        PN4 = PN4 / OFLO
+      END IF
+
+    END DO
+
+    ARG = ARG + LOG ( GAMMAINC )
+
+    IF ( ELIMIT <= ARG ) THEN
+      GAMMAINC = 1.0E+00 - EXP ( ARG )
+    ELSE
+      GAMMAINC = 1.0E+00
+    END IF
+
+  END IF
+
+  RETURN
+END FUNCTION GAMMAINC
+!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+END MODULE lmdz_lscp_tools
+
+
Index: DZ6/trunk/libf/phylmd/lmdz_ratqs_ini.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/lmdz_ratqs_ini.F90	(revision 5267)
+++ 	(revision )
@@ -1,95 +1,0 @@
-MODULE lmdz_ratqs_ini
-
-IMPLICIT NONE
-
-save
-
-integer :: lunout
-
-INTEGER, SAVE, PROTECTED :: nbsrf,is_lic,is_ter
-REAL, SAVE, PROTECTED :: RG,RV,RD,RCPD,RLSTT,RLVTT,RTT
-REAL, SAVE, PROTECTED :: a_ratqs_cv
-REAL, SAVE, PROTECTED :: tau_var
-REAL, SAVE, PROTECTED :: fac_tau
-REAL, SAVE, PROTECTED :: tau_cumul
-REAL, SAVE, PROTECTED :: a_ratqs_wake
-INTEGER, SAVE, PROTECTED :: dqimpl
-
-real, allocatable, SAVE :: povariance(:,:)
-!$OMP THREADPRIVATE(povariance)
-real, allocatable, SAVE :: var_conv(:,:)
-!$OMP THREADPRIVATE(var_conv)
-
-!$OMP THREADPRIVATE(a_ratqs_cv,tau_var,fac_tau,tau_cumul,a_ratqs_wake)
-
-
-CONTAINS
-SUBROUTINE ratqs_ini(klon,klev,iflag_thermals,lunout_in,nbsrf_in,is_lic_in,is_ter_in,RG_in,RV_in,RD_in,RCPD_in,RLSTT_in,RLVTT_in,RTT_in)
-
-   USE ioipsl_getin_p_mod, ONLY : getin_p
-
-integer, intent(in) :: klon,klev,iflag_thermals,lunout_in
-integer, intent(in) :: nbsrf_in,is_lic_in,is_ter_in
-real, intent(in) :: RG_in,RV_in,RD_in,RCPD_in,RLSTT_in,RLVTT_in,RTT_in
-
-integer :: i,k
-
-nbsrf   =nbsrf_in
-is_lic  =is_lic_in
-is_ter  =is_ter_in
-RG      =RG_in    
-RV      =RV_in
-RD      =RD_in
-RCPD    =RCPD_in
-RLSTT   =RLSTT_in
-RLVTT   =RLVTT_in
-RTT     =RTT_in
-
-print*,'ratqs_ini'
-if (iflag_thermals==15.or.iflag_thermals==16) then
-   dqimpl=-1
-else
-   dqimpl=1
-endif
-lunout=lunout_in
-
-allocate(povariance(klon,klev))
-allocate(var_conv(klon,klev))
-
-
-tau_var = 700. ! temps de relaxation de la variabilit?? pour les thermiques
-fac_tau = 2. 
-tau_cumul = 1000 
-a_ratqs_wake = 3.    ! param??tre pilotant l'importance du terme d??pendant des poches froides
-a_ratqs_cv = 1.
-CALL getin_p('tau_var', tau_var)
-CALL getin_p('fac_tau', fac_tau)
-CALL getin_p('tau_cumul', tau_cumul)
-CALL getin_p('a_ratqs_wake', a_ratqs_wake) 
-CALL getin_p('a_ratqs_cv', a_ratqs_cv)
-
-!--------------------------------------------------------
-! Initialisation des variances pour la param??trisation
-! pronostique des variances de Louis.
-! Ne marche pour le moment qu'en 1D en forcant une 
-! initialisation des variances ?? une valeur constante.
-! A terme la variance doit devenir une variable d'etat
-! passee en argument
-!--------------------------------------------------------
-
-if (klon.eq.1) then
-    do k=1,klev
-      do i=1,klon 
-          povariance(i,k) = 0.00000000001
-          var_conv(i,k) = 0.00000000001
-      enddo
-    enddo
-else
-    print*, 'conserver la variance dans les restarts'
-endif
-!--------------------------------------------------------
-
- RETURN
-
-END SUBROUTINE ratqs_ini
-END MODULE lmdz_ratqs_ini
Index: /LMDZ6/trunk/libf/phylmd/lmdz_ratqs_ini.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/lmdz_ratqs_ini.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/lmdz_ratqs_ini.f90	(revision 5268)
@@ -0,0 +1,95 @@
+MODULE lmdz_ratqs_ini
+
+IMPLICIT NONE
+
+save
+
+integer :: lunout
+
+INTEGER, SAVE, PROTECTED :: nbsrf,is_lic,is_ter
+REAL, SAVE, PROTECTED :: RG,RV,RD,RCPD,RLSTT,RLVTT,RTT
+REAL, SAVE, PROTECTED :: a_ratqs_cv
+REAL, SAVE, PROTECTED :: tau_var
+REAL, SAVE, PROTECTED :: fac_tau
+REAL, SAVE, PROTECTED :: tau_cumul
+REAL, SAVE, PROTECTED :: a_ratqs_wake
+INTEGER, SAVE, PROTECTED :: dqimpl
+
+real, allocatable, SAVE :: povariance(:,:)
+!$OMP THREADPRIVATE(povariance)
+real, allocatable, SAVE :: var_conv(:,:)
+!$OMP THREADPRIVATE(var_conv)
+
+!$OMP THREADPRIVATE(a_ratqs_cv,tau_var,fac_tau,tau_cumul,a_ratqs_wake)
+
+
+CONTAINS
+SUBROUTINE ratqs_ini(klon,klev,iflag_thermals,lunout_in,nbsrf_in,is_lic_in,is_ter_in,RG_in,RV_in,RD_in,RCPD_in,RLSTT_in,RLVTT_in,RTT_in)
+
+   USE ioipsl_getin_p_mod, ONLY : getin_p
+
+integer, intent(in) :: klon,klev,iflag_thermals,lunout_in
+integer, intent(in) :: nbsrf_in,is_lic_in,is_ter_in
+real, intent(in) :: RG_in,RV_in,RD_in,RCPD_in,RLSTT_in,RLVTT_in,RTT_in
+
+integer :: i,k
+
+nbsrf   =nbsrf_in
+is_lic  =is_lic_in
+is_ter  =is_ter_in
+RG      =RG_in    
+RV      =RV_in
+RD      =RD_in
+RCPD    =RCPD_in
+RLSTT   =RLSTT_in
+RLVTT   =RLVTT_in
+RTT     =RTT_in
+
+print*,'ratqs_ini'
+if (iflag_thermals==15.or.iflag_thermals==16) then
+   dqimpl=-1
+else
+   dqimpl=1
+endif
+lunout=lunout_in
+
+allocate(povariance(klon,klev))
+allocate(var_conv(klon,klev))
+
+
+tau_var = 700. ! temps de relaxation de la variabilit?? pour les thermiques
+fac_tau = 2. 
+tau_cumul = 1000 
+a_ratqs_wake = 3.    ! param??tre pilotant l'importance du terme d??pendant des poches froides
+a_ratqs_cv = 1.
+CALL getin_p('tau_var', tau_var)
+CALL getin_p('fac_tau', fac_tau)
+CALL getin_p('tau_cumul', tau_cumul)
+CALL getin_p('a_ratqs_wake', a_ratqs_wake) 
+CALL getin_p('a_ratqs_cv', a_ratqs_cv)
+
+!--------------------------------------------------------
+! Initialisation des variances pour la param??trisation
+! pronostique des variances de Louis.
+! Ne marche pour le moment qu'en 1D en forcant une 
+! initialisation des variances ?? une valeur constante.
+! A terme la variance doit devenir une variable d'etat
+! passee en argument
+!--------------------------------------------------------
+
+if (klon.eq.1) then
+    do k=1,klev
+      do i=1,klon 
+          povariance(i,k) = 0.00000000001
+          var_conv(i,k) = 0.00000000001
+      enddo
+    enddo
+else
+    print*, 'conserver la variance dans les restarts'
+endif
+!--------------------------------------------------------
+
+ RETURN
+
+END SUBROUTINE ratqs_ini
+END MODULE lmdz_ratqs_ini
Index: DZ6/trunk/libf/phylmd/lmdz_ratqs_main.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/lmdz_ratqs_main.F90	(revision 5267)
+++ 	(revision )
@@ -1,281 +1,0 @@
-MODULE lmdz_ratqs_main
-
-CONTAINS
-
-SUBROUTINE ratqs_main(klon,klev,nbsrf,prt_level,lunout,       &
-           iflag_ratqs,iflag_con,iflag_cld_th,pdtphys, &
-           ratqsbas,ratqshaut,ratqsp0,ratqsdp, &
-           pctsrf,s_pblh,zstd, &
-           tau_ratqs,fact_cldcon,wake_s, wake_deltaq,   &
-           ptconv,ptconvth,clwcon0th, rnebcon0th,       &
-           paprs,pplay,t_seri,q_seri,                   &
-           qtc_cv, sigt_cv,detrain_cv,fm_cv,fqd,fqcomp,sigd,zqsat,             &
-           omega,tke,tke_dissip,lmix,wprime, &
-           t2m,q2m,fm_therm,entr_therm,detr_therm,cell_area,&
-           ratqs,ratqsc,ratqs_inter_,sigma_qtherm)
-
-
-USE lmdz_ratqs_multi,   ONLY: ratqs_inter, ratqs_oro, ratqs_hetero, ratqs_tke
-
-implicit none
-
-!========================================================================
-! Computation of ratqs, the width of the subrid scale water distribution
-! (normalized by the mean value)
-! Various options controled by flags iflag_con and iflag_ratqs
-! F Hourdin 2012/12/06
-!========================================================================
-
-! Declarations
-
-! Input
-integer,intent(in) :: klon,klev,nbsrf,prt_level,lunout
-integer,intent(in) :: iflag_con,iflag_cld_th,iflag_ratqs
-real,intent(in) :: pdtphys,ratqsbas,ratqshaut,fact_cldcon,tau_ratqs
-real,intent(in) :: ratqsp0, ratqsdp
-real, dimension(klon,klev),intent(in) :: omega
-real, dimension(klon,klev+1),intent(in) :: paprs,tke,tke_dissip,lmix,wprime
-real, dimension(klon,klev),intent(in) :: pplay,t_seri,q_seri,zqsat
-real, dimension(klon,klev),intent(in) :: entr_therm,detr_therm,qtc_cv, sigt_cv
-real, dimension(klon,klev) :: detrain_cv,fm_cv,fqd,fqcomp
-real, dimension(klon) :: sigd
-
-real, dimension(klon,klev+1),intent(in) :: fm_therm
-logical, dimension(klon,klev),intent(in) :: ptconv
-real, dimension(klon,klev),intent(in) :: rnebcon0th,clwcon0th
-real, dimension(klon,klev),intent(in) :: wake_deltaq,wake_s
-real, dimension(klon,nbsrf),intent(in) :: t2m,q2m
-real, dimension(klon), intent(in) :: cell_area
-real, dimension(klon,nbsrf),intent(in) :: pctsrf
-real, dimension(klon),intent(in) :: s_pblh
-real, dimension(klon),intent(in) :: zstd
-
-! Output
-real, dimension(klon,klev),intent(inout) :: ratqs,ratqsc,ratqs_inter_,sigma_qtherm
-
-logical, dimension(klon,klev),intent(inout) :: ptconvth
-
-! local
-integer i,k
-real, dimension(klon,klev) :: ratqss
-real facteur,zfratqs1,zfratqs2
-real, dimension(klon,klev) :: ratqs_hetero_,ratqs_oro_,ratqs_tke_
-real resol,resolmax,fact
-
-!-------------------------------------------------------------------------
-!  Caclul des ratqs
-!-------------------------------------------------------------------------
-
-!      print*,'calcul des ratqs'
-!   ratqs convectifs a l'ancienne en fonction de q(z=0)-q / q
-!   ----------------
-!   on ecrase le tableau ratqsc calcule par clouds_gno
-      if (iflag_cld_th.eq.1) then
-         do k=1,klev
-         do i=1,klon
-            if(ptconv(i,k)) then
-              ratqsc(i,k)=ratqsbas &
-              +fact_cldcon*(q_seri(i,1)-q_seri(i,k))/q_seri(i,k)
-            else
-               ratqsc(i,k)=0.
-            endif
-         enddo
-         enddo
-
-!-----------------------------------------------------------------------
-!  par nversion de la fonction log normale
-!-----------------------------------------------------------------------
-      else if (iflag_cld_th.eq.4) then
-         ptconvth(:,:)=.false.
-         ratqsc(:,:)=0.
-         if(prt_level.ge.9) print*,'avant clouds_gno thermique'
-         call clouds_gno &
-         (klon,klev,q_seri,zqsat,clwcon0th,ptconvth,ratqsc,rnebcon0th)
-         if(prt_level.ge.9) print*,' CLOUDS_GNO OK'
-       
-       endif
-
-!   ratqs stables
-!   -------------
-
-      if (iflag_ratqs.eq.0) then
-
-! Le cas iflag_ratqs=0 correspond a la version IPCC 2005 du modele.
-         do k=1,klev
-            do i=1, klon
-               ratqss(i,k)=ratqsbas+(ratqshaut-ratqsbas)* &
-               min((paprs(i,1)-pplay(i,k))/(paprs(i,1)-30000.),1.) 
-            enddo 
-         enddo
-
-! Pour iflag_ratqs=1 ou 2, le ratqs est constant au dessus de 
-! 300 hPa (ratqshaut), varie lineariement en fonction de la pression
-! entre 600 et 300 hPa et est soit constant (ratqsbas) pour iflag_ratqs=1
-! soit lineaire (entre 0 a la surface et ratqsbas) pour iflag_ratqs=2
-! Il s'agit de differents tests dans la phase de reglage du modele
-! avec thermiques.
-
-      else if (iflag_ratqs.eq.1) then
-
-         do k=1,klev
-            do i=1, klon
-               if (pplay(i,k).ge.60000.) then
-                  ratqss(i,k)=ratqsbas
-               else if ((pplay(i,k).ge.30000.).and.(pplay(i,k).lt.60000.)) then
-                  ratqss(i,k)=ratqsbas+(ratqshaut-ratqsbas)*(60000.-pplay(i,k))/(60000.-30000.)
-               else
-                  ratqss(i,k)=ratqshaut
-               endif
-            enddo
-         enddo
-
-      else if (iflag_ratqs.eq.2) then
-
-         do k=1,klev
-            do i=1, klon
-               if (pplay(i,k).ge.60000.) then
-                  ratqss(i,k)=ratqsbas*(paprs(i,1)-pplay(i,k))/(paprs(i,1)-60000.)
-               else if ((pplay(i,k).ge.30000.).and.(pplay(i,k).lt.60000.)) then
-                    ratqss(i,k)=ratqsbas+(ratqshaut-ratqsbas)*(60000.-pplay(i,k))/(60000.-30000.)
-               else
-                    ratqss(i,k)=ratqshaut
-               endif
-            enddo
-         enddo
-
-      else if (iflag_ratqs==3) then
-         do k=1,klev
-           ratqss(:,k)=ratqsbas+(ratqshaut-ratqsbas) &
-           *min( ((paprs(:,1)-pplay(:,k))/70000.)**2 , 1. )
-         enddo
-
-      else if (iflag_ratqs==4) then 
-         do k=1,klev
-           ratqss(:,k)=ratqsbas+0.5*(ratqshaut-ratqsbas) &
-!          *( tanh( (50000.-pplay(:,k))/20000.) + 1.)
-           *( tanh( (ratqsp0-pplay(:,k))/ratqsdp) + 1.)
-         enddo
-
-
-      else if (iflag_ratqs==5) then
-! Dependency of ratqs on model resolution
-! Audran, Meryl, Lea, Gwendal and Etienne
-! April 2023 
-        resolmax=sqrt(maxval(cell_area))
-         do k=1,klev
-            do i=1,klon
-              resol=sqrt(cell_area(i))
-              fact=sqrt(resol/resolmax)
-              ratqss(i,k)=ratqsbas*fact+0.5*(ratqshaut-ratqsbas)*fact &
-              *( tanh( (ratqsp0-pplay(i,k))/ratqsdp) + 1.)
-           enddo
-         enddo
-
-
-       else if (iflag_ratqs .GT. 9) then
- 
-       ! interactive ratqs calculations that depend on cold pools, orography, surface heterogeneity and small-scale turbulence
-       ! This should help getting a more realistic ratqs in the low and mid troposphere
-       ! We however need a "background" ratqs to account for subgrid distribution of qt (or qt/qs)
-       ! in the high troposphere
-       
-       ! background ratqs and initialisations
-          do k=1,klev
-             do i=1,klon
-              ratqss(i,k)=ratqsbas+0.5*(ratqshaut-ratqsbas) &
-              *( tanh( (ratqsp0-pplay(i,k))/ratqsdp) + 1.)
-              ratqss(i,k)=max(ratqss(i,k),0.0)
-              ratqs_hetero_(i,k)=0.
-              ratqs_oro_(i,k)=0.
-              ratqs_tke_(i,k)=0.
-              ratqs_inter_(i,k)=0
-             enddo
-          enddo
-      
-          if (iflag_ratqs .EQ. 10) then 
-             print*,'avant ratqs_inter'
-            ! interactive ratqs with several sources
-             call ratqs_inter(klon,klev,iflag_ratqs,pdtphys,paprs, &
-                       ratqsbas,wake_deltaq,wake_s,q_seri,qtc_cv, sigt_cv, &
-                       fm_therm,entr_therm,detr_therm,detrain_cv,fm_cv,fqd,fqcomp,sigd, &
-                       ratqs_inter_,sigma_qtherm)
-             ratqss=ratqss+ratqs_inter_
-          else if (iflag_ratqs .EQ. 11) then
-            print*,'avant ratqs_inter'
-            ! interactive ratqs with several sources
-             call ratqs_inter(klon,klev,iflag_ratqs,pdtphys,paprs, &
-                       ratqsbas,wake_deltaq,wake_s,q_seri,qtc_cv, sigt_cv, &
-                       fm_therm,entr_therm,detr_therm,detrain_cv,fm_cv,fqd,fqcomp,sigd, &
-                       ratqs_inter_,sigma_qtherm)
-             ratqss=ratqss+ratqs_inter_
-          else if (iflag_ratqs .EQ. 12) then
-             ! contribution of surface heterogeneities to ratqs
-             call ratqs_hetero(klon,klev,pctsrf,s_pblh,t2m,q2m,t_seri,q_seri,pplay,paprs,ratqs_hetero_)
-             ratqss=ratqss+ratqs_hetero_
-          else if (iflag_ratqs .EQ. 13) then
-             ! contribution of ubgrid orography to ratqs
-             call ratqs_oro(klon,klev,pctsrf,zstd,zqsat,t_seri,pplay,paprs,ratqs_oro_)
-             ratqss=ratqss+ratqs_oro_
-          else if (iflag_ratqs .EQ. 14) then
-             ! effect of subgrid-scale TKE on ratqs (in development)
-             call ratqs_tke(klon,klev,pdtphys,t_seri,q_seri,zqsat,pplay,paprs,omega,tke,tke_dissip,lmix,wprime,ratqs_tke_)     
-             ratqss=ratqss+ratqs_tke_
-          endif
-          
-      
-      endif
-
-
-!  ratqs final
-!  -----------
-
-      if (iflag_cld_th.eq.1 .or.iflag_cld_th.eq.2.or.iflag_cld_th.eq.4) then
-
-! On ajoute une constante au ratqsc*2 pour tenir compte de 
-! fluctuations turbulentes de petite echelle
-
-         do k=1,klev
-            do i=1,klon
-               if ((fm_therm(i,k)>1.e-10)) then
-                  ratqsc(i,k)=sqrt(ratqsc(i,k)**2+0.05**2)
-               endif
-            enddo
-         enddo
-
-!   les ratqs sont une combinaison de ratqss et ratqsc
-       if(prt_level.ge.9) write(lunout,*)'PHYLMD NOUVEAU TAU_RATQS ',tau_ratqs
-
-         if (tau_ratqs>1.e-10) then
-            facteur=exp(-pdtphys/tau_ratqs)
-         else
-            facteur=0.
-         endif
-         ratqs(:,:)=ratqsc(:,:)*(1.-facteur)+ratqs(:,:)*facteur
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! FH 22/09/2009
-! La ligne ci-dessous faisait osciller le modele et donnait une solution
-! assymptotique bidon et d??pendant fortement du pas de temps.
-!        ratqs(:,:)=sqrt(ratqs(:,:)**2+ratqss(:,:)**2)
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-         ratqs(:,:)=max(ratqs(:,:),ratqss(:,:))
-      else if (iflag_cld_th<=6) then
-!   on ne prend que le ratqs stable pour fisrtilp
-         ratqs(:,:)=ratqss(:,:)
-      else
-          zfratqs1=exp(-pdtphys/10800.)
-          zfratqs2=exp(-pdtphys/10800.)
-          do k=1,klev
-             do i=1,klon
-                if (ratqsc(i,k).gt.1.e-10) then
-                   ratqs(i,k)=ratqs(i,k)*zfratqs2+(iflag_cld_th/100.)*ratqsc(i,k)*(1.-zfratqs2)
-                endif
-                ratqs(i,k)=min(ratqs(i,k)*zfratqs1+ratqss(i,k)*(1.-zfratqs1),0.5)
-             enddo
-          enddo
-      endif
-
-
-return
-END SUBROUTINE ratqs_main
-
-END MODULE lmdz_ratqs_main
Index: /LMDZ6/trunk/libf/phylmd/lmdz_ratqs_main.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/lmdz_ratqs_main.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/lmdz_ratqs_main.f90	(revision 5268)
@@ -0,0 +1,281 @@
+MODULE lmdz_ratqs_main
+
+CONTAINS
+
+SUBROUTINE ratqs_main(klon,klev,nbsrf,prt_level,lunout,       &
+           iflag_ratqs,iflag_con,iflag_cld_th,pdtphys, &
+           ratqsbas,ratqshaut,ratqsp0,ratqsdp, &
+           pctsrf,s_pblh,zstd, &
+           tau_ratqs,fact_cldcon,wake_s, wake_deltaq,   &
+           ptconv,ptconvth,clwcon0th, rnebcon0th,       &
+           paprs,pplay,t_seri,q_seri,                   &
+           qtc_cv, sigt_cv,detrain_cv,fm_cv,fqd,fqcomp,sigd,zqsat,             &
+           omega,tke,tke_dissip,lmix,wprime, &
+           t2m,q2m,fm_therm,entr_therm,detr_therm,cell_area,&
+           ratqs,ratqsc,ratqs_inter_,sigma_qtherm)
+
+
+USE lmdz_ratqs_multi,   ONLY: ratqs_inter, ratqs_oro, ratqs_hetero, ratqs_tke
+
+implicit none
+
+!========================================================================
+! Computation of ratqs, the width of the subrid scale water distribution
+! (normalized by the mean value)
+! Various options controled by flags iflag_con and iflag_ratqs
+! F Hourdin 2012/12/06
+!========================================================================
+
+! Declarations
+
+! Input
+integer,intent(in) :: klon,klev,nbsrf,prt_level,lunout
+integer,intent(in) :: iflag_con,iflag_cld_th,iflag_ratqs
+real,intent(in) :: pdtphys,ratqsbas,ratqshaut,fact_cldcon,tau_ratqs
+real,intent(in) :: ratqsp0, ratqsdp
+real, dimension(klon,klev),intent(in) :: omega
+real, dimension(klon,klev+1),intent(in) :: paprs,tke,tke_dissip,lmix,wprime
+real, dimension(klon,klev),intent(in) :: pplay,t_seri,q_seri,zqsat
+real, dimension(klon,klev),intent(in) :: entr_therm,detr_therm,qtc_cv, sigt_cv
+real, dimension(klon,klev) :: detrain_cv,fm_cv,fqd,fqcomp
+real, dimension(klon) :: sigd
+
+real, dimension(klon,klev+1),intent(in) :: fm_therm
+logical, dimension(klon,klev),intent(in) :: ptconv
+real, dimension(klon,klev),intent(in) :: rnebcon0th,clwcon0th
+real, dimension(klon,klev),intent(in) :: wake_deltaq,wake_s
+real, dimension(klon,nbsrf),intent(in) :: t2m,q2m
+real, dimension(klon), intent(in) :: cell_area
+real, dimension(klon,nbsrf),intent(in) :: pctsrf
+real, dimension(klon),intent(in) :: s_pblh
+real, dimension(klon),intent(in) :: zstd
+
+! Output
+real, dimension(klon,klev),intent(inout) :: ratqs,ratqsc,ratqs_inter_,sigma_qtherm
+
+logical, dimension(klon,klev),intent(inout) :: ptconvth
+
+! local
+integer i,k
+real, dimension(klon,klev) :: ratqss
+real facteur,zfratqs1,zfratqs2
+real, dimension(klon,klev) :: ratqs_hetero_,ratqs_oro_,ratqs_tke_
+real resol,resolmax,fact
+
+!-------------------------------------------------------------------------
+!  Caclul des ratqs
+!-------------------------------------------------------------------------
+
+!      print*,'calcul des ratqs'
+!   ratqs convectifs a l'ancienne en fonction de q(z=0)-q / q
+!   ----------------
+!   on ecrase le tableau ratqsc calcule par clouds_gno
+      if (iflag_cld_th.eq.1) then
+         do k=1,klev
+         do i=1,klon
+            if(ptconv(i,k)) then
+              ratqsc(i,k)=ratqsbas &
+              +fact_cldcon*(q_seri(i,1)-q_seri(i,k))/q_seri(i,k)
+            else
+               ratqsc(i,k)=0.
+            endif
+         enddo
+         enddo
+
+!-----------------------------------------------------------------------
+!  par nversion de la fonction log normale
+!-----------------------------------------------------------------------
+      else if (iflag_cld_th.eq.4) then
+         ptconvth(:,:)=.false.
+         ratqsc(:,:)=0.
+         if(prt_level.ge.9) print*,'avant clouds_gno thermique'
+         call clouds_gno &
+         (klon,klev,q_seri,zqsat,clwcon0th,ptconvth,ratqsc,rnebcon0th)
+         if(prt_level.ge.9) print*,' CLOUDS_GNO OK'
+       
+       endif
+
+!   ratqs stables
+!   -------------
+
+      if (iflag_ratqs.eq.0) then
+
+! Le cas iflag_ratqs=0 correspond a la version IPCC 2005 du modele.
+         do k=1,klev
+            do i=1, klon
+               ratqss(i,k)=ratqsbas+(ratqshaut-ratqsbas)* &
+               min((paprs(i,1)-pplay(i,k))/(paprs(i,1)-30000.),1.) 
+            enddo 
+         enddo
+
+! Pour iflag_ratqs=1 ou 2, le ratqs est constant au dessus de 
+! 300 hPa (ratqshaut), varie lineariement en fonction de la pression
+! entre 600 et 300 hPa et est soit constant (ratqsbas) pour iflag_ratqs=1
+! soit lineaire (entre 0 a la surface et ratqsbas) pour iflag_ratqs=2
+! Il s'agit de differents tests dans la phase de reglage du modele
+! avec thermiques.
+
+      else if (iflag_ratqs.eq.1) then
+
+         do k=1,klev
+            do i=1, klon
+               if (pplay(i,k).ge.60000.) then
+                  ratqss(i,k)=ratqsbas
+               else if ((pplay(i,k).ge.30000.).and.(pplay(i,k).lt.60000.)) then
+                  ratqss(i,k)=ratqsbas+(ratqshaut-ratqsbas)*(60000.-pplay(i,k))/(60000.-30000.)
+               else
+                  ratqss(i,k)=ratqshaut
+               endif
+            enddo
+         enddo
+
+      else if (iflag_ratqs.eq.2) then
+
+         do k=1,klev
+            do i=1, klon
+               if (pplay(i,k).ge.60000.) then
+                  ratqss(i,k)=ratqsbas*(paprs(i,1)-pplay(i,k))/(paprs(i,1)-60000.)
+               else if ((pplay(i,k).ge.30000.).and.(pplay(i,k).lt.60000.)) then
+                    ratqss(i,k)=ratqsbas+(ratqshaut-ratqsbas)*(60000.-pplay(i,k))/(60000.-30000.)
+               else
+                    ratqss(i,k)=ratqshaut
+               endif
+            enddo
+         enddo
+
+      else if (iflag_ratqs==3) then
+         do k=1,klev
+           ratqss(:,k)=ratqsbas+(ratqshaut-ratqsbas) &
+           *min( ((paprs(:,1)-pplay(:,k))/70000.)**2 , 1. )
+         enddo
+
+      else if (iflag_ratqs==4) then 
+         do k=1,klev
+           ratqss(:,k)=ratqsbas+0.5*(ratqshaut-ratqsbas) &
+!          *( tanh( (50000.-pplay(:,k))/20000.) + 1.)
+           *( tanh( (ratqsp0-pplay(:,k))/ratqsdp) + 1.)
+         enddo
+
+
+      else if (iflag_ratqs==5) then
+! Dependency of ratqs on model resolution
+! Audran, Meryl, Lea, Gwendal and Etienne
+! April 2023 
+        resolmax=sqrt(maxval(cell_area))
+         do k=1,klev
+            do i=1,klon
+              resol=sqrt(cell_area(i))
+              fact=sqrt(resol/resolmax)
+              ratqss(i,k)=ratqsbas*fact+0.5*(ratqshaut-ratqsbas)*fact &
+              *( tanh( (ratqsp0-pplay(i,k))/ratqsdp) + 1.)
+           enddo
+         enddo
+
+
+       else if (iflag_ratqs .GT. 9) then
+ 
+       ! interactive ratqs calculations that depend on cold pools, orography, surface heterogeneity and small-scale turbulence
+       ! This should help getting a more realistic ratqs in the low and mid troposphere
+       ! We however need a "background" ratqs to account for subgrid distribution of qt (or qt/qs)
+       ! in the high troposphere
+       
+       ! background ratqs and initialisations
+          do k=1,klev
+             do i=1,klon
+              ratqss(i,k)=ratqsbas+0.5*(ratqshaut-ratqsbas) &
+              *( tanh( (ratqsp0-pplay(i,k))/ratqsdp) + 1.)
+              ratqss(i,k)=max(ratqss(i,k),0.0)
+              ratqs_hetero_(i,k)=0.
+              ratqs_oro_(i,k)=0.
+              ratqs_tke_(i,k)=0.
+              ratqs_inter_(i,k)=0
+             enddo
+          enddo
+      
+          if (iflag_ratqs .EQ. 10) then 
+             print*,'avant ratqs_inter'
+            ! interactive ratqs with several sources
+             call ratqs_inter(klon,klev,iflag_ratqs,pdtphys,paprs, &
+                       ratqsbas,wake_deltaq,wake_s,q_seri,qtc_cv, sigt_cv, &
+                       fm_therm,entr_therm,detr_therm,detrain_cv,fm_cv,fqd,fqcomp,sigd, &
+                       ratqs_inter_,sigma_qtherm)
+             ratqss=ratqss+ratqs_inter_
+          else if (iflag_ratqs .EQ. 11) then
+            print*,'avant ratqs_inter'
+            ! interactive ratqs with several sources
+             call ratqs_inter(klon,klev,iflag_ratqs,pdtphys,paprs, &
+                       ratqsbas,wake_deltaq,wake_s,q_seri,qtc_cv, sigt_cv, &
+                       fm_therm,entr_therm,detr_therm,detrain_cv,fm_cv,fqd,fqcomp,sigd, &
+                       ratqs_inter_,sigma_qtherm)
+             ratqss=ratqss+ratqs_inter_
+          else if (iflag_ratqs .EQ. 12) then
+             ! contribution of surface heterogeneities to ratqs
+             call ratqs_hetero(klon,klev,pctsrf,s_pblh,t2m,q2m,t_seri,q_seri,pplay,paprs,ratqs_hetero_)
+             ratqss=ratqss+ratqs_hetero_
+          else if (iflag_ratqs .EQ. 13) then
+             ! contribution of ubgrid orography to ratqs
+             call ratqs_oro(klon,klev,pctsrf,zstd,zqsat,t_seri,pplay,paprs,ratqs_oro_)
+             ratqss=ratqss+ratqs_oro_
+          else if (iflag_ratqs .EQ. 14) then
+             ! effect of subgrid-scale TKE on ratqs (in development)
+             call ratqs_tke(klon,klev,pdtphys,t_seri,q_seri,zqsat,pplay,paprs,omega,tke,tke_dissip,lmix,wprime,ratqs_tke_)     
+             ratqss=ratqss+ratqs_tke_
+          endif
+          
+      
+      endif
+
+
+!  ratqs final
+!  -----------
+
+      if (iflag_cld_th.eq.1 .or.iflag_cld_th.eq.2.or.iflag_cld_th.eq.4) then
+
+! On ajoute une constante au ratqsc*2 pour tenir compte de 
+! fluctuations turbulentes de petite echelle
+
+         do k=1,klev
+            do i=1,klon
+               if ((fm_therm(i,k)>1.e-10)) then
+                  ratqsc(i,k)=sqrt(ratqsc(i,k)**2+0.05**2)
+               endif
+            enddo
+         enddo
+
+!   les ratqs sont une combinaison de ratqss et ratqsc
+       if(prt_level.ge.9) write(lunout,*)'PHYLMD NOUVEAU TAU_RATQS ',tau_ratqs
+
+         if (tau_ratqs>1.e-10) then
+            facteur=exp(-pdtphys/tau_ratqs)
+         else
+            facteur=0.
+         endif
+         ratqs(:,:)=ratqsc(:,:)*(1.-facteur)+ratqs(:,:)*facteur
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! FH 22/09/2009
+! La ligne ci-dessous faisait osciller le modele et donnait une solution
+! assymptotique bidon et d??pendant fortement du pas de temps.
+!        ratqs(:,:)=sqrt(ratqs(:,:)**2+ratqss(:,:)**2)
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+         ratqs(:,:)=max(ratqs(:,:),ratqss(:,:))
+      else if (iflag_cld_th<=6) then
+!   on ne prend que le ratqs stable pour fisrtilp
+         ratqs(:,:)=ratqss(:,:)
+      else
+          zfratqs1=exp(-pdtphys/10800.)
+          zfratqs2=exp(-pdtphys/10800.)
+          do k=1,klev
+             do i=1,klon
+                if (ratqsc(i,k).gt.1.e-10) then
+                   ratqs(i,k)=ratqs(i,k)*zfratqs2+(iflag_cld_th/100.)*ratqsc(i,k)*(1.-zfratqs2)
+                endif
+                ratqs(i,k)=min(ratqs(i,k)*zfratqs1+ratqss(i,k)*(1.-zfratqs1),0.5)
+             enddo
+          enddo
+      endif
+
+
+return
+END SUBROUTINE ratqs_main
+
+END MODULE lmdz_ratqs_main
Index: DZ6/trunk/libf/phylmd/lmdz_ratqs_multi.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/lmdz_ratqs_multi.F90	(revision 5267)
+++ 	(revision )
@@ -1,451 +1,0 @@
-MODULE lmdz_ratqs_multi
-
-!=============================================
-! A FAIRE :
-! Traiter le probleme de USE lmdz_lscp_tools, ONLY: CALC_QSAT_ECMWF
-!=============================================
-
-!=============================================
-! module containing subroutines that take 
-! into account the effect of convection, orography,
-! surface heterogeneities and subgrid-scale
-! turbulence on ratqs, i.e. on the width of the
-! total water subgrid distribution.
-!=============================================
-
-IMPLICIT NONE
-
-! Include
-!=============================================
-    INCLUDE "YOETHF.h"
-
-
-      CONTAINS
-
-
-!========================================================================    
-SUBROUTINE ratqs_inter(klon,klev,iflag_ratqs,pdtphys,paprs, &
-           ratqsbas, wake_deltaq, wake_s, q_seri,qtc_cv, sigt_cv,     &
-           fm_therm,entr_therm,detr_therm,detrain_cv,fm_cv,fqd,fqcomp,sigd, &
-           ratqs_inter_,sigma_qtherm)
-
-USE lmdz_ratqs_ini, ONLY : a_ratqs_cv,tau_var,fac_tau,tau_cumul,a_ratqs_wake, dqimpl
-USE lmdz_ratqs_ini, ONLY : RG
-USE lmdz_ratqs_ini, ONLY : povariance, var_conv
-USE lmdz_thermcell_dq,  ONLY : thermcell_dq
-
-implicit none
-
-!========================================================================
-! L. d'Alen??on, 25/02/2021
-! Cette subroutine calcule une valeur de ratqsbas interactive  
-! Elle est appel??e par la subroutine ratqs lorsque iflag_ratqs = 11. 
-!========================================================================
-
-! Declarations
-! Input
-integer,intent(in) :: klon,klev,iflag_ratqs
-real,intent(in) :: pdtphys,ratqsbas
-real, dimension(klon,klev+1),intent(in) :: paprs
-real, dimension(klon,klev),intent(in) :: wake_deltaq, q_seri,qtc_cv, sigt_cv
-real, dimension(klon),intent(in) :: wake_s
-real, dimension(klon,klev+1),intent(in) :: fm_therm
-real, dimension(klon,klev),intent(in) :: entr_therm,detr_therm,detrain_cv,fm_cv,fqd,fqcomp
-real, dimension(klon),intent(in) :: sigd
-
-! Output
-real, dimension(klon,klev),intent(inout) :: ratqs_inter_
-
-! local
-LOGICAL :: klein = .false.
-LOGICAL :: klein_conv = .true.
-REAL :: taup0 = 70000
-REAL :: taudp = 500
-integer :: lev_out=10
-REAL, DIMENSION (klon,klev) :: zmasse,entr0,detr0,detraincv,dqp,detrain_p,q0,qd0,tau_diss
-REAL, DIMENSION (klon,klev+1) :: fm0
-integer i,k
-real, dimension(klon,klev) :: wake_dq
-
-real, dimension(klon) :: max_sigd, max_dqconv,max_sigt
-real, dimension(klon,klev) :: zoa,zocarrea,pdocarreadj,pocarre,po,pdoadj,varq_therm
-real, dimension(klon,klev) :: var_moy, var_var, var_desc_th,var_det_conv,var_desc_prec,var_desc_conv,sigma_qtherm
-
-lev_out=0.
-
-print*,'ratqs_inter'
-
-!-----------------------------------------------------------------------
-!   Calcul des masses
-!-----------------------------------------------------------------------
-
-      do k=1,klev
-         zmasse(:,k)=(paprs(:,k)-paprs(:,k+1))/RG
-      enddo
-!-------------------------------------------------------------------------
-!  Caclul du terme de d??trainement de la variance pour les thermiques
-!-------------------------------------------------------------------------
-
-! initialisations 
-
-
-      do k=1,klev
-         do i=1,klon
-            tau_diss(i,k)=tau_var +0.5*fac_tau*tau_var*(tanh((taup0-paprs(i,k))/taudp) + 1.)
-         enddo
-      enddo
-       
-                    
-      
-      entr0(:,:) = entr_therm(:,:) 
-      fm0(:,:) = fm_therm(:,:)  
-      detr0(:,:) = detr_therm(:,:) 
-
-! calcul du carr?? de l'humidit?? sp??cifique et circulation dans les thermiques
-      po(:,:) = q_seri(:,:)
-      call thermcell_dq(klon,klev,dqimpl,pdtphys,fm0,entr0,zmasse,  &
-     &                   po,pdoadj,zoa,lev_out)
-      do k=1,klev
-         do i=1,klon
-            pocarre(i,k)=po(i,k)*po(i,k) + povariance(i,k)
-         enddo
-      enddo
-      call thermcell_dq(klon,klev,dqimpl,pdtphys,fm0,entr0,zmasse,  &
-      &                   pocarre,pdocarreadj,zocarrea,lev_out) 
-
-
-! variance de l'humidit?? sp??cifique totale dans les thermiques     
-      do k=1,klev
-         do i=1,klon      
-            varq_therm(i,k)=zocarrea(i,k)-zoa(i,k)*zoa(i,k)
-         enddo
-      enddo
-
-! calcul des termes sources de la variance avec thermiques et convection profonde (voir Klein 2005 par exemple)
-      do k=1,klev
-         do i=1,klon      
-            var_moy(i,k) = detr0(i,k)*((zoa(i,k)-po(i,k))**2)/zmasse(i,k)
-            var_var(i,k) = detr0(i,k)*(varq_therm(i,k)-povariance(i,k))/zmasse(i,k)
-            var_det_conv(i,k) =  a_ratqs_cv*(detrain_cv(i,k)/zmasse(i,k))
-            if (sigd(i).ne.0) then
-               var_desc_prec(i,k) = sigd(i)*(1-sigd(i))*(fqd(i,k)*tau_cumul/sigd(i))**2/tau_cumul
-            else
-               var_desc_prec(i,k) = 0
-            endif
-         enddo
-      enddo
-
-      do k=1,klev-1
-         do i=1,klon      
-            var_desc_th(i,k) = fm0(i,k+1)*povariance(i,k+1)/zmasse(i,k) -  &
-               fm0(i,k)*povariance(i,k)/zmasse(i,k)
-            var_desc_conv(i,k) = ((povariance(i,k+1)-povariance(i,k))*(fm_cv(i,k)/zmasse(i,k)))
-         enddo
-      enddo
-      var_desc_th(:,klev) = var_desc_th(:,klev-1)
-      var_desc_conv(:,klev) = var_desc_conv(:,klev-1)
-      
-      if (klein) then
-         do k=1,klev-1
-            do i=1,klon
-              qd0(:,:) = 0.0
-              if (sigd(i).ne.0) then
-                qd0(i,k) = fqd(i,k)*tau_cumul/sigd(i) 
-              endif
-            enddo
-         enddo
-         do k=1,klev-1
-            do i=1,klon      
-               povariance(i,k)= (var_moy(i,k) + var_var(i,k) + var_desc_th(i,k) +  &
-               var_det_conv(i,k) +  var_desc_prec(i,k)  &   
-                + var_desc_conv(i,k))*pdtphys + povariance(i,k)
-               povariance(i,k)= povariance(i,k)*exp(-pdtphys/tau_diss(i,k))
-            enddo
-         enddo
-         povariance(:,klev) = povariance(:,klev-1)
-         
-      else ! calcul direct     
-         qd0(:,:) = 0.0
-         q0(:,:) = 0.0
-         do k=1,klev-1
-            do i=1,klon
-               if (sigd(i).ne.0) then    ! termes de variance par accumulation
-                 qd0(i,k) = fqd(i,k)*tau_cumul/sigd(i) 
-               endif
-               if (sigt_cv(i,k).ne.0) then
-                 q0(i,k) = fqcomp(i,k)*tau_cumul/sigt_cv(i,k)
-               endif
-            enddo
-         enddo
-         do k=1,klev-1
-            do i=1,klon      
-               povariance(i,k)= (pdocarreadj(i,k)-2.*po(i,k)*pdoadj(i,k) +  &
-               a_ratqs_cv*(sigt_cv(i,k)*(1-sigt_cv(i,k))*q0(i,k)**2/tau_cumul + var_desc_prec(i,k) +  &
-               var_desc_conv(i,k)))*pdtphys + povariance(i,k)
-               povariance(i,k)=povariance(i,k)*exp(-pdtphys/tau_diss(i,k))
-            enddo
-         enddo
-         povariance(:,klev) = povariance(:,klev-1)
-!         fqd(:,:)=sigt_cv(:,:)*(1-sigt_cv(:,:))*q0(:,:)**2/tau_cumul 
-      endif
-
-!-------------------------------------------------------------------------
-!  Caclul du ratqs_inter_
-!-------------------------------------------------------------------------
-
-      do k=1,klev
-        do i=1,klon
-           if(q_seri(i,k).ge.1E-7) then
-               ratqs_inter_(i,k) = abs(povariance(i,k))**0.5/q_seri(i,k)    
-               sigma_qtherm(i,k) = abs(varq_therm(i,k))**0.5     ! sigma dans les thermiques
-           else 
-               ratqs_inter_(i,k) = 0.  
-               sigma_qtherm(i,k) = 0.
-           endif
-        enddo
-      enddo
-      
-return
-end             
-
-!------------------------------------------------------------------
-SUBROUTINE ratqs_oro(klon,klev,pctsrf,zstd,qsat,temp,pplay,paprs,ratqs_oro_)
-
-! Etienne Vignon, November 2021: effect of subgrid orography on ratqs
-
-USE lmdz_ratqs_ini, ONLY : RG,RV,RD,RLSTT,RLVTT,RTT,nbsrf,is_lic,is_ter
-
-IMPLICIT NONE
-
-! Declarations
-!--------------
-
-! INPUTS
-
-INTEGER, INTENT(IN) :: klon                       ! number of horizontal grid points
-INTEGER, INTENT(IN) :: klev                       ! number of vertical layers
-REAL, DIMENSION(klon,nbsrf) :: pctsrf
-REAL, DIMENSION(klon,klev), INTENT(IN) :: qsat    ! saturation specific humidity [kg/kg]
-REAL, DIMENSION(klon), INTENT(IN) :: zstd    ! sub grid orography standard deviation
-REAL, DIMENSION(klon,klev), INTENT(IN) :: temp    ! air temperature [K]
-REAL, DIMENSION(klon,klev), INTENT(IN) :: pplay    ! air pressure, layer's center [Pa]
-REAL, DIMENSION(klon,klev+1), INTENT(IN) :: paprs    ! air pressure, lower inteface [Pa]
-
-! OUTPUTS
-
-REAL, DIMENSION(klon,klev), INTENT(out) :: ratqs_oro_ ! ratqs profile due to subgrid orography
-
-
-! LOCAL
-
-INTEGER :: i,k
-REAL, DIMENSION(klon) :: orogradT,xsi0
-REAL, DIMENSION (klon,klev) :: zlay
-REAL :: Lvs, temp0
-
-
-! Calculation of the near-surface temperature gradient along the topography
-!--------------------------------------------------------------------------
-
-! at the moment, we fix it at a constant value (moist adiab. lapse rate)
-
-orogradT(:)=-6.5/1000. ! K/m
-
-! Calculation of near-surface surface ratqs
-!-------------------------------------------
-
-DO i=1,klon
-    temp0=temp(i,1)
-    IF (temp0 .LT. RTT) THEN
-        Lvs=RLSTT
-    ELSE
-        Lvs=RLVTT
-    ENDIF
-    xsi0(i)=zstd(i)*ABS(orogradT(i))*Lvs/temp0/temp0/RV
-    ratqs_oro_(i,1)=xsi0(i)
-END DO
-
-! Vertical profile of ratqs assuming an exponential decrease with height
-!------------------------------------------------------------------------
-     
-! calculation of geop. height AGL        
-zlay(:,1)= RD*temp(:,1)/(0.5*(paprs(:,1)+pplay(:,1))) &
-           *(paprs(:,1)-pplay(:,1))/RG
-
-DO k=2,klev
-   DO i = 1, klon
-      zlay(i,k)= zlay(i,k-1)+RD*0.5*(temp(i,k-1)+temp(i,k)) &
-               /paprs(i,k)*(pplay(i,k-1)-pplay(i,k))/RG
-               
-      ratqs_oro_(i,k)=MAX(0.0,pctsrf(i,is_ter)*xsi0(i)*exp(-zlay(i,k)/MAX(zstd(i),1.)))   
-    END DO
-END DO
-
-
-
-
-END SUBROUTINE ratqs_oro
-
-!=============================================
-
-SUBROUTINE ratqs_hetero(klon,klev,pctsrf,s_pblh,t2m,q2m,temp,q,pplay,paprs,ratqs_hetero_)
-
-! Etienne Vignon, November 2021
-! Effect of subgrid surface heterogeneities on ratqs
-
-USE lmdz_lscp_tools, ONLY: CALC_QSAT_ECMWF
-
-USE lmdz_ratqs_ini, ONLY : RG,RD,RTT,nbsrf
-
-IMPLICIT NONE
-
-! INPUTS
-
-
-INTEGER, INTENT(IN) :: klon                       ! number of horizontal grid points
-INTEGER, INTENT(IN) :: klev                       ! number of vertical layers
-REAL, DIMENSION(klon)                   :: s_pblh ! height of the planetary boundary layer(HPBL)
-REAL, DIMENSION(klon,nbsrf)             :: pctsrf ! Fractional cover of subsurfaces
-REAL, DIMENSION(klon,nbsrf), INTENT(IN) :: t2m    ! 2m temperature for each tile [K]
-REAL, DIMENSION(klon,nbsrf), INTENT(IN) :: q2m    ! 2m specific humidity for each tile [kg/kg]
-REAL, DIMENSION(klon,klev), INTENT(IN) :: temp    ! air temperature [K]
-REAL, DIMENSION(klon,klev), INTENT(IN) :: q       ! specific humidity [kg/kg]
-REAL, DIMENSION(klon,klev), INTENT(IN) :: pplay   ! air pressure, layer's center [Pa]
-REAL, DIMENSION(klon,klev+1), INTENT(IN) :: paprs ! air pressure, lower inteface [Pa]
-
-! OUTPUTS
-
-REAL, DIMENSION(klon,klev), INTENT(out) :: ratqs_hetero_ ! ratsq profile due to surface heterogeneities
-
-
-INTEGER :: i,k,nsrf
-REAL, DIMENSION(klon) :: xsi0, ratiom, qsat2m, dqsatdT
-REAL, DIMENSION (klon,klev) :: zlay
-
-
-
-! Calculation of near-surface surface ratqs
-!-------------------------------------------
-
-    
-    ratiom(:)=0.
-    xsi0(:)=0.
-    
-    DO nsrf=1,nbsrf
-    CALL CALC_QSAT_ECMWF(klon,t2m(:,nsrf),q2m(:,nsrf),paprs(:,1),RTT,0,.false.,qsat2m,dqsatdT)
-    ratiom(:)=ratiom(:)+pctsrf(:,nsrf)*(q2m(:,nsrf)/qsat2m(:))
-    xsi0(:)=xsi0(:)+pctsrf(:,nsrf)*((q2m(:,nsrf)/qsat2m(:)-ratiom(:))**2)
-    END DO
-    
-    xsi0(:)=sqrt(xsi0(:))/(ratiom(:)+1E-6)
-
-
-
-! Vertical profile of ratqs assuming an exponential decrease with height
-!------------------------------------------------------------------------
-        
-! calculation of geop. height AGL
-
-zlay(:,1)= RD*temp(:,1)/(0.5*(paprs(:,1)+pplay(:,1))) &
-           *(paprs(:,1)-pplay(:,1))/RG
-ratqs_hetero_(:,1)=xsi0(:)
-
-DO k=2,klev
-   DO i = 1, klon
-      zlay(i,k)= zlay(i,k-1)+RD*0.5*(temp(i,k-1)+temp(i,k)) &
-               /paprs(i,k)*(pplay(i,k-1)-pplay(i,k))/RG
-               
-      ratqs_hetero_(i,k)=MAX(xsi0(i)*exp(-zlay(i,k)/(s_pblh(i)+1.0)),0.0)   
-    END DO
-END DO
-
-END SUBROUTINE ratqs_hetero
-
-!=============================================
-
-SUBROUTINE ratqs_tke(klon,klev,pdtphys,temp,q,qsat,pplay,paprs,omega,tke,tke_dissip,lmix,wprime,ratqs_tke_)
-
-! References:
-!
-! Etienne Vignon: effect of subgrid turbulence on ratqs
-!
-! Field, P.R., Hill, A., Furtado, K., Korolev, A., 2014b. Mixed-phase clouds in a turbulent environment. Part
-! 2: analytic treatment. Q. J. R. Meteorol. Soc. 21, 2651???2663. https://doi.org/10.1002/qj.2175.
-! 
-! Furtado, K., Field, P.R., Boutle, I.A., Morcrette, C.R., Wilkinson, J., 2016. A physically-based, subgrid
-! parametrization for the production and maintenance of mixed-phase clouds in a general circulation
-! model. J. Atmos. Sci. 73, 279???291. https://doi.org/10.1175/JAS-D-15-0021.
-
-USE lmdz_ratqs_ini, ONLY : RG,RV,RD,RCPD,RLSTT,RLVTT,RTT
-
-IMPLICIT NONE
-
-! INPUTS
-
-INTEGER, INTENT(IN) :: klon                             ! number of horizontal grid points
-INTEGER, INTENT(IN) :: klev                             ! number of vertical layers
-REAL, INTENT(IN) :: pdtphys                             ! physics time step [s]
-REAL, DIMENSION(klon,klev), INTENT(IN) :: temp          ! air temperature [K]
-REAL, DIMENSION(klon,klev), INTENT(IN) :: q             ! specific humidity [kg/kg]
-REAL, DIMENSION(klon,klev), INTENT(IN) :: qsat          ! saturation specific humidity [kg/kg]
-REAL, DIMENSION(klon,klev), INTENT(IN) :: pplay         ! air pressure, layer's center [Pa]
-REAL, DIMENSION(klon,klev+1), INTENT(IN) :: paprs       ! air pressure, lower inteface [Pa]
-REAL, DIMENSION(klon,klev), INTENT(IN) :: omega       ! air pressure, lower inteface [Pa]
-REAL, DIMENSION(klon,klev+1), INTENT(IN) :: tke         ! Turbulent Kinetic Energy [m2/s2]
-REAL, DIMENSION(klon,klev+1), INTENT(IN) :: tke_dissip  ! Turbulent Kinetic Energy Dissipation rate [m2/s3]
-REAL, DIMENSION(klon,klev+1), INTENT(IN) :: lmix  ! Turbulent mixing length
-REAL, DIMENSION(klon,klev+1), INTENT(IN) :: wprime      ! Turbulent vertical velocity scale [m/s]
-
-! OUTPUTS
-
-REAL, DIMENSION(klon,klev), INTENT(out) :: ratqs_tke_  ! ratsq profile due to subgrid TKE
-
-! LOCAL
-INTEGER :: i, k
-REAL :: AA, DD, NW, AAprime, VARLOG,rho,Lvs,taue,lhomo,dissmin,maxvarlog
-REAL, DIMENSION(klon,klev) :: sigmaw,w
-REAL, PARAMETER :: C0=10.0
-REAL, PARAMETER :: lmin=0.001
-REAL, PARAMETER :: ratqsmin=1E-6
-REAL, PARAMETER :: ratqsmax=0.5
-
-
-! Calculation of large scale and turbulent vertical velocities
-!---------------------------------------------------------------
-
-DO k=1,klev
-    DO i=1,klon
-        rho=pplay(i,k)/temp(i,k)/RD
-        w(i,k)=-rho*RG*omega(i,k)
-        sigmaw(i,k)=0.5*(wprime(i,k+1)+wprime(i,k)) ! turbulent vertical velocity at the middle of model layers. 
-    END DO
-END DO
-
-! Calculation of ratqs
-!---------------------------------------------------------------
-ratqs_tke_(:,1)=ratqsmin ! set to a very low value to avoid division by 0 in order parts
-                        ! of the code
-DO k=2,klev ! we start from second model level since TKE is not defined at k=1
-    DO i=1,klon
-
-       IF (temp(i,k) .LT. RTT) THEN
-           Lvs=RLSTT
-       ELSE
-           Lvs=RLVTT
-       ENDIF
-       dissmin=0.01*(0.5*(tke(i,k)+tke(i,k+1))/pdtphys)
-       maxvarlog=LOG(1.0+ratqsmax**2)! to prevent ratqs from exceeding an arbitrary threshold value 
-       AA=RG*(Lvs/(RCPD*temp(i,k)*temp(i,k)*RV) - 1./(RD*temp(i,k)))
-       lhomo=MAX(0.5*(lmix(i,k)+lmix(i,k+1)),lmin)
-       taue=(lhomo*lhomo/MAX(0.5*(tke_dissip(i,k)+tke_dissip(i,k+1)),dissmin))**(1./3) ! Fields et al. 2014
-       DD=1.0/taue
-       NW=(sigmaw(i,k)**2)*SQRT(2./(C0*MAX(0.5*(tke_dissip(i,k)+tke_dissip(i,k+1)),dissmin)))
-       AAprime=AA*NW
-       VARLOG=AAprime/2./DD
-       VARLOG=MIN(VARLOG,maxvarlog)
-       ratqs_tke_(i,k)=SQRT(MAX(EXP(VARLOG)-1.0,ratqsmin))
-       END DO
-END DO
-END SUBROUTINE ratqs_tke
-
-END MODULE lmdz_ratqs_multi
Index: /LMDZ6/trunk/libf/phylmd/lmdz_ratqs_multi.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/lmdz_ratqs_multi.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/lmdz_ratqs_multi.f90	(revision 5268)
@@ -0,0 +1,451 @@
+MODULE lmdz_ratqs_multi
+
+!=============================================
+! A FAIRE :
+! Traiter le probleme de USE lmdz_lscp_tools, ONLY: CALC_QSAT_ECMWF
+!=============================================
+
+!=============================================
+! module containing subroutines that take 
+! into account the effect of convection, orography,
+! surface heterogeneities and subgrid-scale
+! turbulence on ratqs, i.e. on the width of the
+! total water subgrid distribution.
+!=============================================
+
+IMPLICIT NONE
+
+! Include
+!=============================================
+    INCLUDE "YOETHF.h"
+
+
+      CONTAINS
+
+
+!========================================================================    
+SUBROUTINE ratqs_inter(klon,klev,iflag_ratqs,pdtphys,paprs, &
+           ratqsbas, wake_deltaq, wake_s, q_seri,qtc_cv, sigt_cv,     &
+           fm_therm,entr_therm,detr_therm,detrain_cv,fm_cv,fqd,fqcomp,sigd, &
+           ratqs_inter_,sigma_qtherm)
+
+USE lmdz_ratqs_ini, ONLY : a_ratqs_cv,tau_var,fac_tau,tau_cumul,a_ratqs_wake, dqimpl
+USE lmdz_ratqs_ini, ONLY : RG
+USE lmdz_ratqs_ini, ONLY : povariance, var_conv
+USE lmdz_thermcell_dq,  ONLY : thermcell_dq
+
+implicit none
+
+!========================================================================
+! L. d'Alen??on, 25/02/2021
+! Cette subroutine calcule une valeur de ratqsbas interactive  
+! Elle est appel??e par la subroutine ratqs lorsque iflag_ratqs = 11. 
+!========================================================================
+
+! Declarations
+! Input
+integer,intent(in) :: klon,klev,iflag_ratqs
+real,intent(in) :: pdtphys,ratqsbas
+real, dimension(klon,klev+1),intent(in) :: paprs
+real, dimension(klon,klev),intent(in) :: wake_deltaq, q_seri,qtc_cv, sigt_cv
+real, dimension(klon),intent(in) :: wake_s
+real, dimension(klon,klev+1),intent(in) :: fm_therm
+real, dimension(klon,klev),intent(in) :: entr_therm,detr_therm,detrain_cv,fm_cv,fqd,fqcomp
+real, dimension(klon),intent(in) :: sigd
+
+! Output
+real, dimension(klon,klev),intent(inout) :: ratqs_inter_
+
+! local
+LOGICAL :: klein = .false.
+LOGICAL :: klein_conv = .true.
+REAL :: taup0 = 70000
+REAL :: taudp = 500
+integer :: lev_out=10
+REAL, DIMENSION (klon,klev) :: zmasse,entr0,detr0,detraincv,dqp,detrain_p,q0,qd0,tau_diss
+REAL, DIMENSION (klon,klev+1) :: fm0
+integer i,k
+real, dimension(klon,klev) :: wake_dq
+
+real, dimension(klon) :: max_sigd, max_dqconv,max_sigt
+real, dimension(klon,klev) :: zoa,zocarrea,pdocarreadj,pocarre,po,pdoadj,varq_therm
+real, dimension(klon,klev) :: var_moy, var_var, var_desc_th,var_det_conv,var_desc_prec,var_desc_conv,sigma_qtherm
+
+lev_out=0.
+
+print*,'ratqs_inter'
+
+!-----------------------------------------------------------------------
+!   Calcul des masses
+!-----------------------------------------------------------------------
+
+      do k=1,klev
+         zmasse(:,k)=(paprs(:,k)-paprs(:,k+1))/RG
+      enddo
+!-------------------------------------------------------------------------
+!  Caclul du terme de d??trainement de la variance pour les thermiques
+!-------------------------------------------------------------------------
+
+! initialisations 
+
+
+      do k=1,klev
+         do i=1,klon
+            tau_diss(i,k)=tau_var +0.5*fac_tau*tau_var*(tanh((taup0-paprs(i,k))/taudp) + 1.)
+         enddo
+      enddo
+       
+                    
+      
+      entr0(:,:) = entr_therm(:,:) 
+      fm0(:,:) = fm_therm(:,:)  
+      detr0(:,:) = detr_therm(:,:) 
+
+! calcul du carr?? de l'humidit?? sp??cifique et circulation dans les thermiques
+      po(:,:) = q_seri(:,:)
+      call thermcell_dq(klon,klev,dqimpl,pdtphys,fm0,entr0,zmasse,  &
+     &                   po,pdoadj,zoa,lev_out)
+      do k=1,klev
+         do i=1,klon
+            pocarre(i,k)=po(i,k)*po(i,k) + povariance(i,k)
+         enddo
+      enddo
+      call thermcell_dq(klon,klev,dqimpl,pdtphys,fm0,entr0,zmasse,  &
+      &                   pocarre,pdocarreadj,zocarrea,lev_out) 
+
+
+! variance de l'humidit?? sp??cifique totale dans les thermiques     
+      do k=1,klev
+         do i=1,klon      
+            varq_therm(i,k)=zocarrea(i,k)-zoa(i,k)*zoa(i,k)
+         enddo
+      enddo
+
+! calcul des termes sources de la variance avec thermiques et convection profonde (voir Klein 2005 par exemple)
+      do k=1,klev
+         do i=1,klon      
+            var_moy(i,k) = detr0(i,k)*((zoa(i,k)-po(i,k))**2)/zmasse(i,k)
+            var_var(i,k) = detr0(i,k)*(varq_therm(i,k)-povariance(i,k))/zmasse(i,k)
+            var_det_conv(i,k) =  a_ratqs_cv*(detrain_cv(i,k)/zmasse(i,k))
+            if (sigd(i).ne.0) then
+               var_desc_prec(i,k) = sigd(i)*(1-sigd(i))*(fqd(i,k)*tau_cumul/sigd(i))**2/tau_cumul
+            else
+               var_desc_prec(i,k) = 0
+            endif
+         enddo
+      enddo
+
+      do k=1,klev-1
+         do i=1,klon      
+            var_desc_th(i,k) = fm0(i,k+1)*povariance(i,k+1)/zmasse(i,k) -  &
+               fm0(i,k)*povariance(i,k)/zmasse(i,k)
+            var_desc_conv(i,k) = ((povariance(i,k+1)-povariance(i,k))*(fm_cv(i,k)/zmasse(i,k)))
+         enddo
+      enddo
+      var_desc_th(:,klev) = var_desc_th(:,klev-1)
+      var_desc_conv(:,klev) = var_desc_conv(:,klev-1)
+      
+      if (klein) then
+         do k=1,klev-1
+            do i=1,klon
+              qd0(:,:) = 0.0
+              if (sigd(i).ne.0) then
+                qd0(i,k) = fqd(i,k)*tau_cumul/sigd(i) 
+              endif
+            enddo
+         enddo
+         do k=1,klev-1
+            do i=1,klon      
+               povariance(i,k)= (var_moy(i,k) + var_var(i,k) + var_desc_th(i,k) +  &
+               var_det_conv(i,k) +  var_desc_prec(i,k)  &   
+                + var_desc_conv(i,k))*pdtphys + povariance(i,k)
+               povariance(i,k)= povariance(i,k)*exp(-pdtphys/tau_diss(i,k))
+            enddo
+         enddo
+         povariance(:,klev) = povariance(:,klev-1)
+         
+      else ! calcul direct     
+         qd0(:,:) = 0.0
+         q0(:,:) = 0.0
+         do k=1,klev-1
+            do i=1,klon
+               if (sigd(i).ne.0) then    ! termes de variance par accumulation
+                 qd0(i,k) = fqd(i,k)*tau_cumul/sigd(i) 
+               endif
+               if (sigt_cv(i,k).ne.0) then
+                 q0(i,k) = fqcomp(i,k)*tau_cumul/sigt_cv(i,k)
+               endif
+            enddo
+         enddo
+         do k=1,klev-1
+            do i=1,klon      
+               povariance(i,k)= (pdocarreadj(i,k)-2.*po(i,k)*pdoadj(i,k) +  &
+               a_ratqs_cv*(sigt_cv(i,k)*(1-sigt_cv(i,k))*q0(i,k)**2/tau_cumul + var_desc_prec(i,k) +  &
+               var_desc_conv(i,k)))*pdtphys + povariance(i,k)
+               povariance(i,k)=povariance(i,k)*exp(-pdtphys/tau_diss(i,k))
+            enddo
+         enddo
+         povariance(:,klev) = povariance(:,klev-1)
+!         fqd(:,:)=sigt_cv(:,:)*(1-sigt_cv(:,:))*q0(:,:)**2/tau_cumul 
+      endif
+
+!-------------------------------------------------------------------------
+!  Caclul du ratqs_inter_
+!-------------------------------------------------------------------------
+
+      do k=1,klev
+        do i=1,klon
+           if(q_seri(i,k).ge.1E-7) then
+               ratqs_inter_(i,k) = abs(povariance(i,k))**0.5/q_seri(i,k)    
+               sigma_qtherm(i,k) = abs(varq_therm(i,k))**0.5     ! sigma dans les thermiques
+           else 
+               ratqs_inter_(i,k) = 0.  
+               sigma_qtherm(i,k) = 0.
+           endif
+        enddo
+      enddo
+      
+return
+end             
+
+!------------------------------------------------------------------
+SUBROUTINE ratqs_oro(klon,klev,pctsrf,zstd,qsat,temp,pplay,paprs,ratqs_oro_)
+
+! Etienne Vignon, November 2021: effect of subgrid orography on ratqs
+
+USE lmdz_ratqs_ini, ONLY : RG,RV,RD,RLSTT,RLVTT,RTT,nbsrf,is_lic,is_ter
+
+IMPLICIT NONE
+
+! Declarations
+!--------------
+
+! INPUTS
+
+INTEGER, INTENT(IN) :: klon                       ! number of horizontal grid points
+INTEGER, INTENT(IN) :: klev                       ! number of vertical layers
+REAL, DIMENSION(klon,nbsrf) :: pctsrf
+REAL, DIMENSION(klon,klev), INTENT(IN) :: qsat    ! saturation specific humidity [kg/kg]
+REAL, DIMENSION(klon), INTENT(IN) :: zstd    ! sub grid orography standard deviation
+REAL, DIMENSION(klon,klev), INTENT(IN) :: temp    ! air temperature [K]
+REAL, DIMENSION(klon,klev), INTENT(IN) :: pplay    ! air pressure, layer's center [Pa]
+REAL, DIMENSION(klon,klev+1), INTENT(IN) :: paprs    ! air pressure, lower inteface [Pa]
+
+! OUTPUTS
+
+REAL, DIMENSION(klon,klev), INTENT(out) :: ratqs_oro_ ! ratqs profile due to subgrid orography
+
+
+! LOCAL
+
+INTEGER :: i,k
+REAL, DIMENSION(klon) :: orogradT,xsi0
+REAL, DIMENSION (klon,klev) :: zlay
+REAL :: Lvs, temp0
+
+
+! Calculation of the near-surface temperature gradient along the topography
+!--------------------------------------------------------------------------
+
+! at the moment, we fix it at a constant value (moist adiab. lapse rate)
+
+orogradT(:)=-6.5/1000. ! K/m
+
+! Calculation of near-surface surface ratqs
+!-------------------------------------------
+
+DO i=1,klon
+    temp0=temp(i,1)
+    IF (temp0 .LT. RTT) THEN
+        Lvs=RLSTT
+    ELSE
+        Lvs=RLVTT
+    ENDIF
+    xsi0(i)=zstd(i)*ABS(orogradT(i))*Lvs/temp0/temp0/RV
+    ratqs_oro_(i,1)=xsi0(i)
+END DO
+
+! Vertical profile of ratqs assuming an exponential decrease with height
+!------------------------------------------------------------------------
+     
+! calculation of geop. height AGL        
+zlay(:,1)= RD*temp(:,1)/(0.5*(paprs(:,1)+pplay(:,1))) &
+           *(paprs(:,1)-pplay(:,1))/RG
+
+DO k=2,klev
+   DO i = 1, klon
+      zlay(i,k)= zlay(i,k-1)+RD*0.5*(temp(i,k-1)+temp(i,k)) &
+               /paprs(i,k)*(pplay(i,k-1)-pplay(i,k))/RG
+               
+      ratqs_oro_(i,k)=MAX(0.0,pctsrf(i,is_ter)*xsi0(i)*exp(-zlay(i,k)/MAX(zstd(i),1.)))   
+    END DO
+END DO
+
+
+
+
+END SUBROUTINE ratqs_oro
+
+!=============================================
+
+SUBROUTINE ratqs_hetero(klon,klev,pctsrf,s_pblh,t2m,q2m,temp,q,pplay,paprs,ratqs_hetero_)
+
+! Etienne Vignon, November 2021
+! Effect of subgrid surface heterogeneities on ratqs
+
+USE lmdz_lscp_tools, ONLY: CALC_QSAT_ECMWF
+
+USE lmdz_ratqs_ini, ONLY : RG,RD,RTT,nbsrf
+
+IMPLICIT NONE
+
+! INPUTS
+
+
+INTEGER, INTENT(IN) :: klon                       ! number of horizontal grid points
+INTEGER, INTENT(IN) :: klev                       ! number of vertical layers
+REAL, DIMENSION(klon)                   :: s_pblh ! height of the planetary boundary layer(HPBL)
+REAL, DIMENSION(klon,nbsrf)             :: pctsrf ! Fractional cover of subsurfaces
+REAL, DIMENSION(klon,nbsrf), INTENT(IN) :: t2m    ! 2m temperature for each tile [K]
+REAL, DIMENSION(klon,nbsrf), INTENT(IN) :: q2m    ! 2m specific humidity for each tile [kg/kg]
+REAL, DIMENSION(klon,klev), INTENT(IN) :: temp    ! air temperature [K]
+REAL, DIMENSION(klon,klev), INTENT(IN) :: q       ! specific humidity [kg/kg]
+REAL, DIMENSION(klon,klev), INTENT(IN) :: pplay   ! air pressure, layer's center [Pa]
+REAL, DIMENSION(klon,klev+1), INTENT(IN) :: paprs ! air pressure, lower inteface [Pa]
+
+! OUTPUTS
+
+REAL, DIMENSION(klon,klev), INTENT(out) :: ratqs_hetero_ ! ratsq profile due to surface heterogeneities
+
+
+INTEGER :: i,k,nsrf
+REAL, DIMENSION(klon) :: xsi0, ratiom, qsat2m, dqsatdT
+REAL, DIMENSION (klon,klev) :: zlay
+
+
+
+! Calculation of near-surface surface ratqs
+!-------------------------------------------
+
+    
+    ratiom(:)=0.
+    xsi0(:)=0.
+    
+    DO nsrf=1,nbsrf
+    CALL CALC_QSAT_ECMWF(klon,t2m(:,nsrf),q2m(:,nsrf),paprs(:,1),RTT,0,.false.,qsat2m,dqsatdT)
+    ratiom(:)=ratiom(:)+pctsrf(:,nsrf)*(q2m(:,nsrf)/qsat2m(:))
+    xsi0(:)=xsi0(:)+pctsrf(:,nsrf)*((q2m(:,nsrf)/qsat2m(:)-ratiom(:))**2)
+    END DO
+    
+    xsi0(:)=sqrt(xsi0(:))/(ratiom(:)+1E-6)
+
+
+
+! Vertical profile of ratqs assuming an exponential decrease with height
+!------------------------------------------------------------------------
+        
+! calculation of geop. height AGL
+
+zlay(:,1)= RD*temp(:,1)/(0.5*(paprs(:,1)+pplay(:,1))) &
+           *(paprs(:,1)-pplay(:,1))/RG
+ratqs_hetero_(:,1)=xsi0(:)
+
+DO k=2,klev
+   DO i = 1, klon
+      zlay(i,k)= zlay(i,k-1)+RD*0.5*(temp(i,k-1)+temp(i,k)) &
+               /paprs(i,k)*(pplay(i,k-1)-pplay(i,k))/RG
+               
+      ratqs_hetero_(i,k)=MAX(xsi0(i)*exp(-zlay(i,k)/(s_pblh(i)+1.0)),0.0)   
+    END DO
+END DO
+
+END SUBROUTINE ratqs_hetero
+
+!=============================================
+
+SUBROUTINE ratqs_tke(klon,klev,pdtphys,temp,q,qsat,pplay,paprs,omega,tke,tke_dissip,lmix,wprime,ratqs_tke_)
+
+! References:
+!
+! Etienne Vignon: effect of subgrid turbulence on ratqs
+!
+! Field, P.R., Hill, A., Furtado, K., Korolev, A., 2014b. Mixed-phase clouds in a turbulent environment. Part
+! 2: analytic treatment. Q. J. R. Meteorol. Soc. 21, 2651???2663. https://doi.org/10.1002/qj.2175.
+! 
+! Furtado, K., Field, P.R., Boutle, I.A., Morcrette, C.R., Wilkinson, J., 2016. A physically-based, subgrid
+! parametrization for the production and maintenance of mixed-phase clouds in a general circulation
+! model. J. Atmos. Sci. 73, 279???291. https://doi.org/10.1175/JAS-D-15-0021.
+
+USE lmdz_ratqs_ini, ONLY : RG,RV,RD,RCPD,RLSTT,RLVTT,RTT
+
+IMPLICIT NONE
+
+! INPUTS
+
+INTEGER, INTENT(IN) :: klon                             ! number of horizontal grid points
+INTEGER, INTENT(IN) :: klev                             ! number of vertical layers
+REAL, INTENT(IN) :: pdtphys                             ! physics time step [s]
+REAL, DIMENSION(klon,klev), INTENT(IN) :: temp          ! air temperature [K]
+REAL, DIMENSION(klon,klev), INTENT(IN) :: q             ! specific humidity [kg/kg]
+REAL, DIMENSION(klon,klev), INTENT(IN) :: qsat          ! saturation specific humidity [kg/kg]
+REAL, DIMENSION(klon,klev), INTENT(IN) :: pplay         ! air pressure, layer's center [Pa]
+REAL, DIMENSION(klon,klev+1), INTENT(IN) :: paprs       ! air pressure, lower inteface [Pa]
+REAL, DIMENSION(klon,klev), INTENT(IN) :: omega       ! air pressure, lower inteface [Pa]
+REAL, DIMENSION(klon,klev+1), INTENT(IN) :: tke         ! Turbulent Kinetic Energy [m2/s2]
+REAL, DIMENSION(klon,klev+1), INTENT(IN) :: tke_dissip  ! Turbulent Kinetic Energy Dissipation rate [m2/s3]
+REAL, DIMENSION(klon,klev+1), INTENT(IN) :: lmix  ! Turbulent mixing length
+REAL, DIMENSION(klon,klev+1), INTENT(IN) :: wprime      ! Turbulent vertical velocity scale [m/s]
+
+! OUTPUTS
+
+REAL, DIMENSION(klon,klev), INTENT(out) :: ratqs_tke_  ! ratsq profile due to subgrid TKE
+
+! LOCAL
+INTEGER :: i, k
+REAL :: AA, DD, NW, AAprime, VARLOG,rho,Lvs,taue,lhomo,dissmin,maxvarlog
+REAL, DIMENSION(klon,klev) :: sigmaw,w
+REAL, PARAMETER :: C0=10.0
+REAL, PARAMETER :: lmin=0.001
+REAL, PARAMETER :: ratqsmin=1E-6
+REAL, PARAMETER :: ratqsmax=0.5
+
+
+! Calculation of large scale and turbulent vertical velocities
+!---------------------------------------------------------------
+
+DO k=1,klev
+    DO i=1,klon
+        rho=pplay(i,k)/temp(i,k)/RD
+        w(i,k)=-rho*RG*omega(i,k)
+        sigmaw(i,k)=0.5*(wprime(i,k+1)+wprime(i,k)) ! turbulent vertical velocity at the middle of model layers. 
+    END DO
+END DO
+
+! Calculation of ratqs
+!---------------------------------------------------------------
+ratqs_tke_(:,1)=ratqsmin ! set to a very low value to avoid division by 0 in order parts
+                        ! of the code
+DO k=2,klev ! we start from second model level since TKE is not defined at k=1
+    DO i=1,klon
+
+       IF (temp(i,k) .LT. RTT) THEN
+           Lvs=RLSTT
+       ELSE
+           Lvs=RLVTT
+       ENDIF
+       dissmin=0.01*(0.5*(tke(i,k)+tke(i,k+1))/pdtphys)
+       maxvarlog=LOG(1.0+ratqsmax**2)! to prevent ratqs from exceeding an arbitrary threshold value 
+       AA=RG*(Lvs/(RCPD*temp(i,k)*temp(i,k)*RV) - 1./(RD*temp(i,k)))
+       lhomo=MAX(0.5*(lmix(i,k)+lmix(i,k+1)),lmin)
+       taue=(lhomo*lhomo/MAX(0.5*(tke_dissip(i,k)+tke_dissip(i,k+1)),dissmin))**(1./3) ! Fields et al. 2014
+       DD=1.0/taue
+       NW=(sigmaw(i,k)**2)*SQRT(2./(C0*MAX(0.5*(tke_dissip(i,k)+tke_dissip(i,k+1)),dissmin)))
+       AAprime=AA*NW
+       VARLOG=AAprime/2./DD
+       VARLOG=MIN(VARLOG,maxvarlog)
+       ratqs_tke_(i,k)=SQRT(MAX(EXP(VARLOG)-1.0,ratqsmin))
+       END DO
+END DO
+END SUBROUTINE ratqs_tke
+
+END MODULE lmdz_ratqs_multi
Index: DZ6/trunk/libf/phylmd/lmdz_thermcell_alim.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/lmdz_thermcell_alim.F90	(revision 5267)
+++ 	(revision )
@@ -1,127 +1,0 @@
-MODULE lmdz_thermcell_alim
-!
-! $Id: thermcell_plume.F90 2311 2015-06-25 07:45:24Z emillour $
-!
-CONTAINS
-
-      SUBROUTINE thermcell_alim(flag,ngrid,klev,ztv,d_temp,zlev,alim_star,lalim)
-IMPLICIT NONE
-
-!--------------------------------------------------------------------------
-! FH : 2015/11/06
-! thermcell_alim: calcule la distribution verticale de l'alimentation 
-! laterale a la base des panaches thermiques
-!--------------------------------------------------------------------------
-
-      INTEGER, INTENT(IN) :: ngrid,klev
-      REAL, INTENT(IN) :: ztv(ngrid,klev)
-      REAL, INTENT(IN) :: d_temp(ngrid)
-      REAL, INTENT(IN) :: zlev(ngrid,klev+1)
-      REAL, INTENT(OUT) :: alim_star(ngrid,klev)
-      INTEGER, INTENT(OUT) :: lalim(ngrid)
-      INTEGER, INTENT(IN) :: flag
-
-      REAL :: alim_star_tot(ngrid),zi(ngrid),zh(ngrid)
-      REAL :: zlay(ngrid,klev)
-      REAL ztv_parcel
-
-      INTEGER ig,l
-
-      REAL h,z,falim
-      falim(h,z)=0.2*((z-h)**5+h**5)
-
-
-!===================================================================
-
-   lalim(:)=1
-   alim_star_tot(:)=0.
-
-!-------------------------------------------------------------------------
-! Definition de l'alimentation
-!-------------------------------------------------------------------------
-   IF (flag==0) THEN ! CMIP5 version
-      do l=1,klev-1
-         do ig=1,ngrid
-            if (ztv(ig,l)> ztv(ig,l+1) .and. ztv(ig,1)>=ztv(ig,l) ) then
-               alim_star(ig,l)=MAX((ztv(ig,l)-ztv(ig,l+1)),0.)  &
-     &                       *sqrt(zlev(ig,l+1)) 
-               lalim(ig)=l+1
-               alim_star_tot(ig)=alim_star_tot(ig)+alim_star(ig,l)
-            endif
-         enddo
-      enddo
-      do l=1,klev
-         do ig=1,ngrid 
-            if (alim_star_tot(ig) > 1.e-10 ) then
-               alim_star(ig,l)=alim_star(ig,l)/alim_star_tot(ig)
-            endif
-         enddo
-      enddo
-      alim_star_tot(:)=1.
-
-!-------------------------------------------------------------------------
-! Nouvelle definition avec possibilite d'introduire un DT en surface
-! On suppose que la forme du profile d'alimentation scale avec la hauteur
-! d'inversion calculée avec une particule partant de la premieere couche
-
-! Fonction  f(z) = z ( h - z ) , avec h = zi/3
-! On utilise l'integralle
-! Int_0^z f(z') dz' = z^2 ( h/2 - z/3 ) = falim(h,z)
-! Pour calculer l'alimentation des couches
-!-------------------------------------------------------------------------
-   ELSE
-! Computing inversion height zi and zh=zi/3.
-      zi(:)=0.
-! Il faut recalculer zlay qui n'est pas dispo dans thermcell_plume
-! A changer eventuellement.
-      do l=1,klev
-         zlay(:,l)=0.5*(zlev(:,l)+zlev(:,l+1))
-      enddo
-
-      do l=klev-1,1,-1
-         do ig=1,ngrid
-            ztv_parcel=ztv(ig,1)+d_temp(ig)
-            if (ztv_parcel<ztv(ig,l+1)) lalim(ig)=l
-         enddo
-      enddo
-
-      do ig=1,ngrid
-         l=lalim(ig)
-         IF (l==1) THEN
-            zi(ig)=0.
-         ELSE
-            ztv_parcel=ztv(ig,1)+d_temp(ig)
-            zi(ig)=zlay(ig,l)+(zlay(ig,l+1)-zlay(ig,l))/(ztv(ig,l+1)-ztv(ig,l))*(ztv_parcel-ztv(ig,l))
-         ENDIF
-      enddo
-
-      zh(:)=zi(:)/2.
-      alim_star_tot(:)=0.
-      alim_star(:,:)=0.
-      lalim(:)=0
-      do l=1,klev-1
-         do ig=1,ngrid
-            IF (zh(ig)==0.) THEN
-               alim_star(ig,l)=0.
-               lalim(ig)=1
-            ELSE IF (zlev(ig,l+1)<=zh(ig)) THEN
-               alim_star(ig,l)=(falim(zh(ig),zlev(ig,l+1))-falim(zh(ig),zlev(ig,l)))/falim(zh(ig),zh(ig))
-               lalim(ig)=l
-            ELSE IF (zlev(ig,l)<=zh(ig)) THEN
-               alim_star(ig,l)=(falim(zh(ig),zh(ig))-falim(zh(ig),zlev(ig,l)))/falim(zh(ig),zh(ig))
-               lalim(ig)=l
-            ELSE
-               alim_star(ig,l)=0.
-            ENDIF
-         ENDDO
-         alim_star_tot(:)=alim_star_tot(:)+alim_star(:,l)
-      ENDDO
-      IF (ngrid==1) print*,'NEW ALIM CALCUL DE ZI ',alim_star_tot,lalim,zi,zh
-      alim_star_tot(:)=1.
-
-   ENDIF
-
-
-RETURN
-END
-END MODULE lmdz_thermcell_alim
Index: /LMDZ6/trunk/libf/phylmd/lmdz_thermcell_alim.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/lmdz_thermcell_alim.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/lmdz_thermcell_alim.f90	(revision 5268)
@@ -0,0 +1,127 @@
+MODULE lmdz_thermcell_alim
+!
+! $Id: thermcell_plume.F90 2311 2015-06-25 07:45:24Z emillour $
+!
+CONTAINS
+
+      SUBROUTINE thermcell_alim(flag,ngrid,klev,ztv,d_temp,zlev,alim_star,lalim)
+IMPLICIT NONE
+
+!--------------------------------------------------------------------------
+! FH : 2015/11/06
+! thermcell_alim: calcule la distribution verticale de l'alimentation 
+! laterale a la base des panaches thermiques
+!--------------------------------------------------------------------------
+
+      INTEGER, INTENT(IN) :: ngrid,klev
+      REAL, INTENT(IN) :: ztv(ngrid,klev)
+      REAL, INTENT(IN) :: d_temp(ngrid)
+      REAL, INTENT(IN) :: zlev(ngrid,klev+1)
+      REAL, INTENT(OUT) :: alim_star(ngrid,klev)
+      INTEGER, INTENT(OUT) :: lalim(ngrid)
+      INTEGER, INTENT(IN) :: flag
+
+      REAL :: alim_star_tot(ngrid),zi(ngrid),zh(ngrid)
+      REAL :: zlay(ngrid,klev)
+      REAL ztv_parcel
+
+      INTEGER ig,l
+
+      REAL h,z,falim
+      falim(h,z)=0.2*((z-h)**5+h**5)
+
+
+!===================================================================
+
+   lalim(:)=1
+   alim_star_tot(:)=0.
+
+!-------------------------------------------------------------------------
+! Definition de l'alimentation
+!-------------------------------------------------------------------------
+   IF (flag==0) THEN ! CMIP5 version
+      do l=1,klev-1
+         do ig=1,ngrid
+            if (ztv(ig,l)> ztv(ig,l+1) .and. ztv(ig,1)>=ztv(ig,l) ) then
+               alim_star(ig,l)=MAX((ztv(ig,l)-ztv(ig,l+1)),0.)  &
+     &                       *sqrt(zlev(ig,l+1)) 
+               lalim(ig)=l+1
+               alim_star_tot(ig)=alim_star_tot(ig)+alim_star(ig,l)
+            endif
+         enddo
+      enddo
+      do l=1,klev
+         do ig=1,ngrid 
+            if (alim_star_tot(ig) > 1.e-10 ) then
+               alim_star(ig,l)=alim_star(ig,l)/alim_star_tot(ig)
+            endif
+         enddo
+      enddo
+      alim_star_tot(:)=1.
+
+!-------------------------------------------------------------------------
+! Nouvelle definition avec possibilite d'introduire un DT en surface
+! On suppose que la forme du profile d'alimentation scale avec la hauteur
+! d'inversion calculée avec une particule partant de la premieere couche
+
+! Fonction  f(z) = z ( h - z ) , avec h = zi/3
+! On utilise l'integralle
+! Int_0^z f(z') dz' = z^2 ( h/2 - z/3 ) = falim(h,z)
+! Pour calculer l'alimentation des couches
+!-------------------------------------------------------------------------
+   ELSE
+! Computing inversion height zi and zh=zi/3.
+      zi(:)=0.
+! Il faut recalculer zlay qui n'est pas dispo dans thermcell_plume
+! A changer eventuellement.
+      do l=1,klev
+         zlay(:,l)=0.5*(zlev(:,l)+zlev(:,l+1))
+      enddo
+
+      do l=klev-1,1,-1
+         do ig=1,ngrid
+            ztv_parcel=ztv(ig,1)+d_temp(ig)
+            if (ztv_parcel<ztv(ig,l+1)) lalim(ig)=l
+         enddo
+      enddo
+
+      do ig=1,ngrid
+         l=lalim(ig)
+         IF (l==1) THEN
+            zi(ig)=0.
+         ELSE
+            ztv_parcel=ztv(ig,1)+d_temp(ig)
+            zi(ig)=zlay(ig,l)+(zlay(ig,l+1)-zlay(ig,l))/(ztv(ig,l+1)-ztv(ig,l))*(ztv_parcel-ztv(ig,l))
+         ENDIF
+      enddo
+
+      zh(:)=zi(:)/2.
+      alim_star_tot(:)=0.
+      alim_star(:,:)=0.
+      lalim(:)=0
+      do l=1,klev-1
+         do ig=1,ngrid
+            IF (zh(ig)==0.) THEN
+               alim_star(ig,l)=0.
+               lalim(ig)=1
+            ELSE IF (zlev(ig,l+1)<=zh(ig)) THEN
+               alim_star(ig,l)=(falim(zh(ig),zlev(ig,l+1))-falim(zh(ig),zlev(ig,l)))/falim(zh(ig),zh(ig))
+               lalim(ig)=l
+            ELSE IF (zlev(ig,l)<=zh(ig)) THEN
+               alim_star(ig,l)=(falim(zh(ig),zh(ig))-falim(zh(ig),zlev(ig,l)))/falim(zh(ig),zh(ig))
+               lalim(ig)=l
+            ELSE
+               alim_star(ig,l)=0.
+            ENDIF
+         ENDDO
+         alim_star_tot(:)=alim_star_tot(:)+alim_star(:,l)
+      ENDDO
+      IF (ngrid==1) print*,'NEW ALIM CALCUL DE ZI ',alim_star_tot,lalim,zi,zh
+      alim_star_tot(:)=1.
+
+   ENDIF
+
+
+RETURN
+END
+END MODULE lmdz_thermcell_alim
Index: DZ6/trunk/libf/phylmd/lmdz_thermcell_alp.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/lmdz_thermcell_alp.F90	(revision 5267)
+++ 	(revision )
@@ -1,428 +1,0 @@
-MODULE lmdz_thermcell_alp
-! $Id: thermcell_main.F90 2351 2015-08-25 15:14:59Z emillour $
-!
-CONTAINS
-
-      SUBROUTINE thermcell_alp(ngrid,nlay,ptimestep  &                         ! in
-     &                  ,pplay,pplev  &                                        ! in
-     &                  ,fm0,entr0,lmax  &                                     ! in
-     &                  ,pbl_tke,pctsrf,omega,airephy &                        ! in
-     &                  ,zw2,fraca &                                           ! in
-     &                  ,pcon,rhobarz,wth3,wmax_sec,lalim,fm,alim_star,zmax &  ! in
-!
-     &                  ,zcong,ale_bl,alp_bl,lalim_conv,wght_th &                    ! out
-     &                  ,zlcl,fraca0,w0,w_conv,therm_tke_max0,env_tke_max0 &   ! out
-     &                  ,n2,s2,strig,ale_bl_stat &                                   ! out
-     &                  ,therm_tke_max,env_tke_max &                           ! out
-     &                  ,alp_bl_det,alp_bl_fluct_m,alp_bl_fluct_tke &          ! out
-     &                  ,alp_bl_conv,alp_bl_stat &                             ! out
-     &)
-
-      USE indice_sol_mod
-      USE lmdz_thermcell_main, ONLY : thermcell_tke_transport
-      IMPLICIT NONE
-
-!=======================================================================
-!
-!   Auteurs: Catherine Rio
-!   Modifications :
-!   Nicolas Rochetin et Jean-Yves Grandpeix
-!         pour la fermeture stochastique. 2012
-!   Frédéric Hourdin :
-!         netoyage informatique. 2022
-!   
-!=======================================================================
-!-----------------------------------------------------------------------
-!   declarations:
-!   -------------
-
-      INCLUDE "YOMCST.h"
-      INCLUDE "YOETHF.h"
-      INCLUDE "FCTTRE.h"
-      INCLUDE "alpale.h"
-
-!   arguments:
-!   ----------
-
-!------Entrees
-      integer, intent(in) :: ngrid,nlay
-      real, intent(in) :: ptimestep
-      real, intent(in) :: pplay(ngrid,nlay),pplev(ngrid,nlay+1)
-      integer, intent(in), dimension(ngrid) ::lmax,lalim
-      real, intent(in), dimension(ngrid) :: zmax, zcong
-      real, intent(in), dimension(ngrid,nlay+1) :: zw2
-      real, intent(in), dimension(ngrid,nlay+1) :: fraca
-      real, intent(in), dimension(ngrid,nlay) :: wth3
-      real, intent(in), dimension(ngrid,nlay) :: rhobarz
-      real, intent(in), dimension(ngrid) :: wmax_sec
-      real, intent(in), dimension(ngrid,nlay) :: entr0
-      real, intent(in), dimension(ngrid,nlay+1) :: fm0,fm
-      real, intent(in), dimension(ngrid) :: pcon
-      real, intent(in), dimension(ngrid,nlay) :: alim_star
-      real, intent(in), dimension(ngrid,nlay+1,nbsrf) :: pbl_tke
-      real, intent(in), dimension(ngrid,nbsrf) :: pctsrf
-      real, intent(in), dimension(ngrid,nlay) :: omega
-      real, intent(in), dimension(ngrid) :: airephy
-!------Sorties
-      real, intent(out), dimension(ngrid) :: ale_bl,alp_bl
-      real, intent(out), dimension(ngrid,nlay) :: wght_th
-      integer, intent(out), dimension(ngrid) :: lalim_conv
-      real, intent(out), dimension(ngrid) :: zlcl,fraca0,w0,w_conv
-      real, intent(out), dimension(ngrid) :: therm_tke_max0,env_tke_max0,n2,s2,ale_bl_stat,strig
-      real, intent(out), dimension(ngrid,nlay) :: therm_tke_max,env_tke_max
-      real, intent(out), dimension(ngrid) :: alp_bl_det,alp_bl_fluct_m,alp_bl_fluct_tke
-      real, intent(out), dimension(ngrid) :: alp_bl_conv,alp_bl_stat
-
-!=============================================================================================
-!------Local
-!=============================================================================================
-
-      REAL susqr2pi, reuler
-      INTEGER ig,k,l
-      integer nsrf
-      real rhobarz0(ngrid)                    ! Densité au LCL
-      logical ok_lcl(ngrid)                   ! Existence du LCL des thermiques
-      integer klcl(ngrid)                     ! Niveau du LCL
-      real interp(ngrid)                      ! Coef d'interpolation pour le LCL
-!--Triggering
-      real, parameter :: su_cst=4e4              ! Surface unite: celle d'un updraft élémentaire
-      real, parameter :: hcoef=1             ! Coefficient directeur pour le calcul de s2
-      real, parameter :: hmincoef=0.3        ! Coefficient directeur pour l'ordonnée à l'origine pour le calcul de s2 
-      real, parameter :: eps1=0.3            ! Fraction de surface occupée par la population 1 : eps1=n1*s1/(fraca0*Sd)
-      real, dimension(ngrid) :: hmin         ! Ordonnée à l'origine pour le calcul de s2
-      real, dimension(ngrid) :: zmax_moy     ! Hauteur moyenne des thermiques : zmax_moy = zlcl + 0.33 (zmax-zlcl)
-      real, parameter :: zmax_moy_coef=0.33
-      real, dimension(ngrid) :: depth        ! Epaisseur moyenne du cumulus
-      real, dimension(ngrid) :: zcong_moy 
-      real, dimension(ngrid) ::  w_max                 ! Vitesse max statistique 
-      real, dimension(ngrid) ::  s_max(ngrid)
-!--Closure
-      real, dimension(ngrid,nlay) :: pbl_tke_max       ! Profil de TKE moyenne 
-      real, dimension(ngrid) :: pbl_tke_max0           ! TKE moyenne au LCL
-      real, dimension(ngrid,nlay) :: w_ls              ! Vitesse verticale grande échelle (m/s)
-      real, parameter :: coef_m=1.            ! On considère un rendement pour alp_bl_fluct_m
-      real, parameter :: coef_tke=1.          ! On considère un rendement pour alp_bl_fluct_tke
-      real :: zdp
-      real, dimension(ngrid) :: alp_int,dp_int
-      real, dimension(ngrid) :: fm_tot
-
-!------------------------------------------------------------
-!  Initialize output arrays related to stochastic triggering
-!------------------------------------------------------------
-  DO ig = 1,ngrid
-     zlcl(ig) = 0.
-     fraca0(ig) = 0.
-     w0(ig) = 0.
-     w_conv(ig) = 0.
-     therm_tke_max0(ig) = 0.
-     env_tke_max0(ig) = 0.
-     n2(ig) = 0.
-     s2(ig) = 0.
-     ale_bl_stat(ig) = 0.
-     strig(ig) = 0.
-     alp_bl_det(ig) = 0.
-     alp_bl_fluct_m(ig) = 0.
-     alp_bl_fluct_tke(ig) = 0.
-     alp_bl_conv(ig) = 0.
-     alp_bl_stat(ig) = 0.
-  ENDDO
-  DO l = 1,nlay
-    DO ig = 1,ngrid
-     therm_tke_max(ig,l) = 0.
-     env_tke_max(ig,l) = 0.
-    ENDDO
-  ENDDO
-
-!------------Test sur le LCL des thermiques
-    do ig=1,ngrid
-      ok_lcl(ig)=.false.
-      if ( (pcon(ig) .gt. pplay(ig,nlay-1)) .and. (pcon(ig) .lt. pplay(ig,1)) ) ok_lcl(ig)=.true.
-    enddo
-
-!------------Localisation des niveaux entourant le LCL et du coef d'interpolation
-    do l=1,nlay-1
-      do ig=1,ngrid
-        if (ok_lcl(ig)) then 
-!ATTENTION,zw2 calcule en pplev
-!          if ((pplay(ig,l) .ge. pcon(ig)) .and. (pplay(ig,l+1) .le. pcon(ig))) then
-!          klcl(ig)=l
-!          interp(ig)=(pcon(ig)-pplay(ig,klcl(ig)))/(pplay(ig,klcl(ig)+1)-pplay(ig,klcl(ig)))
-!          endif
-          if ((pplev(ig,l) .ge. pcon(ig)) .and. (pplev(ig,l+1) .le. pcon(ig))) then
-          klcl(ig)=l
-          interp(ig)=(pcon(ig)-pplev(ig,klcl(ig)))/(pplev(ig,klcl(ig)+1)-pplev(ig,klcl(ig)))
-          endif
-        endif
-      enddo
-    enddo
-
-    do ig =1,ngrid
-!CR:REHABILITATION ZMAX CONTINU
-     if (ok_lcl(ig)) then 
-      rhobarz0(ig)=rhobarz(ig,klcl(ig))+(rhobarz(ig,klcl(ig)+1) &
- &               -rhobarz(ig,klcl(ig)))*interp(ig)
-      zlcl(ig)=(pplev(ig,1)-pcon(ig))/(rhobarz0(ig)*RG)
-      zlcl(ig)=min(zlcl(ig),zmax(ig))   ! Si zlcl > zmax alors on pose zlcl = zmax
-     else
-      rhobarz0(ig)=0.
-      zlcl(ig)=zmax(ig)
-     endif
-    enddo
-!!jyg fin
-
-!------------Calcul des propriétés du thermique au LCL 
-  IF ( (iflag_trig_bl.ge.1) .or. (iflag_clos_bl.ge.1) ) THEN 
-
-  !-----Initialisation de la TKE moyenne 
-   do l=1,nlay
-    do ig=1,ngrid
-     pbl_tke_max(ig,l)=0.
-    enddo
-   enddo
-
-!-----Calcul de la TKE moyenne 
-   do nsrf=1,nbsrf
-    do l=1,nlay
-     do ig=1,ngrid
-     pbl_tke_max(ig,l)=pctsrf(ig,nsrf)*pbl_tke(ig,l,nsrf)+pbl_tke_max(ig,l)
-     enddo
-    enddo
-   enddo
-
-!-----Initialisations des TKE dans et hors des thermiques 
-   do l=1,nlay
-    do ig=1,ngrid
-    therm_tke_max(ig,l)=pbl_tke_max(ig,l)
-    env_tke_max(ig,l)=pbl_tke_max(ig,l)
-    enddo
-   enddo
-
-!-----Calcul de la TKE transportée par les thermiques : therm_tke_max
-   call thermcell_tke_transport(ngrid,nlay,ptimestep,fm0,entr0,  &  ! in
-  &           rg,pplev,therm_tke_max)                               ! out
-!   print *,' thermcell_tke_transport -> '   !!jyg
-
-!-----Calcul des profils verticaux de TKE hors thermiques : env_tke_max, et de la vitesse verticale grande échelle : W_ls
-   do l=1,nlay
-    do ig=1,ngrid
-     pbl_tke_max(ig,l)=fraca(ig,l)*therm_tke_max(ig,l)+(1.-fraca(ig,l))*env_tke_max(ig,l)         !  Recalcul de TKE moyenne aprés transport de TKE_TH
-     env_tke_max(ig,l)=(pbl_tke_max(ig,l)-fraca(ig,l)*therm_tke_max(ig,l))/(1.-fraca(ig,l))       !  Recalcul de TKE dans  l'environnement aprés transport de TKE_TH
-     w_ls(ig,l)=-1.*omega(ig,l)/(RG*rhobarz(ig,l))                                                !  Vitesse verticale de grande échelle
-    enddo
-   enddo
-!    print *,' apres w_ls = '   !!jyg
-
-  do ig=1,ngrid
-   if (ok_lcl(ig)) then
-     fraca0(ig)=fraca(ig,klcl(ig))+(fraca(ig,klcl(ig)+1) &
- &             -fraca(ig,klcl(ig)))*interp(ig)
-     w0(ig)=zw2(ig,klcl(ig))+(zw2(ig,klcl(ig)+1) &
- &         -zw2(ig,klcl(ig)))*interp(ig)
-     w_conv(ig)=w_ls(ig,klcl(ig))+(w_ls(ig,klcl(ig)+1) &
- &             -w_ls(ig,klcl(ig)))*interp(ig)
-     therm_tke_max0(ig)=therm_tke_max(ig,klcl(ig)) &
- &                     +(therm_tke_max(ig,klcl(ig)+1)-therm_tke_max(ig,klcl(ig)))*interp(ig)
-     env_tke_max0(ig)=env_tke_max(ig,klcl(ig))+(env_tke_max(ig,klcl(ig)+1) &
- &                   -env_tke_max(ig,klcl(ig)))*interp(ig)
-     pbl_tke_max0(ig)=pbl_tke_max(ig,klcl(ig))+(pbl_tke_max(ig,klcl(ig)+1) &
- &                   -pbl_tke_max(ig,klcl(ig)))*interp(ig)
-     if (therm_tke_max0(ig).ge.20.) therm_tke_max0(ig)=20.
-     if (env_tke_max0(ig).ge.20.) env_tke_max0(ig)=20.
-     if (pbl_tke_max0(ig).ge.20.) pbl_tke_max0(ig)=20.
-   else 
-     fraca0(ig)=0.
-     w0(ig)=0.
-!!jyg le 27/04/2012
-!!     zlcl(ig)=0.
-!!
-   endif
-  enddo
-
-  ENDIF ! IF ( (iflag_trig_bl.ge.1) .or. (iflag_clos_bl.ge.1) )
-!  print *,'ENDIF  ( (iflag_trig_bl.ge.1) .or. (iflag_clos_bl.ge.1) ) '    !!jyg
-
-!------------Triggering------------------
-  IF (iflag_trig_bl.ge.1) THEN 
-
-!-----Initialisations
-   depth(:)=0.
-   n2(:)=0.
-   s2(:)=100. ! some low value, arbitrary
-   s_max(:)=0.
-
-
-
-!-----Epaisseur du nuage (depth) et détermination de la queue du spectre de panaches (n2,s2) et du panache le plus gros (s_max)
-   do ig=1,ngrid
-     zmax_moy(ig)=zlcl(ig)+zmax_moy_coef*(zmax(ig)-zlcl(ig))
-     depth(ig)=zmax_moy(ig)-zlcl(ig)
-     hmin(ig)=hmincoef*zlcl(ig)
-     if (depth(ig).ge.10.) then 
-       s2(ig)=(hcoef*depth(ig)+hmin(ig))**2
-       n2(ig)=(1.-eps1)*fraca0(ig)*airephy(ig)/s2(ig)
-!!
-!!jyg le 27/04/2012
-!!       s_max(ig)=s2(ig)*log(n2(ig))
-!!       if (n2(ig) .lt. 1) s_max(ig)=0.
-       s_max(ig)=s2(ig)*log(max(n2(ig),1.))
-!!fin jyg
-     else
-       n2(ig)=0.
-       s_max(ig)=0.
-     endif
-   enddo
-!   print *,'avant Calcul de Wmax '    !!jyg
-
-!CR: calcul de strig
-   if (iflag_strig.eq.0) then
-      strig(:)=s_trig
-   else if (iflag_strig.eq.1) then
-      do ig=1,ngrid
-!         zcong_moy(ig)=zlcl(ig)+zmax_moy_coef*(zcong(ig)-zlcl(ig))
-!         strig(ig)=(hcoef*(zcong_moy(ig)-zlcl(ig))+hmin(ig))**2  
-         strig(ig)=(zcong(ig)-zlcl(ig))**2  
-      enddo
-   else if (iflag_strig.eq.2) then
-      do ig=1,ngrid 
-         if (h_trig.gt.zlcl(ig)) then
-         strig(ig)=(h_trig-zlcl(ig))**2
-         else
-         strig(ig)=s_trig
-         endif
-      enddo   
-   endif
-
-   susqr2pi=su_cst*sqrt(2.*Rpi)
-   reuler=exp(1.)
-   do ig=1,ngrid
-     if ( (depth(ig).ge.10.) .and. (s_max(ig).gt.susqr2pi*reuler) ) then
-      w_max(ig)=w0(ig)*(1.+sqrt(2.*log(s_max(ig)/susqr2pi)-log(2.*log(s_max(ig)/susqr2pi))))
-      ale_bl_stat(ig)=0.5*w_max(ig)**2
-     else
-      w_max(ig)=0.
-      ale_bl_stat(ig)=0.
-     endif
-   enddo
-
-  ENDIF ! iflag_trig_bl
-!  print *,'ENDIF  iflag_trig_bl'    !!jyg
-
-!------------Closure------------------
-
-  IF (iflag_clos_bl.ge.2) THEN 
-
-!-----Calcul de ALP_BL_STAT
-  do ig=1,ngrid
-  alp_bl_det(ig)=0.5*coef_m*rhobarz0(ig)*(w0(ig)**3)*fraca0(ig)*(1.-2.*fraca0(ig))/((1.-fraca0(ig))**2)
-  alp_bl_fluct_m(ig)=1.5*rhobarz0(ig)*fraca0(ig)*(w_conv(ig)+coef_m*w0(ig))* &
- &                   (w0(ig)**2)
-  alp_bl_fluct_tke(ig)=3.*coef_m*rhobarz0(ig)*w0(ig)*fraca0(ig)*(therm_tke_max0(ig)-env_tke_max0(ig)) &
- &                    +3.*rhobarz0(ig)*w_conv(ig)*pbl_tke_max0(ig)
-    if (iflag_clos_bl.ge.2) then 
-    alp_bl_conv(ig)=1.5*coef_m*rhobarz0(ig)*fraca0(ig)*(fraca0(ig)/(1.-fraca0(ig)))*w_conv(ig)* &
- &                   (w0(ig)**2)
-    else
-    alp_bl_conv(ig)=0.
-    endif
-  alp_bl_stat(ig)=alp_bl_det(ig)+alp_bl_fluct_m(ig)+alp_bl_fluct_tke(ig)+alp_bl_conv(ig)
-  enddo
-
-!-----Sécurité ALP infinie
-  do ig=1,ngrid
-   if (fraca0(ig).gt.0.98) alp_bl_stat(ig)=2.
-  enddo
-
-  ENDIF ! (iflag_clos_bl.ge.2)
-
-!!! fin nrlmd le 10/04/2012
-
-!      print*,'avant calcul ale et alp' 
-!calcul de ALE et ALP pour la convection
-      alp_bl(:)=0.
-      ale_bl(:)=0.
-!          print*,'ALE,ALP ,l,zw2(ig,l),ale_bl(ig),alp_bl(ig)'
-      do l=1,nlay
-      do ig=1,ngrid
-           alp_bl(ig)=max(alp_bl(ig),0.5*rhobarz(ig,l)*wth3(ig,l) )
-           ale_bl(ig)=max(ale_bl(ig),0.5*zw2(ig,l)**2)
-!          print*,'ALE,ALP',l,zw2(ig,l),ale_bl(ig),alp_bl(ig)
-      enddo
-      enddo
-
-! ale sec (max de wmax/2 sous la zone d'inhibition) dans
-! le cas iflag_trig_bl=3
-      IF (iflag_trig_bl==3) ale_bl(:)=0.5*wmax_sec(:)**2
-
-!test:calcul de la ponderation des couches pour KE
-!initialisations
-
-      fm_tot(:)=0.
-      wght_th(:,:)=1.
-      lalim_conv(:)=lalim(:)
-
-      do k=1,nlay
-         do ig=1,ngrid
-            if (k<=lalim_conv(ig)) fm_tot(ig)=fm_tot(ig)+fm(ig,k)
-         enddo
-      enddo
-
-! assez bizarre car, si on est dans la couche d'alim et que alim_star et
-! plus petit que 1.e-10, on prend wght_th=1.
-      do k=1,nlay
-         do ig=1,ngrid
-            if (k<=lalim_conv(ig).and.alim_star(ig,k)>1.e-10) then
-               wght_th(ig,k)=alim_star(ig,k)
-            endif
-         enddo
-      enddo
-
-!      print*,'apres wght_th'
-!test pour prolonger la convection
-      do ig=1,ngrid
-!v1d  if ((alim_star(ig,1).lt.1.e-10).and.(therm)) then
-      if ((alim_star(ig,1).lt.1.e-10)) then
-      lalim_conv(ig)=1
-      wght_th(ig,1)=1.
-!      print*,'lalim_conv ok',lalim_conv(ig),wght_th(ig,1)
-      endif
-      enddo
-
-!------------------------------------------------------------------------
-! Modif CR/FH 20110310 : alp integree sur la verticale.
-! Integrale verticale de ALP.
-! wth3 etant aux niveaux inter-couches, on utilise d play comme masse des
-! couches
-!------------------------------------------------------------------------
-
-      alp_int(:)=0.
-      dp_int(:)=0.
-      do l=2,nlay
-        do ig=1,ngrid
-           if(l.LE.lmax(ig)) THEN
-           zdp=pplay(ig,l-1)-pplay(ig,l)
-           alp_int(ig)=alp_int(ig)+0.5*rhobarz(ig,l)*wth3(ig,l)*zdp
-           dp_int(ig)=dp_int(ig)+zdp
-           endif
-        enddo
-      enddo
-
-      if (iflag_coupl>=3 .and. iflag_coupl<=5) then
-      do ig=1,ngrid
-!valeur integree de alp_bl * 0.5:
-        if (dp_int(ig)>0.) then
-        alp_bl(ig)=alp_int(ig)/dp_int(ig)
-        endif
-      enddo!
-      endif
-
-
-! Facteur multiplicatif sur alp_bl
-      alp_bl(:)=alp_bl_k*alp_bl(:)
-
-!------------------------------------------------------------------------
-
-
-
-      return
-      end
-END MODULE lmdz_thermcell_alp
Index: /LMDZ6/trunk/libf/phylmd/lmdz_thermcell_alp.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/lmdz_thermcell_alp.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/lmdz_thermcell_alp.f90	(revision 5268)
@@ -0,0 +1,428 @@
+MODULE lmdz_thermcell_alp
+! $Id: thermcell_main.F90 2351 2015-08-25 15:14:59Z emillour $
+!
+CONTAINS
+
+      SUBROUTINE thermcell_alp(ngrid,nlay,ptimestep  &                         ! in
+     &                  ,pplay,pplev  &                                        ! in
+     &                  ,fm0,entr0,lmax  &                                     ! in
+     &                  ,pbl_tke,pctsrf,omega,airephy &                        ! in
+     &                  ,zw2,fraca &                                           ! in
+     &                  ,pcon,rhobarz,wth3,wmax_sec,lalim,fm,alim_star,zmax &  ! in
+!
+     &                  ,zcong,ale_bl,alp_bl,lalim_conv,wght_th &                    ! out
+     &                  ,zlcl,fraca0,w0,w_conv,therm_tke_max0,env_tke_max0 &   ! out
+     &                  ,n2,s2,strig,ale_bl_stat &                                   ! out
+     &                  ,therm_tke_max,env_tke_max &                           ! out
+     &                  ,alp_bl_det,alp_bl_fluct_m,alp_bl_fluct_tke &          ! out
+     &                  ,alp_bl_conv,alp_bl_stat &                             ! out
+     &)
+
+      USE indice_sol_mod
+      USE lmdz_thermcell_main, ONLY : thermcell_tke_transport
+      IMPLICIT NONE
+
+!=======================================================================
+!
+!   Auteurs: Catherine Rio
+!   Modifications :
+!   Nicolas Rochetin et Jean-Yves Grandpeix
+!         pour la fermeture stochastique. 2012
+!   Frédéric Hourdin :
+!         netoyage informatique. 2022
+!   
+!=======================================================================
+!-----------------------------------------------------------------------
+!   declarations:
+!   -------------
+
+      INCLUDE "YOMCST.h"
+      INCLUDE "YOETHF.h"
+      INCLUDE "FCTTRE.h"
+      INCLUDE "alpale.h"
+
+!   arguments:
+!   ----------
+
+!------Entrees
+      integer, intent(in) :: ngrid,nlay
+      real, intent(in) :: ptimestep
+      real, intent(in) :: pplay(ngrid,nlay),pplev(ngrid,nlay+1)
+      integer, intent(in), dimension(ngrid) ::lmax,lalim
+      real, intent(in), dimension(ngrid) :: zmax, zcong
+      real, intent(in), dimension(ngrid,nlay+1) :: zw2
+      real, intent(in), dimension(ngrid,nlay+1) :: fraca
+      real, intent(in), dimension(ngrid,nlay) :: wth3
+      real, intent(in), dimension(ngrid,nlay) :: rhobarz
+      real, intent(in), dimension(ngrid) :: wmax_sec
+      real, intent(in), dimension(ngrid,nlay) :: entr0
+      real, intent(in), dimension(ngrid,nlay+1) :: fm0,fm
+      real, intent(in), dimension(ngrid) :: pcon
+      real, intent(in), dimension(ngrid,nlay) :: alim_star
+      real, intent(in), dimension(ngrid,nlay+1,nbsrf) :: pbl_tke
+      real, intent(in), dimension(ngrid,nbsrf) :: pctsrf
+      real, intent(in), dimension(ngrid,nlay) :: omega
+      real, intent(in), dimension(ngrid) :: airephy
+!------Sorties
+      real, intent(out), dimension(ngrid) :: ale_bl,alp_bl
+      real, intent(out), dimension(ngrid,nlay) :: wght_th
+      integer, intent(out), dimension(ngrid) :: lalim_conv
+      real, intent(out), dimension(ngrid) :: zlcl,fraca0,w0,w_conv
+      real, intent(out), dimension(ngrid) :: therm_tke_max0,env_tke_max0,n2,s2,ale_bl_stat,strig
+      real, intent(out), dimension(ngrid,nlay) :: therm_tke_max,env_tke_max
+      real, intent(out), dimension(ngrid) :: alp_bl_det,alp_bl_fluct_m,alp_bl_fluct_tke
+      real, intent(out), dimension(ngrid) :: alp_bl_conv,alp_bl_stat
+
+!=============================================================================================
+!------Local
+!=============================================================================================
+
+      REAL susqr2pi, reuler
+      INTEGER ig,k,l
+      integer nsrf
+      real rhobarz0(ngrid)                    ! Densité au LCL
+      logical ok_lcl(ngrid)                   ! Existence du LCL des thermiques
+      integer klcl(ngrid)                     ! Niveau du LCL
+      real interp(ngrid)                      ! Coef d'interpolation pour le LCL
+!--Triggering
+      real, parameter :: su_cst=4e4              ! Surface unite: celle d'un updraft élémentaire
+      real, parameter :: hcoef=1             ! Coefficient directeur pour le calcul de s2
+      real, parameter :: hmincoef=0.3        ! Coefficient directeur pour l'ordonnée à l'origine pour le calcul de s2 
+      real, parameter :: eps1=0.3            ! Fraction de surface occupée par la population 1 : eps1=n1*s1/(fraca0*Sd)
+      real, dimension(ngrid) :: hmin         ! Ordonnée à l'origine pour le calcul de s2
+      real, dimension(ngrid) :: zmax_moy     ! Hauteur moyenne des thermiques : zmax_moy = zlcl + 0.33 (zmax-zlcl)
+      real, parameter :: zmax_moy_coef=0.33
+      real, dimension(ngrid) :: depth        ! Epaisseur moyenne du cumulus
+      real, dimension(ngrid) :: zcong_moy 
+      real, dimension(ngrid) ::  w_max                 ! Vitesse max statistique 
+      real, dimension(ngrid) ::  s_max(ngrid)
+!--Closure
+      real, dimension(ngrid,nlay) :: pbl_tke_max       ! Profil de TKE moyenne 
+      real, dimension(ngrid) :: pbl_tke_max0           ! TKE moyenne au LCL
+      real, dimension(ngrid,nlay) :: w_ls              ! Vitesse verticale grande échelle (m/s)
+      real, parameter :: coef_m=1.            ! On considère un rendement pour alp_bl_fluct_m
+      real, parameter :: coef_tke=1.          ! On considère un rendement pour alp_bl_fluct_tke
+      real :: zdp
+      real, dimension(ngrid) :: alp_int,dp_int
+      real, dimension(ngrid) :: fm_tot
+
+!------------------------------------------------------------
+!  Initialize output arrays related to stochastic triggering
+!------------------------------------------------------------
+  DO ig = 1,ngrid
+     zlcl(ig) = 0.
+     fraca0(ig) = 0.
+     w0(ig) = 0.
+     w_conv(ig) = 0.
+     therm_tke_max0(ig) = 0.
+     env_tke_max0(ig) = 0.
+     n2(ig) = 0.
+     s2(ig) = 0.
+     ale_bl_stat(ig) = 0.
+     strig(ig) = 0.
+     alp_bl_det(ig) = 0.
+     alp_bl_fluct_m(ig) = 0.
+     alp_bl_fluct_tke(ig) = 0.
+     alp_bl_conv(ig) = 0.
+     alp_bl_stat(ig) = 0.
+  ENDDO
+  DO l = 1,nlay
+    DO ig = 1,ngrid
+     therm_tke_max(ig,l) = 0.
+     env_tke_max(ig,l) = 0.
+    ENDDO
+  ENDDO
+
+!------------Test sur le LCL des thermiques
+    do ig=1,ngrid
+      ok_lcl(ig)=.false.
+      if ( (pcon(ig) .gt. pplay(ig,nlay-1)) .and. (pcon(ig) .lt. pplay(ig,1)) ) ok_lcl(ig)=.true.
+    enddo
+
+!------------Localisation des niveaux entourant le LCL et du coef d'interpolation
+    do l=1,nlay-1
+      do ig=1,ngrid
+        if (ok_lcl(ig)) then 
+!ATTENTION,zw2 calcule en pplev
+!          if ((pplay(ig,l) .ge. pcon(ig)) .and. (pplay(ig,l+1) .le. pcon(ig))) then
+!          klcl(ig)=l
+!          interp(ig)=(pcon(ig)-pplay(ig,klcl(ig)))/(pplay(ig,klcl(ig)+1)-pplay(ig,klcl(ig)))
+!          endif
+          if ((pplev(ig,l) .ge. pcon(ig)) .and. (pplev(ig,l+1) .le. pcon(ig))) then
+          klcl(ig)=l
+          interp(ig)=(pcon(ig)-pplev(ig,klcl(ig)))/(pplev(ig,klcl(ig)+1)-pplev(ig,klcl(ig)))
+          endif
+        endif
+      enddo
+    enddo
+
+    do ig =1,ngrid
+!CR:REHABILITATION ZMAX CONTINU
+     if (ok_lcl(ig)) then 
+      rhobarz0(ig)=rhobarz(ig,klcl(ig))+(rhobarz(ig,klcl(ig)+1) &
+ &               -rhobarz(ig,klcl(ig)))*interp(ig)
+      zlcl(ig)=(pplev(ig,1)-pcon(ig))/(rhobarz0(ig)*RG)
+      zlcl(ig)=min(zlcl(ig),zmax(ig))   ! Si zlcl > zmax alors on pose zlcl = zmax
+     else
+      rhobarz0(ig)=0.
+      zlcl(ig)=zmax(ig)
+     endif
+    enddo
+!!jyg fin
+
+!------------Calcul des propriétés du thermique au LCL 
+  IF ( (iflag_trig_bl.ge.1) .or. (iflag_clos_bl.ge.1) ) THEN 
+
+  !-----Initialisation de la TKE moyenne 
+   do l=1,nlay
+    do ig=1,ngrid
+     pbl_tke_max(ig,l)=0.
+    enddo
+   enddo
+
+!-----Calcul de la TKE moyenne 
+   do nsrf=1,nbsrf
+    do l=1,nlay
+     do ig=1,ngrid
+     pbl_tke_max(ig,l)=pctsrf(ig,nsrf)*pbl_tke(ig,l,nsrf)+pbl_tke_max(ig,l)
+     enddo
+    enddo
+   enddo
+
+!-----Initialisations des TKE dans et hors des thermiques 
+   do l=1,nlay
+    do ig=1,ngrid
+    therm_tke_max(ig,l)=pbl_tke_max(ig,l)
+    env_tke_max(ig,l)=pbl_tke_max(ig,l)
+    enddo
+   enddo
+
+!-----Calcul de la TKE transportée par les thermiques : therm_tke_max
+   call thermcell_tke_transport(ngrid,nlay,ptimestep,fm0,entr0,  &  ! in
+  &           rg,pplev,therm_tke_max)                               ! out
+!   print *,' thermcell_tke_transport -> '   !!jyg
+
+!-----Calcul des profils verticaux de TKE hors thermiques : env_tke_max, et de la vitesse verticale grande échelle : W_ls
+   do l=1,nlay
+    do ig=1,ngrid
+     pbl_tke_max(ig,l)=fraca(ig,l)*therm_tke_max(ig,l)+(1.-fraca(ig,l))*env_tke_max(ig,l)         !  Recalcul de TKE moyenne aprés transport de TKE_TH
+     env_tke_max(ig,l)=(pbl_tke_max(ig,l)-fraca(ig,l)*therm_tke_max(ig,l))/(1.-fraca(ig,l))       !  Recalcul de TKE dans  l'environnement aprés transport de TKE_TH
+     w_ls(ig,l)=-1.*omega(ig,l)/(RG*rhobarz(ig,l))                                                !  Vitesse verticale de grande échelle
+    enddo
+   enddo
+!    print *,' apres w_ls = '   !!jyg
+
+  do ig=1,ngrid
+   if (ok_lcl(ig)) then
+     fraca0(ig)=fraca(ig,klcl(ig))+(fraca(ig,klcl(ig)+1) &
+ &             -fraca(ig,klcl(ig)))*interp(ig)
+     w0(ig)=zw2(ig,klcl(ig))+(zw2(ig,klcl(ig)+1) &
+ &         -zw2(ig,klcl(ig)))*interp(ig)
+     w_conv(ig)=w_ls(ig,klcl(ig))+(w_ls(ig,klcl(ig)+1) &
+ &             -w_ls(ig,klcl(ig)))*interp(ig)
+     therm_tke_max0(ig)=therm_tke_max(ig,klcl(ig)) &
+ &                     +(therm_tke_max(ig,klcl(ig)+1)-therm_tke_max(ig,klcl(ig)))*interp(ig)
+     env_tke_max0(ig)=env_tke_max(ig,klcl(ig))+(env_tke_max(ig,klcl(ig)+1) &
+ &                   -env_tke_max(ig,klcl(ig)))*interp(ig)
+     pbl_tke_max0(ig)=pbl_tke_max(ig,klcl(ig))+(pbl_tke_max(ig,klcl(ig)+1) &
+ &                   -pbl_tke_max(ig,klcl(ig)))*interp(ig)
+     if (therm_tke_max0(ig).ge.20.) therm_tke_max0(ig)=20.
+     if (env_tke_max0(ig).ge.20.) env_tke_max0(ig)=20.
+     if (pbl_tke_max0(ig).ge.20.) pbl_tke_max0(ig)=20.
+   else 
+     fraca0(ig)=0.
+     w0(ig)=0.
+!!jyg le 27/04/2012
+!!     zlcl(ig)=0.
+!!
+   endif
+  enddo
+
+  ENDIF ! IF ( (iflag_trig_bl.ge.1) .or. (iflag_clos_bl.ge.1) )
+!  print *,'ENDIF  ( (iflag_trig_bl.ge.1) .or. (iflag_clos_bl.ge.1) ) '    !!jyg
+
+!------------Triggering------------------
+  IF (iflag_trig_bl.ge.1) THEN 
+
+!-----Initialisations
+   depth(:)=0.
+   n2(:)=0.
+   s2(:)=100. ! some low value, arbitrary
+   s_max(:)=0.
+
+
+
+!-----Epaisseur du nuage (depth) et détermination de la queue du spectre de panaches (n2,s2) et du panache le plus gros (s_max)
+   do ig=1,ngrid
+     zmax_moy(ig)=zlcl(ig)+zmax_moy_coef*(zmax(ig)-zlcl(ig))
+     depth(ig)=zmax_moy(ig)-zlcl(ig)
+     hmin(ig)=hmincoef*zlcl(ig)
+     if (depth(ig).ge.10.) then 
+       s2(ig)=(hcoef*depth(ig)+hmin(ig))**2
+       n2(ig)=(1.-eps1)*fraca0(ig)*airephy(ig)/s2(ig)
+!!
+!!jyg le 27/04/2012
+!!       s_max(ig)=s2(ig)*log(n2(ig))
+!!       if (n2(ig) .lt. 1) s_max(ig)=0.
+       s_max(ig)=s2(ig)*log(max(n2(ig),1.))
+!!fin jyg
+     else
+       n2(ig)=0.
+       s_max(ig)=0.
+     endif
+   enddo
+!   print *,'avant Calcul de Wmax '    !!jyg
+
+!CR: calcul de strig
+   if (iflag_strig.eq.0) then
+      strig(:)=s_trig
+   else if (iflag_strig.eq.1) then
+      do ig=1,ngrid
+!         zcong_moy(ig)=zlcl(ig)+zmax_moy_coef*(zcong(ig)-zlcl(ig))
+!         strig(ig)=(hcoef*(zcong_moy(ig)-zlcl(ig))+hmin(ig))**2  
+         strig(ig)=(zcong(ig)-zlcl(ig))**2  
+      enddo
+   else if (iflag_strig.eq.2) then
+      do ig=1,ngrid 
+         if (h_trig.gt.zlcl(ig)) then
+         strig(ig)=(h_trig-zlcl(ig))**2
+         else
+         strig(ig)=s_trig
+         endif
+      enddo   
+   endif
+
+   susqr2pi=su_cst*sqrt(2.*Rpi)
+   reuler=exp(1.)
+   do ig=1,ngrid
+     if ( (depth(ig).ge.10.) .and. (s_max(ig).gt.susqr2pi*reuler) ) then
+      w_max(ig)=w0(ig)*(1.+sqrt(2.*log(s_max(ig)/susqr2pi)-log(2.*log(s_max(ig)/susqr2pi))))
+      ale_bl_stat(ig)=0.5*w_max(ig)**2
+     else
+      w_max(ig)=0.
+      ale_bl_stat(ig)=0.
+     endif
+   enddo
+
+  ENDIF ! iflag_trig_bl
+!  print *,'ENDIF  iflag_trig_bl'    !!jyg
+
+!------------Closure------------------
+
+  IF (iflag_clos_bl.ge.2) THEN 
+
+!-----Calcul de ALP_BL_STAT
+  do ig=1,ngrid
+  alp_bl_det(ig)=0.5*coef_m*rhobarz0(ig)*(w0(ig)**3)*fraca0(ig)*(1.-2.*fraca0(ig))/((1.-fraca0(ig))**2)
+  alp_bl_fluct_m(ig)=1.5*rhobarz0(ig)*fraca0(ig)*(w_conv(ig)+coef_m*w0(ig))* &
+ &                   (w0(ig)**2)
+  alp_bl_fluct_tke(ig)=3.*coef_m*rhobarz0(ig)*w0(ig)*fraca0(ig)*(therm_tke_max0(ig)-env_tke_max0(ig)) &
+ &                    +3.*rhobarz0(ig)*w_conv(ig)*pbl_tke_max0(ig)
+    if (iflag_clos_bl.ge.2) then 
+    alp_bl_conv(ig)=1.5*coef_m*rhobarz0(ig)*fraca0(ig)*(fraca0(ig)/(1.-fraca0(ig)))*w_conv(ig)* &
+ &                   (w0(ig)**2)
+    else
+    alp_bl_conv(ig)=0.
+    endif
+  alp_bl_stat(ig)=alp_bl_det(ig)+alp_bl_fluct_m(ig)+alp_bl_fluct_tke(ig)+alp_bl_conv(ig)
+  enddo
+
+!-----Sécurité ALP infinie
+  do ig=1,ngrid
+   if (fraca0(ig).gt.0.98) alp_bl_stat(ig)=2.
+  enddo
+
+  ENDIF ! (iflag_clos_bl.ge.2)
+
+!!! fin nrlmd le 10/04/2012
+
+!      print*,'avant calcul ale et alp' 
+!calcul de ALE et ALP pour la convection
+      alp_bl(:)=0.
+      ale_bl(:)=0.
+!          print*,'ALE,ALP ,l,zw2(ig,l),ale_bl(ig),alp_bl(ig)'
+      do l=1,nlay
+      do ig=1,ngrid
+           alp_bl(ig)=max(alp_bl(ig),0.5*rhobarz(ig,l)*wth3(ig,l) )
+           ale_bl(ig)=max(ale_bl(ig),0.5*zw2(ig,l)**2)
+!          print*,'ALE,ALP',l,zw2(ig,l),ale_bl(ig),alp_bl(ig)
+      enddo
+      enddo
+
+! ale sec (max de wmax/2 sous la zone d'inhibition) dans
+! le cas iflag_trig_bl=3
+      IF (iflag_trig_bl==3) ale_bl(:)=0.5*wmax_sec(:)**2
+
+!test:calcul de la ponderation des couches pour KE
+!initialisations
+
+      fm_tot(:)=0.
+      wght_th(:,:)=1.
+      lalim_conv(:)=lalim(:)
+
+      do k=1,nlay
+         do ig=1,ngrid
+            if (k<=lalim_conv(ig)) fm_tot(ig)=fm_tot(ig)+fm(ig,k)
+         enddo
+      enddo
+
+! assez bizarre car, si on est dans la couche d'alim et que alim_star et
+! plus petit que 1.e-10, on prend wght_th=1.
+      do k=1,nlay
+         do ig=1,ngrid
+            if (k<=lalim_conv(ig).and.alim_star(ig,k)>1.e-10) then
+               wght_th(ig,k)=alim_star(ig,k)
+            endif
+         enddo
+      enddo
+
+!      print*,'apres wght_th'
+!test pour prolonger la convection
+      do ig=1,ngrid
+!v1d  if ((alim_star(ig,1).lt.1.e-10).and.(therm)) then
+      if ((alim_star(ig,1).lt.1.e-10)) then
+      lalim_conv(ig)=1
+      wght_th(ig,1)=1.
+!      print*,'lalim_conv ok',lalim_conv(ig),wght_th(ig,1)
+      endif
+      enddo
+
+!------------------------------------------------------------------------
+! Modif CR/FH 20110310 : alp integree sur la verticale.
+! Integrale verticale de ALP.
+! wth3 etant aux niveaux inter-couches, on utilise d play comme masse des
+! couches
+!------------------------------------------------------------------------
+
+      alp_int(:)=0.
+      dp_int(:)=0.
+      do l=2,nlay
+        do ig=1,ngrid
+           if(l.LE.lmax(ig)) THEN
+           zdp=pplay(ig,l-1)-pplay(ig,l)
+           alp_int(ig)=alp_int(ig)+0.5*rhobarz(ig,l)*wth3(ig,l)*zdp
+           dp_int(ig)=dp_int(ig)+zdp
+           endif
+        enddo
+      enddo
+
+      if (iflag_coupl>=3 .and. iflag_coupl<=5) then
+      do ig=1,ngrid
+!valeur integree de alp_bl * 0.5:
+        if (dp_int(ig)>0.) then
+        alp_bl(ig)=alp_int(ig)/dp_int(ig)
+        endif
+      enddo!
+      endif
+
+
+! Facteur multiplicatif sur alp_bl
+      alp_bl(:)=alp_bl_k*alp_bl(:)
+
+!------------------------------------------------------------------------
+
+
+
+      return
+      end
+END MODULE lmdz_thermcell_alp
Index: DZ6/trunk/libf/phylmd/lmdz_thermcell_closure.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/lmdz_thermcell_closure.F90	(revision 5267)
+++ 	(revision )
@@ -1,75 +1,0 @@
-MODULE lmdz_thermcell_closure
-!
-! $Header$
-!
-CONTAINS
-
-      SUBROUTINE thermcell_closure(ngrid,nlay,r_aspect,ptimestep,rho,  &
-     &   zlev,lalim,alim_star,zmax,wmax,f)
-
-!-------------------------------------------------------------------------
-!thermcell_closure: fermeture, determination de f
-!
-! Modification 7 septembre 2009
-! 1. On enleve alim_star_tot des arguments pour le recalculer et etre ainis
-! coherent avec l'integrale au numerateur.
-! 2. On ne garde qu'une version des couples wmax,zmax et wmax_sec,zmax_sec
-! l'idee etant que le choix se fasse a l'appel de thermcell_closure
-! 3. Vectorisation en mettant les boucles en l l'exterieur avec des if
-!-------------------------------------------------------------------------
-      IMPLICIT NONE
-
-! --- arguments ------------------------------------------
-integer, intent(in) :: ngrid,nlay
-real, intent(in) :: r_aspect,ptimestep
-real, intent(in), dimension(ngrid,nlay) :: alim_star,rho,zlev
-integer, intent(in), dimension(ngrid) :: lalim
-real, intent(in), dimension(ngrid) :: zmax,wmax
-
-real, intent(out), dimension(ngrid) :: f
-
-
-! --- local ------------------------------------------
-real, dimension(ngrid) :: zdenom,alim_star2,alim_star_tot
-INTEGER llmax
-INTEGER ig,k       
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!print*,'THERMCELL CLOSURE 26E'
-
-alim_star2(:)=0.
-alim_star_tot(:)=0.
-f(:)=0.
-
-! Indice vertical max (max de lalim) atteint par les thermiques sur le domaine
-llmax=1
-do ig=1,ngrid
-   if (lalim(ig)>llmax) llmax=lalim(ig)
-enddo
-
-
-! Calcul des integrales sur la verticale de alim_star et de
-!   alim_star^2/(rho dz)
-do k=1,llmax-1
-   do ig=1,ngrid
-      if (k<lalim(ig)) then
-         alim_star2(ig)=alim_star2(ig)+alim_star(ig,k)**2  &
-&                    /(rho(ig,k)*(zlev(ig,k+1)-zlev(ig,k)))
-         alim_star_tot(ig)=alim_star_tot(ig)+alim_star(ig,k)
-      endif
-   enddo
-enddo
-
-
-do ig=1,ngrid
-   if (alim_star2(ig)>1.e-10) then
-      f(ig)=wmax(ig)*alim_star_tot(ig)/  &
-&     (max(500.,zmax(ig))*r_aspect*alim_star2(ig))
-   endif
-enddo
-
-
-
- RETURN
-      end
-END MODULE lmdz_thermcell_closure
Index: /LMDZ6/trunk/libf/phylmd/lmdz_thermcell_closure.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/lmdz_thermcell_closure.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/lmdz_thermcell_closure.f90	(revision 5268)
@@ -0,0 +1,75 @@
+MODULE lmdz_thermcell_closure
+!
+! $Header$
+!
+CONTAINS
+
+      SUBROUTINE thermcell_closure(ngrid,nlay,r_aspect,ptimestep,rho,  &
+     &   zlev,lalim,alim_star,zmax,wmax,f)
+
+!-------------------------------------------------------------------------
+!thermcell_closure: fermeture, determination de f
+!
+! Modification 7 septembre 2009
+! 1. On enleve alim_star_tot des arguments pour le recalculer et etre ainis
+! coherent avec l'integrale au numerateur.
+! 2. On ne garde qu'une version des couples wmax,zmax et wmax_sec,zmax_sec
+! l'idee etant que le choix se fasse a l'appel de thermcell_closure
+! 3. Vectorisation en mettant les boucles en l l'exterieur avec des if
+!-------------------------------------------------------------------------
+      IMPLICIT NONE
+
+! --- arguments ------------------------------------------
+integer, intent(in) :: ngrid,nlay
+real, intent(in) :: r_aspect,ptimestep
+real, intent(in), dimension(ngrid,nlay) :: alim_star,rho,zlev
+integer, intent(in), dimension(ngrid) :: lalim
+real, intent(in), dimension(ngrid) :: zmax,wmax
+
+real, intent(out), dimension(ngrid) :: f
+
+
+! --- local ------------------------------------------
+real, dimension(ngrid) :: zdenom,alim_star2,alim_star_tot
+INTEGER llmax
+INTEGER ig,k       
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!print*,'THERMCELL CLOSURE 26E'
+
+alim_star2(:)=0.
+alim_star_tot(:)=0.
+f(:)=0.
+
+! Indice vertical max (max de lalim) atteint par les thermiques sur le domaine
+llmax=1
+do ig=1,ngrid
+   if (lalim(ig)>llmax) llmax=lalim(ig)
+enddo
+
+
+! Calcul des integrales sur la verticale de alim_star et de
+!   alim_star^2/(rho dz)
+do k=1,llmax-1
+   do ig=1,ngrid
+      if (k<lalim(ig)) then
+         alim_star2(ig)=alim_star2(ig)+alim_star(ig,k)**2  &
+&                    /(rho(ig,k)*(zlev(ig,k+1)-zlev(ig,k)))
+         alim_star_tot(ig)=alim_star_tot(ig)+alim_star(ig,k)
+      endif
+   enddo
+enddo
+
+
+do ig=1,ngrid
+   if (alim_star2(ig)>1.e-10) then
+      f(ig)=wmax(ig)*alim_star_tot(ig)/  &
+&     (max(500.,zmax(ig))*r_aspect*alim_star2(ig))
+   endif
+enddo
+
+
+
+ RETURN
+      end
+END MODULE lmdz_thermcell_closure
Index: DZ6/trunk/libf/phylmd/lmdz_thermcell_down.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/lmdz_thermcell_down.F90	(revision 5267)
+++ 	(revision )
@@ -1,304 +1,0 @@
-MODULE lmdz_thermcell_down
-CONTAINS
-
-SUBROUTINE thermcell_updown_dq(ngrid,nlay,ptimestep,lmax,eup,dup,edn,ddn,masse,trac,dtrac)
-
-USE lmdz_thermcell_ini, ONLY: iflag_thermals_down
-
-
-!-----------------------------------------------------------------
-! thermcell_updown_dq: computes the tendency of tracers associated
-! with the presence of convective up/down drafts
-! This routine that has been collectively written during the 
-! "ateliers downdrafts" in 2022/2023
-! Maelle, Frédéric, Catherine, Fleur, Florent, Etienne
-!------------------------------------------------------------------
-
-
-   IMPLICIT NONE
-
-! declarations
-!==============================================================
-
-! input/output
-
-   integer,intent(in)  :: ngrid ! number of horizontal grid points
-   integer, intent(in) :: nlay  ! number of vertical layers
-   real,intent(in) :: ptimestep ! time step of the physics [s]
-   real,intent(in), dimension(ngrid,nlay) :: eup ! entrainment to updrafts * dz [same unit as flux]
-   real,intent(in), dimension(ngrid,nlay) :: dup ! detrainment from updrafts * dz [same unit as flux]
-   real,intent(in), dimension(ngrid,nlay) :: edn ! entrainment to downdrafts * dz [same unit as flux]
-   real,intent(in), dimension(ngrid,nlay) :: ddn ! detrainment from downdrafts * dz [same unit as flux]
-   real,intent(in), dimension(ngrid,nlay) :: masse ! mass of layers = rho dz 
-   real,intent(in), dimension(ngrid,nlay) :: trac ! tracer 
-   integer, intent(in), dimension(ngrid) :: lmax ! max level index at which downdraft are present
-   real,intent(out),dimension(ngrid,nlay) ::dtrac ! tendance du traceur
-
-   
-! Local
-
-   real, dimension(ngrid,nlay+1) :: fup,fdn,fc,fthu,fthd,fthe,fthtot
-   real, dimension(ngrid,nlay) :: tracu,tracd,traci,tracold
-   real :: www, mstar_inv
-   integer ig,ilay
-   real, dimension(ngrid,nlay):: s1,s2,num !coefficients pour la resolution implicite
-   integer :: iflag_impl=1 ! 0 pour explicite, 1 pour implicite "classique", 2 pour implicite avec entrainement et detrainement
-   
-   fdn(:,:)=0.
-   fup(:,:)=0.
-   fc(:,:)=0.
-   fthu(:,:)=0.
-   fthd(:,:)=0.
-   fthe(:,:)=0.
-   fthtot(:,:)=0.
-   tracd(:,:)=0.
-   tracu(:,:)=0.
-   traci(:,:)=trac(:,:)
-   tracold(:,:)=trac(:,:)
-   s1(:,:)=0.
-   s2(:,:)=0.
-   num(:,:)=1.
-
-   if ( iflag_thermals_down < 10 ) then
-      call abort_physic("thermcell_updown_dq", &
-           'thermcell_down_dq = 0 or >= 10', 1)
-   else
-        iflag_impl=iflag_thermals_down-10
-   endif
-      
-
-   ! lmax : indice tel que fu(kmax+1)=0
-   ! Dans ce cas, pas besoin d'initialiser tracd(lmax) ( =trac(lmax) )
-   ! Boucle pour le downdraft
-   do ilay=nlay,1,-1
-      do ig=1,ngrid
-         !if ( lmax(ig) > nlay - 2 ) stop "les thermiques montent trop haut"
-         if (ilay.le.lmax(ig) .and. lmax(ig)>1 ) then
-            fdn(ig,ilay)=fdn(ig,ilay+1)+edn(ig,ilay)-ddn(ig,ilay)
-            if ( fdn(ig,ilay)+ddn(ig,ilay) > 0. ) then
-               www=fdn(ig,ilay+1)/ (fdn(ig,ilay)+ddn(ig,ilay))
-            else
-               www=0.
-            endif
-            tracd(ig,ilay)=www*tracd(ig,ilay+1) + (1.-www)*trac(ig,ilay)
-         endif
-      enddo 
-   enddo !Fin boucle sur l'updraft
-   fdn(:,1)=0.
-
-   !Boucle pour l'updraft
-   do ilay=1,nlay,1
-      do ig=1,ngrid
-         if (ilay.lt.lmax(ig) .and. lmax(ig)>1) then
-            fup(ig,ilay+1)=fup(ig,ilay)+eup(ig,ilay)-dup(ig,ilay)
-            if (fup(ig,ilay+1)+dup(ig,ilay) > 0.) then
-               www=fup(ig,ilay)/(fup(ig,ilay+1)+dup(ig,ilay))
-            else
-               www=0.
-            endif
-            if (ilay == 1 ) then
-               tracu(ig,ilay)=trac(ig,ilay)
-            else
-               tracu(ig,ilay)=www*tracu(ig,ilay-1)+(1.-www)*trac(ig,ilay)
-            endif
-         endif
-      enddo 
-      enddo !fin boucle sur le downdraft
-
-   ! Calcul des flux des traceurs dans les updraft et les downdrfat 
-   ! et du flux de masse compensateur
-   ! en ilay=1 et nlay+1, fthu=0 et fthd=0
-   fthu(:,1)=0.
-   fthu(:,nlay+1)=0.
-   fthd(:,1)=0.
-   fthd(:,nlay+1)=0.
-   fc(:,1)=0.
-   fc(:,nlay+1)=0.
-   do ilay=2,nlay,1 !boucle sur les interfaces
-     do ig=1,ngrid
-       fthu(ig,ilay)=fup(ig,ilay)*tracu(ig,ilay-1)
-       fthd(ig,ilay)=-fdn(ig,ilay)*tracd(ig,ilay)
-       fc(ig,ilay)=fup(ig,ilay)-fdn(ig,ilay)
-     enddo
-   enddo
-   
-
-   !Boucle pour calculer le flux du traceur flux updraft, flux downdraft, flux compensatoire
-   !Methode explicite : 
-   if(iflag_impl==0) then
-     do ilay=2,nlay,1
-       do ig=1,ngrid
-         !!!!ATTENTION HYPOTHESE de FLUX COMPENSATOIRE DESCENDANT ET DONC comme schema amont on va chercher trac au dessus!!!!!
-         !!!! tentative de prise en compte d'un flux compensatoire montant  !!!!
-         if (fup(ig,ilay)-fdn(ig,ilay) .lt. 0.) then
-            call abort_physic("thermcell_updown_dq", 'flux compensatoire '&
-                 // 'montant, cas non traite par thermcell_updown_dq', 1)
-            !fthe(ig,ilay)=(fup(ig,ilay)-fdn(ig,ilay))*trac(ig,ilay-1)
-         else
-            fthe(ig,ilay)=-(fup(ig,ilay)-fdn(ig,ilay))*trac(ig,ilay)
-         endif
-         !! si on voulait le prendre en compte on
-         !fthe(ig,ilay)=-(fup(ig,ilay)-fdn(ig,ilay))*trac(ig,ilay-1)
-         fthtot(ig,ilay)=fthu(ig,ilay)+fthd(ig,ilay)+fthe(ig,ilay)
-       enddo
-     enddo
-     !Boucle pour calculer trac
-     do ilay=1,nlay
-       do ig=1,ngrid
-         dtrac(ig,ilay)=(fthtot(ig,ilay)-fthtot(ig,ilay+1))/masse(ig,ilay)
-!         trac(ig,ilay)=trac(ig,ilay) + (fthtot(ig,ilay)-fthtot(ig,ilay+1))*(ptimestep/masse(ig,ilay))
-       enddo
-     enddo !fin du calculer de la tendance du traceur avec la methode explicite
-
-   !!! Reecriture du schéma explicite avec les notations du schéma implicite
-   else if(iflag_impl==-1) then
-     write(*,*) 'nouveau schéma explicite !!!'
-     !!! Calcul de s1
-     do ilay=1,nlay
-       do ig=1,ngrid
-         s1(ig,ilay)=fthu(ig,ilay)-fthu(ig,ilay+1)+fthd(ig,ilay)-fthd(ig,ilay+1)
-         s2(ig,ilay)=s1(ig,ilay)+fthe(ig,ilay)-fthe(ig,ilay+1)
-       enddo
-     enddo
-
-     do ilay=2,nlay,1
-       do ig=1,ngrid
-         if (fup(ig,ilay)-fdn(ig,ilay) .lt. 0.) then
-            call abort_physic("thermcell_updown_dq", 'flux compensatoire ' &
-                 // 'montant, cas non traite par thermcell_updown_dq', 1)
-         else
-            fthe(ig,ilay)=-(fup(ig,ilay)-fdn(ig,ilay))*trac(ig,ilay)
-         endif
-         fthtot(ig,ilay)=fthu(ig,ilay)+fthd(ig,ilay)+fthe(ig,ilay)
-       enddo
-     enddo
-     !Boucle pour calculer trac
-     do ilay=1,nlay
-       do ig=1,ngrid
-         ! dtrac(ig,ilay)=(fthtot(ig,ilay)-fthtot(ig,ilay+1))/masse(ig,ilay)
-         dtrac(ig,ilay)=(s1(ig,ilay)+fthe(ig,ilay)-fthe(ig,ilay+1))/masse(ig,ilay)
-!         trac(ig,ilay)=trac(ig,ilay) + (fthtot(ig,ilay)-fthtot(ig,ilay+1))*(ptimestep/masse(ig,ilay))
-!         trac(ig,ilay)=trac(ig,ilay) + (s1(ig,ilay)+fthe(ig,ilay)-fthe(ig,ilay+1))*(ptimestep/masse(ig,ilay))
-       enddo
-     enddo !fin du calculer de la tendance du traceur avec la methode explicite
-
-   else if (iflag_impl==1) then
-     do ilay=1,nlay
-       do ig=1,ngrid
-         s1(ig,ilay)=fthu(ig,ilay)-fthu(ig,ilay+1)+fthd(ig,ilay)-fthd(ig,ilay+1)
-       enddo
-     enddo
-     
-     !Boucle pour calculer traci = trac((t+dt)
-     do ilay=nlay-1,1,-1
-       do ig=1,ngrid
-         if((fup(ig,ilay)-fdn(ig,ilay)) .lt. 0) then
-            write(*,*) 'flux compensatoire montant, cas non traite par thermcell_updown_dq dans le cas d une resolution implicite, ilay : ', ilay
-            call abort_physic("thermcell_updown_dq", "", 1)
-         else
-           mstar_inv=ptimestep/masse(ig,ilay)
-           traci(ig,ilay)=((traci(ig,ilay+1)*fc(ig,ilay+1)+s1(ig,ilay))*mstar_inv+tracold(ig,ilay))/(1.+fc(ig,ilay)*mstar_inv)
-         endif
-       enddo
-     enddo
-     do ilay=1,nlay
-       do ig=1,ngrid
-         dtrac(ig,ilay)=(traci(ig,ilay)-tracold(ig,ilay))/ptimestep
-       enddo
-     enddo
-
-   else
-      call abort_physic("thermcell_updown_dq", &
-           'valeur de iflag_impl non prevue', 1)
-   endif
-
- RETURN
-   END
-
-!=========================================================================
-
-   SUBROUTINE thermcell_down(ngrid,nlay,po,pt,pu,pv,pplay,pplev,  &
-     &           lmax,fup,eup,dup,theta)
-
-!--------------------------------------------------------------
-!thermcell_down: calcul des propri??t??s du panache descendant.
-!--------------------------------------------------------------
-
-
-   USE lmdz_thermcell_ini, ONLY : prt_level,RLvCp,RKAPPA,RETV,fact_thermals_down
-   IMPLICIT NONE
-
-! arguments
-
-   integer,intent(in) :: ngrid,nlay
-   real,intent(in), dimension(ngrid,nlay) :: po,pt,pu,pv,pplay,eup,dup
-   real,intent(in), dimension(ngrid,nlay) :: theta
-   real,intent(in), dimension(ngrid,nlay+1) :: pplev,fup
-   integer, intent(in), dimension(ngrid) :: lmax
-
-
-   
-! Local
-
-   real, dimension(ngrid,nlay) :: edn,ddn,thetad
-   real, dimension(ngrid,nlay+1) :: fdn
-
-   integer ig,ilay
-   real dqsat_dT
-   logical mask(ngrid,nlay)
-
-   edn(:,:)=0.
-   ddn(:,:)=0.
-   fdn(:,:)=0.
-   thetad(:,:)=0.
-
-   ! lmax : indice tel que fu(kmax+1)=0
-   
-   ! Dans ce cas, pas besoin d'initialiser thetad(lmax) ( =theta(lmax) )
-
-! FH MODIFS APRES REUNIONS POUR COMMISSIONS
-! quelques erreurs de declaration
-! probleme si lmax=1 ce qui a l'air d'??tre le cas en d??but de simu. Devrait ??tre 0 ?
-! Remarques :
-! on pourrait ??crire la formule de thetad
-!    www=fdn(ig,ilay+1)/ (fdn(ig,ilay)+ddn(ig,ilay))
-!    thetad(ig,ilay)= www * thetad(ig,ilay+1) + (1.-www) * theta(ig,ilay) 
-! Elle a l'avantage de bien montr?? la conservation, l'id??e fondamentale dans le 
-!   transport qu'on ne fait que sommer des "sources" au travers d'un "propagateur"
-!   (Green)
-! Elle montre aussi beaucoup plus clairement pourquoi on n'a pas ?? se souccier (trop)
-!   de la possible nulit?? du d??nominateur
-
-
-   do ilay=nlay,1,-1
-      do ig=1,ngrid
-         if (ilay.le.lmax(ig).and.lmax(ig)>1) then
-            edn(ig,ilay)=fact_thermals_down*dup(ig,ilay)
-            ddn(ig,ilay)=fact_thermals_down*eup(ig,ilay)
-            fdn(ig,ilay)=fdn(ig,ilay+1)+edn(ig,ilay)-ddn(ig,ilay)
-            thetad(ig,ilay)=( fdn(ig,ilay+1)*thetad(ig,ilay+1) + edn(ig,ilay)*theta(ig,ilay) ) / (fdn(ig,ilay)+ddn(ig,ilay))
-         endif
-      enddo 
-   enddo
-
-   ! Suite du travail :
-   ! Ecrire la conservervation de theta_l dans le panache descendant
-   ! Eventuellement faire la transformation theta_l -> theta_v
-   ! Si l'air est sec (et qu'on oublie le c??t?? theta_v) on peut
-   ! se contenter de conserver theta.
-   !
-   ! Connaissant thetadn, on peut calculer la flotabilit??.
-   ! Connaissant la flotabilit??, on peut calculer w de proche en proche
-   ! On peut calculer le detrainement de facon ?? garder alpha*rho = cste
-   ! On en d??duit l'entrainement lat??ral
-   ! C'est le mod??le des mini-projets.
-
-!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-! Initialisations :
-!------------------
-
-
-!
- RETURN
-   END
-END MODULE lmdz_thermcell_down
Index: /LMDZ6/trunk/libf/phylmd/lmdz_thermcell_down.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/lmdz_thermcell_down.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/lmdz_thermcell_down.f90	(revision 5268)
@@ -0,0 +1,304 @@
+MODULE lmdz_thermcell_down
+CONTAINS
+
+SUBROUTINE thermcell_updown_dq(ngrid,nlay,ptimestep,lmax,eup,dup,edn,ddn,masse,trac,dtrac)
+
+USE lmdz_thermcell_ini, ONLY: iflag_thermals_down
+
+
+!-----------------------------------------------------------------
+! thermcell_updown_dq: computes the tendency of tracers associated
+! with the presence of convective up/down drafts
+! This routine that has been collectively written during the 
+! "ateliers downdrafts" in 2022/2023
+! Maelle, Frédéric, Catherine, Fleur, Florent, Etienne
+!------------------------------------------------------------------
+
+
+   IMPLICIT NONE
+
+! declarations
+!==============================================================
+
+! input/output
+
+   integer,intent(in)  :: ngrid ! number of horizontal grid points
+   integer, intent(in) :: nlay  ! number of vertical layers
+   real,intent(in) :: ptimestep ! time step of the physics [s]
+   real,intent(in), dimension(ngrid,nlay) :: eup ! entrainment to updrafts * dz [same unit as flux]
+   real,intent(in), dimension(ngrid,nlay) :: dup ! detrainment from updrafts * dz [same unit as flux]
+   real,intent(in), dimension(ngrid,nlay) :: edn ! entrainment to downdrafts * dz [same unit as flux]
+   real,intent(in), dimension(ngrid,nlay) :: ddn ! detrainment from downdrafts * dz [same unit as flux]
+   real,intent(in), dimension(ngrid,nlay) :: masse ! mass of layers = rho dz 
+   real,intent(in), dimension(ngrid,nlay) :: trac ! tracer 
+   integer, intent(in), dimension(ngrid) :: lmax ! max level index at which downdraft are present
+   real,intent(out),dimension(ngrid,nlay) ::dtrac ! tendance du traceur
+
+   
+! Local
+
+   real, dimension(ngrid,nlay+1) :: fup,fdn,fc,fthu,fthd,fthe,fthtot
+   real, dimension(ngrid,nlay) :: tracu,tracd,traci,tracold
+   real :: www, mstar_inv
+   integer ig,ilay
+   real, dimension(ngrid,nlay):: s1,s2,num !coefficients pour la resolution implicite
+   integer :: iflag_impl=1 ! 0 pour explicite, 1 pour implicite "classique", 2 pour implicite avec entrainement et detrainement
+   
+   fdn(:,:)=0.
+   fup(:,:)=0.
+   fc(:,:)=0.
+   fthu(:,:)=0.
+   fthd(:,:)=0.
+   fthe(:,:)=0.
+   fthtot(:,:)=0.
+   tracd(:,:)=0.
+   tracu(:,:)=0.
+   traci(:,:)=trac(:,:)
+   tracold(:,:)=trac(:,:)
+   s1(:,:)=0.
+   s2(:,:)=0.
+   num(:,:)=1.
+
+   if ( iflag_thermals_down < 10 ) then
+      call abort_physic("thermcell_updown_dq", &
+           'thermcell_down_dq = 0 or >= 10', 1)
+   else
+        iflag_impl=iflag_thermals_down-10
+   endif
+      
+
+   ! lmax : indice tel que fu(kmax+1)=0
+   ! Dans ce cas, pas besoin d'initialiser tracd(lmax) ( =trac(lmax) )
+   ! Boucle pour le downdraft
+   do ilay=nlay,1,-1
+      do ig=1,ngrid
+         !if ( lmax(ig) > nlay - 2 ) stop "les thermiques montent trop haut"
+         if (ilay.le.lmax(ig) .and. lmax(ig)>1 ) then
+            fdn(ig,ilay)=fdn(ig,ilay+1)+edn(ig,ilay)-ddn(ig,ilay)
+            if ( fdn(ig,ilay)+ddn(ig,ilay) > 0. ) then
+               www=fdn(ig,ilay+1)/ (fdn(ig,ilay)+ddn(ig,ilay))
+            else
+               www=0.
+            endif
+            tracd(ig,ilay)=www*tracd(ig,ilay+1) + (1.-www)*trac(ig,ilay)
+         endif
+      enddo 
+   enddo !Fin boucle sur l'updraft
+   fdn(:,1)=0.
+
+   !Boucle pour l'updraft
+   do ilay=1,nlay,1
+      do ig=1,ngrid
+         if (ilay.lt.lmax(ig) .and. lmax(ig)>1) then
+            fup(ig,ilay+1)=fup(ig,ilay)+eup(ig,ilay)-dup(ig,ilay)
+            if (fup(ig,ilay+1)+dup(ig,ilay) > 0.) then
+               www=fup(ig,ilay)/(fup(ig,ilay+1)+dup(ig,ilay))
+            else
+               www=0.
+            endif
+            if (ilay == 1 ) then
+               tracu(ig,ilay)=trac(ig,ilay)
+            else
+               tracu(ig,ilay)=www*tracu(ig,ilay-1)+(1.-www)*trac(ig,ilay)
+            endif
+         endif
+      enddo 
+      enddo !fin boucle sur le downdraft
+
+   ! Calcul des flux des traceurs dans les updraft et les downdrfat 
+   ! et du flux de masse compensateur
+   ! en ilay=1 et nlay+1, fthu=0 et fthd=0
+   fthu(:,1)=0.
+   fthu(:,nlay+1)=0.
+   fthd(:,1)=0.
+   fthd(:,nlay+1)=0.
+   fc(:,1)=0.
+   fc(:,nlay+1)=0.
+   do ilay=2,nlay,1 !boucle sur les interfaces
+     do ig=1,ngrid
+       fthu(ig,ilay)=fup(ig,ilay)*tracu(ig,ilay-1)
+       fthd(ig,ilay)=-fdn(ig,ilay)*tracd(ig,ilay)
+       fc(ig,ilay)=fup(ig,ilay)-fdn(ig,ilay)
+     enddo
+   enddo
+   
+
+   !Boucle pour calculer le flux du traceur flux updraft, flux downdraft, flux compensatoire
+   !Methode explicite : 
+   if(iflag_impl==0) then
+     do ilay=2,nlay,1
+       do ig=1,ngrid
+         !!!!ATTENTION HYPOTHESE de FLUX COMPENSATOIRE DESCENDANT ET DONC comme schema amont on va chercher trac au dessus!!!!!
+         !!!! tentative de prise en compte d'un flux compensatoire montant  !!!!
+         if (fup(ig,ilay)-fdn(ig,ilay) .lt. 0.) then
+            call abort_physic("thermcell_updown_dq", 'flux compensatoire '&
+                 // 'montant, cas non traite par thermcell_updown_dq', 1)
+            !fthe(ig,ilay)=(fup(ig,ilay)-fdn(ig,ilay))*trac(ig,ilay-1)
+         else
+            fthe(ig,ilay)=-(fup(ig,ilay)-fdn(ig,ilay))*trac(ig,ilay)
+         endif
+         !! si on voulait le prendre en compte on
+         !fthe(ig,ilay)=-(fup(ig,ilay)-fdn(ig,ilay))*trac(ig,ilay-1)
+         fthtot(ig,ilay)=fthu(ig,ilay)+fthd(ig,ilay)+fthe(ig,ilay)
+       enddo
+     enddo
+     !Boucle pour calculer trac
+     do ilay=1,nlay
+       do ig=1,ngrid
+         dtrac(ig,ilay)=(fthtot(ig,ilay)-fthtot(ig,ilay+1))/masse(ig,ilay)
+!         trac(ig,ilay)=trac(ig,ilay) + (fthtot(ig,ilay)-fthtot(ig,ilay+1))*(ptimestep/masse(ig,ilay))
+       enddo
+     enddo !fin du calculer de la tendance du traceur avec la methode explicite
+
+   !!! Reecriture du schéma explicite avec les notations du schéma implicite
+   else if(iflag_impl==-1) then
+     write(*,*) 'nouveau schéma explicite !!!'
+     !!! Calcul de s1
+     do ilay=1,nlay
+       do ig=1,ngrid
+         s1(ig,ilay)=fthu(ig,ilay)-fthu(ig,ilay+1)+fthd(ig,ilay)-fthd(ig,ilay+1)
+         s2(ig,ilay)=s1(ig,ilay)+fthe(ig,ilay)-fthe(ig,ilay+1)
+       enddo
+     enddo
+
+     do ilay=2,nlay,1
+       do ig=1,ngrid
+         if (fup(ig,ilay)-fdn(ig,ilay) .lt. 0.) then
+            call abort_physic("thermcell_updown_dq", 'flux compensatoire ' &
+                 // 'montant, cas non traite par thermcell_updown_dq', 1)
+         else
+            fthe(ig,ilay)=-(fup(ig,ilay)-fdn(ig,ilay))*trac(ig,ilay)
+         endif
+         fthtot(ig,ilay)=fthu(ig,ilay)+fthd(ig,ilay)+fthe(ig,ilay)
+       enddo
+     enddo
+     !Boucle pour calculer trac
+     do ilay=1,nlay
+       do ig=1,ngrid
+         ! dtrac(ig,ilay)=(fthtot(ig,ilay)-fthtot(ig,ilay+1))/masse(ig,ilay)
+         dtrac(ig,ilay)=(s1(ig,ilay)+fthe(ig,ilay)-fthe(ig,ilay+1))/masse(ig,ilay)
+!         trac(ig,ilay)=trac(ig,ilay) + (fthtot(ig,ilay)-fthtot(ig,ilay+1))*(ptimestep/masse(ig,ilay))
+!         trac(ig,ilay)=trac(ig,ilay) + (s1(ig,ilay)+fthe(ig,ilay)-fthe(ig,ilay+1))*(ptimestep/masse(ig,ilay))
+       enddo
+     enddo !fin du calculer de la tendance du traceur avec la methode explicite
+
+   else if (iflag_impl==1) then
+     do ilay=1,nlay
+       do ig=1,ngrid
+         s1(ig,ilay)=fthu(ig,ilay)-fthu(ig,ilay+1)+fthd(ig,ilay)-fthd(ig,ilay+1)
+       enddo
+     enddo
+     
+     !Boucle pour calculer traci = trac((t+dt)
+     do ilay=nlay-1,1,-1
+       do ig=1,ngrid
+         if((fup(ig,ilay)-fdn(ig,ilay)) .lt. 0) then
+            write(*,*) 'flux compensatoire montant, cas non traite par thermcell_updown_dq dans le cas d une resolution implicite, ilay : ', ilay
+            call abort_physic("thermcell_updown_dq", "", 1)
+         else
+           mstar_inv=ptimestep/masse(ig,ilay)
+           traci(ig,ilay)=((traci(ig,ilay+1)*fc(ig,ilay+1)+s1(ig,ilay))*mstar_inv+tracold(ig,ilay))/(1.+fc(ig,ilay)*mstar_inv)
+         endif
+       enddo
+     enddo
+     do ilay=1,nlay
+       do ig=1,ngrid
+         dtrac(ig,ilay)=(traci(ig,ilay)-tracold(ig,ilay))/ptimestep
+       enddo
+     enddo
+
+   else
+      call abort_physic("thermcell_updown_dq", &
+           'valeur de iflag_impl non prevue', 1)
+   endif
+
+ RETURN
+   END
+
+!=========================================================================
+
+   SUBROUTINE thermcell_down(ngrid,nlay,po,pt,pu,pv,pplay,pplev,  &
+     &           lmax,fup,eup,dup,theta)
+
+!--------------------------------------------------------------
+!thermcell_down: calcul des propri??t??s du panache descendant.
+!--------------------------------------------------------------
+
+
+   USE lmdz_thermcell_ini, ONLY : prt_level,RLvCp,RKAPPA,RETV,fact_thermals_down
+   IMPLICIT NONE
+
+! arguments
+
+   integer,intent(in) :: ngrid,nlay
+   real,intent(in), dimension(ngrid,nlay) :: po,pt,pu,pv,pplay,eup,dup
+   real,intent(in), dimension(ngrid,nlay) :: theta
+   real,intent(in), dimension(ngrid,nlay+1) :: pplev,fup
+   integer, intent(in), dimension(ngrid) :: lmax
+
+
+   
+! Local
+
+   real, dimension(ngrid,nlay) :: edn,ddn,thetad
+   real, dimension(ngrid,nlay+1) :: fdn
+
+   integer ig,ilay
+   real dqsat_dT
+   logical mask(ngrid,nlay)
+
+   edn(:,:)=0.
+   ddn(:,:)=0.
+   fdn(:,:)=0.
+   thetad(:,:)=0.
+
+   ! lmax : indice tel que fu(kmax+1)=0
+   
+   ! Dans ce cas, pas besoin d'initialiser thetad(lmax) ( =theta(lmax) )
+
+! FH MODIFS APRES REUNIONS POUR COMMISSIONS
+! quelques erreurs de declaration
+! probleme si lmax=1 ce qui a l'air d'??tre le cas en d??but de simu. Devrait ??tre 0 ?
+! Remarques :
+! on pourrait ??crire la formule de thetad
+!    www=fdn(ig,ilay+1)/ (fdn(ig,ilay)+ddn(ig,ilay))
+!    thetad(ig,ilay)= www * thetad(ig,ilay+1) + (1.-www) * theta(ig,ilay) 
+! Elle a l'avantage de bien montr?? la conservation, l'id??e fondamentale dans le 
+!   transport qu'on ne fait que sommer des "sources" au travers d'un "propagateur"
+!   (Green)
+! Elle montre aussi beaucoup plus clairement pourquoi on n'a pas ?? se souccier (trop)
+!   de la possible nulit?? du d??nominateur
+
+
+   do ilay=nlay,1,-1
+      do ig=1,ngrid
+         if (ilay.le.lmax(ig).and.lmax(ig)>1) then
+            edn(ig,ilay)=fact_thermals_down*dup(ig,ilay)
+            ddn(ig,ilay)=fact_thermals_down*eup(ig,ilay)
+            fdn(ig,ilay)=fdn(ig,ilay+1)+edn(ig,ilay)-ddn(ig,ilay)
+            thetad(ig,ilay)=( fdn(ig,ilay+1)*thetad(ig,ilay+1) + edn(ig,ilay)*theta(ig,ilay) ) / (fdn(ig,ilay)+ddn(ig,ilay))
+         endif
+      enddo 
+   enddo
+
+   ! Suite du travail :
+   ! Ecrire la conservervation de theta_l dans le panache descendant
+   ! Eventuellement faire la transformation theta_l -> theta_v
+   ! Si l'air est sec (et qu'on oublie le c??t?? theta_v) on peut
+   ! se contenter de conserver theta.
+   !
+   ! Connaissant thetadn, on peut calculer la flotabilit??.
+   ! Connaissant la flotabilit??, on peut calculer w de proche en proche
+   ! On peut calculer le detrainement de facon ?? garder alpha*rho = cste
+   ! On en d??duit l'entrainement lat??ral
+   ! C'est le mod??le des mini-projets.
+
+!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+! Initialisations :
+!------------------
+
+
+!
+ RETURN
+   END
+END MODULE lmdz_thermcell_down
Index: DZ6/trunk/libf/phylmd/lmdz_thermcell_dry.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/lmdz_thermcell_dry.F90	(revision 5267)
+++ 	(revision )
@@ -1,169 +1,0 @@
-MODULE lmdz_thermcell_dry
-!
-! $Id$
-!
-CONTAINS
-
-       SUBROUTINE thermcell_dry(ngrid,nlay,zlev,pphi,ztv,alim_star,  &
-     &                            lalim,lmin,zmax,wmax)
-
-!--------------------------------------------------------------------------
-!thermcell_dry: calcul de zmax et wmax du thermique sec
-! Calcul de la vitesse maximum et de la hauteur maximum pour un panache
-! ascendant avec une fonction d'alimentation alim_star et sans changement 
-! de phase.
-! Le calcul pourrait etre sans doute simplifier.
-! La temperature potentielle virtuelle dans la panache ascendant est
-! la temperature potentielle virtuelle pondÃ©rÃ©e par alim_star.
-!--------------------------------------------------------------------------
-       USE lmdz_thermcell_ini, ONLY: prt_level, RG
-       IMPLICIT NONE
-
-       integer, intent(in) :: ngrid,nlay
-       real, intent(in), dimension(ngrid,nlay+1) :: zlev,pphi,ztv,alim_star
-       integer, intent(in), dimension(ngrid) :: lalim
-       real, intent(out), dimension(ngrid) :: zmax,wmax
-
-!variables locales
-       REAL zw2(ngrid,nlay+1)
-       REAL f_star(ngrid,nlay+1)
-       REAL ztva(ngrid,nlay+1)
-       REAL wmaxa(ngrid)
-       REAL wa_moy(ngrid,nlay+1)
-       REAL linter(ngrid),zlevinter(ngrid)
-       INTEGER lmix(ngrid),lmax(ngrid),lmin(ngrid)
-      CHARACTER (LEN=20) :: modname='thermcell_dry'
-      CHARACTER (LEN=80) :: abort_message
-       INTEGER l,ig
-
-!initialisations
-       do ig=1,ngrid
-          do l=1,nlay+1
-             zw2(ig,l)=0.
-             wa_moy(ig,l)=0.
-          enddo
-       enddo
-       do ig=1,ngrid
-          do l=1,nlay
-             ztva(ig,l)=ztv(ig,l)
-          enddo
-       enddo
-       do ig=1,ngrid
-          wmax(ig)=0.
-          wmaxa(ig)=0.
-       enddo
-!calcul de la vitesse a partir de la CAPE en melangeant thetav
-
-
-! Calcul des F^*, integrale verticale de E^*
-       f_star(:,1)=0.
-       do l=1,nlay
-          f_star(:,l+1)=f_star(:,l)+alim_star(:,l)
-       enddo
-
-! niveau (reel) auquel zw2 s'annule FH :n'etait pas initialise
-       linter(:)=0.
-
-! couche la plus haute concernee par le thermique. 
-       lmax(:)=1
-
-! Le niveau linter est une variable continue qui se trouve dans la couche
-! lmax
-
-       do l=1,nlay-2
-         do ig=1,ngrid
-            if (l.eq.lmin(ig).and.lalim(ig).gt.1) then
-
-!------------------------------------------------------------------------
-!  Calcul de la vitesse en haut de la premiere couche instable.
-!  Premiere couche du panache thermique
-!------------------------------------------------------------------------
-
-               zw2(ig,l+1)=2.*RG*(ztv(ig,l)-ztv(ig,l+1))/ztv(ig,l+1)  &
-     &                     *(zlev(ig,l+1)-zlev(ig,l))  &
-     &                     *0.4*pphi(ig,l)/(pphi(ig,l+1)-pphi(ig,l))
-
-!------------------------------------------------------------------------
-! Tant que la vitesse en bas de la couche et la somme du flux de masse
-! et de l'entrainement (c'est a dire le flux de masse en haut) sont
-! positifs, on calcul
-! 1. le flux de masse en haut  f_star(ig,l+1)
-! 2. la temperature potentielle virtuelle dans la couche ztva(ig,l)
-! 3. la vitesse au carré en haut zw2(ig,l+1)
-!------------------------------------------------------------------------
-
-            else if (zw2(ig,l).ge.1e-10) then
-
-               ztva(ig,l)=(f_star(ig,l)*ztva(ig,l-1)+alim_star(ig,l)  &
-     &                    *ztv(ig,l))/f_star(ig,l+1)
-               zw2(ig,l+1)=zw2(ig,l)*(f_star(ig,l)/f_star(ig,l+1))**2+  &
-     &                     2.*RG*(ztva(ig,l)-ztv(ig,l))/ztv(ig,l)  &
-     &                     *(zlev(ig,l+1)-zlev(ig,l))
-            endif
-! determination de zmax continu par interpolation lineaire
-!------------------------------------------------------------------------
-
-            if (zw2(ig,l+1)>0. .and. zw2(ig,l+1).lt.1.e-10) then
-!               stop'On tombe sur le cas particulier de thermcell_dry'
-!               print*,'On tombe sur le cas particulier de thermcell_dry'
-                zw2(ig,l+1)=0.
-                linter(ig)=l+1
-                lmax(ig)=l
-            endif
-
-            if (zw2(ig,l+1).lt.0.) then
-               linter(ig)=(l*(zw2(ig,l+1)-zw2(ig,l))  &
-     &           -zw2(ig,l))/(zw2(ig,l+1)-zw2(ig,l))
-               zw2(ig,l+1)=0.
-               lmax(ig)=l
-!            endif
-!CR:zmax continu 06/05/12: calcul de linter quand le thermique est stoppe par le detrainement
-            elseif (f_star(ig,l+1).lt.0.) then
-               linter(ig)=(l*(f_star(ig,l+1)-f_star(ig,l))  &
-     &           -f_star(ig,l))/(f_star(ig,l+1)-f_star(ig,l))
-               zw2(ig,l+1)=0.
-               lmax(ig)=l
-            endif
-!CRfin
-               wa_moy(ig,l+1)=sqrt(zw2(ig,l+1))
-
-            if (wa_moy(ig,l+1).gt.wmaxa(ig)) then
-!   lmix est le niveau de la couche ou w (wa_moy) est maximum
-               lmix(ig)=l+1
-               wmaxa(ig)=wa_moy(ig,l+1)
-            endif
-         enddo
-      enddo
-       if (prt_level.ge.1) print*,'fin calcul zw2'
-!
-! Determination de zw2 max
-      do ig=1,ngrid
-         wmax(ig)=0.
-      enddo
-
-      do l=1,nlay
-         do ig=1,ngrid
-            if (l.le.lmax(ig)) then
-                zw2(ig,l)=sqrt(zw2(ig,l))
-                wmax(ig)=max(wmax(ig),zw2(ig,l))
-            else
-                 zw2(ig,l)=0.
-            endif
-          enddo
-      enddo
-
-!   Longueur caracteristique correspondant a la hauteur des thermiques.
-      do  ig=1,ngrid
-         zmax(ig)=0.
-         zlevinter(ig)=zlev(ig,1)
-      enddo
-      do  ig=1,ngrid
-! calcul de zlevinter
-          zlevinter(ig)=zlev(ig,lmax(ig)) + &
-     &    (linter(ig)-lmax(ig))*(zlev(ig,lmax(ig)+1)-zlev(ig,lmax(ig)))
-           zmax(ig)=max(zmax(ig),zlevinter(ig)-zlev(ig,lmin(ig)))
-      enddo
-
- RETURN
-      END
-END MODULE lmdz_thermcell_dry
Index: /LMDZ6/trunk/libf/phylmd/lmdz_thermcell_dry.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/lmdz_thermcell_dry.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/lmdz_thermcell_dry.f90	(revision 5268)
@@ -0,0 +1,169 @@
+MODULE lmdz_thermcell_dry
+!
+! $Id$
+!
+CONTAINS
+
+       SUBROUTINE thermcell_dry(ngrid,nlay,zlev,pphi,ztv,alim_star,  &
+     &                            lalim,lmin,zmax,wmax)
+
+!--------------------------------------------------------------------------
+!thermcell_dry: calcul de zmax et wmax du thermique sec
+! Calcul de la vitesse maximum et de la hauteur maximum pour un panache
+! ascendant avec une fonction d'alimentation alim_star et sans changement 
+! de phase.
+! Le calcul pourrait etre sans doute simplifier.
+! La temperature potentielle virtuelle dans la panache ascendant est
+! la temperature potentielle virtuelle pondÃ©rÃ©e par alim_star.
+!--------------------------------------------------------------------------
+       USE lmdz_thermcell_ini, ONLY: prt_level, RG
+       IMPLICIT NONE
+
+       integer, intent(in) :: ngrid,nlay
+       real, intent(in), dimension(ngrid,nlay+1) :: zlev,pphi,ztv,alim_star
+       integer, intent(in), dimension(ngrid) :: lalim
+       real, intent(out), dimension(ngrid) :: zmax,wmax
+
+!variables locales
+       REAL zw2(ngrid,nlay+1)
+       REAL f_star(ngrid,nlay+1)
+       REAL ztva(ngrid,nlay+1)
+       REAL wmaxa(ngrid)
+       REAL wa_moy(ngrid,nlay+1)
+       REAL linter(ngrid),zlevinter(ngrid)
+       INTEGER lmix(ngrid),lmax(ngrid),lmin(ngrid)
+      CHARACTER (LEN=20) :: modname='thermcell_dry'
+      CHARACTER (LEN=80) :: abort_message
+       INTEGER l,ig
+
+!initialisations
+       do ig=1,ngrid
+          do l=1,nlay+1
+             zw2(ig,l)=0.
+             wa_moy(ig,l)=0.
+          enddo
+       enddo
+       do ig=1,ngrid
+          do l=1,nlay
+             ztva(ig,l)=ztv(ig,l)
+          enddo
+       enddo
+       do ig=1,ngrid
+          wmax(ig)=0.
+          wmaxa(ig)=0.
+       enddo
+!calcul de la vitesse a partir de la CAPE en melangeant thetav
+
+
+! Calcul des F^*, integrale verticale de E^*
+       f_star(:,1)=0.
+       do l=1,nlay
+          f_star(:,l+1)=f_star(:,l)+alim_star(:,l)
+       enddo
+
+! niveau (reel) auquel zw2 s'annule FH :n'etait pas initialise
+       linter(:)=0.
+
+! couche la plus haute concernee par le thermique. 
+       lmax(:)=1
+
+! Le niveau linter est une variable continue qui se trouve dans la couche
+! lmax
+
+       do l=1,nlay-2
+         do ig=1,ngrid
+            if (l.eq.lmin(ig).and.lalim(ig).gt.1) then
+
+!------------------------------------------------------------------------
+!  Calcul de la vitesse en haut de la premiere couche instable.
+!  Premiere couche du panache thermique
+!------------------------------------------------------------------------
+
+               zw2(ig,l+1)=2.*RG*(ztv(ig,l)-ztv(ig,l+1))/ztv(ig,l+1)  &
+     &                     *(zlev(ig,l+1)-zlev(ig,l))  &
+     &                     *0.4*pphi(ig,l)/(pphi(ig,l+1)-pphi(ig,l))
+
+!------------------------------------------------------------------------
+! Tant que la vitesse en bas de la couche et la somme du flux de masse
+! et de l'entrainement (c'est a dire le flux de masse en haut) sont
+! positifs, on calcul
+! 1. le flux de masse en haut  f_star(ig,l+1)
+! 2. la temperature potentielle virtuelle dans la couche ztva(ig,l)
+! 3. la vitesse au carré en haut zw2(ig,l+1)
+!------------------------------------------------------------------------
+
+            else if (zw2(ig,l).ge.1e-10) then
+
+               ztva(ig,l)=(f_star(ig,l)*ztva(ig,l-1)+alim_star(ig,l)  &
+     &                    *ztv(ig,l))/f_star(ig,l+1)
+               zw2(ig,l+1)=zw2(ig,l)*(f_star(ig,l)/f_star(ig,l+1))**2+  &
+     &                     2.*RG*(ztva(ig,l)-ztv(ig,l))/ztv(ig,l)  &
+     &                     *(zlev(ig,l+1)-zlev(ig,l))
+            endif
+! determination de zmax continu par interpolation lineaire
+!------------------------------------------------------------------------
+
+            if (zw2(ig,l+1)>0. .and. zw2(ig,l+1).lt.1.e-10) then
+!               stop'On tombe sur le cas particulier de thermcell_dry'
+!               print*,'On tombe sur le cas particulier de thermcell_dry'
+                zw2(ig,l+1)=0.
+                linter(ig)=l+1
+                lmax(ig)=l
+            endif
+
+            if (zw2(ig,l+1).lt.0.) then
+               linter(ig)=(l*(zw2(ig,l+1)-zw2(ig,l))  &
+     &           -zw2(ig,l))/(zw2(ig,l+1)-zw2(ig,l))
+               zw2(ig,l+1)=0.
+               lmax(ig)=l
+!            endif
+!CR:zmax continu 06/05/12: calcul de linter quand le thermique est stoppe par le detrainement
+            elseif (f_star(ig,l+1).lt.0.) then
+               linter(ig)=(l*(f_star(ig,l+1)-f_star(ig,l))  &
+     &           -f_star(ig,l))/(f_star(ig,l+1)-f_star(ig,l))
+               zw2(ig,l+1)=0.
+               lmax(ig)=l
+            endif
+!CRfin
+               wa_moy(ig,l+1)=sqrt(zw2(ig,l+1))
+
+            if (wa_moy(ig,l+1).gt.wmaxa(ig)) then
+!   lmix est le niveau de la couche ou w (wa_moy) est maximum
+               lmix(ig)=l+1
+               wmaxa(ig)=wa_moy(ig,l+1)
+            endif
+         enddo
+      enddo
+       if (prt_level.ge.1) print*,'fin calcul zw2'
+!
+! Determination de zw2 max
+      do ig=1,ngrid
+         wmax(ig)=0.
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+            if (l.le.lmax(ig)) then
+                zw2(ig,l)=sqrt(zw2(ig,l))
+                wmax(ig)=max(wmax(ig),zw2(ig,l))
+            else
+                 zw2(ig,l)=0.
+            endif
+          enddo
+      enddo
+
+!   Longueur caracteristique correspondant a la hauteur des thermiques.
+      do  ig=1,ngrid
+         zmax(ig)=0.
+         zlevinter(ig)=zlev(ig,1)
+      enddo
+      do  ig=1,ngrid
+! calcul de zlevinter
+          zlevinter(ig)=zlev(ig,lmax(ig)) + &
+     &    (linter(ig)-lmax(ig))*(zlev(ig,lmax(ig)+1)-zlev(ig,lmax(ig)))
+           zmax(ig)=max(zmax(ig),zlevinter(ig)-zlev(ig,lmin(ig)))
+      enddo
+
+ RETURN
+      END
+END MODULE lmdz_thermcell_dry
Index: DZ6/trunk/libf/phylmd/lmdz_thermcell_dtke.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/lmdz_thermcell_dtke.F90	(revision 5267)
+++ 	(revision )
@@ -1,124 +1,0 @@
-MODULE lmdz_thermcell_dtke
-CONTAINS
-
-      subroutine thermcell_dtke(ngrid,nlay,nsrf,ptimestep,fm0,entr0,  &
-     &           rg,pplev,tke)
-      USE print_control_mod, ONLY: prt_level
-      implicit none
-
-!=======================================================================
-!
-!   Calcul du transport verticale dans la couche limite en presence
-!   de "thermiques" explicitement representes
-!   calcul du dq/dt une fois qu'on connait les ascendances
-!
-!=======================================================================
-
-      integer, intent(in) :: ngrid,nlay,nsrf
-      real, intent(in) :: ptimestep
-      real, dimension(ngrid,nlay), intent(in) :: entr0
-      real, dimension(ngrid,nlay+1), intent(in) :: fm0,pplev
-      real, intent(in) :: rg
-      real, intent(inout) :: tke(ngrid,nlay+1,nsrf)
-
-      real, dimension(ngrid,nlay) :: masse0,detr0, masse,entr,detr
-      real, dimension(ngrid,nlay+1) :: fm,wqd,q,qa
-      integer lev_out                           ! niveau pour les print
-
-
-      real :: zzm
-
-      integer ig,k
-      integer isrf
-
-
-      lev_out=0
-
-!print*,'thermcell_dtke'
-
-      if (prt_level.ge.1) print*,'Q2 THERMCEL_DQ 0'
-
-!   calcul du detrainement
-      do k=1,nlay
-         detr0(:,k)=fm0(:,k)-fm0(:,k+1)+entr0(:,k)
-         masse0(:,k)=(pplev(:,k)-pplev(:,k+1))/RG
-      enddo
-
-
-! Decalage vertical des entrainements et detrainements.
-      masse(:,1)=0.5*masse0(:,1)
-      entr(:,1)=0.5*entr0(:,1)
-      detr(:,1)=0.5*detr0(:,1)
-      fm(:,1)=0.
-      do k=1,nlay-1
-         masse(:,k+1)=0.5*(masse0(:,k)+masse0(:,k+1))
-         entr(:,k+1)=0.5*(entr0(:,k)+entr0(:,k+1))
-         detr(:,k+1)=0.5*(detr0(:,k)+detr0(:,k+1))
-         fm(:,k+1)=fm(:,k)+entr(:,k)-detr(:,k)
-      enddo
-      fm(:,nlay+1)=0.
-
-
-
-do isrf=1,nsrf
-
-   q(:,:)=tke(:,:,isrf)
-!   calcul de la valeur dans les ascendances
-      do ig=1,ngrid
-         qa(ig,1)=q(ig,1)
-      enddo
-
-
-    if (1==1) then
-      do k=2,nlay
-         do ig=1,ngrid
-            if ((fm(ig,k+1)+detr(ig,k))*ptimestep.gt.  &
-     &         1.e-5*masse(ig,k)) then
-         qa(ig,k)=(fm(ig,k)*qa(ig,k-1)+entr(ig,k)*q(ig,k))  &
-     &         /(fm(ig,k+1)+detr(ig,k))
-            else
-               qa(ig,k)=q(ig,k)
-            endif
-            if (qa(ig,k).lt.0.) then
-!               print*,'qa<0!!!'
-            endif
-            if (q(ig,k).lt.0.) then
-!               print*,'q<0!!!'
-            endif
-         enddo
-      enddo
-
-! Calcul du flux subsident
-
-      do k=2,nlay
-         do ig=1,ngrid
-            wqd(ig,k)=fm(ig,k)*q(ig,k)
-            if (wqd(ig,k).lt.0.) then
-!               print*,'wqd<0!!!'
-            endif
-         enddo
-      enddo
-      do ig=1,ngrid
-         wqd(ig,1)=0.
-         wqd(ig,nlay+1)=0.
-      enddo
-     
-
-! Calcul des tendances
-      do k=1,nlay
-         do ig=1,ngrid
-            q(ig,k)=q(ig,k)+(detr(ig,k)*qa(ig,k)-entr(ig,k)*q(ig,k)  &
-     &               -wqd(ig,k)+wqd(ig,k+1))  &
-     &               *ptimestep/masse(ig,k)
-         enddo
-      enddo
-
- endif
-
-   tke(:,:,isrf)=q(:,:)
-
-enddo
-
-      return
-      end
-END MODULE lmdz_thermcell_dtke
Index: /LMDZ6/trunk/libf/phylmd/lmdz_thermcell_dtke.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/lmdz_thermcell_dtke.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/lmdz_thermcell_dtke.f90	(revision 5268)
@@ -0,0 +1,124 @@
+MODULE lmdz_thermcell_dtke
+CONTAINS
+
+      subroutine thermcell_dtke(ngrid,nlay,nsrf,ptimestep,fm0,entr0,  &
+     &           rg,pplev,tke)
+      USE print_control_mod, ONLY: prt_level
+      implicit none
+
+!=======================================================================
+!
+!   Calcul du transport verticale dans la couche limite en presence
+!   de "thermiques" explicitement representes
+!   calcul du dq/dt une fois qu'on connait les ascendances
+!
+!=======================================================================
+
+      integer, intent(in) :: ngrid,nlay,nsrf
+      real, intent(in) :: ptimestep
+      real, dimension(ngrid,nlay), intent(in) :: entr0
+      real, dimension(ngrid,nlay+1), intent(in) :: fm0,pplev
+      real, intent(in) :: rg
+      real, intent(inout) :: tke(ngrid,nlay+1,nsrf)
+
+      real, dimension(ngrid,nlay) :: masse0,detr0, masse,entr,detr
+      real, dimension(ngrid,nlay+1) :: fm,wqd,q,qa
+      integer lev_out                           ! niveau pour les print
+
+
+      real :: zzm
+
+      integer ig,k
+      integer isrf
+
+
+      lev_out=0
+
+!print*,'thermcell_dtke'
+
+      if (prt_level.ge.1) print*,'Q2 THERMCEL_DQ 0'
+
+!   calcul du detrainement
+      do k=1,nlay
+         detr0(:,k)=fm0(:,k)-fm0(:,k+1)+entr0(:,k)
+         masse0(:,k)=(pplev(:,k)-pplev(:,k+1))/RG
+      enddo
+
+
+! Decalage vertical des entrainements et detrainements.
+      masse(:,1)=0.5*masse0(:,1)
+      entr(:,1)=0.5*entr0(:,1)
+      detr(:,1)=0.5*detr0(:,1)
+      fm(:,1)=0.
+      do k=1,nlay-1
+         masse(:,k+1)=0.5*(masse0(:,k)+masse0(:,k+1))
+         entr(:,k+1)=0.5*(entr0(:,k)+entr0(:,k+1))
+         detr(:,k+1)=0.5*(detr0(:,k)+detr0(:,k+1))
+         fm(:,k+1)=fm(:,k)+entr(:,k)-detr(:,k)
+      enddo
+      fm(:,nlay+1)=0.
+
+
+
+do isrf=1,nsrf
+
+   q(:,:)=tke(:,:,isrf)
+!   calcul de la valeur dans les ascendances
+      do ig=1,ngrid
+         qa(ig,1)=q(ig,1)
+      enddo
+
+
+    if (1==1) then
+      do k=2,nlay
+         do ig=1,ngrid
+            if ((fm(ig,k+1)+detr(ig,k))*ptimestep.gt.  &
+     &         1.e-5*masse(ig,k)) then
+         qa(ig,k)=(fm(ig,k)*qa(ig,k-1)+entr(ig,k)*q(ig,k))  &
+     &         /(fm(ig,k+1)+detr(ig,k))
+            else
+               qa(ig,k)=q(ig,k)
+            endif
+            if (qa(ig,k).lt.0.) then
+!               print*,'qa<0!!!'
+            endif
+            if (q(ig,k).lt.0.) then
+!               print*,'q<0!!!'
+            endif
+         enddo
+      enddo
+
+! Calcul du flux subsident
+
+      do k=2,nlay
+         do ig=1,ngrid
+            wqd(ig,k)=fm(ig,k)*q(ig,k)
+            if (wqd(ig,k).lt.0.) then
+!               print*,'wqd<0!!!'
+            endif
+         enddo
+      enddo
+      do ig=1,ngrid
+         wqd(ig,1)=0.
+         wqd(ig,nlay+1)=0.
+      enddo
+     
+
+! Calcul des tendances
+      do k=1,nlay
+         do ig=1,ngrid
+            q(ig,k)=q(ig,k)+(detr(ig,k)*qa(ig,k)-entr(ig,k)*q(ig,k)  &
+     &               -wqd(ig,k)+wqd(ig,k+1))  &
+     &               *ptimestep/masse(ig,k)
+         enddo
+      enddo
+
+ endif
+
+   tke(:,:,isrf)=q(:,:)
+
+enddo
+
+      return
+      end
+END MODULE lmdz_thermcell_dtke
Index: DZ6/trunk/libf/phylmd/lmdz_thermcell_dv2.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/lmdz_thermcell_dv2.F90	(revision 5267)
+++ 	(revision )
@@ -1,197 +1,0 @@
-MODULE lmdz_thermcell_dv2
-CONTAINS
-
-      subroutine thermcell_dv2(ngrid,nlay,ptimestep,fm,entr,masse  &
-     &    ,fraca,larga  &
-     &    ,u,v,du,dv,ua,va,lev_out)
-      USE print_control_mod, ONLY: prt_level,lunout
-      implicit none
-
-!=======================================================================
-!
-!   Calcul du transport verticale dans la couche limite en presence
-!   de "thermiques" explicitement representes
-!   calcul du dq/dt une fois qu'on connait les ascendances
-!
-! Vectorisation, FH : 2010/03/08
-!
-!=======================================================================
-
-
-      integer ngrid,nlay
-
-      real ptimestep
-      real masse(ngrid,nlay),fm(ngrid,nlay+1)
-      real fraca(ngrid,nlay+1)
-      real larga(ngrid)
-      real entr(ngrid,nlay)
-      real u(ngrid,nlay)
-      real ua(ngrid,nlay)
-      real du(ngrid,nlay)
-      real v(ngrid,nlay)
-      real va(ngrid,nlay)
-      real dv(ngrid,nlay)
-      integer lev_out                           ! niveau pour les print
-
-      real qa(ngrid,nlay),detr(ngrid,nlay),zf,zf2
-      real wvd(ngrid,nlay+1),wud(ngrid,nlay+1)
-      real gamma0(ngrid,nlay+1),gamma(ngrid,nlay+1)
-      real ue(ngrid,nlay),ve(ngrid,nlay)
-      LOGICAL ltherm(ngrid,nlay)
-      real dua(ngrid,nlay),dva(ngrid,nlay)
-      integer iter
-
-      integer ig,k,nlarga0
-
-!-------------------------------------------------------------------------
-
-!   calcul du detrainement
-!---------------------------
-
-!      print*,'THERMCELL DV2 OPTIMISE 3'
-
-      nlarga0=0.
-
-      do k=1,nlay
-         do ig=1,ngrid
-            detr(ig,k)=fm(ig,k)-fm(ig,k+1)+entr(ig,k)
-         enddo
-      enddo
-
-!   calcul de la valeur dans les ascendances
-      do ig=1,ngrid
-         ua(ig,1)=u(ig,1)
-         va(ig,1)=v(ig,1)
-         ue(ig,1)=u(ig,1)
-         ve(ig,1)=v(ig,1)
-      enddo
-
-      IF(prt_level>9)WRITE(lunout,*)                                    &
-     &      'WARNING on initialise gamma(1:ngrid,1)=0.'
-      gamma(1:ngrid,1)=0.
-      do k=2,nlay
-         do ig=1,ngrid
-            ltherm(ig,k)=(fm(ig,k+1)+detr(ig,k))*ptimestep > 1.e-5*masse(ig,k)
-            if(ltherm(ig,k).and.larga(ig)>0.) then
-               gamma0(ig,k)=masse(ig,k)  &
-     &         *sqrt( 0.5*(fraca(ig,k+1)+fraca(ig,k)) )  &
-     &         *0.5/larga(ig)  &
-     &         *1.
-            else
-               gamma0(ig,k)=0.
-            endif
-            if (ltherm(ig,k).and.larga(ig)<=0.) nlarga0=nlarga0+1
-         enddo
-      enddo
-
-      gamma(:,:)=0.
-
-      do k=2,nlay
-
-         do ig=1,ngrid
-            if (ltherm(ig,k)) then
-               dua(ig,k)=ua(ig,k-1)-u(ig,k-1)
-               dva(ig,k)=va(ig,k-1)-v(ig,k-1)
-            else
-               ua(ig,k)=u(ig,k)
-               va(ig,k)=v(ig,k)
-               ue(ig,k)=u(ig,k)
-               ve(ig,k)=v(ig,k)
-            endif
-         enddo
-
-
-! Debut des iterations
-!----------------------
-do iter=1,5
-         do ig=1,ngrid
-! Pour memoire : calcul prenant en compte la fraction reelle
-!              zf=0.5*(fraca(ig,k)+fraca(ig,k+1))
-!              zf2=1./(1.-zf)
-! Calcul avec fraction infiniement petite
-               zf=0.
-               zf2=1.
-
-!  la première fois on multiplie le coefficient de freinage
-!  par le module du vent dans la couche en dessous.
-!  Mais pourquoi donc ???
-               if (ltherm(ig,k)) then
-!   On choisit une relaxation lineaire.
-!                 gamma(ig,k)=gamma0(ig,k)
-!   On choisit une relaxation quadratique.
-                  gamma(ig,k)=gamma0(ig,k)*sqrt(dua(ig,k)**2+dva(ig,k)**2)
-                  ua(ig,k)=(fm(ig,k)*ua(ig,k-1)  &
-     &               +(zf2*entr(ig,k)+gamma(ig,k))*u(ig,k))  &
-     &               /(fm(ig,k+1)+detr(ig,k)+entr(ig,k)*zf*zf2  &
-     &                 +gamma(ig,k))
-                  va(ig,k)=(fm(ig,k)*va(ig,k-1)  &
-     &               +(zf2*entr(ig,k)+gamma(ig,k))*v(ig,k))  &
-     &               /(fm(ig,k+1)+detr(ig,k)+entr(ig,k)*zf*zf2  &
-     &                 +gamma(ig,k))
-!                 print*,k,ua(ig,k),va(ig,k),u(ig,k),v(ig,k),dua(ig,k),dva(ig,k)
-                  dua(ig,k)=ua(ig,k)-u(ig,k)
-                  dva(ig,k)=va(ig,k)-v(ig,k)
-                  ue(ig,k)=(u(ig,k)-zf*ua(ig,k))*zf2
-                  ve(ig,k)=(v(ig,k)-zf*va(ig,k))*zf2
-               endif
-         enddo
-! Fin des iterations
-!--------------------
-enddo
-
-      enddo ! k=2,nlay
-
-
-! Calcul du flux vertical de moment dans l'environnement.
-!---------------------------------------------------------
-      do k=2,nlay
-         do ig=1,ngrid
-            wud(ig,k)=fm(ig,k)*ue(ig,k)
-            wvd(ig,k)=fm(ig,k)*ve(ig,k)
-         enddo
-      enddo
-      do ig=1,ngrid
-         wud(ig,1)=0.
-         wud(ig,nlay+1)=0.
-         wvd(ig,1)=0.
-         wvd(ig,nlay+1)=0.
-      enddo
-
-! calcul des tendances.
-!-----------------------
-      do k=1,nlay
-         do ig=1,ngrid
-            du(ig,k)=((detr(ig,k)+gamma(ig,k))*ua(ig,k)  &
-     &               -(entr(ig,k)+gamma(ig,k))*ue(ig,k)  &
-     &               -wud(ig,k)+wud(ig,k+1))  &
-     &               /masse(ig,k)
-            dv(ig,k)=((detr(ig,k)+gamma(ig,k))*va(ig,k)  &
-     &               -(entr(ig,k)+gamma(ig,k))*ve(ig,k)  &
-     &               -wvd(ig,k)+wvd(ig,k+1))  &
-     &               /masse(ig,k)
-         enddo
-      enddo
-
-
-! Sorties eventuelles.
-!----------------------
-
-   if(prt_level.GE.10) then
-      do k=1,nlay
-         do ig=1,ngrid
-           print*,'th_dv2 ig k gamma entr detr ua ue va ve wud wvd masse',ig,k,gamma(ig,k), &
-     &   entr(ig,k),detr(ig,k),ua(ig,k),ue(ig,k),va(ig,k),ve(ig,k),wud(ig,k),wvd(ig,k),wud(ig,k+1),wvd(ig,k+1), &
-     &   masse(ig,k)
-         enddo
-      enddo
-   endif
-!
-     if (nlarga0>0) then
-          print*,'WARNING !!!!!! DANS THERMCELL_DV2 '
-          print*,nlarga0,' points pour lesquels laraga=0. dans un thermique'
-          print*,'Il faudrait decortiquer ces points'
-     endif
-
-      return
-      end
-END MODULE lmdz_thermcell_dv2
Index: /LMDZ6/trunk/libf/phylmd/lmdz_thermcell_dv2.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/lmdz_thermcell_dv2.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/lmdz_thermcell_dv2.f90	(revision 5268)
@@ -0,0 +1,197 @@
+MODULE lmdz_thermcell_dv2
+CONTAINS
+
+      subroutine thermcell_dv2(ngrid,nlay,ptimestep,fm,entr,masse  &
+     &    ,fraca,larga  &
+     &    ,u,v,du,dv,ua,va,lev_out)
+      USE print_control_mod, ONLY: prt_level,lunout
+      implicit none
+
+!=======================================================================
+!
+!   Calcul du transport verticale dans la couche limite en presence
+!   de "thermiques" explicitement representes
+!   calcul du dq/dt une fois qu'on connait les ascendances
+!
+! Vectorisation, FH : 2010/03/08
+!
+!=======================================================================
+
+
+      integer ngrid,nlay
+
+      real ptimestep
+      real masse(ngrid,nlay),fm(ngrid,nlay+1)
+      real fraca(ngrid,nlay+1)
+      real larga(ngrid)
+      real entr(ngrid,nlay)
+      real u(ngrid,nlay)
+      real ua(ngrid,nlay)
+      real du(ngrid,nlay)
+      real v(ngrid,nlay)
+      real va(ngrid,nlay)
+      real dv(ngrid,nlay)
+      integer lev_out                           ! niveau pour les print
+
+      real qa(ngrid,nlay),detr(ngrid,nlay),zf,zf2
+      real wvd(ngrid,nlay+1),wud(ngrid,nlay+1)
+      real gamma0(ngrid,nlay+1),gamma(ngrid,nlay+1)
+      real ue(ngrid,nlay),ve(ngrid,nlay)
+      LOGICAL ltherm(ngrid,nlay)
+      real dua(ngrid,nlay),dva(ngrid,nlay)
+      integer iter
+
+      integer ig,k,nlarga0
+
+!-------------------------------------------------------------------------
+
+!   calcul du detrainement
+!---------------------------
+
+!      print*,'THERMCELL DV2 OPTIMISE 3'
+
+      nlarga0=0.
+
+      do k=1,nlay
+         do ig=1,ngrid
+            detr(ig,k)=fm(ig,k)-fm(ig,k+1)+entr(ig,k)
+         enddo
+      enddo
+
+!   calcul de la valeur dans les ascendances
+      do ig=1,ngrid
+         ua(ig,1)=u(ig,1)
+         va(ig,1)=v(ig,1)
+         ue(ig,1)=u(ig,1)
+         ve(ig,1)=v(ig,1)
+      enddo
+
+      IF(prt_level>9)WRITE(lunout,*)                                    &
+     &      'WARNING on initialise gamma(1:ngrid,1)=0.'
+      gamma(1:ngrid,1)=0.
+      do k=2,nlay
+         do ig=1,ngrid
+            ltherm(ig,k)=(fm(ig,k+1)+detr(ig,k))*ptimestep > 1.e-5*masse(ig,k)
+            if(ltherm(ig,k).and.larga(ig)>0.) then
+               gamma0(ig,k)=masse(ig,k)  &
+     &         *sqrt( 0.5*(fraca(ig,k+1)+fraca(ig,k)) )  &
+     &         *0.5/larga(ig)  &
+     &         *1.
+            else
+               gamma0(ig,k)=0.
+            endif
+            if (ltherm(ig,k).and.larga(ig)<=0.) nlarga0=nlarga0+1
+         enddo
+      enddo
+
+      gamma(:,:)=0.
+
+      do k=2,nlay
+
+         do ig=1,ngrid
+            if (ltherm(ig,k)) then
+               dua(ig,k)=ua(ig,k-1)-u(ig,k-1)
+               dva(ig,k)=va(ig,k-1)-v(ig,k-1)
+            else
+               ua(ig,k)=u(ig,k)
+               va(ig,k)=v(ig,k)
+               ue(ig,k)=u(ig,k)
+               ve(ig,k)=v(ig,k)
+            endif
+         enddo
+
+
+! Debut des iterations
+!----------------------
+do iter=1,5
+         do ig=1,ngrid
+! Pour memoire : calcul prenant en compte la fraction reelle
+!              zf=0.5*(fraca(ig,k)+fraca(ig,k+1))
+!              zf2=1./(1.-zf)
+! Calcul avec fraction infiniement petite
+               zf=0.
+               zf2=1.
+
+!  la première fois on multiplie le coefficient de freinage
+!  par le module du vent dans la couche en dessous.
+!  Mais pourquoi donc ???
+               if (ltherm(ig,k)) then
+!   On choisit une relaxation lineaire.
+!                 gamma(ig,k)=gamma0(ig,k)
+!   On choisit une relaxation quadratique.
+                  gamma(ig,k)=gamma0(ig,k)*sqrt(dua(ig,k)**2+dva(ig,k)**2)
+                  ua(ig,k)=(fm(ig,k)*ua(ig,k-1)  &
+     &               +(zf2*entr(ig,k)+gamma(ig,k))*u(ig,k))  &
+     &               /(fm(ig,k+1)+detr(ig,k)+entr(ig,k)*zf*zf2  &
+     &                 +gamma(ig,k))
+                  va(ig,k)=(fm(ig,k)*va(ig,k-1)  &
+     &               +(zf2*entr(ig,k)+gamma(ig,k))*v(ig,k))  &
+     &               /(fm(ig,k+1)+detr(ig,k)+entr(ig,k)*zf*zf2  &
+     &                 +gamma(ig,k))
+!                 print*,k,ua(ig,k),va(ig,k),u(ig,k),v(ig,k),dua(ig,k),dva(ig,k)
+                  dua(ig,k)=ua(ig,k)-u(ig,k)
+                  dva(ig,k)=va(ig,k)-v(ig,k)
+                  ue(ig,k)=(u(ig,k)-zf*ua(ig,k))*zf2
+                  ve(ig,k)=(v(ig,k)-zf*va(ig,k))*zf2
+               endif
+         enddo
+! Fin des iterations
+!--------------------
+enddo
+
+      enddo ! k=2,nlay
+
+
+! Calcul du flux vertical de moment dans l'environnement.
+!---------------------------------------------------------
+      do k=2,nlay
+         do ig=1,ngrid
+            wud(ig,k)=fm(ig,k)*ue(ig,k)
+            wvd(ig,k)=fm(ig,k)*ve(ig,k)
+         enddo
+      enddo
+      do ig=1,ngrid
+         wud(ig,1)=0.
+         wud(ig,nlay+1)=0.
+         wvd(ig,1)=0.
+         wvd(ig,nlay+1)=0.
+      enddo
+
+! calcul des tendances.
+!-----------------------
+      do k=1,nlay
+         do ig=1,ngrid
+            du(ig,k)=((detr(ig,k)+gamma(ig,k))*ua(ig,k)  &
+     &               -(entr(ig,k)+gamma(ig,k))*ue(ig,k)  &
+     &               -wud(ig,k)+wud(ig,k+1))  &
+     &               /masse(ig,k)
+            dv(ig,k)=((detr(ig,k)+gamma(ig,k))*va(ig,k)  &
+     &               -(entr(ig,k)+gamma(ig,k))*ve(ig,k)  &
+     &               -wvd(ig,k)+wvd(ig,k+1))  &
+     &               /masse(ig,k)
+         enddo
+      enddo
+
+
+! Sorties eventuelles.
+!----------------------
+
+   if(prt_level.GE.10) then
+      do k=1,nlay
+         do ig=1,ngrid
+           print*,'th_dv2 ig k gamma entr detr ua ue va ve wud wvd masse',ig,k,gamma(ig,k), &
+     &   entr(ig,k),detr(ig,k),ua(ig,k),ue(ig,k),va(ig,k),ve(ig,k),wud(ig,k),wvd(ig,k),wud(ig,k+1),wvd(ig,k+1), &
+     &   masse(ig,k)
+         enddo
+      enddo
+   endif
+!
+     if (nlarga0>0) then
+          print*,'WARNING !!!!!! DANS THERMCELL_DV2 '
+          print*,nlarga0,' points pour lesquels laraga=0. dans un thermique'
+          print*,'Il faudrait decortiquer ces points'
+     endif
+
+      return
+      end
+END MODULE lmdz_thermcell_dv2
Index: DZ6/trunk/libf/phylmd/lmdz_thermcell_env.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/lmdz_thermcell_env.F90	(revision 5267)
+++ 	(revision )
@@ -1,98 +1,0 @@
-MODULE lmdz_thermcell_env
-CONTAINS
-
-   SUBROUTINE thermcell_env(ngrid,nlay,po,pt,pu,pv,pplay,  &
-     &           pplev,zo,zh,zl,ztv,zthl,zu,zv,zpspsk,pqsat,lcong,lintercong,lev_out)
-
-!--------------------------------------------------------------
-!thermcell_env: calcule les caracteristiques de l environnement
-!necessaires au calcul des proprietes dans le thermique
-!--------------------------------------------------------------
-
-
-   USE lmdz_thermcell_ini, ONLY : prt_level,RLvCp,RKAPPA,RETV
-   USE lmdz_thermcell_qsat, ONLY : thermcell_qsat
-   IMPLICIT NONE
-
-! arguments
-
-   integer,intent(in) :: ngrid,nlay,lev_out
-   real,intent(in), dimension(ngrid,nlay) :: po,pt,pu,pv,pplay
-   real,intent(in), dimension(ngrid,nlay+1) :: pplev
-   real,intent(out), dimension(ngrid,nlay) :: zo,zl,zh,ztv,zthl
-   real,intent(out), dimension(ngrid,nlay) :: zpspsk,zu,zv,pqsat
-   real, intent(out), dimension(ngrid) :: lintercong
-   integer, intent(out), dimension(ngrid) :: lcong   
-! Local
-
-   integer ig,ll
-   real dqsat_dT
-   logical mask(ngrid,nlay)
-
-
-!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-! Initialisations :
-!------------------
-
-   mask(:,:)=.true.
-
-!
-! calcul des caracteristiques de l environnement
-   DO  ll=1,nlay
-     DO ig=1,ngrid
-        zo(ig,ll)=po(ig,ll)
-        zl(ig,ll)=0.
-        zh(ig,ll)=pt(ig,ll)
-     enddo
-   enddo
-
-! Condensation :
-!---------------
-! Calcul de l'humidite a saturation et de la condensation
-
-   call thermcell_qsat(ngrid*nlay,mask,pplev,pt,po,pqsat)
-   do ll=1,nlay
-      do ig=1,ngrid
-         zl(ig,ll) = max(0.,po(ig,ll)-pqsat(ig,ll))
-         zh(ig,ll) = pt(ig,ll)+RLvCp*zl(ig,ll)         !   T = Tl + Lv/Cp ql
-         zo(ig,ll) = po(ig,ll)-zl(ig,ll)
-      enddo
-   enddo
-
-!-----------------------------------------------------------------------
-   if (prt_level.ge.1) print*,'0 OK convect8'
-
-   do ll=1,nlay
-      do ig=1,ngrid
-          zpspsk(ig,ll)=(pplay(ig,ll)/100000.)**RKAPPA
-          zu(ig,ll)=pu(ig,ll)
-          zv(ig,ll)=pv(ig,ll)
-!attention zh est maintenant le profil de T et plus le profil de theta !
-! Quelle horreur ! A eviter.
-!   T-> Theta
-            ztv(ig,ll)=zh(ig,ll)/zpspsk(ig,ll)
-!Theta_v
-            ztv(ig,ll)=ztv(ig,ll)*(1.+RETV*(zo(ig,ll))-zl(ig,ll))
-!Thetal
-            zthl(ig,ll)=pt(ig,ll)/zpspsk(ig,ll)
-!            
-      enddo
-   enddo
-!CR: Calcul du niveau de congelation
-   do ig=1,ngrid
-      lcong(ig)=1
-      lintercong(ig)=0.
-   enddo
-   do ig=1,ngrid
-      do ll=1,nlay-1
-         if ((zh(ig,ll).gt.273.15).and.(zh(ig,ll+1).le.273.15)) then
-            lcong(ig)=ll+1
-            lintercong(ig)=(ll*(zh(ig,ll+1)-zh(ig,ll))  &
-     &               -zh(ig,ll)+273.15)/(zh(ig,ll+1)-zh(ig,ll))
-         endif
-      enddo
-   enddo 
- 
- RETURN
-   END
-END MODULE lmdz_thermcell_env
Index: /LMDZ6/trunk/libf/phylmd/lmdz_thermcell_env.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/lmdz_thermcell_env.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/lmdz_thermcell_env.f90	(revision 5268)
@@ -0,0 +1,98 @@
+MODULE lmdz_thermcell_env
+CONTAINS
+
+   SUBROUTINE thermcell_env(ngrid,nlay,po,pt,pu,pv,pplay,  &
+     &           pplev,zo,zh,zl,ztv,zthl,zu,zv,zpspsk,pqsat,lcong,lintercong,lev_out)
+
+!--------------------------------------------------------------
+!thermcell_env: calcule les caracteristiques de l environnement
+!necessaires au calcul des proprietes dans le thermique
+!--------------------------------------------------------------
+
+
+   USE lmdz_thermcell_ini, ONLY : prt_level,RLvCp,RKAPPA,RETV
+   USE lmdz_thermcell_qsat, ONLY : thermcell_qsat
+   IMPLICIT NONE
+
+! arguments
+
+   integer,intent(in) :: ngrid,nlay,lev_out
+   real,intent(in), dimension(ngrid,nlay) :: po,pt,pu,pv,pplay
+   real,intent(in), dimension(ngrid,nlay+1) :: pplev
+   real,intent(out), dimension(ngrid,nlay) :: zo,zl,zh,ztv,zthl
+   real,intent(out), dimension(ngrid,nlay) :: zpspsk,zu,zv,pqsat
+   real, intent(out), dimension(ngrid) :: lintercong
+   integer, intent(out), dimension(ngrid) :: lcong   
+! Local
+
+   integer ig,ll
+   real dqsat_dT
+   logical mask(ngrid,nlay)
+
+
+!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+! Initialisations :
+!------------------
+
+   mask(:,:)=.true.
+
+!
+! calcul des caracteristiques de l environnement
+   DO  ll=1,nlay
+     DO ig=1,ngrid
+        zo(ig,ll)=po(ig,ll)
+        zl(ig,ll)=0.
+        zh(ig,ll)=pt(ig,ll)
+     enddo
+   enddo
+
+! Condensation :
+!---------------
+! Calcul de l'humidite a saturation et de la condensation
+
+   call thermcell_qsat(ngrid*nlay,mask,pplev,pt,po,pqsat)
+   do ll=1,nlay
+      do ig=1,ngrid
+         zl(ig,ll) = max(0.,po(ig,ll)-pqsat(ig,ll))
+         zh(ig,ll) = pt(ig,ll)+RLvCp*zl(ig,ll)         !   T = Tl + Lv/Cp ql
+         zo(ig,ll) = po(ig,ll)-zl(ig,ll)
+      enddo
+   enddo
+
+!-----------------------------------------------------------------------
+   if (prt_level.ge.1) print*,'0 OK convect8'
+
+   do ll=1,nlay
+      do ig=1,ngrid
+          zpspsk(ig,ll)=(pplay(ig,ll)/100000.)**RKAPPA
+          zu(ig,ll)=pu(ig,ll)
+          zv(ig,ll)=pv(ig,ll)
+!attention zh est maintenant le profil de T et plus le profil de theta !
+! Quelle horreur ! A eviter.
+!   T-> Theta
+            ztv(ig,ll)=zh(ig,ll)/zpspsk(ig,ll)
+!Theta_v
+            ztv(ig,ll)=ztv(ig,ll)*(1.+RETV*(zo(ig,ll))-zl(ig,ll))
+!Thetal
+            zthl(ig,ll)=pt(ig,ll)/zpspsk(ig,ll)
+!            
+      enddo
+   enddo
+!CR: Calcul du niveau de congelation
+   do ig=1,ngrid
+      lcong(ig)=1
+      lintercong(ig)=0.
+   enddo
+   do ig=1,ngrid
+      do ll=1,nlay-1
+         if ((zh(ig,ll).gt.273.15).and.(zh(ig,ll+1).le.273.15)) then
+            lcong(ig)=ll+1
+            lintercong(ig)=(ll*(zh(ig,ll+1)-zh(ig,ll))  &
+     &               -zh(ig,ll)+273.15)/(zh(ig,ll+1)-zh(ig,ll))
+         endif
+      enddo
+   enddo 
+ 
+ RETURN
+   END
+END MODULE lmdz_thermcell_env
Index: DZ6/trunk/libf/phylmd/lmdz_thermcell_flux2.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/lmdz_thermcell_flux2.F90	(revision 5267)
+++ 	(revision )
@@ -1,515 +1,0 @@
-MODULE lmdz_thermcell_flux2
-!
-! $Id$
-!
-CONTAINS
-
-      SUBROUTINE thermcell_flux2(ngrid,nlay,ptimestep,masse, &
-     &       lalim,lmax,alim_star,  &
-     &       entr_star,detr_star,f,rhobarz,zlev,zw2,fm,entr,  &
-     &       detr,zqla,lev_out,lunout1,igout)
-!IM 060508    &       detr,zqla,zmax,lev_out,lunout,igout)
-
-
-!---------------------------------------------------------------------------
-!thermcell_flux: deduction des flux
-!---------------------------------------------------------------------------
-
-      USE lmdz_thermcell_ini, ONLY : prt_level,iflag_thermals_optflux
-      IMPLICIT NONE
-      
-! arguments
-      INTEGER, intent(in) :: ngrid,nlay
-      REAL, intent(in) :: ptimestep
-      REAL, intent(in), dimension(ngrid,nlay) :: masse
-      INTEGER, intent(in), dimension(ngrid) :: lalim,lmax
-      REAL, intent(in), dimension(ngrid,nlay) :: alim_star,entr_star,detr_star
-      REAL, intent(in), dimension(ngrid) :: f
-      REAL, intent(in), dimension(ngrid,nlay) :: rhobarz
-      REAL, intent(in), dimension(ngrid,nlay+1) :: zw2,zlev
-! FH : laisser ca le temps de verifier qu'on a bien fait de commenter les
-!      lignes faisant apparaitre zqla, zmax ...
-!     REAL, intent(in), dimension(ngrid) :: zmax(ngrid)
-!     enlever aussi zqla
-      REAL, intent(in), dimension(ngrid,nlay) :: zqla  ! not used
-      integer, intent(in) :: lev_out, lunout1
-
-      REAL,intent(out), dimension(ngrid,nlay) :: entr,detr
-      REAL,intent(out), dimension(ngrid,nlay+1) :: fm
-
-! local
-      INTEGER ig,l
-      integer igout,lout
-      REAL zfm
-      integer ncorecfm1,ncorecfm2,ncorecfm3,ncorecalpha
-      integer ncorecfm4,ncorecfm5,ncorecfm6,ncorecfm7,ncorecfm8
-      
-
-      REAL f_old,ddd0,eee0,ddd,eee,zzz
-
-      REAL,SAVE :: fomass_max=0.5
-      REAL,SAVE :: alphamax=0.7
-!$OMP THREADPRIVATE(fomass_max,alphamax)
-
-      logical check_debug,labort_physic
-
-      character (len=20) :: modname='thermcell_flux2'
-      character (len=80) :: abort_message
-
-
-      ncorecfm1=0
-      ncorecfm2=0
-      ncorecfm3=0
-      ncorecfm4=0
-      ncorecfm5=0
-      ncorecfm6=0
-      ncorecfm7=0
-      ncorecfm8=0
-      ncorecalpha=0
-
-!initialisation
-      fm(:,:)=0.
-      
-      if (prt_level.ge.10) then
-         write(lunout1,*) 'Dans thermcell_flux 0'
-         write(lunout1,*) 'flux base ',f(igout)
-         write(lunout1,*) 'lmax ',lmax(igout)
-         write(lunout1,*) 'lalim ',lalim(igout)
-         write(lunout1,*) 'ig= ',igout
-         write(lunout1,*) ' l E*    A*     D*  '
-         write(lunout1,'(i4,3e15.5)') (l,entr_star(igout,l),alim_star(igout,l),detr_star(igout,l) &
-     &    ,l=1,lmax(igout))
-      endif
-
-
-!-------------------------------------------------------------------------
-! Verification de la nullite des entrainement et detrainement au dessus
-! de lmax(ig)
-! Active uniquement si check_debug=.true. ou prt_level>=10
-!-------------------------------------------------------------------------
-
-      check_debug=.false..or.prt_level>=10
-
-      if (check_debug) then
-      do l=1,nlay
-         do ig=1,ngrid
-            if (l.le.lmax(ig)) then
-               if (entr_star(ig,l).gt.1.) then
-                    print*,'WARNING thermcell_flux 1 ig,l,lmax(ig)',ig,l,lmax(ig)
-                    print*,'entr_star(ig,l)',entr_star(ig,l)
-                    print*,'alim_star(ig,l)',alim_star(ig,l)
-                    print*,'detr_star(ig,l)',detr_star(ig,l)
-               endif
-            else
-               if (abs(entr_star(ig,l))+abs(alim_star(ig,l))+abs(detr_star(ig,l)).gt.0.) then
-                    print*,'cas 1 : ig,l,lmax(ig)',ig,l,lmax(ig)
-                    print*,'entr_star(ig,l)',entr_star(ig,l)
-                    print*,'alim_star(ig,l)',alim_star(ig,l)
-                    print*,'detr_star(ig,l)',detr_star(ig,l)
-                    abort_message = ''
-                    labort_physic=.true.
-                    CALL abort_physic (modname,abort_message,1)
-               endif
-            endif
-         enddo
-      enddo
-      endif
-
-!-------------------------------------------------------------------------
-! Multiplication par le flux de masse issu de la femreture
-!-------------------------------------------------------------------------
-
-      do l=1,nlay
-         entr(:,l)=f(:)*(entr_star(:,l)+alim_star(:,l))
-         detr(:,l)=f(:)*detr_star(:,l)
-      enddo
-
-      if (prt_level.ge.10) then
-         write(lunout1,*) 'Dans thermcell_flux 1'
-         write(lunout1,*) 'flux base ',f(igout)
-         write(lunout1,*) 'lmax ',lmax(igout)
-         write(lunout1,*) 'lalim ',lalim(igout)
-         write(lunout1,*) 'ig= ',igout
-         write(lunout1,*) ' l   E    D     W2'
-         write(lunout1,'(i4,3e15.5)') (l,entr(igout,l),detr(igout,l) &
-     &    ,zw2(igout,l+1),l=1,lmax(igout))
-      endif
-
-      fm(:,1)=0.
-      do l=1,nlay
-         do ig=1,ngrid
-            if (l.lt.lmax(ig)) then
-               fm(ig,l+1)=fm(ig,l)+entr(ig,l)-detr(ig,l)
-            elseif(l.eq.lmax(ig)) then
-               fm(ig,l+1)=0.
-               detr(ig,l)=fm(ig,l)+entr(ig,l)
-            else
-               fm(ig,l+1)=0.
-            endif
-         enddo
-      enddo
-
-
-
-! Test provisoire : pour comprendre pourquoi on corrige plein de fois 
-! le cas fm6, on commence par regarder une premiere fois avant les
-! autres corrections.
-
-      do l=1,nlay
-         do ig=1,ngrid
-            if (detr(ig,l).gt.fm(ig,l)) then
-               ncorecfm8=ncorecfm8+1
-!              igout=ig
-            endif
-         enddo
-      enddo
-
-!      if (prt_level.ge.10) &
-!    &    call printflux(ngrid,nlay,lunout1,igout,f,lmax,lalim, &
-!    &    ptimestep,masse,entr,detr,fm,'2  ')
-
-
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! FH Version en cours de test;
-! par rapport a thermcell_flux, on fait une grande boucle sur "l"
-! et on modifie le flux avec tous les contr�les appliques d'affilee
-! pour la meme couche
-! Momentanement, on duplique le calcule du flux pour pouvoir comparer
-! les flux avant et apres modif
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-      do l=1,nlay
-
-         do ig=1,ngrid
-            if (l.lt.lmax(ig)) then
-               fm(ig,l+1)=fm(ig,l)+entr(ig,l)-detr(ig,l)
-            elseif(l.eq.lmax(ig)) then
-               fm(ig,l+1)=0.
-               detr(ig,l)=fm(ig,l)+entr(ig,l)
-            else
-               fm(ig,l+1)=0.
-            endif
-         enddo
-
-
-!-------------------------------------------------------------------------
-! Verification de la positivite des flux de masse
-!-------------------------------------------------------------------------
-
-!     do l=1,nlay
-         do ig=1,ngrid
-            if (fm(ig,l+1).lt.0.) then
-!              print*,'fm1<0',l+1,lmax(ig),fm(ig,l+1)
-                ncorecfm1=ncorecfm1+1
-               fm(ig,l+1)=fm(ig,l)
-               detr(ig,l)=entr(ig,l)
-            endif
-         enddo
-!     enddo
-
-      if (prt_level.ge.10) &
-     &   write(lunout1,'(i4,4e14.4)') l,masse(igout,l)/ptimestep, &
-     &     entr(igout,l),detr(igout,l),fm(igout,l+1)
-
-!-------------------------------------------------------------------------
-!Test sur fraca croissant
-!-------------------------------------------------------------------------
-      if (iflag_thermals_optflux==0) then 
-!     do l=1,nlay
-         do ig=1,ngrid
-          if (l.ge.lalim(ig).and.l.le.lmax(ig) &
-     &    .and.(zw2(ig,l+1).gt.1.e-10).and.(zw2(ig,l).gt.1.e-10) ) then
-!  zzz est le flux en l+1 a frac constant
-             zzz=fm(ig,l)*rhobarz(ig,l+1)*zw2(ig,l+1)  &
-     &                          /(rhobarz(ig,l)*zw2(ig,l))
-             if (fm(ig,l+1).gt.zzz) then
-                detr(ig,l)=detr(ig,l)+fm(ig,l+1)-zzz
-                fm(ig,l+1)=zzz
-                ncorecfm4=ncorecfm4+1
-             endif
-          endif
-        enddo
-!     enddo
-      endif
-
-      if (prt_level.ge.10) &
-     &   write(lunout1,'(i4,4e14.4)') l,masse(igout,l)/ptimestep, &
-     &     entr(igout,l),detr(igout,l),fm(igout,l+1)
-
-
-!-------------------------------------------------------------------------
-!test sur flux de masse croissant
-!-------------------------------------------------------------------------
-      if (iflag_thermals_optflux==0) then
-!     do l=1,nlay
-         do ig=1,ngrid
-            if ((fm(ig,l+1).gt.fm(ig,l)).and.(l.gt.lalim(ig))) then
-              f_old=fm(ig,l+1)
-              fm(ig,l+1)=fm(ig,l)
-              detr(ig,l)=detr(ig,l)+f_old-fm(ig,l+1)
-               ncorecfm5=ncorecfm5+1
-            endif
-         enddo
-!     enddo
-      endif
-
-      if (prt_level.ge.10) &
-     &   write(lunout1,'(i4,4e14.4)') l,masse(igout,l)/ptimestep, &
-     &     entr(igout,l),detr(igout,l),fm(igout,l+1)
-
-!fin 1.eq.0
-!-------------------------------------------------------------------------
-!detr ne peut pas etre superieur a fm
-!-------------------------------------------------------------------------
-
-      if(1.eq.1) then
-
-!     do l=1,nlay
-
-
-
-         labort_physic=.false.
-         do ig=1,ngrid
-            if (entr(ig,l)<0.) then
-               labort_physic=.true.
-               igout=ig
-               lout=l
-            endif
-         enddo
-
-         if (labort_physic) then
-            print*,'N1 ig,l,entr',igout,lout,entr(igout,lout)
-            abort_message = 'entr negatif'
-            CALL abort_physic (modname,abort_message,1)
-         endif
-
-         do ig=1,ngrid
-            if (detr(ig,l).gt.fm(ig,l)) then
-               ncorecfm6=ncorecfm6+1
-               detr(ig,l)=fm(ig,l)
-               entr(ig,l)=fm(ig,l+1)
-
-! Dans le cas ou on est au dessus de la couche d'alimentation et que le
-! detrainement est plus fort que le flux de masse, on stope le thermique.
-!test:on commente
-!               if (l.gt.lalim(ig)) then
-!                  lmax(ig)=l
-!                  fm(ig,l+1)=0.
-!                  entr(ig,l)=0.
-!               else
-!                  ncorecfm7=ncorecfm7+1
-!               endif
-            endif
-
-            if(l.gt.lmax(ig)) then
-               detr(ig,l)=0.
-               fm(ig,l+1)=0.
-               entr(ig,l)=0.
-            endif
-         enddo
-
-         labort_physic=.false.
-         do ig=1,ngrid
-            if (entr(ig,l).lt.0.) then
-               labort_physic=.true.
-               igout=ig
-            endif
-         enddo
-         if (labort_physic) then
-            ig=igout
-            print*,'ig,l,lmax(ig)',ig,l,lmax(ig)
-            print*,'entr(ig,l)',entr(ig,l)
-            print*,'fm(ig,l)',fm(ig,l)
-            abort_message = 'probleme dans thermcell flux'
-            CALL abort_physic (modname,abort_message,1)
-         endif
-
-
-!     enddo
-      endif
-
-
-      if (prt_level.ge.10) &
-     &   write(lunout1,'(i4,4e14.4)') l,masse(igout,l)/ptimestep, &
-     &     entr(igout,l),detr(igout,l),fm(igout,l+1)
-
-!-------------------------------------------------------------------------
-!fm ne peut pas etre negatif
-!-------------------------------------------------------------------------
-
-!     do l=1,nlay
-         do ig=1,ngrid
-            if (fm(ig,l+1).lt.0.) then
-               detr(ig,l)=detr(ig,l)+fm(ig,l+1)
-               fm(ig,l+1)=0.
-               ncorecfm2=ncorecfm2+1
-            endif
-         enddo
-
-         labort_physic=.false.
-         do ig=1,ngrid
-            if (detr(ig,l).lt.0.) then
-               labort_physic=.true.
-               igout=ig
-            endif
-        enddo
-        if (labort_physic) then
-               ig=igout
-               print*,'cas 2 : ig,l,lmax(ig)',ig,l,lmax(ig)
-               print*,'detr(ig,l)',detr(ig,l)
-               print*,'fm(ig,l)',fm(ig,l)
-               abort_message = 'probleme dans thermcell flux'
-               CALL abort_physic (modname,abort_message,1)
-        endif
-!    enddo
-
-      if (prt_level.ge.10) &
-     &   write(lunout1,'(i4,4e14.4)') l,masse(igout,l)/ptimestep, &
-     &     entr(igout,l),detr(igout,l),fm(igout,l+1)
-
-!-----------------------------------------------------------------------
-!la fraction couverte ne peut pas etre superieure a 1            
-!-----------------------------------------------------------------------
-
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! FH Partie a revisiter.
-! Il semble qu'etaient codees ici deux optiques dans le cas
-! F/ (rho *w) > 1
-! soit limiter la hauteur du thermique en considerant que c'est 
-! la derniere chouche, soit limiter F a rho w.
-! Dans le second cas, il faut en fait limiter a un peu moins
-! que ca parce qu'on a des 1 / ( 1 -alpha) un peu plus loin
-! dans thermcell_main et qu'il semble de toutes facons deraisonable
-! d'avoir des fractions de 1..
-! Ci dessous, et dans l'etat actuel, le premier des  deux if est
-! sans doute inutile.
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-!    do l=1,nlay
-        do ig=1,ngrid
-           if (zw2(ig,l+1).gt.1.e-10) then
-           zfm=rhobarz(ig,l+1)*zw2(ig,l+1)*alphamax
-           if ( fm(ig,l+1) .gt. zfm) then
-              f_old=fm(ig,l+1)
-              fm(ig,l+1)=zfm
-              detr(ig,l)=detr(ig,l)+f_old-fm(ig,l+1)
-!             lmax(ig)=l+1
-!             zmax(ig)=zlev(ig,lmax(ig))
-!             print*,'alpha>1',l+1,lmax(ig)
-              ncorecalpha=ncorecalpha+1
-           endif
-           endif
-        enddo
-!    enddo
-!
-
-
-      if (prt_level.ge.10) &
-     &   write(lunout1,'(i4,4e14.4)') l,masse(igout,l)/ptimestep, &
-     &     entr(igout,l),detr(igout,l),fm(igout,l+1)
-
-! Fin de la grande boucle sur les niveaux verticaux
-      enddo
-
-!      if (prt_level.ge.10) &
-!    &    call printflux(ngrid,nlay,lunout1,igout,f,lmax,lalim, &
-!    &    ptimestep,masse,entr,detr,fm,'8  ')
-
-
-!-----------------------------------------------------------------------
-! On fait en sorte que la quantite totale d'air entraine dans le 
-! panache ne soit pas trop grande comparee a la masse de la maille
-!-----------------------------------------------------------------------
-
-      if (1.eq.1) then
-      labort_physic=.false.
-      do l=1,nlay-1
-         do ig=1,ngrid
-            eee0=entr(ig,l)
-            ddd0=detr(ig,l)
-            eee=entr(ig,l)-masse(ig,l)*fomass_max/ptimestep
-            ddd=detr(ig,l)-eee
-            if (eee.gt.0.) then
-                ncorecfm3=ncorecfm3+1
-                entr(ig,l)=entr(ig,l)-eee
-                if ( ddd.gt.0.) then
-!   l'entrainement est trop fort mais l'exces peut etre compense par une
-!   diminution du detrainement)
-                   detr(ig,l)=ddd
-                else
-!   l'entrainement est trop fort mais l'exces doit etre compense en partie
-!   par un entrainement plus fort dans la couche superieure
-                   if(l.eq.lmax(ig)) then
-                      detr(ig,l)=fm(ig,l)+entr(ig,l)
-                   else
-                      if(l.ge.lmax(ig).and.0.eq.1) then
-                         igout=ig
-                         lout=l
-                         labort_physic=.true.
-                      endif
-                      entr(ig,l+1)=entr(ig,l+1)-ddd
-                      detr(ig,l)=0.
-                      fm(ig,l+1)=fm(ig,l)+entr(ig,l)
-                      detr(ig,l)=0.
-                   endif
-                endif
-            endif
-         enddo
-      enddo
-      if (labort_physic) then
-                         ig=igout
-                         l=lout
-                         print*,'ig,l',ig,l
-                         print*,'eee0',eee0
-                         print*,'ddd0',ddd0
-                         print*,'eee',eee
-                         print*,'ddd',ddd
-                         print*,'entr',entr(ig,l)
-                         print*,'detr',detr(ig,l)
-                         print*,'masse',masse(ig,l)
-                         print*,'fomass_max',fomass_max
-                         print*,'masse(ig,l)*fomass_max/ptimestep',masse(ig,l)*fomass_max/ptimestep
-                         print*,'ptimestep',ptimestep
-                         print*,'lmax(ig)',lmax(ig)
-                         print*,'fm(ig,l+1)',fm(ig,l+1)
-                         print*,'fm(ig,l)',fm(ig,l)
-                         abort_message = 'probleme dans thermcell_flux'
-                         CALL abort_physic (modname,abort_message,1)
-      endif
-      endif
-!                  
-!              ddd=detr(ig)-entre
-!on s assure que tout s annule bien en zmax
-      do ig=1,ngrid
-         fm(ig,lmax(ig)+1)=0.
-         entr(ig,lmax(ig))=0.
-         detr(ig,lmax(ig))=fm(ig,lmax(ig))+entr(ig,lmax(ig))
-      enddo
-
-!-----------------------------------------------------------------------
-! Impression du nombre de bidouilles qui ont ete necessaires
-!-----------------------------------------------------------------------
-
-!IM 090508 beg
-!     if (ncorecfm1+ncorecfm2+ncorecfm3+ncorecfm4+ncorecfm5+ncorecalpha > 0 ) then
-!
-!         print*,'PB thermcell : on a du coriger ',ncorecfm1,'x fm1',&
-!   &     ncorecfm2,'x fm2',ncorecfm3,'x fm3 et', &
-!   &     ncorecfm4,'x fm4',ncorecfm5,'x fm5 et', &
-!   &     ncorecfm6,'x fm6', &
-!   &     ncorecfm7,'x fm7', &
-!   &     ncorecfm8,'x fm8', &
-!   &     ncorecalpha,'x alpha'
-!     endif
-!IM 090508 end
-
-!      if (prt_level.ge.10) &
-!    &    call printflux(ngrid,nlay,lunout1,igout,f,lmax,lalim, &
-!    &    ptimestep,masse,entr,detr,fm,'fin')
-
-
- RETURN
-      end
-END MODULE lmdz_thermcell_flux2
Index: /LMDZ6/trunk/libf/phylmd/lmdz_thermcell_flux2.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/lmdz_thermcell_flux2.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/lmdz_thermcell_flux2.f90	(revision 5268)
@@ -0,0 +1,515 @@
+MODULE lmdz_thermcell_flux2
+!
+! $Id$
+!
+CONTAINS
+
+      SUBROUTINE thermcell_flux2(ngrid,nlay,ptimestep,masse, &
+     &       lalim,lmax,alim_star,  &
+     &       entr_star,detr_star,f,rhobarz,zlev,zw2,fm,entr,  &
+     &       detr,zqla,lev_out,lunout1,igout)
+!IM 060508    &       detr,zqla,zmax,lev_out,lunout,igout)
+
+
+!---------------------------------------------------------------------------
+!thermcell_flux: deduction des flux
+!---------------------------------------------------------------------------
+
+      USE lmdz_thermcell_ini, ONLY : prt_level,iflag_thermals_optflux
+      IMPLICIT NONE
+      
+! arguments
+      INTEGER, intent(in) :: ngrid,nlay
+      REAL, intent(in) :: ptimestep
+      REAL, intent(in), dimension(ngrid,nlay) :: masse
+      INTEGER, intent(in), dimension(ngrid) :: lalim,lmax
+      REAL, intent(in), dimension(ngrid,nlay) :: alim_star,entr_star,detr_star
+      REAL, intent(in), dimension(ngrid) :: f
+      REAL, intent(in), dimension(ngrid,nlay) :: rhobarz
+      REAL, intent(in), dimension(ngrid,nlay+1) :: zw2,zlev
+! FH : laisser ca le temps de verifier qu'on a bien fait de commenter les
+!      lignes faisant apparaitre zqla, zmax ...
+!     REAL, intent(in), dimension(ngrid) :: zmax(ngrid)
+!     enlever aussi zqla
+      REAL, intent(in), dimension(ngrid,nlay) :: zqla  ! not used
+      integer, intent(in) :: lev_out, lunout1
+
+      REAL,intent(out), dimension(ngrid,nlay) :: entr,detr
+      REAL,intent(out), dimension(ngrid,nlay+1) :: fm
+
+! local
+      INTEGER ig,l
+      integer igout,lout
+      REAL zfm
+      integer ncorecfm1,ncorecfm2,ncorecfm3,ncorecalpha
+      integer ncorecfm4,ncorecfm5,ncorecfm6,ncorecfm7,ncorecfm8
+      
+
+      REAL f_old,ddd0,eee0,ddd,eee,zzz
+
+      REAL,SAVE :: fomass_max=0.5
+      REAL,SAVE :: alphamax=0.7
+!$OMP THREADPRIVATE(fomass_max,alphamax)
+
+      logical check_debug,labort_physic
+
+      character (len=20) :: modname='thermcell_flux2'
+      character (len=80) :: abort_message
+
+
+      ncorecfm1=0
+      ncorecfm2=0
+      ncorecfm3=0
+      ncorecfm4=0
+      ncorecfm5=0
+      ncorecfm6=0
+      ncorecfm7=0
+      ncorecfm8=0
+      ncorecalpha=0
+
+!initialisation
+      fm(:,:)=0.
+      
+      if (prt_level.ge.10) then
+         write(lunout1,*) 'Dans thermcell_flux 0'
+         write(lunout1,*) 'flux base ',f(igout)
+         write(lunout1,*) 'lmax ',lmax(igout)
+         write(lunout1,*) 'lalim ',lalim(igout)
+         write(lunout1,*) 'ig= ',igout
+         write(lunout1,*) ' l E*    A*     D*  '
+         write(lunout1,'(i4,3e15.5)') (l,entr_star(igout,l),alim_star(igout,l),detr_star(igout,l) &
+     &    ,l=1,lmax(igout))
+      endif
+
+
+!-------------------------------------------------------------------------
+! Verification de la nullite des entrainement et detrainement au dessus
+! de lmax(ig)
+! Active uniquement si check_debug=.true. ou prt_level>=10
+!-------------------------------------------------------------------------
+
+      check_debug=.false..or.prt_level>=10
+
+      if (check_debug) then
+      do l=1,nlay
+         do ig=1,ngrid
+            if (l.le.lmax(ig)) then
+               if (entr_star(ig,l).gt.1.) then
+                    print*,'WARNING thermcell_flux 1 ig,l,lmax(ig)',ig,l,lmax(ig)
+                    print*,'entr_star(ig,l)',entr_star(ig,l)
+                    print*,'alim_star(ig,l)',alim_star(ig,l)
+                    print*,'detr_star(ig,l)',detr_star(ig,l)
+               endif
+            else
+               if (abs(entr_star(ig,l))+abs(alim_star(ig,l))+abs(detr_star(ig,l)).gt.0.) then
+                    print*,'cas 1 : ig,l,lmax(ig)',ig,l,lmax(ig)
+                    print*,'entr_star(ig,l)',entr_star(ig,l)
+                    print*,'alim_star(ig,l)',alim_star(ig,l)
+                    print*,'detr_star(ig,l)',detr_star(ig,l)
+                    abort_message = ''
+                    labort_physic=.true.
+                    CALL abort_physic (modname,abort_message,1)
+               endif
+            endif
+         enddo
+      enddo
+      endif
+
+!-------------------------------------------------------------------------
+! Multiplication par le flux de masse issu de la femreture
+!-------------------------------------------------------------------------
+
+      do l=1,nlay
+         entr(:,l)=f(:)*(entr_star(:,l)+alim_star(:,l))
+         detr(:,l)=f(:)*detr_star(:,l)
+      enddo
+
+      if (prt_level.ge.10) then
+         write(lunout1,*) 'Dans thermcell_flux 1'
+         write(lunout1,*) 'flux base ',f(igout)
+         write(lunout1,*) 'lmax ',lmax(igout)
+         write(lunout1,*) 'lalim ',lalim(igout)
+         write(lunout1,*) 'ig= ',igout
+         write(lunout1,*) ' l   E    D     W2'
+         write(lunout1,'(i4,3e15.5)') (l,entr(igout,l),detr(igout,l) &
+     &    ,zw2(igout,l+1),l=1,lmax(igout))
+      endif
+
+      fm(:,1)=0.
+      do l=1,nlay
+         do ig=1,ngrid
+            if (l.lt.lmax(ig)) then
+               fm(ig,l+1)=fm(ig,l)+entr(ig,l)-detr(ig,l)
+            elseif(l.eq.lmax(ig)) then
+               fm(ig,l+1)=0.
+               detr(ig,l)=fm(ig,l)+entr(ig,l)
+            else
+               fm(ig,l+1)=0.
+            endif
+         enddo
+      enddo
+
+
+
+! Test provisoire : pour comprendre pourquoi on corrige plein de fois 
+! le cas fm6, on commence par regarder une premiere fois avant les
+! autres corrections.
+
+      do l=1,nlay
+         do ig=1,ngrid
+            if (detr(ig,l).gt.fm(ig,l)) then
+               ncorecfm8=ncorecfm8+1
+!              igout=ig
+            endif
+         enddo
+      enddo
+
+!      if (prt_level.ge.10) &
+!    &    call printflux(ngrid,nlay,lunout1,igout,f,lmax,lalim, &
+!    &    ptimestep,masse,entr,detr,fm,'2  ')
+
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! FH Version en cours de test;
+! par rapport a thermcell_flux, on fait une grande boucle sur "l"
+! et on modifie le flux avec tous les contr�les appliques d'affilee
+! pour la meme couche
+! Momentanement, on duplique le calcule du flux pour pouvoir comparer
+! les flux avant et apres modif
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+      do l=1,nlay
+
+         do ig=1,ngrid
+            if (l.lt.lmax(ig)) then
+               fm(ig,l+1)=fm(ig,l)+entr(ig,l)-detr(ig,l)
+            elseif(l.eq.lmax(ig)) then
+               fm(ig,l+1)=0.
+               detr(ig,l)=fm(ig,l)+entr(ig,l)
+            else
+               fm(ig,l+1)=0.
+            endif
+         enddo
+
+
+!-------------------------------------------------------------------------
+! Verification de la positivite des flux de masse
+!-------------------------------------------------------------------------
+
+!     do l=1,nlay
+         do ig=1,ngrid
+            if (fm(ig,l+1).lt.0.) then
+!              print*,'fm1<0',l+1,lmax(ig),fm(ig,l+1)
+                ncorecfm1=ncorecfm1+1
+               fm(ig,l+1)=fm(ig,l)
+               detr(ig,l)=entr(ig,l)
+            endif
+         enddo
+!     enddo
+
+      if (prt_level.ge.10) &
+     &   write(lunout1,'(i4,4e14.4)') l,masse(igout,l)/ptimestep, &
+     &     entr(igout,l),detr(igout,l),fm(igout,l+1)
+
+!-------------------------------------------------------------------------
+!Test sur fraca croissant
+!-------------------------------------------------------------------------
+      if (iflag_thermals_optflux==0) then 
+!     do l=1,nlay
+         do ig=1,ngrid
+          if (l.ge.lalim(ig).and.l.le.lmax(ig) &
+     &    .and.(zw2(ig,l+1).gt.1.e-10).and.(zw2(ig,l).gt.1.e-10) ) then
+!  zzz est le flux en l+1 a frac constant
+             zzz=fm(ig,l)*rhobarz(ig,l+1)*zw2(ig,l+1)  &
+     &                          /(rhobarz(ig,l)*zw2(ig,l))
+             if (fm(ig,l+1).gt.zzz) then
+                detr(ig,l)=detr(ig,l)+fm(ig,l+1)-zzz
+                fm(ig,l+1)=zzz
+                ncorecfm4=ncorecfm4+1
+             endif
+          endif
+        enddo
+!     enddo
+      endif
+
+      if (prt_level.ge.10) &
+     &   write(lunout1,'(i4,4e14.4)') l,masse(igout,l)/ptimestep, &
+     &     entr(igout,l),detr(igout,l),fm(igout,l+1)
+
+
+!-------------------------------------------------------------------------
+!test sur flux de masse croissant
+!-------------------------------------------------------------------------
+      if (iflag_thermals_optflux==0) then
+!     do l=1,nlay
+         do ig=1,ngrid
+            if ((fm(ig,l+1).gt.fm(ig,l)).and.(l.gt.lalim(ig))) then
+              f_old=fm(ig,l+1)
+              fm(ig,l+1)=fm(ig,l)
+              detr(ig,l)=detr(ig,l)+f_old-fm(ig,l+1)
+               ncorecfm5=ncorecfm5+1
+            endif
+         enddo
+!     enddo
+      endif
+
+      if (prt_level.ge.10) &
+     &   write(lunout1,'(i4,4e14.4)') l,masse(igout,l)/ptimestep, &
+     &     entr(igout,l),detr(igout,l),fm(igout,l+1)
+
+!fin 1.eq.0
+!-------------------------------------------------------------------------
+!detr ne peut pas etre superieur a fm
+!-------------------------------------------------------------------------
+
+      if(1.eq.1) then
+
+!     do l=1,nlay
+
+
+
+         labort_physic=.false.
+         do ig=1,ngrid
+            if (entr(ig,l)<0.) then
+               labort_physic=.true.
+               igout=ig
+               lout=l
+            endif
+         enddo
+
+         if (labort_physic) then
+            print*,'N1 ig,l,entr',igout,lout,entr(igout,lout)
+            abort_message = 'entr negatif'
+            CALL abort_physic (modname,abort_message,1)
+         endif
+
+         do ig=1,ngrid
+            if (detr(ig,l).gt.fm(ig,l)) then
+               ncorecfm6=ncorecfm6+1
+               detr(ig,l)=fm(ig,l)
+               entr(ig,l)=fm(ig,l+1)
+
+! Dans le cas ou on est au dessus de la couche d'alimentation et que le
+! detrainement est plus fort que le flux de masse, on stope le thermique.
+!test:on commente
+!               if (l.gt.lalim(ig)) then
+!                  lmax(ig)=l
+!                  fm(ig,l+1)=0.
+!                  entr(ig,l)=0.
+!               else
+!                  ncorecfm7=ncorecfm7+1
+!               endif
+            endif
+
+            if(l.gt.lmax(ig)) then
+               detr(ig,l)=0.
+               fm(ig,l+1)=0.
+               entr(ig,l)=0.
+            endif
+         enddo
+
+         labort_physic=.false.
+         do ig=1,ngrid
+            if (entr(ig,l).lt.0.) then
+               labort_physic=.true.
+               igout=ig
+            endif
+         enddo
+         if (labort_physic) then
+            ig=igout
+            print*,'ig,l,lmax(ig)',ig,l,lmax(ig)
+            print*,'entr(ig,l)',entr(ig,l)
+            print*,'fm(ig,l)',fm(ig,l)
+            abort_message = 'probleme dans thermcell flux'
+            CALL abort_physic (modname,abort_message,1)
+         endif
+
+
+!     enddo
+      endif
+
+
+      if (prt_level.ge.10) &
+     &   write(lunout1,'(i4,4e14.4)') l,masse(igout,l)/ptimestep, &
+     &     entr(igout,l),detr(igout,l),fm(igout,l+1)
+
+!-------------------------------------------------------------------------
+!fm ne peut pas etre negatif
+!-------------------------------------------------------------------------
+
+!     do l=1,nlay
+         do ig=1,ngrid
+            if (fm(ig,l+1).lt.0.) then
+               detr(ig,l)=detr(ig,l)+fm(ig,l+1)
+               fm(ig,l+1)=0.
+               ncorecfm2=ncorecfm2+1
+            endif
+         enddo
+
+         labort_physic=.false.
+         do ig=1,ngrid
+            if (detr(ig,l).lt.0.) then
+               labort_physic=.true.
+               igout=ig
+            endif
+        enddo
+        if (labort_physic) then
+               ig=igout
+               print*,'cas 2 : ig,l,lmax(ig)',ig,l,lmax(ig)
+               print*,'detr(ig,l)',detr(ig,l)
+               print*,'fm(ig,l)',fm(ig,l)
+               abort_message = 'probleme dans thermcell flux'
+               CALL abort_physic (modname,abort_message,1)
+        endif
+!    enddo
+
+      if (prt_level.ge.10) &
+     &   write(lunout1,'(i4,4e14.4)') l,masse(igout,l)/ptimestep, &
+     &     entr(igout,l),detr(igout,l),fm(igout,l+1)
+
+!-----------------------------------------------------------------------
+!la fraction couverte ne peut pas etre superieure a 1            
+!-----------------------------------------------------------------------
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! FH Partie a revisiter.
+! Il semble qu'etaient codees ici deux optiques dans le cas
+! F/ (rho *w) > 1
+! soit limiter la hauteur du thermique en considerant que c'est 
+! la derniere chouche, soit limiter F a rho w.
+! Dans le second cas, il faut en fait limiter a un peu moins
+! que ca parce qu'on a des 1 / ( 1 -alpha) un peu plus loin
+! dans thermcell_main et qu'il semble de toutes facons deraisonable
+! d'avoir des fractions de 1..
+! Ci dessous, et dans l'etat actuel, le premier des  deux if est
+! sans doute inutile.
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+!    do l=1,nlay
+        do ig=1,ngrid
+           if (zw2(ig,l+1).gt.1.e-10) then
+           zfm=rhobarz(ig,l+1)*zw2(ig,l+1)*alphamax
+           if ( fm(ig,l+1) .gt. zfm) then
+              f_old=fm(ig,l+1)
+              fm(ig,l+1)=zfm
+              detr(ig,l)=detr(ig,l)+f_old-fm(ig,l+1)
+!             lmax(ig)=l+1
+!             zmax(ig)=zlev(ig,lmax(ig))
+!             print*,'alpha>1',l+1,lmax(ig)
+              ncorecalpha=ncorecalpha+1
+           endif
+           endif
+        enddo
+!    enddo
+!
+
+
+      if (prt_level.ge.10) &
+     &   write(lunout1,'(i4,4e14.4)') l,masse(igout,l)/ptimestep, &
+     &     entr(igout,l),detr(igout,l),fm(igout,l+1)
+
+! Fin de la grande boucle sur les niveaux verticaux
+      enddo
+
+!      if (prt_level.ge.10) &
+!    &    call printflux(ngrid,nlay,lunout1,igout,f,lmax,lalim, &
+!    &    ptimestep,masse,entr,detr,fm,'8  ')
+
+
+!-----------------------------------------------------------------------
+! On fait en sorte que la quantite totale d'air entraine dans le 
+! panache ne soit pas trop grande comparee a la masse de la maille
+!-----------------------------------------------------------------------
+
+      if (1.eq.1) then
+      labort_physic=.false.
+      do l=1,nlay-1
+         do ig=1,ngrid
+            eee0=entr(ig,l)
+            ddd0=detr(ig,l)
+            eee=entr(ig,l)-masse(ig,l)*fomass_max/ptimestep
+            ddd=detr(ig,l)-eee
+            if (eee.gt.0.) then
+                ncorecfm3=ncorecfm3+1
+                entr(ig,l)=entr(ig,l)-eee
+                if ( ddd.gt.0.) then
+!   l'entrainement est trop fort mais l'exces peut etre compense par une
+!   diminution du detrainement)
+                   detr(ig,l)=ddd
+                else
+!   l'entrainement est trop fort mais l'exces doit etre compense en partie
+!   par un entrainement plus fort dans la couche superieure
+                   if(l.eq.lmax(ig)) then
+                      detr(ig,l)=fm(ig,l)+entr(ig,l)
+                   else
+                      if(l.ge.lmax(ig).and.0.eq.1) then
+                         igout=ig
+                         lout=l
+                         labort_physic=.true.
+                      endif
+                      entr(ig,l+1)=entr(ig,l+1)-ddd
+                      detr(ig,l)=0.
+                      fm(ig,l+1)=fm(ig,l)+entr(ig,l)
+                      detr(ig,l)=0.
+                   endif
+                endif
+            endif
+         enddo
+      enddo
+      if (labort_physic) then
+                         ig=igout
+                         l=lout
+                         print*,'ig,l',ig,l
+                         print*,'eee0',eee0
+                         print*,'ddd0',ddd0
+                         print*,'eee',eee
+                         print*,'ddd',ddd
+                         print*,'entr',entr(ig,l)
+                         print*,'detr',detr(ig,l)
+                         print*,'masse',masse(ig,l)
+                         print*,'fomass_max',fomass_max
+                         print*,'masse(ig,l)*fomass_max/ptimestep',masse(ig,l)*fomass_max/ptimestep
+                         print*,'ptimestep',ptimestep
+                         print*,'lmax(ig)',lmax(ig)
+                         print*,'fm(ig,l+1)',fm(ig,l+1)
+                         print*,'fm(ig,l)',fm(ig,l)
+                         abort_message = 'probleme dans thermcell_flux'
+                         CALL abort_physic (modname,abort_message,1)
+      endif
+      endif
+!                  
+!              ddd=detr(ig)-entre
+!on s assure que tout s annule bien en zmax
+      do ig=1,ngrid
+         fm(ig,lmax(ig)+1)=0.
+         entr(ig,lmax(ig))=0.
+         detr(ig,lmax(ig))=fm(ig,lmax(ig))+entr(ig,lmax(ig))
+      enddo
+
+!-----------------------------------------------------------------------
+! Impression du nombre de bidouilles qui ont ete necessaires
+!-----------------------------------------------------------------------
+
+!IM 090508 beg
+!     if (ncorecfm1+ncorecfm2+ncorecfm3+ncorecfm4+ncorecfm5+ncorecalpha > 0 ) then
+!
+!         print*,'PB thermcell : on a du coriger ',ncorecfm1,'x fm1',&
+!   &     ncorecfm2,'x fm2',ncorecfm3,'x fm3 et', &
+!   &     ncorecfm4,'x fm4',ncorecfm5,'x fm5 et', &
+!   &     ncorecfm6,'x fm6', &
+!   &     ncorecfm7,'x fm7', &
+!   &     ncorecfm8,'x fm8', &
+!   &     ncorecalpha,'x alpha'
+!     endif
+!IM 090508 end
+
+!      if (prt_level.ge.10) &
+!    &    call printflux(ngrid,nlay,lunout1,igout,f,lmax,lalim, &
+!    &    ptimestep,masse,entr,detr,fm,'fin')
+
+
+ RETURN
+      end
+END MODULE lmdz_thermcell_flux2
Index: DZ6/trunk/libf/phylmd/lmdz_thermcell_height.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/lmdz_thermcell_height.F90	(revision 5267)
+++ 	(revision )
@@ -1,172 +1,0 @@
-MODULE lmdz_thermcell_height
-CONTAINS
-
-      SUBROUTINE thermcell_height(ngrid,nlay,lalim,lmin,linter,lcong,lintercong,lmix,  &
-     &           zw2,zlev,lmax,zmax,zmax0,zmix,wmax,zcong)
-      IMPLICIT NONE
-
-!-----------------------------------------------------------------------------
-!thermcell_height: calcul des caracteristiques du thermique: zmax,wmax,zmix
-!-----------------------------------------------------------------------------
-
-! arguments
-
-! Entree
-      integer, intent(in) :: ngrid,nlay
-      real, intent(in), dimension(ngrid) :: linter,lintercong
-      real, intent(in), dimension(ngrid,nlay+1) :: zlev
-! Sortie
-      real, intent(out), dimension(ngrid) :: wmax,zmax,zmax0,zmix,zcong
-      integer, intent(out), dimension(ngrid) :: lmax,lcong
-! Les deux
-     integer, intent(inout), dimension(ngrid) :: lmix,lalim,lmin
-     real, intent(inout), dimension(ngrid,nlay+1) :: zw2
-
-! local
-     real, dimension(ngrid) :: num,denom,zlevinter,zlevintercong
-     integer ig,l
-
-!calcul de la hauteur max du thermique
-      do ig=1,ngrid
-         lmax(ig)=lalim(ig)
-      enddo
-      do ig=1,ngrid
-         do l=nlay,lalim(ig)+1,-1
-            if (zw2(ig,l).le.1.e-10) then
-               lmax(ig)=l-1
-            endif
-         enddo
-      enddo
-
-! On traite le cas particulier qu'il faudrait éviter ou le thermique
-! atteind le haut du modele ...
-      do ig=1,ngrid
-      if ( zw2(ig,nlay) > 1.e-10 ) then
-          print*,'WARNING !!!!! W2 thermiques non nul derniere couche '
-          lmax(ig)=nlay
-      endif
-      enddo
-
-! pas de thermique si couche 1 stable
-      do ig=1,ngrid
-         if (lmin(ig).gt.1) then
-             lmax(ig)=1
-             lmin(ig)=1
-             lalim(ig)=1
-         endif
-      enddo 
-!    
-! Determination de zw2 max
-      do ig=1,ngrid
-         wmax(ig)=0.
-      enddo
-
-      do l=1,nlay
-         do ig=1,ngrid
-            if (l.le.lmax(ig)) then
-                if (zw2(ig,l).lt.0.)then
-                  print*,'pb2 zw2<0'
-                endif
-                zw2(ig,l)=sqrt(zw2(ig,l))
-                wmax(ig)=max(wmax(ig),zw2(ig,l))
-            else
-                 zw2(ig,l)=0.
-            endif
-          enddo
-      enddo
-
-!   Longueur caracteristique correspondant a la hauteur des thermiques.
-      do  ig=1,ngrid
-         zmax(ig)=0.
-         zlevinter(ig)=zlev(ig,1)
-      enddo
-
-!     if (iflag_thermals_ed.ge.1) then
-      if (1==0) then
-!CR:date de quand le calcul du zmax continu etait buggue 
-         num(:)=0.
-         denom(:)=0.
-         do ig=1,ngrid
-          do l=1,nlay
-             num(ig)=num(ig)+zw2(ig,l)*zlev(ig,l)*(zlev(ig,l+1)-zlev(ig,l))
-             denom(ig)=denom(ig)+zw2(ig,l)*(zlev(ig,l+1)-zlev(ig,l))
-          enddo
-       enddo
-       do ig=1,ngrid
-       if (denom(ig).gt.1.e-10) then
-          zmax(ig)=2.*num(ig)/denom(ig)
-          zmax0(ig)=zmax(ig)
-       endif 
-       enddo
- 
-      else
-!CR:Calcul de zmax continu via le linter      
-      do  ig=1,ngrid
-! calcul de zlevinter
-          zlevinter(ig)=(zlev(ig,lmax(ig)+1)-zlev(ig,lmax(ig)))*  &
-     &    linter(ig)+zlev(ig,lmax(ig))-lmax(ig)*(zlev(ig,lmax(ig)+1)  &
-     &    -zlev(ig,lmax(ig)))
-!pour le cas ou on prend tjs lmin=1
-!       zmax(ig)=max(zmax(ig),zlevinter(ig)-zlev(ig,lmin(ig)))
-       zmax(ig)=max(zmax(ig),zlevinter(ig)-zlev(ig,1))
-       zmax0(ig)=zmax(ig)
-      enddo
-
-!CR:calcul du zcong
-      do  ig=1,ngrid
-! calcul de zlevintercong
-         zlevintercong(ig)=(zlev(ig,lcong(ig)+1)-zlev(ig,lcong(ig)))*  &
-     &    lintercong(ig)+zlev(ig,lcong(ig))-lcong(ig)*(zlev(ig,lcong(ig)+1)  &
-     &    -zlev(ig,lcong(ig)))
-         zcong(ig)=zlevintercong(ig)-zlev(ig,1)
-!         print*,"calcul zcong",lcong(ig),lintercong(ig),zlevintercong(ig),zcong(ig)
-      enddo
-
-      endif
-!endif iflag_thermals_ed
-!
-! def de  zmix continu (profil parabolique des vitesses)
-      do ig=1,ngrid
-           if (lmix(ig).gt.1) then
-! test 
-              if (((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))  &
-     &        *((zlev(ig,lmix(ig)))-(zlev(ig,lmix(ig)+1)))  &
-     &        -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1))  &
-     &        *((zlev(ig,lmix(ig)-1))-(zlev(ig,lmix(ig))))).gt.1e-10)  &
-     &        then
-!             
-            zmix(ig)=((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))  &
-     &        *((zlev(ig,lmix(ig)))**2-(zlev(ig,lmix(ig)+1))**2)  &
-     &        -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1))  &
-     &        *((zlev(ig,lmix(ig)-1))**2-(zlev(ig,lmix(ig)))**2))  &
-     &        /(2.*((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))  &
-     &        *((zlev(ig,lmix(ig)))-(zlev(ig,lmix(ig)+1)))  &
-     &        -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1))  &
-     &        *((zlev(ig,lmix(ig)-1))-(zlev(ig,lmix(ig))))))
-              else
-              zmix(ig)=zlev(ig,lmix(ig))
-              print*,'pb zmix'
-              endif
-          else 
-              zmix(ig)=0.
-          endif
-!test
-         if ((zmax(ig)-zmix(ig)).le.0.) then
-            zmix(ig)=0.9*zmax(ig)
-!            print*,'pb zmix>zmax'
-         endif
-      enddo
-!
-! calcul du nouveau lmix correspondant
-      do ig=1,ngrid
-         do l=1,nlay
-            if (zmix(ig).ge.zlev(ig,l).and.  &
-     &          zmix(ig).lt.zlev(ig,l+1)) then
-              lmix(ig)=l
-             endif
-          enddo
-      enddo
-!
- RETURN
-      end
-END MODULE lmdz_thermcell_height
Index: /LMDZ6/trunk/libf/phylmd/lmdz_thermcell_height.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/lmdz_thermcell_height.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/lmdz_thermcell_height.f90	(revision 5268)
@@ -0,0 +1,172 @@
+MODULE lmdz_thermcell_height
+CONTAINS
+
+      SUBROUTINE thermcell_height(ngrid,nlay,lalim,lmin,linter,lcong,lintercong,lmix,  &
+     &           zw2,zlev,lmax,zmax,zmax0,zmix,wmax,zcong)
+      IMPLICIT NONE
+
+!-----------------------------------------------------------------------------
+!thermcell_height: calcul des caracteristiques du thermique: zmax,wmax,zmix
+!-----------------------------------------------------------------------------
+
+! arguments
+
+! Entree
+      integer, intent(in) :: ngrid,nlay
+      real, intent(in), dimension(ngrid) :: linter,lintercong
+      real, intent(in), dimension(ngrid,nlay+1) :: zlev
+! Sortie
+      real, intent(out), dimension(ngrid) :: wmax,zmax,zmax0,zmix,zcong
+      integer, intent(out), dimension(ngrid) :: lmax,lcong
+! Les deux
+     integer, intent(inout), dimension(ngrid) :: lmix,lalim,lmin
+     real, intent(inout), dimension(ngrid,nlay+1) :: zw2
+
+! local
+     real, dimension(ngrid) :: num,denom,zlevinter,zlevintercong
+     integer ig,l
+
+!calcul de la hauteur max du thermique
+      do ig=1,ngrid
+         lmax(ig)=lalim(ig)
+      enddo
+      do ig=1,ngrid
+         do l=nlay,lalim(ig)+1,-1
+            if (zw2(ig,l).le.1.e-10) then
+               lmax(ig)=l-1
+            endif
+         enddo
+      enddo
+
+! On traite le cas particulier qu'il faudrait éviter ou le thermique
+! atteind le haut du modele ...
+      do ig=1,ngrid
+      if ( zw2(ig,nlay) > 1.e-10 ) then
+          print*,'WARNING !!!!! W2 thermiques non nul derniere couche '
+          lmax(ig)=nlay
+      endif
+      enddo
+
+! pas de thermique si couche 1 stable
+      do ig=1,ngrid
+         if (lmin(ig).gt.1) then
+             lmax(ig)=1
+             lmin(ig)=1
+             lalim(ig)=1
+         endif
+      enddo 
+!    
+! Determination de zw2 max
+      do ig=1,ngrid
+         wmax(ig)=0.
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+            if (l.le.lmax(ig)) then
+                if (zw2(ig,l).lt.0.)then
+                  print*,'pb2 zw2<0'
+                endif
+                zw2(ig,l)=sqrt(zw2(ig,l))
+                wmax(ig)=max(wmax(ig),zw2(ig,l))
+            else
+                 zw2(ig,l)=0.
+            endif
+          enddo
+      enddo
+
+!   Longueur caracteristique correspondant a la hauteur des thermiques.
+      do  ig=1,ngrid
+         zmax(ig)=0.
+         zlevinter(ig)=zlev(ig,1)
+      enddo
+
+!     if (iflag_thermals_ed.ge.1) then
+      if (1==0) then
+!CR:date de quand le calcul du zmax continu etait buggue 
+         num(:)=0.
+         denom(:)=0.
+         do ig=1,ngrid
+          do l=1,nlay
+             num(ig)=num(ig)+zw2(ig,l)*zlev(ig,l)*(zlev(ig,l+1)-zlev(ig,l))
+             denom(ig)=denom(ig)+zw2(ig,l)*(zlev(ig,l+1)-zlev(ig,l))
+          enddo
+       enddo
+       do ig=1,ngrid
+       if (denom(ig).gt.1.e-10) then
+          zmax(ig)=2.*num(ig)/denom(ig)
+          zmax0(ig)=zmax(ig)
+       endif 
+       enddo
+ 
+      else
+!CR:Calcul de zmax continu via le linter      
+      do  ig=1,ngrid
+! calcul de zlevinter
+          zlevinter(ig)=(zlev(ig,lmax(ig)+1)-zlev(ig,lmax(ig)))*  &
+     &    linter(ig)+zlev(ig,lmax(ig))-lmax(ig)*(zlev(ig,lmax(ig)+1)  &
+     &    -zlev(ig,lmax(ig)))
+!pour le cas ou on prend tjs lmin=1
+!       zmax(ig)=max(zmax(ig),zlevinter(ig)-zlev(ig,lmin(ig)))
+       zmax(ig)=max(zmax(ig),zlevinter(ig)-zlev(ig,1))
+       zmax0(ig)=zmax(ig)
+      enddo
+
+!CR:calcul du zcong
+      do  ig=1,ngrid
+! calcul de zlevintercong
+         zlevintercong(ig)=(zlev(ig,lcong(ig)+1)-zlev(ig,lcong(ig)))*  &
+     &    lintercong(ig)+zlev(ig,lcong(ig))-lcong(ig)*(zlev(ig,lcong(ig)+1)  &
+     &    -zlev(ig,lcong(ig)))
+         zcong(ig)=zlevintercong(ig)-zlev(ig,1)
+!         print*,"calcul zcong",lcong(ig),lintercong(ig),zlevintercong(ig),zcong(ig)
+      enddo
+
+      endif
+!endif iflag_thermals_ed
+!
+! def de  zmix continu (profil parabolique des vitesses)
+      do ig=1,ngrid
+           if (lmix(ig).gt.1) then
+! test 
+              if (((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))  &
+     &        *((zlev(ig,lmix(ig)))-(zlev(ig,lmix(ig)+1)))  &
+     &        -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1))  &
+     &        *((zlev(ig,lmix(ig)-1))-(zlev(ig,lmix(ig))))).gt.1e-10)  &
+     &        then
+!             
+            zmix(ig)=((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))  &
+     &        *((zlev(ig,lmix(ig)))**2-(zlev(ig,lmix(ig)+1))**2)  &
+     &        -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1))  &
+     &        *((zlev(ig,lmix(ig)-1))**2-(zlev(ig,lmix(ig)))**2))  &
+     &        /(2.*((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))  &
+     &        *((zlev(ig,lmix(ig)))-(zlev(ig,lmix(ig)+1)))  &
+     &        -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1))  &
+     &        *((zlev(ig,lmix(ig)-1))-(zlev(ig,lmix(ig))))))
+              else
+              zmix(ig)=zlev(ig,lmix(ig))
+              print*,'pb zmix'
+              endif
+          else 
+              zmix(ig)=0.
+          endif
+!test
+         if ((zmax(ig)-zmix(ig)).le.0.) then
+            zmix(ig)=0.9*zmax(ig)
+!            print*,'pb zmix>zmax'
+         endif
+      enddo
+!
+! calcul du nouveau lmix correspondant
+      do ig=1,ngrid
+         do l=1,nlay
+            if (zmix(ig).ge.zlev(ig,l).and.  &
+     &          zmix(ig).lt.zlev(ig,l+1)) then
+              lmix(ig)=l
+             endif
+          enddo
+      enddo
+!
+ RETURN
+      end
+END MODULE lmdz_thermcell_height
Index: DZ6/trunk/libf/phylmd/lmdz_thermcell_ini.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/lmdz_thermcell_ini.F90	(revision 5267)
+++ 	(revision )
@@ -1,140 +1,0 @@
-MODULE lmdz_thermcell_ini
-
-IMPLICIT NONE
-
-save
-
-
-integer, protected :: dvdq=1,dqimpl=-1,prt_level=0,lunout
-real   , protected :: RG,RD,RCPD,RKAPPA,RLVTT,RLvCp,RETV
-
-!$OMP THREADPRIVATE(dvdq,dqimpl,prt_level,lunout)
-!$OMP THREADPRIVATE(RG,RD,RCPD,RKAPPA,RLVTT,RLvCp)
-
-
-! Parameters that can be modified directly by a getin call
-real,    protected :: r_aspect_thermals=2.       ! Aspect ratio for thermal celles
-real,    protected :: tau_thermals = 0.          ! relaxation time constant
-real,    protected :: fact_thermals_ed_dz = 0.1  ! bouyancy computed with a delta
-real,    protected :: betalpha=0.9               !
-real,    protected :: afact=2./3.                !
-real,    protected :: fact_shell=1.              !
-real,    protected :: detr_min=1.e-5             !
-real,    protected :: entr_min=1.e-5             !
-real,    protected :: detr_q_coef=0.012          !
-real,    protected :: detr_q_power=0.5           !
-real,    protected :: mix0=0.                    !
-integer, protected :: iflag_thermals_ed = 0      !
-integer, protected :: iflag_thermals_optflux = 0 !
-integer, protected :: iflag_thermals_closure = 1 !
-integer, protected :: iflag_thermals_down = 0    !
-real, protected    :: fact_thermals_down = 0.5   !
-integer, protected :: thermals_flag_alim=0       !
-integer, protected :: iflag_thermals_tenv=0      ! 
-
-   ! WARNING !!! fact_epsilon is not protected. It can be modified in thermcell_plume*
-   ! depending on other flags.
-
-   real               :: fact_epsilon=0.002
-
-!$OMP THREADPRIVATE(r_aspect_thermals,tau_thermals,fact_thermals_ed_dz)
-!$OMP THREADPRIVATE(iflag_thermals_ed,iflag_thermals_optflux,iflag_thermals_closure)
-!$OMP THREADPRIVATE(iflag_thermals_down)
-!$OMP THREADPRIVATE(fact_thermals_down)
-!$OMP THREADPRIVATE(fact_epsilon, betalpha, afact, fact_shell)
-!$OMP THREADPRIVATE(detr_min, entr_min, detr_q_coef, detr_q_power)
-!$OMP THREADPRIVATE( mix0, thermals_flag_alim)
-!$OMP THREADPRIVATE(iflag_thermals_tenv)
-
-
-CONTAINS
-
-SUBROUTINE thermcell_ini(iflag_thermals,prt_level_in,tau_thermals_in,lunout_in, &
-   &    RG_in,RD_in,RCPD_in,RKAPPA_in,RLVTT_in,RETV_in)
-
-   USE ioipsl_getin_p_mod, ONLY : getin_p
-
-integer, intent(in) :: iflag_thermals,prt_level_in,lunout_in
-real, intent(in) :: RG_in,RD_in,RCPD_in,RKAPPA_in,RLVTT_in,RETV_in,tau_thermals_in
-
-print*,'thermcell_ini'
-      if (iflag_thermals==15.or.iflag_thermals==16) then
-         dvdq=0
-         dqimpl=-1
-      else
-         dvdq=1
-         dqimpl=1
-      endif
-   prt_level=prt_level_in
-   RG=RG_in
-   RD=RD_in
-   RCPD=RCPD_in
-   RKAPPA=RKAPPA_in
-   RLVTT=RLVTT_in
-   RLvCp = RLVTT/RCPD
-   RETV=RETV_in
-   tau_thermals=tau_thermals_in
-   lunout=lunout_in
-
-
-!=====================================================================
-! a la fois les vieilles param et thermcell_main :
-!=====================================================================
-
-   CALL getin_p('r_aspect_thermals',r_aspect_thermals)
-   CALL getin_p('tau_thermals',tau_thermals)
-   CALL getin_p('fact_thermals_ed_dz',fact_thermals_ed_dz)
-   CALL getin_p('iflag_thermals_ed',iflag_thermals_ed)
-   CALL getin_p('iflag_thermals_optflux',iflag_thermals_optflux)
-   CALL getin_p('iflag_thermals_closure',iflag_thermals_closure)
-   CALL getin_p('iflag_thermals_down',iflag_thermals_down)
-   CALL getin_p('fact_thermals_down',fact_thermals_down)
-   CALL getin_p('thermals_fact_epsilon',fact_epsilon)
-   CALL getin_p('thermals_betalpha',betalpha)
-   CALL getin_p('thermals_afact',afact)
-   CALL getin_p('thermals_fact_shell',fact_shell)
-   CALL getin_p('thermals_detr_min',detr_min)
-   CALL getin_p('thermals_entr_min',entr_min)
-   CALL getin_p('thermals_detr_q_coef',detr_q_coef)
-   CALL getin_p('thermals_detr_q_power',detr_q_power)
-   CALL getin_p('thermals_mix0',mix0)
-   CALL getin_p('thermals_flag_alim',thermals_flag_alim)
-   CALL getin_p('iflag_thermals_tenv',iflag_thermals_tenv)
-
-
-
-write(lunout,*) 'thermcell_ini ,prt_level                =',  prt_level                   
-write(lunout,*) 'thermcell_ini ,RG                       =',  RG                      
-write(lunout,*) 'thermcell_ini ,RD                       =',  RD                       
-write(lunout,*) 'thermcell_ini ,RCPD                     =',  RCPD                    
-write(lunout,*) 'thermcell_ini ,RKAPPA                   =',  RKAPPA                  
-write(lunout,*) 'thermcell_ini ,RLVTT                    =',  RLVTT                   
-write(lunout,*) 'thermcell_ini ,RLvCp                    =',  RLvCp                   
-write(lunout,*) 'thermcell_ini ,RETV                     =',  RETV                    
-write(lunout,*) 'thermcell_ini ,tau_thermals             =',  tau_thermals            
-write(lunout,*) 'thermcell_ini ,lunout                   =',  lunout                  
-write(lunout,*) 'thermcell_ini ,r_aspect_thermals        =',  r_aspect_thermals       
-write(lunout,*) 'thermcell_ini ,tau_thermals             =',  tau_thermals            
-write(lunout,*) 'thermcell_ini ,fact_thermals_ed_dz      =',  fact_thermals_ed_dz
-write(lunout,*) 'thermcell_ini ,fact_thermals_ed_dz      =',  fact_thermals_ed_dz
-write(lunout,*) 'thermcell_ini ,iflag_thermals_ed        =',  iflag_thermals_ed       
-write(lunout,*) 'thermcell_ini ,iflag_thermals_optflux   =',  iflag_thermals_optflux
-write(lunout,*) 'thermcell_ini ,iflag_thermals_closure   =',  iflag_thermals_closure
-write(lunout,*) 'thermcell_ini ,iflag_thermals_down      =',  iflag_thermals_down
-write(lunout,*) 'thermcell_ini ,fact_thermals_down       =',  fact_thermals_down
-write(lunout,*) 'thermcell_ini ,fact_epsilon             =',  fact_epsilon            
-write(lunout,*) 'thermcell_ini ,betalpha                 =',  betalpha                
-write(lunout,*) 'thermcell_ini ,afact                    =',  afact                   
-write(lunout,*) 'thermcell_ini ,fact_shell               =',  fact_shell              
-write(lunout,*) 'thermcell_ini ,detr_min                 =',  detr_min                
-write(lunout,*) 'thermcell_ini ,entr_min                 =',  entr_min                
-write(lunout,*) 'thermcell_ini ,detr_q_coef              =',  detr_q_coef             
-write(lunout,*) 'thermcell_ini ,detr_q_power             =',  detr_q_power            
-write(lunout,*) 'thermcell_ini ,mix0                     =',  mix0                    
-write(lunout,*) 'thermcell_ini ,thermals_flag_alim       =',  thermals_flag_alim
-write(lunout,*) 'thermcell_ini ,iflag_thermals_tenv      =',  iflag_thermals_tenv
-
- RETURN
-
-END SUBROUTINE thermcell_ini
-END MODULE lmdz_thermcell_ini
Index: /LMDZ6/trunk/libf/phylmd/lmdz_thermcell_ini.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/lmdz_thermcell_ini.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/lmdz_thermcell_ini.f90	(revision 5268)
@@ -0,0 +1,140 @@
+MODULE lmdz_thermcell_ini
+
+IMPLICIT NONE
+
+save
+
+
+integer, protected :: dvdq=1,dqimpl=-1,prt_level=0,lunout
+real   , protected :: RG,RD,RCPD,RKAPPA,RLVTT,RLvCp,RETV
+
+!$OMP THREADPRIVATE(dvdq,dqimpl,prt_level,lunout)
+!$OMP THREADPRIVATE(RG,RD,RCPD,RKAPPA,RLVTT,RLvCp)
+
+
+! Parameters that can be modified directly by a getin call
+real,    protected :: r_aspect_thermals=2.       ! Aspect ratio for thermal celles
+real,    protected :: tau_thermals = 0.          ! relaxation time constant
+real,    protected :: fact_thermals_ed_dz = 0.1  ! bouyancy computed with a delta
+real,    protected :: betalpha=0.9               !
+real,    protected :: afact=2./3.                !
+real,    protected :: fact_shell=1.              !
+real,    protected :: detr_min=1.e-5             !
+real,    protected :: entr_min=1.e-5             !
+real,    protected :: detr_q_coef=0.012          !
+real,    protected :: detr_q_power=0.5           !
+real,    protected :: mix0=0.                    !
+integer, protected :: iflag_thermals_ed = 0      !
+integer, protected :: iflag_thermals_optflux = 0 !
+integer, protected :: iflag_thermals_closure = 1 !
+integer, protected :: iflag_thermals_down = 0    !
+real, protected    :: fact_thermals_down = 0.5   !
+integer, protected :: thermals_flag_alim=0       !
+integer, protected :: iflag_thermals_tenv=0      ! 
+
+   ! WARNING !!! fact_epsilon is not protected. It can be modified in thermcell_plume*
+   ! depending on other flags.
+
+   real               :: fact_epsilon=0.002
+
+!$OMP THREADPRIVATE(r_aspect_thermals,tau_thermals,fact_thermals_ed_dz)
+!$OMP THREADPRIVATE(iflag_thermals_ed,iflag_thermals_optflux,iflag_thermals_closure)
+!$OMP THREADPRIVATE(iflag_thermals_down)
+!$OMP THREADPRIVATE(fact_thermals_down)
+!$OMP THREADPRIVATE(fact_epsilon, betalpha, afact, fact_shell)
+!$OMP THREADPRIVATE(detr_min, entr_min, detr_q_coef, detr_q_power)
+!$OMP THREADPRIVATE( mix0, thermals_flag_alim)
+!$OMP THREADPRIVATE(iflag_thermals_tenv)
+
+
+CONTAINS
+
+SUBROUTINE thermcell_ini(iflag_thermals,prt_level_in,tau_thermals_in,lunout_in, &
+   &    RG_in,RD_in,RCPD_in,RKAPPA_in,RLVTT_in,RETV_in)
+
+   USE ioipsl_getin_p_mod, ONLY : getin_p
+
+integer, intent(in) :: iflag_thermals,prt_level_in,lunout_in
+real, intent(in) :: RG_in,RD_in,RCPD_in,RKAPPA_in,RLVTT_in,RETV_in,tau_thermals_in
+
+print*,'thermcell_ini'
+      if (iflag_thermals==15.or.iflag_thermals==16) then
+         dvdq=0
+         dqimpl=-1
+      else
+         dvdq=1
+         dqimpl=1
+      endif
+   prt_level=prt_level_in
+   RG=RG_in
+   RD=RD_in
+   RCPD=RCPD_in
+   RKAPPA=RKAPPA_in
+   RLVTT=RLVTT_in
+   RLvCp = RLVTT/RCPD
+   RETV=RETV_in
+   tau_thermals=tau_thermals_in
+   lunout=lunout_in
+
+
+!=====================================================================
+! a la fois les vieilles param et thermcell_main :
+!=====================================================================
+
+   CALL getin_p('r_aspect_thermals',r_aspect_thermals)
+   CALL getin_p('tau_thermals',tau_thermals)
+   CALL getin_p('fact_thermals_ed_dz',fact_thermals_ed_dz)
+   CALL getin_p('iflag_thermals_ed',iflag_thermals_ed)
+   CALL getin_p('iflag_thermals_optflux',iflag_thermals_optflux)
+   CALL getin_p('iflag_thermals_closure',iflag_thermals_closure)
+   CALL getin_p('iflag_thermals_down',iflag_thermals_down)
+   CALL getin_p('fact_thermals_down',fact_thermals_down)
+   CALL getin_p('thermals_fact_epsilon',fact_epsilon)
+   CALL getin_p('thermals_betalpha',betalpha)
+   CALL getin_p('thermals_afact',afact)
+   CALL getin_p('thermals_fact_shell',fact_shell)
+   CALL getin_p('thermals_detr_min',detr_min)
+   CALL getin_p('thermals_entr_min',entr_min)
+   CALL getin_p('thermals_detr_q_coef',detr_q_coef)
+   CALL getin_p('thermals_detr_q_power',detr_q_power)
+   CALL getin_p('thermals_mix0',mix0)
+   CALL getin_p('thermals_flag_alim',thermals_flag_alim)
+   CALL getin_p('iflag_thermals_tenv',iflag_thermals_tenv)
+
+
+
+write(lunout,*) 'thermcell_ini ,prt_level                =',  prt_level                   
+write(lunout,*) 'thermcell_ini ,RG                       =',  RG                      
+write(lunout,*) 'thermcell_ini ,RD                       =',  RD                       
+write(lunout,*) 'thermcell_ini ,RCPD                     =',  RCPD                    
+write(lunout,*) 'thermcell_ini ,RKAPPA                   =',  RKAPPA                  
+write(lunout,*) 'thermcell_ini ,RLVTT                    =',  RLVTT                   
+write(lunout,*) 'thermcell_ini ,RLvCp                    =',  RLvCp                   
+write(lunout,*) 'thermcell_ini ,RETV                     =',  RETV                    
+write(lunout,*) 'thermcell_ini ,tau_thermals             =',  tau_thermals            
+write(lunout,*) 'thermcell_ini ,lunout                   =',  lunout                  
+write(lunout,*) 'thermcell_ini ,r_aspect_thermals        =',  r_aspect_thermals       
+write(lunout,*) 'thermcell_ini ,tau_thermals             =',  tau_thermals            
+write(lunout,*) 'thermcell_ini ,fact_thermals_ed_dz      =',  fact_thermals_ed_dz
+write(lunout,*) 'thermcell_ini ,fact_thermals_ed_dz      =',  fact_thermals_ed_dz
+write(lunout,*) 'thermcell_ini ,iflag_thermals_ed        =',  iflag_thermals_ed       
+write(lunout,*) 'thermcell_ini ,iflag_thermals_optflux   =',  iflag_thermals_optflux
+write(lunout,*) 'thermcell_ini ,iflag_thermals_closure   =',  iflag_thermals_closure
+write(lunout,*) 'thermcell_ini ,iflag_thermals_down      =',  iflag_thermals_down
+write(lunout,*) 'thermcell_ini ,fact_thermals_down       =',  fact_thermals_down
+write(lunout,*) 'thermcell_ini ,fact_epsilon             =',  fact_epsilon            
+write(lunout,*) 'thermcell_ini ,betalpha                 =',  betalpha                
+write(lunout,*) 'thermcell_ini ,afact                    =',  afact                   
+write(lunout,*) 'thermcell_ini ,fact_shell               =',  fact_shell              
+write(lunout,*) 'thermcell_ini ,detr_min                 =',  detr_min                
+write(lunout,*) 'thermcell_ini ,entr_min                 =',  entr_min                
+write(lunout,*) 'thermcell_ini ,detr_q_coef              =',  detr_q_coef             
+write(lunout,*) 'thermcell_ini ,detr_q_power             =',  detr_q_power            
+write(lunout,*) 'thermcell_ini ,mix0                     =',  mix0                    
+write(lunout,*) 'thermcell_ini ,thermals_flag_alim       =',  thermals_flag_alim
+write(lunout,*) 'thermcell_ini ,iflag_thermals_tenv      =',  iflag_thermals_tenv
+
+ RETURN
+
+END SUBROUTINE thermcell_ini
+END MODULE lmdz_thermcell_ini
Index: DZ6/trunk/libf/phylmd/lmdz_thermcell_qsat.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/lmdz_thermcell_qsat.F90	(revision 5267)
+++ 	(revision )
@@ -1,99 +1,0 @@
-MODULE lmdz_thermcell_qsat
-CONTAINS
-
-subroutine thermcell_qsat(klon,active,pplev,ztemp,zqta,zqsat)
-implicit none
-
-  INCLUDE "YOMCST.h"
-  INCLUDE "YOETHF.h"
-  INCLUDE "FCTTRE.h"
-
-
-!====================================================================
-! DECLARATIONS
-!====================================================================
-
-! Arguments
-INTEGER klon
-REAL zpspsk(klon),pplev(klon)
-REAL ztemp(klon),zqta(klon),zqsat(klon)
-LOGICAL active(klon)
-
-! Variables locales
-INTEGER ig,iter
-REAL Tbef(klon),DT(klon)
-REAL tdelta,qsatbef,zcor,qlbef,zdelta,zcvm5,dqsat,num,denom,dqsat_dT
-logical Zsat
-REAL RLvCp
-
-REAL, SAVE :: DDT0=.01
-!$OMP THREADPRIVATE(DDT0)
-
-LOGICAL afaire(klon),tout_converge
-
-!====================================================================
-! INITIALISATIONS
-!====================================================================
-
-RLvCp = RLVTT/RCPD
-tout_converge=.false.
-afaire(:)=.false.
-DT(:)=0.
-
-
-!====================================================================
-! Routine a vectoriser en copiant active dans converge et en mettant
-! la boucle sur les iterations a l'exterieur est en mettant
-! converge= false des que la convergence est atteinte.
-!====================================================================
-
-do ig=1,klon
-   if (active(ig)) then
-               Tbef(ig)=ztemp(ig)
-               zdelta=MAX(0.,SIGN(1.,RTT-Tbef(ig)))
-               qsatbef= R2ES * FOEEW(Tbef(ig),zdelta)/pplev(ig)
-               qsatbef=MIN(0.5,qsatbef)
-               zcor=1./(1.-retv*qsatbef)
-               qsatbef=qsatbef*zcor
-               qlbef=max(0.,zqta(ig)-qsatbef)
-               DT(ig) = 0.5*RLvCp*qlbef
-               zqsat(ig)=qsatbef
-     endif
-enddo
-
-! Traitement du cas ou il y a condensation mais faible
-! On ne condense pas mais on dit que le qsat est le qta
-do ig=1,klon
-   if (active(ig)) then
-      if (0.<abs(DT(ig)).and.abs(DT(ig))<=DDT0) then
-         zqsat(ig)=zqta(ig)
-      endif
-   endif
-enddo
-
-do iter=1,10
-    afaire(:)=abs(DT(:)).gt.DDT0
-    do ig=1,klon
-               if (afaire(ig)) then
-                 Tbef(ig)=Tbef(ig)+DT(ig)
-                 zdelta=MAX(0.,SIGN(1.,RTT-Tbef(ig)))
-                 qsatbef= R2ES * FOEEW(Tbef(ig),zdelta)/pplev(ig)
-                 qsatbef=MIN(0.5,qsatbef)
-                 zcor=1./(1.-retv*qsatbef)
-                 qsatbef=qsatbef*zcor
-                 qlbef=zqta(ig)-qsatbef
-                 zdelta=MAX(0.,SIGN(1.,RTT-Tbef(ig)))
-                 zcvm5=R5LES*(1.-zdelta) + R5IES*zdelta
-                 zcor=1./(1.-retv*qsatbef)
-                 dqsat_dT=FOEDE(Tbef(ig),zdelta,zcvm5,qsatbef,zcor)
-                 num=-Tbef(ig)+ztemp(ig)+RLvCp*qlbef
-                 denom=1.+RLvCp*dqsat_dT
-                 zqsat(ig) = qsatbef
-                 DT(ig)=num/denom
-               endif
-    enddo
-enddo
-
-return
-end
-END MODULE lmdz_thermcell_qsat
Index: /LMDZ6/trunk/libf/phylmd/lmdz_thermcell_qsat.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/lmdz_thermcell_qsat.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/lmdz_thermcell_qsat.f90	(revision 5268)
@@ -0,0 +1,99 @@
+MODULE lmdz_thermcell_qsat
+CONTAINS
+
+subroutine thermcell_qsat(klon,active,pplev,ztemp,zqta,zqsat)
+implicit none
+
+  INCLUDE "YOMCST.h"
+  INCLUDE "YOETHF.h"
+  INCLUDE "FCTTRE.h"
+
+
+!====================================================================
+! DECLARATIONS
+!====================================================================
+
+! Arguments
+INTEGER klon
+REAL zpspsk(klon),pplev(klon)
+REAL ztemp(klon),zqta(klon),zqsat(klon)
+LOGICAL active(klon)
+
+! Variables locales
+INTEGER ig,iter
+REAL Tbef(klon),DT(klon)
+REAL tdelta,qsatbef,zcor,qlbef,zdelta,zcvm5,dqsat,num,denom,dqsat_dT
+logical Zsat
+REAL RLvCp
+
+REAL, SAVE :: DDT0=.01
+!$OMP THREADPRIVATE(DDT0)
+
+LOGICAL afaire(klon),tout_converge
+
+!====================================================================
+! INITIALISATIONS
+!====================================================================
+
+RLvCp = RLVTT/RCPD
+tout_converge=.false.
+afaire(:)=.false.
+DT(:)=0.
+
+
+!====================================================================
+! Routine a vectoriser en copiant active dans converge et en mettant
+! la boucle sur les iterations a l'exterieur est en mettant
+! converge= false des que la convergence est atteinte.
+!====================================================================
+
+do ig=1,klon
+   if (active(ig)) then
+               Tbef(ig)=ztemp(ig)
+               zdelta=MAX(0.,SIGN(1.,RTT-Tbef(ig)))
+               qsatbef= R2ES * FOEEW(Tbef(ig),zdelta)/pplev(ig)
+               qsatbef=MIN(0.5,qsatbef)
+               zcor=1./(1.-retv*qsatbef)
+               qsatbef=qsatbef*zcor
+               qlbef=max(0.,zqta(ig)-qsatbef)
+               DT(ig) = 0.5*RLvCp*qlbef
+               zqsat(ig)=qsatbef
+     endif
+enddo
+
+! Traitement du cas ou il y a condensation mais faible
+! On ne condense pas mais on dit que le qsat est le qta
+do ig=1,klon
+   if (active(ig)) then
+      if (0.<abs(DT(ig)).and.abs(DT(ig))<=DDT0) then
+         zqsat(ig)=zqta(ig)
+      endif
+   endif
+enddo
+
+do iter=1,10
+    afaire(:)=abs(DT(:)).gt.DDT0
+    do ig=1,klon
+               if (afaire(ig)) then
+                 Tbef(ig)=Tbef(ig)+DT(ig)
+                 zdelta=MAX(0.,SIGN(1.,RTT-Tbef(ig)))
+                 qsatbef= R2ES * FOEEW(Tbef(ig),zdelta)/pplev(ig)
+                 qsatbef=MIN(0.5,qsatbef)
+                 zcor=1./(1.-retv*qsatbef)
+                 qsatbef=qsatbef*zcor
+                 qlbef=zqta(ig)-qsatbef
+                 zdelta=MAX(0.,SIGN(1.,RTT-Tbef(ig)))
+                 zcvm5=R5LES*(1.-zdelta) + R5IES*zdelta
+                 zcor=1./(1.-retv*qsatbef)
+                 dqsat_dT=FOEDE(Tbef(ig),zdelta,zcvm5,qsatbef,zcor)
+                 num=-Tbef(ig)+ztemp(ig)+RLvCp*qlbef
+                 denom=1.+RLvCp*dqsat_dT
+                 zqsat(ig) = qsatbef
+                 DT(ig)=num/denom
+               endif
+    enddo
+enddo
+
+return
+end
+END MODULE lmdz_thermcell_qsat
Index: DZ6/trunk/libf/phylmd/lmdz_wake.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/lmdz_wake.F90	(revision 5267)
+++ 	(revision )
@@ -1,3379 +1,0 @@
-MODULE lmdz_wake
-
-  USE lmdz_wake_ini, ONLY: CPPKEY_IOPHYS_WK
-
-  IMPLICIT NONE; PRIVATE
-  PUBLIC wake
-
-CONTAINS
-
-SUBROUTINE wake(klon,klev,znatsurf, p, ph, pi, dtime, &
-                tb0, qb0, omgb, &
-                dtdwn, dqdwn, amdwn, amup, dta, dqa, wgen, &
-                sigd_con, Cin, &
-                deltatw, deltaqw, sigmaw, asigmaw, wdens, awdens, &                  ! state variables           
-                dth, hw, wape, fip, gfl, &
-                dtls, dqls, ktopw, omgbdth, dp_omgb, tx, qx, &
-                dtke, dqke, omg, dp_deltomg, wkspread, cstar, &
-                d_deltat_gw, &                                                      ! tendencies
-                d_deltatw2, d_deltaqw2, d_sigmaw2, d_asigmaw2, d_wdens2, d_awdens2)             ! tendencies
-
-
-  ! **************************************************************
-  ! *
-  ! WAKE                                                        *
-  ! retour a un Pupper fixe                                *
-  ! *
-  ! written by   :  GRANDPEIX Jean-Yves   09/03/2000            *
-  ! modified by :   ROEHRIG Romain        01/29/2007            *
-  ! **************************************************************
-
-
-  USE lmdz_wake_ini , ONLY : wake_ini
-  USE lmdz_wake_ini , ONLY : prt_level,epsim1,RG,RD
-  USE lmdz_wake_ini , ONLY : stark, wdens_ref, coefgw, alpk, wk_pupper
-  USE lmdz_wake_ini , ONLY : crep_upper, crep_sol, tau_cv, rzero, aa0, flag_wk_check_trgl
-  USE lmdz_wake_ini , ONLY : ok_bug_gfl
-  USE lmdz_wake_ini , ONLY : iflag_wk_act, iflag_wk_check_trgl, iflag_wk_pop_dyn, wdensinit, wdensthreshold
-  USE lmdz_wake_ini , ONLY : sigmad, hwmin, wapecut, cstart, sigmaw_max, dens_rate, epsilon_loc
-  USE lmdz_wake_ini , ONLY : iflag_wk_profile
-  USE lmdz_wake_ini , ONLY : smallestreal,wk_nsub
-
-
-  IMPLICIT NONE
-  ! ============================================================================
-
-
-  ! But : Decrire le comportement des poches froides apparaissant dans les
-  ! grands systemes convectifs, et fournir l'energie disponible pour
-  ! le declenchement de nouvelles colonnes convectives.
-
-  ! State variables : 
-  ! deltatw    : temperature difference between wake and off-wake regions
-  ! deltaqw    : specific humidity difference between wake and off-wake regions
-  ! sigmaw     : fractional area covered by wakes.
-  ! asigmaw    : fractional area covered by active wakes.
-  ! wdens      : number of wakes per unit area
-  ! awdens     : number of active wakes per unit area
-
-  ! Variable de sortie :
-
-  ! wape : WAke Potential Energy
-  ! fip  : Front Incident Power (W/m2) - ALP
-  ! gfl  : Gust Front Length per unit area (m-1)
-  ! dtls : large scale temperature tendency due to wake
-  ! dqls : large scale humidity tendency due to wake
-  ! hw   : wake top hight (given by hw*deltatw(1)/2=wape)
-  ! dp_omgb : vertical gradient of large scale omega
-  ! awdens  : densite de poches actives
-  ! wdens   : densite de poches
-  ! omgbdth: flux of Delta_Theta transported by LS omega
-  ! dtKE   : differential heating (wake - unpertubed)
-  ! dqKE   : differential moistening (wake - unpertubed)
-  ! omg    : Delta_omg =vertical velocity diff. wake-undist. (Pa/s)
-  ! dp_deltomg  : vertical gradient of omg (s-1)
-  ! wkspread  : spreading term in d_t_wake and d_q_wake
-  ! deltatw     : updated temperature difference (T_w-T_u).
-  ! deltaqw     : updated humidity difference (q_w-q_u).
-  ! sigmaw      : updated wake fractional area.
-  ! asigmaw     : updated active wake fractional area.
-  ! d_deltat_gw : delta T tendency due to GW
-
-  ! Variables d'entree :
-
-  ! aire : aire de la maille
-  ! tb0  : horizontal average of temperature  (K)
-  ! qb0  : horizontal average of humidity   (kg/kg)
-  ! omgb : vitesse verticale moyenne sur la maille (Pa/s)
-  ! dtdwn: source de chaleur due aux descentes (K/s)
-  ! dqdwn: source d'humidite due aux descentes (kg/kg/s)
-  ! dta  : source de chaleur due courants satures et detrain  (K/s)
-  ! dqa  : source d'humidite due aux courants satures et detra (kg/kg/s)
-  ! wgen : number of wakes generated per unit area and per sec (/m^2/s)
-  ! amdwn: flux de masse total des descentes, par unite de
-  !        surface de la maille (kg/m2/s)
-  ! amup : flux de masse total des ascendances, par unite de
-  !        surface de la maille (kg/m2/s)
-  ! sigd_con: 
-  ! Cin  : convective inhibition
-  ! p    : pressions aux milieux des couches (Pa)
-  ! ph   : pressions aux interfaces (Pa)
-  ! pi  : (p/p_0)**kapa (adim)
-  ! dtime: increment temporel (s)
-
-  ! Variables internes :
-
-  ! rho  : mean density at P levels
-  ! rhoh : mean density at Ph levels
-  ! tb   : mean temperature | may change within
-  ! qb   : mean humidity    | sub-time-stepping
-  ! thb  : mean potential temperature
-  ! thx  : potential temperature in (x) area
-  ! tx   : temperature  in (x) area
-  ! qx   : humidity in (x) area
-  ! dp_omgb: vertical gradient og LS omega
-  ! omgbw  : wake average vertical omega
-  ! dp_omgbw: vertical gradient of omgbw
-  ! omgbdq : flux of Delta_q transported by LS omega
-  ! dth  : potential temperature diff. wake-undist.
-  ! th1  : first pot. temp. for vertical advection (=thx)
-  ! th2  : second pot. temp. for vertical advection (=thw)
-  ! q1   : first humidity for vertical advection
-  ! q2   : second humidity for vertical advection
-  ! d_deltatw   : redistribution term for deltatw
-  ! d_deltaqw   : redistribution term for deltaqw
-  ! deltatw0   : initial deltatw 
-  ! deltaqw0   : initial deltaqw 
-  ! hw0    : wake top hight (defined as the altitude at which deltatw=0)
-  ! amflux : horizontal mass flux through wake boundary
-  ! wdens_ref: initial number of wakes per unit area (3D) or per
-  !            unit length (2D), at the beginning of each time step
-  ! Tgw    : 1 sur la periode de onde de gravite
-  ! Cgw    : vitesse de propagation de onde de gravite
-  ! LL     : distance between 2 wakes
-
-  ! -------------------------------------------------------------------------
-  ! Declaration de variables
-  ! -------------------------------------------------------------------------
-
-
-  ! Arguments en entree
-  ! --------------------
-
-  INTEGER, INTENT(IN) :: klon,klev
-  INTEGER, DIMENSION (klon),        INTENT(IN)          :: znatsurf
-  REAL, DIMENSION (klon, klev),     INTENT(IN)          :: p, pi
-  REAL, DIMENSION (klon, klev+1),   INTENT(IN)          :: ph
-  REAL, DIMENSION (klon, klev),     INTENT(IN)          :: omgb
-  REAL,                             INTENT(IN)          :: dtime
-  REAL, DIMENSION (klon, klev),     INTENT(IN)          :: tb0, qb0
-  REAL, DIMENSION (klon, klev),     INTENT(IN)          :: dtdwn, dqdwn
-  REAL, DIMENSION (klon, klev),     INTENT(IN)          :: amdwn, amup
-  REAL, DIMENSION (klon, klev),     INTENT(IN)          :: dta, dqa
-  REAL, DIMENSION (klon),           INTENT(IN)          :: wgen
-  REAL, DIMENSION (klon),           INTENT(IN)          :: sigd_con
-  REAL, DIMENSION (klon),           INTENT(IN)          :: Cin
-
-  !
-  ! Input/Output
-  ! State variables
-  REAL, DIMENSION (klon, klev),     INTENT(INOUT)       :: deltatw, deltaqw
-  REAL, DIMENSION (klon),           INTENT(INOUT)       :: sigmaw
-  REAL, DIMENSION (klon),           INTENT(INOUT)       :: asigmaw
-  REAL, DIMENSION (klon),           INTENT(INOUT)       :: wdens
-  REAL, DIMENSION (klon),           INTENT(INOUT)       :: awdens
-
-  ! Sorties
-  ! --------
-
-  REAL, DIMENSION (klon, klev),     INTENT(OUT)         :: dth
-  REAL, DIMENSION (klon, klev),     INTENT(OUT)         :: tx, qx
-  REAL, DIMENSION (klon, klev),     INTENT(OUT)         :: dtls, dqls
-  REAL, DIMENSION (klon, klev),     INTENT(OUT)         :: dtke, dqke
-  REAL, DIMENSION (klon, klev),     INTENT(OUT)         :: wkspread    !  unused (jyg)
-  REAL, DIMENSION (klon, klev),     INTENT(OUT)         :: omgbdth, omg
-  REAL, DIMENSION (klon, klev),     INTENT(OUT)         :: dp_omgb, dp_deltomg
-  REAL, DIMENSION (klon),           INTENT(OUT)         :: hw, wape, fip, gfl, cstar
-  INTEGER, DIMENSION (klon),        INTENT(OUT)         :: ktopw
-  ! Tendencies of state variables (2 is appended to the names of fields which are the cumul of fields 
-  !                                 computed at each sub-timestep; e.g. d_wdens2 is the cumul of d_wdens)
-  REAL, DIMENSION (klon, klev),     INTENT(OUT)         :: d_deltat_gw
-  REAL, DIMENSION (klon, klev),     INTENT(OUT)         :: d_deltatw2, d_deltaqw2
-  REAL, DIMENSION (klon),           INTENT(OUT)         :: d_sigmaw2, d_asigmaw2, d_wdens2, d_awdens2
-
-  ! Variables internes
-  ! -------------------
-
-  ! Variables a fixer
-
-  REAL                                                  :: delta_t_min
-  REAL                                                  :: dtimesub
-  REAL                                                  :: wdens0
-  ! IM 080208
-  LOGICAL, DIMENSION (klon)                             :: gwake
-
-  ! Variables de sauvegarde
-  REAL, DIMENSION (klon, klev)                          :: deltatw0
-  REAL, DIMENSION (klon, klev)                          :: deltaqw0
-  REAL, DIMENSION (klon, klev)                          :: tb, qb
-
-  ! Variables liees a la dynamique de population 1
-  REAL, DIMENSION(klon)                                 :: act
-  REAL, DIMENSION(klon)                                 :: rad_wk, tau_wk_inv
-  REAL, DIMENSION(klon)                                 :: f_shear
-  REAL, DIMENSION(klon)                                 :: drdt
-  
-  ! Variables liees a la dynamique de population 2
-  REAL, DIMENSION(klon)                                 :: cont_fact  
-  
-  ! Variables liees a la dynamique de population 3
-  REAL, DIMENSION(klon)                                 :: arad_wk, irad_wk
-  
-!!  REAL, DIMENSION(klon)                                 :: d_sig_gen, d_sig_death, d_sig_col
-  REAL, DIMENSION(klon)                                 :: wape1_act, wape2_act
-  LOGICAL, DIMENSION (klon)                             :: kill_wake
-  REAL                                                  :: drdt_pos
-  REAL                                                  :: tau_wk_inv_min
-  ! Some components of the tendencies of state variables  
-  REAL, DIMENSION (klon)                                :: d_sig_gen2, d_sig_death2, d_sig_col2, d_sig_spread2, d_sig_bnd2
-  REAL, DIMENSION (klon)                                :: d_asig_death2, d_asig_aicol2, d_asig_iicol2, d_asig_spread2, d_asig_bnd2
-  REAL, DIMENSION (klon)                                :: d_dens_gen2, d_dens_death2, d_dens_col2, d_dens_bnd2
-  REAL, DIMENSION (klon)                                :: d_adens_death2, d_adens_icol2, d_adens_acol2, d_adens_bnd2
-
-  ! Variables pour les GW
-  REAL, DIMENSION (klon)                                :: ll
-  REAL, DIMENSION (klon, klev)                          :: n2
-  REAL, DIMENSION (klon, klev)                          :: cgw
-  REAL, DIMENSION (klon, klev)                          :: tgw
-
-  ! Variables liees au calcul de hw
-  REAL, DIMENSION (klon)                                :: ptop
-  REAL, DIMENSION (klon)                                :: sum_dth
-  REAL, DIMENSION (klon)                                :: dthmin
-  REAL, DIMENSION (klon)                                :: z, dz, hw0
-  INTEGER, DIMENSION (klon)                             :: ktop, kupper
-
-  ! Variables liees au test de la forme triangulaire du profil de Delta_theta
-  REAL, DIMENSION (klon)                                :: sum_half_dth
-  REAL, DIMENSION (klon)                                :: dz_half
-
-  ! Sub-timestep tendencies and related variables
-  REAL, DIMENSION (klon, klev)                          :: d_deltatw, d_deltaqw
-  REAL, DIMENSION (klon, klev)                          :: d_tb, d_qb
-  REAL, DIMENSION (klon)                                :: d_wdens, d_awdens, d_sigmaw, d_asigmaw 
-  REAL, DIMENSION (klon)                                :: d_sig_gen, d_sig_death, d_sig_col, d_sig_spread, d_sig_bnd
-  REAL, DIMENSION (klon)                                :: d_asig_death, d_asig_aicol, d_asig_iicol, d_asig_spread, d_asig_bnd
-  REAL, DIMENSION (klon)                                :: d_dens_gen, d_dens_death, d_dens_col, d_dens_bnd
-  REAL, DIMENSION (klon)                                :: d_adens_death, d_adens_icol, d_adens_acol, d_adens_bnd
-  REAL, DIMENSION (klon)                                :: agfl              !! gust front length of active wakes
-                                                                             !!  per unit area
-  REAL, DIMENSION (klon)                                :: alpha, alpha_tot
-  REAL, DIMENSION (klon)                                :: q0_min, q1_min
-  LOGICAL, DIMENSION (klon)                             :: wk_adv, ok_qx_qw
-
-  ! Autres variables internes
-  INTEGER                                               ::isubstep, k, i, igout
-
-  REAL                                                  :: wdensmin
-
-  REAL                                                  :: sigmaw_targ
-  REAL                                                  :: wdens_targ
-  REAL                                                  :: d_sigmaw_targ
-  REAL                                                  :: d_wdens_targ
-
-  REAL, DIMENSION (klon)                                :: sum_thx, sum_tx, sum_qx, sum_thvx
-  REAL, DIMENSION (klon)                                :: sum_dq
-  REAL, DIMENSION (klon)                                :: sum_dtdwn, sum_dqdwn
-  REAL, DIMENSION (klon)                                :: av_thx, av_tx, av_qx, av_thvx
-  REAL, DIMENSION (klon)                                :: av_dth, av_dq
-  REAL, DIMENSION (klon)                                :: av_dtdwn, av_dqdwn
-
-  REAL, DIMENSION (klon, klev)                          :: rho
-  REAL, DIMENSION (klon, klev+1)                        :: rhoh
-  REAL, DIMENSION (klon, klev)                          :: zh
-  REAL, DIMENSION (klon, klev+1)                        :: zhh
-
-  REAL, DIMENSION (klon, klev)                          :: thb, thx
-
-  REAL, DIMENSION (klon, klev)                          :: omgbw
-  REAL, DIMENSION (klon)                                :: pupper
-  REAL, DIMENSION (klon)                                :: omgtop
-  REAL, DIMENSION (klon, klev)                          :: dp_omgbw
-  REAL, DIMENSION (klon)                                :: ztop, dztop
-  REAL, DIMENSION (klon, klev)                          :: alpha_up
-
-  REAL, DIMENSION (klon)                                :: rre1, rre2
-  REAL                                                  :: rrd1, rrd2
-  REAL, DIMENSION (klon, klev)                          :: th1, th2, q1, q2
-  REAL, DIMENSION (klon, klev)                          :: d_th1, d_th2, d_dth
-  REAL, DIMENSION (klon, klev)                          :: d_q1, d_q2, d_dq
-  REAL, DIMENSION (klon, klev)                          :: omgbdq
-
-  REAL, DIMENSION (klon)                                :: ff, gg
-  REAL, DIMENSION (klon)                                :: wape2, cstar2, heff
-                                                        
-  REAL, DIMENSION (klon, klev)                          :: crep
-                                                        
-  REAL, DIMENSION (klon, klev)                          :: ppi
-
-  ! cc nrlmd
-  REAL, DIMENSION (klon)                                :: death_rate
-!!  REAL, DIMENSION (klon)                                :: nat_rate
-  REAL, DIMENSION (klon, klev)                          :: entr
-  REAL, DIMENSION (klon, klev)                          :: detr
-
-  REAL, DIMENSION(klon)                                 :: sigmaw_in, asigmaw_in ! pour les prints
-  REAL, DIMENSION(klon)                                 :: wdens_in, awdens_in   ! pour les prints
-
-!!!  LOGICAL                                               :: phys_sub=.true.
-  LOGICAL                                               :: phys_sub=.false.
-
-  LOGICAL                                               :: first_call=.true.
-
-
-  !!-- variables liees au nouveau calcul de ptop et hw
-  REAL, DIMENSION (klon, klev)                          :: int_dth
-  REAL, DIMENSION (klon, klev)                          :: zzz, dzzz
-  REAL                                                  :: epsil
-  REAL, DIMENSION (klon)                                :: ptop1
-  INTEGER, DIMENSION (klon)                             :: ktop1
-  REAL, DIMENSION (klon)                                :: omega
-  REAL, DIMENSION (klon)                                :: h_zzz
-
-!print*,'WAKE LJYFz'
-
-  ! -------------------------------------------------------------------------
-  ! Initialisations
-  ! -------------------------------------------------------------------------
-  ! ALON = 3.e5
-  ! alon = 1.E6
-
-  !  Provisionnal; to be suppressed when f_shear is parameterized
-  f_shear(:) = 1.       ! 0. for strong shear, 1. for weak shear
-
-  ! Configuration de coefgw,stark,wdens (22/02/06 by YU Jingmei)
-
-  ! coefgw : Coefficient pour les ondes de gravite
-  ! stark : Coefficient k dans Cstar=k*sqrt(2*WAPE)
-  ! wdens : Densite surfacique de poche froide
-  ! -------------------------------------------------------------------------
-
-  ! cc nrlmd      coefgw=10
-  ! coefgw=1
-  ! wdens0 = 1.0/(alon**2)
-  ! cc nrlmd      wdens = 1.0/(alon**2)
-  ! cc nrlmd      stark = 0.50
-  ! CRtest
-  ! cc nrlmd      alpk=0.1
-  ! alpk = 1.0
-  ! alpk = 0.5
-  ! alpk = 0.05
-!
- igout = klon/2+1/klon
-!
-!   sub-time-stepping parameters
-  dtimesub = dtime/wk_nsub
-!
-IF (first_call) THEN
-IF (CPPKEY_IOPHYS_WK) THEN
-  IF (phys_sub) THEN
-    call iophys_ini(dtimesub)
-  ELSE
-    call iophys_ini(dtime)
-  ENDIF
-END IF
-  first_call = .false.
-ENDIF   !(first_call)
-
- IF (iflag_wk_pop_dyn == 0) THEN
-  ! Initialisation de toutes des densites a wdens_ref.
-  ! Les densites peuvent evoluer si les poches debordent
-  ! (voir au tout debut de la boucle sur les substeps)
-  !jyg<
-  !!  wdens(:) = wdens_ref
-   DO i = 1,klon
-     wdens(i) = wdens_ref(znatsurf(i)+1)
-   ENDDO 
-  !>jyg
- ENDIF  ! (iflag_wk_pop_dyn == 0)
-!
- IF (iflag_wk_pop_dyn >=1) THEN
-   IF (iflag_wk_pop_dyn == 3) THEN
-     wdensmin = wdensthreshold
-   ELSE
-     wdensmin = wdensinit
-   ENDIF
- ENDIF
-
-  ! print*,'stark',stark
-  ! print*,'alpk',alpk
-  ! print*,'wdens',wdens
-  ! print*,'coefgw',coefgw
-  ! cc
-  ! Minimum value for |T_wake - T_undist|. Used for wake top definition
-  ! -------------------------------------------------------------------------
-
-   delta_t_min = 0.2
-
-  ! 1. - Save initial values, initialize tendencies, initialize output fields
-  ! ------------------------------------------------------------------------
-
-!jyg<
-!!  DO k = 1, klev
-!!    DO i = 1, klon
-!!      ppi(i, k) = pi(i, k)
-!!      deltatw0(i, k) = deltatw(i, k)
-!!      deltaqw0(i, k) = deltaqw(i, k)
-!!      tb(i, k) = tb0(i, k)
-!!      qb(i, k) = qb0(i, k)
-!!      dtls(i, k) = 0.
-!!      dqls(i, k) = 0.
-!!      d_deltat_gw(i, k) = 0.
-!!      d_tb(i, k) = 0.
-!!      d_qb(i, k) = 0.
-!!      d_deltatw(i, k) = 0.
-!!      d_deltaqw(i, k) = 0.
-!!      ! IM 060508 beg
-!!      d_deltatw2(i, k) = 0.
-!!      d_deltaqw2(i, k) = 0.
-!!      ! IM 060508 end
-!!    END DO
-!!  END DO
-      ppi(:,:) = pi(:,:)
-      deltatw0(:,:) = deltatw(:,:)
-      deltaqw0(:,:) = deltaqw(:,:)
-      tb(:,:) = tb0(:,:)
-      qb(:,:) = qb0(:,:)
-      dtls(:,:) = 0.
-      dqls(:,:) = 0.
-      d_deltat_gw(:,:) = 0.
-      d_tb(:,:) = 0.
-      d_qb(:,:) = 0.
-      d_deltatw(:,:) = 0.
-      d_deltaqw(:,:) = 0.
-      d_deltatw2(:,:) = 0.
-      d_deltaqw2(:,:) = 0.
-
-      d_sig_gen2(:)   = 0.
-      d_sig_death2(:) = 0.
-      d_sig_col2(:)   = 0.
-      d_sig_spread2(:)= 0.
-      d_asig_death2(:) = 0.
-      d_asig_iicol2(:) = 0.
-      d_asig_aicol2(:) = 0.
-      d_asig_spread2(:)= 0.
-      d_asig_bnd2(:) = 0.
-      d_asigmaw2(:) = 0.
-!
-      d_dens_gen2(:)   = 0.
-      d_dens_death2(:) = 0.
-      d_dens_col2(:)   = 0.
-      d_dens_bnd2(:) = 0.
-      d_wdens2(:) = 0.
-      d_adens_bnd2(:) = 0.
-      d_awdens2(:) = 0.
-      d_adens_death2(:) = 0.
-      d_adens_icol2(:) = 0.
-      d_adens_acol2(:) = 0.
-
-      IF (iflag_wk_act == 0) THEN
-        act(:) = 0.
-      ELSEIF (iflag_wk_act == 1) THEN
-        act(:) = 1.
-      ENDIF
-
-!!  DO i = 1, klon
-!!   sigmaw_in(i) = sigmaw(i)
-!!  END DO
-   sigmaw_in(:)  = sigmaw(:)
-   asigmaw_in(:) = asigmaw(:)
-!>jyg
-!
-  IF (iflag_wk_pop_dyn >= 1) THEN
-    awdens_in(:) = awdens(:)
-    wdens_in(:) = wdens(:)
-!!    wdens(:) = wdens(:) + wgen(:)*dtime
-!!    d_wdens2(:) = wgen(:)*dtime
-!!  ELSE
-  ENDIF  ! (iflag_wk_pop_dyn >= 1)
-
-
-  ! sigmaw1=sigmaw
-  ! IF (sigd_con.GT.sigmaw1) THEN
-  ! print*, 'sigmaw,sigd_con', sigmaw, sigd_con
-  ! ENDIF
-  IF (iflag_wk_pop_dyn >= 1) THEN
-    DO i = 1, klon
-      d_dens_gen2(i)   = 0.
-      d_dens_death2(i) = 0.
-      d_dens_col2(i)   = 0.
-      d_awdens2(i) = 0.
-      IF (wdens(i) < wdensthreshold) THEN
-  !!      wdens_targ = max(wdens(i),wdensmin)
-        wdens_targ = max(wdens(i),wdensinit)
-        d_dens_bnd2(i) = wdens_targ - wdens(i)
-        d_wdens2(i) = wdens_targ - wdens(i)
-        wdens(i) = wdens_targ
-      ELSE
-        d_dens_bnd2(i) = 0.
-        d_wdens2(i) = 0.
-      ENDIF  !! (wdens(i) < wdensthreshold)
-    END DO
-    IF (iflag_wk_pop_dyn >= 2) THEN
-      DO i = 1, klon  
-        IF (awdens(i) < wdensthreshold) THEN
-!!          wdens_targ = min(max(awdens(i),wdensmin),wdens(i))
-            wdens_targ = min(max(awdens(i),wdensinit),wdens(i))
-            d_adens_bnd2(i) = wdens_targ - awdens(i)
-            d_awdens2(i) = wdens_targ - awdens(i)
-            awdens(i) = wdens_targ
-        ELSE
-            wdens_targ = min(awdens(i), wdens(i))
-            d_adens_bnd2(i) = wdens_targ - awdens(i)
-            d_awdens2(i) = wdens_targ - awdens(i)
-            awdens(i) = wdens_targ
-        ENDIF
-      END DO
-    ENDIF ! (iflag_wk_pop_dyn >= 2)
-  ELSE  
-    DO i = 1, klon
-      d_awdens2(i) = 0.
-      d_wdens2(i) = 0.
-    END DO
-  ENDIF  ! (iflag_wk_pop_dyn >= 1)
-!
-  DO i = 1, klon
-    sigmaw_targ = min(max(sigmaw(i), sigmad),0.99)
-    d_sig_bnd2(i) = sigmaw_targ - sigmaw(i)
-    d_sigmaw2(i) = sigmaw_targ - sigmaw(i)
-    sigmaw(i) = sigmaw_targ
-  END DO
-!
-  IF (iflag_wk_pop_dyn == 3) THEN
-     DO i = 1, klon  
-        IF ((wdens(i)-awdens(i)) <= smallestreal) THEN
-          sigmaw_targ = sigmaw(i)
-        ELSE
-          sigmaw_targ = min(max(asigmaw(i),sigmad),sigmaw(i))
-        ENDIF
-        d_asig_bnd2(i) = sigmaw_targ - asigmaw(i)
-        d_asigmaw2(i) = sigmaw_targ - asigmaw(i)
-        asigmaw(i) = sigmaw_targ
-     END DO
-  ENDIF ! (iflag_wk_pop_dyn == 3)
-
-  wape(:) = 0.
-  wape2(:) = 0.
-  d_sigmaw(:) = 0.
-  d_asigmaw(:) = 0.
-  ktopw(:) = 0
-!
-!<jyg
-dth(:,:) = 0.
-tx(:,:) = 0.
-qx(:,:) = 0.
-dtke(:,:) = 0.
-dqke(:,:) = 0.
-wkspread(:,:) = 0.
-omgbdth(:,:) = 0.
-omg(:,:) = 0.
-dp_omgb(:,:) = 0.
-dp_deltomg(:,:) = 0.
-hw(:) = 0.
-wape(:) = 0.
-fip(:) = 0.
-gfl(:) = 0.
-cstar(:) = 0.
-ktopw(:) = 0
-!
-!  Vertical advection local variables
-omgbw(:,:) = 0.
-omgtop(:) = 0
-dp_omgbw(:,:) = 0.
-omgbdq(:,:) = 0.
-
-!>jyg
-!
-  IF (prt_level>=10) THEN
-    PRINT *, 'wake-1, sigmaw(igout) ', sigmaw(igout)
-    PRINT *, 'wake-1, deltatw(igout,k) ', (k,deltatw(igout,k), k=1,klev)
-    PRINT *, 'wake-1, deltaqw(igout,k) ', (k,deltaqw(igout,k), k=1,klev)
-    PRINT *, 'wake-1, dowwdraughts, amdwn(igout,k) ', (k,amdwn(igout,k), k=1,klev)
-    PRINT *, 'wake-1, dowwdraughts, dtdwn(igout,k) ', (k,dtdwn(igout,k), k=1,klev)
-    PRINT *, 'wake-1, dowwdraughts, dqdwn(igout,k) ', (k,dqdwn(igout,k), k=1,klev)
-    PRINT *, 'wake-1, updraughts, amup(igout,k) ', (k,amup(igout,k), k=1,klev)
-    PRINT *, 'wake-1, updraughts, dta(igout,k) ', (k,dta(igout,k), k=1,klev)
-    PRINT *, 'wake-1, updraughts, dqa(igout,k) ', (k,dqa(igout,k), k=1,klev)
-  ENDIF
-
-  ! 2. - Prognostic part
-  ! --------------------
-
-
-  ! 2.1 - Undisturbed area and Wake integrals
-  ! ---------------------------------------------------------
-
-  DO i = 1, klon
-    z(i) = 0.
-    ktop(i) = 0
-    kupper(i) = 0
-    sum_thx(i) = 0.
-    sum_tx(i) = 0.
-    sum_qx(i) = 0.
-    sum_thvx(i) = 0.
-    sum_dth(i) = 0.
-    sum_dq(i) = 0.
-    sum_dtdwn(i) = 0.
-    sum_dqdwn(i) = 0.
-
-    av_thx(i) = 0.
-    av_tx(i) = 0.
-    av_qx(i) = 0.
-    av_thvx(i) = 0.
-    av_dth(i) = 0.
-    av_dq(i) = 0.
-    av_dtdwn(i) = 0.
-    av_dqdwn(i) = 0.
-  END DO
-
-  ! Distance between wakes
-  DO i = 1, klon
-    ll(i) = (1-sqrt(sigmaw(i)))/sqrt(wdens(i))
-  END DO
-  ! Potential temperatures and humidity
-  ! ----------------------------------------------------------
-  DO k = 1, klev
-    DO i = 1, klon
-      ! write(*,*)'wake 1',i,k,RD,tb(i,k)
-      rho(i, k) = p(i, k)/(RD*tb(i,k))
-      ! write(*,*)'wake 2',rho(i,k)
-      IF (k==1) THEN
-        ! write(*,*)'wake 3',i,k,rd,tb(i,k)
-        rhoh(i, k) = ph(i, k)/(RD*tb(i,k))
-        ! write(*,*)'wake 4',i,k,rd,tb(i,k)
-        zhh(i, k) = 0
-      ELSE
-        ! write(*,*)'wake 5',rd,(tb(i,k)+tb(i,k-1))
-        rhoh(i, k) = ph(i, k)*2./(RD*(tb(i,k)+tb(i,k-1)))
-        ! write(*,*)'wake 6',(-rhoh(i,k)*RG)+zhh(i,k-1)
-        zhh(i, k) = (ph(i,k)-ph(i,k-1))/(-rhoh(i,k)*RG) + zhh(i, k-1)
-      END IF
-      ! write(*,*)'wake 7',ppi(i,k)
-      thb(i, k) = tb(i, k)/ppi(i, k)
-      thx(i, k) = (tb(i,k)-deltatw(i,k)*sigmaw(i))/ppi(i, k)
-      tx(i, k) = tb(i, k) - deltatw(i, k)*sigmaw(i)
-      qx(i, k) = qb(i, k) - deltaqw(i, k)*sigmaw(i)
-      ! write(*,*)'wake 8',(RD*(tb(i,k)+deltatw(i,k)))
-      dth(i, k) = deltatw(i, k)/ppi(i, k)
-    END DO
-  END DO
-
-  DO k = 1, klev - 1
-    DO i = 1, klon
-      IF (k==1) THEN
-        n2(i, k) = 0
-      ELSE
-        n2(i, k) = amax1(0., -RG**2/thb(i,k)*rho(i,k)*(thb(i,k+1)-thb(i,k-1))/ &
-                             (p(i,k+1)-p(i,k-1)))
-      END IF
-      zh(i, k) = (zhh(i,k)+zhh(i,k+1))/2
-
-      cgw(i, k) = sqrt(n2(i,k))*zh(i, k)
-      tgw(i, k) = coefgw*cgw(i, k)/ll(i)
-    END DO
-  END DO
-
-  DO i = 1, klon
-    n2(i, klev) = 0
-    zh(i, klev) = 0
-    cgw(i, klev) = 0
-    tgw(i, klev) = 0
-  END DO
-
-  
-  ! Choose an integration bound well above wake top
-  ! -----------------------------------------------------------------
-
-  ! Determine Wake top pressure (Ptop) from buoyancy integral
-  ! --------------------------------------------------------
-
-   Do i=1, klon
-       wk_adv(i) = .True.
-   Enddo
-   Call pkupper (klon, klev, ptop, ph, p, pupper, kupper, &
-                    dth, hw0, rho, delta_t_min, &
-                    ktop, wk_adv, h_zzz, ptop1, ktop1)
- 
-   !!print'("pkupper APPEL ",7i6)',0,int(ptop/100.),int(ptop1/100.),int(pupper/100.),ktop,ktop1,kupper
-   
-   IF (prt_level>=10) THEN
-     PRINT *, 'wake-3, ktop(igout), kupper(igout) ', ktop(igout), kupper(igout)
-  ENDIF
-
-  ! -5/ Set deltatw & deltaqw to 0 above kupper
-
-  DO k = 1, klev
-    DO i = 1, klon
-      IF (k>=kupper(i)) THEN
-        deltatw(i, k) = 0.
-        deltaqw(i, k) = 0.
-        d_deltatw2(i,k) = -deltatw0(i,k)
-        d_deltaqw2(i,k) = -deltaqw0(i,k)
-      END IF
-    END DO
-  END DO
-
-
-  ! Vertical gradient of LS omega
-
-  DO k = 1, klev
-    DO i = 1, klon
-      IF (k<=kupper(i)) THEN
-        dp_omgb(i, k) = (omgb(i,k+1)-omgb(i,k))/(ph(i,k+1)-ph(i,k))
-      END IF
-    END DO
-  END DO
-
-  ! Integrals (and wake top level number)
-  ! --------------------------------------
-
-  ! Initialize sum_thvx to 1st level virt. pot. temp.
-
-  DO i = 1, klon
-    z(i) = 1.
-    dz(i) = 1.
-    sum_thvx(i) = thx(i, 1)*(1.+epsim1*qx(i,1))*dz(i)
-    sum_dth(i) = 0.
-  END DO
-
-  DO k = 1, klev
-    DO i = 1, klon
-      dz(i) = -(amax1(ph(i,k+1),ptop(i))-ph(i,k))/(rho(i,k)*RG)
-      IF (dz(i)>0) THEN
-              ! LJYF : ecriture pas sympa avec un tableau z(i) qui n'est pas utilise come tableau
-        z(i) = z(i) + dz(i)
-        sum_thx(i) = sum_thx(i) + thx(i, k)*dz(i)
-        sum_tx(i) = sum_tx(i) + tx(i, k)*dz(i)
-        sum_qx(i) = sum_qx(i) + qx(i, k)*dz(i)
-        sum_thvx(i) = sum_thvx(i) + thx(i, k)*(1.+epsim1*qx(i,k))*dz(i)
-        sum_dth(i) = sum_dth(i) + dth(i, k)*dz(i)
-        sum_dq(i) = sum_dq(i) + deltaqw(i, k)*dz(i)
-        sum_dtdwn(i) = sum_dtdwn(i) + dtdwn(i, k)*dz(i)
-        sum_dqdwn(i) = sum_dqdwn(i) + dqdwn(i, k)*dz(i)
-      END IF
-    END DO
-  END DO
-
-  DO i = 1, klon
-    hw0(i) = z(i)
-  END DO
-
-
-  ! 2.1 - WAPE and mean forcing computation
-  ! ---------------------------------------
-
-  ! ---------------------------------------
-
-  ! Means
-
-  DO i = 1, klon
-    av_thx(i) = sum_thx(i)/hw0(i)
-    av_tx(i) = sum_tx(i)/hw0(i)
-    av_qx(i) = sum_qx(i)/hw0(i)
-    av_thvx(i) = sum_thvx(i)/hw0(i)
-    ! av_thve = sum_thve/hw0
-    av_dth(i) = sum_dth(i)/hw0(i)
-    av_dq(i) = sum_dq(i)/hw0(i)
-    av_dtdwn(i) = sum_dtdwn(i)/hw0(i)
-    av_dqdwn(i) = sum_dqdwn(i)/hw0(i)
-
-    wape(i) = -RG*hw0(i)*(av_dth(i)+ &
-        epsim1*(av_thx(i)*av_dq(i)+av_dth(i)*av_qx(i)+av_dth(i)*av_dq(i)))/av_thvx(i)
-
-  END DO
-IF (CPPKEY_IOPHYS_WK) THEN
-  IF (.not.phys_sub) CALL iophys_ecrit('wape_a',1,'wape_a','J/kg',wape)
-END IF
-
-  ! 2.2 Prognostic variable update
-  ! ------------------------------
-
-  ! Filter out bad wakes
-
-  DO k = 1, klev
-    DO i = 1, klon
-      IF (wape(i)<0.) THEN
-        deltatw(i, k) = 0.
-        deltaqw(i, k) = 0.
-        dth(i, k) = 0.
-        d_deltatw2(i,k) = -deltatw0(i,k)
-        d_deltaqw2(i,k) = -deltaqw0(i,k)
-      END IF
-    END DO
-  END DO
-
-  DO i = 1, klon
-    IF (wape(i)<0.) THEN
-!!      sigmaw(i) = amax1(sigmad, sigd_con(i))
-      sigmaw_targ = max(sigmad, sigd_con(i))
-      d_sig_bnd2(i) = d_sig_bnd2(i) + sigmaw_targ - sigmaw(i)
-      d_sigmaw2(i) = d_sigmaw2(i) + sigmaw_targ - sigmaw(i)
-      sigmaw(i) = sigmaw_targ
-    ENDIF  !!  (wape(i)<0.)
-  ENDDO
-  !
-  IF (iflag_wk_pop_dyn == 3) THEN
-    DO i = 1, klon
-      IF (wape(i)<0.) THEN
-        sigmaw_targ = max(sigmad, sigd_con(i))
-        d_asig_bnd2(i) = d_asig_bnd2(i) + sigmaw_targ - asigmaw(i)
-        d_asigmaw2(i) = d_asigmaw2(i) + sigmaw_targ - asigmaw(i)
-        asigmaw(i) = sigmaw_targ
-      ENDIF  !!  (wape(i)<0.)
-    ENDDO
-  ENDIF  !!  (iflag_wk_pop_dyn == 3)
-
-  DO i = 1, klon
-    IF (wape(i)<0.) THEN
-      wape(i) = 0.
-      cstar(i) = 0.
-      hw(i) = hwmin
-      fip(i) = 0.
-      gwake(i) = .FALSE.
-    ELSE
-      hw(i) = hw0(i)
-      cstar(i) = stark*sqrt(2.*wape(i))
-      gwake(i) = .TRUE.
-    END IF
-  END DO
-  !
-
-  ! Check qx and qw positivity
-  ! --------------------------
-  DO i = 1, klon
-    q0_min(i) = min((qb(i,1)-sigmaw(i)*deltaqw(i,1)),  &
-                    (qb(i,1)+(1.-sigmaw(i))*deltaqw(i,1)))
-  END DO
-  DO k = 2, klev
-    DO i = 1, klon
-      q1_min(i) = min((qb(i,k)-sigmaw(i)*deltaqw(i,k)), &
-                      (qb(i,k)+(1.-sigmaw(i))*deltaqw(i,k)))
-      IF (q1_min(i)<=q0_min(i)) THEN
-        q0_min(i) = q1_min(i)
-      END IF
-    END DO
-  END DO
-
-  DO i = 1, klon
-    ok_qx_qw(i) = q0_min(i) >= 0.
-    alpha(i) = 1.
-    alpha_tot(i) = 1.
-  END DO
-
-  IF (prt_level>=10) THEN
-    PRINT *, 'wake-4, sigmaw(igout), cstar(igout), wape(igout), ktop(igout) ', &
-                      sigmaw(igout), cstar(igout), wape(igout), ktop(igout)
-  ENDIF
-
-
-  ! C -----------------------------------------------------------------
-  ! Sub-time-stepping
-  ! -----------------
-
-!    wk_nsub and dtimesub definitions moved to begining of routine.
-!!  wk_nsub = 10
-!!  dtimesub = dtime/wk_nsub
-
-  
-  ! ------------------------------------------------------------------------
-  ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-  ! ------------------------------------------------------------------------
-  !
-  DO isubstep = 1, wk_nsub
-  !
-  ! ------------------------------------------------------------------------
-    ! wk_adv is the logical flag enabling wake evolution in the time advance
-    ! loop
-    DO i = 1, klon
-      wk_adv(i) = ok_qx_qw(i) .AND. alpha(i) >= 1.
-    END DO
-    IF (prt_level>=10) THEN
-      PRINT *, 'wake-4.1, isubstep,wk_adv(igout),cstar(igout),wape(igout), ptop(igout) ', &
-                          isubstep,wk_adv(igout),cstar(igout),wape(igout), ptop(igout)
-     
-    ENDIF
-
-    ! cc nrlmd   Ajout d'un recalcul de wdens dans le cas d'un entrainement
-    ! negatif de ktop a kupper --------
-    ! cc           On calcule pour cela une densite wdens0 pour laquelle on
-    ! aurait un entrainement nul ---
-    !jyg<
-    ! Dans la configuration avec wdens prognostique, il s'agit d'un cas ou 
-    ! les poches sont insuffisantes pour accueillir tout le flux de masse 
-    ! des descentes unsaturees. Nous faisons alors l'hypothese que la 
-    ! convection profonde cree directement de nouvelles poches, sans passer 
-    ! par les thermiques. La nouvelle valeur de wdens est alors imposee.
-
-    DO i = 1, klon
-      ! c       print *,' isubstep,wk_adv(i),cstar(i),wape(i) ',
-      ! c     $           isubstep,wk_adv(i),cstar(i),wape(i)
-      IF (wk_adv(i) .AND. cstar(i)>0.01) THEN
-        IF ( iflag_wk_profile == 0 ) THEN
-           omg(i, kupper(i)+1)=-RG*amdwn(i, kupper(i)+1)/sigmaw(i) + &
-                               RG*amup(i, kupper(i)+1)/(1.-sigmaw(i))
-        ELSE
-           omg(i, kupper(i)+1)=0.
-        ENDIF
-        wdens0 = (sigmaw(i)/(4.*3.14))* &
-          ((1.-sigmaw(i))*omg(i,kupper(i)+1)/((ph(i,1)-pupper(i))*cstar(i)))**(2)
-        IF (prt_level >= 10) THEN
-             print*,'omg(i,kupper(i)+1),wdens0,wdens(i),cstar(i), ph(i,1)-pupper(i)', &
-                     omg(i,kupper(i)+1),wdens0,wdens(i),cstar(i), ph(i,1)-pupper(i)
-        ENDIF
-        IF (wdens(i)<=wdens0*1.1) THEN
-          IF (iflag_wk_pop_dyn >= 1) THEN
-             d_dens_bnd2(i) = d_dens_bnd2(i) + wdens0 - wdens(i)
-             d_wdens2(i) = d_wdens2(i) + wdens0 - wdens(i)
-          ENDIF
-          wdens(i) = wdens0
-        END IF
-      END IF
-    END DO
-
-    IF (iflag_wk_pop_dyn == 0 .AND. ok_bug_gfl) THEN
-!!--------------------------------------------------------
-!!Bug : computing gfl and rad_wk before changing sigmaw
-!!      This bug exists only for iflag_wk_pop_dyn=0. Otherwise, gfl and rad_wk 
-!!      are computed within  wake_popdyn
-!!--------------------------------------------------------
-      DO i = 1, klon
-        IF (wk_adv(i)) THEN
-          gfl(i) = 2.*sqrt(3.14*wdens(i)*sigmaw(i))
-          rad_wk(i) = sqrt(sigmaw(i)/(3.14*wdens(i)))
-        END IF
-      END DO
-    ENDIF   ! (iflag_wk_pop_dyn == 0 .AND. ok_bug_gfl)
-!!--------------------------------------------------------
-
-    DO i = 1, klon
-      IF (wk_adv(i)) THEN
-        sigmaw_targ = min(sigmaw(i), sigmaw_max)
-        d_sig_bnd2(i) = d_sig_bnd2(i) + sigmaw_targ - sigmaw(i)
-        d_sigmaw2(i)  = d_sigmaw2(i)  + sigmaw_targ - sigmaw(i)
-        sigmaw(i) = sigmaw_targ
-      END IF
-    END DO
-
-    IF (iflag_wk_pop_dyn == 0 .AND. .NOT.ok_bug_gfl) THEN
-!!--------------------------------------------------------
-!!Fix : computing gfl and rad_wk after changing sigmaw
-!!--------------------------------------------------------
-      DO i = 1, klon
-        IF (wk_adv(i)) THEN
-          gfl(i) = 2.*sqrt(3.14*wdens(i)*sigmaw(i))
-          rad_wk(i) = sqrt(sigmaw(i)/(3.14*wdens(i)))
-        END IF
-      END DO
-    ENDIF   ! (iflag_wk_pop_dyn == 0 .AND. .NOT.ok_bug_gfl)
-!!--------------------------------------------------------
-
-    IF (iflag_wk_pop_dyn >= 1) THEN
-  !  The variable "death_rate" is significant only when iflag_wk_pop_dyn = 0.
-  !  Here, it has to be set to zero.
-      death_rate(:) = 0.
-    ENDIF
-  
-    IF (iflag_wk_pop_dyn >= 3) THEN
-      DO i = 1, klon
-        IF (wk_adv(i)) THEN
-         sigmaw_targ = min(asigmaw(i), sigmaw_max)
-         d_asig_bnd2(i) = d_asig_bnd2(i) + sigmaw_targ - asigmaw(i)
-         d_asigmaw2(i)  = d_asigmaw2(i)  + sigmaw_targ - asigmaw(i)
-         asigmaw(i) = sigmaw_targ
-        ENDIF
-      ENDDO
-    ENDIF
-  
-!!--------------------------------------------------------
-!!--------------------------------------------------------
-    IF (iflag_wk_pop_dyn == 1) THEN
-  !
-     CALL wake_popdyn_1 (klon, klev, dtime, cstar, tau_wk_inv, wgen, wdens, awdens, sigmaw, &
-                  wdensmin, &
-                  dtimesub, gfl, rad_wk, f_shear, drdt_pos, &
-                  d_awdens, d_wdens, d_sigmaw, &
-                  iflag_wk_act, wk_adv, cin, wape, &
-                  drdt, &
-                  d_dens_gen, d_dens_death, d_dens_col, d_dens_bnd, &
-                  d_sig_gen, d_sig_death, d_sig_col, d_sig_spread, d_sig_bnd, &
-                  d_wdens_targ, d_sigmaw_targ)
-                      
-    
-!!--------------------------------------------------------
-    ELSEIF (iflag_wk_pop_dyn == 2) THEN
-  !
-     CALL wake_popdyn_2 ( klon, klev, wk_adv, dtimesub, wgen, &
-                             wdensmin, &
-                             sigmaw, wdens, awdens, &   !! state variables
-                             gfl, cstar, cin, wape, rad_wk, &
-                             d_sigmaw, d_wdens, d_awdens, &  !! tendencies                              
-                             cont_fact, &
-                             d_sig_gen, d_sig_death, d_sig_col, d_sig_spread, d_sig_bnd, &
-                             d_dens_gen, d_dens_death, d_dens_col, d_dens_bnd, &
-                             d_adens_death, d_adens_icol, d_adens_acol, d_adens_bnd )
-sigmaw=sigmaw-d_sigmaw
-wdens=wdens-d_wdens
-awdens=awdens-d_awdens
-
-!!--------------------------------------------------------
-    ELSEIF (iflag_wk_pop_dyn == 3) THEN
-IF (CPPKEY_IOPHYS_WK) THEN
-    IF (phys_sub) THEN
-     CALL iophys_ecrit('ptop',1,'ptop','Pa',ptop)
-     CALL iophys_ecrit('sigmaw',1,'sigmaw','',sigmaw)
-     CALL iophys_ecrit('asigmaw',1,'asigmaw','',asigmaw)
-     CALL iophys_ecrit('wdens',1,'wdens','1/m2',wdens)
-     CALL iophys_ecrit('awdens',1,'awdens','1/m2',awdens)
-     CALL iophys_ecrit('rad_wk',1,'rad_wk','m',rad_wk)
-     CALL iophys_ecrit('arad_wk',1,'arad_wk','m',arad_wk)
-     CALL iophys_ecrit('irad_wk',1,'irad_wk','m',irad_wk)
-    ENDIF
-END IF
-  !
-     CALL wake_popdyn_3 ( klon, klev, phys_sub, wk_adv, dtimesub, wgen, &
-                             wdensmin, &
-                             sigmaw, asigmaw, wdens, awdens, &   !! state variables
-                             gfl, agfl, cstar, cin, wape, &
-                             rad_wk, arad_wk, irad_wk, &
-                             d_sigmaw, d_asigmaw, d_wdens, d_awdens, &  !! tendencies                              
-                             d_sig_gen, d_sig_death, d_sig_col, d_sig_spread, d_sig_bnd, &
-                             d_asig_death, d_asig_aicol, d_asig_iicol, d_asig_spread, d_asig_bnd, &
-                             d_dens_gen, d_dens_death, d_dens_col, d_dens_bnd, &
-                             d_adens_death, d_adens_icol, d_adens_acol, d_adens_bnd )
-sigmaw=sigmaw-d_sigmaw
-asigmaw=asigmaw-d_asigmaw
-wdens=wdens-d_wdens
-awdens=awdens-d_awdens
-   
-!!--------------------------------------------------------
-    ELSEIF (iflag_wk_pop_dyn == 0) THEN
-    
-    ! cc nrlmd
-
-      DO i = 1, klon
-        IF (wk_adv(i)) THEN
-
-          ! cc nrlmd          Introduction du taux de mortalite des poches et
-          ! test sur sigmaw_max=0.4
-          ! cc         d_sigmaw(i) = gfl(i)*Cstar(i)*dtimesub
-          IF (sigmaw(i)>=sigmaw_max) THEN
-            death_rate(i) = gfl(i)*cstar(i)/sigmaw(i)
-          ELSE
-            death_rate(i) = 0.
-          END IF
-    
-          d_sigmaw(i) = gfl(i)*cstar(i)*dtimesub - death_rate(i)*sigmaw(i)* &
-            dtimesub
-          ! $              - nat_rate(i)*sigmaw(i)*dtimesub
-          ! c        print*, 'd_sigmaw(i),sigmaw(i),gfl(i),Cstar(i),wape(i),
-          ! c     $  death_rate(i),ktop(i),kupper(i)',
-          ! c     $	         d_sigmaw(i),sigmaw(i),gfl(i),Cstar(i),wape(i),
-          ! c     $  death_rate(i),ktop(i),kupper(i)
-    
-          ! sigmaw(i) =sigmaw(i) + gfl(i)*Cstar(i)*dtimesub
-          ! sigmaw(i) =min(sigmaw(i),0.99)     !!!!!!!!
-          ! wdens = wdens0/(10.*sigmaw)
-          ! sigmaw =max(sigmaw,sigd_con)
-          ! sigmaw =max(sigmaw,sigmad)
-        END IF
-      END DO
-
-    ENDIF   !  (iflag_wk_pop_dyn == 1) ... ELSEIF (iflag_wk_pop_dyn == 0)
-!!--------------------------------------------------------
-!!--------------------------------------------------------
-
-IF (CPPKEY_IOPHYS_WK) THEN
-    IF (phys_sub) THEN
-     CALL iophys_ecrit('wdensa',1,'wdensa','m',wdens)
-     CALL iophys_ecrit('awdensa',1,'awdensa','m',awdens)
-     CALL iophys_ecrit('sigmawa',1,'sigmawa','m',sigmaw)
-     CALL iophys_ecrit('asigmawa',1,'asigmawa','m',asigmaw)
-    ENDIF
-END IF
-    ! calcul de la difference de vitesse verticale poche - zone non perturbee
-    ! IM 060208 differences par rapport au code initial; init. a 0 dp_deltomg
-    ! IM 060208 et omg sur les niveaux de 1 a klev+1, alors que avant l'on definit
-    ! IM 060208 au niveau k=1...
-    !JYG 161013 Correction : maintenant omg est dimensionne a klev.
-    DO k = 1, klev
-      DO i = 1, klon
-        IF (wk_adv(i)) THEN !!! nrlmd
-          dp_deltomg(i, k) = 0.
-        END IF
-      END DO
-    END DO
-    DO k = 1, klev
-      DO i = 1, klon
-        IF (wk_adv(i)) THEN !!! nrlmd
-          omg(i, k) = 0.
-        END IF
-      END DO
-    END DO
-
-    DO i = 1, klon
-      IF (wk_adv(i)) THEN
-        z(i) = 0.
-        omg(i, 1) = 0.
-        dp_deltomg(i, 1) = -(gfl(i)*cstar(i))/(sigmaw(i)*(1-sigmaw(i)))
-      END IF
-    END DO
-
-    DO k = 2, klev
-      DO i = 1, klon
-        IF (wk_adv(i) .AND. k<=ktop(i)) THEN
-          dz(i) = -(ph(i,k)-ph(i,k-1))/(rho(i,k-1)*RG)
-          z(i) = z(i) + dz(i)
-          dp_deltomg(i, k) = dp_deltomg(i, 1)
-          omg(i, k) = dp_deltomg(i, 1)*z(i)
-        END IF
-      END DO
-    END DO
-
-    DO i = 1, klon
-      IF (wk_adv(i)) THEN
-        dztop(i) = -(ptop(i)-ph(i,ktop(i)))/(rho(i,ktop(i))*RG)
-        ztop(i) = z(i) + dztop(i)
-        omgtop(i) = dp_deltomg(i, 1)*ztop(i)
-      END IF
-    END DO
-
-    IF (prt_level>=10) THEN
-      PRINT *, 'wake-4.2, omg(igout,k) ', (k,omg(igout,k), k=1,klev)
-      PRINT *, 'wake-4.2, omgtop(igout), ptop(igout), ktop(igout) ', &
-                          omgtop(igout), ptop(igout), ktop(igout)
-    ENDIF
-
-    ! -----------------
-    ! From m/s to Pa/s
-    ! -----------------
-
-    DO i = 1, klon
-      IF (wk_adv(i)) THEN
-        omgtop(i) = -rho(i, ktop(i))*RG*omgtop(i)
-!! LJYF        dp_deltomg(i, 1) = omgtop(i)/(ptop(i)-ph(i,1))
-        dp_deltomg(i, 1) = omgtop(i)/min(ptop(i)-ph(i,1),-smallestreal)
-      END IF
-    END DO
-
-    DO k = 1, klev
-      DO i = 1, klon
-        IF (wk_adv(i) .AND. k<=ktop(i)) THEN
-          omg(i, k) = -rho(i, k)*RG*omg(i, k)
-          dp_deltomg(i, k) = dp_deltomg(i, 1)
-        END IF
-      END DO
-    END DO
-
-    ! raccordement lineaire de omg de ptop a pupper
-
-    DO i = 1, klon
-      IF (wk_adv(i) .AND. kupper(i)>ktop(i)) THEN
-        IF ( iflag_wk_profile == 0 ) THEN
-           omg(i, kupper(i)+1) =-RG*amdwn(i, kupper(i)+1)/sigmaw(i) + &
-          RG*amup(i, kupper(i)+1)/(1.-sigmaw(i))
-        ELSE
-           omg(i, kupper(i)+1) = 0.
-        ENDIF
-        dp_deltomg(i, kupper(i)) = (omgtop(i)-omg(i,kupper(i)+1))/ &
-          (ptop(i)-pupper(i))
-      END IF
-    END DO
-
-    ! c      DO i=1,klon
-    ! c        print*,'Pente entre 0 et kupper (reference)'
-    ! c     $   	,omg(i,kupper(i)+1)/(pupper(i)-ph(i,1))
-    ! c        print*,'Pente entre ktop et kupper'
-    ! c     $  	,(omg(i,kupper(i)+1)-omgtop(i))/(pupper(i)-ptop(i))
-    ! c      ENDDO
-    ! c
-    DO k = 1, klev
-      DO i = 1, klon
-        IF (wk_adv(i) .AND. k>ktop(i) .AND. k<=kupper(i)) THEN
-          dp_deltomg(i, k) = dp_deltomg(i, kupper(i))
-          omg(i, k) = omgtop(i) + (ph(i,k)-ptop(i))*dp_deltomg(i, kupper(i))
-        END IF
-      END DO
-    END DO
-!!    print *,'omg(igout,k) ', (k,omg(igout,k),k=1,klev)
-    ! cc nrlmd
-    ! c      DO i=1,klon
-    ! c      print*,'deltaw_ktop,deltaw_conv',omgtop(i),omg(i,kupper(i)+1)
-    ! c      END DO
-    ! cc
-
-
-    ! --    Compute wake average vertical velocity omgbw
-
-
-    DO k = 1, klev
-      DO i = 1, klon
-        IF (wk_adv(i)) THEN
-          omgbw(i, k) = omgb(i, k) + (1.-sigmaw(i))*omg(i, k)
-        END IF
-      END DO
-    END DO
-    ! --    and its vertical gradient dp_omgbw
-
-    DO k = 1, klev-1
-      DO i = 1, klon
-        IF (wk_adv(i)) THEN
-          dp_omgbw(i, k) = (omgbw(i,k+1)-omgbw(i,k))/(ph(i,k+1)-ph(i,k))
-        END IF
-      END DO
-    END DO
-    DO i = 1, klon
-      IF (wk_adv(i)) THEN
-          dp_omgbw(i, klev) = 0.
-      END IF
-    END DO
-
-    ! --    Upstream coefficients for omgb velocity
-    ! --    (alpha_up(k) is the coefficient of the value at level k)
-    ! --    (1-alpha_up(k) is the coefficient of the value at level k-1)
-    DO k = 1, klev
-      DO i = 1, klon
-        IF (wk_adv(i)) THEN
-          alpha_up(i, k) = 0.
-          IF (omgb(i,k)>0.) alpha_up(i, k) = 1.
-        END IF
-      END DO
-    END DO
-
-    ! Matrix expressing [The,deltatw] from  [Th1,Th2]
-
-    DO i = 1, klon
-      IF (wk_adv(i)) THEN
-        rre1(i) = 1. - sigmaw(i)
-        rre2(i) = sigmaw(i)
-      END IF
-    END DO
-    rrd1 = -1.
-    rrd2 = 1.
-
-    ! --    Get [Th1,Th2], dth and [q1,q2]
-
-    DO k = 1, klev
-      DO i = 1, klon
-        IF (wk_adv(i) .AND. k<=kupper(i)+1) THEN
-          dth(i, k) = deltatw(i, k)/ppi(i, k)
-          th1(i, k) = thb(i, k) - sigmaw(i)*dth(i, k) ! undisturbed area
-          th2(i, k) = thb(i, k) + (1.-sigmaw(i))*dth(i, k) ! wake
-          q1(i, k) = qb(i, k) - sigmaw(i)*deltaqw(i, k) ! undisturbed area
-          q2(i, k) = qb(i, k) + (1.-sigmaw(i))*deltaqw(i, k) ! wake
-        END IF
-      END DO
-    END DO
-
-    DO i = 1, klon
-      IF (wk_adv(i)) THEN !!! nrlmd
-        d_th1(i, 1) = 0.
-        d_th2(i, 1) = 0.
-        d_dth(i, 1) = 0.
-        d_q1(i, 1) = 0.
-        d_q2(i, 1) = 0.
-        d_dq(i, 1) = 0.
-      END IF
-    END DO
-
-    DO k = 2, klev
-      DO i = 1, klon
-        IF (wk_adv(i) .AND. k<=kupper(i)+1) THEN
-          d_th1(i, k) = th1(i, k-1) - th1(i, k)
-          d_th2(i, k) = th2(i, k-1) - th2(i, k)
-          d_dth(i, k) = dth(i, k-1) - dth(i, k)
-          d_q1(i, k) = q1(i, k-1) - q1(i, k)
-          d_q2(i, k) = q2(i, k-1) - q2(i, k)
-          d_dq(i, k) = deltaqw(i, k-1) - deltaqw(i, k)
-        END IF
-      END DO
-    END DO
-
-    DO i = 1, klon
-      IF (wk_adv(i)) THEN
-        omgbdth(i, 1) = 0.
-        omgbdq(i, 1) = 0.
-      END IF
-    END DO
-
-    DO k = 2, klev
-      DO i = 1, klon
-        IF (wk_adv(i) .AND. k<=kupper(i)+1) THEN !   loop on interfaces
-          omgbdth(i, k) = omgb(i, k)*(dth(i,k-1)-dth(i,k))
-          omgbdq(i, k) = omgb(i, k)*(deltaqw(i,k-1)-deltaqw(i,k))
-        END IF
-      END DO
-    END DO
-
-!!    IF (prt_level>=10) THEN
-    IF (prt_level>=10 .and. wk_adv(igout)) THEN
-      PRINT *, 'wake-4.3, th1(igout,k) ', (k,th1(igout,k), k=1,kupper(igout))
-      PRINT *, 'wake-4.3, th2(igout,k) ', (k,th2(igout,k), k=1,kupper(igout))
-      PRINT *, 'wake-4.3, dth(igout,k) ', (k,dth(igout,k), k=1,kupper(igout))
-      PRINT *, 'wake-4.3, omgbdth(igout,k) ', (k,omgbdth(igout,k), k=1,kupper(igout))
-    ENDIF
-
-    ! -----------------------------------------------------------------
-    DO k = 1, klev-1
-      DO i = 1, klon
-        IF (wk_adv(i) .AND. k<=kupper(i)-1) THEN
-          ! -----------------------------------------------------------------
-
-          ! Compute redistribution (advective) term
-
-          d_deltatw(i, k) = dtimesub/(ph(i,k)-ph(i,k+1))* &
-            (rrd1*omg(i,k)*sigmaw(i)*d_th1(i,k) - &
-             rrd2*omg(i,k+1)*(1.-sigmaw(i))*d_th2(i,k+1)- &
-             (1.-alpha_up(i,k))*omgbdth(i,k)- &
-             alpha_up(i,k+1)*omgbdth(i,k+1))*ppi(i, k)
-!           print*,'d_d,k_ptop_provis(i)eltatw=', k, d_deltatw(i,k)
-
-          d_deltaqw(i, k) = dtimesub/(ph(i,k)-ph(i,k+1))* &
-            (rrd1*omg(i,k)*sigmaw(i)*d_q1(i,k)- &
-             rrd2*omg(i,k+1)*(1.-sigmaw(i))*d_q2(i,k+1)- &
-             (1.-alpha_up(i,k))*omgbdq(i,k)- &
-             alpha_up(i,k+1)*omgbdq(i,k+1))
-!           print*,'d_deltaqw=', k, d_deltaqw(i,k)
-
-          ! and increment large scale tendencies
-
-
-
-
-          ! C
-          ! -----------------------------------------------------------------
-          d_tb(i, k) = dtimesub*((rre1(i)*omg(i,k)*sigmaw(i)*d_th1(i,k)- &
-                                  rre2(i)*omg(i,k+1)*(1.-sigmaw(i))*d_th2(i,k+1))/ &
-                                 (ph(i,k)-ph(i,k+1)) &
-                                 -sigmaw(i)*(1.-sigmaw(i))*dth(i,k)*(omg(i,k)-omg(i,k+1))/ &
-                                 (ph(i,k)-ph(i,k+1)) )*ppi(i, k)
-
-          d_qb(i, k) = dtimesub*((rre1(i)*omg(i,k)*sigmaw(i)*d_q1(i,k)- &
-                                  rre2(i)*omg(i,k+1)*(1.-sigmaw(i))*d_q2(i,k+1))/ &
-                                 (ph(i,k)-ph(i,k+1)) &
-                                 -sigmaw(i)*(1.-sigmaw(i))*deltaqw(i,k)*(omg(i,k)-omg(i,k+1))/ &
-                                 (ph(i,k)-ph(i,k+1)) )
-        ELSE IF (wk_adv(i) .AND. k==kupper(i)) THEN
-          d_tb(i, k) = dtimesub*(rre1(i)*omg(i,k)*sigmaw(i)*d_th1(i,k)/(ph(i,k)-ph(i,k+1)))*ppi(i, k)
-
-          d_qb(i, k) = dtimesub*(rre1(i)*omg(i,k)*sigmaw(i)*d_q1(i,k)/(ph(i,k)-ph(i,k+1)))
-
-        END IF
-        ! cc
-      END DO
-    END DO
-    ! ------------------------------------------------------------------
-
-    IF (prt_level>=10) THEN
-      PRINT *, 'wake-4.3, d_deltatw(igout,k) ', (k,d_deltatw(igout,k), k=1,klev)
-      PRINT *, 'wake-4.3, d_deltaqw(igout,k) ', (k,d_deltaqw(igout,k), k=1,klev)
-    ENDIF
-
-    ! Increment state variables
-!jyg<
-    IF (iflag_wk_pop_dyn >= 1) THEN
-      DO k = 1, klev
-        DO i = 1, klon
-          IF (wk_adv(i) .AND. k<=kupper(i)) THEN
-            detr(i,k) = - d_sig_death(i) - d_sig_col(i)      
-            entr(i,k) = d_sig_gen(i)
-          ENDIF
-        ENDDO
-      ENDDO
-      ELSE  ! (iflag_wk_pop_dyn >= 1)
-      DO k = 1, klev
-        DO i = 1, klon
-          IF (wk_adv(i) .AND. k<=kupper(i)) THEN
-            detr(i, k) = 0.
-   
-            entr(i, k) = 0.
-          ENDIF
-        ENDDO
-      ENDDO
-    ENDIF  ! (iflag_wk_pop_dyn >= 1)
-
-    
-
-    DO k = 1, klev
-      DO i = 1, klon
-        ! cc nrlmd       IF( wk_adv(i) .AND. k .LE. kupper(i)-1) THEN
-        IF (wk_adv(i) .AND. k<=kupper(i)) THEN
-          ! cc
-
-
-
-          ! Coefficient de repartition
-
-          crep(i, k) = crep_sol*(ph(i,kupper(i))-ph(i,k))/ &
-            (ph(i,kupper(i))-ph(i,1))
-          crep(i, k) = crep(i, k) + crep_upper*(ph(i,1)-ph(i,k))/ &
-            (ph(i,1)-ph(i,kupper(i)))
-
-
-          ! Reintroduce compensating subsidence term.
-
-          ! dtKE(k)=(dtdwn(k)*Crep(k))/sigmaw
-          ! dtKE(k)=dtKE(k)-(dtdwn(k)*(1-Crep(k))+dta(k))
-          ! .                   /(1-sigmaw)
-          ! dqKE(k)=(dqdwn(k)*Crep(k))/sigmaw
-          ! dqKE(k)=dqKE(k)-(dqdwn(k)*(1-Crep(k))+dqa(k))
-          ! .                   /(1-sigmaw)
-
-          ! dtKE(k)=(dtdwn(k)*Crep(k)+(1-Crep(k))*dta(k))/sigmaw
-          ! dtKE(k)=dtKE(k)-(dtdwn(k)*(1-Crep(k))+dta(k)*Crep(k))
-          ! .                   /(1-sigmaw)
-          ! dqKE(k)=(dqdwn(k)*Crep(k)+(1-Crep(k))*dqa(k))/sigmaw
-          ! dqKE(k)=dqKE(k)-(dqdwn(k)*(1-Crep(k))+dqa(k)*Crep(k))
-          ! .                   /(1-sigmaw)
-
-          dtke(i, k) = (dtdwn(i,k)/sigmaw(i)-dta(i,k)/(1.-sigmaw(i)))
-          dqke(i, k) = (dqdwn(i,k)/sigmaw(i)-dqa(i,k)/(1.-sigmaw(i)))
-          ! print*,'dtKE= ',dtKE(i,k),' dqKE= ',dqKE(i,k)
-
-!
-
-          ! cc nrlmd          Prise en compte du taux de mortalite
-          ! cc               Definitions de entr, detr
-!jyg<
-!!            detr(i, k) = 0.
-!!   
-!!            entr(i, k) = detr(i, k) + gfl(i)*cstar(i) + &
-!!              sigmaw(i)*(1.-sigmaw(i))*dp_deltomg(i, k)
-!!
-            entr(i, k) = entr(i,k) + gfl(i)*cstar(i) + &
-                         sigmaw(i)*(1.-sigmaw(i))*dp_deltomg(i, k)   
-!>jyg
-            wkspread(i, k) = (entr(i,k)-detr(i,k))/sigmaw(i)
-
-          ! cc        wkspread(i,k) =
-          ! (1.-sigmaw(i))*dp_deltomg(i,k)+gfl(i)*Cstar(i)/
-          ! cc     $  sigmaw(i)
-
-
-          ! ajout d'un effet onde de gravite -Tgw(k)*deltatw(k) 03/02/06 YU
-          ! Jingmei
-
-          ! write(lunout,*)'wake.F ',i,k, dtimesub,d_deltat_gw(i,k),
-          ! &  Tgw(i,k),deltatw(i,k)
-          d_deltat_gw(i, k) = d_deltat_gw(i, k) - tgw(i, k)*deltatw(i, k)* &
-            dtimesub
-          ! write(lunout,*)'wake.F ',i,k, dtimesub,d_deltatw(i,k)
-          ff(i) = d_deltatw(i, k)/dtimesub
-
-          ! Sans GW
-
-          ! deltatw(k)=deltatw(k)+dtimesub*(ff+dtKE(k)-wkspread(k)*deltatw(k))
-
-          ! GW formule 1
-
-          ! deltatw(k) = deltatw(k)+dtimesub*
-          ! $         (ff+dtKE(k) - wkspread(k)*deltatw(k)-Tgw(k)*deltatw(k))
-
-          ! GW formule 2
-
-          IF (dtimesub*tgw(i,k)<1.E-10) THEN
-            d_deltatw(i, k) = dtimesub*(ff(i)+dtke(i,k) - & 
-               entr(i,k)*deltatw(i,k)/sigmaw(i) - &
-               (death_rate(i)*sigmaw(i)+detr(i,k))*deltatw(i,k)/(1.-sigmaw(i)) - & ! cc
-               tgw(i,k)*deltatw(i,k) )
-          ELSE
-            d_deltatw(i, k) = 1/tgw(i, k)*(1-exp(-dtimesub*tgw(i,k)))* &
-               (ff(i)+dtke(i,k) - &
-                entr(i,k)*deltatw(i,k)/sigmaw(i) - &
-                (death_rate(i)*sigmaw(i)+detr(i,k))*deltatw(i,k)/(1.-sigmaw(i)) - &
-                tgw(i,k)*deltatw(i,k) )
-          END IF
-
-          dth(i, k) = deltatw(i, k)/ppi(i, k)
-
-          gg(i) = d_deltaqw(i, k)/dtimesub
-
-          d_deltaqw(i, k) = dtimesub*(gg(i)+dqke(i,k) - & 
-            entr(i,k)*deltaqw(i,k)/sigmaw(i) - &
-            (death_rate(i)*sigmaw(i)+detr(i,k))*deltaqw(i,k)/(1.-sigmaw(i)))
-          ! cc
-
-          ! cc nrlmd
-          ! cc       d_deltatw2(i,k)=d_deltatw2(i,k)+d_deltatw(i,k)
-          ! cc       d_deltaqw2(i,k)=d_deltaqw2(i,k)+d_deltaqw(i,k)
-          ! cc
-        END IF
-      END DO
-    END DO
-
-
-    ! Scale tendencies so that water vapour remains positive in w and x.
-
-    CALL wake_vec_modulation(klon, klev, wk_adv, epsilon_loc, qb, d_qb, deltaqw, &
-      d_deltaqw, sigmaw, d_sigmaw, alpha)
-    !
-    ! Alpha_tot = Product of all the alpha's
-    DO i = 1, klon
-      IF (wk_adv(i)) THEN
-        alpha_tot(i) = alpha_tot(i)*alpha(i)    
-      END IF
-    END DO
-
-    ! cc nrlmd
-    ! c      print*,'alpha'
-    ! c      do i=1,klon
-    ! c         print*,alpha(i)
-    ! c      end do
-    ! cc
-    DO k = 1, klev
-      DO i = 1, klon
-        IF (wk_adv(i) .AND. k<=kupper(i)) THEN
-          d_tb(i, k) = alpha(i)*d_tb(i, k)
-          d_qb(i, k) = alpha(i)*d_qb(i, k)
-          d_deltatw(i, k) = alpha(i)*d_deltatw(i, k)
-          d_deltaqw(i, k) = alpha(i)*d_deltaqw(i, k)
-          d_deltat_gw(i, k) = alpha(i)*d_deltat_gw(i, k)
-        END IF
-      END DO
-    END DO
-    DO i = 1, klon
-      IF (wk_adv(i)) THEN
-        d_sigmaw(i) = alpha(i)*d_sigmaw(i)
-      END IF
-    END DO
-
-    ! Update large scale variables and wake variables
-    ! IM 060208 manque DO i + remplace DO k=1,kupper(i)
-    ! IM 060208     DO k = 1,kupper(i)
-    DO k = 1, klev
-      DO i = 1, klon
-        IF (wk_adv(i) .AND. k<=kupper(i)) THEN
-          dtls(i, k) = dtls(i, k) + d_tb(i, k)
-          dqls(i, k) = dqls(i, k) + d_qb(i, k)
-          ! cc nrlmd
-          d_deltatw2(i, k) = d_deltatw2(i, k) + d_deltatw(i, k)
-          d_deltaqw2(i, k) = d_deltaqw2(i, k) + d_deltaqw(i, k)
-          ! cc
-        END IF
-      END DO
-    END DO
-    DO k = 1, klev
-      DO i = 1, klon
-        IF (wk_adv(i) .AND. k<=kupper(i)) THEN
-          tb(i, k) = tb0(i, k) + dtls(i, k)
-          qb(i, k) = qb0(i, k) + dqls(i, k)
-          thb(i, k) = tb(i, k)/ppi(i, k)
-          deltatw(i, k) = deltatw(i, k) + d_deltatw(i, k)
-          deltaqw(i, k) = deltaqw(i, k) + d_deltaqw(i, k)
-          dth(i, k) = deltatw(i, k)/ppi(i, k)
-          ! c      print*,'k,qx,qw',k,qb(i,k)-sigmaw(i)*deltaqw(i,k)
-          ! c     $        ,qb(i,k)+(1-sigmaw(i))*deltaqw(i,k)
-        END IF
-      END DO
-    END DO
-!
-    DO i = 1, klon
-      IF (wk_adv(i)) THEN
-        sigmaw(i) = sigmaw(i) + d_sigmaw(i)
-        d_sigmaw2(i) = d_sigmaw2(i) + d_sigmaw(i)
-      END IF
-    END DO
-!jyg<
-    IF (iflag_wk_pop_dyn >= 1) THEN
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! sigmaw !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!  Cumulatives
-      DO i = 1, klon
-        IF (wk_adv(i)) THEN
-          d_sig_gen2(i)   = d_sig_gen2(i)   + d_sig_gen(i)
-          d_sig_death2(i) = d_sig_death2(i) + d_sig_death(i)
-          d_sig_col2(i)   = d_sig_col2(i)   + d_sig_col(i)
-          d_sig_spread2(i)= d_sig_spread2(i)+ d_sig_spread(i)
-          d_sig_bnd2(i)   = d_sig_bnd2(i)   + d_sig_bnd(i)
-        END IF
-      END DO
-!  Bounds
-      DO i = 1, klon
-        IF (wk_adv(i)) THEN
-          sigmaw_targ = max(sigmaw(i),sigmad)
-          d_sig_bnd2(i) = d_sig_bnd2(i) + sigmaw_targ - sigmaw(i)
-          d_sigmaw2(i) = d_sigmaw2(i) + sigmaw_targ - sigmaw(i)
-          sigmaw(i) = sigmaw_targ
-        END IF
-      END DO
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! wdens  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!  Cumulatives
-      DO i = 1, klon
-        IF (wk_adv(i)) THEN
-          wdens(i) = wdens(i) + d_wdens(i)
-          d_wdens2(i) = d_wdens2(i) + d_wdens(i)
-          d_dens_gen2(i)   = d_dens_gen2(i)   + d_dens_gen(i)
-          d_dens_death2(i) = d_dens_death2(i) + d_dens_death(i)
-          d_dens_col2(i)   = d_dens_col2(i)   + d_dens_col(i)
-          d_dens_bnd2(i)   = d_dens_bnd2(i)   + d_dens_bnd(i)
-        END IF
-      END DO
-!  Bounds
-      DO i = 1, klon
-        IF (wk_adv(i)) THEN
-          wdens_targ = max(wdens(i),wdensmin)
-          d_dens_bnd2(i) = d_dens_bnd2(i) + wdens_targ - wdens(i)
-          d_wdens2(i) = d_wdens2(i) + wdens_targ - wdens(i)
-          wdens(i) = wdens_targ
-        END IF
-      END DO
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! awdens !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!  Cumulatives
-      DO i = 1, klon
-        IF (wk_adv(i)) THEN
-          awdens(i) = awdens(i) + d_awdens(i)
-          d_awdens2(i) = d_awdens2(i) + d_awdens(i)
-        END IF
-      END DO
-!  Bounds
-      DO i = 1, klon
-        IF (wk_adv(i)) THEN
-          wdens_targ = min( max(awdens(i),0.), wdens(i) )
-          d_adens_bnd2(i) = d_adens_bnd2(i) + wdens_targ - awdens(i)
-          d_awdens2(i) = d_awdens2(i) + wdens_targ - awdens(i)
-          awdens(i) = wdens_targ
-        END IF
-      END DO
-!
-      IF (iflag_wk_pop_dyn >= 2) THEN
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! awdens again for iflag_wk_pop_dyn >= 2!!!!!!
-!  Cumulatives
-        DO i = 1, klon
-           IF (wk_adv(i)) THEN
-               d_adens_death2(i)   = d_adens_death2(i)   + d_adens_death(i)
-               d_adens_icol2(i)   = d_adens_icol2(i)   + d_adens_icol(i)
-               d_adens_acol2(i)   = d_adens_acol2(i)   + d_adens_acol(i)
-               d_adens_bnd2(i)   = d_adens_bnd2(i)   + d_adens_bnd(i)          
-           END IF
-        END DO
-!  Bounds
-        DO i = 1, klon
-           IF (wk_adv(i)) THEN
-               wdens_targ = min( max(awdens(i),0.), wdens(i) )
-               d_adens_bnd2(i) = d_adens_bnd2(i) + wdens_targ - awdens(i)
-               awdens(i) = wdens_targ
-           END IF
-        END DO
-!
-        IF (iflag_wk_pop_dyn == 3) THEN
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! asigmaw for iflag_wk_pop_dyn = 3!!!!!!
-!  Cumulatives
-          DO i = 1, klon
-             IF (wk_adv(i)) THEN
-                 asigmaw(i) = asigmaw(i) + d_asigmaw(i)
-                 d_asigmaw2(i) = d_asigmaw2(i) + d_asigmaw(i)
-                 d_asig_death2(i)   = d_asig_death2(i)   + d_asig_death(i)
-                 d_asig_spread2(i)  = d_asig_spread2(i)  + d_asig_spread(i)
-                 d_asig_iicol2(i)   = d_asig_iicol2(i)   + d_asig_iicol(i)
-                 d_asig_aicol2(i)   = d_asig_aicol2(i)   + d_asig_aicol(i)
-                 d_asig_bnd2(i)     = d_asig_bnd2(i)     + d_asig_bnd(i)          
-             END IF
-          END DO
-!  Bounds
-          DO i = 1, klon
-             IF (wk_adv(i)) THEN
-   !   asigmaw lower bound set to sigmad/2 in order to allow asigmaw values lower than sigmad.
-   !!             sigmaw_targ = min(max(asigmaw(i),sigmad),sigmaw(i))
-                sigmaw_targ = min(max(asigmaw(i),sigmad/2.),sigmaw(i))
-                d_asig_bnd2(i) = d_asig_bnd2(i) + sigmaw_targ - asigmaw(i)
-                d_asigmaw2(i) = d_asigmaw2(i) + sigmaw_targ - asigmaw(i)
-                asigmaw(i) = sigmaw_targ
-             END IF
-          END DO
-
-IF (CPPKEY_IOPHYS_WK) THEN
-    IF (phys_sub) THEN
-     CALL iophys_ecrit('wdensb',1,'wdensb','m',wdens)
-     CALL iophys_ecrit('awdensb',1,'awdensb','m',awdens)
-     CALL iophys_ecrit('sigmawb',1,'sigmawb','m',sigmaw)
-     CALL iophys_ecrit('asigmawb',1,'asigmawb','m',asigmaw)
-!
-     call iophys_ecrit('d_wdens2',1,'d_wdens2','',d_wdens2)
-     call iophys_ecrit('d_dens_gen2',1,'d_dens_gen2','',d_dens_gen2)
-     call iophys_ecrit('d_dens_death2',1,'d_dens_death2','',d_dens_death2)
-     call iophys_ecrit('d_dens_col2',1,'d_dens_col2','',d_dens_col2)
-     call iophys_ecrit('d_dens_bnd2',1,'d_dens_bnd2','',d_dens_bnd2)
-!
-     call iophys_ecrit('d_awdens2',1,'d_awdens2','',d_awdens2)
-     call iophys_ecrit('d_adens_death2',1,'d_adens_death2','',d_adens_death2)
-     call iophys_ecrit('d_adens_icol2',1,'d_adens_icol2','',d_adens_icol2)
-     call iophys_ecrit('d_adens_acol2',1,'d_adens_acol2','',d_adens_acol2)
-     call iophys_ecrit('d_adens_bnd2',1,'d_adens_bnd2','',d_adens_bnd2)
-!
-     CALL iophys_ecrit('d_sigmaw2',1,'d_sigmaw2','',d_sigmaw2)
-     CALL iophys_ecrit('d_sig_gen2',1,'d_sig_gen2','m',d_sig_gen2)
-     CALL iophys_ecrit('d_sig_spread2',1,'d_sig_spread2','',d_sig_spread2)
-     CALL iophys_ecrit('d_sig_col2',1,'d_sig_col2','',d_sig_col2)
-     CALL iophys_ecrit('d_sig_death2',1,'d_sig_death2','',d_sig_death2)
-     CALL iophys_ecrit('d_sig_bnd2',1,'d_sig_bnd2','',d_sig_bnd2)
-!
-     CALL iophys_ecrit('d_asigmaw2',1,'d_asigmaw2','',d_asigmaw2)
-     CALL iophys_ecrit('d_asig_spread2',1,'d_asig_spread2','m',d_asig_spread2)
-     CALL iophys_ecrit('d_asig_aicol2',1,'d_asig_aicol2','m',d_asig_aicol2)
-     CALL iophys_ecrit('d_asig_iicol2',1,'d_asig_iicol2','m',d_asig_iicol2)
-     CALL iophys_ecrit('d_asig_death2',1,'d_asig_death2','m',d_asig_death2)
-     CALL iophys_ecrit('d_asig_bnd2',1,'d_asig_bnd2','m',d_asig_bnd2)
-    ENDIF
-END IF
-        ENDIF ! (iflag_wk_pop_dyn == 3)
-      ENDIF ! (iflag_wk_pop_dyn >= 2)
-    ENDIF  ! (iflag_wk_pop_dyn >= 1)
-
-
-
-   Call pkupper (klon, klev, ptop, ph, p, pupper, kupper, &
-                    dth, hw, rho, delta_t_min, &
-                    ktop, wk_adv, h_zzz, ptop1, ktop1)
-   !! print'("pkupper APPEL ",7i6)',isubstep,int(ptop/100.),int(ptop1/100.),int(pupper/100.),ktop,ktop1,kupper
-
-    ! 5/ Set deltatw & deltaqw to 0 above kupper
-
-    DO k = 1, klev
-      DO i = 1, klon
-        IF (wk_adv(i) .AND. k>=kupper(i)) THEN
-          deltatw(i, k) = 0.
-          deltaqw(i, k) = 0.
-          d_deltatw2(i,k) = -deltatw0(i,k)
-          d_deltaqw2(i,k) = -deltaqw0(i,k)
-        END IF
-      END DO
-    END DO
-
-
-    ! -------------Cstar computation---------------------------------
-    DO i = 1, klon
-      IF (wk_adv(i)) THEN !!! nrlmd
-        sum_thx(i) = 0.
-        sum_tx(i) = 0.
-        sum_qx(i) = 0.
-        sum_thvx(i) = 0.
-        sum_dth(i) = 0.
-        sum_dq(i) = 0.
-        sum_dtdwn(i) = 0.
-        sum_dqdwn(i) = 0.
-
-        av_thx(i) = 0.
-        av_tx(i) = 0.
-        av_qx(i) = 0.
-        av_thvx(i) = 0.
-        av_dth(i) = 0.
-        av_dq(i) = 0.
-        av_dtdwn(i) = 0.
-        av_dqdwn(i) = 0.
-      END IF
-    END DO
-
-    ! Integrals (and wake top level number)
-    ! --------------------------------------
-
-    ! Initialize sum_thvx to 1st level virt. pot. temp.
-
-    DO i = 1, klon
-      IF (wk_adv(i)) THEN !!! nrlmd
-        z(i) = 1.
-        dz(i) = 1.
-        sum_thvx(i) = thx(i, 1)*(1.+epsim1*qx(i,1))*dz(i)
-        sum_dth(i) = 0.
-      END IF
-    END DO
-
-    DO k = 1, klev
-      DO i = 1, klon
-        IF (wk_adv(i)) THEN !!! nrlmd
-          dz(i) = -(max(ph(i,k+1),ptop(i))-ph(i,k))/(rho(i,k)*RG)
-          IF (dz(i)>0) THEN
-            z(i) = z(i) + dz(i)
-            sum_thx(i) = sum_thx(i) + thx(i, k)*dz(i)
-            sum_tx(i) = sum_tx(i) + tx(i, k)*dz(i)
-            sum_qx(i) = sum_qx(i) + qx(i, k)*dz(i)
-            sum_thvx(i) = sum_thvx(i) + thx(i, k)*(1.+epsim1*qx(i,k))*dz(i)
-            sum_dth(i) = sum_dth(i) + dth(i, k)*dz(i)
-            sum_dq(i) = sum_dq(i) + deltaqw(i, k)*dz(i)
-            sum_dtdwn(i) = sum_dtdwn(i) + dtdwn(i, k)*dz(i)
-            sum_dqdwn(i) = sum_dqdwn(i) + dqdwn(i, k)*dz(i)
-          END IF
-        END IF
-      END DO
-    END DO
-
-    DO i = 1, klon
-      IF (wk_adv(i)) THEN !!! nrlmd
-        hw0(i) = z(i)
-      END IF
-    END DO
-
-
-    ! - WAPE and mean forcing computation
-    ! ---------------------------------------
-
-    ! ---------------------------------------
-
-    ! Means
-
-    DO i = 1, klon
-      IF (wk_adv(i)) THEN !!! nrlmd
-        av_thx(i) = sum_thx(i)/hw0(i)
-        av_tx(i) = sum_tx(i)/hw0(i)
-        av_qx(i) = sum_qx(i)/hw0(i)
-        av_thvx(i) = sum_thvx(i)/hw0(i)
-        av_dth(i) = sum_dth(i)/hw0(i)
-        av_dq(i) = sum_dq(i)/hw0(i)
-        av_dtdwn(i) = sum_dtdwn(i)/hw0(i)
-        av_dqdwn(i) = sum_dqdwn(i)/hw0(i)
-
-        wape(i) = -RG*hw0(i)*(av_dth(i)+epsim1*(av_thx(i)*av_dq(i) + &
-                              av_dth(i)*av_qx(i)+av_dth(i)*av_dq(i)))/av_thvx(i)
-      END IF
-    END DO
-
-
-    ! Filter out bad wakes
-
-    DO k = 1, klev
-      DO i = 1, klon
-        IF (wk_adv(i)) THEN !!! nrlmd
-          IF (wape(i)<0.) THEN
-            deltatw(i, k) = 0.
-            deltaqw(i, k) = 0.
-            dth(i, k) = 0.
-            d_deltatw2(i,k) = -deltatw0(i,k)
-            d_deltaqw2(i,k) = -deltaqw0(i,k)
-          END IF
-        END IF
-      END DO
-    END DO
-
-    DO i = 1, klon
-      IF (wk_adv(i)) THEN !!! nrlmd
-        IF (wape(i)<0.) THEN
-          wape(i) = 0.
-          cstar(i) = 0.
-          hw(i) = hwmin
-!jyg<
-!!          sigmaw(i) = max(sigmad, sigd_con(i))
-          sigmaw_targ = max(sigmad, sigd_con(i))
-          d_sig_bnd2(i) = d_sig_bnd2(i) + sigmaw_targ - sigmaw(i)
-          d_sigmaw2(i) = d_sigmaw2(i) + sigmaw_targ - sigmaw(i)
-          sigmaw(i) = sigmaw_targ
-!
-          d_asig_bnd2(i) = d_asig_bnd2(i) + sigmaw_targ - asigmaw(i)
-          d_asigmaw2(i) = d_asigmaw2(i) + sigmaw_targ - asigmaw(i)
-          asigmaw(i) = sigmaw_targ
-!>jyg
-          fip(i) = 0.
-          gwake(i) = .FALSE.
-        ELSE
-          cstar(i) = stark*sqrt(2.*wape(i))
-          gwake(i) = .TRUE.
-        END IF
-      END IF
-    END DO
-  !
-  ! ------------------------------------------------------------------------
-  !
-  END DO   ! isubstep end sub-timestep loop
-  !
-  ! ------------------------------------------------------------------------
-  ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-  ! ------------------------------------------------------------------------
-  !
-
-IF (CPPKEY_IOPHYS_WK) THEN
-    IF (.not.phys_sub) CALL iophys_ecrit('wape_b',1,'wape_b','J/kg',wape)
-END IF
-  IF (prt_level>=10) THEN
-    PRINT *, 'wake-5, sigmaw(igout), cstar(igout), wape(igout), ptop(igout) ', &
-                      sigmaw(igout), cstar(igout), wape(igout), ptop(igout)
-  ENDIF
-
-
-  ! ----------------------------------------------------------
-  ! Determine wake final state; recompute wape, cstar, ktop;
-  ! filter out bad wakes.
-  ! ----------------------------------------------------------
-
-  ! 2.1 - Undisturbed area and Wake integrals
-  ! ---------------------------------------------------------
-
-  DO i = 1, klon
-    ! cc nrlmd       if (wk_adv(i)) then !!! nrlmd
-    IF (ok_qx_qw(i)) THEN
-      ! cc
-      z(i) = 0.
-      sum_thx(i) = 0.
-      sum_tx(i) = 0.
-      sum_qx(i) = 0.
-      sum_thvx(i) = 0.
-      sum_dth(i) = 0.
-      sum_half_dth(i) = 0.
-      sum_dq(i) = 0.
-      sum_dtdwn(i) = 0.
-      sum_dqdwn(i) = 0.
-
-      av_thx(i) = 0.
-      av_tx(i) = 0.
-      av_qx(i) = 0.
-      av_thvx(i) = 0.
-      av_dth(i) = 0.
-      av_dq(i) = 0.
-      av_dtdwn(i) = 0.
-      av_dqdwn(i) = 0.
-
-      dthmin(i) = -delta_t_min
-    END IF
-  END DO
-  ! Potential temperatures and humidity
-  ! ----------------------------------------------------------
-
-  DO k = 1, klev
-    DO i = 1, klon
-      ! cc nrlmd       IF ( wk_adv(i)) THEN
-      IF (ok_qx_qw(i)) THEN
-        ! cc
-        rho(i, k) = p(i, k)/(RD*tb(i,k))
-        IF (k==1) THEN
-          rhoh(i, k) = ph(i, k)/(RD*tb(i,k))
-          zhh(i, k) = 0
-        ELSE
-          rhoh(i, k) = ph(i, k)*2./(RD*(tb(i,k)+tb(i,k-1)))
-          zhh(i, k) = (ph(i,k)-ph(i,k-1))/(-rhoh(i,k)*RG) + zhh(i, k-1)
-        END IF
-        thb(i, k) = tb(i, k)/ppi(i, k)
-        thx(i, k) = (tb(i,k)-deltatw(i,k)*sigmaw(i))/ppi(i, k)
-        tx(i, k) = tb(i, k) - deltatw(i, k)*sigmaw(i)
-        qx(i, k) = qb(i, k) - deltaqw(i, k)*sigmaw(i)
-        dth(i, k) = deltatw(i, k)/ppi(i, k)
-      END IF
-    END DO
-  END DO
-
-  ! Integrals (and wake top level number)
-  ! -----------------------------------------------------------
-
-  ! Initialize sum_thvx to 1st level virt. pot. temp.
-
-  DO i = 1, klon
-    ! cc nrlmd       IF ( wk_adv(i)) THEN
-    IF (ok_qx_qw(i)) THEN
-      ! cc
-      z(i) = 1.
-      dz(i) = 1.
-      dz_half(i) = 1.
-      sum_thvx(i) = thx(i, 1)*(1.+epsim1*qx(i,1))*dz(i)
-      sum_dth(i) = 0.
-    END IF
-  END DO
-
-  DO k = 1, klev
-    DO i = 1, klon
-      ! cc nrlmd       IF ( wk_adv(i)) THEN
-      IF (ok_qx_qw(i)) THEN
-        ! cc
-        dz(i) = -(amax1(ph(i,k+1),ptop(i))-ph(i,k))/(rho(i,k)*RG)
-        dz_half(i) = -(amax1(ph(i,k+1),0.5*(ptop(i)+ph(i,1)))-ph(i,k))/(rho(i,k)*RG)
-        IF (dz(i)>0) THEN
-          z(i) = z(i) + dz(i)
-          sum_thx(i) = sum_thx(i) + thx(i, k)*dz(i)
-          sum_tx(i) = sum_tx(i) + tx(i, k)*dz(i)
-          sum_qx(i) = sum_qx(i) + qx(i, k)*dz(i)
-          sum_thvx(i) = sum_thvx(i) + thx(i, k)*(1.+epsim1*qx(i,k))*dz(i)
-          sum_dth(i) = sum_dth(i) + dth(i, k)*dz(i)
-          sum_dq(i) = sum_dq(i) + deltaqw(i, k)*dz(i)
-          sum_dtdwn(i) = sum_dtdwn(i) + dtdwn(i, k)*dz(i)
-          sum_dqdwn(i) = sum_dqdwn(i) + dqdwn(i, k)*dz(i)
-!
-          dthmin(i) = min(dthmin(i), dth(i,k))
-        END IF
-        IF (dz_half(i)>0) THEN
-          sum_half_dth(i) = sum_half_dth(i) + dth(i, k)*dz_half(i)
-        END IF
-      END IF
-    END DO
-  END DO
-
-  DO i = 1, klon
-    ! cc nrlmd       IF ( wk_adv(i)) THEN
-    IF (ok_qx_qw(i)) THEN
-      ! cc
-      hw0(i) = z(i)
-    END IF
-  END DO
-
-  ! - WAPE and mean forcing computation
-  ! -------------------------------------------------------------
-
-  ! Means
-
-  DO i = 1, klon
-    ! cc nrlmd       IF ( wk_adv(i)) THEN
-    IF (ok_qx_qw(i)) THEN
-      ! cc
-      av_thx(i) = sum_thx(i)/hw0(i)
-      av_tx(i) = sum_tx(i)/hw0(i)
-      av_qx(i) = sum_qx(i)/hw0(i)
-      av_thvx(i) = sum_thvx(i)/hw0(i)
-      av_dth(i) = sum_dth(i)/hw0(i)
-      av_dq(i) = sum_dq(i)/hw0(i)
-      av_dtdwn(i) = sum_dtdwn(i)/hw0(i)
-      av_dqdwn(i) = sum_dqdwn(i)/hw0(i)
-
-      wape2(i) = -RG*hw0(i)*(av_dth(i)+epsim1*(av_thx(i)*av_dq(i) + &
-                             av_dth(i)*av_qx(i)+av_dth(i)*av_dq(i)))/av_thvx(i)
-    END IF
-  END DO
-IF (CPPKEY_IOPHYS_WK) THEN
-  IF (.not.phys_sub) CALL iophys_ecrit('wape2_a',1,'wape2_a','J/kg',wape2)
-END IF
-
-
-  ! Prognostic variable update
-  ! ------------------------------------------------------------
-
-  ! Filter out bad wakes
-
-  IF (iflag_wk_check_trgl>=1) THEN
-    ! Check triangular shape of dth profile
-    DO i = 1, klon
-      IF (ok_qx_qw(i)) THEN
-        !! print *,'wake, hw0(i), dthmin(i) ', hw0(i), dthmin(i)
-        !! print *,'wake, 2.*sum_dth(i)/(hw0(i)*dthmin(i)) ', &
-        !!                2.*sum_dth(i)/(hw0(i)*dthmin(i))
-        !! print *,'wake, sum_half_dth(i), sum_dth(i) ', &
-        !!                sum_half_dth(i), sum_dth(i)
-        IF ((hw0(i) < 1.) .or. (dthmin(i) >= -delta_t_min) ) THEN
-          wape2(i) = -1.
-          !! print *,'wake, rej 1'
-        ELSE IF (iflag_wk_check_trgl==1.AND.abs(2.*sum_dth(i)/(hw0(i)*dthmin(i)) - 1.) > 0.5) THEN
-          wape2(i) = -1.
-          !! print *,'wake, rej 2'
-        ELSE IF (abs(sum_half_dth(i)) < 0.5*abs(sum_dth(i)) ) THEN
-          wape2(i) = -1.
-          !! print *,'wake, rej 3'
-        END IF
-      END IF
-    END DO
-  END IF
-IF (CPPKEY_IOPHYS_WK) THEN
-  IF (.not.phys_sub) CALL iophys_ecrit('wape2_b',1,'wape2_b','J/kg',wape2)
-END IF
-
-
-  DO k = 1, klev
-    DO i = 1, klon
-      ! cc nrlmd        IF ( wk_adv(i) .AND. wape2(i) .LT. 0.) THEN
-      IF (ok_qx_qw(i) .AND. wape2(i)<0.) THEN
-        ! cc
-        deltatw(i, k) = 0.
-        deltaqw(i, k) = 0.
-        dth(i, k) = 0.
-        d_deltatw2(i,k) = -deltatw0(i,k)
-        d_deltaqw2(i,k) = -deltaqw0(i,k)
-      END IF
-    END DO
-  END DO
-
-
-  DO i = 1, klon
-    ! cc nrlmd       IF ( wk_adv(i)) THEN
-    IF (ok_qx_qw(i)) THEN
-      ! cc
-      IF (wape2(i)<0.) THEN
-        wape2(i) = 0.
-        cstar2(i) = 0.
-        hw(i) = hwmin
-!jyg<
-!!      sigmaw(i) = amax1(sigmad, sigd_con(i))
-      sigmaw_targ = max(sigmad, sigd_con(i))
-      d_sig_bnd2(i) = d_sig_bnd2(i) + sigmaw_targ - sigmaw(i)
-      d_sigmaw2(i) = d_sigmaw2(i) + sigmaw_targ - sigmaw(i)
-      sigmaw(i) = sigmaw_targ
-!
-      d_asig_bnd2(i) = d_asig_bnd2(i) + sigmaw_targ - asigmaw(i)
-      d_asigmaw2(i) = d_asigmaw2(i) + sigmaw_targ - asigmaw(i)
-      asigmaw(i) = sigmaw_targ
-!>jyg
-        fip(i) = 0.
-        gwake(i) = .FALSE.
-      ELSE
-        IF (prt_level>=10) PRINT *, 'wape2>0'
-        cstar2(i) = stark*sqrt(2.*wape2(i))
-        gwake(i) = .TRUE.
-      END IF
-IF (CPPKEY_IOPHYS_WK) THEN
-  IF (.not.phys_sub) CALL iophys_ecrit('cstar2',1,'cstar2','J/kg',cstar2)
-END IF
-    END IF  ! (ok_qx_qw(i))
-  END DO
-
-  DO i = 1, klon
-    ! cc nrlmd       IF ( wk_adv(i)) THEN
-    IF (ok_qx_qw(i)) THEN
-      ! cc
-      ktopw(i) = ktop(i)
-    END IF
-  END DO
-
-  DO i = 1, klon
-    ! cc nrlmd       IF ( wk_adv(i)) THEN
-    IF (ok_qx_qw(i)) THEN
-      ! cc
-      IF (ktopw(i)>0 .AND. gwake(i)) THEN
-
-        ! jyg1     Utilisation d'un h_efficace constant ( ~ feeding layer)
-        ! cc       heff = 600.
-        ! Utilisation de la hauteur hw
-        ! c       heff = 0.7*hw
-        heff(i) = hw(i)
-
-        fip(i) = 0.5*rho(i, ktopw(i))*cstar2(i)**3*heff(i)*2* &
-          sqrt(sigmaw(i)*wdens(i)*3.14)
-        fip(i) = alpk*fip(i)
-        ! jyg2
-      ELSE
-        fip(i) = 0.
-      END IF
-    END IF
-  END DO
-    IF (iflag_wk_pop_dyn >= 3) THEN
-IF (CPPKEY_IOPHYS_WK) THEN
-      IF (.not.phys_sub) THEN
-       CALL iophys_ecrit('fip',1,'fip','J/kg',fip)
-       CALL iophys_ecrit('hw',1,'hw','J/kg',hw)
-       CALL iophys_ecrit('ptop',1,'ptop','J/kg',ptop)
-       CALL iophys_ecrit('wdens',1,'wdens','J/kg',wdens)
-       CALL iophys_ecrit('awdens',1,'awdens','m',awdens)
-       CALL iophys_ecrit('sigmaw',1,'sigmaw','m',sigmaw)
-       CALL iophys_ecrit('asigmaw',1,'asigmaw','m',asigmaw)
-!   
-       CALL iophys_ecrit('rad_wk',1,'rad_wk','J/kg',rad_wk)
-       CALL iophys_ecrit('arad_wk',1,'arad_wk','J/kg',arad_wk)
-       CALL iophys_ecrit('irad_wk',1,'irad_wk','J/kg',irad_wk)
-!   
-       call iophys_ecrit('d_wdens2',1,'d_wdens2','',d_wdens2)
-       call iophys_ecrit('d_dens_gen2',1,'d_dens_gen2','',d_dens_gen2)
-       call iophys_ecrit('d_dens_death2',1,'d_dens_death2','',d_dens_death2)
-       call iophys_ecrit('d_dens_col2',1,'d_dens_col2','',d_dens_col2)
-       call iophys_ecrit('d_dens_bnd2',1,'d_dens_bnd2','',d_dens_bnd2)
-!   
-       call iophys_ecrit('d_awdens2',1,'d_awdens2','',d_awdens2)
-       call iophys_ecrit('d_adens_death2',1,'d_adens_death2','',d_adens_death2)
-       call iophys_ecrit('d_adens_icol2',1,'d_adens_icol2','',d_adens_icol2)
-       call iophys_ecrit('d_adens_acol2',1,'d_adens_acol2','',d_adens_acol2)
-       call iophys_ecrit('d_adens_bnd2',1,'d_adens_bnd2','',d_adens_bnd2)
-!   
-       CALL iophys_ecrit('d_sigmaw2',1,'d_sigmaw2','',d_sigmaw2)
-       CALL iophys_ecrit('d_sig_gen2',1,'d_sig_gen2','m',d_sig_gen2)
-       CALL iophys_ecrit('d_sig_spread2',1,'d_sig_spread2','',d_sig_spread2)
-       CALL iophys_ecrit('d_sig_col2',1,'d_sig_col2','',d_sig_col2)
-       CALL iophys_ecrit('d_sig_death2',1,'d_sig_death2','',d_sig_death2)
-       CALL iophys_ecrit('d_sig_bnd2',1,'d_sig_bnd2','',d_sig_bnd2)
-!   
-       CALL iophys_ecrit('d_asigmaw2',1,'d_asigmaw2','',d_asigmaw2)
-       CALL iophys_ecrit('d_asig_spread2',1,'d_asig_spread2','m',d_asig_spread2)
-       CALL iophys_ecrit('d_asig_aicol2',1,'d_asig_aicol2','m',d_asig_aicol2)
-       CALL iophys_ecrit('d_asig_iicol2',1,'d_asig_iicol2','m',d_asig_iicol2)
-       CALL iophys_ecrit('d_asig_death2',1,'d_asig_death2','m',d_asig_death2)
-       CALL iophys_ecrit('d_asig_bnd2',1,'d_asig_bnd2','m',d_asig_bnd2)
-      ENDIF  ! (.not.phys_sub)
-END IF
-    ENDIF  ! (iflag_wk_pop_dyn >= 3)
-  ! Limitation de sigmaw
-
-  ! cc nrlmd
-  ! DO i=1,klon
-  ! IF (OK_qx_qw(i)) THEN
-  ! IF (sigmaw(i).GE.sigmaw_max) sigmaw(i)=sigmaw_max
-  ! ENDIF
-  ! ENDDO
-  ! cc
-
-  !jyg<
-  IF (iflag_wk_pop_dyn >= 1) THEN
-    DO i = 1, klon
-      kill_wake(i) = ((wape(i)>=wape2(i)) .AND. (wape2(i)<=wapecut)) .OR. (ktopw(i)<=2) .OR. &
-          .NOT. ok_qx_qw(i) .OR. (wdens(i) < wdensthreshold)
-!!          .NOT. ok_qx_qw(i) .OR. (wdens(i) < 2.*wdensmin)
-    ENDDO
-  ELSE  ! (iflag_wk_pop_dyn >= 1)
-    DO i = 1, klon
-      kill_wake(i) = ((wape(i)>=wape2(i)) .AND. (wape2(i)<=wapecut)) .OR. (ktopw(i)<=2) .OR. &
-          .NOT. ok_qx_qw(i)
-    ENDDO
-  ENDIF  ! (iflag_wk_pop_dyn >= 1)
-  !>jyg
-
-  DO k = 1, klev
-    DO i = 1, klon
-!!jyg      IF (((wape(i)>=wape2(i)) .AND. (wape2(i)<=wapecut)) .OR. (ktopw(i)<=2) .OR. &
-!!jyg          .NOT. ok_qx_qw(i)) THEN
-      IF (kill_wake(i)) THEN
-        ! cc
-        dtls(i, k) = 0.
-        dqls(i, k) = 0.
-        deltatw(i, k) = 0.
-        deltaqw(i, k) = 0.
-        d_deltatw2(i,k) = -deltatw0(i,k)
-        d_deltaqw2(i,k) = -deltaqw0(i,k)
-      END IF  ! (kill_wake(i))
-    END DO
-  END DO
-
-  DO i = 1, klon
-!!jyg    IF (((wape(i)>=wape2(i)) .AND. (wape2(i)<=wapecut)) .OR. (ktopw(i)<=2) .OR. &
-!!jyg        .NOT. ok_qx_qw(i)) THEN
-      IF (kill_wake(i)) THEN
-      ktopw(i) = 0
-      wape(i) = 0.
-      cstar(i) = 0.
-!!jyg   Outside subroutine "Wake" hw, wdens sigmaw and asigmaw are zero when there are no wakes
-!!      hw(i) = hwmin                       !jyg
-!!      sigmaw(i) = sigmad                  !jyg
-      hw(i) = 0.                            !jyg
-      fip(i) = 0.
-!
-!!      sigmaw(i) = 0.                        !jyg
-      sigmaw_targ = 0.
-      d_sig_bnd2(i) = d_sig_bnd2(i) + sigmaw_targ - sigmaw(i)
-!!      d_sigmaw2(i) = d_sigmaw2(i) + sigmaw_targ - sigmaw(i)
-      d_sigmaw2(i) = sigmaw_targ - sigmaw_in(i)      ! _in = correction jyg 20220124
-      sigmaw(i) = sigmaw_targ
-!
-      IF (iflag_wk_pop_dyn >= 3) THEN
-        sigmaw_targ = 0.
-        d_asig_bnd2(i) = d_asig_bnd2(i) + sigmaw_targ - asigmaw(i)
-!!        d_sigmaw2(i) = d_sigmaw2(i) + sigmaw_targ - sigmaw(i)
-        d_asigmaw2(i) = sigmaw_targ - asigmaw_in(i)      ! _in = correction jyg 20220124
-        asigmaw(i) = sigmaw_targ
-      ELSE
-        asigmaw(i) = 0.
-      ENDIF ! (iflag_wk_pop_dyn >= 3)
-!
-      IF (iflag_wk_pop_dyn >= 1) THEN
-!!        awdens(i) = 0.
-!!        wdens(i) = 0.
-        wdens_targ = 0.
-        d_dens_bnd2(i) = d_dens_bnd2(i) + wdens_targ - wdens(i)
-!!        d_wdens2(i) = wdens_targ - wdens(i)
-        d_wdens2(i) = wdens_targ - wdens_in(i)      ! jyg 20220916
-        wdens(i) = wdens_targ
-        wdens_targ = 0.
-!!jyg: bug fix : the d_adens_bnd2 computation must be before the update of awdens.
-        IF (iflag_wk_pop_dyn >= 2) THEN
-            d_adens_bnd2(i) = d_adens_bnd2(i) + wdens_targ - awdens(i)
-        ENDIF ! (iflag_wk_pop_dyn >= 2)
-!!        d_awdens2(i) = wdens_targ - awdens(i)
-        d_awdens2(i) = wdens_targ - awdens_in(i)    ! jyg 20220916
-        awdens(i) = wdens_targ
-!!        IF (iflag_wk_pop_dyn == 2) THEN
-!!            d_adens_bnd2(i) = d_adens_bnd2(i) + wdens_targ - awdens(i)
-!!        ENDIF ! (iflag_wk_pop_dyn == 2)
-      ENDIF  ! (iflag_wk_pop_dyn >= 1)
-    ELSE  ! (kill_wake(i))
-      wape(i) = wape2(i)
-      cstar(i) = cstar2(i)
-    END IF  ! (kill_wake(i))
-    ! c        print*,'wape wape2 ktopw OK_qx_qw =',
-    ! c     $          wape(i),wape2(i),ktopw(i),OK_qx_qw(i)
-  END DO
-
-  IF (prt_level>=10) THEN
-    PRINT *, 'wake-6, wape wape2 ktopw OK_qx_qw =', &
-                      wape(igout),wape2(igout),ktopw(igout),OK_qx_qw(igout)
-  ENDIF
-IF (CPPKEY_IOPHYS_WK) THEN
-  IF (.not.phys_sub) CALL iophys_ecrit('wape_c',1,'wape_c','J/kg',wape)
-END IF
-
-
-  ! -----------------------------------------------------------------
-  ! Get back to tendencies per second
-
-  DO k = 1, klev
-    DO i = 1, klon
-
-      ! cc nrlmd        IF ( wk_adv(i) .AND. k .LE. kupper(i)) THEN
-!jyg<
-!!      IF (ok_qx_qw(i) .AND. k<=kupper(i)) THEN
-      IF (ok_qx_qw(i)) THEN
-!>jyg
-        ! cc
-        dtls(i, k) = dtls(i, k)/dtime
-        dqls(i, k) = dqls(i, k)/dtime
-        d_deltatw2(i, k) = d_deltatw2(i, k)/dtime
-        d_deltaqw2(i, k) = d_deltaqw2(i, k)/dtime
-        d_deltat_gw(i, k) = d_deltat_gw(i, k)/dtime
-        ! c      print*,'k,dqls,omg,entr,detr',k,dqls(i,k),omg(i,k),entr(i,k)
-        ! c     $         ,death_rate(i)*sigmaw(i)
-      END IF
-    END DO
-  END DO
-!jyg<
-  IF (iflag_wk_pop_dyn >= 1) THEN
-    DO i = 1, klon
-        IF (ok_qx_qw(i)) THEN
-      d_sig_gen2(i) = d_sig_gen2(i)/dtime
-      d_sig_death2(i) = d_sig_death2(i)/dtime
-      d_sig_col2(i) = d_sig_col2(i)/dtime
-      d_sig_spread2(i) = d_sig_spread2(i)/dtime
-      d_sig_bnd2(i) = d_sig_bnd2(i)/dtime
-      d_sigmaw2(i) = d_sigmaw2(i)/dtime
-!
-      d_dens_gen2(i) = d_dens_gen2(i)/dtime
-      d_dens_death2(i) = d_dens_death2(i)/dtime
-      d_dens_col2(i) = d_dens_col2(i)/dtime
-      d_dens_bnd2(i) = d_dens_bnd2(i)/dtime
-      d_awdens2(i) = d_awdens2(i)/dtime
-      d_wdens2(i) = d_wdens2(i)/dtime
-        ENDIF
-    ENDDO
-    IF (iflag_wk_pop_dyn >= 2) THEN
-      DO i = 1, klon
-        IF (ok_qx_qw(i)) THEN
-        d_adens_death2(i) = d_adens_death2(i)/dtime
-        d_adens_icol2(i) = d_adens_icol2(i)/dtime
-        d_adens_acol2(i) = d_adens_acol2(i)/dtime
-        d_adens_bnd2(i) = d_adens_bnd2(i)/dtime
-        ENDIF
-      ENDDO
-      IF (iflag_wk_pop_dyn == 3) THEN
-       DO i = 1, klon
-          IF (ok_qx_qw(i)) THEN
-        d_asig_death2(i)  = d_asig_death2(i)/dtime
-        d_asig_iicol2(i)  = d_asig_iicol2(i)/dtime
-        d_asig_aicol2(i)  = d_asig_aicol2(i)/dtime
-        d_asig_spread2(i) = d_asig_spread2(i)/dtime
-        d_asig_bnd2(i) = d_asig_bnd2(i)/dtime
-          ENDIF
-       ENDDO
-      ENDIF ! (iflag_wk_pop_dyn == 3)  
-    ENDIF ! (iflag_wk_pop_dyn >= 2)  
-  ENDIF  ! (iflag_wk_pop_dyn >= 1)
- 
-!>jyg
-
- RETURN
-END SUBROUTINE wake
-
-SUBROUTINE wake_vec_modulation(nlon, nl, wk_adv, epsilon_loc, qb, d_qb, deltaqw, &
-    d_deltaqw, sigmaw, d_sigmaw, alpha)
-  ! ------------------------------------------------------
-  ! Dtermination du coefficient alpha tel que les tendances
-  ! corriges alpha*d_G, pour toutes les grandeurs G, correspondent
-  ! a une humidite positive dans la zone (x) et dans la zone (w).
-  ! ------------------------------------------------------
-  IMPLICIT NONE
-
-  ! Input
-  REAL qb(nlon, nl), d_qb(nlon, nl)
-  REAL deltaqw(nlon, nl), d_deltaqw(nlon, nl)
-  REAL sigmaw(nlon), d_sigmaw(nlon)
-  LOGICAL wk_adv(nlon)
-  INTEGER nl, nlon
-  ! Output
-  REAL alpha(nlon)
-  ! Internal variables
-  REAL zeta(nlon, nl)
-  REAL alpha1(nlon)
-  REAL x, a, b, c, discrim
-  REAL epsilon_loc
-  INTEGER i,k
-
-  DO k = 1, nl
-    DO i = 1, nlon
-      IF (wk_adv(i)) THEN
-        IF ((deltaqw(i,k)+d_deltaqw(i,k))>=0.) THEN
-          zeta(i, k) = 0.
-        ELSE
-          zeta(i, k) = 1.
-        END IF
-      END IF
-    END DO
-    DO i = 1, nlon
-      IF (wk_adv(i)) THEN
-        x = qb(i, k) + (zeta(i,k)-sigmaw(i))*deltaqw(i, k) + d_qb(i, k) + &
-          (zeta(i,k)-sigmaw(i))*d_deltaqw(i, k) - d_sigmaw(i) * &
-          (deltaqw(i,k)+d_deltaqw(i,k))
-        a = -d_sigmaw(i)*d_deltaqw(i, k)
-        b = d_qb(i, k) + (zeta(i,k)-sigmaw(i))*d_deltaqw(i, k) - &
-          deltaqw(i, k)*d_sigmaw(i)
-        c = qb(i, k) + (zeta(i,k)-sigmaw(i))*deltaqw(i, k) + epsilon_loc
-        discrim = b*b - 4.*a*c
-        ! print*, 'x, a, b, c, discrim', x, a, b, c, discrim
-        IF (a+b>=0.) THEN !! Condition suffisante pour la positivite de ovap
-          alpha1(i) = 1.
-        ELSE
-          IF (x>=0.) THEN
-            alpha1(i) = 1.
-          ELSE
-            IF (a>0.) THEN
-              alpha1(i) = 0.9*min( (2.*c)/(-b+sqrt(discrim)),  &
-                                   (-b+sqrt(discrim))/(2.*a) )
-            ELSE IF (a==0.) THEN
-              alpha1(i) = 0.9*(-c/b)
-            ELSE
-              ! print*,'a,b,c discrim',a,b,c discrim
-              alpha1(i) = 0.9*max( (2.*c)/(-b+sqrt(discrim)),  &
-                                   (-b+sqrt(discrim))/(2.*a))
-            END IF
-          END IF
-        END IF
-        alpha(i) = min(alpha(i), alpha1(i))
-      END IF
-    END DO
-  END DO
-
-  RETURN
-END SUBROUTINE wake_vec_modulation
-
-
-
-SUBROUTINE pkupper (klon, klev, ptop, ph, p, pupper, kupper, &
-                    dth, hw_, rho, delta_t_min_in, &
-                    ktop, wk_adv, h_zzz, ptop1, ktop1)
-
-USE lmdz_wake_ini , ONLY : wk_pupper
-USE lmdz_wake_ini , ONLY : RG
-USE lmdz_wake_ini , ONLY : hwmin
-USE lmdz_wake_ini , ONLY : iflag_wk_new_ptop, wk_delta_t_min, wk_frac_int_delta_t
-USE lmdz_wake_ini , ONLY : wk_int_delta_t_min
-
-IMPLICIT NONE
-
-INTEGER,                              INTENT(IN) :: klon,klev
-REAL,       DIMENSION (klon,klev+1) , INTENT(IN) :: ph, p
-REAL,       DIMENSION (klon,klev+1) , INTENT(IN) :: rho
-LOGICAL,    DIMENSION (klon)        , INTENT(IN) :: wk_adv
-REAL,       DIMENSION (klon,klev+1) , INTENT(IN) :: dth
-REAL,                                 INTENT(IN) :: delta_t_min_in
-
-
-REAL,       DIMENSION (klon)  , INTENT(OUT)        :: hw_
-REAL,       DIMENSION (klon)  , INTENT(OUT)        :: ptop
-INTEGER,    DIMENSION (klon)  , INTENT(OUT)        :: Ktop
-REAL,       DIMENSION (klon)  , INTENT(OUT)        :: pupper
-INTEGER,    DIMENSION (klon)  , INTENT(OUT)        :: kupper
-REAL,       DIMENSION (klon)  , INTENT(OUT)        :: h_zzz       !!
-REAL,       DIMENSION (klon)  , INTENT(OUT)        :: Ptop1      !!
-INTEGER,    DIMENSION (klon)  , INTENT(OUT)        :: ktop1      !!
-
-INTEGER :: i,k
-
-LOGICAL,    DIMENSION (klon)       :: wk_active
-REAL                               :: delta_t_min
-REAL,     DIMENSION (klon)         :: dthmin
-REAL,     DIMENSION (klon)         :: ptop_provis,ptop_new
-REAL,     DIMENSION (klon)         :: z, dz
-REAL,     DIMENSION (klon)         :: sum_dth
-
-INTEGER,     DIMENSION (klon)                     :: k_ptop_provis
-REAL,     DIMENSION (klon)                     :: zk_ptop_provis
-REAL,     DIMENSION (klon)                        :: omega        !!
-REAL,     DIMENSION (klon,klev+1)                 :: int_dth      !! 
-REAL,     DIMENSION (klon,klev+1)                 :: dzz          !!
-REAL,     DIMENSION (klon,klev+1)                 :: zzz          !!
-REAL,     DIMENSION (klon)                 :: frac_int_dth          !!
-REAL                                              :: ddd!!
-
-
-INTEGER, SAVE :: ipas=0
-
-
-
-!INTEGER, SAVE :: compte=0
-
-! LJYF : a priori z, dz sum_dth sont aussi des variables internes
-! Les eliminer apres verification convergence numerique
-
-!compte=compte+1
-!print*,'compte=',compte
-
-    ! Determine Ptop from buoyancy integral
-    ! ---------------------------------------
-
-    ! -     1/ Pressure of the level where dth changes sign.
-    !print*,'WAKE LJYF'
-
-
-if (iflag_wk_new_ptop==0) then
-    delta_t_min=delta_t_min_in
-else
-    delta_t_min=wk_delta_t_min
-endif
-
-    DO i = 1, klon
-        ptop_provis(i) = ph(i, 1)
-        k_ptop_provis(i) = 1
-    END DO
-
-    DO k = 2, klev
-      DO i = 1, klon
-        IF (wk_adv(i) .AND. ptop_provis(i)==ph(i,1) .AND. &
-! LJYF changer :           dth(i,k)>=-delta_t_min .AND. dth(i,k-1)<-delta_t_min) THEN
-            dth(i,k)>-delta_t_min .AND. dth(i,k-1)<-delta_t_min) THEN
-          ptop_provis(i) = ((dth(i,k)+delta_t_min)*p(i,k-1) - &
-                            (dth(i,k-1)+delta_t_min)*p(i,k))/(dth(i,k)-dth(i,k-1))
-          k_ptop_provis(i) = k
-        END IF
-      END DO
-    END DO
-
-
-
-    ! -     2/ dth integral
-
-    DO i = 1, klon
-      IF (wk_adv(i)) THEN !!! nrlmd
-        sum_dth(i) = 0.
-        dthmin(i) = -delta_t_min
-        z(i) = 0.
-      END IF
-    END DO
-
-    DO k = 1, klev
-      DO i = 1, klon
-        IF (wk_adv(i)) THEN
-          dz(i) = -(amax1(ph(i,k+1),ptop_provis(i))-ph(i,k))/(rho(i,k)*RG)
-          IF (dz(i)>0) THEN
-            z(i) = z(i) + dz(i)
-            sum_dth(i) = sum_dth(i) + dth(i, k)*dz(i)
-            dthmin(i) = amin1(dthmin(i), dth(i,k))
-          END IF
-        END IF
-      END DO
-    END DO
-
-    ! -     3/ height of triangle with area= sum_dth and base = dthmin
-
-    DO i = 1, klon
-      IF (wk_adv(i)) THEN
-        hw_(i) = 2.*sum_dth(i)/amin1(dthmin(i), -0.5)
-        hw_(i) = amax1(hwmin, hw_(i))
-      END IF
-    END DO
-
-    ! -     4/ now, get Ptop
-
-    DO i = 1, klon
-      IF (wk_adv(i)) THEN !!! nrlmd
-        ktop(i) = 0
-        z(i) = 0.
-      END IF
-    END DO
-
-    DO k = 1, klev
-      DO i = 1, klon
-        IF (wk_adv(i)) THEN
-          dz(i) = amin1(-(ph(i,k+1)-ph(i,k))/(rho(i,k)*RG), hw_(i)-z(i))
-          IF (dz(i)>0) THEN
-            z(i) = z(i) + dz(i)
-            ptop(i) = ph(i, k) - rho(i, k)*RG*dz(i)
-            ktop(i) = k
-          END IF
-        END IF
-      END DO
-    END DO
-
-    ! 4.5/Correct ktop and ptop
-
-    DO i = 1, klon
-        ptop_new(i) = ptop(i)
-    END DO
-
-    DO k = klev, 2, -1
-      DO i = 1, klon
-        ! IM v3JYG; IF (k .GE. ktop(i)
-        IF (wk_adv(i) .AND. k<=ktop(i) .AND. ptop_new(i)==ptop(i) .AND. &
-! LJYF changer :           dth(i,k)>=-delta_t_min .AND. dth(i,k-1)<-delta_t_min) THEN
-            dth(i,k)>=-delta_t_min .AND. dth(i,k-1)<-delta_t_min) THEN
-          ptop_new(i) = ((dth(i,k)+delta_t_min)*p(i,k-1) - &
-                         (dth(i,k-1)+delta_t_min)*p(i,k))/(dth(i,k)-dth(i,k-1))
-        END IF
-      END DO
-    END DO
-
-
-    DO i = 1, klon
-        ptop(i) = ptop_new(i)
-    END DO
-
-    DO k = klev, 1, -1
-      DO i = 1, klon
-        IF (wk_adv(i)) THEN !!! nrlmd
-          IF (ph(i,k+1)<ptop(i)) ktop(i) = k
-        END IF
-      END DO
-    END DO
-  
-!  IF (prt_level>=10) THEN
-!    PRINT *, 'wake-3, ktop(igout), kupper(igout) ', ktop(igout), kupper(igout)
-!  ENDIF
-
-    ! -----------------------------------------------------------------------
-    ! nouveau calcul de hw et ptop
-    ! -----------------------------------------------------------------------
-!if (iflag_wk_new_ptop>0) then
-do i=1,klon
-   ptop1(i)=ph(i,1)
-   ktop1(i)=1
-   h_zzz(i)=0.
-enddo
-    
-IF (iflag_wk_new_ptop/=0) THEN
-    
-    int_dth(1:klon,1:klev+1)=0.
-    DO i = 1, klon
-       IF (wk_adv(i)) THEN 
-          int_dth(i,1) = 0.
-      END IF
-    END DO
-    
-    if (abs(iflag_wk_new_ptop) == 1 ) then
-        DO k = 2, klev+1
-           Do i = 1, klon
-              IF (wk_adv(i)) THEN
-                 if (k<=k_ptop_provis(i)) then
-                      ddd=dth(i,k-1)*(ph(i,k-1) - max(ptop_provis(i),ph(i,k)))
-                      !ddd=dth(i,k-1)*(ph(i,k-1) - ph(i,k))
-                 else
-                      ddd=0.
-                 endif             
-                 int_dth(i,k) = int_dth(i,k-1) + ddd
-              !ELSE
-              !   int_dth(i,k) = 0.
-              END IF
-           END DO
-        END DO
-    else
-        k_ptop_provis(:)=klev+1
-        dthmin(:)=dth(:,1)
-        ! calcul de l'int??grale de dT * dP jusqu'au dernier
-        ! niveau avec dT<0. (en s'assurant qu'on a bien un 
-        ! dT negatif plus bas)
-        DO k = 1, klev
-           DO i = 1, klon
-              dthmin(i)=min(dthmin(i),dth(i,k))
-              ddd=dth(i,k)*(ph(i,k)-ph(i,k+1))
-              if (dthmin(i)<0.) then
-                  if (k>=k_ptop_provis(i)) then
-                      ddd=0.
-                  else if (dth(i,k)>=0.) then
-                      ddd=0.
-                      k_ptop_provis(i)=k+1
-                  endif
-              endif
-              int_dth(i,k+1) = int_dth(i,k)+ ddd
-           ENDDO
-        ENDDO
-
-        DO i = 1, klon
-           if ( k_ptop_provis(i)==klev+1 .or. .not. wk_adv(i)) then
-                k_ptop_provis(i)=1
-           endif
-        ENDDO
-    endif ! (abs(iflag_wk_new_ptop) == 1 )
-   ! print*, 'xxx, int_dth', (k,int_dth(1,k),k=1,klev)
-   ! print*, 'xxx, k_ptop_provis', k_ptop_provis(1)
-   
-
- 
-    ! On se limite ?? des poches avec integrale dT * dp < -wk_int_delta_t_min
-    do i=1,klon
-          if (int_dth(i,k_ptop_provis(i)) > -wk_int_delta_t_min .or. k_ptop_provis(i)==1) then
-          !if (1==0) then
-             wk_active(i)=.false.
-             ptop(i)=ph(i,1)
-             ktop(i)=1
-             hw_(i)=0.
-          else
-             wk_active(i)=wk_adv(i)
-          endif
-    enddo
-
-    DO i=1,klon
-       IF (wk_active(i)) THEN
-        frac_int_dth(i)=wk_frac_int_delta_t*int_dth(i,k_ptop_provis(i))
-       ENDIF
-    ENDDO
-    DO k = 1,klev
-       DO i =1, klon
-!         print*,ipas,'yyy ',k,int_dth(i,k),frac_int_dth(i)
-          IF (wk_active(i)) THEN
-            IF (int_dth(i,k)>=frac_int_dth(i)) THEN
-              ktop1(i) = min(k, k_ptop_provis(i))
-              !ktop1(i) = k
-              !print*,ipas,'yyy ktop1= ',ktop1
-            ENDIF
-          ENDIF
-       END DO
-    END DO
-    !print*, 'LAMINE'
-    
-    DO i = 1, klon
-       IF (wk_active(i)) THEN
-           !print*, ipas,'xxx1, int_dth(i,ktop1(i)), frac_int_dth(i), int_dth(i,ktop1(i)+1) ',ktop1
-           ddd=int_dth(i,ktop1(i)+1)-int_dth(i,ktop1(i))
-           if (ddd==0.) then
-              omega(i)=0.
-           else
-              omega(i) = (frac_int_dth(i) - int_dth(i,ktop1(i)))/ddd
-           endif
-           !! print*,'OMEGA ',omega(i)
-       END IF
-    END DO
-    
-    !! print*, 'xxx'
-    DO i = 1, klon
-       IF (wk_active(i)) THEN
-      ! print*, 'xxx, int_dth(i,ktop1(i)), frac_int_dth(i), int_dth(i,ktop1(i)+1) ', &
-      !               int_dth(i,ktop1(i)), frac_int_dth(i), int_dth(i,ktop1(i)+1)
-      ! print*, 'xxx, omega(i), ph(i,ktop1(i)), ph(i,ktop1(i)+1) ',  &
-      !e               omega(i), ph(i,ktop1(i)), ph(i,ktop1(i)+1)
-          ptop1(i) = min((1 - omega(i))*ph(i,ktop1(i)) + omega(i)*ph(i,ktop1(i)+1), ph(i,1))
-      END IF
-    END DO
-    
-    DO i=1, klon
-       IF (wk_active(i)) THEN 
-           zzz(i, 1) = 0
-       END IF
-     END DO
-    DO k = 1, klev
-       DO i = 1, klon 
-           IF (wk_active(i)) THEN         
-              dzz(i,k) = (ph(i,k) - ph(i,k+1))/(rho(i,k)*RG)
-              zzz(i,k+1) = zzz(i,k) + dzz(i,k)
-           END IF
-       END DO
-    END DO
-    
-    DO i =1, klon
-       IF (wk_active(i)) THEN
-           h_zzz(i) = max((1- omega(i))*zzz(i,ktop1(i)) + omega(i)*zzz(i,ktop1(i)+1), hwmin)
-       END IF
-    END DO
-
-
-ENDIF ! (iflag_wk_new_ptop/=0)
-
-!if (iflag_wk_new_ptop==2) then
-IF (iflag_wk_new_ptop>0) THEN 
-   do i=1,klon
-      ptop(i)=ptop1(i)
-      ktop(i)=ktop1(i)
-      hw_(i)=h_zzz(i)
-   enddo
-
-!endif
-ENDIF
-
- kupper = 0
- 
-IF (wk_pupper<1.) THEN
- ! Choose an integration bound well above wake top
-  ! -----------------------------------------------------------------
-
-  ! Pupper = 50000.  ! melting level
-  ! Pupper = 60000.
-  ! Pupper = 80000.  ! essais pour case_e
-  DO i = 1, klon
-  !  pupper(i) = 0.6*ph(i, 1)
-    pupper(i) = wk_pupper*ph(i, 1)
-    pupper(i) = max(pupper(i), 45000.)
-    ! cc        Pupper(i) = 60000.
-  END DO
-
-ELSE
-  DO i=1, klon
-     ! pupper(i) = wk_pupper*ptop(i)+(1.-wk_pupper)*ph(i, 1) 
-     !  pupper(i) = min( wk_pupper*ptop(i)+(1.-wk_pupper)*ph(i, 1) , ptop(i)-50.) 
-      pupper(i) = min( wk_pupper*ptop(i)+(1.-wk_pupper)*ph(i, 1) , ptop(i)-5000.) 
-  END DO
-END IF
- 
-  ! -5/ Determination de kupper
-
-  DO k = klev, 1, -1
-    DO i = 1, klon
-      IF (ph(i,k+1)<pupper(i)) kupper(i) = k
-    END DO
-  END DO
-
-  ! On evite kupper = 1 et kupper = klev
-  DO i = 1, klon
-    kupper(i) = max(kupper(i), 2)
-    kupper(i) = min(kupper(i), klev-1)
-  END DO 
-  !---------- FIN nouveau calcul hw et ptop -------------------------------------
-
-IF (iflag_wk_new_ptop==999) THEN
-    DO i = 1, klon
-    hw_(i)=0.
-    ptop(i)=ph(i,1)
-    Ktop(i)=1
-    pupper(i)=ph(i,2)
-    kupper(i)=2
-    h_zzz(i)=0.
-    Ptop1(i)=ph(i,1)
-    ENDDO
-ENDIF
-
-zk_ptop_provis=k_ptop_provis
-
-    RETURN
-END SUBROUTINE pkupper
-
-
-SUBROUTINE wake_popdyn_1(klon, klev, dtime, cstar, tau_wk_inv, wgen, wdens, awdens, sigmaw, &
-                  wdensmin, &
-                  dtimesub, gfl, rad_wk, f_shear, drdt_pos, &
-                  d_awdens, d_wdens, d_sigmaw, &
-                  iflag_wk_act, wk_adv, cin, wape, &
-                  drdt, &
-                  d_dens_gen, d_dens_death, d_dens_col, d_dens_bnd, &
-                  d_sig_gen, d_sig_death, d_sig_col, d_sig_spread, d_sig_bnd, &
-                  d_wdens_targ, d_sigmaw_targ)
-                
-
-  USE lmdz_wake_ini , ONLY : wake_ini
-  USE lmdz_wake_ini , ONLY : prt_level,RG
-  USE lmdz_wake_ini , ONLY : stark, wdens_ref
-  USE lmdz_wake_ini , ONLY : tau_cv, rzero, aa0
-!!  USE lmdz_wake_ini , ONLY : iflag_wk_pop_dyn, wdensmin
-  USE lmdz_wake_ini , ONLY : iflag_wk_pop_dyn
-  USE lmdz_wake_ini , ONLY : sigmad, cstart, sigmaw_max
-  
-IMPLICIT NONE
-
-  INTEGER, INTENT(IN)                                   :: klon,klev
-  LOGICAL, DIMENSION (klon),        INTENT(IN)          :: wk_adv
-  REAL,                             INTENT(IN)          :: dtime
-  REAL,                             INTENT(IN)          :: dtimesub
-  REAL,                             INTENT(IN)          :: wdensmin
-  REAL, DIMENSION (klon),           INTENT(IN)          :: wgen
-  REAL, DIMENSION (klon),           INTENT(IN)          :: wdens
-  REAL, DIMENSION (klon),           INTENT(IN)          :: awdens
-  REAL, DIMENSION (klon),           INTENT(IN)          :: sigmaw
-  REAL, DIMENSION (klon),           INTENT(IN)          :: cstar
-  REAL, DIMENSION (klon),           INTENT(IN)          :: cin, wape
-  REAL, DIMENSION (klon),           INTENT(IN)          :: f_shear
-  INTEGER,                          INTENT(IN)          :: iflag_wk_act
-
-  
-  !
- 
-  ! Tendencies of state variables (2 is appended to the names of fields which are the cumul of fields 
-  !                                 computed at each sub-timestep; e.g. d_wdens2 is the cumul of d_wdens)
-  REAL, DIMENSION (klon),           INTENT(OUT)         :: rad_wk
-  REAL, DIMENSION (klon),           INTENT(OUT)         :: gfl
-  REAL, DIMENSION (klon),           INTENT(OUT)         :: d_sigmaw, d_awdens, d_wdens
-  REAL, DIMENSION (klon),           INTENT(OUT)         :: drdt
-  ! Some components of the tendencies of state variables  
-  REAL, DIMENSION (klon),           INTENT(OUT)         :: d_sig_gen, d_sig_death, d_sig_col, d_sig_bnd
-  REAL, DIMENSION (klon),           INTENT(OUT)         :: d_sig_spread
-  REAL, DIMENSION (klon),           INTENT(OUT)         :: d_dens_gen, d_dens_death, d_dens_col, d_dens_bnd
-  REAL,                             INTENT(OUT)         :: d_wdens_targ, d_sigmaw_targ
- 
-  
-  REAL                                                  :: delta_t_min
-  INTEGER                                               :: i, k
-  REAL                                                  :: wdens0
-  ! IM 080208
-  LOGICAL, DIMENSION (klon)                             :: gwake
-  
-   ! Variables liees a la dynamique de population
-  REAL, DIMENSION(klon)                                 :: act
-  REAL, DIMENSION(klon)                                 :: tau_wk_inv
-  REAL, DIMENSION(klon)                                 :: wape1_act, wape2_act
-  LOGICAL, DIMENSION (klon)                             :: kill_wake
-  REAL                                                  :: drdt_pos
-  REAL                                                  :: tau_wk_inv_min
-  
-     
-
-      IF (iflag_wk_act == 0) THEN
-        act(:) = 0.
-      ELSEIF (iflag_wk_act == 1) THEN
-        act(:) = 1.
-      ELSEIF (iflag_wk_act ==2) THEN
-      DO i = 1, klon
-        IF (wk_adv(i)) THEN
-          wape1_act(i) = abs(cin(i))
-          wape2_act(i) = 2.*wape1_act(i) + 1.
-          act(i) = min(1., max(0., (wape(i)-wape1_act(i)) / (wape2_act(i)-wape1_act(i)) ))
-        ENDIF  ! (wk_adv(i))
-      ENDDO
-      ENDIF  ! (iflag_wk_act ==2)
-
-      DO i = 1, klon
-        IF (wk_adv(i)) THEN
-          rad_wk(i) = max( sqrt(sigmaw(i)/(3.14*wdens(i))) , rzero)
-          gfl(i)  = 2.*sqrt(3.14*wdens(i)*sigmaw(i))
-        END IF
-      END DO
-
-      DO i = 1, klon
-        IF (wk_adv(i)) THEN
-!!          tau_wk(i) = max(rad_wk(i)/(3.*cstar(i))*((cstar(i)/cstart)**1.5 - 1), 100.)
-          tau_wk_inv(i) = max( (3.*cstar(i))/(rad_wk(i)*((cstar(i)/cstart)**1.5 - 1)), 0.)
-          tau_wk_inv_min = min(tau_wk_inv(i), 1./dtimesub)
-          drdt(i) = (cstar(i) - wgen(i)*(sigmaw(i)/wdens(i)-aa0)/gfl(i)) / &
-                    (1 + 2*f_shear(i)*(2.*sigmaw(i)-aa0*wdens(i)) - 2.*sigmaw(i))
-!!                    (1 - 2*sigmaw(i)*(1.-f_shear(i)))
-          drdt_pos=max(drdt(i),0.)
-
-!!          d_wdens(i) = ( wgen(i)*(1.+2.*(sigmaw(i)-sigmad)) &
-!!                     - wdens(i)*tau_wk_inv_min &
-!!                     - 2.*gfl(i)*wdens(i)*Cstar(i) )*dtimesub
-!jyg+mlt<
-          d_awdens(i) = ( wgen(i) - (1./tau_cv)*(awdens(i) - act(i)*wdens(i)) )*dtimesub
-          d_dens_gen(i) = wgen(i)
-          d_dens_death(i) = - (wdens(i)-awdens(i))*tau_wk_inv_min 
-          d_dens_col(i) =  -2.*wdens(i)*gfl(i)*drdt_pos 
-          d_dens_gen(i) =  d_dens_gen(i)*dtimesub
-          d_dens_death(i) = d_dens_death(i)*dtimesub
-          d_dens_col(i) =  d_dens_col(i)*dtimesub 
-
-          d_wdens(i) = d_dens_gen(i)+d_dens_death(i)+d_dens_col(i)
-!!          d_wdens(i) = ( wgen(i) - (wdens(i)-awdens(i))*tau_wk_inv_min -  &
-!!                         2.*wdens(i)*gfl(i)*drdt_pos )*dtimesub
-!>jyg+mlt
-!
-!jyg<
-          d_wdens_targ = max(d_wdens(i), wdensmin-wdens(i))
-!!          d_dens_bnd(i) = d_dens_bnd(i) + d_wdens_targ - d_wdens(i)
-          d_dens_bnd(i) = d_wdens_targ - d_wdens(i)
-          d_wdens(i) = d_wdens_targ
-!!          d_wdens(i) = max(d_wdens(i), wdensmin-wdens(i))
-!>jyg
-
-!jyg+mlt<
-!!          d_sigmaw(i) = ( (1.-2*f_shear(i)*sigmaw(i))*(gfl(i)*Cstar(i)+wgen(i)*sigmad/wdens(i)) &
-!!                      + 2.*f_shear(i)*wgen(i)*sigmaw(i)**2/wdens(i) &
-!!                      - sigmaw(i)*tau_wk_inv_min )*dtimesub
-          d_sig_gen(i) = wgen(i)*aa0
-          d_sig_death(i) = - sigmaw(i)*(1.-awdens(i)/wdens(i))*tau_wk_inv_min
-!!        
-          
-          d_sig_col(i) = - 2*f_shear(i)*sigmaw(i)*gfl(i)*drdt_pos
-          d_sig_col(i) = - 2*f_shear(i)*(2.*sigmaw(i)-wdens(i)*aa0)*gfl(i)*drdt_pos
-          d_sig_spread(i) = gfl(i)*cstar(i)
-          d_sig_gen(i) =  d_sig_gen(i)*dtimesub
-          d_sig_death(i) = d_sig_death(i)*dtimesub
-          d_sig_col(i) =  d_sig_col(i)*dtimesub 
-          d_sig_spread(i) =  d_sig_spread(i)*dtimesub 
-          d_sigmaw(i) =  d_sig_gen(i) + d_sig_death(i) + d_sig_col(i) + d_sig_spread(i)
-!>jyg+mlt
-!
-!jyg<
-          d_sigmaw_targ = max(d_sigmaw(i), sigmad-sigmaw(i))
-!!          d_sig_bnd(i) = d_sig_bnd(i) + d_sigmaw_targ - d_sigmaw(i)
-!!          d_sig_bnd_provis(i) = d_sigmaw_targ - d_sigmaw(i)
-          d_sig_bnd(i) = d_sigmaw_targ - d_sigmaw(i)
-          d_sigmaw(i) = d_sigmaw_targ
-!!          d_sigmaw(i) = max(d_sigmaw(i), sigmad-sigmaw(i))
-!>jyg
-        ENDIF
-      ENDDO
-
-      IF (prt_level >= 10) THEN
-        print *,'wake, cstar(1), cstar(1)/cstart, rad_wk(1), tau_wk_inv(1), drdt(1) ', &
-                       cstar(1), cstar(1)/cstart, rad_wk(1), tau_wk_inv(1), drdt(1)
-        print *,'wake, wdens(1), awdens(1), act(1), d_awdens(1) ', &
-                       wdens(1), awdens(1), act(1), d_awdens(1)
-        print *,'wake, wgen, -(wdens-awdens)*tau_wk_inv, -2.*wdens*gfl*drdt_pos, d_wdens ', &
-                       wgen(1), -(wdens(1)-awdens(1))*tau_wk_inv(1), -2.*wdens(1)*gfl(1)*drdt_pos, d_wdens(1)
-        print *,'wake, d_sig_gen(1), d_sig_death(1), d_sig_col(1), d_sigmaw(1) ', &
-                       d_sig_gen(1), d_sig_death(1), d_sig_col(1), d_sigmaw(1)
-      ENDIF
-    
-    RETURN 
-    END SUBROUTINE wake_popdyn_1
-    
-    SUBROUTINE wake_popdyn_2 ( klon, klev, wk_adv, dtimesub, wgen, &
-                             wdensmin, &
-                             sigmaw, wdens, awdens, &   !! states variables
-                             gfl, cstar, cin, wape, rad_wk, &
-                             d_sigmaw, d_wdens, d_awdens, &  !! tendences 
-                             cont_fact, &
-                             d_sig_gen, d_sig_death, d_sig_col, d_sig_spread, d_sig_bnd, &
-                             d_dens_gen, d_dens_death, d_dens_col, d_dens_bnd, &
-                             d_adens_death, d_adens_icol, d_adens_acol, d_adens_bnd )
-                             
-                                             
-
-  USE lmdz_wake_ini , ONLY : wake_ini
-  USE lmdz_wake_ini , ONLY : prt_level,RG
-  USE lmdz_wake_ini , ONLY : stark, wdens_ref
-  USE lmdz_wake_ini , ONLY : tau_cv, rzero, aa0
-!!  USE lmdz_wake_ini , ONLY : iflag_wk_pop_dyn, wdensmin
-  USE lmdz_wake_ini , ONLY : iflag_wk_pop_dyn
-  USE lmdz_wake_ini , ONLY : sigmad, cstart, sigmaw_max
-  
-IMPLICIT NONE
-
-  INTEGER, INTENT(IN)                                   :: klon,klev
-  LOGICAL, DIMENSION (klon),        INTENT(IN)          :: wk_adv
-  REAL,                             INTENT(IN)          :: dtimesub
-  REAL,                             INTENT(IN)          :: wdensmin
-  REAL, DIMENSION (klon),           INTENT(IN)          :: wgen      !! B = birth rate of wakes
-  REAL, DIMENSION (klon),           INTENT(INOUT)       :: sigmaw    !! sigma = fractional area of wakes 
-  REAL, DIMENSION (klon),           INTENT(INOUT)       :: wdens     !! D = number of wakes per unit area 
-  REAL, DIMENSION (klon),           INTENT(INOUT)       :: awdens    !! A = number of active wakes per unit area
-  REAL, DIMENSION (klon),           INTENT(IN)          :: cstar     !! C* = spreading velocity of wakes
-  REAL, DIMENSION (klon),           INTENT(IN)          :: cin, wape  ! RM : A Faire disparaitre
-
-!  
-  REAL, DIMENSION (klon),           INTENT(OUT)         :: rad_wk    !! r = wake radius
-  REAL, DIMENSION (klon),           INTENT(OUT)         :: gfl       !! Lg = gust front lenght per unit area
-  REAL, DIMENSION (klon),           INTENT(OUT)         :: d_sigmaw, d_wdens, d_awdens
-  REAL, DIMENSION (klon),           INTENT(OUT)         :: cont_fact  !! RM facteur de contact = 2 pi * rad * C*
-  ! Some components of the tendencies of state variables  
-  REAL, DIMENSION (klon),           INTENT(OUT)         :: d_sig_gen, d_sig_death, d_sig_col, d_sig_spread, d_sig_bnd
-  REAL, DIMENSION (klon),           INTENT(OUT)         :: d_dens_gen, d_dens_death, d_dens_col, d_dens_bnd
-  REAL, DIMENSION (klon),           INTENT(OUT)         :: d_adens_death, d_adens_icol, d_adens_acol, d_adens_bnd
-
-
-!! internal variables
-  
-  INTEGER                                               :: i, k
-  REAL, DIMENSION (klon)                                :: tau_wk_inv      !! tau = life time of wakes
-  REAL                                                  :: tau_wk_inv_min
-  REAL, DIMENSION (klon)                                :: tau_prime       !! tau_prime = life time of actives wakes
-  REAL                                                  :: d_wdens_targ, d_sigmaw_targ
-  
-
-!! Equations
-!! dD/dt = B - (D-A)/tau - f D^2
-!! dA/dt = B - A/tau_prime + f (D-A)^2 - f A^2
-!! dsigma/dt = B a0 - sigma/D (D-A)/tau + Lg C* - f (D-A)^2 (sigma/D-a0)
-!!
-!! f = 2 (B (a0-sigma/D) + Lg C*) / (2 (D-A)^2 (2 sigma/D-a0) + D (1-2 sigma))
-
-
-      DO i = 1, klon
-        IF (wk_adv(i)) THEN
-          rad_wk(i) = max( sqrt(sigmaw(i)/(3.14*wdens(i))) , rzero)
-          gfl(i)  = 2.*sqrt(3.14*wdens(i)*sigmaw(i))
-        END IF
-      END DO
-
-
-      DO i = 1, klon
-        IF (wk_adv(i)) THEN
-!!          tau_wk(i) = max(rad_wk(i)/(3.*cstar(i))*((cstar(i)/cstart)**1.5 - 1), 100.)
-          tau_wk_inv(i) = max( (3.*cstar(i))/(rad_wk(i)*((cstar(i)/cstart)**1.5 - 1)), 0.)
-          tau_wk_inv_min = min(tau_wk_inv(i), 1./dtimesub)
-          tau_prime(i) = tau_cv
-!!          cont_fact(i) = 2.*(wgen(i)*(aa0-sigmaw(i)/wdens(i)) + gfl(i)*cstar(i)) / &
-!!                             (2.*(wdens(i)-awdens(i))**2*(2.*sigmaw(i)/wdens(i) - aa0) + wdens(i)*(1.-2.*sigmaw(i)))
-!!          cont_fact(i) = 2.*3.14*rad_wk(i)*cstar(i)     ! bug
-!!          cont_fact(i) = 4.*3.14*rad_wk(i)*cstar(i)
-          cont_fact(i) = 2.*gfl(i)*cstar(i)/wdens(i)
-
-          d_sig_gen(i) = wgen(i)*aa0
-          d_sig_death(i) = - sigmaw(i)*(1.-awdens(i)/wdens(i))*tau_wk_inv_min
-          d_sig_col(i) = - cont_fact(i)*(wdens(i)-awdens(i))**2*(2.*sigmaw(i)/wdens(i)-aa0)
-          d_sig_spread(i) = gfl(i)*cstar(i)
-!
-          d_sig_gen(i) =  d_sig_gen(i)*dtimesub
-          d_sig_death(i) = d_sig_death(i)*dtimesub
-          d_sig_col(i) =  d_sig_col(i)*dtimesub 
-          d_sig_spread(i) =  d_sig_spread(i)*dtimesub 
-          d_sigmaw(i) =  d_sig_gen(i) + d_sig_death(i) + d_sig_col(i) + d_sig_spread(i)
-
-         
-          d_sigmaw_targ = max(d_sigmaw(i), sigmad-sigmaw(i))
-!!          d_sig_bnd(i) = d_sig_bnd(i) + d_sigmaw_targ - d_sigmaw(i)
-!!          d_sig_bnd_provis(i) = d_sigmaw_targ - d_sigmaw(i)
-          d_sig_bnd(i) = d_sigmaw_targ - d_sigmaw(i)
-          d_sigmaw(i) = d_sigmaw_targ
-!!          d_sigmaw(i) = max(d_sigmaw(i), sigmad-sigmaw(i))
-         
-         
-          d_dens_gen(i) = wgen(i)
-          d_dens_death(i) = - (wdens(i)-awdens(i))*tau_wk_inv_min 
-          d_dens_col(i) =  - cont_fact(i)*wdens(i)**2
-! 
-          d_dens_gen(i) =  d_dens_gen(i)*dtimesub
-          d_dens_death(i) = d_dens_death(i)*dtimesub
-          d_dens_col(i) =  d_dens_col(i)*dtimesub 
-          d_wdens(i) = d_dens_gen(i) + d_dens_death(i) + d_dens_col(i)
-
-
-          d_adens_death(i) = -awdens(i)/tau_prime(i)
-          d_adens_icol(i) = cont_fact(i)*(wdens(i)-awdens(i))**2
-          d_adens_acol(i) = - cont_fact(i)*awdens(i)**2
-!
-          d_adens_death(i) =  d_adens_death(i)*dtimesub
-          d_adens_icol(i) =   d_adens_icol(i)*dtimesub
-          d_adens_acol(i) =   d_adens_acol(i)*dtimesub
-          d_awdens(i) =   d_dens_gen(i) + d_adens_death(i) + d_adens_icol(i) + d_adens_acol(i)     
-            
-!!
-          d_wdens_targ = max(d_wdens(i), wdensmin-wdens(i))
-!!          d_dens_bnd(i) = d_dens_bnd(i) + d_wdens_targ - d_wdens(i)
-          d_dens_bnd(i) = d_wdens_targ - d_wdens(i)
-          d_wdens(i) = d_wdens_targ
-          
-          d_wdens_targ = min(max(d_awdens(i),-awdens(i)), wdens(i)-awdens(i))
-!!          d_dens_bnd(i) = d_dens_bnd(i) + d_wdens_targ - d_wdens(i)
-          d_adens_bnd(i) = d_wdens_targ - d_awdens(i)
-          d_awdens(i) = d_wdens_targ
-
-
-
-        ENDIF
-      ENDDO
-
-      IF (prt_level >= 10) THEN
-        print *,'wake, cstar(1), cstar(1)/cstart, rad_wk(1), tau_wk_inv(1), cont_fact(1) ', &
-                       cstar(1), cstar(1)/cstart, rad_wk(1), tau_wk_inv(1), cont_fact(1)
-        print *,'wake, wdens(1), awdens(1), d_awdens(1) ', &
-                       wdens(1), awdens(1), d_awdens(1)
-        print *,'wake, d_sig_gen(1), d_sig_death(1), d_sig_col(1), d_sigmaw(1) ', &
-                       d_sig_gen(1), d_sig_death(1), d_sig_col(1), d_sigmaw(1)
-      ENDIF
-sigmaw=sigmaw+d_sigmaw
-wdens=wdens+d_wdens
-awdens=awdens+d_awdens
-
-    RETURN 
-    END SUBROUTINE wake_popdyn_2  
-  
-    SUBROUTINE wake_popdyn_3 ( klon, klev, phys_sub, wk_adv, dtimesub, wgen, &
-                             wdensmin, &
-                             sigmaw, asigmaw, wdens, awdens, &                       !! state variables
-                             gfl, agfl, cstar, cin, wape, &
-                             rad_wk, arad_wk, irad_wk, &
-                             d_sigmaw, d_asigmaw, d_wdens, d_awdens, &               !! tendencies 
-                             d_sig_gen, d_sig_death, d_sig_col, d_sig_spread, d_sig_bnd, &
-                             d_asig_death, d_asig_aicol, d_asig_iicol, d_asig_spread, d_asig_bnd, &
-                             d_dens_gen, d_dens_death, d_dens_col, d_dens_bnd, &
-                             d_adens_death, d_adens_icol, d_adens_acol, d_adens_bnd )
-                             
-                                             
-
-  USE lmdz_wake_ini , ONLY : wake_ini
-  USE lmdz_wake_ini , ONLY : prt_level,RG
-  USE lmdz_wake_ini , ONLY : stark, wdens_ref
-  USE lmdz_wake_ini , ONLY : tau_cv, rzero, aa0
-!!  USE lmdz_wake_ini , ONLY : iflag_wk_pop_dyn, wdensmin
-  USE lmdz_wake_ini , ONLY : iflag_wk_pop_dyn
-  USE lmdz_wake_ini , ONLY : sigmad, cstart, sigmaw_max
-  USE lmdz_wake_ini , ONLY : smallestreal
-  
-IMPLICIT NONE
-
-  INTEGER, INTENT(IN)                                   :: klon,klev
-  LOGICAL,                          INTENT(IN)          :: phys_sub 
-  LOGICAL, DIMENSION (klon),        INTENT(IN)          :: wk_adv
-  REAL,                             INTENT(IN)          :: dtimesub
-  REAL,                             INTENT(IN)          :: wdensmin
-  REAL, DIMENSION (klon),           INTENT(IN)          :: wgen      !! B = birth rate of wakes
-  REAL, DIMENSION (klon),           INTENT(INOUT)       :: sigmaw    !! sigma = fractional area of wakes 
-  REAL, DIMENSION (klon),           INTENT(INOUT)       :: asigmaw   !! sigma = fractional area of active wakes 
-  REAL, DIMENSION (klon),           INTENT(INOUT)       :: wdens     !! D = number of wakes per unit area 
-  REAL, DIMENSION (klon),           INTENT(INOUT)       :: awdens    !! A = number of active wakes per unit area
-  REAL, DIMENSION (klon),           INTENT(IN)          :: cstar     !! C* = spreading velocity of wakes
-  REAL, DIMENSION (klon),           INTENT(IN)          :: cin, wape  ! RM : A Faire disparaitre
-
-!  
-  REAL, DIMENSION (klon),           INTENT(OUT)         :: rad_wk    !! r = mean wake radius
-  REAL, DIMENSION (klon),           INTENT(OUT)         :: arad_wk    !! r_A = wake radius of active wakes
-  REAL, DIMENSION (klon),           INTENT(OUT)         :: irad_wk    !! r_I = wake radius of inactive wakes
-  REAL, DIMENSION (klon),           INTENT(OUT)         :: gfl       !! Lg = gust front length per unit area
-  REAL, DIMENSION (klon),           INTENT(OUT)         :: agfl      !! LgA = gust front length of active wakes
-                                                                     !!  per unit area
-  REAL, DIMENSION (klon),           INTENT(OUT)         :: d_sigmaw, d_asigmaw, d_wdens, d_awdens
-  ! Some components of the tendencies of state variables  
-  REAL, DIMENSION (klon),           INTENT(OUT)         :: d_sig_gen, d_sig_death, d_sig_col, d_sig_spread, d_sig_bnd
-  REAL, DIMENSION (klon),           INTENT(OUT)         :: d_asig_death, d_asig_aicol, d_asig_iicol, d_asig_spread, d_asig_bnd
-  REAL, DIMENSION (klon),           INTENT(OUT)         :: d_dens_gen, d_dens_death, d_dens_col, d_dens_bnd
-  REAL, DIMENSION (klon),           INTENT(OUT)         :: d_adens_death, d_adens_acol, d_adens_icol, d_adens_bnd
-
-
-!! internal variables
-  
-  INTEGER                                               :: i, k
-  REAL, DIMENSION (klon)                                :: iwdens, isigmaw !! inactive wake density and fractional area
-!!  REAL, DIMENSION (klon)                                :: d_arad, d_irad
-  REAL, DIMENSION (klon)                                :: igfl            !! LgI = gust front length of inactive wakes
-                                                                           !!  per unit area
-  REAL, DIMENSION (klon)                                :: s_wk            !! mean area of individual wakes
-  REAL, DIMENSION (klon)                                :: as_wk           !! mean area of individual active wakes
-  REAL, DIMENSION (klon)                                :: is_wk           !! mean area of individual inactive wakes
-  REAL, DIMENSION (klon)                                :: tau_wk_inv      !! tau = life time of wakes
-  REAL                                                  :: tau_wk_inv_min
-  REAL, DIMENSION (klon)                                :: tau_prime       !! tau_prime = life time of actives wakes
-  REAL                                                  :: d_wdens_targ, d_sigmaw_targ
-
-
-!! Equations
-!! ---------
-!! Gust fronts:
-!! Lg_A = 2 pi r_A A
-!! Lg_I = 2 pi r_I I
-!! Lg   = 2 pi r   D
-!!
-!! Areas:
-!! s = pi r^2
-!! s_A = pi r_A^2
-!! s_I = pi r_I^2
-!!
-!! Life expectancy:
-!! tau_I = 3 C* ((C*/C*t)^3/2 - 1) / r_I
-!!
-!! Time deratives:
-!! dD/dt = B - (D-A)/tau_I - 2 Lg C* D
-!! dA/dt = B - A/tau_A     + 2 Lg_I C* (D-A) - 2 Lg_A C* A
-!! dsigma/dt = B a0 - sigma_I/tau_I + Lg C* - 2 Lg_I C* (D-A) (2 s_I - a0)
-!! dsigma_A/dt = B a0 - sigma_A/tau_A + Lg_A C* + (Lg_A I + Lg_I A) C* s_I + 2 Lg_I C* I a0
-!!
-
-      DO i = 1, klon
-        IF (wk_adv(i)) THEN
-         iwdens(i) = wdens(i) - awdens(i)
-         isigmaw(i) = sigmaw(i) - asigmaw(i)
-!
-         arad_wk(i) = max( sqrt(asigmaw(i)/(3.14*awdens(i))) , rzero)
-         irad_wk(i) = max( sqrt((sigmaw(i)-asigmaw(i))/  &
-                           (3.14*max(smallestreal,(wdens(i)-awdens(i))))), rzero)
-         rad_wk(i) = (awdens(i)*arad_wk(i)+(wdens(i)-awdens(i))*irad_wk(i))/wdens(i)
-!
-         s_wk(i) = 3.14*rad_wk(i)**2
-         as_wk(i) = 3.14*arad_wk(i)**2
-         is_wk(i) = 3.14*irad_wk(i)**2
-!
-         gfl(i)  = 2.*sqrt(3.14*wdens(i)*sigmaw(i))
-         agfl(i) = 2.*sqrt(3.14*awdens(i)*asigmaw(i))
-         igfl(i) = gfl(i) - agfl(i)
-        ENDIF
-      ENDDO
-
-
-      DO i = 1, klon
-        IF (wk_adv(i)) THEN
-          tau_wk_inv(i) = max( (3.*cstar(i))/(irad_wk(i)*((cstar(i)/cstart)**1.5 - 1)), 0.)
-          tau_wk_inv_min = min(tau_wk_inv(i), 1./dtimesub)
-          tau_prime(i) = tau_cv
-
-          d_sig_gen(i) = wgen(i)*aa0
-          d_sig_death(i) = - isigmaw(i)*tau_wk_inv_min
-          d_sig_col(i) = - 2.*igfl(i)*cstar(i)*iwdens(i)*(2.*is_wk(i)-aa0)
-          d_sig_spread(i) = gfl(i)*cstar(i)
-!
-          d_sig_gen(i) =  d_sig_gen(i)*dtimesub
-          d_sig_death(i) = d_sig_death(i)*dtimesub
-          d_sig_col(i) =  d_sig_col(i)*dtimesub 
-          d_sig_spread(i) =  d_sig_spread(i)*dtimesub 
-          d_sigmaw(i) =  d_sig_gen(i) + d_sig_death(i) + d_sig_col(i) + d_sig_spread(i)
-IF (CPPKEY_IOPHYS_WK) THEN
-          IF (phys_sub) call iophys_ecrit('d_sigmaw0',1,'d_sigmaw0','',d_sigmaw)
-END IF
-
-         
-          d_sigmaw_targ = max(d_sigmaw(i), sigmad-sigmaw(i))
-!!          d_sig_bnd(i) = d_sig_bnd(i) + d_sigmaw_targ - d_sigmaw(i)
-!!          d_sig_bnd_provis(i) = d_sigmaw_targ - d_sigmaw(i)
-          d_sig_bnd(i) = d_sigmaw_targ - d_sigmaw(i)
-          d_sigmaw(i) = d_sigmaw_targ
-!!          d_sigmaw(i) = max(d_sigmaw(i), sigmad-sigmaw(i))
-IF (CPPKEY_IOPHYS_WK) THEN
-          IF (phys_sub) THEN
-             call iophys_ecrit('tauwk_inv',1,'tau_wk_inv_min','',tau_wk_inv_min)
-             call iophys_ecrit('d_sigmaw',1,'d_sigmaw','',d_sigmaw)
-             call iophys_ecrit('d_sig_gen',1,'d_sig_gen','',d_sig_gen)
-             call iophys_ecrit('d_sig_death',1,'d_sig_death','',d_sig_death)
-             call iophys_ecrit('d_sig_col',1,'d_sig_col','',d_sig_col)
-             call iophys_ecrit('d_sig_spread',1,'d_sig_spread','',d_sig_spread)
-             call iophys_ecrit('d_sig_bnd',1,'d_sig_bnd','',d_sig_bnd)
-          ENDIF
-END IF
-          d_asig_death(i) = - asigmaw(i)/tau_prime(i)
-          d_asig_aicol(i) = (agfl(i)*iwdens(i) + igfl(i)*awdens(i))*cstar(i)*is_wk(i)
-          d_asig_iicol(i) = 2.*igfl(i)*cstar(i)*iwdens(i)*aa0
-          d_asig_spread(i) = agfl(i)*cstar(i)
-!
-          d_asig_death(i) = d_asig_death(i)*dtimesub
-          d_asig_aicol(i) =  d_asig_aicol(i)*dtimesub 
-          d_asig_iicol(i) =  d_asig_iicol(i)*dtimesub 
-          d_asig_spread(i) =  d_asig_spread(i)*dtimesub 
-          d_asigmaw(i) =  d_sig_gen(i) + d_asig_death(i) + d_asig_aicol(i) + d_asig_iicol(i) + d_asig_spread(i)
-IF (CPPKEY_IOPHYS_WK) THEN
-          IF (phys_sub) call iophys_ecrit('d_asigmaw0',1,'d_asigmaw0','',d_asigmaw)
-END IF
-
-          d_sigmaw_targ = min(max(d_asigmaw(i),-asigmaw(i)), sigmaw(i)-asigmaw(i))
-!!          d_dens_bnd(i) = d_dens_bnd(i) + d_sigmaw_targ - d_sigmaw(i)
-          d_asig_bnd(i) = d_sigmaw_targ - d_asigmaw(i)
-          d_asigmaw(i) = d_sigmaw_targ
-IF (CPPKEY_IOPHYS_WK) THEN
-          IF (phys_sub) THEN
-             call iophys_ecrit('d_asigmaw',1,'d_asigmaw','',d_asigmaw)
-             call iophys_ecrit('d_asig_death',1,'d_asig_death','',d_asig_death)
-             call iophys_ecrit('d_asig_aicol',1,'d_asig_aicol','',d_asig_aicol)
-             call iophys_ecrit('d_asig_iicol',1,'d_asig_iicol','',d_asig_iicol)
-             call iophys_ecrit('d_asig_spread',1,'d_asig_spread','',d_asig_spread)
-             call iophys_ecrit('d_asig_bnd',1,'d_asig_bnd','',d_asig_bnd)
-          ENDIF
-END IF
-          d_dens_gen(i) = wgen(i)
-          d_dens_death(i) = - iwdens(i)*tau_wk_inv_min 
-          d_dens_col(i) =  - 2.*gfl(i)*cstar(i)*wdens(i)
-! 
-          d_dens_gen(i) =  d_dens_gen(i)*dtimesub
-          d_dens_death(i) = d_dens_death(i)*dtimesub
-          d_dens_col(i) =  d_dens_col(i)*dtimesub 
-          d_wdens(i) = d_dens_gen(i) + d_dens_death(i) + d_dens_col(i)
-!!
-          d_wdens_targ = max(d_wdens(i), wdensmin-wdens(i))
-!!          d_dens_bnd(i) = d_dens_bnd(i) + d_wdens_targ - d_wdens(i)
-          d_dens_bnd(i) = d_wdens_targ - d_wdens(i)
-          d_wdens(i) = d_wdens_targ
-IF (CPPKEY_IOPHYS_WK) THEN
-    IF (phys_sub) THEN 
-        call iophys_ecrit('d_wdens',1,'d_wdens','',d_wdens)
-        call iophys_ecrit('d_dens_gen',1,'d_dens_gen','',d_dens_gen)
-        call iophys_ecrit('d_dens_death',1,'d_dens_death','',d_dens_death)
-        call iophys_ecrit('d_dens_col',1,'d_dens_col','',d_dens_col)
-    ENDIF
-END IF
-
-          d_adens_death(i) = -awdens(i)/tau_prime(i)
-          d_adens_icol(i) =   2.*igfl(i)*cstar(i)*iwdens(i)
-          d_adens_acol(i)  = - 2.*agfl(i)*cstar(i)*awdens(i)
-!
-          d_adens_death(i) =  d_adens_death(i)*dtimesub
-          d_adens_icol(i) =   d_adens_icol(i)*dtimesub
-          d_adens_acol(i)  =   d_adens_acol(i)*dtimesub
-          d_awdens(i) =   d_dens_gen(i) + d_adens_death(i) + d_adens_icol(i) + d_adens_acol(i)     
-IF (CPPKEY_IOPHYS_WK) THEN
-    IF (phys_sub) THEN 
-        call iophys_ecrit('d_awdens',1,'d_awdens','',d_awdens)
-        call iophys_ecrit('d_adens_death',1,'d_adens_death','',d_adens_death)
-        call iophys_ecrit('d_adens_icol',1,'d_adens_icol','',d_adens_icol)
-        call iophys_ecrit('d_adens_acol',1,'d_adens_acol','',d_adens_acol)
-    ENDIF
-END IF
-          d_wdens_targ = min(max(d_awdens(i),-awdens(i)), wdens(i)-awdens(i))
-!!          d_dens_bnd(i) = d_dens_bnd(i) + d_wdens_targ - d_wdens(i)
-          d_adens_bnd(i) = d_wdens_targ - d_awdens(i)
-          d_awdens(i) = d_wdens_targ
-
-!!          d_irad(i) = (d_sigmaw(i)-d_asigmaw(i)-isigmaw(i)*(d_wdens(i)-awdens(i))/iwdens(i)) / &
-!!                      max(smallestreal,(2.*3.14*iwdens(i)*irad_wk(i)))
-!!          d_arad(i) = (d_asigmaw(i)-asigmaw(i)*d_awdens(i)/awdens(i)) / &
-!!                      max(smallestreal,(2.*3.14*awdens(i)*arad_wk(i)))
-!!          d_irad(i) = d_irad(i)*dtimesub
-!!          d_arad(i) = d_arad(i)*dtimesub
-!!          call iophys_ecrit('d_irad',1,'d_irad','m',d_irad)
-!!          call iophys_ecrit('d_airad',1,'d_arad','m',d_arad)
-!!
-        ENDIF
-      ENDDO
-
-      IF (prt_level >= 10) THEN
-        print *,'wake, cstar(1), cstar(1)/cstart, rad_wk(1), tau_wk_inv(1), gfl(1) ', &
-                       cstar(1), cstar(1)/cstart, rad_wk(1), tau_wk_inv(1), gfl(1)
-        print *,'wake, wdens(1), awdens(1), d_awdens(1) ', &
-                       wdens(1), awdens(1), d_awdens(1)
-        print *,'wake, d_sig_gen(1), d_sig_death(1), d_sig_col(1), d_sigmaw(1) ', &
-                       d_sig_gen(1), d_sig_death(1), d_sig_col(1), d_sigmaw(1)
-      ENDIF
-sigmaw=sigmaw+d_sigmaw
-asigmaw=asigmaw+d_asigmaw
-wdens=wdens+d_wdens
-awdens=awdens+d_awdens
-
-    RETURN 
-    END SUBROUTINE wake_popdyn_3  
-
-END MODULE lmdz_wake
Index: /LMDZ6/trunk/libf/phylmd/lmdz_wake.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/lmdz_wake.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/lmdz_wake.f90	(revision 5268)
@@ -0,0 +1,3379 @@
+MODULE lmdz_wake
+
+  USE lmdz_wake_ini, ONLY: CPPKEY_IOPHYS_WK
+
+  IMPLICIT NONE; PRIVATE
+  PUBLIC wake
+
+CONTAINS
+
+SUBROUTINE wake(klon,klev,znatsurf, p, ph, pi, dtime, &
+                tb0, qb0, omgb, &
+                dtdwn, dqdwn, amdwn, amup, dta, dqa, wgen, &
+                sigd_con, Cin, &
+                deltatw, deltaqw, sigmaw, asigmaw, wdens, awdens, &                  ! state variables           
+                dth, hw, wape, fip, gfl, &
+                dtls, dqls, ktopw, omgbdth, dp_omgb, tx, qx, &
+                dtke, dqke, omg, dp_deltomg, wkspread, cstar, &
+                d_deltat_gw, &                                                      ! tendencies
+                d_deltatw2, d_deltaqw2, d_sigmaw2, d_asigmaw2, d_wdens2, d_awdens2)             ! tendencies
+
+
+  ! **************************************************************
+  ! *
+  ! WAKE                                                        *
+  ! retour a un Pupper fixe                                *
+  ! *
+  ! written by   :  GRANDPEIX Jean-Yves   09/03/2000            *
+  ! modified by :   ROEHRIG Romain        01/29/2007            *
+  ! **************************************************************
+
+
+  USE lmdz_wake_ini , ONLY : wake_ini
+  USE lmdz_wake_ini , ONLY : prt_level,epsim1,RG,RD
+  USE lmdz_wake_ini , ONLY : stark, wdens_ref, coefgw, alpk, wk_pupper
+  USE lmdz_wake_ini , ONLY : crep_upper, crep_sol, tau_cv, rzero, aa0, flag_wk_check_trgl
+  USE lmdz_wake_ini , ONLY : ok_bug_gfl
+  USE lmdz_wake_ini , ONLY : iflag_wk_act, iflag_wk_check_trgl, iflag_wk_pop_dyn, wdensinit, wdensthreshold
+  USE lmdz_wake_ini , ONLY : sigmad, hwmin, wapecut, cstart, sigmaw_max, dens_rate, epsilon_loc
+  USE lmdz_wake_ini , ONLY : iflag_wk_profile
+  USE lmdz_wake_ini , ONLY : smallestreal,wk_nsub
+
+
+  IMPLICIT NONE
+  ! ============================================================================
+
+
+  ! But : Decrire le comportement des poches froides apparaissant dans les
+  ! grands systemes convectifs, et fournir l'energie disponible pour
+  ! le declenchement de nouvelles colonnes convectives.
+
+  ! State variables : 
+  ! deltatw    : temperature difference between wake and off-wake regions
+  ! deltaqw    : specific humidity difference between wake and off-wake regions
+  ! sigmaw     : fractional area covered by wakes.
+  ! asigmaw    : fractional area covered by active wakes.
+  ! wdens      : number of wakes per unit area
+  ! awdens     : number of active wakes per unit area
+
+  ! Variable de sortie :
+
+  ! wape : WAke Potential Energy
+  ! fip  : Front Incident Power (W/m2) - ALP
+  ! gfl  : Gust Front Length per unit area (m-1)
+  ! dtls : large scale temperature tendency due to wake
+  ! dqls : large scale humidity tendency due to wake
+  ! hw   : wake top hight (given by hw*deltatw(1)/2=wape)
+  ! dp_omgb : vertical gradient of large scale omega
+  ! awdens  : densite de poches actives
+  ! wdens   : densite de poches
+  ! omgbdth: flux of Delta_Theta transported by LS omega
+  ! dtKE   : differential heating (wake - unpertubed)
+  ! dqKE   : differential moistening (wake - unpertubed)
+  ! omg    : Delta_omg =vertical velocity diff. wake-undist. (Pa/s)
+  ! dp_deltomg  : vertical gradient of omg (s-1)
+  ! wkspread  : spreading term in d_t_wake and d_q_wake
+  ! deltatw     : updated temperature difference (T_w-T_u).
+  ! deltaqw     : updated humidity difference (q_w-q_u).
+  ! sigmaw      : updated wake fractional area.
+  ! asigmaw     : updated active wake fractional area.
+  ! d_deltat_gw : delta T tendency due to GW
+
+  ! Variables d'entree :
+
+  ! aire : aire de la maille
+  ! tb0  : horizontal average of temperature  (K)
+  ! qb0  : horizontal average of humidity   (kg/kg)
+  ! omgb : vitesse verticale moyenne sur la maille (Pa/s)
+  ! dtdwn: source de chaleur due aux descentes (K/s)
+  ! dqdwn: source d'humidite due aux descentes (kg/kg/s)
+  ! dta  : source de chaleur due courants satures et detrain  (K/s)
+  ! dqa  : source d'humidite due aux courants satures et detra (kg/kg/s)
+  ! wgen : number of wakes generated per unit area and per sec (/m^2/s)
+  ! amdwn: flux de masse total des descentes, par unite de
+  !        surface de la maille (kg/m2/s)
+  ! amup : flux de masse total des ascendances, par unite de
+  !        surface de la maille (kg/m2/s)
+  ! sigd_con: 
+  ! Cin  : convective inhibition
+  ! p    : pressions aux milieux des couches (Pa)
+  ! ph   : pressions aux interfaces (Pa)
+  ! pi  : (p/p_0)**kapa (adim)
+  ! dtime: increment temporel (s)
+
+  ! Variables internes :
+
+  ! rho  : mean density at P levels
+  ! rhoh : mean density at Ph levels
+  ! tb   : mean temperature | may change within
+  ! qb   : mean humidity    | sub-time-stepping
+  ! thb  : mean potential temperature
+  ! thx  : potential temperature in (x) area
+  ! tx   : temperature  in (x) area
+  ! qx   : humidity in (x) area
+  ! dp_omgb: vertical gradient og LS omega
+  ! omgbw  : wake average vertical omega
+  ! dp_omgbw: vertical gradient of omgbw
+  ! omgbdq : flux of Delta_q transported by LS omega
+  ! dth  : potential temperature diff. wake-undist.
+  ! th1  : first pot. temp. for vertical advection (=thx)
+  ! th2  : second pot. temp. for vertical advection (=thw)
+  ! q1   : first humidity for vertical advection
+  ! q2   : second humidity for vertical advection
+  ! d_deltatw   : redistribution term for deltatw
+  ! d_deltaqw   : redistribution term for deltaqw
+  ! deltatw0   : initial deltatw 
+  ! deltaqw0   : initial deltaqw 
+  ! hw0    : wake top hight (defined as the altitude at which deltatw=0)
+  ! amflux : horizontal mass flux through wake boundary
+  ! wdens_ref: initial number of wakes per unit area (3D) or per
+  !            unit length (2D), at the beginning of each time step
+  ! Tgw    : 1 sur la periode de onde de gravite
+  ! Cgw    : vitesse de propagation de onde de gravite
+  ! LL     : distance between 2 wakes
+
+  ! -------------------------------------------------------------------------
+  ! Declaration de variables
+  ! -------------------------------------------------------------------------
+
+
+  ! Arguments en entree
+  ! --------------------
+
+  INTEGER, INTENT(IN) :: klon,klev
+  INTEGER, DIMENSION (klon),        INTENT(IN)          :: znatsurf
+  REAL, DIMENSION (klon, klev),     INTENT(IN)          :: p, pi
+  REAL, DIMENSION (klon, klev+1),   INTENT(IN)          :: ph
+  REAL, DIMENSION (klon, klev),     INTENT(IN)          :: omgb
+  REAL,                             INTENT(IN)          :: dtime
+  REAL, DIMENSION (klon, klev),     INTENT(IN)          :: tb0, qb0
+  REAL, DIMENSION (klon, klev),     INTENT(IN)          :: dtdwn, dqdwn
+  REAL, DIMENSION (klon, klev),     INTENT(IN)          :: amdwn, amup
+  REAL, DIMENSION (klon, klev),     INTENT(IN)          :: dta, dqa
+  REAL, DIMENSION (klon),           INTENT(IN)          :: wgen
+  REAL, DIMENSION (klon),           INTENT(IN)          :: sigd_con
+  REAL, DIMENSION (klon),           INTENT(IN)          :: Cin
+
+  !
+  ! Input/Output
+  ! State variables
+  REAL, DIMENSION (klon, klev),     INTENT(INOUT)       :: deltatw, deltaqw
+  REAL, DIMENSION (klon),           INTENT(INOUT)       :: sigmaw
+  REAL, DIMENSION (klon),           INTENT(INOUT)       :: asigmaw
+  REAL, DIMENSION (klon),           INTENT(INOUT)       :: wdens
+  REAL, DIMENSION (klon),           INTENT(INOUT)       :: awdens
+
+  ! Sorties
+  ! --------
+
+  REAL, DIMENSION (klon, klev),     INTENT(OUT)         :: dth
+  REAL, DIMENSION (klon, klev),     INTENT(OUT)         :: tx, qx
+  REAL, DIMENSION (klon, klev),     INTENT(OUT)         :: dtls, dqls
+  REAL, DIMENSION (klon, klev),     INTENT(OUT)         :: dtke, dqke
+  REAL, DIMENSION (klon, klev),     INTENT(OUT)         :: wkspread    !  unused (jyg)
+  REAL, DIMENSION (klon, klev),     INTENT(OUT)         :: omgbdth, omg
+  REAL, DIMENSION (klon, klev),     INTENT(OUT)         :: dp_omgb, dp_deltomg
+  REAL, DIMENSION (klon),           INTENT(OUT)         :: hw, wape, fip, gfl, cstar
+  INTEGER, DIMENSION (klon),        INTENT(OUT)         :: ktopw
+  ! Tendencies of state variables (2 is appended to the names of fields which are the cumul of fields 
+  !                                 computed at each sub-timestep; e.g. d_wdens2 is the cumul of d_wdens)
+  REAL, DIMENSION (klon, klev),     INTENT(OUT)         :: d_deltat_gw
+  REAL, DIMENSION (klon, klev),     INTENT(OUT)         :: d_deltatw2, d_deltaqw2
+  REAL, DIMENSION (klon),           INTENT(OUT)         :: d_sigmaw2, d_asigmaw2, d_wdens2, d_awdens2
+
+  ! Variables internes
+  ! -------------------
+
+  ! Variables a fixer
+
+  REAL                                                  :: delta_t_min
+  REAL                                                  :: dtimesub
+  REAL                                                  :: wdens0
+  ! IM 080208
+  LOGICAL, DIMENSION (klon)                             :: gwake
+
+  ! Variables de sauvegarde
+  REAL, DIMENSION (klon, klev)                          :: deltatw0
+  REAL, DIMENSION (klon, klev)                          :: deltaqw0
+  REAL, DIMENSION (klon, klev)                          :: tb, qb
+
+  ! Variables liees a la dynamique de population 1
+  REAL, DIMENSION(klon)                                 :: act
+  REAL, DIMENSION(klon)                                 :: rad_wk, tau_wk_inv
+  REAL, DIMENSION(klon)                                 :: f_shear
+  REAL, DIMENSION(klon)                                 :: drdt
+  
+  ! Variables liees a la dynamique de population 2
+  REAL, DIMENSION(klon)                                 :: cont_fact  
+  
+  ! Variables liees a la dynamique de population 3
+  REAL, DIMENSION(klon)                                 :: arad_wk, irad_wk
+  
+!!  REAL, DIMENSION(klon)                                 :: d_sig_gen, d_sig_death, d_sig_col
+  REAL, DIMENSION(klon)                                 :: wape1_act, wape2_act
+  LOGICAL, DIMENSION (klon)                             :: kill_wake
+  REAL                                                  :: drdt_pos
+  REAL                                                  :: tau_wk_inv_min
+  ! Some components of the tendencies of state variables  
+  REAL, DIMENSION (klon)                                :: d_sig_gen2, d_sig_death2, d_sig_col2, d_sig_spread2, d_sig_bnd2
+  REAL, DIMENSION (klon)                                :: d_asig_death2, d_asig_aicol2, d_asig_iicol2, d_asig_spread2, d_asig_bnd2
+  REAL, DIMENSION (klon)                                :: d_dens_gen2, d_dens_death2, d_dens_col2, d_dens_bnd2
+  REAL, DIMENSION (klon)                                :: d_adens_death2, d_adens_icol2, d_adens_acol2, d_adens_bnd2
+
+  ! Variables pour les GW
+  REAL, DIMENSION (klon)                                :: ll
+  REAL, DIMENSION (klon, klev)                          :: n2
+  REAL, DIMENSION (klon, klev)                          :: cgw
+  REAL, DIMENSION (klon, klev)                          :: tgw
+
+  ! Variables liees au calcul de hw
+  REAL, DIMENSION (klon)                                :: ptop
+  REAL, DIMENSION (klon)                                :: sum_dth
+  REAL, DIMENSION (klon)                                :: dthmin
+  REAL, DIMENSION (klon)                                :: z, dz, hw0
+  INTEGER, DIMENSION (klon)                             :: ktop, kupper
+
+  ! Variables liees au test de la forme triangulaire du profil de Delta_theta
+  REAL, DIMENSION (klon)                                :: sum_half_dth
+  REAL, DIMENSION (klon)                                :: dz_half
+
+  ! Sub-timestep tendencies and related variables
+  REAL, DIMENSION (klon, klev)                          :: d_deltatw, d_deltaqw
+  REAL, DIMENSION (klon, klev)                          :: d_tb, d_qb
+  REAL, DIMENSION (klon)                                :: d_wdens, d_awdens, d_sigmaw, d_asigmaw 
+  REAL, DIMENSION (klon)                                :: d_sig_gen, d_sig_death, d_sig_col, d_sig_spread, d_sig_bnd
+  REAL, DIMENSION (klon)                                :: d_asig_death, d_asig_aicol, d_asig_iicol, d_asig_spread, d_asig_bnd
+  REAL, DIMENSION (klon)                                :: d_dens_gen, d_dens_death, d_dens_col, d_dens_bnd
+  REAL, DIMENSION (klon)                                :: d_adens_death, d_adens_icol, d_adens_acol, d_adens_bnd
+  REAL, DIMENSION (klon)                                :: agfl              !! gust front length of active wakes
+                                                                             !!  per unit area
+  REAL, DIMENSION (klon)                                :: alpha, alpha_tot
+  REAL, DIMENSION (klon)                                :: q0_min, q1_min
+  LOGICAL, DIMENSION (klon)                             :: wk_adv, ok_qx_qw
+
+  ! Autres variables internes
+  INTEGER                                               ::isubstep, k, i, igout
+
+  REAL                                                  :: wdensmin
+
+  REAL                                                  :: sigmaw_targ
+  REAL                                                  :: wdens_targ
+  REAL                                                  :: d_sigmaw_targ
+  REAL                                                  :: d_wdens_targ
+
+  REAL, DIMENSION (klon)                                :: sum_thx, sum_tx, sum_qx, sum_thvx
+  REAL, DIMENSION (klon)                                :: sum_dq
+  REAL, DIMENSION (klon)                                :: sum_dtdwn, sum_dqdwn
+  REAL, DIMENSION (klon)                                :: av_thx, av_tx, av_qx, av_thvx
+  REAL, DIMENSION (klon)                                :: av_dth, av_dq
+  REAL, DIMENSION (klon)                                :: av_dtdwn, av_dqdwn
+
+  REAL, DIMENSION (klon, klev)                          :: rho
+  REAL, DIMENSION (klon, klev+1)                        :: rhoh
+  REAL, DIMENSION (klon, klev)                          :: zh
+  REAL, DIMENSION (klon, klev+1)                        :: zhh
+
+  REAL, DIMENSION (klon, klev)                          :: thb, thx
+
+  REAL, DIMENSION (klon, klev)                          :: omgbw
+  REAL, DIMENSION (klon)                                :: pupper
+  REAL, DIMENSION (klon)                                :: omgtop
+  REAL, DIMENSION (klon, klev)                          :: dp_omgbw
+  REAL, DIMENSION (klon)                                :: ztop, dztop
+  REAL, DIMENSION (klon, klev)                          :: alpha_up
+
+  REAL, DIMENSION (klon)                                :: rre1, rre2
+  REAL                                                  :: rrd1, rrd2
+  REAL, DIMENSION (klon, klev)                          :: th1, th2, q1, q2
+  REAL, DIMENSION (klon, klev)                          :: d_th1, d_th2, d_dth
+  REAL, DIMENSION (klon, klev)                          :: d_q1, d_q2, d_dq
+  REAL, DIMENSION (klon, klev)                          :: omgbdq
+
+  REAL, DIMENSION (klon)                                :: ff, gg
+  REAL, DIMENSION (klon)                                :: wape2, cstar2, heff
+                                                        
+  REAL, DIMENSION (klon, klev)                          :: crep
+                                                        
+  REAL, DIMENSION (klon, klev)                          :: ppi
+
+  ! cc nrlmd
+  REAL, DIMENSION (klon)                                :: death_rate
+!!  REAL, DIMENSION (klon)                                :: nat_rate
+  REAL, DIMENSION (klon, klev)                          :: entr
+  REAL, DIMENSION (klon, klev)                          :: detr
+
+  REAL, DIMENSION(klon)                                 :: sigmaw_in, asigmaw_in ! pour les prints
+  REAL, DIMENSION(klon)                                 :: wdens_in, awdens_in   ! pour les prints
+
+!!!  LOGICAL                                               :: phys_sub=.true.
+  LOGICAL                                               :: phys_sub=.false.
+
+  LOGICAL                                               :: first_call=.true.
+
+
+  !!-- variables liees au nouveau calcul de ptop et hw
+  REAL, DIMENSION (klon, klev)                          :: int_dth
+  REAL, DIMENSION (klon, klev)                          :: zzz, dzzz
+  REAL                                                  :: epsil
+  REAL, DIMENSION (klon)                                :: ptop1
+  INTEGER, DIMENSION (klon)                             :: ktop1
+  REAL, DIMENSION (klon)                                :: omega
+  REAL, DIMENSION (klon)                                :: h_zzz
+
+!print*,'WAKE LJYFz'
+
+  ! -------------------------------------------------------------------------
+  ! Initialisations
+  ! -------------------------------------------------------------------------
+  ! ALON = 3.e5
+  ! alon = 1.E6
+
+  !  Provisionnal; to be suppressed when f_shear is parameterized
+  f_shear(:) = 1.       ! 0. for strong shear, 1. for weak shear
+
+  ! Configuration de coefgw,stark,wdens (22/02/06 by YU Jingmei)
+
+  ! coefgw : Coefficient pour les ondes de gravite
+  ! stark : Coefficient k dans Cstar=k*sqrt(2*WAPE)
+  ! wdens : Densite surfacique de poche froide
+  ! -------------------------------------------------------------------------
+
+  ! cc nrlmd      coefgw=10
+  ! coefgw=1
+  ! wdens0 = 1.0/(alon**2)
+  ! cc nrlmd      wdens = 1.0/(alon**2)
+  ! cc nrlmd      stark = 0.50
+  ! CRtest
+  ! cc nrlmd      alpk=0.1
+  ! alpk = 1.0
+  ! alpk = 0.5
+  ! alpk = 0.05
+!
+ igout = klon/2+1/klon
+!
+!   sub-time-stepping parameters
+  dtimesub = dtime/wk_nsub
+!
+IF (first_call) THEN
+IF (CPPKEY_IOPHYS_WK) THEN
+  IF (phys_sub) THEN
+    call iophys_ini(dtimesub)
+  ELSE
+    call iophys_ini(dtime)
+  ENDIF
+END IF
+  first_call = .false.
+ENDIF   !(first_call)
+
+ IF (iflag_wk_pop_dyn == 0) THEN
+  ! Initialisation de toutes des densites a wdens_ref.
+  ! Les densites peuvent evoluer si les poches debordent
+  ! (voir au tout debut de la boucle sur les substeps)
+  !jyg<
+  !!  wdens(:) = wdens_ref
+   DO i = 1,klon
+     wdens(i) = wdens_ref(znatsurf(i)+1)
+   ENDDO 
+  !>jyg
+ ENDIF  ! (iflag_wk_pop_dyn == 0)
+!
+ IF (iflag_wk_pop_dyn >=1) THEN
+   IF (iflag_wk_pop_dyn == 3) THEN
+     wdensmin = wdensthreshold
+   ELSE
+     wdensmin = wdensinit
+   ENDIF
+ ENDIF
+
+  ! print*,'stark',stark
+  ! print*,'alpk',alpk
+  ! print*,'wdens',wdens
+  ! print*,'coefgw',coefgw
+  ! cc
+  ! Minimum value for |T_wake - T_undist|. Used for wake top definition
+  ! -------------------------------------------------------------------------
+
+   delta_t_min = 0.2
+
+  ! 1. - Save initial values, initialize tendencies, initialize output fields
+  ! ------------------------------------------------------------------------
+
+!jyg<
+!!  DO k = 1, klev
+!!    DO i = 1, klon
+!!      ppi(i, k) = pi(i, k)
+!!      deltatw0(i, k) = deltatw(i, k)
+!!      deltaqw0(i, k) = deltaqw(i, k)
+!!      tb(i, k) = tb0(i, k)
+!!      qb(i, k) = qb0(i, k)
+!!      dtls(i, k) = 0.
+!!      dqls(i, k) = 0.
+!!      d_deltat_gw(i, k) = 0.
+!!      d_tb(i, k) = 0.
+!!      d_qb(i, k) = 0.
+!!      d_deltatw(i, k) = 0.
+!!      d_deltaqw(i, k) = 0.
+!!      ! IM 060508 beg
+!!      d_deltatw2(i, k) = 0.
+!!      d_deltaqw2(i, k) = 0.
+!!      ! IM 060508 end
+!!    END DO
+!!  END DO
+      ppi(:,:) = pi(:,:)
+      deltatw0(:,:) = deltatw(:,:)
+      deltaqw0(:,:) = deltaqw(:,:)
+      tb(:,:) = tb0(:,:)
+      qb(:,:) = qb0(:,:)
+      dtls(:,:) = 0.
+      dqls(:,:) = 0.
+      d_deltat_gw(:,:) = 0.
+      d_tb(:,:) = 0.
+      d_qb(:,:) = 0.
+      d_deltatw(:,:) = 0.
+      d_deltaqw(:,:) = 0.
+      d_deltatw2(:,:) = 0.
+      d_deltaqw2(:,:) = 0.
+
+      d_sig_gen2(:)   = 0.
+      d_sig_death2(:) = 0.
+      d_sig_col2(:)   = 0.
+      d_sig_spread2(:)= 0.
+      d_asig_death2(:) = 0.
+      d_asig_iicol2(:) = 0.
+      d_asig_aicol2(:) = 0.
+      d_asig_spread2(:)= 0.
+      d_asig_bnd2(:) = 0.
+      d_asigmaw2(:) = 0.
+!
+      d_dens_gen2(:)   = 0.
+      d_dens_death2(:) = 0.
+      d_dens_col2(:)   = 0.
+      d_dens_bnd2(:) = 0.
+      d_wdens2(:) = 0.
+      d_adens_bnd2(:) = 0.
+      d_awdens2(:) = 0.
+      d_adens_death2(:) = 0.
+      d_adens_icol2(:) = 0.
+      d_adens_acol2(:) = 0.
+
+      IF (iflag_wk_act == 0) THEN
+        act(:) = 0.
+      ELSEIF (iflag_wk_act == 1) THEN
+        act(:) = 1.
+      ENDIF
+
+!!  DO i = 1, klon
+!!   sigmaw_in(i) = sigmaw(i)
+!!  END DO
+   sigmaw_in(:)  = sigmaw(:)
+   asigmaw_in(:) = asigmaw(:)
+!>jyg
+!
+  IF (iflag_wk_pop_dyn >= 1) THEN
+    awdens_in(:) = awdens(:)
+    wdens_in(:) = wdens(:)
+!!    wdens(:) = wdens(:) + wgen(:)*dtime
+!!    d_wdens2(:) = wgen(:)*dtime
+!!  ELSE
+  ENDIF  ! (iflag_wk_pop_dyn >= 1)
+
+
+  ! sigmaw1=sigmaw
+  ! IF (sigd_con.GT.sigmaw1) THEN
+  ! print*, 'sigmaw,sigd_con', sigmaw, sigd_con
+  ! ENDIF
+  IF (iflag_wk_pop_dyn >= 1) THEN
+    DO i = 1, klon
+      d_dens_gen2(i)   = 0.
+      d_dens_death2(i) = 0.
+      d_dens_col2(i)   = 0.
+      d_awdens2(i) = 0.
+      IF (wdens(i) < wdensthreshold) THEN
+  !!      wdens_targ = max(wdens(i),wdensmin)
+        wdens_targ = max(wdens(i),wdensinit)
+        d_dens_bnd2(i) = wdens_targ - wdens(i)
+        d_wdens2(i) = wdens_targ - wdens(i)
+        wdens(i) = wdens_targ
+      ELSE
+        d_dens_bnd2(i) = 0.
+        d_wdens2(i) = 0.
+      ENDIF  !! (wdens(i) < wdensthreshold)
+    END DO
+    IF (iflag_wk_pop_dyn >= 2) THEN
+      DO i = 1, klon  
+        IF (awdens(i) < wdensthreshold) THEN
+!!          wdens_targ = min(max(awdens(i),wdensmin),wdens(i))
+            wdens_targ = min(max(awdens(i),wdensinit),wdens(i))
+            d_adens_bnd2(i) = wdens_targ - awdens(i)
+            d_awdens2(i) = wdens_targ - awdens(i)
+            awdens(i) = wdens_targ
+        ELSE
+            wdens_targ = min(awdens(i), wdens(i))
+            d_adens_bnd2(i) = wdens_targ - awdens(i)
+            d_awdens2(i) = wdens_targ - awdens(i)
+            awdens(i) = wdens_targ
+        ENDIF
+      END DO
+    ENDIF ! (iflag_wk_pop_dyn >= 2)
+  ELSE  
+    DO i = 1, klon
+      d_awdens2(i) = 0.
+      d_wdens2(i) = 0.
+    END DO
+  ENDIF  ! (iflag_wk_pop_dyn >= 1)
+!
+  DO i = 1, klon
+    sigmaw_targ = min(max(sigmaw(i), sigmad),0.99)
+    d_sig_bnd2(i) = sigmaw_targ - sigmaw(i)
+    d_sigmaw2(i) = sigmaw_targ - sigmaw(i)
+    sigmaw(i) = sigmaw_targ
+  END DO
+!
+  IF (iflag_wk_pop_dyn == 3) THEN
+     DO i = 1, klon  
+        IF ((wdens(i)-awdens(i)) <= smallestreal) THEN
+          sigmaw_targ = sigmaw(i)
+        ELSE
+          sigmaw_targ = min(max(asigmaw(i),sigmad),sigmaw(i))
+        ENDIF
+        d_asig_bnd2(i) = sigmaw_targ - asigmaw(i)
+        d_asigmaw2(i) = sigmaw_targ - asigmaw(i)
+        asigmaw(i) = sigmaw_targ
+     END DO
+  ENDIF ! (iflag_wk_pop_dyn == 3)
+
+  wape(:) = 0.
+  wape2(:) = 0.
+  d_sigmaw(:) = 0.
+  d_asigmaw(:) = 0.
+  ktopw(:) = 0
+!
+!<jyg
+dth(:,:) = 0.
+tx(:,:) = 0.
+qx(:,:) = 0.
+dtke(:,:) = 0.
+dqke(:,:) = 0.
+wkspread(:,:) = 0.
+omgbdth(:,:) = 0.
+omg(:,:) = 0.
+dp_omgb(:,:) = 0.
+dp_deltomg(:,:) = 0.
+hw(:) = 0.
+wape(:) = 0.
+fip(:) = 0.
+gfl(:) = 0.
+cstar(:) = 0.
+ktopw(:) = 0
+!
+!  Vertical advection local variables
+omgbw(:,:) = 0.
+omgtop(:) = 0
+dp_omgbw(:,:) = 0.
+omgbdq(:,:) = 0.
+
+!>jyg
+!
+  IF (prt_level>=10) THEN
+    PRINT *, 'wake-1, sigmaw(igout) ', sigmaw(igout)
+    PRINT *, 'wake-1, deltatw(igout,k) ', (k,deltatw(igout,k), k=1,klev)
+    PRINT *, 'wake-1, deltaqw(igout,k) ', (k,deltaqw(igout,k), k=1,klev)
+    PRINT *, 'wake-1, dowwdraughts, amdwn(igout,k) ', (k,amdwn(igout,k), k=1,klev)
+    PRINT *, 'wake-1, dowwdraughts, dtdwn(igout,k) ', (k,dtdwn(igout,k), k=1,klev)
+    PRINT *, 'wake-1, dowwdraughts, dqdwn(igout,k) ', (k,dqdwn(igout,k), k=1,klev)
+    PRINT *, 'wake-1, updraughts, amup(igout,k) ', (k,amup(igout,k), k=1,klev)
+    PRINT *, 'wake-1, updraughts, dta(igout,k) ', (k,dta(igout,k), k=1,klev)
+    PRINT *, 'wake-1, updraughts, dqa(igout,k) ', (k,dqa(igout,k), k=1,klev)
+  ENDIF
+
+  ! 2. - Prognostic part
+  ! --------------------
+
+
+  ! 2.1 - Undisturbed area and Wake integrals
+  ! ---------------------------------------------------------
+
+  DO i = 1, klon
+    z(i) = 0.
+    ktop(i) = 0
+    kupper(i) = 0
+    sum_thx(i) = 0.
+    sum_tx(i) = 0.
+    sum_qx(i) = 0.
+    sum_thvx(i) = 0.
+    sum_dth(i) = 0.
+    sum_dq(i) = 0.
+    sum_dtdwn(i) = 0.
+    sum_dqdwn(i) = 0.
+
+    av_thx(i) = 0.
+    av_tx(i) = 0.
+    av_qx(i) = 0.
+    av_thvx(i) = 0.
+    av_dth(i) = 0.
+    av_dq(i) = 0.
+    av_dtdwn(i) = 0.
+    av_dqdwn(i) = 0.
+  END DO
+
+  ! Distance between wakes
+  DO i = 1, klon
+    ll(i) = (1-sqrt(sigmaw(i)))/sqrt(wdens(i))
+  END DO
+  ! Potential temperatures and humidity
+  ! ----------------------------------------------------------
+  DO k = 1, klev
+    DO i = 1, klon
+      ! write(*,*)'wake 1',i,k,RD,tb(i,k)
+      rho(i, k) = p(i, k)/(RD*tb(i,k))
+      ! write(*,*)'wake 2',rho(i,k)
+      IF (k==1) THEN
+        ! write(*,*)'wake 3',i,k,rd,tb(i,k)
+        rhoh(i, k) = ph(i, k)/(RD*tb(i,k))
+        ! write(*,*)'wake 4',i,k,rd,tb(i,k)
+        zhh(i, k) = 0
+      ELSE
+        ! write(*,*)'wake 5',rd,(tb(i,k)+tb(i,k-1))
+        rhoh(i, k) = ph(i, k)*2./(RD*(tb(i,k)+tb(i,k-1)))
+        ! write(*,*)'wake 6',(-rhoh(i,k)*RG)+zhh(i,k-1)
+        zhh(i, k) = (ph(i,k)-ph(i,k-1))/(-rhoh(i,k)*RG) + zhh(i, k-1)
+      END IF
+      ! write(*,*)'wake 7',ppi(i,k)
+      thb(i, k) = tb(i, k)/ppi(i, k)
+      thx(i, k) = (tb(i,k)-deltatw(i,k)*sigmaw(i))/ppi(i, k)
+      tx(i, k) = tb(i, k) - deltatw(i, k)*sigmaw(i)
+      qx(i, k) = qb(i, k) - deltaqw(i, k)*sigmaw(i)
+      ! write(*,*)'wake 8',(RD*(tb(i,k)+deltatw(i,k)))
+      dth(i, k) = deltatw(i, k)/ppi(i, k)
+    END DO
+  END DO
+
+  DO k = 1, klev - 1
+    DO i = 1, klon
+      IF (k==1) THEN
+        n2(i, k) = 0
+      ELSE
+        n2(i, k) = amax1(0., -RG**2/thb(i,k)*rho(i,k)*(thb(i,k+1)-thb(i,k-1))/ &
+                             (p(i,k+1)-p(i,k-1)))
+      END IF
+      zh(i, k) = (zhh(i,k)+zhh(i,k+1))/2
+
+      cgw(i, k) = sqrt(n2(i,k))*zh(i, k)
+      tgw(i, k) = coefgw*cgw(i, k)/ll(i)
+    END DO
+  END DO
+
+  DO i = 1, klon
+    n2(i, klev) = 0
+    zh(i, klev) = 0
+    cgw(i, klev) = 0
+    tgw(i, klev) = 0
+  END DO
+
+  
+  ! Choose an integration bound well above wake top
+  ! -----------------------------------------------------------------
+
+  ! Determine Wake top pressure (Ptop) from buoyancy integral
+  ! --------------------------------------------------------
+
+   Do i=1, klon
+       wk_adv(i) = .True.
+   Enddo
+   Call pkupper (klon, klev, ptop, ph, p, pupper, kupper, &
+                    dth, hw0, rho, delta_t_min, &
+                    ktop, wk_adv, h_zzz, ptop1, ktop1)
+ 
+   !!print'("pkupper APPEL ",7i6)',0,int(ptop/100.),int(ptop1/100.),int(pupper/100.),ktop,ktop1,kupper
+   
+   IF (prt_level>=10) THEN
+     PRINT *, 'wake-3, ktop(igout), kupper(igout) ', ktop(igout), kupper(igout)
+  ENDIF
+
+  ! -5/ Set deltatw & deltaqw to 0 above kupper
+
+  DO k = 1, klev
+    DO i = 1, klon
+      IF (k>=kupper(i)) THEN
+        deltatw(i, k) = 0.
+        deltaqw(i, k) = 0.
+        d_deltatw2(i,k) = -deltatw0(i,k)
+        d_deltaqw2(i,k) = -deltaqw0(i,k)
+      END IF
+    END DO
+  END DO
+
+
+  ! Vertical gradient of LS omega
+
+  DO k = 1, klev
+    DO i = 1, klon
+      IF (k<=kupper(i)) THEN
+        dp_omgb(i, k) = (omgb(i,k+1)-omgb(i,k))/(ph(i,k+1)-ph(i,k))
+      END IF
+    END DO
+  END DO
+
+  ! Integrals (and wake top level number)
+  ! --------------------------------------
+
+  ! Initialize sum_thvx to 1st level virt. pot. temp.
+
+  DO i = 1, klon
+    z(i) = 1.
+    dz(i) = 1.
+    sum_thvx(i) = thx(i, 1)*(1.+epsim1*qx(i,1))*dz(i)
+    sum_dth(i) = 0.
+  END DO
+
+  DO k = 1, klev
+    DO i = 1, klon
+      dz(i) = -(amax1(ph(i,k+1),ptop(i))-ph(i,k))/(rho(i,k)*RG)
+      IF (dz(i)>0) THEN
+              ! LJYF : ecriture pas sympa avec un tableau z(i) qui n'est pas utilise come tableau
+        z(i) = z(i) + dz(i)
+        sum_thx(i) = sum_thx(i) + thx(i, k)*dz(i)
+        sum_tx(i) = sum_tx(i) + tx(i, k)*dz(i)
+        sum_qx(i) = sum_qx(i) + qx(i, k)*dz(i)
+        sum_thvx(i) = sum_thvx(i) + thx(i, k)*(1.+epsim1*qx(i,k))*dz(i)
+        sum_dth(i) = sum_dth(i) + dth(i, k)*dz(i)
+        sum_dq(i) = sum_dq(i) + deltaqw(i, k)*dz(i)
+        sum_dtdwn(i) = sum_dtdwn(i) + dtdwn(i, k)*dz(i)
+        sum_dqdwn(i) = sum_dqdwn(i) + dqdwn(i, k)*dz(i)
+      END IF
+    END DO
+  END DO
+
+  DO i = 1, klon
+    hw0(i) = z(i)
+  END DO
+
+
+  ! 2.1 - WAPE and mean forcing computation
+  ! ---------------------------------------
+
+  ! ---------------------------------------
+
+  ! Means
+
+  DO i = 1, klon
+    av_thx(i) = sum_thx(i)/hw0(i)
+    av_tx(i) = sum_tx(i)/hw0(i)
+    av_qx(i) = sum_qx(i)/hw0(i)
+    av_thvx(i) = sum_thvx(i)/hw0(i)
+    ! av_thve = sum_thve/hw0
+    av_dth(i) = sum_dth(i)/hw0(i)
+    av_dq(i) = sum_dq(i)/hw0(i)
+    av_dtdwn(i) = sum_dtdwn(i)/hw0(i)
+    av_dqdwn(i) = sum_dqdwn(i)/hw0(i)
+
+    wape(i) = -RG*hw0(i)*(av_dth(i)+ &
+        epsim1*(av_thx(i)*av_dq(i)+av_dth(i)*av_qx(i)+av_dth(i)*av_dq(i)))/av_thvx(i)
+
+  END DO
+IF (CPPKEY_IOPHYS_WK) THEN
+  IF (.not.phys_sub) CALL iophys_ecrit('wape_a',1,'wape_a','J/kg',wape)
+END IF
+
+  ! 2.2 Prognostic variable update
+  ! ------------------------------
+
+  ! Filter out bad wakes
+
+  DO k = 1, klev
+    DO i = 1, klon
+      IF (wape(i)<0.) THEN
+        deltatw(i, k) = 0.
+        deltaqw(i, k) = 0.
+        dth(i, k) = 0.
+        d_deltatw2(i,k) = -deltatw0(i,k)
+        d_deltaqw2(i,k) = -deltaqw0(i,k)
+      END IF
+    END DO
+  END DO
+
+  DO i = 1, klon
+    IF (wape(i)<0.) THEN
+!!      sigmaw(i) = amax1(sigmad, sigd_con(i))
+      sigmaw_targ = max(sigmad, sigd_con(i))
+      d_sig_bnd2(i) = d_sig_bnd2(i) + sigmaw_targ - sigmaw(i)
+      d_sigmaw2(i) = d_sigmaw2(i) + sigmaw_targ - sigmaw(i)
+      sigmaw(i) = sigmaw_targ
+    ENDIF  !!  (wape(i)<0.)
+  ENDDO
+  !
+  IF (iflag_wk_pop_dyn == 3) THEN
+    DO i = 1, klon
+      IF (wape(i)<0.) THEN
+        sigmaw_targ = max(sigmad, sigd_con(i))
+        d_asig_bnd2(i) = d_asig_bnd2(i) + sigmaw_targ - asigmaw(i)
+        d_asigmaw2(i) = d_asigmaw2(i) + sigmaw_targ - asigmaw(i)
+        asigmaw(i) = sigmaw_targ
+      ENDIF  !!  (wape(i)<0.)
+    ENDDO
+  ENDIF  !!  (iflag_wk_pop_dyn == 3)
+
+  DO i = 1, klon
+    IF (wape(i)<0.) THEN
+      wape(i) = 0.
+      cstar(i) = 0.
+      hw(i) = hwmin
+      fip(i) = 0.
+      gwake(i) = .FALSE.
+    ELSE
+      hw(i) = hw0(i)
+      cstar(i) = stark*sqrt(2.*wape(i))
+      gwake(i) = .TRUE.
+    END IF
+  END DO
+  !
+
+  ! Check qx and qw positivity
+  ! --------------------------
+  DO i = 1, klon
+    q0_min(i) = min((qb(i,1)-sigmaw(i)*deltaqw(i,1)),  &
+                    (qb(i,1)+(1.-sigmaw(i))*deltaqw(i,1)))
+  END DO
+  DO k = 2, klev
+    DO i = 1, klon
+      q1_min(i) = min((qb(i,k)-sigmaw(i)*deltaqw(i,k)), &
+                      (qb(i,k)+(1.-sigmaw(i))*deltaqw(i,k)))
+      IF (q1_min(i)<=q0_min(i)) THEN
+        q0_min(i) = q1_min(i)
+      END IF
+    END DO
+  END DO
+
+  DO i = 1, klon
+    ok_qx_qw(i) = q0_min(i) >= 0.
+    alpha(i) = 1.
+    alpha_tot(i) = 1.
+  END DO
+
+  IF (prt_level>=10) THEN
+    PRINT *, 'wake-4, sigmaw(igout), cstar(igout), wape(igout), ktop(igout) ', &
+                      sigmaw(igout), cstar(igout), wape(igout), ktop(igout)
+  ENDIF
+
+
+  ! C -----------------------------------------------------------------
+  ! Sub-time-stepping
+  ! -----------------
+
+!    wk_nsub and dtimesub definitions moved to begining of routine.
+!!  wk_nsub = 10
+!!  dtimesub = dtime/wk_nsub
+
+  
+  ! ------------------------------------------------------------------------
+  ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+  ! ------------------------------------------------------------------------
+  !
+  DO isubstep = 1, wk_nsub
+  !
+  ! ------------------------------------------------------------------------
+    ! wk_adv is the logical flag enabling wake evolution in the time advance
+    ! loop
+    DO i = 1, klon
+      wk_adv(i) = ok_qx_qw(i) .AND. alpha(i) >= 1.
+    END DO
+    IF (prt_level>=10) THEN
+      PRINT *, 'wake-4.1, isubstep,wk_adv(igout),cstar(igout),wape(igout), ptop(igout) ', &
+                          isubstep,wk_adv(igout),cstar(igout),wape(igout), ptop(igout)
+     
+    ENDIF
+
+    ! cc nrlmd   Ajout d'un recalcul de wdens dans le cas d'un entrainement
+    ! negatif de ktop a kupper --------
+    ! cc           On calcule pour cela une densite wdens0 pour laquelle on
+    ! aurait un entrainement nul ---
+    !jyg<
+    ! Dans la configuration avec wdens prognostique, il s'agit d'un cas ou 
+    ! les poches sont insuffisantes pour accueillir tout le flux de masse 
+    ! des descentes unsaturees. Nous faisons alors l'hypothese que la 
+    ! convection profonde cree directement de nouvelles poches, sans passer 
+    ! par les thermiques. La nouvelle valeur de wdens est alors imposee.
+
+    DO i = 1, klon
+      ! c       print *,' isubstep,wk_adv(i),cstar(i),wape(i) ',
+      ! c     $           isubstep,wk_adv(i),cstar(i),wape(i)
+      IF (wk_adv(i) .AND. cstar(i)>0.01) THEN
+        IF ( iflag_wk_profile == 0 ) THEN
+           omg(i, kupper(i)+1)=-RG*amdwn(i, kupper(i)+1)/sigmaw(i) + &
+                               RG*amup(i, kupper(i)+1)/(1.-sigmaw(i))
+        ELSE
+           omg(i, kupper(i)+1)=0.
+        ENDIF
+        wdens0 = (sigmaw(i)/(4.*3.14))* &
+          ((1.-sigmaw(i))*omg(i,kupper(i)+1)/((ph(i,1)-pupper(i))*cstar(i)))**(2)
+        IF (prt_level >= 10) THEN
+             print*,'omg(i,kupper(i)+1),wdens0,wdens(i),cstar(i), ph(i,1)-pupper(i)', &
+                     omg(i,kupper(i)+1),wdens0,wdens(i),cstar(i), ph(i,1)-pupper(i)
+        ENDIF
+        IF (wdens(i)<=wdens0*1.1) THEN
+          IF (iflag_wk_pop_dyn >= 1) THEN
+             d_dens_bnd2(i) = d_dens_bnd2(i) + wdens0 - wdens(i)
+             d_wdens2(i) = d_wdens2(i) + wdens0 - wdens(i)
+          ENDIF
+          wdens(i) = wdens0
+        END IF
+      END IF
+    END DO
+
+    IF (iflag_wk_pop_dyn == 0 .AND. ok_bug_gfl) THEN
+!!--------------------------------------------------------
+!!Bug : computing gfl and rad_wk before changing sigmaw
+!!      This bug exists only for iflag_wk_pop_dyn=0. Otherwise, gfl and rad_wk 
+!!      are computed within  wake_popdyn
+!!--------------------------------------------------------
+      DO i = 1, klon
+        IF (wk_adv(i)) THEN
+          gfl(i) = 2.*sqrt(3.14*wdens(i)*sigmaw(i))
+          rad_wk(i) = sqrt(sigmaw(i)/(3.14*wdens(i)))
+        END IF
+      END DO
+    ENDIF   ! (iflag_wk_pop_dyn == 0 .AND. ok_bug_gfl)
+!!--------------------------------------------------------
+
+    DO i = 1, klon
+      IF (wk_adv(i)) THEN
+        sigmaw_targ = min(sigmaw(i), sigmaw_max)
+        d_sig_bnd2(i) = d_sig_bnd2(i) + sigmaw_targ - sigmaw(i)
+        d_sigmaw2(i)  = d_sigmaw2(i)  + sigmaw_targ - sigmaw(i)
+        sigmaw(i) = sigmaw_targ
+      END IF
+    END DO
+
+    IF (iflag_wk_pop_dyn == 0 .AND. .NOT.ok_bug_gfl) THEN
+!!--------------------------------------------------------
+!!Fix : computing gfl and rad_wk after changing sigmaw
+!!--------------------------------------------------------
+      DO i = 1, klon
+        IF (wk_adv(i)) THEN
+          gfl(i) = 2.*sqrt(3.14*wdens(i)*sigmaw(i))
+          rad_wk(i) = sqrt(sigmaw(i)/(3.14*wdens(i)))
+        END IF
+      END DO
+    ENDIF   ! (iflag_wk_pop_dyn == 0 .AND. .NOT.ok_bug_gfl)
+!!--------------------------------------------------------
+
+    IF (iflag_wk_pop_dyn >= 1) THEN
+  !  The variable "death_rate" is significant only when iflag_wk_pop_dyn = 0.
+  !  Here, it has to be set to zero.
+      death_rate(:) = 0.
+    ENDIF
+  
+    IF (iflag_wk_pop_dyn >= 3) THEN
+      DO i = 1, klon
+        IF (wk_adv(i)) THEN
+         sigmaw_targ = min(asigmaw(i), sigmaw_max)
+         d_asig_bnd2(i) = d_asig_bnd2(i) + sigmaw_targ - asigmaw(i)
+         d_asigmaw2(i)  = d_asigmaw2(i)  + sigmaw_targ - asigmaw(i)
+         asigmaw(i) = sigmaw_targ
+        ENDIF
+      ENDDO
+    ENDIF
+  
+!!--------------------------------------------------------
+!!--------------------------------------------------------
+    IF (iflag_wk_pop_dyn == 1) THEN
+  !
+     CALL wake_popdyn_1 (klon, klev, dtime, cstar, tau_wk_inv, wgen, wdens, awdens, sigmaw, &
+                  wdensmin, &
+                  dtimesub, gfl, rad_wk, f_shear, drdt_pos, &
+                  d_awdens, d_wdens, d_sigmaw, &
+                  iflag_wk_act, wk_adv, cin, wape, &
+                  drdt, &
+                  d_dens_gen, d_dens_death, d_dens_col, d_dens_bnd, &
+                  d_sig_gen, d_sig_death, d_sig_col, d_sig_spread, d_sig_bnd, &
+                  d_wdens_targ, d_sigmaw_targ)
+                      
+    
+!!--------------------------------------------------------
+    ELSEIF (iflag_wk_pop_dyn == 2) THEN
+  !
+     CALL wake_popdyn_2 ( klon, klev, wk_adv, dtimesub, wgen, &
+                             wdensmin, &
+                             sigmaw, wdens, awdens, &   !! state variables
+                             gfl, cstar, cin, wape, rad_wk, &
+                             d_sigmaw, d_wdens, d_awdens, &  !! tendencies                              
+                             cont_fact, &
+                             d_sig_gen, d_sig_death, d_sig_col, d_sig_spread, d_sig_bnd, &
+                             d_dens_gen, d_dens_death, d_dens_col, d_dens_bnd, &
+                             d_adens_death, d_adens_icol, d_adens_acol, d_adens_bnd )
+sigmaw=sigmaw-d_sigmaw
+wdens=wdens-d_wdens
+awdens=awdens-d_awdens
+
+!!--------------------------------------------------------
+    ELSEIF (iflag_wk_pop_dyn == 3) THEN
+IF (CPPKEY_IOPHYS_WK) THEN
+    IF (phys_sub) THEN
+     CALL iophys_ecrit('ptop',1,'ptop','Pa',ptop)
+     CALL iophys_ecrit('sigmaw',1,'sigmaw','',sigmaw)
+     CALL iophys_ecrit('asigmaw',1,'asigmaw','',asigmaw)
+     CALL iophys_ecrit('wdens',1,'wdens','1/m2',wdens)
+     CALL iophys_ecrit('awdens',1,'awdens','1/m2',awdens)
+     CALL iophys_ecrit('rad_wk',1,'rad_wk','m',rad_wk)
+     CALL iophys_ecrit('arad_wk',1,'arad_wk','m',arad_wk)
+     CALL iophys_ecrit('irad_wk',1,'irad_wk','m',irad_wk)
+    ENDIF
+END IF
+  !
+     CALL wake_popdyn_3 ( klon, klev, phys_sub, wk_adv, dtimesub, wgen, &
+                             wdensmin, &
+                             sigmaw, asigmaw, wdens, awdens, &   !! state variables
+                             gfl, agfl, cstar, cin, wape, &
+                             rad_wk, arad_wk, irad_wk, &
+                             d_sigmaw, d_asigmaw, d_wdens, d_awdens, &  !! tendencies                              
+                             d_sig_gen, d_sig_death, d_sig_col, d_sig_spread, d_sig_bnd, &
+                             d_asig_death, d_asig_aicol, d_asig_iicol, d_asig_spread, d_asig_bnd, &
+                             d_dens_gen, d_dens_death, d_dens_col, d_dens_bnd, &
+                             d_adens_death, d_adens_icol, d_adens_acol, d_adens_bnd )
+sigmaw=sigmaw-d_sigmaw
+asigmaw=asigmaw-d_asigmaw
+wdens=wdens-d_wdens
+awdens=awdens-d_awdens
+   
+!!--------------------------------------------------------
+    ELSEIF (iflag_wk_pop_dyn == 0) THEN
+    
+    ! cc nrlmd
+
+      DO i = 1, klon
+        IF (wk_adv(i)) THEN
+
+          ! cc nrlmd          Introduction du taux de mortalite des poches et
+          ! test sur sigmaw_max=0.4
+          ! cc         d_sigmaw(i) = gfl(i)*Cstar(i)*dtimesub
+          IF (sigmaw(i)>=sigmaw_max) THEN
+            death_rate(i) = gfl(i)*cstar(i)/sigmaw(i)
+          ELSE
+            death_rate(i) = 0.
+          END IF
+    
+          d_sigmaw(i) = gfl(i)*cstar(i)*dtimesub - death_rate(i)*sigmaw(i)* &
+            dtimesub
+          ! $              - nat_rate(i)*sigmaw(i)*dtimesub
+          ! c        print*, 'd_sigmaw(i),sigmaw(i),gfl(i),Cstar(i),wape(i),
+          ! c     $  death_rate(i),ktop(i),kupper(i)',
+          ! c     $	         d_sigmaw(i),sigmaw(i),gfl(i),Cstar(i),wape(i),
+          ! c     $  death_rate(i),ktop(i),kupper(i)
+    
+          ! sigmaw(i) =sigmaw(i) + gfl(i)*Cstar(i)*dtimesub
+          ! sigmaw(i) =min(sigmaw(i),0.99)     !!!!!!!!
+          ! wdens = wdens0/(10.*sigmaw)
+          ! sigmaw =max(sigmaw,sigd_con)
+          ! sigmaw =max(sigmaw,sigmad)
+        END IF
+      END DO
+
+    ENDIF   !  (iflag_wk_pop_dyn == 1) ... ELSEIF (iflag_wk_pop_dyn == 0)
+!!--------------------------------------------------------
+!!--------------------------------------------------------
+
+IF (CPPKEY_IOPHYS_WK) THEN
+    IF (phys_sub) THEN
+     CALL iophys_ecrit('wdensa',1,'wdensa','m',wdens)
+     CALL iophys_ecrit('awdensa',1,'awdensa','m',awdens)
+     CALL iophys_ecrit('sigmawa',1,'sigmawa','m',sigmaw)
+     CALL iophys_ecrit('asigmawa',1,'asigmawa','m',asigmaw)
+    ENDIF
+END IF
+    ! calcul de la difference de vitesse verticale poche - zone non perturbee
+    ! IM 060208 differences par rapport au code initial; init. a 0 dp_deltomg
+    ! IM 060208 et omg sur les niveaux de 1 a klev+1, alors que avant l'on definit
+    ! IM 060208 au niveau k=1...
+    !JYG 161013 Correction : maintenant omg est dimensionne a klev.
+    DO k = 1, klev
+      DO i = 1, klon
+        IF (wk_adv(i)) THEN !!! nrlmd
+          dp_deltomg(i, k) = 0.
+        END IF
+      END DO
+    END DO
+    DO k = 1, klev
+      DO i = 1, klon
+        IF (wk_adv(i)) THEN !!! nrlmd
+          omg(i, k) = 0.
+        END IF
+      END DO
+    END DO
+
+    DO i = 1, klon
+      IF (wk_adv(i)) THEN
+        z(i) = 0.
+        omg(i, 1) = 0.
+        dp_deltomg(i, 1) = -(gfl(i)*cstar(i))/(sigmaw(i)*(1-sigmaw(i)))
+      END IF
+    END DO
+
+    DO k = 2, klev
+      DO i = 1, klon
+        IF (wk_adv(i) .AND. k<=ktop(i)) THEN
+          dz(i) = -(ph(i,k)-ph(i,k-1))/(rho(i,k-1)*RG)
+          z(i) = z(i) + dz(i)
+          dp_deltomg(i, k) = dp_deltomg(i, 1)
+          omg(i, k) = dp_deltomg(i, 1)*z(i)
+        END IF
+      END DO
+    END DO
+
+    DO i = 1, klon
+      IF (wk_adv(i)) THEN
+        dztop(i) = -(ptop(i)-ph(i,ktop(i)))/(rho(i,ktop(i))*RG)
+        ztop(i) = z(i) + dztop(i)
+        omgtop(i) = dp_deltomg(i, 1)*ztop(i)
+      END IF
+    END DO
+
+    IF (prt_level>=10) THEN
+      PRINT *, 'wake-4.2, omg(igout,k) ', (k,omg(igout,k), k=1,klev)
+      PRINT *, 'wake-4.2, omgtop(igout), ptop(igout), ktop(igout) ', &
+                          omgtop(igout), ptop(igout), ktop(igout)
+    ENDIF
+
+    ! -----------------
+    ! From m/s to Pa/s
+    ! -----------------
+
+    DO i = 1, klon
+      IF (wk_adv(i)) THEN
+        omgtop(i) = -rho(i, ktop(i))*RG*omgtop(i)
+!! LJYF        dp_deltomg(i, 1) = omgtop(i)/(ptop(i)-ph(i,1))
+        dp_deltomg(i, 1) = omgtop(i)/min(ptop(i)-ph(i,1),-smallestreal)
+      END IF
+    END DO
+
+    DO k = 1, klev
+      DO i = 1, klon
+        IF (wk_adv(i) .AND. k<=ktop(i)) THEN
+          omg(i, k) = -rho(i, k)*RG*omg(i, k)
+          dp_deltomg(i, k) = dp_deltomg(i, 1)
+        END IF
+      END DO
+    END DO
+
+    ! raccordement lineaire de omg de ptop a pupper
+
+    DO i = 1, klon
+      IF (wk_adv(i) .AND. kupper(i)>ktop(i)) THEN
+        IF ( iflag_wk_profile == 0 ) THEN
+           omg(i, kupper(i)+1) =-RG*amdwn(i, kupper(i)+1)/sigmaw(i) + &
+          RG*amup(i, kupper(i)+1)/(1.-sigmaw(i))
+        ELSE
+           omg(i, kupper(i)+1) = 0.
+        ENDIF
+        dp_deltomg(i, kupper(i)) = (omgtop(i)-omg(i,kupper(i)+1))/ &
+          (ptop(i)-pupper(i))
+      END IF
+    END DO
+
+    ! c      DO i=1,klon
+    ! c        print*,'Pente entre 0 et kupper (reference)'
+    ! c     $   	,omg(i,kupper(i)+1)/(pupper(i)-ph(i,1))
+    ! c        print*,'Pente entre ktop et kupper'
+    ! c     $  	,(omg(i,kupper(i)+1)-omgtop(i))/(pupper(i)-ptop(i))
+    ! c      ENDDO
+    ! c
+    DO k = 1, klev
+      DO i = 1, klon
+        IF (wk_adv(i) .AND. k>ktop(i) .AND. k<=kupper(i)) THEN
+          dp_deltomg(i, k) = dp_deltomg(i, kupper(i))
+          omg(i, k) = omgtop(i) + (ph(i,k)-ptop(i))*dp_deltomg(i, kupper(i))
+        END IF
+      END DO
+    END DO
+!!    print *,'omg(igout,k) ', (k,omg(igout,k),k=1,klev)
+    ! cc nrlmd
+    ! c      DO i=1,klon
+    ! c      print*,'deltaw_ktop,deltaw_conv',omgtop(i),omg(i,kupper(i)+1)
+    ! c      END DO
+    ! cc
+
+
+    ! --    Compute wake average vertical velocity omgbw
+
+
+    DO k = 1, klev
+      DO i = 1, klon
+        IF (wk_adv(i)) THEN
+          omgbw(i, k) = omgb(i, k) + (1.-sigmaw(i))*omg(i, k)
+        END IF
+      END DO
+    END DO
+    ! --    and its vertical gradient dp_omgbw
+
+    DO k = 1, klev-1
+      DO i = 1, klon
+        IF (wk_adv(i)) THEN
+          dp_omgbw(i, k) = (omgbw(i,k+1)-omgbw(i,k))/(ph(i,k+1)-ph(i,k))
+        END IF
+      END DO
+    END DO
+    DO i = 1, klon
+      IF (wk_adv(i)) THEN
+          dp_omgbw(i, klev) = 0.
+      END IF
+    END DO
+
+    ! --    Upstream coefficients for omgb velocity
+    ! --    (alpha_up(k) is the coefficient of the value at level k)
+    ! --    (1-alpha_up(k) is the coefficient of the value at level k-1)
+    DO k = 1, klev
+      DO i = 1, klon
+        IF (wk_adv(i)) THEN
+          alpha_up(i, k) = 0.
+          IF (omgb(i,k)>0.) alpha_up(i, k) = 1.
+        END IF
+      END DO
+    END DO
+
+    ! Matrix expressing [The,deltatw] from  [Th1,Th2]
+
+    DO i = 1, klon
+      IF (wk_adv(i)) THEN
+        rre1(i) = 1. - sigmaw(i)
+        rre2(i) = sigmaw(i)
+      END IF
+    END DO
+    rrd1 = -1.
+    rrd2 = 1.
+
+    ! --    Get [Th1,Th2], dth and [q1,q2]
+
+    DO k = 1, klev
+      DO i = 1, klon
+        IF (wk_adv(i) .AND. k<=kupper(i)+1) THEN
+          dth(i, k) = deltatw(i, k)/ppi(i, k)
+          th1(i, k) = thb(i, k) - sigmaw(i)*dth(i, k) ! undisturbed area
+          th2(i, k) = thb(i, k) + (1.-sigmaw(i))*dth(i, k) ! wake
+          q1(i, k) = qb(i, k) - sigmaw(i)*deltaqw(i, k) ! undisturbed area
+          q2(i, k) = qb(i, k) + (1.-sigmaw(i))*deltaqw(i, k) ! wake
+        END IF
+      END DO
+    END DO
+
+    DO i = 1, klon
+      IF (wk_adv(i)) THEN !!! nrlmd
+        d_th1(i, 1) = 0.
+        d_th2(i, 1) = 0.
+        d_dth(i, 1) = 0.
+        d_q1(i, 1) = 0.
+        d_q2(i, 1) = 0.
+        d_dq(i, 1) = 0.
+      END IF
+    END DO
+
+    DO k = 2, klev
+      DO i = 1, klon
+        IF (wk_adv(i) .AND. k<=kupper(i)+1) THEN
+          d_th1(i, k) = th1(i, k-1) - th1(i, k)
+          d_th2(i, k) = th2(i, k-1) - th2(i, k)
+          d_dth(i, k) = dth(i, k-1) - dth(i, k)
+          d_q1(i, k) = q1(i, k-1) - q1(i, k)
+          d_q2(i, k) = q2(i, k-1) - q2(i, k)
+          d_dq(i, k) = deltaqw(i, k-1) - deltaqw(i, k)
+        END IF
+      END DO
+    END DO
+
+    DO i = 1, klon
+      IF (wk_adv(i)) THEN
+        omgbdth(i, 1) = 0.
+        omgbdq(i, 1) = 0.
+      END IF
+    END DO
+
+    DO k = 2, klev
+      DO i = 1, klon
+        IF (wk_adv(i) .AND. k<=kupper(i)+1) THEN !   loop on interfaces
+          omgbdth(i, k) = omgb(i, k)*(dth(i,k-1)-dth(i,k))
+          omgbdq(i, k) = omgb(i, k)*(deltaqw(i,k-1)-deltaqw(i,k))
+        END IF
+      END DO
+    END DO
+
+!!    IF (prt_level>=10) THEN
+    IF (prt_level>=10 .and. wk_adv(igout)) THEN
+      PRINT *, 'wake-4.3, th1(igout,k) ', (k,th1(igout,k), k=1,kupper(igout))
+      PRINT *, 'wake-4.3, th2(igout,k) ', (k,th2(igout,k), k=1,kupper(igout))
+      PRINT *, 'wake-4.3, dth(igout,k) ', (k,dth(igout,k), k=1,kupper(igout))
+      PRINT *, 'wake-4.3, omgbdth(igout,k) ', (k,omgbdth(igout,k), k=1,kupper(igout))
+    ENDIF
+
+    ! -----------------------------------------------------------------
+    DO k = 1, klev-1
+      DO i = 1, klon
+        IF (wk_adv(i) .AND. k<=kupper(i)-1) THEN
+          ! -----------------------------------------------------------------
+
+          ! Compute redistribution (advective) term
+
+          d_deltatw(i, k) = dtimesub/(ph(i,k)-ph(i,k+1))* &
+            (rrd1*omg(i,k)*sigmaw(i)*d_th1(i,k) - &
+             rrd2*omg(i,k+1)*(1.-sigmaw(i))*d_th2(i,k+1)- &
+             (1.-alpha_up(i,k))*omgbdth(i,k)- &
+             alpha_up(i,k+1)*omgbdth(i,k+1))*ppi(i, k)
+!           print*,'d_d,k_ptop_provis(i)eltatw=', k, d_deltatw(i,k)
+
+          d_deltaqw(i, k) = dtimesub/(ph(i,k)-ph(i,k+1))* &
+            (rrd1*omg(i,k)*sigmaw(i)*d_q1(i,k)- &
+             rrd2*omg(i,k+1)*(1.-sigmaw(i))*d_q2(i,k+1)- &
+             (1.-alpha_up(i,k))*omgbdq(i,k)- &
+             alpha_up(i,k+1)*omgbdq(i,k+1))
+!           print*,'d_deltaqw=', k, d_deltaqw(i,k)
+
+          ! and increment large scale tendencies
+
+
+
+
+          ! C
+          ! -----------------------------------------------------------------
+          d_tb(i, k) = dtimesub*((rre1(i)*omg(i,k)*sigmaw(i)*d_th1(i,k)- &
+                                  rre2(i)*omg(i,k+1)*(1.-sigmaw(i))*d_th2(i,k+1))/ &
+                                 (ph(i,k)-ph(i,k+1)) &
+                                 -sigmaw(i)*(1.-sigmaw(i))*dth(i,k)*(omg(i,k)-omg(i,k+1))/ &
+                                 (ph(i,k)-ph(i,k+1)) )*ppi(i, k)
+
+          d_qb(i, k) = dtimesub*((rre1(i)*omg(i,k)*sigmaw(i)*d_q1(i,k)- &
+                                  rre2(i)*omg(i,k+1)*(1.-sigmaw(i))*d_q2(i,k+1))/ &
+                                 (ph(i,k)-ph(i,k+1)) &
+                                 -sigmaw(i)*(1.-sigmaw(i))*deltaqw(i,k)*(omg(i,k)-omg(i,k+1))/ &
+                                 (ph(i,k)-ph(i,k+1)) )
+        ELSE IF (wk_adv(i) .AND. k==kupper(i)) THEN
+          d_tb(i, k) = dtimesub*(rre1(i)*omg(i,k)*sigmaw(i)*d_th1(i,k)/(ph(i,k)-ph(i,k+1)))*ppi(i, k)
+
+          d_qb(i, k) = dtimesub*(rre1(i)*omg(i,k)*sigmaw(i)*d_q1(i,k)/(ph(i,k)-ph(i,k+1)))
+
+        END IF
+        ! cc
+      END DO
+    END DO
+    ! ------------------------------------------------------------------
+
+    IF (prt_level>=10) THEN
+      PRINT *, 'wake-4.3, d_deltatw(igout,k) ', (k,d_deltatw(igout,k), k=1,klev)
+      PRINT *, 'wake-4.3, d_deltaqw(igout,k) ', (k,d_deltaqw(igout,k), k=1,klev)
+    ENDIF
+
+    ! Increment state variables
+!jyg<
+    IF (iflag_wk_pop_dyn >= 1) THEN
+      DO k = 1, klev
+        DO i = 1, klon
+          IF (wk_adv(i) .AND. k<=kupper(i)) THEN
+            detr(i,k) = - d_sig_death(i) - d_sig_col(i)      
+            entr(i,k) = d_sig_gen(i)
+          ENDIF
+        ENDDO
+      ENDDO
+      ELSE  ! (iflag_wk_pop_dyn >= 1)
+      DO k = 1, klev
+        DO i = 1, klon
+          IF (wk_adv(i) .AND. k<=kupper(i)) THEN
+            detr(i, k) = 0.
+   
+            entr(i, k) = 0.
+          ENDIF
+        ENDDO
+      ENDDO
+    ENDIF  ! (iflag_wk_pop_dyn >= 1)
+
+    
+
+    DO k = 1, klev
+      DO i = 1, klon
+        ! cc nrlmd       IF( wk_adv(i) .AND. k .LE. kupper(i)-1) THEN
+        IF (wk_adv(i) .AND. k<=kupper(i)) THEN
+          ! cc
+
+
+
+          ! Coefficient de repartition
+
+          crep(i, k) = crep_sol*(ph(i,kupper(i))-ph(i,k))/ &
+            (ph(i,kupper(i))-ph(i,1))
+          crep(i, k) = crep(i, k) + crep_upper*(ph(i,1)-ph(i,k))/ &
+            (ph(i,1)-ph(i,kupper(i)))
+
+
+          ! Reintroduce compensating subsidence term.
+
+          ! dtKE(k)=(dtdwn(k)*Crep(k))/sigmaw
+          ! dtKE(k)=dtKE(k)-(dtdwn(k)*(1-Crep(k))+dta(k))
+          ! .                   /(1-sigmaw)
+          ! dqKE(k)=(dqdwn(k)*Crep(k))/sigmaw
+          ! dqKE(k)=dqKE(k)-(dqdwn(k)*(1-Crep(k))+dqa(k))
+          ! .                   /(1-sigmaw)
+
+          ! dtKE(k)=(dtdwn(k)*Crep(k)+(1-Crep(k))*dta(k))/sigmaw
+          ! dtKE(k)=dtKE(k)-(dtdwn(k)*(1-Crep(k))+dta(k)*Crep(k))
+          ! .                   /(1-sigmaw)
+          ! dqKE(k)=(dqdwn(k)*Crep(k)+(1-Crep(k))*dqa(k))/sigmaw
+          ! dqKE(k)=dqKE(k)-(dqdwn(k)*(1-Crep(k))+dqa(k)*Crep(k))
+          ! .                   /(1-sigmaw)
+
+          dtke(i, k) = (dtdwn(i,k)/sigmaw(i)-dta(i,k)/(1.-sigmaw(i)))
+          dqke(i, k) = (dqdwn(i,k)/sigmaw(i)-dqa(i,k)/(1.-sigmaw(i)))
+          ! print*,'dtKE= ',dtKE(i,k),' dqKE= ',dqKE(i,k)
+
+!
+
+          ! cc nrlmd          Prise en compte du taux de mortalite
+          ! cc               Definitions de entr, detr
+!jyg<
+!!            detr(i, k) = 0.
+!!   
+!!            entr(i, k) = detr(i, k) + gfl(i)*cstar(i) + &
+!!              sigmaw(i)*(1.-sigmaw(i))*dp_deltomg(i, k)
+!!
+            entr(i, k) = entr(i,k) + gfl(i)*cstar(i) + &
+                         sigmaw(i)*(1.-sigmaw(i))*dp_deltomg(i, k)   
+!>jyg
+            wkspread(i, k) = (entr(i,k)-detr(i,k))/sigmaw(i)
+
+          ! cc        wkspread(i,k) =
+          ! (1.-sigmaw(i))*dp_deltomg(i,k)+gfl(i)*Cstar(i)/
+          ! cc     $  sigmaw(i)
+
+
+          ! ajout d'un effet onde de gravite -Tgw(k)*deltatw(k) 03/02/06 YU
+          ! Jingmei
+
+          ! write(lunout,*)'wake.F ',i,k, dtimesub,d_deltat_gw(i,k),
+          ! &  Tgw(i,k),deltatw(i,k)
+          d_deltat_gw(i, k) = d_deltat_gw(i, k) - tgw(i, k)*deltatw(i, k)* &
+            dtimesub
+          ! write(lunout,*)'wake.F ',i,k, dtimesub,d_deltatw(i,k)
+          ff(i) = d_deltatw(i, k)/dtimesub
+
+          ! Sans GW
+
+          ! deltatw(k)=deltatw(k)+dtimesub*(ff+dtKE(k)-wkspread(k)*deltatw(k))
+
+          ! GW formule 1
+
+          ! deltatw(k) = deltatw(k)+dtimesub*
+          ! $         (ff+dtKE(k) - wkspread(k)*deltatw(k)-Tgw(k)*deltatw(k))
+
+          ! GW formule 2
+
+          IF (dtimesub*tgw(i,k)<1.E-10) THEN
+            d_deltatw(i, k) = dtimesub*(ff(i)+dtke(i,k) - & 
+               entr(i,k)*deltatw(i,k)/sigmaw(i) - &
+               (death_rate(i)*sigmaw(i)+detr(i,k))*deltatw(i,k)/(1.-sigmaw(i)) - & ! cc
+               tgw(i,k)*deltatw(i,k) )
+          ELSE
+            d_deltatw(i, k) = 1/tgw(i, k)*(1-exp(-dtimesub*tgw(i,k)))* &
+               (ff(i)+dtke(i,k) - &
+                entr(i,k)*deltatw(i,k)/sigmaw(i) - &
+                (death_rate(i)*sigmaw(i)+detr(i,k))*deltatw(i,k)/(1.-sigmaw(i)) - &
+                tgw(i,k)*deltatw(i,k) )
+          END IF
+
+          dth(i, k) = deltatw(i, k)/ppi(i, k)
+
+          gg(i) = d_deltaqw(i, k)/dtimesub
+
+          d_deltaqw(i, k) = dtimesub*(gg(i)+dqke(i,k) - & 
+            entr(i,k)*deltaqw(i,k)/sigmaw(i) - &
+            (death_rate(i)*sigmaw(i)+detr(i,k))*deltaqw(i,k)/(1.-sigmaw(i)))
+          ! cc
+
+          ! cc nrlmd
+          ! cc       d_deltatw2(i,k)=d_deltatw2(i,k)+d_deltatw(i,k)
+          ! cc       d_deltaqw2(i,k)=d_deltaqw2(i,k)+d_deltaqw(i,k)
+          ! cc
+        END IF
+      END DO
+    END DO
+
+
+    ! Scale tendencies so that water vapour remains positive in w and x.
+
+    CALL wake_vec_modulation(klon, klev, wk_adv, epsilon_loc, qb, d_qb, deltaqw, &
+      d_deltaqw, sigmaw, d_sigmaw, alpha)
+    !
+    ! Alpha_tot = Product of all the alpha's
+    DO i = 1, klon
+      IF (wk_adv(i)) THEN
+        alpha_tot(i) = alpha_tot(i)*alpha(i)    
+      END IF
+    END DO
+
+    ! cc nrlmd
+    ! c      print*,'alpha'
+    ! c      do i=1,klon
+    ! c         print*,alpha(i)
+    ! c      end do
+    ! cc
+    DO k = 1, klev
+      DO i = 1, klon
+        IF (wk_adv(i) .AND. k<=kupper(i)) THEN
+          d_tb(i, k) = alpha(i)*d_tb(i, k)
+          d_qb(i, k) = alpha(i)*d_qb(i, k)
+          d_deltatw(i, k) = alpha(i)*d_deltatw(i, k)
+          d_deltaqw(i, k) = alpha(i)*d_deltaqw(i, k)
+          d_deltat_gw(i, k) = alpha(i)*d_deltat_gw(i, k)
+        END IF
+      END DO
+    END DO
+    DO i = 1, klon
+      IF (wk_adv(i)) THEN
+        d_sigmaw(i) = alpha(i)*d_sigmaw(i)
+      END IF
+    END DO
+
+    ! Update large scale variables and wake variables
+    ! IM 060208 manque DO i + remplace DO k=1,kupper(i)
+    ! IM 060208     DO k = 1,kupper(i)
+    DO k = 1, klev
+      DO i = 1, klon
+        IF (wk_adv(i) .AND. k<=kupper(i)) THEN
+          dtls(i, k) = dtls(i, k) + d_tb(i, k)
+          dqls(i, k) = dqls(i, k) + d_qb(i, k)
+          ! cc nrlmd
+          d_deltatw2(i, k) = d_deltatw2(i, k) + d_deltatw(i, k)
+          d_deltaqw2(i, k) = d_deltaqw2(i, k) + d_deltaqw(i, k)
+          ! cc
+        END IF
+      END DO
+    END DO
+    DO k = 1, klev
+      DO i = 1, klon
+        IF (wk_adv(i) .AND. k<=kupper(i)) THEN
+          tb(i, k) = tb0(i, k) + dtls(i, k)
+          qb(i, k) = qb0(i, k) + dqls(i, k)
+          thb(i, k) = tb(i, k)/ppi(i, k)
+          deltatw(i, k) = deltatw(i, k) + d_deltatw(i, k)
+          deltaqw(i, k) = deltaqw(i, k) + d_deltaqw(i, k)
+          dth(i, k) = deltatw(i, k)/ppi(i, k)
+          ! c      print*,'k,qx,qw',k,qb(i,k)-sigmaw(i)*deltaqw(i,k)
+          ! c     $        ,qb(i,k)+(1-sigmaw(i))*deltaqw(i,k)
+        END IF
+      END DO
+    END DO
+!
+    DO i = 1, klon
+      IF (wk_adv(i)) THEN
+        sigmaw(i) = sigmaw(i) + d_sigmaw(i)
+        d_sigmaw2(i) = d_sigmaw2(i) + d_sigmaw(i)
+      END IF
+    END DO
+!jyg<
+    IF (iflag_wk_pop_dyn >= 1) THEN
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! sigmaw !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!  Cumulatives
+      DO i = 1, klon
+        IF (wk_adv(i)) THEN
+          d_sig_gen2(i)   = d_sig_gen2(i)   + d_sig_gen(i)
+          d_sig_death2(i) = d_sig_death2(i) + d_sig_death(i)
+          d_sig_col2(i)   = d_sig_col2(i)   + d_sig_col(i)
+          d_sig_spread2(i)= d_sig_spread2(i)+ d_sig_spread(i)
+          d_sig_bnd2(i)   = d_sig_bnd2(i)   + d_sig_bnd(i)
+        END IF
+      END DO
+!  Bounds
+      DO i = 1, klon
+        IF (wk_adv(i)) THEN
+          sigmaw_targ = max(sigmaw(i),sigmad)
+          d_sig_bnd2(i) = d_sig_bnd2(i) + sigmaw_targ - sigmaw(i)
+          d_sigmaw2(i) = d_sigmaw2(i) + sigmaw_targ - sigmaw(i)
+          sigmaw(i) = sigmaw_targ
+        END IF
+      END DO
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! wdens  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!  Cumulatives
+      DO i = 1, klon
+        IF (wk_adv(i)) THEN
+          wdens(i) = wdens(i) + d_wdens(i)
+          d_wdens2(i) = d_wdens2(i) + d_wdens(i)
+          d_dens_gen2(i)   = d_dens_gen2(i)   + d_dens_gen(i)
+          d_dens_death2(i) = d_dens_death2(i) + d_dens_death(i)
+          d_dens_col2(i)   = d_dens_col2(i)   + d_dens_col(i)
+          d_dens_bnd2(i)   = d_dens_bnd2(i)   + d_dens_bnd(i)
+        END IF
+      END DO
+!  Bounds
+      DO i = 1, klon
+        IF (wk_adv(i)) THEN
+          wdens_targ = max(wdens(i),wdensmin)
+          d_dens_bnd2(i) = d_dens_bnd2(i) + wdens_targ - wdens(i)
+          d_wdens2(i) = d_wdens2(i) + wdens_targ - wdens(i)
+          wdens(i) = wdens_targ
+        END IF
+      END DO
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! awdens !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!  Cumulatives
+      DO i = 1, klon
+        IF (wk_adv(i)) THEN
+          awdens(i) = awdens(i) + d_awdens(i)
+          d_awdens2(i) = d_awdens2(i) + d_awdens(i)
+        END IF
+      END DO
+!  Bounds
+      DO i = 1, klon
+        IF (wk_adv(i)) THEN
+          wdens_targ = min( max(awdens(i),0.), wdens(i) )
+          d_adens_bnd2(i) = d_adens_bnd2(i) + wdens_targ - awdens(i)
+          d_awdens2(i) = d_awdens2(i) + wdens_targ - awdens(i)
+          awdens(i) = wdens_targ
+        END IF
+      END DO
+!
+      IF (iflag_wk_pop_dyn >= 2) THEN
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! awdens again for iflag_wk_pop_dyn >= 2!!!!!!
+!  Cumulatives
+        DO i = 1, klon
+           IF (wk_adv(i)) THEN
+               d_adens_death2(i)   = d_adens_death2(i)   + d_adens_death(i)
+               d_adens_icol2(i)   = d_adens_icol2(i)   + d_adens_icol(i)
+               d_adens_acol2(i)   = d_adens_acol2(i)   + d_adens_acol(i)
+               d_adens_bnd2(i)   = d_adens_bnd2(i)   + d_adens_bnd(i)          
+           END IF
+        END DO
+!  Bounds
+        DO i = 1, klon
+           IF (wk_adv(i)) THEN
+               wdens_targ = min( max(awdens(i),0.), wdens(i) )
+               d_adens_bnd2(i) = d_adens_bnd2(i) + wdens_targ - awdens(i)
+               awdens(i) = wdens_targ
+           END IF
+        END DO
+!
+        IF (iflag_wk_pop_dyn == 3) THEN
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! asigmaw for iflag_wk_pop_dyn = 3!!!!!!
+!  Cumulatives
+          DO i = 1, klon
+             IF (wk_adv(i)) THEN
+                 asigmaw(i) = asigmaw(i) + d_asigmaw(i)
+                 d_asigmaw2(i) = d_asigmaw2(i) + d_asigmaw(i)
+                 d_asig_death2(i)   = d_asig_death2(i)   + d_asig_death(i)
+                 d_asig_spread2(i)  = d_asig_spread2(i)  + d_asig_spread(i)
+                 d_asig_iicol2(i)   = d_asig_iicol2(i)   + d_asig_iicol(i)
+                 d_asig_aicol2(i)   = d_asig_aicol2(i)   + d_asig_aicol(i)
+                 d_asig_bnd2(i)     = d_asig_bnd2(i)     + d_asig_bnd(i)          
+             END IF
+          END DO
+!  Bounds
+          DO i = 1, klon
+             IF (wk_adv(i)) THEN
+   !   asigmaw lower bound set to sigmad/2 in order to allow asigmaw values lower than sigmad.
+   !!             sigmaw_targ = min(max(asigmaw(i),sigmad),sigmaw(i))
+                sigmaw_targ = min(max(asigmaw(i),sigmad/2.),sigmaw(i))
+                d_asig_bnd2(i) = d_asig_bnd2(i) + sigmaw_targ - asigmaw(i)
+                d_asigmaw2(i) = d_asigmaw2(i) + sigmaw_targ - asigmaw(i)
+                asigmaw(i) = sigmaw_targ
+             END IF
+          END DO
+
+IF (CPPKEY_IOPHYS_WK) THEN
+    IF (phys_sub) THEN
+     CALL iophys_ecrit('wdensb',1,'wdensb','m',wdens)
+     CALL iophys_ecrit('awdensb',1,'awdensb','m',awdens)
+     CALL iophys_ecrit('sigmawb',1,'sigmawb','m',sigmaw)
+     CALL iophys_ecrit('asigmawb',1,'asigmawb','m',asigmaw)
+!
+     call iophys_ecrit('d_wdens2',1,'d_wdens2','',d_wdens2)
+     call iophys_ecrit('d_dens_gen2',1,'d_dens_gen2','',d_dens_gen2)
+     call iophys_ecrit('d_dens_death2',1,'d_dens_death2','',d_dens_death2)
+     call iophys_ecrit('d_dens_col2',1,'d_dens_col2','',d_dens_col2)
+     call iophys_ecrit('d_dens_bnd2',1,'d_dens_bnd2','',d_dens_bnd2)
+!
+     call iophys_ecrit('d_awdens2',1,'d_awdens2','',d_awdens2)
+     call iophys_ecrit('d_adens_death2',1,'d_adens_death2','',d_adens_death2)
+     call iophys_ecrit('d_adens_icol2',1,'d_adens_icol2','',d_adens_icol2)
+     call iophys_ecrit('d_adens_acol2',1,'d_adens_acol2','',d_adens_acol2)
+     call iophys_ecrit('d_adens_bnd2',1,'d_adens_bnd2','',d_adens_bnd2)
+!
+     CALL iophys_ecrit('d_sigmaw2',1,'d_sigmaw2','',d_sigmaw2)
+     CALL iophys_ecrit('d_sig_gen2',1,'d_sig_gen2','m',d_sig_gen2)
+     CALL iophys_ecrit('d_sig_spread2',1,'d_sig_spread2','',d_sig_spread2)
+     CALL iophys_ecrit('d_sig_col2',1,'d_sig_col2','',d_sig_col2)
+     CALL iophys_ecrit('d_sig_death2',1,'d_sig_death2','',d_sig_death2)
+     CALL iophys_ecrit('d_sig_bnd2',1,'d_sig_bnd2','',d_sig_bnd2)
+!
+     CALL iophys_ecrit('d_asigmaw2',1,'d_asigmaw2','',d_asigmaw2)
+     CALL iophys_ecrit('d_asig_spread2',1,'d_asig_spread2','m',d_asig_spread2)
+     CALL iophys_ecrit('d_asig_aicol2',1,'d_asig_aicol2','m',d_asig_aicol2)
+     CALL iophys_ecrit('d_asig_iicol2',1,'d_asig_iicol2','m',d_asig_iicol2)
+     CALL iophys_ecrit('d_asig_death2',1,'d_asig_death2','m',d_asig_death2)
+     CALL iophys_ecrit('d_asig_bnd2',1,'d_asig_bnd2','m',d_asig_bnd2)
+    ENDIF
+END IF
+        ENDIF ! (iflag_wk_pop_dyn == 3)
+      ENDIF ! (iflag_wk_pop_dyn >= 2)
+    ENDIF  ! (iflag_wk_pop_dyn >= 1)
+
+
+
+   Call pkupper (klon, klev, ptop, ph, p, pupper, kupper, &
+                    dth, hw, rho, delta_t_min, &
+                    ktop, wk_adv, h_zzz, ptop1, ktop1)
+   !! print'("pkupper APPEL ",7i6)',isubstep,int(ptop/100.),int(ptop1/100.),int(pupper/100.),ktop,ktop1,kupper
+
+    ! 5/ Set deltatw & deltaqw to 0 above kupper
+
+    DO k = 1, klev
+      DO i = 1, klon
+        IF (wk_adv(i) .AND. k>=kupper(i)) THEN
+          deltatw(i, k) = 0.
+          deltaqw(i, k) = 0.
+          d_deltatw2(i,k) = -deltatw0(i,k)
+          d_deltaqw2(i,k) = -deltaqw0(i,k)
+        END IF
+      END DO
+    END DO
+
+
+    ! -------------Cstar computation---------------------------------
+    DO i = 1, klon
+      IF (wk_adv(i)) THEN !!! nrlmd
+        sum_thx(i) = 0.
+        sum_tx(i) = 0.
+        sum_qx(i) = 0.
+        sum_thvx(i) = 0.
+        sum_dth(i) = 0.
+        sum_dq(i) = 0.
+        sum_dtdwn(i) = 0.
+        sum_dqdwn(i) = 0.
+
+        av_thx(i) = 0.
+        av_tx(i) = 0.
+        av_qx(i) = 0.
+        av_thvx(i) = 0.
+        av_dth(i) = 0.
+        av_dq(i) = 0.
+        av_dtdwn(i) = 0.
+        av_dqdwn(i) = 0.
+      END IF
+    END DO
+
+    ! Integrals (and wake top level number)
+    ! --------------------------------------
+
+    ! Initialize sum_thvx to 1st level virt. pot. temp.
+
+    DO i = 1, klon
+      IF (wk_adv(i)) THEN !!! nrlmd
+        z(i) = 1.
+        dz(i) = 1.
+        sum_thvx(i) = thx(i, 1)*(1.+epsim1*qx(i,1))*dz(i)
+        sum_dth(i) = 0.
+      END IF
+    END DO
+
+    DO k = 1, klev
+      DO i = 1, klon
+        IF (wk_adv(i)) THEN !!! nrlmd
+          dz(i) = -(max(ph(i,k+1),ptop(i))-ph(i,k))/(rho(i,k)*RG)
+          IF (dz(i)>0) THEN
+            z(i) = z(i) + dz(i)
+            sum_thx(i) = sum_thx(i) + thx(i, k)*dz(i)
+            sum_tx(i) = sum_tx(i) + tx(i, k)*dz(i)
+            sum_qx(i) = sum_qx(i) + qx(i, k)*dz(i)
+            sum_thvx(i) = sum_thvx(i) + thx(i, k)*(1.+epsim1*qx(i,k))*dz(i)
+            sum_dth(i) = sum_dth(i) + dth(i, k)*dz(i)
+            sum_dq(i) = sum_dq(i) + deltaqw(i, k)*dz(i)
+            sum_dtdwn(i) = sum_dtdwn(i) + dtdwn(i, k)*dz(i)
+            sum_dqdwn(i) = sum_dqdwn(i) + dqdwn(i, k)*dz(i)
+          END IF
+        END IF
+      END DO
+    END DO
+
+    DO i = 1, klon
+      IF (wk_adv(i)) THEN !!! nrlmd
+        hw0(i) = z(i)
+      END IF
+    END DO
+
+
+    ! - WAPE and mean forcing computation
+    ! ---------------------------------------
+
+    ! ---------------------------------------
+
+    ! Means
+
+    DO i = 1, klon
+      IF (wk_adv(i)) THEN !!! nrlmd
+        av_thx(i) = sum_thx(i)/hw0(i)
+        av_tx(i) = sum_tx(i)/hw0(i)
+        av_qx(i) = sum_qx(i)/hw0(i)
+        av_thvx(i) = sum_thvx(i)/hw0(i)
+        av_dth(i) = sum_dth(i)/hw0(i)
+        av_dq(i) = sum_dq(i)/hw0(i)
+        av_dtdwn(i) = sum_dtdwn(i)/hw0(i)
+        av_dqdwn(i) = sum_dqdwn(i)/hw0(i)
+
+        wape(i) = -RG*hw0(i)*(av_dth(i)+epsim1*(av_thx(i)*av_dq(i) + &
+                              av_dth(i)*av_qx(i)+av_dth(i)*av_dq(i)))/av_thvx(i)
+      END IF
+    END DO
+
+
+    ! Filter out bad wakes
+
+    DO k = 1, klev
+      DO i = 1, klon
+        IF (wk_adv(i)) THEN !!! nrlmd
+          IF (wape(i)<0.) THEN
+            deltatw(i, k) = 0.
+            deltaqw(i, k) = 0.
+            dth(i, k) = 0.
+            d_deltatw2(i,k) = -deltatw0(i,k)
+            d_deltaqw2(i,k) = -deltaqw0(i,k)
+          END IF
+        END IF
+      END DO
+    END DO
+
+    DO i = 1, klon
+      IF (wk_adv(i)) THEN !!! nrlmd
+        IF (wape(i)<0.) THEN
+          wape(i) = 0.
+          cstar(i) = 0.
+          hw(i) = hwmin
+!jyg<
+!!          sigmaw(i) = max(sigmad, sigd_con(i))
+          sigmaw_targ = max(sigmad, sigd_con(i))
+          d_sig_bnd2(i) = d_sig_bnd2(i) + sigmaw_targ - sigmaw(i)
+          d_sigmaw2(i) = d_sigmaw2(i) + sigmaw_targ - sigmaw(i)
+          sigmaw(i) = sigmaw_targ
+!
+          d_asig_bnd2(i) = d_asig_bnd2(i) + sigmaw_targ - asigmaw(i)
+          d_asigmaw2(i) = d_asigmaw2(i) + sigmaw_targ - asigmaw(i)
+          asigmaw(i) = sigmaw_targ
+!>jyg
+          fip(i) = 0.
+          gwake(i) = .FALSE.
+        ELSE
+          cstar(i) = stark*sqrt(2.*wape(i))
+          gwake(i) = .TRUE.
+        END IF
+      END IF
+    END DO
+  !
+  ! ------------------------------------------------------------------------
+  !
+  END DO   ! isubstep end sub-timestep loop
+  !
+  ! ------------------------------------------------------------------------
+  ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+  ! ------------------------------------------------------------------------
+  !
+
+IF (CPPKEY_IOPHYS_WK) THEN
+    IF (.not.phys_sub) CALL iophys_ecrit('wape_b',1,'wape_b','J/kg',wape)
+END IF
+  IF (prt_level>=10) THEN
+    PRINT *, 'wake-5, sigmaw(igout), cstar(igout), wape(igout), ptop(igout) ', &
+                      sigmaw(igout), cstar(igout), wape(igout), ptop(igout)
+  ENDIF
+
+
+  ! ----------------------------------------------------------
+  ! Determine wake final state; recompute wape, cstar, ktop;
+  ! filter out bad wakes.
+  ! ----------------------------------------------------------
+
+  ! 2.1 - Undisturbed area and Wake integrals
+  ! ---------------------------------------------------------
+
+  DO i = 1, klon
+    ! cc nrlmd       if (wk_adv(i)) then !!! nrlmd
+    IF (ok_qx_qw(i)) THEN
+      ! cc
+      z(i) = 0.
+      sum_thx(i) = 0.
+      sum_tx(i) = 0.
+      sum_qx(i) = 0.
+      sum_thvx(i) = 0.
+      sum_dth(i) = 0.
+      sum_half_dth(i) = 0.
+      sum_dq(i) = 0.
+      sum_dtdwn(i) = 0.
+      sum_dqdwn(i) = 0.
+
+      av_thx(i) = 0.
+      av_tx(i) = 0.
+      av_qx(i) = 0.
+      av_thvx(i) = 0.
+      av_dth(i) = 0.
+      av_dq(i) = 0.
+      av_dtdwn(i) = 0.
+      av_dqdwn(i) = 0.
+
+      dthmin(i) = -delta_t_min
+    END IF
+  END DO
+  ! Potential temperatures and humidity
+  ! ----------------------------------------------------------
+
+  DO k = 1, klev
+    DO i = 1, klon
+      ! cc nrlmd       IF ( wk_adv(i)) THEN
+      IF (ok_qx_qw(i)) THEN
+        ! cc
+        rho(i, k) = p(i, k)/(RD*tb(i,k))
+        IF (k==1) THEN
+          rhoh(i, k) = ph(i, k)/(RD*tb(i,k))
+          zhh(i, k) = 0
+        ELSE
+          rhoh(i, k) = ph(i, k)*2./(RD*(tb(i,k)+tb(i,k-1)))
+          zhh(i, k) = (ph(i,k)-ph(i,k-1))/(-rhoh(i,k)*RG) + zhh(i, k-1)
+        END IF
+        thb(i, k) = tb(i, k)/ppi(i, k)
+        thx(i, k) = (tb(i,k)-deltatw(i,k)*sigmaw(i))/ppi(i, k)
+        tx(i, k) = tb(i, k) - deltatw(i, k)*sigmaw(i)
+        qx(i, k) = qb(i, k) - deltaqw(i, k)*sigmaw(i)
+        dth(i, k) = deltatw(i, k)/ppi(i, k)
+      END IF
+    END DO
+  END DO
+
+  ! Integrals (and wake top level number)
+  ! -----------------------------------------------------------
+
+  ! Initialize sum_thvx to 1st level virt. pot. temp.
+
+  DO i = 1, klon
+    ! cc nrlmd       IF ( wk_adv(i)) THEN
+    IF (ok_qx_qw(i)) THEN
+      ! cc
+      z(i) = 1.
+      dz(i) = 1.
+      dz_half(i) = 1.
+      sum_thvx(i) = thx(i, 1)*(1.+epsim1*qx(i,1))*dz(i)
+      sum_dth(i) = 0.
+    END IF
+  END DO
+
+  DO k = 1, klev
+    DO i = 1, klon
+      ! cc nrlmd       IF ( wk_adv(i)) THEN
+      IF (ok_qx_qw(i)) THEN
+        ! cc
+        dz(i) = -(amax1(ph(i,k+1),ptop(i))-ph(i,k))/(rho(i,k)*RG)
+        dz_half(i) = -(amax1(ph(i,k+1),0.5*(ptop(i)+ph(i,1)))-ph(i,k))/(rho(i,k)*RG)
+        IF (dz(i)>0) THEN
+          z(i) = z(i) + dz(i)
+          sum_thx(i) = sum_thx(i) + thx(i, k)*dz(i)
+          sum_tx(i) = sum_tx(i) + tx(i, k)*dz(i)
+          sum_qx(i) = sum_qx(i) + qx(i, k)*dz(i)
+          sum_thvx(i) = sum_thvx(i) + thx(i, k)*(1.+epsim1*qx(i,k))*dz(i)
+          sum_dth(i) = sum_dth(i) + dth(i, k)*dz(i)
+          sum_dq(i) = sum_dq(i) + deltaqw(i, k)*dz(i)
+          sum_dtdwn(i) = sum_dtdwn(i) + dtdwn(i, k)*dz(i)
+          sum_dqdwn(i) = sum_dqdwn(i) + dqdwn(i, k)*dz(i)
+!
+          dthmin(i) = min(dthmin(i), dth(i,k))
+        END IF
+        IF (dz_half(i)>0) THEN
+          sum_half_dth(i) = sum_half_dth(i) + dth(i, k)*dz_half(i)
+        END IF
+      END IF
+    END DO
+  END DO
+
+  DO i = 1, klon
+    ! cc nrlmd       IF ( wk_adv(i)) THEN
+    IF (ok_qx_qw(i)) THEN
+      ! cc
+      hw0(i) = z(i)
+    END IF
+  END DO
+
+  ! - WAPE and mean forcing computation
+  ! -------------------------------------------------------------
+
+  ! Means
+
+  DO i = 1, klon
+    ! cc nrlmd       IF ( wk_adv(i)) THEN
+    IF (ok_qx_qw(i)) THEN
+      ! cc
+      av_thx(i) = sum_thx(i)/hw0(i)
+      av_tx(i) = sum_tx(i)/hw0(i)
+      av_qx(i) = sum_qx(i)/hw0(i)
+      av_thvx(i) = sum_thvx(i)/hw0(i)
+      av_dth(i) = sum_dth(i)/hw0(i)
+      av_dq(i) = sum_dq(i)/hw0(i)
+      av_dtdwn(i) = sum_dtdwn(i)/hw0(i)
+      av_dqdwn(i) = sum_dqdwn(i)/hw0(i)
+
+      wape2(i) = -RG*hw0(i)*(av_dth(i)+epsim1*(av_thx(i)*av_dq(i) + &
+                             av_dth(i)*av_qx(i)+av_dth(i)*av_dq(i)))/av_thvx(i)
+    END IF
+  END DO
+IF (CPPKEY_IOPHYS_WK) THEN
+  IF (.not.phys_sub) CALL iophys_ecrit('wape2_a',1,'wape2_a','J/kg',wape2)
+END IF
+
+
+  ! Prognostic variable update
+  ! ------------------------------------------------------------
+
+  ! Filter out bad wakes
+
+  IF (iflag_wk_check_trgl>=1) THEN
+    ! Check triangular shape of dth profile
+    DO i = 1, klon
+      IF (ok_qx_qw(i)) THEN
+        !! print *,'wake, hw0(i), dthmin(i) ', hw0(i), dthmin(i)
+        !! print *,'wake, 2.*sum_dth(i)/(hw0(i)*dthmin(i)) ', &
+        !!                2.*sum_dth(i)/(hw0(i)*dthmin(i))
+        !! print *,'wake, sum_half_dth(i), sum_dth(i) ', &
+        !!                sum_half_dth(i), sum_dth(i)
+        IF ((hw0(i) < 1.) .or. (dthmin(i) >= -delta_t_min) ) THEN
+          wape2(i) = -1.
+          !! print *,'wake, rej 1'
+        ELSE IF (iflag_wk_check_trgl==1.AND.abs(2.*sum_dth(i)/(hw0(i)*dthmin(i)) - 1.) > 0.5) THEN
+          wape2(i) = -1.
+          !! print *,'wake, rej 2'
+        ELSE IF (abs(sum_half_dth(i)) < 0.5*abs(sum_dth(i)) ) THEN
+          wape2(i) = -1.
+          !! print *,'wake, rej 3'
+        END IF
+      END IF
+    END DO
+  END IF
+IF (CPPKEY_IOPHYS_WK) THEN
+  IF (.not.phys_sub) CALL iophys_ecrit('wape2_b',1,'wape2_b','J/kg',wape2)
+END IF
+
+
+  DO k = 1, klev
+    DO i = 1, klon
+      ! cc nrlmd        IF ( wk_adv(i) .AND. wape2(i) .LT. 0.) THEN
+      IF (ok_qx_qw(i) .AND. wape2(i)<0.) THEN
+        ! cc
+        deltatw(i, k) = 0.
+        deltaqw(i, k) = 0.
+        dth(i, k) = 0.
+        d_deltatw2(i,k) = -deltatw0(i,k)
+        d_deltaqw2(i,k) = -deltaqw0(i,k)
+      END IF
+    END DO
+  END DO
+
+
+  DO i = 1, klon
+    ! cc nrlmd       IF ( wk_adv(i)) THEN
+    IF (ok_qx_qw(i)) THEN
+      ! cc
+      IF (wape2(i)<0.) THEN
+        wape2(i) = 0.
+        cstar2(i) = 0.
+        hw(i) = hwmin
+!jyg<
+!!      sigmaw(i) = amax1(sigmad, sigd_con(i))
+      sigmaw_targ = max(sigmad, sigd_con(i))
+      d_sig_bnd2(i) = d_sig_bnd2(i) + sigmaw_targ - sigmaw(i)
+      d_sigmaw2(i) = d_sigmaw2(i) + sigmaw_targ - sigmaw(i)
+      sigmaw(i) = sigmaw_targ
+!
+      d_asig_bnd2(i) = d_asig_bnd2(i) + sigmaw_targ - asigmaw(i)
+      d_asigmaw2(i) = d_asigmaw2(i) + sigmaw_targ - asigmaw(i)
+      asigmaw(i) = sigmaw_targ
+!>jyg
+        fip(i) = 0.
+        gwake(i) = .FALSE.
+      ELSE
+        IF (prt_level>=10) PRINT *, 'wape2>0'
+        cstar2(i) = stark*sqrt(2.*wape2(i))
+        gwake(i) = .TRUE.
+      END IF
+IF (CPPKEY_IOPHYS_WK) THEN
+  IF (.not.phys_sub) CALL iophys_ecrit('cstar2',1,'cstar2','J/kg',cstar2)
+END IF
+    END IF  ! (ok_qx_qw(i))
+  END DO
+
+  DO i = 1, klon
+    ! cc nrlmd       IF ( wk_adv(i)) THEN
+    IF (ok_qx_qw(i)) THEN
+      ! cc
+      ktopw(i) = ktop(i)
+    END IF
+  END DO
+
+  DO i = 1, klon
+    ! cc nrlmd       IF ( wk_adv(i)) THEN
+    IF (ok_qx_qw(i)) THEN
+      ! cc
+      IF (ktopw(i)>0 .AND. gwake(i)) THEN
+
+        ! jyg1     Utilisation d'un h_efficace constant ( ~ feeding layer)
+        ! cc       heff = 600.
+        ! Utilisation de la hauteur hw
+        ! c       heff = 0.7*hw
+        heff(i) = hw(i)
+
+        fip(i) = 0.5*rho(i, ktopw(i))*cstar2(i)**3*heff(i)*2* &
+          sqrt(sigmaw(i)*wdens(i)*3.14)
+        fip(i) = alpk*fip(i)
+        ! jyg2
+      ELSE
+        fip(i) = 0.
+      END IF
+    END IF
+  END DO
+    IF (iflag_wk_pop_dyn >= 3) THEN
+IF (CPPKEY_IOPHYS_WK) THEN
+      IF (.not.phys_sub) THEN
+       CALL iophys_ecrit('fip',1,'fip','J/kg',fip)
+       CALL iophys_ecrit('hw',1,'hw','J/kg',hw)
+       CALL iophys_ecrit('ptop',1,'ptop','J/kg',ptop)
+       CALL iophys_ecrit('wdens',1,'wdens','J/kg',wdens)
+       CALL iophys_ecrit('awdens',1,'awdens','m',awdens)
+       CALL iophys_ecrit('sigmaw',1,'sigmaw','m',sigmaw)
+       CALL iophys_ecrit('asigmaw',1,'asigmaw','m',asigmaw)
+!   
+       CALL iophys_ecrit('rad_wk',1,'rad_wk','J/kg',rad_wk)
+       CALL iophys_ecrit('arad_wk',1,'arad_wk','J/kg',arad_wk)
+       CALL iophys_ecrit('irad_wk',1,'irad_wk','J/kg',irad_wk)
+!   
+       call iophys_ecrit('d_wdens2',1,'d_wdens2','',d_wdens2)
+       call iophys_ecrit('d_dens_gen2',1,'d_dens_gen2','',d_dens_gen2)
+       call iophys_ecrit('d_dens_death2',1,'d_dens_death2','',d_dens_death2)
+       call iophys_ecrit('d_dens_col2',1,'d_dens_col2','',d_dens_col2)
+       call iophys_ecrit('d_dens_bnd2',1,'d_dens_bnd2','',d_dens_bnd2)
+!   
+       call iophys_ecrit('d_awdens2',1,'d_awdens2','',d_awdens2)
+       call iophys_ecrit('d_adens_death2',1,'d_adens_death2','',d_adens_death2)
+       call iophys_ecrit('d_adens_icol2',1,'d_adens_icol2','',d_adens_icol2)
+       call iophys_ecrit('d_adens_acol2',1,'d_adens_acol2','',d_adens_acol2)
+       call iophys_ecrit('d_adens_bnd2',1,'d_adens_bnd2','',d_adens_bnd2)
+!   
+       CALL iophys_ecrit('d_sigmaw2',1,'d_sigmaw2','',d_sigmaw2)
+       CALL iophys_ecrit('d_sig_gen2',1,'d_sig_gen2','m',d_sig_gen2)
+       CALL iophys_ecrit('d_sig_spread2',1,'d_sig_spread2','',d_sig_spread2)
+       CALL iophys_ecrit('d_sig_col2',1,'d_sig_col2','',d_sig_col2)
+       CALL iophys_ecrit('d_sig_death2',1,'d_sig_death2','',d_sig_death2)
+       CALL iophys_ecrit('d_sig_bnd2',1,'d_sig_bnd2','',d_sig_bnd2)
+!   
+       CALL iophys_ecrit('d_asigmaw2',1,'d_asigmaw2','',d_asigmaw2)
+       CALL iophys_ecrit('d_asig_spread2',1,'d_asig_spread2','m',d_asig_spread2)
+       CALL iophys_ecrit('d_asig_aicol2',1,'d_asig_aicol2','m',d_asig_aicol2)
+       CALL iophys_ecrit('d_asig_iicol2',1,'d_asig_iicol2','m',d_asig_iicol2)
+       CALL iophys_ecrit('d_asig_death2',1,'d_asig_death2','m',d_asig_death2)
+       CALL iophys_ecrit('d_asig_bnd2',1,'d_asig_bnd2','m',d_asig_bnd2)
+      ENDIF  ! (.not.phys_sub)
+END IF
+    ENDIF  ! (iflag_wk_pop_dyn >= 3)
+  ! Limitation de sigmaw
+
+  ! cc nrlmd
+  ! DO i=1,klon
+  ! IF (OK_qx_qw(i)) THEN
+  ! IF (sigmaw(i).GE.sigmaw_max) sigmaw(i)=sigmaw_max
+  ! ENDIF
+  ! ENDDO
+  ! cc
+
+  !jyg<
+  IF (iflag_wk_pop_dyn >= 1) THEN
+    DO i = 1, klon
+      kill_wake(i) = ((wape(i)>=wape2(i)) .AND. (wape2(i)<=wapecut)) .OR. (ktopw(i)<=2) .OR. &
+          .NOT. ok_qx_qw(i) .OR. (wdens(i) < wdensthreshold)
+!!          .NOT. ok_qx_qw(i) .OR. (wdens(i) < 2.*wdensmin)
+    ENDDO
+  ELSE  ! (iflag_wk_pop_dyn >= 1)
+    DO i = 1, klon
+      kill_wake(i) = ((wape(i)>=wape2(i)) .AND. (wape2(i)<=wapecut)) .OR. (ktopw(i)<=2) .OR. &
+          .NOT. ok_qx_qw(i)
+    ENDDO
+  ENDIF  ! (iflag_wk_pop_dyn >= 1)
+  !>jyg
+
+  DO k = 1, klev
+    DO i = 1, klon
+!!jyg      IF (((wape(i)>=wape2(i)) .AND. (wape2(i)<=wapecut)) .OR. (ktopw(i)<=2) .OR. &
+!!jyg          .NOT. ok_qx_qw(i)) THEN
+      IF (kill_wake(i)) THEN
+        ! cc
+        dtls(i, k) = 0.
+        dqls(i, k) = 0.
+        deltatw(i, k) = 0.
+        deltaqw(i, k) = 0.
+        d_deltatw2(i,k) = -deltatw0(i,k)
+        d_deltaqw2(i,k) = -deltaqw0(i,k)
+      END IF  ! (kill_wake(i))
+    END DO
+  END DO
+
+  DO i = 1, klon
+!!jyg    IF (((wape(i)>=wape2(i)) .AND. (wape2(i)<=wapecut)) .OR. (ktopw(i)<=2) .OR. &
+!!jyg        .NOT. ok_qx_qw(i)) THEN
+      IF (kill_wake(i)) THEN
+      ktopw(i) = 0
+      wape(i) = 0.
+      cstar(i) = 0.
+!!jyg   Outside subroutine "Wake" hw, wdens sigmaw and asigmaw are zero when there are no wakes
+!!      hw(i) = hwmin                       !jyg
+!!      sigmaw(i) = sigmad                  !jyg
+      hw(i) = 0.                            !jyg
+      fip(i) = 0.
+!
+!!      sigmaw(i) = 0.                        !jyg
+      sigmaw_targ = 0.
+      d_sig_bnd2(i) = d_sig_bnd2(i) + sigmaw_targ - sigmaw(i)
+!!      d_sigmaw2(i) = d_sigmaw2(i) + sigmaw_targ - sigmaw(i)
+      d_sigmaw2(i) = sigmaw_targ - sigmaw_in(i)      ! _in = correction jyg 20220124
+      sigmaw(i) = sigmaw_targ
+!
+      IF (iflag_wk_pop_dyn >= 3) THEN
+        sigmaw_targ = 0.
+        d_asig_bnd2(i) = d_asig_bnd2(i) + sigmaw_targ - asigmaw(i)
+!!        d_sigmaw2(i) = d_sigmaw2(i) + sigmaw_targ - sigmaw(i)
+        d_asigmaw2(i) = sigmaw_targ - asigmaw_in(i)      ! _in = correction jyg 20220124
+        asigmaw(i) = sigmaw_targ
+      ELSE
+        asigmaw(i) = 0.
+      ENDIF ! (iflag_wk_pop_dyn >= 3)
+!
+      IF (iflag_wk_pop_dyn >= 1) THEN
+!!        awdens(i) = 0.
+!!        wdens(i) = 0.
+        wdens_targ = 0.
+        d_dens_bnd2(i) = d_dens_bnd2(i) + wdens_targ - wdens(i)
+!!        d_wdens2(i) = wdens_targ - wdens(i)
+        d_wdens2(i) = wdens_targ - wdens_in(i)      ! jyg 20220916
+        wdens(i) = wdens_targ
+        wdens_targ = 0.
+!!jyg: bug fix : the d_adens_bnd2 computation must be before the update of awdens.
+        IF (iflag_wk_pop_dyn >= 2) THEN
+            d_adens_bnd2(i) = d_adens_bnd2(i) + wdens_targ - awdens(i)
+        ENDIF ! (iflag_wk_pop_dyn >= 2)
+!!        d_awdens2(i) = wdens_targ - awdens(i)
+        d_awdens2(i) = wdens_targ - awdens_in(i)    ! jyg 20220916
+        awdens(i) = wdens_targ
+!!        IF (iflag_wk_pop_dyn == 2) THEN
+!!            d_adens_bnd2(i) = d_adens_bnd2(i) + wdens_targ - awdens(i)
+!!        ENDIF ! (iflag_wk_pop_dyn == 2)
+      ENDIF  ! (iflag_wk_pop_dyn >= 1)
+    ELSE  ! (kill_wake(i))
+      wape(i) = wape2(i)
+      cstar(i) = cstar2(i)
+    END IF  ! (kill_wake(i))
+    ! c        print*,'wape wape2 ktopw OK_qx_qw =',
+    ! c     $          wape(i),wape2(i),ktopw(i),OK_qx_qw(i)
+  END DO
+
+  IF (prt_level>=10) THEN
+    PRINT *, 'wake-6, wape wape2 ktopw OK_qx_qw =', &
+                      wape(igout),wape2(igout),ktopw(igout),OK_qx_qw(igout)
+  ENDIF
+IF (CPPKEY_IOPHYS_WK) THEN
+  IF (.not.phys_sub) CALL iophys_ecrit('wape_c',1,'wape_c','J/kg',wape)
+END IF
+
+
+  ! -----------------------------------------------------------------
+  ! Get back to tendencies per second
+
+  DO k = 1, klev
+    DO i = 1, klon
+
+      ! cc nrlmd        IF ( wk_adv(i) .AND. k .LE. kupper(i)) THEN
+!jyg<
+!!      IF (ok_qx_qw(i) .AND. k<=kupper(i)) THEN
+      IF (ok_qx_qw(i)) THEN
+!>jyg
+        ! cc
+        dtls(i, k) = dtls(i, k)/dtime
+        dqls(i, k) = dqls(i, k)/dtime
+        d_deltatw2(i, k) = d_deltatw2(i, k)/dtime
+        d_deltaqw2(i, k) = d_deltaqw2(i, k)/dtime
+        d_deltat_gw(i, k) = d_deltat_gw(i, k)/dtime
+        ! c      print*,'k,dqls,omg,entr,detr',k,dqls(i,k),omg(i,k),entr(i,k)
+        ! c     $         ,death_rate(i)*sigmaw(i)
+      END IF
+    END DO
+  END DO
+!jyg<
+  IF (iflag_wk_pop_dyn >= 1) THEN
+    DO i = 1, klon
+        IF (ok_qx_qw(i)) THEN
+      d_sig_gen2(i) = d_sig_gen2(i)/dtime
+      d_sig_death2(i) = d_sig_death2(i)/dtime
+      d_sig_col2(i) = d_sig_col2(i)/dtime
+      d_sig_spread2(i) = d_sig_spread2(i)/dtime
+      d_sig_bnd2(i) = d_sig_bnd2(i)/dtime
+      d_sigmaw2(i) = d_sigmaw2(i)/dtime
+!
+      d_dens_gen2(i) = d_dens_gen2(i)/dtime
+      d_dens_death2(i) = d_dens_death2(i)/dtime
+      d_dens_col2(i) = d_dens_col2(i)/dtime
+      d_dens_bnd2(i) = d_dens_bnd2(i)/dtime
+      d_awdens2(i) = d_awdens2(i)/dtime
+      d_wdens2(i) = d_wdens2(i)/dtime
+        ENDIF
+    ENDDO
+    IF (iflag_wk_pop_dyn >= 2) THEN
+      DO i = 1, klon
+        IF (ok_qx_qw(i)) THEN
+        d_adens_death2(i) = d_adens_death2(i)/dtime
+        d_adens_icol2(i) = d_adens_icol2(i)/dtime
+        d_adens_acol2(i) = d_adens_acol2(i)/dtime
+        d_adens_bnd2(i) = d_adens_bnd2(i)/dtime
+        ENDIF
+      ENDDO
+      IF (iflag_wk_pop_dyn == 3) THEN
+       DO i = 1, klon
+          IF (ok_qx_qw(i)) THEN
+        d_asig_death2(i)  = d_asig_death2(i)/dtime
+        d_asig_iicol2(i)  = d_asig_iicol2(i)/dtime
+        d_asig_aicol2(i)  = d_asig_aicol2(i)/dtime
+        d_asig_spread2(i) = d_asig_spread2(i)/dtime
+        d_asig_bnd2(i) = d_asig_bnd2(i)/dtime
+          ENDIF
+       ENDDO
+      ENDIF ! (iflag_wk_pop_dyn == 3)  
+    ENDIF ! (iflag_wk_pop_dyn >= 2)  
+  ENDIF  ! (iflag_wk_pop_dyn >= 1)
+ 
+!>jyg
+
+ RETURN
+END SUBROUTINE wake
+
+SUBROUTINE wake_vec_modulation(nlon, nl, wk_adv, epsilon_loc, qb, d_qb, deltaqw, &
+    d_deltaqw, sigmaw, d_sigmaw, alpha)
+  ! ------------------------------------------------------
+  ! Dtermination du coefficient alpha tel que les tendances
+  ! corriges alpha*d_G, pour toutes les grandeurs G, correspondent
+  ! a une humidite positive dans la zone (x) et dans la zone (w).
+  ! ------------------------------------------------------
+  IMPLICIT NONE
+
+  ! Input
+  REAL qb(nlon, nl), d_qb(nlon, nl)
+  REAL deltaqw(nlon, nl), d_deltaqw(nlon, nl)
+  REAL sigmaw(nlon), d_sigmaw(nlon)
+  LOGICAL wk_adv(nlon)
+  INTEGER nl, nlon
+  ! Output
+  REAL alpha(nlon)
+  ! Internal variables
+  REAL zeta(nlon, nl)
+  REAL alpha1(nlon)
+  REAL x, a, b, c, discrim
+  REAL epsilon_loc
+  INTEGER i,k
+
+  DO k = 1, nl
+    DO i = 1, nlon
+      IF (wk_adv(i)) THEN
+        IF ((deltaqw(i,k)+d_deltaqw(i,k))>=0.) THEN
+          zeta(i, k) = 0.
+        ELSE
+          zeta(i, k) = 1.
+        END IF
+      END IF
+    END DO
+    DO i = 1, nlon
+      IF (wk_adv(i)) THEN
+        x = qb(i, k) + (zeta(i,k)-sigmaw(i))*deltaqw(i, k) + d_qb(i, k) + &
+          (zeta(i,k)-sigmaw(i))*d_deltaqw(i, k) - d_sigmaw(i) * &
+          (deltaqw(i,k)+d_deltaqw(i,k))
+        a = -d_sigmaw(i)*d_deltaqw(i, k)
+        b = d_qb(i, k) + (zeta(i,k)-sigmaw(i))*d_deltaqw(i, k) - &
+          deltaqw(i, k)*d_sigmaw(i)
+        c = qb(i, k) + (zeta(i,k)-sigmaw(i))*deltaqw(i, k) + epsilon_loc
+        discrim = b*b - 4.*a*c
+        ! print*, 'x, a, b, c, discrim', x, a, b, c, discrim
+        IF (a+b>=0.) THEN !! Condition suffisante pour la positivite de ovap
+          alpha1(i) = 1.
+        ELSE
+          IF (x>=0.) THEN
+            alpha1(i) = 1.
+          ELSE
+            IF (a>0.) THEN
+              alpha1(i) = 0.9*min( (2.*c)/(-b+sqrt(discrim)),  &
+                                   (-b+sqrt(discrim))/(2.*a) )
+            ELSE IF (a==0.) THEN
+              alpha1(i) = 0.9*(-c/b)
+            ELSE
+              ! print*,'a,b,c discrim',a,b,c discrim
+              alpha1(i) = 0.9*max( (2.*c)/(-b+sqrt(discrim)),  &
+                                   (-b+sqrt(discrim))/(2.*a))
+            END IF
+          END IF
+        END IF
+        alpha(i) = min(alpha(i), alpha1(i))
+      END IF
+    END DO
+  END DO
+
+  RETURN
+END SUBROUTINE wake_vec_modulation
+
+
+
+SUBROUTINE pkupper (klon, klev, ptop, ph, p, pupper, kupper, &
+                    dth, hw_, rho, delta_t_min_in, &
+                    ktop, wk_adv, h_zzz, ptop1, ktop1)
+
+USE lmdz_wake_ini , ONLY : wk_pupper
+USE lmdz_wake_ini , ONLY : RG
+USE lmdz_wake_ini , ONLY : hwmin
+USE lmdz_wake_ini , ONLY : iflag_wk_new_ptop, wk_delta_t_min, wk_frac_int_delta_t
+USE lmdz_wake_ini , ONLY : wk_int_delta_t_min
+
+IMPLICIT NONE
+
+INTEGER,                              INTENT(IN) :: klon,klev
+REAL,       DIMENSION (klon,klev+1) , INTENT(IN) :: ph, p
+REAL,       DIMENSION (klon,klev+1) , INTENT(IN) :: rho
+LOGICAL,    DIMENSION (klon)        , INTENT(IN) :: wk_adv
+REAL,       DIMENSION (klon,klev+1) , INTENT(IN) :: dth
+REAL,                                 INTENT(IN) :: delta_t_min_in
+
+
+REAL,       DIMENSION (klon)  , INTENT(OUT)        :: hw_
+REAL,       DIMENSION (klon)  , INTENT(OUT)        :: ptop
+INTEGER,    DIMENSION (klon)  , INTENT(OUT)        :: Ktop
+REAL,       DIMENSION (klon)  , INTENT(OUT)        :: pupper
+INTEGER,    DIMENSION (klon)  , INTENT(OUT)        :: kupper
+REAL,       DIMENSION (klon)  , INTENT(OUT)        :: h_zzz       !!
+REAL,       DIMENSION (klon)  , INTENT(OUT)        :: Ptop1      !!
+INTEGER,    DIMENSION (klon)  , INTENT(OUT)        :: ktop1      !!
+
+INTEGER :: i,k
+
+LOGICAL,    DIMENSION (klon)       :: wk_active
+REAL                               :: delta_t_min
+REAL,     DIMENSION (klon)         :: dthmin
+REAL,     DIMENSION (klon)         :: ptop_provis,ptop_new
+REAL,     DIMENSION (klon)         :: z, dz
+REAL,     DIMENSION (klon)         :: sum_dth
+
+INTEGER,     DIMENSION (klon)                     :: k_ptop_provis
+REAL,     DIMENSION (klon)                     :: zk_ptop_provis
+REAL,     DIMENSION (klon)                        :: omega        !!
+REAL,     DIMENSION (klon,klev+1)                 :: int_dth      !! 
+REAL,     DIMENSION (klon,klev+1)                 :: dzz          !!
+REAL,     DIMENSION (klon,klev+1)                 :: zzz          !!
+REAL,     DIMENSION (klon)                 :: frac_int_dth          !!
+REAL                                              :: ddd!!
+
+
+INTEGER, SAVE :: ipas=0
+
+
+
+!INTEGER, SAVE :: compte=0
+
+! LJYF : a priori z, dz sum_dth sont aussi des variables internes
+! Les eliminer apres verification convergence numerique
+
+!compte=compte+1
+!print*,'compte=',compte
+
+    ! Determine Ptop from buoyancy integral
+    ! ---------------------------------------
+
+    ! -     1/ Pressure of the level where dth changes sign.
+    !print*,'WAKE LJYF'
+
+
+if (iflag_wk_new_ptop==0) then
+    delta_t_min=delta_t_min_in
+else
+    delta_t_min=wk_delta_t_min
+endif
+
+    DO i = 1, klon
+        ptop_provis(i) = ph(i, 1)
+        k_ptop_provis(i) = 1
+    END DO
+
+    DO k = 2, klev
+      DO i = 1, klon
+        IF (wk_adv(i) .AND. ptop_provis(i)==ph(i,1) .AND. &
+! LJYF changer :           dth(i,k)>=-delta_t_min .AND. dth(i,k-1)<-delta_t_min) THEN
+            dth(i,k)>-delta_t_min .AND. dth(i,k-1)<-delta_t_min) THEN
+          ptop_provis(i) = ((dth(i,k)+delta_t_min)*p(i,k-1) - &
+                            (dth(i,k-1)+delta_t_min)*p(i,k))/(dth(i,k)-dth(i,k-1))
+          k_ptop_provis(i) = k
+        END IF
+      END DO
+    END DO
+
+
+
+    ! -     2/ dth integral
+
+    DO i = 1, klon
+      IF (wk_adv(i)) THEN !!! nrlmd
+        sum_dth(i) = 0.
+        dthmin(i) = -delta_t_min
+        z(i) = 0.
+      END IF
+    END DO
+
+    DO k = 1, klev
+      DO i = 1, klon
+        IF (wk_adv(i)) THEN
+          dz(i) = -(amax1(ph(i,k+1),ptop_provis(i))-ph(i,k))/(rho(i,k)*RG)
+          IF (dz(i)>0) THEN
+            z(i) = z(i) + dz(i)
+            sum_dth(i) = sum_dth(i) + dth(i, k)*dz(i)
+            dthmin(i) = amin1(dthmin(i), dth(i,k))
+          END IF
+        END IF
+      END DO
+    END DO
+
+    ! -     3/ height of triangle with area= sum_dth and base = dthmin
+
+    DO i = 1, klon
+      IF (wk_adv(i)) THEN
+        hw_(i) = 2.*sum_dth(i)/amin1(dthmin(i), -0.5)
+        hw_(i) = amax1(hwmin, hw_(i))
+      END IF
+    END DO
+
+    ! -     4/ now, get Ptop
+
+    DO i = 1, klon
+      IF (wk_adv(i)) THEN !!! nrlmd
+        ktop(i) = 0
+        z(i) = 0.
+      END IF
+    END DO
+
+    DO k = 1, klev
+      DO i = 1, klon
+        IF (wk_adv(i)) THEN
+          dz(i) = amin1(-(ph(i,k+1)-ph(i,k))/(rho(i,k)*RG), hw_(i)-z(i))
+          IF (dz(i)>0) THEN
+            z(i) = z(i) + dz(i)
+            ptop(i) = ph(i, k) - rho(i, k)*RG*dz(i)
+            ktop(i) = k
+          END IF
+        END IF
+      END DO
+    END DO
+
+    ! 4.5/Correct ktop and ptop
+
+    DO i = 1, klon
+        ptop_new(i) = ptop(i)
+    END DO
+
+    DO k = klev, 2, -1
+      DO i = 1, klon
+        ! IM v3JYG; IF (k .GE. ktop(i)
+        IF (wk_adv(i) .AND. k<=ktop(i) .AND. ptop_new(i)==ptop(i) .AND. &
+! LJYF changer :           dth(i,k)>=-delta_t_min .AND. dth(i,k-1)<-delta_t_min) THEN
+            dth(i,k)>=-delta_t_min .AND. dth(i,k-1)<-delta_t_min) THEN
+          ptop_new(i) = ((dth(i,k)+delta_t_min)*p(i,k-1) - &
+                         (dth(i,k-1)+delta_t_min)*p(i,k))/(dth(i,k)-dth(i,k-1))
+        END IF
+      END DO
+    END DO
+
+
+    DO i = 1, klon
+        ptop(i) = ptop_new(i)
+    END DO
+
+    DO k = klev, 1, -1
+      DO i = 1, klon
+        IF (wk_adv(i)) THEN !!! nrlmd
+          IF (ph(i,k+1)<ptop(i)) ktop(i) = k
+        END IF
+      END DO
+    END DO
+  
+!  IF (prt_level>=10) THEN
+!    PRINT *, 'wake-3, ktop(igout), kupper(igout) ', ktop(igout), kupper(igout)
+!  ENDIF
+
+    ! -----------------------------------------------------------------------
+    ! nouveau calcul de hw et ptop
+    ! -----------------------------------------------------------------------
+!if (iflag_wk_new_ptop>0) then
+do i=1,klon
+   ptop1(i)=ph(i,1)
+   ktop1(i)=1
+   h_zzz(i)=0.
+enddo
+    
+IF (iflag_wk_new_ptop/=0) THEN
+    
+    int_dth(1:klon,1:klev+1)=0.
+    DO i = 1, klon
+       IF (wk_adv(i)) THEN 
+          int_dth(i,1) = 0.
+      END IF
+    END DO
+    
+    if (abs(iflag_wk_new_ptop) == 1 ) then
+        DO k = 2, klev+1
+           Do i = 1, klon
+              IF (wk_adv(i)) THEN
+                 if (k<=k_ptop_provis(i)) then
+                      ddd=dth(i,k-1)*(ph(i,k-1) - max(ptop_provis(i),ph(i,k)))
+                      !ddd=dth(i,k-1)*(ph(i,k-1) - ph(i,k))
+                 else
+                      ddd=0.
+                 endif             
+                 int_dth(i,k) = int_dth(i,k-1) + ddd
+              !ELSE
+              !   int_dth(i,k) = 0.
+              END IF
+           END DO
+        END DO
+    else
+        k_ptop_provis(:)=klev+1
+        dthmin(:)=dth(:,1)
+        ! calcul de l'int??grale de dT * dP jusqu'au dernier
+        ! niveau avec dT<0. (en s'assurant qu'on a bien un 
+        ! dT negatif plus bas)
+        DO k = 1, klev
+           DO i = 1, klon
+              dthmin(i)=min(dthmin(i),dth(i,k))
+              ddd=dth(i,k)*(ph(i,k)-ph(i,k+1))
+              if (dthmin(i)<0.) then
+                  if (k>=k_ptop_provis(i)) then
+                      ddd=0.
+                  else if (dth(i,k)>=0.) then
+                      ddd=0.
+                      k_ptop_provis(i)=k+1
+                  endif
+              endif
+              int_dth(i,k+1) = int_dth(i,k)+ ddd
+           ENDDO
+        ENDDO
+
+        DO i = 1, klon
+           if ( k_ptop_provis(i)==klev+1 .or. .not. wk_adv(i)) then
+                k_ptop_provis(i)=1
+           endif
+        ENDDO
+    endif ! (abs(iflag_wk_new_ptop) == 1 )
+   ! print*, 'xxx, int_dth', (k,int_dth(1,k),k=1,klev)
+   ! print*, 'xxx, k_ptop_provis', k_ptop_provis(1)
+   
+
+ 
+    ! On se limite ?? des poches avec integrale dT * dp < -wk_int_delta_t_min
+    do i=1,klon
+          if (int_dth(i,k_ptop_provis(i)) > -wk_int_delta_t_min .or. k_ptop_provis(i)==1) then
+          !if (1==0) then
+             wk_active(i)=.false.
+             ptop(i)=ph(i,1)
+             ktop(i)=1
+             hw_(i)=0.
+          else
+             wk_active(i)=wk_adv(i)
+          endif
+    enddo
+
+    DO i=1,klon
+       IF (wk_active(i)) THEN
+        frac_int_dth(i)=wk_frac_int_delta_t*int_dth(i,k_ptop_provis(i))
+       ENDIF
+    ENDDO
+    DO k = 1,klev
+       DO i =1, klon
+!         print*,ipas,'yyy ',k,int_dth(i,k),frac_int_dth(i)
+          IF (wk_active(i)) THEN
+            IF (int_dth(i,k)>=frac_int_dth(i)) THEN
+              ktop1(i) = min(k, k_ptop_provis(i))
+              !ktop1(i) = k
+              !print*,ipas,'yyy ktop1= ',ktop1
+            ENDIF
+          ENDIF
+       END DO
+    END DO
+    !print*, 'LAMINE'
+    
+    DO i = 1, klon
+       IF (wk_active(i)) THEN
+           !print*, ipas,'xxx1, int_dth(i,ktop1(i)), frac_int_dth(i), int_dth(i,ktop1(i)+1) ',ktop1
+           ddd=int_dth(i,ktop1(i)+1)-int_dth(i,ktop1(i))
+           if (ddd==0.) then
+              omega(i)=0.
+           else
+              omega(i) = (frac_int_dth(i) - int_dth(i,ktop1(i)))/ddd
+           endif
+           !! print*,'OMEGA ',omega(i)
+       END IF
+    END DO
+    
+    !! print*, 'xxx'
+    DO i = 1, klon
+       IF (wk_active(i)) THEN
+      ! print*, 'xxx, int_dth(i,ktop1(i)), frac_int_dth(i), int_dth(i,ktop1(i)+1) ', &
+      !               int_dth(i,ktop1(i)), frac_int_dth(i), int_dth(i,ktop1(i)+1)
+      ! print*, 'xxx, omega(i), ph(i,ktop1(i)), ph(i,ktop1(i)+1) ',  &
+      !e               omega(i), ph(i,ktop1(i)), ph(i,ktop1(i)+1)
+          ptop1(i) = min((1 - omega(i))*ph(i,ktop1(i)) + omega(i)*ph(i,ktop1(i)+1), ph(i,1))
+      END IF
+    END DO
+    
+    DO i=1, klon
+       IF (wk_active(i)) THEN 
+           zzz(i, 1) = 0
+       END IF
+     END DO
+    DO k = 1, klev
+       DO i = 1, klon 
+           IF (wk_active(i)) THEN         
+              dzz(i,k) = (ph(i,k) - ph(i,k+1))/(rho(i,k)*RG)
+              zzz(i,k+1) = zzz(i,k) + dzz(i,k)
+           END IF
+       END DO
+    END DO
+    
+    DO i =1, klon
+       IF (wk_active(i)) THEN
+           h_zzz(i) = max((1- omega(i))*zzz(i,ktop1(i)) + omega(i)*zzz(i,ktop1(i)+1), hwmin)
+       END IF
+    END DO
+
+
+ENDIF ! (iflag_wk_new_ptop/=0)
+
+!if (iflag_wk_new_ptop==2) then
+IF (iflag_wk_new_ptop>0) THEN 
+   do i=1,klon
+      ptop(i)=ptop1(i)
+      ktop(i)=ktop1(i)
+      hw_(i)=h_zzz(i)
+   enddo
+
+!endif
+ENDIF
+
+ kupper = 0
+ 
+IF (wk_pupper<1.) THEN
+ ! Choose an integration bound well above wake top
+  ! -----------------------------------------------------------------
+
+  ! Pupper = 50000.  ! melting level
+  ! Pupper = 60000.
+  ! Pupper = 80000.  ! essais pour case_e
+  DO i = 1, klon
+  !  pupper(i) = 0.6*ph(i, 1)
+    pupper(i) = wk_pupper*ph(i, 1)
+    pupper(i) = max(pupper(i), 45000.)
+    ! cc        Pupper(i) = 60000.
+  END DO
+
+ELSE
+  DO i=1, klon
+     ! pupper(i) = wk_pupper*ptop(i)+(1.-wk_pupper)*ph(i, 1) 
+     !  pupper(i) = min( wk_pupper*ptop(i)+(1.-wk_pupper)*ph(i, 1) , ptop(i)-50.) 
+      pupper(i) = min( wk_pupper*ptop(i)+(1.-wk_pupper)*ph(i, 1) , ptop(i)-5000.) 
+  END DO
+END IF
+ 
+  ! -5/ Determination de kupper
+
+  DO k = klev, 1, -1
+    DO i = 1, klon
+      IF (ph(i,k+1)<pupper(i)) kupper(i) = k
+    END DO
+  END DO
+
+  ! On evite kupper = 1 et kupper = klev
+  DO i = 1, klon
+    kupper(i) = max(kupper(i), 2)
+    kupper(i) = min(kupper(i), klev-1)
+  END DO 
+  !---------- FIN nouveau calcul hw et ptop -------------------------------------
+
+IF (iflag_wk_new_ptop==999) THEN
+    DO i = 1, klon
+    hw_(i)=0.
+    ptop(i)=ph(i,1)
+    Ktop(i)=1
+    pupper(i)=ph(i,2)
+    kupper(i)=2
+    h_zzz(i)=0.
+    Ptop1(i)=ph(i,1)
+    ENDDO
+ENDIF
+
+zk_ptop_provis=k_ptop_provis
+
+    RETURN
+END SUBROUTINE pkupper
+
+
+SUBROUTINE wake_popdyn_1(klon, klev, dtime, cstar, tau_wk_inv, wgen, wdens, awdens, sigmaw, &
+                  wdensmin, &
+                  dtimesub, gfl, rad_wk, f_shear, drdt_pos, &
+                  d_awdens, d_wdens, d_sigmaw, &
+                  iflag_wk_act, wk_adv, cin, wape, &
+                  drdt, &
+                  d_dens_gen, d_dens_death, d_dens_col, d_dens_bnd, &
+                  d_sig_gen, d_sig_death, d_sig_col, d_sig_spread, d_sig_bnd, &
+                  d_wdens_targ, d_sigmaw_targ)
+                
+
+  USE lmdz_wake_ini , ONLY : wake_ini
+  USE lmdz_wake_ini , ONLY : prt_level,RG
+  USE lmdz_wake_ini , ONLY : stark, wdens_ref
+  USE lmdz_wake_ini , ONLY : tau_cv, rzero, aa0
+!!  USE lmdz_wake_ini , ONLY : iflag_wk_pop_dyn, wdensmin
+  USE lmdz_wake_ini , ONLY : iflag_wk_pop_dyn
+  USE lmdz_wake_ini , ONLY : sigmad, cstart, sigmaw_max
+  
+IMPLICIT NONE
+
+  INTEGER, INTENT(IN)                                   :: klon,klev
+  LOGICAL, DIMENSION (klon),        INTENT(IN)          :: wk_adv
+  REAL,                             INTENT(IN)          :: dtime
+  REAL,                             INTENT(IN)          :: dtimesub
+  REAL,                             INTENT(IN)          :: wdensmin
+  REAL, DIMENSION (klon),           INTENT(IN)          :: wgen
+  REAL, DIMENSION (klon),           INTENT(IN)          :: wdens
+  REAL, DIMENSION (klon),           INTENT(IN)          :: awdens
+  REAL, DIMENSION (klon),           INTENT(IN)          :: sigmaw
+  REAL, DIMENSION (klon),           INTENT(IN)          :: cstar
+  REAL, DIMENSION (klon),           INTENT(IN)          :: cin, wape
+  REAL, DIMENSION (klon),           INTENT(IN)          :: f_shear
+  INTEGER,                          INTENT(IN)          :: iflag_wk_act
+
+  
+  !
+ 
+  ! Tendencies of state variables (2 is appended to the names of fields which are the cumul of fields 
+  !                                 computed at each sub-timestep; e.g. d_wdens2 is the cumul of d_wdens)
+  REAL, DIMENSION (klon),           INTENT(OUT)         :: rad_wk
+  REAL, DIMENSION (klon),           INTENT(OUT)         :: gfl
+  REAL, DIMENSION (klon),           INTENT(OUT)         :: d_sigmaw, d_awdens, d_wdens
+  REAL, DIMENSION (klon),           INTENT(OUT)         :: drdt
+  ! Some components of the tendencies of state variables  
+  REAL, DIMENSION (klon),           INTENT(OUT)         :: d_sig_gen, d_sig_death, d_sig_col, d_sig_bnd
+  REAL, DIMENSION (klon),           INTENT(OUT)         :: d_sig_spread
+  REAL, DIMENSION (klon),           INTENT(OUT)         :: d_dens_gen, d_dens_death, d_dens_col, d_dens_bnd
+  REAL,                             INTENT(OUT)         :: d_wdens_targ, d_sigmaw_targ
+ 
+  
+  REAL                                                  :: delta_t_min
+  INTEGER                                               :: i, k
+  REAL                                                  :: wdens0
+  ! IM 080208
+  LOGICAL, DIMENSION (klon)                             :: gwake
+  
+   ! Variables liees a la dynamique de population
+  REAL, DIMENSION(klon)                                 :: act
+  REAL, DIMENSION(klon)                                 :: tau_wk_inv
+  REAL, DIMENSION(klon)                                 :: wape1_act, wape2_act
+  LOGICAL, DIMENSION (klon)                             :: kill_wake
+  REAL                                                  :: drdt_pos
+  REAL                                                  :: tau_wk_inv_min
+  
+     
+
+      IF (iflag_wk_act == 0) THEN
+        act(:) = 0.
+      ELSEIF (iflag_wk_act == 1) THEN
+        act(:) = 1.
+      ELSEIF (iflag_wk_act ==2) THEN
+      DO i = 1, klon
+        IF (wk_adv(i)) THEN
+          wape1_act(i) = abs(cin(i))
+          wape2_act(i) = 2.*wape1_act(i) + 1.
+          act(i) = min(1., max(0., (wape(i)-wape1_act(i)) / (wape2_act(i)-wape1_act(i)) ))
+        ENDIF  ! (wk_adv(i))
+      ENDDO
+      ENDIF  ! (iflag_wk_act ==2)
+
+      DO i = 1, klon
+        IF (wk_adv(i)) THEN
+          rad_wk(i) = max( sqrt(sigmaw(i)/(3.14*wdens(i))) , rzero)
+          gfl(i)  = 2.*sqrt(3.14*wdens(i)*sigmaw(i))
+        END IF
+      END DO
+
+      DO i = 1, klon
+        IF (wk_adv(i)) THEN
+!!          tau_wk(i) = max(rad_wk(i)/(3.*cstar(i))*((cstar(i)/cstart)**1.5 - 1), 100.)
+          tau_wk_inv(i) = max( (3.*cstar(i))/(rad_wk(i)*((cstar(i)/cstart)**1.5 - 1)), 0.)
+          tau_wk_inv_min = min(tau_wk_inv(i), 1./dtimesub)
+          drdt(i) = (cstar(i) - wgen(i)*(sigmaw(i)/wdens(i)-aa0)/gfl(i)) / &
+                    (1 + 2*f_shear(i)*(2.*sigmaw(i)-aa0*wdens(i)) - 2.*sigmaw(i))
+!!                    (1 - 2*sigmaw(i)*(1.-f_shear(i)))
+          drdt_pos=max(drdt(i),0.)
+
+!!          d_wdens(i) = ( wgen(i)*(1.+2.*(sigmaw(i)-sigmad)) &
+!!                     - wdens(i)*tau_wk_inv_min &
+!!                     - 2.*gfl(i)*wdens(i)*Cstar(i) )*dtimesub
+!jyg+mlt<
+          d_awdens(i) = ( wgen(i) - (1./tau_cv)*(awdens(i) - act(i)*wdens(i)) )*dtimesub
+          d_dens_gen(i) = wgen(i)
+          d_dens_death(i) = - (wdens(i)-awdens(i))*tau_wk_inv_min 
+          d_dens_col(i) =  -2.*wdens(i)*gfl(i)*drdt_pos 
+          d_dens_gen(i) =  d_dens_gen(i)*dtimesub
+          d_dens_death(i) = d_dens_death(i)*dtimesub
+          d_dens_col(i) =  d_dens_col(i)*dtimesub 
+
+          d_wdens(i) = d_dens_gen(i)+d_dens_death(i)+d_dens_col(i)
+!!          d_wdens(i) = ( wgen(i) - (wdens(i)-awdens(i))*tau_wk_inv_min -  &
+!!                         2.*wdens(i)*gfl(i)*drdt_pos )*dtimesub
+!>jyg+mlt
+!
+!jyg<
+          d_wdens_targ = max(d_wdens(i), wdensmin-wdens(i))
+!!          d_dens_bnd(i) = d_dens_bnd(i) + d_wdens_targ - d_wdens(i)
+          d_dens_bnd(i) = d_wdens_targ - d_wdens(i)
+          d_wdens(i) = d_wdens_targ
+!!          d_wdens(i) = max(d_wdens(i), wdensmin-wdens(i))
+!>jyg
+
+!jyg+mlt<
+!!          d_sigmaw(i) = ( (1.-2*f_shear(i)*sigmaw(i))*(gfl(i)*Cstar(i)+wgen(i)*sigmad/wdens(i)) &
+!!                      + 2.*f_shear(i)*wgen(i)*sigmaw(i)**2/wdens(i) &
+!!                      - sigmaw(i)*tau_wk_inv_min )*dtimesub
+          d_sig_gen(i) = wgen(i)*aa0
+          d_sig_death(i) = - sigmaw(i)*(1.-awdens(i)/wdens(i))*tau_wk_inv_min
+!!        
+          
+          d_sig_col(i) = - 2*f_shear(i)*sigmaw(i)*gfl(i)*drdt_pos
+          d_sig_col(i) = - 2*f_shear(i)*(2.*sigmaw(i)-wdens(i)*aa0)*gfl(i)*drdt_pos
+          d_sig_spread(i) = gfl(i)*cstar(i)
+          d_sig_gen(i) =  d_sig_gen(i)*dtimesub
+          d_sig_death(i) = d_sig_death(i)*dtimesub
+          d_sig_col(i) =  d_sig_col(i)*dtimesub 
+          d_sig_spread(i) =  d_sig_spread(i)*dtimesub 
+          d_sigmaw(i) =  d_sig_gen(i) + d_sig_death(i) + d_sig_col(i) + d_sig_spread(i)
+!>jyg+mlt
+!
+!jyg<
+          d_sigmaw_targ = max(d_sigmaw(i), sigmad-sigmaw(i))
+!!          d_sig_bnd(i) = d_sig_bnd(i) + d_sigmaw_targ - d_sigmaw(i)
+!!          d_sig_bnd_provis(i) = d_sigmaw_targ - d_sigmaw(i)
+          d_sig_bnd(i) = d_sigmaw_targ - d_sigmaw(i)
+          d_sigmaw(i) = d_sigmaw_targ
+!!          d_sigmaw(i) = max(d_sigmaw(i), sigmad-sigmaw(i))
+!>jyg
+        ENDIF
+      ENDDO
+
+      IF (prt_level >= 10) THEN
+        print *,'wake, cstar(1), cstar(1)/cstart, rad_wk(1), tau_wk_inv(1), drdt(1) ', &
+                       cstar(1), cstar(1)/cstart, rad_wk(1), tau_wk_inv(1), drdt(1)
+        print *,'wake, wdens(1), awdens(1), act(1), d_awdens(1) ', &
+                       wdens(1), awdens(1), act(1), d_awdens(1)
+        print *,'wake, wgen, -(wdens-awdens)*tau_wk_inv, -2.*wdens*gfl*drdt_pos, d_wdens ', &
+                       wgen(1), -(wdens(1)-awdens(1))*tau_wk_inv(1), -2.*wdens(1)*gfl(1)*drdt_pos, d_wdens(1)
+        print *,'wake, d_sig_gen(1), d_sig_death(1), d_sig_col(1), d_sigmaw(1) ', &
+                       d_sig_gen(1), d_sig_death(1), d_sig_col(1), d_sigmaw(1)
+      ENDIF
+    
+    RETURN 
+    END SUBROUTINE wake_popdyn_1
+    
+    SUBROUTINE wake_popdyn_2 ( klon, klev, wk_adv, dtimesub, wgen, &
+                             wdensmin, &
+                             sigmaw, wdens, awdens, &   !! states variables
+                             gfl, cstar, cin, wape, rad_wk, &
+                             d_sigmaw, d_wdens, d_awdens, &  !! tendences 
+                             cont_fact, &
+                             d_sig_gen, d_sig_death, d_sig_col, d_sig_spread, d_sig_bnd, &
+                             d_dens_gen, d_dens_death, d_dens_col, d_dens_bnd, &
+                             d_adens_death, d_adens_icol, d_adens_acol, d_adens_bnd )
+                             
+                                             
+
+  USE lmdz_wake_ini , ONLY : wake_ini
+  USE lmdz_wake_ini , ONLY : prt_level,RG
+  USE lmdz_wake_ini , ONLY : stark, wdens_ref
+  USE lmdz_wake_ini , ONLY : tau_cv, rzero, aa0
+!!  USE lmdz_wake_ini , ONLY : iflag_wk_pop_dyn, wdensmin
+  USE lmdz_wake_ini , ONLY : iflag_wk_pop_dyn
+  USE lmdz_wake_ini , ONLY : sigmad, cstart, sigmaw_max
+  
+IMPLICIT NONE
+
+  INTEGER, INTENT(IN)                                   :: klon,klev
+  LOGICAL, DIMENSION (klon),        INTENT(IN)          :: wk_adv
+  REAL,                             INTENT(IN)          :: dtimesub
+  REAL,                             INTENT(IN)          :: wdensmin
+  REAL, DIMENSION (klon),           INTENT(IN)          :: wgen      !! B = birth rate of wakes
+  REAL, DIMENSION (klon),           INTENT(INOUT)       :: sigmaw    !! sigma = fractional area of wakes 
+  REAL, DIMENSION (klon),           INTENT(INOUT)       :: wdens     !! D = number of wakes per unit area 
+  REAL, DIMENSION (klon),           INTENT(INOUT)       :: awdens    !! A = number of active wakes per unit area
+  REAL, DIMENSION (klon),           INTENT(IN)          :: cstar     !! C* = spreading velocity of wakes
+  REAL, DIMENSION (klon),           INTENT(IN)          :: cin, wape  ! RM : A Faire disparaitre
+
+!  
+  REAL, DIMENSION (klon),           INTENT(OUT)         :: rad_wk    !! r = wake radius
+  REAL, DIMENSION (klon),           INTENT(OUT)         :: gfl       !! Lg = gust front lenght per unit area
+  REAL, DIMENSION (klon),           INTENT(OUT)         :: d_sigmaw, d_wdens, d_awdens
+  REAL, DIMENSION (klon),           INTENT(OUT)         :: cont_fact  !! RM facteur de contact = 2 pi * rad * C*
+  ! Some components of the tendencies of state variables  
+  REAL, DIMENSION (klon),           INTENT(OUT)         :: d_sig_gen, d_sig_death, d_sig_col, d_sig_spread, d_sig_bnd
+  REAL, DIMENSION (klon),           INTENT(OUT)         :: d_dens_gen, d_dens_death, d_dens_col, d_dens_bnd
+  REAL, DIMENSION (klon),           INTENT(OUT)         :: d_adens_death, d_adens_icol, d_adens_acol, d_adens_bnd
+
+
+!! internal variables
+  
+  INTEGER                                               :: i, k
+  REAL, DIMENSION (klon)                                :: tau_wk_inv      !! tau = life time of wakes
+  REAL                                                  :: tau_wk_inv_min
+  REAL, DIMENSION (klon)                                :: tau_prime       !! tau_prime = life time of actives wakes
+  REAL                                                  :: d_wdens_targ, d_sigmaw_targ
+  
+
+!! Equations
+!! dD/dt = B - (D-A)/tau - f D^2
+!! dA/dt = B - A/tau_prime + f (D-A)^2 - f A^2
+!! dsigma/dt = B a0 - sigma/D (D-A)/tau + Lg C* - f (D-A)^2 (sigma/D-a0)
+!!
+!! f = 2 (B (a0-sigma/D) + Lg C*) / (2 (D-A)^2 (2 sigma/D-a0) + D (1-2 sigma))
+
+
+      DO i = 1, klon
+        IF (wk_adv(i)) THEN
+          rad_wk(i) = max( sqrt(sigmaw(i)/(3.14*wdens(i))) , rzero)
+          gfl(i)  = 2.*sqrt(3.14*wdens(i)*sigmaw(i))
+        END IF
+      END DO
+
+
+      DO i = 1, klon
+        IF (wk_adv(i)) THEN
+!!          tau_wk(i) = max(rad_wk(i)/(3.*cstar(i))*((cstar(i)/cstart)**1.5 - 1), 100.)
+          tau_wk_inv(i) = max( (3.*cstar(i))/(rad_wk(i)*((cstar(i)/cstart)**1.5 - 1)), 0.)
+          tau_wk_inv_min = min(tau_wk_inv(i), 1./dtimesub)
+          tau_prime(i) = tau_cv
+!!          cont_fact(i) = 2.*(wgen(i)*(aa0-sigmaw(i)/wdens(i)) + gfl(i)*cstar(i)) / &
+!!                             (2.*(wdens(i)-awdens(i))**2*(2.*sigmaw(i)/wdens(i) - aa0) + wdens(i)*(1.-2.*sigmaw(i)))
+!!          cont_fact(i) = 2.*3.14*rad_wk(i)*cstar(i)     ! bug
+!!          cont_fact(i) = 4.*3.14*rad_wk(i)*cstar(i)
+          cont_fact(i) = 2.*gfl(i)*cstar(i)/wdens(i)
+
+          d_sig_gen(i) = wgen(i)*aa0
+          d_sig_death(i) = - sigmaw(i)*(1.-awdens(i)/wdens(i))*tau_wk_inv_min
+          d_sig_col(i) = - cont_fact(i)*(wdens(i)-awdens(i))**2*(2.*sigmaw(i)/wdens(i)-aa0)
+          d_sig_spread(i) = gfl(i)*cstar(i)
+!
+          d_sig_gen(i) =  d_sig_gen(i)*dtimesub
+          d_sig_death(i) = d_sig_death(i)*dtimesub
+          d_sig_col(i) =  d_sig_col(i)*dtimesub 
+          d_sig_spread(i) =  d_sig_spread(i)*dtimesub 
+          d_sigmaw(i) =  d_sig_gen(i) + d_sig_death(i) + d_sig_col(i) + d_sig_spread(i)
+
+         
+          d_sigmaw_targ = max(d_sigmaw(i), sigmad-sigmaw(i))
+!!          d_sig_bnd(i) = d_sig_bnd(i) + d_sigmaw_targ - d_sigmaw(i)
+!!          d_sig_bnd_provis(i) = d_sigmaw_targ - d_sigmaw(i)
+          d_sig_bnd(i) = d_sigmaw_targ - d_sigmaw(i)
+          d_sigmaw(i) = d_sigmaw_targ
+!!          d_sigmaw(i) = max(d_sigmaw(i), sigmad-sigmaw(i))
+         
+         
+          d_dens_gen(i) = wgen(i)
+          d_dens_death(i) = - (wdens(i)-awdens(i))*tau_wk_inv_min 
+          d_dens_col(i) =  - cont_fact(i)*wdens(i)**2
+! 
+          d_dens_gen(i) =  d_dens_gen(i)*dtimesub
+          d_dens_death(i) = d_dens_death(i)*dtimesub
+          d_dens_col(i) =  d_dens_col(i)*dtimesub 
+          d_wdens(i) = d_dens_gen(i) + d_dens_death(i) + d_dens_col(i)
+
+
+          d_adens_death(i) = -awdens(i)/tau_prime(i)
+          d_adens_icol(i) = cont_fact(i)*(wdens(i)-awdens(i))**2
+          d_adens_acol(i) = - cont_fact(i)*awdens(i)**2
+!
+          d_adens_death(i) =  d_adens_death(i)*dtimesub
+          d_adens_icol(i) =   d_adens_icol(i)*dtimesub
+          d_adens_acol(i) =   d_adens_acol(i)*dtimesub
+          d_awdens(i) =   d_dens_gen(i) + d_adens_death(i) + d_adens_icol(i) + d_adens_acol(i)     
+            
+!!
+          d_wdens_targ = max(d_wdens(i), wdensmin-wdens(i))
+!!          d_dens_bnd(i) = d_dens_bnd(i) + d_wdens_targ - d_wdens(i)
+          d_dens_bnd(i) = d_wdens_targ - d_wdens(i)
+          d_wdens(i) = d_wdens_targ
+          
+          d_wdens_targ = min(max(d_awdens(i),-awdens(i)), wdens(i)-awdens(i))
+!!          d_dens_bnd(i) = d_dens_bnd(i) + d_wdens_targ - d_wdens(i)
+          d_adens_bnd(i) = d_wdens_targ - d_awdens(i)
+          d_awdens(i) = d_wdens_targ
+
+
+
+        ENDIF
+      ENDDO
+
+      IF (prt_level >= 10) THEN
+        print *,'wake, cstar(1), cstar(1)/cstart, rad_wk(1), tau_wk_inv(1), cont_fact(1) ', &
+                       cstar(1), cstar(1)/cstart, rad_wk(1), tau_wk_inv(1), cont_fact(1)
+        print *,'wake, wdens(1), awdens(1), d_awdens(1) ', &
+                       wdens(1), awdens(1), d_awdens(1)
+        print *,'wake, d_sig_gen(1), d_sig_death(1), d_sig_col(1), d_sigmaw(1) ', &
+                       d_sig_gen(1), d_sig_death(1), d_sig_col(1), d_sigmaw(1)
+      ENDIF
+sigmaw=sigmaw+d_sigmaw
+wdens=wdens+d_wdens
+awdens=awdens+d_awdens
+
+    RETURN 
+    END SUBROUTINE wake_popdyn_2  
+  
+    SUBROUTINE wake_popdyn_3 ( klon, klev, phys_sub, wk_adv, dtimesub, wgen, &
+                             wdensmin, &
+                             sigmaw, asigmaw, wdens, awdens, &                       !! state variables
+                             gfl, agfl, cstar, cin, wape, &
+                             rad_wk, arad_wk, irad_wk, &
+                             d_sigmaw, d_asigmaw, d_wdens, d_awdens, &               !! tendencies 
+                             d_sig_gen, d_sig_death, d_sig_col, d_sig_spread, d_sig_bnd, &
+                             d_asig_death, d_asig_aicol, d_asig_iicol, d_asig_spread, d_asig_bnd, &
+                             d_dens_gen, d_dens_death, d_dens_col, d_dens_bnd, &
+                             d_adens_death, d_adens_icol, d_adens_acol, d_adens_bnd )
+                             
+                                             
+
+  USE lmdz_wake_ini , ONLY : wake_ini
+  USE lmdz_wake_ini , ONLY : prt_level,RG
+  USE lmdz_wake_ini , ONLY : stark, wdens_ref
+  USE lmdz_wake_ini , ONLY : tau_cv, rzero, aa0
+!!  USE lmdz_wake_ini , ONLY : iflag_wk_pop_dyn, wdensmin
+  USE lmdz_wake_ini , ONLY : iflag_wk_pop_dyn
+  USE lmdz_wake_ini , ONLY : sigmad, cstart, sigmaw_max
+  USE lmdz_wake_ini , ONLY : smallestreal
+  
+IMPLICIT NONE
+
+  INTEGER, INTENT(IN)                                   :: klon,klev
+  LOGICAL,                          INTENT(IN)          :: phys_sub 
+  LOGICAL, DIMENSION (klon),        INTENT(IN)          :: wk_adv
+  REAL,                             INTENT(IN)          :: dtimesub
+  REAL,                             INTENT(IN)          :: wdensmin
+  REAL, DIMENSION (klon),           INTENT(IN)          :: wgen      !! B = birth rate of wakes
+  REAL, DIMENSION (klon),           INTENT(INOUT)       :: sigmaw    !! sigma = fractional area of wakes 
+  REAL, DIMENSION (klon),           INTENT(INOUT)       :: asigmaw   !! sigma = fractional area of active wakes 
+  REAL, DIMENSION (klon),           INTENT(INOUT)       :: wdens     !! D = number of wakes per unit area 
+  REAL, DIMENSION (klon),           INTENT(INOUT)       :: awdens    !! A = number of active wakes per unit area
+  REAL, DIMENSION (klon),           INTENT(IN)          :: cstar     !! C* = spreading velocity of wakes
+  REAL, DIMENSION (klon),           INTENT(IN)          :: cin, wape  ! RM : A Faire disparaitre
+
+!  
+  REAL, DIMENSION (klon),           INTENT(OUT)         :: rad_wk    !! r = mean wake radius
+  REAL, DIMENSION (klon),           INTENT(OUT)         :: arad_wk    !! r_A = wake radius of active wakes
+  REAL, DIMENSION (klon),           INTENT(OUT)         :: irad_wk    !! r_I = wake radius of inactive wakes
+  REAL, DIMENSION (klon),           INTENT(OUT)         :: gfl       !! Lg = gust front length per unit area
+  REAL, DIMENSION (klon),           INTENT(OUT)         :: agfl      !! LgA = gust front length of active wakes
+                                                                     !!  per unit area
+  REAL, DIMENSION (klon),           INTENT(OUT)         :: d_sigmaw, d_asigmaw, d_wdens, d_awdens
+  ! Some components of the tendencies of state variables  
+  REAL, DIMENSION (klon),           INTENT(OUT)         :: d_sig_gen, d_sig_death, d_sig_col, d_sig_spread, d_sig_bnd
+  REAL, DIMENSION (klon),           INTENT(OUT)         :: d_asig_death, d_asig_aicol, d_asig_iicol, d_asig_spread, d_asig_bnd
+  REAL, DIMENSION (klon),           INTENT(OUT)         :: d_dens_gen, d_dens_death, d_dens_col, d_dens_bnd
+  REAL, DIMENSION (klon),           INTENT(OUT)         :: d_adens_death, d_adens_acol, d_adens_icol, d_adens_bnd
+
+
+!! internal variables
+  
+  INTEGER                                               :: i, k
+  REAL, DIMENSION (klon)                                :: iwdens, isigmaw !! inactive wake density and fractional area
+!!  REAL, DIMENSION (klon)                                :: d_arad, d_irad
+  REAL, DIMENSION (klon)                                :: igfl            !! LgI = gust front length of inactive wakes
+                                                                           !!  per unit area
+  REAL, DIMENSION (klon)                                :: s_wk            !! mean area of individual wakes
+  REAL, DIMENSION (klon)                                :: as_wk           !! mean area of individual active wakes
+  REAL, DIMENSION (klon)                                :: is_wk           !! mean area of individual inactive wakes
+  REAL, DIMENSION (klon)                                :: tau_wk_inv      !! tau = life time of wakes
+  REAL                                                  :: tau_wk_inv_min
+  REAL, DIMENSION (klon)                                :: tau_prime       !! tau_prime = life time of actives wakes
+  REAL                                                  :: d_wdens_targ, d_sigmaw_targ
+
+
+!! Equations
+!! ---------
+!! Gust fronts:
+!! Lg_A = 2 pi r_A A
+!! Lg_I = 2 pi r_I I
+!! Lg   = 2 pi r   D
+!!
+!! Areas:
+!! s = pi r^2
+!! s_A = pi r_A^2
+!! s_I = pi r_I^2
+!!
+!! Life expectancy:
+!! tau_I = 3 C* ((C*/C*t)^3/2 - 1) / r_I
+!!
+!! Time deratives:
+!! dD/dt = B - (D-A)/tau_I - 2 Lg C* D
+!! dA/dt = B - A/tau_A     + 2 Lg_I C* (D-A) - 2 Lg_A C* A
+!! dsigma/dt = B a0 - sigma_I/tau_I + Lg C* - 2 Lg_I C* (D-A) (2 s_I - a0)
+!! dsigma_A/dt = B a0 - sigma_A/tau_A + Lg_A C* + (Lg_A I + Lg_I A) C* s_I + 2 Lg_I C* I a0
+!!
+
+      DO i = 1, klon
+        IF (wk_adv(i)) THEN
+         iwdens(i) = wdens(i) - awdens(i)
+         isigmaw(i) = sigmaw(i) - asigmaw(i)
+!
+         arad_wk(i) = max( sqrt(asigmaw(i)/(3.14*awdens(i))) , rzero)
+         irad_wk(i) = max( sqrt((sigmaw(i)-asigmaw(i))/  &
+                           (3.14*max(smallestreal,(wdens(i)-awdens(i))))), rzero)
+         rad_wk(i) = (awdens(i)*arad_wk(i)+(wdens(i)-awdens(i))*irad_wk(i))/wdens(i)
+!
+         s_wk(i) = 3.14*rad_wk(i)**2
+         as_wk(i) = 3.14*arad_wk(i)**2
+         is_wk(i) = 3.14*irad_wk(i)**2
+!
+         gfl(i)  = 2.*sqrt(3.14*wdens(i)*sigmaw(i))
+         agfl(i) = 2.*sqrt(3.14*awdens(i)*asigmaw(i))
+         igfl(i) = gfl(i) - agfl(i)
+        ENDIF
+      ENDDO
+
+
+      DO i = 1, klon
+        IF (wk_adv(i)) THEN
+          tau_wk_inv(i) = max( (3.*cstar(i))/(irad_wk(i)*((cstar(i)/cstart)**1.5 - 1)), 0.)
+          tau_wk_inv_min = min(tau_wk_inv(i), 1./dtimesub)
+          tau_prime(i) = tau_cv
+
+          d_sig_gen(i) = wgen(i)*aa0
+          d_sig_death(i) = - isigmaw(i)*tau_wk_inv_min
+          d_sig_col(i) = - 2.*igfl(i)*cstar(i)*iwdens(i)*(2.*is_wk(i)-aa0)
+          d_sig_spread(i) = gfl(i)*cstar(i)
+!
+          d_sig_gen(i) =  d_sig_gen(i)*dtimesub
+          d_sig_death(i) = d_sig_death(i)*dtimesub
+          d_sig_col(i) =  d_sig_col(i)*dtimesub 
+          d_sig_spread(i) =  d_sig_spread(i)*dtimesub 
+          d_sigmaw(i) =  d_sig_gen(i) + d_sig_death(i) + d_sig_col(i) + d_sig_spread(i)
+IF (CPPKEY_IOPHYS_WK) THEN
+          IF (phys_sub) call iophys_ecrit('d_sigmaw0',1,'d_sigmaw0','',d_sigmaw)
+END IF
+
+         
+          d_sigmaw_targ = max(d_sigmaw(i), sigmad-sigmaw(i))
+!!          d_sig_bnd(i) = d_sig_bnd(i) + d_sigmaw_targ - d_sigmaw(i)
+!!          d_sig_bnd_provis(i) = d_sigmaw_targ - d_sigmaw(i)
+          d_sig_bnd(i) = d_sigmaw_targ - d_sigmaw(i)
+          d_sigmaw(i) = d_sigmaw_targ
+!!          d_sigmaw(i) = max(d_sigmaw(i), sigmad-sigmaw(i))
+IF (CPPKEY_IOPHYS_WK) THEN
+          IF (phys_sub) THEN
+             call iophys_ecrit('tauwk_inv',1,'tau_wk_inv_min','',tau_wk_inv_min)
+             call iophys_ecrit('d_sigmaw',1,'d_sigmaw','',d_sigmaw)
+             call iophys_ecrit('d_sig_gen',1,'d_sig_gen','',d_sig_gen)
+             call iophys_ecrit('d_sig_death',1,'d_sig_death','',d_sig_death)
+             call iophys_ecrit('d_sig_col',1,'d_sig_col','',d_sig_col)
+             call iophys_ecrit('d_sig_spread',1,'d_sig_spread','',d_sig_spread)
+             call iophys_ecrit('d_sig_bnd',1,'d_sig_bnd','',d_sig_bnd)
+          ENDIF
+END IF
+          d_asig_death(i) = - asigmaw(i)/tau_prime(i)
+          d_asig_aicol(i) = (agfl(i)*iwdens(i) + igfl(i)*awdens(i))*cstar(i)*is_wk(i)
+          d_asig_iicol(i) = 2.*igfl(i)*cstar(i)*iwdens(i)*aa0
+          d_asig_spread(i) = agfl(i)*cstar(i)
+!
+          d_asig_death(i) = d_asig_death(i)*dtimesub
+          d_asig_aicol(i) =  d_asig_aicol(i)*dtimesub 
+          d_asig_iicol(i) =  d_asig_iicol(i)*dtimesub 
+          d_asig_spread(i) =  d_asig_spread(i)*dtimesub 
+          d_asigmaw(i) =  d_sig_gen(i) + d_asig_death(i) + d_asig_aicol(i) + d_asig_iicol(i) + d_asig_spread(i)
+IF (CPPKEY_IOPHYS_WK) THEN
+          IF (phys_sub) call iophys_ecrit('d_asigmaw0',1,'d_asigmaw0','',d_asigmaw)
+END IF
+
+          d_sigmaw_targ = min(max(d_asigmaw(i),-asigmaw(i)), sigmaw(i)-asigmaw(i))
+!!          d_dens_bnd(i) = d_dens_bnd(i) + d_sigmaw_targ - d_sigmaw(i)
+          d_asig_bnd(i) = d_sigmaw_targ - d_asigmaw(i)
+          d_asigmaw(i) = d_sigmaw_targ
+IF (CPPKEY_IOPHYS_WK) THEN
+          IF (phys_sub) THEN
+             call iophys_ecrit('d_asigmaw',1,'d_asigmaw','',d_asigmaw)
+             call iophys_ecrit('d_asig_death',1,'d_asig_death','',d_asig_death)
+             call iophys_ecrit('d_asig_aicol',1,'d_asig_aicol','',d_asig_aicol)
+             call iophys_ecrit('d_asig_iicol',1,'d_asig_iicol','',d_asig_iicol)
+             call iophys_ecrit('d_asig_spread',1,'d_asig_spread','',d_asig_spread)
+             call iophys_ecrit('d_asig_bnd',1,'d_asig_bnd','',d_asig_bnd)
+          ENDIF
+END IF
+          d_dens_gen(i) = wgen(i)
+          d_dens_death(i) = - iwdens(i)*tau_wk_inv_min 
+          d_dens_col(i) =  - 2.*gfl(i)*cstar(i)*wdens(i)
+! 
+          d_dens_gen(i) =  d_dens_gen(i)*dtimesub
+          d_dens_death(i) = d_dens_death(i)*dtimesub
+          d_dens_col(i) =  d_dens_col(i)*dtimesub 
+          d_wdens(i) = d_dens_gen(i) + d_dens_death(i) + d_dens_col(i)
+!!
+          d_wdens_targ = max(d_wdens(i), wdensmin-wdens(i))
+!!          d_dens_bnd(i) = d_dens_bnd(i) + d_wdens_targ - d_wdens(i)
+          d_dens_bnd(i) = d_wdens_targ - d_wdens(i)
+          d_wdens(i) = d_wdens_targ
+IF (CPPKEY_IOPHYS_WK) THEN
+    IF (phys_sub) THEN 
+        call iophys_ecrit('d_wdens',1,'d_wdens','',d_wdens)
+        call iophys_ecrit('d_dens_gen',1,'d_dens_gen','',d_dens_gen)
+        call iophys_ecrit('d_dens_death',1,'d_dens_death','',d_dens_death)
+        call iophys_ecrit('d_dens_col',1,'d_dens_col','',d_dens_col)
+    ENDIF
+END IF
+
+          d_adens_death(i) = -awdens(i)/tau_prime(i)
+          d_adens_icol(i) =   2.*igfl(i)*cstar(i)*iwdens(i)
+          d_adens_acol(i)  = - 2.*agfl(i)*cstar(i)*awdens(i)
+!
+          d_adens_death(i) =  d_adens_death(i)*dtimesub
+          d_adens_icol(i) =   d_adens_icol(i)*dtimesub
+          d_adens_acol(i)  =   d_adens_acol(i)*dtimesub
+          d_awdens(i) =   d_dens_gen(i) + d_adens_death(i) + d_adens_icol(i) + d_adens_acol(i)     
+IF (CPPKEY_IOPHYS_WK) THEN
+    IF (phys_sub) THEN 
+        call iophys_ecrit('d_awdens',1,'d_awdens','',d_awdens)
+        call iophys_ecrit('d_adens_death',1,'d_adens_death','',d_adens_death)
+        call iophys_ecrit('d_adens_icol',1,'d_adens_icol','',d_adens_icol)
+        call iophys_ecrit('d_adens_acol',1,'d_adens_acol','',d_adens_acol)
+    ENDIF
+END IF
+          d_wdens_targ = min(max(d_awdens(i),-awdens(i)), wdens(i)-awdens(i))
+!!          d_dens_bnd(i) = d_dens_bnd(i) + d_wdens_targ - d_wdens(i)
+          d_adens_bnd(i) = d_wdens_targ - d_awdens(i)
+          d_awdens(i) = d_wdens_targ
+
+!!          d_irad(i) = (d_sigmaw(i)-d_asigmaw(i)-isigmaw(i)*(d_wdens(i)-awdens(i))/iwdens(i)) / &
+!!                      max(smallestreal,(2.*3.14*iwdens(i)*irad_wk(i)))
+!!          d_arad(i) = (d_asigmaw(i)-asigmaw(i)*d_awdens(i)/awdens(i)) / &
+!!                      max(smallestreal,(2.*3.14*awdens(i)*arad_wk(i)))
+!!          d_irad(i) = d_irad(i)*dtimesub
+!!          d_arad(i) = d_arad(i)*dtimesub
+!!          call iophys_ecrit('d_irad',1,'d_irad','m',d_irad)
+!!          call iophys_ecrit('d_airad',1,'d_arad','m',d_arad)
+!!
+        ENDIF
+      ENDDO
+
+      IF (prt_level >= 10) THEN
+        print *,'wake, cstar(1), cstar(1)/cstart, rad_wk(1), tau_wk_inv(1), gfl(1) ', &
+                       cstar(1), cstar(1)/cstart, rad_wk(1), tau_wk_inv(1), gfl(1)
+        print *,'wake, wdens(1), awdens(1), d_awdens(1) ', &
+                       wdens(1), awdens(1), d_awdens(1)
+        print *,'wake, d_sig_gen(1), d_sig_death(1), d_sig_col(1), d_sigmaw(1) ', &
+                       d_sig_gen(1), d_sig_death(1), d_sig_col(1), d_sigmaw(1)
+      ENDIF
+sigmaw=sigmaw+d_sigmaw
+asigmaw=asigmaw+d_asigmaw
+wdens=wdens+d_wdens
+awdens=awdens+d_awdens
+
+    RETURN 
+    END SUBROUTINE wake_popdyn_3  
+
+END MODULE lmdz_wake
Index: DZ6/trunk/libf/phylmd/lsc_scav.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/lsc_scav.F90	(revision 5267)
+++ 	(revision )
@@ -1,260 +1,0 @@
-!$Id $
-
-SUBROUTINE lsc_scav(pdtime,it,iflag_lscav, aerosol,  &
-                    oliq,flxr,flxs,rneb,beta_fisrt,  &
-                    beta_v1,pplay,paprs,t,tr_seri,   & 
-                    d_tr_insc,d_tr_bcscav,d_tr_evap,qPrls) 
-  USE ioipsl
-  USE dimphy
-  USE mod_grid_phy_lmdz
-  USE mod_phys_lmdz_para
-  USE traclmdz_mod
-  USE infotrac_phy,ONLY : nbtr
-  USE iophy
-  IMPLICIT NONE 
-!=====================================================================
-! Objet : depot humide (lessivage et evaporation) de traceurs
-! Inspired by routines of Olivier Boucher (mars 1998)
-! author R. Pilon 10 octobre 2012
-! last modification 16/01/2013 (reformulation partie evaporation)
-!=====================================================================
-
-  include "chem.h"
-  include "YOMCST.h"
-  include "YOECUMF.h" 
-
-! inputs
-  REAL,INTENT(IN)                        :: pdtime ! time step (s)
-  INTEGER,INTENT(IN)                     :: it     ! tracer number
-  INTEGER,INTENT(IN)                     :: iflag_lscav ! LS scavenging param: 3=Reddy_Boucher2004, 4=3+RPilon.
-  REAL,DIMENSION(klon,klev+1),INTENT(IN) :: flxr     ! flux precipitant de pluie
-  REAL,DIMENSION(klon,klev+1),INTENT(IN) :: flxs     ! flux precipitant de neige
-  REAL,INTENT(IN)                        :: oliq ! contenu en eau liquide dans le nuage (kg/kg)
-  REAL,DIMENSION(klon,klev),INTENT(IN)   :: rneb
-  REAL,DIMENSION(klon,klev),INTENT(IN)   :: pplay    ! pression
-  REAL,DIMENSION(klon,klev+1),INTENT(IN) :: paprs    ! pression
-  REAL,DIMENSION(klon,klev),INTENT(IN)   :: t        ! temperature
-! tracers
-  LOGICAL,DIMENSION(nbtr), INTENT(IN)         :: aerosol
-  REAL,DIMENSION(klon,klev,nbtr),INTENT(IN)   :: tr_seri        ! q de traceur  
-  REAL,DIMENSION(klon,klev),INTENT(IN)        :: beta_fisrt     ! taux de conversion de l'eau cond
-  REAL,DIMENSION(klon,klev),INTENT(OUT)       :: beta_v1        ! -- (originale version)
-  REAL,DIMENSION(klon)                        :: his_dh         ! tendance de traceur integre verticalement
-  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)  :: d_tr_insc      ! tendance du traceur 
-  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)  :: d_tr_bcscav  ! tendance de traceur
-  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)  :: d_tr_evap
-  REAL,DIMENSION(klon,nbtr),INTENT(OUT)       :: qPrls      !jyg: concentration tra dans pluie LS a la surf.
-  REAL :: dxin,dxev                              ! tendance temporaire de traceur incloud
-  REAL,DIMENSION(klon,klev) :: dxbc       ! tendance temporaire de traceur bc
-
-!  variables locales      
- LOGICAL,SAVE :: debut=.TRUE.
-!$OMP THREADPRIVATE(debut)
-!
-  REAL,PARAMETER :: henry=1.4  ! constante de Henry en mol/l/atm ~1.4 for gases
-  REAL           :: henry_t    !  constante de Henry a T t  (mol/l/atm)
-  REAL,PARAMETER :: kk=2900.   ! coefficient de dependence en T (K)
-  REAL :: f_a     !  rapport de la phase aqueuse a la phase gazeuse
-  REAL :: beta    !  taux de conversion de l'eau en pluie
-
-  INTEGER :: i, k
-  REAL,DIMENSION(klon,klev)    :: scav  !  water liquid content / fraction aqueuse du constituant
-  REAL,DIMENSION(klon,klev)    :: zrho
-  REAL,DIMENSION(klon,klev)    :: zdz
-  REAL,DIMENSION(klon,klev)    :: zmass ! layer mass
-
-  REAL           :: frac_ev       ! cste pour la reevaporation : dropplet shrinking
-!  frac_ev = frac_gas ou frac_aer
-  REAL,PARAMETER :: frac_gas=1.0  ! cste pour la reevaporation pour les gaz
-  REAL,SAVE      :: frac_aer      ! cste pour la reevaporation pour les particules
-  REAL,DIMENSION(klon,klev) :: deltaP     ! P(i+1)-P(i)
-  REAL,DIMENSION(klon,klev) :: beta_ev    !  dP/P(i+1)
-!$OMP THREADPRIVATE(frac_aer)
-
-!  101.325  m3/l x Pa/atm
-!  R        Pa.m3/mol/K
-!   cste de dissolution pour le depot humide
-  REAL,SAVE :: frac_fine_scav
-  REAL,SAVE :: frac_coar_scav
-!$OMP THREADPRIVATE(frac_fine_scav, frac_coar_scav)
-
-! below-cloud scav variables
-! aerosol : alpha_r=0.001, gas 0.001  (Pruppacher & Klett 1967)
-  REAL,SAVE :: alpha_r  !  coefficient d'impaction pour la pluie
-  REAL,SAVE :: alpha_s  !  coefficient d'impaction pour la neige  
-  REAL,SAVE :: R_r      !  mean raindrop radius (m) 
-  REAL,SAVE :: R_s      !  mean snow crystal radius (m)
-!$OMP THREADPRIVATE(alpha_r, alpha_s, R_r, R_s)
-  REAL           :: pr, ps, ice, water
-!  REAL :: conserv
-!
-!
-  IF (debut) THEN
-!
-      alpha_r=0.001        !  coefficient d'impaction pour la pluie
-      alpha_s=0.01         !  coefficient d'impaction pour la neige  
-      R_r=0.001            !  mean raindrop radius (m) 
-      R_s=0.001            !  mean snow crystal radius (m)
-      frac_fine_scav=0.7
-      frac_coar_scav=0.7
-!     Droplet size shrinks by evap
-      frac_aer=0.5
-      debut=.FALSE.
-!
-      OPEN(99,file='lsc_scav_param.data',status='old', &
-                form='formatted',err=9999)
-      READ(99,*,end=9998)  alpha_r
-      READ(99,*,end=9998)  alpha_s
-      READ(99,*,end=9998)  R_r
-      READ(99,*,end=9998)  R_s
-      READ(99,*,end=9998)  frac_fine_scav
-      READ(99,*,end=9998)  frac_coar_scav
-      READ(99,*,end=9998)  frac_aer
-9998  CONTINUE
-      CLOSE(99)
-9999  CONTINUE
-
-   print*,'alpha_r',alpha_r
-   print*,'alpha_s',alpha_s
-   print*,'R_r',R_r
-   print*,'R_s',R_s
-   print*,'frac_fine_scav',frac_fine_scav
-   print*,'frac_coar_scav',frac_coar_scav
-   print*,'frac_aer ev',frac_aer
-!
-  ENDIF !(debut)
-!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!
-! initialization
-  dxin=0.
-  dxev=0.
-  beta_ev=0.
-
-  DO i=1,klon
-   his_dh(i)=0.
-  ENDDO
-
-  DO k=1,klev
-   DO i=1, klon 
-    dxbc(i,k)=0.
-    beta_v1(i,k)=0.
-    deltaP(i,k)=0.
-   ENDDO
-  ENDDO
-
-!  pressure and size of the layer
-  DO k=klev, 1, -1
-   DO i=1, klon 
-     zrho(i,k)=pplay(i,k)/t(i,k)/RD   
-     zdz(i,k)=(paprs(i,k)-paprs(i,k+1))/zrho(i,k)/RG
-     zmass(i,k)=(paprs(i,k)-paprs(i,k+1))/RG
-   ENDDO
-  ENDDO
-
-!jyg<
-!! Temporary correction: all non-aerosol tracers are dealt with in the same way.
-!! Should be updated once it has been decided how gases should be dealt with.
-  IF (aerosol(it)) THEN
-      frac_ev=frac_aer
-  ELSE                                                !  gas
-      frac_ev=frac_gas
-  ENDIF
-!
-!jyg<
-  IF (aerosol(it)) THEN ! aerosol
-    DO k=1, klev
-      DO i=1, klon 
-       scav(i,k)=frac_fine_scav
-      ENDDO 
-    ENDDO
-  ELSE                  ! gas
-    DO k=1, klev
-      DO i=1, klon 
-       henry_t=henry*exp(-kk*(1./298.-1./t(i,k)))    !  mol/l/atm
-       f_a=henry_t/101.325*R*t(i,k)*oliq*zrho(i,k)/rho_water
-       scav(i,k)=f_a/(1.+f_a)
-      ENDDO 
-    ENDDO
-  ENDIF
-
-  DO k=klev-1, 1, -1
-    DO i=1, klon 
-!  incloud scavenging
-      IF (iflag_lscav .EQ. 4) THEN
-        beta=beta_fisrt(i,k)*rneb(i,k)
-      ELSE
-        beta=flxr(i,k)-flxr(i,k+1)+flxs(i,k)-flxs(i,k+1)
-        beta=beta/zmass(i,k)/oliq
-        beta=MAX(0.,beta)
-      ENDIF ! (iflag_lscav .eq. 4)
-      beta_v1(i,k)=beta    !! for output
-!
-      dxin=tr_seri(i,k,it)*(exp(-scav(i,k)*beta*pdtime)-1.)
-      his_dh(i)=his_dh(i)-dxin*zmass(i,k)/pdtime !  kg/m2/s
-      d_tr_insc(i,k,it)=dxin                     !  kg/kg/timestep
-
-!  below-cloud impaction
-!jyg<
-      IF (.NOT.aerosol(it)) THEN
-        d_tr_bcscav(i,k,it)=0.
-      ELSE
-        pr=0.5*(flxr(i,k)+flxr(i,k+1))
-        ps=0.5*(flxs(i,k)+flxs(i,k+1))
-        water=pr*alpha_r/R_r/rho_water
-        ice=ps*alpha_s/R_s/rho_ice
-        dxbc(i,k)=-3./4.*tr_seri(i,k,it)*pdtime*(water+ice)
-!      add tracers from below cloud scav in his_dh
-        his_dh(i)=his_dh(i)-dxbc(i,k)*zmass(i,k)/pdtime !  kg/m2/s
-        d_tr_bcscav(i,k,it)=dxbc(i,k)                   !  kg/kg/timestep
-      ENDIF
-
-!  reevaporation
-      deltaP(i,k)=flxr(i,k+1)+flxs(i,k+1)-flxr(i,k)-flxs(i,k)
-      deltaP(i,k)=max(deltaP(i,k),0.)
-
-      IF (flxr(i,k+1)+flxs(i,k+1).GT.1.e-16) THEn
-        beta_ev(i,k)=deltaP(i,k)/(flxr(i,k+1)+flxs(i,k+1))
-      ELSE
-        beta_ev(i,k)=0.
-      ENDIF
-
-      beta_ev(i,k)=max(min(1.,beta_ev(i,k)),0.)
-
-!jyg
-      IF (ABS(1.-(1.-frac_ev)*beta_ev(i,k)).GT.1.e-16) THEN
-! remove tracers from precipitation owing to release by evaporation in his_dh
-        dxev=frac_ev*beta_ev(i,k)*his_dh(i)*pdtime/zmass(i,k)/(1.-(1.-frac_ev)*beta_ev(i,k))
-        his_dh(i)=his_dh(i)*(1.-frac_ev*beta_ev(i,k)/(1.-(1.-frac_ev)*beta_ev(i,k)))
-      ELSE
-        dxev=his_dh(i)*pdtime/zmass(i,k)
-        his_dh(i)=0.
-      ENDIF
-!
-!      print*,  k, 'beta_ev',beta_ev
-! remove tracers from precipitation owing to release by evaporation in his_dh
-!      dxev=frac_ev*deltaP(i,k)*pdtime * his_dh(i) /(zrho(i,k)*zdz(i,k))
-!rplmd
-!      dxev=frac_ev*deltaP(i,k)*his_dh(i) *pdtime/(zrho(i,k)*zdz(i,k))/max(flxr(i,k)+flxs(i,k),1.e-16)
-
-      d_tr_evap(i,k,it)=dxev       !  kg/kg/timestep
-!
-    ENDDO
-  ENDDO
-!
-  DO i = 1,klon
-     qPrls(i,it) = his_dh(i)/max(flxr(i,1)+flxs(i,1),1.e-16)
-  ENDDO
-!
-! test de conservation
-!      conserv=0.
-!      DO k= klev,1,-1
-!        DO i=1, klon
-!         conserv=conserv+d_tr_insc(i,k,it)*(paprs(i,k)-paprs(i,k+1))/RG &
-!                +d_tr_bcscav(i,k,it)*(paprs(i,k)-paprs(i,k+1))/RG  &
-!                +d_tr_evap(i,k,it)*(paprs(i,k)-paprs(i,k+1))/RG
-!      if(it.eq.3) write(*,'(I2,2X,a,e20.12,2X,a,e20.12,2X,a,e20.12,2X,a,e20.12)'),&
-!      k,'lsc conserv ',conserv,'insc',d_tr_insc(i,k,it),'bc',d_tr_bcscav(i,k,it),'ev',d_tr_evap(i,k,it)
-!       ENDDO
-!     ENDDO
-
-END SUBROUTINE lsc_scav
Index: /LMDZ6/trunk/libf/phylmd/lsc_scav.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/lsc_scav.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/lsc_scav.f90	(revision 5268)
@@ -0,0 +1,260 @@
+!$Id $
+
+SUBROUTINE lsc_scav(pdtime,it,iflag_lscav, aerosol,  &
+                    oliq,flxr,flxs,rneb,beta_fisrt,  &
+                    beta_v1,pplay,paprs,t,tr_seri,   & 
+                    d_tr_insc,d_tr_bcscav,d_tr_evap,qPrls) 
+  USE ioipsl
+  USE dimphy
+  USE mod_grid_phy_lmdz
+  USE mod_phys_lmdz_para
+  USE traclmdz_mod
+  USE infotrac_phy,ONLY : nbtr
+  USE iophy
+  IMPLICIT NONE 
+!=====================================================================
+! Objet : depot humide (lessivage et evaporation) de traceurs
+! Inspired by routines of Olivier Boucher (mars 1998)
+! author R. Pilon 10 octobre 2012
+! last modification 16/01/2013 (reformulation partie evaporation)
+!=====================================================================
+
+  include "chem.h"
+  include "YOMCST.h"
+  include "YOECUMF.h" 
+
+! inputs
+  REAL,INTENT(IN)                        :: pdtime ! time step (s)
+  INTEGER,INTENT(IN)                     :: it     ! tracer number
+  INTEGER,INTENT(IN)                     :: iflag_lscav ! LS scavenging param: 3=Reddy_Boucher2004, 4=3+RPilon.
+  REAL,DIMENSION(klon,klev+1),INTENT(IN) :: flxr     ! flux precipitant de pluie
+  REAL,DIMENSION(klon,klev+1),INTENT(IN) :: flxs     ! flux precipitant de neige
+  REAL,INTENT(IN)                        :: oliq ! contenu en eau liquide dans le nuage (kg/kg)
+  REAL,DIMENSION(klon,klev),INTENT(IN)   :: rneb
+  REAL,DIMENSION(klon,klev),INTENT(IN)   :: pplay    ! pression
+  REAL,DIMENSION(klon,klev+1),INTENT(IN) :: paprs    ! pression
+  REAL,DIMENSION(klon,klev),INTENT(IN)   :: t        ! temperature
+! tracers
+  LOGICAL,DIMENSION(nbtr), INTENT(IN)         :: aerosol
+  REAL,DIMENSION(klon,klev,nbtr),INTENT(IN)   :: tr_seri        ! q de traceur  
+  REAL,DIMENSION(klon,klev),INTENT(IN)        :: beta_fisrt     ! taux de conversion de l'eau cond
+  REAL,DIMENSION(klon,klev),INTENT(OUT)       :: beta_v1        ! -- (originale version)
+  REAL,DIMENSION(klon)                        :: his_dh         ! tendance de traceur integre verticalement
+  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)  :: d_tr_insc      ! tendance du traceur 
+  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)  :: d_tr_bcscav  ! tendance de traceur
+  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)  :: d_tr_evap
+  REAL,DIMENSION(klon,nbtr),INTENT(OUT)       :: qPrls      !jyg: concentration tra dans pluie LS a la surf.
+  REAL :: dxin,dxev                              ! tendance temporaire de traceur incloud
+  REAL,DIMENSION(klon,klev) :: dxbc       ! tendance temporaire de traceur bc
+
+!  variables locales      
+ LOGICAL,SAVE :: debut=.TRUE.
+!$OMP THREADPRIVATE(debut)
+!
+  REAL,PARAMETER :: henry=1.4  ! constante de Henry en mol/l/atm ~1.4 for gases
+  REAL           :: henry_t    !  constante de Henry a T t  (mol/l/atm)
+  REAL,PARAMETER :: kk=2900.   ! coefficient de dependence en T (K)
+  REAL :: f_a     !  rapport de la phase aqueuse a la phase gazeuse
+  REAL :: beta    !  taux de conversion de l'eau en pluie
+
+  INTEGER :: i, k
+  REAL,DIMENSION(klon,klev)    :: scav  !  water liquid content / fraction aqueuse du constituant
+  REAL,DIMENSION(klon,klev)    :: zrho
+  REAL,DIMENSION(klon,klev)    :: zdz
+  REAL,DIMENSION(klon,klev)    :: zmass ! layer mass
+
+  REAL           :: frac_ev       ! cste pour la reevaporation : dropplet shrinking
+!  frac_ev = frac_gas ou frac_aer
+  REAL,PARAMETER :: frac_gas=1.0  ! cste pour la reevaporation pour les gaz
+  REAL,SAVE      :: frac_aer      ! cste pour la reevaporation pour les particules
+  REAL,DIMENSION(klon,klev) :: deltaP     ! P(i+1)-P(i)
+  REAL,DIMENSION(klon,klev) :: beta_ev    !  dP/P(i+1)
+!$OMP THREADPRIVATE(frac_aer)
+
+!  101.325  m3/l x Pa/atm
+!  R        Pa.m3/mol/K
+!   cste de dissolution pour le depot humide
+  REAL,SAVE :: frac_fine_scav
+  REAL,SAVE :: frac_coar_scav
+!$OMP THREADPRIVATE(frac_fine_scav, frac_coar_scav)
+
+! below-cloud scav variables
+! aerosol : alpha_r=0.001, gas 0.001  (Pruppacher & Klett 1967)
+  REAL,SAVE :: alpha_r  !  coefficient d'impaction pour la pluie
+  REAL,SAVE :: alpha_s  !  coefficient d'impaction pour la neige  
+  REAL,SAVE :: R_r      !  mean raindrop radius (m) 
+  REAL,SAVE :: R_s      !  mean snow crystal radius (m)
+!$OMP THREADPRIVATE(alpha_r, alpha_s, R_r, R_s)
+  REAL           :: pr, ps, ice, water
+!  REAL :: conserv
+!
+!
+  IF (debut) THEN
+!
+      alpha_r=0.001        !  coefficient d'impaction pour la pluie
+      alpha_s=0.01         !  coefficient d'impaction pour la neige  
+      R_r=0.001            !  mean raindrop radius (m) 
+      R_s=0.001            !  mean snow crystal radius (m)
+      frac_fine_scav=0.7
+      frac_coar_scav=0.7
+!     Droplet size shrinks by evap
+      frac_aer=0.5
+      debut=.FALSE.
+!
+      OPEN(99,file='lsc_scav_param.data',status='old', &
+                form='formatted',err=9999)
+      READ(99,*,end=9998)  alpha_r
+      READ(99,*,end=9998)  alpha_s
+      READ(99,*,end=9998)  R_r
+      READ(99,*,end=9998)  R_s
+      READ(99,*,end=9998)  frac_fine_scav
+      READ(99,*,end=9998)  frac_coar_scav
+      READ(99,*,end=9998)  frac_aer
+9998  CONTINUE
+      CLOSE(99)
+9999  CONTINUE
+
+   print*,'alpha_r',alpha_r
+   print*,'alpha_s',alpha_s
+   print*,'R_r',R_r
+   print*,'R_s',R_s
+   print*,'frac_fine_scav',frac_fine_scav
+   print*,'frac_coar_scav',frac_coar_scav
+   print*,'frac_aer ev',frac_aer
+!
+  ENDIF !(debut)
+!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
+! initialization
+  dxin=0.
+  dxev=0.
+  beta_ev=0.
+
+  DO i=1,klon
+   his_dh(i)=0.
+  ENDDO
+
+  DO k=1,klev
+   DO i=1, klon 
+    dxbc(i,k)=0.
+    beta_v1(i,k)=0.
+    deltaP(i,k)=0.
+   ENDDO
+  ENDDO
+
+!  pressure and size of the layer
+  DO k=klev, 1, -1
+   DO i=1, klon 
+     zrho(i,k)=pplay(i,k)/t(i,k)/RD   
+     zdz(i,k)=(paprs(i,k)-paprs(i,k+1))/zrho(i,k)/RG
+     zmass(i,k)=(paprs(i,k)-paprs(i,k+1))/RG
+   ENDDO
+  ENDDO
+
+!jyg<
+!! Temporary correction: all non-aerosol tracers are dealt with in the same way.
+!! Should be updated once it has been decided how gases should be dealt with.
+  IF (aerosol(it)) THEN
+      frac_ev=frac_aer
+  ELSE                                                !  gas
+      frac_ev=frac_gas
+  ENDIF
+!
+!jyg<
+  IF (aerosol(it)) THEN ! aerosol
+    DO k=1, klev
+      DO i=1, klon 
+       scav(i,k)=frac_fine_scav
+      ENDDO 
+    ENDDO
+  ELSE                  ! gas
+    DO k=1, klev
+      DO i=1, klon 
+       henry_t=henry*exp(-kk*(1./298.-1./t(i,k)))    !  mol/l/atm
+       f_a=henry_t/101.325*R*t(i,k)*oliq*zrho(i,k)/rho_water
+       scav(i,k)=f_a/(1.+f_a)
+      ENDDO 
+    ENDDO
+  ENDIF
+
+  DO k=klev-1, 1, -1
+    DO i=1, klon 
+!  incloud scavenging
+      IF (iflag_lscav .EQ. 4) THEN
+        beta=beta_fisrt(i,k)*rneb(i,k)
+      ELSE
+        beta=flxr(i,k)-flxr(i,k+1)+flxs(i,k)-flxs(i,k+1)
+        beta=beta/zmass(i,k)/oliq
+        beta=MAX(0.,beta)
+      ENDIF ! (iflag_lscav .eq. 4)
+      beta_v1(i,k)=beta    !! for output
+!
+      dxin=tr_seri(i,k,it)*(exp(-scav(i,k)*beta*pdtime)-1.)
+      his_dh(i)=his_dh(i)-dxin*zmass(i,k)/pdtime !  kg/m2/s
+      d_tr_insc(i,k,it)=dxin                     !  kg/kg/timestep
+
+!  below-cloud impaction
+!jyg<
+      IF (.NOT.aerosol(it)) THEN
+        d_tr_bcscav(i,k,it)=0.
+      ELSE
+        pr=0.5*(flxr(i,k)+flxr(i,k+1))
+        ps=0.5*(flxs(i,k)+flxs(i,k+1))
+        water=pr*alpha_r/R_r/rho_water
+        ice=ps*alpha_s/R_s/rho_ice
+        dxbc(i,k)=-3./4.*tr_seri(i,k,it)*pdtime*(water+ice)
+!      add tracers from below cloud scav in his_dh
+        his_dh(i)=his_dh(i)-dxbc(i,k)*zmass(i,k)/pdtime !  kg/m2/s
+        d_tr_bcscav(i,k,it)=dxbc(i,k)                   !  kg/kg/timestep
+      ENDIF
+
+!  reevaporation
+      deltaP(i,k)=flxr(i,k+1)+flxs(i,k+1)-flxr(i,k)-flxs(i,k)
+      deltaP(i,k)=max(deltaP(i,k),0.)
+
+      IF (flxr(i,k+1)+flxs(i,k+1).GT.1.e-16) THEn
+        beta_ev(i,k)=deltaP(i,k)/(flxr(i,k+1)+flxs(i,k+1))
+      ELSE
+        beta_ev(i,k)=0.
+      ENDIF
+
+      beta_ev(i,k)=max(min(1.,beta_ev(i,k)),0.)
+
+!jyg
+      IF (ABS(1.-(1.-frac_ev)*beta_ev(i,k)).GT.1.e-16) THEN
+! remove tracers from precipitation owing to release by evaporation in his_dh
+        dxev=frac_ev*beta_ev(i,k)*his_dh(i)*pdtime/zmass(i,k)/(1.-(1.-frac_ev)*beta_ev(i,k))
+        his_dh(i)=his_dh(i)*(1.-frac_ev*beta_ev(i,k)/(1.-(1.-frac_ev)*beta_ev(i,k)))
+      ELSE
+        dxev=his_dh(i)*pdtime/zmass(i,k)
+        his_dh(i)=0.
+      ENDIF
+!
+!      print*,  k, 'beta_ev',beta_ev
+! remove tracers from precipitation owing to release by evaporation in his_dh
+!      dxev=frac_ev*deltaP(i,k)*pdtime * his_dh(i) /(zrho(i,k)*zdz(i,k))
+!rplmd
+!      dxev=frac_ev*deltaP(i,k)*his_dh(i) *pdtime/(zrho(i,k)*zdz(i,k))/max(flxr(i,k)+flxs(i,k),1.e-16)
+
+      d_tr_evap(i,k,it)=dxev       !  kg/kg/timestep
+!
+    ENDDO
+  ENDDO
+!
+  DO i = 1,klon
+     qPrls(i,it) = his_dh(i)/max(flxr(i,1)+flxs(i,1),1.e-16)
+  ENDDO
+!
+! test de conservation
+!      conserv=0.
+!      DO k= klev,1,-1
+!        DO i=1, klon
+!         conserv=conserv+d_tr_insc(i,k,it)*(paprs(i,k)-paprs(i,k+1))/RG &
+!                +d_tr_bcscav(i,k,it)*(paprs(i,k)-paprs(i,k+1))/RG  &
+!                +d_tr_evap(i,k,it)*(paprs(i,k)-paprs(i,k+1))/RG
+!      if(it.eq.3) write(*,'(I2,2X,a,e20.12,2X,a,e20.12,2X,a,e20.12,2X,a,e20.12)'),&
+!      k,'lsc conserv ',conserv,'insc',d_tr_insc(i,k,it),'bc',d_tr_bcscav(i,k,it),'ev',d_tr_evap(i,k,it)
+!       ENDDO
+!     ENDDO
+
+END SUBROUTINE lsc_scav
Index: DZ6/trunk/libf/phylmd/macv2sp.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/macv2sp.F90	(revision 5267)
+++ 	(revision )
@@ -1,176 +1,0 @@
-SUBROUTINE MACv2SP(pphis,pplay,paprs,xlon,xlat,tau_allaer,piz_allaer,cg_allaer)
-  !
-  !--routine to read the MACv2SP plume and compute optical properties
-  !--requires flag_aerosol = 7
-  !--feeds into aerosol optical properties and newmicro cloud droplet size if ok_cdnc activated
-  !--for this one needs to feed natural (pre-industrial) aerosols twice for nat and 1980 files
-  !--pre-ind aerosols (index=1) are not changed, present-day aerosols (index=2) are incremented
-  !--uses model year so year_cur needs to be correct in the model simulation
-  !
-  !--aod_prof = AOD per layer 
-  !--ssa_prof = SSA 
-  !--asy_prof = asymetry parameter
-  !--dNovrN   = enhancement factor for CDNC
-  !
-  USE mo_simple_plumes, ONLY: sp_aop_profile
-  USE phys_cal_mod, ONLY : year_cur, day_cur, year_len
-  USE dimphy
-  USE aero_mod
-  USE phys_local_var_mod, ONLY: t_seri, od443aer, od550aer, od865aer, ec550aer, dryod550aer, od550lt1aer, dNovrN
-  !!USE YOMCST, ONLY : RD, RG
-  !
-  IMPLICIT NONE
-  !
-  include "YOMCST.h"
-  ! 
-  REAL,DIMENSION(klon),INTENT(IN)        :: pphis   ! Geopotentiel de surface
-  REAL,DIMENSION(klon,klev),INTENT(IN)   :: pplay   ! pression pour le mileu de chaque couche (en Pa)
-  REAL,DIMENSION(klon,klev+1),INTENT(IN) :: paprs   ! pression pour les interfaces de chaque couche (en Pa)
-  REAL,DIMENSION(klon),INTENT(IN)        :: xlat    ! latitudes pour chaque point
-  REAL,DIMENSION(klon),INTENT(IN)        :: xlon    ! longitudes pour chaque point
-  !
-  REAL, DIMENSION(klon,klev,2,nbands_sw_rrtm), INTENT(OUT) :: tau_allaer !  epaisseur optique aerosol
-  REAL, DIMENSION(klon,klev,2,nbands_sw_rrtm), INTENT(OUT) :: piz_allaer !  single scattering albedo aerosol
-  REAL, DIMENSION(klon,klev,2,nbands_sw_rrtm), INTENT(OUT) :: cg_allaer  !  asymmetry parameter aerosol
-  !
-  REAL,DIMENSION(klon,klev) :: aod_prof, ssa_prof, asy_prof
-  REAL,DIMENSION(klon,klev) :: z, dz
-  REAL,DIMENSION(klon)      :: oro, zrho, zt
-  !
-  INTEGER, PARAMETER :: nmon = 12
-  !
-  REAL, PARAMETER    :: l443 = 443.0, l550 = 550.0, l865 = 865.0 !--wavelengths in nm
-  !
-  INTEGER, PARAMETER :: Nwvmax=25
-  REAL, DIMENSION(0:Nwvmax), PARAMETER :: lambda=(/ 240.0, &  !--this one is for band 1
-                  280.0,  300.0,  330.0,  360.0,  400.0,   &  !--these are bounds of Streamer bands
-                  440.0,  480.0,  520.0,  570.0,  640.0,   &
-                  690.0,  750.0,  780.0,  870.0, 1000.0,   &
-                 1100.0, 1190.0, 1280.0, 1530.0, 1640.0,   &
-                 2130.0, 2380.0, 2910.0, 3420.0, 4000.0   /)
-  !
-  REAL, DIMENSION(1:Nwvmax-1), PARAMETER :: weight =(/    &   !--and the weights to be given to the bands
-                 0.01,  4.05,  9.51, 15.99, 26.07, 33.10, &   !--corresponding to a typical solar spectrum 
-                33.07, 39.91, 52.67, 27.89, 43.60, 13.67, &
-                42.22, 40.12, 32.70, 14.44, 19.48, 14.23, &
-                13.43, 16.42,  8.33,  0.95,  0.65,  2.76  /)
-  !
-  REAL :: zlambda, zweight
-  REAL :: year_fr
-  !
-  INTEGER band, i, k, Nwv
-  !
-  ! define the height and dheight arrays
-  !
-  oro(:)  = pphis(:)/RG                             ! surface height in m
-  !
-  DO k = 1, klev
-    zrho(:) = pplay(:,k)/t_seri(:,k)/RD                         ! air density in kg/m3
-    dz(:,k) = (paprs(:,k)-paprs(:,k+1))/zrho(:)/RG              ! layer thickness in m
-    IF (k==1) THEN
-       z(:,1) = oro(:) + (paprs(:,1)-pplay(:,1))/zrho(:)/RG     ! altitude middle of first layer in m
-       zt(:)  = oro(:) + dz(:,1)                                ! altitude top of first layer in m
-    ELSE
-      z(:,k) = zt(:) + (paprs(:,k)-pplay(:,k))/zrho(:)/RG       ! altitude middle of layer k in m
-      zt(:)  = zt(:) + dz(:,k)                                  ! altitude top of layer k in m
-    ENDIF
-  ENDDO
-  !
-  !--fractional year
-  !
-  year_fr = FLOAT(year_cur) + (FLOAT(day_cur)-0.5) / FLOAT(year_len)
-  IF (year_fr.LT.1850.0.OR.year_fr.GE.2017.0) THEN
-     CALL abort_physic ('macv2sp','year not supported by plume model',1)
-  ENDIF
-  !
-  !--call to sp routine -- 443 nm
-  !
-  CALL sp_aop_profile                                    ( &
-       klev     ,klon ,l443 ,oro    ,xlon     ,xlat      , &
-       year_fr  ,z    ,dz   ,dNovrN ,aod_prof ,ssa_prof  , &
-       asy_prof )
-  !
-  !--AOD calculations for diagnostics
-  od443aer(:)= od443aer(:)+SUM(aod_prof(:,:),dim=2)
-  !
-  !--call to sp routine -- 550 nm
-  !
-  CALL sp_aop_profile                                    ( &
-       klev     ,klon ,l550 ,oro    ,xlon     ,xlat      , &
-       year_fr  ,z    ,dz   ,dNovrN ,aod_prof ,ssa_prof  , &
-       asy_prof )
-  !
-  !--AOD calculations for diagnostics
-  od550aer(:)=od550aer(:)+SUM(aod_prof(:,:),dim=2)
-  !
-  !--dry AOD calculation for diagnostics
-  dryod550aer(:)=dryod550aer(:)+od550aer(:)
-  !
-  !--fine-mode AOD calculation for diagnostics
-  od550lt1aer(:)=od550lt1aer(:)+od550aer(:)
-  !
-  !--extinction coefficient for diagnostic
-  ec550aer(:,:)=ec550aer(:,:)+aod_prof(:,:)/dz(:,:)
-  !
-  !--call to sp routine -- 865 nm
-  !
-  CALL sp_aop_profile                                    ( &
-       klev     ,klon ,l865 ,oro    ,xlon     ,xlat      , &
-       year_fr  ,z    ,dz   ,dNovrN ,aod_prof ,ssa_prof  , &
-       asy_prof )
-  !
-  !--AOD calculations for diagnostics
-  od865aer(:)=od865aer(:)+SUM(aod_prof(:,:),dim=2)
-  !
-  !--re-weighting of piz and cg arrays before adding the anthropogenic aerosols
-  !--index 2 = all natural + anthropogenic aerosols
-  piz_allaer(:,:,2,:)=piz_allaer(:,:,2,:)*tau_allaer(:,:,2,:)
-  cg_allaer(:,:,2,:) =cg_allaer(:,:,2,:)*piz_allaer(:,:,2,:)
-  !
-  !--now computing the same at many wavelengths to fill the model bands
-  !
-  DO Nwv=0,Nwvmax-1
-
-    IF (Nwv.EQ.0) THEN          !--RRTM spectral band 1
-      zlambda=lambda(Nwv)
-      zweight=1.0
-      band=1
-    ELSEIF (Nwv.LE.5) THEN      !--RRTM spectral band 2
-      zlambda=0.5*(lambda(Nwv)+lambda(Nwv+1))
-      zweight=weight(Nwv)/SUM(weight(1:5))
-      band=2
-    ELSEIF (Nwv.LE.10) THEN     !--RRTM spectral band 3
-      zlambda=0.5*(lambda(Nwv)+lambda(Nwv+1))
-      zweight=weight(Nwv)/SUM(weight(6:10))
-      band=3
-    ELSEIF (Nwv.LE.16) THEN     !--RRTM spectral band 4
-      zlambda=0.5*(lambda(Nwv)+lambda(Nwv+1))
-      zweight=weight(Nwv)/SUM(weight(11:16))
-      band=4
-    ELSEIF (Nwv.LE.21) THEN     !--RRTM spectral band 5
-      zlambda=0.5*(lambda(Nwv)+lambda(Nwv+1))
-      zweight=weight(Nwv)/SUM(weight(17:21))
-      band=5
-    ELSE                        !--RRTM spectral band 6
-      zlambda=0.5*(lambda(Nwv)+lambda(Nwv+1))
-      zweight=weight(Nwv)/SUM(weight(22:Nwvmax-1))
-      band=6
-    ENDIF
-    !
-    CALL sp_aop_profile                                       ( &
-         klev     ,klon ,zlambda ,oro    ,xlon     ,xlat      , &
-         year_fr  ,z    ,dz      ,dNovrN ,aod_prof ,ssa_prof  , &
-         asy_prof )
-    !
-    !--adding up the quantities tau, piz*tau and cg*piz*tau
-    tau_allaer(:,:,2,band)=tau_allaer(:,:,2,band)+zweight*MAX(aod_prof(:,:),1.e-15)
-    piz_allaer(:,:,2,band)=piz_allaer(:,:,2,band)+zweight*MAX(aod_prof(:,:),1.e-15)*ssa_prof(:,:)
-    cg_allaer(:,:,2,band) =cg_allaer(:,:,2,band) +zweight*MAX(aod_prof(:,:),1.e-15)*ssa_prof(:,:)*asy_prof(:,:)
-    !
-  ENDDO
-  !
-  !--renpomalizing cg and piz now that MACv2SP increments have been added
-  cg_allaer(:,:,2,:) =cg_allaer(:,:,2,:) /piz_allaer(:,:,2,:)
-  piz_allaer(:,:,2,:)=piz_allaer(:,:,2,:)/tau_allaer(:,:,2,:)
-  !
-END SUBROUTINE MACv2SP
Index: /LMDZ6/trunk/libf/phylmd/macv2sp.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/macv2sp.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/macv2sp.f90	(revision 5268)
@@ -0,0 +1,176 @@
+SUBROUTINE MACv2SP(pphis,pplay,paprs,xlon,xlat,tau_allaer,piz_allaer,cg_allaer)
+  !
+  !--routine to read the MACv2SP plume and compute optical properties
+  !--requires flag_aerosol = 7
+  !--feeds into aerosol optical properties and newmicro cloud droplet size if ok_cdnc activated
+  !--for this one needs to feed natural (pre-industrial) aerosols twice for nat and 1980 files
+  !--pre-ind aerosols (index=1) are not changed, present-day aerosols (index=2) are incremented
+  !--uses model year so year_cur needs to be correct in the model simulation
+  !
+  !--aod_prof = AOD per layer 
+  !--ssa_prof = SSA 
+  !--asy_prof = asymetry parameter
+  !--dNovrN   = enhancement factor for CDNC
+  !
+  USE mo_simple_plumes, ONLY: sp_aop_profile
+  USE phys_cal_mod, ONLY : year_cur, day_cur, year_len
+  USE dimphy
+  USE aero_mod
+  USE phys_local_var_mod, ONLY: t_seri, od443aer, od550aer, od865aer, ec550aer, dryod550aer, od550lt1aer, dNovrN
+  !!USE YOMCST, ONLY : RD, RG
+  !
+  IMPLICIT NONE
+  !
+  include "YOMCST.h"
+  ! 
+  REAL,DIMENSION(klon),INTENT(IN)        :: pphis   ! Geopotentiel de surface
+  REAL,DIMENSION(klon,klev),INTENT(IN)   :: pplay   ! pression pour le mileu de chaque couche (en Pa)
+  REAL,DIMENSION(klon,klev+1),INTENT(IN) :: paprs   ! pression pour les interfaces de chaque couche (en Pa)
+  REAL,DIMENSION(klon),INTENT(IN)        :: xlat    ! latitudes pour chaque point
+  REAL,DIMENSION(klon),INTENT(IN)        :: xlon    ! longitudes pour chaque point
+  !
+  REAL, DIMENSION(klon,klev,2,nbands_sw_rrtm), INTENT(OUT) :: tau_allaer !  epaisseur optique aerosol
+  REAL, DIMENSION(klon,klev,2,nbands_sw_rrtm), INTENT(OUT) :: piz_allaer !  single scattering albedo aerosol
+  REAL, DIMENSION(klon,klev,2,nbands_sw_rrtm), INTENT(OUT) :: cg_allaer  !  asymmetry parameter aerosol
+  !
+  REAL,DIMENSION(klon,klev) :: aod_prof, ssa_prof, asy_prof
+  REAL,DIMENSION(klon,klev) :: z, dz
+  REAL,DIMENSION(klon)      :: oro, zrho, zt
+  !
+  INTEGER, PARAMETER :: nmon = 12
+  !
+  REAL, PARAMETER    :: l443 = 443.0, l550 = 550.0, l865 = 865.0 !--wavelengths in nm
+  !
+  INTEGER, PARAMETER :: Nwvmax=25
+  REAL, DIMENSION(0:Nwvmax), PARAMETER :: lambda=(/ 240.0, &  !--this one is for band 1
+                  280.0,  300.0,  330.0,  360.0,  400.0,   &  !--these are bounds of Streamer bands
+                  440.0,  480.0,  520.0,  570.0,  640.0,   &
+                  690.0,  750.0,  780.0,  870.0, 1000.0,   &
+                 1100.0, 1190.0, 1280.0, 1530.0, 1640.0,   &
+                 2130.0, 2380.0, 2910.0, 3420.0, 4000.0   /)
+  !
+  REAL, DIMENSION(1:Nwvmax-1), PARAMETER :: weight =(/    &   !--and the weights to be given to the bands
+                 0.01,  4.05,  9.51, 15.99, 26.07, 33.10, &   !--corresponding to a typical solar spectrum 
+                33.07, 39.91, 52.67, 27.89, 43.60, 13.67, &
+                42.22, 40.12, 32.70, 14.44, 19.48, 14.23, &
+                13.43, 16.42,  8.33,  0.95,  0.65,  2.76  /)
+  !
+  REAL :: zlambda, zweight
+  REAL :: year_fr
+  !
+  INTEGER band, i, k, Nwv
+  !
+  ! define the height and dheight arrays
+  !
+  oro(:)  = pphis(:)/RG                             ! surface height in m
+  !
+  DO k = 1, klev
+    zrho(:) = pplay(:,k)/t_seri(:,k)/RD                         ! air density in kg/m3
+    dz(:,k) = (paprs(:,k)-paprs(:,k+1))/zrho(:)/RG              ! layer thickness in m
+    IF (k==1) THEN
+       z(:,1) = oro(:) + (paprs(:,1)-pplay(:,1))/zrho(:)/RG     ! altitude middle of first layer in m
+       zt(:)  = oro(:) + dz(:,1)                                ! altitude top of first layer in m
+    ELSE
+      z(:,k) = zt(:) + (paprs(:,k)-pplay(:,k))/zrho(:)/RG       ! altitude middle of layer k in m
+      zt(:)  = zt(:) + dz(:,k)                                  ! altitude top of layer k in m
+    ENDIF
+  ENDDO
+  !
+  !--fractional year
+  !
+  year_fr = FLOAT(year_cur) + (FLOAT(day_cur)-0.5) / FLOAT(year_len)
+  IF (year_fr.LT.1850.0.OR.year_fr.GE.2017.0) THEN
+     CALL abort_physic ('macv2sp','year not supported by plume model',1)
+  ENDIF
+  !
+  !--call to sp routine -- 443 nm
+  !
+  CALL sp_aop_profile                                    ( &
+       klev     ,klon ,l443 ,oro    ,xlon     ,xlat      , &
+       year_fr  ,z    ,dz   ,dNovrN ,aod_prof ,ssa_prof  , &
+       asy_prof )
+  !
+  !--AOD calculations for diagnostics
+  od443aer(:)= od443aer(:)+SUM(aod_prof(:,:),dim=2)
+  !
+  !--call to sp routine -- 550 nm
+  !
+  CALL sp_aop_profile                                    ( &
+       klev     ,klon ,l550 ,oro    ,xlon     ,xlat      , &
+       year_fr  ,z    ,dz   ,dNovrN ,aod_prof ,ssa_prof  , &
+       asy_prof )
+  !
+  !--AOD calculations for diagnostics
+  od550aer(:)=od550aer(:)+SUM(aod_prof(:,:),dim=2)
+  !
+  !--dry AOD calculation for diagnostics
+  dryod550aer(:)=dryod550aer(:)+od550aer(:)
+  !
+  !--fine-mode AOD calculation for diagnostics
+  od550lt1aer(:)=od550lt1aer(:)+od550aer(:)
+  !
+  !--extinction coefficient for diagnostic
+  ec550aer(:,:)=ec550aer(:,:)+aod_prof(:,:)/dz(:,:)
+  !
+  !--call to sp routine -- 865 nm
+  !
+  CALL sp_aop_profile                                    ( &
+       klev     ,klon ,l865 ,oro    ,xlon     ,xlat      , &
+       year_fr  ,z    ,dz   ,dNovrN ,aod_prof ,ssa_prof  , &
+       asy_prof )
+  !
+  !--AOD calculations for diagnostics
+  od865aer(:)=od865aer(:)+SUM(aod_prof(:,:),dim=2)
+  !
+  !--re-weighting of piz and cg arrays before adding the anthropogenic aerosols
+  !--index 2 = all natural + anthropogenic aerosols
+  piz_allaer(:,:,2,:)=piz_allaer(:,:,2,:)*tau_allaer(:,:,2,:)
+  cg_allaer(:,:,2,:) =cg_allaer(:,:,2,:)*piz_allaer(:,:,2,:)
+  !
+  !--now computing the same at many wavelengths to fill the model bands
+  !
+  DO Nwv=0,Nwvmax-1
+
+    IF (Nwv.EQ.0) THEN          !--RRTM spectral band 1
+      zlambda=lambda(Nwv)
+      zweight=1.0
+      band=1
+    ELSEIF (Nwv.LE.5) THEN      !--RRTM spectral band 2
+      zlambda=0.5*(lambda(Nwv)+lambda(Nwv+1))
+      zweight=weight(Nwv)/SUM(weight(1:5))
+      band=2
+    ELSEIF (Nwv.LE.10) THEN     !--RRTM spectral band 3
+      zlambda=0.5*(lambda(Nwv)+lambda(Nwv+1))
+      zweight=weight(Nwv)/SUM(weight(6:10))
+      band=3
+    ELSEIF (Nwv.LE.16) THEN     !--RRTM spectral band 4
+      zlambda=0.5*(lambda(Nwv)+lambda(Nwv+1))
+      zweight=weight(Nwv)/SUM(weight(11:16))
+      band=4
+    ELSEIF (Nwv.LE.21) THEN     !--RRTM spectral band 5
+      zlambda=0.5*(lambda(Nwv)+lambda(Nwv+1))
+      zweight=weight(Nwv)/SUM(weight(17:21))
+      band=5
+    ELSE                        !--RRTM spectral band 6
+      zlambda=0.5*(lambda(Nwv)+lambda(Nwv+1))
+      zweight=weight(Nwv)/SUM(weight(22:Nwvmax-1))
+      band=6
+    ENDIF
+    !
+    CALL sp_aop_profile                                       ( &
+         klev     ,klon ,zlambda ,oro    ,xlon     ,xlat      , &
+         year_fr  ,z    ,dz      ,dNovrN ,aod_prof ,ssa_prof  , &
+         asy_prof )
+    !
+    !--adding up the quantities tau, piz*tau and cg*piz*tau
+    tau_allaer(:,:,2,band)=tau_allaer(:,:,2,band)+zweight*MAX(aod_prof(:,:),1.e-15)
+    piz_allaer(:,:,2,band)=piz_allaer(:,:,2,band)+zweight*MAX(aod_prof(:,:),1.e-15)*ssa_prof(:,:)
+    cg_allaer(:,:,2,band) =cg_allaer(:,:,2,band) +zweight*MAX(aod_prof(:,:),1.e-15)*ssa_prof(:,:)*asy_prof(:,:)
+    !
+  ENDDO
+  !
+  !--renpomalizing cg and piz now that MACv2SP increments have been added
+  cg_allaer(:,:,2,:) =cg_allaer(:,:,2,:) /piz_allaer(:,:,2,:)
+  piz_allaer(:,:,2,:)=piz_allaer(:,:,2,:)/tau_allaer(:,:,2,:)
+  !
+END SUBROUTINE MACv2SP
Index: DZ6/trunk/libf/phylmd/methox.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/methox.F90	(revision 5267)
+++ 	(revision )
@@ -1,118 +1,0 @@
-SUBROUTINE METHOX(KIDIA,  KFDIA,  KLON,  KLEV,PQ,     PTENQ,  PAP )
-
-!**** *METHOX*   - Calculate humidity tendencies from methane
-!                  oxidation and photolysis
-
-!**   INTERFACE.
-!     ----------
-!        CALL *METHOX* FROM *CALLPAR*
-!              ------        -------
-
-!        EXPLICIT ARGUMENTS :
-!        --------------------
-!     PARAMETER     DESCRIPTION                                   UNITS
-!     ---------     -----------                                   -----
-!     INPUT PARAMETERS (INTEGER):
-
-!    *KIDIA*        START POINT
-!    *KFDIA*        END POINT
-!    *KLON*         NUMBER OF GRID POINTS PER PACKET
-!    *KLEV*         NUMBER OF LEVELS
-
-!     INPUT PARAMETERS (REAL):
-
-!    *PAP*          PRESSURE                                      PA
-!    *PQ*           SPECIFIC HUMIDITY                             KG/KG
-
-!     UPDATED PARAMETERS (REAL):
-
-!    *PTENQ*        TENDENCY OF SPECIFIC HUMIDITY                 KG/(KG*S)
-
-!        NONE
-
-!        IMPLICIT ARGUMENTS :
-!        --------------------
-!        MODULE YOEMETH
-!        MODULE YOMCST
-
-!     METHOD.
-!     -------
-!        SEE RD-MEMO R60.1/AJS/31
-
-!     EXTERNALS.
-!     ----------
-!        NONE
-
-!     REFERENCE.
-!     ----------
-!        SEE RD-MEMO R60.1/AJS/31
-
-!     AUTHOR.
-!     -------
-!        C.JAKOB   *ECMWF*
-
-!     MODIFICATIONS.
-!     --------------
-!        ORIGINAL : 98-04-07
-!        M.Hamrud      01-Oct-2003 CY28 Cleaning
-!        D. Cugnet     24-Feb-2012 Adapted for LMDZ
-!     ------------------------------------------------------------------
-
-USE YOEMETH   , ONLY : RALPHA1 ,RALPHA2  ,RQLIM   ,&
- & RPBOTOX,  RPBOTPH ,RPTOPOX  ,RPTOPPH ,&
- & RALPHA3,  RLOGPPH  
-
-IMPLICIT NONE
-
-INCLUDE "YOMCST.h"
-
-INTEGER,INTENT(IN)    :: KLON 
-INTEGER,INTENT(IN)    :: KLEV 
-INTEGER,INTENT(IN)    :: KIDIA 
-INTEGER,INTENT(IN)    :: KFDIA 
-REAL   ,INTENT(IN)    :: PQ(KLON,KLEV) 
-REAL   ,INTENT(INOUT) :: PTENQ(KLON,KLEV) 
-REAL   ,INTENT(IN)    :: PAP(KLON,KLEV) 
-LOGICAL :: LLOXID,         LLPHOTO
-
-INTEGER :: JK, JL
-
-REAL :: ZARG, ZPRATIO, ZTAU1, ZTAU2, ZTDAYS
-
-DO JK=1,KLEV
-  DO JL=KIDIA,KFDIA
-
-    LLOXID=PAP(JL,JK) < RPBOTOX.AND.PQ(JL,JK) < RQLIM
-    LLPHOTO=PAP(JL,JK) < RPBOTPH
-
-!     METHANE OXIDATION
-
-    IF(LLOXID) THEN
-      IF(PAP(JL,JK) <= RPTOPOX) THEN
-        ZTDAYS=100.
-      ELSE
-        ZPRATIO=(LOG(PAP(JL,JK)/RPTOPOX))**4./LOG(RPBOTOX/PAP(JL,JK))
-        ZTDAYS=100.*(1+RALPHA1*ZPRATIO)
-      ENDIF
-      ZTAU1=86400.*ZTDAYS
-      PTENQ(JL,JK)=PTENQ(JL,JK)+(RQLIM-PQ(JL,JK))/ZTAU1
-    ENDIF
-
-!     PHOTOLYSIS
-
-    IF(LLPHOTO) THEN
-      IF(PAP(JL,JK) <= RPTOPPH) THEN
-        ZTDAYS=3.
-      ELSE
-        ZARG=RALPHA2-RALPHA3*(1+COS((RPI*LOG(PAP(JL,JK)/RPBOTPH))/RLOGPPH))
-        ZTDAYS=1.0/(EXP(ZARG)-0.01)
-      ENDIF
-      ZTAU2=86400.*ZTDAYS
-      PTENQ(JL,JK)=PTENQ(JL,JK)-PQ(JL,JK)/ZTAU2
-    ENDIF
-  ENDDO
-ENDDO
-
-END SUBROUTINE METHOX
-
-
Index: /LMDZ6/trunk/libf/phylmd/methox.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/methox.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/methox.f90	(revision 5268)
@@ -0,0 +1,118 @@
+SUBROUTINE METHOX(KIDIA,  KFDIA,  KLON,  KLEV,PQ,     PTENQ,  PAP )
+
+!**** *METHOX*   - Calculate humidity tendencies from methane
+!                  oxidation and photolysis
+
+!**   INTERFACE.
+!     ----------
+!        CALL *METHOX* FROM *CALLPAR*
+!              ------        -------
+
+!        EXPLICIT ARGUMENTS :
+!        --------------------
+!     PARAMETER     DESCRIPTION                                   UNITS
+!     ---------     -----------                                   -----
+!     INPUT PARAMETERS (INTEGER):
+
+!    *KIDIA*        START POINT
+!    *KFDIA*        END POINT
+!    *KLON*         NUMBER OF GRID POINTS PER PACKET
+!    *KLEV*         NUMBER OF LEVELS
+
+!     INPUT PARAMETERS (REAL):
+
+!    *PAP*          PRESSURE                                      PA
+!    *PQ*           SPECIFIC HUMIDITY                             KG/KG
+
+!     UPDATED PARAMETERS (REAL):
+
+!    *PTENQ*        TENDENCY OF SPECIFIC HUMIDITY                 KG/(KG*S)
+
+!        NONE
+
+!        IMPLICIT ARGUMENTS :
+!        --------------------
+!        MODULE YOEMETH
+!        MODULE YOMCST
+
+!     METHOD.
+!     -------
+!        SEE RD-MEMO R60.1/AJS/31
+
+!     EXTERNALS.
+!     ----------
+!        NONE
+
+!     REFERENCE.
+!     ----------
+!        SEE RD-MEMO R60.1/AJS/31
+
+!     AUTHOR.
+!     -------
+!        C.JAKOB   *ECMWF*
+
+!     MODIFICATIONS.
+!     --------------
+!        ORIGINAL : 98-04-07
+!        M.Hamrud      01-Oct-2003 CY28 Cleaning
+!        D. Cugnet     24-Feb-2012 Adapted for LMDZ
+!     ------------------------------------------------------------------
+
+USE YOEMETH   , ONLY : RALPHA1 ,RALPHA2  ,RQLIM   ,&
+ & RPBOTOX,  RPBOTPH ,RPTOPOX  ,RPTOPPH ,&
+ & RALPHA3,  RLOGPPH  
+
+IMPLICIT NONE
+
+INCLUDE "YOMCST.h"
+
+INTEGER,INTENT(IN)    :: KLON 
+INTEGER,INTENT(IN)    :: KLEV 
+INTEGER,INTENT(IN)    :: KIDIA 
+INTEGER,INTENT(IN)    :: KFDIA 
+REAL   ,INTENT(IN)    :: PQ(KLON,KLEV) 
+REAL   ,INTENT(INOUT) :: PTENQ(KLON,KLEV) 
+REAL   ,INTENT(IN)    :: PAP(KLON,KLEV) 
+LOGICAL :: LLOXID,         LLPHOTO
+
+INTEGER :: JK, JL
+
+REAL :: ZARG, ZPRATIO, ZTAU1, ZTAU2, ZTDAYS
+
+DO JK=1,KLEV
+  DO JL=KIDIA,KFDIA
+
+    LLOXID=PAP(JL,JK) < RPBOTOX.AND.PQ(JL,JK) < RQLIM
+    LLPHOTO=PAP(JL,JK) < RPBOTPH
+
+!     METHANE OXIDATION
+
+    IF(LLOXID) THEN
+      IF(PAP(JL,JK) <= RPTOPOX) THEN
+        ZTDAYS=100.
+      ELSE
+        ZPRATIO=(LOG(PAP(JL,JK)/RPTOPOX))**4./LOG(RPBOTOX/PAP(JL,JK))
+        ZTDAYS=100.*(1+RALPHA1*ZPRATIO)
+      ENDIF
+      ZTAU1=86400.*ZTDAYS
+      PTENQ(JL,JK)=PTENQ(JL,JK)+(RQLIM-PQ(JL,JK))/ZTAU1
+    ENDIF
+
+!     PHOTOLYSIS
+
+    IF(LLPHOTO) THEN
+      IF(PAP(JL,JK) <= RPTOPPH) THEN
+        ZTDAYS=3.
+      ELSE
+        ZARG=RALPHA2-RALPHA3*(1+COS((RPI*LOG(PAP(JL,JK)/RPBOTPH))/RLOGPPH))
+        ZTDAYS=1.0/(EXP(ZARG)-0.01)
+      ENDIF
+      ZTAU2=86400.*ZTDAYS
+      PTENQ(JL,JK)=PTENQ(JL,JK)-PQ(JL,JK)/ZTAU2
+    ENDIF
+  ENDDO
+ENDDO
+
+END SUBROUTINE METHOX
+
+
Index: DZ6/trunk/libf/phylmd/minmaxqfi.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/minmaxqfi.F90	(revision 5267)
+++ 	(revision )
@@ -1,36 +1,0 @@
-!
-! $Id$
-!
-SUBROUTINE minmaxqfi(zq,qmin,qmax,comment)
-  USE dimphy
-  USE print_control_mod, ONLY: prt_level
-  IMPLICIT NONE
-
-! Entrees
-  REAL,DIMENSION(klon,klev), INTENT(IN)   :: zq
-  REAL,INTENT(IN)                         :: qmin,qmax
-  CHARACTER(LEN=*),INTENT(IN)             :: comment
-
-! Local  
-  INTEGER,DIMENSION(klon)     :: jadrs 
-  INTEGER                     :: i, jbad, k
-
-  DO k = 1, klev
-     jbad = 0
-     DO i = 1, klon
-        IF (zq(i,k).GT.qmax .OR. zq(i,k).LT.qmin) THEN
-           jbad = jbad + 1
-           jadrs(jbad) = i
-        ENDIF
-     ENDDO
-     IF (jbad.GT.0) THEN
-        WRITE(*,*)comment, "  k = ", k, "jbad > 0"
-        if (prt_level >= 1) then
-           DO i = 1, jbad
-              WRITE(*,*) "i,q=", jadrs(i), zq(jadrs(i),k)
-           ENDDO
-        end if
-     ENDIF
-  ENDDO
-  
-END SUBROUTINE minmaxqfi
Index: /LMDZ6/trunk/libf/phylmd/minmaxqfi.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/minmaxqfi.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/minmaxqfi.f90	(revision 5268)
@@ -0,0 +1,36 @@
+!
+! $Id$
+!
+SUBROUTINE minmaxqfi(zq,qmin,qmax,comment)
+  USE dimphy
+  USE print_control_mod, ONLY: prt_level
+  IMPLICIT NONE
+
+! Entrees
+  REAL,DIMENSION(klon,klev), INTENT(IN)   :: zq
+  REAL,INTENT(IN)                         :: qmin,qmax
+  CHARACTER(LEN=*),INTENT(IN)             :: comment
+
+! Local  
+  INTEGER,DIMENSION(klon)     :: jadrs 
+  INTEGER                     :: i, jbad, k
+
+  DO k = 1, klev
+     jbad = 0
+     DO i = 1, klon
+        IF (zq(i,k).GT.qmax .OR. zq(i,k).LT.qmin) THEN
+           jbad = jbad + 1
+           jadrs(jbad) = i
+        ENDIF
+     ENDDO
+     IF (jbad.GT.0) THEN
+        WRITE(*,*)comment, "  k = ", k, "jbad > 0"
+        if (prt_level >= 1) then
+           DO i = 1, jbad
+              WRITE(*,*) "i,q=", jadrs(i), zq(jadrs(i),k)
+           ENDDO
+        end if
+     ENDIF
+  ENDDO
+  
+END SUBROUTINE minmaxqfi
Index: DZ6/trunk/libf/phylmd/mo_simple_plumes.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/mo_simple_plumes.F90	(revision 5267)
+++ 	(revision )
@@ -1,498 +1,0 @@
-!>
-!!
-!! @brief Module MO_SIMPLE_PLUMES: provides anthropogenic aerosol optical properties as a function of lat, lon
-!!   height, time, and wavelength
-!!
-!! @remarks
-!!
-!! @author Bjorn Stevens, Stephanie Fiedler and Karsten Peters MPI-Met, Hamburg (v1 release 2016-11-10)
-!!
-!! @change-log:
-!!          - 2016-12-05: beta release (BS, SF and KP, MPI-Met)
-!!          - 2016-09-28: revised representation of Twomey effect (SF, MPI-Met)
-!!          - 2015-09-28: bug fixes  (SF, MPI-Met)
-!!          - 2016-10-12: revised maximum longitudinal extent of European plume (KP, SF, MPI-Met)
-!! $ID: n/a$
-!!
-!! @par Origin
-!!   Based on code originally developed at the MPI-Met by Karsten Peters, Bjorn Stevens, Stephanie Fiedler
-!!   and Stefan Kinne with input from Thorsten Mauritsen and Robert Pincus
-!!
-!! @par Copyright
-!! 
-!
-MODULE MO_SIMPLE_PLUMES
-
-  USE netcdf
-
-  IMPLICIT NONE
-
-  INTEGER, PARAMETER ::                        &
-       nplumes   = 9                          ,& !< Number of plumes
-       nfeatures = 2                          ,& !< Number of features per plume
-       ntimes    = 52                         ,& !< Number of times resolved per year (52 => weekly resolution)
-       nyears    = 251                           !< Number of years of available forcing
-
-  LOGICAL, SAVE ::                             &
-       sp_initialized = .FALSE.                  !< parameter determining whether input needs to be read
-!$OMP THREADPRIVATE(sp_initialized)
-
-  REAL, SAVE ::                                &
-       plume_lat      (nplumes)               ,& !< latitude of plume center (AOD maximum)
-       plume_lon      (nplumes)               ,& !< longitude of plume center (AOD maximum)
-       beta_a         (nplumes)               ,& !< parameter a for beta function vertical profile
-       beta_b         (nplumes)               ,& !< parameter b for beta function vertical profile
-       aod_spmx       (nplumes)               ,& !< anthropogenic AOD maximum at 550 for plumes 
-       aod_fmbg       (nplumes)               ,& !< anthropogenic AOD at 550 for fine-mode natural background (idealized to mimic Twomey effect)
-       asy550         (nplumes)               ,& !< asymmetry parameter at 550nm for plume
-       ssa550         (nplumes)               ,& !< single scattering albedo at 550nm for plume
-       angstrom       (nplumes)               ,& !< Angstrom parameter for plume 
-       sig_lon_E      (nfeatures,nplumes)     ,& !< Eastward extent of plume feature
-       sig_lon_W      (nfeatures,nplumes)     ,& !< Westward extent of plume feature
-       sig_lat_E      (nfeatures,nplumes)     ,& !< Southward extent of plume feature
-       sig_lat_W      (nfeatures,nplumes)     ,& !< Northward extent of plume feature
-       theta          (nfeatures,nplumes)     ,& !< Rotation angle of plume feature
-       ftr_weight     (nfeatures,nplumes)     ,& !< Feature weights 
-       year_weight    (nyears,nplumes)        ,& !< Yearly weight for plume
-       ann_cycle      (nfeatures,ntimes,nplumes) !< annual cycle for plume feature
-!$OMP THREADPRIVATE(plume_lat,plume_lon,beta_a,beta_b,aod_spmx,aod_fmbg,asy550,ssa550,angstrom)
-!$OMP THREADPRIVATE(sig_lon_E,sig_lon_W,sig_lat_E,sig_lat_W,theta,ftr_weight,year_weight,ann_cycle)
-
-  REAL ::                                      &
-       time_weight    (nfeatures,nplumes)     ,& !< Time weights 
-       time_weight_bg (nfeatures,nplumes)        !< as time_weight but for natural background in Twomey effect 
-
-  PUBLIC sp_aop_profile
-
-CONTAINS
-  !
-  ! ------------------------------------------------------------------------------------------------------------------------
-  ! SP_SETUP:  This subroutine should be called at initialization to read the netcdf data that describes the simple plume
-  ! climatology.  The information needs to be either read by each processor or distributed to processors.
-  !
-  SUBROUTINE sp_setup
-    !
-    USE mod_phys_lmdz_mpi_data, ONLY: is_mpi_root
-    USE mod_phys_lmdz_omp_data, ONLY: is_omp_root
-    USE mod_phys_lmdz_transfert_para, ONLY: bcast
-    !
-    ! ---------- 
-    !
-    INTEGER :: iret, ncid, DimID, VarID, xdmy
-    CHARACTER (len = 50)     :: modname = 'mo_simple_plumes.sp_setup'
-    CHARACTER (len = 80)     :: abort_message
-    !
-    ! ---------- 
-    !--only one processor reads the input data
-    IF (is_mpi_root.AND.is_omp_root) THEN
-       !    
-       iret = nf90_open("MACv2.0-SP_v1.nc", NF90_NOWRITE, ncid)
-       IF (iret /= NF90_NOERR) THEN
-          abort_message='NetCDF File not opened'
-          CALL abort_physic(modname,abort_message,1)
-       ENDIF
-       !
-       ! read dimensions and make sure file conforms to expected size
-       !
-       iret = nf90_inq_dimid(ncid, "plume_number"  , DimId)
-       iret = nf90_inquire_dimension(ncid, DimId, len = xdmy)
-       IF (xdmy /= nplumes) THEN
-          abort_message='NetCDF improperly dimensioned -- plume_number'
-          CALL abort_physic(modname,abort_message,1)
-       ENDIF
-       !
-       iret = nf90_inq_dimid(ncid, "plume_feature", DimId)
-       iret = nf90_inquire_dimension(ncid, DimId, len = xdmy)
-       IF (xdmy /= nfeatures) THEN
-          abort_message='NetCDF improperly dimensioned -- plume_feature'
-          CALL abort_physic(modname,abort_message,1)
-       ENDIF
-       !
-       iret = nf90_inq_dimid(ncid, "year_fr"   , DimId)
-       iret = nf90_inquire_dimension(ncid, DimID, len = xdmy)
-       IF (xdmy /= ntimes) THEN
-          abort_message='NetCDF improperly dimensioned -- year_fr'
-          CALL abort_physic(modname,abort_message,1)
-       ENDIF
-       !
-       iret = nf90_inq_dimid(ncid, "years"   , DimId)
-       iret = nf90_inquire_dimension(ncid, DimID, len = xdmy)
-       IF (xdmy /= nyears) THEN
-          abort_message='NetCDF improperly dimensioned -- years'
-          CALL abort_physic(modname,abort_message,1)
-       ENDIF
-       !
-       ! read variables that define the simple plume climatology
-       !
-       iret = nf90_inq_varid(ncid, "plume_lat", VarId)
-       iret = nf90_get_var(ncid, VarID, plume_lat(:), start=(/1/),count=(/nplumes/))
-       IF (iret /= NF90_NOERR) THEN
-          abort_message='NetCDF Error reading plume_lat'
-          CALL abort_physic(modname,abort_message,1)
-       ENDIF
-       !
-       iret = nf90_inq_varid(ncid, "plume_lon", VarId)
-       iret = nf90_get_var(ncid, VarID, plume_lon(:), start=(/1/),count=(/nplumes/))
-       IF (iret /= NF90_NOERR) THEN
-          abort_message='NetCDF Error reading plume_lon'
-          CALL abort_physic(modname,abort_message,1)
-       ENDIF
-       !
-       iret = nf90_inq_varid(ncid, "beta_a"   , VarId)
-       iret = nf90_get_var(ncid, VarID, beta_a(:)   , start=(/1/),count=(/nplumes/))
-       IF (iret /= NF90_NOERR) THEN
-          abort_message='NetCDF Error reading beta_a'
-          CALL abort_physic(modname,abort_message,1)
-       ENDIF
-       !
-       iret = nf90_inq_varid(ncid, "beta_b"   , VarId)
-       iret = nf90_get_var(ncid, VarID, beta_b(:)   , start=(/1/),count=(/nplumes/))
-       IF (iret /= NF90_NOERR) THEN
-          abort_message='NetCDF Error reading beta_b'
-          CALL abort_physic(modname,abort_message,1)
-       ENDIF
-       !
-       iret = nf90_inq_varid(ncid, "aod_spmx" , VarId)
-       iret = nf90_get_var(ncid, VarID, aod_spmx(:)  , start=(/1/),count=(/nplumes/))
-       IF (iret /= NF90_NOERR) THEN
-          abort_message='NetCDF Error reading aod_spmx'
-          CALL abort_physic(modname,abort_message,1)
-       ENDIF
-       !
-       iret = nf90_inq_varid(ncid, "aod_fmbg" , VarId)
-       iret = nf90_get_var(ncid, VarID, aod_fmbg(:)  , start=(/1/),count=(/nplumes/))
-       IF (iret /= NF90_NOERR) THEN
-          abort_message='NetCDF Error reading aod_fmbg'
-          CALL abort_physic(modname,abort_message,1)
-       ENDIF
-       !
-       iret = nf90_inq_varid(ncid, "ssa550"   , VarId)
-       iret = nf90_get_var(ncid, VarID, ssa550(:)  , start=(/1/),count=(/nplumes/))
-       IF (iret /= NF90_NOERR) THEN
-          abort_message='NetCDF Error reading ssa550'
-          CALL abort_physic(modname,abort_message,1)
-       ENDIF
-       !
-       iret = nf90_inq_varid(ncid, "asy550"   , VarId)
-       iret = nf90_get_var(ncid, VarID, asy550(:)  , start=(/1/),count=(/nplumes/))
-       IF (iret /= NF90_NOERR) THEN
-          abort_message='NetCDF Error reading asy550'
-          CALL abort_physic(modname,abort_message,1)
-       ENDIF
-       !
-       iret = nf90_inq_varid(ncid, "angstrom" , VarId)
-       iret = nf90_get_var(ncid, VarID, angstrom(:), start=(/1/),count=(/nplumes/))
-       IF (iret /= NF90_NOERR) THEN
-          abort_message='NetCDF Error reading angstrom'
-          CALL abort_physic(modname,abort_message,1)
-       ENDIF
-       !
-       iret = nf90_inq_varid(ncid, "sig_lat_W"     , VarId)
-       iret = nf90_get_var(ncid, VarID, sig_lat_W(:,:)    , start=(/1,1/),count=(/nfeatures,nplumes/))
-       IF (iret /= NF90_NOERR) THEN
-          abort_message='NetCDF Error reading sig_lat_W'
-          CALL abort_physic(modname,abort_message,1)
-       ENDIF
-       !
-       iret = nf90_inq_varid(ncid, "sig_lat_E"     , VarId)
-       iret = nf90_get_var(ncid, VarID, sig_lat_E(:,:)    , start=(/1,1/),count=(/nfeatures,nplumes/))
-       IF (iret /= NF90_NOERR) THEN
-          abort_message='NetCDF Error reading sig_lat_E'
-          CALL abort_physic(modname,abort_message,1)
-       ENDIF
-       !
-       iret = nf90_inq_varid(ncid, "sig_lon_E"     , VarId)
-       iret = nf90_get_var(ncid, VarID, sig_lon_E(:,:)    , start=(/1,1/),count=(/nfeatures,nplumes/))
-       IF (iret /= NF90_NOERR) THEN
-          abort_message='NetCDF Error reading sig_lon_E'
-          CALL abort_physic(modname,abort_message,1)
-       ENDIF
-       !
-       iret = nf90_inq_varid(ncid, "sig_lon_W"     , VarId)
-       iret = nf90_get_var(ncid, VarID, sig_lon_W(:,:)    , start=(/1,1/),count=(/nfeatures,nplumes/))
-       IF (iret /= NF90_NOERR) THEN
-          abort_message='NetCDF Error reading sig_lon_W'
-          CALL abort_physic(modname,abort_message,1)
-       ENDIF
-       !
-       iret = nf90_inq_varid(ncid, "theta"         , VarId)
-       iret = nf90_get_var(ncid, VarID, theta(:,:)        , start=(/1,1/),count=(/nfeatures,nplumes/))
-       IF (iret /= NF90_NOERR) THEN
-          abort_message='NetCDF Error reading theta'
-          CALL abort_physic(modname,abort_message,1)
-       ENDIF
-       !
-       iret = nf90_inq_varid(ncid, "ftr_weight"    , VarId)
-       iret = nf90_get_var(ncid, VarID, ftr_weight(:,:)   , start=(/1,1/),count=(/nfeatures,nplumes/))
-       IF (iret /= NF90_NOERR) THEN
-          abort_message='NetCDF Error reading plume_lat'
-          CALL abort_physic(modname,abort_message,1)
-       ENDIF
-       !
-       iret = nf90_inq_varid(ncid, "year_weight"   , VarId)
-       iret = nf90_get_var(ncid, VarID, year_weight(:,:)  , start=(/1,1/),count=(/nyears,nplumes   /))
-       IF (iret /= NF90_NOERR) THEN
-          abort_message='NetCDF Error reading year_weight'
-          CALL abort_physic(modname,abort_message,1)
-       ENDIF
-       !
-       iret = nf90_inq_varid(ncid, "ann_cycle"     , VarId)
-       iret = nf90_get_var(ncid, VarID, ann_cycle(:,:,:)  , start=(/1,1,1/),count=(/nfeatures,ntimes,nplumes/))
-       IF (iret /= NF90_NOERR) THEN
-          abort_message='NetCDF Error reading ann_cycle'
-          CALL abort_physic(modname,abort_message,1)
-       ENDIF
-       !
-       iret = nf90_close(ncid)
-       !
-    ENDIF !--root processor
-    !
-    CALL bcast(plume_lat)
-    CALL bcast(plume_lon)
-    CALL bcast(beta_a)
-    CALL bcast(beta_b)
-    CALL bcast(aod_spmx)
-    CALL bcast(aod_fmbg)
-    CALL bcast(asy550)
-    CALL bcast(ssa550)
-    CALL bcast(angstrom)
-    CALL bcast(sig_lon_E)
-    CALL bcast(sig_lon_W)
-    CALL bcast(sig_lat_E)
-    CALL bcast(sig_lat_W)
-    CALL bcast(theta)
-    CALL bcast(ftr_weight)
-    CALL bcast(year_weight)
-    CALL bcast(ann_cycle)
-    !
-    sp_initialized = .TRUE.
-    !
-    RETURN
-    !
-  END SUBROUTINE sp_setup
-  !
-  ! ------------------------------------------------------------------------------------------------------------------------
-  ! SET_TIME_WEIGHT:  The simple plume model assumes that meteorology constrains plume shape and that only source strength
-  ! influences the amplitude of a plume associated with a given source region.   This routine retrieves the temporal weights
-  ! for the plumes.  Each plume feature has its own temporal weights which varies yearly.  The annual cycle is indexed by
-  ! week in the year and superimposed on the yearly mean value of the weight. 
-  !
-  SUBROUTINE set_time_weight(year_fr)
-    !
-    ! ---------- 
-    !
-    REAL, INTENT(IN) ::  &
-         year_fr           !< Fractional Year (1850.0 - 2100.99)
-
-    INTEGER          ::  &
-         iyear          ,& !< Integer year values between 1 and 156 (1850-2100) 
-         iweek          ,& !< Integer index (between 1 and ntimes); for ntimes=52 this corresponds to weeks (roughly)
-         iplume            ! plume number
-    !
-    ! ---------- 
-    !
-    iyear = FLOOR(year_fr) - 1849
-    iweek = FLOOR((year_fr - FLOOR(year_fr)) * ntimes) + 1
-
-    IF ((iweek > ntimes) .OR. (iweek < 1) .OR. (iyear > nyears) .OR. (iyear < 1)) THEN 
-      CALL abort_physic('set_time_weight','Time out of bounds',1)
-    ENDIF
-
-    DO iplume=1,nplumes
-      time_weight(1,iplume) = year_weight(iyear,iplume) * ann_cycle(1,iweek,iplume)
-      time_weight(2,iplume) = year_weight(iyear,iplume) * ann_cycle(2,iweek,iplume)
-      time_weight_bg(1,iplume) = ann_cycle(1,iweek,iplume)
-      time_weight_bg(2,iplume) = ann_cycle(2,iweek,iplume) 
-    ENDDO
-    
-    RETURN
-  END SUBROUTINE set_time_weight
-  !
-  ! ------------------------------------------------------------------------------------------------------------------------
-  ! SP_AOP_PROFILE:  This subroutine calculates the simple plume aerosol and cloud active optical properties based on the
-  ! the simple plume fit to the MPI Aerosol Climatology (Version 2).  It sums over nplumes to provide a profile of aerosol
-  ! optical properties on a host models vertical grid. 
-  !
-  SUBROUTINE sp_aop_profile                                                                           ( &
-       nlevels        ,ncol           ,lambda         ,oro            ,lon            ,lat            , &
-       year_fr        ,z              ,dz             ,dNovrN         ,aod_prof       ,ssa_prof       , &
-       asy_prof       )
-    !
-    ! ---------- 
-    !
-    INTEGER, INTENT(IN)        :: &
-         nlevels,                 & !< number of levels
-         ncol                       !< number of columns
-
-    REAL, INTENT(IN)           :: &
-         lambda,                  & !< wavelength
-         year_fr,                 & !< Fractional Year (1903.0 is the 0Z on the first of January 1903, Gregorian)
-         oro(ncol),               & !< orographic height (m)
-         lon(ncol),               & !< longitude 
-         lat(ncol),               & !< latitude
-         z (ncol,nlevels),        & !< height above sea-level (m)
-         dz(ncol,nlevels)           !< level thickness (difference between half levels) (m)
-
-    REAL, INTENT(OUT)          :: &
-         dNovrN(ncol)           , & !< anthropogenic increase in cloud drop number concentration (factor)
-         aod_prof(ncol,nlevels) , & !< profile of aerosol optical depth
-         ssa_prof(ncol,nlevels) , & !< profile of single scattering albedo
-         asy_prof(ncol,nlevels)     !< profile of asymmetry parameter
-
-    INTEGER                    :: iplume, icol, k
-
-    REAL                       ::  &
-         eta(ncol,nlevels),        & !< normalized height (by 15 km)
-         z_beta(ncol,nlevels),     & !< profile for scaling column optical depth
-         prof(ncol,nlevels),       & !< scaled profile (by beta function)
-         beta_sum(ncol),           & !< vertical sum of beta function
-         ssa(ncol),                & !< single scattering albedo 
-         asy(ncol),                & !< asymmetry parameter
-         cw_an(ncol),              & !< column weight for simple plume (anthropogenic) AOD at 550 nm
-         cw_bg(ncol),              & !< column weight for fine-mode natural background AOD at 550 nm
-         caod_sp(ncol),            & !< column simple plume anthropogenic AOD at 550 nm
-         caod_bg(ncol),            & !< column fine-mode natural background AOD at 550 nm
-         a_plume1,                 & !< gaussian longitude factor for feature 1
-         a_plume2,                 & !< gaussian longitude factor for feature 2
-         b_plume1,                 & !< gaussian latitude factor for feature 1
-         b_plume2,                 & !< gaussian latitude factor for feature 2
-         delta_lat,                & !< latitude offset
-         delta_lon,                & !< longitude offset
-         delta_lon_t,              & !< threshold for maximum longitudinal plume extent used in transition from 360 to 0 degrees
-         lon1,                     & !< rotated longitude for feature 1
-         lat1,                     & !< rotated latitude for feature 2
-         lon2,                     & !< rotated longitude for feature 1
-         lat2,                     & !< rotated latitude for feature 2
-         f1,                       & !< contribution from feature 1
-         f2,                       & !< contribution from feature 2
-         f3,                       & !< contribution from feature 1 in natural background of Twomey effect
-         f4,                       & !< contribution from feature 2 in natural background of Twomey effect
-         aod_550,                  & !< aerosol optical depth at 550nm
-         aod_lmd,                  & !< aerosol optical depth at input wavelength
-         lfactor                     !< factor to compute wavelength dependence of optical properties
-    !
-    ! ---------- 
-    !
-    ! initialize input data (by calling setup at first instance) 
-    !
-    IF (.NOT.sp_initialized) CALL sp_setup
-    !
-    ! get time weights
-    !
-    CALL set_time_weight(year_fr)
-    !
-    ! initialize variables, including output
-    !
-    DO k=1,nlevels
-      DO icol=1,ncol
-        aod_prof(icol,k) = 0.0
-        ssa_prof(icol,k) = 0.0
-        asy_prof(icol,k) = 0.0
-        z_beta(icol,k)   = MERGE(1.0, 0.0, z(icol,k) >= oro(icol))
-        eta(icol,k)      = MAX(0.0,MIN(1.0,z(icol,k)/15000.))
-      ENDDO
-    ENDDO
-    DO icol=1,ncol
-      dNovrN(icol)   = 1.0
-      caod_sp(icol)  = 0.0
-      caod_bg(icol)  = 0.02
-    ENDDO
-    !
-    ! sum contribution from plumes to construct composite profiles of aerosol optical properties
-    !
-    DO iplume=1,nplumes
-      !
-      ! calculate vertical distribution function from parameters of beta distribution
-      !
-      DO icol=1,ncol
-        beta_sum(icol) = 0.
-      ENDDO
-      DO k=1,nlevels
-        DO icol=1,ncol
-          prof(icol,k)   = (eta(icol,k)**(beta_a(iplume)-1.) * (1.-eta(icol,k))**(beta_b(iplume)-1.)) * dz(icol,k)
-          beta_sum(icol) = beta_sum(icol) + prof(icol,k)
-        ENDDO
-      ENDDO
-      DO k=1,nlevels
-        DO icol=1,ncol
-          prof(icol,k)   = ( prof(icol,k) / beta_sum(icol) ) * z_beta(icol,k)
-        ENDDO
-      ENDDO
-      !
-      ! calculate plume weights
-      !
-      DO icol=1,ncol
-        !
-        ! get plume-center relative spatial parameters for specifying amplitude of plume at given lat and lon
-        !
-        delta_lat   = lat(icol) - plume_lat(iplume)
-        delta_lon   = lon(icol) - plume_lon(iplume)
-        delta_lon_t = MERGE (260., 180., iplume == 1)
-        delta_lon   = MERGE ( delta_lon-SIGN(360.,delta_lon) , delta_lon , ABS(delta_lon) > delta_lon_t)
-
-        a_plume1  = 0.5 / (MERGE(sig_lon_E(1,iplume), sig_lon_W(1,iplume), delta_lon > 0)**2)
-        b_plume1  = 0.5 / (MERGE(sig_lat_E(1,iplume), sig_lat_W(1,iplume), delta_lon > 0)**2)
-        a_plume2  = 0.5 / (MERGE(sig_lon_E(2,iplume), sig_lon_W(2,iplume), delta_lon > 0)**2)
-        b_plume2  = 0.5 / (MERGE(sig_lat_E(2,iplume), sig_lat_W(2,iplume), delta_lon > 0)**2)
-        !
-        ! adjust for a plume specific rotation which helps match plume state to climatology.
-        !
-        lon1 =   COS(theta(1,iplume))*(delta_lon) + SIN(theta(1,iplume))*(delta_lat)
-        lat1 = - SIN(theta(1,iplume))*(delta_lon) + COS(theta(1,iplume))*(delta_lat)
-        lon2 =   COS(theta(2,iplume))*(delta_lon) + SIN(theta(2,iplume))*(delta_lat)
-        lat2 = - SIN(theta(2,iplume))*(delta_lon) + COS(theta(2,iplume))*(delta_lat)
-        !
-        ! calculate contribution to plume from its different features, to get a column weight for the anthropogenic
-        ! (cw_an) and the fine-mode natural background aerosol (cw_bg)
-        !
-        f1 = time_weight(1,iplume) * ftr_weight(1,iplume) * EXP(-1.* (a_plume1 * ((lon1)**2) + (b_plume1 * ((lat1)**2)))) 
-        f2 = time_weight(2,iplume) * ftr_weight(2,iplume) * EXP(-1.* (a_plume2 * ((lon2)**2) + (b_plume2 * ((lat2)**2)))) 
-        f3 = time_weight_bg(1,iplume) * ftr_weight(1,iplume) * EXP(-1.* (a_plume1 * ((lon1)**2) + (b_plume1 * ((lat1)**2)))) 
-        f4 = time_weight_bg(2,iplume) * ftr_weight(2,iplume) * EXP(-1.* (a_plume2 * ((lon2)**2) + (b_plume2 * ((lat2)**2))))
-
-        cw_an(icol) = f1 * aod_spmx(iplume) + f2 * aod_spmx(iplume)  
-        cw_bg(icol) = f3 * aod_fmbg(iplume) + f4 * aod_fmbg(iplume) 
-        !
-        ! calculate wavelength-dependent scattering properties
-        !
-        lfactor   = MIN(1.0,700.0/lambda)
-        ssa(icol) = (ssa550(iplume) * lfactor**4) / ((ssa550(iplume) * lfactor**4) + ((1-ssa550(iplume)) * lfactor))
-        asy(icol) =  asy550(iplume) * SQRT(lfactor)
-      ENDDO
-      !
-      ! distribute plume optical properties across its vertical profile weighting by optical depth and scaling for
-      ! wavelength using the angstrom parameter. 
-      !      
-      lfactor = EXP(-angstrom(iplume) * LOG(lambda/550.0))
-      DO k=1,nlevels
-        DO icol = 1,ncol
-          aod_550          = prof(icol,k)     * cw_an(icol)
-          aod_lmd          = aod_550          * lfactor
-          caod_sp(icol)    = caod_sp(icol)    + aod_550
-          caod_bg(icol)    = caod_bg(icol)    + prof(icol,k) * cw_bg(icol)
-          asy_prof(icol,k) = asy_prof(icol,k) + aod_lmd * ssa(icol) * asy(icol)
-          ssa_prof(icol,k) = ssa_prof(icol,k) + aod_lmd * ssa(icol)
-          aod_prof(icol,k) = aod_prof(icol,k) + aod_lmd
-        ENDDO
-      ENDDO
-    ENDDO
-    !
-    ! complete optical depth weighting
-    !
-    DO k=1,nlevels
-      DO icol = 1,ncol
-        asy_prof(icol,k) = MERGE(asy_prof(icol,k)/ssa_prof(icol,k), 0.0, ssa_prof(icol,k) > TINY(1.))
-        ssa_prof(icol,k) = MERGE(ssa_prof(icol,k)/aod_prof(icol,k), 1.0, aod_prof(icol,k) > TINY(1.))
-      ENDDO
-    ENDDO
-    !
-    ! calculate effective radius normalization (divisor) factor
-    !
-    DO icol=1,ncol
-      dNovrN(icol) = LOG((1000.0 * (caod_sp(icol) + caod_bg(icol))) + 1.0)/LOG((1000.0 * caod_bg(icol)) + 1.0)
-    ENDDO
-
-    RETURN
-  END SUBROUTINE sp_aop_profile
-  
-END MODULE MO_SIMPLE_PLUMES
Index: /LMDZ6/trunk/libf/phylmd/mo_simple_plumes.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/mo_simple_plumes.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/mo_simple_plumes.f90	(revision 5268)
@@ -0,0 +1,498 @@
+!>
+!!
+!! @brief Module MO_SIMPLE_PLUMES: provides anthropogenic aerosol optical properties as a function of lat, lon
+!!   height, time, and wavelength
+!!
+!! @remarks
+!!
+!! @author Bjorn Stevens, Stephanie Fiedler and Karsten Peters MPI-Met, Hamburg (v1 release 2016-11-10)
+!!
+!! @change-log:
+!!          - 2016-12-05: beta release (BS, SF and KP, MPI-Met)
+!!          - 2016-09-28: revised representation of Twomey effect (SF, MPI-Met)
+!!          - 2015-09-28: bug fixes  (SF, MPI-Met)
+!!          - 2016-10-12: revised maximum longitudinal extent of European plume (KP, SF, MPI-Met)
+!! $ID: n/a$
+!!
+!! @par Origin
+!!   Based on code originally developed at the MPI-Met by Karsten Peters, Bjorn Stevens, Stephanie Fiedler
+!!   and Stefan Kinne with input from Thorsten Mauritsen and Robert Pincus
+!!
+!! @par Copyright
+!! 
+!
+MODULE MO_SIMPLE_PLUMES
+
+  USE netcdf
+
+  IMPLICIT NONE
+
+  INTEGER, PARAMETER ::                        &
+       nplumes   = 9                          ,& !< Number of plumes
+       nfeatures = 2                          ,& !< Number of features per plume
+       ntimes    = 52                         ,& !< Number of times resolved per year (52 => weekly resolution)
+       nyears    = 251                           !< Number of years of available forcing
+
+  LOGICAL, SAVE ::                             &
+       sp_initialized = .FALSE.                  !< parameter determining whether input needs to be read
+!$OMP THREADPRIVATE(sp_initialized)
+
+  REAL, SAVE ::                                &
+       plume_lat      (nplumes)               ,& !< latitude of plume center (AOD maximum)
+       plume_lon      (nplumes)               ,& !< longitude of plume center (AOD maximum)
+       beta_a         (nplumes)               ,& !< parameter a for beta function vertical profile
+       beta_b         (nplumes)               ,& !< parameter b for beta function vertical profile
+       aod_spmx       (nplumes)               ,& !< anthropogenic AOD maximum at 550 for plumes 
+       aod_fmbg       (nplumes)               ,& !< anthropogenic AOD at 550 for fine-mode natural background (idealized to mimic Twomey effect)
+       asy550         (nplumes)               ,& !< asymmetry parameter at 550nm for plume
+       ssa550         (nplumes)               ,& !< single scattering albedo at 550nm for plume
+       angstrom       (nplumes)               ,& !< Angstrom parameter for plume 
+       sig_lon_E      (nfeatures,nplumes)     ,& !< Eastward extent of plume feature
+       sig_lon_W      (nfeatures,nplumes)     ,& !< Westward extent of plume feature
+       sig_lat_E      (nfeatures,nplumes)     ,& !< Southward extent of plume feature
+       sig_lat_W      (nfeatures,nplumes)     ,& !< Northward extent of plume feature
+       theta          (nfeatures,nplumes)     ,& !< Rotation angle of plume feature
+       ftr_weight     (nfeatures,nplumes)     ,& !< Feature weights 
+       year_weight    (nyears,nplumes)        ,& !< Yearly weight for plume
+       ann_cycle      (nfeatures,ntimes,nplumes) !< annual cycle for plume feature
+!$OMP THREADPRIVATE(plume_lat,plume_lon,beta_a,beta_b,aod_spmx,aod_fmbg,asy550,ssa550,angstrom)
+!$OMP THREADPRIVATE(sig_lon_E,sig_lon_W,sig_lat_E,sig_lat_W,theta,ftr_weight,year_weight,ann_cycle)
+
+  REAL ::                                      &
+       time_weight    (nfeatures,nplumes)     ,& !< Time weights 
+       time_weight_bg (nfeatures,nplumes)        !< as time_weight but for natural background in Twomey effect 
+
+  PUBLIC sp_aop_profile
+
+CONTAINS
+  !
+  ! ------------------------------------------------------------------------------------------------------------------------
+  ! SP_SETUP:  This subroutine should be called at initialization to read the netcdf data that describes the simple plume
+  ! climatology.  The information needs to be either read by each processor or distributed to processors.
+  !
+  SUBROUTINE sp_setup
+    !
+    USE mod_phys_lmdz_mpi_data, ONLY: is_mpi_root
+    USE mod_phys_lmdz_omp_data, ONLY: is_omp_root
+    USE mod_phys_lmdz_transfert_para, ONLY: bcast
+    !
+    ! ---------- 
+    !
+    INTEGER :: iret, ncid, DimID, VarID, xdmy
+    CHARACTER (len = 50)     :: modname = 'mo_simple_plumes.sp_setup'
+    CHARACTER (len = 80)     :: abort_message
+    !
+    ! ---------- 
+    !--only one processor reads the input data
+    IF (is_mpi_root.AND.is_omp_root) THEN
+       !    
+       iret = nf90_open("MACv2.0-SP_v1.nc", NF90_NOWRITE, ncid)
+       IF (iret /= NF90_NOERR) THEN
+          abort_message='NetCDF File not opened'
+          CALL abort_physic(modname,abort_message,1)
+       ENDIF
+       !
+       ! read dimensions and make sure file conforms to expected size
+       !
+       iret = nf90_inq_dimid(ncid, "plume_number"  , DimId)
+       iret = nf90_inquire_dimension(ncid, DimId, len = xdmy)
+       IF (xdmy /= nplumes) THEN
+          abort_message='NetCDF improperly dimensioned -- plume_number'
+          CALL abort_physic(modname,abort_message,1)
+       ENDIF
+       !
+       iret = nf90_inq_dimid(ncid, "plume_feature", DimId)
+       iret = nf90_inquire_dimension(ncid, DimId, len = xdmy)
+       IF (xdmy /= nfeatures) THEN
+          abort_message='NetCDF improperly dimensioned -- plume_feature'
+          CALL abort_physic(modname,abort_message,1)
+       ENDIF
+       !
+       iret = nf90_inq_dimid(ncid, "year_fr"   , DimId)
+       iret = nf90_inquire_dimension(ncid, DimID, len = xdmy)
+       IF (xdmy /= ntimes) THEN
+          abort_message='NetCDF improperly dimensioned -- year_fr'
+          CALL abort_physic(modname,abort_message,1)
+       ENDIF
+       !
+       iret = nf90_inq_dimid(ncid, "years"   , DimId)
+       iret = nf90_inquire_dimension(ncid, DimID, len = xdmy)
+       IF (xdmy /= nyears) THEN
+          abort_message='NetCDF improperly dimensioned -- years'
+          CALL abort_physic(modname,abort_message,1)
+       ENDIF
+       !
+       ! read variables that define the simple plume climatology
+       !
+       iret = nf90_inq_varid(ncid, "plume_lat", VarId)
+       iret = nf90_get_var(ncid, VarID, plume_lat(:), start=(/1/),count=(/nplumes/))
+       IF (iret /= NF90_NOERR) THEN
+          abort_message='NetCDF Error reading plume_lat'
+          CALL abort_physic(modname,abort_message,1)
+       ENDIF
+       !
+       iret = nf90_inq_varid(ncid, "plume_lon", VarId)
+       iret = nf90_get_var(ncid, VarID, plume_lon(:), start=(/1/),count=(/nplumes/))
+       IF (iret /= NF90_NOERR) THEN
+          abort_message='NetCDF Error reading plume_lon'
+          CALL abort_physic(modname,abort_message,1)
+       ENDIF
+       !
+       iret = nf90_inq_varid(ncid, "beta_a"   , VarId)
+       iret = nf90_get_var(ncid, VarID, beta_a(:)   , start=(/1/),count=(/nplumes/))
+       IF (iret /= NF90_NOERR) THEN
+          abort_message='NetCDF Error reading beta_a'
+          CALL abort_physic(modname,abort_message,1)
+       ENDIF
+       !
+       iret = nf90_inq_varid(ncid, "beta_b"   , VarId)
+       iret = nf90_get_var(ncid, VarID, beta_b(:)   , start=(/1/),count=(/nplumes/))
+       IF (iret /= NF90_NOERR) THEN
+          abort_message='NetCDF Error reading beta_b'
+          CALL abort_physic(modname,abort_message,1)
+       ENDIF
+       !
+       iret = nf90_inq_varid(ncid, "aod_spmx" , VarId)
+       iret = nf90_get_var(ncid, VarID, aod_spmx(:)  , start=(/1/),count=(/nplumes/))
+       IF (iret /= NF90_NOERR) THEN
+          abort_message='NetCDF Error reading aod_spmx'
+          CALL abort_physic(modname,abort_message,1)
+       ENDIF
+       !
+       iret = nf90_inq_varid(ncid, "aod_fmbg" , VarId)
+       iret = nf90_get_var(ncid, VarID, aod_fmbg(:)  , start=(/1/),count=(/nplumes/))
+       IF (iret /= NF90_NOERR) THEN
+          abort_message='NetCDF Error reading aod_fmbg'
+          CALL abort_physic(modname,abort_message,1)
+       ENDIF
+       !
+       iret = nf90_inq_varid(ncid, "ssa550"   , VarId)
+       iret = nf90_get_var(ncid, VarID, ssa550(:)  , start=(/1/),count=(/nplumes/))
+       IF (iret /= NF90_NOERR) THEN
+          abort_message='NetCDF Error reading ssa550'
+          CALL abort_physic(modname,abort_message,1)
+       ENDIF
+       !
+       iret = nf90_inq_varid(ncid, "asy550"   , VarId)
+       iret = nf90_get_var(ncid, VarID, asy550(:)  , start=(/1/),count=(/nplumes/))
+       IF (iret /= NF90_NOERR) THEN
+          abort_message='NetCDF Error reading asy550'
+          CALL abort_physic(modname,abort_message,1)
+       ENDIF
+       !
+       iret = nf90_inq_varid(ncid, "angstrom" , VarId)
+       iret = nf90_get_var(ncid, VarID, angstrom(:), start=(/1/),count=(/nplumes/))
+       IF (iret /= NF90_NOERR) THEN
+          abort_message='NetCDF Error reading angstrom'
+          CALL abort_physic(modname,abort_message,1)
+       ENDIF
+       !
+       iret = nf90_inq_varid(ncid, "sig_lat_W"     , VarId)
+       iret = nf90_get_var(ncid, VarID, sig_lat_W(:,:)    , start=(/1,1/),count=(/nfeatures,nplumes/))
+       IF (iret /= NF90_NOERR) THEN
+          abort_message='NetCDF Error reading sig_lat_W'
+          CALL abort_physic(modname,abort_message,1)
+       ENDIF
+       !
+       iret = nf90_inq_varid(ncid, "sig_lat_E"     , VarId)
+       iret = nf90_get_var(ncid, VarID, sig_lat_E(:,:)    , start=(/1,1/),count=(/nfeatures,nplumes/))
+       IF (iret /= NF90_NOERR) THEN
+          abort_message='NetCDF Error reading sig_lat_E'
+          CALL abort_physic(modname,abort_message,1)
+       ENDIF
+       !
+       iret = nf90_inq_varid(ncid, "sig_lon_E"     , VarId)
+       iret = nf90_get_var(ncid, VarID, sig_lon_E(:,:)    , start=(/1,1/),count=(/nfeatures,nplumes/))
+       IF (iret /= NF90_NOERR) THEN
+          abort_message='NetCDF Error reading sig_lon_E'
+          CALL abort_physic(modname,abort_message,1)
+       ENDIF
+       !
+       iret = nf90_inq_varid(ncid, "sig_lon_W"     , VarId)
+       iret = nf90_get_var(ncid, VarID, sig_lon_W(:,:)    , start=(/1,1/),count=(/nfeatures,nplumes/))
+       IF (iret /= NF90_NOERR) THEN
+          abort_message='NetCDF Error reading sig_lon_W'
+          CALL abort_physic(modname,abort_message,1)
+       ENDIF
+       !
+       iret = nf90_inq_varid(ncid, "theta"         , VarId)
+       iret = nf90_get_var(ncid, VarID, theta(:,:)        , start=(/1,1/),count=(/nfeatures,nplumes/))
+       IF (iret /= NF90_NOERR) THEN
+          abort_message='NetCDF Error reading theta'
+          CALL abort_physic(modname,abort_message,1)
+       ENDIF
+       !
+       iret = nf90_inq_varid(ncid, "ftr_weight"    , VarId)
+       iret = nf90_get_var(ncid, VarID, ftr_weight(:,:)   , start=(/1,1/),count=(/nfeatures,nplumes/))
+       IF (iret /= NF90_NOERR) THEN
+          abort_message='NetCDF Error reading plume_lat'
+          CALL abort_physic(modname,abort_message,1)
+       ENDIF
+       !
+       iret = nf90_inq_varid(ncid, "year_weight"   , VarId)
+       iret = nf90_get_var(ncid, VarID, year_weight(:,:)  , start=(/1,1/),count=(/nyears,nplumes   /))
+       IF (iret /= NF90_NOERR) THEN
+          abort_message='NetCDF Error reading year_weight'
+          CALL abort_physic(modname,abort_message,1)
+       ENDIF
+       !
+       iret = nf90_inq_varid(ncid, "ann_cycle"     , VarId)
+       iret = nf90_get_var(ncid, VarID, ann_cycle(:,:,:)  , start=(/1,1,1/),count=(/nfeatures,ntimes,nplumes/))
+       IF (iret /= NF90_NOERR) THEN
+          abort_message='NetCDF Error reading ann_cycle'
+          CALL abort_physic(modname,abort_message,1)
+       ENDIF
+       !
+       iret = nf90_close(ncid)
+       !
+    ENDIF !--root processor
+    !
+    CALL bcast(plume_lat)
+    CALL bcast(plume_lon)
+    CALL bcast(beta_a)
+    CALL bcast(beta_b)
+    CALL bcast(aod_spmx)
+    CALL bcast(aod_fmbg)
+    CALL bcast(asy550)
+    CALL bcast(ssa550)
+    CALL bcast(angstrom)
+    CALL bcast(sig_lon_E)
+    CALL bcast(sig_lon_W)
+    CALL bcast(sig_lat_E)
+    CALL bcast(sig_lat_W)
+    CALL bcast(theta)
+    CALL bcast(ftr_weight)
+    CALL bcast(year_weight)
+    CALL bcast(ann_cycle)
+    !
+    sp_initialized = .TRUE.
+    !
+    RETURN
+    !
+  END SUBROUTINE sp_setup
+  !
+  ! ------------------------------------------------------------------------------------------------------------------------
+  ! SET_TIME_WEIGHT:  The simple plume model assumes that meteorology constrains plume shape and that only source strength
+  ! influences the amplitude of a plume associated with a given source region.   This routine retrieves the temporal weights
+  ! for the plumes.  Each plume feature has its own temporal weights which varies yearly.  The annual cycle is indexed by
+  ! week in the year and superimposed on the yearly mean value of the weight. 
+  !
+  SUBROUTINE set_time_weight(year_fr)
+    !
+    ! ---------- 
+    !
+    REAL, INTENT(IN) ::  &
+         year_fr           !< Fractional Year (1850.0 - 2100.99)
+
+    INTEGER          ::  &
+         iyear          ,& !< Integer year values between 1 and 156 (1850-2100) 
+         iweek          ,& !< Integer index (between 1 and ntimes); for ntimes=52 this corresponds to weeks (roughly)
+         iplume            ! plume number
+    !
+    ! ---------- 
+    !
+    iyear = FLOOR(year_fr) - 1849
+    iweek = FLOOR((year_fr - FLOOR(year_fr)) * ntimes) + 1
+
+    IF ((iweek > ntimes) .OR. (iweek < 1) .OR. (iyear > nyears) .OR. (iyear < 1)) THEN 
+      CALL abort_physic('set_time_weight','Time out of bounds',1)
+    ENDIF
+
+    DO iplume=1,nplumes
+      time_weight(1,iplume) = year_weight(iyear,iplume) * ann_cycle(1,iweek,iplume)
+      time_weight(2,iplume) = year_weight(iyear,iplume) * ann_cycle(2,iweek,iplume)
+      time_weight_bg(1,iplume) = ann_cycle(1,iweek,iplume)
+      time_weight_bg(2,iplume) = ann_cycle(2,iweek,iplume) 
+    ENDDO
+    
+    RETURN
+  END SUBROUTINE set_time_weight
+  !
+  ! ------------------------------------------------------------------------------------------------------------------------
+  ! SP_AOP_PROFILE:  This subroutine calculates the simple plume aerosol and cloud active optical properties based on the
+  ! the simple plume fit to the MPI Aerosol Climatology (Version 2).  It sums over nplumes to provide a profile of aerosol
+  ! optical properties on a host models vertical grid. 
+  !
+  SUBROUTINE sp_aop_profile                                                                           ( &
+       nlevels        ,ncol           ,lambda         ,oro            ,lon            ,lat            , &
+       year_fr        ,z              ,dz             ,dNovrN         ,aod_prof       ,ssa_prof       , &
+       asy_prof       )
+    !
+    ! ---------- 
+    !
+    INTEGER, INTENT(IN)        :: &
+         nlevels,                 & !< number of levels
+         ncol                       !< number of columns
+
+    REAL, INTENT(IN)           :: &
+         lambda,                  & !< wavelength
+         year_fr,                 & !< Fractional Year (1903.0 is the 0Z on the first of January 1903, Gregorian)
+         oro(ncol),               & !< orographic height (m)
+         lon(ncol),               & !< longitude 
+         lat(ncol),               & !< latitude
+         z (ncol,nlevels),        & !< height above sea-level (m)
+         dz(ncol,nlevels)           !< level thickness (difference between half levels) (m)
+
+    REAL, INTENT(OUT)          :: &
+         dNovrN(ncol)           , & !< anthropogenic increase in cloud drop number concentration (factor)
+         aod_prof(ncol,nlevels) , & !< profile of aerosol optical depth
+         ssa_prof(ncol,nlevels) , & !< profile of single scattering albedo
+         asy_prof(ncol,nlevels)     !< profile of asymmetry parameter
+
+    INTEGER                    :: iplume, icol, k
+
+    REAL                       ::  &
+         eta(ncol,nlevels),        & !< normalized height (by 15 km)
+         z_beta(ncol,nlevels),     & !< profile for scaling column optical depth
+         prof(ncol,nlevels),       & !< scaled profile (by beta function)
+         beta_sum(ncol),           & !< vertical sum of beta function
+         ssa(ncol),                & !< single scattering albedo 
+         asy(ncol),                & !< asymmetry parameter
+         cw_an(ncol),              & !< column weight for simple plume (anthropogenic) AOD at 550 nm
+         cw_bg(ncol),              & !< column weight for fine-mode natural background AOD at 550 nm
+         caod_sp(ncol),            & !< column simple plume anthropogenic AOD at 550 nm
+         caod_bg(ncol),            & !< column fine-mode natural background AOD at 550 nm
+         a_plume1,                 & !< gaussian longitude factor for feature 1
+         a_plume2,                 & !< gaussian longitude factor for feature 2
+         b_plume1,                 & !< gaussian latitude factor for feature 1
+         b_plume2,                 & !< gaussian latitude factor for feature 2
+         delta_lat,                & !< latitude offset
+         delta_lon,                & !< longitude offset
+         delta_lon_t,              & !< threshold for maximum longitudinal plume extent used in transition from 360 to 0 degrees
+         lon1,                     & !< rotated longitude for feature 1
+         lat1,                     & !< rotated latitude for feature 2
+         lon2,                     & !< rotated longitude for feature 1
+         lat2,                     & !< rotated latitude for feature 2
+         f1,                       & !< contribution from feature 1
+         f2,                       & !< contribution from feature 2
+         f3,                       & !< contribution from feature 1 in natural background of Twomey effect
+         f4,                       & !< contribution from feature 2 in natural background of Twomey effect
+         aod_550,                  & !< aerosol optical depth at 550nm
+         aod_lmd,                  & !< aerosol optical depth at input wavelength
+         lfactor                     !< factor to compute wavelength dependence of optical properties
+    !
+    ! ---------- 
+    !
+    ! initialize input data (by calling setup at first instance) 
+    !
+    IF (.NOT.sp_initialized) CALL sp_setup
+    !
+    ! get time weights
+    !
+    CALL set_time_weight(year_fr)
+    !
+    ! initialize variables, including output
+    !
+    DO k=1,nlevels
+      DO icol=1,ncol
+        aod_prof(icol,k) = 0.0
+        ssa_prof(icol,k) = 0.0
+        asy_prof(icol,k) = 0.0
+        z_beta(icol,k)   = MERGE(1.0, 0.0, z(icol,k) >= oro(icol))
+        eta(icol,k)      = MAX(0.0,MIN(1.0,z(icol,k)/15000.))
+      ENDDO
+    ENDDO
+    DO icol=1,ncol
+      dNovrN(icol)   = 1.0
+      caod_sp(icol)  = 0.0
+      caod_bg(icol)  = 0.02
+    ENDDO
+    !
+    ! sum contribution from plumes to construct composite profiles of aerosol optical properties
+    !
+    DO iplume=1,nplumes
+      !
+      ! calculate vertical distribution function from parameters of beta distribution
+      !
+      DO icol=1,ncol
+        beta_sum(icol) = 0.
+      ENDDO
+      DO k=1,nlevels
+        DO icol=1,ncol
+          prof(icol,k)   = (eta(icol,k)**(beta_a(iplume)-1.) * (1.-eta(icol,k))**(beta_b(iplume)-1.)) * dz(icol,k)
+          beta_sum(icol) = beta_sum(icol) + prof(icol,k)
+        ENDDO
+      ENDDO
+      DO k=1,nlevels
+        DO icol=1,ncol
+          prof(icol,k)   = ( prof(icol,k) / beta_sum(icol) ) * z_beta(icol,k)
+        ENDDO
+      ENDDO
+      !
+      ! calculate plume weights
+      !
+      DO icol=1,ncol
+        !
+        ! get plume-center relative spatial parameters for specifying amplitude of plume at given lat and lon
+        !
+        delta_lat   = lat(icol) - plume_lat(iplume)
+        delta_lon   = lon(icol) - plume_lon(iplume)
+        delta_lon_t = MERGE (260., 180., iplume == 1)
+        delta_lon   = MERGE ( delta_lon-SIGN(360.,delta_lon) , delta_lon , ABS(delta_lon) > delta_lon_t)
+
+        a_plume1  = 0.5 / (MERGE(sig_lon_E(1,iplume), sig_lon_W(1,iplume), delta_lon > 0)**2)
+        b_plume1  = 0.5 / (MERGE(sig_lat_E(1,iplume), sig_lat_W(1,iplume), delta_lon > 0)**2)
+        a_plume2  = 0.5 / (MERGE(sig_lon_E(2,iplume), sig_lon_W(2,iplume), delta_lon > 0)**2)
+        b_plume2  = 0.5 / (MERGE(sig_lat_E(2,iplume), sig_lat_W(2,iplume), delta_lon > 0)**2)
+        !
+        ! adjust for a plume specific rotation which helps match plume state to climatology.
+        !
+        lon1 =   COS(theta(1,iplume))*(delta_lon) + SIN(theta(1,iplume))*(delta_lat)
+        lat1 = - SIN(theta(1,iplume))*(delta_lon) + COS(theta(1,iplume))*(delta_lat)
+        lon2 =   COS(theta(2,iplume))*(delta_lon) + SIN(theta(2,iplume))*(delta_lat)
+        lat2 = - SIN(theta(2,iplume))*(delta_lon) + COS(theta(2,iplume))*(delta_lat)
+        !
+        ! calculate contribution to plume from its different features, to get a column weight for the anthropogenic
+        ! (cw_an) and the fine-mode natural background aerosol (cw_bg)
+        !
+        f1 = time_weight(1,iplume) * ftr_weight(1,iplume) * EXP(-1.* (a_plume1 * ((lon1)**2) + (b_plume1 * ((lat1)**2)))) 
+        f2 = time_weight(2,iplume) * ftr_weight(2,iplume) * EXP(-1.* (a_plume2 * ((lon2)**2) + (b_plume2 * ((lat2)**2)))) 
+        f3 = time_weight_bg(1,iplume) * ftr_weight(1,iplume) * EXP(-1.* (a_plume1 * ((lon1)**2) + (b_plume1 * ((lat1)**2)))) 
+        f4 = time_weight_bg(2,iplume) * ftr_weight(2,iplume) * EXP(-1.* (a_plume2 * ((lon2)**2) + (b_plume2 * ((lat2)**2))))
+
+        cw_an(icol) = f1 * aod_spmx(iplume) + f2 * aod_spmx(iplume)  
+        cw_bg(icol) = f3 * aod_fmbg(iplume) + f4 * aod_fmbg(iplume) 
+        !
+        ! calculate wavelength-dependent scattering properties
+        !
+        lfactor   = MIN(1.0,700.0/lambda)
+        ssa(icol) = (ssa550(iplume) * lfactor**4) / ((ssa550(iplume) * lfactor**4) + ((1-ssa550(iplume)) * lfactor))
+        asy(icol) =  asy550(iplume) * SQRT(lfactor)
+      ENDDO
+      !
+      ! distribute plume optical properties across its vertical profile weighting by optical depth and scaling for
+      ! wavelength using the angstrom parameter. 
+      !      
+      lfactor = EXP(-angstrom(iplume) * LOG(lambda/550.0))
+      DO k=1,nlevels
+        DO icol = 1,ncol
+          aod_550          = prof(icol,k)     * cw_an(icol)
+          aod_lmd          = aod_550          * lfactor
+          caod_sp(icol)    = caod_sp(icol)    + aod_550
+          caod_bg(icol)    = caod_bg(icol)    + prof(icol,k) * cw_bg(icol)
+          asy_prof(icol,k) = asy_prof(icol,k) + aod_lmd * ssa(icol) * asy(icol)
+          ssa_prof(icol,k) = ssa_prof(icol,k) + aod_lmd * ssa(icol)
+          aod_prof(icol,k) = aod_prof(icol,k) + aod_lmd
+        ENDDO
+      ENDDO
+    ENDDO
+    !
+    ! complete optical depth weighting
+    !
+    DO k=1,nlevels
+      DO icol = 1,ncol
+        asy_prof(icol,k) = MERGE(asy_prof(icol,k)/ssa_prof(icol,k), 0.0, ssa_prof(icol,k) > TINY(1.))
+        ssa_prof(icol,k) = MERGE(ssa_prof(icol,k)/aod_prof(icol,k), 1.0, aod_prof(icol,k) > TINY(1.))
+      ENDDO
+    ENDDO
+    !
+    ! calculate effective radius normalization (divisor) factor
+    !
+    DO icol=1,ncol
+      dNovrN(icol) = LOG((1000.0 * (caod_sp(icol) + caod_bg(icol))) + 1.0)/LOG((1000.0 * caod_bg(icol)) + 1.0)
+    ENDDO
+
+    RETURN
+  END SUBROUTINE sp_aop_profile
+  
+END MODULE MO_SIMPLE_PLUMES
Index: DZ6/trunk/libf/phylmd/mod_surf_para.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/mod_surf_para.F90	(revision 5267)
+++ 	(revision )
@@ -1,336 +1,0 @@
-MODULE mod_surf_para
-  IMPLICIT NONE
-  
-  INTERFACE gather_surf
-    MODULE PROCEDURE gather_surf_i,gather_surf_r
-  END INTERFACE gather_surf
-  
-  INTERFACE gather_surf_omp
-    MODULE PROCEDURE gather_surf_omp_i,gather_surf_omp_r
-  END INTERFACE gather_surf_omp
-
-  INTERFACE gather_surf_mpi
-    MODULE PROCEDURE gather_surf_mpi_i,gather_surf_mpi_r
-  END INTERFACE gather_surf_mpi
-
-  INTERFACE scatter_surf
-    MODULE PROCEDURE scatter_surf_i,scatter_surf_r
-  END INTERFACE scatter_surf
-  
-  INTERFACE scatter_surf_omp
-    MODULE PROCEDURE scatter_surf_omp_i,scatter_surf_omp_r
-  END INTERFACE scatter_surf_omp
-
-  INTERFACE scatter_surf_mpi
-    MODULE PROCEDURE scatter_surf_mpi_i,scatter_surf_mpi_r
-  END INTERFACE scatter_surf_mpi
-  
-  
-  INTEGER,SAVE             :: knon_omp
-  INTEGER,SAVE             :: knon_omp_begin
-  INTEGER,SAVE             :: knon_omp_end
-!$OMP THREADPRIVATE(knon_omp,knon_omp_begin,knon_omp_end)
-  INTEGER,ALLOCATABLE,SAVE :: knon_omp_para(:)
-  INTEGER,ALLOCATABLE,SAVE :: knon_omp_begin_para(:)
-  INTEGER,ALLOCATABLE,SAVE :: knon_omp_end_para(:)
-  
-  INTEGER,SAVE             :: knon_mpi
-  INTEGER,ALLOCATABLE,SAVE :: knon_mpi_para(:)
-  INTEGER,ALLOCATABLE,SAVE :: knon_mpi_begin_para(:)
-  INTEGER,ALLOCATABLE,SAVE :: knon_mpi_end_para(:)
-  
-  INTEGER,SAVE             :: knon_glo
-  INTEGER,SAVE,ALLOCATABLE :: knon_glo_para(:)  
-  INTEGER,ALLOCATABLE,SAVE :: knon_glo_begin_para(:)
-  INTEGER,ALLOCATABLE,SAVE :: knon_glo_end_para(:)
-  
-  
-CONTAINS
-
-  SUBROUTINE Init_surf_para(knon)
-  USE mod_phys_lmdz_para
-  USE lmdz_mpi
-
-    INTEGER :: knon
-    INTEGER :: i,ierr
-    
-    knon_omp=knon
-    IF (is_omp_root) THEN
-      ALLOCATE(knon_omp_para(0:omp_size-1))
-      ALLOCATE(knon_omp_begin_para(0:omp_size-1))
-      ALLOCATE(knon_omp_end_para(0:omp_size-1))
-    ENDIF
-!$OMP BARRIER
-    knon_omp_para(omp_rank)=knon
-!$OMP BARRIER
-    IF (is_omp_root) THEN 
-      knon_omp_begin_para(0)=1
-      knon_omp_end_para(0)=knon_omp_para(0)
-      DO i=1,omp_size-1
-        knon_omp_begin_para(i)=knon_omp_end_para(i-1)+1
-        knon_omp_end_para(i)=knon_omp_begin_para(i)+knon_omp_para(i)-1
-      ENDDO
-    ENDIF 
-!$OMP BARRIER
-    knon_omp_begin=knon_omp_begin_para(omp_rank)
-    knon_omp_end=knon_omp_end_para(omp_rank)
-!$OMP BARRIER    
-    IF (is_omp_root) THEN
-      knon_mpi=sum(knon_omp_para)
-      ALLOCATE(knon_mpi_para(0:mpi_size-1))
-      ALLOCATE(knon_mpi_begin_para(0:mpi_size-1))
-      ALLOCATE(knon_mpi_end_para(0:mpi_size-1))
-      
-      ALLOCATE(knon_glo_para(0:mpi_size*omp_size-1))
-      ALLOCATE(knon_glo_begin_para(0:mpi_size*omp_size-1))
-      ALLOCATE(knon_glo_end_para(0:mpi_size*omp_size-1))
-      
-      IF (is_using_mpi) THEN
-        CALL MPI_ALLGather(knon_mpi,1,MPI_INTEGER,knon_mpi_para,1,MPI_INTEGER,COMM_LMDZ_PHY,ierr)
-        CALL MPI_ALLGather(knon_omp_para,omp_size,MPI_INTEGER,knon_glo_para,omp_size,MPI_INTEGER,COMM_LMDZ_PHY,ierr)
-      ELSE
-        knon_mpi_para(:)=knon_mpi
-        knon_glo_para(:)=knon_omp_para(:)
-      ENDIF     
-      
-      knon_glo=sum(knon_mpi_para(:))
-      
-      knon_mpi_begin_para(0)=1
-      knon_mpi_end_para(0)=knon_mpi_para(0)
-      DO i=1,mpi_size-1
-        knon_mpi_begin_para(i)=knon_mpi_end_para(i-1)+1
-        knon_mpi_end_para(i)=knon_mpi_begin_para(i)+knon_mpi_para(i)-1
-      ENDDO
-      
-      knon_glo_begin_para(0)=1
-      knon_glo_end_para(0)=knon_glo_para(0)
-      DO i=1,mpi_size*omp_size-1
-        knon_glo_begin_para(i)=knon_glo_end_para(i-1)+1
-        knon_glo_end_para(i)= knon_glo_begin_para(i)+knon_glo_para(i)-1
-      ENDDO
-   ENDIF
-!$OMP BARRIER
-
-  END SUBROUTINE Init_surf_para
-
- 
-  SUBROUTINE Finalize_surf_para
-  USE mod_phys_lmdz_para
-
-!$OMP BARRIER   
-   IF (is_omp_root) THEN
-      DEALLOCATE(knon_omp_para)
-      DEALLOCATE(knon_omp_begin_para)
-      DEALLOCATE(knon_omp_end_para)
-      DEALLOCATE(knon_mpi_para)
-      DEALLOCATE(knon_mpi_begin_para)
-      DEALLOCATE(knon_mpi_end_para)
-      DEALLOCATE(knon_glo_para)  
-      DEALLOCATE(knon_glo_begin_para)
-      DEALLOCATE(knon_glo_end_para)
-    ENDIF
-    
-  END SUBROUTINE Finalize_surf_para
-  
-  
-  SUBROUTINE gather_surf_i(FieldIn, FieldOut)
-  USE mod_phys_lmdz_para
-    INTEGER :: FieldIn(:)
-    INTEGER :: FieldOut(:)
-    INTEGER :: FieldTmp(knon_mpi)
-    
-    CALL gather_surf_omp_i(FieldIn,FieldTmp)
-    IF (is_omp_root) CALL gather_surf_mpi_i(FieldTmp,FieldOut)
-    
-  END SUBROUTINE gather_surf_i
-
-
-  SUBROUTINE gather_surf_omp_i(FieldIn,FieldOut)
-  USE mod_phys_lmdz_para
-    INTEGER :: FieldIn(:)
-    INTEGER :: FieldOut(:)
-  
-    INTEGER,SAVE,ALLOCATABLE :: Field_tmp(:)
-    
-    IF (is_omp_root) ALLOCATE(Field_tmp(knon_mpi))
-!$OMP BARRIER
-    Field_tmp(knon_omp_begin:knon_omp_end)=FieldIn(:)
-!$OMP BARRIER        
-    IF (is_omp_root) FieldOut(:)=Field_tmp(:)
-!$OMP BARRIER
-    IF (is_omp_root) DEALLOCATE(Field_tmp)
-    
-  END SUBROUTINE  gather_surf_omp_i
-  
-     
-  SUBROUTINE gather_surf_mpi_i(FieldIn,FieldOut)
-  USE mod_phys_lmdz_para
-  USE lmdz_mpi
-
-    INTEGER :: FieldIn(:)
-    INTEGER :: FieldOut(:)
-    INTEGER :: ierr
-    
-    IF (is_using_mpi) THEN
-      CALL MPI_Gatherv(FieldIn,knon_mpi,MPI_INTEGER,                                &
-                       FieldOut,knon_mpi_para,knon_mpi_begin_para(:)-1,MPI_INTEGER, &
-                       mpi_master,COMM_LMDZ_PHY,ierr)
-    ELSE
-      FieldOut(:)=FieldIn(:)
-    ENDIF
-  
-  END SUBROUTINE gather_surf_mpi_i
-  
-
-
-
-
-  SUBROUTINE gather_surf_r(FieldIn, FieldOut)
-  USE mod_phys_lmdz_para
-    REAL :: FieldIn(:)
-    REAL :: FieldOut(:)
-    REAL :: FieldTmp(knon_mpi)
-    
-    CALL gather_surf_omp_r(FieldIn,FieldTmp)
-    IF (is_omp_root) CALL gather_surf_mpi_r(FieldTmp,FieldOut)
-    
-  END SUBROUTINE gather_surf_r
-
-
-  SUBROUTINE gather_surf_omp_r(FieldIn,FieldOut)
-  USE mod_phys_lmdz_para
-    REAL :: FieldIn(:)
-    REAL :: FieldOut(:)
-  
-    REAL,SAVE,ALLOCATABLE :: Field_tmp(:)
-    
-    IF (is_omp_root) ALLOCATE(Field_tmp(knon_mpi))
-!$OMP BARRIER
-    Field_tmp(knon_omp_begin:knon_omp_end)=FieldIn(:)
-!$OMP BARRIER        
-    IF (is_omp_root) FieldOut(:)=Field_tmp(:)
-!$OMP BARRIER
-    IF (is_omp_root) DEALLOCATE(Field_tmp)
-    
-  END SUBROUTINE  gather_surf_omp_r
-  
-     
-  SUBROUTINE gather_surf_mpi_r(FieldIn,FieldOut)
-  USE mod_phys_lmdz_para
-  USE lmdz_mpi
-
-    REAL :: FieldIn(:)
-    REAL :: FieldOut(:)
-    REAL :: ierr
-    
-    IF (is_using_mpi) THEN
-      CALL MPI_Gatherv(FieldIn,knon_mpi,MPI_REAL_LMDZ,                                 &
-                       FieldOut,knon_mpi_para,knon_mpi_begin_para(:)-1,MPI_REAL_LMDZ,  &
-                       mpi_master,COMM_LMDZ_PHY,ierr)            
-    ELSE
-      FieldOut(:)=FieldIn(:)
-    ENDIF
-  
-  END SUBROUTINE gather_surf_mpi_r
-
-
-
-
-  SUBROUTINE scatter_surf_i(FieldIn, FieldOut)
-  USE mod_phys_lmdz_para
-    INTEGER :: FieldIn(:)
-    INTEGER :: FieldOut(:)
-    INTEGER :: FieldTmp(knon_mpi)
-    
-    IF (is_omp_root) CALL scatter_surf_mpi_i(FieldIn,FieldTmp)
-    CALL scatter_surf_omp_i(FieldTmp,FieldOut)
-    
-  END SUBROUTINE scatter_surf_i
-
-
-  SUBROUTINE scatter_surf_omp_i(FieldIn,FieldOut)
-  USE mod_phys_lmdz_para
-    INTEGER :: FieldIn(:)
-    INTEGER :: FieldOut(:)
-  
-    INTEGER,SAVE,ALLOCATABLE :: Field_tmp(:)
-    
-    IF (is_omp_root) ALLOCATE(Field_tmp(knon_mpi))
-    IF (is_omp_root) Field_tmp(:)=FieldIn(:)
-!$OMP BARRIER        
-    FieldOut(:)=Field_tmp(knon_omp_begin:knon_omp_end)
-!$OMP BARRIER
-    IF (is_omp_root) DEALLOCATE(Field_tmp)
-    
-  END SUBROUTINE  scatter_surf_omp_i
-  
-     
-  SUBROUTINE scatter_surf_mpi_i(FieldIn,FieldOut)
-  USE mod_phys_lmdz_para
-  USE lmdz_mpi
-
-    INTEGER :: FieldIn(:)
-    INTEGER :: FieldOut(:)
-    INTEGER :: ierr
-    
-    IF (is_using_mpi) THEN
-      CALL MPI_Scatterv(FieldIn,knon_mpi_para,knon_mpi_begin_para(:)-1,MPI_INTEGER,   &
-                        FieldOut,knon_mpi,MPI_INTEGER,                                &
-                        mpi_master,COMM_LMDZ_PHY,ierr)
-    ELSE
-      FieldOut(:)=FieldIn(:)
-    ENDIF
-  
-  END SUBROUTINE scatter_surf_mpi_i
-
-
-
-  SUBROUTINE scatter_surf_r(FieldIn, FieldOut)
-  USE mod_phys_lmdz_para
-    REAL :: FieldIn(:)
-    REAL :: FieldOut(:)
-    REAL :: FieldTmp(knon_mpi)
-    
-    IF (is_omp_root) CALL scatter_surf_mpi_r(FieldIn,FieldTmp)
-    CALL scatter_surf_omp_r(FieldTmp,FieldOut)
-    
-  END SUBROUTINE scatter_surf_r
-
-
-  SUBROUTINE scatter_surf_omp_r(FieldIn,FieldOut)
-  USE mod_phys_lmdz_para
-    REAL :: FieldIn(:)
-    REAL :: FieldOut(:)
-  
-    INTEGER,SAVE,ALLOCATABLE :: Field_tmp(:)
-    
-    IF (is_omp_root) ALLOCATE(Field_tmp(knon_mpi))
-    IF (is_omp_root) Field_tmp(:)=FieldIn(:)
-!$OMP BARRIER        
-    FieldOut(:)=Field_tmp(knon_omp_begin:knon_omp_end)
-!$OMP BARRIER
-    IF (is_omp_root) DEALLOCATE(Field_tmp)
-    
-  END SUBROUTINE  scatter_surf_omp_r
-  
-     
-  SUBROUTINE scatter_surf_mpi_r(FieldIn,FieldOut)
-  USE mod_phys_lmdz_para
-  USE lmdz_mpi
-
-    REAL :: FieldIn(:)
-    REAL :: FieldOut(:)
-    INTEGER :: ierr
-    
-    IF (is_using_mpi) THEN
-      CALL MPI_Scatterv(FieldIn,knon_mpi_para,knon_mpi_begin_para(:)-1,MPI_INTEGER,   &
-                        FieldOut,knon_mpi,MPI_INTEGER,                                &
-                        mpi_master,COMM_LMDZ_PHY,ierr)
-    ELSE
-      FieldOut(:)=FieldIn(:)
-    ENDIF
-  
-  END SUBROUTINE scatter_surf_mpi_r
-
-END MODULE mod_surf_para
-
Index: /LMDZ6/trunk/libf/phylmd/mod_surf_para.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/mod_surf_para.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/mod_surf_para.f90	(revision 5268)
@@ -0,0 +1,336 @@
+MODULE mod_surf_para
+  IMPLICIT NONE
+  
+  INTERFACE gather_surf
+    MODULE PROCEDURE gather_surf_i,gather_surf_r
+  END INTERFACE gather_surf
+  
+  INTERFACE gather_surf_omp
+    MODULE PROCEDURE gather_surf_omp_i,gather_surf_omp_r
+  END INTERFACE gather_surf_omp
+
+  INTERFACE gather_surf_mpi
+    MODULE PROCEDURE gather_surf_mpi_i,gather_surf_mpi_r
+  END INTERFACE gather_surf_mpi
+
+  INTERFACE scatter_surf
+    MODULE PROCEDURE scatter_surf_i,scatter_surf_r
+  END INTERFACE scatter_surf
+  
+  INTERFACE scatter_surf_omp
+    MODULE PROCEDURE scatter_surf_omp_i,scatter_surf_omp_r
+  END INTERFACE scatter_surf_omp
+
+  INTERFACE scatter_surf_mpi
+    MODULE PROCEDURE scatter_surf_mpi_i,scatter_surf_mpi_r
+  END INTERFACE scatter_surf_mpi
+  
+  
+  INTEGER,SAVE             :: knon_omp
+  INTEGER,SAVE             :: knon_omp_begin
+  INTEGER,SAVE             :: knon_omp_end
+!$OMP THREADPRIVATE(knon_omp,knon_omp_begin,knon_omp_end)
+  INTEGER,ALLOCATABLE,SAVE :: knon_omp_para(:)
+  INTEGER,ALLOCATABLE,SAVE :: knon_omp_begin_para(:)
+  INTEGER,ALLOCATABLE,SAVE :: knon_omp_end_para(:)
+  
+  INTEGER,SAVE             :: knon_mpi
+  INTEGER,ALLOCATABLE,SAVE :: knon_mpi_para(:)
+  INTEGER,ALLOCATABLE,SAVE :: knon_mpi_begin_para(:)
+  INTEGER,ALLOCATABLE,SAVE :: knon_mpi_end_para(:)
+  
+  INTEGER,SAVE             :: knon_glo
+  INTEGER,SAVE,ALLOCATABLE :: knon_glo_para(:)  
+  INTEGER,ALLOCATABLE,SAVE :: knon_glo_begin_para(:)
+  INTEGER,ALLOCATABLE,SAVE :: knon_glo_end_para(:)
+  
+  
+CONTAINS
+
+  SUBROUTINE Init_surf_para(knon)
+  USE mod_phys_lmdz_para
+  USE lmdz_mpi
+
+    INTEGER :: knon
+    INTEGER :: i,ierr
+    
+    knon_omp=knon
+    IF (is_omp_root) THEN
+      ALLOCATE(knon_omp_para(0:omp_size-1))
+      ALLOCATE(knon_omp_begin_para(0:omp_size-1))
+      ALLOCATE(knon_omp_end_para(0:omp_size-1))
+    ENDIF
+!$OMP BARRIER
+    knon_omp_para(omp_rank)=knon
+!$OMP BARRIER
+    IF (is_omp_root) THEN 
+      knon_omp_begin_para(0)=1
+      knon_omp_end_para(0)=knon_omp_para(0)
+      DO i=1,omp_size-1
+        knon_omp_begin_para(i)=knon_omp_end_para(i-1)+1
+        knon_omp_end_para(i)=knon_omp_begin_para(i)+knon_omp_para(i)-1
+      ENDDO
+    ENDIF 
+!$OMP BARRIER
+    knon_omp_begin=knon_omp_begin_para(omp_rank)
+    knon_omp_end=knon_omp_end_para(omp_rank)
+!$OMP BARRIER    
+    IF (is_omp_root) THEN
+      knon_mpi=sum(knon_omp_para)
+      ALLOCATE(knon_mpi_para(0:mpi_size-1))
+      ALLOCATE(knon_mpi_begin_para(0:mpi_size-1))
+      ALLOCATE(knon_mpi_end_para(0:mpi_size-1))
+      
+      ALLOCATE(knon_glo_para(0:mpi_size*omp_size-1))
+      ALLOCATE(knon_glo_begin_para(0:mpi_size*omp_size-1))
+      ALLOCATE(knon_glo_end_para(0:mpi_size*omp_size-1))
+      
+      IF (is_using_mpi) THEN
+        CALL MPI_ALLGather(knon_mpi,1,MPI_INTEGER,knon_mpi_para,1,MPI_INTEGER,COMM_LMDZ_PHY,ierr)
+        CALL MPI_ALLGather(knon_omp_para,omp_size,MPI_INTEGER,knon_glo_para,omp_size,MPI_INTEGER,COMM_LMDZ_PHY,ierr)
+      ELSE
+        knon_mpi_para(:)=knon_mpi
+        knon_glo_para(:)=knon_omp_para(:)
+      ENDIF     
+      
+      knon_glo=sum(knon_mpi_para(:))
+      
+      knon_mpi_begin_para(0)=1
+      knon_mpi_end_para(0)=knon_mpi_para(0)
+      DO i=1,mpi_size-1
+        knon_mpi_begin_para(i)=knon_mpi_end_para(i-1)+1
+        knon_mpi_end_para(i)=knon_mpi_begin_para(i)+knon_mpi_para(i)-1
+      ENDDO
+      
+      knon_glo_begin_para(0)=1
+      knon_glo_end_para(0)=knon_glo_para(0)
+      DO i=1,mpi_size*omp_size-1
+        knon_glo_begin_para(i)=knon_glo_end_para(i-1)+1
+        knon_glo_end_para(i)= knon_glo_begin_para(i)+knon_glo_para(i)-1
+      ENDDO
+   ENDIF
+!$OMP BARRIER
+
+  END SUBROUTINE Init_surf_para
+
+ 
+  SUBROUTINE Finalize_surf_para
+  USE mod_phys_lmdz_para
+
+!$OMP BARRIER   
+   IF (is_omp_root) THEN
+      DEALLOCATE(knon_omp_para)
+      DEALLOCATE(knon_omp_begin_para)
+      DEALLOCATE(knon_omp_end_para)
+      DEALLOCATE(knon_mpi_para)
+      DEALLOCATE(knon_mpi_begin_para)
+      DEALLOCATE(knon_mpi_end_para)
+      DEALLOCATE(knon_glo_para)  
+      DEALLOCATE(knon_glo_begin_para)
+      DEALLOCATE(knon_glo_end_para)
+    ENDIF
+    
+  END SUBROUTINE Finalize_surf_para
+  
+  
+  SUBROUTINE gather_surf_i(FieldIn, FieldOut)
+  USE mod_phys_lmdz_para
+    INTEGER :: FieldIn(:)
+    INTEGER :: FieldOut(:)
+    INTEGER :: FieldTmp(knon_mpi)
+    
+    CALL gather_surf_omp_i(FieldIn,FieldTmp)
+    IF (is_omp_root) CALL gather_surf_mpi_i(FieldTmp,FieldOut)
+    
+  END SUBROUTINE gather_surf_i
+
+
+  SUBROUTINE gather_surf_omp_i(FieldIn,FieldOut)
+  USE mod_phys_lmdz_para
+    INTEGER :: FieldIn(:)
+    INTEGER :: FieldOut(:)
+  
+    INTEGER,SAVE,ALLOCATABLE :: Field_tmp(:)
+    
+    IF (is_omp_root) ALLOCATE(Field_tmp(knon_mpi))
+!$OMP BARRIER
+    Field_tmp(knon_omp_begin:knon_omp_end)=FieldIn(:)
+!$OMP BARRIER        
+    IF (is_omp_root) FieldOut(:)=Field_tmp(:)
+!$OMP BARRIER
+    IF (is_omp_root) DEALLOCATE(Field_tmp)
+    
+  END SUBROUTINE  gather_surf_omp_i
+  
+     
+  SUBROUTINE gather_surf_mpi_i(FieldIn,FieldOut)
+  USE mod_phys_lmdz_para
+  USE lmdz_mpi
+
+    INTEGER :: FieldIn(:)
+    INTEGER :: FieldOut(:)
+    INTEGER :: ierr
+    
+    IF (is_using_mpi) THEN
+      CALL MPI_Gatherv(FieldIn,knon_mpi,MPI_INTEGER,                                &
+                       FieldOut,knon_mpi_para,knon_mpi_begin_para(:)-1,MPI_INTEGER, &
+                       mpi_master,COMM_LMDZ_PHY,ierr)
+    ELSE
+      FieldOut(:)=FieldIn(:)
+    ENDIF
+  
+  END SUBROUTINE gather_surf_mpi_i
+  
+
+
+
+
+  SUBROUTINE gather_surf_r(FieldIn, FieldOut)
+  USE mod_phys_lmdz_para
+    REAL :: FieldIn(:)
+    REAL :: FieldOut(:)
+    REAL :: FieldTmp(knon_mpi)
+    
+    CALL gather_surf_omp_r(FieldIn,FieldTmp)
+    IF (is_omp_root) CALL gather_surf_mpi_r(FieldTmp,FieldOut)
+    
+  END SUBROUTINE gather_surf_r
+
+
+  SUBROUTINE gather_surf_omp_r(FieldIn,FieldOut)
+  USE mod_phys_lmdz_para
+    REAL :: FieldIn(:)
+    REAL :: FieldOut(:)
+  
+    REAL,SAVE,ALLOCATABLE :: Field_tmp(:)
+    
+    IF (is_omp_root) ALLOCATE(Field_tmp(knon_mpi))
+!$OMP BARRIER
+    Field_tmp(knon_omp_begin:knon_omp_end)=FieldIn(:)
+!$OMP BARRIER        
+    IF (is_omp_root) FieldOut(:)=Field_tmp(:)
+!$OMP BARRIER
+    IF (is_omp_root) DEALLOCATE(Field_tmp)
+    
+  END SUBROUTINE  gather_surf_omp_r
+  
+     
+  SUBROUTINE gather_surf_mpi_r(FieldIn,FieldOut)
+  USE mod_phys_lmdz_para
+  USE lmdz_mpi
+
+    REAL :: FieldIn(:)
+    REAL :: FieldOut(:)
+    REAL :: ierr
+    
+    IF (is_using_mpi) THEN
+      CALL MPI_Gatherv(FieldIn,knon_mpi,MPI_REAL_LMDZ,                                 &
+                       FieldOut,knon_mpi_para,knon_mpi_begin_para(:)-1,MPI_REAL_LMDZ,  &
+                       mpi_master,COMM_LMDZ_PHY,ierr)            
+    ELSE
+      FieldOut(:)=FieldIn(:)
+    ENDIF
+  
+  END SUBROUTINE gather_surf_mpi_r
+
+
+
+
+  SUBROUTINE scatter_surf_i(FieldIn, FieldOut)
+  USE mod_phys_lmdz_para
+    INTEGER :: FieldIn(:)
+    INTEGER :: FieldOut(:)
+    INTEGER :: FieldTmp(knon_mpi)
+    
+    IF (is_omp_root) CALL scatter_surf_mpi_i(FieldIn,FieldTmp)
+    CALL scatter_surf_omp_i(FieldTmp,FieldOut)
+    
+  END SUBROUTINE scatter_surf_i
+
+
+  SUBROUTINE scatter_surf_omp_i(FieldIn,FieldOut)
+  USE mod_phys_lmdz_para
+    INTEGER :: FieldIn(:)
+    INTEGER :: FieldOut(:)
+  
+    INTEGER,SAVE,ALLOCATABLE :: Field_tmp(:)
+    
+    IF (is_omp_root) ALLOCATE(Field_tmp(knon_mpi))
+    IF (is_omp_root) Field_tmp(:)=FieldIn(:)
+!$OMP BARRIER        
+    FieldOut(:)=Field_tmp(knon_omp_begin:knon_omp_end)
+!$OMP BARRIER
+    IF (is_omp_root) DEALLOCATE(Field_tmp)
+    
+  END SUBROUTINE  scatter_surf_omp_i
+  
+     
+  SUBROUTINE scatter_surf_mpi_i(FieldIn,FieldOut)
+  USE mod_phys_lmdz_para
+  USE lmdz_mpi
+
+    INTEGER :: FieldIn(:)
+    INTEGER :: FieldOut(:)
+    INTEGER :: ierr
+    
+    IF (is_using_mpi) THEN
+      CALL MPI_Scatterv(FieldIn,knon_mpi_para,knon_mpi_begin_para(:)-1,MPI_INTEGER,   &
+                        FieldOut,knon_mpi,MPI_INTEGER,                                &
+                        mpi_master,COMM_LMDZ_PHY,ierr)
+    ELSE
+      FieldOut(:)=FieldIn(:)
+    ENDIF
+  
+  END SUBROUTINE scatter_surf_mpi_i
+
+
+
+  SUBROUTINE scatter_surf_r(FieldIn, FieldOut)
+  USE mod_phys_lmdz_para
+    REAL :: FieldIn(:)
+    REAL :: FieldOut(:)
+    REAL :: FieldTmp(knon_mpi)
+    
+    IF (is_omp_root) CALL scatter_surf_mpi_r(FieldIn,FieldTmp)
+    CALL scatter_surf_omp_r(FieldTmp,FieldOut)
+    
+  END SUBROUTINE scatter_surf_r
+
+
+  SUBROUTINE scatter_surf_omp_r(FieldIn,FieldOut)
+  USE mod_phys_lmdz_para
+    REAL :: FieldIn(:)
+    REAL :: FieldOut(:)
+  
+    INTEGER,SAVE,ALLOCATABLE :: Field_tmp(:)
+    
+    IF (is_omp_root) ALLOCATE(Field_tmp(knon_mpi))
+    IF (is_omp_root) Field_tmp(:)=FieldIn(:)
+!$OMP BARRIER        
+    FieldOut(:)=Field_tmp(knon_omp_begin:knon_omp_end)
+!$OMP BARRIER
+    IF (is_omp_root) DEALLOCATE(Field_tmp)
+    
+  END SUBROUTINE  scatter_surf_omp_r
+  
+     
+  SUBROUTINE scatter_surf_mpi_r(FieldIn,FieldOut)
+  USE mod_phys_lmdz_para
+  USE lmdz_mpi
+
+    REAL :: FieldIn(:)
+    REAL :: FieldOut(:)
+    INTEGER :: ierr
+    
+    IF (is_using_mpi) THEN
+      CALL MPI_Scatterv(FieldIn,knon_mpi_para,knon_mpi_begin_para(:)-1,MPI_INTEGER,   &
+                        FieldOut,knon_mpi,MPI_INTEGER,                                &
+                        mpi_master,COMM_LMDZ_PHY,ierr)
+    ELSE
+      FieldOut(:)=FieldIn(:)
+    ENDIF
+  
+  END SUBROUTINE scatter_surf_mpi_r
+
+END MODULE mod_surf_para
+
Index: DZ6/trunk/libf/phylmd/mod_synchro_omp.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/mod_synchro_omp.F90	(revision 5267)
+++ 	(revision )
@@ -1,60 +1,0 @@
-!
-! $Id$
-!
-MODULE mod_synchro_omp
-
-    INTEGER,SAVE :: exit_omp  
-
-CONTAINS
-
-  SUBROUTINE Init_synchro_omp
-  USE mod_phys_lmdz_para 
-  IMPLICIT NONE
-
-  CALL omp_barrier
-!$OMP MASTER
-  exit_omp=0
-!$OMP END MASTER    
-  CALL omp_barrier
-
-  END SUBROUTINE Init_Synchro_omp
-  
-  SUBROUTINE Synchro_omp  
-  USE mod_phys_lmdz_para
-  IMPLICIT NONE
-  LOGICAL :: out
-  CHARACTER (LEN=20) :: modname='synchro_omp'
-  CHARACTER (LEN=80) :: abort_message
-  
-    out=.FALSE.
-!$OMP BARRIER
-!$OMP BARRIER
-!$OMP ATOMIC  
-    exit_omp=exit_omp+1
-!$OMP BARRIER
-!$OMP BARRIER
-    IF (exit_omp==omp_size) THEN
-      out=.TRUE.
-    ENDIF
-    
-    DO WHILE (.NOT. out)
-!$OMP BARRIER
-      IF (exit_omp==omp_size) out=.TRUE.
-!$OMP BARRIER
-    ENDDO
-
-!$OMP BARRIER
-!$OMP MASTER
-    exit_omp=0
-!$OMP END MASTER
-!$OMP BARRIER
-
-    IF (exit_omp/=0) THEN
-       abort_message='synchro_omp'
-       CALL abort_physic(modname,abort_message,1)
-    ENDIF
-
-  END SUBROUTINE Synchro_omp
-
-
-END MODULE mod_synchro_omp
Index: /LMDZ6/trunk/libf/phylmd/mod_synchro_omp.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/mod_synchro_omp.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/mod_synchro_omp.f90	(revision 5268)
@@ -0,0 +1,60 @@
+!
+! $Id$
+!
+MODULE mod_synchro_omp
+
+    INTEGER,SAVE :: exit_omp  
+
+CONTAINS
+
+  SUBROUTINE Init_synchro_omp
+  USE mod_phys_lmdz_para 
+  IMPLICIT NONE
+
+  CALL omp_barrier
+!$OMP MASTER
+  exit_omp=0
+!$OMP END MASTER    
+  CALL omp_barrier
+
+  END SUBROUTINE Init_Synchro_omp
+  
+  SUBROUTINE Synchro_omp  
+  USE mod_phys_lmdz_para
+  IMPLICIT NONE
+  LOGICAL :: out
+  CHARACTER (LEN=20) :: modname='synchro_omp'
+  CHARACTER (LEN=80) :: abort_message
+  
+    out=.FALSE.
+!$OMP BARRIER
+!$OMP BARRIER
+!$OMP ATOMIC  
+    exit_omp=exit_omp+1
+!$OMP BARRIER
+!$OMP BARRIER
+    IF (exit_omp==omp_size) THEN
+      out=.TRUE.
+    ENDIF
+    
+    DO WHILE (.NOT. out)
+!$OMP BARRIER
+      IF (exit_omp==omp_size) out=.TRUE.
+!$OMP BARRIER
+    ENDDO
+
+!$OMP BARRIER
+!$OMP MASTER
+    exit_omp=0
+!$OMP END MASTER
+!$OMP BARRIER
+
+    IF (exit_omp/=0) THEN
+       abort_message='synchro_omp'
+       CALL abort_physic(modname,abort_message,1)
+    ENDIF
+
+  END SUBROUTINE Synchro_omp
+
+
+END MODULE mod_synchro_omp
Index: DZ6/trunk/libf/phylmd/modd_csts.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/modd_csts.F90	(revision 5267)
+++ 	(revision )
@@ -1,91 +1,0 @@
-!SFX_LIC Copyright 1994-2014 CNRS, Meteo-France and Universite Paul Sabatier
-!SFX_LIC This is part of the SURFEX software governed by the CeCILL-C licence
-!SFX_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt  
-!SFX_LIC for details. version 1.
-!     ###############
-      MODULE MODD_CSTS      
-!     ###############
-!
-!!****  *MODD_CSTS* - declaration of Physic constants 
-!!
-!!    PURPOSE
-!!    -------
-!       The purpose of this declarative module is to declare  the 
-!     Physics constants.    
-!
-!!
-!!**  IMPLICIT ARGUMENTS
-!!    ------------------
-!!      None 
-!!
-!!    REFERENCE
-!!    ---------
-!!          
-!!    AUTHOR
-!!    ------
-!!      V. Ducrocq   *Meteo France*
-!!
-!!    MODIFICATIONS
-!!    -------------
-!!      Original    16/05/94  
-!!      J. Stein    02/01/95  add xrholw                    
-!!      J.-P. Pinty 13/12/95  add XALPI,XBETAI,XGAMI
-!!      J. Stein    25/07/97  add XTH00                    
-!!      V. Masson   05/10/98  add XRHOLI
-!!      C. Mari     31/10/00  add NDAYSEC
-!!      J. Escobar     06/13  add XSURF_TIMY XSURF_TIMY_12 XSURF_EPSILON for REAL*4
-!-------------------------------------------------------------------------------
-!
-!*       0.   DECLARATIONS
-!             ------------
-!
-IMPLICIT NONE 
-REAL,SAVE :: XPI                ! Pi
-!
-REAL,SAVE :: XDAY,XSIYEA,XSIDAY ! day duration, sideral year duration,
-                                ! sideral day duration
-!
-REAL,SAVE :: XKARMAN            ! von karman constant
-REAL,SAVE :: XLIGHTSPEED        ! light speed
-REAL,SAVE :: XPLANCK            ! Planck constant
-REAL,SAVE :: XBOLTZ             ! Boltzman constant 
-REAL,SAVE :: XAVOGADRO          ! Avogadro number
-!
-REAL,SAVE :: XRADIUS,XOMEGA     ! Earth radius, earth rotation
-REAL,SAVE :: XG                 ! Gravity constant
-!
-REAL,SAVE :: XP00               ! Reference pressure
-!
-REAL,SAVE :: XSTEFAN,XI0        ! Stefan-Boltzman constant, solar constant
-!
-REAL,SAVE :: XMD,XMV            ! Molar mass of dry air and molar mass of vapor
-REAL,SAVE :: XRD,XRV            ! Gaz constant for dry air, gaz constant for vapor
-REAL,SAVE :: XCPD,XCPV          ! Cpd (dry air), Cpv (vapor)
-REAL,SAVE :: XRHOLW             ! Volumic mass of liquid water
-REAL,SAVE :: XCL,XCI            ! Cl (liquid), Ci (ice)
-REAL,SAVE :: XTT                ! Triple point temperature
-REAL,SAVE :: XTTSI              ! Temperature of ice fusion over salty sea
-REAL,SAVE :: XTTS               ! Equivalent temperature of ice fusion over a mixed of sea and sea-ice
-REAL,SAVE :: XICEC              ! Threshold fraction over which the tile is considered as only covered with ice
-REAL,SAVE :: XLVTT              ! Vaporization heat constant
-REAL,SAVE :: XLSTT              ! Sublimation heat constant
-REAL,SAVE :: XLMTT              ! Melting heat constant
-REAL,SAVE :: XESTT              ! Saturation vapor pressure  at triple point
-                                ! temperature  
-REAL,SAVE :: XALPW,XBETAW,XGAMW ! Constants for saturation vapor 
-                                !  pressure  function 
-REAL,SAVE :: XALPI,XBETAI,XGAMI ! Constants for saturation vapor
-                                !  pressure  function over solid ice
-REAL, SAVE        :: XTH00      ! reference value  for the potential
-                                ! temperature
-REAL,SAVE :: XRHOLI             ! Volumic mass of ice
-REAL,SAVE :: XCONDI             ! thermal conductivity of ice (W m-1 K-1)
-!
-INTEGER, SAVE :: NDAYSEC        ! Number of seconds in a day
-!
-REAL,SAVE     :: XSURF_TINY          ! minimum real on this machine
-REAL,SAVE     :: XSURF_TINY_12       ! sqrt(minimum real on this machine)
-REAL,SAVE     :: XSURF_EPSILON       ! minimum space with 1.0
-!
-END MODULE MODD_CSTS
-
Index: /LMDZ6/trunk/libf/phylmd/modd_csts.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/modd_csts.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/modd_csts.f90	(revision 5268)
@@ -0,0 +1,91 @@
+!SFX_LIC Copyright 1994-2014 CNRS, Meteo-France and Universite Paul Sabatier
+!SFX_LIC This is part of the SURFEX software governed by the CeCILL-C licence
+!SFX_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt  
+!SFX_LIC for details. version 1.
+!     ###############
+      MODULE MODD_CSTS      
+!     ###############
+!
+!!****  *MODD_CSTS* - declaration of Physic constants 
+!!
+!!    PURPOSE
+!!    -------
+!       The purpose of this declarative module is to declare  the 
+!     Physics constants.    
+!
+!!
+!!**  IMPLICIT ARGUMENTS
+!!    ------------------
+!!      None 
+!!
+!!    REFERENCE
+!!    ---------
+!!          
+!!    AUTHOR
+!!    ------
+!!      V. Ducrocq   *Meteo France*
+!!
+!!    MODIFICATIONS
+!!    -------------
+!!      Original    16/05/94  
+!!      J. Stein    02/01/95  add xrholw                    
+!!      J.-P. Pinty 13/12/95  add XALPI,XBETAI,XGAMI
+!!      J. Stein    25/07/97  add XTH00                    
+!!      V. Masson   05/10/98  add XRHOLI
+!!      C. Mari     31/10/00  add NDAYSEC
+!!      J. Escobar     06/13  add XSURF_TIMY XSURF_TIMY_12 XSURF_EPSILON for REAL*4
+!-------------------------------------------------------------------------------
+!
+!*       0.   DECLARATIONS
+!             ------------
+!
+IMPLICIT NONE 
+REAL,SAVE :: XPI                ! Pi
+!
+REAL,SAVE :: XDAY,XSIYEA,XSIDAY ! day duration, sideral year duration,
+                                ! sideral day duration
+!
+REAL,SAVE :: XKARMAN            ! von karman constant
+REAL,SAVE :: XLIGHTSPEED        ! light speed
+REAL,SAVE :: XPLANCK            ! Planck constant
+REAL,SAVE :: XBOLTZ             ! Boltzman constant 
+REAL,SAVE :: XAVOGADRO          ! Avogadro number
+!
+REAL,SAVE :: XRADIUS,XOMEGA     ! Earth radius, earth rotation
+REAL,SAVE :: XG                 ! Gravity constant
+!
+REAL,SAVE :: XP00               ! Reference pressure
+!
+REAL,SAVE :: XSTEFAN,XI0        ! Stefan-Boltzman constant, solar constant
+!
+REAL,SAVE :: XMD,XMV            ! Molar mass of dry air and molar mass of vapor
+REAL,SAVE :: XRD,XRV            ! Gaz constant for dry air, gaz constant for vapor
+REAL,SAVE :: XCPD,XCPV          ! Cpd (dry air), Cpv (vapor)
+REAL,SAVE :: XRHOLW             ! Volumic mass of liquid water
+REAL,SAVE :: XCL,XCI            ! Cl (liquid), Ci (ice)
+REAL,SAVE :: XTT                ! Triple point temperature
+REAL,SAVE :: XTTSI              ! Temperature of ice fusion over salty sea
+REAL,SAVE :: XTTS               ! Equivalent temperature of ice fusion over a mixed of sea and sea-ice
+REAL,SAVE :: XICEC              ! Threshold fraction over which the tile is considered as only covered with ice
+REAL,SAVE :: XLVTT              ! Vaporization heat constant
+REAL,SAVE :: XLSTT              ! Sublimation heat constant
+REAL,SAVE :: XLMTT              ! Melting heat constant
+REAL,SAVE :: XESTT              ! Saturation vapor pressure  at triple point
+                                ! temperature  
+REAL,SAVE :: XALPW,XBETAW,XGAMW ! Constants for saturation vapor 
+                                !  pressure  function 
+REAL,SAVE :: XALPI,XBETAI,XGAMI ! Constants for saturation vapor
+                                !  pressure  function over solid ice
+REAL, SAVE        :: XTH00      ! reference value  for the potential
+                                ! temperature
+REAL,SAVE :: XRHOLI             ! Volumic mass of ice
+REAL,SAVE :: XCONDI             ! thermal conductivity of ice (W m-1 K-1)
+!
+INTEGER, SAVE :: NDAYSEC        ! Number of seconds in a day
+!
+REAL,SAVE     :: XSURF_TINY          ! minimum real on this machine
+REAL,SAVE     :: XSURF_TINY_12       ! sqrt(minimum real on this machine)
+REAL,SAVE     :: XSURF_EPSILON       ! minimum space with 1.0
+!
+END MODULE MODD_CSTS
+
Index: DZ6/trunk/libf/phylmd/moy_undefSTD.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/moy_undefSTD.F90	(revision 5267)
+++ 	(revision )
@@ -1,143 +1,0 @@
-
-! $Id$
-
-SUBROUTINE moy_undefstd(itap, itapm1)
-  USE netcdf
-  USE dimphy
-  USE phys_state_var_mod
-  USE wxios, ONLY: missing_val_xios => missing_val, using_xios
- 
-  USE phys_cal_mod, ONLY: mth_len
-  IMPLICIT NONE
-  include "clesphys.h"
-  REAL :: missing_val
-
-  ! ====================================================================
-
-  ! I. Musat : 09.2004
-
-  ! Moyenne - a des frequences differentes - des valeurs bien definies
-  ! (.NE.missing_val) des variables interpolees a un niveau de
-  ! pression.
-  ! 1) les variables de type "day" (nout=1) ou "mth" (nout=2) sont sommees
-  ! tous les pas de temps de la physique
-
-  ! 2) les variables de type "NMC" (nout=3) sont calculees a partir
-  ! des valeurs instantannees toutes les 6 heures
-
-
-  ! NB: mettre "inst(X)" dans le write_hist*NMC.h !
-  ! ====================================================================
-
-
-  ! variables Input
-  ! INTEGER nlevSTD, klevSTD, itap
-  ! PARAMETER(klevSTD=17)
-  INTEGER itap, itapm1
-
-  ! variables locales
-  ! INTEGER i, k, nout, n
-  ! PARAMETER(nout=3) !nout=1 day/nout=2 mth/nout=3 NMC
-  INTEGER i, k, n
-  ! REAL dtime, freq_outNMC(nout), freq_moyNMC(nout)
-  ! REAL freq_outNMC(nout), freq_calNMC(nout)
-  REAL freq_moynmc(nout)
-
-  ! variables Output
-  ! REAL tnondef(klon,klevSTD,nout)
-  ! REAL tsumSTD(klon,klevSTD,nout)
-
-  REAL un_jour
-  PARAMETER (un_jour=86400.)
-! REAL missing_val
-
-! missing_val = nf90_fill_real
-  IF (using_xios) THEN
-    missing_val = missing_val_xios
-  ELSE
-    missing_val=missing_val_nf90
-  ENDIF
-
-  DO n = 1, nout
-    IF (freq_outnmc(n)<0) THEN
-      freq_moynmc(n) = (mth_len*un_jour)/freq_calnmc(n)
-      ! print*,'moy_undefSTD n freq_out freq_moy =',
-      ! $n,freq_moyNMC(n)
-    ELSE
-      freq_moynmc(n) = freq_outnmc(n)/freq_calnmc(n)
-    END IF
-
-    ! calcul 1 fois pas mois, 1 fois par jour ou toutes les 6h
-
-    IF (n==1 .AND. itap==itapm1 .OR. n>1 .AND. mod(itap,nint(freq_outnmc(n)/ & 
-        phys_tstep))==0) THEN
-
-      ! print*,'moy_undefSTD n itap itapm1',n,itap,itapm1
-
-      DO k = 1, nlevstd
-        DO i = 1, klon
-          IF (tnondef(i,k,n)/=(freq_moynmc(n))) THEN
-            tsumstd(i, k, n) = tsumstd(i, k, n)/(freq_moynmc(n)-tnondef(i,k,n &
-              ))
-            usumstd(i, k, n) = usumstd(i, k, n)/(freq_moynmc(n)-tnondef(i,k,n &
-              ))
-            vsumstd(i, k, n) = vsumstd(i, k, n)/(freq_moynmc(n)-tnondef(i,k,n &
-              ))
-            wsumstd(i, k, n) = wsumstd(i, k, n)/(freq_moynmc(n)-tnondef(i,k,n &
-              ))
-            phisumstd(i, k, n) = phisumstd(i, k, n)/ &
-              (freq_moynmc(n)-tnondef(i,k,n))
-            qsumstd(i, k, n) = qsumstd(i, k, n)/(freq_moynmc(n)-tnondef(i,k,n &
-              ))
-            rhsumstd(i, k, n) = rhsumstd(i, k, n)/(freq_moynmc(n)-tnondef(i,k &
-              ,n))
-            uvsumstd(i, k, n) = uvsumstd(i, k, n)/(freq_moynmc(n)-tnondef(i,k &
-              ,n))
-            vqsumstd(i, k, n) = vqsumstd(i, k, n)/(freq_moynmc(n)-tnondef(i,k &
-              ,n))
-            vtsumstd(i, k, n) = vtsumstd(i, k, n)/(freq_moynmc(n)-tnondef(i,k &
-              ,n))
-            wqsumstd(i, k, n) = wqsumstd(i, k, n)/(freq_moynmc(n)-tnondef(i,k &
-              ,n))
-            vphisumstd(i, k, n) = vphisumstd(i, k, n)/ &
-              (freq_moynmc(n)-tnondef(i,k,n))
-            wtsumstd(i, k, n) = wtsumstd(i, k, n)/(freq_moynmc(n)-tnondef(i,k &
-              ,n))
-            u2sumstd(i, k, n) = u2sumstd(i, k, n)/(freq_moynmc(n)-tnondef(i,k &
-              ,n))
-            v2sumstd(i, k, n) = v2sumstd(i, k, n)/(freq_moynmc(n)-tnondef(i,k &
-              ,n))
-            t2sumstd(i, k, n) = t2sumstd(i, k, n)/(freq_moynmc(n)-tnondef(i,k &
-              ,n))
-            o3sumstd(i, k, n) = o3sumstd(i, k, n)/(freq_moynmc(n)-tnondef(i,k &
-              ,n))
-            o3daysumstd(i, k, n) = o3daysumstd(i, k, n)/ &
-              (freq_moynmc(n)-tnondef(i,k,n))
-          ELSE
-            tsumstd(i, k, n) = missing_val
-            usumstd(i, k, n) = missing_val
-            vsumstd(i, k, n) = missing_val
-            wsumstd(i, k, n) = missing_val
-            phisumstd(i, k, n) = missing_val
-            qsumstd(i, k, n) = missing_val
-            rhsumstd(i, k, n) = missing_val
-            uvsumstd(i, k, n) = missing_val
-            vqsumstd(i, k, n) = missing_val
-            vtsumstd(i, k, n) = missing_val
-            wqsumstd(i, k, n) = missing_val
-            vphisumstd(i, k, n) = missing_val
-            wtsumstd(i, k, n) = missing_val
-            u2sumstd(i, k, n) = missing_val
-            v2sumstd(i, k, n) = missing_val
-            t2sumstd(i, k, n) = missing_val
-            o3sumstd(i, k, n) = missing_val
-            o3daysumstd(i, k, n) = missing_val
-          END IF !tnondef(i,k,n).NE.(freq_moyNMC(n))
-        END DO !i
-      END DO !k
-    END IF !MOD(itap,NINT(freq_outNMC(n)/phys_tstep)).EQ.0
-
-  END DO !n
-
-  RETURN
-END SUBROUTINE moy_undefstd
Index: /LMDZ6/trunk/libf/phylmd/moy_undefSTD.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/moy_undefSTD.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/moy_undefSTD.f90	(revision 5268)
@@ -0,0 +1,143 @@
+
+! $Id$
+
+SUBROUTINE moy_undefstd(itap, itapm1)
+  USE netcdf
+  USE dimphy
+  USE phys_state_var_mod
+  USE wxios, ONLY: missing_val_xios => missing_val, using_xios
+ 
+  USE phys_cal_mod, ONLY: mth_len
+  IMPLICIT NONE
+  include "clesphys.h"
+  REAL :: missing_val
+
+  ! ====================================================================
+
+  ! I. Musat : 09.2004
+
+  ! Moyenne - a des frequences differentes - des valeurs bien definies
+  ! (.NE.missing_val) des variables interpolees a un niveau de
+  ! pression.
+  ! 1) les variables de type "day" (nout=1) ou "mth" (nout=2) sont sommees
+  ! tous les pas de temps de la physique
+
+  ! 2) les variables de type "NMC" (nout=3) sont calculees a partir
+  ! des valeurs instantannees toutes les 6 heures
+
+
+  ! NB: mettre "inst(X)" dans le write_hist*NMC.h !
+  ! ====================================================================
+
+
+  ! variables Input
+  ! INTEGER nlevSTD, klevSTD, itap
+  ! PARAMETER(klevSTD=17)
+  INTEGER itap, itapm1
+
+  ! variables locales
+  ! INTEGER i, k, nout, n
+  ! PARAMETER(nout=3) !nout=1 day/nout=2 mth/nout=3 NMC
+  INTEGER i, k, n
+  ! REAL dtime, freq_outNMC(nout), freq_moyNMC(nout)
+  ! REAL freq_outNMC(nout), freq_calNMC(nout)
+  REAL freq_moynmc(nout)
+
+  ! variables Output
+  ! REAL tnondef(klon,klevSTD,nout)
+  ! REAL tsumSTD(klon,klevSTD,nout)
+
+  REAL un_jour
+  PARAMETER (un_jour=86400.)
+! REAL missing_val
+
+! missing_val = nf90_fill_real
+  IF (using_xios) THEN
+    missing_val = missing_val_xios
+  ELSE
+    missing_val=missing_val_nf90
+  ENDIF
+
+  DO n = 1, nout
+    IF (freq_outnmc(n)<0) THEN
+      freq_moynmc(n) = (mth_len*un_jour)/freq_calnmc(n)
+      ! print*,'moy_undefSTD n freq_out freq_moy =',
+      ! $n,freq_moyNMC(n)
+    ELSE
+      freq_moynmc(n) = freq_outnmc(n)/freq_calnmc(n)
+    END IF
+
+    ! calcul 1 fois pas mois, 1 fois par jour ou toutes les 6h
+
+    IF (n==1 .AND. itap==itapm1 .OR. n>1 .AND. mod(itap,nint(freq_outnmc(n)/ & 
+        phys_tstep))==0) THEN
+
+      ! print*,'moy_undefSTD n itap itapm1',n,itap,itapm1
+
+      DO k = 1, nlevstd
+        DO i = 1, klon
+          IF (tnondef(i,k,n)/=(freq_moynmc(n))) THEN
+            tsumstd(i, k, n) = tsumstd(i, k, n)/(freq_moynmc(n)-tnondef(i,k,n &
+              ))
+            usumstd(i, k, n) = usumstd(i, k, n)/(freq_moynmc(n)-tnondef(i,k,n &
+              ))
+            vsumstd(i, k, n) = vsumstd(i, k, n)/(freq_moynmc(n)-tnondef(i,k,n &
+              ))
+            wsumstd(i, k, n) = wsumstd(i, k, n)/(freq_moynmc(n)-tnondef(i,k,n &
+              ))
+            phisumstd(i, k, n) = phisumstd(i, k, n)/ &
+              (freq_moynmc(n)-tnondef(i,k,n))
+            qsumstd(i, k, n) = qsumstd(i, k, n)/(freq_moynmc(n)-tnondef(i,k,n &
+              ))
+            rhsumstd(i, k, n) = rhsumstd(i, k, n)/(freq_moynmc(n)-tnondef(i,k &
+              ,n))
+            uvsumstd(i, k, n) = uvsumstd(i, k, n)/(freq_moynmc(n)-tnondef(i,k &
+              ,n))
+            vqsumstd(i, k, n) = vqsumstd(i, k, n)/(freq_moynmc(n)-tnondef(i,k &
+              ,n))
+            vtsumstd(i, k, n) = vtsumstd(i, k, n)/(freq_moynmc(n)-tnondef(i,k &
+              ,n))
+            wqsumstd(i, k, n) = wqsumstd(i, k, n)/(freq_moynmc(n)-tnondef(i,k &
+              ,n))
+            vphisumstd(i, k, n) = vphisumstd(i, k, n)/ &
+              (freq_moynmc(n)-tnondef(i,k,n))
+            wtsumstd(i, k, n) = wtsumstd(i, k, n)/(freq_moynmc(n)-tnondef(i,k &
+              ,n))
+            u2sumstd(i, k, n) = u2sumstd(i, k, n)/(freq_moynmc(n)-tnondef(i,k &
+              ,n))
+            v2sumstd(i, k, n) = v2sumstd(i, k, n)/(freq_moynmc(n)-tnondef(i,k &
+              ,n))
+            t2sumstd(i, k, n) = t2sumstd(i, k, n)/(freq_moynmc(n)-tnondef(i,k &
+              ,n))
+            o3sumstd(i, k, n) = o3sumstd(i, k, n)/(freq_moynmc(n)-tnondef(i,k &
+              ,n))
+            o3daysumstd(i, k, n) = o3daysumstd(i, k, n)/ &
+              (freq_moynmc(n)-tnondef(i,k,n))
+          ELSE
+            tsumstd(i, k, n) = missing_val
+            usumstd(i, k, n) = missing_val
+            vsumstd(i, k, n) = missing_val
+            wsumstd(i, k, n) = missing_val
+            phisumstd(i, k, n) = missing_val
+            qsumstd(i, k, n) = missing_val
+            rhsumstd(i, k, n) = missing_val
+            uvsumstd(i, k, n) = missing_val
+            vqsumstd(i, k, n) = missing_val
+            vtsumstd(i, k, n) = missing_val
+            wqsumstd(i, k, n) = missing_val
+            vphisumstd(i, k, n) = missing_val
+            wtsumstd(i, k, n) = missing_val
+            u2sumstd(i, k, n) = missing_val
+            v2sumstd(i, k, n) = missing_val
+            t2sumstd(i, k, n) = missing_val
+            o3sumstd(i, k, n) = missing_val
+            o3daysumstd(i, k, n) = missing_val
+          END IF !tnondef(i,k,n).NE.(freq_moyNMC(n))
+        END DO !i
+      END DO !k
+    END IF !MOD(itap,NINT(freq_outNMC(n)/phys_tstep)).EQ.0
+
+  END DO !n
+
+  RETURN
+END SUBROUTINE moy_undefstd
Index: DZ6/trunk/libf/phylmd/moyglo_aire.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/moyglo_aire.F90	(revision 5267)
+++ 	(revision )
@@ -1,149 +1,0 @@
-
-! $Header$
-
-SUBROUTINE moyglo_pondaire(nhori, champ, aire, ok_msk, msk, moyglo)
-
-  USE dimphy
-  IMPLICIT NONE
-
-  ! ==================================================================
-  ! I. Musat, 07.2004
-
-  ! Calcul moyenne globale ponderee par l'aire totale, avec ou sans masque
-
-  ! moyenne = Somme_(champ* aire)/Somme_aire
-
-  ! ==================================================================
-
-  INTEGER i, nhori
-  REAL champ(klon), aire(klon), msk(klon)
-  LOGICAL ok_msk
-  REAL moyglo
-
-  ! var locale
-  REAL airetot
-
-  ! PRINT*,'moyglo_pondaire nhori',nhori
-
-  airetot = 0.
-  moyglo = 0.
-
-  IF (ok_msk) THEN
-    DO i = 1, nhori
-      ! IF(msk(i).EQ.1.) THEN
-      IF (msk(i)>0.) THEN
-
-        ! aire totale
-        airetot = airetot + aire(i)*msk(i)
-
-        ! ponderation par la masse
-        moyglo = moyglo + champ(i)*aire(i)*msk(i)
-      END IF
-    END DO
-
-  ELSE !ok_msk
-    DO i = 1, nhori
-
-      ! aire totale
-      airetot = airetot + aire(i)
-
-      ! ponderation par la masse
-      moyglo = moyglo + champ(i)*aire(i)
-    END DO
-
-  END IF
-
-  ! moyenne ponderee par l'aire
-  moyglo = moyglo/airetot
-
-  RETURN
-END SUBROUTINE moyglo_pondaire
-
-SUBROUTINE moyglo_pondaima(nhori, nvert, champ, aire, pbord, moyglo)
-  USE dimphy
-  IMPLICIT NONE
-  ! ==================================================================
-  ! I. Musat, 07.2004
-
-  ! Calcul moyenne globale ponderee par la masse d'air, divisee par l'aire
-  ! totale avec ou sans masque
-
-  ! moyenne = Somme_(champ* masse_dair)/Somme_aire
-
-  ! ==================================================================
-  include "YOMCST.h"
-  INTEGER i, k, nhori, nvert
-  REAL champ(klon, klev), aire(klon)
-  REAL pbord(klon, klev+1)
-  REAL moyglo
-
-  ! var locale
-  REAL airetot
-
-  ! PRINT*,'moyglo_pondaima RG, nhori, nvert',RG,nhori,nvert
-
-  ! ponderation par la masse
-  moyglo = 0.
-  DO k = 1, nvert
-    DO i = 1, nhori
-      moyglo = moyglo + champ(i, k)*(pbord(i,k)-pbord(i,k+1))/rg*aire(i)
-    END DO
-  END DO
-
-  ! aire totale
-  airetot = 0.
-  DO i = 1, nhori
-    airetot = airetot + aire(i)
-  END DO
-
-  ! moyenne par mettre carre avec ponderation par la masse
-  moyglo = moyglo/airetot
-
-  RETURN
-END SUBROUTINE moyglo_pondaima
-
-SUBROUTINE moyglo_pondmass(nhori, nvert, champ, aire, pbord, moyglo)
-  USE dimphy
-  IMPLICIT NONE
-  ! ==================================================================
-  ! I. Musat, 07.2004
-
-  ! Calcul moyenne globale ponderee par la masse d'air, divisee par la
-  ! masse totale d'air, avec ou sans masque
-
-  ! moyenne = Somme_(champ* masse_dair)/Somme_(masse_dair)
-
-  ! ==================================================================
-  include "YOMCST.h"
-  INTEGER i, k, nhori, nvert
-  REAL champ(klon, klev), aire(klon)
-  REAL pbord(klon, klev+1)
-  REAL moyglo
-
-  ! var locale
-  REAL massetot
-
-  ! PRINT*,'moyglo_pondmass RG, nhori, nvert',RG,nhori,nvert
-
-  ! ponderation par la masse
-  moyglo = 0.
-  DO k = 1, nvert
-    DO i = 1, nhori
-      moyglo = moyglo + champ(i, k)*(pbord(i,k)-pbord(i,k+1))/rg*aire(i)
-    END DO
-  END DO
-
-  ! masse totale
-  massetot = 0.
-  DO k = 1, nvert
-    DO i = 1, nhori
-      massetot = massetot + (pbord(i,k)-pbord(i,k+1))/rg*aire(i)
-    END DO
-  END DO
-
-  ! moyenne par mettre carre avec ponderation par la masse
-  moyglo = moyglo/massetot
-
-  RETURN
-END SUBROUTINE moyglo_pondmass
-
Index: /LMDZ6/trunk/libf/phylmd/moyglo_aire.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/moyglo_aire.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/moyglo_aire.f90	(revision 5268)
@@ -0,0 +1,149 @@
+
+! $Header$
+
+SUBROUTINE moyglo_pondaire(nhori, champ, aire, ok_msk, msk, moyglo)
+
+  USE dimphy
+  IMPLICIT NONE
+
+  ! ==================================================================
+  ! I. Musat, 07.2004
+
+  ! Calcul moyenne globale ponderee par l'aire totale, avec ou sans masque
+
+  ! moyenne = Somme_(champ* aire)/Somme_aire
+
+  ! ==================================================================
+
+  INTEGER i, nhori
+  REAL champ(klon), aire(klon), msk(klon)
+  LOGICAL ok_msk
+  REAL moyglo
+
+  ! var locale
+  REAL airetot
+
+  ! PRINT*,'moyglo_pondaire nhori',nhori
+
+  airetot = 0.
+  moyglo = 0.
+
+  IF (ok_msk) THEN
+    DO i = 1, nhori
+      ! IF(msk(i).EQ.1.) THEN
+      IF (msk(i)>0.) THEN
+
+        ! aire totale
+        airetot = airetot + aire(i)*msk(i)
+
+        ! ponderation par la masse
+        moyglo = moyglo + champ(i)*aire(i)*msk(i)
+      END IF
+    END DO
+
+  ELSE !ok_msk
+    DO i = 1, nhori
+
+      ! aire totale
+      airetot = airetot + aire(i)
+
+      ! ponderation par la masse
+      moyglo = moyglo + champ(i)*aire(i)
+    END DO
+
+  END IF
+
+  ! moyenne ponderee par l'aire
+  moyglo = moyglo/airetot
+
+  RETURN
+END SUBROUTINE moyglo_pondaire
+
+SUBROUTINE moyglo_pondaima(nhori, nvert, champ, aire, pbord, moyglo)
+  USE dimphy
+  IMPLICIT NONE
+  ! ==================================================================
+  ! I. Musat, 07.2004
+
+  ! Calcul moyenne globale ponderee par la masse d'air, divisee par l'aire
+  ! totale avec ou sans masque
+
+  ! moyenne = Somme_(champ* masse_dair)/Somme_aire
+
+  ! ==================================================================
+  include "YOMCST.h"
+  INTEGER i, k, nhori, nvert
+  REAL champ(klon, klev), aire(klon)
+  REAL pbord(klon, klev+1)
+  REAL moyglo
+
+  ! var locale
+  REAL airetot
+
+  ! PRINT*,'moyglo_pondaima RG, nhori, nvert',RG,nhori,nvert
+
+  ! ponderation par la masse
+  moyglo = 0.
+  DO k = 1, nvert
+    DO i = 1, nhori
+      moyglo = moyglo + champ(i, k)*(pbord(i,k)-pbord(i,k+1))/rg*aire(i)
+    END DO
+  END DO
+
+  ! aire totale
+  airetot = 0.
+  DO i = 1, nhori
+    airetot = airetot + aire(i)
+  END DO
+
+  ! moyenne par mettre carre avec ponderation par la masse
+  moyglo = moyglo/airetot
+
+  RETURN
+END SUBROUTINE moyglo_pondaima
+
+SUBROUTINE moyglo_pondmass(nhori, nvert, champ, aire, pbord, moyglo)
+  USE dimphy
+  IMPLICIT NONE
+  ! ==================================================================
+  ! I. Musat, 07.2004
+
+  ! Calcul moyenne globale ponderee par la masse d'air, divisee par la
+  ! masse totale d'air, avec ou sans masque
+
+  ! moyenne = Somme_(champ* masse_dair)/Somme_(masse_dair)
+
+  ! ==================================================================
+  include "YOMCST.h"
+  INTEGER i, k, nhori, nvert
+  REAL champ(klon, klev), aire(klon)
+  REAL pbord(klon, klev+1)
+  REAL moyglo
+
+  ! var locale
+  REAL massetot
+
+  ! PRINT*,'moyglo_pondmass RG, nhori, nvert',RG,nhori,nvert
+
+  ! ponderation par la masse
+  moyglo = 0.
+  DO k = 1, nvert
+    DO i = 1, nhori
+      moyglo = moyglo + champ(i, k)*(pbord(i,k)-pbord(i,k+1))/rg*aire(i)
+    END DO
+  END DO
+
+  ! masse totale
+  massetot = 0.
+  DO k = 1, nvert
+    DO i = 1, nhori
+      massetot = massetot + (pbord(i,k)-pbord(i,k+1))/rg*aire(i)
+    END DO
+  END DO
+
+  ! moyenne par mettre carre avec ponderation par la masse
+  moyglo = moyglo/massetot
+
+  RETURN
+END SUBROUTINE moyglo_pondmass
+
Index: DZ6/trunk/libf/phylmd/nflxtr.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/nflxtr.F90	(revision 5267)
+++ 	(revision )
@@ -1,159 +1,0 @@
-!
-! $Id $
-!
-SUBROUTINE nflxtr(pdtime,pmfu,pmfd,pen_u,pde_u,pen_d,pde_d,pplay,paprs,x,dx) 
-  USE dimphy
-  IMPLICIT NONE 
-!=====================================================================
-! Objet : Melange convectif de traceurs a partir des flux de masse 
-! Date : 13/12/1996 -- 13/01/97
-! Auteur: O. Boucher (LOA) sur inspiration de Z. X. Li (LMD),
-!         Brinkop et Sausen (1996) et Boucher et al. (1996).
-! ATTENTION : meme si cette routine se veut la plus generale possible, 
-!             elle a herite de certaines notations et conventions du 
-!             schema de Tiedtke (1993).
-! 1. En particulier, les couches sont numerotees de haut en bas !!!
-!    Ceci est valable pour les flux
-!    mais pas pour les entrees x, pplay, paprs !!!!
-! 2. pmfu est positif, pmfd est negatif 
-! 3. Tous les flux d'entrainements et de detrainements sont positifs 
-!    contrairement au schema de Tiedtke d'ou les changements de signe!!!! 
-!=====================================================================
-!
-  include "YOMCST.h"
-  include "YOECUMF.h" 
-
-  REAL,INTENT(IN) :: pdtime  ! pdtphys
-!
-! les flux sont definis au 1/2 niveaux 
-! => pmfu(klev+1) et pmfd(klev+1) sont implicitement nuls
-!
-  REAL,DIMENSION(klon,klev),INTENT(IN) :: pmfu  ! flux de masse dans le panache montant 
-  REAL,DIMENSION(klon,klev),INTENT(IN) :: pmfd  ! flux de masse dans le panache descendant
-  REAL,DIMENSION(klon,klev),INTENT(IN) :: pen_u ! flux entraine dans le panache montant
-  REAL,DIMENSION(klon,klev),INTENT(IN) :: pde_u ! flux detraine dans le panache montant
-  REAL,DIMENSION(klon,klev),INTENT(IN) :: pen_d ! flux entraine dans le panache descendant
-  REAL,DIMENSION(klon,klev),INTENT(IN) :: pde_d ! flux detraine dans le panache descendant
-
-  REAL,DIMENSION(klon,klev),INTENT(IN)   :: pplay ! pression aux couches (bas en haut)
-  REAL,DIMENSION(klon,klev+1),INTENT(IN) :: paprs ! pression aux 1/2 couches (bas en haut)
-  REAL,DIMENSION(klon,klev),INTENT(IN)   :: x     ! q de traceur (bas en haut) 
-  REAL,DIMENSION(klon,klev),INTENT(INOUT) :: dx   ! tendance de traceur  (bas en haut)
-
-! flux convectifs mais en variables locales
-  REAL,DIMENSION(klon,klev+1) :: zmfu  ! copie de pmfu avec klev+1 = 0
-  REAL,DIMENSION(klon,klev+1) :: zmfd  ! copie de pmfd avec klev+1 = 0
-  REAL,DIMENSION(klon,klev)   :: zen_u
-  REAL,DIMENSION(klon,klev)   :: zde_u
-  REAL,DIMENSION(klon,klev)   :: zen_d
-  REAL,DIMENSION(klon,klev)   :: zde_d
-  REAL                        :: zmfe
-
-! variables locales      
-! les flux de x sont definis aux 1/2 niveaux 
-! xu et xd sont definis aux niveaux complets
-  REAL,DIMENSION(klon,klev)   :: xu      ! q de traceurs dans le panache montant
-  REAL,DIMENSION(klon,klev)   :: xd      ! q de traceurs dans le panache descendant
-  REAL,DIMENSION(klon,klev+1) :: zmfux   ! flux de x dans le panache montant
-  REAL,DIMENSION(klon,klev+1) :: zmfdx   ! flux de x dans le panache descendant
-  REAL,DIMENSION(klon,klev+1) :: zmfex   ! flux de x dans l'environnement 
-  INTEGER                     :: i, k 
-  REAL,PARAMETER              :: zmfmin=1.E-10
-
-! ==============================================
-! Extension des flux UP et DN sur klev+1 niveaux
-! ==============================================
-  DO k=1,klev
-     DO i=1,klon
-        zmfu(i,k)=pmfu(i,k)
-        zmfd(i,k)=pmfd(i,k)
-     ENDDO
-  ENDDO
-  DO i=1,klon
-     zmfu(i,klev+1)=0.
-     zmfd(i,klev+1)=0.
-  ENDDO
-! ==========================================
-! modif pour diagnostiquer les detrainements
-! ==========================================
-!   on privilegie l'ajustement de l'entrainement dans l'ascendance.
-
-  DO k=1, klev
-     DO i=1, klon
-        zen_d(i,k)=pen_d(i,k)
-        zde_u(i,k)=pde_u(i,k)
-        zde_d(i,k) =-zmfd(i,k+1)+zmfd(i,k)+zen_d(i,k)
-        zen_u(i,k) = zmfu(i,k+1)-zmfu(i,k)+zde_u(i,k)
-     ENDDO
-  ENDDO
-! =========================================
-! calcul des flux dans le panache montant
-! =========================================
-!
-! Dans la premiere couche, on prend q comme valeur de qu
-
-  DO i=1, klon
-     zmfux(i,1)=0.0 
-  ENDDO
-
-! Autres couches
-  DO k=1,klev
-     DO i=1, klon
-        IF ((zmfu(i,k+1)+zde_u(i,k)).lt.zmfmin) THEN
-           xu(i,k)=x(i,k)
-        ELSE
-           xu(i,k)=(zmfux(i,k)+zen_u(i,k)*x(i,k))/(zmfu(i,k+1)+zde_u(i,k))
-        ENDIF
-        zmfux(i,k+1)=zmfu(i,k+1)*xu(i,k)
-     ENDDO
-  ENDDO
-! ==========================================
-! calcul des flux dans le panache descendant
-! ==========================================
-   
-  DO i=1, klon
-     zmfdx(i,klev+1)=0.0 
-  ENDDO
-
-  DO k=klev,1,-1
-     DO i=1, klon
-        IF ((zde_d(i,k)-zmfd(i,k)).lt.zmfmin) THEN
-           xd(i,k)=x(i,k)
-        ELSE
-           xd(i,k)=(zmfdx(i,k+1)-zen_d(i,k)*x(i,k))/(zmfd(i,k)-zde_d(i,k))
-        ENDIF
-        zmfdx(i,k)=zmfd(i,k)*xd(i,k)
-     ENDDO
-  ENDDO
-! ===================================================
-! introduction du flux de retour dans l'environnement
-! ===================================================
-
-  DO k=2, klev
-     DO i=1, klon
-        zmfe=-zmfu(i,k)-zmfd(i,k)
-        IF (zmfe.le.0.) then
-           zmfex(i,k)= zmfe*x(i,k)
-        ELSE
-           zmfex(i,k)= zmfe*x(i,k-1)
-        ENDIF
-     ENDDO
-  ENDDO
-
-  DO i=1, klon
-     zmfex(i,1)=0.
-     zmfex(i,klev+1)=0.
-  ENDDO
-! ==========================
-! calcul final des tendances
-! ==========================
-  DO k=1, klev
-     DO i=1, klon
-        dx(i,k)=RG/(paprs(i,k)-paprs(i,k+1))*pdtime*  &
-             ( zmfux(i,k) - zmfux(i,k+1) +            &
-             zmfdx(i,k) - zmfdx(i,k+1) +              &
-             zmfex(i,k) - zmfex(i,k+1) )
-     ENDDO
-  ENDDO
-  
-END SUBROUTINE nflxtr
Index: /LMDZ6/trunk/libf/phylmd/nflxtr.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/nflxtr.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/nflxtr.f90	(revision 5268)
@@ -0,0 +1,159 @@
+!
+! $Id $
+!
+SUBROUTINE nflxtr(pdtime,pmfu,pmfd,pen_u,pde_u,pen_d,pde_d,pplay,paprs,x,dx) 
+  USE dimphy
+  IMPLICIT NONE 
+!=====================================================================
+! Objet : Melange convectif de traceurs a partir des flux de masse 
+! Date : 13/12/1996 -- 13/01/97
+! Auteur: O. Boucher (LOA) sur inspiration de Z. X. Li (LMD),
+!         Brinkop et Sausen (1996) et Boucher et al. (1996).
+! ATTENTION : meme si cette routine se veut la plus generale possible, 
+!             elle a herite de certaines notations et conventions du 
+!             schema de Tiedtke (1993).
+! 1. En particulier, les couches sont numerotees de haut en bas !!!
+!    Ceci est valable pour les flux
+!    mais pas pour les entrees x, pplay, paprs !!!!
+! 2. pmfu est positif, pmfd est negatif 
+! 3. Tous les flux d'entrainements et de detrainements sont positifs 
+!    contrairement au schema de Tiedtke d'ou les changements de signe!!!! 
+!=====================================================================
+!
+  include "YOMCST.h"
+  include "YOECUMF.h" 
+
+  REAL,INTENT(IN) :: pdtime  ! pdtphys
+!
+! les flux sont definis au 1/2 niveaux 
+! => pmfu(klev+1) et pmfd(klev+1) sont implicitement nuls
+!
+  REAL,DIMENSION(klon,klev),INTENT(IN) :: pmfu  ! flux de masse dans le panache montant 
+  REAL,DIMENSION(klon,klev),INTENT(IN) :: pmfd  ! flux de masse dans le panache descendant
+  REAL,DIMENSION(klon,klev),INTENT(IN) :: pen_u ! flux entraine dans le panache montant
+  REAL,DIMENSION(klon,klev),INTENT(IN) :: pde_u ! flux detraine dans le panache montant
+  REAL,DIMENSION(klon,klev),INTENT(IN) :: pen_d ! flux entraine dans le panache descendant
+  REAL,DIMENSION(klon,klev),INTENT(IN) :: pde_d ! flux detraine dans le panache descendant
+
+  REAL,DIMENSION(klon,klev),INTENT(IN)   :: pplay ! pression aux couches (bas en haut)
+  REAL,DIMENSION(klon,klev+1),INTENT(IN) :: paprs ! pression aux 1/2 couches (bas en haut)
+  REAL,DIMENSION(klon,klev),INTENT(IN)   :: x     ! q de traceur (bas en haut) 
+  REAL,DIMENSION(klon,klev),INTENT(INOUT) :: dx   ! tendance de traceur  (bas en haut)
+
+! flux convectifs mais en variables locales
+  REAL,DIMENSION(klon,klev+1) :: zmfu  ! copie de pmfu avec klev+1 = 0
+  REAL,DIMENSION(klon,klev+1) :: zmfd  ! copie de pmfd avec klev+1 = 0
+  REAL,DIMENSION(klon,klev)   :: zen_u
+  REAL,DIMENSION(klon,klev)   :: zde_u
+  REAL,DIMENSION(klon,klev)   :: zen_d
+  REAL,DIMENSION(klon,klev)   :: zde_d
+  REAL                        :: zmfe
+
+! variables locales      
+! les flux de x sont definis aux 1/2 niveaux 
+! xu et xd sont definis aux niveaux complets
+  REAL,DIMENSION(klon,klev)   :: xu      ! q de traceurs dans le panache montant
+  REAL,DIMENSION(klon,klev)   :: xd      ! q de traceurs dans le panache descendant
+  REAL,DIMENSION(klon,klev+1) :: zmfux   ! flux de x dans le panache montant
+  REAL,DIMENSION(klon,klev+1) :: zmfdx   ! flux de x dans le panache descendant
+  REAL,DIMENSION(klon,klev+1) :: zmfex   ! flux de x dans l'environnement 
+  INTEGER                     :: i, k 
+  REAL,PARAMETER              :: zmfmin=1.E-10
+
+! ==============================================
+! Extension des flux UP et DN sur klev+1 niveaux
+! ==============================================
+  DO k=1,klev
+     DO i=1,klon
+        zmfu(i,k)=pmfu(i,k)
+        zmfd(i,k)=pmfd(i,k)
+     ENDDO
+  ENDDO
+  DO i=1,klon
+     zmfu(i,klev+1)=0.
+     zmfd(i,klev+1)=0.
+  ENDDO
+! ==========================================
+! modif pour diagnostiquer les detrainements
+! ==========================================
+!   on privilegie l'ajustement de l'entrainement dans l'ascendance.
+
+  DO k=1, klev
+     DO i=1, klon
+        zen_d(i,k)=pen_d(i,k)
+        zde_u(i,k)=pde_u(i,k)
+        zde_d(i,k) =-zmfd(i,k+1)+zmfd(i,k)+zen_d(i,k)
+        zen_u(i,k) = zmfu(i,k+1)-zmfu(i,k)+zde_u(i,k)
+     ENDDO
+  ENDDO
+! =========================================
+! calcul des flux dans le panache montant
+! =========================================
+!
+! Dans la premiere couche, on prend q comme valeur de qu
+
+  DO i=1, klon
+     zmfux(i,1)=0.0 
+  ENDDO
+
+! Autres couches
+  DO k=1,klev
+     DO i=1, klon
+        IF ((zmfu(i,k+1)+zde_u(i,k)).lt.zmfmin) THEN
+           xu(i,k)=x(i,k)
+        ELSE
+           xu(i,k)=(zmfux(i,k)+zen_u(i,k)*x(i,k))/(zmfu(i,k+1)+zde_u(i,k))
+        ENDIF
+        zmfux(i,k+1)=zmfu(i,k+1)*xu(i,k)
+     ENDDO
+  ENDDO
+! ==========================================
+! calcul des flux dans le panache descendant
+! ==========================================
+   
+  DO i=1, klon
+     zmfdx(i,klev+1)=0.0 
+  ENDDO
+
+  DO k=klev,1,-1
+     DO i=1, klon
+        IF ((zde_d(i,k)-zmfd(i,k)).lt.zmfmin) THEN
+           xd(i,k)=x(i,k)
+        ELSE
+           xd(i,k)=(zmfdx(i,k+1)-zen_d(i,k)*x(i,k))/(zmfd(i,k)-zde_d(i,k))
+        ENDIF
+        zmfdx(i,k)=zmfd(i,k)*xd(i,k)
+     ENDDO
+  ENDDO
+! ===================================================
+! introduction du flux de retour dans l'environnement
+! ===================================================
+
+  DO k=2, klev
+     DO i=1, klon
+        zmfe=-zmfu(i,k)-zmfd(i,k)
+        IF (zmfe.le.0.) then
+           zmfex(i,k)= zmfe*x(i,k)
+        ELSE
+           zmfex(i,k)= zmfe*x(i,k-1)
+        ENDIF
+     ENDDO
+  ENDDO
+
+  DO i=1, klon
+     zmfex(i,1)=0.
+     zmfex(i,klev+1)=0.
+  ENDDO
+! ==========================
+! calcul final des tendances
+! ==========================
+  DO k=1, klev
+     DO i=1, klon
+        dx(i,k)=RG/(paprs(i,k)-paprs(i,k+1))*pdtime*  &
+             ( zmfux(i,k) - zmfux(i,k+1) +            &
+             zmfdx(i,k) - zmfdx(i,k+1) +              &
+             zmfex(i,k) - zmfex(i,k+1) )
+     ENDDO
+  ENDDO
+  
+END SUBROUTINE nflxtr
Index: DZ6/trunk/libf/phylmd/nonlocal.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/nonlocal.F90	(revision 5267)
+++ 	(revision )
@@ -1,407 +1,0 @@
-
-! $Header$
-
-! ======================================================================
-SUBROUTINE nonlocal(knon, paprs, pplay, tsol, beta, u, v, t, q, cd_h, cd_m, &
-    pcfh, pcfm, cgh, cgq)
-  USE dimphy
-  IMPLICIT NONE
-  ! ======================================================================
-  ! Laurent Li (LMD/CNRS), le 30 septembre 1998
-  ! Couche limite non-locale. Adaptation du code du CCM3.
-  ! Code non teste, donc a ne pas utiliser.
-  ! ======================================================================
-  ! Nonlocal scheme that determines eddy diffusivities based on a
-  ! diagnosed boundary layer height and a turbulent velocity scale.
-  ! Also countergradient effects for heat and moisture are included.
-
-  ! For more information, see Holtslag, A.A.M., and B.A. Boville, 1993:
-  ! Local versus nonlocal boundary-layer diffusion in a global climate
-  ! model. J. of Climate, vol. 6, 1825-1842.
-  ! ======================================================================
-  include "YOMCST.h"
-
-  ! Arguments:
-
-  INTEGER knon ! nombre de points a calculer
-  REAL tsol(klon) ! temperature du sol (K)
-  REAL beta(klon) ! efficacite d'evaporation (entre 0 et 1)
-  REAL paprs(klon, klev+1) ! pression a inter-couche (Pa)
-  REAL pplay(klon, klev) ! pression au milieu de couche (Pa)
-  REAL u(klon, klev) ! vitesse U (m/s)
-  REAL v(klon, klev) ! vitesse V (m/s)
-  REAL t(klon, klev) ! temperature (K)
-  REAL q(klon, klev) ! vapeur d'eau (kg/kg)
-  REAL cd_h(klon) ! coefficient de friction au sol pour chaleur
-  REAL cd_m(klon) ! coefficient de friction au sol pour vitesse
-
-  INTEGER isommet
-  REAL vk
-  PARAMETER (vk=0.40)
-  REAL ricr
-  PARAMETER (ricr=0.4)
-  REAL fak
-  PARAMETER (fak=8.5)
-  REAL fakn
-  PARAMETER (fakn=7.2)
-  REAL onet
-  PARAMETER (onet=1.0/3.0)
-  REAL t_coup
-  PARAMETER (t_coup=273.15)
-  REAL zkmin
-  PARAMETER (zkmin=0.01)
-  REAL betam
-  PARAMETER (betam=15.0)
-  REAL betah
-  PARAMETER (betah=15.0)
-  REAL betas
-  PARAMETER (betas=5.0)
-  REAL sffrac
-  PARAMETER (sffrac=0.1)
-  REAL binm
-  PARAMETER (binm=betam*sffrac)
-  REAL binh
-  PARAMETER (binh=betah*sffrac)
-  REAL ccon
-  PARAMETER (ccon=fak*sffrac*vk)
-
-  REAL z(klon, klev)
-  REAL pcfm(klon, klev), pcfh(klon, klev)
-
-  INTEGER i, k
-  REAL zxt, zxq, zxu, zxv, zxmod, taux, tauy
-  REAL zx_alf1, zx_alf2 ! parametres pour extrapolation
-  REAL khfs(klon) ! surface kinematic heat flux [mK/s]
-  REAL kqfs(klon) ! sfc kinematic constituent flux [m/s]
-  REAL heatv(klon) ! surface virtual heat flux
-  REAL ustar(klon)
-  REAL rino(klon, klev) ! bulk Richardon no. from level to ref lev
-  LOGICAL unstbl(klon) ! pts w/unstbl pbl (positive virtual ht flx)
-  LOGICAL stblev(klon) ! stable pbl with levels within pbl
-  LOGICAL unslev(klon) ! unstbl pbl with levels within pbl
-  LOGICAL unssrf(klon) ! unstb pbl w/lvls within srf pbl lyr
-  LOGICAL unsout(klon) ! unstb pbl w/lvls in outer pbl lyr
-  LOGICAL check(klon) ! True=>chk if Richardson no.>critcal
-  REAL pblh(klon)
-  REAL cgh(klon, 2:klev) ! counter-gradient term for heat [K/m]
-  REAL cgq(klon, 2:klev) ! counter-gradient term for constituents
-  REAL cgs(klon, 2:klev) ! counter-gradient star (cg/flux)
-  REAL obklen(klon)
-  REAL ztvd, ztvu, zdu2
-  REAL therm(klon) ! thermal virtual temperature excess
-  REAL phiminv(klon) ! inverse phi function for momentum
-  REAL phihinv(klon) ! inverse phi function for heat
-  REAL wm(klon) ! turbulent velocity scale for momentum
-  REAL fak1(klon) ! k*ustar*pblh
-  REAL fak2(klon) ! k*wm*pblh
-  REAL fak3(klon) ! fakn*wstr/wm
-  REAL pblk(klon) ! level eddy diffusivity for momentum
-  REAL pr(klon) ! Prandtl number for eddy diffusivities
-  REAL zl(klon) ! zmzp / Obukhov length
-  REAL zh(klon) ! zmzp / pblh
-  REAL zzh(klon) ! (1-(zmzp/pblh))**2
-  REAL wstr(klon) ! w*, convective velocity scale
-  REAL zm(klon) ! current level height
-  REAL zp(klon) ! current level height + one level up
-  REAL zcor, zdelta, zcvm5, zxqs
-  REAL fac, pblmin, zmzp, term
-
-  include "YOETHF.h"
-  include "FCTTRE.h"
-
-  ! Initialisation
-
-  isommet = klev
-
-  DO i = 1, klon
-    pcfh(i, 1) = cd_h(i)
-    pcfm(i, 1) = cd_m(i)
-  END DO
-  DO k = 2, klev
-    DO i = 1, klon
-      pcfh(i, k) = zkmin
-      pcfm(i, k) = zkmin
-      cgs(i, k) = 0.0
-      cgh(i, k) = 0.0
-      cgq(i, k) = 0.0
-    END DO
-  END DO
-
-  ! Calculer les hauteurs de chaque couche
-
-  DO i = 1, knon
-    z(i, 1) = rd*t(i, 1)/(0.5*(paprs(i,1)+pplay(i,1)))*(paprs(i,1)-pplay(i,1) &
-      )/rg
-  END DO
-  DO k = 2, klev
-    DO i = 1, knon
-      z(i, k) = z(i, k-1) + rd*0.5*(t(i,k-1)+t(i,k))/paprs(i, k)*(pplay(i,k-1 &
-        )-pplay(i,k))/rg
-    END DO
-  END DO
-
-  DO i = 1, knon
-    IF (thermcep) THEN
-      zdelta = max(0., sign(1.,rtt-tsol(i)))
-      zcvm5 = r5les*rlvtt*(1.-zdelta) + r5ies*rlstt*zdelta
-      zcvm5 = zcvm5/rcpd/(1.0+rvtmp2*q(i,1))
-      zxqs = r2es*foeew(tsol(i), zdelta)/paprs(i, 1)
-      zxqs = min(0.5, zxqs)
-      zcor = 1./(1.-retv*zxqs)
-      zxqs = zxqs*zcor
-    ELSE
-      IF (tsol(i)<t_coup) THEN
-        zxqs = qsats(tsol(i))/paprs(i, 1)
-      ELSE
-        zxqs = qsatl(tsol(i))/paprs(i, 1)
-      END IF
-    END IF
-    zx_alf1 = 1.0
-    zx_alf2 = 1.0 - zx_alf1
-    zxt = (t(i,1)+z(i,1)*rg/rcpd/(1.+rvtmp2*q(i,1)))*(1.+retv*q(i,1))*zx_alf1 &
-      + (t(i,2)+z(i,2)*rg/rcpd/(1.+rvtmp2*q(i,2)))*(1.+retv*q(i,2))*zx_alf2
-    zxu = u(i, 1)*zx_alf1 + u(i, 2)*zx_alf2
-    zxv = v(i, 1)*zx_alf1 + v(i, 2)*zx_alf2
-    zxq = q(i, 1)*zx_alf1 + q(i, 2)*zx_alf2
-    zxmod = 1.0 + sqrt(zxu**2+zxv**2)
-    khfs(i) = (tsol(i)*(1.+retv*q(i,1))-zxt)*zxmod*cd_h(i)
-    kqfs(i) = (zxqs-zxq)*zxmod*cd_h(i)*beta(i)
-    heatv(i) = khfs(i) + 0.61*zxt*kqfs(i)
-    taux = zxu*zxmod*cd_m(i)
-    tauy = zxv*zxmod*cd_m(i)
-    ustar(i) = sqrt(taux**2+tauy**2)
-    ustar(i) = max(sqrt(ustar(i)), 0.01)
-  END DO
-
-  DO i = 1, knon
-    rino(i, 1) = 0.0
-    check(i) = .TRUE.
-    pblh(i) = z(i, 1)
-    obklen(i) = -t(i, 1)*ustar(i)**3/(rg*vk*heatv(i))
-  END DO
-
-
-  ! PBL height calculation:
-  ! Search for level of pbl. Scan upward until the Richardson number between
-  ! the first level and the current level exceeds the "critical" value.
-
-  fac = 100.0
-  DO k = 1, isommet
-    DO i = 1, knon
-      IF (check(i)) THEN
-        zdu2 = (u(i,k)-u(i,1))**2 + (v(i,k)-v(i,1))**2 + fac*ustar(i)**2
-        zdu2 = max(zdu2, 1.0E-20)
-        ztvd = (t(i,k)+z(i,k)*0.5*rg/rcpd/(1.+rvtmp2*q(i, &
-          k)))*(1.+retv*q(i,k))
-        ztvu = (t(i,1)-z(i,k)*0.5*rg/rcpd/(1.+rvtmp2*q(i, &
-          1)))*(1.+retv*q(i,1))
-        rino(i, k) = (z(i,k)-z(i,1))*rg*(ztvd-ztvu)/(zdu2*0.5*(ztvd+ztvu))
-        IF (rino(i,k)>=ricr) THEN
-          pblh(i) = z(i, k-1) + (z(i,k-1)-z(i,k))*(ricr-rino(i,k-1))/(rino(i, &
-            k-1)-rino(i,k))
-          check(i) = .FALSE.
-        END IF
-      END IF
-    END DO
-  END DO
-
-
-  ! Set pbl height to maximum value where computation exceeds number of
-  ! layers allowed
-
-  DO i = 1, knon
-    IF (check(i)) pblh(i) = z(i, isommet)
-  END DO
-
-  ! Improve estimate of pbl height for the unstable points.
-  ! Find unstable points (sensible heat flux is upward):
-
-  DO i = 1, knon
-    IF (heatv(i)>0.) THEN
-      unstbl(i) = .TRUE.
-      check(i) = .TRUE.
-    ELSE
-      unstbl(i) = .FALSE.
-      check(i) = .FALSE.
-    END IF
-  END DO
-
-  ! For the unstable case, compute velocity scale and the
-  ! convective temperature excess:
-
-  DO i = 1, knon
-    IF (check(i)) THEN
-      phiminv(i) = (1.-binm*pblh(i)/obklen(i))**onet
-      wm(i) = ustar(i)*phiminv(i)
-      therm(i) = heatv(i)*fak/wm(i)
-      rino(i, 1) = 0.0
-    END IF
-  END DO
-
-  ! Improve pblh estimate for unstable conditions using the
-  ! convective temperature excess:
-
-  DO k = 1, isommet
-    DO i = 1, knon
-      IF (check(i)) THEN
-        zdu2 = (u(i,k)-u(i,1))**2 + (v(i,k)-v(i,1))**2 + fac*ustar(i)**2
-        zdu2 = max(zdu2, 1.0E-20)
-        ztvd = (t(i,k)+z(i,k)*0.5*rg/rcpd/(1.+rvtmp2*q(i, &
-          k)))*(1.+retv*q(i,k))
-        ztvu = (t(i,1)+therm(i)-z(i,k)*0.5*rg/rcpd/(1.+rvtmp2*q(i, &
-          1)))*(1.+retv*q(i,1))
-        rino(i, k) = (z(i,k)-z(i,1))*rg*(ztvd-ztvu)/(zdu2*0.5*(ztvd+ztvu))
-        IF (rino(i,k)>=ricr) THEN
-          pblh(i) = z(i, k-1) + (z(i,k-1)-z(i,k))*(ricr-rino(i,k-1))/(rino(i, &
-            k-1)-rino(i,k))
-          check(i) = .FALSE.
-        END IF
-      END IF
-    END DO
-  END DO
-
-  ! Set pbl height to maximum value where computation exceeds number of
-  ! layers allowed
-
-  DO i = 1, knon
-    IF (check(i)) pblh(i) = z(i, isommet)
-  END DO
-
-  ! Points for which pblh exceeds number of pbl layers allowed;
-  ! set to maximum
-
-  DO i = 1, knon
-    IF (check(i)) pblh(i) = z(i, isommet)
-  END DO
-
-  ! PBL height must be greater than some minimum mechanical mixing depth
-  ! Several investigators have proposed minimum mechanical mixing depth
-  ! relationships as a function of the local friction velocity, u*.  We
-  ! make use of a linear relationship of the form h = c u* where c=700.
-  ! The scaling arguments that give rise to this relationship most often
-  ! represent the coefficient c as some constant over the local coriolis
-  ! parameter.  Here we make use of the experimental results of Koracin
-  ! and Berkowicz (1988) [BLM, Vol 43] for wich they recommend 0.07/f
-  ! where f was evaluated at 39.5 N and 52 N.  Thus we use a typical mid
-  ! latitude value for f so that c = 0.07/f = 700.
-
-  DO i = 1, knon
-    pblmin = 700.0*ustar(i)
-    pblh(i) = max(pblh(i), pblmin)
-  END DO
-
-  ! pblh is now available; do preparation for diffusivity calculation:
-
-  DO i = 1, knon
-    pblk(i) = 0.0
-    fak1(i) = ustar(i)*pblh(i)*vk
-
-    ! Do additional preparation for unstable cases only, set temperature
-    ! and moisture perturbations depending on stability.
-
-    IF (unstbl(i)) THEN
-      zxt = (t(i,1)-z(i,1)*0.5*rg/rcpd/(1.+rvtmp2*q(i,1)))*(1.+retv*q(i,1))
-      phiminv(i) = (1.-binm*pblh(i)/obklen(i))**onet
-      phihinv(i) = sqrt(1.-binh*pblh(i)/obklen(i))
-      wm(i) = ustar(i)*phiminv(i)
-      fak2(i) = wm(i)*pblh(i)*vk
-      wstr(i) = (heatv(i)*rg*pblh(i)/zxt)**onet
-      fak3(i) = fakn*wstr(i)/wm(i)
-    END IF
-  END DO
-
-  ! Main level loop to compute the diffusivities and
-  ! counter-gradient terms:
-
-  DO k = 2, isommet
-
-    ! Find levels within boundary layer:
-
-    DO i = 1, knon
-      unslev(i) = .FALSE.
-      stblev(i) = .FALSE.
-      zm(i) = z(i, k-1)
-      zp(i) = z(i, k)
-      IF (zkmin==0.0 .AND. zp(i)>pblh(i)) zp(i) = pblh(i)
-      IF (zm(i)<pblh(i)) THEN
-        zmzp = 0.5*(zm(i)+zp(i))
-        zh(i) = zmzp/pblh(i)
-        zl(i) = zmzp/obklen(i)
-        zzh(i) = 0.
-        IF (zh(i)<=1.0) zzh(i) = (1.-zh(i))**2
-
-        ! stblev for points zm < plbh and stable and neutral
-        ! unslev for points zm < plbh and unstable
-
-        IF (unstbl(i)) THEN
-          unslev(i) = .TRUE.
-        ELSE
-          stblev(i) = .TRUE.
-        END IF
-      END IF
-    END DO
-
-    ! Stable and neutral points; set diffusivities; counter-gradient
-    ! terms zero for stable case:
-
-    DO i = 1, knon
-      IF (stblev(i)) THEN
-        IF (zl(i)<=1.) THEN
-          pblk(i) = fak1(i)*zh(i)*zzh(i)/(1.+betas*zl(i))
-        ELSE
-          pblk(i) = fak1(i)*zh(i)*zzh(i)/(betas+zl(i))
-        END IF
-        pcfm(i, k) = pblk(i)
-        pcfh(i, k) = pcfm(i, k)
-      END IF
-    END DO
-
-    ! unssrf, unstable within surface layer of pbl
-    ! unsout, unstable within outer   layer of pbl
-
-    DO i = 1, knon
-      unssrf(i) = .FALSE.
-      unsout(i) = .FALSE.
-      IF (unslev(i)) THEN
-        IF (zh(i)<sffrac) THEN
-          unssrf(i) = .TRUE.
-        ELSE
-          unsout(i) = .TRUE.
-        END IF
-      END IF
-    END DO
-
-    ! Unstable for surface layer; counter-gradient terms zero
-
-    DO i = 1, knon
-      IF (unssrf(i)) THEN
-        term = (1.-betam*zl(i))**onet
-        pblk(i) = fak1(i)*zh(i)*zzh(i)*term
-        pr(i) = term/sqrt(1.-betah*zl(i))
-      END IF
-    END DO
-
-    ! Unstable for outer layer; counter-gradient terms non-zero:
-
-    DO i = 1, knon
-      IF (unsout(i)) THEN
-        pblk(i) = fak2(i)*zh(i)*zzh(i)
-        cgs(i, k) = fak3(i)/(pblh(i)*wm(i))
-        cgh(i, k) = khfs(i)*cgs(i, k)
-        pr(i) = phiminv(i)/phihinv(i) + ccon*fak3(i)/fak
-        cgq(i, k) = kqfs(i)*cgs(i, k)
-      END IF
-    END DO
-
-    ! For all unstable layers, set diffusivities
-
-    DO i = 1, knon
-      IF (unslev(i)) THEN
-        pcfm(i, k) = pblk(i)
-        pcfh(i, k) = pblk(i)/pr(i)
-      END IF
-    END DO
-  END DO ! end of level loop
-
-  RETURN
-END SUBROUTINE nonlocal
Index: /LMDZ6/trunk/libf/phylmd/nonlocal.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/nonlocal.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/nonlocal.f90	(revision 5268)
@@ -0,0 +1,407 @@
+
+! $Header$
+
+! ======================================================================
+SUBROUTINE nonlocal(knon, paprs, pplay, tsol, beta, u, v, t, q, cd_h, cd_m, &
+    pcfh, pcfm, cgh, cgq)
+  USE dimphy
+  IMPLICIT NONE
+  ! ======================================================================
+  ! Laurent Li (LMD/CNRS), le 30 septembre 1998
+  ! Couche limite non-locale. Adaptation du code du CCM3.
+  ! Code non teste, donc a ne pas utiliser.
+  ! ======================================================================
+  ! Nonlocal scheme that determines eddy diffusivities based on a
+  ! diagnosed boundary layer height and a turbulent velocity scale.
+  ! Also countergradient effects for heat and moisture are included.
+
+  ! For more information, see Holtslag, A.A.M., and B.A. Boville, 1993:
+  ! Local versus nonlocal boundary-layer diffusion in a global climate
+  ! model. J. of Climate, vol. 6, 1825-1842.
+  ! ======================================================================
+  include "YOMCST.h"
+
+  ! Arguments:
+
+  INTEGER knon ! nombre de points a calculer
+  REAL tsol(klon) ! temperature du sol (K)
+  REAL beta(klon) ! efficacite d'evaporation (entre 0 et 1)
+  REAL paprs(klon, klev+1) ! pression a inter-couche (Pa)
+  REAL pplay(klon, klev) ! pression au milieu de couche (Pa)
+  REAL u(klon, klev) ! vitesse U (m/s)
+  REAL v(klon, klev) ! vitesse V (m/s)
+  REAL t(klon, klev) ! temperature (K)
+  REAL q(klon, klev) ! vapeur d'eau (kg/kg)
+  REAL cd_h(klon) ! coefficient de friction au sol pour chaleur
+  REAL cd_m(klon) ! coefficient de friction au sol pour vitesse
+
+  INTEGER isommet
+  REAL vk
+  PARAMETER (vk=0.40)
+  REAL ricr
+  PARAMETER (ricr=0.4)
+  REAL fak
+  PARAMETER (fak=8.5)
+  REAL fakn
+  PARAMETER (fakn=7.2)
+  REAL onet
+  PARAMETER (onet=1.0/3.0)
+  REAL t_coup
+  PARAMETER (t_coup=273.15)
+  REAL zkmin
+  PARAMETER (zkmin=0.01)
+  REAL betam
+  PARAMETER (betam=15.0)
+  REAL betah
+  PARAMETER (betah=15.0)
+  REAL betas
+  PARAMETER (betas=5.0)
+  REAL sffrac
+  PARAMETER (sffrac=0.1)
+  REAL binm
+  PARAMETER (binm=betam*sffrac)
+  REAL binh
+  PARAMETER (binh=betah*sffrac)
+  REAL ccon
+  PARAMETER (ccon=fak*sffrac*vk)
+
+  REAL z(klon, klev)
+  REAL pcfm(klon, klev), pcfh(klon, klev)
+
+  INTEGER i, k
+  REAL zxt, zxq, zxu, zxv, zxmod, taux, tauy
+  REAL zx_alf1, zx_alf2 ! parametres pour extrapolation
+  REAL khfs(klon) ! surface kinematic heat flux [mK/s]
+  REAL kqfs(klon) ! sfc kinematic constituent flux [m/s]
+  REAL heatv(klon) ! surface virtual heat flux
+  REAL ustar(klon)
+  REAL rino(klon, klev) ! bulk Richardon no. from level to ref lev
+  LOGICAL unstbl(klon) ! pts w/unstbl pbl (positive virtual ht flx)
+  LOGICAL stblev(klon) ! stable pbl with levels within pbl
+  LOGICAL unslev(klon) ! unstbl pbl with levels within pbl
+  LOGICAL unssrf(klon) ! unstb pbl w/lvls within srf pbl lyr
+  LOGICAL unsout(klon) ! unstb pbl w/lvls in outer pbl lyr
+  LOGICAL check(klon) ! True=>chk if Richardson no.>critcal
+  REAL pblh(klon)
+  REAL cgh(klon, 2:klev) ! counter-gradient term for heat [K/m]
+  REAL cgq(klon, 2:klev) ! counter-gradient term for constituents
+  REAL cgs(klon, 2:klev) ! counter-gradient star (cg/flux)
+  REAL obklen(klon)
+  REAL ztvd, ztvu, zdu2
+  REAL therm(klon) ! thermal virtual temperature excess
+  REAL phiminv(klon) ! inverse phi function for momentum
+  REAL phihinv(klon) ! inverse phi function for heat
+  REAL wm(klon) ! turbulent velocity scale for momentum
+  REAL fak1(klon) ! k*ustar*pblh
+  REAL fak2(klon) ! k*wm*pblh
+  REAL fak3(klon) ! fakn*wstr/wm
+  REAL pblk(klon) ! level eddy diffusivity for momentum
+  REAL pr(klon) ! Prandtl number for eddy diffusivities
+  REAL zl(klon) ! zmzp / Obukhov length
+  REAL zh(klon) ! zmzp / pblh
+  REAL zzh(klon) ! (1-(zmzp/pblh))**2
+  REAL wstr(klon) ! w*, convective velocity scale
+  REAL zm(klon) ! current level height
+  REAL zp(klon) ! current level height + one level up
+  REAL zcor, zdelta, zcvm5, zxqs
+  REAL fac, pblmin, zmzp, term
+
+  include "YOETHF.h"
+  include "FCTTRE.h"
+
+  ! Initialisation
+
+  isommet = klev
+
+  DO i = 1, klon
+    pcfh(i, 1) = cd_h(i)
+    pcfm(i, 1) = cd_m(i)
+  END DO
+  DO k = 2, klev
+    DO i = 1, klon
+      pcfh(i, k) = zkmin
+      pcfm(i, k) = zkmin
+      cgs(i, k) = 0.0
+      cgh(i, k) = 0.0
+      cgq(i, k) = 0.0
+    END DO
+  END DO
+
+  ! Calculer les hauteurs de chaque couche
+
+  DO i = 1, knon
+    z(i, 1) = rd*t(i, 1)/(0.5*(paprs(i,1)+pplay(i,1)))*(paprs(i,1)-pplay(i,1) &
+      )/rg
+  END DO
+  DO k = 2, klev
+    DO i = 1, knon
+      z(i, k) = z(i, k-1) + rd*0.5*(t(i,k-1)+t(i,k))/paprs(i, k)*(pplay(i,k-1 &
+        )-pplay(i,k))/rg
+    END DO
+  END DO
+
+  DO i = 1, knon
+    IF (thermcep) THEN
+      zdelta = max(0., sign(1.,rtt-tsol(i)))
+      zcvm5 = r5les*rlvtt*(1.-zdelta) + r5ies*rlstt*zdelta
+      zcvm5 = zcvm5/rcpd/(1.0+rvtmp2*q(i,1))
+      zxqs = r2es*foeew(tsol(i), zdelta)/paprs(i, 1)
+      zxqs = min(0.5, zxqs)
+      zcor = 1./(1.-retv*zxqs)
+      zxqs = zxqs*zcor
+    ELSE
+      IF (tsol(i)<t_coup) THEN
+        zxqs = qsats(tsol(i))/paprs(i, 1)
+      ELSE
+        zxqs = qsatl(tsol(i))/paprs(i, 1)
+      END IF
+    END IF
+    zx_alf1 = 1.0
+    zx_alf2 = 1.0 - zx_alf1
+    zxt = (t(i,1)+z(i,1)*rg/rcpd/(1.+rvtmp2*q(i,1)))*(1.+retv*q(i,1))*zx_alf1 &
+      + (t(i,2)+z(i,2)*rg/rcpd/(1.+rvtmp2*q(i,2)))*(1.+retv*q(i,2))*zx_alf2
+    zxu = u(i, 1)*zx_alf1 + u(i, 2)*zx_alf2
+    zxv = v(i, 1)*zx_alf1 + v(i, 2)*zx_alf2
+    zxq = q(i, 1)*zx_alf1 + q(i, 2)*zx_alf2
+    zxmod = 1.0 + sqrt(zxu**2+zxv**2)
+    khfs(i) = (tsol(i)*(1.+retv*q(i,1))-zxt)*zxmod*cd_h(i)
+    kqfs(i) = (zxqs-zxq)*zxmod*cd_h(i)*beta(i)
+    heatv(i) = khfs(i) + 0.61*zxt*kqfs(i)
+    taux = zxu*zxmod*cd_m(i)
+    tauy = zxv*zxmod*cd_m(i)
+    ustar(i) = sqrt(taux**2+tauy**2)
+    ustar(i) = max(sqrt(ustar(i)), 0.01)
+  END DO
+
+  DO i = 1, knon
+    rino(i, 1) = 0.0
+    check(i) = .TRUE.
+    pblh(i) = z(i, 1)
+    obklen(i) = -t(i, 1)*ustar(i)**3/(rg*vk*heatv(i))
+  END DO
+
+
+  ! PBL height calculation:
+  ! Search for level of pbl. Scan upward until the Richardson number between
+  ! the first level and the current level exceeds the "critical" value.
+
+  fac = 100.0
+  DO k = 1, isommet
+    DO i = 1, knon
+      IF (check(i)) THEN
+        zdu2 = (u(i,k)-u(i,1))**2 + (v(i,k)-v(i,1))**2 + fac*ustar(i)**2
+        zdu2 = max(zdu2, 1.0E-20)
+        ztvd = (t(i,k)+z(i,k)*0.5*rg/rcpd/(1.+rvtmp2*q(i, &
+          k)))*(1.+retv*q(i,k))
+        ztvu = (t(i,1)-z(i,k)*0.5*rg/rcpd/(1.+rvtmp2*q(i, &
+          1)))*(1.+retv*q(i,1))
+        rino(i, k) = (z(i,k)-z(i,1))*rg*(ztvd-ztvu)/(zdu2*0.5*(ztvd+ztvu))
+        IF (rino(i,k)>=ricr) THEN
+          pblh(i) = z(i, k-1) + (z(i,k-1)-z(i,k))*(ricr-rino(i,k-1))/(rino(i, &
+            k-1)-rino(i,k))
+          check(i) = .FALSE.
+        END IF
+      END IF
+    END DO
+  END DO
+
+
+  ! Set pbl height to maximum value where computation exceeds number of
+  ! layers allowed
+
+  DO i = 1, knon
+    IF (check(i)) pblh(i) = z(i, isommet)
+  END DO
+
+  ! Improve estimate of pbl height for the unstable points.
+  ! Find unstable points (sensible heat flux is upward):
+
+  DO i = 1, knon
+    IF (heatv(i)>0.) THEN
+      unstbl(i) = .TRUE.
+      check(i) = .TRUE.
+    ELSE
+      unstbl(i) = .FALSE.
+      check(i) = .FALSE.
+    END IF
+  END DO
+
+  ! For the unstable case, compute velocity scale and the
+  ! convective temperature excess:
+
+  DO i = 1, knon
+    IF (check(i)) THEN
+      phiminv(i) = (1.-binm*pblh(i)/obklen(i))**onet
+      wm(i) = ustar(i)*phiminv(i)
+      therm(i) = heatv(i)*fak/wm(i)
+      rino(i, 1) = 0.0
+    END IF
+  END DO
+
+  ! Improve pblh estimate for unstable conditions using the
+  ! convective temperature excess:
+
+  DO k = 1, isommet
+    DO i = 1, knon
+      IF (check(i)) THEN
+        zdu2 = (u(i,k)-u(i,1))**2 + (v(i,k)-v(i,1))**2 + fac*ustar(i)**2
+        zdu2 = max(zdu2, 1.0E-20)
+        ztvd = (t(i,k)+z(i,k)*0.5*rg/rcpd/(1.+rvtmp2*q(i, &
+          k)))*(1.+retv*q(i,k))
+        ztvu = (t(i,1)+therm(i)-z(i,k)*0.5*rg/rcpd/(1.+rvtmp2*q(i, &
+          1)))*(1.+retv*q(i,1))
+        rino(i, k) = (z(i,k)-z(i,1))*rg*(ztvd-ztvu)/(zdu2*0.5*(ztvd+ztvu))
+        IF (rino(i,k)>=ricr) THEN
+          pblh(i) = z(i, k-1) + (z(i,k-1)-z(i,k))*(ricr-rino(i,k-1))/(rino(i, &
+            k-1)-rino(i,k))
+          check(i) = .FALSE.
+        END IF
+      END IF
+    END DO
+  END DO
+
+  ! Set pbl height to maximum value where computation exceeds number of
+  ! layers allowed
+
+  DO i = 1, knon
+    IF (check(i)) pblh(i) = z(i, isommet)
+  END DO
+
+  ! Points for which pblh exceeds number of pbl layers allowed;
+  ! set to maximum
+
+  DO i = 1, knon
+    IF (check(i)) pblh(i) = z(i, isommet)
+  END DO
+
+  ! PBL height must be greater than some minimum mechanical mixing depth
+  ! Several investigators have proposed minimum mechanical mixing depth
+  ! relationships as a function of the local friction velocity, u*.  We
+  ! make use of a linear relationship of the form h = c u* where c=700.
+  ! The scaling arguments that give rise to this relationship most often
+  ! represent the coefficient c as some constant over the local coriolis
+  ! parameter.  Here we make use of the experimental results of Koracin
+  ! and Berkowicz (1988) [BLM, Vol 43] for wich they recommend 0.07/f
+  ! where f was evaluated at 39.5 N and 52 N.  Thus we use a typical mid
+  ! latitude value for f so that c = 0.07/f = 700.
+
+  DO i = 1, knon
+    pblmin = 700.0*ustar(i)
+    pblh(i) = max(pblh(i), pblmin)
+  END DO
+
+  ! pblh is now available; do preparation for diffusivity calculation:
+
+  DO i = 1, knon
+    pblk(i) = 0.0
+    fak1(i) = ustar(i)*pblh(i)*vk
+
+    ! Do additional preparation for unstable cases only, set temperature
+    ! and moisture perturbations depending on stability.
+
+    IF (unstbl(i)) THEN
+      zxt = (t(i,1)-z(i,1)*0.5*rg/rcpd/(1.+rvtmp2*q(i,1)))*(1.+retv*q(i,1))
+      phiminv(i) = (1.-binm*pblh(i)/obklen(i))**onet
+      phihinv(i) = sqrt(1.-binh*pblh(i)/obklen(i))
+      wm(i) = ustar(i)*phiminv(i)
+      fak2(i) = wm(i)*pblh(i)*vk
+      wstr(i) = (heatv(i)*rg*pblh(i)/zxt)**onet
+      fak3(i) = fakn*wstr(i)/wm(i)
+    END IF
+  END DO
+
+  ! Main level loop to compute the diffusivities and
+  ! counter-gradient terms:
+
+  DO k = 2, isommet
+
+    ! Find levels within boundary layer:
+
+    DO i = 1, knon
+      unslev(i) = .FALSE.
+      stblev(i) = .FALSE.
+      zm(i) = z(i, k-1)
+      zp(i) = z(i, k)
+      IF (zkmin==0.0 .AND. zp(i)>pblh(i)) zp(i) = pblh(i)
+      IF (zm(i)<pblh(i)) THEN
+        zmzp = 0.5*(zm(i)+zp(i))
+        zh(i) = zmzp/pblh(i)
+        zl(i) = zmzp/obklen(i)
+        zzh(i) = 0.
+        IF (zh(i)<=1.0) zzh(i) = (1.-zh(i))**2
+
+        ! stblev for points zm < plbh and stable and neutral
+        ! unslev for points zm < plbh and unstable
+
+        IF (unstbl(i)) THEN
+          unslev(i) = .TRUE.
+        ELSE
+          stblev(i) = .TRUE.
+        END IF
+      END IF
+    END DO
+
+    ! Stable and neutral points; set diffusivities; counter-gradient
+    ! terms zero for stable case:
+
+    DO i = 1, knon
+      IF (stblev(i)) THEN
+        IF (zl(i)<=1.) THEN
+          pblk(i) = fak1(i)*zh(i)*zzh(i)/(1.+betas*zl(i))
+        ELSE
+          pblk(i) = fak1(i)*zh(i)*zzh(i)/(betas+zl(i))
+        END IF
+        pcfm(i, k) = pblk(i)
+        pcfh(i, k) = pcfm(i, k)
+      END IF
+    END DO
+
+    ! unssrf, unstable within surface layer of pbl
+    ! unsout, unstable within outer   layer of pbl
+
+    DO i = 1, knon
+      unssrf(i) = .FALSE.
+      unsout(i) = .FALSE.
+      IF (unslev(i)) THEN
+        IF (zh(i)<sffrac) THEN
+          unssrf(i) = .TRUE.
+        ELSE
+          unsout(i) = .TRUE.
+        END IF
+      END IF
+    END DO
+
+    ! Unstable for surface layer; counter-gradient terms zero
+
+    DO i = 1, knon
+      IF (unssrf(i)) THEN
+        term = (1.-betam*zl(i))**onet
+        pblk(i) = fak1(i)*zh(i)*zzh(i)*term
+        pr(i) = term/sqrt(1.-betah*zl(i))
+      END IF
+    END DO
+
+    ! Unstable for outer layer; counter-gradient terms non-zero:
+
+    DO i = 1, knon
+      IF (unsout(i)) THEN
+        pblk(i) = fak2(i)*zh(i)*zzh(i)
+        cgs(i, k) = fak3(i)/(pblh(i)*wm(i))
+        cgh(i, k) = khfs(i)*cgs(i, k)
+        pr(i) = phiminv(i)/phihinv(i) + ccon*fak3(i)/fak
+        cgq(i, k) = kqfs(i)*cgs(i, k)
+      END IF
+    END DO
+
+    ! For all unstable layers, set diffusivities
+
+    DO i = 1, knon
+      IF (unslev(i)) THEN
+        pcfm(i, k) = pblk(i)
+        pcfh(i, k) = pblk(i)/pr(i)
+      END IF
+    END DO
+  END DO ! end of level loop
+
+  RETURN
+END SUBROUTINE nonlocal
Index: DZ6/trunk/libf/phylmd/nuage.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/nuage.F90	(revision 5267)
+++ 	(revision )
@@ -1,431 +1,0 @@
-! $Id$
-
-SUBROUTINE nuage(paprs, pplay, t, pqlwp,picefra, pclc, pcltau, pclemi, pch, pcl, pcm, &
-    pct, pctlwp, ok_aie, mass_solu_aero, mass_solu_aero_pi, bl95_b0, bl95_b1, distcltop, &
-    temp_cltop, cldtaupi, re, fl)
-  USE dimphy
-  USE lmdz_lscp_tools, only: icefrac_lscp
-  USE icefrac_lsc_mod ! computes ice fraction (JBM 3/14)
-  USE lmdz_lscp_ini, only : iflag_t_glace
-  USE phys_local_var_mod, ONLY: ptconv
-  IMPLICIT NONE
-  ! ======================================================================
-  ! Auteur(s): Z.X. Li (LMD/CNRS) date: 19930910
-  ! Objet: Calculer epaisseur optique et emmissivite des nuages
-  ! ======================================================================
-  ! Arguments:
-  ! t-------input-R-temperature
-  ! pqlwp---input-R-eau liquide nuageuse dans l'atmosphere (kg/kg)
-  ! picefra--inout-R-fraction de glace dans les nuages (-)
-  ! pclc----input-R-couverture nuageuse pour le rayonnement (0 a 1)
-  ! ok_aie--input-L-apply aerosol indirect effect or not
-  ! mass_solu_aero-----input-R-total mass concentration for all soluble
-  ! aerosols[ug/m^3]
-  ! mass_solu_aero_pi--input-R-dito, pre-industrial value
-  ! bl95_b0-input-R-a parameter, may be varied for tests (s-sea, l-land)
-  ! bl95_b1-input-R-a parameter, may be varied for tests (    -"-      )
-
-  ! cldtaupi-output-R-pre-industrial value of cloud optical thickness,
-  ! needed for the diagnostics of the aerosol indirect
-  ! radiative forcing (see radlwsw)
-  ! re------output-R-Cloud droplet effective radius multiplied by fl [um]
-  ! fl------output-R-Denominator to re, introduced to avoid problems in
-  ! the averaging of the output. fl is the fraction of liquid
-  ! water clouds within a grid cell
-
-  ! pcltau--output-R-epaisseur optique des nuages
-  ! pclemi--output-R-emissivite des nuages (0 a 1)
-  ! ======================================================================
-
-  include "YOMCST.h"
-  include "nuage.h" ! JBM 3/14
-  include "clesphys.h"
-
-  REAL paprs(klon, klev+1), pplay(klon, klev)
-  REAL t(klon, klev)
-
-  REAL pclc(klon, klev)
-  REAL pqlwp(klon, klev), picefra(klon,klev)
-  REAL pcltau(klon, klev), pclemi(klon, klev)
-
-  REAL pct(klon), pctlwp(klon), pch(klon), pcl(klon), pcm(klon)
-  REAL distcltop(klon,klev)
-  REAL temp_cltop(klon,klev)
-  LOGICAL lo
-
-  REAL cetahb, cetamb
-  PARAMETER (cetahb=0.45, cetamb=0.80)
-
-  INTEGER i, k
-  REAL zflwp, zradef, zfice(klon), zmsac
-
-  REAL radius, rad_chaud
-! JBM (3/14) parameters already defined in nuage.h:
-! REAL rad_froid, rad_chau1, rad_chau2
-! PARAMETER (rad_chau1=13.0, rad_chau2=9.0, rad_froid=35.0)
-  ! cc      PARAMETER (rad_chaud=15.0, rad_froid=35.0)
-  ! sintex initial      PARAMETER (rad_chaud=10.0, rad_froid=30.0)
-  REAL coef, coef_froi, coef_chau
-  PARAMETER (coef_chau=0.13, coef_froi=0.09)
-  REAL seuil_neb
-  PARAMETER (seuil_neb=0.001)
-! JBM (3/14) nexpo is replaced by exposant_glace
-! REAL nexpo ! exponentiel pour glace/eau
-! PARAMETER (nexpo=6.)
-  REAL, PARAMETER :: t_glace_min_old = 258.
-  INTEGER, PARAMETER :: exposant_glace_old = 6
-
-
-  ! jq for the aerosol indirect effect
-  ! jq introduced by Johannes Quaas (quaas@lmd.jussieu.fr), 27/11/2003
-  ! jq
-  LOGICAL ok_aie ! Apply AIE or not?
-
-  REAL mass_solu_aero(klon, klev) ! total mass concentration for all soluble aerosols[ug m-3]
-  REAL mass_solu_aero_pi(klon, klev) ! - " - pre-industrial value
-  REAL cdnc(klon, klev) ! cloud droplet number concentration [m-3]
-  REAL re(klon, klev) ! cloud droplet effective radius [um]
-  REAL cdnc_pi(klon, klev) ! cloud droplet number concentration [m-3] (pi value)
-  REAL re_pi(klon, klev) ! cloud droplet effective radius [um] (pi value)
-
-  REAL fl(klon, klev) ! xliq * rneb (denominator to re; fraction of liquid water clouds
-  ! within the grid cell)
-
-  REAL bl95_b0, bl95_b1 ! Parameter in B&L 95-Formula
-
-  REAL cldtaupi(klon, klev) ! pre-industrial cloud opt thickness for diag
-  REAl dzfice(klon)
-  ! jq-end
-
-  ! cc      PARAMETER (nexpo=1)
-
-  ! Calculer l'epaisseur optique et l'emmissivite des nuages
-
-  DO k = 1, klev
-     IF (iflag_t_glace.EQ.0) THEN
-       DO i = 1, klon
-        zfice(i) = 1.0 - (t(i,k)-t_glace_min_old)/(273.13-t_glace_min_old)
-        zfice(i) = min(max(zfice(i),0.0), 1.0)
-        zfice(i) = zfice(i)**exposant_glace_old
-       ENDDO
-     ELSE ! of IF (iflag_t_glace.EQ.0)
-! JBM: icefrac_lsc is now a function contained in icefrac_lsc_mod
-!       zfice(i) = icefrac_lsc(t(i,k), t_glace_min, &
-!                           t_glace_max, exposant_glace)
-        IF (ok_new_lscp) THEN
-            CALL icefrac_lscp(klon,t(:,k),iflag_ice_thermo,distcltop(:,k),temp_cltop(:,k),zfice(:),dzfice(:))
-        ELSE
-            CALL icefrac_lsc(klon,t(:,k),pplay(:,k)/paprs(:,1),zfice(:))
-
-        ENDIF
-
-    IF (ok_new_lscp .AND. ok_icefra_lscp) THEN
-    ! EV: take the ice fraction directly from the lscp code
-    ! consistent only for non convective grid points
-    ! critical for mixed phase clouds
-        DO i=1,klon
-        IF (.NOT. ptconv(i,k)) THEN
-           zfice(i)=picefra(i,k)
-        ENDIF
-        ENDDO
-    ENDIF 
-
-
-     ENDIF
-
-    DO i = 1, klon
-      rad_chaud = rad_chau1
-      IF (k<=3) rad_chaud = rad_chau2
-
-      pclc(i, k) = max(pclc(i,k), seuil_neb)
-      zflwp = 1000.*pqlwp(i, k)/rg/pclc(i, k)*(paprs(i,k)-paprs(i,k+1))
-
-      IF (ok_aie) THEN
-          ! Formula "D" of Boucher and Lohmann, Tellus, 1995
-          !
-        cdnc(i, k) = 10.**(bl95_b0+bl95_b1*log(max(mass_solu_aero(i,k), &
-          1.E-4))/log(10.))*1.E6 !-m-3
-          ! Cloud droplet number concentration (CDNC) is restricted
-          ! to be within [20, 1000 cm^3]
-          !
-        cdnc(i, k) = min(1000.E6, max(20.E6,cdnc(i,k)))
-        cdnc_pi(i, k) = 10.**(bl95_b0+bl95_b1*log(max(mass_solu_aero_pi(i,k), &
-          1.E-4))/log(10.))*1.E6 !-m-3
-        cdnc_pi(i, k) = min(1000.E6, max(20.E6,cdnc_pi(i,k)))
-          !
-          !
-          ! air density: pplay(i,k) / (RD * zT(i,k))
-          ! factor 1.1: derive effective radius from volume-mean radius
-          ! factor 1000 is the water density
-          ! _chaud means that this is the CDR for liquid water clouds
-          !
-        rad_chaud = 1.1*((pqlwp(i,k)*pplay(i,k)/(rd*t(i,k)))/(4./3.*rpi*1000. &
-          *cdnc(i,k)))**(1./3.)
-          !
-          ! Convert to um. CDR shall be at least 3 um.
-          !
-        rad_chaud = max(rad_chaud*1.E6, 3.)
-
-          ! For output diagnostics
-          !
-          ! Cloud droplet effective radius [um]
-          !
-          ! we multiply here with f * xl (fraction of liquid water
-          ! clouds in the grid cell) to avoid problems in the
-          ! averaging of the output.
-          ! In the output of IOIPSL, derive the real cloud droplet
-          ! effective radius as re/fl
-          !
-        fl(i, k) = pclc(i, k)*(1.-zfice(i))
-        re(i, k) = rad_chaud*fl(i, k)
-
-          ! Pre-industrial cloud opt thickness
-          !
-          ! "radius" is calculated as rad_chaud above (plus the
-          ! ice cloud contribution) but using cdnc_pi instead of
-          ! cdnc.
-        radius = max(1.1E6*((pqlwp(i,k)*pplay(i,k)/(rd*t(i,k)))/(4./3.*rpi* &
-          1000.*cdnc_pi(i,k)))**(1./3.), 3.)*(1.-zfice(i)) + rad_froid*zfice(i)
-        cldtaupi(i, k) = 3.0/2.0*zflwp/radius
-      END IF ! ok_aie
-
-      radius = rad_chaud*(1.-zfice(i)) + rad_froid*zfice(i)
-      coef = coef_chau*(1.-zfice(i)) + coef_froi*zfice(i)
-      pcltau(i, k) = 3.0/2.0*zflwp/radius
-      pclemi(i, k) = 1.0 - exp(-coef*zflwp)
-      lo = (pclc(i,k)<=seuil_neb)
-      IF (lo) pclc(i, k) = 0.0
-      IF (lo) pcltau(i, k) = 0.0
-      IF (lo) pclemi(i, k) = 0.0
-
-      IF (.NOT. ok_aie) cldtaupi(i, k) = pcltau(i, k)
-    END DO
-  END DO
-  ! cc      DO k = 1, klev
-  ! cc      DO i = 1, klon
-  ! cc         t(i,k) = t(i,k)
-  ! cc         pclc(i,k) = MAX( 1.e-5 , pclc(i,k) )
-  ! cc         lo = pclc(i,k) .GT. (2.*1.e-5)
-  ! cc         zflwp = pqlwp(i,k)*1000.*(paprs(i,k)-paprs(i,k+1))
-  ! cc     .          /(rg*pclc(i,k))
-  ! cc         zradef = 10.0 + (1.-sigs(k))*45.0
-  ! cc         pcltau(i,k) = 1.5 * zflwp / zradef
-  ! cc         zfice=1.0-MIN(MAX((t(i,k)-263.)/(273.-263.),0.0),1.0)
-  ! cc         zmsac = 0.13*(1.0-zfice) + 0.08*zfice
-  ! cc         pclemi(i,k) = 1.-EXP(-zmsac*zflwp)
-  ! cc         if (.NOT.lo) pclc(i,k) = 0.0
-  ! cc         if (.NOT.lo) pcltau(i,k) = 0.0
-  ! cc         if (.NOT.lo) pclemi(i,k) = 0.0
-  ! cc      ENDDO
-  ! cc      ENDDO
-  ! ccccc      print*, 'pas de nuage dans le rayonnement'
-  ! ccccc      DO k = 1, klev
-  ! ccccc      DO i = 1, klon
-  ! ccccc         pclc(i,k) = 0.0
-  ! ccccc         pcltau(i,k) = 0.0
-  ! ccccc         pclemi(i,k) = 0.0
-  ! ccccc      ENDDO
-  ! ccccc      ENDDO
-
-  ! COMPUTE CLOUD LIQUID PATH AND TOTAL CLOUDINESS
-
-  DO i = 1, klon
-    pct(i) = 1.0
-    pch(i) = 1.0
-    pcm(i) = 1.0
-    pcl(i) = 1.0
-    pctlwp(i) = 0.0
-  END DO
-
-  DO k = klev, 1, -1
-    DO i = 1, klon
-      pctlwp(i) = pctlwp(i) + pqlwp(i, k)*(paprs(i,k)-paprs(i,k+1))/rg
-      pct(i) = pct(i)*(1.0-pclc(i,k))
-      IF (pplay(i,k)<=cetahb*paprs(i,1)) pch(i) = pch(i)*(1.0-pclc(i,k))
-      IF (pplay(i,k)>cetahb*paprs(i,1) .AND. pplay(i,k)<=cetamb*paprs(i,1)) &
-        pcm(i) = pcm(i)*(1.0-pclc(i,k))
-      IF (pplay(i,k)>cetamb*paprs(i,1)) pcl(i) = pcl(i)*(1.0-pclc(i,k))
-    END DO
-  END DO
-
-  DO i = 1, klon
-    pct(i) = 1. - pct(i)
-    pch(i) = 1. - pch(i)
-    pcm(i) = 1. - pcm(i)
-    pcl(i) = 1. - pcl(i)
-  END DO
-
-  RETURN
-END SUBROUTINE nuage
-SUBROUTINE diagcld1(paprs, pplay, rain, snow, kbot, ktop, diafra, dialiq)
-  USE dimphy
-  IMPLICIT NONE
-
-  ! Laurent Li (LMD/CNRS), le 12 octobre 1998
-  ! (adaptation du code ECMWF)
-
-  ! Dans certains cas, le schema pronostique des nuages n'est
-  ! pas suffisament performant. On a donc besoin de diagnostiquer
-  ! ces nuages. Je dois avouer que c'est une frustration.
-
-  include "YOMCST.h"
-
-  ! Arguments d'entree:
-  REAL paprs(klon, klev+1) ! pression (Pa) a inter-couche
-  REAL pplay(klon, klev) ! pression (Pa) au milieu de couche
-  REAL t(klon, klev) ! temperature (K)
-  REAL q(klon, klev) ! humidite specifique (Kg/Kg)
-  REAL rain(klon) ! pluie convective (kg/m2/s)
-  REAL snow(klon) ! neige convective (kg/m2/s)
-  INTEGER ktop(klon) ! sommet de la convection
-  INTEGER kbot(klon) ! bas de la convection
-
-  ! Arguments de sortie:
-  REAL diafra(klon, klev) ! fraction nuageuse diagnostiquee
-  REAL dialiq(klon, klev) ! eau liquide nuageuse
-
-  ! Constantes ajustables:
-  REAL canva, canvb, canvh
-  PARAMETER (canva=2.0, canvb=0.3, canvh=0.4)
-  REAL cca, ccb, ccc
-  PARAMETER (cca=0.125, ccb=1.5, ccc=0.8)
-  REAL ccfct, ccscal
-  PARAMETER (ccfct=0.400)
-  PARAMETER (ccscal=1.0E+11)
-  REAL cetahb, cetamb
-  PARAMETER (cetahb=0.45, cetamb=0.80)
-  REAL cclwmr
-  PARAMETER (cclwmr=1.E-04)
-  REAL zepscr
-  PARAMETER (zepscr=1.0E-10)
-
-  ! Variables locales:
-  INTEGER i, k
-  REAL zcc(klon)
-
-  ! Initialisation:
-
-  DO k = 1, klev
-    DO i = 1, klon
-      diafra(i, k) = 0.0
-      dialiq(i, k) = 0.0
-    END DO
-  END DO
-
-  DO i = 1, klon ! Calculer la fraction nuageuse
-    zcc(i) = 0.0
-    IF ((rain(i)+snow(i))>0.) THEN
-      zcc(i) = cca*log(max(zepscr,(rain(i)+snow(i))*ccscal)) - ccb
-      zcc(i) = min(ccc, max(0.0,zcc(i)))
-    END IF
-  END DO
-
-  DO i = 1, klon ! pour traiter les enclumes
-    diafra(i, ktop(i)) = max(diafra(i,ktop(i)), zcc(i)*ccfct)
-    IF ((zcc(i)>=canvh) .AND. (pplay(i,ktop(i))<=cetahb*paprs(i, &
-      1))) diafra(i, ktop(i)) = max(diafra(i,ktop(i)), max(zcc( &
-      i)*ccfct,canva*(zcc(i)-canvb)))
-    dialiq(i, ktop(i)) = cclwmr*diafra(i, ktop(i))
-  END DO
-
-  DO k = 1, klev ! nuages convectifs (sauf enclumes)
-    DO i = 1, klon
-      IF (k<ktop(i) .AND. k>=kbot(i)) THEN
-        diafra(i, k) = max(diafra(i,k), zcc(i)*ccfct)
-        dialiq(i, k) = cclwmr*diafra(i, k)
-      END IF
-    END DO
-  END DO
-
-  RETURN
-END SUBROUTINE diagcld1
-SUBROUTINE diagcld2(paprs, pplay, t, q, diafra, dialiq)
-  USE dimphy
-  IMPLICIT NONE
-
-  include "YOMCST.h"
-
-  ! Arguments d'entree:
-  REAL paprs(klon, klev+1) ! pression (Pa) a inter-couche
-  REAL pplay(klon, klev) ! pression (Pa) au milieu de couche
-  REAL t(klon, klev) ! temperature (K)
-  REAL q(klon, klev) ! humidite specifique (Kg/Kg)
-
-  ! Arguments de sortie:
-  REAL diafra(klon, klev) ! fraction nuageuse diagnostiquee
-  REAL dialiq(klon, klev) ! eau liquide nuageuse
-
-  REAL cetamb
-  PARAMETER (cetamb=0.80)
-  REAL cloia, cloib, cloic, cloid
-  PARAMETER (cloia=1.0E+02, cloib=-10.00, cloic=-0.6, cloid=5.0)
-  ! cc      PARAMETER (CLOIA=1.0E+02, CLOIB=-10.00, CLOIC=-0.9, CLOID=5.0)
-  REAL rgammas
-  PARAMETER (rgammas=0.05)
-  REAL crhl
-  PARAMETER (crhl=0.15)
-  ! cc      PARAMETER (CRHL=0.70)
-  REAL t_coup
-  PARAMETER (t_coup=234.0)
-
-  ! Variables locales:
-  INTEGER i, k, kb, invb(klon)
-  REAL zqs, zrhb, zcll, zdthmin(klon), zdthdp
-  REAL zdelta, zcor
-
-  ! Fonctions thermodynamiques:
-  include "YOETHF.h"
-  include "FCTTRE.h"
-
-  ! Initialisation:
-
-  DO k = 1, klev
-    DO i = 1, klon
-      diafra(i, k) = 0.0
-      dialiq(i, k) = 0.0
-    END DO
-  END DO
-
-  DO i = 1, klon
-    invb(i) = klev
-    zdthmin(i) = 0.0
-  END DO
-
-  DO k = 2, klev/2 - 1
-    DO i = 1, klon
-      zdthdp = (t(i,k)-t(i,k+1))/(pplay(i,k)-pplay(i,k+1)) - &
-        rd*0.5*(t(i,k)+t(i,k+1))/rcpd/paprs(i, k+1)
-      zdthdp = zdthdp*cloia
-      IF (pplay(i,k)>cetamb*paprs(i,1) .AND. zdthdp<zdthmin(i)) THEN
-        zdthmin(i) = zdthdp
-        invb(i) = k
-      END IF
-    END DO
-  END DO
-
-  DO i = 1, klon
-    kb = invb(i)
-    IF (thermcep) THEN
-      zdelta = max(0., sign(1.,rtt-t(i,kb)))
-      zqs = r2es*foeew(t(i,kb), zdelta)/pplay(i, kb)
-      zqs = min(0.5, zqs)
-      zcor = 1./(1.-retv*zqs)
-      zqs = zqs*zcor
-    ELSE
-      IF (t(i,kb)<t_coup) THEN
-        zqs = qsats(t(i,kb))/pplay(i, kb)
-      ELSE
-        zqs = qsatl(t(i,kb))/pplay(i, kb)
-      END IF
-    END IF
-    zcll = cloib*zdthmin(i) + cloic
-    zcll = min(1.0, max(0.0,zcll))
-    zrhb = q(i, kb)/zqs
-    IF (zcll>0.0 .AND. zrhb<crhl) zcll = zcll*(1.-(crhl-zrhb)*cloid)
-    zcll = min(1.0, max(0.0,zcll))
-    diafra(i, kb) = max(diafra(i,kb), zcll)
-    dialiq(i, kb) = diafra(i, kb)*rgammas*zqs
-  END DO
-
-  RETURN
-END SUBROUTINE diagcld2
Index: /LMDZ6/trunk/libf/phylmd/nuage.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/nuage.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/nuage.f90	(revision 5268)
@@ -0,0 +1,431 @@
+! $Id$
+
+SUBROUTINE nuage(paprs, pplay, t, pqlwp,picefra, pclc, pcltau, pclemi, pch, pcl, pcm, &
+    pct, pctlwp, ok_aie, mass_solu_aero, mass_solu_aero_pi, bl95_b0, bl95_b1, distcltop, &
+    temp_cltop, cldtaupi, re, fl)
+  USE dimphy
+  USE lmdz_lscp_tools, only: icefrac_lscp
+  USE icefrac_lsc_mod ! computes ice fraction (JBM 3/14)
+  USE lmdz_lscp_ini, only : iflag_t_glace
+  USE phys_local_var_mod, ONLY: ptconv
+  IMPLICIT NONE
+  ! ======================================================================
+  ! Auteur(s): Z.X. Li (LMD/CNRS) date: 19930910
+  ! Objet: Calculer epaisseur optique et emmissivite des nuages
+  ! ======================================================================
+  ! Arguments:
+  ! t-------input-R-temperature
+  ! pqlwp---input-R-eau liquide nuageuse dans l'atmosphere (kg/kg)
+  ! picefra--inout-R-fraction de glace dans les nuages (-)
+  ! pclc----input-R-couverture nuageuse pour le rayonnement (0 a 1)
+  ! ok_aie--input-L-apply aerosol indirect effect or not
+  ! mass_solu_aero-----input-R-total mass concentration for all soluble
+  ! aerosols[ug/m^3]
+  ! mass_solu_aero_pi--input-R-dito, pre-industrial value
+  ! bl95_b0-input-R-a parameter, may be varied for tests (s-sea, l-land)
+  ! bl95_b1-input-R-a parameter, may be varied for tests (    -"-      )
+
+  ! cldtaupi-output-R-pre-industrial value of cloud optical thickness,
+  ! needed for the diagnostics of the aerosol indirect
+  ! radiative forcing (see radlwsw)
+  ! re------output-R-Cloud droplet effective radius multiplied by fl [um]
+  ! fl------output-R-Denominator to re, introduced to avoid problems in
+  ! the averaging of the output. fl is the fraction of liquid
+  ! water clouds within a grid cell
+
+  ! pcltau--output-R-epaisseur optique des nuages
+  ! pclemi--output-R-emissivite des nuages (0 a 1)
+  ! ======================================================================
+
+  include "YOMCST.h"
+  include "nuage.h" ! JBM 3/14
+  include "clesphys.h"
+
+  REAL paprs(klon, klev+1), pplay(klon, klev)
+  REAL t(klon, klev)
+
+  REAL pclc(klon, klev)
+  REAL pqlwp(klon, klev), picefra(klon,klev)
+  REAL pcltau(klon, klev), pclemi(klon, klev)
+
+  REAL pct(klon), pctlwp(klon), pch(klon), pcl(klon), pcm(klon)
+  REAL distcltop(klon,klev)
+  REAL temp_cltop(klon,klev)
+  LOGICAL lo
+
+  REAL cetahb, cetamb
+  PARAMETER (cetahb=0.45, cetamb=0.80)
+
+  INTEGER i, k
+  REAL zflwp, zradef, zfice(klon), zmsac
+
+  REAL radius, rad_chaud
+! JBM (3/14) parameters already defined in nuage.h:
+! REAL rad_froid, rad_chau1, rad_chau2
+! PARAMETER (rad_chau1=13.0, rad_chau2=9.0, rad_froid=35.0)
+  ! cc      PARAMETER (rad_chaud=15.0, rad_froid=35.0)
+  ! sintex initial      PARAMETER (rad_chaud=10.0, rad_froid=30.0)
+  REAL coef, coef_froi, coef_chau
+  PARAMETER (coef_chau=0.13, coef_froi=0.09)
+  REAL seuil_neb
+  PARAMETER (seuil_neb=0.001)
+! JBM (3/14) nexpo is replaced by exposant_glace
+! REAL nexpo ! exponentiel pour glace/eau
+! PARAMETER (nexpo=6.)
+  REAL, PARAMETER :: t_glace_min_old = 258.
+  INTEGER, PARAMETER :: exposant_glace_old = 6
+
+
+  ! jq for the aerosol indirect effect
+  ! jq introduced by Johannes Quaas (quaas@lmd.jussieu.fr), 27/11/2003
+  ! jq
+  LOGICAL ok_aie ! Apply AIE or not?
+
+  REAL mass_solu_aero(klon, klev) ! total mass concentration for all soluble aerosols[ug m-3]
+  REAL mass_solu_aero_pi(klon, klev) ! - " - pre-industrial value
+  REAL cdnc(klon, klev) ! cloud droplet number concentration [m-3]
+  REAL re(klon, klev) ! cloud droplet effective radius [um]
+  REAL cdnc_pi(klon, klev) ! cloud droplet number concentration [m-3] (pi value)
+  REAL re_pi(klon, klev) ! cloud droplet effective radius [um] (pi value)
+
+  REAL fl(klon, klev) ! xliq * rneb (denominator to re; fraction of liquid water clouds
+  ! within the grid cell)
+
+  REAL bl95_b0, bl95_b1 ! Parameter in B&L 95-Formula
+
+  REAL cldtaupi(klon, klev) ! pre-industrial cloud opt thickness for diag
+  REAl dzfice(klon)
+  ! jq-end
+
+  ! cc      PARAMETER (nexpo=1)
+
+  ! Calculer l'epaisseur optique et l'emmissivite des nuages
+
+  DO k = 1, klev
+     IF (iflag_t_glace.EQ.0) THEN
+       DO i = 1, klon
+        zfice(i) = 1.0 - (t(i,k)-t_glace_min_old)/(273.13-t_glace_min_old)
+        zfice(i) = min(max(zfice(i),0.0), 1.0)
+        zfice(i) = zfice(i)**exposant_glace_old
+       ENDDO
+     ELSE ! of IF (iflag_t_glace.EQ.0)
+! JBM: icefrac_lsc is now a function contained in icefrac_lsc_mod
+!       zfice(i) = icefrac_lsc(t(i,k), t_glace_min, &
+!                           t_glace_max, exposant_glace)
+        IF (ok_new_lscp) THEN
+            CALL icefrac_lscp(klon,t(:,k),iflag_ice_thermo,distcltop(:,k),temp_cltop(:,k),zfice(:),dzfice(:))
+        ELSE
+            CALL icefrac_lsc(klon,t(:,k),pplay(:,k)/paprs(:,1),zfice(:))
+
+        ENDIF
+
+    IF (ok_new_lscp .AND. ok_icefra_lscp) THEN
+    ! EV: take the ice fraction directly from the lscp code
+    ! consistent only for non convective grid points
+    ! critical for mixed phase clouds
+        DO i=1,klon
+        IF (.NOT. ptconv(i,k)) THEN
+           zfice(i)=picefra(i,k)
+        ENDIF
+        ENDDO
+    ENDIF 
+
+
+     ENDIF
+
+    DO i = 1, klon
+      rad_chaud = rad_chau1
+      IF (k<=3) rad_chaud = rad_chau2
+
+      pclc(i, k) = max(pclc(i,k), seuil_neb)
+      zflwp = 1000.*pqlwp(i, k)/rg/pclc(i, k)*(paprs(i,k)-paprs(i,k+1))
+
+      IF (ok_aie) THEN
+          ! Formula "D" of Boucher and Lohmann, Tellus, 1995
+          !
+        cdnc(i, k) = 10.**(bl95_b0+bl95_b1*log(max(mass_solu_aero(i,k), &
+          1.E-4))/log(10.))*1.E6 !-m-3
+          ! Cloud droplet number concentration (CDNC) is restricted
+          ! to be within [20, 1000 cm^3]
+          !
+        cdnc(i, k) = min(1000.E6, max(20.E6,cdnc(i,k)))
+        cdnc_pi(i, k) = 10.**(bl95_b0+bl95_b1*log(max(mass_solu_aero_pi(i,k), &
+          1.E-4))/log(10.))*1.E6 !-m-3
+        cdnc_pi(i, k) = min(1000.E6, max(20.E6,cdnc_pi(i,k)))
+          !
+          !
+          ! air density: pplay(i,k) / (RD * zT(i,k))
+          ! factor 1.1: derive effective radius from volume-mean radius
+          ! factor 1000 is the water density
+          ! _chaud means that this is the CDR for liquid water clouds
+          !
+        rad_chaud = 1.1*((pqlwp(i,k)*pplay(i,k)/(rd*t(i,k)))/(4./3.*rpi*1000. &
+          *cdnc(i,k)))**(1./3.)
+          !
+          ! Convert to um. CDR shall be at least 3 um.
+          !
+        rad_chaud = max(rad_chaud*1.E6, 3.)
+
+          ! For output diagnostics
+          !
+          ! Cloud droplet effective radius [um]
+          !
+          ! we multiply here with f * xl (fraction of liquid water
+          ! clouds in the grid cell) to avoid problems in the
+          ! averaging of the output.
+          ! In the output of IOIPSL, derive the real cloud droplet
+          ! effective radius as re/fl
+          !
+        fl(i, k) = pclc(i, k)*(1.-zfice(i))
+        re(i, k) = rad_chaud*fl(i, k)
+
+          ! Pre-industrial cloud opt thickness
+          !
+          ! "radius" is calculated as rad_chaud above (plus the
+          ! ice cloud contribution) but using cdnc_pi instead of
+          ! cdnc.
+        radius = max(1.1E6*((pqlwp(i,k)*pplay(i,k)/(rd*t(i,k)))/(4./3.*rpi* &
+          1000.*cdnc_pi(i,k)))**(1./3.), 3.)*(1.-zfice(i)) + rad_froid*zfice(i)
+        cldtaupi(i, k) = 3.0/2.0*zflwp/radius
+      END IF ! ok_aie
+
+      radius = rad_chaud*(1.-zfice(i)) + rad_froid*zfice(i)
+      coef = coef_chau*(1.-zfice(i)) + coef_froi*zfice(i)
+      pcltau(i, k) = 3.0/2.0*zflwp/radius
+      pclemi(i, k) = 1.0 - exp(-coef*zflwp)
+      lo = (pclc(i,k)<=seuil_neb)
+      IF (lo) pclc(i, k) = 0.0
+      IF (lo) pcltau(i, k) = 0.0
+      IF (lo) pclemi(i, k) = 0.0
+
+      IF (.NOT. ok_aie) cldtaupi(i, k) = pcltau(i, k)
+    END DO
+  END DO
+  ! cc      DO k = 1, klev
+  ! cc      DO i = 1, klon
+  ! cc         t(i,k) = t(i,k)
+  ! cc         pclc(i,k) = MAX( 1.e-5 , pclc(i,k) )
+  ! cc         lo = pclc(i,k) .GT. (2.*1.e-5)
+  ! cc         zflwp = pqlwp(i,k)*1000.*(paprs(i,k)-paprs(i,k+1))
+  ! cc     .          /(rg*pclc(i,k))
+  ! cc         zradef = 10.0 + (1.-sigs(k))*45.0
+  ! cc         pcltau(i,k) = 1.5 * zflwp / zradef
+  ! cc         zfice=1.0-MIN(MAX((t(i,k)-263.)/(273.-263.),0.0),1.0)
+  ! cc         zmsac = 0.13*(1.0-zfice) + 0.08*zfice
+  ! cc         pclemi(i,k) = 1.-EXP(-zmsac*zflwp)
+  ! cc         if (.NOT.lo) pclc(i,k) = 0.0
+  ! cc         if (.NOT.lo) pcltau(i,k) = 0.0
+  ! cc         if (.NOT.lo) pclemi(i,k) = 0.0
+  ! cc      ENDDO
+  ! cc      ENDDO
+  ! ccccc      print*, 'pas de nuage dans le rayonnement'
+  ! ccccc      DO k = 1, klev
+  ! ccccc      DO i = 1, klon
+  ! ccccc         pclc(i,k) = 0.0
+  ! ccccc         pcltau(i,k) = 0.0
+  ! ccccc         pclemi(i,k) = 0.0
+  ! ccccc      ENDDO
+  ! ccccc      ENDDO
+
+  ! COMPUTE CLOUD LIQUID PATH AND TOTAL CLOUDINESS
+
+  DO i = 1, klon
+    pct(i) = 1.0
+    pch(i) = 1.0
+    pcm(i) = 1.0
+    pcl(i) = 1.0
+    pctlwp(i) = 0.0
+  END DO
+
+  DO k = klev, 1, -1
+    DO i = 1, klon
+      pctlwp(i) = pctlwp(i) + pqlwp(i, k)*(paprs(i,k)-paprs(i,k+1))/rg
+      pct(i) = pct(i)*(1.0-pclc(i,k))
+      IF (pplay(i,k)<=cetahb*paprs(i,1)) pch(i) = pch(i)*(1.0-pclc(i,k))
+      IF (pplay(i,k)>cetahb*paprs(i,1) .AND. pplay(i,k)<=cetamb*paprs(i,1)) &
+        pcm(i) = pcm(i)*(1.0-pclc(i,k))
+      IF (pplay(i,k)>cetamb*paprs(i,1)) pcl(i) = pcl(i)*(1.0-pclc(i,k))
+    END DO
+  END DO
+
+  DO i = 1, klon
+    pct(i) = 1. - pct(i)
+    pch(i) = 1. - pch(i)
+    pcm(i) = 1. - pcm(i)
+    pcl(i) = 1. - pcl(i)
+  END DO
+
+  RETURN
+END SUBROUTINE nuage
+SUBROUTINE diagcld1(paprs, pplay, rain, snow, kbot, ktop, diafra, dialiq)
+  USE dimphy
+  IMPLICIT NONE
+
+  ! Laurent Li (LMD/CNRS), le 12 octobre 1998
+  ! (adaptation du code ECMWF)
+
+  ! Dans certains cas, le schema pronostique des nuages n'est
+  ! pas suffisament performant. On a donc besoin de diagnostiquer
+  ! ces nuages. Je dois avouer que c'est une frustration.
+
+  include "YOMCST.h"
+
+  ! Arguments d'entree:
+  REAL paprs(klon, klev+1) ! pression (Pa) a inter-couche
+  REAL pplay(klon, klev) ! pression (Pa) au milieu de couche
+  REAL t(klon, klev) ! temperature (K)
+  REAL q(klon, klev) ! humidite specifique (Kg/Kg)
+  REAL rain(klon) ! pluie convective (kg/m2/s)
+  REAL snow(klon) ! neige convective (kg/m2/s)
+  INTEGER ktop(klon) ! sommet de la convection
+  INTEGER kbot(klon) ! bas de la convection
+
+  ! Arguments de sortie:
+  REAL diafra(klon, klev) ! fraction nuageuse diagnostiquee
+  REAL dialiq(klon, klev) ! eau liquide nuageuse
+
+  ! Constantes ajustables:
+  REAL canva, canvb, canvh
+  PARAMETER (canva=2.0, canvb=0.3, canvh=0.4)
+  REAL cca, ccb, ccc
+  PARAMETER (cca=0.125, ccb=1.5, ccc=0.8)
+  REAL ccfct, ccscal
+  PARAMETER (ccfct=0.400)
+  PARAMETER (ccscal=1.0E+11)
+  REAL cetahb, cetamb
+  PARAMETER (cetahb=0.45, cetamb=0.80)
+  REAL cclwmr
+  PARAMETER (cclwmr=1.E-04)
+  REAL zepscr
+  PARAMETER (zepscr=1.0E-10)
+
+  ! Variables locales:
+  INTEGER i, k
+  REAL zcc(klon)
+
+  ! Initialisation:
+
+  DO k = 1, klev
+    DO i = 1, klon
+      diafra(i, k) = 0.0
+      dialiq(i, k) = 0.0
+    END DO
+  END DO
+
+  DO i = 1, klon ! Calculer la fraction nuageuse
+    zcc(i) = 0.0
+    IF ((rain(i)+snow(i))>0.) THEN
+      zcc(i) = cca*log(max(zepscr,(rain(i)+snow(i))*ccscal)) - ccb
+      zcc(i) = min(ccc, max(0.0,zcc(i)))
+    END IF
+  END DO
+
+  DO i = 1, klon ! pour traiter les enclumes
+    diafra(i, ktop(i)) = max(diafra(i,ktop(i)), zcc(i)*ccfct)
+    IF ((zcc(i)>=canvh) .AND. (pplay(i,ktop(i))<=cetahb*paprs(i, &
+      1))) diafra(i, ktop(i)) = max(diafra(i,ktop(i)), max(zcc( &
+      i)*ccfct,canva*(zcc(i)-canvb)))
+    dialiq(i, ktop(i)) = cclwmr*diafra(i, ktop(i))
+  END DO
+
+  DO k = 1, klev ! nuages convectifs (sauf enclumes)
+    DO i = 1, klon
+      IF (k<ktop(i) .AND. k>=kbot(i)) THEN
+        diafra(i, k) = max(diafra(i,k), zcc(i)*ccfct)
+        dialiq(i, k) = cclwmr*diafra(i, k)
+      END IF
+    END DO
+  END DO
+
+  RETURN
+END SUBROUTINE diagcld1
+SUBROUTINE diagcld2(paprs, pplay, t, q, diafra, dialiq)
+  USE dimphy
+  IMPLICIT NONE
+
+  include "YOMCST.h"
+
+  ! Arguments d'entree:
+  REAL paprs(klon, klev+1) ! pression (Pa) a inter-couche
+  REAL pplay(klon, klev) ! pression (Pa) au milieu de couche
+  REAL t(klon, klev) ! temperature (K)
+  REAL q(klon, klev) ! humidite specifique (Kg/Kg)
+
+  ! Arguments de sortie:
+  REAL diafra(klon, klev) ! fraction nuageuse diagnostiquee
+  REAL dialiq(klon, klev) ! eau liquide nuageuse
+
+  REAL cetamb
+  PARAMETER (cetamb=0.80)
+  REAL cloia, cloib, cloic, cloid
+  PARAMETER (cloia=1.0E+02, cloib=-10.00, cloic=-0.6, cloid=5.0)
+  ! cc      PARAMETER (CLOIA=1.0E+02, CLOIB=-10.00, CLOIC=-0.9, CLOID=5.0)
+  REAL rgammas
+  PARAMETER (rgammas=0.05)
+  REAL crhl
+  PARAMETER (crhl=0.15)
+  ! cc      PARAMETER (CRHL=0.70)
+  REAL t_coup
+  PARAMETER (t_coup=234.0)
+
+  ! Variables locales:
+  INTEGER i, k, kb, invb(klon)
+  REAL zqs, zrhb, zcll, zdthmin(klon), zdthdp
+  REAL zdelta, zcor
+
+  ! Fonctions thermodynamiques:
+  include "YOETHF.h"
+  include "FCTTRE.h"
+
+  ! Initialisation:
+
+  DO k = 1, klev
+    DO i = 1, klon
+      diafra(i, k) = 0.0
+      dialiq(i, k) = 0.0
+    END DO
+  END DO
+
+  DO i = 1, klon
+    invb(i) = klev
+    zdthmin(i) = 0.0
+  END DO
+
+  DO k = 2, klev/2 - 1
+    DO i = 1, klon
+      zdthdp = (t(i,k)-t(i,k+1))/(pplay(i,k)-pplay(i,k+1)) - &
+        rd*0.5*(t(i,k)+t(i,k+1))/rcpd/paprs(i, k+1)
+      zdthdp = zdthdp*cloia
+      IF (pplay(i,k)>cetamb*paprs(i,1) .AND. zdthdp<zdthmin(i)) THEN
+        zdthmin(i) = zdthdp
+        invb(i) = k
+      END IF
+    END DO
+  END DO
+
+  DO i = 1, klon
+    kb = invb(i)
+    IF (thermcep) THEN
+      zdelta = max(0., sign(1.,rtt-t(i,kb)))
+      zqs = r2es*foeew(t(i,kb), zdelta)/pplay(i, kb)
+      zqs = min(0.5, zqs)
+      zcor = 1./(1.-retv*zqs)
+      zqs = zqs*zcor
+    ELSE
+      IF (t(i,kb)<t_coup) THEN
+        zqs = qsats(t(i,kb))/pplay(i, kb)
+      ELSE
+        zqs = qsatl(t(i,kb))/pplay(i, kb)
+      END IF
+    END IF
+    zcll = cloib*zdthmin(i) + cloic
+    zcll = min(1.0, max(0.0,zcll))
+    zrhb = q(i, kb)/zqs
+    IF (zcll>0.0 .AND. zrhb<crhl) zcll = zcll*(1.-(crhl-zrhb)*cloid)
+    zcll = min(1.0, max(0.0,zcll))
+    diafra(i, kb) = max(diafra(i,kb), zcll)
+    dialiq(i, kb) = diafra(i, kb)*rgammas*zqs
+  END DO
+
+  RETURN
+END SUBROUTINE diagcld2
Index: DZ6/trunk/libf/phylmd/o3_chem_m.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/o3_chem_m.F90	(revision 5267)
+++ 	(revision )
@@ -1,171 +1,0 @@
-! $Id$
-module o3_chem_m
-
-  IMPLICIT none
-
-  private o3_prod
-
-contains
-
-  subroutine o3_chem(julien, gmtime, t_seri, zmasse, pdtphys, rlat, rlon, q)
-
-    ! This procedure evolves the ozone mass fraction through a time
-    ! step taking only chemistry into account.
-
-    ! All the 2-dimensional arrays are on the partial "physics" grid.
-    ! Their shape is "(/klon, nbp_lev/)".
-    ! Index "(i, :)" is for longitude "rlon(i)", latitude "rlat(i)".
-
-    use assert_m, only: assert
-    use dimphy, only: klon
-    use regr_pr_comb_coefoz_m, only: c_Mob, a4_mass, a2, r_het_interm
-    use mod_grid_phy_lmdz, only: nbp_lev
-    use nrtype, only: pi
-
-    integer, intent(in):: julien ! jour julien, 1 <= julien <= 360
-    real, intent(in):: gmtime ! heure de la journée en fraction de jour
-    real, intent(in):: t_seri(:, :) ! (klon, nbp_lev) temperature, in K
-
-    real, intent(in):: zmasse(:, :) ! (klon, nbp_lev)
-    ! (column-density of mass of air in a cell, in kg m-2)
-    ! "zmasse(:, k)" is for layer "k".)
-
-    real, intent(in):: pdtphys ! time step for physics, in s
-
-    REAL, intent(in):: rlat(:), rlon(:)
-    ! (longitude and latitude of each horizontal position, in degrees)
-
-    real, intent(inout):: q(:, :) ! (klon, nbp_lev) mass fraction of ozone
-    ! "q(:, k)" is at middle of layer "k".)
-
-    ! Variables local to the procedure:
-    ! (for "pi")
-    integer k
-
-    real c(klon, nbp_lev)
-    ! (constant term during a time step in the net mass production
-    ! rate of ozone by chemistry, per unit mass of air, in s-1)
-    ! "c(:, k)" is at middle of layer "k".)
-
-    real b(klon, nbp_lev)
-    ! (coefficient of "q" in the net mass production
-    ! rate of ozone by chemistry, per unit mass of air, in s-1)
-    ! "b(:, k)" is at middle of layer "k".)
-
-    real dq_o3_chem(klon, nbp_lev)
-    ! (variation of ozone mass fraction due to chemistry during a time step)
-    ! "dq_o3_chem(:, k)" is at middle of layer "k".)
-
-    real earth_long
-    ! (longitude vraie de la Terre dans son orbite solaire, par
-    ! rapport au point vernal (21 mars), en degrés)
-
-    real pmu0(klon) ! mean of cosine of solar zenith angle during "pdtphys"
-    real trash1
-    real trash2(klon)
-
-    !-------------------------------------------------------------
-
-    call assert(klon == (/size(q, 1), size(t_seri, 1), size(zmasse, 1), &
-         size(rlat), size(rlon)/), "o3_chem klon")
-    call assert(nbp_lev == (/size(q, 2), size(t_seri, 2), size(zmasse, 2)/), &
-         "o3_chem nbp_lev")
-
-    c = c_Mob + a4_mass * t_seri
-
-    ! Compute coefficient "b":
-
-    ! Heterogeneous chemistry is only at low temperature:
-    where (t_seri < 195.)
-       b = r_het_interm
-    elsewhere
-       b = 0.
-    end where
-
-    ! Heterogeneous chemistry is only during daytime:
-    call orbite(real(julien), earth_long, trash1)
-    call zenang(earth_long, gmtime, 0., pdtphys, rlat, rlon, pmu0, trash2)
-    forall (k = 1: nbp_lev)
-       where (pmu0 <= cos(87. / 180. * pi)) b(:, k) = 0.
-    end forall
-
-    b = b + a2
-
-    ! Midpoint method:
-
-    ! Trial step to the midpoint:
-    dq_o3_chem = o3_prod(q, zmasse, c, b) * pdtphys  / 2
-    ! "Real" step across the whole interval:
-    dq_o3_chem = o3_prod(q + dq_o3_chem, zmasse, c, b) * pdtphys
-    q = q + dq_o3_chem
-
-    ! Confine the mass fraction:
-    q = min(max(q, 0.), .01)
-
-  end subroutine o3_chem
-
-  !*************************************************
-
-  function o3_prod(q, zmasse, c, b)
-
-    ! This function computes the production rate of ozone by chemistry.
-
-    ! All the 2-dimensional arrays are on the partial "physics" grid.
-    ! Their shape is "(/klon, nbp_lev/)".
-    ! Index "(i, :)" is for longitude "rlon(i)", latitude "rlat(i)".
-
-    use regr_pr_comb_coefoz_m, only: a6_mass
-    use assert_m, only: assert
-    use dimphy, only: klon
-    use mod_grid_phy_lmdz, only: nbp_lev
-
-    real, intent(in):: q(:, :) ! mass fraction of ozone
-    ! "q(:, k)" is at middle of layer "k".)
-
-    real, intent(in):: zmasse(:, :)
-    ! (column-density of mass of air in a layer, in kg m-2)
-    ! ("zmasse(:, k)" is for layer "k".)
-
-    real, intent(in):: c(:, :)
-    ! (constant term during a time step in the net mass production
-    ! rate of ozone by chemistry, per unit mass of air, in s-1)
-    ! "c(:, k)" is at middle of layer "k".)
-
-    real, intent(in):: b(:, :)
-    ! (coefficient of "q" in the net mass production rate of ozone by
-    ! chemistry, per unit mass of air, in s-1)
-    ! ("b(:, k)" is at middle of layer "k".)
-
-    real o3_prod(klon, nbp_lev)
-    ! (net mass production rate of ozone by chemistry, per unit mass
-    ! of air, in s-1)
-    ! ("o3_prod(:, k)" is at middle of layer "k".)
-
-    ! Variables local to the procedure:
-
-    real sigma_mass(klon, nbp_lev)
-    ! (mass column-density of ozone above point, in kg m-2)
-    ! ("sigma_mass(:, k)" is at middle of layer "k".)
-
-    integer k
-
-    !-------------------------------------------------------------------
-
-    call assert(klon == (/size(q, 1), size(zmasse, 1), size(c, 1), &
-         size(b, 1)/), "o3_prod 1")
-    call assert(nbp_lev == (/size(q, 2), size(zmasse, 2), size(c, 2), &
-         size(b, 2)/), "o3_prod 2")
-
-    ! Compute the column-density above the base of layer
-    ! "k", and, as a first approximation, take it as column-density
-    ! above the middle of layer "k":
-    sigma_mass(:, nbp_lev) = zmasse(:, nbp_lev) * q(:, nbp_lev) ! top layer
-    do k =  nbp_lev - 1, 1, -1
-       sigma_mass(:, k) = sigma_mass(:, k+1) + zmasse(:, k) * q(:, k)
-    end do
-
-    o3_prod = c + b * q + a6_mass * sigma_mass
-
-  end function o3_prod
-
-end module o3_chem_m
Index: /LMDZ6/trunk/libf/phylmd/o3_chem_m.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/o3_chem_m.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/o3_chem_m.f90	(revision 5268)
@@ -0,0 +1,171 @@
+! $Id$
+module o3_chem_m
+
+  IMPLICIT none
+
+  private o3_prod
+
+contains
+
+  subroutine o3_chem(julien, gmtime, t_seri, zmasse, pdtphys, rlat, rlon, q)
+
+    ! This procedure evolves the ozone mass fraction through a time
+    ! step taking only chemistry into account.
+
+    ! All the 2-dimensional arrays are on the partial "physics" grid.
+    ! Their shape is "(/klon, nbp_lev/)".
+    ! Index "(i, :)" is for longitude "rlon(i)", latitude "rlat(i)".
+
+    use assert_m, only: assert
+    use dimphy, only: klon
+    use regr_pr_comb_coefoz_m, only: c_Mob, a4_mass, a2, r_het_interm
+    use mod_grid_phy_lmdz, only: nbp_lev
+    use nrtype, only: pi
+
+    integer, intent(in):: julien ! jour julien, 1 <= julien <= 360
+    real, intent(in):: gmtime ! heure de la journée en fraction de jour
+    real, intent(in):: t_seri(:, :) ! (klon, nbp_lev) temperature, in K
+
+    real, intent(in):: zmasse(:, :) ! (klon, nbp_lev)
+    ! (column-density of mass of air in a cell, in kg m-2)
+    ! "zmasse(:, k)" is for layer "k".)
+
+    real, intent(in):: pdtphys ! time step for physics, in s
+
+    REAL, intent(in):: rlat(:), rlon(:)
+    ! (longitude and latitude of each horizontal position, in degrees)
+
+    real, intent(inout):: q(:, :) ! (klon, nbp_lev) mass fraction of ozone
+    ! "q(:, k)" is at middle of layer "k".)
+
+    ! Variables local to the procedure:
+    ! (for "pi")
+    integer k
+
+    real c(klon, nbp_lev)
+    ! (constant term during a time step in the net mass production
+    ! rate of ozone by chemistry, per unit mass of air, in s-1)
+    ! "c(:, k)" is at middle of layer "k".)
+
+    real b(klon, nbp_lev)
+    ! (coefficient of "q" in the net mass production
+    ! rate of ozone by chemistry, per unit mass of air, in s-1)
+    ! "b(:, k)" is at middle of layer "k".)
+
+    real dq_o3_chem(klon, nbp_lev)
+    ! (variation of ozone mass fraction due to chemistry during a time step)
+    ! "dq_o3_chem(:, k)" is at middle of layer "k".)
+
+    real earth_long
+    ! (longitude vraie de la Terre dans son orbite solaire, par
+    ! rapport au point vernal (21 mars), en degrés)
+
+    real pmu0(klon) ! mean of cosine of solar zenith angle during "pdtphys"
+    real trash1
+    real trash2(klon)
+
+    !-------------------------------------------------------------
+
+    call assert(klon == (/size(q, 1), size(t_seri, 1), size(zmasse, 1), &
+         size(rlat), size(rlon)/), "o3_chem klon")
+    call assert(nbp_lev == (/size(q, 2), size(t_seri, 2), size(zmasse, 2)/), &
+         "o3_chem nbp_lev")
+
+    c = c_Mob + a4_mass * t_seri
+
+    ! Compute coefficient "b":
+
+    ! Heterogeneous chemistry is only at low temperature:
+    where (t_seri < 195.)
+       b = r_het_interm
+    elsewhere
+       b = 0.
+    end where
+
+    ! Heterogeneous chemistry is only during daytime:
+    call orbite(real(julien), earth_long, trash1)
+    call zenang(earth_long, gmtime, 0., pdtphys, rlat, rlon, pmu0, trash2)
+    forall (k = 1: nbp_lev)
+       where (pmu0 <= cos(87. / 180. * pi)) b(:, k) = 0.
+    end forall
+
+    b = b + a2
+
+    ! Midpoint method:
+
+    ! Trial step to the midpoint:
+    dq_o3_chem = o3_prod(q, zmasse, c, b) * pdtphys  / 2
+    ! "Real" step across the whole interval:
+    dq_o3_chem = o3_prod(q + dq_o3_chem, zmasse, c, b) * pdtphys
+    q = q + dq_o3_chem
+
+    ! Confine the mass fraction:
+    q = min(max(q, 0.), .01)
+
+  end subroutine o3_chem
+
+  !*************************************************
+
+  function o3_prod(q, zmasse, c, b)
+
+    ! This function computes the production rate of ozone by chemistry.
+
+    ! All the 2-dimensional arrays are on the partial "physics" grid.
+    ! Their shape is "(/klon, nbp_lev/)".
+    ! Index "(i, :)" is for longitude "rlon(i)", latitude "rlat(i)".
+
+    use regr_pr_comb_coefoz_m, only: a6_mass
+    use assert_m, only: assert
+    use dimphy, only: klon
+    use mod_grid_phy_lmdz, only: nbp_lev
+
+    real, intent(in):: q(:, :) ! mass fraction of ozone
+    ! "q(:, k)" is at middle of layer "k".)
+
+    real, intent(in):: zmasse(:, :)
+    ! (column-density of mass of air in a layer, in kg m-2)
+    ! ("zmasse(:, k)" is for layer "k".)
+
+    real, intent(in):: c(:, :)
+    ! (constant term during a time step in the net mass production
+    ! rate of ozone by chemistry, per unit mass of air, in s-1)
+    ! "c(:, k)" is at middle of layer "k".)
+
+    real, intent(in):: b(:, :)
+    ! (coefficient of "q" in the net mass production rate of ozone by
+    ! chemistry, per unit mass of air, in s-1)
+    ! ("b(:, k)" is at middle of layer "k".)
+
+    real o3_prod(klon, nbp_lev)
+    ! (net mass production rate of ozone by chemistry, per unit mass
+    ! of air, in s-1)
+    ! ("o3_prod(:, k)" is at middle of layer "k".)
+
+    ! Variables local to the procedure:
+
+    real sigma_mass(klon, nbp_lev)
+    ! (mass column-density of ozone above point, in kg m-2)
+    ! ("sigma_mass(:, k)" is at middle of layer "k".)
+
+    integer k
+
+    !-------------------------------------------------------------------
+
+    call assert(klon == (/size(q, 1), size(zmasse, 1), size(c, 1), &
+         size(b, 1)/), "o3_prod 1")
+    call assert(nbp_lev == (/size(q, 2), size(zmasse, 2), size(c, 2), &
+         size(b, 2)/), "o3_prod 2")
+
+    ! Compute the column-density above the base of layer
+    ! "k", and, as a first approximation, take it as column-density
+    ! above the middle of layer "k":
+    sigma_mass(:, nbp_lev) = zmasse(:, nbp_lev) * q(:, nbp_lev) ! top layer
+    do k =  nbp_lev - 1, 1, -1
+       sigma_mass(:, k) = sigma_mass(:, k+1) + zmasse(:, k) * q(:, k)
+    end do
+
+    o3_prod = c + b * q + a6_mass * sigma_mass
+
+  end function o3_prod
+
+end module o3_chem_m
Index: DZ6/trunk/libf/phylmd/o3cm.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/o3cm.F90	(revision 5267)
+++ 	(revision )
@@ -1,68 +1,0 @@
-
-! $Id$
-
-SUBROUTINE o3cm(amb, bmb, sortie, ntab)
-  IMPLICIT NONE
-  ! ======================================================================
-  ! Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818
-  ! Objet: Ce programme calcule le contenu en ozone "sortie"
-  ! (unite: cm.atm) entre deux niveaux "amb" et "bmb" (unite: mb)
-  ! "ntab" est le nombre d'intervalles pour l'integration, sa
-  ! valeur depend bien sur de l'epaisseur de la couche et de
-  ! la precision qu'on souhaite a obtenir
-  ! ======================================================================
-  REAL amb, bmb, sortie
-  INTEGER ntab
-  ! ======================================================================
-  INTEGER n
-  REAL xtab(500), xa, xb, ya, yb, xincr
-  ! ======================================================================
-  EXTERNAL mbtozm
-  CHARACTER (LEN=20) :: modname = ''
-  CHARACTER (LEN=80) :: abort_message
-  ! ======================================================================
-  ! la fonction en ligne w(x) donne le profil de l'ozone en fonction
-  ! de l'altitude (unite: cm.atm / km)
-  ! (Green 1964, Appl. Opt. 3: 203-208)
-  REAL wp, xp, h, x, w, con
-  PARAMETER (wp=0.218, xp=23.25, h=4.63, con=1.0)
-
-  w(x) = wp/h*exp((x-xp)/h)/(con+exp((x-xp)/h))**2
-  ! ======================================================================
-  IF (ntab>499) THEN
-    abort_message = 'BIG ntab'
-    CALL abort_physic(modname, abort_message, 1)
-  END IF
-  xincr = (bmb-amb)/real(ntab)
-  xtab(1) = amb
-  DO n = 2, ntab
-    xtab(n) = xtab(n-1) + xincr
-  END DO
-  xtab(ntab+1) = bmb
-  sortie = 0.0
-  DO n = 1, ntab
-    CALL mbtozm(xtab(n), xa)
-    CALL mbtozm(xtab(n+1), xb)
-    xa = xa/1000.
-    xb = xb/1000.
-    ya = w(xa)
-    yb = w(xb)
-    sortie = sortie + (ya+yb)/2.0*abs(xb-xa)
-  END DO
-  RETURN
-END SUBROUTINE o3cm
-SUBROUTINE mbtozm(rmb, zm)
-  IMPLICIT NONE
-  ! ======================================================================
-  ! Auteur(s): Z.X. Li (LMD/CNRS)
-  ! Objet: transformer une hauteur de mb (rmb) en metre (zm)
-  ! ======================================================================
-  REAL rmb, zm
-  ! ======================================================================
-  REAL gama, tzero, pzero, g, r
-  PARAMETER (gama=6.5E-3, tzero=288., pzero=1013.25)
-  PARAMETER (g=9.81, r=287.0)
-
-  zm = tzero/gama*(1.-(rmb/pzero)**(r*gama/g))
-  RETURN
-END SUBROUTINE mbtozm
Index: /LMDZ6/trunk/libf/phylmd/o3cm.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/o3cm.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/o3cm.f90	(revision 5268)
@@ -0,0 +1,68 @@
+
+! $Id$
+
+SUBROUTINE o3cm(amb, bmb, sortie, ntab)
+  IMPLICIT NONE
+  ! ======================================================================
+  ! Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818
+  ! Objet: Ce programme calcule le contenu en ozone "sortie"
+  ! (unite: cm.atm) entre deux niveaux "amb" et "bmb" (unite: mb)
+  ! "ntab" est le nombre d'intervalles pour l'integration, sa
+  ! valeur depend bien sur de l'epaisseur de la couche et de
+  ! la precision qu'on souhaite a obtenir
+  ! ======================================================================
+  REAL amb, bmb, sortie
+  INTEGER ntab
+  ! ======================================================================
+  INTEGER n
+  REAL xtab(500), xa, xb, ya, yb, xincr
+  ! ======================================================================
+  EXTERNAL mbtozm
+  CHARACTER (LEN=20) :: modname = ''
+  CHARACTER (LEN=80) :: abort_message
+  ! ======================================================================
+  ! la fonction en ligne w(x) donne le profil de l'ozone en fonction
+  ! de l'altitude (unite: cm.atm / km)
+  ! (Green 1964, Appl. Opt. 3: 203-208)
+  REAL wp, xp, h, x, w, con
+  PARAMETER (wp=0.218, xp=23.25, h=4.63, con=1.0)
+
+  w(x) = wp/h*exp((x-xp)/h)/(con+exp((x-xp)/h))**2
+  ! ======================================================================
+  IF (ntab>499) THEN
+    abort_message = 'BIG ntab'
+    CALL abort_physic(modname, abort_message, 1)
+  END IF
+  xincr = (bmb-amb)/real(ntab)
+  xtab(1) = amb
+  DO n = 2, ntab
+    xtab(n) = xtab(n-1) + xincr
+  END DO
+  xtab(ntab+1) = bmb
+  sortie = 0.0
+  DO n = 1, ntab
+    CALL mbtozm(xtab(n), xa)
+    CALL mbtozm(xtab(n+1), xb)
+    xa = xa/1000.
+    xb = xb/1000.
+    ya = w(xa)
+    yb = w(xb)
+    sortie = sortie + (ya+yb)/2.0*abs(xb-xa)
+  END DO
+  RETURN
+END SUBROUTINE o3cm
+SUBROUTINE mbtozm(rmb, zm)
+  IMPLICIT NONE
+  ! ======================================================================
+  ! Auteur(s): Z.X. Li (LMD/CNRS)
+  ! Objet: transformer une hauteur de mb (rmb) en metre (zm)
+  ! ======================================================================
+  REAL rmb, zm
+  ! ======================================================================
+  REAL gama, tzero, pzero, g, r
+  PARAMETER (gama=6.5E-3, tzero=288., pzero=1013.25)
+  PARAMETER (g=9.81, r=287.0)
+
+  zm = tzero/gama*(1.-(rmb/pzero)**(r*gama/g))
+  RETURN
+END SUBROUTINE mbtozm
Index: DZ6/trunk/libf/phylmd/ocean_albedo.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/ocean_albedo.F90	(revision 5267)
+++ 	(revision )
@@ -1,256 +1,0 @@
-!
-! $Id$
-!
-
-SUBROUTINE ocean_albedo(knon,zrmu0,knindex,pwind,SFRWL,alb_dir_new,alb_dif_new)
-!!
-!!****  *ALBEDO_RS14*  
-!!
-!!    PURPOSE
-!!    -------
-!!     computes the direct & diffuse albedo over open water
-!!     
-!!**  METHOD
-!!    ------
-!!
-!!    EXTERNAL
-!!    --------
-!!
-!!    IMPLICIT ARGUMENTS
-!!    ------------------ 
-!!      
-!!    REFERENCE
-!!    ---------
-!!      
-!!    AUTHOR
-!!    ------
-!!	R. Séférian           * Meteo-France *
-!!
-!!    MODIFICATIONS
-!!    -------------
-!!      Original    03/2014
-!!                  05/2014 R. Séférian & B. Decharme :: Adaptation to spectral
-!!                  computation for diffuse and direct albedo
-!!                  08/2014 S. Baek :: for wider wavelength range 200-4000nm and
-!!                  adaptation to LMDZ + whitecap effect by Koepke + chrolophyll
-!!                  map from climatology file
-!!                  10/2016 O. Boucher :: some optimisation following R.
-!!                  Seferian's work in the CNRM Model
-!!       
-!-------------------------------------------------------------------------------
-!
-!*           DECLARATIONS
-!            ------------
-!
-USE ocean_albedo_para
-USE dimphy
-USE phys_state_var_mod, ONLY : chl_con
-!
-!
-IMPLICIT NONE
-!
-!*      0.1    declarations of arguments
-!              -------------------------
-!
-include "clesphys.h"
-!
-INTEGER, INTENT(IN) :: knon
-INTEGER, DIMENSION(klon), INTENT(IN) :: knindex
-REAL, DIMENSION(klon), INTENT(IN) :: zrmu0         !--cos(SZA) on full vector
-REAL, DIMENSION(klon), INTENT(IN) :: pwind         !--wind speed on compressed vector
-REAL, DIMENSION(6),INTENT(IN) :: SFRWL
-REAL, DIMENSION(klon,nsw), INTENT(OUT) :: alb_dir_new, alb_dif_new
-!
-!*      0.2    declarations of local variables
-!              -------------------------
-!
-REAL, DIMENSION(klon)           :: ZCHL        ! surface chlorophyll
-REAL, DIMENSION(klon)           :: ZCOSZEN     ! Cosine of the zenith solar angle
-!
-INTEGER                         :: JWL, INU    ! indexes
-INTEGER                         :: JI
-REAL                            :: ZWL         ! input parameter: wavelength and diffuse/direct fraction of light
-REAL:: ZCHLABS, ZAW, ZBW, ZREFM, ZYLMD, ZUE, ZUE2 ! scalar computation variables
-!
-REAL, DIMENSION(klon) :: ZAP, ZXX2, ZR00, ZRR0, ZRRR               ! computation variables
-REAL, DIMENSION(klon) :: ZR22, ZR11DF                              ! computation variables
-REAL, DIMENSION(klon) :: ZBBP, ZNU, ZHB                            ! computation variables
-REAL, DIMENSION(klon) :: ZR11, ZRW, ZRWDF, ZRDF                    ! 4 components of the OSA
-REAL, DIMENSION(klon) :: ZSIG, ZFWC, ZWORK1, ZWORK2, ZWORK3
-! 
-!--initialisations-------------
-!
-
-IF (knon==0) RETURN ! A verifier pourquoi on en a besoin...
-
-alb_dir_new(:,:) = 0. 
-alb_dif_new(:,:) = 0. 
-!
-! Initialisation of chlorophyll content
-! ZCHL(:) = CHL_CON!0.05 ! averaged global values for surface chlorophyll
-IF (ok_chlorophyll) THEN
-  ZCHL(1:knon)=CHL_CON(knindex(1:knon))
-ELSE 
-  ZCHL(1:knon) = 0.05
-ENDIF
-
-! variables that do not depend on wavelengths
-! loop over the grid points
-! functions of chlorophyll content
-ZWORK1(1:knon)= EXP(LOG(ZCHL(1:knon))*0.65)
-ZWORK2(1:knon)= 0.416 * EXP(LOG(ZCHL(1:knon))*0.766)
-ZWORK3(1:knon)= LOG10(ZCHL(1:knon))
-! store the cosine of the solar zenith angle
-ZCOSZEN(1:knon) = zrmu0(knindex(1:knon))
-! Compute sigma derived from wind speed (Cox & Munk reflectance model)
-ZSIG(1:knon)=SQRT(0.003+0.00512*PWIND(1:knon))
-! original : correction for foam (Eq 16-17)
-! has to be update once we have information from wave model (discussion with G. Madec)
-ZFWC(1:knon)=3.97e-4*PWIND(1:knon)**1.59 ! Salisbury 2014 eq(2) at 37GHz, value in fraction
-!
-DO JWL=1,NNWL           ! loop over the wavelengths
-  !
-  !---------------------------------------------------------------------------------
-  ! 0- Compute baseline values
-  !---------------------------------------------------------------------------------
-    
-  ! Get refractive index for the correspoding wavelength
-  ZWL=XAKWL(JWL)      !!!--------- wavelength value
-  ZREFM= XAKREFM(JWL) !!!--------- refraction index value
-  
-  !---------------------------------------------------------------------------------
-  ! 1- Compute direct surface albedo (ZR11)
-  !---------------------------------------------------------------------------------
-  !
-  ZXX2(1:knon)=SQRT(1.0-(1.0-ZCOSZEN(1:knon)**2)/ZREFM**2)
-  ZRR0(1:knon)=0.50*(((ZXX2(1:knon)-ZREFM*ZCOSZEN(1:knon))/(ZXX2(1:knon)+ZREFM*ZCOSZEN(1:knon)))**2 +  & 
-               ((ZCOSZEN(1:knon)-ZREFM*ZXX2(1:knon))/(ZCOSZEN(1:knon)+ZREFM*ZXX2(1:knon)))**2)
-  ZRRR(1:knon)=0.50*(((ZXX2(1:knon)-1.34*ZCOSZEN(1:knon))/(ZXX2(1:knon)+1.34*ZCOSZEN(1:knon)))**2 + & 
-               ((ZCOSZEN(1:knon)-1.34*ZXX2(1:knon))/(ZCOSZEN(1:knon)+1.34*ZXX2(1:knon)))**2)
-  ZR11(1:knon)=ZRR0(1:knon)-(0.0152-1.7873*ZCOSZEN(1:knon)+6.8972*ZCOSZEN(1:knon)**2-8.5778*ZCOSZEN(1:knon)**3+ & 
-               4.071*ZSIG(1:knon)-7.6446*ZCOSZEN(1:knon)*ZSIG(1:knon)) *  & 
-               EXP(0.1643-7.8409*ZCOSZEN(1:knon)-3.5639*ZCOSZEN(1:knon)**2-2.3588*ZSIG(1:knon)+ & 
-               10.0538*ZCOSZEN(1:knon)*ZSIG(1:knon))*ZRR0(1:knon)/ZRRR(1:knon)
-  ! 
-  !---------------------------------------------------------------------------------
-  ! 2- Compute surface diffuse albedo (ZRDF)
-  !---------------------------------------------------------------------------------
-  ! Diffuse albedo from Jin et al., 2006 + estimation from diffuse fraction of
-  ! light (relying later on AOD). CNRM model has opted for Eq 5b
-  ZRDF(1:knon)=-0.1482-0.012*ZSIG(1:knon)+0.1609*ZREFM-0.0244*ZSIG(1:knon)*ZREFM ! surface diffuse (Eq 5a)
-  !!ZRDF(1:knon)=-0.1479+0.1502*ZREFM-0.0176*ZSIG(1:knon)*ZREFM   ! surface diffuse (Eq 5b) 
- 
-  !---------------------------------------------------------------------------------
-  ! *- Determine absorption and backscattering
-  ! coefficients to determine reflectance below the surface (Ro) once for all
-  !
-  ! *.1- Absorption by chlorophyll
-  ZCHLABS= XAKACHL(JWL) 
-  ! *.2- Absorption by seawater 
-  ZAW= XAKAW3(JWL) 
-  ! *.3- Backscattering by seawater
-  ZBW= XAKBW(JWL) 
-  ! *.4- Backscattering by chlorophyll
-  ZYLMD = EXP(0.014*(440.0-ZWL))
-  ZAP(1:knon) = 0.06*ZCHLABS*ZWORK1(1:knon) +0.2*(XAW440+0.06*ZWORK1(1:knon))*ZYLMD
-   
-!!  WHERE ( ZCHL(1:knon) > 0.02 )
-!!    ZNU(:)=MIN(0.0,0.5*(ZWORK3(:)-0.3))
-!!    ZBBP(:)=(0.002+0.01*(0.5-0.25*ZWORK3(:))*(ZWL/550.)**ZNU(:))*ZWORK2(:)
-!!  ELSEWHERE
-!!    ZBBP(:)=0.019*(550./ZWL)*ZWORK2(:)       !ZBBPf=0.0113 at chl<=0.02
-!!  ENDWHERE
-
-    do JI = 1, knon
-      IF (ZCHL(JI) > 0.02) THEN
-        ZNU(JI)=MIN(0.0,0.5*(ZWORK3(JI)-0.3))
-        ZBBP(JI)=(0.002+0.01*(0.5-0.25*ZWORK3(JI))*(ZWL/550.)**ZNU(JI)) &
-                  *ZWORK2(JI)
-      ELSE
-        ZBBP(JI)=0.019*(550./ZWL)*ZWORK2(JI)       !ZBBPf=0.0113 at chl<=0.02 
-      ENDIF
-    ENDDO
-
-  ! Morel-Gentili(1991), Eq (12)
-  ! ZHB=h/(h+2*ZBBPf*(1.-h))        
-  ZHB(1:knon)=0.5*ZBW/(0.5*ZBW+ZBBP(1:knon))
-   
-  !---------------------------------------------------------------------------------
-  ! 3- Compute direct water-leaving albedo (ZRW)
-  !---------------------------------------------------------------------------------
-  ! Based on Morel & Gentilli 1991 parametrization
-  ZR22(1:knon)=0.48168549-0.014894708*ZSIG(1:knon)-0.20703885*ZSIG(1:knon)**2
-
-  ! Use Morel 91 formula to compute the direct reflectance
-  ! below the surface
-  ZR00(1:knon)=(0.5*ZBW+ZBBP(1:knon))/(ZAW+ZAP(1:knon)) *  & 
-               (0.6279-0.2227*ZHB(1:knon)-0.0513*ZHB(1:knon)**2 + & 
-               (-0.3119+0.2465*ZHB(1:knon))*ZCOSZEN(1:knon))
-  ZRW(1:knon)=ZR00(1:knon)*(1.-ZR22(1:knon))/(1.-ZR00(1:knon)*ZR22(1:knon))
-
-  !---------------------------------------------------------------------------------
-  ! 4- Compute diffuse water-leaving albedo (ZRWDF)
-  !---------------------------------------------------------------------------------
-  ! as previous water-leaving computation but assumes a uniform incidence of
-  ! shortwave at surface (ue)
-  ZUE=0.676               ! equivalent u_unif for diffuse incidence
-  ZUE2=SQRT(1.0-(1.0-ZUE**2)/ZREFM**2)
-  ZRR0(1:knon)=0.50*(((ZUE2-ZREFM*ZUE)/(ZUE2+ZREFM*ZUE))**2 +((ZUE-ZREFM*ZUE2)/(ZUE+ZREFM*ZUE2))**2)
-  ZRRR(1:knon)=0.50*(((ZUE2-1.34*ZUE)/(ZUE2+1.34*ZUE))**2 +((ZUE-1.34*ZUE2)/(ZUE+1.34*ZUE2))**2)
-  ZR11DF(1:knon)=ZRR0(1:knon)-(0.0152-1.7873*ZUE+6.8972*ZUE**2-8.5778*ZUE**3+4.071*ZSIG(1:knon)-7.6446*ZUE*ZSIG(1:knon)) * &
-                 EXP(0.1643-7.8409*ZUE-3.5639*ZUE**2-2.3588*ZSIG(1:knon)+10.0538*ZUE*ZSIG(1:knon))*ZRR0(1:knon)/ZRRR(1:knon)
-
-  ! Use Morel 91 formula to compute the diffuse
-  ! reflectance below the surface
-  ZR00(1:knon) = (0.5*ZBW+ZBBP(1:knon)) / (ZAW+ZAP(1:knon)) &
-       * (0.6279-0.2227*ZHB(1:knon)-0.0513*ZHB(1:knon)**2 &
-       + (-0.3119+0.2465*ZHB(1:knon))*ZUE)
-  ZRWDF(1:knon)=ZR00(1:knon)*(1.-ZR22(1:knon))*(1.-ZR11DF(1:knon))/(1.-ZR00(1:knon)*ZR22(1:knon))
-   
-  ! get waveband index inu for each nsw band
-  SELECT CASE(nsw)
-  CASE(2)
-    IF (JWL.LE.49) THEN       ! from 200  to 680 nm 
-     inu=1
-    ELSE                      ! from 690  to 4000 nm
-     inu=2
-    ENDIF
-  CASE(4)
-    IF (JWL.LE.49) THEN       ! from 200  to 680 nm 
-     inu=1
-    ELSE IF (JWL.LE.99) THEN  ! from 690  to 1180 nm
-     inu=2
-    ELSE IF (JWL.LE.218) THEN ! from 1190 to 2370 nm
-     inu=3
-    ELSE                      ! from 2380 to 4000 nm
-     inu=4
-    ENDIF
-  CASE(6)
-    IF (JWL.LE.5) THEN        ! from 200  to 240 nm 
-     inu=1
-    ELSE IF (JWL.LE.24) THEN  ! from 250  to 430 nm
-     inu=2
-    ELSE IF (JWL.LE.49) THEN  ! from 440  to 680 nm
-     inu=3
-    ELSE IF (JWL.LE.99) THEN  ! from 690  to 1180 nm
-     inu=4
-    ELSE IF (JWL.LE.218) THEN ! from 1190 to 2370 nm
-     inu=5
-    ELSE                      ! from 2380 to 4000 nm
-     inu=6
-    ENDIF
-  END SELECT
-
-  ! partitionning direct and diffuse albedo
-  ! excluding diffuse albedo ZRW on ZDIR_ALB
-
-  !--direct
-  alb_dir_new(1:knon,inu)=alb_dir_new(1:knon,inu) + & 
-                          ( XFRWL(JWL) * ((1.-ZFWC(1:knon)) * (ZR11(1:knon)+ZRW(1:knon))   + ZFWC(1:knon)*XRWC(JWL)) )/SFRWL(inu)
-  !--diffuse
-  alb_dif_new(1:knon,inu)=alb_dif_new(1:knon,inu) + & 
-                          ( XFRWL(JWL) * ((1.-ZFWC(1:knon)) * (ZRDF(1:knon)+ZRWDF(1:knon)) + ZFWC(1:knon)*XRWC(JWL)) )/SFRWL(inu)
-
-ENDDO ! ending loop over wavelengths
-
-END SUBROUTINE ocean_albedo
Index: /LMDZ6/trunk/libf/phylmd/ocean_albedo.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/ocean_albedo.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/ocean_albedo.f90	(revision 5268)
@@ -0,0 +1,256 @@
+!
+! $Id$
+!
+
+SUBROUTINE ocean_albedo(knon,zrmu0,knindex,pwind,SFRWL,alb_dir_new,alb_dif_new)
+!!
+!!****  *ALBEDO_RS14*  
+!!
+!!    PURPOSE
+!!    -------
+!!     computes the direct & diffuse albedo over open water
+!!     
+!!**  METHOD
+!!    ------
+!!
+!!    EXTERNAL
+!!    --------
+!!
+!!    IMPLICIT ARGUMENTS
+!!    ------------------ 
+!!      
+!!    REFERENCE
+!!    ---------
+!!      
+!!    AUTHOR
+!!    ------
+!!	R. Séférian           * Meteo-France *
+!!
+!!    MODIFICATIONS
+!!    -------------
+!!      Original    03/2014
+!!                  05/2014 R. Séférian & B. Decharme :: Adaptation to spectral
+!!                  computation for diffuse and direct albedo
+!!                  08/2014 S. Baek :: for wider wavelength range 200-4000nm and
+!!                  adaptation to LMDZ + whitecap effect by Koepke + chrolophyll
+!!                  map from climatology file
+!!                  10/2016 O. Boucher :: some optimisation following R.
+!!                  Seferian's work in the CNRM Model
+!!       
+!-------------------------------------------------------------------------------
+!
+!*           DECLARATIONS
+!            ------------
+!
+USE ocean_albedo_para
+USE dimphy
+USE phys_state_var_mod, ONLY : chl_con
+!
+!
+IMPLICIT NONE
+!
+!*      0.1    declarations of arguments
+!              -------------------------
+!
+include "clesphys.h"
+!
+INTEGER, INTENT(IN) :: knon
+INTEGER, DIMENSION(klon), INTENT(IN) :: knindex
+REAL, DIMENSION(klon), INTENT(IN) :: zrmu0         !--cos(SZA) on full vector
+REAL, DIMENSION(klon), INTENT(IN) :: pwind         !--wind speed on compressed vector
+REAL, DIMENSION(6),INTENT(IN) :: SFRWL
+REAL, DIMENSION(klon,nsw), INTENT(OUT) :: alb_dir_new, alb_dif_new
+!
+!*      0.2    declarations of local variables
+!              -------------------------
+!
+REAL, DIMENSION(klon)           :: ZCHL        ! surface chlorophyll
+REAL, DIMENSION(klon)           :: ZCOSZEN     ! Cosine of the zenith solar angle
+!
+INTEGER                         :: JWL, INU    ! indexes
+INTEGER                         :: JI
+REAL                            :: ZWL         ! input parameter: wavelength and diffuse/direct fraction of light
+REAL:: ZCHLABS, ZAW, ZBW, ZREFM, ZYLMD, ZUE, ZUE2 ! scalar computation variables
+!
+REAL, DIMENSION(klon) :: ZAP, ZXX2, ZR00, ZRR0, ZRRR               ! computation variables
+REAL, DIMENSION(klon) :: ZR22, ZR11DF                              ! computation variables
+REAL, DIMENSION(klon) :: ZBBP, ZNU, ZHB                            ! computation variables
+REAL, DIMENSION(klon) :: ZR11, ZRW, ZRWDF, ZRDF                    ! 4 components of the OSA
+REAL, DIMENSION(klon) :: ZSIG, ZFWC, ZWORK1, ZWORK2, ZWORK3
+! 
+!--initialisations-------------
+!
+
+IF (knon==0) RETURN ! A verifier pourquoi on en a besoin...
+
+alb_dir_new(:,:) = 0. 
+alb_dif_new(:,:) = 0. 
+!
+! Initialisation of chlorophyll content
+! ZCHL(:) = CHL_CON!0.05 ! averaged global values for surface chlorophyll
+IF (ok_chlorophyll) THEN
+  ZCHL(1:knon)=CHL_CON(knindex(1:knon))
+ELSE 
+  ZCHL(1:knon) = 0.05
+ENDIF
+
+! variables that do not depend on wavelengths
+! loop over the grid points
+! functions of chlorophyll content
+ZWORK1(1:knon)= EXP(LOG(ZCHL(1:knon))*0.65)
+ZWORK2(1:knon)= 0.416 * EXP(LOG(ZCHL(1:knon))*0.766)
+ZWORK3(1:knon)= LOG10(ZCHL(1:knon))
+! store the cosine of the solar zenith angle
+ZCOSZEN(1:knon) = zrmu0(knindex(1:knon))
+! Compute sigma derived from wind speed (Cox & Munk reflectance model)
+ZSIG(1:knon)=SQRT(0.003+0.00512*PWIND(1:knon))
+! original : correction for foam (Eq 16-17)
+! has to be update once we have information from wave model (discussion with G. Madec)
+ZFWC(1:knon)=3.97e-4*PWIND(1:knon)**1.59 ! Salisbury 2014 eq(2) at 37GHz, value in fraction
+!
+DO JWL=1,NNWL           ! loop over the wavelengths
+  !
+  !---------------------------------------------------------------------------------
+  ! 0- Compute baseline values
+  !---------------------------------------------------------------------------------
+    
+  ! Get refractive index for the correspoding wavelength
+  ZWL=XAKWL(JWL)      !!!--------- wavelength value
+  ZREFM= XAKREFM(JWL) !!!--------- refraction index value
+  
+  !---------------------------------------------------------------------------------
+  ! 1- Compute direct surface albedo (ZR11)
+  !---------------------------------------------------------------------------------
+  !
+  ZXX2(1:knon)=SQRT(1.0-(1.0-ZCOSZEN(1:knon)**2)/ZREFM**2)
+  ZRR0(1:knon)=0.50*(((ZXX2(1:knon)-ZREFM*ZCOSZEN(1:knon))/(ZXX2(1:knon)+ZREFM*ZCOSZEN(1:knon)))**2 +  & 
+               ((ZCOSZEN(1:knon)-ZREFM*ZXX2(1:knon))/(ZCOSZEN(1:knon)+ZREFM*ZXX2(1:knon)))**2)
+  ZRRR(1:knon)=0.50*(((ZXX2(1:knon)-1.34*ZCOSZEN(1:knon))/(ZXX2(1:knon)+1.34*ZCOSZEN(1:knon)))**2 + & 
+               ((ZCOSZEN(1:knon)-1.34*ZXX2(1:knon))/(ZCOSZEN(1:knon)+1.34*ZXX2(1:knon)))**2)
+  ZR11(1:knon)=ZRR0(1:knon)-(0.0152-1.7873*ZCOSZEN(1:knon)+6.8972*ZCOSZEN(1:knon)**2-8.5778*ZCOSZEN(1:knon)**3+ & 
+               4.071*ZSIG(1:knon)-7.6446*ZCOSZEN(1:knon)*ZSIG(1:knon)) *  & 
+               EXP(0.1643-7.8409*ZCOSZEN(1:knon)-3.5639*ZCOSZEN(1:knon)**2-2.3588*ZSIG(1:knon)+ & 
+               10.0538*ZCOSZEN(1:knon)*ZSIG(1:knon))*ZRR0(1:knon)/ZRRR(1:knon)
+  ! 
+  !---------------------------------------------------------------------------------
+  ! 2- Compute surface diffuse albedo (ZRDF)
+  !---------------------------------------------------------------------------------
+  ! Diffuse albedo from Jin et al., 2006 + estimation from diffuse fraction of
+  ! light (relying later on AOD). CNRM model has opted for Eq 5b
+  ZRDF(1:knon)=-0.1482-0.012*ZSIG(1:knon)+0.1609*ZREFM-0.0244*ZSIG(1:knon)*ZREFM ! surface diffuse (Eq 5a)
+  !!ZRDF(1:knon)=-0.1479+0.1502*ZREFM-0.0176*ZSIG(1:knon)*ZREFM   ! surface diffuse (Eq 5b) 
+ 
+  !---------------------------------------------------------------------------------
+  ! *- Determine absorption and backscattering
+  ! coefficients to determine reflectance below the surface (Ro) once for all
+  !
+  ! *.1- Absorption by chlorophyll
+  ZCHLABS= XAKACHL(JWL) 
+  ! *.2- Absorption by seawater 
+  ZAW= XAKAW3(JWL) 
+  ! *.3- Backscattering by seawater
+  ZBW= XAKBW(JWL) 
+  ! *.4- Backscattering by chlorophyll
+  ZYLMD = EXP(0.014*(440.0-ZWL))
+  ZAP(1:knon) = 0.06*ZCHLABS*ZWORK1(1:knon) +0.2*(XAW440+0.06*ZWORK1(1:knon))*ZYLMD
+   
+!!  WHERE ( ZCHL(1:knon) > 0.02 )
+!!    ZNU(:)=MIN(0.0,0.5*(ZWORK3(:)-0.3))
+!!    ZBBP(:)=(0.002+0.01*(0.5-0.25*ZWORK3(:))*(ZWL/550.)**ZNU(:))*ZWORK2(:)
+!!  ELSEWHERE
+!!    ZBBP(:)=0.019*(550./ZWL)*ZWORK2(:)       !ZBBPf=0.0113 at chl<=0.02
+!!  ENDWHERE
+
+    do JI = 1, knon
+      IF (ZCHL(JI) > 0.02) THEN
+        ZNU(JI)=MIN(0.0,0.5*(ZWORK3(JI)-0.3))
+        ZBBP(JI)=(0.002+0.01*(0.5-0.25*ZWORK3(JI))*(ZWL/550.)**ZNU(JI)) &
+                  *ZWORK2(JI)
+      ELSE
+        ZBBP(JI)=0.019*(550./ZWL)*ZWORK2(JI)       !ZBBPf=0.0113 at chl<=0.02 
+      ENDIF
+    ENDDO
+
+  ! Morel-Gentili(1991), Eq (12)
+  ! ZHB=h/(h+2*ZBBPf*(1.-h))        
+  ZHB(1:knon)=0.5*ZBW/(0.5*ZBW+ZBBP(1:knon))
+   
+  !---------------------------------------------------------------------------------
+  ! 3- Compute direct water-leaving albedo (ZRW)
+  !---------------------------------------------------------------------------------
+  ! Based on Morel & Gentilli 1991 parametrization
+  ZR22(1:knon)=0.48168549-0.014894708*ZSIG(1:knon)-0.20703885*ZSIG(1:knon)**2
+
+  ! Use Morel 91 formula to compute the direct reflectance
+  ! below the surface
+  ZR00(1:knon)=(0.5*ZBW+ZBBP(1:knon))/(ZAW+ZAP(1:knon)) *  & 
+               (0.6279-0.2227*ZHB(1:knon)-0.0513*ZHB(1:knon)**2 + & 
+               (-0.3119+0.2465*ZHB(1:knon))*ZCOSZEN(1:knon))
+  ZRW(1:knon)=ZR00(1:knon)*(1.-ZR22(1:knon))/(1.-ZR00(1:knon)*ZR22(1:knon))
+
+  !---------------------------------------------------------------------------------
+  ! 4- Compute diffuse water-leaving albedo (ZRWDF)
+  !---------------------------------------------------------------------------------
+  ! as previous water-leaving computation but assumes a uniform incidence of
+  ! shortwave at surface (ue)
+  ZUE=0.676               ! equivalent u_unif for diffuse incidence
+  ZUE2=SQRT(1.0-(1.0-ZUE**2)/ZREFM**2)
+  ZRR0(1:knon)=0.50*(((ZUE2-ZREFM*ZUE)/(ZUE2+ZREFM*ZUE))**2 +((ZUE-ZREFM*ZUE2)/(ZUE+ZREFM*ZUE2))**2)
+  ZRRR(1:knon)=0.50*(((ZUE2-1.34*ZUE)/(ZUE2+1.34*ZUE))**2 +((ZUE-1.34*ZUE2)/(ZUE+1.34*ZUE2))**2)
+  ZR11DF(1:knon)=ZRR0(1:knon)-(0.0152-1.7873*ZUE+6.8972*ZUE**2-8.5778*ZUE**3+4.071*ZSIG(1:knon)-7.6446*ZUE*ZSIG(1:knon)) * &
+                 EXP(0.1643-7.8409*ZUE-3.5639*ZUE**2-2.3588*ZSIG(1:knon)+10.0538*ZUE*ZSIG(1:knon))*ZRR0(1:knon)/ZRRR(1:knon)
+
+  ! Use Morel 91 formula to compute the diffuse
+  ! reflectance below the surface
+  ZR00(1:knon) = (0.5*ZBW+ZBBP(1:knon)) / (ZAW+ZAP(1:knon)) &
+       * (0.6279-0.2227*ZHB(1:knon)-0.0513*ZHB(1:knon)**2 &
+       + (-0.3119+0.2465*ZHB(1:knon))*ZUE)
+  ZRWDF(1:knon)=ZR00(1:knon)*(1.-ZR22(1:knon))*(1.-ZR11DF(1:knon))/(1.-ZR00(1:knon)*ZR22(1:knon))
+   
+  ! get waveband index inu for each nsw band
+  SELECT CASE(nsw)
+  CASE(2)
+    IF (JWL.LE.49) THEN       ! from 200  to 680 nm 
+     inu=1
+    ELSE                      ! from 690  to 4000 nm
+     inu=2
+    ENDIF
+  CASE(4)
+    IF (JWL.LE.49) THEN       ! from 200  to 680 nm 
+     inu=1
+    ELSE IF (JWL.LE.99) THEN  ! from 690  to 1180 nm
+     inu=2
+    ELSE IF (JWL.LE.218) THEN ! from 1190 to 2370 nm
+     inu=3
+    ELSE                      ! from 2380 to 4000 nm
+     inu=4
+    ENDIF
+  CASE(6)
+    IF (JWL.LE.5) THEN        ! from 200  to 240 nm 
+     inu=1
+    ELSE IF (JWL.LE.24) THEN  ! from 250  to 430 nm
+     inu=2
+    ELSE IF (JWL.LE.49) THEN  ! from 440  to 680 nm
+     inu=3
+    ELSE IF (JWL.LE.99) THEN  ! from 690  to 1180 nm
+     inu=4
+    ELSE IF (JWL.LE.218) THEN ! from 1190 to 2370 nm
+     inu=5
+    ELSE                      ! from 2380 to 4000 nm
+     inu=6
+    ENDIF
+  END SELECT
+
+  ! partitionning direct and diffuse albedo
+  ! excluding diffuse albedo ZRW on ZDIR_ALB
+
+  !--direct
+  alb_dir_new(1:knon,inu)=alb_dir_new(1:knon,inu) + & 
+                          ( XFRWL(JWL) * ((1.-ZFWC(1:knon)) * (ZR11(1:knon)+ZRW(1:knon))   + ZFWC(1:knon)*XRWC(JWL)) )/SFRWL(inu)
+  !--diffuse
+  alb_dif_new(1:knon,inu)=alb_dif_new(1:knon,inu) + & 
+                          ( XFRWL(JWL) * ((1.-ZFWC(1:knon)) * (ZRDF(1:knon)+ZRWDF(1:knon)) + ZFWC(1:knon)*XRWC(JWL)) )/SFRWL(inu)
+
+ENDDO ! ending loop over wavelengths
+
+END SUBROUTINE ocean_albedo
Index: DZ6/trunk/libf/phylmd/ocean_albedo_para.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/ocean_albedo_para.F90	(revision 5267)
+++ 	(revision )
@@ -1,646 +1,0 @@
-!
-! $Id$
-!
-!     ######################
-MODULE ocean_albedo_para
-!     ######################
-!
-!!****  *MOD_DALBEDO_RS14* - declaration of ISBA parameters
-!!
-!!    PURPOSE
-!!    -------
-!       The purpose of this declarative module is to specify  the 
-!     parameters related to direct & diffuse albedo over open water 
-!
-!!
-!!      
-!!
-!!    AUTHOR
-!!    ------
-!!	R. Séférian           * Meteo-France *
-!!
-!!    MODIFICATIONS
-!!    -------------
-!       S. Baek : extention from 200-800nm to 200-40000nm 
-!-------------------------------------------------------------------------------
-!
-!*       0.   DECLARATIONS
-!             ------------
-!
-
-IMPLICIT NONE
-!
-INTEGER, PARAMETER   :: NNWL = 381                ! number of wavelength
-!
-! absorption coefficients for seawater et 440 nm
-REAL, PARAMETER      :: XAW440 =  0.00635
-!
-!! white-caps reflectance (Koepke , 1983 estimation)
-!REAL, PARAMETER      :: XRWC   =  0.55
-!
-! table of wavelength discretization
-REAL, PARAMETER, DIMENSION(NNWL)::  XAKWL= &
-    (/ 200.0, 210.0, 220.0, 230.0, 240.0, 250.0, 260.0, 270.0, 280.0,  &
-    290.0, 300.0, 310.0, 320.0, 330.0, 340.0, 350.0, 360.0, 370.0,            &
-    380.0, 390.0, 400.0, 410.0, 420.0, 430.0, 440.0, 450.0, 460.0,            &
-    470.0, 480.0, 490.0, 500.0, 510.0, 520.0, 530.0, 540.0, 550.0,            &
-    560.0, 570.0, 580.0, 590.0, 600.0, 610.0, 620.0, 630.0, 640.0,            &
-    650.0, 660.0, 670.0, 680.0, 690.0, 700.0, 710.0, 720.0, 730.0,            &
-    740.0, 750.0, 760.0, 770.0, 780.0, 790.0, 800.0, 810.0, 820.0,            &
-    830.0, 840.0, 850.0, 860.0, 870.0, 880.0, 890.0, 900.0, 910.0,            &
-    920.0, 930.0, 940.0, 950.0, 960.0, 970.0, 980.0, 990.0, 1000.0, 1010.0,   &
-    1020.0, 1030.0, 1040.0, 1050.0, 1060.0, 1070.0, 1080.0, 1090.0, 1100.0,   &
-    1110.0, 1120.0, 1130.0, 1140.0, 1150.0, 1160.0, 1170.0, 1180.0, 1190.0,   &
-    1200.0, 1210.0, 1220.0, 1230.0, 1240.0, 1250.0, 1260.0, 1270.0, 1280.0,   &
-    1290.0, 1300.0, 1310.0, 1320.0, 1330.0, 1340.0, 1350.0, 1360.0, 1370.0,   &
-    1380.0, 1390.0, 1400.0, 1410.0, 1420.0, 1430.0, 1440.0, 1450.0, 1460.0,   &
-    1470.0, 1480.0, 1490.0, 1500.0, 1510.0, 1520.0, 1530.0, 1540.0, 1550.0,   &
-    1560.0, 1570.0, 1580.0, 1590.0, 1600.0, 1610.0, 1620.0, 1630.0, 1640.0,   &
-    1650.0, 1660.0, 1670.0, 1680.0, 1690.0, 1700.0, 1710.0, 1720.0, 1730.0,   &
-    1740.0, 1750.0, 1760.0, 1770.0, 1780.0, 1790.0, 1800.0, 1810.0, 1820.0,   &
-    1830.0, 1840.0, 1850.0, 1860.0, 1870.0, 1880.0, 1890.0, 1900.0, 1910.0,   &
-1920.0, 1930.0, 1940.0, 1950.0, 1960.0, 1970.0, 1980.0, 1990.0, 2000.0, 2010.0,& 
-2020.0, 2030.0, 2040.0, 2050.0, 2060.0, 2070.0, 2080.0, 2090.0, 2100.0, 2110.0,&
-2120.0, 2130.0, 2140.0, 2150.0, 2160.0, 2170.0, 2180.0, 2190.0, 2200.0, 2210.0,&
-2220.0, 2230.0, 2240.0, 2250.0, 2260.0, 2270.0, 2280.0, 2290.0, 2300.0, 2310.0,&
-2320.0, 2330.0, 2340.0, 2350.0, 2360.0, 2370.0, 2380.0, 2390.0, 2400.0, 2410.0,&
-2420.0, 2430.0, 2440.0, 2450.0, 2460.0, 2470.0, 2480.0, 2490.0, 2500.0, 2510.0,&
-2520.0, 2530.0, 2540.0, 2550.0, 2560.0, 2570.0, 2580.0, 2590.0, 2600.0, 2610.0,&
-2620.0, 2630.0, 2640.0, 2650.0, 2660.0, 2670.0, 2680.0, 2690.0, 2700.0, 2710.0,&
-2720.0, 2730.0, 2740.0, 2750.0, 2760.0, 2770.0, 2780.0, 2790.0, 2800.0, 2810.0,&
-2820.0, 2830.0, 2840.0, 2850.0, 2860.0, 2870.0, 2880.0, 2890.0, 2900.0, 2910.0,&
-2920.0, 2930.0, 2940.0, 2950.0, 2960.0, 2970.0, 2980.0, 2990.0, 3000.0, 3010.0,&
-3020.0, 3030.0, 3040.0, 3050.0, 3060.0, 3070.0, 3080.0, 3090.0, 3100.0, 3110.0,&
-3120.0, 3130.0, 3140.0, 3150.0, 3160.0, 3170.0, 3180.0, 3190.0, 3200.0, 3210.0,&
-3220.0, 3230.0, 3240.0, 3250.0, 3260.0, 3270.0, 3280.0, 3290.0, 3300.0, 3310.0,&
-3320.0, 3330.0, 3340.0, 3350.0, 3360.0, 3370.0, 3380.0, 3390.0, 3400.0, 3410.0,&
-3420.0, 3430.0, 3440.0, 3450.0, 3460.0, 3470.0, 3480.0, 3490.0, 3500.0, 3510.0,&
-3520.0, 3530.0, 3540.0, 3550.0, 3560.0, 3570.0, 3580.0, 3590.0, 3600.0, 3610.0,&
-3620.0, 3630.0, 3640.0, 3650.0, 3660.0, 3670.0, 3680.0, 3690.0, 3700.0, 3710.0,&
-3720.0, 3730.0, 3740.0, 3750.0, 3760.0, 3770.0, 3780.0, 3790.0, 3800.0, 3810.0,&
-3820.0, 3830.0, 3840.0, 3850.0, 3860.0, 3870.0, 3880.0, 3890.0, 3900.0, 3910.0,&
-3920.0, 3930.0, 3940.0, 3950.0, 3960.0, 3970.0, 3980.0, 3990.0, 4000.0 /) 
-
-
- 
-!
-! proportion of each wavelength
-REAL, PARAMETER, DIMENSION(NNWL)::  XFRWL= &
-(/0.5399519E-04, 0.2057802E-03, 0.3488387E-03, 0.3841427E-03, 0.2915711E-03, &
-0.4429581E-03, 0.6302387E-03, 0.1970095E-02, 0.6974564E-03, 0.4431792E-02,   &
-0.3095547E-02, 0.4587307E-02, 0.5933870E-02, 0.7488277E-02, 0.7421943E-02,   &
-0.7738869E-02, 0.7155137E-02, 0.8394831E-02, 0.8859162E-02, 0.9190828E-02,   &
-0.1239693E-01, 0.1129138E-01, 0.1294971E-01, 0.8365349E-02, 0.1262541E-01,&
-0.1580203E-01, 0.1503552E-01, 0.1383415E-01, 0.1499867E-01, 0.1479230E-01,&
-0.1368674E-01, 0.1435007E-01, 0.1349511E-01, 0.1438693E-01, 0.1303815E-01,&
-0.1372359E-01, 0.1358356E-01, 0.1303815E-01, 0.1354671E-01, 0.1336245E-01,&
-0.1286863E-01, 0.1255171E-01, 0.1278019E-01, 0.1208001E-01, 0.1189575E-01,&
-0.1183678E-01, 0.1157882E-01, 0.1117345E-01, 0.1099656E-01, 0.1067227E-01,&
-0.1021531E-01, 0.1020794E-01, 0.9809937E-02, 0.9773086E-02, 0.9271902E-02,&
-0.9301383E-02, 0.9117125E-02, 0.8873903E-02, 0.8748608E-02, 0.8534866E-02,&
-0.8416941E-02, 0.8210571E-02, 0.7959980E-02, 0.7834683E-02, 0.7665165E-02,&
-0.7119759E-02, 0.7347503E-02, 0.7183881E-02, 0.7041634E-02, 0.7023945E-02,&
-0.6749768E-02, 0.6571406E-02, 0.6565509E-02, 0.6395254E-02, 0.6219103E-02,&
-0.6168247E-02, 0.6007574E-02, 0.5866062E-02, 0.5709074E-02, 0.5557982E-02,&
-0.5512286E-02, 0.5389938E-02, 0.5189464E-02, 0.5112813E-02, 0.4983095E-02,&
-0.4880646E-02, 0.4728080E-02, 0.4599837E-02, 0.4604259E-02, 0.4568881E-02,&
-0.4453166E-02, 0.4352930E-02, 0.4231319E-02, 0.4166460E-02, 0.4075804E-02,&
-0.4045586E-02, 0.3921027E-02, 0.3888597E-02, 0.3861327E-02, 0.3747823E-02,&
-0.3687387E-02, 0.3598206E-02, 0.3593046E-02, 0.3531872E-02, 0.3429424E-02,&
-0.3408050E-02, 0.3338769E-02, 0.3282018E-02, 0.3210525E-02, 0.3136085E-02,&
-0.3085229E-02, 0.3026266E-02, 0.2959933E-02, 0.2858222E-02, 0.2793363E-02,&
-0.2744719E-02, 0.2707130E-02, 0.2652589E-02, 0.2637849E-02, 0.2584045E-02,&
-0.2525819E-02, 0.2519186E-02, 0.2474227E-02, 0.2400524E-02, 0.2349668E-02,&
-0.2348931E-02, 0.2326083E-02, 0.2286283E-02, 0.2261224E-02, 0.2222161E-02,&
-0.2219213E-02, 0.2172043E-02, 0.2112343E-02, 0.2037902E-02, 0.2012106E-02,&
-0.1999576E-02, 0.1977465E-02, 0.1949458E-02, 0.1953143E-02, 0.1772569E-02,&
-0.1851432E-02, 0.1768884E-02, 0.1746036E-02, 0.1763725E-02, 0.1667173E-02,&
-0.1674544E-02, 0.1654644E-02, 0.1639903E-02, 0.1533033E-02, 0.1551459E-02,&
-0.1520504E-02, 0.1483652E-02, 0.1468911E-02, 0.1462278E-02, 0.1404052E-02,&
-0.1369411E-02, 0.1349511E-02, 0.1320030E-02, 0.1294234E-02, 0.1277282E-02,&
-0.1252223E-02, 0.1242641E-02, 0.1176308E-02, 0.1183679E-02, 0.1151249E-02,&
-0.1139456E-02, 0.1107764E-02, 0.1111449E-02, 0.1077545E-02, 0.1049538E-02,&
-0.1029638E-02, 0.1015634E-02, 0.9824679E-03, 0.9677272E-03, 0.9574086E-03,&
-0.9294013E-03, 0.9294013E-03, 0.9131865E-03, 0.8814940E-03, 0.8829681E-03,&
-0.8623311E-03, 0.8468534E-03, 0.8225312E-03, 0.8004201E-03, 0.7945239E-03,&
-0.7805202E-03, 0.7576721E-03, 0.7392463E-03, 0.7280433E-03, 0.7214100E-03,&
-0.7079960E-03, 0.6925183E-03, 0.6836001E-03, 0.6787357E-03, 0.6694490E-03,&
-0.6601624E-03, 0.6471906E-03, 0.6306809E-03, 0.6262587E-03, 0.6120340E-03,&
-0.6091595E-03, 0.5955244E-03, 0.5894070E-03, 0.5771722E-03, 0.5630211E-03,&
-0.5557982E-03, 0.5469538E-03, 0.5378146E-03, 0.5280857E-03, 0.5240319E-03,&
-0.5124605E-03, 0.5063431E-03, 0.4988254E-03, 0.4876225E-03, 0.4805469E-03,&
-0.4756088E-03, 0.4649218E-03, 0.4577725E-03, 0.4548981E-03, 0.4443585E-03,&
-0.4380937E-03, 0.4349982E-03, 0.4252693E-03, 0.4209945E-03, 0.4156141E-03,&
-0.4025686E-03, 0.4022001E-03, 0.3895231E-03, 0.3815631E-03, 0.3851009E-03,&
-0.3799416E-03, 0.3736400E-03, 0.3673383E-03, 0.3610735E-03, 0.3548087E-03,&
-0.3495758E-03, 0.3443428E-03, 0.3398469E-03, 0.3353510E-03, 0.3319237E-03,&
-0.3284966E-03, 0.3228951E-03, 0.3172936E-03, 0.3138296E-03, 0.3103655E-03,&
-0.3055011E-03, 0.3006366E-03, 0.2965461E-03, 0.2924555E-03, 0.2887335E-03,&
-0.2850115E-03, 0.2811789E-03, 0.2773463E-03, 0.2736611E-03, 0.2699760E-03,&
-0.2656643E-03, 0.2613527E-03, 0.2584782E-03, 0.2556038E-03, 0.2525451E-03,&
-0.2494864E-03, 0.2462434E-03, 0.2430005E-03, 0.2397575E-03, 0.2365146E-03,&
-0.2331979E-03, 0.2298813E-03, 0.2266752E-03, 0.2234690E-03, 0.2211474E-03,&
-0.2188257E-03, 0.2159144E-03, 0.2130031E-03, 0.2103130E-03, 0.2076228E-03,&
-0.2051537E-03, 0.2026847E-03, 0.2001787E-03, 0.1976728E-03, 0.1950932E-03,&
-0.1925136E-03, 0.1901182E-03, 0.1877228E-03, 0.1847010E-03, 0.1816792E-03,&
-0.1800945E-03, 0.1785099E-03, 0.1763725E-03, 0.1742351E-03, 0.1720977E-03,&
-0.1699603E-03, 0.1677492E-03, 0.1655381E-03, 0.1637692E-03, 0.1620003E-03,&
-0.1600103E-03, 0.1580203E-03, 0.1562514E-03, 0.1544826E-03, 0.1527137E-03,&
-0.1509448E-03, 0.1491759E-03, 0.1474070E-03, 0.1456013E-03, 0.1437956E-03,&
-0.1421741E-03, 0.1405526E-03, 0.1387469E-03, 0.1369411E-03, 0.1348774E-03,&
-0.1328137E-03, 0.1315608E-03, 0.1303078E-03, 0.1291654E-03, 0.1280230E-03,&
-0.1265489E-03, 0.1250749E-03, 0.1236745E-03, 0.1222741E-03, 0.1206526E-03,&
-0.1190312E-03, 0.1178888E-03, 0.1167464E-03, 0.1156408E-03, 0.1145353E-03,&
-0.1132823E-03, 0.1120294E-03, 0.1107764E-03, 0.1095234E-03, 0.1084179E-03,&
-0.1073123E-03, 0.1061699E-03, 0.1050275E-03, 0.1038483E-03, 0.1026690E-03,&
-0.1015266E-03, 0.1003842E-03, 0.9935234E-04, 0.9832049E-04, 0.9732549E-04,&
-0.9633049E-04, 0.9537235E-04, 0.9441420E-04, 0.9330864E-04, 0.9220310E-04,&
-0.9113440E-04, 0.9006570E-04, 0.8899700E-04, 0.8792829E-04, 0.8678589E-04,&
-0.8564349E-04, 0.8501700E-04, 0.8439052E-04, 0.8302701E-04, 0.8166349E-04,&
-0.8122127E-04, 0.8077905E-04, 0.8011572E-04, 0.7945239E-04, 0.7867850E-04,&
-0.7790462E-04, 0.7720443E-04, 0.7650425E-04, 0.7580406E-04, 0.7510388E-04,&
-0.7434105E-04, 0.7357822E-04, 0.7283750E-04, 0.7209678E-04, 0.7142239E-04,&
-0.7074801E-04, 0.7011415E-04, 0.6948030E-04, 0.6876537E-04, 0.6805045E-04,&
-0.6730973E-04, 0.6656901E-04, 0.6592411E-04, 0.6527920E-04, 0.6458639E-04,&
-0.6389357E-04 /) 
-
-
-!
-! Table for computing Reflectance just below ocean surface (bounded to 200-800 nm)
-! table of refractive index as function of wavelength
-REAL, PARAMETER, DIMENSION(NNWL)::  XAKREFM= &
-(/ 1.4517,  1.4345,  1.4214,  1.4108,  1.4022,  1.3950,  1.3889,  1.3836,      &
-1.3790,  1.3750,  1.3714,  1.3682,  1.3653,  1.3627,  1.3604,  1.3582,  1.3562,&
-1.3544,  1.3528,  1.3512,  1.3498,  1.3484,  1.3472,  1.3460,  1.3449,  1.3439,&
-1.3429,  1.3420,  1.3411,  1.3402,  1.3394,  1.3387,  1.3379,  1.3372,  1.3366,&
-1.3359,  1.3353,  1.3347,  1.3342,  1.3336,  1.3331,  1.3326,  1.3321,  1.3316,&
-1.3311,  1.3307,  1.3303,  1.3299,  1.3295,  1.3291,  1.3288,  1.3284,  1.3281,&
-1.3278,  1.3275,  1.3272,  1.3269,  1.3266,  1.3264,  1.3261,  1.3259,  1.3256,&
-1.3254,  1.3252,  1.3249,  1.3247,  1.3245,  1.3243,  1.3241,  1.3238,  1.3236,&
-1.3234,  1.3232,  1.3230,  1.3228,  1.3226,  1.3225,  1.3223,  1.3221,  1.3219,&
-1.3217,  1.3215,  1.3213,  1.3211,  1.3210,  1.3208,  1.3206,  1.3204,  1.3202,&
-1.3200,  1.3198,  1.3197,  1.3195,  1.3193,  1.3191,  1.3189,  1.3187,  1.3186,&
-1.3184,  1.3182,  1.3180,  1.3178,  1.3176,  1.3174,  1.3172,  1.3170,  1.3169,&
-1.3167,  1.3165,  1.3163,  1.3161,  1.3159,  1.3156,  1.3154,  1.3152,  1.3150,&
-1.3148,  1.3146,  1.3143,  1.3141,  1.3139,  1.3137,  1.3135,  1.3134,  1.3132,&
-1.3130,  1.3129,  1.3127,  1.3125,  1.3123,  1.3121,  1.3119,  1.3116,  1.3114,&
-1.3111,  1.3109,  1.3106,  1.3104,  1.3101,  1.3099,  1.3096,  1.3094,  1.3091,&
-1.3088,  1.3086,  1.3083,  1.3080,  1.3077,  1.3074,  1.3071,  1.3068,  1.3065,&
-1.3061,  1.3058,  1.3055,  1.3051,  1.3048,  1.3044,  1.3041,  1.3037,  1.3034,&
-1.3030,  1.3026,  1.3022,  1.3017,  1.3013,  1.3007,  1.3002,  1.2998,  1.2995,&
-1.2990,  1.2988,  1.2988,  1.2987,  1.2986,  1.2985,  1.2983,  1.2980,  1.2977,&
-1.2973,  1.2969,  1.2965,  1.2960,  1.2955,  1.2950,  1.2945,  1.2940,  1.2935,&
-1.2929,  1.2924,  1.2918,  1.2913,  1.2907,  1.2901,  1.2895,  1.2889,  1.2883,&
-1.2876,  1.2870,  1.2863,  1.2856,  1.2849,  1.2842,  1.2835,  1.2828,  1.2820,&
-1.2812,  1.2804,  1.2796,  1.2788,  1.2779,  1.2770,  1.2761,  1.2751,  1.2741,&
-1.2731,  1.2721,  1.2711,  1.2699,  1.2688,  1.2676,  1.2664,  1.2652,  1.2639,&
-1.2625,  1.2612,  1.2597,  1.2582,  1.2567,  1.2552,  1.2535,  1.2518,  1.2499,&
-1.2480,  1.2459,  1.2436,  1.2413,  1.2388,  1.2361,  1.2331,  1.2299,  1.2263,&
-1.2223,  1.2182,  1.2140,  1.2091,  1.2034,  1.1973,  1.1910,  1.1850,  1.1780,&
-1.1691,  1.1564,  1.1489,  1.1430,  1.1351,  1.1318,  1.1323,  1.1308,  1.1277,&
-1.1294,  1.1286,  1.1255,  1.1271,  1.1348,  1.1417,  1.1480,  1.1612,  1.1736,&
-1.1847,  1.2008,  1.2177,  1.2336,  1.2505,  1.2678,  1.2840,  1.3007,  1.3149,&
-1.3281,  1.3407,  1.3539,  1.3661,  1.3782,  1.3903,  1.4024,  1.4136,  1.4217,&
-1.4299,  1.4380,  1.4461,  1.4528,  1.4557,  1.4587,  1.4616,  1.4645,  1.4665,&
-1.4655,  1.4645,  1.4634,  1.4624,  1.4613,  1.4589,  1.4566,  1.4543,  1.4519,&
-1.4496,  1.4465,  1.4433,  1.4401,  1.4369,  1.4338,  1.4304,  1.4271,  1.4237,&
-1.4203,  1.4170,  1.4144,  1.4117,  1.4091,  1.4065,  1.4041,  1.4020,  1.3999,&
-1.3977,  1.3956,  1.3936,  1.3916,  1.3897,  1.3879,  1.3860,  1.3841,  1.3824,&
-1.3808,  1.3791,  1.3774,  1.3758,  1.3743,  1.3729,  1.3714,  1.3700,  1.3685,&
-1.3673,  1.3660,  1.3647,  1.3635,  1.3623,  1.3612,  1.3601,  1.3589,  1.3578,&
-1.3568,  1.3558,  1.3548,  1.3538,  1.3528,  1.3519,  1.3510,  1.3501,  1.3493,&
-1.3484,  1.3476,  1.3468,  1.3460,  1.3452,  1.3444,  1.3437,  1.3430,  1.3422,&
-1.3415,  1.3408,  1.3401,  1.3395,  1.3388,  1.3382,  1.3375,  1.3369,  1.3363,&
-1.3357,  1.3351,  1.3345,  1.3339 /)
-
-
-
-
-!
-! table of chlorophyll absorption coefficient as function of wavelength
-REAL, PARAMETER, DIMENSION(NNWL)::  XAKACHL= &
-(/0.4629505E+00, 0.4694205E+00, 0.4758904E+00, 0.4823604E+00, 0.4888304E+00,&
-0.4953003E+00, 0.5017703E+00, 0.5082403E+00, 0.5147102E+00, 0.5211802E+00,&
-0.5276502E+00, 0.5341201E+00, 0.5405901E+00, 0.5470601E+00, 0.5535300E+00,&
-0.5600000E+00, 0.5700000E+00, 0.5900000E+00, 0.6100000E+00, 0.6600000E+00,&
-0.6870000E+00, 0.8280000E+00, 0.9130000E+00, 0.9730000E+00, 0.1000000E+01,&
-0.9440000E+00, 0.9170000E+00, 0.8700000E+00, 0.7980000E+00, 0.7500000E+00,&
-0.6680000E+00, 0.6180000E+00, 0.5280000E+00, 0.4740000E+00, 0.4160000E+00,&
-0.3570000E+00, 0.2940000E+00, 0.2760000E+00, 0.2910000E+00, 0.2820000E+00,&
-0.2360000E+00, 0.2520000E+00, 0.2760000E+00, 0.3170000E+00, 0.3340000E+00,&
-0.3560000E+00, 0.4410000E+00, 0.5950000E+00, 0.5020000E+00, 0.3290000E+00,&
-0.2150000E+00, 0.2150000E+00, 0.2083276E+00, 0.2016552E+00, 0.1949828E+00,&
-0.1883103E+00, 0.1816379E+00, 0.1749655E+00, 0.1682931E+00, 0.1616207E+00,&
-0.1549483E+00, 0.1482759E+00, 0.1416035E+00, 0.1349310E+00, 0.1282586E+00,&
-0.1215862E+00, 0.1149138E+00, 0.1082414E+00, 0.1015690E+00, 0.9489655E-01,&
-0.8822414E-01, 0.8155172E-01, 0.7487931E-01, 0.6820690E-01, 0.6153448E-01,&
-0.5486207E-01, 0.4818965E-01, 0.4151724E-01, 0.3484483E-01, 0.2817241E-01,&
-0.2150000E-01, 0.2143550E-01, 0.2137100E-01, 0.2130650E-01, 0.2124200E-01,&
-0.2117750E-01, 0.2111300E-01, 0.2104850E-01, 0.2098400E-01, 0.2091950E-01,&
-0.2085500E-01, 0.2079050E-01, 0.2072600E-01, 0.2066150E-01, 0.2059700E-01,&
-0.2053250E-01, 0.2046800E-01, 0.2040350E-01, 0.2033900E-01, 0.2027450E-01,&
-0.2021000E-01, 0.2014550E-01, 0.2008100E-01, 0.2001650E-01, 0.1995200E-01,&
-0.1988750E-01, 0.1982300E-01, 0.1975850E-01, 0.1969400E-01, 0.1962950E-01,&
-0.1956500E-01, 0.1950050E-01, 0.1943600E-01, 0.1937150E-01, 0.1930700E-01,&
-0.1924250E-01, 0.1917800E-01, 0.1911350E-01, 0.1904900E-01, 0.1898450E-01,&
-0.1892000E-01, 0.1885550E-01, 0.1879100E-01, 0.1872650E-01, 0.1866200E-01,&
-0.1859750E-01, 0.1853300E-01, 0.1846850E-01, 0.1840400E-01, 0.1833950E-01,&
-0.1827500E-01, 0.1821050E-01, 0.1814600E-01, 0.1808150E-01, 0.1801700E-01,&
-0.1795250E-01, 0.1788800E-01, 0.1782350E-01, 0.1775900E-01, 0.1769450E-01,&
-0.1763000E-01, 0.1756550E-01, 0.1750100E-01, 0.1743650E-01, 0.1737200E-01,&
-0.1730750E-01, 0.1724300E-01, 0.1717850E-01, 0.1711400E-01, 0.1704950E-01,&
-0.1698500E-01, 0.1692050E-01, 0.1685600E-01, 0.1679150E-01, 0.1672700E-01,&
-0.1666250E-01, 0.1659800E-01, 0.1653350E-01, 0.1646900E-01, 0.1640450E-01,&
-0.1634000E-01, 0.1627550E-01, 0.1621100E-01, 0.1614650E-01, 0.1608200E-01,&
-0.1601750E-01, 0.1595300E-01, 0.1588850E-01, 0.1582400E-01, 0.1575950E-01,&
-0.1569500E-01, 0.1563050E-01, 0.1556600E-01, 0.1550150E-01, 0.1543700E-01,&
-0.1537250E-01, 0.1530800E-01, 0.1524350E-01, 0.1517900E-01, 0.1511450E-01,&
-0.1505000E-01, 0.1498550E-01, 0.1492100E-01, 0.1485650E-01, 0.1479200E-01,&
-0.1472750E-01, 0.1466300E-01, 0.1459850E-01, 0.1453400E-01, 0.1446950E-01,&
-0.1440500E-01, 0.1434050E-01, 0.1427600E-01, 0.1421150E-01, 0.1414700E-01,&
-0.1408250E-01, 0.1401800E-01, 0.1395350E-01, 0.1388900E-01, 0.1382450E-01,&
-0.1376000E-01, 0.1369550E-01, 0.1363100E-01, 0.1356650E-01, 0.1350200E-01,&
-0.1343750E-01, 0.1337300E-01, 0.1330850E-01, 0.1324400E-01, 0.1317950E-01,&
-0.1311500E-01, 0.1305050E-01, 0.1298600E-01, 0.1292150E-01, 0.1285700E-01,&
-0.1279250E-01, 0.1272800E-01, 0.1266350E-01, 0.1259900E-01, 0.1253450E-01,&
-0.1247000E-01, 0.1240550E-01, 0.1234100E-01, 0.1227650E-01, 0.1221200E-01,&
-0.1214750E-01, 0.1208300E-01, 0.1201850E-01, 0.1195400E-01, 0.1188950E-01,&
-0.1182500E-01, 0.1176050E-01, 0.1169600E-01, 0.1163150E-01, 0.1156700E-01,&
-0.1150250E-01, 0.1143800E-01, 0.1137350E-01, 0.1130900E-01, 0.1124450E-01,&
-0.1118000E-01, 0.1111550E-01, 0.1105100E-01, 0.1098650E-01, 0.1092200E-01,&
-0.1085750E-01, 0.1079300E-01, 0.1072850E-01, 0.1066400E-01, 0.1059950E-01,&
-0.1053500E-01, 0.1047050E-01, 0.1040600E-01, 0.1034150E-01, 0.1027700E-01,&
-0.1021250E-01, 0.1014800E-01, 0.1008350E-01, 0.1001900E-01, 0.9954500E-02,&
-0.9890000E-02, 0.9825500E-02, 0.9761000E-02, 0.9696500E-02, 0.9632000E-02,&
-0.9567500E-02, 0.9503000E-02, 0.9438500E-02, 0.9374000E-02, 0.9309500E-02,&
-0.9245000E-02, 0.9180500E-02, 0.9116000E-02, 0.9051500E-02, 0.8987000E-02,&
-0.8922500E-02, 0.8858000E-02, 0.8793500E-02, 0.8729000E-02, 0.8664500E-02,&
-0.8600000E-02, 0.8535500E-02, 0.8471000E-02, 0.8406500E-02, 0.8342000E-02,&
-0.8277500E-02, 0.8213000E-02, 0.8148500E-02, 0.8084000E-02, 0.8019500E-02,&
-0.7955000E-02, 0.7890500E-02, 0.7826000E-02, 0.7761500E-02, 0.7697000E-02,&
-0.7632500E-02, 0.7568000E-02, 0.7503500E-02, 0.7439000E-02, 0.7374500E-02,&
-0.7310000E-02, 0.7245500E-02, 0.7181000E-02, 0.7116500E-02, 0.7052000E-02,&
-0.6987500E-02, 0.6923000E-02, 0.6858500E-02, 0.6794000E-02, 0.6729500E-02,&
-0.6665000E-02, 0.6600500E-02, 0.6536000E-02, 0.6471500E-02, 0.6407000E-02,&
-0.6342500E-02, 0.6278000E-02, 0.6213500E-02, 0.6149000E-02, 0.6084500E-02,&
-0.6020000E-02, 0.5955500E-02, 0.5891000E-02, 0.5826500E-02, 0.5762000E-02,&
-0.5697500E-02, 0.5633000E-02, 0.5568500E-02, 0.5504000E-02, 0.5439500E-02,&
-0.5375000E-02, 0.5310500E-02, 0.5246000E-02, 0.5181500E-02, 0.5117000E-02,&
-0.5052500E-02, 0.4988000E-02, 0.4923500E-02, 0.4859000E-02, 0.4794500E-02,&
-0.4730000E-02, 0.4665500E-02, 0.4601000E-02, 0.4536500E-02, 0.4472000E-02,&
-0.4407500E-02, 0.4343000E-02, 0.4278500E-02, 0.4214000E-02, 0.4149500E-02,&
-0.4085000E-02, 0.4020500E-02, 0.3956000E-02, 0.3891500E-02, 0.3827000E-02,&
-0.3762500E-02, 0.3698000E-02, 0.3633500E-02, 0.3569000E-02, 0.3504500E-02,&
-0.3440000E-02, 0.3375500E-02, 0.3311000E-02, 0.3246500E-02, 0.3182000E-02,&
-0.3117500E-02, 0.3053000E-02, 0.2988500E-02, 0.2924000E-02, 0.2859500E-02,&
-0.2795000E-02, 0.2730500E-02, 0.2666000E-02, 0.2601500E-02, 0.2537000E-02,&
-0.2472500E-02, 0.2408000E-02, 0.2343500E-02, 0.2279000E-02, 0.2214500E-02,&
-0.2150000E-02 /)
-
-REAL, PARAMETER, DIMENSION(NNWL)::  XAKACHL2= &
-(/0.7745835E+00,  0.7522619E+00,  0.7299404E+00,  0.7076188E+00, 0.6852972E+00,&
-0.6629756E+00,  0.5767828E+00,  0.5011461E+00,  0.4285168E+00,  0.3946458E+00,&
-0.4330427E+00,  0.5309876E+00,  0.6371105E+00,  0.7297136E+00,  0.7904093E+00,&
-0.8097131E+00,  0.8760642E+00,  0.9381161E+00,  0.9457293E+00,  0.9258360E+00,&
-0.9025422E+00,  0.9252829E+00,  0.9270173E+00,  0.9995731E+00,  0.8171211E+00,&
-0.5353835E+00,  0.5329482E+00,  0.5348938E+00,  0.3804893E+00,  0.2089162E+00,&
-0.1108572E+00,  0.7056972E-01,  0.6340462E-01,  0.7044097E-01,  0.8182860E-01,&
-0.9896376E-01,  0.1267309E+00,  0.1598070E+00,  0.1993082E+00,  0.2502128E+00,&
-0.3026099E+00,  0.3196909E+00,  0.2917686E+00,  0.2666667E+00,  0.3314760E+00,&
-0.5711130E+00,  0.7452133E+00,  0.5497976E+00,  0.2406984E+00,  0.1315954E+00,&
-0.1197734E+00,  0.1258391E+00,  0.1367452E+00,  0.1552781E+00,  0.1936057E+00,&
-0.2571016E+00,  0.3363165E+00,  0.4064784E+00,  0.4289439E+00,  0.3819179E+00,&
-0.2987019E+00,  0.2160145E+00,  0.1343931E+00,  0.6321464E-01,  0.2241001E-01,&
-0.5134957E-02, -0.1242093E-02, -0.2531676E-02, -0.4085609E-02, -0.4713067E-02,&
--0.5693497E-02, -0.1090849E-01, -0.1407841E-01, -0.1816251E-01, -0.2587014E-01,&
--0.3565745E-01, -0.4546714E-01, -0.5446691E-01, -0.5650476E-01, -0.5981312E-01,&
--0.5981312E-01, -0.6451318E-01, -0.4835265E-01, -0.4864828E-01, -0.4876773E-01,&
--0.4840301E-01, -0.4866588E-01, -0.4836091E-01, -0.4851014E-01, -0.4860595E-01,&
--0.4852568E-01, -0.4805798E-01, -0.4859427E-01, -0.4795901E-01, -0.4846919E-01,&
--0.4850669E-01, -0.4854093E-01, -0.4849193E-01, -0.4841270E-01, -0.4855558E-01,&
--0.4827924E-01, -0.4906723E-01, -0.4822920E-01, -0.4818162E-01, -0.4854826E-01,&
--0.4875536E-01, -0.4863250E-01, -0.4843162E-01, -0.4836087E-01, -0.4913286E-01,&
--0.4884187E-01, -0.4864121E-01, -0.4865143E-01, -0.4821299E-01, -0.4880581E-01,&
--0.4887014E-01, -0.4868441E-01, -0.4861962E-01, -0.4806854E-01, -0.4918258E-01,&
--0.4813463E-01, -0.4876416E-01, -0.4831872E-01, -0.4867297E-01, -0.4862849E-01,&
--0.4836460E-01, -0.4858448E-01, -0.4886762E-01, -0.4875397E-01, -0.4863992E-01,&
--0.4862744E-01, -0.4887019E-01, -0.4816946E-01, -0.4892569E-01, -0.4864310E-01,&
--0.4881326E-01, -0.4819329E-01, -0.4852681E-01, -0.4803719E-01, -0.4831237E-01,&
--0.4866472E-01, -0.4815419E-01, -0.4873738E-01, -0.4851730E-01, -0.4848577E-01,&
--0.4881878E-01, -0.4878175E-01, -0.4839409E-01, -0.4850954E-01, -0.4846783E-01,&
--0.4847389E-01, -0.4833271E-01, -0.4859281E-01, -0.4863393E-01, -0.4839972E-01,&
--0.4851298E-01, -0.4831513E-01, -0.4842690E-01, -0.4784760E-01, -0.4914954E-01,&
--0.4866549E-01, -0.4890948E-01, -0.4834954E-01, -0.4830681E-01, -0.4859897E-01,&
--0.4838582E-01, -0.4851704E-01, -0.4866422E-01, -0.4881537E-01, -0.4851842E-01,&
--0.4877209E-01, -0.4873482E-01, -0.4825956E-01, -0.4852063E-01, -0.4867407E-01,&
--0.4878135E-01, -0.4830102E-01, -0.4826979E-01, -0.4870005E-01, -0.4902764E-01,&
--0.4871316E-01, -0.4853799E-01, -0.4867663E-01, -0.4823785E-01, -0.4855946E-01,&
--0.4875993E-01, -0.4846177E-01, -0.4886679E-01, -0.4859700E-01, -0.4809872E-01,&
--0.4822881E-01, -0.4837712E-01, -0.4855768E-01, -0.4867230E-01, -0.4838317E-01,&
--0.4876311E-01, -0.4812689E-01, -0.4820772E-01, -0.4904227E-01, -0.4871970E-01,&
--0.4853304E-01, -0.4859587E-01, -0.4845879E-01, -0.4837155E-01, -0.4874718E-01,&
--0.4873789E-01, -0.4851343E-01, -0.4851316E-01, -0.4901856E-01, -0.4836449E-01,&
--0.4880954E-01, -0.4853077E-01, -0.4898909E-01, -0.4812662E-01, -0.4832583E-01,&
--0.4847423E-01, -0.4846226E-01, -0.4844360E-01, -0.4835512E-01, -0.4893025E-01,&
--0.4853777E-01, -0.4873621E-01, -0.4832436E-01, -0.4854396E-01, -0.4848187E-01,&
--0.4850079E-01, -0.4843526E-01, -0.4818938E-01, -0.4874043E-01, -0.4847353E-01,&
--0.4865320E-01, -0.4853667E-01, -0.4859223E-01, -0.4872705E-01, -0.4821515E-01,&
--0.4844453E-01, -0.4870005E-01, -0.4881809E-01, -0.4865348E-01, -0.4871232E-01,&
--0.4859998E-01, -0.4833980E-01, -0.4860161E-01, -0.4839900E-01, -0.4853466E-01,&
--0.4864573E-01, -0.4863669E-01, -0.4901951E-01, -0.4832310E-01, -0.4890333E-01,&
--0.4880714E-01, -0.4855986E-01, -0.4852934E-01, -0.4818182E-01, -0.4795438E-01,&
--0.4834752E-01, -0.4810626E-01, -0.4861891E-01, -0.4872801E-01, -0.4814039E-01,&
--0.4894429E-01, -0.4881275E-01, -0.4903332E-01, -0.4835438E-01, -0.4865217E-01,&
--0.4853667E-01, -0.4841790E-01, -0.4869760E-01, -0.4900452E-01, -0.4856053E-01,&
--0.4825166E-01, -0.4837719E-01, -0.4872088E-01, -0.4873605E-01, -0.4868101E-01,&
--0.4883375E-01, -0.4870022E-01, -0.4875332E-01, -0.4836111E-01, -0.4863061E-01,&
--0.4875719E-01, -0.4874192E-01, -0.4847357E-01, -0.4867528E-01, -0.4836407E-01,&
--0.4828474E-01, -0.4860063E-01, -0.4861546E-01, -0.4864795E-01, -0.4844943E-01,&
--0.4904242E-01, -0.4843469E-01, -0.4866992E-01, -0.4900254E-01, -0.4864337E-01,&
--0.4844130E-01, -0.4837940E-01, -0.4855977E-01, -0.4874923E-01, -0.4906257E-01,&
--0.4864537E-01, -0.4834532E-01, -0.4869347E-01, -0.4858449E-01, -0.4877963E-01,&
--0.4863986E-01, -0.4848931E-01, -0.4836552E-01, -0.4849740E-01, -0.4887220E-01,&
--0.4904565E-01, -0.4872388E-01, -0.4810480E-01, -0.4806256E-01, -0.4874242E-01,&
--0.4819115E-01, -0.4862189E-01, -0.4871701E-01, -0.4839065E-01, -0.4877597E-01,&
--0.4905847E-01, -0.4861049E-01, -0.4812144E-01, -0.4872767E-01, -0.4891870E-01,&
--0.4890406E-01, -0.4818467E-01, -0.4847043E-01, -0.4841457E-01, -0.4821321E-01,&
--0.4847127E-01, -0.4868549E-01, -0.4910397E-01, -0.4863713E-01, -0.4831791E-01,&
--0.4807175E-01, -0.4877013E-01, -0.4882632E-01, -0.4808306E-01, -0.4848078E-01,&
--0.4849469E-01, -0.4864521E-01, -0.4823979E-01, -0.4866831E-01, -0.4870176E-01,&
--0.4837111E-01, -0.4899544E-01, -0.4904284E-01, -0.4913362E-01, -0.4821655E-01,&
--0.4833322E-01, -0.4831560E-01, -0.4840073E-01, -0.4852060E-01, -0.4897843E-01,&
--0.4829322E-01, -0.4884781E-01, -0.4827255E-01, -0.4827960E-01, -0.4864042E-01,&
--0.4828514E-01, -0.4897902E-01, -0.4855954E-01, -0.4855975E-01, -0.4858216E-01,&
--0.4827806E-01, -0.4847189E-01, -0.4860275E-01, -0.4906456E-01, -0.4853636E-01,&
--0.4862808E-01, -0.4848551E-01, -0.4869109E-01, -0.4848604E-01, -0.4866388E-01,&
--0.4846765E-01, -0.4875867E-01, -0.4807435E-01, -0.4867530E-01, -0.4888080E-01,&
--0.4844930E-01 /)
-
-
-
-
-
-
-
-!
-! table of seawater absorption coefficient as function of wavelength
-REAL, PARAMETER, DIMENSION(NNWL)::  XAKAW3= &
-(/0.3067439E+01, 0.1993737E+01, 0.1309263E+01, 0.9275307E+00, 0.7183294E+00,&
-0.5608010E+00, 0.4552411E+00, 0.3738498E+00, 0.2879400E+00, 0.2145172E+00,&
-0.1415658E+00, 0.1048958E+00, 0.8411996E-01, 0.6814662E-01, 0.5585442E-01,&
-0.4638546E-01, 0.3791143E-01, 0.2984669E-01, 0.2234093E-01, 0.1870175E-01,&
-0.1737227E-01, 0.1609624E-01, 0.1530537E-01, 0.1443961E-01, 0.1437088E-01,&
-0.1480803E-01, 0.1517563E-01, 0.1592806E-01, 0.1743279E-01, 0.1967369E-01,&
-0.2564243E-01, 0.3598580E-01, 0.4703195E-01, 0.5145027E-01, 0.5534469E-01,&
-0.6400512E-01, 0.7030880E-01, 0.8172981E-01, 0.1033439E+00, 0.1638825E+00,&
-0.2387544E+00, 0.2908335E+00, 0.3086321E+00, 0.3193000E+00, 0.3277702E+00,&
-0.3523264E+00, 0.3957919E+00, 0.4326377E+00, 0.4485145E+00, 0.5016078E+00,&
-0.6481431E+00, 0.8408502E+00, 0.1165249E+01, 0.1810640E+01, 0.2364421E+01,&
-0.2479177E+01, 0.2547112E+01, 0.2511108E+01, 0.2356959E+01, 0.2164139E+01,&
-0.2068389E+01, 0.2334173E+01, 0.3101571E+01, 0.3715746E+01, 0.4069374E+01,&
-0.4055130E+01, 0.3662220E+01, 0.3265983E+01, 0.3338288E+01, 0.4351006E+01,&
-0.6776006E+01, 0.1092508E+02, 0.1646968E+02, 0.2292120E+02, 0.2979101E+02,&
-0.3659049E+02, 0.4255537E+02, 0.4581877E+02, 0.4488433E+02, 0.4084045E+02,&
-0.3542173E+02, 0.3008784E+02, 0.2519888E+02, 0.2084002E+02, 0.1709645E+02,&
-0.1405336E+02, 0.1179592E+02, 0.1051821E+02, 0.1084989E+02, 0.1352949E+02,&
-0.1929556E+02, 0.2856379E+02, 0.4045844E+02, 0.5378094E+02, 0.6733270E+02,&
-0.7991512E+02, 0.9045451E+02, 0.9837671E+02, 0.1032324E+03, 0.1045724E+03,&
-0.1024582E+03, 0.9870555E+02, 0.9448188E+02, 0.9066481E+02, 0.8813195E+02,&
-0.8776093E+02, 0.9009315E+02, 0.9432506E+02, 0.9931691E+02, 0.1039289E+03,&
-0.1070213E+03, 0.1091415E+03, 0.1175854E+03, 0.1413362E+03, 0.1893769E+03,&
-0.2706907E+03, 0.3927593E+03, 0.5570592E+03, 0.7635654E+03, 0.1012253E+04,&
-0.1303097E+04, 0.1629710E+04, 0.1960254E+04, 0.2256530E+04, 0.2480335E+04,&
-0.2593472E+04, 0.2570322E+04, 0.2435603E+04, 0.2226617E+04, 0.1980665E+04,&
-0.1735048E+04, 0.1520186E+04, 0.1338970E+04, 0.1187410E+04, 0.1061517E+04,&
-0.9572996E+03, 0.8707689E+03, 0.7979346E+03, 0.7348066E+03, 0.6773950E+03,&
-0.6217097E+03, 0.5658621E+03, 0.5163686E+03, 0.4818471E+03, 0.4709154E+03,&
-0.4921914E+03, 0.5339673E+03, 0.5283995E+03, 0.4879842E+03, 0.4503842E+03,&
-0.4532622E+03, 0.5219655E+03, 0.6325787E+03, 0.7488713E+03, 0.8346125E+03,&
-0.8535717E+03, 0.7823218E+03, 0.6486514E+03, 0.4931527E+03, 0.3564180E+03,&
-0.2790396E+03, 0.2973530E+03, 0.4306661E+03, 0.6940303E+03, 0.1102497E+04,&
-0.1671116E+04, 0.2414941E+04, 0.3349021E+04, 0.4488408E+04, 0.5848154E+04,&
-0.7443309E+04, 0.9216590E+04, 0.1082137E+05, 0.1183869E+05, 0.1184960E+05,&
-0.1078493E+05, 0.9686200E+04, 0.8790378E+04, 0.8045845E+04, 0.7400985E+04,&
-0.6804181E+04, 0.6214741E+04, 0.5635665E+04, 0.5080881E+04, 0.4564313E+04,&
-0.4099888E+04, 0.3697940E+04, 0.3354440E+04, 0.3061767E+04, 0.2812299E+04,&
-0.2598416E+04, 0.2413350E+04, 0.2253741E+04, 0.2117085E+04, 0.2000874E+04,&
-0.1902603E+04, 0.1819767E+04, 0.1749858E+04, 0.1690372E+04, 0.1638801E+04,&
-0.1592640E+04, 0.1555394E+04, 0.1548293E+04, 0.1573317E+04, 0.1626133E+04,&
-0.1702405E+04, 0.1797857E+04, 0.1908438E+04, 0.2030156E+04, 0.2159016E+04,&
-0.2291026E+04, 0.2423482E+04, 0.2558843E+04, 0.2700856E+04, 0.2853272E+04,&
-0.3019837E+04, 0.3204129E+04, 0.3409039E+04, 0.3637285E+04, 0.3891587E+04,&
-0.4174664E+04, 0.4489235E+04, 0.4838020E+04, 0.5223737E+04, 0.5649106E+04,&
-0.6116846E+04, 0.6622627E+04, 0.7133928E+04, 0.7611180E+04, 0.8014812E+04,&
-0.8305254E+04, 0.8466704E+04, 0.8578431E+04, 0.8743467E+04, 0.9064849E+04,&
-0.9645611E+04, 0.1051240E+05, 0.1138630E+05, 0.1191200E+05, 0.1173420E+05,&
-0.1049759E+05, 0.8305364E+04, 0.7094721E+04, 0.9142031E+04, 0.1397930E+05,&
-0.1839416E+05, 0.1986234E+05, 0.1908920E+05, 0.1758752E+05, 0.1687005E+05,&
-0.1844957E+05, 0.2383885E+05, 0.3455066E+05, 0.5209777E+05, 0.7799295E+05,&
-0.1137490E+06, 0.1602886E+06, 0.2161751E+06, 0.2793814E+06, 0.3478807E+06,&
-0.4196461E+06, 0.4928405E+06, 0.5663854E+06, 0.6393920E+06, 0.7109715E+06,&
-0.7802351E+06, 0.8462941E+06, 0.9082596E+06, 0.9652429E+06, 0.1016355E+07,&
-0.1060708E+07, 0.1097549E+07, 0.1126679E+07, 0.1148035E+07, 0.1161554E+07,&
-0.1167173E+07, 0.1164996E+07, 0.1155796E+07, 0.1140514E+07, 0.1120088E+07,&
-0.1095461E+07, 0.1067479E+07, 0.1036628E+07, 0.1003298E+07, 0.9678839E+06,&
-0.9307769E+06, 0.8923695E+06, 0.8530543E+06, 0.8132238E+06, 0.7732703E+06,&
-0.7335864E+06, 0.6945089E+06, 0.6561521E+06, 0.6185746E+06, 0.5818354E+06,&
-0.5459929E+06, 0.5111060E+06, 0.4772333E+06, 0.4444336E+06, 0.4127655E+06,&
-0.3822878E+06, 0.3530592E+06, 0.3251383E+06, 0.2985839E+06, 0.2734547E+06,&
-0.2498094E+06, 0.2277067E+06, 0.2072053E+06, 0.1883639E+06, 0.1712413E+06,&
-0.1558960E+06, 0.1423474E+06, 0.1304565E+06, 0.1200447E+06, 0.1109338E+06,&
-0.1029451E+06, 0.9590033E+05, 0.8962092E+05, 0.8392845E+05, 0.7864446E+05,&
-0.7359050E+05, 0.6862405E+05, 0.6374646E+05, 0.5899502E+05, 0.5440700E+05,&
-0.5001969E+05, 0.4587039E+05, 0.4199638E+05, 0.3843495E+05, 0.3522339E+05,&
-0.3239897E+05, 0.2998538E+05, 0.2795181E+05, 0.2625384E+05, 0.2484704E+05,&
-0.2368700E+05, 0.2272929E+05, 0.2192950E+05, 0.2124319E+05, 0.2062596E+05,&
-0.2003338E+05, 0.1942931E+05, 0.1881074E+05, 0.1818297E+05, 0.1755126E+05,&
-0.1692090E+05, 0.1629717E+05, 0.1568535E+05, 0.1509072E+05, 0.1451856E+05,&
-0.1397415E+05, 0.1346277E+05, 0.1298970E+05, 0.1256022E+05, 0.1217961E+05,&
-0.1185315E+05, 0.1158473E+05, 0.1137272E+05, 0.1121409E+05, 0.1110580E+05,&
-0.1104483E+05, 0.1102816E+05, 0.1105274E+05, 0.1111556E+05, 0.1121359E+05,&
-0.1134380E+05, 0.1150316E+05, 0.1168864E+05, 0.1189722E+05, 0.1212586E+05,&
-0.1237155E+05, 0.1263124E+05, 0.1290192E+05, 0.1318056E+05, 0.1346412E+05,&
-0.1374958E+05, 0.1403392E+05, 0.1431409E+05, 0.1458709E+05, 0.1484987E+05,&
-0.1509941E+05 /)
-
-
-
-!
-! table of seawater backscattering coefficient as function of wavelength
-REAL, PARAMETER, DIMENSION(NNWL)::  XAKBW= &
-(/0.1510000E+00, 0.1190000E+00, 0.9950015E-01, 0.8199944E-01, 0.6850207E-01,&
-0.5749506E-01, 0.4850663E-01, 0.4149505E-01, 0.3530210E-01, 0.3049935E-01,&
-0.2620052E-01, 0.2289856E-01, 0.2000336E-01, 0.1749553E-01, 0.1530325E-01,&
-0.1339897E-01, 0.1199900E-01, 0.1060502E-01, 0.9387780E-02, 0.8416411E-02,&
-0.7587748E-02, 0.6805146E-02, 0.6098530E-02, 0.5500733E-02, 0.4898538E-02,&
-0.4503288E-02, 0.4095613E-02, 0.3703303E-02, 0.3398477E-02, 0.3100964E-02,&
-0.2897666E-02, 0.2608371E-02, 0.2380034E-02, 0.2226757E-02, 0.2080041E-02,&
-0.1908345E-02, 0.1797763E-02, 0.1700603E-02, 0.1599833E-02, 0.1500036E-02,&
-0.1400066E-02, 0.1299673E-02, 0.1201250E-02, 0.1095326E-02, 0.1017446E-02,&
-0.9582712E-03, 0.8559384E-03, 0.7582711E-03, 0.7174466E-03, 0.6953252E-03,&
-0.7012525E-03, 0.6996646E-03, 0.6000893E-03, 0.5999768E-03, 0.6000058E-03,&
-0.4999986E-03, 0.5000004E-03, 0.4999999E-03, 0.4000000E-03, 0.4000000E-03,&
-0.4000000E-03, 0.4000000E-03, 0.3987586E-03, 0.3975172E-03, 0.3962759E-03,&
-0.3950345E-03, 0.3937931E-03, 0.3925517E-03, 0.3913103E-03, 0.3900690E-03,&
-0.3888276E-03, 0.3875862E-03, 0.3863448E-03, 0.3851035E-03, 0.3838621E-03,&
-0.3826207E-03, 0.3813793E-03, 0.3801379E-03, 0.3788965E-03, 0.3776552E-03,&
-0.3764138E-03, 0.3751724E-03, 0.3739310E-03, 0.3726897E-03, 0.3714483E-03,&
-0.3702069E-03, 0.3689655E-03, 0.3677241E-03, 0.3664828E-03, 0.3652414E-03,&
-0.3640000E-03, 0.3627586E-03, 0.3615172E-03, 0.3602759E-03, 0.3590345E-03,&
-0.3577931E-03, 0.3565517E-03, 0.3553103E-03, 0.3540690E-03, 0.3528276E-03,&
-0.3515862E-03, 0.3503448E-03, 0.3491034E-03, 0.3478621E-03, 0.3466207E-03,&
-0.3453793E-03, 0.3441379E-03, 0.3428966E-03, 0.3416552E-03, 0.3404138E-03,&
-0.3391724E-03, 0.3379310E-03, 0.3366896E-03, 0.3354483E-03, 0.3342069E-03,&
-0.3329655E-03, 0.3317241E-03, 0.3304828E-03, 0.3292414E-03, 0.3280000E-03,&
-0.3267586E-03, 0.3255172E-03, 0.3242759E-03, 0.3230345E-03, 0.3217931E-03,&
-0.3205517E-03, 0.3193103E-03, 0.3180690E-03, 0.3168276E-03, 0.3155862E-03,&
-0.3143448E-03, 0.3131035E-03, 0.3118621E-03, 0.3106207E-03, 0.3093793E-03,&
-0.3081379E-03, 0.3068965E-03, 0.3056552E-03, 0.3044138E-03, 0.3031724E-03,&
-0.3019310E-03, 0.3006897E-03, 0.2994483E-03, 0.2982069E-03, 0.2969655E-03,&
-0.2957241E-03, 0.2944828E-03, 0.2932414E-03, 0.2920000E-03, 0.2907586E-03,&
-0.2895173E-03, 0.2882759E-03, 0.2870345E-03, 0.2857931E-03, 0.2845517E-03,&
-0.2833103E-03, 0.2820690E-03, 0.2808276E-03, 0.2795862E-03, 0.2783448E-03,&
-0.2771034E-03, 0.2758621E-03, 0.2746207E-03, 0.2733793E-03, 0.2721379E-03,&
-0.2708966E-03, 0.2696552E-03, 0.2684138E-03, 0.2671724E-03, 0.2659310E-03,&
-0.2646896E-03, 0.2634483E-03, 0.2622069E-03, 0.2609655E-03, 0.2597241E-03,&
-0.2584828E-03, 0.2572414E-03, 0.2560000E-03, 0.2547586E-03, 0.2535172E-03,&
-0.2522759E-03, 0.2510345E-03, 0.2497931E-03, 0.2485517E-03, 0.2473104E-03,&
-0.2460690E-03, 0.2448276E-03, 0.2435862E-03, 0.2423448E-03, 0.2411035E-03,&
-0.2398621E-03, 0.2386207E-03, 0.2373793E-03, 0.2361379E-03, 0.2348965E-03,&
-0.2336552E-03, 0.2324138E-03, 0.2311724E-03, 0.2299310E-03, 0.2286896E-03,&
-0.2274483E-03, 0.2262069E-03, 0.2249655E-03, 0.2237241E-03, 0.2224828E-03,&
-0.2212414E-03, 0.2200000E-03, 0.2187586E-03, 0.2175172E-03, 0.2162759E-03,&
-0.2150345E-03, 0.2137931E-03, 0.2125517E-03, 0.2113103E-03, 0.2100690E-03,&
-0.2088276E-03, 0.2075862E-03, 0.2063448E-03, 0.2051035E-03, 0.2038621E-03,&
-0.2026207E-03, 0.2013793E-03, 0.2001379E-03, 0.1988966E-03, 0.1976552E-03,&
-0.1964138E-03, 0.1951724E-03, 0.1939310E-03, 0.1926897E-03, 0.1914483E-03,&
-0.1902069E-03, 0.1889655E-03, 0.1877241E-03, 0.1864828E-03, 0.1852414E-03,&
-0.1840000E-03, 0.1827586E-03, 0.1815172E-03, 0.1802759E-03, 0.1790345E-03,&
-0.1777931E-03, 0.1765517E-03, 0.1753103E-03, 0.1740690E-03, 0.1728276E-03,&
-0.1715862E-03, 0.1703448E-03, 0.1691034E-03, 0.1678621E-03, 0.1666207E-03,&
-0.1653793E-03, 0.1641379E-03, 0.1628966E-03, 0.1616552E-03, 0.1604138E-03,&
-0.1591724E-03, 0.1579310E-03, 0.1566897E-03, 0.1554483E-03, 0.1542069E-03,&
-0.1529655E-03, 0.1517241E-03, 0.1504828E-03, 0.1492414E-03, 0.1480000E-03,&
-0.1467586E-03, 0.1455172E-03, 0.1442759E-03, 0.1430345E-03, 0.1417931E-03,&
-0.1405517E-03, 0.1393103E-03, 0.1380690E-03, 0.1368276E-03, 0.1355862E-03,&
-0.1343448E-03, 0.1331034E-03, 0.1318621E-03, 0.1306207E-03, 0.1293793E-03,&
-0.1281379E-03, 0.1268966E-03, 0.1256552E-03, 0.1244138E-03, 0.1231724E-03,&
-0.1219310E-03, 0.1206897E-03, 0.1194483E-03, 0.1182069E-03, 0.1169655E-03,&
-0.1157241E-03, 0.1144828E-03, 0.1132414E-03, 0.1120000E-03, 0.1107586E-03,&
-0.1095172E-03, 0.1082759E-03, 0.1070345E-03, 0.1057931E-03, 0.1045517E-03,&
-0.1033103E-03, 0.1020690E-03, 0.1008276E-03, 0.9958621E-04, 0.9834483E-04,&
-0.9710345E-04, 0.9586207E-04, 0.9462069E-04, 0.9337931E-04, 0.9213793E-04,&
-0.9089655E-04, 0.8965517E-04, 0.8841379E-04, 0.8717241E-04, 0.8593103E-04,&
-0.8468966E-04, 0.8344828E-04, 0.8220690E-04, 0.8096552E-04, 0.7972414E-04,&
-0.7848276E-04, 0.7724138E-04, 0.7600000E-04, 0.7475862E-04, 0.7351724E-04,&
-0.7227586E-04, 0.7103448E-04, 0.6979310E-04, 0.6855172E-04, 0.6731034E-04,&
-0.6606896E-04, 0.6482759E-04, 0.6358621E-04, 0.6234483E-04, 0.6110345E-04,&
-0.5986207E-04, 0.5862069E-04, 0.5737931E-04, 0.5613793E-04, 0.5489655E-04,&
-0.5365517E-04, 0.5241379E-04, 0.5117241E-04, 0.4993103E-04, 0.4868966E-04,&
-0.4744828E-04, 0.4620690E-04, 0.4496552E-04, 0.4372414E-04, 0.4248276E-04,&
-0.4124138E-04, 0.4000000E-04, 0.3875862E-04, 0.3751724E-04, 0.3627586E-04,&
-0.3503448E-04, 0.3379311E-04, 0.3255172E-04, 0.3131034E-04, 0.3006897E-04,&
-0.2882759E-04, 0.2758621E-04, 0.2634483E-04, 0.2510345E-04, 0.2386207E-04,&
-0.2262069E-04, 0.2137931E-04, 0.2013793E-04, 0.1889655E-04, 0.1765517E-04,&
-0.1641379E-04, 0.1517241E-04, 0.1393103E-04, 0.1268965E-04, 0.1144828E-04,&
-0.1020690E-04, 0.8965517E-05, 0.7724138E-05, 0.6482759E-05, 0.5241379E-05,&
-0.4000000E-05 /)
-
-! white-caps reflectance (Koepke and Whitlock)
-! Whitlock fit varid 400nm - 2.4nm. set albedo 0 otherwise 
-REAL, PARAMETER, DIMENSION(NNWL)::  XRWC   = &
-(/0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00,&
-0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00,&
-0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00,&
-0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00,&
-0.1986623E+00, 0.1968392E+00, 0.1955961E+00, 0.1941208E+00, 0.1939980E+00,&
-0.1947642E+00, 0.1953830E+00, 0.1965826E+00, 0.1987437E+00, 0.2014820E+00,&
-0.2068586E+00, 0.2125197E+00, 0.2160829E+00, 0.2171109E+00, 0.2178881E+00,&
-0.2192886E+00, 0.2200949E+00, 0.2212391E+00, 0.2227055E+00, 0.2247944E+00,&
-0.2262073E+00, 0.2270383E+00, 0.2273185E+00, 0.2274869E+00, 0.2276210E+00,&
-0.2280129E+00, 0.2287211E+00, 0.2293381E+00, 0.2296089E+00, 0.2305354E+00,&
-0.2332379E+00, 0.2370188E+00, 0.2373674E+00, 0.2314480E+00, 0.2291741E+00,&
-0.2288465E+00, 0.2286684E+00, 0.2287614E+00, 0.2291967E+00, 0.2298426E+00,&
-0.2302154E+00, 0.2292666E+00, 0.2275362E+00, 0.2266957E+00, 0.2263213E+00,&
-0.2263353E+00, 0.2267580E+00, 0.2272800E+00, 0.2271755E+00, 0.2260595E+00,&
-0.2243821E+00, 0.2219912E+00, 0.2188027E+00, 0.2151597E+00, 0.2114653E+00,&
-0.2080255E+00, 0.2051811E+00, 0.2036894E+00, 0.2041120E+00, 0.2059829E+00,&
-0.2086015E+00, 0.2113106E+00, 0.2139111E+00, 0.2163195E+00, 0.2184435E+00,&
-0.2201926E+00, 0.2214916E+00, 0.2222242E+00, 0.2220343E+00, 0.2204943E+00,&
-0.2171906E+00, 0.2121093E+00, 0.2061633E+00, 0.2002262E+00, 0.1948388E+00,&
-0.1903174E+00, 0.1868275E+00, 0.1843590E+00, 0.1829052E+00, 0.1825115E+00,&
-0.1831341E+00, 0.1842591E+00, 0.1855570E+00, 0.1867604E+00, 0.1875755E+00,&
-0.1876960E+00, 0.1869431E+00, 0.1856059E+00, 0.1840741E+00, 0.1827001E+00,&
-0.1818000E+00, 0.1811922E+00, 0.1788437E+00, 0.1727826E+00, 0.1624180E+00,&
-0.1487052E+00, 0.1334511E+00, 0.1185638E+00, 0.1049801E+00, 0.9298412E-01,&
-0.8257660E-01, 0.7379698E-01, 0.6696978E-01, 0.6208307E-01, 0.5897739E-01,&
-0.5756657E-01, 0.5784728E-01, 0.5956322E-01, 0.6253327E-01, 0.6660015E-01,&
-0.7143353E-01, 0.7647427E-01, 0.8148541E-01, 0.8635699E-01, 0.9099500E-01,&
-0.9533520E-01, 0.9935633E-01, 0.1030906E+00, 0.1066306E+00, 0.1101345E+00,&
-0.1138333E+00, 0.1178890E+00, 0.1218228E+00, 0.1247853E+00, 0.1257652E+00,&
-0.1238772E+00, 0.1203841E+00, 0.1208343E+00, 0.1242444E+00, 0.1276640E+00,&
-0.1273930E+00, 0.1213602E+00, 0.1130860E+00, 0.1058152E+00, 0.1011666E+00,&
-0.1002071E+00, 0.1039381E+00, 0.1120040E+00, 0.1237937E+00, 0.1375058E+00,&
-0.1474928E+00, 0.1449352E+00, 0.1295643E+00, 0.1090889E+00, 0.8941860E-01,&
-0.7284467E-01, 0.5983944E-01, 0.5022947E-01, 0.4366299E-01, 0.3977196E-01,&
-0.3822227E-01, 0.3867308E-01, 0.4026759E-01, 0.4166813E-01, 0.4168444E-01,&
-0.4022229E-01, 0.3904642E-01, 0.3841435E-01, 0.3817649E-01, 0.3823472E-01,&
-0.3855810E-01, 0.3919018E-01, 0.4018588E-01, 0.4157600E-01, 0.4335490E-01,&
-0.4545942E-01, 0.4776782E-01, 0.5018748E-01, 0.5264894E-01, 0.5509888E-01,&
-0.5750712E-01, 0.5986086E-01, 0.6212466E-01, 0.6426051E-01, 0.6623940E-01,&
-0.6804333E-01, 0.6966664E-01, 0.7111643E-01, 0.7241227E-01, 0.7358521E-01,&
-0.7467659E-01, 0.7558735E-01, 0.7576417E-01, 0.7514564E-01, 0.7388073E-01,&
-0.7214532E-01, 0.7011285E-01, 0.6793264E-01, 0.6572567E-01, 0.6358425E-01,&
-0.6157472E-01, 0.5972482E-01, 0.5798797E-01, 0.5631501E-01, 0.5467161E-01,&
-0.5303634E-01, 0.5140076E-01, 0.4977145E-01, 0.4816243E-01, 0.4659231E-01,&
-0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00,&
-0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00,&
-0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00,&
-0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00,&
-0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00,&
-0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00,&
-0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00,&
-0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00,&
-0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00,&
-0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00,&
-0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00,&
-0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00,&
-0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00,&
-0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00,&
-0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00,&
-0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00,&
-0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00,&
-0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00,&
-0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00,&
-0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00,&
-0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00,&
-0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00,&
-0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00,&
-0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00,&
-0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00,&
-0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00,&
-0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00,&
-0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00,&
-0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00,&
-0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00,&
-0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00,&
-0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00,&
-0.0000000E+00 /)
-
-
-!
-!--------------------------------------------------------------------------------
-!
-END MODULE 
-
-
-
-
-
-
-
-
-
-
-
-
Index: /LMDZ6/trunk/libf/phylmd/ocean_albedo_para.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/ocean_albedo_para.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/ocean_albedo_para.f90	(revision 5268)
@@ -0,0 +1,646 @@
+!
+! $Id$
+!
+!     ######################
+MODULE ocean_albedo_para
+!     ######################
+!
+!!****  *MOD_DALBEDO_RS14* - declaration of ISBA parameters
+!!
+!!    PURPOSE
+!!    -------
+!       The purpose of this declarative module is to specify  the 
+!     parameters related to direct & diffuse albedo over open water 
+!
+!!
+!!      
+!!
+!!    AUTHOR
+!!    ------
+!!	R. Séférian           * Meteo-France *
+!!
+!!    MODIFICATIONS
+!!    -------------
+!       S. Baek : extention from 200-800nm to 200-40000nm 
+!-------------------------------------------------------------------------------
+!
+!*       0.   DECLARATIONS
+!             ------------
+!
+
+IMPLICIT NONE
+!
+INTEGER, PARAMETER   :: NNWL = 381                ! number of wavelength
+!
+! absorption coefficients for seawater et 440 nm
+REAL, PARAMETER      :: XAW440 =  0.00635
+!
+!! white-caps reflectance (Koepke , 1983 estimation)
+!REAL, PARAMETER      :: XRWC   =  0.55
+!
+! table of wavelength discretization
+REAL, PARAMETER, DIMENSION(NNWL)::  XAKWL= &
+    (/ 200.0, 210.0, 220.0, 230.0, 240.0, 250.0, 260.0, 270.0, 280.0,  &
+    290.0, 300.0, 310.0, 320.0, 330.0, 340.0, 350.0, 360.0, 370.0,            &
+    380.0, 390.0, 400.0, 410.0, 420.0, 430.0, 440.0, 450.0, 460.0,            &
+    470.0, 480.0, 490.0, 500.0, 510.0, 520.0, 530.0, 540.0, 550.0,            &
+    560.0, 570.0, 580.0, 590.0, 600.0, 610.0, 620.0, 630.0, 640.0,            &
+    650.0, 660.0, 670.0, 680.0, 690.0, 700.0, 710.0, 720.0, 730.0,            &
+    740.0, 750.0, 760.0, 770.0, 780.0, 790.0, 800.0, 810.0, 820.0,            &
+    830.0, 840.0, 850.0, 860.0, 870.0, 880.0, 890.0, 900.0, 910.0,            &
+    920.0, 930.0, 940.0, 950.0, 960.0, 970.0, 980.0, 990.0, 1000.0, 1010.0,   &
+    1020.0, 1030.0, 1040.0, 1050.0, 1060.0, 1070.0, 1080.0, 1090.0, 1100.0,   &
+    1110.0, 1120.0, 1130.0, 1140.0, 1150.0, 1160.0, 1170.0, 1180.0, 1190.0,   &
+    1200.0, 1210.0, 1220.0, 1230.0, 1240.0, 1250.0, 1260.0, 1270.0, 1280.0,   &
+    1290.0, 1300.0, 1310.0, 1320.0, 1330.0, 1340.0, 1350.0, 1360.0, 1370.0,   &
+    1380.0, 1390.0, 1400.0, 1410.0, 1420.0, 1430.0, 1440.0, 1450.0, 1460.0,   &
+    1470.0, 1480.0, 1490.0, 1500.0, 1510.0, 1520.0, 1530.0, 1540.0, 1550.0,   &
+    1560.0, 1570.0, 1580.0, 1590.0, 1600.0, 1610.0, 1620.0, 1630.0, 1640.0,   &
+    1650.0, 1660.0, 1670.0, 1680.0, 1690.0, 1700.0, 1710.0, 1720.0, 1730.0,   &
+    1740.0, 1750.0, 1760.0, 1770.0, 1780.0, 1790.0, 1800.0, 1810.0, 1820.0,   &
+    1830.0, 1840.0, 1850.0, 1860.0, 1870.0, 1880.0, 1890.0, 1900.0, 1910.0,   &
+1920.0, 1930.0, 1940.0, 1950.0, 1960.0, 1970.0, 1980.0, 1990.0, 2000.0, 2010.0,& 
+2020.0, 2030.0, 2040.0, 2050.0, 2060.0, 2070.0, 2080.0, 2090.0, 2100.0, 2110.0,&
+2120.0, 2130.0, 2140.0, 2150.0, 2160.0, 2170.0, 2180.0, 2190.0, 2200.0, 2210.0,&
+2220.0, 2230.0, 2240.0, 2250.0, 2260.0, 2270.0, 2280.0, 2290.0, 2300.0, 2310.0,&
+2320.0, 2330.0, 2340.0, 2350.0, 2360.0, 2370.0, 2380.0, 2390.0, 2400.0, 2410.0,&
+2420.0, 2430.0, 2440.0, 2450.0, 2460.0, 2470.0, 2480.0, 2490.0, 2500.0, 2510.0,&
+2520.0, 2530.0, 2540.0, 2550.0, 2560.0, 2570.0, 2580.0, 2590.0, 2600.0, 2610.0,&
+2620.0, 2630.0, 2640.0, 2650.0, 2660.0, 2670.0, 2680.0, 2690.0, 2700.0, 2710.0,&
+2720.0, 2730.0, 2740.0, 2750.0, 2760.0, 2770.0, 2780.0, 2790.0, 2800.0, 2810.0,&
+2820.0, 2830.0, 2840.0, 2850.0, 2860.0, 2870.0, 2880.0, 2890.0, 2900.0, 2910.0,&
+2920.0, 2930.0, 2940.0, 2950.0, 2960.0, 2970.0, 2980.0, 2990.0, 3000.0, 3010.0,&
+3020.0, 3030.0, 3040.0, 3050.0, 3060.0, 3070.0, 3080.0, 3090.0, 3100.0, 3110.0,&
+3120.0, 3130.0, 3140.0, 3150.0, 3160.0, 3170.0, 3180.0, 3190.0, 3200.0, 3210.0,&
+3220.0, 3230.0, 3240.0, 3250.0, 3260.0, 3270.0, 3280.0, 3290.0, 3300.0, 3310.0,&
+3320.0, 3330.0, 3340.0, 3350.0, 3360.0, 3370.0, 3380.0, 3390.0, 3400.0, 3410.0,&
+3420.0, 3430.0, 3440.0, 3450.0, 3460.0, 3470.0, 3480.0, 3490.0, 3500.0, 3510.0,&
+3520.0, 3530.0, 3540.0, 3550.0, 3560.0, 3570.0, 3580.0, 3590.0, 3600.0, 3610.0,&
+3620.0, 3630.0, 3640.0, 3650.0, 3660.0, 3670.0, 3680.0, 3690.0, 3700.0, 3710.0,&
+3720.0, 3730.0, 3740.0, 3750.0, 3760.0, 3770.0, 3780.0, 3790.0, 3800.0, 3810.0,&
+3820.0, 3830.0, 3840.0, 3850.0, 3860.0, 3870.0, 3880.0, 3890.0, 3900.0, 3910.0,&
+3920.0, 3930.0, 3940.0, 3950.0, 3960.0, 3970.0, 3980.0, 3990.0, 4000.0 /) 
+
+
+ 
+!
+! proportion of each wavelength
+REAL, PARAMETER, DIMENSION(NNWL)::  XFRWL= &
+(/0.5399519E-04, 0.2057802E-03, 0.3488387E-03, 0.3841427E-03, 0.2915711E-03, &
+0.4429581E-03, 0.6302387E-03, 0.1970095E-02, 0.6974564E-03, 0.4431792E-02,   &
+0.3095547E-02, 0.4587307E-02, 0.5933870E-02, 0.7488277E-02, 0.7421943E-02,   &
+0.7738869E-02, 0.7155137E-02, 0.8394831E-02, 0.8859162E-02, 0.9190828E-02,   &
+0.1239693E-01, 0.1129138E-01, 0.1294971E-01, 0.8365349E-02, 0.1262541E-01,&
+0.1580203E-01, 0.1503552E-01, 0.1383415E-01, 0.1499867E-01, 0.1479230E-01,&
+0.1368674E-01, 0.1435007E-01, 0.1349511E-01, 0.1438693E-01, 0.1303815E-01,&
+0.1372359E-01, 0.1358356E-01, 0.1303815E-01, 0.1354671E-01, 0.1336245E-01,&
+0.1286863E-01, 0.1255171E-01, 0.1278019E-01, 0.1208001E-01, 0.1189575E-01,&
+0.1183678E-01, 0.1157882E-01, 0.1117345E-01, 0.1099656E-01, 0.1067227E-01,&
+0.1021531E-01, 0.1020794E-01, 0.9809937E-02, 0.9773086E-02, 0.9271902E-02,&
+0.9301383E-02, 0.9117125E-02, 0.8873903E-02, 0.8748608E-02, 0.8534866E-02,&
+0.8416941E-02, 0.8210571E-02, 0.7959980E-02, 0.7834683E-02, 0.7665165E-02,&
+0.7119759E-02, 0.7347503E-02, 0.7183881E-02, 0.7041634E-02, 0.7023945E-02,&
+0.6749768E-02, 0.6571406E-02, 0.6565509E-02, 0.6395254E-02, 0.6219103E-02,&
+0.6168247E-02, 0.6007574E-02, 0.5866062E-02, 0.5709074E-02, 0.5557982E-02,&
+0.5512286E-02, 0.5389938E-02, 0.5189464E-02, 0.5112813E-02, 0.4983095E-02,&
+0.4880646E-02, 0.4728080E-02, 0.4599837E-02, 0.4604259E-02, 0.4568881E-02,&
+0.4453166E-02, 0.4352930E-02, 0.4231319E-02, 0.4166460E-02, 0.4075804E-02,&
+0.4045586E-02, 0.3921027E-02, 0.3888597E-02, 0.3861327E-02, 0.3747823E-02,&
+0.3687387E-02, 0.3598206E-02, 0.3593046E-02, 0.3531872E-02, 0.3429424E-02,&
+0.3408050E-02, 0.3338769E-02, 0.3282018E-02, 0.3210525E-02, 0.3136085E-02,&
+0.3085229E-02, 0.3026266E-02, 0.2959933E-02, 0.2858222E-02, 0.2793363E-02,&
+0.2744719E-02, 0.2707130E-02, 0.2652589E-02, 0.2637849E-02, 0.2584045E-02,&
+0.2525819E-02, 0.2519186E-02, 0.2474227E-02, 0.2400524E-02, 0.2349668E-02,&
+0.2348931E-02, 0.2326083E-02, 0.2286283E-02, 0.2261224E-02, 0.2222161E-02,&
+0.2219213E-02, 0.2172043E-02, 0.2112343E-02, 0.2037902E-02, 0.2012106E-02,&
+0.1999576E-02, 0.1977465E-02, 0.1949458E-02, 0.1953143E-02, 0.1772569E-02,&
+0.1851432E-02, 0.1768884E-02, 0.1746036E-02, 0.1763725E-02, 0.1667173E-02,&
+0.1674544E-02, 0.1654644E-02, 0.1639903E-02, 0.1533033E-02, 0.1551459E-02,&
+0.1520504E-02, 0.1483652E-02, 0.1468911E-02, 0.1462278E-02, 0.1404052E-02,&
+0.1369411E-02, 0.1349511E-02, 0.1320030E-02, 0.1294234E-02, 0.1277282E-02,&
+0.1252223E-02, 0.1242641E-02, 0.1176308E-02, 0.1183679E-02, 0.1151249E-02,&
+0.1139456E-02, 0.1107764E-02, 0.1111449E-02, 0.1077545E-02, 0.1049538E-02,&
+0.1029638E-02, 0.1015634E-02, 0.9824679E-03, 0.9677272E-03, 0.9574086E-03,&
+0.9294013E-03, 0.9294013E-03, 0.9131865E-03, 0.8814940E-03, 0.8829681E-03,&
+0.8623311E-03, 0.8468534E-03, 0.8225312E-03, 0.8004201E-03, 0.7945239E-03,&
+0.7805202E-03, 0.7576721E-03, 0.7392463E-03, 0.7280433E-03, 0.7214100E-03,&
+0.7079960E-03, 0.6925183E-03, 0.6836001E-03, 0.6787357E-03, 0.6694490E-03,&
+0.6601624E-03, 0.6471906E-03, 0.6306809E-03, 0.6262587E-03, 0.6120340E-03,&
+0.6091595E-03, 0.5955244E-03, 0.5894070E-03, 0.5771722E-03, 0.5630211E-03,&
+0.5557982E-03, 0.5469538E-03, 0.5378146E-03, 0.5280857E-03, 0.5240319E-03,&
+0.5124605E-03, 0.5063431E-03, 0.4988254E-03, 0.4876225E-03, 0.4805469E-03,&
+0.4756088E-03, 0.4649218E-03, 0.4577725E-03, 0.4548981E-03, 0.4443585E-03,&
+0.4380937E-03, 0.4349982E-03, 0.4252693E-03, 0.4209945E-03, 0.4156141E-03,&
+0.4025686E-03, 0.4022001E-03, 0.3895231E-03, 0.3815631E-03, 0.3851009E-03,&
+0.3799416E-03, 0.3736400E-03, 0.3673383E-03, 0.3610735E-03, 0.3548087E-03,&
+0.3495758E-03, 0.3443428E-03, 0.3398469E-03, 0.3353510E-03, 0.3319237E-03,&
+0.3284966E-03, 0.3228951E-03, 0.3172936E-03, 0.3138296E-03, 0.3103655E-03,&
+0.3055011E-03, 0.3006366E-03, 0.2965461E-03, 0.2924555E-03, 0.2887335E-03,&
+0.2850115E-03, 0.2811789E-03, 0.2773463E-03, 0.2736611E-03, 0.2699760E-03,&
+0.2656643E-03, 0.2613527E-03, 0.2584782E-03, 0.2556038E-03, 0.2525451E-03,&
+0.2494864E-03, 0.2462434E-03, 0.2430005E-03, 0.2397575E-03, 0.2365146E-03,&
+0.2331979E-03, 0.2298813E-03, 0.2266752E-03, 0.2234690E-03, 0.2211474E-03,&
+0.2188257E-03, 0.2159144E-03, 0.2130031E-03, 0.2103130E-03, 0.2076228E-03,&
+0.2051537E-03, 0.2026847E-03, 0.2001787E-03, 0.1976728E-03, 0.1950932E-03,&
+0.1925136E-03, 0.1901182E-03, 0.1877228E-03, 0.1847010E-03, 0.1816792E-03,&
+0.1800945E-03, 0.1785099E-03, 0.1763725E-03, 0.1742351E-03, 0.1720977E-03,&
+0.1699603E-03, 0.1677492E-03, 0.1655381E-03, 0.1637692E-03, 0.1620003E-03,&
+0.1600103E-03, 0.1580203E-03, 0.1562514E-03, 0.1544826E-03, 0.1527137E-03,&
+0.1509448E-03, 0.1491759E-03, 0.1474070E-03, 0.1456013E-03, 0.1437956E-03,&
+0.1421741E-03, 0.1405526E-03, 0.1387469E-03, 0.1369411E-03, 0.1348774E-03,&
+0.1328137E-03, 0.1315608E-03, 0.1303078E-03, 0.1291654E-03, 0.1280230E-03,&
+0.1265489E-03, 0.1250749E-03, 0.1236745E-03, 0.1222741E-03, 0.1206526E-03,&
+0.1190312E-03, 0.1178888E-03, 0.1167464E-03, 0.1156408E-03, 0.1145353E-03,&
+0.1132823E-03, 0.1120294E-03, 0.1107764E-03, 0.1095234E-03, 0.1084179E-03,&
+0.1073123E-03, 0.1061699E-03, 0.1050275E-03, 0.1038483E-03, 0.1026690E-03,&
+0.1015266E-03, 0.1003842E-03, 0.9935234E-04, 0.9832049E-04, 0.9732549E-04,&
+0.9633049E-04, 0.9537235E-04, 0.9441420E-04, 0.9330864E-04, 0.9220310E-04,&
+0.9113440E-04, 0.9006570E-04, 0.8899700E-04, 0.8792829E-04, 0.8678589E-04,&
+0.8564349E-04, 0.8501700E-04, 0.8439052E-04, 0.8302701E-04, 0.8166349E-04,&
+0.8122127E-04, 0.8077905E-04, 0.8011572E-04, 0.7945239E-04, 0.7867850E-04,&
+0.7790462E-04, 0.7720443E-04, 0.7650425E-04, 0.7580406E-04, 0.7510388E-04,&
+0.7434105E-04, 0.7357822E-04, 0.7283750E-04, 0.7209678E-04, 0.7142239E-04,&
+0.7074801E-04, 0.7011415E-04, 0.6948030E-04, 0.6876537E-04, 0.6805045E-04,&
+0.6730973E-04, 0.6656901E-04, 0.6592411E-04, 0.6527920E-04, 0.6458639E-04,&
+0.6389357E-04 /) 
+
+
+!
+! Table for computing Reflectance just below ocean surface (bounded to 200-800 nm)
+! table of refractive index as function of wavelength
+REAL, PARAMETER, DIMENSION(NNWL)::  XAKREFM= &
+(/ 1.4517,  1.4345,  1.4214,  1.4108,  1.4022,  1.3950,  1.3889,  1.3836,      &
+1.3790,  1.3750,  1.3714,  1.3682,  1.3653,  1.3627,  1.3604,  1.3582,  1.3562,&
+1.3544,  1.3528,  1.3512,  1.3498,  1.3484,  1.3472,  1.3460,  1.3449,  1.3439,&
+1.3429,  1.3420,  1.3411,  1.3402,  1.3394,  1.3387,  1.3379,  1.3372,  1.3366,&
+1.3359,  1.3353,  1.3347,  1.3342,  1.3336,  1.3331,  1.3326,  1.3321,  1.3316,&
+1.3311,  1.3307,  1.3303,  1.3299,  1.3295,  1.3291,  1.3288,  1.3284,  1.3281,&
+1.3278,  1.3275,  1.3272,  1.3269,  1.3266,  1.3264,  1.3261,  1.3259,  1.3256,&
+1.3254,  1.3252,  1.3249,  1.3247,  1.3245,  1.3243,  1.3241,  1.3238,  1.3236,&
+1.3234,  1.3232,  1.3230,  1.3228,  1.3226,  1.3225,  1.3223,  1.3221,  1.3219,&
+1.3217,  1.3215,  1.3213,  1.3211,  1.3210,  1.3208,  1.3206,  1.3204,  1.3202,&
+1.3200,  1.3198,  1.3197,  1.3195,  1.3193,  1.3191,  1.3189,  1.3187,  1.3186,&
+1.3184,  1.3182,  1.3180,  1.3178,  1.3176,  1.3174,  1.3172,  1.3170,  1.3169,&
+1.3167,  1.3165,  1.3163,  1.3161,  1.3159,  1.3156,  1.3154,  1.3152,  1.3150,&
+1.3148,  1.3146,  1.3143,  1.3141,  1.3139,  1.3137,  1.3135,  1.3134,  1.3132,&
+1.3130,  1.3129,  1.3127,  1.3125,  1.3123,  1.3121,  1.3119,  1.3116,  1.3114,&
+1.3111,  1.3109,  1.3106,  1.3104,  1.3101,  1.3099,  1.3096,  1.3094,  1.3091,&
+1.3088,  1.3086,  1.3083,  1.3080,  1.3077,  1.3074,  1.3071,  1.3068,  1.3065,&
+1.3061,  1.3058,  1.3055,  1.3051,  1.3048,  1.3044,  1.3041,  1.3037,  1.3034,&
+1.3030,  1.3026,  1.3022,  1.3017,  1.3013,  1.3007,  1.3002,  1.2998,  1.2995,&
+1.2990,  1.2988,  1.2988,  1.2987,  1.2986,  1.2985,  1.2983,  1.2980,  1.2977,&
+1.2973,  1.2969,  1.2965,  1.2960,  1.2955,  1.2950,  1.2945,  1.2940,  1.2935,&
+1.2929,  1.2924,  1.2918,  1.2913,  1.2907,  1.2901,  1.2895,  1.2889,  1.2883,&
+1.2876,  1.2870,  1.2863,  1.2856,  1.2849,  1.2842,  1.2835,  1.2828,  1.2820,&
+1.2812,  1.2804,  1.2796,  1.2788,  1.2779,  1.2770,  1.2761,  1.2751,  1.2741,&
+1.2731,  1.2721,  1.2711,  1.2699,  1.2688,  1.2676,  1.2664,  1.2652,  1.2639,&
+1.2625,  1.2612,  1.2597,  1.2582,  1.2567,  1.2552,  1.2535,  1.2518,  1.2499,&
+1.2480,  1.2459,  1.2436,  1.2413,  1.2388,  1.2361,  1.2331,  1.2299,  1.2263,&
+1.2223,  1.2182,  1.2140,  1.2091,  1.2034,  1.1973,  1.1910,  1.1850,  1.1780,&
+1.1691,  1.1564,  1.1489,  1.1430,  1.1351,  1.1318,  1.1323,  1.1308,  1.1277,&
+1.1294,  1.1286,  1.1255,  1.1271,  1.1348,  1.1417,  1.1480,  1.1612,  1.1736,&
+1.1847,  1.2008,  1.2177,  1.2336,  1.2505,  1.2678,  1.2840,  1.3007,  1.3149,&
+1.3281,  1.3407,  1.3539,  1.3661,  1.3782,  1.3903,  1.4024,  1.4136,  1.4217,&
+1.4299,  1.4380,  1.4461,  1.4528,  1.4557,  1.4587,  1.4616,  1.4645,  1.4665,&
+1.4655,  1.4645,  1.4634,  1.4624,  1.4613,  1.4589,  1.4566,  1.4543,  1.4519,&
+1.4496,  1.4465,  1.4433,  1.4401,  1.4369,  1.4338,  1.4304,  1.4271,  1.4237,&
+1.4203,  1.4170,  1.4144,  1.4117,  1.4091,  1.4065,  1.4041,  1.4020,  1.3999,&
+1.3977,  1.3956,  1.3936,  1.3916,  1.3897,  1.3879,  1.3860,  1.3841,  1.3824,&
+1.3808,  1.3791,  1.3774,  1.3758,  1.3743,  1.3729,  1.3714,  1.3700,  1.3685,&
+1.3673,  1.3660,  1.3647,  1.3635,  1.3623,  1.3612,  1.3601,  1.3589,  1.3578,&
+1.3568,  1.3558,  1.3548,  1.3538,  1.3528,  1.3519,  1.3510,  1.3501,  1.3493,&
+1.3484,  1.3476,  1.3468,  1.3460,  1.3452,  1.3444,  1.3437,  1.3430,  1.3422,&
+1.3415,  1.3408,  1.3401,  1.3395,  1.3388,  1.3382,  1.3375,  1.3369,  1.3363,&
+1.3357,  1.3351,  1.3345,  1.3339 /)
+
+
+
+
+!
+! table of chlorophyll absorption coefficient as function of wavelength
+REAL, PARAMETER, DIMENSION(NNWL)::  XAKACHL= &
+(/0.4629505E+00, 0.4694205E+00, 0.4758904E+00, 0.4823604E+00, 0.4888304E+00,&
+0.4953003E+00, 0.5017703E+00, 0.5082403E+00, 0.5147102E+00, 0.5211802E+00,&
+0.5276502E+00, 0.5341201E+00, 0.5405901E+00, 0.5470601E+00, 0.5535300E+00,&
+0.5600000E+00, 0.5700000E+00, 0.5900000E+00, 0.6100000E+00, 0.6600000E+00,&
+0.6870000E+00, 0.8280000E+00, 0.9130000E+00, 0.9730000E+00, 0.1000000E+01,&
+0.9440000E+00, 0.9170000E+00, 0.8700000E+00, 0.7980000E+00, 0.7500000E+00,&
+0.6680000E+00, 0.6180000E+00, 0.5280000E+00, 0.4740000E+00, 0.4160000E+00,&
+0.3570000E+00, 0.2940000E+00, 0.2760000E+00, 0.2910000E+00, 0.2820000E+00,&
+0.2360000E+00, 0.2520000E+00, 0.2760000E+00, 0.3170000E+00, 0.3340000E+00,&
+0.3560000E+00, 0.4410000E+00, 0.5950000E+00, 0.5020000E+00, 0.3290000E+00,&
+0.2150000E+00, 0.2150000E+00, 0.2083276E+00, 0.2016552E+00, 0.1949828E+00,&
+0.1883103E+00, 0.1816379E+00, 0.1749655E+00, 0.1682931E+00, 0.1616207E+00,&
+0.1549483E+00, 0.1482759E+00, 0.1416035E+00, 0.1349310E+00, 0.1282586E+00,&
+0.1215862E+00, 0.1149138E+00, 0.1082414E+00, 0.1015690E+00, 0.9489655E-01,&
+0.8822414E-01, 0.8155172E-01, 0.7487931E-01, 0.6820690E-01, 0.6153448E-01,&
+0.5486207E-01, 0.4818965E-01, 0.4151724E-01, 0.3484483E-01, 0.2817241E-01,&
+0.2150000E-01, 0.2143550E-01, 0.2137100E-01, 0.2130650E-01, 0.2124200E-01,&
+0.2117750E-01, 0.2111300E-01, 0.2104850E-01, 0.2098400E-01, 0.2091950E-01,&
+0.2085500E-01, 0.2079050E-01, 0.2072600E-01, 0.2066150E-01, 0.2059700E-01,&
+0.2053250E-01, 0.2046800E-01, 0.2040350E-01, 0.2033900E-01, 0.2027450E-01,&
+0.2021000E-01, 0.2014550E-01, 0.2008100E-01, 0.2001650E-01, 0.1995200E-01,&
+0.1988750E-01, 0.1982300E-01, 0.1975850E-01, 0.1969400E-01, 0.1962950E-01,&
+0.1956500E-01, 0.1950050E-01, 0.1943600E-01, 0.1937150E-01, 0.1930700E-01,&
+0.1924250E-01, 0.1917800E-01, 0.1911350E-01, 0.1904900E-01, 0.1898450E-01,&
+0.1892000E-01, 0.1885550E-01, 0.1879100E-01, 0.1872650E-01, 0.1866200E-01,&
+0.1859750E-01, 0.1853300E-01, 0.1846850E-01, 0.1840400E-01, 0.1833950E-01,&
+0.1827500E-01, 0.1821050E-01, 0.1814600E-01, 0.1808150E-01, 0.1801700E-01,&
+0.1795250E-01, 0.1788800E-01, 0.1782350E-01, 0.1775900E-01, 0.1769450E-01,&
+0.1763000E-01, 0.1756550E-01, 0.1750100E-01, 0.1743650E-01, 0.1737200E-01,&
+0.1730750E-01, 0.1724300E-01, 0.1717850E-01, 0.1711400E-01, 0.1704950E-01,&
+0.1698500E-01, 0.1692050E-01, 0.1685600E-01, 0.1679150E-01, 0.1672700E-01,&
+0.1666250E-01, 0.1659800E-01, 0.1653350E-01, 0.1646900E-01, 0.1640450E-01,&
+0.1634000E-01, 0.1627550E-01, 0.1621100E-01, 0.1614650E-01, 0.1608200E-01,&
+0.1601750E-01, 0.1595300E-01, 0.1588850E-01, 0.1582400E-01, 0.1575950E-01,&
+0.1569500E-01, 0.1563050E-01, 0.1556600E-01, 0.1550150E-01, 0.1543700E-01,&
+0.1537250E-01, 0.1530800E-01, 0.1524350E-01, 0.1517900E-01, 0.1511450E-01,&
+0.1505000E-01, 0.1498550E-01, 0.1492100E-01, 0.1485650E-01, 0.1479200E-01,&
+0.1472750E-01, 0.1466300E-01, 0.1459850E-01, 0.1453400E-01, 0.1446950E-01,&
+0.1440500E-01, 0.1434050E-01, 0.1427600E-01, 0.1421150E-01, 0.1414700E-01,&
+0.1408250E-01, 0.1401800E-01, 0.1395350E-01, 0.1388900E-01, 0.1382450E-01,&
+0.1376000E-01, 0.1369550E-01, 0.1363100E-01, 0.1356650E-01, 0.1350200E-01,&
+0.1343750E-01, 0.1337300E-01, 0.1330850E-01, 0.1324400E-01, 0.1317950E-01,&
+0.1311500E-01, 0.1305050E-01, 0.1298600E-01, 0.1292150E-01, 0.1285700E-01,&
+0.1279250E-01, 0.1272800E-01, 0.1266350E-01, 0.1259900E-01, 0.1253450E-01,&
+0.1247000E-01, 0.1240550E-01, 0.1234100E-01, 0.1227650E-01, 0.1221200E-01,&
+0.1214750E-01, 0.1208300E-01, 0.1201850E-01, 0.1195400E-01, 0.1188950E-01,&
+0.1182500E-01, 0.1176050E-01, 0.1169600E-01, 0.1163150E-01, 0.1156700E-01,&
+0.1150250E-01, 0.1143800E-01, 0.1137350E-01, 0.1130900E-01, 0.1124450E-01,&
+0.1118000E-01, 0.1111550E-01, 0.1105100E-01, 0.1098650E-01, 0.1092200E-01,&
+0.1085750E-01, 0.1079300E-01, 0.1072850E-01, 0.1066400E-01, 0.1059950E-01,&
+0.1053500E-01, 0.1047050E-01, 0.1040600E-01, 0.1034150E-01, 0.1027700E-01,&
+0.1021250E-01, 0.1014800E-01, 0.1008350E-01, 0.1001900E-01, 0.9954500E-02,&
+0.9890000E-02, 0.9825500E-02, 0.9761000E-02, 0.9696500E-02, 0.9632000E-02,&
+0.9567500E-02, 0.9503000E-02, 0.9438500E-02, 0.9374000E-02, 0.9309500E-02,&
+0.9245000E-02, 0.9180500E-02, 0.9116000E-02, 0.9051500E-02, 0.8987000E-02,&
+0.8922500E-02, 0.8858000E-02, 0.8793500E-02, 0.8729000E-02, 0.8664500E-02,&
+0.8600000E-02, 0.8535500E-02, 0.8471000E-02, 0.8406500E-02, 0.8342000E-02,&
+0.8277500E-02, 0.8213000E-02, 0.8148500E-02, 0.8084000E-02, 0.8019500E-02,&
+0.7955000E-02, 0.7890500E-02, 0.7826000E-02, 0.7761500E-02, 0.7697000E-02,&
+0.7632500E-02, 0.7568000E-02, 0.7503500E-02, 0.7439000E-02, 0.7374500E-02,&
+0.7310000E-02, 0.7245500E-02, 0.7181000E-02, 0.7116500E-02, 0.7052000E-02,&
+0.6987500E-02, 0.6923000E-02, 0.6858500E-02, 0.6794000E-02, 0.6729500E-02,&
+0.6665000E-02, 0.6600500E-02, 0.6536000E-02, 0.6471500E-02, 0.6407000E-02,&
+0.6342500E-02, 0.6278000E-02, 0.6213500E-02, 0.6149000E-02, 0.6084500E-02,&
+0.6020000E-02, 0.5955500E-02, 0.5891000E-02, 0.5826500E-02, 0.5762000E-02,&
+0.5697500E-02, 0.5633000E-02, 0.5568500E-02, 0.5504000E-02, 0.5439500E-02,&
+0.5375000E-02, 0.5310500E-02, 0.5246000E-02, 0.5181500E-02, 0.5117000E-02,&
+0.5052500E-02, 0.4988000E-02, 0.4923500E-02, 0.4859000E-02, 0.4794500E-02,&
+0.4730000E-02, 0.4665500E-02, 0.4601000E-02, 0.4536500E-02, 0.4472000E-02,&
+0.4407500E-02, 0.4343000E-02, 0.4278500E-02, 0.4214000E-02, 0.4149500E-02,&
+0.4085000E-02, 0.4020500E-02, 0.3956000E-02, 0.3891500E-02, 0.3827000E-02,&
+0.3762500E-02, 0.3698000E-02, 0.3633500E-02, 0.3569000E-02, 0.3504500E-02,&
+0.3440000E-02, 0.3375500E-02, 0.3311000E-02, 0.3246500E-02, 0.3182000E-02,&
+0.3117500E-02, 0.3053000E-02, 0.2988500E-02, 0.2924000E-02, 0.2859500E-02,&
+0.2795000E-02, 0.2730500E-02, 0.2666000E-02, 0.2601500E-02, 0.2537000E-02,&
+0.2472500E-02, 0.2408000E-02, 0.2343500E-02, 0.2279000E-02, 0.2214500E-02,&
+0.2150000E-02 /)
+
+REAL, PARAMETER, DIMENSION(NNWL)::  XAKACHL2= &
+(/0.7745835E+00,  0.7522619E+00,  0.7299404E+00,  0.7076188E+00, 0.6852972E+00,&
+0.6629756E+00,  0.5767828E+00,  0.5011461E+00,  0.4285168E+00,  0.3946458E+00,&
+0.4330427E+00,  0.5309876E+00,  0.6371105E+00,  0.7297136E+00,  0.7904093E+00,&
+0.8097131E+00,  0.8760642E+00,  0.9381161E+00,  0.9457293E+00,  0.9258360E+00,&
+0.9025422E+00,  0.9252829E+00,  0.9270173E+00,  0.9995731E+00,  0.8171211E+00,&
+0.5353835E+00,  0.5329482E+00,  0.5348938E+00,  0.3804893E+00,  0.2089162E+00,&
+0.1108572E+00,  0.7056972E-01,  0.6340462E-01,  0.7044097E-01,  0.8182860E-01,&
+0.9896376E-01,  0.1267309E+00,  0.1598070E+00,  0.1993082E+00,  0.2502128E+00,&
+0.3026099E+00,  0.3196909E+00,  0.2917686E+00,  0.2666667E+00,  0.3314760E+00,&
+0.5711130E+00,  0.7452133E+00,  0.5497976E+00,  0.2406984E+00,  0.1315954E+00,&
+0.1197734E+00,  0.1258391E+00,  0.1367452E+00,  0.1552781E+00,  0.1936057E+00,&
+0.2571016E+00,  0.3363165E+00,  0.4064784E+00,  0.4289439E+00,  0.3819179E+00,&
+0.2987019E+00,  0.2160145E+00,  0.1343931E+00,  0.6321464E-01,  0.2241001E-01,&
+0.5134957E-02, -0.1242093E-02, -0.2531676E-02, -0.4085609E-02, -0.4713067E-02,&
+-0.5693497E-02, -0.1090849E-01, -0.1407841E-01, -0.1816251E-01, -0.2587014E-01,&
+-0.3565745E-01, -0.4546714E-01, -0.5446691E-01, -0.5650476E-01, -0.5981312E-01,&
+-0.5981312E-01, -0.6451318E-01, -0.4835265E-01, -0.4864828E-01, -0.4876773E-01,&
+-0.4840301E-01, -0.4866588E-01, -0.4836091E-01, -0.4851014E-01, -0.4860595E-01,&
+-0.4852568E-01, -0.4805798E-01, -0.4859427E-01, -0.4795901E-01, -0.4846919E-01,&
+-0.4850669E-01, -0.4854093E-01, -0.4849193E-01, -0.4841270E-01, -0.4855558E-01,&
+-0.4827924E-01, -0.4906723E-01, -0.4822920E-01, -0.4818162E-01, -0.4854826E-01,&
+-0.4875536E-01, -0.4863250E-01, -0.4843162E-01, -0.4836087E-01, -0.4913286E-01,&
+-0.4884187E-01, -0.4864121E-01, -0.4865143E-01, -0.4821299E-01, -0.4880581E-01,&
+-0.4887014E-01, -0.4868441E-01, -0.4861962E-01, -0.4806854E-01, -0.4918258E-01,&
+-0.4813463E-01, -0.4876416E-01, -0.4831872E-01, -0.4867297E-01, -0.4862849E-01,&
+-0.4836460E-01, -0.4858448E-01, -0.4886762E-01, -0.4875397E-01, -0.4863992E-01,&
+-0.4862744E-01, -0.4887019E-01, -0.4816946E-01, -0.4892569E-01, -0.4864310E-01,&
+-0.4881326E-01, -0.4819329E-01, -0.4852681E-01, -0.4803719E-01, -0.4831237E-01,&
+-0.4866472E-01, -0.4815419E-01, -0.4873738E-01, -0.4851730E-01, -0.4848577E-01,&
+-0.4881878E-01, -0.4878175E-01, -0.4839409E-01, -0.4850954E-01, -0.4846783E-01,&
+-0.4847389E-01, -0.4833271E-01, -0.4859281E-01, -0.4863393E-01, -0.4839972E-01,&
+-0.4851298E-01, -0.4831513E-01, -0.4842690E-01, -0.4784760E-01, -0.4914954E-01,&
+-0.4866549E-01, -0.4890948E-01, -0.4834954E-01, -0.4830681E-01, -0.4859897E-01,&
+-0.4838582E-01, -0.4851704E-01, -0.4866422E-01, -0.4881537E-01, -0.4851842E-01,&
+-0.4877209E-01, -0.4873482E-01, -0.4825956E-01, -0.4852063E-01, -0.4867407E-01,&
+-0.4878135E-01, -0.4830102E-01, -0.4826979E-01, -0.4870005E-01, -0.4902764E-01,&
+-0.4871316E-01, -0.4853799E-01, -0.4867663E-01, -0.4823785E-01, -0.4855946E-01,&
+-0.4875993E-01, -0.4846177E-01, -0.4886679E-01, -0.4859700E-01, -0.4809872E-01,&
+-0.4822881E-01, -0.4837712E-01, -0.4855768E-01, -0.4867230E-01, -0.4838317E-01,&
+-0.4876311E-01, -0.4812689E-01, -0.4820772E-01, -0.4904227E-01, -0.4871970E-01,&
+-0.4853304E-01, -0.4859587E-01, -0.4845879E-01, -0.4837155E-01, -0.4874718E-01,&
+-0.4873789E-01, -0.4851343E-01, -0.4851316E-01, -0.4901856E-01, -0.4836449E-01,&
+-0.4880954E-01, -0.4853077E-01, -0.4898909E-01, -0.4812662E-01, -0.4832583E-01,&
+-0.4847423E-01, -0.4846226E-01, -0.4844360E-01, -0.4835512E-01, -0.4893025E-01,&
+-0.4853777E-01, -0.4873621E-01, -0.4832436E-01, -0.4854396E-01, -0.4848187E-01,&
+-0.4850079E-01, -0.4843526E-01, -0.4818938E-01, -0.4874043E-01, -0.4847353E-01,&
+-0.4865320E-01, -0.4853667E-01, -0.4859223E-01, -0.4872705E-01, -0.4821515E-01,&
+-0.4844453E-01, -0.4870005E-01, -0.4881809E-01, -0.4865348E-01, -0.4871232E-01,&
+-0.4859998E-01, -0.4833980E-01, -0.4860161E-01, -0.4839900E-01, -0.4853466E-01,&
+-0.4864573E-01, -0.4863669E-01, -0.4901951E-01, -0.4832310E-01, -0.4890333E-01,&
+-0.4880714E-01, -0.4855986E-01, -0.4852934E-01, -0.4818182E-01, -0.4795438E-01,&
+-0.4834752E-01, -0.4810626E-01, -0.4861891E-01, -0.4872801E-01, -0.4814039E-01,&
+-0.4894429E-01, -0.4881275E-01, -0.4903332E-01, -0.4835438E-01, -0.4865217E-01,&
+-0.4853667E-01, -0.4841790E-01, -0.4869760E-01, -0.4900452E-01, -0.4856053E-01,&
+-0.4825166E-01, -0.4837719E-01, -0.4872088E-01, -0.4873605E-01, -0.4868101E-01,&
+-0.4883375E-01, -0.4870022E-01, -0.4875332E-01, -0.4836111E-01, -0.4863061E-01,&
+-0.4875719E-01, -0.4874192E-01, -0.4847357E-01, -0.4867528E-01, -0.4836407E-01,&
+-0.4828474E-01, -0.4860063E-01, -0.4861546E-01, -0.4864795E-01, -0.4844943E-01,&
+-0.4904242E-01, -0.4843469E-01, -0.4866992E-01, -0.4900254E-01, -0.4864337E-01,&
+-0.4844130E-01, -0.4837940E-01, -0.4855977E-01, -0.4874923E-01, -0.4906257E-01,&
+-0.4864537E-01, -0.4834532E-01, -0.4869347E-01, -0.4858449E-01, -0.4877963E-01,&
+-0.4863986E-01, -0.4848931E-01, -0.4836552E-01, -0.4849740E-01, -0.4887220E-01,&
+-0.4904565E-01, -0.4872388E-01, -0.4810480E-01, -0.4806256E-01, -0.4874242E-01,&
+-0.4819115E-01, -0.4862189E-01, -0.4871701E-01, -0.4839065E-01, -0.4877597E-01,&
+-0.4905847E-01, -0.4861049E-01, -0.4812144E-01, -0.4872767E-01, -0.4891870E-01,&
+-0.4890406E-01, -0.4818467E-01, -0.4847043E-01, -0.4841457E-01, -0.4821321E-01,&
+-0.4847127E-01, -0.4868549E-01, -0.4910397E-01, -0.4863713E-01, -0.4831791E-01,&
+-0.4807175E-01, -0.4877013E-01, -0.4882632E-01, -0.4808306E-01, -0.4848078E-01,&
+-0.4849469E-01, -0.4864521E-01, -0.4823979E-01, -0.4866831E-01, -0.4870176E-01,&
+-0.4837111E-01, -0.4899544E-01, -0.4904284E-01, -0.4913362E-01, -0.4821655E-01,&
+-0.4833322E-01, -0.4831560E-01, -0.4840073E-01, -0.4852060E-01, -0.4897843E-01,&
+-0.4829322E-01, -0.4884781E-01, -0.4827255E-01, -0.4827960E-01, -0.4864042E-01,&
+-0.4828514E-01, -0.4897902E-01, -0.4855954E-01, -0.4855975E-01, -0.4858216E-01,&
+-0.4827806E-01, -0.4847189E-01, -0.4860275E-01, -0.4906456E-01, -0.4853636E-01,&
+-0.4862808E-01, -0.4848551E-01, -0.4869109E-01, -0.4848604E-01, -0.4866388E-01,&
+-0.4846765E-01, -0.4875867E-01, -0.4807435E-01, -0.4867530E-01, -0.4888080E-01,&
+-0.4844930E-01 /)
+
+
+
+
+
+
+
+!
+! table of seawater absorption coefficient as function of wavelength
+REAL, PARAMETER, DIMENSION(NNWL)::  XAKAW3= &
+(/0.3067439E+01, 0.1993737E+01, 0.1309263E+01, 0.9275307E+00, 0.7183294E+00,&
+0.5608010E+00, 0.4552411E+00, 0.3738498E+00, 0.2879400E+00, 0.2145172E+00,&
+0.1415658E+00, 0.1048958E+00, 0.8411996E-01, 0.6814662E-01, 0.5585442E-01,&
+0.4638546E-01, 0.3791143E-01, 0.2984669E-01, 0.2234093E-01, 0.1870175E-01,&
+0.1737227E-01, 0.1609624E-01, 0.1530537E-01, 0.1443961E-01, 0.1437088E-01,&
+0.1480803E-01, 0.1517563E-01, 0.1592806E-01, 0.1743279E-01, 0.1967369E-01,&
+0.2564243E-01, 0.3598580E-01, 0.4703195E-01, 0.5145027E-01, 0.5534469E-01,&
+0.6400512E-01, 0.7030880E-01, 0.8172981E-01, 0.1033439E+00, 0.1638825E+00,&
+0.2387544E+00, 0.2908335E+00, 0.3086321E+00, 0.3193000E+00, 0.3277702E+00,&
+0.3523264E+00, 0.3957919E+00, 0.4326377E+00, 0.4485145E+00, 0.5016078E+00,&
+0.6481431E+00, 0.8408502E+00, 0.1165249E+01, 0.1810640E+01, 0.2364421E+01,&
+0.2479177E+01, 0.2547112E+01, 0.2511108E+01, 0.2356959E+01, 0.2164139E+01,&
+0.2068389E+01, 0.2334173E+01, 0.3101571E+01, 0.3715746E+01, 0.4069374E+01,&
+0.4055130E+01, 0.3662220E+01, 0.3265983E+01, 0.3338288E+01, 0.4351006E+01,&
+0.6776006E+01, 0.1092508E+02, 0.1646968E+02, 0.2292120E+02, 0.2979101E+02,&
+0.3659049E+02, 0.4255537E+02, 0.4581877E+02, 0.4488433E+02, 0.4084045E+02,&
+0.3542173E+02, 0.3008784E+02, 0.2519888E+02, 0.2084002E+02, 0.1709645E+02,&
+0.1405336E+02, 0.1179592E+02, 0.1051821E+02, 0.1084989E+02, 0.1352949E+02,&
+0.1929556E+02, 0.2856379E+02, 0.4045844E+02, 0.5378094E+02, 0.6733270E+02,&
+0.7991512E+02, 0.9045451E+02, 0.9837671E+02, 0.1032324E+03, 0.1045724E+03,&
+0.1024582E+03, 0.9870555E+02, 0.9448188E+02, 0.9066481E+02, 0.8813195E+02,&
+0.8776093E+02, 0.9009315E+02, 0.9432506E+02, 0.9931691E+02, 0.1039289E+03,&
+0.1070213E+03, 0.1091415E+03, 0.1175854E+03, 0.1413362E+03, 0.1893769E+03,&
+0.2706907E+03, 0.3927593E+03, 0.5570592E+03, 0.7635654E+03, 0.1012253E+04,&
+0.1303097E+04, 0.1629710E+04, 0.1960254E+04, 0.2256530E+04, 0.2480335E+04,&
+0.2593472E+04, 0.2570322E+04, 0.2435603E+04, 0.2226617E+04, 0.1980665E+04,&
+0.1735048E+04, 0.1520186E+04, 0.1338970E+04, 0.1187410E+04, 0.1061517E+04,&
+0.9572996E+03, 0.8707689E+03, 0.7979346E+03, 0.7348066E+03, 0.6773950E+03,&
+0.6217097E+03, 0.5658621E+03, 0.5163686E+03, 0.4818471E+03, 0.4709154E+03,&
+0.4921914E+03, 0.5339673E+03, 0.5283995E+03, 0.4879842E+03, 0.4503842E+03,&
+0.4532622E+03, 0.5219655E+03, 0.6325787E+03, 0.7488713E+03, 0.8346125E+03,&
+0.8535717E+03, 0.7823218E+03, 0.6486514E+03, 0.4931527E+03, 0.3564180E+03,&
+0.2790396E+03, 0.2973530E+03, 0.4306661E+03, 0.6940303E+03, 0.1102497E+04,&
+0.1671116E+04, 0.2414941E+04, 0.3349021E+04, 0.4488408E+04, 0.5848154E+04,&
+0.7443309E+04, 0.9216590E+04, 0.1082137E+05, 0.1183869E+05, 0.1184960E+05,&
+0.1078493E+05, 0.9686200E+04, 0.8790378E+04, 0.8045845E+04, 0.7400985E+04,&
+0.6804181E+04, 0.6214741E+04, 0.5635665E+04, 0.5080881E+04, 0.4564313E+04,&
+0.4099888E+04, 0.3697940E+04, 0.3354440E+04, 0.3061767E+04, 0.2812299E+04,&
+0.2598416E+04, 0.2413350E+04, 0.2253741E+04, 0.2117085E+04, 0.2000874E+04,&
+0.1902603E+04, 0.1819767E+04, 0.1749858E+04, 0.1690372E+04, 0.1638801E+04,&
+0.1592640E+04, 0.1555394E+04, 0.1548293E+04, 0.1573317E+04, 0.1626133E+04,&
+0.1702405E+04, 0.1797857E+04, 0.1908438E+04, 0.2030156E+04, 0.2159016E+04,&
+0.2291026E+04, 0.2423482E+04, 0.2558843E+04, 0.2700856E+04, 0.2853272E+04,&
+0.3019837E+04, 0.3204129E+04, 0.3409039E+04, 0.3637285E+04, 0.3891587E+04,&
+0.4174664E+04, 0.4489235E+04, 0.4838020E+04, 0.5223737E+04, 0.5649106E+04,&
+0.6116846E+04, 0.6622627E+04, 0.7133928E+04, 0.7611180E+04, 0.8014812E+04,&
+0.8305254E+04, 0.8466704E+04, 0.8578431E+04, 0.8743467E+04, 0.9064849E+04,&
+0.9645611E+04, 0.1051240E+05, 0.1138630E+05, 0.1191200E+05, 0.1173420E+05,&
+0.1049759E+05, 0.8305364E+04, 0.7094721E+04, 0.9142031E+04, 0.1397930E+05,&
+0.1839416E+05, 0.1986234E+05, 0.1908920E+05, 0.1758752E+05, 0.1687005E+05,&
+0.1844957E+05, 0.2383885E+05, 0.3455066E+05, 0.5209777E+05, 0.7799295E+05,&
+0.1137490E+06, 0.1602886E+06, 0.2161751E+06, 0.2793814E+06, 0.3478807E+06,&
+0.4196461E+06, 0.4928405E+06, 0.5663854E+06, 0.6393920E+06, 0.7109715E+06,&
+0.7802351E+06, 0.8462941E+06, 0.9082596E+06, 0.9652429E+06, 0.1016355E+07,&
+0.1060708E+07, 0.1097549E+07, 0.1126679E+07, 0.1148035E+07, 0.1161554E+07,&
+0.1167173E+07, 0.1164996E+07, 0.1155796E+07, 0.1140514E+07, 0.1120088E+07,&
+0.1095461E+07, 0.1067479E+07, 0.1036628E+07, 0.1003298E+07, 0.9678839E+06,&
+0.9307769E+06, 0.8923695E+06, 0.8530543E+06, 0.8132238E+06, 0.7732703E+06,&
+0.7335864E+06, 0.6945089E+06, 0.6561521E+06, 0.6185746E+06, 0.5818354E+06,&
+0.5459929E+06, 0.5111060E+06, 0.4772333E+06, 0.4444336E+06, 0.4127655E+06,&
+0.3822878E+06, 0.3530592E+06, 0.3251383E+06, 0.2985839E+06, 0.2734547E+06,&
+0.2498094E+06, 0.2277067E+06, 0.2072053E+06, 0.1883639E+06, 0.1712413E+06,&
+0.1558960E+06, 0.1423474E+06, 0.1304565E+06, 0.1200447E+06, 0.1109338E+06,&
+0.1029451E+06, 0.9590033E+05, 0.8962092E+05, 0.8392845E+05, 0.7864446E+05,&
+0.7359050E+05, 0.6862405E+05, 0.6374646E+05, 0.5899502E+05, 0.5440700E+05,&
+0.5001969E+05, 0.4587039E+05, 0.4199638E+05, 0.3843495E+05, 0.3522339E+05,&
+0.3239897E+05, 0.2998538E+05, 0.2795181E+05, 0.2625384E+05, 0.2484704E+05,&
+0.2368700E+05, 0.2272929E+05, 0.2192950E+05, 0.2124319E+05, 0.2062596E+05,&
+0.2003338E+05, 0.1942931E+05, 0.1881074E+05, 0.1818297E+05, 0.1755126E+05,&
+0.1692090E+05, 0.1629717E+05, 0.1568535E+05, 0.1509072E+05, 0.1451856E+05,&
+0.1397415E+05, 0.1346277E+05, 0.1298970E+05, 0.1256022E+05, 0.1217961E+05,&
+0.1185315E+05, 0.1158473E+05, 0.1137272E+05, 0.1121409E+05, 0.1110580E+05,&
+0.1104483E+05, 0.1102816E+05, 0.1105274E+05, 0.1111556E+05, 0.1121359E+05,&
+0.1134380E+05, 0.1150316E+05, 0.1168864E+05, 0.1189722E+05, 0.1212586E+05,&
+0.1237155E+05, 0.1263124E+05, 0.1290192E+05, 0.1318056E+05, 0.1346412E+05,&
+0.1374958E+05, 0.1403392E+05, 0.1431409E+05, 0.1458709E+05, 0.1484987E+05,&
+0.1509941E+05 /)
+
+
+
+!
+! table of seawater backscattering coefficient as function of wavelength
+REAL, PARAMETER, DIMENSION(NNWL)::  XAKBW= &
+(/0.1510000E+00, 0.1190000E+00, 0.9950015E-01, 0.8199944E-01, 0.6850207E-01,&
+0.5749506E-01, 0.4850663E-01, 0.4149505E-01, 0.3530210E-01, 0.3049935E-01,&
+0.2620052E-01, 0.2289856E-01, 0.2000336E-01, 0.1749553E-01, 0.1530325E-01,&
+0.1339897E-01, 0.1199900E-01, 0.1060502E-01, 0.9387780E-02, 0.8416411E-02,&
+0.7587748E-02, 0.6805146E-02, 0.6098530E-02, 0.5500733E-02, 0.4898538E-02,&
+0.4503288E-02, 0.4095613E-02, 0.3703303E-02, 0.3398477E-02, 0.3100964E-02,&
+0.2897666E-02, 0.2608371E-02, 0.2380034E-02, 0.2226757E-02, 0.2080041E-02,&
+0.1908345E-02, 0.1797763E-02, 0.1700603E-02, 0.1599833E-02, 0.1500036E-02,&
+0.1400066E-02, 0.1299673E-02, 0.1201250E-02, 0.1095326E-02, 0.1017446E-02,&
+0.9582712E-03, 0.8559384E-03, 0.7582711E-03, 0.7174466E-03, 0.6953252E-03,&
+0.7012525E-03, 0.6996646E-03, 0.6000893E-03, 0.5999768E-03, 0.6000058E-03,&
+0.4999986E-03, 0.5000004E-03, 0.4999999E-03, 0.4000000E-03, 0.4000000E-03,&
+0.4000000E-03, 0.4000000E-03, 0.3987586E-03, 0.3975172E-03, 0.3962759E-03,&
+0.3950345E-03, 0.3937931E-03, 0.3925517E-03, 0.3913103E-03, 0.3900690E-03,&
+0.3888276E-03, 0.3875862E-03, 0.3863448E-03, 0.3851035E-03, 0.3838621E-03,&
+0.3826207E-03, 0.3813793E-03, 0.3801379E-03, 0.3788965E-03, 0.3776552E-03,&
+0.3764138E-03, 0.3751724E-03, 0.3739310E-03, 0.3726897E-03, 0.3714483E-03,&
+0.3702069E-03, 0.3689655E-03, 0.3677241E-03, 0.3664828E-03, 0.3652414E-03,&
+0.3640000E-03, 0.3627586E-03, 0.3615172E-03, 0.3602759E-03, 0.3590345E-03,&
+0.3577931E-03, 0.3565517E-03, 0.3553103E-03, 0.3540690E-03, 0.3528276E-03,&
+0.3515862E-03, 0.3503448E-03, 0.3491034E-03, 0.3478621E-03, 0.3466207E-03,&
+0.3453793E-03, 0.3441379E-03, 0.3428966E-03, 0.3416552E-03, 0.3404138E-03,&
+0.3391724E-03, 0.3379310E-03, 0.3366896E-03, 0.3354483E-03, 0.3342069E-03,&
+0.3329655E-03, 0.3317241E-03, 0.3304828E-03, 0.3292414E-03, 0.3280000E-03,&
+0.3267586E-03, 0.3255172E-03, 0.3242759E-03, 0.3230345E-03, 0.3217931E-03,&
+0.3205517E-03, 0.3193103E-03, 0.3180690E-03, 0.3168276E-03, 0.3155862E-03,&
+0.3143448E-03, 0.3131035E-03, 0.3118621E-03, 0.3106207E-03, 0.3093793E-03,&
+0.3081379E-03, 0.3068965E-03, 0.3056552E-03, 0.3044138E-03, 0.3031724E-03,&
+0.3019310E-03, 0.3006897E-03, 0.2994483E-03, 0.2982069E-03, 0.2969655E-03,&
+0.2957241E-03, 0.2944828E-03, 0.2932414E-03, 0.2920000E-03, 0.2907586E-03,&
+0.2895173E-03, 0.2882759E-03, 0.2870345E-03, 0.2857931E-03, 0.2845517E-03,&
+0.2833103E-03, 0.2820690E-03, 0.2808276E-03, 0.2795862E-03, 0.2783448E-03,&
+0.2771034E-03, 0.2758621E-03, 0.2746207E-03, 0.2733793E-03, 0.2721379E-03,&
+0.2708966E-03, 0.2696552E-03, 0.2684138E-03, 0.2671724E-03, 0.2659310E-03,&
+0.2646896E-03, 0.2634483E-03, 0.2622069E-03, 0.2609655E-03, 0.2597241E-03,&
+0.2584828E-03, 0.2572414E-03, 0.2560000E-03, 0.2547586E-03, 0.2535172E-03,&
+0.2522759E-03, 0.2510345E-03, 0.2497931E-03, 0.2485517E-03, 0.2473104E-03,&
+0.2460690E-03, 0.2448276E-03, 0.2435862E-03, 0.2423448E-03, 0.2411035E-03,&
+0.2398621E-03, 0.2386207E-03, 0.2373793E-03, 0.2361379E-03, 0.2348965E-03,&
+0.2336552E-03, 0.2324138E-03, 0.2311724E-03, 0.2299310E-03, 0.2286896E-03,&
+0.2274483E-03, 0.2262069E-03, 0.2249655E-03, 0.2237241E-03, 0.2224828E-03,&
+0.2212414E-03, 0.2200000E-03, 0.2187586E-03, 0.2175172E-03, 0.2162759E-03,&
+0.2150345E-03, 0.2137931E-03, 0.2125517E-03, 0.2113103E-03, 0.2100690E-03,&
+0.2088276E-03, 0.2075862E-03, 0.2063448E-03, 0.2051035E-03, 0.2038621E-03,&
+0.2026207E-03, 0.2013793E-03, 0.2001379E-03, 0.1988966E-03, 0.1976552E-03,&
+0.1964138E-03, 0.1951724E-03, 0.1939310E-03, 0.1926897E-03, 0.1914483E-03,&
+0.1902069E-03, 0.1889655E-03, 0.1877241E-03, 0.1864828E-03, 0.1852414E-03,&
+0.1840000E-03, 0.1827586E-03, 0.1815172E-03, 0.1802759E-03, 0.1790345E-03,&
+0.1777931E-03, 0.1765517E-03, 0.1753103E-03, 0.1740690E-03, 0.1728276E-03,&
+0.1715862E-03, 0.1703448E-03, 0.1691034E-03, 0.1678621E-03, 0.1666207E-03,&
+0.1653793E-03, 0.1641379E-03, 0.1628966E-03, 0.1616552E-03, 0.1604138E-03,&
+0.1591724E-03, 0.1579310E-03, 0.1566897E-03, 0.1554483E-03, 0.1542069E-03,&
+0.1529655E-03, 0.1517241E-03, 0.1504828E-03, 0.1492414E-03, 0.1480000E-03,&
+0.1467586E-03, 0.1455172E-03, 0.1442759E-03, 0.1430345E-03, 0.1417931E-03,&
+0.1405517E-03, 0.1393103E-03, 0.1380690E-03, 0.1368276E-03, 0.1355862E-03,&
+0.1343448E-03, 0.1331034E-03, 0.1318621E-03, 0.1306207E-03, 0.1293793E-03,&
+0.1281379E-03, 0.1268966E-03, 0.1256552E-03, 0.1244138E-03, 0.1231724E-03,&
+0.1219310E-03, 0.1206897E-03, 0.1194483E-03, 0.1182069E-03, 0.1169655E-03,&
+0.1157241E-03, 0.1144828E-03, 0.1132414E-03, 0.1120000E-03, 0.1107586E-03,&
+0.1095172E-03, 0.1082759E-03, 0.1070345E-03, 0.1057931E-03, 0.1045517E-03,&
+0.1033103E-03, 0.1020690E-03, 0.1008276E-03, 0.9958621E-04, 0.9834483E-04,&
+0.9710345E-04, 0.9586207E-04, 0.9462069E-04, 0.9337931E-04, 0.9213793E-04,&
+0.9089655E-04, 0.8965517E-04, 0.8841379E-04, 0.8717241E-04, 0.8593103E-04,&
+0.8468966E-04, 0.8344828E-04, 0.8220690E-04, 0.8096552E-04, 0.7972414E-04,&
+0.7848276E-04, 0.7724138E-04, 0.7600000E-04, 0.7475862E-04, 0.7351724E-04,&
+0.7227586E-04, 0.7103448E-04, 0.6979310E-04, 0.6855172E-04, 0.6731034E-04,&
+0.6606896E-04, 0.6482759E-04, 0.6358621E-04, 0.6234483E-04, 0.6110345E-04,&
+0.5986207E-04, 0.5862069E-04, 0.5737931E-04, 0.5613793E-04, 0.5489655E-04,&
+0.5365517E-04, 0.5241379E-04, 0.5117241E-04, 0.4993103E-04, 0.4868966E-04,&
+0.4744828E-04, 0.4620690E-04, 0.4496552E-04, 0.4372414E-04, 0.4248276E-04,&
+0.4124138E-04, 0.4000000E-04, 0.3875862E-04, 0.3751724E-04, 0.3627586E-04,&
+0.3503448E-04, 0.3379311E-04, 0.3255172E-04, 0.3131034E-04, 0.3006897E-04,&
+0.2882759E-04, 0.2758621E-04, 0.2634483E-04, 0.2510345E-04, 0.2386207E-04,&
+0.2262069E-04, 0.2137931E-04, 0.2013793E-04, 0.1889655E-04, 0.1765517E-04,&
+0.1641379E-04, 0.1517241E-04, 0.1393103E-04, 0.1268965E-04, 0.1144828E-04,&
+0.1020690E-04, 0.8965517E-05, 0.7724138E-05, 0.6482759E-05, 0.5241379E-05,&
+0.4000000E-05 /)
+
+! white-caps reflectance (Koepke and Whitlock)
+! Whitlock fit varid 400nm - 2.4nm. set albedo 0 otherwise 
+REAL, PARAMETER, DIMENSION(NNWL)::  XRWC   = &
+(/0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00,&
+0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00,&
+0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00,&
+0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00,&
+0.1986623E+00, 0.1968392E+00, 0.1955961E+00, 0.1941208E+00, 0.1939980E+00,&
+0.1947642E+00, 0.1953830E+00, 0.1965826E+00, 0.1987437E+00, 0.2014820E+00,&
+0.2068586E+00, 0.2125197E+00, 0.2160829E+00, 0.2171109E+00, 0.2178881E+00,&
+0.2192886E+00, 0.2200949E+00, 0.2212391E+00, 0.2227055E+00, 0.2247944E+00,&
+0.2262073E+00, 0.2270383E+00, 0.2273185E+00, 0.2274869E+00, 0.2276210E+00,&
+0.2280129E+00, 0.2287211E+00, 0.2293381E+00, 0.2296089E+00, 0.2305354E+00,&
+0.2332379E+00, 0.2370188E+00, 0.2373674E+00, 0.2314480E+00, 0.2291741E+00,&
+0.2288465E+00, 0.2286684E+00, 0.2287614E+00, 0.2291967E+00, 0.2298426E+00,&
+0.2302154E+00, 0.2292666E+00, 0.2275362E+00, 0.2266957E+00, 0.2263213E+00,&
+0.2263353E+00, 0.2267580E+00, 0.2272800E+00, 0.2271755E+00, 0.2260595E+00,&
+0.2243821E+00, 0.2219912E+00, 0.2188027E+00, 0.2151597E+00, 0.2114653E+00,&
+0.2080255E+00, 0.2051811E+00, 0.2036894E+00, 0.2041120E+00, 0.2059829E+00,&
+0.2086015E+00, 0.2113106E+00, 0.2139111E+00, 0.2163195E+00, 0.2184435E+00,&
+0.2201926E+00, 0.2214916E+00, 0.2222242E+00, 0.2220343E+00, 0.2204943E+00,&
+0.2171906E+00, 0.2121093E+00, 0.2061633E+00, 0.2002262E+00, 0.1948388E+00,&
+0.1903174E+00, 0.1868275E+00, 0.1843590E+00, 0.1829052E+00, 0.1825115E+00,&
+0.1831341E+00, 0.1842591E+00, 0.1855570E+00, 0.1867604E+00, 0.1875755E+00,&
+0.1876960E+00, 0.1869431E+00, 0.1856059E+00, 0.1840741E+00, 0.1827001E+00,&
+0.1818000E+00, 0.1811922E+00, 0.1788437E+00, 0.1727826E+00, 0.1624180E+00,&
+0.1487052E+00, 0.1334511E+00, 0.1185638E+00, 0.1049801E+00, 0.9298412E-01,&
+0.8257660E-01, 0.7379698E-01, 0.6696978E-01, 0.6208307E-01, 0.5897739E-01,&
+0.5756657E-01, 0.5784728E-01, 0.5956322E-01, 0.6253327E-01, 0.6660015E-01,&
+0.7143353E-01, 0.7647427E-01, 0.8148541E-01, 0.8635699E-01, 0.9099500E-01,&
+0.9533520E-01, 0.9935633E-01, 0.1030906E+00, 0.1066306E+00, 0.1101345E+00,&
+0.1138333E+00, 0.1178890E+00, 0.1218228E+00, 0.1247853E+00, 0.1257652E+00,&
+0.1238772E+00, 0.1203841E+00, 0.1208343E+00, 0.1242444E+00, 0.1276640E+00,&
+0.1273930E+00, 0.1213602E+00, 0.1130860E+00, 0.1058152E+00, 0.1011666E+00,&
+0.1002071E+00, 0.1039381E+00, 0.1120040E+00, 0.1237937E+00, 0.1375058E+00,&
+0.1474928E+00, 0.1449352E+00, 0.1295643E+00, 0.1090889E+00, 0.8941860E-01,&
+0.7284467E-01, 0.5983944E-01, 0.5022947E-01, 0.4366299E-01, 0.3977196E-01,&
+0.3822227E-01, 0.3867308E-01, 0.4026759E-01, 0.4166813E-01, 0.4168444E-01,&
+0.4022229E-01, 0.3904642E-01, 0.3841435E-01, 0.3817649E-01, 0.3823472E-01,&
+0.3855810E-01, 0.3919018E-01, 0.4018588E-01, 0.4157600E-01, 0.4335490E-01,&
+0.4545942E-01, 0.4776782E-01, 0.5018748E-01, 0.5264894E-01, 0.5509888E-01,&
+0.5750712E-01, 0.5986086E-01, 0.6212466E-01, 0.6426051E-01, 0.6623940E-01,&
+0.6804333E-01, 0.6966664E-01, 0.7111643E-01, 0.7241227E-01, 0.7358521E-01,&
+0.7467659E-01, 0.7558735E-01, 0.7576417E-01, 0.7514564E-01, 0.7388073E-01,&
+0.7214532E-01, 0.7011285E-01, 0.6793264E-01, 0.6572567E-01, 0.6358425E-01,&
+0.6157472E-01, 0.5972482E-01, 0.5798797E-01, 0.5631501E-01, 0.5467161E-01,&
+0.5303634E-01, 0.5140076E-01, 0.4977145E-01, 0.4816243E-01, 0.4659231E-01,&
+0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00,&
+0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00,&
+0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00,&
+0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00,&
+0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00,&
+0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00,&
+0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00,&
+0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00,&
+0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00,&
+0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00,&
+0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00,&
+0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00,&
+0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00,&
+0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00,&
+0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00,&
+0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00,&
+0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00,&
+0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00,&
+0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00,&
+0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00,&
+0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00,&
+0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00,&
+0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00,&
+0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00,&
+0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00,&
+0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00,&
+0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00,&
+0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00,&
+0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00,&
+0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00,&
+0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00,&
+0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00, 0.0000000E+00,&
+0.0000000E+00 /)
+
+
+!
+!--------------------------------------------------------------------------------
+!
+END MODULE 
+
+
+
+
+
+
+
+
+
+
+
+
Index: DZ6/trunk/libf/phylmd/ocean_cpl_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/ocean_cpl_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,402 +1,0 @@
-!
-! $Id$
-!
-MODULE ocean_cpl_mod
-!
-! This module is used both for the sub-surface ocean and sea-ice for the case of a 
-! coupled model configuration, ocean=couple. 
-!
-
-  IMPLICIT NONE
-  PRIVATE
-
-  PUBLIC :: ocean_cpl_init, ocean_cpl_noice, ocean_cpl_ice
-
-
-!****************************************************************************************
-!
-CONTAINS
-!
-!****************************************************************************************
-!
-  SUBROUTINE ocean_cpl_init(dtime, rlon, rlat)
-!
-! Allocate fields for this module and initailize the module mod_cpl
-!
-    USE dimphy,           ONLY : klon
-    USE cpl_mod
-
-! Input arguments
-!*************************************************************************************
-    REAL, INTENT(IN)                  :: dtime
-    REAL, DIMENSION(klon), INTENT(IN) :: rlon, rlat
-
-! Local variables
-!*************************************************************************************
-    INTEGER              :: error
-    CHARACTER (len = 80) :: abort_message
-    CHARACTER (len = 20) :: modname = 'ocean_cpl_init'
-
-! Initialize module cpl_init
-    CALL cpl_init(dtime, rlon, rlat)
-    
-  END SUBROUTINE ocean_cpl_init
-!
-!****************************************************************************************
-!
-  SUBROUTINE ocean_cpl_noice( &
-       swnet, lwnet, alb1, &
-       windsp, fder_old, &
-       itime, dtime, knon, knindex, &
-       p1lay, cdragh, cdragq, cdragm, precip_rain, precip_snow, temp_air, spechum, &
-       AcoefH, AcoefQ, BcoefH, BcoefQ, &
-       AcoefU, AcoefV, BcoefU, BcoefV, &
-       ps, u1, v1, gustiness, tsurf_in, &
-       radsol, snow, agesno, &
-       qsurf, evap, fluxsens, fluxlat, flux_u1, flux_v1, &
-       tsurf_new, dflux_s, dflux_l, sens_prec_liq, sss, delta_sal, rhoa, &
-       delta_sst, dTer, dSer, dt_ds)
-
-!
-! This subroutine treats the "open ocean", all grid points that are not entierly covered
-! by ice. The subroutine first receives fields from coupler, then some calculations at 
-! surface is done and finally it sends some fields to the coupler.
-!
-    USE dimphy,           ONLY : klon
-    USE calcul_fluxs_mod
-    USE indice_sol_mod
-    USE phys_output_var_mod, ONLY : sens_prec_liq_o, sens_prec_sol_o, lat_prec_liq_o, lat_prec_sol_o
-    USE cpl_mod, ONLY : gath2cpl, cpl_receive_ocean_fields, &
-         cpl_send_ocean_fields
-    use config_ocean_skin_m, only: activate_ocean_skin
-
-    INCLUDE "YOMCST.h"
-    INCLUDE "clesphys.h"
-!    
-! Input arguments  
-!****************************************************************************************
-    INTEGER, INTENT(IN)                      :: itime, knon
-    INTEGER, DIMENSION(klon), INTENT(IN)     :: knindex
-    REAL, INTENT(IN)                         :: dtime
-    REAL, DIMENSION(klon), INTENT(IN)        :: swnet
-    REAL, DIMENSION(klon), INTENT(IN)        :: lwnet
-    REAL, DIMENSION(klon), INTENT(IN)        :: alb1   ! albedo in visible SW interval
-    REAL, DIMENSION(klon), INTENT(IN)        :: windsp
-    REAL, DIMENSION(klon), INTENT(IN)        :: fder_old
-    REAL, DIMENSION(klon), INTENT(IN)        :: p1lay
-    REAL, DIMENSION(klon), INTENT(IN)        :: cdragh, cdragq, cdragm
-    REAL, DIMENSION(klon), INTENT(IN)        :: precip_rain, precip_snow
-    REAL, DIMENSION(klon), INTENT(IN)        :: temp_air, spechum
-    REAL, DIMENSION(klon), INTENT(IN)        :: AcoefH, AcoefQ, BcoefH, BcoefQ
-    REAL, DIMENSION(klon), INTENT(IN)        :: AcoefU, AcoefV, BcoefU, BcoefV
-    REAL, DIMENSION(klon), INTENT(IN)        :: ps
-    REAL, DIMENSION(klon), INTENT(IN)        :: u1, v1, gustiness
-    REAL, INTENT(IN) :: tsurf_in(:) ! (klon)
-
-    real, intent(in):: delta_sal(:) ! (knon)
-    ! ocean-air interface salinity minus bulk salinity, in ppt
-
-    real, intent(in):: rhoa(:) ! (knon) density of moist air  (kg / m3)
-
-    REAL, intent(in):: delta_sst(:) ! (knon)
-    ! Ocean-air interface temperature minus bulk SST, in K. Defined
-    ! only if activate_ocean_skin >= 1.
-
-    REAL, intent(in):: dter(:) ! (knon)
-    ! Temperature variation in the diffusive microlayer, that is
-    ! ocean-air interface temperature minus subskin temperature. In
-    ! K.
-
-    REAL, intent(in):: dser(:) ! (knon)
-    ! Salinity variation in the diffusive microlayer, that is
-    ! ocean-air interface salinity minus subskin salinity. In ppt.
-
-    real, intent(in):: dt_ds(:) ! (knon)
-    ! (tks / tkt) * dTer, in K
-
-! In/Output arguments
-!****************************************************************************************
-    REAL, DIMENSION(klon), INTENT(INOUT)     :: radsol
-    REAL, DIMENSION(klon), INTENT(INOUT)     :: snow
-    REAL, DIMENSION(klon), INTENT(INOUT)     :: agesno
-  
-! Output arguments
-!****************************************************************************************
-    REAL, DIMENSION(klon), INTENT(OUT)       :: qsurf
-    REAL, DIMENSION(klon), INTENT(OUT)       :: evap, fluxsens, fluxlat
-    REAL, DIMENSION(klon), INTENT(OUT)       :: flux_u1, flux_v1
-    REAL, DIMENSION(klon), INTENT(OUT)       :: tsurf_new
-    REAL, DIMENSION(klon), INTENT(OUT)       :: dflux_s, dflux_l      
-    REAL, intent(out):: sens_prec_liq(:) ! (knon)
-
-    REAL, INTENT(OUT):: sss(:) ! (klon)
-    ! bulk salinity of the surface layer of the ocean, in ppt
-  
-
-! Local variables
-!****************************************************************************************
-    INTEGER               :: i, j
-    INTEGER, DIMENSION(1) :: iloc
-    REAL, DIMENSION(klon) :: cal, beta, dif_grnd
-    REAL, DIMENSION(klon) :: fder_new
-    REAL, DIMENSION(klon) :: tsurf_cpl
-    REAL, DIMENSION(klon) :: u0_cpl, v0_cpl
-    REAL, DIMENSION(klon) :: u1_lay, v1_lay
-    LOGICAL               :: check=.FALSE.
-    REAL sens_prec_sol(knon)  
-    REAL, DIMENSION(klon) :: lat_prec_liq, lat_prec_sol    
-
-! End definitions
-!****************************************************************************************
-
-    IF (check) WRITE(*,*)' Entering ocean_cpl_noice'
-
-!****************************************************************************************
-! Receive sea-surface temperature(tsurf_cpl) from coupler
-!
-!****************************************************************************************
-    CALL cpl_receive_ocean_fields(knon, knindex, tsurf_cpl, u0_cpl, v0_cpl, &
-         sss)
-
-!****************************************************************************************
-! Calculate fluxes at surface
-!
-!****************************************************************************************
-    cal = 0.
-    beta = 1.
-    dif_grnd = 0.
-    agesno(:) = 0.
-    lat_prec_liq = 0.; lat_prec_sol = 0.
-    
-
-    DO i = 1, knon
-       u1_lay(i) = u1(i) - u0_cpl(i)
-       v1_lay(i) = v1(i) - v0_cpl(i)
-    END DO
-
-    CALL calcul_fluxs(knon, is_oce, dtime, &
-         merge(tsurf_in, tsurf_cpl, activate_ocean_skin == 2), p1lay, cal, &
-         beta, cdragh, cdragq, ps, &
-         precip_rain, precip_snow, snow, qsurf,  &
-         radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, gustiness, &
-         f_qsat_oce,AcoefH, AcoefQ, BcoefH, BcoefQ, &
-         tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l, &
-         sens_prec_liq, sens_prec_sol, lat_prec_liq, lat_prec_sol, rhoa)
-
-    if (activate_ocean_skin == 2) then
-       ! tsurf_new was set to tsurf_in in calcul_flux, correct it to
-       ! the new bulk SST tsurf_cpl:
-       tsurf_new = tsurf_cpl
-    end if
-
-    ! assertion: tsurf_new == tsurf_cpl
-    
-    do j = 1, knon
-      i = knindex(j)
-      sens_prec_liq_o(i,1) = sens_prec_liq(j)
-      sens_prec_sol_o(i,1) = sens_prec_sol(j)
-      lat_prec_liq_o(i,1) = lat_prec_liq(j)
-      lat_prec_sol_o(i,1) = lat_prec_sol(j)
-    enddo
-
-
-    
-! - Flux calculation at first modele level for U and V
-    CALL calcul_flux_wind(knon, dtime, &
-         u0_cpl, v0_cpl, u1, v1, gustiness, cdragm, &
-         AcoefU, AcoefV, BcoefU, BcoefV, &
-         p1lay, temp_air, &
-         flux_u1, flux_v1)  
-
-!****************************************************************************************
-! Calculate fder : flux derivative (sensible and latente)
-!
-!****************************************************************************************
-    fder_new(:) = fder_old(:) + dflux_s(:) + dflux_l(:)
-    
-    iloc = MAXLOC(fder_new(1:klon))
-    IF (check .AND. fder_new(iloc(1))> 0.) THEN
-       WRITE(*,*)'**** Debug fder****'
-       WRITE(*,*)'max fder(',iloc(1),') = ',fder_new(iloc(1))
-       WRITE(*,*)'fder_old, dflux_s, dflux_l',fder_old(iloc(1)), &
-            dflux_s(iloc(1)), dflux_l(iloc(1))
-    ENDIF
-
-!****************************************************************************************
-! Send and cumulate fields to the coupler
-!
-!****************************************************************************************
-
-    CALL cpl_send_ocean_fields(itime, knon, knindex, swnet, lwnet, fluxlat, &
-         fluxsens, precip_rain, precip_snow, evap, tsurf_new, fder_new, alb1, &
-         flux_u1, flux_v1, windsp, sens_prec_liq, sens_prec_sol, lat_prec_liq, &
-         lat_prec_sol, delta_sst, delta_sal, dTer, dSer, dt_ds)
-
-  END SUBROUTINE ocean_cpl_noice
-!
-!****************************************************************************************
-!
-  SUBROUTINE ocean_cpl_ice( &
-       rlon, rlat, swnet, lwnet, alb1, &
-       fder_old, &
-       itime, dtime, knon, knindex, &
-       lafin, &
-       p1lay, cdragh, cdragm, precip_rain, precip_snow, temp_air, spechum, &
-       AcoefH, AcoefQ, BcoefH, BcoefQ, &
-       AcoefU, AcoefV, BcoefU, BcoefV, &
-       ps, u1, v1, gustiness, pctsrf, &
-       radsol, snow, qsurf, &
-       alb1_new, alb2_new, evap, fluxsens, fluxlat, flux_u1, flux_v1, &
-       tsurf_new, dflux_s, dflux_l, rhoa)
-!
-! This subroutine treats the ocean where there is ice. The subroutine first receives 
-! fields from coupler, then some calculations at surface is done and finally sends 
-! some fields to the coupler.
-!    
-    USE dimphy,           ONLY : klon
-    USE cpl_mod
-    USE calcul_fluxs_mod
-    USE indice_sol_mod
-    USE phys_output_var_mod, ONLY : sens_prec_liq_o, sens_prec_sol_o, lat_prec_liq_o, lat_prec_sol_o
-
-    INCLUDE "YOMCST.h"
-    INCLUDE "clesphys.h"
-
-! Input arguments
-!****************************************************************************************
-    INTEGER, INTENT(IN)                      :: itime, knon
-    INTEGER, DIMENSION(klon), INTENT(IN)     :: knindex
-    LOGICAL, INTENT(IN)                      :: lafin
-    REAL, INTENT(IN)                         :: dtime
-    REAL, DIMENSION(klon), INTENT(IN)        :: rlon, rlat
-    REAL, DIMENSION(klon), INTENT(IN)        :: swnet
-    REAL, DIMENSION(klon), INTENT(IN)        :: lwnet
-    REAL, DIMENSION(klon), INTENT(IN)        :: alb1   ! albedo in visible SW interval
-    REAL, DIMENSION(klon), INTENT(IN)        :: fder_old
-    REAL, DIMENSION(klon), INTENT(IN)        :: p1lay
-    REAL, DIMENSION(klon), INTENT(IN)        :: cdragh, cdragm
-    REAL, DIMENSION(klon), INTENT(IN)        :: precip_rain, precip_snow
-    REAL, DIMENSION(klon), INTENT(IN)        :: temp_air, spechum
-    REAL, DIMENSION(klon), INTENT(IN)        :: AcoefH, AcoefQ, BcoefH, BcoefQ
-    REAL, DIMENSION(klon), INTENT(IN)        :: AcoefU, AcoefV, BcoefU, BcoefV
-    REAL, DIMENSION(klon), INTENT(IN)        :: ps
-    REAL, DIMENSION(klon), INTENT(IN)        :: u1, v1, gustiness
-    REAL, DIMENSION(klon,nbsrf), INTENT(IN)  :: pctsrf
-    real, intent(in):: rhoa(:) ! (knon) density of moist air  (kg / m3)
-
-! In/output arguments
-!****************************************************************************************
-    REAL, DIMENSION(klon), INTENT(INOUT)     :: radsol
-    REAL, DIMENSION(klon), INTENT(INOUT)     :: snow
-
-! Output arguments
-!****************************************************************************************
-    REAL, DIMENSION(klon), INTENT(OUT)       :: qsurf
-    REAL, DIMENSION(klon), INTENT(OUT)       :: alb1_new, alb2_new
-    REAL, DIMENSION(klon), INTENT(OUT)       :: evap, fluxsens, fluxlat
-    REAL, DIMENSION(klon), INTENT(OUT)       :: flux_u1, flux_v1
-    REAL, DIMENSION(klon), INTENT(OUT)       :: tsurf_new
-    REAL, DIMENSION(klon), INTENT(OUT)       :: dflux_s, dflux_l      
-  
-
-! Local variables
-!****************************************************************************************
-    INTEGER                 :: i, j
-    INTEGER, DIMENSION(1)   :: iloc
-    LOGICAL                 :: check=.FALSE.
-    REAL, PARAMETER         :: t_grnd=271.35
-    REAL, DIMENSION(klon)   :: cal, beta, dif_grnd
-    REAL, DIMENSION(klon)   :: tsurf_cpl, fder_new
-    REAL, DIMENSION(klon)   :: alb_cpl
-    REAL, DIMENSION(klon)   :: u0, v0
-    REAL, DIMENSION(klon)   :: u1_lay, v1_lay
-    REAL sens_prec_liq(knon), sens_prec_sol(knon)   
-    REAL, DIMENSION(klon) :: lat_prec_liq, lat_prec_sol    
-
-! End definitions
-!****************************************************************************************
-    
-    IF (check) WRITE(*,*)'Entering surface_seaice, knon=',knon 
-
-    lat_prec_liq = 0.; lat_prec_sol = 0.
-
-!****************************************************************************************
-! Receive ocean temperature(tsurf_cpl) and albedo(alb_new) from coupler
-!
-!****************************************************************************************
-
-    CALL cpl_receive_seaice_fields(knon, knindex, &
-         tsurf_cpl, alb_cpl, u0, v0)
-
-    alb1_new(1:knon) = alb_cpl(1:knon)
-    alb2_new(1:knon) = alb_cpl(1:knon)    
-
-    
-!****************************************************************************************
-! Calculate fluxes at surface
-!
-!****************************************************************************************
-    cal = 0.
-    dif_grnd = 0.
-    beta = 1.0
-    
-    DO i = 1, knon
-       u1_lay(i) = u1(i) - u0(i)
-       v1_lay(i) = v1(i) - v0(i)
-    END DO
-
-    CALL calcul_fluxs(knon, is_sic, dtime, &
-         tsurf_cpl, p1lay, cal, beta, cdragh, cdragh, ps, &
-         precip_rain, precip_snow, snow, qsurf,  &
-         radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, gustiness, &
-         f_qsat_oce,AcoefH, AcoefQ, BcoefH, BcoefQ, &
-         tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l, &
-         sens_prec_liq, sens_prec_sol, lat_prec_liq, lat_prec_sol, rhoa)
-    do j = 1, knon
-      i = knindex(j)
-      sens_prec_liq_o(i,2) = sens_prec_liq(j)
-      sens_prec_sol_o(i,2) = sens_prec_sol(j)
-      lat_prec_liq_o(i,2) = lat_prec_liq(j)
-      lat_prec_sol_o(i,2) = lat_prec_sol(j)
-    enddo
-
-
-! - Flux calculation at first modele level for U and V
-    CALL calcul_flux_wind(knon, dtime, &
-         u0, v0, u1, v1, gustiness, cdragm, &
-         AcoefU, AcoefV, BcoefU, BcoefV, &
-         p1lay, temp_air, &
-         flux_u1, flux_v1)  
-
-!****************************************************************************************
-! Calculate fder : flux derivative (sensible and latente)
-!
-!****************************************************************************************
-    fder_new(:) = fder_old(:) + dflux_s(:) + dflux_l(:)
-    
-    iloc = MAXLOC(fder_new(1:klon))
-    IF (check .AND. fder_new(iloc(1))> 0.) THEN
-       WRITE(*,*)'**** Debug fder ****'
-       WRITE(*,*)'max fder(',iloc(1),') = ',fder_new(iloc(1))
-       WRITE(*,*)'fder_old, dflux_s, dflux_l',fder_old(iloc(1)), &
-            dflux_s(iloc(1)), dflux_l(iloc(1))
-    ENDIF
-
-!****************************************************************************************
-! Send and cumulate fields to the coupler
-!
-!****************************************************************************************
-
-    CALL cpl_send_seaice_fields(itime, dtime, knon, knindex, &
-       pctsrf, lafin, rlon, rlat, &
-       swnet, lwnet, fluxlat, fluxsens, &
-       precip_rain, precip_snow, evap, tsurf_new, fder_new, alb1, flux_u1, flux_v1,&
-       sens_prec_liq, sens_prec_sol, lat_prec_liq, lat_prec_sol)
-
- 
-
-  END SUBROUTINE ocean_cpl_ice
-!  
-!****************************************************************************************
-!
-END MODULE ocean_cpl_mod
Index: /LMDZ6/trunk/libf/phylmd/ocean_cpl_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/ocean_cpl_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/ocean_cpl_mod.f90	(revision 5268)
@@ -0,0 +1,402 @@
+!
+! $Id$
+!
+MODULE ocean_cpl_mod
+!
+! This module is used both for the sub-surface ocean and sea-ice for the case of a 
+! coupled model configuration, ocean=couple. 
+!
+
+  IMPLICIT NONE
+  PRIVATE
+
+  PUBLIC :: ocean_cpl_init, ocean_cpl_noice, ocean_cpl_ice
+
+
+!****************************************************************************************
+!
+CONTAINS
+!
+!****************************************************************************************
+!
+  SUBROUTINE ocean_cpl_init(dtime, rlon, rlat)
+!
+! Allocate fields for this module and initailize the module mod_cpl
+!
+    USE dimphy,           ONLY : klon
+    USE cpl_mod
+
+! Input arguments
+!*************************************************************************************
+    REAL, INTENT(IN)                  :: dtime
+    REAL, DIMENSION(klon), INTENT(IN) :: rlon, rlat
+
+! Local variables
+!*************************************************************************************
+    INTEGER              :: error
+    CHARACTER (len = 80) :: abort_message
+    CHARACTER (len = 20) :: modname = 'ocean_cpl_init'
+
+! Initialize module cpl_init
+    CALL cpl_init(dtime, rlon, rlat)
+    
+  END SUBROUTINE ocean_cpl_init
+!
+!****************************************************************************************
+!
+  SUBROUTINE ocean_cpl_noice( &
+       swnet, lwnet, alb1, &
+       windsp, fder_old, &
+       itime, dtime, knon, knindex, &
+       p1lay, cdragh, cdragq, cdragm, precip_rain, precip_snow, temp_air, spechum, &
+       AcoefH, AcoefQ, BcoefH, BcoefQ, &
+       AcoefU, AcoefV, BcoefU, BcoefV, &
+       ps, u1, v1, gustiness, tsurf_in, &
+       radsol, snow, agesno, &
+       qsurf, evap, fluxsens, fluxlat, flux_u1, flux_v1, &
+       tsurf_new, dflux_s, dflux_l, sens_prec_liq, sss, delta_sal, rhoa, &
+       delta_sst, dTer, dSer, dt_ds)
+
+!
+! This subroutine treats the "open ocean", all grid points that are not entierly covered
+! by ice. The subroutine first receives fields from coupler, then some calculations at 
+! surface is done and finally it sends some fields to the coupler.
+!
+    USE dimphy,           ONLY : klon
+    USE calcul_fluxs_mod
+    USE indice_sol_mod
+    USE phys_output_var_mod, ONLY : sens_prec_liq_o, sens_prec_sol_o, lat_prec_liq_o, lat_prec_sol_o
+    USE cpl_mod, ONLY : gath2cpl, cpl_receive_ocean_fields, &
+         cpl_send_ocean_fields
+    use config_ocean_skin_m, only: activate_ocean_skin
+
+    INCLUDE "YOMCST.h"
+    INCLUDE "clesphys.h"
+!    
+! Input arguments  
+!****************************************************************************************
+    INTEGER, INTENT(IN)                      :: itime, knon
+    INTEGER, DIMENSION(klon), INTENT(IN)     :: knindex
+    REAL, INTENT(IN)                         :: dtime
+    REAL, DIMENSION(klon), INTENT(IN)        :: swnet
+    REAL, DIMENSION(klon), INTENT(IN)        :: lwnet
+    REAL, DIMENSION(klon), INTENT(IN)        :: alb1   ! albedo in visible SW interval
+    REAL, DIMENSION(klon), INTENT(IN)        :: windsp
+    REAL, DIMENSION(klon), INTENT(IN)        :: fder_old
+    REAL, DIMENSION(klon), INTENT(IN)        :: p1lay
+    REAL, DIMENSION(klon), INTENT(IN)        :: cdragh, cdragq, cdragm
+    REAL, DIMENSION(klon), INTENT(IN)        :: precip_rain, precip_snow
+    REAL, DIMENSION(klon), INTENT(IN)        :: temp_air, spechum
+    REAL, DIMENSION(klon), INTENT(IN)        :: AcoefH, AcoefQ, BcoefH, BcoefQ
+    REAL, DIMENSION(klon), INTENT(IN)        :: AcoefU, AcoefV, BcoefU, BcoefV
+    REAL, DIMENSION(klon), INTENT(IN)        :: ps
+    REAL, DIMENSION(klon), INTENT(IN)        :: u1, v1, gustiness
+    REAL, INTENT(IN) :: tsurf_in(:) ! (klon)
+
+    real, intent(in):: delta_sal(:) ! (knon)
+    ! ocean-air interface salinity minus bulk salinity, in ppt
+
+    real, intent(in):: rhoa(:) ! (knon) density of moist air  (kg / m3)
+
+    REAL, intent(in):: delta_sst(:) ! (knon)
+    ! Ocean-air interface temperature minus bulk SST, in K. Defined
+    ! only if activate_ocean_skin >= 1.
+
+    REAL, intent(in):: dter(:) ! (knon)
+    ! Temperature variation in the diffusive microlayer, that is
+    ! ocean-air interface temperature minus subskin temperature. In
+    ! K.
+
+    REAL, intent(in):: dser(:) ! (knon)
+    ! Salinity variation in the diffusive microlayer, that is
+    ! ocean-air interface salinity minus subskin salinity. In ppt.
+
+    real, intent(in):: dt_ds(:) ! (knon)
+    ! (tks / tkt) * dTer, in K
+
+! In/Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(INOUT)     :: radsol
+    REAL, DIMENSION(klon), INTENT(INOUT)     :: snow
+    REAL, DIMENSION(klon), INTENT(INOUT)     :: agesno
+  
+! Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(OUT)       :: qsurf
+    REAL, DIMENSION(klon), INTENT(OUT)       :: evap, fluxsens, fluxlat
+    REAL, DIMENSION(klon), INTENT(OUT)       :: flux_u1, flux_v1
+    REAL, DIMENSION(klon), INTENT(OUT)       :: tsurf_new
+    REAL, DIMENSION(klon), INTENT(OUT)       :: dflux_s, dflux_l      
+    REAL, intent(out):: sens_prec_liq(:) ! (knon)
+
+    REAL, INTENT(OUT):: sss(:) ! (klon)
+    ! bulk salinity of the surface layer of the ocean, in ppt
+  
+
+! Local variables
+!****************************************************************************************
+    INTEGER               :: i, j
+    INTEGER, DIMENSION(1) :: iloc
+    REAL, DIMENSION(klon) :: cal, beta, dif_grnd
+    REAL, DIMENSION(klon) :: fder_new
+    REAL, DIMENSION(klon) :: tsurf_cpl
+    REAL, DIMENSION(klon) :: u0_cpl, v0_cpl
+    REAL, DIMENSION(klon) :: u1_lay, v1_lay
+    LOGICAL               :: check=.FALSE.
+    REAL sens_prec_sol(knon)  
+    REAL, DIMENSION(klon) :: lat_prec_liq, lat_prec_sol    
+
+! End definitions
+!****************************************************************************************
+
+    IF (check) WRITE(*,*)' Entering ocean_cpl_noice'
+
+!****************************************************************************************
+! Receive sea-surface temperature(tsurf_cpl) from coupler
+!
+!****************************************************************************************
+    CALL cpl_receive_ocean_fields(knon, knindex, tsurf_cpl, u0_cpl, v0_cpl, &
+         sss)
+
+!****************************************************************************************
+! Calculate fluxes at surface
+!
+!****************************************************************************************
+    cal = 0.
+    beta = 1.
+    dif_grnd = 0.
+    agesno(:) = 0.
+    lat_prec_liq = 0.; lat_prec_sol = 0.
+    
+
+    DO i = 1, knon
+       u1_lay(i) = u1(i) - u0_cpl(i)
+       v1_lay(i) = v1(i) - v0_cpl(i)
+    END DO
+
+    CALL calcul_fluxs(knon, is_oce, dtime, &
+         merge(tsurf_in, tsurf_cpl, activate_ocean_skin == 2), p1lay, cal, &
+         beta, cdragh, cdragq, ps, &
+         precip_rain, precip_snow, snow, qsurf,  &
+         radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, gustiness, &
+         f_qsat_oce,AcoefH, AcoefQ, BcoefH, BcoefQ, &
+         tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l, &
+         sens_prec_liq, sens_prec_sol, lat_prec_liq, lat_prec_sol, rhoa)
+
+    if (activate_ocean_skin == 2) then
+       ! tsurf_new was set to tsurf_in in calcul_flux, correct it to
+       ! the new bulk SST tsurf_cpl:
+       tsurf_new = tsurf_cpl
+    end if
+
+    ! assertion: tsurf_new == tsurf_cpl
+    
+    do j = 1, knon
+      i = knindex(j)
+      sens_prec_liq_o(i,1) = sens_prec_liq(j)
+      sens_prec_sol_o(i,1) = sens_prec_sol(j)
+      lat_prec_liq_o(i,1) = lat_prec_liq(j)
+      lat_prec_sol_o(i,1) = lat_prec_sol(j)
+    enddo
+
+
+    
+! - Flux calculation at first modele level for U and V
+    CALL calcul_flux_wind(knon, dtime, &
+         u0_cpl, v0_cpl, u1, v1, gustiness, cdragm, &
+         AcoefU, AcoefV, BcoefU, BcoefV, &
+         p1lay, temp_air, &
+         flux_u1, flux_v1)  
+
+!****************************************************************************************
+! Calculate fder : flux derivative (sensible and latente)
+!
+!****************************************************************************************
+    fder_new(:) = fder_old(:) + dflux_s(:) + dflux_l(:)
+    
+    iloc = MAXLOC(fder_new(1:klon))
+    IF (check .AND. fder_new(iloc(1))> 0.) THEN
+       WRITE(*,*)'**** Debug fder****'
+       WRITE(*,*)'max fder(',iloc(1),') = ',fder_new(iloc(1))
+       WRITE(*,*)'fder_old, dflux_s, dflux_l',fder_old(iloc(1)), &
+            dflux_s(iloc(1)), dflux_l(iloc(1))
+    ENDIF
+
+!****************************************************************************************
+! Send and cumulate fields to the coupler
+!
+!****************************************************************************************
+
+    CALL cpl_send_ocean_fields(itime, knon, knindex, swnet, lwnet, fluxlat, &
+         fluxsens, precip_rain, precip_snow, evap, tsurf_new, fder_new, alb1, &
+         flux_u1, flux_v1, windsp, sens_prec_liq, sens_prec_sol, lat_prec_liq, &
+         lat_prec_sol, delta_sst, delta_sal, dTer, dSer, dt_ds)
+
+  END SUBROUTINE ocean_cpl_noice
+!
+!****************************************************************************************
+!
+  SUBROUTINE ocean_cpl_ice( &
+       rlon, rlat, swnet, lwnet, alb1, &
+       fder_old, &
+       itime, dtime, knon, knindex, &
+       lafin, &
+       p1lay, cdragh, cdragm, precip_rain, precip_snow, temp_air, spechum, &
+       AcoefH, AcoefQ, BcoefH, BcoefQ, &
+       AcoefU, AcoefV, BcoefU, BcoefV, &
+       ps, u1, v1, gustiness, pctsrf, &
+       radsol, snow, qsurf, &
+       alb1_new, alb2_new, evap, fluxsens, fluxlat, flux_u1, flux_v1, &
+       tsurf_new, dflux_s, dflux_l, rhoa)
+!
+! This subroutine treats the ocean where there is ice. The subroutine first receives 
+! fields from coupler, then some calculations at surface is done and finally sends 
+! some fields to the coupler.
+!    
+    USE dimphy,           ONLY : klon
+    USE cpl_mod
+    USE calcul_fluxs_mod
+    USE indice_sol_mod
+    USE phys_output_var_mod, ONLY : sens_prec_liq_o, sens_prec_sol_o, lat_prec_liq_o, lat_prec_sol_o
+
+    INCLUDE "YOMCST.h"
+    INCLUDE "clesphys.h"
+
+! Input arguments
+!****************************************************************************************
+    INTEGER, INTENT(IN)                      :: itime, knon
+    INTEGER, DIMENSION(klon), INTENT(IN)     :: knindex
+    LOGICAL, INTENT(IN)                      :: lafin
+    REAL, INTENT(IN)                         :: dtime
+    REAL, DIMENSION(klon), INTENT(IN)        :: rlon, rlat
+    REAL, DIMENSION(klon), INTENT(IN)        :: swnet
+    REAL, DIMENSION(klon), INTENT(IN)        :: lwnet
+    REAL, DIMENSION(klon), INTENT(IN)        :: alb1   ! albedo in visible SW interval
+    REAL, DIMENSION(klon), INTENT(IN)        :: fder_old
+    REAL, DIMENSION(klon), INTENT(IN)        :: p1lay
+    REAL, DIMENSION(klon), INTENT(IN)        :: cdragh, cdragm
+    REAL, DIMENSION(klon), INTENT(IN)        :: precip_rain, precip_snow
+    REAL, DIMENSION(klon), INTENT(IN)        :: temp_air, spechum
+    REAL, DIMENSION(klon), INTENT(IN)        :: AcoefH, AcoefQ, BcoefH, BcoefQ
+    REAL, DIMENSION(klon), INTENT(IN)        :: AcoefU, AcoefV, BcoefU, BcoefV
+    REAL, DIMENSION(klon), INTENT(IN)        :: ps
+    REAL, DIMENSION(klon), INTENT(IN)        :: u1, v1, gustiness
+    REAL, DIMENSION(klon,nbsrf), INTENT(IN)  :: pctsrf
+    real, intent(in):: rhoa(:) ! (knon) density of moist air  (kg / m3)
+
+! In/output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(INOUT)     :: radsol
+    REAL, DIMENSION(klon), INTENT(INOUT)     :: snow
+
+! Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(OUT)       :: qsurf
+    REAL, DIMENSION(klon), INTENT(OUT)       :: alb1_new, alb2_new
+    REAL, DIMENSION(klon), INTENT(OUT)       :: evap, fluxsens, fluxlat
+    REAL, DIMENSION(klon), INTENT(OUT)       :: flux_u1, flux_v1
+    REAL, DIMENSION(klon), INTENT(OUT)       :: tsurf_new
+    REAL, DIMENSION(klon), INTENT(OUT)       :: dflux_s, dflux_l      
+  
+
+! Local variables
+!****************************************************************************************
+    INTEGER                 :: i, j
+    INTEGER, DIMENSION(1)   :: iloc
+    LOGICAL                 :: check=.FALSE.
+    REAL, PARAMETER         :: t_grnd=271.35
+    REAL, DIMENSION(klon)   :: cal, beta, dif_grnd
+    REAL, DIMENSION(klon)   :: tsurf_cpl, fder_new
+    REAL, DIMENSION(klon)   :: alb_cpl
+    REAL, DIMENSION(klon)   :: u0, v0
+    REAL, DIMENSION(klon)   :: u1_lay, v1_lay
+    REAL sens_prec_liq(knon), sens_prec_sol(knon)   
+    REAL, DIMENSION(klon) :: lat_prec_liq, lat_prec_sol    
+
+! End definitions
+!****************************************************************************************
+    
+    IF (check) WRITE(*,*)'Entering surface_seaice, knon=',knon 
+
+    lat_prec_liq = 0.; lat_prec_sol = 0.
+
+!****************************************************************************************
+! Receive ocean temperature(tsurf_cpl) and albedo(alb_new) from coupler
+!
+!****************************************************************************************
+
+    CALL cpl_receive_seaice_fields(knon, knindex, &
+         tsurf_cpl, alb_cpl, u0, v0)
+
+    alb1_new(1:knon) = alb_cpl(1:knon)
+    alb2_new(1:knon) = alb_cpl(1:knon)    
+
+    
+!****************************************************************************************
+! Calculate fluxes at surface
+!
+!****************************************************************************************
+    cal = 0.
+    dif_grnd = 0.
+    beta = 1.0
+    
+    DO i = 1, knon
+       u1_lay(i) = u1(i) - u0(i)
+       v1_lay(i) = v1(i) - v0(i)
+    END DO
+
+    CALL calcul_fluxs(knon, is_sic, dtime, &
+         tsurf_cpl, p1lay, cal, beta, cdragh, cdragh, ps, &
+         precip_rain, precip_snow, snow, qsurf,  &
+         radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, gustiness, &
+         f_qsat_oce,AcoefH, AcoefQ, BcoefH, BcoefQ, &
+         tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l, &
+         sens_prec_liq, sens_prec_sol, lat_prec_liq, lat_prec_sol, rhoa)
+    do j = 1, knon
+      i = knindex(j)
+      sens_prec_liq_o(i,2) = sens_prec_liq(j)
+      sens_prec_sol_o(i,2) = sens_prec_sol(j)
+      lat_prec_liq_o(i,2) = lat_prec_liq(j)
+      lat_prec_sol_o(i,2) = lat_prec_sol(j)
+    enddo
+
+
+! - Flux calculation at first modele level for U and V
+    CALL calcul_flux_wind(knon, dtime, &
+         u0, v0, u1, v1, gustiness, cdragm, &
+         AcoefU, AcoefV, BcoefU, BcoefV, &
+         p1lay, temp_air, &
+         flux_u1, flux_v1)  
+
+!****************************************************************************************
+! Calculate fder : flux derivative (sensible and latente)
+!
+!****************************************************************************************
+    fder_new(:) = fder_old(:) + dflux_s(:) + dflux_l(:)
+    
+    iloc = MAXLOC(fder_new(1:klon))
+    IF (check .AND. fder_new(iloc(1))> 0.) THEN
+       WRITE(*,*)'**** Debug fder ****'
+       WRITE(*,*)'max fder(',iloc(1),') = ',fder_new(iloc(1))
+       WRITE(*,*)'fder_old, dflux_s, dflux_l',fder_old(iloc(1)), &
+            dflux_s(iloc(1)), dflux_l(iloc(1))
+    ENDIF
+
+!****************************************************************************************
+! Send and cumulate fields to the coupler
+!
+!****************************************************************************************
+
+    CALL cpl_send_seaice_fields(itime, dtime, knon, knindex, &
+       pctsrf, lafin, rlon, rlat, &
+       swnet, lwnet, fluxlat, fluxsens, &
+       precip_rain, precip_snow, evap, tsurf_new, fder_new, alb1, flux_u1, flux_v1,&
+       sens_prec_liq, sens_prec_sol, lat_prec_liq, lat_prec_sol)
+
+ 
+
+  END SUBROUTINE ocean_cpl_ice
+!  
+!****************************************************************************************
+!
+END MODULE ocean_cpl_mod
Index: DZ6/trunk/libf/phylmd/ocean_slab_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/ocean_slab_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,991 +1,0 @@
-!Completed
-MODULE ocean_slab_mod
-!
-! This module is used for both surface ocean and sea-ice when using the slab ocean,
-! "ocean=slab".
-!
-
-  USE dimphy
-  USE indice_sol_mod
-  USE surface_data
-  USE mod_grid_phy_lmdz, ONLY: klon_glo
-  USE mod_phys_lmdz_mpi_data, ONLY: is_mpi_root
-
-  IMPLICIT NONE
-  PRIVATE
-  PUBLIC :: ocean_slab_init, ocean_slab_frac, ocean_slab_noice, ocean_slab_ice
-
-!***********************************************************************************
-! Global saved variables
-!***********************************************************************************
-  ! number of slab vertical layers
-  INTEGER, PUBLIC, SAVE :: nslay
-  !$OMP THREADPRIVATE(nslay)
-  ! timestep for coupling (update slab temperature) in timesteps
-  INTEGER, PRIVATE, SAVE                           :: cpl_pas
-  !$OMP THREADPRIVATE(cpl_pas)
-  ! cyang = 1/heat capacity of top layer (rho.c.H)
-  REAL, PRIVATE, SAVE                              :: cyang
-  !$OMP THREADPRIVATE(cyang)
-  ! depth of slab layers (1 or 2)
-  REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE   :: slabh
-  !$OMP THREADPRIVATE(slabh)
-  ! slab temperature
-  REAL, ALLOCATABLE, DIMENSION(:,:), PUBLIC, SAVE   :: tslab
-  !$OMP THREADPRIVATE(tslab)
-  ! heat flux convergence due to Ekman
-  REAL, ALLOCATABLE, DIMENSION(:,:), PUBLIC, SAVE   :: dt_ekman
-  !$OMP THREADPRIVATE(dt_ekman)
-  ! heat flux convergence due to horiz diffusion
-  REAL, ALLOCATABLE, DIMENSION(:,:), PUBLIC, SAVE   :: dt_hdiff
-  !$OMP THREADPRIVATE(dt_hdiff)
-  ! heat flux convergence due to GM eddy advection
-  REAL, ALLOCATABLE, DIMENSION(:,:), PUBLIC, SAVE   :: dt_gm
-  !$OMP THREADPRIVATE(dt_gm)
-  ! Heat Flux correction 
-  REAL, ALLOCATABLE, DIMENSION(:,:), PUBLIC, SAVE   :: dt_qflux
-  !$OMP THREADPRIVATE(dt_qflux)
-  ! fraction of ocean covered by sea ice (sic / (oce+sic))
-  REAL, ALLOCATABLE, DIMENSION(:), PUBLIC, SAVE  :: fsic
-  !$OMP THREADPRIVATE(fsic)
-  ! temperature of the sea ice
-  REAL, ALLOCATABLE, DIMENSION(:), PUBLIC, SAVE  :: tice
-  !$OMP THREADPRIVATE(tice)
-  ! sea ice thickness, in kg/m2
-  REAL, ALLOCATABLE, DIMENSION(:), PUBLIC, SAVE  :: seaice
-  !$OMP THREADPRIVATE(seaice)
-  ! net surface heat flux, weighted by open ocean fraction
-  ! slab_bils accumulated over cpl_pas timesteps
-  REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE  :: bils_cum
-  !$OMP THREADPRIVATE(bils_cum)
-  ! net heat flux into the ocean below the ice : conduction + solar radiation
-  REAL, ALLOCATABLE, DIMENSION(:), PUBLIC, SAVE  :: slab_bilg
-  !$OMP THREADPRIVATE(slab_bilg)
-  ! slab_bilg over cpl_pas timesteps
-  REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE  :: bilg_cum
-  !$OMP THREADPRIVATE(bilg_cum)
-  ! wind stress saved over cpl_pas timesteps
-  REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE  :: taux_cum
-  !$OMP THREADPRIVATE(taux_cum)
-  REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE  :: tauy_cum
-  !$OMP THREADPRIVATE(tauy_cum)
-
-!***********************************************************************************
-! Parameters (could be read in def file: move to slab_init)
-!***********************************************************************************
-! snow and ice physical characteristics:
-    REAL, PARAMETER :: t_freeze=271.35 ! freezing sea water temp
-    REAL, PARAMETER :: t_melt=273.15   ! melting ice temp
-    REAL, PARAMETER :: sno_den=300. !mean snow density, kg/m3
-    REAL, PARAMETER :: ice_den=917. ! ice density
-    REAL, PARAMETER :: sea_den=1025. ! sea water density
-    REAL, PARAMETER :: ice_cond=2.17*ice_den !conductivity of ice
-    REAL, PARAMETER :: sno_cond=0.31*sno_den ! conductivity of snow
-    REAL, PARAMETER :: ice_cap=2067.   ! specific heat capacity, snow and ice
-    REAL, PARAMETER :: sea_cap=3995.   ! specific heat capacity, snow and ice
-    REAL, PARAMETER :: ice_lat=334000. ! freeze /melt latent heat snow and ice
-
-! control of snow and ice cover & freeze / melt (heights converted to kg/m2)
-    REAL, PARAMETER :: snow_min=0.05*sno_den !critical snow height 5 cm
-    REAL, PARAMETER :: snow_wfact=0.4 ! max fraction of falling snow blown into ocean
-    REAL, PARAMETER :: ice_frac_min=0.001
-    REAL, PARAMETER :: ice_frac_max=1. ! less than 1. if min leads fraction 
-    REAL, PARAMETER :: h_ice_min=0.01*ice_den ! min ice thickness 
-    REAL, PARAMETER :: h_ice_thin=0.15*ice_den ! thin ice thickness 
-    ! below ice_thin, priority is melt lateral / grow height
-    ! ice_thin is also height of new ice
-    REAL, PARAMETER :: h_ice_thick=2.5*ice_den ! thin ice thickness 
-    ! above ice_thick, priority is melt height / grow lateral
-    REAL, PARAMETER :: h_ice_new=1.*ice_den ! max height of new open ocean ice 
-    REAL, PARAMETER :: h_ice_max=10.*ice_den ! max ice height 
-
-! albedo  and radiation parameters
-    REAL, PARAMETER :: alb_sno_min=0.55 !min snow albedo
-    REAL, PARAMETER :: alb_sno_del=0.3  !max snow albedo = min + del
-    REAL, PARAMETER :: alb_ice_dry=0.75 !dry thick ice
-    REAL, PARAMETER :: alb_ice_wet=0.66 !melting thick ice
-    REAL, PARAMETER :: pen_frac=0.3 !fraction of shortwave penetrating into the
-    ! ice (no snow)
-    REAL, PARAMETER :: pen_ext=1.5 !extinction of penetrating shortwave (m-1)
-
-! horizontal transport
-   LOGICAL, PUBLIC, SAVE :: slab_hdiff
-   !$OMP THREADPRIVATE(slab_hdiff)
-   LOGICAL, PUBLIC, SAVE :: slab_gm
-   !$OMP THREADPRIVATE(slab_gm)
-   REAL, PRIVATE, SAVE    :: coef_hdiff ! coefficient for horizontal diffusion
-   !$OMP THREADPRIVATE(coef_hdiff)
-   INTEGER, PUBLIC, SAVE :: slab_ekman, slab_cadj ! Ekman, conv adjustment
-   !$OMP THREADPRIVATE(slab_ekman)
-   !$OMP THREADPRIVATE(slab_cadj)
-
-!***********************************************************************************
-
-CONTAINS
-!
-!***********************************************************************************
-!
-  SUBROUTINE ocean_slab_init(dtime, pctsrf_rst)
-  !, seaice_rst etc
-
-    USE ioipsl_getin_p_mod, ONLY : getin_p
-    USE mod_phys_lmdz_transfert_para, ONLY : gather
-    USE slab_heat_transp_mod, ONLY : ini_slab_transp
-
-    ! Input variables
-!***********************************************************************************
-    REAL, INTENT(IN)                         :: dtime
-! Variables read from restart file
-    REAL, DIMENSION(klon, nbsrf), INTENT(IN) :: pctsrf_rst 
-    ! surface fractions from start file
-
-! Local variables
-!************************************************************************************
-    INTEGER                :: error
-    REAL, DIMENSION(klon_glo) :: zmasq_glo
-    CHARACTER (len = 80)   :: abort_message
-    CHARACTER (len = 20)   :: modname = 'ocean_slab_intit'
-
-!***********************************************************************************
-! Define some parameters
-!***********************************************************************************
-! Number of slab layers
-    nslay=2
-    CALL getin_p('slab_layers',nslay)
-    print *,'number of slab layers : ',nslay
-! Layer thickness
-    ALLOCATE(slabh(nslay), stat = error)
-    IF (error /= 0) THEN
-       abort_message='Pb allocation slabh'
-       CALL abort_physic(modname,abort_message,1)
-    ENDIF
-    slabh(1)=50.
-    CALL getin_p('slab_depth',slabh(1))
-    IF (nslay.GT.1) THEN 
-        slabh(2)=150.
-    END IF
-
-! cyang = 1/heat capacity of top layer (rho.c.H)
-    cyang=1/(slabh(1)*sea_den*sea_cap)
-
-! cpl_pas  coupling period (update of tslab and ice fraction)
-! pour un calcul a chaque pas de temps, cpl_pas=1
-    cpl_pas = NINT(86400./dtime * 1.0) ! une fois par jour
-    CALL getin_p('cpl_pas',cpl_pas)
-    print *,'cpl_pas',cpl_pas
-
-! Horizontal diffusion
-    slab_hdiff=.FALSE.
-    CALL getin_p('slab_hdiff',slab_hdiff)
-    coef_hdiff=25000.
-    CALL getin_p('coef_hdiff',coef_hdiff)
-! Ekman transport
-    slab_ekman=0
-    CALL getin_p('slab_ekman',slab_ekman)
-! GM eddy advection (2-layers only)
-    slab_gm=.FALSE.
-    CALL getin_p('slab_gm',slab_gm)
-    IF (slab_ekman.LT.2) THEN
-       slab_gm=.FALSE.
-    ENDIF 
-! Convective adjustment
-    IF (nslay.EQ.1) THEN
-        slab_cadj=0
-    ELSE
-        slab_cadj=1
-    END IF
-    CALL getin_p('slab_cadj',slab_cadj)
-
-!************************************************************************************
-! Allocate surface fraction read from restart file
-!************************************************************************************
-    ALLOCATE(fsic(klon), stat = error)
-    IF (error /= 0) THEN
-       abort_message='Pb allocation tmp_pctsrf_slab'
-       CALL abort_physic(modname,abort_message,1)
-    ENDIF
-    fsic(:)=0.
-    !zmasq = continent fraction
-    WHERE (1.-zmasq(:)>EPSFRA)
-        fsic(:) = pctsrf_rst(:,is_sic)/(1.-zmasq(:))
-    END WHERE
-
-!************************************************************************************
-! Allocate saved fields
-!************************************************************************************
-    ALLOCATE(tslab(klon,nslay), stat=error)
-       IF (error /= 0) CALL abort_physic &
-         (modname,'pb allocation tslab', 1)
-
-    ALLOCATE(bils_cum(klon), stat = error)
-    IF (error /= 0) THEN
-       abort_message='Pb allocation slab_bils_cum'
-       CALL abort_physic(modname,abort_message,1)
-    ENDIF
-    bils_cum(:) = 0.0   
-
-    IF (version_ocean=='sicINT') THEN ! interactive sea ice
-        ALLOCATE(slab_bilg(klon), stat = error)
-        IF (error /= 0) THEN
-           abort_message='Pb allocation slab_bilg'
-           CALL abort_physic(modname,abort_message,1)
-        ENDIF
-        slab_bilg(:) = 0.0   
-        ALLOCATE(bilg_cum(klon), stat = error)
-        IF (error /= 0) THEN
-           abort_message='Pb allocation slab_bilg_cum'
-           CALL abort_physic(modname,abort_message,1)
-        ENDIF
-        bilg_cum(:) = 0.0   
-        ALLOCATE(tice(klon), stat = error)
-        IF (error /= 0) THEN
-           abort_message='Pb allocation slab_tice'
-           CALL abort_physic(modname,abort_message,1)
-        ENDIF
-        ALLOCATE(seaice(klon), stat = error)
-        IF (error /= 0) THEN
-           abort_message='Pb allocation slab_seaice'
-           CALL abort_physic(modname,abort_message,1)
-        ENDIF
-    END IF
-
-    IF (slab_hdiff) THEN !horizontal diffusion
-        ALLOCATE(dt_hdiff(klon,nslay), stat = error)
-        IF (error /= 0) THEN
-           abort_message='Pb allocation dt_hdiff'
-           CALL abort_physic(modname,abort_message,1)
-        ENDIF
-        dt_hdiff(:,:) = 0.0   
-    ENDIF
-
-    ALLOCATE(dt_qflux(klon,nslay), stat = error)
-    IF (error /= 0) THEN
-       abort_message='Pb allocation dt_qflux'
-       CALL abort_physic(modname,abort_message,1)
-    ENDIF
-    dt_qflux(:,:) = 0.0   
-
-    IF (slab_gm) THEN !GM advection
-        ALLOCATE(dt_gm(klon,nslay), stat = error)
-        IF (error /= 0) THEN
-           abort_message='Pb allocation dt_gm'
-           CALL abort_physic(modname,abort_message,1)
-        ENDIF
-        dt_gm(:,:) = 0.0   
-    ENDIF
-
-    IF (slab_ekman.GT.0) THEN ! ekman transport
-        ALLOCATE(dt_ekman(klon,nslay), stat = error)
-        IF (error /= 0) THEN
-           abort_message='Pb allocation dt_ekman'
-           CALL abort_physic(modname,abort_message,1)
-        ENDIF
-        dt_ekman(:,:) = 0.0   
-        ALLOCATE(taux_cum(klon), stat = error)
-        IF (error /= 0) THEN
-           abort_message='Pb allocation taux_cum'
-           CALL abort_physic(modname,abort_message,1)
-        ENDIF
-        taux_cum(:) = 0.0   
-        ALLOCATE(tauy_cum(klon), stat = error)
-        IF (error /= 0) THEN
-           abort_message='Pb allocation tauy_cum'
-           CALL abort_physic(modname,abort_message,1)
-        ENDIF
-        tauy_cum(:) = 0.0   
-    ENDIF
-
-! Initialize transport
-    IF (slab_hdiff.OR.(slab_ekman.GT.0)) THEN
-      CALL gather(zmasq,zmasq_glo)
-! Master thread/process only
-!$OMP MASTER  
-      IF (is_mpi_root) THEN 
-          CALL ini_slab_transp(zmasq_glo)
-      END IF
-!$OMP END MASTER
-    END IF
-
- END SUBROUTINE ocean_slab_init
-!
-!***********************************************************************************
-!
-  SUBROUTINE ocean_slab_frac(itime, dtime, jour, pctsrf_chg, is_modified)
-
-! this routine sends back the sea ice and ocean fraction to the main physics
-! routine. Called only with interactive sea ice
-
-! Arguments
-!************************************************************************************
-    INTEGER, INTENT(IN)                        :: itime   ! current timestep 
-    INTEGER, INTENT(IN)                        :: jour    !  day in year (not 
-    REAL   , INTENT(IN)                        :: dtime   ! physics timestep (s)
-    REAL, DIMENSION(klon,nbsrf), INTENT(INOUT) :: pctsrf_chg  ! sub-surface fraction
-    LOGICAL, INTENT(OUT)                       :: is_modified ! true if pctsrf is 
-                                                         ! modified at this time step
-
-       pctsrf_chg(:,is_oce)=(1.-fsic(:))*(1.-zmasq(:))
-       pctsrf_chg(:,is_sic)=fsic(:)*(1.-zmasq(:))
-       is_modified=.TRUE.
-
-  END SUBROUTINE ocean_slab_frac
-!
-!************************************************************************************
-!
-  SUBROUTINE ocean_slab_noice( & 
-       itime, dtime, jour, knon, knindex, &
-       p1lay, cdragh, cdragq, cdragm, precip_rain, precip_snow, temp_air, spechum, &
-       AcoefH, AcoefQ, BcoefH, BcoefQ, &
-       AcoefU, AcoefV, BcoefU, BcoefV, &
-       ps, u1, v1, gustiness, tsurf_in, &
-       radsol, snow, &
-       qsurf, evap, fluxsens, fluxlat, flux_u1, flux_v1, &
-       tsurf_new, dflux_s, dflux_l, slab_bils)
-    
-    USE calcul_fluxs_mod
-    USE slab_heat_transp_mod, ONLY: divgrad_phy,slab_ekman1,slab_ekman2,slab_gmdiff
-    USE mod_phys_lmdz_para
-
-    INCLUDE "clesphys.h"
-
-! This routine 
-! (1) computes surface turbulent fluxes over points with some open ocean    
-! (2) reads additional Q-flux (everywhere)
-! (3) computes horizontal transport (diffusion & Ekman)
-! (4) updates slab temperature every cpl_pas ; creates new ice if needed.
-
-! Note : 
-! klon total number of points
-! knon number of points with open ocean (varies with time)
-! knindex gives position of the knon points within klon.
-! In general, local saved variables have klon values
-! variables exchanged with PBL module have knon.
-
-! Input arguments
-!***********************************************************************************
-    INTEGER, INTENT(IN)                  :: itime ! current timestep INTEGER,
-    INTEGER, INTENT(IN)                  :: jour  ! day in year (for Q-Flux) 
-    INTEGER, INTENT(IN)                  :: knon  ! number of points 
-    INTEGER, DIMENSION(klon), INTENT(IN) :: knindex 
-    REAL, INTENT(IN) :: dtime  ! timestep (s)
-    REAL, DIMENSION(klon), INTENT(IN)    :: p1lay 
-    REAL, DIMENSION(klon), INTENT(IN)    :: cdragh, cdragq, cdragm 
-    ! drag coefficients
-    REAL, DIMENSION(klon), INTENT(IN)    :: precip_rain, precip_snow 
-    REAL, DIMENSION(klon), INTENT(IN)    :: temp_air, spechum ! near surface T, q
-    REAL, DIMENSION(klon), INTENT(IN)    :: AcoefH, AcoefQ, BcoefH, BcoefQ 
-    REAL, DIMENSION(klon), INTENT(IN)    :: AcoefU, AcoefV, BcoefU, BcoefV 
-    ! exchange coefficients for boundary layer scheme
-    REAL, DIMENSION(klon), INTENT(IN)    :: ps  ! surface pressure
-    REAL, DIMENSION(klon), INTENT(IN)    :: u1, v1, gustiness ! surface wind
-    REAL, DIMENSION(klon), INTENT(IN)    :: tsurf_in ! surface temperature
-    REAL, DIMENSION(klon), INTENT(INOUT) :: radsol ! net surface radiative flux
-
-! In/Output arguments
-!************************************************************************************
-    REAL, DIMENSION(klon), INTENT(INOUT) :: snow ! in kg/m2
-    
-! Output arguments
-!************************************************************************************
-    REAL, DIMENSION(klon), INTENT(OUT)   :: qsurf
-    REAL, DIMENSION(klon), INTENT(OUT)   :: evap, fluxsens, fluxlat
-    REAL, DIMENSION(klon), INTENT(OUT)   :: flux_u1, flux_v1
-    REAL, DIMENSION(klon), INTENT(OUT)   :: tsurf_new ! new surface tempearture
-    REAL, DIMENSION(klon), INTENT(OUT)   :: dflux_s, dflux_l      
-    REAL, DIMENSION(klon), INTENT(OUT)   :: slab_bils
-
-! Local variables
-!************************************************************************************
-    INTEGER               :: i,ki,k
-    REAL                  :: t_cadj
-    !  for surface heat fluxes
-    REAL, DIMENSION(klon) :: cal, beta, dif_grnd
-    ! for Q-Flux computation: d/dt SST, d/dt ice volume (kg/m2), surf fluxes 
-    REAL, DIMENSION(klon) :: diff_sst, diff_siv
-    REAL, DIMENSION(klon,nslay) :: lmt_bils
-    ! for surface wind stress
-    REAL, DIMENSION(klon) :: u0, v0
-    REAL, DIMENSION(klon) :: u1_lay, v1_lay
-    ! for new ice creation
-    REAL                  :: e_freeze, h_new, dfsic
-    ! horizontal diffusion and Ekman local vars
-    ! dimension = global domain (klon_glo) instead of // subdomains 
-    REAL, DIMENSION(klon_glo,nslay) :: dt_hdiff_glo,dt_ekman_glo,dt_gm_glo
-    ! dt_ekman_glo saved for diagnostic, dt_ekman_tmp used for time loop
-    REAL, DIMENSION(klon_glo,nslay) :: dt_hdiff_tmp, dt_ekman_tmp
-    REAL, DIMENSION(klon_glo,nslay) :: tslab_glo
-    REAL, DIMENSION(klon_glo) :: taux_glo,tauy_glo
-
-!****************************************************************************************
-! 1) Surface fluxes calculation
-!    
-!****************************************************************************************
-    !cal(:)      = 0. ! infinite thermal inertia
-    !beta(:)     = 1. ! wet surface
-    !dif_grnd(:) = 0. ! no diffusion into ground
-    ! EV: use calbeta
-    CALL calbeta(dtime, is_oce, knon, snow,qsurf, beta, cal, dif_grnd)
-
-
-    
-! Suppose zero surface speed
-    u0(:)=0.0
-    v0(:)=0.0
-    u1_lay(:) = u1(:) - u0(:)
-    v1_lay(:) = v1(:) - v0(:)
-
-! Compute latent & sensible fluxes
-    CALL calcul_fluxs(knon, is_oce, dtime, &
-         tsurf_in, p1lay, cal, beta, cdragh, cdragq, ps, &
-         precip_rain, precip_snow, snow, qsurf,  &
-         radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, gustiness, &
-         f_qsat_oce,AcoefH, AcoefQ, BcoefH, BcoefQ, &
-         tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l)
-
-! save total cumulated heat fluxes locally
-! radiative + turbulent + melt of falling snow 
-    slab_bils(:)=0.
-    DO i=1,knon
-        ki=knindex(i)
-        slab_bils(ki)=(1.-fsic(ki))*(fluxlat(i)+fluxsens(i)+radsol(i) &
-                      -precip_snow(i)*ice_lat*(1.+snow_wfact*fsic(ki)))
-        bils_cum(ki)=bils_cum(ki)+slab_bils(ki)
-    END DO
-
-!  Compute surface wind stress
-    CALL calcul_flux_wind(knon, dtime, &
-         u0, v0, u1, v1, gustiness, cdragm, &
-         AcoefU, AcoefV, BcoefU, BcoefV, &
-         p1lay, temp_air, &
-         flux_u1, flux_v1)  
-
-! save cumulated wind stress
-    IF (slab_ekman.GT.0) THEN 
-      DO i=1,knon
-          ki=knindex(i)
-          taux_cum(ki)=taux_cum(ki)+flux_u1(i)*(1.-fsic(ki))/cpl_pas
-          tauy_cum(ki)=tauy_cum(ki)+flux_v1(i)*(1.-fsic(ki))/cpl_pas
-      END DO
-    ENDIF
-
-!****************************************************************************************
-! 2) Q-Flux : get global variables lmt_bils, diff_sst and diff_siv from file limit_slab.nc
-!
-!****************************************************************************************
-    CALL limit_slab(itime, dtime, jour, lmt_bils, diff_sst, diff_siv) 
-    ! lmt_bils and diff_sst,siv saved by limit_slab
-    ! qflux = total QFlux correction (in W/m2)
-    dt_qflux(:,1)=lmt_bils(:,1)+diff_sst(:)/cyang/86400.-diff_siv(:)*ice_den*ice_lat/86400.
-    IF (nslay.GT.1) THEN
-       dt_qflux(:,2:nslay)=lmt_bils(:,2:nslay)
-    END IF
-
-!****************************************************************************************
-! 3) Recalculate new temperature (add Surf fluxes, Q-Flux, Ocean transport)
-!    Bring to freezing temp and make sea ice if necessary
-!  
-!***********************************************o*****************************************
-    tsurf_new=tsurf_in
-    IF (MOD(itime,cpl_pas).EQ.0) THEN ! time to update tslab & fraction
-! ***********************************
-!  Horizontal transport 
-! ***********************************
-      IF (slab_ekman.GT.0) THEN 
-          ! copy wind stress to global var
-          CALL gather(taux_cum,taux_glo)
-          CALL gather(tauy_cum,tauy_glo)
-      END IF
-
-      IF (slab_hdiff.OR.(slab_ekman.GT.0)) THEN 
-        CALL gather(tslab,tslab_glo)
-      ! Compute horiz transport on one process only
-        IF (is_mpi_root .AND. is_omp_root) THEN ! Only master processus          
-          IF (slab_hdiff) THEN 
-              dt_hdiff_glo(:,:)=0.
-          END IF
-          IF (slab_ekman.GT.0) THEN 
-              dt_ekman_glo(:,:)=0.
-          END IF
-          IF (slab_gm) THEN 
-              dt_gm_glo(:,:)=0.
-          END IF
-          DO i=1,cpl_pas ! time splitting for numerical stability
-            IF (slab_ekman.GT.0) THEN
-              SELECT CASE (slab_ekman)
-                CASE (1)
-                  CALL slab_ekman1(taux_glo,tauy_glo,tslab_glo,dt_ekman_tmp)
-                CASE (2)
-                  CALL slab_ekman2(taux_glo,tauy_glo,tslab_glo,dt_ekman_tmp,dt_hdiff_tmp,slab_gm)
-                CASE DEFAULT
-                  dt_ekman_tmp(:,:)=0.
-              END SELECT
-              dt_ekman_glo(:,:)=dt_ekman_glo(:,:)+dt_ekman_tmp(:,:)
-              ! convert dt_ekman from K.s-1.(kg.m-2) to K.s-1   
-              DO k=1,nslay
-                dt_ekman_tmp(:,k)=dt_ekman_tmp(:,k)/(slabh(k)*sea_den)
-              ENDDO
-              tslab_glo=tslab_glo+dt_ekman_tmp*dtime
-              IF (slab_gm) THEN ! Gent-McWilliams eddy advection
-                dt_gm_glo(:,:)=dt_gm_glo(:,:)+ dt_hdiff_tmp(:,:)
-                ! convert dt from K.s-1.(kg.m-2) to K.s-1   
-                DO k=1,nslay
-                  dt_hdiff_tmp(:,k)=dt_hdiff_tmp(:,k)/(slabh(k)*sea_den) 
-                END DO
-                tslab_glo=tslab_glo+dt_hdiff_tmp*dtime
-              END IF
-            ENDIF
-! GM included in Ekman_2
-!            IF (slab_gm) THEN ! Gent-McWilliams eddy advection
-!              CALL slab_gmdiff(tslab_glo,dt_hdiff_tmp)
-!              ! convert dt_gm from K.m.s-1 to K.s-1   
-!              DO k=1,nslay
-!                dt_hdiff_tmp(:,k)=dt_hdiff_tmp(:,k)/slabh(k) 
-!              END DO
-!              tslab_glo=tslab_glo+dt_hdiff_tmp*dtime
-!              dt_gm_glo(:,:)=dt_gm_glo(:,:)+ dt_hdiff_tmp(:,:)
-!            END IF
-            IF (slab_hdiff) THEN ! horizontal diffusion
-              ! laplacian of slab T
-              CALL divgrad_phy(nslay,tslab_glo,dt_hdiff_tmp)
-              ! multiply by diff coef and normalize to 50m slab equivalent
-              dt_hdiff_tmp=dt_hdiff_tmp*coef_hdiff*50./SUM(slabh)
-              dt_hdiff_glo(:,:)=dt_hdiff_glo(:,:)+ dt_hdiff_tmp(:,:)
-              tslab_glo=tslab_glo+dt_hdiff_tmp*dtime
-            END IF
-          END DO ! time splitting
-          IF (slab_hdiff) THEN
-            !dt_hdiff_glo saved in W/m2
-            DO k=1,nslay
-              dt_hdiff_glo(:,k)=dt_hdiff_glo(:,k)*slabh(k)*sea_den*sea_cap/cpl_pas
-            END DO
-          END IF
-          IF (slab_gm) THEN
-            !dt_hdiff_glo saved in W/m2
-            dt_gm_glo(:,:)=dt_gm_glo(:,:)*sea_cap/cpl_pas
-          END IF
-          IF (slab_ekman.GT.0) THEN 
-            ! dt_ekman_glo saved in W/m2
-            dt_ekman_glo(:,:)=dt_ekman_glo(:,:)*sea_cap/cpl_pas
-          END IF
-        END IF ! master process
-!$OMP BARRIER
-        ! Send new fields back to all processes
-        CALL Scatter(tslab_glo,tslab)
-        IF (slab_hdiff) THEN
-          CALL Scatter(dt_hdiff_glo,dt_hdiff)
-        END IF
-        IF (slab_gm) THEN
-          CALL Scatter(dt_gm_glo,dt_gm)
-        END IF
-        IF (slab_ekman.GT.0) THEN 
-          CALL Scatter(dt_ekman_glo,dt_ekman)
-          ! clear wind stress
-          taux_cum(:)=0.
-          tauy_cum(:)=0.
-        END IF
-      ENDIF ! transport
-
-! ***********************************
-! Other heat fluxes
-! ***********************************
-      ! Add read QFlux
-      DO k=1,nslay
-        tslab(:,k)=tslab(:,k)+dt_qflux(:,k)*cyang*dtime*cpl_pas &
-                   *slabh(1)/slabh(k) 
-      END DO
-      ! Add cumulated surface fluxes
-      tslab(:,1)=tslab(:,1)+bils_cum(:)*cyang*dtime
-      ! Convective adjustment if 2 layers 
-      IF ((nslay.GT.1).AND.(slab_cadj.GT.0)) THEN
-        DO i=1,klon
-          IF (tslab(i,2).GT.tslab(i,1)) THEN
-            ! mean (mass-weighted) temperature
-            t_cadj=SUM(tslab(i,:)*slabh(:))/SUM(slabh(:))
-            tslab(i,1)=t_cadj
-            tslab(i,2)=t_cadj
-          END IF
-        END DO
-      END IF
-! ***********************************
-! Update surface temperature and ice 
-! ***********************************
-      SELECT CASE(version_ocean)
-      CASE('sicNO') ! no sea ice even below freezing !
-          DO i=1,knon
-              ki=knindex(i)
-              tsurf_new(i)=tslab(ki,1)
-          END DO
-      CASE('sicOBS') ! "realistic" case, for prescribed sea ice
-        ! tslab cannot be below freezing, or above it if there is sea ice
-          DO i=1,knon
-              ki=knindex(i)
-              IF ((tslab(ki,1).LT.t_freeze).OR.(fsic(ki).GT.epsfra)) THEN
-                  tslab(ki,1)=t_freeze
-              END IF
-              tsurf_new(i)=tslab(ki,1)
-          END DO
-      CASE('sicINT') ! interactive sea ice
-          DO i=1,knon
-              ki=knindex(i)
-              IF (fsic(ki).LT.epsfra) THEN ! Free of ice
-                  IF (tslab(ki,1).LT.t_freeze) THEN ! create new ice
-                      ! quantity of new ice formed
-                      e_freeze=(t_freeze-tslab(ki,1))/cyang/ice_lat
-                      ! new ice
-                      tice(ki)=t_freeze
-                      fsic(ki)=MIN(ice_frac_max,e_freeze/h_ice_thin)
-                      IF (fsic(ki).GT.ice_frac_min) THEN
-                          seaice(ki)=MIN(e_freeze/fsic(ki),h_ice_max)
-                          tslab(ki,1)=t_freeze
-                      ELSE
-                          fsic(ki)=0.
-                      END IF
-                      tsurf_new(i)=t_freeze
-                  ELSE
-                      tsurf_new(i)=tslab(ki,1)
-                  END IF 
-              ELSE ! ice present
-                  tsurf_new(i)=t_freeze
-                  IF (tslab(ki,1).LT.t_freeze) THEN ! create new ice
-                      ! quantity of new ice formed over open ocean
-                      e_freeze=(t_freeze-tslab(ki,1))/cyang*(1.-fsic(ki)) &
-                               /(ice_lat+ice_cap/2.*(t_freeze-tice(ki)))
-                      ! new ice height and fraction
-                      h_new=MIN(h_ice_new,seaice(ki)) ! max new height ice_new
-                      dfsic=MIN(ice_frac_max-fsic(ki),e_freeze/h_new)
-                      h_new=MIN(e_freeze/dfsic,h_ice_max)
-                      ! update tslab to freezing over open ocean only
-                      tslab(ki,1)=tslab(ki,1)*fsic(ki)+t_freeze*(1.-fsic(ki))
-                      ! update sea ice
-                      seaice(ki)=(h_new*dfsic+seaice(ki)*fsic(ki)) &
-                                 /(dfsic+fsic(ki))
-                      fsic(ki)=fsic(ki)+dfsic
-                      ! update snow?
-                  END IF ! tslab below freezing
-              END IF ! sea ice present
-          END DO
-      END SELECT
-      bils_cum(:)=0.0! clear cumulated fluxes
-    END IF ! coupling time
-  END SUBROUTINE ocean_slab_noice
-!
-!****************************************************************************************
-
-  SUBROUTINE ocean_slab_ice(   &
-       itime, dtime, jour, knon, knindex, &
-       tsurf_in, p1lay, cdragh, cdragm, precip_rain, precip_snow, temp_air, spechum, &
-       AcoefH, AcoefQ, BcoefH, BcoefQ, &
-       AcoefU, AcoefV, BcoefU, BcoefV, &
-       ps, u1, v1, gustiness, &
-       radsol, snow, qsurf, qsol, agesno, &
-       alb1_new, alb2_new, evap, fluxsens, fluxlat, flux_u1, flux_v1, &
-       tsurf_new, dflux_s, dflux_l, swnet)
-
-   USE calcul_fluxs_mod
-
-   INCLUDE "YOMCST.h"
-   INCLUDE "clesphys.h"
-
-! Input arguments
-!****************************************************************************************
-    INTEGER, INTENT(IN)                  :: itime, jour, knon
-    INTEGER, DIMENSION(klon), INTENT(IN) :: knindex
-    REAL, INTENT(IN)                     :: dtime
-    REAL, DIMENSION(klon), INTENT(IN)    :: tsurf_in
-    REAL, DIMENSION(klon), INTENT(IN)    :: p1lay
-    REAL, DIMENSION(klon), INTENT(IN)    :: cdragh, cdragm
-    REAL, DIMENSION(klon), INTENT(IN)    :: precip_rain, precip_snow
-    REAL, DIMENSION(klon), INTENT(IN)    :: temp_air, spechum
-    REAL, DIMENSION(klon), INTENT(IN)    :: AcoefH, AcoefQ, BcoefH, BcoefQ
-    REAL, DIMENSION(klon), INTENT(IN)    :: AcoefU, AcoefV, BcoefU, BcoefV
-    REAL, DIMENSION(klon), INTENT(IN)    :: ps
-    REAL, DIMENSION(klon), INTENT(IN)    :: u1, v1, gustiness
-    REAL, DIMENSION(klon), INTENT(IN)    :: swnet
-
-! In/Output arguments
-!****************************************************************************************
-    REAL, DIMENSION(klon), INTENT(INOUT)          :: snow, qsol
-    REAL, DIMENSION(klon), INTENT(INOUT)          :: agesno
-    REAL, DIMENSION(klon), INTENT(INOUT)          :: radsol
-
-! Output arguments
-!****************************************************************************************
-    REAL, DIMENSION(klon), INTENT(OUT)            :: qsurf
-    REAL, DIMENSION(klon), INTENT(OUT)            :: alb1_new  ! new albedo in visible SW interval
-    REAL, DIMENSION(klon), INTENT(OUT)            :: alb2_new  ! new albedo in near IR interval
-    REAL, DIMENSION(klon), INTENT(OUT)            :: evap, fluxsens, fluxlat
-    REAL, DIMENSION(klon), INTENT(OUT)            :: flux_u1, flux_v1
-    REAL, DIMENSION(klon), INTENT(OUT)            :: tsurf_new
-    REAL, DIMENSION(klon), INTENT(OUT)            :: dflux_s, dflux_l
-
-! Local variables
-!****************************************************************************************
-    INTEGER               :: i,ki
-    REAL, DIMENSION(klon) :: cal, beta, dif_grnd
-    REAL, DIMENSION(klon) :: u0, v0
-    REAL, DIMENSION(klon) :: u1_lay, v1_lay
-    ! intermediate heat fluxes:
-    REAL                  :: f_cond, f_swpen
-    ! for snow/ice albedo:
-    REAL                  :: alb_snow, alb_ice, alb_pond
-    REAL                  :: frac_snow, frac_ice, frac_pond
-    ! for ice melt / freeze
-    REAL                  :: e_melt, snow_evap, h_test
-    ! dhsic, dfsic change in ice mass, fraction.
-    REAL                  :: dhsic, dfsic, frac_mf
-
-!****************************************************************************************
-! 1) Flux calculation
-!****************************************************************************************
-! Suppose zero surface speed
-    u0(:)=0.0
-    v0(:)=0.0
-    u1_lay(:) = u1(:) - u0(:)
-    v1_lay(:) = v1(:) - v0(:)
-
-! set beta, cal, compute conduction fluxes inside ice/snow 
-    slab_bilg(:)=0.
-    !dif_grnd(:)=0.
-    !beta(:) = 1.
-    ! EV: use calbeta to calculate beta and then recalculate properly cal
-    CALL calbeta(dtime, is_sic, knon, snow, qsol, beta, cal, dif_grnd)
-
-
-    DO i=1,knon
-    ki=knindex(i)
-        IF (snow(i).GT.snow_min) THEN
-            ! snow-layer heat capacity
-            cal(i)=2.*RCPD/(snow(i)*ice_cap)
-            ! snow conductive flux
-            f_cond=sno_cond*(tice(ki)-tsurf_in(i))/snow(i)
-            ! all shortwave flux absorbed
-            f_swpen=0.
-            ! bottom flux (ice conduction)
-            slab_bilg(ki)=ice_cond*(tice(ki)-t_freeze)/seaice(ki)
-            ! update ice temperature
-            tice(ki)=tice(ki)-2./ice_cap/(snow(i)+seaice(ki)) &
-                     *(slab_bilg(ki)+f_cond)*dtime
-       ELSE ! bare ice
-            ! ice-layer heat capacity
-            cal(i)=2.*RCPD/(seaice(ki)*ice_cap)
-            ! conductive flux
-            f_cond=ice_cond*(t_freeze-tice(ki))/seaice(ki)
-            ! penetrative shortwave flux...
-            f_swpen=swnet(i)*pen_frac*exp(-pen_ext*seaice(ki)/ice_den)
-            slab_bilg(ki)=f_swpen-f_cond
-        END IF
-        radsol(i)=radsol(i)+f_cond-f_swpen
-    END DO
-    ! weight fluxes to ocean by sea ice fraction
-    slab_bilg(:)=slab_bilg(:)*fsic(:)
-
-! calcul_fluxs (sens, lat etc)
-    CALL calcul_fluxs(knon, is_sic, dtime, &
-        tsurf_in, p1lay, cal, beta, cdragh, cdragh, ps, &
-        precip_rain, precip_snow, snow, qsurf,  &
-        radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, gustiness, &
-        f_qsat_oce,AcoefH, AcoefQ, BcoefH, BcoefQ, &
-        tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l)
-    DO i=1,knon 
-        IF (snow(i).LT.snow_min) tice(knindex(i))=tsurf_new(i)
-    END DO
-
-! calcul_flux_wind
-    CALL calcul_flux_wind(knon, dtime, &
-         u0, v0, u1, v1, gustiness, cdragm, &
-         AcoefU, AcoefV, BcoefU, BcoefV, &
-         p1lay, temp_air, &
-         flux_u1, flux_v1)
-
-!****************************************************************************************
-! 2) Update snow and ice surface
-!****************************************************************************************
-! snow precip
-    DO i=1,knon
-        ki=knindex(i)
-        IF (precip_snow(i) > 0.) THEN
-            snow(i) = snow(i)+precip_snow(i)*dtime*(1.-snow_wfact*(1.-fsic(ki)))
-        END IF
-! snow and ice sublimation
-        IF (evap(i) > 0.) THEN 
-           snow_evap = MIN (snow(i) / dtime, evap(i))
-           snow(i) = snow(i) - snow_evap * dtime
-           snow(i) = MAX(0.0, snow(i))
-           seaice(ki) = MAX(0.0,seaice(ki)-(evap(i)-snow_evap)*dtime)
-        ENDIF
-! Melt / Freeze snow from above if Tsurf>0
-        IF (tsurf_new(i).GT.t_melt) THEN
-            ! energy available for melting snow (in kg of melted snow /m2)
-            e_melt = MIN(MAX(snow(i)*(tsurf_new(i)-t_melt)*ice_cap/2. &
-               /(ice_lat+ice_cap/2.*(t_melt-tice(ki))),0.0),snow(i))
-            ! remove snow
-            IF (snow(i).GT.e_melt) THEN
-                snow(i)=snow(i)-e_melt
-                tsurf_new(i)=t_melt
-            ELSE ! all snow is melted
-                ! add remaining heat flux to ice
-                e_melt=e_melt-snow(i)
-                tice(ki)=tice(ki)+e_melt*ice_lat*2./(ice_cap*seaice(ki))
-                tsurf_new(i)=tice(ki)
-            END IF
-        END IF
-! melt ice from above if Tice>0
-        IF (tice(ki).GT.t_melt) THEN
-            ! quantity of ice melted (kg/m2)
-            e_melt=MAX(seaice(ki)*(tice(ki)-t_melt)*ice_cap/2. & 
-             /(ice_lat+ice_cap/2.*(t_melt-t_freeze)),0.0)
-            ! melt from above, height only
-            dhsic=MIN(seaice(ki)-h_ice_min,e_melt)
-            e_melt=e_melt-dhsic
-            IF (e_melt.GT.0) THEN
-            ! lateral melt if ice too thin
-            dfsic=MAX(fsic(ki)-ice_frac_min,e_melt/h_ice_min*fsic(ki))
-            ! if all melted add remaining heat to ocean
-            e_melt=MAX(0.,e_melt*fsic(ki)-dfsic*h_ice_min)
-            slab_bilg(ki)=slab_bilg(ki)+ e_melt*ice_lat/dtime
-            ! update height and fraction
-            fsic(ki)=fsic(ki)-dfsic
-            END IF
-            seaice(ki)=seaice(ki)-dhsic
-            ! surface temperature at melting point
-            tice(ki)=t_melt
-            tsurf_new(i)=t_melt
-        END IF
-        ! convert snow to ice if below floating line
-        h_test=(seaice(ki)+snow(i))*ice_den-seaice(ki)*sea_den
-        IF (h_test.GT.0.) THEN !snow under water
-            ! extra snow converted to ice (with added frozen sea water)
-            dhsic=h_test/(sea_den-ice_den+sno_den)
-            seaice(ki)=seaice(ki)+dhsic
-            snow(i)=snow(i)-dhsic*sno_den/ice_den
-            ! available energy (freeze sea water + bring to tice)
-            e_melt=dhsic*(1.-sno_den/ice_den)*(ice_lat+ &
-                   ice_cap/2.*(t_freeze-tice(ki)))
-            ! update ice temperature
-            tice(ki)=tice(ki)+2.*e_melt/ice_cap/(snow(i)+seaice(ki))
-        END IF
-    END DO
-
-! New albedo
-    DO i=1,knon
-        ki=knindex(i)
-       ! snow albedo: update snow age
-        IF (snow(i).GT.0.0001) THEN
-             agesno(i)=(agesno(i) + (1.-agesno(i)/50.)*dtime/86400.)&
-                         * EXP(-1.*MAX(0.0,precip_snow(i))*dtime/5.)
-        ELSE
-            agesno(i)=0.0
-        END IF
-        ! snow albedo
-        alb_snow=alb_sno_min+alb_sno_del*EXP(-agesno(i)/50.)
-        ! ice albedo (varies with ice tkickness and temp)
-        alb_ice=MAX(0.0,0.13*LOG(100.*seaice(ki)/ice_den)+0.1)
-        IF (tice(ki).GT.t_freeze-0.01) THEN
-            alb_ice=MIN(alb_ice,alb_ice_wet)
-        ELSE
-            alb_ice=MIN(alb_ice,alb_ice_dry)
-        END IF
-        ! pond albedo
-        alb_pond=0.36-0.1*(2.0+MIN(0.0,MAX(tice(ki)-t_melt,-2.0)))
-        ! pond fraction
-        frac_pond=0.2*(2.0+MIN(0.0,MAX(tice(ki)-t_melt,-2.0)))
-        ! snow fraction
-        frac_snow=MAX(0.0,MIN(1.0-frac_pond,snow(i)/snow_min))
-        ! ice fraction
-        frac_ice=MAX(0.0,1.-frac_pond-frac_snow)
-        ! total albedo
-        alb1_new(i)=alb_snow*frac_snow+alb_ice*frac_ice+alb_pond*frac_pond
-    END DO
-    alb2_new(:) = alb1_new(:)
-
-!****************************************************************************************
-! 3) Recalculate new ocean temperature (add fluxes below ice)
-!    Melt / freeze from below
-!***********************************************o*****************************************
-    !cumul fluxes
-    bilg_cum(:)=bilg_cum(:)+slab_bilg(:)
-    IF (MOD(itime,cpl_pas).EQ.0) THEN ! time to update tslab & fraction
-        ! Add cumulated surface fluxes
-        tslab(:,1)=tslab(:,1)+bilg_cum(:)*cyang*dtime
-        DO i=1,knon
-            ki=knindex(i)
-            ! split lateral/top melt-freeze
-            frac_mf=MIN(1.,MAX(0.,(seaice(ki)-h_ice_thin)/(h_ice_thick-h_ice_thin)))
-            IF (tslab(ki,1).LE.t_freeze) THEN 
-               ! ****** Form new ice from below *******
-               ! quantity of new ice
-                e_melt=(t_freeze-tslab(ki,1))/cyang & 
-                       /(ice_lat+ice_cap/2.*(t_freeze-tice(ki)))
-               ! first increase height to h_thin
-               dhsic=MAX(0.,MIN(h_ice_thin-seaice(ki),e_melt/fsic(ki)))
-               seaice(ki)=dhsic+seaice(ki)
-               e_melt=e_melt-fsic(ki)*dhsic
-               IF (e_melt.GT.0.) THEN
-               ! frac_mf fraction used for lateral increase
-               dfsic=MIN(ice_frac_max-fsic(ki),e_melt*frac_mf/seaice(ki))
-               fsic(ki)=fsic(ki)+dfsic
-               e_melt=e_melt-dfsic*seaice(ki)
-               ! rest used to increase height
-               seaice(ki)=MIN(h_ice_max,seaice(ki)+e_melt/fsic(ki))
-               END IF
-               tslab(ki,1)=t_freeze
-           ELSE ! slab temperature above freezing
-               ! ****** melt ice from below *******
-               ! quantity of melted ice
-               e_melt=(tslab(ki,1)-t_freeze)/cyang & 
-                       /(ice_lat+ice_cap/2.*(tice(ki)-t_freeze))
-               ! first decrease height to h_thick
-               dhsic=MAX(0.,MIN(seaice(ki)-h_ice_thick,e_melt/fsic(ki)))
-               seaice(ki)=seaice(ki)-dhsic
-               e_melt=e_melt-fsic(ki)*dhsic
-               IF (e_melt.GT.0) THEN
-               ! frac_mf fraction used for height decrease
-               dhsic=MAX(0.,MIN(seaice(ki)-h_ice_min,e_melt*frac_mf/fsic(ki)))
-               seaice(ki)=seaice(ki)-dhsic
-               e_melt=e_melt-fsic(ki)*dhsic
-               ! rest used to decrease fraction (up to 0!)
-               dfsic=MIN(fsic(ki),e_melt/seaice(ki))
-               ! keep remaining in ocean
-               e_melt=e_melt-dfsic*seaice(ki)
-               END IF
-               tslab(ki,1)=t_freeze+e_melt*ice_lat*cyang
-               fsic(ki)=fsic(ki)-dfsic
-           END IF
-        END DO
-        bilg_cum(:)=0.
-    END IF ! coupling time
-    
-    !tests ice fraction 
-    WHERE (fsic.LT.ice_frac_min)
-        tslab(:,1)=tslab(:,1)-fsic*seaice*ice_lat*cyang
-        tice=t_melt
-        fsic=0.
-        seaice=0.
-    END WHERE
-
-  END SUBROUTINE ocean_slab_ice
-!
-!****************************************************************************************
-!
-  SUBROUTINE ocean_slab_final
-
-!****************************************************************************************
-! Deallocate module variables
-!****************************************************************************************
-    IF (ALLOCATED(tslab)) DEALLOCATE(tslab)
-    IF (ALLOCATED(fsic)) DEALLOCATE(fsic)
-    IF (ALLOCATED(tice)) DEALLOCATE(tice)
-    IF (ALLOCATED(seaice)) DEALLOCATE(seaice)
-    IF (ALLOCATED(slab_bilg)) DEALLOCATE(slab_bilg)
-    IF (ALLOCATED(bilg_cum)) DEALLOCATE(bilg_cum)
-    IF (ALLOCATED(bils_cum)) DEALLOCATE(bils_cum)
-    IF (ALLOCATED(taux_cum)) DEALLOCATE(taux_cum)
-    IF (ALLOCATED(tauy_cum)) DEALLOCATE(tauy_cum)
-    IF (ALLOCATED(dt_ekman)) DEALLOCATE(dt_ekman)
-    IF (ALLOCATED(dt_hdiff)) DEALLOCATE(dt_hdiff)
-    IF (ALLOCATED(dt_gm)) DEALLOCATE(dt_gm)
-    IF (ALLOCATED(dt_qflux)) DEALLOCATE(dt_qflux)
-
-  END SUBROUTINE ocean_slab_final
-
-END MODULE ocean_slab_mod
Index: /LMDZ6/trunk/libf/phylmd/ocean_slab_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/ocean_slab_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/ocean_slab_mod.f90	(revision 5268)
@@ -0,0 +1,991 @@
+!Completed
+MODULE ocean_slab_mod
+!
+! This module is used for both surface ocean and sea-ice when using the slab ocean,
+! "ocean=slab".
+!
+
+  USE dimphy
+  USE indice_sol_mod
+  USE surface_data
+  USE mod_grid_phy_lmdz, ONLY: klon_glo
+  USE mod_phys_lmdz_mpi_data, ONLY: is_mpi_root
+
+  IMPLICIT NONE
+  PRIVATE
+  PUBLIC :: ocean_slab_init, ocean_slab_frac, ocean_slab_noice, ocean_slab_ice
+
+!***********************************************************************************
+! Global saved variables
+!***********************************************************************************
+  ! number of slab vertical layers
+  INTEGER, PUBLIC, SAVE :: nslay
+  !$OMP THREADPRIVATE(nslay)
+  ! timestep for coupling (update slab temperature) in timesteps
+  INTEGER, PRIVATE, SAVE                           :: cpl_pas
+  !$OMP THREADPRIVATE(cpl_pas)
+  ! cyang = 1/heat capacity of top layer (rho.c.H)
+  REAL, PRIVATE, SAVE                              :: cyang
+  !$OMP THREADPRIVATE(cyang)
+  ! depth of slab layers (1 or 2)
+  REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE   :: slabh
+  !$OMP THREADPRIVATE(slabh)
+  ! slab temperature
+  REAL, ALLOCATABLE, DIMENSION(:,:), PUBLIC, SAVE   :: tslab
+  !$OMP THREADPRIVATE(tslab)
+  ! heat flux convergence due to Ekman
+  REAL, ALLOCATABLE, DIMENSION(:,:), PUBLIC, SAVE   :: dt_ekman
+  !$OMP THREADPRIVATE(dt_ekman)
+  ! heat flux convergence due to horiz diffusion
+  REAL, ALLOCATABLE, DIMENSION(:,:), PUBLIC, SAVE   :: dt_hdiff
+  !$OMP THREADPRIVATE(dt_hdiff)
+  ! heat flux convergence due to GM eddy advection
+  REAL, ALLOCATABLE, DIMENSION(:,:), PUBLIC, SAVE   :: dt_gm
+  !$OMP THREADPRIVATE(dt_gm)
+  ! Heat Flux correction 
+  REAL, ALLOCATABLE, DIMENSION(:,:), PUBLIC, SAVE   :: dt_qflux
+  !$OMP THREADPRIVATE(dt_qflux)
+  ! fraction of ocean covered by sea ice (sic / (oce+sic))
+  REAL, ALLOCATABLE, DIMENSION(:), PUBLIC, SAVE  :: fsic
+  !$OMP THREADPRIVATE(fsic)
+  ! temperature of the sea ice
+  REAL, ALLOCATABLE, DIMENSION(:), PUBLIC, SAVE  :: tice
+  !$OMP THREADPRIVATE(tice)
+  ! sea ice thickness, in kg/m2
+  REAL, ALLOCATABLE, DIMENSION(:), PUBLIC, SAVE  :: seaice
+  !$OMP THREADPRIVATE(seaice)
+  ! net surface heat flux, weighted by open ocean fraction
+  ! slab_bils accumulated over cpl_pas timesteps
+  REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE  :: bils_cum
+  !$OMP THREADPRIVATE(bils_cum)
+  ! net heat flux into the ocean below the ice : conduction + solar radiation
+  REAL, ALLOCATABLE, DIMENSION(:), PUBLIC, SAVE  :: slab_bilg
+  !$OMP THREADPRIVATE(slab_bilg)
+  ! slab_bilg over cpl_pas timesteps
+  REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE  :: bilg_cum
+  !$OMP THREADPRIVATE(bilg_cum)
+  ! wind stress saved over cpl_pas timesteps
+  REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE  :: taux_cum
+  !$OMP THREADPRIVATE(taux_cum)
+  REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE  :: tauy_cum
+  !$OMP THREADPRIVATE(tauy_cum)
+
+!***********************************************************************************
+! Parameters (could be read in def file: move to slab_init)
+!***********************************************************************************
+! snow and ice physical characteristics:
+    REAL, PARAMETER :: t_freeze=271.35 ! freezing sea water temp
+    REAL, PARAMETER :: t_melt=273.15   ! melting ice temp
+    REAL, PARAMETER :: sno_den=300. !mean snow density, kg/m3
+    REAL, PARAMETER :: ice_den=917. ! ice density
+    REAL, PARAMETER :: sea_den=1025. ! sea water density
+    REAL, PARAMETER :: ice_cond=2.17*ice_den !conductivity of ice
+    REAL, PARAMETER :: sno_cond=0.31*sno_den ! conductivity of snow
+    REAL, PARAMETER :: ice_cap=2067.   ! specific heat capacity, snow and ice
+    REAL, PARAMETER :: sea_cap=3995.   ! specific heat capacity, snow and ice
+    REAL, PARAMETER :: ice_lat=334000. ! freeze /melt latent heat snow and ice
+
+! control of snow and ice cover & freeze / melt (heights converted to kg/m2)
+    REAL, PARAMETER :: snow_min=0.05*sno_den !critical snow height 5 cm
+    REAL, PARAMETER :: snow_wfact=0.4 ! max fraction of falling snow blown into ocean
+    REAL, PARAMETER :: ice_frac_min=0.001
+    REAL, PARAMETER :: ice_frac_max=1. ! less than 1. if min leads fraction 
+    REAL, PARAMETER :: h_ice_min=0.01*ice_den ! min ice thickness 
+    REAL, PARAMETER :: h_ice_thin=0.15*ice_den ! thin ice thickness 
+    ! below ice_thin, priority is melt lateral / grow height
+    ! ice_thin is also height of new ice
+    REAL, PARAMETER :: h_ice_thick=2.5*ice_den ! thin ice thickness 
+    ! above ice_thick, priority is melt height / grow lateral
+    REAL, PARAMETER :: h_ice_new=1.*ice_den ! max height of new open ocean ice 
+    REAL, PARAMETER :: h_ice_max=10.*ice_den ! max ice height 
+
+! albedo  and radiation parameters
+    REAL, PARAMETER :: alb_sno_min=0.55 !min snow albedo
+    REAL, PARAMETER :: alb_sno_del=0.3  !max snow albedo = min + del
+    REAL, PARAMETER :: alb_ice_dry=0.75 !dry thick ice
+    REAL, PARAMETER :: alb_ice_wet=0.66 !melting thick ice
+    REAL, PARAMETER :: pen_frac=0.3 !fraction of shortwave penetrating into the
+    ! ice (no snow)
+    REAL, PARAMETER :: pen_ext=1.5 !extinction of penetrating shortwave (m-1)
+
+! horizontal transport
+   LOGICAL, PUBLIC, SAVE :: slab_hdiff
+   !$OMP THREADPRIVATE(slab_hdiff)
+   LOGICAL, PUBLIC, SAVE :: slab_gm
+   !$OMP THREADPRIVATE(slab_gm)
+   REAL, PRIVATE, SAVE    :: coef_hdiff ! coefficient for horizontal diffusion
+   !$OMP THREADPRIVATE(coef_hdiff)
+   INTEGER, PUBLIC, SAVE :: slab_ekman, slab_cadj ! Ekman, conv adjustment
+   !$OMP THREADPRIVATE(slab_ekman)
+   !$OMP THREADPRIVATE(slab_cadj)
+
+!***********************************************************************************
+
+CONTAINS
+!
+!***********************************************************************************
+!
+  SUBROUTINE ocean_slab_init(dtime, pctsrf_rst)
+  !, seaice_rst etc
+
+    USE ioipsl_getin_p_mod, ONLY : getin_p
+    USE mod_phys_lmdz_transfert_para, ONLY : gather
+    USE slab_heat_transp_mod, ONLY : ini_slab_transp
+
+    ! Input variables
+!***********************************************************************************
+    REAL, INTENT(IN)                         :: dtime
+! Variables read from restart file
+    REAL, DIMENSION(klon, nbsrf), INTENT(IN) :: pctsrf_rst 
+    ! surface fractions from start file
+
+! Local variables
+!************************************************************************************
+    INTEGER                :: error
+    REAL, DIMENSION(klon_glo) :: zmasq_glo
+    CHARACTER (len = 80)   :: abort_message
+    CHARACTER (len = 20)   :: modname = 'ocean_slab_intit'
+
+!***********************************************************************************
+! Define some parameters
+!***********************************************************************************
+! Number of slab layers
+    nslay=2
+    CALL getin_p('slab_layers',nslay)
+    print *,'number of slab layers : ',nslay
+! Layer thickness
+    ALLOCATE(slabh(nslay), stat = error)
+    IF (error /= 0) THEN
+       abort_message='Pb allocation slabh'
+       CALL abort_physic(modname,abort_message,1)
+    ENDIF
+    slabh(1)=50.
+    CALL getin_p('slab_depth',slabh(1))
+    IF (nslay.GT.1) THEN 
+        slabh(2)=150.
+    END IF
+
+! cyang = 1/heat capacity of top layer (rho.c.H)
+    cyang=1/(slabh(1)*sea_den*sea_cap)
+
+! cpl_pas  coupling period (update of tslab and ice fraction)
+! pour un calcul a chaque pas de temps, cpl_pas=1
+    cpl_pas = NINT(86400./dtime * 1.0) ! une fois par jour
+    CALL getin_p('cpl_pas',cpl_pas)
+    print *,'cpl_pas',cpl_pas
+
+! Horizontal diffusion
+    slab_hdiff=.FALSE.
+    CALL getin_p('slab_hdiff',slab_hdiff)
+    coef_hdiff=25000.
+    CALL getin_p('coef_hdiff',coef_hdiff)
+! Ekman transport
+    slab_ekman=0
+    CALL getin_p('slab_ekman',slab_ekman)
+! GM eddy advection (2-layers only)
+    slab_gm=.FALSE.
+    CALL getin_p('slab_gm',slab_gm)
+    IF (slab_ekman.LT.2) THEN
+       slab_gm=.FALSE.
+    ENDIF 
+! Convective adjustment
+    IF (nslay.EQ.1) THEN
+        slab_cadj=0
+    ELSE
+        slab_cadj=1
+    END IF
+    CALL getin_p('slab_cadj',slab_cadj)
+
+!************************************************************************************
+! Allocate surface fraction read from restart file
+!************************************************************************************
+    ALLOCATE(fsic(klon), stat = error)
+    IF (error /= 0) THEN
+       abort_message='Pb allocation tmp_pctsrf_slab'
+       CALL abort_physic(modname,abort_message,1)
+    ENDIF
+    fsic(:)=0.
+    !zmasq = continent fraction
+    WHERE (1.-zmasq(:)>EPSFRA)
+        fsic(:) = pctsrf_rst(:,is_sic)/(1.-zmasq(:))
+    END WHERE
+
+!************************************************************************************
+! Allocate saved fields
+!************************************************************************************
+    ALLOCATE(tslab(klon,nslay), stat=error)
+       IF (error /= 0) CALL abort_physic &
+         (modname,'pb allocation tslab', 1)
+
+    ALLOCATE(bils_cum(klon), stat = error)
+    IF (error /= 0) THEN
+       abort_message='Pb allocation slab_bils_cum'
+       CALL abort_physic(modname,abort_message,1)
+    ENDIF
+    bils_cum(:) = 0.0   
+
+    IF (version_ocean=='sicINT') THEN ! interactive sea ice
+        ALLOCATE(slab_bilg(klon), stat = error)
+        IF (error /= 0) THEN
+           abort_message='Pb allocation slab_bilg'
+           CALL abort_physic(modname,abort_message,1)
+        ENDIF
+        slab_bilg(:) = 0.0   
+        ALLOCATE(bilg_cum(klon), stat = error)
+        IF (error /= 0) THEN
+           abort_message='Pb allocation slab_bilg_cum'
+           CALL abort_physic(modname,abort_message,1)
+        ENDIF
+        bilg_cum(:) = 0.0   
+        ALLOCATE(tice(klon), stat = error)
+        IF (error /= 0) THEN
+           abort_message='Pb allocation slab_tice'
+           CALL abort_physic(modname,abort_message,1)
+        ENDIF
+        ALLOCATE(seaice(klon), stat = error)
+        IF (error /= 0) THEN
+           abort_message='Pb allocation slab_seaice'
+           CALL abort_physic(modname,abort_message,1)
+        ENDIF
+    END IF
+
+    IF (slab_hdiff) THEN !horizontal diffusion
+        ALLOCATE(dt_hdiff(klon,nslay), stat = error)
+        IF (error /= 0) THEN
+           abort_message='Pb allocation dt_hdiff'
+           CALL abort_physic(modname,abort_message,1)
+        ENDIF
+        dt_hdiff(:,:) = 0.0   
+    ENDIF
+
+    ALLOCATE(dt_qflux(klon,nslay), stat = error)
+    IF (error /= 0) THEN
+       abort_message='Pb allocation dt_qflux'
+       CALL abort_physic(modname,abort_message,1)
+    ENDIF
+    dt_qflux(:,:) = 0.0   
+
+    IF (slab_gm) THEN !GM advection
+        ALLOCATE(dt_gm(klon,nslay), stat = error)
+        IF (error /= 0) THEN
+           abort_message='Pb allocation dt_gm'
+           CALL abort_physic(modname,abort_message,1)
+        ENDIF
+        dt_gm(:,:) = 0.0   
+    ENDIF
+
+    IF (slab_ekman.GT.0) THEN ! ekman transport
+        ALLOCATE(dt_ekman(klon,nslay), stat = error)
+        IF (error /= 0) THEN
+           abort_message='Pb allocation dt_ekman'
+           CALL abort_physic(modname,abort_message,1)
+        ENDIF
+        dt_ekman(:,:) = 0.0   
+        ALLOCATE(taux_cum(klon), stat = error)
+        IF (error /= 0) THEN
+           abort_message='Pb allocation taux_cum'
+           CALL abort_physic(modname,abort_message,1)
+        ENDIF
+        taux_cum(:) = 0.0   
+        ALLOCATE(tauy_cum(klon), stat = error)
+        IF (error /= 0) THEN
+           abort_message='Pb allocation tauy_cum'
+           CALL abort_physic(modname,abort_message,1)
+        ENDIF
+        tauy_cum(:) = 0.0   
+    ENDIF
+
+! Initialize transport
+    IF (slab_hdiff.OR.(slab_ekman.GT.0)) THEN
+      CALL gather(zmasq,zmasq_glo)
+! Master thread/process only
+!$OMP MASTER  
+      IF (is_mpi_root) THEN 
+          CALL ini_slab_transp(zmasq_glo)
+      END IF
+!$OMP END MASTER
+    END IF
+
+ END SUBROUTINE ocean_slab_init
+!
+!***********************************************************************************
+!
+  SUBROUTINE ocean_slab_frac(itime, dtime, jour, pctsrf_chg, is_modified)
+
+! this routine sends back the sea ice and ocean fraction to the main physics
+! routine. Called only with interactive sea ice
+
+! Arguments
+!************************************************************************************
+    INTEGER, INTENT(IN)                        :: itime   ! current timestep 
+    INTEGER, INTENT(IN)                        :: jour    !  day in year (not 
+    REAL   , INTENT(IN)                        :: dtime   ! physics timestep (s)
+    REAL, DIMENSION(klon,nbsrf), INTENT(INOUT) :: pctsrf_chg  ! sub-surface fraction
+    LOGICAL, INTENT(OUT)                       :: is_modified ! true if pctsrf is 
+                                                         ! modified at this time step
+
+       pctsrf_chg(:,is_oce)=(1.-fsic(:))*(1.-zmasq(:))
+       pctsrf_chg(:,is_sic)=fsic(:)*(1.-zmasq(:))
+       is_modified=.TRUE.
+
+  END SUBROUTINE ocean_slab_frac
+!
+!************************************************************************************
+!
+  SUBROUTINE ocean_slab_noice( & 
+       itime, dtime, jour, knon, knindex, &
+       p1lay, cdragh, cdragq, cdragm, precip_rain, precip_snow, temp_air, spechum, &
+       AcoefH, AcoefQ, BcoefH, BcoefQ, &
+       AcoefU, AcoefV, BcoefU, BcoefV, &
+       ps, u1, v1, gustiness, tsurf_in, &
+       radsol, snow, &
+       qsurf, evap, fluxsens, fluxlat, flux_u1, flux_v1, &
+       tsurf_new, dflux_s, dflux_l, slab_bils)
+    
+    USE calcul_fluxs_mod
+    USE slab_heat_transp_mod, ONLY: divgrad_phy,slab_ekman1,slab_ekman2,slab_gmdiff
+    USE mod_phys_lmdz_para
+
+    INCLUDE "clesphys.h"
+
+! This routine 
+! (1) computes surface turbulent fluxes over points with some open ocean    
+! (2) reads additional Q-flux (everywhere)
+! (3) computes horizontal transport (diffusion & Ekman)
+! (4) updates slab temperature every cpl_pas ; creates new ice if needed.
+
+! Note : 
+! klon total number of points
+! knon number of points with open ocean (varies with time)
+! knindex gives position of the knon points within klon.
+! In general, local saved variables have klon values
+! variables exchanged with PBL module have knon.
+
+! Input arguments
+!***********************************************************************************
+    INTEGER, INTENT(IN)                  :: itime ! current timestep INTEGER,
+    INTEGER, INTENT(IN)                  :: jour  ! day in year (for Q-Flux) 
+    INTEGER, INTENT(IN)                  :: knon  ! number of points 
+    INTEGER, DIMENSION(klon), INTENT(IN) :: knindex 
+    REAL, INTENT(IN) :: dtime  ! timestep (s)
+    REAL, DIMENSION(klon), INTENT(IN)    :: p1lay 
+    REAL, DIMENSION(klon), INTENT(IN)    :: cdragh, cdragq, cdragm 
+    ! drag coefficients
+    REAL, DIMENSION(klon), INTENT(IN)    :: precip_rain, precip_snow 
+    REAL, DIMENSION(klon), INTENT(IN)    :: temp_air, spechum ! near surface T, q
+    REAL, DIMENSION(klon), INTENT(IN)    :: AcoefH, AcoefQ, BcoefH, BcoefQ 
+    REAL, DIMENSION(klon), INTENT(IN)    :: AcoefU, AcoefV, BcoefU, BcoefV 
+    ! exchange coefficients for boundary layer scheme
+    REAL, DIMENSION(klon), INTENT(IN)    :: ps  ! surface pressure
+    REAL, DIMENSION(klon), INTENT(IN)    :: u1, v1, gustiness ! surface wind
+    REAL, DIMENSION(klon), INTENT(IN)    :: tsurf_in ! surface temperature
+    REAL, DIMENSION(klon), INTENT(INOUT) :: radsol ! net surface radiative flux
+
+! In/Output arguments
+!************************************************************************************
+    REAL, DIMENSION(klon), INTENT(INOUT) :: snow ! in kg/m2
+    
+! Output arguments
+!************************************************************************************
+    REAL, DIMENSION(klon), INTENT(OUT)   :: qsurf
+    REAL, DIMENSION(klon), INTENT(OUT)   :: evap, fluxsens, fluxlat
+    REAL, DIMENSION(klon), INTENT(OUT)   :: flux_u1, flux_v1
+    REAL, DIMENSION(klon), INTENT(OUT)   :: tsurf_new ! new surface tempearture
+    REAL, DIMENSION(klon), INTENT(OUT)   :: dflux_s, dflux_l      
+    REAL, DIMENSION(klon), INTENT(OUT)   :: slab_bils
+
+! Local variables
+!************************************************************************************
+    INTEGER               :: i,ki,k
+    REAL                  :: t_cadj
+    !  for surface heat fluxes
+    REAL, DIMENSION(klon) :: cal, beta, dif_grnd
+    ! for Q-Flux computation: d/dt SST, d/dt ice volume (kg/m2), surf fluxes 
+    REAL, DIMENSION(klon) :: diff_sst, diff_siv
+    REAL, DIMENSION(klon,nslay) :: lmt_bils
+    ! for surface wind stress
+    REAL, DIMENSION(klon) :: u0, v0
+    REAL, DIMENSION(klon) :: u1_lay, v1_lay
+    ! for new ice creation
+    REAL                  :: e_freeze, h_new, dfsic
+    ! horizontal diffusion and Ekman local vars
+    ! dimension = global domain (klon_glo) instead of // subdomains 
+    REAL, DIMENSION(klon_glo,nslay) :: dt_hdiff_glo,dt_ekman_glo,dt_gm_glo
+    ! dt_ekman_glo saved for diagnostic, dt_ekman_tmp used for time loop
+    REAL, DIMENSION(klon_glo,nslay) :: dt_hdiff_tmp, dt_ekman_tmp
+    REAL, DIMENSION(klon_glo,nslay) :: tslab_glo
+    REAL, DIMENSION(klon_glo) :: taux_glo,tauy_glo
+
+!****************************************************************************************
+! 1) Surface fluxes calculation
+!    
+!****************************************************************************************
+    !cal(:)      = 0. ! infinite thermal inertia
+    !beta(:)     = 1. ! wet surface
+    !dif_grnd(:) = 0. ! no diffusion into ground
+    ! EV: use calbeta
+    CALL calbeta(dtime, is_oce, knon, snow,qsurf, beta, cal, dif_grnd)
+
+
+    
+! Suppose zero surface speed
+    u0(:)=0.0
+    v0(:)=0.0
+    u1_lay(:) = u1(:) - u0(:)
+    v1_lay(:) = v1(:) - v0(:)
+
+! Compute latent & sensible fluxes
+    CALL calcul_fluxs(knon, is_oce, dtime, &
+         tsurf_in, p1lay, cal, beta, cdragh, cdragq, ps, &
+         precip_rain, precip_snow, snow, qsurf,  &
+         radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, gustiness, &
+         f_qsat_oce,AcoefH, AcoefQ, BcoefH, BcoefQ, &
+         tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l)
+
+! save total cumulated heat fluxes locally
+! radiative + turbulent + melt of falling snow 
+    slab_bils(:)=0.
+    DO i=1,knon
+        ki=knindex(i)
+        slab_bils(ki)=(1.-fsic(ki))*(fluxlat(i)+fluxsens(i)+radsol(i) &
+                      -precip_snow(i)*ice_lat*(1.+snow_wfact*fsic(ki)))
+        bils_cum(ki)=bils_cum(ki)+slab_bils(ki)
+    END DO
+
+!  Compute surface wind stress
+    CALL calcul_flux_wind(knon, dtime, &
+         u0, v0, u1, v1, gustiness, cdragm, &
+         AcoefU, AcoefV, BcoefU, BcoefV, &
+         p1lay, temp_air, &
+         flux_u1, flux_v1)  
+
+! save cumulated wind stress
+    IF (slab_ekman.GT.0) THEN 
+      DO i=1,knon
+          ki=knindex(i)
+          taux_cum(ki)=taux_cum(ki)+flux_u1(i)*(1.-fsic(ki))/cpl_pas
+          tauy_cum(ki)=tauy_cum(ki)+flux_v1(i)*(1.-fsic(ki))/cpl_pas
+      END DO
+    ENDIF
+
+!****************************************************************************************
+! 2) Q-Flux : get global variables lmt_bils, diff_sst and diff_siv from file limit_slab.nc
+!
+!****************************************************************************************
+    CALL limit_slab(itime, dtime, jour, lmt_bils, diff_sst, diff_siv) 
+    ! lmt_bils and diff_sst,siv saved by limit_slab
+    ! qflux = total QFlux correction (in W/m2)
+    dt_qflux(:,1)=lmt_bils(:,1)+diff_sst(:)/cyang/86400.-diff_siv(:)*ice_den*ice_lat/86400.
+    IF (nslay.GT.1) THEN
+       dt_qflux(:,2:nslay)=lmt_bils(:,2:nslay)
+    END IF
+
+!****************************************************************************************
+! 3) Recalculate new temperature (add Surf fluxes, Q-Flux, Ocean transport)
+!    Bring to freezing temp and make sea ice if necessary
+!  
+!***********************************************o*****************************************
+    tsurf_new=tsurf_in
+    IF (MOD(itime,cpl_pas).EQ.0) THEN ! time to update tslab & fraction
+! ***********************************
+!  Horizontal transport 
+! ***********************************
+      IF (slab_ekman.GT.0) THEN 
+          ! copy wind stress to global var
+          CALL gather(taux_cum,taux_glo)
+          CALL gather(tauy_cum,tauy_glo)
+      END IF
+
+      IF (slab_hdiff.OR.(slab_ekman.GT.0)) THEN 
+        CALL gather(tslab,tslab_glo)
+      ! Compute horiz transport on one process only
+        IF (is_mpi_root .AND. is_omp_root) THEN ! Only master processus          
+          IF (slab_hdiff) THEN 
+              dt_hdiff_glo(:,:)=0.
+          END IF
+          IF (slab_ekman.GT.0) THEN 
+              dt_ekman_glo(:,:)=0.
+          END IF
+          IF (slab_gm) THEN 
+              dt_gm_glo(:,:)=0.
+          END IF
+          DO i=1,cpl_pas ! time splitting for numerical stability
+            IF (slab_ekman.GT.0) THEN
+              SELECT CASE (slab_ekman)
+                CASE (1)
+                  CALL slab_ekman1(taux_glo,tauy_glo,tslab_glo,dt_ekman_tmp)
+                CASE (2)
+                  CALL slab_ekman2(taux_glo,tauy_glo,tslab_glo,dt_ekman_tmp,dt_hdiff_tmp,slab_gm)
+                CASE DEFAULT
+                  dt_ekman_tmp(:,:)=0.
+              END SELECT
+              dt_ekman_glo(:,:)=dt_ekman_glo(:,:)+dt_ekman_tmp(:,:)
+              ! convert dt_ekman from K.s-1.(kg.m-2) to K.s-1   
+              DO k=1,nslay
+                dt_ekman_tmp(:,k)=dt_ekman_tmp(:,k)/(slabh(k)*sea_den)
+              ENDDO
+              tslab_glo=tslab_glo+dt_ekman_tmp*dtime
+              IF (slab_gm) THEN ! Gent-McWilliams eddy advection
+                dt_gm_glo(:,:)=dt_gm_glo(:,:)+ dt_hdiff_tmp(:,:)
+                ! convert dt from K.s-1.(kg.m-2) to K.s-1   
+                DO k=1,nslay
+                  dt_hdiff_tmp(:,k)=dt_hdiff_tmp(:,k)/(slabh(k)*sea_den) 
+                END DO
+                tslab_glo=tslab_glo+dt_hdiff_tmp*dtime
+              END IF
+            ENDIF
+! GM included in Ekman_2
+!            IF (slab_gm) THEN ! Gent-McWilliams eddy advection
+!              CALL slab_gmdiff(tslab_glo,dt_hdiff_tmp)
+!              ! convert dt_gm from K.m.s-1 to K.s-1   
+!              DO k=1,nslay
+!                dt_hdiff_tmp(:,k)=dt_hdiff_tmp(:,k)/slabh(k) 
+!              END DO
+!              tslab_glo=tslab_glo+dt_hdiff_tmp*dtime
+!              dt_gm_glo(:,:)=dt_gm_glo(:,:)+ dt_hdiff_tmp(:,:)
+!            END IF
+            IF (slab_hdiff) THEN ! horizontal diffusion
+              ! laplacian of slab T
+              CALL divgrad_phy(nslay,tslab_glo,dt_hdiff_tmp)
+              ! multiply by diff coef and normalize to 50m slab equivalent
+              dt_hdiff_tmp=dt_hdiff_tmp*coef_hdiff*50./SUM(slabh)
+              dt_hdiff_glo(:,:)=dt_hdiff_glo(:,:)+ dt_hdiff_tmp(:,:)
+              tslab_glo=tslab_glo+dt_hdiff_tmp*dtime
+            END IF
+          END DO ! time splitting
+          IF (slab_hdiff) THEN
+            !dt_hdiff_glo saved in W/m2
+            DO k=1,nslay
+              dt_hdiff_glo(:,k)=dt_hdiff_glo(:,k)*slabh(k)*sea_den*sea_cap/cpl_pas
+            END DO
+          END IF
+          IF (slab_gm) THEN
+            !dt_hdiff_glo saved in W/m2
+            dt_gm_glo(:,:)=dt_gm_glo(:,:)*sea_cap/cpl_pas
+          END IF
+          IF (slab_ekman.GT.0) THEN 
+            ! dt_ekman_glo saved in W/m2
+            dt_ekman_glo(:,:)=dt_ekman_glo(:,:)*sea_cap/cpl_pas
+          END IF
+        END IF ! master process
+!$OMP BARRIER
+        ! Send new fields back to all processes
+        CALL Scatter(tslab_glo,tslab)
+        IF (slab_hdiff) THEN
+          CALL Scatter(dt_hdiff_glo,dt_hdiff)
+        END IF
+        IF (slab_gm) THEN
+          CALL Scatter(dt_gm_glo,dt_gm)
+        END IF
+        IF (slab_ekman.GT.0) THEN 
+          CALL Scatter(dt_ekman_glo,dt_ekman)
+          ! clear wind stress
+          taux_cum(:)=0.
+          tauy_cum(:)=0.
+        END IF
+      ENDIF ! transport
+
+! ***********************************
+! Other heat fluxes
+! ***********************************
+      ! Add read QFlux
+      DO k=1,nslay
+        tslab(:,k)=tslab(:,k)+dt_qflux(:,k)*cyang*dtime*cpl_pas &
+                   *slabh(1)/slabh(k) 
+      END DO
+      ! Add cumulated surface fluxes
+      tslab(:,1)=tslab(:,1)+bils_cum(:)*cyang*dtime
+      ! Convective adjustment if 2 layers 
+      IF ((nslay.GT.1).AND.(slab_cadj.GT.0)) THEN
+        DO i=1,klon
+          IF (tslab(i,2).GT.tslab(i,1)) THEN
+            ! mean (mass-weighted) temperature
+            t_cadj=SUM(tslab(i,:)*slabh(:))/SUM(slabh(:))
+            tslab(i,1)=t_cadj
+            tslab(i,2)=t_cadj
+          END IF
+        END DO
+      END IF
+! ***********************************
+! Update surface temperature and ice 
+! ***********************************
+      SELECT CASE(version_ocean)
+      CASE('sicNO') ! no sea ice even below freezing !
+          DO i=1,knon
+              ki=knindex(i)
+              tsurf_new(i)=tslab(ki,1)
+          END DO
+      CASE('sicOBS') ! "realistic" case, for prescribed sea ice
+        ! tslab cannot be below freezing, or above it if there is sea ice
+          DO i=1,knon
+              ki=knindex(i)
+              IF ((tslab(ki,1).LT.t_freeze).OR.(fsic(ki).GT.epsfra)) THEN
+                  tslab(ki,1)=t_freeze
+              END IF
+              tsurf_new(i)=tslab(ki,1)
+          END DO
+      CASE('sicINT') ! interactive sea ice
+          DO i=1,knon
+              ki=knindex(i)
+              IF (fsic(ki).LT.epsfra) THEN ! Free of ice
+                  IF (tslab(ki,1).LT.t_freeze) THEN ! create new ice
+                      ! quantity of new ice formed
+                      e_freeze=(t_freeze-tslab(ki,1))/cyang/ice_lat
+                      ! new ice
+                      tice(ki)=t_freeze
+                      fsic(ki)=MIN(ice_frac_max,e_freeze/h_ice_thin)
+                      IF (fsic(ki).GT.ice_frac_min) THEN
+                          seaice(ki)=MIN(e_freeze/fsic(ki),h_ice_max)
+                          tslab(ki,1)=t_freeze
+                      ELSE
+                          fsic(ki)=0.
+                      END IF
+                      tsurf_new(i)=t_freeze
+                  ELSE
+                      tsurf_new(i)=tslab(ki,1)
+                  END IF 
+              ELSE ! ice present
+                  tsurf_new(i)=t_freeze
+                  IF (tslab(ki,1).LT.t_freeze) THEN ! create new ice
+                      ! quantity of new ice formed over open ocean
+                      e_freeze=(t_freeze-tslab(ki,1))/cyang*(1.-fsic(ki)) &
+                               /(ice_lat+ice_cap/2.*(t_freeze-tice(ki)))
+                      ! new ice height and fraction
+                      h_new=MIN(h_ice_new,seaice(ki)) ! max new height ice_new
+                      dfsic=MIN(ice_frac_max-fsic(ki),e_freeze/h_new)
+                      h_new=MIN(e_freeze/dfsic,h_ice_max)
+                      ! update tslab to freezing over open ocean only
+                      tslab(ki,1)=tslab(ki,1)*fsic(ki)+t_freeze*(1.-fsic(ki))
+                      ! update sea ice
+                      seaice(ki)=(h_new*dfsic+seaice(ki)*fsic(ki)) &
+                                 /(dfsic+fsic(ki))
+                      fsic(ki)=fsic(ki)+dfsic
+                      ! update snow?
+                  END IF ! tslab below freezing
+              END IF ! sea ice present
+          END DO
+      END SELECT
+      bils_cum(:)=0.0! clear cumulated fluxes
+    END IF ! coupling time
+  END SUBROUTINE ocean_slab_noice
+!
+!****************************************************************************************
+
+  SUBROUTINE ocean_slab_ice(   &
+       itime, dtime, jour, knon, knindex, &
+       tsurf_in, p1lay, cdragh, cdragm, precip_rain, precip_snow, temp_air, spechum, &
+       AcoefH, AcoefQ, BcoefH, BcoefQ, &
+       AcoefU, AcoefV, BcoefU, BcoefV, &
+       ps, u1, v1, gustiness, &
+       radsol, snow, qsurf, qsol, agesno, &
+       alb1_new, alb2_new, evap, fluxsens, fluxlat, flux_u1, flux_v1, &
+       tsurf_new, dflux_s, dflux_l, swnet)
+
+   USE calcul_fluxs_mod
+
+   INCLUDE "YOMCST.h"
+   INCLUDE "clesphys.h"
+
+! Input arguments
+!****************************************************************************************
+    INTEGER, INTENT(IN)                  :: itime, jour, knon
+    INTEGER, DIMENSION(klon), INTENT(IN) :: knindex
+    REAL, INTENT(IN)                     :: dtime
+    REAL, DIMENSION(klon), INTENT(IN)    :: tsurf_in
+    REAL, DIMENSION(klon), INTENT(IN)    :: p1lay
+    REAL, DIMENSION(klon), INTENT(IN)    :: cdragh, cdragm
+    REAL, DIMENSION(klon), INTENT(IN)    :: precip_rain, precip_snow
+    REAL, DIMENSION(klon), INTENT(IN)    :: temp_air, spechum
+    REAL, DIMENSION(klon), INTENT(IN)    :: AcoefH, AcoefQ, BcoefH, BcoefQ
+    REAL, DIMENSION(klon), INTENT(IN)    :: AcoefU, AcoefV, BcoefU, BcoefV
+    REAL, DIMENSION(klon), INTENT(IN)    :: ps
+    REAL, DIMENSION(klon), INTENT(IN)    :: u1, v1, gustiness
+    REAL, DIMENSION(klon), INTENT(IN)    :: swnet
+
+! In/Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(INOUT)          :: snow, qsol
+    REAL, DIMENSION(klon), INTENT(INOUT)          :: agesno
+    REAL, DIMENSION(klon), INTENT(INOUT)          :: radsol
+
+! Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(OUT)            :: qsurf
+    REAL, DIMENSION(klon), INTENT(OUT)            :: alb1_new  ! new albedo in visible SW interval
+    REAL, DIMENSION(klon), INTENT(OUT)            :: alb2_new  ! new albedo in near IR interval
+    REAL, DIMENSION(klon), INTENT(OUT)            :: evap, fluxsens, fluxlat
+    REAL, DIMENSION(klon), INTENT(OUT)            :: flux_u1, flux_v1
+    REAL, DIMENSION(klon), INTENT(OUT)            :: tsurf_new
+    REAL, DIMENSION(klon), INTENT(OUT)            :: dflux_s, dflux_l
+
+! Local variables
+!****************************************************************************************
+    INTEGER               :: i,ki
+    REAL, DIMENSION(klon) :: cal, beta, dif_grnd
+    REAL, DIMENSION(klon) :: u0, v0
+    REAL, DIMENSION(klon) :: u1_lay, v1_lay
+    ! intermediate heat fluxes:
+    REAL                  :: f_cond, f_swpen
+    ! for snow/ice albedo:
+    REAL                  :: alb_snow, alb_ice, alb_pond
+    REAL                  :: frac_snow, frac_ice, frac_pond
+    ! for ice melt / freeze
+    REAL                  :: e_melt, snow_evap, h_test
+    ! dhsic, dfsic change in ice mass, fraction.
+    REAL                  :: dhsic, dfsic, frac_mf
+
+!****************************************************************************************
+! 1) Flux calculation
+!****************************************************************************************
+! Suppose zero surface speed
+    u0(:)=0.0
+    v0(:)=0.0
+    u1_lay(:) = u1(:) - u0(:)
+    v1_lay(:) = v1(:) - v0(:)
+
+! set beta, cal, compute conduction fluxes inside ice/snow 
+    slab_bilg(:)=0.
+    !dif_grnd(:)=0.
+    !beta(:) = 1.
+    ! EV: use calbeta to calculate beta and then recalculate properly cal
+    CALL calbeta(dtime, is_sic, knon, snow, qsol, beta, cal, dif_grnd)
+
+
+    DO i=1,knon
+    ki=knindex(i)
+        IF (snow(i).GT.snow_min) THEN
+            ! snow-layer heat capacity
+            cal(i)=2.*RCPD/(snow(i)*ice_cap)
+            ! snow conductive flux
+            f_cond=sno_cond*(tice(ki)-tsurf_in(i))/snow(i)
+            ! all shortwave flux absorbed
+            f_swpen=0.
+            ! bottom flux (ice conduction)
+            slab_bilg(ki)=ice_cond*(tice(ki)-t_freeze)/seaice(ki)
+            ! update ice temperature
+            tice(ki)=tice(ki)-2./ice_cap/(snow(i)+seaice(ki)) &
+                     *(slab_bilg(ki)+f_cond)*dtime
+       ELSE ! bare ice
+            ! ice-layer heat capacity
+            cal(i)=2.*RCPD/(seaice(ki)*ice_cap)
+            ! conductive flux
+            f_cond=ice_cond*(t_freeze-tice(ki))/seaice(ki)
+            ! penetrative shortwave flux...
+            f_swpen=swnet(i)*pen_frac*exp(-pen_ext*seaice(ki)/ice_den)
+            slab_bilg(ki)=f_swpen-f_cond
+        END IF
+        radsol(i)=radsol(i)+f_cond-f_swpen
+    END DO
+    ! weight fluxes to ocean by sea ice fraction
+    slab_bilg(:)=slab_bilg(:)*fsic(:)
+
+! calcul_fluxs (sens, lat etc)
+    CALL calcul_fluxs(knon, is_sic, dtime, &
+        tsurf_in, p1lay, cal, beta, cdragh, cdragh, ps, &
+        precip_rain, precip_snow, snow, qsurf,  &
+        radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, gustiness, &
+        f_qsat_oce,AcoefH, AcoefQ, BcoefH, BcoefQ, &
+        tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l)
+    DO i=1,knon 
+        IF (snow(i).LT.snow_min) tice(knindex(i))=tsurf_new(i)
+    END DO
+
+! calcul_flux_wind
+    CALL calcul_flux_wind(knon, dtime, &
+         u0, v0, u1, v1, gustiness, cdragm, &
+         AcoefU, AcoefV, BcoefU, BcoefV, &
+         p1lay, temp_air, &
+         flux_u1, flux_v1)
+
+!****************************************************************************************
+! 2) Update snow and ice surface
+!****************************************************************************************
+! snow precip
+    DO i=1,knon
+        ki=knindex(i)
+        IF (precip_snow(i) > 0.) THEN
+            snow(i) = snow(i)+precip_snow(i)*dtime*(1.-snow_wfact*(1.-fsic(ki)))
+        END IF
+! snow and ice sublimation
+        IF (evap(i) > 0.) THEN 
+           snow_evap = MIN (snow(i) / dtime, evap(i))
+           snow(i) = snow(i) - snow_evap * dtime
+           snow(i) = MAX(0.0, snow(i))
+           seaice(ki) = MAX(0.0,seaice(ki)-(evap(i)-snow_evap)*dtime)
+        ENDIF
+! Melt / Freeze snow from above if Tsurf>0
+        IF (tsurf_new(i).GT.t_melt) THEN
+            ! energy available for melting snow (in kg of melted snow /m2)
+            e_melt = MIN(MAX(snow(i)*(tsurf_new(i)-t_melt)*ice_cap/2. &
+               /(ice_lat+ice_cap/2.*(t_melt-tice(ki))),0.0),snow(i))
+            ! remove snow
+            IF (snow(i).GT.e_melt) THEN
+                snow(i)=snow(i)-e_melt
+                tsurf_new(i)=t_melt
+            ELSE ! all snow is melted
+                ! add remaining heat flux to ice
+                e_melt=e_melt-snow(i)
+                tice(ki)=tice(ki)+e_melt*ice_lat*2./(ice_cap*seaice(ki))
+                tsurf_new(i)=tice(ki)
+            END IF
+        END IF
+! melt ice from above if Tice>0
+        IF (tice(ki).GT.t_melt) THEN
+            ! quantity of ice melted (kg/m2)
+            e_melt=MAX(seaice(ki)*(tice(ki)-t_melt)*ice_cap/2. & 
+             /(ice_lat+ice_cap/2.*(t_melt-t_freeze)),0.0)
+            ! melt from above, height only
+            dhsic=MIN(seaice(ki)-h_ice_min,e_melt)
+            e_melt=e_melt-dhsic
+            IF (e_melt.GT.0) THEN
+            ! lateral melt if ice too thin
+            dfsic=MAX(fsic(ki)-ice_frac_min,e_melt/h_ice_min*fsic(ki))
+            ! if all melted add remaining heat to ocean
+            e_melt=MAX(0.,e_melt*fsic(ki)-dfsic*h_ice_min)
+            slab_bilg(ki)=slab_bilg(ki)+ e_melt*ice_lat/dtime
+            ! update height and fraction
+            fsic(ki)=fsic(ki)-dfsic
+            END IF
+            seaice(ki)=seaice(ki)-dhsic
+            ! surface temperature at melting point
+            tice(ki)=t_melt
+            tsurf_new(i)=t_melt
+        END IF
+        ! convert snow to ice if below floating line
+        h_test=(seaice(ki)+snow(i))*ice_den-seaice(ki)*sea_den
+        IF (h_test.GT.0.) THEN !snow under water
+            ! extra snow converted to ice (with added frozen sea water)
+            dhsic=h_test/(sea_den-ice_den+sno_den)
+            seaice(ki)=seaice(ki)+dhsic
+            snow(i)=snow(i)-dhsic*sno_den/ice_den
+            ! available energy (freeze sea water + bring to tice)
+            e_melt=dhsic*(1.-sno_den/ice_den)*(ice_lat+ &
+                   ice_cap/2.*(t_freeze-tice(ki)))
+            ! update ice temperature
+            tice(ki)=tice(ki)+2.*e_melt/ice_cap/(snow(i)+seaice(ki))
+        END IF
+    END DO
+
+! New albedo
+    DO i=1,knon
+        ki=knindex(i)
+       ! snow albedo: update snow age
+        IF (snow(i).GT.0.0001) THEN
+             agesno(i)=(agesno(i) + (1.-agesno(i)/50.)*dtime/86400.)&
+                         * EXP(-1.*MAX(0.0,precip_snow(i))*dtime/5.)
+        ELSE
+            agesno(i)=0.0
+        END IF
+        ! snow albedo
+        alb_snow=alb_sno_min+alb_sno_del*EXP(-agesno(i)/50.)
+        ! ice albedo (varies with ice tkickness and temp)
+        alb_ice=MAX(0.0,0.13*LOG(100.*seaice(ki)/ice_den)+0.1)
+        IF (tice(ki).GT.t_freeze-0.01) THEN
+            alb_ice=MIN(alb_ice,alb_ice_wet)
+        ELSE
+            alb_ice=MIN(alb_ice,alb_ice_dry)
+        END IF
+        ! pond albedo
+        alb_pond=0.36-0.1*(2.0+MIN(0.0,MAX(tice(ki)-t_melt,-2.0)))
+        ! pond fraction
+        frac_pond=0.2*(2.0+MIN(0.0,MAX(tice(ki)-t_melt,-2.0)))
+        ! snow fraction
+        frac_snow=MAX(0.0,MIN(1.0-frac_pond,snow(i)/snow_min))
+        ! ice fraction
+        frac_ice=MAX(0.0,1.-frac_pond-frac_snow)
+        ! total albedo
+        alb1_new(i)=alb_snow*frac_snow+alb_ice*frac_ice+alb_pond*frac_pond
+    END DO
+    alb2_new(:) = alb1_new(:)
+
+!****************************************************************************************
+! 3) Recalculate new ocean temperature (add fluxes below ice)
+!    Melt / freeze from below
+!***********************************************o*****************************************
+    !cumul fluxes
+    bilg_cum(:)=bilg_cum(:)+slab_bilg(:)
+    IF (MOD(itime,cpl_pas).EQ.0) THEN ! time to update tslab & fraction
+        ! Add cumulated surface fluxes
+        tslab(:,1)=tslab(:,1)+bilg_cum(:)*cyang*dtime
+        DO i=1,knon
+            ki=knindex(i)
+            ! split lateral/top melt-freeze
+            frac_mf=MIN(1.,MAX(0.,(seaice(ki)-h_ice_thin)/(h_ice_thick-h_ice_thin)))
+            IF (tslab(ki,1).LE.t_freeze) THEN 
+               ! ****** Form new ice from below *******
+               ! quantity of new ice
+                e_melt=(t_freeze-tslab(ki,1))/cyang & 
+                       /(ice_lat+ice_cap/2.*(t_freeze-tice(ki)))
+               ! first increase height to h_thin
+               dhsic=MAX(0.,MIN(h_ice_thin-seaice(ki),e_melt/fsic(ki)))
+               seaice(ki)=dhsic+seaice(ki)
+               e_melt=e_melt-fsic(ki)*dhsic
+               IF (e_melt.GT.0.) THEN
+               ! frac_mf fraction used for lateral increase
+               dfsic=MIN(ice_frac_max-fsic(ki),e_melt*frac_mf/seaice(ki))
+               fsic(ki)=fsic(ki)+dfsic
+               e_melt=e_melt-dfsic*seaice(ki)
+               ! rest used to increase height
+               seaice(ki)=MIN(h_ice_max,seaice(ki)+e_melt/fsic(ki))
+               END IF
+               tslab(ki,1)=t_freeze
+           ELSE ! slab temperature above freezing
+               ! ****** melt ice from below *******
+               ! quantity of melted ice
+               e_melt=(tslab(ki,1)-t_freeze)/cyang & 
+                       /(ice_lat+ice_cap/2.*(tice(ki)-t_freeze))
+               ! first decrease height to h_thick
+               dhsic=MAX(0.,MIN(seaice(ki)-h_ice_thick,e_melt/fsic(ki)))
+               seaice(ki)=seaice(ki)-dhsic
+               e_melt=e_melt-fsic(ki)*dhsic
+               IF (e_melt.GT.0) THEN
+               ! frac_mf fraction used for height decrease
+               dhsic=MAX(0.,MIN(seaice(ki)-h_ice_min,e_melt*frac_mf/fsic(ki)))
+               seaice(ki)=seaice(ki)-dhsic
+               e_melt=e_melt-fsic(ki)*dhsic
+               ! rest used to decrease fraction (up to 0!)
+               dfsic=MIN(fsic(ki),e_melt/seaice(ki))
+               ! keep remaining in ocean
+               e_melt=e_melt-dfsic*seaice(ki)
+               END IF
+               tslab(ki,1)=t_freeze+e_melt*ice_lat*cyang
+               fsic(ki)=fsic(ki)-dfsic
+           END IF
+        END DO
+        bilg_cum(:)=0.
+    END IF ! coupling time
+    
+    !tests ice fraction 
+    WHERE (fsic.LT.ice_frac_min)
+        tslab(:,1)=tslab(:,1)-fsic*seaice*ice_lat*cyang
+        tice=t_melt
+        fsic=0.
+        seaice=0.
+    END WHERE
+
+  END SUBROUTINE ocean_slab_ice
+!
+!****************************************************************************************
+!
+  SUBROUTINE ocean_slab_final
+
+!****************************************************************************************
+! Deallocate module variables
+!****************************************************************************************
+    IF (ALLOCATED(tslab)) DEALLOCATE(tslab)
+    IF (ALLOCATED(fsic)) DEALLOCATE(fsic)
+    IF (ALLOCATED(tice)) DEALLOCATE(tice)
+    IF (ALLOCATED(seaice)) DEALLOCATE(seaice)
+    IF (ALLOCATED(slab_bilg)) DEALLOCATE(slab_bilg)
+    IF (ALLOCATED(bilg_cum)) DEALLOCATE(bilg_cum)
+    IF (ALLOCATED(bils_cum)) DEALLOCATE(bils_cum)
+    IF (ALLOCATED(taux_cum)) DEALLOCATE(taux_cum)
+    IF (ALLOCATED(tauy_cum)) DEALLOCATE(tauy_cum)
+    IF (ALLOCATED(dt_ekman)) DEALLOCATE(dt_ekman)
+    IF (ALLOCATED(dt_hdiff)) DEALLOCATE(dt_hdiff)
+    IF (ALLOCATED(dt_gm)) DEALLOCATE(dt_gm)
+    IF (ALLOCATED(dt_qflux)) DEALLOCATE(dt_qflux)
+
+  END SUBROUTINE ocean_slab_final
+
+END MODULE ocean_slab_mod
Index: DZ6/trunk/libf/phylmd/open_climoz_m.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/open_climoz_m.F90	(revision 5267)
+++ 	(revision )
@@ -1,101 +1,0 @@
-! $Id$
-MODULE open_climoz_m
-
-  USE print_control_mod, ONLY: lunout
-  IMPLICIT NONE
-
-CONTAINS
-
-!-------------------------------------------------------------------------------
-!
-SUBROUTINE open_climoz(ncid, press_in_cen, press_in_edg, time_in, daily, adjust)
-!
-!-------------------------------------------------------------------------------
-  USE netcdf95, ONLY: nf95_open, nf95_close, nf95_gw_var, nf95_inq_varid
-  USE netcdf,   ONLY: nf90_nowrite
-  USE mod_phys_lmdz_mpi_data,      ONLY: is_mpi_root
-  USE mod_phys_lmdz_mpi_transfert, ONLY: bcast_mpi
-  USE phys_cal_mod,                ONLY: calend, year_len, year_cur
-!-------------------------------------------------------------------------------
-! Purpose: This procedure should be called once per "gcm" run, by a single
-!          thread of each MPI process.
-!          The root MPI process opens "climoz_LMDZ.nc", reads the pressure
-! levels and the times and broadcasts them to the other processes.
-!          We assume that, in "climoz_LMDZ.nc", the pressure levels are in hPa
-! and in strictly ascending order.
-!-------------------------------------------------------------------------------
-! Arguments (OpenMP shared):
-  INTEGER, INTENT(OUT):: ncid      !--- "climoz_LMDZ.nc" identifier
-  REAL, allocatable, intent(out):: press_in_cen(:) !--- at cells centers
-  REAL, allocatable, INTENT(OUT):: press_in_edg(:) !--- at the interfaces (pressure intervals)
-  REAL, allocatable, intent(out):: time_in(:)      !--- records times, in days since Jan. 1st
-  LOGICAL, INTENT(IN) :: daily     !--- daily files (calendar dependent days nb)
-  LOGICAL, INTENT(IN) :: adjust    !--- tropopause adjustement required
-!   pressure levels press_in_cen/edg are in Pa a,d strictly ascending order.
-!   time_in is only used for monthly files (14 records)
-!-------------------------------------------------------------------------------
-! Local variables:
-  INTEGER :: varid                 !--- NetCDF variables identifier
-  INTEGER :: nlev, ntim            !--- pressure levels and time records numbers
-  CHARACTER(LEN=80)  :: sub
-  CHARACTER(LEN=320) :: msg
-!-------------------------------------------------------------------------------
-  sub="open_climoz"
-  WRITE(lunout,*)"Entering routine "//TRIM(sub)
-
-  IF(is_mpi_root) THEN
-
-    !--- OPEN FILE, READ PRESSURE LEVELS AND TIME VECTOR
-    CALL nf95_open("climoz_LMDZ.nc", nf90_nowrite, ncid)
-    CALL nf95_inq_varid(ncid, "plev", varid)
-    CALL nf95_gw_var(ncid, varid, press_in_cen)
-    ! Convert from hPa to Pa because "paprs" and "pplay" are in Pa:
-    press_in_cen = press_in_cen * 100.
-    nlev = SIZE(press_in_cen)
-    CALL NF95_INQ_VARID(ncID, "time", varID)
-    CALL NF95_GW_VAR(ncid, varid, time_in)
-    ntim = SIZE(time_in)
-
-    !--- BUILD EDGES OF PRESSURE INTERVALS: HALFWAY IN LOGARITHMS
-    ALLOCATE(press_in_edg(nlev+1))
-    press_in_edg=[0.,SQRT(press_in_cen(1:nlev-1)*press_in_cen(2:nlev)),HUGE(0.)]
-
-    !--- CHECK RECORDS NUMBER AND DISPLAY CORRESPONDING INFORMATION
-    IF(daily.AND.ntim/=year_len) THEN
-      WRITE(msg,'(a,3(i4,a))')TRIM(sub)//': Expecting a daily ozone file with',&
-     &year_len,' records (year ',year_cur,') ; found ',ntim,' instead'
-      CALL abort_physic(sub, msg, 1)
-    ELSE IF(ALL([360,14]/=ntim)) THEN
-      WRITE(msg,'(a,i4,a)')TRIM(sub)//': Expecting an ozone file with 14 (mont'&
-     &//'hly case) or 360 (old style files) records ; found ',ntim,' instead'
-      CALL abort_physic(sub, msg, 1)
-    ELSE
-      IF(daily) THEN
-         WRITE(msg,'(a,2(i4,a))')'daily file (',ntim,' days in ',year_cur,')'
-       ELSE IF(ntim==14) THEN
-         msg='14 records monthly file'
-       ELSE
-         msg='360 records files (old convention)'
-       END IF
-      WRITE(lunout,*)TRIM(sub)//': Using a '//TRIM(msg)
-    END IF
-
-    !--- MESSAGE ABOUT OPTIONAL STRETCHING FOR TROPOPAUSES MATCHING
-    IF(adjust) THEN
-      WRITE(lunout,*)TRIM(sub)//': Adjusting O3 field to match gcm tropopause.'
-    ELSE
-      WRITE(lunout,*)TRIM(sub)//': Interpolating O3 field directly on gcm levels.'
-    END IF
-
-  END IF
-  CALL bcast_mpi(nlev)
-  IF(.NOT.is_mpi_root) ALLOCATE(press_in_cen(nlev  )); CALL bcast_mpi(press_in_cen)
-  IF(.NOT.is_mpi_root) ALLOCATE(press_in_edg(nlev+1)); CALL bcast_mpi(press_in_edg)
-  CALL bcast_mpi(ntim)
-  IF(.NOT.is_mpi_root) ALLOCATE(time_in(ntim));        CALL bcast_mpi(time_in)
-
-END SUBROUTINE open_climoz
-!
-!-------------------------------------------------------------------------------
-
-END MODULE open_climoz_m
Index: /LMDZ6/trunk/libf/phylmd/open_climoz_m.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/open_climoz_m.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/open_climoz_m.f90	(revision 5268)
@@ -0,0 +1,101 @@
+! $Id$
+MODULE open_climoz_m
+
+  USE print_control_mod, ONLY: lunout
+  IMPLICIT NONE
+
+CONTAINS
+
+!-------------------------------------------------------------------------------
+!
+SUBROUTINE open_climoz(ncid, press_in_cen, press_in_edg, time_in, daily, adjust)
+!
+!-------------------------------------------------------------------------------
+  USE netcdf95, ONLY: nf95_open, nf95_close, nf95_gw_var, nf95_inq_varid
+  USE netcdf,   ONLY: nf90_nowrite
+  USE mod_phys_lmdz_mpi_data,      ONLY: is_mpi_root
+  USE mod_phys_lmdz_mpi_transfert, ONLY: bcast_mpi
+  USE phys_cal_mod,                ONLY: calend, year_len, year_cur
+!-------------------------------------------------------------------------------
+! Purpose: This procedure should be called once per "gcm" run, by a single
+!          thread of each MPI process.
+!          The root MPI process opens "climoz_LMDZ.nc", reads the pressure
+! levels and the times and broadcasts them to the other processes.
+!          We assume that, in "climoz_LMDZ.nc", the pressure levels are in hPa
+! and in strictly ascending order.
+!-------------------------------------------------------------------------------
+! Arguments (OpenMP shared):
+  INTEGER, INTENT(OUT):: ncid      !--- "climoz_LMDZ.nc" identifier
+  REAL, allocatable, intent(out):: press_in_cen(:) !--- at cells centers
+  REAL, allocatable, INTENT(OUT):: press_in_edg(:) !--- at the interfaces (pressure intervals)
+  REAL, allocatable, intent(out):: time_in(:)      !--- records times, in days since Jan. 1st
+  LOGICAL, INTENT(IN) :: daily     !--- daily files (calendar dependent days nb)
+  LOGICAL, INTENT(IN) :: adjust    !--- tropopause adjustement required
+!   pressure levels press_in_cen/edg are in Pa a,d strictly ascending order.
+!   time_in is only used for monthly files (14 records)
+!-------------------------------------------------------------------------------
+! Local variables:
+  INTEGER :: varid                 !--- NetCDF variables identifier
+  INTEGER :: nlev, ntim            !--- pressure levels and time records numbers
+  CHARACTER(LEN=80)  :: sub
+  CHARACTER(LEN=320) :: msg
+!-------------------------------------------------------------------------------
+  sub="open_climoz"
+  WRITE(lunout,*)"Entering routine "//TRIM(sub)
+
+  IF(is_mpi_root) THEN
+
+    !--- OPEN FILE, READ PRESSURE LEVELS AND TIME VECTOR
+    CALL nf95_open("climoz_LMDZ.nc", nf90_nowrite, ncid)
+    CALL nf95_inq_varid(ncid, "plev", varid)
+    CALL nf95_gw_var(ncid, varid, press_in_cen)
+    ! Convert from hPa to Pa because "paprs" and "pplay" are in Pa:
+    press_in_cen = press_in_cen * 100.
+    nlev = SIZE(press_in_cen)
+    CALL NF95_INQ_VARID(ncID, "time", varID)
+    CALL NF95_GW_VAR(ncid, varid, time_in)
+    ntim = SIZE(time_in)
+
+    !--- BUILD EDGES OF PRESSURE INTERVALS: HALFWAY IN LOGARITHMS
+    ALLOCATE(press_in_edg(nlev+1))
+    press_in_edg=[0.,SQRT(press_in_cen(1:nlev-1)*press_in_cen(2:nlev)),HUGE(0.)]
+
+    !--- CHECK RECORDS NUMBER AND DISPLAY CORRESPONDING INFORMATION
+    IF(daily.AND.ntim/=year_len) THEN
+      WRITE(msg,'(a,3(i4,a))')TRIM(sub)//': Expecting a daily ozone file with',&
+     &year_len,' records (year ',year_cur,') ; found ',ntim,' instead'
+      CALL abort_physic(sub, msg, 1)
+    ELSE IF(ALL([360,14]/=ntim)) THEN
+      WRITE(msg,'(a,i4,a)')TRIM(sub)//': Expecting an ozone file with 14 (mont'&
+     &//'hly case) or 360 (old style files) records ; found ',ntim,' instead'
+      CALL abort_physic(sub, msg, 1)
+    ELSE
+      IF(daily) THEN
+         WRITE(msg,'(a,2(i4,a))')'daily file (',ntim,' days in ',year_cur,')'
+       ELSE IF(ntim==14) THEN
+         msg='14 records monthly file'
+       ELSE
+         msg='360 records files (old convention)'
+       END IF
+      WRITE(lunout,*)TRIM(sub)//': Using a '//TRIM(msg)
+    END IF
+
+    !--- MESSAGE ABOUT OPTIONAL STRETCHING FOR TROPOPAUSES MATCHING
+    IF(adjust) THEN
+      WRITE(lunout,*)TRIM(sub)//': Adjusting O3 field to match gcm tropopause.'
+    ELSE
+      WRITE(lunout,*)TRIM(sub)//': Interpolating O3 field directly on gcm levels.'
+    END IF
+
+  END IF
+  CALL bcast_mpi(nlev)
+  IF(.NOT.is_mpi_root) ALLOCATE(press_in_cen(nlev  )); CALL bcast_mpi(press_in_cen)
+  IF(.NOT.is_mpi_root) ALLOCATE(press_in_edg(nlev+1)); CALL bcast_mpi(press_in_edg)
+  CALL bcast_mpi(ntim)
+  IF(.NOT.is_mpi_root) ALLOCATE(time_in(ntim));        CALL bcast_mpi(time_in)
+
+END SUBROUTINE open_climoz
+!
+!-------------------------------------------------------------------------------
+
+END MODULE open_climoz_m
Index: DZ6/trunk/libf/phylmd/orbite.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/orbite.F90	(revision 5267)
+++ 	(revision )
@@ -1,294 +1,0 @@
-
-! $Header$
-
-! ======================================================================
-SUBROUTINE orbite(xjour, longi, dist)
-  IMPLICIT NONE
-  ! ======================================================================
-  ! Auteur(s): Z.X. Li (LMD/CNRS) (adapte du GCM du LMD) date: 19930818
-  ! Objet: pour un jour donne, calculer la longitude vraie de la terre
-  ! (par rapport au point vernal-21 mars) dans son orbite solaire
-  ! calculer aussi la distance terre-soleil (unite astronomique)
-  ! ======================================================================
-  ! Arguments:
-  ! xjour--INPUT--R- jour de l'annee a compter du 1er janvier
-  ! longi--OUTPUT-R- longitude vraie en degres par rapport au point
-  ! vernal (21 mars) en degres
-  ! dist---OUTPUT-R- distance terre-soleil (par rapport a la moyenne)
-  REAL xjour, longi, dist
-  ! ======================================================================
-  include "YOMCST.h"
-
-  ! -- Variables dynamiques locales
-  REAL pir, xl, xllp, xee, xse, xlam, dlamm, anm, ranm, anv, ranv
-
-  pir = 4.0*atan(1.0)/180.0
-  xl = r_peri + 180.0
-  xllp = xl*pir
-  xee = r_ecc*r_ecc
-  xse = sqrt(1.0-xee)
-  xlam = (r_ecc/2.0+r_ecc*xee/8.0)*(1.0+xse)*sin(xllp) - &
-    xee/4.0*(0.5+xse)*sin(2.0*xllp) + r_ecc*xee/8.0*(1.0/3.0+xse)*sin(3.0* &
-    xllp)
-  xlam = 2.0*xlam/pir
-  dlamm = xlam + (xjour-81.0)
-  anm = dlamm - xl
-  ranm = anm*pir
-  xee = xee*r_ecc
-  ranv = ranm + (2.0*r_ecc-xee/4.0)*sin(ranm) + 5.0/4.0*r_ecc*r_ecc*sin(2.0* &
-    ranm) + 13.0/12.0*xee*sin(3.0*ranm)
-
-  anv = ranv/pir
-  longi = anv + xl
-
-  dist = (1-r_ecc*r_ecc)/(1+r_ecc*cos(pir*(longi-(r_peri+180.0))))
-  RETURN
-END SUBROUTINE orbite
-! ======================================================================
-SUBROUTINE angle(longi, lati, frac, muzero)
-  USE dimphy
-  IMPLICIT NONE
-  ! ======================================================================
-  ! Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818
-  ! Objet: Calculer la duree d'ensoleillement pour un jour et la hauteur
-  ! du soleil (cosinus de l'angle zinithal) moyenne sur la journee
-  ! ======================================================================
-  ! Arguments:
-  ! longi----INPUT-R- la longitude vraie de la terre dans son plan
-  ! solaire a partir de l'equinoxe de printemps (degre)
-  ! lati-----INPUT-R- la latitude d'un point sur la terre (degre)
-  ! frac-----OUTPUT-R la duree d'ensoleillement dans la journee divisee
-  ! par 24 heures (unite en fraction de 0 a 1)
-  ! muzero---OUTPUT-R la moyenne du cosinus de l'angle zinithal sur
-  ! la journee (0 a 1)
-  ! ======================================================================
-  REAL longi
-  REAL lati(klon), frac(klon), muzero(klon)
-  include "YOMCST.h"
-  REAL lat, omega, lon_sun, lat_sun
-  REAL pi_local, incl
-  INTEGER i
-
-  pi_local = 4.0*atan(1.0)
-  incl = r_incl*pi_local/180.
-
-  lon_sun = longi*pi_local/180.0
-  lat_sun = asin(sin(lon_sun)*sin(incl))
-
-  DO i = 1, klon
-    lat = lati(i)*pi_local/180.0
-
-    IF (lat>=(pi_local/2.+lat_sun) .OR. lat<=(-pi_local/2.+lat_sun)) THEN
-      omega = 0.0 ! nuit polaire
-    ELSE IF (lat>=(pi_local/2.-lat_sun) .OR. lat<=(-pi_local/2.-lat_sun)) &
-        THEN
-      omega = pi_local ! journee polaire
-    ELSE
-      omega = -tan(lat)*tan(lat_sun)
-      omega = acos(omega)
-    END IF
-
-    frac(i) = omega/pi_local
-
-    IF (omega>0.0) THEN
-      muzero(i) = sin(lat)*sin(lat_sun) + cos(lat)*cos(lat_sun)*sin(omega)/ &
-        omega
-    ELSE
-      muzero(i) = 0.0
-    END IF
-  END DO
-
-  RETURN
-END SUBROUTINE angle
-! ====================================================================
-SUBROUTINE zenang(longi, gmtime, pdtrad1, pdtrad2, lat, long, pmu0, frac)
-  USE dimphy
-  IMPLICIT NONE
-  ! =============================================================
-  ! Auteur : O. Boucher (LMD/CNRS)
-  ! d'apres les routines zenith et angle de Z.X. Li
-  ! Objet  : calculer les valeurs moyennes du cos de l'angle zenithal
-  ! et l'ensoleillement moyen entre gmtime1 et gmtime2
-  ! connaissant la declinaison, la latitude et la longitude.
-  ! Rque   : Different de la routine angle en ce sens que zenang
-  ! fournit des moyennes de pmu0 et non des valeurs
-  ! instantanees, du coup frac prend toutes les valeurs
-  ! entre 0 et 1. La routine integre entre gmtime+pdtrad1 et 
-  ! gmtime+pdtrad2 avec pdtrad1 et pdtrad2 exprimes en secondes.
-  ! Date   : premiere version le 13 decembre 1994
-  ! revu pour  GCM  le 30 septembre 1996
-  ! revu le 3 septembre 2015 pour les bornes de l'integrale
-  ! ===============================================================
-  ! longi : la longitude vraie de la terre dans son plan
-  ! solaire a partir de l'equinoxe de printemps (degre)
-  ! gmtime : temps universel en fraction de jour
-  ! pdtrad1 : borne inferieure du pas de temps du rayonnement (secondes)
-  ! pdtrad2 : borne inferieure du pas de temps du rayonnement (secondes)
-  ! pdtrad2-pdtrad1 correspond a pdtrad, le pas de temps du rayonnement (secondes)
-  ! lat------INPUT : latitude en degres
-  ! long-----INPUT : longitude en degres
-  ! pmu0-----OUTPUT: angle zenithal moyen entre gmtime+pdtrad1 et gmtime+pdtrad2
-  ! frac-----OUTPUT: ensoleillement moyen entre gmtime+pdtrad1 et gmtime+pdtrad2
-  ! ================================================================
-  include "YOMCST.h"
-  ! ================================================================
-  REAL, INTENT (IN) :: longi, gmtime, pdtrad1, pdtrad2
-  REAL lat(klon), long(klon), pmu0(klon), frac(klon)
-  ! ================================================================
-  INTEGER i
-  REAL gmtime1, gmtime2
-  REAL pi_local, deux_pi_local, incl
-  REAL omega1, omega2, omega
-  ! omega1, omega2 : temps 1 et 2 exprime en radian avec 0 a midi.
-  ! omega : heure en radian du coucher de soleil
-  ! -omega est donc l'heure en radian de lever du soleil
-  REAL omegadeb, omegafin
-  REAL zfrac1, zfrac2, z1_mu, z2_mu
-  REAL lat_sun ! declinaison en radian
-  REAL lon_sun ! longitude solaire en radian
-  REAL latr    ! latitude du pt de grille en radian
-  ! ================================================================
-
-  pi_local = 4.0*atan(1.0)
-  deux_pi_local = 2.0*pi_local
-  incl = r_incl*pi_local/180.
-
-  lon_sun = longi*pi_local/180.0
-  lat_sun = asin(sin(lon_sun)*sin(incl))
-
-  gmtime1 = gmtime*86400. + pdtrad1
-  gmtime2 = gmtime*86400. + pdtrad2
-
-  DO i = 1, klon
-
-    latr = lat(i)*pi_local/180.
-
-    omega = 0.0 !--nuit polaire
-
-    IF (latr>=(pi_local/2.-lat_sun) .OR. latr<=(-pi_local/2.-lat_sun)) THEN
-      omega = pi_local ! journee polaire
-    END IF
-
-    IF (latr<(pi_local/2.+lat_sun) .AND. latr>(-pi_local/2.+lat_sun) .AND. &
-        latr<(pi_local/2.-lat_sun) .AND. latr>(-pi_local/2.-lat_sun)) THEN
-      omega = -tan(latr)*tan(lat_sun)
-      omega = acos(omega)
-    END IF
-
-    omega1 = gmtime1 + long(i)*86400.0/360.0
-    omega1 = omega1/86400.0*deux_pi_local
-    omega1 = mod(omega1+deux_pi_local, deux_pi_local)
-    omega1 = omega1 - pi_local
-
-    omega2 = gmtime2 + long(i)*86400.0/360.0
-    omega2 = omega2/86400.0*deux_pi_local
-    omega2 = mod(omega2+deux_pi_local, deux_pi_local)
-    omega2 = omega2 - pi_local
-
-    IF (omega1<=omega2) THEN !--on est dans la meme journee locale
-
-      IF (omega2<=-omega .OR. omega1>=omega .OR. omega<1E-5) THEN !--nuit
-        frac(i) = 0.0
-        pmu0(i) = 0.0
-      ELSE !--jour+nuit/jour
-        omegadeb = max(-omega, omega1)
-        omegafin = min(omega, omega2)
-        frac(i) = (omegafin-omegadeb)/(omega2-omega1)
-        pmu0(i) = sin(latr)*sin(lat_sun) + cos(latr)*cos(lat_sun)*(sin( &
-          omegafin)-sin(omegadeb))/(omegafin-omegadeb)
-      END IF
-
-    ELSE !---omega1 GT omega2 -- a cheval sur deux journees
-
-      ! -------------------entre omega1 et pi
-      IF (omega1>=omega) THEN !--nuit
-        zfrac1 = 0.0
-        z1_mu = 0.0
-      ELSE !--jour+nuit
-        omegadeb = max(-omega, omega1)
-        omegafin = omega
-        zfrac1 = omegafin - omegadeb
-        z1_mu = sin(latr)*sin(lat_sun) + cos(latr)*cos(lat_sun)*(sin(omegafin &
-          )-sin(omegadeb))/(omegafin-omegadeb)
-      END IF
-      ! ---------------------entre -pi et omega2
-      IF (omega2<=-omega) THEN !--nuit
-        zfrac2 = 0.0
-        z2_mu = 0.0
-      ELSE !--jour+nuit
-        omegadeb = -omega
-        omegafin = min(omega, omega2)
-        zfrac2 = omegafin - omegadeb
-        z2_mu = sin(latr)*sin(lat_sun) + cos(latr)*cos(lat_sun)*(sin(omegafin &
-          )-sin(omegadeb))/(omegafin-omegadeb)
-
-      END IF
-      ! -----------------------moyenne
-      frac(i) = (zfrac1+zfrac2)/(omega2+deux_pi_local-omega1)
-      pmu0(i) = (zfrac1*z1_mu+zfrac2*z2_mu)/max(zfrac1+zfrac2, 1.E-10)
-
-    END IF !---comparaison omega1 et omega2
-
-  END DO
-
-END SUBROUTINE zenang
-! ===================================================================
-SUBROUTINE zenith(longi, gmtime, lat, long, pmu0, fract)
-  USE dimphy
-  IMPLICIT NONE
-
-  ! Auteur(s): Z.X. Li (LMD/ENS)
-
-  ! Objet: calculer le cosinus de l'angle zenithal du soleil en
-  ! connaissant la declinaison du soleil, la latitude et la
-  ! longitude du point sur la terre, et le temps universel
-
-  ! Arguments d'entree:
-  ! longi  : declinaison du soleil (en degres)
-  ! gmtime : temps universel en second qui varie entre 0 et 86400
-  ! lat    : latitude en degres
-  ! long   : longitude en degres
-  ! Arguments de sortie:
-  ! pmu0   : cosinus de l'angle zenithal
-
-  ! ====================================================================
-  include "YOMCST.h"
-  ! ====================================================================
-  REAL longi, gmtime
-  REAL lat(klon), long(klon), pmu0(klon), fract(klon)
-  ! =====================================================================
-  INTEGER n
-  REAL zpi, zpir, omega, zgmtime
-  REAL incl, lat_sun, lon_sun
-  ! ----------------------------------------------------------------------
-  zpi = 4.0*atan(1.0)
-  zpir = zpi/180.0
-  zgmtime = gmtime*86400.
-
-  incl = r_incl*zpir
-
-  lon_sun = longi*zpir
-  lat_sun = asin(sin(lon_sun)*sin(incl))
-
-  ! --initialisation a la nuit
-
-  DO n = 1, klon
-    pmu0(n) = 0.
-    fract(n) = 0.0
-  END DO
-
-  ! 1 degre en longitude = 240 secondes en temps
-
-  DO n = 1, klon
-    omega = zgmtime + long(n)*86400.0/360.0
-    omega = omega/86400.0*2.0*zpi
-    omega = mod(omega+2.0*zpi, 2.0*zpi)
-    omega = omega - zpi
-    pmu0(n) = sin(lat(n)*zpir)*sin(lat_sun) + cos(lat(n)*zpir)*cos(lat_sun)* &
-      cos(omega)
-    pmu0(n) = max(pmu0(n), 0.0)
-    IF (pmu0(n)>1.E-6) fract(n) = 1.0
-  END DO
-
-  RETURN
-END SUBROUTINE zenith
Index: /LMDZ6/trunk/libf/phylmd/orbite.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/orbite.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/orbite.f90	(revision 5268)
@@ -0,0 +1,294 @@
+
+! $Header$
+
+! ======================================================================
+SUBROUTINE orbite(xjour, longi, dist)
+  IMPLICIT NONE
+  ! ======================================================================
+  ! Auteur(s): Z.X. Li (LMD/CNRS) (adapte du GCM du LMD) date: 19930818
+  ! Objet: pour un jour donne, calculer la longitude vraie de la terre
+  ! (par rapport au point vernal-21 mars) dans son orbite solaire
+  ! calculer aussi la distance terre-soleil (unite astronomique)
+  ! ======================================================================
+  ! Arguments:
+  ! xjour--INPUT--R- jour de l'annee a compter du 1er janvier
+  ! longi--OUTPUT-R- longitude vraie en degres par rapport au point
+  ! vernal (21 mars) en degres
+  ! dist---OUTPUT-R- distance terre-soleil (par rapport a la moyenne)
+  REAL xjour, longi, dist
+  ! ======================================================================
+  include "YOMCST.h"
+
+  ! -- Variables dynamiques locales
+  REAL pir, xl, xllp, xee, xse, xlam, dlamm, anm, ranm, anv, ranv
+
+  pir = 4.0*atan(1.0)/180.0
+  xl = r_peri + 180.0
+  xllp = xl*pir
+  xee = r_ecc*r_ecc
+  xse = sqrt(1.0-xee)
+  xlam = (r_ecc/2.0+r_ecc*xee/8.0)*(1.0+xse)*sin(xllp) - &
+    xee/4.0*(0.5+xse)*sin(2.0*xllp) + r_ecc*xee/8.0*(1.0/3.0+xse)*sin(3.0* &
+    xllp)
+  xlam = 2.0*xlam/pir
+  dlamm = xlam + (xjour-81.0)
+  anm = dlamm - xl
+  ranm = anm*pir
+  xee = xee*r_ecc
+  ranv = ranm + (2.0*r_ecc-xee/4.0)*sin(ranm) + 5.0/4.0*r_ecc*r_ecc*sin(2.0* &
+    ranm) + 13.0/12.0*xee*sin(3.0*ranm)
+
+  anv = ranv/pir
+  longi = anv + xl
+
+  dist = (1-r_ecc*r_ecc)/(1+r_ecc*cos(pir*(longi-(r_peri+180.0))))
+  RETURN
+END SUBROUTINE orbite
+! ======================================================================
+SUBROUTINE angle(longi, lati, frac, muzero)
+  USE dimphy
+  IMPLICIT NONE
+  ! ======================================================================
+  ! Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818
+  ! Objet: Calculer la duree d'ensoleillement pour un jour et la hauteur
+  ! du soleil (cosinus de l'angle zinithal) moyenne sur la journee
+  ! ======================================================================
+  ! Arguments:
+  ! longi----INPUT-R- la longitude vraie de la terre dans son plan
+  ! solaire a partir de l'equinoxe de printemps (degre)
+  ! lati-----INPUT-R- la latitude d'un point sur la terre (degre)
+  ! frac-----OUTPUT-R la duree d'ensoleillement dans la journee divisee
+  ! par 24 heures (unite en fraction de 0 a 1)
+  ! muzero---OUTPUT-R la moyenne du cosinus de l'angle zinithal sur
+  ! la journee (0 a 1)
+  ! ======================================================================
+  REAL longi
+  REAL lati(klon), frac(klon), muzero(klon)
+  include "YOMCST.h"
+  REAL lat, omega, lon_sun, lat_sun
+  REAL pi_local, incl
+  INTEGER i
+
+  pi_local = 4.0*atan(1.0)
+  incl = r_incl*pi_local/180.
+
+  lon_sun = longi*pi_local/180.0
+  lat_sun = asin(sin(lon_sun)*sin(incl))
+
+  DO i = 1, klon
+    lat = lati(i)*pi_local/180.0
+
+    IF (lat>=(pi_local/2.+lat_sun) .OR. lat<=(-pi_local/2.+lat_sun)) THEN
+      omega = 0.0 ! nuit polaire
+    ELSE IF (lat>=(pi_local/2.-lat_sun) .OR. lat<=(-pi_local/2.-lat_sun)) &
+        THEN
+      omega = pi_local ! journee polaire
+    ELSE
+      omega = -tan(lat)*tan(lat_sun)
+      omega = acos(omega)
+    END IF
+
+    frac(i) = omega/pi_local
+
+    IF (omega>0.0) THEN
+      muzero(i) = sin(lat)*sin(lat_sun) + cos(lat)*cos(lat_sun)*sin(omega)/ &
+        omega
+    ELSE
+      muzero(i) = 0.0
+    END IF
+  END DO
+
+  RETURN
+END SUBROUTINE angle
+! ====================================================================
+SUBROUTINE zenang(longi, gmtime, pdtrad1, pdtrad2, lat, long, pmu0, frac)
+  USE dimphy
+  IMPLICIT NONE
+  ! =============================================================
+  ! Auteur : O. Boucher (LMD/CNRS)
+  ! d'apres les routines zenith et angle de Z.X. Li
+  ! Objet  : calculer les valeurs moyennes du cos de l'angle zenithal
+  ! et l'ensoleillement moyen entre gmtime1 et gmtime2
+  ! connaissant la declinaison, la latitude et la longitude.
+  ! Rque   : Different de la routine angle en ce sens que zenang
+  ! fournit des moyennes de pmu0 et non des valeurs
+  ! instantanees, du coup frac prend toutes les valeurs
+  ! entre 0 et 1. La routine integre entre gmtime+pdtrad1 et 
+  ! gmtime+pdtrad2 avec pdtrad1 et pdtrad2 exprimes en secondes.
+  ! Date   : premiere version le 13 decembre 1994
+  ! revu pour  GCM  le 30 septembre 1996
+  ! revu le 3 septembre 2015 pour les bornes de l'integrale
+  ! ===============================================================
+  ! longi : la longitude vraie de la terre dans son plan
+  ! solaire a partir de l'equinoxe de printemps (degre)
+  ! gmtime : temps universel en fraction de jour
+  ! pdtrad1 : borne inferieure du pas de temps du rayonnement (secondes)
+  ! pdtrad2 : borne inferieure du pas de temps du rayonnement (secondes)
+  ! pdtrad2-pdtrad1 correspond a pdtrad, le pas de temps du rayonnement (secondes)
+  ! lat------INPUT : latitude en degres
+  ! long-----INPUT : longitude en degres
+  ! pmu0-----OUTPUT: angle zenithal moyen entre gmtime+pdtrad1 et gmtime+pdtrad2
+  ! frac-----OUTPUT: ensoleillement moyen entre gmtime+pdtrad1 et gmtime+pdtrad2
+  ! ================================================================
+  include "YOMCST.h"
+  ! ================================================================
+  REAL, INTENT (IN) :: longi, gmtime, pdtrad1, pdtrad2
+  REAL lat(klon), long(klon), pmu0(klon), frac(klon)
+  ! ================================================================
+  INTEGER i
+  REAL gmtime1, gmtime2
+  REAL pi_local, deux_pi_local, incl
+  REAL omega1, omega2, omega
+  ! omega1, omega2 : temps 1 et 2 exprime en radian avec 0 a midi.
+  ! omega : heure en radian du coucher de soleil
+  ! -omega est donc l'heure en radian de lever du soleil
+  REAL omegadeb, omegafin
+  REAL zfrac1, zfrac2, z1_mu, z2_mu
+  REAL lat_sun ! declinaison en radian
+  REAL lon_sun ! longitude solaire en radian
+  REAL latr    ! latitude du pt de grille en radian
+  ! ================================================================
+
+  pi_local = 4.0*atan(1.0)
+  deux_pi_local = 2.0*pi_local
+  incl = r_incl*pi_local/180.
+
+  lon_sun = longi*pi_local/180.0
+  lat_sun = asin(sin(lon_sun)*sin(incl))
+
+  gmtime1 = gmtime*86400. + pdtrad1
+  gmtime2 = gmtime*86400. + pdtrad2
+
+  DO i = 1, klon
+
+    latr = lat(i)*pi_local/180.
+
+    omega = 0.0 !--nuit polaire
+
+    IF (latr>=(pi_local/2.-lat_sun) .OR. latr<=(-pi_local/2.-lat_sun)) THEN
+      omega = pi_local ! journee polaire
+    END IF
+
+    IF (latr<(pi_local/2.+lat_sun) .AND. latr>(-pi_local/2.+lat_sun) .AND. &
+        latr<(pi_local/2.-lat_sun) .AND. latr>(-pi_local/2.-lat_sun)) THEN
+      omega = -tan(latr)*tan(lat_sun)
+      omega = acos(omega)
+    END IF
+
+    omega1 = gmtime1 + long(i)*86400.0/360.0
+    omega1 = omega1/86400.0*deux_pi_local
+    omega1 = mod(omega1+deux_pi_local, deux_pi_local)
+    omega1 = omega1 - pi_local
+
+    omega2 = gmtime2 + long(i)*86400.0/360.0
+    omega2 = omega2/86400.0*deux_pi_local
+    omega2 = mod(omega2+deux_pi_local, deux_pi_local)
+    omega2 = omega2 - pi_local
+
+    IF (omega1<=omega2) THEN !--on est dans la meme journee locale
+
+      IF (omega2<=-omega .OR. omega1>=omega .OR. omega<1E-5) THEN !--nuit
+        frac(i) = 0.0
+        pmu0(i) = 0.0
+      ELSE !--jour+nuit/jour
+        omegadeb = max(-omega, omega1)
+        omegafin = min(omega, omega2)
+        frac(i) = (omegafin-omegadeb)/(omega2-omega1)
+        pmu0(i) = sin(latr)*sin(lat_sun) + cos(latr)*cos(lat_sun)*(sin( &
+          omegafin)-sin(omegadeb))/(omegafin-omegadeb)
+      END IF
+
+    ELSE !---omega1 GT omega2 -- a cheval sur deux journees
+
+      ! -------------------entre omega1 et pi
+      IF (omega1>=omega) THEN !--nuit
+        zfrac1 = 0.0
+        z1_mu = 0.0
+      ELSE !--jour+nuit
+        omegadeb = max(-omega, omega1)
+        omegafin = omega
+        zfrac1 = omegafin - omegadeb
+        z1_mu = sin(latr)*sin(lat_sun) + cos(latr)*cos(lat_sun)*(sin(omegafin &
+          )-sin(omegadeb))/(omegafin-omegadeb)
+      END IF
+      ! ---------------------entre -pi et omega2
+      IF (omega2<=-omega) THEN !--nuit
+        zfrac2 = 0.0
+        z2_mu = 0.0
+      ELSE !--jour+nuit
+        omegadeb = -omega
+        omegafin = min(omega, omega2)
+        zfrac2 = omegafin - omegadeb
+        z2_mu = sin(latr)*sin(lat_sun) + cos(latr)*cos(lat_sun)*(sin(omegafin &
+          )-sin(omegadeb))/(omegafin-omegadeb)
+
+      END IF
+      ! -----------------------moyenne
+      frac(i) = (zfrac1+zfrac2)/(omega2+deux_pi_local-omega1)
+      pmu0(i) = (zfrac1*z1_mu+zfrac2*z2_mu)/max(zfrac1+zfrac2, 1.E-10)
+
+    END IF !---comparaison omega1 et omega2
+
+  END DO
+
+END SUBROUTINE zenang
+! ===================================================================
+SUBROUTINE zenith(longi, gmtime, lat, long, pmu0, fract)
+  USE dimphy
+  IMPLICIT NONE
+
+  ! Auteur(s): Z.X. Li (LMD/ENS)
+
+  ! Objet: calculer le cosinus de l'angle zenithal du soleil en
+  ! connaissant la declinaison du soleil, la latitude et la
+  ! longitude du point sur la terre, et le temps universel
+
+  ! Arguments d'entree:
+  ! longi  : declinaison du soleil (en degres)
+  ! gmtime : temps universel en second qui varie entre 0 et 86400
+  ! lat    : latitude en degres
+  ! long   : longitude en degres
+  ! Arguments de sortie:
+  ! pmu0   : cosinus de l'angle zenithal
+
+  ! ====================================================================
+  include "YOMCST.h"
+  ! ====================================================================
+  REAL longi, gmtime
+  REAL lat(klon), long(klon), pmu0(klon), fract(klon)
+  ! =====================================================================
+  INTEGER n
+  REAL zpi, zpir, omega, zgmtime
+  REAL incl, lat_sun, lon_sun
+  ! ----------------------------------------------------------------------
+  zpi = 4.0*atan(1.0)
+  zpir = zpi/180.0
+  zgmtime = gmtime*86400.
+
+  incl = r_incl*zpir
+
+  lon_sun = longi*zpir
+  lat_sun = asin(sin(lon_sun)*sin(incl))
+
+  ! --initialisation a la nuit
+
+  DO n = 1, klon
+    pmu0(n) = 0.
+    fract(n) = 0.0
+  END DO
+
+  ! 1 degre en longitude = 240 secondes en temps
+
+  DO n = 1, klon
+    omega = zgmtime + long(n)*86400.0/360.0
+    omega = omega/86400.0*2.0*zpi
+    omega = mod(omega+2.0*zpi, 2.0*zpi)
+    omega = omega - zpi
+    pmu0(n) = sin(lat(n)*zpir)*sin(lat_sun) + cos(lat(n)*zpir)*cos(lat_sun)* &
+      cos(omega)
+    pmu0(n) = max(pmu0(n), 0.0)
+    IF (pmu0(n)>1.E-6) fract(n) = 1.0
+  END DO
+
+  RETURN
+END SUBROUTINE zenith
Index: DZ6/trunk/libf/phylmd/orografi.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/orografi.F90	(revision 5267)
+++ 	(revision )
@@ -1,1681 +1,0 @@
-
-! $Id$
-
-SUBROUTINE drag_noro(nlon, nlev, dtime, paprs, pplay, pmea, pstd, psig, pgam, &
-    pthe, ppic, pval, kgwd, kdx, ktest, t, u, v, pulow, pvlow, pustr, pvstr, &
-    d_t, d_u, d_v)
-
-  USE dimphy
-  IMPLICIT NONE
-  ! ======================================================================
-  ! Auteur(s): F.Lott (LMD/CNRS) date: 19950201
-  ! Objet: Frottement de la montagne Interface
-  ! ======================================================================
-  ! Arguments:
-  ! dtime---input-R- pas d'integration (s)
-  ! paprs---input-R-pression pour chaque inter-couche (en Pa)
-  ! pplay---input-R-pression pour le mileu de chaque couche (en Pa)
-  ! t-------input-R-temperature (K)
-  ! u-------input-R-vitesse horizontale (m/s)
-  ! v-------input-R-vitesse horizontale (m/s)
-
-  ! d_t-----output-R-increment de la temperature
-  ! d_u-----output-R-increment de la vitesse u
-  ! d_v-----output-R-increment de la vitesse v
-  ! ======================================================================
-  include "YOMCST.h"
-
-  ! ARGUMENTS
-
-  INTEGER nlon, nlev
-  REAL dtime
-  REAL paprs(klon, klev+1)
-  REAL pplay(klon, klev)
-  REAL pmea(nlon), pstd(nlon), psig(nlon), pgam(nlon), pthe(nlon)
-  REAL ppic(nlon), pval(nlon)
-  REAL pulow(nlon), pvlow(nlon), pustr(nlon), pvstr(nlon)
-  REAL t(nlon, nlev), u(nlon, nlev), v(nlon, nlev)
-  REAL d_t(nlon, nlev), d_u(nlon, nlev), d_v(nlon, nlev)
-
-  INTEGER i, k, kgwd, kdx(nlon), ktest(nlon)
-
-  ! Variables locales:
-
-  REAL zgeom(klon, klev)
-  REAL pdtdt(klon, klev), pdudt(klon, klev), pdvdt(klon, klev)
-  REAL pt(klon, klev), pu(klon, klev), pv(klon, klev)
-  REAL papmf(klon, klev), papmh(klon, klev+1)
-
-  ! initialiser les variables de sortie (pour securite)
-
-  DO i = 1, klon
-    pulow(i) = 0.0
-    pvlow(i) = 0.0
-    pustr(i) = 0.0
-    pvstr(i) = 0.0
-  END DO
-  DO k = 1, klev
-    DO i = 1, klon
-      d_t(i, k) = 0.0
-      d_u(i, k) = 0.0
-      d_v(i, k) = 0.0
-      pdudt(i, k) = 0.0
-      pdvdt(i, k) = 0.0
-      pdtdt(i, k) = 0.0
-    END DO
-  END DO
-
-  ! preparer les variables d'entree (attention: l'ordre des niveaux
-  ! verticaux augmente du haut vers le bas)
-
-  DO k = 1, klev
-    DO i = 1, klon
-      pt(i, k) = t(i, klev-k+1)
-      pu(i, k) = u(i, klev-k+1)
-      pv(i, k) = v(i, klev-k+1)
-      papmf(i, k) = pplay(i, klev-k+1)
-    END DO
-  END DO
-  DO k = 1, klev + 1
-    DO i = 1, klon
-      papmh(i, k) = paprs(i, klev-k+2)
-    END DO
-  END DO
-  DO i = 1, klon
-    zgeom(i, klev) = rd*pt(i, klev)*log(papmh(i,klev+1)/papmf(i,klev))
-  END DO
-  DO k = klev - 1, 1, -1
-    DO i = 1, klon
-      zgeom(i, k) = zgeom(i, k+1) + rd*(pt(i,k)+pt(i,k+1))/2.0*log(papmf(i,k+ &
-        1)/papmf(i,k))
-    END DO
-  END DO
-
-  ! appeler la routine principale
-
-  CALL orodrag(klon, klev, kgwd, kdx, ktest, dtime, papmh, papmf, zgeom, pt, &
-    pu, pv, pmea, pstd, psig, pgam, pthe, ppic, pval, pulow, pvlow, pdudt, &
-    pdvdt, pdtdt)
-
-  DO k = 1, klev
-    DO i = 1, klon
-      d_u(i, klev+1-k) = dtime*pdudt(i, k)
-      d_v(i, klev+1-k) = dtime*pdvdt(i, k)
-      d_t(i, klev+1-k) = dtime*pdtdt(i, k)
-      pustr(i) = pustr(i) &        ! IM BUG  .
-                                   ! +rg*pdudt(i,k)*(papmh(i,k+1)-papmh(i,k))
-        +pdudt(i, k)*(papmh(i,k+1)-papmh(i,k))/rg
-      pvstr(i) = pvstr(i) &        ! IM BUG  .
-                                   ! +rg*pdvdt(i,k)*(papmh(i,k+1)-papmh(i,k))
-        +pdvdt(i, k)*(papmh(i,k+1)-papmh(i,k))/rg
-    END DO
-  END DO
-
-  RETURN
-END SUBROUTINE drag_noro
-SUBROUTINE orodrag(nlon, nlev, kgwd, kdx, ktest, ptsphy, paphm1, papm1, &
-    pgeom1, ptm1, pum1, pvm1, pmea, pstd, psig, pgamma, ptheta, ppic, pval &
-  ! outputs
-    , pulow, pvlow, pvom, pvol, pte)
-
-  USE dimphy
-  IMPLICIT NONE
-
-
-
-  ! **** *gwdrag* - does the gravity wave parametrization.
-
-  ! purpose.
-  ! --------
-
-  ! this routine computes the physical tendencies of the
-  ! prognostic variables u,v  and t due to  vertical transports by
-  ! subgridscale orographically excited gravity waves
-
-  ! **   interface.
-  ! ----------
-  ! called from *callpar*.
-
-  ! the routine takes its input from the long-term storage:
-  ! u,v,t and p at t-1.
-
-  ! explicit arguments :
-  ! --------------------
-  ! ==== inputs ===
-  ! ==== outputs ===
-
-  ! implicit arguments :   none
-  ! --------------------
-
-  ! implicit logical (l)
-
-  ! method.
-  ! -------
-
-  ! externals.
-  ! ----------
-  INTEGER ismin, ismax
-  EXTERNAL ismin, ismax
-
-  ! reference.
-  ! ----------
-
-  ! author.
-  ! -------
-  ! m.miller + b.ritter   e.c.m.w.f.     15/06/86.
-
-  ! f.lott + m. miller    e.c.m.w.f.     22/11/94
-  ! -----------------------------------------------------------------------
-
-
-  include "YOMCST.h"
-  include "YOEGWD.h"
-  ! -----------------------------------------------------------------------
-
-  ! *       0.1   arguments
-  ! ---------
-
-
-  ! ym      integer nlon, nlev, klevm1
-  INTEGER nlon, nlev
-  INTEGER kgwd, jl, ilevp1, jk, ji
-  REAL zdelp, ztemp, zforc, ztend
-  REAL rover, zb, zc, zconb, zabsv
-  REAL zzd1, ratio, zbet, zust, zvst, zdis
-  REAL pte(nlon, nlev), pvol(nlon, nlev), pvom(nlon, nlev), pulow(klon), &
-    pvlow(klon)
-  REAL pum1(nlon, nlev), pvm1(nlon, nlev), ptm1(nlon, nlev), pmea(nlon), &
-    pstd(nlon), psig(nlon), pgamma(nlon), ptheta(nlon), ppic(nlon), &
-    pval(nlon), pgeom1(nlon, nlev), papm1(nlon, nlev), paphm1(nlon, nlev+1)
-
-  INTEGER kdx(nlon), ktest(nlon)
-  ! -----------------------------------------------------------------------
-
-  ! *       0.2   local arrays
-  ! ------------
-  INTEGER isect(klon), icrit(klon), ikcrith(klon), ikenvh(klon), iknu(klon), &
-    iknu2(klon), ikcrit(klon), ikhlim(klon)
-
-  REAL ztau(klon, klev+1), ztauf(klon, klev+1), zstab(klon, klev+1), &
-    zvph(klon, klev+1), zrho(klon, klev+1), zri(klon, klev+1), &
-    zpsi(klon, klev+1), zzdep(klon, klev)
-  REAL zdudt(klon), zdvdt(klon), zdtdt(klon), zdedt(klon), zvidis(klon), &
-    znu(klon), zd1(klon), zd2(klon), zdmod(klon)
-  REAL ztmst, ptsphy, zrtmst
-
-  ! ------------------------------------------------------------------
-
-  ! *         1.    initialization
-  ! --------------
-
-
-  ! ------------------------------------------------------------------
-
-  ! *         1.1   computational constants
-  ! -----------------------
-
-
-  ! ztmst=twodt
-  ! if(nstep.eq.nstart) ztmst=0.5*twodt
-  ! ym      klevm1=klev-1
-  ztmst = ptsphy
-  zrtmst = 1./ztmst
-
-  ! ------------------------------------------------------------------
-
-  ! *         1.3   check whether row contains point for printing
-  ! ---------------------------------------------
-
-
-  ! ------------------------------------------------------------------
-
-  ! *         2.     precompute basic state variables.
-  ! *                ---------- ----- ----- ----------
-  ! *                define low level wind, project winds in plane of
-  ! *                low level wind, determine sector in which to take
-  ! *                the variance and set indicator for critical levels.
-
-
-
-
-  CALL orosetup(nlon, ktest, ikcrit, ikcrith, icrit, ikenvh, iknu, iknu2, &
-    paphm1, papm1, pum1, pvm1, ptm1, pgeom1, pstd, zrho, zri, zstab, ztau, &
-    zvph, zpsi, zzdep, pulow, pvlow, ptheta, pgamma, pmea, ppic, pval, znu, &
-    zd1, zd2, zdmod)
-
-  ! ***********************************************************
-
-
-  ! *         3.      compute low level stresses using subcritical and
-  ! *                 supercritical forms.computes anisotropy coefficient
-  ! *                 as measure of orographic twodimensionality.
-
-
-  CALL gwstress(nlon, nlev, ktest, icrit, ikenvh, iknu, zrho, zstab, zvph, &
-    pstd, psig, pmea, ppic, ztau, pgeom1, zdmod)
-
-  ! *         4.      compute stress profile.
-  ! *                 ------- ------ --------
-
-
-
-  CALL gwprofil(nlon, nlev, kgwd, kdx, ktest, ikcrith, icrit, paphm1, zrho, &
-    zstab, zvph, zri, ztau, zdmod, psig, pstd)
-
-  ! *         5.      compute tendencies.
-  ! *                 -------------------
-
-
-  ! explicit solution at all levels for the gravity wave
-  ! implicit solution for the blocked levels
-
-  DO jl = kidia, kfdia
-    zvidis(jl) = 0.0
-    zdudt(jl) = 0.0
-    zdvdt(jl) = 0.0
-    zdtdt(jl) = 0.0
-  END DO
-
-  ilevp1 = klev + 1
-
-
-  DO jk = 1, klev
-
-
-    ! do 523 jl=1,kgwd
-    ! ji=kdx(jl)
-    ! Modif vectorisation 02/04/2004
-    DO ji = kidia, kfdia
-      IF (ktest(ji)==1) THEN
-
-        zdelp = paphm1(ji, jk+1) - paphm1(ji, jk)
-        ztemp = -rg*(ztau(ji,jk+1)-ztau(ji,jk))/(zvph(ji,ilevp1)*zdelp)
-        zdudt(ji) = (pulow(ji)*zd1(ji)-pvlow(ji)*zd2(ji))*ztemp/zdmod(ji)
-        zdvdt(ji) = (pvlow(ji)*zd1(ji)+pulow(ji)*zd2(ji))*ztemp/zdmod(ji)
-
-        ! controle des overshoots:
-
-        zforc = sqrt(zdudt(ji)**2+zdvdt(ji)**2) + 1.E-12
-        ztend = sqrt(pum1(ji,jk)**2+pvm1(ji,jk)**2)/ztmst + 1.E-12
-        rover = 0.25
-        IF (zforc>=rover*ztend) THEN
-          zdudt(ji) = rover*ztend/zforc*zdudt(ji)
-          zdvdt(ji) = rover*ztend/zforc*zdvdt(ji)
-        END IF
-
-        ! fin du controle des overshoots
-
-        IF (jk>=ikenvh(ji)) THEN
-          zb = 1.0 - 0.18*pgamma(ji) - 0.04*pgamma(ji)**2
-          zc = 0.48*pgamma(ji) + 0.3*pgamma(ji)**2
-          zconb = 2.*ztmst*gkwake*psig(ji)/(4.*pstd(ji))
-          zabsv = sqrt(pum1(ji,jk)**2+pvm1(ji,jk)**2)/2.
-          zzd1 = zb*cos(zpsi(ji,jk))**2 + zc*sin(zpsi(ji,jk))**2
-          ratio = (cos(zpsi(ji,jk))**2+pgamma(ji)*sin(zpsi(ji, &
-            jk))**2)/(pgamma(ji)*cos(zpsi(ji,jk))**2+sin(zpsi(ji,jk))**2)
-          zbet = max(0., 2.-1./ratio)*zconb*zzdep(ji, jk)*zzd1*zabsv
-
-          ! simplement oppose au vent
-
-          zdudt(ji) = -pum1(ji, jk)/ztmst
-          zdvdt(ji) = -pvm1(ji, jk)/ztmst
-
-          ! projection dans la direction de l'axe principal de l'orographie
-          ! mod     zdudt(ji)=-(pum1(ji,jk)*cos(ptheta(ji)*rpi/180.)
-          ! mod *              +pvm1(ji,jk)*sin(ptheta(ji)*rpi/180.))
-          ! mod *              *cos(ptheta(ji)*rpi/180.)/ztmst
-          ! mod     zdvdt(ji)=-(pum1(ji,jk)*cos(ptheta(ji)*rpi/180.)
-          ! mod *              +pvm1(ji,jk)*sin(ptheta(ji)*rpi/180.))
-          ! mod *              *sin(ptheta(ji)*rpi/180.)/ztmst
-          zdudt(ji) = zdudt(ji)*(zbet/(1.+zbet))
-          zdvdt(ji) = zdvdt(ji)*(zbet/(1.+zbet))
-        END IF
-        pvom(ji, jk) = zdudt(ji)
-        pvol(ji, jk) = zdvdt(ji)
-        zust = pum1(ji, jk) + ztmst*zdudt(ji)
-        zvst = pvm1(ji, jk) + ztmst*zdvdt(ji)
-        zdis = 0.5*(pum1(ji,jk)**2+pvm1(ji,jk)**2-zust**2-zvst**2)
-        zdedt(ji) = zdis/ztmst
-        zvidis(ji) = zvidis(ji) + zdis*zdelp
-        zdtdt(ji) = zdedt(ji)/rcpd
-        ! pte(ji,jk)=zdtdt(ji)
-
-        ! ENCORE UN TRUC POUR EVITER LES EXPLOSIONS
-
-        pte(ji, jk) = 0.0
-
-      END IF
-    END DO
-
-  END DO
-
-
-  RETURN
-END SUBROUTINE orodrag
-SUBROUTINE orosetup(nlon, ktest, kkcrit, kkcrith, kcrit, kkenvh, kknu, kknu2, &
-    paphm1, papm1, pum1, pvm1, ptm1, pgeom1, pstd, prho, pri, pstab, ptau, &
-    pvph, ppsi, pzdep, pulow, pvlow, ptheta, pgamma, pmea, ppic, pval, pnu, &
-    pd1, pd2, pdmod)
-
-  ! **** *gwsetup*
-
-  ! purpose.
-  ! --------
-
-  ! **   interface.
-  ! ----------
-  ! from *orodrag*
-
-  ! explicit arguments :
-  ! --------------------
-  ! ==== inputs ===
-  ! ==== outputs ===
-
-  ! implicit arguments :   none
-  ! --------------------
-
-  ! method.
-  ! -------
-
-
-  ! externals.
-  ! ----------
-
-
-  ! reference.
-  ! ----------
-
-  ! see ecmwf research department documentation of the "i.f.s."
-
-  ! author.
-  ! -------
-
-  ! modifications.
-  ! --------------
-  ! f.lott  for the new-gwdrag scheme november 1993
-
-  ! -----------------------------------------------------------------------
-  USE dimphy
-  IMPLICIT NONE
-
-
-  include "YOMCST.h"
-  include "YOEGWD.h"
-
-  ! -----------------------------------------------------------------------
-
-  ! *       0.1   arguments
-  ! ---------
-
-  INTEGER nlon
-  INTEGER jl, jk
-  REAL zdelp
-
-  INTEGER kkcrit(nlon), kkcrith(nlon), kcrit(nlon), ktest(nlon), kkenvh(nlon)
-
-
-  REAL paphm1(nlon, klev+1), papm1(nlon, klev), pum1(nlon, klev), &
-    pvm1(nlon, klev), ptm1(nlon, klev), pgeom1(nlon, klev), &
-    prho(nlon, klev+1), pri(nlon, klev+1), pstab(nlon, klev+1), &
-    ptau(nlon, klev+1), pvph(nlon, klev+1), ppsi(nlon, klev+1), &
-    pzdep(nlon, klev)
-  REAL pulow(nlon), pvlow(nlon), ptheta(nlon), pgamma(nlon), pnu(nlon), &
-    pd1(nlon), pd2(nlon), pdmod(nlon)
-  REAL pstd(nlon), pmea(nlon), ppic(nlon), pval(nlon)
-
-  ! -----------------------------------------------------------------------
-
-  ! *       0.2   local arrays
-  ! ------------
-
-
-  INTEGER ilevm1, ilevm2, ilevh
-  REAL zcons1, zcons2, zcons3, zhgeo
-  REAL zu, zphi, zvt1, zvt2, zst, zvar, zdwind, zwind
-  REAL zstabm, zstabp, zrhom, zrhop, alpha
-  REAL zggeenv, zggeom1, zgvar
-  LOGICAL lo
-  LOGICAL ll1(klon, klev+1)
-  INTEGER kknu(klon), kknu2(klon), kknub(klon), kknul(klon), kentp(klon), &
-    ncount(klon)
-
-  REAL zhcrit(klon, klev), zvpf(klon, klev), zdp(klon, klev)
-  REAL znorm(klon), zb(klon), zc(klon), zulow(klon), zvlow(klon), znup(klon), &
-    znum(klon)
-
-  ! ------------------------------------------------------------------
-
-  ! *         1.    initialization
-  ! --------------
-
-  ! print *,' entree gwsetup'
-
-  ! ------------------------------------------------------------------
-
-  ! *         1.1   computational constants
-  ! -----------------------
-
-
-  ilevm1 = klev - 1
-  ilevm2 = klev - 2
-  ilevh = klev/3
-
-  zcons1 = 1./rd
-  ! old  zcons2=g**2/cpd
-  zcons2 = rg**2/rcpd
-  ! old  zcons3=1.5*api
-  zcons3 = 1.5*rpi
-
-  ! ------------------------------------------------------------------
-
-  ! *         2.
-  ! --------------
-
-
-  ! ------------------------------------------------------------------
-
-  ! *         2.1     define low level wind, project winds in plane of
-  ! *                 low level wind, determine sector in which to take
-  ! *                 the variance and set indicator for critical levels.
-
-
-
-  DO jl = kidia, kfdia
-    kknu(jl) = klev
-    kknu2(jl) = klev
-    kknub(jl) = klev
-    kknul(jl) = klev
-    pgamma(jl) = max(pgamma(jl), gtsec)
-    ll1(jl, klev+1) = .FALSE.
-  END DO
-
-  ! Ajouter une initialisation (L. Li, le 23fev99):
-
-  DO jk = klev, ilevh, -1
-    DO jl = kidia, kfdia
-      ll1(jl, jk) = .FALSE.
-    END DO
-  END DO
-
-  ! *      define top of low level flow
-  ! ----------------------------
-  DO jk = klev, ilevh, -1
-    DO jl = kidia, kfdia
-      lo = (paphm1(jl,jk)/paphm1(jl,klev+1)) >= gsigcr
-      IF (lo) THEN
-        kkcrit(jl) = jk
-      END IF
-      zhcrit(jl, jk) = ppic(jl)
-      zhgeo = pgeom1(jl, jk)/rg
-      ll1(jl, jk) = (zhgeo>zhcrit(jl,jk))
-      IF (ll1(jl,jk) .NEQV. ll1(jl,jk+1)) THEN
-        kknu(jl) = jk
-      END IF
-      IF (.NOT. ll1(jl,ilevh)) kknu(jl) = ilevh
-    END DO
-  END DO
-  DO jk = klev, ilevh, -1
-    DO jl = kidia, kfdia
-      zhcrit(jl, jk) = ppic(jl) - pval(jl)
-      zhgeo = pgeom1(jl, jk)/rg
-      ll1(jl, jk) = (zhgeo>zhcrit(jl,jk))
-      IF (ll1(jl,jk) .NEQV. ll1(jl,jk+1)) THEN
-        kknu2(jl) = jk
-      END IF
-      IF (.NOT. ll1(jl,ilevh)) kknu2(jl) = ilevh
-    END DO
-  END DO
-  DO jk = klev, ilevh, -1
-    DO jl = kidia, kfdia
-      zhcrit(jl, jk) = amax1(ppic(jl)-pmea(jl), pmea(jl)-pval(jl))
-      zhgeo = pgeom1(jl, jk)/rg
-      ll1(jl, jk) = (zhgeo>zhcrit(jl,jk))
-      IF (ll1(jl,jk) .NEQV. ll1(jl,jk+1)) THEN
-        kknub(jl) = jk
-      END IF
-      IF (.NOT. ll1(jl,ilevh)) kknub(jl) = ilevh
-    END DO
-  END DO
-
-  DO jl = kidia, kfdia
-    kknu(jl) = min(kknu(jl), nktopg)
-    kknu2(jl) = min(kknu2(jl), nktopg)
-    kknub(jl) = min(kknub(jl), nktopg)
-    kknul(jl) = klev
-  END DO
-
-  ! c*     initialize various arrays
-
-  DO jl = kidia, kfdia
-    prho(jl, klev+1) = 0.0
-    pstab(jl, klev+1) = 0.0
-    pstab(jl, 1) = 0.0
-    pri(jl, klev+1) = 9999.0
-    ppsi(jl, klev+1) = 0.0
-    pri(jl, 1) = 0.0
-    pvph(jl, 1) = 0.0
-    pulow(jl) = 0.0
-    pvlow(jl) = 0.0
-    zulow(jl) = 0.0
-    zvlow(jl) = 0.0
-    kkcrith(jl) = klev
-    kkenvh(jl) = klev
-    kentp(jl) = klev
-    kcrit(jl) = 1
-    ncount(jl) = 0
-    ll1(jl, klev+1) = .FALSE.
-  END DO
-
-  ! *     define low-level flow
-  ! ---------------------
-
-  DO jk = klev, 2, -1
-    DO jl = kidia, kfdia
-      IF (ktest(jl)==1) THEN
-        zdp(jl, jk) = papm1(jl, jk) - papm1(jl, jk-1)
-        prho(jl, jk) = 2.*paphm1(jl, jk)*zcons1/(ptm1(jl,jk)+ptm1(jl,jk-1))
-        pstab(jl, jk) = 2.*zcons2/(ptm1(jl,jk)+ptm1(jl,jk-1))* &
-          (1.-rcpd*prho(jl,jk)*(ptm1(jl,jk)-ptm1(jl,jk-1))/zdp(jl,jk))
-        pstab(jl, jk) = max(pstab(jl,jk), gssec)
-      END IF
-    END DO
-  END DO
-
-  ! ********************************************************************
-
-  ! *     define blocked flow
-  ! -------------------
-  DO jk = klev, ilevh, -1
-    DO jl = kidia, kfdia
-      IF (jk>=kknub(jl) .AND. jk<=kknul(jl)) THEN
-        pulow(jl) = pulow(jl) + pum1(jl, jk)*(paphm1(jl,jk+1)-paphm1(jl,jk))
-        pvlow(jl) = pvlow(jl) + pvm1(jl, jk)*(paphm1(jl,jk+1)-paphm1(jl,jk))
-      END IF
-    END DO
-  END DO
-  DO jl = kidia, kfdia
-    pulow(jl) = pulow(jl)/(paphm1(jl,kknul(jl)+1)-paphm1(jl,kknub(jl)))
-    pvlow(jl) = pvlow(jl)/(paphm1(jl,kknul(jl)+1)-paphm1(jl,kknub(jl)))
-    znorm(jl) = max(sqrt(pulow(jl)**2+pvlow(jl)**2), gvsec)
-    pvph(jl, klev+1) = znorm(jl)
-  END DO
-
-  ! *******  setup orography axes and define plane of profiles  *******
-
-  DO jl = kidia, kfdia
-    lo = (pulow(jl)<gvsec) .AND. (pulow(jl)>=-gvsec)
-    IF (lo) THEN
-      zu = pulow(jl) + 2.*gvsec
-    ELSE
-      zu = pulow(jl)
-    END IF
-    zphi = atan(pvlow(jl)/zu)
-    ppsi(jl, klev+1) = ptheta(jl)*rpi/180. - zphi
-    zb(jl) = 1. - 0.18*pgamma(jl) - 0.04*pgamma(jl)**2
-    zc(jl) = 0.48*pgamma(jl) + 0.3*pgamma(jl)**2
-    pd1(jl) = zb(jl) - (zb(jl)-zc(jl))*(sin(ppsi(jl,klev+1))**2)
-    pd2(jl) = (zb(jl)-zc(jl))*sin(ppsi(jl,klev+1))*cos(ppsi(jl,klev+1))
-    pdmod(jl) = sqrt(pd1(jl)**2+pd2(jl)**2)
-  END DO
-
-  ! ************ define flow in plane of lowlevel stress *************
-
-  DO jk = 1, klev
-    DO jl = kidia, kfdia
-      IF (ktest(jl)==1) THEN
-        zvt1 = pulow(jl)*pum1(jl, jk) + pvlow(jl)*pvm1(jl, jk)
-        zvt2 = -pvlow(jl)*pum1(jl, jk) + pulow(jl)*pvm1(jl, jk)
-        zvpf(jl, jk) = (zvt1*pd1(jl)+zvt2*pd2(jl))/(znorm(jl)*pdmod(jl))
-      END IF
-      ptau(jl, jk) = 0.0
-      pzdep(jl, jk) = 0.0
-      ppsi(jl, jk) = 0.0
-      ll1(jl, jk) = .FALSE.
-    END DO
-  END DO
-  DO jk = 2, klev
-    DO jl = kidia, kfdia
-      IF (ktest(jl)==1) THEN
-        zdp(jl, jk) = papm1(jl, jk) - papm1(jl, jk-1)
-        pvph(jl, jk) = ((paphm1(jl,jk)-papm1(jl,jk-1))*zvpf(jl,jk)+(papm1(jl, &
-          jk)-paphm1(jl,jk))*zvpf(jl,jk-1))/zdp(jl, jk)
-        IF (pvph(jl,jk)<gvsec) THEN
-          pvph(jl, jk) = gvsec
-          kcrit(jl) = jk
-        END IF
-      END IF
-    END DO
-  END DO
-
-  ! *         2.2     brunt-vaisala frequency and density at half levels.
-
-
-  DO jk = ilevh, klev
-    DO jl = kidia, kfdia
-      IF (ktest(jl)==1) THEN
-        IF (jk>=(kknub(jl)+1) .AND. jk<=kknul(jl)) THEN
-          zst = zcons2/ptm1(jl, jk)*(1.-rcpd*prho(jl,jk)*(ptm1(jl, &
-            jk)-ptm1(jl,jk-1))/zdp(jl,jk))
-          pstab(jl, klev+1) = pstab(jl, klev+1) + zst*zdp(jl, jk)
-          pstab(jl, klev+1) = max(pstab(jl,klev+1), gssec)
-          prho(jl, klev+1) = prho(jl, klev+1) + paphm1(jl, jk)*2.*zdp(jl, jk) &
-            *zcons1/(ptm1(jl,jk)+ptm1(jl,jk-1))
-        END IF
-      END IF
-    END DO
-  END DO
-
-  DO jl = kidia, kfdia
-    pstab(jl, klev+1) = pstab(jl, klev+1)/(papm1(jl,kknul(jl))-papm1(jl,kknub &
-      (jl)))
-    prho(jl, klev+1) = prho(jl, klev+1)/(papm1(jl,kknul(jl))-papm1(jl,kknub( &
-      jl)))
-    zvar = pstd(jl)
-  END DO
-
-  ! *         2.3     mean flow richardson number.
-  ! *                 and critical height for froude layer
-
-
-  DO jk = 2, klev
-    DO jl = kidia, kfdia
-      IF (ktest(jl)==1) THEN
-        zdwind = max(abs(zvpf(jl,jk)-zvpf(jl,jk-1)), gvsec)
-        pri(jl, jk) = pstab(jl, jk)*(zdp(jl,jk)/(rg*prho(jl,jk)*zdwind))**2
-        pri(jl, jk) = max(pri(jl,jk), grcrit)
-      END IF
-    END DO
-  END DO
-
-
-
-  ! *      define top of 'envelope' layer
-  ! ----------------------------
-
-  DO jl = kidia, kfdia
-    pnu(jl) = 0.0
-    znum(jl) = 0.0
-  END DO
-
-  DO jk = 2, klev - 1
-    DO jl = kidia, kfdia
-
-      IF (ktest(jl)==1) THEN
-
-        IF (jk>=kknub(jl)) THEN
-
-          znum(jl) = pnu(jl)
-          zwind = (pulow(jl)*pum1(jl,jk)+pvlow(jl)*pvm1(jl,jk))/ &
-            max(sqrt(pulow(jl)**2+pvlow(jl)**2), gvsec)
-          zwind = max(sqrt(zwind**2), gvsec)
-          zdelp = paphm1(jl, jk+1) - paphm1(jl, jk)
-          zstabm = sqrt(max(pstab(jl,jk),gssec))
-          zstabp = sqrt(max(pstab(jl,jk+1),gssec))
-          zrhom = prho(jl, jk)
-          zrhop = prho(jl, jk+1)
-          pnu(jl) = pnu(jl) + (zdelp/rg)*((zstabp/zrhop+zstabm/zrhom)/2.)/ &
-            zwind
-          IF ((znum(jl)<=gfrcrit) .AND. (pnu(jl)>gfrcrit) .AND. (kkenvh( &
-            jl)==klev)) kkenvh(jl) = jk
-
-        END IF
-
-      END IF
-
-    END DO
-  END DO
-
-  ! calculation of a dynamical mixing height for the breaking
-  ! of gravity waves:
-
-
-  DO jl = kidia, kfdia
-    znup(jl) = 0.0
-    znum(jl) = 0.0
-  END DO
-
-  DO jk = klev - 1, 2, -1
-    DO jl = kidia, kfdia
-
-      IF (ktest(jl)==1) THEN
-
-        znum(jl) = znup(jl)
-        zwind = (pulow(jl)*pum1(jl,jk)+pvlow(jl)*pvm1(jl,jk))/ &
-          max(sqrt(pulow(jl)**2+pvlow(jl)**2), gvsec)
-        zwind = max(sqrt(zwind**2), gvsec)
-        zdelp = paphm1(jl, jk+1) - paphm1(jl, jk)
-        zstabm = sqrt(max(pstab(jl,jk),gssec))
-        zstabp = sqrt(max(pstab(jl,jk+1),gssec))
-        zrhom = prho(jl, jk)
-        zrhop = prho(jl, jk+1)
-        znup(jl) = znup(jl) + (zdelp/rg)*((zstabp/zrhop+zstabm/zrhom)/2.)/ &
-          zwind
-        IF ((znum(jl)<=rpi/2.) .AND. (znup(jl)>rpi/2.) .AND. (kkcrith( &
-          jl)==klev)) kkcrith(jl) = jk
-
-      END IF
-
-    END DO
-  END DO
-
-  DO jl = kidia, kfdia
-    kkcrith(jl) = min0(kkcrith(jl), kknu2(jl))
-    kkcrith(jl) = max0(kkcrith(jl), ilevh*2)
-  END DO
-
-  ! directional info for flow blocking *************************
-
-  DO jk = ilevh, klev
-    DO jl = kidia, kfdia
-      IF (jk>=kkenvh(jl)) THEN
-        lo = (pum1(jl,jk)<gvsec) .AND. (pum1(jl,jk)>=-gvsec)
-        IF (lo) THEN
-          zu = pum1(jl, jk) + 2.*gvsec
-        ELSE
-          zu = pum1(jl, jk)
-        END IF
-        zphi = atan(pvm1(jl,jk)/zu)
-        ppsi(jl, jk) = ptheta(jl)*rpi/180. - zphi
-      END IF
-    END DO
-  END DO
-  ! forms the vertical 'leakiness' **************************
-
-  alpha = 3.
-
-  DO jk = ilevh, klev
-    DO jl = kidia, kfdia
-      IF (jk>=kkenvh(jl)) THEN
-        zggeenv = amax1(1., (pgeom1(jl,kkenvh(jl))+pgeom1(jl, &
-          kkenvh(jl)-1))/2.)
-        zggeom1 = amax1(pgeom1(jl,jk), 1.)
-        zgvar = amax1(pstd(jl)*rg, 1.)
-        ! mod    pzdep(jl,jk)=sqrt((zggeenv-zggeom1)/(zggeom1+zgvar))
-        pzdep(jl, jk) = (pgeom1(jl,kkenvh(jl)-1)-pgeom1(jl,jk))/ &
-          (pgeom1(jl,kkenvh(jl)-1)-pgeom1(jl,klev))
-      END IF
-    END DO
-  END DO
-
-  RETURN
-END SUBROUTINE orosetup
-SUBROUTINE gwstress(nlon, nlev, ktest, kcrit, kkenvh, kknu, prho, pstab, &
-    pvph, pstd, psig, pmea, ppic, ptau, pgeom1, pdmod)
-
-  ! **** *gwstress*
-
-  ! purpose.
-  ! --------
-
-  ! **   interface.
-  ! ----------
-  ! call *gwstress*  from *gwdrag*
-
-  ! explicit arguments :
-  ! --------------------
-  ! ==== inputs ===
-  ! ==== outputs ===
-
-  ! implicit arguments :   none
-  ! --------------------
-
-  ! method.
-  ! -------
-
-
-  ! externals.
-  ! ----------
-
-
-  ! reference.
-  ! ----------
-
-  ! see ecmwf research department documentation of the "i.f.s."
-
-  ! author.
-  ! -------
-
-  ! modifications.
-  ! --------------
-  ! f. lott put the new gwd on ifs      22/11/93
-
-  ! -----------------------------------------------------------------------
-  USE dimphy
-  IMPLICIT NONE
-  include "YOMCST.h"
-  include "YOEGWD.h"
-
-  ! -----------------------------------------------------------------------
-
-  ! *       0.1   arguments
-  ! ---------
-
-  INTEGER nlon, nlev
-  INTEGER kcrit(nlon), ktest(nlon), kkenvh(nlon), kknu(nlon)
-
-  REAL prho(nlon, nlev+1), pstab(nlon, nlev+1), ptau(nlon, nlev+1), &
-    pvph(nlon, nlev+1), pgeom1(nlon, nlev), pstd(nlon)
-
-  REAL psig(nlon)
-  REAL pmea(nlon), ppic(nlon)
-  REAL pdmod(nlon)
-
-  ! -----------------------------------------------------------------------
-
-  ! *       0.2   local arrays
-  ! ------------
-  INTEGER jl
-  REAL zblock, zvar, zeff
-  LOGICAL lo
-
-  ! -----------------------------------------------------------------------
-
-  ! *       0.3   functions
-  ! ---------
-  ! ------------------------------------------------------------------
-
-  ! *         1.    initialization
-  ! --------------
-
-
-  ! *         3.1     gravity wave stress.
-
-
-
-  DO jl = kidia, kfdia
-    IF (ktest(jl)==1) THEN
-
-      ! effective mountain height above the blocked flow
-
-      IF (kkenvh(jl)==klev) THEN
-        zblock = 0.0
-      ELSE
-        zblock = (pgeom1(jl,kkenvh(jl))+pgeom1(jl,kkenvh(jl)+1))/2./rg
-      END IF
-
-      zvar = ppic(jl) - pmea(jl)
-      zeff = amax1(0., zvar-zblock)
-
-      ptau(jl, klev+1) = prho(jl, klev+1)*gkdrag*psig(jl)*zeff**2/4./ &
-        pstd(jl)*pvph(jl, klev+1)*pdmod(jl)*sqrt(pstab(jl,klev+1))
-
-      ! too small value of stress or  low level flow include critical level
-      ! or low level flow:  gravity wave stress nul.
-
-      lo = (ptau(jl,klev+1)<gtsec) .OR. (kcrit(jl)>=kknu(jl)) .OR. &
-        (pvph(jl,klev+1)<gvcrit)
-      ! if(lo) ptau(jl,klev+1)=0.0
-
-    ELSE
-
-      ptau(jl, klev+1) = 0.0
-
-    END IF
-
-  END DO
-
-  RETURN
-END SUBROUTINE gwstress
-SUBROUTINE gwprofil(nlon, nlev, kgwd, kdx, ktest, kkcrith, kcrit, paphm1, &
-    prho, pstab, pvph, pri, ptau, pdmod, psig, pvar)
-
-  ! **** *GWPROFIL*
-
-  ! PURPOSE.
-  ! --------
-
-  ! **   INTERFACE.
-  ! ----------
-  ! FROM *GWDRAG*
-
-  ! EXPLICIT ARGUMENTS :
-  ! --------------------
-  ! ==== INPUTS ===
-  ! ==== OUTPUTS ===
-
-  ! IMPLICIT ARGUMENTS :   NONE
-  ! --------------------
-
-  ! METHOD:
-  ! -------
-  ! THE STRESS PROFILE FOR GRAVITY WAVES IS COMPUTED AS FOLLOWS:
-  ! IT IS CONSTANT (NO GWD) AT THE LEVELS BETWEEN THE GROUND
-  ! AND THE TOP OF THE BLOCKED LAYER (KKENVH).
-  ! IT DECREASES LINEARLY WITH HEIGHTS FROM THE TOP OF THE
-  ! BLOCKED LAYER TO 3*VAROR (kKNU), TO SIMULATES LEE WAVES OR
-  ! NONLINEAR GRAVITY WAVE BREAKING.
-  ! ABOVE IT IS CONSTANT, EXCEPT WHEN THE WAVE ENCOUNTERS A CRITICAL
-  ! LEVEL (KCRIT) OR WHEN IT BREAKS.
-
-
-
-  ! EXTERNALS.
-  ! ----------
-
-
-  ! REFERENCE.
-  ! ----------
-
-  ! SEE ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE "I.F.S."
-
-  ! AUTHOR.
-  ! -------
-
-  ! MODIFICATIONS.
-  ! --------------
-  ! PASSAGE OF THE NEW GWDRAG TO I.F.S. (F. LOTT, 22/11/93)
-  ! -----------------------------------------------------------------------
-  USE dimphy
-  IMPLICIT NONE
-
-
-
-
-  include "YOMCST.h"
-  include "YOEGWD.h"
-
-  ! -----------------------------------------------------------------------
-
-  ! *       0.1   ARGUMENTS
-  ! ---------
-
-  INTEGER nlon, nlev
-  INTEGER kkcrith(nlon), kcrit(nlon), kdx(nlon), ktest(nlon)
-
-
-  REAL paphm1(nlon, nlev+1), pstab(nlon, nlev+1), prho(nlon, nlev+1), &
-    pvph(nlon, nlev+1), pri(nlon, nlev+1), ptau(nlon, nlev+1)
-
-  REAL pdmod(nlon), psig(nlon), pvar(nlon)
-
-  ! -----------------------------------------------------------------------
-
-  ! *       0.2   LOCAL ARRAYS
-  ! ------------
-
-  INTEGER ilevh, ji, kgwd, jl, jk
-  REAL zsqr, zalfa, zriw, zdel, zb, zalpha, zdz2n
-  REAL zdelp, zdelpt
-  REAL zdz2(klon, klev), znorm(klon), zoro(klon)
-  REAL ztau(klon, klev+1)
-
-  ! -----------------------------------------------------------------------
-
-  ! *         1.    INITIALIZATION
-  ! --------------
-
-  ! print *,' entree gwprofil'
-
-
-  ! *    COMPUTATIONAL CONSTANTS.
-  ! ------------- ----------
-
-  ilevh = klev/3
-
-  ! DO 400 ji=1,kgwd
-  ! jl=kdx(ji)
-  ! Modif vectorisation 02/04/2004
-  DO jl = kidia, kfdia
-    IF (ktest(jl)==1) THEN
-      zoro(jl) = psig(jl)*pdmod(jl)/4./max(pvar(jl), 1.0)
-      ztau(jl, klev+1) = ptau(jl, klev+1)
-    END IF
-  END DO
-
-
-  DO jk = klev, 2, -1
-
-    ! *         4.1    CONSTANT WAVE STRESS UNTIL TOP OF THE
-    ! BLOCKING LAYER.
-
-    ! DO 411 ji=1,kgwd
-    ! jl=kdx(ji)
-    ! Modif vectorisation 02/04/2004
-    DO jl = kidia, kfdia
-      IF (ktest(jl)==1) THEN
-        IF (jk>kkcrith(jl)) THEN
-          ptau(jl, jk) = ztau(jl, klev+1)
-          ! ENDIF
-          ! IF(JK.EQ.KKCRITH(JL)) THEN
-        ELSE
-          ptau(jl, jk) = grahilo*ztau(jl, klev+1)
-        END IF
-      END IF
-    END DO
-
-    ! *         4.15   CONSTANT SHEAR STRESS UNTIL THE TOP OF THE
-    ! LOW LEVEL FLOW LAYER.
-
-
-    ! *         4.2    WAVE DISPLACEMENT AT NEXT LEVEL.
-
-
-    ! DO 421 ji=1,kgwd
-    ! jl=kdx(ji)
-    ! Modif vectorisation 02/04/2004
-    DO jl = kidia, kfdia
-      IF (ktest(jl)==1) THEN
-        IF (jk<kkcrith(jl)) THEN
-          znorm(jl) = gkdrag*prho(jl, jk)*sqrt(pstab(jl,jk))*pvph(jl, jk)* &
-            zoro(jl)
-          zdz2(jl, jk) = ptau(jl, jk+1)/max(znorm(jl), gssec)
-        END IF
-      END IF
-    END DO
-
-    ! *         4.3    WAVE RICHARDSON NUMBER, NEW WAVE DISPLACEMENT
-    ! *                AND STRESS:  BREAKING EVALUATION AND CRITICAL
-    ! LEVEL
-
-
-    ! DO 431 ji=1,kgwd
-    ! jl=Kdx(ji)
-    ! Modif vectorisation 02/04/2004
-    DO jl = kidia, kfdia
-      IF (ktest(jl)==1) THEN
-
-        IF (jk<kkcrith(jl)) THEN
-          IF ((ptau(jl,jk+1)<gtsec) .OR. (jk<=kcrit(jl))) THEN
-            ptau(jl, jk) = 0.0
-          ELSE
-            zsqr = sqrt(pri(jl,jk))
-            zalfa = sqrt(pstab(jl,jk)*zdz2(jl,jk))/pvph(jl, jk)
-            zriw = pri(jl, jk)*(1.-zalfa)/(1+zalfa*zsqr)**2
-            IF (zriw<grcrit) THEN
-              zdel = 4./zsqr/grcrit + 1./grcrit**2 + 4./grcrit
-              zb = 1./grcrit + 2./zsqr
-              zalpha = 0.5*(-zb+sqrt(zdel))
-              zdz2n = (pvph(jl,jk)*zalpha)**2/pstab(jl, jk)
-              ptau(jl, jk) = znorm(jl)*zdz2n
-            ELSE
-              ptau(jl, jk) = znorm(jl)*zdz2(jl, jk)
-            END IF
-            ptau(jl, jk) = min(ptau(jl,jk), ptau(jl,jk+1))
-          END IF
-        END IF
-      END IF
-    END DO
-
-  END DO
-
-  ! REORGANISATION OF THE STRESS PROFILE AT LOW LEVEL
-
-  ! DO 530 ji=1,kgwd
-  ! jl=kdx(ji)
-  ! Modif vectorisation 02/04/2004
-  DO jl = kidia, kfdia
-    IF (ktest(jl)==1) THEN
-      ztau(jl, kkcrith(jl)) = ptau(jl, kkcrith(jl))
-      ztau(jl, nstra) = ptau(jl, nstra)
-    END IF
-  END DO
-
-  DO jk = 1, klev
-
-    ! DO 532 ji=1,kgwd
-    ! jl=kdx(ji)
-    ! Modif vectorisation 02/04/2004
-    DO jl = kidia, kfdia
-      IF (ktest(jl)==1) THEN
-
-
-        IF (jk>kkcrith(jl)) THEN
-
-          zdelp = paphm1(jl, jk) - paphm1(jl, klev+1)
-          zdelpt = paphm1(jl, kkcrith(jl)) - paphm1(jl, klev+1)
-          ptau(jl, jk) = ztau(jl, klev+1) + (ztau(jl,kkcrith(jl))-ztau(jl, &
-            klev+1))*zdelp/zdelpt
-
-        END IF
-
-      END IF
-    END DO
-
-    ! REORGANISATION IN THE STRATOSPHERE
-
-    ! DO 533 ji=1,kgwd
-    ! jl=kdx(ji)
-    ! Modif vectorisation 02/04/2004
-    DO jl = kidia, kfdia
-      IF (ktest(jl)==1) THEN
-
-
-        IF (jk<nstra) THEN
-
-          zdelp = paphm1(jl, nstra)
-          zdelpt = paphm1(jl, jk)
-          ptau(jl, jk) = ztau(jl, nstra)*zdelpt/zdelp
-
-        END IF
-
-      END IF
-    END DO
-
-    ! REORGANISATION IN THE TROPOSPHERE
-
-    ! DO 534 ji=1,kgwd
-    ! jl=kdx(ji)
-    ! Modif vectorisation 02/04/2004
-    DO jl = kidia, kfdia
-      IF (ktest(jl)==1) THEN
-
-
-        IF (jk<kkcrith(jl) .AND. jk>nstra) THEN
-
-          zdelp = paphm1(jl, jk) - paphm1(jl, kkcrith(jl))
-          zdelpt = paphm1(jl, nstra) - paphm1(jl, kkcrith(jl))
-          ptau(jl, jk) = ztau(jl, kkcrith(jl)) + (ztau(jl,nstra)-ztau(jl, &
-            kkcrith(jl)))*zdelp/zdelpt
-
-        END IF
-      END IF
-    END DO
-
-
-  END DO
-
-
-  RETURN
-END SUBROUTINE gwprofil
-SUBROUTINE lift_noro(nlon, nlev, dtime, paprs, pplay, plat, pmea, pstd, ppic, &
-    ktest, t, u, v, pulow, pvlow, pustr, pvstr, d_t, d_u, d_v)
-
-  USE dimphy
-  IMPLICIT NONE
-  ! ======================================================================
-  ! Auteur(s): F.Lott (LMD/CNRS) date: 19950201
-  ! Objet: Frottement de la montagne Interface
-  ! ======================================================================
-  ! Arguments:
-  ! dtime---input-R- pas d'integration (s)
-  ! paprs---input-R-pression pour chaque inter-couche (en Pa)
-  ! pplay---input-R-pression pour le mileu de chaque couche (en Pa)
-  ! t-------input-R-temperature (K)
-  ! u-------input-R-vitesse horizontale (m/s)
-  ! v-------input-R-vitesse horizontale (m/s)
-
-  ! d_t-----output-R-increment de la temperature
-  ! d_u-----output-R-increment de la vitesse u
-  ! d_v-----output-R-increment de la vitesse v
-  ! ======================================================================
-  include "YOMCST.h"
-
-  ! ARGUMENTS
-
-  INTEGER nlon, nlev
-  REAL dtime
-  REAL paprs(klon, klev+1)
-  REAL pplay(klon, klev)
-  REAL plat(nlon), pmea(nlon)
-  REAL pstd(nlon)
-  REAL ppic(nlon)
-  REAL pulow(nlon), pvlow(nlon), pustr(nlon), pvstr(nlon)
-  REAL t(nlon, nlev), u(nlon, nlev), v(nlon, nlev)
-  REAL d_t(nlon, nlev), d_u(nlon, nlev), d_v(nlon, nlev)
-
-  INTEGER i, k, ktest(nlon)
-
-  ! Variables locales:
-
-  REAL zgeom(klon, klev)
-  REAL pdtdt(klon, klev), pdudt(klon, klev), pdvdt(klon, klev)
-  REAL pt(klon, klev), pu(klon, klev), pv(klon, klev)
-  REAL papmf(klon, klev), papmh(klon, klev+1)
-
-  ! initialiser les variables de sortie (pour securite)
-
-  DO i = 1, klon
-    pulow(i) = 0.0
-    pvlow(i) = 0.0
-    pustr(i) = 0.0
-    pvstr(i) = 0.0
-  END DO
-  DO k = 1, klev
-    DO i = 1, klon
-      d_t(i, k) = 0.0
-      d_u(i, k) = 0.0
-      d_v(i, k) = 0.0
-      pdudt(i, k) = 0.0
-      pdvdt(i, k) = 0.0
-      pdtdt(i, k) = 0.0
-    END DO
-  END DO
-
-  ! preparer les variables d'entree (attention: l'ordre des niveaux
-  ! verticaux augmente du haut vers le bas)
-
-  DO k = 1, klev
-    DO i = 1, klon
-      pt(i, k) = t(i, klev-k+1)
-      pu(i, k) = u(i, klev-k+1)
-      pv(i, k) = v(i, klev-k+1)
-      papmf(i, k) = pplay(i, klev-k+1)
-    END DO
-  END DO
-  DO k = 1, klev + 1
-    DO i = 1, klon
-      papmh(i, k) = paprs(i, klev-k+2)
-    END DO
-  END DO
-  DO i = 1, klon
-    zgeom(i, klev) = rd*pt(i, klev)*log(papmh(i,klev+1)/papmf(i,klev))
-  END DO
-  DO k = klev - 1, 1, -1
-    DO i = 1, klon
-      zgeom(i, k) = zgeom(i, k+1) + rd*(pt(i,k)+pt(i,k+1))/2.0*log(papmf(i,k+ &
-        1)/papmf(i,k))
-    END DO
-  END DO
-
-  ! appeler la routine principale
-
-  CALL orolift(klon, klev, ktest, dtime, papmh, zgeom, pt, pu, pv, plat, &
-    pmea, pstd, ppic, pulow, pvlow, pdudt, pdvdt, pdtdt)
-
-  DO k = 1, klev
-    DO i = 1, klon
-      d_u(i, klev+1-k) = dtime*pdudt(i, k)
-      d_v(i, klev+1-k) = dtime*pdvdt(i, k)
-      d_t(i, klev+1-k) = dtime*pdtdt(i, k)
-      pustr(i) = pustr(i) &        ! IM BUG .
-                                   ! +RG*pdudt(i,k)*(papmh(i,k+1)-papmh(i,k))
-        +pdudt(i, k)*(papmh(i,k+1)-papmh(i,k))/rg
-      pvstr(i) = pvstr(i) &        ! IM BUG .
-                                   ! +RG*pdvdt(i,k)*(papmh(i,k+1)-papmh(i,k))
-        +pdvdt(i, k)*(papmh(i,k+1)-papmh(i,k))/rg
-    END DO
-  END DO
-
-  RETURN
-END SUBROUTINE lift_noro
-SUBROUTINE orolift(nlon, nlev, ktest, ptsphy, paphm1, pgeom1, ptm1, pum1, &
-    pvm1, plat, pmea, pvaror, ppic & ! OUTPUTS
-    , pulow, pvlow, pvom, pvol, pte)
-
-
-  ! **** *OROLIFT: SIMULATE THE GEOSTROPHIC LIFT.
-
-  ! PURPOSE.
-  ! --------
-
-  ! **   INTERFACE.
-  ! ----------
-  ! CALLED FROM *lift_noro
-  ! ----------
-
-  ! AUTHOR.
-  ! -------
-  ! F.LOTT  LMD 22/11/95
-
-  USE dimphy
-  IMPLICIT NONE
-
-
-  include "YOMCST.h"
-  include "YOEGWD.h"
-  ! -----------------------------------------------------------------------
-
-  ! *       0.1   ARGUMENTS
-  ! ---------
-
-
-  INTEGER nlon, nlev
-  REAL pte(nlon, nlev), pvol(nlon, nlev), pvom(nlon, nlev), pulow(nlon), &
-    pvlow(nlon)
-  REAL pum1(nlon, nlev), pvm1(nlon, nlev), ptm1(nlon, nlev), plat(nlon), &
-    pmea(nlon), pvaror(nlon), ppic(nlon), pgeom1(nlon, nlev), &
-    paphm1(nlon, nlev+1)
-
-  INTEGER ktest(nlon)
-  REAL ptsphy
-  ! -----------------------------------------------------------------------
-
-  ! *       0.2   LOCAL ARRAYS
-  ! ------------
-  LOGICAL lifthigh
-  ! ym      integer klevm1, jl, ilevh, jk
-  INTEGER jl, ilevh, jk
-  REAL zcons1, ztmst, zrtmst, zpi, zhgeo
-  REAL zdelp, zslow, zsqua, zscav, zbet
-  INTEGER iknub(klon), iknul(klon)
-  LOGICAL ll1(klon, klev+1)
-
-  REAL ztau(klon, klev+1), ztav(klon, klev+1), zrho(klon, klev+1)
-  REAL zdudt(klon), zdvdt(klon)
-  REAL zhcrit(klon, klev)
-  CHARACTER (LEN=20) :: modname = 'orografi'
-  CHARACTER (LEN=80) :: abort_message
-  ! -----------------------------------------------------------------------
-
-  ! *         1.1  INITIALIZATIONS
-  ! ---------------
-
-  lifthigh = .FALSE.
-
-  IF (nlon/=klon .OR. nlev/=klev) THEN
-    abort_message = 'pb dimension'
-    CALL abort_physic(modname, abort_message, 1)
-  END IF
-  zcons1 = 1./rd
-  ! ym      KLEVM1=KLEV-1
-  ztmst = ptsphy
-  zrtmst = 1./ztmst
-  zpi = acos(-1.)
-
-  DO jl = kidia, kfdia
-    zrho(jl, klev+1) = 0.0
-    pulow(jl) = 0.0
-    pvlow(jl) = 0.0
-    iknub(jl) = klev
-    iknul(jl) = klev
-    ilevh = klev/3
-    ll1(jl, klev+1) = .FALSE.
-    DO jk = 1, klev
-      pvom(jl, jk) = 0.0
-      pvol(jl, jk) = 0.0
-      pte(jl, jk) = 0.0
-    END DO
-  END DO
-
-
-  ! *         2.1     DEFINE LOW LEVEL WIND, PROJECT WINDS IN PLANE OF
-  ! *                 LOW LEVEL WIND, DETERMINE SECTOR IN WHICH TO TAKE
-  ! *                 THE VARIANCE AND SET INDICATOR FOR CRITICAL LEVELS.
-
-
-
-  DO jk = klev, 1, -1
-    DO jl = kidia, kfdia
-      IF (ktest(jl)==1) THEN
-        zhcrit(jl, jk) = amax1(ppic(jl)-pmea(jl), 100.)
-        zhgeo = pgeom1(jl, jk)/rg
-        ll1(jl, jk) = (zhgeo>zhcrit(jl,jk))
-        IF (ll1(jl,jk) .NEQV. ll1(jl,jk+1)) THEN
-          iknub(jl) = jk
-        END IF
-      END IF
-    END DO
-  END DO
-
-  DO jl = kidia, kfdia
-    IF (ktest(jl)==1) THEN
-      iknub(jl) = max(iknub(jl), klev/2)
-      iknul(jl) = max(iknul(jl), 2*klev/3)
-      IF (iknub(jl)>nktopg) iknub(jl) = nktopg
-      IF (iknub(jl)==nktopg) iknul(jl) = klev
-      IF (iknub(jl)==iknul(jl)) iknub(jl) = iknul(jl) - 1
-    END IF
-  END DO
-
-  ! do 2011 jl=kidia,kfdia
-  ! IF(KTEST(JL).EQ.1) THEN
-  ! print *,' iknul= ',iknul(jl),'  iknub=',iknub(jl)
-  ! ENDIF
-  ! 2011 continue
-
-  ! PRINT *,'  DANS OROLIFT: 2010'
-
-  DO jk = klev, 2, -1
-    DO jl = kidia, kfdia
-      zrho(jl, jk) = 2.*paphm1(jl, jk)*zcons1/(ptm1(jl,jk)+ptm1(jl,jk-1))
-    END DO
-  END DO
-  ! PRINT *,'  DANS OROLIFT: 223'
-
-  ! ********************************************************************
-
-  ! *     DEFINE LOW LEVEL FLOW
-  ! -------------------
-  DO jk = klev, 1, -1
-    DO jl = kidia, kfdia
-      IF (ktest(jl)==1) THEN
-        IF (jk>=iknub(jl) .AND. jk<=iknul(jl)) THEN
-          pulow(jl) = pulow(jl) + pum1(jl, jk)*(paphm1(jl,jk+1)-paphm1(jl,jk) &
-            )
-          pvlow(jl) = pvlow(jl) + pvm1(jl, jk)*(paphm1(jl,jk+1)-paphm1(jl,jk) &
-            )
-          zrho(jl, klev+1) = zrho(jl, klev+1) + zrho(jl, jk)*(paphm1(jl,jk+1) &
-            -paphm1(jl,jk))
-        END IF
-      END IF
-    END DO
-  END DO
-  DO jl = kidia, kfdia
-    IF (ktest(jl)==1) THEN
-      pulow(jl) = pulow(jl)/(paphm1(jl,iknul(jl)+1)-paphm1(jl,iknub(jl)))
-      pvlow(jl) = pvlow(jl)/(paphm1(jl,iknul(jl)+1)-paphm1(jl,iknub(jl)))
-      zrho(jl, klev+1) = zrho(jl, klev+1)/(paphm1(jl,iknul(jl)+1)-paphm1(jl, &
-        iknub(jl)))
-    END IF
-  END DO
-
-  ! ***********************************************************
-
-  ! *         3.      COMPUTE MOUNTAIN LIFT
-
-
-  DO jl = kidia, kfdia
-    IF (ktest(jl)==1) THEN
-      ztau(jl, klev+1) = -gklift*zrho(jl, klev+1)*2.*romega* & ! *
-                                                               ! (2*PVAROR(JL)+PMEA(JL))*
-        2*pvaror(jl)*sin(zpi/180.*plat(jl))*pvlow(jl)
-      ztav(jl, klev+1) = gklift*zrho(jl, klev+1)*2.*romega* & ! *
-                                                              ! (2*PVAROR(JL)+PMEA(JL))*
-        2*pvaror(jl)*sin(zpi/180.*plat(jl))*pulow(jl)
-    ELSE
-      ztau(jl, klev+1) = 0.0
-      ztav(jl, klev+1) = 0.0
-    END IF
-  END DO
-
-  ! *         4.      COMPUTE LIFT PROFILE
-  ! *                 --------------------
-
-
-
-  DO jk = 1, klev
-    DO jl = kidia, kfdia
-      IF (ktest(jl)==1) THEN
-        ztau(jl, jk) = ztau(jl, klev+1)*paphm1(jl, jk)/paphm1(jl, klev+1)
-        ztav(jl, jk) = ztav(jl, klev+1)*paphm1(jl, jk)/paphm1(jl, klev+1)
-      ELSE
-        ztau(jl, jk) = 0.0
-        ztav(jl, jk) = 0.0
-      END IF
-    END DO
-  END DO
-
-
-  ! *         5.      COMPUTE TENDENCIES.
-  ! *                 -------------------
-  IF (lifthigh) THEN
-    ! PRINT *,'  DANS OROLIFT: 500'
-
-    ! EXPLICIT SOLUTION AT ALL LEVELS
-
-    DO jk = 1, klev
-      DO jl = kidia, kfdia
-        IF (ktest(jl)==1) THEN
-          zdelp = paphm1(jl, jk+1) - paphm1(jl, jk)
-          zdudt(jl) = -rg*(ztau(jl,jk+1)-ztau(jl,jk))/zdelp
-          zdvdt(jl) = -rg*(ztav(jl,jk+1)-ztav(jl,jk))/zdelp
-        END IF
-      END DO
-    END DO
-
-    ! PROJECT PERPENDICULARLY TO U NOT TO DESTROY ENERGY
-
-    DO jk = 1, klev
-      DO jl = kidia, kfdia
-        IF (ktest(jl)==1) THEN
-
-          zslow = sqrt(pulow(jl)**2+pvlow(jl)**2)
-          zsqua = amax1(sqrt(pum1(jl,jk)**2+pvm1(jl,jk)**2), gvsec)
-          zscav = -zdudt(jl)*pvm1(jl, jk) + zdvdt(jl)*pum1(jl, jk)
-          IF (zsqua>gvsec) THEN
-            pvom(jl, jk) = -zscav*pvm1(jl, jk)/zsqua**2
-            pvol(jl, jk) = zscav*pum1(jl, jk)/zsqua**2
-          ELSE
-            pvom(jl, jk) = 0.0
-            pvol(jl, jk) = 0.0
-          END IF
-          zsqua = sqrt(pum1(jl,jk)**2+pum1(jl,jk)**2)
-          IF (zsqua<zslow) THEN
-            pvom(jl, jk) = zsqua/zslow*pvom(jl, jk)
-            pvol(jl, jk) = zsqua/zslow*pvol(jl, jk)
-          END IF
-
-        END IF
-      END DO
-    END DO
-
-    ! 6.  LOW LEVEL LIFT, SEMI IMPLICIT:
-    ! ----------------------------------
-
-  ELSE
-
-    DO jl = kidia, kfdia
-      IF (ktest(jl)==1) THEN
-        DO jk = klev, iknub(jl), -1
-          zbet = gklift*2.*romega*sin(zpi/180.*plat(jl))*ztmst* &
-            (pgeom1(jl,iknub(jl)-1)-pgeom1(jl,jk))/ &
-            (pgeom1(jl,iknub(jl)-1)-pgeom1(jl,klev))
-          zdudt(jl) = -pum1(jl, jk)/ztmst/(1+zbet**2)
-          zdvdt(jl) = -pvm1(jl, jk)/ztmst/(1+zbet**2)
-          pvom(jl, jk) = zbet**2*zdudt(jl) - zbet*zdvdt(jl)
-          pvol(jl, jk) = zbet*zdudt(jl) + zbet**2*zdvdt(jl)
-        END DO
-      END IF
-    END DO
-
-  END IF
-
-  RETURN
-END SUBROUTINE orolift
-
-
-SUBROUTINE sugwd(nlon, nlev, paprs, pplay)
-  USE dimphy
-  USE mod_phys_lmdz_para
-  USE mod_grid_phy_lmdz
-  ! USE parallel
-
-  ! **** *SUGWD* INITIALIZE COMMON YOEGWD CONTROLLING GRAVITY WAVE DRAG
-
-  ! PURPOSE.
-  ! --------
-  ! INITIALIZE YOEGWD, THE COMMON THAT CONTROLS THE
-  ! GRAVITY WAVE DRAG PARAMETRIZATION.
-
-  ! **   INTERFACE.
-  ! ----------
-  ! CALL *SUGWD* FROM *SUPHEC*
-  ! -----        ------
-
-  ! EXPLICIT ARGUMENTS :
-  ! --------------------
-  ! PSIG        : VERTICAL COORDINATE TABLE
-  ! NLEV        : NUMBER OF MODEL LEVELS
-
-  ! IMPLICIT ARGUMENTS :
-  ! --------------------
-  ! COMMON YOEGWD
-
-  ! METHOD.
-  ! -------
-  ! SEE DOCUMENTATION
-
-  ! EXTERNALS.
-  ! ----------
-  ! NONE
-
-  ! REFERENCE.
-  ! ----------
-  ! ECMWF Research Department documentation of the IFS
-
-  ! AUTHOR.
-  ! -------
-  ! MARTIN MILLER             *ECMWF*
-
-  ! MODIFICATIONS.
-  ! --------------
-  ! ORIGINAL : 90-01-01
-  ! ------------------------------------------------------------------
-  IMPLICIT NONE
-
-  ! -----------------------------------------------------------------
-  include "YOEGWD.h"
-  ! ----------------------------------------------------------------
-
-  INTEGER nlon, nlev, jk
-  REAL paprs(nlon, nlev+1)
-  REAL pplay(nlon, nlev)
-  REAL zpr, zstra, zsigt, zpm1r
-  REAL :: pplay_glo(klon_glo, nlev)
-  REAL :: paprs_glo(klon_glo, nlev+1)
-
-  ! *       1.    SET THE VALUES OF THE PARAMETERS
-  ! --------------------------------
-
-
-  PRINT *, ' DANS SUGWD NLEV=', nlev
-  ghmax = 10000.
-
-  zpr = 100000.
-  zstra = 0.1
-  zsigt = 0.94
-  ! old  ZPR=80000.
-  ! old  ZSIGT=0.85
-
-
-  CALL gather(pplay, pplay_glo)
-  CALL bcast(pplay_glo)
-  CALL gather(paprs, paprs_glo)
-  CALL bcast(paprs_glo)
-
-
-  DO jk = 1, nlev
-    zpm1r = pplay_glo((klon_glo/2)+1, jk)/paprs_glo((klon_glo/2)+1, 1)
-    IF (zpm1r>=zsigt) THEN
-      nktopg = jk
-    END IF
-    zpm1r = pplay_glo((klon_glo/2)+1, jk)/paprs_glo((klon_glo/2)+1, 1)
-    IF (zpm1r>=zstra) THEN
-      nstra = jk
-    END IF
-  END DO
-
-
-
-  ! inversion car dans orodrag on compte les niveaux a l'envers
-  nktopg = nlev - nktopg + 1
-  nstra = nlev - nstra
-  PRINT *, ' DANS SUGWD nktopg=', nktopg
-  PRINT *, ' DANS SUGWD nstra=', nstra
-
-  gsigcr = 0.80
-
-!  Values now specified in run.def, or conf_phys_m.F90
-!  gkdrag = 0.2
-!  grahilo = 1.
-!  grcrit = 0.01
-!  gfrcrit = 1.0
-!  gkwake = 0.50
-! gklift = 0.50
-  gvcrit = 0.0
-
-  ! ----------------------------------------------------------------
-
-  ! *       2.    SET VALUES OF SECURITY PARAMETERS
-  ! ---------------------------------
-
-
-  gvsec = 0.10
-  gssec = 1.E-12
-
-  gtsec = 1.E-07
-
-  ! ----------------------------------------------------------------
-
-  RETURN
-END SUBROUTINE sugwd
Index: /LMDZ6/trunk/libf/phylmd/orografi.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/orografi.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/orografi.f90	(revision 5268)
@@ -0,0 +1,1681 @@
+
+! $Id$
+
+SUBROUTINE drag_noro(nlon, nlev, dtime, paprs, pplay, pmea, pstd, psig, pgam, &
+    pthe, ppic, pval, kgwd, kdx, ktest, t, u, v, pulow, pvlow, pustr, pvstr, &
+    d_t, d_u, d_v)
+
+  USE dimphy
+  IMPLICIT NONE
+  ! ======================================================================
+  ! Auteur(s): F.Lott (LMD/CNRS) date: 19950201
+  ! Objet: Frottement de la montagne Interface
+  ! ======================================================================
+  ! Arguments:
+  ! dtime---input-R- pas d'integration (s)
+  ! paprs---input-R-pression pour chaque inter-couche (en Pa)
+  ! pplay---input-R-pression pour le mileu de chaque couche (en Pa)
+  ! t-------input-R-temperature (K)
+  ! u-------input-R-vitesse horizontale (m/s)
+  ! v-------input-R-vitesse horizontale (m/s)
+
+  ! d_t-----output-R-increment de la temperature
+  ! d_u-----output-R-increment de la vitesse u
+  ! d_v-----output-R-increment de la vitesse v
+  ! ======================================================================
+  include "YOMCST.h"
+
+  ! ARGUMENTS
+
+  INTEGER nlon, nlev
+  REAL dtime
+  REAL paprs(klon, klev+1)
+  REAL pplay(klon, klev)
+  REAL pmea(nlon), pstd(nlon), psig(nlon), pgam(nlon), pthe(nlon)
+  REAL ppic(nlon), pval(nlon)
+  REAL pulow(nlon), pvlow(nlon), pustr(nlon), pvstr(nlon)
+  REAL t(nlon, nlev), u(nlon, nlev), v(nlon, nlev)
+  REAL d_t(nlon, nlev), d_u(nlon, nlev), d_v(nlon, nlev)
+
+  INTEGER i, k, kgwd, kdx(nlon), ktest(nlon)
+
+  ! Variables locales:
+
+  REAL zgeom(klon, klev)
+  REAL pdtdt(klon, klev), pdudt(klon, klev), pdvdt(klon, klev)
+  REAL pt(klon, klev), pu(klon, klev), pv(klon, klev)
+  REAL papmf(klon, klev), papmh(klon, klev+1)
+
+  ! initialiser les variables de sortie (pour securite)
+
+  DO i = 1, klon
+    pulow(i) = 0.0
+    pvlow(i) = 0.0
+    pustr(i) = 0.0
+    pvstr(i) = 0.0
+  END DO
+  DO k = 1, klev
+    DO i = 1, klon
+      d_t(i, k) = 0.0
+      d_u(i, k) = 0.0
+      d_v(i, k) = 0.0
+      pdudt(i, k) = 0.0
+      pdvdt(i, k) = 0.0
+      pdtdt(i, k) = 0.0
+    END DO
+  END DO
+
+  ! preparer les variables d'entree (attention: l'ordre des niveaux
+  ! verticaux augmente du haut vers le bas)
+
+  DO k = 1, klev
+    DO i = 1, klon
+      pt(i, k) = t(i, klev-k+1)
+      pu(i, k) = u(i, klev-k+1)
+      pv(i, k) = v(i, klev-k+1)
+      papmf(i, k) = pplay(i, klev-k+1)
+    END DO
+  END DO
+  DO k = 1, klev + 1
+    DO i = 1, klon
+      papmh(i, k) = paprs(i, klev-k+2)
+    END DO
+  END DO
+  DO i = 1, klon
+    zgeom(i, klev) = rd*pt(i, klev)*log(papmh(i,klev+1)/papmf(i,klev))
+  END DO
+  DO k = klev - 1, 1, -1
+    DO i = 1, klon
+      zgeom(i, k) = zgeom(i, k+1) + rd*(pt(i,k)+pt(i,k+1))/2.0*log(papmf(i,k+ &
+        1)/papmf(i,k))
+    END DO
+  END DO
+
+  ! appeler la routine principale
+
+  CALL orodrag(klon, klev, kgwd, kdx, ktest, dtime, papmh, papmf, zgeom, pt, &
+    pu, pv, pmea, pstd, psig, pgam, pthe, ppic, pval, pulow, pvlow, pdudt, &
+    pdvdt, pdtdt)
+
+  DO k = 1, klev
+    DO i = 1, klon
+      d_u(i, klev+1-k) = dtime*pdudt(i, k)
+      d_v(i, klev+1-k) = dtime*pdvdt(i, k)
+      d_t(i, klev+1-k) = dtime*pdtdt(i, k)
+      pustr(i) = pustr(i) &        ! IM BUG  .
+                                   ! +rg*pdudt(i,k)*(papmh(i,k+1)-papmh(i,k))
+        +pdudt(i, k)*(papmh(i,k+1)-papmh(i,k))/rg
+      pvstr(i) = pvstr(i) &        ! IM BUG  .
+                                   ! +rg*pdvdt(i,k)*(papmh(i,k+1)-papmh(i,k))
+        +pdvdt(i, k)*(papmh(i,k+1)-papmh(i,k))/rg
+    END DO
+  END DO
+
+  RETURN
+END SUBROUTINE drag_noro
+SUBROUTINE orodrag(nlon, nlev, kgwd, kdx, ktest, ptsphy, paphm1, papm1, &
+    pgeom1, ptm1, pum1, pvm1, pmea, pstd, psig, pgamma, ptheta, ppic, pval &
+  ! outputs
+    , pulow, pvlow, pvom, pvol, pte)
+
+  USE dimphy
+  IMPLICIT NONE
+
+
+
+  ! **** *gwdrag* - does the gravity wave parametrization.
+
+  ! purpose.
+  ! --------
+
+  ! this routine computes the physical tendencies of the
+  ! prognostic variables u,v  and t due to  vertical transports by
+  ! subgridscale orographically excited gravity waves
+
+  ! **   interface.
+  ! ----------
+  ! called from *callpar*.
+
+  ! the routine takes its input from the long-term storage:
+  ! u,v,t and p at t-1.
+
+  ! explicit arguments :
+  ! --------------------
+  ! ==== inputs ===
+  ! ==== outputs ===
+
+  ! implicit arguments :   none
+  ! --------------------
+
+  ! implicit logical (l)
+
+  ! method.
+  ! -------
+
+  ! externals.
+  ! ----------
+  INTEGER ismin, ismax
+  EXTERNAL ismin, ismax
+
+  ! reference.
+  ! ----------
+
+  ! author.
+  ! -------
+  ! m.miller + b.ritter   e.c.m.w.f.     15/06/86.
+
+  ! f.lott + m. miller    e.c.m.w.f.     22/11/94
+  ! -----------------------------------------------------------------------
+
+
+  include "YOMCST.h"
+  include "YOEGWD.h"
+  ! -----------------------------------------------------------------------
+
+  ! *       0.1   arguments
+  ! ---------
+
+
+  ! ym      integer nlon, nlev, klevm1
+  INTEGER nlon, nlev
+  INTEGER kgwd, jl, ilevp1, jk, ji
+  REAL zdelp, ztemp, zforc, ztend
+  REAL rover, zb, zc, zconb, zabsv
+  REAL zzd1, ratio, zbet, zust, zvst, zdis
+  REAL pte(nlon, nlev), pvol(nlon, nlev), pvom(nlon, nlev), pulow(klon), &
+    pvlow(klon)
+  REAL pum1(nlon, nlev), pvm1(nlon, nlev), ptm1(nlon, nlev), pmea(nlon), &
+    pstd(nlon), psig(nlon), pgamma(nlon), ptheta(nlon), ppic(nlon), &
+    pval(nlon), pgeom1(nlon, nlev), papm1(nlon, nlev), paphm1(nlon, nlev+1)
+
+  INTEGER kdx(nlon), ktest(nlon)
+  ! -----------------------------------------------------------------------
+
+  ! *       0.2   local arrays
+  ! ------------
+  INTEGER isect(klon), icrit(klon), ikcrith(klon), ikenvh(klon), iknu(klon), &
+    iknu2(klon), ikcrit(klon), ikhlim(klon)
+
+  REAL ztau(klon, klev+1), ztauf(klon, klev+1), zstab(klon, klev+1), &
+    zvph(klon, klev+1), zrho(klon, klev+1), zri(klon, klev+1), &
+    zpsi(klon, klev+1), zzdep(klon, klev)
+  REAL zdudt(klon), zdvdt(klon), zdtdt(klon), zdedt(klon), zvidis(klon), &
+    znu(klon), zd1(klon), zd2(klon), zdmod(klon)
+  REAL ztmst, ptsphy, zrtmst
+
+  ! ------------------------------------------------------------------
+
+  ! *         1.    initialization
+  ! --------------
+
+
+  ! ------------------------------------------------------------------
+
+  ! *         1.1   computational constants
+  ! -----------------------
+
+
+  ! ztmst=twodt
+  ! if(nstep.eq.nstart) ztmst=0.5*twodt
+  ! ym      klevm1=klev-1
+  ztmst = ptsphy
+  zrtmst = 1./ztmst
+
+  ! ------------------------------------------------------------------
+
+  ! *         1.3   check whether row contains point for printing
+  ! ---------------------------------------------
+
+
+  ! ------------------------------------------------------------------
+
+  ! *         2.     precompute basic state variables.
+  ! *                ---------- ----- ----- ----------
+  ! *                define low level wind, project winds in plane of
+  ! *                low level wind, determine sector in which to take
+  ! *                the variance and set indicator for critical levels.
+
+
+
+
+  CALL orosetup(nlon, ktest, ikcrit, ikcrith, icrit, ikenvh, iknu, iknu2, &
+    paphm1, papm1, pum1, pvm1, ptm1, pgeom1, pstd, zrho, zri, zstab, ztau, &
+    zvph, zpsi, zzdep, pulow, pvlow, ptheta, pgamma, pmea, ppic, pval, znu, &
+    zd1, zd2, zdmod)
+
+  ! ***********************************************************
+
+
+  ! *         3.      compute low level stresses using subcritical and
+  ! *                 supercritical forms.computes anisotropy coefficient
+  ! *                 as measure of orographic twodimensionality.
+
+
+  CALL gwstress(nlon, nlev, ktest, icrit, ikenvh, iknu, zrho, zstab, zvph, &
+    pstd, psig, pmea, ppic, ztau, pgeom1, zdmod)
+
+  ! *         4.      compute stress profile.
+  ! *                 ------- ------ --------
+
+
+
+  CALL gwprofil(nlon, nlev, kgwd, kdx, ktest, ikcrith, icrit, paphm1, zrho, &
+    zstab, zvph, zri, ztau, zdmod, psig, pstd)
+
+  ! *         5.      compute tendencies.
+  ! *                 -------------------
+
+
+  ! explicit solution at all levels for the gravity wave
+  ! implicit solution for the blocked levels
+
+  DO jl = kidia, kfdia
+    zvidis(jl) = 0.0
+    zdudt(jl) = 0.0
+    zdvdt(jl) = 0.0
+    zdtdt(jl) = 0.0
+  END DO
+
+  ilevp1 = klev + 1
+
+
+  DO jk = 1, klev
+
+
+    ! do 523 jl=1,kgwd
+    ! ji=kdx(jl)
+    ! Modif vectorisation 02/04/2004
+    DO ji = kidia, kfdia
+      IF (ktest(ji)==1) THEN
+
+        zdelp = paphm1(ji, jk+1) - paphm1(ji, jk)
+        ztemp = -rg*(ztau(ji,jk+1)-ztau(ji,jk))/(zvph(ji,ilevp1)*zdelp)
+        zdudt(ji) = (pulow(ji)*zd1(ji)-pvlow(ji)*zd2(ji))*ztemp/zdmod(ji)
+        zdvdt(ji) = (pvlow(ji)*zd1(ji)+pulow(ji)*zd2(ji))*ztemp/zdmod(ji)
+
+        ! controle des overshoots:
+
+        zforc = sqrt(zdudt(ji)**2+zdvdt(ji)**2) + 1.E-12
+        ztend = sqrt(pum1(ji,jk)**2+pvm1(ji,jk)**2)/ztmst + 1.E-12
+        rover = 0.25
+        IF (zforc>=rover*ztend) THEN
+          zdudt(ji) = rover*ztend/zforc*zdudt(ji)
+          zdvdt(ji) = rover*ztend/zforc*zdvdt(ji)
+        END IF
+
+        ! fin du controle des overshoots
+
+        IF (jk>=ikenvh(ji)) THEN
+          zb = 1.0 - 0.18*pgamma(ji) - 0.04*pgamma(ji)**2
+          zc = 0.48*pgamma(ji) + 0.3*pgamma(ji)**2
+          zconb = 2.*ztmst*gkwake*psig(ji)/(4.*pstd(ji))
+          zabsv = sqrt(pum1(ji,jk)**2+pvm1(ji,jk)**2)/2.
+          zzd1 = zb*cos(zpsi(ji,jk))**2 + zc*sin(zpsi(ji,jk))**2
+          ratio = (cos(zpsi(ji,jk))**2+pgamma(ji)*sin(zpsi(ji, &
+            jk))**2)/(pgamma(ji)*cos(zpsi(ji,jk))**2+sin(zpsi(ji,jk))**2)
+          zbet = max(0., 2.-1./ratio)*zconb*zzdep(ji, jk)*zzd1*zabsv
+
+          ! simplement oppose au vent
+
+          zdudt(ji) = -pum1(ji, jk)/ztmst
+          zdvdt(ji) = -pvm1(ji, jk)/ztmst
+
+          ! projection dans la direction de l'axe principal de l'orographie
+          ! mod     zdudt(ji)=-(pum1(ji,jk)*cos(ptheta(ji)*rpi/180.)
+          ! mod *              +pvm1(ji,jk)*sin(ptheta(ji)*rpi/180.))
+          ! mod *              *cos(ptheta(ji)*rpi/180.)/ztmst
+          ! mod     zdvdt(ji)=-(pum1(ji,jk)*cos(ptheta(ji)*rpi/180.)
+          ! mod *              +pvm1(ji,jk)*sin(ptheta(ji)*rpi/180.))
+          ! mod *              *sin(ptheta(ji)*rpi/180.)/ztmst
+          zdudt(ji) = zdudt(ji)*(zbet/(1.+zbet))
+          zdvdt(ji) = zdvdt(ji)*(zbet/(1.+zbet))
+        END IF
+        pvom(ji, jk) = zdudt(ji)
+        pvol(ji, jk) = zdvdt(ji)
+        zust = pum1(ji, jk) + ztmst*zdudt(ji)
+        zvst = pvm1(ji, jk) + ztmst*zdvdt(ji)
+        zdis = 0.5*(pum1(ji,jk)**2+pvm1(ji,jk)**2-zust**2-zvst**2)
+        zdedt(ji) = zdis/ztmst
+        zvidis(ji) = zvidis(ji) + zdis*zdelp
+        zdtdt(ji) = zdedt(ji)/rcpd
+        ! pte(ji,jk)=zdtdt(ji)
+
+        ! ENCORE UN TRUC POUR EVITER LES EXPLOSIONS
+
+        pte(ji, jk) = 0.0
+
+      END IF
+    END DO
+
+  END DO
+
+
+  RETURN
+END SUBROUTINE orodrag
+SUBROUTINE orosetup(nlon, ktest, kkcrit, kkcrith, kcrit, kkenvh, kknu, kknu2, &
+    paphm1, papm1, pum1, pvm1, ptm1, pgeom1, pstd, prho, pri, pstab, ptau, &
+    pvph, ppsi, pzdep, pulow, pvlow, ptheta, pgamma, pmea, ppic, pval, pnu, &
+    pd1, pd2, pdmod)
+
+  ! **** *gwsetup*
+
+  ! purpose.
+  ! --------
+
+  ! **   interface.
+  ! ----------
+  ! from *orodrag*
+
+  ! explicit arguments :
+  ! --------------------
+  ! ==== inputs ===
+  ! ==== outputs ===
+
+  ! implicit arguments :   none
+  ! --------------------
+
+  ! method.
+  ! -------
+
+
+  ! externals.
+  ! ----------
+
+
+  ! reference.
+  ! ----------
+
+  ! see ecmwf research department documentation of the "i.f.s."
+
+  ! author.
+  ! -------
+
+  ! modifications.
+  ! --------------
+  ! f.lott  for the new-gwdrag scheme november 1993
+
+  ! -----------------------------------------------------------------------
+  USE dimphy
+  IMPLICIT NONE
+
+
+  include "YOMCST.h"
+  include "YOEGWD.h"
+
+  ! -----------------------------------------------------------------------
+
+  ! *       0.1   arguments
+  ! ---------
+
+  INTEGER nlon
+  INTEGER jl, jk
+  REAL zdelp
+
+  INTEGER kkcrit(nlon), kkcrith(nlon), kcrit(nlon), ktest(nlon), kkenvh(nlon)
+
+
+  REAL paphm1(nlon, klev+1), papm1(nlon, klev), pum1(nlon, klev), &
+    pvm1(nlon, klev), ptm1(nlon, klev), pgeom1(nlon, klev), &
+    prho(nlon, klev+1), pri(nlon, klev+1), pstab(nlon, klev+1), &
+    ptau(nlon, klev+1), pvph(nlon, klev+1), ppsi(nlon, klev+1), &
+    pzdep(nlon, klev)
+  REAL pulow(nlon), pvlow(nlon), ptheta(nlon), pgamma(nlon), pnu(nlon), &
+    pd1(nlon), pd2(nlon), pdmod(nlon)
+  REAL pstd(nlon), pmea(nlon), ppic(nlon), pval(nlon)
+
+  ! -----------------------------------------------------------------------
+
+  ! *       0.2   local arrays
+  ! ------------
+
+
+  INTEGER ilevm1, ilevm2, ilevh
+  REAL zcons1, zcons2, zcons3, zhgeo
+  REAL zu, zphi, zvt1, zvt2, zst, zvar, zdwind, zwind
+  REAL zstabm, zstabp, zrhom, zrhop, alpha
+  REAL zggeenv, zggeom1, zgvar
+  LOGICAL lo
+  LOGICAL ll1(klon, klev+1)
+  INTEGER kknu(klon), kknu2(klon), kknub(klon), kknul(klon), kentp(klon), &
+    ncount(klon)
+
+  REAL zhcrit(klon, klev), zvpf(klon, klev), zdp(klon, klev)
+  REAL znorm(klon), zb(klon), zc(klon), zulow(klon), zvlow(klon), znup(klon), &
+    znum(klon)
+
+  ! ------------------------------------------------------------------
+
+  ! *         1.    initialization
+  ! --------------
+
+  ! print *,' entree gwsetup'
+
+  ! ------------------------------------------------------------------
+
+  ! *         1.1   computational constants
+  ! -----------------------
+
+
+  ilevm1 = klev - 1
+  ilevm2 = klev - 2
+  ilevh = klev/3
+
+  zcons1 = 1./rd
+  ! old  zcons2=g**2/cpd
+  zcons2 = rg**2/rcpd
+  ! old  zcons3=1.5*api
+  zcons3 = 1.5*rpi
+
+  ! ------------------------------------------------------------------
+
+  ! *         2.
+  ! --------------
+
+
+  ! ------------------------------------------------------------------
+
+  ! *         2.1     define low level wind, project winds in plane of
+  ! *                 low level wind, determine sector in which to take
+  ! *                 the variance and set indicator for critical levels.
+
+
+
+  DO jl = kidia, kfdia
+    kknu(jl) = klev
+    kknu2(jl) = klev
+    kknub(jl) = klev
+    kknul(jl) = klev
+    pgamma(jl) = max(pgamma(jl), gtsec)
+    ll1(jl, klev+1) = .FALSE.
+  END DO
+
+  ! Ajouter une initialisation (L. Li, le 23fev99):
+
+  DO jk = klev, ilevh, -1
+    DO jl = kidia, kfdia
+      ll1(jl, jk) = .FALSE.
+    END DO
+  END DO
+
+  ! *      define top of low level flow
+  ! ----------------------------
+  DO jk = klev, ilevh, -1
+    DO jl = kidia, kfdia
+      lo = (paphm1(jl,jk)/paphm1(jl,klev+1)) >= gsigcr
+      IF (lo) THEN
+        kkcrit(jl) = jk
+      END IF
+      zhcrit(jl, jk) = ppic(jl)
+      zhgeo = pgeom1(jl, jk)/rg
+      ll1(jl, jk) = (zhgeo>zhcrit(jl,jk))
+      IF (ll1(jl,jk) .NEQV. ll1(jl,jk+1)) THEN
+        kknu(jl) = jk
+      END IF
+      IF (.NOT. ll1(jl,ilevh)) kknu(jl) = ilevh
+    END DO
+  END DO
+  DO jk = klev, ilevh, -1
+    DO jl = kidia, kfdia
+      zhcrit(jl, jk) = ppic(jl) - pval(jl)
+      zhgeo = pgeom1(jl, jk)/rg
+      ll1(jl, jk) = (zhgeo>zhcrit(jl,jk))
+      IF (ll1(jl,jk) .NEQV. ll1(jl,jk+1)) THEN
+        kknu2(jl) = jk
+      END IF
+      IF (.NOT. ll1(jl,ilevh)) kknu2(jl) = ilevh
+    END DO
+  END DO
+  DO jk = klev, ilevh, -1
+    DO jl = kidia, kfdia
+      zhcrit(jl, jk) = amax1(ppic(jl)-pmea(jl), pmea(jl)-pval(jl))
+      zhgeo = pgeom1(jl, jk)/rg
+      ll1(jl, jk) = (zhgeo>zhcrit(jl,jk))
+      IF (ll1(jl,jk) .NEQV. ll1(jl,jk+1)) THEN
+        kknub(jl) = jk
+      END IF
+      IF (.NOT. ll1(jl,ilevh)) kknub(jl) = ilevh
+    END DO
+  END DO
+
+  DO jl = kidia, kfdia
+    kknu(jl) = min(kknu(jl), nktopg)
+    kknu2(jl) = min(kknu2(jl), nktopg)
+    kknub(jl) = min(kknub(jl), nktopg)
+    kknul(jl) = klev
+  END DO
+
+  ! c*     initialize various arrays
+
+  DO jl = kidia, kfdia
+    prho(jl, klev+1) = 0.0
+    pstab(jl, klev+1) = 0.0
+    pstab(jl, 1) = 0.0
+    pri(jl, klev+1) = 9999.0
+    ppsi(jl, klev+1) = 0.0
+    pri(jl, 1) = 0.0
+    pvph(jl, 1) = 0.0
+    pulow(jl) = 0.0
+    pvlow(jl) = 0.0
+    zulow(jl) = 0.0
+    zvlow(jl) = 0.0
+    kkcrith(jl) = klev
+    kkenvh(jl) = klev
+    kentp(jl) = klev
+    kcrit(jl) = 1
+    ncount(jl) = 0
+    ll1(jl, klev+1) = .FALSE.
+  END DO
+
+  ! *     define low-level flow
+  ! ---------------------
+
+  DO jk = klev, 2, -1
+    DO jl = kidia, kfdia
+      IF (ktest(jl)==1) THEN
+        zdp(jl, jk) = papm1(jl, jk) - papm1(jl, jk-1)
+        prho(jl, jk) = 2.*paphm1(jl, jk)*zcons1/(ptm1(jl,jk)+ptm1(jl,jk-1))
+        pstab(jl, jk) = 2.*zcons2/(ptm1(jl,jk)+ptm1(jl,jk-1))* &
+          (1.-rcpd*prho(jl,jk)*(ptm1(jl,jk)-ptm1(jl,jk-1))/zdp(jl,jk))
+        pstab(jl, jk) = max(pstab(jl,jk), gssec)
+      END IF
+    END DO
+  END DO
+
+  ! ********************************************************************
+
+  ! *     define blocked flow
+  ! -------------------
+  DO jk = klev, ilevh, -1
+    DO jl = kidia, kfdia
+      IF (jk>=kknub(jl) .AND. jk<=kknul(jl)) THEN
+        pulow(jl) = pulow(jl) + pum1(jl, jk)*(paphm1(jl,jk+1)-paphm1(jl,jk))
+        pvlow(jl) = pvlow(jl) + pvm1(jl, jk)*(paphm1(jl,jk+1)-paphm1(jl,jk))
+      END IF
+    END DO
+  END DO
+  DO jl = kidia, kfdia
+    pulow(jl) = pulow(jl)/(paphm1(jl,kknul(jl)+1)-paphm1(jl,kknub(jl)))
+    pvlow(jl) = pvlow(jl)/(paphm1(jl,kknul(jl)+1)-paphm1(jl,kknub(jl)))
+    znorm(jl) = max(sqrt(pulow(jl)**2+pvlow(jl)**2), gvsec)
+    pvph(jl, klev+1) = znorm(jl)
+  END DO
+
+  ! *******  setup orography axes and define plane of profiles  *******
+
+  DO jl = kidia, kfdia
+    lo = (pulow(jl)<gvsec) .AND. (pulow(jl)>=-gvsec)
+    IF (lo) THEN
+      zu = pulow(jl) + 2.*gvsec
+    ELSE
+      zu = pulow(jl)
+    END IF
+    zphi = atan(pvlow(jl)/zu)
+    ppsi(jl, klev+1) = ptheta(jl)*rpi/180. - zphi
+    zb(jl) = 1. - 0.18*pgamma(jl) - 0.04*pgamma(jl)**2
+    zc(jl) = 0.48*pgamma(jl) + 0.3*pgamma(jl)**2
+    pd1(jl) = zb(jl) - (zb(jl)-zc(jl))*(sin(ppsi(jl,klev+1))**2)
+    pd2(jl) = (zb(jl)-zc(jl))*sin(ppsi(jl,klev+1))*cos(ppsi(jl,klev+1))
+    pdmod(jl) = sqrt(pd1(jl)**2+pd2(jl)**2)
+  END DO
+
+  ! ************ define flow in plane of lowlevel stress *************
+
+  DO jk = 1, klev
+    DO jl = kidia, kfdia
+      IF (ktest(jl)==1) THEN
+        zvt1 = pulow(jl)*pum1(jl, jk) + pvlow(jl)*pvm1(jl, jk)
+        zvt2 = -pvlow(jl)*pum1(jl, jk) + pulow(jl)*pvm1(jl, jk)
+        zvpf(jl, jk) = (zvt1*pd1(jl)+zvt2*pd2(jl))/(znorm(jl)*pdmod(jl))
+      END IF
+      ptau(jl, jk) = 0.0
+      pzdep(jl, jk) = 0.0
+      ppsi(jl, jk) = 0.0
+      ll1(jl, jk) = .FALSE.
+    END DO
+  END DO
+  DO jk = 2, klev
+    DO jl = kidia, kfdia
+      IF (ktest(jl)==1) THEN
+        zdp(jl, jk) = papm1(jl, jk) - papm1(jl, jk-1)
+        pvph(jl, jk) = ((paphm1(jl,jk)-papm1(jl,jk-1))*zvpf(jl,jk)+(papm1(jl, &
+          jk)-paphm1(jl,jk))*zvpf(jl,jk-1))/zdp(jl, jk)
+        IF (pvph(jl,jk)<gvsec) THEN
+          pvph(jl, jk) = gvsec
+          kcrit(jl) = jk
+        END IF
+      END IF
+    END DO
+  END DO
+
+  ! *         2.2     brunt-vaisala frequency and density at half levels.
+
+
+  DO jk = ilevh, klev
+    DO jl = kidia, kfdia
+      IF (ktest(jl)==1) THEN
+        IF (jk>=(kknub(jl)+1) .AND. jk<=kknul(jl)) THEN
+          zst = zcons2/ptm1(jl, jk)*(1.-rcpd*prho(jl,jk)*(ptm1(jl, &
+            jk)-ptm1(jl,jk-1))/zdp(jl,jk))
+          pstab(jl, klev+1) = pstab(jl, klev+1) + zst*zdp(jl, jk)
+          pstab(jl, klev+1) = max(pstab(jl,klev+1), gssec)
+          prho(jl, klev+1) = prho(jl, klev+1) + paphm1(jl, jk)*2.*zdp(jl, jk) &
+            *zcons1/(ptm1(jl,jk)+ptm1(jl,jk-1))
+        END IF
+      END IF
+    END DO
+  END DO
+
+  DO jl = kidia, kfdia
+    pstab(jl, klev+1) = pstab(jl, klev+1)/(papm1(jl,kknul(jl))-papm1(jl,kknub &
+      (jl)))
+    prho(jl, klev+1) = prho(jl, klev+1)/(papm1(jl,kknul(jl))-papm1(jl,kknub( &
+      jl)))
+    zvar = pstd(jl)
+  END DO
+
+  ! *         2.3     mean flow richardson number.
+  ! *                 and critical height for froude layer
+
+
+  DO jk = 2, klev
+    DO jl = kidia, kfdia
+      IF (ktest(jl)==1) THEN
+        zdwind = max(abs(zvpf(jl,jk)-zvpf(jl,jk-1)), gvsec)
+        pri(jl, jk) = pstab(jl, jk)*(zdp(jl,jk)/(rg*prho(jl,jk)*zdwind))**2
+        pri(jl, jk) = max(pri(jl,jk), grcrit)
+      END IF
+    END DO
+  END DO
+
+
+
+  ! *      define top of 'envelope' layer
+  ! ----------------------------
+
+  DO jl = kidia, kfdia
+    pnu(jl) = 0.0
+    znum(jl) = 0.0
+  END DO
+
+  DO jk = 2, klev - 1
+    DO jl = kidia, kfdia
+
+      IF (ktest(jl)==1) THEN
+
+        IF (jk>=kknub(jl)) THEN
+
+          znum(jl) = pnu(jl)
+          zwind = (pulow(jl)*pum1(jl,jk)+pvlow(jl)*pvm1(jl,jk))/ &
+            max(sqrt(pulow(jl)**2+pvlow(jl)**2), gvsec)
+          zwind = max(sqrt(zwind**2), gvsec)
+          zdelp = paphm1(jl, jk+1) - paphm1(jl, jk)
+          zstabm = sqrt(max(pstab(jl,jk),gssec))
+          zstabp = sqrt(max(pstab(jl,jk+1),gssec))
+          zrhom = prho(jl, jk)
+          zrhop = prho(jl, jk+1)
+          pnu(jl) = pnu(jl) + (zdelp/rg)*((zstabp/zrhop+zstabm/zrhom)/2.)/ &
+            zwind
+          IF ((znum(jl)<=gfrcrit) .AND. (pnu(jl)>gfrcrit) .AND. (kkenvh( &
+            jl)==klev)) kkenvh(jl) = jk
+
+        END IF
+
+      END IF
+
+    END DO
+  END DO
+
+  ! calculation of a dynamical mixing height for the breaking
+  ! of gravity waves:
+
+
+  DO jl = kidia, kfdia
+    znup(jl) = 0.0
+    znum(jl) = 0.0
+  END DO
+
+  DO jk = klev - 1, 2, -1
+    DO jl = kidia, kfdia
+
+      IF (ktest(jl)==1) THEN
+
+        znum(jl) = znup(jl)
+        zwind = (pulow(jl)*pum1(jl,jk)+pvlow(jl)*pvm1(jl,jk))/ &
+          max(sqrt(pulow(jl)**2+pvlow(jl)**2), gvsec)
+        zwind = max(sqrt(zwind**2), gvsec)
+        zdelp = paphm1(jl, jk+1) - paphm1(jl, jk)
+        zstabm = sqrt(max(pstab(jl,jk),gssec))
+        zstabp = sqrt(max(pstab(jl,jk+1),gssec))
+        zrhom = prho(jl, jk)
+        zrhop = prho(jl, jk+1)
+        znup(jl) = znup(jl) + (zdelp/rg)*((zstabp/zrhop+zstabm/zrhom)/2.)/ &
+          zwind
+        IF ((znum(jl)<=rpi/2.) .AND. (znup(jl)>rpi/2.) .AND. (kkcrith( &
+          jl)==klev)) kkcrith(jl) = jk
+
+      END IF
+
+    END DO
+  END DO
+
+  DO jl = kidia, kfdia
+    kkcrith(jl) = min0(kkcrith(jl), kknu2(jl))
+    kkcrith(jl) = max0(kkcrith(jl), ilevh*2)
+  END DO
+
+  ! directional info for flow blocking *************************
+
+  DO jk = ilevh, klev
+    DO jl = kidia, kfdia
+      IF (jk>=kkenvh(jl)) THEN
+        lo = (pum1(jl,jk)<gvsec) .AND. (pum1(jl,jk)>=-gvsec)
+        IF (lo) THEN
+          zu = pum1(jl, jk) + 2.*gvsec
+        ELSE
+          zu = pum1(jl, jk)
+        END IF
+        zphi = atan(pvm1(jl,jk)/zu)
+        ppsi(jl, jk) = ptheta(jl)*rpi/180. - zphi
+      END IF
+    END DO
+  END DO
+  ! forms the vertical 'leakiness' **************************
+
+  alpha = 3.
+
+  DO jk = ilevh, klev
+    DO jl = kidia, kfdia
+      IF (jk>=kkenvh(jl)) THEN
+        zggeenv = amax1(1., (pgeom1(jl,kkenvh(jl))+pgeom1(jl, &
+          kkenvh(jl)-1))/2.)
+        zggeom1 = amax1(pgeom1(jl,jk), 1.)
+        zgvar = amax1(pstd(jl)*rg, 1.)
+        ! mod    pzdep(jl,jk)=sqrt((zggeenv-zggeom1)/(zggeom1+zgvar))
+        pzdep(jl, jk) = (pgeom1(jl,kkenvh(jl)-1)-pgeom1(jl,jk))/ &
+          (pgeom1(jl,kkenvh(jl)-1)-pgeom1(jl,klev))
+      END IF
+    END DO
+  END DO
+
+  RETURN
+END SUBROUTINE orosetup
+SUBROUTINE gwstress(nlon, nlev, ktest, kcrit, kkenvh, kknu, prho, pstab, &
+    pvph, pstd, psig, pmea, ppic, ptau, pgeom1, pdmod)
+
+  ! **** *gwstress*
+
+  ! purpose.
+  ! --------
+
+  ! **   interface.
+  ! ----------
+  ! call *gwstress*  from *gwdrag*
+
+  ! explicit arguments :
+  ! --------------------
+  ! ==== inputs ===
+  ! ==== outputs ===
+
+  ! implicit arguments :   none
+  ! --------------------
+
+  ! method.
+  ! -------
+
+
+  ! externals.
+  ! ----------
+
+
+  ! reference.
+  ! ----------
+
+  ! see ecmwf research department documentation of the "i.f.s."
+
+  ! author.
+  ! -------
+
+  ! modifications.
+  ! --------------
+  ! f. lott put the new gwd on ifs      22/11/93
+
+  ! -----------------------------------------------------------------------
+  USE dimphy
+  IMPLICIT NONE
+  include "YOMCST.h"
+  include "YOEGWD.h"
+
+  ! -----------------------------------------------------------------------
+
+  ! *       0.1   arguments
+  ! ---------
+
+  INTEGER nlon, nlev
+  INTEGER kcrit(nlon), ktest(nlon), kkenvh(nlon), kknu(nlon)
+
+  REAL prho(nlon, nlev+1), pstab(nlon, nlev+1), ptau(nlon, nlev+1), &
+    pvph(nlon, nlev+1), pgeom1(nlon, nlev), pstd(nlon)
+
+  REAL psig(nlon)
+  REAL pmea(nlon), ppic(nlon)
+  REAL pdmod(nlon)
+
+  ! -----------------------------------------------------------------------
+
+  ! *       0.2   local arrays
+  ! ------------
+  INTEGER jl
+  REAL zblock, zvar, zeff
+  LOGICAL lo
+
+  ! -----------------------------------------------------------------------
+
+  ! *       0.3   functions
+  ! ---------
+  ! ------------------------------------------------------------------
+
+  ! *         1.    initialization
+  ! --------------
+
+
+  ! *         3.1     gravity wave stress.
+
+
+
+  DO jl = kidia, kfdia
+    IF (ktest(jl)==1) THEN
+
+      ! effective mountain height above the blocked flow
+
+      IF (kkenvh(jl)==klev) THEN
+        zblock = 0.0
+      ELSE
+        zblock = (pgeom1(jl,kkenvh(jl))+pgeom1(jl,kkenvh(jl)+1))/2./rg
+      END IF
+
+      zvar = ppic(jl) - pmea(jl)
+      zeff = amax1(0., zvar-zblock)
+
+      ptau(jl, klev+1) = prho(jl, klev+1)*gkdrag*psig(jl)*zeff**2/4./ &
+        pstd(jl)*pvph(jl, klev+1)*pdmod(jl)*sqrt(pstab(jl,klev+1))
+
+      ! too small value of stress or  low level flow include critical level
+      ! or low level flow:  gravity wave stress nul.
+
+      lo = (ptau(jl,klev+1)<gtsec) .OR. (kcrit(jl)>=kknu(jl)) .OR. &
+        (pvph(jl,klev+1)<gvcrit)
+      ! if(lo) ptau(jl,klev+1)=0.0
+
+    ELSE
+
+      ptau(jl, klev+1) = 0.0
+
+    END IF
+
+  END DO
+
+  RETURN
+END SUBROUTINE gwstress
+SUBROUTINE gwprofil(nlon, nlev, kgwd, kdx, ktest, kkcrith, kcrit, paphm1, &
+    prho, pstab, pvph, pri, ptau, pdmod, psig, pvar)
+
+  ! **** *GWPROFIL*
+
+  ! PURPOSE.
+  ! --------
+
+  ! **   INTERFACE.
+  ! ----------
+  ! FROM *GWDRAG*
+
+  ! EXPLICIT ARGUMENTS :
+  ! --------------------
+  ! ==== INPUTS ===
+  ! ==== OUTPUTS ===
+
+  ! IMPLICIT ARGUMENTS :   NONE
+  ! --------------------
+
+  ! METHOD:
+  ! -------
+  ! THE STRESS PROFILE FOR GRAVITY WAVES IS COMPUTED AS FOLLOWS:
+  ! IT IS CONSTANT (NO GWD) AT THE LEVELS BETWEEN THE GROUND
+  ! AND THE TOP OF THE BLOCKED LAYER (KKENVH).
+  ! IT DECREASES LINEARLY WITH HEIGHTS FROM THE TOP OF THE
+  ! BLOCKED LAYER TO 3*VAROR (kKNU), TO SIMULATES LEE WAVES OR
+  ! NONLINEAR GRAVITY WAVE BREAKING.
+  ! ABOVE IT IS CONSTANT, EXCEPT WHEN THE WAVE ENCOUNTERS A CRITICAL
+  ! LEVEL (KCRIT) OR WHEN IT BREAKS.
+
+
+
+  ! EXTERNALS.
+  ! ----------
+
+
+  ! REFERENCE.
+  ! ----------
+
+  ! SEE ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE "I.F.S."
+
+  ! AUTHOR.
+  ! -------
+
+  ! MODIFICATIONS.
+  ! --------------
+  ! PASSAGE OF THE NEW GWDRAG TO I.F.S. (F. LOTT, 22/11/93)
+  ! -----------------------------------------------------------------------
+  USE dimphy
+  IMPLICIT NONE
+
+
+
+
+  include "YOMCST.h"
+  include "YOEGWD.h"
+
+  ! -----------------------------------------------------------------------
+
+  ! *       0.1   ARGUMENTS
+  ! ---------
+
+  INTEGER nlon, nlev
+  INTEGER kkcrith(nlon), kcrit(nlon), kdx(nlon), ktest(nlon)
+
+
+  REAL paphm1(nlon, nlev+1), pstab(nlon, nlev+1), prho(nlon, nlev+1), &
+    pvph(nlon, nlev+1), pri(nlon, nlev+1), ptau(nlon, nlev+1)
+
+  REAL pdmod(nlon), psig(nlon), pvar(nlon)
+
+  ! -----------------------------------------------------------------------
+
+  ! *       0.2   LOCAL ARRAYS
+  ! ------------
+
+  INTEGER ilevh, ji, kgwd, jl, jk
+  REAL zsqr, zalfa, zriw, zdel, zb, zalpha, zdz2n
+  REAL zdelp, zdelpt
+  REAL zdz2(klon, klev), znorm(klon), zoro(klon)
+  REAL ztau(klon, klev+1)
+
+  ! -----------------------------------------------------------------------
+
+  ! *         1.    INITIALIZATION
+  ! --------------
+
+  ! print *,' entree gwprofil'
+
+
+  ! *    COMPUTATIONAL CONSTANTS.
+  ! ------------- ----------
+
+  ilevh = klev/3
+
+  ! DO 400 ji=1,kgwd
+  ! jl=kdx(ji)
+  ! Modif vectorisation 02/04/2004
+  DO jl = kidia, kfdia
+    IF (ktest(jl)==1) THEN
+      zoro(jl) = psig(jl)*pdmod(jl)/4./max(pvar(jl), 1.0)
+      ztau(jl, klev+1) = ptau(jl, klev+1)
+    END IF
+  END DO
+
+
+  DO jk = klev, 2, -1
+
+    ! *         4.1    CONSTANT WAVE STRESS UNTIL TOP OF THE
+    ! BLOCKING LAYER.
+
+    ! DO 411 ji=1,kgwd
+    ! jl=kdx(ji)
+    ! Modif vectorisation 02/04/2004
+    DO jl = kidia, kfdia
+      IF (ktest(jl)==1) THEN
+        IF (jk>kkcrith(jl)) THEN
+          ptau(jl, jk) = ztau(jl, klev+1)
+          ! ENDIF
+          ! IF(JK.EQ.KKCRITH(JL)) THEN
+        ELSE
+          ptau(jl, jk) = grahilo*ztau(jl, klev+1)
+        END IF
+      END IF
+    END DO
+
+    ! *         4.15   CONSTANT SHEAR STRESS UNTIL THE TOP OF THE
+    ! LOW LEVEL FLOW LAYER.
+
+
+    ! *         4.2    WAVE DISPLACEMENT AT NEXT LEVEL.
+
+
+    ! DO 421 ji=1,kgwd
+    ! jl=kdx(ji)
+    ! Modif vectorisation 02/04/2004
+    DO jl = kidia, kfdia
+      IF (ktest(jl)==1) THEN
+        IF (jk<kkcrith(jl)) THEN
+          znorm(jl) = gkdrag*prho(jl, jk)*sqrt(pstab(jl,jk))*pvph(jl, jk)* &
+            zoro(jl)
+          zdz2(jl, jk) = ptau(jl, jk+1)/max(znorm(jl), gssec)
+        END IF
+      END IF
+    END DO
+
+    ! *         4.3    WAVE RICHARDSON NUMBER, NEW WAVE DISPLACEMENT
+    ! *                AND STRESS:  BREAKING EVALUATION AND CRITICAL
+    ! LEVEL
+
+
+    ! DO 431 ji=1,kgwd
+    ! jl=Kdx(ji)
+    ! Modif vectorisation 02/04/2004
+    DO jl = kidia, kfdia
+      IF (ktest(jl)==1) THEN
+
+        IF (jk<kkcrith(jl)) THEN
+          IF ((ptau(jl,jk+1)<gtsec) .OR. (jk<=kcrit(jl))) THEN
+            ptau(jl, jk) = 0.0
+          ELSE
+            zsqr = sqrt(pri(jl,jk))
+            zalfa = sqrt(pstab(jl,jk)*zdz2(jl,jk))/pvph(jl, jk)
+            zriw = pri(jl, jk)*(1.-zalfa)/(1+zalfa*zsqr)**2
+            IF (zriw<grcrit) THEN
+              zdel = 4./zsqr/grcrit + 1./grcrit**2 + 4./grcrit
+              zb = 1./grcrit + 2./zsqr
+              zalpha = 0.5*(-zb+sqrt(zdel))
+              zdz2n = (pvph(jl,jk)*zalpha)**2/pstab(jl, jk)
+              ptau(jl, jk) = znorm(jl)*zdz2n
+            ELSE
+              ptau(jl, jk) = znorm(jl)*zdz2(jl, jk)
+            END IF
+            ptau(jl, jk) = min(ptau(jl,jk), ptau(jl,jk+1))
+          END IF
+        END IF
+      END IF
+    END DO
+
+  END DO
+
+  ! REORGANISATION OF THE STRESS PROFILE AT LOW LEVEL
+
+  ! DO 530 ji=1,kgwd
+  ! jl=kdx(ji)
+  ! Modif vectorisation 02/04/2004
+  DO jl = kidia, kfdia
+    IF (ktest(jl)==1) THEN
+      ztau(jl, kkcrith(jl)) = ptau(jl, kkcrith(jl))
+      ztau(jl, nstra) = ptau(jl, nstra)
+    END IF
+  END DO
+
+  DO jk = 1, klev
+
+    ! DO 532 ji=1,kgwd
+    ! jl=kdx(ji)
+    ! Modif vectorisation 02/04/2004
+    DO jl = kidia, kfdia
+      IF (ktest(jl)==1) THEN
+
+
+        IF (jk>kkcrith(jl)) THEN
+
+          zdelp = paphm1(jl, jk) - paphm1(jl, klev+1)
+          zdelpt = paphm1(jl, kkcrith(jl)) - paphm1(jl, klev+1)
+          ptau(jl, jk) = ztau(jl, klev+1) + (ztau(jl,kkcrith(jl))-ztau(jl, &
+            klev+1))*zdelp/zdelpt
+
+        END IF
+
+      END IF
+    END DO
+
+    ! REORGANISATION IN THE STRATOSPHERE
+
+    ! DO 533 ji=1,kgwd
+    ! jl=kdx(ji)
+    ! Modif vectorisation 02/04/2004
+    DO jl = kidia, kfdia
+      IF (ktest(jl)==1) THEN
+
+
+        IF (jk<nstra) THEN
+
+          zdelp = paphm1(jl, nstra)
+          zdelpt = paphm1(jl, jk)
+          ptau(jl, jk) = ztau(jl, nstra)*zdelpt/zdelp
+
+        END IF
+
+      END IF
+    END DO
+
+    ! REORGANISATION IN THE TROPOSPHERE
+
+    ! DO 534 ji=1,kgwd
+    ! jl=kdx(ji)
+    ! Modif vectorisation 02/04/2004
+    DO jl = kidia, kfdia
+      IF (ktest(jl)==1) THEN
+
+
+        IF (jk<kkcrith(jl) .AND. jk>nstra) THEN
+
+          zdelp = paphm1(jl, jk) - paphm1(jl, kkcrith(jl))
+          zdelpt = paphm1(jl, nstra) - paphm1(jl, kkcrith(jl))
+          ptau(jl, jk) = ztau(jl, kkcrith(jl)) + (ztau(jl,nstra)-ztau(jl, &
+            kkcrith(jl)))*zdelp/zdelpt
+
+        END IF
+      END IF
+    END DO
+
+
+  END DO
+
+
+  RETURN
+END SUBROUTINE gwprofil
+SUBROUTINE lift_noro(nlon, nlev, dtime, paprs, pplay, plat, pmea, pstd, ppic, &
+    ktest, t, u, v, pulow, pvlow, pustr, pvstr, d_t, d_u, d_v)
+
+  USE dimphy
+  IMPLICIT NONE
+  ! ======================================================================
+  ! Auteur(s): F.Lott (LMD/CNRS) date: 19950201
+  ! Objet: Frottement de la montagne Interface
+  ! ======================================================================
+  ! Arguments:
+  ! dtime---input-R- pas d'integration (s)
+  ! paprs---input-R-pression pour chaque inter-couche (en Pa)
+  ! pplay---input-R-pression pour le mileu de chaque couche (en Pa)
+  ! t-------input-R-temperature (K)
+  ! u-------input-R-vitesse horizontale (m/s)
+  ! v-------input-R-vitesse horizontale (m/s)
+
+  ! d_t-----output-R-increment de la temperature
+  ! d_u-----output-R-increment de la vitesse u
+  ! d_v-----output-R-increment de la vitesse v
+  ! ======================================================================
+  include "YOMCST.h"
+
+  ! ARGUMENTS
+
+  INTEGER nlon, nlev
+  REAL dtime
+  REAL paprs(klon, klev+1)
+  REAL pplay(klon, klev)
+  REAL plat(nlon), pmea(nlon)
+  REAL pstd(nlon)
+  REAL ppic(nlon)
+  REAL pulow(nlon), pvlow(nlon), pustr(nlon), pvstr(nlon)
+  REAL t(nlon, nlev), u(nlon, nlev), v(nlon, nlev)
+  REAL d_t(nlon, nlev), d_u(nlon, nlev), d_v(nlon, nlev)
+
+  INTEGER i, k, ktest(nlon)
+
+  ! Variables locales:
+
+  REAL zgeom(klon, klev)
+  REAL pdtdt(klon, klev), pdudt(klon, klev), pdvdt(klon, klev)
+  REAL pt(klon, klev), pu(klon, klev), pv(klon, klev)
+  REAL papmf(klon, klev), papmh(klon, klev+1)
+
+  ! initialiser les variables de sortie (pour securite)
+
+  DO i = 1, klon
+    pulow(i) = 0.0
+    pvlow(i) = 0.0
+    pustr(i) = 0.0
+    pvstr(i) = 0.0
+  END DO
+  DO k = 1, klev
+    DO i = 1, klon
+      d_t(i, k) = 0.0
+      d_u(i, k) = 0.0
+      d_v(i, k) = 0.0
+      pdudt(i, k) = 0.0
+      pdvdt(i, k) = 0.0
+      pdtdt(i, k) = 0.0
+    END DO
+  END DO
+
+  ! preparer les variables d'entree (attention: l'ordre des niveaux
+  ! verticaux augmente du haut vers le bas)
+
+  DO k = 1, klev
+    DO i = 1, klon
+      pt(i, k) = t(i, klev-k+1)
+      pu(i, k) = u(i, klev-k+1)
+      pv(i, k) = v(i, klev-k+1)
+      papmf(i, k) = pplay(i, klev-k+1)
+    END DO
+  END DO
+  DO k = 1, klev + 1
+    DO i = 1, klon
+      papmh(i, k) = paprs(i, klev-k+2)
+    END DO
+  END DO
+  DO i = 1, klon
+    zgeom(i, klev) = rd*pt(i, klev)*log(papmh(i,klev+1)/papmf(i,klev))
+  END DO
+  DO k = klev - 1, 1, -1
+    DO i = 1, klon
+      zgeom(i, k) = zgeom(i, k+1) + rd*(pt(i,k)+pt(i,k+1))/2.0*log(papmf(i,k+ &
+        1)/papmf(i,k))
+    END DO
+  END DO
+
+  ! appeler la routine principale
+
+  CALL orolift(klon, klev, ktest, dtime, papmh, zgeom, pt, pu, pv, plat, &
+    pmea, pstd, ppic, pulow, pvlow, pdudt, pdvdt, pdtdt)
+
+  DO k = 1, klev
+    DO i = 1, klon
+      d_u(i, klev+1-k) = dtime*pdudt(i, k)
+      d_v(i, klev+1-k) = dtime*pdvdt(i, k)
+      d_t(i, klev+1-k) = dtime*pdtdt(i, k)
+      pustr(i) = pustr(i) &        ! IM BUG .
+                                   ! +RG*pdudt(i,k)*(papmh(i,k+1)-papmh(i,k))
+        +pdudt(i, k)*(papmh(i,k+1)-papmh(i,k))/rg
+      pvstr(i) = pvstr(i) &        ! IM BUG .
+                                   ! +RG*pdvdt(i,k)*(papmh(i,k+1)-papmh(i,k))
+        +pdvdt(i, k)*(papmh(i,k+1)-papmh(i,k))/rg
+    END DO
+  END DO
+
+  RETURN
+END SUBROUTINE lift_noro
+SUBROUTINE orolift(nlon, nlev, ktest, ptsphy, paphm1, pgeom1, ptm1, pum1, &
+    pvm1, plat, pmea, pvaror, ppic & ! OUTPUTS
+    , pulow, pvlow, pvom, pvol, pte)
+
+
+  ! **** *OROLIFT: SIMULATE THE GEOSTROPHIC LIFT.
+
+  ! PURPOSE.
+  ! --------
+
+  ! **   INTERFACE.
+  ! ----------
+  ! CALLED FROM *lift_noro
+  ! ----------
+
+  ! AUTHOR.
+  ! -------
+  ! F.LOTT  LMD 22/11/95
+
+  USE dimphy
+  IMPLICIT NONE
+
+
+  include "YOMCST.h"
+  include "YOEGWD.h"
+  ! -----------------------------------------------------------------------
+
+  ! *       0.1   ARGUMENTS
+  ! ---------
+
+
+  INTEGER nlon, nlev
+  REAL pte(nlon, nlev), pvol(nlon, nlev), pvom(nlon, nlev), pulow(nlon), &
+    pvlow(nlon)
+  REAL pum1(nlon, nlev), pvm1(nlon, nlev), ptm1(nlon, nlev), plat(nlon), &
+    pmea(nlon), pvaror(nlon), ppic(nlon), pgeom1(nlon, nlev), &
+    paphm1(nlon, nlev+1)
+
+  INTEGER ktest(nlon)
+  REAL ptsphy
+  ! -----------------------------------------------------------------------
+
+  ! *       0.2   LOCAL ARRAYS
+  ! ------------
+  LOGICAL lifthigh
+  ! ym      integer klevm1, jl, ilevh, jk
+  INTEGER jl, ilevh, jk
+  REAL zcons1, ztmst, zrtmst, zpi, zhgeo
+  REAL zdelp, zslow, zsqua, zscav, zbet
+  INTEGER iknub(klon), iknul(klon)
+  LOGICAL ll1(klon, klev+1)
+
+  REAL ztau(klon, klev+1), ztav(klon, klev+1), zrho(klon, klev+1)
+  REAL zdudt(klon), zdvdt(klon)
+  REAL zhcrit(klon, klev)
+  CHARACTER (LEN=20) :: modname = 'orografi'
+  CHARACTER (LEN=80) :: abort_message
+  ! -----------------------------------------------------------------------
+
+  ! *         1.1  INITIALIZATIONS
+  ! ---------------
+
+  lifthigh = .FALSE.
+
+  IF (nlon/=klon .OR. nlev/=klev) THEN
+    abort_message = 'pb dimension'
+    CALL abort_physic(modname, abort_message, 1)
+  END IF
+  zcons1 = 1./rd
+  ! ym      KLEVM1=KLEV-1
+  ztmst = ptsphy
+  zrtmst = 1./ztmst
+  zpi = acos(-1.)
+
+  DO jl = kidia, kfdia
+    zrho(jl, klev+1) = 0.0
+    pulow(jl) = 0.0
+    pvlow(jl) = 0.0
+    iknub(jl) = klev
+    iknul(jl) = klev
+    ilevh = klev/3
+    ll1(jl, klev+1) = .FALSE.
+    DO jk = 1, klev
+      pvom(jl, jk) = 0.0
+      pvol(jl, jk) = 0.0
+      pte(jl, jk) = 0.0
+    END DO
+  END DO
+
+
+  ! *         2.1     DEFINE LOW LEVEL WIND, PROJECT WINDS IN PLANE OF
+  ! *                 LOW LEVEL WIND, DETERMINE SECTOR IN WHICH TO TAKE
+  ! *                 THE VARIANCE AND SET INDICATOR FOR CRITICAL LEVELS.
+
+
+
+  DO jk = klev, 1, -1
+    DO jl = kidia, kfdia
+      IF (ktest(jl)==1) THEN
+        zhcrit(jl, jk) = amax1(ppic(jl)-pmea(jl), 100.)
+        zhgeo = pgeom1(jl, jk)/rg
+        ll1(jl, jk) = (zhgeo>zhcrit(jl,jk))
+        IF (ll1(jl,jk) .NEQV. ll1(jl,jk+1)) THEN
+          iknub(jl) = jk
+        END IF
+      END IF
+    END DO
+  END DO
+
+  DO jl = kidia, kfdia
+    IF (ktest(jl)==1) THEN
+      iknub(jl) = max(iknub(jl), klev/2)
+      iknul(jl) = max(iknul(jl), 2*klev/3)
+      IF (iknub(jl)>nktopg) iknub(jl) = nktopg
+      IF (iknub(jl)==nktopg) iknul(jl) = klev
+      IF (iknub(jl)==iknul(jl)) iknub(jl) = iknul(jl) - 1
+    END IF
+  END DO
+
+  ! do 2011 jl=kidia,kfdia
+  ! IF(KTEST(JL).EQ.1) THEN
+  ! print *,' iknul= ',iknul(jl),'  iknub=',iknub(jl)
+  ! ENDIF
+  ! 2011 continue
+
+  ! PRINT *,'  DANS OROLIFT: 2010'
+
+  DO jk = klev, 2, -1
+    DO jl = kidia, kfdia
+      zrho(jl, jk) = 2.*paphm1(jl, jk)*zcons1/(ptm1(jl,jk)+ptm1(jl,jk-1))
+    END DO
+  END DO
+  ! PRINT *,'  DANS OROLIFT: 223'
+
+  ! ********************************************************************
+
+  ! *     DEFINE LOW LEVEL FLOW
+  ! -------------------
+  DO jk = klev, 1, -1
+    DO jl = kidia, kfdia
+      IF (ktest(jl)==1) THEN
+        IF (jk>=iknub(jl) .AND. jk<=iknul(jl)) THEN
+          pulow(jl) = pulow(jl) + pum1(jl, jk)*(paphm1(jl,jk+1)-paphm1(jl,jk) &
+            )
+          pvlow(jl) = pvlow(jl) + pvm1(jl, jk)*(paphm1(jl,jk+1)-paphm1(jl,jk) &
+            )
+          zrho(jl, klev+1) = zrho(jl, klev+1) + zrho(jl, jk)*(paphm1(jl,jk+1) &
+            -paphm1(jl,jk))
+        END IF
+      END IF
+    END DO
+  END DO
+  DO jl = kidia, kfdia
+    IF (ktest(jl)==1) THEN
+      pulow(jl) = pulow(jl)/(paphm1(jl,iknul(jl)+1)-paphm1(jl,iknub(jl)))
+      pvlow(jl) = pvlow(jl)/(paphm1(jl,iknul(jl)+1)-paphm1(jl,iknub(jl)))
+      zrho(jl, klev+1) = zrho(jl, klev+1)/(paphm1(jl,iknul(jl)+1)-paphm1(jl, &
+        iknub(jl)))
+    END IF
+  END DO
+
+  ! ***********************************************************
+
+  ! *         3.      COMPUTE MOUNTAIN LIFT
+
+
+  DO jl = kidia, kfdia
+    IF (ktest(jl)==1) THEN
+      ztau(jl, klev+1) = -gklift*zrho(jl, klev+1)*2.*romega* & ! *
+                                                               ! (2*PVAROR(JL)+PMEA(JL))*
+        2*pvaror(jl)*sin(zpi/180.*plat(jl))*pvlow(jl)
+      ztav(jl, klev+1) = gklift*zrho(jl, klev+1)*2.*romega* & ! *
+                                                              ! (2*PVAROR(JL)+PMEA(JL))*
+        2*pvaror(jl)*sin(zpi/180.*plat(jl))*pulow(jl)
+    ELSE
+      ztau(jl, klev+1) = 0.0
+      ztav(jl, klev+1) = 0.0
+    END IF
+  END DO
+
+  ! *         4.      COMPUTE LIFT PROFILE
+  ! *                 --------------------
+
+
+
+  DO jk = 1, klev
+    DO jl = kidia, kfdia
+      IF (ktest(jl)==1) THEN
+        ztau(jl, jk) = ztau(jl, klev+1)*paphm1(jl, jk)/paphm1(jl, klev+1)
+        ztav(jl, jk) = ztav(jl, klev+1)*paphm1(jl, jk)/paphm1(jl, klev+1)
+      ELSE
+        ztau(jl, jk) = 0.0
+        ztav(jl, jk) = 0.0
+      END IF
+    END DO
+  END DO
+
+
+  ! *         5.      COMPUTE TENDENCIES.
+  ! *                 -------------------
+  IF (lifthigh) THEN
+    ! PRINT *,'  DANS OROLIFT: 500'
+
+    ! EXPLICIT SOLUTION AT ALL LEVELS
+
+    DO jk = 1, klev
+      DO jl = kidia, kfdia
+        IF (ktest(jl)==1) THEN
+          zdelp = paphm1(jl, jk+1) - paphm1(jl, jk)
+          zdudt(jl) = -rg*(ztau(jl,jk+1)-ztau(jl,jk))/zdelp
+          zdvdt(jl) = -rg*(ztav(jl,jk+1)-ztav(jl,jk))/zdelp
+        END IF
+      END DO
+    END DO
+
+    ! PROJECT PERPENDICULARLY TO U NOT TO DESTROY ENERGY
+
+    DO jk = 1, klev
+      DO jl = kidia, kfdia
+        IF (ktest(jl)==1) THEN
+
+          zslow = sqrt(pulow(jl)**2+pvlow(jl)**2)
+          zsqua = amax1(sqrt(pum1(jl,jk)**2+pvm1(jl,jk)**2), gvsec)
+          zscav = -zdudt(jl)*pvm1(jl, jk) + zdvdt(jl)*pum1(jl, jk)
+          IF (zsqua>gvsec) THEN
+            pvom(jl, jk) = -zscav*pvm1(jl, jk)/zsqua**2
+            pvol(jl, jk) = zscav*pum1(jl, jk)/zsqua**2
+          ELSE
+            pvom(jl, jk) = 0.0
+            pvol(jl, jk) = 0.0
+          END IF
+          zsqua = sqrt(pum1(jl,jk)**2+pum1(jl,jk)**2)
+          IF (zsqua<zslow) THEN
+            pvom(jl, jk) = zsqua/zslow*pvom(jl, jk)
+            pvol(jl, jk) = zsqua/zslow*pvol(jl, jk)
+          END IF
+
+        END IF
+      END DO
+    END DO
+
+    ! 6.  LOW LEVEL LIFT, SEMI IMPLICIT:
+    ! ----------------------------------
+
+  ELSE
+
+    DO jl = kidia, kfdia
+      IF (ktest(jl)==1) THEN
+        DO jk = klev, iknub(jl), -1
+          zbet = gklift*2.*romega*sin(zpi/180.*plat(jl))*ztmst* &
+            (pgeom1(jl,iknub(jl)-1)-pgeom1(jl,jk))/ &
+            (pgeom1(jl,iknub(jl)-1)-pgeom1(jl,klev))
+          zdudt(jl) = -pum1(jl, jk)/ztmst/(1+zbet**2)
+          zdvdt(jl) = -pvm1(jl, jk)/ztmst/(1+zbet**2)
+          pvom(jl, jk) = zbet**2*zdudt(jl) - zbet*zdvdt(jl)
+          pvol(jl, jk) = zbet*zdudt(jl) + zbet**2*zdvdt(jl)
+        END DO
+      END IF
+    END DO
+
+  END IF
+
+  RETURN
+END SUBROUTINE orolift
+
+
+SUBROUTINE sugwd(nlon, nlev, paprs, pplay)
+  USE dimphy
+  USE mod_phys_lmdz_para
+  USE mod_grid_phy_lmdz
+  ! USE parallel
+
+  ! **** *SUGWD* INITIALIZE COMMON YOEGWD CONTROLLING GRAVITY WAVE DRAG
+
+  ! PURPOSE.
+  ! --------
+  ! INITIALIZE YOEGWD, THE COMMON THAT CONTROLS THE
+  ! GRAVITY WAVE DRAG PARAMETRIZATION.
+
+  ! **   INTERFACE.
+  ! ----------
+  ! CALL *SUGWD* FROM *SUPHEC*
+  ! -----        ------
+
+  ! EXPLICIT ARGUMENTS :
+  ! --------------------
+  ! PSIG        : VERTICAL COORDINATE TABLE
+  ! NLEV        : NUMBER OF MODEL LEVELS
+
+  ! IMPLICIT ARGUMENTS :
+  ! --------------------
+  ! COMMON YOEGWD
+
+  ! METHOD.
+  ! -------
+  ! SEE DOCUMENTATION
+
+  ! EXTERNALS.
+  ! ----------
+  ! NONE
+
+  ! REFERENCE.
+  ! ----------
+  ! ECMWF Research Department documentation of the IFS
+
+  ! AUTHOR.
+  ! -------
+  ! MARTIN MILLER             *ECMWF*
+
+  ! MODIFICATIONS.
+  ! --------------
+  ! ORIGINAL : 90-01-01
+  ! ------------------------------------------------------------------
+  IMPLICIT NONE
+
+  ! -----------------------------------------------------------------
+  include "YOEGWD.h"
+  ! ----------------------------------------------------------------
+
+  INTEGER nlon, nlev, jk
+  REAL paprs(nlon, nlev+1)
+  REAL pplay(nlon, nlev)
+  REAL zpr, zstra, zsigt, zpm1r
+  REAL :: pplay_glo(klon_glo, nlev)
+  REAL :: paprs_glo(klon_glo, nlev+1)
+
+  ! *       1.    SET THE VALUES OF THE PARAMETERS
+  ! --------------------------------
+
+
+  PRINT *, ' DANS SUGWD NLEV=', nlev
+  ghmax = 10000.
+
+  zpr = 100000.
+  zstra = 0.1
+  zsigt = 0.94
+  ! old  ZPR=80000.
+  ! old  ZSIGT=0.85
+
+
+  CALL gather(pplay, pplay_glo)
+  CALL bcast(pplay_glo)
+  CALL gather(paprs, paprs_glo)
+  CALL bcast(paprs_glo)
+
+
+  DO jk = 1, nlev
+    zpm1r = pplay_glo((klon_glo/2)+1, jk)/paprs_glo((klon_glo/2)+1, 1)
+    IF (zpm1r>=zsigt) THEN
+      nktopg = jk
+    END IF
+    zpm1r = pplay_glo((klon_glo/2)+1, jk)/paprs_glo((klon_glo/2)+1, 1)
+    IF (zpm1r>=zstra) THEN
+      nstra = jk
+    END IF
+  END DO
+
+
+
+  ! inversion car dans orodrag on compte les niveaux a l'envers
+  nktopg = nlev - nktopg + 1
+  nstra = nlev - nstra
+  PRINT *, ' DANS SUGWD nktopg=', nktopg
+  PRINT *, ' DANS SUGWD nstra=', nstra
+
+  gsigcr = 0.80
+
+!  Values now specified in run.def, or conf_phys_m.F90
+!  gkdrag = 0.2
+!  grahilo = 1.
+!  grcrit = 0.01
+!  gfrcrit = 1.0
+!  gkwake = 0.50
+! gklift = 0.50
+  gvcrit = 0.0
+
+  ! ----------------------------------------------------------------
+
+  ! *       2.    SET VALUES OF SECURITY PARAMETERS
+  ! ---------------------------------
+
+
+  gvsec = 0.10
+  gssec = 1.E-12
+
+  gtsec = 1.E-07
+
+  ! ----------------------------------------------------------------
+
+  RETURN
+END SUBROUTINE sugwd
Index: DZ6/trunk/libf/phylmd/orografi_strato.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/orografi_strato.F90	(revision 5267)
+++ 	(revision )
@@ -1,1938 +1,0 @@
-SUBROUTINE drag_noro_strato(partdrag, nlon, nlev, dtime, paprs, pplay, pmea, pstd, &
-    psig, pgam, pthe, ppic, pval, kgwd, kdx, ktest, t, u, v, pulow, pvlow, &
-    pustr, pvstr, d_t, d_u, d_v)
-
-  USE dimphy
-  IMPLICIT NONE
-  ! ======================================================================
-  ! Auteur(s): F.Lott (LMD/CNRS) date: 19950201
-  ! Object: Mountain drag interface. Made necessary because:
-  ! 1. in the LMD-GCM Layers are from bottom to top,
-  ! contrary to most European GCM.
-  ! 2. the altitude above ground of each model layers
-  ! needs to be known (variable zgeom)
-  ! ======================================================================
-  ! Explicit Arguments:
-  ! ==================
-  ! partdrag-input-I-control which part of the drag we consider (total part or GW part)
-  ! nlon----input-I-Total number of horizontal points that get into physics
-  ! nlev----input-I-Number of vertical levels
-  ! dtime---input-R-Time-step (s)
-  ! paprs---input-R-Pressure in semi layers    (Pa)
-  ! pplay---input-R-Pressure model-layers      (Pa)
-  ! t-------input-R-temperature (K)
-  ! u-------input-R-Horizontal wind (m/s)
-  ! v-------input-R-Meridional wind (m/s)
-  ! pmea----input-R-Mean Orography (m)
-  ! pstd----input-R-SSO standard deviation (m)
-  ! psig----input-R-SSO slope
-  ! pgam----input-R-SSO Anisotropy
-  ! pthe----input-R-SSO Angle
-  ! ppic----input-R-SSO Peacks elevation (m)
-  ! pval----input-R-SSO Valleys elevation (m)
-
-  ! kgwd- -input-I: Total nb of points where the orography schemes are active
-  ! ktest--input-I: Flags to indicate active points
-  ! kdx----input-I: Locate the physical location of an active point.
-
-  ! pulow, pvlow -output-R: Low-level wind
-  ! pustr, pvstr -output-R: Surface stress due to SSO drag      (Pa)
-
-  ! d_t-----output-R: T increment
-  ! d_u-----output-R: U increment
-  ! d_v-----output-R: V increment
-
-  ! Implicit Arguments:
-  ! ===================
-
-  ! iim--common-I: Number of longitude intervals
-  ! jjm--common-I: Number of latitude intervals
-  ! klon-common-I: Number of points seen by the physics
-  ! (iim+1)*(jjm+1) for instance
-  ! klev-common-I: Number of vertical layers
-  ! ======================================================================
-  ! Local Variables:
-  ! ================
-
-  ! zgeom-----R: Altitude of layer above ground
-  ! pt, pu, pv --R: t u v from top to bottom
-  ! pdtdt, pdudt, pdvdt --R: t u v tendencies (from top to bottom)
-  ! papmf: pressure at model layer (from top to bottom)
-  ! papmh: pressure at model 1/2 layer (from top to bottom)
-
-  ! ======================================================================
-  include "YOMCST.h"
-  include "YOEGWD.h"
-
-  ! ARGUMENTS
-
-  INTEGER partdrag,nlon, nlev
-  REAL dtime
-  REAL paprs(nlon, nlev+1)
-  REAL pplay(nlon, nlev)
-  REAL pmea(nlon), pstd(nlon), psig(nlon), pgam(nlon), pthe(nlon)
-  REAL ppic(nlon), pval(nlon)
-  REAL pulow(nlon), pvlow(nlon), pustr(nlon), pvstr(nlon)
-  REAL t(nlon, nlev), u(nlon, nlev), v(nlon, nlev)
-  REAL d_t(nlon, nlev), d_u(nlon, nlev), d_v(nlon, nlev)
-
-  INTEGER i, k, kgwd, kdx(nlon), ktest(nlon)
-
-  ! LOCAL VARIABLES:
-
-  REAL zgeom(klon, klev)
-  REAL pdtdt(klon, klev), pdudt(klon, klev), pdvdt(klon, klev)
-  REAL pt(klon, klev), pu(klon, klev), pv(klon, klev)
-  REAL papmf(klon, klev), papmh(klon, klev+1)
-  CHARACTER (LEN=20) :: modname = 'orografi_strato'
-  CHARACTER (LEN=80) :: abort_message
-
-  ! INITIALIZE OUTPUT VARIABLES
-
-  DO i = 1, klon
-    pulow(i) = 0.0
-    pvlow(i) = 0.0
-    pustr(i) = 0.0
-    pvstr(i) = 0.0
-  END DO
-  DO k = 1, klev
-    DO i = 1, klon
-      d_t(i, k) = 0.0
-      d_u(i, k) = 0.0
-      d_v(i, k) = 0.0
-      pdudt(i, k) = 0.0
-      pdvdt(i, k) = 0.0
-      pdtdt(i, k) = 0.0
-    END DO
-  END DO
-
-  ! PREPARE INPUT VARIABLES FOR ORODRAG (i.e., ORDERED FROM TOP TO BOTTOM)
-  ! CALCULATE LAYERS HEIGHT ABOVE GROUND)
-
-  DO k = 1, klev
-    DO i = 1, klon
-      pt(i, k) = t(i, klev-k+1)
-      pu(i, k) = u(i, klev-k+1)
-      pv(i, k) = v(i, klev-k+1)
-      papmf(i, k) = pplay(i, klev-k+1)
-    END DO
-  END DO
-  DO k = 1, klev + 1
-    DO i = 1, klon
-      papmh(i, k) = paprs(i, klev-k+2)
-    END DO
-  END DO
-  DO i = 1, klon
-    zgeom(i, klev) = rd*pt(i, klev)*log(papmh(i,klev+1)/papmf(i,klev))
-  END DO
-  DO k = klev - 1, 1, -1
-    DO i = 1, klon
-      zgeom(i, k) = zgeom(i, k+1) + rd*(pt(i,k)+pt(i,k+1))/2.0*log(papmf(i,k+ &
-        1)/papmf(i,k))
-    END DO
-  END DO
-
-  ! CALL SSO DRAG ROUTINES
-
-  CALL orodrag_strato(partdrag,klon, klev, kgwd, kdx, ktest, dtime, papmh, papmf, &
-    zgeom, pt, pu, pv, pmea, pstd, psig, pgam, pthe, ppic, pval, pulow, &
-    pvlow, pdudt, pdvdt, pdtdt)
-
-  ! COMPUTE INCREMENTS AND STRESS FROM TENDENCIES
-
-  DO k = 1, klev
-    DO i = 1, klon
-      d_u(i, klev+1-k) = dtime*pdudt(i, k)
-      d_v(i, klev+1-k) = dtime*pdvdt(i, k)
-      d_t(i, klev+1-k) = dtime*pdtdt(i, k)
-      pustr(i) = pustr(i) + pdudt(i, k)*(papmh(i,k+1)-papmh(i,k))/rg
-      pvstr(i) = pvstr(i) + pdvdt(i, k)*(papmh(i,k+1)-papmh(i,k))/rg
-    END DO
-  END DO
-
-  RETURN
-END SUBROUTINE drag_noro_strato
-
-SUBROUTINE orodrag_strato(partdrag,nlon, nlev, kgwd, kdx, ktest, ptsphy, paphm1, &
-    papm1, pgeom1, ptm1, pum1, pvm1, pmea, pstd, psig, pgam, pthe, ppic, pval &
-  ! outputs
-    , pulow, pvlow, pvom, pvol, pte)
-
-  USE dimphy
-  IMPLICIT NONE
-
-
-  ! **** *orodrag* - does the SSO drag  parametrization.
-
-  ! purpose.
-  ! --------
-
-  ! this routine computes the physical tendencies of the
-  ! prognostic variables u,v  and t due to  vertical transports by
-  ! subgridscale orographically excited gravity waves, and to
-  ! low level blocked flow drag.
-
-  ! **   interface.
-  ! ----------
-  ! called from *drag_noro*.
-
-  ! the routine takes its input from the long-term storage:
-  ! u,v,t and p at t-1.
-
-  ! explicit arguments :
-  ! --------------------
-  ! ==== inputs ===
-  ! partdrag-input-I-control which part of the drag we consider (total part or GW part)
-  ! nlon----input-I-Total number of horizontal points that get into physics
-  ! nlev----input-I-Number of vertical levels
-
-  ! kgwd- -input-I: Total nb of points where the orography schemes are active
-  ! ktest--input-I: Flags to indicate active points
-  ! kdx----input-I: Locate the physical location of an active point.
-  ! ptsphy--input-R-Time-step (s)
-  ! paphm1--input-R: pressure at model 1/2 layer
-  ! papm1---input-R: pressure at model layer
-  ! pgeom1--input-R: Altitude of layer above ground
-  ! ptm1, pum1, pvm1--R-: t, u and v
-  ! pmea----input-R-Mean Orography (m)
-  ! pstd----input-R-SSO standard deviation (m)
-  ! psig----input-R-SSO slope
-  ! pgam----input-R-SSO Anisotropy
-  ! pthe----input-R-SSO Angle
-  ! ppic----input-R-SSO Peacks elevation (m)
-  ! pval----input-R-SSO Valleys elevation (m)
-
-  INTEGER  nlon, nlev, kgwd
-  REAL ptsphy
-
-  ! ==== outputs ===
-  ! pulow, pvlow -output-R: Low-level wind
-
-  ! pte -----output-R: T tendency
-  ! pvom-----output-R: U tendency
-  ! pvol-----output-R: V tendency
-
-
-  ! Implicit Arguments:
-  ! ===================
-
-  ! klon-common-I: Number of points seen by the physics
-  ! klev-common-I: Number of vertical layers
-
-  ! method.
-  ! -------
-
-  ! externals.
-  ! ----------
-  INTEGER ismin, ismax
-  EXTERNAL ismin, ismax
-
-  ! reference.
-  ! ----------
-
-  ! author.
-  ! -------
-  ! m.miller + b.ritter   e.c.m.w.f.     15/06/86.
-
-  ! f.lott + m. miller    e.c.m.w.f.     22/11/94
-  ! -----------------------------------------------------------------------
-
-
-  include "YOMCST.h"
-  include "YOEGWD.h"
-
-  ! -----------------------------------------------------------------------
-
-  ! *       0.1   arguments
-  ! ---------
-
-  INTEGER partdrag
-  REAL pte(nlon, nlev), pvol(nlon, nlev), pvom(nlon, nlev), pulow(nlon), &
-    pvlow(nlon)
-  REAL pum1(nlon, nlev), pvm1(nlon, nlev), ptm1(nlon, nlev), pmea(nlon), &
-    pstd(nlon), psig(nlon), pgam(nlon), pthe(nlon), ppic(nlon), pval(nlon), &
-    pgeom1(nlon, nlev), papm1(nlon, nlev), paphm1(nlon, nlev+1)
-
-  INTEGER kdx(nlon), ktest(nlon)
-  ! -----------------------------------------------------------------------
-
-  ! *       0.2   local arrays
-  ! ------------
-  INTEGER isect(klon), icrit(klon), ikcrith(klon), ikenvh(klon), iknu(klon), &
-    iknu2(klon), ikcrit(klon), ikhlim(klon)
-
-  REAL ztau(klon, klev+1), zstab(klon, klev+1), zvph(klon, klev+1), &
-    zrho(klon, klev+1), zri(klon, klev+1), zpsi(klon, klev+1), &
-    zzdep(klon, klev)
-  REAL zdudt(klon), zdvdt(klon), zdtdt(klon), zdedt(klon), zvidis(klon), &
-    ztfr(klon), znu(klon), zd1(klon), zd2(klon), zdmod(klon)
-
-
-  ! local quantities:
-
-  INTEGER jl, jk, ji
-  REAL ztmst, zdelp, ztemp, zforc, ztend, rover, facpart
-  REAL zb, zc, zconb, zabsv, zzd1, ratio, zbet, zust, zvst, zdis
-
-  ! ------------------------------------------------------------------
-
-  ! *         1.    initialization
-  ! --------------
-
-  ! print *,' in orodrag'
-
-  ! ------------------------------------------------------------------
-
-  ! *         1.1   computational constants
-  ! -----------------------
-
-
-  ! ztmst=twodt
-  ! if(nstep.eq.nstart) ztmst=0.5*twodt
-  ztmst = ptsphy
-
-  ! ------------------------------------------------------------------
-
-  ! *         1.3   check whether row contains point for printing
-  ! ---------------------------------------------
-
-
-  ! ------------------------------------------------------------------
-
-  ! *         2.     precompute basic state variables.
-  ! *                ---------- ----- ----- ----------
-  ! *                define low level wind, project winds in plane of
-  ! *                low level wind, determine sector in which to take
-  ! *                the variance and set indicator for critical levels.
-
-
-
-
-
-  CALL orosetup_strato(nlon, nlev, ktest, ikcrit, ikcrith, icrit, isect, &
-    ikhlim, ikenvh, iknu, iknu2, paphm1, papm1, pum1, pvm1, ptm1, pgeom1, &
-    pstd, zrho, zri, zstab, ztau, zvph, zpsi, zzdep, pulow, pvlow, pthe, &
-    pgam, pmea, ppic, pval, znu, zd1, zd2, zdmod)
-
-  ! ***********************************************************
-
-
-  ! *         3.      compute low level stresses using subcritical and
-  ! *                 supercritical forms.computes anisotropy coefficient
-  ! *                 as measure of orographic twodimensionality.
-
-
-  CALL gwstress_strato(nlon, nlev, ikcrit, isect, ikhlim, ktest, ikcrith, &
-    icrit, ikenvh, iknu, zrho, zstab, zvph, pstd, psig, pmea, ppic, pval, &
-    ztfr, ztau, pgeom1, pgam, zd1, zd2, zdmod, znu)
-
-  ! *         4.      compute stress profile including
-  ! trapped waves, wave breaking,
-  ! linear decay in stratosphere.
-
-
-
-
-  CALL gwprofil_strato(nlon, nlev, kgwd, kdx, ktest, ikcrit, ikcrith, icrit, &
-    ikenvh, iknu, iknu2, paphm1, zrho, zstab, ztfr, zvph, zri, ztau &
-    , zdmod, znu, psig, pgam, pstd, ppic, pval)
-
-  ! *         5.      Compute tendencies from waves stress profile.
-  ! Compute low level blocked flow drag.
-  ! *                 --------------------------------------------
-
-
-
-
-  ! explicit solution at all levels for the gravity wave
-  ! implicit solution for the blocked levels
-
-  DO jl = kidia, kfdia
-    zvidis(jl) = 0.0
-    zdudt(jl) = 0.0
-    zdvdt(jl) = 0.0
-    zdtdt(jl) = 0.0
-  END DO
-
-
-  DO jk = 1, klev
-
-
-    ! WAVE STRESS
-    ! -------------
-
-
-    DO ji = kidia, kfdia
-
-      IF (ktest(ji)==1) THEN
-
-        zdelp = paphm1(ji, jk+1) - paphm1(ji, jk)
-        ztemp = -rg*(ztau(ji,jk+1)-ztau(ji,jk))/(zvph(ji,klev+1)*zdelp)
-
-        zdudt(ji) = (pulow(ji)*zd1(ji)-pvlow(ji)*zd2(ji))*ztemp/zdmod(ji)
-        zdvdt(ji) = (pvlow(ji)*zd1(ji)+pulow(ji)*zd2(ji))*ztemp/zdmod(ji)
-
-        ! Control Overshoots
-
-
-        IF (jk>=nstra) THEN
-          rover = 0.10
-          IF (abs(zdudt(ji))>rover*abs(pum1(ji,jk))/ztmst) zdudt(ji) = rover* &
-            abs(pum1(ji,jk))/ztmst*zdudt(ji)/(abs(zdudt(ji))+1.E-10)
-          IF (abs(zdvdt(ji))>rover*abs(pvm1(ji,jk))/ztmst) zdvdt(ji) = rover* &
-            abs(pvm1(ji,jk))/ztmst*zdvdt(ji)/(abs(zdvdt(ji))+1.E-10)
-        END IF
-
-        rover = 0.25
-        zforc = sqrt(zdudt(ji)**2+zdvdt(ji)**2)
-        ztend = sqrt(pum1(ji,jk)**2+pvm1(ji,jk)**2)/ztmst
-
-        IF (zforc>=rover*ztend) THEN
-          zdudt(ji) = rover*ztend/zforc*zdudt(ji)
-          zdvdt(ji) = rover*ztend/zforc*zdvdt(ji)
-        END IF
-
-        ! BLOCKED FLOW DRAG:
-        ! -----------------
-
-        IF (partdrag .GE. 2) THEN
-        facpart=0.
-        ELSE
-        facpart=gkwake
-        ENDIF
-
-
-        IF (jk>ikenvh(ji)) THEN
-          zb = 1.0 - 0.18*pgam(ji) - 0.04*pgam(ji)**2
-          zc = 0.48*pgam(ji) + 0.3*pgam(ji)**2
-          zconb = 2.*ztmst*facpart*psig(ji)/(4.*pstd(ji))
-          zabsv = sqrt(pum1(ji,jk)**2+pvm1(ji,jk)**2)/2.
-          zzd1 = zb*cos(zpsi(ji,jk))**2 + zc*sin(zpsi(ji,jk))**2
-          ratio = (cos(zpsi(ji,jk))**2+pgam(ji)*sin(zpsi(ji, &
-            jk))**2)/(pgam(ji)*cos(zpsi(ji,jk))**2+sin(zpsi(ji,jk))**2)
-          zbet = max(0., 2.-1./ratio)*zconb*zzdep(ji, jk)*zzd1*zabsv
-
-          ! OPPOSED TO THE WIND
-
-          zdudt(ji) = -pum1(ji, jk)/ztmst
-          zdvdt(ji) = -pvm1(ji, jk)/ztmst
-
-          ! PERPENDICULAR TO THE SSO MAIN AXIS:
-
-          ! mod     zdudt(ji)=-(pum1(ji,jk)*cos(pthe(ji)*rpi/180.)
-          ! mod *              +pvm1(ji,jk)*sin(pthe(ji)*rpi/180.))
-          ! mod *              *cos(pthe(ji)*rpi/180.)/ztmst
-          ! mod     zdvdt(ji)=-(pum1(ji,jk)*cos(pthe(ji)*rpi/180.)
-          ! mod *              +pvm1(ji,jk)*sin(pthe(ji)*rpi/180.))
-          ! mod *              *sin(pthe(ji)*rpi/180.)/ztmst
-
-          zdudt(ji) = zdudt(ji)*(zbet/(1.+zbet))
-          zdvdt(ji) = zdvdt(ji)*(zbet/(1.+zbet))
-        END IF
-        pvom(ji, jk) = zdudt(ji)
-        pvol(ji, jk) = zdvdt(ji)
-        zust = pum1(ji, jk) + ztmst*zdudt(ji)
-        zvst = pvm1(ji, jk) + ztmst*zdvdt(ji)
-        zdis = 0.5*(pum1(ji,jk)**2+pvm1(ji,jk)**2-zust**2-zvst**2)
-        zdedt(ji) = zdis/ztmst
-        zvidis(ji) = zvidis(ji) + zdis*zdelp
-        zdtdt(ji) = zdedt(ji)/rcpd
-
-        ! NO TENDENCIES ON TEMPERATURE .....
-
-        ! Instead of, pte(ji,jk)=zdtdt(ji), due to mechanical dissipation
-
-        pte(ji, jk) = 0.0
-
-      END IF
-
-    END DO
-  END DO
-
-  RETURN
-END SUBROUTINE orodrag_strato
-SUBROUTINE orosetup_strato(nlon, nlev, ktest, kkcrit, kkcrith, kcrit, ksect, &
-    kkhlim, kkenvh, kknu, kknu2, paphm1, papm1, pum1, pvm1, ptm1, pgeom1, &
-    pstd, prho, pri, pstab, ptau, pvph, ppsi, pzdep, pulow, pvlow, ptheta, &
-    pgam, pmea, ppic, pval, pnu, pd1, pd2, pdmod)
-
-  ! **** *gwsetup*
-
-  ! purpose.
-  ! --------
-  ! SET-UP THE ESSENTIAL PARAMETERS OF THE SSO DRAG SCHEME:
-  ! DEPTH OF LOW WBLOCKED LAYER, LOW-LEVEL FLOW, BACKGROUND
-  ! STRATIFICATION.....
-
-  ! **   interface.
-  ! ----------
-  ! from *orodrag*
-
-  ! explicit arguments :
-  ! --------------------
-  ! ==== inputs ===
-
-  ! nlon----input-I-Total number of horizontal points that get into physics
-  ! nlev----input-I-Number of vertical levels
-  ! ktest--input-I: Flags to indicate active points
-
-  ! ptsphy--input-R-Time-step (s)
-  ! paphm1--input-R: pressure at model 1/2 layer
-  ! papm1---input-R: pressure at model layer
-  ! pgeom1--input-R: Altitude of layer above ground
-  ! ptm1, pum1, pvm1--R-: t, u and v
-  ! pmea----input-R-Mean Orography (m)
-  ! pstd----input-R-SSO standard deviation (m)
-  ! psig----input-R-SSO slope
-  ! pgam----input-R-SSO Anisotropy
-  ! pthe----input-R-SSO Angle
-  ! ppic----input-R-SSO Peacks elevation (m)
-  ! pval----input-R-SSO Valleys elevation (m)
-
-  ! ==== outputs ===
-  ! pulow, pvlow -output-R: Low-level wind
-  ! kkcrit----I-: Security value for top of low level flow
-  ! kcrit-----I-: Critical level
-  ! ksect-----I-: Not used
-  ! kkhlim----I-: Not used
-  ! kkenvh----I-: Top of blocked flow layer
-  ! kknu------I-: Layer that sees mountain peacks
-  ! kknu2-----I-: Layer that sees mountain peacks above mountain mean
-  ! kknub-----I-: Layer that sees mountain mean above valleys
-  ! prho------R-: Density at 1/2 layers
-  ! pri-------R-: Background Richardson Number, Wind shear measured along GW
-  ! stress
-  ! pstab-----R-: Brunt-Vaisala freq. at 1/2 layers
-  ! pvph------R-: Wind in  plan of GW stress, Half levels.
-  ! ppsi------R-: Angle between low level wind and SS0 main axis.
-  ! pd1-------R-| Compared the ratio of the stress
-  ! pd2-------R-| that is along the wind to that Normal to it.
-  ! pdi define the plane of low level stress
-  ! compared to the low level wind.
-  ! see p. 108 Lott & Miller (1997).
-  ! pdmod-----R-: Norme of pdi
-
-  ! === local arrays ===
-
-  ! zvpf------R-: Wind projected in the plan of the low-level stress.
-
-  ! ==== outputs ===
-
-  ! implicit arguments :   none
-  ! --------------------
-
-  ! method.
-  ! -------
-
-
-  ! externals.
-  ! ----------
-
-
-  ! reference.
-  ! ----------
-
-  ! see ecmwf research department documentation of the "i.f.s."
-
-  ! author.
-  ! -------
-
-  ! modifications.
-  ! --------------
-  ! f.lott  for the new-gwdrag scheme november 1993
-
-  ! -----------------------------------------------------------------------
-  USE dimphy
-  IMPLICIT NONE
-
-
-  include "YOMCST.h"
-  include "YOEGWD.h"
-
-  ! -----------------------------------------------------------------------
-
-  ! *       0.1   arguments
-  ! ---------
-
-  INTEGER nlon, nlev
-  INTEGER kkcrit(nlon), kkcrith(nlon), kcrit(nlon), ksect(nlon), &
-    kkhlim(nlon), ktest(nlon), kkenvh(nlon)
-
-
-  REAL paphm1(nlon, klev+1), papm1(nlon, klev), pum1(nlon, klev), &
-    pvm1(nlon, klev), ptm1(nlon, klev), pgeom1(nlon, klev), &
-    prho(nlon, klev+1), pri(nlon, klev+1), pstab(nlon, klev+1), &
-    ptau(nlon, klev+1), pvph(nlon, klev+1), ppsi(nlon, klev+1), &
-    pzdep(nlon, klev)
-  REAL pulow(nlon), pvlow(nlon), ptheta(nlon), pgam(nlon), pnu(nlon), &
-    pd1(nlon), pd2(nlon), pdmod(nlon)
-  REAL pstd(nlon), pmea(nlon), ppic(nlon), pval(nlon)
-
-  ! -----------------------------------------------------------------------
-
-  ! *       0.2   local arrays
-  ! ------------
-
-
-  INTEGER ilevh, jl, jk
-  REAL zcons1, zcons2, zhgeo, zu, zphi
-  REAL zvt1, zvt2, zdwind, zwind, zdelp
-  REAL zstabm, zstabp, zrhom, zrhop
-  LOGICAL lo
-  LOGICAL ll1(klon, klev+1)
-  INTEGER kknu(klon), kknu2(klon), kknub(klon), kknul(klon), kentp(klon), &
-    ncount(klon)
-
-  REAL zhcrit(klon, klev), zvpf(klon, klev), zdp(klon, klev)
-  REAL znorm(klon), zb(klon), zc(klon), zulow(klon), zvlow(klon), znup(klon), &
-    znum(klon)
-
-  ! ------------------------------------------------------------------
-
-  ! *         1.    initialization
-  ! --------------
-
-  ! PRINT *,' in orosetup'
-
-  ! ------------------------------------------------------------------
-
-  ! *         1.1   computational constants
-  ! -----------------------
-
-
-  ilevh = klev/3
-
-  zcons1 = 1./rd
-  zcons2 = rg**2/rcpd
-
-  ! ------------------------------------------------------------------
-
-  ! *         2.
-  ! --------------
-
-
-  ! ------------------------------------------------------------------
-
-  ! *         2.1     define low level wind, project winds in plane of
-  ! *                 low level wind, determine sector in which to take
-  ! *                 the variance and set indicator for critical levels.
-
-
-
-  DO jl = kidia, kfdia
-    kknu(jl) = klev
-    kknu2(jl) = klev
-    kknub(jl) = klev
-    kknul(jl) = klev
-    pgam(jl) = max(pgam(jl), gtsec)
-    ll1(jl, klev+1) = .FALSE.
-  END DO
-
-  ! Ajouter une initialisation (L. Li, le 23fev99):
-
-  DO jk = klev, ilevh, -1
-    DO jl = kidia, kfdia
-      ll1(jl, jk) = .FALSE.
-    END DO
-  END DO
-
-  ! *      define top of low level flow
-  ! ----------------------------
-  DO jk = klev, ilevh, -1
-    DO jl = kidia, kfdia
-      IF (ktest(jl)==1) THEN
-        lo = (paphm1(jl,jk)/paphm1(jl,klev+1)) >= gsigcr
-        IF (lo) THEN
-          kkcrit(jl) = jk
-        END IF
-        zhcrit(jl, jk) = ppic(jl) - pval(jl)
-        zhgeo = pgeom1(jl, jk)/rg
-        ll1(jl, jk) = (zhgeo>zhcrit(jl,jk))
-        IF (ll1(jl,jk) .NEQV. ll1(jl,jk+1)) THEN
-          kknu(jl) = jk
-        END IF
-        IF (.NOT. ll1(jl,ilevh)) kknu(jl) = ilevh
-      END IF
-    END DO
-  END DO
-  DO jk = klev, ilevh, -1
-    DO jl = kidia, kfdia
-      IF (ktest(jl)==1) THEN
-        zhcrit(jl, jk) = ppic(jl) - pmea(jl)
-        zhgeo = pgeom1(jl, jk)/rg
-        ll1(jl, jk) = (zhgeo>zhcrit(jl,jk))
-        IF (ll1(jl,jk) .NEQV. ll1(jl,jk+1)) THEN
-          kknu2(jl) = jk
-        END IF
-        IF (.NOT. ll1(jl,ilevh)) kknu2(jl) = ilevh
-      END IF
-    END DO
-  END DO
-  DO jk = klev, ilevh, -1
-    DO jl = kidia, kfdia
-      IF (ktest(jl)==1) THEN
-        zhcrit(jl, jk) = amin1(ppic(jl)-pmea(jl), pmea(jl)-pval(jl))
-        zhgeo = pgeom1(jl, jk)/rg
-        ll1(jl, jk) = (zhgeo>zhcrit(jl,jk))
-        IF (ll1(jl,jk) .NEQV. ll1(jl,jk+1)) THEN
-          kknub(jl) = jk
-        END IF
-        IF (.NOT. ll1(jl,ilevh)) kknub(jl) = ilevh
-      END IF
-    END DO
-  END DO
-
-  DO jl = kidia, kfdia
-    IF (ktest(jl)==1) THEN
-      kknu(jl) = min(kknu(jl), nktopg)
-      kknu2(jl) = min(kknu2(jl), nktopg)
-      kknub(jl) = min(kknub(jl), nktopg)
-      kknul(jl) = klev
-    END IF
-  END DO
-
-  ! c*     initialize various arrays
-
-  DO jl = kidia, kfdia
-    prho(jl, klev+1) = 0.0
-    ! ym correction en attendant mieux
-    prho(jl, 1) = 0.0
-    pstab(jl, klev+1) = 0.0
-    pstab(jl, 1) = 0.0
-    pri(jl, klev+1) = 9999.0
-    ppsi(jl, klev+1) = 0.0
-    pri(jl, 1) = 0.0
-    pvph(jl, 1) = 0.0
-    pvph(jl, klev+1) = 0.0
-    ! ym correction en attendant mieux
-    ! ym      pvph(jl,klev)    =0.0
-    pulow(jl) = 0.0
-    pvlow(jl) = 0.0
-    zulow(jl) = 0.0
-    zvlow(jl) = 0.0
-    kkcrith(jl) = klev
-    kkenvh(jl) = klev
-    kentp(jl) = klev
-    kcrit(jl) = 1
-    ncount(jl) = 0
-    ll1(jl, klev+1) = .FALSE.
-  END DO
-
-  ! *     define flow density and stratification (rho and N2)
-  ! at semi layers.
-  ! -------------------------------------------------------
-
-  DO jk = klev, 2, -1
-    DO jl = kidia, kfdia
-      IF (ktest(jl)==1) THEN
-        zdp(jl, jk) = papm1(jl, jk) - papm1(jl, jk-1)
-        prho(jl, jk) = 2.*paphm1(jl, jk)*zcons1/(ptm1(jl,jk)+ptm1(jl,jk-1))
-        pstab(jl, jk) = 2.*zcons2/(ptm1(jl,jk)+ptm1(jl,jk-1))* &
-          (1.-rcpd*prho(jl,jk)*(ptm1(jl,jk)-ptm1(jl,jk-1))/zdp(jl,jk))
-        pstab(jl, jk) = max(pstab(jl,jk), gssec)
-      END IF
-    END DO
-  END DO
-
-  ! ********************************************************************
-
-  ! *     define Low level flow (between ground and peacks-valleys)
-  ! ---------------------------------------------------------
-  DO jk = klev, ilevh, -1
-    DO jl = kidia, kfdia
-      IF (ktest(jl)==1) THEN
-        IF (jk>=kknu2(jl) .AND. jk<=kknul(jl)) THEN
-          pulow(jl) = pulow(jl) + pum1(jl, jk)*(paphm1(jl,jk+1)-paphm1(jl,jk) &
-            )
-          pvlow(jl) = pvlow(jl) + pvm1(jl, jk)*(paphm1(jl,jk+1)-paphm1(jl,jk) &
-            )
-          pstab(jl, klev+1) = pstab(jl, klev+1) + pstab(jl, jk)*(paphm1(jl,jk &
-            +1)-paphm1(jl,jk))
-          prho(jl, klev+1) = prho(jl, klev+1) + prho(jl, jk)*(paphm1(jl,jk+1) &
-            -paphm1(jl,jk))
-        END IF
-      END IF
-    END DO
-  END DO
-  DO jl = kidia, kfdia
-    IF (ktest(jl)==1) THEN
-      pulow(jl) = pulow(jl)/(paphm1(jl,kknul(jl)+1)-paphm1(jl,kknu2(jl)))
-      pvlow(jl) = pvlow(jl)/(paphm1(jl,kknul(jl)+1)-paphm1(jl,kknu2(jl)))
-      znorm(jl) = max(sqrt(pulow(jl)**2+pvlow(jl)**2), gvsec)
-      pvph(jl, klev+1) = znorm(jl)
-      pstab(jl, klev+1) = pstab(jl, klev+1)/(paphm1(jl,kknul(jl)+1)-paphm1(jl &
-        ,kknu2(jl)))
-      prho(jl, klev+1) = prho(jl, klev+1)/(paphm1(jl,kknul(jl)+1)-paphm1(jl, &
-        kknu2(jl)))
-    END IF
-  END DO
-
-
-  ! *******  setup orography orientation relative to the low level
-  ! wind and define parameters of the Anisotropic wave stress.
-
-  DO jl = kidia, kfdia
-    IF (ktest(jl)==1) THEN
-      lo = (pulow(jl)<gvsec) .AND. (pulow(jl)>=-gvsec)
-      IF (lo) THEN
-        zu = pulow(jl) + 2.*gvsec
-      ELSE
-        zu = pulow(jl)
-      END IF
-      zphi = atan(pvlow(jl)/zu)
-      ppsi(jl, klev+1) = ptheta(jl)*rpi/180. - zphi
-      zb(jl) = 1. - 0.18*pgam(jl) - 0.04*pgam(jl)**2
-      zc(jl) = 0.48*pgam(jl) + 0.3*pgam(jl)**2
-      pd1(jl) = zb(jl) - (zb(jl)-zc(jl))*(sin(ppsi(jl,klev+1))**2)
-      pd2(jl) = (zb(jl)-zc(jl))*sin(ppsi(jl,klev+1))*cos(ppsi(jl,klev+1))
-      pdmod(jl) = sqrt(pd1(jl)**2+pd2(jl)**2)
-    END IF
-  END DO
-
-  ! ************ projet flow in plane of lowlevel stress *************
-  ! ************ Find critical levels...                 *************
-
-  DO jk = 1, klev
-    DO jl = kidia, kfdia
-      IF (ktest(jl)==1) THEN
-        zvt1 = pulow(jl)*pum1(jl, jk) + pvlow(jl)*pvm1(jl, jk)
-        zvt2 = -pvlow(jl)*pum1(jl, jk) + pulow(jl)*pvm1(jl, jk)
-        zvpf(jl, jk) = (zvt1*pd1(jl)+zvt2*pd2(jl))/(znorm(jl)*pdmod(jl))
-      END IF
-      ptau(jl, jk) = 0.0
-      pzdep(jl, jk) = 0.0
-      ppsi(jl, jk) = 0.0
-      ll1(jl, jk) = .FALSE.
-    END DO
-  END DO
-  DO jk = 2, klev
-    DO jl = kidia, kfdia
-      IF (ktest(jl)==1) THEN
-        zdp(jl, jk) = papm1(jl, jk) - papm1(jl, jk-1)
-        pvph(jl, jk) = ((paphm1(jl,jk)-papm1(jl,jk-1))*zvpf(jl,jk)+(papm1(jl, &
-          jk)-paphm1(jl,jk))*zvpf(jl,jk-1))/zdp(jl, jk)
-        IF (pvph(jl,jk)<gvsec) THEN
-          pvph(jl, jk) = gvsec
-          kcrit(jl) = jk
-        END IF
-      END IF
-    END DO
-  END DO
-
-  ! *         2.3     mean flow richardson number.
-
-
-  DO jk = 2, klev
-    DO jl = kidia, kfdia
-      IF (ktest(jl)==1) THEN
-        zdwind = max(abs(zvpf(jl,jk)-zvpf(jl,jk-1)), gvsec)
-        pri(jl, jk) = pstab(jl, jk)*(zdp(jl,jk)/(rg*prho(jl,jk)*zdwind))**2
-        pri(jl, jk) = max(pri(jl,jk), grcrit)
-      END IF
-    END DO
-  END DO
-
-
-
-  ! *      define top of 'envelope' layer
-  ! ----------------------------
-
-  DO jl = kidia, kfdia
-    pnu(jl) = 0.0
-    znum(jl) = 0.0
-  END DO
-
-  DO jk = 2, klev - 1
-    DO jl = kidia, kfdia
-
-      IF (ktest(jl)==1) THEN
-
-        IF (jk>=kknu2(jl)) THEN
-
-          znum(jl) = pnu(jl)
-          zwind = (pulow(jl)*pum1(jl,jk)+pvlow(jl)*pvm1(jl,jk))/ &
-            max(sqrt(pulow(jl)**2+pvlow(jl)**2), gvsec)
-          zwind = max(sqrt(zwind**2), gvsec)
-          zdelp = paphm1(jl, jk+1) - paphm1(jl, jk)
-          zstabm = sqrt(max(pstab(jl,jk),gssec))
-          zstabp = sqrt(max(pstab(jl,jk+1),gssec))
-          zrhom = prho(jl, jk)
-          zrhop = prho(jl, jk+1)
-          pnu(jl) = pnu(jl) + (zdelp/rg)*((zstabp/zrhop+zstabm/zrhom)/2.)/ &
-            zwind
-          IF ((znum(jl)<=gfrcrit) .AND. (pnu(jl)>gfrcrit) .AND. (kkenvh( &
-            jl)==klev)) kkenvh(jl) = jk
-
-        END IF
-
-      END IF
-
-    END DO
-  END DO
-
-  ! calculation of a dynamical mixing height for when the waves
-  ! BREAK AT LOW LEVEL: The drag will be repartited over
-  ! a depths that depends on waves vertical wavelength,
-  ! not just between two adjacent model layers.
-  ! of gravity waves:
-
-  DO jl = kidia, kfdia
-    znup(jl) = 0.0
-    znum(jl) = 0.0
-  END DO
-
-  DO jk = klev - 1, 2, -1
-    DO jl = kidia, kfdia
-
-      IF (ktest(jl)==1) THEN
-
-        znum(jl) = znup(jl)
-        zwind = (pulow(jl)*pum1(jl,jk)+pvlow(jl)*pvm1(jl,jk))/ &
-          max(sqrt(pulow(jl)**2+pvlow(jl)**2), gvsec)
-        zwind = max(sqrt(zwind**2), gvsec)
-        zdelp = paphm1(jl, jk+1) - paphm1(jl, jk)
-        zstabm = sqrt(max(pstab(jl,jk),gssec))
-        zstabp = sqrt(max(pstab(jl,jk+1),gssec))
-        zrhom = prho(jl, jk)
-        zrhop = prho(jl, jk+1)
-        znup(jl) = znup(jl) + (zdelp/rg)*((zstabp/zrhop+zstabm/zrhom)/2.)/ &
-          zwind
-        IF ((znum(jl)<=rpi/4.) .AND. (znup(jl)>rpi/4.) .AND. (kkcrith( &
-          jl)==klev)) kkcrith(jl) = jk
-
-      END IF
-
-    END DO
-  END DO
-
-  DO jl = kidia, kfdia
-    IF (ktest(jl)==1) THEN
-      kkcrith(jl) = max0(kkcrith(jl), ilevh*2)
-      kkcrith(jl) = max0(kkcrith(jl), kknu(jl))
-      IF (kcrit(jl)>=kkcrith(jl)) kcrit(jl) = 1
-    END IF
-  END DO
-
-  ! directional info for flow blocking *************************
-
-  DO jk = 1, klev
-    DO jl = kidia, kfdia
-      IF (ktest(jl)==1) THEN
-        lo = (pum1(jl,jk)<gvsec) .AND. (pum1(jl,jk)>=-gvsec)
-        IF (lo) THEN
-          zu = pum1(jl, jk) + 2.*gvsec
-        ELSE
-          zu = pum1(jl, jk)
-        END IF
-        zphi = atan(pvm1(jl,jk)/zu)
-        ppsi(jl, jk) = ptheta(jl)*rpi/180. - zphi
-      END IF
-    END DO
-  END DO
-
-  ! forms the vertical 'leakiness' **************************
-
-  DO jk = ilevh, klev
-    DO jl = kidia, kfdia
-      IF (ktest(jl)==1) THEN
-        pzdep(jl, jk) = 0
-        IF (jk>=kkenvh(jl) .AND. kkenvh(jl)/=klev) THEN
-          pzdep(jl, jk) = (pgeom1(jl,kkenvh(jl))-pgeom1(jl,jk))/ &
-            (pgeom1(jl,kkenvh(jl))-pgeom1(jl,klev))
-        END IF
-      END IF
-    END DO
-  END DO
-
-  RETURN
-END SUBROUTINE orosetup_strato
-SUBROUTINE gwstress_strato(nlon, nlev, kkcrit, ksect, kkhlim, ktest, kkcrith, &
-    kcrit, kkenvh, kknu, prho, pstab, pvph, pstd, psig, pmea, ppic, pval, &
-    ptfr, ptau, pgeom1, pgamma, pd1, pd2, pdmod, pnu)
-
-  ! **** *gwstress*
-
-  ! purpose.
-  ! --------
-  ! Compute the surface stress due to Gravity Waves, according
-  ! to the Phillips (1979) theory of 3-D flow above
-  ! anisotropic elliptic ridges.
-
-  ! The stress is reduced two account for cut-off flow over
-  ! hill.  The flow only see that part of the ridge located
-  ! above the blocked layer (see zeff).
-
-  ! **   interface.
-  ! ----------
-  ! call *gwstress*  from *gwdrag*
-
-  ! explicit arguments :
-  ! --------------------
-  ! ==== inputs ===
-  ! ==== outputs ===
-
-  ! implicit arguments :   none
-  ! --------------------
-
-  ! method.
-  ! -------
-
-
-  ! externals.
-  ! ----------
-
-
-  ! reference.
-  ! ----------
-
-  ! LOTT and MILLER (1997)  &  LOTT (1999)
-
-  ! author.
-  ! -------
-
-  ! modifications.
-  ! --------------
-  ! f. lott put the new gwd on ifs      22/11/93
-
-  ! -----------------------------------------------------------------------
-  USE dimphy
-  IMPLICIT NONE
-
-  include "YOMCST.h"
-  include "YOEGWD.h"
-
-  ! -----------------------------------------------------------------------
-
-  ! *       0.1   arguments
-  ! ---------
-
-  INTEGER nlon, nlev
-  INTEGER kkcrit(nlon), kkcrith(nlon), kcrit(nlon), ksect(nlon), &
-    kkhlim(nlon), ktest(nlon), kkenvh(nlon), kknu(nlon)
-
-  REAL prho(nlon, nlev+1), pstab(nlon, nlev+1), ptau(nlon, nlev+1), &
-    pvph(nlon, nlev+1), ptfr(nlon), pgeom1(nlon, nlev), pstd(nlon)
-
-  REAL pd1(nlon), pd2(nlon), pnu(nlon), psig(nlon), pgamma(nlon)
-  REAL pmea(nlon), ppic(nlon), pval(nlon)
-  REAL pdmod(nlon)
-
-  ! -----------------------------------------------------------------------
-
-  ! *       0.2   local arrays
-  ! ------------
-  ! zeff--real: effective height seen by the flow when there is blocking
-
-  INTEGER jl
-  REAL zeff
-
-  ! -----------------------------------------------------------------------
-
-  ! *       0.3   functions
-  ! ---------
-  ! ------------------------------------------------------------------
-
-  ! *         1.    initialization
-  ! --------------
-
-  ! PRINT *,' in gwstress'
-
-  ! *         3.1     gravity wave stress.
-
-
-
-  DO jl = kidia, kfdia
-    IF (ktest(jl)==1) THEN
-
-      ! effective mountain height above the blocked flow
-
-      zeff = ppic(jl) - pval(jl)
-      IF (kkenvh(jl)<klev) THEN
-        zeff = amin1(gfrcrit*pvph(jl,klev+1)/sqrt(pstab(jl,klev+1)), zeff)
-      END IF
-
-
-      ptau(jl, klev+1) = gkdrag*prho(jl, klev+1)*psig(jl)*pdmod(jl)/4./ &
-        pstd(jl)*pvph(jl, klev+1)*sqrt(pstab(jl,klev+1))*zeff**2
-
-
-      ! too small value of stress or  low level flow include critical level
-      ! or low level flow:  gravity wave stress nul.
-
-      ! lo=(ptau(jl,klev+1).lt.gtsec).or.(kcrit(jl).ge.kknu(jl))
-      ! *      .or.(pvph(jl,klev+1).lt.gvcrit)
-      ! if(lo) ptau(jl,klev+1)=0.0
-
-      ! print *,jl,ptau(jl,klev+1)
-
-    ELSE
-
-      ptau(jl, klev+1) = 0.0
-
-    END IF
-
-  END DO
-
-  ! write(21)(ptau(jl,klev+1),jl=kidia,kfdia)
-
-  RETURN
-END SUBROUTINE gwstress_strato
-
-SUBROUTINE gwprofil_strato(nlon, nlev, kgwd, kdx, ktest, kkcrit, kkcrith, &
-    kcrit, kkenvh, kknu, kknu2, paphm1, prho, pstab, ptfr, pvph, pri, ptau, &
-    pdmod, pnu, psig, pgamma, pstd, ppic, pval)
-
-  ! **** *gwprofil*
-
-  ! purpose.
-  ! --------
-
-  ! **   interface.
-  ! ----------
-  ! from *gwdrag*
-
-  ! explicit arguments :
-  ! --------------------
-  ! ==== inputs ===
-
-  ! ==== outputs ===
-
-  ! implicit arguments :   none
-  ! --------------------
-
-  ! method:
-  ! -------
-  ! the stress profile for gravity waves is computed as follows:
-  ! it decreases linearly with heights from the ground
-  ! to the low-level indicated by kkcrith,
-  ! to simulates lee waves or
-  ! low-level gravity wave breaking.
-  ! above it is constant, except when the waves encounter a critical
-  ! level (kcrit) or when they break.
-  ! The stress is also uniformly distributed above the level
-  ! nstra.
-
-  USE dimphy
-  IMPLICIT NONE
-
-  include "YOMCST.h"
-  include "YOEGWD.h"
-
-  ! -----------------------------------------------------------------------
-
-  ! *       0.1   ARGUMENTS
-  ! ---------
-
-  INTEGER nlon, nlev, kgwd
-  INTEGER kkcrit(nlon), kkcrith(nlon), kcrit(nlon), kdx(nlon), ktest(nlon), &
-    kkenvh(nlon), kknu(nlon), kknu2(nlon)
-
-  REAL paphm1(nlon, nlev+1), pstab(nlon, nlev+1), prho(nlon, nlev+1), &
-    pvph(nlon, nlev+1), pri(nlon, nlev+1), ptfr(nlon), ptau(nlon, nlev+1)
-
-  REAL pdmod(nlon), pnu(nlon), psig(nlon), pgamma(nlon), pstd(nlon), &
-    ppic(nlon), pval(nlon)
-
-  ! -----------------------------------------------------------------------
-
-  ! *       0.2   local arrays
-  ! ------------
-
-  INTEGER jl, jk
-  REAL zsqr, zalfa, zriw, zdel, zb, zalpha, zdz2n, zdelp, zdelpt
-
-  REAL zdz2(klon, klev), znorm(klon), zoro(klon)
-  REAL ztau(klon, klev+1)
-
-  ! -----------------------------------------------------------------------
-
-  ! *         1.    INITIALIZATION
-  ! --------------
-
-  ! print *,' entree gwprofil'
-
-
-  ! *    COMPUTATIONAL CONSTANTS.
-  ! ------------- ----------
-
-  DO jl = kidia, kfdia
-    IF (ktest(jl)==1) THEN
-      zoro(jl) = psig(jl)*pdmod(jl)/4./pstd(jl)
-      ztau(jl, klev+1) = ptau(jl, klev+1)
-      ! print *,jl,ptau(jl,klev+1)
-      ztau(jl, kkcrith(jl)) = grahilo*ptau(jl, klev+1)
-    END IF
-  END DO
-
-
-  DO jk = klev + 1, 1, -1
-    ! *         4.1    constant shear stress until top of the
-    ! low-level breaking/trapped layer
-
-    DO jl = kidia, kfdia
-      IF (ktest(jl)==1) THEN
-        IF (jk>kkcrith(jl)) THEN
-          zdelp = paphm1(jl, jk) - paphm1(jl, klev+1)
-          zdelpt = paphm1(jl, kkcrith(jl)) - paphm1(jl, klev+1)
-          ptau(jl, jk) = ztau(jl, klev+1) + zdelp/zdelpt*(ztau(jl,kkcrith(jl) &
-            )-ztau(jl,klev+1))
-        ELSE
-          ptau(jl, jk) = ztau(jl, kkcrith(jl))
-        END IF
-      END IF
-    END DO
-
-    ! *         4.15   constant shear stress until the top of the
-    ! low level flow layer.
-
-
-    ! *         4.2    wave displacement at next level.
-
-
-  END DO
-
-
-  ! *         4.4    wave richardson number, new wave displacement
-  ! *                and stress:  breaking evaluation and critical
-  ! level
-
-
-  DO jk = klev, 1, -1
-
-    DO jl = kidia, kfdia
-      IF (ktest(jl)==1) THEN
-        znorm(jl) = prho(jl, jk)*sqrt(pstab(jl,jk))*pvph(jl, jk)
-        zdz2(jl, jk) = ptau(jl, jk)/amax1(znorm(jl), gssec)/zoro(jl)
-      END IF
-    END DO
-
-    DO jl = kidia, kfdia
-      IF (ktest(jl)==1) THEN
-        IF (jk<kkcrith(jl)) THEN
-          IF ((ptau(jl,jk+1)<gtsec) .OR. (jk<=kcrit(jl))) THEN
-            ptau(jl, jk) = 0.0
-          ELSE
-            zsqr = sqrt(pri(jl,jk))
-            zalfa = sqrt(pstab(jl,jk)*zdz2(jl,jk))/pvph(jl, jk)
-            zriw = pri(jl, jk)*(1.-zalfa)/(1+zalfa*zsqr)**2
-            IF (zriw<grcrit) THEN
-              ! print *,' breaking!!!',ptau(jl,jk)
-              zdel = 4./zsqr/grcrit + 1./grcrit**2 + 4./grcrit
-              zb = 1./grcrit + 2./zsqr
-              zalpha = 0.5*(-zb+sqrt(zdel))
-              zdz2n = (pvph(jl,jk)*zalpha)**2/pstab(jl, jk)
-              ptau(jl, jk) = znorm(jl)*zdz2n*zoro(jl)
-            END IF
-
-            ptau(jl, jk) = amin1(ptau(jl,jk), ptau(jl,jk+1))
-
-          END IF
-        END IF
-      END IF
-    END DO
-  END DO
-
-  ! REORGANISATION OF THE STRESS PROFILE AT LOW LEVEL
-
-  DO jl = kidia, kfdia
-    IF (ktest(jl)==1) THEN
-      ztau(jl, kkcrith(jl)-1) = ptau(jl, kkcrith(jl)-1)
-      ztau(jl, nstra) = ptau(jl, nstra)
-    END IF
-  END DO
-
-  DO jk = 1, klev
-
-    DO jl = kidia, kfdia
-      IF (ktest(jl)==1) THEN
-
-        IF (jk>kkcrith(jl)-1) THEN
-
-          zdelp = paphm1(jl, jk) - paphm1(jl, klev+1)
-          zdelpt = paphm1(jl, kkcrith(jl)-1) - paphm1(jl, klev+1)
-          ptau(jl, jk) = ztau(jl, klev+1) + (ztau(jl,kkcrith(jl)-1)-ztau(jl, &
-            klev+1))*zdelp/zdelpt
-
-        END IF
-      END IF
-
-    END DO
-
-    ! REORGANISATION AT THE MODEL TOP....
-
-    DO jl = kidia, kfdia
-      IF (ktest(jl)==1) THEN
-
-        IF (jk<nstra) THEN
-
-          zdelp = paphm1(jl, nstra)
-          zdelpt = paphm1(jl, jk)
-          ptau(jl, jk) = ztau(jl, nstra)*zdelpt/zdelp
-          ! ptau(jl,jk)=ztau(jl,nstra)
-
-        END IF
-
-      END IF
-
-    END DO
-
-
-  END DO
-
-
-123 FORMAT (I4, 1X, 20(F6.3,1X))
-
-
-  RETURN
-END SUBROUTINE gwprofil_strato
-SUBROUTINE lift_noro_strato(nlon, nlev, dtime, paprs, pplay, plat, pmea, &
-    pstd, psig, pgam, pthe, ppic, pval, kgwd, kdx, ktest, t, u, v, pulow, &
-    pvlow, pustr, pvstr, d_t, d_u, d_v)
-
-  USE dimphy
-  IMPLICIT NONE
-  ! ======================================================================
-  ! Auteur(s): F.Lott (LMD/CNRS) date: 19950201
-  ! Object: Mountain lift interface (enhanced vortex stretching).
-  ! Made necessary because:
-  ! 1. in the LMD-GCM Layers are from bottom to top,
-  ! contrary to most European GCM.
-  ! 2. the altitude above ground of each model layers
-  ! needs to be known (variable zgeom)
-  ! ======================================================================
-  ! Explicit Arguments:
-  ! ==================
-  ! nlon----input-I-Total number of horizontal points that get into physics
-  ! nlev----input-I-Number of vertical levels
-  ! dtime---input-R-Time-step (s)
-  ! paprs---input-R-Pressure in semi layers    (Pa)
-  ! pplay---input-R-Pressure model-layers      (Pa)
-  ! t-------input-R-temperature (K)
-  ! u-------input-R-Horizontal wind (m/s)
-  ! v-------input-R-Meridional wind (m/s)
-  ! pmea----input-R-Mean Orography (m)
-  ! pstd----input-R-SSO standard deviation (m)
-  ! psig----input-R-SSO slope
-  ! pgam----input-R-SSO Anisotropy
-  ! pthe----input-R-SSO Angle
-  ! ppic----input-R-SSO Peacks elevation (m)
-  ! pval----input-R-SSO Valleys elevation (m)
-
-  ! kgwd- -input-I: Total nb of points where the orography schemes are active
-  ! ktest--input-I: Flags to indicate active points
-  ! kdx----input-I: Locate the physical location of an active point.
-
-  ! pulow, pvlow -output-R: Low-level wind
-  ! pustr, pvstr -output-R: Surface stress due to SSO drag      (Pa)
-
-  ! d_t-----output-R: T increment
-  ! d_u-----output-R: U increment
-  ! d_v-----output-R: V increment
-
-  ! Implicit Arguments:
-  ! ===================
-
-  ! iim--common-I: Number of longitude intervals
-  ! jjm--common-I: Number of latitude intervals
-  ! klon-common-I: Number of points seen by the physics
-  ! (iim+1)*(jjm+1) for instance
-  ! klev-common-I: Number of vertical layers
-  ! ======================================================================
-  ! Local Variables:
-  ! ================
-
-  ! zgeom-----R: Altitude of layer above ground
-  ! pt, pu, pv --R: t u v from top to bottom
-  ! pdtdt, pdudt, pdvdt --R: t u v tendencies (from top to bottom)
-  ! papmf: pressure at model layer (from top to bottom)
-  ! papmh: pressure at model 1/2 layer (from top to bottom)
-
-  ! ======================================================================
-
-  include "YOMCST.h"
-  include "YOEGWD.h"
-
-  ! ARGUMENTS
-
-  INTEGER nlon, nlev
-  REAL dtime
-  REAL paprs(klon, klev+1)
-  REAL pplay(klon, klev)
-  REAL plat(nlon), pmea(nlon)
-  REAL pstd(nlon), psig(nlon), pgam(nlon), pthe(nlon)
-  REAL ppic(nlon), pval(nlon)
-  REAL pulow(nlon), pvlow(nlon), pustr(nlon), pvstr(nlon)
-  REAL t(nlon, nlev), u(nlon, nlev), v(nlon, nlev)
-  REAL d_t(nlon, nlev), d_u(nlon, nlev), d_v(nlon, nlev)
-
-  INTEGER i, k, kgwd, kdx(nlon), ktest(nlon)
-
-  ! Variables locales:
-
-  REAL zgeom(klon, klev)
-  REAL pdtdt(klon, klev), pdudt(klon, klev), pdvdt(klon, klev)
-  REAL pt(klon, klev), pu(klon, klev), pv(klon, klev)
-  REAL papmf(klon, klev), papmh(klon, klev+1)
-
-  ! initialiser les variables de sortie (pour securite)
-
-
-  ! print *,'in lift_noro'
-  DO i = 1, klon
-    pulow(i) = 0.0
-    pvlow(i) = 0.0
-    pustr(i) = 0.0
-    pvstr(i) = 0.0
-  END DO
-  DO k = 1, klev
-    DO i = 1, klon
-      d_t(i, k) = 0.0
-      d_u(i, k) = 0.0
-      d_v(i, k) = 0.0
-      pdudt(i, k) = 0.0
-      pdvdt(i, k) = 0.0
-      pdtdt(i, k) = 0.0
-    END DO
-  END DO
-
-  ! preparer les variables d'entree (attention: l'ordre des niveaux
-  ! verticaux augmente du haut vers le bas)
-
-  DO k = 1, klev
-    DO i = 1, klon
-      pt(i, k) = t(i, klev-k+1)
-      pu(i, k) = u(i, klev-k+1)
-      pv(i, k) = v(i, klev-k+1)
-      papmf(i, k) = pplay(i, klev-k+1)
-    END DO
-  END DO
-  DO k = 1, klev + 1
-    DO i = 1, klon
-      papmh(i, k) = paprs(i, klev-k+2)
-    END DO
-  END DO
-  DO i = 1, klon
-    zgeom(i, klev) = rd*pt(i, klev)*log(papmh(i,klev+1)/papmf(i,klev))
-  END DO
-  DO k = klev - 1, 1, -1
-    DO i = 1, klon
-      zgeom(i, k) = zgeom(i, k+1) + rd*(pt(i,k)+pt(i,k+1))/2.0*log(papmf(i,k+ &
-        1)/papmf(i,k))
-    END DO
-  END DO
-
-  ! appeler la routine principale
-
-
-  CALL orolift_strato(klon, klev, kgwd, kdx, ktest, dtime, papmh, papmf, &
-    zgeom, pt, pu, pv, plat, pmea, pstd, psig, pgam, pthe, ppic, pval, pulow, &
-    pvlow, pdudt, pdvdt, pdtdt)
-
-  DO k = 1, klev
-    DO i = 1, klon
-      d_u(i, klev+1-k) = dtime*pdudt(i, k)
-      d_v(i, klev+1-k) = dtime*pdvdt(i, k)
-      d_t(i, klev+1-k) = dtime*pdtdt(i, k)
-      pustr(i) = pustr(i) + pdudt(i, k)*(papmh(i,k+1)-papmh(i,k))/rg
-      pvstr(i) = pvstr(i) + pdvdt(i, k)*(papmh(i,k+1)-papmh(i,k))/rg
-    END DO
-  END DO
-
-  ! print *,' out lift_noro'
-
-  RETURN
-END SUBROUTINE lift_noro_strato
-SUBROUTINE orolift_strato(nlon, nlev, kgwd, kdx, ktest, ptsphy, paphm1, &
-    papm1, pgeom1, ptm1, pum1, pvm1, plat, pmea, pstd, psig, pgam, pthe, &
-    ppic, pval &                   ! OUTPUTS
-    , pulow, pvlow, pvom, pvol, pte)
-
-
-  ! **** *OROLIFT: SIMULATE THE GEOSTROPHIC LIFT.
-
-  ! PURPOSE.
-  ! --------
-  ! this routine computes the physical tendencies of the
-  ! prognostic variables u,v  when enhanced vortex stretching
-  ! is needed.
-
-  ! **   INTERFACE.
-  ! ----------
-  ! CALLED FROM *lift_noro
-  ! explicit arguments :
-  ! --------------------
-  ! ==== inputs ===
-  ! nlon----input-I-Total number of horizontal points that get into physics
-  ! nlev----input-I-Number of vertical levels
-
-  ! kgwd- -input-I: Total nb of points where the orography schemes are active
-  ! ktest--input-I: Flags to indicate active points
-  ! kdx----input-I: Locate the physical location of an active point.
-  ! ptsphy--input-R-Time-step (s)
-  ! paphm1--input-R: pressure at model 1/2 layer
-  ! papm1---input-R: pressure at model layer
-  ! pgeom1--input-R: Altitude of layer above ground
-  ! ptm1, pum1, pvm1--R-: t, u and v
-  ! pmea----input-R-Mean Orography (m)
-  ! pstd----input-R-SSO standard deviation (m)
-  ! psig----input-R-SSO slope
-  ! pgam----input-R-SSO Anisotropy
-  ! pthe----input-R-SSO Angle
-  ! ppic----input-R-SSO Peacks elevation (m)
-  ! pval----input-R-SSO Valleys elevation (m)
-  ! plat----input-R-Latitude (degree)
-
-  ! ==== outputs ===
-  ! pulow, pvlow -output-R: Low-level wind
-
-  ! pte -----output-R: T tendency
-  ! pvom-----output-R: U tendency
-  ! pvol-----output-R: V tendency
-
-
-  ! Implicit Arguments:
-  ! ===================
-
-  ! klon-common-I: Number of points seen by the physics
-  ! klev-common-I: Number of vertical layers
-
-
-  ! ----------
-
-  ! AUTHOR.
-  ! -------
-  ! F.LOTT  LMD 22/11/95
-
-  USE dimphy
-  IMPLICIT NONE
-
-
-  include "YOMCST.h"
-  include "YOEGWD.h"
-  ! -----------------------------------------------------------------------
-
-  ! *       0.1   ARGUMENTS
-  ! ---------
-
-
-  INTEGER nlon, nlev, kgwd
-  REAL ptsphy
-  REAL pte(nlon, nlev), pvol(nlon, nlev), pvom(nlon, nlev), pulow(nlon), &
-    pvlow(nlon)
-  REAL pum1(nlon, nlev), pvm1(nlon, nlev), ptm1(nlon, nlev), plat(nlon), &
-    pmea(nlon), pstd(nlon), psig(nlon), pgam(nlon), pthe(nlon), ppic(nlon), &
-    pval(nlon), pgeom1(nlon, nlev), papm1(nlon, nlev), paphm1(nlon, nlev+1)
-
-  INTEGER kdx(nlon), ktest(nlon)
-  ! -----------------------------------------------------------------------
-
-  ! *       0.2   local arrays
-
-  INTEGER jl, ilevh, jk
-  REAL zhgeo, zdelp, zslow, zsqua, zscav, zbet
-  ! ------------
-  INTEGER iknub(klon), iknul(klon)
-  LOGICAL ll1(klon, klev+1)
-
-  REAL ztau(klon, klev+1), ztav(klon, klev+1), zrho(klon, klev+1)
-  REAL zdudt(klon), zdvdt(klon)
-  REAL zhcrit(klon, klev)
-
-  LOGICAL lifthigh
-  REAL zcons1, ztmst
-  CHARACTER (LEN=20) :: modname = 'orolift_strato'
-  CHARACTER (LEN=80) :: abort_message
-
-
-  ! -----------------------------------------------------------------------
-
-  ! *         1.1  initialisations
-  ! ---------------
-
-  lifthigh = .FALSE.
-
-  IF (nlon/=klon .OR. nlev/=klev) THEN
-    abort_message = 'pb dimension'
-    CALL abort_physic(modname, abort_message, 1)
-  END IF
-  zcons1 = 1./rd
-  ztmst = ptsphy
-
-  DO jl = kidia, kfdia
-    zrho(jl, klev+1) = 0.0
-    pulow(jl) = 0.0
-    pvlow(jl) = 0.0
-    iknub(jl) = klev
-    iknul(jl) = klev
-    ilevh = klev/3
-    ll1(jl, klev+1) = .FALSE.
-    DO jk = 1, klev
-      pvom(jl, jk) = 0.0
-      pvol(jl, jk) = 0.0
-      pte(jl, jk) = 0.0
-    END DO
-  END DO
-
-
-  ! *         2.1     DEFINE LOW LEVEL WIND, PROJECT WINDS IN PLANE OF
-  ! *                 LOW LEVEL WIND, DETERMINE SECTOR IN WHICH TO TAKE
-  ! *                 THE VARIANCE AND SET INDICATOR FOR CRITICAL LEVELS.
-
-
-
-  DO jk = klev, 1, -1
-    DO jl = kidia, kfdia
-      IF (ktest(jl)==1) THEN
-        zhcrit(jl, jk) = amax1(ppic(jl)-pval(jl), 100.)
-        zhgeo = pgeom1(jl, jk)/rg
-        ll1(jl, jk) = (zhgeo>zhcrit(jl,jk))
-        IF (ll1(jl,jk) .NEQV. ll1(jl,jk+1)) THEN
-          iknub(jl) = jk
-        END IF
-      END IF
-    END DO
-  END DO
-
-
-  DO jl = kidia, kfdia
-    IF (ktest(jl)==1) THEN
-      iknub(jl) = max(iknub(jl), klev/2)
-      iknul(jl) = max(iknul(jl), 2*klev/3)
-      IF (iknub(jl)>nktopg) iknub(jl) = nktopg
-      IF (iknub(jl)==nktopg) iknul(jl) = klev
-      IF (iknub(jl)==iknul(jl)) iknub(jl) = iknul(jl) - 1
-    END IF
-  END DO
-
-  DO jk = klev, 2, -1
-    DO jl = kidia, kfdia
-      zrho(jl, jk) = 2.*paphm1(jl, jk)*zcons1/(ptm1(jl,jk)+ptm1(jl,jk-1))
-    END DO
-  END DO
-  ! print *,'  dans orolift: 223'
-
-  ! ********************************************************************
-
-  ! *     define low level flow
-  ! -------------------
-  DO jk = klev, 1, -1
-    DO jl = kidia, kfdia
-      IF (ktest(jl)==1) THEN
-        IF (jk>=iknub(jl) .AND. jk<=iknul(jl)) THEN
-          pulow(jl) = pulow(jl) + pum1(jl, jk)*(paphm1(jl,jk+1)-paphm1(jl,jk) &
-            )
-          pvlow(jl) = pvlow(jl) + pvm1(jl, jk)*(paphm1(jl,jk+1)-paphm1(jl,jk) &
-            )
-          zrho(jl, klev+1) = zrho(jl, klev+1) + zrho(jl, jk)*(paphm1(jl,jk+1) &
-            -paphm1(jl,jk))
-        END IF
-      END IF
-    END DO
-  END DO
-  DO jl = kidia, kfdia
-    IF (ktest(jl)==1) THEN
-      pulow(jl) = pulow(jl)/(paphm1(jl,iknul(jl)+1)-paphm1(jl,iknub(jl)))
-      pvlow(jl) = pvlow(jl)/(paphm1(jl,iknul(jl)+1)-paphm1(jl,iknub(jl)))
-      zrho(jl, klev+1) = zrho(jl, klev+1)/(paphm1(jl,iknul(jl)+1)-paphm1(jl, &
-        iknub(jl)))
-    END IF
-  END DO
-
-  ! ***********************************************************
-
-  ! *         3.      COMPUTE MOUNTAIN LIFT
-
-
-  DO jl = kidia, kfdia
-    IF (ktest(jl)==1) THEN
-      ztau(jl, klev+1) = -gklift*zrho(jl, klev+1)*2.*romega* & ! *
-                                                               ! (2*pstd(jl)+pmea(jl))*
-        2*pstd(jl)*sin(rpi/180.*plat(jl))*pvlow(jl)
-      ztav(jl, klev+1) = gklift*zrho(jl, klev+1)*2.*romega* & ! *
-                                                              ! (2*pstd(jl)+pmea(jl))*
-        2*pstd(jl)*sin(rpi/180.*plat(jl))*pulow(jl)
-    ELSE
-      ztau(jl, klev+1) = 0.0
-      ztav(jl, klev+1) = 0.0
-    END IF
-  END DO
-
-  ! *         4.      COMPUTE LIFT PROFILE
-  ! *                 --------------------
-
-
-
-  DO jk = 1, klev
-    DO jl = kidia, kfdia
-      IF (ktest(jl)==1) THEN
-        ztau(jl, jk) = ztau(jl, klev+1)*paphm1(jl, jk)/paphm1(jl, klev+1)
-        ztav(jl, jk) = ztav(jl, klev+1)*paphm1(jl, jk)/paphm1(jl, klev+1)
-      ELSE
-        ztau(jl, jk) = 0.0
-        ztav(jl, jk) = 0.0
-      END IF
-    END DO
-  END DO
-
-
-  ! *         5.      COMPUTE TENDENCIES.
-  ! *                 -------------------
-  IF (lifthigh) THEN
-    ! EXPLICIT SOLUTION AT ALL LEVELS
-
-    DO jk = 1, klev
-      DO jl = kidia, kfdia
-        IF (ktest(jl)==1) THEN
-          zdelp = paphm1(jl, jk+1) - paphm1(jl, jk)
-          zdudt(jl) = -rg*(ztau(jl,jk+1)-ztau(jl,jk))/zdelp
-          zdvdt(jl) = -rg*(ztav(jl,jk+1)-ztav(jl,jk))/zdelp
-        END IF
-      END DO
-    END DO
-
-    ! PROJECT PERPENDICULARLY TO U NOT TO DESTROY ENERGY
-
-    DO jk = 1, klev
-      DO jl = kidia, kfdia
-        IF (ktest(jl)==1) THEN
-
-          zslow = sqrt(pulow(jl)**2+pvlow(jl)**2)
-          zsqua = amax1(sqrt(pum1(jl,jk)**2+pvm1(jl,jk)**2), gvsec)
-          zscav = -zdudt(jl)*pvm1(jl, jk) + zdvdt(jl)*pum1(jl, jk)
-          IF (zsqua>gvsec) THEN
-            pvom(jl, jk) = -zscav*pvm1(jl, jk)/zsqua**2
-            pvol(jl, jk) = zscav*pum1(jl, jk)/zsqua**2
-          ELSE
-            pvom(jl, jk) = 0.0
-            pvol(jl, jk) = 0.0
-          END IF
-          zsqua = sqrt(pum1(jl,jk)**2+pum1(jl,jk)**2)
-          IF (zsqua<zslow) THEN
-            pvom(jl, jk) = zsqua/zslow*pvom(jl, jk)
-            pvol(jl, jk) = zsqua/zslow*pvol(jl, jk)
-          END IF
-
-        END IF
-      END DO
-    END DO
-
-    ! 6.  LOW LEVEL LIFT, SEMI IMPLICIT:
-    ! ----------------------------------
-
-  ELSE
-
-    DO jl = kidia, kfdia
-      IF (ktest(jl)==1) THEN
-        DO jk = klev, iknub(jl), -1
-          zbet = gklift*2.*romega*sin(rpi/180.*plat(jl))*ztmst* &
-            (pgeom1(jl,iknub(jl)-1)-pgeom1(jl,jk))/ &
-            (pgeom1(jl,iknub(jl)-1)-pgeom1(jl,klev))
-          zdudt(jl) = -pum1(jl, jk)/ztmst/(1+zbet**2)
-          zdvdt(jl) = -pvm1(jl, jk)/ztmst/(1+zbet**2)
-          pvom(jl, jk) = zbet**2*zdudt(jl) - zbet*zdvdt(jl)
-          pvol(jl, jk) = zbet*zdudt(jl) + zbet**2*zdvdt(jl)
-        END DO
-      END IF
-    END DO
-
-  END IF
-
-  ! print *,' out orolift'
-
-  RETURN
-END SUBROUTINE orolift_strato
-SUBROUTINE sugwd_strato(nlon, nlev, paprs, pplay)
-
-
-  ! **** *SUGWD* INITIALIZE COMMON YOEGWD CONTROLLING GRAVITY WAVE DRAG
-
-  ! PURPOSE.
-  ! --------
-  ! INITIALIZE YOEGWD, THE COMMON THAT CONTROLS THE
-  ! GRAVITY WAVE DRAG PARAMETRIZATION.
-  ! VERY IMPORTANT:
-  ! ______________
-  ! THIS ROUTINE SET_UP THE "TUNABLE PARAMETERS" OF THE
-  ! VARIOUS SSO SCHEMES
-
-  ! **   INTERFACE.
-  ! ----------
-  ! CALL *SUGWD* FROM *SUPHEC*
-  ! -----        ------
-
-  ! EXPLICIT ARGUMENTS :
-  ! --------------------
-  ! PAPRS,PPLAY : Pressure at semi and full model levels
-  ! NLEV        : number of model levels
-  ! NLON        : number of points treated in the physics
-
-  ! IMPLICIT ARGUMENTS :
-  ! --------------------
-  ! COMMON YOEGWD
-  ! -GFRCRIT-R:  Critical Non-dimensional mountain Height
-  ! (HNC in (1),    LOTT 1999)
-  ! -GKWAKE--R:  Bluff-body drag coefficient for low level wake
-  ! (Cd in (2),     LOTT 1999)
-  ! -GRCRIT--R:  Critical Richardson Number
-  ! (Ric, End of first column p791 of LOTT 1999)
-  ! -GKDRAG--R:  Gravity wave drag coefficient
-  ! (G in (3),      LOTT 1999)
-  ! -GKLIFT--R:  Mountain Lift coefficient
-  ! (Cl in (4),     LOTT 1999)
-  ! -GHMAX---R:  Not used
-  ! -GRAHILO-R:  Set-up the trapped waves fraction
-  ! (Beta , End of first column,  LOTT 1999)
-
-  ! -GSIGCR--R:  Security value for blocked flow depth
-  ! -NKTOPG--I:  Security value for blocked flow level
-  ! -nstra----I:  An estimate to qualify the upper levels of
-  ! the model where one wants to impose strees
-  ! profiles
-  ! -GSSECC--R:  Security min value for low-level B-V frequency
-  ! -GTSEC---R:  Security min value for anisotropy and GW stress.
-  ! -GVSEC---R:  Security min value for ulow
-
-
-  ! METHOD.
-  ! -------
-  ! SEE DOCUMENTATION
-
-  ! EXTERNALS.
-  ! ----------
-  ! NONE
-
-  ! REFERENCE.
-  ! ----------
-  ! Lott, 1999: Alleviation of stationary biases in a GCM through...
-  ! Monthly Weather Review, 127, pp 788-801.
-
-  ! AUTHOR.
-  ! -------
-  ! FRANCOIS LOTT        *LMD*
-
-  ! MODIFICATIONS.
-  ! --------------
-  ! ORIGINAL : 90-01-01 (MARTIN MILLER, ECMWF)
-  ! LAST:  99-07-09     (FRANCOIS LOTT,LMD)
-  ! ------------------------------------------------------------------
-  USE dimphy
-  USE mod_phys_lmdz_para
-  USE mod_grid_phy_lmdz
-  USE geometry_mod
-  IMPLICIT NONE
-
-  ! -----------------------------------------------------------------
-  include "YOEGWD.h"
-  ! ----------------------------------------------------------------
-
-  ! ARGUMENTS
-  INTEGER nlon, nlev
-  REAL paprs(nlon, nlev+1)
-  REAL pplay(nlon, nlev)
-
-  INTEGER jk
-  REAL zpr, ztop, zsigt, zpm1r
-  INTEGER :: cell,ij,nstra_tmp,nktopg_tmp
-  REAL :: current_dist, dist_min,dist_min_glo
-
-  ! *       1.    SET THE VALUES OF THE PARAMETERS
-  ! --------------------------------
-
-
-  PRINT *, ' DANS SUGWD NLEV=', nlev
-  ghmax = 10000.
-
-  zpr = 100000.
-  ZTOP=0.00005
-  zsigt = 0.94
-  ! old  ZPR=80000.
-  ! old  ZSIGT=0.85
-
-
-!ym Take the point at equator close to (0,0) coordinates.
-  dist_min=360
-  dist_min_glo=360.
-  cell=-1
-  DO ij=1,klon
-    current_dist=sqrt(longitude_deg(ij)**2+latitude_deg(ij)**2)
-    current_dist=current_dist*(1+(1e-10*ind_cell_glo(ij))/klon_glo) ! For point unicity
-    IF (dist_min>current_dist) THEN
-      dist_min=current_dist
-      cell=ij    
-    ENDIF  
-  ENDDO
-  
-  !PRINT *, 'SUGWD distmin cell=', dist_min,cell
-  CALL reduce_min(dist_min,dist_min_glo)
-  CALL bcast(dist_min_glo)
-  IF (dist_min/=dist_min_glo) cell=-1
-!ym in future find the point at equator close to (0,0) coordinates.
-  PRINT *, 'SUGWD distmin dist_min_glo cell=', dist_min,dist_min_glo,cell
-
-  nktopg_tmp=nktopg
-  nstra_tmp=nstra
-  
-  IF (cell/=-1) THEN
-
-    !print*,'SUGWD shape ',shape(pplay),cell+1
-
-    DO jk = 1, nlev
-      !zpm1r = pplay(cell+1, jk)/paprs(cell+1, 1)
-      zpm1r = pplay(cell, jk)/paprs(cell, 1)
-      IF (zpm1r>=zsigt) THEN
-        nktopg_tmp = jk
-      END IF
-      IF (zpm1r>=ztop) THEN
-        nstra_tmp = jk
-      END IF
-    END DO
-  ELSE
-    nktopg_tmp=0
-    nstra_tmp=0
-  ENDIF
-  
-  CALL reduce_sum(nktopg_tmp,nktopg)
-  CALL bcast(nktopg)
-  CALL reduce_sum(nstra_tmp,nstra)
-  CALL bcast(nstra)
-  
-  ! inversion car dans orodrag on compte les niveaux a l'envers
-  nktopg = nlev - nktopg + 1
-  nstra = nlev - nstra
-  PRINT *, ' DANS SUGWD nktopg=', nktopg
-  PRINT *, ' DANS SUGWD nstra=', nstra
-  if (nstra == 0) call abort_physic("sugwd_strato", "no level in stratosphere", 1)
-
-!  Valeurs lues dans les .def, ou attribues dans conf_phys
-  !gkdrag = 0.2   
-  !grahilo = 0.1
-  !grcrit = 1.00
-  !gfrcrit = 0.70
-  !gkwake = 0.40
-  !gklift = 0.25
-
-  gsigcr = 0.80 ! Top of low level flow
-  gvcrit = 0.1
-
-  WRITE (UNIT=6, FMT='('' *** SSO essential constants ***'')')
-  WRITE (UNIT=6, FMT='('' *** SPECIFIED IN SUGWD ***'')')
-  WRITE (UNIT=6, FMT='('' Gravity wave ct '',E13.7,'' '')') gkdrag
-  WRITE (UNIT=6, FMT='('' Trapped/total wave dag '',E13.7,'' '')') grahilo
-  WRITE (UNIT=6, FMT='('' Critical Richardson   = '',E13.7,'' '')') grcrit
-  WRITE (UNIT=6, FMT='('' Critical Froude'',e13.7)') gfrcrit
-  WRITE (UNIT=6, FMT='('' Low level Wake bluff cte'',e13.7)') gkwake
-  WRITE (UNIT=6, FMT='('' Low level lift  cte'',e13.7)') gklift
-
-  ! ----------------------------------------------------------------
-
-  ! *       2.    SET VALUES OF SECURITY PARAMETERS
-  ! ---------------------------------
-
-
-  gvsec = 0.10
-  gssec = 0.0001
-
-  gtsec = 0.00001
-
-  RETURN
-END SUBROUTINE sugwd_strato
Index: /LMDZ6/trunk/libf/phylmd/orografi_strato.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/orografi_strato.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/orografi_strato.f90	(revision 5268)
@@ -0,0 +1,1938 @@
+SUBROUTINE drag_noro_strato(partdrag, nlon, nlev, dtime, paprs, pplay, pmea, pstd, &
+    psig, pgam, pthe, ppic, pval, kgwd, kdx, ktest, t, u, v, pulow, pvlow, &
+    pustr, pvstr, d_t, d_u, d_v)
+
+  USE dimphy
+  IMPLICIT NONE
+  ! ======================================================================
+  ! Auteur(s): F.Lott (LMD/CNRS) date: 19950201
+  ! Object: Mountain drag interface. Made necessary because:
+  ! 1. in the LMD-GCM Layers are from bottom to top,
+  ! contrary to most European GCM.
+  ! 2. the altitude above ground of each model layers
+  ! needs to be known (variable zgeom)
+  ! ======================================================================
+  ! Explicit Arguments:
+  ! ==================
+  ! partdrag-input-I-control which part of the drag we consider (total part or GW part)
+  ! nlon----input-I-Total number of horizontal points that get into physics
+  ! nlev----input-I-Number of vertical levels
+  ! dtime---input-R-Time-step (s)
+  ! paprs---input-R-Pressure in semi layers    (Pa)
+  ! pplay---input-R-Pressure model-layers      (Pa)
+  ! t-------input-R-temperature (K)
+  ! u-------input-R-Horizontal wind (m/s)
+  ! v-------input-R-Meridional wind (m/s)
+  ! pmea----input-R-Mean Orography (m)
+  ! pstd----input-R-SSO standard deviation (m)
+  ! psig----input-R-SSO slope
+  ! pgam----input-R-SSO Anisotropy
+  ! pthe----input-R-SSO Angle
+  ! ppic----input-R-SSO Peacks elevation (m)
+  ! pval----input-R-SSO Valleys elevation (m)
+
+  ! kgwd- -input-I: Total nb of points where the orography schemes are active
+  ! ktest--input-I: Flags to indicate active points
+  ! kdx----input-I: Locate the physical location of an active point.
+
+  ! pulow, pvlow -output-R: Low-level wind
+  ! pustr, pvstr -output-R: Surface stress due to SSO drag      (Pa)
+
+  ! d_t-----output-R: T increment
+  ! d_u-----output-R: U increment
+  ! d_v-----output-R: V increment
+
+  ! Implicit Arguments:
+  ! ===================
+
+  ! iim--common-I: Number of longitude intervals
+  ! jjm--common-I: Number of latitude intervals
+  ! klon-common-I: Number of points seen by the physics
+  ! (iim+1)*(jjm+1) for instance
+  ! klev-common-I: Number of vertical layers
+  ! ======================================================================
+  ! Local Variables:
+  ! ================
+
+  ! zgeom-----R: Altitude of layer above ground
+  ! pt, pu, pv --R: t u v from top to bottom
+  ! pdtdt, pdudt, pdvdt --R: t u v tendencies (from top to bottom)
+  ! papmf: pressure at model layer (from top to bottom)
+  ! papmh: pressure at model 1/2 layer (from top to bottom)
+
+  ! ======================================================================
+  include "YOMCST.h"
+  include "YOEGWD.h"
+
+  ! ARGUMENTS
+
+  INTEGER partdrag,nlon, nlev
+  REAL dtime
+  REAL paprs(nlon, nlev+1)
+  REAL pplay(nlon, nlev)
+  REAL pmea(nlon), pstd(nlon), psig(nlon), pgam(nlon), pthe(nlon)
+  REAL ppic(nlon), pval(nlon)
+  REAL pulow(nlon), pvlow(nlon), pustr(nlon), pvstr(nlon)
+  REAL t(nlon, nlev), u(nlon, nlev), v(nlon, nlev)
+  REAL d_t(nlon, nlev), d_u(nlon, nlev), d_v(nlon, nlev)
+
+  INTEGER i, k, kgwd, kdx(nlon), ktest(nlon)
+
+  ! LOCAL VARIABLES:
+
+  REAL zgeom(klon, klev)
+  REAL pdtdt(klon, klev), pdudt(klon, klev), pdvdt(klon, klev)
+  REAL pt(klon, klev), pu(klon, klev), pv(klon, klev)
+  REAL papmf(klon, klev), papmh(klon, klev+1)
+  CHARACTER (LEN=20) :: modname = 'orografi_strato'
+  CHARACTER (LEN=80) :: abort_message
+
+  ! INITIALIZE OUTPUT VARIABLES
+
+  DO i = 1, klon
+    pulow(i) = 0.0
+    pvlow(i) = 0.0
+    pustr(i) = 0.0
+    pvstr(i) = 0.0
+  END DO
+  DO k = 1, klev
+    DO i = 1, klon
+      d_t(i, k) = 0.0
+      d_u(i, k) = 0.0
+      d_v(i, k) = 0.0
+      pdudt(i, k) = 0.0
+      pdvdt(i, k) = 0.0
+      pdtdt(i, k) = 0.0
+    END DO
+  END DO
+
+  ! PREPARE INPUT VARIABLES FOR ORODRAG (i.e., ORDERED FROM TOP TO BOTTOM)
+  ! CALCULATE LAYERS HEIGHT ABOVE GROUND)
+
+  DO k = 1, klev
+    DO i = 1, klon
+      pt(i, k) = t(i, klev-k+1)
+      pu(i, k) = u(i, klev-k+1)
+      pv(i, k) = v(i, klev-k+1)
+      papmf(i, k) = pplay(i, klev-k+1)
+    END DO
+  END DO
+  DO k = 1, klev + 1
+    DO i = 1, klon
+      papmh(i, k) = paprs(i, klev-k+2)
+    END DO
+  END DO
+  DO i = 1, klon
+    zgeom(i, klev) = rd*pt(i, klev)*log(papmh(i,klev+1)/papmf(i,klev))
+  END DO
+  DO k = klev - 1, 1, -1
+    DO i = 1, klon
+      zgeom(i, k) = zgeom(i, k+1) + rd*(pt(i,k)+pt(i,k+1))/2.0*log(papmf(i,k+ &
+        1)/papmf(i,k))
+    END DO
+  END DO
+
+  ! CALL SSO DRAG ROUTINES
+
+  CALL orodrag_strato(partdrag,klon, klev, kgwd, kdx, ktest, dtime, papmh, papmf, &
+    zgeom, pt, pu, pv, pmea, pstd, psig, pgam, pthe, ppic, pval, pulow, &
+    pvlow, pdudt, pdvdt, pdtdt)
+
+  ! COMPUTE INCREMENTS AND STRESS FROM TENDENCIES
+
+  DO k = 1, klev
+    DO i = 1, klon
+      d_u(i, klev+1-k) = dtime*pdudt(i, k)
+      d_v(i, klev+1-k) = dtime*pdvdt(i, k)
+      d_t(i, klev+1-k) = dtime*pdtdt(i, k)
+      pustr(i) = pustr(i) + pdudt(i, k)*(papmh(i,k+1)-papmh(i,k))/rg
+      pvstr(i) = pvstr(i) + pdvdt(i, k)*(papmh(i,k+1)-papmh(i,k))/rg
+    END DO
+  END DO
+
+  RETURN
+END SUBROUTINE drag_noro_strato
+
+SUBROUTINE orodrag_strato(partdrag,nlon, nlev, kgwd, kdx, ktest, ptsphy, paphm1, &
+    papm1, pgeom1, ptm1, pum1, pvm1, pmea, pstd, psig, pgam, pthe, ppic, pval &
+  ! outputs
+    , pulow, pvlow, pvom, pvol, pte)
+
+  USE dimphy
+  IMPLICIT NONE
+
+
+  ! **** *orodrag* - does the SSO drag  parametrization.
+
+  ! purpose.
+  ! --------
+
+  ! this routine computes the physical tendencies of the
+  ! prognostic variables u,v  and t due to  vertical transports by
+  ! subgridscale orographically excited gravity waves, and to
+  ! low level blocked flow drag.
+
+  ! **   interface.
+  ! ----------
+  ! called from *drag_noro*.
+
+  ! the routine takes its input from the long-term storage:
+  ! u,v,t and p at t-1.
+
+  ! explicit arguments :
+  ! --------------------
+  ! ==== inputs ===
+  ! partdrag-input-I-control which part of the drag we consider (total part or GW part)
+  ! nlon----input-I-Total number of horizontal points that get into physics
+  ! nlev----input-I-Number of vertical levels
+
+  ! kgwd- -input-I: Total nb of points where the orography schemes are active
+  ! ktest--input-I: Flags to indicate active points
+  ! kdx----input-I: Locate the physical location of an active point.
+  ! ptsphy--input-R-Time-step (s)
+  ! paphm1--input-R: pressure at model 1/2 layer
+  ! papm1---input-R: pressure at model layer
+  ! pgeom1--input-R: Altitude of layer above ground
+  ! ptm1, pum1, pvm1--R-: t, u and v
+  ! pmea----input-R-Mean Orography (m)
+  ! pstd----input-R-SSO standard deviation (m)
+  ! psig----input-R-SSO slope
+  ! pgam----input-R-SSO Anisotropy
+  ! pthe----input-R-SSO Angle
+  ! ppic----input-R-SSO Peacks elevation (m)
+  ! pval----input-R-SSO Valleys elevation (m)
+
+  INTEGER  nlon, nlev, kgwd
+  REAL ptsphy
+
+  ! ==== outputs ===
+  ! pulow, pvlow -output-R: Low-level wind
+
+  ! pte -----output-R: T tendency
+  ! pvom-----output-R: U tendency
+  ! pvol-----output-R: V tendency
+
+
+  ! Implicit Arguments:
+  ! ===================
+
+  ! klon-common-I: Number of points seen by the physics
+  ! klev-common-I: Number of vertical layers
+
+  ! method.
+  ! -------
+
+  ! externals.
+  ! ----------
+  INTEGER ismin, ismax
+  EXTERNAL ismin, ismax
+
+  ! reference.
+  ! ----------
+
+  ! author.
+  ! -------
+  ! m.miller + b.ritter   e.c.m.w.f.     15/06/86.
+
+  ! f.lott + m. miller    e.c.m.w.f.     22/11/94
+  ! -----------------------------------------------------------------------
+
+
+  include "YOMCST.h"
+  include "YOEGWD.h"
+
+  ! -----------------------------------------------------------------------
+
+  ! *       0.1   arguments
+  ! ---------
+
+  INTEGER partdrag
+  REAL pte(nlon, nlev), pvol(nlon, nlev), pvom(nlon, nlev), pulow(nlon), &
+    pvlow(nlon)
+  REAL pum1(nlon, nlev), pvm1(nlon, nlev), ptm1(nlon, nlev), pmea(nlon), &
+    pstd(nlon), psig(nlon), pgam(nlon), pthe(nlon), ppic(nlon), pval(nlon), &
+    pgeom1(nlon, nlev), papm1(nlon, nlev), paphm1(nlon, nlev+1)
+
+  INTEGER kdx(nlon), ktest(nlon)
+  ! -----------------------------------------------------------------------
+
+  ! *       0.2   local arrays
+  ! ------------
+  INTEGER isect(klon), icrit(klon), ikcrith(klon), ikenvh(klon), iknu(klon), &
+    iknu2(klon), ikcrit(klon), ikhlim(klon)
+
+  REAL ztau(klon, klev+1), zstab(klon, klev+1), zvph(klon, klev+1), &
+    zrho(klon, klev+1), zri(klon, klev+1), zpsi(klon, klev+1), &
+    zzdep(klon, klev)
+  REAL zdudt(klon), zdvdt(klon), zdtdt(klon), zdedt(klon), zvidis(klon), &
+    ztfr(klon), znu(klon), zd1(klon), zd2(klon), zdmod(klon)
+
+
+  ! local quantities:
+
+  INTEGER jl, jk, ji
+  REAL ztmst, zdelp, ztemp, zforc, ztend, rover, facpart
+  REAL zb, zc, zconb, zabsv, zzd1, ratio, zbet, zust, zvst, zdis
+
+  ! ------------------------------------------------------------------
+
+  ! *         1.    initialization
+  ! --------------
+
+  ! print *,' in orodrag'
+
+  ! ------------------------------------------------------------------
+
+  ! *         1.1   computational constants
+  ! -----------------------
+
+
+  ! ztmst=twodt
+  ! if(nstep.eq.nstart) ztmst=0.5*twodt
+  ztmst = ptsphy
+
+  ! ------------------------------------------------------------------
+
+  ! *         1.3   check whether row contains point for printing
+  ! ---------------------------------------------
+
+
+  ! ------------------------------------------------------------------
+
+  ! *         2.     precompute basic state variables.
+  ! *                ---------- ----- ----- ----------
+  ! *                define low level wind, project winds in plane of
+  ! *                low level wind, determine sector in which to take
+  ! *                the variance and set indicator for critical levels.
+
+
+
+
+
+  CALL orosetup_strato(nlon, nlev, ktest, ikcrit, ikcrith, icrit, isect, &
+    ikhlim, ikenvh, iknu, iknu2, paphm1, papm1, pum1, pvm1, ptm1, pgeom1, &
+    pstd, zrho, zri, zstab, ztau, zvph, zpsi, zzdep, pulow, pvlow, pthe, &
+    pgam, pmea, ppic, pval, znu, zd1, zd2, zdmod)
+
+  ! ***********************************************************
+
+
+  ! *         3.      compute low level stresses using subcritical and
+  ! *                 supercritical forms.computes anisotropy coefficient
+  ! *                 as measure of orographic twodimensionality.
+
+
+  CALL gwstress_strato(nlon, nlev, ikcrit, isect, ikhlim, ktest, ikcrith, &
+    icrit, ikenvh, iknu, zrho, zstab, zvph, pstd, psig, pmea, ppic, pval, &
+    ztfr, ztau, pgeom1, pgam, zd1, zd2, zdmod, znu)
+
+  ! *         4.      compute stress profile including
+  ! trapped waves, wave breaking,
+  ! linear decay in stratosphere.
+
+
+
+
+  CALL gwprofil_strato(nlon, nlev, kgwd, kdx, ktest, ikcrit, ikcrith, icrit, &
+    ikenvh, iknu, iknu2, paphm1, zrho, zstab, ztfr, zvph, zri, ztau &
+    , zdmod, znu, psig, pgam, pstd, ppic, pval)
+
+  ! *         5.      Compute tendencies from waves stress profile.
+  ! Compute low level blocked flow drag.
+  ! *                 --------------------------------------------
+
+
+
+
+  ! explicit solution at all levels for the gravity wave
+  ! implicit solution for the blocked levels
+
+  DO jl = kidia, kfdia
+    zvidis(jl) = 0.0
+    zdudt(jl) = 0.0
+    zdvdt(jl) = 0.0
+    zdtdt(jl) = 0.0
+  END DO
+
+
+  DO jk = 1, klev
+
+
+    ! WAVE STRESS
+    ! -------------
+
+
+    DO ji = kidia, kfdia
+
+      IF (ktest(ji)==1) THEN
+
+        zdelp = paphm1(ji, jk+1) - paphm1(ji, jk)
+        ztemp = -rg*(ztau(ji,jk+1)-ztau(ji,jk))/(zvph(ji,klev+1)*zdelp)
+
+        zdudt(ji) = (pulow(ji)*zd1(ji)-pvlow(ji)*zd2(ji))*ztemp/zdmod(ji)
+        zdvdt(ji) = (pvlow(ji)*zd1(ji)+pulow(ji)*zd2(ji))*ztemp/zdmod(ji)
+
+        ! Control Overshoots
+
+
+        IF (jk>=nstra) THEN
+          rover = 0.10
+          IF (abs(zdudt(ji))>rover*abs(pum1(ji,jk))/ztmst) zdudt(ji) = rover* &
+            abs(pum1(ji,jk))/ztmst*zdudt(ji)/(abs(zdudt(ji))+1.E-10)
+          IF (abs(zdvdt(ji))>rover*abs(pvm1(ji,jk))/ztmst) zdvdt(ji) = rover* &
+            abs(pvm1(ji,jk))/ztmst*zdvdt(ji)/(abs(zdvdt(ji))+1.E-10)
+        END IF
+
+        rover = 0.25
+        zforc = sqrt(zdudt(ji)**2+zdvdt(ji)**2)
+        ztend = sqrt(pum1(ji,jk)**2+pvm1(ji,jk)**2)/ztmst
+
+        IF (zforc>=rover*ztend) THEN
+          zdudt(ji) = rover*ztend/zforc*zdudt(ji)
+          zdvdt(ji) = rover*ztend/zforc*zdvdt(ji)
+        END IF
+
+        ! BLOCKED FLOW DRAG:
+        ! -----------------
+
+        IF (partdrag .GE. 2) THEN
+        facpart=0.
+        ELSE
+        facpart=gkwake
+        ENDIF
+
+
+        IF (jk>ikenvh(ji)) THEN
+          zb = 1.0 - 0.18*pgam(ji) - 0.04*pgam(ji)**2
+          zc = 0.48*pgam(ji) + 0.3*pgam(ji)**2
+          zconb = 2.*ztmst*facpart*psig(ji)/(4.*pstd(ji))
+          zabsv = sqrt(pum1(ji,jk)**2+pvm1(ji,jk)**2)/2.
+          zzd1 = zb*cos(zpsi(ji,jk))**2 + zc*sin(zpsi(ji,jk))**2
+          ratio = (cos(zpsi(ji,jk))**2+pgam(ji)*sin(zpsi(ji, &
+            jk))**2)/(pgam(ji)*cos(zpsi(ji,jk))**2+sin(zpsi(ji,jk))**2)
+          zbet = max(0., 2.-1./ratio)*zconb*zzdep(ji, jk)*zzd1*zabsv
+
+          ! OPPOSED TO THE WIND
+
+          zdudt(ji) = -pum1(ji, jk)/ztmst
+          zdvdt(ji) = -pvm1(ji, jk)/ztmst
+
+          ! PERPENDICULAR TO THE SSO MAIN AXIS:
+
+          ! mod     zdudt(ji)=-(pum1(ji,jk)*cos(pthe(ji)*rpi/180.)
+          ! mod *              +pvm1(ji,jk)*sin(pthe(ji)*rpi/180.))
+          ! mod *              *cos(pthe(ji)*rpi/180.)/ztmst
+          ! mod     zdvdt(ji)=-(pum1(ji,jk)*cos(pthe(ji)*rpi/180.)
+          ! mod *              +pvm1(ji,jk)*sin(pthe(ji)*rpi/180.))
+          ! mod *              *sin(pthe(ji)*rpi/180.)/ztmst
+
+          zdudt(ji) = zdudt(ji)*(zbet/(1.+zbet))
+          zdvdt(ji) = zdvdt(ji)*(zbet/(1.+zbet))
+        END IF
+        pvom(ji, jk) = zdudt(ji)
+        pvol(ji, jk) = zdvdt(ji)
+        zust = pum1(ji, jk) + ztmst*zdudt(ji)
+        zvst = pvm1(ji, jk) + ztmst*zdvdt(ji)
+        zdis = 0.5*(pum1(ji,jk)**2+pvm1(ji,jk)**2-zust**2-zvst**2)
+        zdedt(ji) = zdis/ztmst
+        zvidis(ji) = zvidis(ji) + zdis*zdelp
+        zdtdt(ji) = zdedt(ji)/rcpd
+
+        ! NO TENDENCIES ON TEMPERATURE .....
+
+        ! Instead of, pte(ji,jk)=zdtdt(ji), due to mechanical dissipation
+
+        pte(ji, jk) = 0.0
+
+      END IF
+
+    END DO
+  END DO
+
+  RETURN
+END SUBROUTINE orodrag_strato
+SUBROUTINE orosetup_strato(nlon, nlev, ktest, kkcrit, kkcrith, kcrit, ksect, &
+    kkhlim, kkenvh, kknu, kknu2, paphm1, papm1, pum1, pvm1, ptm1, pgeom1, &
+    pstd, prho, pri, pstab, ptau, pvph, ppsi, pzdep, pulow, pvlow, ptheta, &
+    pgam, pmea, ppic, pval, pnu, pd1, pd2, pdmod)
+
+  ! **** *gwsetup*
+
+  ! purpose.
+  ! --------
+  ! SET-UP THE ESSENTIAL PARAMETERS OF THE SSO DRAG SCHEME:
+  ! DEPTH OF LOW WBLOCKED LAYER, LOW-LEVEL FLOW, BACKGROUND
+  ! STRATIFICATION.....
+
+  ! **   interface.
+  ! ----------
+  ! from *orodrag*
+
+  ! explicit arguments :
+  ! --------------------
+  ! ==== inputs ===
+
+  ! nlon----input-I-Total number of horizontal points that get into physics
+  ! nlev----input-I-Number of vertical levels
+  ! ktest--input-I: Flags to indicate active points
+
+  ! ptsphy--input-R-Time-step (s)
+  ! paphm1--input-R: pressure at model 1/2 layer
+  ! papm1---input-R: pressure at model layer
+  ! pgeom1--input-R: Altitude of layer above ground
+  ! ptm1, pum1, pvm1--R-: t, u and v
+  ! pmea----input-R-Mean Orography (m)
+  ! pstd----input-R-SSO standard deviation (m)
+  ! psig----input-R-SSO slope
+  ! pgam----input-R-SSO Anisotropy
+  ! pthe----input-R-SSO Angle
+  ! ppic----input-R-SSO Peacks elevation (m)
+  ! pval----input-R-SSO Valleys elevation (m)
+
+  ! ==== outputs ===
+  ! pulow, pvlow -output-R: Low-level wind
+  ! kkcrit----I-: Security value for top of low level flow
+  ! kcrit-----I-: Critical level
+  ! ksect-----I-: Not used
+  ! kkhlim----I-: Not used
+  ! kkenvh----I-: Top of blocked flow layer
+  ! kknu------I-: Layer that sees mountain peacks
+  ! kknu2-----I-: Layer that sees mountain peacks above mountain mean
+  ! kknub-----I-: Layer that sees mountain mean above valleys
+  ! prho------R-: Density at 1/2 layers
+  ! pri-------R-: Background Richardson Number, Wind shear measured along GW
+  ! stress
+  ! pstab-----R-: Brunt-Vaisala freq. at 1/2 layers
+  ! pvph------R-: Wind in  plan of GW stress, Half levels.
+  ! ppsi------R-: Angle between low level wind and SS0 main axis.
+  ! pd1-------R-| Compared the ratio of the stress
+  ! pd2-------R-| that is along the wind to that Normal to it.
+  ! pdi define the plane of low level stress
+  ! compared to the low level wind.
+  ! see p. 108 Lott & Miller (1997).
+  ! pdmod-----R-: Norme of pdi
+
+  ! === local arrays ===
+
+  ! zvpf------R-: Wind projected in the plan of the low-level stress.
+
+  ! ==== outputs ===
+
+  ! implicit arguments :   none
+  ! --------------------
+
+  ! method.
+  ! -------
+
+
+  ! externals.
+  ! ----------
+
+
+  ! reference.
+  ! ----------
+
+  ! see ecmwf research department documentation of the "i.f.s."
+
+  ! author.
+  ! -------
+
+  ! modifications.
+  ! --------------
+  ! f.lott  for the new-gwdrag scheme november 1993
+
+  ! -----------------------------------------------------------------------
+  USE dimphy
+  IMPLICIT NONE
+
+
+  include "YOMCST.h"
+  include "YOEGWD.h"
+
+  ! -----------------------------------------------------------------------
+
+  ! *       0.1   arguments
+  ! ---------
+
+  INTEGER nlon, nlev
+  INTEGER kkcrit(nlon), kkcrith(nlon), kcrit(nlon), ksect(nlon), &
+    kkhlim(nlon), ktest(nlon), kkenvh(nlon)
+
+
+  REAL paphm1(nlon, klev+1), papm1(nlon, klev), pum1(nlon, klev), &
+    pvm1(nlon, klev), ptm1(nlon, klev), pgeom1(nlon, klev), &
+    prho(nlon, klev+1), pri(nlon, klev+1), pstab(nlon, klev+1), &
+    ptau(nlon, klev+1), pvph(nlon, klev+1), ppsi(nlon, klev+1), &
+    pzdep(nlon, klev)
+  REAL pulow(nlon), pvlow(nlon), ptheta(nlon), pgam(nlon), pnu(nlon), &
+    pd1(nlon), pd2(nlon), pdmod(nlon)
+  REAL pstd(nlon), pmea(nlon), ppic(nlon), pval(nlon)
+
+  ! -----------------------------------------------------------------------
+
+  ! *       0.2   local arrays
+  ! ------------
+
+
+  INTEGER ilevh, jl, jk
+  REAL zcons1, zcons2, zhgeo, zu, zphi
+  REAL zvt1, zvt2, zdwind, zwind, zdelp
+  REAL zstabm, zstabp, zrhom, zrhop
+  LOGICAL lo
+  LOGICAL ll1(klon, klev+1)
+  INTEGER kknu(klon), kknu2(klon), kknub(klon), kknul(klon), kentp(klon), &
+    ncount(klon)
+
+  REAL zhcrit(klon, klev), zvpf(klon, klev), zdp(klon, klev)
+  REAL znorm(klon), zb(klon), zc(klon), zulow(klon), zvlow(klon), znup(klon), &
+    znum(klon)
+
+  ! ------------------------------------------------------------------
+
+  ! *         1.    initialization
+  ! --------------
+
+  ! PRINT *,' in orosetup'
+
+  ! ------------------------------------------------------------------
+
+  ! *         1.1   computational constants
+  ! -----------------------
+
+
+  ilevh = klev/3
+
+  zcons1 = 1./rd
+  zcons2 = rg**2/rcpd
+
+  ! ------------------------------------------------------------------
+
+  ! *         2.
+  ! --------------
+
+
+  ! ------------------------------------------------------------------
+
+  ! *         2.1     define low level wind, project winds in plane of
+  ! *                 low level wind, determine sector in which to take
+  ! *                 the variance and set indicator for critical levels.
+
+
+
+  DO jl = kidia, kfdia
+    kknu(jl) = klev
+    kknu2(jl) = klev
+    kknub(jl) = klev
+    kknul(jl) = klev
+    pgam(jl) = max(pgam(jl), gtsec)
+    ll1(jl, klev+1) = .FALSE.
+  END DO
+
+  ! Ajouter une initialisation (L. Li, le 23fev99):
+
+  DO jk = klev, ilevh, -1
+    DO jl = kidia, kfdia
+      ll1(jl, jk) = .FALSE.
+    END DO
+  END DO
+
+  ! *      define top of low level flow
+  ! ----------------------------
+  DO jk = klev, ilevh, -1
+    DO jl = kidia, kfdia
+      IF (ktest(jl)==1) THEN
+        lo = (paphm1(jl,jk)/paphm1(jl,klev+1)) >= gsigcr
+        IF (lo) THEN
+          kkcrit(jl) = jk
+        END IF
+        zhcrit(jl, jk) = ppic(jl) - pval(jl)
+        zhgeo = pgeom1(jl, jk)/rg
+        ll1(jl, jk) = (zhgeo>zhcrit(jl,jk))
+        IF (ll1(jl,jk) .NEQV. ll1(jl,jk+1)) THEN
+          kknu(jl) = jk
+        END IF
+        IF (.NOT. ll1(jl,ilevh)) kknu(jl) = ilevh
+      END IF
+    END DO
+  END DO
+  DO jk = klev, ilevh, -1
+    DO jl = kidia, kfdia
+      IF (ktest(jl)==1) THEN
+        zhcrit(jl, jk) = ppic(jl) - pmea(jl)
+        zhgeo = pgeom1(jl, jk)/rg
+        ll1(jl, jk) = (zhgeo>zhcrit(jl,jk))
+        IF (ll1(jl,jk) .NEQV. ll1(jl,jk+1)) THEN
+          kknu2(jl) = jk
+        END IF
+        IF (.NOT. ll1(jl,ilevh)) kknu2(jl) = ilevh
+      END IF
+    END DO
+  END DO
+  DO jk = klev, ilevh, -1
+    DO jl = kidia, kfdia
+      IF (ktest(jl)==1) THEN
+        zhcrit(jl, jk) = amin1(ppic(jl)-pmea(jl), pmea(jl)-pval(jl))
+        zhgeo = pgeom1(jl, jk)/rg
+        ll1(jl, jk) = (zhgeo>zhcrit(jl,jk))
+        IF (ll1(jl,jk) .NEQV. ll1(jl,jk+1)) THEN
+          kknub(jl) = jk
+        END IF
+        IF (.NOT. ll1(jl,ilevh)) kknub(jl) = ilevh
+      END IF
+    END DO
+  END DO
+
+  DO jl = kidia, kfdia
+    IF (ktest(jl)==1) THEN
+      kknu(jl) = min(kknu(jl), nktopg)
+      kknu2(jl) = min(kknu2(jl), nktopg)
+      kknub(jl) = min(kknub(jl), nktopg)
+      kknul(jl) = klev
+    END IF
+  END DO
+
+  ! c*     initialize various arrays
+
+  DO jl = kidia, kfdia
+    prho(jl, klev+1) = 0.0
+    ! ym correction en attendant mieux
+    prho(jl, 1) = 0.0
+    pstab(jl, klev+1) = 0.0
+    pstab(jl, 1) = 0.0
+    pri(jl, klev+1) = 9999.0
+    ppsi(jl, klev+1) = 0.0
+    pri(jl, 1) = 0.0
+    pvph(jl, 1) = 0.0
+    pvph(jl, klev+1) = 0.0
+    ! ym correction en attendant mieux
+    ! ym      pvph(jl,klev)    =0.0
+    pulow(jl) = 0.0
+    pvlow(jl) = 0.0
+    zulow(jl) = 0.0
+    zvlow(jl) = 0.0
+    kkcrith(jl) = klev
+    kkenvh(jl) = klev
+    kentp(jl) = klev
+    kcrit(jl) = 1
+    ncount(jl) = 0
+    ll1(jl, klev+1) = .FALSE.
+  END DO
+
+  ! *     define flow density and stratification (rho and N2)
+  ! at semi layers.
+  ! -------------------------------------------------------
+
+  DO jk = klev, 2, -1
+    DO jl = kidia, kfdia
+      IF (ktest(jl)==1) THEN
+        zdp(jl, jk) = papm1(jl, jk) - papm1(jl, jk-1)
+        prho(jl, jk) = 2.*paphm1(jl, jk)*zcons1/(ptm1(jl,jk)+ptm1(jl,jk-1))
+        pstab(jl, jk) = 2.*zcons2/(ptm1(jl,jk)+ptm1(jl,jk-1))* &
+          (1.-rcpd*prho(jl,jk)*(ptm1(jl,jk)-ptm1(jl,jk-1))/zdp(jl,jk))
+        pstab(jl, jk) = max(pstab(jl,jk), gssec)
+      END IF
+    END DO
+  END DO
+
+  ! ********************************************************************
+
+  ! *     define Low level flow (between ground and peacks-valleys)
+  ! ---------------------------------------------------------
+  DO jk = klev, ilevh, -1
+    DO jl = kidia, kfdia
+      IF (ktest(jl)==1) THEN
+        IF (jk>=kknu2(jl) .AND. jk<=kknul(jl)) THEN
+          pulow(jl) = pulow(jl) + pum1(jl, jk)*(paphm1(jl,jk+1)-paphm1(jl,jk) &
+            )
+          pvlow(jl) = pvlow(jl) + pvm1(jl, jk)*(paphm1(jl,jk+1)-paphm1(jl,jk) &
+            )
+          pstab(jl, klev+1) = pstab(jl, klev+1) + pstab(jl, jk)*(paphm1(jl,jk &
+            +1)-paphm1(jl,jk))
+          prho(jl, klev+1) = prho(jl, klev+1) + prho(jl, jk)*(paphm1(jl,jk+1) &
+            -paphm1(jl,jk))
+        END IF
+      END IF
+    END DO
+  END DO
+  DO jl = kidia, kfdia
+    IF (ktest(jl)==1) THEN
+      pulow(jl) = pulow(jl)/(paphm1(jl,kknul(jl)+1)-paphm1(jl,kknu2(jl)))
+      pvlow(jl) = pvlow(jl)/(paphm1(jl,kknul(jl)+1)-paphm1(jl,kknu2(jl)))
+      znorm(jl) = max(sqrt(pulow(jl)**2+pvlow(jl)**2), gvsec)
+      pvph(jl, klev+1) = znorm(jl)
+      pstab(jl, klev+1) = pstab(jl, klev+1)/(paphm1(jl,kknul(jl)+1)-paphm1(jl &
+        ,kknu2(jl)))
+      prho(jl, klev+1) = prho(jl, klev+1)/(paphm1(jl,kknul(jl)+1)-paphm1(jl, &
+        kknu2(jl)))
+    END IF
+  END DO
+
+
+  ! *******  setup orography orientation relative to the low level
+  ! wind and define parameters of the Anisotropic wave stress.
+
+  DO jl = kidia, kfdia
+    IF (ktest(jl)==1) THEN
+      lo = (pulow(jl)<gvsec) .AND. (pulow(jl)>=-gvsec)
+      IF (lo) THEN
+        zu = pulow(jl) + 2.*gvsec
+      ELSE
+        zu = pulow(jl)
+      END IF
+      zphi = atan(pvlow(jl)/zu)
+      ppsi(jl, klev+1) = ptheta(jl)*rpi/180. - zphi
+      zb(jl) = 1. - 0.18*pgam(jl) - 0.04*pgam(jl)**2
+      zc(jl) = 0.48*pgam(jl) + 0.3*pgam(jl)**2
+      pd1(jl) = zb(jl) - (zb(jl)-zc(jl))*(sin(ppsi(jl,klev+1))**2)
+      pd2(jl) = (zb(jl)-zc(jl))*sin(ppsi(jl,klev+1))*cos(ppsi(jl,klev+1))
+      pdmod(jl) = sqrt(pd1(jl)**2+pd2(jl)**2)
+    END IF
+  END DO
+
+  ! ************ projet flow in plane of lowlevel stress *************
+  ! ************ Find critical levels...                 *************
+
+  DO jk = 1, klev
+    DO jl = kidia, kfdia
+      IF (ktest(jl)==1) THEN
+        zvt1 = pulow(jl)*pum1(jl, jk) + pvlow(jl)*pvm1(jl, jk)
+        zvt2 = -pvlow(jl)*pum1(jl, jk) + pulow(jl)*pvm1(jl, jk)
+        zvpf(jl, jk) = (zvt1*pd1(jl)+zvt2*pd2(jl))/(znorm(jl)*pdmod(jl))
+      END IF
+      ptau(jl, jk) = 0.0
+      pzdep(jl, jk) = 0.0
+      ppsi(jl, jk) = 0.0
+      ll1(jl, jk) = .FALSE.
+    END DO
+  END DO
+  DO jk = 2, klev
+    DO jl = kidia, kfdia
+      IF (ktest(jl)==1) THEN
+        zdp(jl, jk) = papm1(jl, jk) - papm1(jl, jk-1)
+        pvph(jl, jk) = ((paphm1(jl,jk)-papm1(jl,jk-1))*zvpf(jl,jk)+(papm1(jl, &
+          jk)-paphm1(jl,jk))*zvpf(jl,jk-1))/zdp(jl, jk)
+        IF (pvph(jl,jk)<gvsec) THEN
+          pvph(jl, jk) = gvsec
+          kcrit(jl) = jk
+        END IF
+      END IF
+    END DO
+  END DO
+
+  ! *         2.3     mean flow richardson number.
+
+
+  DO jk = 2, klev
+    DO jl = kidia, kfdia
+      IF (ktest(jl)==1) THEN
+        zdwind = max(abs(zvpf(jl,jk)-zvpf(jl,jk-1)), gvsec)
+        pri(jl, jk) = pstab(jl, jk)*(zdp(jl,jk)/(rg*prho(jl,jk)*zdwind))**2
+        pri(jl, jk) = max(pri(jl,jk), grcrit)
+      END IF
+    END DO
+  END DO
+
+
+
+  ! *      define top of 'envelope' layer
+  ! ----------------------------
+
+  DO jl = kidia, kfdia
+    pnu(jl) = 0.0
+    znum(jl) = 0.0
+  END DO
+
+  DO jk = 2, klev - 1
+    DO jl = kidia, kfdia
+
+      IF (ktest(jl)==1) THEN
+
+        IF (jk>=kknu2(jl)) THEN
+
+          znum(jl) = pnu(jl)
+          zwind = (pulow(jl)*pum1(jl,jk)+pvlow(jl)*pvm1(jl,jk))/ &
+            max(sqrt(pulow(jl)**2+pvlow(jl)**2), gvsec)
+          zwind = max(sqrt(zwind**2), gvsec)
+          zdelp = paphm1(jl, jk+1) - paphm1(jl, jk)
+          zstabm = sqrt(max(pstab(jl,jk),gssec))
+          zstabp = sqrt(max(pstab(jl,jk+1),gssec))
+          zrhom = prho(jl, jk)
+          zrhop = prho(jl, jk+1)
+          pnu(jl) = pnu(jl) + (zdelp/rg)*((zstabp/zrhop+zstabm/zrhom)/2.)/ &
+            zwind
+          IF ((znum(jl)<=gfrcrit) .AND. (pnu(jl)>gfrcrit) .AND. (kkenvh( &
+            jl)==klev)) kkenvh(jl) = jk
+
+        END IF
+
+      END IF
+
+    END DO
+  END DO
+
+  ! calculation of a dynamical mixing height for when the waves
+  ! BREAK AT LOW LEVEL: The drag will be repartited over
+  ! a depths that depends on waves vertical wavelength,
+  ! not just between two adjacent model layers.
+  ! of gravity waves:
+
+  DO jl = kidia, kfdia
+    znup(jl) = 0.0
+    znum(jl) = 0.0
+  END DO
+
+  DO jk = klev - 1, 2, -1
+    DO jl = kidia, kfdia
+
+      IF (ktest(jl)==1) THEN
+
+        znum(jl) = znup(jl)
+        zwind = (pulow(jl)*pum1(jl,jk)+pvlow(jl)*pvm1(jl,jk))/ &
+          max(sqrt(pulow(jl)**2+pvlow(jl)**2), gvsec)
+        zwind = max(sqrt(zwind**2), gvsec)
+        zdelp = paphm1(jl, jk+1) - paphm1(jl, jk)
+        zstabm = sqrt(max(pstab(jl,jk),gssec))
+        zstabp = sqrt(max(pstab(jl,jk+1),gssec))
+        zrhom = prho(jl, jk)
+        zrhop = prho(jl, jk+1)
+        znup(jl) = znup(jl) + (zdelp/rg)*((zstabp/zrhop+zstabm/zrhom)/2.)/ &
+          zwind
+        IF ((znum(jl)<=rpi/4.) .AND. (znup(jl)>rpi/4.) .AND. (kkcrith( &
+          jl)==klev)) kkcrith(jl) = jk
+
+      END IF
+
+    END DO
+  END DO
+
+  DO jl = kidia, kfdia
+    IF (ktest(jl)==1) THEN
+      kkcrith(jl) = max0(kkcrith(jl), ilevh*2)
+      kkcrith(jl) = max0(kkcrith(jl), kknu(jl))
+      IF (kcrit(jl)>=kkcrith(jl)) kcrit(jl) = 1
+    END IF
+  END DO
+
+  ! directional info for flow blocking *************************
+
+  DO jk = 1, klev
+    DO jl = kidia, kfdia
+      IF (ktest(jl)==1) THEN
+        lo = (pum1(jl,jk)<gvsec) .AND. (pum1(jl,jk)>=-gvsec)
+        IF (lo) THEN
+          zu = pum1(jl, jk) + 2.*gvsec
+        ELSE
+          zu = pum1(jl, jk)
+        END IF
+        zphi = atan(pvm1(jl,jk)/zu)
+        ppsi(jl, jk) = ptheta(jl)*rpi/180. - zphi
+      END IF
+    END DO
+  END DO
+
+  ! forms the vertical 'leakiness' **************************
+
+  DO jk = ilevh, klev
+    DO jl = kidia, kfdia
+      IF (ktest(jl)==1) THEN
+        pzdep(jl, jk) = 0
+        IF (jk>=kkenvh(jl) .AND. kkenvh(jl)/=klev) THEN
+          pzdep(jl, jk) = (pgeom1(jl,kkenvh(jl))-pgeom1(jl,jk))/ &
+            (pgeom1(jl,kkenvh(jl))-pgeom1(jl,klev))
+        END IF
+      END IF
+    END DO
+  END DO
+
+  RETURN
+END SUBROUTINE orosetup_strato
+SUBROUTINE gwstress_strato(nlon, nlev, kkcrit, ksect, kkhlim, ktest, kkcrith, &
+    kcrit, kkenvh, kknu, prho, pstab, pvph, pstd, psig, pmea, ppic, pval, &
+    ptfr, ptau, pgeom1, pgamma, pd1, pd2, pdmod, pnu)
+
+  ! **** *gwstress*
+
+  ! purpose.
+  ! --------
+  ! Compute the surface stress due to Gravity Waves, according
+  ! to the Phillips (1979) theory of 3-D flow above
+  ! anisotropic elliptic ridges.
+
+  ! The stress is reduced two account for cut-off flow over
+  ! hill.  The flow only see that part of the ridge located
+  ! above the blocked layer (see zeff).
+
+  ! **   interface.
+  ! ----------
+  ! call *gwstress*  from *gwdrag*
+
+  ! explicit arguments :
+  ! --------------------
+  ! ==== inputs ===
+  ! ==== outputs ===
+
+  ! implicit arguments :   none
+  ! --------------------
+
+  ! method.
+  ! -------
+
+
+  ! externals.
+  ! ----------
+
+
+  ! reference.
+  ! ----------
+
+  ! LOTT and MILLER (1997)  &  LOTT (1999)
+
+  ! author.
+  ! -------
+
+  ! modifications.
+  ! --------------
+  ! f. lott put the new gwd on ifs      22/11/93
+
+  ! -----------------------------------------------------------------------
+  USE dimphy
+  IMPLICIT NONE
+
+  include "YOMCST.h"
+  include "YOEGWD.h"
+
+  ! -----------------------------------------------------------------------
+
+  ! *       0.1   arguments
+  ! ---------
+
+  INTEGER nlon, nlev
+  INTEGER kkcrit(nlon), kkcrith(nlon), kcrit(nlon), ksect(nlon), &
+    kkhlim(nlon), ktest(nlon), kkenvh(nlon), kknu(nlon)
+
+  REAL prho(nlon, nlev+1), pstab(nlon, nlev+1), ptau(nlon, nlev+1), &
+    pvph(nlon, nlev+1), ptfr(nlon), pgeom1(nlon, nlev), pstd(nlon)
+
+  REAL pd1(nlon), pd2(nlon), pnu(nlon), psig(nlon), pgamma(nlon)
+  REAL pmea(nlon), ppic(nlon), pval(nlon)
+  REAL pdmod(nlon)
+
+  ! -----------------------------------------------------------------------
+
+  ! *       0.2   local arrays
+  ! ------------
+  ! zeff--real: effective height seen by the flow when there is blocking
+
+  INTEGER jl
+  REAL zeff
+
+  ! -----------------------------------------------------------------------
+
+  ! *       0.3   functions
+  ! ---------
+  ! ------------------------------------------------------------------
+
+  ! *         1.    initialization
+  ! --------------
+
+  ! PRINT *,' in gwstress'
+
+  ! *         3.1     gravity wave stress.
+
+
+
+  DO jl = kidia, kfdia
+    IF (ktest(jl)==1) THEN
+
+      ! effective mountain height above the blocked flow
+
+      zeff = ppic(jl) - pval(jl)
+      IF (kkenvh(jl)<klev) THEN
+        zeff = amin1(gfrcrit*pvph(jl,klev+1)/sqrt(pstab(jl,klev+1)), zeff)
+      END IF
+
+
+      ptau(jl, klev+1) = gkdrag*prho(jl, klev+1)*psig(jl)*pdmod(jl)/4./ &
+        pstd(jl)*pvph(jl, klev+1)*sqrt(pstab(jl,klev+1))*zeff**2
+
+
+      ! too small value of stress or  low level flow include critical level
+      ! or low level flow:  gravity wave stress nul.
+
+      ! lo=(ptau(jl,klev+1).lt.gtsec).or.(kcrit(jl).ge.kknu(jl))
+      ! *      .or.(pvph(jl,klev+1).lt.gvcrit)
+      ! if(lo) ptau(jl,klev+1)=0.0
+
+      ! print *,jl,ptau(jl,klev+1)
+
+    ELSE
+
+      ptau(jl, klev+1) = 0.0
+
+    END IF
+
+  END DO
+
+  ! write(21)(ptau(jl,klev+1),jl=kidia,kfdia)
+
+  RETURN
+END SUBROUTINE gwstress_strato
+
+SUBROUTINE gwprofil_strato(nlon, nlev, kgwd, kdx, ktest, kkcrit, kkcrith, &
+    kcrit, kkenvh, kknu, kknu2, paphm1, prho, pstab, ptfr, pvph, pri, ptau, &
+    pdmod, pnu, psig, pgamma, pstd, ppic, pval)
+
+  ! **** *gwprofil*
+
+  ! purpose.
+  ! --------
+
+  ! **   interface.
+  ! ----------
+  ! from *gwdrag*
+
+  ! explicit arguments :
+  ! --------------------
+  ! ==== inputs ===
+
+  ! ==== outputs ===
+
+  ! implicit arguments :   none
+  ! --------------------
+
+  ! method:
+  ! -------
+  ! the stress profile for gravity waves is computed as follows:
+  ! it decreases linearly with heights from the ground
+  ! to the low-level indicated by kkcrith,
+  ! to simulates lee waves or
+  ! low-level gravity wave breaking.
+  ! above it is constant, except when the waves encounter a critical
+  ! level (kcrit) or when they break.
+  ! The stress is also uniformly distributed above the level
+  ! nstra.
+
+  USE dimphy
+  IMPLICIT NONE
+
+  include "YOMCST.h"
+  include "YOEGWD.h"
+
+  ! -----------------------------------------------------------------------
+
+  ! *       0.1   ARGUMENTS
+  ! ---------
+
+  INTEGER nlon, nlev, kgwd
+  INTEGER kkcrit(nlon), kkcrith(nlon), kcrit(nlon), kdx(nlon), ktest(nlon), &
+    kkenvh(nlon), kknu(nlon), kknu2(nlon)
+
+  REAL paphm1(nlon, nlev+1), pstab(nlon, nlev+1), prho(nlon, nlev+1), &
+    pvph(nlon, nlev+1), pri(nlon, nlev+1), ptfr(nlon), ptau(nlon, nlev+1)
+
+  REAL pdmod(nlon), pnu(nlon), psig(nlon), pgamma(nlon), pstd(nlon), &
+    ppic(nlon), pval(nlon)
+
+  ! -----------------------------------------------------------------------
+
+  ! *       0.2   local arrays
+  ! ------------
+
+  INTEGER jl, jk
+  REAL zsqr, zalfa, zriw, zdel, zb, zalpha, zdz2n, zdelp, zdelpt
+
+  REAL zdz2(klon, klev), znorm(klon), zoro(klon)
+  REAL ztau(klon, klev+1)
+
+  ! -----------------------------------------------------------------------
+
+  ! *         1.    INITIALIZATION
+  ! --------------
+
+  ! print *,' entree gwprofil'
+
+
+  ! *    COMPUTATIONAL CONSTANTS.
+  ! ------------- ----------
+
+  DO jl = kidia, kfdia
+    IF (ktest(jl)==1) THEN
+      zoro(jl) = psig(jl)*pdmod(jl)/4./pstd(jl)
+      ztau(jl, klev+1) = ptau(jl, klev+1)
+      ! print *,jl,ptau(jl,klev+1)
+      ztau(jl, kkcrith(jl)) = grahilo*ptau(jl, klev+1)
+    END IF
+  END DO
+
+
+  DO jk = klev + 1, 1, -1
+    ! *         4.1    constant shear stress until top of the
+    ! low-level breaking/trapped layer
+
+    DO jl = kidia, kfdia
+      IF (ktest(jl)==1) THEN
+        IF (jk>kkcrith(jl)) THEN
+          zdelp = paphm1(jl, jk) - paphm1(jl, klev+1)
+          zdelpt = paphm1(jl, kkcrith(jl)) - paphm1(jl, klev+1)
+          ptau(jl, jk) = ztau(jl, klev+1) + zdelp/zdelpt*(ztau(jl,kkcrith(jl) &
+            )-ztau(jl,klev+1))
+        ELSE
+          ptau(jl, jk) = ztau(jl, kkcrith(jl))
+        END IF
+      END IF
+    END DO
+
+    ! *         4.15   constant shear stress until the top of the
+    ! low level flow layer.
+
+
+    ! *         4.2    wave displacement at next level.
+
+
+  END DO
+
+
+  ! *         4.4    wave richardson number, new wave displacement
+  ! *                and stress:  breaking evaluation and critical
+  ! level
+
+
+  DO jk = klev, 1, -1
+
+    DO jl = kidia, kfdia
+      IF (ktest(jl)==1) THEN
+        znorm(jl) = prho(jl, jk)*sqrt(pstab(jl,jk))*pvph(jl, jk)
+        zdz2(jl, jk) = ptau(jl, jk)/amax1(znorm(jl), gssec)/zoro(jl)
+      END IF
+    END DO
+
+    DO jl = kidia, kfdia
+      IF (ktest(jl)==1) THEN
+        IF (jk<kkcrith(jl)) THEN
+          IF ((ptau(jl,jk+1)<gtsec) .OR. (jk<=kcrit(jl))) THEN
+            ptau(jl, jk) = 0.0
+          ELSE
+            zsqr = sqrt(pri(jl,jk))
+            zalfa = sqrt(pstab(jl,jk)*zdz2(jl,jk))/pvph(jl, jk)
+            zriw = pri(jl, jk)*(1.-zalfa)/(1+zalfa*zsqr)**2
+            IF (zriw<grcrit) THEN
+              ! print *,' breaking!!!',ptau(jl,jk)
+              zdel = 4./zsqr/grcrit + 1./grcrit**2 + 4./grcrit
+              zb = 1./grcrit + 2./zsqr
+              zalpha = 0.5*(-zb+sqrt(zdel))
+              zdz2n = (pvph(jl,jk)*zalpha)**2/pstab(jl, jk)
+              ptau(jl, jk) = znorm(jl)*zdz2n*zoro(jl)
+            END IF
+
+            ptau(jl, jk) = amin1(ptau(jl,jk), ptau(jl,jk+1))
+
+          END IF
+        END IF
+      END IF
+    END DO
+  END DO
+
+  ! REORGANISATION OF THE STRESS PROFILE AT LOW LEVEL
+
+  DO jl = kidia, kfdia
+    IF (ktest(jl)==1) THEN
+      ztau(jl, kkcrith(jl)-1) = ptau(jl, kkcrith(jl)-1)
+      ztau(jl, nstra) = ptau(jl, nstra)
+    END IF
+  END DO
+
+  DO jk = 1, klev
+
+    DO jl = kidia, kfdia
+      IF (ktest(jl)==1) THEN
+
+        IF (jk>kkcrith(jl)-1) THEN
+
+          zdelp = paphm1(jl, jk) - paphm1(jl, klev+1)
+          zdelpt = paphm1(jl, kkcrith(jl)-1) - paphm1(jl, klev+1)
+          ptau(jl, jk) = ztau(jl, klev+1) + (ztau(jl,kkcrith(jl)-1)-ztau(jl, &
+            klev+1))*zdelp/zdelpt
+
+        END IF
+      END IF
+
+    END DO
+
+    ! REORGANISATION AT THE MODEL TOP....
+
+    DO jl = kidia, kfdia
+      IF (ktest(jl)==1) THEN
+
+        IF (jk<nstra) THEN
+
+          zdelp = paphm1(jl, nstra)
+          zdelpt = paphm1(jl, jk)
+          ptau(jl, jk) = ztau(jl, nstra)*zdelpt/zdelp
+          ! ptau(jl,jk)=ztau(jl,nstra)
+
+        END IF
+
+      END IF
+
+    END DO
+
+
+  END DO
+
+
+123 FORMAT (I4, 1X, 20(F6.3,1X))
+
+
+  RETURN
+END SUBROUTINE gwprofil_strato
+SUBROUTINE lift_noro_strato(nlon, nlev, dtime, paprs, pplay, plat, pmea, &
+    pstd, psig, pgam, pthe, ppic, pval, kgwd, kdx, ktest, t, u, v, pulow, &
+    pvlow, pustr, pvstr, d_t, d_u, d_v)
+
+  USE dimphy
+  IMPLICIT NONE
+  ! ======================================================================
+  ! Auteur(s): F.Lott (LMD/CNRS) date: 19950201
+  ! Object: Mountain lift interface (enhanced vortex stretching).
+  ! Made necessary because:
+  ! 1. in the LMD-GCM Layers are from bottom to top,
+  ! contrary to most European GCM.
+  ! 2. the altitude above ground of each model layers
+  ! needs to be known (variable zgeom)
+  ! ======================================================================
+  ! Explicit Arguments:
+  ! ==================
+  ! nlon----input-I-Total number of horizontal points that get into physics
+  ! nlev----input-I-Number of vertical levels
+  ! dtime---input-R-Time-step (s)
+  ! paprs---input-R-Pressure in semi layers    (Pa)
+  ! pplay---input-R-Pressure model-layers      (Pa)
+  ! t-------input-R-temperature (K)
+  ! u-------input-R-Horizontal wind (m/s)
+  ! v-------input-R-Meridional wind (m/s)
+  ! pmea----input-R-Mean Orography (m)
+  ! pstd----input-R-SSO standard deviation (m)
+  ! psig----input-R-SSO slope
+  ! pgam----input-R-SSO Anisotropy
+  ! pthe----input-R-SSO Angle
+  ! ppic----input-R-SSO Peacks elevation (m)
+  ! pval----input-R-SSO Valleys elevation (m)
+
+  ! kgwd- -input-I: Total nb of points where the orography schemes are active
+  ! ktest--input-I: Flags to indicate active points
+  ! kdx----input-I: Locate the physical location of an active point.
+
+  ! pulow, pvlow -output-R: Low-level wind
+  ! pustr, pvstr -output-R: Surface stress due to SSO drag      (Pa)
+
+  ! d_t-----output-R: T increment
+  ! d_u-----output-R: U increment
+  ! d_v-----output-R: V increment
+
+  ! Implicit Arguments:
+  ! ===================
+
+  ! iim--common-I: Number of longitude intervals
+  ! jjm--common-I: Number of latitude intervals
+  ! klon-common-I: Number of points seen by the physics
+  ! (iim+1)*(jjm+1) for instance
+  ! klev-common-I: Number of vertical layers
+  ! ======================================================================
+  ! Local Variables:
+  ! ================
+
+  ! zgeom-----R: Altitude of layer above ground
+  ! pt, pu, pv --R: t u v from top to bottom
+  ! pdtdt, pdudt, pdvdt --R: t u v tendencies (from top to bottom)
+  ! papmf: pressure at model layer (from top to bottom)
+  ! papmh: pressure at model 1/2 layer (from top to bottom)
+
+  ! ======================================================================
+
+  include "YOMCST.h"
+  include "YOEGWD.h"
+
+  ! ARGUMENTS
+
+  INTEGER nlon, nlev
+  REAL dtime
+  REAL paprs(klon, klev+1)
+  REAL pplay(klon, klev)
+  REAL plat(nlon), pmea(nlon)
+  REAL pstd(nlon), psig(nlon), pgam(nlon), pthe(nlon)
+  REAL ppic(nlon), pval(nlon)
+  REAL pulow(nlon), pvlow(nlon), pustr(nlon), pvstr(nlon)
+  REAL t(nlon, nlev), u(nlon, nlev), v(nlon, nlev)
+  REAL d_t(nlon, nlev), d_u(nlon, nlev), d_v(nlon, nlev)
+
+  INTEGER i, k, kgwd, kdx(nlon), ktest(nlon)
+
+  ! Variables locales:
+
+  REAL zgeom(klon, klev)
+  REAL pdtdt(klon, klev), pdudt(klon, klev), pdvdt(klon, klev)
+  REAL pt(klon, klev), pu(klon, klev), pv(klon, klev)
+  REAL papmf(klon, klev), papmh(klon, klev+1)
+
+  ! initialiser les variables de sortie (pour securite)
+
+
+  ! print *,'in lift_noro'
+  DO i = 1, klon
+    pulow(i) = 0.0
+    pvlow(i) = 0.0
+    pustr(i) = 0.0
+    pvstr(i) = 0.0
+  END DO
+  DO k = 1, klev
+    DO i = 1, klon
+      d_t(i, k) = 0.0
+      d_u(i, k) = 0.0
+      d_v(i, k) = 0.0
+      pdudt(i, k) = 0.0
+      pdvdt(i, k) = 0.0
+      pdtdt(i, k) = 0.0
+    END DO
+  END DO
+
+  ! preparer les variables d'entree (attention: l'ordre des niveaux
+  ! verticaux augmente du haut vers le bas)
+
+  DO k = 1, klev
+    DO i = 1, klon
+      pt(i, k) = t(i, klev-k+1)
+      pu(i, k) = u(i, klev-k+1)
+      pv(i, k) = v(i, klev-k+1)
+      papmf(i, k) = pplay(i, klev-k+1)
+    END DO
+  END DO
+  DO k = 1, klev + 1
+    DO i = 1, klon
+      papmh(i, k) = paprs(i, klev-k+2)
+    END DO
+  END DO
+  DO i = 1, klon
+    zgeom(i, klev) = rd*pt(i, klev)*log(papmh(i,klev+1)/papmf(i,klev))
+  END DO
+  DO k = klev - 1, 1, -1
+    DO i = 1, klon
+      zgeom(i, k) = zgeom(i, k+1) + rd*(pt(i,k)+pt(i,k+1))/2.0*log(papmf(i,k+ &
+        1)/papmf(i,k))
+    END DO
+  END DO
+
+  ! appeler la routine principale
+
+
+  CALL orolift_strato(klon, klev, kgwd, kdx, ktest, dtime, papmh, papmf, &
+    zgeom, pt, pu, pv, plat, pmea, pstd, psig, pgam, pthe, ppic, pval, pulow, &
+    pvlow, pdudt, pdvdt, pdtdt)
+
+  DO k = 1, klev
+    DO i = 1, klon
+      d_u(i, klev+1-k) = dtime*pdudt(i, k)
+      d_v(i, klev+1-k) = dtime*pdvdt(i, k)
+      d_t(i, klev+1-k) = dtime*pdtdt(i, k)
+      pustr(i) = pustr(i) + pdudt(i, k)*(papmh(i,k+1)-papmh(i,k))/rg
+      pvstr(i) = pvstr(i) + pdvdt(i, k)*(papmh(i,k+1)-papmh(i,k))/rg
+    END DO
+  END DO
+
+  ! print *,' out lift_noro'
+
+  RETURN
+END SUBROUTINE lift_noro_strato
+SUBROUTINE orolift_strato(nlon, nlev, kgwd, kdx, ktest, ptsphy, paphm1, &
+    papm1, pgeom1, ptm1, pum1, pvm1, plat, pmea, pstd, psig, pgam, pthe, &
+    ppic, pval &                   ! OUTPUTS
+    , pulow, pvlow, pvom, pvol, pte)
+
+
+  ! **** *OROLIFT: SIMULATE THE GEOSTROPHIC LIFT.
+
+  ! PURPOSE.
+  ! --------
+  ! this routine computes the physical tendencies of the
+  ! prognostic variables u,v  when enhanced vortex stretching
+  ! is needed.
+
+  ! **   INTERFACE.
+  ! ----------
+  ! CALLED FROM *lift_noro
+  ! explicit arguments :
+  ! --------------------
+  ! ==== inputs ===
+  ! nlon----input-I-Total number of horizontal points that get into physics
+  ! nlev----input-I-Number of vertical levels
+
+  ! kgwd- -input-I: Total nb of points where the orography schemes are active
+  ! ktest--input-I: Flags to indicate active points
+  ! kdx----input-I: Locate the physical location of an active point.
+  ! ptsphy--input-R-Time-step (s)
+  ! paphm1--input-R: pressure at model 1/2 layer
+  ! papm1---input-R: pressure at model layer
+  ! pgeom1--input-R: Altitude of layer above ground
+  ! ptm1, pum1, pvm1--R-: t, u and v
+  ! pmea----input-R-Mean Orography (m)
+  ! pstd----input-R-SSO standard deviation (m)
+  ! psig----input-R-SSO slope
+  ! pgam----input-R-SSO Anisotropy
+  ! pthe----input-R-SSO Angle
+  ! ppic----input-R-SSO Peacks elevation (m)
+  ! pval----input-R-SSO Valleys elevation (m)
+  ! plat----input-R-Latitude (degree)
+
+  ! ==== outputs ===
+  ! pulow, pvlow -output-R: Low-level wind
+
+  ! pte -----output-R: T tendency
+  ! pvom-----output-R: U tendency
+  ! pvol-----output-R: V tendency
+
+
+  ! Implicit Arguments:
+  ! ===================
+
+  ! klon-common-I: Number of points seen by the physics
+  ! klev-common-I: Number of vertical layers
+
+
+  ! ----------
+
+  ! AUTHOR.
+  ! -------
+  ! F.LOTT  LMD 22/11/95
+
+  USE dimphy
+  IMPLICIT NONE
+
+
+  include "YOMCST.h"
+  include "YOEGWD.h"
+  ! -----------------------------------------------------------------------
+
+  ! *       0.1   ARGUMENTS
+  ! ---------
+
+
+  INTEGER nlon, nlev, kgwd
+  REAL ptsphy
+  REAL pte(nlon, nlev), pvol(nlon, nlev), pvom(nlon, nlev), pulow(nlon), &
+    pvlow(nlon)
+  REAL pum1(nlon, nlev), pvm1(nlon, nlev), ptm1(nlon, nlev), plat(nlon), &
+    pmea(nlon), pstd(nlon), psig(nlon), pgam(nlon), pthe(nlon), ppic(nlon), &
+    pval(nlon), pgeom1(nlon, nlev), papm1(nlon, nlev), paphm1(nlon, nlev+1)
+
+  INTEGER kdx(nlon), ktest(nlon)
+  ! -----------------------------------------------------------------------
+
+  ! *       0.2   local arrays
+
+  INTEGER jl, ilevh, jk
+  REAL zhgeo, zdelp, zslow, zsqua, zscav, zbet
+  ! ------------
+  INTEGER iknub(klon), iknul(klon)
+  LOGICAL ll1(klon, klev+1)
+
+  REAL ztau(klon, klev+1), ztav(klon, klev+1), zrho(klon, klev+1)
+  REAL zdudt(klon), zdvdt(klon)
+  REAL zhcrit(klon, klev)
+
+  LOGICAL lifthigh
+  REAL zcons1, ztmst
+  CHARACTER (LEN=20) :: modname = 'orolift_strato'
+  CHARACTER (LEN=80) :: abort_message
+
+
+  ! -----------------------------------------------------------------------
+
+  ! *         1.1  initialisations
+  ! ---------------
+
+  lifthigh = .FALSE.
+
+  IF (nlon/=klon .OR. nlev/=klev) THEN
+    abort_message = 'pb dimension'
+    CALL abort_physic(modname, abort_message, 1)
+  END IF
+  zcons1 = 1./rd
+  ztmst = ptsphy
+
+  DO jl = kidia, kfdia
+    zrho(jl, klev+1) = 0.0
+    pulow(jl) = 0.0
+    pvlow(jl) = 0.0
+    iknub(jl) = klev
+    iknul(jl) = klev
+    ilevh = klev/3
+    ll1(jl, klev+1) = .FALSE.
+    DO jk = 1, klev
+      pvom(jl, jk) = 0.0
+      pvol(jl, jk) = 0.0
+      pte(jl, jk) = 0.0
+    END DO
+  END DO
+
+
+  ! *         2.1     DEFINE LOW LEVEL WIND, PROJECT WINDS IN PLANE OF
+  ! *                 LOW LEVEL WIND, DETERMINE SECTOR IN WHICH TO TAKE
+  ! *                 THE VARIANCE AND SET INDICATOR FOR CRITICAL LEVELS.
+
+
+
+  DO jk = klev, 1, -1
+    DO jl = kidia, kfdia
+      IF (ktest(jl)==1) THEN
+        zhcrit(jl, jk) = amax1(ppic(jl)-pval(jl), 100.)
+        zhgeo = pgeom1(jl, jk)/rg
+        ll1(jl, jk) = (zhgeo>zhcrit(jl,jk))
+        IF (ll1(jl,jk) .NEQV. ll1(jl,jk+1)) THEN
+          iknub(jl) = jk
+        END IF
+      END IF
+    END DO
+  END DO
+
+
+  DO jl = kidia, kfdia
+    IF (ktest(jl)==1) THEN
+      iknub(jl) = max(iknub(jl), klev/2)
+      iknul(jl) = max(iknul(jl), 2*klev/3)
+      IF (iknub(jl)>nktopg) iknub(jl) = nktopg
+      IF (iknub(jl)==nktopg) iknul(jl) = klev
+      IF (iknub(jl)==iknul(jl)) iknub(jl) = iknul(jl) - 1
+    END IF
+  END DO
+
+  DO jk = klev, 2, -1
+    DO jl = kidia, kfdia
+      zrho(jl, jk) = 2.*paphm1(jl, jk)*zcons1/(ptm1(jl,jk)+ptm1(jl,jk-1))
+    END DO
+  END DO
+  ! print *,'  dans orolift: 223'
+
+  ! ********************************************************************
+
+  ! *     define low level flow
+  ! -------------------
+  DO jk = klev, 1, -1
+    DO jl = kidia, kfdia
+      IF (ktest(jl)==1) THEN
+        IF (jk>=iknub(jl) .AND. jk<=iknul(jl)) THEN
+          pulow(jl) = pulow(jl) + pum1(jl, jk)*(paphm1(jl,jk+1)-paphm1(jl,jk) &
+            )
+          pvlow(jl) = pvlow(jl) + pvm1(jl, jk)*(paphm1(jl,jk+1)-paphm1(jl,jk) &
+            )
+          zrho(jl, klev+1) = zrho(jl, klev+1) + zrho(jl, jk)*(paphm1(jl,jk+1) &
+            -paphm1(jl,jk))
+        END IF
+      END IF
+    END DO
+  END DO
+  DO jl = kidia, kfdia
+    IF (ktest(jl)==1) THEN
+      pulow(jl) = pulow(jl)/(paphm1(jl,iknul(jl)+1)-paphm1(jl,iknub(jl)))
+      pvlow(jl) = pvlow(jl)/(paphm1(jl,iknul(jl)+1)-paphm1(jl,iknub(jl)))
+      zrho(jl, klev+1) = zrho(jl, klev+1)/(paphm1(jl,iknul(jl)+1)-paphm1(jl, &
+        iknub(jl)))
+    END IF
+  END DO
+
+  ! ***********************************************************
+
+  ! *         3.      COMPUTE MOUNTAIN LIFT
+
+
+  DO jl = kidia, kfdia
+    IF (ktest(jl)==1) THEN
+      ztau(jl, klev+1) = -gklift*zrho(jl, klev+1)*2.*romega* & ! *
+                                                               ! (2*pstd(jl)+pmea(jl))*
+        2*pstd(jl)*sin(rpi/180.*plat(jl))*pvlow(jl)
+      ztav(jl, klev+1) = gklift*zrho(jl, klev+1)*2.*romega* & ! *
+                                                              ! (2*pstd(jl)+pmea(jl))*
+        2*pstd(jl)*sin(rpi/180.*plat(jl))*pulow(jl)
+    ELSE
+      ztau(jl, klev+1) = 0.0
+      ztav(jl, klev+1) = 0.0
+    END IF
+  END DO
+
+  ! *         4.      COMPUTE LIFT PROFILE
+  ! *                 --------------------
+
+
+
+  DO jk = 1, klev
+    DO jl = kidia, kfdia
+      IF (ktest(jl)==1) THEN
+        ztau(jl, jk) = ztau(jl, klev+1)*paphm1(jl, jk)/paphm1(jl, klev+1)
+        ztav(jl, jk) = ztav(jl, klev+1)*paphm1(jl, jk)/paphm1(jl, klev+1)
+      ELSE
+        ztau(jl, jk) = 0.0
+        ztav(jl, jk) = 0.0
+      END IF
+    END DO
+  END DO
+
+
+  ! *         5.      COMPUTE TENDENCIES.
+  ! *                 -------------------
+  IF (lifthigh) THEN
+    ! EXPLICIT SOLUTION AT ALL LEVELS
+
+    DO jk = 1, klev
+      DO jl = kidia, kfdia
+        IF (ktest(jl)==1) THEN
+          zdelp = paphm1(jl, jk+1) - paphm1(jl, jk)
+          zdudt(jl) = -rg*(ztau(jl,jk+1)-ztau(jl,jk))/zdelp
+          zdvdt(jl) = -rg*(ztav(jl,jk+1)-ztav(jl,jk))/zdelp
+        END IF
+      END DO
+    END DO
+
+    ! PROJECT PERPENDICULARLY TO U NOT TO DESTROY ENERGY
+
+    DO jk = 1, klev
+      DO jl = kidia, kfdia
+        IF (ktest(jl)==1) THEN
+
+          zslow = sqrt(pulow(jl)**2+pvlow(jl)**2)
+          zsqua = amax1(sqrt(pum1(jl,jk)**2+pvm1(jl,jk)**2), gvsec)
+          zscav = -zdudt(jl)*pvm1(jl, jk) + zdvdt(jl)*pum1(jl, jk)
+          IF (zsqua>gvsec) THEN
+            pvom(jl, jk) = -zscav*pvm1(jl, jk)/zsqua**2
+            pvol(jl, jk) = zscav*pum1(jl, jk)/zsqua**2
+          ELSE
+            pvom(jl, jk) = 0.0
+            pvol(jl, jk) = 0.0
+          END IF
+          zsqua = sqrt(pum1(jl,jk)**2+pum1(jl,jk)**2)
+          IF (zsqua<zslow) THEN
+            pvom(jl, jk) = zsqua/zslow*pvom(jl, jk)
+            pvol(jl, jk) = zsqua/zslow*pvol(jl, jk)
+          END IF
+
+        END IF
+      END DO
+    END DO
+
+    ! 6.  LOW LEVEL LIFT, SEMI IMPLICIT:
+    ! ----------------------------------
+
+  ELSE
+
+    DO jl = kidia, kfdia
+      IF (ktest(jl)==1) THEN
+        DO jk = klev, iknub(jl), -1
+          zbet = gklift*2.*romega*sin(rpi/180.*plat(jl))*ztmst* &
+            (pgeom1(jl,iknub(jl)-1)-pgeom1(jl,jk))/ &
+            (pgeom1(jl,iknub(jl)-1)-pgeom1(jl,klev))
+          zdudt(jl) = -pum1(jl, jk)/ztmst/(1+zbet**2)
+          zdvdt(jl) = -pvm1(jl, jk)/ztmst/(1+zbet**2)
+          pvom(jl, jk) = zbet**2*zdudt(jl) - zbet*zdvdt(jl)
+          pvol(jl, jk) = zbet*zdudt(jl) + zbet**2*zdvdt(jl)
+        END DO
+      END IF
+    END DO
+
+  END IF
+
+  ! print *,' out orolift'
+
+  RETURN
+END SUBROUTINE orolift_strato
+SUBROUTINE sugwd_strato(nlon, nlev, paprs, pplay)
+
+
+  ! **** *SUGWD* INITIALIZE COMMON YOEGWD CONTROLLING GRAVITY WAVE DRAG
+
+  ! PURPOSE.
+  ! --------
+  ! INITIALIZE YOEGWD, THE COMMON THAT CONTROLS THE
+  ! GRAVITY WAVE DRAG PARAMETRIZATION.
+  ! VERY IMPORTANT:
+  ! ______________
+  ! THIS ROUTINE SET_UP THE "TUNABLE PARAMETERS" OF THE
+  ! VARIOUS SSO SCHEMES
+
+  ! **   INTERFACE.
+  ! ----------
+  ! CALL *SUGWD* FROM *SUPHEC*
+  ! -----        ------
+
+  ! EXPLICIT ARGUMENTS :
+  ! --------------------
+  ! PAPRS,PPLAY : Pressure at semi and full model levels
+  ! NLEV        : number of model levels
+  ! NLON        : number of points treated in the physics
+
+  ! IMPLICIT ARGUMENTS :
+  ! --------------------
+  ! COMMON YOEGWD
+  ! -GFRCRIT-R:  Critical Non-dimensional mountain Height
+  ! (HNC in (1),    LOTT 1999)
+  ! -GKWAKE--R:  Bluff-body drag coefficient for low level wake
+  ! (Cd in (2),     LOTT 1999)
+  ! -GRCRIT--R:  Critical Richardson Number
+  ! (Ric, End of first column p791 of LOTT 1999)
+  ! -GKDRAG--R:  Gravity wave drag coefficient
+  ! (G in (3),      LOTT 1999)
+  ! -GKLIFT--R:  Mountain Lift coefficient
+  ! (Cl in (4),     LOTT 1999)
+  ! -GHMAX---R:  Not used
+  ! -GRAHILO-R:  Set-up the trapped waves fraction
+  ! (Beta , End of first column,  LOTT 1999)
+
+  ! -GSIGCR--R:  Security value for blocked flow depth
+  ! -NKTOPG--I:  Security value for blocked flow level
+  ! -nstra----I:  An estimate to qualify the upper levels of
+  ! the model where one wants to impose strees
+  ! profiles
+  ! -GSSECC--R:  Security min value for low-level B-V frequency
+  ! -GTSEC---R:  Security min value for anisotropy and GW stress.
+  ! -GVSEC---R:  Security min value for ulow
+
+
+  ! METHOD.
+  ! -------
+  ! SEE DOCUMENTATION
+
+  ! EXTERNALS.
+  ! ----------
+  ! NONE
+
+  ! REFERENCE.
+  ! ----------
+  ! Lott, 1999: Alleviation of stationary biases in a GCM through...
+  ! Monthly Weather Review, 127, pp 788-801.
+
+  ! AUTHOR.
+  ! -------
+  ! FRANCOIS LOTT        *LMD*
+
+  ! MODIFICATIONS.
+  ! --------------
+  ! ORIGINAL : 90-01-01 (MARTIN MILLER, ECMWF)
+  ! LAST:  99-07-09     (FRANCOIS LOTT,LMD)
+  ! ------------------------------------------------------------------
+  USE dimphy
+  USE mod_phys_lmdz_para
+  USE mod_grid_phy_lmdz
+  USE geometry_mod
+  IMPLICIT NONE
+
+  ! -----------------------------------------------------------------
+  include "YOEGWD.h"
+  ! ----------------------------------------------------------------
+
+  ! ARGUMENTS
+  INTEGER nlon, nlev
+  REAL paprs(nlon, nlev+1)
+  REAL pplay(nlon, nlev)
+
+  INTEGER jk
+  REAL zpr, ztop, zsigt, zpm1r
+  INTEGER :: cell,ij,nstra_tmp,nktopg_tmp
+  REAL :: current_dist, dist_min,dist_min_glo
+
+  ! *       1.    SET THE VALUES OF THE PARAMETERS
+  ! --------------------------------
+
+
+  PRINT *, ' DANS SUGWD NLEV=', nlev
+  ghmax = 10000.
+
+  zpr = 100000.
+  ZTOP=0.00005
+  zsigt = 0.94
+  ! old  ZPR=80000.
+  ! old  ZSIGT=0.85
+
+
+!ym Take the point at equator close to (0,0) coordinates.
+  dist_min=360
+  dist_min_glo=360.
+  cell=-1
+  DO ij=1,klon
+    current_dist=sqrt(longitude_deg(ij)**2+latitude_deg(ij)**2)
+    current_dist=current_dist*(1+(1e-10*ind_cell_glo(ij))/klon_glo) ! For point unicity
+    IF (dist_min>current_dist) THEN
+      dist_min=current_dist
+      cell=ij    
+    ENDIF  
+  ENDDO
+  
+  !PRINT *, 'SUGWD distmin cell=', dist_min,cell
+  CALL reduce_min(dist_min,dist_min_glo)
+  CALL bcast(dist_min_glo)
+  IF (dist_min/=dist_min_glo) cell=-1
+!ym in future find the point at equator close to (0,0) coordinates.
+  PRINT *, 'SUGWD distmin dist_min_glo cell=', dist_min,dist_min_glo,cell
+
+  nktopg_tmp=nktopg
+  nstra_tmp=nstra
+  
+  IF (cell/=-1) THEN
+
+    !print*,'SUGWD shape ',shape(pplay),cell+1
+
+    DO jk = 1, nlev
+      !zpm1r = pplay(cell+1, jk)/paprs(cell+1, 1)
+      zpm1r = pplay(cell, jk)/paprs(cell, 1)
+      IF (zpm1r>=zsigt) THEN
+        nktopg_tmp = jk
+      END IF
+      IF (zpm1r>=ztop) THEN
+        nstra_tmp = jk
+      END IF
+    END DO
+  ELSE
+    nktopg_tmp=0
+    nstra_tmp=0
+  ENDIF
+  
+  CALL reduce_sum(nktopg_tmp,nktopg)
+  CALL bcast(nktopg)
+  CALL reduce_sum(nstra_tmp,nstra)
+  CALL bcast(nstra)
+  
+  ! inversion car dans orodrag on compte les niveaux a l'envers
+  nktopg = nlev - nktopg + 1
+  nstra = nlev - nstra
+  PRINT *, ' DANS SUGWD nktopg=', nktopg
+  PRINT *, ' DANS SUGWD nstra=', nstra
+  if (nstra == 0) call abort_physic("sugwd_strato", "no level in stratosphere", 1)
+
+!  Valeurs lues dans les .def, ou attribues dans conf_phys
+  !gkdrag = 0.2   
+  !grahilo = 0.1
+  !grcrit = 1.00
+  !gfrcrit = 0.70
+  !gkwake = 0.40
+  !gklift = 0.25
+
+  gsigcr = 0.80 ! Top of low level flow
+  gvcrit = 0.1
+
+  WRITE (UNIT=6, FMT='('' *** SSO essential constants ***'')')
+  WRITE (UNIT=6, FMT='('' *** SPECIFIED IN SUGWD ***'')')
+  WRITE (UNIT=6, FMT='('' Gravity wave ct '',E13.7,'' '')') gkdrag
+  WRITE (UNIT=6, FMT='('' Trapped/total wave dag '',E13.7,'' '')') grahilo
+  WRITE (UNIT=6, FMT='('' Critical Richardson   = '',E13.7,'' '')') grcrit
+  WRITE (UNIT=6, FMT='('' Critical Froude'',e13.7)') gfrcrit
+  WRITE (UNIT=6, FMT='('' Low level Wake bluff cte'',e13.7)') gkwake
+  WRITE (UNIT=6, FMT='('' Low level lift  cte'',e13.7)') gklift
+
+  ! ----------------------------------------------------------------
+
+  ! *       2.    SET VALUES OF SECURITY PARAMETERS
+  ! ---------------------------------
+
+
+  gvsec = 0.10
+  gssec = 0.0001
+
+  gtsec = 0.00001
+
+  RETURN
+END SUBROUTINE sugwd_strato
Index: DZ6/trunk/libf/phylmd/output_physiqex_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/output_physiqex_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,87 +1,0 @@
-MODULE output_physiqex_mod
-
-
-
-CONTAINS 
-
-SUBROUTINE output_physiqex(debut,zjulian,pdtphys,presnivs,paprs,u,v,t,qx,cf,zqr,zqs,zqg,ptke,theta)
-
-      USE dimphy, only : klon,klev
-      USE iophy, only : histbeg_phy,histwrite_phy
-      USE ioipsl, only : histvert,histdef,histend,histsync
-      USE mod_phys_lmdz_para, only : jj_nb
-      USE ioipsl_getin_p_mod, ONLY : getin_p
-      USE mod_grid_phy_lmdz, ONLY: nbp_lon,nbp_lat
-      USE iophy, ONLY : init_iophy_new
-      USE geometry_mod, ONLY: latitude_deg, longitude_deg
-      USE infotrac_phy, only : nqtot
-
-
-
-implicit none
-logical, intent(in) :: debut
-real, intent(in) :: pdtphys,zjulian
-real,intent(in) :: presnivs(klev) ! pseudo-pressure (Pa) of mid-layers
-real,intent(in) :: u(klon,klev) ! eastward zonal wind (m/s)
-real,intent(in) :: v(klon,klev) ! northward meridional wind (m/s)
-real,intent(in) :: t(klon,klev) ! temperature (K)
-real,intent(in) :: theta(klon,klev) ! temperature (K)
-real,intent(in) :: paprs(klon,klev+1) ! interlayer pressure (Pa)
-real,intent(in) :: qx(klon,klev,nqtot) !tracers
-real,intent(in) :: cf(klon,klev) !cloud fraction
-real,intent(in) :: zqr(klon,klev) !rain specifiq content
-real,intent(in) :: zqs(klon,klev) !snow specifiq content
-real,intent(in) :: zqg(klon,klev) !graupel specifiq content
-real,intent(in) :: ptke(klon,klev) !tke
-
-real :: t_ops ! frequency of the IOIPSL operations (eg average over...)
-real :: t_wrt ! frequency of the IOIPSL outputs
-integer :: zvertid ! vertical coordinate ID
-real :: dtime
-
-integer,save :: iwrite_phys=1 ! output every iwrite_phys physics step
-!$OMP THREADPRIVATE(iwrite_phys)
-integer :: nhori ! horizontal coordinate ID
-integer,save :: nid_hist ! output file ID
-!$OMP THREADPRIVATE(nid_hist)
-integer, save :: itau=0
-!$OMP THREADPRIVATE(itau)
-
-integer, save :: ioex=1
-
-
-print*,'nnnnnnn ',nid_hist,debut,itau
-
-if(debut)then
-
-   call getin_p("iwrite_phys",iwrite_phys)
-
-   !$OMP MASTER
-   CALL iophys_ini(pdtphys)
-   !$OMP END MASTER
-   !$OMP BARRIER
-
-endif
-
-
-itau=itau+1
-
-if (modulo(itau,iwrite_phys)==0) then
-     call iophys_ecrit('temp',klev,'Temperature','K',t)
-     call iophys_ecrit('u',klev,'zonal wind','m/s',u)
-     call iophys_ecrit('v',klev,'meridinal wind','m/s',v)
-     call iophys_ecrit('ps',1,'Surface pressure','Pa',paprs(:,1))
-     call iophys_ecrit('qv',klev,'Water vapor specifiq content', 'kg/kg', qx(:,:,1))
-     call iophys_ecrit('qc',klev,'Cloud liquid water specifiq content', 'kg/kg', qx(:,:,2))
-     call iophys_ecrit('qi',klev,'Cloud solid water specifiq content', 'kg/kg', qx(:,:,3))
-     call iophys_ecrit('CF',klev,'Cloud fraction', '0-1', cf)
-     call iophys_ecrit('qr',klev,'Rain specifiq content', 'kg/kg', zqr)
-     call iophys_ecrit('qs',klev,'Snow specifiq content', 'kg/kg', zqs)
-     call iophys_ecrit('qg',klev,'Graupel specifiq content', 'kg/kg', zqg)
-     call iophys_ecrit('TKE',klev,'TKE', 'm2/s2', ptke)
-     call iophys_ecrit('theta',klev,'Temperature potentielle', 'K', theta)
-endif
-
-
-END SUBROUTINE output_physiqex
-END MODULE output_physiqex_mod
Index: /LMDZ6/trunk/libf/phylmd/output_physiqex_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/output_physiqex_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/output_physiqex_mod.f90	(revision 5268)
@@ -0,0 +1,87 @@
+MODULE output_physiqex_mod
+
+
+
+CONTAINS 
+
+SUBROUTINE output_physiqex(debut,zjulian,pdtphys,presnivs,paprs,u,v,t,qx,cf,zqr,zqs,zqg,ptke,theta)
+
+      USE dimphy, only : klon,klev
+      USE iophy, only : histbeg_phy,histwrite_phy
+      USE ioipsl, only : histvert,histdef,histend,histsync
+      USE mod_phys_lmdz_para, only : jj_nb
+      USE ioipsl_getin_p_mod, ONLY : getin_p
+      USE mod_grid_phy_lmdz, ONLY: nbp_lon,nbp_lat
+      USE iophy, ONLY : init_iophy_new
+      USE geometry_mod, ONLY: latitude_deg, longitude_deg
+      USE infotrac_phy, only : nqtot
+
+
+
+implicit none
+logical, intent(in) :: debut
+real, intent(in) :: pdtphys,zjulian
+real,intent(in) :: presnivs(klev) ! pseudo-pressure (Pa) of mid-layers
+real,intent(in) :: u(klon,klev) ! eastward zonal wind (m/s)
+real,intent(in) :: v(klon,klev) ! northward meridional wind (m/s)
+real,intent(in) :: t(klon,klev) ! temperature (K)
+real,intent(in) :: theta(klon,klev) ! temperature (K)
+real,intent(in) :: paprs(klon,klev+1) ! interlayer pressure (Pa)
+real,intent(in) :: qx(klon,klev,nqtot) !tracers
+real,intent(in) :: cf(klon,klev) !cloud fraction
+real,intent(in) :: zqr(klon,klev) !rain specifiq content
+real,intent(in) :: zqs(klon,klev) !snow specifiq content
+real,intent(in) :: zqg(klon,klev) !graupel specifiq content
+real,intent(in) :: ptke(klon,klev) !tke
+
+real :: t_ops ! frequency of the IOIPSL operations (eg average over...)
+real :: t_wrt ! frequency of the IOIPSL outputs
+integer :: zvertid ! vertical coordinate ID
+real :: dtime
+
+integer,save :: iwrite_phys=1 ! output every iwrite_phys physics step
+!$OMP THREADPRIVATE(iwrite_phys)
+integer :: nhori ! horizontal coordinate ID
+integer,save :: nid_hist ! output file ID
+!$OMP THREADPRIVATE(nid_hist)
+integer, save :: itau=0
+!$OMP THREADPRIVATE(itau)
+
+integer, save :: ioex=1
+
+
+print*,'nnnnnnn ',nid_hist,debut,itau
+
+if(debut)then
+
+   call getin_p("iwrite_phys",iwrite_phys)
+
+   !$OMP MASTER
+   CALL iophys_ini(pdtphys)
+   !$OMP END MASTER
+   !$OMP BARRIER
+
+endif
+
+
+itau=itau+1
+
+if (modulo(itau,iwrite_phys)==0) then
+     call iophys_ecrit('temp',klev,'Temperature','K',t)
+     call iophys_ecrit('u',klev,'zonal wind','m/s',u)
+     call iophys_ecrit('v',klev,'meridinal wind','m/s',v)
+     call iophys_ecrit('ps',1,'Surface pressure','Pa',paprs(:,1))
+     call iophys_ecrit('qv',klev,'Water vapor specifiq content', 'kg/kg', qx(:,:,1))
+     call iophys_ecrit('qc',klev,'Cloud liquid water specifiq content', 'kg/kg', qx(:,:,2))
+     call iophys_ecrit('qi',klev,'Cloud solid water specifiq content', 'kg/kg', qx(:,:,3))
+     call iophys_ecrit('CF',klev,'Cloud fraction', '0-1', cf)
+     call iophys_ecrit('qr',klev,'Rain specifiq content', 'kg/kg', zqr)
+     call iophys_ecrit('qs',klev,'Snow specifiq content', 'kg/kg', zqs)
+     call iophys_ecrit('qg',klev,'Graupel specifiq content', 'kg/kg', zqg)
+     call iophys_ecrit('TKE',klev,'TKE', 'm2/s2', ptke)
+     call iophys_ecrit('theta',klev,'Temperature potentielle', 'K', theta)
+endif
+
+
+END SUBROUTINE output_physiqex
+END MODULE output_physiqex_mod
Index: DZ6/trunk/libf/phylmd/ozonecm_m.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/ozonecm_m.F90	(revision 5267)
+++ 	(revision )
@@ -1,97 +1,0 @@
-! $Header$
-module ozonecm_m
-
-  IMPLICIT NONE
-
-contains
-
-  function ozonecm(rlat, paprs,read_climoz, rjour)
-
-    ! The ozone climatology is based on an analytic formula which fits the
-    ! Krueger and Mintzner (1976) profile, as well as the variations with
-    ! altitude and latitude of the maximum ozone concentrations and the total
-    ! column ozone concentration of Keating and Young (1986). The analytic
-    ! formula have been established by J.-F. Royer (CRNM, Meteo France), who
-    ! also provided us the code.
-
-    ! A. J. Krueger and R. A. Minzner, A Mid-Latitude Ozone Model for the
-    ! 1976 U.S. Standard Atmosphere, J. Geophys. Res., 81, 4477, (1976).
-
-    ! Keating, G. M. and D. F. Young, 1985: Interim reference models for the
-    ! middle atmosphere, Handbook for MAP, vol. 16, 205-229.
-
-    USE dimphy, only: klon, klev
-    use assert_m, only: assert
-
-    REAL, INTENT (IN) :: rlat(:) ! (klon)
-    REAL, INTENT (IN) :: paprs(:, :) ! (klon,klev+1)
-    REAL, INTENT (IN) :: rjour
-    INTEGER, INTENT (IN) :: read_climoz
-
-    REAL ozonecm(klon,klev)
-    ! "ozonecm(j, k)" is the column-density of ozone in cell "(j, k)", that is
-    ! between interface "k" and interface "k + 1", in kDU.
-
-    ! Variables local to the procedure:
-
-    REAL tozon ! equivalent pressure of ozone above interface "k", in Pa
-    real pi, pl
-    INTEGER i, k
-
-    REAL field(klon,klev+1)
-    ! "field(:, k)" is the column-density of ozone between interface
-    ! "k" and the top of the atmosphere (interface "llm + 1"), in kDU.
-
-    real, PARAMETER:: ps=101325.
-    REAL, parameter:: an = 360., zo3q3 = 4E-8
-    REAL, parameter:: dobson_unit = 2.1415E-5 ! in kg m-2
-    REAL gms, zslat,zslat2, zsint, zcost, z, ppm, qpm, a
-    REAL asec, bsec, aprim, zo3a3
-
-    !----------------------------------------------------------
-
-    call assert((/size(rlat), size(paprs, 1)/) == klon, "ozonecm klon")
-    call assert(size(paprs, 2) == klev + 1, "ozonecm klev")
-
-    pi = 4. * atan(1.)
-    DO k = 1, klev
-       DO i = 1, klon
-          zslat = sin(pi / 180. * rlat(i))
-          zslat2=zslat*zslat
-          IF (read_climoz==-1) zslat=0. ! Imposing hemispheric symetry
-          zsint = sin(2 * pi * (rjour + 15.) / an)
-          zcost = cos(2 * pi * (rjour + 15.) / an)
-          z = 0.0531 + zsint * (-0.001595+0.009443*zslat) &
-               + zcost * (-0.001344-0.00346*zslat) &
-               + zslat2 * (.056222 + zslat2 &
-               * (-.037609+.012248*zsint+.00521*zcost+.008890*zslat))
-          zo3a3 = zo3q3/ps/2.
-          z = z - zo3q3*ps
-          gms = z
-          ppm = 800. - 500.*zslat2 - 150.*zcost*zslat
-          qpm = 1.74E-5 - 7.5E-6*zslat2 - 1.7E-6*zcost*zslat
-          bsec = 2650. + 5000.*zslat2
-          a = 4.0*(bsec)**(3./2.)*(ppm)**(3./2.)*(1.0+(bsec/ps)**(3./2.))
-          a = a/(bsec**(3./2.)+ppm**(3./2.))**2
-          aprim = (2.666666*qpm*ppm-a*gms)/(1.0-a)
-          aprim = amax1(0., aprim)
-          asec = (gms-aprim)*(1.0+(bsec/ps)**(3./2.))
-          asec = amax1(0.0, asec)
-          aprim = gms - asec/(1.+(bsec/ps)**(3./2.))
-          pl = paprs(i, k)
-          tozon = aprim / (1. + 3. * (ppm / pl)**2) &
-               + asec / (1. + (bsec / pl)**(3./2.)) + zo3a3 * pl * pl
-          ! Convert from Pa to kDU:
-          field(i, k) = tozon / 9.81 / dobson_unit / 1e3
-       END DO
-    END DO
-
-    field(:,klev+1) = 0.
-    forall (k = 1: klev) ozonecm(:,k) = field(:,k) - field(:,k+1)
-    ozonecm = max(ozonecm, 1e-12)
-
-!    print*,'ozonecm Version2'
-
-  END function ozonecm
-
-end module ozonecm_m
Index: /LMDZ6/trunk/libf/phylmd/ozonecm_m.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/ozonecm_m.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/ozonecm_m.f90	(revision 5268)
@@ -0,0 +1,97 @@
+! $Header$
+module ozonecm_m
+
+  IMPLICIT NONE
+
+contains
+
+  function ozonecm(rlat, paprs,read_climoz, rjour)
+
+    ! The ozone climatology is based on an analytic formula which fits the
+    ! Krueger and Mintzner (1976) profile, as well as the variations with
+    ! altitude and latitude of the maximum ozone concentrations and the total
+    ! column ozone concentration of Keating and Young (1986). The analytic
+    ! formula have been established by J.-F. Royer (CRNM, Meteo France), who
+    ! also provided us the code.
+
+    ! A. J. Krueger and R. A. Minzner, A Mid-Latitude Ozone Model for the
+    ! 1976 U.S. Standard Atmosphere, J. Geophys. Res., 81, 4477, (1976).
+
+    ! Keating, G. M. and D. F. Young, 1985: Interim reference models for the
+    ! middle atmosphere, Handbook for MAP, vol. 16, 205-229.
+
+    USE dimphy, only: klon, klev
+    use assert_m, only: assert
+
+    REAL, INTENT (IN) :: rlat(:) ! (klon)
+    REAL, INTENT (IN) :: paprs(:, :) ! (klon,klev+1)
+    REAL, INTENT (IN) :: rjour
+    INTEGER, INTENT (IN) :: read_climoz
+
+    REAL ozonecm(klon,klev)
+    ! "ozonecm(j, k)" is the column-density of ozone in cell "(j, k)", that is
+    ! between interface "k" and interface "k + 1", in kDU.
+
+    ! Variables local to the procedure:
+
+    REAL tozon ! equivalent pressure of ozone above interface "k", in Pa
+    real pi, pl
+    INTEGER i, k
+
+    REAL field(klon,klev+1)
+    ! "field(:, k)" is the column-density of ozone between interface
+    ! "k" and the top of the atmosphere (interface "llm + 1"), in kDU.
+
+    real, PARAMETER:: ps=101325.
+    REAL, parameter:: an = 360., zo3q3 = 4E-8
+    REAL, parameter:: dobson_unit = 2.1415E-5 ! in kg m-2
+    REAL gms, zslat,zslat2, zsint, zcost, z, ppm, qpm, a
+    REAL asec, bsec, aprim, zo3a3
+
+    !----------------------------------------------------------
+
+    call assert((/size(rlat), size(paprs, 1)/) == klon, "ozonecm klon")
+    call assert(size(paprs, 2) == klev + 1, "ozonecm klev")
+
+    pi = 4. * atan(1.)
+    DO k = 1, klev
+       DO i = 1, klon
+          zslat = sin(pi / 180. * rlat(i))
+          zslat2=zslat*zslat
+          IF (read_climoz==-1) zslat=0. ! Imposing hemispheric symetry
+          zsint = sin(2 * pi * (rjour + 15.) / an)
+          zcost = cos(2 * pi * (rjour + 15.) / an)
+          z = 0.0531 + zsint * (-0.001595+0.009443*zslat) &
+               + zcost * (-0.001344-0.00346*zslat) &
+               + zslat2 * (.056222 + zslat2 &
+               * (-.037609+.012248*zsint+.00521*zcost+.008890*zslat))
+          zo3a3 = zo3q3/ps/2.
+          z = z - zo3q3*ps
+          gms = z
+          ppm = 800. - 500.*zslat2 - 150.*zcost*zslat
+          qpm = 1.74E-5 - 7.5E-6*zslat2 - 1.7E-6*zcost*zslat
+          bsec = 2650. + 5000.*zslat2
+          a = 4.0*(bsec)**(3./2.)*(ppm)**(3./2.)*(1.0+(bsec/ps)**(3./2.))
+          a = a/(bsec**(3./2.)+ppm**(3./2.))**2
+          aprim = (2.666666*qpm*ppm-a*gms)/(1.0-a)
+          aprim = amax1(0., aprim)
+          asec = (gms-aprim)*(1.0+(bsec/ps)**(3./2.))
+          asec = amax1(0.0, asec)
+          aprim = gms - asec/(1.+(bsec/ps)**(3./2.))
+          pl = paprs(i, k)
+          tozon = aprim / (1. + 3. * (ppm / pl)**2) &
+               + asec / (1. + (bsec / pl)**(3./2.)) + zo3a3 * pl * pl
+          ! Convert from Pa to kDU:
+          field(i, k) = tozon / 9.81 / dobson_unit / 1e3
+       END DO
+    END DO
+
+    field(:,klev+1) = 0.
+    forall (k = 1: klev) ozonecm(:,k) = field(:,k) - field(:,k+1)
+    ozonecm = max(ozonecm, 1e-12)
+
+!    print*,'ozonecm Version2'
+
+  END function ozonecm
+
+end module ozonecm_m
Index: DZ6/trunk/libf/phylmd/perturb_radlwsw.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/perturb_radlwsw.F90	(revision 5267)
+++ 	(revision )
@@ -1,27 +1,0 @@
-      SUBROUTINE perturb_radlwsw(zxtsol,iflag_radia)
-!
-!Case-specific radiative setup
-!
-      use dimphy
-      IMPLICIT none
-      INCLUDE "flux_arp.h"     
-!
-! Arguments :
-!------------
-      REAL,DIMENSION(klon), INTENT(INOUT) :: zxtsol
-      INTEGER, INTENT(IN)                 :: iflag_radia
-!
-!======================================================================
-!
-      IF (iflag_radia == 2) THEN
-!
-! Iflag_radia = 2 : DICE case : 
-!               on force zxtsol=tg pour le rayonnement (MPL 20130806)
-!Sonia : Cas dice lmdz1d force en flux : on impose Tg pour imposer le LWUP
-!
-        zxtsol(:) =  tg
-      ENDIF
-!
-      RETURN
-      END
-
Index: /LMDZ6/trunk/libf/phylmd/perturb_radlwsw.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/perturb_radlwsw.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/perturb_radlwsw.f90	(revision 5268)
@@ -0,0 +1,27 @@
+      SUBROUTINE perturb_radlwsw(zxtsol,iflag_radia)
+!
+!Case-specific radiative setup
+!
+      use dimphy
+      IMPLICIT none
+      INCLUDE "flux_arp.h"     
+!
+! Arguments :
+!------------
+      REAL,DIMENSION(klon), INTENT(INOUT) :: zxtsol
+      INTEGER, INTENT(IN)                 :: iflag_radia
+!
+!======================================================================
+!
+      IF (iflag_radia == 2) THEN
+!
+! Iflag_radia = 2 : DICE case : 
+!               on force zxtsol=tg pour le rayonnement (MPL 20130806)
+!Sonia : Cas dice lmdz1d force en flux : on impose Tg pour imposer le LWUP
+!
+        zxtsol(:) =  tg
+      ENDIF
+!
+      RETURN
+      END
+
Index: DZ6/trunk/libf/phylmd/phyaqua_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/phyaqua_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,993 +1,0 @@
-!
-! $Id$
-!
-MODULE phyaqua_mod
-  ! Routines complementaires pour la physique planetaire.
-  IMPLICIT NONE
-
-CONTAINS
-
-  SUBROUTINE iniaqua(nlon,year_len,iflag_phys)
-
-    ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-    ! Creation d'un etat initial et de conditions aux limites
-    ! (resp startphy.nc et limit.nc) pour des configurations idealisees
-    ! du modele LMDZ dans sa version terrestre.
-    ! iflag_phys est un parametre qui controle
-    ! iflag_phys = N
-    ! de 100 a 199 : aqua planetes avec SST forcees
-    ! N-100 determine le type de SSTs
-    ! de 200 a 299 : terra planetes avec Ts calcule
-
-    ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-    USE dimphy, ONLY: klon
-    USE geometry_mod, ONLY : latitude
-    USE surface_data, ONLY: type_ocean, ok_veget
-    USE pbl_surface_mod, ONLY: pbl_surface_init
-    USE fonte_neige_mod, ONLY: fonte_neige_init
-    USE phys_state_var_mod
-    USE time_phylmdz_mod, ONLY: day_ref, ndays, pdtphys, &
-                                day_ini,day_end
-    USE indice_sol_mod
-    USE nrtype, ONLY: pi
-!    USE ioipsl
-    USE mod_phys_lmdz_para, ONLY: is_master
-    USE mod_phys_lmdz_transfert_para, ONLY: bcast
-    USE mod_grid_phy_lmdz
-    USE ioipsl_getin_p_mod, ONLY : getin_p
-    USE phys_cal_mod , ONLY: calend, year_len_phy => year_len 
-    IMPLICIT NONE
-
-    include "YOMCST.h"
-    include "clesphys.h"
-    include "dimsoil.h"
-
-    INTEGER, INTENT (IN) :: nlon, year_len, iflag_phys
-    ! IM ajout latfi, lonfi
-!    REAL, INTENT (IN) :: lonfi(nlon), latfi(nlon)
-
-    INTEGER type_profil, type_aqua
-
-    ! Ajouts initialisation des surfaces
-    REAL :: run_off_lic_0(nlon)
-    REAL :: qsolsrf(nlon, nbsrf), snsrf(nlon, nbsrf)
-    REAL :: tsoil(nlon, nsoilmx, nbsrf)
-    REAL :: tslab(nlon), seaice(nlon)
-    REAL fder(nlon)
-
-
-
-    ! Arguments :
-    ! -----------
-
-    ! integer radpas
-    INTEGER it, unit, i, k, itap
-
-    REAL rugos, albedo
-    REAL tsurf
-    REAL time, timestep, day, day0
-    REAL qsol_f
-    REAL rugsrel(nlon)
-    LOGICAL alb_ocean
-
-    CHARACTER *80 ans, file_forctl, file_fordat, file_start
-    CHARACTER *100 file, var
-    CHARACTER *2 cnbl
-
-    REAL phy_nat(nlon, year_len)
-    REAL phy_alb(nlon, year_len)
-    REAL phy_sst(nlon, year_len)
-    REAL phy_bil(nlon, year_len)
-    REAL phy_rug(nlon, year_len)
-    REAL phy_ice(nlon, year_len)
-    REAL phy_fter(nlon, year_len)
-    REAL phy_foce(nlon, year_len)
-    REAL phy_fsic(nlon, year_len)
-    REAL phy_flic(nlon, year_len)
-
-    INTEGER, SAVE :: read_climoz = 0 ! read ozone climatology
-!$OMP THREADPRIVATE(read_climoz)
-
-    ! -------------------------------------------------------------------------
-    ! declaration pour l'appel a phyredem
-    ! -------------------------------------------------------------------------
-
-    ! real pctsrf(nlon,nbsrf),ftsol(nlon,nbsrf)
-    REAL falbe(nlon, nbsrf), falblw(nlon, nbsrf)
-    ! real pbl_tke(nlon,llm,nbsrf)
-    ! real rain_fall(nlon),snow_fall(nlon)
-    ! real solsw(nlon), sollw(nlon),radsol(nlon)
-    ! real t_ancien(nlon,llm),q_ancien(nlon,llm),rnebcon(nlon,llm)
-    ! real ratqs(nlon,llm)
-    ! real clwcon(nlon,llm)
-
-    INTEGER longcles
-    PARAMETER (longcles=20)
-    REAL clesphy0(longcles)
-
-
-    ! -----------------------------------------------------------------------
-    ! dynamial tendencies :
-    ! ---------------------
-
-    INTEGER l, ierr, aslun
-
-    REAL paire
-
-    ! Local
-    CHARACTER (LEN=20) :: modname='phyaqua'
-    CHARACTER (LEN=80) :: abort_message
-
-
-    ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-    ! INITIALISATIONS
-    ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-    ! -----------------------------------------------------------------------
-    ! Initialisations  des constantes
-    ! -------------------------------
-
-    !IF (calend .EQ. "earth_360d") Then
-      year_len_phy = year_len
-    !END IF
-    
-    if (year_len.ne.360) then
-      write (*,*) year_len
-      call abort_physic("iniaqua", 'iniaqua: 360 day calendar is required !', 1)
-    endif
-
-    type_aqua = iflag_phys/100
-    type_profil = iflag_phys - type_aqua*100
-    PRINT *, 'iniaqua:type_aqua, type_profil', type_aqua, type_profil
-
-    IF (klon/=nlon) THEN
-      WRITE (*, *) 'iniaqua: klon=', klon, ' nlon=', nlon
-      abort_message= 'probleme de dimensions dans iniaqua'
-      CALL abort_physic(modname,abort_message,1)
-    END IF
-    CALL phys_state_var_init(read_climoz)
-
-
-    read_climoz = 0
-    day0 = 217.
-    day = day0
-    it = 0
-    time = 0.
-
-    ! -----------------------------------------------------------------------
-    ! initialisations de la physique
-    ! -----------------------------------------------------------------------
-
-    day_ini = day_ref
-    day_end = day_ini + ndays
-
-    nbapp_rad = 24
-    CALL getin_p('nbapp_rad', nbapp_rad)
-
-    ! ---------------------------------------------------------------------
-    ! Creation des conditions aux limites:
-    ! ------------------------------------
-    ! Initialisations des constantes
-    ! Ajouter les manquants dans planete.def... (albedo etc)
-    co2_ppm = 348.
-    CALL getin_p('co2_ppm', co2_ppm)
-
-    solaire = 1365.
-    CALL getin_p('solaire', solaire)
- 
-    ! CALL getin('albedo',albedo) ! albedo is set below, depending on
-    ! type_aqua
-    alb_ocean = .TRUE.
-    CALL getin_p('alb_ocean', alb_ocean)
-
-    WRITE (*, *) 'iniaqua: co2_ppm=', co2_ppm
-    WRITE (*, *) 'iniaqua: solaire=', solaire
-    WRITE (*, *) 'iniaqua: alb_ocean=', alb_ocean
-
-    radsol = 0.
-    qsol_f = 10.
-
-    ! Conditions aux limites:
-    ! -----------------------
-
-    qsol(:) = qsol_f
-    rugsrel = 0.0 ! (rugsrel = rugoro)
-    rugoro = 0.0
-    u_ancien = 0.0
-    v_ancien = 0.0
-    agesno = 50.0
-    ! Relief plat
-    zmea = 0.
-    zstd = 0.
-    zsig = 0.
-    zgam = 0.
-    zthe = 0.
-    zpic = 0.
-    zval = 0.
-
-    ! Une seule surface
-    pctsrf = 0.
-    IF (type_aqua==1) THEN
-      rugos = 1.E-4
-      albedo = 0.19
-      pctsrf(:, is_oce) = 1.
-    ELSE IF (type_aqua==2) THEN
-      rugos = 0.03
-      albedo = 0.1
-      pctsrf(:, is_ter) = 1.
-    END IF
-
-    CALL getin_p('rugos', rugos)
-
-    WRITE (*, *) 'iniaqua: rugos=', rugos
-    zmasq(:) = pctsrf(:, is_ter)
-
-    ! pctsrf_pot(:,is_oce) = 1. - zmasq(:)
-    ! pctsrf_pot(:,is_sic) = 1. - zmasq(:)
-
-    ! Si alb_ocean on calcule un albedo oceanique moyen
-    ! if (alb_ocean) then
-    ! Voir pourquoi on avait ca.
-    ! CALL ini_alb_oce(phy_alb)
-    ! else
-    phy_alb(:, :) = albedo ! albedo land only (old value condsurf_jyg=0.3)
-    ! endif !alb_ocean
-
-    DO i = 1, year_len
-      ! IM Terraplanete   phy_sst(:,i) = 260.+50.*cos(rlatd(:))**2
-      ! IM ajout calcul profil sst selon le cas considere (cf. FBr)
-
-      phy_nat(:, i) = 1.0 ! 0=ocean libre, 1=land, 2=glacier, 3=banquise
-      phy_bil(:, i) = 1.0 ! ne sert que pour les slab_ocean
-      phy_rug(:, i) = rugos ! longueur rugosite utilisee sur land only
-      phy_ice(:, i) = 0.0 ! fraction de glace (?)
-      phy_fter(:, i) = pctsrf(:, is_ter) ! fraction de glace (?)
-      phy_foce(:, i) = pctsrf(:, is_oce) ! fraction de glace (?)
-      phy_fsic(:, i) = pctsrf(:, is_sic) ! fraction de glace (?)
-      phy_flic(:, i) = pctsrf(:, is_lic) ! fraction de glace (?)
-    END DO
-    ! IM calcul profil sst
-    CALL profil_sst(nlon, latitude, type_profil, phy_sst)
-
-    IF (grid_type==unstructured) THEN
-      CALL writelim_unstruct(klon, phy_nat, phy_alb, phy_sst, phy_bil, phy_rug, phy_ice, &
-                             phy_fter, phy_foce, phy_flic, phy_fsic)
-    ELSE
-      
-       CALL writelim(klon, phy_nat, phy_alb, phy_sst, phy_bil, phy_rug, phy_ice, &
-                     phy_fter, phy_foce, phy_flic, phy_fsic)
-    ENDIF
-
-    ! ---------------------------------------------------------------------
-    ! Ecriture de l'etat initial:
-    ! ---------------------------
-
-
-    ! Ecriture etat initial physique
-
-    timestep = pdtphys
-    radpas = nint(rday/timestep/float(nbapp_rad))
-
-    DO i = 1, longcles
-      clesphy0(i) = 0.
-    END DO
-    clesphy0(1) = float(iflag_con)
-    clesphy0(2) = float(nbapp_rad)
-    ! IF( cycle_diurne  ) clesphy0(3) =  1.
-    clesphy0(3) = 1. ! cycle_diurne
-    clesphy0(4) = 1. ! soil_model
-    clesphy0(5) = 1. ! new_oliq
-    clesphy0(6) = 0. ! ok_orodr
-    clesphy0(7) = 0. ! ok_orolf
-    clesphy0(8) = 0. ! ok_limitvrai
-
-
-    ! =======================================================================
-    ! Profils initiaux
-    ! =======================================================================
-
-    ! On initialise les temperatures de surfaces comme les sst
-    DO i = 1, nlon
-      ftsol(i, :) = phy_sst(i, 1)
-      tsoil(i, :, :) = phy_sst(i, 1)
-      tslab(i) = phy_sst(i, 1)
-    END DO
-
-    falbe(:, :) = albedo
-    falblw(:, :) = albedo
-    rain_fall(:) = 0.
-    snow_fall(:) = 0.
-    solsw(:) = 0.
-    sollw(:) = 0.
-    radsol(:) = 0.
-
-    ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-    ! intialisation bidon mais pas grave
-    t_ancien(:, :) = 0.
-    q_ancien(:, :) = 0.
-    ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-    rnebcon = 0.
-    ratqs = 0.
-    clwcon = 0.
-    pbl_tke = 1.E-8
-
-    ! variables supplementaires pour appel a plb_surface_init
-    fder(:) = 0.
-    seaice(:) = 0.
-    run_off_lic_0 = 0.
-    fevap = 0.
-
-
-    ! Initialisations necessaires avant phyredem
-    type_ocean = 'force'
-    CALL fonte_neige_init(run_off_lic_0)
-    qsolsrf(:, :) = qsol(1) ! humidite du sol des sous surface
-    snsrf(:, :) = 0. ! couverture de neige des sous surface
-    z0m(:, :) = rugos ! couverture de neige des sous surface
-    z0h=z0m
-
-
-    CALL pbl_surface_init(fder, snsrf, qsolsrf, tsoil)
-
-    PRINT *, 'iniaqua: before phyredem'
-
-    pbl_tke(:,:,:) = 1.e-8 
-    falb1 = albedo
-    falb2 = albedo
-    zmax0 = 0.
-    f0 = 0.
-    sig1 = 0.
-    w01 = 0.
-    wake_deltat = 0.
-    wake_deltaq = 0.
-    wake_s = 0.
-    wake_dens = 0.
-    wake_cstar = 0.
-    wake_pe = 0.
-    wake_fip = 0.
-    fm_therm = 0.
-    entr_therm = 0.
-    detr_therm = 0.
-    ale_bl = 0.
-    ale_bl_trig =0. 
-    alp_bl =0.
-    treedrg(:,:,:)=0.
-
-    u10m = 0.
-    v10m = 0.
-
-    ql_ancien   = 0.
-    qs_ancien   = 0.
-    qbs_ancien  = 0.
-    u_ancien    = 0.
-    v_ancien    = 0.
-    prw_ancien  = 0.
-    prlw_ancien = 0.
-    prsw_ancien = 0.  
-    prbsw_ancien= 0.
-
-    ale_wake    = 0.
-    ale_bl_stat = 0.  
-
-
-!ym error : the sub surface dimension is the third not second : forgotten for iniaqua
-!    falb_dir(:,is_ter,:)=0.08; falb_dir(:,is_lic,:)=0.6
-!    falb_dir(:,is_oce,:)=0.5;  falb_dir(:,is_sic,:)=0.6
-    falb_dir(:,:,is_ter)=0.08; falb_dir(:,:,is_lic)=0.6
-    falb_dir(:,:,is_oce)=0.5;  falb_dir(:,:,is_sic)=0.6
-
-!ym falb_dif has been forgotten, initialize with defaukt value found in phyetat0 or 0 ?
-!ym probably the uninitialized value was 0 for standard (regular grid) case
-    falb_dif(:,:,:)=0
-
-
-    CALL phyredem('startphy.nc')
-
-    PRINT *, 'iniaqua: after phyredem'
-    CALL phys_state_var_end
-
-    RETURN
-  END SUBROUTINE iniaqua
-
-
-  ! ====================================================================
-  ! ====================================================================
-  SUBROUTINE zenang_an(cycle_diurne, gmtime, rlat, rlon, rmu0, fract)
-    USE dimphy
-    IMPLICIT NONE
-    ! ====================================================================
-    ! =============================================================
-    ! CALL zenang(cycle_diurne,gmtime,rlat,rlon,rmu0,fract)
-    ! Auteur : A. Campoy et F. Hourdin
-    ! Objet  : calculer les valeurs moyennes du cos de l'angle zenithal
-    ! et l'ensoleillement moyen entre gmtime1 et gmtime2
-    ! connaissant la declinaison, la latitude et la longitude.
-
-    ! Dans cette version particuliere, on calcule le rayonnement
-    ! moyen sur l'année à chaque latitude.
-    ! angle zenithal calculé pour obtenir un
-    ! Fit polynomial de  l'ensoleillement moyen au sommet de l'atmosphere
-    ! en moyenne annuelle.
-    ! Spécifique de la terre. Utilisé pour les aqua planetes.
-
-    ! Rque   : Different de la routine angle en ce sens que zenang
-    ! fournit des moyennes de pmu0 et non des valeurs
-    ! instantanees, du coup frac prend toutes les valeurs
-    ! entre 0 et 1.
-    ! Date   : premiere version le 13 decembre 1994
-    ! revu pour  GCM  le 30 septembre 1996
-    ! ===============================================================
-    ! longi----INPUT : la longitude vraie de la terre dans son plan
-    ! solaire a partir de l'equinoxe de printemps (degre)
-    ! gmtime---INPUT : temps universel en fraction de jour
-    ! pdtrad---INPUT : pas de temps du rayonnement (secondes)
-    ! lat------INPUT : latitude en degres
-    ! long-----INPUT : longitude en degres
-    ! pmu0-----OUTPUT: angle zenithal moyen entre gmtime et gmtime+pdtrad
-    ! frac-----OUTPUT: ensoleillement moyen entre gmtime et gmtime+pdtrad
-    ! ================================================================
-    include "YOMCST.h"
-    ! ================================================================
-    LOGICAL cycle_diurne
-    REAL gmtime
-    REAL rlat(klon), rlon(klon), rmu0(klon), fract(klon)
-    ! ================================================================
-    INTEGER i
-    REAL gmtime1, gmtime2
-    REAL pi_local
-
-
-    REAL rmu0m(klon), rmu0a(klon)
-
-
-    pi_local = 4.0*atan(1.0)
-
-    ! ================================================================
-    ! Calcul de l'angle zenithal moyen sur la journee
-    ! ================================================================
-
-    DO i = 1, klon
-      fract(i) = 1.
-      ! Calcule du flux moyen
-      IF (abs(rlat(i))<=28.75) THEN
-        rmu0m(i) = (210.1924+206.6059*cos(0.0174533*rlat(i))**2)/1365.
-      ELSE IF (abs(rlat(i))<=43.75) THEN
-        rmu0m(i) = (187.4562+236.1853*cos(0.0174533*rlat(i))**2)/1365.
-      ELSE IF (abs(rlat(i))<=71.25) THEN
-        rmu0m(i) = (162.4439+284.1192*cos(0.0174533*rlat(i))**2)/1365.
-      ELSE
-        rmu0m(i) = (172.8125+183.7673*cos(0.0174533*rlat(i))**2)/1365.
-      END IF
-    END DO
-
-    ! ================================================================
-    ! Avec ou sans cycle diurne
-    ! ================================================================
-
-    IF (cycle_diurne) THEN
-
-      ! On redecompose flux  au sommet suivant un cycle diurne idealise
-      ! identique a toutes les latitudes.
-
-      DO i = 1, klon
-        rmu0a(i) = 2.*rmu0m(i)*sqrt(2.)*pi_local/(4.-pi_local)
-        rmu0(i) = rmu0a(i)*abs(sin(pi_local*gmtime+pi_local*rlon(i)/360.)) - &
-          rmu0a(i)/sqrt(2.)
-      END DO
-
-      DO i = 1, klon
-        IF (rmu0(i)<=0.) THEN
-          rmu0(i) = 0.
-          fract(i) = 0.
-        ELSE
-          fract(i) = 1.
-        END IF
-      END DO
-
-      ! Affichage de l'angel zenitale
-      ! print*,'************************************'
-      ! print*,'************************************'
-      ! print*,'************************************'
-      ! print*,'latitude=',rlat(i),'longitude=',rlon(i)
-      ! print*,'rmu0m=',rmu0m(i)
-      ! print*,'rmu0a=',rmu0a(i)
-      ! print*,'rmu0=',rmu0(i)
-
-    ELSE
-
-      DO i = 1, klon
-        fract(i) = 0.5
-        rmu0(i) = rmu0m(i)*2.
-      END DO
-
-    END IF
-
-    RETURN
-  END SUBROUTINE zenang_an
-
-  ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-  SUBROUTINE writelim_unstruct(klon, phy_nat, phy_alb, phy_sst, phy_bil, phy_rug, &
-      phy_ice, phy_fter, phy_foce, phy_flic, phy_fsic)
-
-    USE mod_phys_lmdz_para, ONLY: is_omp_master, klon_mpi
-    USE mod_phys_lmdz_transfert_para, ONLY: gather_omp
-    USE lmdz_xios
-    IMPLICIT NONE
-
-    include "netcdf.inc"
-
-    INTEGER, INTENT (IN) :: klon
-    REAL, INTENT (IN) :: phy_nat(klon, 360)
-    REAL, INTENT (IN) :: phy_alb(klon, 360)
-    REAL, INTENT (IN) :: phy_sst(klon, 360)
-    REAL, INTENT (IN) :: phy_bil(klon, 360)
-    REAL, INTENT (IN) :: phy_rug(klon, 360)
-    REAL, INTENT (IN) :: phy_ice(klon, 360)
-    REAL, INTENT (IN) :: phy_fter(klon, 360)
-    REAL, INTENT (IN) :: phy_foce(klon, 360)
-    REAL, INTENT (IN) :: phy_flic(klon, 360)
-    REAL, INTENT (IN) :: phy_fsic(klon, 360)
-
-    REAL :: phy_mpi(klon_mpi, 360) ! temporary variable, to store phy_***(:)
-      ! on the whole physics grid
- 
-    IF (using_xios) THEN
-      PRINT *, 'writelim: Ecriture du fichier limit'
-
-      CALL gather_omp(phy_foce, phy_mpi)
-      IF (is_omp_master) CALL xios_send_field('foce_limout',phy_mpi)
-
-      CALL gather_omp(phy_fsic, phy_mpi)
-      IF (is_omp_master) CALL xios_send_field('fsic_limout',phy_mpi)
-      
-      CALL gather_omp(phy_fter, phy_mpi)
-      IF (is_omp_master) CALL xios_send_field('fter_limout',phy_mpi)
-      
-      CALL gather_omp(phy_flic, phy_mpi)
-      IF (is_omp_master) CALL xios_send_field('flic_limout',phy_mpi)
-
-      CALL gather_omp(phy_sst, phy_mpi)
-      IF (is_omp_master) CALL xios_send_field('sst_limout',phy_mpi)
-
-      CALL gather_omp(phy_bil, phy_mpi)
-      IF (is_omp_master) CALL xios_send_field('bils_limout',phy_mpi)
-
-      CALL gather_omp(phy_alb, phy_mpi)
-      IF (is_omp_master) CALL xios_send_field('alb_limout',phy_mpi)
-
-      CALL gather_omp(phy_rug, phy_mpi)
-      IF (is_omp_master) CALL xios_send_field('rug_limout',phy_mpi)
-    ENDIF
-  END SUBROUTINE writelim_unstruct
-
-
-
-  SUBROUTINE writelim(klon, phy_nat, phy_alb, phy_sst, phy_bil, phy_rug, &
-      phy_ice, phy_fter, phy_foce, phy_flic, phy_fsic)
-
-    USE mod_phys_lmdz_para, ONLY: is_master
-    USE mod_grid_phy_lmdz, ONLY: klon_glo
-    USE mod_phys_lmdz_transfert_para, ONLY: gather
-    USE phys_cal_mod, ONLY: year_len
-    use netcdf, only: nf90_def_var, nf90_double, nf90_float, nf90_put_var
-    USE lmdz_cppkeys_wrapper, ONLY: nf90_format
-    IMPLICIT NONE
-    include "netcdf.inc"
-
-    INTEGER, INTENT (IN) :: klon
-    REAL, INTENT (IN) :: phy_nat(klon, year_len)
-    REAL, INTENT (IN) :: phy_alb(klon, year_len)
-    REAL, INTENT (IN) :: phy_sst(klon, year_len)
-    REAL, INTENT (IN) :: phy_bil(klon, year_len)
-    REAL, INTENT (IN) :: phy_rug(klon, year_len)
-    REAL, INTENT (IN) :: phy_ice(klon, year_len)
-    REAL, INTENT (IN) :: phy_fter(klon, year_len)
-    REAL, INTENT (IN) :: phy_foce(klon, year_len)
-    REAL, INTENT (IN) :: phy_flic(klon, year_len)
-    REAL, INTENT (IN) :: phy_fsic(klon, year_len)
-
-    REAL :: phy_glo(klon_glo, year_len) ! temporary variable, to store phy_***(:)
-      ! on the whole physics grid
-    INTEGER :: k
-    INTEGER ierr
-    INTEGER dimfirst(3)
-    INTEGER dimlast(3)
-
-    INTEGER nid, ndim, ntim
-    INTEGER dims(2), debut(2), epais(2)
-    INTEGER id_tim
-    INTEGER id_nat, id_sst, id_bils, id_rug, id_alb
-    INTEGER id_fter, id_foce, id_fsic, id_flic
-
-    IF (is_master) THEN
-
-      PRINT *, 'writelim: Ecriture du fichier limit'
-
-      ierr = nf_create('limit.nc', IOR(NF_CLOBBER,NF_64BIT_OFFSET), nid)
-
-      ierr = nf_put_att_text(nid, nf_global, 'title', 30, &
-        'Fichier conditions aux limites')
-      ! !        ierr = NF_DEF_DIM (nid, "points_physiques", klon, ndim)
-      ierr = nf_def_dim(nid, 'points_physiques', klon_glo, ndim)
-      ierr = nf_def_dim(nid, 'time', nf_unlimited, ntim)
-
-      dims(1) = ndim
-      dims(2) = ntim
-
-      ierr = nf90_def_var(nid, 'TEMPS', nf90_format, [ntim], id_tim)
-      ierr = nf_put_att_text(nid, id_tim, 'title', 17, 'Jour dans l annee')
-
-      ierr = nf90_def_var(nid, 'NAT', nf90_format, dims, id_nat)
-      ierr = nf_put_att_text(nid, id_nat, 'title', 23, &
-        'Nature du sol (0,1,2,3)')
-
-      ierr = nf90_def_var(nid, 'SST', nf90_format, dims, id_sst)
-      ierr = nf_put_att_text(nid, id_sst, 'title', 35, &
-        'Temperature superficielle de la mer')
-
-      ierr = nf90_def_var(nid, 'BILS', nf90_format, dims, id_bils)
-      ierr = nf_put_att_text(nid, id_bils, 'title', 32, &
-        'Reference flux de chaleur au sol')
-
-      ierr = nf90_def_var(nid, 'ALB', nf90_format, dims, id_alb)
-      ierr = nf_put_att_text(nid, id_alb, 'title', 19, 'Albedo a la surface')
-
-      ierr = nf90_def_var(nid, 'RUG', nf90_format, dims, id_rug)
-      ierr = nf_put_att_text(nid, id_rug, 'title', 8, 'Rugosite')
-
-      ierr = nf90_def_var(nid, 'FTER', nf90_format, dims, id_fter)
-      ierr = nf_put_att_text(nid, id_fter, 'title',10,'Frac. Land')
-      ierr = nf90_def_var(nid, 'FOCE', nf90_format, dims, id_foce)
-      ierr = nf_put_att_text(nid, id_foce, 'title',11,'Frac. Ocean')
-      ierr = nf90_def_var(nid, 'FSIC', nf90_format, dims, id_fsic)
-      ierr = nf_put_att_text(nid, id_fsic, 'title',13,'Frac. Sea Ice')
-      ierr = nf90_def_var(nid, 'FLIC', nf90_format, dims, id_flic)
-      ierr = nf_put_att_text(nid, id_flic, 'title',14,'Frac. Land Ice')
-
-      ierr = nf_enddef(nid)
-      IF (ierr/=nf_noerr) THEN
-        WRITE (*, *) 'writelim error: failed to end define mode'
-        WRITE (*, *) nf_strerror(ierr)
-      END IF
-
-
-      ! write the 'times'
-      DO k = 1, year_len
-        ierr = nf90_put_var(nid, id_tim, k, [k])
-        IF (ierr/=nf_noerr) THEN
-          WRITE (*, *) 'writelim error with temps(k),k=', k
-          WRITE (*, *) nf_strerror(ierr)
-        END IF
-      END DO
-
-    END IF ! of if (is_master)
-
-    ! write the fields, after having collected them on master
-
-    CALL gather(phy_nat, phy_glo)
-    IF (is_master) THEN
-      ierr = nf90_put_var(nid, id_nat, phy_glo)
-      IF (ierr/=nf_noerr) THEN
-        WRITE (*, *) 'writelim error with phy_nat'
-        WRITE (*, *) nf_strerror(ierr)
-      END IF
-    END IF
-
-    CALL gather(phy_sst, phy_glo)
-    IF (is_master) THEN
-      ierr = nf90_put_var(nid, id_sst, phy_glo)
-      IF (ierr/=nf_noerr) THEN
-        WRITE (*, *) 'writelim error with phy_sst'
-        WRITE (*, *) nf_strerror(ierr)
-      END IF
-    END IF
-
-    CALL gather(phy_bil, phy_glo)
-    IF (is_master) THEN
-      ierr = nf90_put_var(nid, id_bils, phy_glo)
-      IF (ierr/=nf_noerr) THEN
-        WRITE (*, *) 'writelim error with phy_bil'
-        WRITE (*, *) nf_strerror(ierr)
-      END IF
-    END IF
-
-    CALL gather(phy_alb, phy_glo)
-    IF (is_master) THEN
-      ierr = nf90_put_var(nid, id_alb, phy_glo)
-      IF (ierr/=nf_noerr) THEN
-        WRITE (*, *) 'writelim error with phy_alb'
-        WRITE (*, *) nf_strerror(ierr)
-      END IF
-    END IF
-
-    CALL gather(phy_rug, phy_glo)
-    IF (is_master) THEN
-      ierr = nf90_put_var(nid, id_rug, phy_glo)
-      IF (ierr/=nf_noerr) THEN
-        WRITE (*, *) 'writelim error with phy_rug'
-        WRITE (*, *) nf_strerror(ierr)
-      END IF
-    END IF
-
-    CALL gather(phy_fter, phy_glo)
-    IF (is_master) THEN
-      ierr = nf90_put_var(nid, id_fter, phy_glo)
-      IF (ierr/=nf_noerr) THEN
-        WRITE (*, *) 'writelim error with phy_fter'
-        WRITE (*, *) nf_strerror(ierr)
-      END IF
-    END IF
-
-    CALL gather(phy_foce, phy_glo)
-    IF (is_master) THEN
-      ierr = nf90_put_var(nid, id_foce, phy_glo)
-      IF (ierr/=nf_noerr) THEN
-        WRITE (*, *) 'writelim error with phy_foce'
-        WRITE (*, *) nf_strerror(ierr)
-      END IF
-    END IF
-
-    CALL gather(phy_fsic, phy_glo)
-    IF (is_master) THEN
-      ierr = nf90_put_var(nid, id_fsic, phy_glo)
-      IF (ierr/=nf_noerr) THEN
-        WRITE (*, *) 'writelim error with phy_fsic'
-        WRITE (*, *) nf_strerror(ierr)
-      END IF
-    END IF
-
-    CALL gather(phy_flic, phy_glo)
-    IF (is_master) THEN
-      ierr = nf90_put_var(nid, id_flic, phy_glo)
-      IF (ierr/=nf_noerr) THEN
-        WRITE (*, *) 'writelim error with phy_flic'
-        WRITE (*, *) nf_strerror(ierr)
-      END IF
-    END IF
-
-    ! close file:
-    IF (is_master) THEN
-      ierr = nf_close(nid)
-    END IF
-
-  END SUBROUTINE writelim
-
-  ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-  SUBROUTINE profil_sst(nlon, rlatd, type_profil, phy_sst)
-    USE dimphy
-    USE phys_cal_mod , ONLY: year_len
-    IMPLICIT NONE
-
-    INTEGER nlon, type_profil, i, k, j
-    REAL :: rlatd(nlon), phy_sst(nlon, year_len)
-    INTEGER imn, imx, amn, amx, kmn, kmx
-    INTEGER p, pplus, nlat_max
-    PARAMETER (nlat_max=72)
-    REAL x_anom_sst(nlat_max)
-    CHARACTER (LEN=20) :: modname='profil_sst'
-    CHARACTER (LEN=80) :: abort_message
-
-    IF (klon/=nlon) THEN
-       abort_message='probleme de dimensions dans profil_sst'
-       CALL abort_physic(modname,abort_message,1)
-    ENDIF
-    WRITE (*, *) ' profil_sst: type_profil=', type_profil
-    DO i = 1, year_len
-      ! phy_sst(:,i) = 260.+50.*cos(rlatd(:))**2
-
-      ! Rajout fbrlmd
-
-      IF (type_profil==1) THEN
-        ! Méthode 1 "Control" faible plateau à l'Equateur
-        DO j = 1, klon
-          phy_sst(j, i) = 273. + 27.*(1-sin(1.5*rlatd(j))**2)
-          ! PI/3=1.047197551
-          IF ((rlatd(j)>1.0471975) .OR. (rlatd(j)<-1.0471975)) THEN
-            phy_sst(j, i) = 273.
-          END IF
-        END DO
-      END IF
-      IF (type_profil==2) THEN
-        ! Méthode 2 "Flat" fort plateau à l'Equateur
-        DO j = 1, klon
-          phy_sst(j, i) = 273. + 27.*(1-sin(1.5*rlatd(j))**4)
-          IF ((rlatd(j)>1.0471975) .OR. (rlatd(j)<-1.0471975)) THEN
-            phy_sst(j, i) = 273.
-          END IF
-        END DO
-      END IF
-
-
-      IF (type_profil==3) THEN
-        ! Méthode 3 "Qobs" plateau réel à l'Equateur
-        DO j = 1, klon
-          phy_sst(j, i) = 273. + 0.5*27.*(2-sin(1.5*rlatd(j))**2-sin(1.5* &
-            rlatd(j))**4)
-          IF ((rlatd(j)>1.0471975) .OR. (rlatd(j)<-1.0471975)) THEN
-            phy_sst(j, i) = 273.
-          END IF
-        END DO
-      END IF
-
-      IF (type_profil==4) THEN
-        ! Méthode 4 : Méthode 3 + SST+2 "Qobs" plateau réel à l'Equateur
-        DO j = 1, klon
-          phy_sst(j, i) = 273. + 0.5*29.*(2-sin(1.5*rlatd(j))**2-sin(1.5* &
-            rlatd(j))**4)
-          IF ((rlatd(j)>1.0471975) .OR. (rlatd(j)<-1.0471975)) THEN
-            phy_sst(j, i) = 273.
-          END IF
-        END DO
-      END IF
-
-      IF (type_profil==5) THEN
-        ! Méthode 5 : Méthode 3 + +2K "Qobs" plateau réel à l'Equateur
-        DO j = 1, klon
-          phy_sst(j, i) = 273. + 2. + 0.5*27.*(2-sin(1.5*rlatd(j))**2-sin(1.5 &
-            *rlatd(j))**4)
-          IF ((rlatd(j)>1.0471975) .OR. (rlatd(j)<-1.0471975)) THEN
-            phy_sst(j, i) = 273. + 2.
-          END IF
-
-        END DO
-      END IF
-
-      IF (type_profil==6) THEN
-        ! Méthode 6 "cst" valeur constante de SST
-        DO j = 1, klon
-          phy_sst(j, i) = 288.
-        END DO
-      END IF
-
-
-      IF (type_profil==7) THEN
-        ! Méthode 7 "cst" valeur constante de SST +2
-        DO j = 1, klon
-          phy_sst(j, i) = 288. + 2.
-        END DO
-      END IF
-
-      p = 0
-      IF (type_profil==8) THEN
-        ! Méthode 8 profil anomalies SST du modèle couplé AR4
-        DO j = 1, klon
-          IF (rlatd(j)==rlatd(j-1)) THEN
-            phy_sst(j, i) = 273. + x_anom_sst(pplus) + &
-              0.5*27.*(2-sin(1.5*rlatd(j))**2-sin(1.5*rlatd(j))**4)
-            IF ((rlatd(j)>1.0471975) .OR. (rlatd(j)<-1.0471975)) THEN
-              phy_sst(j, i) = 273. + x_anom_sst(pplus)
-            END IF
-          ELSE
-            p = p + 1
-            pplus = 73 - p
-            phy_sst(j, i) = 273. + x_anom_sst(pplus) + &
-              0.5*27.*(2-sin(1.5*rlatd(j))**2-sin(1.5*rlatd(j))**4)
-            IF ((rlatd(j)>1.0471975) .OR. (rlatd(j)<-1.0471975)) THEN
-              phy_sst(j, i) = 273. + x_anom_sst(pplus)
-            END IF
-            WRITE (*, *) rlatd(j), x_anom_sst(pplus), phy_sst(j, i)
-          END IF
-        END DO
-      END IF
-
-      IF (type_profil==9) THEN
-        ! Méthode 5 : Méthode 3 + -2K "Qobs" plateau réel à l'Equateur
-        DO j = 1, klon
-          phy_sst(j, i) = 273. - 2. + 0.5*27.*(2-sin(1.5*rlatd(j))**2-sin(1.5 &
-            *rlatd(j))**4)
-          IF ((rlatd(j)>1.0471975) .OR. (rlatd(j)<-1.0471975)) THEN
-            phy_sst(j, i) = 273. - 2.
-          END IF
-        END DO
-      END IF
-
-
-      IF (type_profil==10) THEN
-        ! Méthode 10 : Méthode 3 + +4K "Qobs" plateau réel à l'Equateur
-        DO j = 1, klon
-          phy_sst(j, i) = 273. + 4. + 0.5*27.*(2-sin(1.5*rlatd(j))**2-sin(1.5 &
-            *rlatd(j))**4)
-          IF ((rlatd(j)>1.0471975) .OR. (rlatd(j)<-1.0471975)) THEN
-            phy_sst(j, i) = 273. + 4.
-          END IF
-        END DO
-      END IF
-
-      IF (type_profil==11) THEN
-        ! Méthode 11 : Méthode 3 + 4CO2 "Qobs" plateau réel à l'Equateur
-        DO j = 1, klon
-          phy_sst(j, i) = 273. + 0.5*27.*(2-sin(1.5*rlatd(j))**2-sin(1.5* &
-            rlatd(j))**4)
-          IF ((rlatd(j)>1.0471975) .OR. (rlatd(j)<-1.0471975)) THEN
-            phy_sst(j, i) = 273.
-          END IF
-        END DO
-      END IF
-
-      IF (type_profil==12) THEN
-        ! Méthode 12 : Méthode 10 + 4CO2 "Qobs" plateau réel à l'Equateur
-        DO j = 1, klon
-          phy_sst(j, i) = 273. + 4. + 0.5*27.*(2-sin(1.5*rlatd(j))**2-sin(1.5 &
-            *rlatd(j))**4)
-          IF ((rlatd(j)>1.0471975) .OR. (rlatd(j)<-1.0471975)) THEN
-            phy_sst(j, i) = 273. + 4.
-          END IF
-        END DO
-      END IF
-
-      IF (type_profil==13) THEN
-        ! Méthode 13 "Qmax" plateau réel à l'Equateur augmenté !
-        DO j = 1, klon
-          phy_sst(j, i) = 273. + 0.5*29.*(2-sin(1.5*rlatd(j))**2-sin(1.5* &
-            rlatd(j))**4)
-          IF ((rlatd(j)>1.0471975) .OR. (rlatd(j)<-1.0471975)) THEN
-            phy_sst(j, i) = 273.
-          END IF
-        END DO
-      END IF
-
-      IF (type_profil==14) THEN
-        ! Méthode 13 "Qmax2K" plateau réel à l'Equateur augmenté +2K !
-        DO j = 1, klon
-          phy_sst(j, i) = 273. + 2. + 0.5*29.*(2-sin(1.5*rlatd(j))**2-sin(1.5 &
-            *rlatd(j))**4)
-          IF ((rlatd(j)>1.0471975) .OR. (rlatd(j)<-1.0471975)) THEN
-            phy_sst(j, i) = 273.
-          END IF
-        END DO
-      END IF
-
-      if (type_profil.EQ.20) then
-      print*,'Profile SST 20'
-!     Méthode 13 "Qmax2K" plateau réel �|  l'Equateur augmenté +2K
-
-      do j=1,klon
-        phy_sst(j,i)=248.+55.*(1-sin(rlatd(j))**2)
-      enddo
-      endif
-
-      if (type_profil.EQ.21) then
-      print*,'Profile SST 21'
-!     Méthode 13 "Qmax2K" plateau réel �|  l'Equateur augmenté +2K
-      do j=1,klon
-        phy_sst(j,i)=252.+55.*(1-sin(rlatd(j))**2)
-      enddo
-      endif
-
-
-
-    END DO
-
-    ! IM beg : verif profil SST: phy_sst
-    amn = min(phy_sst(1,1), 1000.)
-    amx = max(phy_sst(1,1), -1000.)
-    imn = 1
-    kmn = 1
-    imx = 1
-    kmx = 1
-    DO k = 1, year_len
-      DO i = 2, nlon
-        IF (phy_sst(i,k)<amn) THEN
-          amn = phy_sst(i, k)
-          imn = i
-          kmn = k
-        END IF
-        IF (phy_sst(i,k)>amx) THEN
-          amx = phy_sst(i, k)
-          imx = i
-          kmx = k
-        END IF
-      END DO
-    END DO
-
-    PRINT *, 'profil_sst: imn, kmn, phy_sst(imn,kmn) ', imn, kmn, amn
-    PRINT *, 'profil_sst: imx, kmx, phy_sst(imx,kmx) ', imx, kmx, amx
-    ! IM end : verif profil SST: phy_sst
-
-    RETURN
-  END SUBROUTINE profil_sst
-
-END MODULE phyaqua_mod
Index: /LMDZ6/trunk/libf/phylmd/phyaqua_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/phyaqua_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/phyaqua_mod.f90	(revision 5268)
@@ -0,0 +1,993 @@
+!
+! $Id$
+!
+MODULE phyaqua_mod
+  ! Routines complementaires pour la physique planetaire.
+  IMPLICIT NONE
+
+CONTAINS
+
+  SUBROUTINE iniaqua(nlon,year_len,iflag_phys)
+
+    ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+    ! Creation d'un etat initial et de conditions aux limites
+    ! (resp startphy.nc et limit.nc) pour des configurations idealisees
+    ! du modele LMDZ dans sa version terrestre.
+    ! iflag_phys est un parametre qui controle
+    ! iflag_phys = N
+    ! de 100 a 199 : aqua planetes avec SST forcees
+    ! N-100 determine le type de SSTs
+    ! de 200 a 299 : terra planetes avec Ts calcule
+
+    ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+    USE dimphy, ONLY: klon
+    USE geometry_mod, ONLY : latitude
+    USE surface_data, ONLY: type_ocean, ok_veget
+    USE pbl_surface_mod, ONLY: pbl_surface_init
+    USE fonte_neige_mod, ONLY: fonte_neige_init
+    USE phys_state_var_mod
+    USE time_phylmdz_mod, ONLY: day_ref, ndays, pdtphys, &
+                                day_ini,day_end
+    USE indice_sol_mod
+    USE nrtype, ONLY: pi
+!    USE ioipsl
+    USE mod_phys_lmdz_para, ONLY: is_master
+    USE mod_phys_lmdz_transfert_para, ONLY: bcast
+    USE mod_grid_phy_lmdz
+    USE ioipsl_getin_p_mod, ONLY : getin_p
+    USE phys_cal_mod , ONLY: calend, year_len_phy => year_len 
+    IMPLICIT NONE
+
+    include "YOMCST.h"
+    include "clesphys.h"
+    include "dimsoil.h"
+
+    INTEGER, INTENT (IN) :: nlon, year_len, iflag_phys
+    ! IM ajout latfi, lonfi
+!    REAL, INTENT (IN) :: lonfi(nlon), latfi(nlon)
+
+    INTEGER type_profil, type_aqua
+
+    ! Ajouts initialisation des surfaces
+    REAL :: run_off_lic_0(nlon)
+    REAL :: qsolsrf(nlon, nbsrf), snsrf(nlon, nbsrf)
+    REAL :: tsoil(nlon, nsoilmx, nbsrf)
+    REAL :: tslab(nlon), seaice(nlon)
+    REAL fder(nlon)
+
+
+
+    ! Arguments :
+    ! -----------
+
+    ! integer radpas
+    INTEGER it, unit, i, k, itap
+
+    REAL rugos, albedo
+    REAL tsurf
+    REAL time, timestep, day, day0
+    REAL qsol_f
+    REAL rugsrel(nlon)
+    LOGICAL alb_ocean
+
+    CHARACTER *80 ans, file_forctl, file_fordat, file_start
+    CHARACTER *100 file, var
+    CHARACTER *2 cnbl
+
+    REAL phy_nat(nlon, year_len)
+    REAL phy_alb(nlon, year_len)
+    REAL phy_sst(nlon, year_len)
+    REAL phy_bil(nlon, year_len)
+    REAL phy_rug(nlon, year_len)
+    REAL phy_ice(nlon, year_len)
+    REAL phy_fter(nlon, year_len)
+    REAL phy_foce(nlon, year_len)
+    REAL phy_fsic(nlon, year_len)
+    REAL phy_flic(nlon, year_len)
+
+    INTEGER, SAVE :: read_climoz = 0 ! read ozone climatology
+!$OMP THREADPRIVATE(read_climoz)
+
+    ! -------------------------------------------------------------------------
+    ! declaration pour l'appel a phyredem
+    ! -------------------------------------------------------------------------
+
+    ! real pctsrf(nlon,nbsrf),ftsol(nlon,nbsrf)
+    REAL falbe(nlon, nbsrf), falblw(nlon, nbsrf)
+    ! real pbl_tke(nlon,llm,nbsrf)
+    ! real rain_fall(nlon),snow_fall(nlon)
+    ! real solsw(nlon), sollw(nlon),radsol(nlon)
+    ! real t_ancien(nlon,llm),q_ancien(nlon,llm),rnebcon(nlon,llm)
+    ! real ratqs(nlon,llm)
+    ! real clwcon(nlon,llm)
+
+    INTEGER longcles
+    PARAMETER (longcles=20)
+    REAL clesphy0(longcles)
+
+
+    ! -----------------------------------------------------------------------
+    ! dynamial tendencies :
+    ! ---------------------
+
+    INTEGER l, ierr, aslun
+
+    REAL paire
+
+    ! Local
+    CHARACTER (LEN=20) :: modname='phyaqua'
+    CHARACTER (LEN=80) :: abort_message
+
+
+    ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+    ! INITIALISATIONS
+    ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+    ! -----------------------------------------------------------------------
+    ! Initialisations  des constantes
+    ! -------------------------------
+
+    !IF (calend .EQ. "earth_360d") Then
+      year_len_phy = year_len
+    !END IF
+    
+    if (year_len.ne.360) then
+      write (*,*) year_len
+      call abort_physic("iniaqua", 'iniaqua: 360 day calendar is required !', 1)
+    endif
+
+    type_aqua = iflag_phys/100
+    type_profil = iflag_phys - type_aqua*100
+    PRINT *, 'iniaqua:type_aqua, type_profil', type_aqua, type_profil
+
+    IF (klon/=nlon) THEN
+      WRITE (*, *) 'iniaqua: klon=', klon, ' nlon=', nlon
+      abort_message= 'probleme de dimensions dans iniaqua'
+      CALL abort_physic(modname,abort_message,1)
+    END IF
+    CALL phys_state_var_init(read_climoz)
+
+
+    read_climoz = 0
+    day0 = 217.
+    day = day0
+    it = 0
+    time = 0.
+
+    ! -----------------------------------------------------------------------
+    ! initialisations de la physique
+    ! -----------------------------------------------------------------------
+
+    day_ini = day_ref
+    day_end = day_ini + ndays
+
+    nbapp_rad = 24
+    CALL getin_p('nbapp_rad', nbapp_rad)
+
+    ! ---------------------------------------------------------------------
+    ! Creation des conditions aux limites:
+    ! ------------------------------------
+    ! Initialisations des constantes
+    ! Ajouter les manquants dans planete.def... (albedo etc)
+    co2_ppm = 348.
+    CALL getin_p('co2_ppm', co2_ppm)
+
+    solaire = 1365.
+    CALL getin_p('solaire', solaire)
+ 
+    ! CALL getin('albedo',albedo) ! albedo is set below, depending on
+    ! type_aqua
+    alb_ocean = .TRUE.
+    CALL getin_p('alb_ocean', alb_ocean)
+
+    WRITE (*, *) 'iniaqua: co2_ppm=', co2_ppm
+    WRITE (*, *) 'iniaqua: solaire=', solaire
+    WRITE (*, *) 'iniaqua: alb_ocean=', alb_ocean
+
+    radsol = 0.
+    qsol_f = 10.
+
+    ! Conditions aux limites:
+    ! -----------------------
+
+    qsol(:) = qsol_f
+    rugsrel = 0.0 ! (rugsrel = rugoro)
+    rugoro = 0.0
+    u_ancien = 0.0
+    v_ancien = 0.0
+    agesno = 50.0
+    ! Relief plat
+    zmea = 0.
+    zstd = 0.
+    zsig = 0.
+    zgam = 0.
+    zthe = 0.
+    zpic = 0.
+    zval = 0.
+
+    ! Une seule surface
+    pctsrf = 0.
+    IF (type_aqua==1) THEN
+      rugos = 1.E-4
+      albedo = 0.19
+      pctsrf(:, is_oce) = 1.
+    ELSE IF (type_aqua==2) THEN
+      rugos = 0.03
+      albedo = 0.1
+      pctsrf(:, is_ter) = 1.
+    END IF
+
+    CALL getin_p('rugos', rugos)
+
+    WRITE (*, *) 'iniaqua: rugos=', rugos
+    zmasq(:) = pctsrf(:, is_ter)
+
+    ! pctsrf_pot(:,is_oce) = 1. - zmasq(:)
+    ! pctsrf_pot(:,is_sic) = 1. - zmasq(:)
+
+    ! Si alb_ocean on calcule un albedo oceanique moyen
+    ! if (alb_ocean) then
+    ! Voir pourquoi on avait ca.
+    ! CALL ini_alb_oce(phy_alb)
+    ! else
+    phy_alb(:, :) = albedo ! albedo land only (old value condsurf_jyg=0.3)
+    ! endif !alb_ocean
+
+    DO i = 1, year_len
+      ! IM Terraplanete   phy_sst(:,i) = 260.+50.*cos(rlatd(:))**2
+      ! IM ajout calcul profil sst selon le cas considere (cf. FBr)
+
+      phy_nat(:, i) = 1.0 ! 0=ocean libre, 1=land, 2=glacier, 3=banquise
+      phy_bil(:, i) = 1.0 ! ne sert que pour les slab_ocean
+      phy_rug(:, i) = rugos ! longueur rugosite utilisee sur land only
+      phy_ice(:, i) = 0.0 ! fraction de glace (?)
+      phy_fter(:, i) = pctsrf(:, is_ter) ! fraction de glace (?)
+      phy_foce(:, i) = pctsrf(:, is_oce) ! fraction de glace (?)
+      phy_fsic(:, i) = pctsrf(:, is_sic) ! fraction de glace (?)
+      phy_flic(:, i) = pctsrf(:, is_lic) ! fraction de glace (?)
+    END DO
+    ! IM calcul profil sst
+    CALL profil_sst(nlon, latitude, type_profil, phy_sst)
+
+    IF (grid_type==unstructured) THEN
+      CALL writelim_unstruct(klon, phy_nat, phy_alb, phy_sst, phy_bil, phy_rug, phy_ice, &
+                             phy_fter, phy_foce, phy_flic, phy_fsic)
+    ELSE
+      
+       CALL writelim(klon, phy_nat, phy_alb, phy_sst, phy_bil, phy_rug, phy_ice, &
+                     phy_fter, phy_foce, phy_flic, phy_fsic)
+    ENDIF
+
+    ! ---------------------------------------------------------------------
+    ! Ecriture de l'etat initial:
+    ! ---------------------------
+
+
+    ! Ecriture etat initial physique
+
+    timestep = pdtphys
+    radpas = nint(rday/timestep/float(nbapp_rad))
+
+    DO i = 1, longcles
+      clesphy0(i) = 0.
+    END DO
+    clesphy0(1) = float(iflag_con)
+    clesphy0(2) = float(nbapp_rad)
+    ! IF( cycle_diurne  ) clesphy0(3) =  1.
+    clesphy0(3) = 1. ! cycle_diurne
+    clesphy0(4) = 1. ! soil_model
+    clesphy0(5) = 1. ! new_oliq
+    clesphy0(6) = 0. ! ok_orodr
+    clesphy0(7) = 0. ! ok_orolf
+    clesphy0(8) = 0. ! ok_limitvrai
+
+
+    ! =======================================================================
+    ! Profils initiaux
+    ! =======================================================================
+
+    ! On initialise les temperatures de surfaces comme les sst
+    DO i = 1, nlon
+      ftsol(i, :) = phy_sst(i, 1)
+      tsoil(i, :, :) = phy_sst(i, 1)
+      tslab(i) = phy_sst(i, 1)
+    END DO
+
+    falbe(:, :) = albedo
+    falblw(:, :) = albedo
+    rain_fall(:) = 0.
+    snow_fall(:) = 0.
+    solsw(:) = 0.
+    sollw(:) = 0.
+    radsol(:) = 0.
+
+    ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+    ! intialisation bidon mais pas grave
+    t_ancien(:, :) = 0.
+    q_ancien(:, :) = 0.
+    ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+    rnebcon = 0.
+    ratqs = 0.
+    clwcon = 0.
+    pbl_tke = 1.E-8
+
+    ! variables supplementaires pour appel a plb_surface_init
+    fder(:) = 0.
+    seaice(:) = 0.
+    run_off_lic_0 = 0.
+    fevap = 0.
+
+
+    ! Initialisations necessaires avant phyredem
+    type_ocean = 'force'
+    CALL fonte_neige_init(run_off_lic_0)
+    qsolsrf(:, :) = qsol(1) ! humidite du sol des sous surface
+    snsrf(:, :) = 0. ! couverture de neige des sous surface
+    z0m(:, :) = rugos ! couverture de neige des sous surface
+    z0h=z0m
+
+
+    CALL pbl_surface_init(fder, snsrf, qsolsrf, tsoil)
+
+    PRINT *, 'iniaqua: before phyredem'
+
+    pbl_tke(:,:,:) = 1.e-8 
+    falb1 = albedo
+    falb2 = albedo
+    zmax0 = 0.
+    f0 = 0.
+    sig1 = 0.
+    w01 = 0.
+    wake_deltat = 0.
+    wake_deltaq = 0.
+    wake_s = 0.
+    wake_dens = 0.
+    wake_cstar = 0.
+    wake_pe = 0.
+    wake_fip = 0.
+    fm_therm = 0.
+    entr_therm = 0.
+    detr_therm = 0.
+    ale_bl = 0.
+    ale_bl_trig =0. 
+    alp_bl =0.
+    treedrg(:,:,:)=0.
+
+    u10m = 0.
+    v10m = 0.
+
+    ql_ancien   = 0.
+    qs_ancien   = 0.
+    qbs_ancien  = 0.
+    u_ancien    = 0.
+    v_ancien    = 0.
+    prw_ancien  = 0.
+    prlw_ancien = 0.
+    prsw_ancien = 0.  
+    prbsw_ancien= 0.
+
+    ale_wake    = 0.
+    ale_bl_stat = 0.  
+
+
+!ym error : the sub surface dimension is the third not second : forgotten for iniaqua
+!    falb_dir(:,is_ter,:)=0.08; falb_dir(:,is_lic,:)=0.6
+!    falb_dir(:,is_oce,:)=0.5;  falb_dir(:,is_sic,:)=0.6
+    falb_dir(:,:,is_ter)=0.08; falb_dir(:,:,is_lic)=0.6
+    falb_dir(:,:,is_oce)=0.5;  falb_dir(:,:,is_sic)=0.6
+
+!ym falb_dif has been forgotten, initialize with defaukt value found in phyetat0 or 0 ?
+!ym probably the uninitialized value was 0 for standard (regular grid) case
+    falb_dif(:,:,:)=0
+
+
+    CALL phyredem('startphy.nc')
+
+    PRINT *, 'iniaqua: after phyredem'
+    CALL phys_state_var_end
+
+    RETURN
+  END SUBROUTINE iniaqua
+
+
+  ! ====================================================================
+  ! ====================================================================
+  SUBROUTINE zenang_an(cycle_diurne, gmtime, rlat, rlon, rmu0, fract)
+    USE dimphy
+    IMPLICIT NONE
+    ! ====================================================================
+    ! =============================================================
+    ! CALL zenang(cycle_diurne,gmtime,rlat,rlon,rmu0,fract)
+    ! Auteur : A. Campoy et F. Hourdin
+    ! Objet  : calculer les valeurs moyennes du cos de l'angle zenithal
+    ! et l'ensoleillement moyen entre gmtime1 et gmtime2
+    ! connaissant la declinaison, la latitude et la longitude.
+
+    ! Dans cette version particuliere, on calcule le rayonnement
+    ! moyen sur l'année à chaque latitude.
+    ! angle zenithal calculé pour obtenir un
+    ! Fit polynomial de  l'ensoleillement moyen au sommet de l'atmosphere
+    ! en moyenne annuelle.
+    ! Spécifique de la terre. Utilisé pour les aqua planetes.
+
+    ! Rque   : Different de la routine angle en ce sens que zenang
+    ! fournit des moyennes de pmu0 et non des valeurs
+    ! instantanees, du coup frac prend toutes les valeurs
+    ! entre 0 et 1.
+    ! Date   : premiere version le 13 decembre 1994
+    ! revu pour  GCM  le 30 septembre 1996
+    ! ===============================================================
+    ! longi----INPUT : la longitude vraie de la terre dans son plan
+    ! solaire a partir de l'equinoxe de printemps (degre)
+    ! gmtime---INPUT : temps universel en fraction de jour
+    ! pdtrad---INPUT : pas de temps du rayonnement (secondes)
+    ! lat------INPUT : latitude en degres
+    ! long-----INPUT : longitude en degres
+    ! pmu0-----OUTPUT: angle zenithal moyen entre gmtime et gmtime+pdtrad
+    ! frac-----OUTPUT: ensoleillement moyen entre gmtime et gmtime+pdtrad
+    ! ================================================================
+    include "YOMCST.h"
+    ! ================================================================
+    LOGICAL cycle_diurne
+    REAL gmtime
+    REAL rlat(klon), rlon(klon), rmu0(klon), fract(klon)
+    ! ================================================================
+    INTEGER i
+    REAL gmtime1, gmtime2
+    REAL pi_local
+
+
+    REAL rmu0m(klon), rmu0a(klon)
+
+
+    pi_local = 4.0*atan(1.0)
+
+    ! ================================================================
+    ! Calcul de l'angle zenithal moyen sur la journee
+    ! ================================================================
+
+    DO i = 1, klon
+      fract(i) = 1.
+      ! Calcule du flux moyen
+      IF (abs(rlat(i))<=28.75) THEN
+        rmu0m(i) = (210.1924+206.6059*cos(0.0174533*rlat(i))**2)/1365.
+      ELSE IF (abs(rlat(i))<=43.75) THEN
+        rmu0m(i) = (187.4562+236.1853*cos(0.0174533*rlat(i))**2)/1365.
+      ELSE IF (abs(rlat(i))<=71.25) THEN
+        rmu0m(i) = (162.4439+284.1192*cos(0.0174533*rlat(i))**2)/1365.
+      ELSE
+        rmu0m(i) = (172.8125+183.7673*cos(0.0174533*rlat(i))**2)/1365.
+      END IF
+    END DO
+
+    ! ================================================================
+    ! Avec ou sans cycle diurne
+    ! ================================================================
+
+    IF (cycle_diurne) THEN
+
+      ! On redecompose flux  au sommet suivant un cycle diurne idealise
+      ! identique a toutes les latitudes.
+
+      DO i = 1, klon
+        rmu0a(i) = 2.*rmu0m(i)*sqrt(2.)*pi_local/(4.-pi_local)
+        rmu0(i) = rmu0a(i)*abs(sin(pi_local*gmtime+pi_local*rlon(i)/360.)) - &
+          rmu0a(i)/sqrt(2.)
+      END DO
+
+      DO i = 1, klon
+        IF (rmu0(i)<=0.) THEN
+          rmu0(i) = 0.
+          fract(i) = 0.
+        ELSE
+          fract(i) = 1.
+        END IF
+      END DO
+
+      ! Affichage de l'angel zenitale
+      ! print*,'************************************'
+      ! print*,'************************************'
+      ! print*,'************************************'
+      ! print*,'latitude=',rlat(i),'longitude=',rlon(i)
+      ! print*,'rmu0m=',rmu0m(i)
+      ! print*,'rmu0a=',rmu0a(i)
+      ! print*,'rmu0=',rmu0(i)
+
+    ELSE
+
+      DO i = 1, klon
+        fract(i) = 0.5
+        rmu0(i) = rmu0m(i)*2.
+      END DO
+
+    END IF
+
+    RETURN
+  END SUBROUTINE zenang_an
+
+  ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+  SUBROUTINE writelim_unstruct(klon, phy_nat, phy_alb, phy_sst, phy_bil, phy_rug, &
+      phy_ice, phy_fter, phy_foce, phy_flic, phy_fsic)
+
+    USE mod_phys_lmdz_para, ONLY: is_omp_master, klon_mpi
+    USE mod_phys_lmdz_transfert_para, ONLY: gather_omp
+    USE lmdz_xios
+    IMPLICIT NONE
+
+    include "netcdf.inc"
+
+    INTEGER, INTENT (IN) :: klon
+    REAL, INTENT (IN) :: phy_nat(klon, 360)
+    REAL, INTENT (IN) :: phy_alb(klon, 360)
+    REAL, INTENT (IN) :: phy_sst(klon, 360)
+    REAL, INTENT (IN) :: phy_bil(klon, 360)
+    REAL, INTENT (IN) :: phy_rug(klon, 360)
+    REAL, INTENT (IN) :: phy_ice(klon, 360)
+    REAL, INTENT (IN) :: phy_fter(klon, 360)
+    REAL, INTENT (IN) :: phy_foce(klon, 360)
+    REAL, INTENT (IN) :: phy_flic(klon, 360)
+    REAL, INTENT (IN) :: phy_fsic(klon, 360)
+
+    REAL :: phy_mpi(klon_mpi, 360) ! temporary variable, to store phy_***(:)
+      ! on the whole physics grid
+ 
+    IF (using_xios) THEN
+      PRINT *, 'writelim: Ecriture du fichier limit'
+
+      CALL gather_omp(phy_foce, phy_mpi)
+      IF (is_omp_master) CALL xios_send_field('foce_limout',phy_mpi)
+
+      CALL gather_omp(phy_fsic, phy_mpi)
+      IF (is_omp_master) CALL xios_send_field('fsic_limout',phy_mpi)
+      
+      CALL gather_omp(phy_fter, phy_mpi)
+      IF (is_omp_master) CALL xios_send_field('fter_limout',phy_mpi)
+      
+      CALL gather_omp(phy_flic, phy_mpi)
+      IF (is_omp_master) CALL xios_send_field('flic_limout',phy_mpi)
+
+      CALL gather_omp(phy_sst, phy_mpi)
+      IF (is_omp_master) CALL xios_send_field('sst_limout',phy_mpi)
+
+      CALL gather_omp(phy_bil, phy_mpi)
+      IF (is_omp_master) CALL xios_send_field('bils_limout',phy_mpi)
+
+      CALL gather_omp(phy_alb, phy_mpi)
+      IF (is_omp_master) CALL xios_send_field('alb_limout',phy_mpi)
+
+      CALL gather_omp(phy_rug, phy_mpi)
+      IF (is_omp_master) CALL xios_send_field('rug_limout',phy_mpi)
+    ENDIF
+  END SUBROUTINE writelim_unstruct
+
+
+
+  SUBROUTINE writelim(klon, phy_nat, phy_alb, phy_sst, phy_bil, phy_rug, &
+      phy_ice, phy_fter, phy_foce, phy_flic, phy_fsic)
+
+    USE mod_phys_lmdz_para, ONLY: is_master
+    USE mod_grid_phy_lmdz, ONLY: klon_glo
+    USE mod_phys_lmdz_transfert_para, ONLY: gather
+    USE phys_cal_mod, ONLY: year_len
+    use netcdf, only: nf90_def_var, nf90_double, nf90_float, nf90_put_var
+    USE lmdz_cppkeys_wrapper, ONLY: nf90_format
+    IMPLICIT NONE
+    include "netcdf.inc"
+
+    INTEGER, INTENT (IN) :: klon
+    REAL, INTENT (IN) :: phy_nat(klon, year_len)
+    REAL, INTENT (IN) :: phy_alb(klon, year_len)
+    REAL, INTENT (IN) :: phy_sst(klon, year_len)
+    REAL, INTENT (IN) :: phy_bil(klon, year_len)
+    REAL, INTENT (IN) :: phy_rug(klon, year_len)
+    REAL, INTENT (IN) :: phy_ice(klon, year_len)
+    REAL, INTENT (IN) :: phy_fter(klon, year_len)
+    REAL, INTENT (IN) :: phy_foce(klon, year_len)
+    REAL, INTENT (IN) :: phy_flic(klon, year_len)
+    REAL, INTENT (IN) :: phy_fsic(klon, year_len)
+
+    REAL :: phy_glo(klon_glo, year_len) ! temporary variable, to store phy_***(:)
+      ! on the whole physics grid
+    INTEGER :: k
+    INTEGER ierr
+    INTEGER dimfirst(3)
+    INTEGER dimlast(3)
+
+    INTEGER nid, ndim, ntim
+    INTEGER dims(2), debut(2), epais(2)
+    INTEGER id_tim
+    INTEGER id_nat, id_sst, id_bils, id_rug, id_alb
+    INTEGER id_fter, id_foce, id_fsic, id_flic
+
+    IF (is_master) THEN
+
+      PRINT *, 'writelim: Ecriture du fichier limit'
+
+      ierr = nf_create('limit.nc', IOR(NF_CLOBBER,NF_64BIT_OFFSET), nid)
+
+      ierr = nf_put_att_text(nid, nf_global, 'title', 30, &
+        'Fichier conditions aux limites')
+      ! !        ierr = NF_DEF_DIM (nid, "points_physiques", klon, ndim)
+      ierr = nf_def_dim(nid, 'points_physiques', klon_glo, ndim)
+      ierr = nf_def_dim(nid, 'time', nf_unlimited, ntim)
+
+      dims(1) = ndim
+      dims(2) = ntim
+
+      ierr = nf90_def_var(nid, 'TEMPS', nf90_format, [ntim], id_tim)
+      ierr = nf_put_att_text(nid, id_tim, 'title', 17, 'Jour dans l annee')
+
+      ierr = nf90_def_var(nid, 'NAT', nf90_format, dims, id_nat)
+      ierr = nf_put_att_text(nid, id_nat, 'title', 23, &
+        'Nature du sol (0,1,2,3)')
+
+      ierr = nf90_def_var(nid, 'SST', nf90_format, dims, id_sst)
+      ierr = nf_put_att_text(nid, id_sst, 'title', 35, &
+        'Temperature superficielle de la mer')
+
+      ierr = nf90_def_var(nid, 'BILS', nf90_format, dims, id_bils)
+      ierr = nf_put_att_text(nid, id_bils, 'title', 32, &
+        'Reference flux de chaleur au sol')
+
+      ierr = nf90_def_var(nid, 'ALB', nf90_format, dims, id_alb)
+      ierr = nf_put_att_text(nid, id_alb, 'title', 19, 'Albedo a la surface')
+
+      ierr = nf90_def_var(nid, 'RUG', nf90_format, dims, id_rug)
+      ierr = nf_put_att_text(nid, id_rug, 'title', 8, 'Rugosite')
+
+      ierr = nf90_def_var(nid, 'FTER', nf90_format, dims, id_fter)
+      ierr = nf_put_att_text(nid, id_fter, 'title',10,'Frac. Land')
+      ierr = nf90_def_var(nid, 'FOCE', nf90_format, dims, id_foce)
+      ierr = nf_put_att_text(nid, id_foce, 'title',11,'Frac. Ocean')
+      ierr = nf90_def_var(nid, 'FSIC', nf90_format, dims, id_fsic)
+      ierr = nf_put_att_text(nid, id_fsic, 'title',13,'Frac. Sea Ice')
+      ierr = nf90_def_var(nid, 'FLIC', nf90_format, dims, id_flic)
+      ierr = nf_put_att_text(nid, id_flic, 'title',14,'Frac. Land Ice')
+
+      ierr = nf_enddef(nid)
+      IF (ierr/=nf_noerr) THEN
+        WRITE (*, *) 'writelim error: failed to end define mode'
+        WRITE (*, *) nf_strerror(ierr)
+      END IF
+
+
+      ! write the 'times'
+      DO k = 1, year_len
+        ierr = nf90_put_var(nid, id_tim, k, [k])
+        IF (ierr/=nf_noerr) THEN
+          WRITE (*, *) 'writelim error with temps(k),k=', k
+          WRITE (*, *) nf_strerror(ierr)
+        END IF
+      END DO
+
+    END IF ! of if (is_master)
+
+    ! write the fields, after having collected them on master
+
+    CALL gather(phy_nat, phy_glo)
+    IF (is_master) THEN
+      ierr = nf90_put_var(nid, id_nat, phy_glo)
+      IF (ierr/=nf_noerr) THEN
+        WRITE (*, *) 'writelim error with phy_nat'
+        WRITE (*, *) nf_strerror(ierr)
+      END IF
+    END IF
+
+    CALL gather(phy_sst, phy_glo)
+    IF (is_master) THEN
+      ierr = nf90_put_var(nid, id_sst, phy_glo)
+      IF (ierr/=nf_noerr) THEN
+        WRITE (*, *) 'writelim error with phy_sst'
+        WRITE (*, *) nf_strerror(ierr)
+      END IF
+    END IF
+
+    CALL gather(phy_bil, phy_glo)
+    IF (is_master) THEN
+      ierr = nf90_put_var(nid, id_bils, phy_glo)
+      IF (ierr/=nf_noerr) THEN
+        WRITE (*, *) 'writelim error with phy_bil'
+        WRITE (*, *) nf_strerror(ierr)
+      END IF
+    END IF
+
+    CALL gather(phy_alb, phy_glo)
+    IF (is_master) THEN
+      ierr = nf90_put_var(nid, id_alb, phy_glo)
+      IF (ierr/=nf_noerr) THEN
+        WRITE (*, *) 'writelim error with phy_alb'
+        WRITE (*, *) nf_strerror(ierr)
+      END IF
+    END IF
+
+    CALL gather(phy_rug, phy_glo)
+    IF (is_master) THEN
+      ierr = nf90_put_var(nid, id_rug, phy_glo)
+      IF (ierr/=nf_noerr) THEN
+        WRITE (*, *) 'writelim error with phy_rug'
+        WRITE (*, *) nf_strerror(ierr)
+      END IF
+    END IF
+
+    CALL gather(phy_fter, phy_glo)
+    IF (is_master) THEN
+      ierr = nf90_put_var(nid, id_fter, phy_glo)
+      IF (ierr/=nf_noerr) THEN
+        WRITE (*, *) 'writelim error with phy_fter'
+        WRITE (*, *) nf_strerror(ierr)
+      END IF
+    END IF
+
+    CALL gather(phy_foce, phy_glo)
+    IF (is_master) THEN
+      ierr = nf90_put_var(nid, id_foce, phy_glo)
+      IF (ierr/=nf_noerr) THEN
+        WRITE (*, *) 'writelim error with phy_foce'
+        WRITE (*, *) nf_strerror(ierr)
+      END IF
+    END IF
+
+    CALL gather(phy_fsic, phy_glo)
+    IF (is_master) THEN
+      ierr = nf90_put_var(nid, id_fsic, phy_glo)
+      IF (ierr/=nf_noerr) THEN
+        WRITE (*, *) 'writelim error with phy_fsic'
+        WRITE (*, *) nf_strerror(ierr)
+      END IF
+    END IF
+
+    CALL gather(phy_flic, phy_glo)
+    IF (is_master) THEN
+      ierr = nf90_put_var(nid, id_flic, phy_glo)
+      IF (ierr/=nf_noerr) THEN
+        WRITE (*, *) 'writelim error with phy_flic'
+        WRITE (*, *) nf_strerror(ierr)
+      END IF
+    END IF
+
+    ! close file:
+    IF (is_master) THEN
+      ierr = nf_close(nid)
+    END IF
+
+  END SUBROUTINE writelim
+
+  ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+  SUBROUTINE profil_sst(nlon, rlatd, type_profil, phy_sst)
+    USE dimphy
+    USE phys_cal_mod , ONLY: year_len
+    IMPLICIT NONE
+
+    INTEGER nlon, type_profil, i, k, j
+    REAL :: rlatd(nlon), phy_sst(nlon, year_len)
+    INTEGER imn, imx, amn, amx, kmn, kmx
+    INTEGER p, pplus, nlat_max
+    PARAMETER (nlat_max=72)
+    REAL x_anom_sst(nlat_max)
+    CHARACTER (LEN=20) :: modname='profil_sst'
+    CHARACTER (LEN=80) :: abort_message
+
+    IF (klon/=nlon) THEN
+       abort_message='probleme de dimensions dans profil_sst'
+       CALL abort_physic(modname,abort_message,1)
+    ENDIF
+    WRITE (*, *) ' profil_sst: type_profil=', type_profil
+    DO i = 1, year_len
+      ! phy_sst(:,i) = 260.+50.*cos(rlatd(:))**2
+
+      ! Rajout fbrlmd
+
+      IF (type_profil==1) THEN
+        ! Méthode 1 "Control" faible plateau à l'Equateur
+        DO j = 1, klon
+          phy_sst(j, i) = 273. + 27.*(1-sin(1.5*rlatd(j))**2)
+          ! PI/3=1.047197551
+          IF ((rlatd(j)>1.0471975) .OR. (rlatd(j)<-1.0471975)) THEN
+            phy_sst(j, i) = 273.
+          END IF
+        END DO
+      END IF
+      IF (type_profil==2) THEN
+        ! Méthode 2 "Flat" fort plateau à l'Equateur
+        DO j = 1, klon
+          phy_sst(j, i) = 273. + 27.*(1-sin(1.5*rlatd(j))**4)
+          IF ((rlatd(j)>1.0471975) .OR. (rlatd(j)<-1.0471975)) THEN
+            phy_sst(j, i) = 273.
+          END IF
+        END DO
+      END IF
+
+
+      IF (type_profil==3) THEN
+        ! Méthode 3 "Qobs" plateau réel à l'Equateur
+        DO j = 1, klon
+          phy_sst(j, i) = 273. + 0.5*27.*(2-sin(1.5*rlatd(j))**2-sin(1.5* &
+            rlatd(j))**4)
+          IF ((rlatd(j)>1.0471975) .OR. (rlatd(j)<-1.0471975)) THEN
+            phy_sst(j, i) = 273.
+          END IF
+        END DO
+      END IF
+
+      IF (type_profil==4) THEN
+        ! Méthode 4 : Méthode 3 + SST+2 "Qobs" plateau réel à l'Equateur
+        DO j = 1, klon
+          phy_sst(j, i) = 273. + 0.5*29.*(2-sin(1.5*rlatd(j))**2-sin(1.5* &
+            rlatd(j))**4)
+          IF ((rlatd(j)>1.0471975) .OR. (rlatd(j)<-1.0471975)) THEN
+            phy_sst(j, i) = 273.
+          END IF
+        END DO
+      END IF
+
+      IF (type_profil==5) THEN
+        ! Méthode 5 : Méthode 3 + +2K "Qobs" plateau réel à l'Equateur
+        DO j = 1, klon
+          phy_sst(j, i) = 273. + 2. + 0.5*27.*(2-sin(1.5*rlatd(j))**2-sin(1.5 &
+            *rlatd(j))**4)
+          IF ((rlatd(j)>1.0471975) .OR. (rlatd(j)<-1.0471975)) THEN
+            phy_sst(j, i) = 273. + 2.
+          END IF
+
+        END DO
+      END IF
+
+      IF (type_profil==6) THEN
+        ! Méthode 6 "cst" valeur constante de SST
+        DO j = 1, klon
+          phy_sst(j, i) = 288.
+        END DO
+      END IF
+
+
+      IF (type_profil==7) THEN
+        ! Méthode 7 "cst" valeur constante de SST +2
+        DO j = 1, klon
+          phy_sst(j, i) = 288. + 2.
+        END DO
+      END IF
+
+      p = 0
+      IF (type_profil==8) THEN
+        ! Méthode 8 profil anomalies SST du modèle couplé AR4
+        DO j = 1, klon
+          IF (rlatd(j)==rlatd(j-1)) THEN
+            phy_sst(j, i) = 273. + x_anom_sst(pplus) + &
+              0.5*27.*(2-sin(1.5*rlatd(j))**2-sin(1.5*rlatd(j))**4)
+            IF ((rlatd(j)>1.0471975) .OR. (rlatd(j)<-1.0471975)) THEN
+              phy_sst(j, i) = 273. + x_anom_sst(pplus)
+            END IF
+          ELSE
+            p = p + 1
+            pplus = 73 - p
+            phy_sst(j, i) = 273. + x_anom_sst(pplus) + &
+              0.5*27.*(2-sin(1.5*rlatd(j))**2-sin(1.5*rlatd(j))**4)
+            IF ((rlatd(j)>1.0471975) .OR. (rlatd(j)<-1.0471975)) THEN
+              phy_sst(j, i) = 273. + x_anom_sst(pplus)
+            END IF
+            WRITE (*, *) rlatd(j), x_anom_sst(pplus), phy_sst(j, i)
+          END IF
+        END DO
+      END IF
+
+      IF (type_profil==9) THEN
+        ! Méthode 5 : Méthode 3 + -2K "Qobs" plateau réel à l'Equateur
+        DO j = 1, klon
+          phy_sst(j, i) = 273. - 2. + 0.5*27.*(2-sin(1.5*rlatd(j))**2-sin(1.5 &
+            *rlatd(j))**4)
+          IF ((rlatd(j)>1.0471975) .OR. (rlatd(j)<-1.0471975)) THEN
+            phy_sst(j, i) = 273. - 2.
+          END IF
+        END DO
+      END IF
+
+
+      IF (type_profil==10) THEN
+        ! Méthode 10 : Méthode 3 + +4K "Qobs" plateau réel à l'Equateur
+        DO j = 1, klon
+          phy_sst(j, i) = 273. + 4. + 0.5*27.*(2-sin(1.5*rlatd(j))**2-sin(1.5 &
+            *rlatd(j))**4)
+          IF ((rlatd(j)>1.0471975) .OR. (rlatd(j)<-1.0471975)) THEN
+            phy_sst(j, i) = 273. + 4.
+          END IF
+        END DO
+      END IF
+
+      IF (type_profil==11) THEN
+        ! Méthode 11 : Méthode 3 + 4CO2 "Qobs" plateau réel à l'Equateur
+        DO j = 1, klon
+          phy_sst(j, i) = 273. + 0.5*27.*(2-sin(1.5*rlatd(j))**2-sin(1.5* &
+            rlatd(j))**4)
+          IF ((rlatd(j)>1.0471975) .OR. (rlatd(j)<-1.0471975)) THEN
+            phy_sst(j, i) = 273.
+          END IF
+        END DO
+      END IF
+
+      IF (type_profil==12) THEN
+        ! Méthode 12 : Méthode 10 + 4CO2 "Qobs" plateau réel à l'Equateur
+        DO j = 1, klon
+          phy_sst(j, i) = 273. + 4. + 0.5*27.*(2-sin(1.5*rlatd(j))**2-sin(1.5 &
+            *rlatd(j))**4)
+          IF ((rlatd(j)>1.0471975) .OR. (rlatd(j)<-1.0471975)) THEN
+            phy_sst(j, i) = 273. + 4.
+          END IF
+        END DO
+      END IF
+
+      IF (type_profil==13) THEN
+        ! Méthode 13 "Qmax" plateau réel à l'Equateur augmenté !
+        DO j = 1, klon
+          phy_sst(j, i) = 273. + 0.5*29.*(2-sin(1.5*rlatd(j))**2-sin(1.5* &
+            rlatd(j))**4)
+          IF ((rlatd(j)>1.0471975) .OR. (rlatd(j)<-1.0471975)) THEN
+            phy_sst(j, i) = 273.
+          END IF
+        END DO
+      END IF
+
+      IF (type_profil==14) THEN
+        ! Méthode 13 "Qmax2K" plateau réel à l'Equateur augmenté +2K !
+        DO j = 1, klon
+          phy_sst(j, i) = 273. + 2. + 0.5*29.*(2-sin(1.5*rlatd(j))**2-sin(1.5 &
+            *rlatd(j))**4)
+          IF ((rlatd(j)>1.0471975) .OR. (rlatd(j)<-1.0471975)) THEN
+            phy_sst(j, i) = 273.
+          END IF
+        END DO
+      END IF
+
+      if (type_profil.EQ.20) then
+      print*,'Profile SST 20'
+!     Méthode 13 "Qmax2K" plateau réel �|  l'Equateur augmenté +2K
+
+      do j=1,klon
+        phy_sst(j,i)=248.+55.*(1-sin(rlatd(j))**2)
+      enddo
+      endif
+
+      if (type_profil.EQ.21) then
+      print*,'Profile SST 21'
+!     Méthode 13 "Qmax2K" plateau réel �|  l'Equateur augmenté +2K
+      do j=1,klon
+        phy_sst(j,i)=252.+55.*(1-sin(rlatd(j))**2)
+      enddo
+      endif
+
+
+
+    END DO
+
+    ! IM beg : verif profil SST: phy_sst
+    amn = min(phy_sst(1,1), 1000.)
+    amx = max(phy_sst(1,1), -1000.)
+    imn = 1
+    kmn = 1
+    imx = 1
+    kmx = 1
+    DO k = 1, year_len
+      DO i = 2, nlon
+        IF (phy_sst(i,k)<amn) THEN
+          amn = phy_sst(i, k)
+          imn = i
+          kmn = k
+        END IF
+        IF (phy_sst(i,k)>amx) THEN
+          amx = phy_sst(i, k)
+          imx = i
+          kmx = k
+        END IF
+      END DO
+    END DO
+
+    PRINT *, 'profil_sst: imn, kmn, phy_sst(imn,kmn) ', imn, kmn, amn
+    PRINT *, 'profil_sst: imx, kmx, phy_sst(imx,kmx) ', imx, kmx, amx
+    ! IM end : verif profil SST: phy_sst
+
+    RETURN
+  END SUBROUTINE profil_sst
+
+END MODULE phyaqua_mod
Index: DZ6/trunk/libf/phylmd/phyetat0_get_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/phyetat0_get_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,143 +1,0 @@
-MODULE phyetat0_get_mod
-
-  PRIVATE
-  PUBLIC :: phyetat0_get, phyetat0_srf
-
-  INTERFACE phyetat0_get
-    MODULE PROCEDURE phyetat0_get10, phyetat0_get20, phyetat0_get11, phyetat0_get21
-  END INTERFACE phyetat0_get
-  INTERFACE phyetat0_srf
-    MODULE PROCEDURE phyetat0_srf20, phyetat0_srf30, phyetat0_srf21, phyetat0_srf31
-  END INTERFACE phyetat0_srf
-
-CONTAINS
-
-!==============================================================================
-LOGICAL FUNCTION phyetat0_get10(field, name, descr, default) RESULT(lFound)
-! Read a field. Check whether reading succeded and use default value if not.
-  IMPLICIT NONE
-  REAL,             INTENT(INOUT) :: field(:) ! klon
-  CHARACTER(LEN=*), INTENT(IN)    :: name
-  CHARACTER(LEN=*), INTENT(IN)    :: descr
-  REAL,             INTENT(IN)    :: default
-!------------------------------------------------------------------------------
-  REAL :: fld(SIZE(field),1)
-  lFound = phyetat0_get21(fld, [name], descr, default); field = fld(:,1)
-END FUNCTION phyetat0_get10
-!==============================================================================
-LOGICAL FUNCTION phyetat0_get20(field, name, descr, default) RESULT(lFound)
-! Same as phyetat0_get11, field on multiple levels.
-  IMPLICIT NONE
-  REAL,             INTENT(INOUT) :: field(:,:) ! klon, nlev
-  CHARACTER(LEN=*), INTENT(IN)    :: name
-  CHARACTER(LEN=*), INTENT(IN)    :: descr
-  REAL,             INTENT(IN)    :: default
-!-----------------------------------------------------------------------------
-  lFound = phyetat0_get21(field, [name], descr, default)
-END FUNCTION phyetat0_get20
-!==============================================================================
-LOGICAL FUNCTION phyetat0_get11(field, name, descr, default) RESULT(lFound)
-! Same as phyetat0_get11, multiple names.
-  IMPLICIT NONE
-  REAL,             INTENT(INOUT) :: field(:) ! klon
-  CHARACTER(LEN=*), INTENT(IN)    :: name(:)
-  CHARACTER(LEN=*), INTENT(IN)    :: descr
-  REAL,             INTENT(IN)    :: default
-!-----------------------------------------------------------------------------
-  REAL :: fld(SIZE(field),1)
-  lFound = phyetat0_get21(fld, name, descr, default); field = fld(:,1)
-END FUNCTION phyetat0_get11
-!==============================================================================
-LOGICAL FUNCTION phyetat0_get21(field, name, descr, default, tname) RESULT(lFound)
-! Same as phyetat0_get11, field on multiple levels, multiple names.
-  USE iostart,           ONLY: get_field
-  USE print_control_mod, ONLY: lunout
-  IMPLICIT NONE
-  REAL,             INTENT(INOUT) :: field(:,:) ! klon, nlev
-  CHARACTER(LEN=*), INTENT(IN)    :: name(:)
-  CHARACTER(LEN=*), INTENT(IN)    :: descr
-  REAL,             INTENT(IN)    :: default
-  CHARACTER(LEN=*), OPTIONAL, INTENT(OUT) :: tname
-!-----------------------------------------------------------------------------
-  CHARACTER(LEN=LEN(name)) :: tnam
-  INTEGER :: i
-  DO i = 1, SIZE(name)
-    CALL get_field(TRIM(name(i)), field, lFound)
-    IF(lFound) EXIT
-    WRITE(lunout,*) "phyetat0: Missing field <",TRIM(name(i)),"> "
-  END DO
-  IF(.NOT.lFound) THEN
-    WRITE(lunout,*) "Slightly distorted start ; continuing."
-    field(:,:) = default
-    tnam = name(1)
-  ELSE
-    tnam = name(i)
-  END IF
-  WRITE(lunout,'(2(a,ES14.7))') 'phyetat0: '//TRIM(tnam)//' ('//TRIM(descr)//') min/max=', &
-    MINval(field),' ',MAXval(field)
-  IF(PRESENT(tname)) tname = tnam
-END FUNCTION phyetat0_get21
-!==============================================================================
-LOGICAL FUNCTION phyetat0_srf20(field, name, descr, default) RESULT(lFound)
-! Read a field per sub-surface.
-! Check whether reading succeded and use default value if not.
-  IMPLICIT NONE
-  REAL,             INTENT(INOUT) :: field(:,:)
-  CHARACTER(LEN=*), INTENT(IN)    :: name
-  CHARACTER(LEN=*), INTENT(IN)    :: descr
-  REAL,             INTENT(IN)    :: default
-!-----------------------------------------------------------------------------
-  REAL :: fld(SIZE(field,1),1,SIZE(field,2))
-  lFound = phyetat0_srf31(fld, [name], descr, default); field = fld(:,1,:)
-END FUNCTION phyetat0_srf20
-
-!==============================================================================
-LOGICAL FUNCTION phyetat0_srf30(field, name, descr, default) RESULT(lFound)
-! Same as phyetat0_sfr11, multiple names tested one after the other.
-  IMPLICIT NONE
-  REAL,             INTENT(INOUT) :: field(:,:,:)
-  CHARACTER(LEN=*), INTENT(IN)    :: name
-  CHARACTER(LEN=*), INTENT(IN)    :: descr
-  REAL,             INTENT(IN)    :: default
-!-----------------------------------------------------------------------------
-  lFound = phyetat0_srf31(field, [name], descr, default)
-END FUNCTION phyetat0_srf30
-
-!==============================================================================
-LOGICAL FUNCTION phyetat0_srf21(field, name, descr, default) RESULT(lFound)
-! Same as phyetat0_sfr11, field on multiple levels.
-  IMPLICIT NONE
-  REAL,             INTENT(INOUT) :: field(:,:)
-  CHARACTER(LEN=*), INTENT(IN)    :: name(:)
-  CHARACTER(LEN=*), INTENT(IN)    :: descr
-  REAL,             INTENT(IN)    :: default
-!-----------------------------------------------------------------------------
-  REAL :: fld(SIZE(field,1),1,SIZE(field,2))
-  lFound = phyetat0_srf31(fld, name, descr, default); field = fld(:,1,:)
-END FUNCTION phyetat0_srf21
-
-!==============================================================================
-LOGICAL FUNCTION phyetat0_srf31(field, name, descr, default) RESULT(lFound)
-! Same as phyetat0_sfr11, field on multiple levels, multiple names tested one after the other.
-  USE iostart,           ONLY: get_field
-  USE print_control_mod, ONLY: lunout
-  USE strings_mod,       ONLY: int2str, maxlen
-  IMPLICIT NONE
-  REAL,             INTENT(INOUT) :: field(:,:,:)
-  CHARACTER(LEN=*), INTENT(IN)    :: name(:)
-  CHARACTER(LEN=*), INTENT(IN)    :: descr
-  REAL,             INTENT(IN)    :: default
-!-----------------------------------------------------------------------------
-  INTEGER :: nsrf, i
-  CHARACTER(LEN=maxlen) :: nam(SIZE(name)), tname, des
-  IF(SIZE(field,3)>99) CALL abort_physic("phyetat0", "Too much sub-cells", 1)
-  DO nsrf = 1, SIZE(field,3)
-    DO i = 1, SIZE(name); nam(i) = TRIM(name(i))//TRIM(int2str(nsrf,2)); END DO
-    des = TRIM(descr)//" srf:"//int2str(nsrf,2)
-    lFound = phyetat0_get21(field(:,:,nsrf), nam, TRIM(des), default, tname)
-  END DO
-  WRITE(lunout,'(2(a,ES14.7))') 'phyetat0: '//TRIM(tname)//' ('//TRIM(descr)//') min/max=', &
-    MINval(field),' ',MAXval(field)
-END FUNCTION phyetat0_srf31
-
-END MODULE phyetat0_get_mod
Index: /LMDZ6/trunk/libf/phylmd/phyetat0_get_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/phyetat0_get_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/phyetat0_get_mod.f90	(revision 5268)
@@ -0,0 +1,143 @@
+MODULE phyetat0_get_mod
+
+  PRIVATE
+  PUBLIC :: phyetat0_get, phyetat0_srf
+
+  INTERFACE phyetat0_get
+    MODULE PROCEDURE phyetat0_get10, phyetat0_get20, phyetat0_get11, phyetat0_get21
+  END INTERFACE phyetat0_get
+  INTERFACE phyetat0_srf
+    MODULE PROCEDURE phyetat0_srf20, phyetat0_srf30, phyetat0_srf21, phyetat0_srf31
+  END INTERFACE phyetat0_srf
+
+CONTAINS
+
+!==============================================================================
+LOGICAL FUNCTION phyetat0_get10(field, name, descr, default) RESULT(lFound)
+! Read a field. Check whether reading succeded and use default value if not.
+  IMPLICIT NONE
+  REAL,             INTENT(INOUT) :: field(:) ! klon
+  CHARACTER(LEN=*), INTENT(IN)    :: name
+  CHARACTER(LEN=*), INTENT(IN)    :: descr
+  REAL,             INTENT(IN)    :: default
+!------------------------------------------------------------------------------
+  REAL :: fld(SIZE(field),1)
+  lFound = phyetat0_get21(fld, [name], descr, default); field = fld(:,1)
+END FUNCTION phyetat0_get10
+!==============================================================================
+LOGICAL FUNCTION phyetat0_get20(field, name, descr, default) RESULT(lFound)
+! Same as phyetat0_get11, field on multiple levels.
+  IMPLICIT NONE
+  REAL,             INTENT(INOUT) :: field(:,:) ! klon, nlev
+  CHARACTER(LEN=*), INTENT(IN)    :: name
+  CHARACTER(LEN=*), INTENT(IN)    :: descr
+  REAL,             INTENT(IN)    :: default
+!-----------------------------------------------------------------------------
+  lFound = phyetat0_get21(field, [name], descr, default)
+END FUNCTION phyetat0_get20
+!==============================================================================
+LOGICAL FUNCTION phyetat0_get11(field, name, descr, default) RESULT(lFound)
+! Same as phyetat0_get11, multiple names.
+  IMPLICIT NONE
+  REAL,             INTENT(INOUT) :: field(:) ! klon
+  CHARACTER(LEN=*), INTENT(IN)    :: name(:)
+  CHARACTER(LEN=*), INTENT(IN)    :: descr
+  REAL,             INTENT(IN)    :: default
+!-----------------------------------------------------------------------------
+  REAL :: fld(SIZE(field),1)
+  lFound = phyetat0_get21(fld, name, descr, default); field = fld(:,1)
+END FUNCTION phyetat0_get11
+!==============================================================================
+LOGICAL FUNCTION phyetat0_get21(field, name, descr, default, tname) RESULT(lFound)
+! Same as phyetat0_get11, field on multiple levels, multiple names.
+  USE iostart,           ONLY: get_field
+  USE print_control_mod, ONLY: lunout
+  IMPLICIT NONE
+  REAL,             INTENT(INOUT) :: field(:,:) ! klon, nlev
+  CHARACTER(LEN=*), INTENT(IN)    :: name(:)
+  CHARACTER(LEN=*), INTENT(IN)    :: descr
+  REAL,             INTENT(IN)    :: default
+  CHARACTER(LEN=*), OPTIONAL, INTENT(OUT) :: tname
+!-----------------------------------------------------------------------------
+  CHARACTER(LEN=LEN(name)) :: tnam
+  INTEGER :: i
+  DO i = 1, SIZE(name)
+    CALL get_field(TRIM(name(i)), field, lFound)
+    IF(lFound) EXIT
+    WRITE(lunout,*) "phyetat0: Missing field <",TRIM(name(i)),"> "
+  END DO
+  IF(.NOT.lFound) THEN
+    WRITE(lunout,*) "Slightly distorted start ; continuing."
+    field(:,:) = default
+    tnam = name(1)
+  ELSE
+    tnam = name(i)
+  END IF
+  WRITE(lunout,'(2(a,ES14.7))') 'phyetat0: '//TRIM(tnam)//' ('//TRIM(descr)//') min/max=', &
+    MINval(field),' ',MAXval(field)
+  IF(PRESENT(tname)) tname = tnam
+END FUNCTION phyetat0_get21
+!==============================================================================
+LOGICAL FUNCTION phyetat0_srf20(field, name, descr, default) RESULT(lFound)
+! Read a field per sub-surface.
+! Check whether reading succeded and use default value if not.
+  IMPLICIT NONE
+  REAL,             INTENT(INOUT) :: field(:,:)
+  CHARACTER(LEN=*), INTENT(IN)    :: name
+  CHARACTER(LEN=*), INTENT(IN)    :: descr
+  REAL,             INTENT(IN)    :: default
+!-----------------------------------------------------------------------------
+  REAL :: fld(SIZE(field,1),1,SIZE(field,2))
+  lFound = phyetat0_srf31(fld, [name], descr, default); field = fld(:,1,:)
+END FUNCTION phyetat0_srf20
+
+!==============================================================================
+LOGICAL FUNCTION phyetat0_srf30(field, name, descr, default) RESULT(lFound)
+! Same as phyetat0_sfr11, multiple names tested one after the other.
+  IMPLICIT NONE
+  REAL,             INTENT(INOUT) :: field(:,:,:)
+  CHARACTER(LEN=*), INTENT(IN)    :: name
+  CHARACTER(LEN=*), INTENT(IN)    :: descr
+  REAL,             INTENT(IN)    :: default
+!-----------------------------------------------------------------------------
+  lFound = phyetat0_srf31(field, [name], descr, default)
+END FUNCTION phyetat0_srf30
+
+!==============================================================================
+LOGICAL FUNCTION phyetat0_srf21(field, name, descr, default) RESULT(lFound)
+! Same as phyetat0_sfr11, field on multiple levels.
+  IMPLICIT NONE
+  REAL,             INTENT(INOUT) :: field(:,:)
+  CHARACTER(LEN=*), INTENT(IN)    :: name(:)
+  CHARACTER(LEN=*), INTENT(IN)    :: descr
+  REAL,             INTENT(IN)    :: default
+!-----------------------------------------------------------------------------
+  REAL :: fld(SIZE(field,1),1,SIZE(field,2))
+  lFound = phyetat0_srf31(fld, name, descr, default); field = fld(:,1,:)
+END FUNCTION phyetat0_srf21
+
+!==============================================================================
+LOGICAL FUNCTION phyetat0_srf31(field, name, descr, default) RESULT(lFound)
+! Same as phyetat0_sfr11, field on multiple levels, multiple names tested one after the other.
+  USE iostart,           ONLY: get_field
+  USE print_control_mod, ONLY: lunout
+  USE strings_mod,       ONLY: int2str, maxlen
+  IMPLICIT NONE
+  REAL,             INTENT(INOUT) :: field(:,:,:)
+  CHARACTER(LEN=*), INTENT(IN)    :: name(:)
+  CHARACTER(LEN=*), INTENT(IN)    :: descr
+  REAL,             INTENT(IN)    :: default
+!-----------------------------------------------------------------------------
+  INTEGER :: nsrf, i
+  CHARACTER(LEN=maxlen) :: nam(SIZE(name)), tname, des
+  IF(SIZE(field,3)>99) CALL abort_physic("phyetat0", "Too much sub-cells", 1)
+  DO nsrf = 1, SIZE(field,3)
+    DO i = 1, SIZE(name); nam(i) = TRIM(name(i))//TRIM(int2str(nsrf,2)); END DO
+    des = TRIM(descr)//" srf:"//int2str(nsrf,2)
+    lFound = phyetat0_get21(field(:,:,nsrf), nam, TRIM(des), default, tname)
+  END DO
+  WRITE(lunout,'(2(a,ES14.7))') 'phyetat0: '//TRIM(tname)//' ('//TRIM(descr)//') min/max=', &
+    MINval(field),' ',MAXval(field)
+END FUNCTION phyetat0_srf31
+
+END MODULE phyetat0_get_mod
Index: DZ6/trunk/libf/phylmd/phyetat0_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/phyetat0_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,657 +1,0 @@
-! $Id$
-
-MODULE phyetat0_mod
-
-  PRIVATE
-  PUBLIC :: phyetat0
-
-CONTAINS
-
-SUBROUTINE phyetat0 (fichnom, clesphy0, tabcntr0)
-
-  USE dimphy, only: klon, zmasq, klev
-  USE iophy, ONLY : init_iophy_new
-  USE ocean_cpl_mod,    ONLY : ocean_cpl_init
-  USE fonte_neige_mod,  ONLY : fonte_neige_init
-  USE pbl_surface_mod,  ONLY : pbl_surface_init
-  USE surface_data,     ONLY : type_ocean, version_ocean
-  USE phyetat0_get_mod, ONLY : phyetat0_get, phyetat0_srf
-  USE phys_state_var_mod, ONLY : ancien_ok, clwcon, detr_therm, phys_tstep, &
-       qsol, fevap, z0m, z0h, agesno, &
-       du_gwd_rando, du_gwd_front, entr_therm, f0, fm_therm, &
-       falb_dir, falb_dif, prw_ancien, prlw_ancien, prsw_ancien, prbsw_ancien, &
-       ftsol, pbl_tke, pctsrf, q_ancien, ql_ancien, qs_ancien, qbs_ancien, &
-       cf_ancien, rvc_ancien, radpas, radsol, rain_fall, ratqs, &
-       rnebcon, rugoro, sig1, snow_fall, bs_fall, solaire_etat0, sollw, sollwdown, &
-       solsw, solswfdiff, t_ancien, u_ancien, v_ancien, w01, wake_cstar, wake_deltaq, &
-       wake_deltat, wake_delta_pbl_TKE, delta_tsurf, beta_aridity, wake_fip, wake_pe, &
-       wake_s, awake_s, wake_dens, awake_dens, cv_gen, zgam, zmax0, zmea, zpic, zsig, &
-       zstd, zthe, zval, ale_bl, ale_bl_trig, alp_bl, u10m, v10m, treedrg, &
-       ale_wake, ale_bl_stat, ds_ns, dt_ns, delta_sst, delta_sal, dter, dser, &
-       dt_ds, ratqs_inter_
-!FC
-  USE geometry_mod,     ONLY: longitude_deg, latitude_deg
-  USE iostart,          ONLY: close_startphy, get_field, get_var, open_startphy
-  USE infotrac_phy,     ONLY: nqtot, nbtr, type_trac, tracers, new2oldH2O
-  USE strings_mod,      ONLY: maxlen
-  USE traclmdz_mod,     ONLY: traclmdz_from_restart
-  USE carbon_cycle_mod, ONLY: carbon_cycle_init, carbon_cycle_cpl, carbon_cycle_tr, carbon_cycle_rad, co2_send, RCO2_glo
-  USE indice_sol_mod,   ONLY: nbsrf, is_ter, epsfra, is_lic, is_oce, is_sic
-  USE ocean_slab_mod,   ONLY: nslay, tslab, seaice, tice, ocean_slab_init
-  USE time_phylmdz_mod, ONLY: init_iteration, pdtphys, itau_phy
-  USE wxios, ONLY: missing_val_xios => missing_val, using_xios
-  use netcdf, only: missing_val_netcdf => nf90_fill_real
-  use config_ocean_skin_m, only: activate_ocean_skin
-
-  IMPLICIT none
-  !======================================================================
-  ! Auteur(s) Z.X. Li (LMD/CNRS) date: 19930818
-  ! Objet: Lecture de l'etat initial pour la physique
-  !======================================================================
-  include "dimsoil.h"
-  include "clesphys.h"
-  include "alpale.h"
-  include "compbl.h"
-  include "YOMCST.h"
-  !======================================================================
-  CHARACTER*(*) fichnom
-
-  ! les variables globales lues dans le fichier restart
-
-  REAL tsoil(klon, nsoilmx, nbsrf)
-  REAL qsurf(klon, nbsrf)
-  REAL snow(klon, nbsrf)
-  real fder(klon)
-  REAL run_off_lic_0(klon)
-  REAL fractint(klon)
-  REAL trs(klon, nbtr)
-  REAL zts(klon)
-  ! pour drag arbres FC
-  REAL drg_ter(klon,klev)
-
-  CHARACTER*6 ocean_in
-  LOGICAL ok_veget_in
-
-  INTEGER        longcles
-  PARAMETER    ( longcles = 20 )
-  REAL clesphy0( longcles )
-
-  REAL xmin, xmax
-
-  INTEGER nid, nvarid
-  INTEGER ierr, i, nsrf, isoil , k
-  INTEGER length
-  PARAMETER (length=100)
-  INTEGER it, iq, isw
-  REAL tab_cntrl(length), tabcntr0(length)
-  CHARACTER*7 str7
-  CHARACTER*2 str2
-  LOGICAL :: found
-  REAL :: lon_startphy(klon), lat_startphy(klon)
-  CHARACTER(LEN=maxlen) :: tname, t(2)
-  REAL :: missing_val
-
-  IF (using_xios) THEN
-    missing_val=missing_val_xios
-  ELSE
-    missing_val=missing_val_netcdf
-  ENDIF
-  
-  ! FH1D
-  !     real iolat(jjm+1)
-  !real iolat(jjm+1-1/(iim*jjm))
-
-  ! Ouvrir le fichier contenant l'etat initial:
-
-  CALL open_startphy(fichnom)
-
-  ! Lecture des parametres de controle:
-
-  CALL get_var("controle", tab_cntrl)
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-  ! FH 2008/05/09 On elimine toutes les clefs physiques dans la dynamique
-  ! Les constantes de la physiques sont lues dans la physique seulement.
-  ! Les egalites du type
-  !             tab_cntrl( 5 )=clesphy0(1)
-  ! sont remplacees par
-  !             clesphy0(1)=tab_cntrl( 5 )
-  ! On inverse aussi la logique.
-  ! On remplit les tab_cntrl avec les parametres lus dans les .def
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-  DO i = 1, length
-     tabcntr0( i ) = tab_cntrl( i )
-  ENDDO
-
-  tab_cntrl(1)=pdtphys
-  tab_cntrl(2)=radpas
-
-  ! co2_ppm : value from the previous time step
-
-  ! co2_ppm0 : initial value of atmospheric CO2 (from create_etat0_limit.e .def)
-  co2_ppm0 = 284.32
-  ! when no initial value is available e.g., from a restart 
-  ! this variable must be set  in a .def file which will then be 
-  ! used by the conf_phys_m.F90 routine.
-  ! co2_ppm0 = 284.32 (illustrative example on how to set the variable in .def
-  ! file, for a pre-industrial CO2 concentration value)
-
-  IF (carbon_cycle_tr .OR. carbon_cycle_cpl) THEN
-     co2_ppm = tab_cntrl(3)
-     RCO2    = co2_ppm * 1.0e-06 * RMCO2 / RMD
-     IF (tab_cntrl(17) > 0. .AND. carbon_cycle_rad) THEN
-           RCO2_glo = tab_cntrl(17)
-       ELSE
-           RCO2_glo    = co2_ppm0 * 1.0e-06 * RMCO2 / RMD
-     ENDIF
-     ! ELSE : keep value from .def
-  ENDIF
-
-  solaire_etat0      = tab_cntrl(4)
-  tab_cntrl(5)=iflag_con
-  tab_cntrl(6)=nbapp_rad
-
-  IF (iflag_cycle_diurne.GE.1) tab_cntrl( 7) = iflag_cycle_diurne
-  IF (soil_model) tab_cntrl( 8) =1.
-  IF (new_oliq) tab_cntrl( 9) =1.
-  IF (ok_orodr) tab_cntrl(10) =1.
-  IF (ok_orolf) tab_cntrl(11) =1.
-  IF (ok_limitvrai) tab_cntrl(12) =1.
-
-  itau_phy = tab_cntrl(15)
-
-  clesphy0(1)=tab_cntrl( 5 )
-  clesphy0(2)=tab_cntrl( 6 )
-  clesphy0(3)=tab_cntrl( 7 )
-  clesphy0(4)=tab_cntrl( 8 )
-  clesphy0(5)=tab_cntrl( 9 )
-  clesphy0(6)=tab_cntrl( 10 )
-  clesphy0(7)=tab_cntrl( 11 )
-  clesphy0(8)=tab_cntrl( 12 )
-  clesphy0(9)=tab_cntrl( 17 )
-
-  ! set time iteration
-   CALL init_iteration(itau_phy)
-
-  ! read latitudes and make a sanity check (because already known from dyn)
-  CALL get_field("latitude",lat_startphy)
-  DO i=1,klon
-    IF (ABS(lat_startphy(i)-latitude_deg(i))>=1) THEN
-      WRITE(*,*) "phyetat0: Error! Latitude discrepancy wrt startphy file:",&
-                 " i=",i," lat_startphy(i)=",lat_startphy(i),&
-                 " latitude_deg(i)=",latitude_deg(i)
-      ! This is presumably serious enough to abort run
-      CALL abort_physic("phyetat0","discrepancy in latitudes!",1)
-    ENDIF
-    IF (ABS(lat_startphy(i)-latitude_deg(i))>=0.0001) THEN
-      WRITE(*,*) "phyetat0: Warning! Latitude discrepancy wrt startphy file:",&
-                 " i=",i," lat_startphy(i)=",lat_startphy(i),&
-                 " latitude_deg(i)=",latitude_deg(i)
-    ENDIF
-  ENDDO
-
-  ! read longitudes and make a sanity check (because already known from dyn)
-  CALL get_field("longitude",lon_startphy)
-  DO i=1,klon
-    IF (ABS(lon_startphy(i)-longitude_deg(i))>=1) THEN
-      IF (ABS(360-ABS(lon_startphy(i)-longitude_deg(i)))>=1) THEN
-        WRITE(*,*) "phyetat0: Error! Longitude discrepancy wrt startphy file:",&
-                   " i=",i," lon_startphy(i)=",lon_startphy(i),&
-                   " longitude_deg(i)=",longitude_deg(i)
-        ! This is presumably serious enough to abort run
-        CALL abort_physic("phyetat0","discrepancy in longitudes!",1)
-      ENDIF
-    ENDIF
-    IF (ABS(lon_startphy(i)-longitude_deg(i))>=1) THEN
-      IF (ABS(360-ABS(lon_startphy(i)-longitude_deg(i))) > 0.0001) THEN
-        WRITE(*,*) "phyetat0: Warning! Longitude discrepancy wrt startphy file:",&
-                   " i=",i," lon_startphy(i)=",lon_startphy(i),&
-                   " longitude_deg(i)=",longitude_deg(i)
-      ENDIF 
-    ENDIF
-  ENDDO
-
-  ! Lecture du masque terre mer
-
-  CALL get_field("masque", zmasq, found)
-  IF (.NOT. found) THEN
-     PRINT*, 'phyetat0: Le champ <masque> est absent'
-     PRINT *, 'fichier startphy non compatible avec phyetat0'
-  ENDIF
-
-  ! Lecture des fractions pour chaque sous-surface
-
-  ! initialisation des sous-surfaces
-
-  pctsrf = 0.
-
-  ! fraction de terre
-
-  CALL get_field("FTER", pctsrf(:, is_ter), found)
-  IF (.NOT. found) PRINT*, 'phyetat0: Le champ <FTER> est absent'
-
-  ! fraction de glace de terre
-
-  CALL get_field("FLIC", pctsrf(:, is_lic), found)
-  IF (.NOT. found) PRINT*, 'phyetat0: Le champ <FLIC> est absent'
-
-  ! fraction d'ocean
-
-  CALL get_field("FOCE", pctsrf(:, is_oce), found)
-  IF (.NOT. found) PRINT*, 'phyetat0: Le champ <FOCE> est absent'
-
-  ! fraction glace de mer
-
-  CALL get_field("FSIC", pctsrf(:, is_sic), found)
-  IF (.NOT. found) PRINT*, 'phyetat0: Le champ <FSIC> est absent'
-
-  !  Verification de l'adequation entre le masque et les sous-surfaces
-
-  fractint( 1 : klon) = pctsrf(1 : klon, is_ter)  &
-       + pctsrf(1 : klon, is_lic)
-  DO i = 1 , klon
-     IF ( abs(fractint(i) - zmasq(i) ) .GT. EPSFRA ) THEN
-        WRITE(*, *) 'phyetat0: attention fraction terre pas ',  &
-             'coherente ', i, zmasq(i), pctsrf(i, is_ter) &
-             , pctsrf(i, is_lic)
-        WRITE(*, *) 'Je force la coherence zmasq=fractint'
-        zmasq(i) = fractint(i)
-     ENDIF
-  ENDDO
-  fractint (1 : klon) =  pctsrf(1 : klon, is_oce)  &
-       + pctsrf(1 : klon, is_sic)
-  DO i = 1 , klon
-     IF ( abs( fractint(i) - (1. - zmasq(i))) .GT. EPSFRA ) THEN
-        WRITE(*, *) 'phyetat0 attention fraction ocean pas ',  &
-             'coherente ', i, zmasq(i) , pctsrf(i, is_oce) &
-             , pctsrf(i, is_sic)
-        WRITE(*, *) 'Je force la coherence zmasq=1.-fractint'
-        zmasq(i) = 1. - fractint(i)
-     ENDIF
-  ENDDO
-
-!===================================================================
-! Lecture des temperatures du sol:
-!===================================================================
-
-  found=phyetat0_get(ftsol(:,1),"TS","Surface temperature",283.)
-  IF (found) THEN
-     DO nsrf=2,nbsrf
-        ftsol(:,nsrf)=ftsol(:,1)
-     ENDDO
-  ELSE
-     found=phyetat0_srf(ftsol,"TS","Surface temperature",283.)
-  ENDIF
-
-!===================================================================
-  ! Lecture des albedo difus et direct
-!===================================================================
-
-  DO nsrf = 1, nbsrf
-     DO isw=1, nsw
-        IF (isw.GT.99) THEN
-           PRINT*, "Trop de bandes SW"
-           call abort_physic("phyetat0", "", 1)
-        ENDIF
-        WRITE(str2, '(i2.2)') isw
-        found=phyetat0_srf(falb_dir(:, isw,:),"A_dir_SW"//str2//"srf","Direct Albedo",0.2)
-        found=phyetat0_srf(falb_dif(:, isw,:),"A_dif_SW"//str2//"srf","Direct Albedo",0.2)
-     ENDDO
-  ENDDO
-
-  found=phyetat0_srf(u10m,"U10M","u a 10m",0.)
-  found=phyetat0_srf(v10m,"V10M","v a 10m",0.)
-
-!===================================================================
-! Lecture dans le cas iflag_pbl_surface =1
-!===================================================================
-
-   if ( iflag_physiq <= 1 ) then
-!===================================================================
-  ! Lecture des temperatures du sol profond:
-!===================================================================
-
-   DO isoil=1, nsoilmx
-        IF (isoil.GT.99) THEN
-           PRINT*, "Trop de couches "
-           call abort_physic("phyetat0", "", 1)
-        ENDIF
-        WRITE(str2,'(i2.2)') isoil
-        found=phyetat0_srf(tsoil(:, isoil,:),"Tsoil"//str2//"srf","Temp soil",0.)
-        IF (.NOT. found) THEN
-           PRINT*, "phyetat0: Le champ <Tsoil"//str7//"> est absent"
-           PRINT*, "          Il prend donc la valeur de surface"
-           tsoil(:, isoil, :)=ftsol(:, :)
-        ENDIF
-   ENDDO
-
-!=======================================================================
-! Lecture precipitation/evaporation
-!=======================================================================
-
-  found=phyetat0_srf(qsurf,"QS","Near surface hmidity",0.)
-  found=phyetat0_get(qsol,"QSOL","Surface hmidity / bucket",0.)
-  found=phyetat0_srf(snow,"SNOW","Surface snow",0.)
-  found=phyetat0_srf(fevap,"EVAP","evaporation",0.)
-  found=phyetat0_get(snow_fall,"snow_f","snow fall",0.)
-  found=phyetat0_get(rain_fall,"rain_f","rain fall",0.)
-  IF (ok_bs) THEN
-     found=phyetat0_get(bs_fall,"bs_f","blowing snow fall",0.)
-  ELSE
-     bs_fall(:)=0.
-  ENDIF
-!=======================================================================
-! Radiation
-!=======================================================================
-
-  found=phyetat0_get(solsw,"solsw","net SW radiation surf",0.)
-  found=phyetat0_get(solswfdiff,"solswfdiff","fraction of SW radiation surf that is diffuse",1.)
-  found=phyetat0_get(sollw,"sollw","net LW radiation surf",0.)
-  found=phyetat0_get(sollwdown,"sollwdown","down LW radiation surf",0.)
-  IF (.NOT. found) THEN
-     sollwdown(:) = 0. ;  zts(:)=0.
-     DO nsrf=1,nbsrf
-        zts(:)=zts(:)+ftsol(:,nsrf)*pctsrf(:,nsrf)
-     ENDDO
-     sollwdown(:)=sollw(:)+RSIGMA*zts(:)**4
-  ENDIF
-
-  found=phyetat0_get(radsol,"RADS","Solar radiation",0.)
-  found=phyetat0_get(fder,"fder","Flux derivative",0.) 
-
-
-  ! Lecture de la longueur de rugosite 
-  found=phyetat0_srf(z0m,"RUG","Z0m ancien",0.001)
-  IF (found) THEN
-     z0h(:,1:nbsrf)=z0m(:,1:nbsrf)
-  ELSE
-     found=phyetat0_srf(z0m,"Z0m","Roughness length, momentum ",0.001)
-     found=phyetat0_srf(z0h,"Z0h","Roughness length, enthalpy ",0.001)
-  ENDIF
-!FC
-  IF (ifl_pbltree>0) THEN
-!CALL get_field("FTER", pctsrf(:, is_ter), found)
-    treedrg(:,1:klev,1:nbsrf)= 0.0
-    CALL get_field("treedrg_ter", drg_ter(:,:), found)
-!  found=phyetat0_srf(treedrg,"treedrg","drag from vegetation" , 0.)
-    !lecture du profile de freinage des arbres
-    IF (.not. found ) THEN
-      treedrg(:,1:klev,1:nbsrf)= 0.0
-    ELSE
-      treedrg(:,1:klev,is_ter)= drg_ter(:,:)
-!     found=phyetat0_get(treedrg,"treedrg","freinage arbres",0.)
-    ENDIF
-  ELSE
-    ! initialize treedrg(), because it will be written in restartphy.nc
-    treedrg(:,:,:) = 0.0 
-  ENDIF
-
-  endif ! iflag_physiq <= 1
-
-  ! Lecture de l'age de la neige:
-  found=phyetat0_srf(agesno,"AGESNO","SNOW AGE",0.001)
-
-  ancien_ok=.true.
-  ancien_ok=ancien_ok.AND.phyetat0_get(t_ancien,"TANCIEN","TANCIEN",0.)
-  ancien_ok=ancien_ok.AND.phyetat0_get(q_ancien,"QANCIEN","QANCIEN",0.)
-  ancien_ok=ancien_ok.AND.phyetat0_get(ql_ancien,"QLANCIEN","QLANCIEN",0.)
-  ancien_ok=ancien_ok.AND.phyetat0_get(qs_ancien,"QSANCIEN","QSANCIEN",0.)
-  ancien_ok=ancien_ok.AND.phyetat0_get(u_ancien,"UANCIEN","UANCIEN",0.)
-  ancien_ok=ancien_ok.AND.phyetat0_get(v_ancien,"VANCIEN","VANCIEN",0.)
-  ancien_ok=ancien_ok.AND.phyetat0_get(prw_ancien,"PRWANCIEN","PRWANCIEN",0.)
-  ancien_ok=ancien_ok.AND.phyetat0_get(prlw_ancien,"PRLWANCIEN","PRLWANCIEN",0.)
-  ancien_ok=ancien_ok.AND.phyetat0_get(prsw_ancien,"PRSWANCIEN","PRSWANCIEN",0.)
-
-  ! cas specifique des variables de la neige soufflee
-  IF (ok_bs) THEN
-     ancien_ok=ancien_ok.AND.phyetat0_get(qbs_ancien,"QBSANCIEN","QBSANCIEN",0.)
-     ancien_ok=ancien_ok.AND.phyetat0_get(prbsw_ancien,"PRBSWANCIEN","PRBSWANCIEN",0.)
-  ELSE
-     qbs_ancien(:,:)=0.
-     prbsw_ancien(:)=0.
-  ENDIF
-  
-  ! cas specifique des variables de la sursaturation par rapport a la glace
-  IF ( ok_ice_supersat ) THEN
-    ancien_ok=ancien_ok.AND.phyetat0_get(cf_ancien,"CFANCIEN","CFANCIEN",0.)
-    ancien_ok=ancien_ok.AND.phyetat0_get(rvc_ancien,"RVCANCIEN","RVCANCIEN",0.)
-  ELSE
-    cf_ancien(:,:)=0.
-    rvc_ancien(:,:)=0.
-  ENDIF
-
-  ! Ehouarn: addtional tests to check if t_ancien, q_ancien contain
-  !          dummy values (as is the case when generated by ce0l,
-  !          or by iniaqua)
-  IF ( (maxval(q_ancien).EQ.minval(q_ancien))       .OR. &
-       (maxval(ql_ancien).EQ.minval(ql_ancien))     .OR. &
-       (maxval(qs_ancien).EQ.minval(qs_ancien))     .OR. &
-       (maxval(prw_ancien).EQ.minval(prw_ancien))   .OR. &
-       (maxval(prlw_ancien).EQ.minval(prlw_ancien)) .OR. &
-       (maxval(prsw_ancien).EQ.minval(prsw_ancien)) .OR. &
-       (maxval(t_ancien).EQ.minval(t_ancien)) ) THEN
-    ancien_ok=.false.
-  ENDIF
-
-  IF (ok_bs) THEN
-    IF ( (maxval(qbs_ancien).EQ.minval(qbs_ancien))       .OR. &
-         (maxval(prbsw_ancien).EQ.minval(prbsw_ancien)) ) THEN
-       ancien_ok=.false.
-    ENDIF
-  ENDIF
-
-  IF ( ok_ice_supersat ) THEN
-    IF ( (maxval(cf_ancien).EQ.minval(cf_ancien))     .OR. &
-         (maxval(rvc_ancien).EQ.minval(rvc_ancien)) ) THEN
-       ancien_ok=.false.
-     ENDIF
-  ENDIF
-
-  found=phyetat0_get(clwcon,"CLWCON","CLWCON",0.)
-  found=phyetat0_get(rnebcon,"RNEBCON","RNEBCON",0.)
-  found=phyetat0_get(ratqs,"RATQS","RATQS",0.)
-
-  found=phyetat0_get(run_off_lic_0,"RUNOFFLIC0","RUNOFFLIC0",0.)
-
-!==================================
-!  TKE
-!==================================
-!
-  IF (iflag_pbl>1) then
-     found=phyetat0_srf(pbl_tke,"TKE","Turb. Kinetic. Energ. ",1.e-8)
-  ENDIF
-
-  IF (iflag_pbl>1 .AND. iflag_wake>=1  .AND. iflag_pbl_split >=1 ) then
-    found=phyetat0_srf(wake_delta_pbl_tke,"DELTATKE","Del TKE wk/env",0.)
-!!    found=phyetat0_srf(delta_tsurf,"DELTA_TSURF","Delta Ts wk/env ",0.)
-    found=phyetat0_srf(delta_tsurf,"DELTATS","Delta Ts wk/env ",0.)
-!!    found=phyetat0_srf(beta_aridity,"BETA_S","Aridity factor ",1.)
-    found=phyetat0_srf(beta_aridity,"BETAS","Aridity factor ",1.)
-  ENDIF   !(iflag_pbl>1 .AND. iflag_wake>=1 .AND. iflag_pbl_split >=1 )
-
-!==================================
-!  thermiques, poches, convection
-!==================================
-
-! Emanuel
-  found=phyetat0_get(sig1,"sig1","sig1",0.)
-  found=phyetat0_get(w01,"w01","w01",0.)
-
-! Wake
-  found=phyetat0_get(wake_deltat,"WAKE_DELTAT","Delta T wake/env",0.)
-  found=phyetat0_get(wake_deltaq,"WAKE_DELTAQ","Delta hum. wake/env",0.)
-  found=phyetat0_get(wake_s,"WAKE_S","Wake frac. area",0.)
-  found=phyetat0_get(awake_s,"AWAKE_S","Active Wake frac. area",0.)
-!jyg<
-!  Set wake_dens to -1000. when there is no restart so that the actual
-!  initialization is made in calwake.
-!!  found=phyetat0_get(1,wake_dens,"WAKE_DENS","Wake num. /unit area",0.)
-  found=phyetat0_get(wake_dens,"WAKE_DENS","Wake num. /unit area",-1000.)
-  found=phyetat0_get(awake_dens,"AWAKE_DENS","Active Wake num. /unit area",0.)
-  found=phyetat0_get(cv_gen,"CV_GEN","CB birth rate",0.)
-!>jyg
-  found=phyetat0_get(wake_cstar,"WAKE_CSTAR","WAKE_CSTAR",0.)
-  found=phyetat0_get(wake_pe,"WAKE_PE","WAKE_PE",0.)
-  found=phyetat0_get(wake_fip,"WAKE_FIP","WAKE_FIP",0.)
-
-! Thermiques
-  found=phyetat0_get(zmax0,"ZMAX0","ZMAX0",40.)
-  found=phyetat0_get(f0,"F0","F0",1.e-5)
-  found=phyetat0_get(fm_therm,"FM_THERM","Thermals mass flux",0.)
-  found=phyetat0_get(entr_therm,"ENTR_THERM","Thermals Entrain.",0.)
-  found=phyetat0_get(detr_therm,"DETR_THERM","Thermals Detrain.",0.)
-
-! ALE/ALP
-  found=phyetat0_get(ale_bl,"ALE_BL","ALE BL",0.)
-  found=phyetat0_get(ale_bl_trig,"ALE_BL_TRIG","ALE BL_TRIG",0.)
-  found=phyetat0_get(alp_bl,"ALP_BL","ALP BL",0.)
-  found=phyetat0_get(ale_wake,"ALE_WAKE","ALE_WAKE",0.)
-  found=phyetat0_get(ale_bl_stat,"ALE_BL_STAT","ALE_BL_STAT",0.)
-
-! fisrtilp/Clouds 0.002 could be ratqsbas. But can stay like this as well
-  found=phyetat0_get(ratqs_inter_,"RATQS_INTER","Relative width of the lsc sugrid scale water",0.002)
-
-!===========================================
-  ! Read and send field trs to traclmdz
-!===========================================
-
-!--OB now this is for co2i - ThL: and therefore also for inco
-  IF (ANY(type_trac == ['co2i','inco'])) THEN
-     IF (carbon_cycle_cpl) THEN
-        ALLOCATE(co2_send(klon), stat=ierr)
-        IF (ierr /= 0) CALL abort_physic('phyetat0', 'pb allocation co2_send', 1)
-        found=phyetat0_get(co2_send,"co2_send","co2 send",co2_ppm0)
-     ENDIF
-  ELSE IF (type_trac == 'lmdz') THEN
-     it = 0
-     DO iq = 1, nqtot
-        IF(.NOT.(tracers(iq)%isAdvected .AND. tracers(iq)%isInPhysics)) CYCLE
-        it = it+1
-        tname = tracers(iq)%name
-        t(1) = 'trs_'//TRIM(tname); t(2) = 'trs_'//TRIM(new2oldH2O(tname))
-        found = phyetat0_get(trs(:,it), t(:), "Surf trac"//TRIM(tname), 0.)
-     END DO
-     CALL traclmdz_from_restart(trs)
-  ENDIF
-
-
-!===========================================
-!  ondes de gravite / relief
-!===========================================
-
-!  ondes de gravite non orographiques
-  IF (ok_gwd_rando) found = &
-       phyetat0_get(du_gwd_rando,"du_gwd_rando","du_gwd_rando",0.)
-  IF (.NOT. ok_hines .AND. ok_gwd_rando) found &
-       = phyetat0_get(du_gwd_front,"du_gwd_front","du_gwd_front",0.)
-
-!  prise en compte du relief sous-maille
-  found=phyetat0_get(zmea,"ZMEA","sub grid orography",0.)
-  found=phyetat0_get(zstd,"ZSTD","sub grid orography",0.)
-  found=phyetat0_get(zsig,"ZSIG","sub grid orography",0.)
-  found=phyetat0_get(zgam,"ZGAM","sub grid orography",0.)
-  found=phyetat0_get(zthe,"ZTHE","sub grid orography",0.)
-  found=phyetat0_get(zpic,"ZPIC","sub grid orography",0.)
-  found=phyetat0_get(zval,"ZVAL","sub grid orography",0.)
-  found=phyetat0_get(zmea,"ZMEA","sub grid orography",0.)
-  found=phyetat0_get(rugoro,"RUGSREL","sub grid orography",0.)
-
-!===========================================
-! Initialize ocean
-!===========================================
-
-  IF ( type_ocean == 'slab' ) THEN
-      CALL ocean_slab_init(phys_tstep, pctsrf)
-      IF (nslay.EQ.1) THEN
-        found=phyetat0_get(tslab,["tslab01","tslab  "],"tslab",0.)
-      ELSE
-          DO i=1,nslay
-            WRITE(str2,'(i2.2)') i
-            found=phyetat0_get(tslab(:,i),"tslab"//str2,"tslab",0.)  
-          ENDDO
-      ENDIF
-      IF (.NOT. found) THEN 
-          PRINT*, "phyetat0: Le champ <tslab> est absent"
-          PRINT*, "Initialisation a tsol_oce"
-          DO i=1,nslay
-              tslab(:,i)=MAX(ftsol(:,is_oce),271.35)
-          ENDDO
-      ENDIF 
-
-      ! Sea ice variables
-      IF (version_ocean == 'sicINT') THEN
-          found=phyetat0_get(tice,"slab_tice","slab_tice",0.)
-          IF (.NOT. found) THEN 
-              PRINT*, "phyetat0: Le champ <tice> est absent"
-              PRINT*, "Initialisation a tsol_sic"
-                  tice(:)=ftsol(:,is_sic)
-          ENDIF 
-          found=phyetat0_get(seaice,"seaice","seaice",0.)
-          IF (.NOT. found) THEN
-              PRINT*, "phyetat0: Le champ <seaice> est absent"
-              PRINT*, "Initialisation a 0/1m suivant fraction glace"
-              seaice(:)=0.
-              WHERE (pctsrf(:,is_sic).GT.EPSFRA)
-                  seaice=917.
-              ENDWHERE
-          ENDIF
-      ENDIF !sea ice INT
-  ENDIF ! Slab        
-
-  if (activate_ocean_skin >= 1) then
-     if (activate_ocean_skin == 2 .and. type_ocean == 'couple') then
-        found = phyetat0_get(delta_sal, "delta_sal", &
-             "ocean-air interface salinity minus bulk salinity", 0.)
-        found = phyetat0_get(delta_sst, "delta_SST", &
-             "ocean-air interface temperature minus bulk SST", 0.)
-        found = phyetat0_get(dter, "dter", &
-             "ocean-air interface temperature minus subskin temperature", 0.)
-        found = phyetat0_get(dser, "dser", &
-             "ocean-air interface salinity minus subskin salinity", 0.)
-        found = phyetat0_get(dt_ds, "dt_ds", "(tks / tkt) * dTer", 0.)
-
-        where (pctsrf(:, is_oce) == 0.)
-           delta_sst = missing_val
-           delta_sal = missing_val
-           dter = missing_val
-           dser = missing_val
-           dt_ds = missing_val
-        end where
-     end if
-     
-     found = phyetat0_get(ds_ns, "dS_ns", "delta salinity near surface", 0.)
-     found = phyetat0_get(dt_ns, "dT_ns", "delta temperature near surface", &
-          0.)
-
-     where (pctsrf(:, is_oce) == 0.)
-        ds_ns = missing_val
-        dt_ns = missing_val
-        delta_sst = missing_val
-        delta_sal = missing_val
-     end where
-  end if
-
-  ! on ferme le fichier
-  CALL close_startphy
-
-  ! Initialize module pbl_surface_mod 
-
-  if ( iflag_physiq <= 1 ) then
-  CALL pbl_surface_init(fder, snow, qsurf, tsoil)
-  endif
-
-  ! Initialize module ocean_cpl_mod for the case of coupled ocean
-  IF ( type_ocean == 'couple' ) THEN
-     CALL ocean_cpl_init(phys_tstep, longitude_deg, latitude_deg)
-  ENDIF
-
-!  CALL init_iophy_new(latitude_deg, longitude_deg)
-
-  ! Initilialize module fonte_neige_mod      
-  CALL fonte_neige_init(run_off_lic_0)
-
-END SUBROUTINE phyetat0
-
-END MODULE phyetat0_mod
-
Index: /LMDZ6/trunk/libf/phylmd/phyetat0_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/phyetat0_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/phyetat0_mod.f90	(revision 5268)
@@ -0,0 +1,657 @@
+! $Id$
+
+MODULE phyetat0_mod
+
+  PRIVATE
+  PUBLIC :: phyetat0
+
+CONTAINS
+
+SUBROUTINE phyetat0 (fichnom, clesphy0, tabcntr0)
+
+  USE dimphy, only: klon, zmasq, klev
+  USE iophy, ONLY : init_iophy_new
+  USE ocean_cpl_mod,    ONLY : ocean_cpl_init
+  USE fonte_neige_mod,  ONLY : fonte_neige_init
+  USE pbl_surface_mod,  ONLY : pbl_surface_init
+  USE surface_data,     ONLY : type_ocean, version_ocean
+  USE phyetat0_get_mod, ONLY : phyetat0_get, phyetat0_srf
+  USE phys_state_var_mod, ONLY : ancien_ok, clwcon, detr_therm, phys_tstep, &
+       qsol, fevap, z0m, z0h, agesno, &
+       du_gwd_rando, du_gwd_front, entr_therm, f0, fm_therm, &
+       falb_dir, falb_dif, prw_ancien, prlw_ancien, prsw_ancien, prbsw_ancien, &
+       ftsol, pbl_tke, pctsrf, q_ancien, ql_ancien, qs_ancien, qbs_ancien, &
+       cf_ancien, rvc_ancien, radpas, radsol, rain_fall, ratqs, &
+       rnebcon, rugoro, sig1, snow_fall, bs_fall, solaire_etat0, sollw, sollwdown, &
+       solsw, solswfdiff, t_ancien, u_ancien, v_ancien, w01, wake_cstar, wake_deltaq, &
+       wake_deltat, wake_delta_pbl_TKE, delta_tsurf, beta_aridity, wake_fip, wake_pe, &
+       wake_s, awake_s, wake_dens, awake_dens, cv_gen, zgam, zmax0, zmea, zpic, zsig, &
+       zstd, zthe, zval, ale_bl, ale_bl_trig, alp_bl, u10m, v10m, treedrg, &
+       ale_wake, ale_bl_stat, ds_ns, dt_ns, delta_sst, delta_sal, dter, dser, &
+       dt_ds, ratqs_inter_
+!FC
+  USE geometry_mod,     ONLY: longitude_deg, latitude_deg
+  USE iostart,          ONLY: close_startphy, get_field, get_var, open_startphy
+  USE infotrac_phy,     ONLY: nqtot, nbtr, type_trac, tracers, new2oldH2O
+  USE strings_mod,      ONLY: maxlen
+  USE traclmdz_mod,     ONLY: traclmdz_from_restart
+  USE carbon_cycle_mod, ONLY: carbon_cycle_init, carbon_cycle_cpl, carbon_cycle_tr, carbon_cycle_rad, co2_send, RCO2_glo
+  USE indice_sol_mod,   ONLY: nbsrf, is_ter, epsfra, is_lic, is_oce, is_sic
+  USE ocean_slab_mod,   ONLY: nslay, tslab, seaice, tice, ocean_slab_init
+  USE time_phylmdz_mod, ONLY: init_iteration, pdtphys, itau_phy
+  USE wxios, ONLY: missing_val_xios => missing_val, using_xios
+  use netcdf, only: missing_val_netcdf => nf90_fill_real
+  use config_ocean_skin_m, only: activate_ocean_skin
+
+  IMPLICIT none
+  !======================================================================
+  ! Auteur(s) Z.X. Li (LMD/CNRS) date: 19930818
+  ! Objet: Lecture de l'etat initial pour la physique
+  !======================================================================
+  include "dimsoil.h"
+  include "clesphys.h"
+  include "alpale.h"
+  include "compbl.h"
+  include "YOMCST.h"
+  !======================================================================
+  CHARACTER*(*) fichnom
+
+  ! les variables globales lues dans le fichier restart
+
+  REAL tsoil(klon, nsoilmx, nbsrf)
+  REAL qsurf(klon, nbsrf)
+  REAL snow(klon, nbsrf)
+  real fder(klon)
+  REAL run_off_lic_0(klon)
+  REAL fractint(klon)
+  REAL trs(klon, nbtr)
+  REAL zts(klon)
+  ! pour drag arbres FC
+  REAL drg_ter(klon,klev)
+
+  CHARACTER*6 ocean_in
+  LOGICAL ok_veget_in
+
+  INTEGER        longcles
+  PARAMETER    ( longcles = 20 )
+  REAL clesphy0( longcles )
+
+  REAL xmin, xmax
+
+  INTEGER nid, nvarid
+  INTEGER ierr, i, nsrf, isoil , k
+  INTEGER length
+  PARAMETER (length=100)
+  INTEGER it, iq, isw
+  REAL tab_cntrl(length), tabcntr0(length)
+  CHARACTER*7 str7
+  CHARACTER*2 str2
+  LOGICAL :: found
+  REAL :: lon_startphy(klon), lat_startphy(klon)
+  CHARACTER(LEN=maxlen) :: tname, t(2)
+  REAL :: missing_val
+
+  IF (using_xios) THEN
+    missing_val=missing_val_xios
+  ELSE
+    missing_val=missing_val_netcdf
+  ENDIF
+  
+  ! FH1D
+  !     real iolat(jjm+1)
+  !real iolat(jjm+1-1/(iim*jjm))
+
+  ! Ouvrir le fichier contenant l'etat initial:
+
+  CALL open_startphy(fichnom)
+
+  ! Lecture des parametres de controle:
+
+  CALL get_var("controle", tab_cntrl)
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+  ! FH 2008/05/09 On elimine toutes les clefs physiques dans la dynamique
+  ! Les constantes de la physiques sont lues dans la physique seulement.
+  ! Les egalites du type
+  !             tab_cntrl( 5 )=clesphy0(1)
+  ! sont remplacees par
+  !             clesphy0(1)=tab_cntrl( 5 )
+  ! On inverse aussi la logique.
+  ! On remplit les tab_cntrl avec les parametres lus dans les .def
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+  DO i = 1, length
+     tabcntr0( i ) = tab_cntrl( i )
+  ENDDO
+
+  tab_cntrl(1)=pdtphys
+  tab_cntrl(2)=radpas
+
+  ! co2_ppm : value from the previous time step
+
+  ! co2_ppm0 : initial value of atmospheric CO2 (from create_etat0_limit.e .def)
+  co2_ppm0 = 284.32
+  ! when no initial value is available e.g., from a restart 
+  ! this variable must be set  in a .def file which will then be 
+  ! used by the conf_phys_m.F90 routine.
+  ! co2_ppm0 = 284.32 (illustrative example on how to set the variable in .def
+  ! file, for a pre-industrial CO2 concentration value)
+
+  IF (carbon_cycle_tr .OR. carbon_cycle_cpl) THEN
+     co2_ppm = tab_cntrl(3)
+     RCO2    = co2_ppm * 1.0e-06 * RMCO2 / RMD
+     IF (tab_cntrl(17) > 0. .AND. carbon_cycle_rad) THEN
+           RCO2_glo = tab_cntrl(17)
+       ELSE
+           RCO2_glo    = co2_ppm0 * 1.0e-06 * RMCO2 / RMD
+     ENDIF
+     ! ELSE : keep value from .def
+  ENDIF
+
+  solaire_etat0      = tab_cntrl(4)
+  tab_cntrl(5)=iflag_con
+  tab_cntrl(6)=nbapp_rad
+
+  IF (iflag_cycle_diurne.GE.1) tab_cntrl( 7) = iflag_cycle_diurne
+  IF (soil_model) tab_cntrl( 8) =1.
+  IF (new_oliq) tab_cntrl( 9) =1.
+  IF (ok_orodr) tab_cntrl(10) =1.
+  IF (ok_orolf) tab_cntrl(11) =1.
+  IF (ok_limitvrai) tab_cntrl(12) =1.
+
+  itau_phy = tab_cntrl(15)
+
+  clesphy0(1)=tab_cntrl( 5 )
+  clesphy0(2)=tab_cntrl( 6 )
+  clesphy0(3)=tab_cntrl( 7 )
+  clesphy0(4)=tab_cntrl( 8 )
+  clesphy0(5)=tab_cntrl( 9 )
+  clesphy0(6)=tab_cntrl( 10 )
+  clesphy0(7)=tab_cntrl( 11 )
+  clesphy0(8)=tab_cntrl( 12 )
+  clesphy0(9)=tab_cntrl( 17 )
+
+  ! set time iteration
+   CALL init_iteration(itau_phy)
+
+  ! read latitudes and make a sanity check (because already known from dyn)
+  CALL get_field("latitude",lat_startphy)
+  DO i=1,klon
+    IF (ABS(lat_startphy(i)-latitude_deg(i))>=1) THEN
+      WRITE(*,*) "phyetat0: Error! Latitude discrepancy wrt startphy file:",&
+                 " i=",i," lat_startphy(i)=",lat_startphy(i),&
+                 " latitude_deg(i)=",latitude_deg(i)
+      ! This is presumably serious enough to abort run
+      CALL abort_physic("phyetat0","discrepancy in latitudes!",1)
+    ENDIF
+    IF (ABS(lat_startphy(i)-latitude_deg(i))>=0.0001) THEN
+      WRITE(*,*) "phyetat0: Warning! Latitude discrepancy wrt startphy file:",&
+                 " i=",i," lat_startphy(i)=",lat_startphy(i),&
+                 " latitude_deg(i)=",latitude_deg(i)
+    ENDIF
+  ENDDO
+
+  ! read longitudes and make a sanity check (because already known from dyn)
+  CALL get_field("longitude",lon_startphy)
+  DO i=1,klon
+    IF (ABS(lon_startphy(i)-longitude_deg(i))>=1) THEN
+      IF (ABS(360-ABS(lon_startphy(i)-longitude_deg(i)))>=1) THEN
+        WRITE(*,*) "phyetat0: Error! Longitude discrepancy wrt startphy file:",&
+                   " i=",i," lon_startphy(i)=",lon_startphy(i),&
+                   " longitude_deg(i)=",longitude_deg(i)
+        ! This is presumably serious enough to abort run
+        CALL abort_physic("phyetat0","discrepancy in longitudes!",1)
+      ENDIF
+    ENDIF
+    IF (ABS(lon_startphy(i)-longitude_deg(i))>=1) THEN
+      IF (ABS(360-ABS(lon_startphy(i)-longitude_deg(i))) > 0.0001) THEN
+        WRITE(*,*) "phyetat0: Warning! Longitude discrepancy wrt startphy file:",&
+                   " i=",i," lon_startphy(i)=",lon_startphy(i),&
+                   " longitude_deg(i)=",longitude_deg(i)
+      ENDIF 
+    ENDIF
+  ENDDO
+
+  ! Lecture du masque terre mer
+
+  CALL get_field("masque", zmasq, found)
+  IF (.NOT. found) THEN
+     PRINT*, 'phyetat0: Le champ <masque> est absent'
+     PRINT *, 'fichier startphy non compatible avec phyetat0'
+  ENDIF
+
+  ! Lecture des fractions pour chaque sous-surface
+
+  ! initialisation des sous-surfaces
+
+  pctsrf = 0.
+
+  ! fraction de terre
+
+  CALL get_field("FTER", pctsrf(:, is_ter), found)
+  IF (.NOT. found) PRINT*, 'phyetat0: Le champ <FTER> est absent'
+
+  ! fraction de glace de terre
+
+  CALL get_field("FLIC", pctsrf(:, is_lic), found)
+  IF (.NOT. found) PRINT*, 'phyetat0: Le champ <FLIC> est absent'
+
+  ! fraction d'ocean
+
+  CALL get_field("FOCE", pctsrf(:, is_oce), found)
+  IF (.NOT. found) PRINT*, 'phyetat0: Le champ <FOCE> est absent'
+
+  ! fraction glace de mer
+
+  CALL get_field("FSIC", pctsrf(:, is_sic), found)
+  IF (.NOT. found) PRINT*, 'phyetat0: Le champ <FSIC> est absent'
+
+  !  Verification de l'adequation entre le masque et les sous-surfaces
+
+  fractint( 1 : klon) = pctsrf(1 : klon, is_ter)  &
+       + pctsrf(1 : klon, is_lic)
+  DO i = 1 , klon
+     IF ( abs(fractint(i) - zmasq(i) ) .GT. EPSFRA ) THEN
+        WRITE(*, *) 'phyetat0: attention fraction terre pas ',  &
+             'coherente ', i, zmasq(i), pctsrf(i, is_ter) &
+             , pctsrf(i, is_lic)
+        WRITE(*, *) 'Je force la coherence zmasq=fractint'
+        zmasq(i) = fractint(i)
+     ENDIF
+  ENDDO
+  fractint (1 : klon) =  pctsrf(1 : klon, is_oce)  &
+       + pctsrf(1 : klon, is_sic)
+  DO i = 1 , klon
+     IF ( abs( fractint(i) - (1. - zmasq(i))) .GT. EPSFRA ) THEN
+        WRITE(*, *) 'phyetat0 attention fraction ocean pas ',  &
+             'coherente ', i, zmasq(i) , pctsrf(i, is_oce) &
+             , pctsrf(i, is_sic)
+        WRITE(*, *) 'Je force la coherence zmasq=1.-fractint'
+        zmasq(i) = 1. - fractint(i)
+     ENDIF
+  ENDDO
+
+!===================================================================
+! Lecture des temperatures du sol:
+!===================================================================
+
+  found=phyetat0_get(ftsol(:,1),"TS","Surface temperature",283.)
+  IF (found) THEN
+     DO nsrf=2,nbsrf
+        ftsol(:,nsrf)=ftsol(:,1)
+     ENDDO
+  ELSE
+     found=phyetat0_srf(ftsol,"TS","Surface temperature",283.)
+  ENDIF
+
+!===================================================================
+  ! Lecture des albedo difus et direct
+!===================================================================
+
+  DO nsrf = 1, nbsrf
+     DO isw=1, nsw
+        IF (isw.GT.99) THEN
+           PRINT*, "Trop de bandes SW"
+           call abort_physic("phyetat0", "", 1)
+        ENDIF
+        WRITE(str2, '(i2.2)') isw
+        found=phyetat0_srf(falb_dir(:, isw,:),"A_dir_SW"//str2//"srf","Direct Albedo",0.2)
+        found=phyetat0_srf(falb_dif(:, isw,:),"A_dif_SW"//str2//"srf","Direct Albedo",0.2)
+     ENDDO
+  ENDDO
+
+  found=phyetat0_srf(u10m,"U10M","u a 10m",0.)
+  found=phyetat0_srf(v10m,"V10M","v a 10m",0.)
+
+!===================================================================
+! Lecture dans le cas iflag_pbl_surface =1
+!===================================================================
+
+   if ( iflag_physiq <= 1 ) then
+!===================================================================
+  ! Lecture des temperatures du sol profond:
+!===================================================================
+
+   DO isoil=1, nsoilmx
+        IF (isoil.GT.99) THEN
+           PRINT*, "Trop de couches "
+           call abort_physic("phyetat0", "", 1)
+        ENDIF
+        WRITE(str2,'(i2.2)') isoil
+        found=phyetat0_srf(tsoil(:, isoil,:),"Tsoil"//str2//"srf","Temp soil",0.)
+        IF (.NOT. found) THEN
+           PRINT*, "phyetat0: Le champ <Tsoil"//str7//"> est absent"
+           PRINT*, "          Il prend donc la valeur de surface"
+           tsoil(:, isoil, :)=ftsol(:, :)
+        ENDIF
+   ENDDO
+
+!=======================================================================
+! Lecture precipitation/evaporation
+!=======================================================================
+
+  found=phyetat0_srf(qsurf,"QS","Near surface hmidity",0.)
+  found=phyetat0_get(qsol,"QSOL","Surface hmidity / bucket",0.)
+  found=phyetat0_srf(snow,"SNOW","Surface snow",0.)
+  found=phyetat0_srf(fevap,"EVAP","evaporation",0.)
+  found=phyetat0_get(snow_fall,"snow_f","snow fall",0.)
+  found=phyetat0_get(rain_fall,"rain_f","rain fall",0.)
+  IF (ok_bs) THEN
+     found=phyetat0_get(bs_fall,"bs_f","blowing snow fall",0.)
+  ELSE
+     bs_fall(:)=0.
+  ENDIF
+!=======================================================================
+! Radiation
+!=======================================================================
+
+  found=phyetat0_get(solsw,"solsw","net SW radiation surf",0.)
+  found=phyetat0_get(solswfdiff,"solswfdiff","fraction of SW radiation surf that is diffuse",1.)
+  found=phyetat0_get(sollw,"sollw","net LW radiation surf",0.)
+  found=phyetat0_get(sollwdown,"sollwdown","down LW radiation surf",0.)
+  IF (.NOT. found) THEN
+     sollwdown(:) = 0. ;  zts(:)=0.
+     DO nsrf=1,nbsrf
+        zts(:)=zts(:)+ftsol(:,nsrf)*pctsrf(:,nsrf)
+     ENDDO
+     sollwdown(:)=sollw(:)+RSIGMA*zts(:)**4
+  ENDIF
+
+  found=phyetat0_get(radsol,"RADS","Solar radiation",0.)
+  found=phyetat0_get(fder,"fder","Flux derivative",0.) 
+
+
+  ! Lecture de la longueur de rugosite 
+  found=phyetat0_srf(z0m,"RUG","Z0m ancien",0.001)
+  IF (found) THEN
+     z0h(:,1:nbsrf)=z0m(:,1:nbsrf)
+  ELSE
+     found=phyetat0_srf(z0m,"Z0m","Roughness length, momentum ",0.001)
+     found=phyetat0_srf(z0h,"Z0h","Roughness length, enthalpy ",0.001)
+  ENDIF
+!FC
+  IF (ifl_pbltree>0) THEN
+!CALL get_field("FTER", pctsrf(:, is_ter), found)
+    treedrg(:,1:klev,1:nbsrf)= 0.0
+    CALL get_field("treedrg_ter", drg_ter(:,:), found)
+!  found=phyetat0_srf(treedrg,"treedrg","drag from vegetation" , 0.)
+    !lecture du profile de freinage des arbres
+    IF (.not. found ) THEN
+      treedrg(:,1:klev,1:nbsrf)= 0.0
+    ELSE
+      treedrg(:,1:klev,is_ter)= drg_ter(:,:)
+!     found=phyetat0_get(treedrg,"treedrg","freinage arbres",0.)
+    ENDIF
+  ELSE
+    ! initialize treedrg(), because it will be written in restartphy.nc
+    treedrg(:,:,:) = 0.0 
+  ENDIF
+
+  endif ! iflag_physiq <= 1
+
+  ! Lecture de l'age de la neige:
+  found=phyetat0_srf(agesno,"AGESNO","SNOW AGE",0.001)
+
+  ancien_ok=.true.
+  ancien_ok=ancien_ok.AND.phyetat0_get(t_ancien,"TANCIEN","TANCIEN",0.)
+  ancien_ok=ancien_ok.AND.phyetat0_get(q_ancien,"QANCIEN","QANCIEN",0.)
+  ancien_ok=ancien_ok.AND.phyetat0_get(ql_ancien,"QLANCIEN","QLANCIEN",0.)
+  ancien_ok=ancien_ok.AND.phyetat0_get(qs_ancien,"QSANCIEN","QSANCIEN",0.)
+  ancien_ok=ancien_ok.AND.phyetat0_get(u_ancien,"UANCIEN","UANCIEN",0.)
+  ancien_ok=ancien_ok.AND.phyetat0_get(v_ancien,"VANCIEN","VANCIEN",0.)
+  ancien_ok=ancien_ok.AND.phyetat0_get(prw_ancien,"PRWANCIEN","PRWANCIEN",0.)
+  ancien_ok=ancien_ok.AND.phyetat0_get(prlw_ancien,"PRLWANCIEN","PRLWANCIEN",0.)
+  ancien_ok=ancien_ok.AND.phyetat0_get(prsw_ancien,"PRSWANCIEN","PRSWANCIEN",0.)
+
+  ! cas specifique des variables de la neige soufflee
+  IF (ok_bs) THEN
+     ancien_ok=ancien_ok.AND.phyetat0_get(qbs_ancien,"QBSANCIEN","QBSANCIEN",0.)
+     ancien_ok=ancien_ok.AND.phyetat0_get(prbsw_ancien,"PRBSWANCIEN","PRBSWANCIEN",0.)
+  ELSE
+     qbs_ancien(:,:)=0.
+     prbsw_ancien(:)=0.
+  ENDIF
+  
+  ! cas specifique des variables de la sursaturation par rapport a la glace
+  IF ( ok_ice_supersat ) THEN
+    ancien_ok=ancien_ok.AND.phyetat0_get(cf_ancien,"CFANCIEN","CFANCIEN",0.)
+    ancien_ok=ancien_ok.AND.phyetat0_get(rvc_ancien,"RVCANCIEN","RVCANCIEN",0.)
+  ELSE
+    cf_ancien(:,:)=0.
+    rvc_ancien(:,:)=0.
+  ENDIF
+
+  ! Ehouarn: addtional tests to check if t_ancien, q_ancien contain
+  !          dummy values (as is the case when generated by ce0l,
+  !          or by iniaqua)
+  IF ( (maxval(q_ancien).EQ.minval(q_ancien))       .OR. &
+       (maxval(ql_ancien).EQ.minval(ql_ancien))     .OR. &
+       (maxval(qs_ancien).EQ.minval(qs_ancien))     .OR. &
+       (maxval(prw_ancien).EQ.minval(prw_ancien))   .OR. &
+       (maxval(prlw_ancien).EQ.minval(prlw_ancien)) .OR. &
+       (maxval(prsw_ancien).EQ.minval(prsw_ancien)) .OR. &
+       (maxval(t_ancien).EQ.minval(t_ancien)) ) THEN
+    ancien_ok=.false.
+  ENDIF
+
+  IF (ok_bs) THEN
+    IF ( (maxval(qbs_ancien).EQ.minval(qbs_ancien))       .OR. &
+         (maxval(prbsw_ancien).EQ.minval(prbsw_ancien)) ) THEN
+       ancien_ok=.false.
+    ENDIF
+  ENDIF
+
+  IF ( ok_ice_supersat ) THEN
+    IF ( (maxval(cf_ancien).EQ.minval(cf_ancien))     .OR. &
+         (maxval(rvc_ancien).EQ.minval(rvc_ancien)) ) THEN
+       ancien_ok=.false.
+     ENDIF
+  ENDIF
+
+  found=phyetat0_get(clwcon,"CLWCON","CLWCON",0.)
+  found=phyetat0_get(rnebcon,"RNEBCON","RNEBCON",0.)
+  found=phyetat0_get(ratqs,"RATQS","RATQS",0.)
+
+  found=phyetat0_get(run_off_lic_0,"RUNOFFLIC0","RUNOFFLIC0",0.)
+
+!==================================
+!  TKE
+!==================================
+!
+  IF (iflag_pbl>1) then
+     found=phyetat0_srf(pbl_tke,"TKE","Turb. Kinetic. Energ. ",1.e-8)
+  ENDIF
+
+  IF (iflag_pbl>1 .AND. iflag_wake>=1  .AND. iflag_pbl_split >=1 ) then
+    found=phyetat0_srf(wake_delta_pbl_tke,"DELTATKE","Del TKE wk/env",0.)
+!!    found=phyetat0_srf(delta_tsurf,"DELTA_TSURF","Delta Ts wk/env ",0.)
+    found=phyetat0_srf(delta_tsurf,"DELTATS","Delta Ts wk/env ",0.)
+!!    found=phyetat0_srf(beta_aridity,"BETA_S","Aridity factor ",1.)
+    found=phyetat0_srf(beta_aridity,"BETAS","Aridity factor ",1.)
+  ENDIF   !(iflag_pbl>1 .AND. iflag_wake>=1 .AND. iflag_pbl_split >=1 )
+
+!==================================
+!  thermiques, poches, convection
+!==================================
+
+! Emanuel
+  found=phyetat0_get(sig1,"sig1","sig1",0.)
+  found=phyetat0_get(w01,"w01","w01",0.)
+
+! Wake
+  found=phyetat0_get(wake_deltat,"WAKE_DELTAT","Delta T wake/env",0.)
+  found=phyetat0_get(wake_deltaq,"WAKE_DELTAQ","Delta hum. wake/env",0.)
+  found=phyetat0_get(wake_s,"WAKE_S","Wake frac. area",0.)
+  found=phyetat0_get(awake_s,"AWAKE_S","Active Wake frac. area",0.)
+!jyg<
+!  Set wake_dens to -1000. when there is no restart so that the actual
+!  initialization is made in calwake.
+!!  found=phyetat0_get(1,wake_dens,"WAKE_DENS","Wake num. /unit area",0.)
+  found=phyetat0_get(wake_dens,"WAKE_DENS","Wake num. /unit area",-1000.)
+  found=phyetat0_get(awake_dens,"AWAKE_DENS","Active Wake num. /unit area",0.)
+  found=phyetat0_get(cv_gen,"CV_GEN","CB birth rate",0.)
+!>jyg
+  found=phyetat0_get(wake_cstar,"WAKE_CSTAR","WAKE_CSTAR",0.)
+  found=phyetat0_get(wake_pe,"WAKE_PE","WAKE_PE",0.)
+  found=phyetat0_get(wake_fip,"WAKE_FIP","WAKE_FIP",0.)
+
+! Thermiques
+  found=phyetat0_get(zmax0,"ZMAX0","ZMAX0",40.)
+  found=phyetat0_get(f0,"F0","F0",1.e-5)
+  found=phyetat0_get(fm_therm,"FM_THERM","Thermals mass flux",0.)
+  found=phyetat0_get(entr_therm,"ENTR_THERM","Thermals Entrain.",0.)
+  found=phyetat0_get(detr_therm,"DETR_THERM","Thermals Detrain.",0.)
+
+! ALE/ALP
+  found=phyetat0_get(ale_bl,"ALE_BL","ALE BL",0.)
+  found=phyetat0_get(ale_bl_trig,"ALE_BL_TRIG","ALE BL_TRIG",0.)
+  found=phyetat0_get(alp_bl,"ALP_BL","ALP BL",0.)
+  found=phyetat0_get(ale_wake,"ALE_WAKE","ALE_WAKE",0.)
+  found=phyetat0_get(ale_bl_stat,"ALE_BL_STAT","ALE_BL_STAT",0.)
+
+! fisrtilp/Clouds 0.002 could be ratqsbas. But can stay like this as well
+  found=phyetat0_get(ratqs_inter_,"RATQS_INTER","Relative width of the lsc sugrid scale water",0.002)
+
+!===========================================
+  ! Read and send field trs to traclmdz
+!===========================================
+
+!--OB now this is for co2i - ThL: and therefore also for inco
+  IF (ANY(type_trac == ['co2i','inco'])) THEN
+     IF (carbon_cycle_cpl) THEN
+        ALLOCATE(co2_send(klon), stat=ierr)
+        IF (ierr /= 0) CALL abort_physic('phyetat0', 'pb allocation co2_send', 1)
+        found=phyetat0_get(co2_send,"co2_send","co2 send",co2_ppm0)
+     ENDIF
+  ELSE IF (type_trac == 'lmdz') THEN
+     it = 0
+     DO iq = 1, nqtot
+        IF(.NOT.(tracers(iq)%isAdvected .AND. tracers(iq)%isInPhysics)) CYCLE
+        it = it+1
+        tname = tracers(iq)%name
+        t(1) = 'trs_'//TRIM(tname); t(2) = 'trs_'//TRIM(new2oldH2O(tname))
+        found = phyetat0_get(trs(:,it), t(:), "Surf trac"//TRIM(tname), 0.)
+     END DO
+     CALL traclmdz_from_restart(trs)
+  ENDIF
+
+
+!===========================================
+!  ondes de gravite / relief
+!===========================================
+
+!  ondes de gravite non orographiques
+  IF (ok_gwd_rando) found = &
+       phyetat0_get(du_gwd_rando,"du_gwd_rando","du_gwd_rando",0.)
+  IF (.NOT. ok_hines .AND. ok_gwd_rando) found &
+       = phyetat0_get(du_gwd_front,"du_gwd_front","du_gwd_front",0.)
+
+!  prise en compte du relief sous-maille
+  found=phyetat0_get(zmea,"ZMEA","sub grid orography",0.)
+  found=phyetat0_get(zstd,"ZSTD","sub grid orography",0.)
+  found=phyetat0_get(zsig,"ZSIG","sub grid orography",0.)
+  found=phyetat0_get(zgam,"ZGAM","sub grid orography",0.)
+  found=phyetat0_get(zthe,"ZTHE","sub grid orography",0.)
+  found=phyetat0_get(zpic,"ZPIC","sub grid orography",0.)
+  found=phyetat0_get(zval,"ZVAL","sub grid orography",0.)
+  found=phyetat0_get(zmea,"ZMEA","sub grid orography",0.)
+  found=phyetat0_get(rugoro,"RUGSREL","sub grid orography",0.)
+
+!===========================================
+! Initialize ocean
+!===========================================
+
+  IF ( type_ocean == 'slab' ) THEN
+      CALL ocean_slab_init(phys_tstep, pctsrf)
+      IF (nslay.EQ.1) THEN
+        found=phyetat0_get(tslab,["tslab01","tslab  "],"tslab",0.)
+      ELSE
+          DO i=1,nslay
+            WRITE(str2,'(i2.2)') i
+            found=phyetat0_get(tslab(:,i),"tslab"//str2,"tslab",0.)  
+          ENDDO
+      ENDIF
+      IF (.NOT. found) THEN 
+          PRINT*, "phyetat0: Le champ <tslab> est absent"
+          PRINT*, "Initialisation a tsol_oce"
+          DO i=1,nslay
+              tslab(:,i)=MAX(ftsol(:,is_oce),271.35)
+          ENDDO
+      ENDIF 
+
+      ! Sea ice variables
+      IF (version_ocean == 'sicINT') THEN
+          found=phyetat0_get(tice,"slab_tice","slab_tice",0.)
+          IF (.NOT. found) THEN 
+              PRINT*, "phyetat0: Le champ <tice> est absent"
+              PRINT*, "Initialisation a tsol_sic"
+                  tice(:)=ftsol(:,is_sic)
+          ENDIF 
+          found=phyetat0_get(seaice,"seaice","seaice",0.)
+          IF (.NOT. found) THEN
+              PRINT*, "phyetat0: Le champ <seaice> est absent"
+              PRINT*, "Initialisation a 0/1m suivant fraction glace"
+              seaice(:)=0.
+              WHERE (pctsrf(:,is_sic).GT.EPSFRA)
+                  seaice=917.
+              ENDWHERE
+          ENDIF
+      ENDIF !sea ice INT
+  ENDIF ! Slab        
+
+  if (activate_ocean_skin >= 1) then
+     if (activate_ocean_skin == 2 .and. type_ocean == 'couple') then
+        found = phyetat0_get(delta_sal, "delta_sal", &
+             "ocean-air interface salinity minus bulk salinity", 0.)
+        found = phyetat0_get(delta_sst, "delta_SST", &
+             "ocean-air interface temperature minus bulk SST", 0.)
+        found = phyetat0_get(dter, "dter", &
+             "ocean-air interface temperature minus subskin temperature", 0.)
+        found = phyetat0_get(dser, "dser", &
+             "ocean-air interface salinity minus subskin salinity", 0.)
+        found = phyetat0_get(dt_ds, "dt_ds", "(tks / tkt) * dTer", 0.)
+
+        where (pctsrf(:, is_oce) == 0.)
+           delta_sst = missing_val
+           delta_sal = missing_val
+           dter = missing_val
+           dser = missing_val
+           dt_ds = missing_val
+        end where
+     end if
+     
+     found = phyetat0_get(ds_ns, "dS_ns", "delta salinity near surface", 0.)
+     found = phyetat0_get(dt_ns, "dT_ns", "delta temperature near surface", &
+          0.)
+
+     where (pctsrf(:, is_oce) == 0.)
+        ds_ns = missing_val
+        dt_ns = missing_val
+        delta_sst = missing_val
+        delta_sal = missing_val
+     end where
+  end if
+
+  ! on ferme le fichier
+  CALL close_startphy
+
+  ! Initialize module pbl_surface_mod 
+
+  if ( iflag_physiq <= 1 ) then
+  CALL pbl_surface_init(fder, snow, qsurf, tsoil)
+  endif
+
+  ! Initialize module ocean_cpl_mod for the case of coupled ocean
+  IF ( type_ocean == 'couple' ) THEN
+     CALL ocean_cpl_init(phys_tstep, longitude_deg, latitude_deg)
+  ENDIF
+
+!  CALL init_iophy_new(latitude_deg, longitude_deg)
+
+  ! Initilialize module fonte_neige_mod      
+  CALL fonte_neige_init(run_off_lic_0)
+
+END SUBROUTINE phyetat0
+
+END MODULE phyetat0_mod
+
Index: DZ6/trunk/libf/phylmd/phyredem.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/phyredem.F90	(revision 5267)
+++ 	(revision )
@@ -1,471 +1,0 @@
-!
-! $Id$
-!
-SUBROUTINE phyredem (fichnom)
-!
-!-------------------------------------------------------------------------------
-! Author: Z.X. Li (LMD/CNRS), 1993/08/18
-!-------------------------------------------------------------------------------
-! Purpose: Write restart state for physics.
-!-------------------------------------------------------------------------------
-  USE dimphy, ONLY: klon, klev
-  USE fonte_neige_mod,  ONLY : fonte_neige_final
-  USE pbl_surface_mod,  ONLY : pbl_surface_final
-  USE phys_state_var_mod, ONLY: radpas, zmasq, pctsrf,                       &
-                                ftsol, beta_aridity, delta_tsurf, falb_dir,  &
-                                falb_dif, qsol, fevap, radsol, solsw, sollw, &
-                                sollwdown, rain_fall, snow_fall, bs_fall, z0m, z0h, &
-                                agesno, zmea, zstd, zsig, zgam, zthe, zpic,  &
-                                zval, rugoro, t_ancien, q_ancien,            &
-                                prw_ancien, prlw_ancien, prsw_ancien, prbsw_ancien,      &
-                                ql_ancien, qs_ancien, qbs_ancien, cf_ancien, &
-                                rvc_ancien, u_ancien, v_ancien,              &
-                                clwcon, rnebcon, ratqs, pbl_tke,             &
-                                wake_delta_pbl_tke, zmax0, f0, sig1, w01,    &
-                                wake_deltat, wake_deltaq, wake_s, awake_s,   &
-                                wake_dens, awake_dens, cv_gen,               &
-                                wake_cstar,                                  &
-                                wake_pe, wake_fip, fm_therm, entr_therm,     &
-                                detr_therm, ale_bl, ale_bl_trig, alp_bl,     &
-                                ale_wake, ale_bl_stat,                       &
-                                du_gwd_rando, du_gwd_front, u10m, v10m, &
-                                treedrg, solswfdiff, delta_sal, ds_ns, dt_ns, &
-                                delta_sst, ratqs_inter_, dter, dser, dt_ds
-
-  USE geometry_mod, ONLY : longitude_deg, latitude_deg
-  USE iostart, ONLY: open_restartphy, close_restartphy, enddef_restartphy, put_field, put_var
-  USE traclmdz_mod, ONLY : traclmdz_to_restart
-  USE infotrac_phy, ONLY: type_trac, nqtot, tracers, nbtr
-  USE carbon_cycle_mod, ONLY : carbon_cycle_cpl, co2_send, carbon_cycle_rad, RCO2_glo
-  USE indice_sol_mod, ONLY: nbsrf, is_oce, is_sic, is_ter, is_lic, epsfra
-  USE surface_data, ONLY: type_ocean, version_ocean
-  USE ocean_slab_mod, ONLY : nslay, tslab, seaice, tice, fsic
-  USE time_phylmdz_mod, ONLY: annee_ref, day_end, itau_phy, pdtphys
-  use config_ocean_skin_m, only: activate_ocean_skin  
-
-  IMPLICIT none
-
-  include "dimsoil.h"
-  include "clesphys.h"
-  include "alpale.h"
-  include "compbl.h"
-  !======================================================================
-  CHARACTER*(*) fichnom
-
-  ! les variables globales ecrites dans le fichier restart
-
-  REAL tsoil(klon, nsoilmx, nbsrf)
-  REAL qsurf(klon, nbsrf)
-  REAL snow(klon, nbsrf)
-  real fder(klon)
-  REAL run_off_lic_0(klon)
-  REAL trs(klon, nbtr)
-
-  INTEGER nid, nvarid, idim1, idim2, idim3
-  INTEGER ierr
-  INTEGER length
-  PARAMETER (length=100)
-  REAL tab_cntrl(length)
-
-  INTEGER isoil, nsrf,isw
-  CHARACTER (len=2) :: str2
-  CHARACTER (len=256) :: nam, lnam
-  INTEGER           :: it, iq, pass
-
-  !======================================================================
-
-  ! Get variables which will be written to restart file from module 
-  ! pbl_surface_mod
-  if ( iflag_physiq <= 1 ) then
-     CALL pbl_surface_final(fder, snow, qsurf,  tsoil)
-  endif
-
-  ! Get a variable calculated in module fonte_neige_mod
-  CALL fonte_neige_final(run_off_lic_0)
-
-  !======================================================================
-
-  CALL open_restartphy(fichnom)
-
-  
-  DO ierr = 1, length
-     tab_cntrl(ierr) = 0.0
-  ENDDO
-  tab_cntrl(1) = pdtphys
-  tab_cntrl(2) = radpas
-  ! co2_ppm : current value of atmospheric CO2
-  tab_cntrl(3) = co2_ppm
-  tab_cntrl(4) = solaire
-  tab_cntrl(5) = iflag_con
-  tab_cntrl(6) = nbapp_rad
-
-  IF( iflag_cycle_diurne.GE.1 ) tab_cntrl( 7 ) = iflag_cycle_diurne
-  IF(   soil_model ) tab_cntrl( 8 ) = 1.
-  IF(     new_oliq ) tab_cntrl( 9 ) = 1.
-  IF(     ok_orodr ) tab_cntrl(10 ) = 1.
-  IF(     ok_orolf ) tab_cntrl(11 ) = 1.
-
-  tab_cntrl(13) = day_end
-  tab_cntrl(14) = annee_ref
-  tab_cntrl(15) = itau_phy
-
-  ! co2_ppm0 : initial value of atmospheric CO2
-  ! tab_cntrl(16) = co2_ppm0
-
-  !  PC -- initial value of RCO2 for the radiation scheme
-  !  tab_cntrl(17) = co2_ppm * 1.0e-06 * RMCO2 / RMD
-  IF (carbon_cycle_rad) tab_cntrl(17) = RCO2_glo
-  !PRINT*, "PC : phyredem RCO2_glo =",RCO2_glo
-
-  DO pass=1,2   ! pass=1 netcdf definition ; pass=2 netcdf write
-  
-    CALL put_var(pass, "controle", "Parametres de controle", tab_cntrl)
-
-    CALL put_field(pass,"longitude", &
-         "Longitudes de la grille physique", longitude_deg)
-
-    CALL put_field(pass,"latitude", "Latitudes de la grille physique", latitude_deg)
-
-    ! PB ajout du masque terre/mer
-
-    CALL put_field(pass,"masque", "masque terre mer", zmasq)
-
-    ! BP ajout des fraction de chaque sous-surface
-
-    ! Get last fractions from slab ocean
-    IF (type_ocean == 'slab' .AND. version_ocean == "sicINT") THEN
-        WHERE (1.-zmasq(:).GT.EPSFRA)
-            pctsrf(:,is_oce)=(1.-fsic(:))*(1.-zmasq(:))
-            pctsrf(:,is_sic)=fsic(:)*(1.-zmasq(:))
-        END WHERE
-    END IF
-
-    ! 1. fraction de terre 
-
-    CALL put_field(pass,"FTER", "fraction de continent", pctsrf(:, is_ter))
-
-    ! 2. Fraction de glace de terre
-
-    CALL put_field(pass,"FLIC", "fraction glace de terre", pctsrf(:, is_lic))
-    ! 3. fraction ocean
-
-    CALL put_field(pass,"FOCE", "fraction ocean", pctsrf(:, is_oce))
-
-    ! 4. Fraction glace de mer
-
-    CALL put_field(pass,"FSIC", "fraction glace mer", pctsrf(:, is_sic))
-
-    IF(nbsrf>99) THEN
-      PRINT*, "Trop de sous-mailles";  CALL abort_physic("phyredem", "", 1)
-    END IF
-    IF(nsoilmx>99) THEN
-      PRINT*, "Trop de sous-surfaces"; CALL abort_physic("phyredem", "", 1)
-    END IF
-    IF(nsw>99) THEN
-      PRINT*, "Trop de bandes"; CALL abort_physic("phyredem", "", 1)
-    END IF
-
-!    Surface variables 
-    CALL put_field_srf1(pass,"TS","Temperature",ftsol(:,:))
-
-    IF (iflag_pbl>1 .AND. iflag_wake>=1  .AND. iflag_pbl_split >=1) then
-       CALL put_field_srf1(pass, "DELTATS", &
-            "w-x surface temperature difference", delta_tsurf(:,:))
-       CALL put_field_srf1(pass,"BETAS","Aridity factor", beta_aridity(:,:))
-    end IF
-!    End surface variables
-
-! ================== Albedo =======================================
-    print*,'PHYREDEM NOUVEAU'
-    CALL put_field_srf2(pass,"A_dir_SW","Albedo direct",falb_dir(:,:,:))
-    CALL put_field_srf2(pass,"A_dif_SW","Albedo diffus",falb_dif(:,:,:))
-
-    CALL put_field_srf1(pass,"U10M", "u a 10m", u10m)
-
-    CALL put_field_srf1(pass,"V10M", "v a 10m", v10m)
-
-
-! ================== Tsoil =========================================
-    CALL put_field_srf2(pass,"Tsoil","Temperature",tsoil(:,:,:))
-!FC
-!  CALL put_field_srf2("treedrg","freinage arbres",treedrg(:,:,:))
-    CALL put_field(pass,"treedrg_ter","freinage arbres",treedrg(:,:,is_ter))
-
-
-    CALL put_field_srf1(pass,"QS"  , "Humidite",qsurf(:,:))
-
-    CALL put_field     (pass,"QSOL", "Eau dans le sol (mm)", qsol)
-
-    CALL put_field_srf1(pass,"EVAP", "Evaporation", fevap(:,:))
-
-    CALL put_field_srf1(pass,"SNOW", "Neige", snow(:,:))
-
-    CALL put_field(pass,"RADS", "Rayonnement net a la surface", radsol)
-
-    CALL put_field(pass,"solsw", "Rayonnement solaire a la surface", solsw)
-
-    CALL put_field(pass,"solswfdiff", "Fraction du rayonnement solaire a la surface qui est diffus", solswfdiff)
-
-    CALL put_field(pass,"sollw", "Rayonnement IF a la surface", sollw)
-
-    CALL put_field(pass,"sollwdown", "Rayonnement down IF a la surface", sollwdown)
-
-    CALL put_field(pass,"fder", "Derive de flux", fder)
-
-    CALL put_field(pass,"rain_f", "precipitation liquide", rain_fall)
-
-    CALL put_field(pass,"snow_f", "precipitation solide", snow_fall)
-
-    CALL put_field_srf1(pass,"Z0m", "rugosite", z0m(:,:))
-
-    CALL put_field_srf1(pass,"Z0h", "rugosite", z0h(:,:))
-
-    CALL put_field_srf1(pass,"AGESNO", "Age de la neige", agesno(:,:))
-
-    CALL put_field(pass,"ZMEA", "ZMEA", zmea)
-
-    CALL put_field(pass,"ZSTD", "ZSTD", zstd)
-
-    CALL put_field(pass,"ZSIG", "ZSIG", zsig)
-
-    CALL put_field(pass,"ZGAM", "ZGAM", zgam)
-
-    CALL put_field(pass,"ZTHE", "ZTHE", zthe)
-
-    CALL put_field(pass,"ZPIC", "ZPIC", zpic)
-
-    CALL put_field(pass,"ZVAL", "ZVAL", zval)
-
-    CALL put_field(pass,"RUGSREL", "RUGSREL", rugoro)
-
-    CALL put_field(pass,"TANCIEN", "TANCIEN", t_ancien)
-
-    CALL put_field(pass,"QANCIEN", "QANCIEN", q_ancien)
-
-    CALL put_field(pass,"QLANCIEN", "QLANCIEN", ql_ancien)
-
-    CALL put_field(pass,"QSANCIEN", "QSANCIEN", qs_ancien)
-
-    IF (ok_bs) THEN
-       CALL put_field(pass,"bs_f", "precipitation neige soufflee", bs_fall)
-       CALL put_field(pass,"QBSANCIEN", "QBSANCIEN", qbs_ancien)
-       CALL put_field(pass,"PRBSWANCIEN", "PRBSWANCIEN", prbsw_ancien)
-    ENDIF
-
-    IF ( ok_ice_supersat ) THEN
-      CALL put_field(pass,"CFANCIEN", "CFANCIEN", cf_ancien)
-      CALL put_field(pass,"RVCANCIEN", "RVCANCIEN", rvc_ancien)
-    ENDIF
-
-    CALL put_field(pass,"PRWANCIEN", "PRWANCIEN", prw_ancien)
-
-    CALL put_field(pass,"PRLWANCIEN", "PRLWANCIEN", prlw_ancien)
-
-    CALL put_field(pass,"PRSWANCIEN", "PRSWANCIEN", prsw_ancien)
-
-    CALL put_field(pass,"UANCIEN", "UANCIEN", u_ancien)
-
-    CALL put_field(pass,"VANCIEN", "VANCIEN", v_ancien)
-
-    CALL put_field(pass,"CLWCON", "Eau liquide convective", clwcon)
-
-    CALL put_field(pass,"RNEBCON", "Nebulosite convective", rnebcon)
-
-    CALL put_field(pass,"RATQS", "Ratqs", ratqs)
-
-    ! run_off_lic_0
-
-    CALL put_field(pass,"RUNOFFLIC0", "Runofflic0", run_off_lic_0)
-
-    ! DEB TKE PBL !
-
-    IF (iflag_pbl>1) then
-      CALL put_field_srf3(pass,"TKE", "Energ. Cineti. Turb.", &
-           pbl_tke(:,:,:))
-      CALL put_field_srf3(pass,"DELTATKE", "Del TKE wk/env.", &
-           wake_delta_pbl_tke(:,:,:))
-    END IF
-
-    ! FIN TKE PBL !
-    !IM ajout zmax0, f0, sig1, w01
-    !IM wake_deltat, wake_deltaq, wake_s, wake_cstar, wake_pe, wake_fip
-
-    CALL put_field(pass,"ZMAX0", "ZMAX0", zmax0)
-
-    CALL put_field(pass,"F0", "F0", f0)
-
-    CALL put_field(pass,"sig1", "sig1 Emanuel", sig1)
-
-    CALL put_field(pass,"w01", "w01 Emanuel", w01)
-
-    ! wake_deltat
-    CALL put_field(pass,"WAKE_DELTAT", "WAKE_DELTAT", wake_deltat)
-
-    CALL put_field(pass,"WAKE_DELTAQ", "WAKE_DELTAQ", wake_deltaq)
-
-    CALL put_field(pass,"WAKE_S", "Wake frac. area", wake_s)
-
-    CALL put_field(pass,"AWAKE_S", "Active Wake frac. area", awake_s)
-
-    CALL put_field(pass,"WAKE_DENS", "Wake num. /unit area", wake_dens)
-
-    CALL put_field(pass,"AWAKE_DENS", "Active Wake num. /unit area", awake_dens)
-
-    CALL put_field(pass,"CV_GEN", "CB birth rate", cv_gen)
-
-    CALL put_field(pass,"WAKE_CSTAR", "WAKE_CSTAR", wake_cstar)
-
-    CALL put_field(pass,"WAKE_PE", "WAKE_PE", wake_pe)
-
-    CALL put_field(pass,"WAKE_FIP", "WAKE_FIP", wake_fip)
-
-    ! thermiques
-
-    CALL put_field(pass,"FM_THERM", "FM_THERM", fm_therm)
-
-    CALL put_field(pass,"ENTR_THERM", "ENTR_THERM", entr_therm)
-
-    CALL put_field(pass,"DETR_THERM", "DETR_THERM", detr_therm)
-
-    CALL put_field(pass,"ALE_BL", "ALE_BL", ale_bl)
-
-    CALL put_field(pass,"ALE_BL_TRIG", "ALE_BL_TRIG", ale_bl_trig)
-
-    CALL put_field(pass,"ALP_BL", "ALP_BL", alp_bl)
-
-    CALL put_field(pass,"ALE_WAKE", "ALE_WAKE", ale_wake)
-
-    CALL put_field(pass,"ALE_BL_STAT", "ALE_BL_STAT", ale_bl_stat)
-
-
-    ! fisrtilp/clouds
-    CALL put_field(pass,"RATQS_INTER","Relative width of the lsc sugrid scale water",ratqs_inter_)
-
-
-    IF (ANY(type_trac == ['co2i','inco'])) THEN
-       IF (carbon_cycle_cpl) THEN
-          IF (.NOT. ALLOCATED(co2_send)) THEN
-             ! This is the case of create_etat0_limit, ce0l
-             ALLOCATE(co2_send(klon))
-             co2_send(:) = co2_ppm0
-          END IF
-          CALL put_field(pass,"co2_send", "co2_ppm for coupling", co2_send)
-       END IF
-
-    ! trs from traclmdz_mod
-    ELSE IF (type_trac == 'lmdz') THEN
-       CALL traclmdz_to_restart(trs)
-       it = 0
-       DO iq = 1, nqtot
-          IF(.NOT.(tracers(iq)%isAdvected .AND. tracers(iq)%isInPhysics)) CYCLE
-          it = it+1
-          CALL put_field(pass,"trs_"//tracers(iq)%name, "", trs(:, it))
-       END DO
-    END IF
-
-    ! Restart variables for Slab ocean
-    IF (type_ocean == 'slab') THEN
-        IF (nslay.EQ.1) THEN
-          CALL put_field(pass,"tslab", "Slab ocean temperature", tslab)
-        ELSE
-          DO it=1,nslay
-            WRITE(str2,'(i2.2)') it
-            CALL put_field(pass,"tslab"//str2, "Slab ocean temperature", tslab(:,it))
-          END DO
-        END IF
-        IF (version_ocean == 'sicINT') THEN
-            CALL put_field(pass,"seaice", "Slab seaice (kg/m2)", seaice)
-            CALL put_field(pass,"slab_tice", "Slab sea ice temperature", tice)
-        END IF
-    END IF
-
-    if (ok_gwd_rando) call put_field(pass,"du_gwd_rando", &
-         "tendency on zonal wind due to flott gravity waves", du_gwd_rando)
-
-    IF (.not. ok_hines .and. ok_gwd_rando) call put_field(pass,"du_gwd_front", &
-         "tendency on zonal wind due to acama gravity waves", du_gwd_front)
-
-    if (activate_ocean_skin >= 1) then
-       if (activate_ocean_skin == 2 .and. type_ocean == 'couple') then
-          CALL put_field(pass, "delta_sal", &
-               "ocean-air interface salinity minus bulk salinity", delta_sal)
-          CALL put_field(pass, "delta_SST", &
-               "ocean-air interface temperature minus bulk SST", delta_sst)
-          CALL put_field(pass, "dter", &
-               "ocean-air interface temperature minus subskin temperature", &
-               dter)
-          CALL put_field(pass, "dser", &
-               "ocean-air interface salinity minus subskin salinity", dser)
-          CALL put_field(pass, "dt_ds", &
-               "(tks / tkt) * dTer", dt_ds)
-       end if
-       
-       CALL put_field(pass, "dS_ns", "delta salinity near surface", ds_ns)
-       CALL put_field(pass, "dT_ns", "delta temperature near surface", dT_ns)
-    end if
-    
-    IF (pass==1) CALL enddef_restartphy
-    IF (pass==2) CALL close_restartphy
-  ENDDO ! DO pass=1,2   ! pass=1 netcdf definition ; pass=2 netcdf write
-  
-  !$OMP BARRIER
-
-
-  CONTAINS
-
-
-SUBROUTINE put_field_srf1(pass,nam,lnam,field)
-
-  IMPLICIT NONE
-  INTEGER, INTENT(IN)           :: pass
-  CHARACTER(LEN=*),  INTENT(IN) :: nam, lnam
-  REAL,              INTENT(IN) :: field(:,:)
-  CHARACTER(LEN=256) :: nm, lm, str
-  DO nsrf = 1, SIZE(field,2)
-    WRITE(str, '(i2.2)') nsrf
-    nm=TRIM(nam)//TRIM(str)
-    lm=TRIM(lnam)//" de surface No. "//TRIM(str)
-    CALL put_field(pass,nm,lm,field(:,nsrf))
-  END DO
-
-END SUBROUTINE put_field_srf1
-
-
-SUBROUTINE put_field_srf2(pass,nam,lnam,field)
-
-  IMPLICIT NONE
-  INTEGER, INTENT(IN)            :: pass
-  CHARACTER(LEN=*),  INTENT(IN) :: nam, lnam
-  REAL,              INTENT(IN) :: field(:,:,:)
-  CHARACTER(LEN=256) :: nm, lm, str
-  DO nsrf = 1, SIZE(field,3)
-    DO isoil=1, SIZE(field,2)
-      WRITE(str, '(i2.2,"srf",i2.2)')isoil,nsrf
-!      WRITE(lunout,*)"PHYREDEM ",TRIM(nam)//TRIM(str)
-      nm=TRIM(nam)//TRIM(str)
-      lm=TRIM(lnam)//" du sol No. "//TRIM(str)
-      CALL put_field(pass,nm,lm,field(:,isoil,nsrf))
-    END DO
-  END DO
-
-END SUBROUTINE put_field_srf2
-
-
-SUBROUTINE put_field_srf3(pass,nam,lnam,field)
-
-  IMPLICIT NONE
-  INTEGER, INTENT(IN)            :: pass
-  CHARACTER(LEN=*),  INTENT(IN) :: nam, lnam
-  REAL,              INTENT(IN) :: field(:,:,:)
-  CHARACTER(LEN=256) :: nm, lm, str
-  DO nsrf = 1, SIZE(field,3)
-    WRITE(str, '(i2.2)') nsrf
-    nm=TRIM(nam)//TRIM(str)
-    lm=TRIM(lnam)//TRIM(str)
-    CALL put_field(pass,nm,lm,field(:,1:klev+1,nsrf))
-  END DO
-
-END SUBROUTINE put_field_srf3
-
-
-END SUBROUTINE phyredem
Index: /LMDZ6/trunk/libf/phylmd/phyredem.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/phyredem.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/phyredem.f90	(revision 5268)
@@ -0,0 +1,471 @@
+!
+! $Id$
+!
+SUBROUTINE phyredem (fichnom)
+!
+!-------------------------------------------------------------------------------
+! Author: Z.X. Li (LMD/CNRS), 1993/08/18
+!-------------------------------------------------------------------------------
+! Purpose: Write restart state for physics.
+!-------------------------------------------------------------------------------
+  USE dimphy, ONLY: klon, klev
+  USE fonte_neige_mod,  ONLY : fonte_neige_final
+  USE pbl_surface_mod,  ONLY : pbl_surface_final
+  USE phys_state_var_mod, ONLY: radpas, zmasq, pctsrf,                       &
+                                ftsol, beta_aridity, delta_tsurf, falb_dir,  &
+                                falb_dif, qsol, fevap, radsol, solsw, sollw, &
+                                sollwdown, rain_fall, snow_fall, bs_fall, z0m, z0h, &
+                                agesno, zmea, zstd, zsig, zgam, zthe, zpic,  &
+                                zval, rugoro, t_ancien, q_ancien,            &
+                                prw_ancien, prlw_ancien, prsw_ancien, prbsw_ancien,      &
+                                ql_ancien, qs_ancien, qbs_ancien, cf_ancien, &
+                                rvc_ancien, u_ancien, v_ancien,              &
+                                clwcon, rnebcon, ratqs, pbl_tke,             &
+                                wake_delta_pbl_tke, zmax0, f0, sig1, w01,    &
+                                wake_deltat, wake_deltaq, wake_s, awake_s,   &
+                                wake_dens, awake_dens, cv_gen,               &
+                                wake_cstar,                                  &
+                                wake_pe, wake_fip, fm_therm, entr_therm,     &
+                                detr_therm, ale_bl, ale_bl_trig, alp_bl,     &
+                                ale_wake, ale_bl_stat,                       &
+                                du_gwd_rando, du_gwd_front, u10m, v10m, &
+                                treedrg, solswfdiff, delta_sal, ds_ns, dt_ns, &
+                                delta_sst, ratqs_inter_, dter, dser, dt_ds
+
+  USE geometry_mod, ONLY : longitude_deg, latitude_deg
+  USE iostart, ONLY: open_restartphy, close_restartphy, enddef_restartphy, put_field, put_var
+  USE traclmdz_mod, ONLY : traclmdz_to_restart
+  USE infotrac_phy, ONLY: type_trac, nqtot, tracers, nbtr
+  USE carbon_cycle_mod, ONLY : carbon_cycle_cpl, co2_send, carbon_cycle_rad, RCO2_glo
+  USE indice_sol_mod, ONLY: nbsrf, is_oce, is_sic, is_ter, is_lic, epsfra
+  USE surface_data, ONLY: type_ocean, version_ocean
+  USE ocean_slab_mod, ONLY : nslay, tslab, seaice, tice, fsic
+  USE time_phylmdz_mod, ONLY: annee_ref, day_end, itau_phy, pdtphys
+  use config_ocean_skin_m, only: activate_ocean_skin  
+
+  IMPLICIT none
+
+  include "dimsoil.h"
+  include "clesphys.h"
+  include "alpale.h"
+  include "compbl.h"
+  !======================================================================
+  CHARACTER*(*) fichnom
+
+  ! les variables globales ecrites dans le fichier restart
+
+  REAL tsoil(klon, nsoilmx, nbsrf)
+  REAL qsurf(klon, nbsrf)
+  REAL snow(klon, nbsrf)
+  real fder(klon)
+  REAL run_off_lic_0(klon)
+  REAL trs(klon, nbtr)
+
+  INTEGER nid, nvarid, idim1, idim2, idim3
+  INTEGER ierr
+  INTEGER length
+  PARAMETER (length=100)
+  REAL tab_cntrl(length)
+
+  INTEGER isoil, nsrf,isw
+  CHARACTER (len=2) :: str2
+  CHARACTER (len=256) :: nam, lnam
+  INTEGER           :: it, iq, pass
+
+  !======================================================================
+
+  ! Get variables which will be written to restart file from module 
+  ! pbl_surface_mod
+  if ( iflag_physiq <= 1 ) then
+     CALL pbl_surface_final(fder, snow, qsurf,  tsoil)
+  endif
+
+  ! Get a variable calculated in module fonte_neige_mod
+  CALL fonte_neige_final(run_off_lic_0)
+
+  !======================================================================
+
+  CALL open_restartphy(fichnom)
+
+  
+  DO ierr = 1, length
+     tab_cntrl(ierr) = 0.0
+  ENDDO
+  tab_cntrl(1) = pdtphys
+  tab_cntrl(2) = radpas
+  ! co2_ppm : current value of atmospheric CO2
+  tab_cntrl(3) = co2_ppm
+  tab_cntrl(4) = solaire
+  tab_cntrl(5) = iflag_con
+  tab_cntrl(6) = nbapp_rad
+
+  IF( iflag_cycle_diurne.GE.1 ) tab_cntrl( 7 ) = iflag_cycle_diurne
+  IF(   soil_model ) tab_cntrl( 8 ) = 1.
+  IF(     new_oliq ) tab_cntrl( 9 ) = 1.
+  IF(     ok_orodr ) tab_cntrl(10 ) = 1.
+  IF(     ok_orolf ) tab_cntrl(11 ) = 1.
+
+  tab_cntrl(13) = day_end
+  tab_cntrl(14) = annee_ref
+  tab_cntrl(15) = itau_phy
+
+  ! co2_ppm0 : initial value of atmospheric CO2
+  ! tab_cntrl(16) = co2_ppm0
+
+  !  PC -- initial value of RCO2 for the radiation scheme
+  !  tab_cntrl(17) = co2_ppm * 1.0e-06 * RMCO2 / RMD
+  IF (carbon_cycle_rad) tab_cntrl(17) = RCO2_glo
+  !PRINT*, "PC : phyredem RCO2_glo =",RCO2_glo
+
+  DO pass=1,2   ! pass=1 netcdf definition ; pass=2 netcdf write
+  
+    CALL put_var(pass, "controle", "Parametres de controle", tab_cntrl)
+
+    CALL put_field(pass,"longitude", &
+         "Longitudes de la grille physique", longitude_deg)
+
+    CALL put_field(pass,"latitude", "Latitudes de la grille physique", latitude_deg)
+
+    ! PB ajout du masque terre/mer
+
+    CALL put_field(pass,"masque", "masque terre mer", zmasq)
+
+    ! BP ajout des fraction de chaque sous-surface
+
+    ! Get last fractions from slab ocean
+    IF (type_ocean == 'slab' .AND. version_ocean == "sicINT") THEN
+        WHERE (1.-zmasq(:).GT.EPSFRA)
+            pctsrf(:,is_oce)=(1.-fsic(:))*(1.-zmasq(:))
+            pctsrf(:,is_sic)=fsic(:)*(1.-zmasq(:))
+        END WHERE
+    END IF
+
+    ! 1. fraction de terre 
+
+    CALL put_field(pass,"FTER", "fraction de continent", pctsrf(:, is_ter))
+
+    ! 2. Fraction de glace de terre
+
+    CALL put_field(pass,"FLIC", "fraction glace de terre", pctsrf(:, is_lic))
+    ! 3. fraction ocean
+
+    CALL put_field(pass,"FOCE", "fraction ocean", pctsrf(:, is_oce))
+
+    ! 4. Fraction glace de mer
+
+    CALL put_field(pass,"FSIC", "fraction glace mer", pctsrf(:, is_sic))
+
+    IF(nbsrf>99) THEN
+      PRINT*, "Trop de sous-mailles";  CALL abort_physic("phyredem", "", 1)
+    END IF
+    IF(nsoilmx>99) THEN
+      PRINT*, "Trop de sous-surfaces"; CALL abort_physic("phyredem", "", 1)
+    END IF
+    IF(nsw>99) THEN
+      PRINT*, "Trop de bandes"; CALL abort_physic("phyredem", "", 1)
+    END IF
+
+!    Surface variables 
+    CALL put_field_srf1(pass,"TS","Temperature",ftsol(:,:))
+
+    IF (iflag_pbl>1 .AND. iflag_wake>=1  .AND. iflag_pbl_split >=1) then
+       CALL put_field_srf1(pass, "DELTATS", &
+            "w-x surface temperature difference", delta_tsurf(:,:))
+       CALL put_field_srf1(pass,"BETAS","Aridity factor", beta_aridity(:,:))
+    end IF
+!    End surface variables
+
+! ================== Albedo =======================================
+    print*,'PHYREDEM NOUVEAU'
+    CALL put_field_srf2(pass,"A_dir_SW","Albedo direct",falb_dir(:,:,:))
+    CALL put_field_srf2(pass,"A_dif_SW","Albedo diffus",falb_dif(:,:,:))
+
+    CALL put_field_srf1(pass,"U10M", "u a 10m", u10m)
+
+    CALL put_field_srf1(pass,"V10M", "v a 10m", v10m)
+
+
+! ================== Tsoil =========================================
+    CALL put_field_srf2(pass,"Tsoil","Temperature",tsoil(:,:,:))
+!FC
+!  CALL put_field_srf2("treedrg","freinage arbres",treedrg(:,:,:))
+    CALL put_field(pass,"treedrg_ter","freinage arbres",treedrg(:,:,is_ter))
+
+
+    CALL put_field_srf1(pass,"QS"  , "Humidite",qsurf(:,:))
+
+    CALL put_field     (pass,"QSOL", "Eau dans le sol (mm)", qsol)
+
+    CALL put_field_srf1(pass,"EVAP", "Evaporation", fevap(:,:))
+
+    CALL put_field_srf1(pass,"SNOW", "Neige", snow(:,:))
+
+    CALL put_field(pass,"RADS", "Rayonnement net a la surface", radsol)
+
+    CALL put_field(pass,"solsw", "Rayonnement solaire a la surface", solsw)
+
+    CALL put_field(pass,"solswfdiff", "Fraction du rayonnement solaire a la surface qui est diffus", solswfdiff)
+
+    CALL put_field(pass,"sollw", "Rayonnement IF a la surface", sollw)
+
+    CALL put_field(pass,"sollwdown", "Rayonnement down IF a la surface", sollwdown)
+
+    CALL put_field(pass,"fder", "Derive de flux", fder)
+
+    CALL put_field(pass,"rain_f", "precipitation liquide", rain_fall)
+
+    CALL put_field(pass,"snow_f", "precipitation solide", snow_fall)
+
+    CALL put_field_srf1(pass,"Z0m", "rugosite", z0m(:,:))
+
+    CALL put_field_srf1(pass,"Z0h", "rugosite", z0h(:,:))
+
+    CALL put_field_srf1(pass,"AGESNO", "Age de la neige", agesno(:,:))
+
+    CALL put_field(pass,"ZMEA", "ZMEA", zmea)
+
+    CALL put_field(pass,"ZSTD", "ZSTD", zstd)
+
+    CALL put_field(pass,"ZSIG", "ZSIG", zsig)
+
+    CALL put_field(pass,"ZGAM", "ZGAM", zgam)
+
+    CALL put_field(pass,"ZTHE", "ZTHE", zthe)
+
+    CALL put_field(pass,"ZPIC", "ZPIC", zpic)
+
+    CALL put_field(pass,"ZVAL", "ZVAL", zval)
+
+    CALL put_field(pass,"RUGSREL", "RUGSREL", rugoro)
+
+    CALL put_field(pass,"TANCIEN", "TANCIEN", t_ancien)
+
+    CALL put_field(pass,"QANCIEN", "QANCIEN", q_ancien)
+
+    CALL put_field(pass,"QLANCIEN", "QLANCIEN", ql_ancien)
+
+    CALL put_field(pass,"QSANCIEN", "QSANCIEN", qs_ancien)
+
+    IF (ok_bs) THEN
+       CALL put_field(pass,"bs_f", "precipitation neige soufflee", bs_fall)
+       CALL put_field(pass,"QBSANCIEN", "QBSANCIEN", qbs_ancien)
+       CALL put_field(pass,"PRBSWANCIEN", "PRBSWANCIEN", prbsw_ancien)
+    ENDIF
+
+    IF ( ok_ice_supersat ) THEN
+      CALL put_field(pass,"CFANCIEN", "CFANCIEN", cf_ancien)
+      CALL put_field(pass,"RVCANCIEN", "RVCANCIEN", rvc_ancien)
+    ENDIF
+
+    CALL put_field(pass,"PRWANCIEN", "PRWANCIEN", prw_ancien)
+
+    CALL put_field(pass,"PRLWANCIEN", "PRLWANCIEN", prlw_ancien)
+
+    CALL put_field(pass,"PRSWANCIEN", "PRSWANCIEN", prsw_ancien)
+
+    CALL put_field(pass,"UANCIEN", "UANCIEN", u_ancien)
+
+    CALL put_field(pass,"VANCIEN", "VANCIEN", v_ancien)
+
+    CALL put_field(pass,"CLWCON", "Eau liquide convective", clwcon)
+
+    CALL put_field(pass,"RNEBCON", "Nebulosite convective", rnebcon)
+
+    CALL put_field(pass,"RATQS", "Ratqs", ratqs)
+
+    ! run_off_lic_0
+
+    CALL put_field(pass,"RUNOFFLIC0", "Runofflic0", run_off_lic_0)
+
+    ! DEB TKE PBL !
+
+    IF (iflag_pbl>1) then
+      CALL put_field_srf3(pass,"TKE", "Energ. Cineti. Turb.", &
+           pbl_tke(:,:,:))
+      CALL put_field_srf3(pass,"DELTATKE", "Del TKE wk/env.", &
+           wake_delta_pbl_tke(:,:,:))
+    END IF
+
+    ! FIN TKE PBL !
+    !IM ajout zmax0, f0, sig1, w01
+    !IM wake_deltat, wake_deltaq, wake_s, wake_cstar, wake_pe, wake_fip
+
+    CALL put_field(pass,"ZMAX0", "ZMAX0", zmax0)
+
+    CALL put_field(pass,"F0", "F0", f0)
+
+    CALL put_field(pass,"sig1", "sig1 Emanuel", sig1)
+
+    CALL put_field(pass,"w01", "w01 Emanuel", w01)
+
+    ! wake_deltat
+    CALL put_field(pass,"WAKE_DELTAT", "WAKE_DELTAT", wake_deltat)
+
+    CALL put_field(pass,"WAKE_DELTAQ", "WAKE_DELTAQ", wake_deltaq)
+
+    CALL put_field(pass,"WAKE_S", "Wake frac. area", wake_s)
+
+    CALL put_field(pass,"AWAKE_S", "Active Wake frac. area", awake_s)
+
+    CALL put_field(pass,"WAKE_DENS", "Wake num. /unit area", wake_dens)
+
+    CALL put_field(pass,"AWAKE_DENS", "Active Wake num. /unit area", awake_dens)
+
+    CALL put_field(pass,"CV_GEN", "CB birth rate", cv_gen)
+
+    CALL put_field(pass,"WAKE_CSTAR", "WAKE_CSTAR", wake_cstar)
+
+    CALL put_field(pass,"WAKE_PE", "WAKE_PE", wake_pe)
+
+    CALL put_field(pass,"WAKE_FIP", "WAKE_FIP", wake_fip)
+
+    ! thermiques
+
+    CALL put_field(pass,"FM_THERM", "FM_THERM", fm_therm)
+
+    CALL put_field(pass,"ENTR_THERM", "ENTR_THERM", entr_therm)
+
+    CALL put_field(pass,"DETR_THERM", "DETR_THERM", detr_therm)
+
+    CALL put_field(pass,"ALE_BL", "ALE_BL", ale_bl)
+
+    CALL put_field(pass,"ALE_BL_TRIG", "ALE_BL_TRIG", ale_bl_trig)
+
+    CALL put_field(pass,"ALP_BL", "ALP_BL", alp_bl)
+
+    CALL put_field(pass,"ALE_WAKE", "ALE_WAKE", ale_wake)
+
+    CALL put_field(pass,"ALE_BL_STAT", "ALE_BL_STAT", ale_bl_stat)
+
+
+    ! fisrtilp/clouds
+    CALL put_field(pass,"RATQS_INTER","Relative width of the lsc sugrid scale water",ratqs_inter_)
+
+
+    IF (ANY(type_trac == ['co2i','inco'])) THEN
+       IF (carbon_cycle_cpl) THEN
+          IF (.NOT. ALLOCATED(co2_send)) THEN
+             ! This is the case of create_etat0_limit, ce0l
+             ALLOCATE(co2_send(klon))
+             co2_send(:) = co2_ppm0
+          END IF
+          CALL put_field(pass,"co2_send", "co2_ppm for coupling", co2_send)
+       END IF
+
+    ! trs from traclmdz_mod
+    ELSE IF (type_trac == 'lmdz') THEN
+       CALL traclmdz_to_restart(trs)
+       it = 0
+       DO iq = 1, nqtot
+          IF(.NOT.(tracers(iq)%isAdvected .AND. tracers(iq)%isInPhysics)) CYCLE
+          it = it+1
+          CALL put_field(pass,"trs_"//tracers(iq)%name, "", trs(:, it))
+       END DO
+    END IF
+
+    ! Restart variables for Slab ocean
+    IF (type_ocean == 'slab') THEN
+        IF (nslay.EQ.1) THEN
+          CALL put_field(pass,"tslab", "Slab ocean temperature", tslab)
+        ELSE
+          DO it=1,nslay
+            WRITE(str2,'(i2.2)') it
+            CALL put_field(pass,"tslab"//str2, "Slab ocean temperature", tslab(:,it))
+          END DO
+        END IF
+        IF (version_ocean == 'sicINT') THEN
+            CALL put_field(pass,"seaice", "Slab seaice (kg/m2)", seaice)
+            CALL put_field(pass,"slab_tice", "Slab sea ice temperature", tice)
+        END IF
+    END IF
+
+    if (ok_gwd_rando) call put_field(pass,"du_gwd_rando", &
+         "tendency on zonal wind due to flott gravity waves", du_gwd_rando)
+
+    IF (.not. ok_hines .and. ok_gwd_rando) call put_field(pass,"du_gwd_front", &
+         "tendency on zonal wind due to acama gravity waves", du_gwd_front)
+
+    if (activate_ocean_skin >= 1) then
+       if (activate_ocean_skin == 2 .and. type_ocean == 'couple') then
+          CALL put_field(pass, "delta_sal", &
+               "ocean-air interface salinity minus bulk salinity", delta_sal)
+          CALL put_field(pass, "delta_SST", &
+               "ocean-air interface temperature minus bulk SST", delta_sst)
+          CALL put_field(pass, "dter", &
+               "ocean-air interface temperature minus subskin temperature", &
+               dter)
+          CALL put_field(pass, "dser", &
+               "ocean-air interface salinity minus subskin salinity", dser)
+          CALL put_field(pass, "dt_ds", &
+               "(tks / tkt) * dTer", dt_ds)
+       end if
+       
+       CALL put_field(pass, "dS_ns", "delta salinity near surface", ds_ns)
+       CALL put_field(pass, "dT_ns", "delta temperature near surface", dT_ns)
+    end if
+    
+    IF (pass==1) CALL enddef_restartphy
+    IF (pass==2) CALL close_restartphy
+  ENDDO ! DO pass=1,2   ! pass=1 netcdf definition ; pass=2 netcdf write
+  
+  !$OMP BARRIER
+
+
+  CONTAINS
+
+
+SUBROUTINE put_field_srf1(pass,nam,lnam,field)
+
+  IMPLICIT NONE
+  INTEGER, INTENT(IN)           :: pass
+  CHARACTER(LEN=*),  INTENT(IN) :: nam, lnam
+  REAL,              INTENT(IN) :: field(:,:)
+  CHARACTER(LEN=256) :: nm, lm, str
+  DO nsrf = 1, SIZE(field,2)
+    WRITE(str, '(i2.2)') nsrf
+    nm=TRIM(nam)//TRIM(str)
+    lm=TRIM(lnam)//" de surface No. "//TRIM(str)
+    CALL put_field(pass,nm,lm,field(:,nsrf))
+  END DO
+
+END SUBROUTINE put_field_srf1
+
+
+SUBROUTINE put_field_srf2(pass,nam,lnam,field)
+
+  IMPLICIT NONE
+  INTEGER, INTENT(IN)            :: pass
+  CHARACTER(LEN=*),  INTENT(IN) :: nam, lnam
+  REAL,              INTENT(IN) :: field(:,:,:)
+  CHARACTER(LEN=256) :: nm, lm, str
+  DO nsrf = 1, SIZE(field,3)
+    DO isoil=1, SIZE(field,2)
+      WRITE(str, '(i2.2,"srf",i2.2)')isoil,nsrf
+!      WRITE(lunout,*)"PHYREDEM ",TRIM(nam)//TRIM(str)
+      nm=TRIM(nam)//TRIM(str)
+      lm=TRIM(lnam)//" du sol No. "//TRIM(str)
+      CALL put_field(pass,nm,lm,field(:,isoil,nsrf))
+    END DO
+  END DO
+
+END SUBROUTINE put_field_srf2
+
+
+SUBROUTINE put_field_srf3(pass,nam,lnam,field)
+
+  IMPLICIT NONE
+  INTEGER, INTENT(IN)            :: pass
+  CHARACTER(LEN=*),  INTENT(IN) :: nam, lnam
+  REAL,              INTENT(IN) :: field(:,:,:)
+  CHARACTER(LEN=256) :: nm, lm, str
+  DO nsrf = 1, SIZE(field,3)
+    WRITE(str, '(i2.2)') nsrf
+    nm=TRIM(nam)//TRIM(str)
+    lm=TRIM(lnam)//TRIM(str)
+    CALL put_field(pass,nm,lm,field(:,1:klev+1,nsrf))
+  END DO
+
+END SUBROUTINE put_field_srf3
+
+
+END SUBROUTINE phyredem
Index: DZ6/trunk/libf/phylmd/phys_cal_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/phys_cal_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,95 +1,0 @@
-! $Id$
-MODULE phys_cal_mod
-! This module contains information on the calendar at the current time step
-
-  INTEGER,SAVE :: year_cur      ! current year
-!$OMP THREADPRIVATE(year_cur)
-  INTEGER,SAVE :: mth_cur       ! current month
-!$OMP THREADPRIVATE(mth_cur)
-  INTEGER,SAVE :: day_cur       ! current day
-!$OMP THREADPRIVATE(day_cur)
-  INTEGER,SAVE :: days_elapsed  ! number of whole days since start of the current year
-!$OMP THREADPRIVATE(days_elapsed)
-  INTEGER,SAVE :: mth_len       ! number of days in the current month
-!$OMP THREADPRIVATE(mth_len)
-  INTEGER,SAVE :: year_len      ! number of days in the current year
-!$OMP THREADPRIVATE(year_len)
-  REAL,SAVE    :: hour         ! seconds elapsed (in the current day) since midnight
-!$OMP THREADPRIVATE(hour)
-  REAL,SAVE    :: jD_1jan
-!$OMP THREADPRIVATE(jD_1jan)
-  REAL,SAVE    :: jH_1jan
-!$OMP THREADPRIVATE(jH_1jan)
-  REAL,SAVE    :: xjour
-!$OMP THREADPRIVATE(xjour)
-  REAL,SAVE    :: jD_cur  ! jour courant a l'appel de la physique (jour julien)
-!$OMP THREADPRIVATE(jD_cur)
-  REAL,SAVE    :: jH_cur  ! heure courante a l'appel de la physique (jour julien)
-!$OMP THREADPRIVATE(jH_cur)
-  REAL,SAVE    :: jD_ref  ! jour du demarage de la simulation (jour julien)
-!$OMP THREADPRIVATE(jD_ref)
- CHARACTER (len=10) :: calend ! type of calendar to use
-                              ! (can be earth_360d, earth_365d or earth_366d)
-!$OMP THREADPRIVATE(calend)
-
-CONTAINS
-  
-  SUBROUTINE phys_cal_init(annee_ref,day_ref)
-
-    USE IOIPSL, ONLY:  ymds2ju, ioconf_calendar
-    USE mod_phys_lmdz_para, ONLY:  is_master,is_omp_master
-    USE ioipsl_getin_p_mod, ONLY: getin_p
-
-    IMPLICIT NONE
-    INTEGER,INTENT(IN) :: annee_ref
-    INTEGER,INTENT(IN) :: day_ref
-
-    ! Find out which type of calendar we are using
-    calend = 'earth_360d' ! default
-    CALL getin_p("calend",calend)
-
-    IF (is_omp_master) THEN
-      IF (calend == 'earth_360d') THEN
-        CALL ioconf_calendar('360_day')
-      ELSE IF (calend == 'earth_365d') THEN
-        CALL ioconf_calendar('noleap')
-      ELSE IF (calend == 'earth_366d' .OR. calend == 'gregorian') THEN
-        CALL ioconf_calendar('gregorian')
-      ELSE
-        CALL abort_physic('phys_cal_init','Mauvais choix de calendrier',1)
-      ENDIF
-    ENDIF
-!$OMP BARRIER
-     
-    CALL ymds2ju(annee_ref, 1, day_ref, 0., jD_ref)
-    jD_ref=INT(jD_ref)
-  
-  END SUBROUTINE  phys_cal_init
-
-  SUBROUTINE phys_cal_update(julian_date)
-    ! This subroutine updates the module saved variables.
-
-    USE IOIPSL, only: ju2ymds, ymds2ju, ioget_mon_len, ioget_year_len
-    IMPLICIT NONE
-    REAL, INTENT(IN) :: julian_date
-
-    jD_cur=INT(julian_date)
-    jH_cur=julian_date-jD_cur
-    
-    CALL ju2ymds(jD_cur+jH_cur, year_cur, mth_cur, day_cur, hour)
-    CALL ymds2ju(year_cur, 1, 1, 0., jD_1jan)
-    
-    jH_1jan = jD_1jan - int (jD_1jan)
-    jD_1jan = int (jD_1jan) 
-    xjour = jD_cur - jD_1jan
-    days_elapsed = jD_cur - jD_1jan
-
-    ! Get lenght of current month
-    mth_len = ioget_mon_len(year_cur,mth_cur)
-
-    ! Get length of current year
-    year_len = ioget_year_len(year_cur)
-
-  END SUBROUTINE phys_cal_update
-
-END MODULE phys_cal_mod
Index: /LMDZ6/trunk/libf/phylmd/phys_cal_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/phys_cal_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/phys_cal_mod.f90	(revision 5268)
@@ -0,0 +1,95 @@
+! $Id$
+MODULE phys_cal_mod
+! This module contains information on the calendar at the current time step
+
+  INTEGER,SAVE :: year_cur      ! current year
+!$OMP THREADPRIVATE(year_cur)
+  INTEGER,SAVE :: mth_cur       ! current month
+!$OMP THREADPRIVATE(mth_cur)
+  INTEGER,SAVE :: day_cur       ! current day
+!$OMP THREADPRIVATE(day_cur)
+  INTEGER,SAVE :: days_elapsed  ! number of whole days since start of the current year
+!$OMP THREADPRIVATE(days_elapsed)
+  INTEGER,SAVE :: mth_len       ! number of days in the current month
+!$OMP THREADPRIVATE(mth_len)
+  INTEGER,SAVE :: year_len      ! number of days in the current year
+!$OMP THREADPRIVATE(year_len)
+  REAL,SAVE    :: hour         ! seconds elapsed (in the current day) since midnight
+!$OMP THREADPRIVATE(hour)
+  REAL,SAVE    :: jD_1jan
+!$OMP THREADPRIVATE(jD_1jan)
+  REAL,SAVE    :: jH_1jan
+!$OMP THREADPRIVATE(jH_1jan)
+  REAL,SAVE    :: xjour
+!$OMP THREADPRIVATE(xjour)
+  REAL,SAVE    :: jD_cur  ! jour courant a l'appel de la physique (jour julien)
+!$OMP THREADPRIVATE(jD_cur)
+  REAL,SAVE    :: jH_cur  ! heure courante a l'appel de la physique (jour julien)
+!$OMP THREADPRIVATE(jH_cur)
+  REAL,SAVE    :: jD_ref  ! jour du demarage de la simulation (jour julien)
+!$OMP THREADPRIVATE(jD_ref)
+ CHARACTER (len=10) :: calend ! type of calendar to use
+                              ! (can be earth_360d, earth_365d or earth_366d)
+!$OMP THREADPRIVATE(calend)
+
+CONTAINS
+  
+  SUBROUTINE phys_cal_init(annee_ref,day_ref)
+
+    USE IOIPSL, ONLY:  ymds2ju, ioconf_calendar
+    USE mod_phys_lmdz_para, ONLY:  is_master,is_omp_master
+    USE ioipsl_getin_p_mod, ONLY: getin_p
+
+    IMPLICIT NONE
+    INTEGER,INTENT(IN) :: annee_ref
+    INTEGER,INTENT(IN) :: day_ref
+
+    ! Find out which type of calendar we are using
+    calend = 'earth_360d' ! default
+    CALL getin_p("calend",calend)
+
+    IF (is_omp_master) THEN
+      IF (calend == 'earth_360d') THEN
+        CALL ioconf_calendar('360_day')
+      ELSE IF (calend == 'earth_365d') THEN
+        CALL ioconf_calendar('noleap')
+      ELSE IF (calend == 'earth_366d' .OR. calend == 'gregorian') THEN
+        CALL ioconf_calendar('gregorian')
+      ELSE
+        CALL abort_physic('phys_cal_init','Mauvais choix de calendrier',1)
+      ENDIF
+    ENDIF
+!$OMP BARRIER
+     
+    CALL ymds2ju(annee_ref, 1, day_ref, 0., jD_ref)
+    jD_ref=INT(jD_ref)
+  
+  END SUBROUTINE  phys_cal_init
+
+  SUBROUTINE phys_cal_update(julian_date)
+    ! This subroutine updates the module saved variables.
+
+    USE IOIPSL, only: ju2ymds, ymds2ju, ioget_mon_len, ioget_year_len
+    IMPLICIT NONE
+    REAL, INTENT(IN) :: julian_date
+
+    jD_cur=INT(julian_date)
+    jH_cur=julian_date-jD_cur
+    
+    CALL ju2ymds(jD_cur+jH_cur, year_cur, mth_cur, day_cur, hour)
+    CALL ymds2ju(year_cur, 1, 1, 0., jD_1jan)
+    
+    jH_1jan = jD_1jan - int (jD_1jan)
+    jD_1jan = int (jD_1jan) 
+    xjour = jD_cur - jD_1jan
+    days_elapsed = jD_cur - jD_1jan
+
+    ! Get lenght of current month
+    mth_len = ioget_mon_len(year_cur,mth_cur)
+
+    ! Get length of current year
+    year_len = ioget_year_len(year_cur)
+
+  END SUBROUTINE phys_cal_update
+
+END MODULE phys_cal_mod
Index: DZ6/trunk/libf/phylmd/phys_output_var_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/phys_output_var_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,319 +1,0 @@
-!
-! phys_local_var_mod.F90 1327 2010-03-17 15:33:56Z idelkadi $
-
-MODULE phys_output_var_mod
-
-  USE dimphy
-  USE strings_mod, ONLY: maxlen
-  ! Variables outputs pour les ecritures des sorties
-  !======================================================================
-  !
-  !
-  !======================================================================
-  ! Declaration des variables
-
-  REAL, SAVE, ALLOCATABLE :: snow_o(:), zfra_o(:)
-  !$OMP THREADPRIVATE(snow_o, zfra_o)
-  REAL, SAVE, ALLOCATABLE :: sza_o(:) ! solar zenithal angle
-  !$OMP THREADPRIVATE(sza_o)
-  INTEGER, SAVE, ALLOCATABLE ::  itau_con(:)       ! Nombre de pas ou rflag <= 1
-  !$OMP THREADPRIVATE(itau_con)
-  REAL, SAVE, ALLOCATABLE :: bils_ec(:) ! Contribution of energy conservation
-  REAL, SAVE, ALLOCATABLE :: bils_ech(:) ! Contribution of energy conservation
-  REAL, SAVE, ALLOCATABLE :: bils_tke(:) ! Contribution of energy conservation
-  REAL, SAVE, ALLOCATABLE :: bils_diss(:) ! Contribution of energy conservation
-  REAL, SAVE, ALLOCATABLE :: bils_kinetic(:) ! bilan de chaleur au sol, kinetic
-  REAL, SAVE, ALLOCATABLE :: bils_enthalp(:) ! bilan de chaleur au sol
-  REAL, SAVE, ALLOCATABLE :: bils_latent(:) ! bilan de chaleur au sol
-  !$OMP THREADPRIVATE(bils_ec,bils_ech,bils_tke,bils_diss,bils_kinetic,bils_enthalp,bils_latent)
-  ! output variables for energy conservation tests, computed in add_phys_tend
-  REAL, SAVE, ALLOCATABLE :: d_qw_col(:)      ! watter vapour mass budget for each column (kg/m2/s)
-  REAL, SAVE, ALLOCATABLE :: d_ql_col(:)      ! liquid watter mass budget for each column (kg/m2/s)
-  REAL, SAVE, ALLOCATABLE :: d_qs_col(:)      ! cloud ice mass budget for each column (kg/m2/s)
-  REAL, SAVE, ALLOCATABLE :: d_qbs_col(:)     ! blowing snow mass budget for each column (kg/m2/s)
-  REAL, SAVE, ALLOCATABLE :: d_qt_col(:)      ! total watter mass budget for each column (kg/m2/s)
-  REAL, SAVE, ALLOCATABLE :: d_ek_col(:)      ! kinetic energy budget for each column (W/m2)
-  REAL, SAVE, ALLOCATABLE :: d_h_dair_col(:)  ! enthalpy budget of dry air for each column (W/m2)
-  REAL, SAVE, ALLOCATABLE :: d_h_qw_col(:)    ! enthalpy budget of watter vapour for each column (W/m2)
-  REAL, SAVE, ALLOCATABLE :: d_h_ql_col(:)    ! enthalpy budget of liquid watter for each column (W/m2)
-  REAL, SAVE, ALLOCATABLE :: d_h_qs_col(:)    ! enthalpy budget of cloud ice  for each column (W/m2)
-  REAL, SAVE, ALLOCATABLE :: d_h_qbs_col(:)    ! enthalpy budget of blowing snow for each column (W/m2)
-  REAL, SAVE, ALLOCATABLE :: d_h_col(:)       ! total enthalpy budget for each column (W/m2)
-  !$OMP THREADPRIVATE(d_qw_col, d_ql_col, d_qs_col, d_qbs_col, d_qt_col, d_ek_col, d_h_dair_col)
-  !$OMP THREADPRIVATE(d_h_qw_col, d_h_ql_col, d_h_qs_col, d_h_qbs_col, d_h_col)
-
-  ! Outputs used in cloudth_vert to extract the moments of the horizontal and 
-  ! vertical PDFs
-  REAL, SAVE, ALLOCATABLE :: cloudth_sth(:,:),cloudth_senv(:,:)
-  !$OMP THREADPRIVATE(cloudth_sth,cloudth_senv)
-  REAL, SAVE, ALLOCATABLE :: cloudth_sigmath(:,:),cloudth_sigmaenv(:,:)
-  !$OMP THREADPRIVATE(cloudth_sigmath,cloudth_sigmaenv)
-
-! Marine
-! Variables de sortie du simulateur AIRS
-
-  REAL, SAVE, ALLOCATABLE :: map_prop_hc(:),map_prop_hist(:),alt_tropo(:)
-  !$OMP THREADPRIVATE(map_prop_hc,map_prop_hist,alt_tropo)
-  REAL, SAVE, ALLOCATABLE :: map_emis_hc(:),map_iwp_hc(:),map_deltaz_hc(:), &
-                       map_pcld_hc(:),map_tcld_hc(:)
-  !$OMP THREADPRIVATE(map_emis_hc,map_iwp_hc,map_deltaz_hc,map_pcld_hc,map_tcld_hc)
-  REAL, SAVE, ALLOCATABLE :: map_emis_hist(:),map_iwp_hist(:),map_deltaz_hist(:),map_rad_hist(:)         
-  !$OMP THREADPRIVATE(map_emis_hist,map_iwp_hist,map_deltaz_hist,map_rad_hist)
-  REAL, SAVE, ALLOCATABLE :: map_ntot(:),map_hc(:),map_hist(:)
-  REAL, SAVE, ALLOCATABLE :: map_Cb(:),map_ThCi(:),map_Anv(:)
-  !$OMP THREADPRIVATE(map_ntot,map_hc,map_hist,map_Cb,map_ThCi,map_Anv)
-  REAL, SAVE, ALLOCATABLE :: map_emis_Cb(:),map_pcld_Cb(:),map_tcld_Cb(:)
-  REAL, SAVE, ALLOCATABLE :: map_emis_ThCi(:),map_pcld_ThCi(:),map_tcld_ThCi(:)
-  !$OMP THREADPRIVATE(map_emis_Cb,map_pcld_Cb,map_tcld_Cb,map_emis_ThCi)
-  REAL, SAVE, ALLOCATABLE :: map_emis_Anv(:),map_pcld_Anv(:),map_tcld_Anv(:)
-  !$OMP THREADPRIVATE(map_pcld_ThCi,map_tcld_ThCi,map_emis_Anv,map_pcld_Anv,map_tcld_Anv)
-
-  ! variables deplacees de phys_local_var_mod
-  REAL, SAVE, ALLOCATABLE :: scdnc(:,:)
-  !$OMP THREADPRIVATE(scdnc)
-  REAL, SAVE, ALLOCATABLE :: cldncl(:)
-  !$OMP THREADPRIVATE(cldncl)
-  REAL, SAVE, ALLOCATABLE :: reffclwtop(:)
-  !$OMP THREADPRIVATE(reffclwtop)
-  REAL, SAVE, ALLOCATABLE :: lcc(:)
-  !$OMP THREADPRIVATE(lcc)
-  REAL, SAVE, ALLOCATABLE :: reffclws(:,:)
-  !$OMP THREADPRIVATE(reffclws)
-  REAL, SAVE, ALLOCATABLE :: reffclwc(:,:)
-  !$OMP THREADPRIVATE(reffclwc)
-  REAL, SAVE, ALLOCATABLE :: cldnvi(:) 
-  !$OMP THREADPRIVATE(cldnvi)
-  REAL, SAVE, ALLOCATABLE :: lcc3d(:,:)
-  !$OMP THREADPRIVATE(lcc3d)
-  REAL, SAVE, ALLOCATABLE :: lcc3dcon(:,:)
-  !$OMP THREADPRIVATE(lcc3dcon)
-  REAL, SAVE, ALLOCATABLE :: lcc3dstra(:,:)
-  !$OMP THREADPRIVATE(lcc3dstra)
-  REAL, SAVE, ALLOCATABLE :: icc3dcon(:,:)
-  !$OMP THREADPRIVATE(icc3dcon)
-  REAL, SAVE, ALLOCATABLE :: icc3dstra(:,:)
-  !$OMP THREADPRIVATE(icc3dstra)  
-   
-
-  ! ug Plein de variables venues de phys_output_mod
-  INTEGER, PARAMETER                           :: nfiles = 10
-  LOGICAL, DIMENSION(nfiles), SAVE             :: clef_files
-  LOGICAL, DIMENSION(nfiles), SAVE             :: clef_stations
-  INTEGER, DIMENSION(nfiles), SAVE             :: lev_files
-  INTEGER, DIMENSION(nfiles), SAVE             :: nid_files
-  INTEGER, DIMENSION(nfiles), SAVE  :: nnid_files
-  !$OMP THREADPRIVATE(clef_files, clef_stations, lev_files,nid_files,nnid_files)
-  INTEGER, DIMENSION(nfiles), SAVE :: nnhorim
-
-  INTEGER, DIMENSION(nfiles), SAVE :: nhorim, nvertm
-  INTEGER, DIMENSION(nfiles), SAVE :: nvertap, nvertbp, nvertAlt
-  REAL, DIMENSION(nfiles), SAVE                :: zoutm
-  CHARACTER(LEN=20), DIMENSION(nfiles), SAVE   :: type_ecri
-  !$OMP THREADPRIVATE(nnhorim, nhorim, nvertm, zoutm,type_ecri)
-  CHARACTER(LEN=20), DIMENSION(nfiles), SAVE  :: type_ecri_files, phys_out_filetypes
-  !$OMP THREADPRIVATE(type_ecri_files, phys_out_filetypes)
-  CHARACTER(LEN=20), DIMENSION(nfiles), SAVE  :: phys_out_filenames
-  !$OMP THREADPRIVATE(phys_out_filenames)
-
-  ! swaero_diag : flag indicates if it is necessary to do calculation for some aerosol diagnostics
-  ! swaerofree_diag : flag indicates if it is necessary to do calculation for some aerosol diagnostics
-  ! dryaod_diag : flag indicates if it is necessary to do calculation for some aerosol diagnostics
-  !--OB: this needs to be set to FALSE by default and changed back to TRUE based on output requests
-  LOGICAL, SAVE                                :: swaerofree_diag=.FALSE.
-  LOGICAL, SAVE                                :: swaero_diag=.FALSE.
-  LOGICAL, SAVE                                :: dryaod_diag=.FALSE.
-  !$OMP THREADPRIVATE(swaerofree_diag, swaero_diag, dryaod_diag)
- 
-  ! ok_4xCO2atm : flag indicates if it is necessary to do a second call of
-  ! radiation code with a 4xCO2 or another different GES to assess SW/LW
-  ! in this case
-  !--IM: as for swaero_diag this needs to be set to FALSE by default and 
-  !      changed back to TRUE based on output requests
-  LOGICAL, SAVE                                :: ok_4xCO2atm=.FALSE.
-  !$OMP THREADPRIVATE(ok_4xCO2atm)
-
-  INTEGER, SAVE:: levmin(nfiles) = 1
-  INTEGER, SAVE:: levmax(nfiles)
-  !$OMP THREADPRIVATE(levmin, levmax)
-
-  REAL, SAVE                :: zdtime_moy
-  !$OMP THREADPRIVATE(zdtime_moy)
-
-  LOGICAL, SAVE :: vars_defined = .FALSE. ! ug PAS THREADPRIVATE ET C'EST NORMAL
-
-  REAL, allocatable:: zustr_gwd_hines(:), zvstr_gwd_hines(:) ! (klon)
-  REAL, allocatable:: zustr_gwd_front(:), zvstr_gwd_front(:) ! (klon)
-  REAL, allocatable:: zustr_gwd_rando(:), zvstr_gwd_rando(:) ! (klon)
-  !$OMP THREADPRIVATE(zustr_gwd_hines, zvstr_gwd_hines)
-  !$OMP THREADPRIVATE(zustr_gwd_front, zvstr_gwd_front)
-  !$OMP THREADPRIVATE(zustr_gwd_rando, zvstr_gwd_rando)
-
-  TYPE ctrl_out
-     INTEGER               :: flag(nfiles)
-     CHARACTER(len=maxlen) :: name
-     CHARACTER(len=maxlen) :: description
-     CHARACTER(len=maxlen) :: unit
-     CHARACTER(len=maxlen) :: type_ecrit(nfiles)
-  END TYPE ctrl_out
-
-  REAL, SAVE, ALLOCATABLE :: sens_prec_liq_o(:,:), sens_prec_sol_o(:,:)
-  REAL, SAVE, ALLOCATABLE :: lat_prec_liq_o(:,:), lat_prec_sol_o(:,:)
- !$OMP THREADPRIVATE(sens_prec_liq_o, sens_prec_sol_o,lat_prec_liq_o,lat_prec_sol_o)
-
-  ! Ocean-atmosphere interface, subskin ocean and near-surface ocean:
-  
-  REAL, SAVE, ALLOCATABLE:: tkt(:) ! (klon)
-  ! épaisseur (m) de la couche de diffusion thermique (microlayer)
-  ! cool skin thickness
-
-  REAL, SAVE, ALLOCATABLE:: tks(:) ! (klon)
-  ! épaisseur (m) de la couche de diffusion de masse (microlayer)
-  
-  REAL, SAVE, ALLOCATABLE:: taur(:) ! (klon) momentum flux due to rain, in Pa
-
-  REAL, SAVE, ALLOCATABLE:: sss(:) ! (klon)
-  ! bulk salinity of the surface layer of the ocean, in ppt
-  
-  !$OMP THREADPRIVATE(tkt, tks, taur, sss)
-
-  !AI. cloud_cover_sw, cloud_cover_sw_s2 from Ecrad (1rt and 2 call)
-  REAL, SAVE, ALLOCATABLE:: cloud_cover_sw(:), cloud_cover_sw_s2(:)
-  !$OMP THREADPRIVATE(cloud_cover_sw, cloud_cover_sw_s2)
-
-CONTAINS
-
-  !======================================================================
-  SUBROUTINE phys_output_var_init
-    use dimphy
-    use config_ocean_skin_m, only: activate_ocean_skin
-
-    IMPLICIT NONE
-
-    include "clesphys.h"
-
-    !------------------------------------------------
-
-    allocate(snow_o(klon), zfra_o(klon))
-    allocate(sza_o(klon) )
-    allocate(itau_con(klon))
-    allocate(sens_prec_liq_o(klon,2))
-    allocate(sens_prec_sol_o(klon,2))
-    allocate(lat_prec_liq_o(klon,2))
-    allocate(lat_prec_sol_o(klon,2))
-    sens_prec_liq_o = 0.0 ; sens_prec_sol_o = 0.0
-    lat_prec_liq_o = 0.0 ; lat_prec_sol_o = 0.0
-
-    allocate (bils_ec(klon),bils_ech(klon),bils_tke(klon),bils_diss(klon),bils_kinetic(klon),bils_enthalp(klon),bils_latent(klon))
-    allocate (d_qw_col(klon), d_ql_col(klon), d_qs_col(klon), d_qbs_col(klon), d_qt_col(klon), d_ek_col(klon), d_h_dair_col(klon) &
-  &         , d_h_qw_col(klon), d_h_ql_col(klon), d_h_qs_col(klon), d_h_qbs_col(klon), d_h_col(klon))
-    d_qw_col=0. ; d_ql_col=0. ; d_qs_col=0. ; d_qbs_col=0. ; d_qt_col=0. ; d_ek_col=0. ; d_h_dair_col =0.
-    d_h_qw_col=0. ; d_h_ql_col=0. ; d_h_qs_col=0. ; d_h_qbs_col=0. ; d_h_col=0.
-
-    ! Outputs used in cloudth_vert
-    allocate(cloudth_sth(klon,klev))
-    allocate(cloudth_senv(klon,klev))
-    cloudth_sth = 0. ; cloudth_senv = 0. 
-    allocate(cloudth_sigmath(klon,klev))
-    allocate(cloudth_sigmaenv(klon,klev))
-    cloudth_sigmath = 0. ; cloudth_sigmaenv = 0.
-
-! Marine
-! Variables de sortie simulateur AIRS
-
-!     if (ok_airs) then
-      allocate (map_prop_hc(klon),map_prop_hist(klon))
-      allocate (alt_tropo(klon))
-      allocate (map_emis_hc(klon),map_iwp_hc(klon),map_deltaz_hc(klon))
-      allocate (map_pcld_hc(klon),map_tcld_hc(klon))
-      allocate (map_emis_hist(klon),map_iwp_hist(klon),map_deltaz_hist(klon))
-      allocate (map_rad_hist(klon))
-      allocate (map_ntot(klon),map_hc(klon),map_hist(klon))
-      allocate (map_Cb(klon),map_ThCi(klon),map_Anv(klon))
-      allocate (map_emis_Cb(klon),map_pcld_Cb(klon),map_tcld_Cb(klon))
-      allocate (map_emis_ThCi(klon),map_pcld_ThCi(klon),map_tcld_ThCi(klon))
-      allocate (map_emis_Anv(klon),map_pcld_Anv(klon),map_tcld_Anv(klon))
-!     endif
-
-    IF (ok_hines) allocate(zustr_gwd_hines(klon), zvstr_gwd_hines(klon))
-    IF (.not.ok_hines.and.ok_gwd_rando) &
-                  allocate(zustr_gwd_front(klon), zvstr_gwd_front(klon))
-    IF (ok_gwd_rando) allocate(zustr_gwd_rando(klon), zvstr_gwd_rando(klon))
-
-    if (activate_ocean_skin >= 1) allocate(tkt(klon), tks(klon), taur(klon), &
-         sss(klon))
-
-! Sorties de lmdz_cloud_optics_pro
-    ALLOCATE(scdnc(klon, klev))
-    ALLOCATE(cldncl(klon))
-    ALLOCATE(reffclwtop(klon))
-    ALLOCATE(lcc(klon))
-    ALLOCATE(reffclws(klon, klev))
-    ALLOCATE(reffclwc(klon, klev))
-    ALLOCATE(cldnvi(klon))
-    ALLOCATE(lcc3d(klon, klev))
-    ALLOCATE(lcc3dcon(klon, klev))
-    ALLOCATE(lcc3dstra(klon, klev))
-    ALLOCATE(icc3dcon(klon, klev))
-    ALLOCATE(icc3dstra(klon, klev))
-
-    ! cloud_cover_sw, cloud_cover_sw_s2 from Ecrad
-    ALLOCATE(cloud_cover_sw(klon))
-    ALLOCATE(cloud_cover_sw_s2(klon))
-
-  END SUBROUTINE phys_output_var_init
-
-  !======================================================================
-  SUBROUTINE phys_output_var_end
-    USE dimphy
-    IMPLICIT NONE
-
-    include "clesphys.h"
-
-    deallocate(snow_o,zfra_o,itau_con)
-    deallocate(sza_o)
-    deallocate (bils_ec,bils_ech,bils_tke,bils_diss,bils_kinetic,bils_enthalp,bils_latent)
-    deallocate (d_qw_col, d_ql_col, d_qs_col, d_qbs_col, d_qt_col, d_ek_col, d_h_dair_col &
-  &           , d_h_qw_col, d_h_ql_col, d_h_qs_col, d_h_qbs_col, d_h_col)
-
-    ! Outputs used in cloudth_vert
-    deallocate(cloudth_sth)
-    deallocate(cloudth_senv)
-    deallocate(cloudth_sigmath)
-    deallocate(cloudth_sigmaenv)
-
-! Marine
-! Variables de sortie simulateur AIRS
-
- !    if (ok_airs) then
-      deallocate (map_prop_hc,map_prop_hist)
-      deallocate (alt_tropo)
-      deallocate (map_emis_hc,map_iwp_hc,map_deltaz_hc)
-      deallocate (map_pcld_hc,map_tcld_hc)
-      deallocate (map_emis_hist,map_iwp_hist,map_deltaz_hist)
-      deallocate (map_rad_hist)
-      deallocate (map_ntot,map_hc,map_hist)
-      deallocate (map_Cb,map_ThCi,map_Anv)
-      deallocate (map_emis_Cb,map_pcld_Cb,map_tcld_Cb)
-      deallocate (map_emis_ThCi,map_pcld_ThCi,map_tcld_ThCi)
-      deallocate (map_emis_Anv,map_pcld_Anv,map_tcld_Anv)
-  !   endif
-
-    DEALLOCATE(scdnc)
-    DEALLOCATE(cldncl)
-    DEALLOCATE(reffclwtop)
-    DEALLOCATE(lcc)
-    DEALLOCATE(reffclws)
-    DEALLOCATE(reffclwc)
-    DEALLOCATE(cldnvi)
-    DEALLOCATE(lcc3d)
-    DEALLOCATE(lcc3dcon)
-    DEALLOCATE(lcc3dstra)
-    DEALLOCATE(icc3dcon)
-    DEALLOCATE(icc3dstra)
-
-    !AI cloud_cover_sw, cloud_cover_sw_s2 from Ecrad
-    DEALLOCATE(cloud_cover_sw, cloud_cover_sw_s2)
-
-  END SUBROUTINE phys_output_var_end
-
-END MODULE phys_output_var_mod
Index: /LMDZ6/trunk/libf/phylmd/phys_output_var_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/phys_output_var_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/phys_output_var_mod.f90	(revision 5268)
@@ -0,0 +1,319 @@
+!
+! phys_local_var_mod.F90 1327 2010-03-17 15:33:56Z idelkadi $
+
+MODULE phys_output_var_mod
+
+  USE dimphy
+  USE strings_mod, ONLY: maxlen
+  ! Variables outputs pour les ecritures des sorties
+  !======================================================================
+  !
+  !
+  !======================================================================
+  ! Declaration des variables
+
+  REAL, SAVE, ALLOCATABLE :: snow_o(:), zfra_o(:)
+  !$OMP THREADPRIVATE(snow_o, zfra_o)
+  REAL, SAVE, ALLOCATABLE :: sza_o(:) ! solar zenithal angle
+  !$OMP THREADPRIVATE(sza_o)
+  INTEGER, SAVE, ALLOCATABLE ::  itau_con(:)       ! Nombre de pas ou rflag <= 1
+  !$OMP THREADPRIVATE(itau_con)
+  REAL, SAVE, ALLOCATABLE :: bils_ec(:) ! Contribution of energy conservation
+  REAL, SAVE, ALLOCATABLE :: bils_ech(:) ! Contribution of energy conservation
+  REAL, SAVE, ALLOCATABLE :: bils_tke(:) ! Contribution of energy conservation
+  REAL, SAVE, ALLOCATABLE :: bils_diss(:) ! Contribution of energy conservation
+  REAL, SAVE, ALLOCATABLE :: bils_kinetic(:) ! bilan de chaleur au sol, kinetic
+  REAL, SAVE, ALLOCATABLE :: bils_enthalp(:) ! bilan de chaleur au sol
+  REAL, SAVE, ALLOCATABLE :: bils_latent(:) ! bilan de chaleur au sol
+  !$OMP THREADPRIVATE(bils_ec,bils_ech,bils_tke,bils_diss,bils_kinetic,bils_enthalp,bils_latent)
+  ! output variables for energy conservation tests, computed in add_phys_tend
+  REAL, SAVE, ALLOCATABLE :: d_qw_col(:)      ! watter vapour mass budget for each column (kg/m2/s)
+  REAL, SAVE, ALLOCATABLE :: d_ql_col(:)      ! liquid watter mass budget for each column (kg/m2/s)
+  REAL, SAVE, ALLOCATABLE :: d_qs_col(:)      ! cloud ice mass budget for each column (kg/m2/s)
+  REAL, SAVE, ALLOCATABLE :: d_qbs_col(:)     ! blowing snow mass budget for each column (kg/m2/s)
+  REAL, SAVE, ALLOCATABLE :: d_qt_col(:)      ! total watter mass budget for each column (kg/m2/s)
+  REAL, SAVE, ALLOCATABLE :: d_ek_col(:)      ! kinetic energy budget for each column (W/m2)
+  REAL, SAVE, ALLOCATABLE :: d_h_dair_col(:)  ! enthalpy budget of dry air for each column (W/m2)
+  REAL, SAVE, ALLOCATABLE :: d_h_qw_col(:)    ! enthalpy budget of watter vapour for each column (W/m2)
+  REAL, SAVE, ALLOCATABLE :: d_h_ql_col(:)    ! enthalpy budget of liquid watter for each column (W/m2)
+  REAL, SAVE, ALLOCATABLE :: d_h_qs_col(:)    ! enthalpy budget of cloud ice  for each column (W/m2)
+  REAL, SAVE, ALLOCATABLE :: d_h_qbs_col(:)    ! enthalpy budget of blowing snow for each column (W/m2)
+  REAL, SAVE, ALLOCATABLE :: d_h_col(:)       ! total enthalpy budget for each column (W/m2)
+  !$OMP THREADPRIVATE(d_qw_col, d_ql_col, d_qs_col, d_qbs_col, d_qt_col, d_ek_col, d_h_dair_col)
+  !$OMP THREADPRIVATE(d_h_qw_col, d_h_ql_col, d_h_qs_col, d_h_qbs_col, d_h_col)
+
+  ! Outputs used in cloudth_vert to extract the moments of the horizontal and 
+  ! vertical PDFs
+  REAL, SAVE, ALLOCATABLE :: cloudth_sth(:,:),cloudth_senv(:,:)
+  !$OMP THREADPRIVATE(cloudth_sth,cloudth_senv)
+  REAL, SAVE, ALLOCATABLE :: cloudth_sigmath(:,:),cloudth_sigmaenv(:,:)
+  !$OMP THREADPRIVATE(cloudth_sigmath,cloudth_sigmaenv)
+
+! Marine
+! Variables de sortie du simulateur AIRS
+
+  REAL, SAVE, ALLOCATABLE :: map_prop_hc(:),map_prop_hist(:),alt_tropo(:)
+  !$OMP THREADPRIVATE(map_prop_hc,map_prop_hist,alt_tropo)
+  REAL, SAVE, ALLOCATABLE :: map_emis_hc(:),map_iwp_hc(:),map_deltaz_hc(:), &
+                       map_pcld_hc(:),map_tcld_hc(:)
+  !$OMP THREADPRIVATE(map_emis_hc,map_iwp_hc,map_deltaz_hc,map_pcld_hc,map_tcld_hc)
+  REAL, SAVE, ALLOCATABLE :: map_emis_hist(:),map_iwp_hist(:),map_deltaz_hist(:),map_rad_hist(:)         
+  !$OMP THREADPRIVATE(map_emis_hist,map_iwp_hist,map_deltaz_hist,map_rad_hist)
+  REAL, SAVE, ALLOCATABLE :: map_ntot(:),map_hc(:),map_hist(:)
+  REAL, SAVE, ALLOCATABLE :: map_Cb(:),map_ThCi(:),map_Anv(:)
+  !$OMP THREADPRIVATE(map_ntot,map_hc,map_hist,map_Cb,map_ThCi,map_Anv)
+  REAL, SAVE, ALLOCATABLE :: map_emis_Cb(:),map_pcld_Cb(:),map_tcld_Cb(:)
+  REAL, SAVE, ALLOCATABLE :: map_emis_ThCi(:),map_pcld_ThCi(:),map_tcld_ThCi(:)
+  !$OMP THREADPRIVATE(map_emis_Cb,map_pcld_Cb,map_tcld_Cb,map_emis_ThCi)
+  REAL, SAVE, ALLOCATABLE :: map_emis_Anv(:),map_pcld_Anv(:),map_tcld_Anv(:)
+  !$OMP THREADPRIVATE(map_pcld_ThCi,map_tcld_ThCi,map_emis_Anv,map_pcld_Anv,map_tcld_Anv)
+
+  ! variables deplacees de phys_local_var_mod
+  REAL, SAVE, ALLOCATABLE :: scdnc(:,:)
+  !$OMP THREADPRIVATE(scdnc)
+  REAL, SAVE, ALLOCATABLE :: cldncl(:)
+  !$OMP THREADPRIVATE(cldncl)
+  REAL, SAVE, ALLOCATABLE :: reffclwtop(:)
+  !$OMP THREADPRIVATE(reffclwtop)
+  REAL, SAVE, ALLOCATABLE :: lcc(:)
+  !$OMP THREADPRIVATE(lcc)
+  REAL, SAVE, ALLOCATABLE :: reffclws(:,:)
+  !$OMP THREADPRIVATE(reffclws)
+  REAL, SAVE, ALLOCATABLE :: reffclwc(:,:)
+  !$OMP THREADPRIVATE(reffclwc)
+  REAL, SAVE, ALLOCATABLE :: cldnvi(:) 
+  !$OMP THREADPRIVATE(cldnvi)
+  REAL, SAVE, ALLOCATABLE :: lcc3d(:,:)
+  !$OMP THREADPRIVATE(lcc3d)
+  REAL, SAVE, ALLOCATABLE :: lcc3dcon(:,:)
+  !$OMP THREADPRIVATE(lcc3dcon)
+  REAL, SAVE, ALLOCATABLE :: lcc3dstra(:,:)
+  !$OMP THREADPRIVATE(lcc3dstra)
+  REAL, SAVE, ALLOCATABLE :: icc3dcon(:,:)
+  !$OMP THREADPRIVATE(icc3dcon)
+  REAL, SAVE, ALLOCATABLE :: icc3dstra(:,:)
+  !$OMP THREADPRIVATE(icc3dstra)  
+   
+
+  ! ug Plein de variables venues de phys_output_mod
+  INTEGER, PARAMETER                           :: nfiles = 10
+  LOGICAL, DIMENSION(nfiles), SAVE             :: clef_files
+  LOGICAL, DIMENSION(nfiles), SAVE             :: clef_stations
+  INTEGER, DIMENSION(nfiles), SAVE             :: lev_files
+  INTEGER, DIMENSION(nfiles), SAVE             :: nid_files
+  INTEGER, DIMENSION(nfiles), SAVE  :: nnid_files
+  !$OMP THREADPRIVATE(clef_files, clef_stations, lev_files,nid_files,nnid_files)
+  INTEGER, DIMENSION(nfiles), SAVE :: nnhorim
+
+  INTEGER, DIMENSION(nfiles), SAVE :: nhorim, nvertm
+  INTEGER, DIMENSION(nfiles), SAVE :: nvertap, nvertbp, nvertAlt
+  REAL, DIMENSION(nfiles), SAVE                :: zoutm
+  CHARACTER(LEN=20), DIMENSION(nfiles), SAVE   :: type_ecri
+  !$OMP THREADPRIVATE(nnhorim, nhorim, nvertm, zoutm,type_ecri)
+  CHARACTER(LEN=20), DIMENSION(nfiles), SAVE  :: type_ecri_files, phys_out_filetypes
+  !$OMP THREADPRIVATE(type_ecri_files, phys_out_filetypes)
+  CHARACTER(LEN=20), DIMENSION(nfiles), SAVE  :: phys_out_filenames
+  !$OMP THREADPRIVATE(phys_out_filenames)
+
+  ! swaero_diag : flag indicates if it is necessary to do calculation for some aerosol diagnostics
+  ! swaerofree_diag : flag indicates if it is necessary to do calculation for some aerosol diagnostics
+  ! dryaod_diag : flag indicates if it is necessary to do calculation for some aerosol diagnostics
+  !--OB: this needs to be set to FALSE by default and changed back to TRUE based on output requests
+  LOGICAL, SAVE                                :: swaerofree_diag=.FALSE.
+  LOGICAL, SAVE                                :: swaero_diag=.FALSE.
+  LOGICAL, SAVE                                :: dryaod_diag=.FALSE.
+  !$OMP THREADPRIVATE(swaerofree_diag, swaero_diag, dryaod_diag)
+ 
+  ! ok_4xCO2atm : flag indicates if it is necessary to do a second call of
+  ! radiation code with a 4xCO2 or another different GES to assess SW/LW
+  ! in this case
+  !--IM: as for swaero_diag this needs to be set to FALSE by default and 
+  !      changed back to TRUE based on output requests
+  LOGICAL, SAVE                                :: ok_4xCO2atm=.FALSE.
+  !$OMP THREADPRIVATE(ok_4xCO2atm)
+
+  INTEGER, SAVE:: levmin(nfiles) = 1
+  INTEGER, SAVE:: levmax(nfiles)
+  !$OMP THREADPRIVATE(levmin, levmax)
+
+  REAL, SAVE                :: zdtime_moy
+  !$OMP THREADPRIVATE(zdtime_moy)
+
+  LOGICAL, SAVE :: vars_defined = .FALSE. ! ug PAS THREADPRIVATE ET C'EST NORMAL
+
+  REAL, allocatable:: zustr_gwd_hines(:), zvstr_gwd_hines(:) ! (klon)
+  REAL, allocatable:: zustr_gwd_front(:), zvstr_gwd_front(:) ! (klon)
+  REAL, allocatable:: zustr_gwd_rando(:), zvstr_gwd_rando(:) ! (klon)
+  !$OMP THREADPRIVATE(zustr_gwd_hines, zvstr_gwd_hines)
+  !$OMP THREADPRIVATE(zustr_gwd_front, zvstr_gwd_front)
+  !$OMP THREADPRIVATE(zustr_gwd_rando, zvstr_gwd_rando)
+
+  TYPE ctrl_out
+     INTEGER               :: flag(nfiles)
+     CHARACTER(len=maxlen) :: name
+     CHARACTER(len=maxlen) :: description
+     CHARACTER(len=maxlen) :: unit
+     CHARACTER(len=maxlen) :: type_ecrit(nfiles)
+  END TYPE ctrl_out
+
+  REAL, SAVE, ALLOCATABLE :: sens_prec_liq_o(:,:), sens_prec_sol_o(:,:)
+  REAL, SAVE, ALLOCATABLE :: lat_prec_liq_o(:,:), lat_prec_sol_o(:,:)
+ !$OMP THREADPRIVATE(sens_prec_liq_o, sens_prec_sol_o,lat_prec_liq_o,lat_prec_sol_o)
+
+  ! Ocean-atmosphere interface, subskin ocean and near-surface ocean:
+  
+  REAL, SAVE, ALLOCATABLE:: tkt(:) ! (klon)
+  ! épaisseur (m) de la couche de diffusion thermique (microlayer)
+  ! cool skin thickness
+
+  REAL, SAVE, ALLOCATABLE:: tks(:) ! (klon)
+  ! épaisseur (m) de la couche de diffusion de masse (microlayer)
+  
+  REAL, SAVE, ALLOCATABLE:: taur(:) ! (klon) momentum flux due to rain, in Pa
+
+  REAL, SAVE, ALLOCATABLE:: sss(:) ! (klon)
+  ! bulk salinity of the surface layer of the ocean, in ppt
+  
+  !$OMP THREADPRIVATE(tkt, tks, taur, sss)
+
+  !AI. cloud_cover_sw, cloud_cover_sw_s2 from Ecrad (1rt and 2 call)
+  REAL, SAVE, ALLOCATABLE:: cloud_cover_sw(:), cloud_cover_sw_s2(:)
+  !$OMP THREADPRIVATE(cloud_cover_sw, cloud_cover_sw_s2)
+
+CONTAINS
+
+  !======================================================================
+  SUBROUTINE phys_output_var_init
+    use dimphy
+    use config_ocean_skin_m, only: activate_ocean_skin
+
+    IMPLICIT NONE
+
+    include "clesphys.h"
+
+    !------------------------------------------------
+
+    allocate(snow_o(klon), zfra_o(klon))
+    allocate(sza_o(klon) )
+    allocate(itau_con(klon))
+    allocate(sens_prec_liq_o(klon,2))
+    allocate(sens_prec_sol_o(klon,2))
+    allocate(lat_prec_liq_o(klon,2))
+    allocate(lat_prec_sol_o(klon,2))
+    sens_prec_liq_o = 0.0 ; sens_prec_sol_o = 0.0
+    lat_prec_liq_o = 0.0 ; lat_prec_sol_o = 0.0
+
+    allocate (bils_ec(klon),bils_ech(klon),bils_tke(klon),bils_diss(klon),bils_kinetic(klon),bils_enthalp(klon),bils_latent(klon))
+    allocate (d_qw_col(klon), d_ql_col(klon), d_qs_col(klon), d_qbs_col(klon), d_qt_col(klon), d_ek_col(klon), d_h_dair_col(klon) &
+  &         , d_h_qw_col(klon), d_h_ql_col(klon), d_h_qs_col(klon), d_h_qbs_col(klon), d_h_col(klon))
+    d_qw_col=0. ; d_ql_col=0. ; d_qs_col=0. ; d_qbs_col=0. ; d_qt_col=0. ; d_ek_col=0. ; d_h_dair_col =0.
+    d_h_qw_col=0. ; d_h_ql_col=0. ; d_h_qs_col=0. ; d_h_qbs_col=0. ; d_h_col=0.
+
+    ! Outputs used in cloudth_vert
+    allocate(cloudth_sth(klon,klev))
+    allocate(cloudth_senv(klon,klev))
+    cloudth_sth = 0. ; cloudth_senv = 0. 
+    allocate(cloudth_sigmath(klon,klev))
+    allocate(cloudth_sigmaenv(klon,klev))
+    cloudth_sigmath = 0. ; cloudth_sigmaenv = 0.
+
+! Marine
+! Variables de sortie simulateur AIRS
+
+!     if (ok_airs) then
+      allocate (map_prop_hc(klon),map_prop_hist(klon))
+      allocate (alt_tropo(klon))
+      allocate (map_emis_hc(klon),map_iwp_hc(klon),map_deltaz_hc(klon))
+      allocate (map_pcld_hc(klon),map_tcld_hc(klon))
+      allocate (map_emis_hist(klon),map_iwp_hist(klon),map_deltaz_hist(klon))
+      allocate (map_rad_hist(klon))
+      allocate (map_ntot(klon),map_hc(klon),map_hist(klon))
+      allocate (map_Cb(klon),map_ThCi(klon),map_Anv(klon))
+      allocate (map_emis_Cb(klon),map_pcld_Cb(klon),map_tcld_Cb(klon))
+      allocate (map_emis_ThCi(klon),map_pcld_ThCi(klon),map_tcld_ThCi(klon))
+      allocate (map_emis_Anv(klon),map_pcld_Anv(klon),map_tcld_Anv(klon))
+!     endif
+
+    IF (ok_hines) allocate(zustr_gwd_hines(klon), zvstr_gwd_hines(klon))
+    IF (.not.ok_hines.and.ok_gwd_rando) &
+                  allocate(zustr_gwd_front(klon), zvstr_gwd_front(klon))
+    IF (ok_gwd_rando) allocate(zustr_gwd_rando(klon), zvstr_gwd_rando(klon))
+
+    if (activate_ocean_skin >= 1) allocate(tkt(klon), tks(klon), taur(klon), &
+         sss(klon))
+
+! Sorties de lmdz_cloud_optics_pro
+    ALLOCATE(scdnc(klon, klev))
+    ALLOCATE(cldncl(klon))
+    ALLOCATE(reffclwtop(klon))
+    ALLOCATE(lcc(klon))
+    ALLOCATE(reffclws(klon, klev))
+    ALLOCATE(reffclwc(klon, klev))
+    ALLOCATE(cldnvi(klon))
+    ALLOCATE(lcc3d(klon, klev))
+    ALLOCATE(lcc3dcon(klon, klev))
+    ALLOCATE(lcc3dstra(klon, klev))
+    ALLOCATE(icc3dcon(klon, klev))
+    ALLOCATE(icc3dstra(klon, klev))
+
+    ! cloud_cover_sw, cloud_cover_sw_s2 from Ecrad
+    ALLOCATE(cloud_cover_sw(klon))
+    ALLOCATE(cloud_cover_sw_s2(klon))
+
+  END SUBROUTINE phys_output_var_init
+
+  !======================================================================
+  SUBROUTINE phys_output_var_end
+    USE dimphy
+    IMPLICIT NONE
+
+    include "clesphys.h"
+
+    deallocate(snow_o,zfra_o,itau_con)
+    deallocate(sza_o)
+    deallocate (bils_ec,bils_ech,bils_tke,bils_diss,bils_kinetic,bils_enthalp,bils_latent)
+    deallocate (d_qw_col, d_ql_col, d_qs_col, d_qbs_col, d_qt_col, d_ek_col, d_h_dair_col &
+  &           , d_h_qw_col, d_h_ql_col, d_h_qs_col, d_h_qbs_col, d_h_col)
+
+    ! Outputs used in cloudth_vert
+    deallocate(cloudth_sth)
+    deallocate(cloudth_senv)
+    deallocate(cloudth_sigmath)
+    deallocate(cloudth_sigmaenv)
+
+! Marine
+! Variables de sortie simulateur AIRS
+
+ !    if (ok_airs) then
+      deallocate (map_prop_hc,map_prop_hist)
+      deallocate (alt_tropo)
+      deallocate (map_emis_hc,map_iwp_hc,map_deltaz_hc)
+      deallocate (map_pcld_hc,map_tcld_hc)
+      deallocate (map_emis_hist,map_iwp_hist,map_deltaz_hist)
+      deallocate (map_rad_hist)
+      deallocate (map_ntot,map_hc,map_hist)
+      deallocate (map_Cb,map_ThCi,map_Anv)
+      deallocate (map_emis_Cb,map_pcld_Cb,map_tcld_Cb)
+      deallocate (map_emis_ThCi,map_pcld_ThCi,map_tcld_ThCi)
+      deallocate (map_emis_Anv,map_pcld_Anv,map_tcld_Anv)
+  !   endif
+
+    DEALLOCATE(scdnc)
+    DEALLOCATE(cldncl)
+    DEALLOCATE(reffclwtop)
+    DEALLOCATE(lcc)
+    DEALLOCATE(reffclws)
+    DEALLOCATE(reffclwc)
+    DEALLOCATE(cldnvi)
+    DEALLOCATE(lcc3d)
+    DEALLOCATE(lcc3dcon)
+    DEALLOCATE(lcc3dstra)
+    DEALLOCATE(icc3dcon)
+    DEALLOCATE(icc3dstra)
+
+    !AI cloud_cover_sw, cloud_cover_sw_s2 from Ecrad
+    DEALLOCATE(cloud_cover_sw, cloud_cover_sw_s2)
+
+  END SUBROUTINE phys_output_var_end
+
+END MODULE phys_output_var_mod
Index: DZ6/trunk/libf/phylmd/phystokenc_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/phystokenc_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,389 +1,0 @@
-!
-! $Id$
-!
-MODULE phystokenc_mod
-
-  IMPLICIT NONE
-
-  LOGICAL,SAVE :: offline
-!$OMP THREADPRIVATE(offline)
-  INTEGER,SAVE :: istphy
-!$OMP THREADPRIVATE(istphy)
-
-
-CONTAINS
-
-  SUBROUTINE init_phystokenc(offline_dyn,istphy_dyn)
-    IMPLICIT NONE
-    LOGICAL,INTENT(IN) :: offline_dyn
-    INTEGER,INTENT(IN) :: istphy_dyn
-
-    offline=offline_dyn
-    istphy=istphy_dyn
-
-  END SUBROUTINE init_phystokenc
-
-SUBROUTINE phystokenc (nlon,nlev,pdtphys,rlon,rlat, &
-     pt,pmfu, pmfd, pen_u, pde_u, pen_d, pde_d, &
-     pfm_therm,pentr_therm, &
-     cdragh, pcoefh,yu1,yv1,ftsol,pctsrf, &
-     frac_impa,frac_nucl, &
-     pphis,paire,dtime,itap, &
-     psh, pda, pphi, pmp, pupwd, pdnwd)
-  
-  USE ioipsl
-  USE dimphy
-  USE infotrac_phy, ONLY : nqtot
-  USE iophy
-  USE indice_sol_mod
-  USE print_control_mod, ONLY: lunout
-  USE mod_grid_phy_lmdz, ONLY: nbp_lon, nbp_lat
-  
-  IMPLICIT NONE
-  
-!======================================================================
-! Auteur(s) FH
-! Objet: Ecriture des variables pour transport offline
-!
-!  Note (A Cozic - July 2024): when coupled with inca, offline fields are no 
-!  longer calculated in this routine but directly in the physics code.
-!======================================================================
-
-! Arguments:
-!
-  REAL,DIMENSION(klon,klev), INTENT(IN)     :: psh   ! humidite specifique
-  REAL,DIMENSION(klon,klev), INTENT(IN)     :: pda
-  REAL,DIMENSION(klon,klev,klev), INTENT(IN):: pphi
-  REAL,DIMENSION(klon,klev), INTENT(IN)     :: pmp
-  REAL,DIMENSION(klon,klev), INTENT(IN)     :: pupwd ! saturated updraft mass flux
-  REAL,DIMENSION(klon,klev), INTENT(IN)     :: pdnwd ! saturated downdraft mass flux
-
-!   EN ENTREE:
-!   ==========
-!
-!   divers:
-!   -------
-!
-  INTEGER nlon ! nombre de points horizontaux
-  INTEGER nlev ! nombre de couches verticales
-  REAL pdtphys ! pas d'integration pour la physique (seconde)
-  INTEGER itap
-  INTEGER, SAVE :: physid
-!$OMP THREADPRIVATE(physid)
-
-!   convection:
-!   -----------
-!
-  REAL pmfu(klon,klev)  ! flux de masse dans le panache montant
-  REAL pmfd(klon,klev)  ! flux de masse dans le panache descendant
-  REAL pen_u(klon,klev) ! flux entraine dans le panache montant
-  REAL pde_u(klon,klev) ! flux detraine dans le panache montant
-  REAL pen_d(klon,klev) ! flux entraine dans le panache descendant
-  REAL pde_d(klon,klev) ! flux detraine dans le panache descendant
-  REAL pt(klon,klev)
-  REAL,ALLOCATABLE,SAVE :: t(:,:)
-!$OMP THREADPRIVATE(t)
-!
-  REAL rlon(klon), rlat(klon), dtime
-  REAL zx_tmp_3d(nbp_lon,nbp_lat,klev),zx_tmp_2d(nbp_lon,nbp_lat)
-
-!   Couche limite:
-!   --------------
-!
-  REAL cdragh(klon)          ! cdrag
-  REAL pcoefh(klon,klev)     ! coeff melange CL
-  REAL pcoefh_buf(klon,klev) ! coeff melange CL + cdrag
-  REAL yv1(klon)
-  REAL yu1(klon),pphis(klon),paire(klon)
-
-!   Les Thermiques : (Abderr 25 11 02)
-!   ---------------
-  REAL, INTENT(IN) ::  pfm_therm(klon,klev+1)
-  REAL pentr_therm(klon,klev)
-  
-  REAL,ALLOCATABLE,SAVE :: entr_therm(:,:)
-  REAL,ALLOCATABLE,SAVE :: fm_therm(:,:)
-!$OMP THREADPRIVATE(entr_therm)
-!$OMP THREADPRIVATE(fm_therm)
-!
-!   Lessivage:
-!   ----------
-!
-  REAL frac_impa(klon,klev)
-  REAL frac_nucl(klon,klev)
-!
-! Arguments necessaires pour les sources et puits de traceur
-!
-  REAL ftsol(klon,nbsrf)  ! Temperature du sol (surf)(Kelvin)
-  REAL pctsrf(klon,nbsrf) ! Pourcentage de sol f(nature du sol)
-!======================================================================
-!
-  INTEGER i, k, kk
-  REAL,ALLOCATABLE,SAVE :: mfu(:,:)  ! flux de masse dans le panache montant
-  REAL,ALLOCATABLE,SAVE :: mfd(:,:)  ! flux de masse dans le panache descendant
-  REAL,ALLOCATABLE,SAVE :: en_u(:,:) ! flux entraine dans le panache montant
-  REAL,ALLOCATABLE,SAVE :: de_u(:,:) ! flux detraine dans le panache montant
-  REAL,ALLOCATABLE,SAVE :: en_d(:,:) ! flux entraine dans le panache descendant
-  REAL,ALLOCATABLE,SAVE :: de_d(:,:) ! flux detraine dans le panache descendant
-  REAL,ALLOCATABLE,SAVE :: coefh(:,:) ! flux detraine dans le panache descendant
-  
-  REAL,ALLOCATABLE,SAVE :: pyu1(:)
-  REAL,ALLOCATABLE,SAVE :: pyv1(:)
-  REAL,ALLOCATABLE,SAVE :: pftsol(:,:)
-  REAL,ALLOCATABLE,SAVE :: ppsrf(:,:)
-!$OMP THREADPRIVATE(mfu,mfd,en_u,de_u,en_d,de_d,coefh)
-!$OMP THREADPRIVATE(pyu1,pyv1,pftsol,ppsrf)
-
-
-  REAL,DIMENSION(:,:), ALLOCATABLE,SAVE     :: sh  
-  REAL,DIMENSION(:,:), ALLOCATABLE,SAVE     :: da
-  REAL,DIMENSION(:,:,:), ALLOCATABLE,SAVE   :: phi
-  REAL,DIMENSION(:,:), ALLOCATABLE,SAVE     :: mp
-  REAL,DIMENSION(:,:), ALLOCATABLE,SAVE     :: upwd
-  REAL,DIMENSION(:,:), ALLOCATABLE,SAVE     :: dnwd
-  
-  REAL, SAVE :: dtcum
-  INTEGER, SAVE:: iadvtr=0
-!$OMP THREADPRIVATE(dtcum,iadvtr)
-  REAL zmin,zmax
-  LOGICAL ok_sync
-  CHARACTER(len=12) :: nvar
-  logical, parameter :: lstokenc=.FALSE.
-!
-!======================================================================
-
-  iadvtr=iadvtr+1
-
-! Dans le meme vecteur on recombine le drag et les coeff d'echange
-  pcoefh_buf(:,1)      = cdragh(:)
-  pcoefh_buf(:,2:klev) = pcoefh(:,2:klev)
-  
-  ok_sync = .TRUE.
-
-! Initialization done only once
-!======================================================================
-  IF (iadvtr==1) THEN
-     ALLOCATE( t(klon,klev))
-     ALLOCATE( mfu(klon,klev))  
-     ALLOCATE( mfd(klon,klev))  
-     ALLOCATE( en_u(klon,klev)) 
-     ALLOCATE( de_u(klon,klev)) 
-     ALLOCATE( en_d(klon,klev)) 
-     ALLOCATE( de_d(klon,klev)) 
-     ALLOCATE( coefh(klon,klev)) 
-     ALLOCATE( entr_therm(klon,klev))
-     ALLOCATE( fm_therm(klon,klev))
-     ALLOCATE( pyu1(klon))
-     ALLOCATE( pyv1(klon))
-     ALLOCATE( pftsol(klon,nbsrf))
-     ALLOCATE( ppsrf(klon,nbsrf))
-     
-     ALLOCATE(sh(klon,klev)) 
-     ALLOCATE(da(klon,klev)) 
-     ALLOCATE(phi(klon,klev,klev)) 
-     ALLOCATE(mp(klon,klev)) 
-     ALLOCATE(upwd(klon,klev)) 
-     ALLOCATE(dnwd(klon,klev)) 
-
-     CALL initphysto('phystoke', dtime, dtime*istphy,dtime*istphy,physid)
-     
-     ! Write field phis and aire only once
-     CALL histwrite_phy(physid,lstokenc,"phis",itap,pphis)
-     CALL histwrite_phy(physid,lstokenc,"aire",itap,paire)
-     CALL histwrite_phy(physid,lstokenc,"longitudes",itap,rlon)
-     CALL histwrite_phy(physid,lstokenc,"latitudes",itap,rlat)
-
-  END IF
-  
-  
-! Set to zero cumulating fields
-!======================================================================
-  IF (MOD(iadvtr,istphy)==1.OR.istphy==1) THEN
-     WRITE(lunout,*)'reinitialisation des champs cumules a iadvtr=',iadvtr
-     mfu(:,:)=0.
-     mfd(:,:)=0.
-     en_u(:,:)=0.
-     de_u(:,:)=0.
-     en_d(:,:)=0.
-     de_d(:,:)=0.
-     coefh(:,:)=0.
-     t(:,:)=0.
-     fm_therm(:,:)=0.
-     entr_therm(:,:)=0.
-     pyv1(:)=0.
-     pyu1(:)=0.
-     pftsol(:,:)=0.
-     ppsrf(:,:)=0.
-     sh(:,:)=0.
-     da(:,:)=0.
-     phi(:,:,:)=0.
-     mp(:,:)=0.
-     upwd(:,:)=0.
-     dnwd(:,:)=0.
-     dtcum=0.
-  ENDIF
-  
-
-! Cumulate fields at each time step
-!======================================================================
-  DO k=1,klev
-     DO i=1,klon
-        mfu(i,k)=mfu(i,k)+pmfu(i,k)*pdtphys
-        mfd(i,k)=mfd(i,k)+pmfd(i,k)*pdtphys
-        en_u(i,k)=en_u(i,k)+pen_u(i,k)*pdtphys
-        de_u(i,k)=de_u(i,k)+pde_u(i,k)*pdtphys
-        en_d(i,k)=en_d(i,k)+pen_d(i,k)*pdtphys
-        de_d(i,k)=de_d(i,k)+pde_d(i,k)*pdtphys
-        coefh(i,k)=coefh(i,k)+pcoefh_buf(i,k)*pdtphys
-        t(i,k)=t(i,k)+pt(i,k)*pdtphys
-        fm_therm(i,k)=fm_therm(i,k)+pfm_therm(i,k)*pdtphys
-        entr_therm(i,k)=entr_therm(i,k)+pentr_therm(i,k)*pdtphys
-        sh(i,k) = sh(i,k) + psh(i,k)*pdtphys
-        da(i,k) = da(i,k) + pda(i,k)*pdtphys
-        mp(i,k) = mp(i,k) + pmp(i,k)*pdtphys
-        upwd(i,k) = upwd(i,k) + pupwd(i,k)*pdtphys
-        dnwd(i,k) = dnwd(i,k) + pdnwd(i,k)*pdtphys
-     ENDDO
-  ENDDO
-
-  DO kk=1,klev
-     DO k=1,klev
-        DO i=1,klon
-           phi(i,k,kk) = phi(i,k,kk) + pphi(i,k,kk)*pdtphys
-        END DO
-     END DO
-  END DO
-
-  DO i=1,klon
-     pyv1(i)=pyv1(i)+yv1(i)*pdtphys
-     pyu1(i)=pyu1(i)+yu1(i)*pdtphys
-  END DO
-  DO k=1,nbsrf
-     DO i=1,klon
-        pftsol(i,k)=pftsol(i,k)+ftsol(i,k)*pdtphys
-        ppsrf(i,k)=ppsrf(i,k)+pctsrf(i,k)*pdtphys
-     ENDDO
-  ENDDO
-  
-! Add time step to cumulated time
-  dtcum=dtcum+pdtphys
-  
-
-! Write fields to file, if it is time to do so
-!======================================================================
-  IF(MOD(iadvtr,istphy)==0) THEN 
-
-     ! normalize with time period
-     DO k=1,klev
-        DO i=1,klon
-           mfu(i,k)=mfu(i,k)/dtcum
-           mfd(i,k)=mfd(i,k)/dtcum
-           en_u(i,k)=en_u(i,k)/dtcum
-           de_u(i,k)=de_u(i,k)/dtcum
-           en_d(i,k)=en_d(i,k)/dtcum
-           de_d(i,k)=de_d(i,k)/dtcum
-           coefh(i,k)=coefh(i,k)/dtcum
-           t(i,k)=t(i,k)/dtcum	
-           fm_therm(i,k)=fm_therm(i,k)/dtcum
-           entr_therm(i,k)=entr_therm(i,k)/dtcum
-           sh(i,k)=sh(i,k)/dtcum
-           da(i,k)=da(i,k)/dtcum
-           mp(i,k)=mp(i,k)/dtcum
-           upwd(i,k)=upwd(i,k)/dtcum
-           dnwd(i,k)=dnwd(i,k)/dtcum
-        ENDDO
-     ENDDO
-     DO kk=1,klev
-        DO k=1,klev
-           DO i=1,klon
-              phi(i,k,kk) = phi(i,k,kk)/dtcum
-           END DO
-        END DO
-     END DO
-     DO i=1,klon
-        pyv1(i)=pyv1(i)/dtcum
-        pyu1(i)=pyu1(i)/dtcum
-     END DO
-     DO k=1,nbsrf
-        DO i=1,klon
-           pftsol(i,k)=pftsol(i,k)/dtcum
-           ppsrf(i,k)=ppsrf(i,k)/dtcum
-        ENDDO
-     ENDDO
-
-     ! write fields
-     CALL histwrite_phy(physid,lstokenc,"t",itap,t)
-     CALL histwrite_phy(physid,lstokenc,"mfu",itap,mfu)
-     CALL histwrite_phy(physid,lstokenc,"mfd",itap,mfd)
-     CALL histwrite_phy(physid,lstokenc,"en_u",itap,en_u)
-     CALL histwrite_phy(physid,lstokenc,"de_u",itap,de_u)
-     CALL histwrite_phy(physid,lstokenc,"en_d",itap,en_d)
-     CALL histwrite_phy(physid,lstokenc,"de_d",itap,de_d)
-     CALL histwrite_phy(physid,lstokenc,"coefh",itap,coefh)	
-     CALL histwrite_phy(physid,lstokenc,"fm_th",itap,fm_therm)
-     CALL histwrite_phy(physid,lstokenc,"en_th",itap,entr_therm)
-     CALL histwrite_phy(physid,lstokenc,"frac_impa",itap,frac_impa)
-     CALL histwrite_phy(physid,lstokenc,"frac_nucl",itap,frac_nucl)
-     CALL histwrite_phy(physid,lstokenc,"pyu1",itap,pyu1)
-     CALL histwrite_phy(physid,lstokenc,"pyv1",itap,pyv1)
-     CALL histwrite_phy(physid,lstokenc,"ftsol1",itap,pftsol(:,1))
-     CALL histwrite_phy(physid,lstokenc,"ftsol2",itap,pftsol(:,2))
-     CALL histwrite_phy(physid,lstokenc,"ftsol3",itap,pftsol(:,3))
-     CALL histwrite_phy(physid,lstokenc,"ftsol4",itap,pftsol(:,4))
-     CALL histwrite_phy(physid,lstokenc,"psrf1",itap,ppsrf(:,1))
-     CALL histwrite_phy(physid,lstokenc,"psrf2",itap,ppsrf(:,2))
-     CALL histwrite_phy(physid,lstokenc,"psrf3",itap,ppsrf(:,3))
-     CALL histwrite_phy(physid,lstokenc,"psrf4",itap,ppsrf(:,4))
-     CALL histwrite_phy(physid,lstokenc,"sh",itap,sh)
-     CALL histwrite_phy(physid,lstokenc,"da",itap,da)
-     CALL histwrite_phy(physid,lstokenc,"mp",itap,mp)
-     CALL histwrite_phy(physid,lstokenc,"upwd",itap,upwd)
-     CALL histwrite_phy(physid,lstokenc,"dnwd",itap,dnwd)
-
-
-! phi
-     DO k=1,klev
-        IF (k<10) THEN
-           WRITE(nvar,'(i1)') k
-        ELSE IF (k<100) THEN
-           WRITE(nvar,'(i2)') k
-        ELSE
-           WRITE(nvar,'(i3)') k
-        END IF
-        nvar='phi_lev'//trim(nvar)
-        
-        CALL histwrite_phy(physid,lstokenc,nvar,itap,phi(:,:,k))
-     END DO
-     
-     ! Syncronize file
-!$OMP MASTER
-     IF (ok_sync) CALL histsync(physid)
-!$OMP END MASTER
-     
-     
-     ! Calculate min and max values for some fields (coefficients de lessivage)
-     zmin=1e33
-     zmax=-1e33
-     DO k=1,klev
-        DO i=1,klon
-           zmax=MAX(zmax,frac_nucl(i,k))
-           zmin=MIN(zmin,frac_nucl(i,k))
-        ENDDO
-     ENDDO
-     WRITE(lunout,*)'------ coefs de lessivage (min et max) --------'
-     WRITE(lunout,*)'facteur de nucleation ',zmin,zmax
-     zmin=1e33
-     zmax=-1e33
-     DO k=1,klev
-        DO i=1,klon
-           zmax=MAX(zmax,frac_impa(i,k))
-           zmin=MIN(zmin,frac_impa(i,k))
-        ENDDO
-     ENDDO
-     WRITE(lunout,*)'facteur d impaction ',zmin,zmax
-     
-  ENDIF ! IF(MOD(iadvtr,istphy)==0)
-
-END SUBROUTINE phystokenc
-
-END MODULE phystokenc_mod
Index: /LMDZ6/trunk/libf/phylmd/phystokenc_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/phystokenc_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/phystokenc_mod.f90	(revision 5268)
@@ -0,0 +1,389 @@
+!
+! $Id$
+!
+MODULE phystokenc_mod
+
+  IMPLICIT NONE
+
+  LOGICAL,SAVE :: offline
+!$OMP THREADPRIVATE(offline)
+  INTEGER,SAVE :: istphy
+!$OMP THREADPRIVATE(istphy)
+
+
+CONTAINS
+
+  SUBROUTINE init_phystokenc(offline_dyn,istphy_dyn)
+    IMPLICIT NONE
+    LOGICAL,INTENT(IN) :: offline_dyn
+    INTEGER,INTENT(IN) :: istphy_dyn
+
+    offline=offline_dyn
+    istphy=istphy_dyn
+
+  END SUBROUTINE init_phystokenc
+
+SUBROUTINE phystokenc (nlon,nlev,pdtphys,rlon,rlat, &
+     pt,pmfu, pmfd, pen_u, pde_u, pen_d, pde_d, &
+     pfm_therm,pentr_therm, &
+     cdragh, pcoefh,yu1,yv1,ftsol,pctsrf, &
+     frac_impa,frac_nucl, &
+     pphis,paire,dtime,itap, &
+     psh, pda, pphi, pmp, pupwd, pdnwd)
+  
+  USE ioipsl
+  USE dimphy
+  USE infotrac_phy, ONLY : nqtot
+  USE iophy
+  USE indice_sol_mod
+  USE print_control_mod, ONLY: lunout
+  USE mod_grid_phy_lmdz, ONLY: nbp_lon, nbp_lat
+  
+  IMPLICIT NONE
+  
+!======================================================================
+! Auteur(s) FH
+! Objet: Ecriture des variables pour transport offline
+!
+!  Note (A Cozic - July 2024): when coupled with inca, offline fields are no 
+!  longer calculated in this routine but directly in the physics code.
+!======================================================================
+
+! Arguments:
+!
+  REAL,DIMENSION(klon,klev), INTENT(IN)     :: psh   ! humidite specifique
+  REAL,DIMENSION(klon,klev), INTENT(IN)     :: pda
+  REAL,DIMENSION(klon,klev,klev), INTENT(IN):: pphi
+  REAL,DIMENSION(klon,klev), INTENT(IN)     :: pmp
+  REAL,DIMENSION(klon,klev), INTENT(IN)     :: pupwd ! saturated updraft mass flux
+  REAL,DIMENSION(klon,klev), INTENT(IN)     :: pdnwd ! saturated downdraft mass flux
+
+!   EN ENTREE:
+!   ==========
+!
+!   divers:
+!   -------
+!
+  INTEGER nlon ! nombre de points horizontaux
+  INTEGER nlev ! nombre de couches verticales
+  REAL pdtphys ! pas d'integration pour la physique (seconde)
+  INTEGER itap
+  INTEGER, SAVE :: physid
+!$OMP THREADPRIVATE(physid)
+
+!   convection:
+!   -----------
+!
+  REAL pmfu(klon,klev)  ! flux de masse dans le panache montant
+  REAL pmfd(klon,klev)  ! flux de masse dans le panache descendant
+  REAL pen_u(klon,klev) ! flux entraine dans le panache montant
+  REAL pde_u(klon,klev) ! flux detraine dans le panache montant
+  REAL pen_d(klon,klev) ! flux entraine dans le panache descendant
+  REAL pde_d(klon,klev) ! flux detraine dans le panache descendant
+  REAL pt(klon,klev)
+  REAL,ALLOCATABLE,SAVE :: t(:,:)
+!$OMP THREADPRIVATE(t)
+!
+  REAL rlon(klon), rlat(klon), dtime
+  REAL zx_tmp_3d(nbp_lon,nbp_lat,klev),zx_tmp_2d(nbp_lon,nbp_lat)
+
+!   Couche limite:
+!   --------------
+!
+  REAL cdragh(klon)          ! cdrag
+  REAL pcoefh(klon,klev)     ! coeff melange CL
+  REAL pcoefh_buf(klon,klev) ! coeff melange CL + cdrag
+  REAL yv1(klon)
+  REAL yu1(klon),pphis(klon),paire(klon)
+
+!   Les Thermiques : (Abderr 25 11 02)
+!   ---------------
+  REAL, INTENT(IN) ::  pfm_therm(klon,klev+1)
+  REAL pentr_therm(klon,klev)
+  
+  REAL,ALLOCATABLE,SAVE :: entr_therm(:,:)
+  REAL,ALLOCATABLE,SAVE :: fm_therm(:,:)
+!$OMP THREADPRIVATE(entr_therm)
+!$OMP THREADPRIVATE(fm_therm)
+!
+!   Lessivage:
+!   ----------
+!
+  REAL frac_impa(klon,klev)
+  REAL frac_nucl(klon,klev)
+!
+! Arguments necessaires pour les sources et puits de traceur
+!
+  REAL ftsol(klon,nbsrf)  ! Temperature du sol (surf)(Kelvin)
+  REAL pctsrf(klon,nbsrf) ! Pourcentage de sol f(nature du sol)
+!======================================================================
+!
+  INTEGER i, k, kk
+  REAL,ALLOCATABLE,SAVE :: mfu(:,:)  ! flux de masse dans le panache montant
+  REAL,ALLOCATABLE,SAVE :: mfd(:,:)  ! flux de masse dans le panache descendant
+  REAL,ALLOCATABLE,SAVE :: en_u(:,:) ! flux entraine dans le panache montant
+  REAL,ALLOCATABLE,SAVE :: de_u(:,:) ! flux detraine dans le panache montant
+  REAL,ALLOCATABLE,SAVE :: en_d(:,:) ! flux entraine dans le panache descendant
+  REAL,ALLOCATABLE,SAVE :: de_d(:,:) ! flux detraine dans le panache descendant
+  REAL,ALLOCATABLE,SAVE :: coefh(:,:) ! flux detraine dans le panache descendant
+  
+  REAL,ALLOCATABLE,SAVE :: pyu1(:)
+  REAL,ALLOCATABLE,SAVE :: pyv1(:)
+  REAL,ALLOCATABLE,SAVE :: pftsol(:,:)
+  REAL,ALLOCATABLE,SAVE :: ppsrf(:,:)
+!$OMP THREADPRIVATE(mfu,mfd,en_u,de_u,en_d,de_d,coefh)
+!$OMP THREADPRIVATE(pyu1,pyv1,pftsol,ppsrf)
+
+
+  REAL,DIMENSION(:,:), ALLOCATABLE,SAVE     :: sh  
+  REAL,DIMENSION(:,:), ALLOCATABLE,SAVE     :: da
+  REAL,DIMENSION(:,:,:), ALLOCATABLE,SAVE   :: phi
+  REAL,DIMENSION(:,:), ALLOCATABLE,SAVE     :: mp
+  REAL,DIMENSION(:,:), ALLOCATABLE,SAVE     :: upwd
+  REAL,DIMENSION(:,:), ALLOCATABLE,SAVE     :: dnwd
+  
+  REAL, SAVE :: dtcum
+  INTEGER, SAVE:: iadvtr=0
+!$OMP THREADPRIVATE(dtcum,iadvtr)
+  REAL zmin,zmax
+  LOGICAL ok_sync
+  CHARACTER(len=12) :: nvar
+  logical, parameter :: lstokenc=.FALSE.
+!
+!======================================================================
+
+  iadvtr=iadvtr+1
+
+! Dans le meme vecteur on recombine le drag et les coeff d'echange
+  pcoefh_buf(:,1)      = cdragh(:)
+  pcoefh_buf(:,2:klev) = pcoefh(:,2:klev)
+  
+  ok_sync = .TRUE.
+
+! Initialization done only once
+!======================================================================
+  IF (iadvtr==1) THEN
+     ALLOCATE( t(klon,klev))
+     ALLOCATE( mfu(klon,klev))  
+     ALLOCATE( mfd(klon,klev))  
+     ALLOCATE( en_u(klon,klev)) 
+     ALLOCATE( de_u(klon,klev)) 
+     ALLOCATE( en_d(klon,klev)) 
+     ALLOCATE( de_d(klon,klev)) 
+     ALLOCATE( coefh(klon,klev)) 
+     ALLOCATE( entr_therm(klon,klev))
+     ALLOCATE( fm_therm(klon,klev))
+     ALLOCATE( pyu1(klon))
+     ALLOCATE( pyv1(klon))
+     ALLOCATE( pftsol(klon,nbsrf))
+     ALLOCATE( ppsrf(klon,nbsrf))
+     
+     ALLOCATE(sh(klon,klev)) 
+     ALLOCATE(da(klon,klev)) 
+     ALLOCATE(phi(klon,klev,klev)) 
+     ALLOCATE(mp(klon,klev)) 
+     ALLOCATE(upwd(klon,klev)) 
+     ALLOCATE(dnwd(klon,klev)) 
+
+     CALL initphysto('phystoke', dtime, dtime*istphy,dtime*istphy,physid)
+     
+     ! Write field phis and aire only once
+     CALL histwrite_phy(physid,lstokenc,"phis",itap,pphis)
+     CALL histwrite_phy(physid,lstokenc,"aire",itap,paire)
+     CALL histwrite_phy(physid,lstokenc,"longitudes",itap,rlon)
+     CALL histwrite_phy(physid,lstokenc,"latitudes",itap,rlat)
+
+  END IF
+  
+  
+! Set to zero cumulating fields
+!======================================================================
+  IF (MOD(iadvtr,istphy)==1.OR.istphy==1) THEN
+     WRITE(lunout,*)'reinitialisation des champs cumules a iadvtr=',iadvtr
+     mfu(:,:)=0.
+     mfd(:,:)=0.
+     en_u(:,:)=0.
+     de_u(:,:)=0.
+     en_d(:,:)=0.
+     de_d(:,:)=0.
+     coefh(:,:)=0.
+     t(:,:)=0.
+     fm_therm(:,:)=0.
+     entr_therm(:,:)=0.
+     pyv1(:)=0.
+     pyu1(:)=0.
+     pftsol(:,:)=0.
+     ppsrf(:,:)=0.
+     sh(:,:)=0.
+     da(:,:)=0.
+     phi(:,:,:)=0.
+     mp(:,:)=0.
+     upwd(:,:)=0.
+     dnwd(:,:)=0.
+     dtcum=0.
+  ENDIF
+  
+
+! Cumulate fields at each time step
+!======================================================================
+  DO k=1,klev
+     DO i=1,klon
+        mfu(i,k)=mfu(i,k)+pmfu(i,k)*pdtphys
+        mfd(i,k)=mfd(i,k)+pmfd(i,k)*pdtphys
+        en_u(i,k)=en_u(i,k)+pen_u(i,k)*pdtphys
+        de_u(i,k)=de_u(i,k)+pde_u(i,k)*pdtphys
+        en_d(i,k)=en_d(i,k)+pen_d(i,k)*pdtphys
+        de_d(i,k)=de_d(i,k)+pde_d(i,k)*pdtphys
+        coefh(i,k)=coefh(i,k)+pcoefh_buf(i,k)*pdtphys
+        t(i,k)=t(i,k)+pt(i,k)*pdtphys
+        fm_therm(i,k)=fm_therm(i,k)+pfm_therm(i,k)*pdtphys
+        entr_therm(i,k)=entr_therm(i,k)+pentr_therm(i,k)*pdtphys
+        sh(i,k) = sh(i,k) + psh(i,k)*pdtphys
+        da(i,k) = da(i,k) + pda(i,k)*pdtphys
+        mp(i,k) = mp(i,k) + pmp(i,k)*pdtphys
+        upwd(i,k) = upwd(i,k) + pupwd(i,k)*pdtphys
+        dnwd(i,k) = dnwd(i,k) + pdnwd(i,k)*pdtphys
+     ENDDO
+  ENDDO
+
+  DO kk=1,klev
+     DO k=1,klev
+        DO i=1,klon
+           phi(i,k,kk) = phi(i,k,kk) + pphi(i,k,kk)*pdtphys
+        END DO
+     END DO
+  END DO
+
+  DO i=1,klon
+     pyv1(i)=pyv1(i)+yv1(i)*pdtphys
+     pyu1(i)=pyu1(i)+yu1(i)*pdtphys
+  END DO
+  DO k=1,nbsrf
+     DO i=1,klon
+        pftsol(i,k)=pftsol(i,k)+ftsol(i,k)*pdtphys
+        ppsrf(i,k)=ppsrf(i,k)+pctsrf(i,k)*pdtphys
+     ENDDO
+  ENDDO
+  
+! Add time step to cumulated time
+  dtcum=dtcum+pdtphys
+  
+
+! Write fields to file, if it is time to do so
+!======================================================================
+  IF(MOD(iadvtr,istphy)==0) THEN 
+
+     ! normalize with time period
+     DO k=1,klev
+        DO i=1,klon
+           mfu(i,k)=mfu(i,k)/dtcum
+           mfd(i,k)=mfd(i,k)/dtcum
+           en_u(i,k)=en_u(i,k)/dtcum
+           de_u(i,k)=de_u(i,k)/dtcum
+           en_d(i,k)=en_d(i,k)/dtcum
+           de_d(i,k)=de_d(i,k)/dtcum
+           coefh(i,k)=coefh(i,k)/dtcum
+           t(i,k)=t(i,k)/dtcum	
+           fm_therm(i,k)=fm_therm(i,k)/dtcum
+           entr_therm(i,k)=entr_therm(i,k)/dtcum
+           sh(i,k)=sh(i,k)/dtcum
+           da(i,k)=da(i,k)/dtcum
+           mp(i,k)=mp(i,k)/dtcum
+           upwd(i,k)=upwd(i,k)/dtcum
+           dnwd(i,k)=dnwd(i,k)/dtcum
+        ENDDO
+     ENDDO
+     DO kk=1,klev
+        DO k=1,klev
+           DO i=1,klon
+              phi(i,k,kk) = phi(i,k,kk)/dtcum
+           END DO
+        END DO
+     END DO
+     DO i=1,klon
+        pyv1(i)=pyv1(i)/dtcum
+        pyu1(i)=pyu1(i)/dtcum
+     END DO
+     DO k=1,nbsrf
+        DO i=1,klon
+           pftsol(i,k)=pftsol(i,k)/dtcum
+           ppsrf(i,k)=ppsrf(i,k)/dtcum
+        ENDDO
+     ENDDO
+
+     ! write fields
+     CALL histwrite_phy(physid,lstokenc,"t",itap,t)
+     CALL histwrite_phy(physid,lstokenc,"mfu",itap,mfu)
+     CALL histwrite_phy(physid,lstokenc,"mfd",itap,mfd)
+     CALL histwrite_phy(physid,lstokenc,"en_u",itap,en_u)
+     CALL histwrite_phy(physid,lstokenc,"de_u",itap,de_u)
+     CALL histwrite_phy(physid,lstokenc,"en_d",itap,en_d)
+     CALL histwrite_phy(physid,lstokenc,"de_d",itap,de_d)
+     CALL histwrite_phy(physid,lstokenc,"coefh",itap,coefh)	
+     CALL histwrite_phy(physid,lstokenc,"fm_th",itap,fm_therm)
+     CALL histwrite_phy(physid,lstokenc,"en_th",itap,entr_therm)
+     CALL histwrite_phy(physid,lstokenc,"frac_impa",itap,frac_impa)
+     CALL histwrite_phy(physid,lstokenc,"frac_nucl",itap,frac_nucl)
+     CALL histwrite_phy(physid,lstokenc,"pyu1",itap,pyu1)
+     CALL histwrite_phy(physid,lstokenc,"pyv1",itap,pyv1)
+     CALL histwrite_phy(physid,lstokenc,"ftsol1",itap,pftsol(:,1))
+     CALL histwrite_phy(physid,lstokenc,"ftsol2",itap,pftsol(:,2))
+     CALL histwrite_phy(physid,lstokenc,"ftsol3",itap,pftsol(:,3))
+     CALL histwrite_phy(physid,lstokenc,"ftsol4",itap,pftsol(:,4))
+     CALL histwrite_phy(physid,lstokenc,"psrf1",itap,ppsrf(:,1))
+     CALL histwrite_phy(physid,lstokenc,"psrf2",itap,ppsrf(:,2))
+     CALL histwrite_phy(physid,lstokenc,"psrf3",itap,ppsrf(:,3))
+     CALL histwrite_phy(physid,lstokenc,"psrf4",itap,ppsrf(:,4))
+     CALL histwrite_phy(physid,lstokenc,"sh",itap,sh)
+     CALL histwrite_phy(physid,lstokenc,"da",itap,da)
+     CALL histwrite_phy(physid,lstokenc,"mp",itap,mp)
+     CALL histwrite_phy(physid,lstokenc,"upwd",itap,upwd)
+     CALL histwrite_phy(physid,lstokenc,"dnwd",itap,dnwd)
+
+
+! phi
+     DO k=1,klev
+        IF (k<10) THEN
+           WRITE(nvar,'(i1)') k
+        ELSE IF (k<100) THEN
+           WRITE(nvar,'(i2)') k
+        ELSE
+           WRITE(nvar,'(i3)') k
+        END IF
+        nvar='phi_lev'//trim(nvar)
+        
+        CALL histwrite_phy(physid,lstokenc,nvar,itap,phi(:,:,k))
+     END DO
+     
+     ! Syncronize file
+!$OMP MASTER
+     IF (ok_sync) CALL histsync(physid)
+!$OMP END MASTER
+     
+     
+     ! Calculate min and max values for some fields (coefficients de lessivage)
+     zmin=1e33
+     zmax=-1e33
+     DO k=1,klev
+        DO i=1,klon
+           zmax=MAX(zmax,frac_nucl(i,k))
+           zmin=MIN(zmin,frac_nucl(i,k))
+        ENDDO
+     ENDDO
+     WRITE(lunout,*)'------ coefs de lessivage (min et max) --------'
+     WRITE(lunout,*)'facteur de nucleation ',zmin,zmax
+     zmin=1e33
+     zmax=-1e33
+     DO k=1,klev
+        DO i=1,klon
+           zmax=MAX(zmax,frac_impa(i,k))
+           zmin=MIN(zmin,frac_impa(i,k))
+        ENDDO
+     ENDDO
+     WRITE(lunout,*)'facteur d impaction ',zmin,zmax
+     
+  ENDIF ! IF(MOD(iadvtr,istphy)==0)
+
+END SUBROUTINE phystokenc
+
+END MODULE phystokenc_mod
Index: DZ6/trunk/libf/phylmd/phytrac_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/phytrac_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,1096 +1,0 @@
-!$Id$
-MODULE phytrac_mod
-!=================================================================================
-! Interface between the LMDZ physical package and tracer computation.
-! Chemistry modules (INCA, Reprobus or the more specific traclmdz routine)
-! are called from phytrac.
-!
-!======================================================================
-! Auteur(s) FH
-! Objet: Moniteur general des tendances traceurs
-!
-! iflag_vdf_trac : Options for activating transport by vertical diffusion :
-!     1. notmal
-!     0. emission is injected in the first layer only, without diffusion
-!    -1  no emission & no diffusion
-! Modification 2013/07/22 : transformed into a module to pass tendencies to
-!     physics outputs. Additional keys for controling activation of sub processes.
-! Modification R. Pilon 10 octobre 2012 large scale scavenging incloud_scav + bc_scav
-! Modification R. Pilon 01 janvier 2012 transport+scavenging KE scheme : cvltr
-!=================================================================================
-
-!
-! Tracer tendencies, for outputs
-!-------------------------------
-  REAL,DIMENSION(:,:,:),ALLOCATABLE,SAVE :: d_tr_cl  ! Td couche limite/traceur
-  REAL,DIMENSION(:,:,:),ALLOCATABLE,SAVE :: d_tr_dec                            !RomP
-  REAL,DIMENSION(:,:,:),ALLOCATABLE,SAVE :: d_tr_cv  ! Td convection/traceur
-! RomP >>>
-  REAL,DIMENSION(:,:,:),ALLOCATABLE,SAVE :: d_tr_insc
-  REAL,DIMENSION(:,:,:),ALLOCATABLE,SAVE :: d_tr_bcscav
-  REAL,DIMENSION(:,:,:),ALLOCATABLE,SAVE :: d_tr_evapls
-  REAL,DIMENSION(:,:,:),ALLOCATABLE,SAVE :: d_tr_ls
-  REAL,DIMENSION(:,:,:),ALLOCATABLE,SAVE :: d_tr_trsp
-  REAL,DIMENSION(:,:,:),ALLOCATABLE,SAVE :: d_tr_sscav
-  REAL,DIMENSION(:,:,:),ALLOCATABLE,SAVE :: d_tr_sat
-  REAL,DIMENSION(:,:,:),ALLOCATABLE,SAVE :: d_tr_uscav
-  REAL,DIMENSION(:,:,:),ALLOCATABLE,SAVE :: qPr,qDi ! concentration tra dans pluie,air descente insaturee
-  REAL,DIMENSION(:,:,:),ALLOCATABLE,SAVE :: qPa,qMel
-  REAL,DIMENSION(:,:,:),ALLOCATABLE,SAVE :: qTrdi,dtrcvMA ! conc traceur descente air insaturee et td convective MA
-! RomP <<<
-  REAL,DIMENSION(:,:,:),ALLOCATABLE,SAVE :: d_tr_th  ! Td thermique
-  REAL,DIMENSION(:,:,:),ALLOCATABLE,SAVE :: d_tr_lessi_impa ! Td du lessivage par impaction
-  REAL,DIMENSION(:,:,:),ALLOCATABLE,SAVE :: d_tr_lessi_nucl ! Td du lessivage par nucleation
-  REAL,DIMENSION(:,:),ALLOCATABLE,SAVE   :: qPrls      !jyg: concentration tra dans pluie LS a la surf.
-  REAL,DIMENSION(:,:),ALLOCATABLE,SAVE   :: d_tr_dry ! Td depot sec/traceur (1st layer),ALLOCATABLE,SAVE  jyg
-  REAL,DIMENSION(:,:),ALLOCATABLE,SAVE   :: flux_tr_dry ! depot sec/traceur (surface),ALLOCATABLE,SAVE    jyg
-
-!$OMP THREADPRIVATE(qPa,qMel,qTrdi,dtrcvMA,d_tr_th,d_tr_lessi_impa,d_tr_lessi_nucl)
-!$OMP THREADPRIVATE(d_tr_trsp,d_tr_sscav,d_tr_sat,d_tr_uscav,qPr,qDi)
-!$OMP THREADPRIVATE(d_tr_insc,d_tr_bcscav,d_tr_evapls,d_tr_ls,qPrls)
-!$OMP THREADPRIVATE(d_tr_cl,d_tr_dry,flux_tr_dry,d_tr_dec,d_tr_cv)
-
-CONTAINS
-
-  SUBROUTINE phytrac_init()
-
-    USE dimphy
-    USE infotrac_phy, ONLY: nbtr, type_trac
-    USE tracco2i_mod, ONLY: tracco2i_init
-    
-    IMPLICIT NONE
-
-    ALLOCATE(d_tr_cl(klon,klev,nbtr),d_tr_dry(klon,nbtr))
-    ALLOCATE(flux_tr_dry(klon,nbtr),d_tr_dec(klon,klev,nbtr),d_tr_cv(klon,klev,nbtr))
-    ALLOCATE(d_tr_insc(klon,klev,nbtr),d_tr_bcscav(klon,klev,nbtr))
-    ALLOCATE(d_tr_evapls(klon,klev,nbtr),d_tr_ls(klon,klev,nbtr))
-    ALLOCATE(qPrls(klon,nbtr),d_tr_trsp(klon,klev,nbtr))
-    ALLOCATE(d_tr_sscav(klon,klev,nbtr),d_tr_sat(klon,klev,nbtr))
-    ALLOCATE(d_tr_uscav(klon,klev,nbtr),qPr(klon,klev,nbtr),qDi(klon,klev,nbtr))
-    ALLOCATE(qPa(klon,klev,nbtr),qMel(klon,klev,nbtr))
-    ALLOCATE(qTrdi(klon,klev,nbtr),dtrcvMA(klon,klev,nbtr))
-    ALLOCATE(d_tr_th(klon,klev,nbtr))
-    ALLOCATE(d_tr_lessi_impa(klon,klev,nbtr),d_tr_lessi_nucl(klon,klev,nbtr))
-
-    !===============================================================================
-    !    -- Do specific treatment according to chemestry model or local LMDZ tracers
-    !      
-    !===============================================================================
-    !   -- CO2 interactif --
-    IF (ANY(type_trac == ['co2i','inco'])) CALL tracco2i_init()
-
-       !   -- type_trac == 'co2i' ! PC 
-       !   -- CO2 interactif --
-       !   -- source is updated with FF and BB emissions 
-       !   -- and net fluxes from ocean and orchidee 
-       !   -- sign convention : positive into the atmosphere
-
-  END SUBROUTINE phytrac_init
-
-  SUBROUTINE phytrac(                                 &
-       nstep,     julien,   gmtime,   debutphy,       &
-       lafin,     pdtphys,  u, v,     t_seri,         &
-       paprs,     pplay,    pmfu,     pmfd,           &
-       pen_u,     pde_u,    pen_d,    pde_d,          &
-       cdragh,    coefh,    fm_therm, entr_therm,     &
-       yu1,       yv1,      ftsol,    pctsrf,         &
-       ustar,     u10m,      v10m,                    &
-       wstar,     ale_bl,      ale_wake,              &
-       xlat,      xlon,                               &
-       frac_impa,frac_nucl,beta_fisrt,beta_v1,        &
-       presnivs,  pphis,    pphi,     albsol,         &
-       sh,        ch, rh,   cldfra,   rneb,           &
-       diafra,    cldliq,   itop_con, ibas_con,       &
-       pmflxr,    pmflxs,   prfl,     psfl,           &
-       da,        phi,      mp,       upwd,           &
-       phi2,      d1a,      dam,      sij, wght_cvfd, &   ! RomP +RL
-       wdtrainA,  wdtrainM, sigd,     clw, elij,      &   ! RomP 
-       evap,      ep,       epmlmMm,  eplaMm,         &   ! RomP
-       dnwd,      aerosol_couple,     flxmass_w,      &
-       tau_aero,  piz_aero,  cg_aero, ccm,            &
-       rfname,                                        &
-       d_tr_dyn,                                      &   ! RomP
-       tr_seri, init_source)         
-    !
-    !======================================================================
-    ! Auteur(s) FH
-    ! Objet: Moniteur general des tendances traceurs
-    ! Modification R. Pilon 01 janvier 2012 transport+scavenging KE scheme : cvltr
-    ! Modification R. Pilon 10 octobre 2012 large scale scavenging incloud_scav + bc_scav
-    !======================================================================
-
-    USE ioipsl
-    USE phys_cal_mod, only : hour
-    USE dimphy
-    USE infotrac_phy, ONLY: nbtr, nqCO2, type_trac, conv_flg, pbl_flg
-    USE strings_mod,  ONLY: int2str
-    USE mod_grid_phy_lmdz
-    USE mod_phys_lmdz_para
-    USE iophy
-    USE traclmdz_mod
-    USE tracinca_mod
-    USE tracreprobus_mod
-    USE indice_sol_mod
-    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
-    USE print_control_mod, ONLY: lunout
-    USE aero_mod, ONLY : naero_grp
-    USE lmdz_thermcell_dq, ONLY : thermcell_dq
-
-    USE tracco2i_mod
-
-    USE traccoag_mod
-    USE phys_local_var_mod, ONLY: mdw
-    USE phys_local_var_mod, ONLY: budg_dep_dry_ocs,   budg_dep_wet_ocs
-    USE phys_local_var_mod, ONLY: budg_dep_dry_so2,   budg_dep_wet_so2
-    USE phys_local_var_mod, ONLY: budg_dep_dry_h2so4, budg_dep_wet_h2so4
-    USE phys_local_var_mod, ONLY: budg_dep_dry_part,  budg_dep_wet_part
-    USE infotrac_phy, ONLY: nbtr_sulgas, id_OCS_strat, id_SO2_strat, id_H2SO4_strat
-    USE strataer_nuc_mod, ONLY : tracstrataer_init
-    USE aerophys
-
-    USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_STRATAER
-
-    IMPLICIT NONE
-
-    INCLUDE "YOMCST.h"
-    INCLUDE "clesphys.h"
-    !==========================================================================
-    !                   -- ARGUMENT DESCRIPTION --
-    !==========================================================================
-
-    ! Input arguments
-    !----------------
-    !Configuration grille,temps:
-    INTEGER,INTENT(IN) :: nstep      ! Appel physique
-    INTEGER,INTENT(IN) :: julien     ! Jour julien
-    REAL,INTENT(IN)    :: gmtime     ! Heure courante
-    REAL,INTENT(IN)    :: pdtphys    ! Pas d'integration pour la physique (seconde)
-    LOGICAL,INTENT(IN) :: debutphy   ! le flag de l'initialisation de la physique
-    LOGICAL,INTENT(IN) :: lafin      ! le flag de la fin de la physique
-
-    REAL,DIMENSION(klon),INTENT(IN) :: xlat    ! latitudes pour chaque point 
-    REAL,DIMENSION(klon),INTENT(IN) :: xlon    ! longitudes pour chaque point 
-    !
-    !Physique: 
-    !--------
-    REAL,DIMENSION(klon,klev),INTENT(IN)   :: t_seri  ! Temperature
-    REAL,DIMENSION(klon,klev),INTENT(IN)   :: u       ! variable not used 
-    REAL,DIMENSION(klon,klev),INTENT(IN)   :: v       ! variable not used 
-    REAL,DIMENSION(klon,klev),INTENT(IN)   :: sh      ! humidite specifique
-    REAL,DIMENSION(klon,klev),INTENT(IN)   :: rh      ! humidite relative
-    REAL,DIMENSION(klon,klev),INTENT(IN)   :: ch      ! eau liquide (+ glace si le traceur existe) 
-    REAL,DIMENSION(klon,klev+1),INTENT(IN) :: paprs   ! pression pour chaque inter-couche (en Pa)
-    REAL,DIMENSION(klon,klev),INTENT(IN)   :: pplay   ! pression pour le mileu de chaque couche (en Pa)
-    REAL,DIMENSION(klon,klev),INTENT(IN)   :: pphi    ! geopotentiel
-    REAL,DIMENSION(klon),INTENT(IN)        :: pphis
-    REAL,DIMENSION(klev),INTENT(IN)        :: presnivs 
-    REAL,DIMENSION(klon,klev),INTENT(IN)   :: cldliq  ! eau condensee totale
-    REAL,DIMENSION(klon,klev),INTENT(IN)   :: cldfra  ! fraction nuageuse (tous les nuages)
-    REAL,DIMENSION(klon,klev),INTENT(IN)   :: diafra  ! fraction nuageuse (convection ou stratus artificiels)
-    REAL,DIMENSION(klon,klev),INTENT(IN)   :: rneb    ! fraction nuageuse (grande echelle)
-    !
-    REAL                                   :: ql_incl ! contenu en eau liquide nuageuse dans le nuage ! ql_incl=oliq/rneb
-    REAL,DIMENSION(klon,klev),INTENT(IN)   :: beta_fisrt ! taux de conversion de l'eau cond (de fisrtilp)
-    REAL,DIMENSION(klon,klev),INTENT(out)  :: beta_v1    ! -- (originale version)
-
-    !
-    INTEGER,DIMENSION(klon),INTENT(IN)     :: itop_con
-    INTEGER,DIMENSION(klon),INTENT(IN)     :: ibas_con
-    REAL,DIMENSION(klon),INTENT(IN)        :: albsol  ! albedo surface
-    !
-    !Dynamique
-    !--------
-    REAL,DIMENSION(klon,klev,nbtr),INTENT(IN)    :: d_tr_dyn
-    !
-    !Convection:
-    !----------
-    REAL,DIMENSION(klon,klev),INTENT(IN) :: pmfu  ! flux de masse dans le panache montant
-    REAL,DIMENSION(klon,klev),INTENT(IN) :: pmfd  ! flux de masse dans le panache descendant
-    REAL,DIMENSION(klon,klev),INTENT(IN) :: pen_u ! flux entraine dans le panache montant
-    REAL,DIMENSION(klon,klev),INTENT(IN) :: pde_u ! flux detraine dans le panache montant
-    REAL,DIMENSION(klon,klev),INTENT(IN) :: pen_d ! flux entraine dans le panache descendant
-    REAL,DIMENSION(klon,klev),INTENT(IN) :: pde_d ! flux detraine dans le panache descendant
-
-    !...Tiedke     
-    REAL,DIMENSION(klon,klev+1),INTENT(IN)   :: pmflxr, pmflxs ! Flux precipitant de pluie, neige aux interfaces [convection]
-    REAL,DIMENSION(klon,klev+1),INTENT(IN)   :: prfl, psfl ! Flux precipitant de pluie, neige aux interfaces [large-scale]
-
-    LOGICAL,INTENT(IN)                       :: aerosol_couple
-    REAL,DIMENSION(klon,klev),INTENT(IN)     :: flxmass_w
-    REAL,DIMENSION(klon,klev,naero_grp,2),INTENT(IN) :: tau_aero
-    REAL,DIMENSION(klon,klev,naero_grp,2),INTENT(IN) :: piz_aero
-    REAL,DIMENSION(klon,klev,naero_grp,2),INTENT(IN) :: cg_aero
-    CHARACTER(len=4),DIMENSION(naero_grp),INTENT(IN) :: rfname 
-    REAL,DIMENSION(klon,klev,2),INTENT(IN)   :: ccm 
-    !... K.Emanuel
-    REAL,DIMENSION(klon,klev),INTENT(IN)     :: da
-    REAL,DIMENSION(klon,klev,klev),INTENT(IN):: phi
-    ! RomP >>>
-    REAL,DIMENSION(klon,klev),INTENT(IN)      :: d1a,dam
-    REAL,DIMENSION(klon,klev,klev),INTENT(IN) :: phi2
-    !
-    REAL,DIMENSION(klon,klev),INTENT(IN)      :: wdtrainA
-    REAL,DIMENSION(klon,klev),INTENT(IN)      :: wdtrainM
-    REAL,DIMENSION(klon),INTENT(IN)           :: sigd
-    ! ---- RomP flux entraine, detraine et precipitant kerry Emanuel
-    REAL,DIMENSION(klon,klev),INTENT(IN)      :: evap
-    REAL,DIMENSION(klon,klev),INTENT(IN)      :: ep
-    REAL,DIMENSION(klon,klev,klev),INTENT(IN) :: sij
-    REAL,DIMENSION(klon,klev),INTENT(IN)      :: wght_cvfd          !RL
-    REAL,DIMENSION(klon,klev,klev),INTENT(IN) :: elij
-    REAL,DIMENSION(klon,klev,klev),INTENT(IN) :: epmlmMm
-    REAL,DIMENSION(klon,klev),INTENT(IN)      :: eplaMm
-    REAL,DIMENSION(klon,klev),INTENT(IN)      :: clw
-    ! RomP <<<
-    !
-    REAL,DIMENSION(klon,klev),INTENT(IN)     :: mp
-    REAL,DIMENSION(klon,klev),INTENT(IN)     :: upwd      ! saturated updraft mass flux
-    REAL,DIMENSION(klon,klev),INTENT(IN)     :: dnwd      ! saturated downdraft mass flux
-    !
-    !Thermiques:
-    !----------
-    REAL,DIMENSION(klon,klev+1),INTENT(IN)   :: fm_therm
-    REAL,DIMENSION(klon,klev),INTENT(INOUT)     :: entr_therm
-    !
-    !Couche limite:
-    !--------------
-    !
-    REAL,DIMENSION(:),INTENT(IN)   :: cdragh          ! (klon) coeff drag pour T et Q
-    REAL,DIMENSION(:,:),INTENT(IN) :: coefh           ! (klon,klev) coeff melange CL (m**2/s)
-    REAL,DIMENSION(:),INTENT(IN)   :: ustar,u10m,v10m ! (klon) u* & vent a 10m (m/s)
-    REAL,DIMENSION(:),INTENT(IN)   :: wstar,ale_bl,ale_wake ! (klon) w* and Avail. Lifting Ener.
-    REAL,DIMENSION(:),INTENT(IN)   :: yu1             ! (klon) vents au premier niveau
-    REAL,DIMENSION(:),INTENT(IN)   :: yv1             ! (klon) vents au premier niveau
-    !
-    !Lessivage:
-    !----------
-    !
-    REAL, DIMENSION(:), ALLOCATABLE, SAVE :: ccntrAA
-    REAL, DIMENSION(:), ALLOCATABLE, SAVE :: ccntrENV
-    REAL, DIMENSION(:), ALLOCATABLE, SAVE :: coefcoli
-    LOGICAL, DIMENSION(:), ALLOCATABLE, SAVE :: flag_cvltr
-!$OMP THREADPRIVATE(ccntrAA,ccntrENV,coefcoli,flag_cvltr)
-    REAL, DIMENSION(klon,klev) :: ccntrAA_3d
-    REAL, DIMENSION(klon,klev) :: ccntrENV_3d
-    REAL, DIMENSION(klon,klev) :: coefcoli_3d
-    !
-    ! pour le ON-LINE
-    !
-    REAL,DIMENSION(klon,klev),INTENT(IN) :: frac_impa ! fraction d'aerosols non impactes
-    REAL,DIMENSION(klon,klev),INTENT(IN) :: frac_nucl ! fraction d'aerosols non nuclees
-
-    ! Arguments necessaires pour les sources et puits de traceur:
-    REAL,DIMENSION(klon,nbsrf),INTENT(IN) :: ftsol  ! Temperature du sol (surf)(Kelvin)
-    REAL,DIMENSION(klon,nbsrf),INTENT(IN) :: pctsrf ! Pourcentage de sol (nature du sol)
-
-    REAL,DIMENSION(klon)           :: v_dep_dry !dry deposition velocity of stratospheric sulfate in m/s
-    ! Output argument
-    !----------------
-    REAL,DIMENSION(klon,klev,nbtr),INTENT(INOUT) :: tr_seri ! Concentration Traceur [U/KgA]
-    REAL,DIMENSION(klon,klev)                    :: sourceBE 
-    REAL,DIMENSION(klon,nbtr), INTENT(IN) :: init_source
-
-    !=======================================================================================
-    !                        -- LOCAL VARIABLES --
-    !=======================================================================================
-
-    INTEGER :: i, k, it
-    INTEGER :: nsplit
-
-    !Sources et Reservoirs de traceurs (ex:Radon):
-    !--------------------------------------------
-    !
-    REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: source  ! a voir lorsque le flux de surface est prescrit
-!$OMP THREADPRIVATE(source)
-
-    !
-    !Entrees/Sorties:
-    !---------------
-    INTEGER                   :: iiq, ierr
-    INTEGER                   :: nhori, nvert
-    REAL                      :: zsto, zout, zjulian
-    INTEGER,SAVE              :: nid_tra     ! pointe vers le fichier histrac.nc         
-!$OMP THREADPRIVATE(nid_tra)
-    REAL,DIMENSION(klon)      :: zx_tmp_fi2d ! variable temporaire grille physique
-    INTEGER                   :: itau_w      ! pas de temps ecriture = nstep + itau_phy
-    LOGICAL,PARAMETER         :: ok_sync=.TRUE.
-    !
-    ! Nature du traceur
-    !------------------
-    LOGICAL,DIMENSION(:),ALLOCATABLE,SAVE :: aerosol  ! aerosol(it) = true  => aerosol => lessivage
-!$OMP THREADPRIVATE(aerosol)                        ! aerosol(it) = false => gaz
-    REAL,DIMENSION(klon,klev)             :: delp     ! epaisseur de couche (Pa)
-    !
-    ! Tendances de traceurs (Td) et flux de traceurs:
-    !------------------------
-    REAL,DIMENSION(klon,klev)      :: d_tr     ! Td dans l'atmosphere
-    REAL,DIMENSION(klon,klev)      :: Mint
-    REAL,DIMENSION(klon,klev,nbtr) :: zmfd1a
-    REAL,DIMENSION(klon,klev,nbtr) :: zmfdam
-    REAL,DIMENSION(klon,klev,nbtr) :: zmfphi2
-    ! Physique
-    !---------- 
-    REAL,DIMENSION(klon,klev,nbtr) :: flestottr ! flux de lessivage dans chaque couche 
-    REAL,DIMENSION(klon,klev)      :: zmasse    ! densite atmospherique Kg/m2
-    REAL,DIMENSION(klon,klev)      :: ztra_th
-    !PhH
-    REAL,DIMENSION(klon,klev)      :: zrho
-    REAL,DIMENSION(klon,klev)      :: zdz
-    REAL                           :: evaplsc,dx,beta ! variable pour lessivage Genthon
-    REAL,DIMENSION(klon)           :: his_dh          ! ---
-    ! in-cloud scav variables
-    REAL           :: ql_incloud_ref     ! ref value of in-cloud condensed water content
-
-    !Controles:
-    !---------
-    INTEGER,SAVE :: iflag_vdf_trac,iflag_con_trac,iflag_the_trac
-    INTEGER,SAVE  :: iflag_con_trac_omp, iflag_vdf_trac_omp,iflag_the_trac_omp
-!$OMP THREADPRIVATE(iflag_vdf_trac,iflag_con_trac,iflag_the_trac)
-
-    LOGICAL,SAVE :: lessivage
-!$OMP THREADPRIVATE(lessivage)
-
-    !RomP >>>
-    INTEGER,SAVE  :: iflag_lscav_omp,iflag_lscav
-    REAL, SAVE ::   ccntrAA_in,ccntrAA_omp
-    REAL, SAVE ::   ccntrENV_in,ccntrENV_omp
-    REAL, SAVE ::   coefcoli_in,coefcoli_omp
-
-    LOGICAL,SAVE  :: convscav_omp,convscav
-!$OMP THREADPRIVATE(iflag_lscav)
-!$OMP THREADPRIVATE(ccntrAA_in,ccntrENV_in,coefcoli_in)
-!$OMP THREADPRIVATE(convscav)
-    !RomP <<<
-    !######################################################################
-    !                    -- INITIALIZATION --
-    !######################################################################
-
-    DO k=1,klev
-       DO i=1,klon
-          sourceBE(i,k)=0.
-          Mint(i,k)=0.
-          zrho(i,k)=0.
-          zdz(i,k)=0.
-       ENDDO
-    ENDDO
-
-    DO it=1, nbtr
-       DO k=1,klev
-          DO i=1,klon
-             d_tr_insc(i,k,it)=0.
-             d_tr_bcscav(i,k,it)=0.
-             d_tr_evapls(i,k,it)=0.
-             d_tr_ls(i,k,it)=0.
-             d_tr_cv(i,k,it)=0.
-             d_tr_cl(i,k,it)=0.
-             d_tr_trsp(i,k,it)=0.
-             d_tr_sscav(i,k,it)=0.
-             d_tr_sat(i,k,it)=0.
-             d_tr_uscav(i,k,it)=0.
-             d_tr_lessi_impa(i,k,it)=0.
-             d_tr_lessi_nucl(i,k,it)=0.
-             qDi(i,k,it)=0.
-             qPr(i,k,it)=0.
-             qPa(i,k,it)=0.
-             qMel(i,k,it)=0.
-             qTrdi(i,k,it)=0.
-             dtrcvMA(i,k,it)=0.
-             zmfd1a(i,k,it)=0.
-             zmfdam(i,k,it)=0.
-             zmfphi2(i,k,it)=0.
-          ENDDO
-       ENDDO
-    ENDDO
-
-    DO it=1, nbtr
-       DO i=1,klon
-          d_tr_dry(i,it)=0.
-          flux_tr_dry(i,it)=0.
-       ENDDO
-    ENDDO
-
-    DO k = 1, klev
-       DO i = 1, klon
-          delp(i,k) = paprs(i,k)-paprs(i,k+1)
-       ENDDO
-    ENDDO
-
-    IF (debutphy) THEN
-       !!jyg
-!$OMP BARRIER
-       ecrit_tra=86400. ! frequence de stokage en dur
-       ! obsolete car remplace par des ecritures dans phys_output_write
-       !RomP >>>
-       !
-       !Config Key  = convscav
-       !Config Desc = Convective scavenging switch: 0=off, 1=on.
-       !Config Def  = .FALSE.
-       !Config Help = 
-       !
-!$OMP MASTER
-       convscav_omp=.FALSE.
-       call getin('convscav', convscav_omp)
-       iflag_vdf_trac_omp=1
-       call getin('iflag_vdf_trac', iflag_vdf_trac_omp)
-       iflag_con_trac_omp=1
-       call getin('iflag_con_trac', iflag_con_trac_omp)
-       iflag_the_trac_omp=1
-       call getin('iflag_the_trac', iflag_the_trac_omp)
-!$OMP END MASTER
-!$OMP BARRIER
-       convscav=convscav_omp
-       iflag_vdf_trac=iflag_vdf_trac_omp
-       iflag_con_trac=iflag_con_trac_omp
-       iflag_the_trac=iflag_the_trac_omp
-       write(lunout,*) 'phytrac passage dans routine conv avec lessivage', convscav
-       !
-       !Config Key  = iflag_lscav
-       !Config Desc = Large scale scavenging parametrization: 0=none, 1=old(Genthon92),
-       !              2=1+PHeinrich, 3=Reddy_Boucher2004, 4=3+RPilon.
-       !Config Def  = 1
-       !Config Help = 
-       !
-!$OMP MASTER
-       iflag_lscav_omp=1
-       call getin('iflag_lscav', iflag_lscav_omp)
-       ccntrAA_omp=1
-       ccntrENV_omp=1.
-       coefcoli_omp=0.001
-       call getin('ccntrAA', ccntrAA_omp)
-       call getin('ccntrENV', ccntrENV_omp)
-       call getin('coefcoli', coefcoli_omp)
-!$OMP END MASTER
-!$OMP BARRIER
-       iflag_lscav=iflag_lscav_omp
-       ccntrAA_in=ccntrAA_omp
-       ccntrENV_in=ccntrENV_omp
-       coefcoli_in=coefcoli_omp
-       !
-       SELECT CASE(iflag_lscav)
-       CASE(0)
-          WRITE(lunout,*)  'Large scale scavenging: none'
-       CASE(1)
-          WRITE(lunout,*)  'Large scale scavenging: C. Genthon, Tellus(1992), 44B, 371-389'
-       CASE(2)
-          WRITE(lunout,*)  'Large scale scavenging: C. Genthon, modified P. Heinrich'
-       CASE(3)
-          WRITE(lunout,*)  'Large scale scavenging: M. Shekkar Reddy and O. Boucher, JGR(2004), 109, D14202'
-       CASE(4)
-          WRITE(lunout,*)  'Large scale scavenging: Reddy and Boucher, modified R. Pilon'
-       END SELECT
-       !RomP <<<
-       WRITE(*,*) 'FIRST TIME IN PHYTRAC : pdtphys(sec) = ',pdtphys,'ecrit_tra (sec) = ',ecrit_tra
-       ALLOCATE( source(klon,nbtr), stat=ierr)
-       IF (ierr /= 0) CALL abort_physic('phytrac', 'pb in allocation 1',1)
-
-       ALLOCATE( aerosol(nbtr), stat=ierr)
-       IF (ierr /= 0) CALL abort_physic('phytrac', 'pb in allocation 2',1)
-
-
-       ! Initialize module for specific tracers
-       IF (type_trac == 'inca') THEN
-          source(:,:)=init_source(:,:)
-          CALL tracinca_init(aerosol,lessivage)
-       ELSE IF (type_trac == 'repr') THEN
-          source(:,:)=0.
-       ELSE IF (type_trac == 'co2i') THEN
-          source(:,:)=0.
-          lessivage  = .FALSE.
-          aerosol(:) = .FALSE.
-          pbl_flg(:) = 1
-          iflag_the_trac= 1
-          iflag_vdf_trac= 1
-          iflag_con_trac= 1
-       ELSE IF (type_trac == 'inco') THEN
-          source(:,1:nqCO2) = 0.                          ! from CO2i ModThL
-          source(:,nqCO2+1:nbtr)=init_source(:,:)         ! from INCA ModThL
-          aerosol(1:nqCO2) = .FALSE.                      ! from CO2i ModThL
-          CALL tracinca_init(aerosol(nqCO2+1:nbtr),lessivage)     ! from INCA ModThL
-          pbl_flg(1:nqCO2) = 1                            ! From CO2i ModThL
-          iflag_the_trac = 1                              ! From CO2i
-          iflag_vdf_trac = 1                              ! From CO2i
-          iflag_con_trac = 1                              ! From CO2i
-IF (CPPKEY_STRATAER) THEN
-       ELSE IF (type_trac == 'coag') THEN
-          source(:,:)=0.
-          CALL tracstrataer_init(aerosol,lessivage)       ! init aerosols and lessivage param
-END IF
-       ELSE IF (type_trac == 'lmdz') THEN
-          CALL traclmdz_init(pctsrf,xlat,xlon,ftsol,tr_seri,t_seri,pplay,sh,pdtphys,aerosol,lessivage)
-       ENDIF
-
-       !
-       !--initialising coefficients for scavenging in the case of NP
-       !
-       ALLOCATE(flag_cvltr(nbtr))
-       IF (iflag_con.EQ.3) THEN
-          !
-          ALLOCATE(ccntrAA(nbtr))
-          ALLOCATE(ccntrENV(nbtr))
-          ALLOCATE(coefcoli(nbtr))
-          !
-          DO it=1, nbtr
-             IF (type_trac == 'repr') THEN
-                 flag_cvltr(it)=.FALSE.
-             ELSE IF (type_trac == 'inca') THEN
-!                IF ((it.EQ.id_Rn222) .OR. ((it.GE.id_SO2) .AND. (it.LE.id_NH3)) ) THEN 
-!                   !--gas-phase species
-!                   flag_cvltr(it)=.FALSE.
-!
-!                ELSEIF ( (it.GE.id_CIDUSTM) .AND. (it.LE.id_AIN) ) THEN
-!                   !--insoluble aerosol species
-!                   flag_cvltr(it)=.TRUE.
-!                   ccntrAA(it)=0.7
-!                   ccntrENV(it)=0.7
-!                   coefcoli(it)=0.001
-!                ELSEIF ( (it.EQ.id_Pb210) .OR. ((it.GE.id_CSSSM) .AND. (it.LE.id_SSN))) THEN
-!                   !--soluble aerosol species
-!                   flag_cvltr(it)=.TRUE.
-!                   ccntrAA(it)=0.9
-!                   ccntrENV(it)=0.9 
-!                   coefcoli(it)=0.001
-!                ELSE 
-!                   WRITE(lunout,*) 'pb it=', it
-!                   CALL abort_physic('phytrac','pb it scavenging',1)
-!                ENDIF
-                !--test OB 
-                !--for now we do not scavenge in cvltr
-                flag_cvltr(it)=.FALSE.
-             ELSE IF (type_trac == 'co2i') THEN
-                !--co2 tracers are not scavenged
-                flag_cvltr(it)=.FALSE.
-             ELSE IF (type_trac == 'inco') THEN     ! Add ThL
-                flag_cvltr(it)=.FALSE.
-IF (CPPKEY_STRATAER) THEN
-             ELSE IF (type_trac == 'coag') THEN
-                IF (convscav.and.aerosol(it)) THEN
-                   flag_cvltr(it)=.TRUE.
-                   ccntrAA(it) =ccntrAA_in
-                   ccntrENV(it)=ccntrENV_in
-                   coefcoli(it)=coefcoli_in
-                ELSE
-                   flag_cvltr(it)=.FALSE.
-                ENDIF
-END IF
-             ELSE IF (type_trac == 'lmdz') THEN
-                IF (convscav.and.aerosol(it)) THEN
-                   flag_cvltr(it)=.TRUE.
-                   ccntrAA(it) =ccntrAA_in    !--a modifier par JYG a lire depuis fichier 
-                   ccntrENV(it)=ccntrENV_in
-                   coefcoli(it)=coefcoli_in
-                ELSE 
-                   flag_cvltr(it)=.FALSE.
-                ENDIF
-             ENDIF
-          ENDDO
-          !
-       ELSE ! iflag_con .ne. 3 
-          flag_cvltr(:) = .FALSE. 
-       ENDIF
-       !
-       ! print out all tracer flags 
-       !
-       WRITE(lunout,*) 'print out all tracer flags'
-       WRITE(lunout,*) 'type_trac      =', type_trac
-       WRITE(lunout,*) 'config_inca    =', config_inca
-       WRITE(lunout,*) 'iflag_con_trac =', iflag_con_trac
-       WRITE(lunout,*) 'iflag_con      =', iflag_con
-       WRITE(lunout,*) 'convscav       =', convscav
-       WRITE(lunout,*) 'iflag_lscav    =', iflag_lscav
-       WRITE(lunout,*) 'aerosol        =', aerosol
-       WRITE(lunout,*) 'iflag_the_trac =', iflag_the_trac
-       WRITE(lunout,*) 'iflag_thermals =', iflag_thermals
-       WRITE(lunout,*) 'iflag_vdf_trac =', iflag_vdf_trac
-       WRITE(lunout,*) 'pbl_flg        =', pbl_flg
-       WRITE(lunout,*) 'lessivage      =', lessivage
-       write(lunout,*)  'flag_cvltr    = ', flag_cvltr
-
-       IF (lessivage .AND. ANY(type_trac == ['inca','inco'])) &
-          CALL abort_physic('phytrac', 'lessivage=T config_inca=inca impossible',1)
-       !
-    ENDIF ! of IF (debutphy)
-    !############################################ END INITIALIZATION #######
-
-    DO k=1,klev
-       DO i=1,klon
-          zmasse(i,k)=(paprs(i,k)-paprs(i,k+1))/rg
-       ENDDO
-    ENDDO
-    !
-    IF (id_be .GT. 0) THEN
-       DO k=1,klev
-          DO i=1,klon
-             sourceBE(i,k)=srcbe(i,k)       !RomP  -> pour sortie histrac
-          ENDDO
-       ENDDO
-    ENDIF
-
-    !===============================================================================
-    !    -- Do specific treatment according to chemestry model or local LMDZ tracers
-    !      
-    !===============================================================================
-    IF (type_trac == 'inca') THEN
-       !    -- CHIMIE INCA  config_inca = aero or chem --
-       ! Appel fait en fin de phytrac pour avoir les emissions modifiees par 
-       ! la couche limite et la convection avant le calcul de la chimie 
-
-    ELSE IF (type_trac == 'repr') THEN
-       !   -- CHIMIE REPROBUS --
-       CALL tracreprobus(pdtphys, gmtime, debutphy, julien, &
-            presnivs, xlat, xlon, pphis, pphi, &
-            t_seri, pplay, paprs, sh , &
-            tr_seri)
-
-    ELSE IF (type_trac == 'co2i') THEN
-       !   -- CO2 interactif --
-       !   -- source is updated with FF and BB emissions 
-       !   -- and net fluxes from ocean and orchidee 
-       !   -- sign convention : positive into the atmosphere
-
-       CALL tracco2i(pdtphys, debutphy, &
-            xlat, xlon, pphis, pphi, &
-            t_seri, pplay, paprs, tr_seri, source)
-    ELSE IF (type_trac == 'inco') THEN      ! Add ThL
-       CALL tracco2i(pdtphys, debutphy, &
-            xlat, xlon, pphis, pphi, &
-            t_seri, pplay, paprs, tr_seri, source)
-
-IF (CPPKEY_STRATAER) THEN
-    ELSE IF (type_trac == 'coag') THEN
-       !   --STRATOSPHERIC AER IN THE STRAT --
-       CALL traccoag(pdtphys, gmtime, debutphy, julien, &
-            presnivs, xlat, xlon, pphis, pphi, &
-            t_seri, pplay, paprs, sh, rh , &
-            tr_seri)
-END IF
-    ELSE IF (type_trac == 'lmdz') THEN
-       !    -- Traitement des traceurs avec traclmdz
-       CALL traclmdz(nstep, julien, gmtime, pdtphys, t_seri, paprs, pplay, &
-            cdragh,  coefh, yu1, yv1, ftsol, pctsrf, xlat, xlon,iflag_vdf_trac>=0,sh, &
-            rh, pphi, ustar, wstar, ale_bl, ale_wake,  u10m, v10m, &
-            tr_seri, source, d_tr_cl,d_tr_dec, zmasse)               !RomP
-    ENDIF
-    !======================================================================
-    !       -- Calcul de l'effet de la convection --
-    !======================================================================
-
-    IF (iflag_con_trac==1) THEN
-
-       DO it=1, nbtr
-          IF ( conv_flg(it) == 0 ) CYCLE
-          IF (iflag_con.LT.2) THEN
-             !--pas de transport convectif
-             d_tr_cv(:,:,it)=0.
-
-          ELSE IF (iflag_con.EQ.2) THEN
-             !--ancien transport convectif de Tiedtke
-
-             CALL nflxtr(pdtphys, pmfu, pmfd, pen_u, pde_u, pen_d, pde_d, &
-                  pplay, paprs, tr_seri(:,:,it), d_tr_cv(:,:,it))
-          ELSE   
-             !--nouveau transport convectif de Emanuel
-
-             IF (flag_cvltr(it)) THEN
-                !--nouveau transport convectif de Emanuel avec lessivage convectif
-                !
-                !
-                ccntrAA_3d(:,:) =ccntrAA(it)
-                ccntrENV_3d(:,:)=ccntrENV(it)
-                coefcoli_3d(:,:)=coefcoli(it)
-
-                !--beware this interface is a bit weird because it is called for each tracer 
-                !--with the full array tr_seri even if only item it is processed
-
-                CALL cvltr_scav(pdtphys, da, phi,phi2,d1a,dam, mp,ep,         &
-                     sigd,sij,wght_cvfd,clw,elij,epmlmMm,eplaMm,              &     
-                     pmflxr,pmflxs,evap,t_seri,wdtrainA,wdtrainM,             &   
-                     paprs,it,tr_seri,upwd,dnwd,itop_con,ibas_con,            &
-                     ccntrAA_3d,ccntrENV_3d,coefcoli_3d,                      &
-                     d_tr_cv,d_tr_trsp,d_tr_sscav,d_tr_sat,d_tr_uscav,qDi,qPr,&
-                     qPa,qMel,qTrdi,dtrcvMA,Mint,                             &
-                     zmfd1a,zmfphi2,zmfdam)
-
-
-             ELSE  !---flag_cvltr(it).EQ.FALSE
-                !--nouveau transport convectif de Emanuel mais pas de lessivage convectif
-
-                !--beware this interface is a bit weird because it is called for each tracer 
-                !--with the full array tr_seri even if only item it is processed
-                !
-                CALL cvltr_noscav(it,pdtphys, da, phi,mp,wght_cvfd,paprs,pplay, &  !jyg
-                     tr_seri,upwd,dnwd,d_tr_cv)                                !jyg
-
-             ENDIF
-
-          ENDIF !--iflag
-
-          !--on ajoute les tendances
-
-          DO k = 1, klev
-             DO i = 1, klon        
-                tr_seri(i,k,it) = tr_seri(i,k,it) + d_tr_cv(i,k,it)
-             ENDDO
-          ENDDO
-
-          CALL minmaxqfi(tr_seri(:,:,it),0.,1.e33,'convection it = '//TRIM(int2str(it)))
-
-       ENDDO ! nbtr
-
-IF (CPPKEY_STRATAER) THEN
-       IF (type_trac=='coag') THEN
-         ! initialize wet deposition flux of sulfur
-         budg_dep_wet_ocs(:)=0.0
-         budg_dep_wet_so2(:)=0.0
-         budg_dep_wet_h2so4(:)=0.0
-         budg_dep_wet_part(:)=0.0
-         ! compute wet deposition flux of sulfur (sum over gases and particles)
-         ! and convert to kg(S)/m2/s
-         DO i = 1, klon
-         DO k = 1, klev
-         DO it = 1, nbtr
-         !do not include SO2 because most of it comes trom the troposphere
-           IF (it==id_OCS_strat) THEN
-             budg_dep_wet_ocs(i)=budg_dep_wet_ocs(i)+d_tr_cv(i,k,it)*(mSatom/mOCSmol) &
-                            & *(paprs(i,k)-paprs(i,k+1))/RG/pdtphys
-           ELSEIF (it==id_SO2_strat) THEN
-             budg_dep_wet_so2(i)=budg_dep_wet_so2(i)+d_tr_cv(i,k,it)*(mSatom/mSO2mol) &
-                            & *(paprs(i,k)-paprs(i,k+1))/RG/pdtphys
-           ELSEIF (it==id_H2SO4_strat) THEN
-             budg_dep_wet_h2so4(i)=budg_dep_wet_h2so4(i)+d_tr_cv(i,k,it)*(mSatom/mH2SO4mol) &
-                            & *(paprs(i,k)-paprs(i,k+1))/RG/pdtphys
-           ELSEIF (it.GT.nbtr_sulgas) THEN
-             budg_dep_wet_part(i)=budg_dep_wet_part(i)+d_tr_cv(i,k,it)*(mSatom/mH2SO4mol)  &
-                            & *dens_aer_dry*4./3.*RPI*(mdw(it-nbtr_sulgas)/2.)**3 &
-                            & *(paprs(i,k)-paprs(i,k+1))/RG/pdtphys
-           ENDIF
-         ENDDO
-         ENDDO
-         ENDDO
-       ENDIF
-END IF
-
-    ENDIF ! convection
-
-    !======================================================================
-    !    -- Calcul de l'effet des thermiques --
-    !======================================================================
-
-    DO it=1,nbtr
-       DO k=1,klev
-          DO i=1,klon
-             d_tr_th(i,k,it)=0.
-             tr_seri(i,k,it)=MAX(tr_seri(i,k,it),0.)
-! the next safeguard causes some problem for stratospheric aerosol tracers (particle number)
-! and there is little justification for it so it is commented out (4 December 2017) by OB
-! if reinstated please keep the ifndef CPP_StratAer
-!#ifndef CPP_StratAer
-!             tr_seri(i,k,it)=MIN(tr_seri(i,k,it),1.e10)
-!#endif
-          ENDDO
-       ENDDO
-    ENDDO
-
-    IF (iflag_thermals.GT.0.AND.iflag_the_trac>0) THEN   
-
-       DO it=1, nbtr
-
-          CALL thermcell_dq(klon,klev,1,pdtphys,fm_therm,entr_therm, &
-               zmasse,tr_seri(1:klon,1:klev,it),        &
-               d_tr_th(1:klon,1:klev,it),ztra_th,0 )
-
-          DO k=1,klev
-             DO i=1,klon
-                d_tr_th(i,k,it)=pdtphys*d_tr_th(i,k,it)
-                tr_seri(i,k,it)=MAX(tr_seri(i,k,it)+d_tr_th(i,k,it),0.)
-             ENDDO
-          ENDDO
-
-       ENDDO ! it
-
-    ENDIF ! Thermiques
-
-    !======================================================================
-    !     -- Calcul de l'effet de la couche limite --
-    !======================================================================
-
-    IF (iflag_vdf_trac==1) THEN
-
-       !  Injection during BL mixing
-       !
-IF (CPPKEY_STRATAER) THEN
-       IF (type_trac=='coag') THEN
-
-         ! initialize dry deposition flux of sulfur
-         budg_dep_dry_ocs(:)=0.0
-         budg_dep_dry_so2(:)=0.0
-         budg_dep_dry_h2so4(:)=0.0
-         budg_dep_dry_part(:)=0.0
-
-         ! compute dry deposition velocity as function of surface type (numbers
-         ! from IPSL note 23, 2002)
-         v_dep_dry(:) =  pctsrf(:,is_ter) * 2.5e-3 &
-                     & + pctsrf(:,is_oce) * 0.5e-3 &
-                     & + pctsrf(:,is_lic) * 2.5e-3 &
-                     & + pctsrf(:,is_sic) * 2.5e-3
-
-         ! compute surface dry deposition flux
-         zrho(:,1)=pplay(:,1)/t_seri(:,1)/RD
-
-         DO it=1, nbtr
-          source(:,it) = - v_dep_dry(:) * tr_seri(:,1,it) * zrho(:,1)
-         ENDDO
-
-       ENDIF
-END IF
-
-       DO it=1, nbtr
-          !
-          IF (pbl_flg(it) /= 0) THEN
-             !
-             CALL cltrac(pdtphys, coefh,t_seri,       &
-                  tr_seri(:,:,it), source(:,it),      &
-                  paprs, pplay, delp,                 &
-                  d_tr_cl(:,:,it),d_tr_dry(:,it),flux_tr_dry(:,it))
-             !
-             tr_seri(:,:,it)=tr_seri(:,:,it)+d_tr_cl(:,:,it)
-             !
-IF (CPPKEY_STRATAER) THEN
-             IF (type_trac=='coag') THEN
-               ! compute dry deposition flux of sulfur (sum over gases and particles)
-               IF (it==id_OCS_strat) THEN
-                 budg_dep_dry_ocs(:)=budg_dep_dry_ocs(:)-source(:,it)*(mSatom/mOCSmol)
-               ELSEIF (it==id_SO2_strat) THEN
-                 budg_dep_dry_so2(:)=budg_dep_dry_so2(:)-source(:,it)*(mSatom/mSO2mol)
-               ELSEIF (it==id_H2SO4_strat) THEN
-                 budg_dep_dry_h2so4(:)=budg_dep_dry_h2so4(:)-source(:,it)*(mSatom/mH2SO4mol)
-               ELSEIF (it.GT.nbtr_sulgas) THEN
-                 budg_dep_dry_part(:)=budg_dep_dry_part(:)-source(:,it)*(mSatom/mH2SO4mol)*dens_aer_dry &
-                                & *4./3.*RPI*(mdw(it-nbtr_sulgas)/2.)**3
-               ENDIF
-             ENDIF
-END IF
-             !
-          ENDIF
-          !
-       ENDDO
-       !
-    ELSE IF (iflag_vdf_trac==0) THEN
-       !
-       !   Injection of source in the first model layer
-       !
-       DO it=1,nbtr
-          d_tr_cl(:,1,it)=source(:,it)*RG/delp(:,1)*pdtphys
-          tr_seri(:,1,it)=tr_seri(:,1,it)+d_tr_cl(:,1,it)
-       ENDDO
-       d_tr_cl(:,2:klev,1:nbtr)=0.
-       !
-    ELSE IF (iflag_vdf_trac==-1) THEN
-       !
-       ! Nothing happens
-       d_tr_cl=0.
-       !
-    ELSE
-       !
-       CALL abort_physic('iflag_vdf_trac', 'cas non prevu',1)
-       !
-    ENDIF ! couche limite
-
-    !======================================================================
-    !   Calcul de l'effet de la precipitation grande echelle
-    !   POUR INCA le lessivage est fait directement dans INCA
-    !======================================================================
-
-    IF (lessivage) THEN
-
-       ql_incloud_ref = 10.e-4
-       ql_incloud_ref =  5.e-4
-
-
-       ! calcul du contenu en eau liquide au sein du nuage
-       ql_incl = ql_incloud_ref
-       ! choix du lessivage
-       !
-       IF (iflag_lscav .EQ. 3 .OR. iflag_lscav .EQ. 4) THEN
-          ! ********  Olivier Boucher version (3) possibly with modified ql_incl (4)
-          !
-          DO it = 1, nbtr
-
-             IF (aerosol(it)) THEN
-             !  incloud scavenging and removal by large scale rain ! orig : ql_incl was replaced by 0.5e-3 kg/kg
-             ! the value 0.5e-3 kg/kg is from Giorgi and Chameides (1986), JGR
-             ! Liu (2001) proposed to use 1.5e-3 kg/kg
-
-             CALL lsc_scav(pdtphys,it,iflag_lscav,aerosol,ql_incl,prfl,psfl,rneb,beta_fisrt,  &
-                           beta_v1,pplay,paprs,t_seri,tr_seri,d_tr_insc,d_tr_bcscav,d_tr_evapls,qPrls)
-
-             !large scale scavenging tendency
-             DO k = 1, klev
-                DO i = 1, klon
-                   d_tr_ls(i,k,it)=d_tr_insc(i,k,it)+d_tr_bcscav(i,k,it)+d_tr_evapls(i,k,it)
-                   tr_seri(i,k,it)=tr_seri(i,k,it)+d_tr_ls(i,k,it)
-                ENDDO
-             ENDDO
-             CALL minmaxqfi(tr_seri(:,:,it),0.,1.e33,'lsc scav it = '//TRIM(int2str(it)))
-             ENDIF
-
-          ENDDO  !tr
-
-IF (CPPKEY_STRATAER) THEN
-         IF (type_trac=='coag') THEN
-           ! compute wet deposition flux of sulfur (sum over gases and
-           ! particles) and convert to kg(S)/m2/s
-           ! adding contribution of d_tr_ls to d_tr_cv (above)
-           DO i = 1, klon
-           DO k = 1, klev
-           DO it = 1, nbtr
-             IF (it==id_OCS_strat) THEN
-               budg_dep_wet_ocs(i)=budg_dep_wet_ocs(i)+d_tr_ls(i,k,it)*(mSatom/mOCSmol) &
-                              & *(paprs(i,k)-paprs(i,k+1))/RG/pdtphys
-             ELSEIF (it==id_SO2_strat) THEN
-               budg_dep_wet_so2(i)=budg_dep_wet_so2(i)+d_tr_ls(i,k,it)*(mSatom/mSO2mol) &
-                              & *(paprs(i,k)-paprs(i,k+1))/RG/pdtphys
-             ELSEIF (it==id_H2SO4_strat) THEN
-               budg_dep_wet_h2so4(i)=budg_dep_wet_h2so4(i)+d_tr_ls(i,k,it)*(mSatom/mH2SO4mol) &
-                              & *(paprs(i,k)-paprs(i,k+1))/RG/pdtphys
-             ELSEIF (it.GT.nbtr_sulgas) THEN
-               budg_dep_wet_part(i)=budg_dep_wet_part(i)+d_tr_ls(i,k,it)*(mSatom/mH2SO4mol)  &
-                              & *dens_aer_dry*4./3.*RPI*(mdw(it-nbtr_sulgas)/2.)**3 &
-                              & *(paprs(i,k)-paprs(i,k+1))/RG/pdtphys
-             ENDIF
-           ENDDO
-           ENDDO
-           ENDDO
-         ENDIF
-END IF
-
-       ELSE IF (iflag_lscav .EQ. 2) THEN ! frac_impa, frac_nucl
-          ! *********   modified  old version
-
-          d_tr_lessi_nucl(:,:,:) = 0. 
-          d_tr_lessi_impa(:,:,:) = 0.
-          flestottr(:,:,:) = 0. 
-          ! Tendance des aerosols nuclees et impactes 
-          DO it = 1, nbtr
-             IF (aerosol(it)) THEN
-                his_dh(:)=0.
-                DO k = 1, klev
-                   DO i = 1, klon
-                      !PhH
-                      zrho(i,k)=pplay(i,k)/t_seri(i,k)/RD
-                      zdz(i,k)=(paprs(i,k)-paprs(i,k+1))/zrho(i,k)/RG
-                      !
-                   ENDDO
-                ENDDO
-
-                DO k=klev-1, 1, -1
-                   DO i=1, klon
-                      !             d_tr_ls(i,k,it)=tr_seri(i,k,it)*(frac_impa(i,k)*frac_nucl(i,k)-1.)
-                      dx=d_tr_ls(i,k,it)
-                      his_dh(i)=his_dh(i)-dx*zrho(i,k)*zdz(i,k)/pdtphys !  kg/m2/s
-                      evaplsc = prfl(i,k) - prfl(i,k+1) + psfl(i,k) - psfl(i,k+1)
-                      ! Evaporation Partielle -> Liberation Partielle 0.5*evap
-                      IF ( evaplsc .LT.0..and.abs(prfl(i,k+1)+psfl(i,k+1)).gt.1.e-10) THEN
-                         evaplsc = (-evaplsc)/(prfl(i,k+1)+psfl(i,k+1))
-                         ! evaplsc est donc positif, his_dh(i) est positif
-                         !--------------  
-                         d_tr_evapls(i,k,it)=0.5*evaplsc*(d_tr_lessi_nucl(i,k+1,it) &
-                              +d_tr_lessi_impa(i,k+1,it))
-                         !-------------   d_tr_evapls(i,k,it)=-0.5*evaplsc*(d_tr_lsc(i,k+1,it))
-                         beta=0.5*evaplsc
-                         if ((prfl(i,k)+psfl(i,k)).lt.1.e-10) THEN
-                            beta=1.0*evaplsc
-                         endif
-                         dx=beta*his_dh(i)/zrho(i,k)/zdz(i,k)*pdtphys
-                         his_dh(i)=(1.-beta)*his_dh(i)   ! tracer from
-                         d_tr_evapls(i,k,it)=dx
-                      ENDIF
-                      d_tr_ls(i,k,it)=tr_seri(i,k,it)*(frac_impa(i,k)*frac_nucl(i,k)-1.) &
-                           +d_tr_evapls(i,k,it)
-
-                      !--------------
-                      d_tr_lessi_nucl(i,k,it) = d_tr_lessi_nucl(i,k,it) +    &
-                           ( 1 - frac_nucl(i,k) )*tr_seri(i,k,it)
-                      d_tr_lessi_impa(i,k,it) = d_tr_lessi_impa(i,k,it) +    &
-                           ( 1 - frac_impa(i,k) )*tr_seri(i,k,it)
-                      !
-                      ! Flux lessivage total 
-                      flestottr(i,k,it) = flestottr(i,k,it) -   &
-                           ( d_tr_lessi_nucl(i,k,it)   +        &
-                           d_tr_lessi_impa(i,k,it) ) *          &
-                           ( paprs(i,k)-paprs(i,k+1) ) /        &
-                           (RG * pdtphys)
-                      !! Mise a jour des traceurs due a l'impaction,nucleation 
-                      !                 tr_seri(i,k,it)=tr_seri(i,k,it)*frac_impa(i,k)*frac_nucl(i,k)
-                      !!  calcul de la tendance liee au lessivage stratiforme
-                      !                 d_tr_ls(i,k,it)=tr_seri(i,k,it)*&
-                      !                                (1.-1./(frac_impa(i,k)*frac_nucl(i,k)))
-                      !--------------
-                   ENDDO
-                ENDDO
-             ENDIF
-          ENDDO
-          ! *********   end modified old version
-
-       ELSE IF (iflag_lscav .EQ. 1) THEN ! frac_impa, frac_nucl
-          ! *********    old version
-
-          d_tr_lessi_nucl(:,:,:) = 0. 
-          d_tr_lessi_impa(:,:,:) = 0.
-          flestottr(:,:,:) = 0. 
-          !=========================
-          ! LESSIVAGE LARGE SCALE : 
-          !=========================
-
-          ! Tendance des aerosols nuclees et impactes 
-          ! -----------------------------------------
-          DO it = 1, nbtr
-             IF (aerosol(it)) THEN
-                DO k = 1, klev
-                   DO i = 1, klon
-                      d_tr_lessi_nucl(i,k,it) = d_tr_lessi_nucl(i,k,it) +    &
-                           ( 1 - frac_nucl(i,k) )*tr_seri(i,k,it)
-                      d_tr_lessi_impa(i,k,it) = d_tr_lessi_impa(i,k,it) +    &
-                           ( 1 - frac_impa(i,k) )*tr_seri(i,k,it)
-
-                      !
-                      ! Flux lessivage total 
-                      ! ------------------------------------------------------------
-                      flestottr(i,k,it) = flestottr(i,k,it) -   &
-                           ( d_tr_lessi_nucl(i,k,it)   +        &
-                           d_tr_lessi_impa(i,k,it) ) *          &
-                           ( paprs(i,k)-paprs(i,k+1) ) /        &
-                           (RG * pdtphys)
-                      !
-                      ! Mise a jour des traceurs due a l'impaction,nucleation 
-                      ! ----------------------------------------------------------------------
-                      tr_seri(i,k,it)=tr_seri(i,k,it)*frac_impa(i,k)*frac_nucl(i,k)
-                   ENDDO
-                ENDDO
-             ENDIF
-          ENDDO
-
-          ! *********   end old version
-       ENDIF  !  iflag_lscav .EQ. 1, 2, 3 or 4
-       !
-    ENDIF !  lessivage
-
-
-    !    -- CHIMIE INCA  config_inca = aero or chem --
-    IF (ANY(type_trac == ['inca','inco'])) THEN  ! ModThL
-
-       CALL tracinca(&
-            nstep,    julien,   gmtime,         lafin,     &
-            pdtphys,  t_seri,   paprs,          pplay,     &
-            pmfu,     upwd,     ftsol,  pctsrf, pphis,     &
-            pphi,     albsol,   sh,    ch,     rh,        &
-            cldfra,   rneb,     diafra,         cldliq,    &
-            itop_con, ibas_con, pmflxr,         pmflxs,    &
-            prfl,     psfl,     aerosol_couple, flxmass_w, &
-            tau_aero, piz_aero, cg_aero,        ccm,       &
-            rfname,                                        &
-            tr_seri(:,:,1+nqCO2:nbtr),  source(:,1+nqCO2:nbtr))  ! ModThL  
-    ENDIF
-
-  END SUBROUTINE phytrac
-
-END MODULE
Index: /LMDZ6/trunk/libf/phylmd/phytrac_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/phytrac_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/phytrac_mod.f90	(revision 5268)
@@ -0,0 +1,1096 @@
+!$Id$
+MODULE phytrac_mod
+!=================================================================================
+! Interface between the LMDZ physical package and tracer computation.
+! Chemistry modules (INCA, Reprobus or the more specific traclmdz routine)
+! are called from phytrac.
+!
+!======================================================================
+! Auteur(s) FH
+! Objet: Moniteur general des tendances traceurs
+!
+! iflag_vdf_trac : Options for activating transport by vertical diffusion :
+!     1. notmal
+!     0. emission is injected in the first layer only, without diffusion
+!    -1  no emission & no diffusion
+! Modification 2013/07/22 : transformed into a module to pass tendencies to
+!     physics outputs. Additional keys for controling activation of sub processes.
+! Modification R. Pilon 10 octobre 2012 large scale scavenging incloud_scav + bc_scav
+! Modification R. Pilon 01 janvier 2012 transport+scavenging KE scheme : cvltr
+!=================================================================================
+
+!
+! Tracer tendencies, for outputs
+!-------------------------------
+  REAL,DIMENSION(:,:,:),ALLOCATABLE,SAVE :: d_tr_cl  ! Td couche limite/traceur
+  REAL,DIMENSION(:,:,:),ALLOCATABLE,SAVE :: d_tr_dec                            !RomP
+  REAL,DIMENSION(:,:,:),ALLOCATABLE,SAVE :: d_tr_cv  ! Td convection/traceur
+! RomP >>>
+  REAL,DIMENSION(:,:,:),ALLOCATABLE,SAVE :: d_tr_insc
+  REAL,DIMENSION(:,:,:),ALLOCATABLE,SAVE :: d_tr_bcscav
+  REAL,DIMENSION(:,:,:),ALLOCATABLE,SAVE :: d_tr_evapls
+  REAL,DIMENSION(:,:,:),ALLOCATABLE,SAVE :: d_tr_ls
+  REAL,DIMENSION(:,:,:),ALLOCATABLE,SAVE :: d_tr_trsp
+  REAL,DIMENSION(:,:,:),ALLOCATABLE,SAVE :: d_tr_sscav
+  REAL,DIMENSION(:,:,:),ALLOCATABLE,SAVE :: d_tr_sat
+  REAL,DIMENSION(:,:,:),ALLOCATABLE,SAVE :: d_tr_uscav
+  REAL,DIMENSION(:,:,:),ALLOCATABLE,SAVE :: qPr,qDi ! concentration tra dans pluie,air descente insaturee
+  REAL,DIMENSION(:,:,:),ALLOCATABLE,SAVE :: qPa,qMel
+  REAL,DIMENSION(:,:,:),ALLOCATABLE,SAVE :: qTrdi,dtrcvMA ! conc traceur descente air insaturee et td convective MA
+! RomP <<<
+  REAL,DIMENSION(:,:,:),ALLOCATABLE,SAVE :: d_tr_th  ! Td thermique
+  REAL,DIMENSION(:,:,:),ALLOCATABLE,SAVE :: d_tr_lessi_impa ! Td du lessivage par impaction
+  REAL,DIMENSION(:,:,:),ALLOCATABLE,SAVE :: d_tr_lessi_nucl ! Td du lessivage par nucleation
+  REAL,DIMENSION(:,:),ALLOCATABLE,SAVE   :: qPrls      !jyg: concentration tra dans pluie LS a la surf.
+  REAL,DIMENSION(:,:),ALLOCATABLE,SAVE   :: d_tr_dry ! Td depot sec/traceur (1st layer),ALLOCATABLE,SAVE  jyg
+  REAL,DIMENSION(:,:),ALLOCATABLE,SAVE   :: flux_tr_dry ! depot sec/traceur (surface),ALLOCATABLE,SAVE    jyg
+
+!$OMP THREADPRIVATE(qPa,qMel,qTrdi,dtrcvMA,d_tr_th,d_tr_lessi_impa,d_tr_lessi_nucl)
+!$OMP THREADPRIVATE(d_tr_trsp,d_tr_sscav,d_tr_sat,d_tr_uscav,qPr,qDi)
+!$OMP THREADPRIVATE(d_tr_insc,d_tr_bcscav,d_tr_evapls,d_tr_ls,qPrls)
+!$OMP THREADPRIVATE(d_tr_cl,d_tr_dry,flux_tr_dry,d_tr_dec,d_tr_cv)
+
+CONTAINS
+
+  SUBROUTINE phytrac_init()
+
+    USE dimphy
+    USE infotrac_phy, ONLY: nbtr, type_trac
+    USE tracco2i_mod, ONLY: tracco2i_init
+    
+    IMPLICIT NONE
+
+    ALLOCATE(d_tr_cl(klon,klev,nbtr),d_tr_dry(klon,nbtr))
+    ALLOCATE(flux_tr_dry(klon,nbtr),d_tr_dec(klon,klev,nbtr),d_tr_cv(klon,klev,nbtr))
+    ALLOCATE(d_tr_insc(klon,klev,nbtr),d_tr_bcscav(klon,klev,nbtr))
+    ALLOCATE(d_tr_evapls(klon,klev,nbtr),d_tr_ls(klon,klev,nbtr))
+    ALLOCATE(qPrls(klon,nbtr),d_tr_trsp(klon,klev,nbtr))
+    ALLOCATE(d_tr_sscav(klon,klev,nbtr),d_tr_sat(klon,klev,nbtr))
+    ALLOCATE(d_tr_uscav(klon,klev,nbtr),qPr(klon,klev,nbtr),qDi(klon,klev,nbtr))
+    ALLOCATE(qPa(klon,klev,nbtr),qMel(klon,klev,nbtr))
+    ALLOCATE(qTrdi(klon,klev,nbtr),dtrcvMA(klon,klev,nbtr))
+    ALLOCATE(d_tr_th(klon,klev,nbtr))
+    ALLOCATE(d_tr_lessi_impa(klon,klev,nbtr),d_tr_lessi_nucl(klon,klev,nbtr))
+
+    !===============================================================================
+    !    -- Do specific treatment according to chemestry model or local LMDZ tracers
+    !      
+    !===============================================================================
+    !   -- CO2 interactif --
+    IF (ANY(type_trac == ['co2i','inco'])) CALL tracco2i_init()
+
+       !   -- type_trac == 'co2i' ! PC 
+       !   -- CO2 interactif --
+       !   -- source is updated with FF and BB emissions 
+       !   -- and net fluxes from ocean and orchidee 
+       !   -- sign convention : positive into the atmosphere
+
+  END SUBROUTINE phytrac_init
+
+  SUBROUTINE phytrac(                                 &
+       nstep,     julien,   gmtime,   debutphy,       &
+       lafin,     pdtphys,  u, v,     t_seri,         &
+       paprs,     pplay,    pmfu,     pmfd,           &
+       pen_u,     pde_u,    pen_d,    pde_d,          &
+       cdragh,    coefh,    fm_therm, entr_therm,     &
+       yu1,       yv1,      ftsol,    pctsrf,         &
+       ustar,     u10m,      v10m,                    &
+       wstar,     ale_bl,      ale_wake,              &
+       xlat,      xlon,                               &
+       frac_impa,frac_nucl,beta_fisrt,beta_v1,        &
+       presnivs,  pphis,    pphi,     albsol,         &
+       sh,        ch, rh,   cldfra,   rneb,           &
+       diafra,    cldliq,   itop_con, ibas_con,       &
+       pmflxr,    pmflxs,   prfl,     psfl,           &
+       da,        phi,      mp,       upwd,           &
+       phi2,      d1a,      dam,      sij, wght_cvfd, &   ! RomP +RL
+       wdtrainA,  wdtrainM, sigd,     clw, elij,      &   ! RomP 
+       evap,      ep,       epmlmMm,  eplaMm,         &   ! RomP
+       dnwd,      aerosol_couple,     flxmass_w,      &
+       tau_aero,  piz_aero,  cg_aero, ccm,            &
+       rfname,                                        &
+       d_tr_dyn,                                      &   ! RomP
+       tr_seri, init_source)         
+    !
+    !======================================================================
+    ! Auteur(s) FH
+    ! Objet: Moniteur general des tendances traceurs
+    ! Modification R. Pilon 01 janvier 2012 transport+scavenging KE scheme : cvltr
+    ! Modification R. Pilon 10 octobre 2012 large scale scavenging incloud_scav + bc_scav
+    !======================================================================
+
+    USE ioipsl
+    USE phys_cal_mod, only : hour
+    USE dimphy
+    USE infotrac_phy, ONLY: nbtr, nqCO2, type_trac, conv_flg, pbl_flg
+    USE strings_mod,  ONLY: int2str
+    USE mod_grid_phy_lmdz
+    USE mod_phys_lmdz_para
+    USE iophy
+    USE traclmdz_mod
+    USE tracinca_mod
+    USE tracreprobus_mod
+    USE indice_sol_mod
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    USE print_control_mod, ONLY: lunout
+    USE aero_mod, ONLY : naero_grp
+    USE lmdz_thermcell_dq, ONLY : thermcell_dq
+
+    USE tracco2i_mod
+
+    USE traccoag_mod
+    USE phys_local_var_mod, ONLY: mdw
+    USE phys_local_var_mod, ONLY: budg_dep_dry_ocs,   budg_dep_wet_ocs
+    USE phys_local_var_mod, ONLY: budg_dep_dry_so2,   budg_dep_wet_so2
+    USE phys_local_var_mod, ONLY: budg_dep_dry_h2so4, budg_dep_wet_h2so4
+    USE phys_local_var_mod, ONLY: budg_dep_dry_part,  budg_dep_wet_part
+    USE infotrac_phy, ONLY: nbtr_sulgas, id_OCS_strat, id_SO2_strat, id_H2SO4_strat
+    USE strataer_nuc_mod, ONLY : tracstrataer_init
+    USE aerophys
+
+    USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_STRATAER
+
+    IMPLICIT NONE
+
+    INCLUDE "YOMCST.h"
+    INCLUDE "clesphys.h"
+    !==========================================================================
+    !                   -- ARGUMENT DESCRIPTION --
+    !==========================================================================
+
+    ! Input arguments
+    !----------------
+    !Configuration grille,temps:
+    INTEGER,INTENT(IN) :: nstep      ! Appel physique
+    INTEGER,INTENT(IN) :: julien     ! Jour julien
+    REAL,INTENT(IN)    :: gmtime     ! Heure courante
+    REAL,INTENT(IN)    :: pdtphys    ! Pas d'integration pour la physique (seconde)
+    LOGICAL,INTENT(IN) :: debutphy   ! le flag de l'initialisation de la physique
+    LOGICAL,INTENT(IN) :: lafin      ! le flag de la fin de la physique
+
+    REAL,DIMENSION(klon),INTENT(IN) :: xlat    ! latitudes pour chaque point 
+    REAL,DIMENSION(klon),INTENT(IN) :: xlon    ! longitudes pour chaque point 
+    !
+    !Physique: 
+    !--------
+    REAL,DIMENSION(klon,klev),INTENT(IN)   :: t_seri  ! Temperature
+    REAL,DIMENSION(klon,klev),INTENT(IN)   :: u       ! variable not used 
+    REAL,DIMENSION(klon,klev),INTENT(IN)   :: v       ! variable not used 
+    REAL,DIMENSION(klon,klev),INTENT(IN)   :: sh      ! humidite specifique
+    REAL,DIMENSION(klon,klev),INTENT(IN)   :: rh      ! humidite relative
+    REAL,DIMENSION(klon,klev),INTENT(IN)   :: ch      ! eau liquide (+ glace si le traceur existe) 
+    REAL,DIMENSION(klon,klev+1),INTENT(IN) :: paprs   ! pression pour chaque inter-couche (en Pa)
+    REAL,DIMENSION(klon,klev),INTENT(IN)   :: pplay   ! pression pour le mileu de chaque couche (en Pa)
+    REAL,DIMENSION(klon,klev),INTENT(IN)   :: pphi    ! geopotentiel
+    REAL,DIMENSION(klon),INTENT(IN)        :: pphis
+    REAL,DIMENSION(klev),INTENT(IN)        :: presnivs 
+    REAL,DIMENSION(klon,klev),INTENT(IN)   :: cldliq  ! eau condensee totale
+    REAL,DIMENSION(klon,klev),INTENT(IN)   :: cldfra  ! fraction nuageuse (tous les nuages)
+    REAL,DIMENSION(klon,klev),INTENT(IN)   :: diafra  ! fraction nuageuse (convection ou stratus artificiels)
+    REAL,DIMENSION(klon,klev),INTENT(IN)   :: rneb    ! fraction nuageuse (grande echelle)
+    !
+    REAL                                   :: ql_incl ! contenu en eau liquide nuageuse dans le nuage ! ql_incl=oliq/rneb
+    REAL,DIMENSION(klon,klev),INTENT(IN)   :: beta_fisrt ! taux de conversion de l'eau cond (de fisrtilp)
+    REAL,DIMENSION(klon,klev),INTENT(out)  :: beta_v1    ! -- (originale version)
+
+    !
+    INTEGER,DIMENSION(klon),INTENT(IN)     :: itop_con
+    INTEGER,DIMENSION(klon),INTENT(IN)     :: ibas_con
+    REAL,DIMENSION(klon),INTENT(IN)        :: albsol  ! albedo surface
+    !
+    !Dynamique
+    !--------
+    REAL,DIMENSION(klon,klev,nbtr),INTENT(IN)    :: d_tr_dyn
+    !
+    !Convection:
+    !----------
+    REAL,DIMENSION(klon,klev),INTENT(IN) :: pmfu  ! flux de masse dans le panache montant
+    REAL,DIMENSION(klon,klev),INTENT(IN) :: pmfd  ! flux de masse dans le panache descendant
+    REAL,DIMENSION(klon,klev),INTENT(IN) :: pen_u ! flux entraine dans le panache montant
+    REAL,DIMENSION(klon,klev),INTENT(IN) :: pde_u ! flux detraine dans le panache montant
+    REAL,DIMENSION(klon,klev),INTENT(IN) :: pen_d ! flux entraine dans le panache descendant
+    REAL,DIMENSION(klon,klev),INTENT(IN) :: pde_d ! flux detraine dans le panache descendant
+
+    !...Tiedke     
+    REAL,DIMENSION(klon,klev+1),INTENT(IN)   :: pmflxr, pmflxs ! Flux precipitant de pluie, neige aux interfaces [convection]
+    REAL,DIMENSION(klon,klev+1),INTENT(IN)   :: prfl, psfl ! Flux precipitant de pluie, neige aux interfaces [large-scale]
+
+    LOGICAL,INTENT(IN)                       :: aerosol_couple
+    REAL,DIMENSION(klon,klev),INTENT(IN)     :: flxmass_w
+    REAL,DIMENSION(klon,klev,naero_grp,2),INTENT(IN) :: tau_aero
+    REAL,DIMENSION(klon,klev,naero_grp,2),INTENT(IN) :: piz_aero
+    REAL,DIMENSION(klon,klev,naero_grp,2),INTENT(IN) :: cg_aero
+    CHARACTER(len=4),DIMENSION(naero_grp),INTENT(IN) :: rfname 
+    REAL,DIMENSION(klon,klev,2),INTENT(IN)   :: ccm 
+    !... K.Emanuel
+    REAL,DIMENSION(klon,klev),INTENT(IN)     :: da
+    REAL,DIMENSION(klon,klev,klev),INTENT(IN):: phi
+    ! RomP >>>
+    REAL,DIMENSION(klon,klev),INTENT(IN)      :: d1a,dam
+    REAL,DIMENSION(klon,klev,klev),INTENT(IN) :: phi2
+    !
+    REAL,DIMENSION(klon,klev),INTENT(IN)      :: wdtrainA
+    REAL,DIMENSION(klon,klev),INTENT(IN)      :: wdtrainM
+    REAL,DIMENSION(klon),INTENT(IN)           :: sigd
+    ! ---- RomP flux entraine, detraine et precipitant kerry Emanuel
+    REAL,DIMENSION(klon,klev),INTENT(IN)      :: evap
+    REAL,DIMENSION(klon,klev),INTENT(IN)      :: ep
+    REAL,DIMENSION(klon,klev,klev),INTENT(IN) :: sij
+    REAL,DIMENSION(klon,klev),INTENT(IN)      :: wght_cvfd          !RL
+    REAL,DIMENSION(klon,klev,klev),INTENT(IN) :: elij
+    REAL,DIMENSION(klon,klev,klev),INTENT(IN) :: epmlmMm
+    REAL,DIMENSION(klon,klev),INTENT(IN)      :: eplaMm
+    REAL,DIMENSION(klon,klev),INTENT(IN)      :: clw
+    ! RomP <<<
+    !
+    REAL,DIMENSION(klon,klev),INTENT(IN)     :: mp
+    REAL,DIMENSION(klon,klev),INTENT(IN)     :: upwd      ! saturated updraft mass flux
+    REAL,DIMENSION(klon,klev),INTENT(IN)     :: dnwd      ! saturated downdraft mass flux
+    !
+    !Thermiques:
+    !----------
+    REAL,DIMENSION(klon,klev+1),INTENT(IN)   :: fm_therm
+    REAL,DIMENSION(klon,klev),INTENT(INOUT)     :: entr_therm
+    !
+    !Couche limite:
+    !--------------
+    !
+    REAL,DIMENSION(:),INTENT(IN)   :: cdragh          ! (klon) coeff drag pour T et Q
+    REAL,DIMENSION(:,:),INTENT(IN) :: coefh           ! (klon,klev) coeff melange CL (m**2/s)
+    REAL,DIMENSION(:),INTENT(IN)   :: ustar,u10m,v10m ! (klon) u* & vent a 10m (m/s)
+    REAL,DIMENSION(:),INTENT(IN)   :: wstar,ale_bl,ale_wake ! (klon) w* and Avail. Lifting Ener.
+    REAL,DIMENSION(:),INTENT(IN)   :: yu1             ! (klon) vents au premier niveau
+    REAL,DIMENSION(:),INTENT(IN)   :: yv1             ! (klon) vents au premier niveau
+    !
+    !Lessivage:
+    !----------
+    !
+    REAL, DIMENSION(:), ALLOCATABLE, SAVE :: ccntrAA
+    REAL, DIMENSION(:), ALLOCATABLE, SAVE :: ccntrENV
+    REAL, DIMENSION(:), ALLOCATABLE, SAVE :: coefcoli
+    LOGICAL, DIMENSION(:), ALLOCATABLE, SAVE :: flag_cvltr
+!$OMP THREADPRIVATE(ccntrAA,ccntrENV,coefcoli,flag_cvltr)
+    REAL, DIMENSION(klon,klev) :: ccntrAA_3d
+    REAL, DIMENSION(klon,klev) :: ccntrENV_3d
+    REAL, DIMENSION(klon,klev) :: coefcoli_3d
+    !
+    ! pour le ON-LINE
+    !
+    REAL,DIMENSION(klon,klev),INTENT(IN) :: frac_impa ! fraction d'aerosols non impactes
+    REAL,DIMENSION(klon,klev),INTENT(IN) :: frac_nucl ! fraction d'aerosols non nuclees
+
+    ! Arguments necessaires pour les sources et puits de traceur:
+    REAL,DIMENSION(klon,nbsrf),INTENT(IN) :: ftsol  ! Temperature du sol (surf)(Kelvin)
+    REAL,DIMENSION(klon,nbsrf),INTENT(IN) :: pctsrf ! Pourcentage de sol (nature du sol)
+
+    REAL,DIMENSION(klon)           :: v_dep_dry !dry deposition velocity of stratospheric sulfate in m/s
+    ! Output argument
+    !----------------
+    REAL,DIMENSION(klon,klev,nbtr),INTENT(INOUT) :: tr_seri ! Concentration Traceur [U/KgA]
+    REAL,DIMENSION(klon,klev)                    :: sourceBE 
+    REAL,DIMENSION(klon,nbtr), INTENT(IN) :: init_source
+
+    !=======================================================================================
+    !                        -- LOCAL VARIABLES --
+    !=======================================================================================
+
+    INTEGER :: i, k, it
+    INTEGER :: nsplit
+
+    !Sources et Reservoirs de traceurs (ex:Radon):
+    !--------------------------------------------
+    !
+    REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: source  ! a voir lorsque le flux de surface est prescrit
+!$OMP THREADPRIVATE(source)
+
+    !
+    !Entrees/Sorties:
+    !---------------
+    INTEGER                   :: iiq, ierr
+    INTEGER                   :: nhori, nvert
+    REAL                      :: zsto, zout, zjulian
+    INTEGER,SAVE              :: nid_tra     ! pointe vers le fichier histrac.nc         
+!$OMP THREADPRIVATE(nid_tra)
+    REAL,DIMENSION(klon)      :: zx_tmp_fi2d ! variable temporaire grille physique
+    INTEGER                   :: itau_w      ! pas de temps ecriture = nstep + itau_phy
+    LOGICAL,PARAMETER         :: ok_sync=.TRUE.
+    !
+    ! Nature du traceur
+    !------------------
+    LOGICAL,DIMENSION(:),ALLOCATABLE,SAVE :: aerosol  ! aerosol(it) = true  => aerosol => lessivage
+!$OMP THREADPRIVATE(aerosol)                        ! aerosol(it) = false => gaz
+    REAL,DIMENSION(klon,klev)             :: delp     ! epaisseur de couche (Pa)
+    !
+    ! Tendances de traceurs (Td) et flux de traceurs:
+    !------------------------
+    REAL,DIMENSION(klon,klev)      :: d_tr     ! Td dans l'atmosphere
+    REAL,DIMENSION(klon,klev)      :: Mint
+    REAL,DIMENSION(klon,klev,nbtr) :: zmfd1a
+    REAL,DIMENSION(klon,klev,nbtr) :: zmfdam
+    REAL,DIMENSION(klon,klev,nbtr) :: zmfphi2
+    ! Physique
+    !---------- 
+    REAL,DIMENSION(klon,klev,nbtr) :: flestottr ! flux de lessivage dans chaque couche 
+    REAL,DIMENSION(klon,klev)      :: zmasse    ! densite atmospherique Kg/m2
+    REAL,DIMENSION(klon,klev)      :: ztra_th
+    !PhH
+    REAL,DIMENSION(klon,klev)      :: zrho
+    REAL,DIMENSION(klon,klev)      :: zdz
+    REAL                           :: evaplsc,dx,beta ! variable pour lessivage Genthon
+    REAL,DIMENSION(klon)           :: his_dh          ! ---
+    ! in-cloud scav variables
+    REAL           :: ql_incloud_ref     ! ref value of in-cloud condensed water content
+
+    !Controles:
+    !---------
+    INTEGER,SAVE :: iflag_vdf_trac,iflag_con_trac,iflag_the_trac
+    INTEGER,SAVE  :: iflag_con_trac_omp, iflag_vdf_trac_omp,iflag_the_trac_omp
+!$OMP THREADPRIVATE(iflag_vdf_trac,iflag_con_trac,iflag_the_trac)
+
+    LOGICAL,SAVE :: lessivage
+!$OMP THREADPRIVATE(lessivage)
+
+    !RomP >>>
+    INTEGER,SAVE  :: iflag_lscav_omp,iflag_lscav
+    REAL, SAVE ::   ccntrAA_in,ccntrAA_omp
+    REAL, SAVE ::   ccntrENV_in,ccntrENV_omp
+    REAL, SAVE ::   coefcoli_in,coefcoli_omp
+
+    LOGICAL,SAVE  :: convscav_omp,convscav
+!$OMP THREADPRIVATE(iflag_lscav)
+!$OMP THREADPRIVATE(ccntrAA_in,ccntrENV_in,coefcoli_in)
+!$OMP THREADPRIVATE(convscav)
+    !RomP <<<
+    !######################################################################
+    !                    -- INITIALIZATION --
+    !######################################################################
+
+    DO k=1,klev
+       DO i=1,klon
+          sourceBE(i,k)=0.
+          Mint(i,k)=0.
+          zrho(i,k)=0.
+          zdz(i,k)=0.
+       ENDDO
+    ENDDO
+
+    DO it=1, nbtr
+       DO k=1,klev
+          DO i=1,klon
+             d_tr_insc(i,k,it)=0.
+             d_tr_bcscav(i,k,it)=0.
+             d_tr_evapls(i,k,it)=0.
+             d_tr_ls(i,k,it)=0.
+             d_tr_cv(i,k,it)=0.
+             d_tr_cl(i,k,it)=0.
+             d_tr_trsp(i,k,it)=0.
+             d_tr_sscav(i,k,it)=0.
+             d_tr_sat(i,k,it)=0.
+             d_tr_uscav(i,k,it)=0.
+             d_tr_lessi_impa(i,k,it)=0.
+             d_tr_lessi_nucl(i,k,it)=0.
+             qDi(i,k,it)=0.
+             qPr(i,k,it)=0.
+             qPa(i,k,it)=0.
+             qMel(i,k,it)=0.
+             qTrdi(i,k,it)=0.
+             dtrcvMA(i,k,it)=0.
+             zmfd1a(i,k,it)=0.
+             zmfdam(i,k,it)=0.
+             zmfphi2(i,k,it)=0.
+          ENDDO
+       ENDDO
+    ENDDO
+
+    DO it=1, nbtr
+       DO i=1,klon
+          d_tr_dry(i,it)=0.
+          flux_tr_dry(i,it)=0.
+       ENDDO
+    ENDDO
+
+    DO k = 1, klev
+       DO i = 1, klon
+          delp(i,k) = paprs(i,k)-paprs(i,k+1)
+       ENDDO
+    ENDDO
+
+    IF (debutphy) THEN
+       !!jyg
+!$OMP BARRIER
+       ecrit_tra=86400. ! frequence de stokage en dur
+       ! obsolete car remplace par des ecritures dans phys_output_write
+       !RomP >>>
+       !
+       !Config Key  = convscav
+       !Config Desc = Convective scavenging switch: 0=off, 1=on.
+       !Config Def  = .FALSE.
+       !Config Help = 
+       !
+!$OMP MASTER
+       convscav_omp=.FALSE.
+       call getin('convscav', convscav_omp)
+       iflag_vdf_trac_omp=1
+       call getin('iflag_vdf_trac', iflag_vdf_trac_omp)
+       iflag_con_trac_omp=1
+       call getin('iflag_con_trac', iflag_con_trac_omp)
+       iflag_the_trac_omp=1
+       call getin('iflag_the_trac', iflag_the_trac_omp)
+!$OMP END MASTER
+!$OMP BARRIER
+       convscav=convscav_omp
+       iflag_vdf_trac=iflag_vdf_trac_omp
+       iflag_con_trac=iflag_con_trac_omp
+       iflag_the_trac=iflag_the_trac_omp
+       write(lunout,*) 'phytrac passage dans routine conv avec lessivage', convscav
+       !
+       !Config Key  = iflag_lscav
+       !Config Desc = Large scale scavenging parametrization: 0=none, 1=old(Genthon92),
+       !              2=1+PHeinrich, 3=Reddy_Boucher2004, 4=3+RPilon.
+       !Config Def  = 1
+       !Config Help = 
+       !
+!$OMP MASTER
+       iflag_lscav_omp=1
+       call getin('iflag_lscav', iflag_lscav_omp)
+       ccntrAA_omp=1
+       ccntrENV_omp=1.
+       coefcoli_omp=0.001
+       call getin('ccntrAA', ccntrAA_omp)
+       call getin('ccntrENV', ccntrENV_omp)
+       call getin('coefcoli', coefcoli_omp)
+!$OMP END MASTER
+!$OMP BARRIER
+       iflag_lscav=iflag_lscav_omp
+       ccntrAA_in=ccntrAA_omp
+       ccntrENV_in=ccntrENV_omp
+       coefcoli_in=coefcoli_omp
+       !
+       SELECT CASE(iflag_lscav)
+       CASE(0)
+          WRITE(lunout,*)  'Large scale scavenging: none'
+       CASE(1)
+          WRITE(lunout,*)  'Large scale scavenging: C. Genthon, Tellus(1992), 44B, 371-389'
+       CASE(2)
+          WRITE(lunout,*)  'Large scale scavenging: C. Genthon, modified P. Heinrich'
+       CASE(3)
+          WRITE(lunout,*)  'Large scale scavenging: M. Shekkar Reddy and O. Boucher, JGR(2004), 109, D14202'
+       CASE(4)
+          WRITE(lunout,*)  'Large scale scavenging: Reddy and Boucher, modified R. Pilon'
+       END SELECT
+       !RomP <<<
+       WRITE(*,*) 'FIRST TIME IN PHYTRAC : pdtphys(sec) = ',pdtphys,'ecrit_tra (sec) = ',ecrit_tra
+       ALLOCATE( source(klon,nbtr), stat=ierr)
+       IF (ierr /= 0) CALL abort_physic('phytrac', 'pb in allocation 1',1)
+
+       ALLOCATE( aerosol(nbtr), stat=ierr)
+       IF (ierr /= 0) CALL abort_physic('phytrac', 'pb in allocation 2',1)
+
+
+       ! Initialize module for specific tracers
+       IF (type_trac == 'inca') THEN
+          source(:,:)=init_source(:,:)
+          CALL tracinca_init(aerosol,lessivage)
+       ELSE IF (type_trac == 'repr') THEN
+          source(:,:)=0.
+       ELSE IF (type_trac == 'co2i') THEN
+          source(:,:)=0.
+          lessivage  = .FALSE.
+          aerosol(:) = .FALSE.
+          pbl_flg(:) = 1
+          iflag_the_trac= 1
+          iflag_vdf_trac= 1
+          iflag_con_trac= 1
+       ELSE IF (type_trac == 'inco') THEN
+          source(:,1:nqCO2) = 0.                          ! from CO2i ModThL
+          source(:,nqCO2+1:nbtr)=init_source(:,:)         ! from INCA ModThL
+          aerosol(1:nqCO2) = .FALSE.                      ! from CO2i ModThL
+          CALL tracinca_init(aerosol(nqCO2+1:nbtr),lessivage)     ! from INCA ModThL
+          pbl_flg(1:nqCO2) = 1                            ! From CO2i ModThL
+          iflag_the_trac = 1                              ! From CO2i
+          iflag_vdf_trac = 1                              ! From CO2i
+          iflag_con_trac = 1                              ! From CO2i
+IF (CPPKEY_STRATAER) THEN
+       ELSE IF (type_trac == 'coag') THEN
+          source(:,:)=0.
+          CALL tracstrataer_init(aerosol,lessivage)       ! init aerosols and lessivage param
+END IF
+       ELSE IF (type_trac == 'lmdz') THEN
+          CALL traclmdz_init(pctsrf,xlat,xlon,ftsol,tr_seri,t_seri,pplay,sh,pdtphys,aerosol,lessivage)
+       ENDIF
+
+       !
+       !--initialising coefficients for scavenging in the case of NP
+       !
+       ALLOCATE(flag_cvltr(nbtr))
+       IF (iflag_con.EQ.3) THEN
+          !
+          ALLOCATE(ccntrAA(nbtr))
+          ALLOCATE(ccntrENV(nbtr))
+          ALLOCATE(coefcoli(nbtr))
+          !
+          DO it=1, nbtr
+             IF (type_trac == 'repr') THEN
+                 flag_cvltr(it)=.FALSE.
+             ELSE IF (type_trac == 'inca') THEN
+!                IF ((it.EQ.id_Rn222) .OR. ((it.GE.id_SO2) .AND. (it.LE.id_NH3)) ) THEN 
+!                   !--gas-phase species
+!                   flag_cvltr(it)=.FALSE.
+!
+!                ELSEIF ( (it.GE.id_CIDUSTM) .AND. (it.LE.id_AIN) ) THEN
+!                   !--insoluble aerosol species
+!                   flag_cvltr(it)=.TRUE.
+!                   ccntrAA(it)=0.7
+!                   ccntrENV(it)=0.7
+!                   coefcoli(it)=0.001
+!                ELSEIF ( (it.EQ.id_Pb210) .OR. ((it.GE.id_CSSSM) .AND. (it.LE.id_SSN))) THEN
+!                   !--soluble aerosol species
+!                   flag_cvltr(it)=.TRUE.
+!                   ccntrAA(it)=0.9
+!                   ccntrENV(it)=0.9 
+!                   coefcoli(it)=0.001
+!                ELSE 
+!                   WRITE(lunout,*) 'pb it=', it
+!                   CALL abort_physic('phytrac','pb it scavenging',1)
+!                ENDIF
+                !--test OB 
+                !--for now we do not scavenge in cvltr
+                flag_cvltr(it)=.FALSE.
+             ELSE IF (type_trac == 'co2i') THEN
+                !--co2 tracers are not scavenged
+                flag_cvltr(it)=.FALSE.
+             ELSE IF (type_trac == 'inco') THEN     ! Add ThL
+                flag_cvltr(it)=.FALSE.
+IF (CPPKEY_STRATAER) THEN
+             ELSE IF (type_trac == 'coag') THEN
+                IF (convscav.and.aerosol(it)) THEN
+                   flag_cvltr(it)=.TRUE.
+                   ccntrAA(it) =ccntrAA_in
+                   ccntrENV(it)=ccntrENV_in
+                   coefcoli(it)=coefcoli_in
+                ELSE
+                   flag_cvltr(it)=.FALSE.
+                ENDIF
+END IF
+             ELSE IF (type_trac == 'lmdz') THEN
+                IF (convscav.and.aerosol(it)) THEN
+                   flag_cvltr(it)=.TRUE.
+                   ccntrAA(it) =ccntrAA_in    !--a modifier par JYG a lire depuis fichier 
+                   ccntrENV(it)=ccntrENV_in
+                   coefcoli(it)=coefcoli_in
+                ELSE 
+                   flag_cvltr(it)=.FALSE.
+                ENDIF
+             ENDIF
+          ENDDO
+          !
+       ELSE ! iflag_con .ne. 3 
+          flag_cvltr(:) = .FALSE. 
+       ENDIF
+       !
+       ! print out all tracer flags 
+       !
+       WRITE(lunout,*) 'print out all tracer flags'
+       WRITE(lunout,*) 'type_trac      =', type_trac
+       WRITE(lunout,*) 'config_inca    =', config_inca
+       WRITE(lunout,*) 'iflag_con_trac =', iflag_con_trac
+       WRITE(lunout,*) 'iflag_con      =', iflag_con
+       WRITE(lunout,*) 'convscav       =', convscav
+       WRITE(lunout,*) 'iflag_lscav    =', iflag_lscav
+       WRITE(lunout,*) 'aerosol        =', aerosol
+       WRITE(lunout,*) 'iflag_the_trac =', iflag_the_trac
+       WRITE(lunout,*) 'iflag_thermals =', iflag_thermals
+       WRITE(lunout,*) 'iflag_vdf_trac =', iflag_vdf_trac
+       WRITE(lunout,*) 'pbl_flg        =', pbl_flg
+       WRITE(lunout,*) 'lessivage      =', lessivage
+       write(lunout,*)  'flag_cvltr    = ', flag_cvltr
+
+       IF (lessivage .AND. ANY(type_trac == ['inca','inco'])) &
+          CALL abort_physic('phytrac', 'lessivage=T config_inca=inca impossible',1)
+       !
+    ENDIF ! of IF (debutphy)
+    !############################################ END INITIALIZATION #######
+
+    DO k=1,klev
+       DO i=1,klon
+          zmasse(i,k)=(paprs(i,k)-paprs(i,k+1))/rg
+       ENDDO
+    ENDDO
+    !
+    IF (id_be .GT. 0) THEN
+       DO k=1,klev
+          DO i=1,klon
+             sourceBE(i,k)=srcbe(i,k)       !RomP  -> pour sortie histrac
+          ENDDO
+       ENDDO
+    ENDIF
+
+    !===============================================================================
+    !    -- Do specific treatment according to chemestry model or local LMDZ tracers
+    !      
+    !===============================================================================
+    IF (type_trac == 'inca') THEN
+       !    -- CHIMIE INCA  config_inca = aero or chem --
+       ! Appel fait en fin de phytrac pour avoir les emissions modifiees par 
+       ! la couche limite et la convection avant le calcul de la chimie 
+
+    ELSE IF (type_trac == 'repr') THEN
+       !   -- CHIMIE REPROBUS --
+       CALL tracreprobus(pdtphys, gmtime, debutphy, julien, &
+            presnivs, xlat, xlon, pphis, pphi, &
+            t_seri, pplay, paprs, sh , &
+            tr_seri)
+
+    ELSE IF (type_trac == 'co2i') THEN
+       !   -- CO2 interactif --
+       !   -- source is updated with FF and BB emissions 
+       !   -- and net fluxes from ocean and orchidee 
+       !   -- sign convention : positive into the atmosphere
+
+       CALL tracco2i(pdtphys, debutphy, &
+            xlat, xlon, pphis, pphi, &
+            t_seri, pplay, paprs, tr_seri, source)
+    ELSE IF (type_trac == 'inco') THEN      ! Add ThL
+       CALL tracco2i(pdtphys, debutphy, &
+            xlat, xlon, pphis, pphi, &
+            t_seri, pplay, paprs, tr_seri, source)
+
+IF (CPPKEY_STRATAER) THEN
+    ELSE IF (type_trac == 'coag') THEN
+       !   --STRATOSPHERIC AER IN THE STRAT --
+       CALL traccoag(pdtphys, gmtime, debutphy, julien, &
+            presnivs, xlat, xlon, pphis, pphi, &
+            t_seri, pplay, paprs, sh, rh , &
+            tr_seri)
+END IF
+    ELSE IF (type_trac == 'lmdz') THEN
+       !    -- Traitement des traceurs avec traclmdz
+       CALL traclmdz(nstep, julien, gmtime, pdtphys, t_seri, paprs, pplay, &
+            cdragh,  coefh, yu1, yv1, ftsol, pctsrf, xlat, xlon,iflag_vdf_trac>=0,sh, &
+            rh, pphi, ustar, wstar, ale_bl, ale_wake,  u10m, v10m, &
+            tr_seri, source, d_tr_cl,d_tr_dec, zmasse)               !RomP
+    ENDIF
+    !======================================================================
+    !       -- Calcul de l'effet de la convection --
+    !======================================================================
+
+    IF (iflag_con_trac==1) THEN
+
+       DO it=1, nbtr
+          IF ( conv_flg(it) == 0 ) CYCLE
+          IF (iflag_con.LT.2) THEN
+             !--pas de transport convectif
+             d_tr_cv(:,:,it)=0.
+
+          ELSE IF (iflag_con.EQ.2) THEN
+             !--ancien transport convectif de Tiedtke
+
+             CALL nflxtr(pdtphys, pmfu, pmfd, pen_u, pde_u, pen_d, pde_d, &
+                  pplay, paprs, tr_seri(:,:,it), d_tr_cv(:,:,it))
+          ELSE   
+             !--nouveau transport convectif de Emanuel
+
+             IF (flag_cvltr(it)) THEN
+                !--nouveau transport convectif de Emanuel avec lessivage convectif
+                !
+                !
+                ccntrAA_3d(:,:) =ccntrAA(it)
+                ccntrENV_3d(:,:)=ccntrENV(it)
+                coefcoli_3d(:,:)=coefcoli(it)
+
+                !--beware this interface is a bit weird because it is called for each tracer 
+                !--with the full array tr_seri even if only item it is processed
+
+                CALL cvltr_scav(pdtphys, da, phi,phi2,d1a,dam, mp,ep,         &
+                     sigd,sij,wght_cvfd,clw,elij,epmlmMm,eplaMm,              &     
+                     pmflxr,pmflxs,evap,t_seri,wdtrainA,wdtrainM,             &   
+                     paprs,it,tr_seri,upwd,dnwd,itop_con,ibas_con,            &
+                     ccntrAA_3d,ccntrENV_3d,coefcoli_3d,                      &
+                     d_tr_cv,d_tr_trsp,d_tr_sscav,d_tr_sat,d_tr_uscav,qDi,qPr,&
+                     qPa,qMel,qTrdi,dtrcvMA,Mint,                             &
+                     zmfd1a,zmfphi2,zmfdam)
+
+
+             ELSE  !---flag_cvltr(it).EQ.FALSE
+                !--nouveau transport convectif de Emanuel mais pas de lessivage convectif
+
+                !--beware this interface is a bit weird because it is called for each tracer 
+                !--with the full array tr_seri even if only item it is processed
+                !
+                CALL cvltr_noscav(it,pdtphys, da, phi,mp,wght_cvfd,paprs,pplay, &  !jyg
+                     tr_seri,upwd,dnwd,d_tr_cv)                                !jyg
+
+             ENDIF
+
+          ENDIF !--iflag
+
+          !--on ajoute les tendances
+
+          DO k = 1, klev
+             DO i = 1, klon        
+                tr_seri(i,k,it) = tr_seri(i,k,it) + d_tr_cv(i,k,it)
+             ENDDO
+          ENDDO
+
+          CALL minmaxqfi(tr_seri(:,:,it),0.,1.e33,'convection it = '//TRIM(int2str(it)))
+
+       ENDDO ! nbtr
+
+IF (CPPKEY_STRATAER) THEN
+       IF (type_trac=='coag') THEN
+         ! initialize wet deposition flux of sulfur
+         budg_dep_wet_ocs(:)=0.0
+         budg_dep_wet_so2(:)=0.0
+         budg_dep_wet_h2so4(:)=0.0
+         budg_dep_wet_part(:)=0.0
+         ! compute wet deposition flux of sulfur (sum over gases and particles)
+         ! and convert to kg(S)/m2/s
+         DO i = 1, klon
+         DO k = 1, klev
+         DO it = 1, nbtr
+         !do not include SO2 because most of it comes trom the troposphere
+           IF (it==id_OCS_strat) THEN
+             budg_dep_wet_ocs(i)=budg_dep_wet_ocs(i)+d_tr_cv(i,k,it)*(mSatom/mOCSmol) &
+                            & *(paprs(i,k)-paprs(i,k+1))/RG/pdtphys
+           ELSEIF (it==id_SO2_strat) THEN
+             budg_dep_wet_so2(i)=budg_dep_wet_so2(i)+d_tr_cv(i,k,it)*(mSatom/mSO2mol) &
+                            & *(paprs(i,k)-paprs(i,k+1))/RG/pdtphys
+           ELSEIF (it==id_H2SO4_strat) THEN
+             budg_dep_wet_h2so4(i)=budg_dep_wet_h2so4(i)+d_tr_cv(i,k,it)*(mSatom/mH2SO4mol) &
+                            & *(paprs(i,k)-paprs(i,k+1))/RG/pdtphys
+           ELSEIF (it.GT.nbtr_sulgas) THEN
+             budg_dep_wet_part(i)=budg_dep_wet_part(i)+d_tr_cv(i,k,it)*(mSatom/mH2SO4mol)  &
+                            & *dens_aer_dry*4./3.*RPI*(mdw(it-nbtr_sulgas)/2.)**3 &
+                            & *(paprs(i,k)-paprs(i,k+1))/RG/pdtphys
+           ENDIF
+         ENDDO
+         ENDDO
+         ENDDO
+       ENDIF
+END IF
+
+    ENDIF ! convection
+
+    !======================================================================
+    !    -- Calcul de l'effet des thermiques --
+    !======================================================================
+
+    DO it=1,nbtr
+       DO k=1,klev
+          DO i=1,klon
+             d_tr_th(i,k,it)=0.
+             tr_seri(i,k,it)=MAX(tr_seri(i,k,it),0.)
+! the next safeguard causes some problem for stratospheric aerosol tracers (particle number)
+! and there is little justification for it so it is commented out (4 December 2017) by OB
+! if reinstated please keep the ifndef CPP_StratAer
+!#ifndef CPP_StratAer
+!             tr_seri(i,k,it)=MIN(tr_seri(i,k,it),1.e10)
+!#endif
+          ENDDO
+       ENDDO
+    ENDDO
+
+    IF (iflag_thermals.GT.0.AND.iflag_the_trac>0) THEN   
+
+       DO it=1, nbtr
+
+          CALL thermcell_dq(klon,klev,1,pdtphys,fm_therm,entr_therm, &
+               zmasse,tr_seri(1:klon,1:klev,it),        &
+               d_tr_th(1:klon,1:klev,it),ztra_th,0 )
+
+          DO k=1,klev
+             DO i=1,klon
+                d_tr_th(i,k,it)=pdtphys*d_tr_th(i,k,it)
+                tr_seri(i,k,it)=MAX(tr_seri(i,k,it)+d_tr_th(i,k,it),0.)
+             ENDDO
+          ENDDO
+
+       ENDDO ! it
+
+    ENDIF ! Thermiques
+
+    !======================================================================
+    !     -- Calcul de l'effet de la couche limite --
+    !======================================================================
+
+    IF (iflag_vdf_trac==1) THEN
+
+       !  Injection during BL mixing
+       !
+IF (CPPKEY_STRATAER) THEN
+       IF (type_trac=='coag') THEN
+
+         ! initialize dry deposition flux of sulfur
+         budg_dep_dry_ocs(:)=0.0
+         budg_dep_dry_so2(:)=0.0
+         budg_dep_dry_h2so4(:)=0.0
+         budg_dep_dry_part(:)=0.0
+
+         ! compute dry deposition velocity as function of surface type (numbers
+         ! from IPSL note 23, 2002)
+         v_dep_dry(:) =  pctsrf(:,is_ter) * 2.5e-3 &
+                     & + pctsrf(:,is_oce) * 0.5e-3 &
+                     & + pctsrf(:,is_lic) * 2.5e-3 &
+                     & + pctsrf(:,is_sic) * 2.5e-3
+
+         ! compute surface dry deposition flux
+         zrho(:,1)=pplay(:,1)/t_seri(:,1)/RD
+
+         DO it=1, nbtr
+          source(:,it) = - v_dep_dry(:) * tr_seri(:,1,it) * zrho(:,1)
+         ENDDO
+
+       ENDIF
+END IF
+
+       DO it=1, nbtr
+          !
+          IF (pbl_flg(it) /= 0) THEN
+             !
+             CALL cltrac(pdtphys, coefh,t_seri,       &
+                  tr_seri(:,:,it), source(:,it),      &
+                  paprs, pplay, delp,                 &
+                  d_tr_cl(:,:,it),d_tr_dry(:,it),flux_tr_dry(:,it))
+             !
+             tr_seri(:,:,it)=tr_seri(:,:,it)+d_tr_cl(:,:,it)
+             !
+IF (CPPKEY_STRATAER) THEN
+             IF (type_trac=='coag') THEN
+               ! compute dry deposition flux of sulfur (sum over gases and particles)
+               IF (it==id_OCS_strat) THEN
+                 budg_dep_dry_ocs(:)=budg_dep_dry_ocs(:)-source(:,it)*(mSatom/mOCSmol)
+               ELSEIF (it==id_SO2_strat) THEN
+                 budg_dep_dry_so2(:)=budg_dep_dry_so2(:)-source(:,it)*(mSatom/mSO2mol)
+               ELSEIF (it==id_H2SO4_strat) THEN
+                 budg_dep_dry_h2so4(:)=budg_dep_dry_h2so4(:)-source(:,it)*(mSatom/mH2SO4mol)
+               ELSEIF (it.GT.nbtr_sulgas) THEN
+                 budg_dep_dry_part(:)=budg_dep_dry_part(:)-source(:,it)*(mSatom/mH2SO4mol)*dens_aer_dry &
+                                & *4./3.*RPI*(mdw(it-nbtr_sulgas)/2.)**3
+               ENDIF
+             ENDIF
+END IF
+             !
+          ENDIF
+          !
+       ENDDO
+       !
+    ELSE IF (iflag_vdf_trac==0) THEN
+       !
+       !   Injection of source in the first model layer
+       !
+       DO it=1,nbtr
+          d_tr_cl(:,1,it)=source(:,it)*RG/delp(:,1)*pdtphys
+          tr_seri(:,1,it)=tr_seri(:,1,it)+d_tr_cl(:,1,it)
+       ENDDO
+       d_tr_cl(:,2:klev,1:nbtr)=0.
+       !
+    ELSE IF (iflag_vdf_trac==-1) THEN
+       !
+       ! Nothing happens
+       d_tr_cl=0.
+       !
+    ELSE
+       !
+       CALL abort_physic('iflag_vdf_trac', 'cas non prevu',1)
+       !
+    ENDIF ! couche limite
+
+    !======================================================================
+    !   Calcul de l'effet de la precipitation grande echelle
+    !   POUR INCA le lessivage est fait directement dans INCA
+    !======================================================================
+
+    IF (lessivage) THEN
+
+       ql_incloud_ref = 10.e-4
+       ql_incloud_ref =  5.e-4
+
+
+       ! calcul du contenu en eau liquide au sein du nuage
+       ql_incl = ql_incloud_ref
+       ! choix du lessivage
+       !
+       IF (iflag_lscav .EQ. 3 .OR. iflag_lscav .EQ. 4) THEN
+          ! ********  Olivier Boucher version (3) possibly with modified ql_incl (4)
+          !
+          DO it = 1, nbtr
+
+             IF (aerosol(it)) THEN
+             !  incloud scavenging and removal by large scale rain ! orig : ql_incl was replaced by 0.5e-3 kg/kg
+             ! the value 0.5e-3 kg/kg is from Giorgi and Chameides (1986), JGR
+             ! Liu (2001) proposed to use 1.5e-3 kg/kg
+
+             CALL lsc_scav(pdtphys,it,iflag_lscav,aerosol,ql_incl,prfl,psfl,rneb,beta_fisrt,  &
+                           beta_v1,pplay,paprs,t_seri,tr_seri,d_tr_insc,d_tr_bcscav,d_tr_evapls,qPrls)
+
+             !large scale scavenging tendency
+             DO k = 1, klev
+                DO i = 1, klon
+                   d_tr_ls(i,k,it)=d_tr_insc(i,k,it)+d_tr_bcscav(i,k,it)+d_tr_evapls(i,k,it)
+                   tr_seri(i,k,it)=tr_seri(i,k,it)+d_tr_ls(i,k,it)
+                ENDDO
+             ENDDO
+             CALL minmaxqfi(tr_seri(:,:,it),0.,1.e33,'lsc scav it = '//TRIM(int2str(it)))
+             ENDIF
+
+          ENDDO  !tr
+
+IF (CPPKEY_STRATAER) THEN
+         IF (type_trac=='coag') THEN
+           ! compute wet deposition flux of sulfur (sum over gases and
+           ! particles) and convert to kg(S)/m2/s
+           ! adding contribution of d_tr_ls to d_tr_cv (above)
+           DO i = 1, klon
+           DO k = 1, klev
+           DO it = 1, nbtr
+             IF (it==id_OCS_strat) THEN
+               budg_dep_wet_ocs(i)=budg_dep_wet_ocs(i)+d_tr_ls(i,k,it)*(mSatom/mOCSmol) &
+                              & *(paprs(i,k)-paprs(i,k+1))/RG/pdtphys
+             ELSEIF (it==id_SO2_strat) THEN
+               budg_dep_wet_so2(i)=budg_dep_wet_so2(i)+d_tr_ls(i,k,it)*(mSatom/mSO2mol) &
+                              & *(paprs(i,k)-paprs(i,k+1))/RG/pdtphys
+             ELSEIF (it==id_H2SO4_strat) THEN
+               budg_dep_wet_h2so4(i)=budg_dep_wet_h2so4(i)+d_tr_ls(i,k,it)*(mSatom/mH2SO4mol) &
+                              & *(paprs(i,k)-paprs(i,k+1))/RG/pdtphys
+             ELSEIF (it.GT.nbtr_sulgas) THEN
+               budg_dep_wet_part(i)=budg_dep_wet_part(i)+d_tr_ls(i,k,it)*(mSatom/mH2SO4mol)  &
+                              & *dens_aer_dry*4./3.*RPI*(mdw(it-nbtr_sulgas)/2.)**3 &
+                              & *(paprs(i,k)-paprs(i,k+1))/RG/pdtphys
+             ENDIF
+           ENDDO
+           ENDDO
+           ENDDO
+         ENDIF
+END IF
+
+       ELSE IF (iflag_lscav .EQ. 2) THEN ! frac_impa, frac_nucl
+          ! *********   modified  old version
+
+          d_tr_lessi_nucl(:,:,:) = 0. 
+          d_tr_lessi_impa(:,:,:) = 0.
+          flestottr(:,:,:) = 0. 
+          ! Tendance des aerosols nuclees et impactes 
+          DO it = 1, nbtr
+             IF (aerosol(it)) THEN
+                his_dh(:)=0.
+                DO k = 1, klev
+                   DO i = 1, klon
+                      !PhH
+                      zrho(i,k)=pplay(i,k)/t_seri(i,k)/RD
+                      zdz(i,k)=(paprs(i,k)-paprs(i,k+1))/zrho(i,k)/RG
+                      !
+                   ENDDO
+                ENDDO
+
+                DO k=klev-1, 1, -1
+                   DO i=1, klon
+                      !             d_tr_ls(i,k,it)=tr_seri(i,k,it)*(frac_impa(i,k)*frac_nucl(i,k)-1.)
+                      dx=d_tr_ls(i,k,it)
+                      his_dh(i)=his_dh(i)-dx*zrho(i,k)*zdz(i,k)/pdtphys !  kg/m2/s
+                      evaplsc = prfl(i,k) - prfl(i,k+1) + psfl(i,k) - psfl(i,k+1)
+                      ! Evaporation Partielle -> Liberation Partielle 0.5*evap
+                      IF ( evaplsc .LT.0..and.abs(prfl(i,k+1)+psfl(i,k+1)).gt.1.e-10) THEN
+                         evaplsc = (-evaplsc)/(prfl(i,k+1)+psfl(i,k+1))
+                         ! evaplsc est donc positif, his_dh(i) est positif
+                         !--------------  
+                         d_tr_evapls(i,k,it)=0.5*evaplsc*(d_tr_lessi_nucl(i,k+1,it) &
+                              +d_tr_lessi_impa(i,k+1,it))
+                         !-------------   d_tr_evapls(i,k,it)=-0.5*evaplsc*(d_tr_lsc(i,k+1,it))
+                         beta=0.5*evaplsc
+                         if ((prfl(i,k)+psfl(i,k)).lt.1.e-10) THEN
+                            beta=1.0*evaplsc
+                         endif
+                         dx=beta*his_dh(i)/zrho(i,k)/zdz(i,k)*pdtphys
+                         his_dh(i)=(1.-beta)*his_dh(i)   ! tracer from
+                         d_tr_evapls(i,k,it)=dx
+                      ENDIF
+                      d_tr_ls(i,k,it)=tr_seri(i,k,it)*(frac_impa(i,k)*frac_nucl(i,k)-1.) &
+                           +d_tr_evapls(i,k,it)
+
+                      !--------------
+                      d_tr_lessi_nucl(i,k,it) = d_tr_lessi_nucl(i,k,it) +    &
+                           ( 1 - frac_nucl(i,k) )*tr_seri(i,k,it)
+                      d_tr_lessi_impa(i,k,it) = d_tr_lessi_impa(i,k,it) +    &
+                           ( 1 - frac_impa(i,k) )*tr_seri(i,k,it)
+                      !
+                      ! Flux lessivage total 
+                      flestottr(i,k,it) = flestottr(i,k,it) -   &
+                           ( d_tr_lessi_nucl(i,k,it)   +        &
+                           d_tr_lessi_impa(i,k,it) ) *          &
+                           ( paprs(i,k)-paprs(i,k+1) ) /        &
+                           (RG * pdtphys)
+                      !! Mise a jour des traceurs due a l'impaction,nucleation 
+                      !                 tr_seri(i,k,it)=tr_seri(i,k,it)*frac_impa(i,k)*frac_nucl(i,k)
+                      !!  calcul de la tendance liee au lessivage stratiforme
+                      !                 d_tr_ls(i,k,it)=tr_seri(i,k,it)*&
+                      !                                (1.-1./(frac_impa(i,k)*frac_nucl(i,k)))
+                      !--------------
+                   ENDDO
+                ENDDO
+             ENDIF
+          ENDDO
+          ! *********   end modified old version
+
+       ELSE IF (iflag_lscav .EQ. 1) THEN ! frac_impa, frac_nucl
+          ! *********    old version
+
+          d_tr_lessi_nucl(:,:,:) = 0. 
+          d_tr_lessi_impa(:,:,:) = 0.
+          flestottr(:,:,:) = 0. 
+          !=========================
+          ! LESSIVAGE LARGE SCALE : 
+          !=========================
+
+          ! Tendance des aerosols nuclees et impactes 
+          ! -----------------------------------------
+          DO it = 1, nbtr
+             IF (aerosol(it)) THEN
+                DO k = 1, klev
+                   DO i = 1, klon
+                      d_tr_lessi_nucl(i,k,it) = d_tr_lessi_nucl(i,k,it) +    &
+                           ( 1 - frac_nucl(i,k) )*tr_seri(i,k,it)
+                      d_tr_lessi_impa(i,k,it) = d_tr_lessi_impa(i,k,it) +    &
+                           ( 1 - frac_impa(i,k) )*tr_seri(i,k,it)
+
+                      !
+                      ! Flux lessivage total 
+                      ! ------------------------------------------------------------
+                      flestottr(i,k,it) = flestottr(i,k,it) -   &
+                           ( d_tr_lessi_nucl(i,k,it)   +        &
+                           d_tr_lessi_impa(i,k,it) ) *          &
+                           ( paprs(i,k)-paprs(i,k+1) ) /        &
+                           (RG * pdtphys)
+                      !
+                      ! Mise a jour des traceurs due a l'impaction,nucleation 
+                      ! ----------------------------------------------------------------------
+                      tr_seri(i,k,it)=tr_seri(i,k,it)*frac_impa(i,k)*frac_nucl(i,k)
+                   ENDDO
+                ENDDO
+             ENDIF
+          ENDDO
+
+          ! *********   end old version
+       ENDIF  !  iflag_lscav .EQ. 1, 2, 3 or 4
+       !
+    ENDIF !  lessivage
+
+
+    !    -- CHIMIE INCA  config_inca = aero or chem --
+    IF (ANY(type_trac == ['inca','inco'])) THEN  ! ModThL
+
+       CALL tracinca(&
+            nstep,    julien,   gmtime,         lafin,     &
+            pdtphys,  t_seri,   paprs,          pplay,     &
+            pmfu,     upwd,     ftsol,  pctsrf, pphis,     &
+            pphi,     albsol,   sh,    ch,     rh,        &
+            cldfra,   rneb,     diafra,         cldliq,    &
+            itop_con, ibas_con, pmflxr,         pmflxs,    &
+            prfl,     psfl,     aerosol_couple, flxmass_w, &
+            tau_aero, piz_aero, cg_aero,        ccm,       &
+            rfname,                                        &
+            tr_seri(:,:,1+nqCO2:nbtr),  source(:,1+nqCO2:nbtr))  ! ModThL  
+    ENDIF
+
+  END SUBROUTINE phytrac
+
+END MODULE
Index: DZ6/trunk/libf/phylmd/plevel.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/plevel.F90	(revision 5267)
+++ 	(revision )
@@ -1,134 +1,0 @@
-
-! $Header$
-
-! ================================================================
-! ================================================================
-SUBROUTINE plevel(ilon, ilev, lnew, pgcm, pres, qgcm, qpres)
-  ! ================================================================
-  ! ================================================================
-  USE netcdf
-  USE dimphy
-  USE phys_state_var_mod, ONLY: missing_val_nf90
-  USE wxios, ONLY: missing_val_xios => missing_val, using_xios
-  IMPLICIT NONE
-
-  ! ================================================================
-
-  ! Interpoler des champs 3-D u, v et g du modele a un niveau de
-  ! pression donnee (pres)
-
-  ! INPUT:  ilon ----- nombre de points
-  ! ilev ----- nombre de couches
-  ! lnew ----- true si on doit reinitialiser les poids
-  ! pgcm ----- pressions modeles
-  ! pres ----- pression vers laquelle on interpolle
-  ! Qgcm ----- champ GCM
-  ! Qpres ---- champ interpolle au niveau pres
-
-  ! ================================================================
-
-  ! arguments :
-  ! -----------
-
-  INTEGER ilon, ilev
-  LOGICAL lnew
-
-  REAL pgcm(ilon, ilev)
-  REAL qgcm(ilon, ilev)
-  REAL pres
-  REAL qpres(ilon)
-
-  ! local :
-  ! -------
-
-  ! ym      INTEGER lt(klon), lb(klon)
-  ! ym      REAL ptop, pbot, aist(klon), aisb(klon)
-
-  ! ym      save lt,lb,ptop,pbot,aist,aisb
-  INTEGER, ALLOCATABLE, SAVE, DIMENSION (:) :: lt, lb
-  REAL, ALLOCATABLE, SAVE, DIMENSION (:) :: aist, aisb
-  !$OMP THREADPRIVATE(lt,lb,aist,aisb)
-  REAL, SAVE :: ptop, pbot
-  !$OMP THREADPRIVATE(ptop, pbot)
-  LOGICAL, SAVE :: first = .TRUE.
-  !$OMP THREADPRIVATE(first)
-  INTEGER i, k
-
-! REAL missing_val
-  REAL :: missing_val
-
-! missing_val = nf90_fill_real
-  IF (using_xios) THEN
-    missing_val = missing_val_xios
-  ELSE
-    missing_val=missing_val_nf90
-  ENDIF
-
-  IF (first) THEN
-    ALLOCATE (lt(klon), lb(klon), aist(klon), aisb(klon))
-    first = .FALSE.
-  END IF
-
-  ! =====================================================================
-  IF (lnew) THEN
-    ! on r�nitialise les r�ndicages et les poids
-    ! =====================================================================
-
-
-    ! Chercher les 2 couches les plus proches du niveau a obtenir
-
-    ! Eventuellement, faire l'extrapolation a partir des deux couches
-    ! les plus basses ou les deux couches les plus hautes:
-    DO i = 1, klon
-      IF (abs(pres-pgcm(i,ilev))<abs(pres-pgcm(i,1))) THEN
-        lt(i) = ilev ! 2
-        lb(i) = ilev - 1 ! 1
-      ELSE
-        lt(i) = 2
-        lb(i) = 1
-      END IF
-    END DO
-    DO k = 1, ilev - 1
-      DO i = 1, klon
-        pbot = pgcm(i, k)
-        ptop = pgcm(i, k+1)
-        IF (ptop<=pres .AND. pbot>=pres) THEN
-          lt(i) = k + 1
-          lb(i) = k
-        END IF
-      END DO
-    END DO
-
-    ! Interpolation lineaire:
-
-    DO i = 1, klon
-      ! interpolation en logarithme de pression:
-
-      ! ...   Modif . P. Le Van    ( 20/01/98) ....
-      ! Modif Fr��ic Hourdin (3/01/02)
-
-      aist(i) = log(pgcm(i,lb(i))/pres)/log(pgcm(i,lb(i))/pgcm(i,lt(i)))
-      aisb(i) = log(pres/pgcm(i,lt(i)))/log(pgcm(i,lb(i))/pgcm(i,lt(i)))
-    END DO
-
-
-  END IF ! lnew
-
-  ! ======================================================================
-  ! inteprollation
-  ! ======================================================================
-
-  DO i = 1, klon
-    qpres(i) = qgcm(i, lb(i))*aisb(i) + qgcm(i, lt(i))*aist(i)
-  END DO
-
-  ! Je mets les vents a zero quand je rencontre une montagne
-  DO i = 1, klon
-    IF (pgcm(i,1)<pres) THEN
-      qpres(i) = missing_val
-    END IF
-  END DO
-
-
-  RETURN
-END SUBROUTINE plevel
Index: /LMDZ6/trunk/libf/phylmd/plevel.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/plevel.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/plevel.f90	(revision 5268)
@@ -0,0 +1,134 @@
+
+! $Header$
+
+! ================================================================
+! ================================================================
+SUBROUTINE plevel(ilon, ilev, lnew, pgcm, pres, qgcm, qpres)
+  ! ================================================================
+  ! ================================================================
+  USE netcdf
+  USE dimphy
+  USE phys_state_var_mod, ONLY: missing_val_nf90
+  USE wxios, ONLY: missing_val_xios => missing_val, using_xios
+  IMPLICIT NONE
+
+  ! ================================================================
+
+  ! Interpoler des champs 3-D u, v et g du modele a un niveau de
+  ! pression donnee (pres)
+
+  ! INPUT:  ilon ----- nombre de points
+  ! ilev ----- nombre de couches
+  ! lnew ----- true si on doit reinitialiser les poids
+  ! pgcm ----- pressions modeles
+  ! pres ----- pression vers laquelle on interpolle
+  ! Qgcm ----- champ GCM
+  ! Qpres ---- champ interpolle au niveau pres
+
+  ! ================================================================
+
+  ! arguments :
+  ! -----------
+
+  INTEGER ilon, ilev
+  LOGICAL lnew
+
+  REAL pgcm(ilon, ilev)
+  REAL qgcm(ilon, ilev)
+  REAL pres
+  REAL qpres(ilon)
+
+  ! local :
+  ! -------
+
+  ! ym      INTEGER lt(klon), lb(klon)
+  ! ym      REAL ptop, pbot, aist(klon), aisb(klon)
+
+  ! ym      save lt,lb,ptop,pbot,aist,aisb
+  INTEGER, ALLOCATABLE, SAVE, DIMENSION (:) :: lt, lb
+  REAL, ALLOCATABLE, SAVE, DIMENSION (:) :: aist, aisb
+  !$OMP THREADPRIVATE(lt,lb,aist,aisb)
+  REAL, SAVE :: ptop, pbot
+  !$OMP THREADPRIVATE(ptop, pbot)
+  LOGICAL, SAVE :: first = .TRUE.
+  !$OMP THREADPRIVATE(first)
+  INTEGER i, k
+
+! REAL missing_val
+  REAL :: missing_val
+
+! missing_val = nf90_fill_real
+  IF (using_xios) THEN
+    missing_val = missing_val_xios
+  ELSE
+    missing_val=missing_val_nf90
+  ENDIF
+
+  IF (first) THEN
+    ALLOCATE (lt(klon), lb(klon), aist(klon), aisb(klon))
+    first = .FALSE.
+  END IF
+
+  ! =====================================================================
+  IF (lnew) THEN
+    ! on r�nitialise les r�ndicages et les poids
+    ! =====================================================================
+
+
+    ! Chercher les 2 couches les plus proches du niveau a obtenir
+
+    ! Eventuellement, faire l'extrapolation a partir des deux couches
+    ! les plus basses ou les deux couches les plus hautes:
+    DO i = 1, klon
+      IF (abs(pres-pgcm(i,ilev))<abs(pres-pgcm(i,1))) THEN
+        lt(i) = ilev ! 2
+        lb(i) = ilev - 1 ! 1
+      ELSE
+        lt(i) = 2
+        lb(i) = 1
+      END IF
+    END DO
+    DO k = 1, ilev - 1
+      DO i = 1, klon
+        pbot = pgcm(i, k)
+        ptop = pgcm(i, k+1)
+        IF (ptop<=pres .AND. pbot>=pres) THEN
+          lt(i) = k + 1
+          lb(i) = k
+        END IF
+      END DO
+    END DO
+
+    ! Interpolation lineaire:
+
+    DO i = 1, klon
+      ! interpolation en logarithme de pression:
+
+      ! ...   Modif . P. Le Van    ( 20/01/98) ....
+      ! Modif Fr��ic Hourdin (3/01/02)
+
+      aist(i) = log(pgcm(i,lb(i))/pres)/log(pgcm(i,lb(i))/pgcm(i,lt(i)))
+      aisb(i) = log(pres/pgcm(i,lt(i)))/log(pgcm(i,lb(i))/pgcm(i,lt(i)))
+    END DO
+
+
+  END IF ! lnew
+
+  ! ======================================================================
+  ! inteprollation
+  ! ======================================================================
+
+  DO i = 1, klon
+    qpres(i) = qgcm(i, lb(i))*aisb(i) + qgcm(i, lt(i))*aist(i)
+  END DO
+
+  ! Je mets les vents a zero quand je rencontre une montagne
+  DO i = 1, klon
+    IF (pgcm(i,1)<pres) THEN
+      qpres(i) = missing_val
+    END IF
+  END DO
+
+
+  RETURN
+END SUBROUTINE plevel
Index: DZ6/trunk/libf/phylmd/plevel_new.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/plevel_new.F90	(revision 5267)
+++ 	(revision )
@@ -1,141 +1,0 @@
-
-! $Header: /home/cvsroot/LMDZ4/libf/phylmd/plevel.F,v 1.1.1.1.10.1 2006/08/17
-! 15:41:51 fairhead Exp $
-
-! ================================================================
-! ================================================================
-SUBROUTINE plevel_new(ilon, ilev, klevstd, lnew, pgcm, pres, qgcm, qpres)
-  ! ================================================================
-  ! ================================================================
-  USE netcdf
-  USE dimphy
-  USE phys_state_var_mod, ONLY: missing_val_nf90
-  USE wxios, ONLY: missing_val_xios=>missing_val, using_xios
-
-  IMPLICIT NONE
-
-  ! ================================================================
-
-  ! Interpoler des champs 3-D u, v et g du modele a un niveau de
-  ! pression donnee (pres)
-
-  ! INPUT:  ilon ----- nombre de points
-  ! ilev ----- nombre de couches
-  ! lnew ----- true si on doit reinitialiser les poids
-  ! pgcm ----- pressions modeles
-  ! pres ----- pression vers laquelle on interpolle
-  ! Qgcm ----- champ GCM
-  ! Qpres ---- champ interpolle au niveau pres
-
-  ! ================================================================
-
-  ! arguments :
-  ! -----------
-
-  INTEGER ilon, ilev, klevstd
-  LOGICAL lnew
-
-  REAL pgcm(ilon, ilev)
-  REAL qgcm(ilon, ilev)
-  REAL pres(klevstd)
-  REAL qpres(ilon, klevstd)
-
-  ! local :
-  ! -------
-
-  ! ym      INTEGER lt(klon), lb(klon)
-  ! ym      REAL ptop, pbot, aist(klon), aisb(klon)
-
-  ! ym      save lt,lb,ptop,pbot,aist,aisb
-  INTEGER, ALLOCATABLE, SAVE, DIMENSION (:, :) :: lt, lb
-  REAL, ALLOCATABLE, SAVE, DIMENSION (:, :) :: aist, aisb
-  !$OMP THREADPRIVATE(lt,lb,aist,aisb)
-  REAL, SAVE :: ptop, pbot
-  !$OMP THREADPRIVATE(ptop, pbot)
-  LOGICAL, SAVE :: first = .TRUE.
-  INTEGER :: nlev
-  !$OMP THREADPRIVATE(first)
-  INTEGER i, k
-
-  REAL :: missing_val
-
-  IF (using_xios) THEN
-    missing_val=missing_val_xios
-  ELSE
-    missing_val=missing_val_nf90
-  ENDIF
-
-  IF (first) THEN
-    ALLOCATE (lt(klon,klevstd), lb(klon,klevstd))
-    ALLOCATE (aist(klon,klevstd), aisb(klon,klevstd))
-    first = .FALSE.
-  END IF
-
-  ! =====================================================================
-  IF (lnew) THEN
-    ! on reinitialise les reindicages et les poids
-    ! =====================================================================
-
-
-    ! Chercher les 2 couches les plus proches du niveau a obtenir
-
-    ! Eventuellement, faire l'extrapolation a partir des deux couches
-    ! les plus basses ou les deux couches les plus hautes:
-
-
-    DO nlev = 1, klevstd
-      DO i = 1, klon
-        IF (abs(pres(nlev)-pgcm(i,ilev))<abs(pres(nlev)-pgcm(i,1))) THEN
-          lt(i, nlev) = ilev ! 2
-          lb(i, nlev) = ilev - 1 ! 1
-        ELSE
-          lt(i, nlev) = 2
-          lb(i, nlev) = 1
-        END IF
-      END DO
-      DO k = 1, ilev - 1
-        DO i = 1, klon
-          pbot = pgcm(i, k)
-          ptop = pgcm(i, k+1)
-          IF (ptop<=pres(nlev) .AND. pbot>=pres(nlev)) THEN
-            lt(i, nlev) = k + 1
-            lb(i, nlev) = k
-          END IF
-        END DO
-      END DO
-
-      ! Interpolation lineaire:
-      DO i = 1, klon
-        ! interpolation en logarithme de pression:
-
-        ! ...   Modif . P. Le Van    ( 20/01/98) ....
-        ! Modif Frederic Hourdin (3/01/02)
-
-        aist(i, nlev) = log(pgcm(i,lb(i,nlev))/pres(nlev))/log(pgcm(i,lb(i, &
-          nlev))/pgcm(i,lt(i,nlev)))
-        aisb(i, nlev) = log(pres(nlev)/pgcm(i,lt(i,nlev)))/log(pgcm(i,lb(i, &
-          nlev))/pgcm(i,lt(i,nlev)))
-      END DO
-    END DO
-
-  END IF ! lnew
-
-  ! ======================================================================
-  ! inteprollation
-  ! ET je mets les vents a zero quand je rencontre une montagne
-  ! ======================================================================
-
-  DO nlev = 1, klevstd
-    DO i = 1, klon
-      IF (pgcm(i,1)<pres(nlev)) THEN
-        qpres(i, nlev) = missing_val
-      ELSE
-        qpres(i, nlev) = qgcm(i, lb(i,nlev))*aisb(i, nlev) + &
-          qgcm(i, lt(i,nlev))*aist(i, nlev)
-      END IF
-    END DO
-  END DO
-
-
-  RETURN
-END SUBROUTINE plevel_new
Index: /LMDZ6/trunk/libf/phylmd/plevel_new.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/plevel_new.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/plevel_new.f90	(revision 5268)
@@ -0,0 +1,141 @@
+
+! $Header: /home/cvsroot/LMDZ4/libf/phylmd/plevel.F,v 1.1.1.1.10.1 2006/08/17
+! 15:41:51 fairhead Exp $
+
+! ================================================================
+! ================================================================
+SUBROUTINE plevel_new(ilon, ilev, klevstd, lnew, pgcm, pres, qgcm, qpres)
+  ! ================================================================
+  ! ================================================================
+  USE netcdf
+  USE dimphy
+  USE phys_state_var_mod, ONLY: missing_val_nf90
+  USE wxios, ONLY: missing_val_xios=>missing_val, using_xios
+
+  IMPLICIT NONE
+
+  ! ================================================================
+
+  ! Interpoler des champs 3-D u, v et g du modele a un niveau de
+  ! pression donnee (pres)
+
+  ! INPUT:  ilon ----- nombre de points
+  ! ilev ----- nombre de couches
+  ! lnew ----- true si on doit reinitialiser les poids
+  ! pgcm ----- pressions modeles
+  ! pres ----- pression vers laquelle on interpolle
+  ! Qgcm ----- champ GCM
+  ! Qpres ---- champ interpolle au niveau pres
+
+  ! ================================================================
+
+  ! arguments :
+  ! -----------
+
+  INTEGER ilon, ilev, klevstd
+  LOGICAL lnew
+
+  REAL pgcm(ilon, ilev)
+  REAL qgcm(ilon, ilev)
+  REAL pres(klevstd)
+  REAL qpres(ilon, klevstd)
+
+  ! local :
+  ! -------
+
+  ! ym      INTEGER lt(klon), lb(klon)
+  ! ym      REAL ptop, pbot, aist(klon), aisb(klon)
+
+  ! ym      save lt,lb,ptop,pbot,aist,aisb
+  INTEGER, ALLOCATABLE, SAVE, DIMENSION (:, :) :: lt, lb
+  REAL, ALLOCATABLE, SAVE, DIMENSION (:, :) :: aist, aisb
+  !$OMP THREADPRIVATE(lt,lb,aist,aisb)
+  REAL, SAVE :: ptop, pbot
+  !$OMP THREADPRIVATE(ptop, pbot)
+  LOGICAL, SAVE :: first = .TRUE.
+  INTEGER :: nlev
+  !$OMP THREADPRIVATE(first)
+  INTEGER i, k
+
+  REAL :: missing_val
+
+  IF (using_xios) THEN
+    missing_val=missing_val_xios
+  ELSE
+    missing_val=missing_val_nf90
+  ENDIF
+
+  IF (first) THEN
+    ALLOCATE (lt(klon,klevstd), lb(klon,klevstd))
+    ALLOCATE (aist(klon,klevstd), aisb(klon,klevstd))
+    first = .FALSE.
+  END IF
+
+  ! =====================================================================
+  IF (lnew) THEN
+    ! on reinitialise les reindicages et les poids
+    ! =====================================================================
+
+
+    ! Chercher les 2 couches les plus proches du niveau a obtenir
+
+    ! Eventuellement, faire l'extrapolation a partir des deux couches
+    ! les plus basses ou les deux couches les plus hautes:
+
+
+    DO nlev = 1, klevstd
+      DO i = 1, klon
+        IF (abs(pres(nlev)-pgcm(i,ilev))<abs(pres(nlev)-pgcm(i,1))) THEN
+          lt(i, nlev) = ilev ! 2
+          lb(i, nlev) = ilev - 1 ! 1
+        ELSE
+          lt(i, nlev) = 2
+          lb(i, nlev) = 1
+        END IF
+      END DO
+      DO k = 1, ilev - 1
+        DO i = 1, klon
+          pbot = pgcm(i, k)
+          ptop = pgcm(i, k+1)
+          IF (ptop<=pres(nlev) .AND. pbot>=pres(nlev)) THEN
+            lt(i, nlev) = k + 1
+            lb(i, nlev) = k
+          END IF
+        END DO
+      END DO
+
+      ! Interpolation lineaire:
+      DO i = 1, klon
+        ! interpolation en logarithme de pression:
+
+        ! ...   Modif . P. Le Van    ( 20/01/98) ....
+        ! Modif Frederic Hourdin (3/01/02)
+
+        aist(i, nlev) = log(pgcm(i,lb(i,nlev))/pres(nlev))/log(pgcm(i,lb(i, &
+          nlev))/pgcm(i,lt(i,nlev)))
+        aisb(i, nlev) = log(pres(nlev)/pgcm(i,lt(i,nlev)))/log(pgcm(i,lb(i, &
+          nlev))/pgcm(i,lt(i,nlev)))
+      END DO
+    END DO
+
+  END IF ! lnew
+
+  ! ======================================================================
+  ! inteprollation
+  ! ET je mets les vents a zero quand je rencontre une montagne
+  ! ======================================================================
+
+  DO nlev = 1, klevstd
+    DO i = 1, klon
+      IF (pgcm(i,1)<pres(nlev)) THEN
+        qpres(i, nlev) = missing_val
+      ELSE
+        qpres(i, nlev) = qgcm(i, lb(i,nlev))*aisb(i, nlev) + &
+          qgcm(i, lt(i,nlev))*aist(i, nlev)
+      END IF
+    END DO
+  END DO
+
+
+  RETURN
+END SUBROUTINE plevel_new
Index: DZ6/trunk/libf/phylmd/pppmer.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/pppmer.F90	(revision 5267)
+++ 	(revision )
@@ -1,161 +1,0 @@
-SUBROUTINE PPPMER(KPROMA,KSTART,KPROF,PRPRESS,POROG,PTSTAR,PT0,PMSLPPP)
-
-!**** *PPPMER* - POST-PROCESS MSL PRESSURE.
-
-!     PURPOSE.
-!     --------
-!           COMPUTES MSL PRESSURE.
-
-!**   INTERFACE.
-!     ----------
-
-!        *CALL* *PPPMER(KPROMA,KSTART,KPROF,PRPRESS,POROG,PTSTAR,PT0,
-!    S                  PMSLPPP)
-
-!        EXPLICIT ARGUMENTS
-!        --------------------
-
-
-!        KPROMA                    - HORIZONTAL DIMENSION.             (INPUT)
-!        KSTART                    - START OF WORK.                    (INPUT)
-!        KPROF                     - DEPTH OF WORK.                    (INPUT)
-!        PRPRESS(KPROMA)           - SURFACE PRESSURE                  (INPUT)
-!        POROG(KPROMA)             - MODEL OROGRAPHY.                  (INPUT)
-!        PTSTAR(KPROMA)            - SURFACE TEMPERATURE               (INPUT)
-!        PT0(KPROMA)               - STANDARD SURFACE TEMPERATURE      (INPUT)
-!        PMSLPPP(KPROMA)           - POST-PROCESSED MSL PRESSURE       (OUTPUT)
-!        IMPLICIT ARGUMENTS :  CONSTANTS FROM YOMCST,YOMGEM,YOMSTA.
-!        --------------------
-
-!     METHOD.
-!     -------
-!        SEE DOCUMENTATION
-
-!     EXTERNALS.  NONE
-!     ----------
-
-!     REFERENCE.
-!     ----------
-!        ECMWF Research Department documentation of the IFS
-
-!     AUTHOR.
-!     -------
-!        MATS HAMRUD AND PHILIPPE COURTIER  *ECMWF*
-
-!     MODIFICATIONS.
-!     --------------
-!        ORIGINAL : 89-01-26
-
-!     E. A-son, J-F Geleyn 920409 Mod. T*, T0 and alpha below surface.
-!        M.Hamrud      01-Oct-2003 CY28 Cleaning
-
-!     ------------------------------------------------------------------
-
-! USE PARKIND1 
-!<http://intra.cnrm.meteo.fr/eac/ARPCLI5.2/doci/code/arpcli5.2/xrd/module/parkind1.F90.php#parkind1>  ,ONLY : JPIM     ,JPRB
-! USE YOMHOOK 
-!<http://intra.cnrm.meteo.fr/eac/ARPCLI5.2/doci/code/arpcli5.2/xrd/module/yomhook.F90.php#yomhook>   ,ONLY : LHOOK,   DR_HOOK
-
-!USE YOMCST, ONLY : RG, RD
-!<http://intra.cnrm.meteo.fr/eac/ARPCLI5.2/doci/code/arpcli5.2/arp/module/yomcst.F90.php#yomcst>   , ONLY : RG
-
-!<http://intra.cnrm.meteo.fr/eac/ARPCLI5.2/doci/code/arpcli5.2/xrd/support/rg.F.php#rg>       ,RD
-! USE YOMSTA 
-!<http://intra.cnrm.meteo.fr/eac/ARPCLI5.2/doci/code/arpcli5.2/arp/module/yomsta.F90.php#yomsta>   , ONLY : RDTDZ1
-
-  IMPLICIT NONE
-
-include "YOMCST.h"
-!IM INTEGER(KIND=JPIM),INTENT(IN)    :: KPROMA
-!IM INTEGER(KIND=JPIM),INTENT(IN)    :: KSTART
-!IM INTEGER(KIND=JPIM),INTENT(IN)    :: KPROF
- INTEGER,INTENT(IN)    :: KPROMA
- INTEGER,INTENT(IN)    :: KSTART
- INTEGER,INTENT(IN)    :: KPROF
-!IM REAL(KIND=JPRB)   ,INTENT(IN)    :: PRPRESS(KPROMA)
-!IM REAL(KIND=JPRB)   ,INTENT(IN)    :: POROG(KPROMA)
-!IM REAL(KIND=JPRB)   ,INTENT(IN)    :: PTSTAR(KPROMA)
-!IM REAL(KIND=JPRB)   ,INTENT(IN)    :: PT0(KPROMA)
-!IM REAL(KIND=JPRB)   ,INTENT(OUT)   :: PMSLPPP(KPROMA)
-!IM REAL(KIND=JPRB) :: ZTSTAR(KPROMA)
-!IM REAL(KIND=JPRB) :: ZALPHA(KPROMA)
- REAL,INTENT(IN)    :: PRPRESS(KPROMA)
- REAL,INTENT(IN)    :: POROG(KPROMA)
- REAL,INTENT(IN)    :: PTSTAR(KPROMA)
- REAL,INTENT(IN)    :: PT0(KPROMA)
- REAL,INTENT(OUT)   :: PMSLPPP(KPROMA)
- REAL :: ZTSTAR(KPROMA)
- REAL :: ZALPHA(KPROMA)
-
-!IM INTEGER(KIND=JPIM) :: JL
- INTEGER :: JL
-
-!IM REAL(KIND=JPRB) :: ZDTDZSG, ZOROG, ZT0, ZTX, ZTY, ZX, ZY, ZY2
-!IM REAL(KIND=JPRB) :: ZHOOK_HANDLE
- REAL :: ZDTDZSG, ZOROG, ZT0, ZTX, ZTY, ZX, ZY, ZY2
- REAL :: ZHOOK_HANDLE
-!IM beg
-REAL, PARAMETER                  :: RDTDZ1=-0.0065 !or USE YOMSTA
-!IM end
-
-!     ------------------------------------------------------------------
-
-!*       1.    POST-PROCESS MSL PRESSURE.
-!              --------------------------
-
-!*       1.1   COMPUTATION OF MODIFIED ALPHA AND TSTAR.
-
-!IM IF (LHOOK) CALL DR_HOOK('PPPMER',0,ZHOOK_HANDLE)
-!IM ZTX=290.5_JPRB
-!IM ZTY=255.0_JPRB
- ZTX=290.5
- ZTY=255.0
- ZDTDZSG=-RDTDZ1/RG 
-!<http://intra.cnrm.meteo.fr/eac/ARPCLI5.2/doci/code/arpcli5.2/xrd/support/rg.F.php#rg>
- DO JL=KSTART,KPROF
-
-   IF(PTSTAR(JL) < ZTY) THEN
-!IM  ZTSTAR(JL)=0.5_JPRB*(ZTY+PTSTAR(JL))
-     ZTSTAR(JL)=0.5*(ZTY+PTSTAR(JL))
-   ELSEIF(PTSTAR(JL) < ZTX) THEN
-     ZTSTAR(JL)=PTSTAR(JL)
-   ELSE
-!IM    ZTSTAR(JL)=0.5_JPRB*(ZTX+PTSTAR(JL))
-     ZTSTAR(JL)=0.5*(ZTX+PTSTAR(JL))
-   ENDIF
-
-   ZT0=ZTSTAR(JL)+ZDTDZSG*POROG(JL)
-   IF(ZTX > ZTSTAR(JL) .AND. ZT0 > ZTX) THEN
-     ZT0=ZTX
-   ELSEIF(ZTX <= ZTSTAR(JL) .AND. ZT0 > ZTSTAR(JL)) THEN
-     ZT0=ZTSTAR(JL)
-   ELSE
-     ZT0=PT0(JL)
-   ENDIF
-
-!IM  ZOROG=SIGN(MAX(1.0_JPRB,ABS(POROG(JL))),POROG(JL))
-   ZOROG=SIGN(MAX(1.0,ABS(POROG(JL))),POROG(JL))
-   ZALPHA(JL)=RD*(ZT0-ZTSTAR(JL))/ZOROG
- ENDDO
-
-!*       1.2   COMPUTATION OF MSL PRESSURE.
-
- DO JL=KSTART,KPROF
-!IM  IF (ABS(POROG(JL)) >= 0.001_JPRB) THEN
-   IF (ABS(POROG(JL)) >= 0.001) THEN
-     ZX=POROG(JL)/(RD*ZTSTAR(JL))
-     ZY=ZALPHA(JL)*ZX
-     ZY2=ZY*ZY
-
-!IM    PMSLPPP(JL)=PRPRESS(JL)*EXP(ZX*(1.0_JPRB-0.5_JPRB*ZY+1.0_JPRB/3._JPRB*ZY2))
-     PMSLPPP(JL)=PRPRESS(JL)*EXP(ZX*(1.0-0.5*ZY+1.0/3.*ZY2))
-   ELSE
-     PMSLPPP(JL)=PRPRESS(JL)
-   ENDIF
- ENDDO
-
-
-!     ------------------------------------------------------------------
-
-!IM IF (LHOOK) CALL DR_HOOK('PPPMER',1,ZHOOK_HANDLE)
- END SUBROUTINE PPPMER
Index: /LMDZ6/trunk/libf/phylmd/pppmer.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/pppmer.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/pppmer.f90	(revision 5268)
@@ -0,0 +1,161 @@
+SUBROUTINE PPPMER(KPROMA,KSTART,KPROF,PRPRESS,POROG,PTSTAR,PT0,PMSLPPP)
+
+!**** *PPPMER* - POST-PROCESS MSL PRESSURE.
+
+!     PURPOSE.
+!     --------
+!           COMPUTES MSL PRESSURE.
+
+!**   INTERFACE.
+!     ----------
+
+!        *CALL* *PPPMER(KPROMA,KSTART,KPROF,PRPRESS,POROG,PTSTAR,PT0,
+!    S                  PMSLPPP)
+
+!        EXPLICIT ARGUMENTS
+!        --------------------
+
+
+!        KPROMA                    - HORIZONTAL DIMENSION.             (INPUT)
+!        KSTART                    - START OF WORK.                    (INPUT)
+!        KPROF                     - DEPTH OF WORK.                    (INPUT)
+!        PRPRESS(KPROMA)           - SURFACE PRESSURE                  (INPUT)
+!        POROG(KPROMA)             - MODEL OROGRAPHY.                  (INPUT)
+!        PTSTAR(KPROMA)            - SURFACE TEMPERATURE               (INPUT)
+!        PT0(KPROMA)               - STANDARD SURFACE TEMPERATURE      (INPUT)
+!        PMSLPPP(KPROMA)           - POST-PROCESSED MSL PRESSURE       (OUTPUT)
+!        IMPLICIT ARGUMENTS :  CONSTANTS FROM YOMCST,YOMGEM,YOMSTA.
+!        --------------------
+
+!     METHOD.
+!     -------
+!        SEE DOCUMENTATION
+
+!     EXTERNALS.  NONE
+!     ----------
+
+!     REFERENCE.
+!     ----------
+!        ECMWF Research Department documentation of the IFS
+
+!     AUTHOR.
+!     -------
+!        MATS HAMRUD AND PHILIPPE COURTIER  *ECMWF*
+
+!     MODIFICATIONS.
+!     --------------
+!        ORIGINAL : 89-01-26
+
+!     E. A-son, J-F Geleyn 920409 Mod. T*, T0 and alpha below surface.
+!        M.Hamrud      01-Oct-2003 CY28 Cleaning
+
+!     ------------------------------------------------------------------
+
+! USE PARKIND1 
+!<http://intra.cnrm.meteo.fr/eac/ARPCLI5.2/doci/code/arpcli5.2/xrd/module/parkind1.F90.php#parkind1>  ,ONLY : JPIM     ,JPRB
+! USE YOMHOOK 
+!<http://intra.cnrm.meteo.fr/eac/ARPCLI5.2/doci/code/arpcli5.2/xrd/module/yomhook.F90.php#yomhook>   ,ONLY : LHOOK,   DR_HOOK
+
+!USE YOMCST, ONLY : RG, RD
+!<http://intra.cnrm.meteo.fr/eac/ARPCLI5.2/doci/code/arpcli5.2/arp/module/yomcst.F90.php#yomcst>   , ONLY : RG
+
+!<http://intra.cnrm.meteo.fr/eac/ARPCLI5.2/doci/code/arpcli5.2/xrd/support/rg.F.php#rg>       ,RD
+! USE YOMSTA 
+!<http://intra.cnrm.meteo.fr/eac/ARPCLI5.2/doci/code/arpcli5.2/arp/module/yomsta.F90.php#yomsta>   , ONLY : RDTDZ1
+
+  IMPLICIT NONE
+
+include "YOMCST.h"
+!IM INTEGER(KIND=JPIM),INTENT(IN)    :: KPROMA
+!IM INTEGER(KIND=JPIM),INTENT(IN)    :: KSTART
+!IM INTEGER(KIND=JPIM),INTENT(IN)    :: KPROF
+ INTEGER,INTENT(IN)    :: KPROMA
+ INTEGER,INTENT(IN)    :: KSTART
+ INTEGER,INTENT(IN)    :: KPROF
+!IM REAL(KIND=JPRB)   ,INTENT(IN)    :: PRPRESS(KPROMA)
+!IM REAL(KIND=JPRB)   ,INTENT(IN)    :: POROG(KPROMA)
+!IM REAL(KIND=JPRB)   ,INTENT(IN)    :: PTSTAR(KPROMA)
+!IM REAL(KIND=JPRB)   ,INTENT(IN)    :: PT0(KPROMA)
+!IM REAL(KIND=JPRB)   ,INTENT(OUT)   :: PMSLPPP(KPROMA)
+!IM REAL(KIND=JPRB) :: ZTSTAR(KPROMA)
+!IM REAL(KIND=JPRB) :: ZALPHA(KPROMA)
+ REAL,INTENT(IN)    :: PRPRESS(KPROMA)
+ REAL,INTENT(IN)    :: POROG(KPROMA)
+ REAL,INTENT(IN)    :: PTSTAR(KPROMA)
+ REAL,INTENT(IN)    :: PT0(KPROMA)
+ REAL,INTENT(OUT)   :: PMSLPPP(KPROMA)
+ REAL :: ZTSTAR(KPROMA)
+ REAL :: ZALPHA(KPROMA)
+
+!IM INTEGER(KIND=JPIM) :: JL
+ INTEGER :: JL
+
+!IM REAL(KIND=JPRB) :: ZDTDZSG, ZOROG, ZT0, ZTX, ZTY, ZX, ZY, ZY2
+!IM REAL(KIND=JPRB) :: ZHOOK_HANDLE
+ REAL :: ZDTDZSG, ZOROG, ZT0, ZTX, ZTY, ZX, ZY, ZY2
+ REAL :: ZHOOK_HANDLE
+!IM beg
+REAL, PARAMETER                  :: RDTDZ1=-0.0065 !or USE YOMSTA
+!IM end
+
+!     ------------------------------------------------------------------
+
+!*       1.    POST-PROCESS MSL PRESSURE.
+!              --------------------------
+
+!*       1.1   COMPUTATION OF MODIFIED ALPHA AND TSTAR.
+
+!IM IF (LHOOK) CALL DR_HOOK('PPPMER',0,ZHOOK_HANDLE)
+!IM ZTX=290.5_JPRB
+!IM ZTY=255.0_JPRB
+ ZTX=290.5
+ ZTY=255.0
+ ZDTDZSG=-RDTDZ1/RG 
+!<http://intra.cnrm.meteo.fr/eac/ARPCLI5.2/doci/code/arpcli5.2/xrd/support/rg.F.php#rg>
+ DO JL=KSTART,KPROF
+
+   IF(PTSTAR(JL) < ZTY) THEN
+!IM  ZTSTAR(JL)=0.5_JPRB*(ZTY+PTSTAR(JL))
+     ZTSTAR(JL)=0.5*(ZTY+PTSTAR(JL))
+   ELSEIF(PTSTAR(JL) < ZTX) THEN
+     ZTSTAR(JL)=PTSTAR(JL)
+   ELSE
+!IM    ZTSTAR(JL)=0.5_JPRB*(ZTX+PTSTAR(JL))
+     ZTSTAR(JL)=0.5*(ZTX+PTSTAR(JL))
+   ENDIF
+
+   ZT0=ZTSTAR(JL)+ZDTDZSG*POROG(JL)
+   IF(ZTX > ZTSTAR(JL) .AND. ZT0 > ZTX) THEN
+     ZT0=ZTX
+   ELSEIF(ZTX <= ZTSTAR(JL) .AND. ZT0 > ZTSTAR(JL)) THEN
+     ZT0=ZTSTAR(JL)
+   ELSE
+     ZT0=PT0(JL)
+   ENDIF
+
+!IM  ZOROG=SIGN(MAX(1.0_JPRB,ABS(POROG(JL))),POROG(JL))
+   ZOROG=SIGN(MAX(1.0,ABS(POROG(JL))),POROG(JL))
+   ZALPHA(JL)=RD*(ZT0-ZTSTAR(JL))/ZOROG
+ ENDDO
+
+!*       1.2   COMPUTATION OF MSL PRESSURE.
+
+ DO JL=KSTART,KPROF
+!IM  IF (ABS(POROG(JL)) >= 0.001_JPRB) THEN
+   IF (ABS(POROG(JL)) >= 0.001) THEN
+     ZX=POROG(JL)/(RD*ZTSTAR(JL))
+     ZY=ZALPHA(JL)*ZX
+     ZY2=ZY*ZY
+
+!IM    PMSLPPP(JL)=PRPRESS(JL)*EXP(ZX*(1.0_JPRB-0.5_JPRB*ZY+1.0_JPRB/3._JPRB*ZY2))
+     PMSLPPP(JL)=PRPRESS(JL)*EXP(ZX*(1.0-0.5*ZY+1.0/3.*ZY2))
+   ELSE
+     PMSLPPP(JL)=PRPRESS(JL)
+   ENDIF
+ ENDDO
+
+
+!     ------------------------------------------------------------------
+
+!IM IF (LHOOK) CALL DR_HOOK('PPPMER',1,ZHOOK_HANDLE)
+ END SUBROUTINE PPPMER
Index: DZ6/trunk/libf/phylmd/press_coefoz_m.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/press_coefoz_m.F90	(revision 5267)
+++ 	(revision )
@@ -1,74 +1,0 @@
-! $Id$
-module press_coefoz_m
-
-  implicit none
-
-  real, allocatable, save:: plev(:)
-  ! (pressure level of Mobidic input data, converted to Pa, in strictly
-  ! ascending order)
-
-  real, allocatable, save:: press_in_edg(:)
-  ! (edges of pressure intervals for Mobidic input data, in Pa, in strictly
-  ! ascending order)
-
-contains
-
-  subroutine press_coefoz
-
-    ! This procedure is called once per "gcm" run.
-    ! A single thread of the root process reads the pressure levels
-    ! from "coefoz_LMDZ.nc" and broadcasts them to the other processes.
-
-    ! We assume that, in "coefoz_LMDZ.nc", the pressure levels are in hPa
-    ! and in strictly ascending order.
-
-    use netcdf95, only: nf95_open, nf95_close, nf95_gw_var, nf95_inq_varid
-    use netcdf, only: nf90_nowrite
-
-    use mod_phys_lmdz_mpi_data, only: is_mpi_root
-    use mod_phys_lmdz_mpi_transfert, only: bcast_mpi ! broadcast
-
-    ! Variables local to the procedure:
-    integer ncid, varid ! for NetCDF
-    integer n_plev ! number of pressure levels in the input data
-    integer k
-
-    !---------------------------------------
-
-    !$omp single
-    print *, "Call sequence information: press_coefoz"
-
-    if (is_mpi_root) then
-       call nf95_open("coefoz_LMDZ.nc", nf90_nowrite, ncid)
-
-       call nf95_inq_varid(ncid, "plev", varid)
-       call nf95_gw_var(ncid, varid, plev)
-       ! Convert from hPa to Pa because "paprs" and "pplay" are in Pa:
-       plev = plev * 100.
-       n_plev = size(plev)
-
-       call nf95_close(ncid)
-    end if
-
-    call bcast_mpi(n_plev)
-    if (.not. is_mpi_root) allocate(plev(n_plev))
-    call bcast_mpi(plev)
-    
-    ! Compute edges of pressure intervals:
-    allocate(press_in_edg(n_plev + 1))
-    if (is_mpi_root) then
-       press_in_edg(1) = 0.
-       ! We choose edges halfway in logarithm:
-       DO k = 2,n_plev
-          press_in_edg(k) = SQRT(plev(k - 1) * plev(k))
-       ENDDO
-       press_in_edg(n_plev + 1) = huge(0.)
-       ! (infinity, but any value guaranteed to be greater than the
-       ! surface pressure would do)
-    end if
-    call bcast_mpi(press_in_edg)
-    !$omp end single
-
-  end subroutine press_coefoz
-
-end module press_coefoz_m
Index: /LMDZ6/trunk/libf/phylmd/press_coefoz_m.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/press_coefoz_m.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/press_coefoz_m.f90	(revision 5268)
@@ -0,0 +1,74 @@
+! $Id$
+module press_coefoz_m
+
+  implicit none
+
+  real, allocatable, save:: plev(:)
+  ! (pressure level of Mobidic input data, converted to Pa, in strictly
+  ! ascending order)
+
+  real, allocatable, save:: press_in_edg(:)
+  ! (edges of pressure intervals for Mobidic input data, in Pa, in strictly
+  ! ascending order)
+
+contains
+
+  subroutine press_coefoz
+
+    ! This procedure is called once per "gcm" run.
+    ! A single thread of the root process reads the pressure levels
+    ! from "coefoz_LMDZ.nc" and broadcasts them to the other processes.
+
+    ! We assume that, in "coefoz_LMDZ.nc", the pressure levels are in hPa
+    ! and in strictly ascending order.
+
+    use netcdf95, only: nf95_open, nf95_close, nf95_gw_var, nf95_inq_varid
+    use netcdf, only: nf90_nowrite
+
+    use mod_phys_lmdz_mpi_data, only: is_mpi_root
+    use mod_phys_lmdz_mpi_transfert, only: bcast_mpi ! broadcast
+
+    ! Variables local to the procedure:
+    integer ncid, varid ! for NetCDF
+    integer n_plev ! number of pressure levels in the input data
+    integer k
+
+    !---------------------------------------
+
+    !$omp single
+    print *, "Call sequence information: press_coefoz"
+
+    if (is_mpi_root) then
+       call nf95_open("coefoz_LMDZ.nc", nf90_nowrite, ncid)
+
+       call nf95_inq_varid(ncid, "plev", varid)
+       call nf95_gw_var(ncid, varid, plev)
+       ! Convert from hPa to Pa because "paprs" and "pplay" are in Pa:
+       plev = plev * 100.
+       n_plev = size(plev)
+
+       call nf95_close(ncid)
+    end if
+
+    call bcast_mpi(n_plev)
+    if (.not. is_mpi_root) allocate(plev(n_plev))
+    call bcast_mpi(plev)
+    
+    ! Compute edges of pressure intervals:
+    allocate(press_in_edg(n_plev + 1))
+    if (is_mpi_root) then
+       press_in_edg(1) = 0.
+       ! We choose edges halfway in logarithm:
+       DO k = 2,n_plev
+          press_in_edg(k) = SQRT(plev(k - 1) * plev(k))
+       ENDDO
+       press_in_edg(n_plev + 1) = huge(0.)
+       ! (infinity, but any value guaranteed to be greater than the
+       ! surface pressure would do)
+    end if
+    call bcast_mpi(press_in_edg)
+    !$omp end single
+
+  end subroutine press_coefoz
+
+end module press_coefoz_m
Index: DZ6/trunk/libf/phylmd/print_debug_phys.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/print_debug_phys.F90	(revision 5267)
+++ 	(revision )
@@ -1,21 +1,0 @@
-SUBROUTINE print_debug_phys (i,debug_lev,text)
-
-USE dimphy, ONLY: klev
-USE phys_local_var_mod, ONLY: u_seri, v_seri, t_seri, q_seri, ql_seri
-USE geometry_mod, ONLY: longitude_deg, latitude_deg
-IMPLICIT NONE
-integer i,debug_lev
-CHARACTER*(*) text
-
-
-integer k
-
-print*,'PLANTAGE POUR LE POINT i=',i,text
-print*,'l    u, v, T, q, ql'
-DO k = 1, klev
-   write(*,'(i3,2f8.4,3f14.4,2e14.2)') k,longitude_deg(i),latitude_deg(i), &
-   u_seri(i,k),v_seri(i,k),t_seri(i,k),q_seri(i,k),ql_seri(i,k)
-ENDDO
-
-RETURN
-END
Index: /LMDZ6/trunk/libf/phylmd/print_debug_phys.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/print_debug_phys.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/print_debug_phys.f90	(revision 5268)
@@ -0,0 +1,21 @@
+SUBROUTINE print_debug_phys (i,debug_lev,text)
+
+USE dimphy, ONLY: klev
+USE phys_local_var_mod, ONLY: u_seri, v_seri, t_seri, q_seri, ql_seri
+USE geometry_mod, ONLY: longitude_deg, latitude_deg
+IMPLICIT NONE
+integer i,debug_lev
+CHARACTER*(*) text
+
+
+integer k
+
+print*,'PLANTAGE POUR LE POINT i=',i,text
+print*,'l    u, v, T, q, ql'
+DO k = 1, klev
+   write(*,'(i3,2f8.4,3f14.4,2e14.2)') k,longitude_deg(i),latitude_deg(i), &
+   u_seri(i,k),v_seri(i,k),t_seri(i,k),q_seri(i,k),ql_seri(i,k)
+ENDDO
+
+RETURN
+END
Index: DZ6/trunk/libf/phylmd/printflag.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/printflag.F90	(revision 5267)
+++ 	(revision )
@@ -1,190 +1,0 @@
-
-! $Header$
-
-SUBROUTINE printflag(tabcntr0, radpas, ok_journe, ok_instan, ok_region)
-
-
-
-  ! Auteur :  P. Le Van
-
-  IMPLICIT NONE
-
-  REAL tabcntr0(100)
-  LOGICAL cycle_diurn0, soil_model0, new_oliq0, ok_orodr0
-  LOGICAL ok_orolf0, ok_limitvr0
-  LOGICAL ok_journe, ok_instan, ok_region
-  INTEGER radpas, radpas0
-
-  include "clesphys.h"
-
-
-  PRINT 100
-  PRINT *, ' ******************************************************* &
-    &                                                         &
-    &  ************'
-  PRINT *, ' ********   Choix  des principales  cles de la physique &
-    &                                                         &
-    &      *********'
-  PRINT *, ' ******************************************************* &
-    &                                                         &
-    &  ************'
-  PRINT 100
-  PRINT 10, iflag_cycle_diurne.GE.1, soil_model
-  PRINT 100
-
-  IF (iflag_con==1) THEN
-    PRINT *, ' *****           Shema  convection   LMD        &
-      &                                                       &
-      &                   ******'
-  ELSE IF (iflag_con==2) THEN
-    PRINT *, ' *****           Shema  convection  Tiedtke     &
-      &                                                       &
-      &                   ******'
-  ELSE IF (iflag_con>=3) THEN
-    PRINT *, ' *****           Shema  convection    Emanuel   &
-      &                                                       &
-      &                   ******'
-  END IF
-  PRINT 100
-
-  PRINT 11, new_oliq, ok_orodr, ok_orolf
-  PRINT 100
-
-  PRINT 7, ok_limitvrai
-  PRINT 100
-
-  PRINT 12, nbapp_rad
-  PRINT 100
-
-  PRINT 8, radpas
-  PRINT 100
-
-  PRINT 4, ok_journe, ok_instan, ok_region
-  PRINT 100
-  PRINT 100
-
-
-  cycle_diurn0 = .FALSE.
-  soil_model0 = .FALSE.
-  new_oliq0 = .FALSE.
-  ok_orodr0 = .FALSE.
-  ok_orolf0 = .FALSE.
-  ok_limitvr0 = .FALSE.
-
-  IF (tabcntr0(7)==1.) cycle_diurn0 = .TRUE.
-  IF (tabcntr0(8)==1.) soil_model0 = .TRUE.
-  IF (tabcntr0(9)==1.) new_oliq0 = .TRUE.
-  IF (tabcntr0(10)==1.) ok_orodr0 = .TRUE.
-  IF (tabcntr0(11)==1.) ok_orolf0 = .TRUE.
-  IF (tabcntr0(12)==1.) ok_limitvr0 = .TRUE.
-
-  PRINT *, ' $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ &
-    &                                                         &
-    & $$$$$$$$$$$$$'
-  PRINT 100
-
-  IF (int(tabcntr0(5))/=iflag_con) THEN
-    PRINT 20, int(tabcntr0(5)), iflag_con
-    PRINT 100
-  END IF
-
-  IF (int(tabcntr0(6))/=nbapp_rad) THEN
-    PRINT 21, int(tabcntr0(6)), nbapp_rad
-    ! radpas0  = NINT( 86400./tabcntr0(1)/INT( tabcntr0(6) ) )
-    PRINT 100
-    ! PRINT 22, radpas0, radpas
-    PRINT 100
-  END IF
-
-  IF (cycle_diurn0 .AND. .NOT. (iflag_cycle_diurne.GE.1) .OR. .NOT. cycle_diurn0 .AND. &
-      (iflag_cycle_diurne.GE.1) ) THEN
-    PRINT 13, cycle_diurn0, iflag_cycle_diurne
-    PRINT 100
-  END IF
-
-  IF (soil_model0 .AND. .NOT. soil_model .OR. .NOT. soil_model0 .AND. &
-      soil_model) THEN
-    PRINT 14, soil_model0, soil_model
-    PRINT 100
-  END IF
-
-  IF (new_oliq0 .AND. .NOT. new_oliq .OR. .NOT. new_oliq0 .AND. new_oliq) &
-      THEN
-    PRINT 16, new_oliq0, new_oliq
-    PRINT 100
-  END IF
-
-  IF (ok_orodr0 .AND. .NOT. ok_orodr .OR. .NOT. ok_orodr0 .AND. ok_orodr) &
-      THEN
-    PRINT 15, ok_orodr0, ok_orodr
-    PRINT 100
-  END IF
-
-  IF (ok_orolf0 .AND. .NOT. ok_orolf .OR. .NOT. ok_orolf0 .AND. ok_orolf) &
-      THEN
-    PRINT 17, ok_orolf0, ok_orolf
-    PRINT 100
-  END IF
-
-  IF (ok_limitvr0 .AND. .NOT. ok_limitvrai .OR. .NOT. ok_limitvr0 .AND. &
-      ok_limitvrai) THEN
-    PRINT 18, ok_limitvr0, ok_limitvrai
-    PRINT 100
-  END IF
-
-  PRINT 100
-  PRINT *, ' ******************************************************* &
-    &                                                         &
-    &  ************'
-  PRINT 100
-
-4 FORMAT (2X, 5('*'), '  ok_journe= ', L3, 3X, ',ok_instan = ', L3, 3X, &
-    ',ok_region = ', L3, 3X, 5('*'))
-
-7 FORMAT (2X, 5('*'), 15X, '      ok_limitvrai   = ', L3, 16X, 5('*'))
-
-8 FORMAT (2X, '*****             radpas    =                      ', I4, 6X, &
-    ' *****')
-
-10 FORMAT (2X, 5('*'), '    Cycle_diurne = ', L3, 4X, ', Soil_model = ', L3, &
-    12X, 6('*'))
-
-
-11 FORMAT (2X, 5('*'), '  new_oliq = ', L3, 3X, ', Ok_orodr = ', L3, 3X, &
-    ', Ok_orolf = ', L3, 3X, 5('*'))
-
-
-12 FORMAT (2X, '*****  Nb d appels /jour des routines de rayonn. = ', I4, 6X, &
-    ' *****')
-
-13 FORMAT (2X, '$$$$$$$$   Attention !!  cycle_diurne  different  sur', /1X, &
-    10X, ' startphy = ', L3, 2X, ' et  run.def = ', L3)
-
-14 FORMAT (2X, '$$$$$$$$   Attention !!    soil_model  different  sur', /1X, &
-    10X, ' startphy = ', L3, 2X, ' et  run.def = ', L3)
-
-15 FORMAT (2X, '$$$$$$$$   Attention !!      ok_orodr  different  sur', /1X, &
-    10X, ' startphy = ', L3, 2X, ' et  run.def = ', L3)
-
-16 FORMAT (2X, '$$$$$$$$   Attention !!      new_oliq  different  sur', /1X, &
-    10X, ' startphy = ', L3, 2X, ' et  run.def = ', L3)
-
-17 FORMAT (2X, '$$$$$$$$   Attention !!      ok_orolf  different  sur', /1X, &
-    10X, ' startphy = ', L3, 2X, ' et  run.def = ', L3)
-
-18 FORMAT (2X, '$$$$$$$$   Attention !!  ok_limitvrai  different  sur', /1X, &
-    10X, ' startphy = ', L3, 2X, ' et  run.def = ', L3)
-
-20 FORMAT (/2X, '$$$$$$$$   Attention !!    iflag_con  different  sur', /1X, &
-    10X, ' startphy = ', I3, 2X, ' et  run.def = ', I3)
-
-21 FORMAT (2X, '$$$$$$$$   Attention !!     nbapp_rad  different  sur', /1X, &
-    10X, ' startphy = ', I3, 2X, ' et  run.def = ', I3)
-
-22 FORMAT (2X, '$$$$$$$$   Attention !!        radpas  different  sur', /1X, &
-    10X, ' startphy = ', I3, 2X, ' et  run.def = ', I3)
-
-100 FORMAT (/)
-
-  RETURN
-END SUBROUTINE printflag
Index: /LMDZ6/trunk/libf/phylmd/printflag.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/printflag.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/printflag.f90	(revision 5268)
@@ -0,0 +1,190 @@
+
+! $Header$
+
+SUBROUTINE printflag(tabcntr0, radpas, ok_journe, ok_instan, ok_region)
+
+
+
+  ! Auteur :  P. Le Van
+
+  IMPLICIT NONE
+
+  REAL tabcntr0(100)
+  LOGICAL cycle_diurn0, soil_model0, new_oliq0, ok_orodr0
+  LOGICAL ok_orolf0, ok_limitvr0
+  LOGICAL ok_journe, ok_instan, ok_region
+  INTEGER radpas, radpas0
+
+  include "clesphys.h"
+
+
+  PRINT 100
+  PRINT *, ' ******************************************************* &
+    &                                                         &
+    &  ************'
+  PRINT *, ' ********   Choix  des principales  cles de la physique &
+    &                                                         &
+    &      *********'
+  PRINT *, ' ******************************************************* &
+    &                                                         &
+    &  ************'
+  PRINT 100
+  PRINT 10, iflag_cycle_diurne.GE.1, soil_model
+  PRINT 100
+
+  IF (iflag_con==1) THEN
+    PRINT *, ' *****           Shema  convection   LMD        &
+      &                                                       &
+      &                   ******'
+  ELSE IF (iflag_con==2) THEN
+    PRINT *, ' *****           Shema  convection  Tiedtke     &
+      &                                                       &
+      &                   ******'
+  ELSE IF (iflag_con>=3) THEN
+    PRINT *, ' *****           Shema  convection    Emanuel   &
+      &                                                       &
+      &                   ******'
+  END IF
+  PRINT 100
+
+  PRINT 11, new_oliq, ok_orodr, ok_orolf
+  PRINT 100
+
+  PRINT 7, ok_limitvrai
+  PRINT 100
+
+  PRINT 12, nbapp_rad
+  PRINT 100
+
+  PRINT 8, radpas
+  PRINT 100
+
+  PRINT 4, ok_journe, ok_instan, ok_region
+  PRINT 100
+  PRINT 100
+
+
+  cycle_diurn0 = .FALSE.
+  soil_model0 = .FALSE.
+  new_oliq0 = .FALSE.
+  ok_orodr0 = .FALSE.
+  ok_orolf0 = .FALSE.
+  ok_limitvr0 = .FALSE.
+
+  IF (tabcntr0(7)==1.) cycle_diurn0 = .TRUE.
+  IF (tabcntr0(8)==1.) soil_model0 = .TRUE.
+  IF (tabcntr0(9)==1.) new_oliq0 = .TRUE.
+  IF (tabcntr0(10)==1.) ok_orodr0 = .TRUE.
+  IF (tabcntr0(11)==1.) ok_orolf0 = .TRUE.
+  IF (tabcntr0(12)==1.) ok_limitvr0 = .TRUE.
+
+  PRINT *, ' $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ &
+    &                                                         &
+    & $$$$$$$$$$$$$'
+  PRINT 100
+
+  IF (int(tabcntr0(5))/=iflag_con) THEN
+    PRINT 20, int(tabcntr0(5)), iflag_con
+    PRINT 100
+  END IF
+
+  IF (int(tabcntr0(6))/=nbapp_rad) THEN
+    PRINT 21, int(tabcntr0(6)), nbapp_rad
+    ! radpas0  = NINT( 86400./tabcntr0(1)/INT( tabcntr0(6) ) )
+    PRINT 100
+    ! PRINT 22, radpas0, radpas
+    PRINT 100
+  END IF
+
+  IF (cycle_diurn0 .AND. .NOT. (iflag_cycle_diurne.GE.1) .OR. .NOT. cycle_diurn0 .AND. &
+      (iflag_cycle_diurne.GE.1) ) THEN
+    PRINT 13, cycle_diurn0, iflag_cycle_diurne
+    PRINT 100
+  END IF
+
+  IF (soil_model0 .AND. .NOT. soil_model .OR. .NOT. soil_model0 .AND. &
+      soil_model) THEN
+    PRINT 14, soil_model0, soil_model
+    PRINT 100
+  END IF
+
+  IF (new_oliq0 .AND. .NOT. new_oliq .OR. .NOT. new_oliq0 .AND. new_oliq) &
+      THEN
+    PRINT 16, new_oliq0, new_oliq
+    PRINT 100
+  END IF
+
+  IF (ok_orodr0 .AND. .NOT. ok_orodr .OR. .NOT. ok_orodr0 .AND. ok_orodr) &
+      THEN
+    PRINT 15, ok_orodr0, ok_orodr
+    PRINT 100
+  END IF
+
+  IF (ok_orolf0 .AND. .NOT. ok_orolf .OR. .NOT. ok_orolf0 .AND. ok_orolf) &
+      THEN
+    PRINT 17, ok_orolf0, ok_orolf
+    PRINT 100
+  END IF
+
+  IF (ok_limitvr0 .AND. .NOT. ok_limitvrai .OR. .NOT. ok_limitvr0 .AND. &
+      ok_limitvrai) THEN
+    PRINT 18, ok_limitvr0, ok_limitvrai
+    PRINT 100
+  END IF
+
+  PRINT 100
+  PRINT *, ' ******************************************************* &
+    &                                                         &
+    &  ************'
+  PRINT 100
+
+4 FORMAT (2X, 5('*'), '  ok_journe= ', L3, 3X, ',ok_instan = ', L3, 3X, &
+    ',ok_region = ', L3, 3X, 5('*'))
+
+7 FORMAT (2X, 5('*'), 15X, '      ok_limitvrai   = ', L3, 16X, 5('*'))
+
+8 FORMAT (2X, '*****             radpas    =                      ', I4, 6X, &
+    ' *****')
+
+10 FORMAT (2X, 5('*'), '    Cycle_diurne = ', L3, 4X, ', Soil_model = ', L3, &
+    12X, 6('*'))
+
+
+11 FORMAT (2X, 5('*'), '  new_oliq = ', L3, 3X, ', Ok_orodr = ', L3, 3X, &
+    ', Ok_orolf = ', L3, 3X, 5('*'))
+
+
+12 FORMAT (2X, '*****  Nb d appels /jour des routines de rayonn. = ', I4, 6X, &
+    ' *****')
+
+13 FORMAT (2X, '$$$$$$$$   Attention !!  cycle_diurne  different  sur', /1X, &
+    10X, ' startphy = ', L3, 2X, ' et  run.def = ', L3)
+
+14 FORMAT (2X, '$$$$$$$$   Attention !!    soil_model  different  sur', /1X, &
+    10X, ' startphy = ', L3, 2X, ' et  run.def = ', L3)
+
+15 FORMAT (2X, '$$$$$$$$   Attention !!      ok_orodr  different  sur', /1X, &
+    10X, ' startphy = ', L3, 2X, ' et  run.def = ', L3)
+
+16 FORMAT (2X, '$$$$$$$$   Attention !!      new_oliq  different  sur', /1X, &
+    10X, ' startphy = ', L3, 2X, ' et  run.def = ', L3)
+
+17 FORMAT (2X, '$$$$$$$$   Attention !!      ok_orolf  different  sur', /1X, &
+    10X, ' startphy = ', L3, 2X, ' et  run.def = ', L3)
+
+18 FORMAT (2X, '$$$$$$$$   Attention !!  ok_limitvrai  different  sur', /1X, &
+    10X, ' startphy = ', L3, 2X, ' et  run.def = ', L3)
+
+20 FORMAT (/2X, '$$$$$$$$   Attention !!    iflag_con  different  sur', /1X, &
+    10X, ' startphy = ', I3, 2X, ' et  run.def = ', I3)
+
+21 FORMAT (2X, '$$$$$$$$   Attention !!     nbapp_rad  different  sur', /1X, &
+    10X, ' startphy = ', I3, 2X, ' et  run.def = ', I3)
+
+22 FORMAT (2X, '$$$$$$$$   Attention !!        radpas  different  sur', /1X, &
+    10X, ' startphy = ', I3, 2X, ' et  run.def = ', I3)
+
+100 FORMAT (/)
+
+  RETURN
+END SUBROUTINE printflag
Index: DZ6/trunk/libf/phylmd/qcheck.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/qcheck.F90	(revision 5267)
+++ 	(revision )
@@ -1,29 +1,0 @@
-FUNCTION qcheck(klon,klev,paprs,q,ql,aire)
-  IMPLICIT none
-  !
-  ! Calculer et imprimer l'eau totale. A utiliser pour verifier
-  ! la conservation de l'eau
-  !
-  include "YOMCST.h"
-  INTEGER,INTENT(IN) :: klon,klev
-  REAL,INTENT(IN) :: paprs(klon,klev+1), q(klon,klev), ql(klon,klev)
-  REAL,INTENT(IN) :: aire(klon)
-  REAL qtotal, zx, qcheck
-  INTEGER i, k
-  !
-  zx = 0.0
-  DO i = 1, klon
-     zx = zx + aire(i)
-  ENDDO
-  qtotal = 0.0
-  DO k = 1, klev
-     DO i = 1, klon
-        qtotal = qtotal + (q(i,k)+ql(i,k)) * aire(i) &
-             *(paprs(i,k)-paprs(i,k+1))/RG
-     ENDDO
-  ENDDO
-  !
-  qcheck = qtotal/zx
-  !
-END FUNCTION qcheck
-
Index: /LMDZ6/trunk/libf/phylmd/qcheck.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/qcheck.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/qcheck.f90	(revision 5268)
@@ -0,0 +1,29 @@
+FUNCTION qcheck(klon,klev,paprs,q,ql,aire)
+  IMPLICIT none
+  !
+  ! Calculer et imprimer l'eau totale. A utiliser pour verifier
+  ! la conservation de l'eau
+  !
+  include "YOMCST.h"
+  INTEGER,INTENT(IN) :: klon,klev
+  REAL,INTENT(IN) :: paprs(klon,klev+1), q(klon,klev), ql(klon,klev)
+  REAL,INTENT(IN) :: aire(klon)
+  REAL qtotal, zx, qcheck
+  INTEGER i, k
+  !
+  zx = 0.0
+  DO i = 1, klon
+     zx = zx + aire(i)
+  ENDDO
+  qtotal = 0.0
+  DO k = 1, klev
+     DO i = 1, klon
+        qtotal = qtotal + (q(i,k)+ql(i,k)) * aire(i) &
+             *(paprs(i,k)-paprs(i,k+1))/RG
+     ENDDO
+  ENDDO
+  !
+  qcheck = qtotal/zx
+  !
+END FUNCTION qcheck
+
Index: DZ6/trunk/libf/phylmd/qsat_seawater.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/qsat_seawater.F90	(revision 5267)
+++ 	(revision )
@@ -1,119 +1,0 @@
-!-------------------------------------------------------------------------------
-!
-!     ######################################
-REAL      FUNCTION QSAT_SEAWATER(PT,PP) 
-!     ######################################
-!
-!!****  *QSATW * - function to compute saturation vapor humidity from
-!!                 temperature
-!!
-!!    PURPOSE
-!!    -------
-!       The purpose of this function is to compute the saturation vapor 
-!     pressure from temperature over saline seawater
-!      
-!
-!!**  METHOD
-!!    ------
-!!       Given temperature T (PT), the saturation vapor pressure es(T)
-!!    (FOES(PT)) is computed by integration of the Clapeyron equation
-!!    from the triple point temperature Tt (XTT) and the saturation vapor 
-!!    pressure of the triple point es(Tt) (XESTT), i.e  
-!!    The reduction due to salinity is compute with the factor 0.98 (reduction of 2%)
-!!     
-!!         es(T)= 0.98*EXP( alphaw - betaw /T - gammaw Log(T) )
-!!  
-!!     with :
-!!       alphaw (XALPW) = LOG(es(Tt))+ betaw/Tt + gammaw Log(Tt) 
-!!       betaw (XBETAW) = Lv(Tt)/Rv + gammaw Tt
-!!       gammaw (XGAMW) = (Cl -Cpv) /Rv
-!!
-!!      Then, the specific humidity at saturation is deduced.
-!!  
-!!
-!!    EXTERNAL
-!!    --------
-!!      NONE
-!!
-!!    IMPLICIT ARGUMENTS
-!!    ------------------
-!!      Module MODD_CST : comtains physical constants
-!!        XALPW   : Constant for saturation vapor pressure function
-!!        XBETAW  : Constant for saturation vapor pressure function
-!!        XGAMW   : Constant for saturation vapor pressure function  
-!!      
-!!    REFERENCE
-!!    ---------
-!!      Book2 of documentation of Meso-NH 
-!!      Zeng, X., Zhao, M., and Dickinson, R. E., 1998 : Intercomparaison of bulk
-!!      aerodynamic algorithm for the computation of sea surface fluxes using
-!!      TOGA COARE and TAO data. Journal of Climate, vol 11, n°10, pp 2628--2644
-!!
-!!
-!!    AUTHOR
-!!    ------
-!!      C. Lebeaupin    * Meteo France *
-!!
-!!    MODIFICATIONS
-!!    -------------
-!!      Original    6/04/2005 
-!-------------------------------------------------------------------------------
-!
-!*       0.    DECLARATIONS
-!              ------------
-!
-USE MODD_CSTS
-USE dimphy
-USE indice_sol_mod
-!
-IMPLICIT NONE
-!
-!*       0.1   Declarations of arguments and results
-!
-!
-
-REAL, DIMENSION(klon), INTENT(IN)                :: PT     ! Temperature
-                                                        ! (Kelvin)
-REAL, DIMENSION(klon), INTENT(IN)                :: PP     ! Pressure
-                                                        ! (Pa)
-REAL, DIMENSION(SIZE(PT))                        :: PQSAT  ! saturation vapor 
-                                                        ! specific humidity
-                                                        ! with respect to
-                                                        ! water (kg/kg)
-
-!
-!*       0.2   Declarations of local variables
-!
-REAL, DIMENSION(SIZE(PT))                   :: ZFOES  ! saturation vapor 
-                                                        ! pressure
-                                                        ! (Pascal) 
-!
-REAL, DIMENSION(SIZE(PT))                   :: ZWORK1
-REAL                                        :: ZWORK2
-!REAL(KIND=JPRB) :: ZHOOK_HANDLE
-!-------------------------------------------------------------------------------
-!
-!IF (LHOOK) CALL DR_HOOK('MODE_THERMOS:QSATSEAW_1D',0,ZHOOK_HANDLE)
-!
-!ZFOES  = 1 !PSAT(PT(:))
-!ZFOES  = 0.98*ZFOES
-!ZFOES(:) = ZFOES(:)*1013.25E+02             !convert from atm to Pa
-ZFOES = 0.98*EXP( XALPW - XBETAW/PT - XGAMW*LOG(PT)  )
-! vapor pressure reduction of 2% over saline seawater could have a significant 
-! impact on the computation of surface latent heat flux under strong wind 
-! conditions (Zeng et al, 1998). 
-!
-ZWORK1 = ZFOES/PP
-ZWORK2    = XRD/XRV
-!
-!*       2.    COMPUTE SATURATION HUMIDITY
-!              ---------------------------
-!
-PQSAT = ZWORK2*ZWORK1 / (1.+(ZWORK2-1.)*ZWORK1)
-!
-!IF (LHOOK) CALL DR_HOOK('MODE_THERMOS:QSATSEAW_1D',1,ZHOOK_HANDLE)
-!-------------------------------------------------------------------------------
-!
-END FUNCTION QSAT_SEAWATER
-!
-!-------------------------------------------------------------------------------
Index: /LMDZ6/trunk/libf/phylmd/qsat_seawater.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/qsat_seawater.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/qsat_seawater.f90	(revision 5268)
@@ -0,0 +1,119 @@
+!-------------------------------------------------------------------------------
+!
+!     ######################################
+REAL      FUNCTION QSAT_SEAWATER(PT,PP) 
+!     ######################################
+!
+!!****  *QSATW * - function to compute saturation vapor humidity from
+!!                 temperature
+!!
+!!    PURPOSE
+!!    -------
+!       The purpose of this function is to compute the saturation vapor 
+!     pressure from temperature over saline seawater
+!      
+!
+!!**  METHOD
+!!    ------
+!!       Given temperature T (PT), the saturation vapor pressure es(T)
+!!    (FOES(PT)) is computed by integration of the Clapeyron equation
+!!    from the triple point temperature Tt (XTT) and the saturation vapor 
+!!    pressure of the triple point es(Tt) (XESTT), i.e  
+!!    The reduction due to salinity is compute with the factor 0.98 (reduction of 2%)
+!!     
+!!         es(T)= 0.98*EXP( alphaw - betaw /T - gammaw Log(T) )
+!!  
+!!     with :
+!!       alphaw (XALPW) = LOG(es(Tt))+ betaw/Tt + gammaw Log(Tt) 
+!!       betaw (XBETAW) = Lv(Tt)/Rv + gammaw Tt
+!!       gammaw (XGAMW) = (Cl -Cpv) /Rv
+!!
+!!      Then, the specific humidity at saturation is deduced.
+!!  
+!!
+!!    EXTERNAL
+!!    --------
+!!      NONE
+!!
+!!    IMPLICIT ARGUMENTS
+!!    ------------------
+!!      Module MODD_CST : comtains physical constants
+!!        XALPW   : Constant for saturation vapor pressure function
+!!        XBETAW  : Constant for saturation vapor pressure function
+!!        XGAMW   : Constant for saturation vapor pressure function  
+!!      
+!!    REFERENCE
+!!    ---------
+!!      Book2 of documentation of Meso-NH 
+!!      Zeng, X., Zhao, M., and Dickinson, R. E., 1998 : Intercomparaison of bulk
+!!      aerodynamic algorithm for the computation of sea surface fluxes using
+!!      TOGA COARE and TAO data. Journal of Climate, vol 11, n°10, pp 2628--2644
+!!
+!!
+!!    AUTHOR
+!!    ------
+!!      C. Lebeaupin    * Meteo France *
+!!
+!!    MODIFICATIONS
+!!    -------------
+!!      Original    6/04/2005 
+!-------------------------------------------------------------------------------
+!
+!*       0.    DECLARATIONS
+!              ------------
+!
+USE MODD_CSTS
+USE dimphy
+USE indice_sol_mod
+!
+IMPLICIT NONE
+!
+!*       0.1   Declarations of arguments and results
+!
+!
+
+REAL, DIMENSION(klon), INTENT(IN)                :: PT     ! Temperature
+                                                        ! (Kelvin)
+REAL, DIMENSION(klon), INTENT(IN)                :: PP     ! Pressure
+                                                        ! (Pa)
+REAL, DIMENSION(SIZE(PT))                        :: PQSAT  ! saturation vapor 
+                                                        ! specific humidity
+                                                        ! with respect to
+                                                        ! water (kg/kg)
+
+!
+!*       0.2   Declarations of local variables
+!
+REAL, DIMENSION(SIZE(PT))                   :: ZFOES  ! saturation vapor 
+                                                        ! pressure
+                                                        ! (Pascal) 
+!
+REAL, DIMENSION(SIZE(PT))                   :: ZWORK1
+REAL                                        :: ZWORK2
+!REAL(KIND=JPRB) :: ZHOOK_HANDLE
+!-------------------------------------------------------------------------------
+!
+!IF (LHOOK) CALL DR_HOOK('MODE_THERMOS:QSATSEAW_1D',0,ZHOOK_HANDLE)
+!
+!ZFOES  = 1 !PSAT(PT(:))
+!ZFOES  = 0.98*ZFOES
+!ZFOES(:) = ZFOES(:)*1013.25E+02             !convert from atm to Pa
+ZFOES = 0.98*EXP( XALPW - XBETAW/PT - XGAMW*LOG(PT)  )
+! vapor pressure reduction of 2% over saline seawater could have a significant 
+! impact on the computation of surface latent heat flux under strong wind 
+! conditions (Zeng et al, 1998). 
+!
+ZWORK1 = ZFOES/PP
+ZWORK2    = XRD/XRV
+!
+!*       2.    COMPUTE SATURATION HUMIDITY
+!              ---------------------------
+!
+PQSAT = ZWORK2*ZWORK1 / (1.+(ZWORK2-1.)*ZWORK1)
+!
+!IF (LHOOK) CALL DR_HOOK('MODE_THERMOS:QSATSEAW_1D',1,ZHOOK_HANDLE)
+!-------------------------------------------------------------------------------
+!
+END FUNCTION QSAT_SEAWATER
+!
+!-------------------------------------------------------------------------------
Index: DZ6/trunk/libf/phylmd/qsat_seawater2.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/qsat_seawater2.F90	(revision 5267)
+++ 	(revision )
@@ -1,104 +1,0 @@
-!-------------------------------------------------------------------------------
-!
-!     ######################################
-REAL      FUNCTION QSAT_SEAWATER2(PT,PP,PSSS) 
-!     ######################################
-!
-!!****  *QSATW * - function to compute saturation vapor humidity from
-!!                 temperature
-!!
-!!    PURPOSE
-!!    -------
-!       The purpose of this function is to compute the saturation vapor 
-!     pressure from temperature over saline seawater
-!      
-!
-!!**  METHOD
-!!    ------
-!!       Given temperature T (PT) and salinity S (PSSS), the saturation vapor 
-!!    pressure es(T,S) (FOES(PT,PSSS)) is computed following Weiss and Price
-!!    (1980).
-!!
-!!      Then, the specific humidity at saturation is deduced.
-!!  
-!!
-!!    EXTERNAL
-!!    --------
-!!      NONE
-!!
-!!    IMPLICIT ARGUMENTS
-!!    ------------------
-!!      Module MODD_CST : contains physical constants
-!!      
-!!    REFERENCE
-!!    ---------
-!!      Weiss, R.F., and Price, B.A., 1980 : Nitrous oxide solubility in water
-!!      and seawater. Marine Chemistry, n°8, pp 347-359.
-!!
-!!
-!!    AUTHOR
-!!    ------
-!!      S. Belamari     * Meteo France *
-!!
-!!    MODIFICATIONS
-!!    -------------
-!!      Original    19/03/2014 
-!-------------------------------------------------------------------------------
-!
-!*       0.    DECLARATIONS
-!              ------------
-!
-USE MODD_CSTS, ONLY : XRD, XRV
-USE dimphy
-USE indice_sol_mod
-!
-IMPLICIT NONE
-!
-!*       0.1   Declarations of arguments and results
-!
-!
-REAL, DIMENSION(klon), INTENT(IN)                :: PT     ! Temperature
-                                                        ! (Kelvin)
-REAL, DIMENSION(klon), INTENT(IN)                :: PP     ! Pressure
-                                                        ! (Pascal)
-REAL, DIMENSION(klon), INTENT(IN)                :: PSSS   ! Salinity
-                                                        ! (g/kg)
-REAL, DIMENSION(SIZE(PT))                   :: PQSATA  ! saturation vapor
-                                                        ! specific humidity
-                                                        ! with respect to
-                                                        ! water (kg/kg)
-!
-!*       0.2   Declarations of local variables
-!
-REAL, DIMENSION(SIZE(PT))                   :: ZFOES  ! saturation vapor
-                                                        ! pressure
-                                                        ! (Pascal)
-!
-REAL, DIMENSION(SIZE(PT))                   :: ZWORK1
-REAL                                        :: ZWORK2
-!REAL(KIND=JPRB) :: ZHOOK_HANDLE
-!-------------------------------------------------------------------------------
-!
-!IF (LHOOK) CALL DR_HOOK('MODE_THERMOS:QSATSEAW2_1D',0,ZHOOK_HANDLE)
-!
-!*       1.    COMPUTE SATURATION VAPOR PRESSURE
-!              ---------------------------------
-!
-ZFOES(:) = EXP( 24.4543 -67.4509*(100.0/PT(:)) -4.8489*LOG(PT(:)/100.0)   &
-                -5.44E-04*(PSSS(:)/1.00472) ) !see Sharqawy et al (2010) Eq32 p368
-ZFOES(:) = ZFOES(:)*1013.25E+02             !convert from atm to Pa
-!
-ZWORK1(:) = ZFOES(:)/PP(:)
-ZWORK2    = XRD/XRV
-!
-!*       2.    COMPUTE SATURATION SPECIFIC HUMIDITY
-!              ------------------------------------
-!
-PQSATA(:) = ZWORK2*ZWORK1(:) / (1.0+(ZWORK2-1.0)*ZWORK1(:))
-!
-!IF (LHOOK) CALL DR_HOOK('MODE_THERMOS:QSATSEAW2_1D',1,ZHOOK_HANDLE)
-!-------------------------------------------------------------------------------
-!
-END FUNCTION QSAT_SEAWATER2
-!
-!-------------------------------------------------------------------------------
Index: /LMDZ6/trunk/libf/phylmd/qsat_seawater2.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/qsat_seawater2.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/qsat_seawater2.f90	(revision 5268)
@@ -0,0 +1,104 @@
+!-------------------------------------------------------------------------------
+!
+!     ######################################
+REAL      FUNCTION QSAT_SEAWATER2(PT,PP,PSSS) 
+!     ######################################
+!
+!!****  *QSATW * - function to compute saturation vapor humidity from
+!!                 temperature
+!!
+!!    PURPOSE
+!!    -------
+!       The purpose of this function is to compute the saturation vapor 
+!     pressure from temperature over saline seawater
+!      
+!
+!!**  METHOD
+!!    ------
+!!       Given temperature T (PT) and salinity S (PSSS), the saturation vapor 
+!!    pressure es(T,S) (FOES(PT,PSSS)) is computed following Weiss and Price
+!!    (1980).
+!!
+!!      Then, the specific humidity at saturation is deduced.
+!!  
+!!
+!!    EXTERNAL
+!!    --------
+!!      NONE
+!!
+!!    IMPLICIT ARGUMENTS
+!!    ------------------
+!!      Module MODD_CST : contains physical constants
+!!      
+!!    REFERENCE
+!!    ---------
+!!      Weiss, R.F., and Price, B.A., 1980 : Nitrous oxide solubility in water
+!!      and seawater. Marine Chemistry, n°8, pp 347-359.
+!!
+!!
+!!    AUTHOR
+!!    ------
+!!      S. Belamari     * Meteo France *
+!!
+!!    MODIFICATIONS
+!!    -------------
+!!      Original    19/03/2014 
+!-------------------------------------------------------------------------------
+!
+!*       0.    DECLARATIONS
+!              ------------
+!
+USE MODD_CSTS, ONLY : XRD, XRV
+USE dimphy
+USE indice_sol_mod
+!
+IMPLICIT NONE
+!
+!*       0.1   Declarations of arguments and results
+!
+!
+REAL, DIMENSION(klon), INTENT(IN)                :: PT     ! Temperature
+                                                        ! (Kelvin)
+REAL, DIMENSION(klon), INTENT(IN)                :: PP     ! Pressure
+                                                        ! (Pascal)
+REAL, DIMENSION(klon), INTENT(IN)                :: PSSS   ! Salinity
+                                                        ! (g/kg)
+REAL, DIMENSION(SIZE(PT))                   :: PQSATA  ! saturation vapor
+                                                        ! specific humidity
+                                                        ! with respect to
+                                                        ! water (kg/kg)
+!
+!*       0.2   Declarations of local variables
+!
+REAL, DIMENSION(SIZE(PT))                   :: ZFOES  ! saturation vapor
+                                                        ! pressure
+                                                        ! (Pascal)
+!
+REAL, DIMENSION(SIZE(PT))                   :: ZWORK1
+REAL                                        :: ZWORK2
+!REAL(KIND=JPRB) :: ZHOOK_HANDLE
+!-------------------------------------------------------------------------------
+!
+!IF (LHOOK) CALL DR_HOOK('MODE_THERMOS:QSATSEAW2_1D',0,ZHOOK_HANDLE)
+!
+!*       1.    COMPUTE SATURATION VAPOR PRESSURE
+!              ---------------------------------
+!
+ZFOES(:) = EXP( 24.4543 -67.4509*(100.0/PT(:)) -4.8489*LOG(PT(:)/100.0)   &
+                -5.44E-04*(PSSS(:)/1.00472) ) !see Sharqawy et al (2010) Eq32 p368
+ZFOES(:) = ZFOES(:)*1013.25E+02             !convert from atm to Pa
+!
+ZWORK1(:) = ZFOES(:)/PP(:)
+ZWORK2    = XRD/XRV
+!
+!*       2.    COMPUTE SATURATION SPECIFIC HUMIDITY
+!              ------------------------------------
+!
+PQSATA(:) = ZWORK2*ZWORK1(:) / (1.0+(ZWORK2-1.0)*ZWORK1(:))
+!
+!IF (LHOOK) CALL DR_HOOK('MODE_THERMOS:QSATSEAW2_1D',1,ZHOOK_HANDLE)
+!-------------------------------------------------------------------------------
+!
+END FUNCTION QSAT_SEAWATER2
+!
+!-------------------------------------------------------------------------------
Index: DZ6/trunk/libf/phylmd/qsatseaw_1D.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/qsatseaw_1D.F90	(revision 5267)
+++ 	(revision )
@@ -1,113 +1,0 @@
-!-------------------------------------------------------------------------------
-!
-!     ######################################
-REAL       FUNCTION QSATSEAW_1D(PT,PP) 
-!     ######################################
-!
-!!****  *QSATW * - function to compute saturation vapor humidity from
-!!                 temperature
-!!
-!!    PURPOSE
-!!    -------
-!       The purpose of this function is to compute the saturation vapor 
-!     pressure from temperature over saline seawater
-!      
-!
-!!**  METHOD
-!!    ------
-!!       Given temperature T (PT), the saturation vapor pressure es(T)
-!!    (FOES(PT)) is computed by integration of the Clapeyron equation
-!!    from the triple point temperature Tt (XTT) and the saturation vapor 
-!!    pressure of the triple point es(Tt) (XESTT), i.e  
-!!    The reduction due to salinity is compute with the factor 0.98 (reduction of 2%)
-!!     
-!!         es(T)= 0.98*EXP( alphaw - betaw /T - gammaw Log(T) )
-!!  
-!!     with :
-!!       alphaw (XALPW) = LOG(es(Tt))+ betaw/Tt + gammaw Log(Tt) 
-!!       betaw (XBETAW) = Lv(Tt)/Rv + gammaw Tt
-!!       gammaw (XGAMW) = (Cl -Cpv) /Rv
-!!
-!!      Then, the specific humidity at saturation is deduced.
-!!  
-!!
-!!    EXTERNAL
-!!    --------
-!!      NONE
-!!
-!!    IMPLICIT ARGUMENTS
-!!    ------------------
-!!      Module MODD_CST : comtains physical constants
-!!        XALPW   : Constant for saturation vapor pressure function
-!!        XBETAW  : Constant for saturation vapor pressure function
-!!        XGAMW   : Constant for saturation vapor pressure function  
-!!      
-!!    REFERENCE
-!!    ---------
-!!      Book2 of documentation of Meso-NH 
-!!      Zeng, X., Zhao, M., and Dickinson, R. E., 1998 : Intercomparaison of bulk
-!!      aerodynamic algorithm for the computation of sea surface fluxes using
-!!      TOGA COARE and TAO data. Journal of Climate, vol 11, n�10, pp 2628--2644
-!!
-!!
-!!    AUTHOR
-!!    ------
-!!      C. Lebeaupin    * Meteo France *
-!!
-!!    MODIFICATIONS
-!!    -------------
-!!      Original    6/04/2005 
-!-------------------------------------------------------------------------------
-!
-!*       0.    DECLARATIONS
-!              ------------
-!
-USE MODD_CSTS
-USE dimphy
-USE indice_sol_mod
-
-IMPLICIT NONE
-
-!*       0.1   Declarations of arguments and results
-!
-!
-REAL, DIMENSION(klon), INTENT(IN)                :: PT     ! Temperature
-                                                        ! (Kelvin)
-REAL, DIMENSION(klon), INTENT(IN)                :: PP     ! Pressure
-                                                        ! (Pa)
-REAL, DIMENSION(SIZE(PT))                        :: PQSAT  ! saturation vapor 
-                                                        ! specific humidity
-                                                        ! with respect to
-                                                        ! water (kg/kg)
-!
-!*       0.2   Declarations of local variables
-!
-REAL, DIMENSION(SIZE(PT))                   :: ZFOES  ! saturation vapor 
-                                                        ! pressure
-                                                        ! (Pascal) 
-!
-INTEGER                         :: JJ   ! loop index
-!REAL(KIND=JPRB) :: ZHOOK_HANDLE
-!-------------------------------------------------------------------------------
-!
-!IF (LHOOK) CALL DR_HOOK('MODE_THERMOS:QSATSEAW_1D',0,ZHOOK_HANDLE)
-!DO JJ = 1, SIZE(PT)
-!*       1.    COMPUTE SATURATION VAPOR PRESSURE
-!              ---------------------------------
-!
-ZFOES = 0.98*EXP( XALPW - XBETAW/PT - XGAMW*LOG(PT)  )
-! vapor pressure reduction of 2% over saline seawater could have a significant 
-! impact on the computation of surface latent heat flux under strong wind 
-! conditions (Zeng et al, 1998). 
-!
-!*       2.    COMPUTE SATURATION HUMIDITY
-!              ---------------------------
-!
-PQSAT = XRD/XRV*ZFOES/PP /(1.+(XRD/XRV-1.)*ZFOES/PP)  
-!
-!ENDDO
-!IF (LHOOK) CALL DR_HOOK('MODE_THERMOS:QSATSEAW_1D',1,ZHOOK_HANDLE)
-!-------------------------------------------------------------------------------
-!
-END FUNCTION QSATSEAW_1D
-!------------------------------------
Index: /LMDZ6/trunk/libf/phylmd/qsatseaw_1D.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/qsatseaw_1D.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/qsatseaw_1D.f90	(revision 5268)
@@ -0,0 +1,113 @@
+!-------------------------------------------------------------------------------
+!
+!     ######################################
+REAL       FUNCTION QSATSEAW_1D(PT,PP) 
+!     ######################################
+!
+!!****  *QSATW * - function to compute saturation vapor humidity from
+!!                 temperature
+!!
+!!    PURPOSE
+!!    -------
+!       The purpose of this function is to compute the saturation vapor 
+!     pressure from temperature over saline seawater
+!      
+!
+!!**  METHOD
+!!    ------
+!!       Given temperature T (PT), the saturation vapor pressure es(T)
+!!    (FOES(PT)) is computed by integration of the Clapeyron equation
+!!    from the triple point temperature Tt (XTT) and the saturation vapor 
+!!    pressure of the triple point es(Tt) (XESTT), i.e  
+!!    The reduction due to salinity is compute with the factor 0.98 (reduction of 2%)
+!!     
+!!         es(T)= 0.98*EXP( alphaw - betaw /T - gammaw Log(T) )
+!!  
+!!     with :
+!!       alphaw (XALPW) = LOG(es(Tt))+ betaw/Tt + gammaw Log(Tt) 
+!!       betaw (XBETAW) = Lv(Tt)/Rv + gammaw Tt
+!!       gammaw (XGAMW) = (Cl -Cpv) /Rv
+!!
+!!      Then, the specific humidity at saturation is deduced.
+!!  
+!!
+!!    EXTERNAL
+!!    --------
+!!      NONE
+!!
+!!    IMPLICIT ARGUMENTS
+!!    ------------------
+!!      Module MODD_CST : comtains physical constants
+!!        XALPW   : Constant for saturation vapor pressure function
+!!        XBETAW  : Constant for saturation vapor pressure function
+!!        XGAMW   : Constant for saturation vapor pressure function  
+!!      
+!!    REFERENCE
+!!    ---------
+!!      Book2 of documentation of Meso-NH 
+!!      Zeng, X., Zhao, M., and Dickinson, R. E., 1998 : Intercomparaison of bulk
+!!      aerodynamic algorithm for the computation of sea surface fluxes using
+!!      TOGA COARE and TAO data. Journal of Climate, vol 11, n�10, pp 2628--2644
+!!
+!!
+!!    AUTHOR
+!!    ------
+!!      C. Lebeaupin    * Meteo France *
+!!
+!!    MODIFICATIONS
+!!    -------------
+!!      Original    6/04/2005 
+!-------------------------------------------------------------------------------
+!
+!*       0.    DECLARATIONS
+!              ------------
+!
+USE MODD_CSTS
+USE dimphy
+USE indice_sol_mod
+
+IMPLICIT NONE
+
+!*       0.1   Declarations of arguments and results
+!
+!
+REAL, DIMENSION(klon), INTENT(IN)                :: PT     ! Temperature
+                                                        ! (Kelvin)
+REAL, DIMENSION(klon), INTENT(IN)                :: PP     ! Pressure
+                                                        ! (Pa)
+REAL, DIMENSION(SIZE(PT))                        :: PQSAT  ! saturation vapor 
+                                                        ! specific humidity
+                                                        ! with respect to
+                                                        ! water (kg/kg)
+!
+!*       0.2   Declarations of local variables
+!
+REAL, DIMENSION(SIZE(PT))                   :: ZFOES  ! saturation vapor 
+                                                        ! pressure
+                                                        ! (Pascal) 
+!
+INTEGER                         :: JJ   ! loop index
+!REAL(KIND=JPRB) :: ZHOOK_HANDLE
+!-------------------------------------------------------------------------------
+!
+!IF (LHOOK) CALL DR_HOOK('MODE_THERMOS:QSATSEAW_1D',0,ZHOOK_HANDLE)
+!DO JJ = 1, SIZE(PT)
+!*       1.    COMPUTE SATURATION VAPOR PRESSURE
+!              ---------------------------------
+!
+ZFOES = 0.98*EXP( XALPW - XBETAW/PT - XGAMW*LOG(PT)  )
+! vapor pressure reduction of 2% over saline seawater could have a significant 
+! impact on the computation of surface latent heat flux under strong wind 
+! conditions (Zeng et al, 1998). 
+!
+!*       2.    COMPUTE SATURATION HUMIDITY
+!              ---------------------------
+!
+PQSAT = XRD/XRV*ZFOES/PP /(1.+(XRD/XRV-1.)*ZFOES/PP)  
+!
+!ENDDO
+!IF (LHOOK) CALL DR_HOOK('MODE_THERMOS:QSATSEAW_1D',1,ZHOOK_HANDLE)
+!-------------------------------------------------------------------------------
+!
+END FUNCTION QSATSEAW_1D
+!------------------------------------
Index: DZ6/trunk/libf/phylmd/radiation_AR4.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/radiation_AR4.F90	(revision 5267)
+++ 	(revision )
@@ -1,5713 +1,0 @@
-! IM ctes ds clesphys.h   SUBROUTINE SW(PSCT, RCO2, PRMU0, PFRAC,
-SUBROUTINE sw_lmdar4(psct, prmu0, pfrac, ppmb, pdp, ppsol, palbd, palbp, &
-    ptave, pwv, pqs, pozon, paer, pcldsw, ptau, pomega, pcg, pheat, pheat0, &
-    palbpla, ptopsw, psolsw, ptopsw0, psolsw0, zfsup, zfsdn, zfsup0, zfsdn0, &
-    tauae, pizae, cgae, ptaua, pomegaa, ptopswad, psolswad, ptopswai, &
-    psolswai, ok_ade, ok_aie)
-  USE dimphy
-  USE print_control_mod, ONLY: lunout
-  IMPLICIT NONE
-
-  include "YOMCST.h"
-
-  ! ------------------------------------------------------------------
-
-  ! PURPOSE.
-  ! --------
-
-  ! THIS ROUTINE COMPUTES THE SHORTWAVE RADIATION FLUXES IN TWO
-  ! SPECTRAL INTERVALS FOLLOWING FOUQUART AND BONNEL (1980).
-
-  ! METHOD.
-  ! -------
-
-  ! 1. COMPUTES ABSORBER AMOUNTS                 (SWU)
-  ! 2. COMPUTES FLUXES IN 1ST SPECTRAL INTERVAL  (SW1S)
-  ! 3. COMPUTES FLUXES IN 2ND SPECTRAL INTERVAL  (SW2S)
-
-  ! REFERENCE.
-  ! ----------
-
-  ! SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT
-  ! DOCUMENTATION, AND FOUQUART AND BONNEL (1980)
-
-  ! AUTHOR.
-  ! -------
-  ! JEAN-JACQUES MORCRETTE  *ECMWF*
-
-  ! MODIFICATIONS.
-  ! --------------
-  ! ORIGINAL : 89-07-14
-  ! 95-01-01   J.-J. MORCRETTE  Direct/Diffuse Albedo
-  ! 03-11-27   J. QUAAS Introduce aerosol forcings (based on BOUCHER)
-  ! ------------------------------------------------------------------
-
-  ! * ARGUMENTS:
-
-  REAL (KIND=8) psct ! constante solaire (valeur conseillee: 1370)
-  ! IM ctes ds clesphys.h   REAL(KIND=8) RCO2  ! concentration CO2 (IPCC:
-  ! 353.E-06*44.011/28.97)
-  include "clesphys.h"
-
-  REAL (KIND=8) ppsol(kdlon) ! SURFACE PRESSURE (PA)
-  REAL (KIND=8) pdp(kdlon, kflev) ! LAYER THICKNESS (PA)
-  REAL (KIND=8) ppmb(kdlon, kflev+1) ! HALF-LEVEL PRESSURE (MB)
-
-  REAL (KIND=8) prmu0(kdlon) ! COSINE OF ZENITHAL ANGLE
-  REAL (KIND=8) pfrac(kdlon) ! fraction de la journee
-
-  REAL (KIND=8) ptave(kdlon, kflev) ! LAYER TEMPERATURE (K)
-  REAL (KIND=8) pwv(kdlon, kflev) ! SPECIFIC HUMIDITY (KG/KG)
-  REAL (KIND=8) pqs(kdlon, kflev) ! SATURATED WATER VAPOUR (KG/KG)
-  REAL (KIND=8) pozon(kdlon, kflev) ! OZONE CONCENTRATION (KG/KG)
-  REAL (KIND=8) paer(kdlon, kflev, 5) ! AEROSOLS' OPTICAL THICKNESS
-
-  REAL (KIND=8) palbd(kdlon, 2) ! albedo du sol (lumiere diffuse)
-  REAL (KIND=8) palbp(kdlon, 2) ! albedo du sol (lumiere parallele)
-
-  REAL (KIND=8) pcldsw(kdlon, kflev) ! CLOUD FRACTION
-  REAL (KIND=8) ptau(kdlon, 2, kflev) ! CLOUD OPTICAL THICKNESS
-  REAL (KIND=8) pcg(kdlon, 2, kflev) ! ASYMETRY FACTOR
-  REAL (KIND=8) pomega(kdlon, 2, kflev) ! SINGLE SCATTERING ALBEDO
-
-  REAL (KIND=8) pheat(kdlon, kflev) ! SHORTWAVE HEATING (K/DAY)
-  REAL (KIND=8) pheat0(kdlon, kflev) ! SHORTWAVE HEATING (K/DAY) clear-sky
-  REAL (KIND=8) palbpla(kdlon) ! PLANETARY ALBEDO
-  REAL (KIND=8) ptopsw(kdlon) ! SHORTWAVE FLUX AT T.O.A.
-  REAL (KIND=8) psolsw(kdlon) ! SHORTWAVE FLUX AT SURFACE
-  REAL (KIND=8) ptopsw0(kdlon) ! SHORTWAVE FLUX AT T.O.A. (CLEAR-SKY)
-  REAL (KIND=8) psolsw0(kdlon) ! SHORTWAVE FLUX AT SURFACE (CLEAR-SKY)
-
-  ! * LOCAL VARIABLES:
-
-  REAL, PARAMETER :: dobson_u = 2.1415E-05 ! Dobson unit, in kg m-2
-
-  REAL (KIND=8) zoz(kdlon, kflev)
-  ! column-density of ozone in layer, in kilo-Dobsons
-
-  REAL (KIND=8) zaki(kdlon, 2)
-  REAL (KIND=8) zcld(kdlon, kflev)
-  REAL (KIND=8) zclear(kdlon)
-  REAL (KIND=8) zdsig(kdlon, kflev)
-  REAL (KIND=8) zfact(kdlon)
-  REAL (KIND=8) zfd(kdlon, kflev+1)
-  REAL (KIND=8) zfdown(kdlon, kflev+1)
-  REAL (KIND=8) zfu(kdlon, kflev+1)
-  REAL (KIND=8) zfup(kdlon, kflev+1)
-  REAL (KIND=8) zrmu(kdlon)
-  REAL (KIND=8) zsec(kdlon)
-  REAL (KIND=8) zud(kdlon, 5, kflev+1)
-  REAL (KIND=8) zcldsw0(kdlon, kflev)
-
-  REAL (KIND=8) zfsup(kdlon, kflev+1)
-  REAL (KIND=8) zfsdn(kdlon, kflev+1)
-  REAL (KIND=8) zfsup0(kdlon, kflev+1)
-  REAL (KIND=8) zfsdn0(kdlon, kflev+1)
-
-  INTEGER inu, jl, jk, i, k, kpl1
-
-  INTEGER swpas ! Every swpas steps, sw is calculated
-  PARAMETER (swpas=1)
-
-  INTEGER itapsw
-  LOGICAL appel1er
-  DATA itapsw/0/
-  DATA appel1er/.TRUE./
-  SAVE itapsw, appel1er
-  !$OMP THREADPRIVATE(appel1er)
-  !$OMP THREADPRIVATE(itapsw)
-  ! jq-Introduced for aerosol forcings
-  REAL (KIND=8) flag_aer
-  LOGICAL ok_ade, ok_aie ! use aerosol forcings or not?
-  REAL (KIND=8) tauae(kdlon, kflev, 2) ! aerosol optical properties
-  REAL (KIND=8) pizae(kdlon, kflev, 2) ! (see aeropt.F)
-  REAL (KIND=8) cgae(kdlon, kflev, 2) ! -"-
-  REAL (KIND=8) ptaua(kdlon, 2, kflev) ! CLOUD OPTICAL THICKNESS (pre-industrial value)
-  REAL (KIND=8) pomegaa(kdlon, 2, kflev) ! SINGLE SCATTERING ALBEDO
-  REAL (KIND=8) ptopswad(kdlon) ! SHORTWAVE FLUX AT T.O.A.(+AEROSOL DIR)
-  REAL (KIND=8) psolswad(kdlon) ! SHORTWAVE FLUX AT SURFACE(+AEROSOL DIR)
-  REAL (KIND=8) ptopswai(kdlon) ! SHORTWAVE FLUX AT T.O.A.(+AEROSOL IND)
-  REAL (KIND=8) psolswai(kdlon) ! SHORTWAVE FLUX AT SURFACE(+AEROSOL IND)
-  ! jq - Fluxes including aerosol effects
-  REAL (KIND=8), ALLOCATABLE, SAVE :: zfsupad(:, :)
-  !$OMP THREADPRIVATE(ZFSUPAD)
-  REAL (KIND=8), ALLOCATABLE, SAVE :: zfsdnad(:, :)
-  !$OMP THREADPRIVATE(ZFSDNAD)
-  REAL (KIND=8), ALLOCATABLE, SAVE :: zfsupai(:, :)
-  !$OMP THREADPRIVATE(ZFSUPAI)
-  REAL (KIND=8), ALLOCATABLE, SAVE :: zfsdnai(:, :)
-  !$OMP THREADPRIVATE(ZFSDNAI)
-  LOGICAL initialized
-  ! ym      SAVE ZFSUPAD, ZFSDNAD, ZFSUPAI, ZFSDNAI ! aerosol fluxes
-  ! rv
-  SAVE flag_aer
-  !$OMP THREADPRIVATE(flag_aer)
-  DATA initialized/.FALSE./
-  SAVE initialized
-  !$OMP THREADPRIVATE(initialized)
-  ! jq-end
-  REAL tmp_
-
-  IF (.NOT. initialized) THEN
-    flag_aer = 0.
-    initialized = .TRUE.
-    ALLOCATE (zfsupad(kdlon,kflev+1))
-    ALLOCATE (zfsdnad(kdlon,kflev+1))
-    ALLOCATE (zfsupai(kdlon,kflev+1))
-    ALLOCATE (zfsdnai(kdlon,kflev+1))
-
-    zfsupad(:, :) = 0.
-    zfsdnad(:, :) = 0.
-    zfsupai(:, :) = 0.
-    zfsdnai(:, :) = 0.
-  END IF
-
-  IF (appel1er) THEN
-    WRITE (lunout, *) 'SW calling frequency : ', swpas
-    WRITE (lunout, *) '   In general, it should be 1'
-    appel1er = .FALSE.
-  END IF
-  ! ------------------------------------------------------------------
-  IF (mod(itapsw,swpas)==0) THEN
-
-    tmp_ = 1./(dobson_u*1E3*rg)
-    ! cdir collapse
-    DO jk = 1, kflev
-      DO jl = 1, kdlon
-        zcldsw0(jl, jk) = 0.0
-        zoz(jl, jk) = pozon(jl, jk)*tmp_*pdp(jl, jk)
-      END DO
-    END DO
-
-
-    ! clear-sky:
-    ! IM ctes ds clesphys.h  CALL SWU(PSCT,RCO2,ZCLDSW0,PPMB,PPSOL,
-    CALL swu_lmdar4(psct, zcldsw0, ppmb, ppsol, prmu0, pfrac, ptave, pwv, &
-      zaki, zcld, zclear, zdsig, zfact, zrmu, zsec, zud)
-    inu = 1
-    CALL sw1s_lmdar4(inu, paer, flag_aer, tauae, pizae, cgae, palbd, palbp, &
-      pcg, zcld, zclear, zcldsw0, zdsig, pomega, zoz, zrmu, zsec, ptau, zud, &
-      zfd, zfu)
-    inu = 2
-    CALL sw2s_lmdar4(inu, paer, flag_aer, tauae, pizae, cgae, zaki, palbd, &
-      palbp, pcg, zcld, zclear, zcldsw0, zdsig, pomega, zoz, zrmu, zsec, &
-      ptau, zud, pwv, pqs, zfdown, zfup)
-    DO jk = 1, kflev + 1
-      DO jl = 1, kdlon
-        zfsup0(jl, jk) = (zfup(jl,jk)+zfu(jl,jk))*zfact(jl)
-        zfsdn0(jl, jk) = (zfdown(jl,jk)+zfd(jl,jk))*zfact(jl)
-      END DO
-    END DO
-
-    flag_aer = 0.0
-    CALL swu_lmdar4(psct, pcldsw, ppmb, ppsol, prmu0, pfrac, ptave, pwv, &
-      zaki, zcld, zclear, zdsig, zfact, zrmu, zsec, zud)
-    inu = 1
-    CALL sw1s_lmdar4(inu, paer, flag_aer, tauae, pizae, cgae, palbd, palbp, &
-      pcg, zcld, zclear, pcldsw, zdsig, pomega, zoz, zrmu, zsec, ptau, zud, &
-      zfd, zfu)
-    inu = 2
-    CALL sw2s_lmdar4(inu, paer, flag_aer, tauae, pizae, cgae, zaki, palbd, &
-      palbp, pcg, zcld, zclear, pcldsw, zdsig, pomega, zoz, zrmu, zsec, ptau, &
-      zud, pwv, pqs, zfdown, zfup)
-
-    ! cloudy-sky:
-
-    DO jk = 1, kflev + 1
-      DO jl = 1, kdlon
-        zfsup(jl, jk) = (zfup(jl,jk)+zfu(jl,jk))*zfact(jl)
-        zfsdn(jl, jk) = (zfdown(jl,jk)+zfd(jl,jk))*zfact(jl)
-      END DO
-    END DO
-
-
-    IF (ok_ade) THEN
-
-      ! cloudy-sky + aerosol dir OB
-      flag_aer = 1.0
-      CALL swu_lmdar4(psct, pcldsw, ppmb, ppsol, prmu0, pfrac, ptave, pwv, &
-        zaki, zcld, zclear, zdsig, zfact, zrmu, zsec, zud)
-      inu = 1
-      CALL sw1s_lmdar4(inu, paer, flag_aer, tauae, pizae, cgae, palbd, palbp, &
-        pcg, zcld, zclear, pcldsw, zdsig, pomega, zoz, zrmu, zsec, ptau, zud, &
-        zfd, zfu)
-      inu = 2
-      CALL sw2s_lmdar4(inu, paer, flag_aer, tauae, pizae, cgae, zaki, palbd, &
-        palbp, pcg, zcld, zclear, pcldsw, zdsig, pomega, zoz, zrmu, zsec, &
-        ptau, zud, pwv, pqs, zfdown, zfup)
-      DO jk = 1, kflev + 1
-        DO jl = 1, kdlon
-          zfsupad(jl, jk) = zfsup(jl, jk)
-          zfsdnad(jl, jk) = zfsdn(jl, jk)
-          zfsup(jl, jk) = (zfup(jl,jk)+zfu(jl,jk))*zfact(jl)
-          zfsdn(jl, jk) = (zfdown(jl,jk)+zfd(jl,jk))*zfact(jl)
-        END DO
-      END DO
-
-    END IF ! ok_ade
-
-    IF (ok_aie) THEN
-
-      ! jq   cloudy-sky + aerosol direct + aerosol indirect
-      flag_aer = 1.0
-      CALL swu_lmdar4(psct, pcldsw, ppmb, ppsol, prmu0, pfrac, ptave, pwv, &
-        zaki, zcld, zclear, zdsig, zfact, zrmu, zsec, zud)
-      inu = 1
-      CALL sw1s_lmdar4(inu, paer, flag_aer, tauae, pizae, cgae, palbd, palbp, &
-        pcg, zcld, zclear, pcldsw, zdsig, pomegaa, zoz, zrmu, zsec, ptaua, &
-        zud, zfd, zfu)
-      inu = 2
-      CALL sw2s_lmdar4(inu, paer, flag_aer, tauae, pizae, cgae, zaki, palbd, &
-        palbp, pcg, zcld, zclear, pcldsw, zdsig, pomegaa, zoz, zrmu, zsec, &
-        ptaua, zud, pwv, pqs, zfdown, zfup)
-      DO jk = 1, kflev + 1
-        DO jl = 1, kdlon
-          zfsupai(jl, jk) = zfsup(jl, jk)
-          zfsdnai(jl, jk) = zfsdn(jl, jk)
-          zfsup(jl, jk) = (zfup(jl,jk)+zfu(jl,jk))*zfact(jl)
-          zfsdn(jl, jk) = (zfdown(jl,jk)+zfd(jl,jk))*zfact(jl)
-        END DO
-      END DO
-    END IF ! ok_aie
-    ! jq -end
-
-    itapsw = 0
-  END IF
-  itapsw = itapsw + 1
-
-  DO k = 1, kflev
-    kpl1 = k + 1
-    DO i = 1, kdlon
-      pheat(i, k) = -(zfsup(i,kpl1)-zfsup(i,k)) - (zfsdn(i,k)-zfsdn(i,kpl1))
-      pheat(i, k) = pheat(i, k)*rday*rg/rcpd/pdp(i, k)
-      pheat0(i, k) = -(zfsup0(i,kpl1)-zfsup0(i,k)) - &
-        (zfsdn0(i,k)-zfsdn0(i,kpl1))
-      pheat0(i, k) = pheat0(i, k)*rday*rg/rcpd/pdp(i, k)
-    END DO
-  END DO
-  DO i = 1, kdlon
-    palbpla(i) = zfsup(i, kflev+1)/(zfsdn(i,kflev+1)+1.0E-20)
-
-    psolsw(i) = zfsdn(i, 1) - zfsup(i, 1)
-    ptopsw(i) = zfsdn(i, kflev+1) - zfsup(i, kflev+1)
-
-    psolsw0(i) = zfsdn0(i, 1) - zfsup0(i, 1)
-    ptopsw0(i) = zfsdn0(i, kflev+1) - zfsup0(i, kflev+1)
-    ! -OB
-    psolswad(i) = zfsdnad(i, 1) - zfsupad(i, 1)
-    ptopswad(i) = zfsdnad(i, kflev+1) - zfsupad(i, kflev+1)
-
-    psolswai(i) = zfsdnai(i, 1) - zfsupai(i, 1)
-    ptopswai(i) = zfsdnai(i, kflev+1) - zfsupai(i, kflev+1)
-    ! -fin
-  END DO
-
-  RETURN
-END SUBROUTINE sw_lmdar4
-
-! IM ctes ds clesphys.h   SUBROUTINE SWU
-! (PSCT,RCO2,PCLDSW,PPMB,PPSOL,PRMU0,PFRAC,
-SUBROUTINE swu_lmdar4(psct, pcldsw, ppmb, ppsol, prmu0, pfrac, ptave, pwv, &
-    paki, pcld, pclear, pdsig, pfact, prmu, psec, pud)
-  USE dimphy
-  USE radiation_ar4_param, ONLY: zpdh2o, zpdumg, zprh2o, zprumg, rtdh2o, &
-    rtdumg, rth2o, rtumg
-  IMPLICIT NONE
-  include "radepsi.h"
-  include "radopt.h"
-  include "YOMCST.h"
-
-  ! * ARGUMENTS:
-
-  REAL (KIND=8) psct
-  ! IM ctes ds clesphys.h   REAL(KIND=8) RCO2
-  include "clesphys.h"
-  REAL (KIND=8) pcldsw(kdlon, kflev)
-  REAL (KIND=8) ppmb(kdlon, kflev+1)
-  REAL (KIND=8) ppsol(kdlon)
-  REAL (KIND=8) prmu0(kdlon)
-  REAL (KIND=8) pfrac(kdlon)
-  REAL (KIND=8) ptave(kdlon, kflev)
-  REAL (KIND=8) pwv(kdlon, kflev)
-
-  REAL (KIND=8) paki(kdlon, 2)
-  REAL (KIND=8) pcld(kdlon, kflev)
-  REAL (KIND=8) pclear(kdlon)
-  REAL (KIND=8) pdsig(kdlon, kflev)
-  REAL (KIND=8) pfact(kdlon)
-  REAL (KIND=8) prmu(kdlon)
-  REAL (KIND=8) psec(kdlon)
-  REAL (KIND=8) pud(kdlon, 5, kflev+1)
-
-  ! * LOCAL VARIABLES:
-
-  INTEGER iind(2)
-  REAL (KIND=8) zc1j(kdlon, kflev+1)
-  REAL (KIND=8) zclear(kdlon)
-  REAL (KIND=8) zcloud(kdlon)
-  REAL (KIND=8) zn175(kdlon)
-  REAL (KIND=8) zn190(kdlon)
-  REAL (KIND=8) zo175(kdlon)
-  REAL (KIND=8) zo190(kdlon)
-  REAL (KIND=8) zsign(kdlon)
-  REAL (KIND=8) zr(kdlon, 2)
-  REAL (KIND=8) zsigo(kdlon)
-  REAL (KIND=8) zud(kdlon, 2)
-  REAL (KIND=8) zrth, zrtu, zwh2o, zdsco2, zdsh2o, zfppw
-  INTEGER jl, jk, jkp1, jkl, jklp1, ja
-
-  ! ------------------------------------------------------------------
-
-  ! *         1.     COMPUTES AMOUNTS OF ABSORBERS
-  ! -----------------------------
-
-
-  iind(1) = 1
-  iind(2) = 2
-
-  ! *         1.1    INITIALIZES QUANTITIES
-  ! ----------------------
-
-
-  DO jl = 1, kdlon
-    pud(jl, 1, kflev+1) = 0.
-    pud(jl, 2, kflev+1) = 0.
-    pud(jl, 3, kflev+1) = 0.
-    pud(jl, 4, kflev+1) = 0.
-    pud(jl, 5, kflev+1) = 0.
-    pfact(jl) = prmu0(jl)*pfrac(jl)*psct
-    prmu(jl) = sqrt(1224.*prmu0(jl)*prmu0(jl)+1.)/35.
-    psec(jl) = 1./prmu(jl)
-    zc1j(jl, kflev+1) = 0.
-  END DO
-
-  ! *          1.3    AMOUNTS OF ABSORBERS
-  ! --------------------
-
-
-  DO jl = 1, kdlon
-    zud(jl, 1) = 0.
-    zud(jl, 2) = 0.
-    zo175(jl) = ppsol(jl)**(zpdumg+1.)
-    zo190(jl) = ppsol(jl)**(zpdh2o+1.)
-    zsigo(jl) = ppsol(jl)
-    zclear(jl) = 1.
-    zcloud(jl) = 0.
-  END DO
-
-  DO jk = 1, kflev
-    jkp1 = jk + 1
-    jkl = kflev + 1 - jk
-    jklp1 = jkl + 1
-    DO jl = 1, kdlon
-      zrth = (rth2o/ptave(jl,jk))**rtdh2o
-      zrtu = (rtumg/ptave(jl,jk))**rtdumg
-      zwh2o = max(pwv(jl,jk), zepscq)
-      zsign(jl) = 100.*ppmb(jl, jkp1)
-      pdsig(jl, jk) = (zsigo(jl)-zsign(jl))/ppsol(jl)
-      zn175(jl) = zsign(jl)**(zpdumg+1.)
-      zn190(jl) = zsign(jl)**(zpdh2o+1.)
-      zdsco2 = zo175(jl) - zn175(jl)
-      zdsh2o = zo190(jl) - zn190(jl)
-      pud(jl, 1, jk) = 1./(10.*rg*(zpdh2o+1.))/(zprh2o**zpdh2o)*zdsh2o*zwh2o* &
-        zrth
-      pud(jl, 2, jk) = 1./(10.*rg*(zpdumg+1.))/(zprumg**zpdumg)*zdsco2*rco2* &
-        zrtu
-      zfppw = 1.6078*zwh2o/(1.+0.608*zwh2o)
-      pud(jl, 4, jk) = pud(jl, 1, jk)*zfppw
-      pud(jl, 5, jk) = pud(jl, 1, jk)*(1.-zfppw)
-      zud(jl, 1) = zud(jl, 1) + pud(jl, 1, jk)
-      zud(jl, 2) = zud(jl, 2) + pud(jl, 2, jk)
-      zsigo(jl) = zsign(jl)
-      zo175(jl) = zn175(jl)
-      zo190(jl) = zn190(jl)
-
-      IF (novlp==1) THEN
-        zclear(jl) = zclear(jl)*(1.-max(pcldsw(jl,jkl),zcloud(jl)))/(1.-min( &
-          zcloud(jl),1.-zepsec))
-        zc1j(jl, jkl) = 1.0 - zclear(jl)
-        zcloud(jl) = pcldsw(jl, jkl)
-      ELSE IF (novlp==2) THEN
-        zcloud(jl) = max(pcldsw(jl,jkl), zcloud(jl))
-        zc1j(jl, jkl) = zcloud(jl)
-      ELSE IF (novlp==3) THEN
-        zclear(jl) = zclear(jl)*(1.-pcldsw(jl,jkl))
-        zcloud(jl) = 1.0 - zclear(jl)
-        zc1j(jl, jkl) = zcloud(jl)
-      END IF
-    END DO
-  END DO
-  DO jl = 1, kdlon
-    pclear(jl) = 1. - zc1j(jl, 1)
-  END DO
-  DO jk = 1, kflev
-    DO jl = 1, kdlon
-      IF (pclear(jl)<1.) THEN
-        pcld(jl, jk) = pcldsw(jl, jk)/(1.-pclear(jl))
-      ELSE
-        pcld(jl, jk) = 0.
-      END IF
-    END DO
-  END DO
-
-  ! *         1.4    COMPUTES CLEAR-SKY GREY ABSORPTION COEFFICIENTS
-  ! -----------------------------------------------
-
-
-  DO ja = 1, 2
-    DO jl = 1, kdlon
-      zud(jl, ja) = zud(jl, ja)*psec(jl)
-    END DO
-  END DO
-
-  CALL swtt1_lmdar4(2, 2, iind, zud, zr)
-
-  DO ja = 1, 2
-    DO jl = 1, kdlon
-      paki(jl, ja) = -log(zr(jl,ja))/zud(jl, ja)
-    END DO
-  END DO
-
-
-  ! ------------------------------------------------------------------
-
-  RETURN
-END SUBROUTINE swu_lmdar4
-SUBROUTINE sw1s_lmdar4(knu, paer, flag_aer, tauae, pizae, cgae, palbd, palbp, &
-    pcg, pcld, pclear, pcldsw, pdsig, pomega, poz, prmu, psec, ptau, pud, &
-    pfd, pfu)
-  USE dimphy
-  USE radiation_ar4_param, ONLY: rsun, rray
-  USE infotrac_phy, ONLY: type_trac
-  USE lmdz_reprobus_wrappers, ONLY: rsuntime, ok_suntime
-  USE print_control_mod, ONLY: lunout
-  USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_REPROBUS
-
-  IMPLICIT NONE
-
-  ! ------------------------------------------------------------------
-  ! PURPOSE.
-  ! --------
-
-  ! THIS ROUTINE COMPUTES THE SHORTWAVE RADIATION FLUXES IN TWO
-  ! SPECTRAL INTERVALS FOLLOWING FOUQUART AND BONNEL (1980).
-
-  ! METHOD.
-  ! -------
-
-  ! 1. COMPUTES UPWARD AND DOWNWARD FLUXES CORRESPONDING TO
-  ! CONTINUUM SCATTERING
-  ! 2. MULTIPLY BY OZONE TRANSMISSION FUNCTION
-
-  ! REFERENCE.
-  ! ----------
-
-  ! SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT
-  ! DOCUMENTATION, AND FOUQUART AND BONNEL (1980)
-
-  ! AUTHOR.
-  ! -------
-  ! JEAN-JACQUES MORCRETTE  *ECMWF*
-
-  ! MODIFICATIONS.
-  ! --------------
-  ! ORIGINAL : 89-07-14
-  ! 94-11-15   J.-J. MORCRETTE    DIRECT/DIFFUSE ALBEDO
-  ! ------------------------------------------------------------------
-
-  ! * ARGUMENTS:
-
-  INTEGER knu
-  ! -OB
-  REAL (KIND=8) flag_aer
-  REAL (KIND=8) tauae(kdlon, kflev, 2)
-  REAL (KIND=8) pizae(kdlon, kflev, 2)
-  REAL (KIND=8) cgae(kdlon, kflev, 2)
-  REAL (KIND=8) paer(kdlon, kflev, 5)
-  REAL (KIND=8) palbd(kdlon, 2)
-  REAL (KIND=8) palbp(kdlon, 2)
-  REAL (KIND=8) pcg(kdlon, 2, kflev)
-  REAL (KIND=8) pcld(kdlon, kflev)
-  REAL (KIND=8) pcldsw(kdlon, kflev)
-  REAL (KIND=8) pclear(kdlon)
-  REAL (KIND=8) pdsig(kdlon, kflev)
-  REAL (KIND=8) pomega(kdlon, 2, kflev)
-  REAL (KIND=8) poz(kdlon, kflev)
-  REAL (KIND=8) prmu(kdlon)
-  REAL (KIND=8) psec(kdlon)
-  REAL (KIND=8) ptau(kdlon, 2, kflev)
-  REAL (KIND=8) pud(kdlon, 5, kflev+1)
-
-  REAL (KIND=8) pfd(kdlon, kflev+1)
-  REAL (KIND=8) pfu(kdlon, kflev+1)
-
-  ! * LOCAL VARIABLES:
-
-  INTEGER iind(4)
-
-  REAL (KIND=8) zcgaz(kdlon, kflev)
-  REAL (KIND=8) zdiff(kdlon)
-  REAL (KIND=8) zdirf(kdlon)
-  REAL (KIND=8) zpizaz(kdlon, kflev)
-  REAL (KIND=8) zrayl(kdlon)
-  REAL (KIND=8) zray1(kdlon, kflev+1)
-  REAL (KIND=8) zray2(kdlon, kflev+1)
-  REAL (KIND=8) zrefz(kdlon, 2, kflev+1)
-  REAL (KIND=8) zrj(kdlon, 6, kflev+1)
-  REAL (KIND=8) zrj0(kdlon, 6, kflev+1)
-  REAL (KIND=8) zrk(kdlon, 6, kflev+1)
-  REAL (KIND=8) zrk0(kdlon, 6, kflev+1)
-  REAL (KIND=8) zrmue(kdlon, kflev+1)
-  REAL (KIND=8) zrmu0(kdlon, kflev+1)
-  REAL (KIND=8) zr(kdlon, 4)
-  REAL (KIND=8) ztauaz(kdlon, kflev)
-  REAL (KIND=8) ztra1(kdlon, kflev+1)
-  REAL (KIND=8) ztra2(kdlon, kflev+1)
-  REAL (KIND=8) zw(kdlon, 4)
-
-  INTEGER jl, jk, k, jaj, ikm1, ikl
-
-  ! If running with Reporbus, overwrite default values of RSUN.
-  ! Otherwise keep default values from radiation_AR4_param module.
-  IF (type_trac=='repr') THEN
-IF (CPPKEY_REPROBUS) THEN
-    IF (ok_suntime) THEN
-      rsun(1) = rsuntime(1)
-      rsun(2) = rsuntime(2)
-    END IF
-    WRITE (lunout, *) 'RSUN(1): ', rsun(1)
-END IF
-  END IF
-
-  ! ------------------------------------------------------------------
-
-  ! *         1.     FIRST SPECTRAL INTERVAL (0.25-0.68 MICRON)
-  ! ----------------------- ------------------
-
-
-
-  ! *         1.1    OPTICAL THICKNESS FOR RAYLEIGH SCATTERING
-  ! -----------------------------------------
-
-
-  DO jl = 1, kdlon
-    zrayl(jl) = rray(knu, 1) + prmu(jl)*(rray(knu,2)+prmu(jl)*(rray(knu, &
-      3)+prmu(jl)*(rray(knu,4)+prmu(jl)*(rray(knu,5)+prmu(jl)*rray(knu,6)))))
-  END DO
-
-
-  ! ------------------------------------------------------------------
-
-  ! *         2.    CONTINUUM SCATTERING CALCULATIONS
-  ! ---------------------------------
-
-
-  ! *         2.1   CLEAR-SKY FRACTION OF THE COLUMN
-  ! --------------------------------
-
-
-  CALL swclr_lmdar4(knu, paer, flag_aer, tauae, pizae, cgae, palbp, pdsig, &
-    zrayl, psec, zcgaz, zpizaz, zray1, zray2, zrefz, zrj0, zrk0, zrmu0, &
-    ztauaz, ztra1, ztra2)
-
-  ! *         2.2   CLOUDY FRACTION OF THE COLUMN
-  ! -----------------------------
-
-
-  CALL swr_lmdar4(knu, palbd, pcg, pcld, pdsig, pomega, zrayl, psec, ptau, &
-    zcgaz, zpizaz, zray1, zray2, zrefz, zrj, zrk, zrmue, ztauaz, ztra1, &
-    ztra2)
-
-  ! ------------------------------------------------------------------
-
-  ! *         3.    OZONE ABSORPTION
-  ! ----------------
-
-
-  iind(1) = 1
-  iind(2) = 3
-  iind(3) = 1
-  iind(4) = 3
-
-  ! *         3.1   DOWNWARD FLUXES
-  ! ---------------
-
-
-  jaj = 2
-
-  DO jl = 1, kdlon
-    zw(jl, 1) = 0.
-    zw(jl, 2) = 0.
-    zw(jl, 3) = 0.
-    zw(jl, 4) = 0.
-    pfd(jl, kflev+1) = ((1.-pclear(jl))*zrj(jl,jaj,kflev+1)+pclear(jl)*zrj0( &
-      jl,jaj,kflev+1))*rsun(knu)
-  END DO
-  DO jk = 1, kflev
-    ikl = kflev + 1 - jk
-    DO jl = 1, kdlon
-      zw(jl, 1) = zw(jl, 1) + pud(jl, 1, ikl)/zrmue(jl, ikl)
-      zw(jl, 2) = zw(jl, 2) + poz(jl, ikl)/zrmue(jl, ikl)
-      zw(jl, 3) = zw(jl, 3) + pud(jl, 1, ikl)/zrmu0(jl, ikl)
-      zw(jl, 4) = zw(jl, 4) + poz(jl, ikl)/zrmu0(jl, ikl)
-    END DO
-
-    CALL swtt1_lmdar4(knu, 4, iind, zw, zr)
-
-    DO jl = 1, kdlon
-      zdiff(jl) = zr(jl, 1)*zr(jl, 2)*zrj(jl, jaj, ikl)
-      zdirf(jl) = zr(jl, 3)*zr(jl, 4)*zrj0(jl, jaj, ikl)
-      pfd(jl, ikl) = ((1.-pclear(jl))*zdiff(jl)+pclear(jl)*zdirf(jl))* &
-        rsun(knu)
-    END DO
-  END DO
-
-  ! *         3.2   UPWARD FLUXES
-  ! -------------
-
-
-  DO jl = 1, kdlon
-    pfu(jl, 1) = ((1.-pclear(jl))*zdiff(jl)*palbd(jl,knu)+pclear(jl)*zdirf(jl &
-      )*palbp(jl,knu))*rsun(knu)
-  END DO
-
-  DO jk = 2, kflev + 1
-    ikm1 = jk - 1
-    DO jl = 1, kdlon
-      zw(jl, 1) = zw(jl, 1) + pud(jl, 1, ikm1)*1.66
-      zw(jl, 2) = zw(jl, 2) + poz(jl, ikm1)*1.66
-      zw(jl, 3) = zw(jl, 3) + pud(jl, 1, ikm1)*1.66
-      zw(jl, 4) = zw(jl, 4) + poz(jl, ikm1)*1.66
-    END DO
-
-    CALL swtt1_lmdar4(knu, 4, iind, zw, zr)
-
-    DO jl = 1, kdlon
-      zdiff(jl) = zr(jl, 1)*zr(jl, 2)*zrk(jl, jaj, jk)
-      zdirf(jl) = zr(jl, 3)*zr(jl, 4)*zrk0(jl, jaj, jk)
-      pfu(jl, jk) = ((1.-pclear(jl))*zdiff(jl)+pclear(jl)*zdirf(jl))* &
-        rsun(knu)
-    END DO
-  END DO
-
-  ! ------------------------------------------------------------------
-
-  RETURN
-END SUBROUTINE sw1s_lmdar4
-SUBROUTINE sw2s_lmdar4(knu, paer, flag_aer, tauae, pizae, cgae, paki, palbd, &
-    palbp, pcg, pcld, pclear, pcldsw, pdsig, pomega, poz, prmu, psec, ptau, &
-    pud, pwv, pqs, pfdown, pfup)
-  USE dimphy
-  USE radiation_ar4_param, ONLY: rsun, rray
-  USE infotrac_phy, ONLY: type_trac
-  USE lmdz_reprobus_wrappers, ONLY: rsuntime, ok_suntime
-  USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_REPROBUS
-
-  IMPLICIT NONE
-  include "radepsi.h"
-
-  ! ------------------------------------------------------------------
-  ! PURPOSE.
-  ! --------
-
-  ! THIS ROUTINE COMPUTES THE SHORTWAVE RADIATION FLUXES IN THE
-  ! SECOND SPECTRAL INTERVAL FOLLOWING FOUQUART AND BONNEL (1980).
-
-  ! METHOD.
-  ! -------
-
-  ! 1. COMPUTES REFLECTIVITY/TRANSMISSIVITY CORRESPONDING TO
-  ! CONTINUUM SCATTERING
-  ! 2. COMPUTES REFLECTIVITY/TRANSMISSIVITY CORRESPONDING FOR
-  ! A GREY MOLECULAR ABSORPTION
-  ! 3. LAPLACE TRANSFORM ON THE PREVIOUS TO GET EFFECTIVE AMOUNTS
-  ! OF ABSORBERS
-  ! 4. APPLY H2O AND U.M.G. TRANSMISSION FUNCTIONS
-  ! 5. MULTIPLY BY OZONE TRANSMISSION FUNCTION
-
-  ! REFERENCE.
-  ! ----------
-
-  ! SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT
-  ! DOCUMENTATION, AND FOUQUART AND BONNEL (1980)
-
-  ! AUTHOR.
-  ! -------
-  ! JEAN-JACQUES MORCRETTE  *ECMWF*
-
-  ! MODIFICATIONS.
-  ! --------------
-  ! ORIGINAL : 89-07-14
-  ! 94-11-15   J.-J. MORCRETTE    DIRECT/DIFFUSE ALBEDO
-  ! ------------------------------------------------------------------
-  ! * ARGUMENTS:
-
-  INTEGER knu
-  ! -OB
-  REAL (KIND=8) flag_aer
-  REAL (KIND=8) tauae(kdlon, kflev, 2)
-  REAL (KIND=8) pizae(kdlon, kflev, 2)
-  REAL (KIND=8) cgae(kdlon, kflev, 2)
-  REAL (KIND=8) paer(kdlon, kflev, 5)
-  REAL (KIND=8) paki(kdlon, 2)
-  REAL (KIND=8) palbd(kdlon, 2)
-  REAL (KIND=8) palbp(kdlon, 2)
-  REAL (KIND=8) pcg(kdlon, 2, kflev)
-  REAL (KIND=8) pcld(kdlon, kflev)
-  REAL (KIND=8) pcldsw(kdlon, kflev)
-  REAL (KIND=8) pclear(kdlon)
-  REAL (KIND=8) pdsig(kdlon, kflev)
-  REAL (KIND=8) pomega(kdlon, 2, kflev)
-  REAL (KIND=8) poz(kdlon, kflev)
-  REAL (KIND=8) pqs(kdlon, kflev)
-  REAL (KIND=8) prmu(kdlon)
-  REAL (KIND=8) psec(kdlon)
-  REAL (KIND=8) ptau(kdlon, 2, kflev)
-  REAL (KIND=8) pud(kdlon, 5, kflev+1)
-  REAL (KIND=8) pwv(kdlon, kflev)
-
-  REAL (KIND=8) pfdown(kdlon, kflev+1)
-  REAL (KIND=8) pfup(kdlon, kflev+1)
-
-  ! * LOCAL VARIABLES:
-
-  INTEGER iind2(2), iind3(3)
-  REAL (KIND=8) zcgaz(kdlon, kflev)
-  REAL (KIND=8) zfd(kdlon, kflev+1)
-  REAL (KIND=8) zfu(kdlon, kflev+1)
-  REAL (KIND=8) zg(kdlon)
-  REAL (KIND=8) zgg(kdlon)
-  REAL (KIND=8) zpizaz(kdlon, kflev)
-  REAL (KIND=8) zrayl(kdlon)
-  REAL (KIND=8) zray1(kdlon, kflev+1)
-  REAL (KIND=8) zray2(kdlon, kflev+1)
-  REAL (KIND=8) zref(kdlon)
-  REAL (KIND=8) zrefz(kdlon, 2, kflev+1)
-  REAL (KIND=8) zre1(kdlon)
-  REAL (KIND=8) zre2(kdlon)
-  REAL (KIND=8) zrj(kdlon, 6, kflev+1)
-  REAL (KIND=8) zrj0(kdlon, 6, kflev+1)
-  REAL (KIND=8) zrk(kdlon, 6, kflev+1)
-  REAL (KIND=8) zrk0(kdlon, 6, kflev+1)
-  REAL (KIND=8) zrl(kdlon, 8)
-  REAL (KIND=8) zrmue(kdlon, kflev+1)
-  REAL (KIND=8) zrmu0(kdlon, kflev+1)
-  REAL (KIND=8) zrmuz(kdlon)
-  REAL (KIND=8) zrneb(kdlon)
-  REAL (KIND=8) zruef(kdlon, 8)
-  REAL (KIND=8) zr1(kdlon)
-  REAL (KIND=8) zr2(kdlon, 2)
-  REAL (KIND=8) zr3(kdlon, 3)
-  REAL (KIND=8) zr4(kdlon)
-  REAL (KIND=8) zr21(kdlon)
-  REAL (KIND=8) zr22(kdlon)
-  REAL (KIND=8) zs(kdlon)
-  REAL (KIND=8) ztauaz(kdlon, kflev)
-  REAL (KIND=8) zto1(kdlon)
-  REAL (KIND=8) ztr(kdlon, 2, kflev+1)
-  REAL (KIND=8) ztra1(kdlon, kflev+1)
-  REAL (KIND=8) ztra2(kdlon, kflev+1)
-  REAL (KIND=8) ztr1(kdlon)
-  REAL (KIND=8) ztr2(kdlon)
-  REAL (KIND=8) zw(kdlon)
-  REAL (KIND=8) zw1(kdlon)
-  REAL (KIND=8) zw2(kdlon, 2)
-  REAL (KIND=8) zw3(kdlon, 3)
-  REAL (KIND=8) zw4(kdlon)
-  REAL (KIND=8) zw5(kdlon)
-
-  INTEGER jl, jk, k, jaj, ikm1, ikl, jn, jabs, jkm1
-  INTEGER jref, jkl, jklp1, jajp, jkki, jkkp4, jn2j, iabs
-  REAL (KIND=8) zrmum1, zwh2o, zcneb, zaa, zbb, zrki, zre11
-
-  ! If running with Reporbus, overwrite default values of RSUN.
-  ! Otherwise keep default values from radiation_AR4_param module.
-  IF (type_trac=='repr') THEN
-IF (CPPKEY_REPROBUS) THEN
-    IF (ok_suntime) THEN
-      rsun(1) = rsuntime(1)
-      rsun(2) = rsuntime(2)
-    END IF
-END IF
-  END IF
-
-  ! ------------------------------------------------------------------
-
-  ! *         1.     SECOND SPECTRAL INTERVAL (0.68-4.00 MICRON)
-  ! -------------------------------------------
-
-
-
-  ! *         1.1    OPTICAL THICKNESS FOR RAYLEIGH SCATTERING
-  ! -----------------------------------------
-
-
-  DO jl = 1, kdlon
-    zrmum1 = 1. - prmu(jl)
-    zrayl(jl) = rray(knu, 1) + zrmum1*(rray(knu,2)+zrmum1*(rray(knu, &
-      3)+zrmum1*(rray(knu,4)+zrmum1*(rray(knu,5)+zrmum1*rray(knu,6)))))
-  END DO
-
-  ! ------------------------------------------------------------------
-
-  ! *         2.    CONTINUUM SCATTERING CALCULATIONS
-  ! ---------------------------------
-
-
-  ! *         2.1   CLEAR-SKY FRACTION OF THE COLUMN
-  ! --------------------------------
-
-
-  CALL swclr_lmdar4(knu, paer, flag_aer, tauae, pizae, cgae, palbp, pdsig, &
-    zrayl, psec, zcgaz, zpizaz, zray1, zray2, zrefz, zrj0, zrk0, zrmu0, &
-    ztauaz, ztra1, ztra2)
-
-  ! *         2.2   CLOUDY FRACTION OF THE COLUMN
-  ! -----------------------------
-
-
-  CALL swr_lmdar4(knu, palbd, pcg, pcld, pdsig, pomega, zrayl, psec, ptau, &
-    zcgaz, zpizaz, zray1, zray2, zrefz, zrj, zrk, zrmue, ztauaz, ztra1, &
-    ztra2)
-
-  ! ------------------------------------------------------------------
-
-  ! *         3.    SCATTERING CALCULATIONS WITH GREY MOLECULAR ABSORPTION
-  ! ------------------------------------------------------
-
-
-  jn = 2
-
-  DO jabs = 1, 2
-    ! *         3.1  SURFACE CONDITIONS
-    ! ------------------
-
-
-    DO jl = 1, kdlon
-      zrefz(jl, 2, 1) = palbd(jl, knu)
-      zrefz(jl, 1, 1) = palbd(jl, knu)
-    END DO
-
-    ! *         3.2  INTRODUCING CLOUD EFFECTS
-    ! -------------------------
-
-
-    DO jk = 2, kflev + 1
-      jkm1 = jk - 1
-      ikl = kflev + 1 - jkm1
-      DO jl = 1, kdlon
-        zrneb(jl) = pcld(jl, jkm1)
-        IF (jabs==1 .AND. zrneb(jl)>2.*zeelog) THEN
-          zwh2o = max(pwv(jl,jkm1), zeelog)
-          zcneb = max(zeelog, min(zrneb(jl),1.-zeelog))
-          zbb = pud(jl, jabs, jkm1)*pqs(jl, jkm1)/zwh2o
-          zaa = max((pud(jl,jabs,jkm1)-zcneb*zbb)/(1.-zcneb), zeelog)
-        ELSE
-          zaa = pud(jl, jabs, jkm1)
-          zbb = zaa
-        END IF
-        zrki = paki(jl, jabs)
-        zs(jl) = exp(-zrki*zaa*1.66)
-        zg(jl) = exp(-zrki*zaa/zrmue(jl,jk))
-        ztr1(jl) = 0.
-        zre1(jl) = 0.
-        ztr2(jl) = 0.
-        zre2(jl) = 0.
-
-        zw(jl) = pomega(jl, knu, jkm1)
-        zto1(jl) = ptau(jl, knu, jkm1)/zw(jl) + ztauaz(jl, jkm1)/zpizaz(jl, &
-          jkm1) + zbb*zrki
-
-        zr21(jl) = ptau(jl, knu, jkm1) + ztauaz(jl, jkm1)
-        zr22(jl) = ptau(jl, knu, jkm1)/zr21(jl)
-        zgg(jl) = zr22(jl)*pcg(jl, knu, jkm1) + (1.-zr22(jl))*zcgaz(jl, jkm1)
-        zw(jl) = zr21(jl)/zto1(jl)
-        zref(jl) = zrefz(jl, 1, jkm1)
-        zrmuz(jl) = zrmue(jl, jk)
-      END DO
-
-      CALL swde_lmdar4(zgg, zref, zrmuz, zto1, zw, zre1, zre2, ztr1, ztr2)
-
-      DO jl = 1, kdlon
-
-        zrefz(jl, 2, jk) = (1.-zrneb(jl))*(zray1(jl,jkm1)+zrefz(jl,2,jkm1)* &
-          ztra1(jl,jkm1)*ztra2(jl,jkm1))*zg(jl)*zs(jl) + zrneb(jl)*zre1(jl)
-
-        ztr(jl, 2, jkm1) = zrneb(jl)*ztr1(jl) + (ztra1(jl,jkm1))*zg(jl)*(1.- &
-          zrneb(jl))
-
-        zrefz(jl, 1, jk) = (1.-zrneb(jl))*(zray1(jl,jkm1)+zrefz(jl,1,jkm1)* &
-          ztra1(jl,jkm1)*ztra2(jl,jkm1)/(1.-zray2(jl,jkm1)*zrefz(jl,1, &
-          jkm1)))*zg(jl)*zs(jl) + zrneb(jl)*zre2(jl)
-
-        ztr(jl, 1, jkm1) = zrneb(jl)*ztr2(jl) + (ztra1(jl,jkm1)/(1.-zray2(jl, &
-          jkm1)*zrefz(jl,1,jkm1)))*zg(jl)*(1.-zrneb(jl))
-
-      END DO
-    END DO
-
-    ! *         3.3  REFLECT./TRANSMISSIVITY BETWEEN SURFACE AND LEVEL
-    ! -------------------------------------------------
-
-
-    DO jref = 1, 2
-
-      jn = jn + 1
-
-      DO jl = 1, kdlon
-        zrj(jl, jn, kflev+1) = 1.
-        zrk(jl, jn, kflev+1) = zrefz(jl, jref, kflev+1)
-      END DO
-
-      DO jk = 1, kflev
-        jkl = kflev + 1 - jk
-        jklp1 = jkl + 1
-        DO jl = 1, kdlon
-          zre11 = zrj(jl, jn, jklp1)*ztr(jl, jref, jkl)
-          zrj(jl, jn, jkl) = zre11
-          zrk(jl, jn, jkl) = zre11*zrefz(jl, jref, jkl)
-        END DO
-      END DO
-    END DO
-  END DO
-
-  ! ------------------------------------------------------------------
-
-  ! *         4.    INVERT GREY AND CONTINUUM FLUXES
-  ! --------------------------------
-
-
-
-  ! *         4.1   UPWARD (ZRK) AND DOWNWARD (ZRJ) PSEUDO-FLUXES
-  ! ---------------------------------------------
-
-
-  DO jk = 1, kflev + 1
-    DO jaj = 1, 5, 2
-      jajp = jaj + 1
-      DO jl = 1, kdlon
-        zrj(jl, jaj, jk) = zrj(jl, jaj, jk) - zrj(jl, jajp, jk)
-        zrk(jl, jaj, jk) = zrk(jl, jaj, jk) - zrk(jl, jajp, jk)
-        zrj(jl, jaj, jk) = max(zrj(jl,jaj,jk), zeelog)
-        zrk(jl, jaj, jk) = max(zrk(jl,jaj,jk), zeelog)
-      END DO
-    END DO
-  END DO
-
-  DO jk = 1, kflev + 1
-    DO jaj = 2, 6, 2
-      DO jl = 1, kdlon
-        zrj(jl, jaj, jk) = max(zrj(jl,jaj,jk), zeelog)
-        zrk(jl, jaj, jk) = max(zrk(jl,jaj,jk), zeelog)
-      END DO
-    END DO
-  END DO
-
-  ! *         4.2    EFFECTIVE ABSORBER AMOUNTS BY INVERSE LAPLACE
-  ! ---------------------------------------------
-
-
-  DO jk = 1, kflev + 1
-    jkki = 1
-    DO jaj = 1, 2
-      iind2(1) = jaj
-      iind2(2) = jaj
-      DO jn = 1, 2
-        jn2j = jn + 2*jaj
-        jkkp4 = jkki + 4
-
-        ! *         4.2.1  EFFECTIVE ABSORBER AMOUNTS
-        ! --------------------------
-
-
-        DO jl = 1, kdlon
-          zw2(jl, 1) = log(zrj(jl,jn,jk)/zrj(jl,jn2j,jk))/paki(jl, jaj)
-          zw2(jl, 2) = log(zrk(jl,jn,jk)/zrk(jl,jn2j,jk))/paki(jl, jaj)
-        END DO
-
-        ! *         4.2.2  TRANSMISSION FUNCTION
-        ! ---------------------
-
-
-        CALL swtt1_lmdar4(knu, 2, iind2, zw2, zr2)
-
-        DO jl = 1, kdlon
-          zrl(jl, jkki) = zr2(jl, 1)
-          zruef(jl, jkki) = zw2(jl, 1)
-          zrl(jl, jkkp4) = zr2(jl, 2)
-          zruef(jl, jkkp4) = zw2(jl, 2)
-        END DO
-
-        jkki = jkki + 1
-      END DO
-    END DO
-
-    ! *         4.3    UPWARD AND DOWNWARD FLUXES WITH H2O AND UMG ABSORPTION
-    ! ------------------------------------------------------
-
-
-    DO jl = 1, kdlon
-      pfdown(jl, jk) = zrj(jl, 1, jk)*zrl(jl, 1)*zrl(jl, 3) + &
-        zrj(jl, 2, jk)*zrl(jl, 2)*zrl(jl, 4)
-      pfup(jl, jk) = zrk(jl, 1, jk)*zrl(jl, 5)*zrl(jl, 7) + &
-        zrk(jl, 2, jk)*zrl(jl, 6)*zrl(jl, 8)
-    END DO
-  END DO
-
-  ! ------------------------------------------------------------------
-
-  ! *         5.    MOLECULAR ABSORPTION ON CLEAR-SKY FLUXES
-  ! ----------------------------------------
-
-
-
-  ! *         5.1   DOWNWARD FLUXES
-  ! ---------------
-
-
-  jaj = 2
-  iind3(1) = 1
-  iind3(2) = 2
-  iind3(3) = 3
-
-  DO jl = 1, kdlon
-    zw3(jl, 1) = 0.
-    zw3(jl, 2) = 0.
-    zw3(jl, 3) = 0.
-    zw4(jl) = 0.
-    zw5(jl) = 0.
-    zr4(jl) = 1.
-    zfd(jl, kflev+1) = zrj0(jl, jaj, kflev+1)
-  END DO
-  DO jk = 1, kflev
-    ikl = kflev + 1 - jk
-    DO jl = 1, kdlon
-      zw3(jl, 1) = zw3(jl, 1) + pud(jl, 1, ikl)/zrmu0(jl, ikl)
-      zw3(jl, 2) = zw3(jl, 2) + pud(jl, 2, ikl)/zrmu0(jl, ikl)
-      zw3(jl, 3) = zw3(jl, 3) + poz(jl, ikl)/zrmu0(jl, ikl)
-      zw4(jl) = zw4(jl) + pud(jl, 4, ikl)/zrmu0(jl, ikl)
-      zw5(jl) = zw5(jl) + pud(jl, 5, ikl)/zrmu0(jl, ikl)
-    END DO
-
-    CALL swtt1_lmdar4(knu, 3, iind3, zw3, zr3)
-
-    DO jl = 1, kdlon
-      ! ZR4(JL) = EXP(-RSWCE*ZW4(JL)-RSWCP*ZW5(JL))
-      zfd(jl, ikl) = zr3(jl, 1)*zr3(jl, 2)*zr3(jl, 3)*zr4(jl)* &
-        zrj0(jl, jaj, ikl)
-    END DO
-  END DO
-
-  ! *         5.2   UPWARD FLUXES
-  ! -------------
-
-
-  DO jl = 1, kdlon
-    zfu(jl, 1) = zfd(jl, 1)*palbp(jl, knu)
-  END DO
-
-  DO jk = 2, kflev + 1
-    ikm1 = jk - 1
-    DO jl = 1, kdlon
-      zw3(jl, 1) = zw3(jl, 1) + pud(jl, 1, ikm1)*1.66
-      zw3(jl, 2) = zw3(jl, 2) + pud(jl, 2, ikm1)*1.66
-      zw3(jl, 3) = zw3(jl, 3) + poz(jl, ikm1)*1.66
-      zw4(jl) = zw4(jl) + pud(jl, 4, ikm1)*1.66
-      zw5(jl) = zw5(jl) + pud(jl, 5, ikm1)*1.66
-    END DO
-
-    CALL swtt1_lmdar4(knu, 3, iind3, zw3, zr3)
-
-    DO jl = 1, kdlon
-      ! ZR4(JL) = EXP(-RSWCE*ZW4(JL)-RSWCP*ZW5(JL))
-      zfu(jl, jk) = zr3(jl, 1)*zr3(jl, 2)*zr3(jl, 3)*zr4(jl)* &
-        zrk0(jl, jaj, jk)
-    END DO
-  END DO
-
-  ! ------------------------------------------------------------------
-
-  ! *         6.     INTRODUCTION OF OZONE AND H2O CONTINUUM ABSORPTION
-  ! --------------------------------------------------
-
-  iabs = 3
-
-  ! *         6.1    DOWNWARD FLUXES
-  ! ---------------
-
-  DO jl = 1, kdlon
-    zw1(jl) = 0.
-    zw4(jl) = 0.
-    zw5(jl) = 0.
-    zr1(jl) = 0.
-    pfdown(jl, kflev+1) = ((1.-pclear(jl))*pfdown(jl,kflev+1)+pclear(jl)*zfd( &
-      jl,kflev+1))*rsun(knu)
-  END DO
-
-  DO jk = 1, kflev
-    ikl = kflev + 1 - jk
-    DO jl = 1, kdlon
-      zw1(jl) = zw1(jl) + poz(jl, ikl)/zrmue(jl, ikl)
-      zw4(jl) = zw4(jl) + pud(jl, 4, ikl)/zrmue(jl, ikl)
-      zw5(jl) = zw5(jl) + pud(jl, 5, ikl)/zrmue(jl, ikl)
-      ! ZR4(JL) = EXP(-RSWCE*ZW4(JL)-RSWCP*ZW5(JL))
-    END DO
-
-    CALL swtt_lmdar4(knu, iabs, zw1, zr1)
-
-    DO jl = 1, kdlon
-      pfdown(jl, ikl) = ((1.-pclear(jl))*zr1(jl)*zr4(jl)*pfdown(jl,ikl)+ &
-        pclear(jl)*zfd(jl,ikl))*rsun(knu)
-    END DO
-  END DO
-
-  ! *         6.2    UPWARD FLUXES
-  ! -------------
-
-  DO jl = 1, kdlon
-    pfup(jl, 1) = ((1.-pclear(jl))*zr1(jl)*zr4(jl)*pfup(jl,1)+pclear(jl)*zfu( &
-      jl,1))*rsun(knu)
-  END DO
-
-  DO jk = 2, kflev + 1
-    ikm1 = jk - 1
-    DO jl = 1, kdlon
-      zw1(jl) = zw1(jl) + poz(jl, ikm1)*1.66
-      zw4(jl) = zw4(jl) + pud(jl, 4, ikm1)*1.66
-      zw5(jl) = zw5(jl) + pud(jl, 5, ikm1)*1.66
-      ! ZR4(JL) = EXP(-RSWCE*ZW4(JL)-RSWCP*ZW5(JL))
-    END DO
-
-    CALL swtt_lmdar4(knu, iabs, zw1, zr1)
-
-    DO jl = 1, kdlon
-      pfup(jl, jk) = ((1.-pclear(jl))*zr1(jl)*zr4(jl)*pfup(jl,jk)+pclear(jl)* &
-        zfu(jl,jk))*rsun(knu)
-    END DO
-  END DO
-
-  ! ------------------------------------------------------------------
-
-  RETURN
-END SUBROUTINE sw2s_lmdar4
-SUBROUTINE swclr_lmdar4(knu, paer, flag_aer, tauae, pizae, cgae, palbp, &
-    pdsig, prayl, psec, pcgaz, ppizaz, pray1, pray2, prefz, prj, prk, prmu0, &
-    ptauaz, ptra1, ptra2)
-  USE dimphy
-  USE radiation_ar4_param, ONLY: taua, rpiza, rcga
-  IMPLICIT NONE
-  include "radepsi.h"
-  include "radopt.h"
-
-  ! ------------------------------------------------------------------
-  ! PURPOSE.
-  ! --------
-  ! COMPUTES THE REFLECTIVITY AND TRANSMISSIVITY IN CASE OF
-  ! CLEAR-SKY COLUMN
-
-  ! REFERENCE.
-  ! ----------
-
-  ! SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT
-  ! DOCUMENTATION, AND FOUQUART AND BONNEL (1980)
-
-  ! AUTHOR.
-  ! -------
-  ! JEAN-JACQUES MORCRETTE  *ECMWF*
-
-  ! MODIFICATIONS.
-  ! --------------
-  ! ORIGINAL : 94-11-15
-  ! ------------------------------------------------------------------
-  ! * ARGUMENTS:
-
-  INTEGER knu
-  ! -OB
-  REAL (KIND=8) flag_aer
-  REAL (KIND=8) tauae(kdlon, kflev, 2)
-  REAL (KIND=8) pizae(kdlon, kflev, 2)
-  REAL (KIND=8) cgae(kdlon, kflev, 2)
-  REAL (KIND=8) paer(kdlon, kflev, 5)
-  REAL (KIND=8) palbp(kdlon, 2)
-  REAL (KIND=8) pdsig(kdlon, kflev)
-  REAL (KIND=8) prayl(kdlon)
-  REAL (KIND=8) psec(kdlon)
-
-  REAL (KIND=8) pcgaz(kdlon, kflev)
-  REAL (KIND=8) ppizaz(kdlon, kflev)
-  REAL (KIND=8) pray1(kdlon, kflev+1)
-  REAL (KIND=8) pray2(kdlon, kflev+1)
-  REAL (KIND=8) prefz(kdlon, 2, kflev+1)
-  REAL (KIND=8) prj(kdlon, 6, kflev+1)
-  REAL (KIND=8) prk(kdlon, 6, kflev+1)
-  REAL (KIND=8) prmu0(kdlon, kflev+1)
-  REAL (KIND=8) ptauaz(kdlon, kflev)
-  REAL (KIND=8) ptra1(kdlon, kflev+1)
-  REAL (KIND=8) ptra2(kdlon, kflev+1)
-
-  ! * LOCAL VARIABLES:
-
-  REAL (KIND=8) zc0i(kdlon, kflev+1)
-  REAL (KIND=8) zcle0(kdlon, kflev)
-  REAL (KIND=8) zclear(kdlon)
-  REAL (KIND=8) zr21(kdlon)
-  REAL (KIND=8) zr23(kdlon)
-  REAL (KIND=8) zss0(kdlon)
-  REAL (KIND=8) zscat(kdlon)
-  REAL (KIND=8) ztr(kdlon, 2, kflev+1)
-
-  INTEGER jl, jk, ja, jae, jkl, jklp1, jaj, jkm1, in
-  REAL (KIND=8) ztray, zgar, zratio, zff, zfacoa, zcorae
-  REAL (KIND=8) zmue, zgap, zww, zto, zden, zmu1, zden1
-  REAL (KIND=8) zbmu0, zbmu1, zre11
-
-  ! ------------------------------------------------------------------
-
-  ! *         1.    OPTICAL PARAMETERS FOR AEROSOLS AND RAYLEIGH
-  ! --------------------------------------------
-
-
-  ! cdir collapse
-  DO jk = 1, kflev + 1
-    DO ja = 1, 6
-      DO jl = 1, kdlon
-        prj(jl, ja, jk) = 0.
-        prk(jl, ja, jk) = 0.
-      END DO
-    END DO
-  END DO
-
-  DO jk = 1, kflev
-    ! -OB
-    ! DO 104 JL = 1, KDLON
-    ! PCGAZ(JL,JK) = 0.
-    ! PPIZAZ(JL,JK) =  0.
-    ! PTAUAZ(JL,JK) = 0.
-    ! 104  CONTINUE
-    ! -OB
-    ! DO 106 JAE=1,5
-    ! DO 105 JL = 1, KDLON
-    ! PTAUAZ(JL,JK)=PTAUAZ(JL,JK)
-    ! S        +PAER(JL,JK,JAE)*TAUA(KNU,JAE)
-    ! PPIZAZ(JL,JK)=PPIZAZ(JL,JK)+PAER(JL,JK,JAE)
-    ! S        * TAUA(KNU,JAE)*RPIZA(KNU,JAE)
-    ! PCGAZ(JL,JK) =  PCGAZ(JL,JK) +PAER(JL,JK,JAE)
-    ! S        * TAUA(KNU,JAE)*RPIZA(KNU,JAE)*RCGA(KNU,JAE)
-    ! 105  CONTINUE
-    ! 106  CONTINUE
-    ! -OB
-    DO jl = 1, kdlon
-      ptauaz(jl, jk) = flag_aer*tauae(jl, jk, knu)
-      ppizaz(jl, jk) = flag_aer*pizae(jl, jk, knu)
-      pcgaz(jl, jk) = flag_aer*cgae(jl, jk, knu)
-    END DO
-
-    IF (flag_aer>0) THEN
-      ! -OB
-      DO jl = 1, kdlon
-        ! PCGAZ(JL,JK)=PCGAZ(JL,JK)/PPIZAZ(JL,JK)
-        ! PPIZAZ(JL,JK)=PPIZAZ(JL,JK)/PTAUAZ(JL,JK)
-        ztray = prayl(jl)*pdsig(jl, jk)
-        zratio = ztray/(ztray+ptauaz(jl,jk))
-        zgar = pcgaz(jl, jk)
-        zff = zgar*zgar
-        ptauaz(jl, jk) = ztray + ptauaz(jl, jk)*(1.-ppizaz(jl,jk)*zff)
-        pcgaz(jl, jk) = zgar*(1.-zratio)/(1.+zgar)
-        ppizaz(jl, jk) = zratio + (1.-zratio)*ppizaz(jl, jk)*(1.-zff)/(1.- &
-          ppizaz(jl,jk)*zff)
-      END DO
-    ELSE
-      DO jl = 1, kdlon
-        ztray = prayl(jl)*pdsig(jl, jk)
-        ptauaz(jl, jk) = ztray
-        pcgaz(jl, jk) = 0.
-        ppizaz(jl, jk) = 1. - repsct
-      END DO
-    END IF ! check flag_aer
-    ! 107  CONTINUE
-    ! PRINT 9107,JK,((PAER(JL,JK,JAE),JAE=1,5)
-    ! $ ,PTAUAZ(JL,JK),PPIZAZ(JL,JK),PCGAZ(JL,JK),JL=1,KDLON)
-    ! 9107 FORMAT(1X,'SWCLR_107',I3,8E12.5)
-
-  END DO
-
-  ! ------------------------------------------------------------------
-
-  ! *         2.    TOTAL EFFECTIVE CLOUDINESS ABOVE A GIVEN LEVEL
-  ! ----------------------------------------------
-
-
-  DO jl = 1, kdlon
-    zr23(jl) = 0.
-    zc0i(jl, kflev+1) = 0.
-    zclear(jl) = 1.
-    zscat(jl) = 0.
-  END DO
-
-  jk = 1
-  jkl = kflev + 1 - jk
-  jklp1 = jkl + 1
-  DO jl = 1, kdlon
-    zfacoa = 1. - ppizaz(jl, jkl)*pcgaz(jl, jkl)*pcgaz(jl, jkl)
-    zcorae = zfacoa*ptauaz(jl, jkl)*psec(jl)
-    zr21(jl) = exp(-zcorae)
-    zss0(jl) = 1. - zr21(jl)
-    zcle0(jl, jkl) = zss0(jl)
-
-    IF (novlp==1) THEN
-      ! * maximum-random
-      zclear(jl) = zclear(jl)*(1.0-max(zss0(jl),zscat(jl)))/ &
-        (1.0-min(zscat(jl),1.-zepsec))
-      zc0i(jl, jkl) = 1.0 - zclear(jl)
-      zscat(jl) = zss0(jl)
-    ELSE IF (novlp==2) THEN
-      ! * maximum
-      zscat(jl) = max(zss0(jl), zscat(jl))
-      zc0i(jl, jkl) = zscat(jl)
-    ELSE IF (novlp==3) THEN
-      ! * random
-      zclear(jl) = zclear(jl)*(1.0-zss0(jl))
-      zscat(jl) = 1.0 - zclear(jl)
-      zc0i(jl, jkl) = zscat(jl)
-    END IF
-  END DO
-
-  DO jk = 2, kflev
-    jkl = kflev + 1 - jk
-    jklp1 = jkl + 1
-    DO jl = 1, kdlon
-      zfacoa = 1. - ppizaz(jl, jkl)*pcgaz(jl, jkl)*pcgaz(jl, jkl)
-      zcorae = zfacoa*ptauaz(jl, jkl)*psec(jl)
-      zr21(jl) = exp(-zcorae)
-      zss0(jl) = 1. - zr21(jl)
-      zcle0(jl, jkl) = zss0(jl)
-
-      IF (novlp==1) THEN
-        ! * maximum-random
-        zclear(jl) = zclear(jl)*(1.0-max(zss0(jl),zscat(jl)))/ &
-          (1.0-min(zscat(jl),1.-zepsec))
-        zc0i(jl, jkl) = 1.0 - zclear(jl)
-        zscat(jl) = zss0(jl)
-      ELSE IF (novlp==2) THEN
-        ! * maximum
-        zscat(jl) = max(zss0(jl), zscat(jl))
-        zc0i(jl, jkl) = zscat(jl)
-      ELSE IF (novlp==3) THEN
-        ! * random
-        zclear(jl) = zclear(jl)*(1.0-zss0(jl))
-        zscat(jl) = 1.0 - zclear(jl)
-        zc0i(jl, jkl) = zscat(jl)
-      END IF
-    END DO
-  END DO
-
-  ! ------------------------------------------------------------------
-
-  ! *         3.    REFLECTIVITY/TRANSMISSIVITY FOR PURE SCATTERING
-  ! -----------------------------------------------
-
-
-  DO jl = 1, kdlon
-    pray1(jl, kflev+1) = 0.
-    pray2(jl, kflev+1) = 0.
-    prefz(jl, 2, 1) = palbp(jl, knu)
-    prefz(jl, 1, 1) = palbp(jl, knu)
-    ptra1(jl, kflev+1) = 1.
-    ptra2(jl, kflev+1) = 1.
-  END DO
-
-  DO jk = 2, kflev + 1
-    jkm1 = jk - 1
-    DO jl = 1, kdlon
-
-      ! ------------------------------------------------------------------
-
-      ! *         3.1  EQUIVALENT ZENITH ANGLE
-      ! -----------------------
-
-
-      zmue = (1.-zc0i(jl,jk))*psec(jl) + zc0i(jl, jk)*1.66
-      prmu0(jl, jk) = 1./zmue
-
-      ! ------------------------------------------------------------------
-
-      ! *         3.2  REFLECT./TRANSMISSIVITY DUE TO RAYLEIGH AND AEROSOLS
-      ! ----------------------------------------------------
-
-
-      zgap = pcgaz(jl, jkm1)
-      zbmu0 = 0.5 - 0.75*zgap/zmue
-      zww = ppizaz(jl, jkm1)
-      zto = ptauaz(jl, jkm1)
-      zden = 1. + (1.-zww+zbmu0*zww)*zto*zmue + (1-zww)*(1.-zww+2.*zbmu0*zww) &
-        *zto*zto*zmue*zmue
-      pray1(jl, jkm1) = zbmu0*zww*zto*zmue/zden
-      ptra1(jl, jkm1) = 1./zden
-
-      zmu1 = 0.5
-      zbmu1 = 0.5 - 0.75*zgap*zmu1
-      zden1 = 1. + (1.-zww+zbmu1*zww)*zto/zmu1 + (1-zww)*(1.-zww+2.*zbmu1*zww &
-        )*zto*zto/zmu1/zmu1
-      pray2(jl, jkm1) = zbmu1*zww*zto/zmu1/zden1
-      ptra2(jl, jkm1) = 1./zden1
-
-
-
-      prefz(jl, 1, jk) = (pray1(jl,jkm1)+prefz(jl,1,jkm1)*ptra1(jl,jkm1)* &
-        ptra2(jl,jkm1)/(1.-pray2(jl,jkm1)*prefz(jl,1,jkm1)))
-
-      ztr(jl, 1, jkm1) = (ptra1(jl,jkm1)/(1.-pray2(jl,jkm1)*prefz(jl,1, &
-        jkm1)))
-
-      prefz(jl, 2, jk) = (pray1(jl,jkm1)+prefz(jl,2,jkm1)*ptra1(jl,jkm1)* &
-        ptra2(jl,jkm1))
-
-      ztr(jl, 2, jkm1) = ptra1(jl, jkm1)
-
-    END DO
-  END DO
-  DO jl = 1, kdlon
-    zmue = (1.-zc0i(jl,1))*psec(jl) + zc0i(jl, 1)*1.66
-    prmu0(jl, 1) = 1./zmue
-  END DO
-
-  ! ------------------------------------------------------------------
-
-  ! *         3.5    REFLECT./TRANSMISSIVITY BETWEEN SURFACE AND LEVEL
-  ! -------------------------------------------------
-
-
-  IF (knu==1) THEN
-    jaj = 2
-    DO jl = 1, kdlon
-      prj(jl, jaj, kflev+1) = 1.
-      prk(jl, jaj, kflev+1) = prefz(jl, 1, kflev+1)
-    END DO
-
-    DO jk = 1, kflev
-      jkl = kflev + 1 - jk
-      jklp1 = jkl + 1
-      DO jl = 1, kdlon
-        zre11 = prj(jl, jaj, jklp1)*ztr(jl, 1, jkl)
-        prj(jl, jaj, jkl) = zre11
-        prk(jl, jaj, jkl) = zre11*prefz(jl, 1, jkl)
-      END DO
-    END DO
-
-  ELSE
-
-    DO jaj = 1, 2
-      DO jl = 1, kdlon
-        prj(jl, jaj, kflev+1) = 1.
-        prk(jl, jaj, kflev+1) = prefz(jl, jaj, kflev+1)
-      END DO
-
-      DO jk = 1, kflev
-        jkl = kflev + 1 - jk
-        jklp1 = jkl + 1
-        DO jl = 1, kdlon
-          zre11 = prj(jl, jaj, jklp1)*ztr(jl, jaj, jkl)
-          prj(jl, jaj, jkl) = zre11
-          prk(jl, jaj, jkl) = zre11*prefz(jl, jaj, jkl)
-        END DO
-      END DO
-    END DO
-
-  END IF
-
-  ! ------------------------------------------------------------------
-
-  RETURN
-END SUBROUTINE swclr_lmdar4
-SUBROUTINE swr_lmdar4(knu, palbd, pcg, pcld, pdsig, pomega, prayl, psec, &
-    ptau, pcgaz, ppizaz, pray1, pray2, prefz, prj, prk, prmue, ptauaz, ptra1, &
-    ptra2)
-  USE dimphy
-  IMPLICIT NONE
-  include "radepsi.h"
-  include "radopt.h"
-
-  ! ------------------------------------------------------------------
-  ! PURPOSE.
-  ! --------
-  ! COMPUTES THE REFLECTIVITY AND TRANSMISSIVITY IN CASE OF
-  ! CONTINUUM SCATTERING
-
-  ! METHOD.
-  ! -------
-
-  ! 1. COMPUTES CONTINUUM FLUXES CORRESPONDING TO AEROSOL
-  ! OR/AND RAYLEIGH SCATTERING (NO MOLECULAR GAS ABSORPTION)
-
-  ! REFERENCE.
-  ! ----------
-
-  ! SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT
-  ! DOCUMENTATION, AND FOUQUART AND BONNEL (1980)
-
-  ! AUTHOR.
-  ! -------
-  ! JEAN-JACQUES MORCRETTE  *ECMWF*
-
-  ! MODIFICATIONS.
-  ! --------------
-  ! ORIGINAL : 89-07-14
-  ! ------------------------------------------------------------------
-  ! * ARGUMENTS:
-
-  INTEGER knu
-  REAL (KIND=8) palbd(kdlon, 2)
-  REAL (KIND=8) pcg(kdlon, 2, kflev)
-  REAL (KIND=8) pcld(kdlon, kflev)
-  REAL (KIND=8) pdsig(kdlon, kflev)
-  REAL (KIND=8) pomega(kdlon, 2, kflev)
-  REAL (KIND=8) prayl(kdlon)
-  REAL (KIND=8) psec(kdlon)
-  REAL (KIND=8) ptau(kdlon, 2, kflev)
-
-  REAL (KIND=8) pray1(kdlon, kflev+1)
-  REAL (KIND=8) pray2(kdlon, kflev+1)
-  REAL (KIND=8) prefz(kdlon, 2, kflev+1)
-  REAL (KIND=8) prj(kdlon, 6, kflev+1)
-  REAL (KIND=8) prk(kdlon, 6, kflev+1)
-  REAL (KIND=8) prmue(kdlon, kflev+1)
-  REAL (KIND=8) pcgaz(kdlon, kflev)
-  REAL (KIND=8) ppizaz(kdlon, kflev)
-  REAL (KIND=8) ptauaz(kdlon, kflev)
-  REAL (KIND=8) ptra1(kdlon, kflev+1)
-  REAL (KIND=8) ptra2(kdlon, kflev+1)
-
-  ! * LOCAL VARIABLES:
-
-  REAL (KIND=8) zc1i(kdlon, kflev+1)
-  REAL (KIND=8) zcleq(kdlon, kflev)
-  REAL (KIND=8) zclear(kdlon)
-  REAL (KIND=8) zcloud(kdlon)
-  REAL (KIND=8) zgg(kdlon)
-  REAL (KIND=8) zref(kdlon)
-  REAL (KIND=8) zre1(kdlon)
-  REAL (KIND=8) zre2(kdlon)
-  REAL (KIND=8) zrmuz(kdlon)
-  REAL (KIND=8) zrneb(kdlon)
-  REAL (KIND=8) zr21(kdlon)
-  REAL (KIND=8) zr22(kdlon)
-  REAL (KIND=8) zr23(kdlon)
-  REAL (KIND=8) zss1(kdlon)
-  REAL (KIND=8) zto1(kdlon)
-  REAL (KIND=8) ztr(kdlon, 2, kflev+1)
-  REAL (KIND=8) ztr1(kdlon)
-  REAL (KIND=8) ztr2(kdlon)
-  REAL (KIND=8) zw(kdlon)
-
-  INTEGER jk, jl, ja, jkl, jklp1, jkm1, jaj
-  REAL (KIND=8) zfacoa, zfacoc, zcorae, zcorcd
-  REAL (KIND=8) zmue, zgap, zww, zto, zden, zden1
-  REAL (KIND=8) zmu1, zre11, zbmu0, zbmu1
-
-  ! ------------------------------------------------------------------
-
-  ! *         1.    INITIALIZATION
-  ! --------------
-
-
-  DO jk = 1, kflev + 1
-    DO ja = 1, 6
-      DO jl = 1, kdlon
-        prj(jl, ja, jk) = 0.
-        prk(jl, ja, jk) = 0.
-      END DO
-    END DO
-  END DO
-
-  ! ------------------------------------------------------------------
-
-  ! *         2.    TOTAL EFFECTIVE CLOUDINESS ABOVE A GIVEN LEVEL
-  ! ----------------------------------------------
-
-
-  DO jl = 1, kdlon
-    zr23(jl) = 0.
-    zc1i(jl, kflev+1) = 0.
-    zclear(jl) = 1.
-    zcloud(jl) = 0.
-  END DO
-
-  jk = 1
-  jkl = kflev + 1 - jk
-  jklp1 = jkl + 1
-  DO jl = 1, kdlon
-    zfacoa = 1. - ppizaz(jl, jkl)*pcgaz(jl, jkl)*pcgaz(jl, jkl)
-    zfacoc = 1. - pomega(jl, knu, jkl)*pcg(jl, knu, jkl)*pcg(jl, knu, jkl)
-    zcorae = zfacoa*ptauaz(jl, jkl)*psec(jl)
-    zcorcd = zfacoc*ptau(jl, knu, jkl)*psec(jl)
-    zr21(jl) = exp(-zcorae)
-    zr22(jl) = exp(-zcorcd)
-    zss1(jl) = pcld(jl, jkl)*(1.0-zr21(jl)*zr22(jl)) + &
-      (1.0-pcld(jl,jkl))*(1.0-zr21(jl))
-    zcleq(jl, jkl) = zss1(jl)
-
-    IF (novlp==1) THEN
-      ! * maximum-random
-      zclear(jl) = zclear(jl)*(1.0-max(zss1(jl),zcloud(jl)))/ &
-        (1.0-min(zcloud(jl),1.-zepsec))
-      zc1i(jl, jkl) = 1.0 - zclear(jl)
-      zcloud(jl) = zss1(jl)
-    ELSE IF (novlp==2) THEN
-      ! * maximum
-      zcloud(jl) = max(zss1(jl), zcloud(jl))
-      zc1i(jl, jkl) = zcloud(jl)
-    ELSE IF (novlp==3) THEN
-      ! * random
-      zclear(jl) = zclear(jl)*(1.0-zss1(jl))
-      zcloud(jl) = 1.0 - zclear(jl)
-      zc1i(jl, jkl) = zcloud(jl)
-    END IF
-  END DO
-
-  DO jk = 2, kflev
-    jkl = kflev + 1 - jk
-    jklp1 = jkl + 1
-    DO jl = 1, kdlon
-      zfacoa = 1. - ppizaz(jl, jkl)*pcgaz(jl, jkl)*pcgaz(jl, jkl)
-      zfacoc = 1. - pomega(jl, knu, jkl)*pcg(jl, knu, jkl)*pcg(jl, knu, jkl)
-      zcorae = zfacoa*ptauaz(jl, jkl)*psec(jl)
-      zcorcd = zfacoc*ptau(jl, knu, jkl)*psec(jl)
-      zr21(jl) = exp(-zcorae)
-      zr22(jl) = exp(-zcorcd)
-      zss1(jl) = pcld(jl, jkl)*(1.0-zr21(jl)*zr22(jl)) + &
-        (1.0-pcld(jl,jkl))*(1.0-zr21(jl))
-      zcleq(jl, jkl) = zss1(jl)
-
-      IF (novlp==1) THEN
-        ! * maximum-random
-        zclear(jl) = zclear(jl)*(1.0-max(zss1(jl),zcloud(jl)))/ &
-          (1.0-min(zcloud(jl),1.-zepsec))
-        zc1i(jl, jkl) = 1.0 - zclear(jl)
-        zcloud(jl) = zss1(jl)
-      ELSE IF (novlp==2) THEN
-        ! * maximum
-        zcloud(jl) = max(zss1(jl), zcloud(jl))
-        zc1i(jl, jkl) = zcloud(jl)
-      ELSE IF (novlp==3) THEN
-        ! * random
-        zclear(jl) = zclear(jl)*(1.0-zss1(jl))
-        zcloud(jl) = 1.0 - zclear(jl)
-        zc1i(jl, jkl) = zcloud(jl)
-      END IF
-    END DO
-  END DO
-
-  ! ------------------------------------------------------------------
-
-  ! *         3.    REFLECTIVITY/TRANSMISSIVITY FOR PURE SCATTERING
-  ! -----------------------------------------------
-
-
-  DO jl = 1, kdlon
-    pray1(jl, kflev+1) = 0.
-    pray2(jl, kflev+1) = 0.
-    prefz(jl, 2, 1) = palbd(jl, knu)
-    prefz(jl, 1, 1) = palbd(jl, knu)
-    ptra1(jl, kflev+1) = 1.
-    ptra2(jl, kflev+1) = 1.
-  END DO
-
-  DO jk = 2, kflev + 1
-    jkm1 = jk - 1
-    DO jl = 1, kdlon
-      zrneb(jl) = pcld(jl, jkm1)
-      zre1(jl) = 0.
-      ztr1(jl) = 0.
-      zre2(jl) = 0.
-      ztr2(jl) = 0.
-
-      ! ------------------------------------------------------------------
-
-      ! *         3.1  EQUIVALENT ZENITH ANGLE
-      ! -----------------------
-
-
-      zmue = (1.-zc1i(jl,jk))*psec(jl) + zc1i(jl, jk)*1.66
-      prmue(jl, jk) = 1./zmue
-
-      ! ------------------------------------------------------------------
-
-      ! *         3.2  REFLECT./TRANSMISSIVITY DUE TO RAYLEIGH AND AEROSOLS
-      ! ----------------------------------------------------
-
-
-      zgap = pcgaz(jl, jkm1)
-      zbmu0 = 0.5 - 0.75*zgap/zmue
-      zww = ppizaz(jl, jkm1)
-      zto = ptauaz(jl, jkm1)
-      zden = 1. + (1.-zww+zbmu0*zww)*zto*zmue + (1-zww)*(1.-zww+2.*zbmu0*zww) &
-        *zto*zto*zmue*zmue
-      pray1(jl, jkm1) = zbmu0*zww*zto*zmue/zden
-      ptra1(jl, jkm1) = 1./zden
-      ! PRINT *,' LOOP 342 ** 3 ** JL=',JL,PRAY1(JL,JKM1),PTRA1(JL,JKM1)
-
-      zmu1 = 0.5
-      zbmu1 = 0.5 - 0.75*zgap*zmu1
-      zden1 = 1. + (1.-zww+zbmu1*zww)*zto/zmu1 + (1-zww)*(1.-zww+2.*zbmu1*zww &
-        )*zto*zto/zmu1/zmu1
-      pray2(jl, jkm1) = zbmu1*zww*zto/zmu1/zden1
-      ptra2(jl, jkm1) = 1./zden1
-
-      ! ------------------------------------------------------------------
-
-      ! *         3.3  EFFECT OF CLOUD LAYER
-      ! ---------------------
-
-
-      zw(jl) = pomega(jl, knu, jkm1)
-      zto1(jl) = ptau(jl, knu, jkm1)/zw(jl) + ptauaz(jl, jkm1)/ppizaz(jl, &
-        jkm1)
-      zr21(jl) = ptau(jl, knu, jkm1) + ptauaz(jl, jkm1)
-      zr22(jl) = ptau(jl, knu, jkm1)/zr21(jl)
-      zgg(jl) = zr22(jl)*pcg(jl, knu, jkm1) + (1.-zr22(jl))*pcgaz(jl, jkm1)
-      ! Modif PhD - JJM 19/03/96 pour erreurs arrondis
-      ! machine
-      ! PHD PROTECTION ZW(JL) = ZR21(JL) / ZTO1(JL)
-      IF (zw(jl)==1. .AND. ppizaz(jl,jkm1)==1.) THEN
-        zw(jl) = 1.
-      ELSE
-        zw(jl) = zr21(jl)/zto1(jl)
-      END IF
-      zref(jl) = prefz(jl, 1, jkm1)
-      zrmuz(jl) = prmue(jl, jk)
-    END DO
-
-    CALL swde_lmdar4(zgg, zref, zrmuz, zto1, zw, zre1, zre2, ztr1, ztr2)
-
-    DO jl = 1, kdlon
-
-      prefz(jl, 1, jk) = (1.-zrneb(jl))*(pray1(jl,jkm1)+prefz(jl,1,jkm1)* &
-        ptra1(jl,jkm1)*ptra2(jl,jkm1)/(1.-pray2(jl,jkm1)*prefz(jl,1, &
-        jkm1))) + zrneb(jl)*zre2(jl)
-
-      ztr(jl, 1, jkm1) = zrneb(jl)*ztr2(jl) + (ptra1(jl,jkm1)/(1.-pray2(jl, &
-        jkm1)*prefz(jl,1,jkm1)))*(1.-zrneb(jl))
-
-      prefz(jl, 2, jk) = (1.-zrneb(jl))*(pray1(jl,jkm1)+prefz(jl,2,jkm1)* &
-        ptra1(jl,jkm1)*ptra2(jl,jkm1)) + zrneb(jl)*zre1(jl)
-
-      ztr(jl, 2, jkm1) = zrneb(jl)*ztr1(jl) + ptra1(jl, jkm1)*(1.-zrneb(jl))
-
-    END DO
-  END DO
-  DO jl = 1, kdlon
-    zmue = (1.-zc1i(jl,1))*psec(jl) + zc1i(jl, 1)*1.66
-    prmue(jl, 1) = 1./zmue
-  END DO
-
-  ! ------------------------------------------------------------------
-
-  ! *         3.5    REFLECT./TRANSMISSIVITY BETWEEN SURFACE AND LEVEL
-  ! -------------------------------------------------
-
-
-  IF (knu==1) THEN
-    jaj = 2
-    DO jl = 1, kdlon
-      prj(jl, jaj, kflev+1) = 1.
-      prk(jl, jaj, kflev+1) = prefz(jl, 1, kflev+1)
-    END DO
-
-    DO jk = 1, kflev
-      jkl = kflev + 1 - jk
-      jklp1 = jkl + 1
-      DO jl = 1, kdlon
-        zre11 = prj(jl, jaj, jklp1)*ztr(jl, 1, jkl)
-        prj(jl, jaj, jkl) = zre11
-        prk(jl, jaj, jkl) = zre11*prefz(jl, 1, jkl)
-      END DO
-    END DO
-
-  ELSE
-
-    DO jaj = 1, 2
-      DO jl = 1, kdlon
-        prj(jl, jaj, kflev+1) = 1.
-        prk(jl, jaj, kflev+1) = prefz(jl, jaj, kflev+1)
-      END DO
-
-      DO jk = 1, kflev
-        jkl = kflev + 1 - jk
-        jklp1 = jkl + 1
-        DO jl = 1, kdlon
-          zre11 = prj(jl, jaj, jklp1)*ztr(jl, jaj, jkl)
-          prj(jl, jaj, jkl) = zre11
-          prk(jl, jaj, jkl) = zre11*prefz(jl, jaj, jkl)
-        END DO
-      END DO
-    END DO
-
-  END IF
-
-  ! ------------------------------------------------------------------
-
-  RETURN
-END SUBROUTINE swr_lmdar4
-SUBROUTINE swde_lmdar4(pgg, pref, prmuz, pto1, pw, pre1, pre2, ptr1, ptr2)
-  USE dimphy
-  IMPLICIT NONE
-
-  ! ------------------------------------------------------------------
-  ! PURPOSE.
-  ! --------
-  ! COMPUTES THE REFLECTIVITY AND TRANSMISSIVITY OF A CLOUDY
-  ! LAYER USING THE DELTA-EDDINGTON'S APPROXIMATION.
-
-  ! METHOD.
-  ! -------
-
-  ! STANDARD DELTA-EDDINGTON LAYER CALCULATIONS.
-
-  ! REFERENCE.
-  ! ----------
-
-  ! SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
-  ! ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
-
-  ! AUTHOR.
-  ! -------
-  ! JEAN-JACQUES MORCRETTE  *ECMWF*
-
-  ! MODIFICATIONS.
-  ! --------------
-  ! ORIGINAL : 88-12-15
-  ! ------------------------------------------------------------------
-  ! * ARGUMENTS:
-
-  REAL (KIND=8) pgg(kdlon) ! ASSYMETRY FACTOR
-  REAL (KIND=8) pref(kdlon) ! REFLECTIVITY OF THE UNDERLYING LAYER
-  REAL (KIND=8) prmuz(kdlon) ! COSINE OF SOLAR ZENITH ANGLE
-  REAL (KIND=8) pto1(kdlon) ! OPTICAL THICKNESS
-  REAL (KIND=8) pw(kdlon) ! SINGLE SCATTERING ALBEDO
-  REAL (KIND=8) pre1(kdlon) ! LAYER REFLECTIVITY (NO UNDERLYING-LAYER REFLECTION)
-  REAL (KIND=8) pre2(kdlon) ! LAYER REFLECTIVITY
-  REAL (KIND=8) ptr1(kdlon) ! LAYER TRANSMISSIVITY (NO UNDERLYING-LAYER REFLECTION)
-  REAL (KIND=8) ptr2(kdlon) ! LAYER TRANSMISSIVITY
-
-  ! * LOCAL VARIABLES:
-
-  INTEGER jl
-  REAL (KIND=8) zff, zgp, ztop, zwcp, zdt, zx1, zwm
-  REAL (KIND=8) zrm2, zrk, zx2, zrp, zalpha, zbeta, zarg
-  REAL (KIND=8) zexmu0, zarg2, zexkp, zexkm, zxp2p, zxm2p, zap2b, zam2b
-  REAL (KIND=8) za11, za12, za13, za21, za22, za23
-  REAL (KIND=8) zdena, zc1a, zc2a, zri0a, zri1a
-  REAL (KIND=8) zri0b, zri1b
-  REAL (KIND=8) zb21, zb22, zb23, zdenb, zc1b, zc2b
-  REAL (KIND=8) zri0c, zri1c, zri0d, zri1d
-
-  ! ------------------------------------------------------------------
-
-  ! *         1.      DELTA-EDDINGTON CALCULATIONS
-
-
-  DO jl = 1, kdlon
-    ! *         1.1     SET UP THE DELTA-MODIFIED PARAMETERS
-
-
-    zff = pgg(jl)*pgg(jl)
-    zgp = pgg(jl)/(1.+pgg(jl))
-    ztop = (1.-pw(jl)*zff)*pto1(jl)
-    zwcp = (1-zff)*pw(jl)/(1.-pw(jl)*zff)
-    zdt = 2./3.
-    zx1 = 1. - zwcp*zgp
-    zwm = 1. - zwcp
-    zrm2 = prmuz(jl)*prmuz(jl)
-    zrk = sqrt(3.*zwm*zx1)
-    zx2 = 4.*(1.-zrk*zrk*zrm2)
-    zrp = zrk/zx1
-    zalpha = 3.*zwcp*zrm2*(1.+zgp*zwm)/zx2
-    zbeta = 3.*zwcp*prmuz(jl)*(1.+3.*zgp*zrm2*zwm)/zx2
-    zarg = min(ztop/prmuz(jl), 200._8)
-    zexmu0 = exp(-zarg)
-    zarg2 = min(zrk*ztop, 200._8)
-    zexkp = exp(zarg2)
-    zexkm = 1./zexkp
-    zxp2p = 1. + zdt*zrp
-    zxm2p = 1. - zdt*zrp
-    zap2b = zalpha + zdt*zbeta
-    zam2b = zalpha - zdt*zbeta
-
-    ! *         1.2     WITHOUT REFLECTION FROM THE UNDERLYING LAYER
-
-
-    za11 = zxp2p
-    za12 = zxm2p
-    za13 = zap2b
-    za22 = zxp2p*zexkp
-    za21 = zxm2p*zexkm
-    za23 = zam2b*zexmu0
-    zdena = za11*za22 - za21*za12
-    zc1a = (za22*za13-za12*za23)/zdena
-    zc2a = (za11*za23-za21*za13)/zdena
-    zri0a = zc1a + zc2a - zalpha
-    zri1a = zrp*(zc1a-zc2a) - zbeta
-    pre1(jl) = (zri0a-zdt*zri1a)/prmuz(jl)
-    zri0b = zc1a*zexkm + zc2a*zexkp - zalpha*zexmu0
-    zri1b = zrp*(zc1a*zexkm-zc2a*zexkp) - zbeta*zexmu0
-    ptr1(jl) = zexmu0 + (zri0b+zdt*zri1b)/prmuz(jl)
-
-    ! *         1.3     WITH REFLECTION FROM THE UNDERLYING LAYER
-
-
-    zb21 = za21 - pref(jl)*zxp2p*zexkm
-    zb22 = za22 - pref(jl)*zxm2p*zexkp
-    zb23 = za23 - pref(jl)*zexmu0*(zap2b-prmuz(jl))
-    zdenb = za11*zb22 - zb21*za12
-    zc1b = (zb22*za13-za12*zb23)/zdenb
-    zc2b = (za11*zb23-zb21*za13)/zdenb
-    zri0c = zc1b + zc2b - zalpha
-    zri1c = zrp*(zc1b-zc2b) - zbeta
-    pre2(jl) = (zri0c-zdt*zri1c)/prmuz(jl)
-    zri0d = zc1b*zexkm + zc2b*zexkp - zalpha*zexmu0
-    zri1d = zrp*(zc1b*zexkm-zc2b*zexkp) - zbeta*zexmu0
-    ptr2(jl) = zexmu0 + (zri0d+zdt*zri1d)/prmuz(jl)
-
-  END DO
-  RETURN
-END SUBROUTINE swde_lmdar4
-SUBROUTINE swtt_lmdar4(knu, ka, pu, ptr)
-  USE dimphy
-  USE radiation_ar4_param, ONLY: apad, bpad, d
-  IMPLICIT NONE
-
-  ! -----------------------------------------------------------------------
-  ! PURPOSE.
-  ! --------
-  ! THIS ROUTINE COMPUTES THE TRANSMISSION FUNCTIONS FOR ALL THE
-  ! ABSORBERS (H2O, UNIFORMLY MIXED GASES, AND O3) IN THE TWO SPECTRAL
-  ! INTERVALS.
-
-  ! METHOD.
-  ! -------
-
-  ! TRANSMISSION FUNCTION ARE COMPUTED USING PADE APPROXIMANTS
-  ! AND HORNER'S ALGORITHM.
-
-  ! REFERENCE.
-  ! ----------
-
-  ! SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
-  ! ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
-
-  ! AUTHOR.
-  ! -------
-  ! JEAN-JACQUES MORCRETTE  *ECMWF*
-
-  ! MODIFICATIONS.
-  ! --------------
-  ! ORIGINAL : 88-12-15
-  ! -----------------------------------------------------------------------
-
-  ! * ARGUMENTS
-
-  INTEGER knu ! INDEX OF THE SPECTRAL INTERVAL
-  INTEGER ka ! INDEX OF THE ABSORBER
-  REAL (KIND=8) pu(kdlon) ! ABSORBER AMOUNT
-
-  REAL (KIND=8) ptr(kdlon) ! TRANSMISSION FUNCTION
-
-  ! * LOCAL VARIABLES:
-
-  REAL (KIND=8) zr1(kdlon), zr2(kdlon)
-  INTEGER jl, i, j
-
-  ! -----------------------------------------------------------------------
-
-  ! *         1.      HORNER'S ALGORITHM TO COMPUTE TRANSMISSION FUNCTION
-
-
-  DO jl = 1, kdlon
-    zr1(jl) = apad(knu, ka, 1) + pu(jl)*(apad(knu,ka,2)+pu(jl)*(apad(knu,ka, &
-      3)+pu(jl)*(apad(knu,ka,4)+pu(jl)*(apad(knu,ka,5)+pu(jl)*(apad(knu,ka,6) &
-      +pu(jl)*(apad(knu,ka,7)))))))
-
-    zr2(jl) = bpad(knu, ka, 1) + pu(jl)*(bpad(knu,ka,2)+pu(jl)*(bpad(knu,ka, &
-      3)+pu(jl)*(bpad(knu,ka,4)+pu(jl)*(bpad(knu,ka,5)+pu(jl)*(bpad(knu,ka,6) &
-      +pu(jl)*(bpad(knu,ka,7)))))))
-
-    ! *         2.      ADD THE BACKGROUND TRANSMISSION
-
-
-
-    ptr(jl) = (zr1(jl)/zr2(jl))*(1.-d(knu,ka)) + d(knu, ka)
-  END DO
-
-  RETURN
-END SUBROUTINE swtt_lmdar4
-SUBROUTINE swtt1_lmdar4(knu, kabs, kind, pu, ptr)
-  USE dimphy
-  USE radiation_ar4_param, ONLY: apad, bpad, d
-  IMPLICIT NONE
-
-  ! -----------------------------------------------------------------------
-  ! PURPOSE.
-  ! --------
-  ! THIS ROUTINE COMPUTES THE TRANSMISSION FUNCTIONS FOR ALL THE
-  ! ABSORBERS (H2O, UNIFORMLY MIXED GASES, AND O3) IN THE TWO SPECTRAL
-  ! INTERVALS.
-
-  ! METHOD.
-  ! -------
-
-  ! TRANSMISSION FUNCTION ARE COMPUTED USING PADE APPROXIMANTS
-  ! AND HORNER'S ALGORITHM.
-
-  ! REFERENCE.
-  ! ----------
-
-  ! SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
-  ! ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
-
-  ! AUTHOR.
-  ! -------
-  ! JEAN-JACQUES MORCRETTE  *ECMWF*
-
-  ! MODIFICATIONS.
-  ! --------------
-  ! ORIGINAL : 95-01-20
-  ! -----------------------------------------------------------------------
-  ! * ARGUMENTS:
-
-  INTEGER knu ! INDEX OF THE SPECTRAL INTERVAL
-  INTEGER kabs ! NUMBER OF ABSORBERS
-  INTEGER kind(kabs) ! INDICES OF THE ABSORBERS
-  REAL (KIND=8) pu(kdlon, kabs) ! ABSORBER AMOUNT
-
-  REAL (KIND=8) ptr(kdlon, kabs) ! TRANSMISSION FUNCTION
-
-  ! * LOCAL VARIABLES:
-
-  REAL (KIND=8) zr1(kdlon)
-  REAL (KIND=8) zr2(kdlon)
-  REAL (KIND=8) zu(kdlon)
-  INTEGER jl, ja, i, j, ia
-
-  ! -----------------------------------------------------------------------
-
-  ! *         1.      HORNER'S ALGORITHM TO COMPUTE TRANSMISSION FUNCTION
-
-
-  DO ja = 1, kabs
-    ia = kind(ja)
-    DO jl = 1, kdlon
-      zu(jl) = pu(jl, ja)
-      zr1(jl) = apad(knu, ia, 1) + zu(jl)*(apad(knu,ia,2)+zu(jl)*(apad(knu, &
-        ia,3)+zu(jl)*(apad(knu,ia,4)+zu(jl)*(apad(knu,ia,5)+zu(jl)*(apad(knu, &
-        ia,6)+zu(jl)*(apad(knu,ia,7)))))))
-
-      zr2(jl) = bpad(knu, ia, 1) + zu(jl)*(bpad(knu,ia,2)+zu(jl)*(bpad(knu, &
-        ia,3)+zu(jl)*(bpad(knu,ia,4)+zu(jl)*(bpad(knu,ia,5)+zu(jl)*(bpad(knu, &
-        ia,6)+zu(jl)*(bpad(knu,ia,7)))))))
-
-      ! *         2.      ADD THE BACKGROUND TRANSMISSION
-
-
-      ptr(jl, ja) = (zr1(jl)/zr2(jl))*(1.-d(knu,ia)) + d(knu, ia)
-    END DO
-  END DO
-
-  RETURN
-END SUBROUTINE swtt1_lmdar4
-! IM ctes ds clesphys.h   SUBROUTINE LW(RCO2,RCH4,RN2O,RCFC11,RCFC12,
-SUBROUTINE lw_lmdar4(ppmb, pdp, ppsol, pdt0, pemis, ptl, ptave, pwv, pozon, &
-    paer, pcldld, pcldlu, pview, pcolr, pcolr0, ptoplw, psollw, ptoplw0, &
-    psollw0, psollwdown, &         ! IM  .
-                                   ! psollwdown,psollwdownclr,
-  ! IM  .              ptoplwdown,ptoplwdownclr)
-    plwup, plwdn, plwup0, plwdn0)
-  USE dimphy
-  USE print_control_mod, ONLY: lunout
-  IMPLICIT NONE
-  include "raddimlw.h"
-  include "YOMCST.h"
-
-  ! -----------------------------------------------------------------------
-  ! METHOD.
-  ! -------
-
-  ! 1. COMPUTES THE PRESSURE AND TEMPERATURE WEIGHTED AMOUNTS OF
-  ! ABSORBERS.
-  ! 2. COMPUTES THE PLANCK FUNCTIONS ON THE INTERFACES AND THE
-  ! GRADIENT OF PLANCK FUNCTIONS IN THE LAYERS.
-  ! 3. PERFORMS THE VERTICAL INTEGRATION DISTINGUISHING THE CON-
-  ! TRIBUTIONS OF THE ADJACENT AND DISTANT LAYERS AND THOSE FROM THE
-  ! BOUNDARIES.
-  ! 4. COMPUTES THE CLEAR-SKY DOWNWARD AND UPWARD EMISSIVITIES.
-  ! 5. INTRODUCES THE EFFECTS OF THE CLOUDS ON THE FLUXES.
-
-
-  ! REFERENCE.
-  ! ----------
-
-  ! SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
-  ! ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
-
-  ! AUTHOR.
-  ! -------
-  ! JEAN-JACQUES MORCRETTE  *ECMWF*
-
-  ! MODIFICATIONS.
-  ! --------------
-  ! ORIGINAL : 89-07-14
-  ! -----------------------------------------------------------------------
-  ! IM ctes ds clesphys.h
-  ! REAL(KIND=8) RCO2   ! CO2 CONCENTRATION (IPCC:353.E-06* 44.011/28.97)
-  ! REAL(KIND=8) RCH4   ! CH4 CONCENTRATION (IPCC: 1.72E-06* 16.043/28.97)
-  ! REAL(KIND=8) RN2O   ! N2O CONCENTRATION (IPCC: 310.E-09* 44.013/28.97)
-  ! REAL(KIND=8) RCFC11 ! CFC11 CONCENTRATION (IPCC: 280.E-12*
-  ! 137.3686/28.97)
-  ! REAL(KIND=8) RCFC12 ! CFC12 CONCENTRATION (IPCC: 484.E-12*
-  ! 120.9140/28.97)
-  include "clesphys.h"
-  REAL (KIND=8) pcldld(kdlon, kflev) ! DOWNWARD EFFECTIVE CLOUD COVER
-  REAL (KIND=8) pcldlu(kdlon, kflev) ! UPWARD EFFECTIVE CLOUD COVER
-  REAL (KIND=8) pdp(kdlon, kflev) ! LAYER PRESSURE THICKNESS (Pa)
-  REAL (KIND=8) pdt0(kdlon) ! SURFACE TEMPERATURE DISCONTINUITY (K)
-  REAL (KIND=8) pemis(kdlon) ! SURFACE EMISSIVITY
-  REAL (KIND=8) ppmb(kdlon, kflev+1) ! HALF LEVEL PRESSURE (mb)
-  REAL (KIND=8) ppsol(kdlon) ! SURFACE PRESSURE (Pa)
-  REAL (KIND=8) pozon(kdlon, kflev) ! O3 mass fraction
-  REAL (KIND=8) ptl(kdlon, kflev+1) ! HALF LEVEL TEMPERATURE (K)
-  REAL (KIND=8) paer(kdlon, kflev, 5) ! OPTICAL THICKNESS OF THE AEROSOLS
-  REAL (KIND=8) ptave(kdlon, kflev) ! LAYER TEMPERATURE (K)
-  REAL (KIND=8) pview(kdlon) ! COSECANT OF VIEWING ANGLE
-  REAL (KIND=8) pwv(kdlon, kflev) ! SPECIFIC HUMIDITY (kg/kg)
-
-  REAL (KIND=8) pcolr(kdlon, kflev) ! LONG-WAVE TENDENCY (K/day)
-  REAL (KIND=8) pcolr0(kdlon, kflev) ! LONG-WAVE TENDENCY (K/day) clear-sky
-  REAL (KIND=8) ptoplw(kdlon) ! LONGWAVE FLUX AT T.O.A.
-  REAL (KIND=8) psollw(kdlon) ! LONGWAVE FLUX AT SURFACE
-  REAL (KIND=8) ptoplw0(kdlon) ! LONGWAVE FLUX AT T.O.A. (CLEAR-SKY)
-  REAL (KIND=8) psollw0(kdlon) ! LONGWAVE FLUX AT SURFACE (CLEAR-SKY)
-  ! Rajout LF
-  REAL (KIND=8) psollwdown(kdlon) ! LONGWAVE downwards flux at surface
-  ! Rajout IM
-  ! IM   real(kind=8) psollwdownclr(kdlon) ! LONGWAVE CS downwards flux at
-  ! surface
-  ! IM   real(kind=8) ptoplwdown(kdlon)    ! LONGWAVE downwards flux at
-  ! T.O.A.
-  ! IM   real(kind=8) ptoplwdownclr(kdlon) ! LONGWAVE CS downwards flux at
-  ! T.O.A.
-  ! IM
-  REAL (KIND=8) plwup(kdlon, kflev+1) ! LW up total sky
-  REAL (KIND=8) plwup0(kdlon, kflev+1) ! LW up clear sky
-  REAL (KIND=8) plwdn(kdlon, kflev+1) ! LW down total sky
-  REAL (KIND=8) plwdn0(kdlon, kflev+1) ! LW down clear sky
-  ! -------------------------------------------------------------------------
-  REAL (KIND=8) zabcu(kdlon, nua, 3*kflev+1)
-
-  REAL (KIND=8) zoz(kdlon, kflev)
-  ! equivalent pressure of ozone in a layer, in Pa
-
-  ! ym      REAL(KIND=8) ZFLUX(KDLON,2,KFLEV+1) ! RADIATIVE FLUXES (1:up;
-  ! 2:down)
-  ! ym      REAL(KIND=8) ZFLUC(KDLON,2,KFLEV+1) ! CLEAR-SKY RADIATIVE FLUXES
-  ! ym      REAL(KIND=8) ZBINT(KDLON,KFLEV+1)            ! Intermediate
-  ! variable
-  ! ym      REAL(KIND=8) ZBSUI(KDLON)                    ! Intermediate
-  ! variable
-  ! ym      REAL(KIND=8) ZCTS(KDLON,KFLEV)               ! Intermediate
-  ! variable
-  ! ym      REAL(KIND=8) ZCNTRB(KDLON,KFLEV+1,KFLEV+1)   ! Intermediate
-  ! variable
-  ! ym      SAVE ZFLUX, ZFLUC, ZBINT, ZBSUI, ZCTS, ZCNTRB
-  REAL (KIND=8), ALLOCATABLE, SAVE :: zflux(:, :, :) ! RADIATIVE FLUXES (1:up; 2:down)
-  REAL (KIND=8), ALLOCATABLE, SAVE :: zfluc(:, :, :) ! CLEAR-SKY RADIATIVE FLUXES
-  REAL (KIND=8), ALLOCATABLE, SAVE :: zbint(:, :) ! Intermediate variable
-  REAL (KIND=8), ALLOCATABLE, SAVE :: zbsui(:) ! Intermediate variable
-  REAL (KIND=8), ALLOCATABLE, SAVE :: zcts(:, :) ! Intermediate variable
-  REAL (KIND=8), ALLOCATABLE, SAVE :: zcntrb(:, :, :) ! Intermediate variable
-  !$OMP THREADPRIVATE(ZFLUX, ZFLUC, ZBINT, ZBSUI, ZCTS, ZCNTRB)
-
-  INTEGER ilim, i, k, kpl1
-
-  INTEGER lw0pas ! Every lw0pas steps, clear-sky is done
-  PARAMETER (lw0pas=1)
-  INTEGER lwpas ! Every lwpas steps, cloudy-sky is done
-  PARAMETER (lwpas=1)
-
-  INTEGER itaplw0, itaplw
-  LOGICAL appel1er
-  SAVE appel1er, itaplw0, itaplw
-  !$OMP THREADPRIVATE(appel1er, itaplw0, itaplw)
-  DATA appel1er/.TRUE./
-  DATA itaplw0, itaplw/0, 0/
-
-  ! ------------------------------------------------------------------
-  IF (appel1er) THEN
-    WRITE (lunout, *) 'LW clear-sky calling frequency: ', lw0pas
-    WRITE (lunout, *) 'LW cloudy-sky calling frequency: ', lwpas
-    WRITE (lunout, *) '   In general, they should be 1'
-    ! ym
-    ALLOCATE (zflux(kdlon,2,kflev+1))
-    ALLOCATE (zfluc(kdlon,2,kflev+1))
-    ALLOCATE (zbint(kdlon,kflev+1))
-    ALLOCATE (zbsui(kdlon))
-    ALLOCATE (zcts(kdlon,kflev))
-    ALLOCATE (zcntrb(kdlon,kflev+1,kflev+1))
-    appel1er = .FALSE.
-  END IF
-
-  IF (mod(itaplw0,lw0pas)==0) THEN
-    ! Compute equivalent pressure of ozone from mass fraction:
-    DO k = 1, kflev
-      DO i = 1, kdlon
-        zoz(i, k) = pozon(i, k)*pdp(i, k)
-      END DO
-    END DO
-    ! IM ctes ds clesphys.h   CALL LWU(RCO2,RCH4, RN2O, RCFC11, RCFC12,
-    CALL lwu_lmdar4(paer, pdp, ppmb, ppsol, zoz, ptave, pview, pwv, zabcu)
-    CALL lwbv_lmdar4(ilim, pdp, pdt0, pemis, ppmb, ptl, ptave, zabcu, zfluc, &
-      zbint, zbsui, zcts, zcntrb)
-    itaplw0 = 0
-  END IF
-  itaplw0 = itaplw0 + 1
-
-  IF (mod(itaplw,lwpas)==0) THEN
-    CALL lwc_lmdar4(ilim, pcldld, pcldlu, pemis, zfluc, zbint, zbsui, zcts, &
-      zcntrb, zflux)
-    itaplw = 0
-  END IF
-  itaplw = itaplw + 1
-
-  DO k = 1, kflev
-    kpl1 = k + 1
-    DO i = 1, kdlon
-      pcolr(i, k) = zflux(i, 1, kpl1) + zflux(i, 2, kpl1) - zflux(i, 1, k) - &
-        zflux(i, 2, k)
-      pcolr(i, k) = pcolr(i, k)*rday*rg/rcpd/pdp(i, k)
-      pcolr0(i, k) = zfluc(i, 1, kpl1) + zfluc(i, 2, kpl1) - zfluc(i, 1, k) - &
-        zfluc(i, 2, k)
-      pcolr0(i, k) = pcolr0(i, k)*rday*rg/rcpd/pdp(i, k)
-    END DO
-  END DO
-  DO i = 1, kdlon
-    psollw(i) = -zflux(i, 1, 1) - zflux(i, 2, 1)
-    ptoplw(i) = zflux(i, 1, kflev+1) + zflux(i, 2, kflev+1)
-
-    psollw0(i) = -zfluc(i, 1, 1) - zfluc(i, 2, 1)
-    ptoplw0(i) = zfluc(i, 1, kflev+1) + zfluc(i, 2, kflev+1)
-    psollwdown(i) = -zflux(i, 2, 1)
-
-    ! IM attention aux signes !; LWtop >0, LWdn < 0
-    DO k = 1, kflev + 1
-      plwup(i, k) = zflux(i, 1, k)
-      plwup0(i, k) = zfluc(i, 1, k)
-      plwdn(i, k) = zflux(i, 2, k)
-      plwdn0(i, k) = zfluc(i, 2, k)
-    END DO
-  END DO
-  ! ------------------------------------------------------------------
-  RETURN
-END SUBROUTINE lw_lmdar4
-! IM ctes ds clesphys.h   SUBROUTINE LWU(RCO2, RCH4, RN2O, RCFC11, RCFC12,
-SUBROUTINE lwu_lmdar4(paer, pdp, ppmb, ppsol, poz, ptave, pview, pwv, pabcu)
-  USE dimphy
-  USE radiation_ar4_param, ONLY: tref, rt1, raer, at, bt, oct
-  USE infotrac_phy, ONLY: type_trac
-  USE lmdz_reprobus_wrappers, ONLY: rch42d, rn2o2d, rcfc112d, rcfc122d, ok_rtime2d
-  USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_REPROBUS
-
-  IMPLICIT NONE
-  include "raddimlw.h"
-  include "YOMCST.h"
-  include "radepsi.h"
-  include "radopt.h"
-
-  ! PURPOSE.
-  ! --------
-  ! COMPUTES ABSORBER AMOUNTS INCLUDING PRESSURE AND
-  ! TEMPERATURE EFFECTS
-
-  ! METHOD.
-  ! -------
-
-  ! 1. COMPUTES THE PRESSURE AND TEMPERATURE WEIGHTED AMOUNTS OF
-  ! ABSORBERS.
-
-
-  ! REFERENCE.
-  ! ----------
-
-  ! SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
-  ! ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
-
-  ! AUTHOR.
-  ! -------
-  ! JEAN-JACQUES MORCRETTE  *ECMWF*
-
-  ! MODIFICATIONS.
-  ! --------------
-  ! ORIGINAL : 89-07-14
-  ! Voigt lines (loop 404 modified) - JJM & PhD - 01/96
-  ! -----------------------------------------------------------------------
-  ! * ARGUMENTS:
-  ! IM ctes ds clesphys.h
-  ! REAL(KIND=8) RCO2
-  ! REAL(KIND=8) RCH4, RN2O, RCFC11, RCFC12
-  include "clesphys.h"
-  REAL (KIND=8) paer(kdlon, kflev, 5)
-  REAL (KIND=8) pdp(kdlon, kflev)
-  REAL (KIND=8) ppmb(kdlon, kflev+1)
-  REAL (KIND=8) ppsol(kdlon)
-  REAL (KIND=8) poz(kdlon, kflev)
-  REAL (KIND=8) ptave(kdlon, kflev)
-  REAL (KIND=8) pview(kdlon)
-  REAL (KIND=8) pwv(kdlon, kflev)
-
-  REAL (KIND=8) pabcu(kdlon, nua, 3*kflev+1) ! EFFECTIVE ABSORBER AMOUNTS
-
-  ! -----------------------------------------------------------------------
-  ! * LOCAL VARIABLES:
-  REAL (KIND=8) zably(kdlon, nua, 3*kflev+1)
-  REAL (KIND=8) zduc(kdlon, 3*kflev+1)
-  REAL (KIND=8) zphio(kdlon)
-  REAL (KIND=8) zpsc2(kdlon)
-  REAL (KIND=8) zpsc3(kdlon)
-  REAL (KIND=8) zpsh1(kdlon)
-  REAL (KIND=8) zpsh2(kdlon)
-  REAL (KIND=8) zpsh3(kdlon)
-  REAL (KIND=8) zpsh4(kdlon)
-  REAL (KIND=8) zpsh5(kdlon)
-  REAL (KIND=8) zpsh6(kdlon)
-  REAL (KIND=8) zpsio(kdlon)
-  REAL (KIND=8) ztcon(kdlon)
-  REAL (KIND=8) zphm6(kdlon)
-  REAL (KIND=8) zpsm6(kdlon)
-  REAL (KIND=8) zphn6(kdlon)
-  REAL (KIND=8) zpsn6(kdlon)
-  REAL (KIND=8) zssig(kdlon, 3*kflev+1)
-  REAL (KIND=8) ztavi(kdlon)
-  REAL (KIND=8) zuaer(kdlon, ninter)
-  REAL (KIND=8) zxoz(kdlon)
-  REAL (KIND=8) zxwv(kdlon)
-
-  INTEGER jl, jk, jkj, jkjr, jkjp, ig1
-  INTEGER jki, jkip1, ja, jj
-  INTEGER jkl, jkp1, jkk, jkjpn
-  INTEGER jae1, jae2, jae3, jae, jjpn
-  INTEGER ir, jc, jcp1
-  REAL (KIND=8) zdpm, zupm, zupmh2o, zupmco2, zupmo3, zu6, zup
-  REAL (KIND=8) zfppw, ztx, ztx2, zzably
-  REAL (KIND=8) zcah1, zcbh1, zcah2, zcbh2, zcah3, zcbh3
-  REAL (KIND=8) zcah4, zcbh4, zcah5, zcbh5, zcah6, zcbh6
-  REAL (KIND=8) zcac8, zcbc8
-  REAL (KIND=8) zalup, zdiff
-
-  REAL (KIND=8) pvgco2, pvgh2o, pvgo3
-
-  REAL (KIND=8) r10e ! DECIMAL/NATURAL LOG.FACTOR
-  PARAMETER (r10e=0.4342945)
-
-  ! -----------------------------------------------------------------------
-
-  IF (levoigt) THEN
-    pvgco2 = 60.
-    pvgh2o = 30.
-    pvgo3 = 400.
-  ELSE
-    pvgco2 = 0.
-    pvgh2o = 0.
-    pvgo3 = 0.
-  END IF
-
-  ! *         2.    PRESSURE OVER GAUSS SUB-LEVELS
-  ! ------------------------------
-
-
-  DO jl = 1, kdlon
-    zssig(jl, 1) = ppmb(jl, 1)*100.
-  END DO
-
-  DO jk = 1, kflev
-    jkj = (jk-1)*ng1p1 + 1
-    jkjr = jkj
-    jkjp = jkj + ng1p1
-    DO jl = 1, kdlon
-      zssig(jl, jkjp) = ppmb(jl, jk+1)*100.
-    END DO
-    DO ig1 = 1, ng1
-      jkj = jkj + 1
-      DO jl = 1, kdlon
-        zssig(jl, jkj) = (zssig(jl,jkjr)+zssig(jl,jkjp))*0.5 + &
-          rt1(ig1)*(zssig(jl,jkjp)-zssig(jl,jkjr))*0.5
-      END DO
-    END DO
-  END DO
-
-  ! -----------------------------------------------------------------------
-
-
-  ! *         4.    PRESSURE THICKNESS AND MEAN PRESSURE OF SUB-LAYERS
-  ! --------------------------------------------------
-
-
-  DO jki = 1, 3*kflev
-    jkip1 = jki + 1
-    DO jl = 1, kdlon
-      zably(jl, 5, jki) = (zssig(jl,jki)+zssig(jl,jkip1))*0.5
-      zably(jl, 3, jki) = (zssig(jl,jki)-zssig(jl,jkip1))/(10.*rg)
-    END DO
-  END DO
-
-  DO jk = 1, kflev
-    jkp1 = jk + 1
-    jkl = kflev + 1 - jk
-    DO jl = 1, kdlon
-      zxwv(jl) = max(pwv(jl,jk), zepscq)
-      zxoz(jl) = max(poz(jl,jk)/pdp(jl,jk), zepsco)
-    END DO
-    jkj = (jk-1)*ng1p1 + 1
-    jkjpn = jkj + ng1
-    DO jkk = jkj, jkjpn
-      DO jl = 1, kdlon
-        zdpm = zably(jl, 3, jkk)
-        zupm = zably(jl, 5, jkk)*zdpm/101325.
-        zupmco2 = (zably(jl,5,jkk)+pvgco2)*zdpm/101325.
-        zupmh2o = (zably(jl,5,jkk)+pvgh2o)*zdpm/101325.
-        zupmo3 = (zably(jl,5,jkk)+pvgo3)*zdpm/101325.
-        zduc(jl, jkk) = zdpm
-        zably(jl, 12, jkk) = zxoz(jl)*zdpm
-        zably(jl, 13, jkk) = zxoz(jl)*zupmo3
-        zu6 = zxwv(jl)*zupm
-        zfppw = 1.6078*zxwv(jl)/(1.+0.608*zxwv(jl))
-        zably(jl, 6, jkk) = zxwv(jl)*zupmh2o
-        zably(jl, 11, jkk) = zu6*zfppw
-        zably(jl, 10, jkk) = zu6*(1.-zfppw)
-        zably(jl, 9, jkk) = rco2*zupmco2
-        zably(jl, 8, jkk) = rco2*zdpm
-      END DO
-    END DO
-  END DO
-
-  ! -----------------------------------------------------------------------
-
-
-  ! *         5.    CUMULATIVE ABSORBER AMOUNTS FROM TOP OF ATMOSPHERE
-  ! --------------------------------------------------
-
-
-  DO ja = 1, nua
-    DO jl = 1, kdlon
-      pabcu(jl, ja, 3*kflev+1) = 0.
-    END DO
-  END DO
-
-  DO jk = 1, kflev
-    jj = (jk-1)*ng1p1 + 1
-    jjpn = jj + ng1
-    jkl = kflev + 1 - jk
-
-    ! *         5.1  CUMULATIVE AEROSOL AMOUNTS FROM TOP OF ATMOSPHERE
-    ! --------------------------------------------------
-
-
-    jae1 = 3*kflev + 1 - jj
-    jae2 = 3*kflev + 1 - (jj+1)
-    jae3 = 3*kflev + 1 - jjpn
-    DO jae = 1, 5
-      DO jl = 1, kdlon
-        zuaer(jl, jae) = (raer(jae,1)*paer(jl,jkl,1)+raer(jae,2)*paer(jl,jkl, &
-          2)+raer(jae,3)*paer(jl,jkl,3)+raer(jae,4)*paer(jl,jkl,4)+ &
-          raer(jae,5)*paer(jl,jkl,5))/(zduc(jl,jae1)+zduc(jl,jae2)+zduc(jl, &
-          jae3))
-      END DO
-    END DO
-
-    ! *         5.2  INTRODUCES TEMPERATURE EFFECTS ON ABSORBER AMOUNTS
-    ! --------------------------------------------------
-
-
-    DO jl = 1, kdlon
-      ztavi(jl) = ptave(jl, jkl)
-      ztcon(jl) = exp(6.08*(296./ztavi(jl)-1.))
-      ztx = ztavi(jl) - tref
-      ztx2 = ztx*ztx
-      zzably = zably(jl, 6, jae1) + zably(jl, 6, jae2) + zably(jl, 6, jae3)
-      zup = min(max(0.5*r10e*log(zzably)+5.,0._8), 6._8)
-      zcah1 = at(1, 1) + zup*(at(1,2)+zup*(at(1,3)))
-      zcbh1 = bt(1, 1) + zup*(bt(1,2)+zup*(bt(1,3)))
-      zpsh1(jl) = exp(zcah1*ztx+zcbh1*ztx2)
-      zcah2 = at(2, 1) + zup*(at(2,2)+zup*(at(2,3)))
-      zcbh2 = bt(2, 1) + zup*(bt(2,2)+zup*(bt(2,3)))
-      zpsh2(jl) = exp(zcah2*ztx+zcbh2*ztx2)
-      zcah3 = at(3, 1) + zup*(at(3,2)+zup*(at(3,3)))
-      zcbh3 = bt(3, 1) + zup*(bt(3,2)+zup*(bt(3,3)))
-      zpsh3(jl) = exp(zcah3*ztx+zcbh3*ztx2)
-      zcah4 = at(4, 1) + zup*(at(4,2)+zup*(at(4,3)))
-      zcbh4 = bt(4, 1) + zup*(bt(4,2)+zup*(bt(4,3)))
-      zpsh4(jl) = exp(zcah4*ztx+zcbh4*ztx2)
-      zcah5 = at(5, 1) + zup*(at(5,2)+zup*(at(5,3)))
-      zcbh5 = bt(5, 1) + zup*(bt(5,2)+zup*(bt(5,3)))
-      zpsh5(jl) = exp(zcah5*ztx+zcbh5*ztx2)
-      zcah6 = at(6, 1) + zup*(at(6,2)+zup*(at(6,3)))
-      zcbh6 = bt(6, 1) + zup*(bt(6,2)+zup*(bt(6,3)))
-      zpsh6(jl) = exp(zcah6*ztx+zcbh6*ztx2)
-      zphm6(jl) = exp(-5.81E-4*ztx-1.13E-6*ztx2)
-      zpsm6(jl) = exp(-5.57E-4*ztx-3.30E-6*ztx2)
-      zphn6(jl) = exp(-3.46E-5*ztx+2.05E-7*ztx2)
-      zpsn6(jl) = exp(3.70E-3*ztx-2.30E-6*ztx2)
-    END DO
-
-    DO jl = 1, kdlon
-      ztavi(jl) = ptave(jl, jkl)
-      ztx = ztavi(jl) - tref
-      ztx2 = ztx*ztx
-      zzably = zably(jl, 9, jae1) + zably(jl, 9, jae2) + zably(jl, 9, jae3)
-      zalup = r10e*log(zzably)
-      zup = max(0._8, 5.0+0.5*zalup)
-      zpsc2(jl) = (ztavi(jl)/tref)**zup
-      zcac8 = at(8, 1) + zup*(at(8,2)+zup*(at(8,3)))
-      zcbc8 = bt(8, 1) + zup*(bt(8,2)+zup*(bt(8,3)))
-      zpsc3(jl) = exp(zcac8*ztx+zcbc8*ztx2)
-      zphio(jl) = exp(oct(1)*ztx+oct(2)*ztx2)
-      zpsio(jl) = exp(2.*(oct(3)*ztx+oct(4)*ztx2))
-    END DO
-
-    DO jkk = jj, jjpn
-      jc = 3*kflev + 1 - jkk
-      jcp1 = jc + 1
-      DO jl = 1, kdlon
-        zdiff = pview(jl)
-        pabcu(jl, 10, jc) = pabcu(jl, 10, jcp1) + zably(jl, 10, jc)*zdiff
-        pabcu(jl, 11, jc) = pabcu(jl, 11, jcp1) + zably(jl, 11, jc)*ztcon(jl) &
-          *zdiff
-
-        pabcu(jl, 12, jc) = pabcu(jl, 12, jcp1) + zably(jl, 12, jc)*zphio(jl) &
-          *zdiff
-        pabcu(jl, 13, jc) = pabcu(jl, 13, jcp1) + zably(jl, 13, jc)*zpsio(jl) &
-          *zdiff
-
-        pabcu(jl, 7, jc) = pabcu(jl, 7, jcp1) + zably(jl, 9, jc)*zpsc2(jl)* &
-          zdiff
-        pabcu(jl, 8, jc) = pabcu(jl, 8, jcp1) + zably(jl, 9, jc)*zpsc3(jl)* &
-          zdiff
-        pabcu(jl, 9, jc) = pabcu(jl, 9, jcp1) + zably(jl, 9, jc)*zpsc3(jl)* &
-          zdiff
-
-        pabcu(jl, 1, jc) = pabcu(jl, 1, jcp1) + zably(jl, 6, jc)*zpsh1(jl)* &
-          zdiff
-        pabcu(jl, 2, jc) = pabcu(jl, 2, jcp1) + zably(jl, 6, jc)*zpsh2(jl)* &
-          zdiff
-        pabcu(jl, 3, jc) = pabcu(jl, 3, jcp1) + zably(jl, 6, jc)*zpsh5(jl)* &
-          zdiff
-        pabcu(jl, 4, jc) = pabcu(jl, 4, jcp1) + zably(jl, 6, jc)*zpsh3(jl)* &
-          zdiff
-        pabcu(jl, 5, jc) = pabcu(jl, 5, jcp1) + zably(jl, 6, jc)*zpsh4(jl)* &
-          zdiff
-        pabcu(jl, 6, jc) = pabcu(jl, 6, jcp1) + zably(jl, 6, jc)*zpsh6(jl)* &
-          zdiff
-
-        pabcu(jl, 14, jc) = pabcu(jl, 14, jcp1) + zuaer(jl, 1)*zduc(jl, jc)* &
-          zdiff
-        pabcu(jl, 15, jc) = pabcu(jl, 15, jcp1) + zuaer(jl, 2)*zduc(jl, jc)* &
-          zdiff
-        pabcu(jl, 16, jc) = pabcu(jl, 16, jcp1) + zuaer(jl, 3)*zduc(jl, jc)* &
-          zdiff
-        pabcu(jl, 17, jc) = pabcu(jl, 17, jcp1) + zuaer(jl, 4)*zduc(jl, jc)* &
-          zdiff
-        pabcu(jl, 18, jc) = pabcu(jl, 18, jcp1) + zuaer(jl, 5)*zduc(jl, jc)* &
-          zdiff
-
-
-
-        IF (type_trac=='repr') THEN
-IF (CPPKEY_REPROBUS) THEN
-          IF (ok_rtime2d) THEN
-            pabcu(jl, 19, jc) = pabcu(jl, 19, jcp1) + &
-              zably(jl, 8, jc)*rch42d(jl, jc)/rco2*zphm6(jl)*zdiff
-            pabcu(jl, 20, jc) = pabcu(jl, 20, jcp1) + &
-              zably(jl, 9, jc)*rch42d(jl, jc)/rco2*zpsm6(jl)*zdiff
-            pabcu(jl, 21, jc) = pabcu(jl, 21, jcp1) + &
-              zably(jl, 8, jc)*rn2o2d(jl, jc)/rco2*zphn6(jl)*zdiff
-            pabcu(jl, 22, jc) = pabcu(jl, 22, jcp1) + &
-              zably(jl, 9, jc)*rn2o2d(jl, jc)/rco2*zpsn6(jl)*zdiff
-
-            pabcu(jl, 23, jc) = pabcu(jl, 23, jcp1) + &
-              zably(jl, 8, jc)*rcfc112d(jl, jc)/rco2*zdiff
-            pabcu(jl, 24, jc) = pabcu(jl, 24, jcp1) + &
-              zably(jl, 8, jc)*rcfc122d(jl, jc)/rco2*zdiff
-          ELSE
-              ! Same calculation as for type_trac /= repr
-            pabcu(jl, 19, jc) = pabcu(jl, 19, jcp1) + &
-              zably(jl, 8, jc)*rch4/rco2*zphm6(jl)*zdiff
-            pabcu(jl, 20, jc) = pabcu(jl, 20, jcp1) + &
-              zably(jl, 9, jc)*rch4/rco2*zpsm6(jl)*zdiff
-            pabcu(jl, 21, jc) = pabcu(jl, 21, jcp1) + &
-              zably(jl, 8, jc)*rn2o/rco2*zphn6(jl)*zdiff
-            pabcu(jl, 22, jc) = pabcu(jl, 22, jcp1) + &
-              zably(jl, 9, jc)*rn2o/rco2*zpsn6(jl)*zdiff
-
-            pabcu(jl, 23, jc) = pabcu(jl, 23, jcp1) + &
-              zably(jl, 8, jc)*rcfc11/rco2*zdiff
-            pabcu(jl, 24, jc) = pabcu(jl, 24, jcp1) + &
-              zably(jl, 8, jc)*rcfc12/rco2*zdiff
-          END IF
-END IF
-        ELSE
-          pabcu(jl, 19, jc) = pabcu(jl, 19, jcp1) + &
-            zably(jl, 8, jc)*rch4/rco2*zphm6(jl)*zdiff
-          pabcu(jl, 20, jc) = pabcu(jl, 20, jcp1) + &
-            zably(jl, 9, jc)*rch4/rco2*zpsm6(jl)*zdiff
-          pabcu(jl, 21, jc) = pabcu(jl, 21, jcp1) + &
-            zably(jl, 8, jc)*rn2o/rco2*zphn6(jl)*zdiff
-          pabcu(jl, 22, jc) = pabcu(jl, 22, jcp1) + &
-            zably(jl, 9, jc)*rn2o/rco2*zpsn6(jl)*zdiff
-
-          pabcu(jl, 23, jc) = pabcu(jl, 23, jcp1) + &
-            zably(jl, 8, jc)*rcfc11/rco2*zdiff
-          pabcu(jl, 24, jc) = pabcu(jl, 24, jcp1) + &
-            zably(jl, 8, jc)*rcfc12/rco2*zdiff
-        END IF
-
-      END DO
-    END DO
-
-  END DO
-
-
-  RETURN
-END SUBROUTINE lwu_lmdar4
-SUBROUTINE lwbv_lmdar4(klim, pdp, pdt0, pemis, ppmb, ptl, ptave, pabcu, &
-    pfluc, pbint, pbsui, pcts, pcntrb)
-  USE dimphy
-  IMPLICIT NONE
-  include "raddimlw.h"
-  include "YOMCST.h"
-
-  ! PURPOSE.
-  ! --------
-  ! TO COMPUTE THE PLANCK FUNCTION AND PERFORM THE
-  ! VERTICAL INTEGRATION. SPLIT OUT FROM LW FOR MEMORY
-  ! SAVING
-
-  ! METHOD.
-  ! -------
-
-  ! 1. COMPUTES THE PLANCK FUNCTIONS ON THE INTERFACES AND THE
-  ! GRADIENT OF PLANCK FUNCTIONS IN THE LAYERS.
-  ! 2. PERFORMS THE VERTICAL INTEGRATION DISTINGUISHING THE CON-
-  ! TRIBUTIONS OF THE ADJACENT AND DISTANT LAYERS AND THOSE FROM THE
-  ! BOUNDARIES.
-  ! 3. COMPUTES THE CLEAR-SKY COOLING RATES.
-
-  ! REFERENCE.
-  ! ----------
-
-  ! SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
-  ! ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
-
-  ! AUTHOR.
-  ! -------
-  ! JEAN-JACQUES MORCRETTE  *ECMWF*
-
-  ! MODIFICATIONS.
-  ! --------------
-  ! ORIGINAL : 89-07-14
-  ! MODIFICATION : 93-10-15 M.HAMRUD (SPLIT OUT FROM LW TO SAVE
-  ! MEMORY)
-  ! -----------------------------------------------------------------------
-  ! * ARGUMENTS:
-  INTEGER klim
-
-  REAL (KIND=8) pdp(kdlon, kflev)
-  REAL (KIND=8) pdt0(kdlon)
-  REAL (KIND=8) pemis(kdlon)
-  REAL (KIND=8) ppmb(kdlon, kflev+1)
-  REAL (KIND=8) ptl(kdlon, kflev+1)
-  REAL (KIND=8) ptave(kdlon, kflev)
-
-  REAL (KIND=8) pfluc(kdlon, 2, kflev+1)
-
-  REAL (KIND=8) pabcu(kdlon, nua, 3*kflev+1)
-  REAL (KIND=8) pbint(kdlon, kflev+1)
-  REAL (KIND=8) pbsui(kdlon)
-  REAL (KIND=8) pcts(kdlon, kflev)
-  REAL (KIND=8) pcntrb(kdlon, kflev+1, kflev+1)
-
-  ! -------------------------------------------------------------------------
-
-  ! * LOCAL VARIABLES:
-  REAL (KIND=8) zb(kdlon, ninter, kflev+1)
-  REAL (KIND=8) zbsur(kdlon, ninter)
-  REAL (KIND=8) zbtop(kdlon, ninter)
-  REAL (KIND=8) zdbsl(kdlon, ninter, kflev*2)
-  REAL (KIND=8) zga(kdlon, 8, 2, kflev)
-  REAL (KIND=8) zgb(kdlon, 8, 2, kflev)
-  REAL (KIND=8) zgasur(kdlon, 8, 2)
-  REAL (KIND=8) zgbsur(kdlon, 8, 2)
-  REAL (KIND=8) zgatop(kdlon, 8, 2)
-  REAL (KIND=8) zgbtop(kdlon, 8, 2)
-
-  INTEGER nuaer, ntraer
-  ! ------------------------------------------------------------------
-  ! * COMPUTES PLANCK FUNCTIONS:
-  CALL lwb_lmdar4(pdt0, ptave, ptl, zb, pbint, pbsui, zbsur, zbtop, zdbsl, &
-    zga, zgb, zgasur, zgbsur, zgatop, zgbtop)
-  ! ------------------------------------------------------------------
-  ! * PERFORMS THE VERTICAL INTEGRATION:
-  nuaer = nua
-  ntraer = ntra
-  CALL lwv_lmdar4(nuaer, ntraer, klim, pabcu, zb, pbint, pbsui, zbsur, zbtop, &
-    zdbsl, pemis, ppmb, ptave, zga, zgb, zgasur, zgbsur, zgatop, zgbtop, &
-    pcntrb, pcts, pfluc)
-  ! ------------------------------------------------------------------
-  RETURN
-END SUBROUTINE lwbv_lmdar4
-SUBROUTINE lwc_lmdar4(klim, pcldld, pcldlu, pemis, pfluc, pbint, pbsuin, &
-    pcts, pcntrb, pflux)
-  USE dimphy
-  IMPLICIT NONE
-  include "radepsi.h"
-  include "radopt.h"
-
-  ! PURPOSE.
-  ! --------
-  ! INTRODUCES CLOUD EFFECTS ON LONGWAVE FLUXES OR
-  ! RADIANCES
-
-  ! EXPLICIT ARGUMENTS :
-  ! --------------------
-  ! ==== INPUTS ===
-  ! PBINT  : (KDLON,0:KFLEV)     ; HALF LEVEL PLANCK FUNCTION
-  ! PBSUIN : (KDLON)             ; SURFACE PLANCK FUNCTION
-  ! PCLDLD : (KDLON,KFLEV)       ; DOWNWARD EFFECTIVE CLOUD FRACTION
-  ! PCLDLU : (KDLON,KFLEV)       ; UPWARD EFFECTIVE CLOUD FRACTION
-  ! PCNTRB : (KDLON,KFLEV+1,KFLEV+1); CLEAR-SKY ENERGY EXCHANGE
-  ! PCTS   : (KDLON,KFLEV)       ; CLEAR-SKY LAYER COOLING-TO-SPACE
-  ! PEMIS  : (KDLON)             ; SURFACE EMISSIVITY
-  ! PFLUC
-  ! ==== OUTPUTS ===
-  ! PFLUX(KDLON,2,KFLEV)         ; RADIATIVE FLUXES :
-  ! 1  ==>  UPWARD   FLUX TOTAL
-  ! 2  ==>  DOWNWARD FLUX TOTAL
-
-  ! METHOD.
-  ! -------
-
-  ! 1. INITIALIZES ALL FLUXES TO CLEAR-SKY VALUES
-  ! 2. EFFECT OF ONE OVERCAST UNITY EMISSIVITY CLOUD LAYER
-  ! 3. EFFECT OF SEMI-TRANSPARENT, PARTIAL OR MULTI-LAYERED
-  ! CLOUDS
-
-  ! REFERENCE.
-  ! ----------
-
-  ! SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
-  ! ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
-
-  ! AUTHOR.
-  ! -------
-  ! JEAN-JACQUES MORCRETTE  *ECMWF*
-
-  ! MODIFICATIONS.
-  ! --------------
-  ! ORIGINAL : 89-07-14
-  ! Voigt lines (loop 231 to 233)  - JJM & PhD - 01/96
-  ! -----------------------------------------------------------------------
-  ! * ARGUMENTS:
-  INTEGER klim
-  REAL (KIND=8) pfluc(kdlon, 2, kflev+1) ! CLEAR-SKY RADIATIVE FLUXES
-  REAL (KIND=8) pbint(kdlon, kflev+1) ! HALF LEVEL PLANCK FUNCTION
-  REAL (KIND=8) pbsuin(kdlon) ! SURFACE PLANCK FUNCTION
-  REAL (KIND=8) pcntrb(kdlon, kflev+1, kflev+1) !CLEAR-SKY ENERGY EXCHANGE
-  REAL (KIND=8) pcts(kdlon, kflev) ! CLEAR-SKY LAYER COOLING-TO-SPACE
-
-  REAL (KIND=8) pcldld(kdlon, kflev)
-  REAL (KIND=8) pcldlu(kdlon, kflev)
-  REAL (KIND=8) pemis(kdlon)
-
-  REAL (KIND=8) pflux(kdlon, 2, kflev+1)
-  ! -----------------------------------------------------------------------
-  ! * LOCAL VARIABLES:
-  INTEGER imx(kdlon), imxp(kdlon)
-
-  REAL (KIND=8) zclear(kdlon), zcloud(kdlon), zdnf(kdlon, kflev+1, kflev+1), &
-    zfd(kdlon), zfn10(kdlon), zfu(kdlon), zupf(kdlon, kflev+1, kflev+1)
-  REAL (KIND=8) zclm(kdlon, kflev+1, kflev+1)
-
-  INTEGER jk, jl, imaxc, imx1, imx2, jkj, jkp1, jkm1
-  INTEGER jk1, jk2, jkc, jkcp1, jcloud
-  INTEGER imxm1, imxp1
-  REAL (KIND=8) zcfrac
-
-  ! ------------------------------------------------------------------
-
-  ! *         1.     INITIALIZATION
-  ! --------------
-
-
-  imaxc = 0
-
-  DO jl = 1, kdlon
-    imx(jl) = 0
-    imxp(jl) = 0
-    zcloud(jl) = 0.
-  END DO
-
-  ! *         1.1    SEARCH THE LAYER INDEX OF THE HIGHEST CLOUD
-  ! -------------------------------------------
-
-
-  DO jk = 1, kflev
-    DO jl = 1, kdlon
-      imx1 = imx(jl)
-      imx2 = jk
-      IF (pcldlu(jl,jk)>zepsc) THEN
-        imxp(jl) = imx2
-      ELSE
-        imxp(jl) = imx1
-      END IF
-      imaxc = max(imxp(jl), imaxc)
-      imx(jl) = imxp(jl)
-    END DO
-  END DO
-  ! GM*******
-  imaxc = kflev
-  ! GM*******
-
-  DO jk = 1, kflev + 1
-    DO jl = 1, kdlon
-      pflux(jl, 1, jk) = pfluc(jl, 1, jk)
-      pflux(jl, 2, jk) = pfluc(jl, 2, jk)
-    END DO
-  END DO
-
-  ! ------------------------------------------------------------------
-
-  ! *         2.      EFFECT OF CLOUDINESS ON LONGWAVE FLUXES
-  ! ---------------------------------------
-
-  IF (imaxc>0) THEN
-
-    imxp1 = imaxc + 1
-    imxm1 = imaxc - 1
-
-    ! *         2.0     INITIALIZE TO CLEAR-SKY FLUXES
-    ! ------------------------------
-
-
-    DO jk1 = 1, kflev + 1
-      DO jk2 = 1, kflev + 1
-        DO jl = 1, kdlon
-          zupf(jl, jk2, jk1) = pfluc(jl, 1, jk1)
-          zdnf(jl, jk2, jk1) = pfluc(jl, 2, jk1)
-        END DO
-      END DO
-    END DO
-
-    ! *         2.1     FLUXES FOR ONE OVERCAST UNITY EMISSIVITY CLOUD
-    ! ----------------------------------------------
-
-
-    DO jkc = 1, imaxc
-      jcloud = jkc
-      jkcp1 = jcloud + 1
-
-      ! *         2.1.1   ABOVE THE CLOUD
-      ! ---------------
-
-
-      DO jk = jkcp1, kflev + 1
-        jkm1 = jk - 1
-        DO jl = 1, kdlon
-          zfu(jl) = 0.
-        END DO
-        IF (jk>jkcp1) THEN
-          DO jkj = jkcp1, jkm1
-            DO jl = 1, kdlon
-              zfu(jl) = zfu(jl) + pcntrb(jl, jk, jkj)
-            END DO
-          END DO
-        END IF
-
-        DO jl = 1, kdlon
-          zupf(jl, jkcp1, jk) = pbint(jl, jk) - zfu(jl)
-        END DO
-      END DO
-
-      ! *         2.1.2   BELOW THE CLOUD
-      ! ---------------
-
-
-      DO jk = 1, jcloud
-        jkp1 = jk + 1
-        DO jl = 1, kdlon
-          zfd(jl) = 0.
-        END DO
-
-        IF (jk<jcloud) THEN
-          DO jkj = jkp1, jcloud
-            DO jl = 1, kdlon
-              zfd(jl) = zfd(jl) + pcntrb(jl, jk, jkj)
-            END DO
-          END DO
-        END IF
-        DO jl = 1, kdlon
-          zdnf(jl, jkcp1, jk) = -pbint(jl, jk) - zfd(jl)
-        END DO
-      END DO
-
-    END DO
-
-    ! *         2.2     CLOUD COVER MATRIX
-    ! ------------------
-
-    ! *    ZCLM(JK1,JK2) IS THE OBSCURATION FACTOR BY CLOUD LAYERS BETWEEN
-    ! HALF-LEVELS JK1 AND JK2 AS SEEN FROM JK1
-
-
-    DO jk1 = 1, kflev + 1
-      DO jk2 = 1, kflev + 1
-        DO jl = 1, kdlon
-          zclm(jl, jk1, jk2) = 0.
-        END DO
-      END DO
-    END DO
-
-    ! *         2.4     CLOUD COVER BELOW THE LEVEL OF CALCULATION
-    ! ------------------------------------------
-
-
-    DO jk1 = 2, kflev + 1
-      DO jl = 1, kdlon
-        zclear(jl) = 1.
-        zcloud(jl) = 0.
-      END DO
-      DO jk = jk1 - 1, 1, -1
-        DO jl = 1, kdlon
-          IF (novlp==1) THEN
-            ! * maximum-random
-            zclear(jl) = zclear(jl)*(1.0-max(pcldlu(jl, &
-              jk),zcloud(jl)))/(1.0-min(zcloud(jl),1.-zepsec))
-            zclm(jl, jk1, jk) = 1.0 - zclear(jl)
-            zcloud(jl) = pcldlu(jl, jk)
-          ELSE IF (novlp==2) THEN
-            ! * maximum
-            zcloud(jl) = max(zcloud(jl), pcldlu(jl,jk))
-            zclm(jl, jk1, jk) = zcloud(jl)
-          ELSE IF (novlp==3) THEN
-            ! * random
-            zclear(jl) = zclear(jl)*(1.0-pcldlu(jl,jk))
-            zcloud(jl) = 1.0 - zclear(jl)
-            zclm(jl, jk1, jk) = zcloud(jl)
-          END IF
-        END DO
-      END DO
-    END DO
-
-    ! *         2.5     CLOUD COVER ABOVE THE LEVEL OF CALCULATION
-    ! ------------------------------------------
-
-
-    DO jk1 = 1, kflev
-      DO jl = 1, kdlon
-        zclear(jl) = 1.
-        zcloud(jl) = 0.
-      END DO
-      DO jk = jk1, kflev
-        DO jl = 1, kdlon
-          IF (novlp==1) THEN
-            ! * maximum-random
-            zclear(jl) = zclear(jl)*(1.0-max(pcldld(jl, &
-              jk),zcloud(jl)))/(1.0-min(zcloud(jl),1.-zepsec))
-            zclm(jl, jk1, jk) = 1.0 - zclear(jl)
-            zcloud(jl) = pcldld(jl, jk)
-          ELSE IF (novlp==2) THEN
-            ! * maximum
-            zcloud(jl) = max(zcloud(jl), pcldld(jl,jk))
-            zclm(jl, jk1, jk) = zcloud(jl)
-          ELSE IF (novlp==3) THEN
-            ! * random
-            zclear(jl) = zclear(jl)*(1.0-pcldld(jl,jk))
-            zcloud(jl) = 1.0 - zclear(jl)
-            zclm(jl, jk1, jk) = zcloud(jl)
-          END IF
-        END DO
-      END DO
-    END DO
-
-    ! *         3.      FLUXES FOR PARTIAL/MULTIPLE LAYERED CLOUDINESS
-    ! ----------------------------------------------
-
-
-    ! *         3.1     DOWNWARD FLUXES
-    ! ---------------
-
-
-    DO jl = 1, kdlon
-      pflux(jl, 2, kflev+1) = 0.
-    END DO
-
-    DO jk1 = kflev, 1, -1
-
-      ! *                 CONTRIBUTION FROM CLEAR-SKY FRACTION
-
-      DO jl = 1, kdlon
-        zfd(jl) = (1.-zclm(jl,jk1,kflev))*zdnf(jl, 1, jk1)
-      END DO
-
-      ! *                 CONTRIBUTION FROM ADJACENT CLOUD
-
-      DO jl = 1, kdlon
-        zfd(jl) = zfd(jl) + zclm(jl, jk1, jk1)*zdnf(jl, jk1+1, jk1)
-      END DO
-
-      ! *                 CONTRIBUTION FROM OTHER CLOUDY FRACTIONS
-
-      DO jk = kflev - 1, jk1, -1
-        DO jl = 1, kdlon
-          zcfrac = zclm(jl, jk1, jk+1) - zclm(jl, jk1, jk)
-          zfd(jl) = zfd(jl) + zcfrac*zdnf(jl, jk+2, jk1)
-        END DO
-      END DO
-
-      DO jl = 1, kdlon
-        pflux(jl, 2, jk1) = zfd(jl)
-      END DO
-
-    END DO
-
-    ! *         3.2     UPWARD FLUX AT THE SURFACE
-    ! --------------------------
-
-
-    DO jl = 1, kdlon
-      pflux(jl, 1, 1) = pemis(jl)*pbsuin(jl) - (1.-pemis(jl))*pflux(jl, 2, 1)
-    END DO
-
-    ! *         3.3     UPWARD FLUXES
-    ! -------------
-
-
-    DO jk1 = 2, kflev + 1
-
-      ! *                 CONTRIBUTION FROM CLEAR-SKY FRACTION
-
-      DO jl = 1, kdlon
-        zfu(jl) = (1.-zclm(jl,jk1,1))*zupf(jl, 1, jk1)
-      END DO
-
-      ! *                 CONTRIBUTION FROM ADJACENT CLOUD
-
-      DO jl = 1, kdlon
-        zfu(jl) = zfu(jl) + zclm(jl, jk1, jk1-1)*zupf(jl, jk1, jk1)
-      END DO
-
-      ! *                 CONTRIBUTION FROM OTHER CLOUDY FRACTIONS
-
-      DO jk = 2, jk1 - 1
-        DO jl = 1, kdlon
-          zcfrac = zclm(jl, jk1, jk-1) - zclm(jl, jk1, jk)
-          zfu(jl) = zfu(jl) + zcfrac*zupf(jl, jk, jk1)
-        END DO
-      END DO
-
-      DO jl = 1, kdlon
-        pflux(jl, 1, jk1) = zfu(jl)
-      END DO
-
-    END DO
-
-
-  END IF
-
-  ! *         2.3     END OF CLOUD EFFECT COMPUTATIONS
-
-
-  IF (.NOT. levoigt) THEN
-    DO jl = 1, kdlon
-      zfn10(jl) = pflux(jl, 1, klim) + pflux(jl, 2, klim)
-    END DO
-    DO jk = klim + 1, kflev + 1
-      DO jl = 1, kdlon
-        zfn10(jl) = zfn10(jl) + pcts(jl, jk-1)
-        pflux(jl, 1, jk) = zfn10(jl)
-        pflux(jl, 2, jk) = 0.0
-      END DO
-    END DO
-  END IF
-
-  RETURN
-END SUBROUTINE lwc_lmdar4
-SUBROUTINE lwb_lmdar4(pdt0, ptave, ptl, pb, pbint, pbsuin, pbsur, pbtop, &
-    pdbsl, pga, pgb, pgasur, pgbsur, pgatop, pgbtop)
-  USE dimphy
-  USE radiation_ar4_param, ONLY: tintp, xp, ga, gb
-  IMPLICIT NONE
-  include "raddimlw.h"
-
-  ! -----------------------------------------------------------------------
-  ! PURPOSE.
-  ! --------
-  ! COMPUTES PLANCK FUNCTIONS
-
-  ! EXPLICIT ARGUMENTS :
-  ! --------------------
-  ! ==== INPUTS ===
-  ! PDT0   : (KDLON)             ; SURFACE TEMPERATURE DISCONTINUITY
-  ! PTAVE  : (KDLON,KFLEV)       ; TEMPERATURE
-  ! PTL    : (KDLON,0:KFLEV)     ; HALF LEVEL TEMPERATURE
-  ! ==== OUTPUTS ===
-  ! PB     : (KDLON,Ninter,KFLEV+1); SPECTRAL HALF LEVEL PLANCK FUNCTION
-  ! PBINT  : (KDLON,KFLEV+1)     ; HALF LEVEL PLANCK FUNCTION
-  ! PBSUIN : (KDLON)             ; SURFACE PLANCK FUNCTION
-  ! PBSUR  : (KDLON,Ninter)        ; SURFACE SPECTRAL PLANCK FUNCTION
-  ! PBTOP  : (KDLON,Ninter)        ; TOP SPECTRAL PLANCK FUNCTION
-  ! PDBSL  : (KDLON,Ninter,KFLEV*2); SUB-LAYER PLANCK FUNCTION GRADIENT
-  ! PGA    : (KDLON,8,2,KFLEV); dB/dT-weighted LAYER PADE APPROXIMANTS
-  ! PGB    : (KDLON,8,2,KFLEV); dB/dT-weighted LAYER PADE APPROXIMANTS
-  ! PGASUR, PGBSUR (KDLON,8,2)   ; SURFACE PADE APPROXIMANTS
-  ! PGATOP, PGBTOP (KDLON,8,2)   ; T.O.A. PADE APPROXIMANTS
-
-  ! IMPLICIT ARGUMENTS :   NONE
-  ! --------------------
-
-  ! METHOD.
-  ! -------
-
-  ! 1. COMPUTES THE PLANCK FUNCTION ON ALL LEVELS AND HALF LEVELS
-  ! FROM A POLYNOMIAL DEVELOPMENT OF PLANCK FUNCTION
-
-  ! REFERENCE.
-  ! ----------
-
-  ! SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
-  ! ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS           "
-
-  ! AUTHOR.
-  ! -------
-  ! JEAN-JACQUES MORCRETTE  *ECMWF*
-
-  ! MODIFICATIONS.
-  ! --------------
-  ! ORIGINAL : 89-07-14
-
-  ! -----------------------------------------------------------------------
-
-  ! ARGUMENTS:
-
-  REAL (KIND=8) pdt0(kdlon)
-  REAL (KIND=8) ptave(kdlon, kflev)
-  REAL (KIND=8) ptl(kdlon, kflev+1)
-
-  REAL (KIND=8) pb(kdlon, ninter, kflev+1) ! SPECTRAL HALF LEVEL PLANCK FUNCTION
-  REAL (KIND=8) pbint(kdlon, kflev+1) ! HALF LEVEL PLANCK FUNCTION
-  REAL (KIND=8) pbsuin(kdlon) ! SURFACE PLANCK FUNCTION
-  REAL (KIND=8) pbsur(kdlon, ninter) ! SURFACE SPECTRAL PLANCK FUNCTION
-  REAL (KIND=8) pbtop(kdlon, ninter) ! TOP SPECTRAL PLANCK FUNCTION
-  REAL (KIND=8) pdbsl(kdlon, ninter, kflev*2) ! SUB-LAYER PLANCK FUNCTION GRADIENT
-  REAL (KIND=8) pga(kdlon, 8, 2, kflev) ! dB/dT-weighted LAYER PADE APPROXIMANTS
-  REAL (KIND=8) pgb(kdlon, 8, 2, kflev) ! dB/dT-weighted LAYER PADE APPROXIMANTS
-  REAL (KIND=8) pgasur(kdlon, 8, 2) ! SURFACE PADE APPROXIMANTS
-  REAL (KIND=8) pgbsur(kdlon, 8, 2) ! SURFACE PADE APPROXIMANTS
-  REAL (KIND=8) pgatop(kdlon, 8, 2) ! T.O.A. PADE APPROXIMANTS
-  REAL (KIND=8) pgbtop(kdlon, 8, 2) ! T.O.A. PADE APPROXIMANTS
-
-  ! -------------------------------------------------------------------------
-  ! *  LOCAL VARIABLES:
-  INTEGER indb(kdlon), inds(kdlon)
-  REAL (KIND=8) zblay(kdlon, kflev), zblev(kdlon, kflev+1)
-  REAL (KIND=8) zres(kdlon), zres2(kdlon), zti(kdlon), zti2(kdlon)
-
-  INTEGER jk, jl, ic, jnu, jf, jg
-  INTEGER jk1, jk2
-  INTEGER k, j, ixtox, indto, ixtx, indt
-  INTEGER indsu, indtp
-  REAL (KIND=8) zdsto1, zdstox, zdst1, zdstx
-
-  ! * Quelques parametres:
-  REAL (KIND=8) tstand
-  PARAMETER (tstand=250.0)
-  REAL (KIND=8) tstp
-  PARAMETER (tstp=12.5)
-  INTEGER mxixt
-  PARAMETER (mxixt=10)
-
-  ! * Used Data Block:
-  ! REAL*8 TINTP(11)
-  ! SAVE TINTP
-  ! c$OMP THREADPRIVATE(TINTP)
-  ! REAL*8 GA(11,16,3), GB(11,16,3)
-  ! SAVE GA, GB
-  ! c$OMP THREADPRIVATE(GA, GB)
-  ! REAL*8 XP(6,6)
-  ! SAVE XP
-  ! c$OMP THREADPRIVATE(XP)
-
-  ! DATA TINTP / 187.5, 200., 212.5, 225., 237.5, 250.,
-  ! S             262.5, 275., 287.5, 300., 312.5 /
-  ! -----------------------------------------------------------------------
-  ! -- WATER VAPOR -- INT.1 -- 0- 500 CM-1 -- FROM ABS225 ----------------
-
-
-
-
-  ! -- R.D. -- G = - 0.2 SLA
-
-
-  ! ----- INTERVAL = 1 ----- T =  187.5
-
-  ! -- INDICES FOR PADE APPROXIMATION     1   15   29   45
-  ! DATA (GA( 1, 1,IC),IC=1,3) /
-  ! S 0.63499072E-02,-0.99506586E-03, 0.00000000E+00/
-  ! DATA (GB( 1, 1,IC),IC=1,3) /
-  ! S 0.63499072E-02, 0.97222852E-01, 0.10000000E+01/
-  ! DATA (GA( 1, 2,IC),IC=1,3) /
-  ! S 0.77266491E-02,-0.11661515E-02, 0.00000000E+00/
-  ! DATA (GB( 1, 2,IC),IC=1,3) /
-  ! S 0.77266491E-02, 0.10681591E+00, 0.10000000E+01/
-
-  ! ----- INTERVAL = 1 ----- T =  200.0
-
-  ! -- INDICES FOR PADE APPROXIMATION     1   15   29   45
-  ! DATA (GA( 2, 1,IC),IC=1,3) /
-  ! S 0.65566348E-02,-0.10184169E-02, 0.00000000E+00/
-  ! DATA (GB( 2, 1,IC),IC=1,3) /
-  ! S 0.65566348E-02, 0.98862238E-01, 0.10000000E+01/
-  ! DATA (GA( 2, 2,IC),IC=1,3) /
-  ! S 0.81323287E-02,-0.11886130E-02, 0.00000000E+00/
-  ! DATA (GB( 2, 2,IC),IC=1,3) /
-  ! S 0.81323287E-02, 0.10921298E+00, 0.10000000E+01/
-
-  ! ----- INTERVAL = 1 ----- T =  212.5
-
-  ! -- INDICES FOR PADE APPROXIMATION     1   15   29   45
-  ! DATA (GA( 3, 1,IC),IC=1,3) /
-  ! S 0.67849730E-02,-0.10404730E-02, 0.00000000E+00/
-  ! DATA (GB( 3, 1,IC),IC=1,3) /
-  ! S 0.67849730E-02, 0.10061504E+00, 0.10000000E+01/
-  ! DATA (GA( 3, 2,IC),IC=1,3) /
-  ! S 0.86507620E-02,-0.12139929E-02, 0.00000000E+00/
-  ! DATA (GB( 3, 2,IC),IC=1,3) /
-  ! S 0.86507620E-02, 0.11198225E+00, 0.10000000E+01/
-
-  ! ----- INTERVAL = 1 ----- T =  225.0
-
-  ! -- INDICES FOR PADE APPROXIMATION     1   15   29   45
-  ! DATA (GA( 4, 1,IC),IC=1,3) /
-  ! S 0.70481947E-02,-0.10621792E-02, 0.00000000E+00/
-  ! DATA (GB( 4, 1,IC),IC=1,3) /
-  ! S 0.70481947E-02, 0.10256222E+00, 0.10000000E+01/
-  ! DATA (GA( 4, 2,IC),IC=1,3) /
-  ! S 0.92776391E-02,-0.12445811E-02, 0.00000000E+00/
-  ! DATA (GB( 4, 2,IC),IC=1,3) /
-  ! S 0.92776391E-02, 0.11487826E+00, 0.10000000E+01/
-
-  ! ----- INTERVAL = 1 ----- T =  237.5
-
-  ! -- INDICES FOR PADE APPROXIMATION     1   15   29   45
-  ! DATA (GA( 5, 1,IC),IC=1,3) /
-  ! S 0.73585943E-02,-0.10847662E-02, 0.00000000E+00/
-  ! DATA (GB( 5, 1,IC),IC=1,3) /
-  ! S 0.73585943E-02, 0.10475952E+00, 0.10000000E+01/
-  ! DATA (GA( 5, 2,IC),IC=1,3) /
-  ! S 0.99806312E-02,-0.12807672E-02, 0.00000000E+00/
-  ! DATA (GB( 5, 2,IC),IC=1,3) /
-  ! S 0.99806312E-02, 0.11751113E+00, 0.10000000E+01/
-
-  ! ----- INTERVAL = 1 ----- T =  250.0
-
-  ! -- INDICES FOR PADE APPROXIMATION     1   15   29   45
-  ! DATA (GA( 6, 1,IC),IC=1,3) /
-  ! S 0.77242818E-02,-0.11094726E-02, 0.00000000E+00/
-  ! DATA (GB( 6, 1,IC),IC=1,3) /
-  ! S 0.77242818E-02, 0.10720986E+00, 0.10000000E+01/
-  ! DATA (GA( 6, 2,IC),IC=1,3) /
-  ! S 0.10709803E-01,-0.13208251E-02, 0.00000000E+00/
-  ! DATA (GB( 6, 2,IC),IC=1,3) /
-  ! S 0.10709803E-01, 0.11951535E+00, 0.10000000E+01/
-
-  ! ----- INTERVAL = 1 ----- T =  262.5
-
-  ! -- INDICES FOR PADE APPROXIMATION     1   15   29   45
-  ! DATA (GA( 7, 1,IC),IC=1,3) /
-  ! S 0.81472693E-02,-0.11372949E-02, 0.00000000E+00/
-  ! DATA (GB( 7, 1,IC),IC=1,3) /
-  ! S 0.81472693E-02, 0.10985370E+00, 0.10000000E+01/
-  ! DATA (GA( 7, 2,IC),IC=1,3) /
-  ! S 0.11414739E-01,-0.13619034E-02, 0.00000000E+00/
-  ! DATA (GB( 7, 2,IC),IC=1,3) /
-  ! S 0.11414739E-01, 0.12069945E+00, 0.10000000E+01/
-
-  ! ----- INTERVAL = 1 ----- T =  275.0
-
-  ! -- INDICES FOR PADE APPROXIMATION     1   15   29   45
-  ! DATA (GA( 8, 1,IC),IC=1,3) /
-  ! S 0.86227527E-02,-0.11687683E-02, 0.00000000E+00/
-  ! DATA (GB( 8, 1,IC),IC=1,3) /
-  ! S 0.86227527E-02, 0.11257633E+00, 0.10000000E+01/
-  ! DATA (GA( 8, 2,IC),IC=1,3) /
-  ! S 0.12058772E-01,-0.14014165E-02, 0.00000000E+00/
-  ! DATA (GB( 8, 2,IC),IC=1,3) /
-  ! S 0.12058772E-01, 0.12108524E+00, 0.10000000E+01/
-
-  ! ----- INTERVAL = 1 ----- T =  287.5
-
-  ! -- INDICES FOR PADE APPROXIMATION     1   15   29   45
-  ! DATA (GA( 9, 1,IC),IC=1,3) /
-  ! S 0.91396814E-02,-0.12038314E-02, 0.00000000E+00/
-  ! DATA (GB( 9, 1,IC),IC=1,3) /
-  ! S 0.91396814E-02, 0.11522980E+00, 0.10000000E+01/
-  ! DATA (GA( 9, 2,IC),IC=1,3) /
-  ! S 0.12623992E-01,-0.14378639E-02, 0.00000000E+00/
-  ! DATA (GB( 9, 2,IC),IC=1,3) /
-  ! S 0.12623992E-01, 0.12084229E+00, 0.10000000E+01/
-
-  ! ----- INTERVAL = 1 ----- T =  300.0
-
-  ! -- INDICES FOR PADE APPROXIMATION     1   15   29   45
-  ! DATA (GA(10, 1,IC),IC=1,3) /
-  ! S 0.96825438E-02,-0.12418367E-02, 0.00000000E+00/
-  ! DATA (GB(10, 1,IC),IC=1,3) /
-  ! S 0.96825438E-02, 0.11766343E+00, 0.10000000E+01/
-  ! DATA (GA(10, 2,IC),IC=1,3) /
-  ! S 0.13108146E-01,-0.14708488E-02, 0.00000000E+00/
-  ! DATA (GB(10, 2,IC),IC=1,3) /
-  ! S 0.13108146E-01, 0.12019005E+00, 0.10000000E+01/
-
-  ! ----- INTERVAL = 1 ----- T =  312.5
-
-  ! -- INDICES FOR PADE APPROXIMATION     1   15   29   45
-  ! DATA (GA(11, 1,IC),IC=1,3) /
-  ! S 0.10233955E-01,-0.12817135E-02, 0.00000000E+00/
-  ! DATA (GB(11, 1,IC),IC=1,3) /
-  ! S 0.10233955E-01, 0.11975320E+00, 0.10000000E+01/
-  ! DATA (GA(11, 2,IC),IC=1,3) /
-  ! S 0.13518390E-01,-0.15006791E-02, 0.00000000E+00/
-  ! DATA (GB(11, 2,IC),IC=1,3) /
-  ! S 0.13518390E-01, 0.11932684E+00, 0.10000000E+01/
-
-
-
-  ! --- WATER VAPOR --- INTERVAL 2 -- 500-800 CM-1--- FROM ABS225 ---------
-
-
-
-
-  ! --- R.D.  ---  G = 0.02 + 0.50 / ( 1 + 4.5 U )
-
-
-  ! ----- INTERVAL = 2 ----- T =  187.5
-
-  ! -- INDICES FOR PADE APPROXIMATION     1   28   37   45
-  ! DATA (GA( 1, 3,IC),IC=1,3) /
-  ! S 0.11644593E+01, 0.41243390E+00, 0.00000000E+00/
-  ! DATA (GB( 1, 3,IC),IC=1,3) /
-  ! S 0.11644593E+01, 0.10346097E+01, 0.10000000E+01/
-  ! DATA (GA( 1, 4,IC),IC=1,3) /
-  ! S 0.12006968E+01, 0.48318936E+00, 0.00000000E+00/
-  ! DATA (GB( 1, 4,IC),IC=1,3) /
-  ! S 0.12006968E+01, 0.10626130E+01, 0.10000000E+01/
-
-  ! ----- INTERVAL = 2 ----- T =  200.0
-
-  ! -- INDICES FOR PADE APPROXIMATION     1   28   37   45
-  ! DATA (GA( 2, 3,IC),IC=1,3) /
-  ! S 0.11747203E+01, 0.43407282E+00, 0.00000000E+00/
-  ! DATA (GB( 2, 3,IC),IC=1,3) /
-  ! S 0.11747203E+01, 0.10433655E+01, 0.10000000E+01/
-  ! DATA (GA( 2, 4,IC),IC=1,3) /
-  ! S 0.12108196E+01, 0.50501827E+00, 0.00000000E+00/
-  ! DATA (GB( 2, 4,IC),IC=1,3) /
-  ! S 0.12108196E+01, 0.10716026E+01, 0.10000000E+01/
-
-  ! ----- INTERVAL = 2 ----- T =  212.5
-
-  ! -- INDICES FOR PADE APPROXIMATION     1   28   37   45
-  ! DATA (GA( 3, 3,IC),IC=1,3) /
-  ! S 0.11837872E+01, 0.45331413E+00, 0.00000000E+00/
-  ! DATA (GB( 3, 3,IC),IC=1,3) /
-  ! S 0.11837872E+01, 0.10511933E+01, 0.10000000E+01/
-  ! DATA (GA( 3, 4,IC),IC=1,3) /
-  ! S 0.12196717E+01, 0.52409502E+00, 0.00000000E+00/
-  ! DATA (GB( 3, 4,IC),IC=1,3) /
-  ! S 0.12196717E+01, 0.10795108E+01, 0.10000000E+01/
-
-  ! ----- INTERVAL = 2 ----- T =  225.0
-
-  ! -- INDICES FOR PADE APPROXIMATION     1   28   37   45
-  ! DATA (GA( 4, 3,IC),IC=1,3) /
-  ! S 0.11918561E+01, 0.47048604E+00, 0.00000000E+00/
-  ! DATA (GB( 4, 3,IC),IC=1,3) /
-  ! S 0.11918561E+01, 0.10582150E+01, 0.10000000E+01/
-  ! DATA (GA( 4, 4,IC),IC=1,3) /
-  ! S 0.12274493E+01, 0.54085277E+00, 0.00000000E+00/
-  ! DATA (GB( 4, 4,IC),IC=1,3) /
-  ! S 0.12274493E+01, 0.10865006E+01, 0.10000000E+01/
-
-  ! ----- INTERVAL = 2 ----- T =  237.5
-
-  ! -- INDICES FOR PADE APPROXIMATION     1   28   37   45
-  ! DATA (GA( 5, 3,IC),IC=1,3) /
-  ! S 0.11990757E+01, 0.48586286E+00, 0.00000000E+00/
-  ! DATA (GB( 5, 3,IC),IC=1,3) /
-  ! S 0.11990757E+01, 0.10645317E+01, 0.10000000E+01/
-  ! DATA (GA( 5, 4,IC),IC=1,3) /
-  ! S 0.12343189E+01, 0.55565422E+00, 0.00000000E+00/
-  ! DATA (GB( 5, 4,IC),IC=1,3) /
-  ! S 0.12343189E+01, 0.10927103E+01, 0.10000000E+01/
-
-  ! ----- INTERVAL = 2 ----- T =  250.0
-
-  ! -- INDICES FOR PADE APPROXIMATION     1   28   37   45
-  ! DATA (GA( 6, 3,IC),IC=1,3) /
-  ! S 0.12055643E+01, 0.49968044E+00, 0.00000000E+00/
-  ! DATA (GB( 6, 3,IC),IC=1,3) /
-  ! S 0.12055643E+01, 0.10702313E+01, 0.10000000E+01/
-  ! DATA (GA( 6, 4,IC),IC=1,3) /
-  ! S 0.12404147E+01, 0.56878618E+00, 0.00000000E+00/
-  ! DATA (GB( 6, 4,IC),IC=1,3) /
-  ! S 0.12404147E+01, 0.10982489E+01, 0.10000000E+01/
-
-  ! ----- INTERVAL = 2 ----- T =  262.5
-
-  ! -- INDICES FOR PADE APPROXIMATION     1   28   37   45
-  ! DATA (GA( 7, 3,IC),IC=1,3) /
-  ! S 0.12114186E+01, 0.51214132E+00, 0.00000000E+00/
-  ! DATA (GB( 7, 3,IC),IC=1,3) /
-  ! S 0.12114186E+01, 0.10753907E+01, 0.10000000E+01/
-  ! DATA (GA( 7, 4,IC),IC=1,3) /
-  ! S 0.12458431E+01, 0.58047395E+00, 0.00000000E+00/
-  ! DATA (GB( 7, 4,IC),IC=1,3) /
-  ! S 0.12458431E+01, 0.11032019E+01, 0.10000000E+01/
-
-  ! ----- INTERVAL = 2 ----- T =  275.0
-
-  ! -- INDICES FOR PADE APPROXIMATION     1   28   37   45
-  ! DATA (GA( 8, 3,IC),IC=1,3) /
-  ! S 0.12167192E+01, 0.52341830E+00, 0.00000000E+00/
-  ! DATA (GB( 8, 3,IC),IC=1,3) /
-  ! S 0.12167192E+01, 0.10800762E+01, 0.10000000E+01/
-  ! DATA (GA( 8, 4,IC),IC=1,3) /
-  ! S 0.12506907E+01, 0.59089894E+00, 0.00000000E+00/
-  ! DATA (GB( 8, 4,IC),IC=1,3) /
-  ! S 0.12506907E+01, 0.11076379E+01, 0.10000000E+01/
-
-  ! ----- INTERVAL = 2 ----- T =  287.5
-
-  ! -- INDICES FOR PADE APPROXIMATION     1   28   37   45
-  ! DATA (GA( 9, 3,IC),IC=1,3) /
-  ! S 0.12215344E+01, 0.53365803E+00, 0.00000000E+00/
-  ! DATA (GB( 9, 3,IC),IC=1,3) /
-  ! S 0.12215344E+01, 0.10843446E+01, 0.10000000E+01/
-  ! DATA (GA( 9, 4,IC),IC=1,3) /
-  ! S 0.12550299E+01, 0.60021475E+00, 0.00000000E+00/
-  ! DATA (GB( 9, 4,IC),IC=1,3) /
-  ! S 0.12550299E+01, 0.11116160E+01, 0.10000000E+01/
-
-  ! ----- INTERVAL = 2 ----- T =  300.0
-
-  ! -- INDICES FOR PADE APPROXIMATION     1   28   37   45
-  ! DATA (GA(10, 3,IC),IC=1,3) /
-  ! S 0.12259226E+01, 0.54298448E+00, 0.00000000E+00/
-  ! DATA (GB(10, 3,IC),IC=1,3) /
-  ! S 0.12259226E+01, 0.10882439E+01, 0.10000000E+01/
-  ! DATA (GA(10, 4,IC),IC=1,3) /
-  ! S 0.12589256E+01, 0.60856112E+00, 0.00000000E+00/
-  ! DATA (GB(10, 4,IC),IC=1,3) /
-  ! S 0.12589256E+01, 0.11151910E+01, 0.10000000E+01/
-
-  ! ----- INTERVAL = 2 ----- T =  312.5
-
-  ! -- INDICES FOR PADE APPROXIMATION     1   28   37   45
-  ! DATA (GA(11, 3,IC),IC=1,3) /
-  ! S 0.12299344E+01, 0.55150227E+00, 0.00000000E+00/
-  ! DATA (GB(11, 3,IC),IC=1,3) /
-  ! S 0.12299344E+01, 0.10918144E+01, 0.10000000E+01/
-  ! DATA (GA(11, 4,IC),IC=1,3) /
-  ! S 0.12624402E+01, 0.61607594E+00, 0.00000000E+00/
-  ! DATA (GB(11, 4,IC),IC=1,3) /
-  ! S 0.12624402E+01, 0.11184188E+01, 0.10000000E+01/
-
-
-
-
-
-
-  ! - WATER VAPOR - INT. 3 -- 800-970 + 1110-1250 CM-1 -- FIT FROM 215 IS -
-
-
-  ! -- WATER VAPOR LINES IN THE WINDOW REGION (800-1250 CM-1)
-
-
-
-  ! --- G = 3.875E-03 ---------------
-
-  ! ----- INTERVAL = 3 ----- T =  187.5
-
-  ! -- INDICES FOR PADE APPROXIMATION     1   28   37   45
-  ! DATA (GA( 1, 7,IC),IC=1,3) /
-  ! S 0.10192131E+02, 0.80737799E+01, 0.00000000E+00/
-  ! DATA (GB( 1, 7,IC),IC=1,3) /
-  ! S 0.10192131E+02, 0.82623280E+01, 0.10000000E+01/
-  ! DATA (GA( 1, 8,IC),IC=1,3) /
-  ! S 0.92439050E+01, 0.77425778E+01, 0.00000000E+00/
-  ! DATA (GB( 1, 8,IC),IC=1,3) /
-  ! S 0.92439050E+01, 0.79342219E+01, 0.10000000E+01/
-
-  ! ----- INTERVAL = 3 ----- T =  200.0
-
-  ! -- INDICES FOR PADE APPROXIMATION     1   28   37   45
-  ! DATA (GA( 2, 7,IC),IC=1,3) /
-  ! S 0.97258602E+01, 0.79171158E+01, 0.00000000E+00/
-  ! DATA (GB( 2, 7,IC),IC=1,3) /
-  ! S 0.97258602E+01, 0.81072291E+01, 0.10000000E+01/
-  ! DATA (GA( 2, 8,IC),IC=1,3) /
-  ! S 0.87567422E+01, 0.75443460E+01, 0.00000000E+00/
-  ! DATA (GB( 2, 8,IC),IC=1,3) /
-  ! S 0.87567422E+01, 0.77373458E+01, 0.10000000E+01/
-
-  ! ----- INTERVAL = 3 ----- T =  212.5
-
-  ! -- INDICES FOR PADE APPROXIMATION     1   28   37   45
-  ! DATA (GA( 3, 7,IC),IC=1,3) /
-  ! S 0.92992890E+01, 0.77609605E+01, 0.00000000E+00/
-  ! DATA (GB( 3, 7,IC),IC=1,3) /
-  ! S 0.92992890E+01, 0.79523834E+01, 0.10000000E+01/
-  ! DATA (GA( 3, 8,IC),IC=1,3) /
-  ! S 0.83270144E+01, 0.73526151E+01, 0.00000000E+00/
-  ! DATA (GB( 3, 8,IC),IC=1,3) /
-  ! S 0.83270144E+01, 0.75467334E+01, 0.10000000E+01/
-
-  ! ----- INTERVAL = 3 ----- T =  225.0
-
-  ! -- INDICES FOR PADE APPROXIMATION     1   28   37   45
-  ! DATA (GA( 4, 7,IC),IC=1,3) /
-  ! S 0.89154021E+01, 0.76087371E+01, 0.00000000E+00/
-  ! DATA (GB( 4, 7,IC),IC=1,3) /
-  ! S 0.89154021E+01, 0.78012527E+01, 0.10000000E+01/
-  ! DATA (GA( 4, 8,IC),IC=1,3) /
-  ! S 0.79528337E+01, 0.71711188E+01, 0.00000000E+00/
-  ! DATA (GB( 4, 8,IC),IC=1,3) /
-  ! S 0.79528337E+01, 0.73661786E+01, 0.10000000E+01/
-
-  ! ----- INTERVAL = 3 ----- T =  237.5
-
-  ! -- INDICES FOR PADE APPROXIMATION     1   28   37   45
-  ! DATA (GA( 5, 7,IC),IC=1,3) /
-  ! S 0.85730084E+01, 0.74627112E+01, 0.00000000E+00/
-  ! DATA (GB( 5, 7,IC),IC=1,3) /
-  ! S 0.85730084E+01, 0.76561458E+01, 0.10000000E+01/
-  ! DATA (GA( 5, 8,IC),IC=1,3) /
-  ! S 0.76286839E+01, 0.70015571E+01, 0.00000000E+00/
-  ! DATA (GB( 5, 8,IC),IC=1,3) /
-  ! S 0.76286839E+01, 0.71974319E+01, 0.10000000E+01/
-
-  ! ----- INTERVAL = 3 ----- T =  250.0
-
-  ! -- INDICES FOR PADE APPROXIMATION     1   28   37   45
-  ! DATA (GA( 6, 7,IC),IC=1,3) /
-  ! S 0.82685838E+01, 0.73239981E+01, 0.00000000E+00/
-  ! DATA (GB( 6, 7,IC),IC=1,3) /
-  ! S 0.82685838E+01, 0.75182174E+01, 0.10000000E+01/
-  ! DATA (GA( 6, 8,IC),IC=1,3) /
-  ! S 0.73477879E+01, 0.68442532E+01, 0.00000000E+00/
-  ! DATA (GB( 6, 8,IC),IC=1,3) /
-  ! S 0.73477879E+01, 0.70408543E+01, 0.10000000E+01/
-
-  ! ----- INTERVAL = 3 ----- T =  262.5
-
-  ! -- INDICES FOR PADE APPROXIMATION     1   28   37   45
-  ! DATA (GA( 7, 7,IC),IC=1,3) /
-  ! S 0.79978921E+01, 0.71929934E+01, 0.00000000E+00/
-  ! DATA (GB( 7, 7,IC),IC=1,3) /
-  ! S 0.79978921E+01, 0.73878952E+01, 0.10000000E+01/
-  ! DATA (GA( 7, 8,IC),IC=1,3) /
-  ! S 0.71035818E+01, 0.66987996E+01, 0.00000000E+00/
-  ! DATA (GB( 7, 8,IC),IC=1,3) /
-  ! S 0.71035818E+01, 0.68960649E+01, 0.10000000E+01/
-
-  ! ----- INTERVAL = 3 ----- T =  275.0
-
-  ! -- INDICES FOR PADE APPROXIMATION     1   28   37   45
-  ! DATA (GA( 8, 7,IC),IC=1,3) /
-  ! S 0.77568055E+01, 0.70697065E+01, 0.00000000E+00/
-  ! DATA (GB( 8, 7,IC),IC=1,3) /
-  ! S 0.77568055E+01, 0.72652133E+01, 0.10000000E+01/
-  ! DATA (GA( 8, 8,IC),IC=1,3) /
-  ! S 0.68903312E+01, 0.65644820E+01, 0.00000000E+00/
-  ! DATA (GB( 8, 8,IC),IC=1,3) /
-  ! S 0.68903312E+01, 0.67623672E+01, 0.10000000E+01/
-
-  ! ----- INTERVAL = 3 ----- T =  287.5
-
-  ! -- INDICES FOR PADE APPROXIMATION     1   28   37   45
-  ! DATA (GA( 9, 7,IC),IC=1,3) /
-  ! S 0.75416266E+01, 0.69539626E+01, 0.00000000E+00/
-  ! DATA (GB( 9, 7,IC),IC=1,3) /
-  ! S 0.75416266E+01, 0.71500151E+01, 0.10000000E+01/
-  ! DATA (GA( 9, 8,IC),IC=1,3) /
-  ! S 0.67032875E+01, 0.64405267E+01, 0.00000000E+00/
-  ! DATA (GB( 9, 8,IC),IC=1,3) /
-  ! S 0.67032875E+01, 0.66389989E+01, 0.10000000E+01/
-
-  ! ----- INTERVAL = 3 ----- T =  300.0
-
-  ! -- INDICES FOR PADE APPROXIMATION     1   28   37   45
-  ! DATA (GA(10, 7,IC),IC=1,3) /
-  ! S 0.73491694E+01, 0.68455144E+01, 0.00000000E+00/
-  ! DATA (GB(10, 7,IC),IC=1,3) /
-  ! S 0.73491694E+01, 0.70420667E+01, 0.10000000E+01/
-  ! DATA (GA(10, 8,IC),IC=1,3) /
-  ! S 0.65386461E+01, 0.63262376E+01, 0.00000000E+00/
-  ! DATA (GB(10, 8,IC),IC=1,3) /
-  ! S 0.65386461E+01, 0.65252707E+01, 0.10000000E+01/
-
-  ! ----- INTERVAL = 3 ----- T =  312.5
-
-  ! -- INDICES FOR PADE APPROXIMATION     1   28   37   45
-  ! DATA (GA(11, 7,IC),IC=1,3) /
-  ! S 0.71767400E+01, 0.67441020E+01, 0.00000000E+00/
-  ! DATA (GB(11, 7,IC),IC=1,3) /
-  ! S 0.71767400E+01, 0.69411177E+01, 0.10000000E+01/
-  ! DATA (GA(11, 8,IC),IC=1,3) /
-  ! S 0.63934377E+01, 0.62210701E+01, 0.00000000E+00/
-  ! DATA (GB(11, 8,IC),IC=1,3) /
-  ! S 0.63934377E+01, 0.64206412E+01, 0.10000000E+01/
-
-
-  ! -- WATER VAPOR -- 970-1110 CM-1 ----------------------------------------
-
-  ! -- G = 3.6E-03
-
-  ! ----- INTERVAL = 4 ----- T =  187.5
-
-  ! -- INDICES FOR PADE APPROXIMATION     1   28   37   45
-  ! DATA (GA( 1, 9,IC),IC=1,3) /
-  ! S 0.24870635E+02, 0.10542131E+02, 0.00000000E+00/
-  ! DATA (GB( 1, 9,IC),IC=1,3) /
-  ! S 0.24870635E+02, 0.10656640E+02, 0.10000000E+01/
-  ! DATA (GA( 1,10,IC),IC=1,3) /
-  ! S 0.24586283E+02, 0.10490353E+02, 0.00000000E+00/
-  ! DATA (GB( 1,10,IC),IC=1,3) /
-  ! S 0.24586283E+02, 0.10605856E+02, 0.10000000E+01/
-
-  ! ----- INTERVAL = 4 ----- T =  200.0
-
-  ! -- INDICES FOR PADE APPROXIMATION     1   28   37   45
-  ! DATA (GA( 2, 9,IC),IC=1,3) /
-  ! S 0.24725591E+02, 0.10515895E+02, 0.00000000E+00/
-  ! DATA (GB( 2, 9,IC),IC=1,3) /
-  ! S 0.24725591E+02, 0.10630910E+02, 0.10000000E+01/
-  ! DATA (GA( 2,10,IC),IC=1,3) /
-  ! S 0.24441465E+02, 0.10463512E+02, 0.00000000E+00/
-  ! DATA (GB( 2,10,IC),IC=1,3) /
-  ! S 0.24441465E+02, 0.10579514E+02, 0.10000000E+01/
-
-  ! ----- INTERVAL = 4 ----- T =  212.5
-
-  ! -- INDICES FOR PADE APPROXIMATION     1   28   37   45
-  ! DATA (GA( 3, 9,IC),IC=1,3) /
-  ! S 0.24600320E+02, 0.10492949E+02, 0.00000000E+00/
-  ! DATA (GB( 3, 9,IC),IC=1,3) /
-  ! S 0.24600320E+02, 0.10608399E+02, 0.10000000E+01/
-  ! DATA (GA( 3,10,IC),IC=1,3) /
-  ! S 0.24311657E+02, 0.10439183E+02, 0.00000000E+00/
-  ! DATA (GB( 3,10,IC),IC=1,3) /
-  ! S 0.24311657E+02, 0.10555632E+02, 0.10000000E+01/
-
-  ! ----- INTERVAL = 4 ----- T =  225.0
-
-  ! -- INDICES FOR PADE APPROXIMATION     1   28   37   45
-  ! DATA (GA( 4, 9,IC),IC=1,3) /
-  ! S 0.24487300E+02, 0.10472049E+02, 0.00000000E+00/
-  ! DATA (GB( 4, 9,IC),IC=1,3) /
-  ! S 0.24487300E+02, 0.10587891E+02, 0.10000000E+01/
-  ! DATA (GA( 4,10,IC),IC=1,3) /
-  ! S 0.24196167E+02, 0.10417324E+02, 0.00000000E+00/
-  ! DATA (GB( 4,10,IC),IC=1,3) /
-  ! S 0.24196167E+02, 0.10534169E+02, 0.10000000E+01/
-
-  ! ----- INTERVAL = 4 ----- T =  237.5
-
-  ! -- INDICES FOR PADE APPROXIMATION     1   28   37   45
-  ! DATA (GA( 5, 9,IC),IC=1,3) /
-  ! S 0.24384935E+02, 0.10452961E+02, 0.00000000E+00/
-  ! DATA (GB( 5, 9,IC),IC=1,3) /
-  ! S 0.24384935E+02, 0.10569156E+02, 0.10000000E+01/
-  ! DATA (GA( 5,10,IC),IC=1,3) /
-  ! S 0.24093406E+02, 0.10397704E+02, 0.00000000E+00/
-  ! DATA (GB( 5,10,IC),IC=1,3) /
-  ! S 0.24093406E+02, 0.10514900E+02, 0.10000000E+01/
-
-  ! ----- INTERVAL = 4 ----- T =  250.0
-
-  ! -- INDICES FOR PADE APPROXIMATION     1   28   37   45
-  ! DATA (GA( 6, 9,IC),IC=1,3) /
-  ! S 0.24292341E+02, 0.10435562E+02, 0.00000000E+00/
-  ! DATA (GB( 6, 9,IC),IC=1,3) /
-  ! S 0.24292341E+02, 0.10552075E+02, 0.10000000E+01/
-  ! DATA (GA( 6,10,IC),IC=1,3) /
-  ! S 0.24001597E+02, 0.10380038E+02, 0.00000000E+00/
-  ! DATA (GB( 6,10,IC),IC=1,3) /
-  ! S 0.24001597E+02, 0.10497547E+02, 0.10000000E+01/
-
-  ! ----- INTERVAL = 4 ----- T =  262.5
-
-  ! -- INDICES FOR PADE APPROXIMATION     1   28   37   45
-  ! DATA (GA( 7, 9,IC),IC=1,3) /
-  ! S 0.24208572E+02, 0.10419710E+02, 0.00000000E+00/
-  ! DATA (GB( 7, 9,IC),IC=1,3) /
-  ! S 0.24208572E+02, 0.10536510E+02, 0.10000000E+01/
-  ! DATA (GA( 7,10,IC),IC=1,3) /
-  ! S 0.23919098E+02, 0.10364052E+02, 0.00000000E+00/
-  ! DATA (GB( 7,10,IC),IC=1,3) /
-  ! S 0.23919098E+02, 0.10481842E+02, 0.10000000E+01/
-
-  ! ----- INTERVAL = 4 ----- T =  275.0
-
-  ! -- INDICES FOR PADE APPROXIMATION     1   28   37   45
-  ! DATA (GA( 8, 9,IC),IC=1,3) /
-  ! S 0.24132642E+02, 0.10405247E+02, 0.00000000E+00/
-  ! DATA (GB( 8, 9,IC),IC=1,3) /
-  ! S 0.24132642E+02, 0.10522307E+02, 0.10000000E+01/
-  ! DATA (GA( 8,10,IC),IC=1,3) /
-  ! S 0.23844511E+02, 0.10349509E+02, 0.00000000E+00/
-  ! DATA (GB( 8,10,IC),IC=1,3) /
-  ! S 0.23844511E+02, 0.10467553E+02, 0.10000000E+01/
-
-  ! ----- INTERVAL = 4 ----- T =  287.5
-
-  ! -- INDICES FOR PADE APPROXIMATION     1   28   37   45
-  ! DATA (GA( 9, 9,IC),IC=1,3) /
-  ! S 0.24063614E+02, 0.10392022E+02, 0.00000000E+00/
-  ! DATA (GB( 9, 9,IC),IC=1,3) /
-  ! S 0.24063614E+02, 0.10509317E+02, 0.10000000E+01/
-  ! DATA (GA( 9,10,IC),IC=1,3) /
-  ! S 0.23776708E+02, 0.10336215E+02, 0.00000000E+00/
-  ! DATA (GB( 9,10,IC),IC=1,3) /
-  ! S 0.23776708E+02, 0.10454488E+02, 0.10000000E+01/
-
-  ! ----- INTERVAL = 4 ----- T =  300.0
-
-  ! -- INDICES FOR PADE APPROXIMATION     1   28   37   45
-  ! DATA (GA(10, 9,IC),IC=1,3) /
-  ! S 0.24000649E+02, 0.10379892E+02, 0.00000000E+00/
-  ! DATA (GB(10, 9,IC),IC=1,3) /
-  ! S 0.24000649E+02, 0.10497402E+02, 0.10000000E+01/
-  ! DATA (GA(10,10,IC),IC=1,3) /
-  ! S 0.23714816E+02, 0.10324018E+02, 0.00000000E+00/
-  ! DATA (GB(10,10,IC),IC=1,3) /
-  ! S 0.23714816E+02, 0.10442501E+02, 0.10000000E+01/
-
-  ! ----- INTERVAL = 4 ----- T =  312.5
-
-  ! -- INDICES FOR PADE APPROXIMATION     1   28   37   45
-  ! DATA (GA(11, 9,IC),IC=1,3) /
-  ! S 0.23943021E+02, 0.10368736E+02, 0.00000000E+00/
-  ! DATA (GB(11, 9,IC),IC=1,3) /
-  ! S 0.23943021E+02, 0.10486443E+02, 0.10000000E+01/
-  ! DATA (GA(11,10,IC),IC=1,3) /
-  ! S 0.23658197E+02, 0.10312808E+02, 0.00000000E+00/
-  ! DATA (GB(11,10,IC),IC=1,3) /
-  ! S 0.23658197E+02, 0.10431483E+02, 0.10000000E+01/
-
-
-
-  ! -- H2O -- WEAKER PARTS OF THE STRONG BANDS  -- FROM ABS225 ----
-
-  ! -- WATER VAPOR --- 350 - 500 CM-1
-
-  ! -- G = - 0.2*SLA, 0.0 +0.5/(1+0.5U)
-
-  ! ----- INTERVAL = 5 ----- T =  187.5
-
-  ! -- INDICES FOR PADE APPROXIMATION   1 35 40 45
-  ! DATA (GA( 1, 5,IC),IC=1,3) /
-  ! S 0.15750172E+00,-0.22159303E-01, 0.00000000E+00/
-  ! DATA (GB( 1, 5,IC),IC=1,3) /
-  ! S 0.15750172E+00, 0.38103212E+00, 0.10000000E+01/
-  ! DATA (GA( 1, 6,IC),IC=1,3) /
-  ! S 0.17770551E+00,-0.24972399E-01, 0.00000000E+00/
-  ! DATA (GB( 1, 6,IC),IC=1,3) /
-  ! S 0.17770551E+00, 0.41646579E+00, 0.10000000E+01/
-
-  ! ----- INTERVAL = 5 ----- T =  200.0
-
-  ! -- INDICES FOR PADE APPROXIMATION   1 35 40 45
-  ! DATA (GA( 2, 5,IC),IC=1,3) /
-  ! S 0.16174076E+00,-0.22748917E-01, 0.00000000E+00/
-  ! DATA (GB( 2, 5,IC),IC=1,3) /
-  ! S 0.16174076E+00, 0.38913800E+00, 0.10000000E+01/
-  ! DATA (GA( 2, 6,IC),IC=1,3) /
-  ! S 0.18176757E+00,-0.25537247E-01, 0.00000000E+00/
-  ! DATA (GB( 2, 6,IC),IC=1,3) /
-  ! S 0.18176757E+00, 0.42345095E+00, 0.10000000E+01/
-
-  ! ----- INTERVAL = 5 ----- T =  212.5
-
-  ! -- INDICES FOR PADE APPROXIMATION   1 35 40 45
-  ! DATA (GA( 3, 5,IC),IC=1,3) /
-  ! S 0.16548628E+00,-0.23269898E-01, 0.00000000E+00/
-  ! DATA (GB( 3, 5,IC),IC=1,3) /
-  ! S 0.16548628E+00, 0.39613651E+00, 0.10000000E+01/
-  ! DATA (GA( 3, 6,IC),IC=1,3) /
-  ! S 0.18527967E+00,-0.26025624E-01, 0.00000000E+00/
-  ! DATA (GB( 3, 6,IC),IC=1,3) /
-  ! S 0.18527967E+00, 0.42937476E+00, 0.10000000E+01/
-
-  ! ----- INTERVAL = 5 ----- T =  225.0
-
-  ! -- INDICES FOR PADE APPROXIMATION   1 35 40 45
-  ! DATA (GA( 4, 5,IC),IC=1,3) /
-  ! S 0.16881124E+00,-0.23732392E-01, 0.00000000E+00/
-  ! DATA (GB( 4, 5,IC),IC=1,3) /
-  ! S 0.16881124E+00, 0.40222421E+00, 0.10000000E+01/
-  ! DATA (GA( 4, 6,IC),IC=1,3) /
-  ! S 0.18833348E+00,-0.26450280E-01, 0.00000000E+00/
-  ! DATA (GB( 4, 6,IC),IC=1,3) /
-  ! S 0.18833348E+00, 0.43444062E+00, 0.10000000E+01/
-
-  ! ----- INTERVAL = 5 ----- T =  237.5
-
-  ! -- INDICES FOR PADE APPROXIMATION   1 35 40 45
-  ! DATA (GA( 5, 5,IC),IC=1,3) /
-  ! S 0.17177839E+00,-0.24145123E-01, 0.00000000E+00/
-  ! DATA (GB( 5, 5,IC),IC=1,3) /
-  ! S 0.17177839E+00, 0.40756010E+00, 0.10000000E+01/
-  ! DATA (GA( 5, 6,IC),IC=1,3) /
-  ! S 0.19100108E+00,-0.26821236E-01, 0.00000000E+00/
-  ! DATA (GB( 5, 6,IC),IC=1,3) /
-  ! S 0.19100108E+00, 0.43880316E+00, 0.10000000E+01/
-
-  ! ----- INTERVAL = 5 ----- T =  250.0
-
-  ! -- INDICES FOR PADE APPROXIMATION   1 35 40 45
-  ! DATA (GA( 6, 5,IC),IC=1,3) /
-  ! S 0.17443933E+00,-0.24515269E-01, 0.00000000E+00/
-  ! DATA (GB( 6, 5,IC),IC=1,3) /
-  ! S 0.17443933E+00, 0.41226954E+00, 0.10000000E+01/
-  ! DATA (GA( 6, 6,IC),IC=1,3) /
-  ! S 0.19334122E+00,-0.27146657E-01, 0.00000000E+00/
-  ! DATA (GB( 6, 6,IC),IC=1,3) /
-  ! S 0.19334122E+00, 0.44258354E+00, 0.10000000E+01/
-
-  ! ----- INTERVAL = 5 ----- T =  262.5
-
-  ! -- INDICES FOR PADE APPROXIMATION   1 35 40 45
-  ! DATA (GA( 7, 5,IC),IC=1,3) /
-  ! S 0.17683622E+00,-0.24848690E-01, 0.00000000E+00/
-  ! DATA (GB( 7, 5,IC),IC=1,3) /
-  ! S 0.17683622E+00, 0.41645142E+00, 0.10000000E+01/
-  ! DATA (GA( 7, 6,IC),IC=1,3) /
-  ! S 0.19540288E+00,-0.27433354E-01, 0.00000000E+00/
-  ! DATA (GB( 7, 6,IC),IC=1,3) /
-  ! S 0.19540288E+00, 0.44587882E+00, 0.10000000E+01/
-
-  ! ----- INTERVAL = 5 ----- T =  275.0
-
-  ! -- INDICES FOR PADE APPROXIMATION   1 35 40 45
-  ! DATA (GA( 8, 5,IC),IC=1,3) /
-  ! S 0.17900375E+00,-0.25150210E-01, 0.00000000E+00/
-  ! DATA (GB( 8, 5,IC),IC=1,3) /
-  ! S 0.17900375E+00, 0.42018474E+00, 0.10000000E+01/
-  ! DATA (GA( 8, 6,IC),IC=1,3) /
-  ! S 0.19722732E+00,-0.27687065E-01, 0.00000000E+00/
-  ! DATA (GB( 8, 6,IC),IC=1,3) /
-  ! S 0.19722732E+00, 0.44876776E+00, 0.10000000E+01/
-
-  ! ----- INTERVAL = 5 ----- T =  287.5
-
-  ! -- INDICES FOR PADE APPROXIMATION   1 35 40 45
-  ! DATA (GA( 9, 5,IC),IC=1,3) /
-  ! S 0.18097099E+00,-0.25423873E-01, 0.00000000E+00/
-  ! DATA (GB( 9, 5,IC),IC=1,3) /
-  ! S 0.18097099E+00, 0.42353379E+00, 0.10000000E+01/
-  ! DATA (GA( 9, 6,IC),IC=1,3) /
-  ! S 0.19884918E+00,-0.27912608E-01, 0.00000000E+00/
-  ! DATA (GB( 9, 6,IC),IC=1,3) /
-  ! S 0.19884918E+00, 0.45131451E+00, 0.10000000E+01/
-
-  ! ----- INTERVAL = 5 ----- T =  300.0
-
-  ! -- INDICES FOR PADE APPROXIMATION   1 35 40 45
-  ! DATA (GA(10, 5,IC),IC=1,3) /
-  ! S 0.18276283E+00,-0.25673139E-01, 0.00000000E+00/
-  ! DATA (GB(10, 5,IC),IC=1,3) /
-  ! S 0.18276283E+00, 0.42655211E+00, 0.10000000E+01/
-  ! DATA (GA(10, 6,IC),IC=1,3) /
-  ! S 0.20029696E+00,-0.28113944E-01, 0.00000000E+00/
-  ! DATA (GB(10, 6,IC),IC=1,3) /
-  ! S 0.20029696E+00, 0.45357095E+00, 0.10000000E+01/
-
-  ! ----- INTERVAL = 5 ----- T =  312.5
-
-  ! -- INDICES FOR PADE APPROXIMATION   1 35 40 45
-  ! DATA (GA(11, 5,IC),IC=1,3) /
-  ! S 0.18440117E+00,-0.25901055E-01, 0.00000000E+00/
-  ! DATA (GB(11, 5,IC),IC=1,3) /
-  ! S 0.18440117E+00, 0.42928533E+00, 0.10000000E+01/
-  ! DATA (GA(11, 6,IC),IC=1,3) /
-  ! S 0.20159300E+00,-0.28294180E-01, 0.00000000E+00/
-  ! DATA (GB(11, 6,IC),IC=1,3) /
-  ! S 0.20159300E+00, 0.45557797E+00, 0.10000000E+01/
-
-
-
-
-  ! - WATER VAPOR - WINGS OF VIBRATION-ROTATION BAND - 1250-1450+1880-2820 -
-  ! --- G = 0.0
-
-
-  ! ----- INTERVAL = 6 ----- T =  187.5
-
-  ! -- INDICES FOR PADE APPROXIMATION   1 35 40 45
-  ! DATA (GA( 1,11,IC),IC=1,3) /
-  ! S 0.11990218E+02,-0.12823142E+01, 0.00000000E+00/
-  ! DATA (GB( 1,11,IC),IC=1,3) /
-  ! S 0.11990218E+02, 0.26681588E+02, 0.10000000E+01/
-  ! DATA (GA( 1,12,IC),IC=1,3) /
-  ! S 0.79709806E+01,-0.74805226E+00, 0.00000000E+00/
-  ! DATA (GB( 1,12,IC),IC=1,3) /
-  ! S 0.79709806E+01, 0.18377807E+02, 0.10000000E+01/
-
-  ! ----- INTERVAL = 6 ----- T =  200.0
-
-  ! -- INDICES FOR PADE APPROXIMATION   1 35 40 45
-  ! DATA (GA( 2,11,IC),IC=1,3) /
-  ! S 0.10904073E+02,-0.10571588E+01, 0.00000000E+00/
-  ! DATA (GB( 2,11,IC),IC=1,3) /
-  ! S 0.10904073E+02, 0.24728346E+02, 0.10000000E+01/
-  ! DATA (GA( 2,12,IC),IC=1,3) /
-  ! S 0.75400737E+01,-0.56252739E+00, 0.00000000E+00/
-  ! DATA (GB( 2,12,IC),IC=1,3) /
-  ! S 0.75400737E+01, 0.17643148E+02, 0.10000000E+01/
-
-  ! ----- INTERVAL = 6 ----- T =  212.5
-
-  ! -- INDICES FOR PADE APPROXIMATION   1 35 40 45
-  ! DATA (GA( 3,11,IC),IC=1,3) /
-  ! S 0.89126838E+01,-0.74864953E+00, 0.00000000E+00/
-  ! DATA (GB( 3,11,IC),IC=1,3) /
-  ! S 0.89126838E+01, 0.20551342E+02, 0.10000000E+01/
-  ! DATA (GA( 3,12,IC),IC=1,3) /
-  ! S 0.81804377E+01,-0.46188072E+00, 0.00000000E+00/
-  ! DATA (GB( 3,12,IC),IC=1,3) /
-  ! S 0.81804377E+01, 0.19296161E+02, 0.10000000E+01/
-
-  ! ----- INTERVAL = 6 ----- T =  225.0
-
-  ! -- INDICES FOR PADE APPROXIMATION   1 35 40 45
-  ! DATA (GA( 4,11,IC),IC=1,3) /
-  ! S 0.85622405E+01,-0.58705980E+00, 0.00000000E+00/
-  ! DATA (GB( 4,11,IC),IC=1,3) /
-  ! S 0.85622405E+01, 0.19955244E+02, 0.10000000E+01/
-  ! DATA (GA( 4,12,IC),IC=1,3) /
-  ! S 0.10564339E+02,-0.40712065E+00, 0.00000000E+00/
-  ! DATA (GB( 4,12,IC),IC=1,3) /
-  ! S 0.10564339E+02, 0.24951120E+02, 0.10000000E+01/
-
-  ! ----- INTERVAL = 6 ----- T =  237.5
-
-  ! -- INDICES FOR PADE APPROXIMATION   1 35 40 45
-  ! DATA (GA( 5,11,IC),IC=1,3) /
-  ! S 0.94892164E+01,-0.49305772E+00, 0.00000000E+00/
-  ! DATA (GB( 5,11,IC),IC=1,3) /
-  ! S 0.94892164E+01, 0.22227100E+02, 0.10000000E+01/
-  ! DATA (GA( 5,12,IC),IC=1,3) /
-  ! S 0.46896789E+02,-0.15295996E+01, 0.00000000E+00/
-  ! DATA (GB( 5,12,IC),IC=1,3) /
-  ! S 0.46896789E+02, 0.10957372E+03, 0.10000000E+01/
-
-  ! ----- INTERVAL = 6 ----- T =  250.0
-
-  ! -- INDICES FOR PADE APPROXIMATION   1 35 40 45
-  ! DATA (GA( 6,11,IC),IC=1,3) /
-  ! S 0.13580937E+02,-0.51461431E+00, 0.00000000E+00/
-  ! DATA (GB( 6,11,IC),IC=1,3) /
-  ! S 0.13580937E+02, 0.31770288E+02, 0.10000000E+01/
-  ! DATA (GA( 6,12,IC),IC=1,3) /
-  ! S-0.30926524E+01, 0.43555255E+00, 0.00000000E+00/
-  ! DATA (GB( 6,12,IC),IC=1,3) /
-  ! S-0.30926524E+01,-0.67432659E+01, 0.10000000E+01/
-
-  ! ----- INTERVAL = 6 ----- T =  262.5
-
-  ! -- INDICES FOR PADE APPROXIMATION   1 35 40 45
-  ! DATA (GA( 7,11,IC),IC=1,3) /
-  ! S-0.32050918E+03, 0.12373350E+02, 0.00000000E+00/
-  ! DATA (GB( 7,11,IC),IC=1,3) /
-  ! S-0.32050918E+03,-0.74061287E+03, 0.10000000E+01/
-  ! DATA (GA( 7,12,IC),IC=1,3) /
-  ! S 0.85742941E+00, 0.50380874E+00, 0.00000000E+00/
-  ! DATA (GB( 7,12,IC),IC=1,3) /
-  ! S 0.85742941E+00, 0.24550746E+01, 0.10000000E+01/
-
-  ! ----- INTERVAL = 6 ----- T =  275.0
-
-  ! -- INDICES FOR PADE APPROXIMATION   1 35 40 45
-  ! DATA (GA( 8,11,IC),IC=1,3) /
-  ! S-0.37133165E+01, 0.44809588E+00, 0.00000000E+00/
-  ! DATA (GB( 8,11,IC),IC=1,3) /
-  ! S-0.37133165E+01,-0.81329826E+01, 0.10000000E+01/
-  ! DATA (GA( 8,12,IC),IC=1,3) /
-  ! S 0.19164038E+01, 0.68537352E+00, 0.00000000E+00/
-  ! DATA (GB( 8,12,IC),IC=1,3) /
-  ! S 0.19164038E+01, 0.49089917E+01, 0.10000000E+01/
-
-  ! ----- INTERVAL = 6 ----- T =  287.5
-
-  ! -- INDICES FOR PADE APPROXIMATION   1 35 40 45
-  ! DATA (GA( 9,11,IC),IC=1,3) /
-  ! S 0.18890836E+00, 0.46548918E+00, 0.00000000E+00/
-  ! DATA (GB( 9,11,IC),IC=1,3) /
-  ! S 0.18890836E+00, 0.90279822E+00, 0.10000000E+01/
-  ! DATA (GA( 9,12,IC),IC=1,3) /
-  ! S 0.23513199E+01, 0.89437630E+00, 0.00000000E+00/
-  ! DATA (GB( 9,12,IC),IC=1,3) /
-  ! S 0.23513199E+01, 0.59008712E+01, 0.10000000E+01/
-
-  ! ----- INTERVAL = 6 ----- T =  300.0
-
-  ! -- INDICES FOR PADE APPROXIMATION   1 35 40 45
-  ! DATA (GA(10,11,IC),IC=1,3) /
-  ! S 0.14209226E+01, 0.59121475E+00, 0.00000000E+00/
-  ! DATA (GB(10,11,IC),IC=1,3) /
-  ! S 0.14209226E+01, 0.37532746E+01, 0.10000000E+01/
-  ! DATA (GA(10,12,IC),IC=1,3) /
-  ! S 0.25566644E+01, 0.11127003E+01, 0.00000000E+00/
-  ! DATA (GB(10,12,IC),IC=1,3) /
-  ! S 0.25566644E+01, 0.63532616E+01, 0.10000000E+01/
-
-  ! ----- INTERVAL = 6 ----- T =  312.5
-
-  ! -- INDICES FOR PADE APPROXIMATION   1 35 40 45
-  ! DATA (GA(11,11,IC),IC=1,3) /
-  ! S 0.19817679E+01, 0.74676119E+00, 0.00000000E+00/
-  ! DATA (GB(11,11,IC),IC=1,3) /
-  ! S 0.19817679E+01, 0.50437916E+01, 0.10000000E+01/
-  ! DATA (GA(11,12,IC),IC=1,3) /
-  ! S 0.26555181E+01, 0.13329782E+01, 0.00000000E+00/
-  ! DATA (GB(11,12,IC),IC=1,3) /
-  ! S 0.26555181E+01, 0.65558627E+01, 0.10000000E+01/
-
-
-
-
-
-  ! -- END WATER VAPOR
-
-
-  ! -- CO2 -- INT.2 -- 500-800 CM-1 --- FROM ABS225 ----------------------
-
-
-
-  ! -- FIU = 0.8 + MAX(0.35,(7-IU)*0.9)  , X/T,  9
-
-  ! ----- INTERVAL = 2 ----- T =  187.5
-
-  ! -- INDICES FOR PADE APPROXIMATION   1 30 38 45
-  ! DATA (GA( 1,13,IC),IC=1,3) /
-  ! S 0.87668459E-01, 0.13845511E+01, 0.00000000E+00/
-  ! DATA (GB( 1,13,IC),IC=1,3) /
-  ! S 0.87668459E-01, 0.23203798E+01, 0.10000000E+01/
-  ! DATA (GA( 1,14,IC),IC=1,3) /
-  ! S 0.74878820E-01, 0.11718758E+01, 0.00000000E+00/
-  ! DATA (GB( 1,14,IC),IC=1,3) /
-  ! S 0.74878820E-01, 0.20206726E+01, 0.10000000E+01/
-
-  ! ----- INTERVAL = 2 ----- T =  200.0
-
-  ! -- INDICES FOR PADE APPROXIMATION   1 30 38 45
-  ! DATA (GA( 2,13,IC),IC=1,3) /
-  ! S 0.83754276E-01, 0.13187042E+01, 0.00000000E+00/
-  ! DATA (GB( 2,13,IC),IC=1,3) /
-  ! S 0.83754276E-01, 0.22288925E+01, 0.10000000E+01/
-  ! DATA (GA( 2,14,IC),IC=1,3) /
-  ! S 0.71650966E-01, 0.11216131E+01, 0.00000000E+00/
-  ! DATA (GB( 2,14,IC),IC=1,3) /
-  ! S 0.71650966E-01, 0.19441824E+01, 0.10000000E+01/
-
-  ! ----- INTERVAL = 2 ----- T =  212.5
-
-  ! -- INDICES FOR PADE APPROXIMATION   1 30 38 45
-  ! DATA (GA( 3,13,IC),IC=1,3) /
-  ! S 0.80460283E-01, 0.12644396E+01, 0.00000000E+00/
-  ! DATA (GB( 3,13,IC),IC=1,3) /
-  ! S 0.80460283E-01, 0.21515593E+01, 0.10000000E+01/
-  ! DATA (GA( 3,14,IC),IC=1,3) /
-  ! S 0.68979615E-01, 0.10809473E+01, 0.00000000E+00/
-  ! DATA (GB( 3,14,IC),IC=1,3) /
-  ! S 0.68979615E-01, 0.18807257E+01, 0.10000000E+01/
-
-  ! ----- INTERVAL = 2 ----- T =  225.0
-
-  ! -- INDICES FOR PADE APPROXIMATION   1 30 38 45
-  ! DATA (GA( 4,13,IC),IC=1,3) /
-  ! S 0.77659686E-01, 0.12191543E+01, 0.00000000E+00/
-  ! DATA (GB( 4,13,IC),IC=1,3) /
-  ! S 0.77659686E-01, 0.20855896E+01, 0.10000000E+01/
-  ! DATA (GA( 4,14,IC),IC=1,3) /
-  ! S 0.66745345E-01, 0.10476396E+01, 0.00000000E+00/
-  ! DATA (GB( 4,14,IC),IC=1,3) /
-  ! S 0.66745345E-01, 0.18275618E+01, 0.10000000E+01/
-
-  ! ----- INTERVAL = 2 ----- T =  237.5
-
-  ! -- INDICES FOR PADE APPROXIMATION   1 30 38 45
-  ! DATA (GA( 5,13,IC),IC=1,3) /
-  ! S 0.75257056E-01, 0.11809511E+01, 0.00000000E+00/
-  ! DATA (GB( 5,13,IC),IC=1,3) /
-  ! S 0.75257056E-01, 0.20288489E+01, 0.10000000E+01/
-  ! DATA (GA( 5,14,IC),IC=1,3) /
-  ! S 0.64857571E-01, 0.10200373E+01, 0.00000000E+00/
-  ! DATA (GB( 5,14,IC),IC=1,3) /
-  ! S 0.64857571E-01, 0.17825910E+01, 0.10000000E+01/
-
-  ! ----- INTERVAL = 2 ----- T =  250.0
-
-  ! -- INDICES FOR PADE APPROXIMATION   1 30 38 45
-  ! DATA (GA( 6,13,IC),IC=1,3) /
-  ! S 0.73179175E-01, 0.11484154E+01, 0.00000000E+00/
-  ! DATA (GB( 6,13,IC),IC=1,3) /
-  ! S 0.73179175E-01, 0.19796791E+01, 0.10000000E+01/
-  ! DATA (GA( 6,14,IC),IC=1,3) /
-  ! S 0.63248495E-01, 0.99692726E+00, 0.00000000E+00/
-  ! DATA (GB( 6,14,IC),IC=1,3) /
-  ! S 0.63248495E-01, 0.17442308E+01, 0.10000000E+01/
-
-  ! ----- INTERVAL = 2 ----- T =  262.5
-
-  ! -- INDICES FOR PADE APPROXIMATION   1 30 38 45
-  ! DATA (GA( 7,13,IC),IC=1,3) /
-  ! S 0.71369063E-01, 0.11204723E+01, 0.00000000E+00/
-  ! DATA (GB( 7,13,IC),IC=1,3) /
-  ! S 0.71369063E-01, 0.19367778E+01, 0.10000000E+01/
-  ! DATA (GA( 7,14,IC),IC=1,3) /
-  ! S 0.61866970E-01, 0.97740923E+00, 0.00000000E+00/
-  ! DATA (GB( 7,14,IC),IC=1,3) /
-  ! S 0.61866970E-01, 0.17112809E+01, 0.10000000E+01/
-
-  ! ----- INTERVAL = 2 ----- T =  275.0
-
-  ! -- INDICES FOR PADE APPROXIMATION   1 30 38 45
-  ! DATA (GA( 8,13,IC),IC=1,3) /
-  ! S 0.69781812E-01, 0.10962918E+01, 0.00000000E+00/
-  ! DATA (GB( 8,13,IC),IC=1,3) /
-  ! S 0.69781812E-01, 0.18991112E+01, 0.10000000E+01/
-  ! DATA (GA( 8,14,IC),IC=1,3) /
-  ! S 0.60673632E-01, 0.96080188E+00, 0.00000000E+00/
-  ! DATA (GB( 8,14,IC),IC=1,3) /
-  ! S 0.60673632E-01, 0.16828137E+01, 0.10000000E+01/
-
-  ! ----- INTERVAL = 2 ----- T =  287.5
-
-  ! -- INDICES FOR PADE APPROXIMATION   1 30 38 45
-  ! DATA (GA( 9,13,IC),IC=1,3) /
-  ! S 0.68381606E-01, 0.10752229E+01, 0.00000000E+00/
-  ! DATA (GB( 9,13,IC),IC=1,3) /
-  ! S 0.68381606E-01, 0.18658501E+01, 0.10000000E+01/
-  ! DATA (GA( 9,14,IC),IC=1,3) /
-  ! S 0.59637277E-01, 0.94657562E+00, 0.00000000E+00/
-  ! DATA (GB( 9,14,IC),IC=1,3) /
-  ! S 0.59637277E-01, 0.16580908E+01, 0.10000000E+01/
-
-  ! ----- INTERVAL = 2 ----- T =  300.0
-
-  ! -- INDICES FOR PADE APPROXIMATION   1 30 38 45
-  ! DATA (GA(10,13,IC),IC=1,3) /
-  ! S 0.67139539E-01, 0.10567474E+01, 0.00000000E+00/
-  ! DATA (GB(10,13,IC),IC=1,3) /
-  ! S 0.67139539E-01, 0.18363226E+01, 0.10000000E+01/
-  ! DATA (GA(10,14,IC),IC=1,3) /
-  ! S 0.58732178E-01, 0.93430511E+00, 0.00000000E+00/
-  ! DATA (GB(10,14,IC),IC=1,3) /
-  ! S 0.58732178E-01, 0.16365014E+01, 0.10000000E+01/
-
-  ! ----- INTERVAL = 2 ----- T =  312.5
-
-  ! -- INDICES FOR PADE APPROXIMATION   1 30 38 45
-  ! DATA (GA(11,13,IC),IC=1,3) /
-  ! S 0.66032012E-01, 0.10404465E+01, 0.00000000E+00/
-  ! DATA (GB(11,13,IC),IC=1,3) /
-  ! S 0.66032012E-01, 0.18099779E+01, 0.10000000E+01/
-  ! DATA (GA(11,14,IC),IC=1,3) /
-  ! S 0.57936092E-01, 0.92363528E+00, 0.00000000E+00/
-  ! DATA (GB(11,14,IC),IC=1,3) /
-  ! S 0.57936092E-01, 0.16175164E+01, 0.10000000E+01/
-
-
-
-
-
-
-
-
-
-
-  ! -- CARBON DIOXIDE LINES IN THE WINDOW REGION (800-1250 CM-1)
-
-
-  ! -- G = 0.0
-
-
-  ! ----- INTERVAL = 4 ----- T =  187.5
-
-  ! -- INDICES FOR PADE APPROXIMATION     1   15   29   45
-  ! DATA (GA( 1,15,IC),IC=1,3) /
-  ! S 0.13230067E+02, 0.22042132E+02, 0.00000000E+00/
-  ! DATA (GB( 1,15,IC),IC=1,3) /
-  ! S 0.13230067E+02, 0.22051750E+02, 0.10000000E+01/
-  ! DATA (GA( 1,16,IC),IC=1,3) /
-  ! S 0.13183816E+02, 0.22169501E+02, 0.00000000E+00/
-  ! DATA (GB( 1,16,IC),IC=1,3) /
-  ! S 0.13183816E+02, 0.22178972E+02, 0.10000000E+01/
-
-  ! ----- INTERVAL = 4 ----- T =  200.0
-
-  ! -- INDICES FOR PADE APPROXIMATION     1   15   29   45
-  ! DATA (GA( 2,15,IC),IC=1,3) /
-  ! S 0.13213564E+02, 0.22107298E+02, 0.00000000E+00/
-  ! DATA (GB( 2,15,IC),IC=1,3) /
-  ! S 0.13213564E+02, 0.22116850E+02, 0.10000000E+01/
-  ! DATA (GA( 2,16,IC),IC=1,3) /
-  ! S 0.13189991E+02, 0.22270075E+02, 0.00000000E+00/
-  ! DATA (GB( 2,16,IC),IC=1,3) /
-  ! S 0.13189991E+02, 0.22279484E+02, 0.10000000E+01/
-
-  ! ----- INTERVAL = 4 ----- T =  212.5
-
-  ! -- INDICES FOR PADE APPROXIMATION     1   15   29   45
-  ! DATA (GA( 3,15,IC),IC=1,3) /
-  ! S 0.13209140E+02, 0.22180915E+02, 0.00000000E+00/
-  ! DATA (GB( 3,15,IC),IC=1,3) /
-  ! S 0.13209140E+02, 0.22190410E+02, 0.10000000E+01/
-  ! DATA (GA( 3,16,IC),IC=1,3) /
-  ! S 0.13209485E+02, 0.22379193E+02, 0.00000000E+00/
-  ! DATA (GB( 3,16,IC),IC=1,3) /
-  ! S 0.13209485E+02, 0.22388551E+02, 0.10000000E+01/
-
-  ! ----- INTERVAL = 4 ----- T =  225.0
-
-  ! -- INDICES FOR PADE APPROXIMATION     1   15   29   45
-  ! DATA (GA( 4,15,IC),IC=1,3) /
-  ! S 0.13213894E+02, 0.22259478E+02, 0.00000000E+00/
-  ! DATA (GB( 4,15,IC),IC=1,3) /
-  ! S 0.13213894E+02, 0.22268925E+02, 0.10000000E+01/
-  ! DATA (GA( 4,16,IC),IC=1,3) /
-  ! S 0.13238789E+02, 0.22492992E+02, 0.00000000E+00/
-  ! DATA (GB( 4,16,IC),IC=1,3) /
-  ! S 0.13238789E+02, 0.22502309E+02, 0.10000000E+01/
-
-  ! ----- INTERVAL = 4 ----- T =  237.5
-
-  ! -- INDICES FOR PADE APPROXIMATION     1   15   29   45
-  ! DATA (GA( 5,15,IC),IC=1,3) /
-  ! S 0.13225963E+02, 0.22341039E+02, 0.00000000E+00/
-  ! DATA (GB( 5,15,IC),IC=1,3) /
-  ! S 0.13225963E+02, 0.22350445E+02, 0.10000000E+01/
-  ! DATA (GA( 5,16,IC),IC=1,3) /
-  ! S 0.13275017E+02, 0.22608508E+02, 0.00000000E+00/
-  ! DATA (GB( 5,16,IC),IC=1,3) /
-  ! S 0.13275017E+02, 0.22617792E+02, 0.10000000E+01/
-
-  ! ----- INTERVAL = 4 ----- T =  250.0
-
-  ! -- INDICES FOR PADE APPROXIMATION     1   15   29   45
-  ! DATA (GA( 6,15,IC),IC=1,3) /
-  ! S 0.13243806E+02, 0.22424247E+02, 0.00000000E+00/
-  ! DATA (GB( 6,15,IC),IC=1,3) /
-  ! S 0.13243806E+02, 0.22433617E+02, 0.10000000E+01/
-  ! DATA (GA( 6,16,IC),IC=1,3) /
-  ! S 0.13316096E+02, 0.22723843E+02, 0.00000000E+00/
-  ! DATA (GB( 6,16,IC),IC=1,3) /
-  ! S 0.13316096E+02, 0.22733099E+02, 0.10000000E+01/
-
-  ! ----- INTERVAL = 4 ----- T =  262.5
-
-  ! -- INDICES FOR PADE APPROXIMATION     1   15   29   45
-  ! DATA (GA( 7,15,IC),IC=1,3) /
-  ! S 0.13266104E+02, 0.22508089E+02, 0.00000000E+00/
-  ! DATA (GB( 7,15,IC),IC=1,3) /
-  ! S 0.13266104E+02, 0.22517429E+02, 0.10000000E+01/
-  ! DATA (GA( 7,16,IC),IC=1,3) /
-  ! S 0.13360555E+02, 0.22837837E+02, 0.00000000E+00/
-  ! DATA (GB( 7,16,IC),IC=1,3) /
-  ! S 0.13360555E+02, 0.22847071E+02, 0.10000000E+01/
-
-  ! ----- INTERVAL = 4 ----- T =  275.0
-
-  ! -- INDICES FOR PADE APPROXIMATION     1   15   29   45
-  ! DATA (GA( 8,15,IC),IC=1,3) /
-  ! S 0.13291782E+02, 0.22591771E+02, 0.00000000E+00/
-  ! DATA (GB( 8,15,IC),IC=1,3) /
-  ! S 0.13291782E+02, 0.22601086E+02, 0.10000000E+01/
-  ! DATA (GA( 8,16,IC),IC=1,3) /
-  ! S 0.13407324E+02, 0.22949751E+02, 0.00000000E+00/
-  ! DATA (GB( 8,16,IC),IC=1,3) /
-  ! S 0.13407324E+02, 0.22958967E+02, 0.10000000E+01/
-
-  ! ----- INTERVAL = 4 ----- T =  287.5
-
-  ! -- INDICES FOR PADE APPROXIMATION     1   15   29   45
-  ! DATA (GA( 9,15,IC),IC=1,3) /
-  ! S 0.13319961E+02, 0.22674661E+02, 0.00000000E+00/
-  ! DATA (GB( 9,15,IC),IC=1,3) /
-  ! S 0.13319961E+02, 0.22683956E+02, 0.10000000E+01/
-  ! DATA (GA( 9,16,IC),IC=1,3) /
-  ! S 0.13455544E+02, 0.23059032E+02, 0.00000000E+00/
-  ! DATA (GB( 9,16,IC),IC=1,3) /
-  ! S 0.13455544E+02, 0.23068234E+02, 0.10000000E+01/
-
-  ! ----- INTERVAL = 4 ----- T =  300.0
-
-  ! -- INDICES FOR PADE APPROXIMATION     1   15   29   45
-  ! DATA (GA(10,15,IC),IC=1,3) /
-  ! S 0.13349927E+02, 0.22756246E+02, 0.00000000E+00/
-  ! DATA (GB(10,15,IC),IC=1,3) /
-  ! S 0.13349927E+02, 0.22765522E+02, 0.10000000E+01/
-  ! DATA (GA(10,16,IC),IC=1,3) /
-  ! S 0.13504450E+02, 0.23165146E+02, 0.00000000E+00/
-  ! DATA (GB(10,16,IC),IC=1,3) /
-  ! S 0.13504450E+02, 0.23174336E+02, 0.10000000E+01/
-
-  ! ----- INTERVAL = 4 ----- T =  312.5
-
-  ! -- INDICES FOR PADE APPROXIMATION     1   15   29   45
-  ! DATA (GA(11,15,IC),IC=1,3) /
-  ! S 0.13381108E+02, 0.22836093E+02, 0.00000000E+00/
-  ! DATA (GB(11,15,IC),IC=1,3) /
-  ! S 0.13381108E+02, 0.22845354E+02, 0.10000000E+01/
-  ! DATA (GA(11,16,IC),IC=1,3) /
-  ! S 0.13553282E+02, 0.23267456E+02, 0.00000000E+00/
-  ! DATA (GB(11,16,IC),IC=1,3) /
-  ! S 0.13553282E+02, 0.23276638E+02, 0.10000000E+01/
-
-  ! ------------------------------------------------------------------
-  ! DATA (( XP(  J,K),J=1,6),       K=1,6) /
-  ! S 0.46430621E+02, 0.12928299E+03, 0.20732648E+03,
-  ! S 0.31398411E+03, 0.18373177E+03,-0.11412303E+03,
-  ! S 0.73604774E+02, 0.27887914E+03, 0.27076947E+03,
-  ! S-0.57322111E+02,-0.64742459E+02, 0.87238280E+02,
-  ! S 0.37050866E+02, 0.20498759E+03, 0.37558029E+03,
-  ! S 0.17401171E+03,-0.13350302E+03,-0.37651795E+02,
-  ! S 0.14930141E+02, 0.89161160E+02, 0.17793062E+03,
-  ! S 0.93433860E+02,-0.70646020E+02,-0.26373150E+02,
-  ! S 0.40386780E+02, 0.10855270E+03, 0.50755010E+02,
-  ! S-0.31496190E+02, 0.12791300E+00, 0.18017770E+01,
-  ! S 0.90811926E+01, 0.75073923E+02, 0.24654438E+03,
-  ! S 0.39332612E+03, 0.29385281E+03, 0.89107921E+02 /
-
-
-
-  ! *         1.0     PLANCK FUNCTIONS AND GRADIENTS
-  ! ------------------------------
-
-
-  ! cdir collapse
-  DO jk = 1, kflev + 1
-    DO jl = 1, kdlon
-      pbint(jl, jk) = 0.
-    END DO
-  END DO
-  DO jl = 1, kdlon
-    pbsuin(jl) = 0.
-  END DO
-
-  DO jnu = 1, ninter
-
-    ! *         1.1   LEVELS FROM SURFACE TO KFLEV
-    ! ----------------------------
-
-
-    DO jk = 1, kflev
-      DO jl = 1, kdlon
-        zti(jl) = (ptl(jl,jk)-tstand)/tstand
-        zres(jl) = xp(1, jnu) + zti(jl)*(xp(2,jnu)+zti(jl)*(xp(3, &
-          jnu)+zti(jl)*(xp(4,jnu)+zti(jl)*(xp(5,jnu)+zti(jl)*(xp(6,jnu))))))
-        pbint(jl, jk) = pbint(jl, jk) + zres(jl)
-        pb(jl, jnu, jk) = zres(jl)
-        zblev(jl, jk) = zres(jl)
-        zti2(jl) = (ptave(jl,jk)-tstand)/tstand
-        zres2(jl) = xp(1, jnu) + zti2(jl)*(xp(2,jnu)+zti2(jl)*(xp(3, &
-          jnu)+zti2(jl)*(xp(4,jnu)+zti2(jl)*(xp(5,jnu)+zti2(jl)*(xp(6,jnu)))) &
-          ))
-        zblay(jl, jk) = zres2(jl)
-      END DO
-    END DO
-
-    ! *         1.2   TOP OF THE ATMOSPHERE AND SURFACE
-    ! ---------------------------------
-
-
-    DO jl = 1, kdlon
-      zti(jl) = (ptl(jl,kflev+1)-tstand)/tstand
-      zti2(jl) = (ptl(jl,1)+pdt0(jl)-tstand)/tstand
-      zres(jl) = xp(1, jnu) + zti(jl)*(xp(2,jnu)+zti(jl)*(xp(3, &
-        jnu)+zti(jl)*(xp(4,jnu)+zti(jl)*(xp(5,jnu)+zti(jl)*(xp(6,jnu))))))
-      zres2(jl) = xp(1, jnu) + zti2(jl)*(xp(2,jnu)+zti2(jl)*(xp(3, &
-        jnu)+zti2(jl)*(xp(4,jnu)+zti2(jl)*(xp(5,jnu)+zti2(jl)*(xp(6,jnu))))))
-      pbint(jl, kflev+1) = pbint(jl, kflev+1) + zres(jl)
-      pb(jl, jnu, kflev+1) = zres(jl)
-      zblev(jl, kflev+1) = zres(jl)
-      pbtop(jl, jnu) = zres(jl)
-      pbsur(jl, jnu) = zres2(jl)
-      pbsuin(jl) = pbsuin(jl) + zres2(jl)
-    END DO
-
-    ! *         1.3   GRADIENTS IN SUB-LAYERS
-    ! -----------------------
-
-
-    DO jk = 1, kflev
-      jk2 = 2*jk
-      jk1 = jk2 - 1
-      DO jl = 1, kdlon
-        pdbsl(jl, jnu, jk1) = zblay(jl, jk) - zblev(jl, jk)
-        pdbsl(jl, jnu, jk2) = zblev(jl, jk+1) - zblay(jl, jk)
-      END DO
-    END DO
-
-  END DO
-
-  ! *         2.0   CHOOSE THE RELEVANT SETS OF PADE APPROXIMANTS
-  ! ---------------------------------------------
-
-
-
-
-  DO jl = 1, kdlon
-    zdsto1 = (ptl(jl,kflev+1)-tintp(1))/tstp
-    ixtox = max(1, min(mxixt,int(zdsto1+1.)))
-    zdstox = (ptl(jl,kflev+1)-tintp(ixtox))/tstp
-    IF (zdstox<0.5) THEN
-      indto = ixtox
-    ELSE
-      indto = ixtox + 1
-    END IF
-    indb(jl) = indto
-    zdst1 = (ptl(jl,1)-tintp(1))/tstp
-    ixtx = max(1, min(mxixt,int(zdst1+1.)))
-    zdstx = (ptl(jl,1)-tintp(ixtx))/tstp
-    IF (zdstx<0.5) THEN
-      indt = ixtx
-    ELSE
-      indt = ixtx + 1
-    END IF
-    inds(jl) = indt
-  END DO
-
-  DO jf = 1, 2
-    DO jg = 1, 8
-      DO jl = 1, kdlon
-        indsu = inds(jl)
-        pgasur(jl, jg, jf) = ga(indsu, 2*jg-1, jf)
-        pgbsur(jl, jg, jf) = gb(indsu, 2*jg-1, jf)
-        indtp = indb(jl)
-        pgatop(jl, jg, jf) = ga(indtp, 2*jg-1, jf)
-        pgbtop(jl, jg, jf) = gb(indtp, 2*jg-1, jf)
-      END DO
-    END DO
-  END DO
-
-  DO jk = 1, kflev
-    DO jl = 1, kdlon
-      zdst1 = (ptave(jl,jk)-tintp(1))/tstp
-      ixtx = max(1, min(mxixt,int(zdst1+1.)))
-      zdstx = (ptave(jl,jk)-tintp(ixtx))/tstp
-      IF (zdstx<0.5) THEN
-        indt = ixtx
-      ELSE
-        indt = ixtx + 1
-      END IF
-      indb(jl) = indt
-    END DO
-
-    DO jf = 1, 2
-      DO jg = 1, 8
-        DO jl = 1, kdlon
-          indt = indb(jl)
-          pga(jl, jg, jf, jk) = ga(indt, 2*jg, jf)
-          pgb(jl, jg, jf, jk) = gb(indt, 2*jg, jf)
-        END DO
-      END DO
-    END DO
-  END DO
-
-  ! ------------------------------------------------------------------
-
-  RETURN
-END SUBROUTINE lwb_lmdar4
-SUBROUTINE lwv_lmdar4(kuaer, ktraer, klim, pabcu, pb, pbint, pbsuin, pbsur, &
-    pbtop, pdbsl, pemis, ppmb, ptave, pga, pgb, pgasur, pgbsur, pgatop, &
-    pgbtop, pcntrb, pcts, pfluc)
-  USE dimphy
-  IMPLICIT NONE
-  include "raddimlw.h"
-  include "YOMCST.h"
-
-  ! -----------------------------------------------------------------------
-  ! PURPOSE.
-  ! --------
-  ! CARRIES OUT THE VERTICAL INTEGRATION TO GIVE LONGWAVE
-  ! FLUXES OR RADIANCES
-
-  ! METHOD.
-  ! -------
-
-  ! 1. PERFORMS THE VERTICAL INTEGRATION DISTINGUISHING BETWEEN
-  ! CONTRIBUTIONS BY -  THE NEARBY LAYERS
-  ! -  THE DISTANT LAYERS
-  ! -  THE BOUNDARY TERMS
-  ! 2. COMPUTES THE CLEAR-SKY DOWNWARD AND UPWARD EMISSIVITIES.
-
-  ! REFERENCE.
-  ! ----------
-
-  ! SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
-  ! ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
-
-  ! AUTHOR.
-  ! -------
-  ! JEAN-JACQUES MORCRETTE  *ECMWF*
-
-  ! MODIFICATIONS.
-  ! --------------
-  ! ORIGINAL : 89-07-14
-  ! -----------------------------------------------------------------------
-
-  ! * ARGUMENTS:
-  INTEGER kuaer, ktraer, klim
-
-  REAL (KIND=8) pabcu(kdlon, nua, 3*kflev+1) ! EFFECTIVE ABSORBER AMOUNTS
-  REAL (KIND=8) pb(kdlon, ninter, kflev+1) ! SPECTRAL HALF-LEVEL PLANCK FUNCTIONS
-  REAL (KIND=8) pbint(kdlon, kflev+1) ! HALF-LEVEL PLANCK FUNCTIONS
-  REAL (KIND=8) pbsur(kdlon, ninter) ! SURFACE SPECTRAL PLANCK FUNCTION
-  REAL (KIND=8) pbsuin(kdlon) ! SURFACE PLANCK FUNCTION
-  REAL (KIND=8) pbtop(kdlon, ninter) ! T.O.A. SPECTRAL PLANCK FUNCTION
-  REAL (KIND=8) pdbsl(kdlon, ninter, kflev*2) ! SUB-LAYER PLANCK FUNCTION GRADIENT
-  REAL (KIND=8) pemis(kdlon) ! SURFACE EMISSIVITY
-  REAL (KIND=8) ppmb(kdlon, kflev+1) ! HALF-LEVEL PRESSURE (MB)
-  REAL (KIND=8) ptave(kdlon, kflev) ! TEMPERATURE
-  REAL (KIND=8) pga(kdlon, 8, 2, kflev) ! PADE APPROXIMANTS
-  REAL (KIND=8) pgb(kdlon, 8, 2, kflev) ! PADE APPROXIMANTS
-  REAL (KIND=8) pgasur(kdlon, 8, 2) ! PADE APPROXIMANTS
-  REAL (KIND=8) pgbsur(kdlon, 8, 2) ! PADE APPROXIMANTS
-  REAL (KIND=8) pgatop(kdlon, 8, 2) ! PADE APPROXIMANTS
-  REAL (KIND=8) pgbtop(kdlon, 8, 2) ! PADE APPROXIMANTS
-
-  REAL (KIND=8) pcntrb(kdlon, kflev+1, kflev+1) ! CLEAR-SKY ENERGY EXCHANGE MATRIX
-  REAL (KIND=8) pcts(kdlon, kflev) ! COOLING-TO-SPACE TERM
-  REAL (KIND=8) pfluc(kdlon, 2, kflev+1) ! CLEAR-SKY RADIATIVE FLUXES
-  ! -----------------------------------------------------------------------
-  ! LOCAL VARIABLES:
-  REAL (KIND=8) zadjd(kdlon, kflev+1)
-  REAL (KIND=8) zadju(kdlon, kflev+1)
-  REAL (KIND=8) zdbdt(kdlon, ninter, kflev)
-  REAL (KIND=8) zdisd(kdlon, kflev+1)
-  REAL (KIND=8) zdisu(kdlon, kflev+1)
-
-  INTEGER jk, jl
-  ! -----------------------------------------------------------------------
-
-  DO jk = 1, kflev + 1
-    DO jl = 1, kdlon
-      zadjd(jl, jk) = 0.
-      zadju(jl, jk) = 0.
-      zdisd(jl, jk) = 0.
-      zdisu(jl, jk) = 0.
-    END DO
-  END DO
-
-  DO jk = 1, kflev
-    DO jl = 1, kdlon
-      pcts(jl, jk) = 0.
-    END DO
-  END DO
-
-  ! * CONTRIBUTION FROM ADJACENT LAYERS
-
-  CALL lwvn_lmdar4(kuaer, ktraer, pabcu, pdbsl, pga, pgb, zadjd, zadju, &
-    pcntrb, zdbdt)
-  ! * CONTRIBUTION FROM DISTANT LAYERS
-
-  CALL lwvd_lmdar4(kuaer, ktraer, pabcu, zdbdt, pga, pgb, pcntrb, zdisd, &
-    zdisu)
-
-  ! * EXCHANGE WITH THE BOUNDARIES
-
-  CALL lwvb_lmdar4(kuaer, ktraer, klim, pabcu, zadjd, zadju, pb, pbint, &
-    pbsuin, pbsur, pbtop, zdisd, zdisu, pemis, ppmb, pga, pgb, pgasur, &
-    pgbsur, pgatop, pgbtop, pcts, pfluc)
-
-
-  RETURN
-END SUBROUTINE lwv_lmdar4
-SUBROUTINE lwvb_lmdar4(kuaer, ktraer, klim, pabcu, padjd, padju, pb, pbint, &
-    pbsui, pbsur, pbtop, pdisd, pdisu, pemis, ppmb, pga, pgb, pgasur, pgbsur, &
-    pgatop, pgbtop, pcts, pfluc)
-  USE dimphy
-  IMPLICIT NONE
-  include "raddimlw.h"
-  include "radopt.h"
-
-  ! -----------------------------------------------------------------------
-  ! PURPOSE.
-  ! --------
-  ! INTRODUCES THE EFFECTS OF THE BOUNDARIES IN THE VERTICAL
-  ! INTEGRATION
-
-  ! METHOD.
-  ! -------
-
-  ! 1. COMPUTES THE ENERGY EXCHANGE WITH TOP AND SURFACE OF THE
-  ! ATMOSPHERE
-  ! 2. COMPUTES THE COOLING-TO-SPACE AND HEATING-FROM-GROUND
-  ! TERMS FOR THE APPROXIMATE COOLING RATE ABOVE 10 HPA
-  ! 3. ADDS UP ALL CONTRIBUTIONS TO GET THE CLEAR-SKY FLUXES
-
-  ! REFERENCE.
-  ! ----------
-
-  ! SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
-  ! ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
-
-  ! AUTHOR.
-  ! -------
-  ! JEAN-JACQUES MORCRETTE  *ECMWF*
-
-  ! MODIFICATIONS.
-  ! --------------
-  ! ORIGINAL : 89-07-14
-  ! Voigt lines (loop 2413 to 2427)  - JJM & PhD - 01/96
-  ! -----------------------------------------------------------------------
-
-  ! *       0.1   ARGUMENTS
-  ! ---------
-
-  INTEGER kuaer, ktraer, klim
-
-  REAL (KIND=8) pabcu(kdlon, nua, 3*kflev+1) ! ABSORBER AMOUNTS
-  REAL (KIND=8) padjd(kdlon, kflev+1) ! CONTRIBUTION BY ADJACENT LAYERS
-  REAL (KIND=8) padju(kdlon, kflev+1) ! CONTRIBUTION BY ADJACENT LAYERS
-  REAL (KIND=8) pb(kdlon, ninter, kflev+1) ! SPECTRAL HALF-LEVEL PLANCK FUNCTIONS
-  REAL (KIND=8) pbint(kdlon, kflev+1) ! HALF-LEVEL PLANCK FUNCTIONS
-  REAL (KIND=8) pbsur(kdlon, ninter) ! SPECTRAL SURFACE PLANCK FUNCTION
-  REAL (KIND=8) pbsui(kdlon) ! SURFACE PLANCK FUNCTION
-  REAL (KIND=8) pbtop(kdlon, ninter) ! SPECTRAL T.O.A. PLANCK FUNCTION
-  REAL (KIND=8) pdisd(kdlon, kflev+1) ! CONTRIBUTION BY DISTANT LAYERS
-  REAL (KIND=8) pdisu(kdlon, kflev+1) ! CONTRIBUTION BY DISTANT LAYERS
-  REAL (KIND=8) pemis(kdlon) ! SURFACE EMISSIVITY
-  REAL (KIND=8) ppmb(kdlon, kflev+1) ! PRESSURE MB
-  REAL (KIND=8) pga(kdlon, 8, 2, kflev) ! PADE APPROXIMANTS
-  REAL (KIND=8) pgb(kdlon, 8, 2, kflev) ! PADE APPROXIMANTS
-  REAL (KIND=8) pgasur(kdlon, 8, 2) ! SURFACE PADE APPROXIMANTS
-  REAL (KIND=8) pgbsur(kdlon, 8, 2) ! SURFACE PADE APPROXIMANTS
-  REAL (KIND=8) pgatop(kdlon, 8, 2) ! T.O.A. PADE APPROXIMANTS
-  REAL (KIND=8) pgbtop(kdlon, 8, 2) ! T.O.A. PADE APPROXIMANTS
-
-  REAL (KIND=8) pfluc(kdlon, 2, kflev+1) ! CLEAR-SKY RADIATIVE FLUXES
-  REAL (KIND=8) pcts(kdlon, kflev) ! COOLING-TO-SPACE TERM
-
-  ! * LOCAL VARIABLES:
-
-  REAL (KIND=8) zbgnd(kdlon)
-  REAL (KIND=8) zfd(kdlon)
-  REAL (KIND=8) zfn10(kdlon)
-  REAL (KIND=8) zfu(kdlon)
-  REAL (KIND=8) ztt(kdlon, ntra)
-  REAL (KIND=8) ztt1(kdlon, ntra)
-  REAL (KIND=8) ztt2(kdlon, ntra)
-  REAL (KIND=8) zuu(kdlon, nua)
-  REAL (KIND=8) zcnsol(kdlon)
-  REAL (KIND=8) zcntop(kdlon)
-
-  INTEGER jk, jl, ja
-  INTEGER jstra, jstru
-  INTEGER ind1, ind2, ind3, ind4, in, jlim
-  REAL (KIND=8) zctstr
-
-  ! -----------------------------------------------------------------------
-
-  ! *         1.    INITIALIZATION
-  ! --------------
-
-
-
-  ! *         1.2     INITIALIZE TRANSMISSION FUNCTIONS
-  ! ---------------------------------
-
-
-  DO ja = 1, ntra
-    DO jl = 1, kdlon
-      ztt(jl, ja) = 1.0
-      ztt1(jl, ja) = 1.0
-      ztt2(jl, ja) = 1.0
-    END DO
-  END DO
-
-  DO ja = 1, nua
-    DO jl = 1, kdlon
-      zuu(jl, ja) = 1.0
-    END DO
-  END DO
-
-  ! ------------------------------------------------------------------
-
-  ! *         2.      VERTICAL INTEGRATION
-  ! --------------------
-
-
-  ind1 = 0
-  ind3 = 0
-  ind4 = 1
-  ind2 = 1
-
-  ! *         2.3     EXCHANGE WITH TOP OF THE ATMOSPHERE
-  ! -----------------------------------
-
-
-  DO jk = 1, kflev
-    in = (jk-1)*ng1p1 + 1
-
-    DO ja = 1, kuaer
-      DO jl = 1, kdlon
-        zuu(jl, ja) = pabcu(jl, ja, in)
-      END DO
-    END DO
-
-
-    CALL lwtt_lmdar4(pgatop(1,1,1), pgbtop(1,1,1), zuu, ztt)
-
-    DO jl = 1, kdlon
-      zcntop(jl) = pbtop(jl, 1)*ztt(jl, 1)*ztt(jl, 10) + &
-        pbtop(jl, 2)*ztt(jl, 2)*ztt(jl, 7)*ztt(jl, 11) + &
-        pbtop(jl, 3)*ztt(jl, 4)*ztt(jl, 8)*ztt(jl, 12) + &
-        pbtop(jl, 4)*ztt(jl, 5)*ztt(jl, 9)*ztt(jl, 13) + &
-        pbtop(jl, 5)*ztt(jl, 3)*ztt(jl, 14) + pbtop(jl, 6)*ztt(jl, 6)*ztt(jl, &
-        15)
-      zfd(jl) = zcntop(jl) - pbint(jl, jk) - pdisd(jl, jk) - padjd(jl, jk)
-      pfluc(jl, 2, jk) = zfd(jl)
-    END DO
-
-  END DO
-
-  jk = kflev + 1
-  in = (jk-1)*ng1p1 + 1
-
-  DO jl = 1, kdlon
-    zcntop(jl) = pbtop(jl, 1) + pbtop(jl, 2) + pbtop(jl, 3) + pbtop(jl, 4) + &
-      pbtop(jl, 5) + pbtop(jl, 6)
-    zfd(jl) = zcntop(jl) - pbint(jl, jk) - pdisd(jl, jk) - padjd(jl, jk)
-    pfluc(jl, 2, jk) = zfd(jl)
-  END DO
-
-  ! *         2.4     COOLING-TO-SPACE OF LAYERS ABOVE 10 HPA
-  ! ---------------------------------------
-
-
-
-  ! *         2.4.1   INITIALIZATION
-  ! --------------
-
-
-  jlim = kflev
-
-  IF (.NOT. levoigt) THEN
-    DO jk = kflev, 1, -1
-      IF (ppmb(1,jk)<10.0) THEN
-        jlim = jk
-      END IF
-    END DO
-  END IF
-  klim = jlim
-
-  IF (.NOT. levoigt) THEN
-    DO ja = 1, ktraer
-      DO jl = 1, kdlon
-        ztt1(jl, ja) = 1.0
-      END DO
-    END DO
-
-    ! *         2.4.2   LOOP OVER LAYERS ABOVE 10 HPA
-    ! -----------------------------
-
-
-    DO jstra = kflev, jlim, -1
-      jstru = (jstra-1)*ng1p1 + 1
-
-      DO ja = 1, kuaer
-        DO jl = 1, kdlon
-          zuu(jl, ja) = pabcu(jl, ja, jstru)
-        END DO
-      END DO
-
-
-      CALL lwtt_lmdar4(pga(1,1,1,jstra), pgb(1,1,1,jstra), zuu, ztt)
-
-      DO jl = 1, kdlon
-        zctstr = (pb(jl,1,jstra)+pb(jl,1,jstra+1))* &
-          (ztt1(jl,1)*ztt1(jl,10)-ztt(jl,1)*ztt(jl,10)) + &
-          (pb(jl,2,jstra)+pb(jl,2,jstra+1))*(ztt1(jl,2)*ztt1(jl,7)*ztt1(jl,11 &
-          )-ztt(jl,2)*ztt(jl,7)*ztt(jl,11)) + (pb(jl,3,jstra)+pb(jl,3,jstra+1 &
-          ))*(ztt1(jl,4)*ztt1(jl,8)*ztt1(jl,12)-ztt(jl,4)*ztt(jl,8)*ztt(jl,12 &
-          )) + (pb(jl,4,jstra)+pb(jl,4,jstra+1))*(ztt1(jl,5)*ztt1(jl,9)*ztt1( &
-          jl,13)-ztt(jl,5)*ztt(jl,9)*ztt(jl,13)) + (pb(jl,5,jstra)+pb(jl,5, &
-          jstra+1))*(ztt1(jl,3)*ztt1(jl,14)-ztt(jl,3)*ztt(jl,14)) + &
-          (pb(jl,6,jstra)+pb(jl,6,jstra+1))*(ztt1(jl,6)*ztt1(jl,15)-ztt(jl,6) &
-          *ztt(jl,15))
-        pcts(jl, jstra) = zctstr*0.5
-      END DO
-      DO ja = 1, ktraer
-        DO jl = 1, kdlon
-          ztt1(jl, ja) = ztt(jl, ja)
-        END DO
-      END DO
-    END DO
-  END IF
-  ! Mise a zero de securite pour PCTS en cas de LEVOIGT
-  IF (levoigt) THEN
-    DO jstra = 1, kflev
-      DO jl = 1, kdlon
-        pcts(jl, jstra) = 0.
-      END DO
-    END DO
-  END IF
-
-  ! *         2.5     EXCHANGE WITH LOWER LIMIT
-  ! -------------------------
-
-
-  DO jl = 1, kdlon
-    zbgnd(jl) = pbsui(jl)*pemis(jl) - (1.-pemis(jl))*pfluc(jl, 2, 1) - &
-      pbint(jl, 1)
-  END DO
-
-  jk = 1
-  in = (jk-1)*ng1p1 + 1
-
-  DO jl = 1, kdlon
-    zcnsol(jl) = pbsur(jl, 1) + pbsur(jl, 2) + pbsur(jl, 3) + pbsur(jl, 4) + &
-      pbsur(jl, 5) + pbsur(jl, 6)
-    zcnsol(jl) = zcnsol(jl)*zbgnd(jl)/pbsui(jl)
-    zfu(jl) = zcnsol(jl) + pbint(jl, jk) - pdisu(jl, jk) - padju(jl, jk)
-    pfluc(jl, 1, jk) = zfu(jl)
-  END DO
-
-  DO jk = 2, kflev + 1
-    in = (jk-1)*ng1p1 + 1
-
-
-    DO ja = 1, kuaer
-      DO jl = 1, kdlon
-        zuu(jl, ja) = pabcu(jl, ja, 1) - pabcu(jl, ja, in)
-      END DO
-    END DO
-
-
-    CALL lwtt_lmdar4(pgasur(1,1,1), pgbsur(1,1,1), zuu, ztt)
-
-    DO jl = 1, kdlon
-      zcnsol(jl) = pbsur(jl, 1)*ztt(jl, 1)*ztt(jl, 10) + &
-        pbsur(jl, 2)*ztt(jl, 2)*ztt(jl, 7)*ztt(jl, 11) + &
-        pbsur(jl, 3)*ztt(jl, 4)*ztt(jl, 8)*ztt(jl, 12) + &
-        pbsur(jl, 4)*ztt(jl, 5)*ztt(jl, 9)*ztt(jl, 13) + &
-        pbsur(jl, 5)*ztt(jl, 3)*ztt(jl, 14) + pbsur(jl, 6)*ztt(jl, 6)*ztt(jl, &
-        15)
-      zcnsol(jl) = zcnsol(jl)*zbgnd(jl)/pbsui(jl)
-      zfu(jl) = zcnsol(jl) + pbint(jl, jk) - pdisu(jl, jk) - padju(jl, jk)
-      pfluc(jl, 1, jk) = zfu(jl)
-    END DO
-
-
-  END DO
-
-  ! *         2.7     CLEAR-SKY FLUXES
-  ! ----------------
-
-
-  IF (.NOT. levoigt) THEN
-    DO jl = 1, kdlon
-      zfn10(jl) = pfluc(jl, 1, jlim) + pfluc(jl, 2, jlim)
-    END DO
-    DO jk = jlim + 1, kflev + 1
-      DO jl = 1, kdlon
-        zfn10(jl) = zfn10(jl) + pcts(jl, jk-1)
-        pfluc(jl, 1, jk) = zfn10(jl)
-        pfluc(jl, 2, jk) = 0.
-      END DO
-    END DO
-  END IF
-
-  ! ------------------------------------------------------------------
-
-  RETURN
-END SUBROUTINE lwvb_lmdar4
-SUBROUTINE lwvd_lmdar4(kuaer, ktraer, pabcu, pdbdt, pga, pgb, pcntrb, pdisd, &
-    pdisu)
-  USE dimphy
-  IMPLICIT NONE
-  include "raddimlw.h"
-
-  ! -----------------------------------------------------------------------
-  ! PURPOSE.
-  ! --------
-  ! CARRIES OUT THE VERTICAL INTEGRATION ON THE DISTANT LAYERS
-
-  ! METHOD.
-  ! -------
-
-  ! 1. PERFORMS THE VERTICAL INTEGRATION CORRESPONDING TO THE
-  ! CONTRIBUTIONS OF THE DISTANT LAYERS USING TRAPEZOIDAL RULE
-
-  ! REFERENCE.
-  ! ----------
-
-  ! SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
-  ! ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
-
-  ! AUTHOR.
-  ! -------
-  ! JEAN-JACQUES MORCRETTE  *ECMWF*
-
-  ! MODIFICATIONS.
-  ! --------------
-  ! ORIGINAL : 89-07-14
-  ! -----------------------------------------------------------------------
-  ! * ARGUMENTS:
-
-  INTEGER kuaer, ktraer
-
-  REAL (KIND=8) pabcu(kdlon, nua, 3*kflev+1) ! ABSORBER AMOUNTS
-  REAL (KIND=8) pdbdt(kdlon, ninter, kflev) ! LAYER PLANCK FUNCTION GRADIENT
-  REAL (KIND=8) pga(kdlon, 8, 2, kflev) ! PADE APPROXIMANTS
-  REAL (KIND=8) pgb(kdlon, 8, 2, kflev) ! PADE APPROXIMANTS
-
-  REAL (KIND=8) pcntrb(kdlon, kflev+1, kflev+1) ! ENERGY EXCHANGE MATRIX
-  REAL (KIND=8) pdisd(kdlon, kflev+1) !  CONTRIBUTION BY DISTANT LAYERS
-  REAL (KIND=8) pdisu(kdlon, kflev+1) !  CONTRIBUTION BY DISTANT LAYERS
-
-  ! * LOCAL VARIABLES:
-
-  REAL (KIND=8) zglayd(kdlon)
-  REAL (KIND=8) zglayu(kdlon)
-  REAL (KIND=8) ztt(kdlon, ntra)
-  REAL (KIND=8) ztt1(kdlon, ntra)
-  REAL (KIND=8) ztt2(kdlon, ntra)
-
-  INTEGER jl, jk, ja, ikp1, ikn, ikd1, jkj, ikd2
-  INTEGER ikjp1, ikm1, ikj, jlk, iku1, ijkl, iku2
-  INTEGER ind1, ind2, ind3, ind4, itt
-  REAL (KIND=8) zww, zdzxdg, zdzxmg
-
-  ! *         1.    INITIALIZATION
-  ! --------------
-
-
-  ! *         1.1     INITIALIZE LAYER CONTRIBUTIONS
-  ! ------------------------------
-
-
-  DO jk = 1, kflev + 1
-    DO jl = 1, kdlon
-      pdisd(jl, jk) = 0.
-      pdisu(jl, jk) = 0.
-    END DO
-  END DO
-
-  ! *         1.2     INITIALIZE TRANSMISSION FUNCTIONS
-  ! ---------------------------------
-
-
-
-  DO ja = 1, ntra
-    DO jl = 1, kdlon
-      ztt(jl, ja) = 1.0
-      ztt1(jl, ja) = 1.0
-      ztt2(jl, ja) = 1.0
-    END DO
-  END DO
-
-  ! ------------------------------------------------------------------
-
-  ! *         2.      VERTICAL INTEGRATION
-  ! --------------------
-
-
-  ind1 = 0
-  ind3 = 0
-  ind4 = 1
-  ind2 = 1
-
-  ! *         2.2     CONTRIBUTION FROM DISTANT LAYERS
-  ! ---------------------------------
-
-
-
-  ! *         2.2.1   DISTANT AND ABOVE LAYERS
-  ! ------------------------
-
-
-
-
-  ! *         2.2.2   FIRST UPPER LEVEL
-  ! -----------------
-
-
-  DO jk = 1, kflev - 1
-    ikp1 = jk + 1
-    ikn = (jk-1)*ng1p1 + 1
-    ikd1 = jk*ng1p1 + 1
-
-    CALL lwttm_lmdar4(pga(1,1,1,jk), pgb(1,1,1,jk), pabcu(1,1,ikn), &
-      pabcu(1,1,ikd1), ztt1)
-
-    ! *         2.2.3   HIGHER UP
-    ! ---------
-
-
-    itt = 1
-    DO jkj = ikp1, kflev
-      IF (itt==1) THEN
-        itt = 2
-      ELSE
-        itt = 1
-      END IF
-      ikjp1 = jkj + 1
-      ikd2 = jkj*ng1p1 + 1
-
-      IF (itt==1) THEN
-        CALL lwttm_lmdar4(pga(1,1,1,jkj), pgb(1,1,1,jkj), pabcu(1,1,ikn), &
-          pabcu(1,1,ikd2), ztt1)
-      ELSE
-        CALL lwttm_lmdar4(pga(1,1,1,jkj), pgb(1,1,1,jkj), pabcu(1,1,ikn), &
-          pabcu(1,1,ikd2), ztt2)
-      END IF
-
-      DO ja = 1, ktraer
-        DO jl = 1, kdlon
-          ztt(jl, ja) = (ztt1(jl,ja)+ztt2(jl,ja))*0.5
-        END DO
-      END DO
-
-      DO jl = 1, kdlon
-        zww = pdbdt(jl, 1, jkj)*ztt(jl, 1)*ztt(jl, 10) + &
-          pdbdt(jl, 2, jkj)*ztt(jl, 2)*ztt(jl, 7)*ztt(jl, 11) + &
-          pdbdt(jl, 3, jkj)*ztt(jl, 4)*ztt(jl, 8)*ztt(jl, 12) + &
-          pdbdt(jl, 4, jkj)*ztt(jl, 5)*ztt(jl, 9)*ztt(jl, 13) + &
-          pdbdt(jl, 5, jkj)*ztt(jl, 3)*ztt(jl, 14) + &
-          pdbdt(jl, 6, jkj)*ztt(jl, 6)*ztt(jl, 15)
-        zglayd(jl) = zww
-        zdzxdg = zglayd(jl)
-        pdisd(jl, jk) = pdisd(jl, jk) + zdzxdg
-        pcntrb(jl, jk, ikjp1) = zdzxdg
-      END DO
-
-
-    END DO
-  END DO
-
-  ! *         2.2.4   DISTANT AND BELOW LAYERS
-  ! ------------------------
-
-
-
-
-  ! *         2.2.5   FIRST LOWER LEVEL
-  ! -----------------
-
-
-  DO jk = 3, kflev + 1
-    ikn = (jk-1)*ng1p1 + 1
-    ikm1 = jk - 1
-    ikj = jk - 2
-    iku1 = ikj*ng1p1 + 1
-
-
-    CALL lwttm_lmdar4(pga(1,1,1,ikj), pgb(1,1,1,ikj), pabcu(1,1,iku1), &
-      pabcu(1,1,ikn), ztt1)
-
-    ! *         2.2.6   DOWN BELOW
-    ! ----------
-
-
-    itt = 1
-    DO jlk = 1, ikj
-      IF (itt==1) THEN
-        itt = 2
-      ELSE
-        itt = 1
-      END IF
-      ijkl = ikm1 - jlk
-      iku2 = (ijkl-1)*ng1p1 + 1
-
-
-      IF (itt==1) THEN
-        CALL lwttm_lmdar4(pga(1,1,1,ijkl), pgb(1,1,1,ijkl), pabcu(1,1,iku2), &
-          pabcu(1,1,ikn), ztt1)
-      ELSE
-        CALL lwttm_lmdar4(pga(1,1,1,ijkl), pgb(1,1,1,ijkl), pabcu(1,1,iku2), &
-          pabcu(1,1,ikn), ztt2)
-      END IF
-
-      DO ja = 1, ktraer
-        DO jl = 1, kdlon
-          ztt(jl, ja) = (ztt1(jl,ja)+ztt2(jl,ja))*0.5
-        END DO
-      END DO
-
-      DO jl = 1, kdlon
-        zww = pdbdt(jl, 1, ijkl)*ztt(jl, 1)*ztt(jl, 10) + &
-          pdbdt(jl, 2, ijkl)*ztt(jl, 2)*ztt(jl, 7)*ztt(jl, 11) + &
-          pdbdt(jl, 3, ijkl)*ztt(jl, 4)*ztt(jl, 8)*ztt(jl, 12) + &
-          pdbdt(jl, 4, ijkl)*ztt(jl, 5)*ztt(jl, 9)*ztt(jl, 13) + &
-          pdbdt(jl, 5, ijkl)*ztt(jl, 3)*ztt(jl, 14) + &
-          pdbdt(jl, 6, ijkl)*ztt(jl, 6)*ztt(jl, 15)
-        zglayu(jl) = zww
-        zdzxmg = zglayu(jl)
-        pdisu(jl, jk) = pdisu(jl, jk) + zdzxmg
-        pcntrb(jl, jk, ijkl) = zdzxmg
-      END DO
-
-
-    END DO
-  END DO
-
-  RETURN
-END SUBROUTINE lwvd_lmdar4
-SUBROUTINE lwvn_lmdar4(kuaer, ktraer, pabcu, pdbsl, pga, pgb, padjd, padju, &
-    pcntrb, pdbdt)
-  USE dimphy
-  USE radiation_ar4_param, ONLY: wg1
-  IMPLICIT NONE
-  include "raddimlw.h"
-
-  ! -----------------------------------------------------------------------
-  ! PURPOSE.
-  ! --------
-  ! CARRIES OUT THE VERTICAL INTEGRATION ON NEARBY LAYERS
-  ! TO GIVE LONGWAVE FLUXES OR RADIANCES
-
-  ! METHOD.
-  ! -------
-
-  ! 1. PERFORMS THE VERTICAL INTEGRATION CORRESPONDING TO THE
-  ! CONTRIBUTIONS OF THE ADJACENT LAYERS USING A GAUSSIAN QUADRATURE
-
-  ! REFERENCE.
-  ! ----------
-
-  ! SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
-  ! ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
-
-  ! AUTHOR.
-  ! -------
-  ! JEAN-JACQUES MORCRETTE  *ECMWF*
-
-  ! MODIFICATIONS.
-  ! --------------
-  ! ORIGINAL : 89-07-14
-  ! -----------------------------------------------------------------------
-
-  ! * ARGUMENTS:
-
-  INTEGER kuaer, ktraer
-
-  REAL (KIND=8) pabcu(kdlon, nua, 3*kflev+1) ! ABSORBER AMOUNTS
-  REAL (KIND=8) pdbsl(kdlon, ninter, kflev*2) ! SUB-LAYER PLANCK FUNCTION GRADIENT
-  REAL (KIND=8) pga(kdlon, 8, 2, kflev) ! PADE APPROXIMANTS
-  REAL (KIND=8) pgb(kdlon, 8, 2, kflev) ! PADE APPROXIMANTS
-
-  REAL (KIND=8) padjd(kdlon, kflev+1) ! CONTRIBUTION OF ADJACENT LAYERS
-  REAL (KIND=8) padju(kdlon, kflev+1) ! CONTRIBUTION OF ADJACENT LAYERS
-  REAL (KIND=8) pcntrb(kdlon, kflev+1, kflev+1) ! CLEAR-SKY ENERGY EXCHANGE MATRIX
-  REAL (KIND=8) pdbdt(kdlon, ninter, kflev) !  LAYER PLANCK FUNCTION GRADIENT
-
-  ! * LOCAL ARRAYS:
-
-  REAL (KIND=8) zglayd(kdlon)
-  REAL (KIND=8) zglayu(kdlon)
-  REAL (KIND=8) ztt(kdlon, ntra)
-  REAL (KIND=8) ztt1(kdlon, ntra)
-  REAL (KIND=8) ztt2(kdlon, ntra)
-  REAL (KIND=8) zuu(kdlon, nua)
-
-  INTEGER jk, jl, ja, im12, ind, inu, ixu, jg
-  INTEGER ixd, ibs, idd, imu, jk1, jk2, jnu
-  REAL (KIND=8) zwtr
-
-  ! -----------------------------------------------------------------------
-
-  ! *         1.    INITIALIZATION
-  ! --------------
-
-
-  ! *         1.1     INITIALIZE LAYER CONTRIBUTIONS
-  ! ------------------------------
-
-
-  DO jk = 1, kflev + 1
-    DO jl = 1, kdlon
-      padjd(jl, jk) = 0.
-      padju(jl, jk) = 0.
-    END DO
-  END DO
-
-  ! *         1.2     INITIALIZE TRANSMISSION FUNCTIONS
-  ! ---------------------------------
-
-
-  DO ja = 1, ntra
-    DO jl = 1, kdlon
-      ztt(jl, ja) = 1.0
-      ztt1(jl, ja) = 1.0
-      ztt2(jl, ja) = 1.0
-    END DO
-  END DO
-
-  DO ja = 1, nua
-    DO jl = 1, kdlon
-      zuu(jl, ja) = 0.
-    END DO
-  END DO
-
-  ! ------------------------------------------------------------------
-
-  ! *         2.      VERTICAL INTEGRATION
-  ! --------------------
-
-
-
-  ! *         2.1     CONTRIBUTION FROM ADJACENT LAYERS
-  ! ---------------------------------
-
-
-  DO jk = 1, kflev
-    ! *         2.1.1   DOWNWARD LAYERS
-    ! ---------------
-
-
-    im12 = 2*(jk-1)
-    ind = (jk-1)*ng1p1 + 1
-    ixd = ind
-    inu = jk*ng1p1 + 1
-    ixu = ind
-
-    DO jl = 1, kdlon
-      zglayd(jl) = 0.
-      zglayu(jl) = 0.
-    END DO
-
-    DO jg = 1, ng1
-      ibs = im12 + jg
-      idd = ixd + jg
-      DO ja = 1, kuaer
-        DO jl = 1, kdlon
-          zuu(jl, ja) = pabcu(jl, ja, ind) - pabcu(jl, ja, idd)
-        END DO
-      END DO
-
-
-      CALL lwtt_lmdar4(pga(1,1,1,jk), pgb(1,1,1,jk), zuu, ztt)
-
-      DO jl = 1, kdlon
-        zwtr = pdbsl(jl, 1, ibs)*ztt(jl, 1)*ztt(jl, 10) + &
-          pdbsl(jl, 2, ibs)*ztt(jl, 2)*ztt(jl, 7)*ztt(jl, 11) + &
-          pdbsl(jl, 3, ibs)*ztt(jl, 4)*ztt(jl, 8)*ztt(jl, 12) + &
-          pdbsl(jl, 4, ibs)*ztt(jl, 5)*ztt(jl, 9)*ztt(jl, 13) + &
-          pdbsl(jl, 5, ibs)*ztt(jl, 3)*ztt(jl, 14) + &
-          pdbsl(jl, 6, ibs)*ztt(jl, 6)*ztt(jl, 15)
-        zglayd(jl) = zglayd(jl) + zwtr*wg1(jg)
-      END DO
-
-      ! *         2.1.2   DOWNWARD LAYERS
-      ! ---------------
-
-
-      imu = ixu + jg
-      DO ja = 1, kuaer
-        DO jl = 1, kdlon
-          zuu(jl, ja) = pabcu(jl, ja, imu) - pabcu(jl, ja, inu)
-        END DO
-      END DO
-
-
-      CALL lwtt_lmdar4(pga(1,1,1,jk), pgb(1,1,1,jk), zuu, ztt)
-
-      DO jl = 1, kdlon
-        zwtr = pdbsl(jl, 1, ibs)*ztt(jl, 1)*ztt(jl, 10) + &
-          pdbsl(jl, 2, ibs)*ztt(jl, 2)*ztt(jl, 7)*ztt(jl, 11) + &
-          pdbsl(jl, 3, ibs)*ztt(jl, 4)*ztt(jl, 8)*ztt(jl, 12) + &
-          pdbsl(jl, 4, ibs)*ztt(jl, 5)*ztt(jl, 9)*ztt(jl, 13) + &
-          pdbsl(jl, 5, ibs)*ztt(jl, 3)*ztt(jl, 14) + &
-          pdbsl(jl, 6, ibs)*ztt(jl, 6)*ztt(jl, 15)
-        zglayu(jl) = zglayu(jl) + zwtr*wg1(jg)
-      END DO
-
-    END DO
-
-    DO jl = 1, kdlon
-      padjd(jl, jk) = zglayd(jl)
-      pcntrb(jl, jk, jk+1) = zglayd(jl)
-      padju(jl, jk+1) = zglayu(jl)
-      pcntrb(jl, jk+1, jk) = zglayu(jl)
-      pcntrb(jl, jk, jk) = 0.0
-    END DO
-
-  END DO
-
-  DO jk = 1, kflev
-    jk2 = 2*jk
-    jk1 = jk2 - 1
-    DO jnu = 1, ninter
-      DO jl = 1, kdlon
-        pdbdt(jl, jnu, jk) = pdbsl(jl, jnu, jk1) + pdbsl(jl, jnu, jk2)
-      END DO
-    END DO
-  END DO
-
-  RETURN
-
-END SUBROUTINE lwvn_lmdar4
-SUBROUTINE lwtt_lmdar4(pga, pgb, puu, ptt)
-  USE dimphy
-  IMPLICIT NONE
-  include "raddimlw.h"
-
-  ! -----------------------------------------------------------------------
-  ! PURPOSE.
-  ! --------
-  ! THIS ROUTINE COMPUTES THE TRANSMISSION FUNCTIONS FOR ALL THE
-  ! ABSORBERS (H2O, UNIFORMLY MIXED GASES, AND O3) IN ALL SIX SPECTRAL
-  ! INTERVALS.
-
-  ! METHOD.
-  ! -------
-
-  ! 1. TRANSMISSION FUNCTION BY H2O AND UNIFORMLY MIXED GASES ARE
-  ! COMPUTED USING PADE APPROXIMANTS AND HORNER'S ALGORITHM.
-  ! 2. TRANSMISSION BY O3 IS EVALUATED WITH MALKMUS'S BAND MODEL.
-  ! 3. TRANSMISSION BY H2O CONTINUUM AND AEROSOLS FOLLOW AN
-  ! A SIMPLE EXPONENTIAL DECREASE WITH ABSORBER AMOUNT.
-
-  ! REFERENCE.
-  ! ----------
-
-  ! SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
-  ! ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
-
-  ! AUTHOR.
-  ! -------
-  ! JEAN-JACQUES MORCRETTE  *ECMWF*
-
-  ! MODIFICATIONS.
-  ! --------------
-  ! ORIGINAL : 88-12-15
-
-  ! -----------------------------------------------------------------------
-  REAL (KIND=8) o1h, o2h
-  PARAMETER (o1h=2230.)
-  PARAMETER (o2h=100.)
-  REAL (KIND=8) rpialf0
-  PARAMETER (rpialf0=2.0)
-
-  ! * ARGUMENTS:
-
-  REAL (KIND=8) puu(kdlon, nua)
-  REAL (KIND=8) ptt(kdlon, ntra)
-  REAL (KIND=8) pga(kdlon, 8, 2)
-  REAL (KIND=8) pgb(kdlon, 8, 2)
-
-  ! * LOCAL VARIABLES:
-
-  REAL (KIND=8) zz, zxd, zxn
-  REAL (KIND=8) zpu, zpu10, zpu11, zpu12, zpu13
-  REAL (KIND=8) zeu, zeu10, zeu11, zeu12, zeu13
-  REAL (KIND=8) zx, zy, zsq1, zsq2, zvxy, zuxy
-  REAL (KIND=8) zaercn, zto1, zto2, zxch4, zych4, zxn2o, zyn2o
-  REAL (KIND=8) zsqn21, zodn21, zsqh42, zodh42
-  REAL (KIND=8) zsqh41, zodh41, zsqn22, zodn22, zttf11, zttf12
-  REAL (KIND=8) zuu11, zuu12, za11, za12
-  INTEGER jl, ja
-
-  ! ------------------------------------------------------------------
-
-  ! *         1.     HORNER'S ALGORITHM FOR H2O AND CO2 TRANSMISSION
-  ! -----------------------------------------------
-
-
-
-  ! cdir collapse
-  DO ja = 1, 8
-    DO jl = 1, kdlon
-      zz = sqrt(puu(jl,ja))
-      ! ZXD(JL,1)=PGB( JL, 1,1) + ZZ(JL, 1)*(PGB( JL, 1,2) + ZZ(JL, 1))
-      ! ZXN(JL,1)=PGA( JL, 1,1) + ZZ(JL, 1)*(PGA( JL, 1,2) )
-      ! PTT(JL,1)=ZXN(JL,1)/ZXD(JL,1)
-      zxd = pgb(jl, ja, 1) + zz*(pgb(jl,ja,2)+zz)
-      zxn = pga(jl, ja, 1) + zz*(pga(jl,ja,2))
-      ptt(jl, ja) = zxn/zxd
-    END DO
-  END DO
-
-  ! ------------------------------------------------------------------
-
-  ! *         2.     CONTINUUM, OZONE AND AEROSOL TRANSMISSION FUNCTIONS
-  ! ---------------------------------------------------
-
-
-  DO jl = 1, kdlon
-    ptt(jl, 9) = ptt(jl, 8)
-
-    ! -  CONTINUUM ABSORPTION: E- AND P-TYPE
-
-    zpu = 0.002*puu(jl, 10)
-    zpu10 = 112.*zpu
-    zpu11 = 6.25*zpu
-    zpu12 = 5.00*zpu
-    zpu13 = 80.0*zpu
-    zeu = puu(jl, 11)
-    zeu10 = 12.*zeu
-    zeu11 = 6.25*zeu
-    zeu12 = 5.00*zeu
-    zeu13 = 80.0*zeu
-
-    ! -  OZONE ABSORPTION
-
-    zx = puu(jl, 12)
-    zy = puu(jl, 13)
-    zuxy = 4.*zx*zx/(rpialf0*zy)
-    zsq1 = sqrt(1.+o1h*zuxy) - 1.
-    zsq2 = sqrt(1.+o2h*zuxy) - 1.
-    zvxy = rpialf0*zy/(2.*zx)
-    zaercn = puu(jl, 17) + zeu12 + zpu12
-    zto1 = exp(-zvxy*zsq1-zaercn)
-    zto2 = exp(-zvxy*zsq2-zaercn)
-
-    ! -- TRACE GASES (CH4, N2O, CFC-11, CFC-12)
-
-    ! * CH4 IN INTERVAL 800-970 + 1110-1250 CM-1
-
-    ! NEXOTIC=1
-    ! IF (NEXOTIC.EQ.1) THEN
-    zxch4 = puu(jl, 19)
-    zych4 = puu(jl, 20)
-    zuxy = 4.*zxch4*zxch4/(0.103*zych4)
-    zsqh41 = sqrt(1.+33.7*zuxy) - 1.
-    zvxy = 0.103*zych4/(2.*zxch4)
-    zodh41 = zvxy*zsqh41
-
-    ! * N2O IN INTERVAL 800-970 + 1110-1250 CM-1
-
-    zxn2o = puu(jl, 21)
-    zyn2o = puu(jl, 22)
-    zuxy = 4.*zxn2o*zxn2o/(0.416*zyn2o)
-    zsqn21 = sqrt(1.+21.3*zuxy) - 1.
-    zvxy = 0.416*zyn2o/(2.*zxn2o)
-    zodn21 = zvxy*zsqn21
-
-    ! * CH4 IN INTERVAL 1250-1450 + 1880-2820 CM-1
-
-    zuxy = 4.*zxch4*zxch4/(0.113*zych4)
-    zsqh42 = sqrt(1.+400.*zuxy) - 1.
-    zvxy = 0.113*zych4/(2.*zxch4)
-    zodh42 = zvxy*zsqh42
-
-    ! * N2O IN INTERVAL 1250-1450 + 1880-2820 CM-1
-
-    zuxy = 4.*zxn2o*zxn2o/(0.197*zyn2o)
-    zsqn22 = sqrt(1.+2000.*zuxy) - 1.
-    zvxy = 0.197*zyn2o/(2.*zxn2o)
-    zodn22 = zvxy*zsqn22
-
-    ! * CFC-11 IN INTERVAL 800-970 + 1110-1250 CM-1
-
-    za11 = 2.*puu(jl, 23)*4.404E+05
-    zttf11 = 1. - za11*0.003225
-
-    ! * CFC-12 IN INTERVAL 800-970 + 1110-1250 CM-1
-
-    za12 = 2.*puu(jl, 24)*6.7435E+05
-    zttf12 = 1. - za12*0.003225
-
-    zuu11 = -puu(jl, 15) - zeu10 - zpu10
-    zuu12 = -puu(jl, 16) - zeu11 - zpu11 - zodh41 - zodn21
-    ptt(jl, 10) = exp(-puu(jl,14))
-    ptt(jl, 11) = exp(zuu11)
-    ptt(jl, 12) = exp(zuu12)*zttf11*zttf12
-    ptt(jl, 13) = 0.7554*zto1 + 0.2446*zto2
-    ptt(jl, 14) = ptt(jl, 10)*exp(-zeu13-zpu13)
-    ptt(jl, 15) = exp(-puu(jl,14)-zodh42-zodn22)
-  END DO
-
-  RETURN
-END SUBROUTINE lwtt_lmdar4
-SUBROUTINE lwttm_lmdar4(pga, pgb, puu1, puu2, ptt)
-  USE dimphy
-  IMPLICIT NONE
-  include "raddimlw.h"
-
-  ! ------------------------------------------------------------------
-  ! PURPOSE.
-  ! --------
-  ! THIS ROUTINE COMPUTES THE TRANSMISSION FUNCTIONS FOR ALL THE
-  ! ABSORBERS (H2O, UNIFORMLY MIXED GASES, AND O3) IN ALL SIX SPECTRAL
-  ! INTERVALS.
-
-  ! METHOD.
-  ! -------
-
-  ! 1. TRANSMISSION FUNCTION BY H2O AND UNIFORMLY MIXED GASES ARE
-  ! COMPUTED USING PADE APPROXIMANTS AND HORNER'S ALGORITHM.
-  ! 2. TRANSMISSION BY O3 IS EVALUATED WITH MALKMUS'S BAND MODEL.
-  ! 3. TRANSMISSION BY H2O CONTINUUM AND AEROSOLS FOLLOW AN
-  ! A SIMPLE EXPONENTIAL DECREASE WITH ABSORBER AMOUNT.
-
-  ! REFERENCE.
-  ! ----------
-
-  ! SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
-  ! ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
-
-  ! AUTHOR.
-  ! -------
-  ! JEAN-JACQUES MORCRETTE  *ECMWF*
-
-  ! MODIFICATIONS.
-  ! --------------
-  ! ORIGINAL : 88-12-15
-
-  ! -----------------------------------------------------------------------
-  REAL (KIND=8) o1h, o2h
-  PARAMETER (o1h=2230.)
-  PARAMETER (o2h=100.)
-  REAL (KIND=8) rpialf0
-  PARAMETER (rpialf0=2.0)
-
-  ! * ARGUMENTS:
-
-  REAL (KIND=8) pga(kdlon, 8, 2) ! PADE APPROXIMANTS
-  REAL (KIND=8) pgb(kdlon, 8, 2) ! PADE APPROXIMANTS
-  REAL (KIND=8) puu1(kdlon, nua) ! ABSORBER AMOUNTS FROM TOP TO LEVEL 1
-  REAL (KIND=8) puu2(kdlon, nua) ! ABSORBER AMOUNTS FROM TOP TO LEVEL 2
-  REAL (KIND=8) ptt(kdlon, ntra) ! TRANSMISSION FUNCTIONS
-
-  ! * LOCAL VARIABLES:
-
-  INTEGER ja, jl
-  REAL (KIND=8) zz, zxd, zxn
-  REAL (KIND=8) zpu, zpu10, zpu11, zpu12, zpu13
-  REAL (KIND=8) zeu, zeu10, zeu11, zeu12, zeu13
-  REAL (KIND=8) zx, zy, zuxy, zsq1, zsq2, zvxy, zaercn, zto1, zto2
-  REAL (KIND=8) zxch4, zych4, zsqh41, zodh41
-  REAL (KIND=8) zxn2o, zyn2o, zsqn21, zodn21, zsqh42, zodh42
-  REAL (KIND=8) zsqn22, zodn22, za11, zttf11, za12, zttf12
-  REAL (KIND=8) zuu11, zuu12
-
-  ! ------------------------------------------------------------------
-
-  ! *         1.     HORNER'S ALGORITHM FOR H2O AND CO2 TRANSMISSION
-  ! -----------------------------------------------
-
-
-
-
-  ! CDIR ON_ADB(PUU1)
-  ! CDIR ON_ADB(PUU2)
-  ! CDIR COLLAPSE
-  DO ja = 1, 8
-    DO jl = 1, kdlon
-      zz = sqrt(puu1(jl,ja)-puu2(jl,ja))
-      zxd = pgb(jl, ja, 1) + zz*(pgb(jl,ja,2)+zz)
-      zxn = pga(jl, ja, 1) + zz*(pga(jl,ja,2))
-      ptt(jl, ja) = zxn/zxd
-    END DO
-  END DO
-
-  ! ------------------------------------------------------------------
-
-  ! *         2.     CONTINUUM, OZONE AND AEROSOL TRANSMISSION FUNCTIONS
-  ! ---------------------------------------------------
-
-
-  DO jl = 1, kdlon
-    ptt(jl, 9) = ptt(jl, 8)
-
-    ! -  CONTINUUM ABSORPTION: E- AND P-TYPE
-
-    zpu = 0.002*(puu1(jl,10)-puu2(jl,10))
-    zpu10 = 112.*zpu
-    zpu11 = 6.25*zpu
-    zpu12 = 5.00*zpu
-    zpu13 = 80.0*zpu
-    zeu = (puu1(jl,11)-puu2(jl,11))
-    zeu10 = 12.*zeu
-    zeu11 = 6.25*zeu
-    zeu12 = 5.00*zeu
-    zeu13 = 80.0*zeu
-
-    ! -  OZONE ABSORPTION
-
-    zx = (puu1(jl,12)-puu2(jl,12))
-    zy = (puu1(jl,13)-puu2(jl,13))
-    zuxy = 4.*zx*zx/(rpialf0*zy)
-    zsq1 = sqrt(1.+o1h*zuxy) - 1.
-    zsq2 = sqrt(1.+o2h*zuxy) - 1.
-    zvxy = rpialf0*zy/(2.*zx)
-    zaercn = (puu1(jl,17)-puu2(jl,17)) + zeu12 + zpu12
-    zto1 = exp(-zvxy*zsq1-zaercn)
-    zto2 = exp(-zvxy*zsq2-zaercn)
-
-    ! -- TRACE GASES (CH4, N2O, CFC-11, CFC-12)
-
-    ! * CH4 IN INTERVAL 800-970 + 1110-1250 CM-1
-
-    zxch4 = (puu1(jl,19)-puu2(jl,19))
-    zych4 = (puu1(jl,20)-puu2(jl,20))
-    zuxy = 4.*zxch4*zxch4/(0.103*zych4)
-    zsqh41 = sqrt(1.+33.7*zuxy) - 1.
-    zvxy = 0.103*zych4/(2.*zxch4)
-    zodh41 = zvxy*zsqh41
-
-    ! * N2O IN INTERVAL 800-970 + 1110-1250 CM-1
-
-    zxn2o = (puu1(jl,21)-puu2(jl,21))
-    zyn2o = (puu1(jl,22)-puu2(jl,22))
-    zuxy = 4.*zxn2o*zxn2o/(0.416*zyn2o)
-    zsqn21 = sqrt(1.+21.3*zuxy) - 1.
-    zvxy = 0.416*zyn2o/(2.*zxn2o)
-    zodn21 = zvxy*zsqn21
-
-    ! * CH4 IN INTERVAL 1250-1450 + 1880-2820 CM-1
-
-    zuxy = 4.*zxch4*zxch4/(0.113*zych4)
-    zsqh42 = sqrt(1.+400.*zuxy) - 1.
-    zvxy = 0.113*zych4/(2.*zxch4)
-    zodh42 = zvxy*zsqh42
-
-    ! * N2O IN INTERVAL 1250-1450 + 1880-2820 CM-1
-
-    zuxy = 4.*zxn2o*zxn2o/(0.197*zyn2o)
-    zsqn22 = sqrt(1.+2000.*zuxy) - 1.
-    zvxy = 0.197*zyn2o/(2.*zxn2o)
-    zodn22 = zvxy*zsqn22
-
-    ! * CFC-11 IN INTERVAL 800-970 + 1110-1250 CM-1
-
-    za11 = (puu1(jl,23)-puu2(jl,23))*4.404E+05
-    zttf11 = 1. - za11*0.003225
-
-    ! * CFC-12 IN INTERVAL 800-970 + 1110-1250 CM-1
-
-    za12 = (puu1(jl,24)-puu2(jl,24))*6.7435E+05
-    zttf12 = 1. - za12*0.003225
-
-    zuu11 = -(puu1(jl,15)-puu2(jl,15)) - zeu10 - zpu10
-    zuu12 = -(puu1(jl,16)-puu2(jl,16)) - zeu11 - zpu11 - zodh41 - zodn21
-    ptt(jl, 10) = exp(-(puu1(jl,14)-puu2(jl,14)))
-    ptt(jl, 11) = exp(zuu11)
-    ptt(jl, 12) = exp(zuu12)*zttf11*zttf12
-    ptt(jl, 13) = 0.7554*zto1 + 0.2446*zto2
-    ptt(jl, 14) = ptt(jl, 10)*exp(-zeu13-zpu13)
-    ptt(jl, 15) = exp(-(puu1(jl,14)-puu2(jl,14))-zodh42-zodn22)
-  END DO
-
-  RETURN
-END SUBROUTINE lwttm_lmdar4
Index: /LMDZ6/trunk/libf/phylmd/radiation_AR4.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/radiation_AR4.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/radiation_AR4.f90	(revision 5268)
@@ -0,0 +1,5713 @@
+! IM ctes ds clesphys.h   SUBROUTINE SW(PSCT, RCO2, PRMU0, PFRAC,
+SUBROUTINE sw_lmdar4(psct, prmu0, pfrac, ppmb, pdp, ppsol, palbd, palbp, &
+    ptave, pwv, pqs, pozon, paer, pcldsw, ptau, pomega, pcg, pheat, pheat0, &
+    palbpla, ptopsw, psolsw, ptopsw0, psolsw0, zfsup, zfsdn, zfsup0, zfsdn0, &
+    tauae, pizae, cgae, ptaua, pomegaa, ptopswad, psolswad, ptopswai, &
+    psolswai, ok_ade, ok_aie)
+  USE dimphy
+  USE print_control_mod, ONLY: lunout
+  IMPLICIT NONE
+
+  include "YOMCST.h"
+
+  ! ------------------------------------------------------------------
+
+  ! PURPOSE.
+  ! --------
+
+  ! THIS ROUTINE COMPUTES THE SHORTWAVE RADIATION FLUXES IN TWO
+  ! SPECTRAL INTERVALS FOLLOWING FOUQUART AND BONNEL (1980).
+
+  ! METHOD.
+  ! -------
+
+  ! 1. COMPUTES ABSORBER AMOUNTS                 (SWU)
+  ! 2. COMPUTES FLUXES IN 1ST SPECTRAL INTERVAL  (SW1S)
+  ! 3. COMPUTES FLUXES IN 2ND SPECTRAL INTERVAL  (SW2S)
+
+  ! REFERENCE.
+  ! ----------
+
+  ! SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT
+  ! DOCUMENTATION, AND FOUQUART AND BONNEL (1980)
+
+  ! AUTHOR.
+  ! -------
+  ! JEAN-JACQUES MORCRETTE  *ECMWF*
+
+  ! MODIFICATIONS.
+  ! --------------
+  ! ORIGINAL : 89-07-14
+  ! 95-01-01   J.-J. MORCRETTE  Direct/Diffuse Albedo
+  ! 03-11-27   J. QUAAS Introduce aerosol forcings (based on BOUCHER)
+  ! ------------------------------------------------------------------
+
+  ! * ARGUMENTS:
+
+  REAL (KIND=8) psct ! constante solaire (valeur conseillee: 1370)
+  ! IM ctes ds clesphys.h   REAL(KIND=8) RCO2  ! concentration CO2 (IPCC:
+  ! 353.E-06*44.011/28.97)
+  include "clesphys.h"
+
+  REAL (KIND=8) ppsol(kdlon) ! SURFACE PRESSURE (PA)
+  REAL (KIND=8) pdp(kdlon, kflev) ! LAYER THICKNESS (PA)
+  REAL (KIND=8) ppmb(kdlon, kflev+1) ! HALF-LEVEL PRESSURE (MB)
+
+  REAL (KIND=8) prmu0(kdlon) ! COSINE OF ZENITHAL ANGLE
+  REAL (KIND=8) pfrac(kdlon) ! fraction de la journee
+
+  REAL (KIND=8) ptave(kdlon, kflev) ! LAYER TEMPERATURE (K)
+  REAL (KIND=8) pwv(kdlon, kflev) ! SPECIFIC HUMIDITY (KG/KG)
+  REAL (KIND=8) pqs(kdlon, kflev) ! SATURATED WATER VAPOUR (KG/KG)
+  REAL (KIND=8) pozon(kdlon, kflev) ! OZONE CONCENTRATION (KG/KG)
+  REAL (KIND=8) paer(kdlon, kflev, 5) ! AEROSOLS' OPTICAL THICKNESS
+
+  REAL (KIND=8) palbd(kdlon, 2) ! albedo du sol (lumiere diffuse)
+  REAL (KIND=8) palbp(kdlon, 2) ! albedo du sol (lumiere parallele)
+
+  REAL (KIND=8) pcldsw(kdlon, kflev) ! CLOUD FRACTION
+  REAL (KIND=8) ptau(kdlon, 2, kflev) ! CLOUD OPTICAL THICKNESS
+  REAL (KIND=8) pcg(kdlon, 2, kflev) ! ASYMETRY FACTOR
+  REAL (KIND=8) pomega(kdlon, 2, kflev) ! SINGLE SCATTERING ALBEDO
+
+  REAL (KIND=8) pheat(kdlon, kflev) ! SHORTWAVE HEATING (K/DAY)
+  REAL (KIND=8) pheat0(kdlon, kflev) ! SHORTWAVE HEATING (K/DAY) clear-sky
+  REAL (KIND=8) palbpla(kdlon) ! PLANETARY ALBEDO
+  REAL (KIND=8) ptopsw(kdlon) ! SHORTWAVE FLUX AT T.O.A.
+  REAL (KIND=8) psolsw(kdlon) ! SHORTWAVE FLUX AT SURFACE
+  REAL (KIND=8) ptopsw0(kdlon) ! SHORTWAVE FLUX AT T.O.A. (CLEAR-SKY)
+  REAL (KIND=8) psolsw0(kdlon) ! SHORTWAVE FLUX AT SURFACE (CLEAR-SKY)
+
+  ! * LOCAL VARIABLES:
+
+  REAL, PARAMETER :: dobson_u = 2.1415E-05 ! Dobson unit, in kg m-2
+
+  REAL (KIND=8) zoz(kdlon, kflev)
+  ! column-density of ozone in layer, in kilo-Dobsons
+
+  REAL (KIND=8) zaki(kdlon, 2)
+  REAL (KIND=8) zcld(kdlon, kflev)
+  REAL (KIND=8) zclear(kdlon)
+  REAL (KIND=8) zdsig(kdlon, kflev)
+  REAL (KIND=8) zfact(kdlon)
+  REAL (KIND=8) zfd(kdlon, kflev+1)
+  REAL (KIND=8) zfdown(kdlon, kflev+1)
+  REAL (KIND=8) zfu(kdlon, kflev+1)
+  REAL (KIND=8) zfup(kdlon, kflev+1)
+  REAL (KIND=8) zrmu(kdlon)
+  REAL (KIND=8) zsec(kdlon)
+  REAL (KIND=8) zud(kdlon, 5, kflev+1)
+  REAL (KIND=8) zcldsw0(kdlon, kflev)
+
+  REAL (KIND=8) zfsup(kdlon, kflev+1)
+  REAL (KIND=8) zfsdn(kdlon, kflev+1)
+  REAL (KIND=8) zfsup0(kdlon, kflev+1)
+  REAL (KIND=8) zfsdn0(kdlon, kflev+1)
+
+  INTEGER inu, jl, jk, i, k, kpl1
+
+  INTEGER swpas ! Every swpas steps, sw is calculated
+  PARAMETER (swpas=1)
+
+  INTEGER itapsw
+  LOGICAL appel1er
+  DATA itapsw/0/
+  DATA appel1er/.TRUE./
+  SAVE itapsw, appel1er
+  !$OMP THREADPRIVATE(appel1er)
+  !$OMP THREADPRIVATE(itapsw)
+  ! jq-Introduced for aerosol forcings
+  REAL (KIND=8) flag_aer
+  LOGICAL ok_ade, ok_aie ! use aerosol forcings or not?
+  REAL (KIND=8) tauae(kdlon, kflev, 2) ! aerosol optical properties
+  REAL (KIND=8) pizae(kdlon, kflev, 2) ! (see aeropt.F)
+  REAL (KIND=8) cgae(kdlon, kflev, 2) ! -"-
+  REAL (KIND=8) ptaua(kdlon, 2, kflev) ! CLOUD OPTICAL THICKNESS (pre-industrial value)
+  REAL (KIND=8) pomegaa(kdlon, 2, kflev) ! SINGLE SCATTERING ALBEDO
+  REAL (KIND=8) ptopswad(kdlon) ! SHORTWAVE FLUX AT T.O.A.(+AEROSOL DIR)
+  REAL (KIND=8) psolswad(kdlon) ! SHORTWAVE FLUX AT SURFACE(+AEROSOL DIR)
+  REAL (KIND=8) ptopswai(kdlon) ! SHORTWAVE FLUX AT T.O.A.(+AEROSOL IND)
+  REAL (KIND=8) psolswai(kdlon) ! SHORTWAVE FLUX AT SURFACE(+AEROSOL IND)
+  ! jq - Fluxes including aerosol effects
+  REAL (KIND=8), ALLOCATABLE, SAVE :: zfsupad(:, :)
+  !$OMP THREADPRIVATE(ZFSUPAD)
+  REAL (KIND=8), ALLOCATABLE, SAVE :: zfsdnad(:, :)
+  !$OMP THREADPRIVATE(ZFSDNAD)
+  REAL (KIND=8), ALLOCATABLE, SAVE :: zfsupai(:, :)
+  !$OMP THREADPRIVATE(ZFSUPAI)
+  REAL (KIND=8), ALLOCATABLE, SAVE :: zfsdnai(:, :)
+  !$OMP THREADPRIVATE(ZFSDNAI)
+  LOGICAL initialized
+  ! ym      SAVE ZFSUPAD, ZFSDNAD, ZFSUPAI, ZFSDNAI ! aerosol fluxes
+  ! rv
+  SAVE flag_aer
+  !$OMP THREADPRIVATE(flag_aer)
+  DATA initialized/.FALSE./
+  SAVE initialized
+  !$OMP THREADPRIVATE(initialized)
+  ! jq-end
+  REAL tmp_
+
+  IF (.NOT. initialized) THEN
+    flag_aer = 0.
+    initialized = .TRUE.
+    ALLOCATE (zfsupad(kdlon,kflev+1))
+    ALLOCATE (zfsdnad(kdlon,kflev+1))
+    ALLOCATE (zfsupai(kdlon,kflev+1))
+    ALLOCATE (zfsdnai(kdlon,kflev+1))
+
+    zfsupad(:, :) = 0.
+    zfsdnad(:, :) = 0.
+    zfsupai(:, :) = 0.
+    zfsdnai(:, :) = 0.
+  END IF
+
+  IF (appel1er) THEN
+    WRITE (lunout, *) 'SW calling frequency : ', swpas
+    WRITE (lunout, *) '   In general, it should be 1'
+    appel1er = .FALSE.
+  END IF
+  ! ------------------------------------------------------------------
+  IF (mod(itapsw,swpas)==0) THEN
+
+    tmp_ = 1./(dobson_u*1E3*rg)
+    ! cdir collapse
+    DO jk = 1, kflev
+      DO jl = 1, kdlon
+        zcldsw0(jl, jk) = 0.0
+        zoz(jl, jk) = pozon(jl, jk)*tmp_*pdp(jl, jk)
+      END DO
+    END DO
+
+
+    ! clear-sky:
+    ! IM ctes ds clesphys.h  CALL SWU(PSCT,RCO2,ZCLDSW0,PPMB,PPSOL,
+    CALL swu_lmdar4(psct, zcldsw0, ppmb, ppsol, prmu0, pfrac, ptave, pwv, &
+      zaki, zcld, zclear, zdsig, zfact, zrmu, zsec, zud)
+    inu = 1
+    CALL sw1s_lmdar4(inu, paer, flag_aer, tauae, pizae, cgae, palbd, palbp, &
+      pcg, zcld, zclear, zcldsw0, zdsig, pomega, zoz, zrmu, zsec, ptau, zud, &
+      zfd, zfu)
+    inu = 2
+    CALL sw2s_lmdar4(inu, paer, flag_aer, tauae, pizae, cgae, zaki, palbd, &
+      palbp, pcg, zcld, zclear, zcldsw0, zdsig, pomega, zoz, zrmu, zsec, &
+      ptau, zud, pwv, pqs, zfdown, zfup)
+    DO jk = 1, kflev + 1
+      DO jl = 1, kdlon
+        zfsup0(jl, jk) = (zfup(jl,jk)+zfu(jl,jk))*zfact(jl)
+        zfsdn0(jl, jk) = (zfdown(jl,jk)+zfd(jl,jk))*zfact(jl)
+      END DO
+    END DO
+
+    flag_aer = 0.0
+    CALL swu_lmdar4(psct, pcldsw, ppmb, ppsol, prmu0, pfrac, ptave, pwv, &
+      zaki, zcld, zclear, zdsig, zfact, zrmu, zsec, zud)
+    inu = 1
+    CALL sw1s_lmdar4(inu, paer, flag_aer, tauae, pizae, cgae, palbd, palbp, &
+      pcg, zcld, zclear, pcldsw, zdsig, pomega, zoz, zrmu, zsec, ptau, zud, &
+      zfd, zfu)
+    inu = 2
+    CALL sw2s_lmdar4(inu, paer, flag_aer, tauae, pizae, cgae, zaki, palbd, &
+      palbp, pcg, zcld, zclear, pcldsw, zdsig, pomega, zoz, zrmu, zsec, ptau, &
+      zud, pwv, pqs, zfdown, zfup)
+
+    ! cloudy-sky:
+
+    DO jk = 1, kflev + 1
+      DO jl = 1, kdlon
+        zfsup(jl, jk) = (zfup(jl,jk)+zfu(jl,jk))*zfact(jl)
+        zfsdn(jl, jk) = (zfdown(jl,jk)+zfd(jl,jk))*zfact(jl)
+      END DO
+    END DO
+
+
+    IF (ok_ade) THEN
+
+      ! cloudy-sky + aerosol dir OB
+      flag_aer = 1.0
+      CALL swu_lmdar4(psct, pcldsw, ppmb, ppsol, prmu0, pfrac, ptave, pwv, &
+        zaki, zcld, zclear, zdsig, zfact, zrmu, zsec, zud)
+      inu = 1
+      CALL sw1s_lmdar4(inu, paer, flag_aer, tauae, pizae, cgae, palbd, palbp, &
+        pcg, zcld, zclear, pcldsw, zdsig, pomega, zoz, zrmu, zsec, ptau, zud, &
+        zfd, zfu)
+      inu = 2
+      CALL sw2s_lmdar4(inu, paer, flag_aer, tauae, pizae, cgae, zaki, palbd, &
+        palbp, pcg, zcld, zclear, pcldsw, zdsig, pomega, zoz, zrmu, zsec, &
+        ptau, zud, pwv, pqs, zfdown, zfup)
+      DO jk = 1, kflev + 1
+        DO jl = 1, kdlon
+          zfsupad(jl, jk) = zfsup(jl, jk)
+          zfsdnad(jl, jk) = zfsdn(jl, jk)
+          zfsup(jl, jk) = (zfup(jl,jk)+zfu(jl,jk))*zfact(jl)
+          zfsdn(jl, jk) = (zfdown(jl,jk)+zfd(jl,jk))*zfact(jl)
+        END DO
+      END DO
+
+    END IF ! ok_ade
+
+    IF (ok_aie) THEN
+
+      ! jq   cloudy-sky + aerosol direct + aerosol indirect
+      flag_aer = 1.0
+      CALL swu_lmdar4(psct, pcldsw, ppmb, ppsol, prmu0, pfrac, ptave, pwv, &
+        zaki, zcld, zclear, zdsig, zfact, zrmu, zsec, zud)
+      inu = 1
+      CALL sw1s_lmdar4(inu, paer, flag_aer, tauae, pizae, cgae, palbd, palbp, &
+        pcg, zcld, zclear, pcldsw, zdsig, pomegaa, zoz, zrmu, zsec, ptaua, &
+        zud, zfd, zfu)
+      inu = 2
+      CALL sw2s_lmdar4(inu, paer, flag_aer, tauae, pizae, cgae, zaki, palbd, &
+        palbp, pcg, zcld, zclear, pcldsw, zdsig, pomegaa, zoz, zrmu, zsec, &
+        ptaua, zud, pwv, pqs, zfdown, zfup)
+      DO jk = 1, kflev + 1
+        DO jl = 1, kdlon
+          zfsupai(jl, jk) = zfsup(jl, jk)
+          zfsdnai(jl, jk) = zfsdn(jl, jk)
+          zfsup(jl, jk) = (zfup(jl,jk)+zfu(jl,jk))*zfact(jl)
+          zfsdn(jl, jk) = (zfdown(jl,jk)+zfd(jl,jk))*zfact(jl)
+        END DO
+      END DO
+    END IF ! ok_aie
+    ! jq -end
+
+    itapsw = 0
+  END IF
+  itapsw = itapsw + 1
+
+  DO k = 1, kflev
+    kpl1 = k + 1
+    DO i = 1, kdlon
+      pheat(i, k) = -(zfsup(i,kpl1)-zfsup(i,k)) - (zfsdn(i,k)-zfsdn(i,kpl1))
+      pheat(i, k) = pheat(i, k)*rday*rg/rcpd/pdp(i, k)
+      pheat0(i, k) = -(zfsup0(i,kpl1)-zfsup0(i,k)) - &
+        (zfsdn0(i,k)-zfsdn0(i,kpl1))
+      pheat0(i, k) = pheat0(i, k)*rday*rg/rcpd/pdp(i, k)
+    END DO
+  END DO
+  DO i = 1, kdlon
+    palbpla(i) = zfsup(i, kflev+1)/(zfsdn(i,kflev+1)+1.0E-20)
+
+    psolsw(i) = zfsdn(i, 1) - zfsup(i, 1)
+    ptopsw(i) = zfsdn(i, kflev+1) - zfsup(i, kflev+1)
+
+    psolsw0(i) = zfsdn0(i, 1) - zfsup0(i, 1)
+    ptopsw0(i) = zfsdn0(i, kflev+1) - zfsup0(i, kflev+1)
+    ! -OB
+    psolswad(i) = zfsdnad(i, 1) - zfsupad(i, 1)
+    ptopswad(i) = zfsdnad(i, kflev+1) - zfsupad(i, kflev+1)
+
+    psolswai(i) = zfsdnai(i, 1) - zfsupai(i, 1)
+    ptopswai(i) = zfsdnai(i, kflev+1) - zfsupai(i, kflev+1)
+    ! -fin
+  END DO
+
+  RETURN
+END SUBROUTINE sw_lmdar4
+
+! IM ctes ds clesphys.h   SUBROUTINE SWU
+! (PSCT,RCO2,PCLDSW,PPMB,PPSOL,PRMU0,PFRAC,
+SUBROUTINE swu_lmdar4(psct, pcldsw, ppmb, ppsol, prmu0, pfrac, ptave, pwv, &
+    paki, pcld, pclear, pdsig, pfact, prmu, psec, pud)
+  USE dimphy
+  USE radiation_ar4_param, ONLY: zpdh2o, zpdumg, zprh2o, zprumg, rtdh2o, &
+    rtdumg, rth2o, rtumg
+  IMPLICIT NONE
+  include "radepsi.h"
+  include "radopt.h"
+  include "YOMCST.h"
+
+  ! * ARGUMENTS:
+
+  REAL (KIND=8) psct
+  ! IM ctes ds clesphys.h   REAL(KIND=8) RCO2
+  include "clesphys.h"
+  REAL (KIND=8) pcldsw(kdlon, kflev)
+  REAL (KIND=8) ppmb(kdlon, kflev+1)
+  REAL (KIND=8) ppsol(kdlon)
+  REAL (KIND=8) prmu0(kdlon)
+  REAL (KIND=8) pfrac(kdlon)
+  REAL (KIND=8) ptave(kdlon, kflev)
+  REAL (KIND=8) pwv(kdlon, kflev)
+
+  REAL (KIND=8) paki(kdlon, 2)
+  REAL (KIND=8) pcld(kdlon, kflev)
+  REAL (KIND=8) pclear(kdlon)
+  REAL (KIND=8) pdsig(kdlon, kflev)
+  REAL (KIND=8) pfact(kdlon)
+  REAL (KIND=8) prmu(kdlon)
+  REAL (KIND=8) psec(kdlon)
+  REAL (KIND=8) pud(kdlon, 5, kflev+1)
+
+  ! * LOCAL VARIABLES:
+
+  INTEGER iind(2)
+  REAL (KIND=8) zc1j(kdlon, kflev+1)
+  REAL (KIND=8) zclear(kdlon)
+  REAL (KIND=8) zcloud(kdlon)
+  REAL (KIND=8) zn175(kdlon)
+  REAL (KIND=8) zn190(kdlon)
+  REAL (KIND=8) zo175(kdlon)
+  REAL (KIND=8) zo190(kdlon)
+  REAL (KIND=8) zsign(kdlon)
+  REAL (KIND=8) zr(kdlon, 2)
+  REAL (KIND=8) zsigo(kdlon)
+  REAL (KIND=8) zud(kdlon, 2)
+  REAL (KIND=8) zrth, zrtu, zwh2o, zdsco2, zdsh2o, zfppw
+  INTEGER jl, jk, jkp1, jkl, jklp1, ja
+
+  ! ------------------------------------------------------------------
+
+  ! *         1.     COMPUTES AMOUNTS OF ABSORBERS
+  ! -----------------------------
+
+
+  iind(1) = 1
+  iind(2) = 2
+
+  ! *         1.1    INITIALIZES QUANTITIES
+  ! ----------------------
+
+
+  DO jl = 1, kdlon
+    pud(jl, 1, kflev+1) = 0.
+    pud(jl, 2, kflev+1) = 0.
+    pud(jl, 3, kflev+1) = 0.
+    pud(jl, 4, kflev+1) = 0.
+    pud(jl, 5, kflev+1) = 0.
+    pfact(jl) = prmu0(jl)*pfrac(jl)*psct
+    prmu(jl) = sqrt(1224.*prmu0(jl)*prmu0(jl)+1.)/35.
+    psec(jl) = 1./prmu(jl)
+    zc1j(jl, kflev+1) = 0.
+  END DO
+
+  ! *          1.3    AMOUNTS OF ABSORBERS
+  ! --------------------
+
+
+  DO jl = 1, kdlon
+    zud(jl, 1) = 0.
+    zud(jl, 2) = 0.
+    zo175(jl) = ppsol(jl)**(zpdumg+1.)
+    zo190(jl) = ppsol(jl)**(zpdh2o+1.)
+    zsigo(jl) = ppsol(jl)
+    zclear(jl) = 1.
+    zcloud(jl) = 0.
+  END DO
+
+  DO jk = 1, kflev
+    jkp1 = jk + 1
+    jkl = kflev + 1 - jk
+    jklp1 = jkl + 1
+    DO jl = 1, kdlon
+      zrth = (rth2o/ptave(jl,jk))**rtdh2o
+      zrtu = (rtumg/ptave(jl,jk))**rtdumg
+      zwh2o = max(pwv(jl,jk), zepscq)
+      zsign(jl) = 100.*ppmb(jl, jkp1)
+      pdsig(jl, jk) = (zsigo(jl)-zsign(jl))/ppsol(jl)
+      zn175(jl) = zsign(jl)**(zpdumg+1.)
+      zn190(jl) = zsign(jl)**(zpdh2o+1.)
+      zdsco2 = zo175(jl) - zn175(jl)
+      zdsh2o = zo190(jl) - zn190(jl)
+      pud(jl, 1, jk) = 1./(10.*rg*(zpdh2o+1.))/(zprh2o**zpdh2o)*zdsh2o*zwh2o* &
+        zrth
+      pud(jl, 2, jk) = 1./(10.*rg*(zpdumg+1.))/(zprumg**zpdumg)*zdsco2*rco2* &
+        zrtu
+      zfppw = 1.6078*zwh2o/(1.+0.608*zwh2o)
+      pud(jl, 4, jk) = pud(jl, 1, jk)*zfppw
+      pud(jl, 5, jk) = pud(jl, 1, jk)*(1.-zfppw)
+      zud(jl, 1) = zud(jl, 1) + pud(jl, 1, jk)
+      zud(jl, 2) = zud(jl, 2) + pud(jl, 2, jk)
+      zsigo(jl) = zsign(jl)
+      zo175(jl) = zn175(jl)
+      zo190(jl) = zn190(jl)
+
+      IF (novlp==1) THEN
+        zclear(jl) = zclear(jl)*(1.-max(pcldsw(jl,jkl),zcloud(jl)))/(1.-min( &
+          zcloud(jl),1.-zepsec))
+        zc1j(jl, jkl) = 1.0 - zclear(jl)
+        zcloud(jl) = pcldsw(jl, jkl)
+      ELSE IF (novlp==2) THEN
+        zcloud(jl) = max(pcldsw(jl,jkl), zcloud(jl))
+        zc1j(jl, jkl) = zcloud(jl)
+      ELSE IF (novlp==3) THEN
+        zclear(jl) = zclear(jl)*(1.-pcldsw(jl,jkl))
+        zcloud(jl) = 1.0 - zclear(jl)
+        zc1j(jl, jkl) = zcloud(jl)
+      END IF
+    END DO
+  END DO
+  DO jl = 1, kdlon
+    pclear(jl) = 1. - zc1j(jl, 1)
+  END DO
+  DO jk = 1, kflev
+    DO jl = 1, kdlon
+      IF (pclear(jl)<1.) THEN
+        pcld(jl, jk) = pcldsw(jl, jk)/(1.-pclear(jl))
+      ELSE
+        pcld(jl, jk) = 0.
+      END IF
+    END DO
+  END DO
+
+  ! *         1.4    COMPUTES CLEAR-SKY GREY ABSORPTION COEFFICIENTS
+  ! -----------------------------------------------
+
+
+  DO ja = 1, 2
+    DO jl = 1, kdlon
+      zud(jl, ja) = zud(jl, ja)*psec(jl)
+    END DO
+  END DO
+
+  CALL swtt1_lmdar4(2, 2, iind, zud, zr)
+
+  DO ja = 1, 2
+    DO jl = 1, kdlon
+      paki(jl, ja) = -log(zr(jl,ja))/zud(jl, ja)
+    END DO
+  END DO
+
+
+  ! ------------------------------------------------------------------
+
+  RETURN
+END SUBROUTINE swu_lmdar4
+SUBROUTINE sw1s_lmdar4(knu, paer, flag_aer, tauae, pizae, cgae, palbd, palbp, &
+    pcg, pcld, pclear, pcldsw, pdsig, pomega, poz, prmu, psec, ptau, pud, &
+    pfd, pfu)
+  USE dimphy
+  USE radiation_ar4_param, ONLY: rsun, rray
+  USE infotrac_phy, ONLY: type_trac
+  USE lmdz_reprobus_wrappers, ONLY: rsuntime, ok_suntime
+  USE print_control_mod, ONLY: lunout
+  USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_REPROBUS
+
+  IMPLICIT NONE
+
+  ! ------------------------------------------------------------------
+  ! PURPOSE.
+  ! --------
+
+  ! THIS ROUTINE COMPUTES THE SHORTWAVE RADIATION FLUXES IN TWO
+  ! SPECTRAL INTERVALS FOLLOWING FOUQUART AND BONNEL (1980).
+
+  ! METHOD.
+  ! -------
+
+  ! 1. COMPUTES UPWARD AND DOWNWARD FLUXES CORRESPONDING TO
+  ! CONTINUUM SCATTERING
+  ! 2. MULTIPLY BY OZONE TRANSMISSION FUNCTION
+
+  ! REFERENCE.
+  ! ----------
+
+  ! SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT
+  ! DOCUMENTATION, AND FOUQUART AND BONNEL (1980)
+
+  ! AUTHOR.
+  ! -------
+  ! JEAN-JACQUES MORCRETTE  *ECMWF*
+
+  ! MODIFICATIONS.
+  ! --------------
+  ! ORIGINAL : 89-07-14
+  ! 94-11-15   J.-J. MORCRETTE    DIRECT/DIFFUSE ALBEDO
+  ! ------------------------------------------------------------------
+
+  ! * ARGUMENTS:
+
+  INTEGER knu
+  ! -OB
+  REAL (KIND=8) flag_aer
+  REAL (KIND=8) tauae(kdlon, kflev, 2)
+  REAL (KIND=8) pizae(kdlon, kflev, 2)
+  REAL (KIND=8) cgae(kdlon, kflev, 2)
+  REAL (KIND=8) paer(kdlon, kflev, 5)
+  REAL (KIND=8) palbd(kdlon, 2)
+  REAL (KIND=8) palbp(kdlon, 2)
+  REAL (KIND=8) pcg(kdlon, 2, kflev)
+  REAL (KIND=8) pcld(kdlon, kflev)
+  REAL (KIND=8) pcldsw(kdlon, kflev)
+  REAL (KIND=8) pclear(kdlon)
+  REAL (KIND=8) pdsig(kdlon, kflev)
+  REAL (KIND=8) pomega(kdlon, 2, kflev)
+  REAL (KIND=8) poz(kdlon, kflev)
+  REAL (KIND=8) prmu(kdlon)
+  REAL (KIND=8) psec(kdlon)
+  REAL (KIND=8) ptau(kdlon, 2, kflev)
+  REAL (KIND=8) pud(kdlon, 5, kflev+1)
+
+  REAL (KIND=8) pfd(kdlon, kflev+1)
+  REAL (KIND=8) pfu(kdlon, kflev+1)
+
+  ! * LOCAL VARIABLES:
+
+  INTEGER iind(4)
+
+  REAL (KIND=8) zcgaz(kdlon, kflev)
+  REAL (KIND=8) zdiff(kdlon)
+  REAL (KIND=8) zdirf(kdlon)
+  REAL (KIND=8) zpizaz(kdlon, kflev)
+  REAL (KIND=8) zrayl(kdlon)
+  REAL (KIND=8) zray1(kdlon, kflev+1)
+  REAL (KIND=8) zray2(kdlon, kflev+1)
+  REAL (KIND=8) zrefz(kdlon, 2, kflev+1)
+  REAL (KIND=8) zrj(kdlon, 6, kflev+1)
+  REAL (KIND=8) zrj0(kdlon, 6, kflev+1)
+  REAL (KIND=8) zrk(kdlon, 6, kflev+1)
+  REAL (KIND=8) zrk0(kdlon, 6, kflev+1)
+  REAL (KIND=8) zrmue(kdlon, kflev+1)
+  REAL (KIND=8) zrmu0(kdlon, kflev+1)
+  REAL (KIND=8) zr(kdlon, 4)
+  REAL (KIND=8) ztauaz(kdlon, kflev)
+  REAL (KIND=8) ztra1(kdlon, kflev+1)
+  REAL (KIND=8) ztra2(kdlon, kflev+1)
+  REAL (KIND=8) zw(kdlon, 4)
+
+  INTEGER jl, jk, k, jaj, ikm1, ikl
+
+  ! If running with Reporbus, overwrite default values of RSUN.
+  ! Otherwise keep default values from radiation_AR4_param module.
+  IF (type_trac=='repr') THEN
+IF (CPPKEY_REPROBUS) THEN
+    IF (ok_suntime) THEN
+      rsun(1) = rsuntime(1)
+      rsun(2) = rsuntime(2)
+    END IF
+    WRITE (lunout, *) 'RSUN(1): ', rsun(1)
+END IF
+  END IF
+
+  ! ------------------------------------------------------------------
+
+  ! *         1.     FIRST SPECTRAL INTERVAL (0.25-0.68 MICRON)
+  ! ----------------------- ------------------
+
+
+
+  ! *         1.1    OPTICAL THICKNESS FOR RAYLEIGH SCATTERING
+  ! -----------------------------------------
+
+
+  DO jl = 1, kdlon
+    zrayl(jl) = rray(knu, 1) + prmu(jl)*(rray(knu,2)+prmu(jl)*(rray(knu, &
+      3)+prmu(jl)*(rray(knu,4)+prmu(jl)*(rray(knu,5)+prmu(jl)*rray(knu,6)))))
+  END DO
+
+
+  ! ------------------------------------------------------------------
+
+  ! *         2.    CONTINUUM SCATTERING CALCULATIONS
+  ! ---------------------------------
+
+
+  ! *         2.1   CLEAR-SKY FRACTION OF THE COLUMN
+  ! --------------------------------
+
+
+  CALL swclr_lmdar4(knu, paer, flag_aer, tauae, pizae, cgae, palbp, pdsig, &
+    zrayl, psec, zcgaz, zpizaz, zray1, zray2, zrefz, zrj0, zrk0, zrmu0, &
+    ztauaz, ztra1, ztra2)
+
+  ! *         2.2   CLOUDY FRACTION OF THE COLUMN
+  ! -----------------------------
+
+
+  CALL swr_lmdar4(knu, palbd, pcg, pcld, pdsig, pomega, zrayl, psec, ptau, &
+    zcgaz, zpizaz, zray1, zray2, zrefz, zrj, zrk, zrmue, ztauaz, ztra1, &
+    ztra2)
+
+  ! ------------------------------------------------------------------
+
+  ! *         3.    OZONE ABSORPTION
+  ! ----------------
+
+
+  iind(1) = 1
+  iind(2) = 3
+  iind(3) = 1
+  iind(4) = 3
+
+  ! *         3.1   DOWNWARD FLUXES
+  ! ---------------
+
+
+  jaj = 2
+
+  DO jl = 1, kdlon
+    zw(jl, 1) = 0.
+    zw(jl, 2) = 0.
+    zw(jl, 3) = 0.
+    zw(jl, 4) = 0.
+    pfd(jl, kflev+1) = ((1.-pclear(jl))*zrj(jl,jaj,kflev+1)+pclear(jl)*zrj0( &
+      jl,jaj,kflev+1))*rsun(knu)
+  END DO
+  DO jk = 1, kflev
+    ikl = kflev + 1 - jk
+    DO jl = 1, kdlon
+      zw(jl, 1) = zw(jl, 1) + pud(jl, 1, ikl)/zrmue(jl, ikl)
+      zw(jl, 2) = zw(jl, 2) + poz(jl, ikl)/zrmue(jl, ikl)
+      zw(jl, 3) = zw(jl, 3) + pud(jl, 1, ikl)/zrmu0(jl, ikl)
+      zw(jl, 4) = zw(jl, 4) + poz(jl, ikl)/zrmu0(jl, ikl)
+    END DO
+
+    CALL swtt1_lmdar4(knu, 4, iind, zw, zr)
+
+    DO jl = 1, kdlon
+      zdiff(jl) = zr(jl, 1)*zr(jl, 2)*zrj(jl, jaj, ikl)
+      zdirf(jl) = zr(jl, 3)*zr(jl, 4)*zrj0(jl, jaj, ikl)
+      pfd(jl, ikl) = ((1.-pclear(jl))*zdiff(jl)+pclear(jl)*zdirf(jl))* &
+        rsun(knu)
+    END DO
+  END DO
+
+  ! *         3.2   UPWARD FLUXES
+  ! -------------
+
+
+  DO jl = 1, kdlon
+    pfu(jl, 1) = ((1.-pclear(jl))*zdiff(jl)*palbd(jl,knu)+pclear(jl)*zdirf(jl &
+      )*palbp(jl,knu))*rsun(knu)
+  END DO
+
+  DO jk = 2, kflev + 1
+    ikm1 = jk - 1
+    DO jl = 1, kdlon
+      zw(jl, 1) = zw(jl, 1) + pud(jl, 1, ikm1)*1.66
+      zw(jl, 2) = zw(jl, 2) + poz(jl, ikm1)*1.66
+      zw(jl, 3) = zw(jl, 3) + pud(jl, 1, ikm1)*1.66
+      zw(jl, 4) = zw(jl, 4) + poz(jl, ikm1)*1.66
+    END DO
+
+    CALL swtt1_lmdar4(knu, 4, iind, zw, zr)
+
+    DO jl = 1, kdlon
+      zdiff(jl) = zr(jl, 1)*zr(jl, 2)*zrk(jl, jaj, jk)
+      zdirf(jl) = zr(jl, 3)*zr(jl, 4)*zrk0(jl, jaj, jk)
+      pfu(jl, jk) = ((1.-pclear(jl))*zdiff(jl)+pclear(jl)*zdirf(jl))* &
+        rsun(knu)
+    END DO
+  END DO
+
+  ! ------------------------------------------------------------------
+
+  RETURN
+END SUBROUTINE sw1s_lmdar4
+SUBROUTINE sw2s_lmdar4(knu, paer, flag_aer, tauae, pizae, cgae, paki, palbd, &
+    palbp, pcg, pcld, pclear, pcldsw, pdsig, pomega, poz, prmu, psec, ptau, &
+    pud, pwv, pqs, pfdown, pfup)
+  USE dimphy
+  USE radiation_ar4_param, ONLY: rsun, rray
+  USE infotrac_phy, ONLY: type_trac
+  USE lmdz_reprobus_wrappers, ONLY: rsuntime, ok_suntime
+  USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_REPROBUS
+
+  IMPLICIT NONE
+  include "radepsi.h"
+
+  ! ------------------------------------------------------------------
+  ! PURPOSE.
+  ! --------
+
+  ! THIS ROUTINE COMPUTES THE SHORTWAVE RADIATION FLUXES IN THE
+  ! SECOND SPECTRAL INTERVAL FOLLOWING FOUQUART AND BONNEL (1980).
+
+  ! METHOD.
+  ! -------
+
+  ! 1. COMPUTES REFLECTIVITY/TRANSMISSIVITY CORRESPONDING TO
+  ! CONTINUUM SCATTERING
+  ! 2. COMPUTES REFLECTIVITY/TRANSMISSIVITY CORRESPONDING FOR
+  ! A GREY MOLECULAR ABSORPTION
+  ! 3. LAPLACE TRANSFORM ON THE PREVIOUS TO GET EFFECTIVE AMOUNTS
+  ! OF ABSORBERS
+  ! 4. APPLY H2O AND U.M.G. TRANSMISSION FUNCTIONS
+  ! 5. MULTIPLY BY OZONE TRANSMISSION FUNCTION
+
+  ! REFERENCE.
+  ! ----------
+
+  ! SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT
+  ! DOCUMENTATION, AND FOUQUART AND BONNEL (1980)
+
+  ! AUTHOR.
+  ! -------
+  ! JEAN-JACQUES MORCRETTE  *ECMWF*
+
+  ! MODIFICATIONS.
+  ! --------------
+  ! ORIGINAL : 89-07-14
+  ! 94-11-15   J.-J. MORCRETTE    DIRECT/DIFFUSE ALBEDO
+  ! ------------------------------------------------------------------
+  ! * ARGUMENTS:
+
+  INTEGER knu
+  ! -OB
+  REAL (KIND=8) flag_aer
+  REAL (KIND=8) tauae(kdlon, kflev, 2)
+  REAL (KIND=8) pizae(kdlon, kflev, 2)
+  REAL (KIND=8) cgae(kdlon, kflev, 2)
+  REAL (KIND=8) paer(kdlon, kflev, 5)
+  REAL (KIND=8) paki(kdlon, 2)
+  REAL (KIND=8) palbd(kdlon, 2)
+  REAL (KIND=8) palbp(kdlon, 2)
+  REAL (KIND=8) pcg(kdlon, 2, kflev)
+  REAL (KIND=8) pcld(kdlon, kflev)
+  REAL (KIND=8) pcldsw(kdlon, kflev)
+  REAL (KIND=8) pclear(kdlon)
+  REAL (KIND=8) pdsig(kdlon, kflev)
+  REAL (KIND=8) pomega(kdlon, 2, kflev)
+  REAL (KIND=8) poz(kdlon, kflev)
+  REAL (KIND=8) pqs(kdlon, kflev)
+  REAL (KIND=8) prmu(kdlon)
+  REAL (KIND=8) psec(kdlon)
+  REAL (KIND=8) ptau(kdlon, 2, kflev)
+  REAL (KIND=8) pud(kdlon, 5, kflev+1)
+  REAL (KIND=8) pwv(kdlon, kflev)
+
+  REAL (KIND=8) pfdown(kdlon, kflev+1)
+  REAL (KIND=8) pfup(kdlon, kflev+1)
+
+  ! * LOCAL VARIABLES:
+
+  INTEGER iind2(2), iind3(3)
+  REAL (KIND=8) zcgaz(kdlon, kflev)
+  REAL (KIND=8) zfd(kdlon, kflev+1)
+  REAL (KIND=8) zfu(kdlon, kflev+1)
+  REAL (KIND=8) zg(kdlon)
+  REAL (KIND=8) zgg(kdlon)
+  REAL (KIND=8) zpizaz(kdlon, kflev)
+  REAL (KIND=8) zrayl(kdlon)
+  REAL (KIND=8) zray1(kdlon, kflev+1)
+  REAL (KIND=8) zray2(kdlon, kflev+1)
+  REAL (KIND=8) zref(kdlon)
+  REAL (KIND=8) zrefz(kdlon, 2, kflev+1)
+  REAL (KIND=8) zre1(kdlon)
+  REAL (KIND=8) zre2(kdlon)
+  REAL (KIND=8) zrj(kdlon, 6, kflev+1)
+  REAL (KIND=8) zrj0(kdlon, 6, kflev+1)
+  REAL (KIND=8) zrk(kdlon, 6, kflev+1)
+  REAL (KIND=8) zrk0(kdlon, 6, kflev+1)
+  REAL (KIND=8) zrl(kdlon, 8)
+  REAL (KIND=8) zrmue(kdlon, kflev+1)
+  REAL (KIND=8) zrmu0(kdlon, kflev+1)
+  REAL (KIND=8) zrmuz(kdlon)
+  REAL (KIND=8) zrneb(kdlon)
+  REAL (KIND=8) zruef(kdlon, 8)
+  REAL (KIND=8) zr1(kdlon)
+  REAL (KIND=8) zr2(kdlon, 2)
+  REAL (KIND=8) zr3(kdlon, 3)
+  REAL (KIND=8) zr4(kdlon)
+  REAL (KIND=8) zr21(kdlon)
+  REAL (KIND=8) zr22(kdlon)
+  REAL (KIND=8) zs(kdlon)
+  REAL (KIND=8) ztauaz(kdlon, kflev)
+  REAL (KIND=8) zto1(kdlon)
+  REAL (KIND=8) ztr(kdlon, 2, kflev+1)
+  REAL (KIND=8) ztra1(kdlon, kflev+1)
+  REAL (KIND=8) ztra2(kdlon, kflev+1)
+  REAL (KIND=8) ztr1(kdlon)
+  REAL (KIND=8) ztr2(kdlon)
+  REAL (KIND=8) zw(kdlon)
+  REAL (KIND=8) zw1(kdlon)
+  REAL (KIND=8) zw2(kdlon, 2)
+  REAL (KIND=8) zw3(kdlon, 3)
+  REAL (KIND=8) zw4(kdlon)
+  REAL (KIND=8) zw5(kdlon)
+
+  INTEGER jl, jk, k, jaj, ikm1, ikl, jn, jabs, jkm1
+  INTEGER jref, jkl, jklp1, jajp, jkki, jkkp4, jn2j, iabs
+  REAL (KIND=8) zrmum1, zwh2o, zcneb, zaa, zbb, zrki, zre11
+
+  ! If running with Reporbus, overwrite default values of RSUN.
+  ! Otherwise keep default values from radiation_AR4_param module.
+  IF (type_trac=='repr') THEN
+IF (CPPKEY_REPROBUS) THEN
+    IF (ok_suntime) THEN
+      rsun(1) = rsuntime(1)
+      rsun(2) = rsuntime(2)
+    END IF
+END IF
+  END IF
+
+  ! ------------------------------------------------------------------
+
+  ! *         1.     SECOND SPECTRAL INTERVAL (0.68-4.00 MICRON)
+  ! -------------------------------------------
+
+
+
+  ! *         1.1    OPTICAL THICKNESS FOR RAYLEIGH SCATTERING
+  ! -----------------------------------------
+
+
+  DO jl = 1, kdlon
+    zrmum1 = 1. - prmu(jl)
+    zrayl(jl) = rray(knu, 1) + zrmum1*(rray(knu,2)+zrmum1*(rray(knu, &
+      3)+zrmum1*(rray(knu,4)+zrmum1*(rray(knu,5)+zrmum1*rray(knu,6)))))
+  END DO
+
+  ! ------------------------------------------------------------------
+
+  ! *         2.    CONTINUUM SCATTERING CALCULATIONS
+  ! ---------------------------------
+
+
+  ! *         2.1   CLEAR-SKY FRACTION OF THE COLUMN
+  ! --------------------------------
+
+
+  CALL swclr_lmdar4(knu, paer, flag_aer, tauae, pizae, cgae, palbp, pdsig, &
+    zrayl, psec, zcgaz, zpizaz, zray1, zray2, zrefz, zrj0, zrk0, zrmu0, &
+    ztauaz, ztra1, ztra2)
+
+  ! *         2.2   CLOUDY FRACTION OF THE COLUMN
+  ! -----------------------------
+
+
+  CALL swr_lmdar4(knu, palbd, pcg, pcld, pdsig, pomega, zrayl, psec, ptau, &
+    zcgaz, zpizaz, zray1, zray2, zrefz, zrj, zrk, zrmue, ztauaz, ztra1, &
+    ztra2)
+
+  ! ------------------------------------------------------------------
+
+  ! *         3.    SCATTERING CALCULATIONS WITH GREY MOLECULAR ABSORPTION
+  ! ------------------------------------------------------
+
+
+  jn = 2
+
+  DO jabs = 1, 2
+    ! *         3.1  SURFACE CONDITIONS
+    ! ------------------
+
+
+    DO jl = 1, kdlon
+      zrefz(jl, 2, 1) = palbd(jl, knu)
+      zrefz(jl, 1, 1) = palbd(jl, knu)
+    END DO
+
+    ! *         3.2  INTRODUCING CLOUD EFFECTS
+    ! -------------------------
+
+
+    DO jk = 2, kflev + 1
+      jkm1 = jk - 1
+      ikl = kflev + 1 - jkm1
+      DO jl = 1, kdlon
+        zrneb(jl) = pcld(jl, jkm1)
+        IF (jabs==1 .AND. zrneb(jl)>2.*zeelog) THEN
+          zwh2o = max(pwv(jl,jkm1), zeelog)
+          zcneb = max(zeelog, min(zrneb(jl),1.-zeelog))
+          zbb = pud(jl, jabs, jkm1)*pqs(jl, jkm1)/zwh2o
+          zaa = max((pud(jl,jabs,jkm1)-zcneb*zbb)/(1.-zcneb), zeelog)
+        ELSE
+          zaa = pud(jl, jabs, jkm1)
+          zbb = zaa
+        END IF
+        zrki = paki(jl, jabs)
+        zs(jl) = exp(-zrki*zaa*1.66)
+        zg(jl) = exp(-zrki*zaa/zrmue(jl,jk))
+        ztr1(jl) = 0.
+        zre1(jl) = 0.
+        ztr2(jl) = 0.
+        zre2(jl) = 0.
+
+        zw(jl) = pomega(jl, knu, jkm1)
+        zto1(jl) = ptau(jl, knu, jkm1)/zw(jl) + ztauaz(jl, jkm1)/zpizaz(jl, &
+          jkm1) + zbb*zrki
+
+        zr21(jl) = ptau(jl, knu, jkm1) + ztauaz(jl, jkm1)
+        zr22(jl) = ptau(jl, knu, jkm1)/zr21(jl)
+        zgg(jl) = zr22(jl)*pcg(jl, knu, jkm1) + (1.-zr22(jl))*zcgaz(jl, jkm1)
+        zw(jl) = zr21(jl)/zto1(jl)
+        zref(jl) = zrefz(jl, 1, jkm1)
+        zrmuz(jl) = zrmue(jl, jk)
+      END DO
+
+      CALL swde_lmdar4(zgg, zref, zrmuz, zto1, zw, zre1, zre2, ztr1, ztr2)
+
+      DO jl = 1, kdlon
+
+        zrefz(jl, 2, jk) = (1.-zrneb(jl))*(zray1(jl,jkm1)+zrefz(jl,2,jkm1)* &
+          ztra1(jl,jkm1)*ztra2(jl,jkm1))*zg(jl)*zs(jl) + zrneb(jl)*zre1(jl)
+
+        ztr(jl, 2, jkm1) = zrneb(jl)*ztr1(jl) + (ztra1(jl,jkm1))*zg(jl)*(1.- &
+          zrneb(jl))
+
+        zrefz(jl, 1, jk) = (1.-zrneb(jl))*(zray1(jl,jkm1)+zrefz(jl,1,jkm1)* &
+          ztra1(jl,jkm1)*ztra2(jl,jkm1)/(1.-zray2(jl,jkm1)*zrefz(jl,1, &
+          jkm1)))*zg(jl)*zs(jl) + zrneb(jl)*zre2(jl)
+
+        ztr(jl, 1, jkm1) = zrneb(jl)*ztr2(jl) + (ztra1(jl,jkm1)/(1.-zray2(jl, &
+          jkm1)*zrefz(jl,1,jkm1)))*zg(jl)*(1.-zrneb(jl))
+
+      END DO
+    END DO
+
+    ! *         3.3  REFLECT./TRANSMISSIVITY BETWEEN SURFACE AND LEVEL
+    ! -------------------------------------------------
+
+
+    DO jref = 1, 2
+
+      jn = jn + 1
+
+      DO jl = 1, kdlon
+        zrj(jl, jn, kflev+1) = 1.
+        zrk(jl, jn, kflev+1) = zrefz(jl, jref, kflev+1)
+      END DO
+
+      DO jk = 1, kflev
+        jkl = kflev + 1 - jk
+        jklp1 = jkl + 1
+        DO jl = 1, kdlon
+          zre11 = zrj(jl, jn, jklp1)*ztr(jl, jref, jkl)
+          zrj(jl, jn, jkl) = zre11
+          zrk(jl, jn, jkl) = zre11*zrefz(jl, jref, jkl)
+        END DO
+      END DO
+    END DO
+  END DO
+
+  ! ------------------------------------------------------------------
+
+  ! *         4.    INVERT GREY AND CONTINUUM FLUXES
+  ! --------------------------------
+
+
+
+  ! *         4.1   UPWARD (ZRK) AND DOWNWARD (ZRJ) PSEUDO-FLUXES
+  ! ---------------------------------------------
+
+
+  DO jk = 1, kflev + 1
+    DO jaj = 1, 5, 2
+      jajp = jaj + 1
+      DO jl = 1, kdlon
+        zrj(jl, jaj, jk) = zrj(jl, jaj, jk) - zrj(jl, jajp, jk)
+        zrk(jl, jaj, jk) = zrk(jl, jaj, jk) - zrk(jl, jajp, jk)
+        zrj(jl, jaj, jk) = max(zrj(jl,jaj,jk), zeelog)
+        zrk(jl, jaj, jk) = max(zrk(jl,jaj,jk), zeelog)
+      END DO
+    END DO
+  END DO
+
+  DO jk = 1, kflev + 1
+    DO jaj = 2, 6, 2
+      DO jl = 1, kdlon
+        zrj(jl, jaj, jk) = max(zrj(jl,jaj,jk), zeelog)
+        zrk(jl, jaj, jk) = max(zrk(jl,jaj,jk), zeelog)
+      END DO
+    END DO
+  END DO
+
+  ! *         4.2    EFFECTIVE ABSORBER AMOUNTS BY INVERSE LAPLACE
+  ! ---------------------------------------------
+
+
+  DO jk = 1, kflev + 1
+    jkki = 1
+    DO jaj = 1, 2
+      iind2(1) = jaj
+      iind2(2) = jaj
+      DO jn = 1, 2
+        jn2j = jn + 2*jaj
+        jkkp4 = jkki + 4
+
+        ! *         4.2.1  EFFECTIVE ABSORBER AMOUNTS
+        ! --------------------------
+
+
+        DO jl = 1, kdlon
+          zw2(jl, 1) = log(zrj(jl,jn,jk)/zrj(jl,jn2j,jk))/paki(jl, jaj)
+          zw2(jl, 2) = log(zrk(jl,jn,jk)/zrk(jl,jn2j,jk))/paki(jl, jaj)
+        END DO
+
+        ! *         4.2.2  TRANSMISSION FUNCTION
+        ! ---------------------
+
+
+        CALL swtt1_lmdar4(knu, 2, iind2, zw2, zr2)
+
+        DO jl = 1, kdlon
+          zrl(jl, jkki) = zr2(jl, 1)
+          zruef(jl, jkki) = zw2(jl, 1)
+          zrl(jl, jkkp4) = zr2(jl, 2)
+          zruef(jl, jkkp4) = zw2(jl, 2)
+        END DO
+
+        jkki = jkki + 1
+      END DO
+    END DO
+
+    ! *         4.3    UPWARD AND DOWNWARD FLUXES WITH H2O AND UMG ABSORPTION
+    ! ------------------------------------------------------
+
+
+    DO jl = 1, kdlon
+      pfdown(jl, jk) = zrj(jl, 1, jk)*zrl(jl, 1)*zrl(jl, 3) + &
+        zrj(jl, 2, jk)*zrl(jl, 2)*zrl(jl, 4)
+      pfup(jl, jk) = zrk(jl, 1, jk)*zrl(jl, 5)*zrl(jl, 7) + &
+        zrk(jl, 2, jk)*zrl(jl, 6)*zrl(jl, 8)
+    END DO
+  END DO
+
+  ! ------------------------------------------------------------------
+
+  ! *         5.    MOLECULAR ABSORPTION ON CLEAR-SKY FLUXES
+  ! ----------------------------------------
+
+
+
+  ! *         5.1   DOWNWARD FLUXES
+  ! ---------------
+
+
+  jaj = 2
+  iind3(1) = 1
+  iind3(2) = 2
+  iind3(3) = 3
+
+  DO jl = 1, kdlon
+    zw3(jl, 1) = 0.
+    zw3(jl, 2) = 0.
+    zw3(jl, 3) = 0.
+    zw4(jl) = 0.
+    zw5(jl) = 0.
+    zr4(jl) = 1.
+    zfd(jl, kflev+1) = zrj0(jl, jaj, kflev+1)
+  END DO
+  DO jk = 1, kflev
+    ikl = kflev + 1 - jk
+    DO jl = 1, kdlon
+      zw3(jl, 1) = zw3(jl, 1) + pud(jl, 1, ikl)/zrmu0(jl, ikl)
+      zw3(jl, 2) = zw3(jl, 2) + pud(jl, 2, ikl)/zrmu0(jl, ikl)
+      zw3(jl, 3) = zw3(jl, 3) + poz(jl, ikl)/zrmu0(jl, ikl)
+      zw4(jl) = zw4(jl) + pud(jl, 4, ikl)/zrmu0(jl, ikl)
+      zw5(jl) = zw5(jl) + pud(jl, 5, ikl)/zrmu0(jl, ikl)
+    END DO
+
+    CALL swtt1_lmdar4(knu, 3, iind3, zw3, zr3)
+
+    DO jl = 1, kdlon
+      ! ZR4(JL) = EXP(-RSWCE*ZW4(JL)-RSWCP*ZW5(JL))
+      zfd(jl, ikl) = zr3(jl, 1)*zr3(jl, 2)*zr3(jl, 3)*zr4(jl)* &
+        zrj0(jl, jaj, ikl)
+    END DO
+  END DO
+
+  ! *         5.2   UPWARD FLUXES
+  ! -------------
+
+
+  DO jl = 1, kdlon
+    zfu(jl, 1) = zfd(jl, 1)*palbp(jl, knu)
+  END DO
+
+  DO jk = 2, kflev + 1
+    ikm1 = jk - 1
+    DO jl = 1, kdlon
+      zw3(jl, 1) = zw3(jl, 1) + pud(jl, 1, ikm1)*1.66
+      zw3(jl, 2) = zw3(jl, 2) + pud(jl, 2, ikm1)*1.66
+      zw3(jl, 3) = zw3(jl, 3) + poz(jl, ikm1)*1.66
+      zw4(jl) = zw4(jl) + pud(jl, 4, ikm1)*1.66
+      zw5(jl) = zw5(jl) + pud(jl, 5, ikm1)*1.66
+    END DO
+
+    CALL swtt1_lmdar4(knu, 3, iind3, zw3, zr3)
+
+    DO jl = 1, kdlon
+      ! ZR4(JL) = EXP(-RSWCE*ZW4(JL)-RSWCP*ZW5(JL))
+      zfu(jl, jk) = zr3(jl, 1)*zr3(jl, 2)*zr3(jl, 3)*zr4(jl)* &
+        zrk0(jl, jaj, jk)
+    END DO
+  END DO
+
+  ! ------------------------------------------------------------------
+
+  ! *         6.     INTRODUCTION OF OZONE AND H2O CONTINUUM ABSORPTION
+  ! --------------------------------------------------
+
+  iabs = 3
+
+  ! *         6.1    DOWNWARD FLUXES
+  ! ---------------
+
+  DO jl = 1, kdlon
+    zw1(jl) = 0.
+    zw4(jl) = 0.
+    zw5(jl) = 0.
+    zr1(jl) = 0.
+    pfdown(jl, kflev+1) = ((1.-pclear(jl))*pfdown(jl,kflev+1)+pclear(jl)*zfd( &
+      jl,kflev+1))*rsun(knu)
+  END DO
+
+  DO jk = 1, kflev
+    ikl = kflev + 1 - jk
+    DO jl = 1, kdlon
+      zw1(jl) = zw1(jl) + poz(jl, ikl)/zrmue(jl, ikl)
+      zw4(jl) = zw4(jl) + pud(jl, 4, ikl)/zrmue(jl, ikl)
+      zw5(jl) = zw5(jl) + pud(jl, 5, ikl)/zrmue(jl, ikl)
+      ! ZR4(JL) = EXP(-RSWCE*ZW4(JL)-RSWCP*ZW5(JL))
+    END DO
+
+    CALL swtt_lmdar4(knu, iabs, zw1, zr1)
+
+    DO jl = 1, kdlon
+      pfdown(jl, ikl) = ((1.-pclear(jl))*zr1(jl)*zr4(jl)*pfdown(jl,ikl)+ &
+        pclear(jl)*zfd(jl,ikl))*rsun(knu)
+    END DO
+  END DO
+
+  ! *         6.2    UPWARD FLUXES
+  ! -------------
+
+  DO jl = 1, kdlon
+    pfup(jl, 1) = ((1.-pclear(jl))*zr1(jl)*zr4(jl)*pfup(jl,1)+pclear(jl)*zfu( &
+      jl,1))*rsun(knu)
+  END DO
+
+  DO jk = 2, kflev + 1
+    ikm1 = jk - 1
+    DO jl = 1, kdlon
+      zw1(jl) = zw1(jl) + poz(jl, ikm1)*1.66
+      zw4(jl) = zw4(jl) + pud(jl, 4, ikm1)*1.66
+      zw5(jl) = zw5(jl) + pud(jl, 5, ikm1)*1.66
+      ! ZR4(JL) = EXP(-RSWCE*ZW4(JL)-RSWCP*ZW5(JL))
+    END DO
+
+    CALL swtt_lmdar4(knu, iabs, zw1, zr1)
+
+    DO jl = 1, kdlon
+      pfup(jl, jk) = ((1.-pclear(jl))*zr1(jl)*zr4(jl)*pfup(jl,jk)+pclear(jl)* &
+        zfu(jl,jk))*rsun(knu)
+    END DO
+  END DO
+
+  ! ------------------------------------------------------------------
+
+  RETURN
+END SUBROUTINE sw2s_lmdar4
+SUBROUTINE swclr_lmdar4(knu, paer, flag_aer, tauae, pizae, cgae, palbp, &
+    pdsig, prayl, psec, pcgaz, ppizaz, pray1, pray2, prefz, prj, prk, prmu0, &
+    ptauaz, ptra1, ptra2)
+  USE dimphy
+  USE radiation_ar4_param, ONLY: taua, rpiza, rcga
+  IMPLICIT NONE
+  include "radepsi.h"
+  include "radopt.h"
+
+  ! ------------------------------------------------------------------
+  ! PURPOSE.
+  ! --------
+  ! COMPUTES THE REFLECTIVITY AND TRANSMISSIVITY IN CASE OF
+  ! CLEAR-SKY COLUMN
+
+  ! REFERENCE.
+  ! ----------
+
+  ! SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT
+  ! DOCUMENTATION, AND FOUQUART AND BONNEL (1980)
+
+  ! AUTHOR.
+  ! -------
+  ! JEAN-JACQUES MORCRETTE  *ECMWF*
+
+  ! MODIFICATIONS.
+  ! --------------
+  ! ORIGINAL : 94-11-15
+  ! ------------------------------------------------------------------
+  ! * ARGUMENTS:
+
+  INTEGER knu
+  ! -OB
+  REAL (KIND=8) flag_aer
+  REAL (KIND=8) tauae(kdlon, kflev, 2)
+  REAL (KIND=8) pizae(kdlon, kflev, 2)
+  REAL (KIND=8) cgae(kdlon, kflev, 2)
+  REAL (KIND=8) paer(kdlon, kflev, 5)
+  REAL (KIND=8) palbp(kdlon, 2)
+  REAL (KIND=8) pdsig(kdlon, kflev)
+  REAL (KIND=8) prayl(kdlon)
+  REAL (KIND=8) psec(kdlon)
+
+  REAL (KIND=8) pcgaz(kdlon, kflev)
+  REAL (KIND=8) ppizaz(kdlon, kflev)
+  REAL (KIND=8) pray1(kdlon, kflev+1)
+  REAL (KIND=8) pray2(kdlon, kflev+1)
+  REAL (KIND=8) prefz(kdlon, 2, kflev+1)
+  REAL (KIND=8) prj(kdlon, 6, kflev+1)
+  REAL (KIND=8) prk(kdlon, 6, kflev+1)
+  REAL (KIND=8) prmu0(kdlon, kflev+1)
+  REAL (KIND=8) ptauaz(kdlon, kflev)
+  REAL (KIND=8) ptra1(kdlon, kflev+1)
+  REAL (KIND=8) ptra2(kdlon, kflev+1)
+
+  ! * LOCAL VARIABLES:
+
+  REAL (KIND=8) zc0i(kdlon, kflev+1)
+  REAL (KIND=8) zcle0(kdlon, kflev)
+  REAL (KIND=8) zclear(kdlon)
+  REAL (KIND=8) zr21(kdlon)
+  REAL (KIND=8) zr23(kdlon)
+  REAL (KIND=8) zss0(kdlon)
+  REAL (KIND=8) zscat(kdlon)
+  REAL (KIND=8) ztr(kdlon, 2, kflev+1)
+
+  INTEGER jl, jk, ja, jae, jkl, jklp1, jaj, jkm1, in
+  REAL (KIND=8) ztray, zgar, zratio, zff, zfacoa, zcorae
+  REAL (KIND=8) zmue, zgap, zww, zto, zden, zmu1, zden1
+  REAL (KIND=8) zbmu0, zbmu1, zre11
+
+  ! ------------------------------------------------------------------
+
+  ! *         1.    OPTICAL PARAMETERS FOR AEROSOLS AND RAYLEIGH
+  ! --------------------------------------------
+
+
+  ! cdir collapse
+  DO jk = 1, kflev + 1
+    DO ja = 1, 6
+      DO jl = 1, kdlon
+        prj(jl, ja, jk) = 0.
+        prk(jl, ja, jk) = 0.
+      END DO
+    END DO
+  END DO
+
+  DO jk = 1, kflev
+    ! -OB
+    ! DO 104 JL = 1, KDLON
+    ! PCGAZ(JL,JK) = 0.
+    ! PPIZAZ(JL,JK) =  0.
+    ! PTAUAZ(JL,JK) = 0.
+    ! 104  CONTINUE
+    ! -OB
+    ! DO 106 JAE=1,5
+    ! DO 105 JL = 1, KDLON
+    ! PTAUAZ(JL,JK)=PTAUAZ(JL,JK)
+    ! S        +PAER(JL,JK,JAE)*TAUA(KNU,JAE)
+    ! PPIZAZ(JL,JK)=PPIZAZ(JL,JK)+PAER(JL,JK,JAE)
+    ! S        * TAUA(KNU,JAE)*RPIZA(KNU,JAE)
+    ! PCGAZ(JL,JK) =  PCGAZ(JL,JK) +PAER(JL,JK,JAE)
+    ! S        * TAUA(KNU,JAE)*RPIZA(KNU,JAE)*RCGA(KNU,JAE)
+    ! 105  CONTINUE
+    ! 106  CONTINUE
+    ! -OB
+    DO jl = 1, kdlon
+      ptauaz(jl, jk) = flag_aer*tauae(jl, jk, knu)
+      ppizaz(jl, jk) = flag_aer*pizae(jl, jk, knu)
+      pcgaz(jl, jk) = flag_aer*cgae(jl, jk, knu)
+    END DO
+
+    IF (flag_aer>0) THEN
+      ! -OB
+      DO jl = 1, kdlon
+        ! PCGAZ(JL,JK)=PCGAZ(JL,JK)/PPIZAZ(JL,JK)
+        ! PPIZAZ(JL,JK)=PPIZAZ(JL,JK)/PTAUAZ(JL,JK)
+        ztray = prayl(jl)*pdsig(jl, jk)
+        zratio = ztray/(ztray+ptauaz(jl,jk))
+        zgar = pcgaz(jl, jk)
+        zff = zgar*zgar
+        ptauaz(jl, jk) = ztray + ptauaz(jl, jk)*(1.-ppizaz(jl,jk)*zff)
+        pcgaz(jl, jk) = zgar*(1.-zratio)/(1.+zgar)
+        ppizaz(jl, jk) = zratio + (1.-zratio)*ppizaz(jl, jk)*(1.-zff)/(1.- &
+          ppizaz(jl,jk)*zff)
+      END DO
+    ELSE
+      DO jl = 1, kdlon
+        ztray = prayl(jl)*pdsig(jl, jk)
+        ptauaz(jl, jk) = ztray
+        pcgaz(jl, jk) = 0.
+        ppizaz(jl, jk) = 1. - repsct
+      END DO
+    END IF ! check flag_aer
+    ! 107  CONTINUE
+    ! PRINT 9107,JK,((PAER(JL,JK,JAE),JAE=1,5)
+    ! $ ,PTAUAZ(JL,JK),PPIZAZ(JL,JK),PCGAZ(JL,JK),JL=1,KDLON)
+    ! 9107 FORMAT(1X,'SWCLR_107',I3,8E12.5)
+
+  END DO
+
+  ! ------------------------------------------------------------------
+
+  ! *         2.    TOTAL EFFECTIVE CLOUDINESS ABOVE A GIVEN LEVEL
+  ! ----------------------------------------------
+
+
+  DO jl = 1, kdlon
+    zr23(jl) = 0.
+    zc0i(jl, kflev+1) = 0.
+    zclear(jl) = 1.
+    zscat(jl) = 0.
+  END DO
+
+  jk = 1
+  jkl = kflev + 1 - jk
+  jklp1 = jkl + 1
+  DO jl = 1, kdlon
+    zfacoa = 1. - ppizaz(jl, jkl)*pcgaz(jl, jkl)*pcgaz(jl, jkl)
+    zcorae = zfacoa*ptauaz(jl, jkl)*psec(jl)
+    zr21(jl) = exp(-zcorae)
+    zss0(jl) = 1. - zr21(jl)
+    zcle0(jl, jkl) = zss0(jl)
+
+    IF (novlp==1) THEN
+      ! * maximum-random
+      zclear(jl) = zclear(jl)*(1.0-max(zss0(jl),zscat(jl)))/ &
+        (1.0-min(zscat(jl),1.-zepsec))
+      zc0i(jl, jkl) = 1.0 - zclear(jl)
+      zscat(jl) = zss0(jl)
+    ELSE IF (novlp==2) THEN
+      ! * maximum
+      zscat(jl) = max(zss0(jl), zscat(jl))
+      zc0i(jl, jkl) = zscat(jl)
+    ELSE IF (novlp==3) THEN
+      ! * random
+      zclear(jl) = zclear(jl)*(1.0-zss0(jl))
+      zscat(jl) = 1.0 - zclear(jl)
+      zc0i(jl, jkl) = zscat(jl)
+    END IF
+  END DO
+
+  DO jk = 2, kflev
+    jkl = kflev + 1 - jk
+    jklp1 = jkl + 1
+    DO jl = 1, kdlon
+      zfacoa = 1. - ppizaz(jl, jkl)*pcgaz(jl, jkl)*pcgaz(jl, jkl)
+      zcorae = zfacoa*ptauaz(jl, jkl)*psec(jl)
+      zr21(jl) = exp(-zcorae)
+      zss0(jl) = 1. - zr21(jl)
+      zcle0(jl, jkl) = zss0(jl)
+
+      IF (novlp==1) THEN
+        ! * maximum-random
+        zclear(jl) = zclear(jl)*(1.0-max(zss0(jl),zscat(jl)))/ &
+          (1.0-min(zscat(jl),1.-zepsec))
+        zc0i(jl, jkl) = 1.0 - zclear(jl)
+        zscat(jl) = zss0(jl)
+      ELSE IF (novlp==2) THEN
+        ! * maximum
+        zscat(jl) = max(zss0(jl), zscat(jl))
+        zc0i(jl, jkl) = zscat(jl)
+      ELSE IF (novlp==3) THEN
+        ! * random
+        zclear(jl) = zclear(jl)*(1.0-zss0(jl))
+        zscat(jl) = 1.0 - zclear(jl)
+        zc0i(jl, jkl) = zscat(jl)
+      END IF
+    END DO
+  END DO
+
+  ! ------------------------------------------------------------------
+
+  ! *         3.    REFLECTIVITY/TRANSMISSIVITY FOR PURE SCATTERING
+  ! -----------------------------------------------
+
+
+  DO jl = 1, kdlon
+    pray1(jl, kflev+1) = 0.
+    pray2(jl, kflev+1) = 0.
+    prefz(jl, 2, 1) = palbp(jl, knu)
+    prefz(jl, 1, 1) = palbp(jl, knu)
+    ptra1(jl, kflev+1) = 1.
+    ptra2(jl, kflev+1) = 1.
+  END DO
+
+  DO jk = 2, kflev + 1
+    jkm1 = jk - 1
+    DO jl = 1, kdlon
+
+      ! ------------------------------------------------------------------
+
+      ! *         3.1  EQUIVALENT ZENITH ANGLE
+      ! -----------------------
+
+
+      zmue = (1.-zc0i(jl,jk))*psec(jl) + zc0i(jl, jk)*1.66
+      prmu0(jl, jk) = 1./zmue
+
+      ! ------------------------------------------------------------------
+
+      ! *         3.2  REFLECT./TRANSMISSIVITY DUE TO RAYLEIGH AND AEROSOLS
+      ! ----------------------------------------------------
+
+
+      zgap = pcgaz(jl, jkm1)
+      zbmu0 = 0.5 - 0.75*zgap/zmue
+      zww = ppizaz(jl, jkm1)
+      zto = ptauaz(jl, jkm1)
+      zden = 1. + (1.-zww+zbmu0*zww)*zto*zmue + (1-zww)*(1.-zww+2.*zbmu0*zww) &
+        *zto*zto*zmue*zmue
+      pray1(jl, jkm1) = zbmu0*zww*zto*zmue/zden
+      ptra1(jl, jkm1) = 1./zden
+
+      zmu1 = 0.5
+      zbmu1 = 0.5 - 0.75*zgap*zmu1
+      zden1 = 1. + (1.-zww+zbmu1*zww)*zto/zmu1 + (1-zww)*(1.-zww+2.*zbmu1*zww &
+        )*zto*zto/zmu1/zmu1
+      pray2(jl, jkm1) = zbmu1*zww*zto/zmu1/zden1
+      ptra2(jl, jkm1) = 1./zden1
+
+
+
+      prefz(jl, 1, jk) = (pray1(jl,jkm1)+prefz(jl,1,jkm1)*ptra1(jl,jkm1)* &
+        ptra2(jl,jkm1)/(1.-pray2(jl,jkm1)*prefz(jl,1,jkm1)))
+
+      ztr(jl, 1, jkm1) = (ptra1(jl,jkm1)/(1.-pray2(jl,jkm1)*prefz(jl,1, &
+        jkm1)))
+
+      prefz(jl, 2, jk) = (pray1(jl,jkm1)+prefz(jl,2,jkm1)*ptra1(jl,jkm1)* &
+        ptra2(jl,jkm1))
+
+      ztr(jl, 2, jkm1) = ptra1(jl, jkm1)
+
+    END DO
+  END DO
+  DO jl = 1, kdlon
+    zmue = (1.-zc0i(jl,1))*psec(jl) + zc0i(jl, 1)*1.66
+    prmu0(jl, 1) = 1./zmue
+  END DO
+
+  ! ------------------------------------------------------------------
+
+  ! *         3.5    REFLECT./TRANSMISSIVITY BETWEEN SURFACE AND LEVEL
+  ! -------------------------------------------------
+
+
+  IF (knu==1) THEN
+    jaj = 2
+    DO jl = 1, kdlon
+      prj(jl, jaj, kflev+1) = 1.
+      prk(jl, jaj, kflev+1) = prefz(jl, 1, kflev+1)
+    END DO
+
+    DO jk = 1, kflev
+      jkl = kflev + 1 - jk
+      jklp1 = jkl + 1
+      DO jl = 1, kdlon
+        zre11 = prj(jl, jaj, jklp1)*ztr(jl, 1, jkl)
+        prj(jl, jaj, jkl) = zre11
+        prk(jl, jaj, jkl) = zre11*prefz(jl, 1, jkl)
+      END DO
+    END DO
+
+  ELSE
+
+    DO jaj = 1, 2
+      DO jl = 1, kdlon
+        prj(jl, jaj, kflev+1) = 1.
+        prk(jl, jaj, kflev+1) = prefz(jl, jaj, kflev+1)
+      END DO
+
+      DO jk = 1, kflev
+        jkl = kflev + 1 - jk
+        jklp1 = jkl + 1
+        DO jl = 1, kdlon
+          zre11 = prj(jl, jaj, jklp1)*ztr(jl, jaj, jkl)
+          prj(jl, jaj, jkl) = zre11
+          prk(jl, jaj, jkl) = zre11*prefz(jl, jaj, jkl)
+        END DO
+      END DO
+    END DO
+
+  END IF
+
+  ! ------------------------------------------------------------------
+
+  RETURN
+END SUBROUTINE swclr_lmdar4
+SUBROUTINE swr_lmdar4(knu, palbd, pcg, pcld, pdsig, pomega, prayl, psec, &
+    ptau, pcgaz, ppizaz, pray1, pray2, prefz, prj, prk, prmue, ptauaz, ptra1, &
+    ptra2)
+  USE dimphy
+  IMPLICIT NONE
+  include "radepsi.h"
+  include "radopt.h"
+
+  ! ------------------------------------------------------------------
+  ! PURPOSE.
+  ! --------
+  ! COMPUTES THE REFLECTIVITY AND TRANSMISSIVITY IN CASE OF
+  ! CONTINUUM SCATTERING
+
+  ! METHOD.
+  ! -------
+
+  ! 1. COMPUTES CONTINUUM FLUXES CORRESPONDING TO AEROSOL
+  ! OR/AND RAYLEIGH SCATTERING (NO MOLECULAR GAS ABSORPTION)
+
+  ! REFERENCE.
+  ! ----------
+
+  ! SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT
+  ! DOCUMENTATION, AND FOUQUART AND BONNEL (1980)
+
+  ! AUTHOR.
+  ! -------
+  ! JEAN-JACQUES MORCRETTE  *ECMWF*
+
+  ! MODIFICATIONS.
+  ! --------------
+  ! ORIGINAL : 89-07-14
+  ! ------------------------------------------------------------------
+  ! * ARGUMENTS:
+
+  INTEGER knu
+  REAL (KIND=8) palbd(kdlon, 2)
+  REAL (KIND=8) pcg(kdlon, 2, kflev)
+  REAL (KIND=8) pcld(kdlon, kflev)
+  REAL (KIND=8) pdsig(kdlon, kflev)
+  REAL (KIND=8) pomega(kdlon, 2, kflev)
+  REAL (KIND=8) prayl(kdlon)
+  REAL (KIND=8) psec(kdlon)
+  REAL (KIND=8) ptau(kdlon, 2, kflev)
+
+  REAL (KIND=8) pray1(kdlon, kflev+1)
+  REAL (KIND=8) pray2(kdlon, kflev+1)
+  REAL (KIND=8) prefz(kdlon, 2, kflev+1)
+  REAL (KIND=8) prj(kdlon, 6, kflev+1)
+  REAL (KIND=8) prk(kdlon, 6, kflev+1)
+  REAL (KIND=8) prmue(kdlon, kflev+1)
+  REAL (KIND=8) pcgaz(kdlon, kflev)
+  REAL (KIND=8) ppizaz(kdlon, kflev)
+  REAL (KIND=8) ptauaz(kdlon, kflev)
+  REAL (KIND=8) ptra1(kdlon, kflev+1)
+  REAL (KIND=8) ptra2(kdlon, kflev+1)
+
+  ! * LOCAL VARIABLES:
+
+  REAL (KIND=8) zc1i(kdlon, kflev+1)
+  REAL (KIND=8) zcleq(kdlon, kflev)
+  REAL (KIND=8) zclear(kdlon)
+  REAL (KIND=8) zcloud(kdlon)
+  REAL (KIND=8) zgg(kdlon)
+  REAL (KIND=8) zref(kdlon)
+  REAL (KIND=8) zre1(kdlon)
+  REAL (KIND=8) zre2(kdlon)
+  REAL (KIND=8) zrmuz(kdlon)
+  REAL (KIND=8) zrneb(kdlon)
+  REAL (KIND=8) zr21(kdlon)
+  REAL (KIND=8) zr22(kdlon)
+  REAL (KIND=8) zr23(kdlon)
+  REAL (KIND=8) zss1(kdlon)
+  REAL (KIND=8) zto1(kdlon)
+  REAL (KIND=8) ztr(kdlon, 2, kflev+1)
+  REAL (KIND=8) ztr1(kdlon)
+  REAL (KIND=8) ztr2(kdlon)
+  REAL (KIND=8) zw(kdlon)
+
+  INTEGER jk, jl, ja, jkl, jklp1, jkm1, jaj
+  REAL (KIND=8) zfacoa, zfacoc, zcorae, zcorcd
+  REAL (KIND=8) zmue, zgap, zww, zto, zden, zden1
+  REAL (KIND=8) zmu1, zre11, zbmu0, zbmu1
+
+  ! ------------------------------------------------------------------
+
+  ! *         1.    INITIALIZATION
+  ! --------------
+
+
+  DO jk = 1, kflev + 1
+    DO ja = 1, 6
+      DO jl = 1, kdlon
+        prj(jl, ja, jk) = 0.
+        prk(jl, ja, jk) = 0.
+      END DO
+    END DO
+  END DO
+
+  ! ------------------------------------------------------------------
+
+  ! *         2.    TOTAL EFFECTIVE CLOUDINESS ABOVE A GIVEN LEVEL
+  ! ----------------------------------------------
+
+
+  DO jl = 1, kdlon
+    zr23(jl) = 0.
+    zc1i(jl, kflev+1) = 0.
+    zclear(jl) = 1.
+    zcloud(jl) = 0.
+  END DO
+
+  jk = 1
+  jkl = kflev + 1 - jk
+  jklp1 = jkl + 1
+  DO jl = 1, kdlon
+    zfacoa = 1. - ppizaz(jl, jkl)*pcgaz(jl, jkl)*pcgaz(jl, jkl)
+    zfacoc = 1. - pomega(jl, knu, jkl)*pcg(jl, knu, jkl)*pcg(jl, knu, jkl)
+    zcorae = zfacoa*ptauaz(jl, jkl)*psec(jl)
+    zcorcd = zfacoc*ptau(jl, knu, jkl)*psec(jl)
+    zr21(jl) = exp(-zcorae)
+    zr22(jl) = exp(-zcorcd)
+    zss1(jl) = pcld(jl, jkl)*(1.0-zr21(jl)*zr22(jl)) + &
+      (1.0-pcld(jl,jkl))*(1.0-zr21(jl))
+    zcleq(jl, jkl) = zss1(jl)
+
+    IF (novlp==1) THEN
+      ! * maximum-random
+      zclear(jl) = zclear(jl)*(1.0-max(zss1(jl),zcloud(jl)))/ &
+        (1.0-min(zcloud(jl),1.-zepsec))
+      zc1i(jl, jkl) = 1.0 - zclear(jl)
+      zcloud(jl) = zss1(jl)
+    ELSE IF (novlp==2) THEN
+      ! * maximum
+      zcloud(jl) = max(zss1(jl), zcloud(jl))
+      zc1i(jl, jkl) = zcloud(jl)
+    ELSE IF (novlp==3) THEN
+      ! * random
+      zclear(jl) = zclear(jl)*(1.0-zss1(jl))
+      zcloud(jl) = 1.0 - zclear(jl)
+      zc1i(jl, jkl) = zcloud(jl)
+    END IF
+  END DO
+
+  DO jk = 2, kflev
+    jkl = kflev + 1 - jk
+    jklp1 = jkl + 1
+    DO jl = 1, kdlon
+      zfacoa = 1. - ppizaz(jl, jkl)*pcgaz(jl, jkl)*pcgaz(jl, jkl)
+      zfacoc = 1. - pomega(jl, knu, jkl)*pcg(jl, knu, jkl)*pcg(jl, knu, jkl)
+      zcorae = zfacoa*ptauaz(jl, jkl)*psec(jl)
+      zcorcd = zfacoc*ptau(jl, knu, jkl)*psec(jl)
+      zr21(jl) = exp(-zcorae)
+      zr22(jl) = exp(-zcorcd)
+      zss1(jl) = pcld(jl, jkl)*(1.0-zr21(jl)*zr22(jl)) + &
+        (1.0-pcld(jl,jkl))*(1.0-zr21(jl))
+      zcleq(jl, jkl) = zss1(jl)
+
+      IF (novlp==1) THEN
+        ! * maximum-random
+        zclear(jl) = zclear(jl)*(1.0-max(zss1(jl),zcloud(jl)))/ &
+          (1.0-min(zcloud(jl),1.-zepsec))
+        zc1i(jl, jkl) = 1.0 - zclear(jl)
+        zcloud(jl) = zss1(jl)
+      ELSE IF (novlp==2) THEN
+        ! * maximum
+        zcloud(jl) = max(zss1(jl), zcloud(jl))
+        zc1i(jl, jkl) = zcloud(jl)
+      ELSE IF (novlp==3) THEN
+        ! * random
+        zclear(jl) = zclear(jl)*(1.0-zss1(jl))
+        zcloud(jl) = 1.0 - zclear(jl)
+        zc1i(jl, jkl) = zcloud(jl)
+      END IF
+    END DO
+  END DO
+
+  ! ------------------------------------------------------------------
+
+  ! *         3.    REFLECTIVITY/TRANSMISSIVITY FOR PURE SCATTERING
+  ! -----------------------------------------------
+
+
+  DO jl = 1, kdlon
+    pray1(jl, kflev+1) = 0.
+    pray2(jl, kflev+1) = 0.
+    prefz(jl, 2, 1) = palbd(jl, knu)
+    prefz(jl, 1, 1) = palbd(jl, knu)
+    ptra1(jl, kflev+1) = 1.
+    ptra2(jl, kflev+1) = 1.
+  END DO
+
+  DO jk = 2, kflev + 1
+    jkm1 = jk - 1
+    DO jl = 1, kdlon
+      zrneb(jl) = pcld(jl, jkm1)
+      zre1(jl) = 0.
+      ztr1(jl) = 0.
+      zre2(jl) = 0.
+      ztr2(jl) = 0.
+
+      ! ------------------------------------------------------------------
+
+      ! *         3.1  EQUIVALENT ZENITH ANGLE
+      ! -----------------------
+
+
+      zmue = (1.-zc1i(jl,jk))*psec(jl) + zc1i(jl, jk)*1.66
+      prmue(jl, jk) = 1./zmue
+
+      ! ------------------------------------------------------------------
+
+      ! *         3.2  REFLECT./TRANSMISSIVITY DUE TO RAYLEIGH AND AEROSOLS
+      ! ----------------------------------------------------
+
+
+      zgap = pcgaz(jl, jkm1)
+      zbmu0 = 0.5 - 0.75*zgap/zmue
+      zww = ppizaz(jl, jkm1)
+      zto = ptauaz(jl, jkm1)
+      zden = 1. + (1.-zww+zbmu0*zww)*zto*zmue + (1-zww)*(1.-zww+2.*zbmu0*zww) &
+        *zto*zto*zmue*zmue
+      pray1(jl, jkm1) = zbmu0*zww*zto*zmue/zden
+      ptra1(jl, jkm1) = 1./zden
+      ! PRINT *,' LOOP 342 ** 3 ** JL=',JL,PRAY1(JL,JKM1),PTRA1(JL,JKM1)
+
+      zmu1 = 0.5
+      zbmu1 = 0.5 - 0.75*zgap*zmu1
+      zden1 = 1. + (1.-zww+zbmu1*zww)*zto/zmu1 + (1-zww)*(1.-zww+2.*zbmu1*zww &
+        )*zto*zto/zmu1/zmu1
+      pray2(jl, jkm1) = zbmu1*zww*zto/zmu1/zden1
+      ptra2(jl, jkm1) = 1./zden1
+
+      ! ------------------------------------------------------------------
+
+      ! *         3.3  EFFECT OF CLOUD LAYER
+      ! ---------------------
+
+
+      zw(jl) = pomega(jl, knu, jkm1)
+      zto1(jl) = ptau(jl, knu, jkm1)/zw(jl) + ptauaz(jl, jkm1)/ppizaz(jl, &
+        jkm1)
+      zr21(jl) = ptau(jl, knu, jkm1) + ptauaz(jl, jkm1)
+      zr22(jl) = ptau(jl, knu, jkm1)/zr21(jl)
+      zgg(jl) = zr22(jl)*pcg(jl, knu, jkm1) + (1.-zr22(jl))*pcgaz(jl, jkm1)
+      ! Modif PhD - JJM 19/03/96 pour erreurs arrondis
+      ! machine
+      ! PHD PROTECTION ZW(JL) = ZR21(JL) / ZTO1(JL)
+      IF (zw(jl)==1. .AND. ppizaz(jl,jkm1)==1.) THEN
+        zw(jl) = 1.
+      ELSE
+        zw(jl) = zr21(jl)/zto1(jl)
+      END IF
+      zref(jl) = prefz(jl, 1, jkm1)
+      zrmuz(jl) = prmue(jl, jk)
+    END DO
+
+    CALL swde_lmdar4(zgg, zref, zrmuz, zto1, zw, zre1, zre2, ztr1, ztr2)
+
+    DO jl = 1, kdlon
+
+      prefz(jl, 1, jk) = (1.-zrneb(jl))*(pray1(jl,jkm1)+prefz(jl,1,jkm1)* &
+        ptra1(jl,jkm1)*ptra2(jl,jkm1)/(1.-pray2(jl,jkm1)*prefz(jl,1, &
+        jkm1))) + zrneb(jl)*zre2(jl)
+
+      ztr(jl, 1, jkm1) = zrneb(jl)*ztr2(jl) + (ptra1(jl,jkm1)/(1.-pray2(jl, &
+        jkm1)*prefz(jl,1,jkm1)))*(1.-zrneb(jl))
+
+      prefz(jl, 2, jk) = (1.-zrneb(jl))*(pray1(jl,jkm1)+prefz(jl,2,jkm1)* &
+        ptra1(jl,jkm1)*ptra2(jl,jkm1)) + zrneb(jl)*zre1(jl)
+
+      ztr(jl, 2, jkm1) = zrneb(jl)*ztr1(jl) + ptra1(jl, jkm1)*(1.-zrneb(jl))
+
+    END DO
+  END DO
+  DO jl = 1, kdlon
+    zmue = (1.-zc1i(jl,1))*psec(jl) + zc1i(jl, 1)*1.66
+    prmue(jl, 1) = 1./zmue
+  END DO
+
+  ! ------------------------------------------------------------------
+
+  ! *         3.5    REFLECT./TRANSMISSIVITY BETWEEN SURFACE AND LEVEL
+  ! -------------------------------------------------
+
+
+  IF (knu==1) THEN
+    jaj = 2
+    DO jl = 1, kdlon
+      prj(jl, jaj, kflev+1) = 1.
+      prk(jl, jaj, kflev+1) = prefz(jl, 1, kflev+1)
+    END DO
+
+    DO jk = 1, kflev
+      jkl = kflev + 1 - jk
+      jklp1 = jkl + 1
+      DO jl = 1, kdlon
+        zre11 = prj(jl, jaj, jklp1)*ztr(jl, 1, jkl)
+        prj(jl, jaj, jkl) = zre11
+        prk(jl, jaj, jkl) = zre11*prefz(jl, 1, jkl)
+      END DO
+    END DO
+
+  ELSE
+
+    DO jaj = 1, 2
+      DO jl = 1, kdlon
+        prj(jl, jaj, kflev+1) = 1.
+        prk(jl, jaj, kflev+1) = prefz(jl, jaj, kflev+1)
+      END DO
+
+      DO jk = 1, kflev
+        jkl = kflev + 1 - jk
+        jklp1 = jkl + 1
+        DO jl = 1, kdlon
+          zre11 = prj(jl, jaj, jklp1)*ztr(jl, jaj, jkl)
+          prj(jl, jaj, jkl) = zre11
+          prk(jl, jaj, jkl) = zre11*prefz(jl, jaj, jkl)
+        END DO
+      END DO
+    END DO
+
+  END IF
+
+  ! ------------------------------------------------------------------
+
+  RETURN
+END SUBROUTINE swr_lmdar4
+SUBROUTINE swde_lmdar4(pgg, pref, prmuz, pto1, pw, pre1, pre2, ptr1, ptr2)
+  USE dimphy
+  IMPLICIT NONE
+
+  ! ------------------------------------------------------------------
+  ! PURPOSE.
+  ! --------
+  ! COMPUTES THE REFLECTIVITY AND TRANSMISSIVITY OF A CLOUDY
+  ! LAYER USING THE DELTA-EDDINGTON'S APPROXIMATION.
+
+  ! METHOD.
+  ! -------
+
+  ! STANDARD DELTA-EDDINGTON LAYER CALCULATIONS.
+
+  ! REFERENCE.
+  ! ----------
+
+  ! SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+  ! ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
+
+  ! AUTHOR.
+  ! -------
+  ! JEAN-JACQUES MORCRETTE  *ECMWF*
+
+  ! MODIFICATIONS.
+  ! --------------
+  ! ORIGINAL : 88-12-15
+  ! ------------------------------------------------------------------
+  ! * ARGUMENTS:
+
+  REAL (KIND=8) pgg(kdlon) ! ASSYMETRY FACTOR
+  REAL (KIND=8) pref(kdlon) ! REFLECTIVITY OF THE UNDERLYING LAYER
+  REAL (KIND=8) prmuz(kdlon) ! COSINE OF SOLAR ZENITH ANGLE
+  REAL (KIND=8) pto1(kdlon) ! OPTICAL THICKNESS
+  REAL (KIND=8) pw(kdlon) ! SINGLE SCATTERING ALBEDO
+  REAL (KIND=8) pre1(kdlon) ! LAYER REFLECTIVITY (NO UNDERLYING-LAYER REFLECTION)
+  REAL (KIND=8) pre2(kdlon) ! LAYER REFLECTIVITY
+  REAL (KIND=8) ptr1(kdlon) ! LAYER TRANSMISSIVITY (NO UNDERLYING-LAYER REFLECTION)
+  REAL (KIND=8) ptr2(kdlon) ! LAYER TRANSMISSIVITY
+
+  ! * LOCAL VARIABLES:
+
+  INTEGER jl
+  REAL (KIND=8) zff, zgp, ztop, zwcp, zdt, zx1, zwm
+  REAL (KIND=8) zrm2, zrk, zx2, zrp, zalpha, zbeta, zarg
+  REAL (KIND=8) zexmu0, zarg2, zexkp, zexkm, zxp2p, zxm2p, zap2b, zam2b
+  REAL (KIND=8) za11, za12, za13, za21, za22, za23
+  REAL (KIND=8) zdena, zc1a, zc2a, zri0a, zri1a
+  REAL (KIND=8) zri0b, zri1b
+  REAL (KIND=8) zb21, zb22, zb23, zdenb, zc1b, zc2b
+  REAL (KIND=8) zri0c, zri1c, zri0d, zri1d
+
+  ! ------------------------------------------------------------------
+
+  ! *         1.      DELTA-EDDINGTON CALCULATIONS
+
+
+  DO jl = 1, kdlon
+    ! *         1.1     SET UP THE DELTA-MODIFIED PARAMETERS
+
+
+    zff = pgg(jl)*pgg(jl)
+    zgp = pgg(jl)/(1.+pgg(jl))
+    ztop = (1.-pw(jl)*zff)*pto1(jl)
+    zwcp = (1-zff)*pw(jl)/(1.-pw(jl)*zff)
+    zdt = 2./3.
+    zx1 = 1. - zwcp*zgp
+    zwm = 1. - zwcp
+    zrm2 = prmuz(jl)*prmuz(jl)
+    zrk = sqrt(3.*zwm*zx1)
+    zx2 = 4.*(1.-zrk*zrk*zrm2)
+    zrp = zrk/zx1
+    zalpha = 3.*zwcp*zrm2*(1.+zgp*zwm)/zx2
+    zbeta = 3.*zwcp*prmuz(jl)*(1.+3.*zgp*zrm2*zwm)/zx2
+    zarg = min(ztop/prmuz(jl), 200._8)
+    zexmu0 = exp(-zarg)
+    zarg2 = min(zrk*ztop, 200._8)
+    zexkp = exp(zarg2)
+    zexkm = 1./zexkp
+    zxp2p = 1. + zdt*zrp
+    zxm2p = 1. - zdt*zrp
+    zap2b = zalpha + zdt*zbeta
+    zam2b = zalpha - zdt*zbeta
+
+    ! *         1.2     WITHOUT REFLECTION FROM THE UNDERLYING LAYER
+
+
+    za11 = zxp2p
+    za12 = zxm2p
+    za13 = zap2b
+    za22 = zxp2p*zexkp
+    za21 = zxm2p*zexkm
+    za23 = zam2b*zexmu0
+    zdena = za11*za22 - za21*za12
+    zc1a = (za22*za13-za12*za23)/zdena
+    zc2a = (za11*za23-za21*za13)/zdena
+    zri0a = zc1a + zc2a - zalpha
+    zri1a = zrp*(zc1a-zc2a) - zbeta
+    pre1(jl) = (zri0a-zdt*zri1a)/prmuz(jl)
+    zri0b = zc1a*zexkm + zc2a*zexkp - zalpha*zexmu0
+    zri1b = zrp*(zc1a*zexkm-zc2a*zexkp) - zbeta*zexmu0
+    ptr1(jl) = zexmu0 + (zri0b+zdt*zri1b)/prmuz(jl)
+
+    ! *         1.3     WITH REFLECTION FROM THE UNDERLYING LAYER
+
+
+    zb21 = za21 - pref(jl)*zxp2p*zexkm
+    zb22 = za22 - pref(jl)*zxm2p*zexkp
+    zb23 = za23 - pref(jl)*zexmu0*(zap2b-prmuz(jl))
+    zdenb = za11*zb22 - zb21*za12
+    zc1b = (zb22*za13-za12*zb23)/zdenb
+    zc2b = (za11*zb23-zb21*za13)/zdenb
+    zri0c = zc1b + zc2b - zalpha
+    zri1c = zrp*(zc1b-zc2b) - zbeta
+    pre2(jl) = (zri0c-zdt*zri1c)/prmuz(jl)
+    zri0d = zc1b*zexkm + zc2b*zexkp - zalpha*zexmu0
+    zri1d = zrp*(zc1b*zexkm-zc2b*zexkp) - zbeta*zexmu0
+    ptr2(jl) = zexmu0 + (zri0d+zdt*zri1d)/prmuz(jl)
+
+  END DO
+  RETURN
+END SUBROUTINE swde_lmdar4
+SUBROUTINE swtt_lmdar4(knu, ka, pu, ptr)
+  USE dimphy
+  USE radiation_ar4_param, ONLY: apad, bpad, d
+  IMPLICIT NONE
+
+  ! -----------------------------------------------------------------------
+  ! PURPOSE.
+  ! --------
+  ! THIS ROUTINE COMPUTES THE TRANSMISSION FUNCTIONS FOR ALL THE
+  ! ABSORBERS (H2O, UNIFORMLY MIXED GASES, AND O3) IN THE TWO SPECTRAL
+  ! INTERVALS.
+
+  ! METHOD.
+  ! -------
+
+  ! TRANSMISSION FUNCTION ARE COMPUTED USING PADE APPROXIMANTS
+  ! AND HORNER'S ALGORITHM.
+
+  ! REFERENCE.
+  ! ----------
+
+  ! SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+  ! ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
+
+  ! AUTHOR.
+  ! -------
+  ! JEAN-JACQUES MORCRETTE  *ECMWF*
+
+  ! MODIFICATIONS.
+  ! --------------
+  ! ORIGINAL : 88-12-15
+  ! -----------------------------------------------------------------------
+
+  ! * ARGUMENTS
+
+  INTEGER knu ! INDEX OF THE SPECTRAL INTERVAL
+  INTEGER ka ! INDEX OF THE ABSORBER
+  REAL (KIND=8) pu(kdlon) ! ABSORBER AMOUNT
+
+  REAL (KIND=8) ptr(kdlon) ! TRANSMISSION FUNCTION
+
+  ! * LOCAL VARIABLES:
+
+  REAL (KIND=8) zr1(kdlon), zr2(kdlon)
+  INTEGER jl, i, j
+
+  ! -----------------------------------------------------------------------
+
+  ! *         1.      HORNER'S ALGORITHM TO COMPUTE TRANSMISSION FUNCTION
+
+
+  DO jl = 1, kdlon
+    zr1(jl) = apad(knu, ka, 1) + pu(jl)*(apad(knu,ka,2)+pu(jl)*(apad(knu,ka, &
+      3)+pu(jl)*(apad(knu,ka,4)+pu(jl)*(apad(knu,ka,5)+pu(jl)*(apad(knu,ka,6) &
+      +pu(jl)*(apad(knu,ka,7)))))))
+
+    zr2(jl) = bpad(knu, ka, 1) + pu(jl)*(bpad(knu,ka,2)+pu(jl)*(bpad(knu,ka, &
+      3)+pu(jl)*(bpad(knu,ka,4)+pu(jl)*(bpad(knu,ka,5)+pu(jl)*(bpad(knu,ka,6) &
+      +pu(jl)*(bpad(knu,ka,7)))))))
+
+    ! *         2.      ADD THE BACKGROUND TRANSMISSION
+
+
+
+    ptr(jl) = (zr1(jl)/zr2(jl))*(1.-d(knu,ka)) + d(knu, ka)
+  END DO
+
+  RETURN
+END SUBROUTINE swtt_lmdar4
+SUBROUTINE swtt1_lmdar4(knu, kabs, kind, pu, ptr)
+  USE dimphy
+  USE radiation_ar4_param, ONLY: apad, bpad, d
+  IMPLICIT NONE
+
+  ! -----------------------------------------------------------------------
+  ! PURPOSE.
+  ! --------
+  ! THIS ROUTINE COMPUTES THE TRANSMISSION FUNCTIONS FOR ALL THE
+  ! ABSORBERS (H2O, UNIFORMLY MIXED GASES, AND O3) IN THE TWO SPECTRAL
+  ! INTERVALS.
+
+  ! METHOD.
+  ! -------
+
+  ! TRANSMISSION FUNCTION ARE COMPUTED USING PADE APPROXIMANTS
+  ! AND HORNER'S ALGORITHM.
+
+  ! REFERENCE.
+  ! ----------
+
+  ! SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+  ! ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
+
+  ! AUTHOR.
+  ! -------
+  ! JEAN-JACQUES MORCRETTE  *ECMWF*
+
+  ! MODIFICATIONS.
+  ! --------------
+  ! ORIGINAL : 95-01-20
+  ! -----------------------------------------------------------------------
+  ! * ARGUMENTS:
+
+  INTEGER knu ! INDEX OF THE SPECTRAL INTERVAL
+  INTEGER kabs ! NUMBER OF ABSORBERS
+  INTEGER kind(kabs) ! INDICES OF THE ABSORBERS
+  REAL (KIND=8) pu(kdlon, kabs) ! ABSORBER AMOUNT
+
+  REAL (KIND=8) ptr(kdlon, kabs) ! TRANSMISSION FUNCTION
+
+  ! * LOCAL VARIABLES:
+
+  REAL (KIND=8) zr1(kdlon)
+  REAL (KIND=8) zr2(kdlon)
+  REAL (KIND=8) zu(kdlon)
+  INTEGER jl, ja, i, j, ia
+
+  ! -----------------------------------------------------------------------
+
+  ! *         1.      HORNER'S ALGORITHM TO COMPUTE TRANSMISSION FUNCTION
+
+
+  DO ja = 1, kabs
+    ia = kind(ja)
+    DO jl = 1, kdlon
+      zu(jl) = pu(jl, ja)
+      zr1(jl) = apad(knu, ia, 1) + zu(jl)*(apad(knu,ia,2)+zu(jl)*(apad(knu, &
+        ia,3)+zu(jl)*(apad(knu,ia,4)+zu(jl)*(apad(knu,ia,5)+zu(jl)*(apad(knu, &
+        ia,6)+zu(jl)*(apad(knu,ia,7)))))))
+
+      zr2(jl) = bpad(knu, ia, 1) + zu(jl)*(bpad(knu,ia,2)+zu(jl)*(bpad(knu, &
+        ia,3)+zu(jl)*(bpad(knu,ia,4)+zu(jl)*(bpad(knu,ia,5)+zu(jl)*(bpad(knu, &
+        ia,6)+zu(jl)*(bpad(knu,ia,7)))))))
+
+      ! *         2.      ADD THE BACKGROUND TRANSMISSION
+
+
+      ptr(jl, ja) = (zr1(jl)/zr2(jl))*(1.-d(knu,ia)) + d(knu, ia)
+    END DO
+  END DO
+
+  RETURN
+END SUBROUTINE swtt1_lmdar4
+! IM ctes ds clesphys.h   SUBROUTINE LW(RCO2,RCH4,RN2O,RCFC11,RCFC12,
+SUBROUTINE lw_lmdar4(ppmb, pdp, ppsol, pdt0, pemis, ptl, ptave, pwv, pozon, &
+    paer, pcldld, pcldlu, pview, pcolr, pcolr0, ptoplw, psollw, ptoplw0, &
+    psollw0, psollwdown, &         ! IM  .
+                                   ! psollwdown,psollwdownclr,
+  ! IM  .              ptoplwdown,ptoplwdownclr)
+    plwup, plwdn, plwup0, plwdn0)
+  USE dimphy
+  USE print_control_mod, ONLY: lunout
+  IMPLICIT NONE
+  include "raddimlw.h"
+  include "YOMCST.h"
+
+  ! -----------------------------------------------------------------------
+  ! METHOD.
+  ! -------
+
+  ! 1. COMPUTES THE PRESSURE AND TEMPERATURE WEIGHTED AMOUNTS OF
+  ! ABSORBERS.
+  ! 2. COMPUTES THE PLANCK FUNCTIONS ON THE INTERFACES AND THE
+  ! GRADIENT OF PLANCK FUNCTIONS IN THE LAYERS.
+  ! 3. PERFORMS THE VERTICAL INTEGRATION DISTINGUISHING THE CON-
+  ! TRIBUTIONS OF THE ADJACENT AND DISTANT LAYERS AND THOSE FROM THE
+  ! BOUNDARIES.
+  ! 4. COMPUTES THE CLEAR-SKY DOWNWARD AND UPWARD EMISSIVITIES.
+  ! 5. INTRODUCES THE EFFECTS OF THE CLOUDS ON THE FLUXES.
+
+
+  ! REFERENCE.
+  ! ----------
+
+  ! SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+  ! ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
+
+  ! AUTHOR.
+  ! -------
+  ! JEAN-JACQUES MORCRETTE  *ECMWF*
+
+  ! MODIFICATIONS.
+  ! --------------
+  ! ORIGINAL : 89-07-14
+  ! -----------------------------------------------------------------------
+  ! IM ctes ds clesphys.h
+  ! REAL(KIND=8) RCO2   ! CO2 CONCENTRATION (IPCC:353.E-06* 44.011/28.97)
+  ! REAL(KIND=8) RCH4   ! CH4 CONCENTRATION (IPCC: 1.72E-06* 16.043/28.97)
+  ! REAL(KIND=8) RN2O   ! N2O CONCENTRATION (IPCC: 310.E-09* 44.013/28.97)
+  ! REAL(KIND=8) RCFC11 ! CFC11 CONCENTRATION (IPCC: 280.E-12*
+  ! 137.3686/28.97)
+  ! REAL(KIND=8) RCFC12 ! CFC12 CONCENTRATION (IPCC: 484.E-12*
+  ! 120.9140/28.97)
+  include "clesphys.h"
+  REAL (KIND=8) pcldld(kdlon, kflev) ! DOWNWARD EFFECTIVE CLOUD COVER
+  REAL (KIND=8) pcldlu(kdlon, kflev) ! UPWARD EFFECTIVE CLOUD COVER
+  REAL (KIND=8) pdp(kdlon, kflev) ! LAYER PRESSURE THICKNESS (Pa)
+  REAL (KIND=8) pdt0(kdlon) ! SURFACE TEMPERATURE DISCONTINUITY (K)
+  REAL (KIND=8) pemis(kdlon) ! SURFACE EMISSIVITY
+  REAL (KIND=8) ppmb(kdlon, kflev+1) ! HALF LEVEL PRESSURE (mb)
+  REAL (KIND=8) ppsol(kdlon) ! SURFACE PRESSURE (Pa)
+  REAL (KIND=8) pozon(kdlon, kflev) ! O3 mass fraction
+  REAL (KIND=8) ptl(kdlon, kflev+1) ! HALF LEVEL TEMPERATURE (K)
+  REAL (KIND=8) paer(kdlon, kflev, 5) ! OPTICAL THICKNESS OF THE AEROSOLS
+  REAL (KIND=8) ptave(kdlon, kflev) ! LAYER TEMPERATURE (K)
+  REAL (KIND=8) pview(kdlon) ! COSECANT OF VIEWING ANGLE
+  REAL (KIND=8) pwv(kdlon, kflev) ! SPECIFIC HUMIDITY (kg/kg)
+
+  REAL (KIND=8) pcolr(kdlon, kflev) ! LONG-WAVE TENDENCY (K/day)
+  REAL (KIND=8) pcolr0(kdlon, kflev) ! LONG-WAVE TENDENCY (K/day) clear-sky
+  REAL (KIND=8) ptoplw(kdlon) ! LONGWAVE FLUX AT T.O.A.
+  REAL (KIND=8) psollw(kdlon) ! LONGWAVE FLUX AT SURFACE
+  REAL (KIND=8) ptoplw0(kdlon) ! LONGWAVE FLUX AT T.O.A. (CLEAR-SKY)
+  REAL (KIND=8) psollw0(kdlon) ! LONGWAVE FLUX AT SURFACE (CLEAR-SKY)
+  ! Rajout LF
+  REAL (KIND=8) psollwdown(kdlon) ! LONGWAVE downwards flux at surface
+  ! Rajout IM
+  ! IM   real(kind=8) psollwdownclr(kdlon) ! LONGWAVE CS downwards flux at
+  ! surface
+  ! IM   real(kind=8) ptoplwdown(kdlon)    ! LONGWAVE downwards flux at
+  ! T.O.A.
+  ! IM   real(kind=8) ptoplwdownclr(kdlon) ! LONGWAVE CS downwards flux at
+  ! T.O.A.
+  ! IM
+  REAL (KIND=8) plwup(kdlon, kflev+1) ! LW up total sky
+  REAL (KIND=8) plwup0(kdlon, kflev+1) ! LW up clear sky
+  REAL (KIND=8) plwdn(kdlon, kflev+1) ! LW down total sky
+  REAL (KIND=8) plwdn0(kdlon, kflev+1) ! LW down clear sky
+  ! -------------------------------------------------------------------------
+  REAL (KIND=8) zabcu(kdlon, nua, 3*kflev+1)
+
+  REAL (KIND=8) zoz(kdlon, kflev)
+  ! equivalent pressure of ozone in a layer, in Pa
+
+  ! ym      REAL(KIND=8) ZFLUX(KDLON,2,KFLEV+1) ! RADIATIVE FLUXES (1:up;
+  ! 2:down)
+  ! ym      REAL(KIND=8) ZFLUC(KDLON,2,KFLEV+1) ! CLEAR-SKY RADIATIVE FLUXES
+  ! ym      REAL(KIND=8) ZBINT(KDLON,KFLEV+1)            ! Intermediate
+  ! variable
+  ! ym      REAL(KIND=8) ZBSUI(KDLON)                    ! Intermediate
+  ! variable
+  ! ym      REAL(KIND=8) ZCTS(KDLON,KFLEV)               ! Intermediate
+  ! variable
+  ! ym      REAL(KIND=8) ZCNTRB(KDLON,KFLEV+1,KFLEV+1)   ! Intermediate
+  ! variable
+  ! ym      SAVE ZFLUX, ZFLUC, ZBINT, ZBSUI, ZCTS, ZCNTRB
+  REAL (KIND=8), ALLOCATABLE, SAVE :: zflux(:, :, :) ! RADIATIVE FLUXES (1:up; 2:down)
+  REAL (KIND=8), ALLOCATABLE, SAVE :: zfluc(:, :, :) ! CLEAR-SKY RADIATIVE FLUXES
+  REAL (KIND=8), ALLOCATABLE, SAVE :: zbint(:, :) ! Intermediate variable
+  REAL (KIND=8), ALLOCATABLE, SAVE :: zbsui(:) ! Intermediate variable
+  REAL (KIND=8), ALLOCATABLE, SAVE :: zcts(:, :) ! Intermediate variable
+  REAL (KIND=8), ALLOCATABLE, SAVE :: zcntrb(:, :, :) ! Intermediate variable
+  !$OMP THREADPRIVATE(ZFLUX, ZFLUC, ZBINT, ZBSUI, ZCTS, ZCNTRB)
+
+  INTEGER ilim, i, k, kpl1
+
+  INTEGER lw0pas ! Every lw0pas steps, clear-sky is done
+  PARAMETER (lw0pas=1)
+  INTEGER lwpas ! Every lwpas steps, cloudy-sky is done
+  PARAMETER (lwpas=1)
+
+  INTEGER itaplw0, itaplw
+  LOGICAL appel1er
+  SAVE appel1er, itaplw0, itaplw
+  !$OMP THREADPRIVATE(appel1er, itaplw0, itaplw)
+  DATA appel1er/.TRUE./
+  DATA itaplw0, itaplw/0, 0/
+
+  ! ------------------------------------------------------------------
+  IF (appel1er) THEN
+    WRITE (lunout, *) 'LW clear-sky calling frequency: ', lw0pas
+    WRITE (lunout, *) 'LW cloudy-sky calling frequency: ', lwpas
+    WRITE (lunout, *) '   In general, they should be 1'
+    ! ym
+    ALLOCATE (zflux(kdlon,2,kflev+1))
+    ALLOCATE (zfluc(kdlon,2,kflev+1))
+    ALLOCATE (zbint(kdlon,kflev+1))
+    ALLOCATE (zbsui(kdlon))
+    ALLOCATE (zcts(kdlon,kflev))
+    ALLOCATE (zcntrb(kdlon,kflev+1,kflev+1))
+    appel1er = .FALSE.
+  END IF
+
+  IF (mod(itaplw0,lw0pas)==0) THEN
+    ! Compute equivalent pressure of ozone from mass fraction:
+    DO k = 1, kflev
+      DO i = 1, kdlon
+        zoz(i, k) = pozon(i, k)*pdp(i, k)
+      END DO
+    END DO
+    ! IM ctes ds clesphys.h   CALL LWU(RCO2,RCH4, RN2O, RCFC11, RCFC12,
+    CALL lwu_lmdar4(paer, pdp, ppmb, ppsol, zoz, ptave, pview, pwv, zabcu)
+    CALL lwbv_lmdar4(ilim, pdp, pdt0, pemis, ppmb, ptl, ptave, zabcu, zfluc, &
+      zbint, zbsui, zcts, zcntrb)
+    itaplw0 = 0
+  END IF
+  itaplw0 = itaplw0 + 1
+
+  IF (mod(itaplw,lwpas)==0) THEN
+    CALL lwc_lmdar4(ilim, pcldld, pcldlu, pemis, zfluc, zbint, zbsui, zcts, &
+      zcntrb, zflux)
+    itaplw = 0
+  END IF
+  itaplw = itaplw + 1
+
+  DO k = 1, kflev
+    kpl1 = k + 1
+    DO i = 1, kdlon
+      pcolr(i, k) = zflux(i, 1, kpl1) + zflux(i, 2, kpl1) - zflux(i, 1, k) - &
+        zflux(i, 2, k)
+      pcolr(i, k) = pcolr(i, k)*rday*rg/rcpd/pdp(i, k)
+      pcolr0(i, k) = zfluc(i, 1, kpl1) + zfluc(i, 2, kpl1) - zfluc(i, 1, k) - &
+        zfluc(i, 2, k)
+      pcolr0(i, k) = pcolr0(i, k)*rday*rg/rcpd/pdp(i, k)
+    END DO
+  END DO
+  DO i = 1, kdlon
+    psollw(i) = -zflux(i, 1, 1) - zflux(i, 2, 1)
+    ptoplw(i) = zflux(i, 1, kflev+1) + zflux(i, 2, kflev+1)
+
+    psollw0(i) = -zfluc(i, 1, 1) - zfluc(i, 2, 1)
+    ptoplw0(i) = zfluc(i, 1, kflev+1) + zfluc(i, 2, kflev+1)
+    psollwdown(i) = -zflux(i, 2, 1)
+
+    ! IM attention aux signes !; LWtop >0, LWdn < 0
+    DO k = 1, kflev + 1
+      plwup(i, k) = zflux(i, 1, k)
+      plwup0(i, k) = zfluc(i, 1, k)
+      plwdn(i, k) = zflux(i, 2, k)
+      plwdn0(i, k) = zfluc(i, 2, k)
+    END DO
+  END DO
+  ! ------------------------------------------------------------------
+  RETURN
+END SUBROUTINE lw_lmdar4
+! IM ctes ds clesphys.h   SUBROUTINE LWU(RCO2, RCH4, RN2O, RCFC11, RCFC12,
+SUBROUTINE lwu_lmdar4(paer, pdp, ppmb, ppsol, poz, ptave, pview, pwv, pabcu)
+  USE dimphy
+  USE radiation_ar4_param, ONLY: tref, rt1, raer, at, bt, oct
+  USE infotrac_phy, ONLY: type_trac
+  USE lmdz_reprobus_wrappers, ONLY: rch42d, rn2o2d, rcfc112d, rcfc122d, ok_rtime2d
+  USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_REPROBUS
+
+  IMPLICIT NONE
+  include "raddimlw.h"
+  include "YOMCST.h"
+  include "radepsi.h"
+  include "radopt.h"
+
+  ! PURPOSE.
+  ! --------
+  ! COMPUTES ABSORBER AMOUNTS INCLUDING PRESSURE AND
+  ! TEMPERATURE EFFECTS
+
+  ! METHOD.
+  ! -------
+
+  ! 1. COMPUTES THE PRESSURE AND TEMPERATURE WEIGHTED AMOUNTS OF
+  ! ABSORBERS.
+
+
+  ! REFERENCE.
+  ! ----------
+
+  ! SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+  ! ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
+
+  ! AUTHOR.
+  ! -------
+  ! JEAN-JACQUES MORCRETTE  *ECMWF*
+
+  ! MODIFICATIONS.
+  ! --------------
+  ! ORIGINAL : 89-07-14
+  ! Voigt lines (loop 404 modified) - JJM & PhD - 01/96
+  ! -----------------------------------------------------------------------
+  ! * ARGUMENTS:
+  ! IM ctes ds clesphys.h
+  ! REAL(KIND=8) RCO2
+  ! REAL(KIND=8) RCH4, RN2O, RCFC11, RCFC12
+  include "clesphys.h"
+  REAL (KIND=8) paer(kdlon, kflev, 5)
+  REAL (KIND=8) pdp(kdlon, kflev)
+  REAL (KIND=8) ppmb(kdlon, kflev+1)
+  REAL (KIND=8) ppsol(kdlon)
+  REAL (KIND=8) poz(kdlon, kflev)
+  REAL (KIND=8) ptave(kdlon, kflev)
+  REAL (KIND=8) pview(kdlon)
+  REAL (KIND=8) pwv(kdlon, kflev)
+
+  REAL (KIND=8) pabcu(kdlon, nua, 3*kflev+1) ! EFFECTIVE ABSORBER AMOUNTS
+
+  ! -----------------------------------------------------------------------
+  ! * LOCAL VARIABLES:
+  REAL (KIND=8) zably(kdlon, nua, 3*kflev+1)
+  REAL (KIND=8) zduc(kdlon, 3*kflev+1)
+  REAL (KIND=8) zphio(kdlon)
+  REAL (KIND=8) zpsc2(kdlon)
+  REAL (KIND=8) zpsc3(kdlon)
+  REAL (KIND=8) zpsh1(kdlon)
+  REAL (KIND=8) zpsh2(kdlon)
+  REAL (KIND=8) zpsh3(kdlon)
+  REAL (KIND=8) zpsh4(kdlon)
+  REAL (KIND=8) zpsh5(kdlon)
+  REAL (KIND=8) zpsh6(kdlon)
+  REAL (KIND=8) zpsio(kdlon)
+  REAL (KIND=8) ztcon(kdlon)
+  REAL (KIND=8) zphm6(kdlon)
+  REAL (KIND=8) zpsm6(kdlon)
+  REAL (KIND=8) zphn6(kdlon)
+  REAL (KIND=8) zpsn6(kdlon)
+  REAL (KIND=8) zssig(kdlon, 3*kflev+1)
+  REAL (KIND=8) ztavi(kdlon)
+  REAL (KIND=8) zuaer(kdlon, ninter)
+  REAL (KIND=8) zxoz(kdlon)
+  REAL (KIND=8) zxwv(kdlon)
+
+  INTEGER jl, jk, jkj, jkjr, jkjp, ig1
+  INTEGER jki, jkip1, ja, jj
+  INTEGER jkl, jkp1, jkk, jkjpn
+  INTEGER jae1, jae2, jae3, jae, jjpn
+  INTEGER ir, jc, jcp1
+  REAL (KIND=8) zdpm, zupm, zupmh2o, zupmco2, zupmo3, zu6, zup
+  REAL (KIND=8) zfppw, ztx, ztx2, zzably
+  REAL (KIND=8) zcah1, zcbh1, zcah2, zcbh2, zcah3, zcbh3
+  REAL (KIND=8) zcah4, zcbh4, zcah5, zcbh5, zcah6, zcbh6
+  REAL (KIND=8) zcac8, zcbc8
+  REAL (KIND=8) zalup, zdiff
+
+  REAL (KIND=8) pvgco2, pvgh2o, pvgo3
+
+  REAL (KIND=8) r10e ! DECIMAL/NATURAL LOG.FACTOR
+  PARAMETER (r10e=0.4342945)
+
+  ! -----------------------------------------------------------------------
+
+  IF (levoigt) THEN
+    pvgco2 = 60.
+    pvgh2o = 30.
+    pvgo3 = 400.
+  ELSE
+    pvgco2 = 0.
+    pvgh2o = 0.
+    pvgo3 = 0.
+  END IF
+
+  ! *         2.    PRESSURE OVER GAUSS SUB-LEVELS
+  ! ------------------------------
+
+
+  DO jl = 1, kdlon
+    zssig(jl, 1) = ppmb(jl, 1)*100.
+  END DO
+
+  DO jk = 1, kflev
+    jkj = (jk-1)*ng1p1 + 1
+    jkjr = jkj
+    jkjp = jkj + ng1p1
+    DO jl = 1, kdlon
+      zssig(jl, jkjp) = ppmb(jl, jk+1)*100.
+    END DO
+    DO ig1 = 1, ng1
+      jkj = jkj + 1
+      DO jl = 1, kdlon
+        zssig(jl, jkj) = (zssig(jl,jkjr)+zssig(jl,jkjp))*0.5 + &
+          rt1(ig1)*(zssig(jl,jkjp)-zssig(jl,jkjr))*0.5
+      END DO
+    END DO
+  END DO
+
+  ! -----------------------------------------------------------------------
+
+
+  ! *         4.    PRESSURE THICKNESS AND MEAN PRESSURE OF SUB-LAYERS
+  ! --------------------------------------------------
+
+
+  DO jki = 1, 3*kflev
+    jkip1 = jki + 1
+    DO jl = 1, kdlon
+      zably(jl, 5, jki) = (zssig(jl,jki)+zssig(jl,jkip1))*0.5
+      zably(jl, 3, jki) = (zssig(jl,jki)-zssig(jl,jkip1))/(10.*rg)
+    END DO
+  END DO
+
+  DO jk = 1, kflev
+    jkp1 = jk + 1
+    jkl = kflev + 1 - jk
+    DO jl = 1, kdlon
+      zxwv(jl) = max(pwv(jl,jk), zepscq)
+      zxoz(jl) = max(poz(jl,jk)/pdp(jl,jk), zepsco)
+    END DO
+    jkj = (jk-1)*ng1p1 + 1
+    jkjpn = jkj + ng1
+    DO jkk = jkj, jkjpn
+      DO jl = 1, kdlon
+        zdpm = zably(jl, 3, jkk)
+        zupm = zably(jl, 5, jkk)*zdpm/101325.
+        zupmco2 = (zably(jl,5,jkk)+pvgco2)*zdpm/101325.
+        zupmh2o = (zably(jl,5,jkk)+pvgh2o)*zdpm/101325.
+        zupmo3 = (zably(jl,5,jkk)+pvgo3)*zdpm/101325.
+        zduc(jl, jkk) = zdpm
+        zably(jl, 12, jkk) = zxoz(jl)*zdpm
+        zably(jl, 13, jkk) = zxoz(jl)*zupmo3
+        zu6 = zxwv(jl)*zupm
+        zfppw = 1.6078*zxwv(jl)/(1.+0.608*zxwv(jl))
+        zably(jl, 6, jkk) = zxwv(jl)*zupmh2o
+        zably(jl, 11, jkk) = zu6*zfppw
+        zably(jl, 10, jkk) = zu6*(1.-zfppw)
+        zably(jl, 9, jkk) = rco2*zupmco2
+        zably(jl, 8, jkk) = rco2*zdpm
+      END DO
+    END DO
+  END DO
+
+  ! -----------------------------------------------------------------------
+
+
+  ! *         5.    CUMULATIVE ABSORBER AMOUNTS FROM TOP OF ATMOSPHERE
+  ! --------------------------------------------------
+
+
+  DO ja = 1, nua
+    DO jl = 1, kdlon
+      pabcu(jl, ja, 3*kflev+1) = 0.
+    END DO
+  END DO
+
+  DO jk = 1, kflev
+    jj = (jk-1)*ng1p1 + 1
+    jjpn = jj + ng1
+    jkl = kflev + 1 - jk
+
+    ! *         5.1  CUMULATIVE AEROSOL AMOUNTS FROM TOP OF ATMOSPHERE
+    ! --------------------------------------------------
+
+
+    jae1 = 3*kflev + 1 - jj
+    jae2 = 3*kflev + 1 - (jj+1)
+    jae3 = 3*kflev + 1 - jjpn
+    DO jae = 1, 5
+      DO jl = 1, kdlon
+        zuaer(jl, jae) = (raer(jae,1)*paer(jl,jkl,1)+raer(jae,2)*paer(jl,jkl, &
+          2)+raer(jae,3)*paer(jl,jkl,3)+raer(jae,4)*paer(jl,jkl,4)+ &
+          raer(jae,5)*paer(jl,jkl,5))/(zduc(jl,jae1)+zduc(jl,jae2)+zduc(jl, &
+          jae3))
+      END DO
+    END DO
+
+    ! *         5.2  INTRODUCES TEMPERATURE EFFECTS ON ABSORBER AMOUNTS
+    ! --------------------------------------------------
+
+
+    DO jl = 1, kdlon
+      ztavi(jl) = ptave(jl, jkl)
+      ztcon(jl) = exp(6.08*(296./ztavi(jl)-1.))
+      ztx = ztavi(jl) - tref
+      ztx2 = ztx*ztx
+      zzably = zably(jl, 6, jae1) + zably(jl, 6, jae2) + zably(jl, 6, jae3)
+      zup = min(max(0.5*r10e*log(zzably)+5.,0._8), 6._8)
+      zcah1 = at(1, 1) + zup*(at(1,2)+zup*(at(1,3)))
+      zcbh1 = bt(1, 1) + zup*(bt(1,2)+zup*(bt(1,3)))
+      zpsh1(jl) = exp(zcah1*ztx+zcbh1*ztx2)
+      zcah2 = at(2, 1) + zup*(at(2,2)+zup*(at(2,3)))
+      zcbh2 = bt(2, 1) + zup*(bt(2,2)+zup*(bt(2,3)))
+      zpsh2(jl) = exp(zcah2*ztx+zcbh2*ztx2)
+      zcah3 = at(3, 1) + zup*(at(3,2)+zup*(at(3,3)))
+      zcbh3 = bt(3, 1) + zup*(bt(3,2)+zup*(bt(3,3)))
+      zpsh3(jl) = exp(zcah3*ztx+zcbh3*ztx2)
+      zcah4 = at(4, 1) + zup*(at(4,2)+zup*(at(4,3)))
+      zcbh4 = bt(4, 1) + zup*(bt(4,2)+zup*(bt(4,3)))
+      zpsh4(jl) = exp(zcah4*ztx+zcbh4*ztx2)
+      zcah5 = at(5, 1) + zup*(at(5,2)+zup*(at(5,3)))
+      zcbh5 = bt(5, 1) + zup*(bt(5,2)+zup*(bt(5,3)))
+      zpsh5(jl) = exp(zcah5*ztx+zcbh5*ztx2)
+      zcah6 = at(6, 1) + zup*(at(6,2)+zup*(at(6,3)))
+      zcbh6 = bt(6, 1) + zup*(bt(6,2)+zup*(bt(6,3)))
+      zpsh6(jl) = exp(zcah6*ztx+zcbh6*ztx2)
+      zphm6(jl) = exp(-5.81E-4*ztx-1.13E-6*ztx2)
+      zpsm6(jl) = exp(-5.57E-4*ztx-3.30E-6*ztx2)
+      zphn6(jl) = exp(-3.46E-5*ztx+2.05E-7*ztx2)
+      zpsn6(jl) = exp(3.70E-3*ztx-2.30E-6*ztx2)
+    END DO
+
+    DO jl = 1, kdlon
+      ztavi(jl) = ptave(jl, jkl)
+      ztx = ztavi(jl) - tref
+      ztx2 = ztx*ztx
+      zzably = zably(jl, 9, jae1) + zably(jl, 9, jae2) + zably(jl, 9, jae3)
+      zalup = r10e*log(zzably)
+      zup = max(0._8, 5.0+0.5*zalup)
+      zpsc2(jl) = (ztavi(jl)/tref)**zup
+      zcac8 = at(8, 1) + zup*(at(8,2)+zup*(at(8,3)))
+      zcbc8 = bt(8, 1) + zup*(bt(8,2)+zup*(bt(8,3)))
+      zpsc3(jl) = exp(zcac8*ztx+zcbc8*ztx2)
+      zphio(jl) = exp(oct(1)*ztx+oct(2)*ztx2)
+      zpsio(jl) = exp(2.*(oct(3)*ztx+oct(4)*ztx2))
+    END DO
+
+    DO jkk = jj, jjpn
+      jc = 3*kflev + 1 - jkk
+      jcp1 = jc + 1
+      DO jl = 1, kdlon
+        zdiff = pview(jl)
+        pabcu(jl, 10, jc) = pabcu(jl, 10, jcp1) + zably(jl, 10, jc)*zdiff
+        pabcu(jl, 11, jc) = pabcu(jl, 11, jcp1) + zably(jl, 11, jc)*ztcon(jl) &
+          *zdiff
+
+        pabcu(jl, 12, jc) = pabcu(jl, 12, jcp1) + zably(jl, 12, jc)*zphio(jl) &
+          *zdiff
+        pabcu(jl, 13, jc) = pabcu(jl, 13, jcp1) + zably(jl, 13, jc)*zpsio(jl) &
+          *zdiff
+
+        pabcu(jl, 7, jc) = pabcu(jl, 7, jcp1) + zably(jl, 9, jc)*zpsc2(jl)* &
+          zdiff
+        pabcu(jl, 8, jc) = pabcu(jl, 8, jcp1) + zably(jl, 9, jc)*zpsc3(jl)* &
+          zdiff
+        pabcu(jl, 9, jc) = pabcu(jl, 9, jcp1) + zably(jl, 9, jc)*zpsc3(jl)* &
+          zdiff
+
+        pabcu(jl, 1, jc) = pabcu(jl, 1, jcp1) + zably(jl, 6, jc)*zpsh1(jl)* &
+          zdiff
+        pabcu(jl, 2, jc) = pabcu(jl, 2, jcp1) + zably(jl, 6, jc)*zpsh2(jl)* &
+          zdiff
+        pabcu(jl, 3, jc) = pabcu(jl, 3, jcp1) + zably(jl, 6, jc)*zpsh5(jl)* &
+          zdiff
+        pabcu(jl, 4, jc) = pabcu(jl, 4, jcp1) + zably(jl, 6, jc)*zpsh3(jl)* &
+          zdiff
+        pabcu(jl, 5, jc) = pabcu(jl, 5, jcp1) + zably(jl, 6, jc)*zpsh4(jl)* &
+          zdiff
+        pabcu(jl, 6, jc) = pabcu(jl, 6, jcp1) + zably(jl, 6, jc)*zpsh6(jl)* &
+          zdiff
+
+        pabcu(jl, 14, jc) = pabcu(jl, 14, jcp1) + zuaer(jl, 1)*zduc(jl, jc)* &
+          zdiff
+        pabcu(jl, 15, jc) = pabcu(jl, 15, jcp1) + zuaer(jl, 2)*zduc(jl, jc)* &
+          zdiff
+        pabcu(jl, 16, jc) = pabcu(jl, 16, jcp1) + zuaer(jl, 3)*zduc(jl, jc)* &
+          zdiff
+        pabcu(jl, 17, jc) = pabcu(jl, 17, jcp1) + zuaer(jl, 4)*zduc(jl, jc)* &
+          zdiff
+        pabcu(jl, 18, jc) = pabcu(jl, 18, jcp1) + zuaer(jl, 5)*zduc(jl, jc)* &
+          zdiff
+
+
+
+        IF (type_trac=='repr') THEN
+IF (CPPKEY_REPROBUS) THEN
+          IF (ok_rtime2d) THEN
+            pabcu(jl, 19, jc) = pabcu(jl, 19, jcp1) + &
+              zably(jl, 8, jc)*rch42d(jl, jc)/rco2*zphm6(jl)*zdiff
+            pabcu(jl, 20, jc) = pabcu(jl, 20, jcp1) + &
+              zably(jl, 9, jc)*rch42d(jl, jc)/rco2*zpsm6(jl)*zdiff
+            pabcu(jl, 21, jc) = pabcu(jl, 21, jcp1) + &
+              zably(jl, 8, jc)*rn2o2d(jl, jc)/rco2*zphn6(jl)*zdiff
+            pabcu(jl, 22, jc) = pabcu(jl, 22, jcp1) + &
+              zably(jl, 9, jc)*rn2o2d(jl, jc)/rco2*zpsn6(jl)*zdiff
+
+            pabcu(jl, 23, jc) = pabcu(jl, 23, jcp1) + &
+              zably(jl, 8, jc)*rcfc112d(jl, jc)/rco2*zdiff
+            pabcu(jl, 24, jc) = pabcu(jl, 24, jcp1) + &
+              zably(jl, 8, jc)*rcfc122d(jl, jc)/rco2*zdiff
+          ELSE
+              ! Same calculation as for type_trac /= repr
+            pabcu(jl, 19, jc) = pabcu(jl, 19, jcp1) + &
+              zably(jl, 8, jc)*rch4/rco2*zphm6(jl)*zdiff
+            pabcu(jl, 20, jc) = pabcu(jl, 20, jcp1) + &
+              zably(jl, 9, jc)*rch4/rco2*zpsm6(jl)*zdiff
+            pabcu(jl, 21, jc) = pabcu(jl, 21, jcp1) + &
+              zably(jl, 8, jc)*rn2o/rco2*zphn6(jl)*zdiff
+            pabcu(jl, 22, jc) = pabcu(jl, 22, jcp1) + &
+              zably(jl, 9, jc)*rn2o/rco2*zpsn6(jl)*zdiff
+
+            pabcu(jl, 23, jc) = pabcu(jl, 23, jcp1) + &
+              zably(jl, 8, jc)*rcfc11/rco2*zdiff
+            pabcu(jl, 24, jc) = pabcu(jl, 24, jcp1) + &
+              zably(jl, 8, jc)*rcfc12/rco2*zdiff
+          END IF
+END IF
+        ELSE
+          pabcu(jl, 19, jc) = pabcu(jl, 19, jcp1) + &
+            zably(jl, 8, jc)*rch4/rco2*zphm6(jl)*zdiff
+          pabcu(jl, 20, jc) = pabcu(jl, 20, jcp1) + &
+            zably(jl, 9, jc)*rch4/rco2*zpsm6(jl)*zdiff
+          pabcu(jl, 21, jc) = pabcu(jl, 21, jcp1) + &
+            zably(jl, 8, jc)*rn2o/rco2*zphn6(jl)*zdiff
+          pabcu(jl, 22, jc) = pabcu(jl, 22, jcp1) + &
+            zably(jl, 9, jc)*rn2o/rco2*zpsn6(jl)*zdiff
+
+          pabcu(jl, 23, jc) = pabcu(jl, 23, jcp1) + &
+            zably(jl, 8, jc)*rcfc11/rco2*zdiff
+          pabcu(jl, 24, jc) = pabcu(jl, 24, jcp1) + &
+            zably(jl, 8, jc)*rcfc12/rco2*zdiff
+        END IF
+
+      END DO
+    END DO
+
+  END DO
+
+
+  RETURN
+END SUBROUTINE lwu_lmdar4
+SUBROUTINE lwbv_lmdar4(klim, pdp, pdt0, pemis, ppmb, ptl, ptave, pabcu, &
+    pfluc, pbint, pbsui, pcts, pcntrb)
+  USE dimphy
+  IMPLICIT NONE
+  include "raddimlw.h"
+  include "YOMCST.h"
+
+  ! PURPOSE.
+  ! --------
+  ! TO COMPUTE THE PLANCK FUNCTION AND PERFORM THE
+  ! VERTICAL INTEGRATION. SPLIT OUT FROM LW FOR MEMORY
+  ! SAVING
+
+  ! METHOD.
+  ! -------
+
+  ! 1. COMPUTES THE PLANCK FUNCTIONS ON THE INTERFACES AND THE
+  ! GRADIENT OF PLANCK FUNCTIONS IN THE LAYERS.
+  ! 2. PERFORMS THE VERTICAL INTEGRATION DISTINGUISHING THE CON-
+  ! TRIBUTIONS OF THE ADJACENT AND DISTANT LAYERS AND THOSE FROM THE
+  ! BOUNDARIES.
+  ! 3. COMPUTES THE CLEAR-SKY COOLING RATES.
+
+  ! REFERENCE.
+  ! ----------
+
+  ! SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+  ! ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
+
+  ! AUTHOR.
+  ! -------
+  ! JEAN-JACQUES MORCRETTE  *ECMWF*
+
+  ! MODIFICATIONS.
+  ! --------------
+  ! ORIGINAL : 89-07-14
+  ! MODIFICATION : 93-10-15 M.HAMRUD (SPLIT OUT FROM LW TO SAVE
+  ! MEMORY)
+  ! -----------------------------------------------------------------------
+  ! * ARGUMENTS:
+  INTEGER klim
+
+  REAL (KIND=8) pdp(kdlon, kflev)
+  REAL (KIND=8) pdt0(kdlon)
+  REAL (KIND=8) pemis(kdlon)
+  REAL (KIND=8) ppmb(kdlon, kflev+1)
+  REAL (KIND=8) ptl(kdlon, kflev+1)
+  REAL (KIND=8) ptave(kdlon, kflev)
+
+  REAL (KIND=8) pfluc(kdlon, 2, kflev+1)
+
+  REAL (KIND=8) pabcu(kdlon, nua, 3*kflev+1)
+  REAL (KIND=8) pbint(kdlon, kflev+1)
+  REAL (KIND=8) pbsui(kdlon)
+  REAL (KIND=8) pcts(kdlon, kflev)
+  REAL (KIND=8) pcntrb(kdlon, kflev+1, kflev+1)
+
+  ! -------------------------------------------------------------------------
+
+  ! * LOCAL VARIABLES:
+  REAL (KIND=8) zb(kdlon, ninter, kflev+1)
+  REAL (KIND=8) zbsur(kdlon, ninter)
+  REAL (KIND=8) zbtop(kdlon, ninter)
+  REAL (KIND=8) zdbsl(kdlon, ninter, kflev*2)
+  REAL (KIND=8) zga(kdlon, 8, 2, kflev)
+  REAL (KIND=8) zgb(kdlon, 8, 2, kflev)
+  REAL (KIND=8) zgasur(kdlon, 8, 2)
+  REAL (KIND=8) zgbsur(kdlon, 8, 2)
+  REAL (KIND=8) zgatop(kdlon, 8, 2)
+  REAL (KIND=8) zgbtop(kdlon, 8, 2)
+
+  INTEGER nuaer, ntraer
+  ! ------------------------------------------------------------------
+  ! * COMPUTES PLANCK FUNCTIONS:
+  CALL lwb_lmdar4(pdt0, ptave, ptl, zb, pbint, pbsui, zbsur, zbtop, zdbsl, &
+    zga, zgb, zgasur, zgbsur, zgatop, zgbtop)
+  ! ------------------------------------------------------------------
+  ! * PERFORMS THE VERTICAL INTEGRATION:
+  nuaer = nua
+  ntraer = ntra
+  CALL lwv_lmdar4(nuaer, ntraer, klim, pabcu, zb, pbint, pbsui, zbsur, zbtop, &
+    zdbsl, pemis, ppmb, ptave, zga, zgb, zgasur, zgbsur, zgatop, zgbtop, &
+    pcntrb, pcts, pfluc)
+  ! ------------------------------------------------------------------
+  RETURN
+END SUBROUTINE lwbv_lmdar4
+SUBROUTINE lwc_lmdar4(klim, pcldld, pcldlu, pemis, pfluc, pbint, pbsuin, &
+    pcts, pcntrb, pflux)
+  USE dimphy
+  IMPLICIT NONE
+  include "radepsi.h"
+  include "radopt.h"
+
+  ! PURPOSE.
+  ! --------
+  ! INTRODUCES CLOUD EFFECTS ON LONGWAVE FLUXES OR
+  ! RADIANCES
+
+  ! EXPLICIT ARGUMENTS :
+  ! --------------------
+  ! ==== INPUTS ===
+  ! PBINT  : (KDLON,0:KFLEV)     ; HALF LEVEL PLANCK FUNCTION
+  ! PBSUIN : (KDLON)             ; SURFACE PLANCK FUNCTION
+  ! PCLDLD : (KDLON,KFLEV)       ; DOWNWARD EFFECTIVE CLOUD FRACTION
+  ! PCLDLU : (KDLON,KFLEV)       ; UPWARD EFFECTIVE CLOUD FRACTION
+  ! PCNTRB : (KDLON,KFLEV+1,KFLEV+1); CLEAR-SKY ENERGY EXCHANGE
+  ! PCTS   : (KDLON,KFLEV)       ; CLEAR-SKY LAYER COOLING-TO-SPACE
+  ! PEMIS  : (KDLON)             ; SURFACE EMISSIVITY
+  ! PFLUC
+  ! ==== OUTPUTS ===
+  ! PFLUX(KDLON,2,KFLEV)         ; RADIATIVE FLUXES :
+  ! 1  ==>  UPWARD   FLUX TOTAL
+  ! 2  ==>  DOWNWARD FLUX TOTAL
+
+  ! METHOD.
+  ! -------
+
+  ! 1. INITIALIZES ALL FLUXES TO CLEAR-SKY VALUES
+  ! 2. EFFECT OF ONE OVERCAST UNITY EMISSIVITY CLOUD LAYER
+  ! 3. EFFECT OF SEMI-TRANSPARENT, PARTIAL OR MULTI-LAYERED
+  ! CLOUDS
+
+  ! REFERENCE.
+  ! ----------
+
+  ! SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+  ! ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
+
+  ! AUTHOR.
+  ! -------
+  ! JEAN-JACQUES MORCRETTE  *ECMWF*
+
+  ! MODIFICATIONS.
+  ! --------------
+  ! ORIGINAL : 89-07-14
+  ! Voigt lines (loop 231 to 233)  - JJM & PhD - 01/96
+  ! -----------------------------------------------------------------------
+  ! * ARGUMENTS:
+  INTEGER klim
+  REAL (KIND=8) pfluc(kdlon, 2, kflev+1) ! CLEAR-SKY RADIATIVE FLUXES
+  REAL (KIND=8) pbint(kdlon, kflev+1) ! HALF LEVEL PLANCK FUNCTION
+  REAL (KIND=8) pbsuin(kdlon) ! SURFACE PLANCK FUNCTION
+  REAL (KIND=8) pcntrb(kdlon, kflev+1, kflev+1) !CLEAR-SKY ENERGY EXCHANGE
+  REAL (KIND=8) pcts(kdlon, kflev) ! CLEAR-SKY LAYER COOLING-TO-SPACE
+
+  REAL (KIND=8) pcldld(kdlon, kflev)
+  REAL (KIND=8) pcldlu(kdlon, kflev)
+  REAL (KIND=8) pemis(kdlon)
+
+  REAL (KIND=8) pflux(kdlon, 2, kflev+1)
+  ! -----------------------------------------------------------------------
+  ! * LOCAL VARIABLES:
+  INTEGER imx(kdlon), imxp(kdlon)
+
+  REAL (KIND=8) zclear(kdlon), zcloud(kdlon), zdnf(kdlon, kflev+1, kflev+1), &
+    zfd(kdlon), zfn10(kdlon), zfu(kdlon), zupf(kdlon, kflev+1, kflev+1)
+  REAL (KIND=8) zclm(kdlon, kflev+1, kflev+1)
+
+  INTEGER jk, jl, imaxc, imx1, imx2, jkj, jkp1, jkm1
+  INTEGER jk1, jk2, jkc, jkcp1, jcloud
+  INTEGER imxm1, imxp1
+  REAL (KIND=8) zcfrac
+
+  ! ------------------------------------------------------------------
+
+  ! *         1.     INITIALIZATION
+  ! --------------
+
+
+  imaxc = 0
+
+  DO jl = 1, kdlon
+    imx(jl) = 0
+    imxp(jl) = 0
+    zcloud(jl) = 0.
+  END DO
+
+  ! *         1.1    SEARCH THE LAYER INDEX OF THE HIGHEST CLOUD
+  ! -------------------------------------------
+
+
+  DO jk = 1, kflev
+    DO jl = 1, kdlon
+      imx1 = imx(jl)
+      imx2 = jk
+      IF (pcldlu(jl,jk)>zepsc) THEN
+        imxp(jl) = imx2
+      ELSE
+        imxp(jl) = imx1
+      END IF
+      imaxc = max(imxp(jl), imaxc)
+      imx(jl) = imxp(jl)
+    END DO
+  END DO
+  ! GM*******
+  imaxc = kflev
+  ! GM*******
+
+  DO jk = 1, kflev + 1
+    DO jl = 1, kdlon
+      pflux(jl, 1, jk) = pfluc(jl, 1, jk)
+      pflux(jl, 2, jk) = pfluc(jl, 2, jk)
+    END DO
+  END DO
+
+  ! ------------------------------------------------------------------
+
+  ! *         2.      EFFECT OF CLOUDINESS ON LONGWAVE FLUXES
+  ! ---------------------------------------
+
+  IF (imaxc>0) THEN
+
+    imxp1 = imaxc + 1
+    imxm1 = imaxc - 1
+
+    ! *         2.0     INITIALIZE TO CLEAR-SKY FLUXES
+    ! ------------------------------
+
+
+    DO jk1 = 1, kflev + 1
+      DO jk2 = 1, kflev + 1
+        DO jl = 1, kdlon
+          zupf(jl, jk2, jk1) = pfluc(jl, 1, jk1)
+          zdnf(jl, jk2, jk1) = pfluc(jl, 2, jk1)
+        END DO
+      END DO
+    END DO
+
+    ! *         2.1     FLUXES FOR ONE OVERCAST UNITY EMISSIVITY CLOUD
+    ! ----------------------------------------------
+
+
+    DO jkc = 1, imaxc
+      jcloud = jkc
+      jkcp1 = jcloud + 1
+
+      ! *         2.1.1   ABOVE THE CLOUD
+      ! ---------------
+
+
+      DO jk = jkcp1, kflev + 1
+        jkm1 = jk - 1
+        DO jl = 1, kdlon
+          zfu(jl) = 0.
+        END DO
+        IF (jk>jkcp1) THEN
+          DO jkj = jkcp1, jkm1
+            DO jl = 1, kdlon
+              zfu(jl) = zfu(jl) + pcntrb(jl, jk, jkj)
+            END DO
+          END DO
+        END IF
+
+        DO jl = 1, kdlon
+          zupf(jl, jkcp1, jk) = pbint(jl, jk) - zfu(jl)
+        END DO
+      END DO
+
+      ! *         2.1.2   BELOW THE CLOUD
+      ! ---------------
+
+
+      DO jk = 1, jcloud
+        jkp1 = jk + 1
+        DO jl = 1, kdlon
+          zfd(jl) = 0.
+        END DO
+
+        IF (jk<jcloud) THEN
+          DO jkj = jkp1, jcloud
+            DO jl = 1, kdlon
+              zfd(jl) = zfd(jl) + pcntrb(jl, jk, jkj)
+            END DO
+          END DO
+        END IF
+        DO jl = 1, kdlon
+          zdnf(jl, jkcp1, jk) = -pbint(jl, jk) - zfd(jl)
+        END DO
+      END DO
+
+    END DO
+
+    ! *         2.2     CLOUD COVER MATRIX
+    ! ------------------
+
+    ! *    ZCLM(JK1,JK2) IS THE OBSCURATION FACTOR BY CLOUD LAYERS BETWEEN
+    ! HALF-LEVELS JK1 AND JK2 AS SEEN FROM JK1
+
+
+    DO jk1 = 1, kflev + 1
+      DO jk2 = 1, kflev + 1
+        DO jl = 1, kdlon
+          zclm(jl, jk1, jk2) = 0.
+        END DO
+      END DO
+    END DO
+
+    ! *         2.4     CLOUD COVER BELOW THE LEVEL OF CALCULATION
+    ! ------------------------------------------
+
+
+    DO jk1 = 2, kflev + 1
+      DO jl = 1, kdlon
+        zclear(jl) = 1.
+        zcloud(jl) = 0.
+      END DO
+      DO jk = jk1 - 1, 1, -1
+        DO jl = 1, kdlon
+          IF (novlp==1) THEN
+            ! * maximum-random
+            zclear(jl) = zclear(jl)*(1.0-max(pcldlu(jl, &
+              jk),zcloud(jl)))/(1.0-min(zcloud(jl),1.-zepsec))
+            zclm(jl, jk1, jk) = 1.0 - zclear(jl)
+            zcloud(jl) = pcldlu(jl, jk)
+          ELSE IF (novlp==2) THEN
+            ! * maximum
+            zcloud(jl) = max(zcloud(jl), pcldlu(jl,jk))
+            zclm(jl, jk1, jk) = zcloud(jl)
+          ELSE IF (novlp==3) THEN
+            ! * random
+            zclear(jl) = zclear(jl)*(1.0-pcldlu(jl,jk))
+            zcloud(jl) = 1.0 - zclear(jl)
+            zclm(jl, jk1, jk) = zcloud(jl)
+          END IF
+        END DO
+      END DO
+    END DO
+
+    ! *         2.5     CLOUD COVER ABOVE THE LEVEL OF CALCULATION
+    ! ------------------------------------------
+
+
+    DO jk1 = 1, kflev
+      DO jl = 1, kdlon
+        zclear(jl) = 1.
+        zcloud(jl) = 0.
+      END DO
+      DO jk = jk1, kflev
+        DO jl = 1, kdlon
+          IF (novlp==1) THEN
+            ! * maximum-random
+            zclear(jl) = zclear(jl)*(1.0-max(pcldld(jl, &
+              jk),zcloud(jl)))/(1.0-min(zcloud(jl),1.-zepsec))
+            zclm(jl, jk1, jk) = 1.0 - zclear(jl)
+            zcloud(jl) = pcldld(jl, jk)
+          ELSE IF (novlp==2) THEN
+            ! * maximum
+            zcloud(jl) = max(zcloud(jl), pcldld(jl,jk))
+            zclm(jl, jk1, jk) = zcloud(jl)
+          ELSE IF (novlp==3) THEN
+            ! * random
+            zclear(jl) = zclear(jl)*(1.0-pcldld(jl,jk))
+            zcloud(jl) = 1.0 - zclear(jl)
+            zclm(jl, jk1, jk) = zcloud(jl)
+          END IF
+        END DO
+      END DO
+    END DO
+
+    ! *         3.      FLUXES FOR PARTIAL/MULTIPLE LAYERED CLOUDINESS
+    ! ----------------------------------------------
+
+
+    ! *         3.1     DOWNWARD FLUXES
+    ! ---------------
+
+
+    DO jl = 1, kdlon
+      pflux(jl, 2, kflev+1) = 0.
+    END DO
+
+    DO jk1 = kflev, 1, -1
+
+      ! *                 CONTRIBUTION FROM CLEAR-SKY FRACTION
+
+      DO jl = 1, kdlon
+        zfd(jl) = (1.-zclm(jl,jk1,kflev))*zdnf(jl, 1, jk1)
+      END DO
+
+      ! *                 CONTRIBUTION FROM ADJACENT CLOUD
+
+      DO jl = 1, kdlon
+        zfd(jl) = zfd(jl) + zclm(jl, jk1, jk1)*zdnf(jl, jk1+1, jk1)
+      END DO
+
+      ! *                 CONTRIBUTION FROM OTHER CLOUDY FRACTIONS
+
+      DO jk = kflev - 1, jk1, -1
+        DO jl = 1, kdlon
+          zcfrac = zclm(jl, jk1, jk+1) - zclm(jl, jk1, jk)
+          zfd(jl) = zfd(jl) + zcfrac*zdnf(jl, jk+2, jk1)
+        END DO
+      END DO
+
+      DO jl = 1, kdlon
+        pflux(jl, 2, jk1) = zfd(jl)
+      END DO
+
+    END DO
+
+    ! *         3.2     UPWARD FLUX AT THE SURFACE
+    ! --------------------------
+
+
+    DO jl = 1, kdlon
+      pflux(jl, 1, 1) = pemis(jl)*pbsuin(jl) - (1.-pemis(jl))*pflux(jl, 2, 1)
+    END DO
+
+    ! *         3.3     UPWARD FLUXES
+    ! -------------
+
+
+    DO jk1 = 2, kflev + 1
+
+      ! *                 CONTRIBUTION FROM CLEAR-SKY FRACTION
+
+      DO jl = 1, kdlon
+        zfu(jl) = (1.-zclm(jl,jk1,1))*zupf(jl, 1, jk1)
+      END DO
+
+      ! *                 CONTRIBUTION FROM ADJACENT CLOUD
+
+      DO jl = 1, kdlon
+        zfu(jl) = zfu(jl) + zclm(jl, jk1, jk1-1)*zupf(jl, jk1, jk1)
+      END DO
+
+      ! *                 CONTRIBUTION FROM OTHER CLOUDY FRACTIONS
+
+      DO jk = 2, jk1 - 1
+        DO jl = 1, kdlon
+          zcfrac = zclm(jl, jk1, jk-1) - zclm(jl, jk1, jk)
+          zfu(jl) = zfu(jl) + zcfrac*zupf(jl, jk, jk1)
+        END DO
+      END DO
+
+      DO jl = 1, kdlon
+        pflux(jl, 1, jk1) = zfu(jl)
+      END DO
+
+    END DO
+
+
+  END IF
+
+  ! *         2.3     END OF CLOUD EFFECT COMPUTATIONS
+
+
+  IF (.NOT. levoigt) THEN
+    DO jl = 1, kdlon
+      zfn10(jl) = pflux(jl, 1, klim) + pflux(jl, 2, klim)
+    END DO
+    DO jk = klim + 1, kflev + 1
+      DO jl = 1, kdlon
+        zfn10(jl) = zfn10(jl) + pcts(jl, jk-1)
+        pflux(jl, 1, jk) = zfn10(jl)
+        pflux(jl, 2, jk) = 0.0
+      END DO
+    END DO
+  END IF
+
+  RETURN
+END SUBROUTINE lwc_lmdar4
+SUBROUTINE lwb_lmdar4(pdt0, ptave, ptl, pb, pbint, pbsuin, pbsur, pbtop, &
+    pdbsl, pga, pgb, pgasur, pgbsur, pgatop, pgbtop)
+  USE dimphy
+  USE radiation_ar4_param, ONLY: tintp, xp, ga, gb
+  IMPLICIT NONE
+  include "raddimlw.h"
+
+  ! -----------------------------------------------------------------------
+  ! PURPOSE.
+  ! --------
+  ! COMPUTES PLANCK FUNCTIONS
+
+  ! EXPLICIT ARGUMENTS :
+  ! --------------------
+  ! ==== INPUTS ===
+  ! PDT0   : (KDLON)             ; SURFACE TEMPERATURE DISCONTINUITY
+  ! PTAVE  : (KDLON,KFLEV)       ; TEMPERATURE
+  ! PTL    : (KDLON,0:KFLEV)     ; HALF LEVEL TEMPERATURE
+  ! ==== OUTPUTS ===
+  ! PB     : (KDLON,Ninter,KFLEV+1); SPECTRAL HALF LEVEL PLANCK FUNCTION
+  ! PBINT  : (KDLON,KFLEV+1)     ; HALF LEVEL PLANCK FUNCTION
+  ! PBSUIN : (KDLON)             ; SURFACE PLANCK FUNCTION
+  ! PBSUR  : (KDLON,Ninter)        ; SURFACE SPECTRAL PLANCK FUNCTION
+  ! PBTOP  : (KDLON,Ninter)        ; TOP SPECTRAL PLANCK FUNCTION
+  ! PDBSL  : (KDLON,Ninter,KFLEV*2); SUB-LAYER PLANCK FUNCTION GRADIENT
+  ! PGA    : (KDLON,8,2,KFLEV); dB/dT-weighted LAYER PADE APPROXIMANTS
+  ! PGB    : (KDLON,8,2,KFLEV); dB/dT-weighted LAYER PADE APPROXIMANTS
+  ! PGASUR, PGBSUR (KDLON,8,2)   ; SURFACE PADE APPROXIMANTS
+  ! PGATOP, PGBTOP (KDLON,8,2)   ; T.O.A. PADE APPROXIMANTS
+
+  ! IMPLICIT ARGUMENTS :   NONE
+  ! --------------------
+
+  ! METHOD.
+  ! -------
+
+  ! 1. COMPUTES THE PLANCK FUNCTION ON ALL LEVELS AND HALF LEVELS
+  ! FROM A POLYNOMIAL DEVELOPMENT OF PLANCK FUNCTION
+
+  ! REFERENCE.
+  ! ----------
+
+  ! SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+  ! ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS           "
+
+  ! AUTHOR.
+  ! -------
+  ! JEAN-JACQUES MORCRETTE  *ECMWF*
+
+  ! MODIFICATIONS.
+  ! --------------
+  ! ORIGINAL : 89-07-14
+
+  ! -----------------------------------------------------------------------
+
+  ! ARGUMENTS:
+
+  REAL (KIND=8) pdt0(kdlon)
+  REAL (KIND=8) ptave(kdlon, kflev)
+  REAL (KIND=8) ptl(kdlon, kflev+1)
+
+  REAL (KIND=8) pb(kdlon, ninter, kflev+1) ! SPECTRAL HALF LEVEL PLANCK FUNCTION
+  REAL (KIND=8) pbint(kdlon, kflev+1) ! HALF LEVEL PLANCK FUNCTION
+  REAL (KIND=8) pbsuin(kdlon) ! SURFACE PLANCK FUNCTION
+  REAL (KIND=8) pbsur(kdlon, ninter) ! SURFACE SPECTRAL PLANCK FUNCTION
+  REAL (KIND=8) pbtop(kdlon, ninter) ! TOP SPECTRAL PLANCK FUNCTION
+  REAL (KIND=8) pdbsl(kdlon, ninter, kflev*2) ! SUB-LAYER PLANCK FUNCTION GRADIENT
+  REAL (KIND=8) pga(kdlon, 8, 2, kflev) ! dB/dT-weighted LAYER PADE APPROXIMANTS
+  REAL (KIND=8) pgb(kdlon, 8, 2, kflev) ! dB/dT-weighted LAYER PADE APPROXIMANTS
+  REAL (KIND=8) pgasur(kdlon, 8, 2) ! SURFACE PADE APPROXIMANTS
+  REAL (KIND=8) pgbsur(kdlon, 8, 2) ! SURFACE PADE APPROXIMANTS
+  REAL (KIND=8) pgatop(kdlon, 8, 2) ! T.O.A. PADE APPROXIMANTS
+  REAL (KIND=8) pgbtop(kdlon, 8, 2) ! T.O.A. PADE APPROXIMANTS
+
+  ! -------------------------------------------------------------------------
+  ! *  LOCAL VARIABLES:
+  INTEGER indb(kdlon), inds(kdlon)
+  REAL (KIND=8) zblay(kdlon, kflev), zblev(kdlon, kflev+1)
+  REAL (KIND=8) zres(kdlon), zres2(kdlon), zti(kdlon), zti2(kdlon)
+
+  INTEGER jk, jl, ic, jnu, jf, jg
+  INTEGER jk1, jk2
+  INTEGER k, j, ixtox, indto, ixtx, indt
+  INTEGER indsu, indtp
+  REAL (KIND=8) zdsto1, zdstox, zdst1, zdstx
+
+  ! * Quelques parametres:
+  REAL (KIND=8) tstand
+  PARAMETER (tstand=250.0)
+  REAL (KIND=8) tstp
+  PARAMETER (tstp=12.5)
+  INTEGER mxixt
+  PARAMETER (mxixt=10)
+
+  ! * Used Data Block:
+  ! REAL*8 TINTP(11)
+  ! SAVE TINTP
+  ! c$OMP THREADPRIVATE(TINTP)
+  ! REAL*8 GA(11,16,3), GB(11,16,3)
+  ! SAVE GA, GB
+  ! c$OMP THREADPRIVATE(GA, GB)
+  ! REAL*8 XP(6,6)
+  ! SAVE XP
+  ! c$OMP THREADPRIVATE(XP)
+
+  ! DATA TINTP / 187.5, 200., 212.5, 225., 237.5, 250.,
+  ! S             262.5, 275., 287.5, 300., 312.5 /
+  ! -----------------------------------------------------------------------
+  ! -- WATER VAPOR -- INT.1 -- 0- 500 CM-1 -- FROM ABS225 ----------------
+
+
+
+
+  ! -- R.D. -- G = - 0.2 SLA
+
+
+  ! ----- INTERVAL = 1 ----- T =  187.5
+
+  ! -- INDICES FOR PADE APPROXIMATION     1   15   29   45
+  ! DATA (GA( 1, 1,IC),IC=1,3) /
+  ! S 0.63499072E-02,-0.99506586E-03, 0.00000000E+00/
+  ! DATA (GB( 1, 1,IC),IC=1,3) /
+  ! S 0.63499072E-02, 0.97222852E-01, 0.10000000E+01/
+  ! DATA (GA( 1, 2,IC),IC=1,3) /
+  ! S 0.77266491E-02,-0.11661515E-02, 0.00000000E+00/
+  ! DATA (GB( 1, 2,IC),IC=1,3) /
+  ! S 0.77266491E-02, 0.10681591E+00, 0.10000000E+01/
+
+  ! ----- INTERVAL = 1 ----- T =  200.0
+
+  ! -- INDICES FOR PADE APPROXIMATION     1   15   29   45
+  ! DATA (GA( 2, 1,IC),IC=1,3) /
+  ! S 0.65566348E-02,-0.10184169E-02, 0.00000000E+00/
+  ! DATA (GB( 2, 1,IC),IC=1,3) /
+  ! S 0.65566348E-02, 0.98862238E-01, 0.10000000E+01/
+  ! DATA (GA( 2, 2,IC),IC=1,3) /
+  ! S 0.81323287E-02,-0.11886130E-02, 0.00000000E+00/
+  ! DATA (GB( 2, 2,IC),IC=1,3) /
+  ! S 0.81323287E-02, 0.10921298E+00, 0.10000000E+01/
+
+  ! ----- INTERVAL = 1 ----- T =  212.5
+
+  ! -- INDICES FOR PADE APPROXIMATION     1   15   29   45
+  ! DATA (GA( 3, 1,IC),IC=1,3) /
+  ! S 0.67849730E-02,-0.10404730E-02, 0.00000000E+00/
+  ! DATA (GB( 3, 1,IC),IC=1,3) /
+  ! S 0.67849730E-02, 0.10061504E+00, 0.10000000E+01/
+  ! DATA (GA( 3, 2,IC),IC=1,3) /
+  ! S 0.86507620E-02,-0.12139929E-02, 0.00000000E+00/
+  ! DATA (GB( 3, 2,IC),IC=1,3) /
+  ! S 0.86507620E-02, 0.11198225E+00, 0.10000000E+01/
+
+  ! ----- INTERVAL = 1 ----- T =  225.0
+
+  ! -- INDICES FOR PADE APPROXIMATION     1   15   29   45
+  ! DATA (GA( 4, 1,IC),IC=1,3) /
+  ! S 0.70481947E-02,-0.10621792E-02, 0.00000000E+00/
+  ! DATA (GB( 4, 1,IC),IC=1,3) /
+  ! S 0.70481947E-02, 0.10256222E+00, 0.10000000E+01/
+  ! DATA (GA( 4, 2,IC),IC=1,3) /
+  ! S 0.92776391E-02,-0.12445811E-02, 0.00000000E+00/
+  ! DATA (GB( 4, 2,IC),IC=1,3) /
+  ! S 0.92776391E-02, 0.11487826E+00, 0.10000000E+01/
+
+  ! ----- INTERVAL = 1 ----- T =  237.5
+
+  ! -- INDICES FOR PADE APPROXIMATION     1   15   29   45
+  ! DATA (GA( 5, 1,IC),IC=1,3) /
+  ! S 0.73585943E-02,-0.10847662E-02, 0.00000000E+00/
+  ! DATA (GB( 5, 1,IC),IC=1,3) /
+  ! S 0.73585943E-02, 0.10475952E+00, 0.10000000E+01/
+  ! DATA (GA( 5, 2,IC),IC=1,3) /
+  ! S 0.99806312E-02,-0.12807672E-02, 0.00000000E+00/
+  ! DATA (GB( 5, 2,IC),IC=1,3) /
+  ! S 0.99806312E-02, 0.11751113E+00, 0.10000000E+01/
+
+  ! ----- INTERVAL = 1 ----- T =  250.0
+
+  ! -- INDICES FOR PADE APPROXIMATION     1   15   29   45
+  ! DATA (GA( 6, 1,IC),IC=1,3) /
+  ! S 0.77242818E-02,-0.11094726E-02, 0.00000000E+00/
+  ! DATA (GB( 6, 1,IC),IC=1,3) /
+  ! S 0.77242818E-02, 0.10720986E+00, 0.10000000E+01/
+  ! DATA (GA( 6, 2,IC),IC=1,3) /
+  ! S 0.10709803E-01,-0.13208251E-02, 0.00000000E+00/
+  ! DATA (GB( 6, 2,IC),IC=1,3) /
+  ! S 0.10709803E-01, 0.11951535E+00, 0.10000000E+01/
+
+  ! ----- INTERVAL = 1 ----- T =  262.5
+
+  ! -- INDICES FOR PADE APPROXIMATION     1   15   29   45
+  ! DATA (GA( 7, 1,IC),IC=1,3) /
+  ! S 0.81472693E-02,-0.11372949E-02, 0.00000000E+00/
+  ! DATA (GB( 7, 1,IC),IC=1,3) /
+  ! S 0.81472693E-02, 0.10985370E+00, 0.10000000E+01/
+  ! DATA (GA( 7, 2,IC),IC=1,3) /
+  ! S 0.11414739E-01,-0.13619034E-02, 0.00000000E+00/
+  ! DATA (GB( 7, 2,IC),IC=1,3) /
+  ! S 0.11414739E-01, 0.12069945E+00, 0.10000000E+01/
+
+  ! ----- INTERVAL = 1 ----- T =  275.0
+
+  ! -- INDICES FOR PADE APPROXIMATION     1   15   29   45
+  ! DATA (GA( 8, 1,IC),IC=1,3) /
+  ! S 0.86227527E-02,-0.11687683E-02, 0.00000000E+00/
+  ! DATA (GB( 8, 1,IC),IC=1,3) /
+  ! S 0.86227527E-02, 0.11257633E+00, 0.10000000E+01/
+  ! DATA (GA( 8, 2,IC),IC=1,3) /
+  ! S 0.12058772E-01,-0.14014165E-02, 0.00000000E+00/
+  ! DATA (GB( 8, 2,IC),IC=1,3) /
+  ! S 0.12058772E-01, 0.12108524E+00, 0.10000000E+01/
+
+  ! ----- INTERVAL = 1 ----- T =  287.5
+
+  ! -- INDICES FOR PADE APPROXIMATION     1   15   29   45
+  ! DATA (GA( 9, 1,IC),IC=1,3) /
+  ! S 0.91396814E-02,-0.12038314E-02, 0.00000000E+00/
+  ! DATA (GB( 9, 1,IC),IC=1,3) /
+  ! S 0.91396814E-02, 0.11522980E+00, 0.10000000E+01/
+  ! DATA (GA( 9, 2,IC),IC=1,3) /
+  ! S 0.12623992E-01,-0.14378639E-02, 0.00000000E+00/
+  ! DATA (GB( 9, 2,IC),IC=1,3) /
+  ! S 0.12623992E-01, 0.12084229E+00, 0.10000000E+01/
+
+  ! ----- INTERVAL = 1 ----- T =  300.0
+
+  ! -- INDICES FOR PADE APPROXIMATION     1   15   29   45
+  ! DATA (GA(10, 1,IC),IC=1,3) /
+  ! S 0.96825438E-02,-0.12418367E-02, 0.00000000E+00/
+  ! DATA (GB(10, 1,IC),IC=1,3) /
+  ! S 0.96825438E-02, 0.11766343E+00, 0.10000000E+01/
+  ! DATA (GA(10, 2,IC),IC=1,3) /
+  ! S 0.13108146E-01,-0.14708488E-02, 0.00000000E+00/
+  ! DATA (GB(10, 2,IC),IC=1,3) /
+  ! S 0.13108146E-01, 0.12019005E+00, 0.10000000E+01/
+
+  ! ----- INTERVAL = 1 ----- T =  312.5
+
+  ! -- INDICES FOR PADE APPROXIMATION     1   15   29   45
+  ! DATA (GA(11, 1,IC),IC=1,3) /
+  ! S 0.10233955E-01,-0.12817135E-02, 0.00000000E+00/
+  ! DATA (GB(11, 1,IC),IC=1,3) /
+  ! S 0.10233955E-01, 0.11975320E+00, 0.10000000E+01/
+  ! DATA (GA(11, 2,IC),IC=1,3) /
+  ! S 0.13518390E-01,-0.15006791E-02, 0.00000000E+00/
+  ! DATA (GB(11, 2,IC),IC=1,3) /
+  ! S 0.13518390E-01, 0.11932684E+00, 0.10000000E+01/
+
+
+
+  ! --- WATER VAPOR --- INTERVAL 2 -- 500-800 CM-1--- FROM ABS225 ---------
+
+
+
+
+  ! --- R.D.  ---  G = 0.02 + 0.50 / ( 1 + 4.5 U )
+
+
+  ! ----- INTERVAL = 2 ----- T =  187.5
+
+  ! -- INDICES FOR PADE APPROXIMATION     1   28   37   45
+  ! DATA (GA( 1, 3,IC),IC=1,3) /
+  ! S 0.11644593E+01, 0.41243390E+00, 0.00000000E+00/
+  ! DATA (GB( 1, 3,IC),IC=1,3) /
+  ! S 0.11644593E+01, 0.10346097E+01, 0.10000000E+01/
+  ! DATA (GA( 1, 4,IC),IC=1,3) /
+  ! S 0.12006968E+01, 0.48318936E+00, 0.00000000E+00/
+  ! DATA (GB( 1, 4,IC),IC=1,3) /
+  ! S 0.12006968E+01, 0.10626130E+01, 0.10000000E+01/
+
+  ! ----- INTERVAL = 2 ----- T =  200.0
+
+  ! -- INDICES FOR PADE APPROXIMATION     1   28   37   45
+  ! DATA (GA( 2, 3,IC),IC=1,3) /
+  ! S 0.11747203E+01, 0.43407282E+00, 0.00000000E+00/
+  ! DATA (GB( 2, 3,IC),IC=1,3) /
+  ! S 0.11747203E+01, 0.10433655E+01, 0.10000000E+01/
+  ! DATA (GA( 2, 4,IC),IC=1,3) /
+  ! S 0.12108196E+01, 0.50501827E+00, 0.00000000E+00/
+  ! DATA (GB( 2, 4,IC),IC=1,3) /
+  ! S 0.12108196E+01, 0.10716026E+01, 0.10000000E+01/
+
+  ! ----- INTERVAL = 2 ----- T =  212.5
+
+  ! -- INDICES FOR PADE APPROXIMATION     1   28   37   45
+  ! DATA (GA( 3, 3,IC),IC=1,3) /
+  ! S 0.11837872E+01, 0.45331413E+00, 0.00000000E+00/
+  ! DATA (GB( 3, 3,IC),IC=1,3) /
+  ! S 0.11837872E+01, 0.10511933E+01, 0.10000000E+01/
+  ! DATA (GA( 3, 4,IC),IC=1,3) /
+  ! S 0.12196717E+01, 0.52409502E+00, 0.00000000E+00/
+  ! DATA (GB( 3, 4,IC),IC=1,3) /
+  ! S 0.12196717E+01, 0.10795108E+01, 0.10000000E+01/
+
+  ! ----- INTERVAL = 2 ----- T =  225.0
+
+  ! -- INDICES FOR PADE APPROXIMATION     1   28   37   45
+  ! DATA (GA( 4, 3,IC),IC=1,3) /
+  ! S 0.11918561E+01, 0.47048604E+00, 0.00000000E+00/
+  ! DATA (GB( 4, 3,IC),IC=1,3) /
+  ! S 0.11918561E+01, 0.10582150E+01, 0.10000000E+01/
+  ! DATA (GA( 4, 4,IC),IC=1,3) /
+  ! S 0.12274493E+01, 0.54085277E+00, 0.00000000E+00/
+  ! DATA (GB( 4, 4,IC),IC=1,3) /
+  ! S 0.12274493E+01, 0.10865006E+01, 0.10000000E+01/
+
+  ! ----- INTERVAL = 2 ----- T =  237.5
+
+  ! -- INDICES FOR PADE APPROXIMATION     1   28   37   45
+  ! DATA (GA( 5, 3,IC),IC=1,3) /
+  ! S 0.11990757E+01, 0.48586286E+00, 0.00000000E+00/
+  ! DATA (GB( 5, 3,IC),IC=1,3) /
+  ! S 0.11990757E+01, 0.10645317E+01, 0.10000000E+01/
+  ! DATA (GA( 5, 4,IC),IC=1,3) /
+  ! S 0.12343189E+01, 0.55565422E+00, 0.00000000E+00/
+  ! DATA (GB( 5, 4,IC),IC=1,3) /
+  ! S 0.12343189E+01, 0.10927103E+01, 0.10000000E+01/
+
+  ! ----- INTERVAL = 2 ----- T =  250.0
+
+  ! -- INDICES FOR PADE APPROXIMATION     1   28   37   45
+  ! DATA (GA( 6, 3,IC),IC=1,3) /
+  ! S 0.12055643E+01, 0.49968044E+00, 0.00000000E+00/
+  ! DATA (GB( 6, 3,IC),IC=1,3) /
+  ! S 0.12055643E+01, 0.10702313E+01, 0.10000000E+01/
+  ! DATA (GA( 6, 4,IC),IC=1,3) /
+  ! S 0.12404147E+01, 0.56878618E+00, 0.00000000E+00/
+  ! DATA (GB( 6, 4,IC),IC=1,3) /
+  ! S 0.12404147E+01, 0.10982489E+01, 0.10000000E+01/
+
+  ! ----- INTERVAL = 2 ----- T =  262.5
+
+  ! -- INDICES FOR PADE APPROXIMATION     1   28   37   45
+  ! DATA (GA( 7, 3,IC),IC=1,3) /
+  ! S 0.12114186E+01, 0.51214132E+00, 0.00000000E+00/
+  ! DATA (GB( 7, 3,IC),IC=1,3) /
+  ! S 0.12114186E+01, 0.10753907E+01, 0.10000000E+01/
+  ! DATA (GA( 7, 4,IC),IC=1,3) /
+  ! S 0.12458431E+01, 0.58047395E+00, 0.00000000E+00/
+  ! DATA (GB( 7, 4,IC),IC=1,3) /
+  ! S 0.12458431E+01, 0.11032019E+01, 0.10000000E+01/
+
+  ! ----- INTERVAL = 2 ----- T =  275.0
+
+  ! -- INDICES FOR PADE APPROXIMATION     1   28   37   45
+  ! DATA (GA( 8, 3,IC),IC=1,3) /
+  ! S 0.12167192E+01, 0.52341830E+00, 0.00000000E+00/
+  ! DATA (GB( 8, 3,IC),IC=1,3) /
+  ! S 0.12167192E+01, 0.10800762E+01, 0.10000000E+01/
+  ! DATA (GA( 8, 4,IC),IC=1,3) /
+  ! S 0.12506907E+01, 0.59089894E+00, 0.00000000E+00/
+  ! DATA (GB( 8, 4,IC),IC=1,3) /
+  ! S 0.12506907E+01, 0.11076379E+01, 0.10000000E+01/
+
+  ! ----- INTERVAL = 2 ----- T =  287.5
+
+  ! -- INDICES FOR PADE APPROXIMATION     1   28   37   45
+  ! DATA (GA( 9, 3,IC),IC=1,3) /
+  ! S 0.12215344E+01, 0.53365803E+00, 0.00000000E+00/
+  ! DATA (GB( 9, 3,IC),IC=1,3) /
+  ! S 0.12215344E+01, 0.10843446E+01, 0.10000000E+01/
+  ! DATA (GA( 9, 4,IC),IC=1,3) /
+  ! S 0.12550299E+01, 0.60021475E+00, 0.00000000E+00/
+  ! DATA (GB( 9, 4,IC),IC=1,3) /
+  ! S 0.12550299E+01, 0.11116160E+01, 0.10000000E+01/
+
+  ! ----- INTERVAL = 2 ----- T =  300.0
+
+  ! -- INDICES FOR PADE APPROXIMATION     1   28   37   45
+  ! DATA (GA(10, 3,IC),IC=1,3) /
+  ! S 0.12259226E+01, 0.54298448E+00, 0.00000000E+00/
+  ! DATA (GB(10, 3,IC),IC=1,3) /
+  ! S 0.12259226E+01, 0.10882439E+01, 0.10000000E+01/
+  ! DATA (GA(10, 4,IC),IC=1,3) /
+  ! S 0.12589256E+01, 0.60856112E+00, 0.00000000E+00/
+  ! DATA (GB(10, 4,IC),IC=1,3) /
+  ! S 0.12589256E+01, 0.11151910E+01, 0.10000000E+01/
+
+  ! ----- INTERVAL = 2 ----- T =  312.5
+
+  ! -- INDICES FOR PADE APPROXIMATION     1   28   37   45
+  ! DATA (GA(11, 3,IC),IC=1,3) /
+  ! S 0.12299344E+01, 0.55150227E+00, 0.00000000E+00/
+  ! DATA (GB(11, 3,IC),IC=1,3) /
+  ! S 0.12299344E+01, 0.10918144E+01, 0.10000000E+01/
+  ! DATA (GA(11, 4,IC),IC=1,3) /
+  ! S 0.12624402E+01, 0.61607594E+00, 0.00000000E+00/
+  ! DATA (GB(11, 4,IC),IC=1,3) /
+  ! S 0.12624402E+01, 0.11184188E+01, 0.10000000E+01/
+
+
+
+
+
+
+  ! - WATER VAPOR - INT. 3 -- 800-970 + 1110-1250 CM-1 -- FIT FROM 215 IS -
+
+
+  ! -- WATER VAPOR LINES IN THE WINDOW REGION (800-1250 CM-1)
+
+
+
+  ! --- G = 3.875E-03 ---------------
+
+  ! ----- INTERVAL = 3 ----- T =  187.5
+
+  ! -- INDICES FOR PADE APPROXIMATION     1   28   37   45
+  ! DATA (GA( 1, 7,IC),IC=1,3) /
+  ! S 0.10192131E+02, 0.80737799E+01, 0.00000000E+00/
+  ! DATA (GB( 1, 7,IC),IC=1,3) /
+  ! S 0.10192131E+02, 0.82623280E+01, 0.10000000E+01/
+  ! DATA (GA( 1, 8,IC),IC=1,3) /
+  ! S 0.92439050E+01, 0.77425778E+01, 0.00000000E+00/
+  ! DATA (GB( 1, 8,IC),IC=1,3) /
+  ! S 0.92439050E+01, 0.79342219E+01, 0.10000000E+01/
+
+  ! ----- INTERVAL = 3 ----- T =  200.0
+
+  ! -- INDICES FOR PADE APPROXIMATION     1   28   37   45
+  ! DATA (GA( 2, 7,IC),IC=1,3) /
+  ! S 0.97258602E+01, 0.79171158E+01, 0.00000000E+00/
+  ! DATA (GB( 2, 7,IC),IC=1,3) /
+  ! S 0.97258602E+01, 0.81072291E+01, 0.10000000E+01/
+  ! DATA (GA( 2, 8,IC),IC=1,3) /
+  ! S 0.87567422E+01, 0.75443460E+01, 0.00000000E+00/
+  ! DATA (GB( 2, 8,IC),IC=1,3) /
+  ! S 0.87567422E+01, 0.77373458E+01, 0.10000000E+01/
+
+  ! ----- INTERVAL = 3 ----- T =  212.5
+
+  ! -- INDICES FOR PADE APPROXIMATION     1   28   37   45
+  ! DATA (GA( 3, 7,IC),IC=1,3) /
+  ! S 0.92992890E+01, 0.77609605E+01, 0.00000000E+00/
+  ! DATA (GB( 3, 7,IC),IC=1,3) /
+  ! S 0.92992890E+01, 0.79523834E+01, 0.10000000E+01/
+  ! DATA (GA( 3, 8,IC),IC=1,3) /
+  ! S 0.83270144E+01, 0.73526151E+01, 0.00000000E+00/
+  ! DATA (GB( 3, 8,IC),IC=1,3) /
+  ! S 0.83270144E+01, 0.75467334E+01, 0.10000000E+01/
+
+  ! ----- INTERVAL = 3 ----- T =  225.0
+
+  ! -- INDICES FOR PADE APPROXIMATION     1   28   37   45
+  ! DATA (GA( 4, 7,IC),IC=1,3) /
+  ! S 0.89154021E+01, 0.76087371E+01, 0.00000000E+00/
+  ! DATA (GB( 4, 7,IC),IC=1,3) /
+  ! S 0.89154021E+01, 0.78012527E+01, 0.10000000E+01/
+  ! DATA (GA( 4, 8,IC),IC=1,3) /
+  ! S 0.79528337E+01, 0.71711188E+01, 0.00000000E+00/
+  ! DATA (GB( 4, 8,IC),IC=1,3) /
+  ! S 0.79528337E+01, 0.73661786E+01, 0.10000000E+01/
+
+  ! ----- INTERVAL = 3 ----- T =  237.5
+
+  ! -- INDICES FOR PADE APPROXIMATION     1   28   37   45
+  ! DATA (GA( 5, 7,IC),IC=1,3) /
+  ! S 0.85730084E+01, 0.74627112E+01, 0.00000000E+00/
+  ! DATA (GB( 5, 7,IC),IC=1,3) /
+  ! S 0.85730084E+01, 0.76561458E+01, 0.10000000E+01/
+  ! DATA (GA( 5, 8,IC),IC=1,3) /
+  ! S 0.76286839E+01, 0.70015571E+01, 0.00000000E+00/
+  ! DATA (GB( 5, 8,IC),IC=1,3) /
+  ! S 0.76286839E+01, 0.71974319E+01, 0.10000000E+01/
+
+  ! ----- INTERVAL = 3 ----- T =  250.0
+
+  ! -- INDICES FOR PADE APPROXIMATION     1   28   37   45
+  ! DATA (GA( 6, 7,IC),IC=1,3) /
+  ! S 0.82685838E+01, 0.73239981E+01, 0.00000000E+00/
+  ! DATA (GB( 6, 7,IC),IC=1,3) /
+  ! S 0.82685838E+01, 0.75182174E+01, 0.10000000E+01/
+  ! DATA (GA( 6, 8,IC),IC=1,3) /
+  ! S 0.73477879E+01, 0.68442532E+01, 0.00000000E+00/
+  ! DATA (GB( 6, 8,IC),IC=1,3) /
+  ! S 0.73477879E+01, 0.70408543E+01, 0.10000000E+01/
+
+  ! ----- INTERVAL = 3 ----- T =  262.5
+
+  ! -- INDICES FOR PADE APPROXIMATION     1   28   37   45
+  ! DATA (GA( 7, 7,IC),IC=1,3) /
+  ! S 0.79978921E+01, 0.71929934E+01, 0.00000000E+00/
+  ! DATA (GB( 7, 7,IC),IC=1,3) /
+  ! S 0.79978921E+01, 0.73878952E+01, 0.10000000E+01/
+  ! DATA (GA( 7, 8,IC),IC=1,3) /
+  ! S 0.71035818E+01, 0.66987996E+01, 0.00000000E+00/
+  ! DATA (GB( 7, 8,IC),IC=1,3) /
+  ! S 0.71035818E+01, 0.68960649E+01, 0.10000000E+01/
+
+  ! ----- INTERVAL = 3 ----- T =  275.0
+
+  ! -- INDICES FOR PADE APPROXIMATION     1   28   37   45
+  ! DATA (GA( 8, 7,IC),IC=1,3) /
+  ! S 0.77568055E+01, 0.70697065E+01, 0.00000000E+00/
+  ! DATA (GB( 8, 7,IC),IC=1,3) /
+  ! S 0.77568055E+01, 0.72652133E+01, 0.10000000E+01/
+  ! DATA (GA( 8, 8,IC),IC=1,3) /
+  ! S 0.68903312E+01, 0.65644820E+01, 0.00000000E+00/
+  ! DATA (GB( 8, 8,IC),IC=1,3) /
+  ! S 0.68903312E+01, 0.67623672E+01, 0.10000000E+01/
+
+  ! ----- INTERVAL = 3 ----- T =  287.5
+
+  ! -- INDICES FOR PADE APPROXIMATION     1   28   37   45
+  ! DATA (GA( 9, 7,IC),IC=1,3) /
+  ! S 0.75416266E+01, 0.69539626E+01, 0.00000000E+00/
+  ! DATA (GB( 9, 7,IC),IC=1,3) /
+  ! S 0.75416266E+01, 0.71500151E+01, 0.10000000E+01/
+  ! DATA (GA( 9, 8,IC),IC=1,3) /
+  ! S 0.67032875E+01, 0.64405267E+01, 0.00000000E+00/
+  ! DATA (GB( 9, 8,IC),IC=1,3) /
+  ! S 0.67032875E+01, 0.66389989E+01, 0.10000000E+01/
+
+  ! ----- INTERVAL = 3 ----- T =  300.0
+
+  ! -- INDICES FOR PADE APPROXIMATION     1   28   37   45
+  ! DATA (GA(10, 7,IC),IC=1,3) /
+  ! S 0.73491694E+01, 0.68455144E+01, 0.00000000E+00/
+  ! DATA (GB(10, 7,IC),IC=1,3) /
+  ! S 0.73491694E+01, 0.70420667E+01, 0.10000000E+01/
+  ! DATA (GA(10, 8,IC),IC=1,3) /
+  ! S 0.65386461E+01, 0.63262376E+01, 0.00000000E+00/
+  ! DATA (GB(10, 8,IC),IC=1,3) /
+  ! S 0.65386461E+01, 0.65252707E+01, 0.10000000E+01/
+
+  ! ----- INTERVAL = 3 ----- T =  312.5
+
+  ! -- INDICES FOR PADE APPROXIMATION     1   28   37   45
+  ! DATA (GA(11, 7,IC),IC=1,3) /
+  ! S 0.71767400E+01, 0.67441020E+01, 0.00000000E+00/
+  ! DATA (GB(11, 7,IC),IC=1,3) /
+  ! S 0.71767400E+01, 0.69411177E+01, 0.10000000E+01/
+  ! DATA (GA(11, 8,IC),IC=1,3) /
+  ! S 0.63934377E+01, 0.62210701E+01, 0.00000000E+00/
+  ! DATA (GB(11, 8,IC),IC=1,3) /
+  ! S 0.63934377E+01, 0.64206412E+01, 0.10000000E+01/
+
+
+  ! -- WATER VAPOR -- 970-1110 CM-1 ----------------------------------------
+
+  ! -- G = 3.6E-03
+
+  ! ----- INTERVAL = 4 ----- T =  187.5
+
+  ! -- INDICES FOR PADE APPROXIMATION     1   28   37   45
+  ! DATA (GA( 1, 9,IC),IC=1,3) /
+  ! S 0.24870635E+02, 0.10542131E+02, 0.00000000E+00/
+  ! DATA (GB( 1, 9,IC),IC=1,3) /
+  ! S 0.24870635E+02, 0.10656640E+02, 0.10000000E+01/
+  ! DATA (GA( 1,10,IC),IC=1,3) /
+  ! S 0.24586283E+02, 0.10490353E+02, 0.00000000E+00/
+  ! DATA (GB( 1,10,IC),IC=1,3) /
+  ! S 0.24586283E+02, 0.10605856E+02, 0.10000000E+01/
+
+  ! ----- INTERVAL = 4 ----- T =  200.0
+
+  ! -- INDICES FOR PADE APPROXIMATION     1   28   37   45
+  ! DATA (GA( 2, 9,IC),IC=1,3) /
+  ! S 0.24725591E+02, 0.10515895E+02, 0.00000000E+00/
+  ! DATA (GB( 2, 9,IC),IC=1,3) /
+  ! S 0.24725591E+02, 0.10630910E+02, 0.10000000E+01/
+  ! DATA (GA( 2,10,IC),IC=1,3) /
+  ! S 0.24441465E+02, 0.10463512E+02, 0.00000000E+00/
+  ! DATA (GB( 2,10,IC),IC=1,3) /
+  ! S 0.24441465E+02, 0.10579514E+02, 0.10000000E+01/
+
+  ! ----- INTERVAL = 4 ----- T =  212.5
+
+  ! -- INDICES FOR PADE APPROXIMATION     1   28   37   45
+  ! DATA (GA( 3, 9,IC),IC=1,3) /
+  ! S 0.24600320E+02, 0.10492949E+02, 0.00000000E+00/
+  ! DATA (GB( 3, 9,IC),IC=1,3) /
+  ! S 0.24600320E+02, 0.10608399E+02, 0.10000000E+01/
+  ! DATA (GA( 3,10,IC),IC=1,3) /
+  ! S 0.24311657E+02, 0.10439183E+02, 0.00000000E+00/
+  ! DATA (GB( 3,10,IC),IC=1,3) /
+  ! S 0.24311657E+02, 0.10555632E+02, 0.10000000E+01/
+
+  ! ----- INTERVAL = 4 ----- T =  225.0
+
+  ! -- INDICES FOR PADE APPROXIMATION     1   28   37   45
+  ! DATA (GA( 4, 9,IC),IC=1,3) /
+  ! S 0.24487300E+02, 0.10472049E+02, 0.00000000E+00/
+  ! DATA (GB( 4, 9,IC),IC=1,3) /
+  ! S 0.24487300E+02, 0.10587891E+02, 0.10000000E+01/
+  ! DATA (GA( 4,10,IC),IC=1,3) /
+  ! S 0.24196167E+02, 0.10417324E+02, 0.00000000E+00/
+  ! DATA (GB( 4,10,IC),IC=1,3) /
+  ! S 0.24196167E+02, 0.10534169E+02, 0.10000000E+01/
+
+  ! ----- INTERVAL = 4 ----- T =  237.5
+
+  ! -- INDICES FOR PADE APPROXIMATION     1   28   37   45
+  ! DATA (GA( 5, 9,IC),IC=1,3) /
+  ! S 0.24384935E+02, 0.10452961E+02, 0.00000000E+00/
+  ! DATA (GB( 5, 9,IC),IC=1,3) /
+  ! S 0.24384935E+02, 0.10569156E+02, 0.10000000E+01/
+  ! DATA (GA( 5,10,IC),IC=1,3) /
+  ! S 0.24093406E+02, 0.10397704E+02, 0.00000000E+00/
+  ! DATA (GB( 5,10,IC),IC=1,3) /
+  ! S 0.24093406E+02, 0.10514900E+02, 0.10000000E+01/
+
+  ! ----- INTERVAL = 4 ----- T =  250.0
+
+  ! -- INDICES FOR PADE APPROXIMATION     1   28   37   45
+  ! DATA (GA( 6, 9,IC),IC=1,3) /
+  ! S 0.24292341E+02, 0.10435562E+02, 0.00000000E+00/
+  ! DATA (GB( 6, 9,IC),IC=1,3) /
+  ! S 0.24292341E+02, 0.10552075E+02, 0.10000000E+01/
+  ! DATA (GA( 6,10,IC),IC=1,3) /
+  ! S 0.24001597E+02, 0.10380038E+02, 0.00000000E+00/
+  ! DATA (GB( 6,10,IC),IC=1,3) /
+  ! S 0.24001597E+02, 0.10497547E+02, 0.10000000E+01/
+
+  ! ----- INTERVAL = 4 ----- T =  262.5
+
+  ! -- INDICES FOR PADE APPROXIMATION     1   28   37   45
+  ! DATA (GA( 7, 9,IC),IC=1,3) /
+  ! S 0.24208572E+02, 0.10419710E+02, 0.00000000E+00/
+  ! DATA (GB( 7, 9,IC),IC=1,3) /
+  ! S 0.24208572E+02, 0.10536510E+02, 0.10000000E+01/
+  ! DATA (GA( 7,10,IC),IC=1,3) /
+  ! S 0.23919098E+02, 0.10364052E+02, 0.00000000E+00/
+  ! DATA (GB( 7,10,IC),IC=1,3) /
+  ! S 0.23919098E+02, 0.10481842E+02, 0.10000000E+01/
+
+  ! ----- INTERVAL = 4 ----- T =  275.0
+
+  ! -- INDICES FOR PADE APPROXIMATION     1   28   37   45
+  ! DATA (GA( 8, 9,IC),IC=1,3) /
+  ! S 0.24132642E+02, 0.10405247E+02, 0.00000000E+00/
+  ! DATA (GB( 8, 9,IC),IC=1,3) /
+  ! S 0.24132642E+02, 0.10522307E+02, 0.10000000E+01/
+  ! DATA (GA( 8,10,IC),IC=1,3) /
+  ! S 0.23844511E+02, 0.10349509E+02, 0.00000000E+00/
+  ! DATA (GB( 8,10,IC),IC=1,3) /
+  ! S 0.23844511E+02, 0.10467553E+02, 0.10000000E+01/
+
+  ! ----- INTERVAL = 4 ----- T =  287.5
+
+  ! -- INDICES FOR PADE APPROXIMATION     1   28   37   45
+  ! DATA (GA( 9, 9,IC),IC=1,3) /
+  ! S 0.24063614E+02, 0.10392022E+02, 0.00000000E+00/
+  ! DATA (GB( 9, 9,IC),IC=1,3) /
+  ! S 0.24063614E+02, 0.10509317E+02, 0.10000000E+01/
+  ! DATA (GA( 9,10,IC),IC=1,3) /
+  ! S 0.23776708E+02, 0.10336215E+02, 0.00000000E+00/
+  ! DATA (GB( 9,10,IC),IC=1,3) /
+  ! S 0.23776708E+02, 0.10454488E+02, 0.10000000E+01/
+
+  ! ----- INTERVAL = 4 ----- T =  300.0
+
+  ! -- INDICES FOR PADE APPROXIMATION     1   28   37   45
+  ! DATA (GA(10, 9,IC),IC=1,3) /
+  ! S 0.24000649E+02, 0.10379892E+02, 0.00000000E+00/
+  ! DATA (GB(10, 9,IC),IC=1,3) /
+  ! S 0.24000649E+02, 0.10497402E+02, 0.10000000E+01/
+  ! DATA (GA(10,10,IC),IC=1,3) /
+  ! S 0.23714816E+02, 0.10324018E+02, 0.00000000E+00/
+  ! DATA (GB(10,10,IC),IC=1,3) /
+  ! S 0.23714816E+02, 0.10442501E+02, 0.10000000E+01/
+
+  ! ----- INTERVAL = 4 ----- T =  312.5
+
+  ! -- INDICES FOR PADE APPROXIMATION     1   28   37   45
+  ! DATA (GA(11, 9,IC),IC=1,3) /
+  ! S 0.23943021E+02, 0.10368736E+02, 0.00000000E+00/
+  ! DATA (GB(11, 9,IC),IC=1,3) /
+  ! S 0.23943021E+02, 0.10486443E+02, 0.10000000E+01/
+  ! DATA (GA(11,10,IC),IC=1,3) /
+  ! S 0.23658197E+02, 0.10312808E+02, 0.00000000E+00/
+  ! DATA (GB(11,10,IC),IC=1,3) /
+  ! S 0.23658197E+02, 0.10431483E+02, 0.10000000E+01/
+
+
+
+  ! -- H2O -- WEAKER PARTS OF THE STRONG BANDS  -- FROM ABS225 ----
+
+  ! -- WATER VAPOR --- 350 - 500 CM-1
+
+  ! -- G = - 0.2*SLA, 0.0 +0.5/(1+0.5U)
+
+  ! ----- INTERVAL = 5 ----- T =  187.5
+
+  ! -- INDICES FOR PADE APPROXIMATION   1 35 40 45
+  ! DATA (GA( 1, 5,IC),IC=1,3) /
+  ! S 0.15750172E+00,-0.22159303E-01, 0.00000000E+00/
+  ! DATA (GB( 1, 5,IC),IC=1,3) /
+  ! S 0.15750172E+00, 0.38103212E+00, 0.10000000E+01/
+  ! DATA (GA( 1, 6,IC),IC=1,3) /
+  ! S 0.17770551E+00,-0.24972399E-01, 0.00000000E+00/
+  ! DATA (GB( 1, 6,IC),IC=1,3) /
+  ! S 0.17770551E+00, 0.41646579E+00, 0.10000000E+01/
+
+  ! ----- INTERVAL = 5 ----- T =  200.0
+
+  ! -- INDICES FOR PADE APPROXIMATION   1 35 40 45
+  ! DATA (GA( 2, 5,IC),IC=1,3) /
+  ! S 0.16174076E+00,-0.22748917E-01, 0.00000000E+00/
+  ! DATA (GB( 2, 5,IC),IC=1,3) /
+  ! S 0.16174076E+00, 0.38913800E+00, 0.10000000E+01/
+  ! DATA (GA( 2, 6,IC),IC=1,3) /
+  ! S 0.18176757E+00,-0.25537247E-01, 0.00000000E+00/
+  ! DATA (GB( 2, 6,IC),IC=1,3) /
+  ! S 0.18176757E+00, 0.42345095E+00, 0.10000000E+01/
+
+  ! ----- INTERVAL = 5 ----- T =  212.5
+
+  ! -- INDICES FOR PADE APPROXIMATION   1 35 40 45
+  ! DATA (GA( 3, 5,IC),IC=1,3) /
+  ! S 0.16548628E+00,-0.23269898E-01, 0.00000000E+00/
+  ! DATA (GB( 3, 5,IC),IC=1,3) /
+  ! S 0.16548628E+00, 0.39613651E+00, 0.10000000E+01/
+  ! DATA (GA( 3, 6,IC),IC=1,3) /
+  ! S 0.18527967E+00,-0.26025624E-01, 0.00000000E+00/
+  ! DATA (GB( 3, 6,IC),IC=1,3) /
+  ! S 0.18527967E+00, 0.42937476E+00, 0.10000000E+01/
+
+  ! ----- INTERVAL = 5 ----- T =  225.0
+
+  ! -- INDICES FOR PADE APPROXIMATION   1 35 40 45
+  ! DATA (GA( 4, 5,IC),IC=1,3) /
+  ! S 0.16881124E+00,-0.23732392E-01, 0.00000000E+00/
+  ! DATA (GB( 4, 5,IC),IC=1,3) /
+  ! S 0.16881124E+00, 0.40222421E+00, 0.10000000E+01/
+  ! DATA (GA( 4, 6,IC),IC=1,3) /
+  ! S 0.18833348E+00,-0.26450280E-01, 0.00000000E+00/
+  ! DATA (GB( 4, 6,IC),IC=1,3) /
+  ! S 0.18833348E+00, 0.43444062E+00, 0.10000000E+01/
+
+  ! ----- INTERVAL = 5 ----- T =  237.5
+
+  ! -- INDICES FOR PADE APPROXIMATION   1 35 40 45
+  ! DATA (GA( 5, 5,IC),IC=1,3) /
+  ! S 0.17177839E+00,-0.24145123E-01, 0.00000000E+00/
+  ! DATA (GB( 5, 5,IC),IC=1,3) /
+  ! S 0.17177839E+00, 0.40756010E+00, 0.10000000E+01/
+  ! DATA (GA( 5, 6,IC),IC=1,3) /
+  ! S 0.19100108E+00,-0.26821236E-01, 0.00000000E+00/
+  ! DATA (GB( 5, 6,IC),IC=1,3) /
+  ! S 0.19100108E+00, 0.43880316E+00, 0.10000000E+01/
+
+  ! ----- INTERVAL = 5 ----- T =  250.0
+
+  ! -- INDICES FOR PADE APPROXIMATION   1 35 40 45
+  ! DATA (GA( 6, 5,IC),IC=1,3) /
+  ! S 0.17443933E+00,-0.24515269E-01, 0.00000000E+00/
+  ! DATA (GB( 6, 5,IC),IC=1,3) /
+  ! S 0.17443933E+00, 0.41226954E+00, 0.10000000E+01/
+  ! DATA (GA( 6, 6,IC),IC=1,3) /
+  ! S 0.19334122E+00,-0.27146657E-01, 0.00000000E+00/
+  ! DATA (GB( 6, 6,IC),IC=1,3) /
+  ! S 0.19334122E+00, 0.44258354E+00, 0.10000000E+01/
+
+  ! ----- INTERVAL = 5 ----- T =  262.5
+
+  ! -- INDICES FOR PADE APPROXIMATION   1 35 40 45
+  ! DATA (GA( 7, 5,IC),IC=1,3) /
+  ! S 0.17683622E+00,-0.24848690E-01, 0.00000000E+00/
+  ! DATA (GB( 7, 5,IC),IC=1,3) /
+  ! S 0.17683622E+00, 0.41645142E+00, 0.10000000E+01/
+  ! DATA (GA( 7, 6,IC),IC=1,3) /
+  ! S 0.19540288E+00,-0.27433354E-01, 0.00000000E+00/
+  ! DATA (GB( 7, 6,IC),IC=1,3) /
+  ! S 0.19540288E+00, 0.44587882E+00, 0.10000000E+01/
+
+  ! ----- INTERVAL = 5 ----- T =  275.0
+
+  ! -- INDICES FOR PADE APPROXIMATION   1 35 40 45
+  ! DATA (GA( 8, 5,IC),IC=1,3) /
+  ! S 0.17900375E+00,-0.25150210E-01, 0.00000000E+00/
+  ! DATA (GB( 8, 5,IC),IC=1,3) /
+  ! S 0.17900375E+00, 0.42018474E+00, 0.10000000E+01/
+  ! DATA (GA( 8, 6,IC),IC=1,3) /
+  ! S 0.19722732E+00,-0.27687065E-01, 0.00000000E+00/
+  ! DATA (GB( 8, 6,IC),IC=1,3) /
+  ! S 0.19722732E+00, 0.44876776E+00, 0.10000000E+01/
+
+  ! ----- INTERVAL = 5 ----- T =  287.5
+
+  ! -- INDICES FOR PADE APPROXIMATION   1 35 40 45
+  ! DATA (GA( 9, 5,IC),IC=1,3) /
+  ! S 0.18097099E+00,-0.25423873E-01, 0.00000000E+00/
+  ! DATA (GB( 9, 5,IC),IC=1,3) /
+  ! S 0.18097099E+00, 0.42353379E+00, 0.10000000E+01/
+  ! DATA (GA( 9, 6,IC),IC=1,3) /
+  ! S 0.19884918E+00,-0.27912608E-01, 0.00000000E+00/
+  ! DATA (GB( 9, 6,IC),IC=1,3) /
+  ! S 0.19884918E+00, 0.45131451E+00, 0.10000000E+01/
+
+  ! ----- INTERVAL = 5 ----- T =  300.0
+
+  ! -- INDICES FOR PADE APPROXIMATION   1 35 40 45
+  ! DATA (GA(10, 5,IC),IC=1,3) /
+  ! S 0.18276283E+00,-0.25673139E-01, 0.00000000E+00/
+  ! DATA (GB(10, 5,IC),IC=1,3) /
+  ! S 0.18276283E+00, 0.42655211E+00, 0.10000000E+01/
+  ! DATA (GA(10, 6,IC),IC=1,3) /
+  ! S 0.20029696E+00,-0.28113944E-01, 0.00000000E+00/
+  ! DATA (GB(10, 6,IC),IC=1,3) /
+  ! S 0.20029696E+00, 0.45357095E+00, 0.10000000E+01/
+
+  ! ----- INTERVAL = 5 ----- T =  312.5
+
+  ! -- INDICES FOR PADE APPROXIMATION   1 35 40 45
+  ! DATA (GA(11, 5,IC),IC=1,3) /
+  ! S 0.18440117E+00,-0.25901055E-01, 0.00000000E+00/
+  ! DATA (GB(11, 5,IC),IC=1,3) /
+  ! S 0.18440117E+00, 0.42928533E+00, 0.10000000E+01/
+  ! DATA (GA(11, 6,IC),IC=1,3) /
+  ! S 0.20159300E+00,-0.28294180E-01, 0.00000000E+00/
+  ! DATA (GB(11, 6,IC),IC=1,3) /
+  ! S 0.20159300E+00, 0.45557797E+00, 0.10000000E+01/
+
+
+
+
+  ! - WATER VAPOR - WINGS OF VIBRATION-ROTATION BAND - 1250-1450+1880-2820 -
+  ! --- G = 0.0
+
+
+  ! ----- INTERVAL = 6 ----- T =  187.5
+
+  ! -- INDICES FOR PADE APPROXIMATION   1 35 40 45
+  ! DATA (GA( 1,11,IC),IC=1,3) /
+  ! S 0.11990218E+02,-0.12823142E+01, 0.00000000E+00/
+  ! DATA (GB( 1,11,IC),IC=1,3) /
+  ! S 0.11990218E+02, 0.26681588E+02, 0.10000000E+01/
+  ! DATA (GA( 1,12,IC),IC=1,3) /
+  ! S 0.79709806E+01,-0.74805226E+00, 0.00000000E+00/
+  ! DATA (GB( 1,12,IC),IC=1,3) /
+  ! S 0.79709806E+01, 0.18377807E+02, 0.10000000E+01/
+
+  ! ----- INTERVAL = 6 ----- T =  200.0
+
+  ! -- INDICES FOR PADE APPROXIMATION   1 35 40 45
+  ! DATA (GA( 2,11,IC),IC=1,3) /
+  ! S 0.10904073E+02,-0.10571588E+01, 0.00000000E+00/
+  ! DATA (GB( 2,11,IC),IC=1,3) /
+  ! S 0.10904073E+02, 0.24728346E+02, 0.10000000E+01/
+  ! DATA (GA( 2,12,IC),IC=1,3) /
+  ! S 0.75400737E+01,-0.56252739E+00, 0.00000000E+00/
+  ! DATA (GB( 2,12,IC),IC=1,3) /
+  ! S 0.75400737E+01, 0.17643148E+02, 0.10000000E+01/
+
+  ! ----- INTERVAL = 6 ----- T =  212.5
+
+  ! -- INDICES FOR PADE APPROXIMATION   1 35 40 45
+  ! DATA (GA( 3,11,IC),IC=1,3) /
+  ! S 0.89126838E+01,-0.74864953E+00, 0.00000000E+00/
+  ! DATA (GB( 3,11,IC),IC=1,3) /
+  ! S 0.89126838E+01, 0.20551342E+02, 0.10000000E+01/
+  ! DATA (GA( 3,12,IC),IC=1,3) /
+  ! S 0.81804377E+01,-0.46188072E+00, 0.00000000E+00/
+  ! DATA (GB( 3,12,IC),IC=1,3) /
+  ! S 0.81804377E+01, 0.19296161E+02, 0.10000000E+01/
+
+  ! ----- INTERVAL = 6 ----- T =  225.0
+
+  ! -- INDICES FOR PADE APPROXIMATION   1 35 40 45
+  ! DATA (GA( 4,11,IC),IC=1,3) /
+  ! S 0.85622405E+01,-0.58705980E+00, 0.00000000E+00/
+  ! DATA (GB( 4,11,IC),IC=1,3) /
+  ! S 0.85622405E+01, 0.19955244E+02, 0.10000000E+01/
+  ! DATA (GA( 4,12,IC),IC=1,3) /
+  ! S 0.10564339E+02,-0.40712065E+00, 0.00000000E+00/
+  ! DATA (GB( 4,12,IC),IC=1,3) /
+  ! S 0.10564339E+02, 0.24951120E+02, 0.10000000E+01/
+
+  ! ----- INTERVAL = 6 ----- T =  237.5
+
+  ! -- INDICES FOR PADE APPROXIMATION   1 35 40 45
+  ! DATA (GA( 5,11,IC),IC=1,3) /
+  ! S 0.94892164E+01,-0.49305772E+00, 0.00000000E+00/
+  ! DATA (GB( 5,11,IC),IC=1,3) /
+  ! S 0.94892164E+01, 0.22227100E+02, 0.10000000E+01/
+  ! DATA (GA( 5,12,IC),IC=1,3) /
+  ! S 0.46896789E+02,-0.15295996E+01, 0.00000000E+00/
+  ! DATA (GB( 5,12,IC),IC=1,3) /
+  ! S 0.46896789E+02, 0.10957372E+03, 0.10000000E+01/
+
+  ! ----- INTERVAL = 6 ----- T =  250.0
+
+  ! -- INDICES FOR PADE APPROXIMATION   1 35 40 45
+  ! DATA (GA( 6,11,IC),IC=1,3) /
+  ! S 0.13580937E+02,-0.51461431E+00, 0.00000000E+00/
+  ! DATA (GB( 6,11,IC),IC=1,3) /
+  ! S 0.13580937E+02, 0.31770288E+02, 0.10000000E+01/
+  ! DATA (GA( 6,12,IC),IC=1,3) /
+  ! S-0.30926524E+01, 0.43555255E+00, 0.00000000E+00/
+  ! DATA (GB( 6,12,IC),IC=1,3) /
+  ! S-0.30926524E+01,-0.67432659E+01, 0.10000000E+01/
+
+  ! ----- INTERVAL = 6 ----- T =  262.5
+
+  ! -- INDICES FOR PADE APPROXIMATION   1 35 40 45
+  ! DATA (GA( 7,11,IC),IC=1,3) /
+  ! S-0.32050918E+03, 0.12373350E+02, 0.00000000E+00/
+  ! DATA (GB( 7,11,IC),IC=1,3) /
+  ! S-0.32050918E+03,-0.74061287E+03, 0.10000000E+01/
+  ! DATA (GA( 7,12,IC),IC=1,3) /
+  ! S 0.85742941E+00, 0.50380874E+00, 0.00000000E+00/
+  ! DATA (GB( 7,12,IC),IC=1,3) /
+  ! S 0.85742941E+00, 0.24550746E+01, 0.10000000E+01/
+
+  ! ----- INTERVAL = 6 ----- T =  275.0
+
+  ! -- INDICES FOR PADE APPROXIMATION   1 35 40 45
+  ! DATA (GA( 8,11,IC),IC=1,3) /
+  ! S-0.37133165E+01, 0.44809588E+00, 0.00000000E+00/
+  ! DATA (GB( 8,11,IC),IC=1,3) /
+  ! S-0.37133165E+01,-0.81329826E+01, 0.10000000E+01/
+  ! DATA (GA( 8,12,IC),IC=1,3) /
+  ! S 0.19164038E+01, 0.68537352E+00, 0.00000000E+00/
+  ! DATA (GB( 8,12,IC),IC=1,3) /
+  ! S 0.19164038E+01, 0.49089917E+01, 0.10000000E+01/
+
+  ! ----- INTERVAL = 6 ----- T =  287.5
+
+  ! -- INDICES FOR PADE APPROXIMATION   1 35 40 45
+  ! DATA (GA( 9,11,IC),IC=1,3) /
+  ! S 0.18890836E+00, 0.46548918E+00, 0.00000000E+00/
+  ! DATA (GB( 9,11,IC),IC=1,3) /
+  ! S 0.18890836E+00, 0.90279822E+00, 0.10000000E+01/
+  ! DATA (GA( 9,12,IC),IC=1,3) /
+  ! S 0.23513199E+01, 0.89437630E+00, 0.00000000E+00/
+  ! DATA (GB( 9,12,IC),IC=1,3) /
+  ! S 0.23513199E+01, 0.59008712E+01, 0.10000000E+01/
+
+  ! ----- INTERVAL = 6 ----- T =  300.0
+
+  ! -- INDICES FOR PADE APPROXIMATION   1 35 40 45
+  ! DATA (GA(10,11,IC),IC=1,3) /
+  ! S 0.14209226E+01, 0.59121475E+00, 0.00000000E+00/
+  ! DATA (GB(10,11,IC),IC=1,3) /
+  ! S 0.14209226E+01, 0.37532746E+01, 0.10000000E+01/
+  ! DATA (GA(10,12,IC),IC=1,3) /
+  ! S 0.25566644E+01, 0.11127003E+01, 0.00000000E+00/
+  ! DATA (GB(10,12,IC),IC=1,3) /
+  ! S 0.25566644E+01, 0.63532616E+01, 0.10000000E+01/
+
+  ! ----- INTERVAL = 6 ----- T =  312.5
+
+  ! -- INDICES FOR PADE APPROXIMATION   1 35 40 45
+  ! DATA (GA(11,11,IC),IC=1,3) /
+  ! S 0.19817679E+01, 0.74676119E+00, 0.00000000E+00/
+  ! DATA (GB(11,11,IC),IC=1,3) /
+  ! S 0.19817679E+01, 0.50437916E+01, 0.10000000E+01/
+  ! DATA (GA(11,12,IC),IC=1,3) /
+  ! S 0.26555181E+01, 0.13329782E+01, 0.00000000E+00/
+  ! DATA (GB(11,12,IC),IC=1,3) /
+  ! S 0.26555181E+01, 0.65558627E+01, 0.10000000E+01/
+
+
+
+
+
+  ! -- END WATER VAPOR
+
+
+  ! -- CO2 -- INT.2 -- 500-800 CM-1 --- FROM ABS225 ----------------------
+
+
+
+  ! -- FIU = 0.8 + MAX(0.35,(7-IU)*0.9)  , X/T,  9
+
+  ! ----- INTERVAL = 2 ----- T =  187.5
+
+  ! -- INDICES FOR PADE APPROXIMATION   1 30 38 45
+  ! DATA (GA( 1,13,IC),IC=1,3) /
+  ! S 0.87668459E-01, 0.13845511E+01, 0.00000000E+00/
+  ! DATA (GB( 1,13,IC),IC=1,3) /
+  ! S 0.87668459E-01, 0.23203798E+01, 0.10000000E+01/
+  ! DATA (GA( 1,14,IC),IC=1,3) /
+  ! S 0.74878820E-01, 0.11718758E+01, 0.00000000E+00/
+  ! DATA (GB( 1,14,IC),IC=1,3) /
+  ! S 0.74878820E-01, 0.20206726E+01, 0.10000000E+01/
+
+  ! ----- INTERVAL = 2 ----- T =  200.0
+
+  ! -- INDICES FOR PADE APPROXIMATION   1 30 38 45
+  ! DATA (GA( 2,13,IC),IC=1,3) /
+  ! S 0.83754276E-01, 0.13187042E+01, 0.00000000E+00/
+  ! DATA (GB( 2,13,IC),IC=1,3) /
+  ! S 0.83754276E-01, 0.22288925E+01, 0.10000000E+01/
+  ! DATA (GA( 2,14,IC),IC=1,3) /
+  ! S 0.71650966E-01, 0.11216131E+01, 0.00000000E+00/
+  ! DATA (GB( 2,14,IC),IC=1,3) /
+  ! S 0.71650966E-01, 0.19441824E+01, 0.10000000E+01/
+
+  ! ----- INTERVAL = 2 ----- T =  212.5
+
+  ! -- INDICES FOR PADE APPROXIMATION   1 30 38 45
+  ! DATA (GA( 3,13,IC),IC=1,3) /
+  ! S 0.80460283E-01, 0.12644396E+01, 0.00000000E+00/
+  ! DATA (GB( 3,13,IC),IC=1,3) /
+  ! S 0.80460283E-01, 0.21515593E+01, 0.10000000E+01/
+  ! DATA (GA( 3,14,IC),IC=1,3) /
+  ! S 0.68979615E-01, 0.10809473E+01, 0.00000000E+00/
+  ! DATA (GB( 3,14,IC),IC=1,3) /
+  ! S 0.68979615E-01, 0.18807257E+01, 0.10000000E+01/
+
+  ! ----- INTERVAL = 2 ----- T =  225.0
+
+  ! -- INDICES FOR PADE APPROXIMATION   1 30 38 45
+  ! DATA (GA( 4,13,IC),IC=1,3) /
+  ! S 0.77659686E-01, 0.12191543E+01, 0.00000000E+00/
+  ! DATA (GB( 4,13,IC),IC=1,3) /
+  ! S 0.77659686E-01, 0.20855896E+01, 0.10000000E+01/
+  ! DATA (GA( 4,14,IC),IC=1,3) /
+  ! S 0.66745345E-01, 0.10476396E+01, 0.00000000E+00/
+  ! DATA (GB( 4,14,IC),IC=1,3) /
+  ! S 0.66745345E-01, 0.18275618E+01, 0.10000000E+01/
+
+  ! ----- INTERVAL = 2 ----- T =  237.5
+
+  ! -- INDICES FOR PADE APPROXIMATION   1 30 38 45
+  ! DATA (GA( 5,13,IC),IC=1,3) /
+  ! S 0.75257056E-01, 0.11809511E+01, 0.00000000E+00/
+  ! DATA (GB( 5,13,IC),IC=1,3) /
+  ! S 0.75257056E-01, 0.20288489E+01, 0.10000000E+01/
+  ! DATA (GA( 5,14,IC),IC=1,3) /
+  ! S 0.64857571E-01, 0.10200373E+01, 0.00000000E+00/
+  ! DATA (GB( 5,14,IC),IC=1,3) /
+  ! S 0.64857571E-01, 0.17825910E+01, 0.10000000E+01/
+
+  ! ----- INTERVAL = 2 ----- T =  250.0
+
+  ! -- INDICES FOR PADE APPROXIMATION   1 30 38 45
+  ! DATA (GA( 6,13,IC),IC=1,3) /
+  ! S 0.73179175E-01, 0.11484154E+01, 0.00000000E+00/
+  ! DATA (GB( 6,13,IC),IC=1,3) /
+  ! S 0.73179175E-01, 0.19796791E+01, 0.10000000E+01/
+  ! DATA (GA( 6,14,IC),IC=1,3) /
+  ! S 0.63248495E-01, 0.99692726E+00, 0.00000000E+00/
+  ! DATA (GB( 6,14,IC),IC=1,3) /
+  ! S 0.63248495E-01, 0.17442308E+01, 0.10000000E+01/
+
+  ! ----- INTERVAL = 2 ----- T =  262.5
+
+  ! -- INDICES FOR PADE APPROXIMATION   1 30 38 45
+  ! DATA (GA( 7,13,IC),IC=1,3) /
+  ! S 0.71369063E-01, 0.11204723E+01, 0.00000000E+00/
+  ! DATA (GB( 7,13,IC),IC=1,3) /
+  ! S 0.71369063E-01, 0.19367778E+01, 0.10000000E+01/
+  ! DATA (GA( 7,14,IC),IC=1,3) /
+  ! S 0.61866970E-01, 0.97740923E+00, 0.00000000E+00/
+  ! DATA (GB( 7,14,IC),IC=1,3) /
+  ! S 0.61866970E-01, 0.17112809E+01, 0.10000000E+01/
+
+  ! ----- INTERVAL = 2 ----- T =  275.0
+
+  ! -- INDICES FOR PADE APPROXIMATION   1 30 38 45
+  ! DATA (GA( 8,13,IC),IC=1,3) /
+  ! S 0.69781812E-01, 0.10962918E+01, 0.00000000E+00/
+  ! DATA (GB( 8,13,IC),IC=1,3) /
+  ! S 0.69781812E-01, 0.18991112E+01, 0.10000000E+01/
+  ! DATA (GA( 8,14,IC),IC=1,3) /
+  ! S 0.60673632E-01, 0.96080188E+00, 0.00000000E+00/
+  ! DATA (GB( 8,14,IC),IC=1,3) /
+  ! S 0.60673632E-01, 0.16828137E+01, 0.10000000E+01/
+
+  ! ----- INTERVAL = 2 ----- T =  287.5
+
+  ! -- INDICES FOR PADE APPROXIMATION   1 30 38 45
+  ! DATA (GA( 9,13,IC),IC=1,3) /
+  ! S 0.68381606E-01, 0.10752229E+01, 0.00000000E+00/
+  ! DATA (GB( 9,13,IC),IC=1,3) /
+  ! S 0.68381606E-01, 0.18658501E+01, 0.10000000E+01/
+  ! DATA (GA( 9,14,IC),IC=1,3) /
+  ! S 0.59637277E-01, 0.94657562E+00, 0.00000000E+00/
+  ! DATA (GB( 9,14,IC),IC=1,3) /
+  ! S 0.59637277E-01, 0.16580908E+01, 0.10000000E+01/
+
+  ! ----- INTERVAL = 2 ----- T =  300.0
+
+  ! -- INDICES FOR PADE APPROXIMATION   1 30 38 45
+  ! DATA (GA(10,13,IC),IC=1,3) /
+  ! S 0.67139539E-01, 0.10567474E+01, 0.00000000E+00/
+  ! DATA (GB(10,13,IC),IC=1,3) /
+  ! S 0.67139539E-01, 0.18363226E+01, 0.10000000E+01/
+  ! DATA (GA(10,14,IC),IC=1,3) /
+  ! S 0.58732178E-01, 0.93430511E+00, 0.00000000E+00/
+  ! DATA (GB(10,14,IC),IC=1,3) /
+  ! S 0.58732178E-01, 0.16365014E+01, 0.10000000E+01/
+
+  ! ----- INTERVAL = 2 ----- T =  312.5
+
+  ! -- INDICES FOR PADE APPROXIMATION   1 30 38 45
+  ! DATA (GA(11,13,IC),IC=1,3) /
+  ! S 0.66032012E-01, 0.10404465E+01, 0.00000000E+00/
+  ! DATA (GB(11,13,IC),IC=1,3) /
+  ! S 0.66032012E-01, 0.18099779E+01, 0.10000000E+01/
+  ! DATA (GA(11,14,IC),IC=1,3) /
+  ! S 0.57936092E-01, 0.92363528E+00, 0.00000000E+00/
+  ! DATA (GB(11,14,IC),IC=1,3) /
+  ! S 0.57936092E-01, 0.16175164E+01, 0.10000000E+01/
+
+
+
+
+
+
+
+
+
+
+  ! -- CARBON DIOXIDE LINES IN THE WINDOW REGION (800-1250 CM-1)
+
+
+  ! -- G = 0.0
+
+
+  ! ----- INTERVAL = 4 ----- T =  187.5
+
+  ! -- INDICES FOR PADE APPROXIMATION     1   15   29   45
+  ! DATA (GA( 1,15,IC),IC=1,3) /
+  ! S 0.13230067E+02, 0.22042132E+02, 0.00000000E+00/
+  ! DATA (GB( 1,15,IC),IC=1,3) /
+  ! S 0.13230067E+02, 0.22051750E+02, 0.10000000E+01/
+  ! DATA (GA( 1,16,IC),IC=1,3) /
+  ! S 0.13183816E+02, 0.22169501E+02, 0.00000000E+00/
+  ! DATA (GB( 1,16,IC),IC=1,3) /
+  ! S 0.13183816E+02, 0.22178972E+02, 0.10000000E+01/
+
+  ! ----- INTERVAL = 4 ----- T =  200.0
+
+  ! -- INDICES FOR PADE APPROXIMATION     1   15   29   45
+  ! DATA (GA( 2,15,IC),IC=1,3) /
+  ! S 0.13213564E+02, 0.22107298E+02, 0.00000000E+00/
+  ! DATA (GB( 2,15,IC),IC=1,3) /
+  ! S 0.13213564E+02, 0.22116850E+02, 0.10000000E+01/
+  ! DATA (GA( 2,16,IC),IC=1,3) /
+  ! S 0.13189991E+02, 0.22270075E+02, 0.00000000E+00/
+  ! DATA (GB( 2,16,IC),IC=1,3) /
+  ! S 0.13189991E+02, 0.22279484E+02, 0.10000000E+01/
+
+  ! ----- INTERVAL = 4 ----- T =  212.5
+
+  ! -- INDICES FOR PADE APPROXIMATION     1   15   29   45
+  ! DATA (GA( 3,15,IC),IC=1,3) /
+  ! S 0.13209140E+02, 0.22180915E+02, 0.00000000E+00/
+  ! DATA (GB( 3,15,IC),IC=1,3) /
+  ! S 0.13209140E+02, 0.22190410E+02, 0.10000000E+01/
+  ! DATA (GA( 3,16,IC),IC=1,3) /
+  ! S 0.13209485E+02, 0.22379193E+02, 0.00000000E+00/
+  ! DATA (GB( 3,16,IC),IC=1,3) /
+  ! S 0.13209485E+02, 0.22388551E+02, 0.10000000E+01/
+
+  ! ----- INTERVAL = 4 ----- T =  225.0
+
+  ! -- INDICES FOR PADE APPROXIMATION     1   15   29   45
+  ! DATA (GA( 4,15,IC),IC=1,3) /
+  ! S 0.13213894E+02, 0.22259478E+02, 0.00000000E+00/
+  ! DATA (GB( 4,15,IC),IC=1,3) /
+  ! S 0.13213894E+02, 0.22268925E+02, 0.10000000E+01/
+  ! DATA (GA( 4,16,IC),IC=1,3) /
+  ! S 0.13238789E+02, 0.22492992E+02, 0.00000000E+00/
+  ! DATA (GB( 4,16,IC),IC=1,3) /
+  ! S 0.13238789E+02, 0.22502309E+02, 0.10000000E+01/
+
+  ! ----- INTERVAL = 4 ----- T =  237.5
+
+  ! -- INDICES FOR PADE APPROXIMATION     1   15   29   45
+  ! DATA (GA( 5,15,IC),IC=1,3) /
+  ! S 0.13225963E+02, 0.22341039E+02, 0.00000000E+00/
+  ! DATA (GB( 5,15,IC),IC=1,3) /
+  ! S 0.13225963E+02, 0.22350445E+02, 0.10000000E+01/
+  ! DATA (GA( 5,16,IC),IC=1,3) /
+  ! S 0.13275017E+02, 0.22608508E+02, 0.00000000E+00/
+  ! DATA (GB( 5,16,IC),IC=1,3) /
+  ! S 0.13275017E+02, 0.22617792E+02, 0.10000000E+01/
+
+  ! ----- INTERVAL = 4 ----- T =  250.0
+
+  ! -- INDICES FOR PADE APPROXIMATION     1   15   29   45
+  ! DATA (GA( 6,15,IC),IC=1,3) /
+  ! S 0.13243806E+02, 0.22424247E+02, 0.00000000E+00/
+  ! DATA (GB( 6,15,IC),IC=1,3) /
+  ! S 0.13243806E+02, 0.22433617E+02, 0.10000000E+01/
+  ! DATA (GA( 6,16,IC),IC=1,3) /
+  ! S 0.13316096E+02, 0.22723843E+02, 0.00000000E+00/
+  ! DATA (GB( 6,16,IC),IC=1,3) /
+  ! S 0.13316096E+02, 0.22733099E+02, 0.10000000E+01/
+
+  ! ----- INTERVAL = 4 ----- T =  262.5
+
+  ! -- INDICES FOR PADE APPROXIMATION     1   15   29   45
+  ! DATA (GA( 7,15,IC),IC=1,3) /
+  ! S 0.13266104E+02, 0.22508089E+02, 0.00000000E+00/
+  ! DATA (GB( 7,15,IC),IC=1,3) /
+  ! S 0.13266104E+02, 0.22517429E+02, 0.10000000E+01/
+  ! DATA (GA( 7,16,IC),IC=1,3) /
+  ! S 0.13360555E+02, 0.22837837E+02, 0.00000000E+00/
+  ! DATA (GB( 7,16,IC),IC=1,3) /
+  ! S 0.13360555E+02, 0.22847071E+02, 0.10000000E+01/
+
+  ! ----- INTERVAL = 4 ----- T =  275.0
+
+  ! -- INDICES FOR PADE APPROXIMATION     1   15   29   45
+  ! DATA (GA( 8,15,IC),IC=1,3) /
+  ! S 0.13291782E+02, 0.22591771E+02, 0.00000000E+00/
+  ! DATA (GB( 8,15,IC),IC=1,3) /
+  ! S 0.13291782E+02, 0.22601086E+02, 0.10000000E+01/
+  ! DATA (GA( 8,16,IC),IC=1,3) /
+  ! S 0.13407324E+02, 0.22949751E+02, 0.00000000E+00/
+  ! DATA (GB( 8,16,IC),IC=1,3) /
+  ! S 0.13407324E+02, 0.22958967E+02, 0.10000000E+01/
+
+  ! ----- INTERVAL = 4 ----- T =  287.5
+
+  ! -- INDICES FOR PADE APPROXIMATION     1   15   29   45
+  ! DATA (GA( 9,15,IC),IC=1,3) /
+  ! S 0.13319961E+02, 0.22674661E+02, 0.00000000E+00/
+  ! DATA (GB( 9,15,IC),IC=1,3) /
+  ! S 0.13319961E+02, 0.22683956E+02, 0.10000000E+01/
+  ! DATA (GA( 9,16,IC),IC=1,3) /
+  ! S 0.13455544E+02, 0.23059032E+02, 0.00000000E+00/
+  ! DATA (GB( 9,16,IC),IC=1,3) /
+  ! S 0.13455544E+02, 0.23068234E+02, 0.10000000E+01/
+
+  ! ----- INTERVAL = 4 ----- T =  300.0
+
+  ! -- INDICES FOR PADE APPROXIMATION     1   15   29   45
+  ! DATA (GA(10,15,IC),IC=1,3) /
+  ! S 0.13349927E+02, 0.22756246E+02, 0.00000000E+00/
+  ! DATA (GB(10,15,IC),IC=1,3) /
+  ! S 0.13349927E+02, 0.22765522E+02, 0.10000000E+01/
+  ! DATA (GA(10,16,IC),IC=1,3) /
+  ! S 0.13504450E+02, 0.23165146E+02, 0.00000000E+00/
+  ! DATA (GB(10,16,IC),IC=1,3) /
+  ! S 0.13504450E+02, 0.23174336E+02, 0.10000000E+01/
+
+  ! ----- INTERVAL = 4 ----- T =  312.5
+
+  ! -- INDICES FOR PADE APPROXIMATION     1   15   29   45
+  ! DATA (GA(11,15,IC),IC=1,3) /
+  ! S 0.13381108E+02, 0.22836093E+02, 0.00000000E+00/
+  ! DATA (GB(11,15,IC),IC=1,3) /
+  ! S 0.13381108E+02, 0.22845354E+02, 0.10000000E+01/
+  ! DATA (GA(11,16,IC),IC=1,3) /
+  ! S 0.13553282E+02, 0.23267456E+02, 0.00000000E+00/
+  ! DATA (GB(11,16,IC),IC=1,3) /
+  ! S 0.13553282E+02, 0.23276638E+02, 0.10000000E+01/
+
+  ! ------------------------------------------------------------------
+  ! DATA (( XP(  J,K),J=1,6),       K=1,6) /
+  ! S 0.46430621E+02, 0.12928299E+03, 0.20732648E+03,
+  ! S 0.31398411E+03, 0.18373177E+03,-0.11412303E+03,
+  ! S 0.73604774E+02, 0.27887914E+03, 0.27076947E+03,
+  ! S-0.57322111E+02,-0.64742459E+02, 0.87238280E+02,
+  ! S 0.37050866E+02, 0.20498759E+03, 0.37558029E+03,
+  ! S 0.17401171E+03,-0.13350302E+03,-0.37651795E+02,
+  ! S 0.14930141E+02, 0.89161160E+02, 0.17793062E+03,
+  ! S 0.93433860E+02,-0.70646020E+02,-0.26373150E+02,
+  ! S 0.40386780E+02, 0.10855270E+03, 0.50755010E+02,
+  ! S-0.31496190E+02, 0.12791300E+00, 0.18017770E+01,
+  ! S 0.90811926E+01, 0.75073923E+02, 0.24654438E+03,
+  ! S 0.39332612E+03, 0.29385281E+03, 0.89107921E+02 /
+
+
+
+  ! *         1.0     PLANCK FUNCTIONS AND GRADIENTS
+  ! ------------------------------
+
+
+  ! cdir collapse
+  DO jk = 1, kflev + 1
+    DO jl = 1, kdlon
+      pbint(jl, jk) = 0.
+    END DO
+  END DO
+  DO jl = 1, kdlon
+    pbsuin(jl) = 0.
+  END DO
+
+  DO jnu = 1, ninter
+
+    ! *         1.1   LEVELS FROM SURFACE TO KFLEV
+    ! ----------------------------
+
+
+    DO jk = 1, kflev
+      DO jl = 1, kdlon
+        zti(jl) = (ptl(jl,jk)-tstand)/tstand
+        zres(jl) = xp(1, jnu) + zti(jl)*(xp(2,jnu)+zti(jl)*(xp(3, &
+          jnu)+zti(jl)*(xp(4,jnu)+zti(jl)*(xp(5,jnu)+zti(jl)*(xp(6,jnu))))))
+        pbint(jl, jk) = pbint(jl, jk) + zres(jl)
+        pb(jl, jnu, jk) = zres(jl)
+        zblev(jl, jk) = zres(jl)
+        zti2(jl) = (ptave(jl,jk)-tstand)/tstand
+        zres2(jl) = xp(1, jnu) + zti2(jl)*(xp(2,jnu)+zti2(jl)*(xp(3, &
+          jnu)+zti2(jl)*(xp(4,jnu)+zti2(jl)*(xp(5,jnu)+zti2(jl)*(xp(6,jnu)))) &
+          ))
+        zblay(jl, jk) = zres2(jl)
+      END DO
+    END DO
+
+    ! *         1.2   TOP OF THE ATMOSPHERE AND SURFACE
+    ! ---------------------------------
+
+
+    DO jl = 1, kdlon
+      zti(jl) = (ptl(jl,kflev+1)-tstand)/tstand
+      zti2(jl) = (ptl(jl,1)+pdt0(jl)-tstand)/tstand
+      zres(jl) = xp(1, jnu) + zti(jl)*(xp(2,jnu)+zti(jl)*(xp(3, &
+        jnu)+zti(jl)*(xp(4,jnu)+zti(jl)*(xp(5,jnu)+zti(jl)*(xp(6,jnu))))))
+      zres2(jl) = xp(1, jnu) + zti2(jl)*(xp(2,jnu)+zti2(jl)*(xp(3, &
+        jnu)+zti2(jl)*(xp(4,jnu)+zti2(jl)*(xp(5,jnu)+zti2(jl)*(xp(6,jnu))))))
+      pbint(jl, kflev+1) = pbint(jl, kflev+1) + zres(jl)
+      pb(jl, jnu, kflev+1) = zres(jl)
+      zblev(jl, kflev+1) = zres(jl)
+      pbtop(jl, jnu) = zres(jl)
+      pbsur(jl, jnu) = zres2(jl)
+      pbsuin(jl) = pbsuin(jl) + zres2(jl)
+    END DO
+
+    ! *         1.3   GRADIENTS IN SUB-LAYERS
+    ! -----------------------
+
+
+    DO jk = 1, kflev
+      jk2 = 2*jk
+      jk1 = jk2 - 1
+      DO jl = 1, kdlon
+        pdbsl(jl, jnu, jk1) = zblay(jl, jk) - zblev(jl, jk)
+        pdbsl(jl, jnu, jk2) = zblev(jl, jk+1) - zblay(jl, jk)
+      END DO
+    END DO
+
+  END DO
+
+  ! *         2.0   CHOOSE THE RELEVANT SETS OF PADE APPROXIMANTS
+  ! ---------------------------------------------
+
+
+
+
+  DO jl = 1, kdlon
+    zdsto1 = (ptl(jl,kflev+1)-tintp(1))/tstp
+    ixtox = max(1, min(mxixt,int(zdsto1+1.)))
+    zdstox = (ptl(jl,kflev+1)-tintp(ixtox))/tstp
+    IF (zdstox<0.5) THEN
+      indto = ixtox
+    ELSE
+      indto = ixtox + 1
+    END IF
+    indb(jl) = indto
+    zdst1 = (ptl(jl,1)-tintp(1))/tstp
+    ixtx = max(1, min(mxixt,int(zdst1+1.)))
+    zdstx = (ptl(jl,1)-tintp(ixtx))/tstp
+    IF (zdstx<0.5) THEN
+      indt = ixtx
+    ELSE
+      indt = ixtx + 1
+    END IF
+    inds(jl) = indt
+  END DO
+
+  DO jf = 1, 2
+    DO jg = 1, 8
+      DO jl = 1, kdlon
+        indsu = inds(jl)
+        pgasur(jl, jg, jf) = ga(indsu, 2*jg-1, jf)
+        pgbsur(jl, jg, jf) = gb(indsu, 2*jg-1, jf)
+        indtp = indb(jl)
+        pgatop(jl, jg, jf) = ga(indtp, 2*jg-1, jf)
+        pgbtop(jl, jg, jf) = gb(indtp, 2*jg-1, jf)
+      END DO
+    END DO
+  END DO
+
+  DO jk = 1, kflev
+    DO jl = 1, kdlon
+      zdst1 = (ptave(jl,jk)-tintp(1))/tstp
+      ixtx = max(1, min(mxixt,int(zdst1+1.)))
+      zdstx = (ptave(jl,jk)-tintp(ixtx))/tstp
+      IF (zdstx<0.5) THEN
+        indt = ixtx
+      ELSE
+        indt = ixtx + 1
+      END IF
+      indb(jl) = indt
+    END DO
+
+    DO jf = 1, 2
+      DO jg = 1, 8
+        DO jl = 1, kdlon
+          indt = indb(jl)
+          pga(jl, jg, jf, jk) = ga(indt, 2*jg, jf)
+          pgb(jl, jg, jf, jk) = gb(indt, 2*jg, jf)
+        END DO
+      END DO
+    END DO
+  END DO
+
+  ! ------------------------------------------------------------------
+
+  RETURN
+END SUBROUTINE lwb_lmdar4
+SUBROUTINE lwv_lmdar4(kuaer, ktraer, klim, pabcu, pb, pbint, pbsuin, pbsur, &
+    pbtop, pdbsl, pemis, ppmb, ptave, pga, pgb, pgasur, pgbsur, pgatop, &
+    pgbtop, pcntrb, pcts, pfluc)
+  USE dimphy
+  IMPLICIT NONE
+  include "raddimlw.h"
+  include "YOMCST.h"
+
+  ! -----------------------------------------------------------------------
+  ! PURPOSE.
+  ! --------
+  ! CARRIES OUT THE VERTICAL INTEGRATION TO GIVE LONGWAVE
+  ! FLUXES OR RADIANCES
+
+  ! METHOD.
+  ! -------
+
+  ! 1. PERFORMS THE VERTICAL INTEGRATION DISTINGUISHING BETWEEN
+  ! CONTRIBUTIONS BY -  THE NEARBY LAYERS
+  ! -  THE DISTANT LAYERS
+  ! -  THE BOUNDARY TERMS
+  ! 2. COMPUTES THE CLEAR-SKY DOWNWARD AND UPWARD EMISSIVITIES.
+
+  ! REFERENCE.
+  ! ----------
+
+  ! SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+  ! ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
+
+  ! AUTHOR.
+  ! -------
+  ! JEAN-JACQUES MORCRETTE  *ECMWF*
+
+  ! MODIFICATIONS.
+  ! --------------
+  ! ORIGINAL : 89-07-14
+  ! -----------------------------------------------------------------------
+
+  ! * ARGUMENTS:
+  INTEGER kuaer, ktraer, klim
+
+  REAL (KIND=8) pabcu(kdlon, nua, 3*kflev+1) ! EFFECTIVE ABSORBER AMOUNTS
+  REAL (KIND=8) pb(kdlon, ninter, kflev+1) ! SPECTRAL HALF-LEVEL PLANCK FUNCTIONS
+  REAL (KIND=8) pbint(kdlon, kflev+1) ! HALF-LEVEL PLANCK FUNCTIONS
+  REAL (KIND=8) pbsur(kdlon, ninter) ! SURFACE SPECTRAL PLANCK FUNCTION
+  REAL (KIND=8) pbsuin(kdlon) ! SURFACE PLANCK FUNCTION
+  REAL (KIND=8) pbtop(kdlon, ninter) ! T.O.A. SPECTRAL PLANCK FUNCTION
+  REAL (KIND=8) pdbsl(kdlon, ninter, kflev*2) ! SUB-LAYER PLANCK FUNCTION GRADIENT
+  REAL (KIND=8) pemis(kdlon) ! SURFACE EMISSIVITY
+  REAL (KIND=8) ppmb(kdlon, kflev+1) ! HALF-LEVEL PRESSURE (MB)
+  REAL (KIND=8) ptave(kdlon, kflev) ! TEMPERATURE
+  REAL (KIND=8) pga(kdlon, 8, 2, kflev) ! PADE APPROXIMANTS
+  REAL (KIND=8) pgb(kdlon, 8, 2, kflev) ! PADE APPROXIMANTS
+  REAL (KIND=8) pgasur(kdlon, 8, 2) ! PADE APPROXIMANTS
+  REAL (KIND=8) pgbsur(kdlon, 8, 2) ! PADE APPROXIMANTS
+  REAL (KIND=8) pgatop(kdlon, 8, 2) ! PADE APPROXIMANTS
+  REAL (KIND=8) pgbtop(kdlon, 8, 2) ! PADE APPROXIMANTS
+
+  REAL (KIND=8) pcntrb(kdlon, kflev+1, kflev+1) ! CLEAR-SKY ENERGY EXCHANGE MATRIX
+  REAL (KIND=8) pcts(kdlon, kflev) ! COOLING-TO-SPACE TERM
+  REAL (KIND=8) pfluc(kdlon, 2, kflev+1) ! CLEAR-SKY RADIATIVE FLUXES
+  ! -----------------------------------------------------------------------
+  ! LOCAL VARIABLES:
+  REAL (KIND=8) zadjd(kdlon, kflev+1)
+  REAL (KIND=8) zadju(kdlon, kflev+1)
+  REAL (KIND=8) zdbdt(kdlon, ninter, kflev)
+  REAL (KIND=8) zdisd(kdlon, kflev+1)
+  REAL (KIND=8) zdisu(kdlon, kflev+1)
+
+  INTEGER jk, jl
+  ! -----------------------------------------------------------------------
+
+  DO jk = 1, kflev + 1
+    DO jl = 1, kdlon
+      zadjd(jl, jk) = 0.
+      zadju(jl, jk) = 0.
+      zdisd(jl, jk) = 0.
+      zdisu(jl, jk) = 0.
+    END DO
+  END DO
+
+  DO jk = 1, kflev
+    DO jl = 1, kdlon
+      pcts(jl, jk) = 0.
+    END DO
+  END DO
+
+  ! * CONTRIBUTION FROM ADJACENT LAYERS
+
+  CALL lwvn_lmdar4(kuaer, ktraer, pabcu, pdbsl, pga, pgb, zadjd, zadju, &
+    pcntrb, zdbdt)
+  ! * CONTRIBUTION FROM DISTANT LAYERS
+
+  CALL lwvd_lmdar4(kuaer, ktraer, pabcu, zdbdt, pga, pgb, pcntrb, zdisd, &
+    zdisu)
+
+  ! * EXCHANGE WITH THE BOUNDARIES
+
+  CALL lwvb_lmdar4(kuaer, ktraer, klim, pabcu, zadjd, zadju, pb, pbint, &
+    pbsuin, pbsur, pbtop, zdisd, zdisu, pemis, ppmb, pga, pgb, pgasur, &
+    pgbsur, pgatop, pgbtop, pcts, pfluc)
+
+
+  RETURN
+END SUBROUTINE lwv_lmdar4
+SUBROUTINE lwvb_lmdar4(kuaer, ktraer, klim, pabcu, padjd, padju, pb, pbint, &
+    pbsui, pbsur, pbtop, pdisd, pdisu, pemis, ppmb, pga, pgb, pgasur, pgbsur, &
+    pgatop, pgbtop, pcts, pfluc)
+  USE dimphy
+  IMPLICIT NONE
+  include "raddimlw.h"
+  include "radopt.h"
+
+  ! -----------------------------------------------------------------------
+  ! PURPOSE.
+  ! --------
+  ! INTRODUCES THE EFFECTS OF THE BOUNDARIES IN THE VERTICAL
+  ! INTEGRATION
+
+  ! METHOD.
+  ! -------
+
+  ! 1. COMPUTES THE ENERGY EXCHANGE WITH TOP AND SURFACE OF THE
+  ! ATMOSPHERE
+  ! 2. COMPUTES THE COOLING-TO-SPACE AND HEATING-FROM-GROUND
+  ! TERMS FOR THE APPROXIMATE COOLING RATE ABOVE 10 HPA
+  ! 3. ADDS UP ALL CONTRIBUTIONS TO GET THE CLEAR-SKY FLUXES
+
+  ! REFERENCE.
+  ! ----------
+
+  ! SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+  ! ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
+
+  ! AUTHOR.
+  ! -------
+  ! JEAN-JACQUES MORCRETTE  *ECMWF*
+
+  ! MODIFICATIONS.
+  ! --------------
+  ! ORIGINAL : 89-07-14
+  ! Voigt lines (loop 2413 to 2427)  - JJM & PhD - 01/96
+  ! -----------------------------------------------------------------------
+
+  ! *       0.1   ARGUMENTS
+  ! ---------
+
+  INTEGER kuaer, ktraer, klim
+
+  REAL (KIND=8) pabcu(kdlon, nua, 3*kflev+1) ! ABSORBER AMOUNTS
+  REAL (KIND=8) padjd(kdlon, kflev+1) ! CONTRIBUTION BY ADJACENT LAYERS
+  REAL (KIND=8) padju(kdlon, kflev+1) ! CONTRIBUTION BY ADJACENT LAYERS
+  REAL (KIND=8) pb(kdlon, ninter, kflev+1) ! SPECTRAL HALF-LEVEL PLANCK FUNCTIONS
+  REAL (KIND=8) pbint(kdlon, kflev+1) ! HALF-LEVEL PLANCK FUNCTIONS
+  REAL (KIND=8) pbsur(kdlon, ninter) ! SPECTRAL SURFACE PLANCK FUNCTION
+  REAL (KIND=8) pbsui(kdlon) ! SURFACE PLANCK FUNCTION
+  REAL (KIND=8) pbtop(kdlon, ninter) ! SPECTRAL T.O.A. PLANCK FUNCTION
+  REAL (KIND=8) pdisd(kdlon, kflev+1) ! CONTRIBUTION BY DISTANT LAYERS
+  REAL (KIND=8) pdisu(kdlon, kflev+1) ! CONTRIBUTION BY DISTANT LAYERS
+  REAL (KIND=8) pemis(kdlon) ! SURFACE EMISSIVITY
+  REAL (KIND=8) ppmb(kdlon, kflev+1) ! PRESSURE MB
+  REAL (KIND=8) pga(kdlon, 8, 2, kflev) ! PADE APPROXIMANTS
+  REAL (KIND=8) pgb(kdlon, 8, 2, kflev) ! PADE APPROXIMANTS
+  REAL (KIND=8) pgasur(kdlon, 8, 2) ! SURFACE PADE APPROXIMANTS
+  REAL (KIND=8) pgbsur(kdlon, 8, 2) ! SURFACE PADE APPROXIMANTS
+  REAL (KIND=8) pgatop(kdlon, 8, 2) ! T.O.A. PADE APPROXIMANTS
+  REAL (KIND=8) pgbtop(kdlon, 8, 2) ! T.O.A. PADE APPROXIMANTS
+
+  REAL (KIND=8) pfluc(kdlon, 2, kflev+1) ! CLEAR-SKY RADIATIVE FLUXES
+  REAL (KIND=8) pcts(kdlon, kflev) ! COOLING-TO-SPACE TERM
+
+  ! * LOCAL VARIABLES:
+
+  REAL (KIND=8) zbgnd(kdlon)
+  REAL (KIND=8) zfd(kdlon)
+  REAL (KIND=8) zfn10(kdlon)
+  REAL (KIND=8) zfu(kdlon)
+  REAL (KIND=8) ztt(kdlon, ntra)
+  REAL (KIND=8) ztt1(kdlon, ntra)
+  REAL (KIND=8) ztt2(kdlon, ntra)
+  REAL (KIND=8) zuu(kdlon, nua)
+  REAL (KIND=8) zcnsol(kdlon)
+  REAL (KIND=8) zcntop(kdlon)
+
+  INTEGER jk, jl, ja
+  INTEGER jstra, jstru
+  INTEGER ind1, ind2, ind3, ind4, in, jlim
+  REAL (KIND=8) zctstr
+
+  ! -----------------------------------------------------------------------
+
+  ! *         1.    INITIALIZATION
+  ! --------------
+
+
+
+  ! *         1.2     INITIALIZE TRANSMISSION FUNCTIONS
+  ! ---------------------------------
+
+
+  DO ja = 1, ntra
+    DO jl = 1, kdlon
+      ztt(jl, ja) = 1.0
+      ztt1(jl, ja) = 1.0
+      ztt2(jl, ja) = 1.0
+    END DO
+  END DO
+
+  DO ja = 1, nua
+    DO jl = 1, kdlon
+      zuu(jl, ja) = 1.0
+    END DO
+  END DO
+
+  ! ------------------------------------------------------------------
+
+  ! *         2.      VERTICAL INTEGRATION
+  ! --------------------
+
+
+  ind1 = 0
+  ind3 = 0
+  ind4 = 1
+  ind2 = 1
+
+  ! *         2.3     EXCHANGE WITH TOP OF THE ATMOSPHERE
+  ! -----------------------------------
+
+
+  DO jk = 1, kflev
+    in = (jk-1)*ng1p1 + 1
+
+    DO ja = 1, kuaer
+      DO jl = 1, kdlon
+        zuu(jl, ja) = pabcu(jl, ja, in)
+      END DO
+    END DO
+
+
+    CALL lwtt_lmdar4(pgatop(1,1,1), pgbtop(1,1,1), zuu, ztt)
+
+    DO jl = 1, kdlon
+      zcntop(jl) = pbtop(jl, 1)*ztt(jl, 1)*ztt(jl, 10) + &
+        pbtop(jl, 2)*ztt(jl, 2)*ztt(jl, 7)*ztt(jl, 11) + &
+        pbtop(jl, 3)*ztt(jl, 4)*ztt(jl, 8)*ztt(jl, 12) + &
+        pbtop(jl, 4)*ztt(jl, 5)*ztt(jl, 9)*ztt(jl, 13) + &
+        pbtop(jl, 5)*ztt(jl, 3)*ztt(jl, 14) + pbtop(jl, 6)*ztt(jl, 6)*ztt(jl, &
+        15)
+      zfd(jl) = zcntop(jl) - pbint(jl, jk) - pdisd(jl, jk) - padjd(jl, jk)
+      pfluc(jl, 2, jk) = zfd(jl)
+    END DO
+
+  END DO
+
+  jk = kflev + 1
+  in = (jk-1)*ng1p1 + 1
+
+  DO jl = 1, kdlon
+    zcntop(jl) = pbtop(jl, 1) + pbtop(jl, 2) + pbtop(jl, 3) + pbtop(jl, 4) + &
+      pbtop(jl, 5) + pbtop(jl, 6)
+    zfd(jl) = zcntop(jl) - pbint(jl, jk) - pdisd(jl, jk) - padjd(jl, jk)
+    pfluc(jl, 2, jk) = zfd(jl)
+  END DO
+
+  ! *         2.4     COOLING-TO-SPACE OF LAYERS ABOVE 10 HPA
+  ! ---------------------------------------
+
+
+
+  ! *         2.4.1   INITIALIZATION
+  ! --------------
+
+
+  jlim = kflev
+
+  IF (.NOT. levoigt) THEN
+    DO jk = kflev, 1, -1
+      IF (ppmb(1,jk)<10.0) THEN
+        jlim = jk
+      END IF
+    END DO
+  END IF
+  klim = jlim
+
+  IF (.NOT. levoigt) THEN
+    DO ja = 1, ktraer
+      DO jl = 1, kdlon
+        ztt1(jl, ja) = 1.0
+      END DO
+    END DO
+
+    ! *         2.4.2   LOOP OVER LAYERS ABOVE 10 HPA
+    ! -----------------------------
+
+
+    DO jstra = kflev, jlim, -1
+      jstru = (jstra-1)*ng1p1 + 1
+
+      DO ja = 1, kuaer
+        DO jl = 1, kdlon
+          zuu(jl, ja) = pabcu(jl, ja, jstru)
+        END DO
+      END DO
+
+
+      CALL lwtt_lmdar4(pga(1,1,1,jstra), pgb(1,1,1,jstra), zuu, ztt)
+
+      DO jl = 1, kdlon
+        zctstr = (pb(jl,1,jstra)+pb(jl,1,jstra+1))* &
+          (ztt1(jl,1)*ztt1(jl,10)-ztt(jl,1)*ztt(jl,10)) + &
+          (pb(jl,2,jstra)+pb(jl,2,jstra+1))*(ztt1(jl,2)*ztt1(jl,7)*ztt1(jl,11 &
+          )-ztt(jl,2)*ztt(jl,7)*ztt(jl,11)) + (pb(jl,3,jstra)+pb(jl,3,jstra+1 &
+          ))*(ztt1(jl,4)*ztt1(jl,8)*ztt1(jl,12)-ztt(jl,4)*ztt(jl,8)*ztt(jl,12 &
+          )) + (pb(jl,4,jstra)+pb(jl,4,jstra+1))*(ztt1(jl,5)*ztt1(jl,9)*ztt1( &
+          jl,13)-ztt(jl,5)*ztt(jl,9)*ztt(jl,13)) + (pb(jl,5,jstra)+pb(jl,5, &
+          jstra+1))*(ztt1(jl,3)*ztt1(jl,14)-ztt(jl,3)*ztt(jl,14)) + &
+          (pb(jl,6,jstra)+pb(jl,6,jstra+1))*(ztt1(jl,6)*ztt1(jl,15)-ztt(jl,6) &
+          *ztt(jl,15))
+        pcts(jl, jstra) = zctstr*0.5
+      END DO
+      DO ja = 1, ktraer
+        DO jl = 1, kdlon
+          ztt1(jl, ja) = ztt(jl, ja)
+        END DO
+      END DO
+    END DO
+  END IF
+  ! Mise a zero de securite pour PCTS en cas de LEVOIGT
+  IF (levoigt) THEN
+    DO jstra = 1, kflev
+      DO jl = 1, kdlon
+        pcts(jl, jstra) = 0.
+      END DO
+    END DO
+  END IF
+
+  ! *         2.5     EXCHANGE WITH LOWER LIMIT
+  ! -------------------------
+
+
+  DO jl = 1, kdlon
+    zbgnd(jl) = pbsui(jl)*pemis(jl) - (1.-pemis(jl))*pfluc(jl, 2, 1) - &
+      pbint(jl, 1)
+  END DO
+
+  jk = 1
+  in = (jk-1)*ng1p1 + 1
+
+  DO jl = 1, kdlon
+    zcnsol(jl) = pbsur(jl, 1) + pbsur(jl, 2) + pbsur(jl, 3) + pbsur(jl, 4) + &
+      pbsur(jl, 5) + pbsur(jl, 6)
+    zcnsol(jl) = zcnsol(jl)*zbgnd(jl)/pbsui(jl)
+    zfu(jl) = zcnsol(jl) + pbint(jl, jk) - pdisu(jl, jk) - padju(jl, jk)
+    pfluc(jl, 1, jk) = zfu(jl)
+  END DO
+
+  DO jk = 2, kflev + 1
+    in = (jk-1)*ng1p1 + 1
+
+
+    DO ja = 1, kuaer
+      DO jl = 1, kdlon
+        zuu(jl, ja) = pabcu(jl, ja, 1) - pabcu(jl, ja, in)
+      END DO
+    END DO
+
+
+    CALL lwtt_lmdar4(pgasur(1,1,1), pgbsur(1,1,1), zuu, ztt)
+
+    DO jl = 1, kdlon
+      zcnsol(jl) = pbsur(jl, 1)*ztt(jl, 1)*ztt(jl, 10) + &
+        pbsur(jl, 2)*ztt(jl, 2)*ztt(jl, 7)*ztt(jl, 11) + &
+        pbsur(jl, 3)*ztt(jl, 4)*ztt(jl, 8)*ztt(jl, 12) + &
+        pbsur(jl, 4)*ztt(jl, 5)*ztt(jl, 9)*ztt(jl, 13) + &
+        pbsur(jl, 5)*ztt(jl, 3)*ztt(jl, 14) + pbsur(jl, 6)*ztt(jl, 6)*ztt(jl, &
+        15)
+      zcnsol(jl) = zcnsol(jl)*zbgnd(jl)/pbsui(jl)
+      zfu(jl) = zcnsol(jl) + pbint(jl, jk) - pdisu(jl, jk) - padju(jl, jk)
+      pfluc(jl, 1, jk) = zfu(jl)
+    END DO
+
+
+  END DO
+
+  ! *         2.7     CLEAR-SKY FLUXES
+  ! ----------------
+
+
+  IF (.NOT. levoigt) THEN
+    DO jl = 1, kdlon
+      zfn10(jl) = pfluc(jl, 1, jlim) + pfluc(jl, 2, jlim)
+    END DO
+    DO jk = jlim + 1, kflev + 1
+      DO jl = 1, kdlon
+        zfn10(jl) = zfn10(jl) + pcts(jl, jk-1)
+        pfluc(jl, 1, jk) = zfn10(jl)
+        pfluc(jl, 2, jk) = 0.
+      END DO
+    END DO
+  END IF
+
+  ! ------------------------------------------------------------------
+
+  RETURN
+END SUBROUTINE lwvb_lmdar4
+SUBROUTINE lwvd_lmdar4(kuaer, ktraer, pabcu, pdbdt, pga, pgb, pcntrb, pdisd, &
+    pdisu)
+  USE dimphy
+  IMPLICIT NONE
+  include "raddimlw.h"
+
+  ! -----------------------------------------------------------------------
+  ! PURPOSE.
+  ! --------
+  ! CARRIES OUT THE VERTICAL INTEGRATION ON THE DISTANT LAYERS
+
+  ! METHOD.
+  ! -------
+
+  ! 1. PERFORMS THE VERTICAL INTEGRATION CORRESPONDING TO THE
+  ! CONTRIBUTIONS OF THE DISTANT LAYERS USING TRAPEZOIDAL RULE
+
+  ! REFERENCE.
+  ! ----------
+
+  ! SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+  ! ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
+
+  ! AUTHOR.
+  ! -------
+  ! JEAN-JACQUES MORCRETTE  *ECMWF*
+
+  ! MODIFICATIONS.
+  ! --------------
+  ! ORIGINAL : 89-07-14
+  ! -----------------------------------------------------------------------
+  ! * ARGUMENTS:
+
+  INTEGER kuaer, ktraer
+
+  REAL (KIND=8) pabcu(kdlon, nua, 3*kflev+1) ! ABSORBER AMOUNTS
+  REAL (KIND=8) pdbdt(kdlon, ninter, kflev) ! LAYER PLANCK FUNCTION GRADIENT
+  REAL (KIND=8) pga(kdlon, 8, 2, kflev) ! PADE APPROXIMANTS
+  REAL (KIND=8) pgb(kdlon, 8, 2, kflev) ! PADE APPROXIMANTS
+
+  REAL (KIND=8) pcntrb(kdlon, kflev+1, kflev+1) ! ENERGY EXCHANGE MATRIX
+  REAL (KIND=8) pdisd(kdlon, kflev+1) !  CONTRIBUTION BY DISTANT LAYERS
+  REAL (KIND=8) pdisu(kdlon, kflev+1) !  CONTRIBUTION BY DISTANT LAYERS
+
+  ! * LOCAL VARIABLES:
+
+  REAL (KIND=8) zglayd(kdlon)
+  REAL (KIND=8) zglayu(kdlon)
+  REAL (KIND=8) ztt(kdlon, ntra)
+  REAL (KIND=8) ztt1(kdlon, ntra)
+  REAL (KIND=8) ztt2(kdlon, ntra)
+
+  INTEGER jl, jk, ja, ikp1, ikn, ikd1, jkj, ikd2
+  INTEGER ikjp1, ikm1, ikj, jlk, iku1, ijkl, iku2
+  INTEGER ind1, ind2, ind3, ind4, itt
+  REAL (KIND=8) zww, zdzxdg, zdzxmg
+
+  ! *         1.    INITIALIZATION
+  ! --------------
+
+
+  ! *         1.1     INITIALIZE LAYER CONTRIBUTIONS
+  ! ------------------------------
+
+
+  DO jk = 1, kflev + 1
+    DO jl = 1, kdlon
+      pdisd(jl, jk) = 0.
+      pdisu(jl, jk) = 0.
+    END DO
+  END DO
+
+  ! *         1.2     INITIALIZE TRANSMISSION FUNCTIONS
+  ! ---------------------------------
+
+
+
+  DO ja = 1, ntra
+    DO jl = 1, kdlon
+      ztt(jl, ja) = 1.0
+      ztt1(jl, ja) = 1.0
+      ztt2(jl, ja) = 1.0
+    END DO
+  END DO
+
+  ! ------------------------------------------------------------------
+
+  ! *         2.      VERTICAL INTEGRATION
+  ! --------------------
+
+
+  ind1 = 0
+  ind3 = 0
+  ind4 = 1
+  ind2 = 1
+
+  ! *         2.2     CONTRIBUTION FROM DISTANT LAYERS
+  ! ---------------------------------
+
+
+
+  ! *         2.2.1   DISTANT AND ABOVE LAYERS
+  ! ------------------------
+
+
+
+
+  ! *         2.2.2   FIRST UPPER LEVEL
+  ! -----------------
+
+
+  DO jk = 1, kflev - 1
+    ikp1 = jk + 1
+    ikn = (jk-1)*ng1p1 + 1
+    ikd1 = jk*ng1p1 + 1
+
+    CALL lwttm_lmdar4(pga(1,1,1,jk), pgb(1,1,1,jk), pabcu(1,1,ikn), &
+      pabcu(1,1,ikd1), ztt1)
+
+    ! *         2.2.3   HIGHER UP
+    ! ---------
+
+
+    itt = 1
+    DO jkj = ikp1, kflev
+      IF (itt==1) THEN
+        itt = 2
+      ELSE
+        itt = 1
+      END IF
+      ikjp1 = jkj + 1
+      ikd2 = jkj*ng1p1 + 1
+
+      IF (itt==1) THEN
+        CALL lwttm_lmdar4(pga(1,1,1,jkj), pgb(1,1,1,jkj), pabcu(1,1,ikn), &
+          pabcu(1,1,ikd2), ztt1)
+      ELSE
+        CALL lwttm_lmdar4(pga(1,1,1,jkj), pgb(1,1,1,jkj), pabcu(1,1,ikn), &
+          pabcu(1,1,ikd2), ztt2)
+      END IF
+
+      DO ja = 1, ktraer
+        DO jl = 1, kdlon
+          ztt(jl, ja) = (ztt1(jl,ja)+ztt2(jl,ja))*0.5
+        END DO
+      END DO
+
+      DO jl = 1, kdlon
+        zww = pdbdt(jl, 1, jkj)*ztt(jl, 1)*ztt(jl, 10) + &
+          pdbdt(jl, 2, jkj)*ztt(jl, 2)*ztt(jl, 7)*ztt(jl, 11) + &
+          pdbdt(jl, 3, jkj)*ztt(jl, 4)*ztt(jl, 8)*ztt(jl, 12) + &
+          pdbdt(jl, 4, jkj)*ztt(jl, 5)*ztt(jl, 9)*ztt(jl, 13) + &
+          pdbdt(jl, 5, jkj)*ztt(jl, 3)*ztt(jl, 14) + &
+          pdbdt(jl, 6, jkj)*ztt(jl, 6)*ztt(jl, 15)
+        zglayd(jl) = zww
+        zdzxdg = zglayd(jl)
+        pdisd(jl, jk) = pdisd(jl, jk) + zdzxdg
+        pcntrb(jl, jk, ikjp1) = zdzxdg
+      END DO
+
+
+    END DO
+  END DO
+
+  ! *         2.2.4   DISTANT AND BELOW LAYERS
+  ! ------------------------
+
+
+
+
+  ! *         2.2.5   FIRST LOWER LEVEL
+  ! -----------------
+
+
+  DO jk = 3, kflev + 1
+    ikn = (jk-1)*ng1p1 + 1
+    ikm1 = jk - 1
+    ikj = jk - 2
+    iku1 = ikj*ng1p1 + 1
+
+
+    CALL lwttm_lmdar4(pga(1,1,1,ikj), pgb(1,1,1,ikj), pabcu(1,1,iku1), &
+      pabcu(1,1,ikn), ztt1)
+
+    ! *         2.2.6   DOWN BELOW
+    ! ----------
+
+
+    itt = 1
+    DO jlk = 1, ikj
+      IF (itt==1) THEN
+        itt = 2
+      ELSE
+        itt = 1
+      END IF
+      ijkl = ikm1 - jlk
+      iku2 = (ijkl-1)*ng1p1 + 1
+
+
+      IF (itt==1) THEN
+        CALL lwttm_lmdar4(pga(1,1,1,ijkl), pgb(1,1,1,ijkl), pabcu(1,1,iku2), &
+          pabcu(1,1,ikn), ztt1)
+      ELSE
+        CALL lwttm_lmdar4(pga(1,1,1,ijkl), pgb(1,1,1,ijkl), pabcu(1,1,iku2), &
+          pabcu(1,1,ikn), ztt2)
+      END IF
+
+      DO ja = 1, ktraer
+        DO jl = 1, kdlon
+          ztt(jl, ja) = (ztt1(jl,ja)+ztt2(jl,ja))*0.5
+        END DO
+      END DO
+
+      DO jl = 1, kdlon
+        zww = pdbdt(jl, 1, ijkl)*ztt(jl, 1)*ztt(jl, 10) + &
+          pdbdt(jl, 2, ijkl)*ztt(jl, 2)*ztt(jl, 7)*ztt(jl, 11) + &
+          pdbdt(jl, 3, ijkl)*ztt(jl, 4)*ztt(jl, 8)*ztt(jl, 12) + &
+          pdbdt(jl, 4, ijkl)*ztt(jl, 5)*ztt(jl, 9)*ztt(jl, 13) + &
+          pdbdt(jl, 5, ijkl)*ztt(jl, 3)*ztt(jl, 14) + &
+          pdbdt(jl, 6, ijkl)*ztt(jl, 6)*ztt(jl, 15)
+        zglayu(jl) = zww
+        zdzxmg = zglayu(jl)
+        pdisu(jl, jk) = pdisu(jl, jk) + zdzxmg
+        pcntrb(jl, jk, ijkl) = zdzxmg
+      END DO
+
+
+    END DO
+  END DO
+
+  RETURN
+END SUBROUTINE lwvd_lmdar4
+SUBROUTINE lwvn_lmdar4(kuaer, ktraer, pabcu, pdbsl, pga, pgb, padjd, padju, &
+    pcntrb, pdbdt)
+  USE dimphy
+  USE radiation_ar4_param, ONLY: wg1
+  IMPLICIT NONE
+  include "raddimlw.h"
+
+  ! -----------------------------------------------------------------------
+  ! PURPOSE.
+  ! --------
+  ! CARRIES OUT THE VERTICAL INTEGRATION ON NEARBY LAYERS
+  ! TO GIVE LONGWAVE FLUXES OR RADIANCES
+
+  ! METHOD.
+  ! -------
+
+  ! 1. PERFORMS THE VERTICAL INTEGRATION CORRESPONDING TO THE
+  ! CONTRIBUTIONS OF THE ADJACENT LAYERS USING A GAUSSIAN QUADRATURE
+
+  ! REFERENCE.
+  ! ----------
+
+  ! SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+  ! ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
+
+  ! AUTHOR.
+  ! -------
+  ! JEAN-JACQUES MORCRETTE  *ECMWF*
+
+  ! MODIFICATIONS.
+  ! --------------
+  ! ORIGINAL : 89-07-14
+  ! -----------------------------------------------------------------------
+
+  ! * ARGUMENTS:
+
+  INTEGER kuaer, ktraer
+
+  REAL (KIND=8) pabcu(kdlon, nua, 3*kflev+1) ! ABSORBER AMOUNTS
+  REAL (KIND=8) pdbsl(kdlon, ninter, kflev*2) ! SUB-LAYER PLANCK FUNCTION GRADIENT
+  REAL (KIND=8) pga(kdlon, 8, 2, kflev) ! PADE APPROXIMANTS
+  REAL (KIND=8) pgb(kdlon, 8, 2, kflev) ! PADE APPROXIMANTS
+
+  REAL (KIND=8) padjd(kdlon, kflev+1) ! CONTRIBUTION OF ADJACENT LAYERS
+  REAL (KIND=8) padju(kdlon, kflev+1) ! CONTRIBUTION OF ADJACENT LAYERS
+  REAL (KIND=8) pcntrb(kdlon, kflev+1, kflev+1) ! CLEAR-SKY ENERGY EXCHANGE MATRIX
+  REAL (KIND=8) pdbdt(kdlon, ninter, kflev) !  LAYER PLANCK FUNCTION GRADIENT
+
+  ! * LOCAL ARRAYS:
+
+  REAL (KIND=8) zglayd(kdlon)
+  REAL (KIND=8) zglayu(kdlon)
+  REAL (KIND=8) ztt(kdlon, ntra)
+  REAL (KIND=8) ztt1(kdlon, ntra)
+  REAL (KIND=8) ztt2(kdlon, ntra)
+  REAL (KIND=8) zuu(kdlon, nua)
+
+  INTEGER jk, jl, ja, im12, ind, inu, ixu, jg
+  INTEGER ixd, ibs, idd, imu, jk1, jk2, jnu
+  REAL (KIND=8) zwtr
+
+  ! -----------------------------------------------------------------------
+
+  ! *         1.    INITIALIZATION
+  ! --------------
+
+
+  ! *         1.1     INITIALIZE LAYER CONTRIBUTIONS
+  ! ------------------------------
+
+
+  DO jk = 1, kflev + 1
+    DO jl = 1, kdlon
+      padjd(jl, jk) = 0.
+      padju(jl, jk) = 0.
+    END DO
+  END DO
+
+  ! *         1.2     INITIALIZE TRANSMISSION FUNCTIONS
+  ! ---------------------------------
+
+
+  DO ja = 1, ntra
+    DO jl = 1, kdlon
+      ztt(jl, ja) = 1.0
+      ztt1(jl, ja) = 1.0
+      ztt2(jl, ja) = 1.0
+    END DO
+  END DO
+
+  DO ja = 1, nua
+    DO jl = 1, kdlon
+      zuu(jl, ja) = 0.
+    END DO
+  END DO
+
+  ! ------------------------------------------------------------------
+
+  ! *         2.      VERTICAL INTEGRATION
+  ! --------------------
+
+
+
+  ! *         2.1     CONTRIBUTION FROM ADJACENT LAYERS
+  ! ---------------------------------
+
+
+  DO jk = 1, kflev
+    ! *         2.1.1   DOWNWARD LAYERS
+    ! ---------------
+
+
+    im12 = 2*(jk-1)
+    ind = (jk-1)*ng1p1 + 1
+    ixd = ind
+    inu = jk*ng1p1 + 1
+    ixu = ind
+
+    DO jl = 1, kdlon
+      zglayd(jl) = 0.
+      zglayu(jl) = 0.
+    END DO
+
+    DO jg = 1, ng1
+      ibs = im12 + jg
+      idd = ixd + jg
+      DO ja = 1, kuaer
+        DO jl = 1, kdlon
+          zuu(jl, ja) = pabcu(jl, ja, ind) - pabcu(jl, ja, idd)
+        END DO
+      END DO
+
+
+      CALL lwtt_lmdar4(pga(1,1,1,jk), pgb(1,1,1,jk), zuu, ztt)
+
+      DO jl = 1, kdlon
+        zwtr = pdbsl(jl, 1, ibs)*ztt(jl, 1)*ztt(jl, 10) + &
+          pdbsl(jl, 2, ibs)*ztt(jl, 2)*ztt(jl, 7)*ztt(jl, 11) + &
+          pdbsl(jl, 3, ibs)*ztt(jl, 4)*ztt(jl, 8)*ztt(jl, 12) + &
+          pdbsl(jl, 4, ibs)*ztt(jl, 5)*ztt(jl, 9)*ztt(jl, 13) + &
+          pdbsl(jl, 5, ibs)*ztt(jl, 3)*ztt(jl, 14) + &
+          pdbsl(jl, 6, ibs)*ztt(jl, 6)*ztt(jl, 15)
+        zglayd(jl) = zglayd(jl) + zwtr*wg1(jg)
+      END DO
+
+      ! *         2.1.2   DOWNWARD LAYERS
+      ! ---------------
+
+
+      imu = ixu + jg
+      DO ja = 1, kuaer
+        DO jl = 1, kdlon
+          zuu(jl, ja) = pabcu(jl, ja, imu) - pabcu(jl, ja, inu)
+        END DO
+      END DO
+
+
+      CALL lwtt_lmdar4(pga(1,1,1,jk), pgb(1,1,1,jk), zuu, ztt)
+
+      DO jl = 1, kdlon
+        zwtr = pdbsl(jl, 1, ibs)*ztt(jl, 1)*ztt(jl, 10) + &
+          pdbsl(jl, 2, ibs)*ztt(jl, 2)*ztt(jl, 7)*ztt(jl, 11) + &
+          pdbsl(jl, 3, ibs)*ztt(jl, 4)*ztt(jl, 8)*ztt(jl, 12) + &
+          pdbsl(jl, 4, ibs)*ztt(jl, 5)*ztt(jl, 9)*ztt(jl, 13) + &
+          pdbsl(jl, 5, ibs)*ztt(jl, 3)*ztt(jl, 14) + &
+          pdbsl(jl, 6, ibs)*ztt(jl, 6)*ztt(jl, 15)
+        zglayu(jl) = zglayu(jl) + zwtr*wg1(jg)
+      END DO
+
+    END DO
+
+    DO jl = 1, kdlon
+      padjd(jl, jk) = zglayd(jl)
+      pcntrb(jl, jk, jk+1) = zglayd(jl)
+      padju(jl, jk+1) = zglayu(jl)
+      pcntrb(jl, jk+1, jk) = zglayu(jl)
+      pcntrb(jl, jk, jk) = 0.0
+    END DO
+
+  END DO
+
+  DO jk = 1, kflev
+    jk2 = 2*jk
+    jk1 = jk2 - 1
+    DO jnu = 1, ninter
+      DO jl = 1, kdlon
+        pdbdt(jl, jnu, jk) = pdbsl(jl, jnu, jk1) + pdbsl(jl, jnu, jk2)
+      END DO
+    END DO
+  END DO
+
+  RETURN
+
+END SUBROUTINE lwvn_lmdar4
+SUBROUTINE lwtt_lmdar4(pga, pgb, puu, ptt)
+  USE dimphy
+  IMPLICIT NONE
+  include "raddimlw.h"
+
+  ! -----------------------------------------------------------------------
+  ! PURPOSE.
+  ! --------
+  ! THIS ROUTINE COMPUTES THE TRANSMISSION FUNCTIONS FOR ALL THE
+  ! ABSORBERS (H2O, UNIFORMLY MIXED GASES, AND O3) IN ALL SIX SPECTRAL
+  ! INTERVALS.
+
+  ! METHOD.
+  ! -------
+
+  ! 1. TRANSMISSION FUNCTION BY H2O AND UNIFORMLY MIXED GASES ARE
+  ! COMPUTED USING PADE APPROXIMANTS AND HORNER'S ALGORITHM.
+  ! 2. TRANSMISSION BY O3 IS EVALUATED WITH MALKMUS'S BAND MODEL.
+  ! 3. TRANSMISSION BY H2O CONTINUUM AND AEROSOLS FOLLOW AN
+  ! A SIMPLE EXPONENTIAL DECREASE WITH ABSORBER AMOUNT.
+
+  ! REFERENCE.
+  ! ----------
+
+  ! SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+  ! ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
+
+  ! AUTHOR.
+  ! -------
+  ! JEAN-JACQUES MORCRETTE  *ECMWF*
+
+  ! MODIFICATIONS.
+  ! --------------
+  ! ORIGINAL : 88-12-15
+
+  ! -----------------------------------------------------------------------
+  REAL (KIND=8) o1h, o2h
+  PARAMETER (o1h=2230.)
+  PARAMETER (o2h=100.)
+  REAL (KIND=8) rpialf0
+  PARAMETER (rpialf0=2.0)
+
+  ! * ARGUMENTS:
+
+  REAL (KIND=8) puu(kdlon, nua)
+  REAL (KIND=8) ptt(kdlon, ntra)
+  REAL (KIND=8) pga(kdlon, 8, 2)
+  REAL (KIND=8) pgb(kdlon, 8, 2)
+
+  ! * LOCAL VARIABLES:
+
+  REAL (KIND=8) zz, zxd, zxn
+  REAL (KIND=8) zpu, zpu10, zpu11, zpu12, zpu13
+  REAL (KIND=8) zeu, zeu10, zeu11, zeu12, zeu13
+  REAL (KIND=8) zx, zy, zsq1, zsq2, zvxy, zuxy
+  REAL (KIND=8) zaercn, zto1, zto2, zxch4, zych4, zxn2o, zyn2o
+  REAL (KIND=8) zsqn21, zodn21, zsqh42, zodh42
+  REAL (KIND=8) zsqh41, zodh41, zsqn22, zodn22, zttf11, zttf12
+  REAL (KIND=8) zuu11, zuu12, za11, za12
+  INTEGER jl, ja
+
+  ! ------------------------------------------------------------------
+
+  ! *         1.     HORNER'S ALGORITHM FOR H2O AND CO2 TRANSMISSION
+  ! -----------------------------------------------
+
+
+
+  ! cdir collapse
+  DO ja = 1, 8
+    DO jl = 1, kdlon
+      zz = sqrt(puu(jl,ja))
+      ! ZXD(JL,1)=PGB( JL, 1,1) + ZZ(JL, 1)*(PGB( JL, 1,2) + ZZ(JL, 1))
+      ! ZXN(JL,1)=PGA( JL, 1,1) + ZZ(JL, 1)*(PGA( JL, 1,2) )
+      ! PTT(JL,1)=ZXN(JL,1)/ZXD(JL,1)
+      zxd = pgb(jl, ja, 1) + zz*(pgb(jl,ja,2)+zz)
+      zxn = pga(jl, ja, 1) + zz*(pga(jl,ja,2))
+      ptt(jl, ja) = zxn/zxd
+    END DO
+  END DO
+
+  ! ------------------------------------------------------------------
+
+  ! *         2.     CONTINUUM, OZONE AND AEROSOL TRANSMISSION FUNCTIONS
+  ! ---------------------------------------------------
+
+
+  DO jl = 1, kdlon
+    ptt(jl, 9) = ptt(jl, 8)
+
+    ! -  CONTINUUM ABSORPTION: E- AND P-TYPE
+
+    zpu = 0.002*puu(jl, 10)
+    zpu10 = 112.*zpu
+    zpu11 = 6.25*zpu
+    zpu12 = 5.00*zpu
+    zpu13 = 80.0*zpu
+    zeu = puu(jl, 11)
+    zeu10 = 12.*zeu
+    zeu11 = 6.25*zeu
+    zeu12 = 5.00*zeu
+    zeu13 = 80.0*zeu
+
+    ! -  OZONE ABSORPTION
+
+    zx = puu(jl, 12)
+    zy = puu(jl, 13)
+    zuxy = 4.*zx*zx/(rpialf0*zy)
+    zsq1 = sqrt(1.+o1h*zuxy) - 1.
+    zsq2 = sqrt(1.+o2h*zuxy) - 1.
+    zvxy = rpialf0*zy/(2.*zx)
+    zaercn = puu(jl, 17) + zeu12 + zpu12
+    zto1 = exp(-zvxy*zsq1-zaercn)
+    zto2 = exp(-zvxy*zsq2-zaercn)
+
+    ! -- TRACE GASES (CH4, N2O, CFC-11, CFC-12)
+
+    ! * CH4 IN INTERVAL 800-970 + 1110-1250 CM-1
+
+    ! NEXOTIC=1
+    ! IF (NEXOTIC.EQ.1) THEN
+    zxch4 = puu(jl, 19)
+    zych4 = puu(jl, 20)
+    zuxy = 4.*zxch4*zxch4/(0.103*zych4)
+    zsqh41 = sqrt(1.+33.7*zuxy) - 1.
+    zvxy = 0.103*zych4/(2.*zxch4)
+    zodh41 = zvxy*zsqh41
+
+    ! * N2O IN INTERVAL 800-970 + 1110-1250 CM-1
+
+    zxn2o = puu(jl, 21)
+    zyn2o = puu(jl, 22)
+    zuxy = 4.*zxn2o*zxn2o/(0.416*zyn2o)
+    zsqn21 = sqrt(1.+21.3*zuxy) - 1.
+    zvxy = 0.416*zyn2o/(2.*zxn2o)
+    zodn21 = zvxy*zsqn21
+
+    ! * CH4 IN INTERVAL 1250-1450 + 1880-2820 CM-1
+
+    zuxy = 4.*zxch4*zxch4/(0.113*zych4)
+    zsqh42 = sqrt(1.+400.*zuxy) - 1.
+    zvxy = 0.113*zych4/(2.*zxch4)
+    zodh42 = zvxy*zsqh42
+
+    ! * N2O IN INTERVAL 1250-1450 + 1880-2820 CM-1
+
+    zuxy = 4.*zxn2o*zxn2o/(0.197*zyn2o)
+    zsqn22 = sqrt(1.+2000.*zuxy) - 1.
+    zvxy = 0.197*zyn2o/(2.*zxn2o)
+    zodn22 = zvxy*zsqn22
+
+    ! * CFC-11 IN INTERVAL 800-970 + 1110-1250 CM-1
+
+    za11 = 2.*puu(jl, 23)*4.404E+05
+    zttf11 = 1. - za11*0.003225
+
+    ! * CFC-12 IN INTERVAL 800-970 + 1110-1250 CM-1
+
+    za12 = 2.*puu(jl, 24)*6.7435E+05
+    zttf12 = 1. - za12*0.003225
+
+    zuu11 = -puu(jl, 15) - zeu10 - zpu10
+    zuu12 = -puu(jl, 16) - zeu11 - zpu11 - zodh41 - zodn21
+    ptt(jl, 10) = exp(-puu(jl,14))
+    ptt(jl, 11) = exp(zuu11)
+    ptt(jl, 12) = exp(zuu12)*zttf11*zttf12
+    ptt(jl, 13) = 0.7554*zto1 + 0.2446*zto2
+    ptt(jl, 14) = ptt(jl, 10)*exp(-zeu13-zpu13)
+    ptt(jl, 15) = exp(-puu(jl,14)-zodh42-zodn22)
+  END DO
+
+  RETURN
+END SUBROUTINE lwtt_lmdar4
+SUBROUTINE lwttm_lmdar4(pga, pgb, puu1, puu2, ptt)
+  USE dimphy
+  IMPLICIT NONE
+  include "raddimlw.h"
+
+  ! ------------------------------------------------------------------
+  ! PURPOSE.
+  ! --------
+  ! THIS ROUTINE COMPUTES THE TRANSMISSION FUNCTIONS FOR ALL THE
+  ! ABSORBERS (H2O, UNIFORMLY MIXED GASES, AND O3) IN ALL SIX SPECTRAL
+  ! INTERVALS.
+
+  ! METHOD.
+  ! -------
+
+  ! 1. TRANSMISSION FUNCTION BY H2O AND UNIFORMLY MIXED GASES ARE
+  ! COMPUTED USING PADE APPROXIMANTS AND HORNER'S ALGORITHM.
+  ! 2. TRANSMISSION BY O3 IS EVALUATED WITH MALKMUS'S BAND MODEL.
+  ! 3. TRANSMISSION BY H2O CONTINUUM AND AEROSOLS FOLLOW AN
+  ! A SIMPLE EXPONENTIAL DECREASE WITH ABSORBER AMOUNT.
+
+  ! REFERENCE.
+  ! ----------
+
+  ! SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+  ! ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
+
+  ! AUTHOR.
+  ! -------
+  ! JEAN-JACQUES MORCRETTE  *ECMWF*
+
+  ! MODIFICATIONS.
+  ! --------------
+  ! ORIGINAL : 88-12-15
+
+  ! -----------------------------------------------------------------------
+  REAL (KIND=8) o1h, o2h
+  PARAMETER (o1h=2230.)
+  PARAMETER (o2h=100.)
+  REAL (KIND=8) rpialf0
+  PARAMETER (rpialf0=2.0)
+
+  ! * ARGUMENTS:
+
+  REAL (KIND=8) pga(kdlon, 8, 2) ! PADE APPROXIMANTS
+  REAL (KIND=8) pgb(kdlon, 8, 2) ! PADE APPROXIMANTS
+  REAL (KIND=8) puu1(kdlon, nua) ! ABSORBER AMOUNTS FROM TOP TO LEVEL 1
+  REAL (KIND=8) puu2(kdlon, nua) ! ABSORBER AMOUNTS FROM TOP TO LEVEL 2
+  REAL (KIND=8) ptt(kdlon, ntra) ! TRANSMISSION FUNCTIONS
+
+  ! * LOCAL VARIABLES:
+
+  INTEGER ja, jl
+  REAL (KIND=8) zz, zxd, zxn
+  REAL (KIND=8) zpu, zpu10, zpu11, zpu12, zpu13
+  REAL (KIND=8) zeu, zeu10, zeu11, zeu12, zeu13
+  REAL (KIND=8) zx, zy, zuxy, zsq1, zsq2, zvxy, zaercn, zto1, zto2
+  REAL (KIND=8) zxch4, zych4, zsqh41, zodh41
+  REAL (KIND=8) zxn2o, zyn2o, zsqn21, zodn21, zsqh42, zodh42
+  REAL (KIND=8) zsqn22, zodn22, za11, zttf11, za12, zttf12
+  REAL (KIND=8) zuu11, zuu12
+
+  ! ------------------------------------------------------------------
+
+  ! *         1.     HORNER'S ALGORITHM FOR H2O AND CO2 TRANSMISSION
+  ! -----------------------------------------------
+
+
+
+
+  ! CDIR ON_ADB(PUU1)
+  ! CDIR ON_ADB(PUU2)
+  ! CDIR COLLAPSE
+  DO ja = 1, 8
+    DO jl = 1, kdlon
+      zz = sqrt(puu1(jl,ja)-puu2(jl,ja))
+      zxd = pgb(jl, ja, 1) + zz*(pgb(jl,ja,2)+zz)
+      zxn = pga(jl, ja, 1) + zz*(pga(jl,ja,2))
+      ptt(jl, ja) = zxn/zxd
+    END DO
+  END DO
+
+  ! ------------------------------------------------------------------
+
+  ! *         2.     CONTINUUM, OZONE AND AEROSOL TRANSMISSION FUNCTIONS
+  ! ---------------------------------------------------
+
+
+  DO jl = 1, kdlon
+    ptt(jl, 9) = ptt(jl, 8)
+
+    ! -  CONTINUUM ABSORPTION: E- AND P-TYPE
+
+    zpu = 0.002*(puu1(jl,10)-puu2(jl,10))
+    zpu10 = 112.*zpu
+    zpu11 = 6.25*zpu
+    zpu12 = 5.00*zpu
+    zpu13 = 80.0*zpu
+    zeu = (puu1(jl,11)-puu2(jl,11))
+    zeu10 = 12.*zeu
+    zeu11 = 6.25*zeu
+    zeu12 = 5.00*zeu
+    zeu13 = 80.0*zeu
+
+    ! -  OZONE ABSORPTION
+
+    zx = (puu1(jl,12)-puu2(jl,12))
+    zy = (puu1(jl,13)-puu2(jl,13))
+    zuxy = 4.*zx*zx/(rpialf0*zy)
+    zsq1 = sqrt(1.+o1h*zuxy) - 1.
+    zsq2 = sqrt(1.+o2h*zuxy) - 1.
+    zvxy = rpialf0*zy/(2.*zx)
+    zaercn = (puu1(jl,17)-puu2(jl,17)) + zeu12 + zpu12
+    zto1 = exp(-zvxy*zsq1-zaercn)
+    zto2 = exp(-zvxy*zsq2-zaercn)
+
+    ! -- TRACE GASES (CH4, N2O, CFC-11, CFC-12)
+
+    ! * CH4 IN INTERVAL 800-970 + 1110-1250 CM-1
+
+    zxch4 = (puu1(jl,19)-puu2(jl,19))
+    zych4 = (puu1(jl,20)-puu2(jl,20))
+    zuxy = 4.*zxch4*zxch4/(0.103*zych4)
+    zsqh41 = sqrt(1.+33.7*zuxy) - 1.
+    zvxy = 0.103*zych4/(2.*zxch4)
+    zodh41 = zvxy*zsqh41
+
+    ! * N2O IN INTERVAL 800-970 + 1110-1250 CM-1
+
+    zxn2o = (puu1(jl,21)-puu2(jl,21))
+    zyn2o = (puu1(jl,22)-puu2(jl,22))
+    zuxy = 4.*zxn2o*zxn2o/(0.416*zyn2o)
+    zsqn21 = sqrt(1.+21.3*zuxy) - 1.
+    zvxy = 0.416*zyn2o/(2.*zxn2o)
+    zodn21 = zvxy*zsqn21
+
+    ! * CH4 IN INTERVAL 1250-1450 + 1880-2820 CM-1
+
+    zuxy = 4.*zxch4*zxch4/(0.113*zych4)
+    zsqh42 = sqrt(1.+400.*zuxy) - 1.
+    zvxy = 0.113*zych4/(2.*zxch4)
+    zodh42 = zvxy*zsqh42
+
+    ! * N2O IN INTERVAL 1250-1450 + 1880-2820 CM-1
+
+    zuxy = 4.*zxn2o*zxn2o/(0.197*zyn2o)
+    zsqn22 = sqrt(1.+2000.*zuxy) - 1.
+    zvxy = 0.197*zyn2o/(2.*zxn2o)
+    zodn22 = zvxy*zsqn22
+
+    ! * CFC-11 IN INTERVAL 800-970 + 1110-1250 CM-1
+
+    za11 = (puu1(jl,23)-puu2(jl,23))*4.404E+05
+    zttf11 = 1. - za11*0.003225
+
+    ! * CFC-12 IN INTERVAL 800-970 + 1110-1250 CM-1
+
+    za12 = (puu1(jl,24)-puu2(jl,24))*6.7435E+05
+    zttf12 = 1. - za12*0.003225
+
+    zuu11 = -(puu1(jl,15)-puu2(jl,15)) - zeu10 - zpu10
+    zuu12 = -(puu1(jl,16)-puu2(jl,16)) - zeu11 - zpu11 - zodh41 - zodn21
+    ptt(jl, 10) = exp(-(puu1(jl,14)-puu2(jl,14)))
+    ptt(jl, 11) = exp(zuu11)
+    ptt(jl, 12) = exp(zuu12)*zttf11*zttf12
+    ptt(jl, 13) = 0.7554*zto1 + 0.2446*zto2
+    ptt(jl, 14) = ptt(jl, 10)*exp(-zeu13-zpu13)
+    ptt(jl, 15) = exp(-(puu1(jl,14)-puu2(jl,14))-zodh42-zodn22)
+  END DO
+
+  RETURN
+END SUBROUTINE lwttm_lmdar4
Index: DZ6/trunk/libf/phylmd/radiation_ar4_param.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/radiation_ar4_param.F90	(revision 5267)
+++ 	(revision )
@@ -1,243 +1,0 @@
-MODULE radiation_ar4_param
-
- IMPLICIT NONE
-
- REAL(KIND=8), parameter :: ZPDH2O = 0.8
- REAL(KIND=8), parameter :: ZPDUMG = 0.75
- REAL(KIND=8), parameter :: ZPRH2O = 30000.0
- REAL(KIND=8), parameter :: ZPRUMG = 30000.0
- REAL(KIND=8), parameter :: RTDH2O = 0.40
- REAL(KIND=8), parameter :: RTDUMG = 0.375
- REAL(KIND=8), parameter :: RTH2O = 240.0
- REAL(KIND=8), parameter :: RTUMG = 240.0
-
- REAL(KIND=8), dimension(2), parameter :: WG1 = (/1.0, 1.0/)
- REAL(KIND=8), dimension(11), parameter :: TINTP = (/ 187.5, 200., 212.5, 225., 237.5, 250., 262.5, 275., 287.5, 300., 312.5 /)
-
- real(kind=8), dimension(11,16,3), parameter :: GA = reshape ( (/ &
- 0.63499072E-02, 0.65566348E-02, 0.67849730E-02, 0.70481947E-02, 0.73585943E-02, 0.77242818E-02, 0.81472693E-02, 0.86227527E-02,&
- 0.91396814E-02, 0.96825438E-02, 0.10233955E-01, 0.77266491E-02, 0.81323287E-02, 0.86507620E-02, 0.92776391E-02, 0.99806312E-02,&
- 0.10709803E-01, 0.11414739E-01, 0.12058772E-01, 0.12623992E-01, 0.13108146E-01, 0.13518390E-01, 0.11644593E+01, 0.11747203E+01,&
- 0.11837872E+01, 0.11918561E+01, 0.11990757E+01, 0.12055643E+01, 0.12114186E+01, 0.12167192E+01, 0.12215344E+01, 0.12259226E+01,&
- 0.12299344E+01, 0.12006968E+01, 0.12108196E+01, 0.12196717E+01, 0.12274493E+01, 0.12343189E+01, 0.12404147E+01, 0.12458431E+01,&
- 0.12506907E+01, 0.12550299E+01, 0.12589256E+01, 0.12624402E+01, 0.15750172E+00, 0.16174076E+00, 0.16548628E+00, 0.16881124E+00,&
- 0.17177839E+00, 0.17443933E+00, 0.17683622E+00, 0.17900375E+00, 0.18097099E+00, 0.18276283E+00, 0.18440117E+00, 0.17770551E+00,&
- 0.18176757E+00, 0.18527967E+00, 0.18833348E+00, 0.19100108E+00, 0.19334122E+00, 0.19540288E+00, 0.19722732E+00, 0.19884918E+00,&
- 0.20029696E+00, 0.20159300E+00, 0.10192131E+02, 0.97258602E+01, 0.92992890E+01, 0.89154021E+01, 0.85730084E+01, 0.82685838E+01,&
- 0.79978921E+01, 0.77568055E+01, 0.75416266E+01, 0.73491694E+01, 0.71767400E+01, 0.92439050E+01, 0.87567422E+01, 0.83270144E+01,&
- 0.79528337E+01, 0.76286839E+01, 0.73477879E+01, 0.71035818E+01, 0.68903312E+01, 0.67032875E+01, 0.65386461E+01, 0.63934377E+01,&
- 0.24870635E+02, 0.24725591E+02, 0.24600320E+02, 0.24487300E+02, 0.24384935E+02, 0.24292341E+02, 0.24208572E+02, 0.24132642E+02,&
- 0.24063614E+02, 0.24000649E+02, 0.23943021E+02, 0.24586283E+02, 0.24441465E+02, 0.24311657E+02, 0.24196167E+02, 0.24093406E+02,&
- 0.24001597E+02, 0.23919098E+02, 0.23844511E+02, 0.23776708E+02, 0.23714816E+02, 0.23658197E+02, 0.11990218E+02, 0.10904073E+02,&
- 0.89126838E+01, 0.85622405E+01, 0.94892164E+01, 0.13580937E+02,-0.32050918E+03,-0.37133165E+01, 0.18890836E+00, 0.14209226E+01,&
- 0.19817679E+01, 0.79709806E+01, 0.75400737E+01, 0.81804377E+01, 0.10564339E+02, 0.46896789E+02,-0.30926524E+01, 0.85742941E+00,&
- 0.19164038E+01, 0.23513199E+01, 0.25566644E+01, 0.26555181E+01, 0.87668459E-01, 0.83754276E-01, 0.80460283E-01, 0.77659686E-01,&
- 0.75257056E-01, 0.73179175E-01, 0.71369063E-01, 0.69781812E-01, 0.68381606E-01, 0.67139539E-01, 0.66032012E-01, 0.74878820E-01,&
- 0.71650966E-01, 0.68979615E-01, 0.66745345E-01, 0.64857571E-01, 0.63248495E-01, 0.61866970E-01, 0.60673632E-01, 0.59637277E-01,&
- 0.58732178E-01, 0.57936092E-01, 0.13230067E+02, 0.13213564E+02, 0.13209140E+02, 0.13213894E+02, 0.13225963E+02, 0.13243806E+02,&
- 0.13266104E+02, 0.13291782E+02, 0.13319961E+02, 0.13349927E+02, 0.13381108E+02, 0.13183816E+02, 0.13189991E+02, 0.13209485E+02,&
- 0.13238789E+02, 0.13275017E+02, 0.13316096E+02, 0.13360555E+02, 0.13407324E+02, 0.13455544E+02, 0.13504450E+02, 0.13553282E+02,&
--0.99506586E-03,-0.10184169E-02,-0.10404730E-02,-0.10621792E-02,-0.10847662E-02,-0.11094726E-02,-0.11372949E-02,-0.11687683E-02,&
--0.12038314E-02,-0.12418367E-02,-0.12817135E-02,-0.11661515E-02,-0.11886130E-02,-0.12139929E-02,-0.12445811E-02,-0.12807672E-02,&
--0.13208251E-02,-0.13619034E-02,-0.14014165E-02,-0.14378639E-02,-0.14708488E-02,-0.15006791E-02, 0.41243390E+00, 0.43407282E+00,&
- 0.45331413E+00, 0.47048604E+00, 0.48586286E+00, 0.49968044E+00, 0.51214132E+00, 0.52341830E+00, 0.53365803E+00, 0.54298448E+00,&
- 0.55150227E+00, 0.48318936E+00, 0.50501827E+00, 0.52409502E+00, 0.54085277E+00, 0.55565422E+00, 0.56878618E+00, 0.58047395E+00,&
- 0.59089894E+00, 0.60021475E+00, 0.60856112E+00, 0.61607594E+00,-0.22159303E-01,-0.22748917E-01,-0.23269898E-01,-0.23732392E-01,&
--0.24145123E-01,-0.24515269E-01,-0.24848690E-01,-0.25150210E-01,-0.25423873E-01,-0.25673139E-01,-0.25901055E-01,-0.24972399E-01,&
--0.25537247E-01,-0.26025624E-01,-0.26450280E-01,-0.26821236E-01,-0.27146657E-01,-0.27433354E-01,-0.27687065E-01,-0.27912608E-01,&
--0.28113944E-01,-0.28294180E-01, 0.80737799E+01, 0.79171158E+01, 0.77609605E+01, 0.76087371E+01, 0.74627112E+01, 0.73239981E+01,&
- 0.71929934E+01, 0.70697065E+01, 0.69539626E+01, 0.68455144E+01, 0.67441020E+01, 0.77425778E+01, 0.75443460E+01, 0.73526151E+01,&
- 0.71711188E+01, 0.70015571E+01, 0.68442532E+01, 0.66987996E+01, 0.65644820E+01, 0.64405267E+01, 0.63262376E+01, 0.62210701E+01,&
- 0.10542131E+02, 0.10515895E+02, 0.10492949E+02, 0.10472049E+02, 0.10452961E+02, 0.10435562E+02, 0.10419710E+02, 0.10405247E+02,&
- 0.10392022E+02, 0.10379892E+02, 0.10368736E+02, 0.10490353E+02, 0.10463512E+02, 0.10439183E+02, 0.10417324E+02, 0.10397704E+02,&
- 0.10380038E+02, 0.10364052E+02, 0.10349509E+02, 0.10336215E+02, 0.10324018E+02, 0.10312808E+02,-0.12823142E+01,-0.10571588E+01,&
--0.74864953E+00,-0.58705980E+00,-0.49305772E+00,-0.51461431E+00, 0.12373350E+02, 0.44809588E+00, 0.46548918E+00, 0.59121475E+00,&
- 0.74676119E+00,-0.74805226E+00,-0.56252739E+00,-0.46188072E+00,-0.40712065E+00,-0.15295996E+01, 0.43555255E+00, 0.50380874E+00,&
- 0.68537352E+00, 0.89437630E+00, 0.11127003E+01, 0.13329782E+01, 0.13845511E+01, 0.13187042E+01, 0.12644396E+01, 0.12191543E+01,&
- 0.11809511E+01, 0.11484154E+01, 0.11204723E+01, 0.10962918E+01, 0.10752229E+01, 0.10567474E+01, 0.10404465E+01, 0.11718758E+01,&
- 0.11216131E+01, 0.10809473E+01, 0.10476396E+01, 0.10200373E+01, 0.99692726E+00, 0.97740923E+00, 0.96080188E+00, 0.94657562E+00,&
- 0.93430511E+00, 0.92363528E+00, 0.22042132E+02, 0.22107298E+02, 0.22180915E+02, 0.22259478E+02, 0.22341039E+02, 0.22424247E+02,&
- 0.22508089E+02, 0.22591771E+02, 0.22674661E+02, 0.22756246E+02, 0.22836093E+02, 0.22169501E+02, 0.22270075E+02, 0.22379193E+02,&
- 0.22492992E+02, 0.22608508E+02, 0.22723843E+02, 0.22837837E+02, 0.22949751E+02, 0.23059032E+02, 0.23165146E+02, 0.23267456E+02,&
- 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00,&
- 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00,&
- 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00,&
- 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00,&
- 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00,&
- 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00,&
- 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00,&
- 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00,&
- 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00,&
- 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00,&
- 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00,&
- 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00,&
- 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00,&
- 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00,&
- 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00,&
- 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00,&
- 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00,&
- 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00,&
- 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00,&
- 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00,&
- 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00,&
- 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00 /) &
- , (/ 11,16,3 /) )
-
- real(kind=8), dimension(11,16,3), parameter :: GB = reshape ( (/ &
- 0.63499072E-02, 0.65566348E-02, 0.67849730E-02, 0.70481947E-02, 0.73585943E-02, 0.77242818E-02, 0.81472693E-02, 0.86227527E-02,&
- 0.91396814E-02, 0.96825438E-02, 0.10233955E-01, 0.77266491E-02, 0.81323287E-02, 0.86507620E-02, 0.92776391E-02, 0.99806312E-02,&
- 0.10709803E-01, 0.11414739E-01, 0.12058772E-01, 0.12623992E-01, 0.13108146E-01, 0.13518390E-01, 0.11644593E+01, 0.11747203E+01,&
- 0.11837872E+01, 0.11918561E+01, 0.11990757E+01, 0.12055643E+01, 0.12114186E+01, 0.12167192E+01, 0.12215344E+01, 0.12259226E+01,&
- 0.12299344E+01, 0.12006968E+01, 0.12108196E+01, 0.12196717E+01, 0.12274493E+01, 0.12343189E+01, 0.12404147E+01, 0.12458431E+01,&
- 0.12506907E+01, 0.12550299E+01, 0.12589256E+01, 0.12624402E+01, 0.15750172E+00, 0.16174076E+00, 0.16548628E+00, 0.16881124E+00,&
- 0.17177839E+00, 0.17443933E+00, 0.17683622E+00, 0.17900375E+00, 0.18097099E+00, 0.18276283E+00, 0.18440117E+00, 0.17770551E+00,&
- 0.18176757E+00, 0.18527967E+00, 0.18833348E+00, 0.19100108E+00, 0.19334122E+00, 0.19540288E+00, 0.19722732E+00, 0.19884918E+00,&
- 0.20029696E+00, 0.20159300E+00, 0.10192131E+02, 0.97258602E+01, 0.92992890E+01, 0.89154021E+01, 0.85730084E+01, 0.82685838E+01,&
- 0.79978921E+01, 0.77568055E+01, 0.75416266E+01, 0.73491694E+01, 0.71767400E+01, 0.92439050E+01, 0.87567422E+01, 0.83270144E+01,&
- 0.79528337E+01, 0.76286839E+01, 0.73477879E+01, 0.71035818E+01, 0.68903312E+01, 0.67032875E+01, 0.65386461E+01, 0.63934377E+01,&
- 0.24870635E+02, 0.24725591E+02, 0.24600320E+02, 0.24487300E+02, 0.24384935E+02, 0.24292341E+02, 0.24208572E+02, 0.24132642E+02,&
- 0.24063614E+02, 0.24000649E+02, 0.23943021E+02, 0.24586283E+02, 0.24441465E+02, 0.24311657E+02, 0.24196167E+02, 0.24093406E+02,&
- 0.24001597E+02, 0.23919098E+02, 0.23844511E+02, 0.23776708E+02, 0.23714816E+02, 0.23658197E+02, 0.11990218E+02, 0.10904073E+02,&
- 0.89126838E+01, 0.85622405E+01, 0.94892164E+01, 0.13580937E+02,-0.32050918E+03,-0.37133165E+01, 0.18890836E+00, 0.14209226E+01,&
- 0.19817679E+01, 0.79709806E+01, 0.75400737E+01, 0.81804377E+01, 0.10564339E+02, 0.46896789E+02,-0.30926524E+01, 0.85742941E+00,&
- 0.19164038E+01, 0.23513199E+01, 0.25566644E+01, 0.26555181E+01, 0.87668459E-01, 0.83754276E-01, 0.80460283E-01, 0.77659686E-01,&
- 0.75257056E-01, 0.73179175E-01, 0.71369063E-01, 0.69781812E-01, 0.68381606E-01, 0.67139539E-01, 0.66032012E-01, 0.74878820E-01,&
- 0.71650966E-01, 0.68979615E-01, 0.66745345E-01, 0.64857571E-01, 0.63248495E-01, 0.61866970E-01, 0.60673632E-01, 0.59637277E-01,&
- 0.58732178E-01, 0.57936092E-01, 0.13230067E+02, 0.13213564E+02, 0.13209140E+02, 0.13213894E+02, 0.13225963E+02, 0.13243806E+02,&
- 0.13266104E+02, 0.13291782E+02, 0.13319961E+02, 0.13349927E+02, 0.13381108E+02, 0.13183816E+02, 0.13189991E+02, 0.13209485E+02,&
- 0.13238789E+02, 0.13275017E+02, 0.13316096E+02, 0.13360555E+02, 0.13407324E+02, 0.13455544E+02, 0.13504450E+02, 0.13553282E+02,&
- 0.97222852E-01, 0.98862238E-01, 0.10061504E+00, 0.10256222E+00, 0.10475952E+00, 0.10720986E+00, 0.10985370E+00, 0.11257633E+00,&
- 0.11522980E+00, 0.11766343E+00, 0.11975320E+00, 0.10681591E+00, 0.10921298E+00, 0.11198225E+00, 0.11487826E+00, 0.11751113E+00,&
- 0.11951535E+00, 0.12069945E+00, 0.12108524E+00, 0.12084229E+00, 0.12019005E+00, 0.11932684E+00, 0.10346097E+01, 0.10433655E+01,&
- 0.10511933E+01, 0.10582150E+01, 0.10645317E+01, 0.10702313E+01, 0.10753907E+01, 0.10800762E+01, 0.10843446E+01, 0.10882439E+01,&
- 0.10918144E+01, 0.10626130E+01, 0.10716026E+01, 0.10795108E+01, 0.10865006E+01, 0.10927103E+01, 0.10982489E+01, 0.11032019E+01,&
- 0.11076379E+01, 0.11116160E+01, 0.11151910E+01, 0.11184188E+01, 0.38103212E+00, 0.38913800E+00, 0.39613651E+00, 0.40222421E+00,&
- 0.40756010E+00, 0.41226954E+00, 0.41645142E+00, 0.42018474E+00, 0.42353379E+00, 0.42655211E+00, 0.42928533E+00, 0.41646579E+00,&
- 0.42345095E+00, 0.42937476E+00, 0.43444062E+00, 0.43880316E+00, 0.44258354E+00, 0.44587882E+00, 0.44876776E+00, 0.45131451E+00,&
- 0.45357095E+00, 0.45557797E+00, 0.82623280E+01, 0.81072291E+01, 0.79523834E+01, 0.78012527E+01, 0.76561458E+01, 0.75182174E+01,&
- 0.73878952E+01, 0.72652133E+01, 0.71500151E+01, 0.70420667E+01, 0.69411177E+01, 0.79342219E+01, 0.77373458E+01, 0.75467334E+01,&
- 0.73661786E+01, 0.71974319E+01, 0.70408543E+01, 0.68960649E+01, 0.67623672E+01, 0.66389989E+01, 0.65252707E+01, 0.64206412E+01,&
- 0.10656640E+02, 0.10630910E+02, 0.10608399E+02, 0.10587891E+02, 0.10569156E+02, 0.10552075E+02, 0.10536510E+02, 0.10522307E+02,&
- 0.10509317E+02, 0.10497402E+02, 0.10486443E+02, 0.10605856E+02, 0.10579514E+02, 0.10555632E+02, 0.10534169E+02, 0.10514900E+02,&
- 0.10497547E+02, 0.10481842E+02, 0.10467553E+02, 0.10454488E+02, 0.10442501E+02, 0.10431483E+02, 0.26681588E+02, 0.24728346E+02,&
- 0.20551342E+02, 0.19955244E+02, 0.22227100E+02, 0.31770288E+02,-0.74061287E+03,-0.81329826E+01, 0.90279822E+00, 0.37532746E+01,&
- 0.50437916E+01, 0.18377807E+02, 0.17643148E+02, 0.19296161E+02, 0.24951120E+02, 0.10957372E+03,-0.67432659E+01, 0.24550746E+01,&
- 0.49089917E+01, 0.59008712E+01, 0.63532616E+01, 0.65558627E+01, 0.23203798E+01, 0.22288925E+01, 0.21515593E+01, 0.20855896E+01,&
- 0.20288489E+01, 0.19796791E+01, 0.19367778E+01, 0.18991112E+01, 0.18658501E+01, 0.18363226E+01, 0.18099779E+01, 0.20206726E+01,&
- 0.19441824E+01, 0.18807257E+01, 0.18275618E+01, 0.17825910E+01, 0.17442308E+01, 0.17112809E+01, 0.16828137E+01, 0.16580908E+01,&
- 0.16365014E+01, 0.16175164E+01, 0.22051750E+02, 0.22116850E+02, 0.22190410E+02, 0.22268925E+02, 0.22350445E+02, 0.22433617E+02,&
- 0.22517429E+02, 0.22601086E+02, 0.22683956E+02, 0.22765522E+02, 0.22845354E+02, 0.22178972E+02, 0.22279484E+02, 0.22388551E+02,&
- 0.22502309E+02, 0.22617792E+02, 0.22733099E+02, 0.22847071E+02, 0.22958967E+02, 0.23068234E+02, 0.23174336E+02, 0.23276638E+02,&
- 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01,&
- 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01,&
- 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01,&
- 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01,&
- 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01,&
- 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01,&
- 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01,&
- 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01,&
- 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01,&
- 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01,&
- 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01,&
- 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01,&
- 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01,&
- 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01,&
- 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01,&
- 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01,&
- 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01,&
- 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01,&
- 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01,&
- 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01,&
- 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01,&
- 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01 /) &
-  , (/ 11,16,3 /) )
-
-      real(kind=8), dimension(6,6), parameter :: XP = reshape ( (/  &
-      0.46430621E+02,  0.12928299E+03,  0.20732648E+03,  0.31398411E+03,  0.18373177E+03, -0.11412303E+03, &
-      0.73604774E+02,  0.27887914E+03,  0.27076947E+03, -0.57322111E+02, -0.64742459E+02,  0.87238280E+02, &
-      0.37050866E+02,  0.20498759E+03,  0.37558029E+03,  0.17401171E+03, -0.13350302E+03, -0.37651795E+02, &
-      0.14930141E+02,  0.89161160E+02,  0.17793062E+03,  0.93433860E+02, -0.70646020E+02, -0.26373150E+02, &
-      0.40386780E+02,  0.10855270E+03,  0.50755010E+02, -0.31496190E+02,  0.12791300E+00,  0.18017770E+01, &
-      0.90811926E+01,  0.75073923E+02,  0.24654438E+03,  0.39332612E+03,  0.29385281E+03,  0.89107921E+02 /) , (/ 6,6 /) )
-
-! If running with Reporbus type_trac=repr, values of RSUN might be overritten in radiation_AR4
-      REAL(KIND=8), dimension(2) :: RSUN = (/ 0.441676 , 0.558324 /)
-      REAL(KIND=8), dimension(2,6), parameter :: RRAY = reshape ( &
-         (/ .428937E-01, .697200E-02,&
-            .890743E+00, .173297E-01,&
-           -.288555E+01,-.850903E-01,&
-            .522744E+01, .248261E+00,&
-           -.469173E+01,-.302031E+00,&
-            .161645E+01, .129662E+00 /) , (/2,6/) )
-
-      REAL(KIND=8), dimension(2,5), parameter :: TAUA = reshape ( &
-      (/ 0.730719, 0.730719, 0.912819, 0.912819, 0.725059, &
-         0.725059, 0.745405, 0.745405, 0.682188, 0.682188 /),(/2,5/) )
-      REAL(KIND=8), dimension(2,5), parameter :: RPIZA = reshape ( &
-      (/ 0.872212, 0.872212, 0.982545, 0.982545, 0.623143,   &
-         0.623143, 0.944887, 0.944887, 0.997975, 0.997975 /),(/2,5/) )
-      REAL(KIND=8), dimension(2,5), parameter :: RCGA = reshape (  &
-      (/ 0.647596, 0.647596, 0.739002, 0.739002, 0.580845,   &
-         0.580845, 0.662657, 0.662657, 0.624246, 0.624246 /),(/2,5/) )
-
-      REAL(KIND=8), dimension(2,3,7), parameter :: APAD = reshape (  &
-          (/ 0.912418292E+05, 0.376655383E-08, 0.000000000E-00,&
-             0.739646016E-08, 0.925887084E-04, 0.410177786E+03,&
-             0.723613782E+05, 0.978576773E-04, 0.000000000E-00,&
-             0.131849595E-03, 0.129353723E-01, 0.672595424E+02,&
-             0.596037057E+04, 0.387714006E+00, 0.000000000E-00,&
-             0.437772681E+00, 0.800821928E+00, 0.000000000E-00,&
-             0.000000000E-00, 0.118461660E+03, 0.000000000E-00,&
-             0.151345118E+03, 0.242715973E+02, 0.000000000E-00,&
-             0.000000000E-00, 0.119079797E+04, 0.000000000E-00,&
-             0.233628890E+04, 0.878331486E+02, 0.000000000E-00,&
-             0.000000000E-00, 0.293353397E+03, 0.000000000E-00,&
-             0.797219934E+03, 0.191559725E+02, 0.000000000E-00,&
-             0.000000000E-00, 0.000000000E+00, 0.000000000E-00,&
-             0.000000000E+00, 0.000000000E+00, 0.000000000E+00 /) , (/2,3,7/) )
-      REAL(KIND=8), dimension(2,3,7), parameter :: BPAD = reshape (  &
-          (/ 0.912418292E+05, 0.376655383E-08, 0.000000000E-00,&
-             0.739646016E-08, 0.925887084E-04, 0.410177786E+03,&
-             0.724555318E+05, 0.979023421E-04, 0.000000000E-00,&
-             0.131861712E-03, 0.131812683E-01, 0.731185438E+02,&
-             0.602593328E+04, 0.388611139E+00, 0.000000000E-00,&
-             0.437949001E+00, 0.812706117E+00, 0.100000000E+01,&
-             0.100000000E+01, 0.120291383E+03, 0.000000000E-00,&
-             0.151692730E+03, 0.249863591E+02, 0.000000000E+00,&
-             0.000000000E-00, 0.130531005E+04, 0.000000000E-00,&
-             0.237071130E+04, 0.931071925E+02, 0.000000000E+00,&
-             0.000000000E-00, 0.415049409E+03, 0.000000000E-00,&
-             0.867914360E+03, 0.252233437E+02, 0.000000000E+00,&
-             0.000000000E-00, 0.100000000E+01, 0.000000000E-00,&
-             0.100000000E+01, 0.100000000E+01, 0.000000000E+00 /) , (/2,3,7/) )
-      REAL(KIND=8), dimension(2,3), parameter :: D = reshape ( &
-       (/ 0.0, 0.0, 0.0, 0.0, 0.0, 0.8 /) , (/2,3/) )
-
-      REAL(KIND=8), parameter :: TREF = 250.0
-      REAL(KIND=8), dimension(2), parameter :: RT1 = (/ -0.577350269, +0.577350269 /)
-      REAL(KIND=8), dimension(5,5), parameter :: RAER= reshape ( &
-        (/ .038520, .037196, .040532, .054934, .038520 &
-         , .12613 , .18313 , .10357 , .064106, .126130 &
-         , .012579, .013649, .018652, .025181, .012579 &
-         , .011890, .016142, .021105, .028908, .011890 &
-         , .013792, .026810, .052203, .066338, .013792 /) , (/5,5/) )
-
-      REAL(KIND=8), dimension(8,3), parameter :: AT= reshape ( &
-       (/ 0.298199E-02,0.143676E-01,0.197861E-01,0.289560E-01,&
-          0.103800E-01,0.868859E-02,0.250073E-03,0.307423E-01,&
-          -.394023E-03,0.366501E-02,0.315541E-02,-.208807E-02,&
-          0.436296E-02,-.972752E-03,0.455875E-03,0.110879E-02,&
-          0.319566E-04,-.160822E-02,-.174547E-02,-.121943E-02,&
-          -.161431E-02,0.000000E-00,0.109242E-03,-.322172E-03 /) , (/8,3/) )
-
-      REAL(KIND=8), dimension(8,3), parameter :: BT= reshape ( &
-       (/ -0.106432E-04,-0.553979E-04,-0.877012E-04,-0.165960E-03,&
-          -0.276744E-04,-0.278412E-04, 0.199846E-05,-0.108482E-03,&
-           0.660324E-06,-0.101701E-04, 0.513302E-04, 0.157704E-03,&
-          -0.327381E-04,-0.713940E-06,-0.216313E-05, 0.258096E-05,&
-           0.174356E-06, 0.920868E-05, 0.523138E-06,-0.146427E-04,&
-           0.127646E-04 ,0.117469E-05, 0.175991E-06,-0.814575E-06 /) , (/8,3/) )
-
-      REAL(KIND=8), dimension(4), parameter :: OCT = (/ -.326E-03, -.102E-05, .137E-02, -.535E-05 /)
-
- end module radiation_AR4_param
Index: /LMDZ6/trunk/libf/phylmd/radiation_ar4_param.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/radiation_ar4_param.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/radiation_ar4_param.f90	(revision 5268)
@@ -0,0 +1,243 @@
+MODULE radiation_ar4_param
+
+ IMPLICIT NONE
+
+ REAL(KIND=8), parameter :: ZPDH2O = 0.8
+ REAL(KIND=8), parameter :: ZPDUMG = 0.75
+ REAL(KIND=8), parameter :: ZPRH2O = 30000.0
+ REAL(KIND=8), parameter :: ZPRUMG = 30000.0
+ REAL(KIND=8), parameter :: RTDH2O = 0.40
+ REAL(KIND=8), parameter :: RTDUMG = 0.375
+ REAL(KIND=8), parameter :: RTH2O = 240.0
+ REAL(KIND=8), parameter :: RTUMG = 240.0
+
+ REAL(KIND=8), dimension(2), parameter :: WG1 = (/1.0, 1.0/)
+ REAL(KIND=8), dimension(11), parameter :: TINTP = (/ 187.5, 200., 212.5, 225., 237.5, 250., 262.5, 275., 287.5, 300., 312.5 /)
+
+ real(kind=8), dimension(11,16,3), parameter :: GA = reshape ( (/ &
+ 0.63499072E-02, 0.65566348E-02, 0.67849730E-02, 0.70481947E-02, 0.73585943E-02, 0.77242818E-02, 0.81472693E-02, 0.86227527E-02,&
+ 0.91396814E-02, 0.96825438E-02, 0.10233955E-01, 0.77266491E-02, 0.81323287E-02, 0.86507620E-02, 0.92776391E-02, 0.99806312E-02,&
+ 0.10709803E-01, 0.11414739E-01, 0.12058772E-01, 0.12623992E-01, 0.13108146E-01, 0.13518390E-01, 0.11644593E+01, 0.11747203E+01,&
+ 0.11837872E+01, 0.11918561E+01, 0.11990757E+01, 0.12055643E+01, 0.12114186E+01, 0.12167192E+01, 0.12215344E+01, 0.12259226E+01,&
+ 0.12299344E+01, 0.12006968E+01, 0.12108196E+01, 0.12196717E+01, 0.12274493E+01, 0.12343189E+01, 0.12404147E+01, 0.12458431E+01,&
+ 0.12506907E+01, 0.12550299E+01, 0.12589256E+01, 0.12624402E+01, 0.15750172E+00, 0.16174076E+00, 0.16548628E+00, 0.16881124E+00,&
+ 0.17177839E+00, 0.17443933E+00, 0.17683622E+00, 0.17900375E+00, 0.18097099E+00, 0.18276283E+00, 0.18440117E+00, 0.17770551E+00,&
+ 0.18176757E+00, 0.18527967E+00, 0.18833348E+00, 0.19100108E+00, 0.19334122E+00, 0.19540288E+00, 0.19722732E+00, 0.19884918E+00,&
+ 0.20029696E+00, 0.20159300E+00, 0.10192131E+02, 0.97258602E+01, 0.92992890E+01, 0.89154021E+01, 0.85730084E+01, 0.82685838E+01,&
+ 0.79978921E+01, 0.77568055E+01, 0.75416266E+01, 0.73491694E+01, 0.71767400E+01, 0.92439050E+01, 0.87567422E+01, 0.83270144E+01,&
+ 0.79528337E+01, 0.76286839E+01, 0.73477879E+01, 0.71035818E+01, 0.68903312E+01, 0.67032875E+01, 0.65386461E+01, 0.63934377E+01,&
+ 0.24870635E+02, 0.24725591E+02, 0.24600320E+02, 0.24487300E+02, 0.24384935E+02, 0.24292341E+02, 0.24208572E+02, 0.24132642E+02,&
+ 0.24063614E+02, 0.24000649E+02, 0.23943021E+02, 0.24586283E+02, 0.24441465E+02, 0.24311657E+02, 0.24196167E+02, 0.24093406E+02,&
+ 0.24001597E+02, 0.23919098E+02, 0.23844511E+02, 0.23776708E+02, 0.23714816E+02, 0.23658197E+02, 0.11990218E+02, 0.10904073E+02,&
+ 0.89126838E+01, 0.85622405E+01, 0.94892164E+01, 0.13580937E+02,-0.32050918E+03,-0.37133165E+01, 0.18890836E+00, 0.14209226E+01,&
+ 0.19817679E+01, 0.79709806E+01, 0.75400737E+01, 0.81804377E+01, 0.10564339E+02, 0.46896789E+02,-0.30926524E+01, 0.85742941E+00,&
+ 0.19164038E+01, 0.23513199E+01, 0.25566644E+01, 0.26555181E+01, 0.87668459E-01, 0.83754276E-01, 0.80460283E-01, 0.77659686E-01,&
+ 0.75257056E-01, 0.73179175E-01, 0.71369063E-01, 0.69781812E-01, 0.68381606E-01, 0.67139539E-01, 0.66032012E-01, 0.74878820E-01,&
+ 0.71650966E-01, 0.68979615E-01, 0.66745345E-01, 0.64857571E-01, 0.63248495E-01, 0.61866970E-01, 0.60673632E-01, 0.59637277E-01,&
+ 0.58732178E-01, 0.57936092E-01, 0.13230067E+02, 0.13213564E+02, 0.13209140E+02, 0.13213894E+02, 0.13225963E+02, 0.13243806E+02,&
+ 0.13266104E+02, 0.13291782E+02, 0.13319961E+02, 0.13349927E+02, 0.13381108E+02, 0.13183816E+02, 0.13189991E+02, 0.13209485E+02,&
+ 0.13238789E+02, 0.13275017E+02, 0.13316096E+02, 0.13360555E+02, 0.13407324E+02, 0.13455544E+02, 0.13504450E+02, 0.13553282E+02,&
+-0.99506586E-03,-0.10184169E-02,-0.10404730E-02,-0.10621792E-02,-0.10847662E-02,-0.11094726E-02,-0.11372949E-02,-0.11687683E-02,&
+-0.12038314E-02,-0.12418367E-02,-0.12817135E-02,-0.11661515E-02,-0.11886130E-02,-0.12139929E-02,-0.12445811E-02,-0.12807672E-02,&
+-0.13208251E-02,-0.13619034E-02,-0.14014165E-02,-0.14378639E-02,-0.14708488E-02,-0.15006791E-02, 0.41243390E+00, 0.43407282E+00,&
+ 0.45331413E+00, 0.47048604E+00, 0.48586286E+00, 0.49968044E+00, 0.51214132E+00, 0.52341830E+00, 0.53365803E+00, 0.54298448E+00,&
+ 0.55150227E+00, 0.48318936E+00, 0.50501827E+00, 0.52409502E+00, 0.54085277E+00, 0.55565422E+00, 0.56878618E+00, 0.58047395E+00,&
+ 0.59089894E+00, 0.60021475E+00, 0.60856112E+00, 0.61607594E+00,-0.22159303E-01,-0.22748917E-01,-0.23269898E-01,-0.23732392E-01,&
+-0.24145123E-01,-0.24515269E-01,-0.24848690E-01,-0.25150210E-01,-0.25423873E-01,-0.25673139E-01,-0.25901055E-01,-0.24972399E-01,&
+-0.25537247E-01,-0.26025624E-01,-0.26450280E-01,-0.26821236E-01,-0.27146657E-01,-0.27433354E-01,-0.27687065E-01,-0.27912608E-01,&
+-0.28113944E-01,-0.28294180E-01, 0.80737799E+01, 0.79171158E+01, 0.77609605E+01, 0.76087371E+01, 0.74627112E+01, 0.73239981E+01,&
+ 0.71929934E+01, 0.70697065E+01, 0.69539626E+01, 0.68455144E+01, 0.67441020E+01, 0.77425778E+01, 0.75443460E+01, 0.73526151E+01,&
+ 0.71711188E+01, 0.70015571E+01, 0.68442532E+01, 0.66987996E+01, 0.65644820E+01, 0.64405267E+01, 0.63262376E+01, 0.62210701E+01,&
+ 0.10542131E+02, 0.10515895E+02, 0.10492949E+02, 0.10472049E+02, 0.10452961E+02, 0.10435562E+02, 0.10419710E+02, 0.10405247E+02,&
+ 0.10392022E+02, 0.10379892E+02, 0.10368736E+02, 0.10490353E+02, 0.10463512E+02, 0.10439183E+02, 0.10417324E+02, 0.10397704E+02,&
+ 0.10380038E+02, 0.10364052E+02, 0.10349509E+02, 0.10336215E+02, 0.10324018E+02, 0.10312808E+02,-0.12823142E+01,-0.10571588E+01,&
+-0.74864953E+00,-0.58705980E+00,-0.49305772E+00,-0.51461431E+00, 0.12373350E+02, 0.44809588E+00, 0.46548918E+00, 0.59121475E+00,&
+ 0.74676119E+00,-0.74805226E+00,-0.56252739E+00,-0.46188072E+00,-0.40712065E+00,-0.15295996E+01, 0.43555255E+00, 0.50380874E+00,&
+ 0.68537352E+00, 0.89437630E+00, 0.11127003E+01, 0.13329782E+01, 0.13845511E+01, 0.13187042E+01, 0.12644396E+01, 0.12191543E+01,&
+ 0.11809511E+01, 0.11484154E+01, 0.11204723E+01, 0.10962918E+01, 0.10752229E+01, 0.10567474E+01, 0.10404465E+01, 0.11718758E+01,&
+ 0.11216131E+01, 0.10809473E+01, 0.10476396E+01, 0.10200373E+01, 0.99692726E+00, 0.97740923E+00, 0.96080188E+00, 0.94657562E+00,&
+ 0.93430511E+00, 0.92363528E+00, 0.22042132E+02, 0.22107298E+02, 0.22180915E+02, 0.22259478E+02, 0.22341039E+02, 0.22424247E+02,&
+ 0.22508089E+02, 0.22591771E+02, 0.22674661E+02, 0.22756246E+02, 0.22836093E+02, 0.22169501E+02, 0.22270075E+02, 0.22379193E+02,&
+ 0.22492992E+02, 0.22608508E+02, 0.22723843E+02, 0.22837837E+02, 0.22949751E+02, 0.23059032E+02, 0.23165146E+02, 0.23267456E+02,&
+ 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00,&
+ 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00,&
+ 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00,&
+ 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00,&
+ 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00,&
+ 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00,&
+ 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00,&
+ 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00,&
+ 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00,&
+ 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00,&
+ 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00,&
+ 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00,&
+ 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00,&
+ 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00,&
+ 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00,&
+ 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00,&
+ 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00,&
+ 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00,&
+ 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00,&
+ 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00,&
+ 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00,&
+ 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00 /) &
+ , (/ 11,16,3 /) )
+
+ real(kind=8), dimension(11,16,3), parameter :: GB = reshape ( (/ &
+ 0.63499072E-02, 0.65566348E-02, 0.67849730E-02, 0.70481947E-02, 0.73585943E-02, 0.77242818E-02, 0.81472693E-02, 0.86227527E-02,&
+ 0.91396814E-02, 0.96825438E-02, 0.10233955E-01, 0.77266491E-02, 0.81323287E-02, 0.86507620E-02, 0.92776391E-02, 0.99806312E-02,&
+ 0.10709803E-01, 0.11414739E-01, 0.12058772E-01, 0.12623992E-01, 0.13108146E-01, 0.13518390E-01, 0.11644593E+01, 0.11747203E+01,&
+ 0.11837872E+01, 0.11918561E+01, 0.11990757E+01, 0.12055643E+01, 0.12114186E+01, 0.12167192E+01, 0.12215344E+01, 0.12259226E+01,&
+ 0.12299344E+01, 0.12006968E+01, 0.12108196E+01, 0.12196717E+01, 0.12274493E+01, 0.12343189E+01, 0.12404147E+01, 0.12458431E+01,&
+ 0.12506907E+01, 0.12550299E+01, 0.12589256E+01, 0.12624402E+01, 0.15750172E+00, 0.16174076E+00, 0.16548628E+00, 0.16881124E+00,&
+ 0.17177839E+00, 0.17443933E+00, 0.17683622E+00, 0.17900375E+00, 0.18097099E+00, 0.18276283E+00, 0.18440117E+00, 0.17770551E+00,&
+ 0.18176757E+00, 0.18527967E+00, 0.18833348E+00, 0.19100108E+00, 0.19334122E+00, 0.19540288E+00, 0.19722732E+00, 0.19884918E+00,&
+ 0.20029696E+00, 0.20159300E+00, 0.10192131E+02, 0.97258602E+01, 0.92992890E+01, 0.89154021E+01, 0.85730084E+01, 0.82685838E+01,&
+ 0.79978921E+01, 0.77568055E+01, 0.75416266E+01, 0.73491694E+01, 0.71767400E+01, 0.92439050E+01, 0.87567422E+01, 0.83270144E+01,&
+ 0.79528337E+01, 0.76286839E+01, 0.73477879E+01, 0.71035818E+01, 0.68903312E+01, 0.67032875E+01, 0.65386461E+01, 0.63934377E+01,&
+ 0.24870635E+02, 0.24725591E+02, 0.24600320E+02, 0.24487300E+02, 0.24384935E+02, 0.24292341E+02, 0.24208572E+02, 0.24132642E+02,&
+ 0.24063614E+02, 0.24000649E+02, 0.23943021E+02, 0.24586283E+02, 0.24441465E+02, 0.24311657E+02, 0.24196167E+02, 0.24093406E+02,&
+ 0.24001597E+02, 0.23919098E+02, 0.23844511E+02, 0.23776708E+02, 0.23714816E+02, 0.23658197E+02, 0.11990218E+02, 0.10904073E+02,&
+ 0.89126838E+01, 0.85622405E+01, 0.94892164E+01, 0.13580937E+02,-0.32050918E+03,-0.37133165E+01, 0.18890836E+00, 0.14209226E+01,&
+ 0.19817679E+01, 0.79709806E+01, 0.75400737E+01, 0.81804377E+01, 0.10564339E+02, 0.46896789E+02,-0.30926524E+01, 0.85742941E+00,&
+ 0.19164038E+01, 0.23513199E+01, 0.25566644E+01, 0.26555181E+01, 0.87668459E-01, 0.83754276E-01, 0.80460283E-01, 0.77659686E-01,&
+ 0.75257056E-01, 0.73179175E-01, 0.71369063E-01, 0.69781812E-01, 0.68381606E-01, 0.67139539E-01, 0.66032012E-01, 0.74878820E-01,&
+ 0.71650966E-01, 0.68979615E-01, 0.66745345E-01, 0.64857571E-01, 0.63248495E-01, 0.61866970E-01, 0.60673632E-01, 0.59637277E-01,&
+ 0.58732178E-01, 0.57936092E-01, 0.13230067E+02, 0.13213564E+02, 0.13209140E+02, 0.13213894E+02, 0.13225963E+02, 0.13243806E+02,&
+ 0.13266104E+02, 0.13291782E+02, 0.13319961E+02, 0.13349927E+02, 0.13381108E+02, 0.13183816E+02, 0.13189991E+02, 0.13209485E+02,&
+ 0.13238789E+02, 0.13275017E+02, 0.13316096E+02, 0.13360555E+02, 0.13407324E+02, 0.13455544E+02, 0.13504450E+02, 0.13553282E+02,&
+ 0.97222852E-01, 0.98862238E-01, 0.10061504E+00, 0.10256222E+00, 0.10475952E+00, 0.10720986E+00, 0.10985370E+00, 0.11257633E+00,&
+ 0.11522980E+00, 0.11766343E+00, 0.11975320E+00, 0.10681591E+00, 0.10921298E+00, 0.11198225E+00, 0.11487826E+00, 0.11751113E+00,&
+ 0.11951535E+00, 0.12069945E+00, 0.12108524E+00, 0.12084229E+00, 0.12019005E+00, 0.11932684E+00, 0.10346097E+01, 0.10433655E+01,&
+ 0.10511933E+01, 0.10582150E+01, 0.10645317E+01, 0.10702313E+01, 0.10753907E+01, 0.10800762E+01, 0.10843446E+01, 0.10882439E+01,&
+ 0.10918144E+01, 0.10626130E+01, 0.10716026E+01, 0.10795108E+01, 0.10865006E+01, 0.10927103E+01, 0.10982489E+01, 0.11032019E+01,&
+ 0.11076379E+01, 0.11116160E+01, 0.11151910E+01, 0.11184188E+01, 0.38103212E+00, 0.38913800E+00, 0.39613651E+00, 0.40222421E+00,&
+ 0.40756010E+00, 0.41226954E+00, 0.41645142E+00, 0.42018474E+00, 0.42353379E+00, 0.42655211E+00, 0.42928533E+00, 0.41646579E+00,&
+ 0.42345095E+00, 0.42937476E+00, 0.43444062E+00, 0.43880316E+00, 0.44258354E+00, 0.44587882E+00, 0.44876776E+00, 0.45131451E+00,&
+ 0.45357095E+00, 0.45557797E+00, 0.82623280E+01, 0.81072291E+01, 0.79523834E+01, 0.78012527E+01, 0.76561458E+01, 0.75182174E+01,&
+ 0.73878952E+01, 0.72652133E+01, 0.71500151E+01, 0.70420667E+01, 0.69411177E+01, 0.79342219E+01, 0.77373458E+01, 0.75467334E+01,&
+ 0.73661786E+01, 0.71974319E+01, 0.70408543E+01, 0.68960649E+01, 0.67623672E+01, 0.66389989E+01, 0.65252707E+01, 0.64206412E+01,&
+ 0.10656640E+02, 0.10630910E+02, 0.10608399E+02, 0.10587891E+02, 0.10569156E+02, 0.10552075E+02, 0.10536510E+02, 0.10522307E+02,&
+ 0.10509317E+02, 0.10497402E+02, 0.10486443E+02, 0.10605856E+02, 0.10579514E+02, 0.10555632E+02, 0.10534169E+02, 0.10514900E+02,&
+ 0.10497547E+02, 0.10481842E+02, 0.10467553E+02, 0.10454488E+02, 0.10442501E+02, 0.10431483E+02, 0.26681588E+02, 0.24728346E+02,&
+ 0.20551342E+02, 0.19955244E+02, 0.22227100E+02, 0.31770288E+02,-0.74061287E+03,-0.81329826E+01, 0.90279822E+00, 0.37532746E+01,&
+ 0.50437916E+01, 0.18377807E+02, 0.17643148E+02, 0.19296161E+02, 0.24951120E+02, 0.10957372E+03,-0.67432659E+01, 0.24550746E+01,&
+ 0.49089917E+01, 0.59008712E+01, 0.63532616E+01, 0.65558627E+01, 0.23203798E+01, 0.22288925E+01, 0.21515593E+01, 0.20855896E+01,&
+ 0.20288489E+01, 0.19796791E+01, 0.19367778E+01, 0.18991112E+01, 0.18658501E+01, 0.18363226E+01, 0.18099779E+01, 0.20206726E+01,&
+ 0.19441824E+01, 0.18807257E+01, 0.18275618E+01, 0.17825910E+01, 0.17442308E+01, 0.17112809E+01, 0.16828137E+01, 0.16580908E+01,&
+ 0.16365014E+01, 0.16175164E+01, 0.22051750E+02, 0.22116850E+02, 0.22190410E+02, 0.22268925E+02, 0.22350445E+02, 0.22433617E+02,&
+ 0.22517429E+02, 0.22601086E+02, 0.22683956E+02, 0.22765522E+02, 0.22845354E+02, 0.22178972E+02, 0.22279484E+02, 0.22388551E+02,&
+ 0.22502309E+02, 0.22617792E+02, 0.22733099E+02, 0.22847071E+02, 0.22958967E+02, 0.23068234E+02, 0.23174336E+02, 0.23276638E+02,&
+ 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01,&
+ 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01,&
+ 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01,&
+ 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01,&
+ 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01,&
+ 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01,&
+ 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01,&
+ 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01,&
+ 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01,&
+ 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01,&
+ 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01,&
+ 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01,&
+ 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01,&
+ 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01,&
+ 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01,&
+ 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01,&
+ 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01,&
+ 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01,&
+ 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01,&
+ 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01,&
+ 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01,&
+ 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01 /) &
+  , (/ 11,16,3 /) )
+
+      real(kind=8), dimension(6,6), parameter :: XP = reshape ( (/  &
+      0.46430621E+02,  0.12928299E+03,  0.20732648E+03,  0.31398411E+03,  0.18373177E+03, -0.11412303E+03, &
+      0.73604774E+02,  0.27887914E+03,  0.27076947E+03, -0.57322111E+02, -0.64742459E+02,  0.87238280E+02, &
+      0.37050866E+02,  0.20498759E+03,  0.37558029E+03,  0.17401171E+03, -0.13350302E+03, -0.37651795E+02, &
+      0.14930141E+02,  0.89161160E+02,  0.17793062E+03,  0.93433860E+02, -0.70646020E+02, -0.26373150E+02, &
+      0.40386780E+02,  0.10855270E+03,  0.50755010E+02, -0.31496190E+02,  0.12791300E+00,  0.18017770E+01, &
+      0.90811926E+01,  0.75073923E+02,  0.24654438E+03,  0.39332612E+03,  0.29385281E+03,  0.89107921E+02 /) , (/ 6,6 /) )
+
+! If running with Reporbus type_trac=repr, values of RSUN might be overritten in radiation_AR4
+      REAL(KIND=8), dimension(2) :: RSUN = (/ 0.441676 , 0.558324 /)
+      REAL(KIND=8), dimension(2,6), parameter :: RRAY = reshape ( &
+         (/ .428937E-01, .697200E-02,&
+            .890743E+00, .173297E-01,&
+           -.288555E+01,-.850903E-01,&
+            .522744E+01, .248261E+00,&
+           -.469173E+01,-.302031E+00,&
+            .161645E+01, .129662E+00 /) , (/2,6/) )
+
+      REAL(KIND=8), dimension(2,5), parameter :: TAUA = reshape ( &
+      (/ 0.730719, 0.730719, 0.912819, 0.912819, 0.725059, &
+         0.725059, 0.745405, 0.745405, 0.682188, 0.682188 /),(/2,5/) )
+      REAL(KIND=8), dimension(2,5), parameter :: RPIZA = reshape ( &
+      (/ 0.872212, 0.872212, 0.982545, 0.982545, 0.623143,   &
+         0.623143, 0.944887, 0.944887, 0.997975, 0.997975 /),(/2,5/) )
+      REAL(KIND=8), dimension(2,5), parameter :: RCGA = reshape (  &
+      (/ 0.647596, 0.647596, 0.739002, 0.739002, 0.580845,   &
+         0.580845, 0.662657, 0.662657, 0.624246, 0.624246 /),(/2,5/) )
+
+      REAL(KIND=8), dimension(2,3,7), parameter :: APAD = reshape (  &
+          (/ 0.912418292E+05, 0.376655383E-08, 0.000000000E-00,&
+             0.739646016E-08, 0.925887084E-04, 0.410177786E+03,&
+             0.723613782E+05, 0.978576773E-04, 0.000000000E-00,&
+             0.131849595E-03, 0.129353723E-01, 0.672595424E+02,&
+             0.596037057E+04, 0.387714006E+00, 0.000000000E-00,&
+             0.437772681E+00, 0.800821928E+00, 0.000000000E-00,&
+             0.000000000E-00, 0.118461660E+03, 0.000000000E-00,&
+             0.151345118E+03, 0.242715973E+02, 0.000000000E-00,&
+             0.000000000E-00, 0.119079797E+04, 0.000000000E-00,&
+             0.233628890E+04, 0.878331486E+02, 0.000000000E-00,&
+             0.000000000E-00, 0.293353397E+03, 0.000000000E-00,&
+             0.797219934E+03, 0.191559725E+02, 0.000000000E-00,&
+             0.000000000E-00, 0.000000000E+00, 0.000000000E-00,&
+             0.000000000E+00, 0.000000000E+00, 0.000000000E+00 /) , (/2,3,7/) )
+      REAL(KIND=8), dimension(2,3,7), parameter :: BPAD = reshape (  &
+          (/ 0.912418292E+05, 0.376655383E-08, 0.000000000E-00,&
+             0.739646016E-08, 0.925887084E-04, 0.410177786E+03,&
+             0.724555318E+05, 0.979023421E-04, 0.000000000E-00,&
+             0.131861712E-03, 0.131812683E-01, 0.731185438E+02,&
+             0.602593328E+04, 0.388611139E+00, 0.000000000E-00,&
+             0.437949001E+00, 0.812706117E+00, 0.100000000E+01,&
+             0.100000000E+01, 0.120291383E+03, 0.000000000E-00,&
+             0.151692730E+03, 0.249863591E+02, 0.000000000E+00,&
+             0.000000000E-00, 0.130531005E+04, 0.000000000E-00,&
+             0.237071130E+04, 0.931071925E+02, 0.000000000E+00,&
+             0.000000000E-00, 0.415049409E+03, 0.000000000E-00,&
+             0.867914360E+03, 0.252233437E+02, 0.000000000E+00,&
+             0.000000000E-00, 0.100000000E+01, 0.000000000E-00,&
+             0.100000000E+01, 0.100000000E+01, 0.000000000E+00 /) , (/2,3,7/) )
+      REAL(KIND=8), dimension(2,3), parameter :: D = reshape ( &
+       (/ 0.0, 0.0, 0.0, 0.0, 0.0, 0.8 /) , (/2,3/) )
+
+      REAL(KIND=8), parameter :: TREF = 250.0
+      REAL(KIND=8), dimension(2), parameter :: RT1 = (/ -0.577350269, +0.577350269 /)
+      REAL(KIND=8), dimension(5,5), parameter :: RAER= reshape ( &
+        (/ .038520, .037196, .040532, .054934, .038520 &
+         , .12613 , .18313 , .10357 , .064106, .126130 &
+         , .012579, .013649, .018652, .025181, .012579 &
+         , .011890, .016142, .021105, .028908, .011890 &
+         , .013792, .026810, .052203, .066338, .013792 /) , (/5,5/) )
+
+      REAL(KIND=8), dimension(8,3), parameter :: AT= reshape ( &
+       (/ 0.298199E-02,0.143676E-01,0.197861E-01,0.289560E-01,&
+          0.103800E-01,0.868859E-02,0.250073E-03,0.307423E-01,&
+          -.394023E-03,0.366501E-02,0.315541E-02,-.208807E-02,&
+          0.436296E-02,-.972752E-03,0.455875E-03,0.110879E-02,&
+          0.319566E-04,-.160822E-02,-.174547E-02,-.121943E-02,&
+          -.161431E-02,0.000000E-00,0.109242E-03,-.322172E-03 /) , (/8,3/) )
+
+      REAL(KIND=8), dimension(8,3), parameter :: BT= reshape ( &
+       (/ -0.106432E-04,-0.553979E-04,-0.877012E-04,-0.165960E-03,&
+          -0.276744E-04,-0.278412E-04, 0.199846E-05,-0.108482E-03,&
+           0.660324E-06,-0.101701E-04, 0.513302E-04, 0.157704E-03,&
+          -0.327381E-04,-0.713940E-06,-0.216313E-05, 0.258096E-05,&
+           0.174356E-06, 0.920868E-05, 0.523138E-06,-0.146427E-04,&
+           0.127646E-04 ,0.117469E-05, 0.175991E-06,-0.814575E-06 /) , (/8,3/) )
+
+      REAL(KIND=8), dimension(4), parameter :: OCT = (/ -.326E-03, -.102E-05, .137E-02, -.535E-05 /)
+
+ end module radiation_AR4_param
Index: DZ6/trunk/libf/phylmd/radio_decay.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/radio_decay.F90	(revision 5267)
+++ 	(revision )
@@ -1,59 +1,0 @@
-!
-! $Id $
-!
-SUBROUTINE radio_decay(radio,rnpb,dtime,tautr,tr,d_tr) 
-!
-! Caluclate radioactive decay for all tracers with radio(it)=true
-!
-  USE dimphy
-  USE infotrac_phy, ONLY : nbtr
-  USE traclmdz_mod, ONLY : id_rn, id_pb
-  IMPLICIT NONE
-!-----------------------------------------------------------------------
-! Auteur(s): AA + CG (LGGE/CNRS) Date 24-06-94
-! Objet: Calcul de la tendance radioactive des traceurs type radioelements
-!        Cas particulier pour le couple radon-plomb : Le radon decroit en plomb
-!-----------------------------------------------------------------------
-!
-! Entrees
-!
-  LOGICAL,DIMENSION(nbtr),INTENT(IN)        :: radio ! .true. = traceur radioactif  
-  LOGICAL,INTENT(IN)                        :: rnpb  ! .true. = decroissance RN = source PB
-  REAL,INTENT(IN)                           :: dtime ! Pas de temps physique (secondes)
-  REAL,DIMENSION(nbtr),INTENT(IN)           :: tautr ! Constante de decroissance radioactive
-  REAL,DIMENSION(klon,klev,nbtr),INTENT(IN) :: tr    ! Concentrations traceurs U/kgA
-!
-! Sortie
-!
-  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT) :: d_tr  ! Tendance de decroissance radioactive
-!
-! Locales
-!
-  INTEGER  :: i,k,it
-
-
-  DO it = 1,nbtr
-     d_tr(:,:,it) = 0.
-     IF ( radio(it) ) THEN
-        IF (tautr(it) .GT. 0.) THEN
-           DO k = 1,klev
-              DO i = 1,klon
-                 d_tr(i,k,it) = - tr(i,k,it) * dtime / tautr(it)
-              END DO
-           END DO
-        END IF
-     END IF
-  END DO
-
-!-------------------------------------------------------
-! Cas particulier radon (id_rn) => plomb (id_pb)
-!-------------------------------------------------------
-  IF ( rnpb ) THEN
-     DO k = 1,klev
-        DO i = 1,klon
-           d_tr(i,k,id_pb) = d_tr(i,k,id_pb) - d_tr(i,k,id_rn)
-        ENDDO
-     ENDDO
-  ENDIF
-
-END SUBROUTINE radio_decay
Index: /LMDZ6/trunk/libf/phylmd/radio_decay.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/radio_decay.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/radio_decay.f90	(revision 5268)
@@ -0,0 +1,59 @@
+!
+! $Id $
+!
+SUBROUTINE radio_decay(radio,rnpb,dtime,tautr,tr,d_tr) 
+!
+! Caluclate radioactive decay for all tracers with radio(it)=true
+!
+  USE dimphy
+  USE infotrac_phy, ONLY : nbtr
+  USE traclmdz_mod, ONLY : id_rn, id_pb
+  IMPLICIT NONE
+!-----------------------------------------------------------------------
+! Auteur(s): AA + CG (LGGE/CNRS) Date 24-06-94
+! Objet: Calcul de la tendance radioactive des traceurs type radioelements
+!        Cas particulier pour le couple radon-plomb : Le radon decroit en plomb
+!-----------------------------------------------------------------------
+!
+! Entrees
+!
+  LOGICAL,DIMENSION(nbtr),INTENT(IN)        :: radio ! .true. = traceur radioactif  
+  LOGICAL,INTENT(IN)                        :: rnpb  ! .true. = decroissance RN = source PB
+  REAL,INTENT(IN)                           :: dtime ! Pas de temps physique (secondes)
+  REAL,DIMENSION(nbtr),INTENT(IN)           :: tautr ! Constante de decroissance radioactive
+  REAL,DIMENSION(klon,klev,nbtr),INTENT(IN) :: tr    ! Concentrations traceurs U/kgA
+!
+! Sortie
+!
+  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT) :: d_tr  ! Tendance de decroissance radioactive
+!
+! Locales
+!
+  INTEGER  :: i,k,it
+
+
+  DO it = 1,nbtr
+     d_tr(:,:,it) = 0.
+     IF ( radio(it) ) THEN
+        IF (tautr(it) .GT. 0.) THEN
+           DO k = 1,klev
+              DO i = 1,klon
+                 d_tr(i,k,it) = - tr(i,k,it) * dtime / tautr(it)
+              END DO
+           END DO
+        END IF
+     END IF
+  END DO
+
+!-------------------------------------------------------
+! Cas particulier radon (id_rn) => plomb (id_pb)
+!-------------------------------------------------------
+  IF ( rnpb ) THEN
+     DO k = 1,klev
+        DO i = 1,klon
+           d_tr(i,k,id_pb) = d_tr(i,k,id_pb) - d_tr(i,k,id_rn)
+        ENDDO
+     ENDDO
+  ENDIF
+
+END SUBROUTINE radio_decay
Index: DZ6/trunk/libf/phylmd/ran0_vec.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/ran0_vec.F90	(revision 5267)
+++ 	(revision )
@@ -1,34 +1,0 @@
-
-! $Header$
-
-SUBROUTINE ran0_vec(npoints, idum, ran0)
-
-  ! $Id$
-  ! Platform independent random number generator from
-  ! Numerical Recipies
-  ! Mark Webb July 1999
-
-  IMPLICIT NONE
-
-  INTEGER j, npoints, idum(npoints), ia, im, iq, ir, k(npoints)
-  REAL ran0(npoints), am
-
-  PARAMETER (ia=16807, im=2147483647, am=1.0/im, iq=127773, ir=2836)
-
-  ! do j=1,npoints
-  ! if (idum(j).eq.0) then
-  ! write(6,*) 'idum=',idum
-  ! write(6,*) 'ZERO seed not allowed'
-  ! stop
-  ! endif
-  ! enddo
-
-  DO j = 1, npoints
-    k(j) = idum(j)/iq
-    idum(j) = ia*(idum(j)-k(j)*iq) - ir*k(j)
-    IF (idum(j)<0) idum(j) = idum(j) + im
-    ran0(j) = am*idum(j)
-  END DO
-
-END SUBROUTINE ran0_vec
-
Index: /LMDZ6/trunk/libf/phylmd/ran0_vec.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/ran0_vec.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/ran0_vec.f90	(revision 5268)
@@ -0,0 +1,34 @@
+
+! $Header$
+
+SUBROUTINE ran0_vec(npoints, idum, ran0)
+
+  ! $Id$
+  ! Platform independent random number generator from
+  ! Numerical Recipies
+  ! Mark Webb July 1999
+
+  IMPLICIT NONE
+
+  INTEGER j, npoints, idum(npoints), ia, im, iq, ir, k(npoints)
+  REAL ran0(npoints), am
+
+  PARAMETER (ia=16807, im=2147483647, am=1.0/im, iq=127773, ir=2836)
+
+  ! do j=1,npoints
+  ! if (idum(j).eq.0) then
+  ! write(6,*) 'idum=',idum
+  ! write(6,*) 'ZERO seed not allowed'
+  ! stop
+  ! endif
+  ! enddo
+
+  DO j = 1, npoints
+    k(j) = idum(j)/iq
+    idum(j) = ia*(idum(j)-k(j)*iq) - ir*k(j)
+    IF (idum(j)<0) idum(j) = idum(j) + im
+    ran0(j) = am*idum(j)
+  END DO
+
+END SUBROUTINE ran0_vec
+
Index: DZ6/trunk/libf/phylmd/read_map2D.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/read_map2D.F90	(revision 5267)
+++ 	(revision )
@@ -1,79 +1,0 @@
-SUBROUTINE read_map2D(filename, varname, timestep, inverse, varout)
-! Open file and read one variable for one timestep.
-! Return variable for the given timestep. 
-  USE dimphy
-  USE netcdf
-  USE mod_grid_phy_lmdz
-  USE mod_phys_lmdz_para
-  USE print_control_mod, ONLY: lunout
-
-  IMPLICIT NONE
-
-! Input arguments
-  CHARACTER(len=*), INTENT(IN)  :: filename     ! name of file to read
-  CHARACTER(len=*), INTENT(IN)  :: varname      ! name of variable in file
-  INTEGER, INTENT(IN)           :: timestep     ! actual timestep
-  LOGICAL, INTENT(IN)           :: inverse      ! TRUE if latitude needs to be inversed
-! Output argument
-  REAL, DIMENSION(klon), INTENT(OUT) :: varout  ! The variable read from file for the given timestep
-
-! Local variables
-  INTEGER :: j
-  INTEGER :: nid, nvarid, ierr
-  INTEGER, DIMENSION(3) :: start, count
-  CHARACTER(len=20)     :: modname='read_map2D'
-
-  REAL, DIMENSION(nbp_lon,nbp_lat) :: var_glo2D     ! 2D global 
-  REAL, DIMENSION(nbp_lon,nbp_lat) :: var_glo2D_tmp ! 2D global
-  REAL, DIMENSION(klon_glo)        :: var_glo1D     ! 1D global
-
-! Read variable from file. Done by master process MPI and master thread OpenMP
-  IF (is_mpi_root .AND. is_omp_root) THEN
-     ierr = NF90_OPEN(trim(filename), NF90_NOWRITE, nid)
-     IF (ierr /= NF90_NOERR) CALL write_err_mess('Problem in opening file')
-
-     ierr = NF90_INQ_VARID(nid, trim(varname), nvarid)
-     IF (ierr /= NF90_NOERR) CALL write_err_mess('The variable is absent in file')
-     
-     start=(/1,1,timestep/)
-     count=(/nbp_lon,nbp_lat,1/)
-     ierr = NF90_GET_VAR(nid, nvarid, var_glo2D,start,count)
-     IF (ierr /= NF90_NOERR) CALL write_err_mess('Problem in reading varaiable')
-
-     ierr = NF90_CLOSE(nid)
-     IF (ierr /= NF90_NOERR) CALL write_err_mess('Problem in closing file')
-
-     ! Inverse latitude order
-     IF (inverse) THEN
-        var_glo2D_tmp(:,:) = var_glo2D(:,:)
-        DO j=1, nbp_lat
-           var_glo2D(:,j) = var_glo2D_tmp(:,nbp_lat-j+1)
-        END DO
-     END IF
-
-     ! Transform the global field from 2D to 1D
-     CALL grid2Dto1D_glo(var_glo2D,var_glo1D)
-
-     WRITE(lunout,*) 'in read_map2D, filename = ', trim(filename)
-     WRITE(lunout,*) 'in read_map2D, varname  = ', trim(varname)
-     WRITE(lunout,*) 'in read_map2D, timestep = ', timestep
-  ENDIF
-
-! Scatter gloabl 1D variable to all processes
-  CALL scatter(var_glo1D, varout)
-
-  CONTAINS
-    SUBROUTINE write_err_mess(err_mess)
-      USE print_control_mod, ONLY: lunout
-      IMPLICIT NONE
-      CHARACTER(len=*), INTENT(IN) :: err_mess
-      
-      WRITE(lunout,*) 'Error in read_map2D, filename = ', trim(filename)
-      WRITE(lunout,*) 'Error in read_map2D, varname  = ', trim(varname)
-      WRITE(lunout,*) 'Error in read_map2D, timestep = ', timestep
-
-      CALL abort_physic(modname, err_mess, 1)
-
-    END SUBROUTINE write_err_mess
-
-END SUBROUTINE read_map2D
Index: /LMDZ6/trunk/libf/phylmd/read_map2D.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/read_map2D.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/read_map2D.f90	(revision 5268)
@@ -0,0 +1,79 @@
+SUBROUTINE read_map2D(filename, varname, timestep, inverse, varout)
+! Open file and read one variable for one timestep.
+! Return variable for the given timestep. 
+  USE dimphy
+  USE netcdf
+  USE mod_grid_phy_lmdz
+  USE mod_phys_lmdz_para
+  USE print_control_mod, ONLY: lunout
+
+  IMPLICIT NONE
+
+! Input arguments
+  CHARACTER(len=*), INTENT(IN)  :: filename     ! name of file to read
+  CHARACTER(len=*), INTENT(IN)  :: varname      ! name of variable in file
+  INTEGER, INTENT(IN)           :: timestep     ! actual timestep
+  LOGICAL, INTENT(IN)           :: inverse      ! TRUE if latitude needs to be inversed
+! Output argument
+  REAL, DIMENSION(klon), INTENT(OUT) :: varout  ! The variable read from file for the given timestep
+
+! Local variables
+  INTEGER :: j
+  INTEGER :: nid, nvarid, ierr
+  INTEGER, DIMENSION(3) :: start, count
+  CHARACTER(len=20)     :: modname='read_map2D'
+
+  REAL, DIMENSION(nbp_lon,nbp_lat) :: var_glo2D     ! 2D global 
+  REAL, DIMENSION(nbp_lon,nbp_lat) :: var_glo2D_tmp ! 2D global
+  REAL, DIMENSION(klon_glo)        :: var_glo1D     ! 1D global
+
+! Read variable from file. Done by master process MPI and master thread OpenMP
+  IF (is_mpi_root .AND. is_omp_root) THEN
+     ierr = NF90_OPEN(trim(filename), NF90_NOWRITE, nid)
+     IF (ierr /= NF90_NOERR) CALL write_err_mess('Problem in opening file')
+
+     ierr = NF90_INQ_VARID(nid, trim(varname), nvarid)
+     IF (ierr /= NF90_NOERR) CALL write_err_mess('The variable is absent in file')
+     
+     start=(/1,1,timestep/)
+     count=(/nbp_lon,nbp_lat,1/)
+     ierr = NF90_GET_VAR(nid, nvarid, var_glo2D,start,count)
+     IF (ierr /= NF90_NOERR) CALL write_err_mess('Problem in reading varaiable')
+
+     ierr = NF90_CLOSE(nid)
+     IF (ierr /= NF90_NOERR) CALL write_err_mess('Problem in closing file')
+
+     ! Inverse latitude order
+     IF (inverse) THEN
+        var_glo2D_tmp(:,:) = var_glo2D(:,:)
+        DO j=1, nbp_lat
+           var_glo2D(:,j) = var_glo2D_tmp(:,nbp_lat-j+1)
+        END DO
+     END IF
+
+     ! Transform the global field from 2D to 1D
+     CALL grid2Dto1D_glo(var_glo2D,var_glo1D)
+
+     WRITE(lunout,*) 'in read_map2D, filename = ', trim(filename)
+     WRITE(lunout,*) 'in read_map2D, varname  = ', trim(varname)
+     WRITE(lunout,*) 'in read_map2D, timestep = ', timestep
+  ENDIF
+
+! Scatter gloabl 1D variable to all processes
+  CALL scatter(var_glo1D, varout)
+
+  CONTAINS
+    SUBROUTINE write_err_mess(err_mess)
+      USE print_control_mod, ONLY: lunout
+      IMPLICIT NONE
+      CHARACTER(len=*), INTENT(IN) :: err_mess
+      
+      WRITE(lunout,*) 'Error in read_map2D, filename = ', trim(filename)
+      WRITE(lunout,*) 'Error in read_map2D, varname  = ', trim(varname)
+      WRITE(lunout,*) 'Error in read_map2D, timestep = ', timestep
+
+      CALL abort_physic(modname, err_mess, 1)
+
+    END SUBROUTINE write_err_mess
+
+END SUBROUTINE read_map2D
Index: DZ6/trunk/libf/phylmd/read_pstoke.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/read_pstoke.F90	(revision 5267)
+++ 	(revision )
@@ -1,418 +1,0 @@
-
-! $Id$
-
-
-
-SUBROUTINE read_pstoke(irec, zrec, zklono, zklevo, airefi, phisfi, t, mfu, &
-    mfd, en_u, de_u, en_d, de_d, coefh, fm_therm, en_therm, frac_impa, &
-    frac_nucl, pyu1, pyv1, ftsol, psrf)
-
-  ! ******************************************************************************
-  ! Frederic HOURDIN, Abderrahmane IDELKADI
-  ! Lecture des parametres physique stockes online necessaires pour
-  ! recalculer offline le transport de traceurs sur une grille 2x plus fine
-  ! que
-  ! celle online
-  ! A FAIRE : une seule routine au lieu de 2 (lectflux, redecoupe)!
-  ! ******************************************************************************
-
-  USE netcdf
-  USE dimphy
-  USE indice_sol_mod
-  USE mod_grid_phy_lmdz, ONLY: nbp_lon, nbp_lat, nbp_lev
-
-  IMPLICIT NONE
-
-  include "netcdf.inc"
-
-  INTEGER klono, klevo, imo, jmo
-!  PARAMETER (imo=iim/2, jmo=(jjm+1)/2)
-!  PARAMETER (klono=(jmo-1)*imo+2, klevo=llm)
-  REAL :: phisfi(((nbp_lat/2)-1)*(nbp_lon/2)+2) !phisfi(klono)
-  REAL,ALLOCATABLE :: phisfi2(:,:) !phisfi2(imo,jmo+1)
-  REAL,ALLOCATABLE :: airefi2(:,:) !airefi2(imo, jmo+1)
-
-  REAL :: mfu(((nbp_lat/2)-1)*(nbp_lon/2)+2,nbp_lev) ! mfu(klono, klevo)
-  REAL :: mfd(((nbp_lat/2)-1)*(nbp_lon/2)+2,nbp_lev) ! mfd(klono, klevo)
-  REAL :: en_u(((nbp_lat/2)-1)*(nbp_lon/2)+2,nbp_lev) !en_u(klono, klevo)
-  REAL :: de_u(((nbp_lat/2)-1)*(nbp_lon/2)+2,nbp_lev) !de_u(klono, klevo)
-  REAL :: en_d(((nbp_lat/2)-1)*(nbp_lon/2)+2,nbp_lev) !en_d(klono, klevo)
-  REAL :: de_d(((nbp_lat/2)-1)*(nbp_lon/2)+2,nbp_lev) !de_d(klono, klevo)
-  REAL :: coefh(((nbp_lat/2)-1)*(nbp_lon/2)+2,nbp_lev) !coefh(klono, klevo)
-  REAL :: fm_therm(((nbp_lat/2)-1)*(nbp_lon/2)+2,nbp_lev) !fm_therm(klono, klevo)
-  REAL :: en_therm(((nbp_lat/2)-1)*(nbp_lon/2)+2,nbp_lev) !en_therm(klono, klevo)
-
-  REAL,ALLOCATABLE :: mfu2(:,:,:) !mfu2(imo, jmo+1, klevo)
-  REAL,ALLOCATABLE :: mfd2(:,:,:) !mfd2(imo, jmo+1, klevo)
-  REAL,ALLOCATABLE :: en_u2(:,:,:) !en_u2(imo, jmo+1, klevo)
-  REAL,ALLOCATABLE :: de_u2(:,:,:) !de_u2(imo, jmo+1, klevo)
-  REAL,ALLOCATABLE :: en_d2(:,:,:) !en_d2(imo, jmo+1, klevo)
-  REAL,ALLOCATABLE :: de_d2(:,:,:) !de_d2(imo, jmo+1, klevo)
-  REAL,ALLOCATABLE :: coefh2(:,:,:) !coefh2(imo, jmo+1, klevo)
-  REAL,ALLOCATABLE :: fm_therm2(:,:,:) !fm_therm2(imo, jmo+1, klevo)
-  REAL,ALLOCATABLE :: en_therm2(:,:,:) !en_therm2(imo, jmo+1, klevo)
-
-  REAL,ALLOCATABLE :: pl(:) !pl(klevo)
-  INTEGER irec
-  INTEGER xid, yid, zid, tid
-  REAL zrec, zklono, zklevo, zim, zjm
-  INTEGER ncrec, ncklono, ncklevo, ncim, ncjm
-
-  REAL :: airefi(((nbp_lat/2)-1)*(nbp_lon/2)+2) !airefi(klono)
-  CHARACTER *20 namedim
-
-  ! !! attention !!
-  ! attention il y a aussi le pb de def klono
-  ! dim de phis??
-
-
-  REAL :: frac_impa(((nbp_lat/2)-1)*(nbp_lon/2)+2,nbp_lev) !frac_impa(klono, klevo)
-  REAL :: frac_nucl(((nbp_lat/2)-1)*(nbp_lon/2)+2,nbp_lev) !frac_nucl(klono, klevo)
-  REAL,ALLOCATABLE :: frac_impa2(:,:,:) !frac_impa2(imo, jmo+1, klevo)
-  REAL,ALLOCATABLE :: frac_nucl2(:,:,:) !frac_nucl2(imo, jmo+1, klevo)
-  REAL :: pyu1(((nbp_lat/2)-1)*(nbp_lon/2)+2) !pyu1(klono)
-  REAL :: pyv1(((nbp_lat/2)-1)*(nbp_lon/2)+2) !pyv1(klono)
-  REAL,ALLOCATABLE :: pyu12(:,:), pyv12(:,:) !pyu12(imo, jmo+1), pyv12(imo, jmo+1)
-  REAL :: ftsol(((nbp_lat/2)-1)*(nbp_lon/2)+2,nbp_lev) !ftsol(klono, nbsrf)
-  REAL :: psrf(((nbp_lat/2)-1)*(nbp_lon/2)+2,nbp_lev) !psrf(klono, nbsrf)
-  REAL,ALLOCATABLE :: ftsol1(:),ftsol2(:) !ftsol1(klono), ftsol2(klono)
-  REAL,ALLOCATABLE :: ftsol3(:),ftsol4(:) !ftsol3(klono), ftsol4(klono)
-  REAL,ALLOCATABLE :: psrf1(:), psrf2(:) !psrf1(klono), psrf2(klono)
-  REAL,ALLOCATABLE :: psrf3(:), psrf4(:) !psrf3(klono), psrf4(klono)
-  REAL,ALLOCATABLE :: ftsol12(:,:) !ftsol12(imo, jmo+1)
-  REAL,ALLOCATABLE :: ftsol22(:,:) !ftsol22(imo, jmo+1)
-  REAL,ALLOCATABLE :: ftsol32(:,:) !ftsol32(imo, jmo+1)
-  REAL,ALLOCATABLE :: ftsol42(:,:) !ftsol42(imo, jmo+1)
-  REAL,ALLOCATABLE :: psrf12(:,:) !psrf12(imo, jmo+1)
-  REAL,ALLOCATABLE :: psrf22(:,:) !psrf22(imo, jmo+1)
-  REAL,ALLOCATABLE :: psrf32(:,:) !psrf32(imo, jmo+1)
-  REAL,ALLOCATABLE :: psrf42(:,:) !psrf42(imo, jmo+1)
-  REAL :: t(((nbp_lon/2)-1)*(nbp_lat/2)+2,nbp_lev) !t(klono, klevo)
-  REAL,ALLOCATABLE :: t2(:,:,:) !t2(imo, jmo+1, klevo)
-  INTEGER,SAVE :: ncidp
-  INTEGER,SAVE :: varidt
-  INTEGER,SAVE :: varidmfu, varidmfd, varidps, varidenu, variddeu
-  INTEGER,SAVE :: varidend, varidded, varidch, varidfi, varidfn
-  INTEGER,SAVE :: varidfmth, varidenth
-  INTEGER,SAVE :: varidyu1, varidyv1, varidpl, varidai, varididvt
-  INTEGER,SAVE :: varidfts1, varidfts2, varidfts3, varidfts4
-  INTEGER,SAVE :: varidpsr1, varidpsr2, varidpsr3, varidpsr4
-
-  INTEGER l, i
-  INTEGER start(4), count(4), status
-  REAL rcode
-  LOGICAL,SAVE :: first=.TRUE.
-
-  ! Allocate arrays
-  imo=nbp_lon/2
-  jmo=nbp_lat/2
-  klono=(jmo-1)*imo+2
-  klevo=nbp_lev
-  
-  ALLOCATE(phisfi2(imo,jmo+1))
-  ALLOCATE(airefi2(imo, jmo+1))
-  ALLOCATE(mfu2(imo, jmo+1, klevo))
-  ALLOCATE(mfd2(imo, jmo+1, klevo))
-  ALLOCATE(en_u2(imo, jmo+1, klevo))
-  ALLOCATE(de_u2(imo, jmo+1, klevo))
-  ALLOCATE(en_d2(imo, jmo+1, klevo))
-  ALLOCATE(de_d2(imo, jmo+1, klevo))
-  ALLOCATE(coefh2(imo, jmo+1, klevo))
-  ALLOCATE(fm_therm2(imo, jmo+1, klevo))
-  ALLOCATE(en_therm2(imo, jmo+1, klevo))
-  ALLOCATE(pl(klevo))
-  ALLOCATE(frac_impa2(imo, jmo+1, klevo))
-  ALLOCATE(frac_nucl2(imo, jmo+1, klevo))
-  ALLOCATE(pyu12(imo, jmo+1), pyv12(imo, jmo+1))
-  ALLOCATE(ftsol1(klono), ftsol2(klono))
-  ALLOCATE(ftsol3(klono), ftsol4(klono))
-  ALLOCATE(psrf1(klono), psrf2(klono))
-  ALLOCATE(psrf3(klono), psrf4(klono))
-  ALLOCATE(ftsol12(imo, jmo+1))
-  ALLOCATE(ftsol22(imo, jmo+1))
-  ALLOCATE(ftsol32(imo, jmo+1))
-  ALLOCATE(ftsol42(imo, jmo+1))
-  ALLOCATE(psrf12(imo, jmo+1))
-  ALLOCATE(psrf22(imo, jmo+1))
-  ALLOCATE(psrf32(imo, jmo+1))
-  ALLOCATE(psrf42(imo, jmo+1))
-  ALLOCATE(t2(imo, jmo+1, klevo))
-
-  ! ---------------------------------------------
-  ! Initialisation de la lecture des fichiers
-  ! ---------------------------------------------
-
-  IF (irec==0) THEN
-
-    rcode = nf90_open('phystoke.nc', nf90_nowrite, ncidp)
-
-    rcode = nf90_inq_varid(ncidp, 'phis', varidps)
-    PRINT *, 'ncidp,varidps', ncidp, varidps
-
-    rcode = nf90_inq_varid(ncidp, 'sig_s', varidpl)
-    PRINT *, 'ncidp,varidpl', ncidp, varidpl
-
-    rcode = nf90_inq_varid(ncidp, 'aire', varidai)
-    PRINT *, 'ncidp,varidai', ncidp, varidai
-
-    ! A FAIRE: Es-il necessaire de stocke t?
-    rcode = nf90_inq_varid(ncidp, 't', varidt)
-    PRINT *, 'ncidp,varidt', ncidp, varidt
-
-    rcode = nf90_inq_varid(ncidp, 'mfu', varidmfu)
-    PRINT *, 'ncidp,varidmfu', ncidp, varidmfu
-
-    rcode = nf90_inq_varid(ncidp, 'mfd', varidmfd)
-    PRINT *, 'ncidp,varidmfd', ncidp, varidmfd
-
-    rcode = nf90_inq_varid(ncidp, 'en_u', varidenu)
-    PRINT *, 'ncidp,varidenu', ncidp, varidenu
-
-    rcode = nf90_inq_varid(ncidp, 'de_u', variddeu)
-    PRINT *, 'ncidp,variddeu', ncidp, variddeu
-
-    rcode = nf90_inq_varid(ncidp, 'en_d', varidend)
-    PRINT *, 'ncidp,varidend', ncidp, varidend
-
-    rcode = nf90_inq_varid(ncidp, 'de_d', varidded)
-    PRINT *, 'ncidp,varidded', ncidp, varidded
-
-    rcode = nf90_inq_varid(ncidp, 'coefh', varidch)
-    PRINT *, 'ncidp,varidch', ncidp, varidch
-
-    ! abder (pour thermiques)
-    rcode = nf90_inq_varid(ncidp, 'fm_th', varidfmth)
-    PRINT *, 'ncidp,varidfmth', ncidp, varidfmth
-
-    rcode = nf90_inq_varid(ncidp, 'en_th', varidenth)
-    PRINT *, 'ncidp,varidenth', ncidp, varidenth
-
-    rcode = nf90_inq_varid(ncidp, 'frac_impa', varidfi)
-    PRINT *, 'ncidp,varidfi', ncidp, varidfi
-
-    rcode = nf90_inq_varid(ncidp, 'frac_nucl', varidfn)
-    PRINT *, 'ncidp,varidfn', ncidp, varidfn
-
-    rcode = nf90_inq_varid(ncidp, 'pyu1', varidyu1)
-    PRINT *, 'ncidp,varidyu1', ncidp, varidyu1
-
-    rcode = nf90_inq_varid(ncidp, 'pyv1', varidyv1)
-    PRINT *, 'ncidp,varidyv1', ncidp, varidyv1
-
-    rcode = nf90_inq_varid(ncidp, 'ftsol1', varidfts1)
-    PRINT *, 'ncidp,varidfts1', ncidp, varidfts1
-
-    rcode = nf90_inq_varid(ncidp, 'ftsol2', varidfts2)
-    PRINT *, 'ncidp,varidfts2', ncidp, varidfts2
-
-    rcode = nf90_inq_varid(ncidp, 'ftsol3', varidfts3)
-    PRINT *, 'ncidp,varidfts3', ncidp, varidfts3
-
-    rcode = nf90_inq_varid(ncidp, 'ftsol4', varidfts4)
-    PRINT *, 'ncidp,varidfts4', ncidp, varidfts4
-
-    rcode = nf90_inq_varid(ncidp, 'psrf1', varidpsr1)
-    PRINT *, 'ncidp,varidpsr1', ncidp, varidpsr1
-
-    rcode = nf90_inq_varid(ncidp, 'psrf2', varidpsr2)
-    PRINT *, 'ncidp,varidpsr2', ncidp, varidpsr2
-
-    rcode = nf90_inq_varid(ncidp, 'psrf3', varidpsr3)
-    PRINT *, 'ncidp,varidpsr3', ncidp, varidpsr3
-
-    rcode = nf90_inq_varid(ncidp, 'psrf4', varidpsr4)
-    PRINT *, 'ncidp,varidpsr4', ncidp, varidpsr4
-
-    ! ID pour les dimensions
-
-    status = nf_inq_dimid(ncidp, 'y', yid)
-    status = nf_inq_dimid(ncidp, 'x', xid)
-    status = nf_inq_dimid(ncidp, 'sig_s', zid)
-    status = nf_inq_dimid(ncidp, 'time_counter', tid)
-
-    ! lecture des dimensions
-
-    status = nf_inq_dim(ncidp, yid, namedim, ncjm)
-    status = nf_inq_dim(ncidp, xid, namedim, ncim)
-    status = nf_inq_dim(ncidp, zid, namedim, ncklevo)
-    status = nf_inq_dim(ncidp, tid, namedim, ncrec)
-
-    zrec = ncrec
-    zklevo = ncklevo
-    zim = ncim
-    zjm = ncjm
-
-    zklono = zim*(zjm-2) + 2
-
-    WRITE (*, *) 'read_pstoke : zrec = ', zrec
-    WRITE (*, *) 'read_pstoke : zklevo = ', zklevo
-    WRITE (*, *) 'read_pstoke : zim = ', zim
-    WRITE (*, *) 'read_pstoke : zjm = ', zjm
-    WRITE (*, *) 'read_pstoke : zklono = ', zklono
-
-    ! niveaux de pression
-    status = nf90_get_var(ncidp, varidpl, pl, [1], [ncklevo])
-
-    ! lecture de aire et phis
-
-    start(1) = 1
-    start(2) = 1
-    start(3) = 1
-    start(4) = 0
-
-    count(1) = zim
-    count(2) = zjm
-    count(3) = 1
-    count(4) = 0
-
-    ! phis
-    status = nf90_get_var(ncidp, varidps, phisfi2, start, count)
-    CALL gr_ecrit_fi(1, klono, imo, jmo+1, phisfi2, phisfi)
-
-    ! aire
-    status = nf90_get_var(ncidp, varidai, airefi2, start, count)
-    CALL gr_ecrit_fi(1, klono, imo, jmo+1, airefi2, airefi)
-  ELSE
-
-    PRINT *, 'ok1'
-
-    ! ---------------------
-    ! lecture des champs
-    ! ---------------------
-
-    PRINT *, 'WARNING!!! Il n y a pas de test de coherence'
-    PRINT *, 'sur le nombre de niveaux verticaux dans le fichier nc'
-
-    start(1) = 1
-    start(2) = 1
-    start(3) = 1
-    start(4) = irec
-
-    count(1) = zim
-    count(2) = zjm
-    count(3) = zklevo
-    count(4) = 1
-
-
-    ! *** Lessivage******************************************************
-    ! frac_impa
-    status = nf90_get_var(ncidp, varidfi, frac_impa2, start, count)
-    CALL gr_ecrit_fi(klevo, klono, imo, jmo+1, frac_impa2, frac_impa)
-
-    ! frac_nucl
-    status = nf90_get_var(ncidp, varidfn, frac_nucl2, start, count)
-    CALL gr_ecrit_fi(klevo, klono, imo, jmo+1, frac_nucl2, frac_nucl)
-
-    ! *** Temperature ******************************************************
-    ! abder t
-    status = nf90_get_var(ncidp, varidt, t2, start, count)
-    CALL gr_ecrit_fi(klevo, klono, imo, jmo+1, t2, t)
-
-    ! *** Flux pour le calcul de la convection TIEDTK ***********************
-    ! mfu
-    status = nf90_get_var(ncidp, varidmfu, mfu2, start, count)
-    CALL gr_ecrit_fi(klevo, klono, imo, jmo+1, mfu2, mfu)
-
-    ! mfd
-    status = nf90_get_var(ncidp, varidmfd, mfd2, start, count)
-    CALL gr_ecrit_fi(klevo, klono, imo, jmo+1, mfd2, mfd)
-
-    ! en_u
-    status = nf90_get_var(ncidp, varidenu, en_u2, start, count)
-    CALL gr_ecrit_fi(klevo, klono, imo, jmo+1, en_u2, en_u)
-
-    ! de_u
-    status = nf90_get_var(ncidp, variddeu, de_u2, start, count)
-    CALL gr_ecrit_fi(klevo, klono, imo, jmo+1, de_u2, de_u)
-
-    ! en_d
-    status = nf90_get_var(ncidp, varidend, en_d2, start, count)
-    CALL gr_ecrit_fi(klevo, klono, imo, jmo+1, en_d2, en_d)
-
-    ! de_d
-    status = nf90_get_var(ncidp, varidded, de_d2, start, count)
-    CALL gr_ecrit_fi(klevo, klono, imo, jmo+1, de_d2, de_d)
-
-    ! **** Coeffecient du mellange
-    ! turbulent**********************************
-    ! coefh
-    status = nf90_get_var(ncidp, varidch, coefh2, start, count)
-    CALL gr_ecrit_fi(klevo, klono, imo, jmo+1, coefh2, coefh)
-
-    ! *** Flux ascendant et entrant pour les
-    ! Thermiques************************
-    ! abder thermiques
-    status = nf90_get_var(ncidp, varidfmth, fm_therm2, start, count)
-    CALL gr_ecrit_fi(klevo, klono, imo, jmo+1, fm_therm2, fm_therm)
-
-    status = nf90_get_var(ncidp, varidenth, en_therm2, start, count)
-    CALL gr_ecrit_fi(klevo, klono, imo, jmo+1, en_therm2, en_therm)
-
-    ! *** Vitesses aux sol
-    ! ******************************************************
-    start(3) = irec
-    start(4) = 0
-    count(3) = 1
-    count(4) = 0
-    ! pyu1
-    status = nf90_get_var(ncidp, varidyu1, pyu12, start, count)
-    CALL gr_ecrit_fi(1, klono, imo, jmo+1, pyu12, pyu1)
-
-    ! pyv1
-    status = nf90_get_var(ncidp, varidyv1, pyv12, start, count)
-    CALL gr_ecrit_fi(1, klono, imo, jmo+1, pyv12, pyv1)
-
-    ! *** Temperature au sol ********************************************
-    ! ftsol1
-    status = nf90_get_var(ncidp, varidfts1, ftsol12, start, count)
-    CALL gr_ecrit_fi(1, klono, imo, jmo+1, ftsol12, ftsol1)
-
-    ! ftsol2
-    status = nf90_get_var(ncidp, varidfts2, ftsol22, start, count)
-    CALL gr_ecrit_fi(1, klono, imo, jmo+1, ftsol22, ftsol2)
-
-    ! ftsol3
-    status = nf90_get_var(ncidp, varidfts3, ftsol32, start, count)
-    CALL gr_ecrit_fi(1, klono, imo, jmo+1, ftsol32, ftsol3)
-
-    ! ftsol4
-    status = nf90_get_var(ncidp, varidfts4, ftsol42, start, count)
-    CALL gr_ecrit_fi(1, klono, imo, jmo+1, ftsol42, ftsol4)
-
-    ! *** Nature du sol **************************************************
-    ! psrf1
-    status = nf90_get_var(ncidp, varidpsr1, psrf12, start, count)
-    CALL gr_ecrit_fi(1, klono, imo, jmo+1, psrf12, psrf1)
-
-    ! psrf2
-    status = nf90_get_var(ncidp, varidpsr2, psrf22, start, count)
-    CALL gr_ecrit_fi(1, klono, imo, jmo+1, psrf22, psrf2)
-
-    ! psrf3
-    status = nf90_get_var(ncidp, varidpsr3, psrf32, start, count)
-    CALL gr_ecrit_fi(1, klono, imo, jmo+1, psrf32, psrf3)
-
-    ! psrf4
-    status = nf90_get_var(ncidp, varidpsr4, psrf42, start, count)
-    CALL gr_ecrit_fi(1, klono, imo, jmo+1, psrf42, psrf4)
-
-    DO i = 1, klono
-
-      psrf(i, 1) = psrf1(i)
-      psrf(i, 2) = psrf2(i)
-      psrf(i, 3) = psrf3(i)
-      psrf(i, 4) = psrf4(i)
-
-      ftsol(i, 1) = ftsol1(i)
-      ftsol(i, 2) = ftsol2(i)
-      ftsol(i, 3) = ftsol3(i)
-      ftsol(i, 4) = ftsol4(i)
-
-    END DO
-
-  END IF
-
-  RETURN
-
-END SUBROUTINE read_pstoke
-
Index: /LMDZ6/trunk/libf/phylmd/read_pstoke.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/read_pstoke.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/read_pstoke.f90	(revision 5268)
@@ -0,0 +1,418 @@
+
+! $Id$
+
+
+
+SUBROUTINE read_pstoke(irec, zrec, zklono, zklevo, airefi, phisfi, t, mfu, &
+    mfd, en_u, de_u, en_d, de_d, coefh, fm_therm, en_therm, frac_impa, &
+    frac_nucl, pyu1, pyv1, ftsol, psrf)
+
+  ! ******************************************************************************
+  ! Frederic HOURDIN, Abderrahmane IDELKADI
+  ! Lecture des parametres physique stockes online necessaires pour
+  ! recalculer offline le transport de traceurs sur une grille 2x plus fine
+  ! que
+  ! celle online
+  ! A FAIRE : une seule routine au lieu de 2 (lectflux, redecoupe)!
+  ! ******************************************************************************
+
+  USE netcdf
+  USE dimphy
+  USE indice_sol_mod
+  USE mod_grid_phy_lmdz, ONLY: nbp_lon, nbp_lat, nbp_lev
+
+  IMPLICIT NONE
+
+  include "netcdf.inc"
+
+  INTEGER klono, klevo, imo, jmo
+!  PARAMETER (imo=iim/2, jmo=(jjm+1)/2)
+!  PARAMETER (klono=(jmo-1)*imo+2, klevo=llm)
+  REAL :: phisfi(((nbp_lat/2)-1)*(nbp_lon/2)+2) !phisfi(klono)
+  REAL,ALLOCATABLE :: phisfi2(:,:) !phisfi2(imo,jmo+1)
+  REAL,ALLOCATABLE :: airefi2(:,:) !airefi2(imo, jmo+1)
+
+  REAL :: mfu(((nbp_lat/2)-1)*(nbp_lon/2)+2,nbp_lev) ! mfu(klono, klevo)
+  REAL :: mfd(((nbp_lat/2)-1)*(nbp_lon/2)+2,nbp_lev) ! mfd(klono, klevo)
+  REAL :: en_u(((nbp_lat/2)-1)*(nbp_lon/2)+2,nbp_lev) !en_u(klono, klevo)
+  REAL :: de_u(((nbp_lat/2)-1)*(nbp_lon/2)+2,nbp_lev) !de_u(klono, klevo)
+  REAL :: en_d(((nbp_lat/2)-1)*(nbp_lon/2)+2,nbp_lev) !en_d(klono, klevo)
+  REAL :: de_d(((nbp_lat/2)-1)*(nbp_lon/2)+2,nbp_lev) !de_d(klono, klevo)
+  REAL :: coefh(((nbp_lat/2)-1)*(nbp_lon/2)+2,nbp_lev) !coefh(klono, klevo)
+  REAL :: fm_therm(((nbp_lat/2)-1)*(nbp_lon/2)+2,nbp_lev) !fm_therm(klono, klevo)
+  REAL :: en_therm(((nbp_lat/2)-1)*(nbp_lon/2)+2,nbp_lev) !en_therm(klono, klevo)
+
+  REAL,ALLOCATABLE :: mfu2(:,:,:) !mfu2(imo, jmo+1, klevo)
+  REAL,ALLOCATABLE :: mfd2(:,:,:) !mfd2(imo, jmo+1, klevo)
+  REAL,ALLOCATABLE :: en_u2(:,:,:) !en_u2(imo, jmo+1, klevo)
+  REAL,ALLOCATABLE :: de_u2(:,:,:) !de_u2(imo, jmo+1, klevo)
+  REAL,ALLOCATABLE :: en_d2(:,:,:) !en_d2(imo, jmo+1, klevo)
+  REAL,ALLOCATABLE :: de_d2(:,:,:) !de_d2(imo, jmo+1, klevo)
+  REAL,ALLOCATABLE :: coefh2(:,:,:) !coefh2(imo, jmo+1, klevo)
+  REAL,ALLOCATABLE :: fm_therm2(:,:,:) !fm_therm2(imo, jmo+1, klevo)
+  REAL,ALLOCATABLE :: en_therm2(:,:,:) !en_therm2(imo, jmo+1, klevo)
+
+  REAL,ALLOCATABLE :: pl(:) !pl(klevo)
+  INTEGER irec
+  INTEGER xid, yid, zid, tid
+  REAL zrec, zklono, zklevo, zim, zjm
+  INTEGER ncrec, ncklono, ncklevo, ncim, ncjm
+
+  REAL :: airefi(((nbp_lat/2)-1)*(nbp_lon/2)+2) !airefi(klono)
+  CHARACTER *20 namedim
+
+  ! !! attention !!
+  ! attention il y a aussi le pb de def klono
+  ! dim de phis??
+
+
+  REAL :: frac_impa(((nbp_lat/2)-1)*(nbp_lon/2)+2,nbp_lev) !frac_impa(klono, klevo)
+  REAL :: frac_nucl(((nbp_lat/2)-1)*(nbp_lon/2)+2,nbp_lev) !frac_nucl(klono, klevo)
+  REAL,ALLOCATABLE :: frac_impa2(:,:,:) !frac_impa2(imo, jmo+1, klevo)
+  REAL,ALLOCATABLE :: frac_nucl2(:,:,:) !frac_nucl2(imo, jmo+1, klevo)
+  REAL :: pyu1(((nbp_lat/2)-1)*(nbp_lon/2)+2) !pyu1(klono)
+  REAL :: pyv1(((nbp_lat/2)-1)*(nbp_lon/2)+2) !pyv1(klono)
+  REAL,ALLOCATABLE :: pyu12(:,:), pyv12(:,:) !pyu12(imo, jmo+1), pyv12(imo, jmo+1)
+  REAL :: ftsol(((nbp_lat/2)-1)*(nbp_lon/2)+2,nbp_lev) !ftsol(klono, nbsrf)
+  REAL :: psrf(((nbp_lat/2)-1)*(nbp_lon/2)+2,nbp_lev) !psrf(klono, nbsrf)
+  REAL,ALLOCATABLE :: ftsol1(:),ftsol2(:) !ftsol1(klono), ftsol2(klono)
+  REAL,ALLOCATABLE :: ftsol3(:),ftsol4(:) !ftsol3(klono), ftsol4(klono)
+  REAL,ALLOCATABLE :: psrf1(:), psrf2(:) !psrf1(klono), psrf2(klono)
+  REAL,ALLOCATABLE :: psrf3(:), psrf4(:) !psrf3(klono), psrf4(klono)
+  REAL,ALLOCATABLE :: ftsol12(:,:) !ftsol12(imo, jmo+1)
+  REAL,ALLOCATABLE :: ftsol22(:,:) !ftsol22(imo, jmo+1)
+  REAL,ALLOCATABLE :: ftsol32(:,:) !ftsol32(imo, jmo+1)
+  REAL,ALLOCATABLE :: ftsol42(:,:) !ftsol42(imo, jmo+1)
+  REAL,ALLOCATABLE :: psrf12(:,:) !psrf12(imo, jmo+1)
+  REAL,ALLOCATABLE :: psrf22(:,:) !psrf22(imo, jmo+1)
+  REAL,ALLOCATABLE :: psrf32(:,:) !psrf32(imo, jmo+1)
+  REAL,ALLOCATABLE :: psrf42(:,:) !psrf42(imo, jmo+1)
+  REAL :: t(((nbp_lon/2)-1)*(nbp_lat/2)+2,nbp_lev) !t(klono, klevo)
+  REAL,ALLOCATABLE :: t2(:,:,:) !t2(imo, jmo+1, klevo)
+  INTEGER,SAVE :: ncidp
+  INTEGER,SAVE :: varidt
+  INTEGER,SAVE :: varidmfu, varidmfd, varidps, varidenu, variddeu
+  INTEGER,SAVE :: varidend, varidded, varidch, varidfi, varidfn
+  INTEGER,SAVE :: varidfmth, varidenth
+  INTEGER,SAVE :: varidyu1, varidyv1, varidpl, varidai, varididvt
+  INTEGER,SAVE :: varidfts1, varidfts2, varidfts3, varidfts4
+  INTEGER,SAVE :: varidpsr1, varidpsr2, varidpsr3, varidpsr4
+
+  INTEGER l, i
+  INTEGER start(4), count(4), status
+  REAL rcode
+  LOGICAL,SAVE :: first=.TRUE.
+
+  ! Allocate arrays
+  imo=nbp_lon/2
+  jmo=nbp_lat/2
+  klono=(jmo-1)*imo+2
+  klevo=nbp_lev
+  
+  ALLOCATE(phisfi2(imo,jmo+1))
+  ALLOCATE(airefi2(imo, jmo+1))
+  ALLOCATE(mfu2(imo, jmo+1, klevo))
+  ALLOCATE(mfd2(imo, jmo+1, klevo))
+  ALLOCATE(en_u2(imo, jmo+1, klevo))
+  ALLOCATE(de_u2(imo, jmo+1, klevo))
+  ALLOCATE(en_d2(imo, jmo+1, klevo))
+  ALLOCATE(de_d2(imo, jmo+1, klevo))
+  ALLOCATE(coefh2(imo, jmo+1, klevo))
+  ALLOCATE(fm_therm2(imo, jmo+1, klevo))
+  ALLOCATE(en_therm2(imo, jmo+1, klevo))
+  ALLOCATE(pl(klevo))
+  ALLOCATE(frac_impa2(imo, jmo+1, klevo))
+  ALLOCATE(frac_nucl2(imo, jmo+1, klevo))
+  ALLOCATE(pyu12(imo, jmo+1), pyv12(imo, jmo+1))
+  ALLOCATE(ftsol1(klono), ftsol2(klono))
+  ALLOCATE(ftsol3(klono), ftsol4(klono))
+  ALLOCATE(psrf1(klono), psrf2(klono))
+  ALLOCATE(psrf3(klono), psrf4(klono))
+  ALLOCATE(ftsol12(imo, jmo+1))
+  ALLOCATE(ftsol22(imo, jmo+1))
+  ALLOCATE(ftsol32(imo, jmo+1))
+  ALLOCATE(ftsol42(imo, jmo+1))
+  ALLOCATE(psrf12(imo, jmo+1))
+  ALLOCATE(psrf22(imo, jmo+1))
+  ALLOCATE(psrf32(imo, jmo+1))
+  ALLOCATE(psrf42(imo, jmo+1))
+  ALLOCATE(t2(imo, jmo+1, klevo))
+
+  ! ---------------------------------------------
+  ! Initialisation de la lecture des fichiers
+  ! ---------------------------------------------
+
+  IF (irec==0) THEN
+
+    rcode = nf90_open('phystoke.nc', nf90_nowrite, ncidp)
+
+    rcode = nf90_inq_varid(ncidp, 'phis', varidps)
+    PRINT *, 'ncidp,varidps', ncidp, varidps
+
+    rcode = nf90_inq_varid(ncidp, 'sig_s', varidpl)
+    PRINT *, 'ncidp,varidpl', ncidp, varidpl
+
+    rcode = nf90_inq_varid(ncidp, 'aire', varidai)
+    PRINT *, 'ncidp,varidai', ncidp, varidai
+
+    ! A FAIRE: Es-il necessaire de stocke t?
+    rcode = nf90_inq_varid(ncidp, 't', varidt)
+    PRINT *, 'ncidp,varidt', ncidp, varidt
+
+    rcode = nf90_inq_varid(ncidp, 'mfu', varidmfu)
+    PRINT *, 'ncidp,varidmfu', ncidp, varidmfu
+
+    rcode = nf90_inq_varid(ncidp, 'mfd', varidmfd)
+    PRINT *, 'ncidp,varidmfd', ncidp, varidmfd
+
+    rcode = nf90_inq_varid(ncidp, 'en_u', varidenu)
+    PRINT *, 'ncidp,varidenu', ncidp, varidenu
+
+    rcode = nf90_inq_varid(ncidp, 'de_u', variddeu)
+    PRINT *, 'ncidp,variddeu', ncidp, variddeu
+
+    rcode = nf90_inq_varid(ncidp, 'en_d', varidend)
+    PRINT *, 'ncidp,varidend', ncidp, varidend
+
+    rcode = nf90_inq_varid(ncidp, 'de_d', varidded)
+    PRINT *, 'ncidp,varidded', ncidp, varidded
+
+    rcode = nf90_inq_varid(ncidp, 'coefh', varidch)
+    PRINT *, 'ncidp,varidch', ncidp, varidch
+
+    ! abder (pour thermiques)
+    rcode = nf90_inq_varid(ncidp, 'fm_th', varidfmth)
+    PRINT *, 'ncidp,varidfmth', ncidp, varidfmth
+
+    rcode = nf90_inq_varid(ncidp, 'en_th', varidenth)
+    PRINT *, 'ncidp,varidenth', ncidp, varidenth
+
+    rcode = nf90_inq_varid(ncidp, 'frac_impa', varidfi)
+    PRINT *, 'ncidp,varidfi', ncidp, varidfi
+
+    rcode = nf90_inq_varid(ncidp, 'frac_nucl', varidfn)
+    PRINT *, 'ncidp,varidfn', ncidp, varidfn
+
+    rcode = nf90_inq_varid(ncidp, 'pyu1', varidyu1)
+    PRINT *, 'ncidp,varidyu1', ncidp, varidyu1
+
+    rcode = nf90_inq_varid(ncidp, 'pyv1', varidyv1)
+    PRINT *, 'ncidp,varidyv1', ncidp, varidyv1
+
+    rcode = nf90_inq_varid(ncidp, 'ftsol1', varidfts1)
+    PRINT *, 'ncidp,varidfts1', ncidp, varidfts1
+
+    rcode = nf90_inq_varid(ncidp, 'ftsol2', varidfts2)
+    PRINT *, 'ncidp,varidfts2', ncidp, varidfts2
+
+    rcode = nf90_inq_varid(ncidp, 'ftsol3', varidfts3)
+    PRINT *, 'ncidp,varidfts3', ncidp, varidfts3
+
+    rcode = nf90_inq_varid(ncidp, 'ftsol4', varidfts4)
+    PRINT *, 'ncidp,varidfts4', ncidp, varidfts4
+
+    rcode = nf90_inq_varid(ncidp, 'psrf1', varidpsr1)
+    PRINT *, 'ncidp,varidpsr1', ncidp, varidpsr1
+
+    rcode = nf90_inq_varid(ncidp, 'psrf2', varidpsr2)
+    PRINT *, 'ncidp,varidpsr2', ncidp, varidpsr2
+
+    rcode = nf90_inq_varid(ncidp, 'psrf3', varidpsr3)
+    PRINT *, 'ncidp,varidpsr3', ncidp, varidpsr3
+
+    rcode = nf90_inq_varid(ncidp, 'psrf4', varidpsr4)
+    PRINT *, 'ncidp,varidpsr4', ncidp, varidpsr4
+
+    ! ID pour les dimensions
+
+    status = nf_inq_dimid(ncidp, 'y', yid)
+    status = nf_inq_dimid(ncidp, 'x', xid)
+    status = nf_inq_dimid(ncidp, 'sig_s', zid)
+    status = nf_inq_dimid(ncidp, 'time_counter', tid)
+
+    ! lecture des dimensions
+
+    status = nf_inq_dim(ncidp, yid, namedim, ncjm)
+    status = nf_inq_dim(ncidp, xid, namedim, ncim)
+    status = nf_inq_dim(ncidp, zid, namedim, ncklevo)
+    status = nf_inq_dim(ncidp, tid, namedim, ncrec)
+
+    zrec = ncrec
+    zklevo = ncklevo
+    zim = ncim
+    zjm = ncjm
+
+    zklono = zim*(zjm-2) + 2
+
+    WRITE (*, *) 'read_pstoke : zrec = ', zrec
+    WRITE (*, *) 'read_pstoke : zklevo = ', zklevo
+    WRITE (*, *) 'read_pstoke : zim = ', zim
+    WRITE (*, *) 'read_pstoke : zjm = ', zjm
+    WRITE (*, *) 'read_pstoke : zklono = ', zklono
+
+    ! niveaux de pression
+    status = nf90_get_var(ncidp, varidpl, pl, [1], [ncklevo])
+
+    ! lecture de aire et phis
+
+    start(1) = 1
+    start(2) = 1
+    start(3) = 1
+    start(4) = 0
+
+    count(1) = zim
+    count(2) = zjm
+    count(3) = 1
+    count(4) = 0
+
+    ! phis
+    status = nf90_get_var(ncidp, varidps, phisfi2, start, count)
+    CALL gr_ecrit_fi(1, klono, imo, jmo+1, phisfi2, phisfi)
+
+    ! aire
+    status = nf90_get_var(ncidp, varidai, airefi2, start, count)
+    CALL gr_ecrit_fi(1, klono, imo, jmo+1, airefi2, airefi)
+  ELSE
+
+    PRINT *, 'ok1'
+
+    ! ---------------------
+    ! lecture des champs
+    ! ---------------------
+
+    PRINT *, 'WARNING!!! Il n y a pas de test de coherence'
+    PRINT *, 'sur le nombre de niveaux verticaux dans le fichier nc'
+
+    start(1) = 1
+    start(2) = 1
+    start(3) = 1
+    start(4) = irec
+
+    count(1) = zim
+    count(2) = zjm
+    count(3) = zklevo
+    count(4) = 1
+
+
+    ! *** Lessivage******************************************************
+    ! frac_impa
+    status = nf90_get_var(ncidp, varidfi, frac_impa2, start, count)
+    CALL gr_ecrit_fi(klevo, klono, imo, jmo+1, frac_impa2, frac_impa)
+
+    ! frac_nucl
+    status = nf90_get_var(ncidp, varidfn, frac_nucl2, start, count)
+    CALL gr_ecrit_fi(klevo, klono, imo, jmo+1, frac_nucl2, frac_nucl)
+
+    ! *** Temperature ******************************************************
+    ! abder t
+    status = nf90_get_var(ncidp, varidt, t2, start, count)
+    CALL gr_ecrit_fi(klevo, klono, imo, jmo+1, t2, t)
+
+    ! *** Flux pour le calcul de la convection TIEDTK ***********************
+    ! mfu
+    status = nf90_get_var(ncidp, varidmfu, mfu2, start, count)
+    CALL gr_ecrit_fi(klevo, klono, imo, jmo+1, mfu2, mfu)
+
+    ! mfd
+    status = nf90_get_var(ncidp, varidmfd, mfd2, start, count)
+    CALL gr_ecrit_fi(klevo, klono, imo, jmo+1, mfd2, mfd)
+
+    ! en_u
+    status = nf90_get_var(ncidp, varidenu, en_u2, start, count)
+    CALL gr_ecrit_fi(klevo, klono, imo, jmo+1, en_u2, en_u)
+
+    ! de_u
+    status = nf90_get_var(ncidp, variddeu, de_u2, start, count)
+    CALL gr_ecrit_fi(klevo, klono, imo, jmo+1, de_u2, de_u)
+
+    ! en_d
+    status = nf90_get_var(ncidp, varidend, en_d2, start, count)
+    CALL gr_ecrit_fi(klevo, klono, imo, jmo+1, en_d2, en_d)
+
+    ! de_d
+    status = nf90_get_var(ncidp, varidded, de_d2, start, count)
+    CALL gr_ecrit_fi(klevo, klono, imo, jmo+1, de_d2, de_d)
+
+    ! **** Coeffecient du mellange
+    ! turbulent**********************************
+    ! coefh
+    status = nf90_get_var(ncidp, varidch, coefh2, start, count)
+    CALL gr_ecrit_fi(klevo, klono, imo, jmo+1, coefh2, coefh)
+
+    ! *** Flux ascendant et entrant pour les
+    ! Thermiques************************
+    ! abder thermiques
+    status = nf90_get_var(ncidp, varidfmth, fm_therm2, start, count)
+    CALL gr_ecrit_fi(klevo, klono, imo, jmo+1, fm_therm2, fm_therm)
+
+    status = nf90_get_var(ncidp, varidenth, en_therm2, start, count)
+    CALL gr_ecrit_fi(klevo, klono, imo, jmo+1, en_therm2, en_therm)
+
+    ! *** Vitesses aux sol
+    ! ******************************************************
+    start(3) = irec
+    start(4) = 0
+    count(3) = 1
+    count(4) = 0
+    ! pyu1
+    status = nf90_get_var(ncidp, varidyu1, pyu12, start, count)
+    CALL gr_ecrit_fi(1, klono, imo, jmo+1, pyu12, pyu1)
+
+    ! pyv1
+    status = nf90_get_var(ncidp, varidyv1, pyv12, start, count)
+    CALL gr_ecrit_fi(1, klono, imo, jmo+1, pyv12, pyv1)
+
+    ! *** Temperature au sol ********************************************
+    ! ftsol1
+    status = nf90_get_var(ncidp, varidfts1, ftsol12, start, count)
+    CALL gr_ecrit_fi(1, klono, imo, jmo+1, ftsol12, ftsol1)
+
+    ! ftsol2
+    status = nf90_get_var(ncidp, varidfts2, ftsol22, start, count)
+    CALL gr_ecrit_fi(1, klono, imo, jmo+1, ftsol22, ftsol2)
+
+    ! ftsol3
+    status = nf90_get_var(ncidp, varidfts3, ftsol32, start, count)
+    CALL gr_ecrit_fi(1, klono, imo, jmo+1, ftsol32, ftsol3)
+
+    ! ftsol4
+    status = nf90_get_var(ncidp, varidfts4, ftsol42, start, count)
+    CALL gr_ecrit_fi(1, klono, imo, jmo+1, ftsol42, ftsol4)
+
+    ! *** Nature du sol **************************************************
+    ! psrf1
+    status = nf90_get_var(ncidp, varidpsr1, psrf12, start, count)
+    CALL gr_ecrit_fi(1, klono, imo, jmo+1, psrf12, psrf1)
+
+    ! psrf2
+    status = nf90_get_var(ncidp, varidpsr2, psrf22, start, count)
+    CALL gr_ecrit_fi(1, klono, imo, jmo+1, psrf22, psrf2)
+
+    ! psrf3
+    status = nf90_get_var(ncidp, varidpsr3, psrf32, start, count)
+    CALL gr_ecrit_fi(1, klono, imo, jmo+1, psrf32, psrf3)
+
+    ! psrf4
+    status = nf90_get_var(ncidp, varidpsr4, psrf42, start, count)
+    CALL gr_ecrit_fi(1, klono, imo, jmo+1, psrf42, psrf4)
+
+    DO i = 1, klono
+
+      psrf(i, 1) = psrf1(i)
+      psrf(i, 2) = psrf2(i)
+      psrf(i, 3) = psrf3(i)
+      psrf(i, 4) = psrf4(i)
+
+      ftsol(i, 1) = ftsol1(i)
+      ftsol(i, 2) = ftsol2(i)
+      ftsol(i, 3) = ftsol3(i)
+      ftsol(i, 4) = ftsol4(i)
+
+    END DO
+
+  END IF
+
+  RETURN
+
+END SUBROUTINE read_pstoke
+
Index: DZ6/trunk/libf/phylmd/read_pstoke0.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/read_pstoke0.F90	(revision 5267)
+++ 	(revision )
@@ -1,440 +1,0 @@
-
-! $Id$
-
-
-
-SUBROUTINE read_pstoke0(irec, zrec, zkon, zkev, airefi, phisfi, t, mfu, mfd, &
-    en_u, de_u, en_d, de_d, coefh, fm_therm, en_therm, frac_impa, frac_nucl, &
-    pyu1, pyv1, ftsol, psrf)
-
-  ! ******************************************************************************
-  ! Frederic HOURDIN, Abderrahmane IDELKADI
-  ! Lecture des parametres physique stockes online necessaires pour
-  ! recalculer offline le transport des traceurs sur la meme grille que
-  ! online
-  ! A FAIRE : une seule routine au lieu de 2 (lectflux, redecoupe)!
-  ! ******************************************************************************
-
-  USE netcdf
-  USE dimphy
-  USE indice_sol_mod
-  USE mod_grid_phy_lmdz, ONLY: nbp_lon, nbp_lat, nbp_lev
-
-  IMPLICIT NONE
-
-  include "netcdf.inc"
-
-  INTEGER kon, kev, zkon, zkev
-!  PARAMETER (kon=iim*(jjm-1)+2, kev=llm)
-  REAL :: phisfi(nbp_lon*(nbp_lat-2)+2) !phisfi(kon)
-  REAL,ALLOCATABLE :: phisfi2(:,:) !phisfi2(nbp_lon, nbp_lat)
-  REAL,ALLOCATABLE :: airefi2(:,:) !airefi2(nbp_lon, nbp_lat)
-
-  REAL :: mfu(nbp_lon*(nbp_lat-2)+2,nbp_lev) !mfu(kon, kev)
-  REAL :: mfd(nbp_lon*(nbp_lat-2)+2,nbp_lev) !mfd(kon, kev)
-  REAL :: en_u(nbp_lon*(nbp_lat-2)+2,nbp_lev) !en_u(kon, kev)
-  REAL :: de_u(nbp_lon*(nbp_lat-2)+2,nbp_lev) !de_u(kon, kev)
-  REAL :: en_d(nbp_lon*(nbp_lat-2)+2,nbp_lev) !en_d(kon, kev)
-  REAL :: de_d(nbp_lon*(nbp_lat-2)+2,nbp_lev) !de_d(kon, kev)
-  REAL :: coefh(nbp_lon*(nbp_lat-2)+2,nbp_lev) !coefh(kon, kev)
-
-  ! abd 25 11 02
-  ! Thermiques
-  REAL :: fm_therm(nbp_lon*(nbp_lat-2)+2,nbp_lev) !fm_therm(kon, kev)
-  REAL :: en_therm(nbp_lon*(nbp_lat-2)+2,nbp_lev) !en_therm(kon, kev)
-  REAL :: t(nbp_lon*(nbp_lat-2)+2,nbp_lev) !t(kon, kev)
-
-  REAL,ALLOCATABLE :: mfu2(:,:,:) !mfu2(nbp_lon, nbp_lat, kev)
-  REAL,ALLOCATABLE :: mfd2(:,:,:) !mfd2(nbp_lon, nbp_lat, kev)
-  REAL,ALLOCATABLE :: en_u2(:,:,:) !en_u2(nbp_lon, nbp_lat, kev)
-  REAL,ALLOCATABLE :: de_u2(:,:,:) !de_u2(nbp_lon, nbp_lat, kev)
-  REAL,ALLOCATABLE :: en_d2(:,:,:) !en_d2(nbp_lon, nbp_lat, kev)
-  REAL,ALLOCATABLE :: de_d2(:,:,:) !de_d2(nbp_lon, nbp_lat, kev)
-  REAL,ALLOCATABLE :: coefh2(:,:,:) !coefh2(nbp_lon, nbp_lat, kev)
-  REAL,ALLOCATABLE :: t2(:,:,:) !t2(nbp_lon, nbp_lat, kev)
-  ! Thermiques
-  REAL,ALLOCATABLE :: fm_therm2(:,:,:) !fm_therm2(nbp_lon, nbp_lat, kev)
-  REAL,ALLOCATABLE :: en_therm2(:,:,:) !en_therm2(nbp_lon, nbp_lat, kev)
-
-  REAL,ALLOCATABLE :: pl(:) !pl(kev)
-  INTEGER irec
-  INTEGER xid, yid, zid, tid
-  INTEGER zrec, zim, zjm
-  INTEGER ncrec, nckon, nckev, ncim, ncjm
-
-  REAL :: airefi(nbp_lon*(nbp_lat-2)+2) !airefi(kon)
-  CHARACTER *20 namedim
-
-  ! !! attention !!
-  ! attention il y a aussi le pb de def kon
-  ! dim de phis??
-
-  REAL :: frac_impa(nbp_lon*(nbp_lat-2)+2,nbp_lev) !frac_impa(kon, kev)
-  REAL :: frac_nucl(nbp_lon*(nbp_lat-2)+2,nbp_lev) !frac_nucl(kon, kev)
-  REAL,ALLOCATABLE :: frac_impa2(:,:,:) !frac_impa2(nbp_lon, nbp_lat, kev)
-  REAL,ALLOCATABLE :: frac_nucl2(:,:,:) !frac_nucl2(nbp_lon, nbp_lat, kev)
-  REAL :: pyu1(nbp_lon*(nbp_lat-2)+2) !pyu1(kon)
-  REAL :: pyv1(nbp_lon*(nbp_lat-2)+2) !pyv1(kon)
-  REAL,ALLOCATABLE :: pyu12(:,:), pyv12(:,:) !pyu12(nbp_lon, nbp_lat), pyv12(nbp_lon, nbp_lat)
-  REAL :: ftsol(nbp_lon*(nbp_lat-2)+2,nbp_lev) !ftsol(kon, nbsrf)
-  REAL :: psrf(nbp_lon*(nbp_lat-2)+2,nbp_lev) !psrf(kon, nbsrf)
-  REAL,ALLOCATABLE :: ftsol1(:),ftsol2(:) !ftsol1(kon), ftsol2(kon)
-  REAL,ALLOCATABLE :: ftsol3(:),ftsol4(:) !ftsol3(kon), ftsol4(kon)
-  REAL,ALLOCATABLE :: psrf1(:), psrf2(:) !psrf1(kon), psrf2(kon)
-  REAL,ALLOCATABLE :: psrf3(:), psrf4(:) !psrf3(kon), psrf4(kon)
-  REAL,ALLOCATABLE :: ftsol12(:,:) !ftsol12(nbp_lon, nbp_lat)
-  REAL,ALLOCATABLE :: ftsol22(:,:) !ftsol22(nbp_lon, nbp_lat)
-  REAL,ALLOCATABLE :: ftsol32(:,:) !ftsol32(nbp_lon, nbp_lat)
-  REAL,ALLOCATABLE :: ftsol42(:,:) !ftsol42(nbp_lon, nbp_lat)
-  REAL,ALLOCATABLE :: psrf12(:,:) !psrf12(nbp_lon, nbp_lat)
-  REAL,ALLOCATABLE :: psrf22(:,:) !psrf22(nbp_lon, nbp_lat)
-  REAL,ALLOCATABLE :: psrf32(:,:) !psrf32(nbp_lon, nbp_lat)
-  REAL,ALLOCATABLE :: psrf42(:,:) !psrf42(nbp_lon, nbp_lat)
-
-  INTEGER,SAVE :: ncidp
-  INTEGER,SAVE :: varidmfu, varidmfd, varidps, varidenu, variddeu
-  INTEGER,SAVE :: varidt
-  INTEGER,SAVE :: varidend, varidded, varidch, varidfi, varidfn
-  ! therm
-  INTEGER,SAVE :: varidfmth, varidenth
-  INTEGER,SAVE :: varidyu1, varidyv1, varidpl, varidai, varididvt
-  INTEGER,SAVE :: varidfts1, varidfts2, varidfts3, varidfts4
-  INTEGER,SAVE :: varidpsr1, varidpsr2, varidpsr3, varidpsr4
-
-  INTEGER l, i
-  INTEGER start(4), count(4), status
-  REAL rcode
-  LOGICAL,SAVE :: first=.TRUE.
-
-  ! Allocate arrays
-  kon=nbp_lon*(nbp_lat-2)+2
-  kev=nbp_lev
-
-  ALLOCATE(phisfi2(nbp_lon, nbp_lat))
-  ALLOCATE(airefi2(nbp_lon, nbp_lat))
-  ALLOCATE(mfu2(nbp_lon, nbp_lat, kev))
-  ALLOCATE(mfd2(nbp_lon, nbp_lat, kev))
-  ALLOCATE(en_u2(nbp_lon, nbp_lat, kev))
-  ALLOCATE(de_u2(nbp_lon, nbp_lat, kev))
-  ALLOCATE(en_d2(nbp_lon, nbp_lat, kev))
-  ALLOCATE(de_d2(nbp_lon, nbp_lat, kev))
-  ALLOCATE(coefh2(nbp_lon, nbp_lat, kev))
-  ALLOCATE(t2(nbp_lon, nbp_lat, kev))
-  ALLOCATE(fm_therm2(nbp_lon, nbp_lat, kev))
-  ALLOCATE(en_therm2(nbp_lon, nbp_lat, kev))
-  ALLOCATE(pl(kev))
-  ALLOCATE(frac_impa2(nbp_lon, nbp_lat, kev))
-  ALLOCATE(frac_nucl2(nbp_lon, nbp_lat, kev))
-  ALLOCATE(pyu12(nbp_lon, nbp_lat), pyv12(nbp_lon, nbp_lat))
-  ALLOCATE(ftsol1(kon), ftsol2(kon))
-  ALLOCATE(ftsol3(kon), ftsol4(kon))
-  ALLOCATE(psrf1(kon), psrf2(kon))
-  ALLOCATE(psrf3(kon), psrf4(kon))
-  ALLOCATE(ftsol12(nbp_lon, nbp_lat))
-  ALLOCATE(ftsol22(nbp_lon, nbp_lat))
-  ALLOCATE(ftsol32(nbp_lon, nbp_lat))
-  ALLOCATE(ftsol42(nbp_lon, nbp_lat))
-  ALLOCATE(psrf12(nbp_lon, nbp_lat))
-  ALLOCATE(psrf22(nbp_lon, nbp_lat))
-  ALLOCATE(psrf32(nbp_lon, nbp_lat))
-  ALLOCATE(psrf42(nbp_lon, nbp_lat))
-
-  ! ---------------------------------------------
-  ! Initialisation de la lecture des fichiers
-  ! ---------------------------------------------
-
-  IF (irec==0) THEN
-
-    rcode = nf90_open('phystoke.nc', nf90_nowrite, ncidp)
-
-    rcode = nf90_inq_varid(ncidp, 'phis', varidps)
-    PRINT *, 'ncidp,varidps', ncidp, varidps
-
-    rcode = nf90_inq_varid(ncidp, 'sig_s', varidpl)
-    PRINT *, 'ncidp,varidpl', ncidp, varidpl
-
-    rcode = nf90_inq_varid(ncidp, 'aire', varidai)
-    PRINT *, 'ncidp,varidai', ncidp, varidai
-
-    rcode = nf90_inq_varid(ncidp, 't', varidt)
-    PRINT *, 'ncidp,varidt', ncidp, varidt
-
-    rcode = nf90_inq_varid(ncidp, 'mfu', varidmfu)
-    PRINT *, 'ncidp,varidmfu', ncidp, varidmfu
-
-    rcode = nf90_inq_varid(ncidp, 'mfd', varidmfd)
-    PRINT *, 'ncidp,varidmfd', ncidp, varidmfd
-
-    rcode = nf90_inq_varid(ncidp, 'en_u', varidenu)
-    PRINT *, 'ncidp,varidenu', ncidp, varidenu
-
-    rcode = nf90_inq_varid(ncidp, 'de_u', variddeu)
-    PRINT *, 'ncidp,variddeu', ncidp, variddeu
-
-    rcode = nf90_inq_varid(ncidp, 'en_d', varidend)
-    PRINT *, 'ncidp,varidend', ncidp, varidend
-
-    rcode = nf90_inq_varid(ncidp, 'de_d', varidded)
-    PRINT *, 'ncidp,varidded', ncidp, varidded
-
-    rcode = nf90_inq_varid(ncidp, 'coefh', varidch)
-    PRINT *, 'ncidp,varidch', ncidp, varidch
-
-    ! Thermiques
-    rcode = nf90_inq_varid(ncidp, 'fm_th', varidfmth)
-    PRINT *, 'ncidp,varidfmth', ncidp, varidfmth
-
-    rcode = nf90_inq_varid(ncidp, 'en_th', varidenth)
-    PRINT *, 'ncidp,varidenth', ncidp, varidenth
-
-    rcode = nf90_inq_varid(ncidp, 'frac_impa', varidfi)
-    PRINT *, 'ncidp,varidfi', ncidp, varidfi
-
-    rcode = nf90_inq_varid(ncidp, 'frac_nucl', varidfn)
-    PRINT *, 'ncidp,varidfn', ncidp, varidfn
-
-    rcode = nf90_inq_varid(ncidp, 'pyu1', varidyu1)
-    PRINT *, 'ncidp,varidyu1', ncidp, varidyu1
-
-    rcode = nf90_inq_varid(ncidp, 'pyv1', varidyv1)
-    PRINT *, 'ncidp,varidyv1', ncidp, varidyv1
-
-    rcode = nf90_inq_varid(ncidp, 'ftsol1', varidfts1)
-    PRINT *, 'ncidp,varidfts1', ncidp, varidfts1
-
-    rcode = nf90_inq_varid(ncidp, 'ftsol2', varidfts2)
-    PRINT *, 'ncidp,varidfts2', ncidp, varidfts2
-
-    rcode = nf90_inq_varid(ncidp, 'ftsol3', varidfts3)
-    PRINT *, 'ncidp,varidfts3', ncidp, varidfts3
-
-    rcode = nf90_inq_varid(ncidp, 'ftsol4', varidfts4)
-    PRINT *, 'ncidp,varidfts4', ncidp, varidfts4
-
-    rcode = nf90_inq_varid(ncidp, 'psrf1', varidpsr1)
-    PRINT *, 'ncidp,varidpsr1', ncidp, varidpsr1
-
-    rcode = nf90_inq_varid(ncidp, 'psrf2', varidpsr2)
-    PRINT *, 'ncidp,varidpsr2', ncidp, varidpsr2
-
-    rcode = nf90_inq_varid(ncidp, 'psrf3', varidpsr3)
-    PRINT *, 'ncidp,varidpsr3', ncidp, varidpsr3
-
-    rcode = nf90_inq_varid(ncidp, 'psrf4', varidpsr4)
-    PRINT *, 'ncidp,varidpsr4', ncidp, varidpsr4
-
-    ! ID pour les dimensions
-
-    status = nf_inq_dimid(ncidp, 'y', yid)
-    status = nf_inq_dimid(ncidp, 'x', xid)
-    status = nf_inq_dimid(ncidp, 'sig_s', zid)
-    status = nf_inq_dimid(ncidp, 'time_counter', tid)
-
-    ! lecture des dimensions
-
-    status = nf_inq_dim(ncidp, yid, namedim, ncjm)
-    status = nf_inq_dim(ncidp, xid, namedim, ncim)
-    status = nf_inq_dim(ncidp, zid, namedim, nckev)
-    status = nf_inq_dim(ncidp, tid, namedim, ncrec)
-
-    zrec = ncrec
-    zkev = nckev
-    zim = ncim
-    zjm = ncjm
-
-    zkon = zim*(zjm-2) + 2
-
-    WRITE (*, *) 'read_pstoke : zrec = ', zrec
-    WRITE (*, *) 'read_pstoke : kev = ', zkev
-    WRITE (*, *) 'read_pstoke : zim = ', zim
-    WRITE (*, *) 'read_pstoke : zjm = ', zjm
-    WRITE (*, *) 'read_pstoke : kon = ', zkon
-
-    ! niveaux de pression
-
-    status = nf_get_vara_real(ncidp, varidpl, 1, kev, pl)
-
-    ! lecture de aire et phis
-
-    start(1) = 1
-    start(2) = 1
-    start(3) = 1
-    start(4) = 0
-
-    count(1) = zim
-    count(2) = zjm
-    count(3) = 1
-    count(4) = 0
-
-
-    ! **** Geopotentiel au sol ***************************************
-    ! phis
-    status = nf90_get_var(ncidp, varidps, phisfi2, start, count)
-    CALL gr_ecrit_fi(1, kon, nbp_lon, nbp_lat, phisfi2, phisfi)
-
-    ! **** Aires des mails aux sol ************************************
-    ! aire
-    status = nf90_get_var(ncidp, varidai, airefi2, start, count)
-    CALL gr_ecrit_fi(1, kon, nbp_lon, nbp_lat, airefi2, airefi)
-  ELSE
-
-    PRINT *, 'ok1'
-
-    ! ---------------------
-    ! lecture des champs
-    ! ---------------------
-
-    PRINT *, 'WARNING!!! Il n y a pas de test de coherence'
-    PRINT *, 'sur le nombre de niveaux verticaux dans le fichier nc'
-
-    start(1) = 1
-    start(2) = 1
-    start(3) = 1
-    start(4) = irec
-
-    count(1) = zim
-    count(2) = zjm
-    count(3) = kev
-    count(4) = 1
-
-    ! **** Temperature ********************************************
-    ! A FAIRE : Es-ce necessaire ?
-
-    ! abder t
-    status = nf90_get_var(ncidp, varidt, t2, start, count)
-    CALL gr_ecrit_fi(kev, kon, nbp_lon, nbp_lat, t2, t)
-
-    ! **** Flux pour la convection (Tiedtk)
-    ! ********************************************
-    ! mfu
-    status = nf90_get_var(ncidp, varidmfu, mfu2, start, count)
-    CALL gr_ecrit_fi(kev, kon, nbp_lon, nbp_lat, mfu2, mfu)
-
-    ! mfd
-    status = nf90_get_var(ncidp, varidmfd, mfd2, start, count)
-    CALL gr_ecrit_fi(kev, kon, nbp_lon, nbp_lat, mfd2, mfd)
-
-    ! en_u
-    status = nf90_get_var(ncidp, varidenu, en_u2, start, count)
-    CALL gr_ecrit_fi(kev, kon, nbp_lon, nbp_lat, en_u2, en_u)
-
-    ! de_u
-    status = nf90_get_var(ncidp, variddeu, de_u2, start, count)
-    CALL gr_ecrit_fi(kev, kon, nbp_lon, nbp_lat, de_u2, de_u)
-
-    ! en_d
-    status = nf90_get_var(ncidp, varidend, en_d2, start, count)
-    CALL gr_ecrit_fi(kev, kon, nbp_lon, nbp_lat, en_d2, en_d)
-
-    ! de_d
-    status = nf90_get_var(ncidp, varidded, de_d2, start, count)
-    CALL gr_ecrit_fi(kev, kon, nbp_lon, nbp_lat, de_d2, de_d)
-
-    ! **** Coefficient de mellange turbulent
-    ! *******************************************
-    ! coefh
-    PRINT *, 'LECTURE de coefh a irec =', irec
-    status = nf90_get_var(ncidp, varidch, coefh2, start, count)
-    CALL gr_ecrit_fi(kev, kon, nbp_lon, nbp_lat, coefh2, coefh)
-    ! call dump2d(iip1,jjp1,coefh2(1,2),'COEFH2READ   ')
-    ! call dump2d(iim ,jjm ,coefh (2,2),'COEFH2READ   ')
-
-    ! **** Flux ascendants et entrant dans le thermique
-    ! **********************************
-    ! Thermiques
-    PRINT *, 'LECTURE de fm_therm a irec =', irec
-    status = nf90_get_var(ncidp, varidfmth, fm_therm2, start, count)
-    CALL gr_ecrit_fi(kev, kon, nbp_lon, nbp_lat, fm_therm2, fm_therm)
-    PRINT *, 'LECTURE de en_therm a irec =', irec
-    status = nf90_get_var(ncidp, varidenth, en_therm2, start, count)
-    CALL gr_ecrit_fi(kev, kon, nbp_lon, nbp_lat, en_therm2, en_therm)
-
-    ! **** Coefficients de lessivage
-    ! *******************************************
-    ! frac_impa
-    status = nf90_get_var(ncidp, varidfi, frac_impa2, start, count)
-    CALL gr_ecrit_fi(kev, kon, nbp_lon, nbp_lat, frac_impa2, frac_impa)
-
-    ! frac_nucl
-
-    status = nf90_get_var(ncidp, varidfn, frac_nucl2, start, count)
-    CALL gr_ecrit_fi(kev, kon, nbp_lon, nbp_lat, frac_nucl2, frac_nucl)
-
-    ! **** Vents aux sol ********************************************
-
-    start(3) = irec
-    start(4) = 0
-    count(3) = 1
-    count(4) = 0
-
-    ! pyu1
-    PRINT *, 'LECTURE de yu1 a irec =', irec
-    status = nf90_get_var(ncidp, varidyu1, pyu12, start, count)
-    CALL gr_ecrit_fi(1, kon, nbp_lon, nbp_lat, pyu12, pyu1)
-
-    ! pyv1
-    PRINT *, 'LECTURE de yv1 a irec =', irec
-    status = nf90_get_var(ncidp, varidyv1, pyv12, start, count)
-    CALL gr_ecrit_fi(1, kon, nbp_lon, nbp_lat, pyv12, pyv1)
-
-    ! **** Temerature au sol ********************************************
-    ! ftsol1
-    PRINT *, 'LECTURE de ftsol1 a irec =', irec
-    status = nf90_get_var(ncidp, varidfts1, ftsol12, start, count)
-    CALL gr_ecrit_fi(1, kon, nbp_lon, nbp_lat, ftsol12, ftsol1)
-
-    ! ftsol2
-    PRINT *, 'LECTURE de ftsol2 a irec =', irec
-    status = nf90_get_var(ncidp, varidfts2, ftsol22, start, count)
-    CALL gr_ecrit_fi(1, kon, nbp_lon, nbp_lat, ftsol22, ftsol2)
-
-    ! ftsol3
-    PRINT *, 'LECTURE de ftsol3 a irec =', irec
-    status = nf90_get_var(ncidp, varidfts3, ftsol32, start, count)
-    CALL gr_ecrit_fi(1, kon, nbp_lon, nbp_lat, ftsol32, ftsol3)
-
-    ! ftsol4
-    status = nf90_get_var(ncidp, varidfts4, ftsol42, start, count)
-    CALL gr_ecrit_fi(1, kon, nbp_lon, nbp_lat, ftsol42, ftsol4)
-
-    ! **** Nature sol ********************************************
-    ! psrf1
-    status = nf90_get_var(ncidp, varidpsr1, psrf12, start, count)
-    ! call dump2d(iip1-1,jjm+1,psrf12,'PSRF1NC')
-    CALL gr_ecrit_fi(1, kon, nbp_lon, nbp_lat, psrf12, psrf1)
-
-    ! psrf2
-    status = nf90_get_var(ncidp, varidpsr2, psrf22, start, count)
-    ! call dump2d(iip1-1,jjm+1,psrf22,'PSRF2NC')
-    CALL gr_ecrit_fi(1, kon, nbp_lon, nbp_lat, psrf22, psrf2)
-
-    ! psrf3
-    status = nf90_get_var(ncidp, varidpsr3, psrf32, start, count)
-    CALL gr_ecrit_fi(1, kon, nbp_lon, nbp_lat, psrf32, psrf3)
-
-    ! psrf4
-    status = nf90_get_var(ncidp, varidpsr4, psrf42, start, count)
-    CALL gr_ecrit_fi(1, kon, nbp_lon, nbp_lat, psrf42, psrf4)
-
-    DO i = 1, kon
-
-      psrf(i, 1) = psrf1(i)
-      psrf(i, 2) = psrf2(i)
-      psrf(i, 3) = psrf3(i)
-      ! test abderr
-      ! print*,'Dans read_pstoke psrf3 =',psrf3(i),i
-      psrf(i, 4) = psrf4(i)
-
-      ftsol(i, 1) = ftsol1(i)
-      ftsol(i, 2) = ftsol2(i)
-      ftsol(i, 3) = ftsol3(i)
-      ftsol(i, 4) = ftsol4(i)
-
-    END DO
-
-  END IF
-
-  RETURN
-
-END SUBROUTINE read_pstoke0
-
Index: /LMDZ6/trunk/libf/phylmd/read_pstoke0.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/read_pstoke0.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/read_pstoke0.f90	(revision 5268)
@@ -0,0 +1,440 @@
+
+! $Id$
+
+
+
+SUBROUTINE read_pstoke0(irec, zrec, zkon, zkev, airefi, phisfi, t, mfu, mfd, &
+    en_u, de_u, en_d, de_d, coefh, fm_therm, en_therm, frac_impa, frac_nucl, &
+    pyu1, pyv1, ftsol, psrf)
+
+  ! ******************************************************************************
+  ! Frederic HOURDIN, Abderrahmane IDELKADI
+  ! Lecture des parametres physique stockes online necessaires pour
+  ! recalculer offline le transport des traceurs sur la meme grille que
+  ! online
+  ! A FAIRE : une seule routine au lieu de 2 (lectflux, redecoupe)!
+  ! ******************************************************************************
+
+  USE netcdf
+  USE dimphy
+  USE indice_sol_mod
+  USE mod_grid_phy_lmdz, ONLY: nbp_lon, nbp_lat, nbp_lev
+
+  IMPLICIT NONE
+
+  include "netcdf.inc"
+
+  INTEGER kon, kev, zkon, zkev
+!  PARAMETER (kon=iim*(jjm-1)+2, kev=llm)
+  REAL :: phisfi(nbp_lon*(nbp_lat-2)+2) !phisfi(kon)
+  REAL,ALLOCATABLE :: phisfi2(:,:) !phisfi2(nbp_lon, nbp_lat)
+  REAL,ALLOCATABLE :: airefi2(:,:) !airefi2(nbp_lon, nbp_lat)
+
+  REAL :: mfu(nbp_lon*(nbp_lat-2)+2,nbp_lev) !mfu(kon, kev)
+  REAL :: mfd(nbp_lon*(nbp_lat-2)+2,nbp_lev) !mfd(kon, kev)
+  REAL :: en_u(nbp_lon*(nbp_lat-2)+2,nbp_lev) !en_u(kon, kev)
+  REAL :: de_u(nbp_lon*(nbp_lat-2)+2,nbp_lev) !de_u(kon, kev)
+  REAL :: en_d(nbp_lon*(nbp_lat-2)+2,nbp_lev) !en_d(kon, kev)
+  REAL :: de_d(nbp_lon*(nbp_lat-2)+2,nbp_lev) !de_d(kon, kev)
+  REAL :: coefh(nbp_lon*(nbp_lat-2)+2,nbp_lev) !coefh(kon, kev)
+
+  ! abd 25 11 02
+  ! Thermiques
+  REAL :: fm_therm(nbp_lon*(nbp_lat-2)+2,nbp_lev) !fm_therm(kon, kev)
+  REAL :: en_therm(nbp_lon*(nbp_lat-2)+2,nbp_lev) !en_therm(kon, kev)
+  REAL :: t(nbp_lon*(nbp_lat-2)+2,nbp_lev) !t(kon, kev)
+
+  REAL,ALLOCATABLE :: mfu2(:,:,:) !mfu2(nbp_lon, nbp_lat, kev)
+  REAL,ALLOCATABLE :: mfd2(:,:,:) !mfd2(nbp_lon, nbp_lat, kev)
+  REAL,ALLOCATABLE :: en_u2(:,:,:) !en_u2(nbp_lon, nbp_lat, kev)
+  REAL,ALLOCATABLE :: de_u2(:,:,:) !de_u2(nbp_lon, nbp_lat, kev)
+  REAL,ALLOCATABLE :: en_d2(:,:,:) !en_d2(nbp_lon, nbp_lat, kev)
+  REAL,ALLOCATABLE :: de_d2(:,:,:) !de_d2(nbp_lon, nbp_lat, kev)
+  REAL,ALLOCATABLE :: coefh2(:,:,:) !coefh2(nbp_lon, nbp_lat, kev)
+  REAL,ALLOCATABLE :: t2(:,:,:) !t2(nbp_lon, nbp_lat, kev)
+  ! Thermiques
+  REAL,ALLOCATABLE :: fm_therm2(:,:,:) !fm_therm2(nbp_lon, nbp_lat, kev)
+  REAL,ALLOCATABLE :: en_therm2(:,:,:) !en_therm2(nbp_lon, nbp_lat, kev)
+
+  REAL,ALLOCATABLE :: pl(:) !pl(kev)
+  INTEGER irec
+  INTEGER xid, yid, zid, tid
+  INTEGER zrec, zim, zjm
+  INTEGER ncrec, nckon, nckev, ncim, ncjm
+
+  REAL :: airefi(nbp_lon*(nbp_lat-2)+2) !airefi(kon)
+  CHARACTER *20 namedim
+
+  ! !! attention !!
+  ! attention il y a aussi le pb de def kon
+  ! dim de phis??
+
+  REAL :: frac_impa(nbp_lon*(nbp_lat-2)+2,nbp_lev) !frac_impa(kon, kev)
+  REAL :: frac_nucl(nbp_lon*(nbp_lat-2)+2,nbp_lev) !frac_nucl(kon, kev)
+  REAL,ALLOCATABLE :: frac_impa2(:,:,:) !frac_impa2(nbp_lon, nbp_lat, kev)
+  REAL,ALLOCATABLE :: frac_nucl2(:,:,:) !frac_nucl2(nbp_lon, nbp_lat, kev)
+  REAL :: pyu1(nbp_lon*(nbp_lat-2)+2) !pyu1(kon)
+  REAL :: pyv1(nbp_lon*(nbp_lat-2)+2) !pyv1(kon)
+  REAL,ALLOCATABLE :: pyu12(:,:), pyv12(:,:) !pyu12(nbp_lon, nbp_lat), pyv12(nbp_lon, nbp_lat)
+  REAL :: ftsol(nbp_lon*(nbp_lat-2)+2,nbp_lev) !ftsol(kon, nbsrf)
+  REAL :: psrf(nbp_lon*(nbp_lat-2)+2,nbp_lev) !psrf(kon, nbsrf)
+  REAL,ALLOCATABLE :: ftsol1(:),ftsol2(:) !ftsol1(kon), ftsol2(kon)
+  REAL,ALLOCATABLE :: ftsol3(:),ftsol4(:) !ftsol3(kon), ftsol4(kon)
+  REAL,ALLOCATABLE :: psrf1(:), psrf2(:) !psrf1(kon), psrf2(kon)
+  REAL,ALLOCATABLE :: psrf3(:), psrf4(:) !psrf3(kon), psrf4(kon)
+  REAL,ALLOCATABLE :: ftsol12(:,:) !ftsol12(nbp_lon, nbp_lat)
+  REAL,ALLOCATABLE :: ftsol22(:,:) !ftsol22(nbp_lon, nbp_lat)
+  REAL,ALLOCATABLE :: ftsol32(:,:) !ftsol32(nbp_lon, nbp_lat)
+  REAL,ALLOCATABLE :: ftsol42(:,:) !ftsol42(nbp_lon, nbp_lat)
+  REAL,ALLOCATABLE :: psrf12(:,:) !psrf12(nbp_lon, nbp_lat)
+  REAL,ALLOCATABLE :: psrf22(:,:) !psrf22(nbp_lon, nbp_lat)
+  REAL,ALLOCATABLE :: psrf32(:,:) !psrf32(nbp_lon, nbp_lat)
+  REAL,ALLOCATABLE :: psrf42(:,:) !psrf42(nbp_lon, nbp_lat)
+
+  INTEGER,SAVE :: ncidp
+  INTEGER,SAVE :: varidmfu, varidmfd, varidps, varidenu, variddeu
+  INTEGER,SAVE :: varidt
+  INTEGER,SAVE :: varidend, varidded, varidch, varidfi, varidfn
+  ! therm
+  INTEGER,SAVE :: varidfmth, varidenth
+  INTEGER,SAVE :: varidyu1, varidyv1, varidpl, varidai, varididvt
+  INTEGER,SAVE :: varidfts1, varidfts2, varidfts3, varidfts4
+  INTEGER,SAVE :: varidpsr1, varidpsr2, varidpsr3, varidpsr4
+
+  INTEGER l, i
+  INTEGER start(4), count(4), status
+  REAL rcode
+  LOGICAL,SAVE :: first=.TRUE.
+
+  ! Allocate arrays
+  kon=nbp_lon*(nbp_lat-2)+2
+  kev=nbp_lev
+
+  ALLOCATE(phisfi2(nbp_lon, nbp_lat))
+  ALLOCATE(airefi2(nbp_lon, nbp_lat))
+  ALLOCATE(mfu2(nbp_lon, nbp_lat, kev))
+  ALLOCATE(mfd2(nbp_lon, nbp_lat, kev))
+  ALLOCATE(en_u2(nbp_lon, nbp_lat, kev))
+  ALLOCATE(de_u2(nbp_lon, nbp_lat, kev))
+  ALLOCATE(en_d2(nbp_lon, nbp_lat, kev))
+  ALLOCATE(de_d2(nbp_lon, nbp_lat, kev))
+  ALLOCATE(coefh2(nbp_lon, nbp_lat, kev))
+  ALLOCATE(t2(nbp_lon, nbp_lat, kev))
+  ALLOCATE(fm_therm2(nbp_lon, nbp_lat, kev))
+  ALLOCATE(en_therm2(nbp_lon, nbp_lat, kev))
+  ALLOCATE(pl(kev))
+  ALLOCATE(frac_impa2(nbp_lon, nbp_lat, kev))
+  ALLOCATE(frac_nucl2(nbp_lon, nbp_lat, kev))
+  ALLOCATE(pyu12(nbp_lon, nbp_lat), pyv12(nbp_lon, nbp_lat))
+  ALLOCATE(ftsol1(kon), ftsol2(kon))
+  ALLOCATE(ftsol3(kon), ftsol4(kon))
+  ALLOCATE(psrf1(kon), psrf2(kon))
+  ALLOCATE(psrf3(kon), psrf4(kon))
+  ALLOCATE(ftsol12(nbp_lon, nbp_lat))
+  ALLOCATE(ftsol22(nbp_lon, nbp_lat))
+  ALLOCATE(ftsol32(nbp_lon, nbp_lat))
+  ALLOCATE(ftsol42(nbp_lon, nbp_lat))
+  ALLOCATE(psrf12(nbp_lon, nbp_lat))
+  ALLOCATE(psrf22(nbp_lon, nbp_lat))
+  ALLOCATE(psrf32(nbp_lon, nbp_lat))
+  ALLOCATE(psrf42(nbp_lon, nbp_lat))
+
+  ! ---------------------------------------------
+  ! Initialisation de la lecture des fichiers
+  ! ---------------------------------------------
+
+  IF (irec==0) THEN
+
+    rcode = nf90_open('phystoke.nc', nf90_nowrite, ncidp)
+
+    rcode = nf90_inq_varid(ncidp, 'phis', varidps)
+    PRINT *, 'ncidp,varidps', ncidp, varidps
+
+    rcode = nf90_inq_varid(ncidp, 'sig_s', varidpl)
+    PRINT *, 'ncidp,varidpl', ncidp, varidpl
+
+    rcode = nf90_inq_varid(ncidp, 'aire', varidai)
+    PRINT *, 'ncidp,varidai', ncidp, varidai
+
+    rcode = nf90_inq_varid(ncidp, 't', varidt)
+    PRINT *, 'ncidp,varidt', ncidp, varidt
+
+    rcode = nf90_inq_varid(ncidp, 'mfu', varidmfu)
+    PRINT *, 'ncidp,varidmfu', ncidp, varidmfu
+
+    rcode = nf90_inq_varid(ncidp, 'mfd', varidmfd)
+    PRINT *, 'ncidp,varidmfd', ncidp, varidmfd
+
+    rcode = nf90_inq_varid(ncidp, 'en_u', varidenu)
+    PRINT *, 'ncidp,varidenu', ncidp, varidenu
+
+    rcode = nf90_inq_varid(ncidp, 'de_u', variddeu)
+    PRINT *, 'ncidp,variddeu', ncidp, variddeu
+
+    rcode = nf90_inq_varid(ncidp, 'en_d', varidend)
+    PRINT *, 'ncidp,varidend', ncidp, varidend
+
+    rcode = nf90_inq_varid(ncidp, 'de_d', varidded)
+    PRINT *, 'ncidp,varidded', ncidp, varidded
+
+    rcode = nf90_inq_varid(ncidp, 'coefh', varidch)
+    PRINT *, 'ncidp,varidch', ncidp, varidch
+
+    ! Thermiques
+    rcode = nf90_inq_varid(ncidp, 'fm_th', varidfmth)
+    PRINT *, 'ncidp,varidfmth', ncidp, varidfmth
+
+    rcode = nf90_inq_varid(ncidp, 'en_th', varidenth)
+    PRINT *, 'ncidp,varidenth', ncidp, varidenth
+
+    rcode = nf90_inq_varid(ncidp, 'frac_impa', varidfi)
+    PRINT *, 'ncidp,varidfi', ncidp, varidfi
+
+    rcode = nf90_inq_varid(ncidp, 'frac_nucl', varidfn)
+    PRINT *, 'ncidp,varidfn', ncidp, varidfn
+
+    rcode = nf90_inq_varid(ncidp, 'pyu1', varidyu1)
+    PRINT *, 'ncidp,varidyu1', ncidp, varidyu1
+
+    rcode = nf90_inq_varid(ncidp, 'pyv1', varidyv1)
+    PRINT *, 'ncidp,varidyv1', ncidp, varidyv1
+
+    rcode = nf90_inq_varid(ncidp, 'ftsol1', varidfts1)
+    PRINT *, 'ncidp,varidfts1', ncidp, varidfts1
+
+    rcode = nf90_inq_varid(ncidp, 'ftsol2', varidfts2)
+    PRINT *, 'ncidp,varidfts2', ncidp, varidfts2
+
+    rcode = nf90_inq_varid(ncidp, 'ftsol3', varidfts3)
+    PRINT *, 'ncidp,varidfts3', ncidp, varidfts3
+
+    rcode = nf90_inq_varid(ncidp, 'ftsol4', varidfts4)
+    PRINT *, 'ncidp,varidfts4', ncidp, varidfts4
+
+    rcode = nf90_inq_varid(ncidp, 'psrf1', varidpsr1)
+    PRINT *, 'ncidp,varidpsr1', ncidp, varidpsr1
+
+    rcode = nf90_inq_varid(ncidp, 'psrf2', varidpsr2)
+    PRINT *, 'ncidp,varidpsr2', ncidp, varidpsr2
+
+    rcode = nf90_inq_varid(ncidp, 'psrf3', varidpsr3)
+    PRINT *, 'ncidp,varidpsr3', ncidp, varidpsr3
+
+    rcode = nf90_inq_varid(ncidp, 'psrf4', varidpsr4)
+    PRINT *, 'ncidp,varidpsr4', ncidp, varidpsr4
+
+    ! ID pour les dimensions
+
+    status = nf_inq_dimid(ncidp, 'y', yid)
+    status = nf_inq_dimid(ncidp, 'x', xid)
+    status = nf_inq_dimid(ncidp, 'sig_s', zid)
+    status = nf_inq_dimid(ncidp, 'time_counter', tid)
+
+    ! lecture des dimensions
+
+    status = nf_inq_dim(ncidp, yid, namedim, ncjm)
+    status = nf_inq_dim(ncidp, xid, namedim, ncim)
+    status = nf_inq_dim(ncidp, zid, namedim, nckev)
+    status = nf_inq_dim(ncidp, tid, namedim, ncrec)
+
+    zrec = ncrec
+    zkev = nckev
+    zim = ncim
+    zjm = ncjm
+
+    zkon = zim*(zjm-2) + 2
+
+    WRITE (*, *) 'read_pstoke : zrec = ', zrec
+    WRITE (*, *) 'read_pstoke : kev = ', zkev
+    WRITE (*, *) 'read_pstoke : zim = ', zim
+    WRITE (*, *) 'read_pstoke : zjm = ', zjm
+    WRITE (*, *) 'read_pstoke : kon = ', zkon
+
+    ! niveaux de pression
+
+    status = nf_get_vara_real(ncidp, varidpl, 1, kev, pl)
+
+    ! lecture de aire et phis
+
+    start(1) = 1
+    start(2) = 1
+    start(3) = 1
+    start(4) = 0
+
+    count(1) = zim
+    count(2) = zjm
+    count(3) = 1
+    count(4) = 0
+
+
+    ! **** Geopotentiel au sol ***************************************
+    ! phis
+    status = nf90_get_var(ncidp, varidps, phisfi2, start, count)
+    CALL gr_ecrit_fi(1, kon, nbp_lon, nbp_lat, phisfi2, phisfi)
+
+    ! **** Aires des mails aux sol ************************************
+    ! aire
+    status = nf90_get_var(ncidp, varidai, airefi2, start, count)
+    CALL gr_ecrit_fi(1, kon, nbp_lon, nbp_lat, airefi2, airefi)
+  ELSE
+
+    PRINT *, 'ok1'
+
+    ! ---------------------
+    ! lecture des champs
+    ! ---------------------
+
+    PRINT *, 'WARNING!!! Il n y a pas de test de coherence'
+    PRINT *, 'sur le nombre de niveaux verticaux dans le fichier nc'
+
+    start(1) = 1
+    start(2) = 1
+    start(3) = 1
+    start(4) = irec
+
+    count(1) = zim
+    count(2) = zjm
+    count(3) = kev
+    count(4) = 1
+
+    ! **** Temperature ********************************************
+    ! A FAIRE : Es-ce necessaire ?
+
+    ! abder t
+    status = nf90_get_var(ncidp, varidt, t2, start, count)
+    CALL gr_ecrit_fi(kev, kon, nbp_lon, nbp_lat, t2, t)
+
+    ! **** Flux pour la convection (Tiedtk)
+    ! ********************************************
+    ! mfu
+    status = nf90_get_var(ncidp, varidmfu, mfu2, start, count)
+    CALL gr_ecrit_fi(kev, kon, nbp_lon, nbp_lat, mfu2, mfu)
+
+    ! mfd
+    status = nf90_get_var(ncidp, varidmfd, mfd2, start, count)
+    CALL gr_ecrit_fi(kev, kon, nbp_lon, nbp_lat, mfd2, mfd)
+
+    ! en_u
+    status = nf90_get_var(ncidp, varidenu, en_u2, start, count)
+    CALL gr_ecrit_fi(kev, kon, nbp_lon, nbp_lat, en_u2, en_u)
+
+    ! de_u
+    status = nf90_get_var(ncidp, variddeu, de_u2, start, count)
+    CALL gr_ecrit_fi(kev, kon, nbp_lon, nbp_lat, de_u2, de_u)
+
+    ! en_d
+    status = nf90_get_var(ncidp, varidend, en_d2, start, count)
+    CALL gr_ecrit_fi(kev, kon, nbp_lon, nbp_lat, en_d2, en_d)
+
+    ! de_d
+    status = nf90_get_var(ncidp, varidded, de_d2, start, count)
+    CALL gr_ecrit_fi(kev, kon, nbp_lon, nbp_lat, de_d2, de_d)
+
+    ! **** Coefficient de mellange turbulent
+    ! *******************************************
+    ! coefh
+    PRINT *, 'LECTURE de coefh a irec =', irec
+    status = nf90_get_var(ncidp, varidch, coefh2, start, count)
+    CALL gr_ecrit_fi(kev, kon, nbp_lon, nbp_lat, coefh2, coefh)
+    ! call dump2d(iip1,jjp1,coefh2(1,2),'COEFH2READ   ')
+    ! call dump2d(iim ,jjm ,coefh (2,2),'COEFH2READ   ')
+
+    ! **** Flux ascendants et entrant dans le thermique
+    ! **********************************
+    ! Thermiques
+    PRINT *, 'LECTURE de fm_therm a irec =', irec
+    status = nf90_get_var(ncidp, varidfmth, fm_therm2, start, count)
+    CALL gr_ecrit_fi(kev, kon, nbp_lon, nbp_lat, fm_therm2, fm_therm)
+    PRINT *, 'LECTURE de en_therm a irec =', irec
+    status = nf90_get_var(ncidp, varidenth, en_therm2, start, count)
+    CALL gr_ecrit_fi(kev, kon, nbp_lon, nbp_lat, en_therm2, en_therm)
+
+    ! **** Coefficients de lessivage
+    ! *******************************************
+    ! frac_impa
+    status = nf90_get_var(ncidp, varidfi, frac_impa2, start, count)
+    CALL gr_ecrit_fi(kev, kon, nbp_lon, nbp_lat, frac_impa2, frac_impa)
+
+    ! frac_nucl
+
+    status = nf90_get_var(ncidp, varidfn, frac_nucl2, start, count)
+    CALL gr_ecrit_fi(kev, kon, nbp_lon, nbp_lat, frac_nucl2, frac_nucl)
+
+    ! **** Vents aux sol ********************************************
+
+    start(3) = irec
+    start(4) = 0
+    count(3) = 1
+    count(4) = 0
+
+    ! pyu1
+    PRINT *, 'LECTURE de yu1 a irec =', irec
+    status = nf90_get_var(ncidp, varidyu1, pyu12, start, count)
+    CALL gr_ecrit_fi(1, kon, nbp_lon, nbp_lat, pyu12, pyu1)
+
+    ! pyv1
+    PRINT *, 'LECTURE de yv1 a irec =', irec
+    status = nf90_get_var(ncidp, varidyv1, pyv12, start, count)
+    CALL gr_ecrit_fi(1, kon, nbp_lon, nbp_lat, pyv12, pyv1)
+
+    ! **** Temerature au sol ********************************************
+    ! ftsol1
+    PRINT *, 'LECTURE de ftsol1 a irec =', irec
+    status = nf90_get_var(ncidp, varidfts1, ftsol12, start, count)
+    CALL gr_ecrit_fi(1, kon, nbp_lon, nbp_lat, ftsol12, ftsol1)
+
+    ! ftsol2
+    PRINT *, 'LECTURE de ftsol2 a irec =', irec
+    status = nf90_get_var(ncidp, varidfts2, ftsol22, start, count)
+    CALL gr_ecrit_fi(1, kon, nbp_lon, nbp_lat, ftsol22, ftsol2)
+
+    ! ftsol3
+    PRINT *, 'LECTURE de ftsol3 a irec =', irec
+    status = nf90_get_var(ncidp, varidfts3, ftsol32, start, count)
+    CALL gr_ecrit_fi(1, kon, nbp_lon, nbp_lat, ftsol32, ftsol3)
+
+    ! ftsol4
+    status = nf90_get_var(ncidp, varidfts4, ftsol42, start, count)
+    CALL gr_ecrit_fi(1, kon, nbp_lon, nbp_lat, ftsol42, ftsol4)
+
+    ! **** Nature sol ********************************************
+    ! psrf1
+    status = nf90_get_var(ncidp, varidpsr1, psrf12, start, count)
+    ! call dump2d(iip1-1,jjm+1,psrf12,'PSRF1NC')
+    CALL gr_ecrit_fi(1, kon, nbp_lon, nbp_lat, psrf12, psrf1)
+
+    ! psrf2
+    status = nf90_get_var(ncidp, varidpsr2, psrf22, start, count)
+    ! call dump2d(iip1-1,jjm+1,psrf22,'PSRF2NC')
+    CALL gr_ecrit_fi(1, kon, nbp_lon, nbp_lat, psrf22, psrf2)
+
+    ! psrf3
+    status = nf90_get_var(ncidp, varidpsr3, psrf32, start, count)
+    CALL gr_ecrit_fi(1, kon, nbp_lon, nbp_lat, psrf32, psrf3)
+
+    ! psrf4
+    status = nf90_get_var(ncidp, varidpsr4, psrf42, start, count)
+    CALL gr_ecrit_fi(1, kon, nbp_lon, nbp_lat, psrf42, psrf4)
+
+    DO i = 1, kon
+
+      psrf(i, 1) = psrf1(i)
+      psrf(i, 2) = psrf2(i)
+      psrf(i, 3) = psrf3(i)
+      ! test abderr
+      ! print*,'Dans read_pstoke psrf3 =',psrf3(i),i
+      psrf(i, 4) = psrf4(i)
+
+      ftsol(i, 1) = ftsol1(i)
+      ftsol(i, 2) = ftsol2(i)
+      ftsol(i, 3) = ftsol3(i)
+      ftsol(i, 4) = ftsol4(i)
+
+    END DO
+
+  END IF
+
+  RETURN
+
+END SUBROUTINE read_pstoke0
+
Index: DZ6/trunk/libf/phylmd/readaerosol_interp.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/readaerosol_interp.F90	(revision 5267)
+++ 	(revision )
@@ -1,579 +1,0 @@
-! $Id$
-!
-SUBROUTINE readaerosol_interp(id_aero, itap, pdtphys, r_day, first, pplay, paprs, t_seri, mass_out, pi_mass_out, load_src)
-!
-! This routine will return the mass concentration at actual day(mass_out) and 
-! the pre-industrial values(pi_mass_out) for aerosol corresponding to "id_aero".
-! The mass concentrations for all aerosols are saved in this routine but each
-! call to this routine only treats the aerosol "id_aero".
-!
-! 1) Read in data for the whole year, only at first time step
-! 2) Interpolate to the actual day, only at new day
-! 3) Interpolate to the model vertical grid (target grid), only at new day
-! 4) Test for negative mass values
-
-  USE ioipsl
-  USE dimphy, ONLY : klev,klon
-  USE mod_phys_lmdz_para, ONLY : mpi_rank  
-  USE readaerosol_mod
-  USE aero_mod, ONLY : naero_spc, name_aero
-  USE write_field_phy
-  USE phys_cal_mod
-  USE pres2lev_mod
-  USE print_control_mod, ONLY: lunout
-
-  IMPLICIT NONE
-
-  INCLUDE "YOMCST.h"
-  INCLUDE "chem.h"      
-  INCLUDE "clesphys.h"
-
-!
-! Input:
-!****************************************************************************************
-  INTEGER, INTENT(IN)                    :: id_aero! Identity number for the aerosol to treat
-  INTEGER, INTENT(IN)                    :: itap   ! Physic step count
-  REAL, INTENT(IN)                       :: pdtphys! Physic day step
-  REAL, INTENT(IN)                       :: r_day  ! Day of integration
-  LOGICAL, INTENT(IN)                    :: first  ! First model timestep 
-  REAL, DIMENSION(klon,klev), INTENT(IN) :: pplay  ! pression at model mid-layers
-  REAL, DIMENSION(klon,klev+1),INTENT(IN):: paprs  ! pression between model layers
-  REAL, DIMENSION(klon,klev), INTENT(IN) :: t_seri ! air temperature
-!      
-! Output:      
-!****************************************************************************************
-  REAL, INTENT(OUT) :: mass_out(klon,klev)    ! Mass of aerosol (monthly mean data,from file) [ug AIBCM/m3]
-  REAL, INTENT(OUT) :: pi_mass_out(klon,klev) ! Mass of preindustrial aerosol (monthly mean data,from file) [ug AIBCM/m3]
-  REAL, INTENT(OUT) :: load_src(klon) ! Load of aerosol (monthly mean data,from file) [kg/m3]
-!      
-! Local Variables:
-!****************************************************************************************
-  INTEGER                         :: i, k, ierr
-  INTEGER                         :: iday, iyr, lmt_pas
-!  INTEGER                         :: im, day1, day2, im2
-  INTEGER                         :: im, im2
-  REAL                            :: day1, day2
-  INTEGER                         :: pi_klev_src ! Only for testing purpose
-  INTEGER, SAVE                   :: klev_src    ! Number of vertical levles in source field
-!$OMP THREADPRIVATE(klev_src)
-
-  REAL                              :: zrho      ! Air density [kg/m3]
-  REAL                              :: volm      ! Volyme de melange [kg/kg]
-  REAL, DIMENSION(klon)             :: psurf_day, pi_psurf_day
-  REAL, DIMENSION(klon)             :: pi_load_src  ! Mass load at source grid
-  REAL, DIMENSION(klon)             :: load_tgt, load_tgt_test
-  REAL, DIMENSION(klon,klev)        :: delp ! pressure difference in each model layer
-
-  REAL, ALLOCATABLE, DIMENSION(:,:)            :: pplay_src ! pression mid-layer at source levels
-  REAL, ALLOCATABLE, DIMENSION(:,:)            :: tmp1, tmp2  ! Temporary variables
-  REAL, ALLOCATABLE, DIMENSION(:,:,:,:), SAVE  :: var_year    ! VAR in right dimension for the total year
-  REAL, ALLOCATABLE, DIMENSION(:,:,:,:), SAVE  :: pi_var_year ! pre-industrial VAR, -"-
-!$OMP THREADPRIVATE(var_year,pi_var_year)
-  REAL, ALLOCATABLE, DIMENSION(:,:,:),SAVE     :: var_day     ! VAR interpolated to the actual day and model grid
-  REAL, ALLOCATABLE, DIMENSION(:,:,:),SAVE     :: pi_var_day  ! pre-industrial VAR, -"-
-!$OMP THREADPRIVATE(var_day,pi_var_day)
-  REAL, ALLOCATABLE, DIMENSION(:,:,:), SAVE    :: psurf_year, pi_psurf_year ! surface pressure for the total year
-!$OMP THREADPRIVATE(psurf_year, pi_psurf_year)
-  REAL, ALLOCATABLE, DIMENSION(:,:,:), SAVE    :: load_year, pi_load_year   ! load in the column for the total year
-!$OMP THREADPRIVATE(load_year, pi_load_year)
-
-  REAL, DIMENSION(:,:,:), POINTER   :: pt_tmp      ! Pointer allocated in readaerosol
-  REAL, POINTER, DIMENSION(:), SAVE :: pt_ap, pt_b ! Pointer for describing the vertical levels 
-!$OMP THREADPRIVATE(pt_ap, pt_b)
-  INTEGER, SAVE                     :: nbr_tsteps ! number of time steps in file read
-  REAL, DIMENSION(14), SAVE         :: month_len, month_start, month_mid
-!$OMP THREADPRIVATE(nbr_tsteps, month_len, month_start, month_mid)
-  REAL                              :: jDay
-
-  LOGICAL            :: lnewday      ! Indicates if first time step at a new day
-  LOGICAL            :: OLDNEWDAY
-  LOGICAL,SAVE       :: vert_interp  ! Indicates if vertical interpolation will be done
-  LOGICAL,SAVE       :: debug=.FALSE.! Debugging in this subroutine
-!$OMP THREADPRIVATE(vert_interp, debug)
-  CHARACTER(len=8)      :: type
-  CHARACTER(len=8)      :: filename
-
-
-!****************************************************************************************
-! Initialization
-!
-!****************************************************************************************
-
-! Calculation to find if it is a new day
-
-  IF(mpi_rank == 0 .AND. debug )then
-     PRINT*,'CONTROL PANEL REGARDING TIME STEPING'
-  ENDIF
-
-  ! Use phys_cal_mod
-  iday= day_cur
-  iyr = year_cur
-  im  = mth_cur
-
-!  iday = INT(r_day)
-!  iyr  = iday/360
-!  iday = iday-iyr*360         ! day of the actual year
-!  iyr  = iyr + annee_ref      ! year of the run   
-!  im   = iday/30 +1           ! the actual month
-  CALL ymds2ju(iyr, im, iday, 0., jDay)
-!   CALL ymds2ju(iyr, im, iday-(im-1)*30, 0., jDay)
-
-
-  IF(MOD(itap-1,NINT(86400./pdtphys)) == 0)THEN
-     lnewday=.TRUE.
-  ELSE
-     lnewday=.FALSE.
-  ENDIF
-
-  IF(mpi_rank == 0 .AND. debug)then
-     ! 0.02 is about 0.5/24, namly less than half an hour
-     OLDNEWDAY = (r_day-REAL(iday) < 0.02)
-     ! Once per day, update aerosol fields
-     lmt_pas = NINT(86400./pdtphys)
-     PRINT*,'r_day-REAL(iday) =',r_day-REAL(iday) 
-     PRINT*,'itap =',itap
-     PRINT*,'pdtphys =',pdtphys
-     PRINT*,'lmt_pas =',lmt_pas
-     PRINT*,'iday =',iday
-     PRINT*,'r_day =',r_day
-     PRINT*,'day_cur =',day_cur
-     PRINT*,'mth_cur =',mth_cur
-     PRINT*,'year_cur =',year_cur
-     PRINT*,'NINT(86400./pdtphys) =',NINT(86400./pdtphys)
-     PRINT*,'MOD(0,1) =',MOD(0,1)
-     PRINT*,'lnewday =',lnewday
-     PRINT*,'OLDNEWDAY =',OLDNEWDAY
-  ENDIF
-
-  IF (.NOT. ALLOCATED(var_day)) THEN
-     ALLOCATE( var_day(klon, klev, naero_spc), stat=ierr)
-     IF (ierr /= 0) CALL abort_physic('readaerosol_interp', 'pb in allocation 1',1)
-     ALLOCATE( pi_var_day(klon, klev, naero_spc), stat=ierr)
-     IF (ierr /= 0) CALL abort_physic('readaerosol_interp', 'pb in allocation 2',1)
-
-     ALLOCATE( psurf_year(klon, 12, naero_spc), pi_psurf_year(klon, 12, naero_spc), stat=ierr)
-     IF (ierr /= 0) CALL abort_physic('readaerosol_interp', 'pb in allocation 3',1)
-
-     ALLOCATE( load_year(klon, 12, naero_spc), pi_load_year(klon, 12, naero_spc), stat=ierr)
-     IF (ierr /= 0) CALL abort_physic('readaerosol_interp', 'pb in allocation 4',1)
-
-     lnewday=.TRUE.
-
-     NULLIFY(pt_ap)
-     NULLIFY(pt_b)
-  ENDIF
-
-!****************************************************************************************
-! 1) Read in data : corresponding to the actual year and preindustrial data. 
-!    Only for the first day of the year.
-!
-!****************************************************************************************
-  IF ( (first .OR. iday==0) .AND. lnewday ) THEN 
-     NULLIFY(pt_tmp)
-
-     ! Reading values corresponding to the closest year taking into count the choice of aer_type. 
-     ! For aer_type=scenario interpolation between 2 data sets is done in readaerosol.
-     ! If aer_type=mix1, mix2 or mix3, the run type and file name depends on the aerosol.
-     IF (aer_type=='preind' .OR. aer_type=='actuel' .OR. aer_type=='annuel' .OR. aer_type=='scenario') THEN
-        ! Standard case
-        filename='aerosols'
-        type=aer_type
-     ELSE IF (aer_type == 'mix1') THEN
-        ! Special case using a mix of decenal sulfate file and annual aerosols(all aerosols except sulfate)
-        IF (name_aero(id_aero) == 'SO4') THEN
-           filename='so4.run '
-           type='scenario'
-        ELSE
-           filename='aerosols'
-           type='annuel'
-        ENDIF
-     ELSE  IF (aer_type == 'mix2') THEN
-        ! Special case using a mix of decenal sulfate file and natrual aerosols
-        IF (name_aero(id_aero) == 'SO4') THEN
-           filename='so4.run '
-           type='scenario'
-        ELSE
-           filename='aerosols'
-           type='preind'
-        ENDIF
-     ELSE  IF (aer_type == 'mix3') THEN
-        ! Special case using a mix of annual sulfate file and natrual aerosols
-        IF (name_aero(id_aero) == 'SO4') THEN
-           filename='aerosols'
-           type='annuel'
-        ELSE
-           filename='aerosols' 
-           type='preind'
-        ENDIF
-     ELSE
-        CALL abort_physic('readaerosol_interp', 'this aer_type not supported',1)
-     ENDIF
-
-     CALL readaerosol(name_aero(id_aero), type, filename, iyr, klev_src, pt_ap, pt_b, pt_tmp, &
-          psurf_year(:,:,id_aero), load_year(:,:,id_aero))
-     IF (.NOT. ALLOCATED(var_year)) THEN
-        ALLOCATE(var_year(klon, klev_src, 12, naero_spc), stat=ierr)
-        IF (ierr /= 0) CALL abort_physic('readaerosol_interp', 'pb in allocation 5',1)
-     ENDIF
-     var_year(:,:,:,id_aero) = pt_tmp(:,:,:)
-
-     ! Reading values corresponding to the preindustrial concentrations.
-     type='preind'
-     CALL readaerosol(name_aero(id_aero), type, filename, iyr, pi_klev_src, pt_ap, pt_b, pt_tmp, &
-          pi_psurf_year(:,:,id_aero), pi_load_year(:,:,id_aero))
-
-     ! klev_src must be the same in both files. 
-     ! Also supposing pt_ap and pt_b to be the same in the 2 files without testing. 
-     IF (pi_klev_src /= klev_src) THEN
-        WRITE(lunout,*) 'Error! All forcing files for the same aerosol must have the same vertical dimension'
-        WRITE(lunout,*) 'Aerosol : ', name_aero(id_aero)
-        CALL abort_physic('readaerosol_interp','Differnt vertical axes in aerosol forcing files',1)
-     ENDIF
-
-     IF (.NOT. ALLOCATED(pi_var_year)) THEN
-        ALLOCATE(pi_var_year(klon, klev_src, 12, naero_spc), stat=ierr)
-        IF (ierr /= 0) CALL abort_physic('readaerosol_interp', 'pb in allocation 6',1)
-     ENDIF
-     pi_var_year(:,:,:,id_aero) = pt_tmp(:,:,:)
-    
-     IF (debug) THEN
-        CALL writefield_phy('var_year_jan',var_year(:,:,1,id_aero),klev_src)
-        CALL writefield_phy('var_year_dec',var_year(:,:,12,id_aero),klev_src)
-        CALL writefield_phy('psurf_src',psurf_year(:,:,id_aero),1)
-        CALL writefield_phy('pi_psurf_src',pi_psurf_year(:,:,id_aero),1)
-        CALL writefield_phy('load_year_src',load_year(:,:,id_aero),1)
-        CALL writefield_phy('pi_load_year_src',pi_load_year(:,:,id_aero),1)
-     ENDIF
-
-     ! Pointer no more useful, deallocate. 
-     DEALLOCATE(pt_tmp)
-
-     ! Test if vertical interpolation will be needed.
-     IF (psurf_year(1,1,id_aero)==not_valid .OR. pi_psurf_year(1,1,id_aero)==not_valid ) THEN
-        ! Pressure=not_valid indicates old file format, see module readaerosol
-        vert_interp = .FALSE.
-
-        ! If old file format, both psurf_year and pi_psurf_year must be not_valid
-        IF (  psurf_year(1,1,id_aero) /= pi_psurf_year(1,1,id_aero) ) THEN
-           WRITE(lunout,*) 'Warning! All forcing files for the same aerosol must have the same structure'
-           CALL abort_physic('readaerosol_interp', 'The aerosol files have not the same format',1)
-        ENDIF
-        
-        IF (klev /= klev_src) THEN
-           WRITE(lunout,*) 'Old format of aerosol file do not allowed vertical interpolation'
-           CALL abort_physic('readaerosol_interp', 'Old aerosol file not possible',1)
-        ENDIF
-
-     ELSE 
-        vert_interp = .TRUE.
-     ENDIF
-
-!    Calendar initialisation
-!
-     DO i = 2, 13
-       month_len(i) = REAL(ioget_mon_len(year_cur, i-1))
-       CALL ymds2ju(year_cur, i-1, 1, 0.0, month_start(i))
-     ENDDO
-     month_len(1) = REAL(ioget_mon_len(year_cur-1, 12))
-     CALL ymds2ju(year_cur-1, 12, 1, 0.0, month_start(1))
-     month_len(14) = REAL(ioget_mon_len(year_cur+1, 1))
-     CALL ymds2ju(year_cur+1, 1, 1, 0.0, month_start(14))
-     month_mid(:) = month_start (:) + month_len(:)/2.
-     
-     if (debug) then
-       write(lunout,*)' month_len = ',month_len
-       write(lunout,*)' month_mid = ',month_mid
-     endif
-
-  ENDIF  ! IF ( (first .OR. iday==0) .AND. lnewday ) THEN 
-  
-!****************************************************************************************
-! - 2) Interpolate to the actual day.
-! - 3) Interpolate to the model vertical grid.
-!
-!****************************************************************************************
-
-  IF (lnewday) THEN ! only if new day
-!****************************************************************************************
-! 2) Interpolate to the actual day
-! 
-!****************************************************************************************
-    ! Find which months and days to use for time interpolation
-     nbr_tsteps = 12
-     IF (nbr_tsteps == 12) then
-       IF (jDay < month_mid(im+1)) THEN
-          im2=im-1
-          day2 = month_mid(im2+1)
-          day1 = month_mid(im+1)
-          IF (im2 <= 0) THEN
-             ! the month is january, thus the month before december
-             im2=12
-          ENDIF
-       ELSE
-          ! the second half of the month
-          im2=im+1
-          day1 = month_mid(im+1)
-          day2 = month_mid(im2+1)
-          IF (im2 > 12) THEN
-             ! the month is december, the following thus january
-             im2=1
-          ENDIF
-       ENDIF
-     ELSE IF (nbr_tsteps == 14) then
-       im = im + 1
-       IF (jDay < month_mid(im)) THEN
-          ! in the first half of the month use month before and actual month
-          im2=im-1
-          day2 = month_mid(im2)
-          day1 = month_mid(im)
-       ELSE
-          ! the second half of the month
-          im2=im+1
-          day1 = month_mid(im)
-          day2 = month_mid(im2)
-       ENDIF
-     ELSE
-       CALL abort_physic('readaerosol_interp', 'number of months undefined',1)
-     ENDIF
-     if (debug) then
-       write(lunout,*)' jDay, day1, day2, im, im2 = ', jDay, day1, day2, im, im2
-     endif
-
- 
-     ! Time interpolation, still on vertical source grid
-     ALLOCATE(tmp1(klon,klev_src), tmp2(klon,klev_src),stat=ierr)
-     IF (ierr /= 0) CALL abort_physic('readaerosol_interp', 'pb in allocation 7',1)
-
-     ALLOCATE(pplay_src(klon,klev_src), stat=ierr)
-     IF (ierr /= 0) CALL abort_physic('readaerosol_interp', 'pb in allocation 8',1)
-     
-
-     DO k=1,klev_src
-        DO i=1,klon 
-           tmp1(i,k) = &
-                var_year(i,k,im2,id_aero) - (jDay-day2)/(day1-day2) * &
-                (var_year(i,k,im2,id_aero) - var_year(i,k,im,id_aero))
-           
-           tmp2(i,k) = &
-                pi_var_year(i,k,im2,id_aero) - (jDay-day2)/(day1-day2) * &
-                (pi_var_year(i,k,im2,id_aero) - pi_var_year(i,k,im,id_aero))
-        ENDDO
-     ENDDO
-
-     ! Time interpolation for pressure at surface, still on vertical source grid
-     DO i=1,klon 
-        psurf_day(i) = &
-             psurf_year(i,im2,id_aero) - (jDay-day2)/(day1-day2) * &
-             (psurf_year(i,im2,id_aero) - psurf_year(i,im,id_aero))
-        
-        pi_psurf_day(i) = &
-             pi_psurf_year(i,im2,id_aero) - (jDay-day2)/(day1-day2) * &
-             (pi_psurf_year(i,im2,id_aero) - pi_psurf_year(i,im,id_aero))
-     ENDDO
-
-     ! Time interpolation for the load, still on vertical source grid
-     DO i=1,klon 
-        load_src(i) = &
-             load_year(i,im2,id_aero) - (jDay-day2)/(day1-day2) * &
-             (load_year(i,im2,id_aero) - load_year(i,im,id_aero))
-        
-        pi_load_src(i) = &
-             pi_load_year(i,im2,id_aero) - (jDay-day2)/(day1-day2) * &
-             (pi_load_year(i,im2,id_aero) - pi_load_year(i,im,id_aero))
-     ENDDO
-
-!****************************************************************************************
-! 3) Interpolate to the model vertical grid (target grid)
-!
-!****************************************************************************************
-
-     IF (vert_interp) THEN
-
-        ! - Interpolate variable tmp1 (on source grid) to var_day (on target grid)
-        !********************************************************************************
-        ! a) calculate pression at vertical levels for the source grid using the
-        !    hybrid-sigma coordinates ap and b and the surface pressure, variables from file.
-        DO k = 1, klev_src
-           DO i = 1, klon
-              pplay_src(i,k)= pt_ap(k) + pt_b(k)*psurf_day(i)
-           ENDDO
-        ENDDO
-        
-        IF (debug) THEN
-           CALL writefield_phy('psurf_day_src',psurf_day(:),1)
-           CALL writefield_phy('pplay_src',pplay_src(:,:),klev_src)
-           CALL writefield_phy('pplay',pplay(:,:),klev)
-           CALL writefield_phy('day_src',tmp1,klev_src)
-           CALL writefield_phy('pi_day_src',tmp2,klev_src)
-        ENDIF
-
-        ! b) vertical interpolation on pressure leveles
-        CALL pres2lev(tmp1(:,:), var_day(:,:,id_aero), klev_src, klev, pplay_src, pplay, &
-             1, klon, .FALSE.)
-        
-        IF (debug) CALL writefield_phy('day_tgt',var_day(:,:,id_aero),klev)
-        
-        ! c) adjust to conserve total aerosol mass load in the vertical pillar
-        !    Calculate the load in the actual pillar and compare with the load
-        !    read from aerosol file.
-        
-        ! Find the pressure difference in each model layer
-        DO k = 1, klev
-           DO i = 1, klon
-              delp(i,k) = paprs(i,k) - paprs (i,k+1)
-           ENDDO
-        ENDDO
-
-        ! Find the mass load in the actual pillar, on target grid
-        load_tgt(:) = 0.
-        DO k= 1, klev
-           DO i = 1, klon
-              zrho = pplay(i,k)/t_seri(i,k)/RD       ! [kg/m3]
-              volm = var_day(i,k,id_aero)*1.E-9/zrho ! [kg/kg]
-              load_tgt(i) = load_tgt(i) + volm *delp(i,k)/RG
-           ENDDO
-        ENDDO
-        
-        ! Adjust, uniform
-        DO k = 1, klev
-           DO i = 1, klon
-              var_day(i,k,id_aero) = var_day(i,k,id_aero)*load_src(i)/max(1.e-30,load_tgt(i))
-           ENDDO
-        ENDDO
-        
-        IF (debug) THEN
-           load_tgt_test(:) = 0.
-           DO k= 1, klev
-              DO i = 1, klon
-                 zrho = pplay(i,k)/t_seri(i,k)/RD       ! [kg/m3]
-                 volm = var_day(i,k,id_aero)*1.E-9/zrho ! [kg/kg]
-                 load_tgt_test(i) = load_tgt_test(i) + volm*delp(i,k)/RG
-              ENDDO
-           ENDDO
-           
-           CALL writefield_phy('day_tgt2',var_day(:,:,id_aero),klev)
-           CALL writefield_phy('load_tgt',load_tgt(:),1)
-           CALL writefield_phy('load_tgt_test',load_tgt_test(:),1)
-           CALL writefield_phy('load_src',load_src(:),1)
-        ENDIF
-
-        ! - Interpolate variable tmp2 (source grid) to pi_var_day (target grid)
-        !********************************************************************************
-        ! a) calculate pression at vertical levels at source grid    
-        DO k = 1, klev_src
-           DO i = 1, klon
-              pplay_src(i,k)= pt_ap(k) + pt_b(k)*pi_psurf_day(i)
-           ENDDO
-        ENDDO
-
-        IF (debug) THEN
-           CALL writefield_phy('pi_psurf_day_src',pi_psurf_day(:),1)
-           CALL writefield_phy('pi_pplay_src',pplay_src(:,:),klev_src)
-        ENDIF
-
-        ! b) vertical interpolation on pressure leveles
-        CALL pres2lev(tmp2(:,:), pi_var_day(:,:,id_aero), klev_src, klev, pplay_src, pplay, &
-             1, klon, .FALSE.)
-
-        IF (debug) CALL writefield_phy('pi_day_tgt',pi_var_day(:,:,id_aero),klev)
-
-        ! c) adjust to conserve total aerosol mass load in the vertical pillar
-        !    Calculate the load in the actual pillar and compare with the load
-        !    read from aerosol file.
-
-        ! Find the load in the actual pillar, on target grid
-        load_tgt(:) = 0.
-        DO k = 1, klev
-           DO i = 1, klon
-              zrho = pplay(i,k)/t_seri(i,k)/RD          ! [kg/m3]
-              volm = pi_var_day(i,k,id_aero)*1.E-9/zrho ! [kg/kg]
-              load_tgt(i) = load_tgt(i) + volm*delp(i,k)/RG
-           ENDDO
-        ENDDO
-
-        DO k = 1, klev
-           DO i = 1, klon
-              pi_var_day(i,k,id_aero) = pi_var_day(i,k,id_aero)*pi_load_src(i)/max(1.e-30,load_tgt(i))
-           ENDDO
-        ENDDO
-
-        IF (debug) THEN
-           load_tgt_test(:) = 0.
-           DO k = 1, klev
-              DO i = 1, klon
-                 zrho = pplay(i,k)/t_seri(i,k)/RD          ! [kg/m3]
-                 volm = pi_var_day(i,k,id_aero)*1.E-9/zrho ! [kg/kg]
-                 load_tgt_test(i) = load_tgt_test(i) + volm*delp(i,k)/RG
-              ENDDO
-           ENDDO
-           CALL writefield_phy('pi_day_tgt2',pi_var_day(:,:,id_aero),klev)
-           CALL writefield_phy('pi_load_tgt',load_tgt(:),1)
-           CALL writefield_phy('pi_load_tgt_test',load_tgt_test(:),1)
-           CALL writefield_phy('pi_load_src',pi_load_src(:),1)
-        ENDIF
-
-
-     ELSE   ! No vertical interpolation done
-
-        var_day(:,:,id_aero)    = tmp1(:,:)
-        pi_var_day(:,:,id_aero) = tmp2(:,:)
-
-     ENDIF ! vert_interp
-
-
-     ! Deallocation
-     DEALLOCATE(tmp1, tmp2, pplay_src, stat=ierr)
-
-!****************************************************************************************
-! 4) Test for negative mass values
-!
-!****************************************************************************************
-     IF (MINVAL(var_day(:,:,id_aero)) < 0.) THEN
-        DO k=1,klev
-           DO i=1,klon 
-              ! Test for var_day
-              IF (var_day(i,k,id_aero) < 0.) THEN
-                 IF (jDay-day2 < 0.) WRITE(lunout,*) 'jDay-day2=',jDay-day2
-                 IF (var_year(i,k,im2,id_aero) - var_year(i,k,im,id_aero) < 0.) THEN
-                    WRITE(lunout,*) trim(name_aero(id_aero)),'(i,k,im2)-', &
-                         trim(name_aero(id_aero)),'(i,k,im)=',           &
-                         var_year(i,k,im2,id_aero) - var_year(i,k,im,id_aero)
-                 ENDIF
-                 WRITE(lunout,*) 'stop for aerosol : ',name_aero(id_aero)
-                 WRITE(lunout,*) 'day1, day2, jDay = ', day1, day2, jDay 
-                 CALL abort_physic('readaerosol_interp','Error in interpolation 1',1)
-              ENDIF
-           ENDDO 
-        ENDDO
-     ENDIF
-
-     IF (MINVAL(pi_var_day(:,:,id_aero)) < 0. ) THEN
-        DO k=1, klev
-           DO i=1,klon
-              ! Test for pi_var_day
-              IF (pi_var_day(i,k,id_aero) < 0.) THEN
-                 IF (jDay-day2 < 0.) WRITE(lunout,*) 'jDay-day2=',jDay-day2
-                 IF (pi_var_year(i,k,im2,id_aero) - pi_var_year(i,k,im,id_aero) < 0.) THEN
-                    WRITE(lunout,*) trim(name_aero(id_aero)),'(i,k,im2)-', &
-                         trim(name_aero(id_aero)),'(i,k,im)=',           &
-                         pi_var_year(i,k,im2,id_aero) - pi_var_year(i,k,im,id_aero)
-                 ENDIF
-                 
-                 WRITE(lunout,*) 'stop for aerosol : ',name_aero(id_aero)
-                 CALL abort_physic('readaerosol_interp','Error in interpolation 2',1)
-              ENDIF
-           ENDDO
-        ENDDO
-     ENDIF
-
-  ENDIF ! lnewday
-
-!****************************************************************************************
-! Copy output from saved variables
-!
-!****************************************************************************************
-
-  mass_out(:,:)    = var_day(:,:,id_aero) 
-  pi_mass_out(:,:) = pi_var_day(:,:,id_aero)
-  
-END SUBROUTINE readaerosol_interp
Index: /LMDZ6/trunk/libf/phylmd/readaerosol_interp.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/readaerosol_interp.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/readaerosol_interp.f90	(revision 5268)
@@ -0,0 +1,579 @@
+! $Id$
+!
+SUBROUTINE readaerosol_interp(id_aero, itap, pdtphys, r_day, first, pplay, paprs, t_seri, mass_out, pi_mass_out, load_src)
+!
+! This routine will return the mass concentration at actual day(mass_out) and 
+! the pre-industrial values(pi_mass_out) for aerosol corresponding to "id_aero".
+! The mass concentrations for all aerosols are saved in this routine but each
+! call to this routine only treats the aerosol "id_aero".
+!
+! 1) Read in data for the whole year, only at first time step
+! 2) Interpolate to the actual day, only at new day
+! 3) Interpolate to the model vertical grid (target grid), only at new day
+! 4) Test for negative mass values
+
+  USE ioipsl
+  USE dimphy, ONLY : klev,klon
+  USE mod_phys_lmdz_para, ONLY : mpi_rank  
+  USE readaerosol_mod
+  USE aero_mod, ONLY : naero_spc, name_aero
+  USE write_field_phy
+  USE phys_cal_mod
+  USE pres2lev_mod
+  USE print_control_mod, ONLY: lunout
+
+  IMPLICIT NONE
+
+  INCLUDE "YOMCST.h"
+  INCLUDE "chem.h"      
+  INCLUDE "clesphys.h"
+
+!
+! Input:
+!****************************************************************************************
+  INTEGER, INTENT(IN)                    :: id_aero! Identity number for the aerosol to treat
+  INTEGER, INTENT(IN)                    :: itap   ! Physic step count
+  REAL, INTENT(IN)                       :: pdtphys! Physic day step
+  REAL, INTENT(IN)                       :: r_day  ! Day of integration
+  LOGICAL, INTENT(IN)                    :: first  ! First model timestep 
+  REAL, DIMENSION(klon,klev), INTENT(IN) :: pplay  ! pression at model mid-layers
+  REAL, DIMENSION(klon,klev+1),INTENT(IN):: paprs  ! pression between model layers
+  REAL, DIMENSION(klon,klev), INTENT(IN) :: t_seri ! air temperature
+!      
+! Output:      
+!****************************************************************************************
+  REAL, INTENT(OUT) :: mass_out(klon,klev)    ! Mass of aerosol (monthly mean data,from file) [ug AIBCM/m3]
+  REAL, INTENT(OUT) :: pi_mass_out(klon,klev) ! Mass of preindustrial aerosol (monthly mean data,from file) [ug AIBCM/m3]
+  REAL, INTENT(OUT) :: load_src(klon) ! Load of aerosol (monthly mean data,from file) [kg/m3]
+!      
+! Local Variables:
+!****************************************************************************************
+  INTEGER                         :: i, k, ierr
+  INTEGER                         :: iday, iyr, lmt_pas
+!  INTEGER                         :: im, day1, day2, im2
+  INTEGER                         :: im, im2
+  REAL                            :: day1, day2
+  INTEGER                         :: pi_klev_src ! Only for testing purpose
+  INTEGER, SAVE                   :: klev_src    ! Number of vertical levles in source field
+!$OMP THREADPRIVATE(klev_src)
+
+  REAL                              :: zrho      ! Air density [kg/m3]
+  REAL                              :: volm      ! Volyme de melange [kg/kg]
+  REAL, DIMENSION(klon)             :: psurf_day, pi_psurf_day
+  REAL, DIMENSION(klon)             :: pi_load_src  ! Mass load at source grid
+  REAL, DIMENSION(klon)             :: load_tgt, load_tgt_test
+  REAL, DIMENSION(klon,klev)        :: delp ! pressure difference in each model layer
+
+  REAL, ALLOCATABLE, DIMENSION(:,:)            :: pplay_src ! pression mid-layer at source levels
+  REAL, ALLOCATABLE, DIMENSION(:,:)            :: tmp1, tmp2  ! Temporary variables
+  REAL, ALLOCATABLE, DIMENSION(:,:,:,:), SAVE  :: var_year    ! VAR in right dimension for the total year
+  REAL, ALLOCATABLE, DIMENSION(:,:,:,:), SAVE  :: pi_var_year ! pre-industrial VAR, -"-
+!$OMP THREADPRIVATE(var_year,pi_var_year)
+  REAL, ALLOCATABLE, DIMENSION(:,:,:),SAVE     :: var_day     ! VAR interpolated to the actual day and model grid
+  REAL, ALLOCATABLE, DIMENSION(:,:,:),SAVE     :: pi_var_day  ! pre-industrial VAR, -"-
+!$OMP THREADPRIVATE(var_day,pi_var_day)
+  REAL, ALLOCATABLE, DIMENSION(:,:,:), SAVE    :: psurf_year, pi_psurf_year ! surface pressure for the total year
+!$OMP THREADPRIVATE(psurf_year, pi_psurf_year)
+  REAL, ALLOCATABLE, DIMENSION(:,:,:), SAVE    :: load_year, pi_load_year   ! load in the column for the total year
+!$OMP THREADPRIVATE(load_year, pi_load_year)
+
+  REAL, DIMENSION(:,:,:), POINTER   :: pt_tmp      ! Pointer allocated in readaerosol
+  REAL, POINTER, DIMENSION(:), SAVE :: pt_ap, pt_b ! Pointer for describing the vertical levels 
+!$OMP THREADPRIVATE(pt_ap, pt_b)
+  INTEGER, SAVE                     :: nbr_tsteps ! number of time steps in file read
+  REAL, DIMENSION(14), SAVE         :: month_len, month_start, month_mid
+!$OMP THREADPRIVATE(nbr_tsteps, month_len, month_start, month_mid)
+  REAL                              :: jDay
+
+  LOGICAL            :: lnewday      ! Indicates if first time step at a new day
+  LOGICAL            :: OLDNEWDAY
+  LOGICAL,SAVE       :: vert_interp  ! Indicates if vertical interpolation will be done
+  LOGICAL,SAVE       :: debug=.FALSE.! Debugging in this subroutine
+!$OMP THREADPRIVATE(vert_interp, debug)
+  CHARACTER(len=8)      :: type
+  CHARACTER(len=8)      :: filename
+
+
+!****************************************************************************************
+! Initialization
+!
+!****************************************************************************************
+
+! Calculation to find if it is a new day
+
+  IF(mpi_rank == 0 .AND. debug )then
+     PRINT*,'CONTROL PANEL REGARDING TIME STEPING'
+  ENDIF
+
+  ! Use phys_cal_mod
+  iday= day_cur
+  iyr = year_cur
+  im  = mth_cur
+
+!  iday = INT(r_day)
+!  iyr  = iday/360
+!  iday = iday-iyr*360         ! day of the actual year
+!  iyr  = iyr + annee_ref      ! year of the run   
+!  im   = iday/30 +1           ! the actual month
+  CALL ymds2ju(iyr, im, iday, 0., jDay)
+!   CALL ymds2ju(iyr, im, iday-(im-1)*30, 0., jDay)
+
+
+  IF(MOD(itap-1,NINT(86400./pdtphys)) == 0)THEN
+     lnewday=.TRUE.
+  ELSE
+     lnewday=.FALSE.
+  ENDIF
+
+  IF(mpi_rank == 0 .AND. debug)then
+     ! 0.02 is about 0.5/24, namly less than half an hour
+     OLDNEWDAY = (r_day-REAL(iday) < 0.02)
+     ! Once per day, update aerosol fields
+     lmt_pas = NINT(86400./pdtphys)
+     PRINT*,'r_day-REAL(iday) =',r_day-REAL(iday) 
+     PRINT*,'itap =',itap
+     PRINT*,'pdtphys =',pdtphys
+     PRINT*,'lmt_pas =',lmt_pas
+     PRINT*,'iday =',iday
+     PRINT*,'r_day =',r_day
+     PRINT*,'day_cur =',day_cur
+     PRINT*,'mth_cur =',mth_cur
+     PRINT*,'year_cur =',year_cur
+     PRINT*,'NINT(86400./pdtphys) =',NINT(86400./pdtphys)
+     PRINT*,'MOD(0,1) =',MOD(0,1)
+     PRINT*,'lnewday =',lnewday
+     PRINT*,'OLDNEWDAY =',OLDNEWDAY
+  ENDIF
+
+  IF (.NOT. ALLOCATED(var_day)) THEN
+     ALLOCATE( var_day(klon, klev, naero_spc), stat=ierr)
+     IF (ierr /= 0) CALL abort_physic('readaerosol_interp', 'pb in allocation 1',1)
+     ALLOCATE( pi_var_day(klon, klev, naero_spc), stat=ierr)
+     IF (ierr /= 0) CALL abort_physic('readaerosol_interp', 'pb in allocation 2',1)
+
+     ALLOCATE( psurf_year(klon, 12, naero_spc), pi_psurf_year(klon, 12, naero_spc), stat=ierr)
+     IF (ierr /= 0) CALL abort_physic('readaerosol_interp', 'pb in allocation 3',1)
+
+     ALLOCATE( load_year(klon, 12, naero_spc), pi_load_year(klon, 12, naero_spc), stat=ierr)
+     IF (ierr /= 0) CALL abort_physic('readaerosol_interp', 'pb in allocation 4',1)
+
+     lnewday=.TRUE.
+
+     NULLIFY(pt_ap)
+     NULLIFY(pt_b)
+  ENDIF
+
+!****************************************************************************************
+! 1) Read in data : corresponding to the actual year and preindustrial data. 
+!    Only for the first day of the year.
+!
+!****************************************************************************************
+  IF ( (first .OR. iday==0) .AND. lnewday ) THEN 
+     NULLIFY(pt_tmp)
+
+     ! Reading values corresponding to the closest year taking into count the choice of aer_type. 
+     ! For aer_type=scenario interpolation between 2 data sets is done in readaerosol.
+     ! If aer_type=mix1, mix2 or mix3, the run type and file name depends on the aerosol.
+     IF (aer_type=='preind' .OR. aer_type=='actuel' .OR. aer_type=='annuel' .OR. aer_type=='scenario') THEN
+        ! Standard case
+        filename='aerosols'
+        type=aer_type
+     ELSE IF (aer_type == 'mix1') THEN
+        ! Special case using a mix of decenal sulfate file and annual aerosols(all aerosols except sulfate)
+        IF (name_aero(id_aero) == 'SO4') THEN
+           filename='so4.run '
+           type='scenario'
+        ELSE
+           filename='aerosols'
+           type='annuel'
+        ENDIF
+     ELSE  IF (aer_type == 'mix2') THEN
+        ! Special case using a mix of decenal sulfate file and natrual aerosols
+        IF (name_aero(id_aero) == 'SO4') THEN
+           filename='so4.run '
+           type='scenario'
+        ELSE
+           filename='aerosols'
+           type='preind'
+        ENDIF
+     ELSE  IF (aer_type == 'mix3') THEN
+        ! Special case using a mix of annual sulfate file and natrual aerosols
+        IF (name_aero(id_aero) == 'SO4') THEN
+           filename='aerosols'
+           type='annuel'
+        ELSE
+           filename='aerosols' 
+           type='preind'
+        ENDIF
+     ELSE
+        CALL abort_physic('readaerosol_interp', 'this aer_type not supported',1)
+     ENDIF
+
+     CALL readaerosol(name_aero(id_aero), type, filename, iyr, klev_src, pt_ap, pt_b, pt_tmp, &
+          psurf_year(:,:,id_aero), load_year(:,:,id_aero))
+     IF (.NOT. ALLOCATED(var_year)) THEN
+        ALLOCATE(var_year(klon, klev_src, 12, naero_spc), stat=ierr)
+        IF (ierr /= 0) CALL abort_physic('readaerosol_interp', 'pb in allocation 5',1)
+     ENDIF
+     var_year(:,:,:,id_aero) = pt_tmp(:,:,:)
+
+     ! Reading values corresponding to the preindustrial concentrations.
+     type='preind'
+     CALL readaerosol(name_aero(id_aero), type, filename, iyr, pi_klev_src, pt_ap, pt_b, pt_tmp, &
+          pi_psurf_year(:,:,id_aero), pi_load_year(:,:,id_aero))
+
+     ! klev_src must be the same in both files. 
+     ! Also supposing pt_ap and pt_b to be the same in the 2 files without testing. 
+     IF (pi_klev_src /= klev_src) THEN
+        WRITE(lunout,*) 'Error! All forcing files for the same aerosol must have the same vertical dimension'
+        WRITE(lunout,*) 'Aerosol : ', name_aero(id_aero)
+        CALL abort_physic('readaerosol_interp','Differnt vertical axes in aerosol forcing files',1)
+     ENDIF
+
+     IF (.NOT. ALLOCATED(pi_var_year)) THEN
+        ALLOCATE(pi_var_year(klon, klev_src, 12, naero_spc), stat=ierr)
+        IF (ierr /= 0) CALL abort_physic('readaerosol_interp', 'pb in allocation 6',1)
+     ENDIF
+     pi_var_year(:,:,:,id_aero) = pt_tmp(:,:,:)
+    
+     IF (debug) THEN
+        CALL writefield_phy('var_year_jan',var_year(:,:,1,id_aero),klev_src)
+        CALL writefield_phy('var_year_dec',var_year(:,:,12,id_aero),klev_src)
+        CALL writefield_phy('psurf_src',psurf_year(:,:,id_aero),1)
+        CALL writefield_phy('pi_psurf_src',pi_psurf_year(:,:,id_aero),1)
+        CALL writefield_phy('load_year_src',load_year(:,:,id_aero),1)
+        CALL writefield_phy('pi_load_year_src',pi_load_year(:,:,id_aero),1)
+     ENDIF
+
+     ! Pointer no more useful, deallocate. 
+     DEALLOCATE(pt_tmp)
+
+     ! Test if vertical interpolation will be needed.
+     IF (psurf_year(1,1,id_aero)==not_valid .OR. pi_psurf_year(1,1,id_aero)==not_valid ) THEN
+        ! Pressure=not_valid indicates old file format, see module readaerosol
+        vert_interp = .FALSE.
+
+        ! If old file format, both psurf_year and pi_psurf_year must be not_valid
+        IF (  psurf_year(1,1,id_aero) /= pi_psurf_year(1,1,id_aero) ) THEN
+           WRITE(lunout,*) 'Warning! All forcing files for the same aerosol must have the same structure'
+           CALL abort_physic('readaerosol_interp', 'The aerosol files have not the same format',1)
+        ENDIF
+        
+        IF (klev /= klev_src) THEN
+           WRITE(lunout,*) 'Old format of aerosol file do not allowed vertical interpolation'
+           CALL abort_physic('readaerosol_interp', 'Old aerosol file not possible',1)
+        ENDIF
+
+     ELSE 
+        vert_interp = .TRUE.
+     ENDIF
+
+!    Calendar initialisation
+!
+     DO i = 2, 13
+       month_len(i) = REAL(ioget_mon_len(year_cur, i-1))
+       CALL ymds2ju(year_cur, i-1, 1, 0.0, month_start(i))
+     ENDDO
+     month_len(1) = REAL(ioget_mon_len(year_cur-1, 12))
+     CALL ymds2ju(year_cur-1, 12, 1, 0.0, month_start(1))
+     month_len(14) = REAL(ioget_mon_len(year_cur+1, 1))
+     CALL ymds2ju(year_cur+1, 1, 1, 0.0, month_start(14))
+     month_mid(:) = month_start (:) + month_len(:)/2.
+     
+     if (debug) then
+       write(lunout,*)' month_len = ',month_len
+       write(lunout,*)' month_mid = ',month_mid
+     endif
+
+  ENDIF  ! IF ( (first .OR. iday==0) .AND. lnewday ) THEN 
+  
+!****************************************************************************************
+! - 2) Interpolate to the actual day.
+! - 3) Interpolate to the model vertical grid.
+!
+!****************************************************************************************
+
+  IF (lnewday) THEN ! only if new day
+!****************************************************************************************
+! 2) Interpolate to the actual day
+! 
+!****************************************************************************************
+    ! Find which months and days to use for time interpolation
+     nbr_tsteps = 12
+     IF (nbr_tsteps == 12) then
+       IF (jDay < month_mid(im+1)) THEN
+          im2=im-1
+          day2 = month_mid(im2+1)
+          day1 = month_mid(im+1)
+          IF (im2 <= 0) THEN
+             ! the month is january, thus the month before december
+             im2=12
+          ENDIF
+       ELSE
+          ! the second half of the month
+          im2=im+1
+          day1 = month_mid(im+1)
+          day2 = month_mid(im2+1)
+          IF (im2 > 12) THEN
+             ! the month is december, the following thus january
+             im2=1
+          ENDIF
+       ENDIF
+     ELSE IF (nbr_tsteps == 14) then
+       im = im + 1
+       IF (jDay < month_mid(im)) THEN
+          ! in the first half of the month use month before and actual month
+          im2=im-1
+          day2 = month_mid(im2)
+          day1 = month_mid(im)
+       ELSE
+          ! the second half of the month
+          im2=im+1
+          day1 = month_mid(im)
+          day2 = month_mid(im2)
+       ENDIF
+     ELSE
+       CALL abort_physic('readaerosol_interp', 'number of months undefined',1)
+     ENDIF
+     if (debug) then
+       write(lunout,*)' jDay, day1, day2, im, im2 = ', jDay, day1, day2, im, im2
+     endif
+
+ 
+     ! Time interpolation, still on vertical source grid
+     ALLOCATE(tmp1(klon,klev_src), tmp2(klon,klev_src),stat=ierr)
+     IF (ierr /= 0) CALL abort_physic('readaerosol_interp', 'pb in allocation 7',1)
+
+     ALLOCATE(pplay_src(klon,klev_src), stat=ierr)
+     IF (ierr /= 0) CALL abort_physic('readaerosol_interp', 'pb in allocation 8',1)
+     
+
+     DO k=1,klev_src
+        DO i=1,klon 
+           tmp1(i,k) = &
+                var_year(i,k,im2,id_aero) - (jDay-day2)/(day1-day2) * &
+                (var_year(i,k,im2,id_aero) - var_year(i,k,im,id_aero))
+           
+           tmp2(i,k) = &
+                pi_var_year(i,k,im2,id_aero) - (jDay-day2)/(day1-day2) * &
+                (pi_var_year(i,k,im2,id_aero) - pi_var_year(i,k,im,id_aero))
+        ENDDO
+     ENDDO
+
+     ! Time interpolation for pressure at surface, still on vertical source grid
+     DO i=1,klon 
+        psurf_day(i) = &
+             psurf_year(i,im2,id_aero) - (jDay-day2)/(day1-day2) * &
+             (psurf_year(i,im2,id_aero) - psurf_year(i,im,id_aero))
+        
+        pi_psurf_day(i) = &
+             pi_psurf_year(i,im2,id_aero) - (jDay-day2)/(day1-day2) * &
+             (pi_psurf_year(i,im2,id_aero) - pi_psurf_year(i,im,id_aero))
+     ENDDO
+
+     ! Time interpolation for the load, still on vertical source grid
+     DO i=1,klon 
+        load_src(i) = &
+             load_year(i,im2,id_aero) - (jDay-day2)/(day1-day2) * &
+             (load_year(i,im2,id_aero) - load_year(i,im,id_aero))
+        
+        pi_load_src(i) = &
+             pi_load_year(i,im2,id_aero) - (jDay-day2)/(day1-day2) * &
+             (pi_load_year(i,im2,id_aero) - pi_load_year(i,im,id_aero))
+     ENDDO
+
+!****************************************************************************************
+! 3) Interpolate to the model vertical grid (target grid)
+!
+!****************************************************************************************
+
+     IF (vert_interp) THEN
+
+        ! - Interpolate variable tmp1 (on source grid) to var_day (on target grid)
+        !********************************************************************************
+        ! a) calculate pression at vertical levels for the source grid using the
+        !    hybrid-sigma coordinates ap and b and the surface pressure, variables from file.
+        DO k = 1, klev_src
+           DO i = 1, klon
+              pplay_src(i,k)= pt_ap(k) + pt_b(k)*psurf_day(i)
+           ENDDO
+        ENDDO
+        
+        IF (debug) THEN
+           CALL writefield_phy('psurf_day_src',psurf_day(:),1)
+           CALL writefield_phy('pplay_src',pplay_src(:,:),klev_src)
+           CALL writefield_phy('pplay',pplay(:,:),klev)
+           CALL writefield_phy('day_src',tmp1,klev_src)
+           CALL writefield_phy('pi_day_src',tmp2,klev_src)
+        ENDIF
+
+        ! b) vertical interpolation on pressure leveles
+        CALL pres2lev(tmp1(:,:), var_day(:,:,id_aero), klev_src, klev, pplay_src, pplay, &
+             1, klon, .FALSE.)
+        
+        IF (debug) CALL writefield_phy('day_tgt',var_day(:,:,id_aero),klev)
+        
+        ! c) adjust to conserve total aerosol mass load in the vertical pillar
+        !    Calculate the load in the actual pillar and compare with the load
+        !    read from aerosol file.
+        
+        ! Find the pressure difference in each model layer
+        DO k = 1, klev
+           DO i = 1, klon
+              delp(i,k) = paprs(i,k) - paprs (i,k+1)
+           ENDDO
+        ENDDO
+
+        ! Find the mass load in the actual pillar, on target grid
+        load_tgt(:) = 0.
+        DO k= 1, klev
+           DO i = 1, klon
+              zrho = pplay(i,k)/t_seri(i,k)/RD       ! [kg/m3]
+              volm = var_day(i,k,id_aero)*1.E-9/zrho ! [kg/kg]
+              load_tgt(i) = load_tgt(i) + volm *delp(i,k)/RG
+           ENDDO
+        ENDDO
+        
+        ! Adjust, uniform
+        DO k = 1, klev
+           DO i = 1, klon
+              var_day(i,k,id_aero) = var_day(i,k,id_aero)*load_src(i)/max(1.e-30,load_tgt(i))
+           ENDDO
+        ENDDO
+        
+        IF (debug) THEN
+           load_tgt_test(:) = 0.
+           DO k= 1, klev
+              DO i = 1, klon
+                 zrho = pplay(i,k)/t_seri(i,k)/RD       ! [kg/m3]
+                 volm = var_day(i,k,id_aero)*1.E-9/zrho ! [kg/kg]
+                 load_tgt_test(i) = load_tgt_test(i) + volm*delp(i,k)/RG
+              ENDDO
+           ENDDO
+           
+           CALL writefield_phy('day_tgt2',var_day(:,:,id_aero),klev)
+           CALL writefield_phy('load_tgt',load_tgt(:),1)
+           CALL writefield_phy('load_tgt_test',load_tgt_test(:),1)
+           CALL writefield_phy('load_src',load_src(:),1)
+        ENDIF
+
+        ! - Interpolate variable tmp2 (source grid) to pi_var_day (target grid)
+        !********************************************************************************
+        ! a) calculate pression at vertical levels at source grid    
+        DO k = 1, klev_src
+           DO i = 1, klon
+              pplay_src(i,k)= pt_ap(k) + pt_b(k)*pi_psurf_day(i)
+           ENDDO
+        ENDDO
+
+        IF (debug) THEN
+           CALL writefield_phy('pi_psurf_day_src',pi_psurf_day(:),1)
+           CALL writefield_phy('pi_pplay_src',pplay_src(:,:),klev_src)
+        ENDIF
+
+        ! b) vertical interpolation on pressure leveles
+        CALL pres2lev(tmp2(:,:), pi_var_day(:,:,id_aero), klev_src, klev, pplay_src, pplay, &
+             1, klon, .FALSE.)
+
+        IF (debug) CALL writefield_phy('pi_day_tgt',pi_var_day(:,:,id_aero),klev)
+
+        ! c) adjust to conserve total aerosol mass load in the vertical pillar
+        !    Calculate the load in the actual pillar and compare with the load
+        !    read from aerosol file.
+
+        ! Find the load in the actual pillar, on target grid
+        load_tgt(:) = 0.
+        DO k = 1, klev
+           DO i = 1, klon
+              zrho = pplay(i,k)/t_seri(i,k)/RD          ! [kg/m3]
+              volm = pi_var_day(i,k,id_aero)*1.E-9/zrho ! [kg/kg]
+              load_tgt(i) = load_tgt(i) + volm*delp(i,k)/RG
+           ENDDO
+        ENDDO
+
+        DO k = 1, klev
+           DO i = 1, klon
+              pi_var_day(i,k,id_aero) = pi_var_day(i,k,id_aero)*pi_load_src(i)/max(1.e-30,load_tgt(i))
+           ENDDO
+        ENDDO
+
+        IF (debug) THEN
+           load_tgt_test(:) = 0.
+           DO k = 1, klev
+              DO i = 1, klon
+                 zrho = pplay(i,k)/t_seri(i,k)/RD          ! [kg/m3]
+                 volm = pi_var_day(i,k,id_aero)*1.E-9/zrho ! [kg/kg]
+                 load_tgt_test(i) = load_tgt_test(i) + volm*delp(i,k)/RG
+              ENDDO
+           ENDDO
+           CALL writefield_phy('pi_day_tgt2',pi_var_day(:,:,id_aero),klev)
+           CALL writefield_phy('pi_load_tgt',load_tgt(:),1)
+           CALL writefield_phy('pi_load_tgt_test',load_tgt_test(:),1)
+           CALL writefield_phy('pi_load_src',pi_load_src(:),1)
+        ENDIF
+
+
+     ELSE   ! No vertical interpolation done
+
+        var_day(:,:,id_aero)    = tmp1(:,:)
+        pi_var_day(:,:,id_aero) = tmp2(:,:)
+
+     ENDIF ! vert_interp
+
+
+     ! Deallocation
+     DEALLOCATE(tmp1, tmp2, pplay_src, stat=ierr)
+
+!****************************************************************************************
+! 4) Test for negative mass values
+!
+!****************************************************************************************
+     IF (MINVAL(var_day(:,:,id_aero)) < 0.) THEN
+        DO k=1,klev
+           DO i=1,klon 
+              ! Test for var_day
+              IF (var_day(i,k,id_aero) < 0.) THEN
+                 IF (jDay-day2 < 0.) WRITE(lunout,*) 'jDay-day2=',jDay-day2
+                 IF (var_year(i,k,im2,id_aero) - var_year(i,k,im,id_aero) < 0.) THEN
+                    WRITE(lunout,*) trim(name_aero(id_aero)),'(i,k,im2)-', &
+                         trim(name_aero(id_aero)),'(i,k,im)=',           &
+                         var_year(i,k,im2,id_aero) - var_year(i,k,im,id_aero)
+                 ENDIF
+                 WRITE(lunout,*) 'stop for aerosol : ',name_aero(id_aero)
+                 WRITE(lunout,*) 'day1, day2, jDay = ', day1, day2, jDay 
+                 CALL abort_physic('readaerosol_interp','Error in interpolation 1',1)
+              ENDIF
+           ENDDO 
+        ENDDO
+     ENDIF
+
+     IF (MINVAL(pi_var_day(:,:,id_aero)) < 0. ) THEN
+        DO k=1, klev
+           DO i=1,klon
+              ! Test for pi_var_day
+              IF (pi_var_day(i,k,id_aero) < 0.) THEN
+                 IF (jDay-day2 < 0.) WRITE(lunout,*) 'jDay-day2=',jDay-day2
+                 IF (pi_var_year(i,k,im2,id_aero) - pi_var_year(i,k,im,id_aero) < 0.) THEN
+                    WRITE(lunout,*) trim(name_aero(id_aero)),'(i,k,im2)-', &
+                         trim(name_aero(id_aero)),'(i,k,im)=',           &
+                         pi_var_year(i,k,im2,id_aero) - pi_var_year(i,k,im,id_aero)
+                 ENDIF
+                 
+                 WRITE(lunout,*) 'stop for aerosol : ',name_aero(id_aero)
+                 CALL abort_physic('readaerosol_interp','Error in interpolation 2',1)
+              ENDIF
+           ENDDO
+        ENDDO
+     ENDIF
+
+  ENDIF ! lnewday
+
+!****************************************************************************************
+! Copy output from saved variables
+!
+!****************************************************************************************
+
+  mass_out(:,:)    = var_day(:,:,id_aero) 
+  pi_mass_out(:,:) = pi_var_day(:,:,id_aero)
+  
+END SUBROUTINE readaerosol_interp
Index: DZ6/trunk/libf/phylmd/readaerosol_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/readaerosol_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,736 +1,0 @@
-! $Id: readaerosol.F90 3436 2019-01-22 16:26:21Z emillour $
-!
-MODULE readaerosol_mod
-
-  REAL, SAVE :: not_valid=-333.
-  
-  INTEGER, SAVE :: nbp_lon_src
-!$OMP THREADPRIVATE(nbp_lon_src)  
-  INTEGER, SAVE :: nbp_lat_src
-!$OMP THREADPRIVATE(nbp_lat_src)  
-  REAL, ALLOCATABLE, SAVE    :: psurf_interp(:,:)
-
-CONTAINS
-
-SUBROUTINE readaerosol(name_aero, type, filename, iyr_in, klev_src, pt_ap, pt_b, pt_out, psurf, load)
-
-!****************************************************************************************
-! This routine will read the aersosol from file. 
-!
-! Read a year data with get_aero_fromfile depending on aer_type : 
-! - actuel   : read year 1980
-! - preind   : read natural data
-! - scenario : read one or two years and do eventually linare time interpolation
-!
-! Return pointer, pt_out, to the year read or result from interpolation
-!****************************************************************************************
-  USE dimphy
-  USE print_control_mod, ONLY: lunout
-
-  IMPLICIT NONE
-
-  ! Input arguments
-  CHARACTER(len=7), INTENT(IN) :: name_aero
-  CHARACTER(len=*), INTENT(IN) :: type  ! actuel, annuel, scenario or preind
-  CHARACTER(len=8), INTENT(IN) :: filename
-  INTEGER, INTENT(IN)          :: iyr_in
-
-  ! Output
-  INTEGER, INTENT(OUT)            :: klev_src
-  REAL, POINTER, DIMENSION(:)     :: pt_ap        ! Pointer for describing the vertical levels      
-  REAL, POINTER, DIMENSION(:)     :: pt_b         ! Pointer for describing the vertical levels      
-  REAL, POINTER, DIMENSION(:,:,:) :: pt_out       ! The massvar distributions, DIMENSION(klon, klev_src, 12)
-  REAL, DIMENSION(klon,12), INTENT(OUT) :: psurf  ! Surface pression for 12 months
-  REAL, DIMENSION(klon,12), INTENT(OUT) :: load   ! Aerosol mass load in each column for 12 months
-
-  ! Local variables
-  CHARACTER(len=4)                :: cyear
-  REAL, POINTER, DIMENSION(:,:,:) :: pt_2
-  REAL, DIMENSION(klon,12)        :: psurf2, load2
-  INTEGER                         :: iyr1, iyr2, klev_src2
-  INTEGER                         :: it, k, i
-  LOGICAL, PARAMETER              :: lonlyone=.FALSE.
-
-!****************************************************************************************
-! Read data depending on aer_type
-!
-!****************************************************************************************
-
-  IF (type == 'actuel') THEN
-! Read and return data for year 1980
-!****************************************************************************************
-     cyear='1980'
-     ! get_aero_fromfile returns pt_out allocated and initialized with data for 12 month 
-     ! pt_out has dimensions (klon, klev_src, 12)
-     CALL get_aero_fromfile(name_aero, cyear, filename, klev_src, pt_ap, pt_b, pt_out, psurf, load)
-     
-
-  ELSE IF (type == 'preind') THEN
-! Read and return data from file with suffix .nat
-!****************************************************************************************     
-     cyear='.nat'
-     ! get_aero_fromfile returns pt_out allocated and initialized with data for 12 month 
-     ! pt_out has dimensions (klon, klev_src, 12)
-     CALL get_aero_fromfile(name_aero, cyear, filename, klev_src, pt_ap, pt_b, pt_out, psurf, load)
-     
-  ELSE IF (type == 'annuel') THEN
-! Read and return data from scenario annual files
-!****************************************************************************************     
-     WRITE(cyear,'(I4)') iyr_in
-     WRITE(lunout,*) 'get_aero 3 iyr_in=', iyr_in,'   ',cyear
-     ! get_aero_fromfile returns pt_out allocated and initialized with data for nbr_tsteps month 
-     ! pt_out has dimensions (klon, klev_src, 12)
-     CALL get_aero_fromfile(name_aero, cyear, filename, klev_src, pt_ap, pt_b, pt_out, psurf, load)
-     
-  ELSE IF (type == 'scenario') THEN
-! Read data depending on actual year and interpolate if necessary
-!****************************************************************************************
-     IF (iyr_in .LT. 1850) THEN
-        cyear='.nat'
-        WRITE(lunout,*) 'get_aero 1 iyr_in=', iyr_in,'   ',cyear
-        ! get_aero_fromfile returns pt_out allocated and initialized with data for 12 month 
-        ! pt_out has dimensions (klon, klev_src, 12)
-        CALL get_aero_fromfile(name_aero, cyear, filename, klev_src, pt_ap, pt_b, pt_out, psurf, load)
-        
-     ELSE IF (iyr_in .GE. 2100) THEN
-        cyear='2100'
-        WRITE(lunout,*) 'get_aero 2 iyr_in=', iyr_in,'   ',cyear
-        ! get_aero_fromfile returns pt_out allocated and initialized with data for 12 month 
-        ! pt_out has dimensions (klon, klev_src, 12)
-        CALL get_aero_fromfile(name_aero, cyear, filename, klev_src, pt_ap, pt_b, pt_out, psurf, load)
-        
-     ELSE
-        ! Read data from 2 decades and interpolate to actual year
-        ! a) from actual 10-yr-period
-        IF (iyr_in.LT.1900) THEN
-           iyr1 = 1850
-           iyr2 = 1900
-        ELSE IF (iyr_in.GE.1900.AND.iyr_in.LT.1920) THEN
-           iyr1 = 1900
-           iyr2 = 1920
-        ELSE 
-           iyr1 = INT(iyr_in/10)*10
-           iyr2 = INT(1+iyr_in/10)*10
-        ENDIF
-        
-        WRITE(cyear,'(I4)') iyr1
-        WRITE(lunout,*) 'get_aero 3 iyr_in=', iyr_in,'   ',cyear
-        ! get_aero_fromfile returns pt_out allocated and initialized with data for 12 month 
-        ! pt_out has dimensions (klon, klev_src, 12)
-        CALL get_aero_fromfile(name_aero, cyear, filename, klev_src, pt_ap, pt_b, pt_out, psurf, load)
-        
-        ! If to read two decades:
-        IF (.NOT.lonlyone) THEN 
-           
-           ! b) from the next following one
-           WRITE(cyear,'(I4)') iyr2
-           WRITE(lunout,*) 'get_aero 4 iyr_in=', iyr_in,'   ',cyear
-           
-           NULLIFY(pt_2)
-           ! get_aero_fromfile returns pt_2 allocated and initialized with data for 12 month 
-           ! pt_2 has dimensions (klon, klev_src, 12)
-           CALL get_aero_fromfile(name_aero, cyear, filename, klev_src2, pt_ap, pt_b, pt_2, psurf2, load2)
-           ! Test for same number of vertical levels
-           IF (klev_src /= klev_src2) THEN
-              WRITE(lunout,*) 'Two aerosols files with different number of vertical levels is not allowded'
-              CALL abort_physic('readaersosol','Error in number of vertical levels',1)
-           END IF
-           
-           ! Linare interpolate to the actual year:
-           DO it=1,12
-              DO k=1,klev_src
-                 DO i = 1, klon
-                    pt_out(i,k,it) = &
-                         pt_out(i,k,it) - REAL(iyr_in-iyr1)/REAL(iyr2-iyr1) * &
-                         (pt_out(i,k,it) - pt_2(i,k,it))
-                 END DO
-              END DO
-
-              DO i = 1, klon
-                 psurf(i,it) = &
-                      psurf(i,it) - REAL(iyr_in-iyr1)/REAL(iyr2-iyr1) * &
-                      (psurf(i,it) - psurf2(i,it))
-
-                 load(i,it) = &
-                      load(i,it) - REAL(iyr_in-iyr1)/REAL(iyr2-iyr1) * &
-                      (load(i,it) - load2(i,it))
-              END DO
-           END DO
-
-           ! Deallocate pt_2 no more needed
-           DEALLOCATE(pt_2)
-           
-        END IF ! lonlyone
-     END IF ! iyr_in .LT. 1850
-
-  ELSE
-     WRITE(lunout,*)'This option is not implemented : aer_type = ', type,' name_aero=',name_aero
-     CALL abort_physic('readaerosol','Error : aer_type parameter not accepted',1)
-  END IF ! type
-
-
-END SUBROUTINE readaerosol
-
-
-SUBROUTINE init_aero_fromfile(flag_aerosol, aerosol_couple)
-  USE netcdf
-  USE mod_phys_lmdz_para
-  USE mod_grid_phy_lmdz, ONLY: grid_type, unstructured
-  USE lmdz_xios
-  IMPLICIT NONE
-
-  INTEGER, INTENT(IN) :: flag_aerosol
-  LOGICAL, INTENT(IN) :: aerosol_couple
-  
-  REAL,ALLOCATABLE :: lat_src(:)
-  REAL,ALLOCATABLE :: lon_src(:)
-  CHARACTER(LEN=*),PARAMETER :: file_aerosol='aerosols.nat.nc'
-  CHARACTER(LEN=*),PARAMETER :: file_so4='so4.nat.nc'
-  INTEGER :: klev_src
-  INTEGER :: ierr ,ncid, dimID, varid
-  REAL :: null_array(0)
-
-  IF (using_xios) THEN
-    IF (flag_aerosol>0 .AND. grid_type==unstructured .AND. (.NOT. aerosol_couple) ) THEN
-  
-      IF (is_omp_root) THEN
-  
-        IF (is_mpi_root) THEN
-    
-          IF (nf90_open(TRIM(file_aerosol), NF90_NOWRITE, ncid) /= NF90_NOERR) THEN
-            CALL check_err( nf90_open(TRIM(file_so4), NF90_NOWRITE, ncid), "pb open "//trim(file_so4) )
-          ENDIF
-
-          ! Read and test longitudes
-          CALL check_err( nf90_inq_dimid(ncid, "lon", dimID),"pb inq dim lon") 
-          CALL check_err( nf90_inquire_dimension(ncid, dimID, len = nbp_lon_src),"pb inq dim lon")
-          CALL check_err( nf90_inq_varid(ncid, 'lon', varid),"pb inq lon" )
-          ALLOCATE(lon_src(nbp_lon_src))
-          CALL check_err( nf90_get_var(ncid, varid, lon_src(:)),"pb get lon" )
-
-          ! Read and test latitudes
-          CALL check_err( nf90_inq_dimid(ncid, "lat", dimID),"pb inq dim lat") 
-          CALL check_err( nf90_inquire_dimension(ncid, dimID, len = nbp_lat_src),"pb inq dim lat")
-          CALL check_err( nf90_inq_varid(ncid, 'lat', varid),"pb inq lat" )
-          ALLOCATE(lat_src(nbp_lat_src))
-          CALL check_err( nf90_get_var(ncid, varid, lat_src(:)),"pb get lat" )
-          IF (nf90_inq_dimid(ncid, 'lev', dimid) /= NF90_NOERR) THEN
-            IF (nf90_inq_dimid(ncid, 'presnivs', dimid)/= NF90_NOERR) THEN
-               CALL check_err(nf90_inq_dimid(ncid, 'PRESNIVS', dimid),'dimension lev,PRESNIVS or presnivs not in file')
-            ENDIF
-          ENDIF
-          CALL check_err( nf90_inquire_dimension(ncid, dimid, len = klev_src),"pb inq dim for PRESNIVS or lev" )
-          CALL check_err( nf90_close(ncid),"pb in close" )   
-        ENDIF
-
-        CALL bcast_mpi(nbp_lat_src)
-        CALL bcast_mpi(nbp_lon_src)
-        CALL bcast_mpi(klev_src)
-
-        IF (is_mpi_root ) THEN
-          CALL xios_set_domain_attr("domain_aerosol",nj_glo=nbp_lat_src, nj=nbp_lat_src, jbegin=0, latvalue_1d=lat_src)
-          CALL xios_set_domain_attr("domain_aerosol",ni_glo=nbp_lon_src, ni=nbp_lon_src, ibegin=0, lonvalue_1d=lon_src)
-        ELSE
-          CALL xios_set_domain_attr("domain_aerosol",nj_glo=nbp_lat_src, nj=0, jbegin=0, latvalue_1d=null_array )
-          CALL xios_set_domain_attr("domain_aerosol",ni_glo=nbp_lon_src, ni=0, ibegin=0, lonvalue_1d=null_array)
-        ENDIF
-        CALL xios_set_axis_attr("axis_aerosol",n_glo=klev_src)
-        CALL xios_set_fieldgroup_attr("aerosols", enabled=.TRUE.)
-  
-      ENDIF
-    
-    ENDIF    
-  ENDIF !using_xios 
-END SUBROUTINE init_aero_fromfile
-
-
-    
-
-  SUBROUTINE get_aero_fromfile(varname, cyr, filename, klev_src, pt_ap, pt_b, pt_year, psurf_out, load_out)
-!****************************************************************************************
-! Read 12 month aerosol from file and distribute to local process on physical grid. 
-! Vertical levels, klev_src, may differ from model levels if new file format.
-!
-! For mpi_root and master thread :
-! 1) Open file 
-! 2) Find vertical dimension klev_src
-! 3) Read field month by month
-! 4) Close file  
-! 5) Transform the global field from 2D(nbp_lon,nbp_lat) to 1D(klon_glo)
-!     - Also the levels and the latitudes have to be inversed
-!
-! For all processes and threads :
-! 6) Scatter global field(klon_glo) to local process domain(klon)
-! 7) Test for negative values
-!****************************************************************************************
-
-    USE netcdf
-    USE dimphy
-    USE mod_grid_phy_lmdz, ONLY: nbp_lon_=>nbp_lon, nbp_lat_=>nbp_lat, klon_glo, &
-                                 grid2Dto1D_glo, grid_type, unstructured
-    USE mod_phys_lmdz_para
-    USE iophy, ONLY : io_lon, io_lat
-    USE print_control_mod, ONLY: lunout
-    USE lmdz_xios
-    IMPLICIT NONE
-      
-! Input argumets
-    CHARACTER(len=7), INTENT(IN)          :: varname
-    CHARACTER(len=4), INTENT(IN)          :: cyr
-    CHARACTER(len=8), INTENT(IN)          :: filename
-
-! Output arguments
-    INTEGER, INTENT(OUT)                  :: klev_src     ! Number of vertical levels in file
-    REAL, POINTER, DIMENSION(:)           :: pt_ap        ! Pointer for describing the vertical levels      
-    REAL, POINTER, DIMENSION(:)           :: pt_b         ! Pointer for describing the vertical levels      
-    REAL, POINTER, DIMENSION(:,:,:)       :: pt_year      ! Pointer-variabale from file, 12 month, grid : klon,klev_src
-    REAL, POINTER, DIMENSION(:,:,:)       :: pt_year_mpi  ! Pointer-variabale from file, 12 month, grid : klon,klev_src
-    REAL, DIMENSION(klon,12), INTENT(OUT) :: psurf_out    ! Surface pression for 12 months
-    REAL, DIMENSION(klon_mpi,12)          :: psurf_out_mpi    ! Surface pression for 12 months
-    REAL, DIMENSION(klon,12), INTENT(OUT) :: load_out     ! Aerosol mass load in each column
-    REAL, DIMENSION(klon_mpi,12)          :: load_out_mpi     ! Aerosol mass load in each column
-    INTEGER                               :: nbr_tsteps   ! number of month in file read
-
-! Local variables
-    CHARACTER(len=30)     :: fname
-    CHARACTER(len=30)     :: cvar
-    INTEGER               :: ncid, dimid, varid
-    INTEGER               :: imth, i, j, k, ierr
-    REAL                  :: npole, spole
-    REAL, ALLOCATABLE, DIMENSION(:,:,:)   :: varmth
-    REAL, ALLOCATABLE, DIMENSION(:,:,:,:) :: varyear       ! Global variable read from file, 12 month
-    REAL, ALLOCATABLE, DIMENSION(:,:,:)   :: varyear_glo1D !(klon_glo, klev_src, 12)
-    REAL, ALLOCATABLE, DIMENSION(:)       :: varktmp
-
-    REAL,  ALLOCATABLE                    :: psurf_glo2D(:,:,:)   ! Surface pression for 12 months on dynamics global grid
-    REAL, DIMENSION(klon_glo,12)          :: psurf_glo1D   ! -"- on physical global grid
-    REAL,  ALLOCATABLE                    :: load_glo2D(:,:,:)    ! Load for 12 months on dynamics global grid
-    REAL, DIMENSION(klon_glo,12)          :: load_glo1D    ! -"- on physical global grid
-    REAL, ALLOCATABLE, DIMENSION(:,:)     :: vartmp
-    REAL, ALLOCATABLE,DIMENSION(:)        :: lon_src              ! longitudes in file
-    REAL, ALLOCATABLE,DIMENSION(:)        :: lat_src, lat_src_inv ! latitudes in file
-    LOGICAL                               :: new_file             ! true if new file format detected
-    LOGICAL                               :: invert_lat           ! true if the field has to be inverted for latitudes
-    INTEGER                               :: nbp_lon, nbp_lat
-    LOGICAL,SAVE                          :: first=.TRUE.
-!$OMP THREADPRIVATE(first)
-    
-    IF (grid_type==unstructured) THEN
-      nbp_lon=nbp_lon_src
-      nbp_lat=nbp_lat_src
-    ELSE
-      nbp_lon=nbp_lon_
-      nbp_lat=nbp_lat_
-    ENDIF
-    
-    IF (is_mpi_root) THEN
-    
-      ALLOCATE(psurf_glo2D(nbp_lon,nbp_lat,12))
-      ALLOCATE(load_glo2D(nbp_lon,nbp_lat,12))
-      ALLOCATE(vartmp(nbp_lon,nbp_lat))
-      ALLOCATE(lon_src(nbp_lon))
-      ALLOCATE(lat_src(nbp_lat))
-      ALLOCATE(lat_src_inv(nbp_lat))
-    ELSE
-      ALLOCATE(varyear(0,0,0,0))
-      ALLOCATE(psurf_glo2D(0,0,0))
-      ALLOCATE(load_glo2D(0,0,0))
-    ENDIF
-            
-    ! Deallocate pointers
-    IF (ASSOCIATED(pt_ap)) DEALLOCATE(pt_ap)
-    IF (ASSOCIATED(pt_b))  DEALLOCATE(pt_b)
-
-    IF (is_mpi_root .AND. is_omp_root) THEN
-
-! 1) Open file 
-!****************************************************************************************
-! Add suffix to filename
-       fname = trim(filename)//cyr//'.nc'
-  
-       WRITE(lunout,*) 'reading variable ',TRIM(varname),' in file ', TRIM(fname)
-       CALL check_err( nf90_open(TRIM(fname), NF90_NOWRITE, ncid), "pb open "//trim(fname) )
-
-
-       IF (grid_type/=unstructured) THEN
-
-! Test for equal longitudes and latitudes in file and model
-!****************************************************************************************
-       ! Read and test longitudes
-         CALL check_err( nf90_inq_varid(ncid, 'lon', varid),"pb inq lon" )
-         CALL check_err( nf90_get_var(ncid, varid, lon_src(:)),"pb get lon" )
-       
-         IF (maxval(ABS(lon_src - io_lon)) > 0.001) THEN
-            WRITE(lunout,*) 'Problem in longitudes read from file : ',TRIM(fname)
-            WRITE(lunout,*) 'longitudes in file ', TRIM(fname),' : ', lon_src
-            WRITE(lunout,*) 'longitudes in model :', io_lon
-          
-            CALL abort_physic('get_aero_fromfile', 'longitudes are not the same in file and model',1)
-         END IF
-
-         ! Read and test latitudes
-         CALL check_err( nf90_inq_varid(ncid, 'lat', varid),"pb inq lat" )
-         CALL check_err( nf90_get_var(ncid, varid, lat_src(:)),"pb get lat" )
-
-         ! Invert source latitudes
-         DO j = 1, nbp_lat
-            lat_src_inv(j) = lat_src(nbp_lat +1 -j)
-         END DO
-
-         IF (maxval(ABS(lat_src - io_lat)) < 0.001) THEN
-            ! Latitudes are the same
-            invert_lat=.FALSE.
-         ELSE IF (maxval(ABS(lat_src_inv - io_lat)) < 0.001) THEN
-            ! Inverted source latitudes correspond to model latitudes
-            WRITE(lunout,*) 'latitudes will be inverted for file : ',TRIM(fname)
-            invert_lat=.TRUE.
-         ELSE
-            WRITE(lunout,*) 'Problem in latitudes read from file : ',TRIM(fname)
-            WRITE(lunout,*) 'latitudes in file ', TRIM(fname),' : ', lat_src      
-            WRITE(lunout,*) 'latitudes in model :', io_lat
-            CALL abort_physic('get_aero_fromfile', 'latitudes do not correspond between file and model',1)
-         END IF
-       ENDIF
-
-! 2) Check if old or new file is avalabale.
-!    New type of file should contain the dimension 'lev'
-!    Old type of file should contain the dimension 'PRESNIVS'
-!****************************************************************************************
-       ierr = nf90_inq_dimid(ncid, 'lev', dimid) 
-       IF (ierr /= NF90_NOERR) THEN
-          ! Coordinate axe lev not found. Check for presnivs.
-          ierr = nf90_inq_dimid(ncid, 'presnivs', dimid) 
-          IF (ierr /= NF90_NOERR) THEN
-             ierr = nf90_inq_dimid(ncid, 'PRESNIVS', dimid)
-             IF (ierr /= NF90_NOERR) THEN
-                ! Dimension PRESNIVS not found either
-                CALL abort_physic('get_aero_fromfile', 'dimension lev,PRESNIVS or presnivs not in file',1)
-             ELSE 
-                ! Old file found
-                new_file=.FALSE.
-                WRITE(lunout,*) 'Vertical interpolation for ',TRIM(varname),' will not be done'
-             END IF
-          ELSE
-             ! New file found
-             new_file=.TRUE.
-             WRITE(lunout,*) 'Vertical interpolation for ',TRIM(varname),' will be done'
-          ENDIF
-       ELSE
-          ! New file found
-          new_file=.TRUE.
-          WRITE(lunout,*) 'Vertical interpolation for ',TRIM(varname),' will be done'
-       END IF
-       
-! 2) Find vertical dimension klev_src
-!****************************************************************************************
-       CALL check_err( nf90_inquire_dimension(ncid, dimid, len = klev_src),"pb inq dim for PRESNIVS or lev" )
-       
-     ! Allocate variables depending on the number of vertical levels
-       ALLOCATE(varmth(nbp_lon,nbp_lat, klev_src), varyear(nbp_lon,nbp_lat, klev_src, 12), stat=ierr)
-       IF (ierr /= 0) CALL abort_physic('get_aero_fromfile', 'pb in allocation 1',1)
-
-       ALLOCATE(pt_ap(klev_src), pt_b(klev_src), varktmp(klev_src), stat=ierr)
-       IF (ierr /= 0) CALL abort_physic('get_aero_fromfile', 'pb in allocation 2',1)
-
-! 3) Read all variables from file
-!    There is 2 options for the file structure :
-!    new_file=TRUE  : read varyear, ps, pt_ap and pt_b
-!    new_file=FALSE : read varyear month by month
-!****************************************************************************************
-
-       IF (new_file) THEN
-! ++) Check number of month in file opened
-!**************************************************************************************************
-       ierr = nf90_inq_dimid(ncid, 'TIME',dimid)
-       if (ierr /= NF90_NOERR) THEN
-          ierr = nf90_inq_dimid(ncid, 'time_counter', dimid)
-       ENDIF
-       CALL check_err( nf90_inquire_dimension(ncid, dimid, len = nbr_tsteps),"pb inq dim TIME or time_counter" )
-!       IF (nbr_tsteps /= 12 .AND. nbr_tsteps /= 14) THEN
-       IF (nbr_tsteps /= 12 ) THEN
-    CALL abort_physic('get_aero_fromfile', 'not the right number of months in aerosol file read (should be 12 for the moment)' &
-                     ,1)
-       ENDIF
-
-! ++) Read the aerosol concentration month by month and concatenate to total variable varyear
-!****************************************************************************************
-          ! Get variable id
-          !CALL check_err( nf90_inq_varid(ncid, TRIM(varname), varid),"pb inq var "//TRIM(varname) )
-          print *,'readaerosol ', TRIM(varname)
-          IF ( nf90_inq_varid(ncid, TRIM(varname), varid) /= NF90_NOERR ) THEN 
-            ! Variable is not there
-            WRITE(lunout,*) 'Attention '//TRIM(varname)//' is not in aerosol input file'
-            varyear(:,:,:,:)=0.0
-          ELSE 
-            ! Get the variable
-            CALL check_err( nf90_get_var(ncid, varid, varyear(:,:,:,:)),"pb get var "//TRIM(varname) )
-          ENDIF
-          
-! ++) Read surface pression, 12 month in one variable
-!****************************************************************************************
-          ! Get variable id
-          CALL check_err( nf90_inq_varid(ncid, "ps", varid),"pb inq var ps" )
-          ! Get the variable
-          CALL check_err( nf90_get_var(ncid, varid, psurf_glo2D),"pb get var ps" )
-          
-! ++) Read mass load, 12 month in one variable
-!****************************************************************************************
-          ! Get variable id
-          !CALL check_err( nf90_inq_varid(ncid, "load_"//TRIM(varname), varid) ,"pb inq var load_"//TRIM(varname))
-          IF ( nf90_inq_varid(ncid, "load_"//TRIM(varname), varid) /= NF90_NOERR ) THEN 
-            WRITE(lunout,*) 'Attention load_'//TRIM(varname)//' is not in aerosol input file'
-            load_glo2D(:,:,:)=0.0
-          ELSE
-            ! Get the variable
-            CALL check_err( nf90_get_var(ncid, varid, load_glo2D),"pb get var load_"//TRIM(varname) )
-          ENDIF
-          
-! ++) Read ap
-!****************************************************************************************
-          ! Get variable id
-          CALL check_err( nf90_inq_varid(ncid, "ap", varid),"pb inq var ap" )
-          ! Get the variable
-          CALL check_err( nf90_get_var(ncid, varid, pt_ap),"pb get var ap" )
-
-! ++) Read b
-!****************************************************************************************
-          ! Get variable id
-          CALL check_err( nf90_inq_varid(ncid, "b", varid),"pb inq var b" )
-          ! Get the variable
-          CALL check_err( nf90_get_var(ncid, varid, pt_b),"pb get var b" )
-
-          
-
-       ELSE  ! old file
-
-! ++) Read the aerosol concentration month by month and concatenate to total variable varyear
-!****************************************************************************************
-          DO imth=1, 12
-             IF (imth.EQ.1) THEN
-                cvar=TRIM(varname)//'JAN'
-             ELSE IF (imth.EQ.2) THEN
-                cvar=TRIM(varname)//'FEB'
-             ELSE IF (imth.EQ.3) THEN
-                cvar=TRIM(varname)//'MAR'
-             ELSE IF (imth.EQ.4) THEN
-                cvar=TRIM(varname)//'APR'
-             ELSE IF (imth.EQ.5) THEN
-                cvar=TRIM(varname)//'MAY'
-             ELSE IF (imth.EQ.6) THEN
-                cvar=TRIM(varname)//'JUN'
-             ELSE IF (imth.EQ.7) THEN
-                cvar=TRIM(varname)//'JUL'
-             ELSE IF (imth.EQ.8) THEN
-                cvar=TRIM(varname)//'AUG'
-             ELSE IF (imth.EQ.9) THEN
-                cvar=TRIM(varname)//'SEP'
-             ELSE IF (imth.EQ.10) THEN
-                cvar=TRIM(varname)//'OCT'
-             ELSE IF (imth.EQ.11) THEN
-                cvar=TRIM(varname)//'NOV'
-             ELSE IF (imth.EQ.12) THEN
-                cvar=TRIM(varname)//'DEC'
-             END IF
-             
-             ! Get variable id
-             CALL check_err( nf90_inq_varid(ncid, TRIM(cvar), varid),"pb inq var "//TRIM(cvar) )
-             
-             ! Get the variable
-             CALL check_err( nf90_get_var(ncid, varid, varmth),"pb get var "//TRIM(cvar) )
-             
-             ! Store in variable for the whole year
-             varyear(:,:,:,imth)=varmth(:,:,:)
-             
-          END DO
-          
-          ! Putting dummy 
-          psurf_glo2D(:,:,:) = not_valid
-          load_glo2D(:,:,:)  = not_valid
-          pt_ap(:) = not_valid
-          pt_b(:)  = not_valid
-
-       END IF
-
-! 4) Close file  
-!****************************************************************************************
-       CALL check_err( nf90_close(ncid),"pb in close" )
-     
-
-! 5) Transform the global field from 2D(nbp_lon,nbp_lat) to 1D(klon_glo)
-!****************************************************************************************
-! Test if vertical levels have to be inversed
-
-       IF ((pt_b(1) < pt_b(klev_src)) .OR. .NOT. new_file) THEN
-!          WRITE(lunout,*) 'Vertical axis in file ',TRIM(fname), ' needs to be inverted'
-!          WRITE(lunout,*) 'before pt_ap = ', pt_ap
-!          WRITE(lunout,*) 'before pt_b = ', pt_b
-          
-          ! Inverse vertical levels for varyear 
-          DO imth=1, 12
-             varmth(:,:,:) = varyear(:,:,:,imth) ! use varmth temporarly
-             DO k=1, klev_src
-                DO j=1, nbp_lat
-                   DO i=1, nbp_lon
-                      varyear(i,j,k,imth) = varmth(i,j,klev_src+1-k)
-                   END DO
-                END DO
-             END DO
-          END DO
-           
-          ! Inverte vertical axes for pt_ap and pt_b
-          varktmp(:) = pt_ap(:)
-          DO k=1, klev_src
-             pt_ap(k) = varktmp(klev_src+1-k)
-          END DO
-
-          varktmp(:) = pt_b(:)
-          DO k=1, klev_src
-             pt_b(k) = varktmp(klev_src+1-k)
-          END DO
-          WRITE(lunout,*) 'after pt_ap = ', pt_ap
-          WRITE(lunout,*) 'after pt_b = ', pt_b
-
-       ELSE 
-          WRITE(lunout,*) 'Vertical axis in file ',TRIM(fname), ' is ok, no vertical inversion is done'
-          WRITE(lunout,*) 'pt_ap = ', pt_ap
-          WRITE(lunout,*) 'pt_b = ', pt_b
-       END IF
-
-
-       IF (grid_type/=unstructured) THEN
-  !     - Invert latitudes if necessary
-         DO imth=1, 12
-            IF (invert_lat) THEN
-
-               ! Invert latitudes for the variable
-               varmth(:,:,:) = varyear(:,:,:,imth) ! use varmth temporarly
-               DO k=1,klev_src
-                  DO j=1,nbp_lat
-                     DO i=1,nbp_lon
-                        varyear(i,j,k,imth) = varmth(i,nbp_lat+1-j,k)
-                     END DO
-                  END DO
-               END DO
-             
-               ! Invert latitudes for surface pressure
-               vartmp(:,:) = psurf_glo2D(:,:,imth)
-               DO j=1,nbp_lat
-                  DO i=1,nbp_lon
-                     psurf_glo2D(i,j,imth)= vartmp(i,nbp_lat+1-j)
-                  END DO
-               END DO
-             
-               ! Invert latitudes for the load
-               vartmp(:,:) = load_glo2D(:,:,imth)
-               DO j=1,nbp_lat
-                  DO i=1,nbp_lon
-                     load_glo2D(i,j,imth)= vartmp(i,nbp_lat+1-j)
-                  END DO
-               END DO
-            END IF ! invert_lat
-             
-            ! Do zonal mead at poles and distribut at whole first and last latitude
-            DO k=1, klev_src
-               npole=0.  ! North pole, j=1
-               spole=0.  ! South pole, j=nbp_lat        
-               DO i=1,nbp_lon
-                  npole = npole + varyear(i,1,k,imth)
-                  spole = spole + varyear(i,nbp_lat,k,imth)
-               END DO
-               npole = npole/REAL(nbp_lon)
-               spole = spole/REAL(nbp_lon)
-               varyear(:,1,    k,imth) = npole
-               varyear(:,nbp_lat,k,imth) = spole
-            END DO
-         END DO ! imth
-       
-         ALLOCATE(varyear_glo1D(klon_glo, klev_src, 12), stat=ierr)
-         IF (ierr /= 0) CALL abort_physic('get_aero_fromfile', 'pb in allocation 3',1)
-       
-         ! Transform from 2D to 1D field
-         CALL grid2Dto1D_glo(varyear,varyear_glo1D)
-         CALL grid2Dto1D_glo(psurf_glo2D,psurf_glo1D)
-         CALL grid2Dto1D_glo(load_glo2D,load_glo1D)
-      
-      ENDIF
-      
-    ELSE
-        ALLOCATE(varyear_glo1D(0,0,0))        
-    END IF ! is_mpi_root .AND. is_omp_root
-
-!$OMP BARRIER
-  
-! 6) Distribute to all processes
-!    Scatter global field(klon_glo) to local process domain(klon)
-!    and distribute klev_src to all processes
-!****************************************************************************************
-
-    ! Distribute klev_src
-    CALL bcast(klev_src)
-
-    ! Allocate and distribute pt_ap and pt_b
-    IF (.NOT. ASSOCIATED(pt_ap)) THEN  ! if pt_ap is allocated also pt_b is allocated
-       ALLOCATE(pt_ap(klev_src), pt_b(klev_src), stat=ierr)
-       IF (ierr /= 0) CALL abort_physic('get_aero_fromfile', 'pb in allocation 4',1)
-    END IF
-    CALL bcast(pt_ap)
-    CALL bcast(pt_b)
-
-    ! Allocate space for output pointer variable at local process
-    IF (ASSOCIATED(pt_year)) DEALLOCATE(pt_year)
-    ALLOCATE(pt_year(klon, klev_src, 12), stat=ierr)
-    ALLOCATE(pt_year_mpi(klon_mpi, klev_src, 12), stat=ierr)
-    IF (ierr /= 0) CALL abort_physic('get_aero_fromfile', 'pb in allocation 5',1)
-
-    IF (grid_type==unstructured) THEN
-      IF (is_omp_master) THEN
-        CALL xios_send_field(TRIM(varname)//"_in",varyear)
-        CALL xios_recv_field(TRIM(varname)//"_out",pt_year_mpi)
-        CALL xios_send_field("load_"//TRIM(varname)//"_in",load_glo2D)
-        CALL xios_recv_field("load_"//TRIM(varname)//"_out",load_out_mpi)
-        IF (.not. allocated(psurf_interp)) THEN
-         ! psurf_interp is a shared array
-          ALLOCATE(psurf_interp(klon_mpi,12))
-          CALL xios_send_field("psurf_aerosol_in",psurf_glo2D)
-          CALL xios_recv_field("psurf_aerosol_out",psurf_interp)
-        ENDIF
-      ENDIF
-      CALL scatter_omp(pt_year_mpi,pt_year)
-      CALL scatter_omp(load_out_mpi,load_out)
-      CALL scatter_omp(psurf_interp,psurf_out)
-      first=.FALSE.
-    ELSE
-      ! Scatter global field to local domain at local process
-      CALL scatter(varyear_glo1D, pt_year)
-      CALL scatter(psurf_glo1D, psurf_out)
-      CALL scatter(load_glo1D,  load_out)
-    ENDIF
-! 7) Test for negative values
-!****************************************************************************************
-    IF (MINVAL(pt_year) < 0.) THEN
-       WRITE(lunout,*) 'Warning! Negative values read from file :', fname
-    END IF
-
-  END SUBROUTINE get_aero_fromfile
-
-
-  SUBROUTINE check_err(status,text)
-    USE netcdf
-    USE print_control_mod, ONLY: lunout
-    IMPLICIT NONE
-
-    INTEGER, INTENT (IN) :: status
-    CHARACTER(len=*), INTENT (IN), OPTIONAL :: text
-
-    IF (status /= NF90_NOERR) THEN
-       WRITE(lunout,*) 'Error in get_aero_fromfile, netcdf error code = ',status
-       IF (PRESENT(text)) THEN
-          WRITE(lunout,*) 'Error in get_aero_fromfile : ',text
-       END IF
-       CALL abort_physic('get_aero_fromfile',trim(nf90_strerror(status)),1)
-    END IF
-
-  END SUBROUTINE check_err
-
-
-END MODULE readaerosol_mod
Index: /LMDZ6/trunk/libf/phylmd/readaerosol_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/readaerosol_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/readaerosol_mod.f90	(revision 5268)
@@ -0,0 +1,736 @@
+! $Id: readaerosol.F90 3436 2019-01-22 16:26:21Z emillour $
+!
+MODULE readaerosol_mod
+
+  REAL, SAVE :: not_valid=-333.
+  
+  INTEGER, SAVE :: nbp_lon_src
+!$OMP THREADPRIVATE(nbp_lon_src)  
+  INTEGER, SAVE :: nbp_lat_src
+!$OMP THREADPRIVATE(nbp_lat_src)  
+  REAL, ALLOCATABLE, SAVE    :: psurf_interp(:,:)
+
+CONTAINS
+
+SUBROUTINE readaerosol(name_aero, type, filename, iyr_in, klev_src, pt_ap, pt_b, pt_out, psurf, load)
+
+!****************************************************************************************
+! This routine will read the aersosol from file. 
+!
+! Read a year data with get_aero_fromfile depending on aer_type : 
+! - actuel   : read year 1980
+! - preind   : read natural data
+! - scenario : read one or two years and do eventually linare time interpolation
+!
+! Return pointer, pt_out, to the year read or result from interpolation
+!****************************************************************************************
+  USE dimphy
+  USE print_control_mod, ONLY: lunout
+
+  IMPLICIT NONE
+
+  ! Input arguments
+  CHARACTER(len=7), INTENT(IN) :: name_aero
+  CHARACTER(len=*), INTENT(IN) :: type  ! actuel, annuel, scenario or preind
+  CHARACTER(len=8), INTENT(IN) :: filename
+  INTEGER, INTENT(IN)          :: iyr_in
+
+  ! Output
+  INTEGER, INTENT(OUT)            :: klev_src
+  REAL, POINTER, DIMENSION(:)     :: pt_ap        ! Pointer for describing the vertical levels      
+  REAL, POINTER, DIMENSION(:)     :: pt_b         ! Pointer for describing the vertical levels      
+  REAL, POINTER, DIMENSION(:,:,:) :: pt_out       ! The massvar distributions, DIMENSION(klon, klev_src, 12)
+  REAL, DIMENSION(klon,12), INTENT(OUT) :: psurf  ! Surface pression for 12 months
+  REAL, DIMENSION(klon,12), INTENT(OUT) :: load   ! Aerosol mass load in each column for 12 months
+
+  ! Local variables
+  CHARACTER(len=4)                :: cyear
+  REAL, POINTER, DIMENSION(:,:,:) :: pt_2
+  REAL, DIMENSION(klon,12)        :: psurf2, load2
+  INTEGER                         :: iyr1, iyr2, klev_src2
+  INTEGER                         :: it, k, i
+  LOGICAL, PARAMETER              :: lonlyone=.FALSE.
+
+!****************************************************************************************
+! Read data depending on aer_type
+!
+!****************************************************************************************
+
+  IF (type == 'actuel') THEN
+! Read and return data for year 1980
+!****************************************************************************************
+     cyear='1980'
+     ! get_aero_fromfile returns pt_out allocated and initialized with data for 12 month 
+     ! pt_out has dimensions (klon, klev_src, 12)
+     CALL get_aero_fromfile(name_aero, cyear, filename, klev_src, pt_ap, pt_b, pt_out, psurf, load)
+     
+
+  ELSE IF (type == 'preind') THEN
+! Read and return data from file with suffix .nat
+!****************************************************************************************     
+     cyear='.nat'
+     ! get_aero_fromfile returns pt_out allocated and initialized with data for 12 month 
+     ! pt_out has dimensions (klon, klev_src, 12)
+     CALL get_aero_fromfile(name_aero, cyear, filename, klev_src, pt_ap, pt_b, pt_out, psurf, load)
+     
+  ELSE IF (type == 'annuel') THEN
+! Read and return data from scenario annual files
+!****************************************************************************************     
+     WRITE(cyear,'(I4)') iyr_in
+     WRITE(lunout,*) 'get_aero 3 iyr_in=', iyr_in,'   ',cyear
+     ! get_aero_fromfile returns pt_out allocated and initialized with data for nbr_tsteps month 
+     ! pt_out has dimensions (klon, klev_src, 12)
+     CALL get_aero_fromfile(name_aero, cyear, filename, klev_src, pt_ap, pt_b, pt_out, psurf, load)
+     
+  ELSE IF (type == 'scenario') THEN
+! Read data depending on actual year and interpolate if necessary
+!****************************************************************************************
+     IF (iyr_in .LT. 1850) THEN
+        cyear='.nat'
+        WRITE(lunout,*) 'get_aero 1 iyr_in=', iyr_in,'   ',cyear
+        ! get_aero_fromfile returns pt_out allocated and initialized with data for 12 month 
+        ! pt_out has dimensions (klon, klev_src, 12)
+        CALL get_aero_fromfile(name_aero, cyear, filename, klev_src, pt_ap, pt_b, pt_out, psurf, load)
+        
+     ELSE IF (iyr_in .GE. 2100) THEN
+        cyear='2100'
+        WRITE(lunout,*) 'get_aero 2 iyr_in=', iyr_in,'   ',cyear
+        ! get_aero_fromfile returns pt_out allocated and initialized with data for 12 month 
+        ! pt_out has dimensions (klon, klev_src, 12)
+        CALL get_aero_fromfile(name_aero, cyear, filename, klev_src, pt_ap, pt_b, pt_out, psurf, load)
+        
+     ELSE
+        ! Read data from 2 decades and interpolate to actual year
+        ! a) from actual 10-yr-period
+        IF (iyr_in.LT.1900) THEN
+           iyr1 = 1850
+           iyr2 = 1900
+        ELSE IF (iyr_in.GE.1900.AND.iyr_in.LT.1920) THEN
+           iyr1 = 1900
+           iyr2 = 1920
+        ELSE 
+           iyr1 = INT(iyr_in/10)*10
+           iyr2 = INT(1+iyr_in/10)*10
+        ENDIF
+        
+        WRITE(cyear,'(I4)') iyr1
+        WRITE(lunout,*) 'get_aero 3 iyr_in=', iyr_in,'   ',cyear
+        ! get_aero_fromfile returns pt_out allocated and initialized with data for 12 month 
+        ! pt_out has dimensions (klon, klev_src, 12)
+        CALL get_aero_fromfile(name_aero, cyear, filename, klev_src, pt_ap, pt_b, pt_out, psurf, load)
+        
+        ! If to read two decades:
+        IF (.NOT.lonlyone) THEN 
+           
+           ! b) from the next following one
+           WRITE(cyear,'(I4)') iyr2
+           WRITE(lunout,*) 'get_aero 4 iyr_in=', iyr_in,'   ',cyear
+           
+           NULLIFY(pt_2)
+           ! get_aero_fromfile returns pt_2 allocated and initialized with data for 12 month 
+           ! pt_2 has dimensions (klon, klev_src, 12)
+           CALL get_aero_fromfile(name_aero, cyear, filename, klev_src2, pt_ap, pt_b, pt_2, psurf2, load2)
+           ! Test for same number of vertical levels
+           IF (klev_src /= klev_src2) THEN
+              WRITE(lunout,*) 'Two aerosols files with different number of vertical levels is not allowded'
+              CALL abort_physic('readaersosol','Error in number of vertical levels',1)
+           END IF
+           
+           ! Linare interpolate to the actual year:
+           DO it=1,12
+              DO k=1,klev_src
+                 DO i = 1, klon
+                    pt_out(i,k,it) = &
+                         pt_out(i,k,it) - REAL(iyr_in-iyr1)/REAL(iyr2-iyr1) * &
+                         (pt_out(i,k,it) - pt_2(i,k,it))
+                 END DO
+              END DO
+
+              DO i = 1, klon
+                 psurf(i,it) = &
+                      psurf(i,it) - REAL(iyr_in-iyr1)/REAL(iyr2-iyr1) * &
+                      (psurf(i,it) - psurf2(i,it))
+
+                 load(i,it) = &
+                      load(i,it) - REAL(iyr_in-iyr1)/REAL(iyr2-iyr1) * &
+                      (load(i,it) - load2(i,it))
+              END DO
+           END DO
+
+           ! Deallocate pt_2 no more needed
+           DEALLOCATE(pt_2)
+           
+        END IF ! lonlyone
+     END IF ! iyr_in .LT. 1850
+
+  ELSE
+     WRITE(lunout,*)'This option is not implemented : aer_type = ', type,' name_aero=',name_aero
+     CALL abort_physic('readaerosol','Error : aer_type parameter not accepted',1)
+  END IF ! type
+
+
+END SUBROUTINE readaerosol
+
+
+SUBROUTINE init_aero_fromfile(flag_aerosol, aerosol_couple)
+  USE netcdf
+  USE mod_phys_lmdz_para
+  USE mod_grid_phy_lmdz, ONLY: grid_type, unstructured
+  USE lmdz_xios
+  IMPLICIT NONE
+
+  INTEGER, INTENT(IN) :: flag_aerosol
+  LOGICAL, INTENT(IN) :: aerosol_couple
+  
+  REAL,ALLOCATABLE :: lat_src(:)
+  REAL,ALLOCATABLE :: lon_src(:)
+  CHARACTER(LEN=*),PARAMETER :: file_aerosol='aerosols.nat.nc'
+  CHARACTER(LEN=*),PARAMETER :: file_so4='so4.nat.nc'
+  INTEGER :: klev_src
+  INTEGER :: ierr ,ncid, dimID, varid
+  REAL :: null_array(0)
+
+  IF (using_xios) THEN
+    IF (flag_aerosol>0 .AND. grid_type==unstructured .AND. (.NOT. aerosol_couple) ) THEN
+  
+      IF (is_omp_root) THEN
+  
+        IF (is_mpi_root) THEN
+    
+          IF (nf90_open(TRIM(file_aerosol), NF90_NOWRITE, ncid) /= NF90_NOERR) THEN
+            CALL check_err( nf90_open(TRIM(file_so4), NF90_NOWRITE, ncid), "pb open "//trim(file_so4) )
+          ENDIF
+
+          ! Read and test longitudes
+          CALL check_err( nf90_inq_dimid(ncid, "lon", dimID),"pb inq dim lon") 
+          CALL check_err( nf90_inquire_dimension(ncid, dimID, len = nbp_lon_src),"pb inq dim lon")
+          CALL check_err( nf90_inq_varid(ncid, 'lon', varid),"pb inq lon" )
+          ALLOCATE(lon_src(nbp_lon_src))
+          CALL check_err( nf90_get_var(ncid, varid, lon_src(:)),"pb get lon" )
+
+          ! Read and test latitudes
+          CALL check_err( nf90_inq_dimid(ncid, "lat", dimID),"pb inq dim lat") 
+          CALL check_err( nf90_inquire_dimension(ncid, dimID, len = nbp_lat_src),"pb inq dim lat")
+          CALL check_err( nf90_inq_varid(ncid, 'lat', varid),"pb inq lat" )
+          ALLOCATE(lat_src(nbp_lat_src))
+          CALL check_err( nf90_get_var(ncid, varid, lat_src(:)),"pb get lat" )
+          IF (nf90_inq_dimid(ncid, 'lev', dimid) /= NF90_NOERR) THEN
+            IF (nf90_inq_dimid(ncid, 'presnivs', dimid)/= NF90_NOERR) THEN
+               CALL check_err(nf90_inq_dimid(ncid, 'PRESNIVS', dimid),'dimension lev,PRESNIVS or presnivs not in file')
+            ENDIF
+          ENDIF
+          CALL check_err( nf90_inquire_dimension(ncid, dimid, len = klev_src),"pb inq dim for PRESNIVS or lev" )
+          CALL check_err( nf90_close(ncid),"pb in close" )   
+        ENDIF
+
+        CALL bcast_mpi(nbp_lat_src)
+        CALL bcast_mpi(nbp_lon_src)
+        CALL bcast_mpi(klev_src)
+
+        IF (is_mpi_root ) THEN
+          CALL xios_set_domain_attr("domain_aerosol",nj_glo=nbp_lat_src, nj=nbp_lat_src, jbegin=0, latvalue_1d=lat_src)
+          CALL xios_set_domain_attr("domain_aerosol",ni_glo=nbp_lon_src, ni=nbp_lon_src, ibegin=0, lonvalue_1d=lon_src)
+        ELSE
+          CALL xios_set_domain_attr("domain_aerosol",nj_glo=nbp_lat_src, nj=0, jbegin=0, latvalue_1d=null_array )
+          CALL xios_set_domain_attr("domain_aerosol",ni_glo=nbp_lon_src, ni=0, ibegin=0, lonvalue_1d=null_array)
+        ENDIF
+        CALL xios_set_axis_attr("axis_aerosol",n_glo=klev_src)
+        CALL xios_set_fieldgroup_attr("aerosols", enabled=.TRUE.)
+  
+      ENDIF
+    
+    ENDIF    
+  ENDIF !using_xios 
+END SUBROUTINE init_aero_fromfile
+
+
+    
+
+  SUBROUTINE get_aero_fromfile(varname, cyr, filename, klev_src, pt_ap, pt_b, pt_year, psurf_out, load_out)
+!****************************************************************************************
+! Read 12 month aerosol from file and distribute to local process on physical grid. 
+! Vertical levels, klev_src, may differ from model levels if new file format.
+!
+! For mpi_root and master thread :
+! 1) Open file 
+! 2) Find vertical dimension klev_src
+! 3) Read field month by month
+! 4) Close file  
+! 5) Transform the global field from 2D(nbp_lon,nbp_lat) to 1D(klon_glo)
+!     - Also the levels and the latitudes have to be inversed
+!
+! For all processes and threads :
+! 6) Scatter global field(klon_glo) to local process domain(klon)
+! 7) Test for negative values
+!****************************************************************************************
+
+    USE netcdf
+    USE dimphy
+    USE mod_grid_phy_lmdz, ONLY: nbp_lon_=>nbp_lon, nbp_lat_=>nbp_lat, klon_glo, &
+                                 grid2Dto1D_glo, grid_type, unstructured
+    USE mod_phys_lmdz_para
+    USE iophy, ONLY : io_lon, io_lat
+    USE print_control_mod, ONLY: lunout
+    USE lmdz_xios
+    IMPLICIT NONE
+      
+! Input argumets
+    CHARACTER(len=7), INTENT(IN)          :: varname
+    CHARACTER(len=4), INTENT(IN)          :: cyr
+    CHARACTER(len=8), INTENT(IN)          :: filename
+
+! Output arguments
+    INTEGER, INTENT(OUT)                  :: klev_src     ! Number of vertical levels in file
+    REAL, POINTER, DIMENSION(:)           :: pt_ap        ! Pointer for describing the vertical levels      
+    REAL, POINTER, DIMENSION(:)           :: pt_b         ! Pointer for describing the vertical levels      
+    REAL, POINTER, DIMENSION(:,:,:)       :: pt_year      ! Pointer-variabale from file, 12 month, grid : klon,klev_src
+    REAL, POINTER, DIMENSION(:,:,:)       :: pt_year_mpi  ! Pointer-variabale from file, 12 month, grid : klon,klev_src
+    REAL, DIMENSION(klon,12), INTENT(OUT) :: psurf_out    ! Surface pression for 12 months
+    REAL, DIMENSION(klon_mpi,12)          :: psurf_out_mpi    ! Surface pression for 12 months
+    REAL, DIMENSION(klon,12), INTENT(OUT) :: load_out     ! Aerosol mass load in each column
+    REAL, DIMENSION(klon_mpi,12)          :: load_out_mpi     ! Aerosol mass load in each column
+    INTEGER                               :: nbr_tsteps   ! number of month in file read
+
+! Local variables
+    CHARACTER(len=30)     :: fname
+    CHARACTER(len=30)     :: cvar
+    INTEGER               :: ncid, dimid, varid
+    INTEGER               :: imth, i, j, k, ierr
+    REAL                  :: npole, spole
+    REAL, ALLOCATABLE, DIMENSION(:,:,:)   :: varmth
+    REAL, ALLOCATABLE, DIMENSION(:,:,:,:) :: varyear       ! Global variable read from file, 12 month
+    REAL, ALLOCATABLE, DIMENSION(:,:,:)   :: varyear_glo1D !(klon_glo, klev_src, 12)
+    REAL, ALLOCATABLE, DIMENSION(:)       :: varktmp
+
+    REAL,  ALLOCATABLE                    :: psurf_glo2D(:,:,:)   ! Surface pression for 12 months on dynamics global grid
+    REAL, DIMENSION(klon_glo,12)          :: psurf_glo1D   ! -"- on physical global grid
+    REAL,  ALLOCATABLE                    :: load_glo2D(:,:,:)    ! Load for 12 months on dynamics global grid
+    REAL, DIMENSION(klon_glo,12)          :: load_glo1D    ! -"- on physical global grid
+    REAL, ALLOCATABLE, DIMENSION(:,:)     :: vartmp
+    REAL, ALLOCATABLE,DIMENSION(:)        :: lon_src              ! longitudes in file
+    REAL, ALLOCATABLE,DIMENSION(:)        :: lat_src, lat_src_inv ! latitudes in file
+    LOGICAL                               :: new_file             ! true if new file format detected
+    LOGICAL                               :: invert_lat           ! true if the field has to be inverted for latitudes
+    INTEGER                               :: nbp_lon, nbp_lat
+    LOGICAL,SAVE                          :: first=.TRUE.
+!$OMP THREADPRIVATE(first)
+    
+    IF (grid_type==unstructured) THEN
+      nbp_lon=nbp_lon_src
+      nbp_lat=nbp_lat_src
+    ELSE
+      nbp_lon=nbp_lon_
+      nbp_lat=nbp_lat_
+    ENDIF
+    
+    IF (is_mpi_root) THEN
+    
+      ALLOCATE(psurf_glo2D(nbp_lon,nbp_lat,12))
+      ALLOCATE(load_glo2D(nbp_lon,nbp_lat,12))
+      ALLOCATE(vartmp(nbp_lon,nbp_lat))
+      ALLOCATE(lon_src(nbp_lon))
+      ALLOCATE(lat_src(nbp_lat))
+      ALLOCATE(lat_src_inv(nbp_lat))
+    ELSE
+      ALLOCATE(varyear(0,0,0,0))
+      ALLOCATE(psurf_glo2D(0,0,0))
+      ALLOCATE(load_glo2D(0,0,0))
+    ENDIF
+            
+    ! Deallocate pointers
+    IF (ASSOCIATED(pt_ap)) DEALLOCATE(pt_ap)
+    IF (ASSOCIATED(pt_b))  DEALLOCATE(pt_b)
+
+    IF (is_mpi_root .AND. is_omp_root) THEN
+
+! 1) Open file 
+!****************************************************************************************
+! Add suffix to filename
+       fname = trim(filename)//cyr//'.nc'
+  
+       WRITE(lunout,*) 'reading variable ',TRIM(varname),' in file ', TRIM(fname)
+       CALL check_err( nf90_open(TRIM(fname), NF90_NOWRITE, ncid), "pb open "//trim(fname) )
+
+
+       IF (grid_type/=unstructured) THEN
+
+! Test for equal longitudes and latitudes in file and model
+!****************************************************************************************
+       ! Read and test longitudes
+         CALL check_err( nf90_inq_varid(ncid, 'lon', varid),"pb inq lon" )
+         CALL check_err( nf90_get_var(ncid, varid, lon_src(:)),"pb get lon" )
+       
+         IF (maxval(ABS(lon_src - io_lon)) > 0.001) THEN
+            WRITE(lunout,*) 'Problem in longitudes read from file : ',TRIM(fname)
+            WRITE(lunout,*) 'longitudes in file ', TRIM(fname),' : ', lon_src
+            WRITE(lunout,*) 'longitudes in model :', io_lon
+          
+            CALL abort_physic('get_aero_fromfile', 'longitudes are not the same in file and model',1)
+         END IF
+
+         ! Read and test latitudes
+         CALL check_err( nf90_inq_varid(ncid, 'lat', varid),"pb inq lat" )
+         CALL check_err( nf90_get_var(ncid, varid, lat_src(:)),"pb get lat" )
+
+         ! Invert source latitudes
+         DO j = 1, nbp_lat
+            lat_src_inv(j) = lat_src(nbp_lat +1 -j)
+         END DO
+
+         IF (maxval(ABS(lat_src - io_lat)) < 0.001) THEN
+            ! Latitudes are the same
+            invert_lat=.FALSE.
+         ELSE IF (maxval(ABS(lat_src_inv - io_lat)) < 0.001) THEN
+            ! Inverted source latitudes correspond to model latitudes
+            WRITE(lunout,*) 'latitudes will be inverted for file : ',TRIM(fname)
+            invert_lat=.TRUE.
+         ELSE
+            WRITE(lunout,*) 'Problem in latitudes read from file : ',TRIM(fname)
+            WRITE(lunout,*) 'latitudes in file ', TRIM(fname),' : ', lat_src      
+            WRITE(lunout,*) 'latitudes in model :', io_lat
+            CALL abort_physic('get_aero_fromfile', 'latitudes do not correspond between file and model',1)
+         END IF
+       ENDIF
+
+! 2) Check if old or new file is avalabale.
+!    New type of file should contain the dimension 'lev'
+!    Old type of file should contain the dimension 'PRESNIVS'
+!****************************************************************************************
+       ierr = nf90_inq_dimid(ncid, 'lev', dimid) 
+       IF (ierr /= NF90_NOERR) THEN
+          ! Coordinate axe lev not found. Check for presnivs.
+          ierr = nf90_inq_dimid(ncid, 'presnivs', dimid) 
+          IF (ierr /= NF90_NOERR) THEN
+             ierr = nf90_inq_dimid(ncid, 'PRESNIVS', dimid)
+             IF (ierr /= NF90_NOERR) THEN
+                ! Dimension PRESNIVS not found either
+                CALL abort_physic('get_aero_fromfile', 'dimension lev,PRESNIVS or presnivs not in file',1)
+             ELSE 
+                ! Old file found
+                new_file=.FALSE.
+                WRITE(lunout,*) 'Vertical interpolation for ',TRIM(varname),' will not be done'
+             END IF
+          ELSE
+             ! New file found
+             new_file=.TRUE.
+             WRITE(lunout,*) 'Vertical interpolation for ',TRIM(varname),' will be done'
+          ENDIF
+       ELSE
+          ! New file found
+          new_file=.TRUE.
+          WRITE(lunout,*) 'Vertical interpolation for ',TRIM(varname),' will be done'
+       END IF
+       
+! 2) Find vertical dimension klev_src
+!****************************************************************************************
+       CALL check_err( nf90_inquire_dimension(ncid, dimid, len = klev_src),"pb inq dim for PRESNIVS or lev" )
+       
+     ! Allocate variables depending on the number of vertical levels
+       ALLOCATE(varmth(nbp_lon,nbp_lat, klev_src), varyear(nbp_lon,nbp_lat, klev_src, 12), stat=ierr)
+       IF (ierr /= 0) CALL abort_physic('get_aero_fromfile', 'pb in allocation 1',1)
+
+       ALLOCATE(pt_ap(klev_src), pt_b(klev_src), varktmp(klev_src), stat=ierr)
+       IF (ierr /= 0) CALL abort_physic('get_aero_fromfile', 'pb in allocation 2',1)
+
+! 3) Read all variables from file
+!    There is 2 options for the file structure :
+!    new_file=TRUE  : read varyear, ps, pt_ap and pt_b
+!    new_file=FALSE : read varyear month by month
+!****************************************************************************************
+
+       IF (new_file) THEN
+! ++) Check number of month in file opened
+!**************************************************************************************************
+       ierr = nf90_inq_dimid(ncid, 'TIME',dimid)
+       if (ierr /= NF90_NOERR) THEN
+          ierr = nf90_inq_dimid(ncid, 'time_counter', dimid)
+       ENDIF
+       CALL check_err( nf90_inquire_dimension(ncid, dimid, len = nbr_tsteps),"pb inq dim TIME or time_counter" )
+!       IF (nbr_tsteps /= 12 .AND. nbr_tsteps /= 14) THEN
+       IF (nbr_tsteps /= 12 ) THEN
+    CALL abort_physic('get_aero_fromfile', 'not the right number of months in aerosol file read (should be 12 for the moment)' &
+                     ,1)
+       ENDIF
+
+! ++) Read the aerosol concentration month by month and concatenate to total variable varyear
+!****************************************************************************************
+          ! Get variable id
+          !CALL check_err( nf90_inq_varid(ncid, TRIM(varname), varid),"pb inq var "//TRIM(varname) )
+          print *,'readaerosol ', TRIM(varname)
+          IF ( nf90_inq_varid(ncid, TRIM(varname), varid) /= NF90_NOERR ) THEN 
+            ! Variable is not there
+            WRITE(lunout,*) 'Attention '//TRIM(varname)//' is not in aerosol input file'
+            varyear(:,:,:,:)=0.0
+          ELSE 
+            ! Get the variable
+            CALL check_err( nf90_get_var(ncid, varid, varyear(:,:,:,:)),"pb get var "//TRIM(varname) )
+          ENDIF
+          
+! ++) Read surface pression, 12 month in one variable
+!****************************************************************************************
+          ! Get variable id
+          CALL check_err( nf90_inq_varid(ncid, "ps", varid),"pb inq var ps" )
+          ! Get the variable
+          CALL check_err( nf90_get_var(ncid, varid, psurf_glo2D),"pb get var ps" )
+          
+! ++) Read mass load, 12 month in one variable
+!****************************************************************************************
+          ! Get variable id
+          !CALL check_err( nf90_inq_varid(ncid, "load_"//TRIM(varname), varid) ,"pb inq var load_"//TRIM(varname))
+          IF ( nf90_inq_varid(ncid, "load_"//TRIM(varname), varid) /= NF90_NOERR ) THEN 
+            WRITE(lunout,*) 'Attention load_'//TRIM(varname)//' is not in aerosol input file'
+            load_glo2D(:,:,:)=0.0
+          ELSE
+            ! Get the variable
+            CALL check_err( nf90_get_var(ncid, varid, load_glo2D),"pb get var load_"//TRIM(varname) )
+          ENDIF
+          
+! ++) Read ap
+!****************************************************************************************
+          ! Get variable id
+          CALL check_err( nf90_inq_varid(ncid, "ap", varid),"pb inq var ap" )
+          ! Get the variable
+          CALL check_err( nf90_get_var(ncid, varid, pt_ap),"pb get var ap" )
+
+! ++) Read b
+!****************************************************************************************
+          ! Get variable id
+          CALL check_err( nf90_inq_varid(ncid, "b", varid),"pb inq var b" )
+          ! Get the variable
+          CALL check_err( nf90_get_var(ncid, varid, pt_b),"pb get var b" )
+
+          
+
+       ELSE  ! old file
+
+! ++) Read the aerosol concentration month by month and concatenate to total variable varyear
+!****************************************************************************************
+          DO imth=1, 12
+             IF (imth.EQ.1) THEN
+                cvar=TRIM(varname)//'JAN'
+             ELSE IF (imth.EQ.2) THEN
+                cvar=TRIM(varname)//'FEB'
+             ELSE IF (imth.EQ.3) THEN
+                cvar=TRIM(varname)//'MAR'
+             ELSE IF (imth.EQ.4) THEN
+                cvar=TRIM(varname)//'APR'
+             ELSE IF (imth.EQ.5) THEN
+                cvar=TRIM(varname)//'MAY'
+             ELSE IF (imth.EQ.6) THEN
+                cvar=TRIM(varname)//'JUN'
+             ELSE IF (imth.EQ.7) THEN
+                cvar=TRIM(varname)//'JUL'
+             ELSE IF (imth.EQ.8) THEN
+                cvar=TRIM(varname)//'AUG'
+             ELSE IF (imth.EQ.9) THEN
+                cvar=TRIM(varname)//'SEP'
+             ELSE IF (imth.EQ.10) THEN
+                cvar=TRIM(varname)//'OCT'
+             ELSE IF (imth.EQ.11) THEN
+                cvar=TRIM(varname)//'NOV'
+             ELSE IF (imth.EQ.12) THEN
+                cvar=TRIM(varname)//'DEC'
+             END IF
+             
+             ! Get variable id
+             CALL check_err( nf90_inq_varid(ncid, TRIM(cvar), varid),"pb inq var "//TRIM(cvar) )
+             
+             ! Get the variable
+             CALL check_err( nf90_get_var(ncid, varid, varmth),"pb get var "//TRIM(cvar) )
+             
+             ! Store in variable for the whole year
+             varyear(:,:,:,imth)=varmth(:,:,:)
+             
+          END DO
+          
+          ! Putting dummy 
+          psurf_glo2D(:,:,:) = not_valid
+          load_glo2D(:,:,:)  = not_valid
+          pt_ap(:) = not_valid
+          pt_b(:)  = not_valid
+
+       END IF
+
+! 4) Close file  
+!****************************************************************************************
+       CALL check_err( nf90_close(ncid),"pb in close" )
+     
+
+! 5) Transform the global field from 2D(nbp_lon,nbp_lat) to 1D(klon_glo)
+!****************************************************************************************
+! Test if vertical levels have to be inversed
+
+       IF ((pt_b(1) < pt_b(klev_src)) .OR. .NOT. new_file) THEN
+!          WRITE(lunout,*) 'Vertical axis in file ',TRIM(fname), ' needs to be inverted'
+!          WRITE(lunout,*) 'before pt_ap = ', pt_ap
+!          WRITE(lunout,*) 'before pt_b = ', pt_b
+          
+          ! Inverse vertical levels for varyear 
+          DO imth=1, 12
+             varmth(:,:,:) = varyear(:,:,:,imth) ! use varmth temporarly
+             DO k=1, klev_src
+                DO j=1, nbp_lat
+                   DO i=1, nbp_lon
+                      varyear(i,j,k,imth) = varmth(i,j,klev_src+1-k)
+                   END DO
+                END DO
+             END DO
+          END DO
+           
+          ! Inverte vertical axes for pt_ap and pt_b
+          varktmp(:) = pt_ap(:)
+          DO k=1, klev_src
+             pt_ap(k) = varktmp(klev_src+1-k)
+          END DO
+
+          varktmp(:) = pt_b(:)
+          DO k=1, klev_src
+             pt_b(k) = varktmp(klev_src+1-k)
+          END DO
+          WRITE(lunout,*) 'after pt_ap = ', pt_ap
+          WRITE(lunout,*) 'after pt_b = ', pt_b
+
+       ELSE 
+          WRITE(lunout,*) 'Vertical axis in file ',TRIM(fname), ' is ok, no vertical inversion is done'
+          WRITE(lunout,*) 'pt_ap = ', pt_ap
+          WRITE(lunout,*) 'pt_b = ', pt_b
+       END IF
+
+
+       IF (grid_type/=unstructured) THEN
+  !     - Invert latitudes if necessary
+         DO imth=1, 12
+            IF (invert_lat) THEN
+
+               ! Invert latitudes for the variable
+               varmth(:,:,:) = varyear(:,:,:,imth) ! use varmth temporarly
+               DO k=1,klev_src
+                  DO j=1,nbp_lat
+                     DO i=1,nbp_lon
+                        varyear(i,j,k,imth) = varmth(i,nbp_lat+1-j,k)
+                     END DO
+                  END DO
+               END DO
+             
+               ! Invert latitudes for surface pressure
+               vartmp(:,:) = psurf_glo2D(:,:,imth)
+               DO j=1,nbp_lat
+                  DO i=1,nbp_lon
+                     psurf_glo2D(i,j,imth)= vartmp(i,nbp_lat+1-j)
+                  END DO
+               END DO
+             
+               ! Invert latitudes for the load
+               vartmp(:,:) = load_glo2D(:,:,imth)
+               DO j=1,nbp_lat
+                  DO i=1,nbp_lon
+                     load_glo2D(i,j,imth)= vartmp(i,nbp_lat+1-j)
+                  END DO
+               END DO
+            END IF ! invert_lat
+             
+            ! Do zonal mead at poles and distribut at whole first and last latitude
+            DO k=1, klev_src
+               npole=0.  ! North pole, j=1
+               spole=0.  ! South pole, j=nbp_lat        
+               DO i=1,nbp_lon
+                  npole = npole + varyear(i,1,k,imth)
+                  spole = spole + varyear(i,nbp_lat,k,imth)
+               END DO
+               npole = npole/REAL(nbp_lon)
+               spole = spole/REAL(nbp_lon)
+               varyear(:,1,    k,imth) = npole
+               varyear(:,nbp_lat,k,imth) = spole
+            END DO
+         END DO ! imth
+       
+         ALLOCATE(varyear_glo1D(klon_glo, klev_src, 12), stat=ierr)
+         IF (ierr /= 0) CALL abort_physic('get_aero_fromfile', 'pb in allocation 3',1)
+       
+         ! Transform from 2D to 1D field
+         CALL grid2Dto1D_glo(varyear,varyear_glo1D)
+         CALL grid2Dto1D_glo(psurf_glo2D,psurf_glo1D)
+         CALL grid2Dto1D_glo(load_glo2D,load_glo1D)
+      
+      ENDIF
+      
+    ELSE
+        ALLOCATE(varyear_glo1D(0,0,0))        
+    END IF ! is_mpi_root .AND. is_omp_root
+
+!$OMP BARRIER
+  
+! 6) Distribute to all processes
+!    Scatter global field(klon_glo) to local process domain(klon)
+!    and distribute klev_src to all processes
+!****************************************************************************************
+
+    ! Distribute klev_src
+    CALL bcast(klev_src)
+
+    ! Allocate and distribute pt_ap and pt_b
+    IF (.NOT. ASSOCIATED(pt_ap)) THEN  ! if pt_ap is allocated also pt_b is allocated
+       ALLOCATE(pt_ap(klev_src), pt_b(klev_src), stat=ierr)
+       IF (ierr /= 0) CALL abort_physic('get_aero_fromfile', 'pb in allocation 4',1)
+    END IF
+    CALL bcast(pt_ap)
+    CALL bcast(pt_b)
+
+    ! Allocate space for output pointer variable at local process
+    IF (ASSOCIATED(pt_year)) DEALLOCATE(pt_year)
+    ALLOCATE(pt_year(klon, klev_src, 12), stat=ierr)
+    ALLOCATE(pt_year_mpi(klon_mpi, klev_src, 12), stat=ierr)
+    IF (ierr /= 0) CALL abort_physic('get_aero_fromfile', 'pb in allocation 5',1)
+
+    IF (grid_type==unstructured) THEN
+      IF (is_omp_master) THEN
+        CALL xios_send_field(TRIM(varname)//"_in",varyear)
+        CALL xios_recv_field(TRIM(varname)//"_out",pt_year_mpi)
+        CALL xios_send_field("load_"//TRIM(varname)//"_in",load_glo2D)
+        CALL xios_recv_field("load_"//TRIM(varname)//"_out",load_out_mpi)
+        IF (.not. allocated(psurf_interp)) THEN
+         ! psurf_interp is a shared array
+          ALLOCATE(psurf_interp(klon_mpi,12))
+          CALL xios_send_field("psurf_aerosol_in",psurf_glo2D)
+          CALL xios_recv_field("psurf_aerosol_out",psurf_interp)
+        ENDIF
+      ENDIF
+      CALL scatter_omp(pt_year_mpi,pt_year)
+      CALL scatter_omp(load_out_mpi,load_out)
+      CALL scatter_omp(psurf_interp,psurf_out)
+      first=.FALSE.
+    ELSE
+      ! Scatter global field to local domain at local process
+      CALL scatter(varyear_glo1D, pt_year)
+      CALL scatter(psurf_glo1D, psurf_out)
+      CALL scatter(load_glo1D,  load_out)
+    ENDIF
+! 7) Test for negative values
+!****************************************************************************************
+    IF (MINVAL(pt_year) < 0.) THEN
+       WRITE(lunout,*) 'Warning! Negative values read from file :', fname
+    END IF
+
+  END SUBROUTINE get_aero_fromfile
+
+
+  SUBROUTINE check_err(status,text)
+    USE netcdf
+    USE print_control_mod, ONLY: lunout
+    IMPLICIT NONE
+
+    INTEGER, INTENT (IN) :: status
+    CHARACTER(len=*), INTENT (IN), OPTIONAL :: text
+
+    IF (status /= NF90_NOERR) THEN
+       WRITE(lunout,*) 'Error in get_aero_fromfile, netcdf error code = ',status
+       IF (PRESENT(text)) THEN
+          WRITE(lunout,*) 'Error in get_aero_fromfile : ',text
+       END IF
+       CALL abort_physic('get_aero_fromfile',trim(nf90_strerror(status)),1)
+    END IF
+
+  END SUBROUTINE check_err
+
+
+END MODULE readaerosol_mod
Index: DZ6/trunk/libf/phylmd/readaerosol_optic.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/readaerosol_optic.F90	(revision 5267)
+++ 	(revision )
@@ -1,220 +1,0 @@
-! $Id$
-!
-SUBROUTINE readaerosol_optic(debut, flag_aerosol, itap, rjourvrai, &
-     pdtphys, pplay, paprs, t_seri, rhcl, presnivs, &
-     mass_solu_aero, mass_solu_aero_pi, &
-     tau_aero, piz_aero, cg_aero, &
-     tausum_aero, tau3d_aero )
-
-! This routine will :
-! 1) recevie the aerosols(already read and interpolated) corresponding to flag_aerosol
-! 2) calculate the optical properties for the aerosols
-!
-  
-  USE dimphy
-  USE aero_mod
-  USE phys_local_var_mod, only: sconcso4,sconcno3,sconcoa,sconcbc,sconcss,sconcdust, &
-      concso4,concno3,concoa,concbc,concss,concdust,loadso4,loadoa,loadbc,loadss,loaddust, &
-      load_tmp1,load_tmp2,load_tmp3,load_tmp4,load_tmp5,load_tmp6,load_tmp7
-  IMPLICIT NONE
-
-! Input arguments
-!****************************************************************************************
-  LOGICAL, INTENT(IN)                      :: debut
-  INTEGER, INTENT(IN)                      :: flag_aerosol
-  INTEGER, INTENT(IN)                      :: itap
-  REAL, INTENT(IN)                         :: rjourvrai
-  REAL, INTENT(IN)                         :: pdtphys
-  REAL, DIMENSION(klon,klev), INTENT(IN)   :: pplay
-  REAL, DIMENSION(klon,klev+1), INTENT(IN) :: paprs
-  REAL, DIMENSION(klon,klev), INTENT(IN)   :: t_seri
-  REAL, DIMENSION(klon,klev), INTENT(IN)   :: rhcl   ! humidite relative ciel clair
-  REAL, DIMENSION(klev), INTENT(IN)        :: presnivs
-
-! Output arguments
-!****************************************************************************************
-  REAL, DIMENSION(klon,klev), INTENT(OUT)     :: mass_solu_aero    ! Total mass for all soluble aerosols
-  REAL, DIMENSION(klon,klev), INTENT(OUT)     :: mass_solu_aero_pi !     -"-     preindustrial values
-  REAL, DIMENSION(klon,klev,naero_grp,nbands), INTENT(OUT) :: tau_aero    ! Aerosol optical thickness
-  REAL, DIMENSION(klon,klev,naero_grp,nbands), INTENT(OUT) :: piz_aero    ! Single scattering albedo aerosol
-  REAL, DIMENSION(klon,klev,naero_grp,nbands), INTENT(OUT) :: cg_aero     ! asymmetry parameter aerosol
-!  REAL, DIMENSION(klon,nwave,naero_spc), INTENT(OUT)       :: tausum_aero
-!  REAL, DIMENSION(klon,klev,nwave,naero_spc), INTENT(OUT)  :: tau3d_aero
-!--correction mini bug OB
-  REAL, DIMENSION(klon,nwave,naero_tot), INTENT(OUT)       :: tausum_aero
-  REAL, DIMENSION(klon,klev,nwave,naero_tot), INTENT(OUT)  :: tau3d_aero
-
-! Local variables
-!****************************************************************************************
-  REAL, DIMENSION(klon)        :: aerindex ! POLDER aerosol index 
-  REAL, DIMENSION(klon,klev)   :: sulfate  ! SO4 aerosol concentration [ug/m3]
-  REAL, DIMENSION(klon,klev)   :: bcsol    ! BC soluble concentration [ug/m3]
-  REAL, DIMENSION(klon,klev)   :: bcins    ! BC insoluble concentration [ug/m3]
-  REAL, DIMENSION(klon,klev)   :: pomsol   ! POM soluble concentration [ug/m3]
-  REAL, DIMENSION(klon,klev)   :: pomins   ! POM insoluble concentration [ug/m3]
-  REAL, DIMENSION(klon,klev)   :: cidust    ! DUST aerosol concentration  [ug/m3]
-  REAL, DIMENSION(klon,klev)   :: sscoarse  ! SS Coarse concentration [ug/m3]
-  REAL, DIMENSION(klon,klev)   :: sssupco   ! SS Super Coarse concentration [ug/m3]
-  REAL, DIMENSION(klon,klev)   :: ssacu     ! SS Acumulation concentration [ug/m3]
-  REAL, DIMENSION(klon,klev)   :: sulfate_pi
-  REAL, DIMENSION(klon,klev)   :: bcsol_pi
-  REAL, DIMENSION(klon,klev)   :: bcins_pi
-  REAL, DIMENSION(klon,klev)   :: pomsol_pi
-  REAL, DIMENSION(klon,klev)   :: pomins_pi
-  REAL, DIMENSION(klon,klev)   :: cidust_pi
-  REAL, DIMENSION(klon,klev)   :: sscoarse_pi
-  REAL, DIMENSION(klon,klev)   :: sssupco_pi
-  REAL, DIMENSION(klon,klev)   :: ssacu_pi
-  REAL, DIMENSION(klon,klev)   :: pdel
-  REAL, DIMENSION(klon,klev,naero_tot) :: m_allaer
-  REAL, DIMENSION(klon,klev,naero_tot) :: m_allaer_pi !RAF  
-!  REAL, DIMENSION(klon,naero_tot)      :: fractnat_allaer !RAF delete??
-
-  INTEGER :: k, i
-  
-!****************************************************************************************
-! 1) Get aerosol mass
-!    
-!****************************************************************************************
-! Read and interpolate sulfate
-  IF ( flag_aerosol .EQ. 1 .OR. &
-       flag_aerosol .EQ. 6 ) THEN 
-
-     CALL readaerosol_interp(id_ASSO4M_phy, itap, pdtphys, rjourvrai, debut, pplay, paprs, t_seri, sulfate, sulfate_pi,loadso4)
-  ELSE
-     sulfate(:,:) = 0. ; sulfate_pi(:,:) = 0.
-     loadso4=0.
-  END IF
-
-! Read and interpolate bcsol and bcins
-  IF ( flag_aerosol .EQ. 2 .OR. &
-       flag_aerosol .EQ. 6 ) THEN 
-
-     ! Get bc aerosol distribution 
-     CALL readaerosol_interp(id_ASBCM_phy, itap, pdtphys, rjourvrai, debut, pplay, paprs, t_seri, bcsol, bcsol_pi, load_tmp1)
-     CALL readaerosol_interp(id_AIBCM_phy, itap, pdtphys, rjourvrai, debut, pplay, paprs, t_seri, bcins, bcins_pi, load_tmp2)
-     loadbc(:)=load_tmp1(:)+load_tmp2(:)
-  ELSE
-     bcsol(:,:) = 0. ; bcsol_pi(:,:) = 0.
-     bcins(:,:) = 0. ; bcins_pi(:,:) = 0.
-     loadbc=0.
-  END IF
-
-
-! Read and interpolate pomsol and pomins
-  IF ( flag_aerosol .EQ. 3 .OR. &
-       flag_aerosol .EQ. 6 ) THEN
-
-     CALL readaerosol_interp(id_ASPOMM_phy, itap, pdtphys, rjourvrai, debut, pplay, paprs, t_seri, pomsol, pomsol_pi, load_tmp3)
-     CALL readaerosol_interp(id_AIPOMM_phy, itap, pdtphys, rjourvrai, debut, pplay, paprs, t_seri, pomins, pomins_pi, load_tmp4)
-     loadoa(:)=load_tmp3(:)+load_tmp4(:)
-  ELSE
-     pomsol(:,:) = 0. ; pomsol_pi(:,:) = 0.
-     pomins(:,:) = 0. ; pomins_pi(:,:) = 0.
-     loadoa=0.
-  END IF
-
-
-! Read and interpolate csssm, ssssm, assssm
-  IF (flag_aerosol .EQ. 4 .OR. &
-      flag_aerosol .EQ. 6 ) THEN 
-
-      CALL readaerosol_interp(id_SSSSM_phy ,itap, pdtphys, rjourvrai, debut, pplay, paprs, t_seri, sssupco, sssupco_pi,  load_tmp5) 
-      CALL readaerosol_interp(id_CSSSM_phy ,itap, pdtphys, rjourvrai, debut, pplay, paprs, t_seri, sscoarse,sscoarse_pi, load_tmp6) 
-      CALL readaerosol_interp(id_ASSSM_phy ,itap, pdtphys, rjourvrai, debut, pplay, paprs, t_seri, ssacu,   ssacu_pi,    load_tmp7) 
-      loadss(:)=load_tmp5(:)+load_tmp6(:)+load_tmp7(:)
-  ELSE
-      sscoarse(:,:) = 0. ; sscoarse_pi(:,:) = 0. 
-      ssacu(:,:)    = 0. ; ssacu_pi(:,:) = 0. 
-      sssupco(:,:)  = 0. ; sssupco_pi = 0. 
-      loadss=0.
-  ENDIF
-
-! Read and interpolate cidustm
-  IF (flag_aerosol .EQ. 5 .OR.  &
-      flag_aerosol .EQ. 6 ) THEN 
-
-      CALL readaerosol_interp(id_CIDUSTM_phy, itap, pdtphys, rjourvrai, debut, pplay, paprs, t_seri, cidust, cidust_pi, loaddust) 
-  ELSE
-      cidust(:,:) = 0. ; cidust_pi(:,:) = 0. 
-      loaddust=0.
-  ENDIF
-
-!
-! Store all aerosols in one variable
-!
-  m_allaer(:,:,id_ASBCM_phy)  = bcsol(:,:)        ! ASBCM
-  m_allaer(:,:,id_ASPOMM_phy) = pomsol(:,:)       ! ASPOMM
-  m_allaer(:,:,id_ASSO4M_phy) = sulfate(:,:)      ! ASSO4M (= SO4) 
-  m_allaer(:,:,id_CSSO4M_phy) = 0.                ! CSSO4M 
-  m_allaer(:,:,id_SSSSM_phy)  = sssupco(:,:)      ! SSSSM
-  m_allaer(:,:,id_CSSSM_phy)  = sscoarse(:,:)     ! CSSSM
-  m_allaer(:,:,id_ASSSM_phy)  = ssacu(:,:)        ! ASSSM
-  m_allaer(:,:,id_CIDUSTM_phy)= cidust(:,:)       ! CIDUSTM
-  m_allaer(:,:,id_AIBCM_phy)  = bcins(:,:)        ! AIBCM
-  m_allaer(:,:,id_AIPOMM_phy) = pomins(:,:)       ! AIPOMM
-  m_allaer(:,:,id_ASNO3M_phy) = 0.0
-  m_allaer(:,:,id_CSNO3M_phy) = 0.0
-  m_allaer(:,:,id_CINO3M_phy) = 0.0
-
-!RAF
-  m_allaer_pi(:,:,id_ASBCM_phy)   = bcsol_pi(:,:)        ! ASBCM pre-ind
-  m_allaer_pi(:,:,id_ASPOMM_phy)  = pomsol_pi(:,:)       ! ASPOMM pre-ind
-  m_allaer_pi(:,:,id_ASSO4M_phy)  = sulfate_pi(:,:)      ! ASSO4M (= SO4) pre-ind
-  m_allaer_pi(:,:,id_CSSO4M_phy)  = 0.                   ! CSSO4M pre-ind
-  m_allaer_pi(:,:,id_SSSSM_phy)   = sssupco_pi(:,:)      ! SSSSM pre-ind
-  m_allaer_pi(:,:,id_CSSSM_phy)   = sscoarse_pi(:,:)     ! CSSSM pre-ind
-  m_allaer_pi(:,:,id_ASSSM_phy)   = ssacu_pi(:,:)        ! ASSSM pre-ind
-  m_allaer_pi(:,:,id_CIDUSTM_phy) = cidust_pi(:,:)       ! CIDUSTM pre-ind
-  m_allaer_pi(:,:,id_AIBCM_phy)   = bcins_pi(:,:)        ! AIBCM pre-ind
-  m_allaer_pi(:,:,id_AIPOMM_phy)  = pomins_pi(:,:)       ! AIPOMM pre-ind
-  m_allaer_pi(:,:,id_ASNO3M_phy) = 0.0
-  m_allaer_pi(:,:,id_CSNO3M_phy) = 0.0
-  m_allaer_pi(:,:,id_CINO3M_phy) = 0.0
-!
-! Calculate the total mass of all soluble aersosols
-!
-  mass_solu_aero(:,:)    = sulfate(:,:)    + bcsol(:,:)    + pomsol(:,:) + ssacu(:,:)
-  mass_solu_aero_pi(:,:) = sulfate_pi(:,:) + bcsol_pi(:,:) + pomsol_pi(:,:) + ssacu_pi(:,:)
-
-!****************************************************************************************
-! 2) Calculate optical properties for the aerosols
-!
-!****************************************************************************************
-  DO k = 1, klev
-     DO i = 1, klon
-        pdel(i,k) = paprs(i,k) - paprs (i,k+1)
-     END DO
-  END DO
-
-! RAF delete??     fractnat_allaer(:,:) = 0.
-! RAF fractnat_allaer -> m_allaer_pi
-
-     CALL aeropt_2bands( &
-          pdel, m_allaer, pdtphys, rhcl, & 
-          tau_aero, piz_aero, cg_aero,   &
-          m_allaer_pi, flag_aerosol, &
-          pplay, t_seri, presnivs) 
-     
-     ! aeropt_5wv only for validation and diagnostics.
-     CALL aeropt_5wv(                    &
-          pdel, m_allaer,                &
-          pdtphys, rhcl, aerindex,       & 
-          flag_aerosol, pplay, t_seri,   &
-          tausum_aero, tau3d_aero, presnivs)
-
-! Diagnostics calculation for CMIP5 protocol
-  sconcso4(:)=m_allaer(:,1,id_ASSO4M_phy)*1.e-9
-  sconcno3(:)=m_allaer(:,1,id_ASNO3M_phy)*1.e-9
-  sconcoa(:)=(m_allaer(:,1,id_ASPOMM_phy)+m_allaer(:,1,id_AIPOMM_phy))*1.e-9
-  sconcbc(:)=(m_allaer(:,1,id_ASBCM_phy)+m_allaer(:,1,id_AIBCM_phy))*1.e-9
-  sconcss(:)=(m_allaer(:,1,id_ASSSM_phy)+m_allaer(:,1,id_CSSSM_phy)+m_allaer(:,1,id_SSSSM_phy))*1.e-9
-  sconcdust(:)=m_allaer(:,1,id_CIDUSTM_phy)*1.e-9
-  concso4(:,:)=m_allaer(:,:,id_ASSO4M_phy)*1.e-9
-  concno3(:,:)=m_allaer(:,:,id_ASNO3M_phy)*1.e-9
-  concoa(:,:)=(m_allaer(:,:,id_ASPOMM_phy)+m_allaer(:,:,id_AIPOMM_phy))*1.e-9
-  concbc(:,:)=(m_allaer(:,:,id_ASBCM_phy)+m_allaer(:,:,id_AIBCM_phy))*1.e-9
-  concss(:,:)=(m_allaer(:,:,id_ASSSM_phy)+m_allaer(:,:,id_CSSSM_phy)+m_allaer(:,:,id_SSSSM_phy))*1.e-9
-  concdust(:,:)=m_allaer(:,:,id_CIDUSTM_phy)*1.e-9
-
-END SUBROUTINE readaerosol_optic
Index: /LMDZ6/trunk/libf/phylmd/readaerosol_optic.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/readaerosol_optic.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/readaerosol_optic.f90	(revision 5268)
@@ -0,0 +1,220 @@
+! $Id$
+!
+SUBROUTINE readaerosol_optic(debut, flag_aerosol, itap, rjourvrai, &
+     pdtphys, pplay, paprs, t_seri, rhcl, presnivs, &
+     mass_solu_aero, mass_solu_aero_pi, &
+     tau_aero, piz_aero, cg_aero, &
+     tausum_aero, tau3d_aero )
+
+! This routine will :
+! 1) recevie the aerosols(already read and interpolated) corresponding to flag_aerosol
+! 2) calculate the optical properties for the aerosols
+!
+  
+  USE dimphy
+  USE aero_mod
+  USE phys_local_var_mod, only: sconcso4,sconcno3,sconcoa,sconcbc,sconcss,sconcdust, &
+      concso4,concno3,concoa,concbc,concss,concdust,loadso4,loadoa,loadbc,loadss,loaddust, &
+      load_tmp1,load_tmp2,load_tmp3,load_tmp4,load_tmp5,load_tmp6,load_tmp7
+  IMPLICIT NONE
+
+! Input arguments
+!****************************************************************************************
+  LOGICAL, INTENT(IN)                      :: debut
+  INTEGER, INTENT(IN)                      :: flag_aerosol
+  INTEGER, INTENT(IN)                      :: itap
+  REAL, INTENT(IN)                         :: rjourvrai
+  REAL, INTENT(IN)                         :: pdtphys
+  REAL, DIMENSION(klon,klev), INTENT(IN)   :: pplay
+  REAL, DIMENSION(klon,klev+1), INTENT(IN) :: paprs
+  REAL, DIMENSION(klon,klev), INTENT(IN)   :: t_seri
+  REAL, DIMENSION(klon,klev), INTENT(IN)   :: rhcl   ! humidite relative ciel clair
+  REAL, DIMENSION(klev), INTENT(IN)        :: presnivs
+
+! Output arguments
+!****************************************************************************************
+  REAL, DIMENSION(klon,klev), INTENT(OUT)     :: mass_solu_aero    ! Total mass for all soluble aerosols
+  REAL, DIMENSION(klon,klev), INTENT(OUT)     :: mass_solu_aero_pi !     -"-     preindustrial values
+  REAL, DIMENSION(klon,klev,naero_grp,nbands), INTENT(OUT) :: tau_aero    ! Aerosol optical thickness
+  REAL, DIMENSION(klon,klev,naero_grp,nbands), INTENT(OUT) :: piz_aero    ! Single scattering albedo aerosol
+  REAL, DIMENSION(klon,klev,naero_grp,nbands), INTENT(OUT) :: cg_aero     ! asymmetry parameter aerosol
+!  REAL, DIMENSION(klon,nwave,naero_spc), INTENT(OUT)       :: tausum_aero
+!  REAL, DIMENSION(klon,klev,nwave,naero_spc), INTENT(OUT)  :: tau3d_aero
+!--correction mini bug OB
+  REAL, DIMENSION(klon,nwave,naero_tot), INTENT(OUT)       :: tausum_aero
+  REAL, DIMENSION(klon,klev,nwave,naero_tot), INTENT(OUT)  :: tau3d_aero
+
+! Local variables
+!****************************************************************************************
+  REAL, DIMENSION(klon)        :: aerindex ! POLDER aerosol index 
+  REAL, DIMENSION(klon,klev)   :: sulfate  ! SO4 aerosol concentration [ug/m3]
+  REAL, DIMENSION(klon,klev)   :: bcsol    ! BC soluble concentration [ug/m3]
+  REAL, DIMENSION(klon,klev)   :: bcins    ! BC insoluble concentration [ug/m3]
+  REAL, DIMENSION(klon,klev)   :: pomsol   ! POM soluble concentration [ug/m3]
+  REAL, DIMENSION(klon,klev)   :: pomins   ! POM insoluble concentration [ug/m3]
+  REAL, DIMENSION(klon,klev)   :: cidust    ! DUST aerosol concentration  [ug/m3]
+  REAL, DIMENSION(klon,klev)   :: sscoarse  ! SS Coarse concentration [ug/m3]
+  REAL, DIMENSION(klon,klev)   :: sssupco   ! SS Super Coarse concentration [ug/m3]
+  REAL, DIMENSION(klon,klev)   :: ssacu     ! SS Acumulation concentration [ug/m3]
+  REAL, DIMENSION(klon,klev)   :: sulfate_pi
+  REAL, DIMENSION(klon,klev)   :: bcsol_pi
+  REAL, DIMENSION(klon,klev)   :: bcins_pi
+  REAL, DIMENSION(klon,klev)   :: pomsol_pi
+  REAL, DIMENSION(klon,klev)   :: pomins_pi
+  REAL, DIMENSION(klon,klev)   :: cidust_pi
+  REAL, DIMENSION(klon,klev)   :: sscoarse_pi
+  REAL, DIMENSION(klon,klev)   :: sssupco_pi
+  REAL, DIMENSION(klon,klev)   :: ssacu_pi
+  REAL, DIMENSION(klon,klev)   :: pdel
+  REAL, DIMENSION(klon,klev,naero_tot) :: m_allaer
+  REAL, DIMENSION(klon,klev,naero_tot) :: m_allaer_pi !RAF  
+!  REAL, DIMENSION(klon,naero_tot)      :: fractnat_allaer !RAF delete??
+
+  INTEGER :: k, i
+  
+!****************************************************************************************
+! 1) Get aerosol mass
+!    
+!****************************************************************************************
+! Read and interpolate sulfate
+  IF ( flag_aerosol .EQ. 1 .OR. &
+       flag_aerosol .EQ. 6 ) THEN 
+
+     CALL readaerosol_interp(id_ASSO4M_phy, itap, pdtphys, rjourvrai, debut, pplay, paprs, t_seri, sulfate, sulfate_pi,loadso4)
+  ELSE
+     sulfate(:,:) = 0. ; sulfate_pi(:,:) = 0.
+     loadso4=0.
+  END IF
+
+! Read and interpolate bcsol and bcins
+  IF ( flag_aerosol .EQ. 2 .OR. &
+       flag_aerosol .EQ. 6 ) THEN 
+
+     ! Get bc aerosol distribution 
+     CALL readaerosol_interp(id_ASBCM_phy, itap, pdtphys, rjourvrai, debut, pplay, paprs, t_seri, bcsol, bcsol_pi, load_tmp1)
+     CALL readaerosol_interp(id_AIBCM_phy, itap, pdtphys, rjourvrai, debut, pplay, paprs, t_seri, bcins, bcins_pi, load_tmp2)
+     loadbc(:)=load_tmp1(:)+load_tmp2(:)
+  ELSE
+     bcsol(:,:) = 0. ; bcsol_pi(:,:) = 0.
+     bcins(:,:) = 0. ; bcins_pi(:,:) = 0.
+     loadbc=0.
+  END IF
+
+
+! Read and interpolate pomsol and pomins
+  IF ( flag_aerosol .EQ. 3 .OR. &
+       flag_aerosol .EQ. 6 ) THEN
+
+     CALL readaerosol_interp(id_ASPOMM_phy, itap, pdtphys, rjourvrai, debut, pplay, paprs, t_seri, pomsol, pomsol_pi, load_tmp3)
+     CALL readaerosol_interp(id_AIPOMM_phy, itap, pdtphys, rjourvrai, debut, pplay, paprs, t_seri, pomins, pomins_pi, load_tmp4)
+     loadoa(:)=load_tmp3(:)+load_tmp4(:)
+  ELSE
+     pomsol(:,:) = 0. ; pomsol_pi(:,:) = 0.
+     pomins(:,:) = 0. ; pomins_pi(:,:) = 0.
+     loadoa=0.
+  END IF
+
+
+! Read and interpolate csssm, ssssm, assssm
+  IF (flag_aerosol .EQ. 4 .OR. &
+      flag_aerosol .EQ. 6 ) THEN 
+
+      CALL readaerosol_interp(id_SSSSM_phy ,itap, pdtphys, rjourvrai, debut, pplay, paprs, t_seri, sssupco, sssupco_pi,  load_tmp5) 
+      CALL readaerosol_interp(id_CSSSM_phy ,itap, pdtphys, rjourvrai, debut, pplay, paprs, t_seri, sscoarse,sscoarse_pi, load_tmp6) 
+      CALL readaerosol_interp(id_ASSSM_phy ,itap, pdtphys, rjourvrai, debut, pplay, paprs, t_seri, ssacu,   ssacu_pi,    load_tmp7) 
+      loadss(:)=load_tmp5(:)+load_tmp6(:)+load_tmp7(:)
+  ELSE
+      sscoarse(:,:) = 0. ; sscoarse_pi(:,:) = 0. 
+      ssacu(:,:)    = 0. ; ssacu_pi(:,:) = 0. 
+      sssupco(:,:)  = 0. ; sssupco_pi = 0. 
+      loadss=0.
+  ENDIF
+
+! Read and interpolate cidustm
+  IF (flag_aerosol .EQ. 5 .OR.  &
+      flag_aerosol .EQ. 6 ) THEN 
+
+      CALL readaerosol_interp(id_CIDUSTM_phy, itap, pdtphys, rjourvrai, debut, pplay, paprs, t_seri, cidust, cidust_pi, loaddust) 
+  ELSE
+      cidust(:,:) = 0. ; cidust_pi(:,:) = 0. 
+      loaddust=0.
+  ENDIF
+
+!
+! Store all aerosols in one variable
+!
+  m_allaer(:,:,id_ASBCM_phy)  = bcsol(:,:)        ! ASBCM
+  m_allaer(:,:,id_ASPOMM_phy) = pomsol(:,:)       ! ASPOMM
+  m_allaer(:,:,id_ASSO4M_phy) = sulfate(:,:)      ! ASSO4M (= SO4) 
+  m_allaer(:,:,id_CSSO4M_phy) = 0.                ! CSSO4M 
+  m_allaer(:,:,id_SSSSM_phy)  = sssupco(:,:)      ! SSSSM
+  m_allaer(:,:,id_CSSSM_phy)  = sscoarse(:,:)     ! CSSSM
+  m_allaer(:,:,id_ASSSM_phy)  = ssacu(:,:)        ! ASSSM
+  m_allaer(:,:,id_CIDUSTM_phy)= cidust(:,:)       ! CIDUSTM
+  m_allaer(:,:,id_AIBCM_phy)  = bcins(:,:)        ! AIBCM
+  m_allaer(:,:,id_AIPOMM_phy) = pomins(:,:)       ! AIPOMM
+  m_allaer(:,:,id_ASNO3M_phy) = 0.0
+  m_allaer(:,:,id_CSNO3M_phy) = 0.0
+  m_allaer(:,:,id_CINO3M_phy) = 0.0
+
+!RAF
+  m_allaer_pi(:,:,id_ASBCM_phy)   = bcsol_pi(:,:)        ! ASBCM pre-ind
+  m_allaer_pi(:,:,id_ASPOMM_phy)  = pomsol_pi(:,:)       ! ASPOMM pre-ind
+  m_allaer_pi(:,:,id_ASSO4M_phy)  = sulfate_pi(:,:)      ! ASSO4M (= SO4) pre-ind
+  m_allaer_pi(:,:,id_CSSO4M_phy)  = 0.                   ! CSSO4M pre-ind
+  m_allaer_pi(:,:,id_SSSSM_phy)   = sssupco_pi(:,:)      ! SSSSM pre-ind
+  m_allaer_pi(:,:,id_CSSSM_phy)   = sscoarse_pi(:,:)     ! CSSSM pre-ind
+  m_allaer_pi(:,:,id_ASSSM_phy)   = ssacu_pi(:,:)        ! ASSSM pre-ind
+  m_allaer_pi(:,:,id_CIDUSTM_phy) = cidust_pi(:,:)       ! CIDUSTM pre-ind
+  m_allaer_pi(:,:,id_AIBCM_phy)   = bcins_pi(:,:)        ! AIBCM pre-ind
+  m_allaer_pi(:,:,id_AIPOMM_phy)  = pomins_pi(:,:)       ! AIPOMM pre-ind
+  m_allaer_pi(:,:,id_ASNO3M_phy) = 0.0
+  m_allaer_pi(:,:,id_CSNO3M_phy) = 0.0
+  m_allaer_pi(:,:,id_CINO3M_phy) = 0.0
+!
+! Calculate the total mass of all soluble aersosols
+!
+  mass_solu_aero(:,:)    = sulfate(:,:)    + bcsol(:,:)    + pomsol(:,:) + ssacu(:,:)
+  mass_solu_aero_pi(:,:) = sulfate_pi(:,:) + bcsol_pi(:,:) + pomsol_pi(:,:) + ssacu_pi(:,:)
+
+!****************************************************************************************
+! 2) Calculate optical properties for the aerosols
+!
+!****************************************************************************************
+  DO k = 1, klev
+     DO i = 1, klon
+        pdel(i,k) = paprs(i,k) - paprs (i,k+1)
+     END DO
+  END DO
+
+! RAF delete??     fractnat_allaer(:,:) = 0.
+! RAF fractnat_allaer -> m_allaer_pi
+
+     CALL aeropt_2bands( &
+          pdel, m_allaer, pdtphys, rhcl, & 
+          tau_aero, piz_aero, cg_aero,   &
+          m_allaer_pi, flag_aerosol, &
+          pplay, t_seri, presnivs) 
+     
+     ! aeropt_5wv only for validation and diagnostics.
+     CALL aeropt_5wv(                    &
+          pdel, m_allaer,                &
+          pdtphys, rhcl, aerindex,       & 
+          flag_aerosol, pplay, t_seri,   &
+          tausum_aero, tau3d_aero, presnivs)
+
+! Diagnostics calculation for CMIP5 protocol
+  sconcso4(:)=m_allaer(:,1,id_ASSO4M_phy)*1.e-9
+  sconcno3(:)=m_allaer(:,1,id_ASNO3M_phy)*1.e-9
+  sconcoa(:)=(m_allaer(:,1,id_ASPOMM_phy)+m_allaer(:,1,id_AIPOMM_phy))*1.e-9
+  sconcbc(:)=(m_allaer(:,1,id_ASBCM_phy)+m_allaer(:,1,id_AIBCM_phy))*1.e-9
+  sconcss(:)=(m_allaer(:,1,id_ASSSM_phy)+m_allaer(:,1,id_CSSSM_phy)+m_allaer(:,1,id_SSSSM_phy))*1.e-9
+  sconcdust(:)=m_allaer(:,1,id_CIDUSTM_phy)*1.e-9
+  concso4(:,:)=m_allaer(:,:,id_ASSO4M_phy)*1.e-9
+  concno3(:,:)=m_allaer(:,:,id_ASNO3M_phy)*1.e-9
+  concoa(:,:)=(m_allaer(:,:,id_ASPOMM_phy)+m_allaer(:,:,id_AIPOMM_phy))*1.e-9
+  concbc(:,:)=(m_allaer(:,:,id_ASBCM_phy)+m_allaer(:,:,id_AIBCM_phy))*1.e-9
+  concss(:,:)=(m_allaer(:,:,id_ASSSM_phy)+m_allaer(:,:,id_CSSSM_phy)+m_allaer(:,:,id_SSSSM_phy))*1.e-9
+  concdust(:,:)=m_allaer(:,:,id_CIDUSTM_phy)*1.e-9
+
+END SUBROUTINE readaerosol_optic
Index: DZ6/trunk/libf/phylmd/readaerosolstrato.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/readaerosolstrato.F90	(revision 5267)
+++ 	(revision )
@@ -1,205 +1,0 @@
-subroutine readaerosolstrato(debut)
-
-    use netcdf95, only: nf95_close, nf95_gw_var, nf95_inq_dimid, & 
-                        nf95_inq_varid, nf95_open
-    use netcdf, only: nf90_get_var, nf90_noerr, nf90_nowrite
-
-    USE phys_cal_mod, ONLY : mth_cur
-    USE mod_grid_phy_lmdz, ONLY: nbp_lon, nbp_lat, klon_glo, &
-                                 grid2dto1d_glo, grid_type, unstructured
-    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
-    USE mod_phys_lmdz_omp_data, ONLY :  is_omp_root
-    USE mod_phys_lmdz_para 
-    USE phys_state_var_mod
-    USE phys_local_var_mod
-    USE aero_mod
-    USE dimphy
-    USE print_control_mod, ONLY: prt_level,lunout
-    USE lmdz_xios
-    implicit none
-
-    include "YOMCST.h"
-
-! Variable input
-    logical debut
-
-! Variables locales
-    integer n_lat   ! number of latitudes in the input data
-    integer n_lon   ! number of longitudes in the input data
-    integer n_lev   ! number of levels in the input data
-    integer n_month ! number of months in the input data
-    real, allocatable:: latitude(:)
-    real, allocatable:: longitude(:)
-    real, allocatable:: time(:)
-    real, allocatable:: lev(:)
-    integer i, k, band, wave
-    integer, save :: mth_pre=1
-!$OMP THREADPRIVATE(mth_pre)
-
-    real, allocatable, dimension(:,:), save :: tau_aer_strat
-!$OMP THREADPRIVATE(tau_aer_strat)
-
-! Champs reconstitues
-    real, allocatable:: tauaerstrat(:, :, :, :)
-    real, allocatable:: tauaerstrat_mois(:, :, :)
-    real, allocatable:: tauaerstrat_mois_glo(:, :)
-    real, allocatable:: tau_aer_strat_mpi(:, :)
-
-! For NetCDF:
-    integer ncid_in  ! IDs for input files
-    integer varid, ncerr
-
-! Stratospheric aerosols optical properties
-! alpha_strat over the 2 bands is normalised by the 550 nm extinction coefficient
-! alpha_strat_wave is *not* normalised by the 550 nm extinction coefficient
-    real, dimension(nbands) :: alpha_strat, piz_strat, cg_strat
-    data alpha_strat/0.9922547, 0.7114912 /
-    data piz_strat  /0.9999998, 0.99762493/
-    data cg_strat   /0.73107845,0.73229635/
-    real, dimension(nwave_sw) :: alpha_strat_wave
-    data alpha_strat_wave/3.36780953,3.34667683,3.20444202,3.0293026,2.82108808/
-
-    CHARACTER (len = 20)                      :: modname = 'readaerosolstrato'
-    CHARACTER (len = 80)                      :: abort_message
-
-!--------------------------------------------------------
-
-    IF (.not.ALLOCATED(tau_aer_strat)) ALLOCATE(tau_aer_strat(klon,klev))
-
-!--only read file if beginning of run or start of new month
-    IF (debut.OR.mth_cur.NE.mth_pre) THEN
-
-!--only root reads
-    IF (is_mpi_root.AND.is_omp_root) THEN
-
-    IF (nbands.NE.2) THEN 
-        abort_message='nbands doit etre egal a 2 dans readaerosolstrat'
-        CALL abort_physic(modname,abort_message,1)
-    ENDIF
-
-    CALL nf95_open("taustrat.nc", nf90_nowrite, ncid_in)
-
-    CALL nf95_inq_varid(ncid_in, "LEV", varid)
-    CALL nf95_gw_var(ncid_in, varid, lev)
-    n_lev = size(lev)
-    IF (n_lev.NE.klev) THEN 
-       abort_message='Le nombre de niveaux n est pas egal a klev'
-       CALL abort_physic(modname,abort_message,1)
-    ENDIF
-
-    CALL nf95_inq_varid(ncid_in, "LAT", varid)
-    CALL nf95_gw_var(ncid_in, varid, latitude)
-    n_lat = size(latitude)
-    WRITE(lunout,*) 'LAT aerosol strato=', n_lat, latitude
-    IF (grid_type/=unstructured) THEN
-      IF (n_lat.NE.nbp_lat) THEN 
-         abort_message='Le nombre de lat n est pas egal a nbp_lat'
-         CALL abort_physic(modname,abort_message,1)
-      ENDIF
-    ENDIF
-    
-    CALL nf95_inq_varid(ncid_in, "LON", varid)
-    CALL nf95_gw_var(ncid_in, varid, longitude)
-    n_lon = size(longitude)
-    IF (grid_type/=unstructured) THEN
-      WRITE(lunout,*) 'LON aerosol strato=', n_lon, longitude
-      IF (n_lon.NE.nbp_lon) THEN 
-         abort_message='Le nombre de lon n est pas egal a nbp_lon'
-         CALL abort_physic(modname,abort_message,1)
-      ENDIF
-    ENDIF
-    
-    CALL nf95_inq_varid(ncid_in, "TIME", varid)
-    CALL nf95_gw_var(ncid_in, varid, time)
-    n_month = size(time)
-    WRITE(lunout,*) 'TIME aerosol strato=', n_month, time
-    IF (n_month.NE.12) THEN 
-       abort_message='Le nombre de month n est pas egal a 12'
-       CALL abort_physic(modname,abort_message,1)
-    ENDIF
-
-    IF (.not.ALLOCATED(tauaerstrat))          ALLOCATE(tauaerstrat(n_lon, n_lat, n_lev, n_month))
-    IF (.not.ALLOCATED(tauaerstrat_mois))     ALLOCATE(tauaerstrat_mois(n_lon, n_lat, n_lev))
-    IF (.not.ALLOCATED(tauaerstrat_mois_glo)) ALLOCATE(tauaerstrat_mois_glo(klon_glo, n_lev))
-
-!--reading stratospheric AOD at 550 nm
-    CALL nf95_inq_varid(ncid_in, "TAUSTRAT", varid)
-    ncerr = nf90_get_var(ncid_in, varid, tauaerstrat)
-    WRITE(lunout,*) 'code erreur readaerosolstrato=', ncerr, varid
-
-    CALL nf95_close(ncid_in)
-
-!---select the correct month
-    IF (mth_cur.LT.1.OR.mth_cur.GT.12) THEN
-     WRITE(lunout,*) 'probleme avec le mois dans readaerosolstrat =', mth_cur
-    ENDIF
-    tauaerstrat_mois(:,:,:) = tauaerstrat(:,:,:,mth_cur)
-
-!---reduce to a klon_glo grid 
-    CALL grid2dTo1d_glo(tauaerstrat_mois,tauaerstrat_mois_glo)
-
-    ELSE
-      ALLOCATE(tauaerstrat_mois(0,0,0))
-    ENDIF !--is_mpi_root and is_omp_root
-
-!$OMP BARRIER
-
-    IF (grid_type==unstructured) THEN
-      IF (is_omp_master) THEN
-        CALL xios_send_field("taustrat_in",tauaerstrat_mois)
-        ALLOCATE(tau_aer_strat_mpi(klon_mpi, klev))
-        CALL xios_recv_field("taustrat_out",tau_aer_strat_mpi)
-      ELSE
-        ALLOCATE(tau_aer_strat_mpi(0,0))
-      ENDIF
-      CALL scatter_omp(tau_aer_strat_mpi,tau_aer_strat)
-    ELSE  
-!--scatter on all proc
-      CALL scatter(tauaerstrat_mois_glo,tau_aer_strat)
-    ENDIF
-
-!--keep memory of previous month
-    mth_pre=mth_cur
-!
-    IF (is_mpi_root.AND.is_omp_root) THEN
-!
-    DEALLOCATE(tauaerstrat)
-    DEALLOCATE(tauaerstrat_mois)
-    DEALLOCATE(tauaerstrat_mois_glo)
-!
-    ENDIF !-is_mpi_root and is_omp_root
-
-!$OMP BARRIER
-
-    ENDIF !--debut ou nouveau mois
-
-!--total vertical aod at the 6 wavelengths
-    DO wave=1, nwave_sw
-    DO k=1, klev
-    tausum_aero(:,wave,id_STRAT_phy)=tausum_aero(:,wave,id_STRAT_phy)+tau_aer_strat(:,k)*alpha_strat_wave(wave)/alpha_strat_wave(2)
-    ENDDO
-    ENDDO
-
-!--weighted average for cg, piz and tau, adding strat aerosols on top of tropospheric ones
-    DO band=1, nbands
-!--anthropogenic aerosols bands 1 and 2
-    cg_aero(:,:,3,band)  = ( cg_aero(:,:,3,band)*piz_aero(:,:,3,band)*tau_aero(:,:,3,band) +          &
-                             cg_strat(band)*piz_strat(band)*alpha_strat(band)*tau_aer_strat(:,:) ) /  &
-                             MAX( piz_aero(:,:,3,band)*tau_aero(:,:,3,band) +                         &
-                                  piz_strat(band)*alpha_strat(band)*tau_aer_strat(:,:), 1.e-15 )
-    piz_aero(:,:,3,band)  = ( piz_aero(:,:,3,band)*tau_aero(:,:,3,band) +                             &
-                              piz_strat(band)*alpha_strat(band)*tau_aer_strat(:,:) ) /                &
-                              MAX( tau_aero(:,:,3,band) + alpha_strat(band)*tau_aer_strat(:,:), 1.e-15 )
-    tau_aero(:,:,3,band)  = tau_aero(:,:,3,band) + alpha_strat(band)*tau_aer_strat(:,:)
-!--natural aerosols bands 1 and 2
-    cg_aero(:,:,2,band)  = ( cg_aero(:,:,2,band)*piz_aero(:,:,2,band)*tau_aero(:,:,2,band) +          &
-                             cg_strat(band)*piz_strat(band)*alpha_strat(band)*tau_aer_strat(:,:) ) /  &
-                             MAX( piz_aero(:,:,2,band)*tau_aero(:,:,2,band) +                         &
-                                  piz_strat(band)*alpha_strat(band)*tau_aer_strat(:,:), 1.e-15 )
-    piz_aero(:,:,2,band)  = ( piz_aero(:,:,2,band)*tau_aero(:,:,2,band) +                             & 
-                              piz_strat(band)*alpha_strat(band)*tau_aer_strat(:,:) ) /                &
-                              MAX( tau_aero(:,:,2,band) + alpha_strat(band)*tau_aer_strat(:,:),1.e-15 )
-    tau_aero(:,:,2,band)  = tau_aero(:,:,2,band) + alpha_strat(band)*tau_aer_strat(:,:)
-    ENDDO
-
-end subroutine readaerosolstrato
Index: /LMDZ6/trunk/libf/phylmd/readaerosolstrato.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/readaerosolstrato.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/readaerosolstrato.f90	(revision 5268)
@@ -0,0 +1,205 @@
+subroutine readaerosolstrato(debut)
+
+    use netcdf95, only: nf95_close, nf95_gw_var, nf95_inq_dimid, & 
+                        nf95_inq_varid, nf95_open
+    use netcdf, only: nf90_get_var, nf90_noerr, nf90_nowrite
+
+    USE phys_cal_mod, ONLY : mth_cur
+    USE mod_grid_phy_lmdz, ONLY: nbp_lon, nbp_lat, klon_glo, &
+                                 grid2dto1d_glo, grid_type, unstructured
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    USE mod_phys_lmdz_omp_data, ONLY :  is_omp_root
+    USE mod_phys_lmdz_para 
+    USE phys_state_var_mod
+    USE phys_local_var_mod
+    USE aero_mod
+    USE dimphy
+    USE print_control_mod, ONLY: prt_level,lunout
+    USE lmdz_xios
+    implicit none
+
+    include "YOMCST.h"
+
+! Variable input
+    logical debut
+
+! Variables locales
+    integer n_lat   ! number of latitudes in the input data
+    integer n_lon   ! number of longitudes in the input data
+    integer n_lev   ! number of levels in the input data
+    integer n_month ! number of months in the input data
+    real, allocatable:: latitude(:)
+    real, allocatable:: longitude(:)
+    real, allocatable:: time(:)
+    real, allocatable:: lev(:)
+    integer i, k, band, wave
+    integer, save :: mth_pre=1
+!$OMP THREADPRIVATE(mth_pre)
+
+    real, allocatable, dimension(:,:), save :: tau_aer_strat
+!$OMP THREADPRIVATE(tau_aer_strat)
+
+! Champs reconstitues
+    real, allocatable:: tauaerstrat(:, :, :, :)
+    real, allocatable:: tauaerstrat_mois(:, :, :)
+    real, allocatable:: tauaerstrat_mois_glo(:, :)
+    real, allocatable:: tau_aer_strat_mpi(:, :)
+
+! For NetCDF:
+    integer ncid_in  ! IDs for input files
+    integer varid, ncerr
+
+! Stratospheric aerosols optical properties
+! alpha_strat over the 2 bands is normalised by the 550 nm extinction coefficient
+! alpha_strat_wave is *not* normalised by the 550 nm extinction coefficient
+    real, dimension(nbands) :: alpha_strat, piz_strat, cg_strat
+    data alpha_strat/0.9922547, 0.7114912 /
+    data piz_strat  /0.9999998, 0.99762493/
+    data cg_strat   /0.73107845,0.73229635/
+    real, dimension(nwave_sw) :: alpha_strat_wave
+    data alpha_strat_wave/3.36780953,3.34667683,3.20444202,3.0293026,2.82108808/
+
+    CHARACTER (len = 20)                      :: modname = 'readaerosolstrato'
+    CHARACTER (len = 80)                      :: abort_message
+
+!--------------------------------------------------------
+
+    IF (.not.ALLOCATED(tau_aer_strat)) ALLOCATE(tau_aer_strat(klon,klev))
+
+!--only read file if beginning of run or start of new month
+    IF (debut.OR.mth_cur.NE.mth_pre) THEN
+
+!--only root reads
+    IF (is_mpi_root.AND.is_omp_root) THEN
+
+    IF (nbands.NE.2) THEN 
+        abort_message='nbands doit etre egal a 2 dans readaerosolstrat'
+        CALL abort_physic(modname,abort_message,1)
+    ENDIF
+
+    CALL nf95_open("taustrat.nc", nf90_nowrite, ncid_in)
+
+    CALL nf95_inq_varid(ncid_in, "LEV", varid)
+    CALL nf95_gw_var(ncid_in, varid, lev)
+    n_lev = size(lev)
+    IF (n_lev.NE.klev) THEN 
+       abort_message='Le nombre de niveaux n est pas egal a klev'
+       CALL abort_physic(modname,abort_message,1)
+    ENDIF
+
+    CALL nf95_inq_varid(ncid_in, "LAT", varid)
+    CALL nf95_gw_var(ncid_in, varid, latitude)
+    n_lat = size(latitude)
+    WRITE(lunout,*) 'LAT aerosol strato=', n_lat, latitude
+    IF (grid_type/=unstructured) THEN
+      IF (n_lat.NE.nbp_lat) THEN 
+         abort_message='Le nombre de lat n est pas egal a nbp_lat'
+         CALL abort_physic(modname,abort_message,1)
+      ENDIF
+    ENDIF
+    
+    CALL nf95_inq_varid(ncid_in, "LON", varid)
+    CALL nf95_gw_var(ncid_in, varid, longitude)
+    n_lon = size(longitude)
+    IF (grid_type/=unstructured) THEN
+      WRITE(lunout,*) 'LON aerosol strato=', n_lon, longitude
+      IF (n_lon.NE.nbp_lon) THEN 
+         abort_message='Le nombre de lon n est pas egal a nbp_lon'
+         CALL abort_physic(modname,abort_message,1)
+      ENDIF
+    ENDIF
+    
+    CALL nf95_inq_varid(ncid_in, "TIME", varid)
+    CALL nf95_gw_var(ncid_in, varid, time)
+    n_month = size(time)
+    WRITE(lunout,*) 'TIME aerosol strato=', n_month, time
+    IF (n_month.NE.12) THEN 
+       abort_message='Le nombre de month n est pas egal a 12'
+       CALL abort_physic(modname,abort_message,1)
+    ENDIF
+
+    IF (.not.ALLOCATED(tauaerstrat))          ALLOCATE(tauaerstrat(n_lon, n_lat, n_lev, n_month))
+    IF (.not.ALLOCATED(tauaerstrat_mois))     ALLOCATE(tauaerstrat_mois(n_lon, n_lat, n_lev))
+    IF (.not.ALLOCATED(tauaerstrat_mois_glo)) ALLOCATE(tauaerstrat_mois_glo(klon_glo, n_lev))
+
+!--reading stratospheric AOD at 550 nm
+    CALL nf95_inq_varid(ncid_in, "TAUSTRAT", varid)
+    ncerr = nf90_get_var(ncid_in, varid, tauaerstrat)
+    WRITE(lunout,*) 'code erreur readaerosolstrato=', ncerr, varid
+
+    CALL nf95_close(ncid_in)
+
+!---select the correct month
+    IF (mth_cur.LT.1.OR.mth_cur.GT.12) THEN
+     WRITE(lunout,*) 'probleme avec le mois dans readaerosolstrat =', mth_cur
+    ENDIF
+    tauaerstrat_mois(:,:,:) = tauaerstrat(:,:,:,mth_cur)
+
+!---reduce to a klon_glo grid 
+    CALL grid2dTo1d_glo(tauaerstrat_mois,tauaerstrat_mois_glo)
+
+    ELSE
+      ALLOCATE(tauaerstrat_mois(0,0,0))
+    ENDIF !--is_mpi_root and is_omp_root
+
+!$OMP BARRIER
+
+    IF (grid_type==unstructured) THEN
+      IF (is_omp_master) THEN
+        CALL xios_send_field("taustrat_in",tauaerstrat_mois)
+        ALLOCATE(tau_aer_strat_mpi(klon_mpi, klev))
+        CALL xios_recv_field("taustrat_out",tau_aer_strat_mpi)
+      ELSE
+        ALLOCATE(tau_aer_strat_mpi(0,0))
+      ENDIF
+      CALL scatter_omp(tau_aer_strat_mpi,tau_aer_strat)
+    ELSE  
+!--scatter on all proc
+      CALL scatter(tauaerstrat_mois_glo,tau_aer_strat)
+    ENDIF
+
+!--keep memory of previous month
+    mth_pre=mth_cur
+!
+    IF (is_mpi_root.AND.is_omp_root) THEN
+!
+    DEALLOCATE(tauaerstrat)
+    DEALLOCATE(tauaerstrat_mois)
+    DEALLOCATE(tauaerstrat_mois_glo)
+!
+    ENDIF !-is_mpi_root and is_omp_root
+
+!$OMP BARRIER
+
+    ENDIF !--debut ou nouveau mois
+
+!--total vertical aod at the 6 wavelengths
+    DO wave=1, nwave_sw
+    DO k=1, klev
+    tausum_aero(:,wave,id_STRAT_phy)=tausum_aero(:,wave,id_STRAT_phy)+tau_aer_strat(:,k)*alpha_strat_wave(wave)/alpha_strat_wave(2)
+    ENDDO
+    ENDDO
+
+!--weighted average for cg, piz and tau, adding strat aerosols on top of tropospheric ones
+    DO band=1, nbands
+!--anthropogenic aerosols bands 1 and 2
+    cg_aero(:,:,3,band)  = ( cg_aero(:,:,3,band)*piz_aero(:,:,3,band)*tau_aero(:,:,3,band) +          &
+                             cg_strat(band)*piz_strat(band)*alpha_strat(band)*tau_aer_strat(:,:) ) /  &
+                             MAX( piz_aero(:,:,3,band)*tau_aero(:,:,3,band) +                         &
+                                  piz_strat(band)*alpha_strat(band)*tau_aer_strat(:,:), 1.e-15 )
+    piz_aero(:,:,3,band)  = ( piz_aero(:,:,3,band)*tau_aero(:,:,3,band) +                             &
+                              piz_strat(band)*alpha_strat(band)*tau_aer_strat(:,:) ) /                &
+                              MAX( tau_aero(:,:,3,band) + alpha_strat(band)*tau_aer_strat(:,:), 1.e-15 )
+    tau_aero(:,:,3,band)  = tau_aero(:,:,3,band) + alpha_strat(band)*tau_aer_strat(:,:)
+!--natural aerosols bands 1 and 2
+    cg_aero(:,:,2,band)  = ( cg_aero(:,:,2,band)*piz_aero(:,:,2,band)*tau_aero(:,:,2,band) +          &
+                             cg_strat(band)*piz_strat(band)*alpha_strat(band)*tau_aer_strat(:,:) ) /  &
+                             MAX( piz_aero(:,:,2,band)*tau_aero(:,:,2,band) +                         &
+                                  piz_strat(band)*alpha_strat(band)*tau_aer_strat(:,:), 1.e-15 )
+    piz_aero(:,:,2,band)  = ( piz_aero(:,:,2,band)*tau_aero(:,:,2,band) +                             & 
+                              piz_strat(band)*alpha_strat(band)*tau_aer_strat(:,:) ) /                &
+                              MAX( tau_aero(:,:,2,band) + alpha_strat(band)*tau_aer_strat(:,:),1.e-15 )
+    tau_aero(:,:,2,band)  = tau_aero(:,:,2,band) + alpha_strat(band)*tau_aer_strat(:,:)
+    ENDDO
+
+end subroutine readaerosolstrato
Index: DZ6/trunk/libf/phylmd/readaerosolstrato_m.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/readaerosolstrato_m.F90	(revision 5267)
+++ 	(revision )
@@ -1,138 +1,0 @@
-MODULE readaerosolstrato_m
-
-
-CONTAINS
-
-  SUBROUTINE init_readaerosolstrato(flag_aerosol_strat)
-  USE mod_grid_phy_lmdz, ONLY: grid_type, unstructured
-  IMPLICIT NONE
-  INTEGER,INTENT(IN) :: flag_aerosol_strat
-    
-    IF (grid_type==unstructured)  THEN 
-   
-      IF (flag_aerosol_strat == 1) THEN
-        CALL init_readaerosolstrato1
-      ELSE IF (flag_aerosol_strat == 2) THEN
-        CALL init_readaerosolstrato2
-      ENDIF
-  
-    ENDIF
-  
-  END SUBROUTINE init_readaerosolstrato
-  
-
-
-SUBROUTINE init_readaerosolstrato1
-  USE netcdf
-  USE netcdf95, ONLY: nf95_close, nf95_gw_var, nf95_inq_dimid, & 
-                      nf95_inq_varid, nf95_open
-  USE mod_phys_lmdz_para
-  USE lmdz_xios
-!  USE YOERAD, ONLY : NLW
-  IMPLICIT NONE
-  REAL, allocatable:: latitude(:)
-  REAL, allocatable:: longitude(:)
-  INTEGER :: nlat, nlon
-  REAL    :: null_array(0)
-  INTEGER :: ncid_in, varid
-  
-  IF (using_xios) THEN
-    IF (is_omp_master) THEN  
-      IF (is_mpi_root) THEN
-        CALL nf95_open("taustrat.nc", nf90_nowrite, ncid_in)
-        CALL nf95_inq_varid(ncid_in, "LAT", varid)
-        CALL nf95_gw_var(ncid_in, varid, latitude)
-        CALL nf95_inq_varid(ncid_in, "LON", varid)
-        CALL nf95_gw_var(ncid_in, varid, longitude)
-        CALL nf95_close(ncid_in)
-        nlat=size(latitude)
-        nlon=size(longitude)
-      ENDIF
-      CALL bcast_mpi(nlat)
-      CALL bcast_mpi(nlon)
-
-      IF (is_mpi_root) THEN
-        CALL xios_set_domain_attr("domain_taustrat",nj_glo=nlat, nj=nlat, jbegin=0, latvalue_1d=latitude)
-        CALL xios_set_domain_attr("domain_taustrat",ni_glo=nlon, ni=nlon, ibegin=0, lonvalue_1d = longitude)
-       ELSE
-        CALL xios_set_domain_attr("domain_taustrat",nj_glo=nlat, nj=0, jbegin=0, latvalue_1d=null_array )
-        CALL xios_set_domain_attr("domain_taustrat",ni_glo=nlon, ni=0, ibegin=0, lonvalue_1d=null_array)
-      ENDIF    
-  
-      CALL xios_set_fieldgroup_attr("aerosol_strato1",enabled=.TRUE.)
-    ENDIF
-    
-  ENDIF
-END SUBROUTINE init_readaerosolstrato1
-  
-SUBROUTINE init_readaerosolstrato2
-  USE netcdf
-  USE netcdf95, ONLY: nf95_close, nf95_gw_var, nf95_inq_dimid, & 
-                      nf95_inq_varid, nf95_open
-  USE mod_phys_lmdz_para
-  USE lmdz_xios
-!  USE YOERAD, ONLY : NLW
-  IMPLICIT NONE
-  REAL, allocatable:: latitude(:)
-  REAL, allocatable:: wav(:)
-  INTEGER :: nlat,n_wav
-  REAL    :: null_array(0)
-  INTEGER :: ncid_in, varid
-  
-  IF (using_xios) THEN
-    IF (is_omp_master) THEN    
-      IF (is_mpi_root) THEN
-        CALL nf95_open("tauswstrat.2D.nc", nf90_nowrite, ncid_in)
-        CALL nf95_inq_varid(ncid_in, "LAT", varid)
-        CALL nf95_gw_var(ncid_in, varid, latitude)
-        CALL nf95_inq_varid(ncid_in, "WAV", varid)
-        CALL nf95_gw_var(ncid_in, varid, wav)
-        CALL nf95_close(ncid_in)
-        nlat=size(latitude)
-        n_wav = size(wav)
-      ENDIF
-      CALL bcast_mpi(nlat)
-      CALL bcast_mpi(n_wav)
-
-      IF (is_mpi_root) THEN
-        CALL xios_set_domain_attr("domain_tauswstrat",nj_glo=nlat, nj=nlat, jbegin=0, latvalue_1d=latitude)
-        CALL xios_set_domain_attr("domain_tauswstrat",ni_glo=8, ni=8, ibegin=0, lonvalue_1d = (/ 0.,45.,90.,135.,180.,225.,270., 315. /))
-        DEALLOCATE(latitude)
-      ELSE
-        CALL xios_set_domain_attr("domain_tauswstrat",nj_glo=nlat, nj=0, jbegin=0, latvalue_1d=null_array )
-        CALL xios_set_domain_attr("domain_tauswstrat",ni_glo=8, ni=0, ibegin=0, lonvalue_1d=null_array)
-      ENDIF    
-      CALL  xios_set_axis_attr("nsw", n_glo=n_wav)
-    
-      IF (is_mpi_root) THEN
-        CALL nf95_open("taulwstrat.2D.nc", nf90_nowrite, ncid_in)
-        CALL nf95_inq_varid(ncid_in, "LAT", varid)
-        CALL nf95_gw_var(ncid_in, varid, latitude)
-        CALL nf95_inq_varid(ncid_in, "WAV", varid)
-        CALL nf95_gw_var(ncid_in, varid, wav)
-        CALL nf95_close(ncid_in)
-        nlat=size(latitude)
-        n_wav = size(wav)
-      ENDIF
-      CALL bcast_mpi(nlat)
-      CALL bcast_mpi(n_wav)
-
-      IF (is_mpi_root) THEN
-        CALL xios_set_domain_attr("domain_taulwstrat",nj_glo=nlat, nj=nlat, jbegin=0, latvalue_1d=latitude)
-        CALL xios_set_domain_attr("domain_taulwstrat",ni_glo=8, ni=8, ibegin=0, lonvalue_1d = (/ 0.,45.,90.,135.,180.,225.,270., 315. /))
-        DEALLOCATE(latitude)
-      ELSE
-        CALL xios_set_domain_attr("domain_taulwstrat",nj_glo=nlat, nj=0, jbegin=0, latvalue_1d=null_array )
-        CALL xios_set_domain_attr("domain_taulwstrat",ni_glo=8, ni=0, ibegin=0, lonvalue_1d=null_array)
-      ENDIF    
-    
-      CALL  xios_set_axis_attr("nlw", n_glo=n_wav)
-      CALL xios_set_fieldgroup_attr("aerosol_strato2",enabled=.TRUE.)
-
-    ENDIF
-  ENDIF    
-END SUBROUTINE init_readaerosolstrato2
-  
-
-END MODULE readaerosolstrato_m
-
Index: /LMDZ6/trunk/libf/phylmd/readaerosolstrato_m.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/readaerosolstrato_m.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/readaerosolstrato_m.f90	(revision 5268)
@@ -0,0 +1,138 @@
+MODULE readaerosolstrato_m
+
+
+CONTAINS
+
+  SUBROUTINE init_readaerosolstrato(flag_aerosol_strat)
+  USE mod_grid_phy_lmdz, ONLY: grid_type, unstructured
+  IMPLICIT NONE
+  INTEGER,INTENT(IN) :: flag_aerosol_strat
+    
+    IF (grid_type==unstructured)  THEN 
+   
+      IF (flag_aerosol_strat == 1) THEN
+        CALL init_readaerosolstrato1
+      ELSE IF (flag_aerosol_strat == 2) THEN
+        CALL init_readaerosolstrato2
+      ENDIF
+  
+    ENDIF
+  
+  END SUBROUTINE init_readaerosolstrato
+  
+
+
+SUBROUTINE init_readaerosolstrato1
+  USE netcdf
+  USE netcdf95, ONLY: nf95_close, nf95_gw_var, nf95_inq_dimid, & 
+                      nf95_inq_varid, nf95_open
+  USE mod_phys_lmdz_para
+  USE lmdz_xios
+!  USE YOERAD, ONLY : NLW
+  IMPLICIT NONE
+  REAL, allocatable:: latitude(:)
+  REAL, allocatable:: longitude(:)
+  INTEGER :: nlat, nlon
+  REAL    :: null_array(0)
+  INTEGER :: ncid_in, varid
+  
+  IF (using_xios) THEN
+    IF (is_omp_master) THEN  
+      IF (is_mpi_root) THEN
+        CALL nf95_open("taustrat.nc", nf90_nowrite, ncid_in)
+        CALL nf95_inq_varid(ncid_in, "LAT", varid)
+        CALL nf95_gw_var(ncid_in, varid, latitude)
+        CALL nf95_inq_varid(ncid_in, "LON", varid)
+        CALL nf95_gw_var(ncid_in, varid, longitude)
+        CALL nf95_close(ncid_in)
+        nlat=size(latitude)
+        nlon=size(longitude)
+      ENDIF
+      CALL bcast_mpi(nlat)
+      CALL bcast_mpi(nlon)
+
+      IF (is_mpi_root) THEN
+        CALL xios_set_domain_attr("domain_taustrat",nj_glo=nlat, nj=nlat, jbegin=0, latvalue_1d=latitude)
+        CALL xios_set_domain_attr("domain_taustrat",ni_glo=nlon, ni=nlon, ibegin=0, lonvalue_1d = longitude)
+       ELSE
+        CALL xios_set_domain_attr("domain_taustrat",nj_glo=nlat, nj=0, jbegin=0, latvalue_1d=null_array )
+        CALL xios_set_domain_attr("domain_taustrat",ni_glo=nlon, ni=0, ibegin=0, lonvalue_1d=null_array)
+      ENDIF    
+  
+      CALL xios_set_fieldgroup_attr("aerosol_strato1",enabled=.TRUE.)
+    ENDIF
+    
+  ENDIF
+END SUBROUTINE init_readaerosolstrato1
+  
+SUBROUTINE init_readaerosolstrato2
+  USE netcdf
+  USE netcdf95, ONLY: nf95_close, nf95_gw_var, nf95_inq_dimid, & 
+                      nf95_inq_varid, nf95_open
+  USE mod_phys_lmdz_para
+  USE lmdz_xios
+!  USE YOERAD, ONLY : NLW
+  IMPLICIT NONE
+  REAL, allocatable:: latitude(:)
+  REAL, allocatable:: wav(:)
+  INTEGER :: nlat,n_wav
+  REAL    :: null_array(0)
+  INTEGER :: ncid_in, varid
+  
+  IF (using_xios) THEN
+    IF (is_omp_master) THEN    
+      IF (is_mpi_root) THEN
+        CALL nf95_open("tauswstrat.2D.nc", nf90_nowrite, ncid_in)
+        CALL nf95_inq_varid(ncid_in, "LAT", varid)
+        CALL nf95_gw_var(ncid_in, varid, latitude)
+        CALL nf95_inq_varid(ncid_in, "WAV", varid)
+        CALL nf95_gw_var(ncid_in, varid, wav)
+        CALL nf95_close(ncid_in)
+        nlat=size(latitude)
+        n_wav = size(wav)
+      ENDIF
+      CALL bcast_mpi(nlat)
+      CALL bcast_mpi(n_wav)
+
+      IF (is_mpi_root) THEN
+        CALL xios_set_domain_attr("domain_tauswstrat",nj_glo=nlat, nj=nlat, jbegin=0, latvalue_1d=latitude)
+        CALL xios_set_domain_attr("domain_tauswstrat",ni_glo=8, ni=8, ibegin=0, lonvalue_1d = (/ 0.,45.,90.,135.,180.,225.,270., 315. /))
+        DEALLOCATE(latitude)
+      ELSE
+        CALL xios_set_domain_attr("domain_tauswstrat",nj_glo=nlat, nj=0, jbegin=0, latvalue_1d=null_array )
+        CALL xios_set_domain_attr("domain_tauswstrat",ni_glo=8, ni=0, ibegin=0, lonvalue_1d=null_array)
+      ENDIF    
+      CALL  xios_set_axis_attr("nsw", n_glo=n_wav)
+    
+      IF (is_mpi_root) THEN
+        CALL nf95_open("taulwstrat.2D.nc", nf90_nowrite, ncid_in)
+        CALL nf95_inq_varid(ncid_in, "LAT", varid)
+        CALL nf95_gw_var(ncid_in, varid, latitude)
+        CALL nf95_inq_varid(ncid_in, "WAV", varid)
+        CALL nf95_gw_var(ncid_in, varid, wav)
+        CALL nf95_close(ncid_in)
+        nlat=size(latitude)
+        n_wav = size(wav)
+      ENDIF
+      CALL bcast_mpi(nlat)
+      CALL bcast_mpi(n_wav)
+
+      IF (is_mpi_root) THEN
+        CALL xios_set_domain_attr("domain_taulwstrat",nj_glo=nlat, nj=nlat, jbegin=0, latvalue_1d=latitude)
+        CALL xios_set_domain_attr("domain_taulwstrat",ni_glo=8, ni=8, ibegin=0, lonvalue_1d = (/ 0.,45.,90.,135.,180.,225.,270., 315. /))
+        DEALLOCATE(latitude)
+      ELSE
+        CALL xios_set_domain_attr("domain_taulwstrat",nj_glo=nlat, nj=0, jbegin=0, latvalue_1d=null_array )
+        CALL xios_set_domain_attr("domain_taulwstrat",ni_glo=8, ni=0, ibegin=0, lonvalue_1d=null_array)
+      ENDIF    
+    
+      CALL  xios_set_axis_attr("nlw", n_glo=n_wav)
+      CALL xios_set_fieldgroup_attr("aerosol_strato2",enabled=.TRUE.)
+
+    ENDIF
+  ENDIF    
+END SUBROUTINE init_readaerosolstrato2
+  
+
+END MODULE readaerosolstrato_m
+
Index: DZ6/trunk/libf/phylmd/readchlorophyll.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/readchlorophyll.F90	(revision 5267)
+++ 	(revision )
@@ -1,123 +1,0 @@
-!
-! $Id$
-!
-!--This routine is to be tested with MPI / OMP parallelism 
-!--OB 26/03/2018
-
-SUBROUTINE readchlorophyll(debut)
-
-    USE netcdf95, ONLY: nf95_close, nf95_gw_var, nf95_inq_dimid, nf95_inq_varid, nf95_open
-    USE netcdf, ONLY: nf90_get_var, nf90_noerr, nf90_nowrite
-    USE phys_cal_mod, ONLY: mth_cur
-    USE mod_grid_phy_lmdz, ONLY: nbp_lon, nbp_lat, klon_glo, grid2dto1d_glo
-    USE mod_phys_lmdz_mpi_data, ONLY: is_mpi_root
-    USE mod_phys_lmdz_omp_data, ONLY: is_omp_root
-    USE mod_phys_lmdz_para, ONLY: scatter 
-    USE phys_state_var_mod, ONLY: chl_con
-    USE print_control_mod, ONLY: prt_level,lunout
-
-    IMPLICIT NONE
-
-    INCLUDE "YOMCST.h"
-
-! Variable input
-    LOGICAL debut
-
-! Variables locales
-    INTEGER n_lat   ! number of latitudes in the input data
-    INTEGER n_lon   ! number of longitudes in the input data
-    INTEGER n_lev   ! number of levels in the input data
-    INTEGER n_month ! number of months in the input data
-    REAL, ALLOCATABLE :: latitude(:)
-    REAL, ALLOCATABLE :: longitude(:)
-    REAL, ALLOCATABLE :: time(:)
-    INTEGER i, k
-    INTEGER, SAVE :: mth_pre
-!$OMP THREADPRIVATE(mth_pre)
-
-! Champs reconstitues
-    REAL, ALLOCATABLE :: chlorocon(:, :, :)
-    REAL, ALLOCATABLE :: chlorocon_mois(:, :)
-    REAL, ALLOCATABLE :: chlorocon_mois_glo(:)
-
-! For NetCDF:
-    INTEGER ncid_in  ! IDs for input files
-    INTEGER varid, ncerr
-
-!--------------------------------------------------------
-    CHARACTER (len = 20)  :: modname = 'readchlorophyll'
-    CHARACTER (len = 80)  :: abort_message
-
-!--only read file if beginning of run or start of new month
-    IF (debut.OR.mth_cur.NE.mth_pre) THEN
-
-    IF (is_mpi_root.AND.is_omp_root) THEN
-
-    CALL nf95_open("chlorophyll.nc", nf90_nowrite, ncid_in)
-
-    CALL nf95_inq_varid(ncid_in, "lon", varid)
-    CALL nf95_gw_var(ncid_in, varid, longitude)
-    n_lon = size(longitude)
-    IF (n_lon.NE.nbp_lon) THEN
-       abort_message='Le nombre de lon n est pas egal a nbp_lon'
-       CALL abort_physic(modname,abort_message,1)
-    ENDIF
-
-    CALL nf95_inq_varid(ncid_in, "lat", varid)
-    CALL nf95_gw_var(ncid_in, varid, latitude)
-    n_lat = size(latitude)
-    IF (n_lat.NE.nbp_lat) THEN 
-       abort_message='Le nombre de lat n est pas egal a jnbp_lat'
-       CALL abort_physic(modname,abort_message,1)
-    ENDIF
-
-    CALL nf95_inq_varid(ncid_in, "time", varid)
-    CALL nf95_gw_var(ncid_in, varid, time)
-    n_month = size(time)
-    IF (n_month.NE.12) THEN 
-       abort_message='Le nombre de month n est pas egal a 12'
-       CALL abort_physic(modname,abort_message,1)
-    ENDIF
-
-    IF (.not.ALLOCATED(chlorocon))          ALLOCATE(chlorocon(n_lon, n_lat, n_month))
-    IF (.not.ALLOCATED(chlorocon_mois))     ALLOCATE(chlorocon_mois(n_lon, n_lat))
-    IF (.not.ALLOCATED(chlorocon_mois_glo)) ALLOCATE(chlorocon_mois_glo(klon_glo))
-
-!--reading stratospheric AOD at 550 nm
-    CALL nf95_inq_varid(ncid_in, "CHL", varid)
-    ncerr = nf90_get_var(ncid_in, varid, chlorocon)
-    WRITE(lunout,*)'code erreur readchlorophyll=', ncerr, varid
-
-    CALL nf95_close(ncid_in)
-
-!---select the correct month
-    IF (mth_cur.LT.1.OR.mth_cur.GT.12) THEN
-      WRITE(lunout,*)'probleme avec le mois dans readchlorophyll =', mth_cur
-    ENDIF
-    chlorocon_mois(:,:) = chlorocon(:,:,mth_cur)
-
-!---reduce to a klon_glo grid 
-    CALL grid2dTo1d_glo(chlorocon_mois,chlorocon_mois_glo)
-
-    WRITE(lunout,*)"chrolophyll current month",mth_cur
-    DO i=1,klon_glo
-!      if(isnan(chlorocon_mois_glo(i)))then ! isnan() is not in the Fortran standard...
-!      Another way to check for NaN:
-       IF (chlorocon_mois_glo(i).NE.chlorocon_mois_glo(i)) chlorocon_mois_glo(i)=0.
-    ENDDO
-
-!    DEALLOCATE(chlorocon)
-!    DEALLOCATE(chlorocon_mois)
-!    DEALLOCATE(chlorocon_mois_glo)
-  
-    ENDIF !--is_mpi_root and is_omp_root
-
-!--scatter on all proc
-    CALL scatter(chlorocon_mois_glo,chl_con)
-
-!--keep memory of previous month
-    mth_pre=mth_cur
-
-    ENDIF !--debut ou nouveau mois
-
-END SUBROUTINE readchlorophyll
Index: /LMDZ6/trunk/libf/phylmd/readchlorophyll.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/readchlorophyll.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/readchlorophyll.f90	(revision 5268)
@@ -0,0 +1,123 @@
+!
+! $Id$
+!
+!--This routine is to be tested with MPI / OMP parallelism 
+!--OB 26/03/2018
+
+SUBROUTINE readchlorophyll(debut)
+
+    USE netcdf95, ONLY: nf95_close, nf95_gw_var, nf95_inq_dimid, nf95_inq_varid, nf95_open
+    USE netcdf, ONLY: nf90_get_var, nf90_noerr, nf90_nowrite
+    USE phys_cal_mod, ONLY: mth_cur
+    USE mod_grid_phy_lmdz, ONLY: nbp_lon, nbp_lat, klon_glo, grid2dto1d_glo
+    USE mod_phys_lmdz_mpi_data, ONLY: is_mpi_root
+    USE mod_phys_lmdz_omp_data, ONLY: is_omp_root
+    USE mod_phys_lmdz_para, ONLY: scatter 
+    USE phys_state_var_mod, ONLY: chl_con
+    USE print_control_mod, ONLY: prt_level,lunout
+
+    IMPLICIT NONE
+
+    INCLUDE "YOMCST.h"
+
+! Variable input
+    LOGICAL debut
+
+! Variables locales
+    INTEGER n_lat   ! number of latitudes in the input data
+    INTEGER n_lon   ! number of longitudes in the input data
+    INTEGER n_lev   ! number of levels in the input data
+    INTEGER n_month ! number of months in the input data
+    REAL, ALLOCATABLE :: latitude(:)
+    REAL, ALLOCATABLE :: longitude(:)
+    REAL, ALLOCATABLE :: time(:)
+    INTEGER i, k
+    INTEGER, SAVE :: mth_pre
+!$OMP THREADPRIVATE(mth_pre)
+
+! Champs reconstitues
+    REAL, ALLOCATABLE :: chlorocon(:, :, :)
+    REAL, ALLOCATABLE :: chlorocon_mois(:, :)
+    REAL, ALLOCATABLE :: chlorocon_mois_glo(:)
+
+! For NetCDF:
+    INTEGER ncid_in  ! IDs for input files
+    INTEGER varid, ncerr
+
+!--------------------------------------------------------
+    CHARACTER (len = 20)  :: modname = 'readchlorophyll'
+    CHARACTER (len = 80)  :: abort_message
+
+!--only read file if beginning of run or start of new month
+    IF (debut.OR.mth_cur.NE.mth_pre) THEN
+
+    IF (is_mpi_root.AND.is_omp_root) THEN
+
+    CALL nf95_open("chlorophyll.nc", nf90_nowrite, ncid_in)
+
+    CALL nf95_inq_varid(ncid_in, "lon", varid)
+    CALL nf95_gw_var(ncid_in, varid, longitude)
+    n_lon = size(longitude)
+    IF (n_lon.NE.nbp_lon) THEN
+       abort_message='Le nombre de lon n est pas egal a nbp_lon'
+       CALL abort_physic(modname,abort_message,1)
+    ENDIF
+
+    CALL nf95_inq_varid(ncid_in, "lat", varid)
+    CALL nf95_gw_var(ncid_in, varid, latitude)
+    n_lat = size(latitude)
+    IF (n_lat.NE.nbp_lat) THEN 
+       abort_message='Le nombre de lat n est pas egal a jnbp_lat'
+       CALL abort_physic(modname,abort_message,1)
+    ENDIF
+
+    CALL nf95_inq_varid(ncid_in, "time", varid)
+    CALL nf95_gw_var(ncid_in, varid, time)
+    n_month = size(time)
+    IF (n_month.NE.12) THEN 
+       abort_message='Le nombre de month n est pas egal a 12'
+       CALL abort_physic(modname,abort_message,1)
+    ENDIF
+
+    IF (.not.ALLOCATED(chlorocon))          ALLOCATE(chlorocon(n_lon, n_lat, n_month))
+    IF (.not.ALLOCATED(chlorocon_mois))     ALLOCATE(chlorocon_mois(n_lon, n_lat))
+    IF (.not.ALLOCATED(chlorocon_mois_glo)) ALLOCATE(chlorocon_mois_glo(klon_glo))
+
+!--reading stratospheric AOD at 550 nm
+    CALL nf95_inq_varid(ncid_in, "CHL", varid)
+    ncerr = nf90_get_var(ncid_in, varid, chlorocon)
+    WRITE(lunout,*)'code erreur readchlorophyll=', ncerr, varid
+
+    CALL nf95_close(ncid_in)
+
+!---select the correct month
+    IF (mth_cur.LT.1.OR.mth_cur.GT.12) THEN
+      WRITE(lunout,*)'probleme avec le mois dans readchlorophyll =', mth_cur
+    ENDIF
+    chlorocon_mois(:,:) = chlorocon(:,:,mth_cur)
+
+!---reduce to a klon_glo grid 
+    CALL grid2dTo1d_glo(chlorocon_mois,chlorocon_mois_glo)
+
+    WRITE(lunout,*)"chrolophyll current month",mth_cur
+    DO i=1,klon_glo
+!      if(isnan(chlorocon_mois_glo(i)))then ! isnan() is not in the Fortran standard...
+!      Another way to check for NaN:
+       IF (chlorocon_mois_glo(i).NE.chlorocon_mois_glo(i)) chlorocon_mois_glo(i)=0.
+    ENDDO
+
+!    DEALLOCATE(chlorocon)
+!    DEALLOCATE(chlorocon_mois)
+!    DEALLOCATE(chlorocon_mois_glo)
+  
+    ENDIF !--is_mpi_root and is_omp_root
+
+!--scatter on all proc
+    CALL scatter(chlorocon_mois_glo,chl_con)
+
+!--keep memory of previous month
+    mth_pre=mth_cur
+
+    ENDIF !--debut ou nouveau mois
+
+END SUBROUTINE readchlorophyll
Index: DZ6/trunk/libf/phylmd/reevap.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/reevap.F90	(revision 5267)
+++ 	(revision )
@@ -1,79 +1,0 @@
-  SUBROUTINE reevap (klon,klev,iflag_ice_thermo,t_seri,q_seri,ql_seri,qs_seri, &
-   &         d_t_eva,d_q_eva,d_ql_eva,d_qs_eva)
-
-    ! flag to include modifications to ensure energy conservation (if flag >0)
-    USE add_phys_tend_mod, only : fl_cor_ebil 
-    
-    IMPLICIT none
-    !>======================================================================
-
-    INTEGER klon,klev,iflag_ice_thermo
-    REAL, DIMENSION(klon,klev), INTENT(in) :: t_seri,q_seri,ql_seri,qs_seri
-    REAL, DIMENSION(klon,klev), INTENT(out) :: d_t_eva,d_q_eva,d_ql_eva,d_qs_eva
-
-    REAL za,zb,zdelta,zlvdcp,zlsdcp
-    INTEGER i,k
-
-    !--------Stochastic Boundary Layer Triggering: ALE_BL--------
-    !---Propri\'et\'es du thermiques au LCL 
-    include "YOMCST.h"
-    include "YOETHF.h"
-    include "FCTTRE.h"
-    !IM 100106 BEG : pouvoir sortir les ctes de la physique
-    !
-    ! Re-evaporer l'eau liquide nuageuse
-    !
-!print *,'rrevap ; fl_cor_ebil:',fl_cor_ebil,' iflag_ice_thermo:',iflag_ice_thermo,' RVTMP2',RVTMP2
-    DO k = 1, klev  ! re-evaporation de l'eau liquide nuageuse
-       DO i = 1, klon
-        if (fl_cor_ebil .GT. 0) then
-          zlvdcp=RLVTT/RCPD/(1.0+RVTMP2*(q_seri(i,k)+ql_seri(i,k)+qs_seri(i,k)))
-          zlsdcp=RLSTT/RCPD/(1.0+RVTMP2*(q_seri(i,k)+ql_seri(i,k)+qs_seri(i,k)))
-        else
-          zlvdcp=RLVTT/RCPD/(1.0+RVTMP2*q_seri(i,k))
-          !jyg<
-          !  Attention : Arnaud a propose des formules completement differentes
-          !                  A verifier !!!
-          zlsdcp=RLSTT/RCPD/(1.0+RVTMP2*q_seri(i,k))
-        end if
-          IF (iflag_ice_thermo .EQ. 0) THEN
-             zlsdcp=zlvdcp
-          ENDIF
-          !>jyg
-
-          IF (iflag_ice_thermo.eq.0) THEN   
-             !pas necessaire a priori
-
-             zdelta = MAX(0.,SIGN(1.,RTT-t_seri(i,k)))
-  zdelta = 0.
-             zb = MAX(0.0,ql_seri(i,k))
-             za = - MAX(0.0,ql_seri(i,k)) &
-                  * (zlvdcp*(1.-zdelta)+zlsdcp*zdelta)
-             d_t_eva(i,k) = za
-             d_q_eva(i,k) = zb
-             d_ql_eva(i,k) = -ql_seri(i,k)
-             d_qs_eva(i,k) = 0.
-
-          ELSE
-
-             !CR: on r\'e-\'evapore eau liquide et glace
-
-             !        zdelta = MAX(0.,SIGN(1.,RTT-t_seri(i,k)))
-             !        zb = MAX(0.0,ql_seri(i,k))
-             !        za = - MAX(0.0,ql_seri(i,k)) &
-             !             * (zlvdcp*(1.-zdelta)+zlsdcp*zdelta)
-             zb = MAX(0.0,ql_seri(i,k)+qs_seri(i,k))
-             za = - MAX(0.0,ql_seri(i,k))*zlvdcp & 
-                  - MAX(0.0,qs_seri(i,k))*zlsdcp
-             d_t_eva(i,k) = za
-             d_q_eva(i,k) = zb
-             d_ql_eva(i,k) = -ql_seri(i,k)
-             d_qs_eva(i,k) = -qs_seri(i,k)
-          ENDIF
-
-       ENDDO
-    ENDDO
-
-RETURN
-
-END SUBROUTINE reevap
Index: /LMDZ6/trunk/libf/phylmd/reevap.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/reevap.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/reevap.f90	(revision 5268)
@@ -0,0 +1,79 @@
+  SUBROUTINE reevap (klon,klev,iflag_ice_thermo,t_seri,q_seri,ql_seri,qs_seri, &
+   &         d_t_eva,d_q_eva,d_ql_eva,d_qs_eva)
+
+    ! flag to include modifications to ensure energy conservation (if flag >0)
+    USE add_phys_tend_mod, only : fl_cor_ebil 
+    
+    IMPLICIT none
+    !>======================================================================
+
+    INTEGER klon,klev,iflag_ice_thermo
+    REAL, DIMENSION(klon,klev), INTENT(in) :: t_seri,q_seri,ql_seri,qs_seri
+    REAL, DIMENSION(klon,klev), INTENT(out) :: d_t_eva,d_q_eva,d_ql_eva,d_qs_eva
+
+    REAL za,zb,zdelta,zlvdcp,zlsdcp
+    INTEGER i,k
+
+    !--------Stochastic Boundary Layer Triggering: ALE_BL--------
+    !---Propri\'et\'es du thermiques au LCL 
+    include "YOMCST.h"
+    include "YOETHF.h"
+    include "FCTTRE.h"
+    !IM 100106 BEG : pouvoir sortir les ctes de la physique
+    !
+    ! Re-evaporer l'eau liquide nuageuse
+    !
+!print *,'rrevap ; fl_cor_ebil:',fl_cor_ebil,' iflag_ice_thermo:',iflag_ice_thermo,' RVTMP2',RVTMP2
+    DO k = 1, klev  ! re-evaporation de l'eau liquide nuageuse
+       DO i = 1, klon
+        if (fl_cor_ebil .GT. 0) then
+          zlvdcp=RLVTT/RCPD/(1.0+RVTMP2*(q_seri(i,k)+ql_seri(i,k)+qs_seri(i,k)))
+          zlsdcp=RLSTT/RCPD/(1.0+RVTMP2*(q_seri(i,k)+ql_seri(i,k)+qs_seri(i,k)))
+        else
+          zlvdcp=RLVTT/RCPD/(1.0+RVTMP2*q_seri(i,k))
+          !jyg<
+          !  Attention : Arnaud a propose des formules completement differentes
+          !                  A verifier !!!
+          zlsdcp=RLSTT/RCPD/(1.0+RVTMP2*q_seri(i,k))
+        end if
+          IF (iflag_ice_thermo .EQ. 0) THEN
+             zlsdcp=zlvdcp
+          ENDIF
+          !>jyg
+
+          IF (iflag_ice_thermo.eq.0) THEN   
+             !pas necessaire a priori
+
+             zdelta = MAX(0.,SIGN(1.,RTT-t_seri(i,k)))
+  zdelta = 0.
+             zb = MAX(0.0,ql_seri(i,k))
+             za = - MAX(0.0,ql_seri(i,k)) &
+                  * (zlvdcp*(1.-zdelta)+zlsdcp*zdelta)
+             d_t_eva(i,k) = za
+             d_q_eva(i,k) = zb
+             d_ql_eva(i,k) = -ql_seri(i,k)
+             d_qs_eva(i,k) = 0.
+
+          ELSE
+
+             !CR: on r\'e-\'evapore eau liquide et glace
+
+             !        zdelta = MAX(0.,SIGN(1.,RTT-t_seri(i,k)))
+             !        zb = MAX(0.0,ql_seri(i,k))
+             !        za = - MAX(0.0,ql_seri(i,k)) &
+             !             * (zlvdcp*(1.-zdelta)+zlsdcp*zdelta)
+             zb = MAX(0.0,ql_seri(i,k)+qs_seri(i,k))
+             za = - MAX(0.0,ql_seri(i,k))*zlvdcp & 
+                  - MAX(0.0,qs_seri(i,k))*zlsdcp
+             d_t_eva(i,k) = za
+             d_q_eva(i,k) = zb
+             d_ql_eva(i,k) = -ql_seri(i,k)
+             d_qs_eva(i,k) = -qs_seri(i,k)
+          ENDIF
+
+       ENDDO
+    ENDDO
+
+RETURN
+
+END SUBROUTINE reevap
Index: DZ6/trunk/libf/phylmd/regr_horiz_time_climoz_m.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/regr_horiz_time_climoz_m.F90	(revision 5267)
+++ 	(revision )
@@ -1,723 +1,0 @@
-MODULE regr_horiz_time_climoz_m
-
-  USE interpolation,     ONLY: locate
-  USE mod_grid_phy_lmdz, ONLY: nbp_lon, nbp_lat, grid_type, unstructured
-  USE nrtype,            ONLY: pi
-  USE netcdf,   ONLY: NF90_CLOBBER, NF90_FLOAT,     NF90_OPEN,   &
-                      NF90_NOWRITE, NF90_NOERR,     NF90_GET_ATT, NF90_GLOBAL
-  USE netcdf95, ONLY: NF95_DEF_DIM, NF95_INQ_DIMID, NF95_INQUIRE_DIMENSION,    &
-       NF95_DEF_VAR, NF95_INQ_VARID, NF95_INQUIRE_VARIABLE, &
-       NF95_OPEN,  NF95_CREATE,  NF95_GET_ATT,   NF95_GW_VAR,  nf95_get_var,  &
-       NF95_CLOSE, NF95_ENDDEF,  NF95_PUT_ATT,   NF95_PUT_VAR, NF95_COPY_ATT
-  USE print_control_mod, ONLY: lunout
-  USE dimphy
-  IMPLICIT NONE
-  PRIVATE
-  PUBLIC :: regr_horiz_time_climoz
-  REAL, PARAMETER :: deg2rad=pi/180.
-  CHARACTER(LEN=13), PARAMETER :: vars_in(2)=['tro3         ','tro3_daylight']
-
-  INTEGER :: nlat_ou, nlon_ou
-  REAL, ALLOCATABLE :: latitude_glo(:)
-!$OMP THREADPRIVATE(latitude_glo)
-  INTEGER, ALLOCATABLE :: ind_cell_glo_glo(:)
-!$OMP THREADPRIVATE(ind_cell_glo_glo)
-
-CONTAINS
-
-!-------------------------------------------------------------------------------
-!
-SUBROUTINE regr_horiz_time_climoz(read_climoz,interpt)
-!
-!-------------------------------------------------------------------------------
-! Purpose: Regrid horizontally and in time zonal or 3D ozone climatologies.
-!   * Read ozone climatology from netcdf file
-!   * Regrid it horizontaly to LMDZ grid (quasi-conservative method)
-!   * If interpt=T, interpolate linearly in time (one record each day)
-!     If interpt=F, keep original time sampling  (14 months).
-!   * Save it to a new netcdf file.
-!-------------------------------------------------------------------------------
-! Remarks:
-!   * Up to 2 variables treated: "tro3" and "tro3_daylight" (if read_climoz=2)
-!   * Input fields coordinates: (longitudes, latitudes, pressure_levels, time)
-!   * Output grid cells centers coordinates given by [rlonv,] rlatu.
-!   * Output grid cells edges   coordinates given by [rlonu,] rlatv.
-!   * Input file [longitudes and] latitudes given in degrees.
-!   * Input file pressure levels are given in Pa or hPa.
-!   * All coordinates variables are stricly monotonic.
-!   * Monthly fields are interpolated linearly in time to get daily values.
-!   * Fields are known at the middle of the months, so interpolation requires an
-!     additional record both for 1st half of january and 2nd half of december:
-!     - For a 14-records "climoz.nc": records 1 and 14.
-!     - For 12-records files:
-!       record 12 of "climoz_m.nc" if available, or record 1  of "climoz.nc".
-!       record 1  of "climoz_p.nc" if available, or record 12 of "climoz.nc".
-!   * Calendar is taken into account to get one record each day (not 360 always).
-!   * Missing values are filled in from sky to ground by copying lowest valid one.
-!     Attribute "missing_value" or "_FillValue" must be present in input file.
-!-------------------------------------------------------------------------------
-  USE assert_m,           ONLY: assert
-  USE cal_tools_m,        ONLY: year_len, mid_month
-!!  USE control_mod,        ONLY: anneeref
-  USE time_phylmdz_mod,   ONLY: annee_ref
-  USE ioipsl,             ONLY: ioget_year_len, ioget_calendar
-  USE regr_conserv_m,     ONLY: regr_conserv
-  USE regr_lint_m,        ONLY: regr_lint
-  USE regular_lonlat_mod, ONLY: boundslon_reg, boundslat_reg, south, west, east
-  USE slopes_m,           ONLY: slopes
-  USE lmdz_xios
-  USE mod_phys_lmdz_para, ONLY: is_mpi_root, is_master, is_omp_master, gather, gather_mpi, bcast_mpi, klon_mpi
-  USE geometry_mod, ONLY : latitude_deg, ind_cell_glo
-  USE mod_grid_phy_lmdz, ONLY: klon_glo
-
-!-------------------------------------------------------------------------------
-! Arguments:
-  INTEGER, INTENT(IN) :: read_climoz ! read ozone climatology, 1 or 2
-!                         1: read a single ozone climatology used day and night
-!                         2: same + read also a daylight climatology
-  LOGICAL, INTENT(IN) :: interpt     ! TRUE  => daily interpolation
-                                     ! FALSE => no interpolation (14 months)
-!-------------------------------------------------------------------------------
-! Local variables:
-
-!--- Input files variables
-  INTEGER :: nlon_in                       ! Number of longitudes
-  INTEGER :: nlat_in                       ! Number of latitudes
-  INTEGER :: nlev_in                       ! Number of pressure levels
-  INTEGER :: nmth_in                       ! Number of months
-  REAL, ALLOCATABLE:: lon_in(:)           ! Longitudes   (ascending order, rad)
-  REAL, ALLOCATABLE:: lat_in(:)           ! Latitudes    (ascending order, rad)
-  REAL, ALLOCATABLE:: lev_in(:)           ! Pressure levels (ascen. order, hPa)
-  REAL, ALLOCATABLE :: lon_in_edge(:)      ! Longitude intervals edges
-                                           !              (ascending order,  / )
-  REAL, ALLOCATABLE :: sinlat_in_edge(:)   ! Sinus of latitude intervals edges
-                                           !              (ascending order,  / )
-  LOGICAL :: ldec_lon, ldec_lat, ldec_lev  ! Decreasing order in input file
-  CHARACTER(LEN=20) :: cal_in              ! Calendar
-  REAL, ALLOCATABLE :: o3_in3(:,:,:,:,:)   ! Ozone climatologies
-  REAL, ALLOCATABLE :: o3_in3bis(:,:,:,:,:)   ! Ozone climatologies
-  REAL, ALLOCATABLE :: o3_in2  (:,:,:,:)   ! Ozone climatologies
-  REAL, ALLOCATABLE :: o3_in2bis(:,:,:,:,:)   ! Ozone climatologies
-  ! last index: 1 for the day-night average, 2 for the daylight field.
-  REAL :: NaN
-
-!--- Partially or totally regridded variables      (:,:,nlev_in,:,read_climoz)
-  REAL, ALLOCATABLE :: o3_regr_lon   (:,:,:,:,:) ! (nlon_ou,nlat_in,:,0:13   ,:)
-  REAL, ALLOCATABLE :: o3_regr_lonlat(:,:,:,:,:) ! (nlon_ou,nlat_ou,:,0:13   ,:)
-  REAL, ALLOCATABLE :: o3_out3       (:,:,:,:,:) ! (nlon_ou,nlat_ou,:,ntim_ou,:)
-  REAL, ALLOCATABLE :: o3_out3_glo   (:,:,:,:) !   (nbp_lat,:,ntim_ou,:)
-  REAL, ALLOCATABLE :: o3_regr_lat     (:,:,:,:) !         (nlat_in,:,0:13   ,:)
-  REAL, ALLOCATABLE :: o3_out2         (:,:,:,:) !         (nlat_ou,:,ntim_ou,:)
-  REAL, ALLOCATABLE :: o3_out2_glo     (:,:,:,:) !         (nbp_lat,:,ntim_ou,:)
-  REAL, ALLOCATABLE :: o3_out          (:,:,:,:) !         (nbp_lat,:,ntim_ou,:)
-! Dimension number  | Interval                | Contains  | For variables:
-!   1 (longitude)   | [rlonu(i-1), rlonu(i)]  | rlonv(i)  | all
-!   2 (latitude)    | [rlatv(j), rlatv(j-1)]  | rlatu(j)  | all but o3_regr_lon
-!   3 (press level) |                         |   lev(k)  | all
-! Note that rlatv(0)=pi/2 and rlatv(nlat_ou)=-pi/2.
-! Dimension 4 is: month number                             (all vars but o3_out)
-!                 days elapsed since Jan. 1st 0h at mid-day (o3_out only)
-  REAL, ALLOCATABLE :: v1(:)
-
-!--- For NetCDF:
-  INTEGER :: fID_in_m, fID_in, levID_ou, dimid, vID_in(read_climoz), ntim_ou
-  INTEGER :: fID_in_p, fID_ou, timID_ou, varid, vID_ou(read_climoz), ndims, ncerr
-  INTEGER, ALLOCATABLE :: dIDs(:)
-  CHARACTER(LEN=20) :: cal_ou     !--- Calendar; no time inter => same as input
-  CHARACTER(LEN=80) :: press_unit !--- Pressure unit
-  REAL    :: tmidmonth(0:13)      !--- Elapsed days since Jan-1 0h at mid-months
-                                  ! Additional records 0, 13 for interpolation
-  REAL, ALLOCATABLE :: tmidday(:) !--- Output times (mid-days since Jan 1st 0h)
-  LOGICAL :: lprev, lnext         !--- Flags: previous/next files are present
-  LOGICAL :: l3D, l2D             !--- Flag:  input fields are 3D or zonal
-  INTEGER :: ii, i, j, k, l, m, dln, ib, ie, iv, dx1, dx2
-  INTEGER, ALLOCATABLE :: sta(:), cnt(:)
-  CHARACTER(LEN=80) :: sub, dim_nam, msg
-  REAL :: null_array(0)
-  LOGICAL,SAVE :: first=.TRUE.
-!$OMP THREADPRIVATE(first)  
-  REAL, ALLOCATABLE :: test_o3_in(:,:)
-  REAL, ALLOCATABLE :: test_o3_out(:)
-
-
-  IF (grid_type==unstructured) THEN 
-    IF (first) THEN
-      IF (is_master) THEN
-        ALLOCATE(latitude_glo(klon_glo))
-        ALLOCATE(ind_cell_glo_glo(klon_glo))
-      ELSE
-        ALLOCATE(latitude_glo(0))
-        ALLOCATE(ind_cell_glo_glo(0))
-      ENDIF
-      CALL gather(latitude_deg,  latitude_glo)
-      CALL gather(ind_cell_glo,  ind_cell_glo_glo)
-    ENDIF 
-  ENDIF
-    
-  IF (is_omp_master) THEN
-    nlat_ou=nbp_lat
-    nlon_ou=nbp_lon
-    
-   !-------------------------------------------------------------------------------
-    IF (is_mpi_root) THEN
-      sub="regr_horiz_time_climoz"
-      WRITE(lunout,*)"Call sequence information: "//TRIM(sub)
-      CALL assert(read_climoz == 1 .OR. read_climoz == 2, "regr_lat_time_climoz")
-
-      CALL  NF95_OPEN("climoz.nc"  , NF90_NOWRITE, fID_in)
-      lprev=NF90_OPEN("climoz_m.nc", NF90_NOWRITE, fID_in_m)==NF90_NOERR
-      lnext=NF90_OPEN("climoz_p.nc", NF90_NOWRITE, fID_in_p)==NF90_NOERR
-
-      !--- Get coordinates from the input file. Converts lon/lat in radians.
-      !    Few inversions because "regr_conserv" and gcm need ascending vectors.
-      CALL NF95_INQ_VARID(fID_in, vars_in(1), varid)
-      CALL NF95_INQUIRE_VARIABLE(fID_in, varid, dimids=dIDs, ndims=ndims)
-      l3D=ndims==4; l2D=ndims==3
-      IF(l3D) WRITE(lunout,*)"Input files contain full 3D ozone fields."
-      IF(l2D) WRITE(lunout,*)"Input files contain zonal 2D ozone fields."
-      DO i=1,ndims
-        CALL NF95_INQUIRE_DIMENSION(fID_in, dIDs(i), name=dim_nam, nclen=dln)
-        CALL NF95_INQ_VARID(fID_in, dim_nam, varid)
-        ii=i; IF(l2D) ii=i+1                              !--- ndims==3:NO LONGITUDE 
-        SELECT CASE(ii)
-          CASE(1)                                         !--- LONGITUDE
-            CALL NF95_GW_VAR(fID_in, varid, lon_in)
-            ldec_lon=lon_in(1)>lon_in(dln); IF(ldec_lon) lon_in=lon_in(dln:1:-1)
-            nlon_in=dln; lon_in=lon_in*deg2rad
-          CASE(2)                                         !--- LATITUDE
-            CALL NF95_GW_VAR(fID_in, varid, lat_in)
-            ldec_lat=lat_in(1)>lat_in(dln); IF(ldec_lat) lat_in=lat_in(dln:1:-1)
-            nlat_in=dln; lat_in=lat_in*deg2rad
-          CASE(3)                                         !--- PRESSURE LEVELS
-            CALL NF95_GW_VAR(fID_in, varid, lev_in)
-            ldec_lev=lev_in(1)>lev_in(dln); IF(ldec_lev) lev_in=lev_in(dln:1:-1)
-            nlev_in=dln
-            CALL NF95_GET_ATT(fID_in, varid, "units", press_unit)
-            k=LEN_TRIM(press_unit)
-            DO WHILE(ICHAR(press_unit(k:k))==0)
-              press_unit(k:k)=' '; k=LEN_TRIM(press_unit) !--- REMOVE NULL END CHAR
-            END DO
-            IF(press_unit ==  "Pa") THEN
-              lev_in = lev_in/100.                        !--- CONVERT TO hPa
-            ELSE IF(press_unit /= "hPa") THEN
-              CALL abort_physic(sub, "the only recognized units are Pa and hPa.",1)
-            END IF
-          CASE(4)                                         !--- TIME
-            CALL NF95_INQUIRE_DIMENSION(fID_in, dIDs(i), nclen=nmth_in)
-            cal_in='gregorian'
-            IF(NF90_GET_ATT(fID_in, varid, 'calendar', cal_in)/=NF90_NOERR)        &  
-            WRITE(lunout,*)'WARNING: missing "calendar" attribute for "'//       &
-            TRIM(dim_nam)//'" in "climoz.nc". Choosing default: "gregorian".'
-            k=LEN_TRIM(cal_in)
-            DO WHILE(ICHAR(cal_in(k:k))==0)
-              cal_in(k:k)=' '; k=LEN_TRIM(cal_in)         !--- REMOVE NULL END CHAR
-            END DO
-        END SELECT
-      END DO
-
-      !--- Prepare quantities for time interpolation
-      tmidmonth=mid_month(annee_ref, cal_in)
-      IF(interpt) THEN
-        ntim_ou=ioget_year_len(annee_ref)
-        ALLOCATE(tmidday(ntim_ou))
-        tmidday=[(REAL(k)-0.5,k=1,ntim_ou)]
-        CALL ioget_calendar(cal_ou)
-      ELSE
-        ntim_ou=14
-        cal_ou=cal_in
-      END IF
-    ENDIF
-
-    IF (grid_type==unstructured) THEN
-      CALL bcast_mpi(nlon_in)
-      CALL bcast_mpi(nlat_in)
-      CALL bcast_mpi(nlev_in)
-      CALL bcast_mpi(l3d)
-      CALL bcast_mpi(tmidmonth)
-      IF(interpt) CALL bcast_mpi(tmidday)
-      CALL bcast_mpi(ntim_ou)
-
-      IF (is_mpi_root) THEN
-        CALL xios_set_domain_attr("domain_climoz",nj_glo=nlat_in, nj=nlat_in, jbegin=0, latvalue_1d=lat_in/deg2rad)
-        IF (l3D) THEN
-          CALL xios_set_domain_attr("domain_climoz",ni_glo=nlon_in, ni=nlon_in, ibegin=0, lonvalue_1d=lon_in/deg2rad)
-        ELSE
-          CALL xios_set_domain_attr("domain_climoz",ni_glo=8, ni=8, ibegin=0, lonvalue_1d = (/ 0.,45.,90.,135.,180.,225.,270., 315. /))
-        ENDIF
-      ELSE
-        CALL xios_set_domain_attr("domain_climoz",nj_glo=nlat_in, nj=0, jbegin=0, latvalue_1d=null_array )
-        IF (l3D) THEN
-          CALL xios_set_domain_attr("domain_climoz",ni_glo=nlon_in, ni=0, ibegin=0, lonvalue_1d=null_array)
-        ELSE
-          CALL xios_set_domain_attr("domain_climoz",ni_glo=8, ni=0, ibegin=0, lonvalue_1d=null_array)
-        ENDIF
-      ENDIF
-      CALL  xios_set_axis_attr("axis_climoz", n_glo=nlev_in)
-      CALL  xios_set_axis_attr("time_axis_climoz", n_glo=ntim_ou)
-      CALL  xios_set_axis_attr("time_axis_climoz", n_glo=ntim_ou)
-      CALL  xios_set_axis_attr("tr_climoz", n_glo=read_climoz)
-      CALL  xios_set_field_attr("tro3_out", enabled=.TRUE.)
-      CALL  xios_set_field_attr("tro3_out", enabled=.TRUE.)
-      
-      IF (first) THEN
-        first=.FALSE.
-        RETURN
-      ENDIF
-    ENDIF
-    
-    
-    IF (is_mpi_root) THEN     
-      !--- Longitudes management:
-      !    * Need to shift data if the origin of input file longitudes /= -pi
-      !    * Need to add some margin in longitude to ensure input interval contains
-      !      all the output intervals => at least one longitudes slice has to be
-      !      duplicated, possibly more for undersampling.
-      IF(l3D) THEN
-        IF (grid_type==unstructured) THEN
-          dx2=0
-        ELSE
-          !--- Compute input edges longitudes vector (no end point yet)
-          ALLOCATE(v1(nlon_in+1))
-          v1(1)=(lon_in(nlon_in)+lon_in(1))/2.-pi
-          FORALL(i=2:nlon_in) v1(i)=(lon_in(i-1)+lon_in(i))/2.
-          v1(nlon_in+1)=v1(1)+2.*pi
-          DEALLOCATE(lon_in)
-
-          !--- Shift input longitudes vector until it contains first output point boundslon_reg(1,west)
-          v1=v1+2*pi*REAL(FLOOR((boundslon_reg(1,west)-v1(1))/(2.*pi)))
-
-          !--- Ensure first input longitudes interval contains first output point boundslon_reg(1,west)
-          dx1=locate(v1,boundslon_reg(1,west))-1
-          v1=CSHIFT(v1,SHIFT=dx1,DIM=1) 
-          v1(nlon_in-dx1+2:)=v1(nlon_in-dx1+2:)+2.*pi
-    
-          !--- Extend input longitudes vector until last interval contains boundslon_reg(nlat_ou,east)
-          dx2=0; DO WHILE(v1(1+dx2)+2.*pi<=boundslon_reg(nlon_ou,east)); dx2=dx2+1; END DO
-
-          !--- Final edges longitudes vector (with margin and end point)
-          ALLOCATE(lon_in_edge(nlon_in+dx2+1)); lon_in_edge=[v1,v1(2:1+dx2)+2.*pi]
-          DEALLOCATE(v1)
-        ENDIF
-      END IF
-
-      !--- Compute sinus of intervals edges latitudes:
-      ALLOCATE(sinlat_in_edge(nlat_in+1))
-      sinlat_in_edge(1) = -1. ; sinlat_in_edge(nlat_in+1) = 1.
-      FORALL(j=2:nlat_in) sinlat_in_edge(j)=SIN((lat_in(j-1)+lat_in(j))/2.)
-      DEALLOCATE(lat_in)
-
-
-
-      !--- Check for contiguous years:
-      ib=0; ie=13
-      IF(nmth_in == 14) THEN; lprev=.FALSE.; lnext=.FALSE.
-        WRITE(lunout,*)'Using 14 months ozone climatology "climoz.nc"...'
-      ELSE  
-        IF(     lprev) WRITE(lunout,*)'Using "climoz_m.nc" last record (previous year).'
-        IF(.NOT.lprev) WRITE(lunout,*)"No previous year file ; assuming periodicity."
-        IF(     lnext) WRITE(lunout,*)'Using "climoz_p.nc" first record (next year).'
-        IF(.NOT.lnext) WRITE(lunout,*)"No next year file ; assuming periodicity."
-        IF(.NOT.lprev) ib=1
-        IF(.NOT.lnext) ie=12
-      END IF
-      ALLOCATE(sta(ndims),cnt(ndims)); sta(:)=1  
-      IF(l3D) cnt=[nlon_in,nlat_in,nlev_in,1]
-      IF(l2D) cnt=[        nlat_in,nlev_in,1]  
-      IF(l3D) ALLOCATE(o3_in3(nlon_in+dx2,nlat_in,nlev_in,ib:ie,read_climoz))
-      IF(l2D) ALLOCATE(o3_in2(            nlat_in,nlev_in,ib:ie,read_climoz))
-
-      !--- Read full current file and one record each available contiguous file
-      DO iv=1,read_climoz
-        CALL NF95_INQ_VARID(fID_in, vars_in(1), vID_in(iv))
-        IF(l3D) call NF95_GET_VAR(fID_in, vID_in(iv), o3_in3(1:nlon_in,:,:,1:12,iv))
-        IF(l2D) call NF95_GET_VAR(fID_in, vID_in(iv), o3_in2(          :,:,1:12,iv))
-        IF(lprev) THEN; sta(ndims)=12  
-          CALL NF95_INQ_VARID(fID_in_m, vars_in(1), vID_in(iv))
-          IF(l3D) call NF95_GET_VAR(fID_in_m,vID_in(iv),o3_in3(1:nlon_in,:,:, 0,iv),sta,cnt)
-          IF(l2d) call NF95_GET_VAR(fID_in_m,vID_in(iv),o3_in2(          :,:, 0,iv),sta,cnt)
-        END IF
-        IF(lnext) THEN; sta(ndims)=1  
-          CALL NF95_INQ_VARID(fID_in_p, vars_in(1), vID_in(iv))
-          IF(l3D) call NF95_GET_VAR(fID_in_p,vID_in(iv),o3_in3(1:nlon_in,:,:,13,iv),sta,cnt)
-          IF(l2D) call NF95_GET_VAR(fID_in_p,vID_in(iv),o3_in2(          :,:,13,iv),sta,cnt)
-        END IF
-      END DO
-      IF(lprev.OR.lnext) DEALLOCATE(sta,cnt)
-      IF(lprev) CALL NF95_CLOSE(fID_in_m)
-      IF(lnext) CALL NF95_CLOSE(fID_in_p)
-
-      !--- Revert decreasing coordinates vector
-      IF(l3D) THEN
-        IF(ldec_lon) o3_in3(1:nlon_in,:,:,:,:) = o3_in3(nlon_in:1:-1,:,:,:,:)
-        IF(ldec_lat) o3_in3 = o3_in3(:,nlat_in:1:-1,:,:,:)
-        IF(ldec_lev) o3_in3 = o3_in3(:,:,nlev_in:1:-1,:,:)
-        
-        IF (grid_type /= unstructured) THEN
-          !--- Shift values for longitude and duplicate some longitudes slices
-          o3_in3(1:nlon_in,:,:,:,:)=CSHIFT(o3_in3(1:nlon_in,:,:,:,:),SHIFT=dx1,DIM=1)
-          o3_in3(nlon_in+1:nlon_in+dx2,:,:,:,:)=o3_in3(1:dx2,:,:,:,:)
-        ENDIF
-      ELSE
-        IF(ldec_lat) o3_in2 = o3_in2(  nlat_in:1:-1,:,:,:)
-        IF(ldec_lev) o3_in2 = o3_in2(  :,nlev_in:1:-1,:,:)
-      END IF
-
-     !--- Deal with missing values 
-      DO m=1, read_climoz
-        WRITE(msg,'(a,i0)')"regr_lat_time_climoz: field Nr.",m
-        IF(NF90_GET_ATT(fID_in,vID_in(m),"missing_value",NaN)/= NF90_NOERR) THEN
-          IF(NF90_GET_ATT(fID_in, vID_in(m),"_FillValue",NaN)/= NF90_NOERR) THEN
-            WRITE(lunout,*)TRIM(msg)//": no missing value attribute found."; CYCLE
-          END IF
-        END IF
-        WRITE(lunout,*)TRIM(msg)//": missing value attribute found."
-        WRITE(lunout,*)"Trying to fill in NaNs ; a full field would be better."
-
-        !--- Check top layer contains no NaNs & search NaNs from top to ground
-        msg=TRIM(sub)//": NaNs in top layer !"
-        IF(l3D) THEN
-          IF(ANY(o3_in3(:,:,1,:,m)==NaN)) CALL abort_physic(sub,msg,1)
-          DO k = 2,nlev_in
-            WHERE(o3_in3(:,:,k,:,m)==NaN) o3_in3(:,:,k,:,m)=o3_in3(:,:,k-1,:,m)
-          END DO
-        ELSE
-          IF(ANY(o3_in2(  :,1,:,m)==NaN)) THEN
-            WRITE(lunout,*)msg
-            !--- Fill in latitudes where all values are missing
-            DO l=1,nmth_in
-              !--- Next to south pole
-              j=1;       DO WHILE(o3_in2(j,1,l,m)==NaN); j=j+1; END DO
-              IF(j>1) &
-                o3_in2(:j-1,:,l,m)=SPREAD(o3_in2(j,:,l,m),DIM=1,ncopies=j-1)
-              !--- Next to north pole
-              j=nlat_in; DO WHILE(o3_in2(j,1,l,m)==NaN); j=j+1; END DO
-              IF(j<nlat_in) &
-                o3_in2(j+1:,:,l,m)=SPREAD(o3_in2(j,:,l,m),DIM=1,ncopies=nlat_in-j)
-            END DO
-          END IF
-
-          !--- Fill in high latitudes missing values
-          !--- Highest level been filled-in, so has always valid values.
-          DO k = 2,nlev_in
-            WHERE(o3_in2(:,k,:,m)==NaN) o3_in2(:,k,:,m)=o3_in2(:,k-1,:,m)
-          END DO
-        END IF
-      END DO
-
-    ENDIF
-    
-    !=============================================================================
-    IF(l3D) THEN                                                   !=== 3D FIELDS
-    !=============================================================================
-     IF (grid_type==unstructured) THEN
-       nlat_ou=klon_mpi
-       
-       IF (is_mpi_root) THEN 
-         ALLOCATE(o3_in3bis(nlon_in,nlat_in,nlev_in,0:13,read_climoz)) 
-         o3_in3bis(:,:,:,ib:ie,:)=o3_in3(1:nlon_in,:,:,ib:ie,:)
-       ELSE
-         ALLOCATE(o3_in3bis(0,0,0,0,read_climoz))
-       ENDIF
-       ALLOCATE(o3_regr_lonlat(1, nlat_ou, nlev_in, 0:13, read_climoz))
-       
-       CALL xios_send_field("tro3_in",o3_in3bis(:,:,:,:,:))
-       CALL xios_recv_field("tro3_out",o3_regr_lonlat(1,:,:,:,:))
-     ELSE
-          
-       !--- Regrid in longitude
-        ALLOCATE(o3_regr_lon(nlon_ou, nlat_in, nlev_in, ie-ib+1, read_climoz))
-        CALL regr_conserv(1, o3_in3, xs = lon_in_edge,                             &
-                            xt = [boundslon_reg(1,west),boundslon_reg(:,east)],    &
-                            vt = o3_regr_lon, slope = slopes(1,o3_in3, lon_in_edge))
-        DEALLOCATE(o3_in3)
-
-        !--- Regrid in latitude: averaging with respect to SIN(lat) is
-        !                        equivalent to weighting by COS(lat)
-        !--- (inverted indices in "o3_regr_lonlat" because "rlatu" is decreasing)
-        ALLOCATE(o3_regr_lonlat(nlon_ou, nlat_ou, nlev_in, 0:13, read_climoz))
-        CALL regr_conserv(2, o3_regr_lon, xs = sinlat_in_edge,                     &
-                        xt = [- 1., SIN(boundslat_reg(nlat_ou-1:1:-1,south)), 1.], &
-                        vt = o3_regr_lonlat(:,nlat_ou:1:- 1,:,ib:ie,:),            &
-                   slope = slopes(2,o3_regr_lon, sinlat_in_edge))
-        DEALLOCATE(o3_regr_lon)
-
-     ENDIF
-
-     !--- Duplicate previous/next record(s) if they are not available
-     IF(.NOT.lprev) o3_regr_lonlat(:,:,:, 0,:) = o3_regr_lonlat(:,:,:,12,:)
-     IF(.NOT.lnext) o3_regr_lonlat(:,:,:,13,:) = o3_regr_lonlat(:,:,:, 1,:)
-      
-     !--- Regrid in time by linear interpolation:
-     ALLOCATE(o3_out3(nlon_ou, nlat_ou, nlev_in, ntim_ou, read_climoz))
-     IF(     interpt) CALL regr_lint(4,o3_regr_lonlat,tmidmonth,tmidday,o3_out3)
-     IF(.NOT.interpt) o3_out3=o3_regr_lonlat
-     DEALLOCATE(o3_regr_lonlat)
-
-     nlat_ou=nbp_lat
-     IF (grid_type==unstructured) THEN
-       CALL xios_send_field('o3_out',o3_out3)
-       ndims=3 
-       ALLOCATE(o3_out3_glo(nlat_ou, nlev_in, ntim_ou, read_climoz))
-       CALL gather_mpi(o3_out3(1,:,:,:,:), o3_out3_glo)
-     ENDIF
-
-    !--- Create the output file and get the variable IDs:
-    CALL prepare_out(fID_in,nlev_in,ntim_ou, fID_ou,levID_ou,timID_ou,vID_ou, &
-                     ndims, cal_ou)
-
-    IF (is_mpi_root) THEN
-      !--- Write remaining coordinate variables:
-      CALL NF95_PUT_VAR(fID_ou, levID_ou, lev_in); DEALLOCATE(lev_in)
-      IF(     interpt) CALL NF95_PUT_VAR(fID_ou, timID_ou, tmidday)
-      IF(.NOT.interpt) CALL NF95_PUT_VAR(fID_ou, timID_ou, tmidmonth)
-
-      !--- Write to file (the order of "rlatu" is inverted in the output file):
-        IF (grid_type==unstructured) THEN
-
-          ALLOCATE(o3_out(nlat_ou, nlev_in, ntim_ou, read_climoz))
-          DO i=1,klon_glo
-            o3_out(ind_cell_glo_glo(i),:,:,:)=o3_out3_glo(i,:,:,:)
-          ENDDO
-
-          DO m = 1, read_climoz
-            CALL NF95_PUT_VAR(fID_ou, vID_ou(m), o3_out(nlat_ou:1:-1,:,:,m))
-          END DO
-          
-        ELSE
-          DO m = 1, read_climoz
-            CALL NF95_PUT_VAR(fID_ou, vID_ou(m), o3_out3(:,nlat_ou:1:-1,:,:,m))
-          END DO
-      ENDIF
-      CALL NF95_CLOSE(fID_ou)
-
-
-    ENDIF
-
-
-    !=============================================================================
-    ELSE                                                         !=== ZONAL FIELDS
-    !=============================================================================
-   
-     IF (grid_type==unstructured) THEN
-       nlat_ou=klon_mpi
-
-       IF (is_mpi_root) THEN 
-         ALLOCATE(o3_in2bis(8,nlat_in,nlev_in,0:13,read_climoz)) 
-         o3_in2bis(:,:,:,ib:ie,:)=SPREAD(o3_in2,1,8)
-       ELSE
-         ALLOCATE(o3_in2bis(0,0,0,0,read_climoz))
-       ENDIF
-       ALLOCATE(o3_regr_lat(nlat_ou, nlev_in, 0:13, read_climoz))
-       CALL xios_send_field("tro3_in",o3_in2bis(:,:,:,:,:))
-       CALL xios_recv_field("tro3_out",o3_regr_lat(:,:,:,:))
-       IF(.NOT.lprev) o3_regr_lat(:,:, 0, :) = o3_regr_lat(:,:,12,:)
-       IF(.NOT.lnext) o3_regr_lat(:,:,13, :) = o3_regr_lat(:,:, 1,:)
-     
-     ELSE 
-        !--- Regrid in latitude: averaging with respect to SIN(lat) is
-        !                        equivalent to weighting by COS(lat)
-        !--- (inverted indices in "o3_regr_lat" because "rlatu" is decreasing)
-        ALLOCATE(o3_regr_lat(nlat_ou, nlev_in, 0:13, read_climoz))
-        CALL regr_conserv(1, o3_in2, xs = sinlat_in_edge,                          &
-                        xt = [- 1., SIN(boundslat_reg(nlat_ou-1:1:-1,south)), 1.], &
-                        vt = o3_regr_lat(nlat_ou:1:- 1,:,ib:ie,:),                 &
-                     slope = slopes(1,o3_in2, sinlat_in_edge))
-        DEALLOCATE(o3_in2)
-
-        !--- Duplicate previous/next record(s) if they are not available
-        IF(.NOT.lprev) o3_regr_lat(:,:, 0,:) = o3_regr_lat(:,:,12,:)
-        IF(.NOT.lnext) o3_regr_lat(:,:,13,:) = o3_regr_lat(:,:, 1,:)
-
-     ENDIF
-     
-      !--- Regrid in time by linear interpolation:
-      ALLOCATE(o3_out2(nlat_ou, nlev_in, ntim_ou, read_climoz))
-      IF(     interpt) CALL regr_lint(3,o3_regr_lat, tmidmonth, tmidday, o3_out2)
-      IF(.NOT.interpt) o3_out2=o3_regr_lat
-      DEALLOCATE(o3_regr_lat)
-
-      nlat_ou=nbp_lat
-    
-      IF (grid_type==unstructured) THEN
-        ndims=3 
-        ALLOCATE(o3_out2_glo(nlat_ou, nlev_in, ntim_ou, read_climoz))
-        CALL gather_mpi(o3_out2, o3_out2_glo)
-      ENDIF
-      
-      !--- Create the output file and get the variable IDs:
-      CALL prepare_out(fID_in,nlev_in,ntim_ou, fID_ou,levID_ou,timID_ou,vID_ou, &
-                         ndims, cal_ou)
-
-      IF (is_mpi_root) THEN
-      
-        !--- Write remaining coordinate variables:
-        CALL NF95_PUT_VAR(fID_ou, levID_ou, lev_in); DEALLOCATE(lev_in)
-        IF(     interpt) CALL NF95_PUT_VAR(fID_ou, timID_ou, tmidday)
-        IF(.NOT.interpt) CALL NF95_PUT_VAR(fID_ou, timID_ou, tmidmonth)
-
-        IF (grid_type==unstructured) THEN
-
-          ALLOCATE(o3_out3_glo(nlat_ou, nlev_in, ntim_ou, read_climoz))
-          DO i=1,klon_glo
-            o3_out(ind_cell_glo_glo(i),:,:,:)=o3_out2_glo(i,:,:,:)
-          ENDDO
-
-
-          DO m = 1, read_climoz
-            CALL NF95_PUT_VAR(fID_ou, vID_ou(m), o3_out(nlat_ou:1:-1,:,:,m))
-          END DO
-        ELSE
-          !--- Write to file (the order of "rlatu" is inverted in the output file):
-          DO m = 1, read_climoz
-            CALL NF95_PUT_VAR(fID_ou, vID_ou(m), o3_out2(nlat_ou:1:-1,:,:,m))
-          END DO
-        ENDIF
-        
-        CALL NF95_CLOSE(fID_ou)
-      
-      ENDIF
-
-    !=============================================================================
-    END IF
-    !=============================================================================
-
-    IF (is_mpi_root) CALL NF95_CLOSE(fID_in)
-
-  ENDIF ! is_omp_master
-
-  first=.FALSE.
-END SUBROUTINE regr_horiz_time_climoz
-!
-!-------------------------------------------------------------------------------
-
-
-!-------------------------------------------------------------------------------
-!
-SUBROUTINE prepare_out(fID_in, nlev_in, ntim_ou, fID_ou, vlevID, vtimID, &
-                       vID_ou, ndims, cal_ou)
-!-------------------------------------------------------------------------------
-! Purpose:  This subroutine creates the NetCDF output file, defines
-!     dimensions and variables, and writes some of the coordinate variables.
-!-------------------------------------------------------------------------------
-  USE regular_lonlat_mod, ONLY: lon_reg, lat_reg
-  USE regular_lonlat_mod, ONLY: lon_reg, lat_reg
-  USE mod_phys_lmdz_para, ONLY: is_mpi_root
-  USE mod_grid_phy_lmdz, ONLY: klon_glo
-!
-!-------------------------------------------------------------------------------
-! Arguments:
-  INTEGER, INTENT(IN)  :: fID_in, nlev_in, ntim_ou
-  INTEGER, INTENT(OUT) :: fID_ou, vlevID,  vtimID
-  INTEGER, INTENT(OUT) :: vID_ou(:)      ! dim(1/2) 1: O3day&night 2: O3daylight
-  INTEGER, INTENT(IN)  :: ndims          ! fields rank (3 or 4)
-  CHARACTER(LEN=*), INTENT(IN) :: cal_ou ! calendar
-!-------------------------------------------------------------------------------
-! Local variables:
-  INTEGER :: dlonID, dlatID, dlevID, dtimID, dIDs(4)
-  INTEGER :: vlonID, vlatID, ncerr,  is
-  REAL,ALLOCATABLE    :: latitude_glo_(:)
-  CHARACTER(LEN=80) :: sub
-  INTEGER :: i
-
-
-!-------------------------------------------------------------------------------
-  
-  IF (is_mpi_root) THEN  
-    sub="prepare_out"
-    WRITE(lunout,*)"CALL sequence information: "//TRIM(sub)
-    CALL NF95_CREATE("climoz_LMDZ.nc", NF90_clobber, fID_ou)
-
-  !--- Dimensions:
-    IF(ndims==4) &
-    CALL NF95_DEF_DIM(fID_ou, "rlonv", nlon_ou, dlonID)
-    CALL NF95_DEF_DIM(fID_ou, "rlatu", nlat_ou, dlatID)
-    CALL NF95_DEF_DIM(fID_ou, "plev",  nlev_in, dlevID)
-    CALL NF95_DEF_DIM(fID_ou, "time",  ntim_ou, dtimID)
-
-    !--- Define coordinate variables:
-    IF(ndims==4) &
-    CALL NF95_DEF_VAR(fID_ou, "rlonv", NF90_FLOAT, dlonID, vlonID)
-    CALL NF95_DEF_VAR(fID_ou, "rlatu", NF90_FLOAT, dlatID, vlatID)
-    CALL NF95_DEF_VAR(fID_ou, "plev",  NF90_FLOAT, dlevID, vlevID)
-    CALL NF95_DEF_VAR(fID_ou, "time",  NF90_FLOAT, dtimID, vtimID)
-    IF(ndims==4) &
-    CALL NF95_PUT_ATT(fID_ou, vlonID, "units", "degrees_east")
-    CALL NF95_PUT_ATT(fID_ou, vlatID, "units", "degrees_north")
-    CALL NF95_PUT_ATT(fID_ou, vlevID, "units", "millibar")
-    CALL NF95_PUT_ATT(fID_ou, vtimID, "units", "days since 2000-1-1")
-    IF(ndims==4) &
-    CALL NF95_PUT_ATT(fID_ou, vlonID, "standard_name", "longitude")
-    CALL NF95_PUT_ATT(fID_ou, vlatID, "standard_name", "latitude")
-    CALL NF95_PUT_ATT(fID_ou, vlevID, "standard_name", "air_pressure")
-    CALL NF95_PUT_ATT(fID_ou, vtimID, "standard_name", "time")
-    CALL NF95_PUT_ATT(fID_ou, vlevID, "long_name",     "air pressure")
-    CALL NF95_PUT_ATT(fID_ou, vtimID, "calendar",      cal_ou)
-
-  !--- Define the main variables:
-    IF(ndims==3) dIDs(1:3) = [ dlatID, dlevID, dtimID]
-    IF(ndims==4) dIDs=[dlonID, dlatID, dlevID, dtimID]
-    CALL NF95_DEF_VAR(fID_ou, vars_in(1), NF90_FLOAT, dIDs(1:ndims), vID_ou(1))
-    CALL NF95_PUT_ATT(fID_ou, vID_ou(1), "long_name", "ozone mole fraction")
-    CALL NF95_PUT_ATT(fID_ou, vID_ou(1), "standard_name", "mole_fraction_of_ozone&
-      &_in_air")
-    IF(SIZE(vID_ou) == 2) THEN
-      CALL NF95_DEF_VAR(fID_ou, vars_in(2), NF90_FLOAT, dIDs(1:ndims), vID_ou(2))
-      CALL NF95_PUT_ATT(fID_ou, vID_ou(2), "long_name","ozone mole fraction in da&
-        &ylight")
-    END IF
-
-  !--- Global attributes:
-  ! The following commands, copying attributes, may fail. That is OK.
-  ! It should just mean that the attribute is not defined in the input file.
-    CALL NF95_COPY_ATT(fID_in,NF90_GLOBAL,"Conventions",fID_ou,NF90_GLOBAL, ncerr)
-    CALL handle_err_copy_att("Conventions")
-    CALL NF95_COPY_ATT(fID_in,NF90_GLOBAL,"title",      fID_ou,NF90_GLOBAL, ncerr)
-    CALL handle_err_copy_att("title")
-    CALL NF95_COPY_ATT(fID_in,NF90_GLOBAL,"institution",fID_ou,NF90_GLOBAL, ncerr)
-    CALL handle_err_copy_att("institution")
-    CALL NF95_COPY_ATT(fID_in,NF90_GLOBAL,"source",     fID_ou,NF90_GLOBAL, ncerr)
-    CALL handle_err_copy_att("source")
-    CALL NF95_PUT_ATT (fID_ou,NF90_GLOBAL,"comment", "Regridded for LMDZ")
-    CALL NF95_ENDDEF(fID_ou)
-
-    IF (grid_type==unstructured) THEN
-      ALLOCATE(latitude_glo_(klon_glo))
-      DO i=1,klon_glo
-        latitude_glo_(ind_cell_glo_glo(i))=latitude_glo(i)
-      ENDDO
-      CALL NF95_PUT_VAR(fID_ou, vlatID, latitude_glo_)
-    ELSE
-      !--- Write one of the coordinate variables:
-      IF(ndims==4) CALL NF95_PUT_VAR(fID_ou, vlonID, lon_reg/deg2rad)
-      CALL NF95_PUT_VAR(fID_ou, vlatID, lat_reg(nlat_ou:1:-1)/deg2rad)
-    !    (convert from rad to degrees and sort in ascending order)
-    ENDIF
-  ENDIF
-  
-CONTAINS
-
-!-------------------------------------------------------------------------------
-!
-SUBROUTINE handle_err_copy_att(att_name)
-!
-!-------------------------------------------------------------------------------
-  USE netcdf, ONLY: NF90_NOERR, NF90_strerror
-!-------------------------------------------------------------------------------
-! Arguments:
-  CHARACTER(LEN=*), INTENT(IN) :: att_name
-!-------------------------------------------------------------------------------
-  IF(ncerr /= NF90_NOERR) &
-    WRITE(lunout,*)TRIM(sub)//" prepare_out NF95_COPY_ATT "//TRIM(att_name)//  &
-                      " -- "//TRIM(NF90_strerror(ncerr))
-
-END SUBROUTINE handle_err_copy_att
-!
-!-------------------------------------------------------------------------------
-
-END SUBROUTINE prepare_out
-!
-!-------------------------------------------------------------------------------
-
-END MODULE regr_horiz_time_climoz_m
-!
-!-------------------------------------------------------------------------------
Index: /LMDZ6/trunk/libf/phylmd/regr_horiz_time_climoz_m.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/regr_horiz_time_climoz_m.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/regr_horiz_time_climoz_m.f90	(revision 5268)
@@ -0,0 +1,723 @@
+MODULE regr_horiz_time_climoz_m
+
+  USE interpolation,     ONLY: locate
+  USE mod_grid_phy_lmdz, ONLY: nbp_lon, nbp_lat, grid_type, unstructured
+  USE nrtype,            ONLY: pi
+  USE netcdf,   ONLY: NF90_CLOBBER, NF90_FLOAT,     NF90_OPEN,   &
+                      NF90_NOWRITE, NF90_NOERR,     NF90_GET_ATT, NF90_GLOBAL
+  USE netcdf95, ONLY: NF95_DEF_DIM, NF95_INQ_DIMID, NF95_INQUIRE_DIMENSION,    &
+       NF95_DEF_VAR, NF95_INQ_VARID, NF95_INQUIRE_VARIABLE, &
+       NF95_OPEN,  NF95_CREATE,  NF95_GET_ATT,   NF95_GW_VAR,  nf95_get_var,  &
+       NF95_CLOSE, NF95_ENDDEF,  NF95_PUT_ATT,   NF95_PUT_VAR, NF95_COPY_ATT
+  USE print_control_mod, ONLY: lunout
+  USE dimphy
+  IMPLICIT NONE
+  PRIVATE
+  PUBLIC :: regr_horiz_time_climoz
+  REAL, PARAMETER :: deg2rad=pi/180.
+  CHARACTER(LEN=13), PARAMETER :: vars_in(2)=['tro3         ','tro3_daylight']
+
+  INTEGER :: nlat_ou, nlon_ou
+  REAL, ALLOCATABLE :: latitude_glo(:)
+!$OMP THREADPRIVATE(latitude_glo)
+  INTEGER, ALLOCATABLE :: ind_cell_glo_glo(:)
+!$OMP THREADPRIVATE(ind_cell_glo_glo)
+
+CONTAINS
+
+!-------------------------------------------------------------------------------
+!
+SUBROUTINE regr_horiz_time_climoz(read_climoz,interpt)
+!
+!-------------------------------------------------------------------------------
+! Purpose: Regrid horizontally and in time zonal or 3D ozone climatologies.
+!   * Read ozone climatology from netcdf file
+!   * Regrid it horizontaly to LMDZ grid (quasi-conservative method)
+!   * If interpt=T, interpolate linearly in time (one record each day)
+!     If interpt=F, keep original time sampling  (14 months).
+!   * Save it to a new netcdf file.
+!-------------------------------------------------------------------------------
+! Remarks:
+!   * Up to 2 variables treated: "tro3" and "tro3_daylight" (if read_climoz=2)
+!   * Input fields coordinates: (longitudes, latitudes, pressure_levels, time)
+!   * Output grid cells centers coordinates given by [rlonv,] rlatu.
+!   * Output grid cells edges   coordinates given by [rlonu,] rlatv.
+!   * Input file [longitudes and] latitudes given in degrees.
+!   * Input file pressure levels are given in Pa or hPa.
+!   * All coordinates variables are stricly monotonic.
+!   * Monthly fields are interpolated linearly in time to get daily values.
+!   * Fields are known at the middle of the months, so interpolation requires an
+!     additional record both for 1st half of january and 2nd half of december:
+!     - For a 14-records "climoz.nc": records 1 and 14.
+!     - For 12-records files:
+!       record 12 of "climoz_m.nc" if available, or record 1  of "climoz.nc".
+!       record 1  of "climoz_p.nc" if available, or record 12 of "climoz.nc".
+!   * Calendar is taken into account to get one record each day (not 360 always).
+!   * Missing values are filled in from sky to ground by copying lowest valid one.
+!     Attribute "missing_value" or "_FillValue" must be present in input file.
+!-------------------------------------------------------------------------------
+  USE assert_m,           ONLY: assert
+  USE cal_tools_m,        ONLY: year_len, mid_month
+!!  USE control_mod,        ONLY: anneeref
+  USE time_phylmdz_mod,   ONLY: annee_ref
+  USE ioipsl,             ONLY: ioget_year_len, ioget_calendar
+  USE regr_conserv_m,     ONLY: regr_conserv
+  USE regr_lint_m,        ONLY: regr_lint
+  USE regular_lonlat_mod, ONLY: boundslon_reg, boundslat_reg, south, west, east
+  USE slopes_m,           ONLY: slopes
+  USE lmdz_xios
+  USE mod_phys_lmdz_para, ONLY: is_mpi_root, is_master, is_omp_master, gather, gather_mpi, bcast_mpi, klon_mpi
+  USE geometry_mod, ONLY : latitude_deg, ind_cell_glo
+  USE mod_grid_phy_lmdz, ONLY: klon_glo
+
+!-------------------------------------------------------------------------------
+! Arguments:
+  INTEGER, INTENT(IN) :: read_climoz ! read ozone climatology, 1 or 2
+!                         1: read a single ozone climatology used day and night
+!                         2: same + read also a daylight climatology
+  LOGICAL, INTENT(IN) :: interpt     ! TRUE  => daily interpolation
+                                     ! FALSE => no interpolation (14 months)
+!-------------------------------------------------------------------------------
+! Local variables:
+
+!--- Input files variables
+  INTEGER :: nlon_in                       ! Number of longitudes
+  INTEGER :: nlat_in                       ! Number of latitudes
+  INTEGER :: nlev_in                       ! Number of pressure levels
+  INTEGER :: nmth_in                       ! Number of months
+  REAL, ALLOCATABLE:: lon_in(:)           ! Longitudes   (ascending order, rad)
+  REAL, ALLOCATABLE:: lat_in(:)           ! Latitudes    (ascending order, rad)
+  REAL, ALLOCATABLE:: lev_in(:)           ! Pressure levels (ascen. order, hPa)
+  REAL, ALLOCATABLE :: lon_in_edge(:)      ! Longitude intervals edges
+                                           !              (ascending order,  / )
+  REAL, ALLOCATABLE :: sinlat_in_edge(:)   ! Sinus of latitude intervals edges
+                                           !              (ascending order,  / )
+  LOGICAL :: ldec_lon, ldec_lat, ldec_lev  ! Decreasing order in input file
+  CHARACTER(LEN=20) :: cal_in              ! Calendar
+  REAL, ALLOCATABLE :: o3_in3(:,:,:,:,:)   ! Ozone climatologies
+  REAL, ALLOCATABLE :: o3_in3bis(:,:,:,:,:)   ! Ozone climatologies
+  REAL, ALLOCATABLE :: o3_in2  (:,:,:,:)   ! Ozone climatologies
+  REAL, ALLOCATABLE :: o3_in2bis(:,:,:,:,:)   ! Ozone climatologies
+  ! last index: 1 for the day-night average, 2 for the daylight field.
+  REAL :: NaN
+
+!--- Partially or totally regridded variables      (:,:,nlev_in,:,read_climoz)
+  REAL, ALLOCATABLE :: o3_regr_lon   (:,:,:,:,:) ! (nlon_ou,nlat_in,:,0:13   ,:)
+  REAL, ALLOCATABLE :: o3_regr_lonlat(:,:,:,:,:) ! (nlon_ou,nlat_ou,:,0:13   ,:)
+  REAL, ALLOCATABLE :: o3_out3       (:,:,:,:,:) ! (nlon_ou,nlat_ou,:,ntim_ou,:)
+  REAL, ALLOCATABLE :: o3_out3_glo   (:,:,:,:) !   (nbp_lat,:,ntim_ou,:)
+  REAL, ALLOCATABLE :: o3_regr_lat     (:,:,:,:) !         (nlat_in,:,0:13   ,:)
+  REAL, ALLOCATABLE :: o3_out2         (:,:,:,:) !         (nlat_ou,:,ntim_ou,:)
+  REAL, ALLOCATABLE :: o3_out2_glo     (:,:,:,:) !         (nbp_lat,:,ntim_ou,:)
+  REAL, ALLOCATABLE :: o3_out          (:,:,:,:) !         (nbp_lat,:,ntim_ou,:)
+! Dimension number  | Interval                | Contains  | For variables:
+!   1 (longitude)   | [rlonu(i-1), rlonu(i)]  | rlonv(i)  | all
+!   2 (latitude)    | [rlatv(j), rlatv(j-1)]  | rlatu(j)  | all but o3_regr_lon
+!   3 (press level) |                         |   lev(k)  | all
+! Note that rlatv(0)=pi/2 and rlatv(nlat_ou)=-pi/2.
+! Dimension 4 is: month number                             (all vars but o3_out)
+!                 days elapsed since Jan. 1st 0h at mid-day (o3_out only)
+  REAL, ALLOCATABLE :: v1(:)
+
+!--- For NetCDF:
+  INTEGER :: fID_in_m, fID_in, levID_ou, dimid, vID_in(read_climoz), ntim_ou
+  INTEGER :: fID_in_p, fID_ou, timID_ou, varid, vID_ou(read_climoz), ndims, ncerr
+  INTEGER, ALLOCATABLE :: dIDs(:)
+  CHARACTER(LEN=20) :: cal_ou     !--- Calendar; no time inter => same as input
+  CHARACTER(LEN=80) :: press_unit !--- Pressure unit
+  REAL    :: tmidmonth(0:13)      !--- Elapsed days since Jan-1 0h at mid-months
+                                  ! Additional records 0, 13 for interpolation
+  REAL, ALLOCATABLE :: tmidday(:) !--- Output times (mid-days since Jan 1st 0h)
+  LOGICAL :: lprev, lnext         !--- Flags: previous/next files are present
+  LOGICAL :: l3D, l2D             !--- Flag:  input fields are 3D or zonal
+  INTEGER :: ii, i, j, k, l, m, dln, ib, ie, iv, dx1, dx2
+  INTEGER, ALLOCATABLE :: sta(:), cnt(:)
+  CHARACTER(LEN=80) :: sub, dim_nam, msg
+  REAL :: null_array(0)
+  LOGICAL,SAVE :: first=.TRUE.
+!$OMP THREADPRIVATE(first)  
+  REAL, ALLOCATABLE :: test_o3_in(:,:)
+  REAL, ALLOCATABLE :: test_o3_out(:)
+
+
+  IF (grid_type==unstructured) THEN 
+    IF (first) THEN
+      IF (is_master) THEN
+        ALLOCATE(latitude_glo(klon_glo))
+        ALLOCATE(ind_cell_glo_glo(klon_glo))
+      ELSE
+        ALLOCATE(latitude_glo(0))
+        ALLOCATE(ind_cell_glo_glo(0))
+      ENDIF
+      CALL gather(latitude_deg,  latitude_glo)
+      CALL gather(ind_cell_glo,  ind_cell_glo_glo)
+    ENDIF 
+  ENDIF
+    
+  IF (is_omp_master) THEN
+    nlat_ou=nbp_lat
+    nlon_ou=nbp_lon
+    
+   !-------------------------------------------------------------------------------
+    IF (is_mpi_root) THEN
+      sub="regr_horiz_time_climoz"
+      WRITE(lunout,*)"Call sequence information: "//TRIM(sub)
+      CALL assert(read_climoz == 1 .OR. read_climoz == 2, "regr_lat_time_climoz")
+
+      CALL  NF95_OPEN("climoz.nc"  , NF90_NOWRITE, fID_in)
+      lprev=NF90_OPEN("climoz_m.nc", NF90_NOWRITE, fID_in_m)==NF90_NOERR
+      lnext=NF90_OPEN("climoz_p.nc", NF90_NOWRITE, fID_in_p)==NF90_NOERR
+
+      !--- Get coordinates from the input file. Converts lon/lat in radians.
+      !    Few inversions because "regr_conserv" and gcm need ascending vectors.
+      CALL NF95_INQ_VARID(fID_in, vars_in(1), varid)
+      CALL NF95_INQUIRE_VARIABLE(fID_in, varid, dimids=dIDs, ndims=ndims)
+      l3D=ndims==4; l2D=ndims==3
+      IF(l3D) WRITE(lunout,*)"Input files contain full 3D ozone fields."
+      IF(l2D) WRITE(lunout,*)"Input files contain zonal 2D ozone fields."
+      DO i=1,ndims
+        CALL NF95_INQUIRE_DIMENSION(fID_in, dIDs(i), name=dim_nam, nclen=dln)
+        CALL NF95_INQ_VARID(fID_in, dim_nam, varid)
+        ii=i; IF(l2D) ii=i+1                              !--- ndims==3:NO LONGITUDE 
+        SELECT CASE(ii)
+          CASE(1)                                         !--- LONGITUDE
+            CALL NF95_GW_VAR(fID_in, varid, lon_in)
+            ldec_lon=lon_in(1)>lon_in(dln); IF(ldec_lon) lon_in=lon_in(dln:1:-1)
+            nlon_in=dln; lon_in=lon_in*deg2rad
+          CASE(2)                                         !--- LATITUDE
+            CALL NF95_GW_VAR(fID_in, varid, lat_in)
+            ldec_lat=lat_in(1)>lat_in(dln); IF(ldec_lat) lat_in=lat_in(dln:1:-1)
+            nlat_in=dln; lat_in=lat_in*deg2rad
+          CASE(3)                                         !--- PRESSURE LEVELS
+            CALL NF95_GW_VAR(fID_in, varid, lev_in)
+            ldec_lev=lev_in(1)>lev_in(dln); IF(ldec_lev) lev_in=lev_in(dln:1:-1)
+            nlev_in=dln
+            CALL NF95_GET_ATT(fID_in, varid, "units", press_unit)
+            k=LEN_TRIM(press_unit)
+            DO WHILE(ICHAR(press_unit(k:k))==0)
+              press_unit(k:k)=' '; k=LEN_TRIM(press_unit) !--- REMOVE NULL END CHAR
+            END DO
+            IF(press_unit ==  "Pa") THEN
+              lev_in = lev_in/100.                        !--- CONVERT TO hPa
+            ELSE IF(press_unit /= "hPa") THEN
+              CALL abort_physic(sub, "the only recognized units are Pa and hPa.",1)
+            END IF
+          CASE(4)                                         !--- TIME
+            CALL NF95_INQUIRE_DIMENSION(fID_in, dIDs(i), nclen=nmth_in)
+            cal_in='gregorian'
+            IF(NF90_GET_ATT(fID_in, varid, 'calendar', cal_in)/=NF90_NOERR)        &  
+            WRITE(lunout,*)'WARNING: missing "calendar" attribute for "'//       &
+            TRIM(dim_nam)//'" in "climoz.nc". Choosing default: "gregorian".'
+            k=LEN_TRIM(cal_in)
+            DO WHILE(ICHAR(cal_in(k:k))==0)
+              cal_in(k:k)=' '; k=LEN_TRIM(cal_in)         !--- REMOVE NULL END CHAR
+            END DO
+        END SELECT
+      END DO
+
+      !--- Prepare quantities for time interpolation
+      tmidmonth=mid_month(annee_ref, cal_in)
+      IF(interpt) THEN
+        ntim_ou=ioget_year_len(annee_ref)
+        ALLOCATE(tmidday(ntim_ou))
+        tmidday=[(REAL(k)-0.5,k=1,ntim_ou)]
+        CALL ioget_calendar(cal_ou)
+      ELSE
+        ntim_ou=14
+        cal_ou=cal_in
+      END IF
+    ENDIF
+
+    IF (grid_type==unstructured) THEN
+      CALL bcast_mpi(nlon_in)
+      CALL bcast_mpi(nlat_in)
+      CALL bcast_mpi(nlev_in)
+      CALL bcast_mpi(l3d)
+      CALL bcast_mpi(tmidmonth)
+      IF(interpt) CALL bcast_mpi(tmidday)
+      CALL bcast_mpi(ntim_ou)
+
+      IF (is_mpi_root) THEN
+        CALL xios_set_domain_attr("domain_climoz",nj_glo=nlat_in, nj=nlat_in, jbegin=0, latvalue_1d=lat_in/deg2rad)
+        IF (l3D) THEN
+          CALL xios_set_domain_attr("domain_climoz",ni_glo=nlon_in, ni=nlon_in, ibegin=0, lonvalue_1d=lon_in/deg2rad)
+        ELSE
+          CALL xios_set_domain_attr("domain_climoz",ni_glo=8, ni=8, ibegin=0, lonvalue_1d = (/ 0.,45.,90.,135.,180.,225.,270., 315. /))
+        ENDIF
+      ELSE
+        CALL xios_set_domain_attr("domain_climoz",nj_glo=nlat_in, nj=0, jbegin=0, latvalue_1d=null_array )
+        IF (l3D) THEN
+          CALL xios_set_domain_attr("domain_climoz",ni_glo=nlon_in, ni=0, ibegin=0, lonvalue_1d=null_array)
+        ELSE
+          CALL xios_set_domain_attr("domain_climoz",ni_glo=8, ni=0, ibegin=0, lonvalue_1d=null_array)
+        ENDIF
+      ENDIF
+      CALL  xios_set_axis_attr("axis_climoz", n_glo=nlev_in)
+      CALL  xios_set_axis_attr("time_axis_climoz", n_glo=ntim_ou)
+      CALL  xios_set_axis_attr("time_axis_climoz", n_glo=ntim_ou)
+      CALL  xios_set_axis_attr("tr_climoz", n_glo=read_climoz)
+      CALL  xios_set_field_attr("tro3_out", enabled=.TRUE.)
+      CALL  xios_set_field_attr("tro3_out", enabled=.TRUE.)
+      
+      IF (first) THEN
+        first=.FALSE.
+        RETURN
+      ENDIF
+    ENDIF
+    
+    
+    IF (is_mpi_root) THEN     
+      !--- Longitudes management:
+      !    * Need to shift data if the origin of input file longitudes /= -pi
+      !    * Need to add some margin in longitude to ensure input interval contains
+      !      all the output intervals => at least one longitudes slice has to be
+      !      duplicated, possibly more for undersampling.
+      IF(l3D) THEN
+        IF (grid_type==unstructured) THEN
+          dx2=0
+        ELSE
+          !--- Compute input edges longitudes vector (no end point yet)
+          ALLOCATE(v1(nlon_in+1))
+          v1(1)=(lon_in(nlon_in)+lon_in(1))/2.-pi
+          FORALL(i=2:nlon_in) v1(i)=(lon_in(i-1)+lon_in(i))/2.
+          v1(nlon_in+1)=v1(1)+2.*pi
+          DEALLOCATE(lon_in)
+
+          !--- Shift input longitudes vector until it contains first output point boundslon_reg(1,west)
+          v1=v1+2*pi*REAL(FLOOR((boundslon_reg(1,west)-v1(1))/(2.*pi)))
+
+          !--- Ensure first input longitudes interval contains first output point boundslon_reg(1,west)
+          dx1=locate(v1,boundslon_reg(1,west))-1
+          v1=CSHIFT(v1,SHIFT=dx1,DIM=1) 
+          v1(nlon_in-dx1+2:)=v1(nlon_in-dx1+2:)+2.*pi
+    
+          !--- Extend input longitudes vector until last interval contains boundslon_reg(nlat_ou,east)
+          dx2=0; DO WHILE(v1(1+dx2)+2.*pi<=boundslon_reg(nlon_ou,east)); dx2=dx2+1; END DO
+
+          !--- Final edges longitudes vector (with margin and end point)
+          ALLOCATE(lon_in_edge(nlon_in+dx2+1)); lon_in_edge=[v1,v1(2:1+dx2)+2.*pi]
+          DEALLOCATE(v1)
+        ENDIF
+      END IF
+
+      !--- Compute sinus of intervals edges latitudes:
+      ALLOCATE(sinlat_in_edge(nlat_in+1))
+      sinlat_in_edge(1) = -1. ; sinlat_in_edge(nlat_in+1) = 1.
+      FORALL(j=2:nlat_in) sinlat_in_edge(j)=SIN((lat_in(j-1)+lat_in(j))/2.)
+      DEALLOCATE(lat_in)
+
+
+
+      !--- Check for contiguous years:
+      ib=0; ie=13
+      IF(nmth_in == 14) THEN; lprev=.FALSE.; lnext=.FALSE.
+        WRITE(lunout,*)'Using 14 months ozone climatology "climoz.nc"...'
+      ELSE  
+        IF(     lprev) WRITE(lunout,*)'Using "climoz_m.nc" last record (previous year).'
+        IF(.NOT.lprev) WRITE(lunout,*)"No previous year file ; assuming periodicity."
+        IF(     lnext) WRITE(lunout,*)'Using "climoz_p.nc" first record (next year).'
+        IF(.NOT.lnext) WRITE(lunout,*)"No next year file ; assuming periodicity."
+        IF(.NOT.lprev) ib=1
+        IF(.NOT.lnext) ie=12
+      END IF
+      ALLOCATE(sta(ndims),cnt(ndims)); sta(:)=1  
+      IF(l3D) cnt=[nlon_in,nlat_in,nlev_in,1]
+      IF(l2D) cnt=[        nlat_in,nlev_in,1]  
+      IF(l3D) ALLOCATE(o3_in3(nlon_in+dx2,nlat_in,nlev_in,ib:ie,read_climoz))
+      IF(l2D) ALLOCATE(o3_in2(            nlat_in,nlev_in,ib:ie,read_climoz))
+
+      !--- Read full current file and one record each available contiguous file
+      DO iv=1,read_climoz
+        CALL NF95_INQ_VARID(fID_in, vars_in(1), vID_in(iv))
+        IF(l3D) call NF95_GET_VAR(fID_in, vID_in(iv), o3_in3(1:nlon_in,:,:,1:12,iv))
+        IF(l2D) call NF95_GET_VAR(fID_in, vID_in(iv), o3_in2(          :,:,1:12,iv))
+        IF(lprev) THEN; sta(ndims)=12  
+          CALL NF95_INQ_VARID(fID_in_m, vars_in(1), vID_in(iv))
+          IF(l3D) call NF95_GET_VAR(fID_in_m,vID_in(iv),o3_in3(1:nlon_in,:,:, 0,iv),sta,cnt)
+          IF(l2d) call NF95_GET_VAR(fID_in_m,vID_in(iv),o3_in2(          :,:, 0,iv),sta,cnt)
+        END IF
+        IF(lnext) THEN; sta(ndims)=1  
+          CALL NF95_INQ_VARID(fID_in_p, vars_in(1), vID_in(iv))
+          IF(l3D) call NF95_GET_VAR(fID_in_p,vID_in(iv),o3_in3(1:nlon_in,:,:,13,iv),sta,cnt)
+          IF(l2D) call NF95_GET_VAR(fID_in_p,vID_in(iv),o3_in2(          :,:,13,iv),sta,cnt)
+        END IF
+      END DO
+      IF(lprev.OR.lnext) DEALLOCATE(sta,cnt)
+      IF(lprev) CALL NF95_CLOSE(fID_in_m)
+      IF(lnext) CALL NF95_CLOSE(fID_in_p)
+
+      !--- Revert decreasing coordinates vector
+      IF(l3D) THEN
+        IF(ldec_lon) o3_in3(1:nlon_in,:,:,:,:) = o3_in3(nlon_in:1:-1,:,:,:,:)
+        IF(ldec_lat) o3_in3 = o3_in3(:,nlat_in:1:-1,:,:,:)
+        IF(ldec_lev) o3_in3 = o3_in3(:,:,nlev_in:1:-1,:,:)
+        
+        IF (grid_type /= unstructured) THEN
+          !--- Shift values for longitude and duplicate some longitudes slices
+          o3_in3(1:nlon_in,:,:,:,:)=CSHIFT(o3_in3(1:nlon_in,:,:,:,:),SHIFT=dx1,DIM=1)
+          o3_in3(nlon_in+1:nlon_in+dx2,:,:,:,:)=o3_in3(1:dx2,:,:,:,:)
+        ENDIF
+      ELSE
+        IF(ldec_lat) o3_in2 = o3_in2(  nlat_in:1:-1,:,:,:)
+        IF(ldec_lev) o3_in2 = o3_in2(  :,nlev_in:1:-1,:,:)
+      END IF
+
+     !--- Deal with missing values 
+      DO m=1, read_climoz
+        WRITE(msg,'(a,i0)')"regr_lat_time_climoz: field Nr.",m
+        IF(NF90_GET_ATT(fID_in,vID_in(m),"missing_value",NaN)/= NF90_NOERR) THEN
+          IF(NF90_GET_ATT(fID_in, vID_in(m),"_FillValue",NaN)/= NF90_NOERR) THEN
+            WRITE(lunout,*)TRIM(msg)//": no missing value attribute found."; CYCLE
+          END IF
+        END IF
+        WRITE(lunout,*)TRIM(msg)//": missing value attribute found."
+        WRITE(lunout,*)"Trying to fill in NaNs ; a full field would be better."
+
+        !--- Check top layer contains no NaNs & search NaNs from top to ground
+        msg=TRIM(sub)//": NaNs in top layer !"
+        IF(l3D) THEN
+          IF(ANY(o3_in3(:,:,1,:,m)==NaN)) CALL abort_physic(sub,msg,1)
+          DO k = 2,nlev_in
+            WHERE(o3_in3(:,:,k,:,m)==NaN) o3_in3(:,:,k,:,m)=o3_in3(:,:,k-1,:,m)
+          END DO
+        ELSE
+          IF(ANY(o3_in2(  :,1,:,m)==NaN)) THEN
+            WRITE(lunout,*)msg
+            !--- Fill in latitudes where all values are missing
+            DO l=1,nmth_in
+              !--- Next to south pole
+              j=1;       DO WHILE(o3_in2(j,1,l,m)==NaN); j=j+1; END DO
+              IF(j>1) &
+                o3_in2(:j-1,:,l,m)=SPREAD(o3_in2(j,:,l,m),DIM=1,ncopies=j-1)
+              !--- Next to north pole
+              j=nlat_in; DO WHILE(o3_in2(j,1,l,m)==NaN); j=j+1; END DO
+              IF(j<nlat_in) &
+                o3_in2(j+1:,:,l,m)=SPREAD(o3_in2(j,:,l,m),DIM=1,ncopies=nlat_in-j)
+            END DO
+          END IF
+
+          !--- Fill in high latitudes missing values
+          !--- Highest level been filled-in, so has always valid values.
+          DO k = 2,nlev_in
+            WHERE(o3_in2(:,k,:,m)==NaN) o3_in2(:,k,:,m)=o3_in2(:,k-1,:,m)
+          END DO
+        END IF
+      END DO
+
+    ENDIF
+    
+    !=============================================================================
+    IF(l3D) THEN                                                   !=== 3D FIELDS
+    !=============================================================================
+     IF (grid_type==unstructured) THEN
+       nlat_ou=klon_mpi
+       
+       IF (is_mpi_root) THEN 
+         ALLOCATE(o3_in3bis(nlon_in,nlat_in,nlev_in,0:13,read_climoz)) 
+         o3_in3bis(:,:,:,ib:ie,:)=o3_in3(1:nlon_in,:,:,ib:ie,:)
+       ELSE
+         ALLOCATE(o3_in3bis(0,0,0,0,read_climoz))
+       ENDIF
+       ALLOCATE(o3_regr_lonlat(1, nlat_ou, nlev_in, 0:13, read_climoz))
+       
+       CALL xios_send_field("tro3_in",o3_in3bis(:,:,:,:,:))
+       CALL xios_recv_field("tro3_out",o3_regr_lonlat(1,:,:,:,:))
+     ELSE
+          
+       !--- Regrid in longitude
+        ALLOCATE(o3_regr_lon(nlon_ou, nlat_in, nlev_in, ie-ib+1, read_climoz))
+        CALL regr_conserv(1, o3_in3, xs = lon_in_edge,                             &
+                            xt = [boundslon_reg(1,west),boundslon_reg(:,east)],    &
+                            vt = o3_regr_lon, slope = slopes(1,o3_in3, lon_in_edge))
+        DEALLOCATE(o3_in3)
+
+        !--- Regrid in latitude: averaging with respect to SIN(lat) is
+        !                        equivalent to weighting by COS(lat)
+        !--- (inverted indices in "o3_regr_lonlat" because "rlatu" is decreasing)
+        ALLOCATE(o3_regr_lonlat(nlon_ou, nlat_ou, nlev_in, 0:13, read_climoz))
+        CALL regr_conserv(2, o3_regr_lon, xs = sinlat_in_edge,                     &
+                        xt = [- 1., SIN(boundslat_reg(nlat_ou-1:1:-1,south)), 1.], &
+                        vt = o3_regr_lonlat(:,nlat_ou:1:- 1,:,ib:ie,:),            &
+                   slope = slopes(2,o3_regr_lon, sinlat_in_edge))
+        DEALLOCATE(o3_regr_lon)
+
+     ENDIF
+
+     !--- Duplicate previous/next record(s) if they are not available
+     IF(.NOT.lprev) o3_regr_lonlat(:,:,:, 0,:) = o3_regr_lonlat(:,:,:,12,:)
+     IF(.NOT.lnext) o3_regr_lonlat(:,:,:,13,:) = o3_regr_lonlat(:,:,:, 1,:)
+      
+     !--- Regrid in time by linear interpolation:
+     ALLOCATE(o3_out3(nlon_ou, nlat_ou, nlev_in, ntim_ou, read_climoz))
+     IF(     interpt) CALL regr_lint(4,o3_regr_lonlat,tmidmonth,tmidday,o3_out3)
+     IF(.NOT.interpt) o3_out3=o3_regr_lonlat
+     DEALLOCATE(o3_regr_lonlat)
+
+     nlat_ou=nbp_lat
+     IF (grid_type==unstructured) THEN
+       CALL xios_send_field('o3_out',o3_out3)
+       ndims=3 
+       ALLOCATE(o3_out3_glo(nlat_ou, nlev_in, ntim_ou, read_climoz))
+       CALL gather_mpi(o3_out3(1,:,:,:,:), o3_out3_glo)
+     ENDIF
+
+    !--- Create the output file and get the variable IDs:
+    CALL prepare_out(fID_in,nlev_in,ntim_ou, fID_ou,levID_ou,timID_ou,vID_ou, &
+                     ndims, cal_ou)
+
+    IF (is_mpi_root) THEN
+      !--- Write remaining coordinate variables:
+      CALL NF95_PUT_VAR(fID_ou, levID_ou, lev_in); DEALLOCATE(lev_in)
+      IF(     interpt) CALL NF95_PUT_VAR(fID_ou, timID_ou, tmidday)
+      IF(.NOT.interpt) CALL NF95_PUT_VAR(fID_ou, timID_ou, tmidmonth)
+
+      !--- Write to file (the order of "rlatu" is inverted in the output file):
+        IF (grid_type==unstructured) THEN
+
+          ALLOCATE(o3_out(nlat_ou, nlev_in, ntim_ou, read_climoz))
+          DO i=1,klon_glo
+            o3_out(ind_cell_glo_glo(i),:,:,:)=o3_out3_glo(i,:,:,:)
+          ENDDO
+
+          DO m = 1, read_climoz
+            CALL NF95_PUT_VAR(fID_ou, vID_ou(m), o3_out(nlat_ou:1:-1,:,:,m))
+          END DO
+          
+        ELSE
+          DO m = 1, read_climoz
+            CALL NF95_PUT_VAR(fID_ou, vID_ou(m), o3_out3(:,nlat_ou:1:-1,:,:,m))
+          END DO
+      ENDIF
+      CALL NF95_CLOSE(fID_ou)
+
+
+    ENDIF
+
+
+    !=============================================================================
+    ELSE                                                         !=== ZONAL FIELDS
+    !=============================================================================
+   
+     IF (grid_type==unstructured) THEN
+       nlat_ou=klon_mpi
+
+       IF (is_mpi_root) THEN 
+         ALLOCATE(o3_in2bis(8,nlat_in,nlev_in,0:13,read_climoz)) 
+         o3_in2bis(:,:,:,ib:ie,:)=SPREAD(o3_in2,1,8)
+       ELSE
+         ALLOCATE(o3_in2bis(0,0,0,0,read_climoz))
+       ENDIF
+       ALLOCATE(o3_regr_lat(nlat_ou, nlev_in, 0:13, read_climoz))
+       CALL xios_send_field("tro3_in",o3_in2bis(:,:,:,:,:))
+       CALL xios_recv_field("tro3_out",o3_regr_lat(:,:,:,:))
+       IF(.NOT.lprev) o3_regr_lat(:,:, 0, :) = o3_regr_lat(:,:,12,:)
+       IF(.NOT.lnext) o3_regr_lat(:,:,13, :) = o3_regr_lat(:,:, 1,:)
+     
+     ELSE 
+        !--- Regrid in latitude: averaging with respect to SIN(lat) is
+        !                        equivalent to weighting by COS(lat)
+        !--- (inverted indices in "o3_regr_lat" because "rlatu" is decreasing)
+        ALLOCATE(o3_regr_lat(nlat_ou, nlev_in, 0:13, read_climoz))
+        CALL regr_conserv(1, o3_in2, xs = sinlat_in_edge,                          &
+                        xt = [- 1., SIN(boundslat_reg(nlat_ou-1:1:-1,south)), 1.], &
+                        vt = o3_regr_lat(nlat_ou:1:- 1,:,ib:ie,:),                 &
+                     slope = slopes(1,o3_in2, sinlat_in_edge))
+        DEALLOCATE(o3_in2)
+
+        !--- Duplicate previous/next record(s) if they are not available
+        IF(.NOT.lprev) o3_regr_lat(:,:, 0,:) = o3_regr_lat(:,:,12,:)
+        IF(.NOT.lnext) o3_regr_lat(:,:,13,:) = o3_regr_lat(:,:, 1,:)
+
+     ENDIF
+     
+      !--- Regrid in time by linear interpolation:
+      ALLOCATE(o3_out2(nlat_ou, nlev_in, ntim_ou, read_climoz))
+      IF(     interpt) CALL regr_lint(3,o3_regr_lat, tmidmonth, tmidday, o3_out2)
+      IF(.NOT.interpt) o3_out2=o3_regr_lat
+      DEALLOCATE(o3_regr_lat)
+
+      nlat_ou=nbp_lat
+    
+      IF (grid_type==unstructured) THEN
+        ndims=3 
+        ALLOCATE(o3_out2_glo(nlat_ou, nlev_in, ntim_ou, read_climoz))
+        CALL gather_mpi(o3_out2, o3_out2_glo)
+      ENDIF
+      
+      !--- Create the output file and get the variable IDs:
+      CALL prepare_out(fID_in,nlev_in,ntim_ou, fID_ou,levID_ou,timID_ou,vID_ou, &
+                         ndims, cal_ou)
+
+      IF (is_mpi_root) THEN
+      
+        !--- Write remaining coordinate variables:
+        CALL NF95_PUT_VAR(fID_ou, levID_ou, lev_in); DEALLOCATE(lev_in)
+        IF(     interpt) CALL NF95_PUT_VAR(fID_ou, timID_ou, tmidday)
+        IF(.NOT.interpt) CALL NF95_PUT_VAR(fID_ou, timID_ou, tmidmonth)
+
+        IF (grid_type==unstructured) THEN
+
+          ALLOCATE(o3_out3_glo(nlat_ou, nlev_in, ntim_ou, read_climoz))
+          DO i=1,klon_glo
+            o3_out(ind_cell_glo_glo(i),:,:,:)=o3_out2_glo(i,:,:,:)
+          ENDDO
+
+
+          DO m = 1, read_climoz
+            CALL NF95_PUT_VAR(fID_ou, vID_ou(m), o3_out(nlat_ou:1:-1,:,:,m))
+          END DO
+        ELSE
+          !--- Write to file (the order of "rlatu" is inverted in the output file):
+          DO m = 1, read_climoz
+            CALL NF95_PUT_VAR(fID_ou, vID_ou(m), o3_out2(nlat_ou:1:-1,:,:,m))
+          END DO
+        ENDIF
+        
+        CALL NF95_CLOSE(fID_ou)
+      
+      ENDIF
+
+    !=============================================================================
+    END IF
+    !=============================================================================
+
+    IF (is_mpi_root) CALL NF95_CLOSE(fID_in)
+
+  ENDIF ! is_omp_master
+
+  first=.FALSE.
+END SUBROUTINE regr_horiz_time_climoz
+!
+!-------------------------------------------------------------------------------
+
+
+!-------------------------------------------------------------------------------
+!
+SUBROUTINE prepare_out(fID_in, nlev_in, ntim_ou, fID_ou, vlevID, vtimID, &
+                       vID_ou, ndims, cal_ou)
+!-------------------------------------------------------------------------------
+! Purpose:  This subroutine creates the NetCDF output file, defines
+!     dimensions and variables, and writes some of the coordinate variables.
+!-------------------------------------------------------------------------------
+  USE regular_lonlat_mod, ONLY: lon_reg, lat_reg
+  USE regular_lonlat_mod, ONLY: lon_reg, lat_reg
+  USE mod_phys_lmdz_para, ONLY: is_mpi_root
+  USE mod_grid_phy_lmdz, ONLY: klon_glo
+!
+!-------------------------------------------------------------------------------
+! Arguments:
+  INTEGER, INTENT(IN)  :: fID_in, nlev_in, ntim_ou
+  INTEGER, INTENT(OUT) :: fID_ou, vlevID,  vtimID
+  INTEGER, INTENT(OUT) :: vID_ou(:)      ! dim(1/2) 1: O3day&night 2: O3daylight
+  INTEGER, INTENT(IN)  :: ndims          ! fields rank (3 or 4)
+  CHARACTER(LEN=*), INTENT(IN) :: cal_ou ! calendar
+!-------------------------------------------------------------------------------
+! Local variables:
+  INTEGER :: dlonID, dlatID, dlevID, dtimID, dIDs(4)
+  INTEGER :: vlonID, vlatID, ncerr,  is
+  REAL,ALLOCATABLE    :: latitude_glo_(:)
+  CHARACTER(LEN=80) :: sub
+  INTEGER :: i
+
+
+!-------------------------------------------------------------------------------
+  
+  IF (is_mpi_root) THEN  
+    sub="prepare_out"
+    WRITE(lunout,*)"CALL sequence information: "//TRIM(sub)
+    CALL NF95_CREATE("climoz_LMDZ.nc", NF90_clobber, fID_ou)
+
+  !--- Dimensions:
+    IF(ndims==4) &
+    CALL NF95_DEF_DIM(fID_ou, "rlonv", nlon_ou, dlonID)
+    CALL NF95_DEF_DIM(fID_ou, "rlatu", nlat_ou, dlatID)
+    CALL NF95_DEF_DIM(fID_ou, "plev",  nlev_in, dlevID)
+    CALL NF95_DEF_DIM(fID_ou, "time",  ntim_ou, dtimID)
+
+    !--- Define coordinate variables:
+    IF(ndims==4) &
+    CALL NF95_DEF_VAR(fID_ou, "rlonv", NF90_FLOAT, dlonID, vlonID)
+    CALL NF95_DEF_VAR(fID_ou, "rlatu", NF90_FLOAT, dlatID, vlatID)
+    CALL NF95_DEF_VAR(fID_ou, "plev",  NF90_FLOAT, dlevID, vlevID)
+    CALL NF95_DEF_VAR(fID_ou, "time",  NF90_FLOAT, dtimID, vtimID)
+    IF(ndims==4) &
+    CALL NF95_PUT_ATT(fID_ou, vlonID, "units", "degrees_east")
+    CALL NF95_PUT_ATT(fID_ou, vlatID, "units", "degrees_north")
+    CALL NF95_PUT_ATT(fID_ou, vlevID, "units", "millibar")
+    CALL NF95_PUT_ATT(fID_ou, vtimID, "units", "days since 2000-1-1")
+    IF(ndims==4) &
+    CALL NF95_PUT_ATT(fID_ou, vlonID, "standard_name", "longitude")
+    CALL NF95_PUT_ATT(fID_ou, vlatID, "standard_name", "latitude")
+    CALL NF95_PUT_ATT(fID_ou, vlevID, "standard_name", "air_pressure")
+    CALL NF95_PUT_ATT(fID_ou, vtimID, "standard_name", "time")
+    CALL NF95_PUT_ATT(fID_ou, vlevID, "long_name",     "air pressure")
+    CALL NF95_PUT_ATT(fID_ou, vtimID, "calendar",      cal_ou)
+
+  !--- Define the main variables:
+    IF(ndims==3) dIDs(1:3) = [ dlatID, dlevID, dtimID]
+    IF(ndims==4) dIDs=[dlonID, dlatID, dlevID, dtimID]
+    CALL NF95_DEF_VAR(fID_ou, vars_in(1), NF90_FLOAT, dIDs(1:ndims), vID_ou(1))
+    CALL NF95_PUT_ATT(fID_ou, vID_ou(1), "long_name", "ozone mole fraction")
+    CALL NF95_PUT_ATT(fID_ou, vID_ou(1), "standard_name", "mole_fraction_of_ozone&
+      &_in_air")
+    IF(SIZE(vID_ou) == 2) THEN
+      CALL NF95_DEF_VAR(fID_ou, vars_in(2), NF90_FLOAT, dIDs(1:ndims), vID_ou(2))
+      CALL NF95_PUT_ATT(fID_ou, vID_ou(2), "long_name","ozone mole fraction in da&
+        &ylight")
+    END IF
+
+  !--- Global attributes:
+  ! The following commands, copying attributes, may fail. That is OK.
+  ! It should just mean that the attribute is not defined in the input file.
+    CALL NF95_COPY_ATT(fID_in,NF90_GLOBAL,"Conventions",fID_ou,NF90_GLOBAL, ncerr)
+    CALL handle_err_copy_att("Conventions")
+    CALL NF95_COPY_ATT(fID_in,NF90_GLOBAL,"title",      fID_ou,NF90_GLOBAL, ncerr)
+    CALL handle_err_copy_att("title")
+    CALL NF95_COPY_ATT(fID_in,NF90_GLOBAL,"institution",fID_ou,NF90_GLOBAL, ncerr)
+    CALL handle_err_copy_att("institution")
+    CALL NF95_COPY_ATT(fID_in,NF90_GLOBAL,"source",     fID_ou,NF90_GLOBAL, ncerr)
+    CALL handle_err_copy_att("source")
+    CALL NF95_PUT_ATT (fID_ou,NF90_GLOBAL,"comment", "Regridded for LMDZ")
+    CALL NF95_ENDDEF(fID_ou)
+
+    IF (grid_type==unstructured) THEN
+      ALLOCATE(latitude_glo_(klon_glo))
+      DO i=1,klon_glo
+        latitude_glo_(ind_cell_glo_glo(i))=latitude_glo(i)
+      ENDDO
+      CALL NF95_PUT_VAR(fID_ou, vlatID, latitude_glo_)
+    ELSE
+      !--- Write one of the coordinate variables:
+      IF(ndims==4) CALL NF95_PUT_VAR(fID_ou, vlonID, lon_reg/deg2rad)
+      CALL NF95_PUT_VAR(fID_ou, vlatID, lat_reg(nlat_ou:1:-1)/deg2rad)
+    !    (convert from rad to degrees and sort in ascending order)
+    ENDIF
+  ENDIF
+  
+CONTAINS
+
+!-------------------------------------------------------------------------------
+!
+SUBROUTINE handle_err_copy_att(att_name)
+!
+!-------------------------------------------------------------------------------
+  USE netcdf, ONLY: NF90_NOERR, NF90_strerror
+!-------------------------------------------------------------------------------
+! Arguments:
+  CHARACTER(LEN=*), INTENT(IN) :: att_name
+!-------------------------------------------------------------------------------
+  IF(ncerr /= NF90_NOERR) &
+    WRITE(lunout,*)TRIM(sub)//" prepare_out NF95_COPY_ATT "//TRIM(att_name)//  &
+                      " -- "//TRIM(NF90_strerror(ncerr))
+
+END SUBROUTINE handle_err_copy_att
+!
+!-------------------------------------------------------------------------------
+
+END SUBROUTINE prepare_out
+!
+!-------------------------------------------------------------------------------
+
+END MODULE regr_horiz_time_climoz_m
+!
+!-------------------------------------------------------------------------------
Index: DZ6/trunk/libf/phylmd/regr_lat_time_coefoz_m.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/regr_lat_time_coefoz_m.F90	(revision 5267)
+++ 	(revision )
@@ -1,346 +1,0 @@
-! $Id$
-module regr_lat_time_coefoz_m
-
-  ! Author: Lionel GUEZ
-
-  implicit none
-
-  private
-  public regr_lat_time_coefoz
-
-contains
-
-  subroutine regr_lat_time_coefoz
-
-    ! "regr_lat_time_coefoz" stands for "regrid latitude time
-    ! coefficients ozone".
-
-    ! This procedure reads from a NetCDF file coefficients for ozone
-    ! chemistry, regrids them in latitude and time, and writes the
-    ! regridded fields to a new NetCDF file.
-
-    ! The input fields depend on time, pressure level and latitude.
-    ! We assume that the input fields are step functions of latitude.
-    ! Regridding in latitude is made by averaging, with a cosine of
-    ! latitude factor.
-    ! The target LMDZ latitude grid is the "scalar" grid: "rlatu".
-    ! The values of "rlatu" are taken to be the centers of intervals.
-    ! Regridding in time is by linear interpolation.
-    ! Monthly values are processed to get daily values, on the basis
-    ! of a 360-day calendar.
-
-    ! We assume that in the input file:
-    ! -- the latitude is in degrees and strictly monotonic (as all
-    ! NetCDF coordinate variables should be);
-    ! -- time increases from January to December (even though we do
-    ! not use values of the input time coordinate);
-    ! -- pressure is in hPa and in strictly ascending order (even
-    ! though we do not use pressure values here, we write the unit of
-    ! pressure in the NetCDF header, and we will use the assumptions later,
-    ! when we regrid in pressure).
-
-    use mod_grid_phy_lmdz, ONLY : nbp_lat
-    use regr_conserv_m, only: regr_conserv
-    use regr_lint_m, only: regr_lint
-    use netcdf95, only: nf95_open, nf95_close, nf95_inq_varid, nf95_get_var, &
-         nf95_put_var, nf95_gw_var
-    use netcdf, only: nf90_nowrite
-    use nrtype, only: pi
-    use regular_lonlat_mod, only: boundslat_reg, south
-
-    ! Variables local to the procedure:
-
-    integer ncid_in, ncid_out ! NetCDF IDs for input and output files
-    integer n_plev ! number of pressure levels in the input data
-    integer n_lat! number of latitudes in the input data
-
-    real, allocatable:: latitude(:)
-    ! (of input data, converted to rad, sorted in strictly ascending order)
-
-    real, allocatable:: lat_in_edg(:)
-    ! (edges of latitude intervals for input data, in rad, in strictly
-    ! ascending order)
-
-    real, allocatable:: plev(:) ! pressure level of input data
-    logical desc_lat ! latitude in descending order in the input file
-
-    real, allocatable:: o3_par_in(:, :, :) ! (n_lat, n_plev, 12)
-    ! (ozone parameter from the input file)
-    ! ("o3_par_in(j, l, month)" is at latitude "latitude(j)" and pressure
-    ! level "plev(l)". "month" is between 1 and 12.)
-
-    real, allocatable:: v_regr_lat(:, :, :) ! (jjm + 1, n_plev, 0:13)
-    ! (mean of a variable "v" over a latitude interval)
-    ! (First dimension is latitude interval.
-    ! The latitude interval for "v_regr_lat(j,:, :)" contains "rlatu(j)".
-    ! If "j" is between 2 and "jjm" then the interval is:
-    ! [rlatv(j), rlatv(j-1)]
-    ! If "j" is 1 or "jjm + 1" then the interval is:
-    ! [rlatv(1), pi / 2]
-    ! or:
-    ! [- pi / 2, rlatv(jjm)]
-    ! respectively.
-    ! "v_regr_lat(:, l, :)" is for pressure level "plev(l)".
-    ! Last dimension is month number.)
-
-    real, allocatable:: o3_par_out(:, :, :) ! (jjm + 1, n_plev, ndays)
-    ! (regridded ozone parameter)
-    ! ("o3_par_out(j, l, day)" is at latitude "rlatu(j)", pressure
-    ! level "plev(l)" and date "January 1st 0h" + "tmidday(day)", in a
-    ! 360-day calendar.)
-
-    integer j
-    integer i_v ! index of ozone parameter
-    integer, parameter:: n_o3_param = 8 ! number of ozone parameters
-
-    character(len=11) name_in(n_o3_param)
-    ! (name of NetCDF primary variable in the input file)
-
-    character(len=9) name_out(n_o3_param)
-    ! (name of NetCDF primary variable in the output file)
-
-    integer varid_in(n_o3_param), varid_out(n_o3_param), varid_plev, varid_time
-    integer ncerr, varid
-    ! (for NetCDF)
-
-    real, parameter:: tmidmonth(0:13) = (/(-15. + 30. * j, j = 0, 13)/)
-    ! (time to middle of month, in days since January 1st 0h, in a
-    ! 360-day calendar)
-    ! (We add values -15 and 375 so that, for example, day 3 of the year is
-    ! interpolated between the December and the January value.)
-
-    real, parameter:: tmidday(360) = (/(j + 0.5, j = 0, 359)/)
-    ! (time to middle of day, in days since January 1st 0h, in a
-    ! 360-day calendar)
-
-    !---------------------------------
-
-    print *, "Call sequence information: regr_lat_time_coefoz"
-
-    ! Names of ozone parameters:
-    i_v = 0
-
-    i_v = i_v + 1
-    name_in(i_v) = "P_net"
-    name_out(i_v) = "P_net_Mob"
-
-    i_v = i_v + 1
-    name_in(i_v) = "a2"
-    name_out(i_v) = "a2"
-
-    i_v = i_v + 1
-    name_in(i_v) = "tro3"
-    name_out(i_v) = "r_Mob"
-
-    i_v = i_v + 1
-    name_in(i_v) = "a4"
-    name_out(i_v) = "a4"
-
-    i_v = i_v + 1
-    name_in(i_v) = "temperature"
-    name_out(i_v) = "temp_Mob"
-
-    i_v = i_v + 1
-    name_in(i_v) = "a6"
-    name_out(i_v) = "a6"
-
-    i_v = i_v + 1
-    name_in(i_v) = "Sigma"
-    name_out(i_v) = "Sigma_Mob"
-
-    i_v = i_v + 1
-    name_in(i_v) = "R_Het"
-    name_out(i_v) = "R_Het"
-
-    call nf95_open("coefoz.nc", nf90_nowrite, ncid_in)
-
-    ! Get coordinates from the input file:
-
-    call nf95_inq_varid(ncid_in, "latitude", varid)
-    call nf95_gw_var(ncid_in, varid, latitude)
-    ! Convert from degrees to rad, because "boundslat_reg" is in rad:
-    latitude = latitude / 180. * pi
-    n_lat = size(latitude)
-    ! We need to supply the latitudes to "regr_conserv" in
-    ! ascending order, so invert order if necessary:
-    desc_lat = latitude(1) > latitude(n_lat)
-    if (desc_lat) latitude = latitude(n_lat:1:-1)
-
-    ! Compute edges of latitude intervals:
-    allocate(lat_in_edg(n_lat + 1))
-    lat_in_edg(1) = - pi / 2
-    forall (j = 2:n_lat) lat_in_edg(j) = (latitude(j - 1) + latitude(j)) / 2
-    lat_in_edg(n_lat + 1) = pi / 2
-    deallocate(latitude)
-
-    call nf95_inq_varid(ncid_in, "plev", varid)
-    call nf95_gw_var(ncid_in, varid, plev)
-    n_plev = size(plev)
-    ! (We only need the pressure coordinate to copy it to the output file.)
-
-    ! Get the IDs of ozone parameters in the input file:
-    do i_v = 1, n_o3_param
-       call nf95_inq_varid(ncid_in, trim(name_in(i_v)), varid_in(i_v))
-    end do
-
-    ! Create the output file and get the variable IDs:
-    call prepare_out(ncid_in, varid_in, n_plev, name_out, ncid_out, &
-         varid_out, varid_plev, varid_time)
-
-    ! Write remaining coordinate variables:
-    call nf95_put_var(ncid_out, varid_time, tmidday)
-    call nf95_put_var(ncid_out, varid_plev, plev)
-
-    deallocate(plev)
-
-    allocate(o3_par_in(n_lat, n_plev, 12))
-    allocate(v_regr_lat(nbp_lat, n_plev, 0:13))
-    allocate(o3_par_out(nbp_lat, n_plev, 360))
-
-    do i_v = 1, n_o3_param
-       ! Process ozone parameter "name_in(i_v)"
-
-       call nf95_get_var(ncid_in, varid_in(i_v), o3_par_in)
-       if (desc_lat) o3_par_in = o3_par_in(n_lat:1:-1, :, :)
-
-       ! Regrid in latitude:
-       ! We average with respect to sine of latitude, which is
-       ! equivalent to weighting by cosine of latitude:
-       call regr_conserv(1, o3_par_in, xs = sin(lat_in_edg), &
-            xt = (/-1., sin((/boundslat_reg(nbp_lat-1:1:-1,south)/)), 1./), &
-            vt = v_regr_lat(nbp_lat:1:-1, :, 1:12))
-       ! (invert order of indices in "v_regr_lat" because "rlatu" is
-       ! in descending order)
-
-       ! Duplicate January and December values, in preparation of time
-       ! interpolation:
-       v_regr_lat(:, :, 0) = v_regr_lat(:, :, 12)
-       v_regr_lat(:, :, 13) = v_regr_lat(:, :, 1)
-
-       ! Regrid in time by linear interpolation:
-       call regr_lint(3, v_regr_lat, tmidmonth, tmidday, o3_par_out)
-
-       ! Write to file:
-       call nf95_put_var(ncid_out, varid_out(i_v), &
-            o3_par_out(nbp_lat:1:-1, :, :))
-       ! (The order of "rlatu" is inverted in the output file)
-    end do
-
-    call nf95_close(ncid_out)
-    call nf95_close(ncid_in)
-
-  end subroutine regr_lat_time_coefoz
-
-  !********************************************
-
-  subroutine prepare_out(ncid_in, varid_in, n_plev, name_out, ncid_out, &
-       varid_out, varid_plev, varid_time)
-
-    ! This subroutine creates the NetCDF output file, defines
-    ! dimensions and variables, and writes one of the coordinate variables.
-
-    use mod_grid_phy_lmdz, ONLY : nbp_lat
-    use assert_eq_m, only: assert_eq
-
-    use netcdf95, only: nf95_create, nf95_def_dim, nf95_def_var, &
-         nf95_put_att, nf95_enddef, nf95_copy_att, nf95_put_var
-    use netcdf, only: nf90_clobber, nf90_float, nf90_copy_att, nf90_global
-    use nrtype, only: pi
-    use regular_lonlat_mod, only : lat_reg
-
-    integer, intent(in):: ncid_in, varid_in(:), n_plev
-    character(len=*), intent(in):: name_out(:) ! of NetCDF variables
-    integer, intent(out):: ncid_out, varid_out(:), varid_plev, varid_time
-
-    ! Variables local to the procedure:
-
-    integer ncerr
-    integer dimid_rlatu, dimid_plev, dimid_time
-    integer varid_rlatu
-    integer i, n_o3_param
-
-    !---------------------------
-
-    print *, "Call sequence information: prepare_out"
-    n_o3_param = assert_eq(size(varid_in), size(varid_out), &
-         size(name_out), "prepare_out") 
-
-    call nf95_create("coefoz_LMDZ.nc", nf90_clobber, ncid_out)
-
-    ! Dimensions:
-    call nf95_def_dim(ncid_out, "time", 360, dimid_time)
-    call nf95_def_dim(ncid_out, "plev", n_plev, dimid_plev)
-    call nf95_def_dim(ncid_out, "rlatu", nbp_lat, dimid_rlatu)
-
-    ! Define coordinate variables:
-
-    call nf95_def_var(ncid_out, "time", nf90_float, dimid_time, varid_time)
-    call nf95_put_att(ncid_out, varid_time, "units", "days since 2000-1-1")
-    call nf95_put_att(ncid_out, varid_time, "calendar", "360_day")
-    call nf95_put_att(ncid_out, varid_time, "standard_name", "time")
-
-    call nf95_def_var(ncid_out, "plev", nf90_float, dimid_plev, varid_plev)
-    call nf95_put_att(ncid_out, varid_plev, "units", "millibar")
-    call nf95_put_att(ncid_out, varid_plev, "standard_name", "air_pressure")
-    call nf95_put_att(ncid_out, varid_plev, "long_name", "air pressure")
-
-    call nf95_def_var(ncid_out, "rlatu", nf90_float, dimid_rlatu, varid_rlatu)
-    call nf95_put_att(ncid_out, varid_rlatu, "units", "degrees_north")
-    call nf95_put_att(ncid_out, varid_rlatu, "standard_name", "latitude")
-
-    ! Define primary variables:
-
-    do i = 1, n_o3_param
-       call nf95_def_var(ncid_out, name_out(i), nf90_float, &
-            (/dimid_rlatu, dimid_plev, dimid_time/), varid_out(i))
-
-       ! The following commands may fail. That is OK. It should just
-       ! mean that the attribute is not defined in the input file.
-
-       ncerr = nf90_copy_att(ncid_in, varid_in(i), "long_name",&
-            & ncid_out, varid_out(i))
-       call handle_err_copy_att("long_name")
-
-       ncerr = nf90_copy_att(ncid_in, varid_in(i), "units", ncid_out,&
-            & varid_out(i))
-       call handle_err_copy_att("units")
-
-       ncerr = nf90_copy_att(ncid_in, varid_in(i), "standard_name", ncid_out,&
-            & varid_out(i))
-       call handle_err_copy_att("standard_name")
-    end do
-
-    ! Global attributes:
-    call nf95_copy_att(ncid_in, nf90_global, "Conventions", ncid_out, &
-         nf90_global)
-    call nf95_copy_att(ncid_in, nf90_global, "title", ncid_out, nf90_global)
-    call nf95_copy_att(ncid_in, nf90_global, "source", ncid_out, nf90_global)
-    call nf95_put_att(ncid_out, nf90_global, "comment", "Regridded for LMDZ")
-
-    call nf95_enddef(ncid_out)
-
-    ! Write one of the coordinate variables:
-    call nf95_put_var(ncid_out, varid_rlatu, lat_reg(nbp_lat:1:-1) / pi * 180.)
-    ! (convert from rad to degrees and sort in ascending order)
-
-  contains
-
-    subroutine handle_err_copy_att(att_name)
-
-      use netcdf, only: nf90_noerr, nf90_strerror
-
-      character(len=*), intent(in):: att_name
-
-      !----------------------------------------
-
-      if (ncerr /= nf90_noerr) then
-         print *, "prepare_out " // trim(name_out(i)) &
-              // " nf90_copy_att " // att_name // " -- " &
-              // trim(nf90_strerror(ncerr))
-      end if
-
-    end subroutine handle_err_copy_att
-
-  end subroutine prepare_out
-
-end module regr_lat_time_coefoz_m
Index: /LMDZ6/trunk/libf/phylmd/regr_lat_time_coefoz_m.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/regr_lat_time_coefoz_m.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/regr_lat_time_coefoz_m.f90	(revision 5268)
@@ -0,0 +1,346 @@
+! $Id$
+module regr_lat_time_coefoz_m
+
+  ! Author: Lionel GUEZ
+
+  implicit none
+
+  private
+  public regr_lat_time_coefoz
+
+contains
+
+  subroutine regr_lat_time_coefoz
+
+    ! "regr_lat_time_coefoz" stands for "regrid latitude time
+    ! coefficients ozone".
+
+    ! This procedure reads from a NetCDF file coefficients for ozone
+    ! chemistry, regrids them in latitude and time, and writes the
+    ! regridded fields to a new NetCDF file.
+
+    ! The input fields depend on time, pressure level and latitude.
+    ! We assume that the input fields are step functions of latitude.
+    ! Regridding in latitude is made by averaging, with a cosine of
+    ! latitude factor.
+    ! The target LMDZ latitude grid is the "scalar" grid: "rlatu".
+    ! The values of "rlatu" are taken to be the centers of intervals.
+    ! Regridding in time is by linear interpolation.
+    ! Monthly values are processed to get daily values, on the basis
+    ! of a 360-day calendar.
+
+    ! We assume that in the input file:
+    ! -- the latitude is in degrees and strictly monotonic (as all
+    ! NetCDF coordinate variables should be);
+    ! -- time increases from January to December (even though we do
+    ! not use values of the input time coordinate);
+    ! -- pressure is in hPa and in strictly ascending order (even
+    ! though we do not use pressure values here, we write the unit of
+    ! pressure in the NetCDF header, and we will use the assumptions later,
+    ! when we regrid in pressure).
+
+    use mod_grid_phy_lmdz, ONLY : nbp_lat
+    use regr_conserv_m, only: regr_conserv
+    use regr_lint_m, only: regr_lint
+    use netcdf95, only: nf95_open, nf95_close, nf95_inq_varid, nf95_get_var, &
+         nf95_put_var, nf95_gw_var
+    use netcdf, only: nf90_nowrite
+    use nrtype, only: pi
+    use regular_lonlat_mod, only: boundslat_reg, south
+
+    ! Variables local to the procedure:
+
+    integer ncid_in, ncid_out ! NetCDF IDs for input and output files
+    integer n_plev ! number of pressure levels in the input data
+    integer n_lat! number of latitudes in the input data
+
+    real, allocatable:: latitude(:)
+    ! (of input data, converted to rad, sorted in strictly ascending order)
+
+    real, allocatable:: lat_in_edg(:)
+    ! (edges of latitude intervals for input data, in rad, in strictly
+    ! ascending order)
+
+    real, allocatable:: plev(:) ! pressure level of input data
+    logical desc_lat ! latitude in descending order in the input file
+
+    real, allocatable:: o3_par_in(:, :, :) ! (n_lat, n_plev, 12)
+    ! (ozone parameter from the input file)
+    ! ("o3_par_in(j, l, month)" is at latitude "latitude(j)" and pressure
+    ! level "plev(l)". "month" is between 1 and 12.)
+
+    real, allocatable:: v_regr_lat(:, :, :) ! (jjm + 1, n_plev, 0:13)
+    ! (mean of a variable "v" over a latitude interval)
+    ! (First dimension is latitude interval.
+    ! The latitude interval for "v_regr_lat(j,:, :)" contains "rlatu(j)".
+    ! If "j" is between 2 and "jjm" then the interval is:
+    ! [rlatv(j), rlatv(j-1)]
+    ! If "j" is 1 or "jjm + 1" then the interval is:
+    ! [rlatv(1), pi / 2]
+    ! or:
+    ! [- pi / 2, rlatv(jjm)]
+    ! respectively.
+    ! "v_regr_lat(:, l, :)" is for pressure level "plev(l)".
+    ! Last dimension is month number.)
+
+    real, allocatable:: o3_par_out(:, :, :) ! (jjm + 1, n_plev, ndays)
+    ! (regridded ozone parameter)
+    ! ("o3_par_out(j, l, day)" is at latitude "rlatu(j)", pressure
+    ! level "plev(l)" and date "January 1st 0h" + "tmidday(day)", in a
+    ! 360-day calendar.)
+
+    integer j
+    integer i_v ! index of ozone parameter
+    integer, parameter:: n_o3_param = 8 ! number of ozone parameters
+
+    character(len=11) name_in(n_o3_param)
+    ! (name of NetCDF primary variable in the input file)
+
+    character(len=9) name_out(n_o3_param)
+    ! (name of NetCDF primary variable in the output file)
+
+    integer varid_in(n_o3_param), varid_out(n_o3_param), varid_plev, varid_time
+    integer ncerr, varid
+    ! (for NetCDF)
+
+    real, parameter:: tmidmonth(0:13) = (/(-15. + 30. * j, j = 0, 13)/)
+    ! (time to middle of month, in days since January 1st 0h, in a
+    ! 360-day calendar)
+    ! (We add values -15 and 375 so that, for example, day 3 of the year is
+    ! interpolated between the December and the January value.)
+
+    real, parameter:: tmidday(360) = (/(j + 0.5, j = 0, 359)/)
+    ! (time to middle of day, in days since January 1st 0h, in a
+    ! 360-day calendar)
+
+    !---------------------------------
+
+    print *, "Call sequence information: regr_lat_time_coefoz"
+
+    ! Names of ozone parameters:
+    i_v = 0
+
+    i_v = i_v + 1
+    name_in(i_v) = "P_net"
+    name_out(i_v) = "P_net_Mob"
+
+    i_v = i_v + 1
+    name_in(i_v) = "a2"
+    name_out(i_v) = "a2"
+
+    i_v = i_v + 1
+    name_in(i_v) = "tro3"
+    name_out(i_v) = "r_Mob"
+
+    i_v = i_v + 1
+    name_in(i_v) = "a4"
+    name_out(i_v) = "a4"
+
+    i_v = i_v + 1
+    name_in(i_v) = "temperature"
+    name_out(i_v) = "temp_Mob"
+
+    i_v = i_v + 1
+    name_in(i_v) = "a6"
+    name_out(i_v) = "a6"
+
+    i_v = i_v + 1
+    name_in(i_v) = "Sigma"
+    name_out(i_v) = "Sigma_Mob"
+
+    i_v = i_v + 1
+    name_in(i_v) = "R_Het"
+    name_out(i_v) = "R_Het"
+
+    call nf95_open("coefoz.nc", nf90_nowrite, ncid_in)
+
+    ! Get coordinates from the input file:
+
+    call nf95_inq_varid(ncid_in, "latitude", varid)
+    call nf95_gw_var(ncid_in, varid, latitude)
+    ! Convert from degrees to rad, because "boundslat_reg" is in rad:
+    latitude = latitude / 180. * pi
+    n_lat = size(latitude)
+    ! We need to supply the latitudes to "regr_conserv" in
+    ! ascending order, so invert order if necessary:
+    desc_lat = latitude(1) > latitude(n_lat)
+    if (desc_lat) latitude = latitude(n_lat:1:-1)
+
+    ! Compute edges of latitude intervals:
+    allocate(lat_in_edg(n_lat + 1))
+    lat_in_edg(1) = - pi / 2
+    forall (j = 2:n_lat) lat_in_edg(j) = (latitude(j - 1) + latitude(j)) / 2
+    lat_in_edg(n_lat + 1) = pi / 2
+    deallocate(latitude)
+
+    call nf95_inq_varid(ncid_in, "plev", varid)
+    call nf95_gw_var(ncid_in, varid, plev)
+    n_plev = size(plev)
+    ! (We only need the pressure coordinate to copy it to the output file.)
+
+    ! Get the IDs of ozone parameters in the input file:
+    do i_v = 1, n_o3_param
+       call nf95_inq_varid(ncid_in, trim(name_in(i_v)), varid_in(i_v))
+    end do
+
+    ! Create the output file and get the variable IDs:
+    call prepare_out(ncid_in, varid_in, n_plev, name_out, ncid_out, &
+         varid_out, varid_plev, varid_time)
+
+    ! Write remaining coordinate variables:
+    call nf95_put_var(ncid_out, varid_time, tmidday)
+    call nf95_put_var(ncid_out, varid_plev, plev)
+
+    deallocate(plev)
+
+    allocate(o3_par_in(n_lat, n_plev, 12))
+    allocate(v_regr_lat(nbp_lat, n_plev, 0:13))
+    allocate(o3_par_out(nbp_lat, n_plev, 360))
+
+    do i_v = 1, n_o3_param
+       ! Process ozone parameter "name_in(i_v)"
+
+       call nf95_get_var(ncid_in, varid_in(i_v), o3_par_in)
+       if (desc_lat) o3_par_in = o3_par_in(n_lat:1:-1, :, :)
+
+       ! Regrid in latitude:
+       ! We average with respect to sine of latitude, which is
+       ! equivalent to weighting by cosine of latitude:
+       call regr_conserv(1, o3_par_in, xs = sin(lat_in_edg), &
+            xt = (/-1., sin((/boundslat_reg(nbp_lat-1:1:-1,south)/)), 1./), &
+            vt = v_regr_lat(nbp_lat:1:-1, :, 1:12))
+       ! (invert order of indices in "v_regr_lat" because "rlatu" is
+       ! in descending order)
+
+       ! Duplicate January and December values, in preparation of time
+       ! interpolation:
+       v_regr_lat(:, :, 0) = v_regr_lat(:, :, 12)
+       v_regr_lat(:, :, 13) = v_regr_lat(:, :, 1)
+
+       ! Regrid in time by linear interpolation:
+       call regr_lint(3, v_regr_lat, tmidmonth, tmidday, o3_par_out)
+
+       ! Write to file:
+       call nf95_put_var(ncid_out, varid_out(i_v), &
+            o3_par_out(nbp_lat:1:-1, :, :))
+       ! (The order of "rlatu" is inverted in the output file)
+    end do
+
+    call nf95_close(ncid_out)
+    call nf95_close(ncid_in)
+
+  end subroutine regr_lat_time_coefoz
+
+  !********************************************
+
+  subroutine prepare_out(ncid_in, varid_in, n_plev, name_out, ncid_out, &
+       varid_out, varid_plev, varid_time)
+
+    ! This subroutine creates the NetCDF output file, defines
+    ! dimensions and variables, and writes one of the coordinate variables.
+
+    use mod_grid_phy_lmdz, ONLY : nbp_lat
+    use assert_eq_m, only: assert_eq
+
+    use netcdf95, only: nf95_create, nf95_def_dim, nf95_def_var, &
+         nf95_put_att, nf95_enddef, nf95_copy_att, nf95_put_var
+    use netcdf, only: nf90_clobber, nf90_float, nf90_copy_att, nf90_global
+    use nrtype, only: pi
+    use regular_lonlat_mod, only : lat_reg
+
+    integer, intent(in):: ncid_in, varid_in(:), n_plev
+    character(len=*), intent(in):: name_out(:) ! of NetCDF variables
+    integer, intent(out):: ncid_out, varid_out(:), varid_plev, varid_time
+
+    ! Variables local to the procedure:
+
+    integer ncerr
+    integer dimid_rlatu, dimid_plev, dimid_time
+    integer varid_rlatu
+    integer i, n_o3_param
+
+    !---------------------------
+
+    print *, "Call sequence information: prepare_out"
+    n_o3_param = assert_eq(size(varid_in), size(varid_out), &
+         size(name_out), "prepare_out") 
+
+    call nf95_create("coefoz_LMDZ.nc", nf90_clobber, ncid_out)
+
+    ! Dimensions:
+    call nf95_def_dim(ncid_out, "time", 360, dimid_time)
+    call nf95_def_dim(ncid_out, "plev", n_plev, dimid_plev)
+    call nf95_def_dim(ncid_out, "rlatu", nbp_lat, dimid_rlatu)
+
+    ! Define coordinate variables:
+
+    call nf95_def_var(ncid_out, "time", nf90_float, dimid_time, varid_time)
+    call nf95_put_att(ncid_out, varid_time, "units", "days since 2000-1-1")
+    call nf95_put_att(ncid_out, varid_time, "calendar", "360_day")
+    call nf95_put_att(ncid_out, varid_time, "standard_name", "time")
+
+    call nf95_def_var(ncid_out, "plev", nf90_float, dimid_plev, varid_plev)
+    call nf95_put_att(ncid_out, varid_plev, "units", "millibar")
+    call nf95_put_att(ncid_out, varid_plev, "standard_name", "air_pressure")
+    call nf95_put_att(ncid_out, varid_plev, "long_name", "air pressure")
+
+    call nf95_def_var(ncid_out, "rlatu", nf90_float, dimid_rlatu, varid_rlatu)
+    call nf95_put_att(ncid_out, varid_rlatu, "units", "degrees_north")
+    call nf95_put_att(ncid_out, varid_rlatu, "standard_name", "latitude")
+
+    ! Define primary variables:
+
+    do i = 1, n_o3_param
+       call nf95_def_var(ncid_out, name_out(i), nf90_float, &
+            (/dimid_rlatu, dimid_plev, dimid_time/), varid_out(i))
+
+       ! The following commands may fail. That is OK. It should just
+       ! mean that the attribute is not defined in the input file.
+
+       ncerr = nf90_copy_att(ncid_in, varid_in(i), "long_name",&
+            & ncid_out, varid_out(i))
+       call handle_err_copy_att("long_name")
+
+       ncerr = nf90_copy_att(ncid_in, varid_in(i), "units", ncid_out,&
+            & varid_out(i))
+       call handle_err_copy_att("units")
+
+       ncerr = nf90_copy_att(ncid_in, varid_in(i), "standard_name", ncid_out,&
+            & varid_out(i))
+       call handle_err_copy_att("standard_name")
+    end do
+
+    ! Global attributes:
+    call nf95_copy_att(ncid_in, nf90_global, "Conventions", ncid_out, &
+         nf90_global)
+    call nf95_copy_att(ncid_in, nf90_global, "title", ncid_out, nf90_global)
+    call nf95_copy_att(ncid_in, nf90_global, "source", ncid_out, nf90_global)
+    call nf95_put_att(ncid_out, nf90_global, "comment", "Regridded for LMDZ")
+
+    call nf95_enddef(ncid_out)
+
+    ! Write one of the coordinate variables:
+    call nf95_put_var(ncid_out, varid_rlatu, lat_reg(nbp_lat:1:-1) / pi * 180.)
+    ! (convert from rad to degrees and sort in ascending order)
+
+  contains
+
+    subroutine handle_err_copy_att(att_name)
+
+      use netcdf, only: nf90_noerr, nf90_strerror
+
+      character(len=*), intent(in):: att_name
+
+      !----------------------------------------
+
+      if (ncerr /= nf90_noerr) then
+         print *, "prepare_out " // trim(name_out(i)) &
+              // " nf90_copy_att " // att_name // " -- " &
+              // trim(nf90_strerror(ncerr))
+      end if
+
+    end subroutine handle_err_copy_att
+
+  end subroutine prepare_out
+
+end module regr_lat_time_coefoz_m
Index: DZ6/trunk/libf/phylmd/regr_pr_comb_coefoz_m.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/regr_pr_comb_coefoz_m.F90	(revision 5267)
+++ 	(revision )
@@ -1,163 +1,0 @@
-! $Id$
-module regr_pr_comb_coefoz_m
-
-  implicit none
-
-  ! The five module variables declared here are on the partial
-  ! "physics" grid.
-  ! The value of each variable for index "(i, k)" is at longitude
-  ! "rlon(i)", latitude "rlat(i)" and middle of layer "k".
-
-  real, allocatable, save:: c_Mob(:, :)
-  ! (sum of Mobidic terms in the net mass production rate of ozone
-  ! by chemistry, per unit mass of air, in s-1)
-
-  real, allocatable, save:: a2(:, :)
-  ! (derivative of mass production rate of ozone per unit mass of
-  ! air with respect to ozone mass fraction, in s-1)
-
-  real, allocatable, save:: a4_mass(:, :)
-  ! (derivative of mass production rate of ozone per unit mass of
-  ! air with respect to temperature, in s-1 K-1)
-
-  real, allocatable, save:: a6_mass(:, :)
-  ! (derivative of mass production rate of ozone per unit mass of
-  ! air with respect to mass column-density of ozone above, in m2 s-1 kg-1)
-
-  real, allocatable, save:: r_het_interm(:, :)
-  ! (net mass production rate by heterogeneous chemistry, per unit
-  ! mass of ozone, corrected for chlorine content and latitude, but
-  ! not for temperature and sun direction, in s-1)
-
-  !$omp threadprivate(c_Mob, a2, a4_mass, a6_mass, r_het_interm)
-
-contains
-
-  subroutine alloc_coefoz
-
-    ! This procedure is called once per run.
-    ! It allocates module variables.
-
-    use dimphy, only: klon
-    use mod_grid_phy_lmdz, only: nbp_lev
-
-    ! Variables local to the procedure:
-
-    !---------------------------------------
-
-    !$omp master
-    print *, "Call sequence information: alloc_coefoz"
-    !$omp end master
-    allocate(c_Mob(klon, nbp_lev), a2(klon, nbp_lev), a4_mass(klon, nbp_lev))
-    allocate(a6_mass(klon, nbp_lev), r_het_interm(klon, nbp_lev))
-
-  end subroutine alloc_coefoz
-
-  !*******************************************************
-
-  subroutine regr_pr_comb_coefoz(julien, rlat, paprs, pplay)
-
-    ! "regr_pr_comb_coefoz" stands for "regrid pressure combine
-    ! coefficients ozone".
-
-    ! In this subroutine:
-    ! -- the master thread of the root process reads from a file all
-    !    eight coefficients for ozone chemistry, at the current day;
-    ! -- the coefficients are packed to the "physics" horizontal grid
-    !    and scattered to all threads of all processes;
-    ! -- in all the threads of all the processes, the coefficients are
-    !    regridded in pressure to the LMDZ vertical grid;
-    ! -- in all the threads of all the processes, the eight
-    !    coefficients are combined to define the five module variables.
-
-    use netcdf95, only: nf95_open, nf95_close
-    use netcdf, only: nf90_nowrite
-    use assert_m, only: assert
-    use dimphy, only: klon
-    use mod_phys_lmdz_mpi_data, only: is_mpi_root
-    use regr_pr_time_av_m, only: regr_pr_time_av
-    use regr_pr_int_m, only: regr_pr_int
-    use press_coefoz_m, only: press_in_edg, plev
-    use mod_grid_phy_lmdz, only: nbp_lev
-
-    integer, intent(in):: julien ! jour julien, 1 <= julien <= 360
-
-    REAL, intent(in):: rlat(:)
-    ! (latitude on the partial "physics" grid, in degrees)
-
-    real, intent(in):: paprs(:, :) ! (klon, nbp_lev + 1)
-    ! (pression pour chaque inter-couche, en Pa)
-
-    real, intent(in):: pplay(:, :) ! (klon, nbp_lev)
-    ! (pression pour le mileu de chaque couche, en Pa)
-
-    ! Variables local to the procedure:
-
-    integer ncid ! for NetCDF
-
-    real coefoz(klon, nbp_lev, 7)
-    ! (temporary storage for 7 ozone coefficients)
-    ! (On the partial "physics" grid.
-    ! "coefoz(i, k, :)" is at longitude "rlon(i)", latitude "rlat(i)",
-    ! middle of layer "k".)
-
-    real a6(klon, nbp_lev)
-    ! (derivative of "P_net_Mob" with respect to column-density of ozone
-    ! above, in cm2 s-1)
-    ! (On the partial "physics" grid.
-    ! "a6(i, k)" is at longitude "rlon(i)", latitude "rlat(i)",
-    ! middle of layer "k".)
-
-    real, parameter:: amu = 1.6605402e-27 ! atomic mass unit, in kg
-
-    real, parameter:: Clx = 3.8e-9
-    ! (total chlorine content in the upper stratosphere)
-
-    integer k
-
-    !------------------------------------
-
-    !!print *, "Call sequence information: regr_pr_comb_coefoz"
-    call assert((/size(rlat), size(paprs, 1), size(pplay, 1)/) == klon, &
-         "regr_pr_comb_coefoz klon")
-    call assert((/size(paprs, 2) - 1, size(pplay, 2)/) == nbp_lev, &
-         "regr_pr_comb_coefoz nbp_lev")
-
-    !$omp master
-    if (is_mpi_root) call nf95_open("coefoz_LMDZ.nc", nf90_nowrite, ncid)
-    !$omp end master
-
-    call regr_pr_time_av(ncid, (/"a2           ", "a4           ", "a6           ", &
-         "P_net_Mob    ", "r_Mob        ", "temp_Mob     ", "R_Het        "/),      &
-         REAL(julien-1), 'I', press_in_edg, paprs, coefoz)
-    a2 = coefoz(:, :, 1)
-    a4_mass = coefoz(:, :, 2) * 48. / 29.
-
-    ! Compute "a6_mass" avoiding underflow, do not divide by 1e4
-    ! before dividing by molecular mass:
-    a6_mass = coefoz(:, :, 3) / (1e4 * 29. * amu)
-    ! (factor 1e4: conversion from cm2 to m2)
-
-    ! We can overwrite "coefoz(:, :, 1)", which was saved to "a2":
-    call regr_pr_int(ncid, "Sigma_Mob", julien, plev, pplay, top_value=0., &
-         v3=coefoz(:, :, 1))
-
-    ! Combine coefficients to get "c_Mob":
-    c_mob = (coefoz(:, :, 4) - a2 * coefoz(:, :, 5) &
-         - coefoz(:, :, 3) * coefoz(:, :, 1)) * 48. / 29. &
-         - a4_mass * coefoz(:, :, 6)
-
-    r_het_interm = coefoz(:, :, 7)
-    ! Heterogeneous chemistry is only at high latitudes:
-    forall (k = 1: nbp_lev)
-       where (abs(rlat) <= 45.) r_het_interm(:, k) = 0.
-    end forall
-    r_het_interm = r_het_interm * (Clx / 3.8e-9)**2
-
-    !$omp master
-    if (is_mpi_root) call nf95_close(ncid)
-    !$omp end master
-
-  end subroutine regr_pr_comb_coefoz
-
-end module regr_pr_comb_coefoz_m
Index: /LMDZ6/trunk/libf/phylmd/regr_pr_comb_coefoz_m.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/regr_pr_comb_coefoz_m.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/regr_pr_comb_coefoz_m.f90	(revision 5268)
@@ -0,0 +1,163 @@
+! $Id$
+module regr_pr_comb_coefoz_m
+
+  implicit none
+
+  ! The five module variables declared here are on the partial
+  ! "physics" grid.
+  ! The value of each variable for index "(i, k)" is at longitude
+  ! "rlon(i)", latitude "rlat(i)" and middle of layer "k".
+
+  real, allocatable, save:: c_Mob(:, :)
+  ! (sum of Mobidic terms in the net mass production rate of ozone
+  ! by chemistry, per unit mass of air, in s-1)
+
+  real, allocatable, save:: a2(:, :)
+  ! (derivative of mass production rate of ozone per unit mass of
+  ! air with respect to ozone mass fraction, in s-1)
+
+  real, allocatable, save:: a4_mass(:, :)
+  ! (derivative of mass production rate of ozone per unit mass of
+  ! air with respect to temperature, in s-1 K-1)
+
+  real, allocatable, save:: a6_mass(:, :)
+  ! (derivative of mass production rate of ozone per unit mass of
+  ! air with respect to mass column-density of ozone above, in m2 s-1 kg-1)
+
+  real, allocatable, save:: r_het_interm(:, :)
+  ! (net mass production rate by heterogeneous chemistry, per unit
+  ! mass of ozone, corrected for chlorine content and latitude, but
+  ! not for temperature and sun direction, in s-1)
+
+  !$omp threadprivate(c_Mob, a2, a4_mass, a6_mass, r_het_interm)
+
+contains
+
+  subroutine alloc_coefoz
+
+    ! This procedure is called once per run.
+    ! It allocates module variables.
+
+    use dimphy, only: klon
+    use mod_grid_phy_lmdz, only: nbp_lev
+
+    ! Variables local to the procedure:
+
+    !---------------------------------------
+
+    !$omp master
+    print *, "Call sequence information: alloc_coefoz"
+    !$omp end master
+    allocate(c_Mob(klon, nbp_lev), a2(klon, nbp_lev), a4_mass(klon, nbp_lev))
+    allocate(a6_mass(klon, nbp_lev), r_het_interm(klon, nbp_lev))
+
+  end subroutine alloc_coefoz
+
+  !*******************************************************
+
+  subroutine regr_pr_comb_coefoz(julien, rlat, paprs, pplay)
+
+    ! "regr_pr_comb_coefoz" stands for "regrid pressure combine
+    ! coefficients ozone".
+
+    ! In this subroutine:
+    ! -- the master thread of the root process reads from a file all
+    !    eight coefficients for ozone chemistry, at the current day;
+    ! -- the coefficients are packed to the "physics" horizontal grid
+    !    and scattered to all threads of all processes;
+    ! -- in all the threads of all the processes, the coefficients are
+    !    regridded in pressure to the LMDZ vertical grid;
+    ! -- in all the threads of all the processes, the eight
+    !    coefficients are combined to define the five module variables.
+
+    use netcdf95, only: nf95_open, nf95_close
+    use netcdf, only: nf90_nowrite
+    use assert_m, only: assert
+    use dimphy, only: klon
+    use mod_phys_lmdz_mpi_data, only: is_mpi_root
+    use regr_pr_time_av_m, only: regr_pr_time_av
+    use regr_pr_int_m, only: regr_pr_int
+    use press_coefoz_m, only: press_in_edg, plev
+    use mod_grid_phy_lmdz, only: nbp_lev
+
+    integer, intent(in):: julien ! jour julien, 1 <= julien <= 360
+
+    REAL, intent(in):: rlat(:)
+    ! (latitude on the partial "physics" grid, in degrees)
+
+    real, intent(in):: paprs(:, :) ! (klon, nbp_lev + 1)
+    ! (pression pour chaque inter-couche, en Pa)
+
+    real, intent(in):: pplay(:, :) ! (klon, nbp_lev)
+    ! (pression pour le mileu de chaque couche, en Pa)
+
+    ! Variables local to the procedure:
+
+    integer ncid ! for NetCDF
+
+    real coefoz(klon, nbp_lev, 7)
+    ! (temporary storage for 7 ozone coefficients)
+    ! (On the partial "physics" grid.
+    ! "coefoz(i, k, :)" is at longitude "rlon(i)", latitude "rlat(i)",
+    ! middle of layer "k".)
+
+    real a6(klon, nbp_lev)
+    ! (derivative of "P_net_Mob" with respect to column-density of ozone
+    ! above, in cm2 s-1)
+    ! (On the partial "physics" grid.
+    ! "a6(i, k)" is at longitude "rlon(i)", latitude "rlat(i)",
+    ! middle of layer "k".)
+
+    real, parameter:: amu = 1.6605402e-27 ! atomic mass unit, in kg
+
+    real, parameter:: Clx = 3.8e-9
+    ! (total chlorine content in the upper stratosphere)
+
+    integer k
+
+    !------------------------------------
+
+    !!print *, "Call sequence information: regr_pr_comb_coefoz"
+    call assert((/size(rlat), size(paprs, 1), size(pplay, 1)/) == klon, &
+         "regr_pr_comb_coefoz klon")
+    call assert((/size(paprs, 2) - 1, size(pplay, 2)/) == nbp_lev, &
+         "regr_pr_comb_coefoz nbp_lev")
+
+    !$omp master
+    if (is_mpi_root) call nf95_open("coefoz_LMDZ.nc", nf90_nowrite, ncid)
+    !$omp end master
+
+    call regr_pr_time_av(ncid, (/"a2           ", "a4           ", "a6           ", &
+         "P_net_Mob    ", "r_Mob        ", "temp_Mob     ", "R_Het        "/),      &
+         REAL(julien-1), 'I', press_in_edg, paprs, coefoz)
+    a2 = coefoz(:, :, 1)
+    a4_mass = coefoz(:, :, 2) * 48. / 29.
+
+    ! Compute "a6_mass" avoiding underflow, do not divide by 1e4
+    ! before dividing by molecular mass:
+    a6_mass = coefoz(:, :, 3) / (1e4 * 29. * amu)
+    ! (factor 1e4: conversion from cm2 to m2)
+
+    ! We can overwrite "coefoz(:, :, 1)", which was saved to "a2":
+    call regr_pr_int(ncid, "Sigma_Mob", julien, plev, pplay, top_value=0., &
+         v3=coefoz(:, :, 1))
+
+    ! Combine coefficients to get "c_Mob":
+    c_mob = (coefoz(:, :, 4) - a2 * coefoz(:, :, 5) &
+         - coefoz(:, :, 3) * coefoz(:, :, 1)) * 48. / 29. &
+         - a4_mass * coefoz(:, :, 6)
+
+    r_het_interm = coefoz(:, :, 7)
+    ! Heterogeneous chemistry is only at high latitudes:
+    forall (k = 1: nbp_lev)
+       where (abs(rlat) <= 45.) r_het_interm(:, k) = 0.
+    end forall
+    r_het_interm = r_het_interm * (Clx / 3.8e-9)**2
+
+    !$omp master
+    if (is_mpi_root) call nf95_close(ncid)
+    !$omp end master
+
+  end subroutine regr_pr_comb_coefoz
+
+end module regr_pr_comb_coefoz_m
Index: DZ6/trunk/libf/phylmd/regr_pr_int_m.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/regr_pr_int_m.F90	(revision 5267)
+++ 	(revision )
@@ -1,104 +1,0 @@
-! $Id$
-module regr_pr_int_m
-
-  ! Author: Lionel GUEZ
-
-  implicit none
-
-contains
-
-  subroutine regr_pr_int(ncid, name, julien, plev, pplay, top_value, v3)
-
-    ! "regr_pr_int" stands for "regrid pressure interpolation".
-    ! In this procedure:
-    ! -- the root process reads a 2D latitude-pressure field from a
-    !    NetCDF file, at a given day.
-    ! -- the field is packed to the LMDZ horizontal "physics"
-    !    grid and scattered to all threads of all processes;
-    ! -- in all the threads of all the processes, the field is regridded in
-    !    pressure to the LMDZ vertical grid.
-    ! We assume that, in the input file, the field has 3 dimensions:
-    ! latitude, pressure, julian day.
-    ! We assume that latitudes are in ascending order in the input file.
-    ! The target vertical LMDZ grid is the grid of mid-layers.
-    ! Regridding is by linear interpolation.
-
-    use dimphy, only: klon
-    use netcdf95, only: nf95_inq_varid, nf95_get_var
-    use assert_m, only: assert
-    use regr_lint_m, only: regr_lint
-    use mod_phys_lmdz_mpi_data, only: is_mpi_root
-    use mod_grid_phy_lmdz, only: nbp_lon, nbp_lat, nbp_lev
-    use mod_phys_lmdz_transfert_para, only: scatter2d
-    ! (pack to the LMDZ horizontal "physics" grid and scatter)
-
-    integer, intent(in):: ncid ! NetCDF ID of the file
-    character(len=*), intent(in):: name ! of the NetCDF variable
-    integer, intent(in):: julien ! jour julien, 1 <= julien <= 360
-
-    real, intent(in):: plev(:)
-    ! (pressure level of input data, in Pa, in strictly ascending order)
-
-    real, intent(in):: pplay(:, :) ! (klon, nbp_lev)
-    ! (pression pour le mileu de chaque couche, en Pa)
-
-    real, intent(in):: top_value
-    ! (extra value of field at 0 pressure)
-
-    real, intent(out):: v3(:, :) ! (klon, nbp_lev)
-    ! (regridded field on the partial "physics" grid)
-    ! ("v3(i, k)" is at longitude "xlon(i)", latitude
-    ! "xlat(i)", middle of layer "k".)
-
-    ! Variables local to the procedure:
-
-    integer varid, ncerr ! for NetCDF
-
-    real  v1(nbp_lon, nbp_lat, 0:size(plev))
-    ! (input field at day "julien", on the global "dynamics" horizontal grid)
-    ! (First dimension is for longitude.
-    ! The value is the same for all longitudes.
-    ! "v1(:, j, k >=1)" is at latitude "rlatu(j)" and pressure "plev(k)".)
-
-    real v2(klon, 0:size(plev))
-    ! (field scattered to the partial "physics" horizontal grid)
-    ! "v2(i, k >= 1)" is at longitude "xlon(i)", latitude "xlat(i)"
-    ! and pressure "plev(k)".)
-
-    integer i
-
-    !--------------------------------------------
-
-    call assert(shape(v3) == (/klon, nbp_lev/), "regr_pr_int v3")
-    call assert(shape(pplay) == (/klon, nbp_lev/), "regr_pr_int pplay")
-
-    !$omp master
-    if (is_mpi_root) then
-       call nf95_inq_varid(ncid, name, varid)
-
-       ! Get data at the right day from the input file:
-       call nf95_get_var(ncid, varid, v1(1, :, 1:), start=(/1, 1, julien/))
-       ! Latitudes are in ascending order in the input file while
-       ! "rlatu" is in descending order so we need to invert order:
-       v1(1, :, 1:) = v1(1, nbp_lat:1:-1, 1:)
-
-       ! Complete "v1" with the value at 0 pressure:
-       v1(1, :, 0) = top_value
-
-       ! Duplicate on all longitudes:
-       v1(2:, :, :) = spread(v1(1, :, :), dim=1, ncopies=nbp_lon-1)
-    end if
-    !$omp end master
-
-    call scatter2d(v1, v2)
-
-    ! Regrid in pressure at each horizontal position:
-    do i = 1, klon
-       call regr_lint(1, v2(i, :), (/0., plev/), pplay(i, nbp_lev:1:-1), &
-                         v3(i, nbp_lev:1:-1))
-       ! (invert order of indices because "pplay" is in descending order)
-    end do
-
-  end subroutine regr_pr_int
-
-end module regr_pr_int_m
Index: /LMDZ6/trunk/libf/phylmd/regr_pr_int_m.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/regr_pr_int_m.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/regr_pr_int_m.f90	(revision 5268)
@@ -0,0 +1,104 @@
+! $Id$
+module regr_pr_int_m
+
+  ! Author: Lionel GUEZ
+
+  implicit none
+
+contains
+
+  subroutine regr_pr_int(ncid, name, julien, plev, pplay, top_value, v3)
+
+    ! "regr_pr_int" stands for "regrid pressure interpolation".
+    ! In this procedure:
+    ! -- the root process reads a 2D latitude-pressure field from a
+    !    NetCDF file, at a given day.
+    ! -- the field is packed to the LMDZ horizontal "physics"
+    !    grid and scattered to all threads of all processes;
+    ! -- in all the threads of all the processes, the field is regridded in
+    !    pressure to the LMDZ vertical grid.
+    ! We assume that, in the input file, the field has 3 dimensions:
+    ! latitude, pressure, julian day.
+    ! We assume that latitudes are in ascending order in the input file.
+    ! The target vertical LMDZ grid is the grid of mid-layers.
+    ! Regridding is by linear interpolation.
+
+    use dimphy, only: klon
+    use netcdf95, only: nf95_inq_varid, nf95_get_var
+    use assert_m, only: assert
+    use regr_lint_m, only: regr_lint
+    use mod_phys_lmdz_mpi_data, only: is_mpi_root
+    use mod_grid_phy_lmdz, only: nbp_lon, nbp_lat, nbp_lev
+    use mod_phys_lmdz_transfert_para, only: scatter2d
+    ! (pack to the LMDZ horizontal "physics" grid and scatter)
+
+    integer, intent(in):: ncid ! NetCDF ID of the file
+    character(len=*), intent(in):: name ! of the NetCDF variable
+    integer, intent(in):: julien ! jour julien, 1 <= julien <= 360
+
+    real, intent(in):: plev(:)
+    ! (pressure level of input data, in Pa, in strictly ascending order)
+
+    real, intent(in):: pplay(:, :) ! (klon, nbp_lev)
+    ! (pression pour le mileu de chaque couche, en Pa)
+
+    real, intent(in):: top_value
+    ! (extra value of field at 0 pressure)
+
+    real, intent(out):: v3(:, :) ! (klon, nbp_lev)
+    ! (regridded field on the partial "physics" grid)
+    ! ("v3(i, k)" is at longitude "xlon(i)", latitude
+    ! "xlat(i)", middle of layer "k".)
+
+    ! Variables local to the procedure:
+
+    integer varid, ncerr ! for NetCDF
+
+    real  v1(nbp_lon, nbp_lat, 0:size(plev))
+    ! (input field at day "julien", on the global "dynamics" horizontal grid)
+    ! (First dimension is for longitude.
+    ! The value is the same for all longitudes.
+    ! "v1(:, j, k >=1)" is at latitude "rlatu(j)" and pressure "plev(k)".)
+
+    real v2(klon, 0:size(plev))
+    ! (field scattered to the partial "physics" horizontal grid)
+    ! "v2(i, k >= 1)" is at longitude "xlon(i)", latitude "xlat(i)"
+    ! and pressure "plev(k)".)
+
+    integer i
+
+    !--------------------------------------------
+
+    call assert(shape(v3) == (/klon, nbp_lev/), "regr_pr_int v3")
+    call assert(shape(pplay) == (/klon, nbp_lev/), "regr_pr_int pplay")
+
+    !$omp master
+    if (is_mpi_root) then
+       call nf95_inq_varid(ncid, name, varid)
+
+       ! Get data at the right day from the input file:
+       call nf95_get_var(ncid, varid, v1(1, :, 1:), start=(/1, 1, julien/))
+       ! Latitudes are in ascending order in the input file while
+       ! "rlatu" is in descending order so we need to invert order:
+       v1(1, :, 1:) = v1(1, nbp_lat:1:-1, 1:)
+
+       ! Complete "v1" with the value at 0 pressure:
+       v1(1, :, 0) = top_value
+
+       ! Duplicate on all longitudes:
+       v1(2:, :, :) = spread(v1(1, :, :), dim=1, ncopies=nbp_lon-1)
+    end if
+    !$omp end master
+
+    call scatter2d(v1, v2)
+
+    ! Regrid in pressure at each horizontal position:
+    do i = 1, klon
+       call regr_lint(1, v2(i, :), (/0., plev/), pplay(i, nbp_lev:1:-1), &
+                         v3(i, nbp_lev:1:-1))
+       ! (invert order of indices because "pplay" is in descending order)
+    end do
+
+  end subroutine regr_pr_int
+
+end module regr_pr_int_m
Index: DZ6/trunk/libf/phylmd/regr_pr_o3_m.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/regr_pr_o3_m.F90	(revision 5267)
+++ 	(revision )
@@ -1,100 +1,0 @@
-! $Id$
-module regr_pr_o3_m
-
-  implicit none
-
-contains
-
-  subroutine regr_pr_o3(p3d, o3_mob_regr)
-
-    ! "regr_pr_o3" stands for "regrid pressure ozone".
-    ! This procedure reads Mobidic ozone mole fraction from
-    ! "coefoz_LMDZ.nc" at the initial day of the run and regrids it in
-    ! pressure.
-    ! Ozone mole fraction from "coefoz_LMDZ.nc" at the initial day is
-    ! a 2D latitude -- pressure variable.
-    ! The target horizontal LMDZ grid is the "scalar" grid: "rlonv", "rlatu".
-    ! The target vertical LMDZ grid is the grid of layer boundaries.
-    ! We assume that the input variable is already on the LMDZ "rlatu"
-    ! latitude grid.
-    ! The input variable does not depend on longitude, but the
-    ! pressure at LMDZ layers does.
-    ! Therefore, the values on the LMDZ grid do depend on longitude.
-    ! Regridding is by averaging, assuming a step function.
-    ! We assume that, in the input file, the pressure levels are in
-    ! hPa and strictly increasing.
-
-    use netcdf95, only: nf95_open, nf95_close, nf95_inq_varid, nf95_get_var
-    use netcdf, only:  nf90_nowrite
-    use assert_m, only: assert
-    use regr_conserv_m, only: regr_conserv
-    use press_coefoz_m, only: press_in_edg
-    use time_phylmdz_mod, only: day_ref
-    use mod_grid_phy_lmdz, only: nbp_lon, nbp_lat, nbp_lev
-
-    REAL, intent(in):: p3d(:, :, :) ! pressure at layer interfaces, in Pa
-    ! ("p3d(i, j, l)" is at longitude "rlonv(i)", latitude "rlatu(j)",
-    ! for interface "l")
-
-    real, intent(out):: o3_mob_regr(:, :, :) ! (iim + 1, jjm + 1, llm)
-    ! (ozone mole fraction from Mobidic adapted to the LMDZ grid)
-    ! ("o3_mob_regr(i, j, l)" is at longitude "rlonv(i)", latitude
-    ! "rlatu(j)" and pressure level "pls(i, j, l)")
-
-    ! Variables local to the procedure:
-
-    integer ncid, varid, ncerr ! for NetCDF
-    integer i, j
-
-    real r_mob(nbp_lat, size(press_in_edg) - 1)
-    ! (ozone mole fraction from Mobidic at day "day_ref")
-    ! (r_mob(j, k) is at latitude "rlatu(j)", in pressure interval
-    ! "[press_in_edg(k), press_in_edg(k+1)]".)
-
-    !------------------------------------------------------------
-
-    print *, "Call sequence information: regr_pr_o3"
-    call assert(shape(o3_mob_regr) == (/nbp_lon + 1, nbp_lat, nbp_lev/), &
-         "regr_pr_o3 o3_mob_regr")
-    call assert(shape(p3d) == (/nbp_lon + 1, nbp_lat, nbp_lev + 1/), "regr_pr_o3 p3d")
-
-    call nf95_open("coefoz_LMDZ.nc", nf90_nowrite, ncid)
-
-    call nf95_inq_varid(ncid, "r_Mob", varid)
-    ! Get data at the right day from the input file:
-    call nf95_get_var(ncid, varid, r_mob, start=(/1, 1, day_ref/))
-    ! Latitudes are in ascending order in the input file while
-    ! "rlatu" is in descending order so we need to invert order:
-    r_mob = r_mob(nbp_lat:1:-1, :)
-
-    call nf95_close(ncid)
-
-    ! Regrid in pressure by averaging a step function of pressure:
-
-    ! Poles:
-    do j = 1, nbp_lat, nbp_lat-1
-       call regr_conserv(1, r_mob(j, :), press_in_edg, &
-            p3d(1, j, nbp_lev + 1:1:-1), o3_mob_regr(1, j, nbp_lev:1:-1))
-       ! (invert order of indices because "p3d" is in descending order)
-    end do
-
-    ! Other latitudes:
-    do j = 2, nbp_lat-1
-       do i = 1, nbp_lon
-          call regr_conserv(1, r_mob(j, :), press_in_edg, &
-               p3d(i, j, nbp_lev + 1:1:-1), o3_mob_regr(i, j, nbp_lev:1:-1))
-          ! (invert order of indices because "p3d" is in descending order)
-       end do
-    end do
-
-    ! Duplicate pole values on all longitudes:
-    o3_mob_regr(2:, 1, :) = spread(o3_mob_regr(1, 1, :), dim=1, ncopies=nbp_lon)
-    o3_mob_regr(2:, nbp_lat, :) &
-         = spread(o3_mob_regr(1, nbp_lat, :), dim=1, ncopies=nbp_lon)
-
-    ! Duplicate first longitude to last longitude:
-    o3_mob_regr(nbp_lon + 1, 2:nbp_lat-1, :) = o3_mob_regr(1, 2:nbp_lat-1, :)
-
-  end subroutine regr_pr_o3
-
-end module regr_pr_o3_m
Index: /LMDZ6/trunk/libf/phylmd/regr_pr_o3_m.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/regr_pr_o3_m.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/regr_pr_o3_m.f90	(revision 5268)
@@ -0,0 +1,100 @@
+! $Id$
+module regr_pr_o3_m
+
+  implicit none
+
+contains
+
+  subroutine regr_pr_o3(p3d, o3_mob_regr)
+
+    ! "regr_pr_o3" stands for "regrid pressure ozone".
+    ! This procedure reads Mobidic ozone mole fraction from
+    ! "coefoz_LMDZ.nc" at the initial day of the run and regrids it in
+    ! pressure.
+    ! Ozone mole fraction from "coefoz_LMDZ.nc" at the initial day is
+    ! a 2D latitude -- pressure variable.
+    ! The target horizontal LMDZ grid is the "scalar" grid: "rlonv", "rlatu".
+    ! The target vertical LMDZ grid is the grid of layer boundaries.
+    ! We assume that the input variable is already on the LMDZ "rlatu"
+    ! latitude grid.
+    ! The input variable does not depend on longitude, but the
+    ! pressure at LMDZ layers does.
+    ! Therefore, the values on the LMDZ grid do depend on longitude.
+    ! Regridding is by averaging, assuming a step function.
+    ! We assume that, in the input file, the pressure levels are in
+    ! hPa and strictly increasing.
+
+    use netcdf95, only: nf95_open, nf95_close, nf95_inq_varid, nf95_get_var
+    use netcdf, only:  nf90_nowrite
+    use assert_m, only: assert
+    use regr_conserv_m, only: regr_conserv
+    use press_coefoz_m, only: press_in_edg
+    use time_phylmdz_mod, only: day_ref
+    use mod_grid_phy_lmdz, only: nbp_lon, nbp_lat, nbp_lev
+
+    REAL, intent(in):: p3d(:, :, :) ! pressure at layer interfaces, in Pa
+    ! ("p3d(i, j, l)" is at longitude "rlonv(i)", latitude "rlatu(j)",
+    ! for interface "l")
+
+    real, intent(out):: o3_mob_regr(:, :, :) ! (iim + 1, jjm + 1, llm)
+    ! (ozone mole fraction from Mobidic adapted to the LMDZ grid)
+    ! ("o3_mob_regr(i, j, l)" is at longitude "rlonv(i)", latitude
+    ! "rlatu(j)" and pressure level "pls(i, j, l)")
+
+    ! Variables local to the procedure:
+
+    integer ncid, varid, ncerr ! for NetCDF
+    integer i, j
+
+    real r_mob(nbp_lat, size(press_in_edg) - 1)
+    ! (ozone mole fraction from Mobidic at day "day_ref")
+    ! (r_mob(j, k) is at latitude "rlatu(j)", in pressure interval
+    ! "[press_in_edg(k), press_in_edg(k+1)]".)
+
+    !------------------------------------------------------------
+
+    print *, "Call sequence information: regr_pr_o3"
+    call assert(shape(o3_mob_regr) == (/nbp_lon + 1, nbp_lat, nbp_lev/), &
+         "regr_pr_o3 o3_mob_regr")
+    call assert(shape(p3d) == (/nbp_lon + 1, nbp_lat, nbp_lev + 1/), "regr_pr_o3 p3d")
+
+    call nf95_open("coefoz_LMDZ.nc", nf90_nowrite, ncid)
+
+    call nf95_inq_varid(ncid, "r_Mob", varid)
+    ! Get data at the right day from the input file:
+    call nf95_get_var(ncid, varid, r_mob, start=(/1, 1, day_ref/))
+    ! Latitudes are in ascending order in the input file while
+    ! "rlatu" is in descending order so we need to invert order:
+    r_mob = r_mob(nbp_lat:1:-1, :)
+
+    call nf95_close(ncid)
+
+    ! Regrid in pressure by averaging a step function of pressure:
+
+    ! Poles:
+    do j = 1, nbp_lat, nbp_lat-1
+       call regr_conserv(1, r_mob(j, :), press_in_edg, &
+            p3d(1, j, nbp_lev + 1:1:-1), o3_mob_regr(1, j, nbp_lev:1:-1))
+       ! (invert order of indices because "p3d" is in descending order)
+    end do
+
+    ! Other latitudes:
+    do j = 2, nbp_lat-1
+       do i = 1, nbp_lon
+          call regr_conserv(1, r_mob(j, :), press_in_edg, &
+               p3d(i, j, nbp_lev + 1:1:-1), o3_mob_regr(i, j, nbp_lev:1:-1))
+          ! (invert order of indices because "p3d" is in descending order)
+       end do
+    end do
+
+    ! Duplicate pole values on all longitudes:
+    o3_mob_regr(2:, 1, :) = spread(o3_mob_regr(1, 1, :), dim=1, ncopies=nbp_lon)
+    o3_mob_regr(2:, nbp_lat, :) &
+         = spread(o3_mob_regr(1, nbp_lat, :), dim=1, ncopies=nbp_lon)
+
+    ! Duplicate first longitude to last longitude:
+    o3_mob_regr(nbp_lon + 1, 2:nbp_lat-1, :) = o3_mob_regr(1, 2:nbp_lat-1, :)
+
+  end subroutine regr_pr_o3
+
+end module regr_pr_o3_m
Index: DZ6/trunk/libf/phylmd/regr_pr_time_av_m.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/regr_pr_time_av_m.F90	(revision 5267)
+++ 	(revision )
@@ -1,715 +1,0 @@
-! $Id$
-MODULE regr_pr_time_av_m
-
-  USE write_field_phy
-  USE mod_phys_lmdz_transfert_para, ONLY: bcast
-  USE mod_phys_lmdz_para, ONLY: mpi_rank, omp_rank
-  USE print_control_mod,  ONLY: prt_level
-  IMPLICIT NONE
-
-!-------------------------------------------------------------------------------
-! Purpose: Regrid pressure with an averaging method. Operations done:
-!  * on the root process: read a NetCDF 3D or 4D field at a given day.
-!  * pack the fields to the LMDZ "horizontal "physics" grid and scatter
-!    to all threads of all processes;
-!  * in all the threads of all the processes, regrid the fields in pressure
-!    to the LMDZ vertical grid.
-!  * the forcing fields are stretched if the following arguments are present:
-!     - "lat_in":  input file latitudes.
-!     - "Ptrp_ou": target grid (LMDZ) tropopause pressure.
-!   so that the tropopause is shifted to the position of the one of LMDZ.
-!  Note that the ozone quantity conservation is not ensured.
-!-------------------------------------------------------------------------------
-! Initial routine: regr_pr_av_m module (L. Guez).
-! Present version: David Cugnet ; corresponding additions:
-!    - time interpolation
-!    - 3D compliant
-!    - vertical stretching of the field to allow tropopause matching between
-!    input field and current lmdz field.
-!-------------------------------------------------------------------------------
-! Remarks:
-!  * 3D fields are zonal means, with dimensions (latitude, pressure, julian day)
-!  * 4D fields have the dimensions:  (longitude, latitude, pressure, julian day)
-!  * All the fields are already on the horizontal grid (rlatu) or (rlatu,rlonv),
-!    except that the latitudes are in ascending order in the input file.
-!  * We assume that all the input fields have the same coordinates.
-!  * The target vertical LMDZ grid is the grid of layer centers.
-!  * Regridding in pressure can be:
-!    - Ploc=='I': pressures provided at Interfaces    => conservative 2nd order
-!         OK for ozone coefficients regridding in Cariolle routines.
-!    - Ploc=='C': pressures provides at cells Centers => classical linear       
-!         OK for ozone vertical regridding, especially when torpopause
-!      adjustment is activated, to avoid "strairs shape effect" on profiles.
-!  * All the fields are regridded as a single multi-dimensional array, so it
-!    saves CPU time to call this procedure once for several NetCDF variables
-!    rather than several times, each time for a single NetCDF variable.
-!  * The input file pressure at tropopause can be (in decreasing priority):
-!    1) read from the file if "tropopause_air_pressure" field is available.
-!    2) computed using "tro3" and "tro3_at_tropopause' (if available).
-!    3) computed using "tro3" and a fixed threshold otherwise, constant or
-!    determined using an empirical three parameters law:
-!         o3t(ppbV)=co1+co2*SIN(PI*(month-2)/6)*TANH(lat_deg/co3)
-!       => co1 and co2 are in ppbV, and co3 in degrees.
-!       => co3 allow a smooth transition between north and south hemispheres.
-!  * If available, the field "ps" (input file pressure at surface) is used.
-!    If not, the current LMDZ ground pressure is taken instead.
-!  * Fields with suffix "m"/"p" are at the closest records earlier/later than
-!  the mid-julian day "julien", on the global "dynamics" horizontal grid.
-!  * Fields(i,j,k,l) are at longitude-latitude-name "rlonv(i)-rlatu(j)-nam(l)",
-!    pressure level/interval (Ploc=="C"/"I") "pcen_in(k)"/"pcen_in(k:k+1)]".
-!  * In the 2D file case, the values are the same for all longitudes.
-!  * The tropopause correction works like this: the input fields (file) are
-!  interpolated on output (LMDZ) pressure field, which is streched using a power
-!  law in a limited zone made of 2 layers:
-!    1) between lower bound (lower than lowest tropopause) and LMDZ tropopause
-!    2) between LMDZ tropopause and upper bound (higher thzn highest tropopause)
-!  The stretching function has the following form:
-!        Sigma_str = Sigma^(1+alpha*phi(Sigma)), where:
-!   * alpha=LOG(SigT_in/SigT_ou)/LOG(SigT_ou)
-!     This value shifts the file tropopause to the height of the one of LMDZ.
-!   * phi is quasi-linear (sections of 1/log function) in the adjacent intervals:
-!       - from 0 to 1 in [Sig_top,SigT_ou]
-!       - from 1 to 0 in [SigT_ou,Sig_bot]
-!  This quasi-triangular localization function ponderates alpha-law from one near
-!  the tropopause to zero each side apart.
-!
-! * The following fields are on the global "dynamics" grid, as read from files:
-  REAL,    SAVE, ALLOCATABLE :: v1 (:,:,:,:)       !--- Current  time ozone fields
-! v1: Field read/interpol at time "julien" on the global "dynamics" horiz. grid.
-  REAL,    SAVE, ALLOCATABLE :: v1m(:,:,:,:)       !--- Previous time ozone fields
-  REAL,    SAVE, ALLOCATABLE :: v1p(:,:,:,:)       !--- Next     time ozone fields
-  REAL,    SAVE, ALLOCATABLE :: pgm(:,:), pgp(:,:) !--- Ground     pressure
-  REAL,    SAVE, ALLOCATABLE :: ptm(:,:), ptp(:,:) !--- Tropopause pressure
-  REAL,    SAVE, ALLOCATABLE :: otm(:,:), otp(:,:) !--- Tropopause o3 mix. ratio
-  INTEGER, SAVE :: ntim_in                         !--- Records nb in input file
-  INTEGER, SAVE :: itrp0                           !--- idx above chem tropop.
-  INTEGER, SAVE :: irec                            !--- Current time index
-!      * for daily   input files: current julian day number
-!      * for monthly input files: julien is in [time_in(irec),time_in(irec+1)]
-  LOGICAL, SAVE :: linterp                         !--- Interpolation in time
-  LOGICAL, SAVE :: lPrSfile                        !--- Surface pressure flag
-  LOGICAL, SAVE :: lPrTfile                        !--- Tropopause pressure flag
-  LOGICAL, SAVE :: lO3Tfile                        !--- Tropopause ozone flag
-  LOGICAL, SAVE :: lfirst=.TRUE.                   !--- First call flag
-!$OMP THREADPRIVATE(lfirst)
-  REAL,    PARAMETER :: pTropUp=9.E+3 !--- Value  <  tropopause pressure (Pa)
-  REAL,    PARAMETER :: gamm   =0.4   !--- Max. stretched layer sigma ratio
-  REAL,    PARAMETER :: rho    =1.4   !--- Max tropopauses sigma ratio
-  REAL,    PARAMETER :: o3t0   =1.E-7 !--- Nominal O3 vmr at tropopause
-  LOGICAL, PARAMETER :: lO3Tpara=.FALSE. !--- Parametrized O3 vmr at tropopause
-  LOGICAL, PARAMETER :: ldebug=.FALSE.!--- Force writefield_phy multiple outputs
-  REAL, PARAMETER :: ChemPTrMin=9.E+3 !--- Thresholds for minimum and maximum
-  REAL, PARAMETER :: ChemPTrMax=4.E+4 !    chemical  tropopause pressure (Pa).
-  REAL, PARAMETER :: DynPTrMin =8.E+3 !--- Thresholds for minimum and maximum
-  REAL, PARAMETER :: DynPTrMax =4.E+4 !    dynamical tropopause pressure (Pa).
-
-CONTAINS
-
-!-------------------------------------------------------------------------------
-!
-SUBROUTINE regr_pr_time_av(fID, nam, julien, Ploc, Pre_in, Pre_ou, v3, Pgnd_ou,&
-                                             time_in, lon_in, lat_in, Ptrp_ou)
-!
-!-------------------------------------------------------------------------------
-  USE dimphy,         ONLY: klon
-  USE netcdf95,       ONLY: NF95_INQ_VARID, NF95_INQUIRE_VARIABLE, &
-                            NF95_INQ_DIMID, NF95_INQUIRE_DIMENSION, nf95_get_var
-  USE netcdf,         ONLY: NF90_INQ_VARID, NF90_NOERR
-  USE assert_m,       ONLY: assert
-  USE assert_eq_m,    ONLY: assert_eq
-!!  USE comvert_mod,    ONLY: scaleheight
-  USE interpolation,  ONLY: locate
-  USE regr_conserv_m, ONLY: regr_conserv
-  USE regr_lint_m,    ONLY: regr_lint
-  USE slopes_m,       ONLY: slopes
-  USE mod_phys_lmdz_para,           ONLY: is_mpi_root,is_master
-  USE mod_grid_phy_lmdz,            ONLY: nlon=>nbp_lon, nlat=>nbp_lat, nlev_ou=>nbp_lev, klon_glo, grid_type, unstructured
-  USE mod_phys_lmdz_transfert_para, ONLY: scatter2d, scatter, gather
-  USE phys_cal_mod,                 ONLY: calend, year_len, days_elapsed, jH_cur
-  USE geometry_mod,                 ONLY: ind_cell_glo
-!-------------------------------------------------------------------------------
-! Arguments:
-  INTEGER,           INTENT(IN) :: fID        !--- NetCDF file ID
-  CHARACTER(LEN=13), INTENT(IN) :: nam(:)     !--- NetCDF variables names
-  REAL,              INTENT(IN) :: julien     !--- Days since Jan 1st
-  CHARACTER(LEN=1),  INTENT(IN) :: Ploc       !--- Pressures locations
-  !--- File/LMDZ (resp. decreasing & increasing order) pressure, Pa
-  !    At cells centers or interfaces depending on "Ploc" keyword (C/I)
-  REAL,    INTENT(IN)  :: Pre_in(:)           !--- in:  file      (nlev_in[+1])
-  REAL,    INTENT(IN)  :: Pre_ou(:,:)         !--- out: LMDZ (klon,nlev_ou[+1])
-  REAL,    INTENT(OUT) :: v3(:,:,:)           !--- Regr. fld (klon,nlev_ou,n_var)
-  REAL,    INTENT(IN), OPTIONAL :: Pgnd_ou(:) !--- LMDZ ground pressure   (klon)
-  REAL,    INTENT(IN), OPTIONAL :: time_in(:) !--- Records times, in days
-                                              !    since Jan 1 of current year
-  REAL,    INTENT(IN), OPTIONAL :: lon_in(:)  !--- File longitudes vector (klon)
-  REAL,    INTENT(IN), OPTIONAL :: lat_in(:)  !--- File latitudes  vector (klon)
-  REAL,    INTENT(IN), OPTIONAL :: Ptrp_ou(:) !--- LMDZ tropopause pres   (klon)
-!-------------------------------------------------------------------------------
-! Local variables:
-  include "clesphys.h"
-  include "YOMCST.h"
-  CHARACTER(LEN=80)  :: sub
-  CHARACTER(LEN=320) :: str
-  INTEGER :: vID, ncerr, n_var, ibot, iout, nn
-  INTEGER :: i, nlev_in, n_dim, itop, itrp, i0
-  LOGICAL :: lAdjTro                          !--- Need to adjust tropopause
-  REAL    :: y_frac                           !--- Elapsed year fraction
-  REAL    :: alpha, beta, al                  !--- For stretching/interpolation
-  REAL    :: SigT_in, SigT_ou                 !--- Input and output tropopauses
-  REAL    :: Sig_bot, Sig_top                 !--- Bounds of quasi-hat function
-  REAL    :: Sig_bo0, Sig_to0                 !--- Lower/upper tropopauses
-  REAL    :: Sig_in (SIZE(Pre_in))            !--- Input field sigma levels
-  REAL    :: Sig_ou (SIZE(Pre_ou,2))          !--- Output LMDZ sigma levels
-  REAL    :: phi    (SIZE(Pre_ou,2))          !--- Stretching exponent anomaly
-  REAL    :: Pstr_ou(SIZE(Pre_ou,2))          !--- Stretched pressure levels
-  REAL    :: Pres_ou(SIZE(Pre_ou,2))          !--- Pre_ou(i,:), reversed order
-  REAL, DIMENSION(nlon, nlat) :: pg1,      pt1,      ot1
-  REAL, DIMENSION(klon)       :: Pgnd_in,  Ptrp_in,  Otrp_in
-  REAL, DIMENSION(klon)       :: Ptrop_ou, Pgrnd_ou
-! * The following fields are scattered to the partial "physics" horizontal grid.
-  REAL, POINTER :: v2(:,:,:)                  !--- Current  time ozone fields
-!     In the 2D file case, the values are the same for all longitudes.
-!     "v2(i, k, l)" is at longitude-latitude "xlon(i)-xlat(i)" and name "nam(l)"
-! Both are:          * if Ploc=='I' in pressure interval "press_in_edg(k:k+1)"
-!                    * if Ploc=='C' at pressure          "press_in_cen(k)"
-  REAL, TARGET :: &
-    v2i(klon,SIZE(Pre_in)-1,SIZE(nam)), &     !--- v2 in Ploc=='I' case
-    v2c(klon,SIZE(Pre_in)  ,SIZE(nam))        !--- v2 in Ploc=='C' case
-  INTEGER,ALLOCATABLE :: ind_cell_glo_glo(:)
-  LOGICAL :: ll
-!--- For debug
-  REAL, DIMENSION(klon)             :: Ptrop_in, Ptrop_ef
-  REAL, DIMENSION(klon)             :: dzStrain, dzStrain0
-  REAL, DIMENSION(klon,SIZE(Pre_ou,2)) :: Pstrn_ou, phii
-!-------------------------------------------------------------------------------
-  sub="regr_pr_time_av"
-  nlev_in=SIZE(Pre_in); IF(Ploc=='I') nlev_in=nlev_in-1
-  IF(Ploc=='I') THEN; v2 => v2i; ELSE; v2 => v2c; END IF
-  CALL assert(SIZE(Pre_ou,1)==klon,TRIM(sub)//" Pre_ou klon")
-  CALL assert(SIZE(v3,1)==klon,    TRIM(sub)//" v3 klon")
-  CALL assert(SIZE(v3,2)==nlev_ou, TRIM(sub)//" v3 nlev_ou")
-  IF(Ploc=='I') CALL assert(SIZE(Pre_ou,2)==nlev_ou+1,TRIM(sub)//" Pre_ou nlev_ou+1")
-  IF(Ploc=='C') CALL assert(SIZE(Pre_ou,2)==nlev_ou  ,TRIM(sub)//" Pre_ou nlev_ou")
-  n_var = assert_eq(SIZE(nam),SIZE(v3,3),TRIM(sub)//" v3 n_var")
-  IF(PRESENT(Pgnd_ou)) CALL assert(SIZE(Pgnd_ou)==klon,TRIM(sub)//" Pgnd_ou klon")
-  IF(PRESENT(lon_in))  CALL assert(SIZE(lon_in )==klon,TRIM(sub)//" lon_in klon")
-  IF(PRESENT(lat_in))  CALL assert(SIZE(lat_in )==klon,TRIM(sub)//" lat_in klon")
-  IF(PRESENT(Ptrp_ou)) CALL assert(SIZE(Ptrp_ou)==klon,TRIM(sub)//" Ptrp_ou klon")
-  lAdjTro=PRESENT(Ptrp_ou)
-  IF(lAdjTro) THEN
-    IF(.NOT.PRESENT(lat_in)) &
-      CALL abort_physic(sub, 'Missing lat_in (required if adjust_tropopause=T)', 1)
-    IF(.NOT.PRESENT(Pgnd_ou).AND.Ploc=='C') &
-      CALL abort_physic(sub, 'Missing ground Pr(required if adjust_tropopause=T)', 1)
-    IF(PRESENT(Pgnd_ou)) THEN; Pgrnd_ou=Pgnd_ou; ELSE; Pgrnd_ou=Pre_ou(:,1); END IF
-  END IF
-
-  !$OMP MASTER
-  IF(is_mpi_root) THEN
-
-    !=== CHECK WHICH FIELDS ARE AVAILABLE IN THE INPUT FILE
-    IF(lfirst) THEN
-      lPrSfile=lAdjTro.AND.NF90_INQ_VARID(fID,"ps"                     ,vID)==NF90_NOERR
-      lPrTfile=lAdjTro.AND.NF90_INQ_VARID(fID,"tropopause_air_pressure",vID)==NF90_NOERR
-      lO3Tfile=lAdjTro.AND.NF90_INQ_VARID(fID,"tro3_at_tropopause"     ,vID)==NF90_NOERR
-      CALL NF95_INQ_DIMID(fID,"time",vID)
-      CALL NF95_INQUIRE_DIMENSION(fID,vID,nclen=ntim_in)
-      linterp=PRESENT(time_in).AND.ntim_in==14
-      ALLOCATE(v1(nlon,nlat,nlev_in,n_var))
-      IF(linterp) THEN
-        ALLOCATE(v1m(nlon,nlat,nlev_in,n_var),v1p(nlon,nlat,nlev_in,n_var))
-        IF(lPrSfile) ALLOCATE(pgm(nlon,nlat),pgp(nlon,nlat))
-        IF(lPrTfile) ALLOCATE(ptm(nlon,nlat),ptp(nlon,nlat))
-        IF(lO3Tfile) ALLOCATE(otm(nlon,nlat),otp(nlon,nlat))
-      END IF
-      !--- INITIAL INDEX: LOCATE A LAYER WELL ABOVE TROPOPAUSE (50hPa)
-      IF(lAdjTro) itrp0=locate(Pre_in,pTropUp)
-      CALL msg(linterp,'Monthly O3 files => ONLINE TIME INTERPOLATION.'    ,sub)
-      CALL msg(lPrSfile,'Using GROUND PRESSURE from input O3 forcing file.',sub)
-      CALL msg(lAdjTro ,'o3 forcing file tropopause location uses:'        ,sub)
-      IF(lPrTfile)      THEN; str='    INPUT FILE PRESSURE'
-      ELSE IF(lO3Tfile) THEN; str='    INPUT FILE O3 CONCENTRATION'
-      ELSE IF(lO3Tpara) THEN; str='    PARAMETRIZED O3 concentration'
-      ELSE;                   str='    CONSTANT O3 concentration'; END IF
-      CALL msg(lAdjTro,TRIM(str)//' at tropopause')
-    END IF
-
-    !=== UPDATE (ALWAYS FOR DAILY FILES, EACH MONTH FOR MONTHLY FILES)
-    CALL update_fields()
-
-    !=== TIME INTERPOLATION FOR MONTHLY INPUT FILES
-    IF(linterp) THEN
-      WRITE(str,'(a,f12.8,2(a,f5.1))')'Interpolating O3 at julian day ',julien,&
-        ' from fields at times ',time_in(irec),' and ', time_in(irec+1)
-      CALL msg(.TRUE.,str,sub)
-      al=(time_in(irec+1)-julien)/(time_in(irec+1)-time_in(irec))
-      v1=al*v1m+(1.-al)*v1p
-      IF(lPrSfile) pg1=al*pgm+(1.-al)*pgp
-      IF(lPrTfile) pt1=al*ptm+(1.-al)*ptp
-      IF(lO3Tfile) ot1=al*otm+(1.-al)*otp
-    END IF
-  ELSE
-    IF (lfirst) ALLOCATE(v1(0,0,0,0))
-  END IF
-  !$OMP END MASTER
-  !$OMP BARRIER
-  IF(lfirst) THEN
-    lfirst=.FALSE.;       CALL bcast(lfirst)
-    IF(lAdjTro)           CALL bcast(itrp0)
-    CALL bcast(lPrSfile); CALL bcast(lPrTfile)
-    CALL bcast(lO3Tfile); CALL bcast(linterp)
-  END IF
-  
-  IF (is_master) THEN 
-    ALLOCATE(ind_cell_glo_glo(klon_glo))
-  ELSE
-    ALLOCATE(ind_cell_glo_glo(0))
-  ENDIF
-  CALL gather(ind_cell_glo,ind_cell_glo_glo)
-  IF (is_master .AND. grid_type==unstructured) v1(:,:,:,:)=v1(:,ind_cell_glo_glo(:),:,:)
-  
-  CALL scatter2d(v1,v2)
-
-  !--- No "ps" in input file => assumed to be equal to current LMDZ ground press
-  IF(lPrSfile) THEN
-    IF (is_master .AND. grid_type==unstructured) pg1(:,:)=pg1(:,ind_cell_glo_glo(:))
-    CALL scatter2d(pg1,Pgnd_in)
-  ELSE
-    Pgnd_in=Pre_ou(:,1)
-  END IF
-
-  IF(lPrTfile) THEN
-    IF (is_master .AND. grid_type==unstructured) pt1(:,:)=pt1(:,ind_cell_glo_glo(:))
-    CALL scatter2d(pt1,Ptrp_in)
-  ENDIF
-
-  IF(lO3Tfile) THEN
-    IF (is_master .AND. grid_type==unstructured) ot1(:,:)=ot1(:,ind_cell_glo_glo(:))
-    CALL scatter2d(ot1,Otrp_in)
-  ENDIF
-  !--- No ground pressure in input file => choose it to be the one of LMDZ
-  IF(lAdjTro.AND..NOT.lPrSfile) Pgnd_in(:)=Pgrnd_ou(:)
-
-  !--- REGRID IN PRESSURE ; 3rd index inverted because "paprs" is decreasing
-  IF(.NOT.lAdjTro) THEN
-    DO i=1,klon
-      Pres_ou=Pre_ou(i,SIZE(Pre_ou,2):1:-1)   !--- pplay & paprs are decreasing
-      IF(Ploc=='C') CALL regr_lint   (1,v2(i,:,:), LOG(Pre_in(:)),             &
-        LOG(Pres_ou(:)), v3(i,nlev_ou:1:-1,:))
-      IF(Ploc=='I') CALL regr_conserv(1,v2(i,:,:),     Pre_in(:) ,             &
-            Pres_ou(:) , v3(i,nlev_ou:1:-1,:), slopes(1,v2(i,:,:), Pre_in(:)))
-    END DO
-!-------------------------------------------------------------------------------
-  ELSE                        !--- REGRID IN PRESSURE ; TROPOPAUSE ADJUSTMENT
-!-------------------------------------------------------------------------------
-    y_frac=(REAL(days_elapsed)+jH_cur)/year_len
-
-    !--- OUTPUT SIGMA LEVELS
-    DO i=1,klon
-
-      !--- INPUT/OUTPUT (FILE/LMDZ) SIGMA LEVELS IN CURRENT COLUMN
-      Pres_ou   = Pre_ou(i,SIZE(Pre_ou,2):1:-1)!--- pplay & paprs are decreasing
-      Sig_in(:) = Pre_in (:)/Pgnd_in(i)            !--- increasing values
-      Sig_ou(:) = Pres_ou(:)/Pgnd_ou(i)            !--- increasing values
-
-      !--- INPUT (FILE) SIGMA LEVEL AT TROPOPAUSE ; extreme values are filtered
-      ! to keep tropopause pressure realistic ; high values are usually due to
-      ! ozone hole fooling the crude chemical tropopause detection algorithm.
-      SigT_in = get_SigTrop(i,itrp)
-      SigT_in=MIN(SigT_in,ChemPTrMax/Pgnd_in(i))   !--- too low  value filtered
-      SigT_in=MAX(SigT_in,ChemPTrMin/Pgnd_ou(i))   !--- too high value filtered
-
-      !--- OUTPUT (LMDZ) SIGMA LEVEL AT TROPOPAUSE ; too high variations of the
-      ! dynamical tropopause (especially in filaments) are conterbalanced with
-      ! a filter ensuring it stays within a certain distance around input (file)
-      ! tropopause, hence avoiding avoid a too thick stretched region ; a final
-      ! extra-safety filter keeps the tropopause pressure value realistic.
-      SigT_ou = Ptrp_ou(i)/Pgnd_ou(i)
-      IF(SigT_ou<SigT_in/rho) SigT_ou=SigT_in/rho  !--- too low  value w/r input
-      IF(SigT_ou>SigT_in*rho) SigT_ou=SigT_in*rho  !--- too high value w/r input
-      SigT_ou=MIN(SigT_ou,DynPTrMax/Pgnd_ou(i))    !--- too low  value filtered
-      SigT_ou=MAX(SigT_ou,DynPTrMin/Pgnd_ou(i))    !--- too high value filtered
-      Ptrop_ou(i)=SigT_ou*Pgnd_ou(i)
-      iout = locate(Sig_ou(:),SigT_ou)
-
-      !--- POWER LAW COEFFICIENT FOR TROPOPAUSES MATCHING
-      alpha = LOG(SigT_in/SigT_ou)/LOG(SigT_ou)
-
-      !--- DETERMINE STRETCHING DOMAIN UPPER AND LOWER BOUNDS
-      Sig_bo0 = MAX(SigT_in,SigT_ou)               !--- lowest  tropopause
-      Sig_to0 = MIN(SigT_in,SigT_ou)               !--- highest tropopause
-      beta    = (Sig_bo0/Sig_to0)**gamm            !--- stretching exponent
-      Sig_bot = MIN(Sig_bo0*beta,0.1*(9.+Sig_bo0)) !--- must be <1
-      ibot = locate(Sig_ou(:),Sig_bot)             !--- layer index
-      IF(ibot-iout<2) THEN                         !--- at least one layer thick
-        ibot=MIN(iout+2,nlev_ou); Sig_bot=Sig_ou(ibot)
-      END IF
-      Sig_top = Sig_to0/beta                       !--- upper bound
-      itop = locate(Sig_ou(:),Sig_top)             !--- layer index
-      IF(iout-itop<2) THEN                         !--- at least one layer thick
-        itop=MAX(iout-2,1); Sig_top=Sig_ou(itop)
-      END IF
-
-      !--- STRETCHING POWER LAW LOCALIZATION FUNCTION:
-      !    0 in [0,Sig_top]    0->1 in [Sig_top,SigT_ou]
-      !    0 in [Sig_bot,1]    1->0 in [SigT_ou, Sig_bot]
-      phi(:)=0.
-      phi(itop+1:iout) = (1.-LOG(Sig_top)/LOG(Sig_ou(itop+1:iout)))&
-                            *LOG(SigT_ou)/LOG(SigT_ou/Sig_top)
-      phi(iout+1:ibot) = (1.-LOG(Sig_bot)/LOG(Sig_ou(iout+1:ibot)))&
-                            *LOG(SigT_ou)/LOG(SigT_ou/Sig_bot)
-
-      !--- LOCALY STRECHED OUTPUT (LMDZ) PRESSURE PROFILES (INCREASING ORDER)
-      Pstr_ou(:) = Pres_ou(:) * Sig_ou(:)**(alpha*phi(:))
-
-      !--- REGRID INPUT PROFILE ON STRAINED VERTICAL OUTPUT LEVELS
-      IF(Ploc=='C') CALL regr_lint   (1, v2(i,:,:), LOG(Pre_in(:)),            &
-        LOG(Pstr_ou(:)), v3(i,nlev_ou:1:-1,:))
-      IF(Ploc=='I') CALL regr_conserv(1, v2(i,:,:),     Pre_in(:) ,            &
-            Pstr_ou(:) , v3(i,nlev_ou:1:-1,:), slopes(1,v2(i,:,:), Pre_in(:)))
-
-      !--- CHECK CONCENTRATIONS. strato: 50ppbV-15ppmV ; tropo: 5ppbV-300ppbV.
-      i0=nlev_ou-locate(Pres_ou(:),Ptrop_ou(i))+1
-      ll=check_ozone(v3(i, 1:i0-1   ,1),lon_in(i),lat_in(i),1 ,'troposphere',  &
-                     5.E-9,3.0E-7)
-!     IF(ll) CALL abort_physic(sub, 'Inconsistent O3 values in troposphere', 1)
-      ll=check_ozone(v3(i,i0:nlev_ou,1),lon_in(i),lat_in(i),i0,'stratosphere', &
-                     5.E-8,1.5E-5)
-!     IF(ll) CALL abort_physic(sub, 'Inconsistent O3 values in stratosphere', 1)
-
-      IF(ldebug) THEN
-        dzStrain0(i) = SIGN(7.*LOG(Sig_bo0/Sig_to0),SigT_in-SigT_ou)
-        dzStrain (i) = SIGN(7.*LOG(Sig_bot/Sig_top),SigT_in-SigT_ou)
-        Ptrop_in (i) = SigT_in*Pgnd_in(i)
-        Pstrn_ou(i,:)= Pstr_ou
-        phii(i,:)    = phi(:)
-        Ptrop_ef(i)  = PTrop_chem(i, itrp, locate(Pres_ou(:),PTropUp),    &
-                             Pres_ou(:), v3(:,nlev_ou:1:-1,1),o3trop=o3t0)
-      END IF
-    END DO
-  END IF
-  IF(ldebug.AND.lAdjTro) THEN
-    CALL writefield_phy('PreSt_ou' ,Pstrn_ou,SIZE(Pre_ou,2)) !--- Strained Pres
-    CALL writefield_phy('dzStrain' ,dzStrain ,1)     !--- Strained thickness
-    CALL writefield_phy('dzStrain0',dzStrain0,1)     !--- Tropopauses distance
-    CALL writefield_phy('phi',phii,nlev_ou)          !--- Localization function
-    !--- Tropopauses pressures:
-    CALL writefield_phy('PreTr_in',Ptrop_in,1)       !--- Input and effective
-    CALL writefield_phy('PreTr_ou',Ptrop_ou,1)       !--- LMDz dyn tropopause
-    CALL writefield_phy('PreTr_ef',Ptrop_ef,1)       !--- Effective chem tropop
-  END IF
-  IF(ldebug) THEN
-    CALL writefield_phy('Ozone_in',v2(:,:,1),nlev_in)!--- Raw input O3 field
-    CALL writefield_phy('Ozone_ou',v3(:,:,1),nlev_ou)!--- Output ozone field
-    CALL writefield_phy('Pres_ou' ,Pre_ou,SIZE(Pre_ou,2))!--- LMDZ Pressure
-  END IF
-
-CONTAINS
-
-
-!-------------------------------------------------------------------------------
-!
-SUBROUTINE update_fields()
-!
-!-------------------------------------------------------------------------------
-  IF(.NOT.linterp) THEN                 !=== DAILY FILES: NO TIME INTERPOLATION
-    CALL msg(.TRUE.,sub,'Updating Ozone forcing field: read from file.')
-    irec=MIN(INT(julien)+1,ntim_in)     !--- irec is just the julian day number
-    !--- MIN -> Security in the unlikely case of roundup errors.
-    CALL get_3Dfields(v1)               !--- Read ozone field(s)
-    IF(lAdjTro) THEN                    !--- Additional files for fields strain
-      IF(lPrSfile) CALL get_2Dfield(pg1,"ps")
-      IF(lPrTfile) CALL get_2Dfield(pt1,"tropopause_air_pressure")
-      IF(lO3Tfile) CALL get_2Dfield(ot1,"tro3_at_tropopause")
-    END IF
-  ELSE                                  !=== MONTHLY FILES: GET 2 NEAREST RECS
-    IF(lfirst) irec=locate(time_in,julien) !--- Need to locate surrounding times
-    IF(.NOT.lfirst.AND.julien<time_in(irec+1)) RETURN
-    CALL msg(.TRUE.,'Refreshing adjacent Ozone forcing fields.',sub)
-    IF(lfirst) THEN                     !=== READ EARLIEST TIME FIELDS
-      WRITE(str,'(a,i3,a,f12.8,a)')'Previous available field update (step 1): '&
-      //'reading record ',irec,' (time ',time_in(irec),')'
-      CALL msg(.TRUE.,str,sub)
-      CALL get_3Dfields(v1m)            !--- Read ozone field(s)
-      IF(lAdjTro) THEN                  !--- Additional files for fields strain
-        IF(lPrSfile) CALL get_2Dfield(pgm,"ps")
-        IF(lPrTfile) CALL get_2Dfield(ptm,"tropopause_air_pressure")
-        IF(lO3Tfile) CALL get_2Dfield(otm,"tro3_at_tropopause")
-      END IF
-    ELSE                                !=== SHIFT FIELDS
-      irec=irec+1
-      WRITE(str,'(a,i3,a,f12.8,a)')'Previous available field update: shifting'&
-      //' current next one (',irec,', time ',time_in(irec),')'
-      CALL msg(.TRUE.,str,sub)
-      v1m=v1p                           !--- Ozone fields
-      IF(lAdjTro) THEN                  !--- Additional files for fields strain
-        IF(lPrSfile) pgm=pgp             !--- Surface pressure
-        IF(lPrTfile) ptm=ptp             !--- Tropopause pressure
-        IF(lO3Tfile) otm=otp             !--- Tropopause ozone
-      END IF
-    END IF
-    irec=irec+1
-    WRITE(str,'(a,i3,a,f12.8,a)')'Next available field update: reading record'&
-    ,irec,' (time ',time_in(irec),')'
-    CALL msg(.TRUE.,str,sub)
-    CALL get_3Dfields(v1p)              !--- Read ozone field(s)
-    IF(lAdjTro) THEN                    !--- Additional files for fields strain
-      IF(lPrSfile) CALL get_2Dfield(pgp,"ps")
-      IF(lPrTfile) CALL get_2Dfield(ptp,"tropopause_air_pressure")
-      IF(lO3Tfile) CALL get_2Dfield(otp,"tro3_at_tropopause")
-    END IF
-    irec=irec-1
-  END IF
-
-END SUBROUTINE update_fields
-!
-!-------------------------------------------------------------------------------
-
-
-!-------------------------------------------------------------------------------
-!
-SUBROUTINE get_2Dfield(v,var)
-!
-!-------------------------------------------------------------------------------
-! Purpose: Shortcut to get the "irec"th record of the surface field named "var"
-!          from the input file.
-! Remark: In case the field is zonal, it is duplicated along first dimension.
-!-------------------------------------------------------------------------------
-! Arguments:
-  REAL,             INTENT(INOUT) :: v(:,:)
-  CHARACTER(LEN=*), INTENT(IN)    :: var
-!-------------------------------------------------------------------------------
-  CALL NF95_INQ_VARID(fID, TRIM(var), vID)
-  CALL NF95_INQUIRE_VARIABLE(fID, vID, ndims=n_dim)
-  IF(n_dim==2) call NF95_GET_VAR(fID,vID,v(1,:), start=[  1,irec])
-  IF(n_dim==3) call NF95_GET_VAR(fID,vID,v(:,:), start=[1,1,irec])
-
-  !--- Flip latitudes: ascending in input file, descending in "rlatu".
-  IF(n_dim==3) THEN
-    v(1,:) = v(1,nlat:1:-1)
-    v(2:,:)= SPREAD(v(1,:),DIM=1,ncopies=nlon-1)  !--- Duplication
-  ELSE
-    v(:,:) = v(:,nlat:1:-1)
-  END IF
-
-END SUBROUTINE get_2Dfield
-!
-!-------------------------------------------------------------------------------
-
-
-!-------------------------------------------------------------------------------
-!
-SUBROUTINE get_3Dfields(v)
-!
-!-------------------------------------------------------------------------------
-! Purpose: Shortcut to get the "irec"th record of the 3D fields named "nam"
-!          from the input file. Fields are stacked on fourth dimension.
-! Remark: In case the field is zonal, it is duplicated along first dimension.
-!-------------------------------------------------------------------------------
-! Arguments:
-  REAL, INTENT(INOUT) :: v(:,:,:,:)
-!-------------------------------------------------------------------------------
-  DO i=1,SIZE(nam)
-    CALL NF95_INQ_VARID(fID, TRIM(nam(i)), vID)
-    CALL NF95_INQUIRE_VARIABLE(fID, vID, ndims=n_dim)
-    IF(n_dim==3) call NF95_GET_VAR(fID,vID,v(1,:,:,i), start=[  1,1,irec])
-    IF(n_dim==4) call NF95_GET_VAR(fID,vID,v(:,:,:,i), start=[1,1,1,irec])
-  END DO
-
-  !--- Flip latitudes: ascending in input file, descending in "rlatu".
-  IF(n_dim==3) THEN
-    v(1,:,:,:) = v(1,nlat:1:-1,:,:)
-    v(2:,:,:,:)= SPREAD(v(1,:,:,:),DIM=1,ncopies=nlon-1)  !--- Duplication
-  ELSE
-    v(:,:,:,:) = v(:,nlat:1:-1,:,:)
-  END IF
-
-END SUBROUTINE get_3Dfields
-!
-!-------------------------------------------------------------------------------
-
-
-
-!-------------------------------------------------------------------------------
-!
-FUNCTION get_SigTrop(ih,it) RESULT(out)
-!
-!-------------------------------------------------------------------------------
-! Arguments:
-  REAL                 :: out
-  INTEGER, INTENT(IN)  :: ih
-  INTEGER, INTENT(OUT) :: it
-!-------------------------------------------------------------------------------
-  !--- Pressure at tropopause read from the forcing file
-       IF(lPrTfile) THEN; out=Ptrp_in(ih)/Pgnd_in(ih); RETURN; END IF
-
-  !--- Chemical tropopause definition based on a particular threshold
-       IF(lO3Tfile) THEN; out=PTrop_chem(ih,it,itrp0,Pre_in,v2(:,:,1),Otrp_in(ih))
-  ELSE IF(lO3Tpara) THEN; out=PTrop_chem(ih,it,itrp0,Pre_in,v2(:,:,1))
-  ELSE                  ; out=PTrop_chem(ih,it,itrp0,Pre_in,v2(:,:,1),o3t0); END IF
-  out=out/Pgnd_in(ih)
-
-END FUNCTION get_SigTrop
-!
-!-------------------------------------------------------------------------------
-
-
-!-------------------------------------------------------------------------------
-!
-FUNCTION PTrop_chem(ih,it,it0,pres,o3,o3trop) RESULT(out)
-!
-!-------------------------------------------------------------------------------
-! Purpose: Determine the tropopause using chemical criterium, ie the pressure
-!          at which the ozone concentration reaches a certain level.
-!-------------------------------------------------------------------------------
-! Remarks:
-! * Input field is upside down (increasing pressure // increasing vertical idx)
-!   The sweep is done from top to ground, starting at the 50hPa layer (idx it0),
-!   where O3 is about 1,5 ppmV, until the first layer where o3<o3t is reached:
-!   the O3 profile in this zone is decreasing with pressure.
-! * Threshold o3t can be given as an input argument ("o3trop", in ppmV) or
-!   determined using an empirical law roughly derived from ... & al.
-!-------------------------------------------------------------------------------
-! Arguments:
-  REAL                        :: out           !--- Pressure at tropopause
-  INTEGER,        INTENT(IN)  :: ih            !--- Horizontal index
-  INTEGER,        INTENT(OUT) :: it            !--- Index of tropopause layer
-  INTEGER,        INTENT(IN)  :: it0           !--- Idx: higher than tropopause
-  REAL,           INTENT(IN)  :: pres(:)       !--- Pressure profile, increasing
-  REAL,           INTENT(IN)  :: o3(:,:)       !--- Ozone field (pptV)
-  REAL, OPTIONAL, INTENT(IN)  :: o3trop        !--- Ozone at tropopause
-!-------------------------------------------------------------------------------
-! Local variables:
-  REAL :: o3t                                  !--- Ozone concent. at tropopause
-  REAL :: al                                   !--- Interpolation coefficient
-  REAL :: coef                                 !--- Coeff of latitude modulation
-  REAL, PARAMETER :: co3(3)=[91.,28.,20.]      !--- Coeff for o3 at tropopause
-!-------------------------------------------------------------------------------
-  !--- DETERMINE THE OZONE CONCENTRATION AT TROPOPAUSE IN THE CURRENT COLUMN
-  IF(PRESENT(o3trop)) THEN                     !=== THRESHOLD FROM ARGUMENTS
-    o3t=o3trop
-  ELSE                                         !=== EMPIRICAL LAW
-    coef = TANH(lat_in(ih)/co3(3))             !--- Latitude  modulation
-    coef = SIN (2.*RPI*(y_frac-1./6.)) * coef  !--- Seasonal  modulation
-    o3t  = 1.E-9 * (co3(1)+co3(2)*coef)        !--- Value from parametrization
-  END IF
-
-  !--- FROM 50hPa, GO DOWN UNTIL "it" IS SUCH THAT o3(ih,it)>o3t>o3(ih,it+1)
-  it=it0; DO WHILE(o3(ih,it+1)>=o3t); it=it+1; END DO
-  al=(o3(ih,it)-o3t)/(o3(ih,it)-o3(ih,it+1))
-  IF(Ploc=='C') out =      pres(it)**(1.-al) * pres(it+1)**al
-  IF(Ploc=='I') out = SQRT(pres(it)**(1.-al) * pres(it+2)**al *pres(it+1))
-  it = locate(pres(:), out)                    !--- pres(it)<Ptrop<pres(it+1)
-
-END FUNCTION PTrop_chem
-!
-!-------------------------------------------------------------------------------
-
-
-!-------------------------------------------------------------------------------
-!
-FUNCTION check_ozone(o3col, lon, lat, ilev0, layer, vmin, vmax) RESULT(out)
-!
-!-------------------------------------------------------------------------------
-  IMPLICIT NONE
-!-------------------------------------------------------------------------------
-! Arguments:
-  LOGICAL                      :: out          !--- .T. => some wrong values
-  REAL,             INTENT(IN) :: o3col(:), lon, lat
-  INTEGER,          INTENT(IN) :: ilev0
-  CHARACTER(LEN=*), INTENT(IN) :: layer
-  REAL, OPTIONAL,   INTENT(IN) :: vmin
-  REAL, OPTIONAL,   INTENT(IN) :: vmax
-!-------------------------------------------------------------------------------
-! Local variables:
-  INTEGER :: k
-  LOGICAL :: lmin, lmax
-  REAL    :: fac
-  CHARACTER(LEN=6) :: unt
-!-------------------------------------------------------------------------------
-  !--- NOTHING TO DO
-  lmin=.FALSE.; IF(PRESENT(vmin)) lmin=COUNT(o3col<vmin)/=0
-  lmax=.FALSE.; IF(PRESENT(vmax)) lmax=COUNT(o3col>vmax)/=0
-  out=lmin.OR.lmax; IF(.NOT.out.OR.prt_level>100) RETURN
-
-  !--- SOME TOO LOW VALUES FOUND
-  IF(lmin) THEN
-    CALL unitc(vmin,unt,fac)
-    DO k=1,SIZE(o3col); IF(o3col(k)>vmin) CYCLE
-      WRITE(*,'(a,2f7.1,i3,a,2(f8.3,a))')'WARNING: inconsistent value in '     &
-        //TRIM(layer)//': O3(',lon,lat,k+ilev0-1,')=',fac*o3col(k),unt//' < ', &
-        fac*vmin,unt//' in '//TRIM(layer)
-    END DO
-  END IF
-
-  !--- SOME TOO HIGH VALUES FOUND
-  IF(lmax) THEN
-    CALL unitc(vmax,unt,fac)
-    DO k=1,SIZE(o3col); IF(o3col(k)<vmax) CYCLE
-      WRITE(*,'(a,2f7.1,i3,a,2(f8.3,a))')'WARNING: inconsistent value in '     &
-        //TRIM(layer)//': O3(',lon,lat,k+ilev0-1,')=',fac*o3col(k),unt//' > ', &
-        fac*vmax,unt//' in '//TRIM(layer)
-    END DO
-  END IF
-
-END FUNCTION check_ozone
-!
-!-------------------------------------------------------------------------------
-
-
-!-------------------------------------------------------------------------------
-!
-SUBROUTINE unitc(val,unt,fac)
-!
-!-------------------------------------------------------------------------------
-  IMPLICIT NONE
-!-------------------------------------------------------------------------------
-! Arguments:
-  REAL,             INTENT(IN)  :: val
-  CHARACTER(LEN=6), INTENT(OUT) :: unt
-  REAL,             INTENT(OUT) :: fac
-!-------------------------------------------------------------------------------
-! Local variables:
-  INTEGER :: ndgt
-!-------------------------------------------------------------------------------
-  ndgt=3*FLOOR(LOG10(val)/3.)
-  SELECT CASE(ndgt)
-    CASE(-6);     unt=' ppmV '; fac=1.E6
-    CASE(-9);     unt=' ppbV '; fac=1.E9
-    CASE DEFAULT; unt=' vmr  '; fac=1.0
-  END SELECT
-
-END SUBROUTINE unitc
-!
-!-------------------------------------------------------------------------------
-
-
-!-------------------------------------------------------------------------------
-!
-SUBROUTINE msg(ll,str,sub)
-!
-!-------------------------------------------------------------------------------
-  USE print_control_mod, ONLY: lunout
-  IMPLICIT NONE
-!-------------------------------------------------------------------------------
-! Arguments:
-  LOGICAL,                    INTENT(IN) :: ll
-  CHARACTER(LEN=*),           INTENT(IN) :: str
-  CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: sub
-!-------------------------------------------------------------------------------
-  IF(.NOT.ll) RETURN
-  IF(PRESENT(sub)) THEN
-    WRITE(lunout,*)TRIM(sub)//': '//TRIM(str)
-  ELSE
-    WRITE(lunout,*)TRIM(str)
-  END IF
-
-END SUBROUTINE msg
-!
-!-------------------------------------------------------------------------------
-
-END SUBROUTINE regr_pr_time_av
-!
-!-------------------------------------------------------------------------------
-
-END MODULE regr_pr_time_av_m
Index: /LMDZ6/trunk/libf/phylmd/regr_pr_time_av_m.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/regr_pr_time_av_m.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/regr_pr_time_av_m.f90	(revision 5268)
@@ -0,0 +1,715 @@
+! $Id$
+MODULE regr_pr_time_av_m
+
+  USE write_field_phy
+  USE mod_phys_lmdz_transfert_para, ONLY: bcast
+  USE mod_phys_lmdz_para, ONLY: mpi_rank, omp_rank
+  USE print_control_mod,  ONLY: prt_level
+  IMPLICIT NONE
+
+!-------------------------------------------------------------------------------
+! Purpose: Regrid pressure with an averaging method. Operations done:
+!  * on the root process: read a NetCDF 3D or 4D field at a given day.
+!  * pack the fields to the LMDZ "horizontal "physics" grid and scatter
+!    to all threads of all processes;
+!  * in all the threads of all the processes, regrid the fields in pressure
+!    to the LMDZ vertical grid.
+!  * the forcing fields are stretched if the following arguments are present:
+!     - "lat_in":  input file latitudes.
+!     - "Ptrp_ou": target grid (LMDZ) tropopause pressure.
+!   so that the tropopause is shifted to the position of the one of LMDZ.
+!  Note that the ozone quantity conservation is not ensured.
+!-------------------------------------------------------------------------------
+! Initial routine: regr_pr_av_m module (L. Guez).
+! Present version: David Cugnet ; corresponding additions:
+!    - time interpolation
+!    - 3D compliant
+!    - vertical stretching of the field to allow tropopause matching between
+!    input field and current lmdz field.
+!-------------------------------------------------------------------------------
+! Remarks:
+!  * 3D fields are zonal means, with dimensions (latitude, pressure, julian day)
+!  * 4D fields have the dimensions:  (longitude, latitude, pressure, julian day)
+!  * All the fields are already on the horizontal grid (rlatu) or (rlatu,rlonv),
+!    except that the latitudes are in ascending order in the input file.
+!  * We assume that all the input fields have the same coordinates.
+!  * The target vertical LMDZ grid is the grid of layer centers.
+!  * Regridding in pressure can be:
+!    - Ploc=='I': pressures provided at Interfaces    => conservative 2nd order
+!         OK for ozone coefficients regridding in Cariolle routines.
+!    - Ploc=='C': pressures provides at cells Centers => classical linear       
+!         OK for ozone vertical regridding, especially when torpopause
+!      adjustment is activated, to avoid "strairs shape effect" on profiles.
+!  * All the fields are regridded as a single multi-dimensional array, so it
+!    saves CPU time to call this procedure once for several NetCDF variables
+!    rather than several times, each time for a single NetCDF variable.
+!  * The input file pressure at tropopause can be (in decreasing priority):
+!    1) read from the file if "tropopause_air_pressure" field is available.
+!    2) computed using "tro3" and "tro3_at_tropopause' (if available).
+!    3) computed using "tro3" and a fixed threshold otherwise, constant or
+!    determined using an empirical three parameters law:
+!         o3t(ppbV)=co1+co2*SIN(PI*(month-2)/6)*TANH(lat_deg/co3)
+!       => co1 and co2 are in ppbV, and co3 in degrees.
+!       => co3 allow a smooth transition between north and south hemispheres.
+!  * If available, the field "ps" (input file pressure at surface) is used.
+!    If not, the current LMDZ ground pressure is taken instead.
+!  * Fields with suffix "m"/"p" are at the closest records earlier/later than
+!  the mid-julian day "julien", on the global "dynamics" horizontal grid.
+!  * Fields(i,j,k,l) are at longitude-latitude-name "rlonv(i)-rlatu(j)-nam(l)",
+!    pressure level/interval (Ploc=="C"/"I") "pcen_in(k)"/"pcen_in(k:k+1)]".
+!  * In the 2D file case, the values are the same for all longitudes.
+!  * The tropopause correction works like this: the input fields (file) are
+!  interpolated on output (LMDZ) pressure field, which is streched using a power
+!  law in a limited zone made of 2 layers:
+!    1) between lower bound (lower than lowest tropopause) and LMDZ tropopause
+!    2) between LMDZ tropopause and upper bound (higher thzn highest tropopause)
+!  The stretching function has the following form:
+!        Sigma_str = Sigma^(1+alpha*phi(Sigma)), where:
+!   * alpha=LOG(SigT_in/SigT_ou)/LOG(SigT_ou)
+!     This value shifts the file tropopause to the height of the one of LMDZ.
+!   * phi is quasi-linear (sections of 1/log function) in the adjacent intervals:
+!       - from 0 to 1 in [Sig_top,SigT_ou]
+!       - from 1 to 0 in [SigT_ou,Sig_bot]
+!  This quasi-triangular localization function ponderates alpha-law from one near
+!  the tropopause to zero each side apart.
+!
+! * The following fields are on the global "dynamics" grid, as read from files:
+  REAL,    SAVE, ALLOCATABLE :: v1 (:,:,:,:)       !--- Current  time ozone fields
+! v1: Field read/interpol at time "julien" on the global "dynamics" horiz. grid.
+  REAL,    SAVE, ALLOCATABLE :: v1m(:,:,:,:)       !--- Previous time ozone fields
+  REAL,    SAVE, ALLOCATABLE :: v1p(:,:,:,:)       !--- Next     time ozone fields
+  REAL,    SAVE, ALLOCATABLE :: pgm(:,:), pgp(:,:) !--- Ground     pressure
+  REAL,    SAVE, ALLOCATABLE :: ptm(:,:), ptp(:,:) !--- Tropopause pressure
+  REAL,    SAVE, ALLOCATABLE :: otm(:,:), otp(:,:) !--- Tropopause o3 mix. ratio
+  INTEGER, SAVE :: ntim_in                         !--- Records nb in input file
+  INTEGER, SAVE :: itrp0                           !--- idx above chem tropop.
+  INTEGER, SAVE :: irec                            !--- Current time index
+!      * for daily   input files: current julian day number
+!      * for monthly input files: julien is in [time_in(irec),time_in(irec+1)]
+  LOGICAL, SAVE :: linterp                         !--- Interpolation in time
+  LOGICAL, SAVE :: lPrSfile                        !--- Surface pressure flag
+  LOGICAL, SAVE :: lPrTfile                        !--- Tropopause pressure flag
+  LOGICAL, SAVE :: lO3Tfile                        !--- Tropopause ozone flag
+  LOGICAL, SAVE :: lfirst=.TRUE.                   !--- First call flag
+!$OMP THREADPRIVATE(lfirst)
+  REAL,    PARAMETER :: pTropUp=9.E+3 !--- Value  <  tropopause pressure (Pa)
+  REAL,    PARAMETER :: gamm   =0.4   !--- Max. stretched layer sigma ratio
+  REAL,    PARAMETER :: rho    =1.4   !--- Max tropopauses sigma ratio
+  REAL,    PARAMETER :: o3t0   =1.E-7 !--- Nominal O3 vmr at tropopause
+  LOGICAL, PARAMETER :: lO3Tpara=.FALSE. !--- Parametrized O3 vmr at tropopause
+  LOGICAL, PARAMETER :: ldebug=.FALSE.!--- Force writefield_phy multiple outputs
+  REAL, PARAMETER :: ChemPTrMin=9.E+3 !--- Thresholds for minimum and maximum
+  REAL, PARAMETER :: ChemPTrMax=4.E+4 !    chemical  tropopause pressure (Pa).
+  REAL, PARAMETER :: DynPTrMin =8.E+3 !--- Thresholds for minimum and maximum
+  REAL, PARAMETER :: DynPTrMax =4.E+4 !    dynamical tropopause pressure (Pa).
+
+CONTAINS
+
+!-------------------------------------------------------------------------------
+!
+SUBROUTINE regr_pr_time_av(fID, nam, julien, Ploc, Pre_in, Pre_ou, v3, Pgnd_ou,&
+                                             time_in, lon_in, lat_in, Ptrp_ou)
+!
+!-------------------------------------------------------------------------------
+  USE dimphy,         ONLY: klon
+  USE netcdf95,       ONLY: NF95_INQ_VARID, NF95_INQUIRE_VARIABLE, &
+                            NF95_INQ_DIMID, NF95_INQUIRE_DIMENSION, nf95_get_var
+  USE netcdf,         ONLY: NF90_INQ_VARID, NF90_NOERR
+  USE assert_m,       ONLY: assert
+  USE assert_eq_m,    ONLY: assert_eq
+!!  USE comvert_mod,    ONLY: scaleheight
+  USE interpolation,  ONLY: locate
+  USE regr_conserv_m, ONLY: regr_conserv
+  USE regr_lint_m,    ONLY: regr_lint
+  USE slopes_m,       ONLY: slopes
+  USE mod_phys_lmdz_para,           ONLY: is_mpi_root,is_master
+  USE mod_grid_phy_lmdz,            ONLY: nlon=>nbp_lon, nlat=>nbp_lat, nlev_ou=>nbp_lev, klon_glo, grid_type, unstructured
+  USE mod_phys_lmdz_transfert_para, ONLY: scatter2d, scatter, gather
+  USE phys_cal_mod,                 ONLY: calend, year_len, days_elapsed, jH_cur
+  USE geometry_mod,                 ONLY: ind_cell_glo
+!-------------------------------------------------------------------------------
+! Arguments:
+  INTEGER,           INTENT(IN) :: fID        !--- NetCDF file ID
+  CHARACTER(LEN=13), INTENT(IN) :: nam(:)     !--- NetCDF variables names
+  REAL,              INTENT(IN) :: julien     !--- Days since Jan 1st
+  CHARACTER(LEN=1),  INTENT(IN) :: Ploc       !--- Pressures locations
+  !--- File/LMDZ (resp. decreasing & increasing order) pressure, Pa
+  !    At cells centers or interfaces depending on "Ploc" keyword (C/I)
+  REAL,    INTENT(IN)  :: Pre_in(:)           !--- in:  file      (nlev_in[+1])
+  REAL,    INTENT(IN)  :: Pre_ou(:,:)         !--- out: LMDZ (klon,nlev_ou[+1])
+  REAL,    INTENT(OUT) :: v3(:,:,:)           !--- Regr. fld (klon,nlev_ou,n_var)
+  REAL,    INTENT(IN), OPTIONAL :: Pgnd_ou(:) !--- LMDZ ground pressure   (klon)
+  REAL,    INTENT(IN), OPTIONAL :: time_in(:) !--- Records times, in days
+                                              !    since Jan 1 of current year
+  REAL,    INTENT(IN), OPTIONAL :: lon_in(:)  !--- File longitudes vector (klon)
+  REAL,    INTENT(IN), OPTIONAL :: lat_in(:)  !--- File latitudes  vector (klon)
+  REAL,    INTENT(IN), OPTIONAL :: Ptrp_ou(:) !--- LMDZ tropopause pres   (klon)
+!-------------------------------------------------------------------------------
+! Local variables:
+  include "clesphys.h"
+  include "YOMCST.h"
+  CHARACTER(LEN=80)  :: sub
+  CHARACTER(LEN=320) :: str
+  INTEGER :: vID, ncerr, n_var, ibot, iout, nn
+  INTEGER :: i, nlev_in, n_dim, itop, itrp, i0
+  LOGICAL :: lAdjTro                          !--- Need to adjust tropopause
+  REAL    :: y_frac                           !--- Elapsed year fraction
+  REAL    :: alpha, beta, al                  !--- For stretching/interpolation
+  REAL    :: SigT_in, SigT_ou                 !--- Input and output tropopauses
+  REAL    :: Sig_bot, Sig_top                 !--- Bounds of quasi-hat function
+  REAL    :: Sig_bo0, Sig_to0                 !--- Lower/upper tropopauses
+  REAL    :: Sig_in (SIZE(Pre_in))            !--- Input field sigma levels
+  REAL    :: Sig_ou (SIZE(Pre_ou,2))          !--- Output LMDZ sigma levels
+  REAL    :: phi    (SIZE(Pre_ou,2))          !--- Stretching exponent anomaly
+  REAL    :: Pstr_ou(SIZE(Pre_ou,2))          !--- Stretched pressure levels
+  REAL    :: Pres_ou(SIZE(Pre_ou,2))          !--- Pre_ou(i,:), reversed order
+  REAL, DIMENSION(nlon, nlat) :: pg1,      pt1,      ot1
+  REAL, DIMENSION(klon)       :: Pgnd_in,  Ptrp_in,  Otrp_in
+  REAL, DIMENSION(klon)       :: Ptrop_ou, Pgrnd_ou
+! * The following fields are scattered to the partial "physics" horizontal grid.
+  REAL, POINTER :: v2(:,:,:)                  !--- Current  time ozone fields
+!     In the 2D file case, the values are the same for all longitudes.
+!     "v2(i, k, l)" is at longitude-latitude "xlon(i)-xlat(i)" and name "nam(l)"
+! Both are:          * if Ploc=='I' in pressure interval "press_in_edg(k:k+1)"
+!                    * if Ploc=='C' at pressure          "press_in_cen(k)"
+  REAL, TARGET :: &
+    v2i(klon,SIZE(Pre_in)-1,SIZE(nam)), &     !--- v2 in Ploc=='I' case
+    v2c(klon,SIZE(Pre_in)  ,SIZE(nam))        !--- v2 in Ploc=='C' case
+  INTEGER,ALLOCATABLE :: ind_cell_glo_glo(:)
+  LOGICAL :: ll
+!--- For debug
+  REAL, DIMENSION(klon)             :: Ptrop_in, Ptrop_ef
+  REAL, DIMENSION(klon)             :: dzStrain, dzStrain0
+  REAL, DIMENSION(klon,SIZE(Pre_ou,2)) :: Pstrn_ou, phii
+!-------------------------------------------------------------------------------
+  sub="regr_pr_time_av"
+  nlev_in=SIZE(Pre_in); IF(Ploc=='I') nlev_in=nlev_in-1
+  IF(Ploc=='I') THEN; v2 => v2i; ELSE; v2 => v2c; END IF
+  CALL assert(SIZE(Pre_ou,1)==klon,TRIM(sub)//" Pre_ou klon")
+  CALL assert(SIZE(v3,1)==klon,    TRIM(sub)//" v3 klon")
+  CALL assert(SIZE(v3,2)==nlev_ou, TRIM(sub)//" v3 nlev_ou")
+  IF(Ploc=='I') CALL assert(SIZE(Pre_ou,2)==nlev_ou+1,TRIM(sub)//" Pre_ou nlev_ou+1")
+  IF(Ploc=='C') CALL assert(SIZE(Pre_ou,2)==nlev_ou  ,TRIM(sub)//" Pre_ou nlev_ou")
+  n_var = assert_eq(SIZE(nam),SIZE(v3,3),TRIM(sub)//" v3 n_var")
+  IF(PRESENT(Pgnd_ou)) CALL assert(SIZE(Pgnd_ou)==klon,TRIM(sub)//" Pgnd_ou klon")
+  IF(PRESENT(lon_in))  CALL assert(SIZE(lon_in )==klon,TRIM(sub)//" lon_in klon")
+  IF(PRESENT(lat_in))  CALL assert(SIZE(lat_in )==klon,TRIM(sub)//" lat_in klon")
+  IF(PRESENT(Ptrp_ou)) CALL assert(SIZE(Ptrp_ou)==klon,TRIM(sub)//" Ptrp_ou klon")
+  lAdjTro=PRESENT(Ptrp_ou)
+  IF(lAdjTro) THEN
+    IF(.NOT.PRESENT(lat_in)) &
+      CALL abort_physic(sub, 'Missing lat_in (required if adjust_tropopause=T)', 1)
+    IF(.NOT.PRESENT(Pgnd_ou).AND.Ploc=='C') &
+      CALL abort_physic(sub, 'Missing ground Pr(required if adjust_tropopause=T)', 1)
+    IF(PRESENT(Pgnd_ou)) THEN; Pgrnd_ou=Pgnd_ou; ELSE; Pgrnd_ou=Pre_ou(:,1); END IF
+  END IF
+
+  !$OMP MASTER
+  IF(is_mpi_root) THEN
+
+    !=== CHECK WHICH FIELDS ARE AVAILABLE IN THE INPUT FILE
+    IF(lfirst) THEN
+      lPrSfile=lAdjTro.AND.NF90_INQ_VARID(fID,"ps"                     ,vID)==NF90_NOERR
+      lPrTfile=lAdjTro.AND.NF90_INQ_VARID(fID,"tropopause_air_pressure",vID)==NF90_NOERR
+      lO3Tfile=lAdjTro.AND.NF90_INQ_VARID(fID,"tro3_at_tropopause"     ,vID)==NF90_NOERR
+      CALL NF95_INQ_DIMID(fID,"time",vID)
+      CALL NF95_INQUIRE_DIMENSION(fID,vID,nclen=ntim_in)
+      linterp=PRESENT(time_in).AND.ntim_in==14
+      ALLOCATE(v1(nlon,nlat,nlev_in,n_var))
+      IF(linterp) THEN
+        ALLOCATE(v1m(nlon,nlat,nlev_in,n_var),v1p(nlon,nlat,nlev_in,n_var))
+        IF(lPrSfile) ALLOCATE(pgm(nlon,nlat),pgp(nlon,nlat))
+        IF(lPrTfile) ALLOCATE(ptm(nlon,nlat),ptp(nlon,nlat))
+        IF(lO3Tfile) ALLOCATE(otm(nlon,nlat),otp(nlon,nlat))
+      END IF
+      !--- INITIAL INDEX: LOCATE A LAYER WELL ABOVE TROPOPAUSE (50hPa)
+      IF(lAdjTro) itrp0=locate(Pre_in,pTropUp)
+      CALL msg(linterp,'Monthly O3 files => ONLINE TIME INTERPOLATION.'    ,sub)
+      CALL msg(lPrSfile,'Using GROUND PRESSURE from input O3 forcing file.',sub)
+      CALL msg(lAdjTro ,'o3 forcing file tropopause location uses:'        ,sub)
+      IF(lPrTfile)      THEN; str='    INPUT FILE PRESSURE'
+      ELSE IF(lO3Tfile) THEN; str='    INPUT FILE O3 CONCENTRATION'
+      ELSE IF(lO3Tpara) THEN; str='    PARAMETRIZED O3 concentration'
+      ELSE;                   str='    CONSTANT O3 concentration'; END IF
+      CALL msg(lAdjTro,TRIM(str)//' at tropopause')
+    END IF
+
+    !=== UPDATE (ALWAYS FOR DAILY FILES, EACH MONTH FOR MONTHLY FILES)
+    CALL update_fields()
+
+    !=== TIME INTERPOLATION FOR MONTHLY INPUT FILES
+    IF(linterp) THEN
+      WRITE(str,'(a,f12.8,2(a,f5.1))')'Interpolating O3 at julian day ',julien,&
+        ' from fields at times ',time_in(irec),' and ', time_in(irec+1)
+      CALL msg(.TRUE.,str,sub)
+      al=(time_in(irec+1)-julien)/(time_in(irec+1)-time_in(irec))
+      v1=al*v1m+(1.-al)*v1p
+      IF(lPrSfile) pg1=al*pgm+(1.-al)*pgp
+      IF(lPrTfile) pt1=al*ptm+(1.-al)*ptp
+      IF(lO3Tfile) ot1=al*otm+(1.-al)*otp
+    END IF
+  ELSE
+    IF (lfirst) ALLOCATE(v1(0,0,0,0))
+  END IF
+  !$OMP END MASTER
+  !$OMP BARRIER
+  IF(lfirst) THEN
+    lfirst=.FALSE.;       CALL bcast(lfirst)
+    IF(lAdjTro)           CALL bcast(itrp0)
+    CALL bcast(lPrSfile); CALL bcast(lPrTfile)
+    CALL bcast(lO3Tfile); CALL bcast(linterp)
+  END IF
+  
+  IF (is_master) THEN 
+    ALLOCATE(ind_cell_glo_glo(klon_glo))
+  ELSE
+    ALLOCATE(ind_cell_glo_glo(0))
+  ENDIF
+  CALL gather(ind_cell_glo,ind_cell_glo_glo)
+  IF (is_master .AND. grid_type==unstructured) v1(:,:,:,:)=v1(:,ind_cell_glo_glo(:),:,:)
+  
+  CALL scatter2d(v1,v2)
+
+  !--- No "ps" in input file => assumed to be equal to current LMDZ ground press
+  IF(lPrSfile) THEN
+    IF (is_master .AND. grid_type==unstructured) pg1(:,:)=pg1(:,ind_cell_glo_glo(:))
+    CALL scatter2d(pg1,Pgnd_in)
+  ELSE
+    Pgnd_in=Pre_ou(:,1)
+  END IF
+
+  IF(lPrTfile) THEN
+    IF (is_master .AND. grid_type==unstructured) pt1(:,:)=pt1(:,ind_cell_glo_glo(:))
+    CALL scatter2d(pt1,Ptrp_in)
+  ENDIF
+
+  IF(lO3Tfile) THEN
+    IF (is_master .AND. grid_type==unstructured) ot1(:,:)=ot1(:,ind_cell_glo_glo(:))
+    CALL scatter2d(ot1,Otrp_in)
+  ENDIF
+  !--- No ground pressure in input file => choose it to be the one of LMDZ
+  IF(lAdjTro.AND..NOT.lPrSfile) Pgnd_in(:)=Pgrnd_ou(:)
+
+  !--- REGRID IN PRESSURE ; 3rd index inverted because "paprs" is decreasing
+  IF(.NOT.lAdjTro) THEN
+    DO i=1,klon
+      Pres_ou=Pre_ou(i,SIZE(Pre_ou,2):1:-1)   !--- pplay & paprs are decreasing
+      IF(Ploc=='C') CALL regr_lint   (1,v2(i,:,:), LOG(Pre_in(:)),             &
+        LOG(Pres_ou(:)), v3(i,nlev_ou:1:-1,:))
+      IF(Ploc=='I') CALL regr_conserv(1,v2(i,:,:),     Pre_in(:) ,             &
+            Pres_ou(:) , v3(i,nlev_ou:1:-1,:), slopes(1,v2(i,:,:), Pre_in(:)))
+    END DO
+!-------------------------------------------------------------------------------
+  ELSE                        !--- REGRID IN PRESSURE ; TROPOPAUSE ADJUSTMENT
+!-------------------------------------------------------------------------------
+    y_frac=(REAL(days_elapsed)+jH_cur)/year_len
+
+    !--- OUTPUT SIGMA LEVELS
+    DO i=1,klon
+
+      !--- INPUT/OUTPUT (FILE/LMDZ) SIGMA LEVELS IN CURRENT COLUMN
+      Pres_ou   = Pre_ou(i,SIZE(Pre_ou,2):1:-1)!--- pplay & paprs are decreasing
+      Sig_in(:) = Pre_in (:)/Pgnd_in(i)            !--- increasing values
+      Sig_ou(:) = Pres_ou(:)/Pgnd_ou(i)            !--- increasing values
+
+      !--- INPUT (FILE) SIGMA LEVEL AT TROPOPAUSE ; extreme values are filtered
+      ! to keep tropopause pressure realistic ; high values are usually due to
+      ! ozone hole fooling the crude chemical tropopause detection algorithm.
+      SigT_in = get_SigTrop(i,itrp)
+      SigT_in=MIN(SigT_in,ChemPTrMax/Pgnd_in(i))   !--- too low  value filtered
+      SigT_in=MAX(SigT_in,ChemPTrMin/Pgnd_ou(i))   !--- too high value filtered
+
+      !--- OUTPUT (LMDZ) SIGMA LEVEL AT TROPOPAUSE ; too high variations of the
+      ! dynamical tropopause (especially in filaments) are conterbalanced with
+      ! a filter ensuring it stays within a certain distance around input (file)
+      ! tropopause, hence avoiding avoid a too thick stretched region ; a final
+      ! extra-safety filter keeps the tropopause pressure value realistic.
+      SigT_ou = Ptrp_ou(i)/Pgnd_ou(i)
+      IF(SigT_ou<SigT_in/rho) SigT_ou=SigT_in/rho  !--- too low  value w/r input
+      IF(SigT_ou>SigT_in*rho) SigT_ou=SigT_in*rho  !--- too high value w/r input
+      SigT_ou=MIN(SigT_ou,DynPTrMax/Pgnd_ou(i))    !--- too low  value filtered
+      SigT_ou=MAX(SigT_ou,DynPTrMin/Pgnd_ou(i))    !--- too high value filtered
+      Ptrop_ou(i)=SigT_ou*Pgnd_ou(i)
+      iout = locate(Sig_ou(:),SigT_ou)
+
+      !--- POWER LAW COEFFICIENT FOR TROPOPAUSES MATCHING
+      alpha = LOG(SigT_in/SigT_ou)/LOG(SigT_ou)
+
+      !--- DETERMINE STRETCHING DOMAIN UPPER AND LOWER BOUNDS
+      Sig_bo0 = MAX(SigT_in,SigT_ou)               !--- lowest  tropopause
+      Sig_to0 = MIN(SigT_in,SigT_ou)               !--- highest tropopause
+      beta    = (Sig_bo0/Sig_to0)**gamm            !--- stretching exponent
+      Sig_bot = MIN(Sig_bo0*beta,0.1*(9.+Sig_bo0)) !--- must be <1
+      ibot = locate(Sig_ou(:),Sig_bot)             !--- layer index
+      IF(ibot-iout<2) THEN                         !--- at least one layer thick
+        ibot=MIN(iout+2,nlev_ou); Sig_bot=Sig_ou(ibot)
+      END IF
+      Sig_top = Sig_to0/beta                       !--- upper bound
+      itop = locate(Sig_ou(:),Sig_top)             !--- layer index
+      IF(iout-itop<2) THEN                         !--- at least one layer thick
+        itop=MAX(iout-2,1); Sig_top=Sig_ou(itop)
+      END IF
+
+      !--- STRETCHING POWER LAW LOCALIZATION FUNCTION:
+      !    0 in [0,Sig_top]    0->1 in [Sig_top,SigT_ou]
+      !    0 in [Sig_bot,1]    1->0 in [SigT_ou, Sig_bot]
+      phi(:)=0.
+      phi(itop+1:iout) = (1.-LOG(Sig_top)/LOG(Sig_ou(itop+1:iout)))&
+                            *LOG(SigT_ou)/LOG(SigT_ou/Sig_top)
+      phi(iout+1:ibot) = (1.-LOG(Sig_bot)/LOG(Sig_ou(iout+1:ibot)))&
+                            *LOG(SigT_ou)/LOG(SigT_ou/Sig_bot)
+
+      !--- LOCALY STRECHED OUTPUT (LMDZ) PRESSURE PROFILES (INCREASING ORDER)
+      Pstr_ou(:) = Pres_ou(:) * Sig_ou(:)**(alpha*phi(:))
+
+      !--- REGRID INPUT PROFILE ON STRAINED VERTICAL OUTPUT LEVELS
+      IF(Ploc=='C') CALL regr_lint   (1, v2(i,:,:), LOG(Pre_in(:)),            &
+        LOG(Pstr_ou(:)), v3(i,nlev_ou:1:-1,:))
+      IF(Ploc=='I') CALL regr_conserv(1, v2(i,:,:),     Pre_in(:) ,            &
+            Pstr_ou(:) , v3(i,nlev_ou:1:-1,:), slopes(1,v2(i,:,:), Pre_in(:)))
+
+      !--- CHECK CONCENTRATIONS. strato: 50ppbV-15ppmV ; tropo: 5ppbV-300ppbV.
+      i0=nlev_ou-locate(Pres_ou(:),Ptrop_ou(i))+1
+      ll=check_ozone(v3(i, 1:i0-1   ,1),lon_in(i),lat_in(i),1 ,'troposphere',  &
+                     5.E-9,3.0E-7)
+!     IF(ll) CALL abort_physic(sub, 'Inconsistent O3 values in troposphere', 1)
+      ll=check_ozone(v3(i,i0:nlev_ou,1),lon_in(i),lat_in(i),i0,'stratosphere', &
+                     5.E-8,1.5E-5)
+!     IF(ll) CALL abort_physic(sub, 'Inconsistent O3 values in stratosphere', 1)
+
+      IF(ldebug) THEN
+        dzStrain0(i) = SIGN(7.*LOG(Sig_bo0/Sig_to0),SigT_in-SigT_ou)
+        dzStrain (i) = SIGN(7.*LOG(Sig_bot/Sig_top),SigT_in-SigT_ou)
+        Ptrop_in (i) = SigT_in*Pgnd_in(i)
+        Pstrn_ou(i,:)= Pstr_ou
+        phii(i,:)    = phi(:)
+        Ptrop_ef(i)  = PTrop_chem(i, itrp, locate(Pres_ou(:),PTropUp),    &
+                             Pres_ou(:), v3(:,nlev_ou:1:-1,1),o3trop=o3t0)
+      END IF
+    END DO
+  END IF
+  IF(ldebug.AND.lAdjTro) THEN
+    CALL writefield_phy('PreSt_ou' ,Pstrn_ou,SIZE(Pre_ou,2)) !--- Strained Pres
+    CALL writefield_phy('dzStrain' ,dzStrain ,1)     !--- Strained thickness
+    CALL writefield_phy('dzStrain0',dzStrain0,1)     !--- Tropopauses distance
+    CALL writefield_phy('phi',phii,nlev_ou)          !--- Localization function
+    !--- Tropopauses pressures:
+    CALL writefield_phy('PreTr_in',Ptrop_in,1)       !--- Input and effective
+    CALL writefield_phy('PreTr_ou',Ptrop_ou,1)       !--- LMDz dyn tropopause
+    CALL writefield_phy('PreTr_ef',Ptrop_ef,1)       !--- Effective chem tropop
+  END IF
+  IF(ldebug) THEN
+    CALL writefield_phy('Ozone_in',v2(:,:,1),nlev_in)!--- Raw input O3 field
+    CALL writefield_phy('Ozone_ou',v3(:,:,1),nlev_ou)!--- Output ozone field
+    CALL writefield_phy('Pres_ou' ,Pre_ou,SIZE(Pre_ou,2))!--- LMDZ Pressure
+  END IF
+
+CONTAINS
+
+
+!-------------------------------------------------------------------------------
+!
+SUBROUTINE update_fields()
+!
+!-------------------------------------------------------------------------------
+  IF(.NOT.linterp) THEN                 !=== DAILY FILES: NO TIME INTERPOLATION
+    CALL msg(.TRUE.,sub,'Updating Ozone forcing field: read from file.')
+    irec=MIN(INT(julien)+1,ntim_in)     !--- irec is just the julian day number
+    !--- MIN -> Security in the unlikely case of roundup errors.
+    CALL get_3Dfields(v1)               !--- Read ozone field(s)
+    IF(lAdjTro) THEN                    !--- Additional files for fields strain
+      IF(lPrSfile) CALL get_2Dfield(pg1,"ps")
+      IF(lPrTfile) CALL get_2Dfield(pt1,"tropopause_air_pressure")
+      IF(lO3Tfile) CALL get_2Dfield(ot1,"tro3_at_tropopause")
+    END IF
+  ELSE                                  !=== MONTHLY FILES: GET 2 NEAREST RECS
+    IF(lfirst) irec=locate(time_in,julien) !--- Need to locate surrounding times
+    IF(.NOT.lfirst.AND.julien<time_in(irec+1)) RETURN
+    CALL msg(.TRUE.,'Refreshing adjacent Ozone forcing fields.',sub)
+    IF(lfirst) THEN                     !=== READ EARLIEST TIME FIELDS
+      WRITE(str,'(a,i3,a,f12.8,a)')'Previous available field update (step 1): '&
+      //'reading record ',irec,' (time ',time_in(irec),')'
+      CALL msg(.TRUE.,str,sub)
+      CALL get_3Dfields(v1m)            !--- Read ozone field(s)
+      IF(lAdjTro) THEN                  !--- Additional files for fields strain
+        IF(lPrSfile) CALL get_2Dfield(pgm,"ps")
+        IF(lPrTfile) CALL get_2Dfield(ptm,"tropopause_air_pressure")
+        IF(lO3Tfile) CALL get_2Dfield(otm,"tro3_at_tropopause")
+      END IF
+    ELSE                                !=== SHIFT FIELDS
+      irec=irec+1
+      WRITE(str,'(a,i3,a,f12.8,a)')'Previous available field update: shifting'&
+      //' current next one (',irec,', time ',time_in(irec),')'
+      CALL msg(.TRUE.,str,sub)
+      v1m=v1p                           !--- Ozone fields
+      IF(lAdjTro) THEN                  !--- Additional files for fields strain
+        IF(lPrSfile) pgm=pgp             !--- Surface pressure
+        IF(lPrTfile) ptm=ptp             !--- Tropopause pressure
+        IF(lO3Tfile) otm=otp             !--- Tropopause ozone
+      END IF
+    END IF
+    irec=irec+1
+    WRITE(str,'(a,i3,a,f12.8,a)')'Next available field update: reading record'&
+    ,irec,' (time ',time_in(irec),')'
+    CALL msg(.TRUE.,str,sub)
+    CALL get_3Dfields(v1p)              !--- Read ozone field(s)
+    IF(lAdjTro) THEN                    !--- Additional files for fields strain
+      IF(lPrSfile) CALL get_2Dfield(pgp,"ps")
+      IF(lPrTfile) CALL get_2Dfield(ptp,"tropopause_air_pressure")
+      IF(lO3Tfile) CALL get_2Dfield(otp,"tro3_at_tropopause")
+    END IF
+    irec=irec-1
+  END IF
+
+END SUBROUTINE update_fields
+!
+!-------------------------------------------------------------------------------
+
+
+!-------------------------------------------------------------------------------
+!
+SUBROUTINE get_2Dfield(v,var)
+!
+!-------------------------------------------------------------------------------
+! Purpose: Shortcut to get the "irec"th record of the surface field named "var"
+!          from the input file.
+! Remark: In case the field is zonal, it is duplicated along first dimension.
+!-------------------------------------------------------------------------------
+! Arguments:
+  REAL,             INTENT(INOUT) :: v(:,:)
+  CHARACTER(LEN=*), INTENT(IN)    :: var
+!-------------------------------------------------------------------------------
+  CALL NF95_INQ_VARID(fID, TRIM(var), vID)
+  CALL NF95_INQUIRE_VARIABLE(fID, vID, ndims=n_dim)
+  IF(n_dim==2) call NF95_GET_VAR(fID,vID,v(1,:), start=[  1,irec])
+  IF(n_dim==3) call NF95_GET_VAR(fID,vID,v(:,:), start=[1,1,irec])
+
+  !--- Flip latitudes: ascending in input file, descending in "rlatu".
+  IF(n_dim==3) THEN
+    v(1,:) = v(1,nlat:1:-1)
+    v(2:,:)= SPREAD(v(1,:),DIM=1,ncopies=nlon-1)  !--- Duplication
+  ELSE
+    v(:,:) = v(:,nlat:1:-1)
+  END IF
+
+END SUBROUTINE get_2Dfield
+!
+!-------------------------------------------------------------------------------
+
+
+!-------------------------------------------------------------------------------
+!
+SUBROUTINE get_3Dfields(v)
+!
+!-------------------------------------------------------------------------------
+! Purpose: Shortcut to get the "irec"th record of the 3D fields named "nam"
+!          from the input file. Fields are stacked on fourth dimension.
+! Remark: In case the field is zonal, it is duplicated along first dimension.
+!-------------------------------------------------------------------------------
+! Arguments:
+  REAL, INTENT(INOUT) :: v(:,:,:,:)
+!-------------------------------------------------------------------------------
+  DO i=1,SIZE(nam)
+    CALL NF95_INQ_VARID(fID, TRIM(nam(i)), vID)
+    CALL NF95_INQUIRE_VARIABLE(fID, vID, ndims=n_dim)
+    IF(n_dim==3) call NF95_GET_VAR(fID,vID,v(1,:,:,i), start=[  1,1,irec])
+    IF(n_dim==4) call NF95_GET_VAR(fID,vID,v(:,:,:,i), start=[1,1,1,irec])
+  END DO
+
+  !--- Flip latitudes: ascending in input file, descending in "rlatu".
+  IF(n_dim==3) THEN
+    v(1,:,:,:) = v(1,nlat:1:-1,:,:)
+    v(2:,:,:,:)= SPREAD(v(1,:,:,:),DIM=1,ncopies=nlon-1)  !--- Duplication
+  ELSE
+    v(:,:,:,:) = v(:,nlat:1:-1,:,:)
+  END IF
+
+END SUBROUTINE get_3Dfields
+!
+!-------------------------------------------------------------------------------
+
+
+
+!-------------------------------------------------------------------------------
+!
+FUNCTION get_SigTrop(ih,it) RESULT(out)
+!
+!-------------------------------------------------------------------------------
+! Arguments:
+  REAL                 :: out
+  INTEGER, INTENT(IN)  :: ih
+  INTEGER, INTENT(OUT) :: it
+!-------------------------------------------------------------------------------
+  !--- Pressure at tropopause read from the forcing file
+       IF(lPrTfile) THEN; out=Ptrp_in(ih)/Pgnd_in(ih); RETURN; END IF
+
+  !--- Chemical tropopause definition based on a particular threshold
+       IF(lO3Tfile) THEN; out=PTrop_chem(ih,it,itrp0,Pre_in,v2(:,:,1),Otrp_in(ih))
+  ELSE IF(lO3Tpara) THEN; out=PTrop_chem(ih,it,itrp0,Pre_in,v2(:,:,1))
+  ELSE                  ; out=PTrop_chem(ih,it,itrp0,Pre_in,v2(:,:,1),o3t0); END IF
+  out=out/Pgnd_in(ih)
+
+END FUNCTION get_SigTrop
+!
+!-------------------------------------------------------------------------------
+
+
+!-------------------------------------------------------------------------------
+!
+FUNCTION PTrop_chem(ih,it,it0,pres,o3,o3trop) RESULT(out)
+!
+!-------------------------------------------------------------------------------
+! Purpose: Determine the tropopause using chemical criterium, ie the pressure
+!          at which the ozone concentration reaches a certain level.
+!-------------------------------------------------------------------------------
+! Remarks:
+! * Input field is upside down (increasing pressure // increasing vertical idx)
+!   The sweep is done from top to ground, starting at the 50hPa layer (idx it0),
+!   where O3 is about 1,5 ppmV, until the first layer where o3<o3t is reached:
+!   the O3 profile in this zone is decreasing with pressure.
+! * Threshold o3t can be given as an input argument ("o3trop", in ppmV) or
+!   determined using an empirical law roughly derived from ... & al.
+!-------------------------------------------------------------------------------
+! Arguments:
+  REAL                        :: out           !--- Pressure at tropopause
+  INTEGER,        INTENT(IN)  :: ih            !--- Horizontal index
+  INTEGER,        INTENT(OUT) :: it            !--- Index of tropopause layer
+  INTEGER,        INTENT(IN)  :: it0           !--- Idx: higher than tropopause
+  REAL,           INTENT(IN)  :: pres(:)       !--- Pressure profile, increasing
+  REAL,           INTENT(IN)  :: o3(:,:)       !--- Ozone field (pptV)
+  REAL, OPTIONAL, INTENT(IN)  :: o3trop        !--- Ozone at tropopause
+!-------------------------------------------------------------------------------
+! Local variables:
+  REAL :: o3t                                  !--- Ozone concent. at tropopause
+  REAL :: al                                   !--- Interpolation coefficient
+  REAL :: coef                                 !--- Coeff of latitude modulation
+  REAL, PARAMETER :: co3(3)=[91.,28.,20.]      !--- Coeff for o3 at tropopause
+!-------------------------------------------------------------------------------
+  !--- DETERMINE THE OZONE CONCENTRATION AT TROPOPAUSE IN THE CURRENT COLUMN
+  IF(PRESENT(o3trop)) THEN                     !=== THRESHOLD FROM ARGUMENTS
+    o3t=o3trop
+  ELSE                                         !=== EMPIRICAL LAW
+    coef = TANH(lat_in(ih)/co3(3))             !--- Latitude  modulation
+    coef = SIN (2.*RPI*(y_frac-1./6.)) * coef  !--- Seasonal  modulation
+    o3t  = 1.E-9 * (co3(1)+co3(2)*coef)        !--- Value from parametrization
+  END IF
+
+  !--- FROM 50hPa, GO DOWN UNTIL "it" IS SUCH THAT o3(ih,it)>o3t>o3(ih,it+1)
+  it=it0; DO WHILE(o3(ih,it+1)>=o3t); it=it+1; END DO
+  al=(o3(ih,it)-o3t)/(o3(ih,it)-o3(ih,it+1))
+  IF(Ploc=='C') out =      pres(it)**(1.-al) * pres(it+1)**al
+  IF(Ploc=='I') out = SQRT(pres(it)**(1.-al) * pres(it+2)**al *pres(it+1))
+  it = locate(pres(:), out)                    !--- pres(it)<Ptrop<pres(it+1)
+
+END FUNCTION PTrop_chem
+!
+!-------------------------------------------------------------------------------
+
+
+!-------------------------------------------------------------------------------
+!
+FUNCTION check_ozone(o3col, lon, lat, ilev0, layer, vmin, vmax) RESULT(out)
+!
+!-------------------------------------------------------------------------------
+  IMPLICIT NONE
+!-------------------------------------------------------------------------------
+! Arguments:
+  LOGICAL                      :: out          !--- .T. => some wrong values
+  REAL,             INTENT(IN) :: o3col(:), lon, lat
+  INTEGER,          INTENT(IN) :: ilev0
+  CHARACTER(LEN=*), INTENT(IN) :: layer
+  REAL, OPTIONAL,   INTENT(IN) :: vmin
+  REAL, OPTIONAL,   INTENT(IN) :: vmax
+!-------------------------------------------------------------------------------
+! Local variables:
+  INTEGER :: k
+  LOGICAL :: lmin, lmax
+  REAL    :: fac
+  CHARACTER(LEN=6) :: unt
+!-------------------------------------------------------------------------------
+  !--- NOTHING TO DO
+  lmin=.FALSE.; IF(PRESENT(vmin)) lmin=COUNT(o3col<vmin)/=0
+  lmax=.FALSE.; IF(PRESENT(vmax)) lmax=COUNT(o3col>vmax)/=0
+  out=lmin.OR.lmax; IF(.NOT.out.OR.prt_level>100) RETURN
+
+  !--- SOME TOO LOW VALUES FOUND
+  IF(lmin) THEN
+    CALL unitc(vmin,unt,fac)
+    DO k=1,SIZE(o3col); IF(o3col(k)>vmin) CYCLE
+      WRITE(*,'(a,2f7.1,i3,a,2(f8.3,a))')'WARNING: inconsistent value in '     &
+        //TRIM(layer)//': O3(',lon,lat,k+ilev0-1,')=',fac*o3col(k),unt//' < ', &
+        fac*vmin,unt//' in '//TRIM(layer)
+    END DO
+  END IF
+
+  !--- SOME TOO HIGH VALUES FOUND
+  IF(lmax) THEN
+    CALL unitc(vmax,unt,fac)
+    DO k=1,SIZE(o3col); IF(o3col(k)<vmax) CYCLE
+      WRITE(*,'(a,2f7.1,i3,a,2(f8.3,a))')'WARNING: inconsistent value in '     &
+        //TRIM(layer)//': O3(',lon,lat,k+ilev0-1,')=',fac*o3col(k),unt//' > ', &
+        fac*vmax,unt//' in '//TRIM(layer)
+    END DO
+  END IF
+
+END FUNCTION check_ozone
+!
+!-------------------------------------------------------------------------------
+
+
+!-------------------------------------------------------------------------------
+!
+SUBROUTINE unitc(val,unt,fac)
+!
+!-------------------------------------------------------------------------------
+  IMPLICIT NONE
+!-------------------------------------------------------------------------------
+! Arguments:
+  REAL,             INTENT(IN)  :: val
+  CHARACTER(LEN=6), INTENT(OUT) :: unt
+  REAL,             INTENT(OUT) :: fac
+!-------------------------------------------------------------------------------
+! Local variables:
+  INTEGER :: ndgt
+!-------------------------------------------------------------------------------
+  ndgt=3*FLOOR(LOG10(val)/3.)
+  SELECT CASE(ndgt)
+    CASE(-6);     unt=' ppmV '; fac=1.E6
+    CASE(-9);     unt=' ppbV '; fac=1.E9
+    CASE DEFAULT; unt=' vmr  '; fac=1.0
+  END SELECT
+
+END SUBROUTINE unitc
+!
+!-------------------------------------------------------------------------------
+
+
+!-------------------------------------------------------------------------------
+!
+SUBROUTINE msg(ll,str,sub)
+!
+!-------------------------------------------------------------------------------
+  USE print_control_mod, ONLY: lunout
+  IMPLICIT NONE
+!-------------------------------------------------------------------------------
+! Arguments:
+  LOGICAL,                    INTENT(IN) :: ll
+  CHARACTER(LEN=*),           INTENT(IN) :: str
+  CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: sub
+!-------------------------------------------------------------------------------
+  IF(.NOT.ll) RETURN
+  IF(PRESENT(sub)) THEN
+    WRITE(lunout,*)TRIM(sub)//': '//TRIM(str)
+  ELSE
+    WRITE(lunout,*)TRIM(str)
+  END IF
+
+END SUBROUTINE msg
+!
+!-------------------------------------------------------------------------------
+
+END SUBROUTINE regr_pr_time_av
+!
+!-------------------------------------------------------------------------------
+
+END MODULE regr_pr_time_av_m
Index: DZ6/trunk/libf/phylmd/screenc_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/screenc_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,206 +1,0 @@
-!
-MODULE screenc_mod
-!
-! This module contains some procedures for calculation of the correction
-! of temperature, specific humidity and wind at a reference level
-!
-  USE cdrag_mod
-  IMPLICIT NONE
-
-CONTAINS
-!
-!****************************************************************************************
-!
-!r original routine svn3623
-!
-      SUBROUTINE screenc(klon, knon, nsrf, zxli, &
-                         speed, temp, q_zref, zref, &
-                         ts, qsurf, z0m, z0h, psol, &
-                         ustar, testar, qstar, okri, ri1, &
-                         pref, delu, delte, delq, s_pblh, prain, tsol, pat1)
-      IMPLICIT NONE
-!-----------------------------------------------------------------------
-! 
-! Objet : calcul "correcteur" des anomalies du vent, de la temperature 
-!         potentielle et de l'humidite relative au niveau de reference zref et 
-!         par rapport au 1er niveau (pour u) ou a la surface (pour theta et q) 
-!         a partir des equations de Louis.
-!
-! Reference : Hess, Colman et McAvaney (1995)
-!
-! I. Musat, 01.07.2002
-!-----------------------------------------------------------------------
-!
-! klon----input-I- dimension de la grille physique (= nb_pts_latitude X nb_pts_longitude)
-! knon----input-I- nombre de points pour un type de surface
-! nsrf----input-I- indice pour le type de surface; voir indice_sol_mod.F90
-! zxli----input-L- TRUE si calcul des cdrags selon Laurent Li
-! speed---input-R- module du vent au 1er niveau du modele
-! temp----input-R- temperature de l'air au 1er niveau du modele
-! q_zref--input-R- humidite relative au 1er niveau du modele
-! zref----input-R- altitude de reference
-! ts------input-R- temperature de l'air a la surface
-! qsurf---input-R- humidite relative a la surface
-! z0m, z0h---input-R- rugosite
-! psol----input-R- pression au sol
-! ustar---input-R- facteur d'echelle pour le vent
-! testar--input-R- facteur d'echelle pour la temperature potentielle
-! qstar---input-R- facteur d'echelle pour l'humidite relative
-! okri----input-L- TRUE si on veut tester le nb. Richardson entre la sfce 
-!                  et zref par rapport au Ri entre la sfce et la 1ere couche
-! ri1-----input-R- nb. Richardson entre la surface et la 1ere couche 
-!
-! pref----input-R- pression au niveau de reference
-! delu----input-R- anomalie du vent par rapport au 1er niveau
-! delte---input-R- anomalie de la temperature potentielle par rapport a la surface
-! delq----input-R- anomalie de l'humidite relative par rapport a la surface
-!
-      INTEGER, intent(in) :: klon, knon, nsrf
-      LOGICAL, intent(in) :: zxli, okri 
-      REAL, dimension(klon), intent(in) :: speed, temp, q_zref
-      REAL, intent(in) :: zref
-      REAL, dimension(klon), intent(IN) :: ts
-      REAL, dimension(klon), intent(in) :: qsurf, psol
-      REAL, dimension(klon), intent(inout):: z0m, z0h
-      REAL, dimension(klon), intent(in) :: ustar, testar, qstar, ri1   
-
-      REAL, dimension(klon), intent(inout) :: s_pblh    
-      REAL, dimension(klon), intent(in) :: prain    
-      REAL, dimension(klon), intent(in) :: tsol    
-      REAL, DIMENSION(klon), INTENT(IN)    :: pat1 !pression premier lev      
-!
-      REAL, dimension(klon), intent(out) :: pref, delu, delte, delq 
-!-----------------------------------------------------------------------
-      include "YOMCST.h"
-      include "flux_arp.h"
-!
-! Variables locales  
-      INTEGER :: i 
-      REAL, dimension(klon) :: cdram, cdrah, cdran, zri1, gref,ycdragm,zri_zero
-!
-!------------------------------------------------------------------------- 
-      DO i=1, knon
-        gref(i) = zref*RG
-      ENDDO 
-!
-! Richardson at reference level 
-!
-!      CALL coefcdrag (klon, knon, nsrf, zxli, &
-!                    speed, temp, q_zref, gref, &
-!                    psol, ts, qsurf, rugos, &
-!                    okri, ri1, &
-!                    cdram, cdrah, cdran, zri1, &
-!                    pref)
-! Fuxing WANG, 04/03/2015, replace the coefcdrag by the merged version: cdrag
-      CALL cdrag (knon, nsrf, &
-                    speed, temp, q_zref, gref, &
-                    psol, s_pblh, ts, qsurf, z0m, z0h, &
-                    zri_zero,0,                &
-                    cdram, cdrah, zri1, pref, prain, tsol, pat1)
-      DO i = 1, knon
-        IF(ok_prescr_ust) THEN
-! La aussi il faut forcer avec ust (FC + MPL 20160210)
-        ycdragm(i) = ust*ust/(1.+speed(i))/speed(i)
-        cdram=ycdragm
-        delu(i) = ust/sqrt(cdram(i))
-        ELSE
-        delu(i) = ustar(i)/sqrt(cdram(i))
-        ENDIF
-        delte(i)= (testar(i)* sqrt(cdram(i)))/ &
-                   cdrah(i)
-        delq(i)= (qstar(i)* sqrt(cdram(i)))/ &
-                  cdrah(i)
-      ENDDO 
-!
-      RETURN 
-      END SUBROUTINE screenc
-!
-      SUBROUTINE screencn(klon, knon, nsrf, zxli, &
-                         speed, temp, q_zref, zref, &
-                         ts, qsurf, z0m, z0h, psol, &
-                         cdrm, cdrh,  okri, &
-                         ri1, iri1, &
-                         pref, delm, delh, zri1, s_pblh, prain, tsol, pat1)
-      IMPLICIT NONE
-!-----------------------------------------------------------------------
-! 
-! Objet : calcul "correcteur" des anomalies du vent, de la temperature 
-!         potentielle et de l'humidite relative au niveau de reference zref et 
-!         par rapport au 1er niveau (pour u) ou a la surface (pour theta et q) 
-!         a partir des equations de Louis.
-!
-! Reference : Hess, Colman et McAvaney (1995)
-!
-! I. Musat, 01.07.2002
-!-----------------------------------------------------------------------
-!
-! klon----input-I- dimension de la grille physique (= nb_pts_latitude X nb_pts_longitude)
-! knon----input-I- nombre de points pour un type de surface
-! nsrf----input-I- indice pour le type de surface; voir indice_sol_mod.F90
-! zxli----input-L- TRUE si calcul des cdrags selon Laurent Li
-! speed---input-R- module du vent au 1er niveau du modele
-! temp----input-R- temperature de l'air au 1er niveau du modele
-! q_zref--input-R- humidite relative au 1er niveau du modele
-! zref----input-R- altitude de reference
-! ts------input-R- temperature de l'air a la surface
-! qsurf---input-R- humidite relative a la surface
-! z0m, z0h---input-R- rugosite
-! psol----input-R- pression au sol
-! ustar---input-R- facteur d'echelle pour le vent
-! testar--input-R- facteur d'echelle pour la temperature potentielle
-! qstar---input-R- facteur d'echelle pour l'humidite relative
-! okri----input-L- TRUE si on veut tester le nb. Richardson entre la sfce 
-!                  et zref par rapport au Ri entre la sfce et la 1ere couche
-! ri1-----input-R- nb. Richardson entre la surface et la 1ere couche 
-!
-! pref----input-R- pression au niveau de reference
-! delu----input-R- anomalie du vent par rapport au 1er niveau
-! delte---input-R- anomalie de la temperature potentielle par rapport a la surface
-! delq----input-R- anomalie de l'humidite relative par rapport a la surface
-!
-      INTEGER, intent(in) :: klon, knon, nsrf
-      LOGICAL, intent(in) :: zxli, okri 
-      REAL, dimension(klon), intent(in) :: speed, temp, q_zref
-      REAL, intent(in) :: zref
-      REAL, dimension(klon), intent(in) :: ts, qsurf, psol
-      REAL, dimension(klon), intent(inout) :: z0m, z0h
-      REAL, dimension(klon), intent(in) :: cdrm, cdrh, ri1         
-      REAL, dimension(klon), intent(inout) :: s_pblh    
-      REAL, dimension(klon), intent(in) :: prain    
-      REAL, dimension(klon), intent(in) :: tsol    
-      REAL, DIMENSION(klon), INTENT(IN) :: pat1 !pression premier lev      
-      INTEGER, INTENT(IN)  :: iri1 ! Richardson de la 1ere couche
-!
-      REAL, dimension(klon), intent(out) :: pref, delm, delh, zri1
-!171220     REAL, dimension(klon) :: cdram, cdrah, zri1 
-      REAL, dimension(klon) :: cdram, cdrah
-!-----------------------------------------------------------------------
-      include "YOMCST.h"
-      include "flux_arp.h"
-!
-! Variables locales  
-      INTEGER :: i 
-      REAL, dimension(klon) :: cdran, gref,ycdragm
-!
-!------------------------------------------------------------------------- 
-      DO i=1, knon
-        gref(i) = zref*RG
-      ENDDO 
-!
-! Richardson at reference level 
-!
-      CALL cdrag(knon, nsrf, &
-                    speed, temp, q_zref, gref, &
-                    psol, s_pblh, ts, qsurf, z0m, z0h, &
-                    ri1, iri1, &
-                    cdram, cdrah, zri1, pref, prain, tsol, pat1)
-      DO i = 1, knon
-        delm(i) = sqrt(cdrm(i))/sqrt(cdram(i))
-!verifier que temp est un temperat potentielle.
-        delh(i)= (cdrh(i)* sqrt(cdram(i)))/ &
-                   (cdrah(i)*sqrt(cdrm(i)))
-      ENDDO 
-!
-      RETURN 
-      END SUBROUTINE screencn
-END MODULE screenc_mod
Index: /LMDZ6/trunk/libf/phylmd/screenc_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/screenc_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/screenc_mod.f90	(revision 5268)
@@ -0,0 +1,206 @@
+!
+MODULE screenc_mod
+!
+! This module contains some procedures for calculation of the correction
+! of temperature, specific humidity and wind at a reference level
+!
+  USE cdrag_mod
+  IMPLICIT NONE
+
+CONTAINS
+!
+!****************************************************************************************
+!
+!r original routine svn3623
+!
+      SUBROUTINE screenc(klon, knon, nsrf, zxli, &
+                         speed, temp, q_zref, zref, &
+                         ts, qsurf, z0m, z0h, psol, &
+                         ustar, testar, qstar, okri, ri1, &
+                         pref, delu, delte, delq, s_pblh, prain, tsol, pat1)
+      IMPLICIT NONE
+!-----------------------------------------------------------------------
+! 
+! Objet : calcul "correcteur" des anomalies du vent, de la temperature 
+!         potentielle et de l'humidite relative au niveau de reference zref et 
+!         par rapport au 1er niveau (pour u) ou a la surface (pour theta et q) 
+!         a partir des equations de Louis.
+!
+! Reference : Hess, Colman et McAvaney (1995)
+!
+! I. Musat, 01.07.2002
+!-----------------------------------------------------------------------
+!
+! klon----input-I- dimension de la grille physique (= nb_pts_latitude X nb_pts_longitude)
+! knon----input-I- nombre de points pour un type de surface
+! nsrf----input-I- indice pour le type de surface; voir indice_sol_mod.F90
+! zxli----input-L- TRUE si calcul des cdrags selon Laurent Li
+! speed---input-R- module du vent au 1er niveau du modele
+! temp----input-R- temperature de l'air au 1er niveau du modele
+! q_zref--input-R- humidite relative au 1er niveau du modele
+! zref----input-R- altitude de reference
+! ts------input-R- temperature de l'air a la surface
+! qsurf---input-R- humidite relative a la surface
+! z0m, z0h---input-R- rugosite
+! psol----input-R- pression au sol
+! ustar---input-R- facteur d'echelle pour le vent
+! testar--input-R- facteur d'echelle pour la temperature potentielle
+! qstar---input-R- facteur d'echelle pour l'humidite relative
+! okri----input-L- TRUE si on veut tester le nb. Richardson entre la sfce 
+!                  et zref par rapport au Ri entre la sfce et la 1ere couche
+! ri1-----input-R- nb. Richardson entre la surface et la 1ere couche 
+!
+! pref----input-R- pression au niveau de reference
+! delu----input-R- anomalie du vent par rapport au 1er niveau
+! delte---input-R- anomalie de la temperature potentielle par rapport a la surface
+! delq----input-R- anomalie de l'humidite relative par rapport a la surface
+!
+      INTEGER, intent(in) :: klon, knon, nsrf
+      LOGICAL, intent(in) :: zxli, okri 
+      REAL, dimension(klon), intent(in) :: speed, temp, q_zref
+      REAL, intent(in) :: zref
+      REAL, dimension(klon), intent(IN) :: ts
+      REAL, dimension(klon), intent(in) :: qsurf, psol
+      REAL, dimension(klon), intent(inout):: z0m, z0h
+      REAL, dimension(klon), intent(in) :: ustar, testar, qstar, ri1   
+
+      REAL, dimension(klon), intent(inout) :: s_pblh    
+      REAL, dimension(klon), intent(in) :: prain    
+      REAL, dimension(klon), intent(in) :: tsol    
+      REAL, DIMENSION(klon), INTENT(IN)    :: pat1 !pression premier lev      
+!
+      REAL, dimension(klon), intent(out) :: pref, delu, delte, delq 
+!-----------------------------------------------------------------------
+      include "YOMCST.h"
+      include "flux_arp.h"
+!
+! Variables locales  
+      INTEGER :: i 
+      REAL, dimension(klon) :: cdram, cdrah, cdran, zri1, gref,ycdragm,zri_zero
+!
+!------------------------------------------------------------------------- 
+      DO i=1, knon
+        gref(i) = zref*RG
+      ENDDO 
+!
+! Richardson at reference level 
+!
+!      CALL coefcdrag (klon, knon, nsrf, zxli, &
+!                    speed, temp, q_zref, gref, &
+!                    psol, ts, qsurf, rugos, &
+!                    okri, ri1, &
+!                    cdram, cdrah, cdran, zri1, &
+!                    pref)
+! Fuxing WANG, 04/03/2015, replace the coefcdrag by the merged version: cdrag
+      CALL cdrag (knon, nsrf, &
+                    speed, temp, q_zref, gref, &
+                    psol, s_pblh, ts, qsurf, z0m, z0h, &
+                    zri_zero,0,                &
+                    cdram, cdrah, zri1, pref, prain, tsol, pat1)
+      DO i = 1, knon
+        IF(ok_prescr_ust) THEN
+! La aussi il faut forcer avec ust (FC + MPL 20160210)
+        ycdragm(i) = ust*ust/(1.+speed(i))/speed(i)
+        cdram=ycdragm
+        delu(i) = ust/sqrt(cdram(i))
+        ELSE
+        delu(i) = ustar(i)/sqrt(cdram(i))
+        ENDIF
+        delte(i)= (testar(i)* sqrt(cdram(i)))/ &
+                   cdrah(i)
+        delq(i)= (qstar(i)* sqrt(cdram(i)))/ &
+                  cdrah(i)
+      ENDDO 
+!
+      RETURN 
+      END SUBROUTINE screenc
+!
+      SUBROUTINE screencn(klon, knon, nsrf, zxli, &
+                         speed, temp, q_zref, zref, &
+                         ts, qsurf, z0m, z0h, psol, &
+                         cdrm, cdrh,  okri, &
+                         ri1, iri1, &
+                         pref, delm, delh, zri1, s_pblh, prain, tsol, pat1)
+      IMPLICIT NONE
+!-----------------------------------------------------------------------
+! 
+! Objet : calcul "correcteur" des anomalies du vent, de la temperature 
+!         potentielle et de l'humidite relative au niveau de reference zref et 
+!         par rapport au 1er niveau (pour u) ou a la surface (pour theta et q) 
+!         a partir des equations de Louis.
+!
+! Reference : Hess, Colman et McAvaney (1995)
+!
+! I. Musat, 01.07.2002
+!-----------------------------------------------------------------------
+!
+! klon----input-I- dimension de la grille physique (= nb_pts_latitude X nb_pts_longitude)
+! knon----input-I- nombre de points pour un type de surface
+! nsrf----input-I- indice pour le type de surface; voir indice_sol_mod.F90
+! zxli----input-L- TRUE si calcul des cdrags selon Laurent Li
+! speed---input-R- module du vent au 1er niveau du modele
+! temp----input-R- temperature de l'air au 1er niveau du modele
+! q_zref--input-R- humidite relative au 1er niveau du modele
+! zref----input-R- altitude de reference
+! ts------input-R- temperature de l'air a la surface
+! qsurf---input-R- humidite relative a la surface
+! z0m, z0h---input-R- rugosite
+! psol----input-R- pression au sol
+! ustar---input-R- facteur d'echelle pour le vent
+! testar--input-R- facteur d'echelle pour la temperature potentielle
+! qstar---input-R- facteur d'echelle pour l'humidite relative
+! okri----input-L- TRUE si on veut tester le nb. Richardson entre la sfce 
+!                  et zref par rapport au Ri entre la sfce et la 1ere couche
+! ri1-----input-R- nb. Richardson entre la surface et la 1ere couche 
+!
+! pref----input-R- pression au niveau de reference
+! delu----input-R- anomalie du vent par rapport au 1er niveau
+! delte---input-R- anomalie de la temperature potentielle par rapport a la surface
+! delq----input-R- anomalie de l'humidite relative par rapport a la surface
+!
+      INTEGER, intent(in) :: klon, knon, nsrf
+      LOGICAL, intent(in) :: zxli, okri 
+      REAL, dimension(klon), intent(in) :: speed, temp, q_zref
+      REAL, intent(in) :: zref
+      REAL, dimension(klon), intent(in) :: ts, qsurf, psol
+      REAL, dimension(klon), intent(inout) :: z0m, z0h
+      REAL, dimension(klon), intent(in) :: cdrm, cdrh, ri1         
+      REAL, dimension(klon), intent(inout) :: s_pblh    
+      REAL, dimension(klon), intent(in) :: prain    
+      REAL, dimension(klon), intent(in) :: tsol    
+      REAL, DIMENSION(klon), INTENT(IN) :: pat1 !pression premier lev      
+      INTEGER, INTENT(IN)  :: iri1 ! Richardson de la 1ere couche
+!
+      REAL, dimension(klon), intent(out) :: pref, delm, delh, zri1
+!171220     REAL, dimension(klon) :: cdram, cdrah, zri1 
+      REAL, dimension(klon) :: cdram, cdrah
+!-----------------------------------------------------------------------
+      include "YOMCST.h"
+      include "flux_arp.h"
+!
+! Variables locales  
+      INTEGER :: i 
+      REAL, dimension(klon) :: cdran, gref,ycdragm
+!
+!------------------------------------------------------------------------- 
+      DO i=1, knon
+        gref(i) = zref*RG
+      ENDDO 
+!
+! Richardson at reference level 
+!
+      CALL cdrag(knon, nsrf, &
+                    speed, temp, q_zref, gref, &
+                    psol, s_pblh, ts, qsurf, z0m, z0h, &
+                    ri1, iri1, &
+                    cdram, cdrah, zri1, pref, prain, tsol, pat1)
+      DO i = 1, knon
+        delm(i) = sqrt(cdrm(i))/sqrt(cdram(i))
+!verifier que temp est un temperat potentielle.
+        delh(i)= (cdrh(i)* sqrt(cdram(i)))/ &
+                   (cdrah(i)*sqrt(cdrm(i)))
+      ENDDO 
+!
+      RETURN 
+      END SUBROUTINE screencn
+END MODULE screenc_mod
Index: DZ6/trunk/libf/phylmd/screenp_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/screenp_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,185 +1,0 @@
-!
-MODULE screenp_mod
-!
-! This module contains some procedures for calculation of the first
-! guess of temperature, specific humidity and wind at a reference level
-! coefficients for turbulent diffusion at surface
-!
-  IMPLICIT NONE
-
-CONTAINS
-!
-!****************************************************************************************
-!
-!r original routine
-!
-      SUBROUTINE screenp(klon, knon, nsrf, &
-     &                   speed, tair, qair, &
-     &                   ts, qsurf, rugos, lmon, &
-     &                   ustar, testar, qstar, zref, &
-     &                   delu, delte, delq) 
-      IMPLICIT none
-!-------------------------------------------------------------------------
-!
-! Objet : calcul "predicteur" des anomalies du vent, de la temperature 
-!         potentielle et de l'humidite relative au niveau de reference zref et 
-!         par rapport au 1er niveau (pour u) ou a la surface (pour theta et q) 
-!         a partir des relations de Dyer-Businger.
-!
-! Reference : Hess, Colman et McAvaney (1995)
-!
-! I. Musat, 01.07.2002
-!-------------------------------------------------------------------------
-!
-! klon----input-I- dimension de la grille physique (= nb_pts_latitude X nb_pts_longitude)
-! knon----input-I- nombre de points pour un type de surface
-! nsrf----input-I- indice pour le type de surface; voir indice_sol_mod.F90
-! speed---input-R- module du vent au 1er niveau du modele
-! tair----input-R- temperature de l'air au 1er niveau du modele
-! qair----input-R- humidite relative au 1er niveau du modele
-! ts------input-R- temperature de l'air a la surface
-! qsurf---input-R- humidite relative a la surface
-! rugos---input-R- rugosite
-! lmon----input-R- longueur de Monin-Obukov
-! ustar---input-R- facteur d'echelle pour le vent
-! testar--input-R- facteur d'echelle pour la temperature potentielle
-! qstar---input-R- facteur d'echelle pour l'humidite relative
-! zref----input-R- altitude de reference
-!
-! delu----input-R- anomalie du vent par rapport au 1er niveau
-! delte---input-R- anomalie de la temperature potentielle par rapport a la surface
-! delq----input-R- anomalie de l'humidite relative par rapport a la surface
-!
-      INTEGER, intent(in) :: klon, knon, nsrf
-      REAL, dimension(klon), intent(in) :: speed, tair, qair
-      REAL, dimension(klon), intent(in) :: ts, qsurf, rugos
-      DOUBLE PRECISION, dimension(klon), intent(in) :: lmon
-      REAL, dimension(klon), intent(in) :: ustar, testar, qstar
-      REAL, intent(in) :: zref
-!
-      REAL, dimension(klon), intent(out) :: delu, delte, delq
-!
-!-------------------------------------------------------------------------
-! Variables locales et constantes :
-      REAL, PARAMETER :: RKAR=0.40
-      INTEGER :: i
-      REAL :: xtmp, xtmp0
-!-------------------------------------------------------------------------
-      DO i = 1, knon
-!
-        IF (lmon(i).GE.0.) THEN
-!
-! STABLE CASE
-!
-          IF (speed(i).GT.1.5.AND.lmon(i).LE.1.0                        &
-     &                      .AND. rugos(i).LE.1.0) THEN
-            delu(i) = (ustar(i)/RKAR)* &
-                      (log(zref/(rugos(i))+1.) + &
-                      min(5.d0, 5.0 *(zref - rugos(i))/lmon(i)))
-            delte(i) = (testar(i)/RKAR)* &
-                       (log(zref/(rugos(i))+1.) + &
-                       min(5.d0, 5.0 * (zref - rugos(i))/lmon(i)))
-            delq(i) = (qstar(i)/RKAR)* &
-                      (log(zref/(rugos(i))+1.) + &
-                      min(5.d0, 5.0 * (zref - rugos(i))/lmon(i)))
-          ELSE
-            delu(i)  = 0.1 * speed(i)
-            delte(i) = 0.1 * (tair(i) - ts(i) )
-            delq(i)  = 0.1 * (max(qair(i),0.0) - max(qsurf(i),0.0))
-          ENDIF
-        ELSE  
-!
-! UNSTABLE CASE
-!
-          IF (speed(i).GT.5.0.AND.abs(lmon(i)).LE.50.0) THEN
-            xtmp = (1. - 16. * (zref/lmon(i)))**(1./4.)
-            xtmp0 = (1. - 16. * (rugos(i)/lmon(i)))**(1./4.)
-            delu(i) = (ustar(i)/RKAR)* &
-                      (log(zref/(rugos(i))+1.) & 
-                      - 2.*log(0.5*(1. + xtmp)) &
-                      + 2.*log(0.5*(1. + xtmp0)) &
-                      - log(0.5*(1. + xtmp*xtmp)) &
-                      + log(0.5*(1. + xtmp0*xtmp0)) &
-                      + 2.*atan(xtmp) - 2.*atan(xtmp0))
-            delte(i) = (testar(i)/RKAR)* &
-                       (log(zref/(rugos(i))+1.) &
-                       - 2.0 * log(0.5*(1. + xtmp*xtmp)) & 
-                       + 2.0 * log(0.5*(1. + xtmp0*xtmp0)))
-            delq(i)  = (qstar(i)/RKAR)* &
-                       (log(zref/(rugos(i))+1.) &
-                       - 2.0 * log(0.5*(1. + xtmp*xtmp)) & 
-                       + 2.0 * log(0.5*(1. + xtmp0*xtmp0)))
-          ELSE
-            delu(i)  = 0.5 * speed(i)
-            delte(i) = 0.5 * (tair(i) - ts(i) )
-            delq(i)  = 0.5 * (max(qair(i),0.0) - max(qsurf(i),0.0))
-          ENDIF
-        ENDIF
-!
-      ENDDO
-      RETURN
-      END SUBROUTINE screenp
-!
-      SUBROUTINE screenpn(klon, knon, nsrf, &
-     &                   speed, tair, qair, &
-     &                   ts, qsurf, rugos, zri1, &
-     &                   zref, &
-     &                   delu, delte, delq) 
-      IMPLICIT none
-!-------------------------------------------------------------------------
-!
-! Objet : calcul "predicteur" des anomalies du vent, de la temperature 
-!         potentielle et de l'humidite relative au niveau de reference zref et 
-!         par rapport au 1er niveau (pour u) ou a la surface (pour theta et q) 
-!         a partir des relations de Dyer-Businger.
-!
-! Reference : Hess, Colman et McAvaney (1995)
-!
-! I. Musat, 01.07.2002
-!-------------------------------------------------------------------------
-!
-! klon----input-I- dimension de la grille physique (= nb_pts_latitude X nb_pts_longitude)
-! knon----input-I- nombre de points pour un type de surface
-! nsrf----input-I- indice pour le type de surface; voir indice_sol_mod.F90
-! speed---input-R- module du vent au 1er niveau du modele
-! tair----input-R- temperature de l'air au 1er niveau du modele
-! qair----input-R- humidite relative au 1er niveau du modele
-! ts------input-R- temperature de l'air a la surface
-! qsurf---input-R- humidite relative a la surface
-! rugos---input-R- rugosite
-! zref----input-R- altitude de reference
-!
-! delu----input-R- anomalie du vent par rapport au 1er niveau
-! delte---input-R- anomalie de la temperature potentielle par rapport a la surface
-! delq----input-R- anomalie de l'humidite relative par rapport a la surface
-!
-      INTEGER, intent(in) :: klon, knon, nsrf
-      REAL, dimension(klon), intent(in) :: speed, tair, qair
-      REAL, dimension(klon), intent(in) :: ts, qsurf, rugos
-      REAL, dimension(klon), intent(in) :: zri1
-      REAL, intent(in) :: zref
-!
-      REAL, dimension(klon), intent(out) :: delu, delte, delq
-!
-!-------------------------------------------------------------------------
-! Variables locales et constantes :
-      REAL, PARAMETER :: RKAR=0.40
-      INTEGER :: i
-      REAL :: xtmp, xtmp0
-!-------------------------------------------------------------------------
-      DO i = 1, knon
-!
-       IF (zri1(i).GE.0.) THEN
-          delu(i)  = 0.1 * speed(i)
-          delte(i) = 0.1 * (tair(i) - ts(i) )
-          delq(i)  = 0.1 * (max(qair(i),0.0) - max(qsurf(i),0.0))
-       ELSE
-          delu(i)  = 0.5 * speed(i)
-          delte(i) = 0.5 * (tair(i) - ts(i) )
-          delq(i)  = 0.5 * (max(qair(i),0.0) - max(qsurf(i),0.0))
-       ENDIF
-!
-      ENDDO
-      RETURN
-      END SUBROUTINE screenpn
-END MODULE screenp_mod 
Index: /LMDZ6/trunk/libf/phylmd/screenp_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/screenp_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/screenp_mod.f90	(revision 5268)
@@ -0,0 +1,185 @@
+!
+MODULE screenp_mod
+!
+! This module contains some procedures for calculation of the first
+! guess of temperature, specific humidity and wind at a reference level
+! coefficients for turbulent diffusion at surface
+!
+  IMPLICIT NONE
+
+CONTAINS
+!
+!****************************************************************************************
+!
+!r original routine
+!
+      SUBROUTINE screenp(klon, knon, nsrf, &
+     &                   speed, tair, qair, &
+     &                   ts, qsurf, rugos, lmon, &
+     &                   ustar, testar, qstar, zref, &
+     &                   delu, delte, delq) 
+      IMPLICIT none
+!-------------------------------------------------------------------------
+!
+! Objet : calcul "predicteur" des anomalies du vent, de la temperature 
+!         potentielle et de l'humidite relative au niveau de reference zref et 
+!         par rapport au 1er niveau (pour u) ou a la surface (pour theta et q) 
+!         a partir des relations de Dyer-Businger.
+!
+! Reference : Hess, Colman et McAvaney (1995)
+!
+! I. Musat, 01.07.2002
+!-------------------------------------------------------------------------
+!
+! klon----input-I- dimension de la grille physique (= nb_pts_latitude X nb_pts_longitude)
+! knon----input-I- nombre de points pour un type de surface
+! nsrf----input-I- indice pour le type de surface; voir indice_sol_mod.F90
+! speed---input-R- module du vent au 1er niveau du modele
+! tair----input-R- temperature de l'air au 1er niveau du modele
+! qair----input-R- humidite relative au 1er niveau du modele
+! ts------input-R- temperature de l'air a la surface
+! qsurf---input-R- humidite relative a la surface
+! rugos---input-R- rugosite
+! lmon----input-R- longueur de Monin-Obukov
+! ustar---input-R- facteur d'echelle pour le vent
+! testar--input-R- facteur d'echelle pour la temperature potentielle
+! qstar---input-R- facteur d'echelle pour l'humidite relative
+! zref----input-R- altitude de reference
+!
+! delu----input-R- anomalie du vent par rapport au 1er niveau
+! delte---input-R- anomalie de la temperature potentielle par rapport a la surface
+! delq----input-R- anomalie de l'humidite relative par rapport a la surface
+!
+      INTEGER, intent(in) :: klon, knon, nsrf
+      REAL, dimension(klon), intent(in) :: speed, tair, qair
+      REAL, dimension(klon), intent(in) :: ts, qsurf, rugos
+      DOUBLE PRECISION, dimension(klon), intent(in) :: lmon
+      REAL, dimension(klon), intent(in) :: ustar, testar, qstar
+      REAL, intent(in) :: zref
+!
+      REAL, dimension(klon), intent(out) :: delu, delte, delq
+!
+!-------------------------------------------------------------------------
+! Variables locales et constantes :
+      REAL, PARAMETER :: RKAR=0.40
+      INTEGER :: i
+      REAL :: xtmp, xtmp0
+!-------------------------------------------------------------------------
+      DO i = 1, knon
+!
+        IF (lmon(i).GE.0.) THEN
+!
+! STABLE CASE
+!
+          IF (speed(i).GT.1.5.AND.lmon(i).LE.1.0                        &
+     &                      .AND. rugos(i).LE.1.0) THEN
+            delu(i) = (ustar(i)/RKAR)* &
+                      (log(zref/(rugos(i))+1.) + &
+                      min(5.d0, 5.0 *(zref - rugos(i))/lmon(i)))
+            delte(i) = (testar(i)/RKAR)* &
+                       (log(zref/(rugos(i))+1.) + &
+                       min(5.d0, 5.0 * (zref - rugos(i))/lmon(i)))
+            delq(i) = (qstar(i)/RKAR)* &
+                      (log(zref/(rugos(i))+1.) + &
+                      min(5.d0, 5.0 * (zref - rugos(i))/lmon(i)))
+          ELSE
+            delu(i)  = 0.1 * speed(i)
+            delte(i) = 0.1 * (tair(i) - ts(i) )
+            delq(i)  = 0.1 * (max(qair(i),0.0) - max(qsurf(i),0.0))
+          ENDIF
+        ELSE  
+!
+! UNSTABLE CASE
+!
+          IF (speed(i).GT.5.0.AND.abs(lmon(i)).LE.50.0) THEN
+            xtmp = (1. - 16. * (zref/lmon(i)))**(1./4.)
+            xtmp0 = (1. - 16. * (rugos(i)/lmon(i)))**(1./4.)
+            delu(i) = (ustar(i)/RKAR)* &
+                      (log(zref/(rugos(i))+1.) & 
+                      - 2.*log(0.5*(1. + xtmp)) &
+                      + 2.*log(0.5*(1. + xtmp0)) &
+                      - log(0.5*(1. + xtmp*xtmp)) &
+                      + log(0.5*(1. + xtmp0*xtmp0)) &
+                      + 2.*atan(xtmp) - 2.*atan(xtmp0))
+            delte(i) = (testar(i)/RKAR)* &
+                       (log(zref/(rugos(i))+1.) &
+                       - 2.0 * log(0.5*(1. + xtmp*xtmp)) & 
+                       + 2.0 * log(0.5*(1. + xtmp0*xtmp0)))
+            delq(i)  = (qstar(i)/RKAR)* &
+                       (log(zref/(rugos(i))+1.) &
+                       - 2.0 * log(0.5*(1. + xtmp*xtmp)) & 
+                       + 2.0 * log(0.5*(1. + xtmp0*xtmp0)))
+          ELSE
+            delu(i)  = 0.5 * speed(i)
+            delte(i) = 0.5 * (tair(i) - ts(i) )
+            delq(i)  = 0.5 * (max(qair(i),0.0) - max(qsurf(i),0.0))
+          ENDIF
+        ENDIF
+!
+      ENDDO
+      RETURN
+      END SUBROUTINE screenp
+!
+      SUBROUTINE screenpn(klon, knon, nsrf, &
+     &                   speed, tair, qair, &
+     &                   ts, qsurf, rugos, zri1, &
+     &                   zref, &
+     &                   delu, delte, delq) 
+      IMPLICIT none
+!-------------------------------------------------------------------------
+!
+! Objet : calcul "predicteur" des anomalies du vent, de la temperature 
+!         potentielle et de l'humidite relative au niveau de reference zref et 
+!         par rapport au 1er niveau (pour u) ou a la surface (pour theta et q) 
+!         a partir des relations de Dyer-Businger.
+!
+! Reference : Hess, Colman et McAvaney (1995)
+!
+! I. Musat, 01.07.2002
+!-------------------------------------------------------------------------
+!
+! klon----input-I- dimension de la grille physique (= nb_pts_latitude X nb_pts_longitude)
+! knon----input-I- nombre de points pour un type de surface
+! nsrf----input-I- indice pour le type de surface; voir indice_sol_mod.F90
+! speed---input-R- module du vent au 1er niveau du modele
+! tair----input-R- temperature de l'air au 1er niveau du modele
+! qair----input-R- humidite relative au 1er niveau du modele
+! ts------input-R- temperature de l'air a la surface
+! qsurf---input-R- humidite relative a la surface
+! rugos---input-R- rugosite
+! zref----input-R- altitude de reference
+!
+! delu----input-R- anomalie du vent par rapport au 1er niveau
+! delte---input-R- anomalie de la temperature potentielle par rapport a la surface
+! delq----input-R- anomalie de l'humidite relative par rapport a la surface
+!
+      INTEGER, intent(in) :: klon, knon, nsrf
+      REAL, dimension(klon), intent(in) :: speed, tair, qair
+      REAL, dimension(klon), intent(in) :: ts, qsurf, rugos
+      REAL, dimension(klon), intent(in) :: zri1
+      REAL, intent(in) :: zref
+!
+      REAL, dimension(klon), intent(out) :: delu, delte, delq
+!
+!-------------------------------------------------------------------------
+! Variables locales et constantes :
+      REAL, PARAMETER :: RKAR=0.40
+      INTEGER :: i
+      REAL :: xtmp, xtmp0
+!-------------------------------------------------------------------------
+      DO i = 1, knon
+!
+       IF (zri1(i).GE.0.) THEN
+          delu(i)  = 0.1 * speed(i)
+          delte(i) = 0.1 * (tair(i) - ts(i) )
+          delq(i)  = 0.1 * (max(qair(i),0.0) - max(qsurf(i),0.0))
+       ELSE
+          delu(i)  = 0.5 * speed(i)
+          delte(i) = 0.5 * (tair(i) - ts(i) )
+          delq(i)  = 0.5 * (max(qair(i),0.0) - max(qsurf(i),0.0))
+       ENDIF
+!
+      ENDDO
+      RETURN
+      END SUBROUTINE screenpn
+END MODULE screenp_mod 
Index: DZ6/trunk/libf/phylmd/simu_airs.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/simu_airs.F90	(revision 5267)
+++ 	(revision )
@@ -1,1306 +1,0 @@
-        
-        module m_simu_airs
-
-        USE print_control_mod, ONLY: prt_level,lunout
-          
-        implicit none
-
-        REAL, PARAMETER :: tau_thresh = 0.05 ! seuil nuages detectables
-        REAL, PARAMETER :: p_thresh = 445.   ! seuil nuages hauts
-        REAL, PARAMETER :: em_min = 0.2      ! seuils nuages semi-transp
-        REAL, PARAMETER :: em_max = 0.85
-        REAL, PARAMETER :: undef = 999.
-
-        contains
-
-        REAL function search_tropopause(P,T,alt,N) result(P_tropo)
-! this function searches for the tropopause pressure in [hPa].
-! The search is based on ideology described in
-! Reichler et al., Determining the tropopause height from gridded data,
-! GRL, 30(20) 2042, doi:10.1029/2003GL018240, 2003
-
-        INTEGER N,i,i_lev,first_point,exit_flag,i_dir
-        REAL P(N),T(N),alt(N),slope(N)
-        REAL P_min, P_max, slope_limit,slope_2km, &
-     & delta_alt_limit,tmp,delta_alt
-        PARAMETER(P_min=75.0, P_max=470.0)   ! hPa
-        PARAMETER(slope_limit=0.002)         ! 2 K/km converted to K/m
-        PARAMETER(delta_alt_limit=2000.0)    ! 2000 meters
-
-        do i=1,N-1
-        slope(i)=-(T(i+1)-T(i))/(alt(i+1)-alt(i))
-        end do
-        slope(N)=slope(N-1)
-
-        if (P(1).gt.P(N)) then
-        i_dir= 1
-        i=1
-        else
-        i_dir=-1
-        i=N
-        end if
-
-        first_point=0
-        exit_flag=0
-        do while(exit_flag.eq.0)
-        if (P(i).ge.P_min.and.P(i).le.P_max) then
-        if (first_point.gt.0) then
-        delta_alt=alt(i)-alt(first_point)
-        if (delta_alt.ge.delta_alt_limit) then
-        slope_2km=(T(first_point)-T(i))/delta_alt
-        if (slope_2km.lt.slope_limit) then
-        exit_flag=1
-        else
-        first_point=0
-        end if
-        end if
-        end if
-        if (first_point.eq.0.and.slope(i).lt.slope_limit) first_point=i
-        end if
-        i=i+i_dir
-        if (i.le.1.or.i.ge.N) exit_flag=1
-        end do
-
-        if (first_point.le.0) P_tropo=65.4321
-        if (first_point.eq.1) P_tropo=64.5432
-        if (first_point.gt.1) then
-        tmp=(slope_limit-slope(first_point))/(slope(first_point+1)- &
-     & slope(first_point))*(P(first_point+1)-P(first_point))
-        P_tropo=P(first_point)+tmp
-        ! print*, 'P_tropo= ', tmp, P(first_point), P_tropo
-        end if
-
-! Ajout Marine
-        if (P_tropo .lt. 60. .or. P_tropo .gt. 470.) then
-        P_tropo = 999.
-        endif
-
-        return
-        end function search_tropopause
-
-
-
-        subroutine cloud_structure(len_cs, rneb_cs, temp_cs, &
-     & emis_cs, iwco_cs, &
-     & pres_cs, dz_cs, rhodz_cs, rad_cs, &
-     & cc_tot_cs, cc_hc_cs, cc_hist_cs, &
-     & cc_Cb_cs, cc_ThCi_cs, cc_Anv_cs, &
-     & pcld_hc_cs, tcld_hc_cs, &
-     & em_hc_cs, iwp_hc_cs, deltaz_hc_cs, &
-     & pcld_Cb_cs, tcld_Cb_cs, em_Cb_cs, &
-     & pcld_ThCi_cs, tcld_ThCi_cs, em_ThCi_cs, &
-     & pcld_Anv_cs, tcld_Anv_cs, em_Anv_cs, &
-     & em_hist_cs, iwp_hist_cs, deltaz_hist_cs, rad_hist_cs)
-
-
-     
-        INTEGER :: i, n, nss
-
-        INTEGER, intent(in) :: len_cs
-        REAL, DIMENSION(:), intent(in) :: rneb_cs, temp_cs
-        REAL, DIMENSION(:), intent(in) :: emis_cs, iwco_cs, rad_cs
-        REAL, DIMENSION(:), intent(in) :: pres_cs, dz_cs, rhodz_cs
-
-        REAL, intent(out) :: cc_tot_cs, cc_hc_cs, cc_hist_cs, &
-     & cc_Cb_cs, cc_ThCi_cs, cc_Anv_cs, &
-     & pcld_hc_cs, tcld_hc_cs, em_hc_cs, iwp_hc_cs, &
-     & pcld_Cb_cs, tcld_Cb_cs, em_Cb_cs, &
-     & pcld_ThCi_cs, tcld_ThCi_cs, em_ThCi_cs, &
-     & pcld_Anv_cs, tcld_Anv_cs, em_Anv_cs, &
-     & em_hist_cs, iwp_hist_cs, &
-     & deltaz_hc_cs, deltaz_hist_cs, rad_hist_cs
-
-        REAL, DIMENSION(len_cs) :: rneb_ord
-        REAL :: rneb_min
-
-        REAL, DIMENSION(:), allocatable :: s, s_hc, s_hist, rneb_max
-        REAL, DIMENSION(:), allocatable :: sCb, sThCi, sAnv
-        REAL, DIMENSION(:), allocatable :: iwp_ss, pcld_ss, tcld_ss,&
-     & emis_ss
-        REAL, DIMENSION(:), allocatable :: deltaz_ss, rad_ss
-
-        CHARACTER (len = 50)      :: modname = 'simu_airs.cloud_structure'
-        CHARACTER (len = 160)     :: abort_message
-        
-
-        write(lunout,*) 'dans cloud_structure'
-
-        call ordonne(len_cs, rneb_cs, rneb_ord)
-       
-
-! Definition des sous_sections
-
-        rneb_min = rneb_ord(1)
-        nss = 1
-
-        do i = 2, size(rneb_cs)
-        if (rneb_ord(i) .gt. rneb_min) then
-        nss = nss+1
-        rneb_min = rneb_ord(i)
-        endif
-        enddo
-
-        allocate (s(nss))
-        allocate (s_hc(nss))
-        allocate (s_hist(nss))
-        allocate (rneb_max(nss))
-        allocate (emis_ss(nss))
-        allocate (pcld_ss(nss))
-        allocate (tcld_ss(nss))
-        allocate (iwp_ss(nss))
-        allocate (deltaz_ss(nss))
-        allocate (rad_ss(nss))
-        allocate (sCb(nss))
-        allocate (sThCi(nss))
-        allocate (sAnv(nss))
-
-        rneb_min = rneb_ord(1)
-        n = 1
-        s(1) = rneb_ord(1)
-        s_hc(1) = rneb_ord(1)
-        s_hist(1) = rneb_ord(1)
-        sCb(1) = rneb_ord(1)
-        sThCi(1) = rneb_ord(1)
-        sAnv(1) = rneb_ord(1)
-
-        rneb_max(1) = rneb_ord(1)
-
-        do i = 2, size(rneb_cs)
-        if (rneb_ord(i) .gt. rneb_min) then
-        n = n+1
-        s(n) = rneb_ord(i)-rneb_min
-        s_hc(n) = rneb_ord(i)-rneb_min
-        s_hist(n) = rneb_ord(i)-rneb_min
-        sCb(n) = rneb_ord(i)-rneb_min
-        sThCi(n) = rneb_ord(i)-rneb_min
-        sAnv(n) = rneb_ord(i)-rneb_min
-
-        rneb_max(n) = rneb_ord(i)
-        rneb_min = rneb_ord(i)
-        endif
-        enddo
-
-! Appel de sous_section
-
-        do i = 1, nss
-         call sous_section(len_cs, rneb_cs, temp_cs, &
-     &  emis_cs, iwco_cs, &
-     &  pres_cs, dz_cs, rhodz_cs, rad_cs, rneb_ord, &
-     &  rneb_max(i),s(i),s_hc(i),s_hist(i), &
-     &  sCb(i), sThCi(i), sAnv(i), &
-     &  emis_ss(i), &
-     &  pcld_ss(i), tcld_ss(i), iwp_ss(i), deltaz_ss(i), rad_ss(i))
-        enddo
-
-! Caracteristiques de la structure nuageuse
-
-        cc_tot_cs = 0.
-        cc_hc_cs = 0.
-        cc_hist_cs = 0.
-
-        cc_Cb_cs = 0.
-        cc_ThCi_cs = 0.
-        cc_Anv_cs = 0.
-
-        em_hc_cs = 0.
-        iwp_hc_cs = 0.
-        deltaz_hc_cs = 0.
-
-        em_hist_cs = 0.
-        iwp_hist_cs = 0.
-        deltaz_hist_cs = 0.
-        rad_hist_cs = 0.
-
-        pcld_hc_cs = 0.
-        tcld_hc_cs = 0.
-
-        pcld_Cb_cs = 0.
-        tcld_Cb_cs = 0.
-        em_Cb_cs = 0.
-
-        pcld_ThCi_cs = 0.
-        tcld_ThCi_cs = 0.
-        em_ThCi_cs = 0.
-
-        pcld_Anv_cs = 0.
-        tcld_Anv_cs = 0.
-        em_Anv_cs = 0.
-
-         do i = 1, nss
-
-        cc_tot_cs = cc_tot_cs + s(i)
-        cc_hc_cs = cc_hc_cs + s_hc(i)
-        cc_hist_cs = cc_hist_cs + s_hist(i)
-
-        cc_Cb_cs = cc_Cb_cs + sCb(i)
-        cc_ThCi_cs = cc_ThCi_cs + sThCi(i)
-        cc_Anv_cs = cc_Anv_cs + sAnv(i)
-
-        iwp_hc_cs = iwp_hc_cs + s_hc(i)*iwp_ss(i)
-        em_hc_cs = em_hc_cs + s_hc(i)*emis_ss(i)
-        deltaz_hc_cs = deltaz_hc_cs + s_hc(i)*deltaz_ss(i)
-
-        iwp_hist_cs = iwp_hist_cs + s_hist(i)*iwp_ss(i)
-        em_hist_cs = em_hist_cs + s_hist(i)*emis_ss(i)
-        deltaz_hist_cs = deltaz_hist_cs + s_hist(i)*deltaz_ss(i)
-        rad_hist_cs = rad_hist_cs + s_hist(i)*rad_ss(i)
-
-        pcld_hc_cs = pcld_hc_cs + s_hc(i)*pcld_ss(i)
-        tcld_hc_cs = tcld_hc_cs + s_hc(i)*tcld_ss(i)
-
-        pcld_Cb_cs = pcld_Cb_cs + sCb(i)*pcld_ss(i)
-        tcld_Cb_cs = tcld_Cb_cs + sCb(i)*tcld_ss(i)
-        em_Cb_cs = em_Cb_cs + sCb(i)*emis_ss(i)
-
-        pcld_ThCi_cs = pcld_ThCi_cs + sThCi(i)*pcld_ss(i)
-        tcld_ThCi_cs = tcld_ThCi_cs + sThCi(i)*tcld_ss(i)
-        em_ThCi_cs = em_ThCi_cs + sThCi(i)*emis_ss(i)
-
-        pcld_Anv_cs = pcld_Anv_cs + sAnv(i)*pcld_ss(i)
-        tcld_Anv_cs = tcld_Anv_cs + sAnv(i)*tcld_ss(i)
-        em_Anv_cs = em_Anv_cs + sAnv(i)*emis_ss(i)
-
-        enddo
-
-        deallocate(s)
-        deallocate (s_hc)
-        deallocate (s_hist)
-        deallocate (rneb_max)
-        deallocate (emis_ss)
-        deallocate (pcld_ss)
-        deallocate (tcld_ss)
-        deallocate (iwp_ss)
-        deallocate (deltaz_ss)
-        deallocate (rad_ss)
-        deallocate (sCb)
-        deallocate (sThCi)
-        deallocate (sAnv)
-
-       call normal_undef(pcld_hc_cs,cc_hc_cs)
-       call normal_undef(tcld_hc_cs,cc_hc_cs)
-       call normal_undef(iwp_hc_cs,cc_hc_cs)
-       call normal_undef(em_hc_cs,cc_hc_cs)
-       call normal_undef(deltaz_hc_cs,cc_hc_cs)
-       
-       call normal_undef(iwp_hist_cs,cc_hist_cs)
-       call normal_undef(em_hist_cs,cc_hist_cs)
-       call normal_undef(deltaz_hist_cs,cc_hist_cs)
-       call normal_undef(rad_hist_cs,cc_hist_cs)
-
-       call normal_undef(pcld_Cb_cs,cc_Cb_cs)
-       call normal_undef(tcld_Cb_cs,cc_Cb_cs)
-       call normal_undef(em_Cb_cs,cc_Cb_cs)
-
-       call normal_undef(pcld_ThCi_cs,cc_ThCi_cs)
-       call normal_undef(tcld_ThCi_cs,cc_ThCi_cs)
-       call normal_undef(em_ThCi_cs,cc_ThCi_cs)
-    
-       call normal_undef(pcld_Anv_cs,cc_Anv_cs)
-       call normal_undef(tcld_Anv_cs,cc_Anv_cs)
-       call normal_undef(em_Anv_cs,cc_Anv_cs)
-
-
-! Tests
-
-        if (cc_tot_cs .gt. maxval(rneb_cs) .and. &
-     & abs(cc_tot_cs-maxval(rneb_cs)) .gt. 1.e-4 )  then
-          WRITE(abort_message,*) 'cc_tot_cs > max rneb_cs', cc_tot_cs, maxval(rneb_cs)
-          CALL abort_physic(modname,abort_message,1)
-        endif
-
-        if (iwp_hc_cs .lt. 0.) then
-          abort_message= 'cloud_structure: iwp_hc_cs < 0'
-          CALL abort_physic(modname,abort_message,1)
-        endif
- 
-        end subroutine cloud_structure
-
-
-        subroutine normal_undef(num, den)
-
-        REAL, intent(in) :: den
-        REAL, intent(inout) :: num
-
-        if (den .ne. 0) then
-        num = num/den
-        else
-        num = undef
-        endif
-
-        end subroutine normal_undef
-
-
-        subroutine normal2_undef(res,num,den)
-
-        REAL, intent(in) :: den
-        REAL, intent(in) :: num
-        REAL, intent(out) :: res
-
-        if (den .ne. 0.) then
-        res = num/den
-        else
-        res = undef
-        endif
-
-        end subroutine normal2_undef
-
-
-        subroutine sous_section(len_cs, rneb_cs, temp_cs, &
-     & emis_cs, iwco_cs, &
-     & pres_cs, dz_cs, rhodz_cs, rad_cs, rneb_ord, &
-     & rnebmax, stot, shc, shist, &
-     & sCb, sThCi, sAnv, &
-     & emis, pcld, tcld, iwp, deltaz, rad)
-
-        INTEGER, intent(in) :: len_cs
-        REAL, DIMENSION(len_cs), intent(in) :: rneb_cs, temp_cs
-        REAL, DIMENSION(len_cs), intent(in) :: emis_cs, iwco_cs, &
-     & rneb_ord
-        REAL, DIMENSION(len_cs), intent(in) :: pres_cs, dz_cs, rad_cs
-        REAL, DIMENSION(len_cs), intent(in) :: rhodz_cs
-        REAL, DIMENSION(len_cs) :: tau_cs, w
-        REAL, intent(in) :: rnebmax
-        REAL, intent(inout) :: stot, shc, shist
-        REAL, intent(inout) :: sCb, sThCi, sAnv
-        REAL, intent(out) :: emis, pcld, tcld, iwp, deltaz, rad
-
-        INTEGER :: i, ideb, ibeg, iend, nuage, visible
-        REAL :: som, som_tau, som_iwc, som_dz, som_rad, tau
-
-        CHARACTER (len = 50)      :: modname = 'simu_airs.sous_section'
-        CHARACTER (len = 160)     :: abort_message
-
-
-! Ponderation: 1 pour les nuages, 0 pour les trous
-
-        do i = 1, len_cs
-        if (rneb_cs(i) .ge. rnebmax) then
-        w(i) = 1.
-        else
-        w(i) = 0.
-        endif
-        enddo
-
-! Calcul des epaisseurs optiques a partir des emissivites
-
-        som = 0.
-        do i = 1, len_cs
-        if (emis_cs(i) .eq. 1.) then
-        tau_cs(i) = 10.
-        else
-        tau_cs(i) = -log(1.-emis_cs(i))
-        endif
-        som = som+tau_cs(i)
-        enddo
-
-
-        ideb = 1
-        nuage = 0
-        visible = 0
-
-
-! Boucle sur les nuages
-        do while (ideb .ne. 0 .and. ideb .le. len_cs)   
-
-
-! Definition d'un nuage de la sous-section
-
-        call topbot(ideb, w, ibeg, iend)
-        ideb = iend+1
-
-        if (ibeg .gt. 0) then
-
-        nuage = nuage + 1
-
-! On determine les caracteristiques du nuage
-! (ep. optique, ice water path, pression, temperature)
-
-        call caract(ibeg, iend, temp_cs, tau_cs, iwco_cs, &
-     & pres_cs, dz_cs, rhodz_cs, rad_cs, pcld, tcld, &
-     & som_tau, som_iwc, som_dz, som_rad)
-
-! On masque le nuage s'il n'est pas detectable
-
-        call masque(ibeg, iend, som_tau, visible, w)
-
-        endif
-
-! Fin boucle nuages
-        enddo
-
-
-! Analyse du nuage detecte
-
-        call topbot(1, w, ibeg, iend)
-
-        if (ibeg .gt. 0) then
-
-        call caract(ibeg, iend, temp_cs, tau_cs, iwco_cs, &
-     & pres_cs, dz_cs, rhodz_cs, rad_cs, pcld, tcld, &
-     & som_tau, som_iwc, som_dz, som_rad)
-
-        tau = som_tau
-        emis = 1. - exp(-tau)
-        iwp = som_iwc
-        deltaz = som_dz
-        rad = som_rad
-
-        if (pcld .gt. p_thresh) then
-
-        shc = 0.
-        shist = 0.
-        sCb = 0.
-        sThCi = 0.
-        sAnv = 0.
-
-        else
-
-        if (emis .lt. em_min .or. emis .gt. em_max  &
-     & .or. tcld .gt. 230.) then
-        shist = 0.
-        endif
-
-        if (emis .lt. 0.98) then
-        sCb = 0.
-        endif
-
-        if (emis .gt. 0.5 .or. emis .lt. 0.1) then
-        sThCi = 0.
-        endif
-
-        if (emis .le. 0.5 .or. emis .ge. 0.98) then
-        sAnv = 0.
-        endif
-
-        endif
-
-        else
-
-        tau = 0.
-        emis = 0.
-        iwp = 0.
-        deltaz = 0.
-        pcld = 0.
-        tcld = 0.
-        stot = 0.
-        shc = 0.
-        shist = 0.
-        rad = 0.
-        sCb = 0.
-        sThCi = 0.
-        sAnv = 0.
-
-        endif
-
-
-! Tests
-
-        if (iwp .lt. 0.) then
-          WRITE(abort_message,*) 'ideb iwp =', ideb, iwp
-          CALL abort_physic(modname,abort_message,1)
-        endif
-
-        if (deltaz .lt. 0.) then
-          WRITE(abort_message,*)'ideb deltaz =', ideb, deltaz
-          CALL abort_physic(modname,abort_message,1)
-        endif
-
-        if (emis .lt. 0.048 .and. emis .ne. 0.) then
-          WRITE(abort_message,*) 'ideb emis =', ideb, emis
-          CALL abort_physic(modname,abort_message,1)
-        endif
-
-        end subroutine sous_section
-
-
-        subroutine masque (ibeg, iend, som_tau, &
-     & visible, w)
-
-        INTEGER, intent(in) :: ibeg, iend
-        REAL, intent(in) :: som_tau
-
-        INTEGER, intent(inout) :: visible
-        REAL, DIMENSION(:), intent(inout) :: w
-
-        INTEGER :: i
-
-
-
-! Masque
-
-! Cas ou il n'y a pas de nuage visible au-dessus
-
-        if (visible .eq. 0) then
-
-        if (som_tau .lt. tau_thresh) then
-        do i = ibeg, iend
-        w(i) = 0.
-        enddo
-        else
-        visible = 1
-        endif
-
-! Cas ou il y a un nuage visible au-dessus
-
-        else
-
-        do i = ibeg, iend
-        w(i) = 0.
-        enddo
-
-        endif
-
-
-        end subroutine masque
-
-
-         subroutine caract (ibeg, iend, temp_cs, tau_cs, iwco_cs, &
-     & pres_cs, dz_cs, rhodz_cs, rad_cs, pcld, tcld, &
-     & som_tau, som_iwc, som_dz, som_rad)
-
-        INTEGER, intent(in) :: ibeg, iend
-        REAL, DIMENSION(:), intent(in) :: tau_cs, iwco_cs, temp_cs
-        REAL, DIMENSION(:), intent(in) :: pres_cs, dz_cs, rad_cs
-        REAL, DIMENSION(:), intent(in) :: rhodz_cs
-        REAL, intent(out) :: som_tau, som_iwc, som_dz, som_rad
-        REAL , intent(out) :: pcld, tcld
-
-        INTEGER :: i, ibase, imid
-
-        CHARACTER (len = 50)      :: modname = 'simu_airs.caract'
-        CHARACTER (len = 160)     :: abort_message
-
-! Somme des epaisseurs optiques et des contenus en glace sur le nuage
-
-        som_tau = 0.
-        som_iwc = 0.
-        som_dz = 0.
-        som_rad = 0.
-        ibase = -100
-
-        do i = ibeg, iend
-
-        som_tau = som_tau + tau_cs(i)
-
-        som_dz = som_dz + dz_cs(i)
-        som_iwc = som_iwc + iwco_cs(i)*1000*rhodz_cs(i)  ! en g/m2
-        som_rad = som_rad + rad_cs(i)*dz_cs(i)
-
-        if (som_tau .gt. 3. .and. ibase .eq. -100) then
-        ibase = i-1
-        endif
-
-        enddo
-
-        if (som_dz .ne. 0.) then
-          som_rad = som_rad/som_dz
-        else
-          write(*,*) 'som_dez = 0 STOP'
-          write(*,*) 'ibeg, iend =', ibeg, iend
-          do i = ibeg, iend
-             write(*,*) dz_cs(i), rhodz_cs(i)
-          enddo
-          abort_message='see above'
-          CALL abort_physic(modname,abort_message,1)
-        endif
-
-! Determination de Pcld et Tcld
-
-       if (ibase .lt. ibeg) then
-       ibase = ibeg
-       endif
-
-       imid = (ibeg+ibase)/2
-
-       pcld = pres_cs(imid)/100.        ! pcld en hPa
-       tcld = temp_cs(imid)
-
-
-       end subroutine caract
- 
-        subroutine topbot(ideb,w,ibeg,iend)
-
-        INTEGER, intent(in) :: ideb
-        REAL, DIMENSION(:), intent(in) :: w
-        INTEGER, intent(out) :: ibeg, iend
-
-        INTEGER :: i, itest
-
-        itest = 0
-        ibeg = 0
-        iend = 0
-
-        do i = ideb, size(w)
-
-        if (w(i) .eq. 1. .and. itest .eq. 0) then
-        ibeg = i
-        itest = 1
-        endif
-
-        enddo
-
-
-        i = ibeg
-        do while (w(i) .eq. 1. .and. i .le. size(w))
-        i = i+1
-        enddo
-        iend = i-1
-
-
-        end subroutine topbot
-
-        subroutine ordonne(len_cs, rneb_cs, rneb_ord)
-
-        INTEGER, intent(in) :: len_cs
-        REAL, DIMENSION(:), intent(in) :: rneb_cs
-        REAL, DIMENSION(:), intent(out) :: rneb_ord
-
-        INTEGER :: i, j, ind_min
-
-        REAL, DIMENSION(len_cs) :: rneb
-        REAL :: rneb_max
-
-
-        do i = 1, size(rneb_cs)
-        rneb(i) = rneb_cs(i)
-        enddo
-
-        do j = 1, size(rneb_cs)
-
-        rneb_max = 100.
-
-        do i = 1, size(rneb_cs)
-        if (rneb(i) .lt. rneb_max) then
-        rneb_max = rneb(i)
-        ind_min = i
-        endif
-        enddo
-
-        rneb_ord(j) = rneb_max
-        rneb(ind_min) = 100.
-
-        enddo
-        
-        end subroutine ordonne
-
- 
-        subroutine sim_mesh(rneb_1D, temp_1D, emis_1D, &
-     & iwcon_1D, rad_1D, &
-     & pres, dz, &
-     & rhodz_1D, cc_tot_mesh, cc_hc_mesh, cc_hist_mesh, pcld_hc_mesh,&
-     & tcld_hc_mesh, &
-     & em_hc_mesh, iwp_hc_mesh, deltaz_hc_mesh, &
-     & cc_Cb_mesh, cc_ThCi_mesh, cc_Anv_mesh, &
-     & pcld_Cb_mesh, tcld_Cb_mesh, em_Cb_mesh, &
-     & pcld_ThCi_mesh, tcld_ThCi_mesh, em_ThCi_mesh, &
-     & pcld_Anv_mesh, tcld_Anv_mesh, em_Anv_mesh, &
-     & em_hist_mesh, iwp_hist_mesh, deltaz_hist_mesh, rad_hist_mesh)
-
-       USE dimphy
-
-       REAL, DIMENSION(klev), intent(in) :: rneb_1D, temp_1D, emis_1D, &
-     & iwcon_1D, rad_1D
-        REAL, DIMENSION(klev), intent(in) :: pres, dz, rhodz_1D
-        REAL, intent(out) :: cc_tot_mesh, cc_hc_mesh, cc_hist_mesh
-        REAL, intent(out) :: cc_Cb_mesh, cc_ThCi_mesh, cc_Anv_mesh
-        REAL, intent(out) :: em_hc_mesh, pcld_hc_mesh, tcld_hc_mesh, &
-     & iwp_hc_mesh
-
-        REAL, intent(out) :: pcld_Cb_mesh, tcld_Cb_mesh, em_Cb_mesh
-        REAL, intent(out) :: pcld_ThCi_mesh, tcld_ThCi_mesh, &
-     & em_ThCi_mesh
-        REAL, intent(out) :: pcld_Anv_mesh, tcld_Anv_mesh, em_Anv_mesh
-
-        REAL, intent(out) :: em_hist_mesh, iwp_hist_mesh, rad_hist_mesh
-        REAL, intent(out) :: deltaz_hc_mesh, deltaz_hist_mesh
-
-        REAL, DIMENSION(:), allocatable :: rneb_cs, temp_cs, emis_cs, &
-     & iwco_cs
-        REAL, DIMENSION(:), allocatable :: pres_cs, dz_cs, rad_cs, &
-     & rhodz_cs
-
-        INTEGER :: i,j,l
-        INTEGER :: ltop, itop, ibot, num_cs, N_cs, len_cs, ics
-
-        REAL :: som_emi_hc,som_pcl_hc,som_tcl_hc,som_iwp_hc,som_hc,&
-     & som_hist
-        REAL :: som_emi_hist, som_iwp_hist, som_deltaz_hc, &
-     & som_deltaz_hist
-        REAL :: som_rad_hist
-        REAL :: som_Cb, som_ThCi, som_Anv
-        REAL :: som_emi_Cb, som_tcld_Cb, som_pcld_Cb
-        REAL :: som_emi_Anv, som_tcld_Anv, som_pcld_Anv
-        REAL :: som_emi_ThCi, som_tcld_ThCi, som_pcld_ThCi
-        REAL :: tsom_tot, tsom_hc, tsom_hist
-        REAL :: prod, prod_hh
-
-        REAL :: cc_tot_cs, cc_hc_cs, cc_hist_cs
-        REAL :: cc_Cb_cs, cc_ThCi_cs, cc_Anv_cs
-        REAL :: pcld_hc_cs, tcld_hc_cs
-        REAL :: em_hc_cs, iwp_hc_cs, deltaz_hc_cs
-        REAL :: pcld_Cb_cs, tcld_Cb_cs, em_Cb_cs
-        REAL :: pcld_ThCi_cs, tcld_ThCi_cs, em_ThCi_cs
-        REAL :: pcld_Anv_cs, tcld_Anv_cs, em_Anv_cs
-        REAL :: em_hist_cs, iwp_hist_cs, deltaz_hist_cs, rad_hist_cs
-
-        REAL, DIMENSION(klev) :: test_tot, test_hc, test_hist
-        REAL, DIMENSION(klev) :: test_pcld, test_tcld, test_em, test_iwp
-
-        CHARACTER (len = 50)      :: modname = 'simu_airs.sim_mesh'
-        CHARACTER (len = 160)     :: abort_message
-        
-
-        do j = 1, klev
-          WRITE(lunout,*) 'simu_airs, j, rneb_1D =', rneb_1D(j)
-        enddo
-
-! Definition des structures nuageuses, de la plus haute a la plus basse
-
-        num_cs = 0
-        ltop = klev-1
-
-        prod = 1.
-
-        som_emi_hc = 0.
-        som_emi_hist = 0.
-        som_pcl_hc = 0.
-        som_tcl_hc = 0.
-        som_iwp_hc = 0.
-        som_iwp_hist = 0.
-        som_deltaz_hc = 0.
-        som_deltaz_hist = 0.
-        som_rad_hist = 0.
-        som_hc = 0.
-        som_hist = 0.
-
-        som_Cb = 0.
-        som_ThCi = 0.
-        som_Anv = 0.
-
-        som_emi_Cb = 0.
-        som_pcld_Cb = 0.
-        som_tcld_Cb = 0.
-
-        som_emi_ThCi = 0.
-        som_pcld_ThCi = 0.
-        som_tcld_ThCi = 0.
-
-        som_emi_Anv = 0.
-        som_pcld_Anv = 0.
-        som_tcld_Anv = 0.
-
-        tsom_tot = 0.
-        tsom_hc = 0.
-        tsom_hist = 0.
-
-        do while (ltop .ge. 1)   ! Boucle sur toute la colonne
-
-        itop = 0
-
-        do l = ltop,1,-1
-
-        if (itop .eq. 0 .and. rneb_1D(l) .gt. 0.001 ) then
-        itop = l
-        endif
-
-        enddo
-
-        ibot = itop
-
-        do while (rneb_1D(ibot) .gt. 0.001 .and. ibot .ge. 1)
-        ibot = ibot -1
-        enddo
-
-
-        ibot = ibot+1
-
-        if (itop .gt. 0) then    ! itop > 0
-
-        num_cs = num_cs +1
-        len_cs = itop-ibot+1
-
-! Allocation et definition des variables de la structure nuageuse
-! le premier indice denote ce qui est le plus haut
-
-        allocate (rneb_cs(len_cs))
-        allocate (temp_cs(len_cs))
-        allocate (emis_cs(len_cs))
-        allocate (iwco_cs(len_cs))
-        allocate (pres_cs(len_cs))
-        allocate (dz_cs(len_cs))
-        allocate (rad_cs(len_cs))
-        allocate (rhodz_cs(len_cs))
-
-        ics = 0
-
-        do i = itop, ibot, -1
-        ics = ics + 1
-        rneb_cs(ics) = rneb_1D(i)
-        temp_cs(ics) = temp_1D(i)
-        emis_cs(ics) = emis_1D(i)
-        iwco_cs(ics) = iwcon_1D(i)
-        rad_cs(ics) = rad_1D(i)
-        pres_cs(ics) = pres(i)
-        dz_cs(ics) = dz(i)
-        rhodz_cs(ics) = rhodz_1D(i)
-        enddo
-
-! Appel du sous_programme cloud_structure
-
-        call cloud_structure(len_cs,rneb_cs,temp_cs,emis_cs,iwco_cs,&
-     & pres_cs, dz_cs, rhodz_cs, rad_cs, &
-     & cc_tot_cs, cc_hc_cs, cc_hist_cs, &
-     & cc_Cb_cs, cc_ThCi_cs, cc_Anv_cs, &
-     & pcld_hc_cs, tcld_hc_cs, &
-     & em_hc_cs, iwp_hc_cs, deltaz_hc_cs, &
-     & pcld_Cb_cs, tcld_Cb_cs, em_Cb_cs, &
-     & pcld_ThCi_cs, tcld_ThCi_cs, em_ThCi_cs, &
-     & pcld_Anv_cs, tcld_Anv_cs, em_Anv_cs, &
-     & em_hist_cs, iwp_hist_cs, deltaz_hist_cs, rad_hist_cs)
-
-
-        deallocate (rneb_cs)
-        deallocate (temp_cs)
-        deallocate (emis_cs)
-        deallocate (iwco_cs)
-        deallocate (pres_cs)
-        deallocate (dz_cs)
-        deallocate (rad_cs)
-        deallocate (rhodz_cs)
-
-
-! Pour la couverture nuageuse sur la maille
-
-        prod_hh = prod
-
-        prod = prod*(1.-cc_tot_cs)
-
-! Pour les autres variables definies sur la maille
-
-        som_emi_hc = som_emi_hc + em_hc_cs*cc_hc_cs*prod_hh
-        som_iwp_hc = som_iwp_hc + iwp_hc_cs*cc_hc_cs*prod_hh
-        som_deltaz_hc = som_deltaz_hc + deltaz_hc_cs*cc_hc_cs*prod_hh
-
-        som_emi_Cb = som_emi_Cb + em_Cb_cs*cc_Cb_cs*prod_hh
-        som_tcld_Cb = som_tcld_Cb + tcld_Cb_cs*cc_Cb_cs*prod_hh
-        som_pcld_Cb = som_pcld_Cb + pcld_Cb_cs*cc_Cb_cs*prod_hh
-
-        som_emi_ThCi = som_emi_ThCi + em_ThCi_cs*cc_ThCi_cs*prod_hh
-        som_tcld_ThCi = som_tcld_ThCi + tcld_ThCi_cs*cc_ThCi_cs*prod_hh
-        som_pcld_ThCi = som_pcld_ThCi + pcld_ThCi_cs*cc_ThCi_cs*prod_hh
-
-        som_emi_Anv = som_emi_Anv + em_Anv_cs*cc_Anv_cs*prod_hh
-        som_tcld_Anv = som_tcld_Anv + tcld_Anv_cs*cc_Anv_cs*prod_hh
-        som_pcld_Anv = som_pcld_Anv + pcld_Anv_cs*cc_Anv_cs*prod_hh
-
-        som_emi_hist = som_emi_hist + em_hist_cs*cc_hist_cs*prod_hh
-        som_iwp_hist = som_iwp_hist + iwp_hist_cs*cc_hist_cs*prod_hh
-        som_deltaz_hist = som_deltaz_hist + &
-     & deltaz_hist_cs*cc_hist_cs*prod_hh
-        som_rad_hist = som_rad_hist + rad_hist_cs*cc_hist_cs*prod_hh
-
-        som_pcl_hc = som_pcl_hc + pcld_hc_cs*cc_hc_cs*prod_hh
-        som_tcl_hc = som_tcl_hc + tcld_hc_cs*cc_hc_cs*prod_hh
-
-        som_hc = som_hc + cc_hc_cs*prod_hh
-        som_hist = som_hist + cc_hist_cs*prod_hh
-
-        som_Cb = som_Cb + cc_Cb_cs*prod_hh
-        som_ThCi = som_ThCi + cc_ThCi_cs*prod_hh
-        som_Anv = som_Anv + cc_Anv_cs*prod_hh
-
-
-! Pour test
-        
-        call test_bornes('cc_tot_cs     ',cc_tot_cs,1.,0.)
-        call test_bornes('cc_hc_cs      ',cc_hc_cs,1.,0.)
-        call test_bornes('cc_hist_cs    ',cc_hist_cs,1.,0.)
-        call test_bornes('pcld_hc_cs    ',pcld_hc_cs,1200.,0.)
-        call test_bornes('tcld_hc_cs    ',tcld_hc_cs,1000.,100.)
-        call test_bornes('em_hc_cs      ',em_hc_cs,1000.,0.048)
-
-        test_tot(num_cs) = cc_tot_cs
-        test_hc(num_cs) = cc_hc_cs
-        test_hist(num_cs) = cc_hist_cs
-        test_pcld(num_cs) = pcld_hc_cs
-        test_tcld(num_cs) = tcld_hc_cs
-        test_em(num_cs) = em_hc_cs
-        test_iwp(num_cs) = iwp_hc_cs
-
-        tsom_tot = tsom_tot + cc_tot_cs
-        tsom_hc = tsom_hc + cc_hc_cs
-        tsom_hist = tsom_hist + cc_hist_cs
-
-
-        endif                   ! itop > 0
-
-        ltop = ibot -1
-
-        enddo                   ! fin de la boucle sur la colonne
-
-        N_CS = num_cs
-
-
-! Determination des variables de sortie
-
-        if (N_CS .gt. 0) then   ! if N_CS>0
-
-        cc_tot_mesh = 1. - prod
-
-        cc_hc_mesh = som_hc
-        cc_hist_mesh = som_hist
-
-        cc_Cb_mesh = som_Cb
-        cc_ThCi_mesh = som_ThCi
-        cc_Anv_mesh = som_Anv
-
-        call normal2_undef(pcld_hc_mesh,som_pcl_hc, &
-     & cc_hc_mesh)
-        call normal2_undef(tcld_hc_mesh,som_tcl_hc, &
-     & cc_hc_mesh)
-        call normal2_undef(em_hc_mesh,som_emi_hc, &
-     & cc_hc_mesh)
-        call normal2_undef(iwp_hc_mesh,som_iwp_hc, &
-     & cc_hc_mesh)
-        call normal2_undef(deltaz_hc_mesh,som_deltaz_hc, &
-     & cc_hc_mesh)
-
-        call normal2_undef(em_Cb_mesh,som_emi_Cb, &
-     & cc_Cb_mesh)
-        call normal2_undef(tcld_Cb_mesh,som_tcld_Cb, &
-     & cc_Cb_mesh)
-        call normal2_undef(pcld_Cb_mesh,som_pcld_Cb, &
-     & cc_Cb_mesh)
-
-        call normal2_undef(em_ThCi_mesh,som_emi_ThCi, &
-     & cc_ThCi_mesh)
-        call normal2_undef(tcld_ThCi_mesh,som_tcld_ThCi, &
-     & cc_ThCi_mesh)
-        call normal2_undef(pcld_ThCi_mesh,som_pcld_ThCi, &
-     & cc_ThCi_mesh)
-
-       call normal2_undef(em_Anv_mesh,som_emi_Anv, &
-     & cc_Anv_mesh)
-        call normal2_undef(tcld_Anv_mesh,som_tcld_Anv, &
-     & cc_Anv_mesh)
-        call normal2_undef(pcld_Anv_mesh,som_pcld_Anv, &
-     & cc_Anv_mesh)
-
-
-        call normal2_undef(em_hist_mesh,som_emi_hist, &
-     & cc_hist_mesh)
-        call normal2_undef(iwp_hist_mesh,som_iwp_hist, &
-     & cc_hist_mesh)
-        call normal2_undef(deltaz_hist_mesh,som_deltaz_hist, &
-     & cc_hist_mesh)
-        call normal2_undef(rad_hist_mesh,som_rad_hist, &
-     & cc_hist_mesh)
-
-
-! Tests 
-
-        ! Tests
-
-       if (cc_tot_mesh .gt. tsom_tot .and. &
-     & abs(cc_tot_mesh-tsom_tot) .gt. 1.e-4) then
-           WRITE(abort_message,*)'cc_tot_mesh > tsom_tot', cc_tot_mesh, tsom_tot
-           CALL abort_physic(modname,abort_message,1)
-        endif
-
-        if (cc_tot_mesh .lt. maxval(test_tot(1:N_CS)) .and. &
-     & abs(cc_tot_mesh-maxval(test_tot(1:N_CS))) .gt. 1.e-4) then
-           WRITE(abort_message,*) 'cc_tot_mesh < max', cc_tot_mesh, maxval(test_tot(1:N_CS))
-           CALL abort_physic(modname,abort_message,1)
-        endif
-
-        if (cc_hc_mesh .gt. tsom_hc .and. &
-     & abs(cc_hc_mesh-tsom_hc) .gt. 1.e-4) then
-           WRITE(abort_message,*) 'cc_hc_mesh > tsom_hc', cc_hc_mesh, tsom_hc
-           CALL abort_physic(modname,abort_message,1)
-        endif
-
-        if (cc_hc_mesh .lt. maxval(test_hc(1:N_CS)) .and. &
-     & abs(cc_hc_mesh-maxval(test_hc(1:N_CS))) .gt. 1.e-4) then
-           WRITE(abort_message,*) 'cc_hc_mesh < max', cc_hc_mesh, maxval(test_hc(1:N_CS))
-           CALL abort_physic(modname,abort_message,1)
-        endif
-
-        if (cc_hist_mesh .gt. tsom_hist .and. &
-     & abs(cc_hist_mesh-tsom_hist) .gt. 1.e-4) then
-           WRITE(abort_message,*) 'cc_hist_mesh > tsom_hist', cc_hist_mesh, tsom_hist
-           CALL abort_physic(modname,abort_message,1)
-        endif
-
-        if (cc_hist_mesh .lt. 0.) then
-           WRITE(abort_message,*) 'cc_hist_mesh < 0', cc_hist_mesh
-           CALL abort_physic(modname,abort_message,1)
-        endif
-
-        if ((pcld_hc_mesh .gt. maxval(test_pcld(1:N_CS)) .or. &
-     & pcld_hc_mesh .lt. minval(test_pcld(1:N_CS))) .and. &
-     & abs(pcld_hc_mesh-maxval(test_pcld(1:N_CS))) .gt. 1. .and. &
-     & maxval(test_pcld(1:N_CS)) .ne. 999. &
-     & .and. minval(test_pcld(1:N_CS)) .ne. 999.) then
-           WRITE(abort_message,*) 'pcld_hc_mesh est faux', pcld_hc_mesh, maxval(test_pcld(1:N_CS)), &
-     & minval(test_pcld(1:N_CS))
-           CALL abort_physic(modname,abort_message,1)
-        endif
-
-       if ((tcld_hc_mesh .gt. maxval(test_tcld(1:N_CS)) .or. &
-     & tcld_hc_mesh .lt. minval(test_tcld(1:N_CS))) .and. &
-     & abs(tcld_hc_mesh-maxval(test_tcld(1:N_CS))) .gt. 0.1 .and. &
-     & maxval(test_tcld(1:N_CS)) .ne. 999. &
-     & .and. minval(test_tcld(1:N_CS)) .ne. 999.) then
-           WRITE(abort_message,*) 'tcld_hc_mesh est faux', tcld_hc_mesh, maxval(test_tcld(1:N_CS)), &
-                & minval(test_tcld(1:N_CS))
-           CALL abort_physic(modname,abort_message,1)
-        endif
-
-        if ((em_hc_mesh .gt. maxval(test_em(1:N_CS)) .or. &
-     & em_hc_mesh .lt. minval(test_em(1:N_CS))) .and. &
-     & abs(em_hc_mesh-maxval(test_em(1:N_CS))) .gt. 1.e-4 .and. &
-     & minval(test_em(1:N_CS)) .ne. 999. .and. &
-     & maxval(test_em(1:N_CS)) .ne. 999. ) then
-           WRITE(abort_message,*) 'em_hc_mesh est faux', em_hc_mesh, maxval(test_em(1:N_CS)), &
-     & minval(test_em(1:N_CS))
-           CALL abort_physic(modname,abort_message,1)
-        endif
-
-        else               ! if N_CS>0
-
-        cc_tot_mesh = 0.
-        cc_hc_mesh = 0.
-        cc_hist_mesh = 0.
-
-        cc_Cb_mesh = 0.
-        cc_ThCi_mesh = 0.
-        cc_Anv_mesh = 0.
-
-        iwp_hc_mesh = undef 
-        deltaz_hc_mesh = undef 
-        em_hc_mesh = undef 
-        iwp_hist_mesh = undef 
-        deltaz_hist_mesh = undef 
-        rad_hist_mesh = undef 
-        em_hist_mesh = undef 
-        pcld_hc_mesh = undef 
-        tcld_hc_mesh = undef 
-
-        pcld_Cb_mesh = undef 
-        tcld_Cb_mesh = undef 
-        em_Cb_mesh = undef 
-
-        pcld_ThCi_mesh = undef 
-        tcld_ThCi_mesh = undef 
-        em_ThCi_mesh = undef 
-
-        pcld_Anv_mesh = undef 
-        tcld_Anv_mesh = undef 
-        em_Anv_mesh = undef 
-
-
-        endif                  ! if N_CS>0
-
-        end subroutine sim_mesh
-
-        subroutine test_bornes(sx,x,bsup,binf)
-
-        REAL, intent(in) :: x, bsup, binf
-        character*14, intent(in) :: sx
-        CHARACTER (len = 50)      :: modname = 'simu_airs.test_bornes'
-        CHARACTER (len = 160)     :: abort_message
-
-        if (x .gt. bsup .or. x .lt. binf) then
-          WRITE(abort_message,*) sx, 'est faux', sx, x
-          CALL abort_physic(modname,abort_message,1)
-        endif
- 
-        end subroutine test_bornes
-
-        end module m_simu_airs
-
-
-        subroutine simu_airs &
-     & (itap, rneb_airs, temp_airs, cldemi_airs, iwcon0_airs, rad_airs, &
-     & geop_airs, pplay_airs, paprs_airs, &
-     & map_prop_hc,map_prop_hist,&
-     & map_emis_hc,map_iwp_hc,map_deltaz_hc,map_pcld_hc,map_tcld_hc,&
-     & map_emis_Cb,map_pcld_Cb,map_tcld_Cb,&
-     & map_emis_ThCi,map_pcld_ThCi,map_tcld_ThCi,&
-     & map_emis_Anv,map_pcld_Anv,map_tcld_Anv,&
-     & map_emis_hist,map_iwp_hist,map_deltaz_hist,map_rad_hist,&
-     & map_ntot,map_hc,map_hist,&
-     & map_Cb,map_ThCi,map_Anv,alt_tropo )
-
-        USE dimphy
-        USE m_simu_airs
-
-        IMPLICIT NONE
-
-        include "YOMCST.h"
-
-        INTEGER,intent(in) :: itap
-
-        REAL, DIMENSION(klon,klev), intent(in) :: &
-     & rneb_airs, temp_airs, cldemi_airs, iwcon0_airs, &
-     & rad_airs, geop_airs, pplay_airs, paprs_airs
-
-       REAL, DIMENSION(klon,klev) :: &
-     & rhodz_airs, rho_airs, iwcon_airs
-
-        REAL, DIMENSION(klon),intent(out) :: alt_tropo
-
-        REAL, DIMENSION(klev) :: rneb_1D, temp_1D, &
-     & emis_1D, rad_1D, pres_1D, alt_1D, &
-     & rhodz_1D, dz_1D, iwcon_1D
-
-        INTEGER :: i, j
-
-        REAL :: cc_tot_mesh, cc_hc_mesh, cc_hist_mesh
-        REAL :: cc_Cb_mesh, cc_ThCi_mesh, cc_Anv_mesh
-        REAL :: pcld_hc_mesh, tcld_hc_mesh, em_hc_mesh, iwp_hc_mesh
-        REAL :: em_hist_mesh, iwp_hist_mesh
-        REAL :: deltaz_hc_mesh, deltaz_hist_mesh, rad_hist_mesh
-        REAL :: pcld_Cb_mesh, tcld_Cb_mesh, em_Cb_mesh
-        REAL :: pcld_ThCi_mesh, tcld_ThCi_mesh, em_ThCi_mesh
-        REAL :: pcld_Anv_mesh, tcld_Anv_mesh, em_Anv_mesh
-
-        REAL, DIMENSION(klon),intent(out) :: map_prop_hc, map_prop_hist
-        REAL, DIMENSION(klon),intent(out) :: map_emis_hc, map_iwp_hc
-        REAL, DIMENSION(klon),intent(out) :: map_deltaz_hc, map_pcld_hc
-        REAL, DIMENSION(klon),intent(out) :: map_tcld_hc
-        REAL, DIMENSION(klon),intent(out) :: map_emis_Cb,map_pcld_Cb,map_tcld_Cb 
-        REAL, DIMENSION(klon),intent(out) :: &
-     & map_emis_ThCi,map_pcld_ThCi,map_tcld_ThCi
-        REAL, DIMENSION(klon),intent(out) :: &
-     & map_emis_Anv,map_pcld_Anv,map_tcld_Anv
-        REAL, DIMENSION(klon),intent(out) :: &
-     & map_emis_hist,map_iwp_hist,map_deltaz_hist,&
-     & map_rad_hist
-        REAL, DIMENSION(klon),intent(out) :: map_ntot,map_hc,map_hist
-        REAL, DIMENSION(klon),intent(out) :: map_Cb,map_ThCi,map_Anv
- 
- 
-        write(*,*) 'simu_airs'
-        write(*,*) 'itap, klon, klev', itap, klon, klev
-        write(*,*) 'RG, RD =', RG, RD
-
-
-! Definition des variables 1D
-
-        do i = 1, klon
-        do j = 1, klev-1
-        rhodz_airs(i,j) = &
-     & (paprs_airs(i,j)-paprs_airs(i,j+1))/RG
-        enddo
-        rhodz_airs(i,klev) = 0.
-        enddo
-
-        do i = 1, klon
-        do j = 1,klev
-        rho_airs(i,j) = &
-     & pplay_airs(i,j)/(temp_airs(i,j)*RD)
-
-        if (rneb_airs(i,j) .gt. 0.001) then
-        iwcon_airs(i,j) = iwcon0_airs(i,j)/rneb_airs(i,j)
-        else
-        iwcon_airs(i,j) = 0.
-        endif
- 
-        enddo
-        enddo
-
-!=============================================================================
-
-        do i = 1, klon  ! boucle sur les points de grille
-
-!=============================================================================
-        
-        do j = 1,klev
-
-        rneb_1D(j) = rneb_airs(i,j)
-        temp_1D(j) = temp_airs(i,j)
-        emis_1D(j) = cldemi_airs(i,j)
-        iwcon_1D(j) = iwcon_airs(i,j)
-        rad_1D(j) = rad_airs(i,j)
-        pres_1D(j) = pplay_airs(i,j)
-        alt_1D(j) = geop_airs(i,j)/RG
-        rhodz_1D(j) = rhodz_airs(i,j)
-        dz_1D(j) = rhodz_airs(i,j)/rho_airs(i,j)
-
-        enddo
-
-        alt_tropo(i) = &
-     & search_tropopause(pres_1D/100.,temp_1D,alt_1D,klev)
-
-
-! Appel du ss-programme sim_mesh
-
-!        if (itap .eq. 1 ) then
-
-        call sim_mesh(rneb_1D, temp_1D, emis_1D, iwcon_1D, rad_1D, &
-     & pres_1D, dz_1D, rhodz_1D, &
-     & cc_tot_mesh, cc_hc_mesh, cc_hist_mesh, &
-     & pcld_hc_mesh, tcld_hc_mesh, em_hc_mesh, iwp_hc_mesh, &
-     & deltaz_hc_mesh,&
-     & cc_Cb_mesh, cc_ThCi_mesh, cc_Anv_mesh, &
-     & pcld_Cb_mesh, tcld_Cb_mesh, em_Cb_mesh, &
-     & pcld_ThCi_mesh, tcld_ThCi_mesh, em_ThCi_mesh, &
-     & pcld_Anv_mesh, tcld_Anv_mesh, em_Anv_mesh, &
-     & em_hist_mesh, iwp_hist_mesh, deltaz_hist_mesh, rad_hist_mesh)
-
-         write(*,*) '===================================='
-         write(*,*) 'itap, i:', itap, i 
-         write(*,*) 'cc_tot, cc_hc, cc_hist, pcld_hc, tcld_hc, em_hc, &
-     & iwp_hc, em_hist, iwp_hist ='
-         write(*,*) cc_tot_mesh, cc_hc_mesh, cc_hist_mesh
-         write(*,*) pcld_hc_mesh, tcld_hc_mesh, em_hc_mesh, iwp_hc_mesh
-         write(*,*)  em_hist_mesh, iwp_hist_mesh
-
-!        endif
-
-! Definition des variables a ecrire dans le fichier de sortie
-
-        call normal2_undef(map_prop_hc(i),cc_hc_mesh, &
-     & cc_tot_mesh)
-        call normal2_undef(map_prop_hist(i),cc_hist_mesh, &
-     & cc_tot_mesh)
-
-       map_emis_hc(i) = em_hc_mesh
-       map_iwp_hc(i) = iwp_hc_mesh
-       map_deltaz_hc(i) = deltaz_hc_mesh
-       map_pcld_hc(i) = pcld_hc_mesh
-       map_tcld_hc(i) = tcld_hc_mesh
-
-       map_emis_Cb(i) = em_Cb_mesh
-       map_pcld_Cb(i) = pcld_Cb_mesh
-       map_tcld_Cb(i) = tcld_Cb_mesh
-
-       map_emis_ThCi(i) = em_ThCi_mesh
-       map_pcld_ThCi(i) = pcld_ThCi_mesh
-       map_tcld_ThCi(i) = tcld_ThCi_mesh
-
-       map_emis_Anv(i) = em_Anv_mesh
-       map_pcld_Anv(i) = pcld_Anv_mesh
-       map_tcld_Anv(i) = tcld_Anv_mesh
-
-       map_emis_hist(i) = em_hist_mesh
-       map_iwp_hist(i) = iwp_hist_mesh
-       map_deltaz_hist(i) = deltaz_hist_mesh
-       map_rad_hist(i) = rad_hist_mesh
-
-       map_ntot(i) = cc_tot_mesh
-       map_hc(i) = cc_hc_mesh
-       map_hist(i) = cc_hist_mesh
-
-       map_Cb(i) = cc_Cb_mesh
-       map_ThCi(i) = cc_ThCi_mesh
-       map_Anv(i) = cc_Anv_mesh
-
-
-        enddo         ! fin boucle sur les points de grille
-
-        
-
-        end subroutine simu_airs
-
Index: /LMDZ6/trunk/libf/phylmd/simu_airs.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/simu_airs.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/simu_airs.f90	(revision 5268)
@@ -0,0 +1,1306 @@
+        
+        module m_simu_airs
+
+        USE print_control_mod, ONLY: prt_level,lunout
+          
+        implicit none
+
+        REAL, PARAMETER :: tau_thresh = 0.05 ! seuil nuages detectables
+        REAL, PARAMETER :: p_thresh = 445.   ! seuil nuages hauts
+        REAL, PARAMETER :: em_min = 0.2      ! seuils nuages semi-transp
+        REAL, PARAMETER :: em_max = 0.85
+        REAL, PARAMETER :: undef = 999.
+
+        contains
+
+        REAL function search_tropopause(P,T,alt,N) result(P_tropo)
+! this function searches for the tropopause pressure in [hPa].
+! The search is based on ideology described in
+! Reichler et al., Determining the tropopause height from gridded data,
+! GRL, 30(20) 2042, doi:10.1029/2003GL018240, 2003
+
+        INTEGER N,i,i_lev,first_point,exit_flag,i_dir
+        REAL P(N),T(N),alt(N),slope(N)
+        REAL P_min, P_max, slope_limit,slope_2km, &
+     & delta_alt_limit,tmp,delta_alt
+        PARAMETER(P_min=75.0, P_max=470.0)   ! hPa
+        PARAMETER(slope_limit=0.002)         ! 2 K/km converted to K/m
+        PARAMETER(delta_alt_limit=2000.0)    ! 2000 meters
+
+        do i=1,N-1
+        slope(i)=-(T(i+1)-T(i))/(alt(i+1)-alt(i))
+        end do
+        slope(N)=slope(N-1)
+
+        if (P(1).gt.P(N)) then
+        i_dir= 1
+        i=1
+        else
+        i_dir=-1
+        i=N
+        end if
+
+        first_point=0
+        exit_flag=0
+        do while(exit_flag.eq.0)
+        if (P(i).ge.P_min.and.P(i).le.P_max) then
+        if (first_point.gt.0) then
+        delta_alt=alt(i)-alt(first_point)
+        if (delta_alt.ge.delta_alt_limit) then
+        slope_2km=(T(first_point)-T(i))/delta_alt
+        if (slope_2km.lt.slope_limit) then
+        exit_flag=1
+        else
+        first_point=0
+        end if
+        end if
+        end if
+        if (first_point.eq.0.and.slope(i).lt.slope_limit) first_point=i
+        end if
+        i=i+i_dir
+        if (i.le.1.or.i.ge.N) exit_flag=1
+        end do
+
+        if (first_point.le.0) P_tropo=65.4321
+        if (first_point.eq.1) P_tropo=64.5432
+        if (first_point.gt.1) then
+        tmp=(slope_limit-slope(first_point))/(slope(first_point+1)- &
+     & slope(first_point))*(P(first_point+1)-P(first_point))
+        P_tropo=P(first_point)+tmp
+        ! print*, 'P_tropo= ', tmp, P(first_point), P_tropo
+        end if
+
+! Ajout Marine
+        if (P_tropo .lt. 60. .or. P_tropo .gt. 470.) then
+        P_tropo = 999.
+        endif
+
+        return
+        end function search_tropopause
+
+
+
+        subroutine cloud_structure(len_cs, rneb_cs, temp_cs, &
+     & emis_cs, iwco_cs, &
+     & pres_cs, dz_cs, rhodz_cs, rad_cs, &
+     & cc_tot_cs, cc_hc_cs, cc_hist_cs, &
+     & cc_Cb_cs, cc_ThCi_cs, cc_Anv_cs, &
+     & pcld_hc_cs, tcld_hc_cs, &
+     & em_hc_cs, iwp_hc_cs, deltaz_hc_cs, &
+     & pcld_Cb_cs, tcld_Cb_cs, em_Cb_cs, &
+     & pcld_ThCi_cs, tcld_ThCi_cs, em_ThCi_cs, &
+     & pcld_Anv_cs, tcld_Anv_cs, em_Anv_cs, &
+     & em_hist_cs, iwp_hist_cs, deltaz_hist_cs, rad_hist_cs)
+
+
+     
+        INTEGER :: i, n, nss
+
+        INTEGER, intent(in) :: len_cs
+        REAL, DIMENSION(:), intent(in) :: rneb_cs, temp_cs
+        REAL, DIMENSION(:), intent(in) :: emis_cs, iwco_cs, rad_cs
+        REAL, DIMENSION(:), intent(in) :: pres_cs, dz_cs, rhodz_cs
+
+        REAL, intent(out) :: cc_tot_cs, cc_hc_cs, cc_hist_cs, &
+     & cc_Cb_cs, cc_ThCi_cs, cc_Anv_cs, &
+     & pcld_hc_cs, tcld_hc_cs, em_hc_cs, iwp_hc_cs, &
+     & pcld_Cb_cs, tcld_Cb_cs, em_Cb_cs, &
+     & pcld_ThCi_cs, tcld_ThCi_cs, em_ThCi_cs, &
+     & pcld_Anv_cs, tcld_Anv_cs, em_Anv_cs, &
+     & em_hist_cs, iwp_hist_cs, &
+     & deltaz_hc_cs, deltaz_hist_cs, rad_hist_cs
+
+        REAL, DIMENSION(len_cs) :: rneb_ord
+        REAL :: rneb_min
+
+        REAL, DIMENSION(:), allocatable :: s, s_hc, s_hist, rneb_max
+        REAL, DIMENSION(:), allocatable :: sCb, sThCi, sAnv
+        REAL, DIMENSION(:), allocatable :: iwp_ss, pcld_ss, tcld_ss,&
+     & emis_ss
+        REAL, DIMENSION(:), allocatable :: deltaz_ss, rad_ss
+
+        CHARACTER (len = 50)      :: modname = 'simu_airs.cloud_structure'
+        CHARACTER (len = 160)     :: abort_message
+        
+
+        write(lunout,*) 'dans cloud_structure'
+
+        call ordonne(len_cs, rneb_cs, rneb_ord)
+       
+
+! Definition des sous_sections
+
+        rneb_min = rneb_ord(1)
+        nss = 1
+
+        do i = 2, size(rneb_cs)
+        if (rneb_ord(i) .gt. rneb_min) then
+        nss = nss+1
+        rneb_min = rneb_ord(i)
+        endif
+        enddo
+
+        allocate (s(nss))
+        allocate (s_hc(nss))
+        allocate (s_hist(nss))
+        allocate (rneb_max(nss))
+        allocate (emis_ss(nss))
+        allocate (pcld_ss(nss))
+        allocate (tcld_ss(nss))
+        allocate (iwp_ss(nss))
+        allocate (deltaz_ss(nss))
+        allocate (rad_ss(nss))
+        allocate (sCb(nss))
+        allocate (sThCi(nss))
+        allocate (sAnv(nss))
+
+        rneb_min = rneb_ord(1)
+        n = 1
+        s(1) = rneb_ord(1)
+        s_hc(1) = rneb_ord(1)
+        s_hist(1) = rneb_ord(1)
+        sCb(1) = rneb_ord(1)
+        sThCi(1) = rneb_ord(1)
+        sAnv(1) = rneb_ord(1)
+
+        rneb_max(1) = rneb_ord(1)
+
+        do i = 2, size(rneb_cs)
+        if (rneb_ord(i) .gt. rneb_min) then
+        n = n+1
+        s(n) = rneb_ord(i)-rneb_min
+        s_hc(n) = rneb_ord(i)-rneb_min
+        s_hist(n) = rneb_ord(i)-rneb_min
+        sCb(n) = rneb_ord(i)-rneb_min
+        sThCi(n) = rneb_ord(i)-rneb_min
+        sAnv(n) = rneb_ord(i)-rneb_min
+
+        rneb_max(n) = rneb_ord(i)
+        rneb_min = rneb_ord(i)
+        endif
+        enddo
+
+! Appel de sous_section
+
+        do i = 1, nss
+         call sous_section(len_cs, rneb_cs, temp_cs, &
+     &  emis_cs, iwco_cs, &
+     &  pres_cs, dz_cs, rhodz_cs, rad_cs, rneb_ord, &
+     &  rneb_max(i),s(i),s_hc(i),s_hist(i), &
+     &  sCb(i), sThCi(i), sAnv(i), &
+     &  emis_ss(i), &
+     &  pcld_ss(i), tcld_ss(i), iwp_ss(i), deltaz_ss(i), rad_ss(i))
+        enddo
+
+! Caracteristiques de la structure nuageuse
+
+        cc_tot_cs = 0.
+        cc_hc_cs = 0.
+        cc_hist_cs = 0.
+
+        cc_Cb_cs = 0.
+        cc_ThCi_cs = 0.
+        cc_Anv_cs = 0.
+
+        em_hc_cs = 0.
+        iwp_hc_cs = 0.
+        deltaz_hc_cs = 0.
+
+        em_hist_cs = 0.
+        iwp_hist_cs = 0.
+        deltaz_hist_cs = 0.
+        rad_hist_cs = 0.
+
+        pcld_hc_cs = 0.
+        tcld_hc_cs = 0.
+
+        pcld_Cb_cs = 0.
+        tcld_Cb_cs = 0.
+        em_Cb_cs = 0.
+
+        pcld_ThCi_cs = 0.
+        tcld_ThCi_cs = 0.
+        em_ThCi_cs = 0.
+
+        pcld_Anv_cs = 0.
+        tcld_Anv_cs = 0.
+        em_Anv_cs = 0.
+
+         do i = 1, nss
+
+        cc_tot_cs = cc_tot_cs + s(i)
+        cc_hc_cs = cc_hc_cs + s_hc(i)
+        cc_hist_cs = cc_hist_cs + s_hist(i)
+
+        cc_Cb_cs = cc_Cb_cs + sCb(i)
+        cc_ThCi_cs = cc_ThCi_cs + sThCi(i)
+        cc_Anv_cs = cc_Anv_cs + sAnv(i)
+
+        iwp_hc_cs = iwp_hc_cs + s_hc(i)*iwp_ss(i)
+        em_hc_cs = em_hc_cs + s_hc(i)*emis_ss(i)
+        deltaz_hc_cs = deltaz_hc_cs + s_hc(i)*deltaz_ss(i)
+
+        iwp_hist_cs = iwp_hist_cs + s_hist(i)*iwp_ss(i)
+        em_hist_cs = em_hist_cs + s_hist(i)*emis_ss(i)
+        deltaz_hist_cs = deltaz_hist_cs + s_hist(i)*deltaz_ss(i)
+        rad_hist_cs = rad_hist_cs + s_hist(i)*rad_ss(i)
+
+        pcld_hc_cs = pcld_hc_cs + s_hc(i)*pcld_ss(i)
+        tcld_hc_cs = tcld_hc_cs + s_hc(i)*tcld_ss(i)
+
+        pcld_Cb_cs = pcld_Cb_cs + sCb(i)*pcld_ss(i)
+        tcld_Cb_cs = tcld_Cb_cs + sCb(i)*tcld_ss(i)
+        em_Cb_cs = em_Cb_cs + sCb(i)*emis_ss(i)
+
+        pcld_ThCi_cs = pcld_ThCi_cs + sThCi(i)*pcld_ss(i)
+        tcld_ThCi_cs = tcld_ThCi_cs + sThCi(i)*tcld_ss(i)
+        em_ThCi_cs = em_ThCi_cs + sThCi(i)*emis_ss(i)
+
+        pcld_Anv_cs = pcld_Anv_cs + sAnv(i)*pcld_ss(i)
+        tcld_Anv_cs = tcld_Anv_cs + sAnv(i)*tcld_ss(i)
+        em_Anv_cs = em_Anv_cs + sAnv(i)*emis_ss(i)
+
+        enddo
+
+        deallocate(s)
+        deallocate (s_hc)
+        deallocate (s_hist)
+        deallocate (rneb_max)
+        deallocate (emis_ss)
+        deallocate (pcld_ss)
+        deallocate (tcld_ss)
+        deallocate (iwp_ss)
+        deallocate (deltaz_ss)
+        deallocate (rad_ss)
+        deallocate (sCb)
+        deallocate (sThCi)
+        deallocate (sAnv)
+
+       call normal_undef(pcld_hc_cs,cc_hc_cs)
+       call normal_undef(tcld_hc_cs,cc_hc_cs)
+       call normal_undef(iwp_hc_cs,cc_hc_cs)
+       call normal_undef(em_hc_cs,cc_hc_cs)
+       call normal_undef(deltaz_hc_cs,cc_hc_cs)
+       
+       call normal_undef(iwp_hist_cs,cc_hist_cs)
+       call normal_undef(em_hist_cs,cc_hist_cs)
+       call normal_undef(deltaz_hist_cs,cc_hist_cs)
+       call normal_undef(rad_hist_cs,cc_hist_cs)
+
+       call normal_undef(pcld_Cb_cs,cc_Cb_cs)
+       call normal_undef(tcld_Cb_cs,cc_Cb_cs)
+       call normal_undef(em_Cb_cs,cc_Cb_cs)
+
+       call normal_undef(pcld_ThCi_cs,cc_ThCi_cs)
+       call normal_undef(tcld_ThCi_cs,cc_ThCi_cs)
+       call normal_undef(em_ThCi_cs,cc_ThCi_cs)
+    
+       call normal_undef(pcld_Anv_cs,cc_Anv_cs)
+       call normal_undef(tcld_Anv_cs,cc_Anv_cs)
+       call normal_undef(em_Anv_cs,cc_Anv_cs)
+
+
+! Tests
+
+        if (cc_tot_cs .gt. maxval(rneb_cs) .and. &
+     & abs(cc_tot_cs-maxval(rneb_cs)) .gt. 1.e-4 )  then
+          WRITE(abort_message,*) 'cc_tot_cs > max rneb_cs', cc_tot_cs, maxval(rneb_cs)
+          CALL abort_physic(modname,abort_message,1)
+        endif
+
+        if (iwp_hc_cs .lt. 0.) then
+          abort_message= 'cloud_structure: iwp_hc_cs < 0'
+          CALL abort_physic(modname,abort_message,1)
+        endif
+ 
+        end subroutine cloud_structure
+
+
+        subroutine normal_undef(num, den)
+
+        REAL, intent(in) :: den
+        REAL, intent(inout) :: num
+
+        if (den .ne. 0) then
+        num = num/den
+        else
+        num = undef
+        endif
+
+        end subroutine normal_undef
+
+
+        subroutine normal2_undef(res,num,den)
+
+        REAL, intent(in) :: den
+        REAL, intent(in) :: num
+        REAL, intent(out) :: res
+
+        if (den .ne. 0.) then
+        res = num/den
+        else
+        res = undef
+        endif
+
+        end subroutine normal2_undef
+
+
+        subroutine sous_section(len_cs, rneb_cs, temp_cs, &
+     & emis_cs, iwco_cs, &
+     & pres_cs, dz_cs, rhodz_cs, rad_cs, rneb_ord, &
+     & rnebmax, stot, shc, shist, &
+     & sCb, sThCi, sAnv, &
+     & emis, pcld, tcld, iwp, deltaz, rad)
+
+        INTEGER, intent(in) :: len_cs
+        REAL, DIMENSION(len_cs), intent(in) :: rneb_cs, temp_cs
+        REAL, DIMENSION(len_cs), intent(in) :: emis_cs, iwco_cs, &
+     & rneb_ord
+        REAL, DIMENSION(len_cs), intent(in) :: pres_cs, dz_cs, rad_cs
+        REAL, DIMENSION(len_cs), intent(in) :: rhodz_cs
+        REAL, DIMENSION(len_cs) :: tau_cs, w
+        REAL, intent(in) :: rnebmax
+        REAL, intent(inout) :: stot, shc, shist
+        REAL, intent(inout) :: sCb, sThCi, sAnv
+        REAL, intent(out) :: emis, pcld, tcld, iwp, deltaz, rad
+
+        INTEGER :: i, ideb, ibeg, iend, nuage, visible
+        REAL :: som, som_tau, som_iwc, som_dz, som_rad, tau
+
+        CHARACTER (len = 50)      :: modname = 'simu_airs.sous_section'
+        CHARACTER (len = 160)     :: abort_message
+
+
+! Ponderation: 1 pour les nuages, 0 pour les trous
+
+        do i = 1, len_cs
+        if (rneb_cs(i) .ge. rnebmax) then
+        w(i) = 1.
+        else
+        w(i) = 0.
+        endif
+        enddo
+
+! Calcul des epaisseurs optiques a partir des emissivites
+
+        som = 0.
+        do i = 1, len_cs
+        if (emis_cs(i) .eq. 1.) then
+        tau_cs(i) = 10.
+        else
+        tau_cs(i) = -log(1.-emis_cs(i))
+        endif
+        som = som+tau_cs(i)
+        enddo
+
+
+        ideb = 1
+        nuage = 0
+        visible = 0
+
+
+! Boucle sur les nuages
+        do while (ideb .ne. 0 .and. ideb .le. len_cs)   
+
+
+! Definition d'un nuage de la sous-section
+
+        call topbot(ideb, w, ibeg, iend)
+        ideb = iend+1
+
+        if (ibeg .gt. 0) then
+
+        nuage = nuage + 1
+
+! On determine les caracteristiques du nuage
+! (ep. optique, ice water path, pression, temperature)
+
+        call caract(ibeg, iend, temp_cs, tau_cs, iwco_cs, &
+     & pres_cs, dz_cs, rhodz_cs, rad_cs, pcld, tcld, &
+     & som_tau, som_iwc, som_dz, som_rad)
+
+! On masque le nuage s'il n'est pas detectable
+
+        call masque(ibeg, iend, som_tau, visible, w)
+
+        endif
+
+! Fin boucle nuages
+        enddo
+
+
+! Analyse du nuage detecte
+
+        call topbot(1, w, ibeg, iend)
+
+        if (ibeg .gt. 0) then
+
+        call caract(ibeg, iend, temp_cs, tau_cs, iwco_cs, &
+     & pres_cs, dz_cs, rhodz_cs, rad_cs, pcld, tcld, &
+     & som_tau, som_iwc, som_dz, som_rad)
+
+        tau = som_tau
+        emis = 1. - exp(-tau)
+        iwp = som_iwc
+        deltaz = som_dz
+        rad = som_rad
+
+        if (pcld .gt. p_thresh) then
+
+        shc = 0.
+        shist = 0.
+        sCb = 0.
+        sThCi = 0.
+        sAnv = 0.
+
+        else
+
+        if (emis .lt. em_min .or. emis .gt. em_max  &
+     & .or. tcld .gt. 230.) then
+        shist = 0.
+        endif
+
+        if (emis .lt. 0.98) then
+        sCb = 0.
+        endif
+
+        if (emis .gt. 0.5 .or. emis .lt. 0.1) then
+        sThCi = 0.
+        endif
+
+        if (emis .le. 0.5 .or. emis .ge. 0.98) then
+        sAnv = 0.
+        endif
+
+        endif
+
+        else
+
+        tau = 0.
+        emis = 0.
+        iwp = 0.
+        deltaz = 0.
+        pcld = 0.
+        tcld = 0.
+        stot = 0.
+        shc = 0.
+        shist = 0.
+        rad = 0.
+        sCb = 0.
+        sThCi = 0.
+        sAnv = 0.
+
+        endif
+
+
+! Tests
+
+        if (iwp .lt. 0.) then
+          WRITE(abort_message,*) 'ideb iwp =', ideb, iwp
+          CALL abort_physic(modname,abort_message,1)
+        endif
+
+        if (deltaz .lt. 0.) then
+          WRITE(abort_message,*)'ideb deltaz =', ideb, deltaz
+          CALL abort_physic(modname,abort_message,1)
+        endif
+
+        if (emis .lt. 0.048 .and. emis .ne. 0.) then
+          WRITE(abort_message,*) 'ideb emis =', ideb, emis
+          CALL abort_physic(modname,abort_message,1)
+        endif
+
+        end subroutine sous_section
+
+
+        subroutine masque (ibeg, iend, som_tau, &
+     & visible, w)
+
+        INTEGER, intent(in) :: ibeg, iend
+        REAL, intent(in) :: som_tau
+
+        INTEGER, intent(inout) :: visible
+        REAL, DIMENSION(:), intent(inout) :: w
+
+        INTEGER :: i
+
+
+
+! Masque
+
+! Cas ou il n'y a pas de nuage visible au-dessus
+
+        if (visible .eq. 0) then
+
+        if (som_tau .lt. tau_thresh) then
+        do i = ibeg, iend
+        w(i) = 0.
+        enddo
+        else
+        visible = 1
+        endif
+
+! Cas ou il y a un nuage visible au-dessus
+
+        else
+
+        do i = ibeg, iend
+        w(i) = 0.
+        enddo
+
+        endif
+
+
+        end subroutine masque
+
+
+         subroutine caract (ibeg, iend, temp_cs, tau_cs, iwco_cs, &
+     & pres_cs, dz_cs, rhodz_cs, rad_cs, pcld, tcld, &
+     & som_tau, som_iwc, som_dz, som_rad)
+
+        INTEGER, intent(in) :: ibeg, iend
+        REAL, DIMENSION(:), intent(in) :: tau_cs, iwco_cs, temp_cs
+        REAL, DIMENSION(:), intent(in) :: pres_cs, dz_cs, rad_cs
+        REAL, DIMENSION(:), intent(in) :: rhodz_cs
+        REAL, intent(out) :: som_tau, som_iwc, som_dz, som_rad
+        REAL , intent(out) :: pcld, tcld
+
+        INTEGER :: i, ibase, imid
+
+        CHARACTER (len = 50)      :: modname = 'simu_airs.caract'
+        CHARACTER (len = 160)     :: abort_message
+
+! Somme des epaisseurs optiques et des contenus en glace sur le nuage
+
+        som_tau = 0.
+        som_iwc = 0.
+        som_dz = 0.
+        som_rad = 0.
+        ibase = -100
+
+        do i = ibeg, iend
+
+        som_tau = som_tau + tau_cs(i)
+
+        som_dz = som_dz + dz_cs(i)
+        som_iwc = som_iwc + iwco_cs(i)*1000*rhodz_cs(i)  ! en g/m2
+        som_rad = som_rad + rad_cs(i)*dz_cs(i)
+
+        if (som_tau .gt. 3. .and. ibase .eq. -100) then
+        ibase = i-1
+        endif
+
+        enddo
+
+        if (som_dz .ne. 0.) then
+          som_rad = som_rad/som_dz
+        else
+          write(*,*) 'som_dez = 0 STOP'
+          write(*,*) 'ibeg, iend =', ibeg, iend
+          do i = ibeg, iend
+             write(*,*) dz_cs(i), rhodz_cs(i)
+          enddo
+          abort_message='see above'
+          CALL abort_physic(modname,abort_message,1)
+        endif
+
+! Determination de Pcld et Tcld
+
+       if (ibase .lt. ibeg) then
+       ibase = ibeg
+       endif
+
+       imid = (ibeg+ibase)/2
+
+       pcld = pres_cs(imid)/100.        ! pcld en hPa
+       tcld = temp_cs(imid)
+
+
+       end subroutine caract
+ 
+        subroutine topbot(ideb,w,ibeg,iend)
+
+        INTEGER, intent(in) :: ideb
+        REAL, DIMENSION(:), intent(in) :: w
+        INTEGER, intent(out) :: ibeg, iend
+
+        INTEGER :: i, itest
+
+        itest = 0
+        ibeg = 0
+        iend = 0
+
+        do i = ideb, size(w)
+
+        if (w(i) .eq. 1. .and. itest .eq. 0) then
+        ibeg = i
+        itest = 1
+        endif
+
+        enddo
+
+
+        i = ibeg
+        do while (w(i) .eq. 1. .and. i .le. size(w))
+        i = i+1
+        enddo
+        iend = i-1
+
+
+        end subroutine topbot
+
+        subroutine ordonne(len_cs, rneb_cs, rneb_ord)
+
+        INTEGER, intent(in) :: len_cs
+        REAL, DIMENSION(:), intent(in) :: rneb_cs
+        REAL, DIMENSION(:), intent(out) :: rneb_ord
+
+        INTEGER :: i, j, ind_min
+
+        REAL, DIMENSION(len_cs) :: rneb
+        REAL :: rneb_max
+
+
+        do i = 1, size(rneb_cs)
+        rneb(i) = rneb_cs(i)
+        enddo
+
+        do j = 1, size(rneb_cs)
+
+        rneb_max = 100.
+
+        do i = 1, size(rneb_cs)
+        if (rneb(i) .lt. rneb_max) then
+        rneb_max = rneb(i)
+        ind_min = i
+        endif
+        enddo
+
+        rneb_ord(j) = rneb_max
+        rneb(ind_min) = 100.
+
+        enddo
+        
+        end subroutine ordonne
+
+ 
+        subroutine sim_mesh(rneb_1D, temp_1D, emis_1D, &
+     & iwcon_1D, rad_1D, &
+     & pres, dz, &
+     & rhodz_1D, cc_tot_mesh, cc_hc_mesh, cc_hist_mesh, pcld_hc_mesh,&
+     & tcld_hc_mesh, &
+     & em_hc_mesh, iwp_hc_mesh, deltaz_hc_mesh, &
+     & cc_Cb_mesh, cc_ThCi_mesh, cc_Anv_mesh, &
+     & pcld_Cb_mesh, tcld_Cb_mesh, em_Cb_mesh, &
+     & pcld_ThCi_mesh, tcld_ThCi_mesh, em_ThCi_mesh, &
+     & pcld_Anv_mesh, tcld_Anv_mesh, em_Anv_mesh, &
+     & em_hist_mesh, iwp_hist_mesh, deltaz_hist_mesh, rad_hist_mesh)
+
+       USE dimphy
+
+       REAL, DIMENSION(klev), intent(in) :: rneb_1D, temp_1D, emis_1D, &
+     & iwcon_1D, rad_1D
+        REAL, DIMENSION(klev), intent(in) :: pres, dz, rhodz_1D
+        REAL, intent(out) :: cc_tot_mesh, cc_hc_mesh, cc_hist_mesh
+        REAL, intent(out) :: cc_Cb_mesh, cc_ThCi_mesh, cc_Anv_mesh
+        REAL, intent(out) :: em_hc_mesh, pcld_hc_mesh, tcld_hc_mesh, &
+     & iwp_hc_mesh
+
+        REAL, intent(out) :: pcld_Cb_mesh, tcld_Cb_mesh, em_Cb_mesh
+        REAL, intent(out) :: pcld_ThCi_mesh, tcld_ThCi_mesh, &
+     & em_ThCi_mesh
+        REAL, intent(out) :: pcld_Anv_mesh, tcld_Anv_mesh, em_Anv_mesh
+
+        REAL, intent(out) :: em_hist_mesh, iwp_hist_mesh, rad_hist_mesh
+        REAL, intent(out) :: deltaz_hc_mesh, deltaz_hist_mesh
+
+        REAL, DIMENSION(:), allocatable :: rneb_cs, temp_cs, emis_cs, &
+     & iwco_cs
+        REAL, DIMENSION(:), allocatable :: pres_cs, dz_cs, rad_cs, &
+     & rhodz_cs
+
+        INTEGER :: i,j,l
+        INTEGER :: ltop, itop, ibot, num_cs, N_cs, len_cs, ics
+
+        REAL :: som_emi_hc,som_pcl_hc,som_tcl_hc,som_iwp_hc,som_hc,&
+     & som_hist
+        REAL :: som_emi_hist, som_iwp_hist, som_deltaz_hc, &
+     & som_deltaz_hist
+        REAL :: som_rad_hist
+        REAL :: som_Cb, som_ThCi, som_Anv
+        REAL :: som_emi_Cb, som_tcld_Cb, som_pcld_Cb
+        REAL :: som_emi_Anv, som_tcld_Anv, som_pcld_Anv
+        REAL :: som_emi_ThCi, som_tcld_ThCi, som_pcld_ThCi
+        REAL :: tsom_tot, tsom_hc, tsom_hist
+        REAL :: prod, prod_hh
+
+        REAL :: cc_tot_cs, cc_hc_cs, cc_hist_cs
+        REAL :: cc_Cb_cs, cc_ThCi_cs, cc_Anv_cs
+        REAL :: pcld_hc_cs, tcld_hc_cs
+        REAL :: em_hc_cs, iwp_hc_cs, deltaz_hc_cs
+        REAL :: pcld_Cb_cs, tcld_Cb_cs, em_Cb_cs
+        REAL :: pcld_ThCi_cs, tcld_ThCi_cs, em_ThCi_cs
+        REAL :: pcld_Anv_cs, tcld_Anv_cs, em_Anv_cs
+        REAL :: em_hist_cs, iwp_hist_cs, deltaz_hist_cs, rad_hist_cs
+
+        REAL, DIMENSION(klev) :: test_tot, test_hc, test_hist
+        REAL, DIMENSION(klev) :: test_pcld, test_tcld, test_em, test_iwp
+
+        CHARACTER (len = 50)      :: modname = 'simu_airs.sim_mesh'
+        CHARACTER (len = 160)     :: abort_message
+        
+
+        do j = 1, klev
+          WRITE(lunout,*) 'simu_airs, j, rneb_1D =', rneb_1D(j)
+        enddo
+
+! Definition des structures nuageuses, de la plus haute a la plus basse
+
+        num_cs = 0
+        ltop = klev-1
+
+        prod = 1.
+
+        som_emi_hc = 0.
+        som_emi_hist = 0.
+        som_pcl_hc = 0.
+        som_tcl_hc = 0.
+        som_iwp_hc = 0.
+        som_iwp_hist = 0.
+        som_deltaz_hc = 0.
+        som_deltaz_hist = 0.
+        som_rad_hist = 0.
+        som_hc = 0.
+        som_hist = 0.
+
+        som_Cb = 0.
+        som_ThCi = 0.
+        som_Anv = 0.
+
+        som_emi_Cb = 0.
+        som_pcld_Cb = 0.
+        som_tcld_Cb = 0.
+
+        som_emi_ThCi = 0.
+        som_pcld_ThCi = 0.
+        som_tcld_ThCi = 0.
+
+        som_emi_Anv = 0.
+        som_pcld_Anv = 0.
+        som_tcld_Anv = 0.
+
+        tsom_tot = 0.
+        tsom_hc = 0.
+        tsom_hist = 0.
+
+        do while (ltop .ge. 1)   ! Boucle sur toute la colonne
+
+        itop = 0
+
+        do l = ltop,1,-1
+
+        if (itop .eq. 0 .and. rneb_1D(l) .gt. 0.001 ) then
+        itop = l
+        endif
+
+        enddo
+
+        ibot = itop
+
+        do while (rneb_1D(ibot) .gt. 0.001 .and. ibot .ge. 1)
+        ibot = ibot -1
+        enddo
+
+
+        ibot = ibot+1
+
+        if (itop .gt. 0) then    ! itop > 0
+
+        num_cs = num_cs +1
+        len_cs = itop-ibot+1
+
+! Allocation et definition des variables de la structure nuageuse
+! le premier indice denote ce qui est le plus haut
+
+        allocate (rneb_cs(len_cs))
+        allocate (temp_cs(len_cs))
+        allocate (emis_cs(len_cs))
+        allocate (iwco_cs(len_cs))
+        allocate (pres_cs(len_cs))
+        allocate (dz_cs(len_cs))
+        allocate (rad_cs(len_cs))
+        allocate (rhodz_cs(len_cs))
+
+        ics = 0
+
+        do i = itop, ibot, -1
+        ics = ics + 1
+        rneb_cs(ics) = rneb_1D(i)
+        temp_cs(ics) = temp_1D(i)
+        emis_cs(ics) = emis_1D(i)
+        iwco_cs(ics) = iwcon_1D(i)
+        rad_cs(ics) = rad_1D(i)
+        pres_cs(ics) = pres(i)
+        dz_cs(ics) = dz(i)
+        rhodz_cs(ics) = rhodz_1D(i)
+        enddo
+
+! Appel du sous_programme cloud_structure
+
+        call cloud_structure(len_cs,rneb_cs,temp_cs,emis_cs,iwco_cs,&
+     & pres_cs, dz_cs, rhodz_cs, rad_cs, &
+     & cc_tot_cs, cc_hc_cs, cc_hist_cs, &
+     & cc_Cb_cs, cc_ThCi_cs, cc_Anv_cs, &
+     & pcld_hc_cs, tcld_hc_cs, &
+     & em_hc_cs, iwp_hc_cs, deltaz_hc_cs, &
+     & pcld_Cb_cs, tcld_Cb_cs, em_Cb_cs, &
+     & pcld_ThCi_cs, tcld_ThCi_cs, em_ThCi_cs, &
+     & pcld_Anv_cs, tcld_Anv_cs, em_Anv_cs, &
+     & em_hist_cs, iwp_hist_cs, deltaz_hist_cs, rad_hist_cs)
+
+
+        deallocate (rneb_cs)
+        deallocate (temp_cs)
+        deallocate (emis_cs)
+        deallocate (iwco_cs)
+        deallocate (pres_cs)
+        deallocate (dz_cs)
+        deallocate (rad_cs)
+        deallocate (rhodz_cs)
+
+
+! Pour la couverture nuageuse sur la maille
+
+        prod_hh = prod
+
+        prod = prod*(1.-cc_tot_cs)
+
+! Pour les autres variables definies sur la maille
+
+        som_emi_hc = som_emi_hc + em_hc_cs*cc_hc_cs*prod_hh
+        som_iwp_hc = som_iwp_hc + iwp_hc_cs*cc_hc_cs*prod_hh
+        som_deltaz_hc = som_deltaz_hc + deltaz_hc_cs*cc_hc_cs*prod_hh
+
+        som_emi_Cb = som_emi_Cb + em_Cb_cs*cc_Cb_cs*prod_hh
+        som_tcld_Cb = som_tcld_Cb + tcld_Cb_cs*cc_Cb_cs*prod_hh
+        som_pcld_Cb = som_pcld_Cb + pcld_Cb_cs*cc_Cb_cs*prod_hh
+
+        som_emi_ThCi = som_emi_ThCi + em_ThCi_cs*cc_ThCi_cs*prod_hh
+        som_tcld_ThCi = som_tcld_ThCi + tcld_ThCi_cs*cc_ThCi_cs*prod_hh
+        som_pcld_ThCi = som_pcld_ThCi + pcld_ThCi_cs*cc_ThCi_cs*prod_hh
+
+        som_emi_Anv = som_emi_Anv + em_Anv_cs*cc_Anv_cs*prod_hh
+        som_tcld_Anv = som_tcld_Anv + tcld_Anv_cs*cc_Anv_cs*prod_hh
+        som_pcld_Anv = som_pcld_Anv + pcld_Anv_cs*cc_Anv_cs*prod_hh
+
+        som_emi_hist = som_emi_hist + em_hist_cs*cc_hist_cs*prod_hh
+        som_iwp_hist = som_iwp_hist + iwp_hist_cs*cc_hist_cs*prod_hh
+        som_deltaz_hist = som_deltaz_hist + &
+     & deltaz_hist_cs*cc_hist_cs*prod_hh
+        som_rad_hist = som_rad_hist + rad_hist_cs*cc_hist_cs*prod_hh
+
+        som_pcl_hc = som_pcl_hc + pcld_hc_cs*cc_hc_cs*prod_hh
+        som_tcl_hc = som_tcl_hc + tcld_hc_cs*cc_hc_cs*prod_hh
+
+        som_hc = som_hc + cc_hc_cs*prod_hh
+        som_hist = som_hist + cc_hist_cs*prod_hh
+
+        som_Cb = som_Cb + cc_Cb_cs*prod_hh
+        som_ThCi = som_ThCi + cc_ThCi_cs*prod_hh
+        som_Anv = som_Anv + cc_Anv_cs*prod_hh
+
+
+! Pour test
+        
+        call test_bornes('cc_tot_cs     ',cc_tot_cs,1.,0.)
+        call test_bornes('cc_hc_cs      ',cc_hc_cs,1.,0.)
+        call test_bornes('cc_hist_cs    ',cc_hist_cs,1.,0.)
+        call test_bornes('pcld_hc_cs    ',pcld_hc_cs,1200.,0.)
+        call test_bornes('tcld_hc_cs    ',tcld_hc_cs,1000.,100.)
+        call test_bornes('em_hc_cs      ',em_hc_cs,1000.,0.048)
+
+        test_tot(num_cs) = cc_tot_cs
+        test_hc(num_cs) = cc_hc_cs
+        test_hist(num_cs) = cc_hist_cs
+        test_pcld(num_cs) = pcld_hc_cs
+        test_tcld(num_cs) = tcld_hc_cs
+        test_em(num_cs) = em_hc_cs
+        test_iwp(num_cs) = iwp_hc_cs
+
+        tsom_tot = tsom_tot + cc_tot_cs
+        tsom_hc = tsom_hc + cc_hc_cs
+        tsom_hist = tsom_hist + cc_hist_cs
+
+
+        endif                   ! itop > 0
+
+        ltop = ibot -1
+
+        enddo                   ! fin de la boucle sur la colonne
+
+        N_CS = num_cs
+
+
+! Determination des variables de sortie
+
+        if (N_CS .gt. 0) then   ! if N_CS>0
+
+        cc_tot_mesh = 1. - prod
+
+        cc_hc_mesh = som_hc
+        cc_hist_mesh = som_hist
+
+        cc_Cb_mesh = som_Cb
+        cc_ThCi_mesh = som_ThCi
+        cc_Anv_mesh = som_Anv
+
+        call normal2_undef(pcld_hc_mesh,som_pcl_hc, &
+     & cc_hc_mesh)
+        call normal2_undef(tcld_hc_mesh,som_tcl_hc, &
+     & cc_hc_mesh)
+        call normal2_undef(em_hc_mesh,som_emi_hc, &
+     & cc_hc_mesh)
+        call normal2_undef(iwp_hc_mesh,som_iwp_hc, &
+     & cc_hc_mesh)
+        call normal2_undef(deltaz_hc_mesh,som_deltaz_hc, &
+     & cc_hc_mesh)
+
+        call normal2_undef(em_Cb_mesh,som_emi_Cb, &
+     & cc_Cb_mesh)
+        call normal2_undef(tcld_Cb_mesh,som_tcld_Cb, &
+     & cc_Cb_mesh)
+        call normal2_undef(pcld_Cb_mesh,som_pcld_Cb, &
+     & cc_Cb_mesh)
+
+        call normal2_undef(em_ThCi_mesh,som_emi_ThCi, &
+     & cc_ThCi_mesh)
+        call normal2_undef(tcld_ThCi_mesh,som_tcld_ThCi, &
+     & cc_ThCi_mesh)
+        call normal2_undef(pcld_ThCi_mesh,som_pcld_ThCi, &
+     & cc_ThCi_mesh)
+
+       call normal2_undef(em_Anv_mesh,som_emi_Anv, &
+     & cc_Anv_mesh)
+        call normal2_undef(tcld_Anv_mesh,som_tcld_Anv, &
+     & cc_Anv_mesh)
+        call normal2_undef(pcld_Anv_mesh,som_pcld_Anv, &
+     & cc_Anv_mesh)
+
+
+        call normal2_undef(em_hist_mesh,som_emi_hist, &
+     & cc_hist_mesh)
+        call normal2_undef(iwp_hist_mesh,som_iwp_hist, &
+     & cc_hist_mesh)
+        call normal2_undef(deltaz_hist_mesh,som_deltaz_hist, &
+     & cc_hist_mesh)
+        call normal2_undef(rad_hist_mesh,som_rad_hist, &
+     & cc_hist_mesh)
+
+
+! Tests 
+
+        ! Tests
+
+       if (cc_tot_mesh .gt. tsom_tot .and. &
+     & abs(cc_tot_mesh-tsom_tot) .gt. 1.e-4) then
+           WRITE(abort_message,*)'cc_tot_mesh > tsom_tot', cc_tot_mesh, tsom_tot
+           CALL abort_physic(modname,abort_message,1)
+        endif
+
+        if (cc_tot_mesh .lt. maxval(test_tot(1:N_CS)) .and. &
+     & abs(cc_tot_mesh-maxval(test_tot(1:N_CS))) .gt. 1.e-4) then
+           WRITE(abort_message,*) 'cc_tot_mesh < max', cc_tot_mesh, maxval(test_tot(1:N_CS))
+           CALL abort_physic(modname,abort_message,1)
+        endif
+
+        if (cc_hc_mesh .gt. tsom_hc .and. &
+     & abs(cc_hc_mesh-tsom_hc) .gt. 1.e-4) then
+           WRITE(abort_message,*) 'cc_hc_mesh > tsom_hc', cc_hc_mesh, tsom_hc
+           CALL abort_physic(modname,abort_message,1)
+        endif
+
+        if (cc_hc_mesh .lt. maxval(test_hc(1:N_CS)) .and. &
+     & abs(cc_hc_mesh-maxval(test_hc(1:N_CS))) .gt. 1.e-4) then
+           WRITE(abort_message,*) 'cc_hc_mesh < max', cc_hc_mesh, maxval(test_hc(1:N_CS))
+           CALL abort_physic(modname,abort_message,1)
+        endif
+
+        if (cc_hist_mesh .gt. tsom_hist .and. &
+     & abs(cc_hist_mesh-tsom_hist) .gt. 1.e-4) then
+           WRITE(abort_message,*) 'cc_hist_mesh > tsom_hist', cc_hist_mesh, tsom_hist
+           CALL abort_physic(modname,abort_message,1)
+        endif
+
+        if (cc_hist_mesh .lt. 0.) then
+           WRITE(abort_message,*) 'cc_hist_mesh < 0', cc_hist_mesh
+           CALL abort_physic(modname,abort_message,1)
+        endif
+
+        if ((pcld_hc_mesh .gt. maxval(test_pcld(1:N_CS)) .or. &
+     & pcld_hc_mesh .lt. minval(test_pcld(1:N_CS))) .and. &
+     & abs(pcld_hc_mesh-maxval(test_pcld(1:N_CS))) .gt. 1. .and. &
+     & maxval(test_pcld(1:N_CS)) .ne. 999. &
+     & .and. minval(test_pcld(1:N_CS)) .ne. 999.) then
+           WRITE(abort_message,*) 'pcld_hc_mesh est faux', pcld_hc_mesh, maxval(test_pcld(1:N_CS)), &
+     & minval(test_pcld(1:N_CS))
+           CALL abort_physic(modname,abort_message,1)
+        endif
+
+       if ((tcld_hc_mesh .gt. maxval(test_tcld(1:N_CS)) .or. &
+     & tcld_hc_mesh .lt. minval(test_tcld(1:N_CS))) .and. &
+     & abs(tcld_hc_mesh-maxval(test_tcld(1:N_CS))) .gt. 0.1 .and. &
+     & maxval(test_tcld(1:N_CS)) .ne. 999. &
+     & .and. minval(test_tcld(1:N_CS)) .ne. 999.) then
+           WRITE(abort_message,*) 'tcld_hc_mesh est faux', tcld_hc_mesh, maxval(test_tcld(1:N_CS)), &
+                & minval(test_tcld(1:N_CS))
+           CALL abort_physic(modname,abort_message,1)
+        endif
+
+        if ((em_hc_mesh .gt. maxval(test_em(1:N_CS)) .or. &
+     & em_hc_mesh .lt. minval(test_em(1:N_CS))) .and. &
+     & abs(em_hc_mesh-maxval(test_em(1:N_CS))) .gt. 1.e-4 .and. &
+     & minval(test_em(1:N_CS)) .ne. 999. .and. &
+     & maxval(test_em(1:N_CS)) .ne. 999. ) then
+           WRITE(abort_message,*) 'em_hc_mesh est faux', em_hc_mesh, maxval(test_em(1:N_CS)), &
+     & minval(test_em(1:N_CS))
+           CALL abort_physic(modname,abort_message,1)
+        endif
+
+        else               ! if N_CS>0
+
+        cc_tot_mesh = 0.
+        cc_hc_mesh = 0.
+        cc_hist_mesh = 0.
+
+        cc_Cb_mesh = 0.
+        cc_ThCi_mesh = 0.
+        cc_Anv_mesh = 0.
+
+        iwp_hc_mesh = undef 
+        deltaz_hc_mesh = undef 
+        em_hc_mesh = undef 
+        iwp_hist_mesh = undef 
+        deltaz_hist_mesh = undef 
+        rad_hist_mesh = undef 
+        em_hist_mesh = undef 
+        pcld_hc_mesh = undef 
+        tcld_hc_mesh = undef 
+
+        pcld_Cb_mesh = undef 
+        tcld_Cb_mesh = undef 
+        em_Cb_mesh = undef 
+
+        pcld_ThCi_mesh = undef 
+        tcld_ThCi_mesh = undef 
+        em_ThCi_mesh = undef 
+
+        pcld_Anv_mesh = undef 
+        tcld_Anv_mesh = undef 
+        em_Anv_mesh = undef 
+
+
+        endif                  ! if N_CS>0
+
+        end subroutine sim_mesh
+
+        subroutine test_bornes(sx,x,bsup,binf)
+
+        REAL, intent(in) :: x, bsup, binf
+        character*14, intent(in) :: sx
+        CHARACTER (len = 50)      :: modname = 'simu_airs.test_bornes'
+        CHARACTER (len = 160)     :: abort_message
+
+        if (x .gt. bsup .or. x .lt. binf) then
+          WRITE(abort_message,*) sx, 'est faux', sx, x
+          CALL abort_physic(modname,abort_message,1)
+        endif
+ 
+        end subroutine test_bornes
+
+        end module m_simu_airs
+
+
+        subroutine simu_airs &
+     & (itap, rneb_airs, temp_airs, cldemi_airs, iwcon0_airs, rad_airs, &
+     & geop_airs, pplay_airs, paprs_airs, &
+     & map_prop_hc,map_prop_hist,&
+     & map_emis_hc,map_iwp_hc,map_deltaz_hc,map_pcld_hc,map_tcld_hc,&
+     & map_emis_Cb,map_pcld_Cb,map_tcld_Cb,&
+     & map_emis_ThCi,map_pcld_ThCi,map_tcld_ThCi,&
+     & map_emis_Anv,map_pcld_Anv,map_tcld_Anv,&
+     & map_emis_hist,map_iwp_hist,map_deltaz_hist,map_rad_hist,&
+     & map_ntot,map_hc,map_hist,&
+     & map_Cb,map_ThCi,map_Anv,alt_tropo )
+
+        USE dimphy
+        USE m_simu_airs
+
+        IMPLICIT NONE
+
+        include "YOMCST.h"
+
+        INTEGER,intent(in) :: itap
+
+        REAL, DIMENSION(klon,klev), intent(in) :: &
+     & rneb_airs, temp_airs, cldemi_airs, iwcon0_airs, &
+     & rad_airs, geop_airs, pplay_airs, paprs_airs
+
+       REAL, DIMENSION(klon,klev) :: &
+     & rhodz_airs, rho_airs, iwcon_airs
+
+        REAL, DIMENSION(klon),intent(out) :: alt_tropo
+
+        REAL, DIMENSION(klev) :: rneb_1D, temp_1D, &
+     & emis_1D, rad_1D, pres_1D, alt_1D, &
+     & rhodz_1D, dz_1D, iwcon_1D
+
+        INTEGER :: i, j
+
+        REAL :: cc_tot_mesh, cc_hc_mesh, cc_hist_mesh
+        REAL :: cc_Cb_mesh, cc_ThCi_mesh, cc_Anv_mesh
+        REAL :: pcld_hc_mesh, tcld_hc_mesh, em_hc_mesh, iwp_hc_mesh
+        REAL :: em_hist_mesh, iwp_hist_mesh
+        REAL :: deltaz_hc_mesh, deltaz_hist_mesh, rad_hist_mesh
+        REAL :: pcld_Cb_mesh, tcld_Cb_mesh, em_Cb_mesh
+        REAL :: pcld_ThCi_mesh, tcld_ThCi_mesh, em_ThCi_mesh
+        REAL :: pcld_Anv_mesh, tcld_Anv_mesh, em_Anv_mesh
+
+        REAL, DIMENSION(klon),intent(out) :: map_prop_hc, map_prop_hist
+        REAL, DIMENSION(klon),intent(out) :: map_emis_hc, map_iwp_hc
+        REAL, DIMENSION(klon),intent(out) :: map_deltaz_hc, map_pcld_hc
+        REAL, DIMENSION(klon),intent(out) :: map_tcld_hc
+        REAL, DIMENSION(klon),intent(out) :: map_emis_Cb,map_pcld_Cb,map_tcld_Cb 
+        REAL, DIMENSION(klon),intent(out) :: &
+     & map_emis_ThCi,map_pcld_ThCi,map_tcld_ThCi
+        REAL, DIMENSION(klon),intent(out) :: &
+     & map_emis_Anv,map_pcld_Anv,map_tcld_Anv
+        REAL, DIMENSION(klon),intent(out) :: &
+     & map_emis_hist,map_iwp_hist,map_deltaz_hist,&
+     & map_rad_hist
+        REAL, DIMENSION(klon),intent(out) :: map_ntot,map_hc,map_hist
+        REAL, DIMENSION(klon),intent(out) :: map_Cb,map_ThCi,map_Anv
+ 
+ 
+        write(*,*) 'simu_airs'
+        write(*,*) 'itap, klon, klev', itap, klon, klev
+        write(*,*) 'RG, RD =', RG, RD
+
+
+! Definition des variables 1D
+
+        do i = 1, klon
+        do j = 1, klev-1
+        rhodz_airs(i,j) = &
+     & (paprs_airs(i,j)-paprs_airs(i,j+1))/RG
+        enddo
+        rhodz_airs(i,klev) = 0.
+        enddo
+
+        do i = 1, klon
+        do j = 1,klev
+        rho_airs(i,j) = &
+     & pplay_airs(i,j)/(temp_airs(i,j)*RD)
+
+        if (rneb_airs(i,j) .gt. 0.001) then
+        iwcon_airs(i,j) = iwcon0_airs(i,j)/rneb_airs(i,j)
+        else
+        iwcon_airs(i,j) = 0.
+        endif
+ 
+        enddo
+        enddo
+
+!=============================================================================
+
+        do i = 1, klon  ! boucle sur les points de grille
+
+!=============================================================================
+        
+        do j = 1,klev
+
+        rneb_1D(j) = rneb_airs(i,j)
+        temp_1D(j) = temp_airs(i,j)
+        emis_1D(j) = cldemi_airs(i,j)
+        iwcon_1D(j) = iwcon_airs(i,j)
+        rad_1D(j) = rad_airs(i,j)
+        pres_1D(j) = pplay_airs(i,j)
+        alt_1D(j) = geop_airs(i,j)/RG
+        rhodz_1D(j) = rhodz_airs(i,j)
+        dz_1D(j) = rhodz_airs(i,j)/rho_airs(i,j)
+
+        enddo
+
+        alt_tropo(i) = &
+     & search_tropopause(pres_1D/100.,temp_1D,alt_1D,klev)
+
+
+! Appel du ss-programme sim_mesh
+
+!        if (itap .eq. 1 ) then
+
+        call sim_mesh(rneb_1D, temp_1D, emis_1D, iwcon_1D, rad_1D, &
+     & pres_1D, dz_1D, rhodz_1D, &
+     & cc_tot_mesh, cc_hc_mesh, cc_hist_mesh, &
+     & pcld_hc_mesh, tcld_hc_mesh, em_hc_mesh, iwp_hc_mesh, &
+     & deltaz_hc_mesh,&
+     & cc_Cb_mesh, cc_ThCi_mesh, cc_Anv_mesh, &
+     & pcld_Cb_mesh, tcld_Cb_mesh, em_Cb_mesh, &
+     & pcld_ThCi_mesh, tcld_ThCi_mesh, em_ThCi_mesh, &
+     & pcld_Anv_mesh, tcld_Anv_mesh, em_Anv_mesh, &
+     & em_hist_mesh, iwp_hist_mesh, deltaz_hist_mesh, rad_hist_mesh)
+
+         write(*,*) '===================================='
+         write(*,*) 'itap, i:', itap, i 
+         write(*,*) 'cc_tot, cc_hc, cc_hist, pcld_hc, tcld_hc, em_hc, &
+     & iwp_hc, em_hist, iwp_hist ='
+         write(*,*) cc_tot_mesh, cc_hc_mesh, cc_hist_mesh
+         write(*,*) pcld_hc_mesh, tcld_hc_mesh, em_hc_mesh, iwp_hc_mesh
+         write(*,*)  em_hist_mesh, iwp_hist_mesh
+
+!        endif
+
+! Definition des variables a ecrire dans le fichier de sortie
+
+        call normal2_undef(map_prop_hc(i),cc_hc_mesh, &
+     & cc_tot_mesh)
+        call normal2_undef(map_prop_hist(i),cc_hist_mesh, &
+     & cc_tot_mesh)
+
+       map_emis_hc(i) = em_hc_mesh
+       map_iwp_hc(i) = iwp_hc_mesh
+       map_deltaz_hc(i) = deltaz_hc_mesh
+       map_pcld_hc(i) = pcld_hc_mesh
+       map_tcld_hc(i) = tcld_hc_mesh
+
+       map_emis_Cb(i) = em_Cb_mesh
+       map_pcld_Cb(i) = pcld_Cb_mesh
+       map_tcld_Cb(i) = tcld_Cb_mesh
+
+       map_emis_ThCi(i) = em_ThCi_mesh
+       map_pcld_ThCi(i) = pcld_ThCi_mesh
+       map_tcld_ThCi(i) = tcld_ThCi_mesh
+
+       map_emis_Anv(i) = em_Anv_mesh
+       map_pcld_Anv(i) = pcld_Anv_mesh
+       map_tcld_Anv(i) = tcld_Anv_mesh
+
+       map_emis_hist(i) = em_hist_mesh
+       map_iwp_hist(i) = iwp_hist_mesh
+       map_deltaz_hist(i) = deltaz_hist_mesh
+       map_rad_hist(i) = rad_hist_mesh
+
+       map_ntot(i) = cc_tot_mesh
+       map_hc(i) = cc_hc_mesh
+       map_hist(i) = cc_hist_mesh
+
+       map_Cb(i) = cc_Cb_mesh
+       map_ThCi(i) = cc_ThCi_mesh
+       map_Anv(i) = cc_Anv_mesh
+
+
+        enddo         ! fin boucle sur les points de grille
+
+        
+
+        end subroutine simu_airs
+
Index: DZ6/trunk/libf/phylmd/slab_heat_transp_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/slab_heat_transp_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,1131 +1,0 @@
-!
-MODULE slab_heat_transp_mod
-!
-! Slab ocean : temperature tendencies due to horizontal diffusion 
-! and / or Ekman transport
-
-USE mod_grid_phy_lmdz, ONLY: nbp_lon, nbp_lat, klon_glo
-IMPLICIT NONE
-
-  ! Variables copied over from dyn3d dynamics:
-  REAL,SAVE,ALLOCATABLE :: fext(:) ! Coriolis f times cell area
-  !$OMP THREADPRIVATE(fext)
-  REAL,SAVE,ALLOCATABLE :: beta(:) ! df/dy
-  !$OMP THREADPRIVATE(beta)
-  REAL,SAVE,ALLOCATABLE :: unsairez(:) ! 1/cell area
-  !$OMP THREADPRIVATE(unsairez)
-  REAL,SAVE,ALLOCATABLE :: unsaire(:)
-  !$OMP THREADPRIVATE(unsaire)
-  REAL,SAVE,ALLOCATABLE :: cu(:) ! cell longitude dim (m)
-  !$OMP THREADPRIVATE(cu)
-  REAL,SAVE,ALLOCATABLE :: cv(:) ! cell latitude dim (m)
-  !$OMP THREADPRIVATE(cv)
-  REAL,SAVE,ALLOCATABLE :: cuvsurcv(:) ! cu/cv (v points)
-  !$OMP THREADPRIVATE(cuvsurcv)
-  REAL,SAVE,ALLOCATABLE :: cvusurcu(:) ! cv/cu (u points)
-  !$OMP THREADPRIVATE(cvusurcu)
-  REAL,SAVE,ALLOCATABLE :: aire(:) ! cell area
-  !$OMP THREADPRIVATE(aire)
-  REAL,SAVE :: apoln ! area of north pole points
-  !$OMP THREADPRIVATE(apoln)
-  REAL,SAVE :: apols ! area of south pole points
-  !$OMP THREADPRIVATE(apols)
-  REAL,SAVE,ALLOCATABLE :: aireu(:) ! area of u cells 
-  !$OMP THREADPRIVATE(aireu)
-  REAL,SAVE,ALLOCATABLE :: airev(:) ! area of v cells
-  !$OMP THREADPRIVATE(airev)
-
-  ! Local parameters for slab transport
-  LOGICAL,SAVE :: alpha_var ! variable coef for deep temp (1 layer)
-  !$OMP THREADPRIVATE(alpha_var)
-  LOGICAL,SAVE :: slab_upstream ! upstream scheme ? (1 layer)
-  !$OMP THREADPRIVATE(slab_upstream)
-  LOGICAL,SAVE :: slab_sverdrup ! use wind stress curl at equator
-  !$OMP THREADPRIVATE(slab_sverdrup)
-  LOGICAL,SAVE :: slab_tyeq ! use merid wind stress at equator
-  !$OMP THREADPRIVATE(slab_tyeq)
-  LOGICAL,SAVE :: ekman_zonadv ! use zonal advection by Ekman currents
-  !$OMP THREADPRIVATE(ekman_zonadv)
-  LOGICAL,SAVE :: ekman_zonavg ! zonally average wind stress
-  !$OMP THREADPRIVATE(ekman_zonavg)
-
-  REAL,SAVE :: alpham
-  !$OMP THREADPRIVATE(alpham)
-  REAL,SAVE :: gmkappa
-  !$OMP THREADPRIVATE(gmkappa)
-  REAL,SAVE :: gm_smax
-  !$OMP THREADPRIVATE(gm_smax)
-
-! geometry variables : f, beta, mask...
-  REAL,SAVE,ALLOCATABLE :: zmasqu(:) ! continent mask for zonal mass flux
-  !$OMP THREADPRIVATE(zmasqu)
-  REAL,SAVE,ALLOCATABLE :: zmasqv(:) ! continent mask for merid mass flux
-  !$OMP THREADPRIVATE(zmasqv)
-  REAL,SAVE,ALLOCATABLE :: unsfv(:) ! 1/f, v points
-  !$OMP THREADPRIVATE(unsfv)
-  REAL,SAVE,ALLOCATABLE :: unsbv(:) ! 1/beta
-  !$OMP THREADPRIVATE(unsbv)
-  REAL,SAVE,ALLOCATABLE :: unsev(:) ! 1/epsilon (drag)
-  !$OMP THREADPRIVATE(unsev)
-  REAL,SAVE,ALLOCATABLE :: unsfu(:) ! 1/F, u points
-  !$OMP THREADPRIVATE(unsfu)
-  REAL,SAVE,ALLOCATABLE :: unseu(:)
-  !$OMP THREADPRIVATE(unseu)
-
-  ! Routines from dyn3d, valid on global dynamics grid only:
-  PRIVATE :: gr_fi_dyn, gr_dyn_fi ! to go between 1D nd 2D horiz grid
-  PRIVATE :: gr_scal_v,gr_v_scal,gr_scal_u ! change on 2D grid U,V, T points
-  PRIVATE :: grad,diverg
-
-CONTAINS
- 
-  SUBROUTINE ini_slab_transp_geom(ip1jm,ip1jmp1,unsairez_,fext_,unsaire_,&
-                                  cu_,cuvsurcv_,cv_,cvusurcu_, &
-                                  aire_,apoln_,apols_, &
-                                  aireu_,airev_,rlatv, rad, omeg)
-    ! number of points in lon, lat
-    IMPLICIT NONE
-    ! Routine copies some geometry variables from the dynamical core
-    ! see global vars for meaning
-    INTEGER,INTENT(IN) :: ip1jm
-    INTEGER,INTENT(IN) :: ip1jmp1
-    REAL,INTENT(IN) :: unsairez_(ip1jm)
-    REAL,INTENT(IN) :: fext_(ip1jm)
-    REAL,INTENT(IN) :: unsaire_(ip1jmp1)
-    REAL,INTENT(IN) :: cu_(ip1jmp1)
-    REAL,INTENT(IN) :: cuvsurcv_(ip1jm)
-    REAL,INTENT(IN) :: cv_(ip1jm)
-    REAL,INTENT(IN) :: cvusurcu_(ip1jmp1)
-    REAL,INTENT(IN) :: aire_(ip1jmp1)
-    REAL,INTENT(IN) :: apoln_
-    REAL,INTENT(IN) :: apols_
-    REAL,INTENT(IN) :: aireu_(ip1jmp1)
-    REAL,INTENT(IN) :: airev_(ip1jm)
-    REAL,INTENT(IN) :: rlatv(nbp_lat-1)
-    REAL,INTENT(IN) :: rad
-    REAL,INTENT(IN) :: omeg
-
-    CHARACTER (len = 20) :: modname = 'slab_heat_transp'
-    CHARACTER (len = 80) :: abort_message
-    
-    ! Sanity check on dimensions
-    if ((ip1jm.ne.((nbp_lon+1)*(nbp_lat-1))).or. &
-        (ip1jmp1.ne.((nbp_lon+1)*nbp_lat))) then
-      abort_message="ini_slab_transp_geom Error: wrong array sizes"
-      CALL abort_physic(modname,abort_message,1)
-    endif
-! Allocations could be done only on master process/thread...
-    allocate(unsairez(ip1jm))
-    unsairez(:)=unsairez_(:)
-    allocate(fext(ip1jm))
-    fext(:)=fext_(:)
-    allocate(unsaire(ip1jmp1))
-    unsaire(:)=unsaire_(:)
-    allocate(cu(ip1jmp1))
-    cu(:)=cu_(:)
-    allocate(cuvsurcv(ip1jm))
-    cuvsurcv(:)=cuvsurcv_(:)
-    allocate(cv(ip1jm))
-    cv(:)=cv_(:)
-    allocate(cvusurcu(ip1jmp1))
-    cvusurcu(:)=cvusurcu_(:)
-    allocate(aire(ip1jmp1))
-    aire(:)=aire_(:)
-    apoln=apoln_
-    apols=apols_
-    allocate(aireu(ip1jmp1))
-    aireu(:)=aireu_(:)
-    allocate(airev(ip1jm))
-    airev(:)=airev_(:) 
-    allocate(beta(nbp_lat-1))
-    beta(:)=2*omeg*cos(rlatv(:))/rad
-
-  END SUBROUTINE ini_slab_transp_geom
-
-  SUBROUTINE ini_slab_transp(zmasq)
-
-!    USE ioipsl_getin_p_mod, only: getin_p
-    USE IOIPSL, ONLY : getin 
-    IMPLICIT NONE
-
-    REAL zmasq(klon_glo) ! ocean / continent mask, 1=continent
-    REAL zmasq_2d((nbp_lon+1)*nbp_lat)
-    REAL ff((nbp_lon+1)*(nbp_lat-1)) ! Coriolis parameter
-    REAL eps ! epsilon friction timescale (s-1)
-    INTEGER :: slab_ekman 
-    INTEGER i
-    INTEGER :: iim,iip1,jjp1,ip1jm,ip1jmp1
-
-! Some definition for grid size
-    ip1jm=(nbp_lon+1)*(nbp_lat-1)
-    ip1jmp1=(nbp_lon+1)*nbp_lat
-    iim=nbp_lon
-    iip1=nbp_lon+1
-    jjp1=nbp_lat
-    ip1jm=(nbp_lon+1)*(nbp_lat-1)
-    ip1jmp1=(nbp_lon+1)*nbp_lat
-
-! Options for Heat transport
-    ! Alpha variable?
-      alpha_var=.FALSE.
-      CALL getin('slab_alphav',alpha_var)
-      print *,'alpha variable',alpha_var
-!  centered ou upstream scheme for meridional transport
-      slab_upstream=.FALSE.
-      CALL getin('slab_upstream',slab_upstream)
-      print *,'upstream slab scheme',slab_upstream
-! Sverdrup balance at equator ?
-      slab_sverdrup=.TRUE.
-      CALL getin('slab_sverdrup',slab_sverdrup)
-      print *,'Sverdrup balance',slab_sverdrup
-! Use tauy for meridional flux at equator ?
-      slab_tyeq=.TRUE.
-      CALL getin('slab_tyeq',slab_tyeq)
-      print *,'Tauy forcing at equator',slab_tyeq
-! Use tauy for meridional flux at equator ?
-      ekman_zonadv=.TRUE.
-      CALL getin('slab_ekman_zonadv',ekman_zonadv)
-      print *,'Use Ekman flow in zonal direction',ekman_zonadv
-! Use tauy for meridional flux at equator ?
-      ekman_zonavg=.FALSE.
-      CALL getin('slab_ekman_zonavg',ekman_zonavg)
-      print *,'Use zonally-averaged wind stress ?',ekman_zonavg
-! Value of alpha
-      alpham=2./3.
-      CALL getin('slab_alpha',alpham)
-      print *,'slab_alpha',alpham
-! GM k coefficient (m2/s) for 2-layers
-      gmkappa=1000.
-      CALL getin('slab_gmkappa',gmkappa)
-      print *,'slab_gmkappa',gmkappa
-! GM k coefficient (m2/s) for 2-layers
-      gm_smax=2e-3
-      CALL getin('slab_gm_smax',gm_smax)
-      print *,'slab_gm_smax',gm_smax
-! -----------------------------------------------------------
-! Define ocean / continent mask (no flux into continent cell)
-    allocate(zmasqu(ip1jmp1))
-    allocate(zmasqv(ip1jm))
-    zmasqu=1.
-    zmasqv=1.
-
-    ! convert mask to 2D grid
-    CALL gr_fi_dyn(1,iip1,jjp1,zmasq,zmasq_2d)
-    ! put flux mask to 0 at boundaries of continent cells
-    DO i=1,ip1jmp1-1
-      IF (zmasq_2d(i).GT.1e-5 .OR. zmasq_2d(i+1).GT.1e-5) THEN
-              zmasqu(i)=0.
-      ENDIF
-    END DO
-    DO i=iip1,ip1jmp1,iip1
-      zmasqu(i)=zmasqu(i-iim)
-    END DO
-    DO i=1,ip1jm
-      IF (zmasq_2d(i).GT.1e-5 .OR. zmasq_2d(i+iip1).GT.1e-5) THEN
-              zmasqv(i)=0.
-      END IF
-    END DO
-
-! -----------------------------------------------------------
-! Coriolis and friction for Ekman transport
-    slab_ekman=2
-    CALL getin("slab_ekman",slab_ekman)
-    IF (slab_ekman.GT.0) THEN
-      allocate(unsfv(ip1jm))
-      allocate(unsev(ip1jm))
-      allocate(unsfu(ip1jmp1))
-      allocate(unseu(ip1jmp1))
-      allocate(unsbv(ip1jm))
-
-      eps=1e-5 ! Drag
-      CALL getin('slab_eps',eps)
-      print *,'epsilon=',eps
-      ff=fext*unsairez ! Coriolis
-      ! coefs to convert tau_x, tau_y to Ekman mass fluxes
-      ! on 2D grid v points
-      ! Compute correction factor [0 1] near the equator (f<<eps)
-      IF (slab_sverdrup) THEN
-         ! New formulation, sharper near equator, when eps gives Rossby Radius
-         DO i=1,ip1jm
-           unsev(i)=exp(-ff(i)*ff(i)/eps**2)
-         ENDDO
-      ELSE
-         DO i=1,ip1jm
-           unsev(i)=eps**2/(ff(i)*ff(i)+eps**2)
-         ENDDO
-      END IF ! slab_sverdrup
-      ! 1/beta
-      DO i=1,jjp1-1
-        unsbv((i-1)*iip1+1:i*iip1)=unsev((i-1)*iip1+1:i*iip1)/beta(i)
-      END DO
-      ! 1/f
-      ff=SIGN(MAX(ABS(ff),eps/100.),ff) ! avoid value 0 at equator...
-      DO i=1,ip1jm
-        unsfv(i)=(1.-unsev(i))/ff(i)
-      END DO
-      ! compute values on 2D u grid
-      ! 1/eps
-      unsev(:)=unsev(:)/eps
-      CALL gr_v_scal(1,unsfv,unsfu)
-      CALL gr_v_scal(1,unsev,unseu)
-    END IF
-  
-  END SUBROUTINE ini_slab_transp
-
-  SUBROUTINE divgrad_phy(nlevs,temp,delta)
-! Computes temperature tendency due to horizontal diffusion :
-! T Laplacian, later multiplied by diffusion coef and time-step
-
-    IMPLICIT NONE
- 
-    INTEGER, INTENT(IN) :: nlevs ! nlevs : slab layers
-    REAL, INTENT(IN)   :: temp(klon_glo,nlevs) ! slab temperature
-    REAL , INTENT(OUT) :: delta(klon_glo,nlevs) ! temp laplacian (heat flux div.)
-    REAL :: delta_2d((nbp_lon+1)*nbp_lat,nlevs)
-    REAL ghx((nbp_lon+1)*nbp_lat,nlevs), ghy((nbp_lon+1)*(nbp_lat-1),nlevs)
-    INTEGER :: ll,iip1,jjp1
- 
-    iip1=nbp_lon+1
-    jjp1=nbp_lat
-    
-    ! transpose temp to 2D horiz. grid
-    CALL gr_fi_dyn(nlevs,iip1,jjp1,temp,delta_2d)
-    ! computes gradient (proportional to heat flx)
-    CALL grad(nlevs,delta_2d,ghx,ghy)
-    ! put flux to 0 at ocean / continent boundary
-    DO ll=1,nlevs
-        ghx(:,ll)=ghx(:,ll)*zmasqu
-        ghy(:,ll)=ghy(:,ll)*zmasqv
-    END DO
-    ! flux divergence
-    CALL diverg(nlevs,ghx,ghy,delta_2d)
-    ! laplacian back to 1D grid
-    CALL gr_dyn_fi(nlevs,iip1,jjp1,delta_2d,delta)
- 
-    RETURN
-  END SUBROUTINE divgrad_phy
-
-  SUBROUTINE slab_ekman1(tx_phy,ty_phy,ts_phy,dt_phy)
-! 1.5 Layer Ekman transport temperature tendency
-! note : tendency dt later multiplied by (delta t)/(rho.H)
-! to convert from divergence of heat fluxes to T
-
-      IMPLICIT NONE
-      
-      ! tx, ty : wind stress (different grids)
-      ! fluxm, fluz : mass *or heat* fluxes
-      ! dt : temperature tendency
-      INTEGER ij
-
-      ! ts surface temp, td deep temp (diagnosed)
-      REAL ts_phy(klon_glo)
-      REAL ts((nbp_lon+1)*nbp_lat),td((nbp_lon+1)*nbp_lat)
-      ! zonal and meridional wind stress 
-      REAL tx_phy(klon_glo),ty_phy(klon_glo)
-      REAL tyu((nbp_lon+1)*nbp_lat),txu((nbp_lon+1)*nbp_lat)
-      REAL txv((nbp_lon+1)*(nbp_lat-1)),tyv((nbp_lon+1)*(nbp_lat-1))
-      REAL tcurl((nbp_lon+1)*(nbp_lat-1))
-      ! zonal and meridional Ekman mass fluxes at u, v points (2D grid)
-      REAL fluxz((nbp_lon+1)*nbp_lat),fluxm((nbp_lon+1)*(nbp_lat-1))
-      ! vertical  and absolute mass fluxes (to estimate alpha)
-      REAL fluxv((nbp_lon+1)*nbp_lat),fluxt((nbp_lon+1)*(nbp_lat-1))
-      ! temperature tendency
-      REAL dt((nbp_lon+1)*nbp_lat),dt_phy(klon_glo)
-      REAL alpha((nbp_lon+1)*nbp_lat) ! deep temperature coef
-
-      INTEGER iim,iip1,iip2,jjp1,ip1jm,ip1jmi1,ip1jmp1
-
-! Grid definitions
-      iim=nbp_lon
-      iip1=nbp_lon+1
-      iip2=nbp_lon+2
-      jjp1=nbp_lat
-      ip1jm=(nbp_lon+1)*(nbp_lat-1) ! = iip1*jjm
-      ip1jmi1=(nbp_lon+1)*(nbp_lat-1)-(nbp_lon+1) ! = ip1jm - iip1
-      ip1jmp1=(nbp_lon+1)*nbp_lat ! = iip1*jjp1
-
-! Convert taux,y to 2D  scalar grid
-! Note: 2D grid size = iim*jjm. iip1=iim+1
-! First and last points in zonal direction are the same 
-! we use 1 index ij from 1 to (iim+1)*(jjm+1)
-      ! north and south poles
-      tx_phy(1)=0.
-      tx_phy(klon_glo)=0.
-      ty_phy(1)=0.
-      ty_phy(klon_glo)=0.
-      CALL gr_fi_dyn(1,iip1,jjp1,tx_phy,txu)
-      CALL gr_fi_dyn(1,iip1,jjp1,ty_phy,tyu)
-! convert to u,v grid (Arakawa C)
-! Multiply by f or eps to get mass flux
-      ! Meridional mass flux
-      CALL gr_scal_v(1,txu,txv) ! wind stress at v points
-      IF (slab_sverdrup) THEN ! Sverdrup bal. near equator
-        tcurl=(txu(1:ip1jm)-txu(iip2:ip1jmp1))/cv(:)
-        fluxm=-tcurl*unsbv-txv*unsfv ! in kg.s-1.m-1 (zonal distance)
-      ELSE 
-        CALL gr_scal_v(1,tyu,tyv)
-        fluxm=tyv*unsev-txv*unsfv ! in kg.s-1.m-1 (zonal distance)
-      ENDIF
-      ! Zonal mass flux
-      CALL gr_scal_u(1,txu,txu) ! wind stress at u points
-      CALL gr_scal_u(1,tyu,tyu)
-      fluxz=tyu*unsfu+txu*unseu
-            
-! Correct flux: continent mask and horiz grid size
-      ! multiply m-flux by mask and dx: flux in kg.s-1
-      fluxm=fluxm*cv*cuvsurcv*zmasqv 
-      ! multiply z-flux by mask and dy: flux in kg.s-1
-      fluxz=fluxz*cu*cvusurcu*zmasqu
-
-! Compute vertical  and absolute mass flux (for variable alpha)
-      IF (alpha_var) THEN
-        DO ij=iip2,ip1jm
-        fluxv(ij)=fluxz(ij)-fluxz(ij-1)-fluxm(ij)+fluxm(ij-iip1)
-        fluxt(ij)=ABS(fluxz(ij))+ABS(fluxz(ij-1)) &
-               +ABS(fluxm(ij))+ABS(fluxm(ij-iip1))
-        ENDDO
-        DO ij=iip1,ip1jmi1,iip1
-            fluxt(ij+1)=fluxt(ij+iip1)
-            fluxv(ij+1)=fluxv(ij+iip1)
-        END DO
-        fluxt(1)=SUM(ABS(fluxm(1:iim)))
-        fluxt(ip1jmp1)=SUM(ABS(fluxm(ip1jm-iim:ip1jm-1)))
-        fluxv(1)=-SUM(fluxm(1:iim))
-        fluxv(ip1jmp1)=SUM(fluxm(ip1jm-iim:ip1jm-1))
-        fluxt=MAX(fluxt,1.e-10)
-      ENDIF
-
-! Compute alpha coefficient. 
-! Tdeep = Tsurf * alpha + 271.35 * (1-alpha)
-      IF (alpha_var) THEN
-          ! increase alpha (and Tdeep) in downwelling regions
-          ! and decrease in upwelling regions
-          ! to avoid "hot spots" where there is surface convergence
-          DO ij=iip2,ip1jm
-              alpha(ij)=alpham-fluxv(ij)/fluxt(ij)*(1.-alpham)
-          ENDDO
-          alpha(1:iip1)=alpham-fluxv(1)/fluxt(1)*(1.-alpham)
-          alpha(ip1jm+1:ip1jmp1)=alpham-fluxv(ip1jmp1)/fluxt(ip1jmp1)*(1.-alpham)
-      ELSE
-          alpha(:)=alpham
-          ! Tsurf-Tdeep ~ 10° in the Tropics
-      ENDIF
-
-! Estimate deep temperature
-      CALL gr_fi_dyn(1,iip1,jjp1,ts_phy,ts)
-      DO ij=1,ip1jmp1
-         td(ij)=271.35+(ts(ij)-271.35)*alpha(ij)
-         td(ij)=MIN(td(ij),ts(ij))
-      END DO
-       
-! Meridional heat flux: multiply mass flux by (ts-td)
-! flux in K.kg.s-1
-      IF (slab_upstream) THEN
-        ! upstream scheme to avoid hot spots
-        DO ij=1,ip1jm
-        IF (fluxm(ij).GE.0.) THEN
-           fluxm(ij)=fluxm(ij)*(ts(ij+iip1)-td(ij))
-        ELSE
-           fluxm(ij)=fluxm(ij)*(ts(ij)-td(ij+iip1))
-        END IF
-        END DO
-      ELSE
-        ! centered scheme better in mid-latitudes
-        DO ij=1,ip1jm
-          fluxm(ij)=fluxm(ij)*(ts(ij+iip1)+ts(ij)-td(ij)-td(ij+iip1))/2.
-        END DO
-      ENDIF
-
-! Zonal heat flux
-! upstream scheme
-      DO ij=iip2,ip1jm
-          fluxz(ij)=fluxz(ij)*(ts(ij)+ts(ij+1)-td(ij+1)-td(ij))/2.
-      END DO
-      DO ij=iip1*2,ip1jmp1,iip1
-           fluxz(ij)=fluxz(ij-iim)
-      END DO
-
-! temperature tendency = divergence of heat fluxes
-! dt in K.s-1.kg.m-2 (T trend times mass/horiz surface)
-      DO ij=iip2,ip1jm
-         dt(ij)=(fluxz(ij-1)-fluxz(ij)+fluxm(ij)-fluxm(ij-iip1)) &
-               /aire(ij) ! aire : grid area 
-      END DO
-      DO ij=iip1,ip1jmi1,iip1
-         dt(ij+1)=dt(ij+iip1) 
-      END DO
-! special treatment at the Poles
-      dt(1)=SUM(fluxm(1:iim))/apoln
-      dt(ip1jmp1)=-SUM(fluxm(ip1jm-iim:ip1jm-1))/apols
-      dt(2:iip1)=dt(1)
-      dt(ip1jm+1:ip1jmp1)=dt(ip1jmp1)
-
-! tendencies back to 1D grid
-      CALL gr_dyn_fi(1,iip1,jjp1,dt,dt_phy)
-
-      RETURN
-  END SUBROUTINE slab_ekman1
-
-  SUBROUTINE slab_ekman2(tx_phy,ty_phy,ts_phy,dt_phy_ek,dt_phy_gm,slab_gm)
-! Temperature tendency for 2-layers slab ocean
-! note : tendency dt later multiplied by (delta time)/(rho.H)
-! to convert from divergence of heat fluxes to T
-
-! 11/16 : Inclusion of GM-like eddy advection
-
-      IMPLICIT NONE
-      
-      LOGICAL,INTENT(in) :: slab_gm
-      ! Here, temperature and flux variables are on 2 layers
-      INTEGER ij
-
-      ! wind stress variables
-      REAL tx_phy(klon_glo),ty_phy(klon_glo)
-      REAL txv((nbp_lon+1)*(nbp_lat-1)), tyv((nbp_lon+1)*(nbp_lat-1))
-      REAL tyu((nbp_lon+1)*nbp_lat),txu((nbp_lon+1)*nbp_lat)
-      REAL tcurl((nbp_lon+1)*(nbp_lat-1))
-      ! slab temperature on  1D, 2D grid
-      REAL ts_phy(klon_glo,2), ts((nbp_lon+1)*nbp_lat,2)
-      ! Temperature gradient, v-points
-      REAL dty((nbp_lon+1)*(nbp_lat-1)),dtx((nbp_lon+1)*nbp_lat)
-      ! Vertical temperature difference, V-points
-      REAL dtz((nbp_lon+1)*(nbp_lat-1))
-      ! zonal and meridional mass fluxes at u, v points (2D grid)
-      REAL fluxz((nbp_lon+1)*nbp_lat), fluxm((nbp_lon+1)*(nbp_lat-1))
-      ! vertical mass flux between the 2 layers
-      REAL fluxv_ek((nbp_lon+1)*nbp_lat)
-      REAL fluxv_gm((nbp_lon+1)*nbp_lat)
-      ! zonal and meridional heat fluxes
-      REAL fluxtz((nbp_lon+1)*nbp_lat,2)
-      REAL fluxtm((nbp_lon+1)*(nbp_lat-1),2)
-      ! temperature tendency (in K.s-1.kg.m-2)
-      REAL dt_ek((nbp_lon+1)*nbp_lat,2), dt_phy_ek(klon_glo,2)
-      REAL dt_gm((nbp_lon+1)*nbp_lat,2), dt_phy_gm(klon_glo,2)
-      ! helper vars
-      REAL zonavg, fluxv
-      REAL, PARAMETER :: sea_den=1025. ! sea water density
-
-      INTEGER iim,iip1,iip2,jjp1,ip1jm,ip1jmi1,ip1jmp1
-
-! Grid definitions
-      iim=nbp_lon
-      iip1=nbp_lon+1
-      iip2=nbp_lon+2
-      jjp1=nbp_lat
-      ip1jm=(nbp_lon+1)*(nbp_lat-1) ! = iip1*jjm
-      ip1jmi1=(nbp_lon+1)*(nbp_lat-1)-(nbp_lon+1) ! = ip1jm - iip1
-      ip1jmp1=(nbp_lon+1)*nbp_lat ! = iip1*jjp1
-! Convert temperature to 2D grid 
-      CALL gr_fi_dyn(2,iip1,jjp1,ts_phy,ts)
-
-! ------------------------------------
-! Ekman mass fluxes and Temp tendency
-! ------------------------------------
-! Convert taux,y to 2D  scalar grid
-      ! north and south poles tx,ty no meaning
-      tx_phy(1)=0.
-      tx_phy(klon_glo)=0.
-      ty_phy(1)=0.
-      ty_phy(klon_glo)=0.
-      CALL gr_fi_dyn(1,iip1,jjp1,tx_phy,txu)
-      CALL gr_fi_dyn(1,iip1,jjp1,ty_phy,tyu)
-      IF (ekman_zonavg) THEN ! use zonal average of wind stress
-        DO ij=1,jjp1-2
-          zonavg=SUM(txu(ij*iip1+1:ij*iip1+iim))/iim
-          txu(ij*iip1+1:(ij+1)*iip1)=zonavg
-          zonavg=SUM(tyu(ij*iip1+1:ij*iip1+iim))/iim
-          tyu(ij*iip1+1:(ij+1)*iip1)=zonavg
-        END DO
-      END IF
-          
-! Divide taux,y by f or eps, and convert to 2D u,v grids
-! (Arakawa C grid)
-      ! Meridional flux
-      CALL gr_scal_v(1,txu,txv) ! wind stress at v points
-      fluxm=-txv*unsfv ! in kg.s-1.m-1 (zonal distance)
-      IF (slab_sverdrup) THEN ! Sverdrup bal. near equator
-        tcurl=(txu(1:ip1jm)-txu(iip2:ip1jmp1))/cv(:) ! dtx/dy
-        !poles curl = 0
-        tcurl(1:iip1)=0.
-        tcurl(ip1jmi1+1:ip1jm)=0.
-        fluxm=fluxm-tcurl*unsbv
-      ENDIF
-      IF (slab_tyeq) THEN ! meridional wind forcing at equator
-        CALL gr_scal_v(1,tyu,tyv)
-        fluxm=fluxm+tyv*unsev ! in kg.s-1.m-1 (zonal distance)
-      ENDIF
-!  apply continent mask, multiply by horiz grid dimension
-      fluxm=fluxm*cv*cuvsurcv*zmasqv
-
-      ! Zonal flux
-      IF (ekman_zonadv) THEN
-        CALL gr_scal_u(1,txu,txu) ! wind stress at u points
-        CALL gr_scal_u(1,tyu,tyu)
-        fluxz=tyu*unsfu+txu*unseu
-        !  apply continent mask, multiply by horiz grid dimension
-        fluxz=fluxz*cu*cvusurcu*zmasqu
-      END IF
-            
-!  Vertical mass flux from mass budget (divergence of horiz fluxes)
-      IF (ekman_zonadv) THEN
-         DO ij=iip2,ip1jm
-           fluxv_ek(ij)=fluxz(ij)-fluxz(ij-1)-fluxm(ij)+fluxm(ij-iip1)
-         ENDDO
-      ELSE 
-         DO ij=iip2,ip1jm
-           fluxv_ek(ij)=-fluxm(ij)+fluxm(ij-iip1)
-         ENDDO
-      END IF
-      DO ij=iip1,ip1jmi1,iip1
-         fluxv_ek(ij+1)=fluxv_ek(ij+iip1)
-      END DO
-!  vertical mass flux at Poles
-      fluxv_ek(1)=-SUM(fluxm(1:iim))     
-      fluxv_ek(ip1jmp1)=SUM(fluxm(ip1jm-iim:ip1jm-1))
-
-! Meridional heat fluxes 
-      DO ij=1,ip1jm
-          ! centered scheme
-          fluxtm(ij,1)=fluxm(ij)*(ts(ij+iip1,1)+ts(ij,1))/2.
-          fluxtm(ij,2)=-fluxm(ij)*(ts(ij+iip1,2)+ts(ij,2))/2.
-      END DO
-
-! Zonal heat fluxes
-! Schema upstream      
-      IF (ekman_zonadv) THEN
-        DO ij=iip2,ip1jm
-          IF (fluxz(ij).GE.0.) THEN
-                 fluxtz(ij,1)=fluxz(ij)*ts(ij,1)
-                 fluxtz(ij,2)=-fluxz(ij)*ts(ij+1,2)
-          ELSE
-                 fluxtz(ij,1)=fluxz(ij)*ts(ij+1,1)
-                 fluxtz(ij,2)=-fluxz(ij)*ts(ij,2)
-          ENDIF
-        ENDDO
-        DO ij=iip1*2,ip1jmp1,iip1
-               fluxtz(ij,:)=fluxtz(ij-iim,:)
-        END DO
-      ELSE
-        fluxtz(:,:)=0.
-      ENDIF        
-                   
-! Temperature tendency, horizontal advection:
-      DO ij=iip2,ip1jm
-         dt_ek(ij,:)=fluxtz(ij-1,:)-fluxtz(ij,:) &
-                 +fluxtm(ij,:)-fluxtm(ij-iip1,:)
-      END DO
-! Poles
-      dt_ek(1,:)=SUM(fluxtm(1:iim,:),dim=1)
-      dt_ek(ip1jmp1,:)=-SUM(fluxtm(ip1jm-iim:ip1jm-1,:),dim=1)
-
-! ------------------------------------
-! GM mass fluxes and Temp tendency
-! ------------------------------------
-     IF (slab_gm) THEN
-! Vertical Temperature difference T1-T2 on v-grid points
-      CALL gr_scal_v(1,ts(:,1)-ts(:,2),dtz)
-      dtz(:)=MAX(dtz(:),0.25) 
-! Horizontal Temperature differences 
-      CALL grad(1,(ts(:,1)+ts(:,2))/2.,dtx,dty)
-! Meridional flux = -k.s (s=dyT/dzT)
-! Continent mask, multiply by dz/dy 
-      fluxm=dty/dtz*500.*cuvsurcv*zmasqv
-! slope limitation, multiply by kappa
-      fluxm=-gmkappa*SIGN(MIN(ABS(fluxm),gm_smax*cv*cuvsurcv),dty)
-! convert to kg/s
-      fluxm(:)=fluxm(:)*sea_den
-! Zonal flux = 0. (temporary)
-      fluxz(:)=0.
-!  Vertical mass flux from mass budget (divergence of horiz fluxes)
-      DO ij=iip2,ip1jm
-        fluxv_gm(ij)=fluxz(ij)-fluxz(ij-1)-fluxm(ij)+fluxm(ij-iip1)
-      ENDDO
-      DO ij=iip1,ip1jmi1,iip1
-         fluxv_gm(ij+1)=fluxv_gm(ij+iip1)
-      END DO
-!  vertical mass flux at Poles
-      fluxv_gm(1)=-SUM(fluxm(1:iim))     
-      fluxv_gm(ip1jmp1)=SUM(fluxm(ip1jm-iim:ip1jm-1))
-
-! Meridional heat fluxes 
-      DO ij=1,ip1jm
-          ! centered scheme
-          fluxtm(ij,1)=fluxm(ij)*(ts(ij+iip1,1)+ts(ij,1))/2.
-          fluxtm(ij,2)=-fluxm(ij)*(ts(ij+iip1,2)+ts(ij,2))/2.
-      END DO
-
-! Zonal heat fluxes
-! Schema upstream      
-      DO ij=iip2,ip1jm
-      IF (fluxz(ij).GE.0.) THEN
-             fluxtz(ij,1)=fluxz(ij)*ts(ij,1)
-             fluxtz(ij,2)=-fluxz(ij)*ts(ij+1,2)
-      ELSE
-             fluxtz(ij,1)=fluxz(ij)*ts(ij+1,1)
-             fluxtz(ij,2)=-fluxz(ij)*ts(ij,2)
-      ENDIF
-      ENDDO
-      DO ij=iip1*2,ip1jmp1,iip1
-             fluxtz(ij,:)=fluxtz(ij-iim,:)
-      END DO
-                   
-! Temperature tendency :
-! divergence of horizontal heat fluxes
-      DO ij=iip2,ip1jm
-         dt_gm(ij,:)=fluxtz(ij-1,:)-fluxtz(ij,:) &
-                 +fluxtm(ij,:)-fluxtm(ij-iip1,:)
-      END DO
-! Poles
-      dt_gm(1,:)=SUM(fluxtm(1:iim,:),dim=1)
-      dt_gm(ip1jmp1,:)=-SUM(fluxtm(ip1jm-iim:ip1jm-1,:),dim=1)
-     ELSE
-       dt_gm(:,:)=0.
-       fluxv_gm(:)=0.
-     ENDIF ! slab_gm
-
-! ------------------------------------
-! Temp tendency from vertical advection
-! Divide by cell area
-! ------------------------------------
-! vertical heat flux = mass flux * T, upstream scheme
-      DO ij=iip2,ip1jm
-         fluxv=fluxv_ek(ij)+fluxv_gm(ij) ! net flux, needed for upstream scheme
-         IF (fluxv.GT.0.) THEN
-           dt_ek(ij,1)=dt_ek(ij,1)+fluxv_ek(ij)*ts(ij,2)
-           dt_ek(ij,2)=dt_ek(ij,2)-fluxv_ek(ij)*ts(ij,2)
-           dt_gm(ij,1)=dt_gm(ij,1)+fluxv_gm(ij)*ts(ij,2)
-           dt_gm(ij,2)=dt_gm(ij,2)-fluxv_gm(ij)*ts(ij,2)
-         ELSE
-           dt_ek(ij,1)=dt_ek(ij,1)+fluxv_ek(ij)*ts(ij,1)
-           dt_ek(ij,2)=dt_ek(ij,2)-fluxv_ek(ij)*ts(ij,1)
-           dt_gm(ij,1)=dt_gm(ij,1)+fluxv_gm(ij)*ts(ij,1)
-           dt_gm(ij,2)=dt_gm(ij,2)-fluxv_gm(ij)*ts(ij,1)
-         ENDIF
-         ! divide by cell area
-         dt_ek(ij,:)=dt_ek(ij,:)/aire(ij)
-         dt_gm(ij,:)=dt_gm(ij,:)/aire(ij)
-      END DO
-      ! North Pole
-      fluxv=fluxv_ek(1)+fluxv_gm(1)
-        IF (fluxv.GT.0.) THEN
-          dt_ek(1,1)=dt_ek(1,1)+fluxv_ek(1)*ts(1,2)
-          dt_ek(1,2)=dt_ek(1,2)-fluxv_ek(1)*ts(1,2)
-          dt_gm(1,1)=dt_gm(1,1)+fluxv_gm(1)*ts(1,2)
-          dt_gm(1,2)=dt_gm(1,2)-fluxv_gm(1)*ts(1,2)
-        ELSE
-          dt_ek(1,1)=dt_ek(1,1)+fluxv_ek(1)*ts(1,1)
-          dt_ek(1,2)=dt_ek(1,2)-fluxv_ek(1)*ts(1,1)
-          dt_gm(1,1)=dt_gm(1,1)+fluxv_gm(1)*ts(1,1)
-          dt_gm(1,2)=dt_gm(1,2)-fluxv_gm(1)*ts(1,1)
-        ENDIF
-      dt_ek(1,:)=dt_ek(1,:)/apoln
-      dt_gm(1,:)=dt_gm(1,:)/apoln
-      ! South pole
-      fluxv=fluxv_ek(ip1jmp1)+fluxv_gm(ip1jmp1)
-        IF (fluxv.GT.0.) THEN
-          dt_ek(ip1jmp1,1)=dt_ek(ip1jmp1,1)+fluxv_ek(ip1jmp1)*ts(ip1jmp1,2)
-          dt_ek(ip1jmp1,2)=dt_ek(ip1jmp1,2)-fluxv_ek(ip1jmp1)*ts(ip1jmp1,2)
-          dt_gm(ip1jmp1,1)=dt_gm(ip1jmp1,1)+fluxv_gm(ip1jmp1)*ts(ip1jmp1,2)
-          dt_gm(ip1jmp1,2)=dt_gm(ip1jmp1,2)-fluxv_gm(ip1jmp1)*ts(ip1jmp1,2)
-        ELSE
-          dt_ek(ip1jmp1,1)=dt_ek(ip1jmp1,1)+fluxv_ek(ip1jmp1)*ts(ip1jmp1,1)
-          dt_ek(ip1jmp1,2)=dt_ek(ip1jmp1,2)-fluxv_ek(ip1jmp1)*ts(ip1jmp1,1)
-          dt_gm(ip1jmp1,1)=dt_gm(ip1jmp1,1)+fluxv_gm(ip1jmp1)*ts(ip1jmp1,1)
-          dt_gm(ip1jmp1,2)=dt_gm(ip1jmp1,2)-fluxv_gm(ip1jmp1)*ts(ip1jmp1,1)
-        ENDIF
-      dt_ek(ip1jmp1,:)=dt_ek(ip1jmp1,:)/apols
-      dt_gm(ip1jmp1,:)=dt_gm(ip1jmp1,:)/apols
-      
-      dt_ek(2:iip1,1)=dt_ek(1,1)
-      dt_ek(2:iip1,2)=dt_ek(1,2)
-      dt_gm(2:iip1,1)=dt_gm(1,1)
-      dt_gm(2:iip1,2)=dt_gm(1,2)
-      dt_ek(ip1jm+1:ip1jmp1,1)=dt_ek(ip1jmp1,1)
-      dt_ek(ip1jm+1:ip1jmp1,2)=dt_ek(ip1jmp1,2)
-      dt_gm(ip1jm+1:ip1jmp1,1)=dt_gm(ip1jmp1,1)
-      dt_gm(ip1jm+1:ip1jmp1,2)=dt_gm(ip1jmp1,2)
-
-      DO ij=iip1,ip1jmi1,iip1
-         dt_gm(ij+1,:)=dt_gm(ij+iip1,:) 
-         dt_ek(ij+1,:)=dt_ek(ij+iip1,:) 
-      END DO
-
-! T tendency back to 1D grid...
-      CALL gr_dyn_fi(2,iip1,jjp1,dt_ek,dt_phy_ek)
-      CALL gr_dyn_fi(2,iip1,jjp1,dt_gm,dt_phy_gm)
-
-      RETURN
-  END SUBROUTINE slab_ekman2
-
-  SUBROUTINE slab_gmdiff(ts_phy,dt_phy)
-! Temperature tendency for 2-layers slab ocean
-! Due to Gent-McWilliams type eddy-induced advection
-      
-      IMPLICIT NONE
-      
-      ! Here, temperature and flux variables are on 2 layers
-      INTEGER ij
-      ! Temperature gradient, v-points
-      REAL dty((nbp_lon+1)*(nbp_lat-1)),dtx((nbp_lon+1)*nbp_lat)
-      ! Vertical temperature difference, V-points
-      REAL dtz((nbp_lon+1)*(nbp_lat-1))
-      ! slab temperature on  1D, 2D grid
-      REAL ts_phy(klon_glo,2),ts((nbp_lon+1)*nbp_lat,2)
-      ! zonal and meridional mass fluxes at u, v points (2D grid)
-      REAL fluxz((nbp_lon+1)*nbp_lat), fluxm((nbp_lon+1)*(nbp_lat-1))
-      ! vertical mass flux between the 2 layers
-      REAL fluxv((nbp_lon+1)*nbp_lat)
-      ! zonal and meridional heat fluxes
-      REAL fluxtz((nbp_lon+1)*nbp_lat,2)
-      REAL fluxtm((nbp_lon+1)*(nbp_lat-1),2)
-      ! temperature tendency (in K.s-1.kg.m-2)
-      REAL dt((nbp_lon+1)*nbp_lat,2), dt_phy(klon_glo,2)
-
-      INTEGER iim,iip1,iip2,jjp1,ip1jm,ip1jmi1,ip1jmp1
-
-! Grid definitions
-      iim=nbp_lon
-      iip1=nbp_lon+1
-      iip2=nbp_lon+2
-      jjp1=nbp_lat
-      ip1jm=(nbp_lon+1)*(nbp_lat-1) ! = iip1*jjm
-      ip1jmi1=(nbp_lon+1)*(nbp_lat-1)-(nbp_lon+1) ! = ip1jm - iip1
-      ip1jmp1=(nbp_lon+1)*nbp_lat ! = iip1*jjp1
-
-! Convert temperature to 2D grid 
-      CALL gr_fi_dyn(2,iip1,jjp1,ts_phy,ts)
-! Vertical Temperature difference T1-T2 on v-grid points
-      CALL gr_scal_v(1,ts(:,1)-ts(:,2),dtz)
-      dtz(:)=MAX(dtz(:),0.25) 
-! Horizontal Temperature differences 
-      CALL grad(1,(ts(:,1)+ts(:,2))/2.,dtx,dty)
-! Meridional flux = -k.s (s=dyT/dzT)
-! Continent mask, multiply by dz/dy 
-      fluxm=dty/dtz*500.*cuvsurcv*zmasqv
-! slope limitation, multiply by kappa
-      fluxm=-gmkappa*SIGN(MIN(ABS(fluxm),gm_smax*cv*cuvsurcv),dty)
-! Zonal flux = 0. (temporary)
-      fluxz(:)=0.
-!  Vertical mass flux from mass budget (divergence of horiz fluxes)
-      DO ij=iip2,ip1jm
-        fluxv(ij)=fluxz(ij)-fluxz(ij-1)-fluxm(ij)+fluxm(ij-iip1)
-      ENDDO
-      DO ij=iip1,ip1jmi1,iip1
-         fluxv(ij+1)=fluxv(ij+iip1)
-      END DO
-!  vertical mass flux at Poles
-      fluxv(1)=-SUM(fluxm(1:iim))     
-      fluxv(ip1jmp1)=SUM(fluxm(ip1jm-iim:ip1jm-1))
-      fluxv=fluxv
-
-! Meridional heat fluxes 
-      DO ij=1,ip1jm
-          ! centered scheme
-          fluxtm(ij,1)=fluxm(ij)*(ts(ij+iip1,1)+ts(ij,1))/2.
-          fluxtm(ij,2)=-fluxm(ij)*(ts(ij+iip1,2)+ts(ij,2))/2.
-      END DO
-
-! Zonal heat fluxes
-! Schema upstream      
-      DO ij=iip2,ip1jm
-      IF (fluxz(ij).GE.0.) THEN
-             fluxtz(ij,1)=fluxz(ij)*ts(ij,1)
-             fluxtz(ij,2)=-fluxz(ij)*ts(ij+1,2)
-      ELSE
-             fluxtz(ij,1)=fluxz(ij)*ts(ij+1,1)
-             fluxtz(ij,2)=-fluxz(ij)*ts(ij,2)
-      ENDIF
-      ENDDO
-      DO ij=iip1*2,ip1jmp1,iip1
-             fluxtz(ij,:)=fluxtz(ij-iim,:)
-      END DO
-                   
-! Temperature tendency :
-      DO ij=iip2,ip1jm
-! divergence of horizontal heat fluxes
-         dt(ij,:)=fluxtz(ij-1,:)-fluxtz(ij,:) &
-                 +fluxtm(ij,:)-fluxtm(ij-iip1,:)
-! + vertical heat flux (mass flux * T, upstream scheme)
-         IF (fluxv(ij).GT.0.) THEN
-           dt(ij,1)=dt(ij,1)+fluxv(ij)*ts(ij,2)
-           dt(ij,2)=dt(ij,2)-fluxv(ij)*ts(ij,2)
-         ELSE
-           dt(ij,1)=dt(ij,1)+fluxv(ij)*ts(ij,1)
-           dt(ij,2)=dt(ij,2)-fluxv(ij)*ts(ij,1)
-         ENDIF
-         ! divide by cell area
-         dt(ij,:)=dt(ij,:)/aire(ij)
-      END DO
-      DO ij=iip1,ip1jmi1,iip1
-         dt(ij+1,:)=dt(ij+iip1,:) 
-      END DO
-! Poles
-      dt(1,:)=SUM(fluxtm(1:iim,:),dim=1)
-        IF (fluxv(1).GT.0.) THEN
-          dt(1,1)=dt(1,1)+fluxv(1)*ts(1,2)
-          dt(1,2)=dt(1,2)-fluxv(1)*ts(1,2)
-        ELSE
-          dt(1,1)=dt(1,1)+fluxv(1)*ts(1,1)
-          dt(1,2)=dt(1,2)-fluxv(1)*ts(1,1)
-        ENDIF
-      dt(1,:)=dt(1,:)/apoln
-      dt(ip1jmp1,:)=-SUM(fluxtm(ip1jm-iim:ip1jm-1,:),dim=1)
-       IF (fluxv(ip1jmp1).GT.0.) THEN
-         dt(ip1jmp1,1)=dt(ip1jmp1,1)+fluxv(ip1jmp1)*ts(ip1jmp1,2)
-         dt(ip1jmp1,2)=dt(ip1jmp1,2)-fluxv(ip1jmp1)*ts(ip1jmp1,2)
-       ELSE
-         dt(ip1jmp1,1)=dt(ip1jmp1,1)+fluxv(ip1jmp1)*ts(ip1jmp1,1)
-         dt(ip1jmp1,2)=dt(ip1jmp1,2)-fluxv(ip1jmp1)*ts(ip1jmp1,1)
-       ENDIF
-      dt(ip1jmp1,:)=dt(ip1jmp1,:)/apols
-      dt(2:iip1,1)=dt(1,1)
-      dt(2:iip1,2)=dt(1,2)
-      dt(ip1jm+1:ip1jmp1,1)=dt(ip1jmp1,1)
-      dt(ip1jm+1:ip1jmp1,2)=dt(ip1jmp1,2)
-
-! T tendency back to 1D grid...
-      CALL gr_dyn_fi(2,iip1,jjp1,dt,dt_phy)
-
-      RETURN
-  END SUBROUTINE slab_gmdiff
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-  SUBROUTINE gr_fi_dyn(nfield,im,jm,pfi,pdyn)
-  ! Transfer a variable from 1D "physics" grid to 2D "dynamics" grid
-  IMPLICIT NONE
-
-  INTEGER,INTENT(IN) :: im,jm,nfield
-  REAL,INTENT(IN) :: pfi(klon_glo,nfield) ! on 1D grid
-  REAL,INTENT(OUT) :: pdyn(im,jm,nfield) ! on 2D grid
-
-  INTEGER :: i,j,ifield,ig
-
-  DO ifield=1,nfield
-    ! Handle poles
-    DO i=1,im
-      pdyn(i,1,ifield)=pfi(1,ifield)
-      pdyn(i,jm,ifield)=pfi(klon_glo,ifield)
-    ENDDO
-    ! Other points
-    DO j=2,jm-1
-      ig=2+(j-2)*(im-1)
-      CALL SCOPY(im-1,pfi(ig,ifield),1,pdyn(1,j,ifield),1)
-      pdyn(im,j,ifield)=pdyn(1,j,ifield)
-    ENDDO
-  ENDDO ! of DO ifield=1,nfield
-
-  END SUBROUTINE gr_fi_dyn
-
-  SUBROUTINE gr_dyn_fi(nfield,im,jm,pdyn,pfi)
-  ! Transfer a variable from 2D "dynamics" grid to 1D "physics" grid
-  IMPLICIT NONE
-
-  INTEGER,INTENT(IN) :: im,jm,nfield
-  REAL,INTENT(IN) :: pdyn(im,jm,nfield) ! on 2D grid
-  REAL,INTENT(OUT) :: pfi(klon_glo,nfield) ! on 1D grid
-
-  INTEGER j,ifield,ig
-
-  CHARACTER (len = 20)                      :: modname = 'slab_heat_transp'
-  CHARACTER (len = 80)                      :: abort_message
-
-  ! Sanity check:
-  IF(klon_glo.NE.2+(jm-2)*(im-1)) THEN
-    abort_message="gr_dyn_fi error, wrong sizes"
-    CALL abort_physic(modname,abort_message,1)
-  ENDIF
-
-  ! Handle poles
-  CALL SCOPY(nfield,pdyn,im*jm,pfi,klon_glo)
-  CALL SCOPY(nfield,pdyn(1,jm,1),im*jm,pfi(klon_glo,1),klon_glo)
-  ! Other points
-  DO ifield=1,nfield
-    DO j=2,jm-1
-      ig=2+(j-2)*(im-1)
-      CALL SCOPY(im-1,pdyn(1,j,ifield),1,pfi(ig,ifield),1)
-    ENDDO
-  ENDDO
-
-  END SUBROUTINE gr_dyn_fi
-
-  SUBROUTINE  grad(klevel,pg,pgx,pgy)
-  ! compute the covariant components pgx,pgy of the gradient of pg
-  ! pgx = d(pg)/dx * delta(x) = delta(pg)
-  IMPLICIT NONE
-
-  INTEGER,INTENT(IN) :: klevel
-  REAL,INTENT(IN) :: pg((nbp_lon+1)*nbp_lat,klevel)
-  REAL,INTENT(OUT) :: pgx((nbp_lon+1)*nbp_lat,klevel)
-  REAL,INTENT(OUT) :: pgy((nbp_lon+1)*(nbp_lat-1),klevel)
-
-  INTEGER :: l,ij
-  INTEGER :: iim,iip1,ip1jm,ip1jmp1
-
-  iim=nbp_lon
-  iip1=nbp_lon+1
-  ip1jm=(nbp_lon+1)*(nbp_lat-1) ! = iip1*jjm
-  ip1jmp1=(nbp_lon+1)*nbp_lat ! = iip1*jjp1
-
-  DO l=1,klevel
-    DO ij=1,ip1jmp1-1
-      pgx(ij,l)=pg(ij+1,l)-pg(ij,l)
-    ENDDO
-    ! correction for pgx(ip1,j,l) ...
-    ! ... pgx(iip1,j,l)=pgx(1,j,l) ...
-    DO ij=iip1,ip1jmp1,iip1
-      pgx(ij,l)=pgx(ij-iim,l)
-    ENDDO
-    DO ij=1,ip1jm
-      pgy(ij,l)=pg(ij,l)-pg(ij+iip1,l)
-    ENDDO
-  ENDDO
-
-  END SUBROUTINE grad
-
-  SUBROUTINE diverg(klevel,x,y,div)
-  ! computes the divergence of a vector field of components
-  ! x,y. x and y being covariant components
-  IMPLICIT NONE
-
-  INTEGER,INTENT(IN) :: klevel
-  REAL,INTENT(IN) :: x((nbp_lon+1)*nbp_lat,klevel)
-  REAL,INTENT(IN) :: y((nbp_lon+1)*(nbp_lat-1),klevel)
-  REAL,INTENT(OUT) :: div((nbp_lon+1)*nbp_lat,klevel)
-
-  INTEGER :: l,ij
-  INTEGER :: iim,iip1,iip2,ip1jm,ip1jmp1,ip1jmi1
-
-  REAL :: aiy1(nbp_lon+1),aiy2(nbp_lon+1)
-  REAL :: sumypn,sumyps
-  REAL,EXTERNAL :: SSUM
-
-  iim=nbp_lon
-  iip1=nbp_lon+1
-  iip2=nbp_lon+2
-  ip1jm=(nbp_lon+1)*(nbp_lat-1) ! = iip1*jjm
-  ip1jmp1=(nbp_lon+1)*nbp_lat ! = iip1*jjp1
-  ip1jmi1=(nbp_lon+1)*(nbp_lat-1)-(nbp_lon+1) ! = ip1jm - iip1
-
-  DO l=1,klevel
-    DO ij=iip2,ip1jm-1
-      div(ij+1,l)= &
-        cvusurcu(ij+1)*x(ij+1,l)-cvusurcu(ij)*x(ij,l)+ &
-        cuvsurcv(ij-iim)*y(ij-iim,l)-cuvsurcv(ij+1)*y(ij+1,l)
-    ENDDO
-    ! correction for div(1,j,l) ...
-    ! ... div(1,j,l)= div(iip1,j,l) ...
-    DO ij=iip2,ip1jm,iip1
-      div(ij,l)=div(ij+iim,l)
-    ENDDO
-    ! at the poles
-    DO ij=1,iim
-      aiy1(ij)=cuvsurcv(ij)*y(ij,l)
-      aiy2(ij)=cuvsurcv(ij+ip1jmi1)*y(ij+ip1jmi1,l)
-    ENDDO
-    sumypn=SSUM(iim,aiy1,1)/apoln
-    sumyps=SSUM(iim,aiy2,1)/apols
-    DO ij=1,iip1
-      div(ij,l)=-sumypn
-      div(ij+ip1jm,l)=sumyps
-    ENDDO
-    ! End (poles)
-  ENDDO ! of DO l=1,klevel
-
-  !!! CALL filtreg( div, jjp1, klevel, 2, 2, .TRUE., 1 )
-  DO l=1,klevel
-    DO ij=iip2,ip1jm
-      div(ij,l)=div(ij,l)*unsaire(ij)
-    ENDDO
-  ENDDO
-
-  END SUBROUTINE diverg
-
-  SUBROUTINE gr_v_scal(nx,x_v,x_scal)
-  ! convert values from v points to scalar points on C-grid
-  ! used to  compute unsfu, unseu (u points, but depends only on latitude)
-  IMPLICIT NONE
-
-  INTEGER,INTENT(IN) :: nx ! number of levels or fields
-  REAL,INTENT(IN) :: x_v((nbp_lon+1)*(nbp_lat-1),nx)
-  REAL,INTENT(OUT) :: x_scal((nbp_lon+1)*nbp_lat,nx)
-
-  INTEGER :: l,ij
-  INTEGER :: iip1,iip2,ip1jm,ip1jmp1
-
-  iip1=nbp_lon+1
-  iip2=nbp_lon+2
-  ip1jm=(nbp_lon+1)*(nbp_lat-1) ! = iip1*jjm
-  ip1jmp1=(nbp_lon+1)*nbp_lat ! = iip1*jjp1
-
-  DO l=1,nx
-    DO ij=iip2,ip1jm
-      x_scal(ij,l)= &
-                   (airev(ij-iip1)*x_v(ij-iip1,l)+airev(ij)*x_v(ij,l)) &
-                  /(airev(ij-iip1)+airev(ij))
-    ENDDO
-    DO ij=1,iip1
-      x_scal(ij,l)=0.
-    ENDDO
-    DO ij=ip1jm+1,ip1jmp1
-      x_scal(ij,l)=0.
-    ENDDO
-  ENDDO
-
-  END SUBROUTINE gr_v_scal
- 
-  SUBROUTINE gr_scal_v(nx,x_scal,x_v)
-  ! convert values from scalar points to v points on C-grid
-  ! used to compute wind stress at V points
-  IMPLICIT NONE
-
-  INTEGER,INTENT(IN) :: nx ! number of levels or fields
-  REAL,INTENT(OUT) :: x_v((nbp_lon+1)*(nbp_lat-1),nx)
-  REAL,INTENT(IN) :: x_scal((nbp_lon+1)*nbp_lat,nx)
-
-  INTEGER :: l,ij
-  INTEGER :: iip1,ip1jm
-
-  iip1=nbp_lon+1
-  ip1jm=(nbp_lon+1)*(nbp_lat-1) ! = iip1*jjm
-
-      DO l=1,nx
-        DO ij=1,ip1jm
-          x_v(ij,l)= &
-            (cu(ij)*cvusurcu(ij)*x_scal(ij,l)+ &
-            cu(ij+iip1)*cvusurcu(ij+iip1)*x_scal(ij+iip1,l)) &
-            /(cu(ij)*cvusurcu(ij)+cu(ij+iip1)*cvusurcu(ij+iip1))
-        ENDDO
-      ENDDO
-
-  END SUBROUTINE gr_scal_v
-
-  SUBROUTINE gr_scal_u(nx,x_scal,x_u)
-  ! convert values from scalar points to U points on C-grid
-  ! used to compute wind stress at U points
-  IMPLICIT NONE
-
-  INTEGER,INTENT(IN) :: nx
-  REAL,INTENT(OUT) :: x_u((nbp_lon+1)*nbp_lat,nx)
-  REAL,INTENT(IN) :: x_scal((nbp_lon+1)*nbp_lat,nx)
-
-  INTEGER :: l,ij
-  INTEGER :: iip1,jjp1,ip1jmp1
-
-  iip1=nbp_lon+1
-  jjp1=nbp_lat
-  ip1jmp1=(nbp_lon+1)*nbp_lat ! = iip1*jjp1
-
-  DO l=1,nx
-     DO ij=1,ip1jmp1-1
-        x_u(ij,l)= &
-         (aire(ij)*x_scal(ij,l)+aire(ij+1)*x_scal(ij+1,l)) &
-         /(aire(ij)+aire(ij+1))
-     ENDDO
-  ENDDO
-
-  CALL SCOPY(nx*jjp1,x_u(1,1),iip1,x_u(iip1,1),iip1)
-
-  END SUBROUTINE gr_scal_u
-
-END MODULE slab_heat_transp_mod
Index: /LMDZ6/trunk/libf/phylmd/slab_heat_transp_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/slab_heat_transp_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/slab_heat_transp_mod.f90	(revision 5268)
@@ -0,0 +1,1131 @@
+!
+MODULE slab_heat_transp_mod
+!
+! Slab ocean : temperature tendencies due to horizontal diffusion 
+! and / or Ekman transport
+
+USE mod_grid_phy_lmdz, ONLY: nbp_lon, nbp_lat, klon_glo
+IMPLICIT NONE
+
+  ! Variables copied over from dyn3d dynamics:
+  REAL,SAVE,ALLOCATABLE :: fext(:) ! Coriolis f times cell area
+  !$OMP THREADPRIVATE(fext)
+  REAL,SAVE,ALLOCATABLE :: beta(:) ! df/dy
+  !$OMP THREADPRIVATE(beta)
+  REAL,SAVE,ALLOCATABLE :: unsairez(:) ! 1/cell area
+  !$OMP THREADPRIVATE(unsairez)
+  REAL,SAVE,ALLOCATABLE :: unsaire(:)
+  !$OMP THREADPRIVATE(unsaire)
+  REAL,SAVE,ALLOCATABLE :: cu(:) ! cell longitude dim (m)
+  !$OMP THREADPRIVATE(cu)
+  REAL,SAVE,ALLOCATABLE :: cv(:) ! cell latitude dim (m)
+  !$OMP THREADPRIVATE(cv)
+  REAL,SAVE,ALLOCATABLE :: cuvsurcv(:) ! cu/cv (v points)
+  !$OMP THREADPRIVATE(cuvsurcv)
+  REAL,SAVE,ALLOCATABLE :: cvusurcu(:) ! cv/cu (u points)
+  !$OMP THREADPRIVATE(cvusurcu)
+  REAL,SAVE,ALLOCATABLE :: aire(:) ! cell area
+  !$OMP THREADPRIVATE(aire)
+  REAL,SAVE :: apoln ! area of north pole points
+  !$OMP THREADPRIVATE(apoln)
+  REAL,SAVE :: apols ! area of south pole points
+  !$OMP THREADPRIVATE(apols)
+  REAL,SAVE,ALLOCATABLE :: aireu(:) ! area of u cells 
+  !$OMP THREADPRIVATE(aireu)
+  REAL,SAVE,ALLOCATABLE :: airev(:) ! area of v cells
+  !$OMP THREADPRIVATE(airev)
+
+  ! Local parameters for slab transport
+  LOGICAL,SAVE :: alpha_var ! variable coef for deep temp (1 layer)
+  !$OMP THREADPRIVATE(alpha_var)
+  LOGICAL,SAVE :: slab_upstream ! upstream scheme ? (1 layer)
+  !$OMP THREADPRIVATE(slab_upstream)
+  LOGICAL,SAVE :: slab_sverdrup ! use wind stress curl at equator
+  !$OMP THREADPRIVATE(slab_sverdrup)
+  LOGICAL,SAVE :: slab_tyeq ! use merid wind stress at equator
+  !$OMP THREADPRIVATE(slab_tyeq)
+  LOGICAL,SAVE :: ekman_zonadv ! use zonal advection by Ekman currents
+  !$OMP THREADPRIVATE(ekman_zonadv)
+  LOGICAL,SAVE :: ekman_zonavg ! zonally average wind stress
+  !$OMP THREADPRIVATE(ekman_zonavg)
+
+  REAL,SAVE :: alpham
+  !$OMP THREADPRIVATE(alpham)
+  REAL,SAVE :: gmkappa
+  !$OMP THREADPRIVATE(gmkappa)
+  REAL,SAVE :: gm_smax
+  !$OMP THREADPRIVATE(gm_smax)
+
+! geometry variables : f, beta, mask...
+  REAL,SAVE,ALLOCATABLE :: zmasqu(:) ! continent mask for zonal mass flux
+  !$OMP THREADPRIVATE(zmasqu)
+  REAL,SAVE,ALLOCATABLE :: zmasqv(:) ! continent mask for merid mass flux
+  !$OMP THREADPRIVATE(zmasqv)
+  REAL,SAVE,ALLOCATABLE :: unsfv(:) ! 1/f, v points
+  !$OMP THREADPRIVATE(unsfv)
+  REAL,SAVE,ALLOCATABLE :: unsbv(:) ! 1/beta
+  !$OMP THREADPRIVATE(unsbv)
+  REAL,SAVE,ALLOCATABLE :: unsev(:) ! 1/epsilon (drag)
+  !$OMP THREADPRIVATE(unsev)
+  REAL,SAVE,ALLOCATABLE :: unsfu(:) ! 1/F, u points
+  !$OMP THREADPRIVATE(unsfu)
+  REAL,SAVE,ALLOCATABLE :: unseu(:)
+  !$OMP THREADPRIVATE(unseu)
+
+  ! Routines from dyn3d, valid on global dynamics grid only:
+  PRIVATE :: gr_fi_dyn, gr_dyn_fi ! to go between 1D nd 2D horiz grid
+  PRIVATE :: gr_scal_v,gr_v_scal,gr_scal_u ! change on 2D grid U,V, T points
+  PRIVATE :: grad,diverg
+
+CONTAINS
+ 
+  SUBROUTINE ini_slab_transp_geom(ip1jm,ip1jmp1,unsairez_,fext_,unsaire_,&
+                                  cu_,cuvsurcv_,cv_,cvusurcu_, &
+                                  aire_,apoln_,apols_, &
+                                  aireu_,airev_,rlatv, rad, omeg)
+    ! number of points in lon, lat
+    IMPLICIT NONE
+    ! Routine copies some geometry variables from the dynamical core
+    ! see global vars for meaning
+    INTEGER,INTENT(IN) :: ip1jm
+    INTEGER,INTENT(IN) :: ip1jmp1
+    REAL,INTENT(IN) :: unsairez_(ip1jm)
+    REAL,INTENT(IN) :: fext_(ip1jm)
+    REAL,INTENT(IN) :: unsaire_(ip1jmp1)
+    REAL,INTENT(IN) :: cu_(ip1jmp1)
+    REAL,INTENT(IN) :: cuvsurcv_(ip1jm)
+    REAL,INTENT(IN) :: cv_(ip1jm)
+    REAL,INTENT(IN) :: cvusurcu_(ip1jmp1)
+    REAL,INTENT(IN) :: aire_(ip1jmp1)
+    REAL,INTENT(IN) :: apoln_
+    REAL,INTENT(IN) :: apols_
+    REAL,INTENT(IN) :: aireu_(ip1jmp1)
+    REAL,INTENT(IN) :: airev_(ip1jm)
+    REAL,INTENT(IN) :: rlatv(nbp_lat-1)
+    REAL,INTENT(IN) :: rad
+    REAL,INTENT(IN) :: omeg
+
+    CHARACTER (len = 20) :: modname = 'slab_heat_transp'
+    CHARACTER (len = 80) :: abort_message
+    
+    ! Sanity check on dimensions
+    if ((ip1jm.ne.((nbp_lon+1)*(nbp_lat-1))).or. &
+        (ip1jmp1.ne.((nbp_lon+1)*nbp_lat))) then
+      abort_message="ini_slab_transp_geom Error: wrong array sizes"
+      CALL abort_physic(modname,abort_message,1)
+    endif
+! Allocations could be done only on master process/thread...
+    allocate(unsairez(ip1jm))
+    unsairez(:)=unsairez_(:)
+    allocate(fext(ip1jm))
+    fext(:)=fext_(:)
+    allocate(unsaire(ip1jmp1))
+    unsaire(:)=unsaire_(:)
+    allocate(cu(ip1jmp1))
+    cu(:)=cu_(:)
+    allocate(cuvsurcv(ip1jm))
+    cuvsurcv(:)=cuvsurcv_(:)
+    allocate(cv(ip1jm))
+    cv(:)=cv_(:)
+    allocate(cvusurcu(ip1jmp1))
+    cvusurcu(:)=cvusurcu_(:)
+    allocate(aire(ip1jmp1))
+    aire(:)=aire_(:)
+    apoln=apoln_
+    apols=apols_
+    allocate(aireu(ip1jmp1))
+    aireu(:)=aireu_(:)
+    allocate(airev(ip1jm))
+    airev(:)=airev_(:) 
+    allocate(beta(nbp_lat-1))
+    beta(:)=2*omeg*cos(rlatv(:))/rad
+
+  END SUBROUTINE ini_slab_transp_geom
+
+  SUBROUTINE ini_slab_transp(zmasq)
+
+!    USE ioipsl_getin_p_mod, only: getin_p
+    USE IOIPSL, ONLY : getin 
+    IMPLICIT NONE
+
+    REAL zmasq(klon_glo) ! ocean / continent mask, 1=continent
+    REAL zmasq_2d((nbp_lon+1)*nbp_lat)
+    REAL ff((nbp_lon+1)*(nbp_lat-1)) ! Coriolis parameter
+    REAL eps ! epsilon friction timescale (s-1)
+    INTEGER :: slab_ekman 
+    INTEGER i
+    INTEGER :: iim,iip1,jjp1,ip1jm,ip1jmp1
+
+! Some definition for grid size
+    ip1jm=(nbp_lon+1)*(nbp_lat-1)
+    ip1jmp1=(nbp_lon+1)*nbp_lat
+    iim=nbp_lon
+    iip1=nbp_lon+1
+    jjp1=nbp_lat
+    ip1jm=(nbp_lon+1)*(nbp_lat-1)
+    ip1jmp1=(nbp_lon+1)*nbp_lat
+
+! Options for Heat transport
+    ! Alpha variable?
+      alpha_var=.FALSE.
+      CALL getin('slab_alphav',alpha_var)
+      print *,'alpha variable',alpha_var
+!  centered ou upstream scheme for meridional transport
+      slab_upstream=.FALSE.
+      CALL getin('slab_upstream',slab_upstream)
+      print *,'upstream slab scheme',slab_upstream
+! Sverdrup balance at equator ?
+      slab_sverdrup=.TRUE.
+      CALL getin('slab_sverdrup',slab_sverdrup)
+      print *,'Sverdrup balance',slab_sverdrup
+! Use tauy for meridional flux at equator ?
+      slab_tyeq=.TRUE.
+      CALL getin('slab_tyeq',slab_tyeq)
+      print *,'Tauy forcing at equator',slab_tyeq
+! Use tauy for meridional flux at equator ?
+      ekman_zonadv=.TRUE.
+      CALL getin('slab_ekman_zonadv',ekman_zonadv)
+      print *,'Use Ekman flow in zonal direction',ekman_zonadv
+! Use tauy for meridional flux at equator ?
+      ekman_zonavg=.FALSE.
+      CALL getin('slab_ekman_zonavg',ekman_zonavg)
+      print *,'Use zonally-averaged wind stress ?',ekman_zonavg
+! Value of alpha
+      alpham=2./3.
+      CALL getin('slab_alpha',alpham)
+      print *,'slab_alpha',alpham
+! GM k coefficient (m2/s) for 2-layers
+      gmkappa=1000.
+      CALL getin('slab_gmkappa',gmkappa)
+      print *,'slab_gmkappa',gmkappa
+! GM k coefficient (m2/s) for 2-layers
+      gm_smax=2e-3
+      CALL getin('slab_gm_smax',gm_smax)
+      print *,'slab_gm_smax',gm_smax
+! -----------------------------------------------------------
+! Define ocean / continent mask (no flux into continent cell)
+    allocate(zmasqu(ip1jmp1))
+    allocate(zmasqv(ip1jm))
+    zmasqu=1.
+    zmasqv=1.
+
+    ! convert mask to 2D grid
+    CALL gr_fi_dyn(1,iip1,jjp1,zmasq,zmasq_2d)
+    ! put flux mask to 0 at boundaries of continent cells
+    DO i=1,ip1jmp1-1
+      IF (zmasq_2d(i).GT.1e-5 .OR. zmasq_2d(i+1).GT.1e-5) THEN
+              zmasqu(i)=0.
+      ENDIF
+    END DO
+    DO i=iip1,ip1jmp1,iip1
+      zmasqu(i)=zmasqu(i-iim)
+    END DO
+    DO i=1,ip1jm
+      IF (zmasq_2d(i).GT.1e-5 .OR. zmasq_2d(i+iip1).GT.1e-5) THEN
+              zmasqv(i)=0.
+      END IF
+    END DO
+
+! -----------------------------------------------------------
+! Coriolis and friction for Ekman transport
+    slab_ekman=2
+    CALL getin("slab_ekman",slab_ekman)
+    IF (slab_ekman.GT.0) THEN
+      allocate(unsfv(ip1jm))
+      allocate(unsev(ip1jm))
+      allocate(unsfu(ip1jmp1))
+      allocate(unseu(ip1jmp1))
+      allocate(unsbv(ip1jm))
+
+      eps=1e-5 ! Drag
+      CALL getin('slab_eps',eps)
+      print *,'epsilon=',eps
+      ff=fext*unsairez ! Coriolis
+      ! coefs to convert tau_x, tau_y to Ekman mass fluxes
+      ! on 2D grid v points
+      ! Compute correction factor [0 1] near the equator (f<<eps)
+      IF (slab_sverdrup) THEN
+         ! New formulation, sharper near equator, when eps gives Rossby Radius
+         DO i=1,ip1jm
+           unsev(i)=exp(-ff(i)*ff(i)/eps**2)
+         ENDDO
+      ELSE
+         DO i=1,ip1jm
+           unsev(i)=eps**2/(ff(i)*ff(i)+eps**2)
+         ENDDO
+      END IF ! slab_sverdrup
+      ! 1/beta
+      DO i=1,jjp1-1
+        unsbv((i-1)*iip1+1:i*iip1)=unsev((i-1)*iip1+1:i*iip1)/beta(i)
+      END DO
+      ! 1/f
+      ff=SIGN(MAX(ABS(ff),eps/100.),ff) ! avoid value 0 at equator...
+      DO i=1,ip1jm
+        unsfv(i)=(1.-unsev(i))/ff(i)
+      END DO
+      ! compute values on 2D u grid
+      ! 1/eps
+      unsev(:)=unsev(:)/eps
+      CALL gr_v_scal(1,unsfv,unsfu)
+      CALL gr_v_scal(1,unsev,unseu)
+    END IF
+  
+  END SUBROUTINE ini_slab_transp
+
+  SUBROUTINE divgrad_phy(nlevs,temp,delta)
+! Computes temperature tendency due to horizontal diffusion :
+! T Laplacian, later multiplied by diffusion coef and time-step
+
+    IMPLICIT NONE
+ 
+    INTEGER, INTENT(IN) :: nlevs ! nlevs : slab layers
+    REAL, INTENT(IN)   :: temp(klon_glo,nlevs) ! slab temperature
+    REAL , INTENT(OUT) :: delta(klon_glo,nlevs) ! temp laplacian (heat flux div.)
+    REAL :: delta_2d((nbp_lon+1)*nbp_lat,nlevs)
+    REAL ghx((nbp_lon+1)*nbp_lat,nlevs), ghy((nbp_lon+1)*(nbp_lat-1),nlevs)
+    INTEGER :: ll,iip1,jjp1
+ 
+    iip1=nbp_lon+1
+    jjp1=nbp_lat
+    
+    ! transpose temp to 2D horiz. grid
+    CALL gr_fi_dyn(nlevs,iip1,jjp1,temp,delta_2d)
+    ! computes gradient (proportional to heat flx)
+    CALL grad(nlevs,delta_2d,ghx,ghy)
+    ! put flux to 0 at ocean / continent boundary
+    DO ll=1,nlevs
+        ghx(:,ll)=ghx(:,ll)*zmasqu
+        ghy(:,ll)=ghy(:,ll)*zmasqv
+    END DO
+    ! flux divergence
+    CALL diverg(nlevs,ghx,ghy,delta_2d)
+    ! laplacian back to 1D grid
+    CALL gr_dyn_fi(nlevs,iip1,jjp1,delta_2d,delta)
+ 
+    RETURN
+  END SUBROUTINE divgrad_phy
+
+  SUBROUTINE slab_ekman1(tx_phy,ty_phy,ts_phy,dt_phy)
+! 1.5 Layer Ekman transport temperature tendency
+! note : tendency dt later multiplied by (delta t)/(rho.H)
+! to convert from divergence of heat fluxes to T
+
+      IMPLICIT NONE
+      
+      ! tx, ty : wind stress (different grids)
+      ! fluxm, fluz : mass *or heat* fluxes
+      ! dt : temperature tendency
+      INTEGER ij
+
+      ! ts surface temp, td deep temp (diagnosed)
+      REAL ts_phy(klon_glo)
+      REAL ts((nbp_lon+1)*nbp_lat),td((nbp_lon+1)*nbp_lat)
+      ! zonal and meridional wind stress 
+      REAL tx_phy(klon_glo),ty_phy(klon_glo)
+      REAL tyu((nbp_lon+1)*nbp_lat),txu((nbp_lon+1)*nbp_lat)
+      REAL txv((nbp_lon+1)*(nbp_lat-1)),tyv((nbp_lon+1)*(nbp_lat-1))
+      REAL tcurl((nbp_lon+1)*(nbp_lat-1))
+      ! zonal and meridional Ekman mass fluxes at u, v points (2D grid)
+      REAL fluxz((nbp_lon+1)*nbp_lat),fluxm((nbp_lon+1)*(nbp_lat-1))
+      ! vertical  and absolute mass fluxes (to estimate alpha)
+      REAL fluxv((nbp_lon+1)*nbp_lat),fluxt((nbp_lon+1)*(nbp_lat-1))
+      ! temperature tendency
+      REAL dt((nbp_lon+1)*nbp_lat),dt_phy(klon_glo)
+      REAL alpha((nbp_lon+1)*nbp_lat) ! deep temperature coef
+
+      INTEGER iim,iip1,iip2,jjp1,ip1jm,ip1jmi1,ip1jmp1
+
+! Grid definitions
+      iim=nbp_lon
+      iip1=nbp_lon+1
+      iip2=nbp_lon+2
+      jjp1=nbp_lat
+      ip1jm=(nbp_lon+1)*(nbp_lat-1) ! = iip1*jjm
+      ip1jmi1=(nbp_lon+1)*(nbp_lat-1)-(nbp_lon+1) ! = ip1jm - iip1
+      ip1jmp1=(nbp_lon+1)*nbp_lat ! = iip1*jjp1
+
+! Convert taux,y to 2D  scalar grid
+! Note: 2D grid size = iim*jjm. iip1=iim+1
+! First and last points in zonal direction are the same 
+! we use 1 index ij from 1 to (iim+1)*(jjm+1)
+      ! north and south poles
+      tx_phy(1)=0.
+      tx_phy(klon_glo)=0.
+      ty_phy(1)=0.
+      ty_phy(klon_glo)=0.
+      CALL gr_fi_dyn(1,iip1,jjp1,tx_phy,txu)
+      CALL gr_fi_dyn(1,iip1,jjp1,ty_phy,tyu)
+! convert to u,v grid (Arakawa C)
+! Multiply by f or eps to get mass flux
+      ! Meridional mass flux
+      CALL gr_scal_v(1,txu,txv) ! wind stress at v points
+      IF (slab_sverdrup) THEN ! Sverdrup bal. near equator
+        tcurl=(txu(1:ip1jm)-txu(iip2:ip1jmp1))/cv(:)
+        fluxm=-tcurl*unsbv-txv*unsfv ! in kg.s-1.m-1 (zonal distance)
+      ELSE 
+        CALL gr_scal_v(1,tyu,tyv)
+        fluxm=tyv*unsev-txv*unsfv ! in kg.s-1.m-1 (zonal distance)
+      ENDIF
+      ! Zonal mass flux
+      CALL gr_scal_u(1,txu,txu) ! wind stress at u points
+      CALL gr_scal_u(1,tyu,tyu)
+      fluxz=tyu*unsfu+txu*unseu
+            
+! Correct flux: continent mask and horiz grid size
+      ! multiply m-flux by mask and dx: flux in kg.s-1
+      fluxm=fluxm*cv*cuvsurcv*zmasqv 
+      ! multiply z-flux by mask and dy: flux in kg.s-1
+      fluxz=fluxz*cu*cvusurcu*zmasqu
+
+! Compute vertical  and absolute mass flux (for variable alpha)
+      IF (alpha_var) THEN
+        DO ij=iip2,ip1jm
+        fluxv(ij)=fluxz(ij)-fluxz(ij-1)-fluxm(ij)+fluxm(ij-iip1)
+        fluxt(ij)=ABS(fluxz(ij))+ABS(fluxz(ij-1)) &
+               +ABS(fluxm(ij))+ABS(fluxm(ij-iip1))
+        ENDDO
+        DO ij=iip1,ip1jmi1,iip1
+            fluxt(ij+1)=fluxt(ij+iip1)
+            fluxv(ij+1)=fluxv(ij+iip1)
+        END DO
+        fluxt(1)=SUM(ABS(fluxm(1:iim)))
+        fluxt(ip1jmp1)=SUM(ABS(fluxm(ip1jm-iim:ip1jm-1)))
+        fluxv(1)=-SUM(fluxm(1:iim))
+        fluxv(ip1jmp1)=SUM(fluxm(ip1jm-iim:ip1jm-1))
+        fluxt=MAX(fluxt,1.e-10)
+      ENDIF
+
+! Compute alpha coefficient. 
+! Tdeep = Tsurf * alpha + 271.35 * (1-alpha)
+      IF (alpha_var) THEN
+          ! increase alpha (and Tdeep) in downwelling regions
+          ! and decrease in upwelling regions
+          ! to avoid "hot spots" where there is surface convergence
+          DO ij=iip2,ip1jm
+              alpha(ij)=alpham-fluxv(ij)/fluxt(ij)*(1.-alpham)
+          ENDDO
+          alpha(1:iip1)=alpham-fluxv(1)/fluxt(1)*(1.-alpham)
+          alpha(ip1jm+1:ip1jmp1)=alpham-fluxv(ip1jmp1)/fluxt(ip1jmp1)*(1.-alpham)
+      ELSE
+          alpha(:)=alpham
+          ! Tsurf-Tdeep ~ 10° in the Tropics
+      ENDIF
+
+! Estimate deep temperature
+      CALL gr_fi_dyn(1,iip1,jjp1,ts_phy,ts)
+      DO ij=1,ip1jmp1
+         td(ij)=271.35+(ts(ij)-271.35)*alpha(ij)
+         td(ij)=MIN(td(ij),ts(ij))
+      END DO
+       
+! Meridional heat flux: multiply mass flux by (ts-td)
+! flux in K.kg.s-1
+      IF (slab_upstream) THEN
+        ! upstream scheme to avoid hot spots
+        DO ij=1,ip1jm
+        IF (fluxm(ij).GE.0.) THEN
+           fluxm(ij)=fluxm(ij)*(ts(ij+iip1)-td(ij))
+        ELSE
+           fluxm(ij)=fluxm(ij)*(ts(ij)-td(ij+iip1))
+        END IF
+        END DO
+      ELSE
+        ! centered scheme better in mid-latitudes
+        DO ij=1,ip1jm
+          fluxm(ij)=fluxm(ij)*(ts(ij+iip1)+ts(ij)-td(ij)-td(ij+iip1))/2.
+        END DO
+      ENDIF
+
+! Zonal heat flux
+! upstream scheme
+      DO ij=iip2,ip1jm
+          fluxz(ij)=fluxz(ij)*(ts(ij)+ts(ij+1)-td(ij+1)-td(ij))/2.
+      END DO
+      DO ij=iip1*2,ip1jmp1,iip1
+           fluxz(ij)=fluxz(ij-iim)
+      END DO
+
+! temperature tendency = divergence of heat fluxes
+! dt in K.s-1.kg.m-2 (T trend times mass/horiz surface)
+      DO ij=iip2,ip1jm
+         dt(ij)=(fluxz(ij-1)-fluxz(ij)+fluxm(ij)-fluxm(ij-iip1)) &
+               /aire(ij) ! aire : grid area 
+      END DO
+      DO ij=iip1,ip1jmi1,iip1
+         dt(ij+1)=dt(ij+iip1) 
+      END DO
+! special treatment at the Poles
+      dt(1)=SUM(fluxm(1:iim))/apoln
+      dt(ip1jmp1)=-SUM(fluxm(ip1jm-iim:ip1jm-1))/apols
+      dt(2:iip1)=dt(1)
+      dt(ip1jm+1:ip1jmp1)=dt(ip1jmp1)
+
+! tendencies back to 1D grid
+      CALL gr_dyn_fi(1,iip1,jjp1,dt,dt_phy)
+
+      RETURN
+  END SUBROUTINE slab_ekman1
+
+  SUBROUTINE slab_ekman2(tx_phy,ty_phy,ts_phy,dt_phy_ek,dt_phy_gm,slab_gm)
+! Temperature tendency for 2-layers slab ocean
+! note : tendency dt later multiplied by (delta time)/(rho.H)
+! to convert from divergence of heat fluxes to T
+
+! 11/16 : Inclusion of GM-like eddy advection
+
+      IMPLICIT NONE
+      
+      LOGICAL,INTENT(in) :: slab_gm
+      ! Here, temperature and flux variables are on 2 layers
+      INTEGER ij
+
+      ! wind stress variables
+      REAL tx_phy(klon_glo),ty_phy(klon_glo)
+      REAL txv((nbp_lon+1)*(nbp_lat-1)), tyv((nbp_lon+1)*(nbp_lat-1))
+      REAL tyu((nbp_lon+1)*nbp_lat),txu((nbp_lon+1)*nbp_lat)
+      REAL tcurl((nbp_lon+1)*(nbp_lat-1))
+      ! slab temperature on  1D, 2D grid
+      REAL ts_phy(klon_glo,2), ts((nbp_lon+1)*nbp_lat,2)
+      ! Temperature gradient, v-points
+      REAL dty((nbp_lon+1)*(nbp_lat-1)),dtx((nbp_lon+1)*nbp_lat)
+      ! Vertical temperature difference, V-points
+      REAL dtz((nbp_lon+1)*(nbp_lat-1))
+      ! zonal and meridional mass fluxes at u, v points (2D grid)
+      REAL fluxz((nbp_lon+1)*nbp_lat), fluxm((nbp_lon+1)*(nbp_lat-1))
+      ! vertical mass flux between the 2 layers
+      REAL fluxv_ek((nbp_lon+1)*nbp_lat)
+      REAL fluxv_gm((nbp_lon+1)*nbp_lat)
+      ! zonal and meridional heat fluxes
+      REAL fluxtz((nbp_lon+1)*nbp_lat,2)
+      REAL fluxtm((nbp_lon+1)*(nbp_lat-1),2)
+      ! temperature tendency (in K.s-1.kg.m-2)
+      REAL dt_ek((nbp_lon+1)*nbp_lat,2), dt_phy_ek(klon_glo,2)
+      REAL dt_gm((nbp_lon+1)*nbp_lat,2), dt_phy_gm(klon_glo,2)
+      ! helper vars
+      REAL zonavg, fluxv
+      REAL, PARAMETER :: sea_den=1025. ! sea water density
+
+      INTEGER iim,iip1,iip2,jjp1,ip1jm,ip1jmi1,ip1jmp1
+
+! Grid definitions
+      iim=nbp_lon
+      iip1=nbp_lon+1
+      iip2=nbp_lon+2
+      jjp1=nbp_lat
+      ip1jm=(nbp_lon+1)*(nbp_lat-1) ! = iip1*jjm
+      ip1jmi1=(nbp_lon+1)*(nbp_lat-1)-(nbp_lon+1) ! = ip1jm - iip1
+      ip1jmp1=(nbp_lon+1)*nbp_lat ! = iip1*jjp1
+! Convert temperature to 2D grid 
+      CALL gr_fi_dyn(2,iip1,jjp1,ts_phy,ts)
+
+! ------------------------------------
+! Ekman mass fluxes and Temp tendency
+! ------------------------------------
+! Convert taux,y to 2D  scalar grid
+      ! north and south poles tx,ty no meaning
+      tx_phy(1)=0.
+      tx_phy(klon_glo)=0.
+      ty_phy(1)=0.
+      ty_phy(klon_glo)=0.
+      CALL gr_fi_dyn(1,iip1,jjp1,tx_phy,txu)
+      CALL gr_fi_dyn(1,iip1,jjp1,ty_phy,tyu)
+      IF (ekman_zonavg) THEN ! use zonal average of wind stress
+        DO ij=1,jjp1-2
+          zonavg=SUM(txu(ij*iip1+1:ij*iip1+iim))/iim
+          txu(ij*iip1+1:(ij+1)*iip1)=zonavg
+          zonavg=SUM(tyu(ij*iip1+1:ij*iip1+iim))/iim
+          tyu(ij*iip1+1:(ij+1)*iip1)=zonavg
+        END DO
+      END IF
+          
+! Divide taux,y by f or eps, and convert to 2D u,v grids
+! (Arakawa C grid)
+      ! Meridional flux
+      CALL gr_scal_v(1,txu,txv) ! wind stress at v points
+      fluxm=-txv*unsfv ! in kg.s-1.m-1 (zonal distance)
+      IF (slab_sverdrup) THEN ! Sverdrup bal. near equator
+        tcurl=(txu(1:ip1jm)-txu(iip2:ip1jmp1))/cv(:) ! dtx/dy
+        !poles curl = 0
+        tcurl(1:iip1)=0.
+        tcurl(ip1jmi1+1:ip1jm)=0.
+        fluxm=fluxm-tcurl*unsbv
+      ENDIF
+      IF (slab_tyeq) THEN ! meridional wind forcing at equator
+        CALL gr_scal_v(1,tyu,tyv)
+        fluxm=fluxm+tyv*unsev ! in kg.s-1.m-1 (zonal distance)
+      ENDIF
+!  apply continent mask, multiply by horiz grid dimension
+      fluxm=fluxm*cv*cuvsurcv*zmasqv
+
+      ! Zonal flux
+      IF (ekman_zonadv) THEN
+        CALL gr_scal_u(1,txu,txu) ! wind stress at u points
+        CALL gr_scal_u(1,tyu,tyu)
+        fluxz=tyu*unsfu+txu*unseu
+        !  apply continent mask, multiply by horiz grid dimension
+        fluxz=fluxz*cu*cvusurcu*zmasqu
+      END IF
+            
+!  Vertical mass flux from mass budget (divergence of horiz fluxes)
+      IF (ekman_zonadv) THEN
+         DO ij=iip2,ip1jm
+           fluxv_ek(ij)=fluxz(ij)-fluxz(ij-1)-fluxm(ij)+fluxm(ij-iip1)
+         ENDDO
+      ELSE 
+         DO ij=iip2,ip1jm
+           fluxv_ek(ij)=-fluxm(ij)+fluxm(ij-iip1)
+         ENDDO
+      END IF
+      DO ij=iip1,ip1jmi1,iip1
+         fluxv_ek(ij+1)=fluxv_ek(ij+iip1)
+      END DO
+!  vertical mass flux at Poles
+      fluxv_ek(1)=-SUM(fluxm(1:iim))     
+      fluxv_ek(ip1jmp1)=SUM(fluxm(ip1jm-iim:ip1jm-1))
+
+! Meridional heat fluxes 
+      DO ij=1,ip1jm
+          ! centered scheme
+          fluxtm(ij,1)=fluxm(ij)*(ts(ij+iip1,1)+ts(ij,1))/2.
+          fluxtm(ij,2)=-fluxm(ij)*(ts(ij+iip1,2)+ts(ij,2))/2.
+      END DO
+
+! Zonal heat fluxes
+! Schema upstream      
+      IF (ekman_zonadv) THEN
+        DO ij=iip2,ip1jm
+          IF (fluxz(ij).GE.0.) THEN
+                 fluxtz(ij,1)=fluxz(ij)*ts(ij,1)
+                 fluxtz(ij,2)=-fluxz(ij)*ts(ij+1,2)
+          ELSE
+                 fluxtz(ij,1)=fluxz(ij)*ts(ij+1,1)
+                 fluxtz(ij,2)=-fluxz(ij)*ts(ij,2)
+          ENDIF
+        ENDDO
+        DO ij=iip1*2,ip1jmp1,iip1
+               fluxtz(ij,:)=fluxtz(ij-iim,:)
+        END DO
+      ELSE
+        fluxtz(:,:)=0.
+      ENDIF        
+                   
+! Temperature tendency, horizontal advection:
+      DO ij=iip2,ip1jm
+         dt_ek(ij,:)=fluxtz(ij-1,:)-fluxtz(ij,:) &
+                 +fluxtm(ij,:)-fluxtm(ij-iip1,:)
+      END DO
+! Poles
+      dt_ek(1,:)=SUM(fluxtm(1:iim,:),dim=1)
+      dt_ek(ip1jmp1,:)=-SUM(fluxtm(ip1jm-iim:ip1jm-1,:),dim=1)
+
+! ------------------------------------
+! GM mass fluxes and Temp tendency
+! ------------------------------------
+     IF (slab_gm) THEN
+! Vertical Temperature difference T1-T2 on v-grid points
+      CALL gr_scal_v(1,ts(:,1)-ts(:,2),dtz)
+      dtz(:)=MAX(dtz(:),0.25) 
+! Horizontal Temperature differences 
+      CALL grad(1,(ts(:,1)+ts(:,2))/2.,dtx,dty)
+! Meridional flux = -k.s (s=dyT/dzT)
+! Continent mask, multiply by dz/dy 
+      fluxm=dty/dtz*500.*cuvsurcv*zmasqv
+! slope limitation, multiply by kappa
+      fluxm=-gmkappa*SIGN(MIN(ABS(fluxm),gm_smax*cv*cuvsurcv),dty)
+! convert to kg/s
+      fluxm(:)=fluxm(:)*sea_den
+! Zonal flux = 0. (temporary)
+      fluxz(:)=0.
+!  Vertical mass flux from mass budget (divergence of horiz fluxes)
+      DO ij=iip2,ip1jm
+        fluxv_gm(ij)=fluxz(ij)-fluxz(ij-1)-fluxm(ij)+fluxm(ij-iip1)
+      ENDDO
+      DO ij=iip1,ip1jmi1,iip1
+         fluxv_gm(ij+1)=fluxv_gm(ij+iip1)
+      END DO
+!  vertical mass flux at Poles
+      fluxv_gm(1)=-SUM(fluxm(1:iim))     
+      fluxv_gm(ip1jmp1)=SUM(fluxm(ip1jm-iim:ip1jm-1))
+
+! Meridional heat fluxes 
+      DO ij=1,ip1jm
+          ! centered scheme
+          fluxtm(ij,1)=fluxm(ij)*(ts(ij+iip1,1)+ts(ij,1))/2.
+          fluxtm(ij,2)=-fluxm(ij)*(ts(ij+iip1,2)+ts(ij,2))/2.
+      END DO
+
+! Zonal heat fluxes
+! Schema upstream      
+      DO ij=iip2,ip1jm
+      IF (fluxz(ij).GE.0.) THEN
+             fluxtz(ij,1)=fluxz(ij)*ts(ij,1)
+             fluxtz(ij,2)=-fluxz(ij)*ts(ij+1,2)
+      ELSE
+             fluxtz(ij,1)=fluxz(ij)*ts(ij+1,1)
+             fluxtz(ij,2)=-fluxz(ij)*ts(ij,2)
+      ENDIF
+      ENDDO
+      DO ij=iip1*2,ip1jmp1,iip1
+             fluxtz(ij,:)=fluxtz(ij-iim,:)
+      END DO
+                   
+! Temperature tendency :
+! divergence of horizontal heat fluxes
+      DO ij=iip2,ip1jm
+         dt_gm(ij,:)=fluxtz(ij-1,:)-fluxtz(ij,:) &
+                 +fluxtm(ij,:)-fluxtm(ij-iip1,:)
+      END DO
+! Poles
+      dt_gm(1,:)=SUM(fluxtm(1:iim,:),dim=1)
+      dt_gm(ip1jmp1,:)=-SUM(fluxtm(ip1jm-iim:ip1jm-1,:),dim=1)
+     ELSE
+       dt_gm(:,:)=0.
+       fluxv_gm(:)=0.
+     ENDIF ! slab_gm
+
+! ------------------------------------
+! Temp tendency from vertical advection
+! Divide by cell area
+! ------------------------------------
+! vertical heat flux = mass flux * T, upstream scheme
+      DO ij=iip2,ip1jm
+         fluxv=fluxv_ek(ij)+fluxv_gm(ij) ! net flux, needed for upstream scheme
+         IF (fluxv.GT.0.) THEN
+           dt_ek(ij,1)=dt_ek(ij,1)+fluxv_ek(ij)*ts(ij,2)
+           dt_ek(ij,2)=dt_ek(ij,2)-fluxv_ek(ij)*ts(ij,2)
+           dt_gm(ij,1)=dt_gm(ij,1)+fluxv_gm(ij)*ts(ij,2)
+           dt_gm(ij,2)=dt_gm(ij,2)-fluxv_gm(ij)*ts(ij,2)
+         ELSE
+           dt_ek(ij,1)=dt_ek(ij,1)+fluxv_ek(ij)*ts(ij,1)
+           dt_ek(ij,2)=dt_ek(ij,2)-fluxv_ek(ij)*ts(ij,1)
+           dt_gm(ij,1)=dt_gm(ij,1)+fluxv_gm(ij)*ts(ij,1)
+           dt_gm(ij,2)=dt_gm(ij,2)-fluxv_gm(ij)*ts(ij,1)
+         ENDIF
+         ! divide by cell area
+         dt_ek(ij,:)=dt_ek(ij,:)/aire(ij)
+         dt_gm(ij,:)=dt_gm(ij,:)/aire(ij)
+      END DO
+      ! North Pole
+      fluxv=fluxv_ek(1)+fluxv_gm(1)
+        IF (fluxv.GT.0.) THEN
+          dt_ek(1,1)=dt_ek(1,1)+fluxv_ek(1)*ts(1,2)
+          dt_ek(1,2)=dt_ek(1,2)-fluxv_ek(1)*ts(1,2)
+          dt_gm(1,1)=dt_gm(1,1)+fluxv_gm(1)*ts(1,2)
+          dt_gm(1,2)=dt_gm(1,2)-fluxv_gm(1)*ts(1,2)
+        ELSE
+          dt_ek(1,1)=dt_ek(1,1)+fluxv_ek(1)*ts(1,1)
+          dt_ek(1,2)=dt_ek(1,2)-fluxv_ek(1)*ts(1,1)
+          dt_gm(1,1)=dt_gm(1,1)+fluxv_gm(1)*ts(1,1)
+          dt_gm(1,2)=dt_gm(1,2)-fluxv_gm(1)*ts(1,1)
+        ENDIF
+      dt_ek(1,:)=dt_ek(1,:)/apoln
+      dt_gm(1,:)=dt_gm(1,:)/apoln
+      ! South pole
+      fluxv=fluxv_ek(ip1jmp1)+fluxv_gm(ip1jmp1)
+        IF (fluxv.GT.0.) THEN
+          dt_ek(ip1jmp1,1)=dt_ek(ip1jmp1,1)+fluxv_ek(ip1jmp1)*ts(ip1jmp1,2)
+          dt_ek(ip1jmp1,2)=dt_ek(ip1jmp1,2)-fluxv_ek(ip1jmp1)*ts(ip1jmp1,2)
+          dt_gm(ip1jmp1,1)=dt_gm(ip1jmp1,1)+fluxv_gm(ip1jmp1)*ts(ip1jmp1,2)
+          dt_gm(ip1jmp1,2)=dt_gm(ip1jmp1,2)-fluxv_gm(ip1jmp1)*ts(ip1jmp1,2)
+        ELSE
+          dt_ek(ip1jmp1,1)=dt_ek(ip1jmp1,1)+fluxv_ek(ip1jmp1)*ts(ip1jmp1,1)
+          dt_ek(ip1jmp1,2)=dt_ek(ip1jmp1,2)-fluxv_ek(ip1jmp1)*ts(ip1jmp1,1)
+          dt_gm(ip1jmp1,1)=dt_gm(ip1jmp1,1)+fluxv_gm(ip1jmp1)*ts(ip1jmp1,1)
+          dt_gm(ip1jmp1,2)=dt_gm(ip1jmp1,2)-fluxv_gm(ip1jmp1)*ts(ip1jmp1,1)
+        ENDIF
+      dt_ek(ip1jmp1,:)=dt_ek(ip1jmp1,:)/apols
+      dt_gm(ip1jmp1,:)=dt_gm(ip1jmp1,:)/apols
+      
+      dt_ek(2:iip1,1)=dt_ek(1,1)
+      dt_ek(2:iip1,2)=dt_ek(1,2)
+      dt_gm(2:iip1,1)=dt_gm(1,1)
+      dt_gm(2:iip1,2)=dt_gm(1,2)
+      dt_ek(ip1jm+1:ip1jmp1,1)=dt_ek(ip1jmp1,1)
+      dt_ek(ip1jm+1:ip1jmp1,2)=dt_ek(ip1jmp1,2)
+      dt_gm(ip1jm+1:ip1jmp1,1)=dt_gm(ip1jmp1,1)
+      dt_gm(ip1jm+1:ip1jmp1,2)=dt_gm(ip1jmp1,2)
+
+      DO ij=iip1,ip1jmi1,iip1
+         dt_gm(ij+1,:)=dt_gm(ij+iip1,:) 
+         dt_ek(ij+1,:)=dt_ek(ij+iip1,:) 
+      END DO
+
+! T tendency back to 1D grid...
+      CALL gr_dyn_fi(2,iip1,jjp1,dt_ek,dt_phy_ek)
+      CALL gr_dyn_fi(2,iip1,jjp1,dt_gm,dt_phy_gm)
+
+      RETURN
+  END SUBROUTINE slab_ekman2
+
+  SUBROUTINE slab_gmdiff(ts_phy,dt_phy)
+! Temperature tendency for 2-layers slab ocean
+! Due to Gent-McWilliams type eddy-induced advection
+      
+      IMPLICIT NONE
+      
+      ! Here, temperature and flux variables are on 2 layers
+      INTEGER ij
+      ! Temperature gradient, v-points
+      REAL dty((nbp_lon+1)*(nbp_lat-1)),dtx((nbp_lon+1)*nbp_lat)
+      ! Vertical temperature difference, V-points
+      REAL dtz((nbp_lon+1)*(nbp_lat-1))
+      ! slab temperature on  1D, 2D grid
+      REAL ts_phy(klon_glo,2),ts((nbp_lon+1)*nbp_lat,2)
+      ! zonal and meridional mass fluxes at u, v points (2D grid)
+      REAL fluxz((nbp_lon+1)*nbp_lat), fluxm((nbp_lon+1)*(nbp_lat-1))
+      ! vertical mass flux between the 2 layers
+      REAL fluxv((nbp_lon+1)*nbp_lat)
+      ! zonal and meridional heat fluxes
+      REAL fluxtz((nbp_lon+1)*nbp_lat,2)
+      REAL fluxtm((nbp_lon+1)*(nbp_lat-1),2)
+      ! temperature tendency (in K.s-1.kg.m-2)
+      REAL dt((nbp_lon+1)*nbp_lat,2), dt_phy(klon_glo,2)
+
+      INTEGER iim,iip1,iip2,jjp1,ip1jm,ip1jmi1,ip1jmp1
+
+! Grid definitions
+      iim=nbp_lon
+      iip1=nbp_lon+1
+      iip2=nbp_lon+2
+      jjp1=nbp_lat
+      ip1jm=(nbp_lon+1)*(nbp_lat-1) ! = iip1*jjm
+      ip1jmi1=(nbp_lon+1)*(nbp_lat-1)-(nbp_lon+1) ! = ip1jm - iip1
+      ip1jmp1=(nbp_lon+1)*nbp_lat ! = iip1*jjp1
+
+! Convert temperature to 2D grid 
+      CALL gr_fi_dyn(2,iip1,jjp1,ts_phy,ts)
+! Vertical Temperature difference T1-T2 on v-grid points
+      CALL gr_scal_v(1,ts(:,1)-ts(:,2),dtz)
+      dtz(:)=MAX(dtz(:),0.25) 
+! Horizontal Temperature differences 
+      CALL grad(1,(ts(:,1)+ts(:,2))/2.,dtx,dty)
+! Meridional flux = -k.s (s=dyT/dzT)
+! Continent mask, multiply by dz/dy 
+      fluxm=dty/dtz*500.*cuvsurcv*zmasqv
+! slope limitation, multiply by kappa
+      fluxm=-gmkappa*SIGN(MIN(ABS(fluxm),gm_smax*cv*cuvsurcv),dty)
+! Zonal flux = 0. (temporary)
+      fluxz(:)=0.
+!  Vertical mass flux from mass budget (divergence of horiz fluxes)
+      DO ij=iip2,ip1jm
+        fluxv(ij)=fluxz(ij)-fluxz(ij-1)-fluxm(ij)+fluxm(ij-iip1)
+      ENDDO
+      DO ij=iip1,ip1jmi1,iip1
+         fluxv(ij+1)=fluxv(ij+iip1)
+      END DO
+!  vertical mass flux at Poles
+      fluxv(1)=-SUM(fluxm(1:iim))     
+      fluxv(ip1jmp1)=SUM(fluxm(ip1jm-iim:ip1jm-1))
+      fluxv=fluxv
+
+! Meridional heat fluxes 
+      DO ij=1,ip1jm
+          ! centered scheme
+          fluxtm(ij,1)=fluxm(ij)*(ts(ij+iip1,1)+ts(ij,1))/2.
+          fluxtm(ij,2)=-fluxm(ij)*(ts(ij+iip1,2)+ts(ij,2))/2.
+      END DO
+
+! Zonal heat fluxes
+! Schema upstream      
+      DO ij=iip2,ip1jm
+      IF (fluxz(ij).GE.0.) THEN
+             fluxtz(ij,1)=fluxz(ij)*ts(ij,1)
+             fluxtz(ij,2)=-fluxz(ij)*ts(ij+1,2)
+      ELSE
+             fluxtz(ij,1)=fluxz(ij)*ts(ij+1,1)
+             fluxtz(ij,2)=-fluxz(ij)*ts(ij,2)
+      ENDIF
+      ENDDO
+      DO ij=iip1*2,ip1jmp1,iip1
+             fluxtz(ij,:)=fluxtz(ij-iim,:)
+      END DO
+                   
+! Temperature tendency :
+      DO ij=iip2,ip1jm
+! divergence of horizontal heat fluxes
+         dt(ij,:)=fluxtz(ij-1,:)-fluxtz(ij,:) &
+                 +fluxtm(ij,:)-fluxtm(ij-iip1,:)
+! + vertical heat flux (mass flux * T, upstream scheme)
+         IF (fluxv(ij).GT.0.) THEN
+           dt(ij,1)=dt(ij,1)+fluxv(ij)*ts(ij,2)
+           dt(ij,2)=dt(ij,2)-fluxv(ij)*ts(ij,2)
+         ELSE
+           dt(ij,1)=dt(ij,1)+fluxv(ij)*ts(ij,1)
+           dt(ij,2)=dt(ij,2)-fluxv(ij)*ts(ij,1)
+         ENDIF
+         ! divide by cell area
+         dt(ij,:)=dt(ij,:)/aire(ij)
+      END DO
+      DO ij=iip1,ip1jmi1,iip1
+         dt(ij+1,:)=dt(ij+iip1,:) 
+      END DO
+! Poles
+      dt(1,:)=SUM(fluxtm(1:iim,:),dim=1)
+        IF (fluxv(1).GT.0.) THEN
+          dt(1,1)=dt(1,1)+fluxv(1)*ts(1,2)
+          dt(1,2)=dt(1,2)-fluxv(1)*ts(1,2)
+        ELSE
+          dt(1,1)=dt(1,1)+fluxv(1)*ts(1,1)
+          dt(1,2)=dt(1,2)-fluxv(1)*ts(1,1)
+        ENDIF
+      dt(1,:)=dt(1,:)/apoln
+      dt(ip1jmp1,:)=-SUM(fluxtm(ip1jm-iim:ip1jm-1,:),dim=1)
+       IF (fluxv(ip1jmp1).GT.0.) THEN
+         dt(ip1jmp1,1)=dt(ip1jmp1,1)+fluxv(ip1jmp1)*ts(ip1jmp1,2)
+         dt(ip1jmp1,2)=dt(ip1jmp1,2)-fluxv(ip1jmp1)*ts(ip1jmp1,2)
+       ELSE
+         dt(ip1jmp1,1)=dt(ip1jmp1,1)+fluxv(ip1jmp1)*ts(ip1jmp1,1)
+         dt(ip1jmp1,2)=dt(ip1jmp1,2)-fluxv(ip1jmp1)*ts(ip1jmp1,1)
+       ENDIF
+      dt(ip1jmp1,:)=dt(ip1jmp1,:)/apols
+      dt(2:iip1,1)=dt(1,1)
+      dt(2:iip1,2)=dt(1,2)
+      dt(ip1jm+1:ip1jmp1,1)=dt(ip1jmp1,1)
+      dt(ip1jm+1:ip1jmp1,2)=dt(ip1jmp1,2)
+
+! T tendency back to 1D grid...
+      CALL gr_dyn_fi(2,iip1,jjp1,dt,dt_phy)
+
+      RETURN
+  END SUBROUTINE slab_gmdiff
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+  SUBROUTINE gr_fi_dyn(nfield,im,jm,pfi,pdyn)
+  ! Transfer a variable from 1D "physics" grid to 2D "dynamics" grid
+  IMPLICIT NONE
+
+  INTEGER,INTENT(IN) :: im,jm,nfield
+  REAL,INTENT(IN) :: pfi(klon_glo,nfield) ! on 1D grid
+  REAL,INTENT(OUT) :: pdyn(im,jm,nfield) ! on 2D grid
+
+  INTEGER :: i,j,ifield,ig
+
+  DO ifield=1,nfield
+    ! Handle poles
+    DO i=1,im
+      pdyn(i,1,ifield)=pfi(1,ifield)
+      pdyn(i,jm,ifield)=pfi(klon_glo,ifield)
+    ENDDO
+    ! Other points
+    DO j=2,jm-1
+      ig=2+(j-2)*(im-1)
+      CALL SCOPY(im-1,pfi(ig,ifield),1,pdyn(1,j,ifield),1)
+      pdyn(im,j,ifield)=pdyn(1,j,ifield)
+    ENDDO
+  ENDDO ! of DO ifield=1,nfield
+
+  END SUBROUTINE gr_fi_dyn
+
+  SUBROUTINE gr_dyn_fi(nfield,im,jm,pdyn,pfi)
+  ! Transfer a variable from 2D "dynamics" grid to 1D "physics" grid
+  IMPLICIT NONE
+
+  INTEGER,INTENT(IN) :: im,jm,nfield
+  REAL,INTENT(IN) :: pdyn(im,jm,nfield) ! on 2D grid
+  REAL,INTENT(OUT) :: pfi(klon_glo,nfield) ! on 1D grid
+
+  INTEGER j,ifield,ig
+
+  CHARACTER (len = 20)                      :: modname = 'slab_heat_transp'
+  CHARACTER (len = 80)                      :: abort_message
+
+  ! Sanity check:
+  IF(klon_glo.NE.2+(jm-2)*(im-1)) THEN
+    abort_message="gr_dyn_fi error, wrong sizes"
+    CALL abort_physic(modname,abort_message,1)
+  ENDIF
+
+  ! Handle poles
+  CALL SCOPY(nfield,pdyn,im*jm,pfi,klon_glo)
+  CALL SCOPY(nfield,pdyn(1,jm,1),im*jm,pfi(klon_glo,1),klon_glo)
+  ! Other points
+  DO ifield=1,nfield
+    DO j=2,jm-1
+      ig=2+(j-2)*(im-1)
+      CALL SCOPY(im-1,pdyn(1,j,ifield),1,pfi(ig,ifield),1)
+    ENDDO
+  ENDDO
+
+  END SUBROUTINE gr_dyn_fi
+
+  SUBROUTINE  grad(klevel,pg,pgx,pgy)
+  ! compute the covariant components pgx,pgy of the gradient of pg
+  ! pgx = d(pg)/dx * delta(x) = delta(pg)
+  IMPLICIT NONE
+
+  INTEGER,INTENT(IN) :: klevel
+  REAL,INTENT(IN) :: pg((nbp_lon+1)*nbp_lat,klevel)
+  REAL,INTENT(OUT) :: pgx((nbp_lon+1)*nbp_lat,klevel)
+  REAL,INTENT(OUT) :: pgy((nbp_lon+1)*(nbp_lat-1),klevel)
+
+  INTEGER :: l,ij
+  INTEGER :: iim,iip1,ip1jm,ip1jmp1
+
+  iim=nbp_lon
+  iip1=nbp_lon+1
+  ip1jm=(nbp_lon+1)*(nbp_lat-1) ! = iip1*jjm
+  ip1jmp1=(nbp_lon+1)*nbp_lat ! = iip1*jjp1
+
+  DO l=1,klevel
+    DO ij=1,ip1jmp1-1
+      pgx(ij,l)=pg(ij+1,l)-pg(ij,l)
+    ENDDO
+    ! correction for pgx(ip1,j,l) ...
+    ! ... pgx(iip1,j,l)=pgx(1,j,l) ...
+    DO ij=iip1,ip1jmp1,iip1
+      pgx(ij,l)=pgx(ij-iim,l)
+    ENDDO
+    DO ij=1,ip1jm
+      pgy(ij,l)=pg(ij,l)-pg(ij+iip1,l)
+    ENDDO
+  ENDDO
+
+  END SUBROUTINE grad
+
+  SUBROUTINE diverg(klevel,x,y,div)
+  ! computes the divergence of a vector field of components
+  ! x,y. x and y being covariant components
+  IMPLICIT NONE
+
+  INTEGER,INTENT(IN) :: klevel
+  REAL,INTENT(IN) :: x((nbp_lon+1)*nbp_lat,klevel)
+  REAL,INTENT(IN) :: y((nbp_lon+1)*(nbp_lat-1),klevel)
+  REAL,INTENT(OUT) :: div((nbp_lon+1)*nbp_lat,klevel)
+
+  INTEGER :: l,ij
+  INTEGER :: iim,iip1,iip2,ip1jm,ip1jmp1,ip1jmi1
+
+  REAL :: aiy1(nbp_lon+1),aiy2(nbp_lon+1)
+  REAL :: sumypn,sumyps
+  REAL,EXTERNAL :: SSUM
+
+  iim=nbp_lon
+  iip1=nbp_lon+1
+  iip2=nbp_lon+2
+  ip1jm=(nbp_lon+1)*(nbp_lat-1) ! = iip1*jjm
+  ip1jmp1=(nbp_lon+1)*nbp_lat ! = iip1*jjp1
+  ip1jmi1=(nbp_lon+1)*(nbp_lat-1)-(nbp_lon+1) ! = ip1jm - iip1
+
+  DO l=1,klevel
+    DO ij=iip2,ip1jm-1
+      div(ij+1,l)= &
+        cvusurcu(ij+1)*x(ij+1,l)-cvusurcu(ij)*x(ij,l)+ &
+        cuvsurcv(ij-iim)*y(ij-iim,l)-cuvsurcv(ij+1)*y(ij+1,l)
+    ENDDO
+    ! correction for div(1,j,l) ...
+    ! ... div(1,j,l)= div(iip1,j,l) ...
+    DO ij=iip2,ip1jm,iip1
+      div(ij,l)=div(ij+iim,l)
+    ENDDO
+    ! at the poles
+    DO ij=1,iim
+      aiy1(ij)=cuvsurcv(ij)*y(ij,l)
+      aiy2(ij)=cuvsurcv(ij+ip1jmi1)*y(ij+ip1jmi1,l)
+    ENDDO
+    sumypn=SSUM(iim,aiy1,1)/apoln
+    sumyps=SSUM(iim,aiy2,1)/apols
+    DO ij=1,iip1
+      div(ij,l)=-sumypn
+      div(ij+ip1jm,l)=sumyps
+    ENDDO
+    ! End (poles)
+  ENDDO ! of DO l=1,klevel
+
+  !!! CALL filtreg( div, jjp1, klevel, 2, 2, .TRUE., 1 )
+  DO l=1,klevel
+    DO ij=iip2,ip1jm
+      div(ij,l)=div(ij,l)*unsaire(ij)
+    ENDDO
+  ENDDO
+
+  END SUBROUTINE diverg
+
+  SUBROUTINE gr_v_scal(nx,x_v,x_scal)
+  ! convert values from v points to scalar points on C-grid
+  ! used to  compute unsfu, unseu (u points, but depends only on latitude)
+  IMPLICIT NONE
+
+  INTEGER,INTENT(IN) :: nx ! number of levels or fields
+  REAL,INTENT(IN) :: x_v((nbp_lon+1)*(nbp_lat-1),nx)
+  REAL,INTENT(OUT) :: x_scal((nbp_lon+1)*nbp_lat,nx)
+
+  INTEGER :: l,ij
+  INTEGER :: iip1,iip2,ip1jm,ip1jmp1
+
+  iip1=nbp_lon+1
+  iip2=nbp_lon+2
+  ip1jm=(nbp_lon+1)*(nbp_lat-1) ! = iip1*jjm
+  ip1jmp1=(nbp_lon+1)*nbp_lat ! = iip1*jjp1
+
+  DO l=1,nx
+    DO ij=iip2,ip1jm
+      x_scal(ij,l)= &
+                   (airev(ij-iip1)*x_v(ij-iip1,l)+airev(ij)*x_v(ij,l)) &
+                  /(airev(ij-iip1)+airev(ij))
+    ENDDO
+    DO ij=1,iip1
+      x_scal(ij,l)=0.
+    ENDDO
+    DO ij=ip1jm+1,ip1jmp1
+      x_scal(ij,l)=0.
+    ENDDO
+  ENDDO
+
+  END SUBROUTINE gr_v_scal
+ 
+  SUBROUTINE gr_scal_v(nx,x_scal,x_v)
+  ! convert values from scalar points to v points on C-grid
+  ! used to compute wind stress at V points
+  IMPLICIT NONE
+
+  INTEGER,INTENT(IN) :: nx ! number of levels or fields
+  REAL,INTENT(OUT) :: x_v((nbp_lon+1)*(nbp_lat-1),nx)
+  REAL,INTENT(IN) :: x_scal((nbp_lon+1)*nbp_lat,nx)
+
+  INTEGER :: l,ij
+  INTEGER :: iip1,ip1jm
+
+  iip1=nbp_lon+1
+  ip1jm=(nbp_lon+1)*(nbp_lat-1) ! = iip1*jjm
+
+      DO l=1,nx
+        DO ij=1,ip1jm
+          x_v(ij,l)= &
+            (cu(ij)*cvusurcu(ij)*x_scal(ij,l)+ &
+            cu(ij+iip1)*cvusurcu(ij+iip1)*x_scal(ij+iip1,l)) &
+            /(cu(ij)*cvusurcu(ij)+cu(ij+iip1)*cvusurcu(ij+iip1))
+        ENDDO
+      ENDDO
+
+  END SUBROUTINE gr_scal_v
+
+  SUBROUTINE gr_scal_u(nx,x_scal,x_u)
+  ! convert values from scalar points to U points on C-grid
+  ! used to compute wind stress at U points
+  IMPLICIT NONE
+
+  INTEGER,INTENT(IN) :: nx
+  REAL,INTENT(OUT) :: x_u((nbp_lon+1)*nbp_lat,nx)
+  REAL,INTENT(IN) :: x_scal((nbp_lon+1)*nbp_lat,nx)
+
+  INTEGER :: l,ij
+  INTEGER :: iip1,jjp1,ip1jmp1
+
+  iip1=nbp_lon+1
+  jjp1=nbp_lat
+  ip1jmp1=(nbp_lon+1)*nbp_lat ! = iip1*jjp1
+
+  DO l=1,nx
+     DO ij=1,ip1jmp1-1
+        x_u(ij,l)= &
+         (aire(ij)*x_scal(ij,l)+aire(ij+1)*x_scal(ij+1,l)) &
+         /(aire(ij)+aire(ij+1))
+     ENDDO
+  ENDDO
+
+  CALL SCOPY(nx*jjp1,x_u(1,1),iip1,x_u(iip1,1),iip1)
+
+  END SUBROUTINE gr_scal_u
+
+END MODULE slab_heat_transp_mod
Index: DZ6/trunk/libf/phylmd/soil.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/soil.F90	(revision 5267)
+++ 	(revision )
@@ -1,354 +1,0 @@
-!
-! $Header$
-!
-SUBROUTINE soil(ptimestep, indice, knon, snow, ptsrf, qsol, &
-     lon, lat, ptsoil, pcapcal, pfluxgrd)
-  
-  USE dimphy
-  USE mod_phys_lmdz_para
-  USE indice_sol_mod
-  USE print_control_mod, ONLY: lunout
-
-  IMPLICIT NONE
-
-!=======================================================================
-!
-!   Auteur:  Frederic Hourdin     30/01/92
-!   -------
-!
-!   Object:  Computation of : the soil temperature evolution
-!   -------                   the surfacic heat capacity "Capcal"
-!                            the surface conduction flux pcapcal
-!
-!   Update: 2021/07 : soil thermal inertia, formerly a constant value,
-!   ------   can also be now a function of soil moisture (F Cheruy's idea)
-!            depending on iflag_inertie, read from physiq.def via conf_phys_m.F90
-!            ("Stage L3" Eve Rebouillat, with E Vignon, A Sima, F Cheruy)
-!
-!   Method: Implicit time integration
-!   -------
-!   Consecutive ground temperatures are related by:
-!           T(k+1) = C(k) + D(k)*T(k)  (*)
-!   The coefficients C and D are computed at the t-dt time-step.
-!   Routine structure:
-!   1) C and D coefficients are computed from the old temperature
-!   2) new temperatures are computed using (*)
-!   3) C and D coefficients are computed from the new temperature
-!      profile for the t+dt time-step
-!   4) the coefficients A and B are computed where the diffusive
-!      fluxes at the t+dt time-step is given by
-!             Fdiff = A + B Ts(t+dt)
-!      or     Fdiff = F0 + Capcal (Ts(t+dt)-Ts(t))/dt
-!             with F0 = A + B (Ts(t))
-!                 Capcal = B*dt
-!           
-!   Interface:
-!   ----------
-!
-!   Arguments:
-!   ----------
-!   ptimestep            physical timestep (s)
-!   indice               sub-surface index
-!   snow(klon)           snow
-!   ptsrf(klon)          surface temperature at time-step t (K)
-!   qsol(klon)           soil moisture (kg/m2 or mm)
-!   lon(klon)            longitude in radian
-!   lat(klon)            latitude in radian
-!   ptsoil(klon,nsoilmx) temperature inside the ground (K)
-!   pcapcal(klon)        surfacic specific heat (W*m-2*s*K-1)
-!   pfluxgrd(klon)       surface diffusive flux from ground (Wm-2)
-!   
-!=======================================================================
-  INCLUDE "YOMCST.h"
-  INCLUDE "dimsoil.h"
-  INCLUDE "comsoil.h"
-!-----------------------------------------------------------------------
-! Arguments
-! ---------
-  REAL, INTENT(IN)                     :: ptimestep
-  INTEGER, INTENT(IN)                  :: indice, knon !, knindex
-  REAL, DIMENSION(klon), INTENT(IN)    :: snow
-  REAL, DIMENSION(klon), INTENT(IN)    :: ptsrf
-  REAL, DIMENSION(klon), INTENT(IN)    :: qsol
-  REAL, DIMENSION(klon), INTENT(IN)    :: lon
-  REAL, DIMENSION(klon), INTENT(IN)    :: lat
-
-  REAL, DIMENSION(klon,nsoilmx), INTENT(INOUT) :: ptsoil
-  REAL, DIMENSION(klon), INTENT(OUT)           :: pcapcal
-  REAL, DIMENSION(klon), INTENT(OUT)           :: pfluxgrd
-
-!-----------------------------------------------------------------------
-! Local variables
-! ---------------
-  INTEGER                             :: ig, jk, ierr
-  REAL                                :: min_period,dalph_soil
-  REAL, DIMENSION(nsoilmx)            :: zdz2
-  REAL                                :: z1s
-  REAL, DIMENSION(klon)               :: ztherm_i
-  REAL, DIMENSION(klon,nsoilmx,nbsrf) :: C_coef, D_coef
-
-! Local saved variables
-! ---------------------
-  REAL, SAVE                     :: lambda
-!$OMP THREADPRIVATE(lambda)
-  REAL, DIMENSION(nsoilmx), SAVE :: dz1, dz2
-!$OMP THREADPRIVATE(dz1,dz2)
-  LOGICAL, SAVE                  :: firstcall=.TRUE.
-!$OMP THREADPRIVATE(firstcall)
-    
-!-----------------------------------------------------------------------
-!   Depthts:
-!   --------
-  REAL fz,rk,fz1,rk1,rk2
-  fz(rk)=fz1*(dalph_soil**rk-1.)/(dalph_soil-1.)
-
-
-!-----------------------------------------------------------------------
-! Calculation of some constants
-! NB! These constants do not depend on the sub-surfaces
-!-----------------------------------------------------------------------
-
-  IF (firstcall) THEN
-!-----------------------------------------------------------------------
-!   ground levels 
-!   grnd=z/l where l is the skin depth of the diurnal cycle:
-!-----------------------------------------------------------------------
-
-     min_period=1800. ! en secondes
-     dalph_soil=2.    ! rapport entre les epaisseurs de 2 couches succ.
-!$OMP MASTER
-     IF (is_mpi_root) THEN
-        OPEN(99,file='soil.def',status='old',form='formatted',iostat=ierr)
-        IF (ierr == 0) THEN ! Read file only if it exists
-           READ(99,*) min_period
-           READ(99,*) dalph_soil
-           WRITE(lunout,*)'Discretization for the soil model'
-           WRITE(lunout,*)'First level e-folding depth',min_period, &
-                '   dalph',dalph_soil
-           CLOSE(99)
-        END IF
-     ENDIF
-!$OMP END MASTER
-     CALL bcast(min_period)
-     CALL bcast(dalph_soil)
-
-!   la premiere couche represente un dixieme de cycle diurne
-     fz1=SQRT(min_period/3.14)
-     
-     DO jk=1,nsoilmx
-        rk1=jk
-        rk2=jk-1
-        dz2(jk)=fz(rk1)-fz(rk2)
-     ENDDO
-     DO jk=1,nsoilmx-1
-        rk1=jk+.5
-        rk2=jk-.5
-        dz1(jk)=1./(fz(rk1)-fz(rk2))
-     ENDDO
-     lambda=fz(.5)*dz1(1)
-     WRITE(lunout,*)'full layers, intermediate layers (seconds)'
-     DO jk=1,nsoilmx
-        rk=jk
-        rk1=jk+.5
-        rk2=jk-.5
-        WRITE(lunout,*)'fz=', &
-             fz(rk1)*fz(rk2)*3.14,fz(rk)*fz(rk)*3.14
-     ENDDO
-
-     firstcall =.FALSE.
-  END IF
-
-
-!-----------------------------------------------------------------------
-!   Calcul de l'inertie thermique a partir de la variable rnat.
-!   on initialise a inertie_sic meme au-dessus d'un point de mer au cas 
-!   ou le point de mer devienne point de glace au pas suivant
-!   on corrige si on a un point de terre avec ou sans glace
-!
-!   iophys can be used to write the ztherm_i variable in a phys.nc file
-!   and check the results; to do so, add "CALL iophys_ini" in physiq_mod
-!   and add knindex to the list of inputs in all the calls to soil.F90
-!   (and to soil.F90 itself !)
-!-----------------------------------------------------------------------
-
-  IF (indice == is_sic) THEN
-     DO ig = 1, knon
-        ztherm_i(ig)   = inertie_sic
-     ENDDO
-     IF (iflag_sic == 0) THEN
-       DO ig = 1, knon
-         IF (snow(ig) > 0.0) ztherm_i(ig)   = inertie_sno
-       ENDDO
-!      Otherwise sea-ice keeps the same inertia, even when covered by snow
-     ENDIF
-!    CALL iophys_ecrit_index('ztherm_sic', 1, 'ztherm_sic', 'USI', &
-!      knon, knindex, ztherm_i)
-  ELSE IF (indice == is_lic) THEN
-     DO ig = 1, knon
-        ztherm_i(ig)   = inertie_lic
-        IF (snow(ig) > 0.0) ztherm_i(ig)   = inertie_sno
-     ENDDO
-!    CALL iophys_ecrit_index('ztherm_lic', 1, 'ztherm_lic', 'USI', &
-!      knon, knindex, ztherm_i)
-  ELSE IF (indice == is_ter) THEN
-     ! 
-     ! La relation entre l'inertie thermique du sol et qsol change d'apres 
-     !   iflag_inertie, defini dans physiq.def, et appele via comsoil.h
-     ! 
-     DO ig = 1, knon
-        ! iflag_inertie=0 correspond au cas inertie=constant, comme avant
-        IF (iflag_inertie==0) THEN         
-           ztherm_i(ig)   = inertie_sol
-        ELSE IF (iflag_inertie == 1) THEN
-          ! I = a_qsol * qsol + b  modele lineaire deduit d'une
-          ! regression lineaire I = a_mrsos * mrsos + b obtenue sur 
-          ! sorties MO d'une simulation LMDZOR(CMIP6) sur l'annee 2000 
-          ! sur tous les points avec frac_snow=0 
-          ! Difference entre qsol et mrsos prise en compte par un
-          ! facteur d'echelle sur le coefficient directeur de regression: 
-          ! fact = 35./150. = mrsos_max/qsol_max
-          ! et a_qsol = a_mrsos * fact (car a = dI/dHumidite)
-            ztherm_i(ig) = 30.0 *35.0/150.0 *qsol(ig) +770.0
-          ! AS : pour qsol entre 0 - 150, on a I entre 770 - 1820
-        ELSE IF (iflag_inertie == 2) THEN
-          ! deux regressions lineaires, sur les memes sorties,  
-          ! distinguant le type de sol : sable ou autre (limons/argile)
-          ! Implementation simple : regression type "sable" seulement pour 
-          ! Sahara, defini par une "boite" lat/lon (NB : en radians !! )
-          IF (lon(ig)>-0.35 .AND. lon(ig)<0.70 .AND. lat(ig)>0.17 .AND. lat(ig)<0.52) THEN 
-              ! Valeurs theoriquement entre 728 et 2373 ; qsol valeurs basses
-              ztherm_i(ig) = 47. *35.0/150.0 *qsol(ig) +728.  ! boite type "sable" pour Sahara
-          ELSE 
-              ! Valeurs theoriquement entre 550 et 1940 ; qsol valeurs moyennes et hautes
-              ztherm_i(ig) = 41. *35.0/150.0 *qsol(ig) +505.
-          ENDIF
-        ELSE IF (iflag_inertie == 3) THEN
-          ! AS : idee a tester : 
-          ! si la relation doit etre une droite, 
-          ! definissons-la en fonction des valeurs min et max de qsol (0:150),
-          ! et de l'inertie (900 : 2000 ou 2400 ; choix ici: 2000)
-          ! I = I_min + qsol * (I_max - I_min)/(qsol_max - qsol_min)
-              ztherm_i(ig) = 900. + qsol(ig) * (2000. - 900.)/150.
-        ELSE          
-          WRITE (lunout,*) "Le choix iflag_inertie = ",iflag_inertie," n'est pas defini. Veuillez choisir un entier entre 0 et 3" 
-        ENDIF
-     !
-     ! Fin de l'introduction de la relation entre l'inertie thermique du sol et qsol
-     !-------------------------------------------
-        !AS : donc le moindre flocon de neige sur un point de grid
-        ! fait que l'inertie du point passe a la valeur pour neige ! 
-        IF (snow(ig) > 0.0) ztherm_i(ig)   = inertie_sno
-       
-     ENDDO
-!    CALL iophys_ecrit_index('ztherm_ter', 1, 'ztherm_ter', 'USI', &
-!      knon, knindex, ztherm_i)
-  ELSE IF (indice == is_oce) THEN
-     DO ig = 1, knon
-!       This is just in case, but SST should be used by the model anyway
-        ztherm_i(ig)   = inertie_sic
-     ENDDO
-!    CALL iophys_ecrit_index('ztherm_oce', 1, 'ztherm_oce', 'USI', &
-!      knon, knindex, ztherm_i)
-  ELSE
-     WRITE(lunout,*) "valeur d indice non prevue", indice
-     call abort_physic("soil", "", 1)
-  ENDIF
-
-
-!-----------------------------------------------------------------------
-! 1)
-! Calculation of Cgrf and Dgrd coefficients using soil temperature from 
-! previous time step.
-!
-! These variables are recalculated on the local compressed grid instead 
-! of saved in restart file.
-!-----------------------------------------------------------------------
-  DO jk=1,nsoilmx
-     zdz2(jk)=dz2(jk)/ptimestep
-  ENDDO
-  
-  DO ig=1,knon
-     z1s = zdz2(nsoilmx)+dz1(nsoilmx-1)
-     C_coef(ig,nsoilmx-1,indice)= &
-          zdz2(nsoilmx)*ptsoil(ig,nsoilmx)/z1s
-     D_coef(ig,nsoilmx-1,indice)=dz1(nsoilmx-1)/z1s
-  ENDDO
-  
-  DO jk=nsoilmx-1,2,-1
-     DO ig=1,knon
-        z1s = 1./(zdz2(jk)+dz1(jk-1)+dz1(jk) &
-             *(1.-D_coef(ig,jk,indice)))
-        C_coef(ig,jk-1,indice)= &
-             (ptsoil(ig,jk)*zdz2(jk)+dz1(jk)*C_coef(ig,jk,indice)) * z1s
-        D_coef(ig,jk-1,indice)=dz1(jk-1)*z1s
-     ENDDO
-  ENDDO
-
-!-----------------------------------------------------------------------
-! 2)
-! Computation of the soil temperatures using the Cgrd and Dgrd
-! coefficient computed above
-!
-!-----------------------------------------------------------------------
-
-!    Surface temperature
-  DO ig=1,knon
-     ptsoil(ig,1)=(lambda*C_coef(ig,1,indice)+ptsrf(ig))/  &
-          (lambda*(1.-D_coef(ig,1,indice))+1.)
-  ENDDO
-  
-!   Other temperatures
-  DO jk=1,nsoilmx-1
-     DO ig=1,knon
-        ptsoil(ig,jk+1)=C_coef(ig,jk,indice)+D_coef(ig,jk,indice) &
-             *ptsoil(ig,jk)
-     ENDDO
-  ENDDO
-
-  IF (indice == is_sic) THEN
-     DO ig = 1 , knon
-        ptsoil(ig,nsoilmx) = RTT - 1.8
-     END DO
-  ENDIF
-
-!-----------------------------------------------------------------------
-! 3)
-! Calculate the Cgrd and Dgrd coefficient corresponding to actual soil 
-! temperature
-!-----------------------------------------------------------------------
-  DO ig=1,knon
-     z1s = zdz2(nsoilmx)+dz1(nsoilmx-1)
-     C_coef(ig,nsoilmx-1,indice) = zdz2(nsoilmx)*ptsoil(ig,nsoilmx)/z1s
-     D_coef(ig,nsoilmx-1,indice) = dz1(nsoilmx-1)/z1s
-  ENDDO
-  
-  DO jk=nsoilmx-1,2,-1
-     DO ig=1,knon
-        z1s = 1./(zdz2(jk)+dz1(jk-1)+dz1(jk) &
-             *(1.-D_coef(ig,jk,indice)))
-        C_coef(ig,jk-1,indice) = &
-             (ptsoil(ig,jk)*zdz2(jk)+dz1(jk)*C_coef(ig,jk,indice)) * z1s
-        D_coef(ig,jk-1,indice) = dz1(jk-1)*z1s
-     ENDDO
-  ENDDO
-
-!-----------------------------------------------------------------------
-! 4)
-! Computation of the surface diffusive flux from ground and
-! calorific capacity of the ground
-!-----------------------------------------------------------------------
-  DO ig=1,knon
-     pfluxgrd(ig) = ztherm_i(ig)*dz1(1)* &
-          (C_coef(ig,1,indice)+(D_coef(ig,1,indice)-1.)*ptsoil(ig,1))
-     pcapcal(ig)  = ztherm_i(ig)* &
-          (dz2(1)+ptimestep*(1.-D_coef(ig,1,indice))*dz1(1))
-     z1s = lambda*(1.-D_coef(ig,1,indice))+1.
-     pcapcal(ig)  = pcapcal(ig)/z1s
-     pfluxgrd(ig) = pfluxgrd(ig) &
-          + pcapcal(ig) * (ptsoil(ig,1) * z1s &
-          - lambda * C_coef(ig,1,indice) &
-          - ptsrf(ig)) &
-          /ptimestep
-  ENDDO
-    
-END SUBROUTINE soil
Index: /LMDZ6/trunk/libf/phylmd/soil.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/soil.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/soil.f90	(revision 5268)
@@ -0,0 +1,354 @@
+!
+! $Header$
+!
+SUBROUTINE soil(ptimestep, indice, knon, snow, ptsrf, qsol, &
+     lon, lat, ptsoil, pcapcal, pfluxgrd)
+  
+  USE dimphy
+  USE mod_phys_lmdz_para
+  USE indice_sol_mod
+  USE print_control_mod, ONLY: lunout
+
+  IMPLICIT NONE
+
+!=======================================================================
+!
+!   Auteur:  Frederic Hourdin     30/01/92
+!   -------
+!
+!   Object:  Computation of : the soil temperature evolution
+!   -------                   the surfacic heat capacity "Capcal"
+!                            the surface conduction flux pcapcal
+!
+!   Update: 2021/07 : soil thermal inertia, formerly a constant value,
+!   ------   can also be now a function of soil moisture (F Cheruy's idea)
+!            depending on iflag_inertie, read from physiq.def via conf_phys_m.F90
+!            ("Stage L3" Eve Rebouillat, with E Vignon, A Sima, F Cheruy)
+!
+!   Method: Implicit time integration
+!   -------
+!   Consecutive ground temperatures are related by:
+!           T(k+1) = C(k) + D(k)*T(k)  (*)
+!   The coefficients C and D are computed at the t-dt time-step.
+!   Routine structure:
+!   1) C and D coefficients are computed from the old temperature
+!   2) new temperatures are computed using (*)
+!   3) C and D coefficients are computed from the new temperature
+!      profile for the t+dt time-step
+!   4) the coefficients A and B are computed where the diffusive
+!      fluxes at the t+dt time-step is given by
+!             Fdiff = A + B Ts(t+dt)
+!      or     Fdiff = F0 + Capcal (Ts(t+dt)-Ts(t))/dt
+!             with F0 = A + B (Ts(t))
+!                 Capcal = B*dt
+!           
+!   Interface:
+!   ----------
+!
+!   Arguments:
+!   ----------
+!   ptimestep            physical timestep (s)
+!   indice               sub-surface index
+!   snow(klon)           snow
+!   ptsrf(klon)          surface temperature at time-step t (K)
+!   qsol(klon)           soil moisture (kg/m2 or mm)
+!   lon(klon)            longitude in radian
+!   lat(klon)            latitude in radian
+!   ptsoil(klon,nsoilmx) temperature inside the ground (K)
+!   pcapcal(klon)        surfacic specific heat (W*m-2*s*K-1)
+!   pfluxgrd(klon)       surface diffusive flux from ground (Wm-2)
+!   
+!=======================================================================
+  INCLUDE "YOMCST.h"
+  INCLUDE "dimsoil.h"
+  INCLUDE "comsoil.h"
+!-----------------------------------------------------------------------
+! Arguments
+! ---------
+  REAL, INTENT(IN)                     :: ptimestep
+  INTEGER, INTENT(IN)                  :: indice, knon !, knindex
+  REAL, DIMENSION(klon), INTENT(IN)    :: snow
+  REAL, DIMENSION(klon), INTENT(IN)    :: ptsrf
+  REAL, DIMENSION(klon), INTENT(IN)    :: qsol
+  REAL, DIMENSION(klon), INTENT(IN)    :: lon
+  REAL, DIMENSION(klon), INTENT(IN)    :: lat
+
+  REAL, DIMENSION(klon,nsoilmx), INTENT(INOUT) :: ptsoil
+  REAL, DIMENSION(klon), INTENT(OUT)           :: pcapcal
+  REAL, DIMENSION(klon), INTENT(OUT)           :: pfluxgrd
+
+!-----------------------------------------------------------------------
+! Local variables
+! ---------------
+  INTEGER                             :: ig, jk, ierr
+  REAL                                :: min_period,dalph_soil
+  REAL, DIMENSION(nsoilmx)            :: zdz2
+  REAL                                :: z1s
+  REAL, DIMENSION(klon)               :: ztherm_i
+  REAL, DIMENSION(klon,nsoilmx,nbsrf) :: C_coef, D_coef
+
+! Local saved variables
+! ---------------------
+  REAL, SAVE                     :: lambda
+!$OMP THREADPRIVATE(lambda)
+  REAL, DIMENSION(nsoilmx), SAVE :: dz1, dz2
+!$OMP THREADPRIVATE(dz1,dz2)
+  LOGICAL, SAVE                  :: firstcall=.TRUE.
+!$OMP THREADPRIVATE(firstcall)
+    
+!-----------------------------------------------------------------------
+!   Depthts:
+!   --------
+  REAL fz,rk,fz1,rk1,rk2
+  fz(rk)=fz1*(dalph_soil**rk-1.)/(dalph_soil-1.)
+
+
+!-----------------------------------------------------------------------
+! Calculation of some constants
+! NB! These constants do not depend on the sub-surfaces
+!-----------------------------------------------------------------------
+
+  IF (firstcall) THEN
+!-----------------------------------------------------------------------
+!   ground levels 
+!   grnd=z/l where l is the skin depth of the diurnal cycle:
+!-----------------------------------------------------------------------
+
+     min_period=1800. ! en secondes
+     dalph_soil=2.    ! rapport entre les epaisseurs de 2 couches succ.
+!$OMP MASTER
+     IF (is_mpi_root) THEN
+        OPEN(99,file='soil.def',status='old',form='formatted',iostat=ierr)
+        IF (ierr == 0) THEN ! Read file only if it exists
+           READ(99,*) min_period
+           READ(99,*) dalph_soil
+           WRITE(lunout,*)'Discretization for the soil model'
+           WRITE(lunout,*)'First level e-folding depth',min_period, &
+                '   dalph',dalph_soil
+           CLOSE(99)
+        END IF
+     ENDIF
+!$OMP END MASTER
+     CALL bcast(min_period)
+     CALL bcast(dalph_soil)
+
+!   la premiere couche represente un dixieme de cycle diurne
+     fz1=SQRT(min_period/3.14)
+     
+     DO jk=1,nsoilmx
+        rk1=jk
+        rk2=jk-1
+        dz2(jk)=fz(rk1)-fz(rk2)
+     ENDDO
+     DO jk=1,nsoilmx-1
+        rk1=jk+.5
+        rk2=jk-.5
+        dz1(jk)=1./(fz(rk1)-fz(rk2))
+     ENDDO
+     lambda=fz(.5)*dz1(1)
+     WRITE(lunout,*)'full layers, intermediate layers (seconds)'
+     DO jk=1,nsoilmx
+        rk=jk
+        rk1=jk+.5
+        rk2=jk-.5
+        WRITE(lunout,*)'fz=', &
+             fz(rk1)*fz(rk2)*3.14,fz(rk)*fz(rk)*3.14
+     ENDDO
+
+     firstcall =.FALSE.
+  END IF
+
+
+!-----------------------------------------------------------------------
+!   Calcul de l'inertie thermique a partir de la variable rnat.
+!   on initialise a inertie_sic meme au-dessus d'un point de mer au cas 
+!   ou le point de mer devienne point de glace au pas suivant
+!   on corrige si on a un point de terre avec ou sans glace
+!
+!   iophys can be used to write the ztherm_i variable in a phys.nc file
+!   and check the results; to do so, add "CALL iophys_ini" in physiq_mod
+!   and add knindex to the list of inputs in all the calls to soil.F90
+!   (and to soil.F90 itself !)
+!-----------------------------------------------------------------------
+
+  IF (indice == is_sic) THEN
+     DO ig = 1, knon
+        ztherm_i(ig)   = inertie_sic
+     ENDDO
+     IF (iflag_sic == 0) THEN
+       DO ig = 1, knon
+         IF (snow(ig) > 0.0) ztherm_i(ig)   = inertie_sno
+       ENDDO
+!      Otherwise sea-ice keeps the same inertia, even when covered by snow
+     ENDIF
+!    CALL iophys_ecrit_index('ztherm_sic', 1, 'ztherm_sic', 'USI', &
+!      knon, knindex, ztherm_i)
+  ELSE IF (indice == is_lic) THEN
+     DO ig = 1, knon
+        ztherm_i(ig)   = inertie_lic
+        IF (snow(ig) > 0.0) ztherm_i(ig)   = inertie_sno
+     ENDDO
+!    CALL iophys_ecrit_index('ztherm_lic', 1, 'ztherm_lic', 'USI', &
+!      knon, knindex, ztherm_i)
+  ELSE IF (indice == is_ter) THEN
+     ! 
+     ! La relation entre l'inertie thermique du sol et qsol change d'apres 
+     !   iflag_inertie, defini dans physiq.def, et appele via comsoil.h
+     ! 
+     DO ig = 1, knon
+        ! iflag_inertie=0 correspond au cas inertie=constant, comme avant
+        IF (iflag_inertie==0) THEN         
+           ztherm_i(ig)   = inertie_sol
+        ELSE IF (iflag_inertie == 1) THEN
+          ! I = a_qsol * qsol + b  modele lineaire deduit d'une
+          ! regression lineaire I = a_mrsos * mrsos + b obtenue sur 
+          ! sorties MO d'une simulation LMDZOR(CMIP6) sur l'annee 2000 
+          ! sur tous les points avec frac_snow=0 
+          ! Difference entre qsol et mrsos prise en compte par un
+          ! facteur d'echelle sur le coefficient directeur de regression: 
+          ! fact = 35./150. = mrsos_max/qsol_max
+          ! et a_qsol = a_mrsos * fact (car a = dI/dHumidite)
+            ztherm_i(ig) = 30.0 *35.0/150.0 *qsol(ig) +770.0
+          ! AS : pour qsol entre 0 - 150, on a I entre 770 - 1820
+        ELSE IF (iflag_inertie == 2) THEN
+          ! deux regressions lineaires, sur les memes sorties,  
+          ! distinguant le type de sol : sable ou autre (limons/argile)
+          ! Implementation simple : regression type "sable" seulement pour 
+          ! Sahara, defini par une "boite" lat/lon (NB : en radians !! )
+          IF (lon(ig)>-0.35 .AND. lon(ig)<0.70 .AND. lat(ig)>0.17 .AND. lat(ig)<0.52) THEN 
+              ! Valeurs theoriquement entre 728 et 2373 ; qsol valeurs basses
+              ztherm_i(ig) = 47. *35.0/150.0 *qsol(ig) +728.  ! boite type "sable" pour Sahara
+          ELSE 
+              ! Valeurs theoriquement entre 550 et 1940 ; qsol valeurs moyennes et hautes
+              ztherm_i(ig) = 41. *35.0/150.0 *qsol(ig) +505.
+          ENDIF
+        ELSE IF (iflag_inertie == 3) THEN
+          ! AS : idee a tester : 
+          ! si la relation doit etre une droite, 
+          ! definissons-la en fonction des valeurs min et max de qsol (0:150),
+          ! et de l'inertie (900 : 2000 ou 2400 ; choix ici: 2000)
+          ! I = I_min + qsol * (I_max - I_min)/(qsol_max - qsol_min)
+              ztherm_i(ig) = 900. + qsol(ig) * (2000. - 900.)/150.
+        ELSE          
+          WRITE (lunout,*) "Le choix iflag_inertie = ",iflag_inertie," n'est pas defini. Veuillez choisir un entier entre 0 et 3" 
+        ENDIF
+     !
+     ! Fin de l'introduction de la relation entre l'inertie thermique du sol et qsol
+     !-------------------------------------------
+        !AS : donc le moindre flocon de neige sur un point de grid
+        ! fait que l'inertie du point passe a la valeur pour neige ! 
+        IF (snow(ig) > 0.0) ztherm_i(ig)   = inertie_sno
+       
+     ENDDO
+!    CALL iophys_ecrit_index('ztherm_ter', 1, 'ztherm_ter', 'USI', &
+!      knon, knindex, ztherm_i)
+  ELSE IF (indice == is_oce) THEN
+     DO ig = 1, knon
+!       This is just in case, but SST should be used by the model anyway
+        ztherm_i(ig)   = inertie_sic
+     ENDDO
+!    CALL iophys_ecrit_index('ztherm_oce', 1, 'ztherm_oce', 'USI', &
+!      knon, knindex, ztherm_i)
+  ELSE
+     WRITE(lunout,*) "valeur d indice non prevue", indice
+     call abort_physic("soil", "", 1)
+  ENDIF
+
+
+!-----------------------------------------------------------------------
+! 1)
+! Calculation of Cgrf and Dgrd coefficients using soil temperature from 
+! previous time step.
+!
+! These variables are recalculated on the local compressed grid instead 
+! of saved in restart file.
+!-----------------------------------------------------------------------
+  DO jk=1,nsoilmx
+     zdz2(jk)=dz2(jk)/ptimestep
+  ENDDO
+  
+  DO ig=1,knon
+     z1s = zdz2(nsoilmx)+dz1(nsoilmx-1)
+     C_coef(ig,nsoilmx-1,indice)= &
+          zdz2(nsoilmx)*ptsoil(ig,nsoilmx)/z1s
+     D_coef(ig,nsoilmx-1,indice)=dz1(nsoilmx-1)/z1s
+  ENDDO
+  
+  DO jk=nsoilmx-1,2,-1
+     DO ig=1,knon
+        z1s = 1./(zdz2(jk)+dz1(jk-1)+dz1(jk) &
+             *(1.-D_coef(ig,jk,indice)))
+        C_coef(ig,jk-1,indice)= &
+             (ptsoil(ig,jk)*zdz2(jk)+dz1(jk)*C_coef(ig,jk,indice)) * z1s
+        D_coef(ig,jk-1,indice)=dz1(jk-1)*z1s
+     ENDDO
+  ENDDO
+
+!-----------------------------------------------------------------------
+! 2)
+! Computation of the soil temperatures using the Cgrd and Dgrd
+! coefficient computed above
+!
+!-----------------------------------------------------------------------
+
+!    Surface temperature
+  DO ig=1,knon
+     ptsoil(ig,1)=(lambda*C_coef(ig,1,indice)+ptsrf(ig))/  &
+          (lambda*(1.-D_coef(ig,1,indice))+1.)
+  ENDDO
+  
+!   Other temperatures
+  DO jk=1,nsoilmx-1
+     DO ig=1,knon
+        ptsoil(ig,jk+1)=C_coef(ig,jk,indice)+D_coef(ig,jk,indice) &
+             *ptsoil(ig,jk)
+     ENDDO
+  ENDDO
+
+  IF (indice == is_sic) THEN
+     DO ig = 1 , knon
+        ptsoil(ig,nsoilmx) = RTT - 1.8
+     END DO
+  ENDIF
+
+!-----------------------------------------------------------------------
+! 3)
+! Calculate the Cgrd and Dgrd coefficient corresponding to actual soil 
+! temperature
+!-----------------------------------------------------------------------
+  DO ig=1,knon
+     z1s = zdz2(nsoilmx)+dz1(nsoilmx-1)
+     C_coef(ig,nsoilmx-1,indice) = zdz2(nsoilmx)*ptsoil(ig,nsoilmx)/z1s
+     D_coef(ig,nsoilmx-1,indice) = dz1(nsoilmx-1)/z1s
+  ENDDO
+  
+  DO jk=nsoilmx-1,2,-1
+     DO ig=1,knon
+        z1s = 1./(zdz2(jk)+dz1(jk-1)+dz1(jk) &
+             *(1.-D_coef(ig,jk,indice)))
+        C_coef(ig,jk-1,indice) = &
+             (ptsoil(ig,jk)*zdz2(jk)+dz1(jk)*C_coef(ig,jk,indice)) * z1s
+        D_coef(ig,jk-1,indice) = dz1(jk-1)*z1s
+     ENDDO
+  ENDDO
+
+!-----------------------------------------------------------------------
+! 4)
+! Computation of the surface diffusive flux from ground and
+! calorific capacity of the ground
+!-----------------------------------------------------------------------
+  DO ig=1,knon
+     pfluxgrd(ig) = ztherm_i(ig)*dz1(1)* &
+          (C_coef(ig,1,indice)+(D_coef(ig,1,indice)-1.)*ptsoil(ig,1))
+     pcapcal(ig)  = ztherm_i(ig)* &
+          (dz2(1)+ptimestep*(1.-D_coef(ig,1,indice))*dz1(1))
+     z1s = lambda*(1.-D_coef(ig,1,indice))+1.
+     pcapcal(ig)  = pcapcal(ig)/z1s
+     pfluxgrd(ig) = pfluxgrd(ig) &
+          + pcapcal(ig) * (ptsoil(ig,1) * z1s &
+          - lambda * C_coef(ig,1,indice) &
+          - ptsrf(ig)) &
+          /ptimestep
+  ENDDO
+    
+END SUBROUTINE soil
Index: DZ6/trunk/libf/phylmd/solarlong.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/solarlong.F90	(revision 5267)
+++ 	(revision )
@@ -1,134 +1,0 @@
-SUBROUTINE solarlong(pday, psollong, pdist_sol)
-
-  USE ioipsl
-  USE print_control_mod, ONLY: lunout
-
-  IMPLICIT NONE
-
-  ! =======================================================================
-
-  ! Objet:
-  ! ------
-
-  ! Calcul de la distance soleil-planete et de la declinaison
-  ! en fonction du jour de l'annee.
-
-
-  ! Methode:
-  ! --------
-
-  ! Calcul complet de l'elipse
-
-  ! Interface:
-  ! ----------
-
-  ! Uncommon comprenant les parametres orbitaux.
-
-  ! Arguments:
-  ! ----------
-
-  ! Input:
-  ! ------
-  ! pday          jour de l'annee (le jour 0 correspondant a l'equinoxe)
-  ! lwrite        clef logique pour sorties de controle
-
-  ! Output:
-  ! -------
-  ! pdist_sol     distance entre le soleil et la planete
-  ! ( en unite astronomique pour utiliser la constante
-  ! solaire terrestre 1370 Wm-2 )
-  ! pdecli        declinaison ( en radians )
-
-  ! =======================================================================
-  ! -----------------------------------------------------------------------
-  ! Declarations:
-  ! -------------
-
-  include "planete.h"
-  include "YOMCST.h"
-
-  ! arguments:
-  ! ----------
-
-  REAL pday, pdist_sol, pdecli, psollong
-  LOGICAL lwrite
-
-  ! Local:
-  ! ------
-
-  REAL zanom, xref, zx0, zdx, zteta, zz, pi
-  INTEGER iter
-  REAL :: pyear_day, pperi_day
-  REAL :: jd_eq, jd_peri
-  LOGICAL, SAVE :: first = .TRUE.
-  !$OMP THREADPRIVATE(first)
-
-  ! -----------------------------------------------------------------------
-  ! calcul de l'angle polaire et de la distance au soleil :
-  ! -------------------------------------------------------
-
-  ! Initialisation eventuelle:
-  IF (first) THEN
-    CALL ioget_calendar(pyear_day)
-    CALL ymds2ju(2000, 3, 21, 0., jd_eq)
-    CALL ymds2ju(2001, 1, 4, 0., jd_peri)
-    pperi_day = jd_peri - jd_eq
-    pperi_day = r_peri + 180.
-    WRITE (lunout, *) ' Number of days in a year = ', pyear_day
-    ! call iniorbit(249.22,206.66,669.,485.,25.2)
-    CALL iniorbit(152.59, 146.61, pyear_day, pperi_day, r_incl)
-    first = .FALSE.
-  END IF
-
-  ! calcul de l'zanomalie moyenne
-
-  zz = (pday-peri_day)/year_day
-  pi = 2.*asin(1.)
-  zanom = 2.*pi*(zz-nint(zz))
-  xref = abs(zanom)
-
-  ! resolution de l'equation horaire  zx0 - e * sin (zx0) = xref
-  ! methode de Newton
-
-  ! zx0=xref+e_elips*sin(xref)
-  zx0 = xref + r_ecc*sin(xref)
-  DO iter = 1, 10
-    ! zdx=-(zx0-e_elips*sin(zx0)-xref)/(1.-e_elips*cos(zx0))
-    zdx = -(zx0-r_ecc*sin(zx0)-xref)/(1.-r_ecc*cos(zx0))
-    IF (abs(zdx)<=(1.E-7)) GO TO 120
-    zx0 = zx0 + zdx
-  END DO
-120 CONTINUE
-  zx0 = zx0 + zdx
-  IF (zanom<0.) zx0 = -zx0
-
-  ! zteta est la longitude solaire
-
-  ! zteta=2.*atan(sqrt((1.+e_elips)/(1.-e_elips))*tan(zx0/2.))
-  zteta = 2.*atan(sqrt((1.+r_ecc)/(1.-r_ecc))*tan(zx0/2.))
-
-  psollong = zteta - timeperi
-
-  IF (psollong<0.) psollong = psollong + 2.*pi
-  IF (psollong>2.*pi) psollong = psollong - 2.*pi
-
-  psollong = psollong*180./pi
-
-  ! distance soleil
-
-  pdist_sol = (1-r_ecc*r_ecc)/(1+r_ecc*cos(pi/180.*(psollong- &
-    (r_peri+180.0))))
-  ! pdist_sol = (1-e_elips*e_elips)
-  ! &      /(1+e_elips*COS(pi/180.*(psollong-(R_peri+180.0))))
-  ! -----------------------------------------------------------------------
-  ! sorties eventuelles:
-  ! ---------------------
-
-  ! IF (lwrite) THEN
-  ! PRINT*,'jour de l"annee   :',pday
-  ! PRINT*,'distance au soleil (en unite astronomique) :',pdist_sol
-  ! PRINT*,'declinaison (en degres) :',pdecli*180./pi
-  ! ENDIF
-
-  RETURN
-END SUBROUTINE solarlong
Index: /LMDZ6/trunk/libf/phylmd/solarlong.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/solarlong.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/solarlong.f90	(revision 5268)
@@ -0,0 +1,134 @@
+SUBROUTINE solarlong(pday, psollong, pdist_sol)
+
+  USE ioipsl
+  USE print_control_mod, ONLY: lunout
+
+  IMPLICIT NONE
+
+  ! =======================================================================
+
+  ! Objet:
+  ! ------
+
+  ! Calcul de la distance soleil-planete et de la declinaison
+  ! en fonction du jour de l'annee.
+
+
+  ! Methode:
+  ! --------
+
+  ! Calcul complet de l'elipse
+
+  ! Interface:
+  ! ----------
+
+  ! Uncommon comprenant les parametres orbitaux.
+
+  ! Arguments:
+  ! ----------
+
+  ! Input:
+  ! ------
+  ! pday          jour de l'annee (le jour 0 correspondant a l'equinoxe)
+  ! lwrite        clef logique pour sorties de controle
+
+  ! Output:
+  ! -------
+  ! pdist_sol     distance entre le soleil et la planete
+  ! ( en unite astronomique pour utiliser la constante
+  ! solaire terrestre 1370 Wm-2 )
+  ! pdecli        declinaison ( en radians )
+
+  ! =======================================================================
+  ! -----------------------------------------------------------------------
+  ! Declarations:
+  ! -------------
+
+  include "planete.h"
+  include "YOMCST.h"
+
+  ! arguments:
+  ! ----------
+
+  REAL pday, pdist_sol, pdecli, psollong
+  LOGICAL lwrite
+
+  ! Local:
+  ! ------
+
+  REAL zanom, xref, zx0, zdx, zteta, zz, pi
+  INTEGER iter
+  REAL :: pyear_day, pperi_day
+  REAL :: jd_eq, jd_peri
+  LOGICAL, SAVE :: first = .TRUE.
+  !$OMP THREADPRIVATE(first)
+
+  ! -----------------------------------------------------------------------
+  ! calcul de l'angle polaire et de la distance au soleil :
+  ! -------------------------------------------------------
+
+  ! Initialisation eventuelle:
+  IF (first) THEN
+    CALL ioget_calendar(pyear_day)
+    CALL ymds2ju(2000, 3, 21, 0., jd_eq)
+    CALL ymds2ju(2001, 1, 4, 0., jd_peri)
+    pperi_day = jd_peri - jd_eq
+    pperi_day = r_peri + 180.
+    WRITE (lunout, *) ' Number of days in a year = ', pyear_day
+    ! call iniorbit(249.22,206.66,669.,485.,25.2)
+    CALL iniorbit(152.59, 146.61, pyear_day, pperi_day, r_incl)
+    first = .FALSE.
+  END IF
+
+  ! calcul de l'zanomalie moyenne
+
+  zz = (pday-peri_day)/year_day
+  pi = 2.*asin(1.)
+  zanom = 2.*pi*(zz-nint(zz))
+  xref = abs(zanom)
+
+  ! resolution de l'equation horaire  zx0 - e * sin (zx0) = xref
+  ! methode de Newton
+
+  ! zx0=xref+e_elips*sin(xref)
+  zx0 = xref + r_ecc*sin(xref)
+  DO iter = 1, 10
+    ! zdx=-(zx0-e_elips*sin(zx0)-xref)/(1.-e_elips*cos(zx0))
+    zdx = -(zx0-r_ecc*sin(zx0)-xref)/(1.-r_ecc*cos(zx0))
+    IF (abs(zdx)<=(1.E-7)) GO TO 120
+    zx0 = zx0 + zdx
+  END DO
+120 CONTINUE
+  zx0 = zx0 + zdx
+  IF (zanom<0.) zx0 = -zx0
+
+  ! zteta est la longitude solaire
+
+  ! zteta=2.*atan(sqrt((1.+e_elips)/(1.-e_elips))*tan(zx0/2.))
+  zteta = 2.*atan(sqrt((1.+r_ecc)/(1.-r_ecc))*tan(zx0/2.))
+
+  psollong = zteta - timeperi
+
+  IF (psollong<0.) psollong = psollong + 2.*pi
+  IF (psollong>2.*pi) psollong = psollong - 2.*pi
+
+  psollong = psollong*180./pi
+
+  ! distance soleil
+
+  pdist_sol = (1-r_ecc*r_ecc)/(1+r_ecc*cos(pi/180.*(psollong- &
+    (r_peri+180.0))))
+  ! pdist_sol = (1-e_elips*e_elips)
+  ! &      /(1+e_elips*COS(pi/180.*(psollong-(R_peri+180.0))))
+  ! -----------------------------------------------------------------------
+  ! sorties eventuelles:
+  ! ---------------------
+
+  ! IF (lwrite) THEN
+  ! PRINT*,'jour de l"annee   :',pday
+  ! PRINT*,'distance au soleil (en unite astronomique) :',pdist_sol
+  ! PRINT*,'declinaison (en degres) :',pdecli*180./pi
+  ! ENDIF
+
+  RETURN
+END SUBROUTINE solarlong
Index: DZ6/trunk/libf/phylmd/stdlevvar_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/stdlevvar_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,757 +1,0 @@
-!
-MODULE stdlevvar_mod
-!
-! This module contains main procedures for calculation
-! of temperature, specific humidity and wind at a reference level
-!
-  USE cdrag_mod
-  USE screenp_mod
-  USE screenc_mod
-  IMPLICIT NONE
-
-CONTAINS
-!
-!****************************************************************************************
-!
-!r original routine svn3623
-!
-      SUBROUTINE stdlevvar(klon, knon, nsrf, zxli, &
-                           u1, v1, t1, q1, z1, &
-                           ts1, qsurf, z0m, z0h, psol, pat1, &
-                           t_2m, q_2m, t_10m, q_10m, u_10m, ustar, s_pblh, prain, tsol)
-      IMPLICIT NONE
-!-------------------------------------------------------------------------
-!
-! Objet : calcul de la temperature et l'humidite relative a 2m et du 
-!         module du vent a 10m a partir des relations de Dyer-Businger et
-!         des equations de Louis.
-!
-! Reference : Hess, Colman et McAvaney (1995)        
-!
-! I. Musat, 01.07.2002
-!
-!AM On rajoute en sortie t et q a 10m pr le calcule d'hbtm2 dans clmain
-!
-!-------------------------------------------------------------------------
-!
-! klon----input-I- dimension de la grille physique (= nb_pts_latitude X nb_pts_longitude)
-! knon----input-I- nombre de points pour un type de surface
-! nsrf----input-I- indice pour le type de surface; voir indice_sol_mod.F90
-! zxli----input-L- TRUE si calcul des cdrags selon Laurent Li
-! u1------input-R- vent zonal au 1er niveau du modele
-! v1------input-R- vent meridien au 1er niveau du modele
-! t1------input-R- temperature de l'air au 1er niveau du modele
-! q1------input-R- humidite relative au 1er niveau du modele
-! z1------input-R- geopotentiel au 1er niveau du modele
-! ts1-----input-R- temperature de l'air a la surface
-! qsurf---input-R- humidite relative a la surface
-! z0m, z0h---input-R- rugosite
-! psol----input-R- pression au sol
-! pat1----input-R- pression au 1er niveau du modele
-!
-! t_2m---output-R- temperature de l'air a 2m
-! q_2m---output-R- humidite relative a 2m
-! u_10m--output-R- vitesse du vent a 10m
-!AM
-! t_10m--output-R- temperature de l'air a 10m
-! q_10m--output-R- humidite specifique a 10m
-! ustar--output-R- u*
-!
-      INTEGER, intent(in) :: klon, knon, nsrf
-      LOGICAL, intent(in) :: zxli
-      REAL, dimension(klon), intent(in) :: u1, v1, t1, q1, z1, ts1
-      REAL, dimension(klon), intent(in) :: qsurf
-      REAL, dimension(klon), intent(inout) :: z0m, z0h
-      REAL, dimension(klon), intent(in) :: psol, pat1
-!
-      REAL, dimension(klon), intent(out) :: t_2m, q_2m, ustar
-      REAL, dimension(klon), intent(out) :: u_10m, t_10m, q_10m
-      REAL, DIMENSION(klon), INTENT(INOUT) :: s_pblh
-      REAL, DIMENSION(klon), INTENT(IN) :: prain
-      REAL, DIMENSION(klon), INTENT(IN) :: tsol
-!-------------------------------------------------------------------------
-      include "flux_arp.h"
-      include "YOMCST.h"
-!IM PLUS
-      include "YOETHF.h"
-!
-! Quelques constantes et options:
-!
-! RKAR : constante de von Karman
-      REAL, PARAMETER :: RKAR=0.40
-! niter : nombre iterations calcul "corrector"
-!     INTEGER, parameter :: niter=6, ncon=niter-1
-      INTEGER, parameter :: niter=2, ncon=niter-1
-!
-! Variables locales
-      INTEGER :: i, n
-      REAL :: zref
-      REAL, dimension(klon) :: speed
-! tpot : temperature potentielle
-      REAL, dimension(klon) :: tpot
-      REAL, dimension(klon) :: zri1, cdran
-      REAL, dimension(klon) :: cdram, cdrah
-! ri1 : nb. de Richardson entre la surface --> la 1ere couche
-      REAL, dimension(klon) :: ri1 
-      REAL, dimension(klon) :: testar, qstar
-      REAL, dimension(klon) :: zdte, zdq   
-! lmon : longueur de Monin-Obukhov selon Hess, Colman and McAvaney 
-      DOUBLE PRECISION, dimension(klon) :: lmon
-      DOUBLE PRECISION, parameter :: eps=1.0D-20
-      REAL, dimension(klon) :: delu, delte, delq
-      REAL, dimension(klon) :: u_zref, te_zref, q_zref  
-      REAL, dimension(klon) :: temp, pref
-      LOGICAL :: okri
-      REAL, dimension(klon) :: u_zref_p, te_zref_p, temp_p, q_zref_p
-!convertgence
-      REAL, dimension(klon) :: te_zref_con, q_zref_con
-      REAL, dimension(klon) :: u_zref_c, te_zref_c, temp_c, q_zref_c
-      REAL, dimension(klon) :: ok_pred, ok_corr, zri_zero
-!     REAL, dimension(klon) :: conv_te, conv_q
-!------------------------------------------------------------------------- 
-      DO i=1, knon
-       speed(i)=SQRT(u1(i)**2+v1(i)**2)
-       ri1(i) = 0.0
-      ENDDO
-!
-      okri=.FALSE.
-!      CALL coefcdrag(klon, knon, nsrf, zxli, &
-! &                   speed, t1, q1, z1, psol, &
-! &                   ts1, qsurf, rugos, okri, ri1,  &         
-! &                   cdram, cdrah, cdran, zri1, pref)            
-! Fuxing WANG, 04/03/2015, replace the coefcdrag by the merged version: cdrag
-
-      CALL cdrag(knon, nsrf, &
- &                   speed, t1, q1, z1, &
- &                   psol, s_pblh, ts1, qsurf, z0m, z0h, &
- &                   zri_zero, 0, &
- &                   cdram, cdrah, zri1, pref, prain, tsol, pat1)
-
-! --- special Dice: on force cdragm ( a defaut de forcer ustar) MPL 05082013
-     IF (ok_prescr_ust) then
-      DO i = 1, knon
-       print *,'cdram avant=',cdram(i)
-       cdram(i) = ust*ust/speed(i)/speed(i)
-       print *,'cdram ust speed apres=',cdram(i),ust,speed
-      ENDDO
-     ENDIF
-!
-!---------Star variables----------------------------------------------------
-!
-      DO i = 1, knon
-        ri1(i) = zri1(i)
-        tpot(i) = t1(i)* (psol(i)/pat1(i))**RKAPPA
-        ustar(i) = sqrt(cdram(i) * speed(i) * speed(i))
-        zdte(i) = tpot(i) - ts1(i)
-        zdq(i) = max(q1(i),0.0) - max(qsurf(i),0.0)
-!
-!
-!IM BUG BUG BUG       zdte(i) = max(zdte(i),1.e-10)
-        zdte(i) = sign(max(abs(zdte(i)),1.e-10),zdte(i))
-!
-        testar(i) = (cdrah(i) * zdte(i) * speed(i))/ustar(i)
-        qstar(i) = (cdrah(i) * zdq(i) * speed(i))/ustar(i)
-        lmon(i) = (ustar(i) * ustar(i) * tpot(i))/ &
- &                (RKAR * RG * testar(i))
-      ENDDO
-!
-!----------First aproximation of variables at zref --------------------------
-      zref = 2.0
-      CALL screenp(klon, knon, nsrf, speed, tpot, q1, &
- &                 ts1, qsurf, z0m, lmon, &
- &                 ustar, testar, qstar, zref, &
- &                 delu, delte, delq)
-!
-      DO i = 1, knon
-        u_zref(i) = delu(i)
-        q_zref(i) = max(qsurf(i),0.0) + delq(i)
-        te_zref(i) = ts1(i) + delte(i)
-        temp(i) = te_zref(i) * (psol(i)/pat1(i))**(-RKAPPA)
-        q_zref_p(i) = q_zref(i)
-!       te_zref_p(i) = te_zref(i)
-        temp_p(i) = temp(i)
-      ENDDO
-!
-! Iteration of the variables at the reference level zref : corrector calculation ; see Hess & McAvaney, 1995 
-!
-      DO n = 1, niter
-!
-        okri=.TRUE.
-        CALL screenc(klon, knon, nsrf, zxli, &
- &                   u_zref, temp, q_zref, zref, &
- &                   ts1, qsurf, z0m, z0h, psol, &           
- &                   ustar, testar, qstar, okri, ri1, &
- &                   pref, delu, delte, delq, s_pblh ,prain, tsol, pat1) 
-!
-        DO i = 1, knon
-          u_zref(i) = delu(i)
-          q_zref(i) = delq(i) + max(qsurf(i),0.0)
-          te_zref(i) = delte(i) + ts1(i) 
-!
-! return to normal temperature
-!
-          temp(i) = te_zref(i) * (psol(i)/pref(i))**(-RKAPPA)
-!         temp(i) = te_zref(i) - (zref* RG)/RCPD/ &
-!                 (1 + RVTMP2 * max(q_zref(i),0.0))
-!
-!IM +++
-!         IF(temp(i).GT.350.) THEN
-!           WRITE(*,*) 'temp(i) GT 350 K !!',i,nsrf,temp(i)
-!         ENDIF
-!IM ---
-!
-        IF(n.EQ.ncon) THEN
-          te_zref_con(i) = te_zref(i)
-          q_zref_con(i) = q_zref(i)
-        ENDIF 
-!
-        ENDDO 
-!
-      ENDDO 
-!
-! verifier le critere de convergence : 0.25% pour te_zref et 5% pour qe_zref
-!
-!       DO i = 1, knon
-!         conv_te(i) = (te_zref(i) - te_zref_con(i))/te_zref_con(i)
-!         conv_q(i) = (q_zref(i) - q_zref_con(i))/q_zref_con(i)
-!IM +++
-!         IF(abs(conv_te(i)).GE.0.0025.AND.abs(conv_q(i)).GE.0.05) THEN
-!           PRINT*,'DIV','i=',i,te_zref_con(i),te_zref(i),conv_te(i), &
-!           q_zref_con(i),q_zref(i),conv_q(i)
-!         ENDIF
-!IM ---
-!       ENDDO
-!
-      DO i = 1, knon
-        q_zref_c(i) = q_zref(i)
-        temp_c(i) = temp(i)
-!
-!       IF(zri1(i).LT.0.) THEN
-!         IF(nsrf.EQ.1) THEN
-!           ok_pred(i)=1.
-!           ok_corr(i)=0.
-!         ELSE
-!           ok_pred(i)=0.
-!           ok_corr(i)=1.
-!         ENDIF
-!       ELSE
-!         ok_pred(i)=0.
-!         ok_corr(i)=1.
-!       ENDIF
-!
-        ok_pred(i)=0.
-        ok_corr(i)=1.
-!
-        t_2m(i) = temp_p(i) * ok_pred(i) + temp_c(i) * ok_corr(i)
-        q_2m(i) = q_zref_p(i) * ok_pred(i) + q_zref_c(i) * ok_corr(i)
-!IM +++
-!       IF(n.EQ.niter) THEN
-!       IF(t_2m(i).LT.t1(i).AND.t_2m(i).LT.ts1(i)) THEN
-!         PRINT*,' BAD t2m LT ',i,nsrf,t_2m(i),t1(i),ts1(i) 
-!       ELSEIF(t_2m(i).GT.t1(i).AND.t_2m(i).GT.ts1(i)) THEN
-!         PRINT*,' BAD t2m GT ',i,nsrf,t_2m(i),t1(i),ts1(i) 
-!       ENDIF
-!       ENDIF
-!IM ---
-      ENDDO
-!
-!
-!----------First aproximation of variables at zref --------------------------
-!
-      zref = 10.0
-      CALL screenp(klon, knon, nsrf, speed, tpot, q1, &
- &                 ts1, qsurf, z0m, lmon, &
- &                 ustar, testar, qstar, zref, &
- &                 delu, delte, delq)
-!
-      DO i = 1, knon
-        u_zref(i) = delu(i)
-        q_zref(i) = max(qsurf(i),0.0) + delq(i)
-        te_zref(i) = ts1(i) + delte(i)
-        temp(i) = te_zref(i) * (psol(i)/pat1(i))**(-RKAPPA)
-!       temp(i) = te_zref(i) - (zref* RG)/RCPD/ &
-!                 (1 + RVTMP2 * max(q_zref(i),0.0))
-        u_zref_p(i) = u_zref(i)
-      ENDDO
-!
-! Iteration of the variables at the reference level zref : corrector ; see Hess & McAvaney, 1995 
-!
-      DO n = 1, niter
-!
-        okri=.TRUE.
-        CALL screenc(klon, knon, nsrf, zxli, &
- &                   u_zref, temp, q_zref, zref, &
- &                   ts1, qsurf, z0m, z0h, psol, &
- &                   ustar, testar, qstar, okri, ri1, &
- &                   pref, delu, delte, delq, s_pblh ,prain, tsol, pat1)
-!
-        DO i = 1, knon
-          u_zref(i) = delu(i)
-          q_zref(i) = delq(i) + max(qsurf(i),0.0)
-          te_zref(i) = delte(i) + ts1(i)
-          temp(i) = te_zref(i) * (psol(i)/pref(i))**(-RKAPPA)
-!         temp(i) = te_zref(i) - (zref* RG)/RCPD/ &
-!                   (1 + RVTMP2 * max(q_zref(i),0.0))
-        ENDDO 
-!
-      ENDDO
-!
-      DO i = 1, knon
-        u_zref_c(i) = u_zref(i)
-!
-        u_10m(i) = u_zref_p(i) * ok_pred(i) + u_zref_c(i) * ok_corr(i)
-!
-!AM
-        q_zref_c(i) = q_zref(i)
-        temp_c(i) = temp(i)
-        t_10m(i) = temp_p(i) * ok_pred(i) + temp_c(i) * ok_corr(i)
-        q_10m(i) = q_zref_p(i) * ok_pred(i) + q_zref_c(i) * ok_corr(i)
-!MA
-      ENDDO
-! 
-      RETURN
-      END subroutine stdlevvar
-!
-      SUBROUTINE stdlevvarn(klon, knon, nsrf, zxli, &
-                           u1, v1, t1, q1, z1, &
-                           ts1, qsurf, z0m, z0h, psol, pat1, &
-                           t_2m, q_2m, t_10m, q_10m, u_10m, ustar, &
-                           n2mout)
-!
-      USE ioipsl_getin_p_mod, ONLY : getin_p
-      IMPLICIT NONE
-!-------------------------------------------------------------------------
-!
-! Objet : calcul de la temperature et l'humidite relative a 2m et du 
-!         module du vent a 10m a partir des relations de Dyer-Businger et
-!         des equations de Louis.
-!
-! Reference : Hess, Colman et McAvaney (1995)        
-!
-! I. Musat, 01.07.2002
-!
-!AM On rajoute en sortie t et q a 10m pr le calcule d'hbtm2 dans clmain
-!
-!-------------------------------------------------------------------------
-!
-! klon----input-I- dimension de la grille physique (= nb_pts_latitude X nb_pts_longitude)
-! knon----input-I- nombre de points pour un type de surface
-! nsrf----input-I- indice pour le type de surface; voir indice_sol_mod.F90
-! zxli----input-L- TRUE si calcul des cdrags selon Laurent Li
-! u1------input-R- vent zonal au 1er niveau du modele
-! v1------input-R- vent meridien au 1er niveau du modele
-! t1------input-R- temperature de l'air au 1er niveau du modele
-! q1------input-R- humidite relative au 1er niveau du modele
-! z1------input-R- geopotentiel au 1er niveau du modele
-! ts1-----input-R- temperature de l'air a la surface
-! qsurf---input-R- humidite relative a la surface
-! z0m, z0h---input-R- rugosite
-! psol----input-R- pression au sol
-! pat1----input-R- pression au 1er niveau du modele
-!
-! t_2m---output-R- temperature de l'air a 2m
-! q_2m---output-R- humidite relative a 2m
-! u_2m--output-R- vitesse du vent a 2m
-! u_10m--output-R- vitesse du vent a 10m
-! ustar--output-R- u*
-!AM
-! t_10m--output-R- temperature de l'air a 10m
-! q_10m--output-R- humidite specifique a 10m
-!
-      INTEGER, intent(in) :: klon, knon, nsrf
-      LOGICAL, intent(in) :: zxli
-      REAL, dimension(klon), intent(in) :: u1, v1, t1, q1, ts1, z1
-      REAL, dimension(klon), intent(inout) :: z0m, z0h
-      REAL, dimension(klon), intent(in) :: qsurf
-      REAL, dimension(klon), intent(in) :: psol, pat1
-!
-      REAL, dimension(klon), intent(out) :: t_2m, q_2m, ustar
-      REAL, dimension(klon), intent(out) :: u_10m, t_10m, q_10m
-      INTEGER, dimension(klon, 6), intent(out) :: n2mout
-!
-      REAL, dimension(klon) :: u_2m
-      REAL, dimension(klon) :: cdrm2m, cdrh2m, ri2m
-      REAL, dimension(klon) :: cdram, cdrah, zri1
-      REAL, dimension(klon) :: cdmn1, cdhn1, fm1, fh1
-      REAL, dimension(klon) :: cdmn2m, cdhn2m, fm2m, fh2m
-      REAL, dimension(klon) :: ri2m_new
-      REAL, DIMENSION(klon) :: s_pblh
-      REAL, DIMENSION(klon) :: prain
-      REAL, DIMENSION(klon) :: tsol
-!-------------------------------------------------------------------------
-      include "flux_arp.h"
-      include "YOMCST.h"
-!IM PLUS
-      include "YOETHF.h"
-!
-! Quelques constantes et options:
-!
-! RKAR : constante de von Karman
-      REAL, PARAMETER :: RKAR=0.40
-! niter : nombre iterations calcul "corrector"
-!     INTEGER, parameter :: niter=6, ncon=niter-1
-!IM 071020     INTEGER, parameter :: niter=2, ncon=niter-1
-      INTEGER, parameter :: niter=2, ncon=niter
-!     INTEGER, parameter :: niter=6, ncon=niter
-!
-! Variables locales
-      INTEGER :: i, n
-      REAL :: zref
-      REAL, dimension(klon) :: speed
-! tpot : temperature potentielle
-      REAL, dimension(klon) :: tpot
-      REAL, dimension(klon) :: cdran
-! ri1 : nb. de Richardson entre la surface --> la 1ere couche
-      REAL, dimension(klon) :: ri1 
-      DOUBLE PRECISION, parameter :: eps=1.0D-20
-      REAL, dimension(klon) :: delu, delte, delq
-      REAL, dimension(klon) :: delh, delm
-      REAL, dimension(klon) :: delh_new, delm_new
-      REAL, dimension(klon) :: u_zref, te_zref, q_zref  
-      REAL, dimension(klon) :: u_zref_pnew, te_zref_pnew, q_zref_pnew
-      REAL, dimension(klon) :: temp, pref
-      REAL, dimension(klon) :: temp_new, pref_new
-      LOGICAL :: okri
-      REAL, dimension(klon) :: u_zref_p, te_zref_p, temp_p, q_zref_p
-      REAL, dimension(klon) :: u_zref_p_new, te_zref_p_new, temp_p_new, q_zref_p_new
-!convergence
-      REAL, dimension(klon) :: te_zref_con, q_zref_con
-      REAL, dimension(klon) :: u_zref_c, te_zref_c, temp_c, q_zref_c
-      REAL, dimension(klon) :: ok_pred, ok_corr
-!
-      REAL, dimension(klon) :: cdrm10m, cdrh10m, ri10m
-      REAL, dimension(klon) :: cdmn10m, cdhn10m, fm10m, fh10m
-      REAL, dimension(klon) :: cdn2m, cdn1, zri_zero
-      REAL :: CEPDUE,zdu2 
-      INTEGER :: nzref, nz1
-      LOGICAL, dimension(klon) :: ok_t2m_toosmall, ok_t2m_toobig
-      LOGICAL, dimension(klon) :: ok_q2m_toosmall, ok_q2m_toobig
-      LOGICAL, dimension(klon) :: ok_u2m_toobig
-      LOGICAL, dimension(klon) :: ok_t10m_toosmall, ok_t10m_toobig
-      LOGICAL, dimension(klon) :: ok_q10m_toosmall, ok_q10m_toobig
-      LOGICAL, dimension(klon) :: ok_u10m_toobig
-      INTEGER, dimension(klon, 6) :: n10mout
-
-!------------------------------------------------------------------------- 
-      CEPDUE=0.1
-!
-! n2mout : compteur des pas de temps ou t2m,q2m ou u2m sont en dehors des intervalles
-!          [tsurf, temp], [qsurf, q1] ou [0, speed]
-! n10mout : compteur des pas de temps ou t10m,q10m ou u10m sont en dehors des intervalles
-!          [tsurf, temp], [qsurf, q1] ou [0, speed]
-!
-      n2mout(:,:)=0
-      n10mout(:,:)=0
-      
-      DO i=1, knon
-       speed(i)=MAX(SQRT(u1(i)**2+v1(i)**2),CEPDUE)
-       ri1(i) = 0.0
-      ENDDO
-!
-      okri=.FALSE.
-      CALL cdrag(knon, nsrf, &
- &                   speed, t1, q1, z1, &
- &                   psol, s_pblh, ts1, qsurf, z0m, z0h, &
- &                   zri_zero, 0, &
- &                   cdram, cdrah, zri1, pref, prain, tsol, pat1)
-
-!
-      DO i = 1, knon
-        ri1(i) = zri1(i)
-        tpot(i) = t1(i)* (psol(i)/pat1(i))**RKAPPA
-        zdu2 = MAX(CEPDUE*CEPDUE, speed(i)**2)
-        ustar(i) = sqrt(cdram(i) * zdu2)
-!
-      ENDDO
-!
-!----------First aproximation of variables at zref --------------------------
-      zref = 2.0
-!
-! calcul first-guess en utilisant dans les calculs à 2m
-! le Richardson de la premiere couche atmospherique 
-!
-       CALL screencn(klon, knon, nsrf, zxli, &
- &                   speed, tpot, q1, zref, &
- &                   ts1, qsurf, z0m, z0h, psol, &           
- &                   cdram, cdrah,  okri, &
- &                   ri1, 1, &
- &                   pref_new, delm_new, delh_new, ri2m, &
- &                   s_pblh, prain, tsol, pat1      )
-!
-       DO i = 1, knon
-         u_zref(i) = delm_new(i)*speed(i)
-         u_zref_p(i) = u_zref(i)
-         q_zref(i) = delh_new(i)*max(q1(i),0.0) + &
-         &           max(qsurf(i),0.0)*(1-delh_new(i))
-         q_zref_p(i) = q_zref(i)
-         te_zref(i) = delh_new(i)*tpot(i) + ts1(i)*(1-delh_new(i))
-         te_zref_p(i) = te_zref(i)
-!
-! return to normal temperature
-         temp(i) = te_zref(i) * (psol(i)/pref_new(i))**(-RKAPPA)
-         temp_p(i) = temp(i)
-!
-! compteurs ici
-!
-         ok_t2m_toosmall(i)=te_zref(i).LT.tpot(i).AND. &
-         & te_zref(i).LT.ts1(i)
-         ok_t2m_toobig(i)=te_zref(i).GT.tpot(i).AND. &
-         & te_zref(i).GT.ts1(i)
-         ok_q2m_toosmall(i)=q_zref(i).LT.q1(i).AND. &
-         & q_zref(i).LT.qsurf(i)
-         ok_q2m_toobig(i)=q_zref(i).GT.q1(i).AND. &
-         & q_zref(i).GT.qsurf(i)
-         ok_u2m_toobig(i)=u_zref(i).GT.speed(i)
-!
-         IF(ok_t2m_toosmall(i).OR.ok_t2m_toobig(i)) THEN
-             n2mout(i,1)=n2mout(i,1)+1
-         ENDIF
-         IF(ok_q2m_toosmall(i).OR.ok_q2m_toobig(i)) THEN
-             n2mout(i,3)=n2mout(i,3)+1
-         ENDIF
-         IF(ok_u2m_toobig(i)) THEN
-             n2mout(i,5)=n2mout(i,5)+1
-         ENDIF
-!
-         IF(ok_t2m_toosmall(i).OR.ok_t2m_toobig(i).OR. &
-          & ok_q2m_toosmall(i).OR.ok_q2m_toobig(i).OR. &
-          & ok_u2m_toobig(i)) THEN 
-             delm_new(i)=min(max(delm_new(i),0.),1.)
-             delh_new(i)=min(max(delh_new(i),0.),1.)
-             u_zref(i) = delm_new(i)*speed(i)
-             u_zref_p(i) = u_zref(i)
-             q_zref(i) = delh_new(i)*max(q1(i),0.0) + &
-         &               max(qsurf(i),0.0)*(1-delh_new(i))
-             q_zref_p(i) = q_zref(i)
-             te_zref(i) = delh_new(i)*tpot(i) + ts1(i)*(1-delh_new(i))
-             te_zref_p(i) = te_zref(i)
-!
-! return to normal temperature
-             temp(i) = te_zref(i) * (psol(i)/pref_new(i))**(-RKAPPA)
-             temp_p(i) = temp(i)
-         ENDIF 
-!
-       ENDDO
-!
-! Iteration of the variables at the reference level zref : corrector calculation ; see Hess & McAvaney, 1995 
-!
-      DO n = 1, niter
-!
-        okri=.TRUE.
-        CALL screencn(klon, knon, nsrf, zxli, &
- &                   u_zref, temp, q_zref, zref, &
- &                   ts1, qsurf, z0m, z0h, psol, &
- &                   cdram, cdrah,  okri, &
- &                   ri1, 0, &
- &                   pref, delm, delh, ri2m, &
- &                   s_pblh, prain, tsol, pat1      )
-!
-        DO i = 1, knon
-          u_zref(i) = delm(i)*speed(i)
-          q_zref(i) = delh(i)*max(q1(i),0.0) + &
-          &           max(qsurf(i),0.0)*(1-delh(i))
-          te_zref(i) = delh(i)*tpot(i) + ts1(i)*(1-delh(i))
-!
-! return to normal temperature
-          temp(i) = te_zref(i) * (psol(i)/pref(i))**(-RKAPPA)
-!
-! compteurs ici
-!
-          ok_t2m_toosmall(i)=te_zref(i).LT.tpot(i).AND. &
-          & te_zref(i).LT.ts1(i)
-          ok_t2m_toobig(i)=te_zref(i).GT.tpot(i).AND. &
-          & te_zref(i).GT.ts1(i)
-          ok_q2m_toosmall(i)=q_zref(i).LT.q1(i).AND. &
-          & q_zref(i).LT.qsurf(i)
-          ok_q2m_toobig(i)=q_zref(i).GT.q1(i).AND. &
-          & q_zref(i).GT.qsurf(i)
-          ok_u2m_toobig(i)=u_zref(i).GT.speed(i)
-!
-          IF(ok_t2m_toosmall(i).OR.ok_t2m_toobig(i)) THEN
-              n2mout(i,2)=n2mout(i,2)+1
-          ENDIF
-          IF(ok_q2m_toosmall(i).OR.ok_q2m_toobig(i)) THEN
-              n2mout(i,4)=n2mout(i,4)+1
-          ENDIF
-          IF(ok_u2m_toobig(i)) THEN
-              n2mout(i,6)=n2mout(i,6)+1
-          ENDIF
-!
-          IF(ok_t2m_toosmall(i).OR.ok_t2m_toobig(i).OR. &
-           & ok_q2m_toosmall(i).OR.ok_q2m_toobig(i).OR. &
-           & ok_u2m_toobig(i)) THEN 
-              delm(i)=min(max(delm(i),0.),1.)
-              delh(i)=min(max(delh(i),0.),1.)
-              u_zref(i) = delm(i)*speed(i)
-              q_zref(i) = delh(i)*max(q1(i),0.0) + &
-          &           max(qsurf(i),0.0)*(1-delh(i))
-              te_zref(i) = delh(i)*tpot(i) + ts1(i)*(1-delh(i))
-              temp(i) = te_zref(i) * (psol(i)/pref(i))**(-RKAPPA)
-          ENDIF
-!
-!
-          IF(n.EQ.ncon) THEN
-            te_zref_con(i) = te_zref(i)
-            q_zref_con(i) = q_zref(i)
-          ENDIF 
-!
-        ENDDO 
-!
-      ENDDO 
-!
-      DO i = 1, knon
-        q_zref_c(i) = q_zref(i)
-        temp_c(i) = temp(i)
-!
-        ok_pred(i)=0.
-        ok_corr(i)=1.
-!
-        t_2m(i) = temp_p(i) * ok_pred(i) + temp_c(i) * ok_corr(i)
-        q_2m(i) = q_zref_p(i) * ok_pred(i) + q_zref_c(i) * ok_corr(i)
-!
-        u_zref_c(i) = u_zref(i)
-        u_2m(i) = u_zref_p(i) * ok_pred(i) + u_zref_c(i) * ok_corr(i)
-      ENDDO
-!
-!
-!----------First aproximation of variables at zref --------------------------
-!
-      zref = 10.0
-!
-       CALL screencn(klon, knon, nsrf, zxli, &
- &                   speed, tpot, q1, zref, &
- &                   ts1, qsurf, z0m, z0h, psol, &           
- &                   cdram, cdrah,  okri, &
- &                   ri1, 1, &
- &                   pref_new, delm_new, delh_new, ri10m, &
- &                   s_pblh, prain, tsol, pat1      )
-!
-       DO i = 1, knon
-         u_zref(i) = delm_new(i)*speed(i)
-         q_zref(i) = delh_new(i)*max(q1(i),0.0) + &
-         &           max(qsurf(i),0.0)*(1-delh_new(i))
-         te_zref(i) = delh_new(i)*tpot(i) + ts1(i)*(1-delh_new(i))
-         temp(i) = te_zref(i) * (psol(i)/pref_new(i))**(-RKAPPA)
-         u_zref_p(i) = u_zref(i)
-!
-! compteurs ici
-!
-         ok_t10m_toosmall(i)=te_zref(i).LT.tpot(i).AND. &
-         & te_zref(i).LT.ts1(i)
-         ok_t10m_toobig(i)=te_zref(i).GT.tpot(i).AND. &
-         & te_zref(i).GT.ts1(i)
-         ok_q10m_toosmall(i)=q_zref(i).LT.q1(i).AND. &
-         & q_zref(i).LT.qsurf(i)
-         ok_q10m_toobig(i)=q_zref(i).GT.q1(i).AND. &
-         & q_zref(i).GT.qsurf(i)
-         ok_u10m_toobig(i)=u_zref(i).GT.speed(i)
-!
-         IF(ok_t10m_toosmall(i).OR.ok_t10m_toobig(i)) THEN
-             n10mout(i,1)=n10mout(i,1)+1
-         ENDIF
-         IF(ok_q10m_toosmall(i).OR.ok_q10m_toobig(i)) THEN
-             n10mout(i,3)=n10mout(i,3)+1
-         ENDIF
-         IF(ok_u10m_toobig(i)) THEN
-             n10mout(i,5)=n10mout(i,5)+1
-         ENDIF
-!
-         IF(ok_t10m_toosmall(i).OR.ok_t10m_toobig(i).OR. &
-          & ok_q10m_toosmall(i).OR.ok_q10m_toobig(i).OR. &
-          & ok_u10m_toobig(i)) THEN 
-             delm_new(i)=min(max(delm_new(i),0.),1.)
-             delh_new(i)=min(max(delh_new(i),0.),1.)
-             u_zref(i) = delm_new(i)*speed(i)
-             u_zref_p(i) = u_zref(i)
-             q_zref(i) = delh_new(i)*max(q1(i),0.0) + &
-         &               max(qsurf(i),0.0)*(1-delh_new(i))
-             te_zref(i) = delh_new(i)*tpot(i) + ts1(i)*(1-delh_new(i))
-             temp(i) = te_zref(i) * (psol(i)/pref_new(i))**(-RKAPPA)
-         ENDIF 
-!
-       ENDDO
-!
-! Iteration of the variables at the reference level zref : corrector calculation ; see Hess & McAvaney, 1995 
-!
-      DO n = 1, niter
-!
-        okri=.TRUE.
-        CALL screencn(klon, knon, nsrf, zxli, &
- &                   u_zref, temp, q_zref, zref, &
- &                   ts1, qsurf, z0m, z0h, psol, &
- &                   cdram, cdrah,  okri, &
- &                   ri1, 0, &
- &                   pref, delm, delh, ri10m, &
- &                   s_pblh, prain, tsol, pat1      )
-!
-        DO i = 1, knon
-          u_zref(i) = delm(i)*speed(i)
-          q_zref(i) = delh(i)*max(q1(i),0.0) + &
-          &           max(qsurf(i),0.0)*(1-delh(i))
-          te_zref(i) = delh(i)*tpot(i) + ts1(i)*(1-delh(i))
-!
-! return to normal temperature
-          temp(i) = te_zref(i) * (psol(i)/pref(i))**(-RKAPPA)
-!
-! compteurs ici
-!
-          ok_t10m_toosmall(i)=te_zref(i).LT.tpot(i).AND. &
-          & te_zref(i).LT.ts1(i)
-          ok_t10m_toobig(i)=te_zref(i).GT.tpot(i).AND. &
-          & te_zref(i).GT.ts1(i)
-          ok_q10m_toosmall(i)=q_zref(i).LT.q1(i).AND. &
-          & q_zref(i).LT.qsurf(i)
-          ok_q10m_toobig(i)=q_zref(i).GT.q1(i).AND. &
-          & q_zref(i).GT.qsurf(i)
-          ok_u10m_toobig(i)=u_zref(i).GT.speed(i)
-!
-          IF(ok_t10m_toosmall(i).OR.ok_t10m_toobig(i)) THEN
-              n10mout(i,2)=n10mout(i,2)+1
-          ENDIF
-          IF(ok_q10m_toosmall(i).OR.ok_q10m_toobig(i)) THEN
-              n10mout(i,4)=n10mout(i,4)+1
-          ENDIF
-          IF(ok_u10m_toobig(i)) THEN
-              n10mout(i,6)=n10mout(i,6)+1
-          ENDIF
-!
-          IF(ok_t10m_toosmall(i).OR.ok_t10m_toobig(i).OR. &
-           & ok_q10m_toosmall(i).OR.ok_q10m_toobig(i).OR. &
-           & ok_u10m_toobig(i)) THEN 
-              delm(i)=min(max(delm(i),0.),1.)
-              delh(i)=min(max(delh(i),0.),1.)
-              u_zref(i) = delm(i)*speed(i)
-              q_zref(i) = delh(i)*max(q1(i),0.0) + &
-          &           max(qsurf(i),0.0)*(1-delh(i))
-              te_zref(i) = delh(i)*tpot(i) + ts1(i)*(1-delh(i))
-              temp(i) = te_zref(i) * (psol(i)/pref(i))**(-RKAPPA)
-          ENDIF
-!
-!
-          IF(n.EQ.ncon) THEN
-            te_zref_con(i) = te_zref(i)
-            q_zref_con(i) = q_zref(i)
-          ENDIF 
-!
-        ENDDO 
-!
-      ENDDO 
-!
-      DO i = 1, knon
-        q_zref_c(i) = q_zref(i)
-        temp_c(i) = temp(i)
-!
-        ok_pred(i)=0.
-        ok_corr(i)=1.
-!
-        t_10m(i) = temp_p(i) * ok_pred(i) + temp_c(i) * ok_corr(i)
-        q_10m(i) = q_zref_p(i) * ok_pred(i) + q_zref_c(i) * ok_corr(i)
-!
-        u_zref_c(i) = u_zref(i)
-        u_10m(i) = u_zref_p(i) * ok_pred(i) + u_zref_c(i) * ok_corr(i)
-      ENDDO
-!
-      RETURN
-      END subroutine stdlevvarn
-
-END MODULE stdlevvar_mod
Index: /LMDZ6/trunk/libf/phylmd/stdlevvar_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/stdlevvar_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/stdlevvar_mod.f90	(revision 5268)
@@ -0,0 +1,757 @@
+!
+MODULE stdlevvar_mod
+!
+! This module contains main procedures for calculation
+! of temperature, specific humidity and wind at a reference level
+!
+  USE cdrag_mod
+  USE screenp_mod
+  USE screenc_mod
+  IMPLICIT NONE
+
+CONTAINS
+!
+!****************************************************************************************
+!
+!r original routine svn3623
+!
+      SUBROUTINE stdlevvar(klon, knon, nsrf, zxli, &
+                           u1, v1, t1, q1, z1, &
+                           ts1, qsurf, z0m, z0h, psol, pat1, &
+                           t_2m, q_2m, t_10m, q_10m, u_10m, ustar, s_pblh, prain, tsol)
+      IMPLICIT NONE
+!-------------------------------------------------------------------------
+!
+! Objet : calcul de la temperature et l'humidite relative a 2m et du 
+!         module du vent a 10m a partir des relations de Dyer-Businger et
+!         des equations de Louis.
+!
+! Reference : Hess, Colman et McAvaney (1995)        
+!
+! I. Musat, 01.07.2002
+!
+!AM On rajoute en sortie t et q a 10m pr le calcule d'hbtm2 dans clmain
+!
+!-------------------------------------------------------------------------
+!
+! klon----input-I- dimension de la grille physique (= nb_pts_latitude X nb_pts_longitude)
+! knon----input-I- nombre de points pour un type de surface
+! nsrf----input-I- indice pour le type de surface; voir indice_sol_mod.F90
+! zxli----input-L- TRUE si calcul des cdrags selon Laurent Li
+! u1------input-R- vent zonal au 1er niveau du modele
+! v1------input-R- vent meridien au 1er niveau du modele
+! t1------input-R- temperature de l'air au 1er niveau du modele
+! q1------input-R- humidite relative au 1er niveau du modele
+! z1------input-R- geopotentiel au 1er niveau du modele
+! ts1-----input-R- temperature de l'air a la surface
+! qsurf---input-R- humidite relative a la surface
+! z0m, z0h---input-R- rugosite
+! psol----input-R- pression au sol
+! pat1----input-R- pression au 1er niveau du modele
+!
+! t_2m---output-R- temperature de l'air a 2m
+! q_2m---output-R- humidite relative a 2m
+! u_10m--output-R- vitesse du vent a 10m
+!AM
+! t_10m--output-R- temperature de l'air a 10m
+! q_10m--output-R- humidite specifique a 10m
+! ustar--output-R- u*
+!
+      INTEGER, intent(in) :: klon, knon, nsrf
+      LOGICAL, intent(in) :: zxli
+      REAL, dimension(klon), intent(in) :: u1, v1, t1, q1, z1, ts1
+      REAL, dimension(klon), intent(in) :: qsurf
+      REAL, dimension(klon), intent(inout) :: z0m, z0h
+      REAL, dimension(klon), intent(in) :: psol, pat1
+!
+      REAL, dimension(klon), intent(out) :: t_2m, q_2m, ustar
+      REAL, dimension(klon), intent(out) :: u_10m, t_10m, q_10m
+      REAL, DIMENSION(klon), INTENT(INOUT) :: s_pblh
+      REAL, DIMENSION(klon), INTENT(IN) :: prain
+      REAL, DIMENSION(klon), INTENT(IN) :: tsol
+!-------------------------------------------------------------------------
+      include "flux_arp.h"
+      include "YOMCST.h"
+!IM PLUS
+      include "YOETHF.h"
+!
+! Quelques constantes et options:
+!
+! RKAR : constante de von Karman
+      REAL, PARAMETER :: RKAR=0.40
+! niter : nombre iterations calcul "corrector"
+!     INTEGER, parameter :: niter=6, ncon=niter-1
+      INTEGER, parameter :: niter=2, ncon=niter-1
+!
+! Variables locales
+      INTEGER :: i, n
+      REAL :: zref
+      REAL, dimension(klon) :: speed
+! tpot : temperature potentielle
+      REAL, dimension(klon) :: tpot
+      REAL, dimension(klon) :: zri1, cdran
+      REAL, dimension(klon) :: cdram, cdrah
+! ri1 : nb. de Richardson entre la surface --> la 1ere couche
+      REAL, dimension(klon) :: ri1 
+      REAL, dimension(klon) :: testar, qstar
+      REAL, dimension(klon) :: zdte, zdq   
+! lmon : longueur de Monin-Obukhov selon Hess, Colman and McAvaney 
+      DOUBLE PRECISION, dimension(klon) :: lmon
+      DOUBLE PRECISION, parameter :: eps=1.0D-20
+      REAL, dimension(klon) :: delu, delte, delq
+      REAL, dimension(klon) :: u_zref, te_zref, q_zref  
+      REAL, dimension(klon) :: temp, pref
+      LOGICAL :: okri
+      REAL, dimension(klon) :: u_zref_p, te_zref_p, temp_p, q_zref_p
+!convertgence
+      REAL, dimension(klon) :: te_zref_con, q_zref_con
+      REAL, dimension(klon) :: u_zref_c, te_zref_c, temp_c, q_zref_c
+      REAL, dimension(klon) :: ok_pred, ok_corr, zri_zero
+!     REAL, dimension(klon) :: conv_te, conv_q
+!------------------------------------------------------------------------- 
+      DO i=1, knon
+       speed(i)=SQRT(u1(i)**2+v1(i)**2)
+       ri1(i) = 0.0
+      ENDDO
+!
+      okri=.FALSE.
+!      CALL coefcdrag(klon, knon, nsrf, zxli, &
+! &                   speed, t1, q1, z1, psol, &
+! &                   ts1, qsurf, rugos, okri, ri1,  &         
+! &                   cdram, cdrah, cdran, zri1, pref)            
+! Fuxing WANG, 04/03/2015, replace the coefcdrag by the merged version: cdrag
+
+      CALL cdrag(knon, nsrf, &
+ &                   speed, t1, q1, z1, &
+ &                   psol, s_pblh, ts1, qsurf, z0m, z0h, &
+ &                   zri_zero, 0, &
+ &                   cdram, cdrah, zri1, pref, prain, tsol, pat1)
+
+! --- special Dice: on force cdragm ( a defaut de forcer ustar) MPL 05082013
+     IF (ok_prescr_ust) then
+      DO i = 1, knon
+       print *,'cdram avant=',cdram(i)
+       cdram(i) = ust*ust/speed(i)/speed(i)
+       print *,'cdram ust speed apres=',cdram(i),ust,speed
+      ENDDO
+     ENDIF
+!
+!---------Star variables----------------------------------------------------
+!
+      DO i = 1, knon
+        ri1(i) = zri1(i)
+        tpot(i) = t1(i)* (psol(i)/pat1(i))**RKAPPA
+        ustar(i) = sqrt(cdram(i) * speed(i) * speed(i))
+        zdte(i) = tpot(i) - ts1(i)
+        zdq(i) = max(q1(i),0.0) - max(qsurf(i),0.0)
+!
+!
+!IM BUG BUG BUG       zdte(i) = max(zdte(i),1.e-10)
+        zdte(i) = sign(max(abs(zdte(i)),1.e-10),zdte(i))
+!
+        testar(i) = (cdrah(i) * zdte(i) * speed(i))/ustar(i)
+        qstar(i) = (cdrah(i) * zdq(i) * speed(i))/ustar(i)
+        lmon(i) = (ustar(i) * ustar(i) * tpot(i))/ &
+ &                (RKAR * RG * testar(i))
+      ENDDO
+!
+!----------First aproximation of variables at zref --------------------------
+      zref = 2.0
+      CALL screenp(klon, knon, nsrf, speed, tpot, q1, &
+ &                 ts1, qsurf, z0m, lmon, &
+ &                 ustar, testar, qstar, zref, &
+ &                 delu, delte, delq)
+!
+      DO i = 1, knon
+        u_zref(i) = delu(i)
+        q_zref(i) = max(qsurf(i),0.0) + delq(i)
+        te_zref(i) = ts1(i) + delte(i)
+        temp(i) = te_zref(i) * (psol(i)/pat1(i))**(-RKAPPA)
+        q_zref_p(i) = q_zref(i)
+!       te_zref_p(i) = te_zref(i)
+        temp_p(i) = temp(i)
+      ENDDO
+!
+! Iteration of the variables at the reference level zref : corrector calculation ; see Hess & McAvaney, 1995 
+!
+      DO n = 1, niter
+!
+        okri=.TRUE.
+        CALL screenc(klon, knon, nsrf, zxli, &
+ &                   u_zref, temp, q_zref, zref, &
+ &                   ts1, qsurf, z0m, z0h, psol, &           
+ &                   ustar, testar, qstar, okri, ri1, &
+ &                   pref, delu, delte, delq, s_pblh ,prain, tsol, pat1) 
+!
+        DO i = 1, knon
+          u_zref(i) = delu(i)
+          q_zref(i) = delq(i) + max(qsurf(i),0.0)
+          te_zref(i) = delte(i) + ts1(i) 
+!
+! return to normal temperature
+!
+          temp(i) = te_zref(i) * (psol(i)/pref(i))**(-RKAPPA)
+!         temp(i) = te_zref(i) - (zref* RG)/RCPD/ &
+!                 (1 + RVTMP2 * max(q_zref(i),0.0))
+!
+!IM +++
+!         IF(temp(i).GT.350.) THEN
+!           WRITE(*,*) 'temp(i) GT 350 K !!',i,nsrf,temp(i)
+!         ENDIF
+!IM ---
+!
+        IF(n.EQ.ncon) THEN
+          te_zref_con(i) = te_zref(i)
+          q_zref_con(i) = q_zref(i)
+        ENDIF 
+!
+        ENDDO 
+!
+      ENDDO 
+!
+! verifier le critere de convergence : 0.25% pour te_zref et 5% pour qe_zref
+!
+!       DO i = 1, knon
+!         conv_te(i) = (te_zref(i) - te_zref_con(i))/te_zref_con(i)
+!         conv_q(i) = (q_zref(i) - q_zref_con(i))/q_zref_con(i)
+!IM +++
+!         IF(abs(conv_te(i)).GE.0.0025.AND.abs(conv_q(i)).GE.0.05) THEN
+!           PRINT*,'DIV','i=',i,te_zref_con(i),te_zref(i),conv_te(i), &
+!           q_zref_con(i),q_zref(i),conv_q(i)
+!         ENDIF
+!IM ---
+!       ENDDO
+!
+      DO i = 1, knon
+        q_zref_c(i) = q_zref(i)
+        temp_c(i) = temp(i)
+!
+!       IF(zri1(i).LT.0.) THEN
+!         IF(nsrf.EQ.1) THEN
+!           ok_pred(i)=1.
+!           ok_corr(i)=0.
+!         ELSE
+!           ok_pred(i)=0.
+!           ok_corr(i)=1.
+!         ENDIF
+!       ELSE
+!         ok_pred(i)=0.
+!         ok_corr(i)=1.
+!       ENDIF
+!
+        ok_pred(i)=0.
+        ok_corr(i)=1.
+!
+        t_2m(i) = temp_p(i) * ok_pred(i) + temp_c(i) * ok_corr(i)
+        q_2m(i) = q_zref_p(i) * ok_pred(i) + q_zref_c(i) * ok_corr(i)
+!IM +++
+!       IF(n.EQ.niter) THEN
+!       IF(t_2m(i).LT.t1(i).AND.t_2m(i).LT.ts1(i)) THEN
+!         PRINT*,' BAD t2m LT ',i,nsrf,t_2m(i),t1(i),ts1(i) 
+!       ELSEIF(t_2m(i).GT.t1(i).AND.t_2m(i).GT.ts1(i)) THEN
+!         PRINT*,' BAD t2m GT ',i,nsrf,t_2m(i),t1(i),ts1(i) 
+!       ENDIF
+!       ENDIF
+!IM ---
+      ENDDO
+!
+!
+!----------First aproximation of variables at zref --------------------------
+!
+      zref = 10.0
+      CALL screenp(klon, knon, nsrf, speed, tpot, q1, &
+ &                 ts1, qsurf, z0m, lmon, &
+ &                 ustar, testar, qstar, zref, &
+ &                 delu, delte, delq)
+!
+      DO i = 1, knon
+        u_zref(i) = delu(i)
+        q_zref(i) = max(qsurf(i),0.0) + delq(i)
+        te_zref(i) = ts1(i) + delte(i)
+        temp(i) = te_zref(i) * (psol(i)/pat1(i))**(-RKAPPA)
+!       temp(i) = te_zref(i) - (zref* RG)/RCPD/ &
+!                 (1 + RVTMP2 * max(q_zref(i),0.0))
+        u_zref_p(i) = u_zref(i)
+      ENDDO
+!
+! Iteration of the variables at the reference level zref : corrector ; see Hess & McAvaney, 1995 
+!
+      DO n = 1, niter
+!
+        okri=.TRUE.
+        CALL screenc(klon, knon, nsrf, zxli, &
+ &                   u_zref, temp, q_zref, zref, &
+ &                   ts1, qsurf, z0m, z0h, psol, &
+ &                   ustar, testar, qstar, okri, ri1, &
+ &                   pref, delu, delte, delq, s_pblh ,prain, tsol, pat1)
+!
+        DO i = 1, knon
+          u_zref(i) = delu(i)
+          q_zref(i) = delq(i) + max(qsurf(i),0.0)
+          te_zref(i) = delte(i) + ts1(i)
+          temp(i) = te_zref(i) * (psol(i)/pref(i))**(-RKAPPA)
+!         temp(i) = te_zref(i) - (zref* RG)/RCPD/ &
+!                   (1 + RVTMP2 * max(q_zref(i),0.0))
+        ENDDO 
+!
+      ENDDO
+!
+      DO i = 1, knon
+        u_zref_c(i) = u_zref(i)
+!
+        u_10m(i) = u_zref_p(i) * ok_pred(i) + u_zref_c(i) * ok_corr(i)
+!
+!AM
+        q_zref_c(i) = q_zref(i)
+        temp_c(i) = temp(i)
+        t_10m(i) = temp_p(i) * ok_pred(i) + temp_c(i) * ok_corr(i)
+        q_10m(i) = q_zref_p(i) * ok_pred(i) + q_zref_c(i) * ok_corr(i)
+!MA
+      ENDDO
+! 
+      RETURN
+      END subroutine stdlevvar
+!
+      SUBROUTINE stdlevvarn(klon, knon, nsrf, zxli, &
+                           u1, v1, t1, q1, z1, &
+                           ts1, qsurf, z0m, z0h, psol, pat1, &
+                           t_2m, q_2m, t_10m, q_10m, u_10m, ustar, &
+                           n2mout)
+!
+      USE ioipsl_getin_p_mod, ONLY : getin_p
+      IMPLICIT NONE
+!-------------------------------------------------------------------------
+!
+! Objet : calcul de la temperature et l'humidite relative a 2m et du 
+!         module du vent a 10m a partir des relations de Dyer-Businger et
+!         des equations de Louis.
+!
+! Reference : Hess, Colman et McAvaney (1995)        
+!
+! I. Musat, 01.07.2002
+!
+!AM On rajoute en sortie t et q a 10m pr le calcule d'hbtm2 dans clmain
+!
+!-------------------------------------------------------------------------
+!
+! klon----input-I- dimension de la grille physique (= nb_pts_latitude X nb_pts_longitude)
+! knon----input-I- nombre de points pour un type de surface
+! nsrf----input-I- indice pour le type de surface; voir indice_sol_mod.F90
+! zxli----input-L- TRUE si calcul des cdrags selon Laurent Li
+! u1------input-R- vent zonal au 1er niveau du modele
+! v1------input-R- vent meridien au 1er niveau du modele
+! t1------input-R- temperature de l'air au 1er niveau du modele
+! q1------input-R- humidite relative au 1er niveau du modele
+! z1------input-R- geopotentiel au 1er niveau du modele
+! ts1-----input-R- temperature de l'air a la surface
+! qsurf---input-R- humidite relative a la surface
+! z0m, z0h---input-R- rugosite
+! psol----input-R- pression au sol
+! pat1----input-R- pression au 1er niveau du modele
+!
+! t_2m---output-R- temperature de l'air a 2m
+! q_2m---output-R- humidite relative a 2m
+! u_2m--output-R- vitesse du vent a 2m
+! u_10m--output-R- vitesse du vent a 10m
+! ustar--output-R- u*
+!AM
+! t_10m--output-R- temperature de l'air a 10m
+! q_10m--output-R- humidite specifique a 10m
+!
+      INTEGER, intent(in) :: klon, knon, nsrf
+      LOGICAL, intent(in) :: zxli
+      REAL, dimension(klon), intent(in) :: u1, v1, t1, q1, ts1, z1
+      REAL, dimension(klon), intent(inout) :: z0m, z0h
+      REAL, dimension(klon), intent(in) :: qsurf
+      REAL, dimension(klon), intent(in) :: psol, pat1
+!
+      REAL, dimension(klon), intent(out) :: t_2m, q_2m, ustar
+      REAL, dimension(klon), intent(out) :: u_10m, t_10m, q_10m
+      INTEGER, dimension(klon, 6), intent(out) :: n2mout
+!
+      REAL, dimension(klon) :: u_2m
+      REAL, dimension(klon) :: cdrm2m, cdrh2m, ri2m
+      REAL, dimension(klon) :: cdram, cdrah, zri1
+      REAL, dimension(klon) :: cdmn1, cdhn1, fm1, fh1
+      REAL, dimension(klon) :: cdmn2m, cdhn2m, fm2m, fh2m
+      REAL, dimension(klon) :: ri2m_new
+      REAL, DIMENSION(klon) :: s_pblh
+      REAL, DIMENSION(klon) :: prain
+      REAL, DIMENSION(klon) :: tsol
+!-------------------------------------------------------------------------
+      include "flux_arp.h"
+      include "YOMCST.h"
+!IM PLUS
+      include "YOETHF.h"
+!
+! Quelques constantes et options:
+!
+! RKAR : constante de von Karman
+      REAL, PARAMETER :: RKAR=0.40
+! niter : nombre iterations calcul "corrector"
+!     INTEGER, parameter :: niter=6, ncon=niter-1
+!IM 071020     INTEGER, parameter :: niter=2, ncon=niter-1
+      INTEGER, parameter :: niter=2, ncon=niter
+!     INTEGER, parameter :: niter=6, ncon=niter
+!
+! Variables locales
+      INTEGER :: i, n
+      REAL :: zref
+      REAL, dimension(klon) :: speed
+! tpot : temperature potentielle
+      REAL, dimension(klon) :: tpot
+      REAL, dimension(klon) :: cdran
+! ri1 : nb. de Richardson entre la surface --> la 1ere couche
+      REAL, dimension(klon) :: ri1 
+      DOUBLE PRECISION, parameter :: eps=1.0D-20
+      REAL, dimension(klon) :: delu, delte, delq
+      REAL, dimension(klon) :: delh, delm
+      REAL, dimension(klon) :: delh_new, delm_new
+      REAL, dimension(klon) :: u_zref, te_zref, q_zref  
+      REAL, dimension(klon) :: u_zref_pnew, te_zref_pnew, q_zref_pnew
+      REAL, dimension(klon) :: temp, pref
+      REAL, dimension(klon) :: temp_new, pref_new
+      LOGICAL :: okri
+      REAL, dimension(klon) :: u_zref_p, te_zref_p, temp_p, q_zref_p
+      REAL, dimension(klon) :: u_zref_p_new, te_zref_p_new, temp_p_new, q_zref_p_new
+!convergence
+      REAL, dimension(klon) :: te_zref_con, q_zref_con
+      REAL, dimension(klon) :: u_zref_c, te_zref_c, temp_c, q_zref_c
+      REAL, dimension(klon) :: ok_pred, ok_corr
+!
+      REAL, dimension(klon) :: cdrm10m, cdrh10m, ri10m
+      REAL, dimension(klon) :: cdmn10m, cdhn10m, fm10m, fh10m
+      REAL, dimension(klon) :: cdn2m, cdn1, zri_zero
+      REAL :: CEPDUE,zdu2 
+      INTEGER :: nzref, nz1
+      LOGICAL, dimension(klon) :: ok_t2m_toosmall, ok_t2m_toobig
+      LOGICAL, dimension(klon) :: ok_q2m_toosmall, ok_q2m_toobig
+      LOGICAL, dimension(klon) :: ok_u2m_toobig
+      LOGICAL, dimension(klon) :: ok_t10m_toosmall, ok_t10m_toobig
+      LOGICAL, dimension(klon) :: ok_q10m_toosmall, ok_q10m_toobig
+      LOGICAL, dimension(klon) :: ok_u10m_toobig
+      INTEGER, dimension(klon, 6) :: n10mout
+
+!------------------------------------------------------------------------- 
+      CEPDUE=0.1
+!
+! n2mout : compteur des pas de temps ou t2m,q2m ou u2m sont en dehors des intervalles
+!          [tsurf, temp], [qsurf, q1] ou [0, speed]
+! n10mout : compteur des pas de temps ou t10m,q10m ou u10m sont en dehors des intervalles
+!          [tsurf, temp], [qsurf, q1] ou [0, speed]
+!
+      n2mout(:,:)=0
+      n10mout(:,:)=0
+      
+      DO i=1, knon
+       speed(i)=MAX(SQRT(u1(i)**2+v1(i)**2),CEPDUE)
+       ri1(i) = 0.0
+      ENDDO
+!
+      okri=.FALSE.
+      CALL cdrag(knon, nsrf, &
+ &                   speed, t1, q1, z1, &
+ &                   psol, s_pblh, ts1, qsurf, z0m, z0h, &
+ &                   zri_zero, 0, &
+ &                   cdram, cdrah, zri1, pref, prain, tsol, pat1)
+
+!
+      DO i = 1, knon
+        ri1(i) = zri1(i)
+        tpot(i) = t1(i)* (psol(i)/pat1(i))**RKAPPA
+        zdu2 = MAX(CEPDUE*CEPDUE, speed(i)**2)
+        ustar(i) = sqrt(cdram(i) * zdu2)
+!
+      ENDDO
+!
+!----------First aproximation of variables at zref --------------------------
+      zref = 2.0
+!
+! calcul first-guess en utilisant dans les calculs à 2m
+! le Richardson de la premiere couche atmospherique 
+!
+       CALL screencn(klon, knon, nsrf, zxli, &
+ &                   speed, tpot, q1, zref, &
+ &                   ts1, qsurf, z0m, z0h, psol, &           
+ &                   cdram, cdrah,  okri, &
+ &                   ri1, 1, &
+ &                   pref_new, delm_new, delh_new, ri2m, &
+ &                   s_pblh, prain, tsol, pat1      )
+!
+       DO i = 1, knon
+         u_zref(i) = delm_new(i)*speed(i)
+         u_zref_p(i) = u_zref(i)
+         q_zref(i) = delh_new(i)*max(q1(i),0.0) + &
+         &           max(qsurf(i),0.0)*(1-delh_new(i))
+         q_zref_p(i) = q_zref(i)
+         te_zref(i) = delh_new(i)*tpot(i) + ts1(i)*(1-delh_new(i))
+         te_zref_p(i) = te_zref(i)
+!
+! return to normal temperature
+         temp(i) = te_zref(i) * (psol(i)/pref_new(i))**(-RKAPPA)
+         temp_p(i) = temp(i)
+!
+! compteurs ici
+!
+         ok_t2m_toosmall(i)=te_zref(i).LT.tpot(i).AND. &
+         & te_zref(i).LT.ts1(i)
+         ok_t2m_toobig(i)=te_zref(i).GT.tpot(i).AND. &
+         & te_zref(i).GT.ts1(i)
+         ok_q2m_toosmall(i)=q_zref(i).LT.q1(i).AND. &
+         & q_zref(i).LT.qsurf(i)
+         ok_q2m_toobig(i)=q_zref(i).GT.q1(i).AND. &
+         & q_zref(i).GT.qsurf(i)
+         ok_u2m_toobig(i)=u_zref(i).GT.speed(i)
+!
+         IF(ok_t2m_toosmall(i).OR.ok_t2m_toobig(i)) THEN
+             n2mout(i,1)=n2mout(i,1)+1
+         ENDIF
+         IF(ok_q2m_toosmall(i).OR.ok_q2m_toobig(i)) THEN
+             n2mout(i,3)=n2mout(i,3)+1
+         ENDIF
+         IF(ok_u2m_toobig(i)) THEN
+             n2mout(i,5)=n2mout(i,5)+1
+         ENDIF
+!
+         IF(ok_t2m_toosmall(i).OR.ok_t2m_toobig(i).OR. &
+          & ok_q2m_toosmall(i).OR.ok_q2m_toobig(i).OR. &
+          & ok_u2m_toobig(i)) THEN 
+             delm_new(i)=min(max(delm_new(i),0.),1.)
+             delh_new(i)=min(max(delh_new(i),0.),1.)
+             u_zref(i) = delm_new(i)*speed(i)
+             u_zref_p(i) = u_zref(i)
+             q_zref(i) = delh_new(i)*max(q1(i),0.0) + &
+         &               max(qsurf(i),0.0)*(1-delh_new(i))
+             q_zref_p(i) = q_zref(i)
+             te_zref(i) = delh_new(i)*tpot(i) + ts1(i)*(1-delh_new(i))
+             te_zref_p(i) = te_zref(i)
+!
+! return to normal temperature
+             temp(i) = te_zref(i) * (psol(i)/pref_new(i))**(-RKAPPA)
+             temp_p(i) = temp(i)
+         ENDIF 
+!
+       ENDDO
+!
+! Iteration of the variables at the reference level zref : corrector calculation ; see Hess & McAvaney, 1995 
+!
+      DO n = 1, niter
+!
+        okri=.TRUE.
+        CALL screencn(klon, knon, nsrf, zxli, &
+ &                   u_zref, temp, q_zref, zref, &
+ &                   ts1, qsurf, z0m, z0h, psol, &
+ &                   cdram, cdrah,  okri, &
+ &                   ri1, 0, &
+ &                   pref, delm, delh, ri2m, &
+ &                   s_pblh, prain, tsol, pat1      )
+!
+        DO i = 1, knon
+          u_zref(i) = delm(i)*speed(i)
+          q_zref(i) = delh(i)*max(q1(i),0.0) + &
+          &           max(qsurf(i),0.0)*(1-delh(i))
+          te_zref(i) = delh(i)*tpot(i) + ts1(i)*(1-delh(i))
+!
+! return to normal temperature
+          temp(i) = te_zref(i) * (psol(i)/pref(i))**(-RKAPPA)
+!
+! compteurs ici
+!
+          ok_t2m_toosmall(i)=te_zref(i).LT.tpot(i).AND. &
+          & te_zref(i).LT.ts1(i)
+          ok_t2m_toobig(i)=te_zref(i).GT.tpot(i).AND. &
+          & te_zref(i).GT.ts1(i)
+          ok_q2m_toosmall(i)=q_zref(i).LT.q1(i).AND. &
+          & q_zref(i).LT.qsurf(i)
+          ok_q2m_toobig(i)=q_zref(i).GT.q1(i).AND. &
+          & q_zref(i).GT.qsurf(i)
+          ok_u2m_toobig(i)=u_zref(i).GT.speed(i)
+!
+          IF(ok_t2m_toosmall(i).OR.ok_t2m_toobig(i)) THEN
+              n2mout(i,2)=n2mout(i,2)+1
+          ENDIF
+          IF(ok_q2m_toosmall(i).OR.ok_q2m_toobig(i)) THEN
+              n2mout(i,4)=n2mout(i,4)+1
+          ENDIF
+          IF(ok_u2m_toobig(i)) THEN
+              n2mout(i,6)=n2mout(i,6)+1
+          ENDIF
+!
+          IF(ok_t2m_toosmall(i).OR.ok_t2m_toobig(i).OR. &
+           & ok_q2m_toosmall(i).OR.ok_q2m_toobig(i).OR. &
+           & ok_u2m_toobig(i)) THEN 
+              delm(i)=min(max(delm(i),0.),1.)
+              delh(i)=min(max(delh(i),0.),1.)
+              u_zref(i) = delm(i)*speed(i)
+              q_zref(i) = delh(i)*max(q1(i),0.0) + &
+          &           max(qsurf(i),0.0)*(1-delh(i))
+              te_zref(i) = delh(i)*tpot(i) + ts1(i)*(1-delh(i))
+              temp(i) = te_zref(i) * (psol(i)/pref(i))**(-RKAPPA)
+          ENDIF
+!
+!
+          IF(n.EQ.ncon) THEN
+            te_zref_con(i) = te_zref(i)
+            q_zref_con(i) = q_zref(i)
+          ENDIF 
+!
+        ENDDO 
+!
+      ENDDO 
+!
+      DO i = 1, knon
+        q_zref_c(i) = q_zref(i)
+        temp_c(i) = temp(i)
+!
+        ok_pred(i)=0.
+        ok_corr(i)=1.
+!
+        t_2m(i) = temp_p(i) * ok_pred(i) + temp_c(i) * ok_corr(i)
+        q_2m(i) = q_zref_p(i) * ok_pred(i) + q_zref_c(i) * ok_corr(i)
+!
+        u_zref_c(i) = u_zref(i)
+        u_2m(i) = u_zref_p(i) * ok_pred(i) + u_zref_c(i) * ok_corr(i)
+      ENDDO
+!
+!
+!----------First aproximation of variables at zref --------------------------
+!
+      zref = 10.0
+!
+       CALL screencn(klon, knon, nsrf, zxli, &
+ &                   speed, tpot, q1, zref, &
+ &                   ts1, qsurf, z0m, z0h, psol, &           
+ &                   cdram, cdrah,  okri, &
+ &                   ri1, 1, &
+ &                   pref_new, delm_new, delh_new, ri10m, &
+ &                   s_pblh, prain, tsol, pat1      )
+!
+       DO i = 1, knon
+         u_zref(i) = delm_new(i)*speed(i)
+         q_zref(i) = delh_new(i)*max(q1(i),0.0) + &
+         &           max(qsurf(i),0.0)*(1-delh_new(i))
+         te_zref(i) = delh_new(i)*tpot(i) + ts1(i)*(1-delh_new(i))
+         temp(i) = te_zref(i) * (psol(i)/pref_new(i))**(-RKAPPA)
+         u_zref_p(i) = u_zref(i)
+!
+! compteurs ici
+!
+         ok_t10m_toosmall(i)=te_zref(i).LT.tpot(i).AND. &
+         & te_zref(i).LT.ts1(i)
+         ok_t10m_toobig(i)=te_zref(i).GT.tpot(i).AND. &
+         & te_zref(i).GT.ts1(i)
+         ok_q10m_toosmall(i)=q_zref(i).LT.q1(i).AND. &
+         & q_zref(i).LT.qsurf(i)
+         ok_q10m_toobig(i)=q_zref(i).GT.q1(i).AND. &
+         & q_zref(i).GT.qsurf(i)
+         ok_u10m_toobig(i)=u_zref(i).GT.speed(i)
+!
+         IF(ok_t10m_toosmall(i).OR.ok_t10m_toobig(i)) THEN
+             n10mout(i,1)=n10mout(i,1)+1
+         ENDIF
+         IF(ok_q10m_toosmall(i).OR.ok_q10m_toobig(i)) THEN
+             n10mout(i,3)=n10mout(i,3)+1
+         ENDIF
+         IF(ok_u10m_toobig(i)) THEN
+             n10mout(i,5)=n10mout(i,5)+1
+         ENDIF
+!
+         IF(ok_t10m_toosmall(i).OR.ok_t10m_toobig(i).OR. &
+          & ok_q10m_toosmall(i).OR.ok_q10m_toobig(i).OR. &
+          & ok_u10m_toobig(i)) THEN 
+             delm_new(i)=min(max(delm_new(i),0.),1.)
+             delh_new(i)=min(max(delh_new(i),0.),1.)
+             u_zref(i) = delm_new(i)*speed(i)
+             u_zref_p(i) = u_zref(i)
+             q_zref(i) = delh_new(i)*max(q1(i),0.0) + &
+         &               max(qsurf(i),0.0)*(1-delh_new(i))
+             te_zref(i) = delh_new(i)*tpot(i) + ts1(i)*(1-delh_new(i))
+             temp(i) = te_zref(i) * (psol(i)/pref_new(i))**(-RKAPPA)
+         ENDIF 
+!
+       ENDDO
+!
+! Iteration of the variables at the reference level zref : corrector calculation ; see Hess & McAvaney, 1995 
+!
+      DO n = 1, niter
+!
+        okri=.TRUE.
+        CALL screencn(klon, knon, nsrf, zxli, &
+ &                   u_zref, temp, q_zref, zref, &
+ &                   ts1, qsurf, z0m, z0h, psol, &
+ &                   cdram, cdrah,  okri, &
+ &                   ri1, 0, &
+ &                   pref, delm, delh, ri10m, &
+ &                   s_pblh, prain, tsol, pat1      )
+!
+        DO i = 1, knon
+          u_zref(i) = delm(i)*speed(i)
+          q_zref(i) = delh(i)*max(q1(i),0.0) + &
+          &           max(qsurf(i),0.0)*(1-delh(i))
+          te_zref(i) = delh(i)*tpot(i) + ts1(i)*(1-delh(i))
+!
+! return to normal temperature
+          temp(i) = te_zref(i) * (psol(i)/pref(i))**(-RKAPPA)
+!
+! compteurs ici
+!
+          ok_t10m_toosmall(i)=te_zref(i).LT.tpot(i).AND. &
+          & te_zref(i).LT.ts1(i)
+          ok_t10m_toobig(i)=te_zref(i).GT.tpot(i).AND. &
+          & te_zref(i).GT.ts1(i)
+          ok_q10m_toosmall(i)=q_zref(i).LT.q1(i).AND. &
+          & q_zref(i).LT.qsurf(i)
+          ok_q10m_toobig(i)=q_zref(i).GT.q1(i).AND. &
+          & q_zref(i).GT.qsurf(i)
+          ok_u10m_toobig(i)=u_zref(i).GT.speed(i)
+!
+          IF(ok_t10m_toosmall(i).OR.ok_t10m_toobig(i)) THEN
+              n10mout(i,2)=n10mout(i,2)+1
+          ENDIF
+          IF(ok_q10m_toosmall(i).OR.ok_q10m_toobig(i)) THEN
+              n10mout(i,4)=n10mout(i,4)+1
+          ENDIF
+          IF(ok_u10m_toobig(i)) THEN
+              n10mout(i,6)=n10mout(i,6)+1
+          ENDIF
+!
+          IF(ok_t10m_toosmall(i).OR.ok_t10m_toobig(i).OR. &
+           & ok_q10m_toosmall(i).OR.ok_q10m_toobig(i).OR. &
+           & ok_u10m_toobig(i)) THEN 
+              delm(i)=min(max(delm(i),0.),1.)
+              delh(i)=min(max(delh(i),0.),1.)
+              u_zref(i) = delm(i)*speed(i)
+              q_zref(i) = delh(i)*max(q1(i),0.0) + &
+          &           max(qsurf(i),0.0)*(1-delh(i))
+              te_zref(i) = delh(i)*tpot(i) + ts1(i)*(1-delh(i))
+              temp(i) = te_zref(i) * (psol(i)/pref(i))**(-RKAPPA)
+          ENDIF
+!
+!
+          IF(n.EQ.ncon) THEN
+            te_zref_con(i) = te_zref(i)
+            q_zref_con(i) = q_zref(i)
+          ENDIF 
+!
+        ENDDO 
+!
+      ENDDO 
+!
+      DO i = 1, knon
+        q_zref_c(i) = q_zref(i)
+        temp_c(i) = temp(i)
+!
+        ok_pred(i)=0.
+        ok_corr(i)=1.
+!
+        t_10m(i) = temp_p(i) * ok_pred(i) + temp_c(i) * ok_corr(i)
+        q_10m(i) = q_zref_p(i) * ok_pred(i) + q_zref_c(i) * ok_corr(i)
+!
+        u_zref_c(i) = u_zref(i)
+        u_10m(i) = u_zref_p(i) * ok_pred(i) + u_zref_c(i) * ok_corr(i)
+      ENDDO
+!
+      RETURN
+      END subroutine stdlevvarn
+
+END MODULE stdlevvar_mod
Index: DZ6/trunk/libf/phylmd/stratocu_if.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/stratocu_if.F90	(revision 5267)
+++ 	(revision )
@@ -1,80 +1,0 @@
-  SUBROUTINE stratocu_if(klon,klev,pctsrf,paprs, pplay,t &
-,seuil_inversion,weak_inversion,dthmin)
-
-  USE indice_sol_mod
-
-IMPLICIT NONE
-
-!======================================================================
-! J'introduit un peu de diffusion sauf dans les endroits
-! ou une forte inversion est presente
-! On peut dire qu'il represente la convection peu profonde
-!
-! Arguments:
-! klon-----input-I- nombre de points a traiter
-! paprs----input-R- pression a chaque intercouche (en Pa)
-! pplay----input-R- pression au milieu de chaque couche (en Pa)
-! t--------input-R- temperature (K)
-!
-! weak_inversion-----logical
-!======================================================================
-!
-! Arguments:
-!
-    INTEGER, INTENT(IN)                       :: klon,klev
-    REAL, DIMENSION(klon, klev+1), INTENT(IN) ::  paprs
-    REAL, DIMENSION(klon, klev), INTENT(IN)   ::  pplay
-    REAL, DIMENSION(klon, 4), INTENT(IN)   ::  pctsrf
-    REAL, DIMENSION(klon, klev), INTENT(IN)   :: t
-    
-    REAL, DIMENSION(klon), INTENT(OUT)  :: weak_inversion
-!
-! Quelques constantes et options:
-!
-    REAL seuil_inversion ! au-dela l'inversion est consideree trop faible
-!    PARAMETER (seuil=-0.1)
-
-!
-! Variables locales:
-!
-    INTEGER i, k, invb(klon)
-    REAL zl2(klon)
-    REAL dthmin(klon), zdthdp
-
-    INCLUDE "YOMCST.h"
-
-!
-! Chercher la zone d'inversion forte
-!
-
-    DO i = 1, klon
-       invb(i) = klev
-       dthmin(i)=0.0
-    ENDDO
-    DO k = 2, klev/2-1
-       DO i = 1, klon
-          zdthdp = (t(i,k)-t(i,k+1))/(pplay(i,k)-pplay(i,k+1)) &
-               - RD * 0.5*(t(i,k)+t(i,k+1))/RCPD/paprs(i,k+1)
-          zdthdp = zdthdp * 100.0
-          IF (pplay(i,k).GT.0.8*paprs(i,1) .AND. &
-               zdthdp.LT.dthmin(i) ) THEN
-             dthmin(i) = zdthdp
-             invb(i) = k
-          ENDIF
-       ENDDO
-    ENDDO
-
-
-!
-! Introduire une diffusion:
-!
-    DO i = 1, klon
-       IF ( (pctsrf(i,is_oce) < 0.5) .OR. &
-          (invb(i) == klev) .OR. (dthmin(i) > seuil_inversion) ) THEN 
-          weak_inversion(i)=1.
-       ELSE
-          weak_inversion(i)=0.
-       ENDIF
-    ENDDO
-
-  END SUBROUTINE stratocu_if
Index: /LMDZ6/trunk/libf/phylmd/stratocu_if.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/stratocu_if.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/stratocu_if.f90	(revision 5268)
@@ -0,0 +1,80 @@
+  SUBROUTINE stratocu_if(klon,klev,pctsrf,paprs, pplay,t &
+,seuil_inversion,weak_inversion,dthmin)
+
+  USE indice_sol_mod
+
+IMPLICIT NONE
+
+!======================================================================
+! J'introduit un peu de diffusion sauf dans les endroits
+! ou une forte inversion est presente
+! On peut dire qu'il represente la convection peu profonde
+!
+! Arguments:
+! klon-----input-I- nombre de points a traiter
+! paprs----input-R- pression a chaque intercouche (en Pa)
+! pplay----input-R- pression au milieu de chaque couche (en Pa)
+! t--------input-R- temperature (K)
+!
+! weak_inversion-----logical
+!======================================================================
+!
+! Arguments:
+!
+    INTEGER, INTENT(IN)                       :: klon,klev
+    REAL, DIMENSION(klon, klev+1), INTENT(IN) ::  paprs
+    REAL, DIMENSION(klon, klev), INTENT(IN)   ::  pplay
+    REAL, DIMENSION(klon, 4), INTENT(IN)   ::  pctsrf
+    REAL, DIMENSION(klon, klev), INTENT(IN)   :: t
+    
+    REAL, DIMENSION(klon), INTENT(OUT)  :: weak_inversion
+!
+! Quelques constantes et options:
+!
+    REAL seuil_inversion ! au-dela l'inversion est consideree trop faible
+!    PARAMETER (seuil=-0.1)
+
+!
+! Variables locales:
+!
+    INTEGER i, k, invb(klon)
+    REAL zl2(klon)
+    REAL dthmin(klon), zdthdp
+
+    INCLUDE "YOMCST.h"
+
+!
+! Chercher la zone d'inversion forte
+!
+
+    DO i = 1, klon
+       invb(i) = klev
+       dthmin(i)=0.0
+    ENDDO
+    DO k = 2, klev/2-1
+       DO i = 1, klon
+          zdthdp = (t(i,k)-t(i,k+1))/(pplay(i,k)-pplay(i,k+1)) &
+               - RD * 0.5*(t(i,k)+t(i,k+1))/RCPD/paprs(i,k+1)
+          zdthdp = zdthdp * 100.0
+          IF (pplay(i,k).GT.0.8*paprs(i,1) .AND. &
+               zdthdp.LT.dthmin(i) ) THEN
+             dthmin(i) = zdthdp
+             invb(i) = k
+          ENDIF
+       ENDDO
+    ENDDO
+
+
+!
+! Introduire une diffusion:
+!
+    DO i = 1, klon
+       IF ( (pctsrf(i,is_oce) < 0.5) .OR. &
+          (invb(i) == klev) .OR. (dthmin(i) > seuil_inversion) ) THEN 
+          weak_inversion(i)=1.
+       ELSE
+          weak_inversion(i)=0.
+       ENDIF
+    ENDDO
+
+  END SUBROUTINE stratocu_if
Index: DZ6/trunk/libf/phylmd/stratosphere_mask.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/stratosphere_mask.F90	(revision 5267)
+++ 	(revision )
@@ -1,252 +1,0 @@
-!
-! $Id$
-!
-SUBROUTINE stratosphere_mask(missing_val, pphis, t_seri, pplay, xlat)
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!
-! determination of tropopause height and temperature from gridded temperature data
-!
-! reference: Reichler, T., M. Dameris, and R. Sausen (GRL, 10.1029/2003GL018240, 2003)
-! modified: 6/28/06 tjr
-! adapted to LMDZ by C. Kleinschmitt (2016-02-15)
-! committed to LMDz by O. Boucher (2016) with a mistake 
-! mistake corrected by O. Boucher (2017-12-11)
-!
-! input:  temp(nlon,nlat,nlev)  3D-temperature field 
-!         ps(nlon,nlat)         2D-surface pressure field
-!         zs(nlon,nlat)         2D-surface height
-!         nlon                  grid points in x
-!         nlat                  grid points in y
-!         pfull(nlon,nlat,nlev) full pressure levels in Pa
-!         plimu                 upper limit for tropopause pressure
-!         pliml                 lower limit for tropopause pressure 
-!         gamma                 tropopause criterion, e.g. -0.002 K/m
-!
-! output: p_tropopause(klon)    tropopause pressure in Pa with missing values
-!         t_tropopause(klon)    tropopause temperature in K with missing values
-!         z_tropopause(klon)    tropopause height in m with missing values
-!         stratomask            stratospheric mask withtout missing values
-!         ifil                  # of undetermined values
-!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-USE dimphy
-USE phys_local_var_mod, ONLY: stratomask
-USE phys_local_var_mod, ONLY: p_tropopause, z_tropopause, t_tropopause
-USE print_control_mod, ONLY: lunout, prt_level
-
-IMPLICIT NONE
-
-INCLUDE "YOMCST.h"
-
-REAL, INTENT(IN)                       :: missing_val ! missing value, also XIOS
-REAL,DIMENSION(klon),INTENT(IN)        :: pphis   ! Geopotentiel de surface
-REAL,DIMENSION(klon,klev),INTENT(IN)   :: t_seri  ! Temperature
-REAL,DIMENSION(klon,klev),INTENT(IN)   :: pplay   ! pression pour le mileu de chaque couche (en Pa)
-REAL,DIMENSION(klon),INTENT(IN)        :: xlat    ! latitudes pour chaque point 
-
-REAL, PARAMETER                        :: plimu=45000.
-REAL, PARAMETER                        :: pliml=7500.
-REAL, PARAMETER                        :: gamma=-0.002
-LOGICAL, PARAMETER                     :: dofill=.true.
-REAL,DIMENSION(klon)                   :: tp
-REAL,DIMENSION(klev)                   :: t, p
-INTEGER                                :: i, k, ifil
-REAL                                   :: ptrp, ttrp, ztrp, psrf, zsrf, pi
-
-pi     = 4.*ATAN(1.)
-
-!--computing tropopause
-DO i=1,klon
-  DO k=1,klev 
-    t(k)=t_seri(i,klev+1-k) 
-    p(k)=pplay(i,klev+1-k)
-  ENDDO
-  psrf=pplay(i,1)
-  zsrf=pphis(i)/RG           !--altitude de la surface
-  call twmo(missing_val, klev, t, p, psrf, zsrf, plimu, pliml, gamma, ptrp, ttrp, ztrp)
-  tp(i)=ptrp
-  p_tropopause(i)=ptrp
-  z_tropopause(i)=ztrp
-  t_tropopause(i)=ttrp
-ENDDO
-
-!--filling holes in tp but not in p_tropopause
-IF (dofill) THEN
-  ifil=0
-  DO i=1,klon
-  IF (ABS(tp(i)/missing_val-1.0).LT.0.01) THEN
-    !set missing values to very simple profile (neighbour averaging too expensive in LMDZ)
-    tp(i)=50000.-20000.*cos(xlat(i)/360.*2.*pi)
-    ifil=ifil+1
-  ENDIF
-  ENDDO
-!
-ENDIF
-!
-DO i=1, klon
-DO k=1, klev
-  IF (pplay(i,k).LT.tp(i)) THEN
-    stratomask(i,k)=1.0
-  ELSE
-    stratomask(i,k)=0.0
-  ENDIF
-ENDDO
-ENDDO
-
-IF (ifil.GT.0 .AND. prt_level >5) THEN
-  write(lunout,*)'Tropopause: number of undetermined values =', ifil
-ENDIF
-
-RETURN
-END SUBROUTINE stratosphere_mask
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! twmo
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-subroutine twmo(missing_val, level, t, p, ps, zs, plimu, pliml, gamma, ptrp, ttrp, ztrp)
-
-! reference: Reichler, T., M. Dameris, and R. Sausen (GRL, 10.1029/2003GL018240, 2003)
-
-implicit none
-
-include "YOMCST.h"
-
-integer,intent(in)              :: level
-real,intent(in)                 :: missing_val
-real,intent(in),dimension(level):: t, p
-real,intent(in)                 :: plimu, pliml, gamma, ps, zs
-real,intent(out)                :: ptrp, ttrp, ztrp
-
-real,parameter                  :: deltaz = 2000.0
-
-real     :: faktor
-real     :: pmk, pm, a, b, tm, dtdp, dtdz, dlnp, tdlnp
-real     :: ag, bg, ptph, ttph, a0, b0
-real     :: pm0, tm0, pmk0, dtdz0
-real     :: p2km, asum, aquer
-real     :: pmk2, pm2, a2, b2, tm2, dtdp2, dtdz2
-integer  :: icount, jj, j
-
-ptrp=missing_val
-ttrp=missing_val
-ztrp=missing_val
-
-faktor = -RG/RD
-
-do j=level,2,-1
-
-   ! dt/dz
-   pmk= 0.5 * (p(j-1)**rkappa+p(j)**rkappa)        ! p**k at half level
-   pm = pmk**(1./rkappa)                    ! p at half level
-   a = (t(j-1)-t(j))/(p(j-1)**rkappa-p(j)**rkappa)    ! dT/dp^k
-   b = t(j)-(a*p(j)**rkappa)
-   tm = a * pmk + b                    ! T at half level         
-   dtdp = a * rkappa * pm**(rkappa-1.) ! dT/dp at half level
-   dtdz = faktor*dtdp*pm/tm            ! dT/dz at half level
-
-   ! dt/dz valid?
-   if (j.eq.level)     go to 999                 ! no, start level, initialize first
-   if (dtdz.le.gamma)  go to 999                 ! no, dt/dz < -2 K/km
-   if (dtdz0.gt.gamma) go to 999                 ! no, dt/dz below > -2 K/km
-   if (pm.gt.plimu)    go to 999                 ! no, pm too low
-
-   ! dtdz is valid, calculate tropopause pressure ptph
-   ag = (dtdz-dtdz0) / (pmk-pmk0)     
-   bg = dtdz0 - (ag * pmk0)          
-   ptph = exp(log((gamma-bg)/ag)/rkappa)
-
-   ! calculate temperature at this ptph assuming linear gamma
-   ! interpolation
-   ttph = tm0
-   ttph = ttph - (bg * log(pm0)  + ag * (pm0**rkappa) /rkappa) / faktor*t(j)
-   ttph = ttph + (bg * log(ptph) + ag * (ptph**rkappa)/rkappa) / faktor*t(j)
-
-   if (ptph.lt.pliml) go to 999 
-   if (ptph.gt.plimu) go to 999     
-
-   ! 2nd test: dtdz above 2 km must not exceed gamma
-   p2km = ptph + deltaz*(pm/tm)*faktor      ! p at ptph + 2km
-   asum = 0.0                               ! dtdz above
-   icount = 0                               ! number of levels above
-
-   ! test until apm < p2km
-   do jj=j,2,-1
-
-       pmk2 = .5 * (p(jj-1)**rkappa+p(jj)**rkappa)    ! p mean ^kappa
-       pm2 = pmk2**(1/rkappa)                      ! p mean
-       if(pm2.gt.ptph) go to 110                ! doesn't happen
-       if(pm2.lt.p2km) go to 888                ! ptropo is valid
-
-       a2 = (t(jj-1)-t(jj))                     ! a
-       a2 = a2/(p(jj-1)**rkappa-p(jj)**rkappa)
-       b2 = t(jj)-(a2*p(jj)**rkappa)               ! b
-       tm2 = a2 * pmk2 + b2                     ! T mean
-       dtdp2 = a2 * rkappa * (pm2**(rkappa-1))        ! dt/dp
-       dtdz2 = faktor*dtdp2*pm2/tm2
-       asum = asum+dtdz2
-       icount = icount+1
-       aquer = asum/float(icount)               ! dt/dz mean
-   
-       ! discard ptropo ?
-        if (aquer.le.gamma) go to 999           ! dt/dz above < gamma
-
-110 continue 
-    enddo                   ! test next level
-
-888 continue                    ! ptph is valid
-    ptrp = ptph
-    ttrp = ttph
-
-! now calculate height of tropopause by integrating hypsometric equation
-! from ps to ptrp
-! linearly interpolate in p (results are identical to p^kappa)
-
-jj = LEVEL                                       ! bottom
-do while ((P(jj).gt.PS) .or. (T(jj).lt.100))     ! T must be valid too
-  jj=jj-1
-enddo
-
-DLNP = log(PS/P(jj))                             ! from surface pressure
-TM = T(jj)                                       ! take TM of lowest level (better: extrapolate)
-TDLNP = TM*DLNP
-
-do while ( (JJ.ge.2) .and. (PTRP.lt.P(jj-1)) ) 
-  DLNP = log(P(jj)/P(jj-1))
-  TM = 0.5 * (T(jj) + T(jj-1))
-  TDLNP = TDLNP + TM*DLNP
-  JJ=JJ-1
-enddo
-
-DLNP = log(P(jj)/PTRP)                           ! up to tropopause pressure
-TM = 0.5 * (T(jj) + TTRP)                        ! use TTRP to get TM of this level
-TDLNP = TDLNP + TM*DLNP
-
-ZTRP = ZS + TDLNP*RD/RG
-
-!!if (ZTRP .lt. 0) then
-!!  print*,'ZTRP=',ZTRP
-!!  print*,'PS=',PS
-!!  print*,'P=',P
-!!  print*,'T=',T
-!!  print*,'ZS=',ZS
-!!  stop
-!!endif
-
-return
-
-999 continue                    ! continue search at next higher level 
-    tm0 = tm
-    pm0 = pm
-    pmk0 = pmk
-    dtdz0  = dtdz
-    a0 = a
-    b0 = b
-
-enddo 
-
-! no tropopouse found
-return
-end subroutine twmo
Index: /LMDZ6/trunk/libf/phylmd/stratosphere_mask.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/stratosphere_mask.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/stratosphere_mask.f90	(revision 5268)
@@ -0,0 +1,252 @@
+!
+! $Id$
+!
+SUBROUTINE stratosphere_mask(missing_val, pphis, t_seri, pplay, xlat)
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
+! determination of tropopause height and temperature from gridded temperature data
+!
+! reference: Reichler, T., M. Dameris, and R. Sausen (GRL, 10.1029/2003GL018240, 2003)
+! modified: 6/28/06 tjr
+! adapted to LMDZ by C. Kleinschmitt (2016-02-15)
+! committed to LMDz by O. Boucher (2016) with a mistake 
+! mistake corrected by O. Boucher (2017-12-11)
+!
+! input:  temp(nlon,nlat,nlev)  3D-temperature field 
+!         ps(nlon,nlat)         2D-surface pressure field
+!         zs(nlon,nlat)         2D-surface height
+!         nlon                  grid points in x
+!         nlat                  grid points in y
+!         pfull(nlon,nlat,nlev) full pressure levels in Pa
+!         plimu                 upper limit for tropopause pressure
+!         pliml                 lower limit for tropopause pressure 
+!         gamma                 tropopause criterion, e.g. -0.002 K/m
+!
+! output: p_tropopause(klon)    tropopause pressure in Pa with missing values
+!         t_tropopause(klon)    tropopause temperature in K with missing values
+!         z_tropopause(klon)    tropopause height in m with missing values
+!         stratomask            stratospheric mask withtout missing values
+!         ifil                  # of undetermined values
+!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+USE dimphy
+USE phys_local_var_mod, ONLY: stratomask
+USE phys_local_var_mod, ONLY: p_tropopause, z_tropopause, t_tropopause
+USE print_control_mod, ONLY: lunout, prt_level
+
+IMPLICIT NONE
+
+INCLUDE "YOMCST.h"
+
+REAL, INTENT(IN)                       :: missing_val ! missing value, also XIOS
+REAL,DIMENSION(klon),INTENT(IN)        :: pphis   ! Geopotentiel de surface
+REAL,DIMENSION(klon,klev),INTENT(IN)   :: t_seri  ! Temperature
+REAL,DIMENSION(klon,klev),INTENT(IN)   :: pplay   ! pression pour le mileu de chaque couche (en Pa)
+REAL,DIMENSION(klon),INTENT(IN)        :: xlat    ! latitudes pour chaque point 
+
+REAL, PARAMETER                        :: plimu=45000.
+REAL, PARAMETER                        :: pliml=7500.
+REAL, PARAMETER                        :: gamma=-0.002
+LOGICAL, PARAMETER                     :: dofill=.true.
+REAL,DIMENSION(klon)                   :: tp
+REAL,DIMENSION(klev)                   :: t, p
+INTEGER                                :: i, k, ifil
+REAL                                   :: ptrp, ttrp, ztrp, psrf, zsrf, pi
+
+pi     = 4.*ATAN(1.)
+
+!--computing tropopause
+DO i=1,klon
+  DO k=1,klev 
+    t(k)=t_seri(i,klev+1-k) 
+    p(k)=pplay(i,klev+1-k)
+  ENDDO
+  psrf=pplay(i,1)
+  zsrf=pphis(i)/RG           !--altitude de la surface
+  call twmo(missing_val, klev, t, p, psrf, zsrf, plimu, pliml, gamma, ptrp, ttrp, ztrp)
+  tp(i)=ptrp
+  p_tropopause(i)=ptrp
+  z_tropopause(i)=ztrp
+  t_tropopause(i)=ttrp
+ENDDO
+
+!--filling holes in tp but not in p_tropopause
+IF (dofill) THEN
+  ifil=0
+  DO i=1,klon
+  IF (ABS(tp(i)/missing_val-1.0).LT.0.01) THEN
+    !set missing values to very simple profile (neighbour averaging too expensive in LMDZ)
+    tp(i)=50000.-20000.*cos(xlat(i)/360.*2.*pi)
+    ifil=ifil+1
+  ENDIF
+  ENDDO
+!
+ENDIF
+!
+DO i=1, klon
+DO k=1, klev
+  IF (pplay(i,k).LT.tp(i)) THEN
+    stratomask(i,k)=1.0
+  ELSE
+    stratomask(i,k)=0.0
+  ENDIF
+ENDDO
+ENDDO
+
+IF (ifil.GT.0 .AND. prt_level >5) THEN
+  write(lunout,*)'Tropopause: number of undetermined values =', ifil
+ENDIF
+
+RETURN
+END SUBROUTINE stratosphere_mask
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! twmo
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+subroutine twmo(missing_val, level, t, p, ps, zs, plimu, pliml, gamma, ptrp, ttrp, ztrp)
+
+! reference: Reichler, T., M. Dameris, and R. Sausen (GRL, 10.1029/2003GL018240, 2003)
+
+implicit none
+
+include "YOMCST.h"
+
+integer,intent(in)              :: level
+real,intent(in)                 :: missing_val
+real,intent(in),dimension(level):: t, p
+real,intent(in)                 :: plimu, pliml, gamma, ps, zs
+real,intent(out)                :: ptrp, ttrp, ztrp
+
+real,parameter                  :: deltaz = 2000.0
+
+real     :: faktor
+real     :: pmk, pm, a, b, tm, dtdp, dtdz, dlnp, tdlnp
+real     :: ag, bg, ptph, ttph, a0, b0
+real     :: pm0, tm0, pmk0, dtdz0
+real     :: p2km, asum, aquer
+real     :: pmk2, pm2, a2, b2, tm2, dtdp2, dtdz2
+integer  :: icount, jj, j
+
+ptrp=missing_val
+ttrp=missing_val
+ztrp=missing_val
+
+faktor = -RG/RD
+
+do j=level,2,-1
+
+   ! dt/dz
+   pmk= 0.5 * (p(j-1)**rkappa+p(j)**rkappa)        ! p**k at half level
+   pm = pmk**(1./rkappa)                    ! p at half level
+   a = (t(j-1)-t(j))/(p(j-1)**rkappa-p(j)**rkappa)    ! dT/dp^k
+   b = t(j)-(a*p(j)**rkappa)
+   tm = a * pmk + b                    ! T at half level         
+   dtdp = a * rkappa * pm**(rkappa-1.) ! dT/dp at half level
+   dtdz = faktor*dtdp*pm/tm            ! dT/dz at half level
+
+   ! dt/dz valid?
+   if (j.eq.level)     go to 999                 ! no, start level, initialize first
+   if (dtdz.le.gamma)  go to 999                 ! no, dt/dz < -2 K/km
+   if (dtdz0.gt.gamma) go to 999                 ! no, dt/dz below > -2 K/km
+   if (pm.gt.plimu)    go to 999                 ! no, pm too low
+
+   ! dtdz is valid, calculate tropopause pressure ptph
+   ag = (dtdz-dtdz0) / (pmk-pmk0)     
+   bg = dtdz0 - (ag * pmk0)          
+   ptph = exp(log((gamma-bg)/ag)/rkappa)
+
+   ! calculate temperature at this ptph assuming linear gamma
+   ! interpolation
+   ttph = tm0
+   ttph = ttph - (bg * log(pm0)  + ag * (pm0**rkappa) /rkappa) / faktor*t(j)
+   ttph = ttph + (bg * log(ptph) + ag * (ptph**rkappa)/rkappa) / faktor*t(j)
+
+   if (ptph.lt.pliml) go to 999 
+   if (ptph.gt.plimu) go to 999     
+
+   ! 2nd test: dtdz above 2 km must not exceed gamma
+   p2km = ptph + deltaz*(pm/tm)*faktor      ! p at ptph + 2km
+   asum = 0.0                               ! dtdz above
+   icount = 0                               ! number of levels above
+
+   ! test until apm < p2km
+   do jj=j,2,-1
+
+       pmk2 = .5 * (p(jj-1)**rkappa+p(jj)**rkappa)    ! p mean ^kappa
+       pm2 = pmk2**(1/rkappa)                      ! p mean
+       if(pm2.gt.ptph) go to 110                ! doesn't happen
+       if(pm2.lt.p2km) go to 888                ! ptropo is valid
+
+       a2 = (t(jj-1)-t(jj))                     ! a
+       a2 = a2/(p(jj-1)**rkappa-p(jj)**rkappa)
+       b2 = t(jj)-(a2*p(jj)**rkappa)               ! b
+       tm2 = a2 * pmk2 + b2                     ! T mean
+       dtdp2 = a2 * rkappa * (pm2**(rkappa-1))        ! dt/dp
+       dtdz2 = faktor*dtdp2*pm2/tm2
+       asum = asum+dtdz2
+       icount = icount+1
+       aquer = asum/float(icount)               ! dt/dz mean
+   
+       ! discard ptropo ?
+        if (aquer.le.gamma) go to 999           ! dt/dz above < gamma
+
+110 continue 
+    enddo                   ! test next level
+
+888 continue                    ! ptph is valid
+    ptrp = ptph
+    ttrp = ttph
+
+! now calculate height of tropopause by integrating hypsometric equation
+! from ps to ptrp
+! linearly interpolate in p (results are identical to p^kappa)
+
+jj = LEVEL                                       ! bottom
+do while ((P(jj).gt.PS) .or. (T(jj).lt.100))     ! T must be valid too
+  jj=jj-1
+enddo
+
+DLNP = log(PS/P(jj))                             ! from surface pressure
+TM = T(jj)                                       ! take TM of lowest level (better: extrapolate)
+TDLNP = TM*DLNP
+
+do while ( (JJ.ge.2) .and. (PTRP.lt.P(jj-1)) ) 
+  DLNP = log(P(jj)/P(jj-1))
+  TM = 0.5 * (T(jj) + T(jj-1))
+  TDLNP = TDLNP + TM*DLNP
+  JJ=JJ-1
+enddo
+
+DLNP = log(P(jj)/PTRP)                           ! up to tropopause pressure
+TM = 0.5 * (T(jj) + TTRP)                        ! use TTRP to get TM of this level
+TDLNP = TDLNP + TM*DLNP
+
+ZTRP = ZS + TDLNP*RD/RG
+
+!!if (ZTRP .lt. 0) then
+!!  print*,'ZTRP=',ZTRP
+!!  print*,'PS=',PS
+!!  print*,'P=',P
+!!  print*,'T=',T
+!!  print*,'ZS=',ZS
+!!  stop
+!!endif
+
+return
+
+999 continue                    ! continue search at next higher level 
+    tm0 = tm
+    pm0 = pm
+    pmk0 = pmk
+    dtdz0  = dtdz
+    a0 = a
+    b0 = b
+
+enddo 
+
+! no tropopouse found
+return
+end subroutine twmo
Index: DZ6/trunk/libf/phylmd/sumethox.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/sumethox.F90	(revision 5267)
+++ 	(revision )
@@ -1,69 +1,0 @@
-SUBROUTINE SUMETHOX
-
-!**** *SUCLDP*   - INITIALIZE MODULE YOEMETH CONTROLLING *METHOX*
-
-!     PURPOSE.
-!     --------
-!           INITIALIZE YOEMETH
-
-!**   INTERFACE.
-!     ----------
-!        CALL *SUMETHOX* FROM *SUPHEC*
-!              --------        ------
-
-!        EXPLICIT ARGUMENTS :
-!        --------------------
-!        NONE
-
-!        IMPLICIT ARGUMENTS :
-!        --------------------
-!        MODULE YOEMETH
-
-!     METHOD.
-!     -------
-!        SEE DOCUMENTATION
-
-!     EXTERNALS.
-!     ----------
-!        NONE
-
-!     REFERENCE.
-!     ----------
-!        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE
-!     "INTEGRATED FORECASTING SYSTEM"
-
-!     AUTHOR.
-!     -------
-!        C.JAKOB   *ECMWF*
-
-!     MODIFICATIONS.
-!     --------------
-!        ORIGINAL : 98-04-07
-!        Modified : 02-01-29  A.Simmons: increase RQLIM from 3.75e-6
-!        M.Hamrud      01-Oct-2003 CY28 Cleaning
-!        D. Cugnet     24-Feb-2012 Adapted for LMDZ
-!     ------------------------------------------------------------------
-
-USE YOEMETH   , ONLY : RALPHA1 ,RALPHA2  ,RQLIM   ,&
- & RPBOTOX,  RPBOTPH ,RPTOPOX  ,RPTOPPH ,&
- & RALPHA3,  RLOGPPH  
-
-!*       1.    SET VALUES
-!              ----------
-
-IMPLICIT NONE
-RALPHA1=(19.*LOG(10.))/(LOG(20.)**4)
-RALPHA2=LOG(1.0/3.+0.01)
-RQLIM=4.25E-6
-RPBOTOX=10000.
-RPBOTPH=20.
-RPTOPOX=50.
-RPTOPPH=0.1
-RALPHA3=0.5*(LOG(100.)+RALPHA2)
-RLOGPPH=LOG(RPTOPPH/RPBOTPH)
-
-!     -----------------------------------------------------------------
-
-END SUBROUTINE SUMETHOX
-
-
Index: /LMDZ6/trunk/libf/phylmd/sumethox.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/sumethox.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/sumethox.f90	(revision 5268)
@@ -0,0 +1,69 @@
+SUBROUTINE SUMETHOX
+
+!**** *SUCLDP*   - INITIALIZE MODULE YOEMETH CONTROLLING *METHOX*
+
+!     PURPOSE.
+!     --------
+!           INITIALIZE YOEMETH
+
+!**   INTERFACE.
+!     ----------
+!        CALL *SUMETHOX* FROM *SUPHEC*
+!              --------        ------
+
+!        EXPLICIT ARGUMENTS :
+!        --------------------
+!        NONE
+
+!        IMPLICIT ARGUMENTS :
+!        --------------------
+!        MODULE YOEMETH
+
+!     METHOD.
+!     -------
+!        SEE DOCUMENTATION
+
+!     EXTERNALS.
+!     ----------
+!        NONE
+
+!     REFERENCE.
+!     ----------
+!        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE
+!     "INTEGRATED FORECASTING SYSTEM"
+
+!     AUTHOR.
+!     -------
+!        C.JAKOB   *ECMWF*
+
+!     MODIFICATIONS.
+!     --------------
+!        ORIGINAL : 98-04-07
+!        Modified : 02-01-29  A.Simmons: increase RQLIM from 3.75e-6
+!        M.Hamrud      01-Oct-2003 CY28 Cleaning
+!        D. Cugnet     24-Feb-2012 Adapted for LMDZ
+!     ------------------------------------------------------------------
+
+USE YOEMETH   , ONLY : RALPHA1 ,RALPHA2  ,RQLIM   ,&
+ & RPBOTOX,  RPBOTPH ,RPTOPOX  ,RPTOPPH ,&
+ & RALPHA3,  RLOGPPH  
+
+!*       1.    SET VALUES
+!              ----------
+
+IMPLICIT NONE
+RALPHA1=(19.*LOG(10.))/(LOG(20.)**4)
+RALPHA2=LOG(1.0/3.+0.01)
+RQLIM=4.25E-6
+RPBOTOX=10000.
+RPBOTPH=20.
+RPTOPOX=50.
+RPTOPPH=0.1
+RALPHA3=0.5*(LOG(100.)+RALPHA2)
+RLOGPPH=LOG(RPTOPPH/RPBOTPH)
+
+!     -----------------------------------------------------------------
+
+END SUBROUTINE SUMETHOX
+
+
Index: DZ6/trunk/libf/phylmd/suphel.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/suphel.F90	(revision 5267)
+++ 	(revision )
@@ -1,231 +1,0 @@
-
-! $Header$
-
-SUBROUTINE suphel
-
-  IMPLICIT NONE
-
-  include "YOMCST.h"
-  include "YOETHF.h"
-  ! IM cf. JLD
-  LOGICAL firstcall
-  SAVE firstcall
-  !$OMP THREADPRIVATE(firstcall)
-  DATA firstcall/.TRUE./
-
-  IF (firstcall) THEN
-    PRINT *, 'suphel initialise les constantes du GCM'
-    firstcall = .FALSE.
-  ELSE
-    PRINT *, 'suphel DEJA APPELE '
-    RETURN
-  END IF
-  ! -----------------------------------------------------------------
-
-  ! *       1.    DEFINE FUNDAMENTAL CONSTANTS.
-  ! -----------------------------
-
-  WRITE (UNIT=6, FMT='(''0*** Constants of the ICM   ***'')')
-  rpi = 2.*asin(1.)
-  rclum = 299792458.
-  rhpla = 6.6260755E-34
-  rkbol = 1.380658E-23
-  rnavo = 6.0221367E+23
-  WRITE (UNIT=6, FMT='('' *** Fundamental constants ***'')')
-  WRITE (UNIT=6, FMT='(''           PI = '',E13.7,'' -'')') rpi
-  WRITE (UNIT=6, FMT='(''            c = '',E13.7,''m s-1'')') rclum
-  WRITE (UNIT=6, FMT='(''            h = '',E13.7,''J s'')') rhpla
-  WRITE (UNIT=6, FMT='(''            K = '',E13.7,''J K-1'')') rkbol
-  WRITE (UNIT=6, FMT='(''            N = '',E13.7,''mol-1'')') rnavo
-
-  ! ----------------------------------------------------------------
-
-  ! *       2.    DEFINE ASTRONOMICAL CONSTANTS.
-  ! ------------------------------
-
-  rday = 86400.
-  rea = 149597870000.
-  repsm = 0.409093
-
-  rsiyea = 365.25*rday*2.*rpi/6.283076
-  rsiday = rday/(1.+rday/rsiyea)
-  romega = 2.*rpi/rsiday
-
-  ! exp1      R_ecc = 0.05
-  ! exp1      R_peri = 102.04
-  ! exp1      R_incl = 22.5
-  ! exp1      print*, 'Parametres orbitaux modifies'
-  ! ref      R_ecc = 0.016724
-  ! ref      R_peri = 102.04
-  ! ref      R_incl = 23.5
-
-  ! IM 161002 : pour avoir les ctes AMIP II
-  ! IM 161002   R_ecc = 0.016724
-  ! IM 161002   R_peri = 102.04
-  ! IM 161002   R_incl = 23.5
-  ! IM on mets R_ecc, R_peri, R_incl dans conf_phys.F90
-  ! R_ecc = 0.016715
-  ! R_peri = 102.7
-  ! R_incl = 23.441
-
-  WRITE (UNIT=6, FMT='('' *** Astronomical constants ***'')')
-  WRITE (UNIT=6, FMT='(''          day = '',E13.7,'' s'')') rday
-  WRITE (UNIT=6, FMT='('' half g. axis = '',E13.7,'' m'')') rea
-  WRITE (UNIT=6, FMT='('' mean anomaly = '',E13.7,'' -'')') repsm
-  WRITE (UNIT=6, FMT='('' sideral year = '',E13.7,'' s'')') rsiyea
-  WRITE (UNIT=6, FMT='(''  sideral day = '',E13.7,'' s'')') rsiday
-  WRITE (UNIT=6, FMT='(''        omega = '',E13.7,'' s-1'')') romega
-  ! write(unit=6,fmt='('' excentricite = '',e13.7,''-'')')R_ecc
-  ! write(unit=6,fmt='(''     equinoxe = '',e13.7,''-'')')R_peri
-  ! write(unit=6,fmt='(''  inclinaison = '',e13.7,''-'')')R_incl
-
-  ! ------------------------------------------------------------------
-
-  ! *       3.    DEFINE GEOIDE.
-  ! --------------
-
-  rg = 9.80665
-  ra = 6371229.
-  r1sa = sngl(1.D0/dble(ra))
-  WRITE (UNIT=6, FMT='('' ***         Geoide         ***'')')
-  WRITE (UNIT=6, FMT='(''      Gravity = '',E13.7,'' m s-2'')') rg
-  WRITE (UNIT=6, FMT='('' Earth radius = '',E13.7,'' m'')') ra
-  WRITE (UNIT=6, FMT='('' Inverse E.R. = '',E13.7,'' m'')') r1sa
-
-  ! -----------------------------------------------------------------
-
-  ! *       4.    DEFINE RADIATION CONSTANTS.
-  ! ---------------------------
-
-  ! z.x.li      RSIGMA=2. * RPI**5 * RKBOL**4 /(15.* RCLUM**2 * RHPLA**3)
-  rsigma = 2.*rpi**5*(rkbol/rhpla)**3*rkbol/rclum/rclum/15.
-  ! IM init. dans conf_phys.F90   RI0=1365.
-  WRITE (UNIT=6, FMT='('' ***        Radiation       ***'')')
-  WRITE (UNIT=6, FMT='('' Stefan-Bol.  = '',E13.7,'' W m-2 K-4'' &
-    &                                                         &
-    &         )') rsigma
-  ! IM init. dans conf_phys.F90   WRITE(UNIT=6,FMT='('' Solar const. =
-  ! '',E13.7,'' W m-2'')')
-  ! IM init. dans conf_phys.F90  S      RI0
-
-  ! -----------------------------------------------------------------
-
-  ! *       5.    DEFINE THERMODYNAMIC CONSTANTS, GAS PHASE.
-  ! ------------------------------------------
-
-  r = rnavo*rkbol
-  rmd = 28.9644
-  rmo3 = 47.9942
-  rmco2 = 44.011
-  rmch4 = 16.043
-  rmn2o = 44.013
-  rmcfc11 = 137.3686
-  rmcfc12 = 120.9140
-  rmc   = 12.0107
-  rmv = 18.0153
-  rd = 1000.*r/rmd
-  rv = 1000.*r/rmv
-  rcpd = 3.5*rd
-  rcvd = rcpd - rd
-  rcpv = 4.*rv
-  rcvv = rcpv - rv
-  rkappa = rd/rcpd
-  eps_w = rmv / rmd
-  retv = rv/rd - 1.
-  WRITE (UNIT=6, FMT='('' *** Thermodynamic, gas     ***'')')
-  WRITE (UNIT=6, FMT='('' Perfect gas  = '',e13.7,'' J mol-1 K-1'')') r
-  WRITE (UNIT=6, FMT='('' Dry air mass = '',e13.7,'' g mol-1'')') rmd
-  WRITE (UNIT=6, FMT='('' Ozone   mass = '',e13.7,'' g mol-1'')') rmo3
-  WRITE (UNIT=6, FMT='('' CO2     mass = '',e13.7,'' g mol-1'')') rmco2
-  WRITE (UNIT=6, FMT='('' C       mass = '',e13.7,'' g mol-1'')') rmc
-  WRITE (UNIT=6, FMT='('' CH4     mass = '',e13.7,'' g mol-1'')') rmch4
-  WRITE (UNIT=6, FMT='('' N2O     mass = '',e13.7,'' g mol-1'')') rmn2o
-  WRITE (UNIT=6, FMT='('' CFC11   mass = '',e13.7,'' g mol-1'')') rmcfc11
-  WRITE (UNIT=6, FMT='('' CFC12   mass = '',e13.7,'' g mol-1'')') rmcfc12
-  WRITE (UNIT=6, FMT='('' Vapour  mass = '',e13.7,'' g mol-1'')') rmv
-  WRITE (UNIT=6, FMT='('' Dry air cst. = '',e13.7,'' J K-1 kg-1'')') rd
-  WRITE (UNIT=6, FMT='('' Vapour  cst. = '',e13.7,'' J K-1 kg-1'')') rv
-  WRITE (UNIT=6, FMT='(''         Cpd  = '',e13.7,'' J K-1 kg-1'')') rcpd
-  WRITE (UNIT=6, FMT='(''         Cvd  = '',e13.7,'' J K-1 kg-1'')') rcvd
-  WRITE (UNIT=6, FMT='(''         Cpv  = '',e13.7,'' J K-1 kg-1'')') rcpv
-  WRITE (UNIT=6, FMT='(''         Cvv  = '',e13.7,'' J K-1 kg-1'')') rcvv
-  WRITE (UNIT=6, FMT='(''      Rd/Cpd  = '',e13.7)') rkappa
-  WRITE (UNIT=6, FMT='(''     Rv/Rd-1  = '',e13.7)') retv
-  WRITE (UNIT=6, FMT='(''        Rd/Rv = '',e13.7)') eps_w
-
-  ! ----------------------------------------------------------------
-
-  ! *       6.    DEFINE THERMODYNAMIC CONSTANTS, LIQUID PHASE.
-  ! ---------------------------------------------
-
-  rcw = rcpv
-  WRITE (UNIT=6, FMT='('' *** Thermodynamic, liquid  ***'')')
-  WRITE (UNIT=6, FMT='(''         Cw   = '',E13.7,'' J K-1 kg-1'')') rcw
-
-  ! ----------------------------------------------------------------
-
-  ! *       7.    DEFINE THERMODYNAMIC CONSTANTS, SOLID PHASE.
-  ! --------------------------------------------
-
-  rcs = rcpv
-  WRITE (UNIT=6, FMT='('' *** thermodynamic, solid   ***'')')
-  WRITE (UNIT=6, FMT='(''         Cs   = '',E13.7,'' J K-1 kg-1'')') rcs
-
-  ! ----------------------------------------------------------------
-
-  ! *       8.    DEFINE THERMODYNAMIC CONSTANTS, TRANSITION OF PHASE.
-  ! ----------------------------------------------------
-
-  rtt = 273.16
-  rlvtt = 2.5008E+6
-  rlstt = 2.8345E+6
-  rlmlt = rlstt - rlvtt
-  ratm = 100000.
-  WRITE (UNIT=6, FMT='('' *** Thermodynamic, trans.  ***'')')
-  WRITE (UNIT=6, FMT='('' Fusion point  = '',E13.7,'' K'')') rtt
-  WRITE (UNIT=6, FMT='(''        RLvTt  = '',E13.7,'' J kg-1'')') rlvtt
-  WRITE (UNIT=6, FMT='(''        RLsTt  = '',E13.7,'' J kg-1'')') rlstt
-  WRITE (UNIT=6, FMT='(''        RLMlt  = '',E13.7,'' J kg-1'')') rlmlt
-  WRITE (UNIT=6, FMT='('' Normal press. = '',E13.7,'' Pa'')') ratm
-  WRITE (UNIT=6, FMT='('' Latent heat :  '')')
-
-  ! ----------------------------------------------------------------
-
-  ! *       9.    SATURATED VAPOUR PRESSURE.
-  ! --------------------------
-
-  restt = 611.14   !--saturation water vapour pressure at triple point (Pa)
-  rgamw = (rcw-rcpv)/rv
-  rbetw = rlvtt/rv + rgamw*rtt
-  ralpw = log(restt) + rbetw/rtt + rgamw*log(rtt)
-  rgams = (rcs-rcpv)/rv
-  rbets = rlstt/rv + rgams*rtt
-  ralps = log(restt) + rbets/rtt + rgams*log(rtt)
-  rgamd = rgams - rgamw
-  rbetd = rbets - rbetw
-  ralpd = ralps - ralpw
-
-  ! ------------------------------------------------------------------
-
-  ! *       10.   CONSTANTS FOR THERMODYNAMICAL FUNCTIONS.
-  ! ----------------------------------------
-
-  rvtmp2 = rcpv/rcpd - 1.
-  rhoh2o = ratm/100.
-  r2es = restt*rd/rv
-  r3les = 17.269
-  r3ies = 21.875
-  r4les = 35.86
-  r4ies = 7.66
-  r5les = r3les*(rtt-r4les)
-  r5ies = r3ies*(rtt-r4ies)
-
-  ! ------------------------------------------------------------------
-
-  ! *       10.   CONSTANTS FOR METHANE OXIDATION AND PHOTOLYSIS.
-  ! -----------------------------------------------
-
-  CALL SUMETHOX()
-
-  RETURN
-END SUBROUTINE suphel
Index: /LMDZ6/trunk/libf/phylmd/suphel.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/suphel.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/suphel.f90	(revision 5268)
@@ -0,0 +1,231 @@
+
+! $Header$
+
+SUBROUTINE suphel
+
+  IMPLICIT NONE
+
+  include "YOMCST.h"
+  include "YOETHF.h"
+  ! IM cf. JLD
+  LOGICAL firstcall
+  SAVE firstcall
+  !$OMP THREADPRIVATE(firstcall)
+  DATA firstcall/.TRUE./
+
+  IF (firstcall) THEN
+    PRINT *, 'suphel initialise les constantes du GCM'
+    firstcall = .FALSE.
+  ELSE
+    PRINT *, 'suphel DEJA APPELE '
+    RETURN
+  END IF
+  ! -----------------------------------------------------------------
+
+  ! *       1.    DEFINE FUNDAMENTAL CONSTANTS.
+  ! -----------------------------
+
+  WRITE (UNIT=6, FMT='(''0*** Constants of the ICM   ***'')')
+  rpi = 2.*asin(1.)
+  rclum = 299792458.
+  rhpla = 6.6260755E-34
+  rkbol = 1.380658E-23
+  rnavo = 6.0221367E+23
+  WRITE (UNIT=6, FMT='('' *** Fundamental constants ***'')')
+  WRITE (UNIT=6, FMT='(''           PI = '',E13.7,'' -'')') rpi
+  WRITE (UNIT=6, FMT='(''            c = '',E13.7,''m s-1'')') rclum
+  WRITE (UNIT=6, FMT='(''            h = '',E13.7,''J s'')') rhpla
+  WRITE (UNIT=6, FMT='(''            K = '',E13.7,''J K-1'')') rkbol
+  WRITE (UNIT=6, FMT='(''            N = '',E13.7,''mol-1'')') rnavo
+
+  ! ----------------------------------------------------------------
+
+  ! *       2.    DEFINE ASTRONOMICAL CONSTANTS.
+  ! ------------------------------
+
+  rday = 86400.
+  rea = 149597870000.
+  repsm = 0.409093
+
+  rsiyea = 365.25*rday*2.*rpi/6.283076
+  rsiday = rday/(1.+rday/rsiyea)
+  romega = 2.*rpi/rsiday
+
+  ! exp1      R_ecc = 0.05
+  ! exp1      R_peri = 102.04
+  ! exp1      R_incl = 22.5
+  ! exp1      print*, 'Parametres orbitaux modifies'
+  ! ref      R_ecc = 0.016724
+  ! ref      R_peri = 102.04
+  ! ref      R_incl = 23.5
+
+  ! IM 161002 : pour avoir les ctes AMIP II
+  ! IM 161002   R_ecc = 0.016724
+  ! IM 161002   R_peri = 102.04
+  ! IM 161002   R_incl = 23.5
+  ! IM on mets R_ecc, R_peri, R_incl dans conf_phys.F90
+  ! R_ecc = 0.016715
+  ! R_peri = 102.7
+  ! R_incl = 23.441
+
+  WRITE (UNIT=6, FMT='('' *** Astronomical constants ***'')')
+  WRITE (UNIT=6, FMT='(''          day = '',E13.7,'' s'')') rday
+  WRITE (UNIT=6, FMT='('' half g. axis = '',E13.7,'' m'')') rea
+  WRITE (UNIT=6, FMT='('' mean anomaly = '',E13.7,'' -'')') repsm
+  WRITE (UNIT=6, FMT='('' sideral year = '',E13.7,'' s'')') rsiyea
+  WRITE (UNIT=6, FMT='(''  sideral day = '',E13.7,'' s'')') rsiday
+  WRITE (UNIT=6, FMT='(''        omega = '',E13.7,'' s-1'')') romega
+  ! write(unit=6,fmt='('' excentricite = '',e13.7,''-'')')R_ecc
+  ! write(unit=6,fmt='(''     equinoxe = '',e13.7,''-'')')R_peri
+  ! write(unit=6,fmt='(''  inclinaison = '',e13.7,''-'')')R_incl
+
+  ! ------------------------------------------------------------------
+
+  ! *       3.    DEFINE GEOIDE.
+  ! --------------
+
+  rg = 9.80665
+  ra = 6371229.
+  r1sa = sngl(1.D0/dble(ra))
+  WRITE (UNIT=6, FMT='('' ***         Geoide         ***'')')
+  WRITE (UNIT=6, FMT='(''      Gravity = '',E13.7,'' m s-2'')') rg
+  WRITE (UNIT=6, FMT='('' Earth radius = '',E13.7,'' m'')') ra
+  WRITE (UNIT=6, FMT='('' Inverse E.R. = '',E13.7,'' m'')') r1sa
+
+  ! -----------------------------------------------------------------
+
+  ! *       4.    DEFINE RADIATION CONSTANTS.
+  ! ---------------------------
+
+  ! z.x.li      RSIGMA=2. * RPI**5 * RKBOL**4 /(15.* RCLUM**2 * RHPLA**3)
+  rsigma = 2.*rpi**5*(rkbol/rhpla)**3*rkbol/rclum/rclum/15.
+  ! IM init. dans conf_phys.F90   RI0=1365.
+  WRITE (UNIT=6, FMT='('' ***        Radiation       ***'')')
+  WRITE (UNIT=6, FMT='('' Stefan-Bol.  = '',E13.7,'' W m-2 K-4'' &
+    &                                                         &
+    &         )') rsigma
+  ! IM init. dans conf_phys.F90   WRITE(UNIT=6,FMT='('' Solar const. =
+  ! '',E13.7,'' W m-2'')')
+  ! IM init. dans conf_phys.F90  S      RI0
+
+  ! -----------------------------------------------------------------
+
+  ! *       5.    DEFINE THERMODYNAMIC CONSTANTS, GAS PHASE.
+  ! ------------------------------------------
+
+  r = rnavo*rkbol
+  rmd = 28.9644
+  rmo3 = 47.9942
+  rmco2 = 44.011
+  rmch4 = 16.043
+  rmn2o = 44.013
+  rmcfc11 = 137.3686
+  rmcfc12 = 120.9140
+  rmc   = 12.0107
+  rmv = 18.0153
+  rd = 1000.*r/rmd
+  rv = 1000.*r/rmv
+  rcpd = 3.5*rd
+  rcvd = rcpd - rd
+  rcpv = 4.*rv
+  rcvv = rcpv - rv
+  rkappa = rd/rcpd
+  eps_w = rmv / rmd
+  retv = rv/rd - 1.
+  WRITE (UNIT=6, FMT='('' *** Thermodynamic, gas     ***'')')
+  WRITE (UNIT=6, FMT='('' Perfect gas  = '',e13.7,'' J mol-1 K-1'')') r
+  WRITE (UNIT=6, FMT='('' Dry air mass = '',e13.7,'' g mol-1'')') rmd
+  WRITE (UNIT=6, FMT='('' Ozone   mass = '',e13.7,'' g mol-1'')') rmo3
+  WRITE (UNIT=6, FMT='('' CO2     mass = '',e13.7,'' g mol-1'')') rmco2
+  WRITE (UNIT=6, FMT='('' C       mass = '',e13.7,'' g mol-1'')') rmc
+  WRITE (UNIT=6, FMT='('' CH4     mass = '',e13.7,'' g mol-1'')') rmch4
+  WRITE (UNIT=6, FMT='('' N2O     mass = '',e13.7,'' g mol-1'')') rmn2o
+  WRITE (UNIT=6, FMT='('' CFC11   mass = '',e13.7,'' g mol-1'')') rmcfc11
+  WRITE (UNIT=6, FMT='('' CFC12   mass = '',e13.7,'' g mol-1'')') rmcfc12
+  WRITE (UNIT=6, FMT='('' Vapour  mass = '',e13.7,'' g mol-1'')') rmv
+  WRITE (UNIT=6, FMT='('' Dry air cst. = '',e13.7,'' J K-1 kg-1'')') rd
+  WRITE (UNIT=6, FMT='('' Vapour  cst. = '',e13.7,'' J K-1 kg-1'')') rv
+  WRITE (UNIT=6, FMT='(''         Cpd  = '',e13.7,'' J K-1 kg-1'')') rcpd
+  WRITE (UNIT=6, FMT='(''         Cvd  = '',e13.7,'' J K-1 kg-1'')') rcvd
+  WRITE (UNIT=6, FMT='(''         Cpv  = '',e13.7,'' J K-1 kg-1'')') rcpv
+  WRITE (UNIT=6, FMT='(''         Cvv  = '',e13.7,'' J K-1 kg-1'')') rcvv
+  WRITE (UNIT=6, FMT='(''      Rd/Cpd  = '',e13.7)') rkappa
+  WRITE (UNIT=6, FMT='(''     Rv/Rd-1  = '',e13.7)') retv
+  WRITE (UNIT=6, FMT='(''        Rd/Rv = '',e13.7)') eps_w
+
+  ! ----------------------------------------------------------------
+
+  ! *       6.    DEFINE THERMODYNAMIC CONSTANTS, LIQUID PHASE.
+  ! ---------------------------------------------
+
+  rcw = rcpv
+  WRITE (UNIT=6, FMT='('' *** Thermodynamic, liquid  ***'')')
+  WRITE (UNIT=6, FMT='(''         Cw   = '',E13.7,'' J K-1 kg-1'')') rcw
+
+  ! ----------------------------------------------------------------
+
+  ! *       7.    DEFINE THERMODYNAMIC CONSTANTS, SOLID PHASE.
+  ! --------------------------------------------
+
+  rcs = rcpv
+  WRITE (UNIT=6, FMT='('' *** thermodynamic, solid   ***'')')
+  WRITE (UNIT=6, FMT='(''         Cs   = '',E13.7,'' J K-1 kg-1'')') rcs
+
+  ! ----------------------------------------------------------------
+
+  ! *       8.    DEFINE THERMODYNAMIC CONSTANTS, TRANSITION OF PHASE.
+  ! ----------------------------------------------------
+
+  rtt = 273.16
+  rlvtt = 2.5008E+6
+  rlstt = 2.8345E+6
+  rlmlt = rlstt - rlvtt
+  ratm = 100000.
+  WRITE (UNIT=6, FMT='('' *** Thermodynamic, trans.  ***'')')
+  WRITE (UNIT=6, FMT='('' Fusion point  = '',E13.7,'' K'')') rtt
+  WRITE (UNIT=6, FMT='(''        RLvTt  = '',E13.7,'' J kg-1'')') rlvtt
+  WRITE (UNIT=6, FMT='(''        RLsTt  = '',E13.7,'' J kg-1'')') rlstt
+  WRITE (UNIT=6, FMT='(''        RLMlt  = '',E13.7,'' J kg-1'')') rlmlt
+  WRITE (UNIT=6, FMT='('' Normal press. = '',E13.7,'' Pa'')') ratm
+  WRITE (UNIT=6, FMT='('' Latent heat :  '')')
+
+  ! ----------------------------------------------------------------
+
+  ! *       9.    SATURATED VAPOUR PRESSURE.
+  ! --------------------------
+
+  restt = 611.14   !--saturation water vapour pressure at triple point (Pa)
+  rgamw = (rcw-rcpv)/rv
+  rbetw = rlvtt/rv + rgamw*rtt
+  ralpw = log(restt) + rbetw/rtt + rgamw*log(rtt)
+  rgams = (rcs-rcpv)/rv
+  rbets = rlstt/rv + rgams*rtt
+  ralps = log(restt) + rbets/rtt + rgams*log(rtt)
+  rgamd = rgams - rgamw
+  rbetd = rbets - rbetw
+  ralpd = ralps - ralpw
+
+  ! ------------------------------------------------------------------
+
+  ! *       10.   CONSTANTS FOR THERMODYNAMICAL FUNCTIONS.
+  ! ----------------------------------------
+
+  rvtmp2 = rcpv/rcpd - 1.
+  rhoh2o = ratm/100.
+  r2es = restt*rd/rv
+  r3les = 17.269
+  r3ies = 21.875
+  r4les = 35.86
+  r4ies = 7.66
+  r5les = r3les*(rtt-r4les)
+  r5ies = r3ies*(rtt-r4ies)
+
+  ! ------------------------------------------------------------------
+
+  ! *       10.   CONSTANTS FOR METHANE OXIDATION AND PHOTOLYSIS.
+  ! -----------------------------------------------
+
+  CALL SUMETHOX()
+
+  RETURN
+END SUBROUTINE suphel
Index: DZ6/trunk/libf/phylmd/surface_data.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/surface_data.F90	(revision 5267)
+++ 	(revision )
@@ -1,67 +1,0 @@
-!
-! $Id$
-!
-MODULE surface_data
-
-  IMPLICIT NONE
-
-  REAL, PARAMETER        :: calice=1.0/(5.1444e+06*0.15)
-  REAL, PARAMETER        :: calsno=1./(2.3867e+06*.15)
-  
-  LOGICAL, SAVE          :: ok_veget      ! true for use of vegetation model ORCHIDEE
-  !$OMP THREADPRIVATE(ok_veget)
-
-  CHARACTER(len=10), SAVE :: type_veget   ! orchidee/y/bucket/n/betaclim
-  !$OMP THREADPRIVATE(type_veget)
-
-  CHARACTER(len=6), SAVE :: type_ocean    ! force/slab/couple
-  !$OMP THREADPRIVATE(type_ocean)
-
-  ! if type_ocean=couple : version_ocean=opa8 ou nemo
-  ! if type_ocean=slab   : version_ocean=sicOBS or sicINT or sicNO
-  CHARACTER(len=6), SAVE :: version_ocean 
-  !$OMP THREADPRIVATE(version_ocean)
-
-  ! Pas de temps couplage atm/oce (en secondes)
-  REAL, SAVE             :: t_coupl
-  !$OMP THREADPRIVATE(t_coupl)
-
-  ! FOR INLANDSIS:
-  !===============
- 
-   ! 1 for coupling with INLANDSIS
-   INTEGER, SAVE          :: landice_opt   ! 1 for coupling with INLANDSIS
-  !$OMP THREADPRIVATE(landice_opt)
-
-  ! temperature calculation options within the soil and at the surface
-   INTEGER, SAVE          :: iflag_tsurf_inlandsis,iflag_temp_inlandsis 
-   !$OMP THREADPRIVATE(iflag_tsurf_inlandsis,iflag_temp_inlandsis)
-
-  ! flags for albedo and roughness calc.
-   INTEGER, SAVE          :: iflag_albcalc,iflag_z0m_snow
-  !$OMP THREADPRIVATE(iflag_albcalc,iflag_z0m_snow)  
-
-  ! with or without snow module/ blowing snow, ascii outfile
-   LOGICAL, SAVE          :: SnoMod,BloMod,ok_outfor 
-  !$OMP THREADPRIVATE(SnoMod,BloMod,ok_outfor)    
-
-  ! activate slush, korlyakov snow density, RN z0h calc.
-   LOGICAL, SAVE          :: is_ok_slush,is_ok_density_kotlyakov,is_ok_z0h_rn
-  !$OMP THREADPRIVATE(is_ok_slush,is_ok_density_kotlyakov,is_ok_z0h_rn) 
-
-  ! activate detection snow/ice layers and option XF discrtet/option runoff AC
-   LOGICAL, SAVE          :: ok_zsn_ii,discret_xf,opt_runoff_ac
-  !$OMP THREADPRIVATE(ok_zsn_ii,discret_xf, opt_runoff_ac)
-
-  ! value of z0m snow when prescribed and albedo correction term
-   REAL, SAVE             :: prescribed_z0m_snow,correc_alb
-  !$OMP THREADPRIVATE(prescribed_z0m_snow, correc_alb)
-
-  ! value of sphericity [0-99] and snow grain size [e-4m] for polar buffer snow
-  ! layer
-   REAL, SAVE             :: buf_sph_pol,buf_siz_pol
-  !$OMP THREADPRIVATE(buf_sph_pol,buf_siz_pol)
-
-
-
-END MODULE surface_data
Index: /LMDZ6/trunk/libf/phylmd/surface_data.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/surface_data.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/surface_data.f90	(revision 5268)
@@ -0,0 +1,67 @@
+!
+! $Id$
+!
+MODULE surface_data
+
+  IMPLICIT NONE
+
+  REAL, PARAMETER        :: calice=1.0/(5.1444e+06*0.15)
+  REAL, PARAMETER        :: calsno=1./(2.3867e+06*.15)
+  
+  LOGICAL, SAVE          :: ok_veget      ! true for use of vegetation model ORCHIDEE
+  !$OMP THREADPRIVATE(ok_veget)
+
+  CHARACTER(len=10), SAVE :: type_veget   ! orchidee/y/bucket/n/betaclim
+  !$OMP THREADPRIVATE(type_veget)
+
+  CHARACTER(len=6), SAVE :: type_ocean    ! force/slab/couple
+  !$OMP THREADPRIVATE(type_ocean)
+
+  ! if type_ocean=couple : version_ocean=opa8 ou nemo
+  ! if type_ocean=slab   : version_ocean=sicOBS or sicINT or sicNO
+  CHARACTER(len=6), SAVE :: version_ocean 
+  !$OMP THREADPRIVATE(version_ocean)
+
+  ! Pas de temps couplage atm/oce (en secondes)
+  REAL, SAVE             :: t_coupl
+  !$OMP THREADPRIVATE(t_coupl)
+
+  ! FOR INLANDSIS:
+  !===============
+ 
+   ! 1 for coupling with INLANDSIS
+   INTEGER, SAVE          :: landice_opt   ! 1 for coupling with INLANDSIS
+  !$OMP THREADPRIVATE(landice_opt)
+
+  ! temperature calculation options within the soil and at the surface
+   INTEGER, SAVE          :: iflag_tsurf_inlandsis,iflag_temp_inlandsis 
+   !$OMP THREADPRIVATE(iflag_tsurf_inlandsis,iflag_temp_inlandsis)
+
+  ! flags for albedo and roughness calc.
+   INTEGER, SAVE          :: iflag_albcalc,iflag_z0m_snow
+  !$OMP THREADPRIVATE(iflag_albcalc,iflag_z0m_snow)  
+
+  ! with or without snow module/ blowing snow, ascii outfile
+   LOGICAL, SAVE          :: SnoMod,BloMod,ok_outfor 
+  !$OMP THREADPRIVATE(SnoMod,BloMod,ok_outfor)    
+
+  ! activate slush, korlyakov snow density, RN z0h calc.
+   LOGICAL, SAVE          :: is_ok_slush,is_ok_density_kotlyakov,is_ok_z0h_rn
+  !$OMP THREADPRIVATE(is_ok_slush,is_ok_density_kotlyakov,is_ok_z0h_rn) 
+
+  ! activate detection snow/ice layers and option XF discrtet/option runoff AC
+   LOGICAL, SAVE          :: ok_zsn_ii,discret_xf,opt_runoff_ac
+  !$OMP THREADPRIVATE(ok_zsn_ii,discret_xf, opt_runoff_ac)
+
+  ! value of z0m snow when prescribed and albedo correction term
+   REAL, SAVE             :: prescribed_z0m_snow,correc_alb
+  !$OMP THREADPRIVATE(prescribed_z0m_snow, correc_alb)
+
+  ! value of sphericity [0-99] and snow grain size [e-4m] for polar buffer snow
+  ! layer
+   REAL, SAVE             :: buf_sph_pol,buf_siz_pol
+  !$OMP THREADPRIVATE(buf_sph_pol,buf_siz_pol)
+
+
+
+END MODULE surface_data
Index: DZ6/trunk/libf/phylmd/sw_aeroAR4.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/sw_aeroAR4.F90	(revision 5267)
+++ 	(revision )
@@ -1,641 +1,0 @@
-!
-! $Id$
-!
-SUBROUTINE SW_AEROAR4(PSCT, PRMU0, PFRAC, &
-     PPMB, PDP, &
-     PPSOL, PALBD, PALBP,&
-     PTAVE, PWV, PQS, POZON, PAER,&
-     PCLDSW, PTAU, POMEGA, PCG,&
-     PHEAT, PHEAT0,&
-     PALBPLA,PTOPSW,PSOLSW,PTOPSW0,PSOLSW0,&
-     ZFSUP,ZFSDN,ZFSUP0,ZFSDN0,&
-     tauaero, pizaero, cgaero,&
-     PTAUA, POMEGAA,&
-     PTOPSWADAERO,PSOLSWADAERO,&
-     PTOPSWAD0AERO,PSOLSWAD0AERO,&
-     PTOPSWAIAERO,PSOLSWAIAERO,&
-     PTOPSWAERO,PTOPSW0AERO,&
-     PSOLSWAERO,PSOLSW0AERO,&
-     PTOPSWCFAERO,PSOLSWCFAERO,&
-     ok_ade, ok_aie, flag_aerosol, flag_aerosol_strat )
-
-  USE dimphy
-  USE phys_output_mod, ONLY : swaero_diag
-  USE print_control_mod, ONLY: lunout
-  USE aero_mod, ONLY : naero_grp
-  IMPLICIT NONE
-
-  INCLUDE "YOMCST.h"
-  INCLUDE "clesphys.h"
-  !
-  !     ------------------------------------------------------------------
-  !
-  !     PURPOSE.
-  !     --------
-  !
-  !          THIS ROUTINE COMPUTES THE SHORTWAVE RADIATION FLUXES IN TWO
-  !     SPECTRAL INTERVALS FOLLOWING FOUQUART AND BONNEL (1980).
-  !
-  !     METHOD.
-  !     -------
-  !
-  !          1. COMPUTES ABSORBER AMOUNTS                 (SWU)
-  !          2. COMPUTES FLUXES IN 1ST SPECTRAL INTERVAL  (SW1S)
-  !          3. COMPUTES FLUXES IN 2ND SPECTRAL INTERVAL  (SW2S)
-  !
-  !     REFERENCE.
-  !     ----------
-  !
-  !        SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT
-  !        DOCUMENTATION, AND FOUQUART AND BONNEL (1980)
-  !
-  !     AUTHOR.
-  !     -------
-  !        JEAN-JACQUES MORCRETTE  *ECMWF*
-  !
-  !     MODIFICATIONS.
-  !     --------------
-  !        ORIGINAL : 89-07-14
-  !        1995-01-01  J.-J. MORCRETTE  Direct/Diffuse Albedo
-  !        2003-11-27  J. QUAAS Introduce aerosol forcings (based on BOUCHER)
-  !        2009-04     A. COZIC - C.DEANDREIS Indroduce NAT/BC/POM/DUST/SS aerosol forcing
-  !        2012-09     O. BOUCHER - reorganise aerosol cases with ok_ade, ok_aie, flag_aerosol
-  !     ------------------------------------------------------------------
-  !
-  !* ARGUMENTS:
-  !
-  REAL(KIND=8) PSCT  ! constante solaire (valeur conseillee: 1370)
-
-  REAL(KIND=8) PPSOL(KDLON)        ! SURFACE PRESSURE (PA)
-  REAL(KIND=8) PDP(KDLON,KFLEV)    ! LAYER THICKNESS (PA)
-  REAL(KIND=8) PPMB(KDLON,KFLEV+1) ! HALF-LEVEL PRESSURE (MB)
-
-  REAL(KIND=8) PRMU0(KDLON)  ! COSINE OF ZENITHAL ANGLE
-  REAL(KIND=8) PFRAC(KDLON)  ! fraction de la journee
-
-  REAL(KIND=8) PTAVE(KDLON,KFLEV)  ! LAYER TEMPERATURE (K)
-  REAL(KIND=8) PWV(KDLON,KFLEV)    ! SPECIFI! HUMIDITY (KG/KG)
-  REAL(KIND=8) PQS(KDLON,KFLEV)    ! SATURATED WATER VAPOUR (KG/KG)
-  REAL(KIND=8) POZON(KDLON,KFLEV)  ! OZONE CONCENTRATION (KG/KG)
-  REAL(KIND=8) PAER(KDLON,KFLEV,5) ! AEROSOLS' OPTICAL THICKNESS
-
-  REAL(KIND=8) PALBD(KDLON,2)  ! albedo du sol (lumiere diffuse)
-  REAL(KIND=8) PALBP(KDLON,2)  ! albedo du sol (lumiere parallele)
-
-  REAL(KIND=8) PCLDSW(KDLON,KFLEV)    ! CLOUD FRACTION
-  REAL(KIND=8) PTAU(KDLON,2,KFLEV)    ! CLOUD OPTICAL THICKNESS (pre-industrial value)
-  REAL(KIND=8) PCG(KDLON,2,KFLEV)     ! ASYMETRY FACTOR
-  REAL(KIND=8) POMEGA(KDLON,2,KFLEV)  ! SINGLE SCATTERING ALBEDO
-
-  REAL(KIND=8) PHEAT(KDLON,KFLEV) ! SHORTWAVE HEATING (K/DAY)
-  REAL(KIND=8) PHEAT0(KDLON,KFLEV)! SHORTWAVE HEATING (K/DAY) clear-sky
-  REAL(KIND=8) PALBPLA(KDLON)     ! PLANETARY ALBEDO
-  REAL(KIND=8) PTOPSW(KDLON)      ! SHORTWAVE FLUX AT T.O.A.
-  REAL(KIND=8) PSOLSW(KDLON)      ! SHORTWAVE FLUX AT SURFACE
-  REAL(KIND=8) PTOPSW0(KDLON)     ! SHORTWAVE FLUX AT T.O.A. (CLEAR-SKY)
-  REAL(KIND=8) PSOLSW0(KDLON)     ! SHORTWAVE FLUX AT SURFACE (CLEAR-SKY)
-  !
-  !* LOCAL VARIABLES:
-  !
-  real, parameter:: dobson_u = 2.1415e-05 ! Dobson unit, in kg m-2
-
-  REAL(KIND=8) ZOZ(KDLON,KFLEV)
-  ! column-density of ozone in layer, in kilo-Dobsons
-
-  REAL(KIND=8) ZAKI(KDLON,2)     
-  REAL(KIND=8) ZCLD(KDLON,KFLEV)
-  REAL(KIND=8) ZCLEAR(KDLON) 
-  REAL(KIND=8) ZDSIG(KDLON,KFLEV)
-  REAL(KIND=8) ZFACT(KDLON)
-  REAL(KIND=8) ZFD(KDLON,KFLEV+1)
-  REAL(KIND=8) ZFDOWN(KDLON,KFLEV+1)
-  REAL(KIND=8) ZFU(KDLON,KFLEV+1)
-  REAL(KIND=8) ZFUP(KDLON,KFLEV+1)
-  REAL(KIND=8) ZRMU(KDLON)
-  REAL(KIND=8) ZSEC(KDLON)
-  REAL(KIND=8) ZUD(KDLON,5,KFLEV+1)
-  REAL(KIND=8) ZCLDSW0(KDLON,KFLEV)
-
-  REAL(KIND=8) ZFSUP(KDLON,KFLEV+1)
-  REAL(KIND=8) ZFSDN(KDLON,KFLEV+1)
-  REAL(KIND=8) ZFSUP0(KDLON,KFLEV+1)
-  REAL(KIND=8) ZFSDN0(KDLON,KFLEV+1)
-
-  INTEGER inu, jl, jk, i, k, kpl1
-
-  INTEGER swpas  ! Every swpas steps, sw is calculated
-  PARAMETER(swpas=1)
-
-  INTEGER, SAVE :: itapsw = 0
-  !$OMP THREADPRIVATE(itapsw)
-  LOGICAL, SAVE :: appel1er = .TRUE.
-  !$OMP THREADPRIVATE(appel1er)
-  LOGICAL, SAVE :: initialized = .FALSE.
-  !$OMP THREADPRIVATE(initialized)
-
-  !jq-local flag introduced for aerosol forcings
-  REAL(KIND=8), SAVE :: flag_aer
-  !$OMP THREADPRIVATE(flag_aer)
-
-  LOGICAL ok_ade, ok_aie    ! use aerosol forcings or not?
-  INTEGER flag_aerosol_strat ! use stratospehric aerosols
-  INTEGER flag_aerosol      ! global flag for aerosol 0 (no aerosol) or 1-5 (aerosols)
-  REAL(KIND=8) tauaero(kdlon,kflev,naero_grp,2)  ! aerosol optical properties
-  REAL(KIND=8) pizaero(kdlon,kflev,naero_grp,2)  ! (see aeropt.F)
-  REAL(KIND=8) cgaero(kdlon,kflev,naero_grp,2)   ! -"-
-  REAL(KIND=8) PTAUA(KDLON,2,KFLEV)    ! CLOUD OPTICAL THICKNESS (present-day value)
-  REAL(KIND=8) POMEGAA(KDLON,2,KFLEV)  ! SINGLE SCATTERING ALBEDO
-  REAL(KIND=8) PTOPSWADAERO(KDLON)     ! SHORTWAVE FLUX AT T.O.A.(+AEROSOL DIR)
-  REAL(KIND=8) PSOLSWADAERO(KDLON)     ! SHORTWAVE FLUX AT SURFACE(+AEROSOL DIR)
-  REAL(KIND=8) PTOPSWAD0AERO(KDLON)    ! SHORTWAVE FLUX AT T.O.A.(+AEROSOL DIR)
-  REAL(KIND=8) PSOLSWAD0AERO(KDLON)    ! SHORTWAVE FLUX AT SURFACE(+AEROSOL DIR)
-  REAL(KIND=8) PTOPSWAIAERO(KDLON)     ! SHORTWAVE FLUX AT T.O.A.(+AEROSOL IND)
-  REAL(KIND=8) PSOLSWAIAERO(KDLON)     ! SHORTWAVE FLUX AT SURFACE(+AEROSOL IND)
-  REAL(KIND=8) PTOPSWAERO(KDLON,9)     ! SW TOA AS DRF nat & ant 
-  REAL(KIND=8) PTOPSW0AERO(KDLON,9)    ! SW SRF AS DRF nat & ant 
-  REAL(KIND=8) PSOLSWAERO(KDLON,9)     ! SW TOA CS DRF nat & ant
-  REAL(KIND=8) PSOLSW0AERO(KDLON,9)    ! SW SRF CS DRF nat & ant
-  REAL(KIND=8) PTOPSWCFAERO(KDLON,3)   !  SW TOA AS cloudRF nat & ant 
-  REAL(KIND=8) PSOLSWCFAERO(KDLON,3)   !  SW SRF AS cloudRF nat & ant 
-
-  !jq - Fluxes including aerosol effects
-  REAL(KIND=8),ALLOCATABLE,SAVE :: ZFSUPAD_AERO(:,:)
-  !$OMP THREADPRIVATE(ZFSUPAD_AERO)
-  REAL(KIND=8),ALLOCATABLE,SAVE :: ZFSDNAD_AERO(:,:)
-  !$OMP THREADPRIVATE(ZFSDNAD_AERO)
-  !jq - Fluxes including aerosol effects
-  REAL(KIND=8),ALLOCATABLE,SAVE :: ZFSUPAD0_AERO(:,:)
-  !$OMP THREADPRIVATE(ZFSUPAD0_AERO)
-  REAL(KIND=8),ALLOCATABLE,SAVE :: ZFSDNAD0_AERO(:,:)
-  !$OMP THREADPRIVATE(ZFSDNAD0_AERO)
-  REAL(KIND=8),ALLOCATABLE,SAVE :: ZFSUPAI_AERO(:,:)
-  !$OMP THREADPRIVATE(ZFSUPAI_AERO)
-  REAL(KIND=8),ALLOCATABLE,SAVE :: ZFSDNAI_AERO(:,:)
-  !$OMP THREADPRIVATE(ZFSDNAI_AERO)
-  REAL(KIND=8),ALLOCATABLE,SAVE ::  ZFSUP_AERO(:,:,:)
-  !$OMP THREADPRIVATE(ZFSUP_AERO)
-  REAL(KIND=8),ALLOCATABLE,SAVE ::  ZFSDN_AERO(:,:,:)
-  !$OMP THREADPRIVATE(ZFSDN_AERO)
-  REAL(KIND=8),ALLOCATABLE,SAVE ::  ZFSUP0_AERO(:,:,:)
-  !$OMP THREADPRIVATE(ZFSUP0_AERO)
-  REAL(KIND=8),ALLOCATABLE,SAVE ::  ZFSDN0_AERO(:,:,:)
-  !$OMP THREADPRIVATE(ZFSDN0_AERO)
-
-! Key to define the aerosol effect acting on climate
-! OB: AEROSOLFEEDBACK_ACTIVE is now a LOGICAL
-! TRUE: fluxes use natural and/or anthropogenic aerosols according to ok_ade and ok_aie, DEFAULT
-! FALSE: fluxes use no aerosols (case 1)
-
-  LOGICAL,SAVE :: AEROSOLFEEDBACK_ACTIVE = .TRUE.
-!$OMP THREADPRIVATE(AEROSOLFEEDBACK_ACTIVE)  
-
-      CHARACTER (LEN=20) :: modname='sw_aeroAR4'
-      CHARACTER (LEN=80) :: abort_message
-
-  IF(.NOT.initialized) THEN
-     flag_aer=0.
-     initialized=.TRUE.
-     ALLOCATE(ZFSUPAD_AERO(KDLON,KFLEV+1))
-     ALLOCATE(ZFSDNAD_AERO(KDLON,KFLEV+1))
-     ALLOCATE(ZFSUPAD0_AERO(KDLON,KFLEV+1))
-     ALLOCATE(ZFSDNAD0_AERO(KDLON,KFLEV+1))
-     ALLOCATE(ZFSUPAI_AERO(KDLON,KFLEV+1))
-     ALLOCATE(ZFSDNAI_AERO(KDLON,KFLEV+1))
-!-OB decrease size of these arrays to what is needed
-!                | direct effect 
-!ind effect      | no aerosol   natural  total
-!natural (PTAU)  |   1            3       2     --ZFSUP/ZFSDN
-!total (PTAUA)   |                5       4     --ZFSUP/ZFSDN
-!no cloud        |   1            3       2     --ZFSUP0/ZFSDN0
-! so we need which case when ? 
-! ok_ade and ok_aie = 4-5, 4-2 and 2 
-! ok_ade and not ok_aie = 2-3 and 2 
-! not ok_ade and ok_aie = 5-3 and 5 
-! not ok_ade and not ok_aie = 3 
-! therefore the cases have the folliwng switches 
-! 3 = not ok_ade or not ok_aie 
-! 4 = ok_ade and ok_aie 
-! 2 = ok_ade 
-! 5 = ok_aie 
-     ALLOCATE(ZFSUP_AERO (KDLON,KFLEV+1,5))
-     ALLOCATE(ZFSDN_AERO (KDLON,KFLEV+1,5))
-     ALLOCATE(ZFSUP0_AERO(KDLON,KFLEV+1,3))
-     ALLOCATE(ZFSDN0_AERO(KDLON,KFLEV+1,3))
-! end OB modif
-     ZFSUPAD_AERO(:,:)=0.
-     ZFSDNAD_AERO(:,:)=0.
-     ZFSUPAD0_AERO(:,:)=0.
-     ZFSDNAD0_AERO(:,:)=0.
-     ZFSUPAI_AERO(:,:)=0.
-     ZFSDNAI_AERO(:,:)=0.
-     ZFSUP_AERO (:,:,:)=0.
-     ZFSDN_AERO (:,:,:)=0.
-     ZFSUP0_AERO(:,:,:)=0.
-     ZFSDN0_AERO(:,:,:)=0.
-  ENDIF
-
-  IF (appel1er) THEN
-     WRITE(lunout,*)'SW calling frequency : ', swpas
-     WRITE(lunout,*) "   In general, it should be 1"
-     appel1er = .FALSE.
-  ENDIF
-  !     ------------------------------------------------------------------
-  IF (MOD(itapsw,swpas).EQ.0) THEN
-
-     DO JK = 1 , KFLEV
-        DO JL = 1, KDLON
-           ZCLDSW0(JL,JK) = 0.0
-           ZOZ(JL,JK) = POZON(JL,JK)*46.6968/RG &
-                *PDP(JL,JK)*(101325.0/PPSOL(JL))
-        ENDDO
-     ENDDO
-
-! clear sky with no aerosols at all is computed IF ACTIVEFEEDBACK_ACTIVE is false or for extended diag
-     IF ( swaero_diag .or. .not. AEROSOLFEEDBACK_ACTIVE .OR. flag_aerosol .EQ. 0 ) THEN    
-
-     ! clear-sky: zero aerosol effect
-     flag_aer=0.0
-     CALL SWU_LMDAR4(PSCT,ZCLDSW0,PPMB,PPSOL,&
-          PRMU0,PFRAC,PTAVE,PWV,&
-          ZAKI,ZCLD,ZCLEAR,ZDSIG,ZFACT,ZRMU,ZSEC,ZUD)
-     INU = 1
-     CALL SW1S_LMDAR4(INU,PAER, flag_aer, &
-          tauaero(:,:,1,:), pizaero(:,:,1,:), cgaero(:,:,1,:),&
-          PALBD, PALBP, PCG, ZCLD, ZCLEAR, ZCLDSW0,&
-          ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,&
-          ZFD, ZFU)
-     INU = 2
-     CALL SW2S_LMDAR4(INU, PAER, flag_aer, &
-          tauaero(:,:,1,:), pizaero(:,:,1,:), cgaero(:,:,1,:),&
-          ZAKI, PALBD, PALBP, PCG, ZCLD, ZCLEAR, ZCLDSW0,&
-          ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,&
-          PWV, PQS,&
-          ZFDOWN, ZFUP)
-     DO JK = 1 , KFLEV+1
-        DO JL = 1, KDLON
-           ZFSUP0_AERO(JL,JK,1) = (ZFUP(JL,JK)   + ZFU(JL,JK)) * ZFACT(JL)
-           ZFSDN0_AERO(JL,JK,1) = (ZFDOWN(JL,JK) + ZFD(JL,JK)) * ZFACT(JL)
-        ENDDO
-     ENDDO
-     ENDIF ! swaero_diag .or. .not. AEROSOLFEEDBACK_ACTIVE
-
-! cloudy sky with no aerosols at all is either computed IF no indirect effect is asked for, or for extended diag
-     IF ( swaero_diag .or. .not. AEROSOLFEEDBACK_ACTIVE .OR. flag_aerosol .EQ. 0 ) THEN    
-     ! cloudy-sky: zero aerosol effect
-     flag_aer=0.0
-     CALL SWU_LMDAR4(PSCT,PCLDSW,PPMB,PPSOL,&
-          PRMU0,PFRAC,PTAVE,PWV,&
-          ZAKI,ZCLD,ZCLEAR,ZDSIG,ZFACT,ZRMU,ZSEC,ZUD)
-     INU = 1
-     CALL SW1S_LMDAR4(INU, PAER, flag_aer, &
-          tauaero(:,:,1,:), pizaero(:,:,1,:), cgaero(:,:,1,:),&
-          PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,&
-          ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,&
-          ZFD, ZFU)
-     INU = 2
-     CALL SW2S_LMDAR4(INU, PAER, flag_aer, &
-          tauaero(:,:,1,:), pizaero(:,:,1,:), cgaero(:,:,1,:),&
-          ZAKI, PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,&
-          ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,&
-          PWV, PQS,&
-          ZFDOWN, ZFUP)
-
-     DO JK = 1 , KFLEV+1
-        DO JL = 1, KDLON
-           ZFSUP_AERO(JL,JK,1) = (ZFUP(JL,JK)   + ZFU(JL,JK)) * ZFACT(JL)
-           ZFSDN_AERO(JL,JK,1) = (ZFDOWN(JL,JK) + ZFD(JL,JK)) * ZFACT(JL)
-        ENDDO
-     ENDDO
-     ENDIF ! swaero_diag .or. .not. AEROSOLFEEDBACK_ACTIVE
-
-     IF (flag_aerosol.GT.0 .OR. flag_aerosol_strat.GT.0) THEN
-
-     IF (ok_ade.and.swaero_diag .or. .not. ok_ade) THEN
-
-        ! clear sky direct effect natural aerosol
-        ! CAS AER (3)
-        flag_aer=1.0
-        CALL SWU_LMDAR4(PSCT,ZCLDSW0,PPMB,PPSOL,&
-             PRMU0,PFRAC,PTAVE,PWV,&
-             ZAKI,ZCLD,ZCLEAR,ZDSIG,ZFACT,ZRMU,ZSEC,ZUD)
-        INU = 1
-        CALL SW1S_LMDAR4(INU, PAER, flag_aer,&
-             tauaero(:,:,3,:), pizaero(:,:,3,:), cgaero(:,:,3,:),&
-             PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,&
-             ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,&
-             ZFD, ZFU)
-        INU = 2
-        CALL SW2S_LMDAR4(INU, PAER, flag_aer,&
-             tauaero(:,:,3,:), pizaero(:,:,3,:), cgaero(:,:,3,:),&
-             ZAKI, PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,&
-             ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,&
-             PWV, PQS,&
-             ZFDOWN, ZFUP)
-
-        DO JK = 1 , KFLEV+1
-           DO JL = 1, KDLON
-              ZFSUP0_AERO(JL,JK,3) = (ZFUP(JL,JK)   + ZFU(JL,JK)) * ZFACT(JL)
-              ZFSDN0_AERO(JL,JK,3) = (ZFDOWN(JL,JK) + ZFD(JL,JK)) * ZFACT(JL)
-           ENDDO
-        ENDDO
-     ENDIF !--end not swaero_diag or not ok_ade
-
-     IF (ok_ade) THEN
-
-        ! clear sky direct effect of total aerosol
-        ! CAS AER (2)
-        flag_aer=1.0
-        CALL SWU_LMDAR4(PSCT,ZCLDSW0,PPMB,PPSOL,&
-             PRMU0,PFRAC,PTAVE,PWV,&
-             ZAKI,ZCLD,ZCLEAR,ZDSIG,ZFACT,ZRMU,ZSEC,ZUD)
-        INU = 1
-        CALL SW1S_LMDAR4(INU, PAER, flag_aer,&
-             tauaero(:,:,2,:), pizaero(:,:,2,:), cgaero(:,:,2,:),&
-             PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,&
-             ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,&
-             ZFD, ZFU)
-        INU = 2
-        CALL SW2S_LMDAR4(INU, PAER, flag_aer,&
-             tauaero(:,:,2,:), pizaero(:,:,2,:), cgaero(:,:,2,:),&
-             ZAKI, PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,&
-             ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,&
-             PWV, PQS,&
-             ZFDOWN, ZFUP)
-
-        DO JK = 1 , KFLEV+1
-           DO JL = 1, KDLON
-              ZFSUP0_AERO(JL,JK,2) = (ZFUP(JL,JK)   + ZFU(JL,JK)) * ZFACT(JL) 
-              ZFSDN0_AERO(JL,JK,2) = (ZFDOWN(JL,JK) + ZFD(JL,JK)) * ZFACT(JL) 
-           ENDDO
-        ENDDO
-
-        ! cloudy-sky with natural aerosols for indirect effect 
-        ! but total aerosols for direct effect
-        ! PTAU
-        ! CAS AER (2)
-        flag_aer=1.0
-        CALL SWU_LMDAR4(PSCT,PCLDSW,PPMB,PPSOL,&
-             PRMU0,PFRAC,PTAVE,PWV,&
-             ZAKI,ZCLD,ZCLEAR,ZDSIG,ZFACT,ZRMU,ZSEC,ZUD)
-        INU = 1
-        CALL SW1S_LMDAR4(INU, PAER, flag_aer,&
-             tauaero(:,:,2,:), pizaero(:,:,2,:), cgaero(:,:,2,:),&
-             PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,&
-             ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,&
-             ZFD, ZFU)
-        INU = 2
-        CALL SW2S_LMDAR4(INU, PAER, flag_aer,&
-             tauaero(:,:,2,:), pizaero(:,:,2,:), cgaero(:,:,2,:),&
-             ZAKI, PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,&
-             ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,&
-             PWV, PQS,&
-             ZFDOWN, ZFUP)
-
-        DO JK = 1 , KFLEV+1
-           DO JL = 1, KDLON
-              ZFSUP_AERO(JL,JK,2) = (ZFUP(JL,JK)   + ZFU(JL,JK)) * ZFACT(JL) 
-              ZFSDN_AERO(JL,JK,2) = (ZFDOWN(JL,JK) + ZFD(JL,JK)) * ZFACT(JL) 
-           ENDDO
-        ENDDO
-
-     ENDIF !-end ok_ade
-
-     IF ( .not. ok_ade .or. .not. ok_aie ) THEN
-
-        ! cloudy-sky with natural aerosols for indirect effect 
-        ! and natural aerosols for direct effect
-        ! PTAU
-        ! CAS AER (3)
-        ! cloudy-sky direct effect natural aerosol
-        flag_aer=1.0
-        CALL SWU_LMDAR4(PSCT,PCLDSW,PPMB,PPSOL,&
-             PRMU0,PFRAC,PTAVE,PWV,&
-             ZAKI,ZCLD,ZCLEAR,ZDSIG,ZFACT,ZRMU,ZSEC,ZUD)
-        INU = 1
-        CALL SW1S_LMDAR4(INU, PAER, flag_aer,&
-             tauaero(:,:,3,:), pizaero(:,:,3,:), cgaero(:,:,3,:),&
-             PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,&
-             ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,&
-             ZFD, ZFU)
-        INU = 2
-        CALL SW2S_LMDAR4(INU, PAER, flag_aer,&
-             tauaero(:,:,3,:), pizaero(:,:,3,:), cgaero(:,:,3,:),&
-             ZAKI, PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,&
-             ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,&
-             PWV, PQS,&
-             ZFDOWN, ZFUP)
-
-        DO JK = 1 , KFLEV+1
-           DO JL = 1, KDLON
-              ZFSUP_AERO(JL,JK,3) = (ZFUP(JL,JK)   + ZFU(JL,JK)) * ZFACT(JL)
-              ZFSDN_AERO(JL,JK,3) = (ZFDOWN(JL,JK) + ZFD(JL,JK)) * ZFACT(JL)
-           ENDDO
-        ENDDO
-
-     ENDIF  !--true/false or false/true
-
-     IF (ok_ade .and. ok_aie) THEN
-
-        ! cloudy-sky with total aerosols for indirect effect 
-        ! and total aerosols for direct effect
-        ! PTAUA
-        ! CAS AER (2)
-        flag_aer=1.0
-        CALL SWU_LMDAR4(PSCT,PCLDSW,PPMB,PPSOL,&
-             PRMU0,PFRAC,PTAVE,PWV,&
-             ZAKI,ZCLD,ZCLEAR,ZDSIG,ZFACT,ZRMU,ZSEC,ZUD)
-        INU = 1
-        CALL SW1S_LMDAR4(INU, PAER, flag_aer,&
-             tauaero(:,:,2,:), pizaero(:,:,2,:), cgaero(:,:,2,:),&
-             PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,&
-             ZDSIG, POMEGAA, ZOZ, ZRMU, ZSEC, PTAUA, ZUD,&
-             ZFD, ZFU)
-        INU = 2
-        CALL SW2S_LMDAR4(INU, PAER, flag_aer,&
-             tauaero(:,:,2,:), pizaero(:,:,2,:), cgaero(:,:,2,:),&
-             ZAKI, PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,&
-             ZDSIG, POMEGAA, ZOZ, ZRMU, ZSEC, PTAUA, ZUD,&
-             PWV, PQS,&
-             ZFDOWN, ZFUP)
-
-        DO JK = 1 , KFLEV+1
-           DO JL = 1, KDLON
-              ZFSUP_AERO(JL,JK,4) = (ZFUP(JL,JK)   + ZFU(JL,JK)) * ZFACT(JL)
-              ZFSDN_AERO(JL,JK,4) = (ZFDOWN(JL,JK) + ZFD(JL,JK)) * ZFACT(JL) 
-           ENDDO
-        ENDDO
-  
-      ENDIF ! ok_ade .and. ok_aie
-
-     IF (ok_aie) THEN
-        ! cloudy-sky with total aerosols for indirect effect 
-        ! and natural aerosols for direct effect
-        ! PTAUA
-        ! CAS AER (3)
-        flag_aer=1.0
-        CALL SWU_LMDAR4(PSCT,PCLDSW,PPMB,PPSOL,&
-             PRMU0,PFRAC,PTAVE,PWV,&
-             ZAKI,ZCLD,ZCLEAR,ZDSIG,ZFACT,ZRMU,ZSEC,ZUD)
-        INU = 1
-        CALL SW1S_LMDAR4(INU, PAER, flag_aer,&
-             tauaero(:,:,3,:), pizaero(:,:,3,:), cgaero(:,:,3,:),&
-             PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,&
-             ZDSIG, POMEGAA, ZOZ, ZRMU, ZSEC, PTAUA, ZUD,&
-             ZFD, ZFU)
-        INU = 2
-        CALL SW2S_LMDAR4(INU, PAER, flag_aer,&
-             tauaero(:,:,3,:), pizaero(:,:,3,:), cgaero(:,:,3,:),&
-             ZAKI, PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,&
-             ZDSIG, POMEGAA, ZOZ, ZRMU, ZSEC, PTAUA, ZUD,&
-             PWV, PQS,&
-             ZFDOWN, ZFUP)
-  
-        DO JK = 1 , KFLEV+1
-           DO JL = 1, KDLON
-              ZFSUP_AERO(JL,JK,5) = (ZFUP(JL,JK)   + ZFU(JL,JK)) * ZFACT(JL)
-              ZFSDN_AERO(JL,JK,5) = (ZFDOWN(JL,JK) + ZFD(JL,JK)) * ZFACT(JL) 
-           ENDDO
-        ENDDO
-
-     ENDIF ! ok_aie      
-
-     ENDIF !--if flag_aerosol GT 0 OR flag_aerosol_strat GT 0
-
-     itapsw = 0
-  ENDIF
-  itapsw = itapsw + 1
-
-  IF  ( AEROSOLFEEDBACK_ACTIVE .AND. (flag_aerosol.GT.0 .OR. flag_aerosol_strat.GT.0) ) THEN
-  IF ( ok_ade .and. ok_aie  ) THEN
-    ZFSUP(:,:) =    ZFSUP_AERO(:,:,4)
-    ZFSDN(:,:) =    ZFSDN_AERO(:,:,4)
-    ZFSUP0(:,:) =   ZFSUP0_AERO(:,:,2)
-    ZFSDN0(:,:) =   ZFSDN0_AERO(:,:,2)
-  ENDIF
-
-  IF ( ok_ade .and. (.not. ok_aie) )  THEN
-    ZFSUP(:,:) =    ZFSUP_AERO(:,:,2)
-    ZFSDN(:,:) =    ZFSDN_AERO(:,:,2)
-    ZFSUP0(:,:) =   ZFSUP0_AERO(:,:,2)
-    ZFSDN0(:,:) =   ZFSDN0_AERO(:,:,2)
-  ENDIF
-
-  IF ( (.not. ok_ade) .and. ok_aie  )  THEN
-    ZFSUP(:,:) =    ZFSUP_AERO(:,:,5)
-    ZFSDN(:,:) =    ZFSDN_AERO(:,:,5)
-    ZFSUP0(:,:) =   ZFSUP0_AERO(:,:,3)
-    ZFSDN0(:,:) =   ZFSDN0_AERO(:,:,3)
-  ENDIF
-
-  IF ((.not. ok_ade) .and. (.not. ok_aie)) THEN
-    ZFSUP(:,:) =    ZFSUP_AERO(:,:,3)
-    ZFSDN(:,:) =    ZFSDN_AERO(:,:,3)
-    ZFSUP0(:,:) =   ZFSUP0_AERO(:,:,3)
-    ZFSDN0(:,:) =   ZFSDN0_AERO(:,:,3)
-  ENDIF
-
-! MS the following allows to compute the forcing diagostics without
-! letting the aerosol forcing act on the meteorology
-! SEE logic above
-  ELSE 
-    ZFSUP(:,:) =    ZFSUP_AERO(:,:,1)
-    ZFSDN(:,:) =    ZFSDN_AERO(:,:,1)
-    ZFSUP0(:,:) =   ZFSUP0_AERO(:,:,1)
-    ZFSDN0(:,:) =   ZFSDN0_AERO(:,:,1)
-  ENDIF
-
-! Now computes heating rates
-  DO k = 1, KFLEV
-     kpl1 = k+1
-     DO i = 1, KDLON
-        PHEAT(i,k) = -(ZFSUP(i,kpl1)-ZFSUP(i,k))-(ZFSDN(i,k)-ZFSDN(i,kpl1))
-        PHEAT(i,k) = PHEAT(i,k) * RDAY*RG/RCPD / PDP(i,k)
-        PHEAT0(i,k) = -(ZFSUP0(i,kpl1)-ZFSUP0(i,k))-(ZFSDN0(i,k)-ZFSDN0(i,kpl1))
-        PHEAT0(i,k) = PHEAT0(i,k) * RDAY*RG/RCPD / PDP(i,k)
-     ENDDO
-  ENDDO
-
-  DO i = 1, KDLON
-! effective SW surface albedo calculation
-     PALBPLA(i) = ZFSUP(i,KFLEV+1)/(ZFSDN(i,KFLEV+1)+1.0e-20)
-     
-! clear sky net fluxes at TOA and SRF
-     PSOLSW0(i) = ZFSDN0(i,1) - ZFSUP0(i,1)
-     PTOPSW0(i) = ZFSDN0(i,KFLEV+1) - ZFSUP0(i,KFLEV+1)
-
-! cloudy sky net fluxes at TOA and SRF
-     PSOLSW(i) = ZFSDN(i,1) - ZFSUP(i,1)
-     PTOPSW(i) = ZFSDN(i,KFLEV+1) - ZFSUP(i,KFLEV+1)
-
-! net anthropogenic forcing direct and 1st indirect effect diagnostics
-! requires a natural aerosol field read and used 
-! Difference of net fluxes from double call to radiation
-
-IF (ok_ade) THEN
-
-! indices 1: natural; 2 anthropogenic 
-
-! TOA/SRF all sky natural forcing
-     PSOLSWAERO(i,1) = (ZFSDN_AERO(i,1,3) - ZFSUP_AERO(i,1,3))-(ZFSDN_AERO(i,1,1) - ZFSUP_AERO(i,1,1))
-     PTOPSWAERO(i,1) = (ZFSDN_AERO(i,KFLEV+1,3) - ZFSUP_AERO(i,KFLEV+1,3))- (ZFSDN_AERO(i,KFLEV+1,1) - ZFSUP_AERO(i,KFLEV+1,1))
-
-! TOA/SRF clear sky natural forcing
-     PSOLSW0AERO(i,1) = (ZFSDN0_AERO(i,1,3) - ZFSUP0_AERO(i,1,3))-(ZFSDN0_AERO(i,1,1) - ZFSUP0_AERO(i,1,1))
-     PTOPSW0AERO(i,1) = (ZFSDN0_AERO(i,KFLEV+1,3) - ZFSUP0_AERO(i,KFLEV+1,3))-(ZFSDN0_AERO(i,KFLEV+1,1) - ZFSUP0_AERO(i,KFLEV+1,1))
-
-   IF (ok_aie) THEN 
-
-! TOA/SRF all sky anthropogenic forcing
-     PSOLSWAERO(i,2) = (ZFSDN_AERO(i,1,4) - ZFSUP_AERO(i,1,4))-(ZFSDN_AERO(i,1,5) - ZFSUP_AERO(i,1,5))
-     PTOPSWAERO(i,2) = (ZFSDN_AERO(i,KFLEV+1,4) - ZFSUP_AERO(i,KFLEV+1,4))- (ZFSDN_AERO(i,KFLEV+1,5) - ZFSUP_AERO(i,KFLEV+1,5))
-
-   ELSE 
-
-! TOA/SRF all sky anthropogenic forcing
-     PSOLSWAERO(i,2) = (ZFSDN_AERO(i,1,2) - ZFSUP_AERO(i,1,2))-(ZFSDN_AERO(i,1,3) - ZFSUP_AERO(i,1,3))
-     PTOPSWAERO(i,2) = (ZFSDN_AERO(i,KFLEV+1,2) - ZFSUP_AERO(i,KFLEV+1,2))- (ZFSDN_AERO(i,KFLEV+1,3) - ZFSUP_AERO(i,KFLEV+1,3))
-
-   ENDIF
-
-! TOA/SRF clear sky anthropogenic forcing
-     PSOLSW0AERO(i,2) = (ZFSDN0_AERO(i,1,2) - ZFSUP0_AERO(i,1,2))-(ZFSDN0_AERO(i,1,3) - ZFSUP0_AERO(i,1,3))
-     PTOPSW0AERO(i,2) = (ZFSDN0_AERO(i,KFLEV+1,2) - ZFSUP0_AERO(i,KFLEV+1,2))-(ZFSDN0_AERO(i,KFLEV+1,3) - ZFSUP0_AERO(i,KFLEV+1,3))
-
-! direct anthropogenic forcing , as in old LMDzT, however differences of net fluxes
-     PSOLSWADAERO(i) = PSOLSWAERO(i,2)
-     PTOPSWADAERO(i) = PTOPSWAERO(i,2)
-     PSOLSWAD0AERO(i) = PSOLSW0AERO(i,2)
-     PTOPSWAD0AERO(i) = PTOPSW0AERO(i,2)
-
-! OB: these diagnostics may not always work but who need them
-! Cloud forcing indices 1: natural; 2 anthropogenic; 3: zero aerosol direct effect
-! Instantaneously computed cloudy sky direct aerosol effect, cloud forcing due to aerosols above clouds
-! natural
-     PSOLSWCFAERO(i,1) = PSOLSWAERO(i,1) - PSOLSW0AERO(i,1)
-     PTOPSWCFAERO(i,1) = PTOPSWAERO(i,1) - PTOPSW0AERO(i,1)
-
-! Instantaneously computed cloudy SKY DIRECT aerosol effect, cloud forcing due to aerosols above clouds
-! anthropogenic
-     PSOLSWCFAERO(i,2) = PSOLSWAERO(i,2) - PSOLSW0AERO(i,2)
-     PTOPSWCFAERO(i,2) = PTOPSWAERO(i,2) - PTOPSW0AERO(i,2)
-
-! Cloudforcing without aerosol
-! zero
-     PSOLSWCFAERO(i,3) = (ZFSDN_AERO(i,1,1) - ZFSUP_AERO(i,1,1))-(ZFSDN0_AERO(i,1,1) - ZFSUP0_AERO(i,1,1))
-     PTOPSWCFAERO(i,3) = (ZFSDN_AERO(i,KFLEV+1,1) - ZFSUP_AERO(i,KFLEV+1,1))- (ZFSDN0_AERO(i,KFLEV+1,1) - ZFSUP0_AERO(i,KFLEV+1,1))
-
-ENDIF
-
-IF (ok_aie) THEN
-   IF (ok_ade) THEN 
-     PSOLSWAIAERO(i) = (ZFSDN_AERO(i,1,4) - ZFSUP_AERO(i,1,4))-(ZFSDN_AERO(i,1,2) - ZFSUP_AERO(i,1,2))
-     PTOPSWAIAERO(i) = (ZFSDN_AERO(i,KFLEV+1,4) - ZFSUP_AERO(i,KFLEV+1,4))-(ZFSDN_AERO(i,KFLEV+1,2) - ZFSUP_AERO(i,KFLEV+1,2))
-   ELSE 
-     PSOLSWAIAERO(i) = (ZFSDN_AERO(i,1,5) - ZFSUP_AERO(i,1,5))-(ZFSDN_AERO(i,1,3) - ZFSUP_AERO(i,1,3))
-     PTOPSWAIAERO(i) = (ZFSDN_AERO(i,KFLEV+1,5) - ZFSUP_AERO(i,KFLEV+1,5))-(ZFSDN_AERO(i,KFLEV+1,3) - ZFSUP_AERO(i,KFLEV+1,3))
-   ENDIF
-ENDIF
-
-ENDDO
-
-END SUBROUTINE SW_AEROAR4
Index: /LMDZ6/trunk/libf/phylmd/sw_aeroAR4.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/sw_aeroAR4.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/sw_aeroAR4.f90	(revision 5268)
@@ -0,0 +1,641 @@
+!
+! $Id$
+!
+SUBROUTINE SW_AEROAR4(PSCT, PRMU0, PFRAC, &
+     PPMB, PDP, &
+     PPSOL, PALBD, PALBP,&
+     PTAVE, PWV, PQS, POZON, PAER,&
+     PCLDSW, PTAU, POMEGA, PCG,&
+     PHEAT, PHEAT0,&
+     PALBPLA,PTOPSW,PSOLSW,PTOPSW0,PSOLSW0,&
+     ZFSUP,ZFSDN,ZFSUP0,ZFSDN0,&
+     tauaero, pizaero, cgaero,&
+     PTAUA, POMEGAA,&
+     PTOPSWADAERO,PSOLSWADAERO,&
+     PTOPSWAD0AERO,PSOLSWAD0AERO,&
+     PTOPSWAIAERO,PSOLSWAIAERO,&
+     PTOPSWAERO,PTOPSW0AERO,&
+     PSOLSWAERO,PSOLSW0AERO,&
+     PTOPSWCFAERO,PSOLSWCFAERO,&
+     ok_ade, ok_aie, flag_aerosol, flag_aerosol_strat )
+
+  USE dimphy
+  USE phys_output_mod, ONLY : swaero_diag
+  USE print_control_mod, ONLY: lunout
+  USE aero_mod, ONLY : naero_grp
+  IMPLICIT NONE
+
+  INCLUDE "YOMCST.h"
+  INCLUDE "clesphys.h"
+  !
+  !     ------------------------------------------------------------------
+  !
+  !     PURPOSE.
+  !     --------
+  !
+  !          THIS ROUTINE COMPUTES THE SHORTWAVE RADIATION FLUXES IN TWO
+  !     SPECTRAL INTERVALS FOLLOWING FOUQUART AND BONNEL (1980).
+  !
+  !     METHOD.
+  !     -------
+  !
+  !          1. COMPUTES ABSORBER AMOUNTS                 (SWU)
+  !          2. COMPUTES FLUXES IN 1ST SPECTRAL INTERVAL  (SW1S)
+  !          3. COMPUTES FLUXES IN 2ND SPECTRAL INTERVAL  (SW2S)
+  !
+  !     REFERENCE.
+  !     ----------
+  !
+  !        SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT
+  !        DOCUMENTATION, AND FOUQUART AND BONNEL (1980)
+  !
+  !     AUTHOR.
+  !     -------
+  !        JEAN-JACQUES MORCRETTE  *ECMWF*
+  !
+  !     MODIFICATIONS.
+  !     --------------
+  !        ORIGINAL : 89-07-14
+  !        1995-01-01  J.-J. MORCRETTE  Direct/Diffuse Albedo
+  !        2003-11-27  J. QUAAS Introduce aerosol forcings (based on BOUCHER)
+  !        2009-04     A. COZIC - C.DEANDREIS Indroduce NAT/BC/POM/DUST/SS aerosol forcing
+  !        2012-09     O. BOUCHER - reorganise aerosol cases with ok_ade, ok_aie, flag_aerosol
+  !     ------------------------------------------------------------------
+  !
+  !* ARGUMENTS:
+  !
+  REAL(KIND=8) PSCT  ! constante solaire (valeur conseillee: 1370)
+
+  REAL(KIND=8) PPSOL(KDLON)        ! SURFACE PRESSURE (PA)
+  REAL(KIND=8) PDP(KDLON,KFLEV)    ! LAYER THICKNESS (PA)
+  REAL(KIND=8) PPMB(KDLON,KFLEV+1) ! HALF-LEVEL PRESSURE (MB)
+
+  REAL(KIND=8) PRMU0(KDLON)  ! COSINE OF ZENITHAL ANGLE
+  REAL(KIND=8) PFRAC(KDLON)  ! fraction de la journee
+
+  REAL(KIND=8) PTAVE(KDLON,KFLEV)  ! LAYER TEMPERATURE (K)
+  REAL(KIND=8) PWV(KDLON,KFLEV)    ! SPECIFI! HUMIDITY (KG/KG)
+  REAL(KIND=8) PQS(KDLON,KFLEV)    ! SATURATED WATER VAPOUR (KG/KG)
+  REAL(KIND=8) POZON(KDLON,KFLEV)  ! OZONE CONCENTRATION (KG/KG)
+  REAL(KIND=8) PAER(KDLON,KFLEV,5) ! AEROSOLS' OPTICAL THICKNESS
+
+  REAL(KIND=8) PALBD(KDLON,2)  ! albedo du sol (lumiere diffuse)
+  REAL(KIND=8) PALBP(KDLON,2)  ! albedo du sol (lumiere parallele)
+
+  REAL(KIND=8) PCLDSW(KDLON,KFLEV)    ! CLOUD FRACTION
+  REAL(KIND=8) PTAU(KDLON,2,KFLEV)    ! CLOUD OPTICAL THICKNESS (pre-industrial value)
+  REAL(KIND=8) PCG(KDLON,2,KFLEV)     ! ASYMETRY FACTOR
+  REAL(KIND=8) POMEGA(KDLON,2,KFLEV)  ! SINGLE SCATTERING ALBEDO
+
+  REAL(KIND=8) PHEAT(KDLON,KFLEV) ! SHORTWAVE HEATING (K/DAY)
+  REAL(KIND=8) PHEAT0(KDLON,KFLEV)! SHORTWAVE HEATING (K/DAY) clear-sky
+  REAL(KIND=8) PALBPLA(KDLON)     ! PLANETARY ALBEDO
+  REAL(KIND=8) PTOPSW(KDLON)      ! SHORTWAVE FLUX AT T.O.A.
+  REAL(KIND=8) PSOLSW(KDLON)      ! SHORTWAVE FLUX AT SURFACE
+  REAL(KIND=8) PTOPSW0(KDLON)     ! SHORTWAVE FLUX AT T.O.A. (CLEAR-SKY)
+  REAL(KIND=8) PSOLSW0(KDLON)     ! SHORTWAVE FLUX AT SURFACE (CLEAR-SKY)
+  !
+  !* LOCAL VARIABLES:
+  !
+  real, parameter:: dobson_u = 2.1415e-05 ! Dobson unit, in kg m-2
+
+  REAL(KIND=8) ZOZ(KDLON,KFLEV)
+  ! column-density of ozone in layer, in kilo-Dobsons
+
+  REAL(KIND=8) ZAKI(KDLON,2)     
+  REAL(KIND=8) ZCLD(KDLON,KFLEV)
+  REAL(KIND=8) ZCLEAR(KDLON) 
+  REAL(KIND=8) ZDSIG(KDLON,KFLEV)
+  REAL(KIND=8) ZFACT(KDLON)
+  REAL(KIND=8) ZFD(KDLON,KFLEV+1)
+  REAL(KIND=8) ZFDOWN(KDLON,KFLEV+1)
+  REAL(KIND=8) ZFU(KDLON,KFLEV+1)
+  REAL(KIND=8) ZFUP(KDLON,KFLEV+1)
+  REAL(KIND=8) ZRMU(KDLON)
+  REAL(KIND=8) ZSEC(KDLON)
+  REAL(KIND=8) ZUD(KDLON,5,KFLEV+1)
+  REAL(KIND=8) ZCLDSW0(KDLON,KFLEV)
+
+  REAL(KIND=8) ZFSUP(KDLON,KFLEV+1)
+  REAL(KIND=8) ZFSDN(KDLON,KFLEV+1)
+  REAL(KIND=8) ZFSUP0(KDLON,KFLEV+1)
+  REAL(KIND=8) ZFSDN0(KDLON,KFLEV+1)
+
+  INTEGER inu, jl, jk, i, k, kpl1
+
+  INTEGER swpas  ! Every swpas steps, sw is calculated
+  PARAMETER(swpas=1)
+
+  INTEGER, SAVE :: itapsw = 0
+  !$OMP THREADPRIVATE(itapsw)
+  LOGICAL, SAVE :: appel1er = .TRUE.
+  !$OMP THREADPRIVATE(appel1er)
+  LOGICAL, SAVE :: initialized = .FALSE.
+  !$OMP THREADPRIVATE(initialized)
+
+  !jq-local flag introduced for aerosol forcings
+  REAL(KIND=8), SAVE :: flag_aer
+  !$OMP THREADPRIVATE(flag_aer)
+
+  LOGICAL ok_ade, ok_aie    ! use aerosol forcings or not?
+  INTEGER flag_aerosol_strat ! use stratospehric aerosols
+  INTEGER flag_aerosol      ! global flag for aerosol 0 (no aerosol) or 1-5 (aerosols)
+  REAL(KIND=8) tauaero(kdlon,kflev,naero_grp,2)  ! aerosol optical properties
+  REAL(KIND=8) pizaero(kdlon,kflev,naero_grp,2)  ! (see aeropt.F)
+  REAL(KIND=8) cgaero(kdlon,kflev,naero_grp,2)   ! -"-
+  REAL(KIND=8) PTAUA(KDLON,2,KFLEV)    ! CLOUD OPTICAL THICKNESS (present-day value)
+  REAL(KIND=8) POMEGAA(KDLON,2,KFLEV)  ! SINGLE SCATTERING ALBEDO
+  REAL(KIND=8) PTOPSWADAERO(KDLON)     ! SHORTWAVE FLUX AT T.O.A.(+AEROSOL DIR)
+  REAL(KIND=8) PSOLSWADAERO(KDLON)     ! SHORTWAVE FLUX AT SURFACE(+AEROSOL DIR)
+  REAL(KIND=8) PTOPSWAD0AERO(KDLON)    ! SHORTWAVE FLUX AT T.O.A.(+AEROSOL DIR)
+  REAL(KIND=8) PSOLSWAD0AERO(KDLON)    ! SHORTWAVE FLUX AT SURFACE(+AEROSOL DIR)
+  REAL(KIND=8) PTOPSWAIAERO(KDLON)     ! SHORTWAVE FLUX AT T.O.A.(+AEROSOL IND)
+  REAL(KIND=8) PSOLSWAIAERO(KDLON)     ! SHORTWAVE FLUX AT SURFACE(+AEROSOL IND)
+  REAL(KIND=8) PTOPSWAERO(KDLON,9)     ! SW TOA AS DRF nat & ant 
+  REAL(KIND=8) PTOPSW0AERO(KDLON,9)    ! SW SRF AS DRF nat & ant 
+  REAL(KIND=8) PSOLSWAERO(KDLON,9)     ! SW TOA CS DRF nat & ant
+  REAL(KIND=8) PSOLSW0AERO(KDLON,9)    ! SW SRF CS DRF nat & ant
+  REAL(KIND=8) PTOPSWCFAERO(KDLON,3)   !  SW TOA AS cloudRF nat & ant 
+  REAL(KIND=8) PSOLSWCFAERO(KDLON,3)   !  SW SRF AS cloudRF nat & ant 
+
+  !jq - Fluxes including aerosol effects
+  REAL(KIND=8),ALLOCATABLE,SAVE :: ZFSUPAD_AERO(:,:)
+  !$OMP THREADPRIVATE(ZFSUPAD_AERO)
+  REAL(KIND=8),ALLOCATABLE,SAVE :: ZFSDNAD_AERO(:,:)
+  !$OMP THREADPRIVATE(ZFSDNAD_AERO)
+  !jq - Fluxes including aerosol effects
+  REAL(KIND=8),ALLOCATABLE,SAVE :: ZFSUPAD0_AERO(:,:)
+  !$OMP THREADPRIVATE(ZFSUPAD0_AERO)
+  REAL(KIND=8),ALLOCATABLE,SAVE :: ZFSDNAD0_AERO(:,:)
+  !$OMP THREADPRIVATE(ZFSDNAD0_AERO)
+  REAL(KIND=8),ALLOCATABLE,SAVE :: ZFSUPAI_AERO(:,:)
+  !$OMP THREADPRIVATE(ZFSUPAI_AERO)
+  REAL(KIND=8),ALLOCATABLE,SAVE :: ZFSDNAI_AERO(:,:)
+  !$OMP THREADPRIVATE(ZFSDNAI_AERO)
+  REAL(KIND=8),ALLOCATABLE,SAVE ::  ZFSUP_AERO(:,:,:)
+  !$OMP THREADPRIVATE(ZFSUP_AERO)
+  REAL(KIND=8),ALLOCATABLE,SAVE ::  ZFSDN_AERO(:,:,:)
+  !$OMP THREADPRIVATE(ZFSDN_AERO)
+  REAL(KIND=8),ALLOCATABLE,SAVE ::  ZFSUP0_AERO(:,:,:)
+  !$OMP THREADPRIVATE(ZFSUP0_AERO)
+  REAL(KIND=8),ALLOCATABLE,SAVE ::  ZFSDN0_AERO(:,:,:)
+  !$OMP THREADPRIVATE(ZFSDN0_AERO)
+
+! Key to define the aerosol effect acting on climate
+! OB: AEROSOLFEEDBACK_ACTIVE is now a LOGICAL
+! TRUE: fluxes use natural and/or anthropogenic aerosols according to ok_ade and ok_aie, DEFAULT
+! FALSE: fluxes use no aerosols (case 1)
+
+  LOGICAL,SAVE :: AEROSOLFEEDBACK_ACTIVE = .TRUE.
+!$OMP THREADPRIVATE(AEROSOLFEEDBACK_ACTIVE)  
+
+      CHARACTER (LEN=20) :: modname='sw_aeroAR4'
+      CHARACTER (LEN=80) :: abort_message
+
+  IF(.NOT.initialized) THEN
+     flag_aer=0.
+     initialized=.TRUE.
+     ALLOCATE(ZFSUPAD_AERO(KDLON,KFLEV+1))
+     ALLOCATE(ZFSDNAD_AERO(KDLON,KFLEV+1))
+     ALLOCATE(ZFSUPAD0_AERO(KDLON,KFLEV+1))
+     ALLOCATE(ZFSDNAD0_AERO(KDLON,KFLEV+1))
+     ALLOCATE(ZFSUPAI_AERO(KDLON,KFLEV+1))
+     ALLOCATE(ZFSDNAI_AERO(KDLON,KFLEV+1))
+!-OB decrease size of these arrays to what is needed
+!                | direct effect 
+!ind effect      | no aerosol   natural  total
+!natural (PTAU)  |   1            3       2     --ZFSUP/ZFSDN
+!total (PTAUA)   |                5       4     --ZFSUP/ZFSDN
+!no cloud        |   1            3       2     --ZFSUP0/ZFSDN0
+! so we need which case when ? 
+! ok_ade and ok_aie = 4-5, 4-2 and 2 
+! ok_ade and not ok_aie = 2-3 and 2 
+! not ok_ade and ok_aie = 5-3 and 5 
+! not ok_ade and not ok_aie = 3 
+! therefore the cases have the folliwng switches 
+! 3 = not ok_ade or not ok_aie 
+! 4 = ok_ade and ok_aie 
+! 2 = ok_ade 
+! 5 = ok_aie 
+     ALLOCATE(ZFSUP_AERO (KDLON,KFLEV+1,5))
+     ALLOCATE(ZFSDN_AERO (KDLON,KFLEV+1,5))
+     ALLOCATE(ZFSUP0_AERO(KDLON,KFLEV+1,3))
+     ALLOCATE(ZFSDN0_AERO(KDLON,KFLEV+1,3))
+! end OB modif
+     ZFSUPAD_AERO(:,:)=0.
+     ZFSDNAD_AERO(:,:)=0.
+     ZFSUPAD0_AERO(:,:)=0.
+     ZFSDNAD0_AERO(:,:)=0.
+     ZFSUPAI_AERO(:,:)=0.
+     ZFSDNAI_AERO(:,:)=0.
+     ZFSUP_AERO (:,:,:)=0.
+     ZFSDN_AERO (:,:,:)=0.
+     ZFSUP0_AERO(:,:,:)=0.
+     ZFSDN0_AERO(:,:,:)=0.
+  ENDIF
+
+  IF (appel1er) THEN
+     WRITE(lunout,*)'SW calling frequency : ', swpas
+     WRITE(lunout,*) "   In general, it should be 1"
+     appel1er = .FALSE.
+  ENDIF
+  !     ------------------------------------------------------------------
+  IF (MOD(itapsw,swpas).EQ.0) THEN
+
+     DO JK = 1 , KFLEV
+        DO JL = 1, KDLON
+           ZCLDSW0(JL,JK) = 0.0
+           ZOZ(JL,JK) = POZON(JL,JK)*46.6968/RG &
+                *PDP(JL,JK)*(101325.0/PPSOL(JL))
+        ENDDO
+     ENDDO
+
+! clear sky with no aerosols at all is computed IF ACTIVEFEEDBACK_ACTIVE is false or for extended diag
+     IF ( swaero_diag .or. .not. AEROSOLFEEDBACK_ACTIVE .OR. flag_aerosol .EQ. 0 ) THEN    
+
+     ! clear-sky: zero aerosol effect
+     flag_aer=0.0
+     CALL SWU_LMDAR4(PSCT,ZCLDSW0,PPMB,PPSOL,&
+          PRMU0,PFRAC,PTAVE,PWV,&
+          ZAKI,ZCLD,ZCLEAR,ZDSIG,ZFACT,ZRMU,ZSEC,ZUD)
+     INU = 1
+     CALL SW1S_LMDAR4(INU,PAER, flag_aer, &
+          tauaero(:,:,1,:), pizaero(:,:,1,:), cgaero(:,:,1,:),&
+          PALBD, PALBP, PCG, ZCLD, ZCLEAR, ZCLDSW0,&
+          ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,&
+          ZFD, ZFU)
+     INU = 2
+     CALL SW2S_LMDAR4(INU, PAER, flag_aer, &
+          tauaero(:,:,1,:), pizaero(:,:,1,:), cgaero(:,:,1,:),&
+          ZAKI, PALBD, PALBP, PCG, ZCLD, ZCLEAR, ZCLDSW0,&
+          ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,&
+          PWV, PQS,&
+          ZFDOWN, ZFUP)
+     DO JK = 1 , KFLEV+1
+        DO JL = 1, KDLON
+           ZFSUP0_AERO(JL,JK,1) = (ZFUP(JL,JK)   + ZFU(JL,JK)) * ZFACT(JL)
+           ZFSDN0_AERO(JL,JK,1) = (ZFDOWN(JL,JK) + ZFD(JL,JK)) * ZFACT(JL)
+        ENDDO
+     ENDDO
+     ENDIF ! swaero_diag .or. .not. AEROSOLFEEDBACK_ACTIVE
+
+! cloudy sky with no aerosols at all is either computed IF no indirect effect is asked for, or for extended diag
+     IF ( swaero_diag .or. .not. AEROSOLFEEDBACK_ACTIVE .OR. flag_aerosol .EQ. 0 ) THEN    
+     ! cloudy-sky: zero aerosol effect
+     flag_aer=0.0
+     CALL SWU_LMDAR4(PSCT,PCLDSW,PPMB,PPSOL,&
+          PRMU0,PFRAC,PTAVE,PWV,&
+          ZAKI,ZCLD,ZCLEAR,ZDSIG,ZFACT,ZRMU,ZSEC,ZUD)
+     INU = 1
+     CALL SW1S_LMDAR4(INU, PAER, flag_aer, &
+          tauaero(:,:,1,:), pizaero(:,:,1,:), cgaero(:,:,1,:),&
+          PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,&
+          ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,&
+          ZFD, ZFU)
+     INU = 2
+     CALL SW2S_LMDAR4(INU, PAER, flag_aer, &
+          tauaero(:,:,1,:), pizaero(:,:,1,:), cgaero(:,:,1,:),&
+          ZAKI, PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,&
+          ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,&
+          PWV, PQS,&
+          ZFDOWN, ZFUP)
+
+     DO JK = 1 , KFLEV+1
+        DO JL = 1, KDLON
+           ZFSUP_AERO(JL,JK,1) = (ZFUP(JL,JK)   + ZFU(JL,JK)) * ZFACT(JL)
+           ZFSDN_AERO(JL,JK,1) = (ZFDOWN(JL,JK) + ZFD(JL,JK)) * ZFACT(JL)
+        ENDDO
+     ENDDO
+     ENDIF ! swaero_diag .or. .not. AEROSOLFEEDBACK_ACTIVE
+
+     IF (flag_aerosol.GT.0 .OR. flag_aerosol_strat.GT.0) THEN
+
+     IF (ok_ade.and.swaero_diag .or. .not. ok_ade) THEN
+
+        ! clear sky direct effect natural aerosol
+        ! CAS AER (3)
+        flag_aer=1.0
+        CALL SWU_LMDAR4(PSCT,ZCLDSW0,PPMB,PPSOL,&
+             PRMU0,PFRAC,PTAVE,PWV,&
+             ZAKI,ZCLD,ZCLEAR,ZDSIG,ZFACT,ZRMU,ZSEC,ZUD)
+        INU = 1
+        CALL SW1S_LMDAR4(INU, PAER, flag_aer,&
+             tauaero(:,:,3,:), pizaero(:,:,3,:), cgaero(:,:,3,:),&
+             PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,&
+             ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,&
+             ZFD, ZFU)
+        INU = 2
+        CALL SW2S_LMDAR4(INU, PAER, flag_aer,&
+             tauaero(:,:,3,:), pizaero(:,:,3,:), cgaero(:,:,3,:),&
+             ZAKI, PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,&
+             ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,&
+             PWV, PQS,&
+             ZFDOWN, ZFUP)
+
+        DO JK = 1 , KFLEV+1
+           DO JL = 1, KDLON
+              ZFSUP0_AERO(JL,JK,3) = (ZFUP(JL,JK)   + ZFU(JL,JK)) * ZFACT(JL)
+              ZFSDN0_AERO(JL,JK,3) = (ZFDOWN(JL,JK) + ZFD(JL,JK)) * ZFACT(JL)
+           ENDDO
+        ENDDO
+     ENDIF !--end not swaero_diag or not ok_ade
+
+     IF (ok_ade) THEN
+
+        ! clear sky direct effect of total aerosol
+        ! CAS AER (2)
+        flag_aer=1.0
+        CALL SWU_LMDAR4(PSCT,ZCLDSW0,PPMB,PPSOL,&
+             PRMU0,PFRAC,PTAVE,PWV,&
+             ZAKI,ZCLD,ZCLEAR,ZDSIG,ZFACT,ZRMU,ZSEC,ZUD)
+        INU = 1
+        CALL SW1S_LMDAR4(INU, PAER, flag_aer,&
+             tauaero(:,:,2,:), pizaero(:,:,2,:), cgaero(:,:,2,:),&
+             PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,&
+             ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,&
+             ZFD, ZFU)
+        INU = 2
+        CALL SW2S_LMDAR4(INU, PAER, flag_aer,&
+             tauaero(:,:,2,:), pizaero(:,:,2,:), cgaero(:,:,2,:),&
+             ZAKI, PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,&
+             ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,&
+             PWV, PQS,&
+             ZFDOWN, ZFUP)
+
+        DO JK = 1 , KFLEV+1
+           DO JL = 1, KDLON
+              ZFSUP0_AERO(JL,JK,2) = (ZFUP(JL,JK)   + ZFU(JL,JK)) * ZFACT(JL) 
+              ZFSDN0_AERO(JL,JK,2) = (ZFDOWN(JL,JK) + ZFD(JL,JK)) * ZFACT(JL) 
+           ENDDO
+        ENDDO
+
+        ! cloudy-sky with natural aerosols for indirect effect 
+        ! but total aerosols for direct effect
+        ! PTAU
+        ! CAS AER (2)
+        flag_aer=1.0
+        CALL SWU_LMDAR4(PSCT,PCLDSW,PPMB,PPSOL,&
+             PRMU0,PFRAC,PTAVE,PWV,&
+             ZAKI,ZCLD,ZCLEAR,ZDSIG,ZFACT,ZRMU,ZSEC,ZUD)
+        INU = 1
+        CALL SW1S_LMDAR4(INU, PAER, flag_aer,&
+             tauaero(:,:,2,:), pizaero(:,:,2,:), cgaero(:,:,2,:),&
+             PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,&
+             ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,&
+             ZFD, ZFU)
+        INU = 2
+        CALL SW2S_LMDAR4(INU, PAER, flag_aer,&
+             tauaero(:,:,2,:), pizaero(:,:,2,:), cgaero(:,:,2,:),&
+             ZAKI, PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,&
+             ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,&
+             PWV, PQS,&
+             ZFDOWN, ZFUP)
+
+        DO JK = 1 , KFLEV+1
+           DO JL = 1, KDLON
+              ZFSUP_AERO(JL,JK,2) = (ZFUP(JL,JK)   + ZFU(JL,JK)) * ZFACT(JL) 
+              ZFSDN_AERO(JL,JK,2) = (ZFDOWN(JL,JK) + ZFD(JL,JK)) * ZFACT(JL) 
+           ENDDO
+        ENDDO
+
+     ENDIF !-end ok_ade
+
+     IF ( .not. ok_ade .or. .not. ok_aie ) THEN
+
+        ! cloudy-sky with natural aerosols for indirect effect 
+        ! and natural aerosols for direct effect
+        ! PTAU
+        ! CAS AER (3)
+        ! cloudy-sky direct effect natural aerosol
+        flag_aer=1.0
+        CALL SWU_LMDAR4(PSCT,PCLDSW,PPMB,PPSOL,&
+             PRMU0,PFRAC,PTAVE,PWV,&
+             ZAKI,ZCLD,ZCLEAR,ZDSIG,ZFACT,ZRMU,ZSEC,ZUD)
+        INU = 1
+        CALL SW1S_LMDAR4(INU, PAER, flag_aer,&
+             tauaero(:,:,3,:), pizaero(:,:,3,:), cgaero(:,:,3,:),&
+             PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,&
+             ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,&
+             ZFD, ZFU)
+        INU = 2
+        CALL SW2S_LMDAR4(INU, PAER, flag_aer,&
+             tauaero(:,:,3,:), pizaero(:,:,3,:), cgaero(:,:,3,:),&
+             ZAKI, PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,&
+             ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,&
+             PWV, PQS,&
+             ZFDOWN, ZFUP)
+
+        DO JK = 1 , KFLEV+1
+           DO JL = 1, KDLON
+              ZFSUP_AERO(JL,JK,3) = (ZFUP(JL,JK)   + ZFU(JL,JK)) * ZFACT(JL)
+              ZFSDN_AERO(JL,JK,3) = (ZFDOWN(JL,JK) + ZFD(JL,JK)) * ZFACT(JL)
+           ENDDO
+        ENDDO
+
+     ENDIF  !--true/false or false/true
+
+     IF (ok_ade .and. ok_aie) THEN
+
+        ! cloudy-sky with total aerosols for indirect effect 
+        ! and total aerosols for direct effect
+        ! PTAUA
+        ! CAS AER (2)
+        flag_aer=1.0
+        CALL SWU_LMDAR4(PSCT,PCLDSW,PPMB,PPSOL,&
+             PRMU0,PFRAC,PTAVE,PWV,&
+             ZAKI,ZCLD,ZCLEAR,ZDSIG,ZFACT,ZRMU,ZSEC,ZUD)
+        INU = 1
+        CALL SW1S_LMDAR4(INU, PAER, flag_aer,&
+             tauaero(:,:,2,:), pizaero(:,:,2,:), cgaero(:,:,2,:),&
+             PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,&
+             ZDSIG, POMEGAA, ZOZ, ZRMU, ZSEC, PTAUA, ZUD,&
+             ZFD, ZFU)
+        INU = 2
+        CALL SW2S_LMDAR4(INU, PAER, flag_aer,&
+             tauaero(:,:,2,:), pizaero(:,:,2,:), cgaero(:,:,2,:),&
+             ZAKI, PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,&
+             ZDSIG, POMEGAA, ZOZ, ZRMU, ZSEC, PTAUA, ZUD,&
+             PWV, PQS,&
+             ZFDOWN, ZFUP)
+
+        DO JK = 1 , KFLEV+1
+           DO JL = 1, KDLON
+              ZFSUP_AERO(JL,JK,4) = (ZFUP(JL,JK)   + ZFU(JL,JK)) * ZFACT(JL)
+              ZFSDN_AERO(JL,JK,4) = (ZFDOWN(JL,JK) + ZFD(JL,JK)) * ZFACT(JL) 
+           ENDDO
+        ENDDO
+  
+      ENDIF ! ok_ade .and. ok_aie
+
+     IF (ok_aie) THEN
+        ! cloudy-sky with total aerosols for indirect effect 
+        ! and natural aerosols for direct effect
+        ! PTAUA
+        ! CAS AER (3)
+        flag_aer=1.0
+        CALL SWU_LMDAR4(PSCT,PCLDSW,PPMB,PPSOL,&
+             PRMU0,PFRAC,PTAVE,PWV,&
+             ZAKI,ZCLD,ZCLEAR,ZDSIG,ZFACT,ZRMU,ZSEC,ZUD)
+        INU = 1
+        CALL SW1S_LMDAR4(INU, PAER, flag_aer,&
+             tauaero(:,:,3,:), pizaero(:,:,3,:), cgaero(:,:,3,:),&
+             PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,&
+             ZDSIG, POMEGAA, ZOZ, ZRMU, ZSEC, PTAUA, ZUD,&
+             ZFD, ZFU)
+        INU = 2
+        CALL SW2S_LMDAR4(INU, PAER, flag_aer,&
+             tauaero(:,:,3,:), pizaero(:,:,3,:), cgaero(:,:,3,:),&
+             ZAKI, PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,&
+             ZDSIG, POMEGAA, ZOZ, ZRMU, ZSEC, PTAUA, ZUD,&
+             PWV, PQS,&
+             ZFDOWN, ZFUP)
+  
+        DO JK = 1 , KFLEV+1
+           DO JL = 1, KDLON
+              ZFSUP_AERO(JL,JK,5) = (ZFUP(JL,JK)   + ZFU(JL,JK)) * ZFACT(JL)
+              ZFSDN_AERO(JL,JK,5) = (ZFDOWN(JL,JK) + ZFD(JL,JK)) * ZFACT(JL) 
+           ENDDO
+        ENDDO
+
+     ENDIF ! ok_aie      
+
+     ENDIF !--if flag_aerosol GT 0 OR flag_aerosol_strat GT 0
+
+     itapsw = 0
+  ENDIF
+  itapsw = itapsw + 1
+
+  IF  ( AEROSOLFEEDBACK_ACTIVE .AND. (flag_aerosol.GT.0 .OR. flag_aerosol_strat.GT.0) ) THEN
+  IF ( ok_ade .and. ok_aie  ) THEN
+    ZFSUP(:,:) =    ZFSUP_AERO(:,:,4)
+    ZFSDN(:,:) =    ZFSDN_AERO(:,:,4)
+    ZFSUP0(:,:) =   ZFSUP0_AERO(:,:,2)
+    ZFSDN0(:,:) =   ZFSDN0_AERO(:,:,2)
+  ENDIF
+
+  IF ( ok_ade .and. (.not. ok_aie) )  THEN
+    ZFSUP(:,:) =    ZFSUP_AERO(:,:,2)
+    ZFSDN(:,:) =    ZFSDN_AERO(:,:,2)
+    ZFSUP0(:,:) =   ZFSUP0_AERO(:,:,2)
+    ZFSDN0(:,:) =   ZFSDN0_AERO(:,:,2)
+  ENDIF
+
+  IF ( (.not. ok_ade) .and. ok_aie  )  THEN
+    ZFSUP(:,:) =    ZFSUP_AERO(:,:,5)
+    ZFSDN(:,:) =    ZFSDN_AERO(:,:,5)
+    ZFSUP0(:,:) =   ZFSUP0_AERO(:,:,3)
+    ZFSDN0(:,:) =   ZFSDN0_AERO(:,:,3)
+  ENDIF
+
+  IF ((.not. ok_ade) .and. (.not. ok_aie)) THEN
+    ZFSUP(:,:) =    ZFSUP_AERO(:,:,3)
+    ZFSDN(:,:) =    ZFSDN_AERO(:,:,3)
+    ZFSUP0(:,:) =   ZFSUP0_AERO(:,:,3)
+    ZFSDN0(:,:) =   ZFSDN0_AERO(:,:,3)
+  ENDIF
+
+! MS the following allows to compute the forcing diagostics without
+! letting the aerosol forcing act on the meteorology
+! SEE logic above
+  ELSE 
+    ZFSUP(:,:) =    ZFSUP_AERO(:,:,1)
+    ZFSDN(:,:) =    ZFSDN_AERO(:,:,1)
+    ZFSUP0(:,:) =   ZFSUP0_AERO(:,:,1)
+    ZFSDN0(:,:) =   ZFSDN0_AERO(:,:,1)
+  ENDIF
+
+! Now computes heating rates
+  DO k = 1, KFLEV
+     kpl1 = k+1
+     DO i = 1, KDLON
+        PHEAT(i,k) = -(ZFSUP(i,kpl1)-ZFSUP(i,k))-(ZFSDN(i,k)-ZFSDN(i,kpl1))
+        PHEAT(i,k) = PHEAT(i,k) * RDAY*RG/RCPD / PDP(i,k)
+        PHEAT0(i,k) = -(ZFSUP0(i,kpl1)-ZFSUP0(i,k))-(ZFSDN0(i,k)-ZFSDN0(i,kpl1))
+        PHEAT0(i,k) = PHEAT0(i,k) * RDAY*RG/RCPD / PDP(i,k)
+     ENDDO
+  ENDDO
+
+  DO i = 1, KDLON
+! effective SW surface albedo calculation
+     PALBPLA(i) = ZFSUP(i,KFLEV+1)/(ZFSDN(i,KFLEV+1)+1.0e-20)
+     
+! clear sky net fluxes at TOA and SRF
+     PSOLSW0(i) = ZFSDN0(i,1) - ZFSUP0(i,1)
+     PTOPSW0(i) = ZFSDN0(i,KFLEV+1) - ZFSUP0(i,KFLEV+1)
+
+! cloudy sky net fluxes at TOA and SRF
+     PSOLSW(i) = ZFSDN(i,1) - ZFSUP(i,1)
+     PTOPSW(i) = ZFSDN(i,KFLEV+1) - ZFSUP(i,KFLEV+1)
+
+! net anthropogenic forcing direct and 1st indirect effect diagnostics
+! requires a natural aerosol field read and used 
+! Difference of net fluxes from double call to radiation
+
+IF (ok_ade) THEN
+
+! indices 1: natural; 2 anthropogenic 
+
+! TOA/SRF all sky natural forcing
+     PSOLSWAERO(i,1) = (ZFSDN_AERO(i,1,3) - ZFSUP_AERO(i,1,3))-(ZFSDN_AERO(i,1,1) - ZFSUP_AERO(i,1,1))
+     PTOPSWAERO(i,1) = (ZFSDN_AERO(i,KFLEV+1,3) - ZFSUP_AERO(i,KFLEV+1,3))- (ZFSDN_AERO(i,KFLEV+1,1) - ZFSUP_AERO(i,KFLEV+1,1))
+
+! TOA/SRF clear sky natural forcing
+     PSOLSW0AERO(i,1) = (ZFSDN0_AERO(i,1,3) - ZFSUP0_AERO(i,1,3))-(ZFSDN0_AERO(i,1,1) - ZFSUP0_AERO(i,1,1))
+     PTOPSW0AERO(i,1) = (ZFSDN0_AERO(i,KFLEV+1,3) - ZFSUP0_AERO(i,KFLEV+1,3))-(ZFSDN0_AERO(i,KFLEV+1,1) - ZFSUP0_AERO(i,KFLEV+1,1))
+
+   IF (ok_aie) THEN 
+
+! TOA/SRF all sky anthropogenic forcing
+     PSOLSWAERO(i,2) = (ZFSDN_AERO(i,1,4) - ZFSUP_AERO(i,1,4))-(ZFSDN_AERO(i,1,5) - ZFSUP_AERO(i,1,5))
+     PTOPSWAERO(i,2) = (ZFSDN_AERO(i,KFLEV+1,4) - ZFSUP_AERO(i,KFLEV+1,4))- (ZFSDN_AERO(i,KFLEV+1,5) - ZFSUP_AERO(i,KFLEV+1,5))
+
+   ELSE 
+
+! TOA/SRF all sky anthropogenic forcing
+     PSOLSWAERO(i,2) = (ZFSDN_AERO(i,1,2) - ZFSUP_AERO(i,1,2))-(ZFSDN_AERO(i,1,3) - ZFSUP_AERO(i,1,3))
+     PTOPSWAERO(i,2) = (ZFSDN_AERO(i,KFLEV+1,2) - ZFSUP_AERO(i,KFLEV+1,2))- (ZFSDN_AERO(i,KFLEV+1,3) - ZFSUP_AERO(i,KFLEV+1,3))
+
+   ENDIF
+
+! TOA/SRF clear sky anthropogenic forcing
+     PSOLSW0AERO(i,2) = (ZFSDN0_AERO(i,1,2) - ZFSUP0_AERO(i,1,2))-(ZFSDN0_AERO(i,1,3) - ZFSUP0_AERO(i,1,3))
+     PTOPSW0AERO(i,2) = (ZFSDN0_AERO(i,KFLEV+1,2) - ZFSUP0_AERO(i,KFLEV+1,2))-(ZFSDN0_AERO(i,KFLEV+1,3) - ZFSUP0_AERO(i,KFLEV+1,3))
+
+! direct anthropogenic forcing , as in old LMDzT, however differences of net fluxes
+     PSOLSWADAERO(i) = PSOLSWAERO(i,2)
+     PTOPSWADAERO(i) = PTOPSWAERO(i,2)
+     PSOLSWAD0AERO(i) = PSOLSW0AERO(i,2)
+     PTOPSWAD0AERO(i) = PTOPSW0AERO(i,2)
+
+! OB: these diagnostics may not always work but who need them
+! Cloud forcing indices 1: natural; 2 anthropogenic; 3: zero aerosol direct effect
+! Instantaneously computed cloudy sky direct aerosol effect, cloud forcing due to aerosols above clouds
+! natural
+     PSOLSWCFAERO(i,1) = PSOLSWAERO(i,1) - PSOLSW0AERO(i,1)
+     PTOPSWCFAERO(i,1) = PTOPSWAERO(i,1) - PTOPSW0AERO(i,1)
+
+! Instantaneously computed cloudy SKY DIRECT aerosol effect, cloud forcing due to aerosols above clouds
+! anthropogenic
+     PSOLSWCFAERO(i,2) = PSOLSWAERO(i,2) - PSOLSW0AERO(i,2)
+     PTOPSWCFAERO(i,2) = PTOPSWAERO(i,2) - PTOPSW0AERO(i,2)
+
+! Cloudforcing without aerosol
+! zero
+     PSOLSWCFAERO(i,3) = (ZFSDN_AERO(i,1,1) - ZFSUP_AERO(i,1,1))-(ZFSDN0_AERO(i,1,1) - ZFSUP0_AERO(i,1,1))
+     PTOPSWCFAERO(i,3) = (ZFSDN_AERO(i,KFLEV+1,1) - ZFSUP_AERO(i,KFLEV+1,1))- (ZFSDN0_AERO(i,KFLEV+1,1) - ZFSUP0_AERO(i,KFLEV+1,1))
+
+ENDIF
+
+IF (ok_aie) THEN
+   IF (ok_ade) THEN 
+     PSOLSWAIAERO(i) = (ZFSDN_AERO(i,1,4) - ZFSUP_AERO(i,1,4))-(ZFSDN_AERO(i,1,2) - ZFSUP_AERO(i,1,2))
+     PTOPSWAIAERO(i) = (ZFSDN_AERO(i,KFLEV+1,4) - ZFSUP_AERO(i,KFLEV+1,4))-(ZFSDN_AERO(i,KFLEV+1,2) - ZFSUP_AERO(i,KFLEV+1,2))
+   ELSE 
+     PSOLSWAIAERO(i) = (ZFSDN_AERO(i,1,5) - ZFSUP_AERO(i,1,5))-(ZFSDN_AERO(i,1,3) - ZFSUP_AERO(i,1,3))
+     PTOPSWAIAERO(i) = (ZFSDN_AERO(i,KFLEV+1,5) - ZFSUP_AERO(i,KFLEV+1,5))-(ZFSDN_AERO(i,KFLEV+1,3) - ZFSUP_AERO(i,KFLEV+1,3))
+   ENDIF
+ENDIF
+
+ENDDO
+
+END SUBROUTINE SW_AEROAR4
Index: DZ6/trunk/libf/phylmd/tend_to_tke.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/tend_to_tke.F90	(revision 5267)
+++ 	(revision )
@@ -1,149 +1,0 @@
-!***************************************************************************************
-! tend_to_tke.F90
-!*************
-!
-! Subroutine that adds a tendency on the TKE created by the 
-! fluxes of momentum retrieved from the wind speed tendencies
-! of the physics.
-! 
-! The basic concept is the following:
-! the TKE equation writes  de/dt = -u'w' du/dz -v'w' dv/dz +g/theta dtheta/dz +......
-!
-!
-! We expect contributions to the term u'w' and v'w' that do not come from the Yamada
-! scheme, for instance: gravity waves, drag from high vegetation..... These contributions
-! need to be accounted for.
-! we explicitely calculate the fluxes, integrating the wind speed 
-!                        tendency from the top of the atmospher
-!
-!
-!
-! contacts: Frederic Hourdin, Etienne Vignon
-!
-! History:
-!---------
-! - 1st redaction, Etienne, 15/10/2016
-! Ajout des 4 sous surfaces pour la tke
-! on sort l'ajout des tendances du if sur les deux cas, pour ne pas
-! dupliuqer les lignes
-! on enleve le pas de temps qui disprait dans les calculs
-!
-!
-!**************************************************************************************
-
- SUBROUTINE tend_to_tke(dt,plev,exner,temp,windu,windv,dt_a,du_a,dv_a,pctsrf,tke)
-
- USE dimphy, ONLY: klon, klev
- USE indice_sol_mod, ONLY: nbsrf
-
-IMPLICIT NONE
-INCLUDE "YOMCST.h"
-
-! Declarations
-!==============
-
-
-! Inputs
-!-------
-  REAL dt                   ! Time step [s]
-  REAL plev(klon,klev+1)    ! inter-layer pressure [Pa]
-  REAL temp(klon,klev)      ! temperature [K], grid-cell average or for a one subsurface
-  REAL windu(klon,klev)     ! zonal wind [m/s], grid-cell average or for a one subsurface
-  REAL windv(klon,klev)     ! meridonal wind [m/s], grid-cell average or for a one subsurface
-  REAL exner(klon,klev)     ! Fonction d'Exner = T/theta
-  REAL dt_a(klon,klev)      ! Temperature tendency [K], grid-cell average or for a one subsurface
-  REAL du_a(klon,klev)      ! Zonal wind speed tendency [m/s], grid-cell average or for a one subsurface
-  REAL dv_a(klon,klev)      ! Meridional wind speed tendency [m/s], grid-cell average or for a one subsurface
-  REAL pctsrf(klon,nbsrf+1)       ! Turbulent Kinetic energy [m2/s2], grid-cell average or for a subsurface
-
-! Inputs/Outputs
-!---------------
-  REAL tke(klon,klev+1,nbsrf+1)       ! Turbulent Kinetic energy [m2/s2], grid-cell average or for a subsurface
-
-
-! Local
-!-------
-
-
-  INTEGER i,k,isrf                 ! indices
-  REAL    masse(klon,klev)          ! mass in the layers [kg/m2]
-  REAL    unsmasse(klon,klev+1)     ! linear mass in the layers [kg/m2]
-  REAL    flux_rhotw(klon,klev+1)   ! flux massique de tempe. pot. rho*u'*theta'
-  REAL    flux_rhouw(klon,klev+1)   ! flux massique de quantit?? de mouvement rho*u'*w' [kg/m/s2]
-  REAL    flux_rhovw(klon,klev+1)   ! flux massique de quantit?? de mouvement rho*v'*w' [kg/m/s2]
-  REAL    tendt(klon,klev)        ! new temperature tke tendency [m2/s2/s]
-  REAL    tendu(klon,klev)        ! new zonal tke tendency [m2/s2/s]
-  REAL    tendv(klon,klev)        ! new meridonal tke tendency [m2/s2/s]
-  
-
-
-
-! First calculations:
-!=====================
-
-      unsmasse(:,:)=0.
-      DO k=1,klev
-         masse(:,k)=(plev(:,k)-plev(:,k+1))/RG
-         unsmasse(:,k)=unsmasse(:,k)+0.5/masse(:,k)
-         unsmasse(:,k+1)=unsmasse(:,k+1)+0.5/masse(:,k)
-      END DO
-
-      tendu(:,:)=0.0
-      tendv(:,:)=0.0
-
-! Method 1: Calculation of fluxes using a downward integration
-!============================================================
-
-
- 
-! Flux calculation
-
- flux_rhotw(:,klev+1)=0.
- flux_rhouw(:,klev+1)=0.
- flux_rhovw(:,klev+1)=0.
-
-   DO k=klev,1,-1
-      flux_rhotw(:,k)=flux_rhotw(:,k+1)+masse(:,k)*dt_a(:,k)/exner(:,k)
-      flux_rhouw(:,k)=flux_rhouw(:,k+1)+masse(:,k)*du_a(:,k)
-      flux_rhovw(:,k)=flux_rhovw(:,k+1)+masse(:,k)*dv_a(:,k)
-   ENDDO
-
-
-! TKE update:
-
-   DO k=2,klev
-      tendt(:,k)=-flux_rhotw(:,k)*(exner(:,k)-exner(:,k-1))*unsmasse(:,k)*RCPD
-      tendu(:,k)=-flux_rhouw(:,k)*(windu(:,k)-windu(:,k-1))*unsmasse(:,k)
-      tendv(:,k)=-flux_rhovw(:,k)*(windv(:,k)-windv(:,k-1))*unsmasse(:,k)
-   ENDDO
-   tendt(:,1)=-flux_rhotw(:,1)*(exner(:,1)-1.)*unsmasse(:,1)*RCPD
-   tendu(:,1)=-1.*flux_rhouw(:,1)*windu(:,1)*unsmasse(:,1)
-   tendv(:,1)=-1.*flux_rhovw(:,1)*windv(:,1)*unsmasse(:,1)
-
-
- DO isrf=1,nbsrf
-    DO k=1,klev
-       DO i=1,klon
-          IF (pctsrf(i,isrf)>0.) THEN
-            tke(i,k,isrf)= tke(i,k,isrf)+tendu(i,k)+tendv(i,k)+tendt(i,k)
-            tke(i,k,isrf)= max(tke(i,k,isrf),1.e-10)
-          ENDIF
-       ENDDO
-    ENDDO
- ENDDO
-
-
-!  IF (klon==1) THEN
-!  CALL iophys_ecrit('u',klev,'u','',windu)
-!  CALL iophys_ecrit('v',klev,'v','',windu)
-!  CALL iophys_ecrit('t',klev,'t','',temp)
-!  CALL iophys_ecrit('tke1',klev,'tke1','',tke(:,1:klev,1))
-!  CALL iophys_ecrit('tke2',klev,'tke2','',tke(:,1:klev,2))
-!  CALL iophys_ecrit('tke3',klev,'tke3','',tke(:,1:klev,3))
-!  CALL iophys_ecrit('tke4',klev,'tke4','',tke(:,1:klev,4))
-!  CALL iophys_ecrit('theta',klev,'theta','',temp/exner)
-!  CALL iophys_ecrit('Duv',klev,'Duv','',tendu(:,1:klev)+tendv(:,1:klev))
-!  CALL iophys_ecrit('Dt',klev,'Dt','',tendt(:,1:klev))
-!  ENDIF
-
- END SUBROUTINE tend_to_tke
Index: /LMDZ6/trunk/libf/phylmd/tend_to_tke.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/tend_to_tke.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/tend_to_tke.f90	(revision 5268)
@@ -0,0 +1,149 @@
+!***************************************************************************************
+! tend_to_tke.F90
+!*************
+!
+! Subroutine that adds a tendency on the TKE created by the 
+! fluxes of momentum retrieved from the wind speed tendencies
+! of the physics.
+! 
+! The basic concept is the following:
+! the TKE equation writes  de/dt = -u'w' du/dz -v'w' dv/dz +g/theta dtheta/dz +......
+!
+!
+! We expect contributions to the term u'w' and v'w' that do not come from the Yamada
+! scheme, for instance: gravity waves, drag from high vegetation..... These contributions
+! need to be accounted for.
+! we explicitely calculate the fluxes, integrating the wind speed 
+!                        tendency from the top of the atmospher
+!
+!
+!
+! contacts: Frederic Hourdin, Etienne Vignon
+!
+! History:
+!---------
+! - 1st redaction, Etienne, 15/10/2016
+! Ajout des 4 sous surfaces pour la tke
+! on sort l'ajout des tendances du if sur les deux cas, pour ne pas
+! dupliuqer les lignes
+! on enleve le pas de temps qui disprait dans les calculs
+!
+!
+!**************************************************************************************
+
+ SUBROUTINE tend_to_tke(dt,plev,exner,temp,windu,windv,dt_a,du_a,dv_a,pctsrf,tke)
+
+ USE dimphy, ONLY: klon, klev
+ USE indice_sol_mod, ONLY: nbsrf
+
+IMPLICIT NONE
+INCLUDE "YOMCST.h"
+
+! Declarations
+!==============
+
+
+! Inputs
+!-------
+  REAL dt                   ! Time step [s]
+  REAL plev(klon,klev+1)    ! inter-layer pressure [Pa]
+  REAL temp(klon,klev)      ! temperature [K], grid-cell average or for a one subsurface
+  REAL windu(klon,klev)     ! zonal wind [m/s], grid-cell average or for a one subsurface
+  REAL windv(klon,klev)     ! meridonal wind [m/s], grid-cell average or for a one subsurface
+  REAL exner(klon,klev)     ! Fonction d'Exner = T/theta
+  REAL dt_a(klon,klev)      ! Temperature tendency [K], grid-cell average or for a one subsurface
+  REAL du_a(klon,klev)      ! Zonal wind speed tendency [m/s], grid-cell average or for a one subsurface
+  REAL dv_a(klon,klev)      ! Meridional wind speed tendency [m/s], grid-cell average or for a one subsurface
+  REAL pctsrf(klon,nbsrf+1)       ! Turbulent Kinetic energy [m2/s2], grid-cell average or for a subsurface
+
+! Inputs/Outputs
+!---------------
+  REAL tke(klon,klev+1,nbsrf+1)       ! Turbulent Kinetic energy [m2/s2], grid-cell average or for a subsurface
+
+
+! Local
+!-------
+
+
+  INTEGER i,k,isrf                 ! indices
+  REAL    masse(klon,klev)          ! mass in the layers [kg/m2]
+  REAL    unsmasse(klon,klev+1)     ! linear mass in the layers [kg/m2]
+  REAL    flux_rhotw(klon,klev+1)   ! flux massique de tempe. pot. rho*u'*theta'
+  REAL    flux_rhouw(klon,klev+1)   ! flux massique de quantit?? de mouvement rho*u'*w' [kg/m/s2]
+  REAL    flux_rhovw(klon,klev+1)   ! flux massique de quantit?? de mouvement rho*v'*w' [kg/m/s2]
+  REAL    tendt(klon,klev)        ! new temperature tke tendency [m2/s2/s]
+  REAL    tendu(klon,klev)        ! new zonal tke tendency [m2/s2/s]
+  REAL    tendv(klon,klev)        ! new meridonal tke tendency [m2/s2/s]
+  
+
+
+
+! First calculations:
+!=====================
+
+      unsmasse(:,:)=0.
+      DO k=1,klev
+         masse(:,k)=(plev(:,k)-plev(:,k+1))/RG
+         unsmasse(:,k)=unsmasse(:,k)+0.5/masse(:,k)
+         unsmasse(:,k+1)=unsmasse(:,k+1)+0.5/masse(:,k)
+      END DO
+
+      tendu(:,:)=0.0
+      tendv(:,:)=0.0
+
+! Method 1: Calculation of fluxes using a downward integration
+!============================================================
+
+
+ 
+! Flux calculation
+
+ flux_rhotw(:,klev+1)=0.
+ flux_rhouw(:,klev+1)=0.
+ flux_rhovw(:,klev+1)=0.
+
+   DO k=klev,1,-1
+      flux_rhotw(:,k)=flux_rhotw(:,k+1)+masse(:,k)*dt_a(:,k)/exner(:,k)
+      flux_rhouw(:,k)=flux_rhouw(:,k+1)+masse(:,k)*du_a(:,k)
+      flux_rhovw(:,k)=flux_rhovw(:,k+1)+masse(:,k)*dv_a(:,k)
+   ENDDO
+
+
+! TKE update:
+
+   DO k=2,klev
+      tendt(:,k)=-flux_rhotw(:,k)*(exner(:,k)-exner(:,k-1))*unsmasse(:,k)*RCPD
+      tendu(:,k)=-flux_rhouw(:,k)*(windu(:,k)-windu(:,k-1))*unsmasse(:,k)
+      tendv(:,k)=-flux_rhovw(:,k)*(windv(:,k)-windv(:,k-1))*unsmasse(:,k)
+   ENDDO
+   tendt(:,1)=-flux_rhotw(:,1)*(exner(:,1)-1.)*unsmasse(:,1)*RCPD
+   tendu(:,1)=-1.*flux_rhouw(:,1)*windu(:,1)*unsmasse(:,1)
+   tendv(:,1)=-1.*flux_rhovw(:,1)*windv(:,1)*unsmasse(:,1)
+
+
+ DO isrf=1,nbsrf
+    DO k=1,klev
+       DO i=1,klon
+          IF (pctsrf(i,isrf)>0.) THEN
+            tke(i,k,isrf)= tke(i,k,isrf)+tendu(i,k)+tendv(i,k)+tendt(i,k)
+            tke(i,k,isrf)= max(tke(i,k,isrf),1.e-10)
+          ENDIF
+       ENDDO
+    ENDDO
+ ENDDO
+
+
+!  IF (klon==1) THEN
+!  CALL iophys_ecrit('u',klev,'u','',windu)
+!  CALL iophys_ecrit('v',klev,'v','',windu)
+!  CALL iophys_ecrit('t',klev,'t','',temp)
+!  CALL iophys_ecrit('tke1',klev,'tke1','',tke(:,1:klev,1))
+!  CALL iophys_ecrit('tke2',klev,'tke2','',tke(:,1:klev,2))
+!  CALL iophys_ecrit('tke3',klev,'tke3','',tke(:,1:klev,3))
+!  CALL iophys_ecrit('tke4',klev,'tke4','',tke(:,1:klev,4))
+!  CALL iophys_ecrit('theta',klev,'theta','',temp/exner)
+!  CALL iophys_ecrit('Duv',klev,'Duv','',tendu(:,1:klev)+tendv(:,1:klev))
+!  CALL iophys_ecrit('Dt',klev,'Dt','',tendt(:,1:klev))
+!  ENDIF
+
+ END SUBROUTINE tend_to_tke
Index: DZ6/trunk/libf/phylmd/tilft43.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/tilft43.F90	(revision 5267)
+++ 	(revision )
@@ -1,99 +1,0 @@
-
-! $Header$
-
-SUBROUTINE tlift43(p, t, q, qs, gz, icb, nk, tvp, tpk, clw, nd, nl, kk)
-  IMPLICIT NONE
-  REAL gz(nd), tpk(nd), clw(nd), p(nd)
-  REAL t(nd), q(nd), qs(nd), tvp(nd), lv0
-  INTEGER icb, nk, nd, nl, kk
-  REAL cpd, cpv,  cl, g, rowl, gravity, cpvmcl, eps, epsi
-  REAL ah0, cpp, cpinv, tg, qg, alv, s, ahg, tc, denom, es
-  INTEGER i, nst, nsb, j 
-  ! ***   ASSIGN VALUES OF THERMODYNAMIC CONSTANTS     ***
-
-  ! -- sb:
-  ! !      CPD=1005.7
-  ! !      CPV=1870.0
-  ! !      CL=4190.0
-  ! !      RV=461.5
-  ! !      RD=287.04
-  ! !      LV0=2.501E6
-  ! !      G=9.8
-  ! !      ROWL=1000.0
-  ! ajouts:
-  include "YOMCST.h"
-  cpd = rcpd
-  cpv = rcpv
-  cl = rcw
-  lv0 = rlvtt
-  g = rg
-  rowl = ratm/100.
-  gravity = rg !sb: Pr que gravite ne devienne pas humidite!
-  ! sb --
-
-  cpvmcl = cl - cpv
-  eps = rd/rv
-  epsi = 1./eps
-
-  ! ***  CALCULATE CERTAIN PARCEL QUANTITIES, INCLUDING STATIC ENERGY   ***
-
-  ah0 = (cpd*(1.-q(nk))+cl*q(nk))*t(nk) + q(nk)*(lv0-cpvmcl*(t(nk)-273.15)) + &
-    gz(nk)
-  cpp = cpd*(1.-q(nk)) + q(nk)*cpv
-  cpinv = 1./cpp
-
-  IF (kk==1) THEN
-
-    ! ***   CALCULATE LIFTED PARCEL QUANTITIES BELOW CLOUD BASE   ***
-
-    DO i = 1, icb - 1
-      clw(i) = 0.0
-    END DO
-    DO i = nk, icb - 1
-      tpk(i) = t(nk) - (gz(i)-gz(nk))*cpinv
-      tvp(i) = tpk(i)*(1.+q(nk)*epsi)
-    END DO
-  END IF
-
-  ! ***  FIND LIFTED PARCEL QUANTITIES ABOVE CLOUD BASE    ***
-
-  nst = icb
-  nsb = icb
-  IF (kk==2) THEN
-    nst = nl
-    nsb = icb + 1
-  END IF
-  DO i = nsb, nst
-    tg = t(i)
-    qg = qs(i)
-    alv = lv0 - cpvmcl*(t(i)-273.15)
-    DO j = 1, 2
-      s = cpd + alv*alv*qg/(rv*t(i)*t(i))
-      s = 1./s
-      ahg = cpd*tg + (cl-cpd)*q(nk)*t(i) + alv*qg + gz(i)
-      tg = tg + s*(ah0-ahg)
-      tg = max(tg, 35.0)
-      tc = tg - 273.15
-      denom = 243.5 + tc
-      IF (tc>=0.0) THEN
-        es = 6.112*exp(17.67*tc/denom)
-      ELSE
-        es = exp(23.33086-6111.72784/tg+0.15215*log(tg))
-      END IF
-      qg = eps*es/(p(i)-es*(1.-eps))
-    END DO
-    alv = lv0 - cpvmcl*(t(i)-273.15)
-    tpk(i) = (ah0-(cl-cpd)*q(nk)*t(i)-gz(i)-alv*qg)/cpd
-    clw(i) = q(nk) - qg
-    clw(i) = max(0.0, clw(i))
-    rg = qg/(1.-q(nk))
-    tvp(i) = tpk(i)*(1.+rg*epsi)
-  END DO
-
-  ! -- sb:
-  rg = gravity ! RG redevient la gravite de YOMCST (sb)
-  ! sb --
-
-  RETURN
-END SUBROUTINE tlift43
-
Index: /LMDZ6/trunk/libf/phylmd/tilft43.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/tilft43.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/tilft43.f90	(revision 5268)
@@ -0,0 +1,99 @@
+
+! $Header$
+
+SUBROUTINE tlift43(p, t, q, qs, gz, icb, nk, tvp, tpk, clw, nd, nl, kk)
+  IMPLICIT NONE
+  REAL gz(nd), tpk(nd), clw(nd), p(nd)
+  REAL t(nd), q(nd), qs(nd), tvp(nd), lv0
+  INTEGER icb, nk, nd, nl, kk
+  REAL cpd, cpv,  cl, g, rowl, gravity, cpvmcl, eps, epsi
+  REAL ah0, cpp, cpinv, tg, qg, alv, s, ahg, tc, denom, es
+  INTEGER i, nst, nsb, j 
+  ! ***   ASSIGN VALUES OF THERMODYNAMIC CONSTANTS     ***
+
+  ! -- sb:
+  ! !      CPD=1005.7
+  ! !      CPV=1870.0
+  ! !      CL=4190.0
+  ! !      RV=461.5
+  ! !      RD=287.04
+  ! !      LV0=2.501E6
+  ! !      G=9.8
+  ! !      ROWL=1000.0
+  ! ajouts:
+  include "YOMCST.h"
+  cpd = rcpd
+  cpv = rcpv
+  cl = rcw
+  lv0 = rlvtt
+  g = rg
+  rowl = ratm/100.
+  gravity = rg !sb: Pr que gravite ne devienne pas humidite!
+  ! sb --
+
+  cpvmcl = cl - cpv
+  eps = rd/rv
+  epsi = 1./eps
+
+  ! ***  CALCULATE CERTAIN PARCEL QUANTITIES, INCLUDING STATIC ENERGY   ***
+
+  ah0 = (cpd*(1.-q(nk))+cl*q(nk))*t(nk) + q(nk)*(lv0-cpvmcl*(t(nk)-273.15)) + &
+    gz(nk)
+  cpp = cpd*(1.-q(nk)) + q(nk)*cpv
+  cpinv = 1./cpp
+
+  IF (kk==1) THEN
+
+    ! ***   CALCULATE LIFTED PARCEL QUANTITIES BELOW CLOUD BASE   ***
+
+    DO i = 1, icb - 1
+      clw(i) = 0.0
+    END DO
+    DO i = nk, icb - 1
+      tpk(i) = t(nk) - (gz(i)-gz(nk))*cpinv
+      tvp(i) = tpk(i)*(1.+q(nk)*epsi)
+    END DO
+  END IF
+
+  ! ***  FIND LIFTED PARCEL QUANTITIES ABOVE CLOUD BASE    ***
+
+  nst = icb
+  nsb = icb
+  IF (kk==2) THEN
+    nst = nl
+    nsb = icb + 1
+  END IF
+  DO i = nsb, nst
+    tg = t(i)
+    qg = qs(i)
+    alv = lv0 - cpvmcl*(t(i)-273.15)
+    DO j = 1, 2
+      s = cpd + alv*alv*qg/(rv*t(i)*t(i))
+      s = 1./s
+      ahg = cpd*tg + (cl-cpd)*q(nk)*t(i) + alv*qg + gz(i)
+      tg = tg + s*(ah0-ahg)
+      tg = max(tg, 35.0)
+      tc = tg - 273.15
+      denom = 243.5 + tc
+      IF (tc>=0.0) THEN
+        es = 6.112*exp(17.67*tc/denom)
+      ELSE
+        es = exp(23.33086-6111.72784/tg+0.15215*log(tg))
+      END IF
+      qg = eps*es/(p(i)-es*(1.-eps))
+    END DO
+    alv = lv0 - cpvmcl*(t(i)-273.15)
+    tpk(i) = (ah0-(cl-cpd)*q(nk)*t(i)-gz(i)-alv*qg)/cpd
+    clw(i) = q(nk) - qg
+    clw(i) = max(0.0, clw(i))
+    rg = qg/(1.-q(nk))
+    tvp(i) = tpk(i)*(1.+rg*epsi)
+  END DO
+
+  ! -- sb:
+  rg = gravity ! RG redevient la gravite de YOMCST (sb)
+  ! sb --
+
+  RETURN
+END SUBROUTINE tlift43
+
Index: DZ6/trunk/libf/phylmd/time_phylmdz_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/time_phylmdz_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,112 +1,0 @@
-!
-! $Id$
-!
-MODULE time_phylmdz_mod
-
-    IMPLICIT NONE
-    REAL,SAVE    :: pdtphys     ! physics time step (s)
-!$OMP THREADPRIVATE(pdtphys)
-    INTEGER,SAVE :: day_step_phy    ! number of physical steps per day
-!$OMP THREADPRIVATE(day_step_phy)
-    INTEGER,SAVE :: ndays       ! number of days to run
-!$OMP THREADPRIVATE(ndays)
-    INTEGER,SAVE :: annee_ref   ! reference year from the origin
-!$OMP THREADPRIVATE(annee_ref)
-    INTEGER,SAVE :: day_ref     ! reference year of the origin
-!$OMP THREADPRIVATE(day_ref)
-    INTEGER,SAVE :: day_ini     ! initial day of the run starting from 1st january of annee_ref
-!$OMP THREADPRIVATE(day_ini)
-    INTEGER,SAVE :: day_end     ! final day of the run starting from 1st january of annee_ref
-!$OMP THREADPRIVATE(day_end)
-    REAL,SAVE    :: start_time  ! starting time from the begining of the initial day
-!$OMP THREADPRIVATE(start_time)
-    INTEGER,SAVE :: raz_date
-!$OMP THREADPRIVATE(raz_date)
-
-    INTEGER,SAVE :: itau_phy     ! number of physiq iteration from origin
-!$OMP THREADPRIVATE(itau_phy)
-    INTEGER,SAVE :: itaufin_phy      ! final iteration (in itau_phy steps)
-!$OMP THREADPRIVATE(itaufin_phy)
-    REAL,SAVE    :: current_time ! current elapsed time in seconds from the begining of the run
-!$OMP THREADPRIVATE(current_time)
-    
-
-CONTAINS
-
-  SUBROUTINE init_time(annee_ref_, day_ref_, day_ini_, start_time_, &
-                       ndays_, pdtphys_)
-  USE ioipsl_getin_p_mod, ONLY : getin_p
-  USE phys_cal_mod, ONLY: phys_cal_init
-  IMPLICIT NONE
-  INCLUDE 'YOMCST.h'
-    INTEGER, INTENT(IN) :: annee_ref_  
-    INTEGER, INTENT(IN) :: day_ref_    
-    INTEGER, INTENT(IN) :: day_ini_    
-    REAL,    INTENT(IN) :: start_time_ 
-    INTEGER, INTENT(IN) :: ndays_      
-    REAL,    INTENT(IN) :: pdtphys_    
-    
-    annee_ref    = annee_ref_
-    day_ref      = day_ref_
-    day_ini      = day_ini_
-    start_time   = start_time_
-    ndays        = ndays_
-    pdtphys      = pdtphys_
-    
-    ! Initialize module variable not inherited from dynamics
-    day_step_phy = NINT(rday/pdtphys)
-    day_end  = day_ini + ndays
-  
-    raz_date = 0
-    CALL getin_p('raz_date', raz_date)
-
-    current_time=0.
-    
-    CALL phys_cal_init(annee_ref,day_ref)
-    
-  END SUBROUTINE init_time
-
-  SUBROUTINE init_iteration(itau_phy_)
-  IMPLICIT NONE
-    INTEGER, INTENT(IN) :: itau_phy_
-    itau_phy=itau_phy_
-    IF (raz_date==1) itau_phy=0
-    
-    itaufin_phy=itau_phy+NINT(ndays/pdtphys)
-    
-  END SUBROUTINE init_iteration
-
-  SUBROUTINE update_time(pdtphys_)
-  ! This subroutine updates the module saved variables.
-  USE ioipsl, ONLY : ymds2ju
-  USE phys_cal_mod, ONLY: phys_cal_update
-  USE print_control_mod, ONLY: lunout
-  IMPLICIT NONE
-  INCLUDE 'YOMCST.h'
-  REAL,INTENT(IN) :: pdtphys_
-  REAL            :: julian_date
-  INTEGER         :: cur_day
-  REAL            :: cur_sec
-
-    ! Check if the physics timestep has changed
-    IF ( ABS( (pdtphys-pdtphys_) / ((pdtphys+pdtphys_)/2))> 10.*EPSILON(pdtphys_)) THEN
-       WRITE(lunout,*) "WARNING ! Physics time step changes from a call to the next",pdtphys_,pdtphys
-       WRITE(lunout,*) "Not sure the physics parametrizations can handle this..."
-    ENDIF
-    pdtphys=pdtphys_
-    
-    ! Update elapsed time since begining of run:
-    current_time = current_time + pdtphys
-    cur_day = int(current_time/rday)
-    cur_sec = current_time - (cur_day * rday) 
-
-    ! Compute corresponding Julian date and update calendar
-    cur_day = cur_day + day_ini
-    cur_sec = cur_sec + (start_time * rday)
-    CALL ymds2ju(annee_ref,1, cur_day, cur_sec, julian_date)
-    CALL phys_cal_update(julian_date)
-    
-  END SUBROUTINE update_time
-
-END MODULE time_phylmdz_mod      
-
Index: /LMDZ6/trunk/libf/phylmd/time_phylmdz_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/time_phylmdz_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/time_phylmdz_mod.f90	(revision 5268)
@@ -0,0 +1,112 @@
+!
+! $Id$
+!
+MODULE time_phylmdz_mod
+
+    IMPLICIT NONE
+    REAL,SAVE    :: pdtphys     ! physics time step (s)
+!$OMP THREADPRIVATE(pdtphys)
+    INTEGER,SAVE :: day_step_phy    ! number of physical steps per day
+!$OMP THREADPRIVATE(day_step_phy)
+    INTEGER,SAVE :: ndays       ! number of days to run
+!$OMP THREADPRIVATE(ndays)
+    INTEGER,SAVE :: annee_ref   ! reference year from the origin
+!$OMP THREADPRIVATE(annee_ref)
+    INTEGER,SAVE :: day_ref     ! reference year of the origin
+!$OMP THREADPRIVATE(day_ref)
+    INTEGER,SAVE :: day_ini     ! initial day of the run starting from 1st january of annee_ref
+!$OMP THREADPRIVATE(day_ini)
+    INTEGER,SAVE :: day_end     ! final day of the run starting from 1st january of annee_ref
+!$OMP THREADPRIVATE(day_end)
+    REAL,SAVE    :: start_time  ! starting time from the begining of the initial day
+!$OMP THREADPRIVATE(start_time)
+    INTEGER,SAVE :: raz_date
+!$OMP THREADPRIVATE(raz_date)
+
+    INTEGER,SAVE :: itau_phy     ! number of physiq iteration from origin
+!$OMP THREADPRIVATE(itau_phy)
+    INTEGER,SAVE :: itaufin_phy      ! final iteration (in itau_phy steps)
+!$OMP THREADPRIVATE(itaufin_phy)
+    REAL,SAVE    :: current_time ! current elapsed time in seconds from the begining of the run
+!$OMP THREADPRIVATE(current_time)
+    
+
+CONTAINS
+
+  SUBROUTINE init_time(annee_ref_, day_ref_, day_ini_, start_time_, &
+                       ndays_, pdtphys_)
+  USE ioipsl_getin_p_mod, ONLY : getin_p
+  USE phys_cal_mod, ONLY: phys_cal_init
+  IMPLICIT NONE
+  INCLUDE 'YOMCST.h'
+    INTEGER, INTENT(IN) :: annee_ref_  
+    INTEGER, INTENT(IN) :: day_ref_    
+    INTEGER, INTENT(IN) :: day_ini_    
+    REAL,    INTENT(IN) :: start_time_ 
+    INTEGER, INTENT(IN) :: ndays_      
+    REAL,    INTENT(IN) :: pdtphys_    
+    
+    annee_ref    = annee_ref_
+    day_ref      = day_ref_
+    day_ini      = day_ini_
+    start_time   = start_time_
+    ndays        = ndays_
+    pdtphys      = pdtphys_
+    
+    ! Initialize module variable not inherited from dynamics
+    day_step_phy = NINT(rday/pdtphys)
+    day_end  = day_ini + ndays
+  
+    raz_date = 0
+    CALL getin_p('raz_date', raz_date)
+
+    current_time=0.
+    
+    CALL phys_cal_init(annee_ref,day_ref)
+    
+  END SUBROUTINE init_time
+
+  SUBROUTINE init_iteration(itau_phy_)
+  IMPLICIT NONE
+    INTEGER, INTENT(IN) :: itau_phy_
+    itau_phy=itau_phy_
+    IF (raz_date==1) itau_phy=0
+    
+    itaufin_phy=itau_phy+NINT(ndays/pdtphys)
+    
+  END SUBROUTINE init_iteration
+
+  SUBROUTINE update_time(pdtphys_)
+  ! This subroutine updates the module saved variables.
+  USE ioipsl, ONLY : ymds2ju
+  USE phys_cal_mod, ONLY: phys_cal_update
+  USE print_control_mod, ONLY: lunout
+  IMPLICIT NONE
+  INCLUDE 'YOMCST.h'
+  REAL,INTENT(IN) :: pdtphys_
+  REAL            :: julian_date
+  INTEGER         :: cur_day
+  REAL            :: cur_sec
+
+    ! Check if the physics timestep has changed
+    IF ( ABS( (pdtphys-pdtphys_) / ((pdtphys+pdtphys_)/2))> 10.*EPSILON(pdtphys_)) THEN
+       WRITE(lunout,*) "WARNING ! Physics time step changes from a call to the next",pdtphys_,pdtphys
+       WRITE(lunout,*) "Not sure the physics parametrizations can handle this..."
+    ENDIF
+    pdtphys=pdtphys_
+    
+    ! Update elapsed time since begining of run:
+    current_time = current_time + pdtphys
+    cur_day = int(current_time/rday)
+    cur_sec = current_time - (cur_day * rday) 
+
+    ! Compute corresponding Julian date and update calendar
+    cur_day = cur_day + day_ini
+    cur_sec = cur_sec + (start_time * rday)
+    CALL ymds2ju(annee_ref,1, cur_day, cur_sec, julian_date)
+    CALL phys_cal_update(julian_date)
+    
+  END SUBROUTINE update_time
+
+END MODULE time_phylmdz_mod      
+
Index: DZ6/trunk/libf/phylmd/tlift.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/tlift.F90	(revision 5267)
+++ 	(revision )
@@ -1,246 +1,0 @@
-
-! $Header$
-
-SUBROUTINE tlift(p, t, rr, rs, gz, plcl, icb, nk, tvp, tpk, clw, nd, nl, &
-    dtvpdt1, dtvpdq1)
-  IMPLICIT NONE
-  ! Argument NK ajoute (jyg) = Niveau de depart de la
-  ! convection
-  INTEGER icb, nk, nd, nl
-  INTEGER,PARAMETER :: na=60
-  REAL gz(nd), tpk(nd), clw(nd), plcl
-  REAL t(nd), rr(nd), rs(nd), tvp(nd), p(nd)
-  REAL dtvpdt1(nd), dtvpdq1(nd) ! Derivatives of parcel virtual
-  ! temperature wrt T1 and Q1
-
-  REAL clw_new(na), qi(na)
-  REAL dtpdt1(na), dtpdq1(na) ! Derivatives of parcel temperature
-  ! wrt T1 and Q1
-  REAL gravity, cpd, cpv, cl, ci, cpvmcl, clmci, eps, alv0, alf0
-  REAL cpp, cpinv, ah0, alf, tg, s, ahg, tc, denom, alv, es, esi
-  REAL qsat_new, snew
-  INTEGER icbl, i, imin, j, icb1
-
-  LOGICAL ice_conv
-
-  ! ***   ASSIGN VALUES OF THERMODYNAMIC CONSTANTS     ***
-
-  ! sb        CPD=1005.7
-  ! sb      CPV=1870.0
-  ! sb        CL=4190.0
-  ! sb        CPVMCL=2320.0
-  ! sb        RV=461.5
-  ! sb        RD=287.04
-  ! sb        EPS=RD/RV
-  ! sb        ALV0=2.501E6
-  ! cccccccccccccccccccccc
-  ! constantes coherentes avec le modele du Centre Europeen
-  ! sb      RD = 1000.0 * 1.380658E-23 * 6.0221367E+23 / 28.9644
-  ! sb      RV = 1000.0 * 1.380658E-23 * 6.0221367E+23 / 18.0153
-  ! sb      CPD = 3.5 * RD
-  ! sb      CPV = 4.0 * RV
-  ! sb      CL = 4218.0
-  ! sb      CI=2090.0
-  ! sb      CPVMCL=CL-CPV
-  ! sb      CLMCI=CL-CI
-  ! sb      EPS=RD/RV
-  ! sb      ALV0=2.5008E+06
-  ! sb      ALF0=3.34E+05
-
-  ! ccccccccccc
-  ! on utilise les constantes thermo du Centre Europeen: (SB)
-
-  include "YOMCST.h"
-  gravity = rg !sb: Pr que gravite ne devienne pas humidite!
-
-  cpd = rcpd
-  cpv = rcpv
-  cl = rcw
-  ci = rcs
-  cpvmcl = cl - cpv
-  clmci = cl - ci
-  eps = rd/rv
-  alv0 = rlvtt
-  alf0 = rlmlt ! (ALF0 = RLSTT-RLVTT)
-
-  ! ccccccccccccccccccccc
-
-  ! ***  CALCULATE CERTAIN PARCEL QUANTITIES, INCLUDING STATIC ENERGY   ***
-
-  icb1 = max(icb, 2)
-  icb1 = min(icb, nl)
-
-  ! jyg1
-  ! C      CPP=CPD*(1.-RR(1))+RR(1)*CPV
-  cpp = cpd*(1.-rr(nk)) + rr(nk)*cpv
-  ! jyg2
-  cpinv = 1./cpp
-  ! jyg1
-  ! ICB may be below condensation level
-  ! CC        DO 100 I=1,ICB1-1
-  ! CC         TPK(I)=T(1)-GZ(I)*CPINV
-  ! CC         TVP(I)=TPK(I)*(1.+RR(1)/EPS)
-  DO i = 1, icb1
-    clw(i) = 0.0
-  END DO
-
-  DO i = nk, icb1
-    tpk(i) = t(nk) - (gz(i)-gz(nk))*cpinv
-    ! jyg1
-    ! CC         TVP(I)=TPK(I)*(1.+RR(NK)/EPS)
-    tvp(i) = tpk(i)*(1.+rr(nk)/eps-rr(nk))
-    ! jyg2
-    dtvpdt1(i) = 1. + rr(nk)/eps - rr(nk)
-    dtvpdq1(i) = tpk(i)*(1./eps-1.)
-
-    ! jyg2
-
-  END DO
-
-
-  ! ***  FIND LIFTED PARCEL TEMPERATURE AND MIXING RATIO    ***
-
-  ! jyg1
-  ! C        AH0=(CPD*(1.-RR(1))+CL*RR(1))*T(1)
-  ! C     $     +RR(1)*(ALV0-CPVMCL*(T(1)-273.15))
-  ah0 = (cpd*(1.-rr(nk))+cl*rr(nk))*t(nk) + rr(nk)*(alv0-cpvmcl*(t(nk)-273.15 &
-    )) + gz(nk)
-  ! jyg2
-
-  ! jyg1
-  imin = icb1
-  ! If ICB is below LCL, start loop at ICB+1
-  IF (plcl<p(icb1)) imin = min(imin+1, nl)
-
-  ! CC        DO 300 I=ICB1,NL
-  DO i = imin, nl
-    ! jyg2
-    alv = alv0 - cpvmcl*(t(i)-273.15)
-    alf = alf0 + clmci*(t(i)-273.15)
-
-    rg = rs(i)
-    tg = t(i)
-    ! S=CPD+ALV*ALV*RG/(RV*T(I)*T(I))
-    ! jyg1
-    ! C        S=CPD*(1.-RR(1))+CL*RR(1)+ALV*ALV*RG/(RV*T(I)*T(I))
-    s = cpd*(1.-rr(nk)) + cl*rr(nk) + alv*alv*rg/(rv*t(i)*t(i))
-    ! jyg2
-    s = 1./s
-
-    DO j = 1, 2
-      ! jyg1
-      ! C         AHG=CPD*TG+(CL-CPD)*RR(1)*TG+ALV*RG+GZ(I)
-      ahg = cpd*tg + (cl-cpd)*rr(nk)*tg + alv*rg + gz(i)
-      ! jyg2
-      tg = tg + s*(ah0-ahg)
-      tc = tg - 273.15
-      denom = 243.5 + tc
-      denom = max(denom, 1.0)
-
-      ! FORMULE DE BOLTON POUR PSAT
-
-      es = 6.112*exp(17.67*tc/denom)
-      rg = eps*es/(p(i)-es*(1.-eps))
-
-
-    END DO
-
-    ! jyg1
-    ! C        TPK(I)=(AH0-GZ(I)-ALV*RG)/(CPD+(CL-CPD)*RR(1))
-    tpk(i) = (ah0-gz(i)-alv*rg)/(cpd+(cl-cpd)*rr(nk))
-    ! jyg2
-    ! TPK(I)=(AH0-GZ(I)-ALV*RG-(CL-CPD)*T(I)*RR(1))/CPD
-
-    ! jyg1
-    ! C        CLW(I)=RR(1)-RG
-    clw(i) = rr(nk) - rg
-    ! jyg2
-    clw(i) = max(0.0, clw(i))
-    ! jyg1
-    ! CC        TVP(I)=TPK(I)*(1.+RG/EPS)
-    tvp(i) = tpk(i)*(1.+rg/eps-rr(nk))
-    ! jyg2
-
-    ! jyg1       Derivatives
-
-    dtpdt1(i) = cpd*s
-    dtpdq1(i) = alv*s
-
-    dtvpdt1(i) = dtpdt1(i)*(1.+rg/eps-rr(nk)+alv*rg/(rd*tpk(i)))
-    dtvpdq1(i) = dtpdq1(i)*(1.+rg/eps-rr(nk)+alv*rg/(rd*tpk(i))) - tpk(i)
-
-    ! jyg2
-
-  END DO
-
-  ice_conv = .FALSE.
-
-  IF (ice_conv) THEN
-
-    ! JAM
-    ! RAJOUT DE LA PROCEDURE ICEFRAC
-
-    ! sb        CALL ICEFRAC(T,CLW,CLW_NEW,QI,ND,NL)
-
-    DO i = icb1, nl
-      IF (t(i)<263.15) THEN
-        tg = tpk(i)
-        tc = tpk(i) - 273.15
-        denom = 243.5 + tc
-        es = 6.112*exp(17.67*tc/denom)
-        alv = alv0 - cpvmcl*(t(i)-273.15)
-        alf = alf0 + clmci*(t(i)-273.15)
-
-        DO j = 1, 4
-          esi = exp(23.33086-(6111.72784/tpk(i))+0.15215*log(tpk(i)))
-          qsat_new = eps*esi/(p(i)-esi*(1.-eps))
-          ! CC        SNEW=
-          ! CPD*(1.-RR(1))+CL*RR(1)+ALV*ALV*QSAT_NEW/(RV*TPK(I)*TPK(I))
-          snew = cpd*(1.-rr(nk)) + cl*rr(nk) + alv*alv*qsat_new/(rv*tpk(i)* &
-            tpk(i))
-
-          snew = 1./snew
-          tpk(i) = tg + (alf*qi(i)+alv*rg*(1.-(esi/es)))*snew
-          ! @$$        PRINT*,'################################'
-          ! @$$        PRINT*,TPK(I)
-          ! @$$        PRINT*,(ALF*QI(I)+ALV*RG*(1.-(ESI/ES)))*SNEW
-        END DO
-        ! CC        CLW(I)=RR(1)-QSAT_NEW
-        clw(i) = rr(nk) - qsat_new
-        clw(i) = max(0.0, clw(i))
-        ! jyg1
-        ! CC        TVP(I)=TPK(I)*(1.+QSAT_NEW/EPS)
-        tvp(i) = tpk(i)*(1.+qsat_new/eps-rr(nk))
-        ! jyg2
-      ELSE
-        CONTINUE
-      END IF
-
-    END DO
-
-  END IF
-
-
-  ! *****************************************************
-  ! * BK :  RAJOUT DE LA TEMPERATURE DES ASCENDANCES
-  ! *   NON DILUES AU  NIVEAU KLEV = ND
-  ! *   POSONS LE ENVIRON EGAL A CELUI DE KLEV-1
-  ! *******************************************************
-
-  tpk(nl+1) = tpk(nl)
-
-  ! ******************************************************
-
-  rg = gravity ! RG redevient la gravite de YOMCST (sb)
-
-
-  RETURN
-END SUBROUTINE tlift
-
-
-
-
-
-
-
-
Index: /LMDZ6/trunk/libf/phylmd/tlift.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/tlift.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/tlift.f90	(revision 5268)
@@ -0,0 +1,246 @@
+
+! $Header$
+
+SUBROUTINE tlift(p, t, rr, rs, gz, plcl, icb, nk, tvp, tpk, clw, nd, nl, &
+    dtvpdt1, dtvpdq1)
+  IMPLICIT NONE
+  ! Argument NK ajoute (jyg) = Niveau de depart de la
+  ! convection
+  INTEGER icb, nk, nd, nl
+  INTEGER,PARAMETER :: na=60
+  REAL gz(nd), tpk(nd), clw(nd), plcl
+  REAL t(nd), rr(nd), rs(nd), tvp(nd), p(nd)
+  REAL dtvpdt1(nd), dtvpdq1(nd) ! Derivatives of parcel virtual
+  ! temperature wrt T1 and Q1
+
+  REAL clw_new(na), qi(na)
+  REAL dtpdt1(na), dtpdq1(na) ! Derivatives of parcel temperature
+  ! wrt T1 and Q1
+  REAL gravity, cpd, cpv, cl, ci, cpvmcl, clmci, eps, alv0, alf0
+  REAL cpp, cpinv, ah0, alf, tg, s, ahg, tc, denom, alv, es, esi
+  REAL qsat_new, snew
+  INTEGER icbl, i, imin, j, icb1
+
+  LOGICAL ice_conv
+
+  ! ***   ASSIGN VALUES OF THERMODYNAMIC CONSTANTS     ***
+
+  ! sb        CPD=1005.7
+  ! sb      CPV=1870.0
+  ! sb        CL=4190.0
+  ! sb        CPVMCL=2320.0
+  ! sb        RV=461.5
+  ! sb        RD=287.04
+  ! sb        EPS=RD/RV
+  ! sb        ALV0=2.501E6
+  ! cccccccccccccccccccccc
+  ! constantes coherentes avec le modele du Centre Europeen
+  ! sb      RD = 1000.0 * 1.380658E-23 * 6.0221367E+23 / 28.9644
+  ! sb      RV = 1000.0 * 1.380658E-23 * 6.0221367E+23 / 18.0153
+  ! sb      CPD = 3.5 * RD
+  ! sb      CPV = 4.0 * RV
+  ! sb      CL = 4218.0
+  ! sb      CI=2090.0
+  ! sb      CPVMCL=CL-CPV
+  ! sb      CLMCI=CL-CI
+  ! sb      EPS=RD/RV
+  ! sb      ALV0=2.5008E+06
+  ! sb      ALF0=3.34E+05
+
+  ! ccccccccccc
+  ! on utilise les constantes thermo du Centre Europeen: (SB)
+
+  include "YOMCST.h"
+  gravity = rg !sb: Pr que gravite ne devienne pas humidite!
+
+  cpd = rcpd
+  cpv = rcpv
+  cl = rcw
+  ci = rcs
+  cpvmcl = cl - cpv
+  clmci = cl - ci
+  eps = rd/rv
+  alv0 = rlvtt
+  alf0 = rlmlt ! (ALF0 = RLSTT-RLVTT)
+
+  ! ccccccccccccccccccccc
+
+  ! ***  CALCULATE CERTAIN PARCEL QUANTITIES, INCLUDING STATIC ENERGY   ***
+
+  icb1 = max(icb, 2)
+  icb1 = min(icb, nl)
+
+  ! jyg1
+  ! C      CPP=CPD*(1.-RR(1))+RR(1)*CPV
+  cpp = cpd*(1.-rr(nk)) + rr(nk)*cpv
+  ! jyg2
+  cpinv = 1./cpp
+  ! jyg1
+  ! ICB may be below condensation level
+  ! CC        DO 100 I=1,ICB1-1
+  ! CC         TPK(I)=T(1)-GZ(I)*CPINV
+  ! CC         TVP(I)=TPK(I)*(1.+RR(1)/EPS)
+  DO i = 1, icb1
+    clw(i) = 0.0
+  END DO
+
+  DO i = nk, icb1
+    tpk(i) = t(nk) - (gz(i)-gz(nk))*cpinv
+    ! jyg1
+    ! CC         TVP(I)=TPK(I)*(1.+RR(NK)/EPS)
+    tvp(i) = tpk(i)*(1.+rr(nk)/eps-rr(nk))
+    ! jyg2
+    dtvpdt1(i) = 1. + rr(nk)/eps - rr(nk)
+    dtvpdq1(i) = tpk(i)*(1./eps-1.)
+
+    ! jyg2
+
+  END DO
+
+
+  ! ***  FIND LIFTED PARCEL TEMPERATURE AND MIXING RATIO    ***
+
+  ! jyg1
+  ! C        AH0=(CPD*(1.-RR(1))+CL*RR(1))*T(1)
+  ! C     $     +RR(1)*(ALV0-CPVMCL*(T(1)-273.15))
+  ah0 = (cpd*(1.-rr(nk))+cl*rr(nk))*t(nk) + rr(nk)*(alv0-cpvmcl*(t(nk)-273.15 &
+    )) + gz(nk)
+  ! jyg2
+
+  ! jyg1
+  imin = icb1
+  ! If ICB is below LCL, start loop at ICB+1
+  IF (plcl<p(icb1)) imin = min(imin+1, nl)
+
+  ! CC        DO 300 I=ICB1,NL
+  DO i = imin, nl
+    ! jyg2
+    alv = alv0 - cpvmcl*(t(i)-273.15)
+    alf = alf0 + clmci*(t(i)-273.15)
+
+    rg = rs(i)
+    tg = t(i)
+    ! S=CPD+ALV*ALV*RG/(RV*T(I)*T(I))
+    ! jyg1
+    ! C        S=CPD*(1.-RR(1))+CL*RR(1)+ALV*ALV*RG/(RV*T(I)*T(I))
+    s = cpd*(1.-rr(nk)) + cl*rr(nk) + alv*alv*rg/(rv*t(i)*t(i))
+    ! jyg2
+    s = 1./s
+
+    DO j = 1, 2
+      ! jyg1
+      ! C         AHG=CPD*TG+(CL-CPD)*RR(1)*TG+ALV*RG+GZ(I)
+      ahg = cpd*tg + (cl-cpd)*rr(nk)*tg + alv*rg + gz(i)
+      ! jyg2
+      tg = tg + s*(ah0-ahg)
+      tc = tg - 273.15
+      denom = 243.5 + tc
+      denom = max(denom, 1.0)
+
+      ! FORMULE DE BOLTON POUR PSAT
+
+      es = 6.112*exp(17.67*tc/denom)
+      rg = eps*es/(p(i)-es*(1.-eps))
+
+
+    END DO
+
+    ! jyg1
+    ! C        TPK(I)=(AH0-GZ(I)-ALV*RG)/(CPD+(CL-CPD)*RR(1))
+    tpk(i) = (ah0-gz(i)-alv*rg)/(cpd+(cl-cpd)*rr(nk))
+    ! jyg2
+    ! TPK(I)=(AH0-GZ(I)-ALV*RG-(CL-CPD)*T(I)*RR(1))/CPD
+
+    ! jyg1
+    ! C        CLW(I)=RR(1)-RG
+    clw(i) = rr(nk) - rg
+    ! jyg2
+    clw(i) = max(0.0, clw(i))
+    ! jyg1
+    ! CC        TVP(I)=TPK(I)*(1.+RG/EPS)
+    tvp(i) = tpk(i)*(1.+rg/eps-rr(nk))
+    ! jyg2
+
+    ! jyg1       Derivatives
+
+    dtpdt1(i) = cpd*s
+    dtpdq1(i) = alv*s
+
+    dtvpdt1(i) = dtpdt1(i)*(1.+rg/eps-rr(nk)+alv*rg/(rd*tpk(i)))
+    dtvpdq1(i) = dtpdq1(i)*(1.+rg/eps-rr(nk)+alv*rg/(rd*tpk(i))) - tpk(i)
+
+    ! jyg2
+
+  END DO
+
+  ice_conv = .FALSE.
+
+  IF (ice_conv) THEN
+
+    ! JAM
+    ! RAJOUT DE LA PROCEDURE ICEFRAC
+
+    ! sb        CALL ICEFRAC(T,CLW,CLW_NEW,QI,ND,NL)
+
+    DO i = icb1, nl
+      IF (t(i)<263.15) THEN
+        tg = tpk(i)
+        tc = tpk(i) - 273.15
+        denom = 243.5 + tc
+        es = 6.112*exp(17.67*tc/denom)
+        alv = alv0 - cpvmcl*(t(i)-273.15)
+        alf = alf0 + clmci*(t(i)-273.15)
+
+        DO j = 1, 4
+          esi = exp(23.33086-(6111.72784/tpk(i))+0.15215*log(tpk(i)))
+          qsat_new = eps*esi/(p(i)-esi*(1.-eps))
+          ! CC        SNEW=
+          ! CPD*(1.-RR(1))+CL*RR(1)+ALV*ALV*QSAT_NEW/(RV*TPK(I)*TPK(I))
+          snew = cpd*(1.-rr(nk)) + cl*rr(nk) + alv*alv*qsat_new/(rv*tpk(i)* &
+            tpk(i))
+
+          snew = 1./snew
+          tpk(i) = tg + (alf*qi(i)+alv*rg*(1.-(esi/es)))*snew
+          ! @$$        PRINT*,'################################'
+          ! @$$        PRINT*,TPK(I)
+          ! @$$        PRINT*,(ALF*QI(I)+ALV*RG*(1.-(ESI/ES)))*SNEW
+        END DO
+        ! CC        CLW(I)=RR(1)-QSAT_NEW
+        clw(i) = rr(nk) - qsat_new
+        clw(i) = max(0.0, clw(i))
+        ! jyg1
+        ! CC        TVP(I)=TPK(I)*(1.+QSAT_NEW/EPS)
+        tvp(i) = tpk(i)*(1.+qsat_new/eps-rr(nk))
+        ! jyg2
+      ELSE
+        CONTINUE
+      END IF
+
+    END DO
+
+  END IF
+
+
+  ! *****************************************************
+  ! * BK :  RAJOUT DE LA TEMPERATURE DES ASCENDANCES
+  ! *   NON DILUES AU  NIVEAU KLEV = ND
+  ! *   POSONS LE ENVIRON EGAL A CELUI DE KLEV-1
+  ! *******************************************************
+
+  tpk(nl+1) = tpk(nl)
+
+  ! ******************************************************
+
+  rg = gravity ! RG redevient la gravite de YOMCST (sb)
+
+
+  RETURN
+END SUBROUTINE tlift
+
+
+
+
+
+
+
+
Index: DZ6/trunk/libf/phylmd/tracco2i_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/tracco2i_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,485 +1,0 @@
-MODULE tracco2i_mod
-!
-! This module does the work for the interactive CO2 tracers
-! Authors: Patricia Cadule and Olivier Boucher
-!
-! Purpose and description:
-!  -----------------------
-! Main routine for the interactive carbon cycle
-! Gather all carbon fluxes and emissions from ORCHIDEE, PISCES and fossil fuel
-! Compute the net flux in source field which is used in phytrac
-! Compute global CO2 mixing ratio for radiation scheme if option is activated
-! Redistribute CO2 evenly over the atmosphere if transport is desactivated
-!
-CONTAINS
-
-  SUBROUTINE tracco2i_init()
-    ! This subroutine calls carbon_cycle_init needed to be done before first call to phys_output_write in physiq.
-    USE carbon_cycle_mod, ONLY: carbon_cycle_init, carbon_cycle_cpl
-
-    ! Initialize carbon_cycle_mod
-    IF (carbon_cycle_cpl) THEN
-       CALL carbon_cycle_init()
-    ENDIF
-
-  END SUBROUTINE tracco2i_init
-
-  SUBROUTINE tracco2i(pdtphys, debutphy, &
-       xlat, xlon, pphis, pphi, &
-       t_seri, pplay, paprs, tr_seri, source)
-
-    USE dimphy
-    USE infotrac_phy, ONLY: nbtr
-    USE geometry_mod, ONLY: cell_area
-    USE carbon_cycle_mod, ONLY: id_CO2, nbcf_in, fields_in, cfname_in
-    USE carbon_cycle_mod, ONLY: fco2_ocn_day, fco2_ff, fco2_bb, fco2_land, fco2_ocean
-    USE carbon_cycle_mod, ONLY: read_fco2_ocean_cor,var_fco2_ocean_cor,fco2_ocean_cor 
-    USE carbon_cycle_mod, ONLY: read_fco2_land_cor,var_fco2_land_cor,fco2_land_cor 
-    USE carbon_cycle_mod, ONLY: co2_send
-    USE carbon_cycle_mod, ONLY: fco2_land_nbp, fco2_land_nep, fco2_land_fLuc
-    USE carbon_cycle_mod, ONLY: fco2_land_fwoodharvest, fco2_land_fHarvest
-    USE carbon_cycle_mod, ONLY: carbon_cycle_cpl, carbon_cycle_tr, carbon_cycle_rad, RCO2_glo, RCO2_tot
-    USE carbon_cycle_mod, ONLY: ocean_area_tot
-    USE carbon_cycle_mod, ONLY: land_area_tot
-    USE mod_grid_phy_lmdz
-    USE mod_phys_lmdz_mpi_data, ONLY: is_mpi_root
-    USE mod_phys_lmdz_para, ONLY: gather, bcast, scatter
-    USE mod_phys_lmdz_omp_data, ONLY: is_omp_root
-    USE phys_cal_mod
-    USE phys_state_var_mod, ONLY: pctsrf
-    USE indice_sol_mod, ONLY: nbsrf, is_ter, is_lic, is_oce, is_sic
-
-    IMPLICIT NONE
-
-    INCLUDE "clesphys.h"
-    INCLUDE "YOMCST.h"
-
-! Input argument
-!---------------
-    REAL,INTENT(IN)    :: pdtphys    ! Pas d'integration pour la physique (seconde)
-    LOGICAL,INTENT(IN) :: debutphy   ! le flag de l'initialisation de la physique
-
-    REAL,DIMENSION(klon),INTENT(IN)        :: xlat    ! latitudes pour chaque point 
-    REAL,DIMENSION(klon),INTENT(IN)        :: xlon    ! longitudes pour chaque point 
-    REAL,DIMENSION(klon),INTENT(IN)        :: pphis   ! geopotentiel du sol
-    REAL,DIMENSION(klon,klev),INTENT(IN)   :: pphi    ! geopotentiel de chaque couche
-
-    REAL,DIMENSION(klon,klev),INTENT(IN)   :: t_seri  ! Temperature
-    REAL,DIMENSION(klon,klev),INTENT(IN)   :: pplay   ! pression pour le mileu de chaque couche (en Pa)
-    REAL,DIMENSION(klon,klev+1),INTENT(IN) :: paprs   ! pression pour chaque inter-couche (en Pa)
-    REAL,DIMENSION(klon,nbtr),INTENT(INOUT):: source  ! flux de traceur [U/m2/s]
-
-! Output argument
-!----------------
-    REAL,DIMENSION(klon,klev,nbtr),INTENT(INOUT)  :: tr_seri ! Concentration Traceur [U/kgA]  
-
-! Local variables
-!----------------
-
-    INTEGER                        :: it, k, i, nb
-    REAL, DIMENSION(klon,klev)     :: m_air     ! mass of air in every grid box [kg]
-    REAL, DIMENSION(klon_glo,klev) :: co2_glo   ! variable temporaire sur la grille global
-    REAL, DIMENSION(klon_glo,klev) :: m_air_glo ! variable temporaire sur la grille global
-    REAL, DIMENSION(klon_glo,nbsrf):: pctsrf_glo      !--fractions de maille sur la grille globale
-    REAL, DIMENSION(klon_glo)      :: pctsrf_ter_glo
-    REAL, DIMENSION(klon_glo)      :: pctsrf_oce_glo
-    REAL, DIMENSION(klon_glo)      :: pctsrf_sic_glo
-    REAL, DIMENSION(klon_glo)      :: cell_area_glo   !--aire des mailles sur la grille globale
-
-    LOGICAL, SAVE :: check_fCO2_nbp_in_cfname
-!$OMP THREADPRIVATE(check_fCO2_nbp_in_cfname)
-    INTEGER, SAVE :: day_pre=-1
-!$OMP THREADPRIVATE(day_pre)
-
-    REAL, PARAMETER :: secinday=86400.
-
-    IF (is_mpi_root) THEN
-      PRINT *,'in tracco2i: date from phys_cal_mod =',year_cur,'-',mth_cur,'-',day_cur,'-',hour
-    ENDIF
-
-!--initialisation of CO2 field if not in restart file
-!--dirty way of doing, do it better later
-!--convert 280 ppm into kg CO2 / kg air
-    IF (debutphy) THEN
-
-! Initialization of tr_seri(id_CO2) If it is not initialized
-      IF (MAXVAL(tr_seri(:,:,id_CO2)).LT.1.e-15) THEN 
-        tr_seri(:,:,id_CO2)=co2_ppm0*1.e-6/RMD*RMCO2 !--initialised from co2_ppm0 in rdem
-      ENDIF 
-
-!--check if fCO2_nbp is in 
-      check_fCO2_nbp_in_cfname=.FALSE.
-      DO nb=1, nbcf_in
-        IF (cfname_in(nb)=="fCO2_nbp") check_fCO2_nbp_in_cfname=.TRUE.
-      ENDDO
-
-      CALL gather(pctsrf,pctsrf_glo)
-      CALL gather(pctsrf(:,is_ter),pctsrf_ter_glo)
-      CALL gather(pctsrf(:,is_oce),pctsrf_oce_glo)
-      CALL gather(pctsrf(:,is_sic),pctsrf_sic_glo)
-      CALL gather(cell_area(:),cell_area_glo)
-
-    ENDIF
-
-!--calculate mass of air in every grid box in kg air
-    DO i=1, klon
-    DO k=1, klev
-      m_air(i,k)=(paprs(i,k)-paprs(i,k+1))/RG*cell_area(i)
-    ENDDO
-    ENDDO
-
-!--call CO2 emission routine 
-!--co2bb is zero for now
-!--unit kg CO2 m-2 s-1 
-    CALL co2_emissions(debutphy)
-
-!--retrieving land and ocean CO2 flux
-    fco2_land(:)=0.0
-    fco2_ocean(:)=0.0
-    fco2_land_nbp(:)=0.
-    fco2_land_nep(:)=0.
-    fco2_land_fLuc(:)=0.
-    fco2_land_fwoodharvest(:)=0.
-    fco2_land_fHarvest(:)=0.
-
-    DO nb=1, nbcf_in
-
-      SELECT CASE(cfname_in(nb))
-!--dealing with the different fluxes coming from ORCHIDEE
-!--fluxes come in unit of kg C m-2 s-1 is converted into kg CO2 m-2 s-1
-      CASE("fCO2_nep")
-          fco2_land_nep(:)=fields_in(:,nb)*RMCO2/RMC*pctsrf(:,is_ter)
-      CASE("fCO2_fLuc")
-          fco2_land_fLuc(:)=fields_in(:,nb)*RMCO2/RMC*pctsrf(:,is_ter)
-      CASE("fCO2_fwoodharvest")
-          fco2_land_fwoodharvest(:)=fields_in(:,nb)*RMCO2/RMC*pctsrf(:,is_ter)
-      CASE("fCO2_fHarvest")
-          fco2_land_fHarvest(:)=fields_in(:,nb)*RMCO2/RMC*pctsrf(:,is_ter)
-      CASE("fCO2_nbp")
-          fco2_land_nbp(:)=fields_in(:,nb)*RMCO2/RMC*pctsrf(:,is_ter)
-!--fCO2_fco2_ocn comes in unit of mol C02 m-2 s-1 is converted into kg CO2 m-2 s-1 + change sign
-      CASE("fCO2_fgco2") 
-          fco2_ocean(:)=-1.*fco2_ocn_day(:)*RMCO2/1.e3*(pctsrf(:,is_oce)+pctsrf(:,is_sic))
-      END SELECT
-
-    ENDDO
-
-    PRINT *, 'tracco2i_mod.F90 --- read_fco2_ocean_cor ',read_fco2_ocean_cor
-    PRINT *, 'tracco2i_mod.F90 --- read_fco2_land_cor ',read_fco2_land_cor
-
-IF (debutphy) THEN
-
-    IF (read_fco2_ocean_cor) THEN
-!$OMP MASTER
-       IF (is_mpi_root .AND. is_omp_root) THEN
-          ocean_area_tot=0.
-          PRINT *, 'tracco2i_mod.F90 --- var_fco2_ocean_cor (PgC/yr) ',var_fco2_ocean_cor
-          DO i=1, klon_glo
-             ocean_area_tot = ocean_area_tot + (pctsrf_oce_glo(i)+pctsrf_sic_glo(i))*cell_area_glo(i)
-          ENDDO
-      ENDIF !--is_mpi_root and is_omp_root 
-!$OMP END MASTER
-      CALL bcast(ocean_area_tot)
-     PRINT *, 'tracco2i_mod.F90 --- ocean_area_tot (debutphy) ',ocean_area_tot
-    ENDIF
-
-    IF (read_fco2_land_cor) THEN
-!$OMP MASTER
-       IF (is_mpi_root .AND. is_omp_root) THEN
-          land_area_tot=0.
-          PRINT *, 'tracco2i_mod.F90 --- var_fco2_land_cor (PgC/yr) ',var_fco2_land_cor
-          DO i=1, klon_glo
-             land_area_tot = land_area_tot + pctsrf_ter_glo(i)*cell_area_glo(i) 
-          ENDDO
-      ENDIF !--is_mpi_root and is_omp_root 
-!$OMP END MASTER
-      CALL bcast(land_area_tot)
-     PRINT *, 'tracco2i_mod.F90 --- land_area_tot (debutphy) ',land_area_tot 
-ENDIF
-
-    ENDIF !-- debutphy  
-
-    PRINT *, 'tracco2i_mod.F90 --- ocean_area_tot (m2) ',ocean_area_tot
-    PRINT *, 'tracco2i_mod.F90 --- land_area_tot (m2) ',land_area_tot
-
-    IF (read_fco2_ocean_cor) THEN
-! var_fco2_ocean_cor: correction of the surface downward CO2 flux into the ocean fgco2 (PgC/yr)
-! This is the correction of the the net air to ocean carbon flux. Positive flux is into the ocean.
-!    PRINT *, 'tracco2i_mod.F90 --- var_fco2_ocean_cor (PgC/yr) ',var_fco2_ocean_cor
-
-!var_fco2_ocean_cor: correction of the net air to ocean carbon flux (input data is a scalar in PgC/yr and must be converted in kg CO2 m-2 s-1)
-
-! Factors for carbon and carbon dioxide
-! 1 mole CO2 = 44.009 g CO2 = 12.011 g C
-! 1 ppm by volume of atmosphere CO2 = 2.13 Gt C
-! 1 gC = 44.009/12.011 gCO2
-
-! ocean_area_tot: ocean area (m2)
-
-! year_len: year length (in days)
-
-! conversion: PgC/yr --> kg CO2 m-2 s-1
-! fco2_ocean_cor  / (86400.*year_len): PgC/yr to PgC/s
-! fco2_ocean_cor  / (86400.*year_len)*(pctsrf(i,is_oce)+pctsrf(i,is_sic))/ocean_area_tot: PgC/s to PgC/s/m2
-! (fco2_ocean_cor / (86400.*year_len)*(pctsrf(i,is_oce)+pctsrf(i,is_sic))/ocean_area_tot) *1e12: PgC/s/m2 to kgC/s/m2
-! (fco2_ocean_cor / (86400.*year_len)*(pctsrf(i,is_oce)+pctsrf(i,is_sic))/ocean_area_tot) * 1e12 * (RMCO2/RMC): kgC/s/m2 to kgCO2/s/m2
-
-      DO i=1, klon  
-         fco2_ocean_cor(i)=(var_fco2_ocean_cor*(RMCO2/RMC) &
-              *(pctsrf(i,is_oce)+pctsrf(i,is_sic))/ocean_area_tot &
-              /(secinday*year_len))*1.e12
-      ENDDO
-
-      PRINT *, 'tracco2i_mod.F90 --- MINVAL(fco2_ocean_cor) ',MINVAL(fco2_ocean_cor)
-      PRINT *, 'tracco2i_mod.F90 --- MAXVAL(fco2_ocean_cor) ',MAXVAL(fco2_ocean_cor)
-
-    ELSE
-    fco2_ocean_cor(:)=0.
-    ENDIF
-
-    IF (read_fco2_land_cor) THEN
-! var_fco2_land_cor: correction of the carbon Mass Flux out of Atmosphere Due to Net Biospheric Production on Land  (PgC/yr)
-! This is the correction of the net mass flux of carbon between land and atmosphere calculated as
-! photosynthesis MINUS the sum of plant and soil respiration, carbon fluxes from
-! fire, harvest, grazing and land use change. Positive flux is into the land.
-!    PRINT *, 'tracco2i_mod.F90 --- var_fco2_land_cor (m2) ',var_fco2_land_cor
-
-!var_fco2_land_cor: correction of the et air to land carbon flux (input data is a scalar in PgC/yr and must be converted in kg CO2 m-2 s-1)
-
-! Factors for carbon and carbon dioxide
-! 1 mole CO2 = 44.009 g CO2 = 12.011 g C
-! 1 ppm by volume of atmosphere CO2 = 2.13 Gt C
-! 1 gC = 44.009/12.011 gCO2
-
-! land_area_tot: land area (m2)
-
-! year_len: year length (in days)
-
-! conversion: PgC/yr --> kg CO2 m-2 s-1
-! fco2_land_cor  / (86400.*year_len): PgC/yr to PgC/s
-! fco2_land_cor  / (86400.*year_len)*pctsrf(i,is_ter)/land_area_tot: PgC/s to PgC/s/m2
-! (fco2_land_cor / (86400.*year_len)*pctsrf(i,is_ter)/land_area_tot) *1e12: PgC/s/m2 to kgC/s/m2
-! (fco2_land_cor / (86400.*year_len)*pctsrf(i,is_ter)/land_area_tot) * 1e12 * (RMCO2/RMC): kgC/s/m2 to kgCO2/s/m2
-
-      DO i=1, klon
-         fco2_land_cor(i)=var_fco2_land_cor*RMCO2/RMC*pctsrf(i,is_ter)/land_area_tot/(secinday*year_len)*1.e12
-      ENDDO
-
-      PRINT *, 'tracco2i_mod.F90 --- MINVAL(fco2_land_cor) ',MINVAL(fco2_land_cor)
-      PRINT *, 'tracco2i_mod.F90 --- MAXVAL(fco2_land_cor) ',MAXVAL(fco2_land_cor)
-
-    ELSE
-      fco2_land_cor(:)=0.
-    ENDIF
-
-!--if fCO2_nbp is transferred we use it, otherwise we use the sum of what has been passed from ORCHIDEE
-    IF (check_fCO2_nbp_in_cfname)  THEN
-       fco2_land(:)=fco2_land_nbp(:)
-    ELSE
-       fco2_land(:)=fco2_land_nep(:)+fco2_land_fLuc(:)+fco2_land_fwoodharvest(:)+fco2_land_fHarvest(:)
-    ENDIF
-
-!!--preparing the net anthropogenic flux at the surface for mixing layer
-!!--unit kg CO2 / m2 / s
-!    PRINT *, 'tracco2i_mod.F90 --- MAXVAL(fco2_ff) ',MAXVAL(fco2_ff)
-!    PRINT *, 'tracco2i_mod.F90 --- MINVAL(fco2_ff) ',MINVAL(fco2_ff)
-!    PRINT *, 'tracco2i_mod.F90 --- MAXVAL(fco2_bb) ',MAXVAL(fco2_bb)
-!    PRINT *, 'tracco2i_mod.F90 --- MINVAL(fco2_bb) ',MINVAL(fco2_bb)
-!    PRINT *, 'tracco2i_mod.F90 --- MAXVAL(fco2_land) ',MAXVAL(fco2_land)
-!    PRINT *, 'tracco2i_mod.F90 --- MINVAL(fco2_land) ',MINVAL(fco2_land)
-!    PRINT *, 'tracco2i_mod.F90 --- MAXVAL(fco2_ocean) ',MAXVAL(fco2_ocean)
-!    PRINT *, 'tracco2i_mod.F90 --- MINVAL(fco2_ocean) ',MINVAL(fco2_ocean)
-!    PRINT *, 'tracco2i_mod.F90 --- MAXVAL(source(:,id_CO2)) ',MAXVAL(source(:,id_CO2))
-!    PRINT *, 'tracco2i_mod.F90 --- MINVAL(source(:,id_CO2)) ',MINVAL(source(:,id_CO2))
-!
-!--build final source term for CO2
-    source(:,id_CO2)=fco2_ff(:)+fco2_bb(:)+fco2_land(:)+fco2_ocean(:)-fco2_ocean_cor(:)-fco2_land_cor(:)
-
-!--computing global mean CO2 for radiation
-!--for every timestep comment out the IF ENDIF statements 
-!--otherwise this is updated every day
-    IF (debutphy.OR.day_cur.NE.day_pre) THEN
-
-      CALL gather(tr_seri(:,:,id_CO2),co2_glo)
-      CALL gather(m_air,m_air_glo)
-
-!$OMP MASTER
-
-!--compute a global mean CO2 value and print its value in ppm
-       IF (is_mpi_root .AND. is_omp_root) THEN
-         RCO2_tot=SUM(co2_glo*m_air_glo)  !--unit kg CO2
-         RCO2_glo=RCO2_tot/SUM(m_air_glo) !--unit kg CO2 / kg air
-         ! the following operation is only to maintain precision consistency
-         ! of RCO2_glo which differs whether it is directly computed or read from
-         ! a restart file (after having been computed)
-         RCO2_glo = FLOAT(INT(RCO2_glo * 1e8))/1e8
-         PRINT *,'tracco2i: global CO2 in ppm =', RCO2_glo*1.e6*RMD/RMCO2
-         PRINT *,'tracco2i: total CO2 in kg =', RCO2_tot
-       ENDIF
-!$OMP END MASTER
-       CALL bcast(RCO2_glo)
-       day_pre=day_cur
-
-!--if not carbon_cycle_tr, then we reinitialize the CO2 each day to its global mean value
-       IF (.NOT.carbon_cycle_tr) THEN 
-         tr_seri(:,:,id_CO2)=RCO2_glo
-       ENDIF
-    ENDIF
-
-    PRINT *, 'tracco2i_mod.F90 --- MINVAL(tr_seri(:,1,id_CO2)*1.e6*RMD/RMCO2): L1: ',MINVAL(tr_seri(:,1,id_CO2)*1.e6*RMD/RMCO2)
-    PRINT *, 'tracco2i_mod.F90 --- MAXVAL(tr_seri(:,1,id_CO2)*1.e6*RMD/RMCO2): L1: ',MAXVAL(tr_seri(:,1,id_CO2)*1.e6*RMD/RMCO2)
-
-    PRINT *, 'tracco2i_mod.F90 --- MINVAL(tr_seri(:,79,id_CO2)*1.e6*RMD/RMCO2): L79: ',MINVAL(tr_seri(:,79,id_CO2)*1.e6*RMD/RMCO2)
-    PRINT *, 'tracco2i_mod.F90 --- MAXVAL(tr_seri(:,79,id_CO2)*1.e6*RMD/RMCO2): L79: ',MAXVAL(tr_seri(:,79,id_CO2)*1.e6*RMD/RMCO2)
-
-    co2_send(:) = tr_seri(:,1,id_CO2)*1.e6*RMD/RMCO2
-
-    PRINT *, 'tracco2i_mod.F90 --- MINVAL(co2_send) ',MINVAL(co2_send)
-    PRINT *, 'tracco2i_mod.F90 --- MAXVAL(co2_send) ',MAXVAL(co2_send)
-
-  END SUBROUTINE tracco2i
-
-  SUBROUTINE co2_emissions(debutphy)
-
-    USE dimphy
-!    USE infotrac_phy
-    USE geometry_mod, ONLY : cell_area
-    USE mod_grid_phy_lmdz
-    USE mod_phys_lmdz_mpi_data, ONLY: is_mpi_root
-    USE mod_phys_lmdz_para, ONLY: gather, scatter
-    USE phys_cal_mod
-
-    USE netcdf95, ONLY: nf95_close, nf95_gw_var, nf95_inq_varid, nf95_open
-    USE netcdf, ONLY: nf90_get_var, nf90_noerr, nf90_nowrite
-
-    USE carbon_cycle_mod, ONLY : fco2_ff, fco2_bb, fco2_land, fco2_ocean
-
-    IMPLICIT NONE
-
-    INCLUDE "YOMCST.h"
-    LOGICAL,INTENT(IN) :: debutphy
-
-! For NetCDF:
-    INTEGER ncid_in  ! IDs for input files
-    INTEGER varid, ncerr
-
-    INTEGER :: n_glo, n_month
-    REAL, allocatable:: vector(:), time(:)
-    REAL,ALLOCATABLE       :: flx_co2ff_glo(:,:) !  fossil-fuel CO2 
-    REAL,ALLOCATABLE       :: flx_co2bb_glo(:,:) !  biomass-burning CO2 
-    REAL,ALLOCATABLE, SAVE :: flx_co2ff(:,:)     !  fossil-fuel CO2 
-    REAL,ALLOCATABLE, SAVE :: flx_co2bb(:,:)     !  biomass-burning CO2 
-!$OMP THREADPRIVATE(flx_co2ff,flx_co2bb)
-
-!! may be controlled via the .def later on
-!! also co2bb for now comes from ORCHIDEE
-    LOGICAL, PARAMETER :: readco2ff=.TRUE.
-!! this should be left to FALSE for now
-    LOGICAL, PARAMETER :: readco2bb=.FALSE. 
-
-    CHARACTER (len = 20) :: modname = 'tracco2i.co2_emissions'
-    CHARACTER (len = 80) :: abort_message
-
-    IF (debutphy) THEN 
-
-    ALLOCATE(flx_co2ff(klon,12))
-    ALLOCATE(flx_co2bb(klon,12))
-
-!$OMP MASTER
-    IF (is_mpi_root) THEN
-    
-      IF (.NOT.ALLOCATED(flx_co2ff_glo)) ALLOCATE(flx_co2ff_glo(klon_glo,12))
-      IF (.NOT.ALLOCATED(flx_co2bb_glo)) ALLOCATE(flx_co2bb_glo(klon_glo,12))
-
-!--reading CO2 fossil fuel emissions
-      IF (readco2ff) THEN 
-
-        ! ... Open the CO2ff file
-        CALL nf95_open("sflx_lmdz_co2_ff.nc", nf90_nowrite, ncid_in)
-
-        CALL nf95_inq_varid(ncid_in, "vector", varid)
-        CALL nf95_gw_var(ncid_in, varid, vector)
-        n_glo = size(vector)
-        IF (n_glo.NE.klon_glo) THEN
-           abort_message='sflx_lmdz_co2_ff: le nombre de points n est pas egal a klon_glo'
-           CALL abort_physic(modname,abort_message,1)
-        ENDIF
-
-        CALL nf95_inq_varid(ncid_in, "time", varid)
-        CALL nf95_gw_var(ncid_in, varid, time)
-        n_month = size(time)
-        IF (n_month.NE.12) THEN
-           abort_message='sflx_lmdz_co2_ff: le nombre de month n est pas egal a 12'
-           CALL abort_physic(modname,abort_message,1)
-        ENDIF
-
-!--reading flx_co2 for fossil fuel
-        CALL nf95_inq_varid(ncid_in, "flx_co2", varid)
-        ncerr = nf90_get_var(ncid_in, varid, flx_co2ff_glo)
-
-        CALL nf95_close(ncid_in)
-    
-      ELSE  !--co2ff not to be read
-        flx_co2ff_glo(:,:)=0.0
-      ENDIF
-
-!--reading CO2 biomass burning emissions
-!--using it will be inconsistent with treatment in ORCHIDEE
-      IF (readco2bb) THEN 
-
-      ! ... Open the CO2bb file
-      CALL nf95_open("sflx_lmdz_co2_bb.nc", nf90_nowrite, ncid_in)
-
-      CALL nf95_inq_varid(ncid_in, "vector", varid)
-      CALL nf95_gw_var(ncid_in, varid, vector)
-      n_glo = size(vector)
-      IF (n_glo.NE.klon_glo) THEN
-         abort_message='sflx_lmdz_co2_bb: le nombre de points n est pas egal a klon_glo'
-         CALL abort_physic(modname,abort_message,1)
-      ENDIF
-
-      CALL nf95_inq_varid(ncid_in, "time", varid)
-      CALL nf95_gw_var(ncid_in, varid, time)
-      n_month = size(time)
-      IF (n_month.NE.12) THEN
-         abort_message='sflx_lmdz_co2_bb: le nombre de month n est pas egal a 12'
-         CALL abort_physic(modname,abort_message,1)
-      ENDIF
-
-!--reading flx_co2 for biomass burning
-      CALL nf95_inq_varid(ncid_in, "flx_co2", varid)
-      ncerr = nf90_get_var(ncid_in, varid, flx_co2bb_glo)
-
-      CALL nf95_close(ncid_in)
-    
-      ELSE  !--co2bb not to be read
-        flx_co2bb_glo(:,:)=0.0
-      ENDIF
-
-    ENDIF
-!$OMP END MASTER
-
-    ! Allocation needed for all proc otherwise scatter might complain
-    IF (.NOT.ALLOCATED(flx_co2ff_glo)) ALLOCATE(flx_co2ff_glo(0,0))
-    IF (.NOT.ALLOCATED(flx_co2bb_glo)) ALLOCATE(flx_co2bb_glo(0,0))
-
-!--scatter on all proc
-    CALL scatter(flx_co2ff_glo,flx_co2ff)
-    CALL scatter(flx_co2bb_glo,flx_co2bb)
-
-   IF (ALLOCATED(flx_co2ff_glo)) DEALLOCATE(flx_co2ff_glo)
-   IF (ALLOCATED(flx_co2bb_glo)) DEALLOCATE(flx_co2bb_glo)
-
-  ENDIF !--end debuthy
-
-!---select the correct month
-  IF (mth_cur.LT.1.OR.mth_cur.GT.12) THEN
-    PRINT *,'probleme avec le mois dans co2_ini =', mth_cur
-  ENDIF
-
-  fco2_ff(:) = flx_co2ff(:,mth_cur)
-  fco2_bb(:) = flx_co2bb(:,mth_cur)
-
-  END SUBROUTINE co2_emissions
-
-END MODULE tracco2i_mod
Index: /LMDZ6/trunk/libf/phylmd/tracco2i_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/tracco2i_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/tracco2i_mod.f90	(revision 5268)
@@ -0,0 +1,485 @@
+MODULE tracco2i_mod
+!
+! This module does the work for the interactive CO2 tracers
+! Authors: Patricia Cadule and Olivier Boucher
+!
+! Purpose and description:
+!  -----------------------
+! Main routine for the interactive carbon cycle
+! Gather all carbon fluxes and emissions from ORCHIDEE, PISCES and fossil fuel
+! Compute the net flux in source field which is used in phytrac
+! Compute global CO2 mixing ratio for radiation scheme if option is activated
+! Redistribute CO2 evenly over the atmosphere if transport is desactivated
+!
+CONTAINS
+
+  SUBROUTINE tracco2i_init()
+    ! This subroutine calls carbon_cycle_init needed to be done before first call to phys_output_write in physiq.
+    USE carbon_cycle_mod, ONLY: carbon_cycle_init, carbon_cycle_cpl
+
+    ! Initialize carbon_cycle_mod
+    IF (carbon_cycle_cpl) THEN
+       CALL carbon_cycle_init()
+    ENDIF
+
+  END SUBROUTINE tracco2i_init
+
+  SUBROUTINE tracco2i(pdtphys, debutphy, &
+       xlat, xlon, pphis, pphi, &
+       t_seri, pplay, paprs, tr_seri, source)
+
+    USE dimphy
+    USE infotrac_phy, ONLY: nbtr
+    USE geometry_mod, ONLY: cell_area
+    USE carbon_cycle_mod, ONLY: id_CO2, nbcf_in, fields_in, cfname_in
+    USE carbon_cycle_mod, ONLY: fco2_ocn_day, fco2_ff, fco2_bb, fco2_land, fco2_ocean
+    USE carbon_cycle_mod, ONLY: read_fco2_ocean_cor,var_fco2_ocean_cor,fco2_ocean_cor 
+    USE carbon_cycle_mod, ONLY: read_fco2_land_cor,var_fco2_land_cor,fco2_land_cor 
+    USE carbon_cycle_mod, ONLY: co2_send
+    USE carbon_cycle_mod, ONLY: fco2_land_nbp, fco2_land_nep, fco2_land_fLuc
+    USE carbon_cycle_mod, ONLY: fco2_land_fwoodharvest, fco2_land_fHarvest
+    USE carbon_cycle_mod, ONLY: carbon_cycle_cpl, carbon_cycle_tr, carbon_cycle_rad, RCO2_glo, RCO2_tot
+    USE carbon_cycle_mod, ONLY: ocean_area_tot
+    USE carbon_cycle_mod, ONLY: land_area_tot
+    USE mod_grid_phy_lmdz
+    USE mod_phys_lmdz_mpi_data, ONLY: is_mpi_root
+    USE mod_phys_lmdz_para, ONLY: gather, bcast, scatter
+    USE mod_phys_lmdz_omp_data, ONLY: is_omp_root
+    USE phys_cal_mod
+    USE phys_state_var_mod, ONLY: pctsrf
+    USE indice_sol_mod, ONLY: nbsrf, is_ter, is_lic, is_oce, is_sic
+
+    IMPLICIT NONE
+
+    INCLUDE "clesphys.h"
+    INCLUDE "YOMCST.h"
+
+! Input argument
+!---------------
+    REAL,INTENT(IN)    :: pdtphys    ! Pas d'integration pour la physique (seconde)
+    LOGICAL,INTENT(IN) :: debutphy   ! le flag de l'initialisation de la physique
+
+    REAL,DIMENSION(klon),INTENT(IN)        :: xlat    ! latitudes pour chaque point 
+    REAL,DIMENSION(klon),INTENT(IN)        :: xlon    ! longitudes pour chaque point 
+    REAL,DIMENSION(klon),INTENT(IN)        :: pphis   ! geopotentiel du sol
+    REAL,DIMENSION(klon,klev),INTENT(IN)   :: pphi    ! geopotentiel de chaque couche
+
+    REAL,DIMENSION(klon,klev),INTENT(IN)   :: t_seri  ! Temperature
+    REAL,DIMENSION(klon,klev),INTENT(IN)   :: pplay   ! pression pour le mileu de chaque couche (en Pa)
+    REAL,DIMENSION(klon,klev+1),INTENT(IN) :: paprs   ! pression pour chaque inter-couche (en Pa)
+    REAL,DIMENSION(klon,nbtr),INTENT(INOUT):: source  ! flux de traceur [U/m2/s]
+
+! Output argument
+!----------------
+    REAL,DIMENSION(klon,klev,nbtr),INTENT(INOUT)  :: tr_seri ! Concentration Traceur [U/kgA]  
+
+! Local variables
+!----------------
+
+    INTEGER                        :: it, k, i, nb
+    REAL, DIMENSION(klon,klev)     :: m_air     ! mass of air in every grid box [kg]
+    REAL, DIMENSION(klon_glo,klev) :: co2_glo   ! variable temporaire sur la grille global
+    REAL, DIMENSION(klon_glo,klev) :: m_air_glo ! variable temporaire sur la grille global
+    REAL, DIMENSION(klon_glo,nbsrf):: pctsrf_glo      !--fractions de maille sur la grille globale
+    REAL, DIMENSION(klon_glo)      :: pctsrf_ter_glo
+    REAL, DIMENSION(klon_glo)      :: pctsrf_oce_glo
+    REAL, DIMENSION(klon_glo)      :: pctsrf_sic_glo
+    REAL, DIMENSION(klon_glo)      :: cell_area_glo   !--aire des mailles sur la grille globale
+
+    LOGICAL, SAVE :: check_fCO2_nbp_in_cfname
+!$OMP THREADPRIVATE(check_fCO2_nbp_in_cfname)
+    INTEGER, SAVE :: day_pre=-1
+!$OMP THREADPRIVATE(day_pre)
+
+    REAL, PARAMETER :: secinday=86400.
+
+    IF (is_mpi_root) THEN
+      PRINT *,'in tracco2i: date from phys_cal_mod =',year_cur,'-',mth_cur,'-',day_cur,'-',hour
+    ENDIF
+
+!--initialisation of CO2 field if not in restart file
+!--dirty way of doing, do it better later
+!--convert 280 ppm into kg CO2 / kg air
+    IF (debutphy) THEN
+
+! Initialization of tr_seri(id_CO2) If it is not initialized
+      IF (MAXVAL(tr_seri(:,:,id_CO2)).LT.1.e-15) THEN 
+        tr_seri(:,:,id_CO2)=co2_ppm0*1.e-6/RMD*RMCO2 !--initialised from co2_ppm0 in rdem
+      ENDIF 
+
+!--check if fCO2_nbp is in 
+      check_fCO2_nbp_in_cfname=.FALSE.
+      DO nb=1, nbcf_in
+        IF (cfname_in(nb)=="fCO2_nbp") check_fCO2_nbp_in_cfname=.TRUE.
+      ENDDO
+
+      CALL gather(pctsrf,pctsrf_glo)
+      CALL gather(pctsrf(:,is_ter),pctsrf_ter_glo)
+      CALL gather(pctsrf(:,is_oce),pctsrf_oce_glo)
+      CALL gather(pctsrf(:,is_sic),pctsrf_sic_glo)
+      CALL gather(cell_area(:),cell_area_glo)
+
+    ENDIF
+
+!--calculate mass of air in every grid box in kg air
+    DO i=1, klon
+    DO k=1, klev
+      m_air(i,k)=(paprs(i,k)-paprs(i,k+1))/RG*cell_area(i)
+    ENDDO
+    ENDDO
+
+!--call CO2 emission routine 
+!--co2bb is zero for now
+!--unit kg CO2 m-2 s-1 
+    CALL co2_emissions(debutphy)
+
+!--retrieving land and ocean CO2 flux
+    fco2_land(:)=0.0
+    fco2_ocean(:)=0.0
+    fco2_land_nbp(:)=0.
+    fco2_land_nep(:)=0.
+    fco2_land_fLuc(:)=0.
+    fco2_land_fwoodharvest(:)=0.
+    fco2_land_fHarvest(:)=0.
+
+    DO nb=1, nbcf_in
+
+      SELECT CASE(cfname_in(nb))
+!--dealing with the different fluxes coming from ORCHIDEE
+!--fluxes come in unit of kg C m-2 s-1 is converted into kg CO2 m-2 s-1
+      CASE("fCO2_nep")
+          fco2_land_nep(:)=fields_in(:,nb)*RMCO2/RMC*pctsrf(:,is_ter)
+      CASE("fCO2_fLuc")
+          fco2_land_fLuc(:)=fields_in(:,nb)*RMCO2/RMC*pctsrf(:,is_ter)
+      CASE("fCO2_fwoodharvest")
+          fco2_land_fwoodharvest(:)=fields_in(:,nb)*RMCO2/RMC*pctsrf(:,is_ter)
+      CASE("fCO2_fHarvest")
+          fco2_land_fHarvest(:)=fields_in(:,nb)*RMCO2/RMC*pctsrf(:,is_ter)
+      CASE("fCO2_nbp")
+          fco2_land_nbp(:)=fields_in(:,nb)*RMCO2/RMC*pctsrf(:,is_ter)
+!--fCO2_fco2_ocn comes in unit of mol C02 m-2 s-1 is converted into kg CO2 m-2 s-1 + change sign
+      CASE("fCO2_fgco2") 
+          fco2_ocean(:)=-1.*fco2_ocn_day(:)*RMCO2/1.e3*(pctsrf(:,is_oce)+pctsrf(:,is_sic))
+      END SELECT
+
+    ENDDO
+
+    PRINT *, 'tracco2i_mod.F90 --- read_fco2_ocean_cor ',read_fco2_ocean_cor
+    PRINT *, 'tracco2i_mod.F90 --- read_fco2_land_cor ',read_fco2_land_cor
+
+IF (debutphy) THEN
+
+    IF (read_fco2_ocean_cor) THEN
+!$OMP MASTER
+       IF (is_mpi_root .AND. is_omp_root) THEN
+          ocean_area_tot=0.
+          PRINT *, 'tracco2i_mod.F90 --- var_fco2_ocean_cor (PgC/yr) ',var_fco2_ocean_cor
+          DO i=1, klon_glo
+             ocean_area_tot = ocean_area_tot + (pctsrf_oce_glo(i)+pctsrf_sic_glo(i))*cell_area_glo(i)
+          ENDDO
+      ENDIF !--is_mpi_root and is_omp_root 
+!$OMP END MASTER
+      CALL bcast(ocean_area_tot)
+     PRINT *, 'tracco2i_mod.F90 --- ocean_area_tot (debutphy) ',ocean_area_tot
+    ENDIF
+
+    IF (read_fco2_land_cor) THEN
+!$OMP MASTER
+       IF (is_mpi_root .AND. is_omp_root) THEN
+          land_area_tot=0.
+          PRINT *, 'tracco2i_mod.F90 --- var_fco2_land_cor (PgC/yr) ',var_fco2_land_cor
+          DO i=1, klon_glo
+             land_area_tot = land_area_tot + pctsrf_ter_glo(i)*cell_area_glo(i) 
+          ENDDO
+      ENDIF !--is_mpi_root and is_omp_root 
+!$OMP END MASTER
+      CALL bcast(land_area_tot)
+     PRINT *, 'tracco2i_mod.F90 --- land_area_tot (debutphy) ',land_area_tot 
+ENDIF
+
+    ENDIF !-- debutphy  
+
+    PRINT *, 'tracco2i_mod.F90 --- ocean_area_tot (m2) ',ocean_area_tot
+    PRINT *, 'tracco2i_mod.F90 --- land_area_tot (m2) ',land_area_tot
+
+    IF (read_fco2_ocean_cor) THEN
+! var_fco2_ocean_cor: correction of the surface downward CO2 flux into the ocean fgco2 (PgC/yr)
+! This is the correction of the the net air to ocean carbon flux. Positive flux is into the ocean.
+!    PRINT *, 'tracco2i_mod.F90 --- var_fco2_ocean_cor (PgC/yr) ',var_fco2_ocean_cor
+
+!var_fco2_ocean_cor: correction of the net air to ocean carbon flux (input data is a scalar in PgC/yr and must be converted in kg CO2 m-2 s-1)
+
+! Factors for carbon and carbon dioxide
+! 1 mole CO2 = 44.009 g CO2 = 12.011 g C
+! 1 ppm by volume of atmosphere CO2 = 2.13 Gt C
+! 1 gC = 44.009/12.011 gCO2
+
+! ocean_area_tot: ocean area (m2)
+
+! year_len: year length (in days)
+
+! conversion: PgC/yr --> kg CO2 m-2 s-1
+! fco2_ocean_cor  / (86400.*year_len): PgC/yr to PgC/s
+! fco2_ocean_cor  / (86400.*year_len)*(pctsrf(i,is_oce)+pctsrf(i,is_sic))/ocean_area_tot: PgC/s to PgC/s/m2
+! (fco2_ocean_cor / (86400.*year_len)*(pctsrf(i,is_oce)+pctsrf(i,is_sic))/ocean_area_tot) *1e12: PgC/s/m2 to kgC/s/m2
+! (fco2_ocean_cor / (86400.*year_len)*(pctsrf(i,is_oce)+pctsrf(i,is_sic))/ocean_area_tot) * 1e12 * (RMCO2/RMC): kgC/s/m2 to kgCO2/s/m2
+
+      DO i=1, klon  
+         fco2_ocean_cor(i)=(var_fco2_ocean_cor*(RMCO2/RMC) &
+              *(pctsrf(i,is_oce)+pctsrf(i,is_sic))/ocean_area_tot &
+              /(secinday*year_len))*1.e12
+      ENDDO
+
+      PRINT *, 'tracco2i_mod.F90 --- MINVAL(fco2_ocean_cor) ',MINVAL(fco2_ocean_cor)
+      PRINT *, 'tracco2i_mod.F90 --- MAXVAL(fco2_ocean_cor) ',MAXVAL(fco2_ocean_cor)
+
+    ELSE
+    fco2_ocean_cor(:)=0.
+    ENDIF
+
+    IF (read_fco2_land_cor) THEN
+! var_fco2_land_cor: correction of the carbon Mass Flux out of Atmosphere Due to Net Biospheric Production on Land  (PgC/yr)
+! This is the correction of the net mass flux of carbon between land and atmosphere calculated as
+! photosynthesis MINUS the sum of plant and soil respiration, carbon fluxes from
+! fire, harvest, grazing and land use change. Positive flux is into the land.
+!    PRINT *, 'tracco2i_mod.F90 --- var_fco2_land_cor (m2) ',var_fco2_land_cor
+
+!var_fco2_land_cor: correction of the et air to land carbon flux (input data is a scalar in PgC/yr and must be converted in kg CO2 m-2 s-1)
+
+! Factors for carbon and carbon dioxide
+! 1 mole CO2 = 44.009 g CO2 = 12.011 g C
+! 1 ppm by volume of atmosphere CO2 = 2.13 Gt C
+! 1 gC = 44.009/12.011 gCO2
+
+! land_area_tot: land area (m2)
+
+! year_len: year length (in days)
+
+! conversion: PgC/yr --> kg CO2 m-2 s-1
+! fco2_land_cor  / (86400.*year_len): PgC/yr to PgC/s
+! fco2_land_cor  / (86400.*year_len)*pctsrf(i,is_ter)/land_area_tot: PgC/s to PgC/s/m2
+! (fco2_land_cor / (86400.*year_len)*pctsrf(i,is_ter)/land_area_tot) *1e12: PgC/s/m2 to kgC/s/m2
+! (fco2_land_cor / (86400.*year_len)*pctsrf(i,is_ter)/land_area_tot) * 1e12 * (RMCO2/RMC): kgC/s/m2 to kgCO2/s/m2
+
+      DO i=1, klon
+         fco2_land_cor(i)=var_fco2_land_cor*RMCO2/RMC*pctsrf(i,is_ter)/land_area_tot/(secinday*year_len)*1.e12
+      ENDDO
+
+      PRINT *, 'tracco2i_mod.F90 --- MINVAL(fco2_land_cor) ',MINVAL(fco2_land_cor)
+      PRINT *, 'tracco2i_mod.F90 --- MAXVAL(fco2_land_cor) ',MAXVAL(fco2_land_cor)
+
+    ELSE
+      fco2_land_cor(:)=0.
+    ENDIF
+
+!--if fCO2_nbp is transferred we use it, otherwise we use the sum of what has been passed from ORCHIDEE
+    IF (check_fCO2_nbp_in_cfname)  THEN
+       fco2_land(:)=fco2_land_nbp(:)
+    ELSE
+       fco2_land(:)=fco2_land_nep(:)+fco2_land_fLuc(:)+fco2_land_fwoodharvest(:)+fco2_land_fHarvest(:)
+    ENDIF
+
+!!--preparing the net anthropogenic flux at the surface for mixing layer
+!!--unit kg CO2 / m2 / s
+!    PRINT *, 'tracco2i_mod.F90 --- MAXVAL(fco2_ff) ',MAXVAL(fco2_ff)
+!    PRINT *, 'tracco2i_mod.F90 --- MINVAL(fco2_ff) ',MINVAL(fco2_ff)
+!    PRINT *, 'tracco2i_mod.F90 --- MAXVAL(fco2_bb) ',MAXVAL(fco2_bb)
+!    PRINT *, 'tracco2i_mod.F90 --- MINVAL(fco2_bb) ',MINVAL(fco2_bb)
+!    PRINT *, 'tracco2i_mod.F90 --- MAXVAL(fco2_land) ',MAXVAL(fco2_land)
+!    PRINT *, 'tracco2i_mod.F90 --- MINVAL(fco2_land) ',MINVAL(fco2_land)
+!    PRINT *, 'tracco2i_mod.F90 --- MAXVAL(fco2_ocean) ',MAXVAL(fco2_ocean)
+!    PRINT *, 'tracco2i_mod.F90 --- MINVAL(fco2_ocean) ',MINVAL(fco2_ocean)
+!    PRINT *, 'tracco2i_mod.F90 --- MAXVAL(source(:,id_CO2)) ',MAXVAL(source(:,id_CO2))
+!    PRINT *, 'tracco2i_mod.F90 --- MINVAL(source(:,id_CO2)) ',MINVAL(source(:,id_CO2))
+!
+!--build final source term for CO2
+    source(:,id_CO2)=fco2_ff(:)+fco2_bb(:)+fco2_land(:)+fco2_ocean(:)-fco2_ocean_cor(:)-fco2_land_cor(:)
+
+!--computing global mean CO2 for radiation
+!--for every timestep comment out the IF ENDIF statements 
+!--otherwise this is updated every day
+    IF (debutphy.OR.day_cur.NE.day_pre) THEN
+
+      CALL gather(tr_seri(:,:,id_CO2),co2_glo)
+      CALL gather(m_air,m_air_glo)
+
+!$OMP MASTER
+
+!--compute a global mean CO2 value and print its value in ppm
+       IF (is_mpi_root .AND. is_omp_root) THEN
+         RCO2_tot=SUM(co2_glo*m_air_glo)  !--unit kg CO2
+         RCO2_glo=RCO2_tot/SUM(m_air_glo) !--unit kg CO2 / kg air
+         ! the following operation is only to maintain precision consistency
+         ! of RCO2_glo which differs whether it is directly computed or read from
+         ! a restart file (after having been computed)
+         RCO2_glo = FLOAT(INT(RCO2_glo * 1e8))/1e8
+         PRINT *,'tracco2i: global CO2 in ppm =', RCO2_glo*1.e6*RMD/RMCO2
+         PRINT *,'tracco2i: total CO2 in kg =', RCO2_tot
+       ENDIF
+!$OMP END MASTER
+       CALL bcast(RCO2_glo)
+       day_pre=day_cur
+
+!--if not carbon_cycle_tr, then we reinitialize the CO2 each day to its global mean value
+       IF (.NOT.carbon_cycle_tr) THEN 
+         tr_seri(:,:,id_CO2)=RCO2_glo
+       ENDIF
+    ENDIF
+
+    PRINT *, 'tracco2i_mod.F90 --- MINVAL(tr_seri(:,1,id_CO2)*1.e6*RMD/RMCO2): L1: ',MINVAL(tr_seri(:,1,id_CO2)*1.e6*RMD/RMCO2)
+    PRINT *, 'tracco2i_mod.F90 --- MAXVAL(tr_seri(:,1,id_CO2)*1.e6*RMD/RMCO2): L1: ',MAXVAL(tr_seri(:,1,id_CO2)*1.e6*RMD/RMCO2)
+
+    PRINT *, 'tracco2i_mod.F90 --- MINVAL(tr_seri(:,79,id_CO2)*1.e6*RMD/RMCO2): L79: ',MINVAL(tr_seri(:,79,id_CO2)*1.e6*RMD/RMCO2)
+    PRINT *, 'tracco2i_mod.F90 --- MAXVAL(tr_seri(:,79,id_CO2)*1.e6*RMD/RMCO2): L79: ',MAXVAL(tr_seri(:,79,id_CO2)*1.e6*RMD/RMCO2)
+
+    co2_send(:) = tr_seri(:,1,id_CO2)*1.e6*RMD/RMCO2
+
+    PRINT *, 'tracco2i_mod.F90 --- MINVAL(co2_send) ',MINVAL(co2_send)
+    PRINT *, 'tracco2i_mod.F90 --- MAXVAL(co2_send) ',MAXVAL(co2_send)
+
+  END SUBROUTINE tracco2i
+
+  SUBROUTINE co2_emissions(debutphy)
+
+    USE dimphy
+!    USE infotrac_phy
+    USE geometry_mod, ONLY : cell_area
+    USE mod_grid_phy_lmdz
+    USE mod_phys_lmdz_mpi_data, ONLY: is_mpi_root
+    USE mod_phys_lmdz_para, ONLY: gather, scatter
+    USE phys_cal_mod
+
+    USE netcdf95, ONLY: nf95_close, nf95_gw_var, nf95_inq_varid, nf95_open
+    USE netcdf, ONLY: nf90_get_var, nf90_noerr, nf90_nowrite
+
+    USE carbon_cycle_mod, ONLY : fco2_ff, fco2_bb, fco2_land, fco2_ocean
+
+    IMPLICIT NONE
+
+    INCLUDE "YOMCST.h"
+    LOGICAL,INTENT(IN) :: debutphy
+
+! For NetCDF:
+    INTEGER ncid_in  ! IDs for input files
+    INTEGER varid, ncerr
+
+    INTEGER :: n_glo, n_month
+    REAL, allocatable:: vector(:), time(:)
+    REAL,ALLOCATABLE       :: flx_co2ff_glo(:,:) !  fossil-fuel CO2 
+    REAL,ALLOCATABLE       :: flx_co2bb_glo(:,:) !  biomass-burning CO2 
+    REAL,ALLOCATABLE, SAVE :: flx_co2ff(:,:)     !  fossil-fuel CO2 
+    REAL,ALLOCATABLE, SAVE :: flx_co2bb(:,:)     !  biomass-burning CO2 
+!$OMP THREADPRIVATE(flx_co2ff,flx_co2bb)
+
+!! may be controlled via the .def later on
+!! also co2bb for now comes from ORCHIDEE
+    LOGICAL, PARAMETER :: readco2ff=.TRUE.
+!! this should be left to FALSE for now
+    LOGICAL, PARAMETER :: readco2bb=.FALSE. 
+
+    CHARACTER (len = 20) :: modname = 'tracco2i.co2_emissions'
+    CHARACTER (len = 80) :: abort_message
+
+    IF (debutphy) THEN 
+
+    ALLOCATE(flx_co2ff(klon,12))
+    ALLOCATE(flx_co2bb(klon,12))
+
+!$OMP MASTER
+    IF (is_mpi_root) THEN
+    
+      IF (.NOT.ALLOCATED(flx_co2ff_glo)) ALLOCATE(flx_co2ff_glo(klon_glo,12))
+      IF (.NOT.ALLOCATED(flx_co2bb_glo)) ALLOCATE(flx_co2bb_glo(klon_glo,12))
+
+!--reading CO2 fossil fuel emissions
+      IF (readco2ff) THEN 
+
+        ! ... Open the CO2ff file
+        CALL nf95_open("sflx_lmdz_co2_ff.nc", nf90_nowrite, ncid_in)
+
+        CALL nf95_inq_varid(ncid_in, "vector", varid)
+        CALL nf95_gw_var(ncid_in, varid, vector)
+        n_glo = size(vector)
+        IF (n_glo.NE.klon_glo) THEN
+           abort_message='sflx_lmdz_co2_ff: le nombre de points n est pas egal a klon_glo'
+           CALL abort_physic(modname,abort_message,1)
+        ENDIF
+
+        CALL nf95_inq_varid(ncid_in, "time", varid)
+        CALL nf95_gw_var(ncid_in, varid, time)
+        n_month = size(time)
+        IF (n_month.NE.12) THEN
+           abort_message='sflx_lmdz_co2_ff: le nombre de month n est pas egal a 12'
+           CALL abort_physic(modname,abort_message,1)
+        ENDIF
+
+!--reading flx_co2 for fossil fuel
+        CALL nf95_inq_varid(ncid_in, "flx_co2", varid)
+        ncerr = nf90_get_var(ncid_in, varid, flx_co2ff_glo)
+
+        CALL nf95_close(ncid_in)
+    
+      ELSE  !--co2ff not to be read
+        flx_co2ff_glo(:,:)=0.0
+      ENDIF
+
+!--reading CO2 biomass burning emissions
+!--using it will be inconsistent with treatment in ORCHIDEE
+      IF (readco2bb) THEN 
+
+      ! ... Open the CO2bb file
+      CALL nf95_open("sflx_lmdz_co2_bb.nc", nf90_nowrite, ncid_in)
+
+      CALL nf95_inq_varid(ncid_in, "vector", varid)
+      CALL nf95_gw_var(ncid_in, varid, vector)
+      n_glo = size(vector)
+      IF (n_glo.NE.klon_glo) THEN
+         abort_message='sflx_lmdz_co2_bb: le nombre de points n est pas egal a klon_glo'
+         CALL abort_physic(modname,abort_message,1)
+      ENDIF
+
+      CALL nf95_inq_varid(ncid_in, "time", varid)
+      CALL nf95_gw_var(ncid_in, varid, time)
+      n_month = size(time)
+      IF (n_month.NE.12) THEN
+         abort_message='sflx_lmdz_co2_bb: le nombre de month n est pas egal a 12'
+         CALL abort_physic(modname,abort_message,1)
+      ENDIF
+
+!--reading flx_co2 for biomass burning
+      CALL nf95_inq_varid(ncid_in, "flx_co2", varid)
+      ncerr = nf90_get_var(ncid_in, varid, flx_co2bb_glo)
+
+      CALL nf95_close(ncid_in)
+    
+      ELSE  !--co2bb not to be read
+        flx_co2bb_glo(:,:)=0.0
+      ENDIF
+
+    ENDIF
+!$OMP END MASTER
+
+    ! Allocation needed for all proc otherwise scatter might complain
+    IF (.NOT.ALLOCATED(flx_co2ff_glo)) ALLOCATE(flx_co2ff_glo(0,0))
+    IF (.NOT.ALLOCATED(flx_co2bb_glo)) ALLOCATE(flx_co2bb_glo(0,0))
+
+!--scatter on all proc
+    CALL scatter(flx_co2ff_glo,flx_co2ff)
+    CALL scatter(flx_co2bb_glo,flx_co2bb)
+
+   IF (ALLOCATED(flx_co2ff_glo)) DEALLOCATE(flx_co2ff_glo)
+   IF (ALLOCATED(flx_co2bb_glo)) DEALLOCATE(flx_co2bb_glo)
+
+  ENDIF !--end debuthy
+
+!---select the correct month
+  IF (mth_cur.LT.1.OR.mth_cur.GT.12) THEN
+    PRINT *,'probleme avec le mois dans co2_ini =', mth_cur
+  ENDIF
+
+  fco2_ff(:) = flx_co2ff(:,mth_cur)
+  fco2_bb(:) = flx_co2bb(:,mth_cur)
+
+  END SUBROUTINE co2_emissions
+
+END MODULE tracco2i_mod
Index: DZ6/trunk/libf/phylmd/tracinca_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/tracinca_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,210 +1,0 @@
-!$Id $
-!
-MODULE tracinca_mod
-!
-! This module prepares and calls the INCA main subroutines. 
-!
-  IMPLICIT NONE  
-
-  CHARACTER(len=4),SAVE :: config_inca
-!$OMP THREADPRIVATE(config_inca)
-                     ! config_inca='none' => without INCA
-                     ! config_inca='chem' => INCA with chemistry
-                     ! config_inca='aero' => INCA with aerosols
-                     ! config_inca='aeNP' => INCA with aerosols NP (?)
-CONTAINS
-
-  SUBROUTINE tracinca_init(aerosol,lessivage)
-    ! This subroutine initialize some control varaibles. 
-
-    USE infotrac_phy, ONLY: nbtr, type_trac
-    IMPLICIT NONE
-    
-    ! Output variables
-    LOGICAL,DIMENSION(nbtr), INTENT(OUT) :: aerosol
-    LOGICAL,INTENT(OUT) :: lessivage
-    
-    ! Initialization
-    lessivage  =.FALSE.
-    aerosol(:) = .FALSE.
-
-    !--- COHERENCE TEST BETWEEN "type_trac" AND "config_inca"
-    IF(ANY(type_trac == ['inca','inco']) .AND. ALL(config_inca /= ['aero','aeNP','chem'])) CALL abort_physic('tracinca_init', &
-       'INCA enabled, but unknown config_inca = "'//TRIM(config_inca)//'". Please modify "run.def"', 1)
-
-    !--- PROBLEM IF "config_inca" DIFFERS FROM "none" AND INCA HAS NOT BEEN ACTIVATED
-    IF(ALL(type_trac /= ['inca','inco'])  .AND.    config_inca /= 'none')                  CALL abort_physic('tracinca_init', &
-       'INCA disabled, but config_inca = "'//TRIM(config_inca)//'" should be "none". Please modify "run.def"', 1)
-
-  END SUBROUTINE tracinca_init
-
-  SUBROUTINE tracinca(                                &
-       nstep,    julien,   gmtime,         lafin,     &
-       pdtphys,  t_seri,   paprs,          pplay,     &
-       pmfu,     upwd,     ftsol,  pctsrf, pphis,     &
-       pphi,     albsol,   sh,             ch, rh,    &
-       cldfra,   rneb,     diafra,         cldliq,    &
-       itop_con, ibas_con, pmflxr,         pmflxs,    &
-       prfl,     psfl,     aerosol_couple, flxmass_w, &
-       tau_aero, piz_aero, cg_aero,        ccm,       &
-       rfname,                                        &
-       tr_seri,  source)      
-
-!========================================================
-!    -- CHIMIE INCA --
-!========================================================
-
-    USE dimphy
-    USE infotrac_phy, ONLY: nbtr
-    USE vampir
-    USE indice_sol_mod
-    USE geometry_mod, ONLY: cell_area
-    USE mod_grid_phy_lmdz, ONLY: nbp_lon, nbp_lat
-    USE aero_mod, ONLY : naero_grp
-    USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_INCA
-    IMPLICIT NONE
-    
-!==========================================================================
-!                   -- DESCRIPTION DES ARGUMENTS --
-!==========================================================================
-
-
-! EN ENTREE ...
-!
-!Configuration grille,temps:
-    INTEGER,INTENT(IN) :: nstep      ! Appel physique
-    INTEGER,INTENT(IN) :: julien     ! Jour julien
-    REAL,INTENT(IN)    :: gmtime
-    REAL,INTENT(IN)    :: pdtphys    ! Pas d'integration pour la physique (seconde)
-    LOGICAL,INTENT(IN) :: lafin      ! le flag de la fin de la physique
-    
-
-!Physique: 
-!--------
-    REAL,DIMENSION(klon,klev),INTENT(IN)   :: t_seri  ! Temperature
-    REAL,DIMENSION(klon,klev),INTENT(IN)   :: sh      ! humidite specifique
-    REAL,DIMENSION(klon,klev),INTENT(IN)   :: ch      ! eau liquide
-    REAL,DIMENSION(klon,klev),INTENT(IN)   :: rh      ! humidite relative
-    REAL,DIMENSION(klon,klev+1),INTENT(IN) :: paprs   ! pression pour chaque inter-couche (en Pa)
-    REAL,DIMENSION(klon,klev),INTENT(IN)   :: pplay   ! pression pour le mileu de chaque couche (en Pa)
-    REAL,DIMENSION(klon,klev),INTENT(IN)   :: pphi    ! geopotentiel
-    REAL,DIMENSION(klon),INTENT(IN)        :: pphis
-    REAL,DIMENSION(klon,klev),INTENT(IN)   :: cldliq  ! eau condensee pour le radiatif
-    REAL,DIMENSION(klon,klev),INTENT(IN)   :: cldfra  ! fraction nuageuse (tous les nuages)
-    REAL,DIMENSION(klon,klev),INTENT(IN)   :: diafra  ! fraction nuageuse (convection ou stratus artificiels)
-    REAL,DIMENSION(klon,klev),INTENT(IN)   :: rneb    ! fraction nuageuse (grande echelle)
-    INTEGER,DIMENSION(klon),INTENT(IN)     :: itop_con
-    INTEGER,DIMENSION(klon),INTENT(IN)     :: ibas_con
-    REAL,DIMENSION(klon),INTENT(IN)        :: albsol  ! albedo surface
-!
-!Convection:
-!----------
-    REAL,DIMENSION(klon,klev),INTENT(IN) :: pmfu  ! flux de masse dans le panache montant - Tiedtke
-    REAL,DIMENSION(klon,klev),INTENT(IN) :: upwd  ! flux de masse dans le panache montant - Emanuel
-
-!...Tiedke     
-    REAL,DIMENSION(klon,klev+1),INTENT(IN)   :: pmflxr, pmflxs ! Flux precipitant de pluie, neige aux interfaces [convection]
-    REAL,DIMENSION(klon,klev+1),INTENT(IN)   :: prfl, psfl ! Flux precipitant de pluie, neige aux interfaces [large-scale]
-
-    LOGICAL,INTENT(IN)                       :: aerosol_couple
-    REAL,DIMENSION(klon,klev),INTENT(IN)     :: flxmass_w
-    REAL,DIMENSION(klon,klev,naero_grp,2),INTENT(IN) :: tau_aero
-    REAL,DIMENSION(klon,klev,naero_grp,2),INTENT(IN) :: piz_aero
-    REAL,DIMENSION(klon,klev,naero_grp,2),INTENT(IN) :: cg_aero
-    CHARACTER(len=4),DIMENSION(naero_grp),INTENT(IN) :: rfname 
-    REAL,DIMENSION(klon,klev,2),INTENT(IN)   :: ccm 
-
-! Arguments necessaires pour les sources et puits de traceur:
-    REAL,DIMENSION(klon,nbsrf),INTENT(IN) :: ftsol  ! Temperature du sol (surf)(Kelvin)
-    REAL,DIMENSION(klon,nbsrf),INTENT(IN) :: pctsrf ! Pourcentage de sol f(nature du sol)
-
-
-  ! InOutput argument
-    REAL,DIMENSION(klon,klev,nbtr),INTENT(INOUT) :: tr_seri ! Concentration Traceur [U/KgA]  
-
-  ! Output arguments
-    REAL,DIMENSION(klon,nbtr), INTENT(OUT)        :: source  ! a voir lorsque le flux de surface est prescrit 
-
-!=======================================================================================
-!                        -- VARIABLES LOCALES TRACEURS --
-!=======================================================================================
-
-    INTEGER :: k
-    REAL,DIMENSION(klon,klev) :: pdel
-    REAL,DIMENSION(klon,klev) :: zpmfu  ! flux de masse dans le panache montant
-    REAL    :: calday
-    INTEGER :: ncsec
-
-    CALL VTe(VTphysiq)
-    CALL VTb(VTinca)
-    
-    calday = REAL(julien) + gmtime
-    ncsec  = NINT (86400.*gmtime)
-     
-    DO k = 1, klev
-       pdel(:,k) = paprs(:,k) - paprs (:,k+1)
-    END DO
-  
-IF (CPPKEY_INCA) THEN
-    IF (config_inca == 'aero' .OR. config_inca == 'chem') THEN
-       zpmfu(:,:)=pmfu(:,:)
-    ELSE IF (config_inca == 'aeNP') THEN
-       zpmfu(:,:)=upwd(:,:)
-    ENDIF
-
-    CALL aerosolmain(                    &
-         aerosol_couple,tr_seri,pdtphys, &
-         pplay,pdel,prfl,pmflxr,psfl,    &
-         pmflxs,zpmfu,itop_con,ibas_con,  &
-         pphi,cell_area,nstep,rneb,t_seri, &
-         rh,tau_aero,piz_aero,cg_aero,   &
-         rfname,ccm,lafin)
-END IF
-
-
-IF (CPPKEY_INCA) THEN
-    CALL chemmain (tr_seri, &   !mmr
-         nstep,      & !nstep
-         calday,     & !calday
-         julien,     & !ncdate
-         ncsec,      & !ncsec
-         1,          & !lat
-         pdtphys,    & !delt
-         paprs(1,1), & !ps
-         pplay,      & !pmid
-         pdel,       & !pdel
-         cell_area,  &
-         pctsrf(1,1),& !oro
-         ftsol,      & !tsurf
-         albsol,     & !albs
-         pphi,       & !zma
-         pphis,      & !phis
-         cldfra,     & !cldfr
-         rneb,       & !cldfr_st
-         diafra,     & !cldfr_cv
-         itop_con,   & !cldtop
-         ibas_con,   & !cldbot
-         cldliq,     & !cwat
-         prfl,       & !flxrst
-         pmflxr,     & !flxrcv
-         psfl,       & !flxsst
-         pmflxs,     & !flxscv
-         zpmfu,      & !flxupd   !--now depends on whether AP or NP
-         flxmass_w,  & !flxmass_w
-         t_seri,     & !tfld
-         sh,         & !sh
-         ch,         & !ql
-         rh,         & !rh
-         nbp_lon,    & !nx
-         nbp_lat,    & !ny
-         source )
-END IF
-    
-    CALL VTe(VTinca)
-    CALL VTb(VTphysiq)
-    
-    
-  END SUBROUTINE tracinca
-
-
-END MODULE tracinca_mod
Index: /LMDZ6/trunk/libf/phylmd/tracinca_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/tracinca_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/tracinca_mod.f90	(revision 5268)
@@ -0,0 +1,210 @@
+!$Id $
+!
+MODULE tracinca_mod
+!
+! This module prepares and calls the INCA main subroutines. 
+!
+  IMPLICIT NONE  
+
+  CHARACTER(len=4),SAVE :: config_inca
+!$OMP THREADPRIVATE(config_inca)
+                     ! config_inca='none' => without INCA
+                     ! config_inca='chem' => INCA with chemistry
+                     ! config_inca='aero' => INCA with aerosols
+                     ! config_inca='aeNP' => INCA with aerosols NP (?)
+CONTAINS
+
+  SUBROUTINE tracinca_init(aerosol,lessivage)
+    ! This subroutine initialize some control varaibles. 
+
+    USE infotrac_phy, ONLY: nbtr, type_trac
+    IMPLICIT NONE
+    
+    ! Output variables
+    LOGICAL,DIMENSION(nbtr), INTENT(OUT) :: aerosol
+    LOGICAL,INTENT(OUT) :: lessivage
+    
+    ! Initialization
+    lessivage  =.FALSE.
+    aerosol(:) = .FALSE.
+
+    !--- COHERENCE TEST BETWEEN "type_trac" AND "config_inca"
+    IF(ANY(type_trac == ['inca','inco']) .AND. ALL(config_inca /= ['aero','aeNP','chem'])) CALL abort_physic('tracinca_init', &
+       'INCA enabled, but unknown config_inca = "'//TRIM(config_inca)//'". Please modify "run.def"', 1)
+
+    !--- PROBLEM IF "config_inca" DIFFERS FROM "none" AND INCA HAS NOT BEEN ACTIVATED
+    IF(ALL(type_trac /= ['inca','inco'])  .AND.    config_inca /= 'none')                  CALL abort_physic('tracinca_init', &
+       'INCA disabled, but config_inca = "'//TRIM(config_inca)//'" should be "none". Please modify "run.def"', 1)
+
+  END SUBROUTINE tracinca_init
+
+  SUBROUTINE tracinca(                                &
+       nstep,    julien,   gmtime,         lafin,     &
+       pdtphys,  t_seri,   paprs,          pplay,     &
+       pmfu,     upwd,     ftsol,  pctsrf, pphis,     &
+       pphi,     albsol,   sh,             ch, rh,    &
+       cldfra,   rneb,     diafra,         cldliq,    &
+       itop_con, ibas_con, pmflxr,         pmflxs,    &
+       prfl,     psfl,     aerosol_couple, flxmass_w, &
+       tau_aero, piz_aero, cg_aero,        ccm,       &
+       rfname,                                        &
+       tr_seri,  source)      
+
+!========================================================
+!    -- CHIMIE INCA --
+!========================================================
+
+    USE dimphy
+    USE infotrac_phy, ONLY: nbtr
+    USE vampir
+    USE indice_sol_mod
+    USE geometry_mod, ONLY: cell_area
+    USE mod_grid_phy_lmdz, ONLY: nbp_lon, nbp_lat
+    USE aero_mod, ONLY : naero_grp
+    USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_INCA
+    IMPLICIT NONE
+    
+!==========================================================================
+!                   -- DESCRIPTION DES ARGUMENTS --
+!==========================================================================
+
+
+! EN ENTREE ...
+!
+!Configuration grille,temps:
+    INTEGER,INTENT(IN) :: nstep      ! Appel physique
+    INTEGER,INTENT(IN) :: julien     ! Jour julien
+    REAL,INTENT(IN)    :: gmtime
+    REAL,INTENT(IN)    :: pdtphys    ! Pas d'integration pour la physique (seconde)
+    LOGICAL,INTENT(IN) :: lafin      ! le flag de la fin de la physique
+    
+
+!Physique: 
+!--------
+    REAL,DIMENSION(klon,klev),INTENT(IN)   :: t_seri  ! Temperature
+    REAL,DIMENSION(klon,klev),INTENT(IN)   :: sh      ! humidite specifique
+    REAL,DIMENSION(klon,klev),INTENT(IN)   :: ch      ! eau liquide
+    REAL,DIMENSION(klon,klev),INTENT(IN)   :: rh      ! humidite relative
+    REAL,DIMENSION(klon,klev+1),INTENT(IN) :: paprs   ! pression pour chaque inter-couche (en Pa)
+    REAL,DIMENSION(klon,klev),INTENT(IN)   :: pplay   ! pression pour le mileu de chaque couche (en Pa)
+    REAL,DIMENSION(klon,klev),INTENT(IN)   :: pphi    ! geopotentiel
+    REAL,DIMENSION(klon),INTENT(IN)        :: pphis
+    REAL,DIMENSION(klon,klev),INTENT(IN)   :: cldliq  ! eau condensee pour le radiatif
+    REAL,DIMENSION(klon,klev),INTENT(IN)   :: cldfra  ! fraction nuageuse (tous les nuages)
+    REAL,DIMENSION(klon,klev),INTENT(IN)   :: diafra  ! fraction nuageuse (convection ou stratus artificiels)
+    REAL,DIMENSION(klon,klev),INTENT(IN)   :: rneb    ! fraction nuageuse (grande echelle)
+    INTEGER,DIMENSION(klon),INTENT(IN)     :: itop_con
+    INTEGER,DIMENSION(klon),INTENT(IN)     :: ibas_con
+    REAL,DIMENSION(klon),INTENT(IN)        :: albsol  ! albedo surface
+!
+!Convection:
+!----------
+    REAL,DIMENSION(klon,klev),INTENT(IN) :: pmfu  ! flux de masse dans le panache montant - Tiedtke
+    REAL,DIMENSION(klon,klev),INTENT(IN) :: upwd  ! flux de masse dans le panache montant - Emanuel
+
+!...Tiedke     
+    REAL,DIMENSION(klon,klev+1),INTENT(IN)   :: pmflxr, pmflxs ! Flux precipitant de pluie, neige aux interfaces [convection]
+    REAL,DIMENSION(klon,klev+1),INTENT(IN)   :: prfl, psfl ! Flux precipitant de pluie, neige aux interfaces [large-scale]
+
+    LOGICAL,INTENT(IN)                       :: aerosol_couple
+    REAL,DIMENSION(klon,klev),INTENT(IN)     :: flxmass_w
+    REAL,DIMENSION(klon,klev,naero_grp,2),INTENT(IN) :: tau_aero
+    REAL,DIMENSION(klon,klev,naero_grp,2),INTENT(IN) :: piz_aero
+    REAL,DIMENSION(klon,klev,naero_grp,2),INTENT(IN) :: cg_aero
+    CHARACTER(len=4),DIMENSION(naero_grp),INTENT(IN) :: rfname 
+    REAL,DIMENSION(klon,klev,2),INTENT(IN)   :: ccm 
+
+! Arguments necessaires pour les sources et puits de traceur:
+    REAL,DIMENSION(klon,nbsrf),INTENT(IN) :: ftsol  ! Temperature du sol (surf)(Kelvin)
+    REAL,DIMENSION(klon,nbsrf),INTENT(IN) :: pctsrf ! Pourcentage de sol f(nature du sol)
+
+
+  ! InOutput argument
+    REAL,DIMENSION(klon,klev,nbtr),INTENT(INOUT) :: tr_seri ! Concentration Traceur [U/KgA]  
+
+  ! Output arguments
+    REAL,DIMENSION(klon,nbtr), INTENT(OUT)        :: source  ! a voir lorsque le flux de surface est prescrit 
+
+!=======================================================================================
+!                        -- VARIABLES LOCALES TRACEURS --
+!=======================================================================================
+
+    INTEGER :: k
+    REAL,DIMENSION(klon,klev) :: pdel
+    REAL,DIMENSION(klon,klev) :: zpmfu  ! flux de masse dans le panache montant
+    REAL    :: calday
+    INTEGER :: ncsec
+
+    CALL VTe(VTphysiq)
+    CALL VTb(VTinca)
+    
+    calday = REAL(julien) + gmtime
+    ncsec  = NINT (86400.*gmtime)
+     
+    DO k = 1, klev
+       pdel(:,k) = paprs(:,k) - paprs (:,k+1)
+    END DO
+  
+IF (CPPKEY_INCA) THEN
+    IF (config_inca == 'aero' .OR. config_inca == 'chem') THEN
+       zpmfu(:,:)=pmfu(:,:)
+    ELSE IF (config_inca == 'aeNP') THEN
+       zpmfu(:,:)=upwd(:,:)
+    ENDIF
+
+    CALL aerosolmain(                    &
+         aerosol_couple,tr_seri,pdtphys, &
+         pplay,pdel,prfl,pmflxr,psfl,    &
+         pmflxs,zpmfu,itop_con,ibas_con,  &
+         pphi,cell_area,nstep,rneb,t_seri, &
+         rh,tau_aero,piz_aero,cg_aero,   &
+         rfname,ccm,lafin)
+END IF
+
+
+IF (CPPKEY_INCA) THEN
+    CALL chemmain (tr_seri, &   !mmr
+         nstep,      & !nstep
+         calday,     & !calday
+         julien,     & !ncdate
+         ncsec,      & !ncsec
+         1,          & !lat
+         pdtphys,    & !delt
+         paprs(1,1), & !ps
+         pplay,      & !pmid
+         pdel,       & !pdel
+         cell_area,  &
+         pctsrf(1,1),& !oro
+         ftsol,      & !tsurf
+         albsol,     & !albs
+         pphi,       & !zma
+         pphis,      & !phis
+         cldfra,     & !cldfr
+         rneb,       & !cldfr_st
+         diafra,     & !cldfr_cv
+         itop_con,   & !cldtop
+         ibas_con,   & !cldbot
+         cldliq,     & !cwat
+         prfl,       & !flxrst
+         pmflxr,     & !flxrcv
+         psfl,       & !flxsst
+         pmflxs,     & !flxscv
+         zpmfu,      & !flxupd   !--now depends on whether AP or NP
+         flxmass_w,  & !flxmass_w
+         t_seri,     & !tfld
+         sh,         & !sh
+         ch,         & !ql
+         rh,         & !rh
+         nbp_lon,    & !nx
+         nbp_lat,    & !ny
+         source )
+END IF
+    
+    CALL VTe(VTinca)
+    CALL VTb(VTphysiq)
+    
+    
+  END SUBROUTINE tracinca
+
+
+END MODULE tracinca_mod
Index: DZ6/trunk/libf/phylmd/traclmdz_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/traclmdz_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,599 +1,0 @@
-!$Id $
-!
-MODULE traclmdz_mod
-
-! 
-! In this module all tracers specific to LMDZ are treated. This module is used 
-! only if running without any other chemestry model as INCA or REPROBUS.  
-!
-  IMPLICIT NONE
-
-  REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: masktr   ! Masque reservoir de sol traceur
-!$OMP THREADPRIVATE(masktr)                        ! Masque de l'echange avec la surface (1 = reservoir) ou (possible >= 1 )
-  REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: fshtr    ! Flux surfacique dans le reservoir de sol
-!$OMP THREADPRIVATE(fshtr)
-  REAL,DIMENSION(:),ALLOCATABLE,SAVE   :: hsoltr   ! Epaisseur equivalente du reservoir de sol
-!$OMP THREADPRIVATE(hsoltr)
-!
-!Radioelements:
-!--------------
-!
-  REAL,DIMENSION(:),ALLOCATABLE,SAVE   :: tautr    ! Constante de decroissance radioactive
-!$OMP THREADPRIVATE(tautr)
-  REAL,DIMENSION(:),ALLOCATABLE,SAVE   :: vdeptr   ! Vitesse de depot sec dans la couche Brownienne
-!$OMP THREADPRIVATE(vdeptr)
-  REAL,DIMENSION(:),ALLOCATABLE,SAVE   :: scavtr   ! Coefficient de lessivage
-!$OMP THREADPRIVATE(scavtr)
-  REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: srcbe    ! Production du beryllium7 dans l atmosphere (U/s/kgA)
-!$OMP THREADPRIVATE(srcbe)
-
-  LOGICAL,DIMENSION(:),ALLOCATABLE,SAVE :: radio    ! radio(it)   = true  => decroisssance radioactive
-!$OMP THREADPRIVATE(radio)  
-
-  REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: trs     ! Conc. radon ds le sol
-!$OMP THREADPRIVATE(trs)
-
-  INTEGER,SAVE :: id_aga      ! Identification number for tracer : Age of stratospheric air
-!$OMP THREADPRIVATE(id_aga)
-  INTEGER,SAVE :: lev_1p5km   ! Approximative vertical layer number at 1.5km above surface, used for calculation of the age of air. The result shouldn't be that sensible to the exactness of this value as long as it is in the lower troposphere. 
-!$OMP THREADPRIVATE(lev_1p5km)
-
-  INTEGER,SAVE :: id_rn, id_pb ! Identification number for tracer : radon (Rn222), lead (Pb210)
-!$OMP THREADPRIVATE(id_rn, id_pb)
-
-  INTEGER,SAVE :: id_be       ! Activation et position du traceur Be7 [ id_be=0 -> desactive ] 
-!$OMP THREADPRIVATE(id_be)
-
-  INTEGER,SAVE :: id_pcsat, id_pcocsat, id_pcq ! traceurs pseudo-vapeur CL qsat, qsat_oc, q
-!$OMP THREADPRIVATE(id_pcsat, id_pcocsat, id_pcq)
-  INTEGER,SAVE :: id_pcs0, id_pcos0, id_pcq0   ! traceurs pseudo-vapeur CL qsat, qsat_oc, q
-!                                              ! qui ne sont pas transportes par la convection
-!$OMP THREADPRIVATE(id_pcs0, id_pcos0, id_pcq0)
-
-  INTEGER, SAVE:: id_o3
-!$OMP THREADPRIVATE(id_o3)
-! index of ozone tracer with Cariolle parameterization
-! 0 means no ozone tracer
-
-  LOGICAL,SAVE :: rnpb=.FALSE. ! Presence du couple Rn222, Pb210
-!$OMP THREADPRIVATE(rnpb)
-
-
-CONTAINS
-
-  SUBROUTINE traclmdz_from_restart(trs_in)
-    ! This subroutine initialize the module saved variable trs with values from restart file (startphy.nc). 
-    ! This subroutine is called from phyetat0 after the field trs_in has been read.
-    
-    USE dimphy
-    USE infotrac_phy, ONLY: nbtr
-    
-    ! Input argument
-    REAL,DIMENSION(klon,nbtr), INTENT(IN) :: trs_in 
-    
-    ! Local variables
-    INTEGER :: ierr
-    
-    ! Allocate restart variables trs
-    ALLOCATE( trs(klon,nbtr), stat=ierr)
-    IF (ierr /= 0) CALL abort_physic('traclmdz_from_restart', 'pb in allocation 1',1)
-    
-    ! Initialize trs with values read from restart file 
-    trs(:,:) = trs_in(:,:)
-    
-  END SUBROUTINE traclmdz_from_restart
-
-
-  SUBROUTINE traclmdz_init(pctsrf, xlat, xlon, ftsol, tr_seri, t_seri, pplay, sh, pdtphys, aerosol, lessivage)
-    ! This subroutine allocates and initialize module variables and control variables.
-    ! Initialization of the tracers should be done here only for those not found in the restart file.
-    USE dimphy
-    USE infotrac_phy, ONLY: nbtr, nqtot, tracers, pbl_flg, conv_flg
-    USE regr_pr_comb_coefoz_m, ONLY: alloc_coefoz
-    USE press_coefoz_m, ONLY: press_coefoz
-    USE mod_grid_phy_lmdz
-    USE mod_phys_lmdz_para
-    USE indice_sol_mod
-    USE print_control_mod, ONLY: lunout
-
-! Input variables
-    REAL,DIMENSION(klon,nbsrf),INTENT(IN)     :: pctsrf ! Pourcentage de sol f(nature du sol)
-    REAL,DIMENSION(klon),INTENT(IN)           :: xlat   ! latitudes en degres pour chaque point 
-    REAL,DIMENSION(klon),INTENT(IN)           :: xlon   ! longitudes en degres pour chaque point 
-    REAL,DIMENSION(klon,nbsrf),INTENT(IN)     :: ftsol  ! Temperature du sol (surf)(Kelvin)
-    REAL,DIMENSION(klon,klev,nbtr),INTENT(INOUT) :: tr_seri! Concentration Traceur [U/KgA]  
-    REAL,DIMENSION(klon,klev),INTENT(IN)   :: t_seri  ! Temperature
-    REAL,DIMENSION(klon,klev),INTENT(IN)   :: pplay   ! pression pour le mileu de chaque couche (en Pa)
-    REAL,DIMENSION(klon,klev),INTENT(IN)   :: sh      ! humidite specifique
-    REAL,INTENT(IN)                        :: pdtphys ! Pas d'integration pour la physique (seconde)  
-
-! Output variables
-    LOGICAL,DIMENSION(nbtr), INTENT(OUT) :: aerosol
-    LOGICAL,INTENT(OUT)                  :: lessivage
-        
-! Local variables    
-    INTEGER :: ierr, it, iq, i, k
-    REAL, DIMENSION(klon_glo,klev) :: varglo ! variable temporaire sur la grille global    
-    REAL, DIMENSION(klev)          :: mintmp, maxtmp
-    LOGICAL                        :: zero
-! RomP >>> profil initial Be7
-      integer ilesfil
-      parameter (ilesfil=1)
-      integer  irr,kradio
-      real     beryllium(klon,klev)
-! profil initial Pb210
-      integer ilesfil2
-      parameter (ilesfil2=1)
-      integer  irr2,kradio2
-      real     plomb(klon,klev)
-!! RomP <<<
-! --------------------------------------------
-! Allocation
-! --------------------------------------------
-    ALLOCATE( scavtr(nbtr), stat=ierr)
-    IF (ierr /= 0) CALL abort_physic('traclmdz_init', 'pb in allocation 9',1)
-    scavtr(:)=1.
-    
-    ALLOCATE( radio(nbtr), stat=ierr)
-    IF (ierr /= 0) CALL abort_physic('traclmdz_init', 'pb in allocation 11',1)
-    radio(:) = .false.    ! Par defaut pas decroissance radioactive
-    
-    ALLOCATE( masktr(klon,nbtr), stat=ierr)
-    IF (ierr /= 0) CALL abort_physic('traclmdz_init', 'pb in allocation 2',1)
-    
-    ALLOCATE( fshtr(klon,nbtr), stat=ierr)
-    IF (ierr /= 0) CALL abort_physic('traclmdz_init', 'pb in allocation 3',1)
-    
-    ALLOCATE( hsoltr(nbtr), stat=ierr)
-    IF (ierr /= 0) CALL abort_physic('traclmdz_init', 'pb in allocation 4',1)
-    
-    ALLOCATE( tautr(nbtr), stat=ierr)
-    IF (ierr /= 0) CALL abort_physic('traclmdz_init', 'pb in allocation 5',1)
-    tautr(:)  = 0.
-    
-    ALLOCATE( vdeptr(nbtr), stat=ierr)
-    IF (ierr /= 0) CALL abort_physic('traclmdz_init', 'pb in allocation 6',1)
-    vdeptr(:) = 0.
-
-
-    lessivage  = .TRUE.
-!!jyg(20130206) : le choix d activation du lessivage est fait dans phytrac avec iflag_lscav
-!!    call getin('lessivage',lessivage)
-!!    if(lessivage) then
-!!     print*,'lessivage lsc ON'
-!!    else
-!!     print*,'lessivage lsc OFF'
-!!    endif
-    aerosol(:) = .FALSE.  ! Tous les traceurs sont des gaz par defaut
-    
-!
-! Recherche des traceurs connus : Be7, O3, CO2,...
-! --------------------------------------------
-    id_rn=0; id_pb=0; id_aga=0; id_be=0; id_o3=0
-    id_pcsat=0; id_pcocsat=0; id_pcq=0; id_pcs0=0; id_pcos0=0; id_pcq0=0
-    it = 0
-    DO iq = 1, nqtot
-       IF(.NOT.(tracers(iq)%isInPhysics)) CYCLE
-       it = it+1
-       SELECT CASE(tracers(iq)%name)
-         CASE("RN");                  id_rn     = it ! radon
-         CASE("PB");                  id_pb     = it ! plomb
-         CASE("Aga","AGA");           id_aga    = it ! Age of stratospheric air
-         CASE("Be","BE","Be7","BE7"); id_be     = it ! Recherche du Beryllium 7
-         CASE("o3","O3");             id_o3     = it ! Recherche de l'ozone
-         CASE("pcsat",  "Pcsat");     id_pcsat  = it
-         CASE("pcocsat","Pcocsat");   id_pcocsat= it
-         CASE("pcq",    "Pcq");       id_pcq    = it
-         CASE("pcs0",   "Pcs0");      id_pcs0   = it
-         CASE("pcos0",  "Pcos0");     id_pcos0  = it
-         CASE("pcq0",   "Pcq0");      id_pcq0   = it
-         CASE DEFAULT
-           WRITE(lunout,*) 'This is an unknown tracer in LMDZ : ', trim(tracers(iq)%name)
-       END SELECT
-
-       SELECT CASE(tracers(iq)%name)
-         CASE("PB")                        !--- RomP >>> profil initial de PB210 
-           OPEN(ilesfil2,file='prof.pb210',status='old',iostat=irr2)
-           IF(irr2 == 0) THEN 
-             READ(ilesfil2,*) kradio2
-             WRITE(lunout,*)'number of levels for pb210 profile ',kradio2
-             DO k=kradio2,1,-1; READ (ilesfil2,*) plomb(:,k); END DO
-             CLOSE(ilesfil2)
-             tr_seri(:,:,id_pb) = plomb(:,:)
-           ELSE
-             WRITE(lunout,*)'prof.pb210 does not exist: use restart values'
-           END IF
-         CASE("Aga","AGA")
-           radio(id_aga) = .FALSE.
-           aerosol(id_aga) = .FALSE.
-           pbl_flg(id_aga) = 0 
-           ! Find the first model layer above 1.5km from the surface
-           IF (klev>=30) THEN
-              lev_1p5km=6                  !--- NB: This value is for klev=39
-           ELSE IF (klev>=10) THEN
-              lev_1p5km=5                  !--- NB: This value is for klev=19
-           ELSE
-              lev_1p5km=klev/2
-           END IF
-         CASE("Be","BE","Be7","BE7")
-           ALLOCATE( srcbe(klon,klev) )
-           radio(id_be) = .TRUE.
-           aerosol(id_be) = .TRUE.         !--- Le Be est un aerosol
-           CALL init_be(pctsrf,pplay,masktr(:,id_be),tautr(id_be),vdeptr(id_be),scavtr(id_be),srcbe)
-           WRITE(lunout,*) 'Initialisation srcBe: OK'
-                                           !--- RomP >>> profil initial de Be7
-           OPEN(ilesfil,file='prof.be7',status='old',iostat=irr)
-           IF(irr == 0) THEN
-             READ(ilesfil,*) kradio
-             WRITE(lunout,*)'number of levels for Be7 profile ',kradio
-             DO k=kradio,1,-1; READ(ilesfil,*) beryllium(:,k); END DO
-             CLOSE(ilesfil)
-             tr_seri(:,:,id_be)=beryllium(:,:)
-           ELSE
-             WRITE(lunout,*)'Prof. Be7 does not exist: use restart values'
-           END IF
-         CASE("o3","O3")                    !--- Parametrisation par la chimie de Cariolle
-           CALL alloc_coefoz                !--- Allocate ozone coefficients
-           CALL press_coefoz                !--- Read input pressure levels
-         CASE("pcs0","Pcs0", "pcos0","Pcos0", "pcq0","Pcq0")
-           conv_flg(it)=0                   !--- No transport by convection for this tracer
-       END SELECT
-    END DO
-
-!
-! Valeurs specifiques pour les traceurs Rn222 et Pb210
-! ----------------------------------------------
-    IF ( id_rn/=0 .AND. id_pb/=0 ) THEN
-       rnpb = .TRUE.
-       radio(id_rn)= .TRUE.
-       radio(id_pb)= .TRUE.
-       pbl_flg(id_rn) = 0 ! au lieu de clsol=true ! CL au sol calcule
-       pbl_flg(id_pb) = 0 ! au lieu de clsol=true
-       aerosol(id_rn) = .FALSE.
-       aerosol(id_pb) = .TRUE. ! le Pb est un aerosol
-       
-       CALL initrrnpb (ftsol,pctsrf,masktr,fshtr,hsoltr,tautr,vdeptr,scavtr)
-    END IF
-
-!
-! Check if all tracers have restart values
-! ----------------------------------------------
-    it = 0
-    DO iq = 1, nqtot
-       IF(.NOT.(tracers(iq)%isAdvected .AND. tracers(iq)%isInPhysics)) CYCLE
-       it = it+1
-       ! Test if tracer is zero everywhere. 
-       ! Done by master process MPI and master thread OpenMP
-       CALL gather(tr_seri(:,:,it),varglo)
-       IF (is_mpi_root .AND. is_omp_root) THEN
-          mintmp=MINVAL(varglo,dim=1)
-          maxtmp=MAXVAL(varglo,dim=1)
-          IF (MINVAL(mintmp,dim=1)==0. .AND. MAXVAL(maxtmp,dim=1)==0.) THEN
-             ! Tracer is zero everywhere
-             zero=.TRUE.
-          ELSE
-             zero=.FALSE.
-          END IF
-       END IF
-
-       ! Distribute variable at all processes
-       CALL bcast(zero)
-
-       ! Initalize tracer that was not found in restart file.
-       IF (zero) THEN
-          ! The tracer was not found in restart file or it was equal zero everywhere.
-          WRITE(lunout,*) "The tracer ",trim(tracers(iq)%name)," will be initialized"
-          IF (it==id_pcsat .OR. it==id_pcq .OR. &
-               it==id_pcs0 .OR. it==id_pcq0) THEN
-             tr_seri(:,:,it) = 100.
-          ELSE IF (it==id_pcocsat .OR. it==id_pcos0) THEN
-             DO i = 1, klon
-                IF ( pctsrf (i, is_oce) == 0. ) THEN
-                   tr_seri(i,:,it) = 0.
-                ELSE
-                   tr_seri(i,:,it) = 100.
-                END IF
-             END DO
-          ELSE
-             ! No specific initialization exist for this tracer
-             tr_seri(:,:,it) = 0.
-          END IF
-       END IF
-    END DO
-
-  END SUBROUTINE traclmdz_init
-
-  SUBROUTINE traclmdz(nstep, julien, gmtime, pdtphys, t_seri, paprs, pplay, &
-       cdragh,  coefh, yu1, yv1, ftsol, pctsrf, xlat, xlon, couchelimite, sh, &
-       rh, pphi, ustar, wstar, ale_bl, ale_wake,  zu10m, zv10m, &
-       tr_seri, source, d_tr_cl,d_tr_dec, zmasse)               !RomP
-    
-    USE dimphy
-    USE infotrac_phy, ONLY: nbtr, pbl_flg
-    USE strings_mod,  ONLY: int2str
-    USE regr_pr_comb_coefoz_m, ONLY: regr_pr_comb_coefoz
-    USE o3_chem_m, ONLY: o3_chem
-    USE indice_sol_mod
-
-    INCLUDE "YOMCST.h"
-
-!==========================================================================
-!                   -- DESCRIPTION DES ARGUMENTS --
-!==========================================================================
-
-! Input arguments
-!
-!Configuration grille,temps:
-    INTEGER,INTENT(IN) :: nstep      ! nombre d'appels de la physiq
-    INTEGER,INTENT(IN) :: julien     ! Jour julien
-    REAL,INTENT(IN)    :: gmtime
-    REAL,INTENT(IN)    :: pdtphys    ! Pas d'integration pour la physique (seconde)  
-    REAL,DIMENSION(klon),INTENT(IN) :: xlat    ! latitudes pour chaque point 
-    REAL, INTENT(IN):: xlon(:) ! dim(klon) longitude
-
-!
-!Physique: 
-!--------
-    REAL,DIMENSION(klon,klev),INTENT(IN)   :: t_seri  ! Temperature
-    REAL,DIMENSION(klon,klev+1),INTENT(IN) :: paprs   ! pression pour chaque inter-couche (en Pa)
-    REAL,DIMENSION(klon,klev),INTENT(IN)   :: pplay   ! pression pour le mileu de chaque couche (en Pa)
-    REAL,intent(in):: zmasse (:, :)   ! dim(klon,klev) density of air, in kg/m2
-
-
-!Couche limite:
-!--------------
-!
-    REAL,DIMENSION(klon),INTENT(IN)      :: cdragh     ! coeff drag pour T et Q
-    REAL,DIMENSION(klon,klev),INTENT(IN) :: coefh      ! coeff melange CL (m**2/s)
-    REAL,DIMENSION(klon),INTENT(IN)      :: yu1        ! vents au premier niveau
-    REAL,DIMENSION(klon),INTENT(IN)      :: yv1        ! vents au premier niveau
-    LOGICAL,INTENT(IN)                   :: couchelimite
-    REAL,DIMENSION(klon,klev),INTENT(IN) :: sh         ! humidite specifique
-    REAL,DIMENSION(klon,klev),INTENT(IN) :: rh      ! Humidite relative
-    REAL,DIMENSION(klon,klev),INTENT(IN) :: pphi    ! geopotentie
-    REAL,DIMENSION(klon),INTENT(IN)      :: ustar   ! ustar (m/s)
-    REAL,DIMENSION(klon),INTENT(IN)      :: wstar,ale_bl,ale_wake   ! wstar (m/s) and Avail. Lifti. Energ.
-    REAL,DIMENSION(klon),INTENT(IN)      :: zu10m   ! vent zonal 10m (m/s)
-    REAL,DIMENSION(klon),INTENT(IN)      :: zv10m   ! vent zonal 10m (m/s)
-
-! Arguments necessaires pour les sources et puits de traceur:
-    REAL,DIMENSION(klon,nbsrf),INTENT(IN) :: ftsol  ! Temperature du sol (surf)(Kelvin)
-    REAL,DIMENSION(klon,nbsrf),INTENT(IN) :: pctsrf ! Pourcentage de sol f(nature du sol)
-
-! InOutput argument
-    REAL,DIMENSION(klon,klev,nbtr),INTENT(INOUT)  :: tr_seri ! Concentration Traceur [U/KgA]  
-
-! Output argument
-    REAL,DIMENSION(klon,nbtr), INTENT(OUT)        :: source  ! a voir lorsque le flux de surface est prescrit 
-    REAL,DIMENSION(klon,klev,nbtr), INTENT(OUT)   :: d_tr_cl ! Td couche limite/traceur
-
-!=======================================================================================
-!                        -- VARIABLES LOCALES TRACEURS --
-!=======================================================================================
-
-    INTEGER :: i, k, it
-    INTEGER :: lmt_pas ! number of time steps of "physics" per day
-
-    REAL,DIMENSION(klon)           :: d_trs    ! Td dans le reservoir
-    REAL,DIMENSION(klon,klev)      :: qsat     ! pression de la vapeur a saturation
-    REAL,DIMENSION(klon,klev,nbtr) :: d_tr_dec ! Td radioactive
-    REAL                           :: zrho     ! Masse Volumique de l'air KgA/m3
-    REAL                           :: amn, amx
-!
-!=================================================================
-!  Ajout de la production en  Be7 (Beryllium) srcbe U/s/kgA
-!=================================================================
-!
-    IF ( id_be /= 0 ) THEN
-       DO k = 1, klev
-          DO i = 1, klon
-             tr_seri(i,k,id_be) = tr_seri(i,k,id_be)+srcbe(i,k)*pdtphys
-          END DO
-       END DO
-       WRITE(*,*) 'Ajout srcBe dans tr_seri: OK'
-    END IF
-  
-
-!=================================================================
-! Update pseudo-vapor tracers 
-!=================================================================
-
-    CALL q_sat(klon*klev,t_seri,pplay,qsat)
-
-    IF ( id_pcsat /= 0 ) THEN
-     DO k = 1, klev
-      DO i = 1, klon
-         IF ( pplay(i,k).GE.85000.) THEN
-            tr_seri(i,k,id_pcsat) = qsat(i,k)
-         ELSE
-            tr_seri(i,k,id_pcsat) = MIN (qsat(i,k), tr_seri(i,k,id_pcsat))            
-         END IF
-      END DO 
-     END DO
-    END IF
-
-    IF ( id_pcocsat /= 0 ) THEN
-     DO k = 1, klev
-      DO i = 1, klon
-         IF ( pplay(i,k).GE.85000.) THEN
-            IF ( pctsrf (i, is_oce) > 0. ) THEN
-               tr_seri(i,k,id_pcocsat) = qsat(i,k)
-            ELSE
-               tr_seri(i,k,id_pcocsat) = 0.
-          END IF
-       ELSE 
-          tr_seri(i,k,id_pcocsat) = MIN (qsat(i,k), tr_seri(i,k,id_pcocsat))
-       END IF
-      END DO
-     END DO
-    END IF
-
-    IF ( id_pcq /= 0 ) THEN
-     DO k = 1, klev
-      DO i = 1, klon
-         IF ( pplay(i,k).GE.85000.) THEN
-            tr_seri(i,k,id_pcq) = sh(i,k)
-         ELSE
-            tr_seri(i,k,id_pcq) = MIN (qsat(i,k), tr_seri(i,k,id_pcq))    
-         END IF
-      END DO
-     END DO
-    END IF
-
-
-    IF ( id_pcs0 /= 0 ) THEN
-     DO k = 1, klev
-      DO i = 1, klon
-         IF ( pplay(i,k).GE.85000.) THEN
-            tr_seri(i,k,id_pcs0) = qsat(i,k)
-         ELSE
-            tr_seri(i,k,id_pcs0) = MIN (qsat(i,k), tr_seri(i,k,id_pcs0))    
-         END IF
-      END DO
-     END DO
-    END IF
-
-
-    IF ( id_pcos0 /= 0 ) THEN
-     DO k = 1, klev
-      DO i = 1, klon
-         IF ( pplay(i,k).GE.85000.) THEN
-            IF ( pctsrf (i, is_oce) > 0. ) THEN
-               tr_seri(i,k,id_pcos0) = qsat(i,k)
-            ELSE
-               tr_seri(i,k,id_pcos0) = 0.
-            END IF
-         ELSE
-            tr_seri(i,k,id_pcos0) = MIN (qsat(i,k), tr_seri(i,k,id_pcos0))
-         END IF
-      END DO
-     END DO
-    END IF
-
-
-    IF ( id_pcq0 /= 0 ) THEN
-     DO k = 1, klev
-      DO i = 1, klon
-         IF ( pplay(i,k).GE.85000.) THEN
-            tr_seri(i,k,id_pcq0) = sh(i,k)
-         ELSE 
-            tr_seri(i,k,id_pcq0) = MIN (qsat(i,k), tr_seri(i,k,id_pcq0))
-         END IF
-      END DO
-     END DO
-    END IF
-
-!=================================================================
-! Update tracer : Age of stratospheric air 
-!=================================================================
-    IF (id_aga/=0) THEN
-       
-       ! Bottom layers
-       DO k = 1, lev_1p5km
-          tr_seri(:,k,id_aga) = 0.0
-       END DO
-       
-       ! Layers above 1.5km
-       DO k = lev_1p5km+1,klev-1
-          tr_seri(:,k,id_aga) = tr_seri(:,k,id_aga) + pdtphys
-       END DO
-       
-       ! Top layer
-       tr_seri(:,klev,id_aga) = tr_seri(:,klev-1,id_aga)
-       
-    END IF
-
-!======================================================================
-!     -- Calcul de l'effet de la couche limite --
-!======================================================================
-
-    IF (couchelimite) THEN             
-       source(:,:) = 0.0
-
-       IF (id_be /=0) THEN
-          DO i=1, klon
-             zrho = pplay(i,1)/t_seri(i,1)/RD
-             source(i,id_be) = - vdeptr(id_be)*tr_seri(i,1,id_be)*zrho
-          END DO
-       END IF
-
-    END IF
-    
-    DO it=1, nbtr
-       IF (couchelimite .AND. pbl_flg(it) == 0 .AND. (it==id_rn .OR. it==id_pb)) THEN 
-          ! couche limite avec quantite dans le sol calculee
-          CALL cltracrn(it, pdtphys, yu1, yv1,     &
-               cdragh, coefh,t_seri,ftsol,pctsrf,  &
-               tr_seri(:,:,it),trs(:,it),          &
-               paprs, pplay, zmasse * rg, &
-               masktr(:,it),fshtr(:,it),hsoltr(it),&
-               tautr(it),vdeptr(it),               &
-               xlat,d_tr_cl(:,:,it),d_trs)
-          
-          DO k = 1, klev
-             DO i = 1, klon
-                tr_seri(i,k,it) = tr_seri(i,k,it) + d_tr_cl(i,k,it)
-             END DO
-          END DO
-        
-          ! Traceur dans le reservoir sol
-          DO i = 1, klon
-             trs(i,it) = trs(i,it) + d_trs(i)
-          END DO
-       END IF
-    END DO
-          
-
-!======================================================================
-!   Calcul de l'effet du puits radioactif
-!======================================================================
-    CALL radio_decay (radio,rnpb,pdtphys,tautr,tr_seri,d_tr_dec)
-
-    DO it=1,nbtr
-       IF(radio(it)) then     
-          DO k = 1, klev
-             DO i = 1, klon
-                tr_seri(i,k,it) = tr_seri(i,k,it) + d_tr_dec(i,k,it)
-             END DO
-          END DO
-          CALL minmaxqfi(tr_seri(:,:,it),0.,1.e33,'puits rn it='//TRIM(int2str(it)))
-       END IF
-    END DO
-
-!======================================================================
-!   Parameterization of ozone chemistry
-!======================================================================
-
-    IF (id_o3 /= 0) then
-       lmt_pas = NINT(86400./pdtphys)
-       IF (MOD(nstep - 1, lmt_pas) == 0) THEN
-          ! Once per day, update the coefficients for ozone chemistry:
-          CALL regr_pr_comb_coefoz(julien, xlat, paprs, pplay)
-       END IF
-       CALL o3_chem(julien, gmtime, t_seri, zmasse, pdtphys, xlat, &
-            xlon, tr_seri(:, :, id_o3))
-    END IF
-
-  END SUBROUTINE traclmdz
-
-
-  SUBROUTINE traclmdz_to_restart(trs_out)
-    ! This subroutine is called from phyredem.F where the module 
-    ! variable trs is written to restart file (restartphy.nc)
-    USE dimphy
-    USE infotrac_phy, ONLY: nbtr
-    
-    REAL,DIMENSION(klon,nbtr), INTENT(OUT) :: trs_out
-    INTEGER :: ierr
-
-    IF ( ALLOCATED(trs) ) THEN
-       trs_out(:,:) = trs(:,:)
-    ELSE
-       ! No previous allocate of trs. This is the case for create_etat0_limit.
-       trs_out(:,:) = 0.0
-    END IF
-    
-  END SUBROUTINE traclmdz_to_restart
-  
-
-END MODULE traclmdz_mod
Index: /LMDZ6/trunk/libf/phylmd/traclmdz_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/traclmdz_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/traclmdz_mod.f90	(revision 5268)
@@ -0,0 +1,599 @@
+!$Id $
+!
+MODULE traclmdz_mod
+
+! 
+! In this module all tracers specific to LMDZ are treated. This module is used 
+! only if running without any other chemestry model as INCA or REPROBUS.  
+!
+  IMPLICIT NONE
+
+  REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: masktr   ! Masque reservoir de sol traceur
+!$OMP THREADPRIVATE(masktr)                        ! Masque de l'echange avec la surface (1 = reservoir) ou (possible >= 1 )
+  REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: fshtr    ! Flux surfacique dans le reservoir de sol
+!$OMP THREADPRIVATE(fshtr)
+  REAL,DIMENSION(:),ALLOCATABLE,SAVE   :: hsoltr   ! Epaisseur equivalente du reservoir de sol
+!$OMP THREADPRIVATE(hsoltr)
+!
+!Radioelements:
+!--------------
+!
+  REAL,DIMENSION(:),ALLOCATABLE,SAVE   :: tautr    ! Constante de decroissance radioactive
+!$OMP THREADPRIVATE(tautr)
+  REAL,DIMENSION(:),ALLOCATABLE,SAVE   :: vdeptr   ! Vitesse de depot sec dans la couche Brownienne
+!$OMP THREADPRIVATE(vdeptr)
+  REAL,DIMENSION(:),ALLOCATABLE,SAVE   :: scavtr   ! Coefficient de lessivage
+!$OMP THREADPRIVATE(scavtr)
+  REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: srcbe    ! Production du beryllium7 dans l atmosphere (U/s/kgA)
+!$OMP THREADPRIVATE(srcbe)
+
+  LOGICAL,DIMENSION(:),ALLOCATABLE,SAVE :: radio    ! radio(it)   = true  => decroisssance radioactive
+!$OMP THREADPRIVATE(radio)  
+
+  REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: trs     ! Conc. radon ds le sol
+!$OMP THREADPRIVATE(trs)
+
+  INTEGER,SAVE :: id_aga      ! Identification number for tracer : Age of stratospheric air
+!$OMP THREADPRIVATE(id_aga)
+  INTEGER,SAVE :: lev_1p5km   ! Approximative vertical layer number at 1.5km above surface, used for calculation of the age of air. The result shouldn't be that sensible to the exactness of this value as long as it is in the lower troposphere. 
+!$OMP THREADPRIVATE(lev_1p5km)
+
+  INTEGER,SAVE :: id_rn, id_pb ! Identification number for tracer : radon (Rn222), lead (Pb210)
+!$OMP THREADPRIVATE(id_rn, id_pb)
+
+  INTEGER,SAVE :: id_be       ! Activation et position du traceur Be7 [ id_be=0 -> desactive ] 
+!$OMP THREADPRIVATE(id_be)
+
+  INTEGER,SAVE :: id_pcsat, id_pcocsat, id_pcq ! traceurs pseudo-vapeur CL qsat, qsat_oc, q
+!$OMP THREADPRIVATE(id_pcsat, id_pcocsat, id_pcq)
+  INTEGER,SAVE :: id_pcs0, id_pcos0, id_pcq0   ! traceurs pseudo-vapeur CL qsat, qsat_oc, q
+!                                              ! qui ne sont pas transportes par la convection
+!$OMP THREADPRIVATE(id_pcs0, id_pcos0, id_pcq0)
+
+  INTEGER, SAVE:: id_o3
+!$OMP THREADPRIVATE(id_o3)
+! index of ozone tracer with Cariolle parameterization
+! 0 means no ozone tracer
+
+  LOGICAL,SAVE :: rnpb=.FALSE. ! Presence du couple Rn222, Pb210
+!$OMP THREADPRIVATE(rnpb)
+
+
+CONTAINS
+
+  SUBROUTINE traclmdz_from_restart(trs_in)
+    ! This subroutine initialize the module saved variable trs with values from restart file (startphy.nc). 
+    ! This subroutine is called from phyetat0 after the field trs_in has been read.
+    
+    USE dimphy
+    USE infotrac_phy, ONLY: nbtr
+    
+    ! Input argument
+    REAL,DIMENSION(klon,nbtr), INTENT(IN) :: trs_in 
+    
+    ! Local variables
+    INTEGER :: ierr
+    
+    ! Allocate restart variables trs
+    ALLOCATE( trs(klon,nbtr), stat=ierr)
+    IF (ierr /= 0) CALL abort_physic('traclmdz_from_restart', 'pb in allocation 1',1)
+    
+    ! Initialize trs with values read from restart file 
+    trs(:,:) = trs_in(:,:)
+    
+  END SUBROUTINE traclmdz_from_restart
+
+
+  SUBROUTINE traclmdz_init(pctsrf, xlat, xlon, ftsol, tr_seri, t_seri, pplay, sh, pdtphys, aerosol, lessivage)
+    ! This subroutine allocates and initialize module variables and control variables.
+    ! Initialization of the tracers should be done here only for those not found in the restart file.
+    USE dimphy
+    USE infotrac_phy, ONLY: nbtr, nqtot, tracers, pbl_flg, conv_flg
+    USE regr_pr_comb_coefoz_m, ONLY: alloc_coefoz
+    USE press_coefoz_m, ONLY: press_coefoz
+    USE mod_grid_phy_lmdz
+    USE mod_phys_lmdz_para
+    USE indice_sol_mod
+    USE print_control_mod, ONLY: lunout
+
+! Input variables
+    REAL,DIMENSION(klon,nbsrf),INTENT(IN)     :: pctsrf ! Pourcentage de sol f(nature du sol)
+    REAL,DIMENSION(klon),INTENT(IN)           :: xlat   ! latitudes en degres pour chaque point 
+    REAL,DIMENSION(klon),INTENT(IN)           :: xlon   ! longitudes en degres pour chaque point 
+    REAL,DIMENSION(klon,nbsrf),INTENT(IN)     :: ftsol  ! Temperature du sol (surf)(Kelvin)
+    REAL,DIMENSION(klon,klev,nbtr),INTENT(INOUT) :: tr_seri! Concentration Traceur [U/KgA]  
+    REAL,DIMENSION(klon,klev),INTENT(IN)   :: t_seri  ! Temperature
+    REAL,DIMENSION(klon,klev),INTENT(IN)   :: pplay   ! pression pour le mileu de chaque couche (en Pa)
+    REAL,DIMENSION(klon,klev),INTENT(IN)   :: sh      ! humidite specifique
+    REAL,INTENT(IN)                        :: pdtphys ! Pas d'integration pour la physique (seconde)  
+
+! Output variables
+    LOGICAL,DIMENSION(nbtr), INTENT(OUT) :: aerosol
+    LOGICAL,INTENT(OUT)                  :: lessivage
+        
+! Local variables    
+    INTEGER :: ierr, it, iq, i, k
+    REAL, DIMENSION(klon_glo,klev) :: varglo ! variable temporaire sur la grille global    
+    REAL, DIMENSION(klev)          :: mintmp, maxtmp
+    LOGICAL                        :: zero
+! RomP >>> profil initial Be7
+      integer ilesfil
+      parameter (ilesfil=1)
+      integer  irr,kradio
+      real     beryllium(klon,klev)
+! profil initial Pb210
+      integer ilesfil2
+      parameter (ilesfil2=1)
+      integer  irr2,kradio2
+      real     plomb(klon,klev)
+!! RomP <<<
+! --------------------------------------------
+! Allocation
+! --------------------------------------------
+    ALLOCATE( scavtr(nbtr), stat=ierr)
+    IF (ierr /= 0) CALL abort_physic('traclmdz_init', 'pb in allocation 9',1)
+    scavtr(:)=1.
+    
+    ALLOCATE( radio(nbtr), stat=ierr)
+    IF (ierr /= 0) CALL abort_physic('traclmdz_init', 'pb in allocation 11',1)
+    radio(:) = .false.    ! Par defaut pas decroissance radioactive
+    
+    ALLOCATE( masktr(klon,nbtr), stat=ierr)
+    IF (ierr /= 0) CALL abort_physic('traclmdz_init', 'pb in allocation 2',1)
+    
+    ALLOCATE( fshtr(klon,nbtr), stat=ierr)
+    IF (ierr /= 0) CALL abort_physic('traclmdz_init', 'pb in allocation 3',1)
+    
+    ALLOCATE( hsoltr(nbtr), stat=ierr)
+    IF (ierr /= 0) CALL abort_physic('traclmdz_init', 'pb in allocation 4',1)
+    
+    ALLOCATE( tautr(nbtr), stat=ierr)
+    IF (ierr /= 0) CALL abort_physic('traclmdz_init', 'pb in allocation 5',1)
+    tautr(:)  = 0.
+    
+    ALLOCATE( vdeptr(nbtr), stat=ierr)
+    IF (ierr /= 0) CALL abort_physic('traclmdz_init', 'pb in allocation 6',1)
+    vdeptr(:) = 0.
+
+
+    lessivage  = .TRUE.
+!!jyg(20130206) : le choix d activation du lessivage est fait dans phytrac avec iflag_lscav
+!!    call getin('lessivage',lessivage)
+!!    if(lessivage) then
+!!     print*,'lessivage lsc ON'
+!!    else
+!!     print*,'lessivage lsc OFF'
+!!    endif
+    aerosol(:) = .FALSE.  ! Tous les traceurs sont des gaz par defaut
+    
+!
+! Recherche des traceurs connus : Be7, O3, CO2,...
+! --------------------------------------------
+    id_rn=0; id_pb=0; id_aga=0; id_be=0; id_o3=0
+    id_pcsat=0; id_pcocsat=0; id_pcq=0; id_pcs0=0; id_pcos0=0; id_pcq0=0
+    it = 0
+    DO iq = 1, nqtot
+       IF(.NOT.(tracers(iq)%isInPhysics)) CYCLE
+       it = it+1
+       SELECT CASE(tracers(iq)%name)
+         CASE("RN");                  id_rn     = it ! radon
+         CASE("PB");                  id_pb     = it ! plomb
+         CASE("Aga","AGA");           id_aga    = it ! Age of stratospheric air
+         CASE("Be","BE","Be7","BE7"); id_be     = it ! Recherche du Beryllium 7
+         CASE("o3","O3");             id_o3     = it ! Recherche de l'ozone
+         CASE("pcsat",  "Pcsat");     id_pcsat  = it
+         CASE("pcocsat","Pcocsat");   id_pcocsat= it
+         CASE("pcq",    "Pcq");       id_pcq    = it
+         CASE("pcs0",   "Pcs0");      id_pcs0   = it
+         CASE("pcos0",  "Pcos0");     id_pcos0  = it
+         CASE("pcq0",   "Pcq0");      id_pcq0   = it
+         CASE DEFAULT
+           WRITE(lunout,*) 'This is an unknown tracer in LMDZ : ', trim(tracers(iq)%name)
+       END SELECT
+
+       SELECT CASE(tracers(iq)%name)
+         CASE("PB")                        !--- RomP >>> profil initial de PB210 
+           OPEN(ilesfil2,file='prof.pb210',status='old',iostat=irr2)
+           IF(irr2 == 0) THEN 
+             READ(ilesfil2,*) kradio2
+             WRITE(lunout,*)'number of levels for pb210 profile ',kradio2
+             DO k=kradio2,1,-1; READ (ilesfil2,*) plomb(:,k); END DO
+             CLOSE(ilesfil2)
+             tr_seri(:,:,id_pb) = plomb(:,:)
+           ELSE
+             WRITE(lunout,*)'prof.pb210 does not exist: use restart values'
+           END IF
+         CASE("Aga","AGA")
+           radio(id_aga) = .FALSE.
+           aerosol(id_aga) = .FALSE.
+           pbl_flg(id_aga) = 0 
+           ! Find the first model layer above 1.5km from the surface
+           IF (klev>=30) THEN
+              lev_1p5km=6                  !--- NB: This value is for klev=39
+           ELSE IF (klev>=10) THEN
+              lev_1p5km=5                  !--- NB: This value is for klev=19
+           ELSE
+              lev_1p5km=klev/2
+           END IF
+         CASE("Be","BE","Be7","BE7")
+           ALLOCATE( srcbe(klon,klev) )
+           radio(id_be) = .TRUE.
+           aerosol(id_be) = .TRUE.         !--- Le Be est un aerosol
+           CALL init_be(pctsrf,pplay,masktr(:,id_be),tautr(id_be),vdeptr(id_be),scavtr(id_be),srcbe)
+           WRITE(lunout,*) 'Initialisation srcBe: OK'
+                                           !--- RomP >>> profil initial de Be7
+           OPEN(ilesfil,file='prof.be7',status='old',iostat=irr)
+           IF(irr == 0) THEN
+             READ(ilesfil,*) kradio
+             WRITE(lunout,*)'number of levels for Be7 profile ',kradio
+             DO k=kradio,1,-1; READ(ilesfil,*) beryllium(:,k); END DO
+             CLOSE(ilesfil)
+             tr_seri(:,:,id_be)=beryllium(:,:)
+           ELSE
+             WRITE(lunout,*)'Prof. Be7 does not exist: use restart values'
+           END IF
+         CASE("o3","O3")                    !--- Parametrisation par la chimie de Cariolle
+           CALL alloc_coefoz                !--- Allocate ozone coefficients
+           CALL press_coefoz                !--- Read input pressure levels
+         CASE("pcs0","Pcs0", "pcos0","Pcos0", "pcq0","Pcq0")
+           conv_flg(it)=0                   !--- No transport by convection for this tracer
+       END SELECT
+    END DO
+
+!
+! Valeurs specifiques pour les traceurs Rn222 et Pb210
+! ----------------------------------------------
+    IF ( id_rn/=0 .AND. id_pb/=0 ) THEN
+       rnpb = .TRUE.
+       radio(id_rn)= .TRUE.
+       radio(id_pb)= .TRUE.
+       pbl_flg(id_rn) = 0 ! au lieu de clsol=true ! CL au sol calcule
+       pbl_flg(id_pb) = 0 ! au lieu de clsol=true
+       aerosol(id_rn) = .FALSE.
+       aerosol(id_pb) = .TRUE. ! le Pb est un aerosol
+       
+       CALL initrrnpb (ftsol,pctsrf,masktr,fshtr,hsoltr,tautr,vdeptr,scavtr)
+    END IF
+
+!
+! Check if all tracers have restart values
+! ----------------------------------------------
+    it = 0
+    DO iq = 1, nqtot
+       IF(.NOT.(tracers(iq)%isAdvected .AND. tracers(iq)%isInPhysics)) CYCLE
+       it = it+1
+       ! Test if tracer is zero everywhere. 
+       ! Done by master process MPI and master thread OpenMP
+       CALL gather(tr_seri(:,:,it),varglo)
+       IF (is_mpi_root .AND. is_omp_root) THEN
+          mintmp=MINVAL(varglo,dim=1)
+          maxtmp=MAXVAL(varglo,dim=1)
+          IF (MINVAL(mintmp,dim=1)==0. .AND. MAXVAL(maxtmp,dim=1)==0.) THEN
+             ! Tracer is zero everywhere
+             zero=.TRUE.
+          ELSE
+             zero=.FALSE.
+          END IF
+       END IF
+
+       ! Distribute variable at all processes
+       CALL bcast(zero)
+
+       ! Initalize tracer that was not found in restart file.
+       IF (zero) THEN
+          ! The tracer was not found in restart file or it was equal zero everywhere.
+          WRITE(lunout,*) "The tracer ",trim(tracers(iq)%name)," will be initialized"
+          IF (it==id_pcsat .OR. it==id_pcq .OR. &
+               it==id_pcs0 .OR. it==id_pcq0) THEN
+             tr_seri(:,:,it) = 100.
+          ELSE IF (it==id_pcocsat .OR. it==id_pcos0) THEN
+             DO i = 1, klon
+                IF ( pctsrf (i, is_oce) == 0. ) THEN
+                   tr_seri(i,:,it) = 0.
+                ELSE
+                   tr_seri(i,:,it) = 100.
+                END IF
+             END DO
+          ELSE
+             ! No specific initialization exist for this tracer
+             tr_seri(:,:,it) = 0.
+          END IF
+       END IF
+    END DO
+
+  END SUBROUTINE traclmdz_init
+
+  SUBROUTINE traclmdz(nstep, julien, gmtime, pdtphys, t_seri, paprs, pplay, &
+       cdragh,  coefh, yu1, yv1, ftsol, pctsrf, xlat, xlon, couchelimite, sh, &
+       rh, pphi, ustar, wstar, ale_bl, ale_wake,  zu10m, zv10m, &
+       tr_seri, source, d_tr_cl,d_tr_dec, zmasse)               !RomP
+    
+    USE dimphy
+    USE infotrac_phy, ONLY: nbtr, pbl_flg
+    USE strings_mod,  ONLY: int2str
+    USE regr_pr_comb_coefoz_m, ONLY: regr_pr_comb_coefoz
+    USE o3_chem_m, ONLY: o3_chem
+    USE indice_sol_mod
+
+    INCLUDE "YOMCST.h"
+
+!==========================================================================
+!                   -- DESCRIPTION DES ARGUMENTS --
+!==========================================================================
+
+! Input arguments
+!
+!Configuration grille,temps:
+    INTEGER,INTENT(IN) :: nstep      ! nombre d'appels de la physiq
+    INTEGER,INTENT(IN) :: julien     ! Jour julien
+    REAL,INTENT(IN)    :: gmtime
+    REAL,INTENT(IN)    :: pdtphys    ! Pas d'integration pour la physique (seconde)  
+    REAL,DIMENSION(klon),INTENT(IN) :: xlat    ! latitudes pour chaque point 
+    REAL, INTENT(IN):: xlon(:) ! dim(klon) longitude
+
+!
+!Physique: 
+!--------
+    REAL,DIMENSION(klon,klev),INTENT(IN)   :: t_seri  ! Temperature
+    REAL,DIMENSION(klon,klev+1),INTENT(IN) :: paprs   ! pression pour chaque inter-couche (en Pa)
+    REAL,DIMENSION(klon,klev),INTENT(IN)   :: pplay   ! pression pour le mileu de chaque couche (en Pa)
+    REAL,intent(in):: zmasse (:, :)   ! dim(klon,klev) density of air, in kg/m2
+
+
+!Couche limite:
+!--------------
+!
+    REAL,DIMENSION(klon),INTENT(IN)      :: cdragh     ! coeff drag pour T et Q
+    REAL,DIMENSION(klon,klev),INTENT(IN) :: coefh      ! coeff melange CL (m**2/s)
+    REAL,DIMENSION(klon),INTENT(IN)      :: yu1        ! vents au premier niveau
+    REAL,DIMENSION(klon),INTENT(IN)      :: yv1        ! vents au premier niveau
+    LOGICAL,INTENT(IN)                   :: couchelimite
+    REAL,DIMENSION(klon,klev),INTENT(IN) :: sh         ! humidite specifique
+    REAL,DIMENSION(klon,klev),INTENT(IN) :: rh      ! Humidite relative
+    REAL,DIMENSION(klon,klev),INTENT(IN) :: pphi    ! geopotentie
+    REAL,DIMENSION(klon),INTENT(IN)      :: ustar   ! ustar (m/s)
+    REAL,DIMENSION(klon),INTENT(IN)      :: wstar,ale_bl,ale_wake   ! wstar (m/s) and Avail. Lifti. Energ.
+    REAL,DIMENSION(klon),INTENT(IN)      :: zu10m   ! vent zonal 10m (m/s)
+    REAL,DIMENSION(klon),INTENT(IN)      :: zv10m   ! vent zonal 10m (m/s)
+
+! Arguments necessaires pour les sources et puits de traceur:
+    REAL,DIMENSION(klon,nbsrf),INTENT(IN) :: ftsol  ! Temperature du sol (surf)(Kelvin)
+    REAL,DIMENSION(klon,nbsrf),INTENT(IN) :: pctsrf ! Pourcentage de sol f(nature du sol)
+
+! InOutput argument
+    REAL,DIMENSION(klon,klev,nbtr),INTENT(INOUT)  :: tr_seri ! Concentration Traceur [U/KgA]  
+
+! Output argument
+    REAL,DIMENSION(klon,nbtr), INTENT(OUT)        :: source  ! a voir lorsque le flux de surface est prescrit 
+    REAL,DIMENSION(klon,klev,nbtr), INTENT(OUT)   :: d_tr_cl ! Td couche limite/traceur
+
+!=======================================================================================
+!                        -- VARIABLES LOCALES TRACEURS --
+!=======================================================================================
+
+    INTEGER :: i, k, it
+    INTEGER :: lmt_pas ! number of time steps of "physics" per day
+
+    REAL,DIMENSION(klon)           :: d_trs    ! Td dans le reservoir
+    REAL,DIMENSION(klon,klev)      :: qsat     ! pression de la vapeur a saturation
+    REAL,DIMENSION(klon,klev,nbtr) :: d_tr_dec ! Td radioactive
+    REAL                           :: zrho     ! Masse Volumique de l'air KgA/m3
+    REAL                           :: amn, amx
+!
+!=================================================================
+!  Ajout de la production en  Be7 (Beryllium) srcbe U/s/kgA
+!=================================================================
+!
+    IF ( id_be /= 0 ) THEN
+       DO k = 1, klev
+          DO i = 1, klon
+             tr_seri(i,k,id_be) = tr_seri(i,k,id_be)+srcbe(i,k)*pdtphys
+          END DO
+       END DO
+       WRITE(*,*) 'Ajout srcBe dans tr_seri: OK'
+    END IF
+  
+
+!=================================================================
+! Update pseudo-vapor tracers 
+!=================================================================
+
+    CALL q_sat(klon*klev,t_seri,pplay,qsat)
+
+    IF ( id_pcsat /= 0 ) THEN
+     DO k = 1, klev
+      DO i = 1, klon
+         IF ( pplay(i,k).GE.85000.) THEN
+            tr_seri(i,k,id_pcsat) = qsat(i,k)
+         ELSE
+            tr_seri(i,k,id_pcsat) = MIN (qsat(i,k), tr_seri(i,k,id_pcsat))            
+         END IF
+      END DO 
+     END DO
+    END IF
+
+    IF ( id_pcocsat /= 0 ) THEN
+     DO k = 1, klev
+      DO i = 1, klon
+         IF ( pplay(i,k).GE.85000.) THEN
+            IF ( pctsrf (i, is_oce) > 0. ) THEN
+               tr_seri(i,k,id_pcocsat) = qsat(i,k)
+            ELSE
+               tr_seri(i,k,id_pcocsat) = 0.
+          END IF
+       ELSE 
+          tr_seri(i,k,id_pcocsat) = MIN (qsat(i,k), tr_seri(i,k,id_pcocsat))
+       END IF
+      END DO
+     END DO
+    END IF
+
+    IF ( id_pcq /= 0 ) THEN
+     DO k = 1, klev
+      DO i = 1, klon
+         IF ( pplay(i,k).GE.85000.) THEN
+            tr_seri(i,k,id_pcq) = sh(i,k)
+         ELSE
+            tr_seri(i,k,id_pcq) = MIN (qsat(i,k), tr_seri(i,k,id_pcq))    
+         END IF
+      END DO
+     END DO
+    END IF
+
+
+    IF ( id_pcs0 /= 0 ) THEN
+     DO k = 1, klev
+      DO i = 1, klon
+         IF ( pplay(i,k).GE.85000.) THEN
+            tr_seri(i,k,id_pcs0) = qsat(i,k)
+         ELSE
+            tr_seri(i,k,id_pcs0) = MIN (qsat(i,k), tr_seri(i,k,id_pcs0))    
+         END IF
+      END DO
+     END DO
+    END IF
+
+
+    IF ( id_pcos0 /= 0 ) THEN
+     DO k = 1, klev
+      DO i = 1, klon
+         IF ( pplay(i,k).GE.85000.) THEN
+            IF ( pctsrf (i, is_oce) > 0. ) THEN
+               tr_seri(i,k,id_pcos0) = qsat(i,k)
+            ELSE
+               tr_seri(i,k,id_pcos0) = 0.
+            END IF
+         ELSE
+            tr_seri(i,k,id_pcos0) = MIN (qsat(i,k), tr_seri(i,k,id_pcos0))
+         END IF
+      END DO
+     END DO
+    END IF
+
+
+    IF ( id_pcq0 /= 0 ) THEN
+     DO k = 1, klev
+      DO i = 1, klon
+         IF ( pplay(i,k).GE.85000.) THEN
+            tr_seri(i,k,id_pcq0) = sh(i,k)
+         ELSE 
+            tr_seri(i,k,id_pcq0) = MIN (qsat(i,k), tr_seri(i,k,id_pcq0))
+         END IF
+      END DO
+     END DO
+    END IF
+
+!=================================================================
+! Update tracer : Age of stratospheric air 
+!=================================================================
+    IF (id_aga/=0) THEN
+       
+       ! Bottom layers
+       DO k = 1, lev_1p5km
+          tr_seri(:,k,id_aga) = 0.0
+       END DO
+       
+       ! Layers above 1.5km
+       DO k = lev_1p5km+1,klev-1
+          tr_seri(:,k,id_aga) = tr_seri(:,k,id_aga) + pdtphys
+       END DO
+       
+       ! Top layer
+       tr_seri(:,klev,id_aga) = tr_seri(:,klev-1,id_aga)
+       
+    END IF
+
+!======================================================================
+!     -- Calcul de l'effet de la couche limite --
+!======================================================================
+
+    IF (couchelimite) THEN             
+       source(:,:) = 0.0
+
+       IF (id_be /=0) THEN
+          DO i=1, klon
+             zrho = pplay(i,1)/t_seri(i,1)/RD
+             source(i,id_be) = - vdeptr(id_be)*tr_seri(i,1,id_be)*zrho
+          END DO
+       END IF
+
+    END IF
+    
+    DO it=1, nbtr
+       IF (couchelimite .AND. pbl_flg(it) == 0 .AND. (it==id_rn .OR. it==id_pb)) THEN 
+          ! couche limite avec quantite dans le sol calculee
+          CALL cltracrn(it, pdtphys, yu1, yv1,     &
+               cdragh, coefh,t_seri,ftsol,pctsrf,  &
+               tr_seri(:,:,it),trs(:,it),          &
+               paprs, pplay, zmasse * rg, &
+               masktr(:,it),fshtr(:,it),hsoltr(it),&
+               tautr(it),vdeptr(it),               &
+               xlat,d_tr_cl(:,:,it),d_trs)
+          
+          DO k = 1, klev
+             DO i = 1, klon
+                tr_seri(i,k,it) = tr_seri(i,k,it) + d_tr_cl(i,k,it)
+             END DO
+          END DO
+        
+          ! Traceur dans le reservoir sol
+          DO i = 1, klon
+             trs(i,it) = trs(i,it) + d_trs(i)
+          END DO
+       END IF
+    END DO
+          
+
+!======================================================================
+!   Calcul de l'effet du puits radioactif
+!======================================================================
+    CALL radio_decay (radio,rnpb,pdtphys,tautr,tr_seri,d_tr_dec)
+
+    DO it=1,nbtr
+       IF(radio(it)) then     
+          DO k = 1, klev
+             DO i = 1, klon
+                tr_seri(i,k,it) = tr_seri(i,k,it) + d_tr_dec(i,k,it)
+             END DO
+          END DO
+          CALL minmaxqfi(tr_seri(:,:,it),0.,1.e33,'puits rn it='//TRIM(int2str(it)))
+       END IF
+    END DO
+
+!======================================================================
+!   Parameterization of ozone chemistry
+!======================================================================
+
+    IF (id_o3 /= 0) then
+       lmt_pas = NINT(86400./pdtphys)
+       IF (MOD(nstep - 1, lmt_pas) == 0) THEN
+          ! Once per day, update the coefficients for ozone chemistry:
+          CALL regr_pr_comb_coefoz(julien, xlat, paprs, pplay)
+       END IF
+       CALL o3_chem(julien, gmtime, t_seri, zmasse, pdtphys, xlat, &
+            xlon, tr_seri(:, :, id_o3))
+    END IF
+
+  END SUBROUTINE traclmdz
+
+
+  SUBROUTINE traclmdz_to_restart(trs_out)
+    ! This subroutine is called from phyredem.F where the module 
+    ! variable trs is written to restart file (restartphy.nc)
+    USE dimphy
+    USE infotrac_phy, ONLY: nbtr
+    
+    REAL,DIMENSION(klon,nbtr), INTENT(OUT) :: trs_out
+    INTEGER :: ierr
+
+    IF ( ALLOCATED(trs) ) THEN
+       trs_out(:,:) = trs(:,:)
+    ELSE
+       ! No previous allocate of trs. This is the case for create_etat0_limit.
+       trs_out(:,:) = 0.0
+    END IF
+    
+  END SUBROUTINE traclmdz_to_restart
+  
+
+END MODULE traclmdz_mod
Index: DZ6/trunk/libf/phylmd/tracreprobus_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/tracreprobus_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,124 +1,0 @@
-MODULE tracreprobus_mod
-!
-! This module prepares and calls the Reprobus main subroutine 
-!
-
-CONTAINS
-
-  SUBROUTINE tracreprobus(pdtphys, gmtime, debutphy, julien, &
-       presnivs, xlat, xlon, pphis, pphi, &
-       t_seri, pplay, paprs, sh , &
-       tr_seri)
-
-    USE dimphy
-    USE infotrac_phy, ONLY: nbtr
-    USE lmdz_reprobus_wrappers, ONLY : pdt_rep, &  ! pas de temps reprobus
-         daynum, iter, &             ! jourjulien, iteration chimie
-         pdel,&
-         d_q_rep,d_ql_rep,d_qi_rep
-    USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_REPROBUS
-    IMPLICIT NONE
-
-! Input argument
-!---------------
-    REAL,INTENT(IN)    :: pdtphys    ! Pas d'integration pour la physique (seconde)
-    REAL,INTENT(IN)    :: gmtime     ! Heure courante
-    LOGICAL,INTENT(IN) :: debutphy   ! le flag de l'initialisation de la physique
-    INTEGER,INTENT(IN) :: julien     ! Jour julien
-
-    REAL,DIMENSION(klev),INTENT(IN)        :: presnivs! pressions approximat. des milieux couches (en PA)
-    REAL,DIMENSION(klon),INTENT(IN)        :: xlat    ! latitudes pour chaque point 
-    REAL,DIMENSION(klon),INTENT(IN)        :: xlon    ! longitudes pour chaque point 
-    REAL,DIMENSION(klon),INTENT(IN)        :: pphis   ! geopotentiel du sol
-    REAL,DIMENSION(klon,klev),INTENT(IN)   :: pphi    ! geopotentiel de chaque couche
-
-    REAL,DIMENSION(klon,klev),INTENT(IN)   :: t_seri  ! Temperature
-    REAL,DIMENSION(klon,klev),INTENT(IN)   :: pplay   ! pression pour le mileu de chaque couche (en Pa)
-    REAL,DIMENSION(klon,klev+1),INTENT(IN) :: paprs   ! pression pour chaque inter-couche (en Pa)
-    REAL,DIMENSION(klon,klev),INTENT(IN)   :: sh      ! humidite specifique   
-
-
-! Output argument
-!----------------
-    REAL,DIMENSION(klon,klev,nbtr),INTENT(INOUT)  :: tr_seri ! Concentration Traceur [U/KgA]  
-  
-
-! Local variables
-!----------------
-    INTEGER :: it, k, niter
-
-IF (CPPKEY_REPROBUS) THEN
-    !   -- CHIMIE REPROBUS --
-!    pdt_rep=pdtphys/2.
-    niter=pdtphys/pdt_rep
-    write(*,*)'nb d appel de REPROBUS',niter
-    
-    DO k = 1, klev
-       pdel(:,k) = paprs(:,k) - paprs (:,k+1)
-    END DO
-    
-    ! initialisation de ozone passif a ozone en debut d hiver HN et HS
-    IF (julien == 341 .OR. julien == 181) THEN
-       tr_seri(:,:,11)=tr_seri(:,:,8)
-    END IF
-
-    d_q_rep(:,:)  =0.
-    d_ql_rep(:,:) =0.
-    d_qi_rep(:,:) =0.
-    
-    DO  iter = 1,niter
-       daynum = FLOAT(julien) + gmtime + (iter-1)*pdt_rep/86400.
-       
-!       DO it=1, nbtr
-!     WRITE(lunout,*)it,' ',minval(tr_seri(:,:,it)),maxval(tr_seri(:,:,it))
-! seulement pour les especes chimiques (pas l'age de l'air)
-! verif valeurs extremes
-! correction: a 1.e-30 quand =0 ou negatif et
-! call abort si >ou= 1.e10
-!          WRITE(*,*)it,'nqtot',nqtot,'nbtr',nbtr
-!          IF (it < nqtot) THEN
-!             WRITE(*,*)'iciav',it,nqtot
-!#ifdef REPROBUS
-!             CALL minmaxqfi_chimie(it,tr_seri(1,1,it),0.,1.e10,'avant chimie ')
-!#endif
-!             WRITE(*,*)iter,'avpres'
-!          ENDIF
-!       ENDDO
-       
-IF (CPPKEY_REPROBUS) THEN
-       CALL chemmain_rlong_1401( &
-            tr_seri, & !argument phytrac (change de nom apres: vmr)
-            xlon,    & !argument phytrac (change de nom apres: lon)
-            xlat,    & !argument phytrac (change de nom apres: lat)
-            t_seri,  & !argument phytrac (meme nom)
-            pplay,   & !argument phytrac (meme nom)
-            paprs,   &
-            pphi,    & !argument phytrac (meme nom)
-            pphis,   & !argument phytrac (meme nom)
-            presnivs, & !argument phytrac (meme nom)
-            sh,      & !argument phytrac (meme nom)
-            debutphy) !argument phytrac (change de nom apres: debut)
-       ! pdel, pdt_rep, daynum : definit dans phytrac et utilise dans chemmain
-       !                 et transporte par CHEM_REP
-
-!       DO it=1, nbtr
-!     WRITE(lunout,*)it,' ',minval(tr_seri(:,:,it)),maxval(tr_seri(:,:,it))
-! seulement pour les especes chimiques (pas l'age de l'air)
-! verif valeurs extremes
-! correction: a 1.e-30 quand =0 ou negatif et
-! call abort si >ou= 1.e10
-!          WRITE(*,*)it,'nqtot',nqtot,'nbtr',nbtr
-!          IF (it < nqtot) THEN
-!             WRITE(*,*)'iciap',it,nqtot
-!             CALL minmaxqfi_chimie(it,tr_seri(1,1,it),0.,1.e10,'apres chemmain')
-!             WRITE(*,*)iter,'appres'
-!          ENDIF
-!       ENDDO
-
-END IF
-       
-    END DO
-END IF
-  END SUBROUTINE tracreprobus
-
-END MODULE tracreprobus_mod
Index: /LMDZ6/trunk/libf/phylmd/tracreprobus_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/tracreprobus_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/tracreprobus_mod.f90	(revision 5268)
@@ -0,0 +1,124 @@
+MODULE tracreprobus_mod
+!
+! This module prepares and calls the Reprobus main subroutine 
+!
+
+CONTAINS
+
+  SUBROUTINE tracreprobus(pdtphys, gmtime, debutphy, julien, &
+       presnivs, xlat, xlon, pphis, pphi, &
+       t_seri, pplay, paprs, sh , &
+       tr_seri)
+
+    USE dimphy
+    USE infotrac_phy, ONLY: nbtr
+    USE lmdz_reprobus_wrappers, ONLY : pdt_rep, &  ! pas de temps reprobus
+         daynum, iter, &             ! jourjulien, iteration chimie
+         pdel,&
+         d_q_rep,d_ql_rep,d_qi_rep
+    USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_REPROBUS
+    IMPLICIT NONE
+
+! Input argument
+!---------------
+    REAL,INTENT(IN)    :: pdtphys    ! Pas d'integration pour la physique (seconde)
+    REAL,INTENT(IN)    :: gmtime     ! Heure courante
+    LOGICAL,INTENT(IN) :: debutphy   ! le flag de l'initialisation de la physique
+    INTEGER,INTENT(IN) :: julien     ! Jour julien
+
+    REAL,DIMENSION(klev),INTENT(IN)        :: presnivs! pressions approximat. des milieux couches (en PA)
+    REAL,DIMENSION(klon),INTENT(IN)        :: xlat    ! latitudes pour chaque point 
+    REAL,DIMENSION(klon),INTENT(IN)        :: xlon    ! longitudes pour chaque point 
+    REAL,DIMENSION(klon),INTENT(IN)        :: pphis   ! geopotentiel du sol
+    REAL,DIMENSION(klon,klev),INTENT(IN)   :: pphi    ! geopotentiel de chaque couche
+
+    REAL,DIMENSION(klon,klev),INTENT(IN)   :: t_seri  ! Temperature
+    REAL,DIMENSION(klon,klev),INTENT(IN)   :: pplay   ! pression pour le mileu de chaque couche (en Pa)
+    REAL,DIMENSION(klon,klev+1),INTENT(IN) :: paprs   ! pression pour chaque inter-couche (en Pa)
+    REAL,DIMENSION(klon,klev),INTENT(IN)   :: sh      ! humidite specifique   
+
+
+! Output argument
+!----------------
+    REAL,DIMENSION(klon,klev,nbtr),INTENT(INOUT)  :: tr_seri ! Concentration Traceur [U/KgA]  
+  
+
+! Local variables
+!----------------
+    INTEGER :: it, k, niter
+
+IF (CPPKEY_REPROBUS) THEN
+    !   -- CHIMIE REPROBUS --
+!    pdt_rep=pdtphys/2.
+    niter=pdtphys/pdt_rep
+    write(*,*)'nb d appel de REPROBUS',niter
+    
+    DO k = 1, klev
+       pdel(:,k) = paprs(:,k) - paprs (:,k+1)
+    END DO
+    
+    ! initialisation de ozone passif a ozone en debut d hiver HN et HS
+    IF (julien == 341 .OR. julien == 181) THEN
+       tr_seri(:,:,11)=tr_seri(:,:,8)
+    END IF
+
+    d_q_rep(:,:)  =0.
+    d_ql_rep(:,:) =0.
+    d_qi_rep(:,:) =0.
+    
+    DO  iter = 1,niter
+       daynum = FLOAT(julien) + gmtime + (iter-1)*pdt_rep/86400.
+       
+!       DO it=1, nbtr
+!     WRITE(lunout,*)it,' ',minval(tr_seri(:,:,it)),maxval(tr_seri(:,:,it))
+! seulement pour les especes chimiques (pas l'age de l'air)
+! verif valeurs extremes
+! correction: a 1.e-30 quand =0 ou negatif et
+! call abort si >ou= 1.e10
+!          WRITE(*,*)it,'nqtot',nqtot,'nbtr',nbtr
+!          IF (it < nqtot) THEN
+!             WRITE(*,*)'iciav',it,nqtot
+!#ifdef REPROBUS
+!             CALL minmaxqfi_chimie(it,tr_seri(1,1,it),0.,1.e10,'avant chimie ')
+!#endif
+!             WRITE(*,*)iter,'avpres'
+!          ENDIF
+!       ENDDO
+       
+IF (CPPKEY_REPROBUS) THEN
+       CALL chemmain_rlong_1401( &
+            tr_seri, & !argument phytrac (change de nom apres: vmr)
+            xlon,    & !argument phytrac (change de nom apres: lon)
+            xlat,    & !argument phytrac (change de nom apres: lat)
+            t_seri,  & !argument phytrac (meme nom)
+            pplay,   & !argument phytrac (meme nom)
+            paprs,   &
+            pphi,    & !argument phytrac (meme nom)
+            pphis,   & !argument phytrac (meme nom)
+            presnivs, & !argument phytrac (meme nom)
+            sh,      & !argument phytrac (meme nom)
+            debutphy) !argument phytrac (change de nom apres: debut)
+       ! pdel, pdt_rep, daynum : definit dans phytrac et utilise dans chemmain
+       !                 et transporte par CHEM_REP
+
+!       DO it=1, nbtr
+!     WRITE(lunout,*)it,' ',minval(tr_seri(:,:,it)),maxval(tr_seri(:,:,it))
+! seulement pour les especes chimiques (pas l'age de l'air)
+! verif valeurs extremes
+! correction: a 1.e-30 quand =0 ou negatif et
+! call abort si >ou= 1.e10
+!          WRITE(*,*)it,'nqtot',nqtot,'nbtr',nbtr
+!          IF (it < nqtot) THEN
+!             WRITE(*,*)'iciap',it,nqtot
+!             CALL minmaxqfi_chimie(it,tr_seri(1,1,it),0.,1.e10,'apres chemmain')
+!             WRITE(*,*)iter,'appres'
+!          ENDIF
+!       ENDDO
+
+END IF
+       
+    END DO
+END IF
+  END SUBROUTINE tracreprobus
+
+END MODULE tracreprobus_mod
Index: DZ6/trunk/libf/phylmd/transp.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/transp.F90	(revision 5267)
+++ 	(revision )
@@ -1,58 +1,0 @@
-
-! $Id$
-
-SUBROUTINE transp(paprs, tsol, t, q, ql, qs, u, v, geom, & 
-                  utran_e, vtran_e, utran_q, vtran_q, utran_w, vtran_w)
-
-  USE dimphy
-  IMPLICIT NONE
-  ! ======================================================================
-  ! Auteur(s): Z.X.Li (LMD/CNRS)
-  ! Date: le 25 avril 1994
-  ! Objet: Calculer le transport de l'energie et de la vapeur d'eau
-  ! ======================================================================
-
-  include "YOMCST.h"
-
-  !--inputs
-  REAL, INTENT(IN)  :: paprs(klon, klev+1), tsol(klon), geom(klon, klev)
-  REAL, INTENT(IN)  :: t(klon, klev), q(klon, klev), ql(klon, klev), qs(klon, klev)
-  REAL, INTENT(IN)  :: u(klon, klev), v(klon, klev)
-  !--outputs
-  REAL, INTENT(OUT) :: utran_e(klon), vtran_e(klon) !--lateral flux of dry static energy (J m-1 s-1)
-  REAL, INTENT(OUT) :: utran_q(klon), vtran_q(klon) !--lateral flux of water vapour (kg m-1 s-1)
-  REAL, INTENT(OUT) :: utran_w(klon), vtran_w(klon) !--lateral flux of total water (kg m-1 s-1)
-  !--local variables
-  INTEGER i, l
-  REAL e, dm
-  ! ------------------------------------------------------------------
-
-  !--initialisations
-  utran_e(:) = 0.0
-  utran_q(:) = 0.0
-  vtran_e(:) = 0.0
-  vtran_q(:) = 0.0
-  utran_w(:) = 0.0
-  vtran_w(:) = 0.0
-
-  !--vertical integration of diagnostics
-  DO l = 1, klev
-    DO i = 1, klon
-      dm= (paprs(i,l)-paprs(i,l+1))/RG  !--mass of layer kg m-2
-      !--moist static energy
-!      e = rcpd*t(i, l) + rlvtt*q(i, l) + geom(i, l)
-      !--dry static energy
-      e = rcpd*t(i, l) + geom(i, l)
-      utran_e(i) = utran_e(i) + u(i, l)*e*dm
-      vtran_e(i) = vtran_e(i) + v(i, l)*e*dm
-      !--water vapour
-      utran_q(i) = utran_q(i) + u(i, l)*q(i,l)*dm 
-      vtran_q(i) = vtran_q(i) + v(i, l)*q(i,l)*dm
-      !--total water
-      utran_w(i) = utran_w(i) + u(i, l)*(q(i,l)+ql(i,l)+qs(i,l))*dm 
-      vtran_w(i) = vtran_w(i) + v(i, l)*(q(i,l)+ql(i,l)+qs(i,l))*dm
-    ENDDO
-  ENDDO
-
-  RETURN
-END SUBROUTINE transp
Index: /LMDZ6/trunk/libf/phylmd/transp.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/transp.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/transp.f90	(revision 5268)
@@ -0,0 +1,58 @@
+
+! $Id$
+
+SUBROUTINE transp(paprs, tsol, t, q, ql, qs, u, v, geom, & 
+                  utran_e, vtran_e, utran_q, vtran_q, utran_w, vtran_w)
+
+  USE dimphy
+  IMPLICIT NONE
+  ! ======================================================================
+  ! Auteur(s): Z.X.Li (LMD/CNRS)
+  ! Date: le 25 avril 1994
+  ! Objet: Calculer le transport de l'energie et de la vapeur d'eau
+  ! ======================================================================
+
+  include "YOMCST.h"
+
+  !--inputs
+  REAL, INTENT(IN)  :: paprs(klon, klev+1), tsol(klon), geom(klon, klev)
+  REAL, INTENT(IN)  :: t(klon, klev), q(klon, klev), ql(klon, klev), qs(klon, klev)
+  REAL, INTENT(IN)  :: u(klon, klev), v(klon, klev)
+  !--outputs
+  REAL, INTENT(OUT) :: utran_e(klon), vtran_e(klon) !--lateral flux of dry static energy (J m-1 s-1)
+  REAL, INTENT(OUT) :: utran_q(klon), vtran_q(klon) !--lateral flux of water vapour (kg m-1 s-1)
+  REAL, INTENT(OUT) :: utran_w(klon), vtran_w(klon) !--lateral flux of total water (kg m-1 s-1)
+  !--local variables
+  INTEGER i, l
+  REAL e, dm
+  ! ------------------------------------------------------------------
+
+  !--initialisations
+  utran_e(:) = 0.0
+  utran_q(:) = 0.0
+  vtran_e(:) = 0.0
+  vtran_q(:) = 0.0
+  utran_w(:) = 0.0
+  vtran_w(:) = 0.0
+
+  !--vertical integration of diagnostics
+  DO l = 1, klev
+    DO i = 1, klon
+      dm= (paprs(i,l)-paprs(i,l+1))/RG  !--mass of layer kg m-2
+      !--moist static energy
+!      e = rcpd*t(i, l) + rlvtt*q(i, l) + geom(i, l)
+      !--dry static energy
+      e = rcpd*t(i, l) + geom(i, l)
+      utran_e(i) = utran_e(i) + u(i, l)*e*dm
+      vtran_e(i) = vtran_e(i) + v(i, l)*e*dm
+      !--water vapour
+      utran_q(i) = utran_q(i) + u(i, l)*q(i,l)*dm 
+      vtran_q(i) = vtran_q(i) + v(i, l)*q(i,l)*dm
+      !--total water
+      utran_w(i) = utran_w(i) + u(i, l)*(q(i,l)+ql(i,l)+qs(i,l))*dm 
+      vtran_w(i) = vtran_w(i) + v(i, l)*(q(i,l)+ql(i,l)+qs(i,l))*dm
+    ENDDO
+  ENDDO
+
+  RETURN
+END SUBROUTINE transp
Index: DZ6/trunk/libf/phylmd/transp_lay.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/transp_lay.F90	(revision 5267)
+++ 	(revision )
@@ -1,50 +1,0 @@
-
-! $Header$
-
-SUBROUTINE transp_lay(paprs, tsol, t, q, u, v, geom, vtran_e, vtran_q, &
-    utran_e, utran_q)
-
-  USE dimphy
-  IMPLICIT NONE
-  ! ======================================================================
-  ! Auteur(s): Z.X.Li (LMD/CNRS)
-  ! Date: le 25 avril 1994
-  ! Objet: Calculer le transport de l'energie et de la vapeur d'eau
-  ! ======================================================================
-
-  include "YOMCST.h"
-
-  REAL paprs(klon, klev+1), tsol(klon)
-  REAL t(klon, klev), q(klon, klev), u(klon, klev), v(klon, klev)
-  REAL utran_e(klon, klev), utran_q(klon, klev)
-  REAL vtran_e(klon, klev), vtran_q(klon, klev)
-
-  INTEGER i, l
-  ! ------------------------------------------------------------------
-  REAL geom(klon, klev), esh
-  ! ------------------------------------------------------------------
-  DO l = 1, klev
-    DO i = 1, klon
-      utran_e(i, l) = 0.0
-      utran_q(i, l) = 0.0
-      vtran_e(i, l) = 0.0
-      vtran_q(i, l) = 0.0
-    END DO
-  END DO
-
-  DO l = 1, klev
-    DO i = 1, klon
-      esh = rcpd*t(i, l) + rlvtt*q(i, l) + geom(i, l)
-      utran_e(i, l) = utran_e(i, l) + u(i, l)*esh*(paprs(i,l)-paprs(i,l+1))/ &
-        rg
-      utran_q(i, l) = utran_q(i, l) + u(i, l)*q(i, l)*(paprs(i,l)-paprs(i,l+1 &
-        ))/rg
-      vtran_e(i, l) = vtran_e(i, l) + v(i, l)*esh*(paprs(i,l)-paprs(i,l+1))/ &
-        rg
-      vtran_q(i, l) = vtran_q(i, l) + v(i, l)*q(i, l)*(paprs(i,l)-paprs(i,l+1 &
-        ))/rg
-    END DO
-  END DO
-
-  RETURN
-END SUBROUTINE transp_lay
Index: /LMDZ6/trunk/libf/phylmd/transp_lay.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/transp_lay.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/transp_lay.f90	(revision 5268)
@@ -0,0 +1,50 @@
+
+! $Header$
+
+SUBROUTINE transp_lay(paprs, tsol, t, q, u, v, geom, vtran_e, vtran_q, &
+    utran_e, utran_q)
+
+  USE dimphy
+  IMPLICIT NONE
+  ! ======================================================================
+  ! Auteur(s): Z.X.Li (LMD/CNRS)
+  ! Date: le 25 avril 1994
+  ! Objet: Calculer le transport de l'energie et de la vapeur d'eau
+  ! ======================================================================
+
+  include "YOMCST.h"
+
+  REAL paprs(klon, klev+1), tsol(klon)
+  REAL t(klon, klev), q(klon, klev), u(klon, klev), v(klon, klev)
+  REAL utran_e(klon, klev), utran_q(klon, klev)
+  REAL vtran_e(klon, klev), vtran_q(klon, klev)
+
+  INTEGER i, l
+  ! ------------------------------------------------------------------
+  REAL geom(klon, klev), esh
+  ! ------------------------------------------------------------------
+  DO l = 1, klev
+    DO i = 1, klon
+      utran_e(i, l) = 0.0
+      utran_q(i, l) = 0.0
+      vtran_e(i, l) = 0.0
+      vtran_q(i, l) = 0.0
+    END DO
+  END DO
+
+  DO l = 1, klev
+    DO i = 1, klon
+      esh = rcpd*t(i, l) + rlvtt*q(i, l) + geom(i, l)
+      utran_e(i, l) = utran_e(i, l) + u(i, l)*esh*(paprs(i,l)-paprs(i,l+1))/ &
+        rg
+      utran_q(i, l) = utran_q(i, l) + u(i, l)*q(i, l)*(paprs(i,l)-paprs(i,l+1 &
+        ))/rg
+      vtran_e(i, l) = vtran_e(i, l) + v(i, l)*esh*(paprs(i,l)-paprs(i,l+1))/ &
+        rg
+      vtran_q(i, l) = vtran_q(i, l) + v(i, l)*q(i, l)*(paprs(i,l)-paprs(i,l+1 &
+        ))/rg
+    END DO
+  END DO
+
+  RETURN
+END SUBROUTINE transp_lay
Index: DZ6/trunk/libf/phylmd/tropopause_m.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/tropopause_m.F90	(revision 5267)
+++ 	(revision )
@@ -1,145 +1,0 @@
-MODULE tropopause_m
-
-  IMPLICIT NONE
-  PRIVATE
-  PUBLIC :: dyn_tropopause
-
-CONTAINS
-
-!-------------------------------------------------------------------------------
-!
-FUNCTION dyn_tropopause(t, ts, paprs, pplay, rot, itrop, thet0, pvor0)
-!
-!-------------------------------------------------------------------------------
-  USE assert_m,     ONLY: assert
-  USE assert_eq_m,  ONLY: assert_eq
-  USE dimphy,       ONLY: klon, klev
-  USE geometry_mod, ONLY: latitude_deg, longitude_deg
-  USE vertical_layers_mod, ONLY: aps, bps, preff
-  USE lmdz_reprobus_wrappers, ONLY: itroprep
-  USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_REPROBUS
-
-!-------------------------------------------------------------------------------
-! Arguments:
-  REAL ::     dyn_tropopause(klon) !--- Pressure at tropopause
-  REAL, INTENT(IN)  ::      t(:,:) !--- Cells-centers temperature
-  REAL, INTENT(IN)  ::     ts(:)   !--- Surface       temperature
-  REAL, INTENT(IN)  ::  paprs(:,:) !--- Cells-edges   pressure
-  REAL, INTENT(IN)  ::  pplay(:,:) !--- Cells-centers pressure
-  REAL, INTENT(IN)  ::    rot(:,:) !--- Cells-centers relative vorticity
-  INTEGER, INTENT(OUT), OPTIONAL :: itrop(klon) !--- Last tropospheric layer idx
-  REAL,    INTENT(IN),  OPTIONAL :: thet0, pvor0
-!-------------------------------------------------------------------------------
-! Local variables:
-  include "YOMCST.h"
-  REAL, PARAMETER :: DynPTrMin =8.E+3 !--- Thresholds for minimum and maximum
-  REAL, PARAMETER :: DynPTrMax =4.E+4 !    dynamical tropopause pressure (Pa).
-  CHARACTER(LEN=80)  :: sub
-  INTEGER :: i, k, kb, kt, kp, ib, ie, nw
-  REAL    :: al, th0, pv0
-  REAL,    DIMENSION(klon,klev) :: tpot_cen, tpot_edg, pvor_cen
-  REAL,    PARAMETER :: sg0=0.75  !--- Start level for PV=cte search loop
-  INTEGER, PARAMETER :: nadj=3    !--- Adjacent levs nb for thresholds detection
-  REAL,    PARAMETER :: w(5)=[0.1,0.25,0.3,0.25,0.1] !--- Vertical smoothing
-  INTEGER, SAVE :: k0
-  LOGICAL, SAVE :: first=.TRUE.
-!$OMP THREADPRIVATE(k0,first)
-!-------------------------------------------------------------------------------
-  sub='dyn_tropopause'
-  CALL assert(SIZE(t ,1)==klon, TRIM(sub)//" t klon")
-  CALL assert(SIZE(t ,2)==klev, TRIM(sub)//" t klev")
-  CALL assert(SIZE(ts,1)==klon, TRIM(sub)//" ts klon")
-  CALL assert(SHAPE(paprs)==[klon,klev+1],TRIM(sub)//" paprs shape")
-  CALL assert(SHAPE(pplay)==[klon,klev  ],TRIM(sub)//" pplay shape")
-  CALL assert(SHAPE(rot)  ==[klon,klev  ],TRIM(sub)//" rot shape")
-
-  !--- DEFAULT THRESHOLDS
-  th0=380.; IF(PRESENT(thet0)) th0=thet0   !--- In kelvins
-  pv0=  2.; IF(PRESENT(pvor0)) pv0=pvor0   !--- In PVU
-  IF(first) THEN
-    DO k0=1,klev; IF(aps(k0)/preff+bps(k0)<sg0) EXIT; END DO; first=.FALSE.
-  END IF
-
-  !--- POTENTIAL TEMPERATURE AT CELLS CENTERS AND INTERFACES
-  DO i = 1,klon
-    tpot_cen(i,1) = t(i,1)*(preff/pplay(i,1))**RKAPPA
-    tpot_edg(i,1) = ts(i) *(preff/paprs(i,1))**RKAPPA
-    DO k=2,klev
-      al = LOG(pplay(i,k-1)/paprs(i,k))/LOG(pplay(i,k-1)/pplay(i,k))
-      tpot_cen(i,k) =  t(i,k)                        *(preff/pplay(i,k))**RKAPPA
-      tpot_edg(i,k) = (t(i,k-1)+al*(t(i,k)-t(i,k-1)))*(preff/paprs(i,k))**RKAPPA
-      !--- FORCE QUANTITIES TO BE GROWING
-      IF(tpot_edg(i,k)<tpot_edg(i,k-1)) tpot_edg(i,k)=tpot_edg(i,k-1)+1.E-5
-      IF(tpot_cen(i,k)<tpot_cen(i,k-1)) tpot_cen(i,k)=tpot_cen(i,k-1)+1.E-5
-    END DO
-    !--- VERTICAL SMOOTHING
-    tpot_cen(i,:)=smooth(tpot_cen(i,:),w)
-    tpot_edg(i,:)=smooth(tpot_edg(i,:),w)
-  END DO
-
-  !--- ERTEL POTENTIAL VORTICITY AT CELLS CENTERS (except in top layer)
-  DO i = 1, klon
-    DO k= 1, klev-1
-      pvor_cen(i,k)=-1.E6*RG*(rot(i,k)+2.*ROMEGA*SIN(latitude_deg(i)*RPI/180.))&
-                   * (tpot_edg(i,k+1)-tpot_edg(i,k)) / (paprs(i,k+1)-paprs(i,k))
-    END DO
-    !--- VERTICAL SMOOTHING
-    pvor_cen(i,1:klev-1)=smooth(pvor_cen(i,1:klev-1),w)
-  END DO
-
-  !--- LOCATE TROPOPAUSE: LOWEST POINT BETWEEN THETA=380K AND PV=2PVU SURFACES.
-  DO i = 1, klon
-    !--- UPPER TROPOPAUSE: |PV|=2PVU POINT STARTING FROM TOP
-    DO kt=klev-1,1,-1; IF(ALL(ABS(pvor_cen(i,kt-nadj:kt))<=pv0)) EXIT; END DO
-    !--- LOWER TROPOPAUSE: |PV|=2PVU POINT STARTING FROM BOTTOM
-    DO kb=k0,klev-1;   IF(ALL(ABS(pvor_cen(i,kb:kb+nadj))> pv0)) EXIT; END DO; kb=kb-1
-    !--- ISO-THETA POINT: THETA=380K       STARTING FROM TOP
-    DO kp=klev-1,1,-1; IF(ALL(ABS(tpot_cen(i,kp-nadj:kp))<=th0)) EXIT; END DO
-    !--- CHOOSE BETWEEN LOWER AND UPPER TROPOPAUSE
-    IF(2*COUNT(ABS(pvor_cen(i,kb:kt))>pv0)>kt-kb+1) kt=kb
-    !--- PV-DEFINED TROPOPAUSE
-    al = (ABS(pvor_cen(i,kt+1))-pv0)/ABS(pvor_cen(i,kt+1)-pvor_cen(i,kt))
-    dyn_tropopause(i) = pplay(i,kt+1)*(pplay(i,kt)/pplay(i,kt+1))**al
-    !--- THETA=380K IN THE TROPICAL REGION
-    al = (tpot_cen(i,kp+1)-th0)/(tpot_cen(i,kp+1)-tpot_cen(i,kp))
-    dyn_tropopause(i) = MAX( pplay(i,kp+1)*(pplay(i,kp)/pplay(i,kp+1))**al,    &
-                            dyn_tropopause(i) )
-    !--- UNREALISTIC VALUES DETECTION
-    IF(dyn_tropopause(i)<DynPTrMin.OR.dyn_tropopause(i)>DynPTrMax) THEN
-      dyn_tropopause(i)=MIN(MAX(dyn_tropopause(i),DynPTrMax),DynPTrMin)
-      DO kt=1,klev-1; IF(pplay(i,kt+1)>dyn_tropopause(i)) EXIT; END DO; kp=kt
-    END IF
-IF (CPPKEY_REPROBUS) THEN
-    itroprep(i)=MAX(kt,kp)
-END IF
-    !--- LAST TROPOSPHERIC LAYER INDEX NEEDED
-    IF(PRESENT(itrop)) itrop(i)=MAX(kt,kp)
-  END DO
-
-END FUNCTION dyn_tropopause
-
-
-!-------------------------------------------------------------------------------
-!
-FUNCTION smooth(v,w)
-!
-!-------------------------------------------------------------------------------
-! Arguments:
-  REAL, INTENT(IN)         :: v(:), w(:)
-  REAL, DIMENSION(SIZE(v)) :: smooth
-!-------------------------------------------------------------------------------
-! Local variables:
-  INTEGER :: nv, nw, k, kb, ke, lb, le
-!-------------------------------------------------------------------------------
-  nv=SIZE(v); nw=(SIZE(w)-1)/2
-  DO k=1,nv
-    kb=MAX(k-nw,1 ); lb=MAX(2+nw   -k,1)
-    ke=MIN(k+nw,nv); le=MIN(1+nw+nv-k,1+2*nw)
-    smooth(k)=SUM(v(kb:ke)*w(lb:le))/SUM(w(lb:le))
-  END DO
-
-END FUNCTION smooth
-!
-!-------------------------------------------------------------------------------
-
-END MODULE tropopause_m
Index: /LMDZ6/trunk/libf/phylmd/tropopause_m.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/tropopause_m.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/tropopause_m.f90	(revision 5268)
@@ -0,0 +1,145 @@
+MODULE tropopause_m
+
+  IMPLICIT NONE
+  PRIVATE
+  PUBLIC :: dyn_tropopause
+
+CONTAINS
+
+!-------------------------------------------------------------------------------
+!
+FUNCTION dyn_tropopause(t, ts, paprs, pplay, rot, itrop, thet0, pvor0)
+!
+!-------------------------------------------------------------------------------
+  USE assert_m,     ONLY: assert
+  USE assert_eq_m,  ONLY: assert_eq
+  USE dimphy,       ONLY: klon, klev
+  USE geometry_mod, ONLY: latitude_deg, longitude_deg
+  USE vertical_layers_mod, ONLY: aps, bps, preff
+  USE lmdz_reprobus_wrappers, ONLY: itroprep
+  USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_REPROBUS
+
+!-------------------------------------------------------------------------------
+! Arguments:
+  REAL ::     dyn_tropopause(klon) !--- Pressure at tropopause
+  REAL, INTENT(IN)  ::      t(:,:) !--- Cells-centers temperature
+  REAL, INTENT(IN)  ::     ts(:)   !--- Surface       temperature
+  REAL, INTENT(IN)  ::  paprs(:,:) !--- Cells-edges   pressure
+  REAL, INTENT(IN)  ::  pplay(:,:) !--- Cells-centers pressure
+  REAL, INTENT(IN)  ::    rot(:,:) !--- Cells-centers relative vorticity
+  INTEGER, INTENT(OUT), OPTIONAL :: itrop(klon) !--- Last tropospheric layer idx
+  REAL,    INTENT(IN),  OPTIONAL :: thet0, pvor0
+!-------------------------------------------------------------------------------
+! Local variables:
+  include "YOMCST.h"
+  REAL, PARAMETER :: DynPTrMin =8.E+3 !--- Thresholds for minimum and maximum
+  REAL, PARAMETER :: DynPTrMax =4.E+4 !    dynamical tropopause pressure (Pa).
+  CHARACTER(LEN=80)  :: sub
+  INTEGER :: i, k, kb, kt, kp, ib, ie, nw
+  REAL    :: al, th0, pv0
+  REAL,    DIMENSION(klon,klev) :: tpot_cen, tpot_edg, pvor_cen
+  REAL,    PARAMETER :: sg0=0.75  !--- Start level for PV=cte search loop
+  INTEGER, PARAMETER :: nadj=3    !--- Adjacent levs nb for thresholds detection
+  REAL,    PARAMETER :: w(5)=[0.1,0.25,0.3,0.25,0.1] !--- Vertical smoothing
+  INTEGER, SAVE :: k0
+  LOGICAL, SAVE :: first=.TRUE.
+!$OMP THREADPRIVATE(k0,first)
+!-------------------------------------------------------------------------------
+  sub='dyn_tropopause'
+  CALL assert(SIZE(t ,1)==klon, TRIM(sub)//" t klon")
+  CALL assert(SIZE(t ,2)==klev, TRIM(sub)//" t klev")
+  CALL assert(SIZE(ts,1)==klon, TRIM(sub)//" ts klon")
+  CALL assert(SHAPE(paprs)==[klon,klev+1],TRIM(sub)//" paprs shape")
+  CALL assert(SHAPE(pplay)==[klon,klev  ],TRIM(sub)//" pplay shape")
+  CALL assert(SHAPE(rot)  ==[klon,klev  ],TRIM(sub)//" rot shape")
+
+  !--- DEFAULT THRESHOLDS
+  th0=380.; IF(PRESENT(thet0)) th0=thet0   !--- In kelvins
+  pv0=  2.; IF(PRESENT(pvor0)) pv0=pvor0   !--- In PVU
+  IF(first) THEN
+    DO k0=1,klev; IF(aps(k0)/preff+bps(k0)<sg0) EXIT; END DO; first=.FALSE.
+  END IF
+
+  !--- POTENTIAL TEMPERATURE AT CELLS CENTERS AND INTERFACES
+  DO i = 1,klon
+    tpot_cen(i,1) = t(i,1)*(preff/pplay(i,1))**RKAPPA
+    tpot_edg(i,1) = ts(i) *(preff/paprs(i,1))**RKAPPA
+    DO k=2,klev
+      al = LOG(pplay(i,k-1)/paprs(i,k))/LOG(pplay(i,k-1)/pplay(i,k))
+      tpot_cen(i,k) =  t(i,k)                        *(preff/pplay(i,k))**RKAPPA
+      tpot_edg(i,k) = (t(i,k-1)+al*(t(i,k)-t(i,k-1)))*(preff/paprs(i,k))**RKAPPA
+      !--- FORCE QUANTITIES TO BE GROWING
+      IF(tpot_edg(i,k)<tpot_edg(i,k-1)) tpot_edg(i,k)=tpot_edg(i,k-1)+1.E-5
+      IF(tpot_cen(i,k)<tpot_cen(i,k-1)) tpot_cen(i,k)=tpot_cen(i,k-1)+1.E-5
+    END DO
+    !--- VERTICAL SMOOTHING
+    tpot_cen(i,:)=smooth(tpot_cen(i,:),w)
+    tpot_edg(i,:)=smooth(tpot_edg(i,:),w)
+  END DO
+
+  !--- ERTEL POTENTIAL VORTICITY AT CELLS CENTERS (except in top layer)
+  DO i = 1, klon
+    DO k= 1, klev-1
+      pvor_cen(i,k)=-1.E6*RG*(rot(i,k)+2.*ROMEGA*SIN(latitude_deg(i)*RPI/180.))&
+                   * (tpot_edg(i,k+1)-tpot_edg(i,k)) / (paprs(i,k+1)-paprs(i,k))
+    END DO
+    !--- VERTICAL SMOOTHING
+    pvor_cen(i,1:klev-1)=smooth(pvor_cen(i,1:klev-1),w)
+  END DO
+
+  !--- LOCATE TROPOPAUSE: LOWEST POINT BETWEEN THETA=380K AND PV=2PVU SURFACES.
+  DO i = 1, klon
+    !--- UPPER TROPOPAUSE: |PV|=2PVU POINT STARTING FROM TOP
+    DO kt=klev-1,1,-1; IF(ALL(ABS(pvor_cen(i,kt-nadj:kt))<=pv0)) EXIT; END DO
+    !--- LOWER TROPOPAUSE: |PV|=2PVU POINT STARTING FROM BOTTOM
+    DO kb=k0,klev-1;   IF(ALL(ABS(pvor_cen(i,kb:kb+nadj))> pv0)) EXIT; END DO; kb=kb-1
+    !--- ISO-THETA POINT: THETA=380K       STARTING FROM TOP
+    DO kp=klev-1,1,-1; IF(ALL(ABS(tpot_cen(i,kp-nadj:kp))<=th0)) EXIT; END DO
+    !--- CHOOSE BETWEEN LOWER AND UPPER TROPOPAUSE
+    IF(2*COUNT(ABS(pvor_cen(i,kb:kt))>pv0)>kt-kb+1) kt=kb
+    !--- PV-DEFINED TROPOPAUSE
+    al = (ABS(pvor_cen(i,kt+1))-pv0)/ABS(pvor_cen(i,kt+1)-pvor_cen(i,kt))
+    dyn_tropopause(i) = pplay(i,kt+1)*(pplay(i,kt)/pplay(i,kt+1))**al
+    !--- THETA=380K IN THE TROPICAL REGION
+    al = (tpot_cen(i,kp+1)-th0)/(tpot_cen(i,kp+1)-tpot_cen(i,kp))
+    dyn_tropopause(i) = MAX( pplay(i,kp+1)*(pplay(i,kp)/pplay(i,kp+1))**al,    &
+                            dyn_tropopause(i) )
+    !--- UNREALISTIC VALUES DETECTION
+    IF(dyn_tropopause(i)<DynPTrMin.OR.dyn_tropopause(i)>DynPTrMax) THEN
+      dyn_tropopause(i)=MIN(MAX(dyn_tropopause(i),DynPTrMax),DynPTrMin)
+      DO kt=1,klev-1; IF(pplay(i,kt+1)>dyn_tropopause(i)) EXIT; END DO; kp=kt
+    END IF
+IF (CPPKEY_REPROBUS) THEN
+    itroprep(i)=MAX(kt,kp)
+END IF
+    !--- LAST TROPOSPHERIC LAYER INDEX NEEDED
+    IF(PRESENT(itrop)) itrop(i)=MAX(kt,kp)
+  END DO
+
+END FUNCTION dyn_tropopause
+
+
+!-------------------------------------------------------------------------------
+!
+FUNCTION smooth(v,w)
+!
+!-------------------------------------------------------------------------------
+! Arguments:
+  REAL, INTENT(IN)         :: v(:), w(:)
+  REAL, DIMENSION(SIZE(v)) :: smooth
+!-------------------------------------------------------------------------------
+! Local variables:
+  INTEGER :: nv, nw, k, kb, ke, lb, le
+!-------------------------------------------------------------------------------
+  nv=SIZE(v); nw=(SIZE(w)-1)/2
+  DO k=1,nv
+    kb=MAX(k-nw,1 ); lb=MAX(2+nw   -k,1)
+    ke=MIN(k+nw,nv); le=MIN(1+nw+nv-k,1+2*nw)
+    smooth(k)=SUM(v(kb:ke)*w(lb:le))/SUM(w(lb:le))
+  END DO
+
+END FUNCTION smooth
+!
+!-------------------------------------------------------------------------------
+
+END MODULE tropopause_m
Index: DZ6/trunk/libf/phylmd/undefSTD.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/undefSTD.F90	(revision 5267)
+++ 	(revision )
@@ -1,105 +1,0 @@
-
-! $Id$
-
-SUBROUTINE undefstd(itap, read_climoz)
-  USE netcdf
-  USE dimphy
-  USE phys_state_var_mod
-  USE wxios, ONLY: missing_val_xios => missing_val, using_xios
-
-  IMPLICIT NONE
-  include "clesphys.h"
-  REAL :: missing_val
-
-  ! ====================================================================
-
-  ! I. Musat : 09.2004
-
-  ! Calcul * du nombre de pas de temps (FLOAT(ecrit_XXX)-tnondef))
-  ! ou la variable tlevSTD est bien definie (.NE.missing_val),
-  ! et
-  ! * de la somme de tlevSTD => tsumSTD
-
-  ! nout=1 !var. journaliere "day" moyenne sur tous les pas de temps
-  ! ! de la physique
-  ! nout=2 !var. mensuelle "mth" moyennee sur tous les pas de temps
-  ! ! de la physique
-  ! nout=3 !var. mensuelle "NMC" moyennee toutes les ecrit_hf
-
-
-  ! NB: mettre "inst(X)" dans le write_hist*NMC.h !
-  ! ====================================================================
-
-  ! ymINCLUDE "dimphy.h"
-  ! variables Input
-
-  ! INTEGER nlevSTD, klevSTD, itap
-  ! PARAMETER(klevSTD=17)
-  INTEGER itap
-
-  ! variables locales
-  ! INTEGER i, k, nout, n
-  ! PARAMETER(nout=3) !nout=1 : day; =2 : mth; =3 : NMC
-  INTEGER i, k, n
-  ! REAL freq_calNMC(nout)
-  INTEGER read_climoz
-
-  ! variables Output
-  ! REAL tlevSTD(klon,klevSTD), tsumSTD(klon,klevSTD,nout)
-  ! LOGICAL oknondef(klon,klevSTD,nout)
-  ! REAL tnondef(klon,klevSTD,nout)
-
-! REAL missing_val
-
-! missing_val = nf90_fill_real
-  IF (using_xios) THEN
-    missing_val=missing_val_xios
-  ELSE
-      missing_val=missing_val_nf90
-  ENDIF
-
-  DO n = 1, nout
-
-
-    ! calcul variables tous les freq_calNMC(n)/phys_tstep pas de temps
-    ! de la physique
-
-    IF (mod(itap,nint(freq_calnmc(n)/phys_tstep))==0) THEN
-      DO k = 1, nlevstd
-        DO i = 1, klon
-          IF (tlevstd(i,k)==missing_val) THEN
-            ! IF(oknondef(i,k,n)) THEN
-            tnondef(i, k, n) = tnondef(i, k, n) + 1.
-            ! ENDIF !oknondef(i,k)
-
-          ELSE IF (tlevstd(i,k)/=missing_val) THEN
-            tsumstd(i, k, n) = tsumstd(i, k, n) + tlevstd(i, k)
-            usumstd(i, k, n) = usumstd(i, k, n) + ulevstd(i, k)
-            vsumstd(i, k, n) = vsumstd(i, k, n) + vlevstd(i, k)
-            wsumstd(i, k, n) = wsumstd(i, k, n) + wlevstd(i, k)
-            phisumstd(i, k, n) = phisumstd(i, k, n) + philevstd(i, k)
-            qsumstd(i, k, n) = qsumstd(i, k, n) + qlevstd(i, k)
-            rhsumstd(i, k, n) = rhsumstd(i, k, n) + rhlevstd(i, k)
-            uvsumstd(i, k, n) = uvsumstd(i, k, n) + uvstd(i, k)
-            vqsumstd(i, k, n) = vqsumstd(i, k, n) + vqstd(i, k)
-            vtsumstd(i, k, n) = vtsumstd(i, k, n) + vtstd(i, k)
-            wqsumstd(i, k, n) = wqsumstd(i, k, n) + wqstd(i, k)
-            vphisumstd(i, k, n) = vphisumstd(i, k, n) + vphistd(i, k)
-            wtsumstd(i, k, n) = wtsumstd(i, k, n) + wtstd(i, k)
-            u2sumstd(i, k, n) = u2sumstd(i, k, n) + u2std(i, k)
-            v2sumstd(i, k, n) = v2sumstd(i, k, n) + v2std(i, k)
-            t2sumstd(i, k, n) = t2sumstd(i, k, n) + t2std(i, k)
-            o3sumstd(i, k, n) = o3sumstd(i, k, n) + o3std(i, k)
-            IF (read_climoz==2) o3daysumstd(i, k, n) = o3daysumstd(i, k, n) + &
-              o3daystd(i, k)
-
-          END IF
-        END DO !i
-      END DO !k
-
-    END IF !MOD(itap,NINT(freq_calNMC(n)/phys_tstep)).EQ.0
-
-  END DO !n
-
-  RETURN
-END SUBROUTINE undefstd
Index: /LMDZ6/trunk/libf/phylmd/undefSTD.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/undefSTD.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/undefSTD.f90	(revision 5268)
@@ -0,0 +1,105 @@
+
+! $Id$
+
+SUBROUTINE undefstd(itap, read_climoz)
+  USE netcdf
+  USE dimphy
+  USE phys_state_var_mod
+  USE wxios, ONLY: missing_val_xios => missing_val, using_xios
+
+  IMPLICIT NONE
+  include "clesphys.h"
+  REAL :: missing_val
+
+  ! ====================================================================
+
+  ! I. Musat : 09.2004
+
+  ! Calcul * du nombre de pas de temps (FLOAT(ecrit_XXX)-tnondef))
+  ! ou la variable tlevSTD est bien definie (.NE.missing_val),
+  ! et
+  ! * de la somme de tlevSTD => tsumSTD
+
+  ! nout=1 !var. journaliere "day" moyenne sur tous les pas de temps
+  ! ! de la physique
+  ! nout=2 !var. mensuelle "mth" moyennee sur tous les pas de temps
+  ! ! de la physique
+  ! nout=3 !var. mensuelle "NMC" moyennee toutes les ecrit_hf
+
+
+  ! NB: mettre "inst(X)" dans le write_hist*NMC.h !
+  ! ====================================================================
+
+  ! ymINCLUDE "dimphy.h"
+  ! variables Input
+
+  ! INTEGER nlevSTD, klevSTD, itap
+  ! PARAMETER(klevSTD=17)
+  INTEGER itap
+
+  ! variables locales
+  ! INTEGER i, k, nout, n
+  ! PARAMETER(nout=3) !nout=1 : day; =2 : mth; =3 : NMC
+  INTEGER i, k, n
+  ! REAL freq_calNMC(nout)
+  INTEGER read_climoz
+
+  ! variables Output
+  ! REAL tlevSTD(klon,klevSTD), tsumSTD(klon,klevSTD,nout)
+  ! LOGICAL oknondef(klon,klevSTD,nout)
+  ! REAL tnondef(klon,klevSTD,nout)
+
+! REAL missing_val
+
+! missing_val = nf90_fill_real
+  IF (using_xios) THEN
+    missing_val=missing_val_xios
+  ELSE
+      missing_val=missing_val_nf90
+  ENDIF
+
+  DO n = 1, nout
+
+
+    ! calcul variables tous les freq_calNMC(n)/phys_tstep pas de temps
+    ! de la physique
+
+    IF (mod(itap,nint(freq_calnmc(n)/phys_tstep))==0) THEN
+      DO k = 1, nlevstd
+        DO i = 1, klon
+          IF (tlevstd(i,k)==missing_val) THEN
+            ! IF(oknondef(i,k,n)) THEN
+            tnondef(i, k, n) = tnondef(i, k, n) + 1.
+            ! ENDIF !oknondef(i,k)
+
+          ELSE IF (tlevstd(i,k)/=missing_val) THEN
+            tsumstd(i, k, n) = tsumstd(i, k, n) + tlevstd(i, k)
+            usumstd(i, k, n) = usumstd(i, k, n) + ulevstd(i, k)
+            vsumstd(i, k, n) = vsumstd(i, k, n) + vlevstd(i, k)
+            wsumstd(i, k, n) = wsumstd(i, k, n) + wlevstd(i, k)
+            phisumstd(i, k, n) = phisumstd(i, k, n) + philevstd(i, k)
+            qsumstd(i, k, n) = qsumstd(i, k, n) + qlevstd(i, k)
+            rhsumstd(i, k, n) = rhsumstd(i, k, n) + rhlevstd(i, k)
+            uvsumstd(i, k, n) = uvsumstd(i, k, n) + uvstd(i, k)
+            vqsumstd(i, k, n) = vqsumstd(i, k, n) + vqstd(i, k)
+            vtsumstd(i, k, n) = vtsumstd(i, k, n) + vtstd(i, k)
+            wqsumstd(i, k, n) = wqsumstd(i, k, n) + wqstd(i, k)
+            vphisumstd(i, k, n) = vphisumstd(i, k, n) + vphistd(i, k)
+            wtsumstd(i, k, n) = wtsumstd(i, k, n) + wtstd(i, k)
+            u2sumstd(i, k, n) = u2sumstd(i, k, n) + u2std(i, k)
+            v2sumstd(i, k, n) = v2sumstd(i, k, n) + v2std(i, k)
+            t2sumstd(i, k, n) = t2sumstd(i, k, n) + t2std(i, k)
+            o3sumstd(i, k, n) = o3sumstd(i, k, n) + o3std(i, k)
+            IF (read_climoz==2) o3daysumstd(i, k, n) = o3daysumstd(i, k, n) + &
+              o3daystd(i, k)
+
+          END IF
+        END DO !i
+      END DO !k
+
+    END IF !MOD(itap,NINT(freq_calNMC(n)/phys_tstep)).EQ.0
+
+  END DO !n
+
+  RETURN
+END SUBROUTINE undefstd
Index: DZ6/trunk/libf/phylmd/ustarhb.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/ustarhb.F90	(revision 5267)
+++ 	(revision )
@@ -1,43 +1,0 @@
-
-! $Header$
-
-SUBROUTINE ustarhb(klon, klev, knon, u, v, cd_m, ustar)
-  IMPLICIT NONE
-  ! ======================================================================
-  ! Laurent Li (LMD/CNRS), le 30 septembre 1998
-  ! Couche limite non-locale. Adaptation du code du CCM3.
-  ! Code non teste, donc a ne pas utiliser.
-  ! ======================================================================
-  ! Nonlocal scheme that determines eddy diffusivities based on a
-  ! diagnosed boundary layer height and a turbulent velocity scale.
-  ! Also countergradient effects for heat and moisture are included.
-
-  ! For more information, see Holtslag, A.A.M., and B.A. Boville, 1993:
-  ! Local versus nonlocal boundary-layer diffusion in a global climate
-  ! model. J. of Climate, vol. 6, 1825-1842.
-  ! ======================================================================
-
-  ! Arguments:
-
-  INTEGER, INTENT(IN) :: klon, klev, knon ! nombre de points a calculer
-  REAL, DIMENSION(klon, klev), INTENT(IN) :: u,v ! vent horizontal (m/s)
-  REAL, DIMENSION(klon), INTENT(IN) :: cd_m ! coefficient de friction au sol pour vitesse
-  REAL, DIMENSION(klon), INTENT(OUT) :: ustar
-
-  INTEGER :: i, k
-  REAL :: zxt, zxq, zxu, zxv, zxmod, taux, tauy
-  REAL :: zx_alf1, zx_alf2 ! parametres pour extrapolation
-
-  DO i = 1, knon
-    zx_alf1 = 1.0
-    zx_alf2 = 1.0 - zx_alf1
-    zxu = u(i, 1)*zx_alf1 + u(i, 2)*zx_alf2
-    zxv = v(i, 1)*zx_alf1 + v(i, 2)*zx_alf2
-    zxmod = 1.0 + sqrt(zxu**2+zxv**2)
-    taux = zxu*zxmod*cd_m(i)
-    tauy = zxv*zxmod*cd_m(i)
-    ustar(i) = sqrt(taux**2+tauy**2)
-  END DO
-
-  RETURN
-END SUBROUTINE ustarhb
Index: /LMDZ6/trunk/libf/phylmd/ustarhb.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/ustarhb.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/ustarhb.f90	(revision 5268)
@@ -0,0 +1,43 @@
+
+! $Header$
+
+SUBROUTINE ustarhb(klon, klev, knon, u, v, cd_m, ustar)
+  IMPLICIT NONE
+  ! ======================================================================
+  ! Laurent Li (LMD/CNRS), le 30 septembre 1998
+  ! Couche limite non-locale. Adaptation du code du CCM3.
+  ! Code non teste, donc a ne pas utiliser.
+  ! ======================================================================
+  ! Nonlocal scheme that determines eddy diffusivities based on a
+  ! diagnosed boundary layer height and a turbulent velocity scale.
+  ! Also countergradient effects for heat and moisture are included.
+
+  ! For more information, see Holtslag, A.A.M., and B.A. Boville, 1993:
+  ! Local versus nonlocal boundary-layer diffusion in a global climate
+  ! model. J. of Climate, vol. 6, 1825-1842.
+  ! ======================================================================
+
+  ! Arguments:
+
+  INTEGER, INTENT(IN) :: klon, klev, knon ! nombre de points a calculer
+  REAL, DIMENSION(klon, klev), INTENT(IN) :: u,v ! vent horizontal (m/s)
+  REAL, DIMENSION(klon), INTENT(IN) :: cd_m ! coefficient de friction au sol pour vitesse
+  REAL, DIMENSION(klon), INTENT(OUT) :: ustar
+
+  INTEGER :: i, k
+  REAL :: zxt, zxq, zxu, zxv, zxmod, taux, tauy
+  REAL :: zx_alf1, zx_alf2 ! parametres pour extrapolation
+
+  DO i = 1, knon
+    zx_alf1 = 1.0
+    zx_alf2 = 1.0 - zx_alf1
+    zxu = u(i, 1)*zx_alf1 + u(i, 2)*zx_alf2
+    zxv = v(i, 1)*zx_alf1 + v(i, 2)*zx_alf2
+    zxmod = 1.0 + sqrt(zxu**2+zxv**2)
+    taux = zxu*zxmod*cd_m(i)
+    tauy = zxv*zxmod*cd_m(i)
+    ustar(i) = sqrt(taux**2+tauy**2)
+  END DO
+
+  RETURN
+END SUBROUTINE ustarhb
Index: DZ6/trunk/libf/phylmd/vdif_kcay.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/vdif_kcay.F90	(revision 5267)
+++ 	(revision )
@@ -1,674 +1,0 @@
-
-! $Header$
-
-SUBROUTINE vdif_kcay(klon,klev,ngrid,dt, g, rconst, plev, temp, zlev, zlay, u, v, &
-    teta, cd, q2, q2diag, km, kn, ustar, l_mix)
-
-  IMPLICIT NONE
-
-  ! dt : pas de temps
-  ! g  : g
-  ! zlev : altitude a chaque niveau (interface inferieure de la couche
-  ! de meme indice)
-  ! zlay : altitude au centre de chaque couche
-  ! u,v : vitesse au centre de chaque couche
-  ! (en entree : la valeur au debut du pas de temps)
-  ! teta : temperature potentielle au centre de chaque couche
-  ! (en entree : la valeur au debut du pas de temps)
-  ! cd : cdrag
-  ! (en entree : la valeur au debut du pas de temps)
-  ! q2 : $q^2$ au bas de chaque couche
-  ! (en entree : la valeur au debut du pas de temps)
-  ! (en sortie : la valeur a la fin du pas de temps)
-  ! km : diffusivite turbulente de quantite de mouvement (au bas de chaque
-  ! couche)
-  ! (en sortie : la valeur a la fin du pas de temps)
-  ! kn : diffusivite turbulente des scalaires (au bas de chaque couche)
-  ! (en sortie : la valeur a la fin du pas de temps)
-
-  ! .......................................................................
-  INTEGER, INTENT(IN) :: klon,klev,ngrid
-  REAL,INTENT(IN) :: dt, g, rconst
-  REAL,DIMENSION(klon,klev+1),INTENT(IN) :: plev
-  REAL,DIMENSION(klon,klev),INTENT(IN) :: temp
-  REAL,DIMENSION(klon),INTENT(IN) :: ustar
-  REAL,DIMENSION(klon,klev+1),INTENT(INOUT) :: zlev
-  REAL,DIMENSION(klon,klev),INTENT(IN) :: zlay
-  REAL,DIMENSION(klon,klev),INTENT(IN) :: u
-  REAL,DIMENSION(klon,klev),INTENT(IN) :: v
-  REAL,DIMENSION(klon,klev),INTENT(IN) :: teta
-  REAL,DIMENSION(klon),INTENT(IN) :: cd
-  REAL,DIMENSION(klon,klev+1),INTENT(INOUT) :: q2
-  REAL,DIMENSION(klon,klev+1),INTENT(OUT) :: q2diag
-  REAL,DIMENSION(klon,klev+1),INTENT(OUT) :: km
-  REAL,DIMENSION(klon,klev+1),INTENT(OUT) :: kn
-  INTEGER, INTENT(OUT) :: l_mix
-
-  REAL,DIMENSION(klon) :: sq, sqz, long0
-  REAL,DIMENSION(klon,klev+1) :: q2s,zz
-  REAL :: snstable,zq
-
-  INTEGER :: iii
-  ! .......................................................................
-
-  ! nlay : nombre de couches
-  ! nlev : nombre de niveaux
-  ! ngrid : nombre de points de grille
-  ! unsdz : 1 sur l'epaisseur de couche
-  ! unsdzdec : 1 sur la distance entre le centre de la couche et le
-  ! centre de la couche inferieure
-  ! q : echelle de vitesse au bas de chaque couche
-  ! (valeur a la fin du pas de temps)
-
-  ! .......................................................................
-  INTEGER :: nlay, nlev
-  REAL, DIMENSION(klon,klev) :: unsdz
-  REAL, DIMENSION(klon, klev+1) :: unsdzdec,q
-
-  ! .......................................................................
-
-  ! kmpre : km au debut du pas de temps
-  ! qcstat : q : solution stationnaire du probleme couple
-  ! (valeur a la fin du pas de temps)
-  ! q2cstat : q2 : solution stationnaire du probleme couple
-  ! (valeur a la fin du pas de temps)
-
-  ! .......................................................................
-  REAL, DIMENSION(klon, klev+1) :: kmpre
-  REAL :: qcstat
-  REAL :: q2cstat
-  REAL :: sss, sssq
-  ! .......................................................................
-
-  ! long : longueur de melange calculee selon Blackadar
-
-  ! .......................................................................
-  REAL, DIMENSION(klon, klev+1) :: long
-  ! .......................................................................
-
-  ! kmq3 : terme en q^3 dans le developpement de km
-  ! (valeur au debut du pas de temps)
-  ! kmcstat : valeur de km solution stationnaire du systeme {q2 ; du/dz}
-  ! (valeur a la fin du pas de temps)
-  ! knq3 : terme en q^3 dans le developpement de kn
-  ! mcstat : valeur de m solution stationnaire du systeme {q2 ; du/dz}
-  ! (valeur a la fin du pas de temps)
-  ! m2cstat : valeur de m2 solution stationnaire du systeme {q2 ; du/dz}
-  ! (valeur a la fin du pas de temps)
-  ! m : valeur a la fin du pas de temps
-  ! mpre : valeur au debut du pas de temps
-  ! m2 : valeur a la fin du pas de temps
-  ! n2 : valeur a la fin du pas de temps
-
-  ! .......................................................................
-  REAL :: kmq3
-  REAL :: kmcstat
-  REAL :: knq3
-  REAL :: mcstat
-  REAL :: m2cstat
-  REAL, DIMENSION(klon, klev+1) :: m,mpre,m2,n2
-  ! .......................................................................
-
-  ! gn : intermediaire pour les coefficients de stabilite
-  ! gnmin : borne inferieure de gn (-0.23 ou -0.28)
-  ! gnmax : borne superieure de gn (0.0233)
-  ! gninf : vrai si gn est en dessous de sa borne inferieure
-  ! gnsup : vrai si gn est en dessus de sa borne superieure
-  ! gm : drole d'objet bien utile
-  ! ri : nombre de Richardson
-  ! sn : coefficient de stabilite pour n
-  ! snq2 : premier terme du developement limite de sn en q2
-  ! sm : coefficient de stabilite pour m
-  ! smq2 : premier terme du developement limite de sm en q2
-
-  ! .......................................................................
-  REAL :: gn,gm
-  REAL :: gnmin
-  REAL :: gnmax
-  LOGICAL :: gninf
-  LOGICAL :: gnsup
-  REAL, DIMENSION(klon, klev+1) :: sn, snq2, sm, smq2
-  ! .......................................................................
-
-  ! kappa : consatnte de Von Karman (0.4)
-  ! long00 : longueur de reference pour le calcul de long (160)
-  ! a1,a2,b1,b2,c1 : constantes d'origine pour les  coefficients
-  ! de stabilite (0.92/0.74/16.6/10.1/0.08)
-  ! cn1,cn2 : constantes pour sn
-  ! cm1,cm2,cm3,cm4 : constantes pour sm
-
-  ! .......................................................................
-  REAL :: kappa
-  REAL :: long00
-  REAL :: a1, a2, b1, b2, c1
-  REAL :: cn1, cn2
-  REAL :: cm1, cm2, cm3, cm4
-  ! .......................................................................
-
-  ! termq : termes en $q$ dans l'equation de q2
-  ! termq3 : termes en $q^3$ dans l'equation de q2
-  ! termqm2 : termes en $q*m^2$ dans l'equation de q2
-  ! termq3m2 : termes en $q^3*m^2$ dans l'equation de q2
-
-  ! .......................................................................
-  REAL :: termq
-  REAL :: termq3
-  REAL :: termqm2
-  REAL :: termq3m2
-  ! .......................................................................
-
-  ! q2min : borne inferieure de q2
-  ! q2max : borne superieure de q2
-
-  ! .......................................................................
-  REAL :: q2min
-  REAL :: q2max
-  ! .......................................................................
-  ! knmin : borne inferieure de kn
-  ! kmmin : borne inferieure de km
-  ! .......................................................................
-  REAL :: knmin
-  REAL :: kmmin
-  ! .......................................................................
-  INTEGER :: ilay, ilev, igrid
-  REAL :: tmp1, tmp2
-  ! .......................................................................
-  PARAMETER (kappa=0.4E+0)
-  PARAMETER (long00=160.E+0)
-  ! PARAMETER (gnmin=-10.E+0)
-  PARAMETER (gnmin=-0.28)
-  PARAMETER (gnmax=0.0233E+0)
-  PARAMETER (a1=0.92E+0)
-  PARAMETER (a2=0.74E+0)
-  PARAMETER (b1=16.6E+0)
-  PARAMETER (b2=10.1E+0)
-  PARAMETER (c1=0.08E+0)
-  PARAMETER (knmin=1.E-5)
-  PARAMETER (kmmin=1.E-5)
-  PARAMETER (q2min=1.E-5)
-  PARAMETER (q2max=1.E+2)
-  ! ym      PARAMETER (nlay=klev)
-  ! ym      PARAMETER (nlev=klev+1)
-
-  PARAMETER (cn1=a2*(1.E+0-6.E+0*a1/b1))
-  PARAMETER (cn2=-3.E+0*a2*(6.E+0*a1+b2))
-  PARAMETER (cm1=a1*(1.E+0-3.E+0*c1-6.E+0*a1/b1))
-  PARAMETER (cm2=a1*(-3.E+0*a2*((b2-3.E+0*a2)*(1.E+0-6.E+0*a1/b1)- &
-    3.E+0*c1*(b2+6.E+0*a1))))
-  PARAMETER (cm3=-3.E+0*a2*(6.E+0*a1+b2))
-  PARAMETER (cm4=-9.E+0*a1*a2)
-
-  LOGICAL :: first
-!  SAVE first
-!  DATA first/.TRUE./
-!  !$OMP THREADPRIVATE(first)
-  ! .......................................................................
-  ! traitment des valeur de q2 en entree
-  ! .......................................................................
-
-  ! Initialisation de q2
-  nlay = klev
-  nlev = klev + 1
-
-! Initialisation avec un schema d'equilibre
-! CALL yamada(ngrid, dt, g, rconst, plev, temp, zlev, zlay, u, v, teta, cd, &
-!   q2diag, km, kn, ustar, l_mix)
-! IF (first .AND. 1==1) THEN
-!   first = .FALSE.
-!   q2 = q2diag
-! END IF
-q2diag=0.
-
-  DO ilev = 2, nlay
-    DO igrid = 1, ngrid
-      q2(igrid, ilev) = amax1(q2(igrid,ilev), q2min)
-      q(igrid, ilev) = sqrt(q2(igrid,ilev))
-    END DO
-  END DO
-
-  DO igrid = 1, ngrid
-    tmp1 = cd(igrid)*(u(igrid,1)**2+v(igrid,1)**2)
-    q2(igrid, 1) = b1**(2.E+0/3.E+0)*tmp1
-    q2(igrid, 1) = amax1(q2(igrid,1), q2min)
-    q(igrid, 1) = sqrt(q2(igrid,1))
-  END DO
-
-  ! .......................................................................
-  ! les increments verticaux
-  ! .......................................................................
-
-  ! !!!!! allerte !!!!!c
-  ! !!!!! zlev n'est pas declare a nlev !!!!!c
-  ! !!!!! ---->
-  DO igrid = 1, ngrid
-    zlev(igrid, nlev) = zlay(igrid, nlay) + (zlay(igrid,nlay)-zlev(igrid,nlev &
-      -1))
-  END DO
-  ! !!!!! <----
-  ! !!!!! allerte !!!!!c
-
-  DO ilay = 1, nlay
-    DO igrid = 1, ngrid
-      unsdz(igrid, ilay) = 1.E+0/(zlev(igrid,ilay+1)-zlev(igrid,ilay))
-    END DO
-  END DO
-  DO igrid = 1, ngrid
-    unsdzdec(igrid, 1) = 1.E+0/(zlay(igrid,1)-zlev(igrid,1))
-  END DO
-  DO ilay = 2, nlay
-    DO igrid = 1, ngrid
-      unsdzdec(igrid, ilay) = 1.E+0/(zlay(igrid,ilay)-zlay(igrid,ilay-1))
-    END DO
-  END DO
-  DO igrid = 1, ngrid
-    unsdzdec(igrid, nlay+1) = 1.E+0/(zlev(igrid,nlay+1)-zlay(igrid,nlay))
-  END DO
-
-  ! .......................................................................
-  ! le cisaillement et le gradient de temperature
-  ! .......................................................................
-
-  DO igrid = 1, ngrid
-    m2(igrid, 1) = (unsdzdec(igrid,1)*u(igrid,1))**2 + &
-      (unsdzdec(igrid,1)*v(igrid,1))**2
-    m(igrid, 1) = sqrt(m2(igrid,1))
-    mpre(igrid, 1) = m(igrid, 1)
-  END DO
-
-  ! -----------------------------------------------------------------------
-  DO ilev = 2, nlev - 1
-    DO igrid = 1, ngrid
-      ! -----------------------------------------------------------------------
-
-      n2(igrid, ilev) = g*unsdzdec(igrid, ilev)*(teta(igrid,ilev)-teta(igrid, &
-        ilev-1))/(teta(igrid,ilev)+teta(igrid,ilev-1))*2.E+0
-      ! n2(igrid,ilev)=0.
-
-      ! --->
-      ! on ne sais traiter que les cas stratifies. et l'ajustement
-      ! convectif est cense faire en sorte que seul des configurations
-      ! stratifiees soient rencontrees en entree de cette routine.
-      ! mais, bon ... on sait jamais (meme on sait que n2 prends
-      ! quelques valeurs negatives ... parfois) alors :
-      ! <---
-
-      IF (n2(igrid,ilev)<0.E+0) THEN
-        n2(igrid, ilev) = 0.E+0
-      END IF
-
-      m2(igrid, ilev) = (unsdzdec(igrid,ilev)*(u(igrid,ilev)-u(igrid, &
-        ilev-1)))**2 + (unsdzdec(igrid,ilev)*(v(igrid,ilev)-v(igrid, &
-        ilev-1)))**2
-      m(igrid, ilev) = sqrt(m2(igrid,ilev))
-      mpre(igrid, ilev) = m(igrid, ilev)
-
-      ! -----------------------------------------------------------------------
-    END DO
-  END DO
-  ! -----------------------------------------------------------------------
-
-  DO igrid = 1, ngrid
-    m2(igrid, nlev) = m2(igrid, nlev-1)
-    m(igrid, nlev) = m(igrid, nlev-1)
-    mpre(igrid, nlev) = m(igrid, nlev)
-  END DO
-
-  ! .......................................................................
-  ! calcul des fonctions de stabilite
-  ! .......................................................................
-
-  IF (l_mix==4) THEN
-    DO igrid = 1, ngrid
-      sqz(igrid) = 1.E-10
-      sq(igrid) = 1.E-10
-    END DO
-    DO ilev = 2, nlev - 1
-      DO igrid = 1, ngrid
-        zq = sqrt(q2(igrid,ilev))
-        sqz(igrid) = sqz(igrid) + zq*zlev(igrid, ilev)*(zlay(igrid,ilev)-zlay &
-          (igrid,ilev-1))
-        sq(igrid) = sq(igrid) + zq*(zlay(igrid,ilev)-zlay(igrid,ilev-1))
-      END DO
-    END DO
-    DO igrid = 1, ngrid
-      long0(igrid) = 0.2*sqz(igrid)/sq(igrid)
-    END DO
-  ELSE IF (l_mix==3) THEN
-    long0(igrid) = long00
-  END IF
-
-  ! (abd 5 2)      print*,'LONG0=',long0
-
-  ! -----------------------------------------------------------------------
-  DO ilev = 2, nlev - 1
-    DO igrid = 1, ngrid
-      ! -----------------------------------------------------------------------
-
-      tmp1 = kappa*(zlev(igrid,ilev)-zlev(igrid,1))
-      IF (l_mix>=10) THEN
-        long(igrid, ilev) = l_mix
-      ELSE
-        long(igrid, ilev) = tmp1/(1.E+0+tmp1/long0(igrid))
-      END IF
-      long(igrid, ilev) = max(min(long(igrid,ilev),0.5*sqrt(q2(igrid,ilev))/ &
-        sqrt(max(n2(igrid,ilev),1.E-10))), 5.)
-
-      gn = -long(igrid, ilev)**2/q2(igrid, ilev)*n2(igrid, ilev)
-      gm = long(igrid, ilev)**2/q2(igrid, ilev)*m2(igrid, ilev)
-
-      gninf = .FALSE.
-      gnsup = .FALSE.
-
-      IF (gn<gnmin) THEN
-        gninf = .TRUE.
-        gn = gnmin
-      END IF
-
-      IF (gn>gnmax) THEN
-        gnsup = .TRUE.
-        gn = gnmax
-      END IF
-
-      sn(igrid, ilev) = cn1/(1.E+0+cn2*gn)
-      sm(igrid, ilev) = (cm1+cm2*gn)/((1.E+0+cm3*gn)*(1.E+0+cm4*gn))
-
-      IF ((gninf) .OR. (gnsup)) THEN
-        snq2(igrid, ilev) = 0.E+0
-        smq2(igrid, ilev) = 0.E+0
-      ELSE
-        snq2(igrid, ilev) = -gn*(-cn1*cn2/(1.E+0+cn2*gn)**2)
-        smq2(igrid, ilev) = -gn*(cm2*(1.E+0+cm3*gn)*(1.E+0+cm4*gn)-(cm3*( &
-          1.E+0+cm4*gn)+cm4*(1.E+0+cm3*gn))*(cm1+cm2*gn))/((1.E+0+cm3*gn)*( &
-          1.E+0+cm4*gn))**2
-      END IF
-
-      ! abd
-      ! if(ilev.le.57.and.ilev.ge.37) then
-      ! print*,'L=',ilev,'   GN=',gn,'  SM=',sm(igrid,ilev)
-      ! endif
-      ! --->
-      ! la decomposition de Taylor en q2 n'a de sens que
-      ! dans les cas stratifies ou sn et sm sont quasi
-      ! proportionnels a q2. ailleurs on laisse le meme
-      ! algorithme car l'ajustement convectif fait le travail.
-      ! mais c'est delirant quand sn et snq2 n'ont pas le meme
-      ! signe : dans ces cas, on ne fait pas la decomposition.
-      ! <---
-
-      IF (snq2(igrid,ilev)*sn(igrid,ilev)<=0.E+0) snq2(igrid, ilev) = 0.E+0
-      IF (smq2(igrid,ilev)*sm(igrid,ilev)<=0.E+0) smq2(igrid, ilev) = 0.E+0
-
-      ! Correction pour les couches stables.
-      ! Schema repris de JHoltzlag Boville, lui meme venant de...
-
-      IF (1==1) THEN
-        snstable = 1. - zlev(igrid, ilev)/(700.*max(ustar(igrid),0.0001))
-        snstable = 1. - zlev(igrid, ilev)/400.
-        snstable = max(snstable, 0.)
-        snstable = snstable*snstable
-
-        ! abde       print*,'SN ',ilev,sn(1,ilev),snstable
-        IF (sn(igrid,ilev)<snstable) THEN
-          sn(igrid, ilev) = snstable
-          snq2(igrid, ilev) = 0.
-        END IF
-
-        IF (sm(igrid,ilev)<snstable) THEN
-          sm(igrid, ilev) = snstable
-          smq2(igrid, ilev) = 0.
-        END IF
-
-      END IF
-
-      ! sn : coefficient de stabilite pour n
-      ! snq2 : premier terme du developement limite de sn en q2
-      ! -----------------------------------------------------------------------
-    END DO
-  END DO
-  ! -----------------------------------------------------------------------
-
-  ! .......................................................................
-  ! calcul de km et kn au debut du pas de temps
-  ! .......................................................................
-
-  DO igrid = 1, ngrid
-    kn(igrid, 1) = knmin
-    km(igrid, 1) = kmmin
-    kmpre(igrid, 1) = km(igrid, 1)
-  END DO
-
-  ! -----------------------------------------------------------------------
-  DO ilev = 2, nlev - 1
-    DO igrid = 1, ngrid
-      ! -----------------------------------------------------------------------
-
-      kn(igrid, ilev) = long(igrid, ilev)*q(igrid, ilev)*sn(igrid, ilev)
-      km(igrid, ilev) = long(igrid, ilev)*q(igrid, ilev)*sm(igrid, ilev)
-      kmpre(igrid, ilev) = km(igrid, ilev)
-
-      ! -----------------------------------------------------------------------
-    END DO
-  END DO
-  ! -----------------------------------------------------------------------
-
-  DO igrid = 1, ngrid
-    kn(igrid, nlev) = kn(igrid, nlev-1)
-    km(igrid, nlev) = km(igrid, nlev-1)
-    kmpre(igrid, nlev) = km(igrid, nlev)
-  END DO
-
-  ! .......................................................................
-  ! boucle sur les niveaux 2 a nlev-1
-  ! .......................................................................
-
-  ! ---->
-  DO ilev = 2, nlev - 1
-    ! ---->
-    DO igrid = 1, ngrid
-
-      ! .......................................................................
-
-      ! calcul des termes sources et puits de l'equation de q2
-      ! ------------------------------------------------------
-
-      knq3 = kn(igrid, ilev)*snq2(igrid, ilev)/sn(igrid, ilev)
-      kmq3 = km(igrid, ilev)*smq2(igrid, ilev)/sm(igrid, ilev)
-
-      termq = 0.E+0
-      termq3 = 0.E+0
-      termqm2 = 0.E+0
-      termq3m2 = 0.E+0
-
-      tmp1 = dt*2.E+0*km(igrid, ilev)*m2(igrid, ilev)
-      tmp2 = dt*2.E+0*kmq3*m2(igrid, ilev)
-      termqm2 = termqm2 + dt*2.E+0*km(igrid, ilev)*m2(igrid, ilev) - &
-        dt*2.E+0*kmq3*m2(igrid, ilev)
-      termq3m2 = termq3m2 + dt*2.E+0*kmq3*m2(igrid, ilev)
-
-      termq = termq - dt*2.E+0*kn(igrid, ilev)*n2(igrid, ilev) + &
-        dt*2.E+0*knq3*n2(igrid, ilev)
-      termq3 = termq3 - dt*2.E+0*knq3*n2(igrid, ilev)
-
-      termq3 = termq3 - dt*2.E+0*q(igrid, ilev)**3/(b1*long(igrid,ilev))
-
-      ! .......................................................................
-
-      ! resolution stationnaire couplee avec le gradient de vitesse local
-      ! -----------------------------------------------------------------
-
-      ! -----{on cherche le cisaillement qui annule l'equation de q^2
-      ! supposee en q3}
-
-      tmp1 = termq + termq3
-      tmp2 = termqm2 + termq3m2
-      m2cstat = m2(igrid, ilev) - (tmp1+tmp2)/(dt*2.E+0*km(igrid,ilev))
-      mcstat = sqrt(m2cstat)
-
-      ! abde      print*,'M2 L=',ilev,mpre(igrid,ilev),mcstat
-
-      ! -----{puis on ecrit la valeur de q qui annule l'equation de m
-      ! supposee en q3}
-
-      IF (ilev==2) THEN
-        kmcstat = 1.E+0/mcstat*(unsdz(igrid,ilev)*kmpre(igrid,ilev+1)*mpre( &
-          igrid,ilev+1)+unsdz(igrid,ilev-1)*cd(igrid)*(sqrt(u(igrid,3)**2+ &
-          v(igrid,3)**2)-mcstat/unsdzdec(igrid,ilev)-mpre(igrid, &
-          ilev+1)/unsdzdec(igrid,ilev+1))**2)/(unsdz(igrid,ilev)+unsdz(igrid, &
-          ilev-1))
-      ELSE
-        kmcstat = 1.E+0/mcstat*(unsdz(igrid,ilev)*kmpre(igrid,ilev+1)*mpre( &
-          igrid,ilev+1)+unsdz(igrid,ilev-1)*kmpre(igrid,ilev-1)*mpre(igrid, &
-          ilev-1))/(unsdz(igrid,ilev)+unsdz(igrid,ilev-1))
-      END IF
-      tmp2 = kmcstat/(sm(igrid,ilev)/q2(igrid,ilev))/long(igrid, ilev)
-      qcstat = tmp2**(1.E+0/3.E+0)
-      q2cstat = qcstat**2
-
-      ! .......................................................................
-
-      ! choix de la solution finale
-      ! ---------------------------
-
-      q(igrid, ilev) = qcstat
-      q2(igrid, ilev) = q2cstat
-      m(igrid, ilev) = mcstat
-      ! abd       if(ilev.le.57.and.ilev.ge.37) then
-      ! print*,'L=',ilev,'   M2=',m2(igrid,ilev),m2cstat,
-      ! s     'N2=',n2(igrid,ilev)
-      ! abd       endif
-      m2(igrid, ilev) = m2cstat
-
-      ! --->
-      ! pour des raisons simples q2 est minore
-      ! <---
-
-      IF (q2(igrid,ilev)<q2min) THEN
-        q2(igrid, ilev) = q2min
-        q(igrid, ilev) = sqrt(q2min)
-      END IF
-
-      ! .......................................................................
-
-      ! calcul final de kn et km
-      ! ------------------------
-
-      gn = -long(igrid, ilev)**2/q2(igrid, ilev)*n2(igrid, ilev)
-      IF (gn<gnmin) gn = gnmin
-      IF (gn>gnmax) gn = gnmax
-      sn(igrid, ilev) = cn1/(1.E+0+cn2*gn)
-      sm(igrid, ilev) = (cm1+cm2*gn)/((1.E+0+cm3*gn)*(1.E+0+cm4*gn))
-      kn(igrid, ilev) = long(igrid, ilev)*q(igrid, ilev)*sn(igrid, ilev)
-      km(igrid, ilev) = long(igrid, ilev)*q(igrid, ilev)*sm(igrid, ilev)
-      ! abd
-      ! if(ilev.le.57.and.ilev.ge.37) then
-      ! print*,'L=',ilev,'   GN=',gn,'  SM=',sm(igrid,ilev)
-      ! endif
-
-      ! .......................................................................
-
-    END DO
-
-  END DO
-
-  ! .......................................................................
-
-
-  DO igrid = 1, ngrid
-    kn(igrid, 1) = knmin
-    km(igrid, 1) = kmmin
-    ! kn(igrid,1)=cd(igrid)
-    ! km(igrid,1)=cd(igrid)
-    q2(igrid, nlev) = q2(igrid, nlev-1)
-    q(igrid, nlev) = q(igrid, nlev-1)
-    kn(igrid, nlev) = kn(igrid, nlev-1)
-    km(igrid, nlev) = km(igrid, nlev-1)
-  END DO
-
-  ! CALCUL DE LA DIFFUSION VERTICALE DE Q2
-  IF (1==1) THEN
-
-    sss=0.
-    sssq=0.
-    ! WARNING : travail sur le point ig=1 ????
-    DO ilev = 2, klev - 1
-      sss = sss + plev(1, ilev-1) - plev(1, ilev+1)
-      sssq = sssq + (plev(1,ilev-1)-plev(1,ilev+1))*q2(1, ilev)
-    END DO
-    ! print*,'Q2moy avant',sssq/sss
-    ! print*,'Q2q20 ',(q2(1,ilev),ilev=1,10)
-    ! print*,'Q2km0 ',(km(1,ilev),ilev=1,10)
-    ! ! C'est quoi ca qu'etait dans l'original???
-    ! do igrid=1,ngrid
-    ! q2(igrid,1)=10.
-    ! enddo
-    ! q2s=q2
-    ! do iii=1,10
-    ! call vdif_q2(dt,g,rconst,plev,temp,km,q2)
-    ! do ilev=1,klev+1
-    ! write(iii+49,*) q2(1,ilev),zlev(1,ilev)
-    ! enddo
-    ! enddo
-    ! stop
-    ! do ilev=1,klev
-    ! print*,zlev(1,ilev),q2s(1,ilev),q2(1,ilev)
-    ! enddo
-    ! q2s=q2-q2s
-    ! do ilev=1,klev
-    ! print*,q2s(1,ilev),zlev(1,ilev)
-    ! enddo
-    DO ilev = 2, klev - 1
-      sss = sss + plev(1, ilev-1) - plev(1, ilev+1)
-      sssq = sssq + (plev(1,ilev-1)-plev(1,ilev+1))*q2(1, ilev)
-    END DO
-    PRINT *, 'Q2moy apres', sssq/sss
-
-
-    DO ilev = 2, klev-1
-      DO igrid = 1, ngrid
-        q2(igrid, ilev) = max(q2(igrid,ilev), q2min)
-        q(igrid, ilev) = sqrt(q2(igrid,ilev))
-
-        ! .......................................................................
-
-        ! calcul final de kn et km
-        ! ------------------------
-
-        gn = -long(igrid, ilev)**2/q2(igrid, ilev)*n2(igrid, ilev)
-        IF (gn<gnmin) gn = gnmin
-        IF (gn>gnmax) gn = gnmax
-        sn(igrid, ilev) = cn1/(1.E+0+cn2*gn)
-        sm(igrid, ilev) = (cm1+cm2*gn)/((1.E+0+cm3*gn)*(1.E+0+cm4*gn))
-        ! Correction pour les couches stables.
-        ! Schema repris de JHoltzlag Boville, lui meme venant de...
-
-        IF (1==1) THEN
-          snstable = 1. - zlev(igrid, ilev)/(700.*max(ustar(igrid),0.0001))
-          snstable = 1. - zlev(igrid, ilev)/400.
-          snstable = max(snstable, 0.)
-          snstable = snstable*snstable
-
-          ! abde      print*,'SN ',ilev,sn(1,ilev),snstable
-          IF (sn(igrid,ilev)<snstable) THEN
-            sn(igrid, ilev) = snstable
-            snq2(igrid, ilev) = 0.
-          END IF
-
-          IF (sm(igrid,ilev)<snstable) THEN
-            sm(igrid, ilev) = snstable
-            smq2(igrid, ilev) = 0.
-          END IF
-
-        END IF
-
-        ! sn : coefficient de stabilite pour n
-        kn(igrid, ilev) = long(igrid, ilev)*q(igrid, ilev)*sn(igrid, ilev)
-        km(igrid, ilev) = long(igrid, ilev)*q(igrid, ilev)
-
-      END DO
-    END DO
-    ! print*,'Q2km1 ',(km(1,ilev),ilev=1,10)
-
-  END IF
-
-  RETURN
-END SUBROUTINE vdif_kcay
Index: /LMDZ6/trunk/libf/phylmd/vdif_kcay.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/vdif_kcay.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/vdif_kcay.f90	(revision 5268)
@@ -0,0 +1,674 @@
+
+! $Header$
+
+SUBROUTINE vdif_kcay(klon,klev,ngrid,dt, g, rconst, plev, temp, zlev, zlay, u, v, &
+    teta, cd, q2, q2diag, km, kn, ustar, l_mix)
+
+  IMPLICIT NONE
+
+  ! dt : pas de temps
+  ! g  : g
+  ! zlev : altitude a chaque niveau (interface inferieure de la couche
+  ! de meme indice)
+  ! zlay : altitude au centre de chaque couche
+  ! u,v : vitesse au centre de chaque couche
+  ! (en entree : la valeur au debut du pas de temps)
+  ! teta : temperature potentielle au centre de chaque couche
+  ! (en entree : la valeur au debut du pas de temps)
+  ! cd : cdrag
+  ! (en entree : la valeur au debut du pas de temps)
+  ! q2 : $q^2$ au bas de chaque couche
+  ! (en entree : la valeur au debut du pas de temps)
+  ! (en sortie : la valeur a la fin du pas de temps)
+  ! km : diffusivite turbulente de quantite de mouvement (au bas de chaque
+  ! couche)
+  ! (en sortie : la valeur a la fin du pas de temps)
+  ! kn : diffusivite turbulente des scalaires (au bas de chaque couche)
+  ! (en sortie : la valeur a la fin du pas de temps)
+
+  ! .......................................................................
+  INTEGER, INTENT(IN) :: klon,klev,ngrid
+  REAL,INTENT(IN) :: dt, g, rconst
+  REAL,DIMENSION(klon,klev+1),INTENT(IN) :: plev
+  REAL,DIMENSION(klon,klev),INTENT(IN) :: temp
+  REAL,DIMENSION(klon),INTENT(IN) :: ustar
+  REAL,DIMENSION(klon,klev+1),INTENT(INOUT) :: zlev
+  REAL,DIMENSION(klon,klev),INTENT(IN) :: zlay
+  REAL,DIMENSION(klon,klev),INTENT(IN) :: u
+  REAL,DIMENSION(klon,klev),INTENT(IN) :: v
+  REAL,DIMENSION(klon,klev),INTENT(IN) :: teta
+  REAL,DIMENSION(klon),INTENT(IN) :: cd
+  REAL,DIMENSION(klon,klev+1),INTENT(INOUT) :: q2
+  REAL,DIMENSION(klon,klev+1),INTENT(OUT) :: q2diag
+  REAL,DIMENSION(klon,klev+1),INTENT(OUT) :: km
+  REAL,DIMENSION(klon,klev+1),INTENT(OUT) :: kn
+  INTEGER, INTENT(OUT) :: l_mix
+
+  REAL,DIMENSION(klon) :: sq, sqz, long0
+  REAL,DIMENSION(klon,klev+1) :: q2s,zz
+  REAL :: snstable,zq
+
+  INTEGER :: iii
+  ! .......................................................................
+
+  ! nlay : nombre de couches
+  ! nlev : nombre de niveaux
+  ! ngrid : nombre de points de grille
+  ! unsdz : 1 sur l'epaisseur de couche
+  ! unsdzdec : 1 sur la distance entre le centre de la couche et le
+  ! centre de la couche inferieure
+  ! q : echelle de vitesse au bas de chaque couche
+  ! (valeur a la fin du pas de temps)
+
+  ! .......................................................................
+  INTEGER :: nlay, nlev
+  REAL, DIMENSION(klon,klev) :: unsdz
+  REAL, DIMENSION(klon, klev+1) :: unsdzdec,q
+
+  ! .......................................................................
+
+  ! kmpre : km au debut du pas de temps
+  ! qcstat : q : solution stationnaire du probleme couple
+  ! (valeur a la fin du pas de temps)
+  ! q2cstat : q2 : solution stationnaire du probleme couple
+  ! (valeur a la fin du pas de temps)
+
+  ! .......................................................................
+  REAL, DIMENSION(klon, klev+1) :: kmpre
+  REAL :: qcstat
+  REAL :: q2cstat
+  REAL :: sss, sssq
+  ! .......................................................................
+
+  ! long : longueur de melange calculee selon Blackadar
+
+  ! .......................................................................
+  REAL, DIMENSION(klon, klev+1) :: long
+  ! .......................................................................
+
+  ! kmq3 : terme en q^3 dans le developpement de km
+  ! (valeur au debut du pas de temps)
+  ! kmcstat : valeur de km solution stationnaire du systeme {q2 ; du/dz}
+  ! (valeur a la fin du pas de temps)
+  ! knq3 : terme en q^3 dans le developpement de kn
+  ! mcstat : valeur de m solution stationnaire du systeme {q2 ; du/dz}
+  ! (valeur a la fin du pas de temps)
+  ! m2cstat : valeur de m2 solution stationnaire du systeme {q2 ; du/dz}
+  ! (valeur a la fin du pas de temps)
+  ! m : valeur a la fin du pas de temps
+  ! mpre : valeur au debut du pas de temps
+  ! m2 : valeur a la fin du pas de temps
+  ! n2 : valeur a la fin du pas de temps
+
+  ! .......................................................................
+  REAL :: kmq3
+  REAL :: kmcstat
+  REAL :: knq3
+  REAL :: mcstat
+  REAL :: m2cstat
+  REAL, DIMENSION(klon, klev+1) :: m,mpre,m2,n2
+  ! .......................................................................
+
+  ! gn : intermediaire pour les coefficients de stabilite
+  ! gnmin : borne inferieure de gn (-0.23 ou -0.28)
+  ! gnmax : borne superieure de gn (0.0233)
+  ! gninf : vrai si gn est en dessous de sa borne inferieure
+  ! gnsup : vrai si gn est en dessus de sa borne superieure
+  ! gm : drole d'objet bien utile
+  ! ri : nombre de Richardson
+  ! sn : coefficient de stabilite pour n
+  ! snq2 : premier terme du developement limite de sn en q2
+  ! sm : coefficient de stabilite pour m
+  ! smq2 : premier terme du developement limite de sm en q2
+
+  ! .......................................................................
+  REAL :: gn,gm
+  REAL :: gnmin
+  REAL :: gnmax
+  LOGICAL :: gninf
+  LOGICAL :: gnsup
+  REAL, DIMENSION(klon, klev+1) :: sn, snq2, sm, smq2
+  ! .......................................................................
+
+  ! kappa : consatnte de Von Karman (0.4)
+  ! long00 : longueur de reference pour le calcul de long (160)
+  ! a1,a2,b1,b2,c1 : constantes d'origine pour les  coefficients
+  ! de stabilite (0.92/0.74/16.6/10.1/0.08)
+  ! cn1,cn2 : constantes pour sn
+  ! cm1,cm2,cm3,cm4 : constantes pour sm
+
+  ! .......................................................................
+  REAL :: kappa
+  REAL :: long00
+  REAL :: a1, a2, b1, b2, c1
+  REAL :: cn1, cn2
+  REAL :: cm1, cm2, cm3, cm4
+  ! .......................................................................
+
+  ! termq : termes en $q$ dans l'equation de q2
+  ! termq3 : termes en $q^3$ dans l'equation de q2
+  ! termqm2 : termes en $q*m^2$ dans l'equation de q2
+  ! termq3m2 : termes en $q^3*m^2$ dans l'equation de q2
+
+  ! .......................................................................
+  REAL :: termq
+  REAL :: termq3
+  REAL :: termqm2
+  REAL :: termq3m2
+  ! .......................................................................
+
+  ! q2min : borne inferieure de q2
+  ! q2max : borne superieure de q2
+
+  ! .......................................................................
+  REAL :: q2min
+  REAL :: q2max
+  ! .......................................................................
+  ! knmin : borne inferieure de kn
+  ! kmmin : borne inferieure de km
+  ! .......................................................................
+  REAL :: knmin
+  REAL :: kmmin
+  ! .......................................................................
+  INTEGER :: ilay, ilev, igrid
+  REAL :: tmp1, tmp2
+  ! .......................................................................
+  PARAMETER (kappa=0.4E+0)
+  PARAMETER (long00=160.E+0)
+  ! PARAMETER (gnmin=-10.E+0)
+  PARAMETER (gnmin=-0.28)
+  PARAMETER (gnmax=0.0233E+0)
+  PARAMETER (a1=0.92E+0)
+  PARAMETER (a2=0.74E+0)
+  PARAMETER (b1=16.6E+0)
+  PARAMETER (b2=10.1E+0)
+  PARAMETER (c1=0.08E+0)
+  PARAMETER (knmin=1.E-5)
+  PARAMETER (kmmin=1.E-5)
+  PARAMETER (q2min=1.E-5)
+  PARAMETER (q2max=1.E+2)
+  ! ym      PARAMETER (nlay=klev)
+  ! ym      PARAMETER (nlev=klev+1)
+
+  PARAMETER (cn1=a2*(1.E+0-6.E+0*a1/b1))
+  PARAMETER (cn2=-3.E+0*a2*(6.E+0*a1+b2))
+  PARAMETER (cm1=a1*(1.E+0-3.E+0*c1-6.E+0*a1/b1))
+  PARAMETER (cm2=a1*(-3.E+0*a2*((b2-3.E+0*a2)*(1.E+0-6.E+0*a1/b1)- &
+    3.E+0*c1*(b2+6.E+0*a1))))
+  PARAMETER (cm3=-3.E+0*a2*(6.E+0*a1+b2))
+  PARAMETER (cm4=-9.E+0*a1*a2)
+
+  LOGICAL :: first
+!  SAVE first
+!  DATA first/.TRUE./
+!  !$OMP THREADPRIVATE(first)
+  ! .......................................................................
+  ! traitment des valeur de q2 en entree
+  ! .......................................................................
+
+  ! Initialisation de q2
+  nlay = klev
+  nlev = klev + 1
+
+! Initialisation avec un schema d'equilibre
+! CALL yamada(ngrid, dt, g, rconst, plev, temp, zlev, zlay, u, v, teta, cd, &
+!   q2diag, km, kn, ustar, l_mix)
+! IF (first .AND. 1==1) THEN
+!   first = .FALSE.
+!   q2 = q2diag
+! END IF
+q2diag=0.
+
+  DO ilev = 2, nlay
+    DO igrid = 1, ngrid
+      q2(igrid, ilev) = amax1(q2(igrid,ilev), q2min)
+      q(igrid, ilev) = sqrt(q2(igrid,ilev))
+    END DO
+  END DO
+
+  DO igrid = 1, ngrid
+    tmp1 = cd(igrid)*(u(igrid,1)**2+v(igrid,1)**2)
+    q2(igrid, 1) = b1**(2.E+0/3.E+0)*tmp1
+    q2(igrid, 1) = amax1(q2(igrid,1), q2min)
+    q(igrid, 1) = sqrt(q2(igrid,1))
+  END DO
+
+  ! .......................................................................
+  ! les increments verticaux
+  ! .......................................................................
+
+  ! !!!!! allerte !!!!!c
+  ! !!!!! zlev n'est pas declare a nlev !!!!!c
+  ! !!!!! ---->
+  DO igrid = 1, ngrid
+    zlev(igrid, nlev) = zlay(igrid, nlay) + (zlay(igrid,nlay)-zlev(igrid,nlev &
+      -1))
+  END DO
+  ! !!!!! <----
+  ! !!!!! allerte !!!!!c
+
+  DO ilay = 1, nlay
+    DO igrid = 1, ngrid
+      unsdz(igrid, ilay) = 1.E+0/(zlev(igrid,ilay+1)-zlev(igrid,ilay))
+    END DO
+  END DO
+  DO igrid = 1, ngrid
+    unsdzdec(igrid, 1) = 1.E+0/(zlay(igrid,1)-zlev(igrid,1))
+  END DO
+  DO ilay = 2, nlay
+    DO igrid = 1, ngrid
+      unsdzdec(igrid, ilay) = 1.E+0/(zlay(igrid,ilay)-zlay(igrid,ilay-1))
+    END DO
+  END DO
+  DO igrid = 1, ngrid
+    unsdzdec(igrid, nlay+1) = 1.E+0/(zlev(igrid,nlay+1)-zlay(igrid,nlay))
+  END DO
+
+  ! .......................................................................
+  ! le cisaillement et le gradient de temperature
+  ! .......................................................................
+
+  DO igrid = 1, ngrid
+    m2(igrid, 1) = (unsdzdec(igrid,1)*u(igrid,1))**2 + &
+      (unsdzdec(igrid,1)*v(igrid,1))**2
+    m(igrid, 1) = sqrt(m2(igrid,1))
+    mpre(igrid, 1) = m(igrid, 1)
+  END DO
+
+  ! -----------------------------------------------------------------------
+  DO ilev = 2, nlev - 1
+    DO igrid = 1, ngrid
+      ! -----------------------------------------------------------------------
+
+      n2(igrid, ilev) = g*unsdzdec(igrid, ilev)*(teta(igrid,ilev)-teta(igrid, &
+        ilev-1))/(teta(igrid,ilev)+teta(igrid,ilev-1))*2.E+0
+      ! n2(igrid,ilev)=0.
+
+      ! --->
+      ! on ne sais traiter que les cas stratifies. et l'ajustement
+      ! convectif est cense faire en sorte que seul des configurations
+      ! stratifiees soient rencontrees en entree de cette routine.
+      ! mais, bon ... on sait jamais (meme on sait que n2 prends
+      ! quelques valeurs negatives ... parfois) alors :
+      ! <---
+
+      IF (n2(igrid,ilev)<0.E+0) THEN
+        n2(igrid, ilev) = 0.E+0
+      END IF
+
+      m2(igrid, ilev) = (unsdzdec(igrid,ilev)*(u(igrid,ilev)-u(igrid, &
+        ilev-1)))**2 + (unsdzdec(igrid,ilev)*(v(igrid,ilev)-v(igrid, &
+        ilev-1)))**2
+      m(igrid, ilev) = sqrt(m2(igrid,ilev))
+      mpre(igrid, ilev) = m(igrid, ilev)
+
+      ! -----------------------------------------------------------------------
+    END DO
+  END DO
+  ! -----------------------------------------------------------------------
+
+  DO igrid = 1, ngrid
+    m2(igrid, nlev) = m2(igrid, nlev-1)
+    m(igrid, nlev) = m(igrid, nlev-1)
+    mpre(igrid, nlev) = m(igrid, nlev)
+  END DO
+
+  ! .......................................................................
+  ! calcul des fonctions de stabilite
+  ! .......................................................................
+
+  IF (l_mix==4) THEN
+    DO igrid = 1, ngrid
+      sqz(igrid) = 1.E-10
+      sq(igrid) = 1.E-10
+    END DO
+    DO ilev = 2, nlev - 1
+      DO igrid = 1, ngrid
+        zq = sqrt(q2(igrid,ilev))
+        sqz(igrid) = sqz(igrid) + zq*zlev(igrid, ilev)*(zlay(igrid,ilev)-zlay &
+          (igrid,ilev-1))
+        sq(igrid) = sq(igrid) + zq*(zlay(igrid,ilev)-zlay(igrid,ilev-1))
+      END DO
+    END DO
+    DO igrid = 1, ngrid
+      long0(igrid) = 0.2*sqz(igrid)/sq(igrid)
+    END DO
+  ELSE IF (l_mix==3) THEN
+    long0(igrid) = long00
+  END IF
+
+  ! (abd 5 2)      print*,'LONG0=',long0
+
+  ! -----------------------------------------------------------------------
+  DO ilev = 2, nlev - 1
+    DO igrid = 1, ngrid
+      ! -----------------------------------------------------------------------
+
+      tmp1 = kappa*(zlev(igrid,ilev)-zlev(igrid,1))
+      IF (l_mix>=10) THEN
+        long(igrid, ilev) = l_mix
+      ELSE
+        long(igrid, ilev) = tmp1/(1.E+0+tmp1/long0(igrid))
+      END IF
+      long(igrid, ilev) = max(min(long(igrid,ilev),0.5*sqrt(q2(igrid,ilev))/ &
+        sqrt(max(n2(igrid,ilev),1.E-10))), 5.)
+
+      gn = -long(igrid, ilev)**2/q2(igrid, ilev)*n2(igrid, ilev)
+      gm = long(igrid, ilev)**2/q2(igrid, ilev)*m2(igrid, ilev)
+
+      gninf = .FALSE.
+      gnsup = .FALSE.
+
+      IF (gn<gnmin) THEN
+        gninf = .TRUE.
+        gn = gnmin
+      END IF
+
+      IF (gn>gnmax) THEN
+        gnsup = .TRUE.
+        gn = gnmax
+      END IF
+
+      sn(igrid, ilev) = cn1/(1.E+0+cn2*gn)
+      sm(igrid, ilev) = (cm1+cm2*gn)/((1.E+0+cm3*gn)*(1.E+0+cm4*gn))
+
+      IF ((gninf) .OR. (gnsup)) THEN
+        snq2(igrid, ilev) = 0.E+0
+        smq2(igrid, ilev) = 0.E+0
+      ELSE
+        snq2(igrid, ilev) = -gn*(-cn1*cn2/(1.E+0+cn2*gn)**2)
+        smq2(igrid, ilev) = -gn*(cm2*(1.E+0+cm3*gn)*(1.E+0+cm4*gn)-(cm3*( &
+          1.E+0+cm4*gn)+cm4*(1.E+0+cm3*gn))*(cm1+cm2*gn))/((1.E+0+cm3*gn)*( &
+          1.E+0+cm4*gn))**2
+      END IF
+
+      ! abd
+      ! if(ilev.le.57.and.ilev.ge.37) then
+      ! print*,'L=',ilev,'   GN=',gn,'  SM=',sm(igrid,ilev)
+      ! endif
+      ! --->
+      ! la decomposition de Taylor en q2 n'a de sens que
+      ! dans les cas stratifies ou sn et sm sont quasi
+      ! proportionnels a q2. ailleurs on laisse le meme
+      ! algorithme car l'ajustement convectif fait le travail.
+      ! mais c'est delirant quand sn et snq2 n'ont pas le meme
+      ! signe : dans ces cas, on ne fait pas la decomposition.
+      ! <---
+
+      IF (snq2(igrid,ilev)*sn(igrid,ilev)<=0.E+0) snq2(igrid, ilev) = 0.E+0
+      IF (smq2(igrid,ilev)*sm(igrid,ilev)<=0.E+0) smq2(igrid, ilev) = 0.E+0
+
+      ! Correction pour les couches stables.
+      ! Schema repris de JHoltzlag Boville, lui meme venant de...
+
+      IF (1==1) THEN
+        snstable = 1. - zlev(igrid, ilev)/(700.*max(ustar(igrid),0.0001))
+        snstable = 1. - zlev(igrid, ilev)/400.
+        snstable = max(snstable, 0.)
+        snstable = snstable*snstable
+
+        ! abde       print*,'SN ',ilev,sn(1,ilev),snstable
+        IF (sn(igrid,ilev)<snstable) THEN
+          sn(igrid, ilev) = snstable
+          snq2(igrid, ilev) = 0.
+        END IF
+
+        IF (sm(igrid,ilev)<snstable) THEN
+          sm(igrid, ilev) = snstable
+          smq2(igrid, ilev) = 0.
+        END IF
+
+      END IF
+
+      ! sn : coefficient de stabilite pour n
+      ! snq2 : premier terme du developement limite de sn en q2
+      ! -----------------------------------------------------------------------
+    END DO
+  END DO
+  ! -----------------------------------------------------------------------
+
+  ! .......................................................................
+  ! calcul de km et kn au debut du pas de temps
+  ! .......................................................................
+
+  DO igrid = 1, ngrid
+    kn(igrid, 1) = knmin
+    km(igrid, 1) = kmmin
+    kmpre(igrid, 1) = km(igrid, 1)
+  END DO
+
+  ! -----------------------------------------------------------------------
+  DO ilev = 2, nlev - 1
+    DO igrid = 1, ngrid
+      ! -----------------------------------------------------------------------
+
+      kn(igrid, ilev) = long(igrid, ilev)*q(igrid, ilev)*sn(igrid, ilev)
+      km(igrid, ilev) = long(igrid, ilev)*q(igrid, ilev)*sm(igrid, ilev)
+      kmpre(igrid, ilev) = km(igrid, ilev)
+
+      ! -----------------------------------------------------------------------
+    END DO
+  END DO
+  ! -----------------------------------------------------------------------
+
+  DO igrid = 1, ngrid
+    kn(igrid, nlev) = kn(igrid, nlev-1)
+    km(igrid, nlev) = km(igrid, nlev-1)
+    kmpre(igrid, nlev) = km(igrid, nlev)
+  END DO
+
+  ! .......................................................................
+  ! boucle sur les niveaux 2 a nlev-1
+  ! .......................................................................
+
+  ! ---->
+  DO ilev = 2, nlev - 1
+    ! ---->
+    DO igrid = 1, ngrid
+
+      ! .......................................................................
+
+      ! calcul des termes sources et puits de l'equation de q2
+      ! ------------------------------------------------------
+
+      knq3 = kn(igrid, ilev)*snq2(igrid, ilev)/sn(igrid, ilev)
+      kmq3 = km(igrid, ilev)*smq2(igrid, ilev)/sm(igrid, ilev)
+
+      termq = 0.E+0
+      termq3 = 0.E+0
+      termqm2 = 0.E+0
+      termq3m2 = 0.E+0
+
+      tmp1 = dt*2.E+0*km(igrid, ilev)*m2(igrid, ilev)
+      tmp2 = dt*2.E+0*kmq3*m2(igrid, ilev)
+      termqm2 = termqm2 + dt*2.E+0*km(igrid, ilev)*m2(igrid, ilev) - &
+        dt*2.E+0*kmq3*m2(igrid, ilev)
+      termq3m2 = termq3m2 + dt*2.E+0*kmq3*m2(igrid, ilev)
+
+      termq = termq - dt*2.E+0*kn(igrid, ilev)*n2(igrid, ilev) + &
+        dt*2.E+0*knq3*n2(igrid, ilev)
+      termq3 = termq3 - dt*2.E+0*knq3*n2(igrid, ilev)
+
+      termq3 = termq3 - dt*2.E+0*q(igrid, ilev)**3/(b1*long(igrid,ilev))
+
+      ! .......................................................................
+
+      ! resolution stationnaire couplee avec le gradient de vitesse local
+      ! -----------------------------------------------------------------
+
+      ! -----{on cherche le cisaillement qui annule l'equation de q^2
+      ! supposee en q3}
+
+      tmp1 = termq + termq3
+      tmp2 = termqm2 + termq3m2
+      m2cstat = m2(igrid, ilev) - (tmp1+tmp2)/(dt*2.E+0*km(igrid,ilev))
+      mcstat = sqrt(m2cstat)
+
+      ! abde      print*,'M2 L=',ilev,mpre(igrid,ilev),mcstat
+
+      ! -----{puis on ecrit la valeur de q qui annule l'equation de m
+      ! supposee en q3}
+
+      IF (ilev==2) THEN
+        kmcstat = 1.E+0/mcstat*(unsdz(igrid,ilev)*kmpre(igrid,ilev+1)*mpre( &
+          igrid,ilev+1)+unsdz(igrid,ilev-1)*cd(igrid)*(sqrt(u(igrid,3)**2+ &
+          v(igrid,3)**2)-mcstat/unsdzdec(igrid,ilev)-mpre(igrid, &
+          ilev+1)/unsdzdec(igrid,ilev+1))**2)/(unsdz(igrid,ilev)+unsdz(igrid, &
+          ilev-1))
+      ELSE
+        kmcstat = 1.E+0/mcstat*(unsdz(igrid,ilev)*kmpre(igrid,ilev+1)*mpre( &
+          igrid,ilev+1)+unsdz(igrid,ilev-1)*kmpre(igrid,ilev-1)*mpre(igrid, &
+          ilev-1))/(unsdz(igrid,ilev)+unsdz(igrid,ilev-1))
+      END IF
+      tmp2 = kmcstat/(sm(igrid,ilev)/q2(igrid,ilev))/long(igrid, ilev)
+      qcstat = tmp2**(1.E+0/3.E+0)
+      q2cstat = qcstat**2
+
+      ! .......................................................................
+
+      ! choix de la solution finale
+      ! ---------------------------
+
+      q(igrid, ilev) = qcstat
+      q2(igrid, ilev) = q2cstat
+      m(igrid, ilev) = mcstat
+      ! abd       if(ilev.le.57.and.ilev.ge.37) then
+      ! print*,'L=',ilev,'   M2=',m2(igrid,ilev),m2cstat,
+      ! s     'N2=',n2(igrid,ilev)
+      ! abd       endif
+      m2(igrid, ilev) = m2cstat
+
+      ! --->
+      ! pour des raisons simples q2 est minore
+      ! <---
+
+      IF (q2(igrid,ilev)<q2min) THEN
+        q2(igrid, ilev) = q2min
+        q(igrid, ilev) = sqrt(q2min)
+      END IF
+
+      ! .......................................................................
+
+      ! calcul final de kn et km
+      ! ------------------------
+
+      gn = -long(igrid, ilev)**2/q2(igrid, ilev)*n2(igrid, ilev)
+      IF (gn<gnmin) gn = gnmin
+      IF (gn>gnmax) gn = gnmax
+      sn(igrid, ilev) = cn1/(1.E+0+cn2*gn)
+      sm(igrid, ilev) = (cm1+cm2*gn)/((1.E+0+cm3*gn)*(1.E+0+cm4*gn))
+      kn(igrid, ilev) = long(igrid, ilev)*q(igrid, ilev)*sn(igrid, ilev)
+      km(igrid, ilev) = long(igrid, ilev)*q(igrid, ilev)*sm(igrid, ilev)
+      ! abd
+      ! if(ilev.le.57.and.ilev.ge.37) then
+      ! print*,'L=',ilev,'   GN=',gn,'  SM=',sm(igrid,ilev)
+      ! endif
+
+      ! .......................................................................
+
+    END DO
+
+  END DO
+
+  ! .......................................................................
+
+
+  DO igrid = 1, ngrid
+    kn(igrid, 1) = knmin
+    km(igrid, 1) = kmmin
+    ! kn(igrid,1)=cd(igrid)
+    ! km(igrid,1)=cd(igrid)
+    q2(igrid, nlev) = q2(igrid, nlev-1)
+    q(igrid, nlev) = q(igrid, nlev-1)
+    kn(igrid, nlev) = kn(igrid, nlev-1)
+    km(igrid, nlev) = km(igrid, nlev-1)
+  END DO
+
+  ! CALCUL DE LA DIFFUSION VERTICALE DE Q2
+  IF (1==1) THEN
+
+    sss=0.
+    sssq=0.
+    ! WARNING : travail sur le point ig=1 ????
+    DO ilev = 2, klev - 1
+      sss = sss + plev(1, ilev-1) - plev(1, ilev+1)
+      sssq = sssq + (plev(1,ilev-1)-plev(1,ilev+1))*q2(1, ilev)
+    END DO
+    ! print*,'Q2moy avant',sssq/sss
+    ! print*,'Q2q20 ',(q2(1,ilev),ilev=1,10)
+    ! print*,'Q2km0 ',(km(1,ilev),ilev=1,10)
+    ! ! C'est quoi ca qu'etait dans l'original???
+    ! do igrid=1,ngrid
+    ! q2(igrid,1)=10.
+    ! enddo
+    ! q2s=q2
+    ! do iii=1,10
+    ! call vdif_q2(dt,g,rconst,plev,temp,km,q2)
+    ! do ilev=1,klev+1
+    ! write(iii+49,*) q2(1,ilev),zlev(1,ilev)
+    ! enddo
+    ! enddo
+    ! stop
+    ! do ilev=1,klev
+    ! print*,zlev(1,ilev),q2s(1,ilev),q2(1,ilev)
+    ! enddo
+    ! q2s=q2-q2s
+    ! do ilev=1,klev
+    ! print*,q2s(1,ilev),zlev(1,ilev)
+    ! enddo
+    DO ilev = 2, klev - 1
+      sss = sss + plev(1, ilev-1) - plev(1, ilev+1)
+      sssq = sssq + (plev(1,ilev-1)-plev(1,ilev+1))*q2(1, ilev)
+    END DO
+    PRINT *, 'Q2moy apres', sssq/sss
+
+
+    DO ilev = 2, klev-1
+      DO igrid = 1, ngrid
+        q2(igrid, ilev) = max(q2(igrid,ilev), q2min)
+        q(igrid, ilev) = sqrt(q2(igrid,ilev))
+
+        ! .......................................................................
+
+        ! calcul final de kn et km
+        ! ------------------------
+
+        gn = -long(igrid, ilev)**2/q2(igrid, ilev)*n2(igrid, ilev)
+        IF (gn<gnmin) gn = gnmin
+        IF (gn>gnmax) gn = gnmax
+        sn(igrid, ilev) = cn1/(1.E+0+cn2*gn)
+        sm(igrid, ilev) = (cm1+cm2*gn)/((1.E+0+cm3*gn)*(1.E+0+cm4*gn))
+        ! Correction pour les couches stables.
+        ! Schema repris de JHoltzlag Boville, lui meme venant de...
+
+        IF (1==1) THEN
+          snstable = 1. - zlev(igrid, ilev)/(700.*max(ustar(igrid),0.0001))
+          snstable = 1. - zlev(igrid, ilev)/400.
+          snstable = max(snstable, 0.)
+          snstable = snstable*snstable
+
+          ! abde      print*,'SN ',ilev,sn(1,ilev),snstable
+          IF (sn(igrid,ilev)<snstable) THEN
+            sn(igrid, ilev) = snstable
+            snq2(igrid, ilev) = 0.
+          END IF
+
+          IF (sm(igrid,ilev)<snstable) THEN
+            sm(igrid, ilev) = snstable
+            smq2(igrid, ilev) = 0.
+          END IF
+
+        END IF
+
+        ! sn : coefficient de stabilite pour n
+        kn(igrid, ilev) = long(igrid, ilev)*q(igrid, ilev)*sn(igrid, ilev)
+        km(igrid, ilev) = long(igrid, ilev)*q(igrid, ilev)
+
+      END DO
+    END DO
+    ! print*,'Q2km1 ',(km(1,ilev),ilev=1,10)
+
+  END IF
+
+  RETURN
+END SUBROUTINE vdif_kcay
Index: DZ6/trunk/libf/phylmd/water_int.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/water_int.F90	(revision 5267)
+++ 	(revision )
@@ -1,23 +1,0 @@
-subroutine water_int(klon,klev,field3d,mass,field2d)
-
-!=============================================================
-! Compute the 2D burden from 3D mixing ratios
-!  OB (obolmd@lmd.jussieu.fr)
-!=============================================================
-
-IMPLICIT none
-
-! Arguments
-INTEGER, INTENT(IN) :: klon,klev
-REAL, DIMENSION(klon,klev),INTENT(IN)  :: field3d, mass 
-REAL, DIMENSION(klon),     INTENT(OUT) :: field2d
-
-INTEGER k
-
-field2d(:)=0.0
-DO k=1, klev
-field2d(:)=field2d(:)+field3d(:,k)*mass(:,k)
-ENDDO
-
-RETURN
-END
Index: /LMDZ6/trunk/libf/phylmd/water_int.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/water_int.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/water_int.f90	(revision 5268)
@@ -0,0 +1,23 @@
+subroutine water_int(klon,klev,field3d,mass,field2d)
+
+!=============================================================
+! Compute the 2D burden from 3D mixing ratios
+!  OB (obolmd@lmd.jussieu.fr)
+!=============================================================
+
+IMPLICIT none
+
+! Arguments
+INTEGER, INTENT(IN) :: klon,klev
+REAL, DIMENSION(klon,klev),INTENT(IN)  :: field3d, mass 
+REAL, DIMENSION(klon),     INTENT(OUT) :: field2d
+
+INTEGER k
+
+field2d(:)=0.0
+DO k=1, klev
+field2d(:)=field2d(:)+field3d(:,k)*mass(:,k)
+ENDDO
+
+RETURN
+END
Index: DZ6/trunk/libf/phylmd/wx_pbl_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/wx_pbl_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,1231 +1,0 @@
-MODULE wx_pbl_mod
-!
-! Split Planetary Boundary Layer
-!
-! This module manages the splitting of the boundary layer between two regions; the (w) 
-! region (inside cold pools) and the (x) region (outside cold pools)
-!
-  USE dimphy
-
-  IMPLICIT NONE
-
-CONTAINS
-!
-!****************************************************************************************
-!
-SUBROUTINE wx_pbl0_merge(knon, ypplay, ypaprs,  &
-                                 sigw, dTs_forcing, dqs_forcing,  &
-                                 yt_x, yt_w, yq_x, yq_w, &
-                                 yu_x, yu_w, yv_x, yv_w, &
-                                 ycdragh_x, ycdragh_w, ycdragq_x, ycdragq_w, &
-                                 ycdragm_x, ycdragm_w, &
-                                 AcoefT_x, AcoefT_w, AcoefQ_x, AcoefQ_w, &
-                                 AcoefU_x, AcoefU_w, AcoefV_x, AcoefV_w, &
-                                 BcoefT_x, BcoefT_w, BcoefQ_x, BcoefQ_w, &
-                                 BcoefU_x, BcoefU_w, BcoefV_x, BcoefV_w, &
-                                 AcoefT, AcoefQ, AcoefU, AcoefV, &
-                                 BcoefT, BcoefQ, BcoefU, BcoefV, &
-                                 ycdragh, ycdragq, ycdragm, &
-                                 yt1, yq1, yu1, yv1 &
-                                 )
-!
-
-    USE wx_pbl_var_mod
-
-    USE print_control_mod, ONLY: prt_level,lunout
-    USE indice_sol_mod, ONLY: is_oce
-!
-    INCLUDE "YOMCST.h"
-    INCLUDE "FCTTRE.h"
-    INCLUDE "YOETHF.h"
-    INCLUDE "clesphys.h"
-!
-    INTEGER,                      INTENT(IN)        :: knon    ! number of grid cells
-    REAL, DIMENSION(knon,klev),   INTENT(IN)        :: ypplay  ! mid-layer pressure (Pa)
-    REAL, DIMENSION(knon,klev),   INTENT(IN)        :: ypaprs  ! pressure at layer interfaces (pa)
-    REAL, DIMENSION(knon),        INTENT(IN)        :: sigw ! cold pools fractional area
-    REAL, DIMENSION(knon),        INTENT(IN)        :: dTs_forcing ! forced temperature difference (w)-(x)
-    REAL, DIMENSION(knon),        INTENT(IN)        :: dqs_forcing ! forced humidity difference (w)-(x)
-    REAL, DIMENSION(knon,klev),   INTENT(IN)        :: yt_x, yt_w, yq_x, yq_w
-    REAL, DIMENSION(knon,klev),   INTENT(IN)        :: yu_x, yu_w, yv_x, yv_w
-    REAL, DIMENSION(knon),        INTENT(IN)        :: ycdragh_x, ycdragh_w, ycdragq_x, ycdragq_w
-    REAL, DIMENSION(knon),        INTENT(IN)        :: ycdragm_x, ycdragm_w
-    REAL, DIMENSION(knon),        INTENT(IN)        :: AcoefT_x, AcoefT_w, AcoefQ_x, AcoefQ_w
-    REAL, DIMENSION(knon),        INTENT(IN)        :: AcoefU_x, AcoefU_w, AcoefV_x, AcoefV_w
-    REAL, DIMENSION(knon),        INTENT(IN)        :: BcoefT_x, BcoefT_w, BcoefQ_x, BcoefQ_w
-    REAL, DIMENSION(knon),        INTENT(IN)        :: BcoefU_x, BcoefU_w, BcoefV_x, BcoefV_w
-    REAL, DIMENSION(knon),        INTENT(OUT)       :: AcoefT, AcoefQ, AcoefU, AcoefV
-    REAL, DIMENSION(knon),        INTENT(OUT)       :: BcoefT, BcoefQ, BcoefU, BcoefV
-    REAL, DIMENSION(knon),        INTENT(OUT)       :: ycdragh, ycdragq, ycdragm
-    REAL, DIMENSION(knon),        INTENT(OUT)       :: yt1, yq1, yu1, yv1  ! Apparent T, q, u, v at first level, as
-                                                                           !seen by surface modules
-!
-! Local variables
-    INTEGER                    :: j
-    REAL                       :: dd_Kh
-    REAL                       :: dd_Kq
-    REAL                       :: dd_Km
-    REAL                       :: dd_u 
-    REAL                       :: dd_v 
-    REAL                       :: dd_t 
-    REAL                       :: dd_q 
-!
-    REAL                       :: LambdaTs, LambdaQs, LambdaUs, LambdaVs 
-!
-    REAL, DIMENSION(knon)      :: sigx       ! fractional area of (x) region
-!
-!
-   sigx(1:knon) = 1.-sigw(1:knon)
-!                                           
-!
-        DO j=1,knon
-!
-!
-! Compute w-x differences
-       dd_t = yt_w(j,1) - yt_x(j,1)
-       dd_q = yq_w(j,1) - yq_x(j,1)
-       dd_u = yu_w(j,1) - yu_x(j,1)
-       dd_v = yv_w(j,1) - yv_x(j,1)
-!
-! Merged exchange coefficients
-         dd_Kh = Kech_h_w(j) - Kech_h_x(j)
-         dd_Kq = Kech_q_w(j) - Kech_q_x(j)
-         dd_Km = Kech_m_w(j) - Kech_m_x(j)
-!
-       LambdaTs = dd_KTp(j)/Kech_Tp(j)
-       LambdaQs = dd_KQs(j)/Kech_Qs(j)
-       LambdaUs = dd_KUp(j)/Kech_Up(j)
-       LambdaVs = dd_KVp(j)/Kech_Vp(j)
-!
-! Calcul des coef A, B \'equivalents dans la couche 1
-!
-! The dTs_forcing and dqs_forcing terms are added for diagnostic purpose ; they should be zero in normal operation.
-       AcoefT(j) = AcoefT_x(j) + sigw(j)*(1.+sigx(j)*LambdaTs)*(dd_AT(j) - C_p(j)*dTs_forcing(j))
-       AcoefQ(j) = AcoefQ_x(j) + sigw(j)*(1.+sigx(j)*LambdaQs)*(dd_AQ(j) - dqs_forcing(j))
-       AcoefU(j) = AcoefU_x(j) + sigw(j)*(1.+sigx(j)*LambdaUs)*dd_AU(j)
-       AcoefV(j) = AcoefV_x(j) + sigw(j)*(1.+sigx(j)*LambdaVs)*dd_AV(j)
-!                                           
-!
-!!       BcoefT(j) = (sigw(j)*Kech_h_w(j)*Kech_T_pw(j)*BcoefT_w(j) + &
-!!                sigx(j)*Kech_h_x(j)*Kech_T_px(j)*BcoefT_x(j) )/(Kech_h(j)*Kech_Tp(j))
-!!       BcoefQ(j) = (sigw(j)*Kech_q_w(j)*Kech_Q_pw(j)*BcoefQ_w(j) + &
-!!                sigx(j)*Kech_q_x(j)*Kech_Q_px(j)*BcoefQ_x(j) )/(Kech_q(j)*Kech_Qp(j))
-!!       BcoefU(j) = (sigw(j)*Kech_m_w(j)*Kech_U_pw(j)*BcoefU_w(j) + &
-!!                sigx(j)*Kech_m_x(j)*Kech_U_px(j)*BcoefU_x(j) )/(Kech_m(j)*Kech_Up(j))
-!!       BcoefV(j) = (sigw(j)*Kech_m_w(j)*Kech_V_pw(j)*BcoefV_w(j) + &
-!!                sigx(j)*Kech_m_x(j)*Kech_V_px(j)*BcoefV_x(j) )/(Kech_m(j)*Kech_Vp(j))
-!
-!!  Print *,'YYYYpbl0: BcoefT_x, sigw, sigx, dd_Kh, dd_KTp, Kech_h_w ', &
-!!                     BcoefT_x, sigw, sigx, dd_Kh, dd_KTp, Kech_h_w
-!!  Print *,'YYYYpbl0: Kech_T_pw, dd_BT, Kech_h, Kech_Tp ', &
-!!                     Kech_T_pw, dd_BT, Kech_h, Kech_Tp
-       BcoefT(j) = BcoefT_x(j) + sigw(j)*(sigx(j)*dd_Kh*dd_KTp(j)*BcoefT_x(j) + &
-                                  Kech_h_w(j)*Kech_T_pw(j)*dd_BT(j))/(Kech_h(j)*Kech_Tp(j))
-       BcoefQ(j) = BcoefQ_x(j) + sigw(j)*(sigx(j)*dd_Kq*dd_KQs(j)*BcoefQ_x(j) + &
-                                  Kech_q_w(j)*Kech_Q_sw(j)*dd_BQ(j))/(Kech_q(j)*Kech_Qs(j))
-       BcoefU(j) = BcoefU_x(j) + sigw(j)*(sigx(j)*dd_Km*dd_KUp(j)*BcoefU_x(j) + &
-                                  Kech_m_w(j)*Kech_U_pw(j)*dd_BU(j))/(Kech_m(j)*Kech_Up(j))
-       BcoefV(j) = BcoefV_x(j) + sigw(j)*(sigx(j)*dd_Km*dd_KVp(j)*BcoefV_x(j) + &
-                                  Kech_m_w(j)*Kech_V_pw(j)*dd_BV(j))/(Kech_m(j)*Kech_Vp(j))
-!>jyg
-!
-!
-! Calcul des cdrag \'equivalents dans la couche 
-!
-       ycdragm(j) = ycdragm_x(j) + sigw(j)*dd_Cdragm(j)
-       ycdragh(j) = ycdragh_x(j) + sigw(j)*dd_Cdragh(j)
-       ycdragq(j) = ycdragq_x(j) + sigw(j)*dd_Cdragq(j)
-!
-! Calcul de T, q, u et v \'equivalents dans la couche 1
-!!       yt1(j) = yt_x(j,1) + sigw(j)*dd_t*(1.+sigx(j)*dd_Kh/KCT)
-!!       yq1(j) = yq_x(j,1) + sigw(j)*dd_q*(1.+sigx(j)*dd_Kh/KCQ)
-!!       yu1(j) = yu_x(j,1) + sigw(j)*dd_u*(1.+sigx(j)*dd_Km/KCU)
-!!       yv1(j) = yv_x(j,1) + sigw(j)*dd_v*(1.+sigx(j)*dd_Km/KCV)
-       yt1(j) = yt_x(j,1) + sigw(j)*dd_t
-       yq1(j) = yq_x(j,1) + sigw(j)*dd_q
-       yu1(j) = yu_x(j,1) + sigw(j)*dd_u
-       yv1(j) = yv_x(j,1) + sigw(j)*dd_v
-
-
-        ENDDO
-
-        RETURN
-
-END SUBROUTINE wx_pbl0_merge
-
-SUBROUTINE wx_pbl_dts_merge(knon, dtime, ypplay, ypaprs, &
-                                 sigw, beta, wcstar, wdens, &
-                                 AT_x, AT_w, &
-                                 BT_x, BT_w, &
-                                 AcoefT0, AcoefQ0, BcoefT0, BcoefQ0, &
-                                 AcoefT,  AcoefQ,  BcoefT,  BcoefQ, &
-                                 HTphiT_b, dd_HTphiT, HTphiQ_b, dd_HTphiQ, HTRn_b, dd_HTRn, &
-                                 phiT0_b, dphiT0, phiQ0_b, dphiQ0, Rn0_b, dRn0, &
-                                 g_T, g_Q, &
-                                 Gamma_phiT, Gamma_phiQ, &
-                                 dTs_ins, dqsatsrf_ins &
-                                 )
-!
-
-    USE wx_pbl_var_mod
-
-    USE print_control_mod, ONLY: prt_level,lunout
-!
-    INCLUDE "YOMCST.h"
-    INCLUDE "FCTTRE.h"
-    INCLUDE "YOETHF.h"
-!
-    INTEGER,                      INTENT(IN)        :: knon    ! number of grid cells
-    REAL,                         INTENT(IN)        :: dtime   ! time step size (s)
-    REAL, DIMENSION(knon,klev),   INTENT(IN)        :: ypplay  ! mid-layer pressure (Pa)
-    REAL, DIMENSION(knon,klev),   INTENT(IN)        :: ypaprs  ! pressure at layer interfaces (pa)
-    REAL, DIMENSION(knon),        INTENT(IN)        :: sigw    ! cold pool fractional area
-    REAL, DIMENSION(knon),        INTENT(IN)        :: beta    ! evaporation by potential evaporation
-    REAL, DIMENSION(knon),        INTENT(IN)        :: wcstar   ! cold pool gust front speed
-    REAL, DIMENSION(knon),        INTENT(IN)        :: wdens    ! cold pool number density
-    REAL, DIMENSION(knon),        INTENT(IN)        :: AT_x, AT_w
-    REAL, DIMENSION(knon),        INTENT(IN)        :: BT_x, BT_w
-    REAL, DIMENSION(knon),        INTENT(IN)        :: AcoefT0, AcoefQ0, BcoefT0, BcoefQ0
-!
-    REAL, DIMENSION(knon),        INTENT(OUT)       :: AcoefT, AcoefQ, BcoefT, BcoefQ
-    REAL, DIMENSION(knon),        INTENT(OUT)       :: HTphiT_b, dd_HTphiT, HTphiQ_b, dd_HTphiQ, HTRn_b, dd_HTRn
-    REAL, DIMENSION(knon),        INTENT(OUT)       :: phiT0_b, dphiT0, phiQ0_b, dphiQ0, Rn0_b, dRn0
-    REAL, DIMENSION(knon),        INTENT(OUT)       :: g_T, g_Q
-    REAL, DIMENSION(knon),        INTENT(OUT)       :: Gamma_phiT, Gamma_phiQ
-    REAL, DIMENSION(knon),        INTENT(OUT)       :: dTs_ins, dqsatsrf_ins
-!
-! Local variables
-    REAL, DIMENSION(knon)      :: qsat_x
-    REAL, DIMENSION(knon)      :: qsat_w
-    REAL, DIMENSION(knon)      :: dqsatdT_x
-    REAL, DIMENSION(knon)      :: dqsatdT_w
-!
-    REAL, DIMENSION(knon)      :: T10_x
-    REAL, DIMENSION(knon)      :: T10_w
-    REAL, DIMENSION(knon)      :: phiT0_x
-    REAL, DIMENSION(knon)      :: phiT0_w
-    REAL, DIMENSION(knon)      :: phiQ0_x
-    REAL, DIMENSION(knon)      :: phiQ0_w
-    REAL, DIMENSION(knon)      :: Rn0_x
-    REAL, DIMENSION(knon)      :: Rn0_w
-    REAL, DIMENSION(knon)      :: Rp1_x
-    REAL, DIMENSION(knon)      :: Rp1_w
-    REAL, DIMENSION(knon)      :: Rps_x
-    REAL, DIMENSION(knon)      :: Rps_w
-!
-    REAL, DIMENSION(knon)      :: HTphiT_x
-    REAL, DIMENSION(knon)      :: HTphiT_w
-    REAL, DIMENSION(knon)      :: HTphiQ_x
-    REAL, DIMENSION(knon)      :: HTphiQ_w
-    REAL, DIMENSION(knon)      :: HTRn_x
-    REAL, DIMENSION(knon)      :: HTRn_w
-!
-    REAL, DIMENSION(knon)      :: HQphiT_x
-    REAL, DIMENSION(knon)      :: HQphiT_w
-    REAL, DIMENSION(knon)      :: HQphiQ_x
-    REAL, DIMENSION(knon)      :: HQphiQ_w
-    REAL, DIMENSION(knon)      :: HQRn_x
-    REAL, DIMENSION(knon)      :: HQRn_w
-!
-    REAL, DIMENSION(knon)      :: HQphiT_b
-    REAL, DIMENSION(knon)      :: dd_HQphiT
-    REAL, DIMENSION(knon)      :: HQphiQ_b
-    REAL, DIMENSION(knon)      :: dd_HQphiQ
-    REAL, DIMENSION(knon)      :: HQRn_b
-    REAL, DIMENSION(knon)      :: dd_HQRn
-!
-
-    REAL, DIMENSION(knon)    :: sigx
-!
-    REAL, DIMENSION(knon)    :: Ts, T1
-!!!    REAL, DIMENSION(knon)    :: qsat, dqsat_dT
-!!!    REAL, DIMENSION(knon)    :: phiT0
-!
-!!!    REAL, DIMENSION(knon)    :: Cp, Lv
-    REAL, DIMENSION(knon)    :: tau, Inert 
-!
-    REAL                     :: dd_Kh
-    REAL                     :: zdelta, zcvm5, zcor
-    REAL                     :: qsat
-!
-    INTEGER                  :: j
-
-
-!----------------------------------------------------------------------------
-!  Reference state
-!  ---------------
-!   dqsat_dT_w = dqsat_dT(Ts0_w)                          dqsat_dT_x = dqsat_dT(Ts0_x)
-!   T10_w = (AT_w/Cp - Kech_T_w BT_w dtime Ts0_w)/(1 - Kech_T_w BT_w dtime)
-!                                                T10_x = (AT_x/Cp - Kech_T_x BT_x dtime Ts0_x)/(1 - Kech_T_x BT_x dtime)
-!   phiT0_w = Kech_T_pw (AT_w - Cp Ts0_w)                 phiT0_x = Kech_T_px (AT_x - Cp Ts0_x)
-!   phiQ0_w = Kech_Q_sw (beta AQ_w - qsatsrf0_w)          phiQ0_x = Kech_Q_sx (beta AQ_x - qsatsrf0_x)
-!   Rn0_w = eps_1 Rsigma T10_w^4 - Rsigma Ts0_w^4         Rn0_x = eps_1 Rsigma T10_x^4 - Rsigma Ts0_x^4
-!   Rp1_w = 4 eps_1 Rsigma T10_w^3                        Rp1_x = 4 eps_1 Rsigma T10_x^3
-!   Rps_w = 4 Rsigma Ts0_w^3                              Rps_x = 4 Rsigma Ts0_x^3
-!
-!   phiT0_b = sigw phiT0_w + sigx phiT0_x
-!   dphiT0 = phiT0_w - phiT0_x
-!   phiQ0_b = sigw phiQ0_w + sigx phiQ0_x
-!   dphiQ0 = phiQ0_w - phiQ0_x
-!   Rn0_b = sigw Rn0_w + sigx Rn0_x
-    dRn0 = Rn0_w - Rn0_x
-!
-!
-!----------------------------------------------------------------------------
-!  Elementary enthalpy equations
-!  -----------------------------
-!   phiT_w = phiT0_w - HTphiT_w (Ts_w-Ts0_w)            phiT_x = phiT0_x - HTphiT_x (Ts_x-Ts0_x)
-!   phiQ_w = phiQ0_w - HTphiQ_w (Ts_w-Ts0_w)            phiQ_x = phiQ0_x - HTphiQ_x (Ts_x-Ts0_x)
-!   Rn_w   = Rn0_w   - HTRn_w   (Ts_w-Ts0_w)            Rn_x   = Rn0_x   - HTRn_x   (Ts_x-Ts0_x)
-!  DFlux_DT coefficients
-!  ---------------------
-!   Heat flux equation
-!     HTphiT_w = Cp Kech_T_pw                            HTphiT_x = Cp Kech_T_px
-!   Moisture flux equation
-!     HTphiQ_w = beta Kech_Q_sw dqsat_dT_w               HTphiQ_x = beta Kech_Q_sx dqsat_dT_x
-!   Radiation equation
-!     HTRn_w = Rp1_w Kech_T_pw BcoefT_w dtime + Rps_w    HTRn_x = Rp1_x Kech_T_px BcoefT_x dtime + Rps_x
-!
-!----------------------------------------------------------------------------
-!  Elementary moisture equations
-!  -----------------------------
-!   beta Ts_w   = beta Ts0_w    + QQ_w     (qsatsrf_w-qsatsrf0_w)    beta Ts_x   = beta Ts0_x    + QQ_x     (qsatsrf_x-qsatsrf0_x)
-!   beta phiT_w = beta phiT0_w - HQphiT_w (qsatsrf_w-qsatsrf0_w)    beta phiQ_x = beta phiQ0_x - HTphiQ_x (qsatsrf_x-qsatsrf0_x)
-!   beta phiQ_w = beta phiQ0_w - HQphiQ_w (qsatsrf_w-qsatsrf0_w)    beta phiQ_x = beta phiQ0_x - HTphiQ_x (qsatsrf_x-qsatsrf0_x)
-!   beta Rn_w   = beta Rn0_w   - HQRn_w   (qsatsrf_w-qsatsrf0_w)    beta Rn_x   = beta Rn0_x   - HTRn_x   (qsatsrf_x-qsatsrf0_x)
-!  DFluxDQ coefficients
-!  ---------------------
-!   dqsat_dT equation
-!     QQ_w = 1. / dqsat_dT_w                             QQ_x = 1. / dqsat_dT_x
-!   Heat flux equation
-!     HQphiT_w = Cp Kech_T_pw QQ_w                       HQphiT_x = Cp Kech_T_px QQ_x
-!   Moisture flux equation
-!     HQphiQ_w = beta Kech_Q_sw                          HQphiQ_x = beta Kech_Q_sx
-!   Radiation equation
-!     HQRn_w = (Rp1_w Kech_T_pw BcoefT_w dtime + Rps_w) QQ_w
-!                                         HQRn_x = (Rp1_x Kech_T_px BcoefT_x dtime + Rps_x) QQ_x
-!
-!----------------------------------------------------------------------------
-! Mean values and w-x differences
-! -------------------------------
-!  HTphiT_b = sigw HTphiT_w + sigx HTphiT_x               dd_HTphiT = HTphiT_w - HTphiT_x
-!  HTphiQ_b = sigw HTphiQ_w + sigx HTphiQ_x               dd_HTphiQ = HTphiQ_w - HTphiQ_x
-!  HTRn_b   = sigw HTRn_w   + sigx HTRn_x                 dd_HTRn   = HTRn_w   - HTRn_x
-!
-!  QQ_b     = sigw QQ_w     + sigx QQ_x                   dd_QQ     = QQ_w     - QQ_x
-!  HQphiT_b = sigw HQphiT_w + sigx HQphiT_x               dd_HQphiT = HQphiT_w - HQphiT_x
-!  HQphiQ_b = sigw HQphiQ_w + sigx HQphiQ_x               dd_HQphiQ = HQphiQ_w - HQphiQ_x
-!  HQRn_b   = sigw HQRn_w   + sigx HQRn_x                 dd_HQRn   = HQRn_w   - HQRn_x
-!
-!----------------------------------------------------------------------------
-!  Equations
-!  ---------
-! (1 - g_T) dTs    = dTs_ins    + Gamma_phiT phiT
-! (1 - g_Q) dqsatsrf = dqsatsrf_ins + Gamma_phiQ phiQ
-!
-! Feedback Gains
-! --------------
-! g_T = - (sqrt(tau)/I) [ HTphiT_b + Lv HTphiQ_b + HTRn_b +  &
-!                        (dd_HTphiT + Lv dd_HTphiQ + dd_HTRn) (sigx - sigw - sigw sigx dd_HTphiT/HTphiT_b) ]
-! g_Q = - (sqrt(tau)/(I QQ_b)) ( HQphiT_b + Lv HQphiQ_b + HQRn_b ) -  &
-!         (sigx - sigw - sigw sigx dd_HQphiQ/HQphiQ_b)   &
-!                          [ dd_QQ/QQ_b + (sqrt(tau)/(I QQ_b))(dd_HQphiT + Lv dd_HQphiQ + dd_HQRn) ]
-!
-!  Ts, qs Coupling coefficients                /
-!  ----------------------------
-! Gamma_phiT = (sqrt(tau)/(I HTphiT_b)) (dd_HTphiT + Lv dd_HTphiQ + dd_HTRn)
-! Gamma_phiQ = (1/(HQphiQ_b QQ_b)) [ dd_QQ +  (sqrt(tau)/(I )) (dd_HQphiT + Lv dd_HQphiQ + dd_HQRn) ]
-!
-!  Insensitive changes
-!  -------------------
-! dTs_ins    = (1 - g_T) dTs0    - Gamma_phiT phiT0_b
-! dqsatsrf_ins = (1 - g_Q) dqsatsrf0 - Gamma_phiQ phiQ0_b
-!
-!----------------------------------------------------------------------------
-!  Effective coefficients Acoef and Bcoef
-!  --------------------------------------
-!  Equations
-!  ---------
-! Cp Ta = AcoefT + BcoefT phiT dtime
-!    qa = AcoefQ + BcoefQ phiQ dtime
-!  Coefficients
-!  ------------
-! AcoefT = AcoefT0 - sigw sigx (dd_KTp/Kech_Tp) Cp dTs_ins/(1 - g_T)
-! BcoefT = BcoefT0 - sigw sigx (dd_KTp/Kech_Tp) Cp Gamma_phiT/(1 - g_T)/dtime
-!
-! AcoefQ = AcoefQ0 - sigw sigx (dd_KQp/Kech_Qp) dqs_ins/(1 - g_Q)
-! BcoefQ = BcoefQ0 - sigw sigx (dd_KQp/Kech_Qp) Gamma_phiq/(1 - g_Q)/dtime
-!
-!==============================================================================
-!
-!
-!  Parameters
-!  ----------
-   Inert(1:knon) = 2000.
-   tau(1:knon) = sqrt(sigw(1:knon)/max(rpi*wdens(1:knon)*wcstar(1:knon)**2 , &
-                                       sigw(1:knon)*1.e-12,smallestreal))
-   sigx(1:knon) = 1.-sigw(1:knon)
-!! Compute Cp, Lv, qsat, dqsat_dT.
-!   C_p(1:knon) = RCpd
-!   L_v(1:knon) = RLvtt
-!
-!      print *,' AAAA wx_pbl_dTs, C_p(j), qsat0(j), Ts0(j) : ', C_p(:), qsat0(:), Ts0(:)
-!
-!
-   T10_x(1:knon) = (AT_x(1:knon)/C_p(1:knon) - Kech_h_x(1:knon)*BT_x(1:knon)*dtime*Ts0_x(1:knon))/  &
-                   (1 - Kech_h_x(1:knon)*BT_x(1:knon)*dtime)
-   T10_w(1:knon) = (AT_w(1:knon)/C_p(1:knon) - Kech_h_w(1:knon)*BT_w(1:knon)*dtime*Ts0_w(1:knon))/  &
-                   (1 - Kech_h_w(1:knon)*BT_w(1:knon)*dtime)
-!
-   phiT0_x(1:knon) = Kech_T_px(1:knon)*(AT_x(1:knon) - C_p(1:knon)*Ts0_x(1:knon))
-   phiT0_w(1:knon) = Kech_T_pw(1:knon)*(AT_w(1:knon) - C_p(1:knon)*Ts0_w(1:knon))
-!
-   phiQ0_x(1:knon) = Kech_Q_sx(1:knon)*(beta(1:knon)*AQ_x(1:knon) - qsatsrf0_x(1:knon))
-   phiQ0_w(1:knon) = Kech_Q_sw(1:knon)*(beta(1:knon)*AQ_w(1:knon) - qsatsrf0_w(1:knon))
-!
-   Rn0_x(1:knon) = eps_1*Rsigma*T10_x(1:knon)**4 - Rsigma*Ts0_x(1:knon)**4
-   Rn0_w(1:knon) = eps_1*Rsigma*T10_w(1:knon)**4 - Rsigma*Ts0_w(1:knon)**4
-!
-   Rp1_x(1:knon) = 4*eps_1*Rsigma*T10_x(1:knon)**3
-   Rp1_w(1:knon) = 4*eps_1*Rsigma*T10_w(1:knon)**3
-!
-   Rps_x(1:knon) = 4*Rsigma*Ts0_x(1:knon)**3
-   Rps_w(1:knon) = 4*Rsigma*Ts0_w(1:knon)**3
-!
-!  DFlux_DT coefficients
-!  ---------------------
-!   Heat flux equation
-     HTphiT_x(1:knon) = C_p(1:knon)*Kech_T_px(1:knon)
-     HTphiT_w(1:knon) = C_p(1:knon)*Kech_T_pw(1:knon)                       
-!   Moisture flux equation
-     HTphiQ_x(1:knon) = beta(1:knon)*Kech_Q_sx(1:knon)*dqsatdT0_x(1:knon)
-     HTphiQ_w(1:knon) = beta(1:knon)*Kech_Q_sw(1:knon)*dqsatdT0_w(1:knon)          
-!   Radiation equation
-     HTRn_x(1:knon) = Rp1_x(1:knon)*Kech_T_px(1:knon)*BT_x(1:knon)*dtime + Rps_x(1:knon)
-     HTRn_w(1:knon) = Rp1_w(1:knon)*Kech_T_pw(1:knon)*BT_w(1:knon)*dtime + Rps_w(1:knon)  
-!
-!  DFluxDQ coefficients
-!  ---------------------
-!   Heat flux equation
-     HQphiT_x(1:knon) = C_p(1:knon)*Kech_T_px(1:knon)*QQ_x(1:knon)
-     HQphiT_w(1:knon) = C_p(1:knon)*Kech_T_pw(1:knon)*QQ_w(1:knon)                 
-!   Moisture flux equation
-     HQphiQ_x(1:knon) = beta(1:knon)*Kech_Q_sx(1:knon)
-     HQphiQ_w(1:knon) = beta(1:knon)*Kech_Q_sw(1:knon)                   
-!   Radiation equation
-     HQRn_x(1:knon) = (Rp1_x(1:knon)*Kech_T_px(1:knon)*BT_x(1:knon)*dtime + Rps_x(1:knon))*QQ_x(1:knon)
-     HQRn_w(1:knon) = (Rp1_w(1:knon)*Kech_T_pw(1:knon)*BT_w(1:knon)*dtime + Rps_w(1:knon))*QQ_w(1:knon)
-!
-! Mean values and w-x differences
-! -------------------------------
-  phiT0_b(1:knon) = sigw(1:knon)*phiT0_w(1:knon) + sigx(1:knon)*phiT0_x(1:knon)           
-  phiQ0_b(1:knon) = sigw(1:knon)*phiQ0_w(1:knon) + sigx(1:knon)*phiQ0_x(1:knon)          
-  Rn0_b(1:knon)   = sigw(1:knon)*Rn0_w(1:knon)   + sigx(1:knon)*Rn0_x(1:knon)          
-!
-  dphiT0(1:knon) = phiT0_w(1:knon) - phiT0_x(1:knon)           
-  dphiQ0(1:knon) = phiQ0_w(1:knon) - phiQ0_x(1:knon)          
-  dRn0(1:knon)   = Rn0_w(1:knon)   - Rn0_x(1:knon)          
-!
-  HTphiT_b(1:knon) = sigw(1:knon)*HTphiT_w(1:knon) + sigx(1:knon)*HTphiT_x(1:knon)           
-  dd_HTphiT(1:knon) = HTphiT_w(1:knon) - HTphiT_x(1:knon)
-!
-  HTphiQ_b(1:knon) = sigw(1:knon)*HTphiQ_w(1:knon) + sigx(1:knon)*HTphiQ_x(1:knon)          
-  dd_HTphiQ(1:knon) = HTphiQ_w(1:knon) - HTphiQ_x(1:knon)
-!
-  HTRn_b(1:knon)   = sigw(1:knon)*HTRn_w(1:knon)   + sigx(1:knon)*HTRn_x(1:knon)           
-  dd_HTRn(1:knon)   = HTRn_w(1:knon)   - HTRn_x(1:knon)
-!
-  HQphiT_b(1:knon) = sigw(1:knon)*HQphiT_w(1:knon) + sigx(1:knon)*HQphiT_x(1:knon)          
-  dd_HQphiT(1:knon) = HQphiT_w(1:knon) - HQphiT_x(1:knon)
-!
-  HQphiQ_b(1:knon) = sigw(1:knon)*HQphiQ_w(1:knon) + sigx(1:knon)*HQphiQ_x(1:knon)          
-  dd_HQphiQ(1:knon) = HQphiQ_w - HQphiQ_x(1:knon)
-!
-  HQRn_b(1:knon)   = sigw(1:knon)*HQRn_w(1:knon)   + sigx(1:knon)*HQRn_x(1:knon)             
-  dd_HQRn(1:knon)   = HQRn_w(1:knon)   - HQRn_x(1:knon)
-!
-! Feedback Gains
-! --------------
- g_T(1:knon) = - (sqrt(tau(1:knon))/Inert(1:knon))  &
-               * (HTphiT_b(1:knon) + L_v(1:knon)*HTphiQ_b(1:knon) + HTRn_b(1:knon)  &
-                 + (dd_HTphiT(1:knon) + L_v(1:knon)*dd_HTphiQ(1:knon) + dd_HTRn(1:knon))  &
-                 * (sigx(1:knon) - sigw(1:knon) - sigw(1:knon)*sigx(1:knon)*dd_HTphiT(1:knon)/HTphiT_b(1:knon)) )
-!
-!!!! DO j = 1,knon
-!!!!  IF (mod(j,20) .eq.0) THEN
-!!!!   print *, '   j     dd_QQ       QQ_b  dd_HQphiQ  dd_HQphiT   dd_HQRn   HQphiQ_b   HQphiT_b     HQRn_b '
-!!!!  ENDIF
-!!!!   print 1789, j, dd_QQ(j), QQ_b(j), dd_HQphiQ(j), dd_HQphiT(j), dd_HQRn(j), HQphiQ_b(j), HQphiT_b(j), HQRn_b(j)
-!!!! 1789 FORMAT( I4, 10(1X,E10.2))
-!!!! ENDDO
-   g_Q(1:knon) = - (dd_QQ(1:knon)/QQ_b(1:knon)) *  &
-                    (sigx(1:knon)-sigw(1:knon)-sigw(1:knon)*sigx(1:knon)*dd_KQs(1:knon)/Kech_Qs(1:knon)) &
-                 - sqrt(tau(1:knon))/(Inert(1:knon)*QQ_b(1:knon)) *  &
-                   ( HQphiT_b(1:knon) + L_v(1:knon)*HQphiQ_b(1:knon) + HQRn_b(1:knon) +  & 
-                      (sigx(1:knon) - sigw(1:knon) - sigw(1:knon)*sigx(1:knon)*dd_KQs(1:knon)/Kech_Qs(1:knon)) *  &
-                       (dd_HQphiT(1:knon) + L_v(1:knon)*dd_HQphiQ(1:knon) + dd_HQRn(1:knon)) )
-
-!!   g_Q(1:knon) = - (dd_QQ(1:knon)/QQ_b(1:knon)) *  &
-!!                    (sigx(1:knon)-sigw(1:knon)-sigw(1:knon)*sigx(1:knon)*dd_HQphiQ(1:knon)/HQphiQ_b(1:knon)) &
-!!                 - sqrt(tau(1:knon))/(Inert(1:knon)*QQ_b(1:knon)) *  &
-!!                   ( HQphiT_b(1:knon) + L_v(1:knon)*HQphiQ_b(1:knon) + HQRn_b(1:knon) +  & 
-!!                      (sigx(1:knon) - sigw(1:knon) - sigw(1:knon)*sigx(1:knon)*dd_HQphiQ(1:knon)/HQphiQ_b(1:knon)) *  &
-!!                       (dd_HQphiT(1:knon) + L_v(1:knon)*dd_HQphiQ(1:knon) + dd_HQRn(1:knon)) )
-
-!! g_Q(1:knon) = - (sqrt(tau(1:knon))/(Inert(1:knon)*QQ_b(1:knon))) *  &
-!!                 ( HQphiT_b(1:knon) + L_v(1:knon)*HQphiQ_b(1:knon) + HQRn_b(1:knon) )  & 
-!!               - (sigx(1:knon) - sigw(1:knon) - sigw(1:knon)*sigx(1:knon)*dd_HQphiQ(1:knon)/HQphiQ_b(1:knon)) *   &
-!!                 ( dd_QQ(1:knon)/QQ_b(1:knon)   &
-!!                 + (sqrt(tau(1:knon))/(Inert(1:knon)*QQ_b(1:knon)))  &
-!!                 * (dd_HQphiT(1:knon) + L_v(1:knon)*dd_HQphiQ(1:knon) + dd_HQRn(1:knon)) )
-
-!  Ts, qs Coupling coefficients                /
-!  ----------------------------
-  Gamma_phiT(1:knon) = (sqrt(tau(1:knon))/(Inert(1:knon)*HTphiT_b(1:knon)))  &
-                     * (dd_HTphiT(1:knon) + L_v(1:knon)*dd_HTphiQ(1:knon) + dd_HTRn(1:knon))
-! 
-  Gamma_phiQ(1:knon) = (1./(Kech_Qs(1:knon)*QQ_b(1:knon))) * &
-                        ( dd_QQ(1:knon)   &
-                         + (sqrt(tau(1:knon))/(Inert(1:knon))) *  &
-                          (dd_HQphiT(1:knon) + L_v(1:knon)*dd_HQphiQ(1:knon) + dd_HQRn(1:knon)) )
-
-!!  Gamma_phiQ(1:knon) = (beta(1:knon)/(HQphiQ_b(1:knon)*QQ_b(1:knon))) * &
-!!                        ( dd_QQ(1:knon)   &
-!!                         + (sqrt(tau(1:knon))/(Inert(1:knon))) *  &
-!!                          (dd_HQphiT(1:knon) + L_v(1:knon)*dd_HQphiQ(1:knon) + dd_HQRn(1:knon)) )
-
-!!  Gamma_phiQ(1:knon) = (1/(HQphiQ_b(1:knon)*QQ_b(1:knon)))   &
-!!                     * ( dd_QQ(1:knon)   &
-!!                       + (sqrt(tau(1:knon))/(Inert(1:knon)))  &
-!!                       * (dd_HQphiT(1:knon) + L_v(1:knon)*dd_HQphiQ(1:knon) + dd_HQRn(1:knon)) )
-!
-!  Insensitive changes
-!  -------------------
-  dTs_ins(1:knon)    = (sqrt(tau(1:knon))/Inert(1:knon))*  &
-                       (dphiT0(1:knon) + L_v(1:knon)*dphiQ0(1:knon) + dRn0(1:knon))
-!
-  dqsatsrf_ins(1:knon) = (beta(1:knon)/QQ_b(1:knon))*dTs_ins(1:knon)
-!
-   IF (prt_level .Ge. 10) THEN
-      print *,'wx_pbl_merge, tau         ', tau
-      print *,'wx_pbl_merge, AcoefT0     ', AcoefT0
-      print *,'wx_pbl_merge, AcoefQ0     ', AcoefQ0
-      print *,'wx_pbl_merge, BcoefT0     ', BcoefT0
-      print *,'wx_pbl_merge, BcoefQ0     ', BcoefQ0
-      print *,'wx_pbl_merge, qsat0_w, qsat0_x ', (qsat0_w(j), qsat0_x(j),j=1,knon)
-      print *,'wx_pbl_merge, dqsatdT0_w, dqsatdT0_x ', (dqsatdT0_w(j), dqsatdT0_x(j),j=1,knon)
-   ENDIF
-!
-!----------------------------------------------------------------------------
-!  
-!------------------------------------------------------------------------------
-!  
-!    Effective coefficients Acoef and Bcoef
-!    --------------------------------------
-   DO j = 1,knon
-     AcoefT(j) = AcoefT0(j) - sigw(j)*sigx(j)*(dd_KTp(j)/Kech_Tp(j))*C_p(j)*   &
-                 (dTs0(j) + (dTs_ins(j)-dTs0(j)-Gamma_phiT(j)*phiT0_b(j))/(1. - g_T(j)))
-     BcoefT(j) = BcoefT0(j) - sigw(j)*sigx(j)*(dd_KTp(j)/Kech_Tp(j))*C_p(j)*Gamma_phiT(j)/(1. - g_T(j))/dtime
-     
-     AcoefQ(j) = AcoefQ0(j) - sigw(j)*sigx(j)*(dd_KQs(j)/Kech_Qs(j))*    &
-                 (dqsatsrf0(j) + (dqsatsrf_ins(j)-(beta(j)/QQ_b(j))*dTs0(j)-Gamma_phiQ(j)*phiQ0_b(j))/(1 - g_Q(j)))/ &
-                 max(beta(j),1.e-4)
-     BcoefQ(j) = BcoefQ0(j) - sigw(j)*sigx(j)*(dd_KQs(j)/Kech_Qs(j))*Gamma_phiQ(j)/(1 - g_Q(j))/ &
-                 (max(beta(j),1.e-4)*dtime)
-!!     AcoefQ(j) = AcoefQ0(j) - sigw(j)*sigx(j)*(dd_KQs(j)/Kech_Qs(j))*    &
-!!                 (dqsatsrf0(j) + (dqsatsrf_ins(j)-(beta(j)/QQ_b(j))*dTs0(j)-Gamma_phiQ(j)*phiQ0_b(j))/(1 - g_Q(j)))/ &
-!!                 beta(j)
-!!     BcoefQ(j) = BcoefQ0(j) - sigw(j)*sigx(j)*(dd_KQs(j)/Kech_Qs(j))*Gamma_phiQ(j)/(1 - g_Q(j))/(beta(j)*dtime)
-   ENDDO ! j = 1,knon
-   
-   IF (prt_level .Ge. 10) THEN
-   print *,'wx_pbl_dts AAAA BcoefQ, BcoefQ0, sigw ', &
-                            BcoefQ, BcoefQ0, sigw
-      print *,'wx_pbl_dts_merge, dTs_ins      ', dTs_ins
-      print *,'wx_pbl_dts_merge, dqs_ins      ', dqsatsrf_ins
-   ENDIF
-
-     RETURN
-
-END SUBROUTINE wx_pbl_dts_merge
-
-SUBROUTINE wx_pbl_split(knon, nsrf, dtime, sigw, beta, iflag_split, &
-                       g_T, g_Q, &
-                       Gamma_phiT, Gamma_phiQ, &
-                       dTs_ins, dqsatsrf_ins, &
-                       phiT, phiQ, phiU, phiV, &
-!!!!                       HTRn_b, dd_HTRn, HTphiT_b, dd_HTphiT, &
-                       phiQ0_b, phiT0_b, &
-                       phiT_x, phiT_w, &
-                       phiQ_x, phiQ_w, &
-                       phiU_x, phiU_w, &
-                       phiV_x, phiV_w, &
-                       philat_x, philat_w, &
-!!!!                       Rn_b, dRn, &
-                       dqsatsrf, &
-                       dTs, delta_qsurf &
-                       )
-!
-
-    USE wx_pbl_var_mod
-
-    USE print_control_mod, ONLY: prt_level,lunout
-    USE indice_sol_mod, ONLY: is_oce
-!
-    INCLUDE "YOMCST.h"
-!
-    INTEGER,                      INTENT(IN)        :: knon    ! number of grid cells
-    INTEGER,                      INTENT(IN)        :: nsrf    ! surface type
-    REAL,                         INTENT(IN)        :: dtime   ! time step size (s)
-    REAL, DIMENSION(knon),        INTENT(IN)        :: sigw ! cold pools fractional area
-    REAL, DIMENSION(knon),        INTENT(IN)        :: beta ! aridity factor
-    INTEGER,                      INTENT(IN)        :: iflag_split
-    REAL, DIMENSION(knon),        INTENT(IN)        :: g_T, g_Q
-    REAL, DIMENSION(knon),        INTENT(IN)        :: Gamma_phiT, Gamma_phiQ
-    REAL, DIMENSION(knon),        INTENT(IN)        :: dTs_ins, dqsatsrf_ins
-    REAL, DIMENSION(knon),        INTENT(IN)        :: phiT, phiQ, phiU, phiV
-    REAL, DIMENSION(knon),        INTENT(IN)        :: phiQ0_b, phiT0_b
-!
-    REAL, DIMENSION(knon),        INTENT(OUT)       :: phiT_x, phiT_w
-    REAL, DIMENSION(knon),        INTENT(OUT)       :: phiQ_x, phiQ_w
-    REAL, DIMENSION(knon),        INTENT(OUT)       :: phiU_x, phiU_w
-    REAL, DIMENSION(knon),        INTENT(OUT)       :: phiV_x, phiV_w
-    REAL, DIMENSION(knon),        INTENT(OUT)       :: philat_x, philat_w
-    REAL, DIMENSION(knon),        INTENT(OUT)       :: dqsatsrf      ! beta delta(qsat(Ts))
-    REAL, DIMENSION(knon),        INTENT(OUT)       :: dTs           ! Temperature difference at surface
-    REAL, DIMENSION(knon),        INTENT(OUT)       :: delta_qsurf
-!
-!! Local variables
-    INTEGER                    :: j
-    REAL, DIMENSION(knon)      :: dphiT, dphiQ, dphiU, dphiV
-    REAL, DIMENSION(knon)      :: q1_x, q1_w
-!
-    REAL, DIMENSION(knon)      :: sigx       ! fractional area of (x) region
-
-!----------------------------------------------------------------------------
-!  Equations
-!  ---------
-!!!!!! (1 - g_T) dTs    = dTs_ins    + Gamma_phiT phiT
-!!!!!! (1 - g_Q) dqsatsrf = dqsatsrf_ins + Gamma_phiQ phiQ
-!!!!!! dphiT = (dd_KTp/KTp) phiT + (     dd_AT - C_p dTs)*KxKwTp/KTp
-!!!!!! dphiQ = (dd_KQs/KQs) phiQ + (beta dd_AQ - dqsatsrf )*KxKwQs/KQs
-!!!!!! dphiU = (dd_KUp/KUp) phiU + (     dd_AU          )*KxKwUp/KUp
-!!!!!! dphiV = (dd_KVp/KVp) phiV + (     dd_AV          )*KxKwVp/KVp
-! 
-! (1 - g_T) (dTs-dTs0)    = dTs_ins-dTs0    + Gamma_phiT (phiT-phiT0)
-! (1 - g_Q) dqsatsrf = dqsatsrf_ins + Gamma_phiQ phiQ
-! dphiT = (dd_KTp/KTp) phiT + (     dd_AT - C_p dTs)*KxKwTp/KTp
-! dphiQ = (dd_KQs/KQs) phiQ + (beta dd_AQ - dqsatsrf )*KxKwQs/KQs
-! dphiU = (dd_KUp/KUp) phiU + (     dd_AU          )*KxKwUp/KUp
-! dphiV = (dd_KVp/KVp) phiV + (     dd_AV          )*KxKwVp/KVp
-! 
-!!
-        sigx(:) = 1.-sigw(:)
-!
-!      print *,' AAAA wx_pbl_split, C_p(j), qsat0(j), Ts0(j) : ', C_p(:), qsat0(:), Ts0(:)
-!
-   IF (iflag_split .EQ. 2 .AND. nsrf .NE. is_oce) THEN
-!
-!   Delta_tsurf and  Delta_qsurf computation
-!   -----------------------------------------
-      IF (prt_level >=10 ) THEN
-        print *,' wx_pbl_split, dTs_ins, dTs0 , Gamma_phiT, g_T ', dTs_ins, dTs0, Gamma_phiT, g_T
-        print *,' wx_pbl_split, dqsatsrf_ins, Gamma_phiQ, g_q ', dqsatsrf_ins, Gamma_phiQ, g_q
-      ENDIF
-!
-      DO j = 1,knon
-        dTs(j)    = dTs0(j) + (dTs_ins(j) - dTs0(j) + Gamma_phiT(j)*(phiT(j)-phiT0_b(j)) )/(1 - g_T(j)) 
-        dqsatsrf(j) = dqsatsrf0(j) + (dqsatsrf_ins(j) - (beta(j)/QQ_b(j))*dTs0(j) + &
-                       Gamma_phiQ(j)*(phiQ(j)-phiQ0_b(j)) )/(1 - g_Q(j)) 
-      ENDDO ! j = 1,knon
-!
-        IF (prt_level >=10 ) THEN
-          print *,' wx_pbl_split, dqsatsrf0, QQ_b ', dqsatsrf0, QQ_b
-          print *,' wx_pbl_split, phiT0_b, phiT, dTs ', phiT0_b, phiT, dTs
-          print *,' wx_pbl_split, phiQ0_b, phiQ, dqsatsrf ', phiQ0_b, phiQ, dqsatsrf
-        ENDIF
-   ELSE
-        dTs(:) = 0.
-        dqsatsrf(:) = 0.
-   ENDIF ! (iflag_split .EQ. 2 .AND. nsrf .NE. is_oce)
-!
-     DO j = 1,knon
-       dphiT(j) = (phiT(j)*dd_KTp(j) + (        dd_AT(j) - C_p(j)*dTs(j))*KxKwTp(j))/Kech_Tp(j)
-       dphiQ(j) = (phiQ(j)*dd_KQs(j) + (beta(j)*dd_AQ(j) -        dqsatsrf(j))*KxKwQs(j))/Kech_Qs(j)
-       dphiU(j) = (phiU(j)*dd_KUp(j) +          dd_AU(j)                 *KxKwUp(j))/Kech_Up(j)
-       dphiV(j) = (phiV(j)*dd_KVp(j) +          dd_AV(j)                 *KxKwVp(j))/Kech_Vp(j)
-!
-       phiT_x(j)=phiT(j) - sigw(j)*dphiT(j)
-       phiT_w(j)=phiT(j) + sigx(j)*dphiT(j)
-       phiQ_x(j)=phiQ(j) - sigw(j)*dphiQ(j)
-       phiQ_w(j)=phiQ(j) + sigx(j)*dphiQ(j)
-       phiU_x(j)=phiU(j) - sigw(j)*dphiU(j)
-       phiU_w(j)=phiU(j) + sigx(j)*dphiU(j)
-       phiV_x(j)=phiV(j) - sigw(j)*dphiV(j)
-       phiV_w(j)=phiV(j) + sigx(j)*dphiV(j)
-!
-       philat_x(j)=phiQ_x(j)*RLVTT
-       philat_w(j)=phiQ_w(j)*RLVTT
-     ENDDO ! j = 1,knon
-!
-     DO j = 1,knon
-       q1_x(j) = AQ_x(j) + BQ_x(j)*phiQ_x(j)*dtime
-       q1_w(j) = AQ_w(j) + BQ_w(j)*phiQ_w(j)*dtime
-     ENDDO ! j = 1,knon
-     DO j = 1,knon
-       delta_qsurf(j) = (1.-beta(j))*(q1_w(j) - q1_x(j)) + dqsatsrf(j)
-     ENDDO ! j = 1,knon
-!
-!!  Do j = 1,knon
-!!     print *,'XXXsplit : j, q1_x(j), AQ_x(j), BQ_x(j), phiQ_x(j) ', j, q1_x(j), AQ_x(j), BQ_x(j), phiQ_x(j)
-!!     print *,'XXXsplit : j, q1_w(j), AQ_w(j), BQ_w(j), phiQ_w(j) ', j, q1_w(j), AQ_w(j), BQ_w(j), phiQ_w(j)
-!!  ENDDO
-!
-        IF (prt_level >=10 ) THEN
-          print *,' wx_pbl_split, phiT, dphiT, dTs ', phiT, dphiT, dTs
-          print *,' wx_pbl_split, phiQ, dphiQ, dqsatsrf ', phiQ, dphiQ, dqsatsrf
-        ENDIF
-!
-        IF (prt_level >=10 ) THEN
-!!          print *,' wx_pbl_split, verif dqsatsrf = beta dqsatdT0 dTs '
-!!          print *,' wx_pbl_split, dqsatsrf, dqsatdT0*dTs ', dqsatsrf, dqsatdT0*dTs
-        ENDIF
-!
-!!    IF (knon .NE. 0) THEN
-!!       call  iophys_ecrit('sigw', 1,'sigw', '.',sigw)
-!!       call  iophys_ecrit('phit', 1,'phit', 'W/m2',phit)
-!!       call  iophys_ecrit('phit_w', 1,'phit_w', 'W/m2',phit_w)
-!!       call  iophys_ecrit('phit_x', 1,'phit_x', 'W/m2',phit_x)
-!!       call  iophys_ecrit('phiq', 1,'phiq', 'kg/m2/s',phiq)
-!!       call  iophys_ecrit('phiq_w', 1,'phiq_w', 'kg/m2/s',phiq_w)
-!!       call  iophys_ecrit('phiq_x', 1,'phiq_x', 'kg/m2/s',phiq_x)
-!!       call  iophys_ecrit('q1_w', 1,'q1_w', '.',q1_w)
-!!       call  iophys_ecrit('q1_x', 1,'q1_x', '.',q1_x)
-!!    ENDIF  ! (knon .NE. 0)
-!
-        RETURN
-
-END SUBROUTINE wx_pbl_split
-
-SUBROUTINE wx_pbl_check( knon, dtime, ypplay, ypaprs, &
-                               sigw, beta, iflag_split,   &
-                               Ts0_b9, dTs09,   &
-                               qs_b9, Ts_b9,  &                         ! yqsurf, Tsurf_new
-                               dTs9, dqsatsrf9,   &
-                               AcoefT_x, AcoefT_w, &
-                               BcoefT_x, BcoefT_w, &
-                               AcoefT0, AcoefQ0, BcoefT0, BcoefQ0, &
-                               AcoefT,  AcoefQ,  BcoefT,  BcoefQ, &
-                               phiT_b9, phiQ_b9,  &
-                               phiT_x9, phiT_w9, &
-                               phiQ_x9, phiQ_w9 &
-                               )
-!
-
-    USE wx_pbl_var_mod
-
-    USE print_control_mod, ONLY: prt_level,lunout
-!
-    INCLUDE "YOMCST.h"
-    INCLUDE "FCTTRE.h"
-    INCLUDE "YOETHF.h"
-!
-    INTEGER,                      INTENT(IN)        :: knon         ! number of grid cells
-    REAL,                         INTENT(IN)        :: dtime        ! time step size (s)
-    REAL, DIMENSION(knon,klev),   INTENT(IN)        :: ypplay       ! mid-layer pressure (Pa)
-    REAL, DIMENSION(knon,klev),   INTENT(IN)        :: ypaprs       ! pressure at layer interfaces (pa)
-    REAL, DIMENSION(knon),        INTENT(IN)        :: sigw         ! cold pools fractional area
-    REAL, DIMENSION(knon),        INTENT(IN)        :: beta         ! aridity factor
-    INTEGER,                      INTENT(IN)        :: iflag_split
-    REAL, DIMENSION(knon),        INTENT(IN)        :: Ts0_b9, dTs09
-    REAL, DIMENSION(knon),        INTENT(IN)        :: qs_b9, Ts_b9         ! yqsurf, Tsurf_new
-    REAL, DIMENSION(knon),        INTENT(IN)        :: dTs9, dqsatsrf9
-    REAL, DIMENSION(knon),        INTENT(IN)        :: AcoefT_x, AcoefT_w
-    REAL, DIMENSION(knon),        INTENT(IN)        :: BcoefT_x, BcoefT_w
-    REAL, DIMENSION(knon),        INTENT(IN)        :: AcoefT0, AcoefQ0, BcoefT0, BcoefQ0
-!
-    REAL, DIMENSION(knon),        INTENT(IN)        :: AcoefT, AcoefQ, BcoefT, BcoefQ
-    REAL, DIMENSION(knon),        INTENT(IN)        :: phiT_b9, phiQ_b9
-    REAL, DIMENSION(knon),        INTENT(IN)        :: phiT_x9, phiT_w9
-    REAL, DIMENSION(knon),        INTENT(IN)        :: phiQ_x9, phiQ_w9
-!
-!! Local variables
-    INTEGER                    :: j
-    REAL, DIMENSION(knon)      :: sigx                 ! fractional area of (x) region
-    REAL, DIMENSION(knon)      :: AcoefT_b, AcoefQ_b   ! mean values of AcoefT and AcoefQ 
-    REAL                       :: zzt, zzq, zzqsat
-    REAL                       :: zdelta, zcvm5, zcor, qsat
-    REAL, DIMENSION(knon)      :: qsat_w, qsat_x
-    REAL, DIMENSION(knon)      :: dqsatdT_w, dqsatdT_x
-    REAL, DIMENSION(knon)      :: qsat_bs              ! qsat(Ts_b)
-    REAL, DIMENSION(knon)      :: qsat01, dqsatdT01
-    REAL, DIMENSION(knon)      :: Ts_x, Ts_w, qs_x, qs_w
-    REAL, DIMENSION(knon)      :: T1_x, T1_w, q1_x, q1_w
-    REAL, DIMENSION(knon)      :: Rn_x, Rn_w
-    REAL, DIMENSION(knon)      :: phiQ0_x, phiQ0_w
-    REAL, DIMENSION(knon)      :: Ta, qa
-    REAL, DIMENSION(knon)      :: qsatsrf_w, qsatsrf_x, qsatsrf_b
-    REAL, DIMENSION(knon)      :: qsurf_w, qsurf_x
-    REAL                       :: dphiT, dphiQ
-    REAL                       :: dqsatsrf1
-    REAL                       :: phiT_w1, phiT_w2
-    REAL                       :: phiT_x1, phiT_x2
-    REAL                       :: phiQ_w1, phiQ_w2, phiQ_w3
-    REAL                       :: phiQ_x1, phiQ_x2, phiQ_x3
-    REAL                       :: phiT_b1, phiQ_b1
-    REAL                       :: Kech_Q_sw1, Kech_Q_sx1
-    REAL                       :: evap_pot
-
-!----------------------------------------------------------------------------
-! Equations to be checked:
-! -----------------------
-!  Input : Ts0_b, dTs0, Ts_b, dTs, qsatsrf_b, dqsatsrf, 
-!          phiT_b, phiQ_b, phiT_w, phiT_x, phiQ_w, phiQ_x, 
-!          
-!          AcoefT, AcoefQ, AcoefT_w, AcoefQ_w, AcoefT_x, AcoefQ_x,
-!          BcoefT, BcoefQ, BcoefT_w, BcoefQ_w, BcoefT_x, BcoefQ_x
-! 
-!  C_p T1_w = AcoefT_w + BcoefT_w phiT_w Delta t          C_p T1_x = AcoefT_x + BcoefT_x phiT_x Delta t
-!  q1_w = AQ_w + BQ_w phiQ_w Delta t                      q1_x = AQ_x + BQ_x phiQ_x Delta t
-!  qsatsrf_w = beta qsat(Ts_w)                            qsatsrf_x = beta qsat(Ts_x)
-!  qsurf_w = (1-beta) q1_w + qsatsrf_w                    qsurf_x = (1-beta) q1_x + qsatsrf_x
-!  phiT_w = Kech_h_w C_p ( T1_w - Ts_w)                   phiT_x = Kech_h_x C_p ( T1_x - Ts_x)             
-!  phiT_w = Kech_T_pw ( AcoefT_w - C_p Ts_w)              phiT_x = Kech_T_px ( AcoefT_x - C_p Ts_x)
-!  phiq_w = Kech_h_w ( beta q1_w - qsatsrf_w)             phiq_x = Kech_h_x ( beta q1_x - qsatsrf_x))
-!  phiq_w = Kech_Q_sw (beta AQ_w -qsatsrf_w)              phiq_x = Kech_Q_sx (beta AQ_x -qsatsrf_x)
-!  phiq_w = Kech_h_w (q1_w - qsurf_w)                     phiq_x = Kech_h_x (q1_x - qsurf_x)
-!  phiT_b = sigw phiT_w + sigx phiT_x                     dphiT = phiT_w - phiT_x
-!  phiQ_b = sigw phiQ_w + sigx phiQ_x                     dphiQ = phiQ_w - phiQ_x
-!  Ts_b = sigw Ts_w + sigx Ts_x                           dTs = Ts_w - Ts_x
-!  qsatsrf_b = sigw qsatsrf_w + sigx qsatsrf_x
-!  C_p Ta = AcoefT + BcoefT phiT_b Delta t
-!  qa = AcoefQ + BcoefQ phiQ_b Delta t
-!  phiT_b = Kech_h C_p (Ta - Ts_b)
-!  phiQ_b = beta Kech_h (qa - qsatsrf_b)
-!  dTs = sqrt(tau)/I (dphit + L_v dphiq + dR)
-
-!----------------------------------------------------------------------------
-!
-!!
-        sigx(:) = 1.-sigw(:)
-        AcoefT_b(1:knon) = AcoefT_x(1:knon) + sigw(1:knon)*dd_AT(1:knon)
-        AcoefQ_b(1:knon) = AQ_x(1:knon) + sigw(1:knon)*dd_AQ(1:knon)
-
-! Compute the three qsat and dqsatdTs
-! ---------------------------------------------
-!!   C_p(1:knon) = RCpd
-!!   L_v(1:knon) = RLvtt
-    IF (prt_level >=10 ) THEN
-      print *,' AAAA wx_pbl_check, C_p(j), qsat0(j), Ts0(j) : ', C_p(:), qsat0(:), Ts0(:)
-    ENDIF ! (prt_level >=10 )
-!
-   DO j = 1, knon
-      zdelta = MAX(0.,SIGN(1.,RTT-Ts0_b9(j)))
-      zcvm5 = R5LES*(1.-zdelta) + R5IES*zdelta
-      qsat = R2ES*FOEEW(Ts0_b9(j),zdelta)/ypaprs(j,1)
-      qsat = MIN(0.5,qsat)
-      zcor = 1./(1.-RETV*qsat)
-      qsat01(j) = fqsat*qsat*zcor
-!!      dqsatdT0(j) = FOEDE(Ts0_b(j),zdelta,zcvm5,qsat0(j),zcor)/RLVTT    ! jyg 20210116
-!!      dqsatdT0(j) = (RLvtt*(1.-zdelta)+RLSTT*zdelta)*qsat0(j)/(Rv*Ts0_b(j)*Ts0_b(j))
-      dqsatdT01(j) = fqsat*FOEDE(Ts0_b9(j),zdelta,zcvm5,qsat01(j),zcor)
-   ENDDO
-!
-!--------------------------------------------------------------------------------------------------
-        IF (prt_level >=10 ) THEN
-!
-          DO j = 1, knon
-!
-   print *,'wx_pbl_check: Kech_h, Kech_q ', Kech_h(j), Kech_q(j)
-!
-  Ta(j) = (AcoefT(j) + BcoefT(j)*phiT_b9(j)*dtime)/C_p(j)
-  qa(j) = AcoefQ(j) + BcoefQ(j)*phiQ_b9(j)*dtime
-    print *, 'wx_pbl_check: j, Ta, qa ', Ta(j), qa(j)
-!
-  qsat_bs(j) = qsat01(j) + dqsatdT01(j)*(Ts_b9(j)-Ts0_b9(j))
-!
-   print *,'wx_pbl_check: qsat01, qsat_bs ', j,qsat01(j), qsat_bs(j)
-!
-  Ts_x(j) = Ts_b9(j) - sigw(j)*dTs9(j)
-  Ts_w(j) = Ts_b9(j) + sigx(j)*dTs9(j)
-    print *, 'wx_pbl_check: j, Ts_b9, Ts_w, Ts_x ', j, Ts_b9(j), Ts_w(j), Ts_x(j)
-!
-  qsat_x(j) = qsat0_x(j) + dqsatdT0_x(j)*(Ts_x(j)-Ts0_x(j))
-  qsat_w(j) = qsat0_w(j) + dqsatdT0_w(j)*(Ts_w(j)-Ts0_w(j))
-!
-   print *,'wx_pbl_check: qsat0_w, qsat0_x, qsat_w, qsat_x ', qsat0_w(j), qsat0_x(j), qsat_w(j), qsat_x(j)
-!
-  T1_x(j) = (AcoefT_x(j) + BcoefT_x(j)*phiT_x9(j)*dtime) / C_p(j)
-  T1_w(j) = (AcoefT_w(j) + BcoefT_w(j)*phiT_w9(j)*dtime) / C_p(j)
-    print *, 'wx_pbl_check: j, T1_w, T1_x ', j, T1_w(j), T1_x(j)
-!
-  q1_x(j) = AQ_x(j) + BQ_x(j)*phiQ_x9(j)*dtime
-  q1_w(j) = AQ_w(j) + BQ_w(j)*phiQ_w9(j)*dtime
-    print *, 'wx_pbl_check: j, q1_w, q1_x ', j, q1_w(j), q1_x(j)
-!
-   qsatsrf_x(j) = beta(j)*qsat_x(j)
-   qsatsrf_w(j) = beta(j)*qsat_w(j) 
-   qsatsrf_b(j) = sigw(j)*qsatsrf_w(j) + sigx(j)*qsatsrf_x(j)
-!
-   dqsatsrf1 = qsatsrf_w(j) - qsatsrf_x(j)
-    print *, 'wx_pbl_check: j, qsatsrf_w, qsatsrf_x, dqsatsrf1, dqsatsrf9 ', &
-                          qsatsrf_w(j), qsatsrf_x(j), dqsatsrf1, dqsatsrf9(j)
-!
-   qsurf_x(j) = (1-beta(j))*q1_x(j) + qsatsrf_x(j)
-   qsurf_w(j) = (1-beta(j))*q1_w(j) + qsatsrf_w(j)
-    print *, 'wx_pbl_check: j, qsurf_w, qsurf_x ', j, qsurf_w(j), qsurf_x(j)
-!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!  Test qsat01 = qsat0    et   dqsatdT01 = dqsatdT0
-!------------------------------------------------------------------------------------------------------
-   print *, 'wx_pbl_check: j, qsat01(j), qsat0(j) ', j, qsat01(j), qsat0(j)
-   print *, 'wx_pbl_check: j, dqsatdT01(j), dqsatdT0(j) ', j, dqsatdT01(j), dqsatdT0(j)
-!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!  Test Kexh_Q_sw = Kech_q_w/(1.-beta*Kech_q_w*BcoefQ)   Kexh_Q_sx = Kech_q_x/(1.-beta*Kech_q_x*BcoefQ)
-!------------------------------------------------------------------------------------------------------
-  Kech_Q_sx1 = Kech_q_x(j)/(1.-beta(j)*Kech_q_x(j)*BQ_x(j)*dtime)
-  Kech_Q_sw1 = Kech_q_w(j)/(1.-beta(j)*Kech_q_w(j)*BQ_w(j)*dtime)
-    print *, 'wx_pbl_check: j, Kech_Q_sx1, Kech_Q_sx(j)', j, Kech_Q_sx1, Kech_Q_sx(j)
-    print *, 'wx_pbl_check: j, Kech_Q_sw1, Kech_Q_sw(j)', j, Kech_Q_sw1, Kech_Q_sw(j)
-!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!  Test phiT_w = Kech_h_w*C_p(j)*(T1_w(j)-Ts_w(j))        phiT_x = Kech_h_x*C_p(j)*(T1_x(j)-Ts_x(j))
-!-----------------------------------------------------
-    phiT_x1 = Kech_h_x(j)*C_p(j)*(T1_x(j)-Ts_x(j))
-    phiT_w1 = Kech_h_w(j)*C_p(j)*(T1_w(j)-Ts_w(j))
-!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!  Test phiT_w = Kech_T_pw*(AcoefT_w(j)-C_p(j)*Ts_w(j))   phiT_x = Kech_T_px*(AcoefT_x(j)-C_p(j)*Ts_x(j))
-!-----------------------------------------------------
-    phiT_x2 = Kech_T_px(j)*(AcoefT_x(j)-C_p(j)*Ts_x(j))
-    phiT_w2 = Kech_T_pw(j)*(AcoefT_w(j)-C_p(j)*Ts_w(j))
-    print *, 'wx_pbl_check: j, phiT_w1, phiT_w2, phiT_w9 ', j, phiT_w1, phiT_w2, phiT_w9(j)
-    print *, 'wx_pbl_check: j, phiT_x1, phiT_x2, phiT_x9 ', j, phiT_x1, phiT_x2, phiT_x9(j)
-!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!  Test phiq_w = Kech_q_w ( beta q1_w - qsatsrf_w)    phiq_x = Kech_q_x ( beta q1_x - qsatsrf_x))
-!--------------------------------------------------------------
-    phiq_x1 = Kech_q_x(j)*( beta(j)*q1_x(j) - qsatsrf_x(j))
-    phiq_w1 = Kech_q_w(j)*( beta(j)*q1_w(j) - qsatsrf_w(j))
-!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!  Test  phiq_w = Kech_Q_sw (beta AQ_w -qsatsrf_w)     phiq_x = Kech_Q_sx (beta AQ_x -qsatsrf_x)
-!--------------------------------------------------------------
-    phiq_x2 = Kech_Q_sx(j)*(beta(j)*AQ_x(j) -qsatsrf_x(j))
-    phiq_w2 = Kech_Q_sw(j)*(beta(j)*AQ_w(j) -qsatsrf_w(j))
-!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!  Test phiq_w = Kech_q_w ( q1_w - qsurf_w)    phiq_x = Kech_q_x ( q1_x - qsurf_x))
-!--------------------------------------------------------------
-    phiq_x3 = Kech_q_x(j)*( q1_x(j) - qsurf_x(j))
-    phiq_w3 = Kech_q_w(j)*( q1_w(j) - qsurf_w(j))
-    print *, 'wx_pbl_check: j, phiQ_w1, phiQ_w2, phiQ_w3, phiQ_w9 ', j, phiQ_w1, phiQ_w2, phiQ_w3, phiQ_w9(j)
-    print *, 'wx_pbl_check: j, phiQ_x1, phiQ_x2, phiQ_x3, phiQ_x9 ', j, phiQ_x1, phiQ_x2, phiQ_x3, phiQ_x9(j)
-!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!  Test phiT_b = Kech_h C_p (Ta - Ts_b)
-!--------------------------------------------------------------
-   phiT_b1 = Kech_h(j)*C_p(j)*(Ta(j) - Ts_b9(j))
-   print *, 'wx_pbl_check: j, phiT_b1, PhiT_b9 ', j, phiT_b1, PhiT_b9(j)
-!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!  Test phiQ_b = beta Kech_q (qa - qsat_bs)
-!--------------------------------------------------------------
-   evap_pot = Kech_q(j)*(qa(j) - qsat_bs(j))
-   phiQ_b1 = beta(j)*Kech_q(j)*(qa(j) - qsat_bs(j))
-   print *, 'wx_pbl_check: j, beta, evap_pot, phiQ_b1, PhiQ_b9 ', j, beta(j), evap_pot, phiQ_b1, PhiQ_b9(j)
-!
-!
-          ENDDO  ! j = 1, knon
-          
-        ENDIF   ! (prt_level >=10 )
-!--------------------------------------------------------------------------------------------------
-
-        RETURN
-
-END SUBROUTINE wx_pbl_check
-
-SUBROUTINE wx_pbl_dts_check( knon, dtime, ypplay, ypaprs, &
-                               sigw, beta, iflag_split,   &
-                               Ts0_b9, dTs09,   &
-                               qs_b9, Ts_b9,  &                         ! yqsurf, Tsurf_new
-                               dqsatsrf9, dTs9, delta_qsurf9,   &
-                               AcoefT_x, AcoefT_w, &
-                               BcoefT_x, BcoefT_w, &
-                               AcoefT0, AcoefQ0, BcoefT0, BcoefQ0, &
-                               AcoefT,  AcoefQ,  BcoefT,  BcoefQ, &
-                               HTphiT_b, dd_HTphiT, HTphiQ_b, dd_HTphiQ, HTRn_b, dd_HTRn, &
-                               phiT0_b9, dphiT09, phiQ0_b9, dphiQ09, Rn0_b9, dRn09, &
-                               g_T, g_Q, &
-                               Gamma_phiT, Gamma_phiQ, &
-                               dTs_ins, dqsatsrf_ins, &
-                               phiT_b9, phiQ_b9,  &
-                               phiT_x9, phiT_w9, &
-                               phiQ_x9, phiQ_w9  &
-                               )
-!
-
-    USE wx_pbl_var_mod
-
-    USE print_control_mod, ONLY: prt_level,lunout
-!
-    INCLUDE "YOMCST.h"
-    INCLUDE "FCTTRE.h"
-    INCLUDE "YOETHF.h"
-!
-    INTEGER,                      INTENT(IN)        :: knon         ! number of grid cells
-    REAL,                         INTENT(IN)        :: dtime        ! time step size (s)
-    REAL, DIMENSION(knon,klev),   INTENT(IN)        :: ypplay       ! mid-layer pressure (Pa)
-    REAL, DIMENSION(knon,klev),   INTENT(IN)        :: ypaprs       ! pressure at layer interfaces (pa)
-    REAL, DIMENSION(knon),        INTENT(IN)        :: sigw         ! cold pools fractional area
-    REAL, DIMENSION(knon),        INTENT(IN)        :: beta         ! aridity factor
-    INTEGER,                      INTENT(IN)        :: iflag_split
-    REAL, DIMENSION(knon),        INTENT(IN)        :: Ts0_b9, dTs09
-    REAL, DIMENSION(knon),        INTENT(IN)        :: qs_b9, Ts_b9         ! yqsurf, Tsurf_new
-    REAL, DIMENSION(knon),        INTENT(IN)        :: dTs9, dqsatsrf9
-    REAL, DIMENSION(knon),        INTENT(IN)        :: delta_qsurf9
-    REAL, DIMENSION(knon),        INTENT(IN)        :: AcoefT_x, AcoefT_w
-    REAL, DIMENSION(knon),        INTENT(IN)        :: BcoefT_x, BcoefT_w
-    REAL, DIMENSION(knon),        INTENT(IN)        :: AcoefT0, AcoefQ0, BcoefT0, BcoefQ0
-!
-    REAL, DIMENSION(knon),        INTENT(IN)        :: AcoefT, AcoefQ, BcoefT, BcoefQ
-    REAL, DIMENSION(knon),        INTENT(IN)        :: HTphiT_b, dd_HTphiT, HTphiQ_b, dd_HTphiQ, HTRn_b, dd_HTRn
-    REAL, DIMENSION(knon),        INTENT(IN)        :: phiT0_b9, dphiT09, phiQ0_b9, dphiQ09, Rn0_b9, dRn09
-    REAL, DIMENSION(knon),        INTENT(IN)        :: g_T, g_Q
-    REAL, DIMENSION(knon),        INTENT(IN)        :: Gamma_phiT, Gamma_phiQ
-    REAL, DIMENSION(knon),        INTENT(IN)        :: dTs_ins, dqsatsrf_ins
-    REAL, DIMENSION(knon),        INTENT(IN)        :: phiT_b9, phiQ_b9
-    REAL, DIMENSION(knon),        INTENT(IN)        :: phiT_x9, phiT_w9
-    REAL, DIMENSION(knon),        INTENT(IN)        :: phiQ_x9, phiQ_w9
-!
-!! Local variables
-    INTEGER                    :: j
-    REAL, DIMENSION(knon)      :: sigx       ! fractional area of (x) region
-    REAL, DIMENSION(knon)      :: AcoefT_b, AcoefQ_b   ! mean values of AcoefT and AcoefQ 
-    REAL                       :: zzt, zzq, zzqsat
-    REAL                       :: zdelta, zcvm5, zcor, qsat
-    REAL, DIMENSION(knon)      :: qsat_w, qsat_x
-    REAL, DIMENSION(knon)      :: Ts_x, Ts_w, qs_x, qs_w
-    REAL, DIMENSION(knon)      :: T1_x, T1_w, q1_x, q1_w
-    REAL, DIMENSION(knon)      :: Rn_x, Rn_w
-    REAL, DIMENSION(knon)      :: Rn_b, dRn
-    REAL, DIMENSION(knon)      :: phiQ0_x, phiQ0_w
-    REAL, DIMENSION(knon)      :: Ta, qa
-    REAL, DIMENSION(knon)      :: err_phiT_w, err_phiT_x
-    REAL, DIMENSION(knon)      :: err_phiq_w, err_phiq_x
-    REAL, DIMENSION(knon)      :: err_phiT_b
-    REAL, DIMENSION(knon)      :: err_phiQ_b
-    REAL, DIMENSION(knon)      :: err2_phiT_b
-    REAL                       :: T1A_x, T1A_w, q1A_x, q1A_w
-    REAL                       :: qsatsrf_w, qsatsrf_x, qsatsrfb, qsbA
-    REAL                       :: dphiT, dphiQ
-    REAL                       :: dphiT_H, dphiQ_H
-    REAL                       :: phiQ_pot
-    REAL                       :: phiQ_w_m_phiQ0_w
-    REAL                       :: phiQ_x_m_phiQ0_x
-    REAL                       :: dphiQ_m_dphiQ0
-    REAL                       :: dphiT_m_dphiT0
-    REAL                       :: dRN_m_dRn0
-    REAL                       :: phiTb_m_phiT0b
-
-!----------------------------------------------------------------------------
-! Equations to be checked:
-! -----------------------
-!  Input : Ts0_b, dTs0, Ts_b, dTs, qsatsrf_b, dqsatsrf, 
-!          phiT_b, phiQ_b, phiT_w, phiT_x, phiQ_w, phiQ_x, 
-!          
-!          AcoefT, AcoefQ, AcoefT_w, AcoefQ_w, AcoefT_x, AcoefQ_x,
-!          BcoefT, BcoefQ, BcoefT_w, BcoefQ_w, BcoefT_x, BcoefQ_x
-! 
-!  Ts_w = Ts_b + sigx dTs                                 Ts_x = Ts_b - sigw dTs
-!  T1_w = AcoefT_w + BcoefT_w phiT_w Delta t              T1_x = AcoefT_x + BcoefT_x phiT_x Delta t
-!  q1_w = AcoefQ_w + BcoefQ_w phiQ_w Delta t              q1_x = AcoefQ_x + BcoefQ_x phiQ_x Delta t
-!  phiT_w = Kech_h_w ( T1_w - Ts_w)                       phiT_x = Kech_h_x ( T1_x - Ts_x)             
-!  phiq_w = beta Kech_h_w ( q1_w - qsat(Ts_w))            phiq_x = beta Kech_h_x ( q1_x - qsat(Ts_x))
-!  phiT_b = sigw phiT_w + sigx phiT_x                     dphiT = phiT_w - phiT_x
-!  phiQ_b = sigw phiQ_w + sigx phiQ_x                     dphiQ = phiQ_w - phiQ_x
-!  Ts_b = sigw Ts_w + sigx Ts_x                           dTs = Ts_w - Ts_x
-!  Ta = AcoefT + BcoefT phiT_b Delta t
-!  qa = AcoefQ + BcoefQ phiQ_b Delta t
-!  phiT_b = Kech_h (Ta - Ts_b)
-!  phiQ_b = beta Kech_h (qa - qsat(Ts_b))
-!  dTs = sqrt(tau)/I (dphit + L_v dphiq + dR)
-
-!----------------------------------------------------------------------------
-!
-!!
-        sigx(:) = 1.-sigw(:)
-        AcoefT_b(1:knon) = AcoefT_x(1:knon) + sigw(1:knon)*dd_AT(1:knon)
-        AcoefQ_b(1:knon) = AQ_x(1:knon) + sigw(1:knon)*dd_AQ(1:knon)
-
-   IF (prt_level >=10 ) THEN
-    print *,'->wx_pbl_dts_check, HTphiT_b, HTphiQ_b, HTRn_b ', &
-                             HTphiT_b, HTphiQ_b, HTRn_b 
-    print *,'->wx_pbl_dts_check, dd_HTphiT, dd_HTphiQ, dd_HTRn ', &
-                             dd_HTphiT, dd_HTphiQ, dd_HTRn 
-   ENDIF ! (prt_level >=10 )
-!
-! Compute the three qsat and dqsatdTs
-! ---------------------------------------------
-!!      print *,' AAAA wx_pbl_dts_check, C_p(j), qsat0(j), Ts0(j) : ',  &
-!!                                      (C_p(j), qsat0(j), Ts0(j), j = 1,knon)
-!
-!
-!--------------------------------------------------------------------------------------------------
-        IF (prt_level >=10 ) THEN
-!
-          DO j = 1, knon
-  Ts_x(j) = Ts_b9(j) - sigw(j)*dTs9(j)
-  Ts_w(j) = Ts_b9(j) + sigx(j)*dTs9(j)
-    print *, 'wx_pbl_dts_check: j, Ts_b9, Ts_w, Ts_x ', j, Ts_b9(j), Ts_w(j), Ts_x(j)
-!
-  qsat_x(j) = qsat0_x(j) + dqsatdT0_x(j)*(Ts_x(j)-Ts0_x(j))
-  qsat_w(j) = qsat0_w(j) + dqsatdT0_w(j)*(Ts_w(j)-Ts0_w(j))
-!
-  T1_x(j) = (AcoefT_x(j) + BcoefT_x(j)*phiT_x9(j)*dtime) / C_p(j)
-  T1_w(j) = (AcoefT_w(j) + BcoefT_w(j)*phiT_w9(j)*dtime) / C_p(j)
-    print *, 'wx_pbl_dts_check: j, T1_w, T1_x ', j, T1_w(j), T1_x(j)
-!
-  q1_x(j) = AQ_x(j) + BQ_x(j)*phiQ_x9(j)*dtime
-  q1_w(j) = AQ_w(j) + BQ_w(j)*phiQ_w9(j)*dtime
-    print *, 'wx_pbl_dts_check: j, q1_w, q1_x ', j, q1_w(j), q1_x(j)
-!
-    Rn_x(j) = eps_1*Rsigma*T1_x(j)**4 - Rsigma*Ts_x(j)**4
-    Rn_w(j) = eps_1*Rsigma*T1_w(j)**4 - Rsigma*Ts_w(j)**4
-    Rn_b(j) = sigw(j)*Rn_w(j) + sigx(j)*Rn_x(j)
-    dRn(j) = dRn09(j) - ( HTRn_b(j) &
-                        +(sigx(j)-sigw(j))*dd_HTRn(j) &
-                        -sigw(j)*sigx(j)*dd_HTRn(j)*dd_HTphiT(j)/HTphiT_b(j) &
-                       )*(dTs9(j)-dTs09(j)) &
-                    + dd_HTRn(j)/HTphiT_b(j)*(phiT_b9(j)-phiT0_b9(j))
-!
-          print *,'wx_pbl_dts_check, dphiT, L_v*dphiQ, dRn, dTs ', &
-              phiT_w9(j)-phiT_x9(j), L_v(j)*(phiQ_w9(j)-phiQ_x9(j)), dRn(j), dTs9(j)
-!
-  phiQ0_x(j) = PhiQ0_b9(j) - sigw(j)*dphiQ09(j)
-  phiQ0_w(j) = PhiQ0_b9(j) + sigx(j)*dphiQ09(j)
-!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!  Test phiQ_w-phiQ0_w = -beta*Kech_Q_sw*dqsatdT_w*(Ts_w-Ts0_w)
-!--------------------------------------------------------------
-  print *,'wx_pbl_dts_check: beta(j), Kech_Q_sw(j), dqsatdT0_w(j), Ts_w(j), Ts0_w(j) ', &
-                         beta(j), Kech_Q_sw(j), dqsatdT0_w(j), Ts_w(j), Ts0_w(j)
-  phiQ_w_m_phiQ0_w = -beta(j)*Kech_Q_sw(j)*dqsatdT0_w(j)*(Ts_w(j)-Ts0_w(j))
-    print *,'wx_pbl_dts_check: j, phiQ_w9-phiQ0_w, phiQ_w_m_phiQ0_w ', &
-                           j, phiQ_w9(j)-phiQ0_w(j), phiQ_w_m_phiQ0_w
-!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!  Test phiQ_x-phiQ0_x = -beta*Kech_Q_sx*dqsatdT_x*(Ts_x-Ts0_x)
-!--------------------------------------------------------------
-  phiQ_x_m_phiQ0_x = -beta(j)*Kech_Q_sx(j)*dqsatdT0_x(j)*(Ts_x(j)-Ts0_x(j))
-    print *,'wx_pbl_dts_check: j, phiQ_x9-phiQ0_x, phiQ_x_m_phiQ0_x ', &
-                           j, phiQ_x9(j)-phiQ0_x(j), phiQ_x_m_phiQ0_x
-!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!  Test dphiT-dphiT0 = -(HTphiT_b+(sigx-sigw)*dd_HTphiT)*(dTs-dTs0) - dd_HTphiT*(Ts_b-Ts0_b)
-!-------------------------------------------------------------------------------------------
- dphiT = phiT_w9(j) - phiT_x9(j)
- dphiT_m_dphiT0 = -(HTphiT_b(j)+(sigx(j)-sigw(j))*dd_HTphiT(j))*(dTs9(j)-dTs09(j)) &
-                  - dd_HTphiT(j)*(Ts_b9(j)-Ts0_b9(j))
- print *,'wx_pbl_dts_check: j, dphiT-dphiT09, dphiT_m_dphiT0 ',j, dphiT-dphiT09(j), dphiT_m_dphiT0
-!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!  Test dphiQ-dphiQ0 = -(HTphiQ_b+(sigx-sigw)*dd_HTphiQ)*(dTs-dTs0) - dd_HTphiQ*(Ts_b-Ts0_b)
-!-------------------------------------------------------------------------------------------
- dphiQ = phiQ_w9(j) - phiQ_x9(j)
- dphiQ_m_dphiQ0 = -(HTphiQ_b(j)+(sigx(j)-sigw(j))*dd_HTphiQ(j))*(dTs9(j)-dTs09(j)) &
-                  - dd_HTphiQ(j)*(Ts_b9(j)-Ts0_b9(j))
- print *,'wx_pbl_dts_check: j, dphiQ-dphiQ09, dphiQ_m_dphiQ0 ',j, dphiQ-dphiQ09(j), dphiQ_m_dphiQ0
-!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!  Test dRn-dRn0 = -(HTRn_b+(sigx-sigw)*dd_HTRn)*(dTs-dTs0) - dd_HTRn*(Ts_b-Ts0_b)
-!-------------------------------------------------------------------------------------------
- dRn_m_dRn0 = -(HTRn_b(j)+(sigx(j)-sigw(j))*dd_HTRn(j))*(dTs9(j)-dTs09(j)) &
-                  - dd_HTRn(j)*(Ts_b9(j)-Ts0_b9(j))
- print *,'wx_pbl_dts_check: j, dRn-dRn09, dRn_m_dRn0 ',j, dRn-dRn09(j), dRn_m_dRn0
-!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!  Test phiT_b-phiT0_b = -sigx*sigw*dd_HTphiT*(dTs-dTs0) - HTphiT_b*(Ts_b-Ts0_b)
-!-------------------------------------------------------------------------------
-   phiTb_m_phiT0b = -sigx(j)*sigw(j)*dd_HTphiT(j)*(dTs9(j)-dTs09(j)) - HTphiT_b(j)*(Ts_b9(j)-Ts0_b9(j))
-   print *,'wx_pbl_dts_check: j, phiT_b9-phiT0_b9, phiTb_m_phiT0b ',j ,phiT_b9(j)-phiT0_b9(j), phiTb_m_phiT0b
-!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!  Test phiT_w, phiT_x, dphiT from HTphiT
-!------------------------------------------
-!  phiT_w = Kech_h_w C_p ( T1_w - Ts_w)                   phiT_x = Kech_h_x C_p ( T1_x - Ts_x)             
-  err_phiT_x(j) = Kech_h_x(j)*C_p(j)*(T1_x(j) - Ts_x(j)) - phiT_x9(j)
-  err_phiT_w(j) = Kech_h_w(j)*C_p(j)*(T1_w(j) - Ts_w(j)) - phiT_w9(j)
-    print *, 'wx_pbl_dts_check: j, phiT_w9, phiT_x9, err_phiT_w, err_phiT_x ',   &
-                            j, phiT_w9(j), phiT_x9(j), err_phiT_w(j), err_phiT_x(j)
-  dphiT = phiT_w9(j) - phiT_x9(j)
-  dphiT_H = dphiT09(j) - ( HTphiT_b(j) &
-                            +(sigx(j)-sigw(j))*dd_HTphiT(j) &
-                            -sigw(j)*sigx(j)*dd_HTphiT(j)*dd_HTphiT(j)/HTphiT_b(j) &
-                           )*(dTs9(j)-dTs09(j)) &
-                         + dd_HTphiT(j)/HTphiT_b(j)*(phiT_b9(j)-phiT0_b9(j))
-    print *,'wx_pbl_dts_check: j, dphiT, dphiT_H ', j, dphiT, dphiT_H
-
-!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!  Test phiq_w, phiq_x, dphiq from HTphiq
-!------------------------------------------
-!
-!  phiq_w = beta Kech_q_w ( q1_w - qsat(Ts_w))            phiq_x = beta Kech_q_x ( q1_x - qsat(Ts_x))
-  err_phiq_x(j) = beta(j)*Kech_q_x(j)*( q1_x(j) - qsat_x(j)) - phiq_x9(j)
-  err_phiq_w(j) = beta(j)*Kech_q_w(j)*( q1_w(j) - qsat_w(j)) - phiq_w9(j)
-  dphiQ = phiQ_w9(j) - phiQ_x9(j)
-  dphiQ_H = dphiQ09(j) - ( HTphiQ_b(j) &
-                            +(sigx(j)-sigw(j))*dd_HTphiQ(j) &
-                            -sigw(j)*sigx(j)*dd_HTphiQ(j)*dd_HTphiT(j)/HTphiT_b(j) &
-                           )*(dTs9(j)-dTs09(j)) &
-                         + dd_HTphiQ(j)/HTphiT_b(j)*(phiT_b9(j)-phiT0_b9(j))
-    print *,'wx_pbl_dts_check: j, dphiQ, dphiQ_H ', j, dphiQ, dphiQ_H
-!
-!  phiT_b = sigw phiT_w + sigx phiT_x                     dphiT = phiT_w - phiT_x
-  err_phiT_b(j) = sigw(j)*phiT_w9(j) + sigx(j)*phiT_x9(j) - phiT_b9(j)
-!
-!  phiQ_b = sigw phiQ_w + sigx phiQ_x                     dphiQ = phiQ_w - phiQ_x
-  err_phiQ_b(j) = sigw(j)*phiQ_w9(j) + sigx(j)*phiQ_x9(j) - phiQ_b9(j)
-!
-!  Ta = AcoefT + BcoefT phiT_b Delta t
-!  phiT_b = Kech_h C_p (Ta - Ts_b)
-  Ta(j) = (AcoefT(j) + BcoefT(j)*phiT_b9(j)*dtime) / C_p(j)
-  err2_phiT_b(j) = Kech_h(j)*C_p(j)*(Ta(j) - Ts_b9(j)) - phiT_b9(j)
-    print *, 'wx_pbl_dts_check: j, Ta, phiT_b9, err2_phiT_b ',   &
-                            j, Ta(j), phiT_b9(j), err2_phiT_b(j)
-!
-          ENDDO  ! j = 1, knon
-          
-        ENDIF   ! (prt_level >=10 )
-!--------------------------------------------------------------------------------------------------
-        RETURN
-
-END SUBROUTINE wx_pbl_dts_check
-
-SUBROUTINE wx_evappot(knon, q1, Ts, evap_pot)
-
-    USE wx_pbl_var_mod
-
-    INTEGER,                      INTENT(IN)        :: knon     ! number of grid cells
-    REAL, DIMENSION(knon),        INTENT(IN)        :: q1       ! specific humidity in layer 1
-    REAL, DIMENSION(knon),        INTENT(IN)        :: Ts       ! surface temperature
-!
-    REAL, DIMENSION(knon),        INTENT(OUT)       :: evap_pot ! potential evaporation
-!
-    INTEGER                   :: j
-    REAL                      :: qsat_bs
-!
- DO j = 1,knon
-   evap_pot(j) = Kech_q(j)*(qsat0(j)+dqsatdT0(j)*(Ts(j)-Ts0(j))-q1(j))
-!
-  qsat_bs = qsat0(j)+dqsatdT0(j)*(Ts(j)-Ts0(j))
-!!  print *,'wx_evappot : Kech_q, qsat_bs, qa, evap_pot ', Kech_q(j), qsat_bs, q1(j), evap_pot(j)
- ENDDO
-!
- RETURN
-END SUBROUTINE wx_evappot
-
-END MODULE wx_pbl_mod
-
Index: /LMDZ6/trunk/libf/phylmd/wx_pbl_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/wx_pbl_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/wx_pbl_mod.f90	(revision 5268)
@@ -0,0 +1,1231 @@
+MODULE wx_pbl_mod
+!
+! Split Planetary Boundary Layer
+!
+! This module manages the splitting of the boundary layer between two regions; the (w) 
+! region (inside cold pools) and the (x) region (outside cold pools)
+!
+  USE dimphy
+
+  IMPLICIT NONE
+
+CONTAINS
+!
+!****************************************************************************************
+!
+SUBROUTINE wx_pbl0_merge(knon, ypplay, ypaprs,  &
+                                 sigw, dTs_forcing, dqs_forcing,  &
+                                 yt_x, yt_w, yq_x, yq_w, &
+                                 yu_x, yu_w, yv_x, yv_w, &
+                                 ycdragh_x, ycdragh_w, ycdragq_x, ycdragq_w, &
+                                 ycdragm_x, ycdragm_w, &
+                                 AcoefT_x, AcoefT_w, AcoefQ_x, AcoefQ_w, &
+                                 AcoefU_x, AcoefU_w, AcoefV_x, AcoefV_w, &
+                                 BcoefT_x, BcoefT_w, BcoefQ_x, BcoefQ_w, &
+                                 BcoefU_x, BcoefU_w, BcoefV_x, BcoefV_w, &
+                                 AcoefT, AcoefQ, AcoefU, AcoefV, &
+                                 BcoefT, BcoefQ, BcoefU, BcoefV, &
+                                 ycdragh, ycdragq, ycdragm, &
+                                 yt1, yq1, yu1, yv1 &
+                                 )
+!
+
+    USE wx_pbl_var_mod
+
+    USE print_control_mod, ONLY: prt_level,lunout
+    USE indice_sol_mod, ONLY: is_oce
+!
+    INCLUDE "YOMCST.h"
+    INCLUDE "FCTTRE.h"
+    INCLUDE "YOETHF.h"
+    INCLUDE "clesphys.h"
+!
+    INTEGER,                      INTENT(IN)        :: knon    ! number of grid cells
+    REAL, DIMENSION(knon,klev),   INTENT(IN)        :: ypplay  ! mid-layer pressure (Pa)
+    REAL, DIMENSION(knon,klev),   INTENT(IN)        :: ypaprs  ! pressure at layer interfaces (pa)
+    REAL, DIMENSION(knon),        INTENT(IN)        :: sigw ! cold pools fractional area
+    REAL, DIMENSION(knon),        INTENT(IN)        :: dTs_forcing ! forced temperature difference (w)-(x)
+    REAL, DIMENSION(knon),        INTENT(IN)        :: dqs_forcing ! forced humidity difference (w)-(x)
+    REAL, DIMENSION(knon,klev),   INTENT(IN)        :: yt_x, yt_w, yq_x, yq_w
+    REAL, DIMENSION(knon,klev),   INTENT(IN)        :: yu_x, yu_w, yv_x, yv_w
+    REAL, DIMENSION(knon),        INTENT(IN)        :: ycdragh_x, ycdragh_w, ycdragq_x, ycdragq_w
+    REAL, DIMENSION(knon),        INTENT(IN)        :: ycdragm_x, ycdragm_w
+    REAL, DIMENSION(knon),        INTENT(IN)        :: AcoefT_x, AcoefT_w, AcoefQ_x, AcoefQ_w
+    REAL, DIMENSION(knon),        INTENT(IN)        :: AcoefU_x, AcoefU_w, AcoefV_x, AcoefV_w
+    REAL, DIMENSION(knon),        INTENT(IN)        :: BcoefT_x, BcoefT_w, BcoefQ_x, BcoefQ_w
+    REAL, DIMENSION(knon),        INTENT(IN)        :: BcoefU_x, BcoefU_w, BcoefV_x, BcoefV_w
+    REAL, DIMENSION(knon),        INTENT(OUT)       :: AcoefT, AcoefQ, AcoefU, AcoefV
+    REAL, DIMENSION(knon),        INTENT(OUT)       :: BcoefT, BcoefQ, BcoefU, BcoefV
+    REAL, DIMENSION(knon),        INTENT(OUT)       :: ycdragh, ycdragq, ycdragm
+    REAL, DIMENSION(knon),        INTENT(OUT)       :: yt1, yq1, yu1, yv1  ! Apparent T, q, u, v at first level, as
+                                                                           !seen by surface modules
+!
+! Local variables
+    INTEGER                    :: j
+    REAL                       :: dd_Kh
+    REAL                       :: dd_Kq
+    REAL                       :: dd_Km
+    REAL                       :: dd_u 
+    REAL                       :: dd_v 
+    REAL                       :: dd_t 
+    REAL                       :: dd_q 
+!
+    REAL                       :: LambdaTs, LambdaQs, LambdaUs, LambdaVs 
+!
+    REAL, DIMENSION(knon)      :: sigx       ! fractional area of (x) region
+!
+!
+   sigx(1:knon) = 1.-sigw(1:knon)
+!                                           
+!
+        DO j=1,knon
+!
+!
+! Compute w-x differences
+       dd_t = yt_w(j,1) - yt_x(j,1)
+       dd_q = yq_w(j,1) - yq_x(j,1)
+       dd_u = yu_w(j,1) - yu_x(j,1)
+       dd_v = yv_w(j,1) - yv_x(j,1)
+!
+! Merged exchange coefficients
+         dd_Kh = Kech_h_w(j) - Kech_h_x(j)
+         dd_Kq = Kech_q_w(j) - Kech_q_x(j)
+         dd_Km = Kech_m_w(j) - Kech_m_x(j)
+!
+       LambdaTs = dd_KTp(j)/Kech_Tp(j)
+       LambdaQs = dd_KQs(j)/Kech_Qs(j)
+       LambdaUs = dd_KUp(j)/Kech_Up(j)
+       LambdaVs = dd_KVp(j)/Kech_Vp(j)
+!
+! Calcul des coef A, B \'equivalents dans la couche 1
+!
+! The dTs_forcing and dqs_forcing terms are added for diagnostic purpose ; they should be zero in normal operation.
+       AcoefT(j) = AcoefT_x(j) + sigw(j)*(1.+sigx(j)*LambdaTs)*(dd_AT(j) - C_p(j)*dTs_forcing(j))
+       AcoefQ(j) = AcoefQ_x(j) + sigw(j)*(1.+sigx(j)*LambdaQs)*(dd_AQ(j) - dqs_forcing(j))
+       AcoefU(j) = AcoefU_x(j) + sigw(j)*(1.+sigx(j)*LambdaUs)*dd_AU(j)
+       AcoefV(j) = AcoefV_x(j) + sigw(j)*(1.+sigx(j)*LambdaVs)*dd_AV(j)
+!                                           
+!
+!!       BcoefT(j) = (sigw(j)*Kech_h_w(j)*Kech_T_pw(j)*BcoefT_w(j) + &
+!!                sigx(j)*Kech_h_x(j)*Kech_T_px(j)*BcoefT_x(j) )/(Kech_h(j)*Kech_Tp(j))
+!!       BcoefQ(j) = (sigw(j)*Kech_q_w(j)*Kech_Q_pw(j)*BcoefQ_w(j) + &
+!!                sigx(j)*Kech_q_x(j)*Kech_Q_px(j)*BcoefQ_x(j) )/(Kech_q(j)*Kech_Qp(j))
+!!       BcoefU(j) = (sigw(j)*Kech_m_w(j)*Kech_U_pw(j)*BcoefU_w(j) + &
+!!                sigx(j)*Kech_m_x(j)*Kech_U_px(j)*BcoefU_x(j) )/(Kech_m(j)*Kech_Up(j))
+!!       BcoefV(j) = (sigw(j)*Kech_m_w(j)*Kech_V_pw(j)*BcoefV_w(j) + &
+!!                sigx(j)*Kech_m_x(j)*Kech_V_px(j)*BcoefV_x(j) )/(Kech_m(j)*Kech_Vp(j))
+!
+!!  Print *,'YYYYpbl0: BcoefT_x, sigw, sigx, dd_Kh, dd_KTp, Kech_h_w ', &
+!!                     BcoefT_x, sigw, sigx, dd_Kh, dd_KTp, Kech_h_w
+!!  Print *,'YYYYpbl0: Kech_T_pw, dd_BT, Kech_h, Kech_Tp ', &
+!!                     Kech_T_pw, dd_BT, Kech_h, Kech_Tp
+       BcoefT(j) = BcoefT_x(j) + sigw(j)*(sigx(j)*dd_Kh*dd_KTp(j)*BcoefT_x(j) + &
+                                  Kech_h_w(j)*Kech_T_pw(j)*dd_BT(j))/(Kech_h(j)*Kech_Tp(j))
+       BcoefQ(j) = BcoefQ_x(j) + sigw(j)*(sigx(j)*dd_Kq*dd_KQs(j)*BcoefQ_x(j) + &
+                                  Kech_q_w(j)*Kech_Q_sw(j)*dd_BQ(j))/(Kech_q(j)*Kech_Qs(j))
+       BcoefU(j) = BcoefU_x(j) + sigw(j)*(sigx(j)*dd_Km*dd_KUp(j)*BcoefU_x(j) + &
+                                  Kech_m_w(j)*Kech_U_pw(j)*dd_BU(j))/(Kech_m(j)*Kech_Up(j))
+       BcoefV(j) = BcoefV_x(j) + sigw(j)*(sigx(j)*dd_Km*dd_KVp(j)*BcoefV_x(j) + &
+                                  Kech_m_w(j)*Kech_V_pw(j)*dd_BV(j))/(Kech_m(j)*Kech_Vp(j))
+!>jyg
+!
+!
+! Calcul des cdrag \'equivalents dans la couche 
+!
+       ycdragm(j) = ycdragm_x(j) + sigw(j)*dd_Cdragm(j)
+       ycdragh(j) = ycdragh_x(j) + sigw(j)*dd_Cdragh(j)
+       ycdragq(j) = ycdragq_x(j) + sigw(j)*dd_Cdragq(j)
+!
+! Calcul de T, q, u et v \'equivalents dans la couche 1
+!!       yt1(j) = yt_x(j,1) + sigw(j)*dd_t*(1.+sigx(j)*dd_Kh/KCT)
+!!       yq1(j) = yq_x(j,1) + sigw(j)*dd_q*(1.+sigx(j)*dd_Kh/KCQ)
+!!       yu1(j) = yu_x(j,1) + sigw(j)*dd_u*(1.+sigx(j)*dd_Km/KCU)
+!!       yv1(j) = yv_x(j,1) + sigw(j)*dd_v*(1.+sigx(j)*dd_Km/KCV)
+       yt1(j) = yt_x(j,1) + sigw(j)*dd_t
+       yq1(j) = yq_x(j,1) + sigw(j)*dd_q
+       yu1(j) = yu_x(j,1) + sigw(j)*dd_u
+       yv1(j) = yv_x(j,1) + sigw(j)*dd_v
+
+
+        ENDDO
+
+        RETURN
+
+END SUBROUTINE wx_pbl0_merge
+
+SUBROUTINE wx_pbl_dts_merge(knon, dtime, ypplay, ypaprs, &
+                                 sigw, beta, wcstar, wdens, &
+                                 AT_x, AT_w, &
+                                 BT_x, BT_w, &
+                                 AcoefT0, AcoefQ0, BcoefT0, BcoefQ0, &
+                                 AcoefT,  AcoefQ,  BcoefT,  BcoefQ, &
+                                 HTphiT_b, dd_HTphiT, HTphiQ_b, dd_HTphiQ, HTRn_b, dd_HTRn, &
+                                 phiT0_b, dphiT0, phiQ0_b, dphiQ0, Rn0_b, dRn0, &
+                                 g_T, g_Q, &
+                                 Gamma_phiT, Gamma_phiQ, &
+                                 dTs_ins, dqsatsrf_ins &
+                                 )
+!
+
+    USE wx_pbl_var_mod
+
+    USE print_control_mod, ONLY: prt_level,lunout
+!
+    INCLUDE "YOMCST.h"
+    INCLUDE "FCTTRE.h"
+    INCLUDE "YOETHF.h"
+!
+    INTEGER,                      INTENT(IN)        :: knon    ! number of grid cells
+    REAL,                         INTENT(IN)        :: dtime   ! time step size (s)
+    REAL, DIMENSION(knon,klev),   INTENT(IN)        :: ypplay  ! mid-layer pressure (Pa)
+    REAL, DIMENSION(knon,klev),   INTENT(IN)        :: ypaprs  ! pressure at layer interfaces (pa)
+    REAL, DIMENSION(knon),        INTENT(IN)        :: sigw    ! cold pool fractional area
+    REAL, DIMENSION(knon),        INTENT(IN)        :: beta    ! evaporation by potential evaporation
+    REAL, DIMENSION(knon),        INTENT(IN)        :: wcstar   ! cold pool gust front speed
+    REAL, DIMENSION(knon),        INTENT(IN)        :: wdens    ! cold pool number density
+    REAL, DIMENSION(knon),        INTENT(IN)        :: AT_x, AT_w
+    REAL, DIMENSION(knon),        INTENT(IN)        :: BT_x, BT_w
+    REAL, DIMENSION(knon),        INTENT(IN)        :: AcoefT0, AcoefQ0, BcoefT0, BcoefQ0
+!
+    REAL, DIMENSION(knon),        INTENT(OUT)       :: AcoefT, AcoefQ, BcoefT, BcoefQ
+    REAL, DIMENSION(knon),        INTENT(OUT)       :: HTphiT_b, dd_HTphiT, HTphiQ_b, dd_HTphiQ, HTRn_b, dd_HTRn
+    REAL, DIMENSION(knon),        INTENT(OUT)       :: phiT0_b, dphiT0, phiQ0_b, dphiQ0, Rn0_b, dRn0
+    REAL, DIMENSION(knon),        INTENT(OUT)       :: g_T, g_Q
+    REAL, DIMENSION(knon),        INTENT(OUT)       :: Gamma_phiT, Gamma_phiQ
+    REAL, DIMENSION(knon),        INTENT(OUT)       :: dTs_ins, dqsatsrf_ins
+!
+! Local variables
+    REAL, DIMENSION(knon)      :: qsat_x
+    REAL, DIMENSION(knon)      :: qsat_w
+    REAL, DIMENSION(knon)      :: dqsatdT_x
+    REAL, DIMENSION(knon)      :: dqsatdT_w
+!
+    REAL, DIMENSION(knon)      :: T10_x
+    REAL, DIMENSION(knon)      :: T10_w
+    REAL, DIMENSION(knon)      :: phiT0_x
+    REAL, DIMENSION(knon)      :: phiT0_w
+    REAL, DIMENSION(knon)      :: phiQ0_x
+    REAL, DIMENSION(knon)      :: phiQ0_w
+    REAL, DIMENSION(knon)      :: Rn0_x
+    REAL, DIMENSION(knon)      :: Rn0_w
+    REAL, DIMENSION(knon)      :: Rp1_x
+    REAL, DIMENSION(knon)      :: Rp1_w
+    REAL, DIMENSION(knon)      :: Rps_x
+    REAL, DIMENSION(knon)      :: Rps_w
+!
+    REAL, DIMENSION(knon)      :: HTphiT_x
+    REAL, DIMENSION(knon)      :: HTphiT_w
+    REAL, DIMENSION(knon)      :: HTphiQ_x
+    REAL, DIMENSION(knon)      :: HTphiQ_w
+    REAL, DIMENSION(knon)      :: HTRn_x
+    REAL, DIMENSION(knon)      :: HTRn_w
+!
+    REAL, DIMENSION(knon)      :: HQphiT_x
+    REAL, DIMENSION(knon)      :: HQphiT_w
+    REAL, DIMENSION(knon)      :: HQphiQ_x
+    REAL, DIMENSION(knon)      :: HQphiQ_w
+    REAL, DIMENSION(knon)      :: HQRn_x
+    REAL, DIMENSION(knon)      :: HQRn_w
+!
+    REAL, DIMENSION(knon)      :: HQphiT_b
+    REAL, DIMENSION(knon)      :: dd_HQphiT
+    REAL, DIMENSION(knon)      :: HQphiQ_b
+    REAL, DIMENSION(knon)      :: dd_HQphiQ
+    REAL, DIMENSION(knon)      :: HQRn_b
+    REAL, DIMENSION(knon)      :: dd_HQRn
+!
+
+    REAL, DIMENSION(knon)    :: sigx
+!
+    REAL, DIMENSION(knon)    :: Ts, T1
+!!!    REAL, DIMENSION(knon)    :: qsat, dqsat_dT
+!!!    REAL, DIMENSION(knon)    :: phiT0
+!
+!!!    REAL, DIMENSION(knon)    :: Cp, Lv
+    REAL, DIMENSION(knon)    :: tau, Inert 
+!
+    REAL                     :: dd_Kh
+    REAL                     :: zdelta, zcvm5, zcor
+    REAL                     :: qsat
+!
+    INTEGER                  :: j
+
+
+!----------------------------------------------------------------------------
+!  Reference state
+!  ---------------
+!   dqsat_dT_w = dqsat_dT(Ts0_w)                          dqsat_dT_x = dqsat_dT(Ts0_x)
+!   T10_w = (AT_w/Cp - Kech_T_w BT_w dtime Ts0_w)/(1 - Kech_T_w BT_w dtime)
+!                                                T10_x = (AT_x/Cp - Kech_T_x BT_x dtime Ts0_x)/(1 - Kech_T_x BT_x dtime)
+!   phiT0_w = Kech_T_pw (AT_w - Cp Ts0_w)                 phiT0_x = Kech_T_px (AT_x - Cp Ts0_x)
+!   phiQ0_w = Kech_Q_sw (beta AQ_w - qsatsrf0_w)          phiQ0_x = Kech_Q_sx (beta AQ_x - qsatsrf0_x)
+!   Rn0_w = eps_1 Rsigma T10_w^4 - Rsigma Ts0_w^4         Rn0_x = eps_1 Rsigma T10_x^4 - Rsigma Ts0_x^4
+!   Rp1_w = 4 eps_1 Rsigma T10_w^3                        Rp1_x = 4 eps_1 Rsigma T10_x^3
+!   Rps_w = 4 Rsigma Ts0_w^3                              Rps_x = 4 Rsigma Ts0_x^3
+!
+!   phiT0_b = sigw phiT0_w + sigx phiT0_x
+!   dphiT0 = phiT0_w - phiT0_x
+!   phiQ0_b = sigw phiQ0_w + sigx phiQ0_x
+!   dphiQ0 = phiQ0_w - phiQ0_x
+!   Rn0_b = sigw Rn0_w + sigx Rn0_x
+    dRn0 = Rn0_w - Rn0_x
+!
+!
+!----------------------------------------------------------------------------
+!  Elementary enthalpy equations
+!  -----------------------------
+!   phiT_w = phiT0_w - HTphiT_w (Ts_w-Ts0_w)            phiT_x = phiT0_x - HTphiT_x (Ts_x-Ts0_x)
+!   phiQ_w = phiQ0_w - HTphiQ_w (Ts_w-Ts0_w)            phiQ_x = phiQ0_x - HTphiQ_x (Ts_x-Ts0_x)
+!   Rn_w   = Rn0_w   - HTRn_w   (Ts_w-Ts0_w)            Rn_x   = Rn0_x   - HTRn_x   (Ts_x-Ts0_x)
+!  DFlux_DT coefficients
+!  ---------------------
+!   Heat flux equation
+!     HTphiT_w = Cp Kech_T_pw                            HTphiT_x = Cp Kech_T_px
+!   Moisture flux equation
+!     HTphiQ_w = beta Kech_Q_sw dqsat_dT_w               HTphiQ_x = beta Kech_Q_sx dqsat_dT_x
+!   Radiation equation
+!     HTRn_w = Rp1_w Kech_T_pw BcoefT_w dtime + Rps_w    HTRn_x = Rp1_x Kech_T_px BcoefT_x dtime + Rps_x
+!
+!----------------------------------------------------------------------------
+!  Elementary moisture equations
+!  -----------------------------
+!   beta Ts_w   = beta Ts0_w    + QQ_w     (qsatsrf_w-qsatsrf0_w)    beta Ts_x   = beta Ts0_x    + QQ_x     (qsatsrf_x-qsatsrf0_x)
+!   beta phiT_w = beta phiT0_w - HQphiT_w (qsatsrf_w-qsatsrf0_w)    beta phiQ_x = beta phiQ0_x - HTphiQ_x (qsatsrf_x-qsatsrf0_x)
+!   beta phiQ_w = beta phiQ0_w - HQphiQ_w (qsatsrf_w-qsatsrf0_w)    beta phiQ_x = beta phiQ0_x - HTphiQ_x (qsatsrf_x-qsatsrf0_x)
+!   beta Rn_w   = beta Rn0_w   - HQRn_w   (qsatsrf_w-qsatsrf0_w)    beta Rn_x   = beta Rn0_x   - HTRn_x   (qsatsrf_x-qsatsrf0_x)
+!  DFluxDQ coefficients
+!  ---------------------
+!   dqsat_dT equation
+!     QQ_w = 1. / dqsat_dT_w                             QQ_x = 1. / dqsat_dT_x
+!   Heat flux equation
+!     HQphiT_w = Cp Kech_T_pw QQ_w                       HQphiT_x = Cp Kech_T_px QQ_x
+!   Moisture flux equation
+!     HQphiQ_w = beta Kech_Q_sw                          HQphiQ_x = beta Kech_Q_sx
+!   Radiation equation
+!     HQRn_w = (Rp1_w Kech_T_pw BcoefT_w dtime + Rps_w) QQ_w
+!                                         HQRn_x = (Rp1_x Kech_T_px BcoefT_x dtime + Rps_x) QQ_x
+!
+!----------------------------------------------------------------------------
+! Mean values and w-x differences
+! -------------------------------
+!  HTphiT_b = sigw HTphiT_w + sigx HTphiT_x               dd_HTphiT = HTphiT_w - HTphiT_x
+!  HTphiQ_b = sigw HTphiQ_w + sigx HTphiQ_x               dd_HTphiQ = HTphiQ_w - HTphiQ_x
+!  HTRn_b   = sigw HTRn_w   + sigx HTRn_x                 dd_HTRn   = HTRn_w   - HTRn_x
+!
+!  QQ_b     = sigw QQ_w     + sigx QQ_x                   dd_QQ     = QQ_w     - QQ_x
+!  HQphiT_b = sigw HQphiT_w + sigx HQphiT_x               dd_HQphiT = HQphiT_w - HQphiT_x
+!  HQphiQ_b = sigw HQphiQ_w + sigx HQphiQ_x               dd_HQphiQ = HQphiQ_w - HQphiQ_x
+!  HQRn_b   = sigw HQRn_w   + sigx HQRn_x                 dd_HQRn   = HQRn_w   - HQRn_x
+!
+!----------------------------------------------------------------------------
+!  Equations
+!  ---------
+! (1 - g_T) dTs    = dTs_ins    + Gamma_phiT phiT
+! (1 - g_Q) dqsatsrf = dqsatsrf_ins + Gamma_phiQ phiQ
+!
+! Feedback Gains
+! --------------
+! g_T = - (sqrt(tau)/I) [ HTphiT_b + Lv HTphiQ_b + HTRn_b +  &
+!                        (dd_HTphiT + Lv dd_HTphiQ + dd_HTRn) (sigx - sigw - sigw sigx dd_HTphiT/HTphiT_b) ]
+! g_Q = - (sqrt(tau)/(I QQ_b)) ( HQphiT_b + Lv HQphiQ_b + HQRn_b ) -  &
+!         (sigx - sigw - sigw sigx dd_HQphiQ/HQphiQ_b)   &
+!                          [ dd_QQ/QQ_b + (sqrt(tau)/(I QQ_b))(dd_HQphiT + Lv dd_HQphiQ + dd_HQRn) ]
+!
+!  Ts, qs Coupling coefficients                /
+!  ----------------------------
+! Gamma_phiT = (sqrt(tau)/(I HTphiT_b)) (dd_HTphiT + Lv dd_HTphiQ + dd_HTRn)
+! Gamma_phiQ = (1/(HQphiQ_b QQ_b)) [ dd_QQ +  (sqrt(tau)/(I )) (dd_HQphiT + Lv dd_HQphiQ + dd_HQRn) ]
+!
+!  Insensitive changes
+!  -------------------
+! dTs_ins    = (1 - g_T) dTs0    - Gamma_phiT phiT0_b
+! dqsatsrf_ins = (1 - g_Q) dqsatsrf0 - Gamma_phiQ phiQ0_b
+!
+!----------------------------------------------------------------------------
+!  Effective coefficients Acoef and Bcoef
+!  --------------------------------------
+!  Equations
+!  ---------
+! Cp Ta = AcoefT + BcoefT phiT dtime
+!    qa = AcoefQ + BcoefQ phiQ dtime
+!  Coefficients
+!  ------------
+! AcoefT = AcoefT0 - sigw sigx (dd_KTp/Kech_Tp) Cp dTs_ins/(1 - g_T)
+! BcoefT = BcoefT0 - sigw sigx (dd_KTp/Kech_Tp) Cp Gamma_phiT/(1 - g_T)/dtime
+!
+! AcoefQ = AcoefQ0 - sigw sigx (dd_KQp/Kech_Qp) dqs_ins/(1 - g_Q)
+! BcoefQ = BcoefQ0 - sigw sigx (dd_KQp/Kech_Qp) Gamma_phiq/(1 - g_Q)/dtime
+!
+!==============================================================================
+!
+!
+!  Parameters
+!  ----------
+   Inert(1:knon) = 2000.
+   tau(1:knon) = sqrt(sigw(1:knon)/max(rpi*wdens(1:knon)*wcstar(1:knon)**2 , &
+                                       sigw(1:knon)*1.e-12,smallestreal))
+   sigx(1:knon) = 1.-sigw(1:knon)
+!! Compute Cp, Lv, qsat, dqsat_dT.
+!   C_p(1:knon) = RCpd
+!   L_v(1:knon) = RLvtt
+!
+!      print *,' AAAA wx_pbl_dTs, C_p(j), qsat0(j), Ts0(j) : ', C_p(:), qsat0(:), Ts0(:)
+!
+!
+   T10_x(1:knon) = (AT_x(1:knon)/C_p(1:knon) - Kech_h_x(1:knon)*BT_x(1:knon)*dtime*Ts0_x(1:knon))/  &
+                   (1 - Kech_h_x(1:knon)*BT_x(1:knon)*dtime)
+   T10_w(1:knon) = (AT_w(1:knon)/C_p(1:knon) - Kech_h_w(1:knon)*BT_w(1:knon)*dtime*Ts0_w(1:knon))/  &
+                   (1 - Kech_h_w(1:knon)*BT_w(1:knon)*dtime)
+!
+   phiT0_x(1:knon) = Kech_T_px(1:knon)*(AT_x(1:knon) - C_p(1:knon)*Ts0_x(1:knon))
+   phiT0_w(1:knon) = Kech_T_pw(1:knon)*(AT_w(1:knon) - C_p(1:knon)*Ts0_w(1:knon))
+!
+   phiQ0_x(1:knon) = Kech_Q_sx(1:knon)*(beta(1:knon)*AQ_x(1:knon) - qsatsrf0_x(1:knon))
+   phiQ0_w(1:knon) = Kech_Q_sw(1:knon)*(beta(1:knon)*AQ_w(1:knon) - qsatsrf0_w(1:knon))
+!
+   Rn0_x(1:knon) = eps_1*Rsigma*T10_x(1:knon)**4 - Rsigma*Ts0_x(1:knon)**4
+   Rn0_w(1:knon) = eps_1*Rsigma*T10_w(1:knon)**4 - Rsigma*Ts0_w(1:knon)**4
+!
+   Rp1_x(1:knon) = 4*eps_1*Rsigma*T10_x(1:knon)**3
+   Rp1_w(1:knon) = 4*eps_1*Rsigma*T10_w(1:knon)**3
+!
+   Rps_x(1:knon) = 4*Rsigma*Ts0_x(1:knon)**3
+   Rps_w(1:knon) = 4*Rsigma*Ts0_w(1:knon)**3
+!
+!  DFlux_DT coefficients
+!  ---------------------
+!   Heat flux equation
+     HTphiT_x(1:knon) = C_p(1:knon)*Kech_T_px(1:knon)
+     HTphiT_w(1:knon) = C_p(1:knon)*Kech_T_pw(1:knon)                       
+!   Moisture flux equation
+     HTphiQ_x(1:knon) = beta(1:knon)*Kech_Q_sx(1:knon)*dqsatdT0_x(1:knon)
+     HTphiQ_w(1:knon) = beta(1:knon)*Kech_Q_sw(1:knon)*dqsatdT0_w(1:knon)          
+!   Radiation equation
+     HTRn_x(1:knon) = Rp1_x(1:knon)*Kech_T_px(1:knon)*BT_x(1:knon)*dtime + Rps_x(1:knon)
+     HTRn_w(1:knon) = Rp1_w(1:knon)*Kech_T_pw(1:knon)*BT_w(1:knon)*dtime + Rps_w(1:knon)  
+!
+!  DFluxDQ coefficients
+!  ---------------------
+!   Heat flux equation
+     HQphiT_x(1:knon) = C_p(1:knon)*Kech_T_px(1:knon)*QQ_x(1:knon)
+     HQphiT_w(1:knon) = C_p(1:knon)*Kech_T_pw(1:knon)*QQ_w(1:knon)                 
+!   Moisture flux equation
+     HQphiQ_x(1:knon) = beta(1:knon)*Kech_Q_sx(1:knon)
+     HQphiQ_w(1:knon) = beta(1:knon)*Kech_Q_sw(1:knon)                   
+!   Radiation equation
+     HQRn_x(1:knon) = (Rp1_x(1:knon)*Kech_T_px(1:knon)*BT_x(1:knon)*dtime + Rps_x(1:knon))*QQ_x(1:knon)
+     HQRn_w(1:knon) = (Rp1_w(1:knon)*Kech_T_pw(1:knon)*BT_w(1:knon)*dtime + Rps_w(1:knon))*QQ_w(1:knon)
+!
+! Mean values and w-x differences
+! -------------------------------
+  phiT0_b(1:knon) = sigw(1:knon)*phiT0_w(1:knon) + sigx(1:knon)*phiT0_x(1:knon)           
+  phiQ0_b(1:knon) = sigw(1:knon)*phiQ0_w(1:knon) + sigx(1:knon)*phiQ0_x(1:knon)          
+  Rn0_b(1:knon)   = sigw(1:knon)*Rn0_w(1:knon)   + sigx(1:knon)*Rn0_x(1:knon)          
+!
+  dphiT0(1:knon) = phiT0_w(1:knon) - phiT0_x(1:knon)           
+  dphiQ0(1:knon) = phiQ0_w(1:knon) - phiQ0_x(1:knon)          
+  dRn0(1:knon)   = Rn0_w(1:knon)   - Rn0_x(1:knon)          
+!
+  HTphiT_b(1:knon) = sigw(1:knon)*HTphiT_w(1:knon) + sigx(1:knon)*HTphiT_x(1:knon)           
+  dd_HTphiT(1:knon) = HTphiT_w(1:knon) - HTphiT_x(1:knon)
+!
+  HTphiQ_b(1:knon) = sigw(1:knon)*HTphiQ_w(1:knon) + sigx(1:knon)*HTphiQ_x(1:knon)          
+  dd_HTphiQ(1:knon) = HTphiQ_w(1:knon) - HTphiQ_x(1:knon)
+!
+  HTRn_b(1:knon)   = sigw(1:knon)*HTRn_w(1:knon)   + sigx(1:knon)*HTRn_x(1:knon)           
+  dd_HTRn(1:knon)   = HTRn_w(1:knon)   - HTRn_x(1:knon)
+!
+  HQphiT_b(1:knon) = sigw(1:knon)*HQphiT_w(1:knon) + sigx(1:knon)*HQphiT_x(1:knon)          
+  dd_HQphiT(1:knon) = HQphiT_w(1:knon) - HQphiT_x(1:knon)
+!
+  HQphiQ_b(1:knon) = sigw(1:knon)*HQphiQ_w(1:knon) + sigx(1:knon)*HQphiQ_x(1:knon)          
+  dd_HQphiQ(1:knon) = HQphiQ_w - HQphiQ_x(1:knon)
+!
+  HQRn_b(1:knon)   = sigw(1:knon)*HQRn_w(1:knon)   + sigx(1:knon)*HQRn_x(1:knon)             
+  dd_HQRn(1:knon)   = HQRn_w(1:knon)   - HQRn_x(1:knon)
+!
+! Feedback Gains
+! --------------
+ g_T(1:knon) = - (sqrt(tau(1:knon))/Inert(1:knon))  &
+               * (HTphiT_b(1:knon) + L_v(1:knon)*HTphiQ_b(1:knon) + HTRn_b(1:knon)  &
+                 + (dd_HTphiT(1:knon) + L_v(1:knon)*dd_HTphiQ(1:knon) + dd_HTRn(1:knon))  &
+                 * (sigx(1:knon) - sigw(1:knon) - sigw(1:knon)*sigx(1:knon)*dd_HTphiT(1:knon)/HTphiT_b(1:knon)) )
+!
+!!!! DO j = 1,knon
+!!!!  IF (mod(j,20) .eq.0) THEN
+!!!!   print *, '   j     dd_QQ       QQ_b  dd_HQphiQ  dd_HQphiT   dd_HQRn   HQphiQ_b   HQphiT_b     HQRn_b '
+!!!!  ENDIF
+!!!!   print 1789, j, dd_QQ(j), QQ_b(j), dd_HQphiQ(j), dd_HQphiT(j), dd_HQRn(j), HQphiQ_b(j), HQphiT_b(j), HQRn_b(j)
+!!!! 1789 FORMAT( I4, 10(1X,E10.2))
+!!!! ENDDO
+   g_Q(1:knon) = - (dd_QQ(1:knon)/QQ_b(1:knon)) *  &
+                    (sigx(1:knon)-sigw(1:knon)-sigw(1:knon)*sigx(1:knon)*dd_KQs(1:knon)/Kech_Qs(1:knon)) &
+                 - sqrt(tau(1:knon))/(Inert(1:knon)*QQ_b(1:knon)) *  &
+                   ( HQphiT_b(1:knon) + L_v(1:knon)*HQphiQ_b(1:knon) + HQRn_b(1:knon) +  & 
+                      (sigx(1:knon) - sigw(1:knon) - sigw(1:knon)*sigx(1:knon)*dd_KQs(1:knon)/Kech_Qs(1:knon)) *  &
+                       (dd_HQphiT(1:knon) + L_v(1:knon)*dd_HQphiQ(1:knon) + dd_HQRn(1:knon)) )
+
+!!   g_Q(1:knon) = - (dd_QQ(1:knon)/QQ_b(1:knon)) *  &
+!!                    (sigx(1:knon)-sigw(1:knon)-sigw(1:knon)*sigx(1:knon)*dd_HQphiQ(1:knon)/HQphiQ_b(1:knon)) &
+!!                 - sqrt(tau(1:knon))/(Inert(1:knon)*QQ_b(1:knon)) *  &
+!!                   ( HQphiT_b(1:knon) + L_v(1:knon)*HQphiQ_b(1:knon) + HQRn_b(1:knon) +  & 
+!!                      (sigx(1:knon) - sigw(1:knon) - sigw(1:knon)*sigx(1:knon)*dd_HQphiQ(1:knon)/HQphiQ_b(1:knon)) *  &
+!!                       (dd_HQphiT(1:knon) + L_v(1:knon)*dd_HQphiQ(1:knon) + dd_HQRn(1:knon)) )
+
+!! g_Q(1:knon) = - (sqrt(tau(1:knon))/(Inert(1:knon)*QQ_b(1:knon))) *  &
+!!                 ( HQphiT_b(1:knon) + L_v(1:knon)*HQphiQ_b(1:knon) + HQRn_b(1:knon) )  & 
+!!               - (sigx(1:knon) - sigw(1:knon) - sigw(1:knon)*sigx(1:knon)*dd_HQphiQ(1:knon)/HQphiQ_b(1:knon)) *   &
+!!                 ( dd_QQ(1:knon)/QQ_b(1:knon)   &
+!!                 + (sqrt(tau(1:knon))/(Inert(1:knon)*QQ_b(1:knon)))  &
+!!                 * (dd_HQphiT(1:knon) + L_v(1:knon)*dd_HQphiQ(1:knon) + dd_HQRn(1:knon)) )
+
+!  Ts, qs Coupling coefficients                /
+!  ----------------------------
+  Gamma_phiT(1:knon) = (sqrt(tau(1:knon))/(Inert(1:knon)*HTphiT_b(1:knon)))  &
+                     * (dd_HTphiT(1:knon) + L_v(1:knon)*dd_HTphiQ(1:knon) + dd_HTRn(1:knon))
+! 
+  Gamma_phiQ(1:knon) = (1./(Kech_Qs(1:knon)*QQ_b(1:knon))) * &
+                        ( dd_QQ(1:knon)   &
+                         + (sqrt(tau(1:knon))/(Inert(1:knon))) *  &
+                          (dd_HQphiT(1:knon) + L_v(1:knon)*dd_HQphiQ(1:knon) + dd_HQRn(1:knon)) )
+
+!!  Gamma_phiQ(1:knon) = (beta(1:knon)/(HQphiQ_b(1:knon)*QQ_b(1:knon))) * &
+!!                        ( dd_QQ(1:knon)   &
+!!                         + (sqrt(tau(1:knon))/(Inert(1:knon))) *  &
+!!                          (dd_HQphiT(1:knon) + L_v(1:knon)*dd_HQphiQ(1:knon) + dd_HQRn(1:knon)) )
+
+!!  Gamma_phiQ(1:knon) = (1/(HQphiQ_b(1:knon)*QQ_b(1:knon)))   &
+!!                     * ( dd_QQ(1:knon)   &
+!!                       + (sqrt(tau(1:knon))/(Inert(1:knon)))  &
+!!                       * (dd_HQphiT(1:knon) + L_v(1:knon)*dd_HQphiQ(1:knon) + dd_HQRn(1:knon)) )
+!
+!  Insensitive changes
+!  -------------------
+  dTs_ins(1:knon)    = (sqrt(tau(1:knon))/Inert(1:knon))*  &
+                       (dphiT0(1:knon) + L_v(1:knon)*dphiQ0(1:knon) + dRn0(1:knon))
+!
+  dqsatsrf_ins(1:knon) = (beta(1:knon)/QQ_b(1:knon))*dTs_ins(1:knon)
+!
+   IF (prt_level .Ge. 10) THEN
+      print *,'wx_pbl_merge, tau         ', tau
+      print *,'wx_pbl_merge, AcoefT0     ', AcoefT0
+      print *,'wx_pbl_merge, AcoefQ0     ', AcoefQ0
+      print *,'wx_pbl_merge, BcoefT0     ', BcoefT0
+      print *,'wx_pbl_merge, BcoefQ0     ', BcoefQ0
+      print *,'wx_pbl_merge, qsat0_w, qsat0_x ', (qsat0_w(j), qsat0_x(j),j=1,knon)
+      print *,'wx_pbl_merge, dqsatdT0_w, dqsatdT0_x ', (dqsatdT0_w(j), dqsatdT0_x(j),j=1,knon)
+   ENDIF
+!
+!----------------------------------------------------------------------------
+!  
+!------------------------------------------------------------------------------
+!  
+!    Effective coefficients Acoef and Bcoef
+!    --------------------------------------
+   DO j = 1,knon
+     AcoefT(j) = AcoefT0(j) - sigw(j)*sigx(j)*(dd_KTp(j)/Kech_Tp(j))*C_p(j)*   &
+                 (dTs0(j) + (dTs_ins(j)-dTs0(j)-Gamma_phiT(j)*phiT0_b(j))/(1. - g_T(j)))
+     BcoefT(j) = BcoefT0(j) - sigw(j)*sigx(j)*(dd_KTp(j)/Kech_Tp(j))*C_p(j)*Gamma_phiT(j)/(1. - g_T(j))/dtime
+     
+     AcoefQ(j) = AcoefQ0(j) - sigw(j)*sigx(j)*(dd_KQs(j)/Kech_Qs(j))*    &
+                 (dqsatsrf0(j) + (dqsatsrf_ins(j)-(beta(j)/QQ_b(j))*dTs0(j)-Gamma_phiQ(j)*phiQ0_b(j))/(1 - g_Q(j)))/ &
+                 max(beta(j),1.e-4)
+     BcoefQ(j) = BcoefQ0(j) - sigw(j)*sigx(j)*(dd_KQs(j)/Kech_Qs(j))*Gamma_phiQ(j)/(1 - g_Q(j))/ &
+                 (max(beta(j),1.e-4)*dtime)
+!!     AcoefQ(j) = AcoefQ0(j) - sigw(j)*sigx(j)*(dd_KQs(j)/Kech_Qs(j))*    &
+!!                 (dqsatsrf0(j) + (dqsatsrf_ins(j)-(beta(j)/QQ_b(j))*dTs0(j)-Gamma_phiQ(j)*phiQ0_b(j))/(1 - g_Q(j)))/ &
+!!                 beta(j)
+!!     BcoefQ(j) = BcoefQ0(j) - sigw(j)*sigx(j)*(dd_KQs(j)/Kech_Qs(j))*Gamma_phiQ(j)/(1 - g_Q(j))/(beta(j)*dtime)
+   ENDDO ! j = 1,knon
+   
+   IF (prt_level .Ge. 10) THEN
+   print *,'wx_pbl_dts AAAA BcoefQ, BcoefQ0, sigw ', &
+                            BcoefQ, BcoefQ0, sigw
+      print *,'wx_pbl_dts_merge, dTs_ins      ', dTs_ins
+      print *,'wx_pbl_dts_merge, dqs_ins      ', dqsatsrf_ins
+   ENDIF
+
+     RETURN
+
+END SUBROUTINE wx_pbl_dts_merge
+
+SUBROUTINE wx_pbl_split(knon, nsrf, dtime, sigw, beta, iflag_split, &
+                       g_T, g_Q, &
+                       Gamma_phiT, Gamma_phiQ, &
+                       dTs_ins, dqsatsrf_ins, &
+                       phiT, phiQ, phiU, phiV, &
+!!!!                       HTRn_b, dd_HTRn, HTphiT_b, dd_HTphiT, &
+                       phiQ0_b, phiT0_b, &
+                       phiT_x, phiT_w, &
+                       phiQ_x, phiQ_w, &
+                       phiU_x, phiU_w, &
+                       phiV_x, phiV_w, &
+                       philat_x, philat_w, &
+!!!!                       Rn_b, dRn, &
+                       dqsatsrf, &
+                       dTs, delta_qsurf &
+                       )
+!
+
+    USE wx_pbl_var_mod
+
+    USE print_control_mod, ONLY: prt_level,lunout
+    USE indice_sol_mod, ONLY: is_oce
+!
+    INCLUDE "YOMCST.h"
+!
+    INTEGER,                      INTENT(IN)        :: knon    ! number of grid cells
+    INTEGER,                      INTENT(IN)        :: nsrf    ! surface type
+    REAL,                         INTENT(IN)        :: dtime   ! time step size (s)
+    REAL, DIMENSION(knon),        INTENT(IN)        :: sigw ! cold pools fractional area
+    REAL, DIMENSION(knon),        INTENT(IN)        :: beta ! aridity factor
+    INTEGER,                      INTENT(IN)        :: iflag_split
+    REAL, DIMENSION(knon),        INTENT(IN)        :: g_T, g_Q
+    REAL, DIMENSION(knon),        INTENT(IN)        :: Gamma_phiT, Gamma_phiQ
+    REAL, DIMENSION(knon),        INTENT(IN)        :: dTs_ins, dqsatsrf_ins
+    REAL, DIMENSION(knon),        INTENT(IN)        :: phiT, phiQ, phiU, phiV
+    REAL, DIMENSION(knon),        INTENT(IN)        :: phiQ0_b, phiT0_b
+!
+    REAL, DIMENSION(knon),        INTENT(OUT)       :: phiT_x, phiT_w
+    REAL, DIMENSION(knon),        INTENT(OUT)       :: phiQ_x, phiQ_w
+    REAL, DIMENSION(knon),        INTENT(OUT)       :: phiU_x, phiU_w
+    REAL, DIMENSION(knon),        INTENT(OUT)       :: phiV_x, phiV_w
+    REAL, DIMENSION(knon),        INTENT(OUT)       :: philat_x, philat_w
+    REAL, DIMENSION(knon),        INTENT(OUT)       :: dqsatsrf      ! beta delta(qsat(Ts))
+    REAL, DIMENSION(knon),        INTENT(OUT)       :: dTs           ! Temperature difference at surface
+    REAL, DIMENSION(knon),        INTENT(OUT)       :: delta_qsurf
+!
+!! Local variables
+    INTEGER                    :: j
+    REAL, DIMENSION(knon)      :: dphiT, dphiQ, dphiU, dphiV
+    REAL, DIMENSION(knon)      :: q1_x, q1_w
+!
+    REAL, DIMENSION(knon)      :: sigx       ! fractional area of (x) region
+
+!----------------------------------------------------------------------------
+!  Equations
+!  ---------
+!!!!!! (1 - g_T) dTs    = dTs_ins    + Gamma_phiT phiT
+!!!!!! (1 - g_Q) dqsatsrf = dqsatsrf_ins + Gamma_phiQ phiQ
+!!!!!! dphiT = (dd_KTp/KTp) phiT + (     dd_AT - C_p dTs)*KxKwTp/KTp
+!!!!!! dphiQ = (dd_KQs/KQs) phiQ + (beta dd_AQ - dqsatsrf )*KxKwQs/KQs
+!!!!!! dphiU = (dd_KUp/KUp) phiU + (     dd_AU          )*KxKwUp/KUp
+!!!!!! dphiV = (dd_KVp/KVp) phiV + (     dd_AV          )*KxKwVp/KVp
+! 
+! (1 - g_T) (dTs-dTs0)    = dTs_ins-dTs0    + Gamma_phiT (phiT-phiT0)
+! (1 - g_Q) dqsatsrf = dqsatsrf_ins + Gamma_phiQ phiQ
+! dphiT = (dd_KTp/KTp) phiT + (     dd_AT - C_p dTs)*KxKwTp/KTp
+! dphiQ = (dd_KQs/KQs) phiQ + (beta dd_AQ - dqsatsrf )*KxKwQs/KQs
+! dphiU = (dd_KUp/KUp) phiU + (     dd_AU          )*KxKwUp/KUp
+! dphiV = (dd_KVp/KVp) phiV + (     dd_AV          )*KxKwVp/KVp
+! 
+!!
+        sigx(:) = 1.-sigw(:)
+!
+!      print *,' AAAA wx_pbl_split, C_p(j), qsat0(j), Ts0(j) : ', C_p(:), qsat0(:), Ts0(:)
+!
+   IF (iflag_split .EQ. 2 .AND. nsrf .NE. is_oce) THEN
+!
+!   Delta_tsurf and  Delta_qsurf computation
+!   -----------------------------------------
+      IF (prt_level >=10 ) THEN
+        print *,' wx_pbl_split, dTs_ins, dTs0 , Gamma_phiT, g_T ', dTs_ins, dTs0, Gamma_phiT, g_T
+        print *,' wx_pbl_split, dqsatsrf_ins, Gamma_phiQ, g_q ', dqsatsrf_ins, Gamma_phiQ, g_q
+      ENDIF
+!
+      DO j = 1,knon
+        dTs(j)    = dTs0(j) + (dTs_ins(j) - dTs0(j) + Gamma_phiT(j)*(phiT(j)-phiT0_b(j)) )/(1 - g_T(j)) 
+        dqsatsrf(j) = dqsatsrf0(j) + (dqsatsrf_ins(j) - (beta(j)/QQ_b(j))*dTs0(j) + &
+                       Gamma_phiQ(j)*(phiQ(j)-phiQ0_b(j)) )/(1 - g_Q(j)) 
+      ENDDO ! j = 1,knon
+!
+        IF (prt_level >=10 ) THEN
+          print *,' wx_pbl_split, dqsatsrf0, QQ_b ', dqsatsrf0, QQ_b
+          print *,' wx_pbl_split, phiT0_b, phiT, dTs ', phiT0_b, phiT, dTs
+          print *,' wx_pbl_split, phiQ0_b, phiQ, dqsatsrf ', phiQ0_b, phiQ, dqsatsrf
+        ENDIF
+   ELSE
+        dTs(:) = 0.
+        dqsatsrf(:) = 0.
+   ENDIF ! (iflag_split .EQ. 2 .AND. nsrf .NE. is_oce)
+!
+     DO j = 1,knon
+       dphiT(j) = (phiT(j)*dd_KTp(j) + (        dd_AT(j) - C_p(j)*dTs(j))*KxKwTp(j))/Kech_Tp(j)
+       dphiQ(j) = (phiQ(j)*dd_KQs(j) + (beta(j)*dd_AQ(j) -        dqsatsrf(j))*KxKwQs(j))/Kech_Qs(j)
+       dphiU(j) = (phiU(j)*dd_KUp(j) +          dd_AU(j)                 *KxKwUp(j))/Kech_Up(j)
+       dphiV(j) = (phiV(j)*dd_KVp(j) +          dd_AV(j)                 *KxKwVp(j))/Kech_Vp(j)
+!
+       phiT_x(j)=phiT(j) - sigw(j)*dphiT(j)
+       phiT_w(j)=phiT(j) + sigx(j)*dphiT(j)
+       phiQ_x(j)=phiQ(j) - sigw(j)*dphiQ(j)
+       phiQ_w(j)=phiQ(j) + sigx(j)*dphiQ(j)
+       phiU_x(j)=phiU(j) - sigw(j)*dphiU(j)
+       phiU_w(j)=phiU(j) + sigx(j)*dphiU(j)
+       phiV_x(j)=phiV(j) - sigw(j)*dphiV(j)
+       phiV_w(j)=phiV(j) + sigx(j)*dphiV(j)
+!
+       philat_x(j)=phiQ_x(j)*RLVTT
+       philat_w(j)=phiQ_w(j)*RLVTT
+     ENDDO ! j = 1,knon
+!
+     DO j = 1,knon
+       q1_x(j) = AQ_x(j) + BQ_x(j)*phiQ_x(j)*dtime
+       q1_w(j) = AQ_w(j) + BQ_w(j)*phiQ_w(j)*dtime
+     ENDDO ! j = 1,knon
+     DO j = 1,knon
+       delta_qsurf(j) = (1.-beta(j))*(q1_w(j) - q1_x(j)) + dqsatsrf(j)
+     ENDDO ! j = 1,knon
+!
+!!  Do j = 1,knon
+!!     print *,'XXXsplit : j, q1_x(j), AQ_x(j), BQ_x(j), phiQ_x(j) ', j, q1_x(j), AQ_x(j), BQ_x(j), phiQ_x(j)
+!!     print *,'XXXsplit : j, q1_w(j), AQ_w(j), BQ_w(j), phiQ_w(j) ', j, q1_w(j), AQ_w(j), BQ_w(j), phiQ_w(j)
+!!  ENDDO
+!
+        IF (prt_level >=10 ) THEN
+          print *,' wx_pbl_split, phiT, dphiT, dTs ', phiT, dphiT, dTs
+          print *,' wx_pbl_split, phiQ, dphiQ, dqsatsrf ', phiQ, dphiQ, dqsatsrf
+        ENDIF
+!
+        IF (prt_level >=10 ) THEN
+!!          print *,' wx_pbl_split, verif dqsatsrf = beta dqsatdT0 dTs '
+!!          print *,' wx_pbl_split, dqsatsrf, dqsatdT0*dTs ', dqsatsrf, dqsatdT0*dTs
+        ENDIF
+!
+!!    IF (knon .NE. 0) THEN
+!!       call  iophys_ecrit('sigw', 1,'sigw', '.',sigw)
+!!       call  iophys_ecrit('phit', 1,'phit', 'W/m2',phit)
+!!       call  iophys_ecrit('phit_w', 1,'phit_w', 'W/m2',phit_w)
+!!       call  iophys_ecrit('phit_x', 1,'phit_x', 'W/m2',phit_x)
+!!       call  iophys_ecrit('phiq', 1,'phiq', 'kg/m2/s',phiq)
+!!       call  iophys_ecrit('phiq_w', 1,'phiq_w', 'kg/m2/s',phiq_w)
+!!       call  iophys_ecrit('phiq_x', 1,'phiq_x', 'kg/m2/s',phiq_x)
+!!       call  iophys_ecrit('q1_w', 1,'q1_w', '.',q1_w)
+!!       call  iophys_ecrit('q1_x', 1,'q1_x', '.',q1_x)
+!!    ENDIF  ! (knon .NE. 0)
+!
+        RETURN
+
+END SUBROUTINE wx_pbl_split
+
+SUBROUTINE wx_pbl_check( knon, dtime, ypplay, ypaprs, &
+                               sigw, beta, iflag_split,   &
+                               Ts0_b9, dTs09,   &
+                               qs_b9, Ts_b9,  &                         ! yqsurf, Tsurf_new
+                               dTs9, dqsatsrf9,   &
+                               AcoefT_x, AcoefT_w, &
+                               BcoefT_x, BcoefT_w, &
+                               AcoefT0, AcoefQ0, BcoefT0, BcoefQ0, &
+                               AcoefT,  AcoefQ,  BcoefT,  BcoefQ, &
+                               phiT_b9, phiQ_b9,  &
+                               phiT_x9, phiT_w9, &
+                               phiQ_x9, phiQ_w9 &
+                               )
+!
+
+    USE wx_pbl_var_mod
+
+    USE print_control_mod, ONLY: prt_level,lunout
+!
+    INCLUDE "YOMCST.h"
+    INCLUDE "FCTTRE.h"
+    INCLUDE "YOETHF.h"
+!
+    INTEGER,                      INTENT(IN)        :: knon         ! number of grid cells
+    REAL,                         INTENT(IN)        :: dtime        ! time step size (s)
+    REAL, DIMENSION(knon,klev),   INTENT(IN)        :: ypplay       ! mid-layer pressure (Pa)
+    REAL, DIMENSION(knon,klev),   INTENT(IN)        :: ypaprs       ! pressure at layer interfaces (pa)
+    REAL, DIMENSION(knon),        INTENT(IN)        :: sigw         ! cold pools fractional area
+    REAL, DIMENSION(knon),        INTENT(IN)        :: beta         ! aridity factor
+    INTEGER,                      INTENT(IN)        :: iflag_split
+    REAL, DIMENSION(knon),        INTENT(IN)        :: Ts0_b9, dTs09
+    REAL, DIMENSION(knon),        INTENT(IN)        :: qs_b9, Ts_b9         ! yqsurf, Tsurf_new
+    REAL, DIMENSION(knon),        INTENT(IN)        :: dTs9, dqsatsrf9
+    REAL, DIMENSION(knon),        INTENT(IN)        :: AcoefT_x, AcoefT_w
+    REAL, DIMENSION(knon),        INTENT(IN)        :: BcoefT_x, BcoefT_w
+    REAL, DIMENSION(knon),        INTENT(IN)        :: AcoefT0, AcoefQ0, BcoefT0, BcoefQ0
+!
+    REAL, DIMENSION(knon),        INTENT(IN)        :: AcoefT, AcoefQ, BcoefT, BcoefQ
+    REAL, DIMENSION(knon),        INTENT(IN)        :: phiT_b9, phiQ_b9
+    REAL, DIMENSION(knon),        INTENT(IN)        :: phiT_x9, phiT_w9
+    REAL, DIMENSION(knon),        INTENT(IN)        :: phiQ_x9, phiQ_w9
+!
+!! Local variables
+    INTEGER                    :: j
+    REAL, DIMENSION(knon)      :: sigx                 ! fractional area of (x) region
+    REAL, DIMENSION(knon)      :: AcoefT_b, AcoefQ_b   ! mean values of AcoefT and AcoefQ 
+    REAL                       :: zzt, zzq, zzqsat
+    REAL                       :: zdelta, zcvm5, zcor, qsat
+    REAL, DIMENSION(knon)      :: qsat_w, qsat_x
+    REAL, DIMENSION(knon)      :: dqsatdT_w, dqsatdT_x
+    REAL, DIMENSION(knon)      :: qsat_bs              ! qsat(Ts_b)
+    REAL, DIMENSION(knon)      :: qsat01, dqsatdT01
+    REAL, DIMENSION(knon)      :: Ts_x, Ts_w, qs_x, qs_w
+    REAL, DIMENSION(knon)      :: T1_x, T1_w, q1_x, q1_w
+    REAL, DIMENSION(knon)      :: Rn_x, Rn_w
+    REAL, DIMENSION(knon)      :: phiQ0_x, phiQ0_w
+    REAL, DIMENSION(knon)      :: Ta, qa
+    REAL, DIMENSION(knon)      :: qsatsrf_w, qsatsrf_x, qsatsrf_b
+    REAL, DIMENSION(knon)      :: qsurf_w, qsurf_x
+    REAL                       :: dphiT, dphiQ
+    REAL                       :: dqsatsrf1
+    REAL                       :: phiT_w1, phiT_w2
+    REAL                       :: phiT_x1, phiT_x2
+    REAL                       :: phiQ_w1, phiQ_w2, phiQ_w3
+    REAL                       :: phiQ_x1, phiQ_x2, phiQ_x3
+    REAL                       :: phiT_b1, phiQ_b1
+    REAL                       :: Kech_Q_sw1, Kech_Q_sx1
+    REAL                       :: evap_pot
+
+!----------------------------------------------------------------------------
+! Equations to be checked:
+! -----------------------
+!  Input : Ts0_b, dTs0, Ts_b, dTs, qsatsrf_b, dqsatsrf, 
+!          phiT_b, phiQ_b, phiT_w, phiT_x, phiQ_w, phiQ_x, 
+!          
+!          AcoefT, AcoefQ, AcoefT_w, AcoefQ_w, AcoefT_x, AcoefQ_x,
+!          BcoefT, BcoefQ, BcoefT_w, BcoefQ_w, BcoefT_x, BcoefQ_x
+! 
+!  C_p T1_w = AcoefT_w + BcoefT_w phiT_w Delta t          C_p T1_x = AcoefT_x + BcoefT_x phiT_x Delta t
+!  q1_w = AQ_w + BQ_w phiQ_w Delta t                      q1_x = AQ_x + BQ_x phiQ_x Delta t
+!  qsatsrf_w = beta qsat(Ts_w)                            qsatsrf_x = beta qsat(Ts_x)
+!  qsurf_w = (1-beta) q1_w + qsatsrf_w                    qsurf_x = (1-beta) q1_x + qsatsrf_x
+!  phiT_w = Kech_h_w C_p ( T1_w - Ts_w)                   phiT_x = Kech_h_x C_p ( T1_x - Ts_x)             
+!  phiT_w = Kech_T_pw ( AcoefT_w - C_p Ts_w)              phiT_x = Kech_T_px ( AcoefT_x - C_p Ts_x)
+!  phiq_w = Kech_h_w ( beta q1_w - qsatsrf_w)             phiq_x = Kech_h_x ( beta q1_x - qsatsrf_x))
+!  phiq_w = Kech_Q_sw (beta AQ_w -qsatsrf_w)              phiq_x = Kech_Q_sx (beta AQ_x -qsatsrf_x)
+!  phiq_w = Kech_h_w (q1_w - qsurf_w)                     phiq_x = Kech_h_x (q1_x - qsurf_x)
+!  phiT_b = sigw phiT_w + sigx phiT_x                     dphiT = phiT_w - phiT_x
+!  phiQ_b = sigw phiQ_w + sigx phiQ_x                     dphiQ = phiQ_w - phiQ_x
+!  Ts_b = sigw Ts_w + sigx Ts_x                           dTs = Ts_w - Ts_x
+!  qsatsrf_b = sigw qsatsrf_w + sigx qsatsrf_x
+!  C_p Ta = AcoefT + BcoefT phiT_b Delta t
+!  qa = AcoefQ + BcoefQ phiQ_b Delta t
+!  phiT_b = Kech_h C_p (Ta - Ts_b)
+!  phiQ_b = beta Kech_h (qa - qsatsrf_b)
+!  dTs = sqrt(tau)/I (dphit + L_v dphiq + dR)
+
+!----------------------------------------------------------------------------
+!
+!!
+        sigx(:) = 1.-sigw(:)
+        AcoefT_b(1:knon) = AcoefT_x(1:knon) + sigw(1:knon)*dd_AT(1:knon)
+        AcoefQ_b(1:knon) = AQ_x(1:knon) + sigw(1:knon)*dd_AQ(1:knon)
+
+! Compute the three qsat and dqsatdTs
+! ---------------------------------------------
+!!   C_p(1:knon) = RCpd
+!!   L_v(1:knon) = RLvtt
+    IF (prt_level >=10 ) THEN
+      print *,' AAAA wx_pbl_check, C_p(j), qsat0(j), Ts0(j) : ', C_p(:), qsat0(:), Ts0(:)
+    ENDIF ! (prt_level >=10 )
+!
+   DO j = 1, knon
+      zdelta = MAX(0.,SIGN(1.,RTT-Ts0_b9(j)))
+      zcvm5 = R5LES*(1.-zdelta) + R5IES*zdelta
+      qsat = R2ES*FOEEW(Ts0_b9(j),zdelta)/ypaprs(j,1)
+      qsat = MIN(0.5,qsat)
+      zcor = 1./(1.-RETV*qsat)
+      qsat01(j) = fqsat*qsat*zcor
+!!      dqsatdT0(j) = FOEDE(Ts0_b(j),zdelta,zcvm5,qsat0(j),zcor)/RLVTT    ! jyg 20210116
+!!      dqsatdT0(j) = (RLvtt*(1.-zdelta)+RLSTT*zdelta)*qsat0(j)/(Rv*Ts0_b(j)*Ts0_b(j))
+      dqsatdT01(j) = fqsat*FOEDE(Ts0_b9(j),zdelta,zcvm5,qsat01(j),zcor)
+   ENDDO
+!
+!--------------------------------------------------------------------------------------------------
+        IF (prt_level >=10 ) THEN
+!
+          DO j = 1, knon
+!
+   print *,'wx_pbl_check: Kech_h, Kech_q ', Kech_h(j), Kech_q(j)
+!
+  Ta(j) = (AcoefT(j) + BcoefT(j)*phiT_b9(j)*dtime)/C_p(j)
+  qa(j) = AcoefQ(j) + BcoefQ(j)*phiQ_b9(j)*dtime
+    print *, 'wx_pbl_check: j, Ta, qa ', Ta(j), qa(j)
+!
+  qsat_bs(j) = qsat01(j) + dqsatdT01(j)*(Ts_b9(j)-Ts0_b9(j))
+!
+   print *,'wx_pbl_check: qsat01, qsat_bs ', j,qsat01(j), qsat_bs(j)
+!
+  Ts_x(j) = Ts_b9(j) - sigw(j)*dTs9(j)
+  Ts_w(j) = Ts_b9(j) + sigx(j)*dTs9(j)
+    print *, 'wx_pbl_check: j, Ts_b9, Ts_w, Ts_x ', j, Ts_b9(j), Ts_w(j), Ts_x(j)
+!
+  qsat_x(j) = qsat0_x(j) + dqsatdT0_x(j)*(Ts_x(j)-Ts0_x(j))
+  qsat_w(j) = qsat0_w(j) + dqsatdT0_w(j)*(Ts_w(j)-Ts0_w(j))
+!
+   print *,'wx_pbl_check: qsat0_w, qsat0_x, qsat_w, qsat_x ', qsat0_w(j), qsat0_x(j), qsat_w(j), qsat_x(j)
+!
+  T1_x(j) = (AcoefT_x(j) + BcoefT_x(j)*phiT_x9(j)*dtime) / C_p(j)
+  T1_w(j) = (AcoefT_w(j) + BcoefT_w(j)*phiT_w9(j)*dtime) / C_p(j)
+    print *, 'wx_pbl_check: j, T1_w, T1_x ', j, T1_w(j), T1_x(j)
+!
+  q1_x(j) = AQ_x(j) + BQ_x(j)*phiQ_x9(j)*dtime
+  q1_w(j) = AQ_w(j) + BQ_w(j)*phiQ_w9(j)*dtime
+    print *, 'wx_pbl_check: j, q1_w, q1_x ', j, q1_w(j), q1_x(j)
+!
+   qsatsrf_x(j) = beta(j)*qsat_x(j)
+   qsatsrf_w(j) = beta(j)*qsat_w(j) 
+   qsatsrf_b(j) = sigw(j)*qsatsrf_w(j) + sigx(j)*qsatsrf_x(j)
+!
+   dqsatsrf1 = qsatsrf_w(j) - qsatsrf_x(j)
+    print *, 'wx_pbl_check: j, qsatsrf_w, qsatsrf_x, dqsatsrf1, dqsatsrf9 ', &
+                          qsatsrf_w(j), qsatsrf_x(j), dqsatsrf1, dqsatsrf9(j)
+!
+   qsurf_x(j) = (1-beta(j))*q1_x(j) + qsatsrf_x(j)
+   qsurf_w(j) = (1-beta(j))*q1_w(j) + qsatsrf_w(j)
+    print *, 'wx_pbl_check: j, qsurf_w, qsurf_x ', j, qsurf_w(j), qsurf_x(j)
+!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!  Test qsat01 = qsat0    et   dqsatdT01 = dqsatdT0
+!------------------------------------------------------------------------------------------------------
+   print *, 'wx_pbl_check: j, qsat01(j), qsat0(j) ', j, qsat01(j), qsat0(j)
+   print *, 'wx_pbl_check: j, dqsatdT01(j), dqsatdT0(j) ', j, dqsatdT01(j), dqsatdT0(j)
+!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!  Test Kexh_Q_sw = Kech_q_w/(1.-beta*Kech_q_w*BcoefQ)   Kexh_Q_sx = Kech_q_x/(1.-beta*Kech_q_x*BcoefQ)
+!------------------------------------------------------------------------------------------------------
+  Kech_Q_sx1 = Kech_q_x(j)/(1.-beta(j)*Kech_q_x(j)*BQ_x(j)*dtime)
+  Kech_Q_sw1 = Kech_q_w(j)/(1.-beta(j)*Kech_q_w(j)*BQ_w(j)*dtime)
+    print *, 'wx_pbl_check: j, Kech_Q_sx1, Kech_Q_sx(j)', j, Kech_Q_sx1, Kech_Q_sx(j)
+    print *, 'wx_pbl_check: j, Kech_Q_sw1, Kech_Q_sw(j)', j, Kech_Q_sw1, Kech_Q_sw(j)
+!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!  Test phiT_w = Kech_h_w*C_p(j)*(T1_w(j)-Ts_w(j))        phiT_x = Kech_h_x*C_p(j)*(T1_x(j)-Ts_x(j))
+!-----------------------------------------------------
+    phiT_x1 = Kech_h_x(j)*C_p(j)*(T1_x(j)-Ts_x(j))
+    phiT_w1 = Kech_h_w(j)*C_p(j)*(T1_w(j)-Ts_w(j))
+!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!  Test phiT_w = Kech_T_pw*(AcoefT_w(j)-C_p(j)*Ts_w(j))   phiT_x = Kech_T_px*(AcoefT_x(j)-C_p(j)*Ts_x(j))
+!-----------------------------------------------------
+    phiT_x2 = Kech_T_px(j)*(AcoefT_x(j)-C_p(j)*Ts_x(j))
+    phiT_w2 = Kech_T_pw(j)*(AcoefT_w(j)-C_p(j)*Ts_w(j))
+    print *, 'wx_pbl_check: j, phiT_w1, phiT_w2, phiT_w9 ', j, phiT_w1, phiT_w2, phiT_w9(j)
+    print *, 'wx_pbl_check: j, phiT_x1, phiT_x2, phiT_x9 ', j, phiT_x1, phiT_x2, phiT_x9(j)
+!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!  Test phiq_w = Kech_q_w ( beta q1_w - qsatsrf_w)    phiq_x = Kech_q_x ( beta q1_x - qsatsrf_x))
+!--------------------------------------------------------------
+    phiq_x1 = Kech_q_x(j)*( beta(j)*q1_x(j) - qsatsrf_x(j))
+    phiq_w1 = Kech_q_w(j)*( beta(j)*q1_w(j) - qsatsrf_w(j))
+!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!  Test  phiq_w = Kech_Q_sw (beta AQ_w -qsatsrf_w)     phiq_x = Kech_Q_sx (beta AQ_x -qsatsrf_x)
+!--------------------------------------------------------------
+    phiq_x2 = Kech_Q_sx(j)*(beta(j)*AQ_x(j) -qsatsrf_x(j))
+    phiq_w2 = Kech_Q_sw(j)*(beta(j)*AQ_w(j) -qsatsrf_w(j))
+!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!  Test phiq_w = Kech_q_w ( q1_w - qsurf_w)    phiq_x = Kech_q_x ( q1_x - qsurf_x))
+!--------------------------------------------------------------
+    phiq_x3 = Kech_q_x(j)*( q1_x(j) - qsurf_x(j))
+    phiq_w3 = Kech_q_w(j)*( q1_w(j) - qsurf_w(j))
+    print *, 'wx_pbl_check: j, phiQ_w1, phiQ_w2, phiQ_w3, phiQ_w9 ', j, phiQ_w1, phiQ_w2, phiQ_w3, phiQ_w9(j)
+    print *, 'wx_pbl_check: j, phiQ_x1, phiQ_x2, phiQ_x3, phiQ_x9 ', j, phiQ_x1, phiQ_x2, phiQ_x3, phiQ_x9(j)
+!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!  Test phiT_b = Kech_h C_p (Ta - Ts_b)
+!--------------------------------------------------------------
+   phiT_b1 = Kech_h(j)*C_p(j)*(Ta(j) - Ts_b9(j))
+   print *, 'wx_pbl_check: j, phiT_b1, PhiT_b9 ', j, phiT_b1, PhiT_b9(j)
+!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!  Test phiQ_b = beta Kech_q (qa - qsat_bs)
+!--------------------------------------------------------------
+   evap_pot = Kech_q(j)*(qa(j) - qsat_bs(j))
+   phiQ_b1 = beta(j)*Kech_q(j)*(qa(j) - qsat_bs(j))
+   print *, 'wx_pbl_check: j, beta, evap_pot, phiQ_b1, PhiQ_b9 ', j, beta(j), evap_pot, phiQ_b1, PhiQ_b9(j)
+!
+!
+          ENDDO  ! j = 1, knon
+          
+        ENDIF   ! (prt_level >=10 )
+!--------------------------------------------------------------------------------------------------
+
+        RETURN
+
+END SUBROUTINE wx_pbl_check
+
+SUBROUTINE wx_pbl_dts_check( knon, dtime, ypplay, ypaprs, &
+                               sigw, beta, iflag_split,   &
+                               Ts0_b9, dTs09,   &
+                               qs_b9, Ts_b9,  &                         ! yqsurf, Tsurf_new
+                               dqsatsrf9, dTs9, delta_qsurf9,   &
+                               AcoefT_x, AcoefT_w, &
+                               BcoefT_x, BcoefT_w, &
+                               AcoefT0, AcoefQ0, BcoefT0, BcoefQ0, &
+                               AcoefT,  AcoefQ,  BcoefT,  BcoefQ, &
+                               HTphiT_b, dd_HTphiT, HTphiQ_b, dd_HTphiQ, HTRn_b, dd_HTRn, &
+                               phiT0_b9, dphiT09, phiQ0_b9, dphiQ09, Rn0_b9, dRn09, &
+                               g_T, g_Q, &
+                               Gamma_phiT, Gamma_phiQ, &
+                               dTs_ins, dqsatsrf_ins, &
+                               phiT_b9, phiQ_b9,  &
+                               phiT_x9, phiT_w9, &
+                               phiQ_x9, phiQ_w9  &
+                               )
+!
+
+    USE wx_pbl_var_mod
+
+    USE print_control_mod, ONLY: prt_level,lunout
+!
+    INCLUDE "YOMCST.h"
+    INCLUDE "FCTTRE.h"
+    INCLUDE "YOETHF.h"
+!
+    INTEGER,                      INTENT(IN)        :: knon         ! number of grid cells
+    REAL,                         INTENT(IN)        :: dtime        ! time step size (s)
+    REAL, DIMENSION(knon,klev),   INTENT(IN)        :: ypplay       ! mid-layer pressure (Pa)
+    REAL, DIMENSION(knon,klev),   INTENT(IN)        :: ypaprs       ! pressure at layer interfaces (pa)
+    REAL, DIMENSION(knon),        INTENT(IN)        :: sigw         ! cold pools fractional area
+    REAL, DIMENSION(knon),        INTENT(IN)        :: beta         ! aridity factor
+    INTEGER,                      INTENT(IN)        :: iflag_split
+    REAL, DIMENSION(knon),        INTENT(IN)        :: Ts0_b9, dTs09
+    REAL, DIMENSION(knon),        INTENT(IN)        :: qs_b9, Ts_b9         ! yqsurf, Tsurf_new
+    REAL, DIMENSION(knon),        INTENT(IN)        :: dTs9, dqsatsrf9
+    REAL, DIMENSION(knon),        INTENT(IN)        :: delta_qsurf9
+    REAL, DIMENSION(knon),        INTENT(IN)        :: AcoefT_x, AcoefT_w
+    REAL, DIMENSION(knon),        INTENT(IN)        :: BcoefT_x, BcoefT_w
+    REAL, DIMENSION(knon),        INTENT(IN)        :: AcoefT0, AcoefQ0, BcoefT0, BcoefQ0
+!
+    REAL, DIMENSION(knon),        INTENT(IN)        :: AcoefT, AcoefQ, BcoefT, BcoefQ
+    REAL, DIMENSION(knon),        INTENT(IN)        :: HTphiT_b, dd_HTphiT, HTphiQ_b, dd_HTphiQ, HTRn_b, dd_HTRn
+    REAL, DIMENSION(knon),        INTENT(IN)        :: phiT0_b9, dphiT09, phiQ0_b9, dphiQ09, Rn0_b9, dRn09
+    REAL, DIMENSION(knon),        INTENT(IN)        :: g_T, g_Q
+    REAL, DIMENSION(knon),        INTENT(IN)        :: Gamma_phiT, Gamma_phiQ
+    REAL, DIMENSION(knon),        INTENT(IN)        :: dTs_ins, dqsatsrf_ins
+    REAL, DIMENSION(knon),        INTENT(IN)        :: phiT_b9, phiQ_b9
+    REAL, DIMENSION(knon),        INTENT(IN)        :: phiT_x9, phiT_w9
+    REAL, DIMENSION(knon),        INTENT(IN)        :: phiQ_x9, phiQ_w9
+!
+!! Local variables
+    INTEGER                    :: j
+    REAL, DIMENSION(knon)      :: sigx       ! fractional area of (x) region
+    REAL, DIMENSION(knon)      :: AcoefT_b, AcoefQ_b   ! mean values of AcoefT and AcoefQ 
+    REAL                       :: zzt, zzq, zzqsat
+    REAL                       :: zdelta, zcvm5, zcor, qsat
+    REAL, DIMENSION(knon)      :: qsat_w, qsat_x
+    REAL, DIMENSION(knon)      :: Ts_x, Ts_w, qs_x, qs_w
+    REAL, DIMENSION(knon)      :: T1_x, T1_w, q1_x, q1_w
+    REAL, DIMENSION(knon)      :: Rn_x, Rn_w
+    REAL, DIMENSION(knon)      :: Rn_b, dRn
+    REAL, DIMENSION(knon)      :: phiQ0_x, phiQ0_w
+    REAL, DIMENSION(knon)      :: Ta, qa
+    REAL, DIMENSION(knon)      :: err_phiT_w, err_phiT_x
+    REAL, DIMENSION(knon)      :: err_phiq_w, err_phiq_x
+    REAL, DIMENSION(knon)      :: err_phiT_b
+    REAL, DIMENSION(knon)      :: err_phiQ_b
+    REAL, DIMENSION(knon)      :: err2_phiT_b
+    REAL                       :: T1A_x, T1A_w, q1A_x, q1A_w
+    REAL                       :: qsatsrf_w, qsatsrf_x, qsatsrfb, qsbA
+    REAL                       :: dphiT, dphiQ
+    REAL                       :: dphiT_H, dphiQ_H
+    REAL                       :: phiQ_pot
+    REAL                       :: phiQ_w_m_phiQ0_w
+    REAL                       :: phiQ_x_m_phiQ0_x
+    REAL                       :: dphiQ_m_dphiQ0
+    REAL                       :: dphiT_m_dphiT0
+    REAL                       :: dRN_m_dRn0
+    REAL                       :: phiTb_m_phiT0b
+
+!----------------------------------------------------------------------------
+! Equations to be checked:
+! -----------------------
+!  Input : Ts0_b, dTs0, Ts_b, dTs, qsatsrf_b, dqsatsrf, 
+!          phiT_b, phiQ_b, phiT_w, phiT_x, phiQ_w, phiQ_x, 
+!          
+!          AcoefT, AcoefQ, AcoefT_w, AcoefQ_w, AcoefT_x, AcoefQ_x,
+!          BcoefT, BcoefQ, BcoefT_w, BcoefQ_w, BcoefT_x, BcoefQ_x
+! 
+!  Ts_w = Ts_b + sigx dTs                                 Ts_x = Ts_b - sigw dTs
+!  T1_w = AcoefT_w + BcoefT_w phiT_w Delta t              T1_x = AcoefT_x + BcoefT_x phiT_x Delta t
+!  q1_w = AcoefQ_w + BcoefQ_w phiQ_w Delta t              q1_x = AcoefQ_x + BcoefQ_x phiQ_x Delta t
+!  phiT_w = Kech_h_w ( T1_w - Ts_w)                       phiT_x = Kech_h_x ( T1_x - Ts_x)             
+!  phiq_w = beta Kech_h_w ( q1_w - qsat(Ts_w))            phiq_x = beta Kech_h_x ( q1_x - qsat(Ts_x))
+!  phiT_b = sigw phiT_w + sigx phiT_x                     dphiT = phiT_w - phiT_x
+!  phiQ_b = sigw phiQ_w + sigx phiQ_x                     dphiQ = phiQ_w - phiQ_x
+!  Ts_b = sigw Ts_w + sigx Ts_x                           dTs = Ts_w - Ts_x
+!  Ta = AcoefT + BcoefT phiT_b Delta t
+!  qa = AcoefQ + BcoefQ phiQ_b Delta t
+!  phiT_b = Kech_h (Ta - Ts_b)
+!  phiQ_b = beta Kech_h (qa - qsat(Ts_b))
+!  dTs = sqrt(tau)/I (dphit + L_v dphiq + dR)
+
+!----------------------------------------------------------------------------
+!
+!!
+        sigx(:) = 1.-sigw(:)
+        AcoefT_b(1:knon) = AcoefT_x(1:knon) + sigw(1:knon)*dd_AT(1:knon)
+        AcoefQ_b(1:knon) = AQ_x(1:knon) + sigw(1:knon)*dd_AQ(1:knon)
+
+   IF (prt_level >=10 ) THEN
+    print *,'->wx_pbl_dts_check, HTphiT_b, HTphiQ_b, HTRn_b ', &
+                             HTphiT_b, HTphiQ_b, HTRn_b 
+    print *,'->wx_pbl_dts_check, dd_HTphiT, dd_HTphiQ, dd_HTRn ', &
+                             dd_HTphiT, dd_HTphiQ, dd_HTRn 
+   ENDIF ! (prt_level >=10 )
+!
+! Compute the three qsat and dqsatdTs
+! ---------------------------------------------
+!!      print *,' AAAA wx_pbl_dts_check, C_p(j), qsat0(j), Ts0(j) : ',  &
+!!                                      (C_p(j), qsat0(j), Ts0(j), j = 1,knon)
+!
+!
+!--------------------------------------------------------------------------------------------------
+        IF (prt_level >=10 ) THEN
+!
+          DO j = 1, knon
+  Ts_x(j) = Ts_b9(j) - sigw(j)*dTs9(j)
+  Ts_w(j) = Ts_b9(j) + sigx(j)*dTs9(j)
+    print *, 'wx_pbl_dts_check: j, Ts_b9, Ts_w, Ts_x ', j, Ts_b9(j), Ts_w(j), Ts_x(j)
+!
+  qsat_x(j) = qsat0_x(j) + dqsatdT0_x(j)*(Ts_x(j)-Ts0_x(j))
+  qsat_w(j) = qsat0_w(j) + dqsatdT0_w(j)*(Ts_w(j)-Ts0_w(j))
+!
+  T1_x(j) = (AcoefT_x(j) + BcoefT_x(j)*phiT_x9(j)*dtime) / C_p(j)
+  T1_w(j) = (AcoefT_w(j) + BcoefT_w(j)*phiT_w9(j)*dtime) / C_p(j)
+    print *, 'wx_pbl_dts_check: j, T1_w, T1_x ', j, T1_w(j), T1_x(j)
+!
+  q1_x(j) = AQ_x(j) + BQ_x(j)*phiQ_x9(j)*dtime
+  q1_w(j) = AQ_w(j) + BQ_w(j)*phiQ_w9(j)*dtime
+    print *, 'wx_pbl_dts_check: j, q1_w, q1_x ', j, q1_w(j), q1_x(j)
+!
+    Rn_x(j) = eps_1*Rsigma*T1_x(j)**4 - Rsigma*Ts_x(j)**4
+    Rn_w(j) = eps_1*Rsigma*T1_w(j)**4 - Rsigma*Ts_w(j)**4
+    Rn_b(j) = sigw(j)*Rn_w(j) + sigx(j)*Rn_x(j)
+    dRn(j) = dRn09(j) - ( HTRn_b(j) &
+                        +(sigx(j)-sigw(j))*dd_HTRn(j) &
+                        -sigw(j)*sigx(j)*dd_HTRn(j)*dd_HTphiT(j)/HTphiT_b(j) &
+                       )*(dTs9(j)-dTs09(j)) &
+                    + dd_HTRn(j)/HTphiT_b(j)*(phiT_b9(j)-phiT0_b9(j))
+!
+          print *,'wx_pbl_dts_check, dphiT, L_v*dphiQ, dRn, dTs ', &
+              phiT_w9(j)-phiT_x9(j), L_v(j)*(phiQ_w9(j)-phiQ_x9(j)), dRn(j), dTs9(j)
+!
+  phiQ0_x(j) = PhiQ0_b9(j) - sigw(j)*dphiQ09(j)
+  phiQ0_w(j) = PhiQ0_b9(j) + sigx(j)*dphiQ09(j)
+!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!  Test phiQ_w-phiQ0_w = -beta*Kech_Q_sw*dqsatdT_w*(Ts_w-Ts0_w)
+!--------------------------------------------------------------
+  print *,'wx_pbl_dts_check: beta(j), Kech_Q_sw(j), dqsatdT0_w(j), Ts_w(j), Ts0_w(j) ', &
+                         beta(j), Kech_Q_sw(j), dqsatdT0_w(j), Ts_w(j), Ts0_w(j)
+  phiQ_w_m_phiQ0_w = -beta(j)*Kech_Q_sw(j)*dqsatdT0_w(j)*(Ts_w(j)-Ts0_w(j))
+    print *,'wx_pbl_dts_check: j, phiQ_w9-phiQ0_w, phiQ_w_m_phiQ0_w ', &
+                           j, phiQ_w9(j)-phiQ0_w(j), phiQ_w_m_phiQ0_w
+!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!  Test phiQ_x-phiQ0_x = -beta*Kech_Q_sx*dqsatdT_x*(Ts_x-Ts0_x)
+!--------------------------------------------------------------
+  phiQ_x_m_phiQ0_x = -beta(j)*Kech_Q_sx(j)*dqsatdT0_x(j)*(Ts_x(j)-Ts0_x(j))
+    print *,'wx_pbl_dts_check: j, phiQ_x9-phiQ0_x, phiQ_x_m_phiQ0_x ', &
+                           j, phiQ_x9(j)-phiQ0_x(j), phiQ_x_m_phiQ0_x
+!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!  Test dphiT-dphiT0 = -(HTphiT_b+(sigx-sigw)*dd_HTphiT)*(dTs-dTs0) - dd_HTphiT*(Ts_b-Ts0_b)
+!-------------------------------------------------------------------------------------------
+ dphiT = phiT_w9(j) - phiT_x9(j)
+ dphiT_m_dphiT0 = -(HTphiT_b(j)+(sigx(j)-sigw(j))*dd_HTphiT(j))*(dTs9(j)-dTs09(j)) &
+                  - dd_HTphiT(j)*(Ts_b9(j)-Ts0_b9(j))
+ print *,'wx_pbl_dts_check: j, dphiT-dphiT09, dphiT_m_dphiT0 ',j, dphiT-dphiT09(j), dphiT_m_dphiT0
+!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!  Test dphiQ-dphiQ0 = -(HTphiQ_b+(sigx-sigw)*dd_HTphiQ)*(dTs-dTs0) - dd_HTphiQ*(Ts_b-Ts0_b)
+!-------------------------------------------------------------------------------------------
+ dphiQ = phiQ_w9(j) - phiQ_x9(j)
+ dphiQ_m_dphiQ0 = -(HTphiQ_b(j)+(sigx(j)-sigw(j))*dd_HTphiQ(j))*(dTs9(j)-dTs09(j)) &
+                  - dd_HTphiQ(j)*(Ts_b9(j)-Ts0_b9(j))
+ print *,'wx_pbl_dts_check: j, dphiQ-dphiQ09, dphiQ_m_dphiQ0 ',j, dphiQ-dphiQ09(j), dphiQ_m_dphiQ0
+!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!  Test dRn-dRn0 = -(HTRn_b+(sigx-sigw)*dd_HTRn)*(dTs-dTs0) - dd_HTRn*(Ts_b-Ts0_b)
+!-------------------------------------------------------------------------------------------
+ dRn_m_dRn0 = -(HTRn_b(j)+(sigx(j)-sigw(j))*dd_HTRn(j))*(dTs9(j)-dTs09(j)) &
+                  - dd_HTRn(j)*(Ts_b9(j)-Ts0_b9(j))
+ print *,'wx_pbl_dts_check: j, dRn-dRn09, dRn_m_dRn0 ',j, dRn-dRn09(j), dRn_m_dRn0
+!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!  Test phiT_b-phiT0_b = -sigx*sigw*dd_HTphiT*(dTs-dTs0) - HTphiT_b*(Ts_b-Ts0_b)
+!-------------------------------------------------------------------------------
+   phiTb_m_phiT0b = -sigx(j)*sigw(j)*dd_HTphiT(j)*(dTs9(j)-dTs09(j)) - HTphiT_b(j)*(Ts_b9(j)-Ts0_b9(j))
+   print *,'wx_pbl_dts_check: j, phiT_b9-phiT0_b9, phiTb_m_phiT0b ',j ,phiT_b9(j)-phiT0_b9(j), phiTb_m_phiT0b
+!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!  Test phiT_w, phiT_x, dphiT from HTphiT
+!------------------------------------------
+!  phiT_w = Kech_h_w C_p ( T1_w - Ts_w)                   phiT_x = Kech_h_x C_p ( T1_x - Ts_x)             
+  err_phiT_x(j) = Kech_h_x(j)*C_p(j)*(T1_x(j) - Ts_x(j)) - phiT_x9(j)
+  err_phiT_w(j) = Kech_h_w(j)*C_p(j)*(T1_w(j) - Ts_w(j)) - phiT_w9(j)
+    print *, 'wx_pbl_dts_check: j, phiT_w9, phiT_x9, err_phiT_w, err_phiT_x ',   &
+                            j, phiT_w9(j), phiT_x9(j), err_phiT_w(j), err_phiT_x(j)
+  dphiT = phiT_w9(j) - phiT_x9(j)
+  dphiT_H = dphiT09(j) - ( HTphiT_b(j) &
+                            +(sigx(j)-sigw(j))*dd_HTphiT(j) &
+                            -sigw(j)*sigx(j)*dd_HTphiT(j)*dd_HTphiT(j)/HTphiT_b(j) &
+                           )*(dTs9(j)-dTs09(j)) &
+                         + dd_HTphiT(j)/HTphiT_b(j)*(phiT_b9(j)-phiT0_b9(j))
+    print *,'wx_pbl_dts_check: j, dphiT, dphiT_H ', j, dphiT, dphiT_H
+
+!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!  Test phiq_w, phiq_x, dphiq from HTphiq
+!------------------------------------------
+!
+!  phiq_w = beta Kech_q_w ( q1_w - qsat(Ts_w))            phiq_x = beta Kech_q_x ( q1_x - qsat(Ts_x))
+  err_phiq_x(j) = beta(j)*Kech_q_x(j)*( q1_x(j) - qsat_x(j)) - phiq_x9(j)
+  err_phiq_w(j) = beta(j)*Kech_q_w(j)*( q1_w(j) - qsat_w(j)) - phiq_w9(j)
+  dphiQ = phiQ_w9(j) - phiQ_x9(j)
+  dphiQ_H = dphiQ09(j) - ( HTphiQ_b(j) &
+                            +(sigx(j)-sigw(j))*dd_HTphiQ(j) &
+                            -sigw(j)*sigx(j)*dd_HTphiQ(j)*dd_HTphiT(j)/HTphiT_b(j) &
+                           )*(dTs9(j)-dTs09(j)) &
+                         + dd_HTphiQ(j)/HTphiT_b(j)*(phiT_b9(j)-phiT0_b9(j))
+    print *,'wx_pbl_dts_check: j, dphiQ, dphiQ_H ', j, dphiQ, dphiQ_H
+!
+!  phiT_b = sigw phiT_w + sigx phiT_x                     dphiT = phiT_w - phiT_x
+  err_phiT_b(j) = sigw(j)*phiT_w9(j) + sigx(j)*phiT_x9(j) - phiT_b9(j)
+!
+!  phiQ_b = sigw phiQ_w + sigx phiQ_x                     dphiQ = phiQ_w - phiQ_x
+  err_phiQ_b(j) = sigw(j)*phiQ_w9(j) + sigx(j)*phiQ_x9(j) - phiQ_b9(j)
+!
+!  Ta = AcoefT + BcoefT phiT_b Delta t
+!  phiT_b = Kech_h C_p (Ta - Ts_b)
+  Ta(j) = (AcoefT(j) + BcoefT(j)*phiT_b9(j)*dtime) / C_p(j)
+  err2_phiT_b(j) = Kech_h(j)*C_p(j)*(Ta(j) - Ts_b9(j)) - phiT_b9(j)
+    print *, 'wx_pbl_dts_check: j, Ta, phiT_b9, err2_phiT_b ',   &
+                            j, Ta(j), phiT_b9(j), err2_phiT_b(j)
+!
+          ENDDO  ! j = 1, knon
+          
+        ENDIF   ! (prt_level >=10 )
+!--------------------------------------------------------------------------------------------------
+        RETURN
+
+END SUBROUTINE wx_pbl_dts_check
+
+SUBROUTINE wx_evappot(knon, q1, Ts, evap_pot)
+
+    USE wx_pbl_var_mod
+
+    INTEGER,                      INTENT(IN)        :: knon     ! number of grid cells
+    REAL, DIMENSION(knon),        INTENT(IN)        :: q1       ! specific humidity in layer 1
+    REAL, DIMENSION(knon),        INTENT(IN)        :: Ts       ! surface temperature
+!
+    REAL, DIMENSION(knon),        INTENT(OUT)       :: evap_pot ! potential evaporation
+!
+    INTEGER                   :: j
+    REAL                      :: qsat_bs
+!
+ DO j = 1,knon
+   evap_pot(j) = Kech_q(j)*(qsat0(j)+dqsatdT0(j)*(Ts(j)-Ts0(j))-q1(j))
+!
+  qsat_bs = qsat0(j)+dqsatdT0(j)*(Ts(j)-Ts0(j))
+!!  print *,'wx_evappot : Kech_q, qsat_bs, qa, evap_pot ', Kech_q(j), qsat_bs, q1(j), evap_pot(j)
+ ENDDO
+!
+ RETURN
+END SUBROUTINE wx_evappot
+
+END MODULE wx_pbl_mod
+
Index: DZ6/trunk/libf/phylmd/wx_pbl_var_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/wx_pbl_var_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,655 +1,0 @@
-MODULE wx_pbl_var_mod
-!
-! Split Planetary Boundary Layer variables
-!
-! This module manages the variables necessary for the splitting of the boundary layer 
-! 
-!
-  USE dimphy
-
-  IMPLICIT NONE
-
-  REAL, PROTECTED, SAVE                             :: eps_1, fqsat, smallestreal
-!$OMP THREADPRIVATE(eps_1, fqsat, smallestreal)
-!
-  REAL, ALLOCATABLE, PROTECTED, DIMENSION(:), SAVE  :: C_p, L_v
-!$OMP THREADPRIVATE(C_p, L_v)
-  REAL, ALLOCATABLE, PROTECTED, DIMENSION(:), SAVE  :: Ts0, dTs0
-!$OMP THREADPRIVATE(Ts0, dTs0)
-  REAL, ALLOCATABLE, PROTECTED, DIMENSION(:), SAVE  :: Ts0_x, Ts0_w
-!$OMP THREADPRIVATE(Ts0_x, Ts0_w)
-  REAL, ALLOCATABLE, PROTECTED, DIMENSION(:), SAVE  :: qsat0, dqsatdT0
-!$OMP THREADPRIVATE(qsat0, dqsatdT0)
-  REAL, ALLOCATABLE, PROTECTED, DIMENSION(:), SAVE  :: qsat0_x, dqsatdT0_x
-!$OMP THREADPRIVATE(qsat0_x, dqsatdT0_x)
-  REAL, ALLOCATABLE, PROTECTED, DIMENSION(:), SAVE  :: qsat0_w, dqsatdT0_w
-!$OMP THREADPRIVATE(qsat0_w, dqsatdT0_w)
-  REAL, ALLOCATABLE, PROTECTED, DIMENSION(:), SAVE  :: QQ_b, dd_QQ
-!$OMP THREADPRIVATE(QQ_b, dd_QQ)
-  REAL, ALLOCATABLE, PROTECTED, DIMENSION(:), SAVE  :: QQ_x, QQ_w
-!$OMP THREADPRIVATE(QQ_x, QQ_w)
-  REAL, ALLOCATABLE, PROTECTED, DIMENSION(:), SAVE  :: qsatsrf0_x, qsatsrf0_w
-!$OMP THREADPRIVATE(qsatsrf0_x, qsatsrf0_w)
-  REAL, ALLOCATABLE, PROTECTED, DIMENSION(:), SAVE  :: dqsatsrf0
-!$OMP THREADPRIVATE(dqsatsrf0)
-  REAL, ALLOCATABLE, PROTECTED, DIMENSION(:), SAVE  :: q1_0b
-!$OMP THREADPRIVATE(q1_0b)
-  REAL, ALLOCATABLE, PROTECTED, DIMENSION(:), SAVE  :: dd_Cdragh, dd_Cdragm, dd_Cdragq 
-!$OMP THREADPRIVATE(dd_Cdragh, dd_Cdragm, dd_Cdragq )
-  REAL, ALLOCATABLE, PROTECTED, DIMENSION(:), SAVE  :: Kech_h, Kech_h_x, Kech_h_w   ! Energy exchange coefficients
-!$OMP THREADPRIVATE(Kech_h, Kech_h_x, Kech_h_w)
-  REAL, ALLOCATABLE, PROTECTED, DIMENSION(:), SAVE  :: Kech_q, Kech_q_x, Kech_q_w   ! Moisture exchange coefficients
-!$OMP THREADPRIVATE(Kech_q, Kech_q_x, Kech_q_w)
-  REAL, ALLOCATABLE, PROTECTED, DIMENSION(:), SAVE  :: Kech_m, Kech_m_x, Kech_m_w   ! Momentum exchange coefficients
-!$OMP THREADPRIVATE(Kech_m, Kech_m_x, Kech_m_w)
-  REAL, ALLOCATABLE, PROTECTED, DIMENSION(:), SAVE  :: Kech_Tp, Kech_T_px, Kech_T_pw
-  REAL, ALLOCATABLE, PROTECTED, DIMENSION(:), SAVE  :: dd_KTp, KxKwTp
-!$OMP THREADPRIVATE(Kech_Tp, Kech_T_px, Kech_T_pw, dd_KTp, KxKwTp)
-  REAL, ALLOCATABLE, PROTECTED, DIMENSION(:), SAVE  :: dd_AT, dd_BT
-!$OMP THREADPRIVATE(dd_AT, dd_BT)
-  REAL, ALLOCATABLE, PROTECTED, DIMENSION(:), SAVE  :: Kech_Qp, Kech_Q_px, Kech_Q_pw
-  REAL, ALLOCATABLE, PROTECTED, DIMENSION(:), SAVE  :: dd_KQp, KxKwQp
-!$OMP THREADPRIVATE(Kech_Qp, Kech_Q_px, Kech_Q_pw, dd_KQp, KxKwQp)
-  REAL, ALLOCATABLE, PROTECTED, DIMENSION(:), SAVE  :: Kech_Qs, Kech_Q_sx, Kech_Q_sw
-  REAL, ALLOCATABLE, PROTECTED, DIMENSION(:), SAVE  :: dd_KQs, KxKwQs
-!$OMP THREADPRIVATE(Kech_Qs, Kech_Q_sx, Kech_Q_sw, dd_KQs, KxKwQs)
-  REAL, ALLOCATABLE, PROTECTED, DIMENSION(:), SAVE  :: dd_AQ, dd_BQ
-!$OMP THREADPRIVATE(dd_AQ, dd_BQ)
-  REAL, ALLOCATABLE, PROTECTED, DIMENSION(:), SAVE  :: AQ_x, AQ_w, BQ_x, BQ_w
-!$OMP THREADPRIVATE(AQ_x, AQ_w, BQ_x, BQ_w)
-  REAL, ALLOCATABLE, PROTECTED, DIMENSION(:), SAVE  :: Kech_Up, Kech_U_px, Kech_U_pw
-  REAL, ALLOCATABLE, PROTECTED, DIMENSION(:), SAVE  :: dd_KUp, KxKwUp
-!$OMP THREADPRIVATE(Kech_Up, Kech_U_px, Kech_U_pw, dd_KUp, KxKwUp)
-  REAL, ALLOCATABLE, PROTECTED, DIMENSION(:), SAVE  :: dd_AU, dd_BU
-!$OMP THREADPRIVATE(dd_AU, dd_BU)
-  REAL, ALLOCATABLE, PROTECTED, DIMENSION(:), SAVE  :: Kech_Vp, Kech_V_px, Kech_V_pw
-  REAL, ALLOCATABLE, PROTECTED, DIMENSION(:), SAVE  :: dd_KVp, KxKwVp
-!$OMP THREADPRIVATE(Kech_Vp, Kech_V_px, Kech_V_pw, dd_KVp, KxKwVp)
-  REAL, ALLOCATABLE, PROTECTED, DIMENSION(:), SAVE  :: dd_AV, dd_BV
-!$OMP THREADPRIVATE(dd_AV, dd_BV)
-
-CONTAINS
-!
-!****************************************************************************************
-!
-SUBROUTINE wx_pbl_init
-
-! Local variables
-!****************************************************************************************
-    INTEGER                       :: ierr
- 
-
-!****************************************************************************************
-! Allocate module variables
-!
-!****************************************************************************************    
-
-    ierr = 0
-
-    ALLOCATE(C_p(klon), stat=ierr)
-    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
-
-    ALLOCATE(L_v(klon), stat=ierr)
-    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
-
-    ALLOCATE(Ts0(klon), stat=ierr)
-    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
-
-    ALLOCATE(dTs0(klon), stat=ierr)
-    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
-
-    ALLOCATE(Ts0_x(klon), stat=ierr)
-    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
-
-    ALLOCATE(Ts0_w(klon), stat=ierr)
-    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
-
-    ALLOCATE(qsat0(klon), stat=ierr)
-    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
-
-    ALLOCATE(dqsatdT0(klon), stat=ierr)
-    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
-
-    ALLOCATE(qsat0_x(klon), stat=ierr)
-    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
-
-    ALLOCATE(dqsatdT0_x(klon), stat=ierr)
-    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
-
-    ALLOCATE(qsat0_w(klon), stat=ierr)
-    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
-
-    ALLOCATE(dqsatdT0_w(klon), stat=ierr)
-    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
-
-    ALLOCATE(q1_0b(klon), stat=ierr)
-    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
-
-    ALLOCATE(QQ_b(klon), stat=ierr)
-    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
-
-    ALLOCATE(dd_QQ(klon), stat=ierr)
-    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
-
-    ALLOCATE(QQ_x(klon), stat=ierr)
-    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
-
-    ALLOCATE(QQ_w(klon), stat=ierr)
-    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
-
-    ALLOCATE(qsatsrf0_x(klon), stat=ierr)
-    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
-
-    ALLOCATE(qsatsrf0_w(klon), stat=ierr)
-    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
-
-    ALLOCATE(dqsatsrf0(klon), stat=ierr)
-    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
-
-    ALLOCATE(dd_Cdragh(klon), stat=ierr)
-    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
-
-    ALLOCATE(dd_Cdragm(klon), stat=ierr)
-    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
-
-    ALLOCATE(dd_Cdragq(klon), stat=ierr)
-    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
-
-    ALLOCATE(Kech_h(klon), stat=ierr)
-    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
-
-    ALLOCATE(Kech_h_x(klon), stat=ierr)
-    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
-
-    ALLOCATE(Kech_h_w(klon), stat=ierr)
-    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
-
-    ALLOCATE(Kech_q(klon), stat=ierr)
-    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
-
-    ALLOCATE(Kech_q_x(klon), stat=ierr)
-    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
-
-    ALLOCATE(Kech_q_w(klon), stat=ierr)
-    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
-
-    ALLOCATE(Kech_m(klon), stat=ierr)
-    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
-
-    ALLOCATE(Kech_m_x(klon), stat=ierr)
-    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
-
-    ALLOCATE(Kech_m_w(klon), stat=ierr)
-    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
-
-    ALLOCATE(Kech_Tp(klon), stat=ierr)
-    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
-
-    ALLOCATE(Kech_T_px(klon), stat=ierr)
-    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
-
-    ALLOCATE(Kech_T_pw(klon), stat=ierr)
-    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
-
-    ALLOCATE(dd_KTp(klon), stat=ierr)
-    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
-
-    ALLOCATE(KxKwTp(klon), stat=ierr)
-    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
-
-    ALLOCATE(dd_AT(klon), stat=ierr)
-    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
-
-    ALLOCATE(dd_BT(klon), stat=ierr)
-    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
-
-!----------------------------------------------------------------------------
-    ALLOCATE(Kech_Qp(klon), stat=ierr)
-    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
-
-    ALLOCATE(Kech_Q_px(klon), stat=ierr)
-    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
-
-    ALLOCATE(Kech_Q_pw(klon), stat=ierr)
-    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
-
-    ALLOCATE(dd_KQp(klon), stat=ierr)
-    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
-
-    ALLOCATE(KxKwQp(klon), stat=ierr)
-    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
-
-    ALLOCATE(Kech_Qs(klon), stat=ierr)
-    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
-
-    ALLOCATE(Kech_Q_sx(klon), stat=ierr)
-    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
-
-    ALLOCATE(Kech_Q_sw(klon), stat=ierr)
-    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
-
-    ALLOCATE(dd_KQs(klon), stat=ierr)
-    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
-
-    ALLOCATE(KxKwQs(klon), stat=ierr)
-    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
-
-!!!!!!!!!!
-    ALLOCATE(AQ_x(klon), stat=ierr)
-    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
-
-    ALLOCATE(AQ_w(klon), stat=ierr)
-    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
-
-    ALLOCATE(BQ_x(klon), stat=ierr)
-    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
-
-    ALLOCATE(BQ_w(klon), stat=ierr)
-    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
-
-    ALLOCATE(dd_AQ(klon), stat=ierr)
-    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
-
-    ALLOCATE(dd_BQ(klon), stat=ierr)
-    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
-
-!----------------------------------------------------------------------------
-    ALLOCATE(Kech_Up(klon), stat=ierr)
-    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
-
-    ALLOCATE(Kech_U_px(klon), stat=ierr)
-    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
-
-    ALLOCATE(Kech_U_pw(klon), stat=ierr)
-    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
-
-    ALLOCATE(dd_KUp(klon), stat=ierr)
-    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
-
-    ALLOCATE(KxKwUp(klon), stat=ierr)
-    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
-
-    ALLOCATE(dd_AU(klon), stat=ierr)
-    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
-
-    ALLOCATE(dd_BU(klon), stat=ierr)
-    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
-
-!----------------------------------------------------------------------------
-    ALLOCATE(Kech_Vp(klon), stat=ierr)
-    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
-
-    ALLOCATE(Kech_V_px(klon), stat=ierr)
-    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
-
-    ALLOCATE(Kech_V_pw(klon), stat=ierr)
-    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
-
-    ALLOCATE(dd_KVp(klon), stat=ierr)
-    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
-
-    ALLOCATE(KxKwVp(klon), stat=ierr)
-    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
-
-    ALLOCATE(dd_AV(klon), stat=ierr)
-    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
-
-    ALLOCATE(dd_BV(klon), stat=ierr)
-    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
-
-!----------------------------------------------------------------------------
-
-END SUBROUTINE wx_pbl_init
-
-SUBROUTINE wx_pbl_prelim_0(knon, nsrf, dtime, ypplay, ypaprs, sigw,   &
-                                 yt_s, ydeltat_s, ygustiness, &
-                                 yt_x, yt_w, yq_x, yq_w, &
-                                 yu_x, yu_w, yv_x, yv_w, &
-                                 ycdragh_x, ycdragh_w, ycdragq_x, ycdragq_w, &
-                                 ycdragm_x, ycdragm_w, &
-                                 AcoefT_x, AcoefT_w, AcoefQ_x, AcoefQ_w, &
-                                 AcoefU_x, AcoefU_w, AcoefV_x, AcoefV_w, &
-                                 BcoefT_x, BcoefT_w, BcoefQ_x, BcoefQ_w, &
-                                 BcoefU_x, BcoefU_w, BcoefV_x, BcoefV_w, &
-                                 Kech_h_x_out, Kech_h_w_out, Kech_h_out  &
-                                 )
-!
-    USE print_control_mod, ONLY: prt_level,lunout
-    USE indice_sol_mod, ONLY: is_oce
-!
-    INCLUDE "YOMCST.h"
-    INCLUDE "FCTTRE.h"
-    INCLUDE "YOETHF.h"
-    INCLUDE "clesphys.h"
-!
-    INTEGER,                      INTENT(IN)        :: knon    ! number of grid cells
-    INTEGER,                      INTENT(IN)        :: nsrf    ! surface type
-    REAL,                         INTENT(IN)        :: dtime   ! time step size (s)
-    REAL, DIMENSION(knon,klev),   INTENT(IN)        :: ypplay  ! mid-layer pressure (Pa)
-    REAL, DIMENSION(knon,klev),   INTENT(IN)        :: ypaprs  ! pressure at layer interfaces (pa)
-    REAL, DIMENSION(knon),        INTENT(IN)        :: sigw ! cold pools fractional area
-    REAL, DIMENSION(knon),        INTENT(IN)        :: yt_s
-    REAL, DIMENSION(knon),        INTENT(IN)        :: ydeltat_s
-    REAL, DIMENSION(knon),        INTENT(IN)        :: ygustiness
-    REAL, DIMENSION(knon,klev),   INTENT(IN)        :: yt_x, yt_w, yq_x, yq_w
-    REAL, DIMENSION(knon,klev),   INTENT(IN)        :: yu_x, yu_w, yv_x, yv_w
-    REAL, DIMENSION(knon),        INTENT(IN)        :: ycdragh_x, ycdragh_w, ycdragq_x, ycdragq_w
-    REAL, DIMENSION(knon),        INTENT(IN)        :: ycdragm_x, ycdragm_w
-    REAL, DIMENSION(knon),        INTENT(IN)        :: AcoefT_x, AcoefT_w, AcoefQ_x, AcoefQ_w
-    REAL, DIMENSION(knon),        INTENT(IN)        :: AcoefU_x, AcoefU_w, AcoefV_x, AcoefV_w
-    REAL, DIMENSION(knon),        INTENT(IN)        :: BcoefT_x, BcoefT_w, BcoefQ_x, BcoefQ_w
-    REAL, DIMENSION(knon),        INTENT(IN)        :: BcoefU_x, BcoefU_w, BcoefV_x, BcoefV_w
-!
-    REAL, DIMENSION(knon),        INTENT(OUT)       :: Kech_h_x_out, Kech_h_w_out, Kech_h_out
-!
-! Local variables
-    INTEGER                    :: j
-    REAL                       :: rho1
-    REAL                       :: mod_wind_x
-    REAL                       :: mod_wind_w   
-    REAL                       :: dd_Kh
-    REAL                       :: dd_Kq
-    REAL                       :: dd_Km
-!
-    REAL                       :: zdelta, zcvm5, zcor, qsat
-! 
-    REAL, DIMENSION(knon)      :: sigx       ! fractional area of (x) region
-!
-!!!
-!!! jyg le 09/04/2013 ; passage aux nouvelles expressions en differences
-
-!
-!  First computations
-!  ------------------
-   eps_1 = 0.5
-   smallestreal=tiny(smallestreal)
-!
-   sigx(1:knon) = 1.-sigw(1:knon)
-! Compute Cp, Lv, qsat, dqsat_dT.
-   L_v(1:knon) = RLvtt
-   Ts0(1:knon) = yt_s(1:knon)
-   dTs0(1:knon) = ydeltat_s(1:knon)
-   q1_0b(1:knon) = sigw(1:knon)*yq_w(1:knon,1)+sigx(1:knon)*yq_x(1:knon,1)
-!
-! fqsat determination 
-! -------------------
-   IF (nsrf == is_oce) THEN
-     fqsat = f_qsat_oce
-   ELSE
-     fqsat = 1.
-   ENDIF
-!
-!
-!  Reference state
-!  ---------------
-   DO j = 1, knon
-      zdelta = MAX(0.,SIGN(1.,RTT-Ts0(j)))
-      zcvm5 = R5LES*(1.-zdelta) + R5IES*zdelta
-      qsat = R2ES*FOEEW(Ts0(j),zdelta)/ypaprs(j,1)
-      qsat = MIN(0.5,qsat)
-      zcor = 1./(1.-RETV*qsat)
-      qsat0(j) = fqsat*qsat*zcor
-      dqsatdT0(j) = fqsat*FOEDE(Ts0(j),zdelta,zcvm5,qsat0(j),zcor)
-      C_p(j) = RCpd + qsat0(j)*(RCpv - RCpd)
-      C_p(j) = RCpd
-!
-!      print *,' AAAA wx_pbl0, C_p(j), qsat0(j), Ts0(j) : ', C_p(j), qsat0(j), Ts0(j)
-   ENDDO
-   DO j = 1, knon
-      Ts0_x(j) = Ts0(j) - sigw(j)*dTs0(j)
-      zdelta = MAX(0.,SIGN(1.,RTT-Ts0_x(j)))
-      zcvm5 = R5LES*(1.-zdelta) + R5IES*zdelta
-!!      zcvm5 = R5LES*RLVTT*(1.-zdelta) + R5IES*RLSTT*zdelta
-      qsat = R2ES*FOEEW(Ts0_x(j),zdelta)/ypaprs(j,1)
-      qsat = MIN(0.5,qsat)
-      zcor = 1./(1.-RETV*qsat)
-      qsat0_x(j) = fqsat*qsat*zcor
-      dqsatdT0_x(j) = fqsat*FOEDE(Ts0_x(j),zdelta,zcvm5,qsat0_x(j),zcor)
-!!      dqsatdT0_x(j) = (RLvtt*(1.-zdelta)+RLSTT*zdelta)*qsat0_x(j)/(Rv*Ts0_x(j)*Ts0_x(j))
-   ENDDO
-   DO j = 1, knon
-      Ts0_w(j) = Ts0(j) + sigx(j)*dTs0(j)
-      zdelta = MAX(0.,SIGN(1.,RTT-Ts0_w(j)))
-      zcvm5 = R5LES*(1.-zdelta) + R5IES*zdelta
-!!      zcvm5 = R5LES*RLVTT*(1.-zdelta) + R5IES*RLSTT*zdelta
-      qsat = R2ES*FOEEW(Ts0_w(j),zdelta)/ypaprs(j,1)
-      qsat = MIN(0.5,qsat)
-      zcor = 1./(1.-RETV*qsat)
-      qsat0_w(j) = fqsat*qsat*zcor
-      dqsatdT0_w(j) = fqsat*FOEDE(Ts0_w(j),zdelta,zcvm5,qsat0_w(j),zcor)
-!!      dqsatdT0_w(j) = (RLvtt*(1.-zdelta)+RLSTT*zdelta)*qsat0_w(j)/(Rv*Ts0_w(j)*Ts0_w(j))
-   ENDDO
-!
-   QQ_x(1:knon)  = 1./dqsatdT0_x(1:knon)
-   QQ_w(1:knon)  = 1./dqsatdT0_w(1:knon)
-   QQ_b(1:knon)  = sigw(1:knon)*QQ_w(1:knon) + sigx(1:knon)*QQ_x(1:knon)
-   dd_QQ(1:knon) = QQ_w(1:knon) - QQ_x(1:knon)
-!
-        DO j=1,knon
-!
-! Exchange coefficients computation
-! ---------------------------------
-!
-! Wind factor (Warning : this is not valid when using land_surf_orchidee)
-         mod_wind_x = min_wind_speed+SQRT(ygustiness(j)+yu_x(j,1)**2+yv_x(j,1)**2)
-         mod_wind_w = min_wind_speed+SQRT(ygustiness(j)+yu_w(j,1)**2+yv_w(j,1)**2)
-!
-!!         rho1 = ypplay(j,1)/(RD*yt(j,1))
-         rho1 = ypplay(j,1)/(RD*(yt_x(j,1) + sigw(j)*(yt_w(j,1)-yt_x(j,1))))
-! 
-! (w) and (x) Exchange coefficients
-         Kech_h_x(j) = ycdragh_x(j) * mod_wind_x * rho1
-         Kech_h_w(j) = ycdragh_w(j) * mod_wind_w * rho1
-         Kech_q_x(j) = ycdragq_x(j) * mod_wind_x * rho1
-         Kech_q_w(j) = ycdragq_w(j) * mod_wind_w * rho1
-         Kech_m_x(j) = ycdragm_x(j) * mod_wind_x * rho1
-         Kech_m_w(j) = ycdragm_w(j) * mod_wind_w * rho1
-!!  Print *,'YYYYpbl0: ycdragh_x, ycdragq_x, mod_wind_x, rho1, Kech_q_x, Kech_h_x ', &
-!!                     ycdragh_x(j), ycdragq_x(j), mod_wind_x, rho1, Kech_q_x(j), Kech_h_x(j)
-!!  Print *,'YYYYpbl0: ycdragh_w, ycdragq_w, mod_wind_w, rho1, Kech_q_w, Kech_h_w ', &
-!!                     ycdragh_w(j), ycdragq_w(j), mod_wind_w, rho1, Kech_q_w(j), Kech_h_w(j)
-!
-! Merged exchange coefficients
-         dd_Kh = Kech_h_w(j) - Kech_h_x(j)
-         dd_Kq = Kech_q_w(j) - Kech_q_x(j)
-         dd_Km = Kech_m_w(j) - Kech_m_x(j)
-         IF (prt_level >=10) THEN
-          print *,' mod_wind_x, mod_wind_w ', mod_wind_x, mod_wind_w
-          print *,' rho1 ',rho1
-          print *,' ycdragh_x(j),ycdragm_x(j) ',ycdragh_x(j),ycdragm_x(j)
-          print *,' ycdragh_w(j),ycdragm_w(j) ',ycdragh_w(j),ycdragm_w(j)
-          print *,' dd_Kh: ',dd_Kh
-         ENDIF
-!
-         Kech_h(j) = Kech_h_x(j) + sigw(j)*dd_Kh
-         Kech_q(j) = Kech_q_x(j) + sigw(j)*dd_Kq
-         Kech_m(j) = Kech_m_x(j) + sigw(j)*dd_Km
-!
-         Kech_h_x_out(j) = Kech_h_x(j)
-         Kech_h_w_out(j) = Kech_h_w(j)
-         Kech_h_out(j)   = Kech_h(j)
-!
-! Effective exchange coefficient computation
-! ------------------------------------------
-        Kech_T_px(j) = Kech_h_x(j)/(1.-BcoefT_x(j)*Kech_h_x(j)*dtime)
-        Kech_T_pw(j) = Kech_h_w(j)/(1.-BcoefT_w(j)*Kech_h_w(j)*dtime)
-!
-        Kech_Q_px(j) = Kech_q_x(j)/(1.-BcoefQ_x(j)*Kech_q_x(j)*dtime)
-        Kech_Q_pw(j) = Kech_q_w(j)/(1.-BcoefQ_w(j)*Kech_q_w(j)*dtime)
-!
-        Kech_U_px(j) = Kech_m_x(j)/(1.-BcoefU_x(j)*Kech_m_x(j)*dtime)
-        Kech_U_pw(j) = Kech_m_w(j)/(1.-BcoefU_w(j)*Kech_m_w(j)*dtime)
-!
-        Kech_V_px(j) = Kech_m_x(j)/(1.-BcoefV_x(j)*Kech_m_x(j)*dtime)
-        Kech_V_pw(j) = Kech_m_w(j)/(1.-BcoefV_w(j)*Kech_m_w(j)*dtime)
-!
-         dd_KTp(j) = Kech_T_pw(j) - Kech_T_px(j)
-         dd_KQp(j) = Kech_Q_pw(j) - Kech_Q_px(j)
-         dd_KUp(j) = Kech_U_pw(j) - Kech_U_px(j)
-         dd_KVp(j) = Kech_V_pw(j) - Kech_V_px(j)
-!
-        Kech_Tp(j) = Kech_T_px(j) + sigw(j)*dd_KTp(j)
-        Kech_Qp(j) = Kech_Q_px(j) + sigw(j)*dd_KQp(j)
-        Kech_Up(j) = Kech_U_px(j) + sigw(j)*dd_KUp(j)
-        Kech_Vp(j) = Kech_V_px(j) + sigw(j)*dd_KVp(j)
-!
-! Store AQ and BQ in the module variables
-       AQ_x(j) = AcoefQ_x(j)
-       AQ_w(j) = AcoefQ_w(j)
-       BQ_x(j) = BcoefQ_x(j)
-       BQ_w(j) = BcoefQ_w(j)
-!
-! Calcul des differences w-x
-       dd_Cdragm(j) = ycdragm_w(j) - ycdragm_x(j)
-       dd_Cdragh(j) = ycdragh_w(j) - ycdragh_x(j)
-       dd_Cdragq(j) = ycdragq_w(j) - ycdragq_x(j)
-!
-       dd_AT(j) = AcoefT_w(j) - AcoefT_x(j)
-       dd_AQ(j) = AcoefQ_w(j) - AcoefQ_x(j)
-       dd_AU(j) = AcoefU_w(j) - AcoefU_x(j)
-       dd_AV(j) = AcoefV_w(j) - AcoefV_x(j)
-       dd_BT(j) = BcoefT_w(j) - BcoefT_x(j)
-       dd_BQ(j) = BcoefQ_w(j) - BcoefQ_x(j)
-       dd_BU(j) = BcoefU_w(j) - BcoefU_x(j)
-       dd_BV(j) = BcoefV_w(j) - BcoefV_x(j)
-!
-       KxKwTp(j) = Kech_T_px(j)*Kech_T_pw(j)
-       KxKwQp(j) = Kech_Q_px(j)*Kech_Q_pw(j)
-       KxKwUp(j) = Kech_U_px(j)*Kech_U_pw(j)
-       KxKwVp(j) = Kech_V_px(j)*Kech_V_pw(j)
-!                                           
-!
-       IF (prt_level >=10) THEN
-          print *,'Variables pour la fusion : Kech_T_px(j)' ,Kech_T_px(j)
-          print *,'Variables pour la fusion : Kech_T_pw(j)' ,Kech_T_pw(j)
-          print *,'Variables pour la fusion : Kech_Tp(j)' ,Kech_Tp(j)
-          print *,'Variables pour la fusion : Kech_h(j)' ,Kech_h(j)
-       ENDIF
-
-     ENDDO  ! j = 1, knon
-
-     RETURN
-
-END SUBROUTINE wx_pbl_prelim_0
-
-SUBROUTINE wx_pbl_prelim_beta(knon, dtime,  &
-                                 sigw, beta,       &
-                                 BcoefQ_x, BcoefQ_w &
-                                 )
-!
-    USE print_control_mod, ONLY: prt_level,lunout
-    USE indice_sol_mod, ONLY: is_oce
-!
-    INTEGER,                      INTENT(IN)        :: knon    ! number of grid cells
-    REAL,                         INTENT(IN)        :: dtime   ! time step size (s)
-    REAL, DIMENSION(knon),        INTENT(IN)        :: sigw ! cold pools fractional area
-    REAL, DIMENSION(knon),        INTENT(IN)        :: beta ! evaporation by potential evaporation
-    REAL, DIMENSION(knon),        INTENT(IN)        :: BcoefQ_x, BcoefQ_w
-!
-! Local variables
-    INTEGER                    :: j
-!
-   DO j = 1, knon
-!
-        qsatsrf0_x(j) = beta(j)*qsat0_x(j)
-        qsatsrf0_w(j) = beta(j)*qsat0_w(j)
-        dqsatsrf0(j)  = qsatsrf0_w(j) - qsatsrf0_x(j)
-!
-        Kech_Q_sx(j) = Kech_q_x(j)/(1.-beta(j)*BcoefQ_x(j)*Kech_q_x(j)*dtime)
-        Kech_Q_sw(j) = Kech_q_w(j)/(1.-beta(j)*BcoefQ_w(j)*Kech_q_w(j)*dtime)
-!
-        dd_KQs(j) = Kech_Q_sw(j) - Kech_Q_sx(j)
-!
-        Kech_Qs(j) = Kech_Q_sx(j) + sigw(j)*dd_KQs(j)
-!
-        KxKwQs(j) = Kech_Q_sx(j)*Kech_Q_sw(j)
-!
-!!  print *,'BBBBwx_prelim_beta : beta ', beta(j)
-!
-  ENDDO ! j = 1, knon
-
-  RETURN
-
-END SUBROUTINE wx_pbl_prelim_beta
-
-SUBROUTINE wx_pbl_final
-!
-!****************************************************************************************
-! Deallocate module variables
-!
-!****************************************************************************************    
-!
-    IF (ALLOCATED(C_p))           DEALLOCATE(C_p)
-    IF (ALLOCATED(L_v))           DEALLOCATE(L_v)
-    IF (ALLOCATED(Ts0))           DEALLOCATE(Ts0)
-    IF (ALLOCATED(dTs0))          DEALLOCATE(dTs0)
-    IF (ALLOCATED(Ts0_x))         DEALLOCATE(Ts0_x)
-    IF (ALLOCATED(Ts0_w))         DEALLOCATE(Ts0_w)
-    IF (ALLOCATED(qsat0))         DEALLOCATE(qsat0)
-    IF (ALLOCATED(dqsatdT0))      DEALLOCATE(dqsatdT0 )
-    IF (ALLOCATED(qsat0_x))       DEALLOCATE(qsat0_x)
-    IF (ALLOCATED(dqsatdT0_x))    DEALLOCATE(dqsatdT0_x )
-    IF (ALLOCATED(qsat0_w))       DEALLOCATE(qsat0_w)
-    IF (ALLOCATED(dqsatdT0_w))    DEALLOCATE(dqsatdT0_w )
-    IF (ALLOCATED(q1_0b))         DEALLOCATE(q1_0b)
-    IF (ALLOCATED(QQ_b))          DEALLOCATE(QQ_b)
-    IF (ALLOCATED(dd_QQ))         DEALLOCATE(dd_QQ)
-    IF (ALLOCATED(QQ_x))          DEALLOCATE(QQ_x)
-    IF (ALLOCATED(QQ_w))          DEALLOCATE(QQ_w)
-    IF (ALLOCATED(qsatsrf0_x))    DEALLOCATE(qsatsrf0_x)
-    IF (ALLOCATED(qsatsrf0_w))    DEALLOCATE(qsatsrf0_w)
-    IF (ALLOCATED(dqsatsrf0))     DEALLOCATE(dqsatsrf0)
-    IF (ALLOCATED(dd_Cdragh))     DEALLOCATE(dd_Cdragh)
-    IF (ALLOCATED(dd_Cdragm))     DEALLOCATE(dd_Cdragm)
-    IF (ALLOCATED(dd_Cdragq))     DEALLOCATE(dd_Cdragq)
-    IF (ALLOCATED(Kech_h))        DEALLOCATE(Kech_h)
-    IF (ALLOCATED(Kech_h_x))      DEALLOCATE(Kech_h_x)
-    IF (ALLOCATED(Kech_h_w))      DEALLOCATE(Kech_h_w)
-    IF (ALLOCATED(Kech_q))        DEALLOCATE(Kech_q)
-    IF (ALLOCATED(Kech_q_x))      DEALLOCATE(Kech_q_x)
-    IF (ALLOCATED(Kech_q_w))      DEALLOCATE(Kech_q_w)
-    IF (ALLOCATED(Kech_m))        DEALLOCATE(Kech_m)
-    IF (ALLOCATED(Kech_m_x))      DEALLOCATE(Kech_m_x)
-    IF (ALLOCATED(Kech_m_w))      DEALLOCATE(Kech_m_w)
-    IF (ALLOCATED(Kech_Tp))       DEALLOCATE(Kech_Tp)
-    IF (ALLOCATED(Kech_T_px))     DEALLOCATE(Kech_T_px)
-    IF (ALLOCATED(Kech_T_pw))     DEALLOCATE(Kech_T_pw)
-    IF (ALLOCATED(dd_KTp))        DEALLOCATE(dd_KTp)
-    IF (ALLOCATED(KxKwTp))        DEALLOCATE(KxKwTp)
-    IF (ALLOCATED(dd_AT))         DEALLOCATE(dd_AT)
-    IF (ALLOCATED(dd_BT))         DEALLOCATE(dd_BT)
-    IF (ALLOCATED(Kech_Qp))       DEALLOCATE(Kech_Qp)
-    IF (ALLOCATED(Kech_Q_px))     DEALLOCATE(Kech_Q_px)
-    IF (ALLOCATED(Kech_Q_pw))     DEALLOCATE(Kech_Q_pw)
-    IF (ALLOCATED(dd_KQp))        DEALLOCATE(dd_KQp)
-    IF (ALLOCATED(KxKwQp))        DEALLOCATE(KxKwQp)
-    IF (ALLOCATED(Kech_Qs))       DEALLOCATE(Kech_Qs)
-    IF (ALLOCATED(Kech_Q_sx))     DEALLOCATE(Kech_Q_sx)
-    IF (ALLOCATED(Kech_Q_sw))     DEALLOCATE(Kech_Q_sw)
-    IF (ALLOCATED(dd_KQs))        DEALLOCATE(dd_KQs)
-    IF (ALLOCATED(KxKwQs ))       DEALLOCATE(KxKwQs )
-    IF (ALLOCATED(AQ_x))          DEALLOCATE(AQ_x)
-    IF (ALLOCATED(AQ_w))          DEALLOCATE(AQ_w)
-    IF (ALLOCATED(BQ_x))          DEALLOCATE(BQ_x)
-    IF (ALLOCATED(BQ_w))          DEALLOCATE(BQ_w)
-    IF (ALLOCATED(dd_AQ))         DEALLOCATE(dd_AQ)
-    IF (ALLOCATED(dd_BQ ))        DEALLOCATE(dd_BQ )
-    IF (ALLOCATED(Kech_Up))       DEALLOCATE(Kech_Up)
-    IF (ALLOCATED(Kech_U_px))     DEALLOCATE(Kech_U_px)
-    IF (ALLOCATED(Kech_U_pw))     DEALLOCATE(Kech_U_pw)
-    IF (ALLOCATED(dd_KUp))        DEALLOCATE(dd_KUp)
-    IF (ALLOCATED(KxKwUp))        DEALLOCATE(KxKwUp)
-    IF (ALLOCATED(dd_AU))         DEALLOCATE(dd_AU)
-    IF (ALLOCATED(dd_BU))         DEALLOCATE(dd_BU)
-    IF (ALLOCATED(Kech_Vp))       DEALLOCATE(Kech_Vp)
-    IF (ALLOCATED(Kech_V_px))     DEALLOCATE(Kech_V_px)
-    IF (ALLOCATED(Kech_V_pw))     DEALLOCATE(Kech_V_pw)
-    IF (ALLOCATED(dd_KVp))        DEALLOCATE(dd_KVp)
-    IF (ALLOCATED(KxKwVp))        DEALLOCATE(KxKwVp)
-    IF (ALLOCATED(dd_AV))         DEALLOCATE(dd_AV)
-    IF (ALLOCATED(dd_BV))         DEALLOCATE(dd_BV)
-
-END SUBROUTINE wx_pbl_final
-
-END MODULE wx_pbl_var_mod
-
Index: /LMDZ6/trunk/libf/phylmd/wx_pbl_var_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/wx_pbl_var_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/wx_pbl_var_mod.f90	(revision 5268)
@@ -0,0 +1,655 @@
+MODULE wx_pbl_var_mod
+!
+! Split Planetary Boundary Layer variables
+!
+! This module manages the variables necessary for the splitting of the boundary layer 
+! 
+!
+  USE dimphy
+
+  IMPLICIT NONE
+
+  REAL, PROTECTED, SAVE                             :: eps_1, fqsat, smallestreal
+!$OMP THREADPRIVATE(eps_1, fqsat, smallestreal)
+!
+  REAL, ALLOCATABLE, PROTECTED, DIMENSION(:), SAVE  :: C_p, L_v
+!$OMP THREADPRIVATE(C_p, L_v)
+  REAL, ALLOCATABLE, PROTECTED, DIMENSION(:), SAVE  :: Ts0, dTs0
+!$OMP THREADPRIVATE(Ts0, dTs0)
+  REAL, ALLOCATABLE, PROTECTED, DIMENSION(:), SAVE  :: Ts0_x, Ts0_w
+!$OMP THREADPRIVATE(Ts0_x, Ts0_w)
+  REAL, ALLOCATABLE, PROTECTED, DIMENSION(:), SAVE  :: qsat0, dqsatdT0
+!$OMP THREADPRIVATE(qsat0, dqsatdT0)
+  REAL, ALLOCATABLE, PROTECTED, DIMENSION(:), SAVE  :: qsat0_x, dqsatdT0_x
+!$OMP THREADPRIVATE(qsat0_x, dqsatdT0_x)
+  REAL, ALLOCATABLE, PROTECTED, DIMENSION(:), SAVE  :: qsat0_w, dqsatdT0_w
+!$OMP THREADPRIVATE(qsat0_w, dqsatdT0_w)
+  REAL, ALLOCATABLE, PROTECTED, DIMENSION(:), SAVE  :: QQ_b, dd_QQ
+!$OMP THREADPRIVATE(QQ_b, dd_QQ)
+  REAL, ALLOCATABLE, PROTECTED, DIMENSION(:), SAVE  :: QQ_x, QQ_w
+!$OMP THREADPRIVATE(QQ_x, QQ_w)
+  REAL, ALLOCATABLE, PROTECTED, DIMENSION(:), SAVE  :: qsatsrf0_x, qsatsrf0_w
+!$OMP THREADPRIVATE(qsatsrf0_x, qsatsrf0_w)
+  REAL, ALLOCATABLE, PROTECTED, DIMENSION(:), SAVE  :: dqsatsrf0
+!$OMP THREADPRIVATE(dqsatsrf0)
+  REAL, ALLOCATABLE, PROTECTED, DIMENSION(:), SAVE  :: q1_0b
+!$OMP THREADPRIVATE(q1_0b)
+  REAL, ALLOCATABLE, PROTECTED, DIMENSION(:), SAVE  :: dd_Cdragh, dd_Cdragm, dd_Cdragq 
+!$OMP THREADPRIVATE(dd_Cdragh, dd_Cdragm, dd_Cdragq )
+  REAL, ALLOCATABLE, PROTECTED, DIMENSION(:), SAVE  :: Kech_h, Kech_h_x, Kech_h_w   ! Energy exchange coefficients
+!$OMP THREADPRIVATE(Kech_h, Kech_h_x, Kech_h_w)
+  REAL, ALLOCATABLE, PROTECTED, DIMENSION(:), SAVE  :: Kech_q, Kech_q_x, Kech_q_w   ! Moisture exchange coefficients
+!$OMP THREADPRIVATE(Kech_q, Kech_q_x, Kech_q_w)
+  REAL, ALLOCATABLE, PROTECTED, DIMENSION(:), SAVE  :: Kech_m, Kech_m_x, Kech_m_w   ! Momentum exchange coefficients
+!$OMP THREADPRIVATE(Kech_m, Kech_m_x, Kech_m_w)
+  REAL, ALLOCATABLE, PROTECTED, DIMENSION(:), SAVE  :: Kech_Tp, Kech_T_px, Kech_T_pw
+  REAL, ALLOCATABLE, PROTECTED, DIMENSION(:), SAVE  :: dd_KTp, KxKwTp
+!$OMP THREADPRIVATE(Kech_Tp, Kech_T_px, Kech_T_pw, dd_KTp, KxKwTp)
+  REAL, ALLOCATABLE, PROTECTED, DIMENSION(:), SAVE  :: dd_AT, dd_BT
+!$OMP THREADPRIVATE(dd_AT, dd_BT)
+  REAL, ALLOCATABLE, PROTECTED, DIMENSION(:), SAVE  :: Kech_Qp, Kech_Q_px, Kech_Q_pw
+  REAL, ALLOCATABLE, PROTECTED, DIMENSION(:), SAVE  :: dd_KQp, KxKwQp
+!$OMP THREADPRIVATE(Kech_Qp, Kech_Q_px, Kech_Q_pw, dd_KQp, KxKwQp)
+  REAL, ALLOCATABLE, PROTECTED, DIMENSION(:), SAVE  :: Kech_Qs, Kech_Q_sx, Kech_Q_sw
+  REAL, ALLOCATABLE, PROTECTED, DIMENSION(:), SAVE  :: dd_KQs, KxKwQs
+!$OMP THREADPRIVATE(Kech_Qs, Kech_Q_sx, Kech_Q_sw, dd_KQs, KxKwQs)
+  REAL, ALLOCATABLE, PROTECTED, DIMENSION(:), SAVE  :: dd_AQ, dd_BQ
+!$OMP THREADPRIVATE(dd_AQ, dd_BQ)
+  REAL, ALLOCATABLE, PROTECTED, DIMENSION(:), SAVE  :: AQ_x, AQ_w, BQ_x, BQ_w
+!$OMP THREADPRIVATE(AQ_x, AQ_w, BQ_x, BQ_w)
+  REAL, ALLOCATABLE, PROTECTED, DIMENSION(:), SAVE  :: Kech_Up, Kech_U_px, Kech_U_pw
+  REAL, ALLOCATABLE, PROTECTED, DIMENSION(:), SAVE  :: dd_KUp, KxKwUp
+!$OMP THREADPRIVATE(Kech_Up, Kech_U_px, Kech_U_pw, dd_KUp, KxKwUp)
+  REAL, ALLOCATABLE, PROTECTED, DIMENSION(:), SAVE  :: dd_AU, dd_BU
+!$OMP THREADPRIVATE(dd_AU, dd_BU)
+  REAL, ALLOCATABLE, PROTECTED, DIMENSION(:), SAVE  :: Kech_Vp, Kech_V_px, Kech_V_pw
+  REAL, ALLOCATABLE, PROTECTED, DIMENSION(:), SAVE  :: dd_KVp, KxKwVp
+!$OMP THREADPRIVATE(Kech_Vp, Kech_V_px, Kech_V_pw, dd_KVp, KxKwVp)
+  REAL, ALLOCATABLE, PROTECTED, DIMENSION(:), SAVE  :: dd_AV, dd_BV
+!$OMP THREADPRIVATE(dd_AV, dd_BV)
+
+CONTAINS
+!
+!****************************************************************************************
+!
+SUBROUTINE wx_pbl_init
+
+! Local variables
+!****************************************************************************************
+    INTEGER                       :: ierr
+ 
+
+!****************************************************************************************
+! Allocate module variables
+!
+!****************************************************************************************    
+
+    ierr = 0
+
+    ALLOCATE(C_p(klon), stat=ierr)
+    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
+
+    ALLOCATE(L_v(klon), stat=ierr)
+    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
+
+    ALLOCATE(Ts0(klon), stat=ierr)
+    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
+
+    ALLOCATE(dTs0(klon), stat=ierr)
+    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
+
+    ALLOCATE(Ts0_x(klon), stat=ierr)
+    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
+
+    ALLOCATE(Ts0_w(klon), stat=ierr)
+    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
+
+    ALLOCATE(qsat0(klon), stat=ierr)
+    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
+
+    ALLOCATE(dqsatdT0(klon), stat=ierr)
+    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
+
+    ALLOCATE(qsat0_x(klon), stat=ierr)
+    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
+
+    ALLOCATE(dqsatdT0_x(klon), stat=ierr)
+    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
+
+    ALLOCATE(qsat0_w(klon), stat=ierr)
+    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
+
+    ALLOCATE(dqsatdT0_w(klon), stat=ierr)
+    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
+
+    ALLOCATE(q1_0b(klon), stat=ierr)
+    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
+
+    ALLOCATE(QQ_b(klon), stat=ierr)
+    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
+
+    ALLOCATE(dd_QQ(klon), stat=ierr)
+    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
+
+    ALLOCATE(QQ_x(klon), stat=ierr)
+    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
+
+    ALLOCATE(QQ_w(klon), stat=ierr)
+    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
+
+    ALLOCATE(qsatsrf0_x(klon), stat=ierr)
+    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
+
+    ALLOCATE(qsatsrf0_w(klon), stat=ierr)
+    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
+
+    ALLOCATE(dqsatsrf0(klon), stat=ierr)
+    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
+
+    ALLOCATE(dd_Cdragh(klon), stat=ierr)
+    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
+
+    ALLOCATE(dd_Cdragm(klon), stat=ierr)
+    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
+
+    ALLOCATE(dd_Cdragq(klon), stat=ierr)
+    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
+
+    ALLOCATE(Kech_h(klon), stat=ierr)
+    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
+
+    ALLOCATE(Kech_h_x(klon), stat=ierr)
+    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
+
+    ALLOCATE(Kech_h_w(klon), stat=ierr)
+    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
+
+    ALLOCATE(Kech_q(klon), stat=ierr)
+    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
+
+    ALLOCATE(Kech_q_x(klon), stat=ierr)
+    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
+
+    ALLOCATE(Kech_q_w(klon), stat=ierr)
+    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
+
+    ALLOCATE(Kech_m(klon), stat=ierr)
+    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
+
+    ALLOCATE(Kech_m_x(klon), stat=ierr)
+    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
+
+    ALLOCATE(Kech_m_w(klon), stat=ierr)
+    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
+
+    ALLOCATE(Kech_Tp(klon), stat=ierr)
+    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
+
+    ALLOCATE(Kech_T_px(klon), stat=ierr)
+    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
+
+    ALLOCATE(Kech_T_pw(klon), stat=ierr)
+    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
+
+    ALLOCATE(dd_KTp(klon), stat=ierr)
+    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
+
+    ALLOCATE(KxKwTp(klon), stat=ierr)
+    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
+
+    ALLOCATE(dd_AT(klon), stat=ierr)
+    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
+
+    ALLOCATE(dd_BT(klon), stat=ierr)
+    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
+
+!----------------------------------------------------------------------------
+    ALLOCATE(Kech_Qp(klon), stat=ierr)
+    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
+
+    ALLOCATE(Kech_Q_px(klon), stat=ierr)
+    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
+
+    ALLOCATE(Kech_Q_pw(klon), stat=ierr)
+    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
+
+    ALLOCATE(dd_KQp(klon), stat=ierr)
+    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
+
+    ALLOCATE(KxKwQp(klon), stat=ierr)
+    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
+
+    ALLOCATE(Kech_Qs(klon), stat=ierr)
+    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
+
+    ALLOCATE(Kech_Q_sx(klon), stat=ierr)
+    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
+
+    ALLOCATE(Kech_Q_sw(klon), stat=ierr)
+    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
+
+    ALLOCATE(dd_KQs(klon), stat=ierr)
+    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
+
+    ALLOCATE(KxKwQs(klon), stat=ierr)
+    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
+
+!!!!!!!!!!
+    ALLOCATE(AQ_x(klon), stat=ierr)
+    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
+
+    ALLOCATE(AQ_w(klon), stat=ierr)
+    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
+
+    ALLOCATE(BQ_x(klon), stat=ierr)
+    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
+
+    ALLOCATE(BQ_w(klon), stat=ierr)
+    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
+
+    ALLOCATE(dd_AQ(klon), stat=ierr)
+    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
+
+    ALLOCATE(dd_BQ(klon), stat=ierr)
+    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
+
+!----------------------------------------------------------------------------
+    ALLOCATE(Kech_Up(klon), stat=ierr)
+    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
+
+    ALLOCATE(Kech_U_px(klon), stat=ierr)
+    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
+
+    ALLOCATE(Kech_U_pw(klon), stat=ierr)
+    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
+
+    ALLOCATE(dd_KUp(klon), stat=ierr)
+    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
+
+    ALLOCATE(KxKwUp(klon), stat=ierr)
+    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
+
+    ALLOCATE(dd_AU(klon), stat=ierr)
+    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
+
+    ALLOCATE(dd_BU(klon), stat=ierr)
+    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
+
+!----------------------------------------------------------------------------
+    ALLOCATE(Kech_Vp(klon), stat=ierr)
+    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
+
+    ALLOCATE(Kech_V_px(klon), stat=ierr)
+    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
+
+    ALLOCATE(Kech_V_pw(klon), stat=ierr)
+    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
+
+    ALLOCATE(dd_KVp(klon), stat=ierr)
+    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
+
+    ALLOCATE(KxKwVp(klon), stat=ierr)
+    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
+
+    ALLOCATE(dd_AV(klon), stat=ierr)
+    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
+
+    ALLOCATE(dd_BV(klon), stat=ierr)
+    IF (ierr /= 0) CALL abort_physic('wx_pbl_init', 'pb in allocation',1)
+
+!----------------------------------------------------------------------------
+
+END SUBROUTINE wx_pbl_init
+
+SUBROUTINE wx_pbl_prelim_0(knon, nsrf, dtime, ypplay, ypaprs, sigw,   &
+                                 yt_s, ydeltat_s, ygustiness, &
+                                 yt_x, yt_w, yq_x, yq_w, &
+                                 yu_x, yu_w, yv_x, yv_w, &
+                                 ycdragh_x, ycdragh_w, ycdragq_x, ycdragq_w, &
+                                 ycdragm_x, ycdragm_w, &
+                                 AcoefT_x, AcoefT_w, AcoefQ_x, AcoefQ_w, &
+                                 AcoefU_x, AcoefU_w, AcoefV_x, AcoefV_w, &
+                                 BcoefT_x, BcoefT_w, BcoefQ_x, BcoefQ_w, &
+                                 BcoefU_x, BcoefU_w, BcoefV_x, BcoefV_w, &
+                                 Kech_h_x_out, Kech_h_w_out, Kech_h_out  &
+                                 )
+!
+    USE print_control_mod, ONLY: prt_level,lunout
+    USE indice_sol_mod, ONLY: is_oce
+!
+    INCLUDE "YOMCST.h"
+    INCLUDE "FCTTRE.h"
+    INCLUDE "YOETHF.h"
+    INCLUDE "clesphys.h"
+!
+    INTEGER,                      INTENT(IN)        :: knon    ! number of grid cells
+    INTEGER,                      INTENT(IN)        :: nsrf    ! surface type
+    REAL,                         INTENT(IN)        :: dtime   ! time step size (s)
+    REAL, DIMENSION(knon,klev),   INTENT(IN)        :: ypplay  ! mid-layer pressure (Pa)
+    REAL, DIMENSION(knon,klev),   INTENT(IN)        :: ypaprs  ! pressure at layer interfaces (pa)
+    REAL, DIMENSION(knon),        INTENT(IN)        :: sigw ! cold pools fractional area
+    REAL, DIMENSION(knon),        INTENT(IN)        :: yt_s
+    REAL, DIMENSION(knon),        INTENT(IN)        :: ydeltat_s
+    REAL, DIMENSION(knon),        INTENT(IN)        :: ygustiness
+    REAL, DIMENSION(knon,klev),   INTENT(IN)        :: yt_x, yt_w, yq_x, yq_w
+    REAL, DIMENSION(knon,klev),   INTENT(IN)        :: yu_x, yu_w, yv_x, yv_w
+    REAL, DIMENSION(knon),        INTENT(IN)        :: ycdragh_x, ycdragh_w, ycdragq_x, ycdragq_w
+    REAL, DIMENSION(knon),        INTENT(IN)        :: ycdragm_x, ycdragm_w
+    REAL, DIMENSION(knon),        INTENT(IN)        :: AcoefT_x, AcoefT_w, AcoefQ_x, AcoefQ_w
+    REAL, DIMENSION(knon),        INTENT(IN)        :: AcoefU_x, AcoefU_w, AcoefV_x, AcoefV_w
+    REAL, DIMENSION(knon),        INTENT(IN)        :: BcoefT_x, BcoefT_w, BcoefQ_x, BcoefQ_w
+    REAL, DIMENSION(knon),        INTENT(IN)        :: BcoefU_x, BcoefU_w, BcoefV_x, BcoefV_w
+!
+    REAL, DIMENSION(knon),        INTENT(OUT)       :: Kech_h_x_out, Kech_h_w_out, Kech_h_out
+!
+! Local variables
+    INTEGER                    :: j
+    REAL                       :: rho1
+    REAL                       :: mod_wind_x
+    REAL                       :: mod_wind_w   
+    REAL                       :: dd_Kh
+    REAL                       :: dd_Kq
+    REAL                       :: dd_Km
+!
+    REAL                       :: zdelta, zcvm5, zcor, qsat
+! 
+    REAL, DIMENSION(knon)      :: sigx       ! fractional area of (x) region
+!
+!!!
+!!! jyg le 09/04/2013 ; passage aux nouvelles expressions en differences
+
+!
+!  First computations
+!  ------------------
+   eps_1 = 0.5
+   smallestreal=tiny(smallestreal)
+!
+   sigx(1:knon) = 1.-sigw(1:knon)
+! Compute Cp, Lv, qsat, dqsat_dT.
+   L_v(1:knon) = RLvtt
+   Ts0(1:knon) = yt_s(1:knon)
+   dTs0(1:knon) = ydeltat_s(1:knon)
+   q1_0b(1:knon) = sigw(1:knon)*yq_w(1:knon,1)+sigx(1:knon)*yq_x(1:knon,1)
+!
+! fqsat determination 
+! -------------------
+   IF (nsrf == is_oce) THEN
+     fqsat = f_qsat_oce
+   ELSE
+     fqsat = 1.
+   ENDIF
+!
+!
+!  Reference state
+!  ---------------
+   DO j = 1, knon
+      zdelta = MAX(0.,SIGN(1.,RTT-Ts0(j)))
+      zcvm5 = R5LES*(1.-zdelta) + R5IES*zdelta
+      qsat = R2ES*FOEEW(Ts0(j),zdelta)/ypaprs(j,1)
+      qsat = MIN(0.5,qsat)
+      zcor = 1./(1.-RETV*qsat)
+      qsat0(j) = fqsat*qsat*zcor
+      dqsatdT0(j) = fqsat*FOEDE(Ts0(j),zdelta,zcvm5,qsat0(j),zcor)
+      C_p(j) = RCpd + qsat0(j)*(RCpv - RCpd)
+      C_p(j) = RCpd
+!
+!      print *,' AAAA wx_pbl0, C_p(j), qsat0(j), Ts0(j) : ', C_p(j), qsat0(j), Ts0(j)
+   ENDDO
+   DO j = 1, knon
+      Ts0_x(j) = Ts0(j) - sigw(j)*dTs0(j)
+      zdelta = MAX(0.,SIGN(1.,RTT-Ts0_x(j)))
+      zcvm5 = R5LES*(1.-zdelta) + R5IES*zdelta
+!!      zcvm5 = R5LES*RLVTT*(1.-zdelta) + R5IES*RLSTT*zdelta
+      qsat = R2ES*FOEEW(Ts0_x(j),zdelta)/ypaprs(j,1)
+      qsat = MIN(0.5,qsat)
+      zcor = 1./(1.-RETV*qsat)
+      qsat0_x(j) = fqsat*qsat*zcor
+      dqsatdT0_x(j) = fqsat*FOEDE(Ts0_x(j),zdelta,zcvm5,qsat0_x(j),zcor)
+!!      dqsatdT0_x(j) = (RLvtt*(1.-zdelta)+RLSTT*zdelta)*qsat0_x(j)/(Rv*Ts0_x(j)*Ts0_x(j))
+   ENDDO
+   DO j = 1, knon
+      Ts0_w(j) = Ts0(j) + sigx(j)*dTs0(j)
+      zdelta = MAX(0.,SIGN(1.,RTT-Ts0_w(j)))
+      zcvm5 = R5LES*(1.-zdelta) + R5IES*zdelta
+!!      zcvm5 = R5LES*RLVTT*(1.-zdelta) + R5IES*RLSTT*zdelta
+      qsat = R2ES*FOEEW(Ts0_w(j),zdelta)/ypaprs(j,1)
+      qsat = MIN(0.5,qsat)
+      zcor = 1./(1.-RETV*qsat)
+      qsat0_w(j) = fqsat*qsat*zcor
+      dqsatdT0_w(j) = fqsat*FOEDE(Ts0_w(j),zdelta,zcvm5,qsat0_w(j),zcor)
+!!      dqsatdT0_w(j) = (RLvtt*(1.-zdelta)+RLSTT*zdelta)*qsat0_w(j)/(Rv*Ts0_w(j)*Ts0_w(j))
+   ENDDO
+!
+   QQ_x(1:knon)  = 1./dqsatdT0_x(1:knon)
+   QQ_w(1:knon)  = 1./dqsatdT0_w(1:knon)
+   QQ_b(1:knon)  = sigw(1:knon)*QQ_w(1:knon) + sigx(1:knon)*QQ_x(1:knon)
+   dd_QQ(1:knon) = QQ_w(1:knon) - QQ_x(1:knon)
+!
+        DO j=1,knon
+!
+! Exchange coefficients computation
+! ---------------------------------
+!
+! Wind factor (Warning : this is not valid when using land_surf_orchidee)
+         mod_wind_x = min_wind_speed+SQRT(ygustiness(j)+yu_x(j,1)**2+yv_x(j,1)**2)
+         mod_wind_w = min_wind_speed+SQRT(ygustiness(j)+yu_w(j,1)**2+yv_w(j,1)**2)
+!
+!!         rho1 = ypplay(j,1)/(RD*yt(j,1))
+         rho1 = ypplay(j,1)/(RD*(yt_x(j,1) + sigw(j)*(yt_w(j,1)-yt_x(j,1))))
+! 
+! (w) and (x) Exchange coefficients
+         Kech_h_x(j) = ycdragh_x(j) * mod_wind_x * rho1
+         Kech_h_w(j) = ycdragh_w(j) * mod_wind_w * rho1
+         Kech_q_x(j) = ycdragq_x(j) * mod_wind_x * rho1
+         Kech_q_w(j) = ycdragq_w(j) * mod_wind_w * rho1
+         Kech_m_x(j) = ycdragm_x(j) * mod_wind_x * rho1
+         Kech_m_w(j) = ycdragm_w(j) * mod_wind_w * rho1
+!!  Print *,'YYYYpbl0: ycdragh_x, ycdragq_x, mod_wind_x, rho1, Kech_q_x, Kech_h_x ', &
+!!                     ycdragh_x(j), ycdragq_x(j), mod_wind_x, rho1, Kech_q_x(j), Kech_h_x(j)
+!!  Print *,'YYYYpbl0: ycdragh_w, ycdragq_w, mod_wind_w, rho1, Kech_q_w, Kech_h_w ', &
+!!                     ycdragh_w(j), ycdragq_w(j), mod_wind_w, rho1, Kech_q_w(j), Kech_h_w(j)
+!
+! Merged exchange coefficients
+         dd_Kh = Kech_h_w(j) - Kech_h_x(j)
+         dd_Kq = Kech_q_w(j) - Kech_q_x(j)
+         dd_Km = Kech_m_w(j) - Kech_m_x(j)
+         IF (prt_level >=10) THEN
+          print *,' mod_wind_x, mod_wind_w ', mod_wind_x, mod_wind_w
+          print *,' rho1 ',rho1
+          print *,' ycdragh_x(j),ycdragm_x(j) ',ycdragh_x(j),ycdragm_x(j)
+          print *,' ycdragh_w(j),ycdragm_w(j) ',ycdragh_w(j),ycdragm_w(j)
+          print *,' dd_Kh: ',dd_Kh
+         ENDIF
+!
+         Kech_h(j) = Kech_h_x(j) + sigw(j)*dd_Kh
+         Kech_q(j) = Kech_q_x(j) + sigw(j)*dd_Kq
+         Kech_m(j) = Kech_m_x(j) + sigw(j)*dd_Km
+!
+         Kech_h_x_out(j) = Kech_h_x(j)
+         Kech_h_w_out(j) = Kech_h_w(j)
+         Kech_h_out(j)   = Kech_h(j)
+!
+! Effective exchange coefficient computation
+! ------------------------------------------
+        Kech_T_px(j) = Kech_h_x(j)/(1.-BcoefT_x(j)*Kech_h_x(j)*dtime)
+        Kech_T_pw(j) = Kech_h_w(j)/(1.-BcoefT_w(j)*Kech_h_w(j)*dtime)
+!
+        Kech_Q_px(j) = Kech_q_x(j)/(1.-BcoefQ_x(j)*Kech_q_x(j)*dtime)
+        Kech_Q_pw(j) = Kech_q_w(j)/(1.-BcoefQ_w(j)*Kech_q_w(j)*dtime)
+!
+        Kech_U_px(j) = Kech_m_x(j)/(1.-BcoefU_x(j)*Kech_m_x(j)*dtime)
+        Kech_U_pw(j) = Kech_m_w(j)/(1.-BcoefU_w(j)*Kech_m_w(j)*dtime)
+!
+        Kech_V_px(j) = Kech_m_x(j)/(1.-BcoefV_x(j)*Kech_m_x(j)*dtime)
+        Kech_V_pw(j) = Kech_m_w(j)/(1.-BcoefV_w(j)*Kech_m_w(j)*dtime)
+!
+         dd_KTp(j) = Kech_T_pw(j) - Kech_T_px(j)
+         dd_KQp(j) = Kech_Q_pw(j) - Kech_Q_px(j)
+         dd_KUp(j) = Kech_U_pw(j) - Kech_U_px(j)
+         dd_KVp(j) = Kech_V_pw(j) - Kech_V_px(j)
+!
+        Kech_Tp(j) = Kech_T_px(j) + sigw(j)*dd_KTp(j)
+        Kech_Qp(j) = Kech_Q_px(j) + sigw(j)*dd_KQp(j)
+        Kech_Up(j) = Kech_U_px(j) + sigw(j)*dd_KUp(j)
+        Kech_Vp(j) = Kech_V_px(j) + sigw(j)*dd_KVp(j)
+!
+! Store AQ and BQ in the module variables
+       AQ_x(j) = AcoefQ_x(j)
+       AQ_w(j) = AcoefQ_w(j)
+       BQ_x(j) = BcoefQ_x(j)
+       BQ_w(j) = BcoefQ_w(j)
+!
+! Calcul des differences w-x
+       dd_Cdragm(j) = ycdragm_w(j) - ycdragm_x(j)
+       dd_Cdragh(j) = ycdragh_w(j) - ycdragh_x(j)
+       dd_Cdragq(j) = ycdragq_w(j) - ycdragq_x(j)
+!
+       dd_AT(j) = AcoefT_w(j) - AcoefT_x(j)
+       dd_AQ(j) = AcoefQ_w(j) - AcoefQ_x(j)
+       dd_AU(j) = AcoefU_w(j) - AcoefU_x(j)
+       dd_AV(j) = AcoefV_w(j) - AcoefV_x(j)
+       dd_BT(j) = BcoefT_w(j) - BcoefT_x(j)
+       dd_BQ(j) = BcoefQ_w(j) - BcoefQ_x(j)
+       dd_BU(j) = BcoefU_w(j) - BcoefU_x(j)
+       dd_BV(j) = BcoefV_w(j) - BcoefV_x(j)
+!
+       KxKwTp(j) = Kech_T_px(j)*Kech_T_pw(j)
+       KxKwQp(j) = Kech_Q_px(j)*Kech_Q_pw(j)
+       KxKwUp(j) = Kech_U_px(j)*Kech_U_pw(j)
+       KxKwVp(j) = Kech_V_px(j)*Kech_V_pw(j)
+!                                           
+!
+       IF (prt_level >=10) THEN
+          print *,'Variables pour la fusion : Kech_T_px(j)' ,Kech_T_px(j)
+          print *,'Variables pour la fusion : Kech_T_pw(j)' ,Kech_T_pw(j)
+          print *,'Variables pour la fusion : Kech_Tp(j)' ,Kech_Tp(j)
+          print *,'Variables pour la fusion : Kech_h(j)' ,Kech_h(j)
+       ENDIF
+
+     ENDDO  ! j = 1, knon
+
+     RETURN
+
+END SUBROUTINE wx_pbl_prelim_0
+
+SUBROUTINE wx_pbl_prelim_beta(knon, dtime,  &
+                                 sigw, beta,       &
+                                 BcoefQ_x, BcoefQ_w &
+                                 )
+!
+    USE print_control_mod, ONLY: prt_level,lunout
+    USE indice_sol_mod, ONLY: is_oce
+!
+    INTEGER,                      INTENT(IN)        :: knon    ! number of grid cells
+    REAL,                         INTENT(IN)        :: dtime   ! time step size (s)
+    REAL, DIMENSION(knon),        INTENT(IN)        :: sigw ! cold pools fractional area
+    REAL, DIMENSION(knon),        INTENT(IN)        :: beta ! evaporation by potential evaporation
+    REAL, DIMENSION(knon),        INTENT(IN)        :: BcoefQ_x, BcoefQ_w
+!
+! Local variables
+    INTEGER                    :: j
+!
+   DO j = 1, knon
+!
+        qsatsrf0_x(j) = beta(j)*qsat0_x(j)
+        qsatsrf0_w(j) = beta(j)*qsat0_w(j)
+        dqsatsrf0(j)  = qsatsrf0_w(j) - qsatsrf0_x(j)
+!
+        Kech_Q_sx(j) = Kech_q_x(j)/(1.-beta(j)*BcoefQ_x(j)*Kech_q_x(j)*dtime)
+        Kech_Q_sw(j) = Kech_q_w(j)/(1.-beta(j)*BcoefQ_w(j)*Kech_q_w(j)*dtime)
+!
+        dd_KQs(j) = Kech_Q_sw(j) - Kech_Q_sx(j)
+!
+        Kech_Qs(j) = Kech_Q_sx(j) + sigw(j)*dd_KQs(j)
+!
+        KxKwQs(j) = Kech_Q_sx(j)*Kech_Q_sw(j)
+!
+!!  print *,'BBBBwx_prelim_beta : beta ', beta(j)
+!
+  ENDDO ! j = 1, knon
+
+  RETURN
+
+END SUBROUTINE wx_pbl_prelim_beta
+
+SUBROUTINE wx_pbl_final
+!
+!****************************************************************************************
+! Deallocate module variables
+!
+!****************************************************************************************    
+!
+    IF (ALLOCATED(C_p))           DEALLOCATE(C_p)
+    IF (ALLOCATED(L_v))           DEALLOCATE(L_v)
+    IF (ALLOCATED(Ts0))           DEALLOCATE(Ts0)
+    IF (ALLOCATED(dTs0))          DEALLOCATE(dTs0)
+    IF (ALLOCATED(Ts0_x))         DEALLOCATE(Ts0_x)
+    IF (ALLOCATED(Ts0_w))         DEALLOCATE(Ts0_w)
+    IF (ALLOCATED(qsat0))         DEALLOCATE(qsat0)
+    IF (ALLOCATED(dqsatdT0))      DEALLOCATE(dqsatdT0 )
+    IF (ALLOCATED(qsat0_x))       DEALLOCATE(qsat0_x)
+    IF (ALLOCATED(dqsatdT0_x))    DEALLOCATE(dqsatdT0_x )
+    IF (ALLOCATED(qsat0_w))       DEALLOCATE(qsat0_w)
+    IF (ALLOCATED(dqsatdT0_w))    DEALLOCATE(dqsatdT0_w )
+    IF (ALLOCATED(q1_0b))         DEALLOCATE(q1_0b)
+    IF (ALLOCATED(QQ_b))          DEALLOCATE(QQ_b)
+    IF (ALLOCATED(dd_QQ))         DEALLOCATE(dd_QQ)
+    IF (ALLOCATED(QQ_x))          DEALLOCATE(QQ_x)
+    IF (ALLOCATED(QQ_w))          DEALLOCATE(QQ_w)
+    IF (ALLOCATED(qsatsrf0_x))    DEALLOCATE(qsatsrf0_x)
+    IF (ALLOCATED(qsatsrf0_w))    DEALLOCATE(qsatsrf0_w)
+    IF (ALLOCATED(dqsatsrf0))     DEALLOCATE(dqsatsrf0)
+    IF (ALLOCATED(dd_Cdragh))     DEALLOCATE(dd_Cdragh)
+    IF (ALLOCATED(dd_Cdragm))     DEALLOCATE(dd_Cdragm)
+    IF (ALLOCATED(dd_Cdragq))     DEALLOCATE(dd_Cdragq)
+    IF (ALLOCATED(Kech_h))        DEALLOCATE(Kech_h)
+    IF (ALLOCATED(Kech_h_x))      DEALLOCATE(Kech_h_x)
+    IF (ALLOCATED(Kech_h_w))      DEALLOCATE(Kech_h_w)
+    IF (ALLOCATED(Kech_q))        DEALLOCATE(Kech_q)
+    IF (ALLOCATED(Kech_q_x))      DEALLOCATE(Kech_q_x)
+    IF (ALLOCATED(Kech_q_w))      DEALLOCATE(Kech_q_w)
+    IF (ALLOCATED(Kech_m))        DEALLOCATE(Kech_m)
+    IF (ALLOCATED(Kech_m_x))      DEALLOCATE(Kech_m_x)
+    IF (ALLOCATED(Kech_m_w))      DEALLOCATE(Kech_m_w)
+    IF (ALLOCATED(Kech_Tp))       DEALLOCATE(Kech_Tp)
+    IF (ALLOCATED(Kech_T_px))     DEALLOCATE(Kech_T_px)
+    IF (ALLOCATED(Kech_T_pw))     DEALLOCATE(Kech_T_pw)
+    IF (ALLOCATED(dd_KTp))        DEALLOCATE(dd_KTp)
+    IF (ALLOCATED(KxKwTp))        DEALLOCATE(KxKwTp)
+    IF (ALLOCATED(dd_AT))         DEALLOCATE(dd_AT)
+    IF (ALLOCATED(dd_BT))         DEALLOCATE(dd_BT)
+    IF (ALLOCATED(Kech_Qp))       DEALLOCATE(Kech_Qp)
+    IF (ALLOCATED(Kech_Q_px))     DEALLOCATE(Kech_Q_px)
+    IF (ALLOCATED(Kech_Q_pw))     DEALLOCATE(Kech_Q_pw)
+    IF (ALLOCATED(dd_KQp))        DEALLOCATE(dd_KQp)
+    IF (ALLOCATED(KxKwQp))        DEALLOCATE(KxKwQp)
+    IF (ALLOCATED(Kech_Qs))       DEALLOCATE(Kech_Qs)
+    IF (ALLOCATED(Kech_Q_sx))     DEALLOCATE(Kech_Q_sx)
+    IF (ALLOCATED(Kech_Q_sw))     DEALLOCATE(Kech_Q_sw)
+    IF (ALLOCATED(dd_KQs))        DEALLOCATE(dd_KQs)
+    IF (ALLOCATED(KxKwQs ))       DEALLOCATE(KxKwQs )
+    IF (ALLOCATED(AQ_x))          DEALLOCATE(AQ_x)
+    IF (ALLOCATED(AQ_w))          DEALLOCATE(AQ_w)
+    IF (ALLOCATED(BQ_x))          DEALLOCATE(BQ_x)
+    IF (ALLOCATED(BQ_w))          DEALLOCATE(BQ_w)
+    IF (ALLOCATED(dd_AQ))         DEALLOCATE(dd_AQ)
+    IF (ALLOCATED(dd_BQ ))        DEALLOCATE(dd_BQ )
+    IF (ALLOCATED(Kech_Up))       DEALLOCATE(Kech_Up)
+    IF (ALLOCATED(Kech_U_px))     DEALLOCATE(Kech_U_px)
+    IF (ALLOCATED(Kech_U_pw))     DEALLOCATE(Kech_U_pw)
+    IF (ALLOCATED(dd_KUp))        DEALLOCATE(dd_KUp)
+    IF (ALLOCATED(KxKwUp))        DEALLOCATE(KxKwUp)
+    IF (ALLOCATED(dd_AU))         DEALLOCATE(dd_AU)
+    IF (ALLOCATED(dd_BU))         DEALLOCATE(dd_BU)
+    IF (ALLOCATED(Kech_Vp))       DEALLOCATE(Kech_Vp)
+    IF (ALLOCATED(Kech_V_px))     DEALLOCATE(Kech_V_px)
+    IF (ALLOCATED(Kech_V_pw))     DEALLOCATE(Kech_V_pw)
+    IF (ALLOCATED(dd_KVp))        DEALLOCATE(dd_KVp)
+    IF (ALLOCATED(KxKwVp))        DEALLOCATE(KxKwVp)
+    IF (ALLOCATED(dd_AV))         DEALLOCATE(dd_AV)
+    IF (ALLOCATED(dd_BV))         DEALLOCATE(dd_BV)
+
+END SUBROUTINE wx_pbl_final
+
+END MODULE wx_pbl_var_mod
+
Index: DZ6/trunk/libf/phylmd/yamada.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/yamada.F90	(revision 5267)
+++ 	(revision )
@@ -1,170 +1,0 @@
-
-! $Header$
-
-SUBROUTINE yamada(ngrid, dt, g, rconst, plev, temp, zlev, zlay, u, v, teta, &
-    cd, q2, km, kn, ustar, l_mix)
-  USE dimphy
-  IMPLICIT NONE
-
-  ! dt : pas de temps
-  ! g  : g
-  ! zlev : altitude a chaque niveau (interface inferieure de la couche
-  ! de meme indice)
-  ! zlay : altitude au centre de chaque couche
-  ! u,v : vitesse au centre de chaque couche
-  ! (en entree : la valeur au debut du pas de temps)
-  ! teta : temperature potentielle au centre de chaque couche
-  ! (en entree : la valeur au debut du pas de temps)
-  ! cd : cdrag
-  ! (en entree : la valeur au debut du pas de temps)
-  ! q2 : $q^2$ au bas de chaque couche
-  ! (en entree : la valeur au debut du pas de temps)
-  ! (en sortie : la valeur a la fin du pas de temps)
-  ! km : diffusivite turbulente de quantite de mouvement (au bas de chaque
-  ! couche)
-  ! (en sortie : la valeur a la fin du pas de temps)
-  ! kn : diffusivite turbulente des scalaires (au bas de chaque couche)
-  ! (en sortie : la valeur a la fin du pas de temps)
-
-  ! .......................................................................
-  REAL dt, g, rconst
-  REAL plev(klon, klev+1), temp(klon, klev)
-  REAL ustar(klon), snstable
-  REAL zlev(klon, klev+1)
-  REAL zlay(klon, klev)
-  REAL u(klon, klev)
-  REAL v(klon, klev)
-  REAL teta(klon, klev)
-  REAL cd(klon)
-  REAL q2(klon, klev+1)
-  REAL km(klon, klev+1)
-  REAL kn(klon, klev+1)
-  INTEGER l_mix, ngrid
-
-
-  INTEGER nlay, nlev
-  ! ym      PARAMETER (nlay=klev)
-  ! ym      PARAMETER (nlev=klev+1)
-
-  LOGICAL first
-  SAVE first
-  DATA first/.TRUE./
-  !$OMP THREADPRIVATE(first)
-
-  INTEGER ig, k
-
-  REAL ri, zrif, zalpha, zsm
-  REAL rif(klon, klev+1), sm(klon, klev+1), alpha(klon, klev)
-
-  REAL m2(klon, klev+1), dz(klon, klev+1), zq, n2(klon, klev+1)
-  REAL l(klon, klev+1), l0(klon)
-
-  REAL sq(klon), sqz(klon), zz(klon, klev+1)
-  INTEGER iter
-
-  REAL ric, rifc, b1, kap
-  SAVE ric, rifc, b1, kap
-  DATA ric, rifc, b1, kap/0.195, 0.191, 16.6, 0.3/
-  !$OMP THREADPRIVATE(ric,rifc,b1,kap)
-
-  REAL frif, falpha, fsm
-
-  frif(ri) = 0.6588*(ri+0.1776-sqrt(ri*ri-0.3221*ri+0.03156))
-  falpha(ri) = 1.318*(0.2231-ri)/(0.2341-ri)
-  fsm(ri) = 1.96*(0.1912-ri)*(0.2341-ri)/((1.-ri)*(0.2231-ri))
-
-  nlay = klev
-  nlev = klev + 1
-
-  IF (0==1 .AND. first) THEN
-    DO ig = 1, 1000
-      ri = (ig-800.)/500.
-      IF (ri<ric) THEN
-        zrif = frif(ri)
-      ELSE
-        zrif = rifc
-      END IF
-      IF (zrif<0.16) THEN
-        zalpha = falpha(zrif)
-        zsm = fsm(zrif)
-      ELSE
-        zalpha = 1.12
-        zsm = 0.085
-      END IF
-      PRINT *, ri, rif, zalpha, zsm
-    END DO
-    first = .FALSE.
-  END IF
-
-  ! Correction d'un bug sauvage a verifier.
-  ! do k=2,nlev
-  DO k = 2, nlay
-    DO ig = 1, ngrid
-      dz(ig, k) = zlay(ig, k) - zlay(ig, k-1)
-      m2(ig, k) = ((u(ig,k)-u(ig,k-1))**2+(v(ig,k)-v(ig, &
-        k-1))**2)/(dz(ig,k)*dz(ig,k))
-      n2(ig, k) = g*2.*(teta(ig,k)-teta(ig,k-1))/(teta(ig,k-1)+teta(ig,k))/ &
-        dz(ig, k)
-      ri = n2(ig, k)/max(m2(ig,k), 1.E-10)
-      IF (ri<ric) THEN
-        rif(ig, k) = frif(ri)
-      ELSE
-        rif(ig, k) = rifc
-      END IF
-      IF (rif(ig,k)<0.16) THEN
-        alpha(ig, k) = falpha(rif(ig,k))
-        sm(ig, k) = fsm(rif(ig,k))
-      ELSE
-        alpha(ig, k) = 1.12
-        sm(ig, k) = 0.085
-      END IF
-      zz(ig, k) = b1*m2(ig, k)*(1.-rif(ig,k))*sm(ig, k)
-    END DO
-  END DO
-
-  ! iterration pour determiner la longueur de melange
-
-  DO ig = 1, ngrid
-    l0(ig) = 100.
-  END DO
-  DO k = 2, klev
-    DO ig = 1, ngrid
-      l(ig, k) = l0(ig)*kap*zlev(ig, k)/(kap*zlev(ig,k)+l0(ig))
-    END DO
-  END DO
-
-  DO iter = 1, 10
-    DO ig = 1, ngrid
-      sq(ig) = 1.E-10
-      sqz(ig) = 1.E-10
-    END DO
-    !DO k = 2, klev - 1
-    DO k = 2, klev
-      DO ig = 1, ngrid
-        q2(ig, k) = l(ig, k)**2*zz(ig, k)
-        l(ig, k) = min(l0(ig)*kap*zlev(ig,k)/(kap*zlev(ig, &
-          k)+l0(ig)), 0.5*sqrt(q2(ig,k))/sqrt(max(n2(ig,k),1.E-10)))
-        zq = sqrt(q2(ig,k))
-        sqz(ig) = sqz(ig) + zq*zlev(ig, k)*(zlay(ig,k)-zlay(ig,k-1))
-        sq(ig) = sq(ig) + zq*(zlay(ig,k)-zlay(ig,k-1))
-      END DO
-    END DO
-    DO ig = 1, ngrid
-      l0(ig) = 0.2*sqz(ig)/sq(ig)
-    END DO
-    ! (abd 3 5 2)         print*,'ITER=',iter,'  L0=',l0
-
-  END DO
-
-  DO k = 2, klev
-    DO ig = 1, ngrid
-      l(ig, k) = min(l0(ig)*kap*zlev(ig,k)/(kap*zlev(ig, &
-        k)+l0(ig)), 0.5*sqrt(q2(ig,k))/sqrt(max(n2(ig,k),1.E-10)))
-      q2(ig, k) = l(ig, k)**2*zz(ig, k)
-      km(ig, k) = l(ig, k)*sqrt(q2(ig,k))*sm(ig, k)
-      kn(ig, k) = km(ig, k)*alpha(ig, k)
-    END DO
-  END DO
-
-  RETURN
-END SUBROUTINE yamada
Index: /LMDZ6/trunk/libf/phylmd/yamada.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/yamada.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/yamada.f90	(revision 5268)
@@ -0,0 +1,170 @@
+
+! $Header$
+
+SUBROUTINE yamada(ngrid, dt, g, rconst, plev, temp, zlev, zlay, u, v, teta, &
+    cd, q2, km, kn, ustar, l_mix)
+  USE dimphy
+  IMPLICIT NONE
+
+  ! dt : pas de temps
+  ! g  : g
+  ! zlev : altitude a chaque niveau (interface inferieure de la couche
+  ! de meme indice)
+  ! zlay : altitude au centre de chaque couche
+  ! u,v : vitesse au centre de chaque couche
+  ! (en entree : la valeur au debut du pas de temps)
+  ! teta : temperature potentielle au centre de chaque couche
+  ! (en entree : la valeur au debut du pas de temps)
+  ! cd : cdrag
+  ! (en entree : la valeur au debut du pas de temps)
+  ! q2 : $q^2$ au bas de chaque couche
+  ! (en entree : la valeur au debut du pas de temps)
+  ! (en sortie : la valeur a la fin du pas de temps)
+  ! km : diffusivite turbulente de quantite de mouvement (au bas de chaque
+  ! couche)
+  ! (en sortie : la valeur a la fin du pas de temps)
+  ! kn : diffusivite turbulente des scalaires (au bas de chaque couche)
+  ! (en sortie : la valeur a la fin du pas de temps)
+
+  ! .......................................................................
+  REAL dt, g, rconst
+  REAL plev(klon, klev+1), temp(klon, klev)
+  REAL ustar(klon), snstable
+  REAL zlev(klon, klev+1)
+  REAL zlay(klon, klev)
+  REAL u(klon, klev)
+  REAL v(klon, klev)
+  REAL teta(klon, klev)
+  REAL cd(klon)
+  REAL q2(klon, klev+1)
+  REAL km(klon, klev+1)
+  REAL kn(klon, klev+1)
+  INTEGER l_mix, ngrid
+
+
+  INTEGER nlay, nlev
+  ! ym      PARAMETER (nlay=klev)
+  ! ym      PARAMETER (nlev=klev+1)
+
+  LOGICAL first
+  SAVE first
+  DATA first/.TRUE./
+  !$OMP THREADPRIVATE(first)
+
+  INTEGER ig, k
+
+  REAL ri, zrif, zalpha, zsm
+  REAL rif(klon, klev+1), sm(klon, klev+1), alpha(klon, klev)
+
+  REAL m2(klon, klev+1), dz(klon, klev+1), zq, n2(klon, klev+1)
+  REAL l(klon, klev+1), l0(klon)
+
+  REAL sq(klon), sqz(klon), zz(klon, klev+1)
+  INTEGER iter
+
+  REAL ric, rifc, b1, kap
+  SAVE ric, rifc, b1, kap
+  DATA ric, rifc, b1, kap/0.195, 0.191, 16.6, 0.3/
+  !$OMP THREADPRIVATE(ric,rifc,b1,kap)
+
+  REAL frif, falpha, fsm
+
+  frif(ri) = 0.6588*(ri+0.1776-sqrt(ri*ri-0.3221*ri+0.03156))
+  falpha(ri) = 1.318*(0.2231-ri)/(0.2341-ri)
+  fsm(ri) = 1.96*(0.1912-ri)*(0.2341-ri)/((1.-ri)*(0.2231-ri))
+
+  nlay = klev
+  nlev = klev + 1
+
+  IF (0==1 .AND. first) THEN
+    DO ig = 1, 1000
+      ri = (ig-800.)/500.
+      IF (ri<ric) THEN
+        zrif = frif(ri)
+      ELSE
+        zrif = rifc
+      END IF
+      IF (zrif<0.16) THEN
+        zalpha = falpha(zrif)
+        zsm = fsm(zrif)
+      ELSE
+        zalpha = 1.12
+        zsm = 0.085
+      END IF
+      PRINT *, ri, rif, zalpha, zsm
+    END DO
+    first = .FALSE.
+  END IF
+
+  ! Correction d'un bug sauvage a verifier.
+  ! do k=2,nlev
+  DO k = 2, nlay
+    DO ig = 1, ngrid
+      dz(ig, k) = zlay(ig, k) - zlay(ig, k-1)
+      m2(ig, k) = ((u(ig,k)-u(ig,k-1))**2+(v(ig,k)-v(ig, &
+        k-1))**2)/(dz(ig,k)*dz(ig,k))
+      n2(ig, k) = g*2.*(teta(ig,k)-teta(ig,k-1))/(teta(ig,k-1)+teta(ig,k))/ &
+        dz(ig, k)
+      ri = n2(ig, k)/max(m2(ig,k), 1.E-10)
+      IF (ri<ric) THEN
+        rif(ig, k) = frif(ri)
+      ELSE
+        rif(ig, k) = rifc
+      END IF
+      IF (rif(ig,k)<0.16) THEN
+        alpha(ig, k) = falpha(rif(ig,k))
+        sm(ig, k) = fsm(rif(ig,k))
+      ELSE
+        alpha(ig, k) = 1.12
+        sm(ig, k) = 0.085
+      END IF
+      zz(ig, k) = b1*m2(ig, k)*(1.-rif(ig,k))*sm(ig, k)
+    END DO
+  END DO
+
+  ! iterration pour determiner la longueur de melange
+
+  DO ig = 1, ngrid
+    l0(ig) = 100.
+  END DO
+  DO k = 2, klev
+    DO ig = 1, ngrid
+      l(ig, k) = l0(ig)*kap*zlev(ig, k)/(kap*zlev(ig,k)+l0(ig))
+    END DO
+  END DO
+
+  DO iter = 1, 10
+    DO ig = 1, ngrid
+      sq(ig) = 1.E-10
+      sqz(ig) = 1.E-10
+    END DO
+    !DO k = 2, klev - 1
+    DO k = 2, klev
+      DO ig = 1, ngrid
+        q2(ig, k) = l(ig, k)**2*zz(ig, k)
+        l(ig, k) = min(l0(ig)*kap*zlev(ig,k)/(kap*zlev(ig, &
+          k)+l0(ig)), 0.5*sqrt(q2(ig,k))/sqrt(max(n2(ig,k),1.E-10)))
+        zq = sqrt(q2(ig,k))
+        sqz(ig) = sqz(ig) + zq*zlev(ig, k)*(zlay(ig,k)-zlay(ig,k-1))
+        sq(ig) = sq(ig) + zq*(zlay(ig,k)-zlay(ig,k-1))
+      END DO
+    END DO
+    DO ig = 1, ngrid
+      l0(ig) = 0.2*sqz(ig)/sq(ig)
+    END DO
+    ! (abd 3 5 2)         print*,'ITER=',iter,'  L0=',l0
+
+  END DO
+
+  DO k = 2, klev
+    DO ig = 1, ngrid
+      l(ig, k) = min(l0(ig)*kap*zlev(ig,k)/(kap*zlev(ig, &
+        k)+l0(ig)), 0.5*sqrt(q2(ig,k))/sqrt(max(n2(ig,k),1.E-10)))
+      q2(ig, k) = l(ig, k)**2*zz(ig, k)
+      km(ig, k) = l(ig, k)*sqrt(q2(ig,k))*sm(ig, k)
+      kn(ig, k) = km(ig, k)*alpha(ig, k)
+    END DO
+  END DO
+
+  RETURN
+END SUBROUTINE yamada
Index: DZ6/trunk/libf/phylmd/yamada4.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/yamada4.F90	(revision 5267)
+++ 	(revision )
@@ -1,1122 +1,0 @@
-!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-
-SUBROUTINE yamada4(ni, nsrf, ngrid, dt, g, rconst, plev, temp, zlev, zlay, u, v, teta, &
-    cd, tke, eps, km, kn, kq, ustar, iflag_pbl, drgpro)
-
-  USE dimphy, only : klev,klon
-  USE phys_local_var_mod, only: wprime
-  USE yamada_ini_mod, only : new_yamada4,yamada4_num,hboville
-  USE yamada_ini_mod, only : prt_level, lunout,pbl_lmixmin_alpha,b1,kap,viscom,viscoh
-  USE yamada_ini_mod, only : ric, yun,ydeux,lmixmin,iflag_vdif_q2
-  
-  IMPLICIT NONE
-  ! ************************************************************************************************
-  !
-  ! yamada4: subroutine qui calcule le transfert turbulent avec une fermeture d'ordre 2 ou 2.5
-  ! 
-  ! Reference: Simulation of nocturnal drainage flows by a q2l Turbulence Closure Model
-  !            Yamada T.
-  !            J. Atmos. Sci, 40, 91-106, 1983
-  !
-  !************************************************************************************************
-  ! Input :
-  !'======
-  ! ni: indice horizontal sur la grille de base, non restreinte
-  ! nsrf: type de surface
-  ! ngrid: nombre de mailles concern??es sur l'horizontal
-  ! dt : pas de temps
-  ! g  : g
-  ! rconst: constante de l'air sec
-  ! zlev : altitude a chaque niveau (interface inferieure de la couche
-  ! de meme indice)
-  ! zlay : altitude au centre de chaque couche
-  ! u,v : vitesse au centre de chaque couche
-  ! (en entree : la valeur au debut du pas de temps)
-  ! teta : temperature potentielle virtuelle au centre de chaque couche
-  ! (en entree : la valeur au debut du pas de temps)
-  ! cd : cdrag pour la quantit?? de mouvement
-  ! (en entree : la valeur au debut du pas de temps)
-  ! ustar: vitesse de friction calcul??e par une formule diagnostique 
-  ! iflag_pbl: flag pour choisir des options du sch??ma de turbulence
-  !
-  !             iflag_pbl doit valoir entre 6 et 9
-  !             l=6, on prend  systematiquement une longueur d'equilibre
-  !             iflag_pbl=6 : MY 2.0
-  !             iflag_pbl=7 : MY 2.0.Fournier
-  !             iflag_pbl=8/9 : MY 2.5
-  !             iflag_pbl=8 with special obsolete treatments for convergence
-  !             with Cmpi5 NPv3.1 simulations
-  !             iflag_pbl=10/11 :  New scheme M2 and N2 explicit and dissiptation exact
-  !             iflag_pbl=12 = 11 with vertical diffusion off q2
-  !
-  !             2013/04/01 (FH hourdin@lmd.jussieu.fr)
-  !             Correction for very stable PBLs (iflag_pbl=10 and 11)
-  !             iflag_pbl=8 converges numerically with NPv3.1
-  !             iflag_pbl=11 -> the model starts with NP from start files created by ce0l
-  !                          -> the model can run with longer time-steps.
-  !             2016/11/30 (EV etienne.vignon@lmd.ipsl.fr)
-  !               On met tke (=q2/2) en entr??e plut??t que q2
-  !               On corrige l'update de la tke
-  !             2020/10/01 (EV)
-  !               On ajoute la dissipation de la TKE en diagnostique de sortie
-  !                  
-  ! Inpout/Output :
-  !==============
-  ! tke : tke au bas de chaque couche
-  ! (en entree : la valeur au debut du pas de temps)
-  ! (en sortie : la valeur a la fin du pas de temps)
- 
-  ! Outputs:
-  !==========
-  ! eps: tke dissipation rate 
-  ! km : diffusivite turbulente de quantite de mouvement (au bas de chaque
-  ! couche)
-  ! (en sortie : la valeur a la fin du pas de temps)
-  ! kn : diffusivite turbulente des scalaires (au bas de chaque couche)
-  ! (en sortie : la valeur a la fin du pas de temps)
-  !
-  !.......................................................................
-
-  !=======================================================================
-  ! Declarations:
-  !=======================================================================
-
-
-  ! Inputs/Outputs
-  !----------------
-  REAL dt, g, rconst
-  REAL plev(klon, klev+1), temp(klon, klev)
-  REAL ustar(klon)
-  REAL kmin, qmin, pblhmin(klon), coriol(klon)
-  REAL zlev(klon, klev+1)
-  REAL zlay(klon, klev)
-  REAL u(klon, klev)
-  REAL v(klon, klev)
-  REAL teta(klon, klev)
-  REAL cd(klon)
-  REAL tke(klon, klev+1)
-  REAL eps(klon,klev+1)
-  REAL unsdz(klon, klev)
-  REAL unsdzdec(klon, klev+1)
-  REAL kn(klon, klev+1)
-  REAL km(klon, klev+1)
-  INTEGER iflag_pbl, ngrid, nsrf
-  INTEGER ni(klon)
-
-!FC
-  REAL drgpro(klon,klev)
-  REAL winds(klon,klev)
-
-  ! Local
-  !-------
-
-  REAL q2(klon, klev+1)
-  REAL kmpre(klon, klev+1), tmp2, qpre
-  REAL mpre(klon, klev+1)
-  REAL kq(klon, klev+1)
-  REAL ff(klon, klev+1), delta(klon, klev+1)
-  REAL aa(klon, klev+1), aa0, aa1
-  INTEGER nlay, nlev
-
-  INTEGER ig, jg, k
-  REAL ri, zrif, zalpha, zsm, zsn
-  REAL rif(klon, klev+1), sm(klon, klev+1), alpha(klon, klev)
-  REAL m2(klon, klev+1), dz(klon, klev+1), zq, n2(klon, klev+1)
-  REAL dtetadz(klon, klev+1)
-  REAL m2cstat, mcstat, kmcstat
-  REAL l(klon, klev+1)
-  REAL zz(klon, klev+1)
-  INTEGER iter
-  REAL dissip(klon,klev), tkeprov,tkeexp, shear(klon,klev), buoy(klon,klev)
-  REAL :: disseff
-
-  REAL,SAVE :: rifc
-  !$OMP THREADPRIVATE(rifc)
-  REAL,SAVE :: seuilsm, seuilalpha
-  !$OMP THREADPRIVATE(seuilsm, seuilalpha)
-
-  REAL frif, falpha, fsm
-  REAL rino(klon, klev+1), smyam(klon, klev), styam(klon, klev), &
-    lyam(klon, klev), knyam(klon, klev), w2yam(klon, klev), t2yam(klon, klev)
-
-  CHARACTER (len = 20) :: modname = 'yamada4'
-  CHARACTER (len = 80) :: abort_message
-
-
-
-  ! Fonctions utilis??es
-  !--------------------
-
-  frif(ri) = 0.6588*(ri+0.1776-sqrt(ri*ri-0.3221*ri+0.03156))
-  falpha(ri) = 1.318*(0.2231-ri)/(0.2341-ri)
-  fsm(ri) = 1.96*(0.1912-ri)*(0.2341-ri)/((1.-ri)*(0.2231-ri))
-  
-
-
-    IF (new_yamada4) THEN
-! Corrections et reglages issus du travail de these d'Etienne Vignon.
-       rifc=frif(ric)
-       seuilsm=fsm(frif(ric))
-       seuilalpha=falpha(frif(ric))
-    ELSE
-       rifc=0.191
-       seuilalpha=1.12
-       seuilsm=0.085
-    ENDIF
-
-!===============================================================================
-! Flags, tests et ??valuations de constantes
-!===============================================================================
-
-! On utilise ou non la routine de Holstalg Boville pour les cas tres stables
-
-
-  IF (.NOT. (iflag_pbl>=6 .AND. iflag_pbl<=12)) THEN
-    abort_message='probleme de coherence dans appel a MY'
-    CALL abort_physic(modname,abort_message,1)
-  END IF
-
-
-  nlay = klev
-  nlev = klev + 1
-
-
-!========================================================================
-! Calcul des increments verticaux
-!=========================================================================
-
-  
-! Attention: zlev n'est pas declare a nlev
-  DO ig = 1, ngrid
-    zlev(ig, nlev) = zlay(ig, nlay) + (zlay(ig,nlay)-zlev(ig,nlev-1))
-  END DO
-
-
-  DO k = 1, nlay
-    DO ig = 1, ngrid
-      unsdz(ig, k) = 1.E+0/(zlev(ig,k+1)-zlev(ig,k))
-    END DO
-  END DO
-  DO ig = 1, ngrid
-    unsdzdec(ig, 1) = 1.E+0/(zlay(ig,1)-zlev(ig,1))
-  END DO
-  DO k = 2, nlay
-    DO ig = 1, ngrid
-      unsdzdec(ig, k) = 1.E+0/(zlay(ig,k)-zlay(ig,k-1))
-    END DO
-  END DO
-  DO ig = 1, ngrid
-    unsdzdec(ig, nlay+1) = 1.E+0/(zlev(ig,nlay+1)-zlay(ig,nlay))
-  END DO
-
-!=========================================================================
-! Richardson number and stability functions
-!=========================================================================
- 
-! initialize arrays:
-
-  m2(1:ngrid, :) = 0.0
-  sm(1:ngrid, :) = 0.0
-  rif(1:ngrid, :) = 0.0
-
-!------------------------------------------------------------
-  DO k = 2, klev
-
-    DO ig = 1, ngrid
-      dz(ig, k) = zlay(ig, k) - zlay(ig, k-1)
-      m2(ig, k) = ((u(ig,k)-u(ig,k-1))**2+(v(ig,k)-v(ig, &
-        k-1))**2)/(dz(ig,k)*dz(ig,k))
-      dtetadz(ig, k) = (teta(ig,k)-teta(ig,k-1))/dz(ig, k)
-      n2(ig, k) = g*2.*dtetadz(ig, k)/(teta(ig,k-1)+teta(ig,k))
-      ri = n2(ig, k)/max(m2(ig,k), 1.E-10)
-      IF (ri<ric) THEN
-        rif(ig, k) = frif(ri)
-      ELSE
-        rif(ig, k) = rifc
-      END IF
-if (new_yamada4) then
-        alpha(ig, k) = max(falpha(rif(ig,k)),seuilalpha)
-        sm(ig, k) = max(fsm(rif(ig,k)),seuilsm)
-else 
-      IF (rif(ig,k)<0.16) THEN
-        alpha(ig, k) = falpha(rif(ig,k))
-        sm(ig, k) = fsm(rif(ig,k))
-      ELSE
-        alpha(ig, k) = seuilalpha
-        sm(ig, k) = seuilsm
-      END IF
-
-end if
-      zz(ig, k) = b1*m2(ig, k)*(1.-rif(ig,k))*sm(ig, k)
-    END DO
-  END DO
-
-
-
-
-
-  !=======================================================================
-  !     DIFFERENT TYPES  DE SCHEMA de  YAMADA
-  !=======================================================================
-
-  ! On commence par calculer q2 a partir de la tke
-
-  IF (new_yamada4) THEN
-      DO k=1,klev+1
-         q2(1:ngrid,k)=tke(1:ngrid,k)*ydeux
-      ENDDO
-  ELSE
-      DO k=1,klev+1
-         q2(1:ngrid,k)=tke(1:ngrid,k)
-      ENDDO
-  ENDIF
-
-! ====================================================================
-! Computing the mixing length
-! ====================================================================
-
- 
-  CALL mixinglength(ni,nsrf,ngrid,iflag_pbl,pbl_lmixmin_alpha,lmixmin,zlay,zlev,u,v,q2,n2, l)
-
-
-  !--------------
-  ! Yamada 2.0
-  !--------------
-  IF (iflag_pbl==6) THEN
- 
-    DO k = 2, klev
-      q2(1:ngrid, k) = l(1:ngrid, k)**2*zz(1:ngrid, k)
-    END DO
-
-
-  !------------------
-  ! Yamada 2.Fournier
-  !------------------
-
-  ELSE IF (iflag_pbl==7) THEN
-
-
-    ! Calcul de l,  km, au pas precedent
-    !....................................
-    DO k = 2, klev
-      DO ig = 1, ngrid
-        delta(ig, k) = q2(ig, k)/(l(ig,k)**2*sm(ig,k))
-        kmpre(ig, k) = l(ig, k)*sqrt(q2(ig,k))*sm(ig, k)
-        mpre(ig, k) = sqrt(m2(ig,k))
-      END DO
-    END DO
-
-    DO k = 2, klev - 1
-      DO ig = 1, ngrid
-        m2cstat = max(alpha(ig,k)*n2(ig,k)+delta(ig,k)/b1, 1.E-12)
-        mcstat = sqrt(m2cstat)
-
-     ! Puis on ecrit la valeur de q qui annule l'equation de m supposee en q3
-     !.........................................................................
-
-        IF (k==2) THEN
-          kmcstat = 1.E+0/mcstat*(unsdz(ig,k)*kmpre(ig,k+1)*mpre(ig,k+1)+ &
-            unsdz(ig,k-1)*cd(ig)*(sqrt(u(ig,3)**2+v(ig,3)**2)-mcstat/unsdzdec &
-            (ig,k)-mpre(ig,k+1)/unsdzdec(ig,k+1))**2)/(unsdz(ig,k)+unsdz(ig,k &
-            -1))
-        ELSE
-          kmcstat = 1.E+0/mcstat*(unsdz(ig,k)*kmpre(ig,k+1)*mpre(ig,k+1)+ &
-            unsdz(ig,k-1)*kmpre(ig,k-1)*mpre(ig,k-1))/ &
-            (unsdz(ig,k)+unsdz(ig,k-1))
-        END IF
-
-        tmp2 = kmcstat/(sm(ig,k)/q2(ig,k))/l(ig, k)
-        q2(ig, k) = max(tmp2, 1.E-12)**(2./3.)
-
-      END DO
-    END DO
-
-
-    ! ------------------------
-    ! Yamada 2.5 a la Didi
-    !-------------------------
-
-  ELSE IF (iflag_pbl==8 .OR. iflag_pbl==9) THEN
-
-    ! Calcul de l, km, au pas precedent
-    !....................................
-    DO k = 2, klev
-      DO ig = 1, ngrid
-        delta(ig, k) = q2(ig, k)/(l(ig,k)**2*sm(ig,k))
-        IF (delta(ig,k)<1.E-20) THEN
-          delta(ig, k) = 1.E-20
-        END IF
-        km(ig, k) = l(ig, k)*sqrt(q2(ig,k))*sm(ig, k)
-        aa0 = (m2(ig,k)-alpha(ig,k)*n2(ig,k)-delta(ig,k)/b1)
-        aa1 = (m2(ig,k)*(1.-rif(ig,k))-delta(ig,k)/b1)
-        aa(ig, k) = aa1*dt/(delta(ig,k)*l(ig,k))
-        qpre = sqrt(q2(ig,k))
-        IF (aa(ig,k)>0.) THEN
-          q2(ig, k) = (qpre+aa(ig,k)*qpre*qpre)**2
-        ELSE
-          q2(ig, k) = (qpre/(1.-aa(ig,k)*qpre))**2
-        END IF
-        ! else ! iflag_pbl=9
-        ! if (aa(ig,k)*qpre.gt.0.9) then
-        ! q2(ig,k)=(qpre*10.)**2
-        ! else
-        ! q2(ig,k)=(qpre/(1.-aa(ig,k)*qpre))**2
-        ! endif
-        ! endif
-        q2(ig, k) = min(max(q2(ig,k),1.E-10), 1.E4)
-      END DO
-    END DO
-
-  ELSE IF (iflag_pbl>=10) THEN
-
-    shear(:,:)=0.
-    buoy(:,:)=0.
-    dissip(:,:)=0.
-    km(:,:)=0.
-        
-    IF (yamada4_num>=1) THEN
- 
-    DO k = 2, klev - 1
-      DO ig=1,ngrid
-      q2(ig, k) = min(max(q2(ig,k),1.E-10), 1.E4)
-      km(ig, k) = l(ig, k)*sqrt(q2(ig,k))*sm(ig, k)
-      shear(ig,k)=km(ig, k)*m2(ig, k)
-      buoy(ig,k)=km(ig, k)*m2(ig, k)*(-1.*rif(ig,k))
-!      dissip(ig,k)=min(max(((sqrt(q2(ig,k)))**3)/(b1*l(ig,k)),1.E-12),1.E4)
-      dissip(ig,k)=((sqrt(q2(ig,k)))**3)/(b1*l(ig,k)) 
-     ENDDO
-    ENDDO
-    
-    IF (yamada4_num==1) THEN ! Schema du MAR tel quel
-       DO k = 2, klev - 1
-         DO ig=1,ngrid
-         tkeprov=q2(ig,k)/ydeux
-         tkeprov= tkeprov*                           &
-           &  (tkeprov+dt*(shear(ig,k)+max(0.,buoy(ig,k))))/ &
-           &  (tkeprov+dt*((-1.)*min(0.,buoy(ig,k))+dissip(ig,k)+drgpro(ig,k)*tkeprov))
-         q2(ig,k)=tkeprov*ydeux
-        ENDDO
-       ENDDO
-    ELSE IF (yamada4_num==2) THEN ! version modifiee avec integration exacte pour la dissipation
-       DO k = 2, klev - 1
-         DO ig=1,ngrid
-         tkeprov=q2(ig,k)/ydeux
-         disseff=dissip(ig,k)-min(0.,buoy(ig,k))
-         tkeprov = tkeprov/(1.+dt*disseff/(2.*tkeprov))**2
-         tkeprov= tkeprov+dt*(shear(ig,k)+max(0.,buoy(ig,k)))
-         q2(ig,k)=tkeprov*ydeux
-         ! En cas stable, on traite la flotabilite comme la
-         ! dissipation, en supposant que buoy/q2^3 est constant.
-         ! Puis on prend la solution exacte
-        ENDDO
-       ENDDO
-    ELSE IF (yamada4_num==3) THEN ! version modifiee avec integration exacte pour la dissipation
-       DO k = 2, klev - 1
-         DO ig=1,ngrid
-         tkeprov=q2(ig,k)/ydeux
-         disseff=dissip(ig,k)-min(0.,buoy(ig,k))
-         tkeprov=tkeprov*exp(-dt*disseff/tkeprov)
-         tkeprov= tkeprov+dt*(shear(ig,k)+max(0.,buoy(ig,k)))
-         q2(ig,k)=tkeprov*ydeux
-         ! En cas stable, on traite la flotabilite comme la
-         ! dissipation, en supposant que buoy/q2^3 est constant.
-         ! Puis on prend la solution exacte
-        ENDDO
-       ENDDO
-    ELSE IF (yamada4_num==4) THEN ! version modifiee avec integration exacte pour la dissipation
-       DO k = 2, klev - 1
-         DO ig=1,ngrid
-         tkeprov=q2(ig,k)/ydeux
-         tkeprov= tkeprov+dt*(shear(ig,k)+max(0.,buoy(ig,k)))
-         tkeprov= tkeprov*                           &
-           &  tkeprov/ &
-           &  (tkeprov+dt*((-1.)*min(0.,buoy(ig,k))+dissip(ig,k)))
-         q2(ig,k)=tkeprov*ydeux
-         ! En cas stable, on traite la flotabilite comme la
-         ! dissipation, en supposant que buoy/q2^3 est constant.
-         ! Puis on prend la solution exacte
-        ENDDO
-       ENDDO
-       
-      !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-      !! Attention, yamada4_num=5 est inexacte car néglige les termes de flottabilité
-      !! en conditions instables
-      !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-    ELSE IF (yamada4_num==5) THEN ! version modifiee avec integration exacte pour la dissipation
-       DO k = 2, klev - 1
-         DO ig=1,ngrid
-         tkeprov=q2(ig,k)/ydeux
-!FC on ajoute la dissipation due aux arbres
-         disseff=dissip(ig,k)-min(0.,buoy(ig,k)) + drgpro(ig,k)*tkeprov
-         tkeexp=exp(-dt*disseff/tkeprov)
-! on prend en compte la tke cree par les arbres
-         winds(ig,k)=sqrt(u(ig,k)**2+v(ig,k)**2)
-         tkeprov= (shear(ig,k)+ &
-          & drgpro(ig,k)*(winds(ig,k))**3)*tkeprov/disseff*(1.-tkeexp)+tkeprov*tkeexp
-         q2(ig,k)=tkeprov*ydeux
-         ! En cas stable, on traite la flotabilite comme la
-         ! dissipation, en supposant que buoy/q2^3 est constant.
-         ! Puis on prend la solution exacte
-        ENDDO
-       ENDDO
-    ELSE IF (yamada4_num==6) THEN ! version modifiee avec integration exacte pour la dissipation
-       DO k = 2, klev - 1
-         DO ig=1,ngrid
-         ! En cas stable, on traite la flotabilite comme la
-         ! dissipation, en supposant que dissipeff/TKE est constant.
-         ! Puis on prend la solution exacte
-         ! With drag and dissipation from high vegetation (EV & FC, 05/10/2020)
-         winds(ig,k)=sqrt(u(ig,k)**2+v(ig,k)**2)
-         tkeprov=q2(ig,k)/ydeux
-         tkeprov=tkeprov+max(buoy(ig,k)+shear(ig,k)+drgpro(ig,k)*(winds(ig,k))**3,0.)*dt
-         disseff=dissip(ig,k)-min(0.,buoy(ig,k)+shear(ig,k)+drgpro(ig,k)*(winds(ig,k))**3) + drgpro(ig,k)*tkeprov
-         tkeexp=exp(-dt*disseff/tkeprov)
-         tkeprov= tkeprov*tkeexp
-         q2(ig,k)=tkeprov*ydeux
-         
-        ENDDO
-       ENDDO
-    ENDIF
-
-    DO k = 2, klev - 1
-      DO ig=1,ngrid
-      q2(ig, k) = min(max(q2(ig,k),1.E-10), 1.E4)
-      ENDDO
-    ENDDO
-
-   ELSE 
-
-    DO k = 2, klev - 1
-      km(1:ngrid, k) = l(1:ngrid, k)*sqrt(q2(1:ngrid,k))*sm(1:ngrid, k)
-      q2(1:ngrid, k) = q2(1:ngrid, k) + ydeux*dt*km(1:ngrid, k)*m2(1:ngrid, k)*(1.-rif(1:ngrid,k))
-!     q2(1:ngrid, k) = q2(1:ngrid, k) + dt*km(1:ngrid, k)*m2(1:ngrid, k)*(1.-rif(1:ngrid,k))
-      q2(1:ngrid, k) = min(max(q2(1:ngrid,k),1.E-10), 1.E4)
-       q2(1:ngrid, k) = 1./(1./sqrt(q2(1:ngrid,k))+dt/(yun*l(1:ngrid,k)*b1))
-!     q2(1:ngrid, k) = 1./(1./sqrt(q2(1:ngrid,k))+dt/(2*l(1:ngrid,k)*b1))
-      q2(1:ngrid, k) = q2(1:ngrid, k)*q2(1:ngrid, k)
-    END DO
-
-  ENDIF
-
-  ELSE
-     abort_message='Cas nom prevu dans yamada4'
-     CALL abort_physic(modname,abort_message,1)
-
-  END IF ! Fin du cas 8
-
-
-  ! ====================================================================
-  ! Calcul des coefficients de melange
-  ! ====================================================================
-
-  DO k = 2, klev
-    DO ig = 1, ngrid
-      zq = sqrt(q2(ig,k))
-      km(ig, k) = l(ig, k)*zq*sm(ig, k)     ! For momentum
-      kn(ig, k) = km(ig, k)*alpha(ig, k)    ! For scalars
-      kq(ig, k) = l(ig, k)*zq*0.2           ! For TKE
-    END DO
-  END DO
-
-
-  !====================================================================
-  ! Transport diffusif vertical de la TKE par la TKE
-  !====================================================================
-
-
-    ! initialize near-surface and top-layer mixing coefficients
-    !...........................................................
-
-  kq(1:ngrid, 1) = kq(1:ngrid, 2)    ! constant (ie no gradient) near the surface
-  kq(1:ngrid, klev+1) = 0            ! zero at the top
-
-    ! Transport diffusif vertical de la TKE.
-    !.......................................
-
-  IF (iflag_vdif_q2==1) THEN
-    q2(1:ngrid, 1) = q2(1:ngrid, 2)
-    CALL vdif_q2(dt, g, rconst, ngrid, plev, temp, kq, q2)
-  END IF
-
-
-  !====================================================================
-  ! Traitement particulier pour les cas tres stables, introduction d'une
-  ! longueur de m??lange minimale
-  !====================================================================
-  !
-  ! Reference: Local versus Nonlocal boundary-layer diffusion in a global climate model
-  !            Holtslag A.A.M. and Boville B.A.
-  !            J. Clim., 6, 1825-1842, 1993
-
-
- IF (hboville) THEN
-
-
-  IF (prt_level>1) THEN
-    WRITE(lunout,*) 'YAMADA4 0'
-  END IF 
-
-  DO ig = 1, ngrid
-    coriol(ig) = 1.E-4
-    pblhmin(ig) = 0.07*ustar(ig)/max(abs(coriol(ig)), 2.546E-5)
-  END DO
-
-  IF (1==1) THEN
-    IF (iflag_pbl==8 .OR. iflag_pbl==10) THEN
-
-      DO k = 2, klev
-        DO ig = 1, ngrid
-          IF (teta(ig,2)>teta(ig,1)) THEN
-            qmin = ustar(ig)*(max(1.-zlev(ig,k)/pblhmin(ig),0.))**2
-            kmin = kap*zlev(ig, k)*qmin
-          ELSE
-            kmin = -1. ! kmin n'est utilise que pour les SL stables.
-          END IF
-          IF (kn(ig,k)<kmin .OR. km(ig,k)<kmin) THEN
-
-            kn(ig, k) = kmin
-            km(ig, k) = kmin
-            kq(ig, k) = kmin
-
- ! la longueur de melange est suposee etre l= kap z
- ! K=l q Sm d'ou q2=(K/l Sm)**2
-
-            q2(ig, k) = (qmin/sm(ig,k))**2
-          END IF
-        END DO
-      END DO
-
-    ELSE
-      DO k = 2, klev
-        DO ig = 1, ngrid
-          IF (teta(ig,2)>teta(ig,1)) THEN
-            qmin = ustar(ig)*(max(1.-zlev(ig,k)/pblhmin(ig),0.))**2
-            kmin = kap*zlev(ig, k)*qmin
-          ELSE
-            kmin = -1. ! kmin n'est utilise que pour les SL stables.
-          END IF
-          IF (kn(ig,k)<kmin .OR. km(ig,k)<kmin) THEN
-            kn(ig, k) = kmin
-            km(ig, k) = kmin
-            kq(ig, k) = kmin
- ! la longueur de melange est suposee etre l= kap z
- ! K=l q Sm d'ou q2=(K/l Sm)**2
-            sm(ig, k) = 1.
-            alpha(ig, k) = 1.
-            q2(ig, k) = min((qmin/sm(ig,k))**2, 10.)
-            zq = sqrt(q2(ig,k))
-            km(ig, k) = l(ig, k)*zq*sm(ig, k)
-            kn(ig, k) = km(ig, k)*alpha(ig, k)
-            kq(ig, k) = l(ig, k)*zq*0.2
-          END IF
-        END DO
-      END DO
-    END IF
-
-  END IF
-
- END IF ! hboville
-
-! Ajout d'une viscosite moleculaire
-   km(1:ngrid,2:klev)=km(1:ngrid,2:klev)+viscom
-   kn(1:ngrid,2:klev)=kn(1:ngrid,2:klev)+viscoh
-   kq(1:ngrid,2:klev)=kq(1:ngrid,2:klev)+viscoh
-
-  IF (prt_level>1) THEN
-    WRITE(lunout,*)'YAMADA4 1'
-  END IF !(prt_level>1) THEN
-
-
- !======================================================
- ! Estimations de w'2 et T'2 d'apres Abdela et McFarlane
- !======================================================
- !
- ! Reference: A New Second-Order Turbulence Closure Scheme for the Planetary Boundary Layer
- !            Abdella K and McFarlane N
- !            J. Atmos. Sci., 54, 1850-1867, 1997
-
-  ! Diagnostique pour stokage
-  !..........................
-
-  IF (1==0) THEN
-    rino = rif
-    smyam(1:ngrid, 1) = 0.
-    styam(1:ngrid, 1) = 0.
-    lyam(1:ngrid, 1) = 0.
-    knyam(1:ngrid, 1) = 0.
-    w2yam(1:ngrid, 1) = 0.
-    t2yam(1:ngrid, 1) = 0.
-
-    smyam(1:ngrid, 2:klev) = sm(1:ngrid, 2:klev)
-    styam(1:ngrid, 2:klev) = sm(1:ngrid, 2:klev)*alpha(1:ngrid, 2:klev)
-    lyam(1:ngrid, 2:klev) = l(1:ngrid, 2:klev)
-    knyam(1:ngrid, 2:klev) = kn(1:ngrid, 2:klev)
-
-
-  ! Calcul de w'2 et T'2
-  !.......................
-
-    w2yam(1:ngrid, 2:klev) = q2(1:ngrid, 2:klev)*0.24 + &
-      lyam(1:ngrid, 2:klev)*5.17*kn(1:ngrid, 2:klev)*n2(1:ngrid, 2:klev)/ &
-      sqrt(q2(1:ngrid,2:klev))
- 
-    t2yam(1:ngrid, 2:klev) = 9.1*kn(1:ngrid, 2:klev)* &
-      dtetadz(1:ngrid, 2:klev)**2/sqrt(q2(1:ngrid,2:klev))* &
-      lyam(1:ngrid, 2:klev)
-  END IF
-
-
-
-!============================================================================
-! Mise a jour de la tke
-!============================================================================
-
-  IF (new_yamada4) THEN
-     DO k=1,klev+1
-        tke(1:ngrid,k)=q2(1:ngrid,k)/ydeux
-     ENDDO
-  ELSE
-     DO k=1,klev+1
-        tke(1:ngrid,k)=q2(1:ngrid,k)
-     ENDDO
-  ENDIF
-
-
-!============================================================================
-! Diagnostique de la dissipation et vitesse verticale
-!============================================================================
-
-! Diagnostics
-
- eps(:,:)=0.
- wprime(1:ngrid,:,nsrf)=0.
- DO k=2,klev
-    DO ig=1,ngrid
-       eps(ig,k)=dissip(ig,k)
-       jg=ni(ig)
-       wprime(jg,k,nsrf)=sqrt(MAX(1./3*q2(ig,k),0.))
-    ENDDO
- ENDDO
-
- 
-!=============================================================================
-
-  RETURN
-
-
-END SUBROUTINE yamada4
-
-!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-
-!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-SUBROUTINE vdif_q2(timestep, gravity, rconst, ngrid, plev, temp, kmy, q2)
-
-  USE dimphy, only : klev,klon
-  IMPLICIT NONE
- 
-!    vdif_q2: subroutine qui calcule la diffusion de la TKE par la TKE
-!             avec un schema implicite en temps avec 
-!             inversion d'un syst??me tridiagonal
-! 
-!     Reference: Description of the interface with the surface and 
-!                the computation of the turbulet diffusion in LMDZ
-!                Technical note on LMDZ
-!                Dufresne, J-L, Ghattas, J. and Grandpeix, J-Y
-!
-!============================================================================
-! Declarations
-!============================================================================
-
-  REAL plev(klon, klev+1)
-  REAL temp(klon, klev)
-  REAL timestep
-  REAL gravity, rconst
-  REAL kstar(klon, klev+1), zz
-  REAL kmy(klon, klev+1)
-  REAL q2(klon, klev+1)
-  REAL deltap(klon, klev+1)
-  REAL denom(klon, klev+1), alpha(klon, klev+1), beta(klon, klev+1)
-  INTEGER ngrid
-
-  INTEGER i, k
-
-
-!=========================================================================
-! Calcul
-!=========================================================================
-
-  DO k = 1, klev
-    DO i = 1, ngrid
-      zz = (plev(i,k)+plev(i,k+1))*gravity/(rconst*temp(i,k))
-      kstar(i, k) = 0.125*(kmy(i,k+1)+kmy(i,k))*zz*zz/ &
-        (plev(i,k)-plev(i,k+1))*timestep
-    END DO
-  END DO
-
-  DO k = 2, klev
-    DO i = 1, ngrid
-      deltap(i, k) = 0.5*(plev(i,k-1)-plev(i,k+1))
-    END DO
-  END DO
-  DO i = 1, ngrid
-    deltap(i, 1) = 0.5*(plev(i,1)-plev(i,2))
-    deltap(i, klev+1) = 0.5*(plev(i,klev)-plev(i,klev+1))
-    denom(i, klev+1) = deltap(i, klev+1) + kstar(i, klev)
-    alpha(i, klev+1) = deltap(i, klev+1)*q2(i, klev+1)/denom(i, klev+1)
-    beta(i, klev+1) = kstar(i, klev)/denom(i, klev+1)
-  END DO
-
-  DO k = klev, 2, -1
-    DO i = 1, ngrid
-      denom(i, k) = deltap(i, k) + (1.-beta(i,k+1))*kstar(i, k) + &
-        kstar(i, k-1)
-      alpha(i, k) = (q2(i,k)*deltap(i,k)+kstar(i,k)*alpha(i,k+1))/denom(i, k)
-      beta(i, k) = kstar(i, k-1)/denom(i, k)
-    END DO
-  END DO
-
-  ! Si on recalcule q2(1)
-  !.......................
-  IF (1==0) THEN
-    DO i = 1, ngrid
-      denom(i, 1) = deltap(i, 1) + (1-beta(i,2))*kstar(i, 1)
-      q2(i, 1) = (q2(i,1)*deltap(i,1)+kstar(i,1)*alpha(i,2))/denom(i, 1)
-    END DO
-  END IF
-
-
-  DO k = 2, klev + 1
-    DO i = 1, ngrid
-      q2(i, k) = alpha(i, k) + beta(i, k)*q2(i, k-1)
-    END DO
-  END DO
-
-  RETURN
-END SUBROUTINE vdif_q2
-!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-
-
-
-!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
- SUBROUTINE vdif_q2e(timestep, gravity, rconst, ngrid, plev, temp, kmy, q2)
-  
-   USE dimphy, only : klev,klon
-  IMPLICIT NONE
-
-! vdif_q2e: subroutine qui calcule la diffusion de TKE par la TKE
-!           avec un schema explicite en temps
-
-
-!====================================================
-! Declarations
-!====================================================
-
-  REAL plev(klon, klev+1)
-  REAL temp(klon, klev)
-  REAL timestep
-  REAL gravity, rconst
-  REAL kstar(klon, klev+1), zz
-  REAL kmy(klon, klev+1)
-  REAL q2(klon, klev+1)
-  REAL deltap(klon, klev+1)
-  REAL denom(klon, klev+1), alpha(klon, klev+1), beta(klon, klev+1)
-  INTEGER ngrid
-  INTEGER i, k
-
-
-!==================================================
-! Calcul
-!==================================================
-
-  DO k = 1, klev
-    DO i = 1, ngrid
-      zz = (plev(i,k)+plev(i,k+1))*gravity/(rconst*temp(i,k))
-      kstar(i, k) = 0.125*(kmy(i,k+1)+kmy(i,k))*zz*zz/ &
-        (plev(i,k)-plev(i,k+1))*timestep
-    END DO
-  END DO
-
-  DO k = 2, klev
-    DO i = 1, ngrid
-      deltap(i, k) = 0.5*(plev(i,k-1)-plev(i,k+1))
-    END DO
-  END DO
-  DO i = 1, ngrid
-    deltap(i, 1) = 0.5*(plev(i,1)-plev(i,2))
-    deltap(i, klev+1) = 0.5*(plev(i,klev)-plev(i,klev+1))
-  END DO
-
-  DO k = klev, 2, -1
-    DO i = 1, ngrid
-      q2(i, k) = q2(i, k) + (kstar(i,k)*(q2(i,k+1)-q2(i, &
-        k))-kstar(i,k-1)*(q2(i,k)-q2(i,k-1)))/deltap(i, k)
-    END DO
-  END DO
-
-  DO i = 1, ngrid
-    q2(i, 1) = q2(i, 1) + (kstar(i,1)*(q2(i,2)-q2(i,1)))/deltap(i, 1)
-    q2(i, klev+1) = q2(i, klev+1) + (-kstar(i,klev)*(q2(i,klev+1)-q2(i, &
-      klev)))/deltap(i, klev+1)
-  END DO
-
-  RETURN
-END SUBROUTINE vdif_q2e
-
-!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-
-
-!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
-
-SUBROUTINE mixinglength(ni, nsrf, ngrid,iflag_pbl,pbl_lmixmin_alpha,lmixmin,zlay,zlev,u,v,q2,n2, lmix)
-
-
-
-  USE dimphy, only : klev,klon
-  USE yamada_ini_mod, only : l0
-  USE phys_state_var_mod, only: zstd, zsig, zmea
-  USE phys_local_var_mod, only: l_mixmin, l_mix
-  USE yamada_ini_mod, only : kap, kapb
-
- ! zstd: ecart type de la'altitud e sous-maille
- ! zmea: altitude moyenne sous maille
- ! zsig: pente moyenne de le maille
-
-  USE geometry_mod, only: cell_area
-  ! aire_cell: aire de la maille
-
-  IMPLICIT NONE
-!*************************************************************************
-! Subrourine qui calcule la longueur de m??lange dans le sch??ma de turbulence
-! avec la formule de Blackadar 
-! Calcul d'un  minimum en fonction de l'orographie sous-maille:
-! L'id??e est la suivante: plus il y a de relief, plus il y a du m??lange
-! induit par les circulations meso et submeso ??chelles.
-!
-! References: * The vertical distribution of wind and turbulent exchange in a neutral atmosphere
-!               Blackadar A.K.
-!               J. Geophys. Res., 64, No 8, 1962
-!
-!             * An evaluation of neutral and convective planetary boundary-layer parametrisations relative 
-!               to large eddy simulations
-!               Ayotte K et al 
-!               Boundary Layer Meteorology, 79, 131-175, 1996
-!
-!
-!             * Local Similarity in the Stable Boundary Layer and Mixing length Approaches: consistency of concepts
-!               Van de Wiel B.J.H et al
-!               Boundary-Lay Meteorol, 128, 103-166, 2008
-!
-!
-! Histoire:
-!----------
-! * premi??re r??daction, Etienne et Frederic, 09/06/2016
-!
-! ***********************************************************************
-
-!==================================================================
-! Declarations
-!==================================================================
-
-! Inputs
-!-------
- INTEGER            ni(klon)           ! indice sur la grille original (non restreinte)
- INTEGER            nsrf               ! Type de surface
- INTEGER            ngrid              ! Nombre de points concern??s sur l'horizontal
- INTEGER            iflag_pbl          ! Choix du sch??ma de turbulence
- REAL               pbl_lmixmin_alpha  ! on active ou non le calcul de la longueur de melange minimum en fonction du relief
- REAL               lmixmin            ! Minimum absolu de la longueur de m??lange
- REAL               zlay(klon, klev)   ! altitude du centre de la couche
- REAL               zlev(klon, klev+1) ! atitude de l'interface inf??rieure de la couche
- REAL               u(klon, klev)      ! vitesse du vent zonal
- REAL               v(klon, klev)      ! vitesse du vent meridional
- REAL               q2(klon, klev+1)   ! energie cin??tique turbulente 
- REAL               n2(klon, klev+1)   ! frequence de Brunt-Vaisala
-
-!In/out
-!-------
-
-! Outputs
-!---------
-
- REAL               lmix(klon, klev+1)    ! Longueur de melange  
-
-
-! Local
-!-------
-  
- INTEGER  ig,jg, k
- REAL     h_oro(klon)
- REAL     hlim(klon)
- REAL zq
- REAL sq(klon), sqz(klon)
- REAL fl, zzz, zl0, zq2, zn2
- REAL famorti, zzzz, zh_oro, zhlim
- REAL l1(klon, klev+1), l2(klon,klev+1)
- REAL winds(klon, klev)
- REAL xcell
- REAL zstdslope(klon)  
- REAL lmax
- REAL l2strat, l2neutre, extent  
- REAL l2limit(klon)
-!===============================================================
-! Fonctions utiles
-!===============================================================
-
-! Calcul de l suivant la formule de Blackadar 1962 adapt??e par Ayotte 1996
-!..........................................................................
-
- fl(zzz, zl0, zq2, zn2) = max(min(l0(ig)*kap*zlev(ig, &
-    k)/(kap*zlev(ig,k)+l0(ig)),0.5*sqrt(q2(ig,k))/sqrt( &
-    max(n2(ig,k),1.E-10))), 1.E-5)
- 
-! Fonction d'amortissement de la turbulence au dessus de la montagne
-! On augmente l'amortissement en diminuant la valeur de hlim (extent) dans le code
-!.....................................................................
-
- famorti(zzzz, zh_oro, zhlim)=(-1.)*ATAN((zzzz-zh_oro)/(zhlim-zh_oro))*2./3.1416+1.    
-
-  IF (ngrid==0) RETURN
-
-
-!=====================================================================
-!         CALCUL de la LONGUEUR de m??lange suivant BLACKADAR: l1
-!=====================================================================
-
-  l1(1:ngrid,:)=0.
-  IF (iflag_pbl==8 .OR. iflag_pbl==10) THEN
-
-    
-    ! Iterative computation of l0
-    ! This version is kept for iflag_pbl only for convergence
-    ! with NPv3.1 Cmip5 simulations
-    !...................................................................
-
-    DO ig = 1, ngrid
-      sq(ig) = 1.E-10
-      sqz(ig) = 1.E-10
-    END DO
-    DO k = 2, klev - 1
-      DO ig = 1, ngrid
-        zq = sqrt(q2(ig,k))
-        sqz(ig) = sqz(ig) + zq*zlev(ig, k)*(zlay(ig,k)-zlay(ig,k-1))
-        sq(ig) = sq(ig) + zq*(zlay(ig,k)-zlay(ig,k-1))
-      END DO
-    END DO
-    DO ig = 1, ngrid
-      l0(ig) = 0.2*sqz(ig)/sq(ig)
-    END DO
-    DO k = 2, klev
-      DO ig = 1, ngrid
-        l1(ig, k) = fl(zlev(ig,k), l0(ig), q2(ig,k), n2(ig,k))
-      END DO
-    END DO
-
-  ELSE
-
-    
-    ! In all other case, the assymptotic mixing length l0 is imposed (150m)
-    !......................................................................
-
-    l0(1:ngrid) = 150.
-    DO k = 2, klev
-      DO ig = 1, ngrid
-        l1(ig, k) = fl(zlev(ig,k), l0(ig), q2(ig,k), n2(ig,k))
-      END DO
-    END DO
-
-  END IF
-
-!===========================================================================================
-!  CALCUL d'une longueur de melange minimum en fonctions de la topographie sous maille: l2
-! si pbl_lmixmin_alpha=TRUE et si on se trouve sur de la terre ( pas actif sur les 
-! glacier, la glace de mer et les oc??ans)
-!===========================================================================================
-
-   l2(1:ngrid,:)=0.0
-   l_mixmin(1:ngrid,:,nsrf)=0.
-   l_mix(1:ngrid,:,nsrf)=0.
-   hlim(1:ngrid)=0.
-
-   IF (nsrf .EQ. 1) THEN
-
-! coefficients 
-!--------------
-
-     extent=2.                                                         ! On ??tend l'impact du relief jusqu'?? extent*h, extent >1.  
-     lmax=150.                                                         ! Longueur de m??lange max dans l'absolu
-
-! calculs
-!---------
-
-     DO ig=1,ngrid
-
-      ! On calcule la hauteur du relief
-      !.................................
-      ! On ne peut pas prendre zstd seulement pour caracteriser le relief sous maille
-      ! car sur un terrain pentu mais sans relief, zstd est non nul (comme en Antarctique, C. Genthon)
-      ! On corrige donc zstd avec l'ecart type de l'altitude dans la maille sans relief 
-      ! (en gros, une maille de taille xcell avec une pente constante zstdslope)
-      jg=ni(ig) 
-!     IF (zsig(jg) .EQ. 0.) THEN
-!          zstdslope(ig)=0.         
-!     ELSE
-!     xcell=sqrt(cell_area(jg))
-!     zstdslope(ig)=max((xcell*zsig(jg)-zmea(jg))**3 /(3.*zsig(jg)),0.)
-!     zstdslope(ig)=sqrt(zstdslope(ig))
-!     END IF
-      
-!     h_oro(ig)=max(zstd(jg)-zstdslope(ig),0.)   ! Hauteur du relief
-      h_oro(ig)=zstd(jg)
-      hlim(ig)=extent*h_oro(ig)     
-     ENDDO
-
-     l2limit(1:ngrid)=0.
-
-     DO k=2,klev
-        DO ig=1,ngrid
-           winds(ig,k)=sqrt(u(ig,k)**2+v(ig,k)**2)
-           IF (zlev(ig,k) .LE. h_oro(ig)) THEN  ! sous l'orographie
-              l2strat= kapb*pbl_lmixmin_alpha*winds(ig,k)/sqrt(max(n2(ig,k),1.E-10))  ! si stratifi??, amplitude d'oscillation * kappab (voir Van de Wiel et al 2008)
-              l2neutre=kap*zlev(ig,k)*h_oro(ig)/(kap*zlev(ig,k)+h_oro(ig))            ! Dans le cas neutre, formule de blackadar. tend asymptotiquement vers h
-              l2neutre=MIN(l2neutre,lmax)                                             ! On majore par lmax 
-              l2limit(ig)=MIN(l2neutre,l2strat)                                       ! Calcule de l2 (minimum de la longueur en cas neutre et celle en situation stratifi??e)
-              l2(ig,k)=l2limit(ig)
-                                      
-           ELSE IF (zlev(ig,k) .LE. hlim(ig)) THEN ! Si on est au dessus des montagnes, mais affect?? encore par elles
-
-      ! Au dessus des montagnes, on prend la l2limit au sommet des montagnes 
-      ! (la derni??re calcul??e dans la boucle k, vu que k est un indice croissant avec z)
-      ! et on multiplie l2limit par une fonction qui d??croit entre h et hlim
-              l2(ig,k)=l2limit(ig)*famorti(zlev(ig,k),h_oro(ig), hlim(ig))
-           ELSE                                                                    ! Au dessus de extent*h, on prend l2=l0 
-              l2(ig,k)=0.
-           END IF
-        ENDDO
-     ENDDO
-   ENDIF                                                                           ! pbl_lmixmin_alpha
-
-!==================================================================================
-! On prend le max entre la longueur de melange de blackadar et celle calcul??e
-! en fonction de la topographie 
-!===================================================================================
-
-
- DO k=1,klev+1
-    DO ig=1,ngrid
-       lmix(ig,k)=MAX(MAX(l1(ig,k), l2(ig,k)),lmixmin)
-   ENDDO
- ENDDO
-
-! Diagnostics
-
- DO k=1,klev+1
-    DO ig=1,ngrid
-       jg=ni(ig)
-       l_mix(jg,k,nsrf)=lmix(ig,k)
-       l_mixmin(jg,k,nsrf)=MAX(l2(ig,k),lmixmin)
-    ENDDO
- ENDDO
-
-
-
-END SUBROUTINE mixinglength
Index: /LMDZ6/trunk/libf/phylmd/yamada4.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/yamada4.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/yamada4.f90	(revision 5268)
@@ -0,0 +1,1122 @@
+!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+SUBROUTINE yamada4(ni, nsrf, ngrid, dt, g, rconst, plev, temp, zlev, zlay, u, v, teta, &
+    cd, tke, eps, km, kn, kq, ustar, iflag_pbl, drgpro)
+
+  USE dimphy, only : klev,klon
+  USE phys_local_var_mod, only: wprime
+  USE yamada_ini_mod, only : new_yamada4,yamada4_num,hboville
+  USE yamada_ini_mod, only : prt_level, lunout,pbl_lmixmin_alpha,b1,kap,viscom,viscoh
+  USE yamada_ini_mod, only : ric, yun,ydeux,lmixmin,iflag_vdif_q2
+  
+  IMPLICIT NONE
+  ! ************************************************************************************************
+  !
+  ! yamada4: subroutine qui calcule le transfert turbulent avec une fermeture d'ordre 2 ou 2.5
+  ! 
+  ! Reference: Simulation of nocturnal drainage flows by a q2l Turbulence Closure Model
+  !            Yamada T.
+  !            J. Atmos. Sci, 40, 91-106, 1983
+  !
+  !************************************************************************************************
+  ! Input :
+  !'======
+  ! ni: indice horizontal sur la grille de base, non restreinte
+  ! nsrf: type de surface
+  ! ngrid: nombre de mailles concern??es sur l'horizontal
+  ! dt : pas de temps
+  ! g  : g
+  ! rconst: constante de l'air sec
+  ! zlev : altitude a chaque niveau (interface inferieure de la couche
+  ! de meme indice)
+  ! zlay : altitude au centre de chaque couche
+  ! u,v : vitesse au centre de chaque couche
+  ! (en entree : la valeur au debut du pas de temps)
+  ! teta : temperature potentielle virtuelle au centre de chaque couche
+  ! (en entree : la valeur au debut du pas de temps)
+  ! cd : cdrag pour la quantit?? de mouvement
+  ! (en entree : la valeur au debut du pas de temps)
+  ! ustar: vitesse de friction calcul??e par une formule diagnostique 
+  ! iflag_pbl: flag pour choisir des options du sch??ma de turbulence
+  !
+  !             iflag_pbl doit valoir entre 6 et 9
+  !             l=6, on prend  systematiquement une longueur d'equilibre
+  !             iflag_pbl=6 : MY 2.0
+  !             iflag_pbl=7 : MY 2.0.Fournier
+  !             iflag_pbl=8/9 : MY 2.5
+  !             iflag_pbl=8 with special obsolete treatments for convergence
+  !             with Cmpi5 NPv3.1 simulations
+  !             iflag_pbl=10/11 :  New scheme M2 and N2 explicit and dissiptation exact
+  !             iflag_pbl=12 = 11 with vertical diffusion off q2
+  !
+  !             2013/04/01 (FH hourdin@lmd.jussieu.fr)
+  !             Correction for very stable PBLs (iflag_pbl=10 and 11)
+  !             iflag_pbl=8 converges numerically with NPv3.1
+  !             iflag_pbl=11 -> the model starts with NP from start files created by ce0l
+  !                          -> the model can run with longer time-steps.
+  !             2016/11/30 (EV etienne.vignon@lmd.ipsl.fr)
+  !               On met tke (=q2/2) en entr??e plut??t que q2
+  !               On corrige l'update de la tke
+  !             2020/10/01 (EV)
+  !               On ajoute la dissipation de la TKE en diagnostique de sortie
+  !                  
+  ! Inpout/Output :
+  !==============
+  ! tke : tke au bas de chaque couche
+  ! (en entree : la valeur au debut du pas de temps)
+  ! (en sortie : la valeur a la fin du pas de temps)
+ 
+  ! Outputs:
+  !==========
+  ! eps: tke dissipation rate 
+  ! km : diffusivite turbulente de quantite de mouvement (au bas de chaque
+  ! couche)
+  ! (en sortie : la valeur a la fin du pas de temps)
+  ! kn : diffusivite turbulente des scalaires (au bas de chaque couche)
+  ! (en sortie : la valeur a la fin du pas de temps)
+  !
+  !.......................................................................
+
+  !=======================================================================
+  ! Declarations:
+  !=======================================================================
+
+
+  ! Inputs/Outputs
+  !----------------
+  REAL dt, g, rconst
+  REAL plev(klon, klev+1), temp(klon, klev)
+  REAL ustar(klon)
+  REAL kmin, qmin, pblhmin(klon), coriol(klon)
+  REAL zlev(klon, klev+1)
+  REAL zlay(klon, klev)
+  REAL u(klon, klev)
+  REAL v(klon, klev)
+  REAL teta(klon, klev)
+  REAL cd(klon)
+  REAL tke(klon, klev+1)
+  REAL eps(klon,klev+1)
+  REAL unsdz(klon, klev)
+  REAL unsdzdec(klon, klev+1)
+  REAL kn(klon, klev+1)
+  REAL km(klon, klev+1)
+  INTEGER iflag_pbl, ngrid, nsrf
+  INTEGER ni(klon)
+
+!FC
+  REAL drgpro(klon,klev)
+  REAL winds(klon,klev)
+
+  ! Local
+  !-------
+
+  REAL q2(klon, klev+1)
+  REAL kmpre(klon, klev+1), tmp2, qpre
+  REAL mpre(klon, klev+1)
+  REAL kq(klon, klev+1)
+  REAL ff(klon, klev+1), delta(klon, klev+1)
+  REAL aa(klon, klev+1), aa0, aa1
+  INTEGER nlay, nlev
+
+  INTEGER ig, jg, k
+  REAL ri, zrif, zalpha, zsm, zsn
+  REAL rif(klon, klev+1), sm(klon, klev+1), alpha(klon, klev)
+  REAL m2(klon, klev+1), dz(klon, klev+1), zq, n2(klon, klev+1)
+  REAL dtetadz(klon, klev+1)
+  REAL m2cstat, mcstat, kmcstat
+  REAL l(klon, klev+1)
+  REAL zz(klon, klev+1)
+  INTEGER iter
+  REAL dissip(klon,klev), tkeprov,tkeexp, shear(klon,klev), buoy(klon,klev)
+  REAL :: disseff
+
+  REAL,SAVE :: rifc
+  !$OMP THREADPRIVATE(rifc)
+  REAL,SAVE :: seuilsm, seuilalpha
+  !$OMP THREADPRIVATE(seuilsm, seuilalpha)
+
+  REAL frif, falpha, fsm
+  REAL rino(klon, klev+1), smyam(klon, klev), styam(klon, klev), &
+    lyam(klon, klev), knyam(klon, klev), w2yam(klon, klev), t2yam(klon, klev)
+
+  CHARACTER (len = 20) :: modname = 'yamada4'
+  CHARACTER (len = 80) :: abort_message
+
+
+
+  ! Fonctions utilis??es
+  !--------------------
+
+  frif(ri) = 0.6588*(ri+0.1776-sqrt(ri*ri-0.3221*ri+0.03156))
+  falpha(ri) = 1.318*(0.2231-ri)/(0.2341-ri)
+  fsm(ri) = 1.96*(0.1912-ri)*(0.2341-ri)/((1.-ri)*(0.2231-ri))
+  
+
+
+    IF (new_yamada4) THEN
+! Corrections et reglages issus du travail de these d'Etienne Vignon.
+       rifc=frif(ric)
+       seuilsm=fsm(frif(ric))
+       seuilalpha=falpha(frif(ric))
+    ELSE
+       rifc=0.191
+       seuilalpha=1.12
+       seuilsm=0.085
+    ENDIF
+
+!===============================================================================
+! Flags, tests et ??valuations de constantes
+!===============================================================================
+
+! On utilise ou non la routine de Holstalg Boville pour les cas tres stables
+
+
+  IF (.NOT. (iflag_pbl>=6 .AND. iflag_pbl<=12)) THEN
+    abort_message='probleme de coherence dans appel a MY'
+    CALL abort_physic(modname,abort_message,1)
+  END IF
+
+
+  nlay = klev
+  nlev = klev + 1
+
+
+!========================================================================
+! Calcul des increments verticaux
+!=========================================================================
+
+  
+! Attention: zlev n'est pas declare a nlev
+  DO ig = 1, ngrid
+    zlev(ig, nlev) = zlay(ig, nlay) + (zlay(ig,nlay)-zlev(ig,nlev-1))
+  END DO
+
+
+  DO k = 1, nlay
+    DO ig = 1, ngrid
+      unsdz(ig, k) = 1.E+0/(zlev(ig,k+1)-zlev(ig,k))
+    END DO
+  END DO
+  DO ig = 1, ngrid
+    unsdzdec(ig, 1) = 1.E+0/(zlay(ig,1)-zlev(ig,1))
+  END DO
+  DO k = 2, nlay
+    DO ig = 1, ngrid
+      unsdzdec(ig, k) = 1.E+0/(zlay(ig,k)-zlay(ig,k-1))
+    END DO
+  END DO
+  DO ig = 1, ngrid
+    unsdzdec(ig, nlay+1) = 1.E+0/(zlev(ig,nlay+1)-zlay(ig,nlay))
+  END DO
+
+!=========================================================================
+! Richardson number and stability functions
+!=========================================================================
+ 
+! initialize arrays:
+
+  m2(1:ngrid, :) = 0.0
+  sm(1:ngrid, :) = 0.0
+  rif(1:ngrid, :) = 0.0
+
+!------------------------------------------------------------
+  DO k = 2, klev
+
+    DO ig = 1, ngrid
+      dz(ig, k) = zlay(ig, k) - zlay(ig, k-1)
+      m2(ig, k) = ((u(ig,k)-u(ig,k-1))**2+(v(ig,k)-v(ig, &
+        k-1))**2)/(dz(ig,k)*dz(ig,k))
+      dtetadz(ig, k) = (teta(ig,k)-teta(ig,k-1))/dz(ig, k)
+      n2(ig, k) = g*2.*dtetadz(ig, k)/(teta(ig,k-1)+teta(ig,k))
+      ri = n2(ig, k)/max(m2(ig,k), 1.E-10)
+      IF (ri<ric) THEN
+        rif(ig, k) = frif(ri)
+      ELSE
+        rif(ig, k) = rifc
+      END IF
+if (new_yamada4) then
+        alpha(ig, k) = max(falpha(rif(ig,k)),seuilalpha)
+        sm(ig, k) = max(fsm(rif(ig,k)),seuilsm)
+else 
+      IF (rif(ig,k)<0.16) THEN
+        alpha(ig, k) = falpha(rif(ig,k))
+        sm(ig, k) = fsm(rif(ig,k))
+      ELSE
+        alpha(ig, k) = seuilalpha
+        sm(ig, k) = seuilsm
+      END IF
+
+end if
+      zz(ig, k) = b1*m2(ig, k)*(1.-rif(ig,k))*sm(ig, k)
+    END DO
+  END DO
+
+
+
+
+
+  !=======================================================================
+  !     DIFFERENT TYPES  DE SCHEMA de  YAMADA
+  !=======================================================================
+
+  ! On commence par calculer q2 a partir de la tke
+
+  IF (new_yamada4) THEN
+      DO k=1,klev+1
+         q2(1:ngrid,k)=tke(1:ngrid,k)*ydeux
+      ENDDO
+  ELSE
+      DO k=1,klev+1
+         q2(1:ngrid,k)=tke(1:ngrid,k)
+      ENDDO
+  ENDIF
+
+! ====================================================================
+! Computing the mixing length
+! ====================================================================
+
+ 
+  CALL mixinglength(ni,nsrf,ngrid,iflag_pbl,pbl_lmixmin_alpha,lmixmin,zlay,zlev,u,v,q2,n2, l)
+
+
+  !--------------
+  ! Yamada 2.0
+  !--------------
+  IF (iflag_pbl==6) THEN
+ 
+    DO k = 2, klev
+      q2(1:ngrid, k) = l(1:ngrid, k)**2*zz(1:ngrid, k)
+    END DO
+
+
+  !------------------
+  ! Yamada 2.Fournier
+  !------------------
+
+  ELSE IF (iflag_pbl==7) THEN
+
+
+    ! Calcul de l,  km, au pas precedent
+    !....................................
+    DO k = 2, klev
+      DO ig = 1, ngrid
+        delta(ig, k) = q2(ig, k)/(l(ig,k)**2*sm(ig,k))
+        kmpre(ig, k) = l(ig, k)*sqrt(q2(ig,k))*sm(ig, k)
+        mpre(ig, k) = sqrt(m2(ig,k))
+      END DO
+    END DO
+
+    DO k = 2, klev - 1
+      DO ig = 1, ngrid
+        m2cstat = max(alpha(ig,k)*n2(ig,k)+delta(ig,k)/b1, 1.E-12)
+        mcstat = sqrt(m2cstat)
+
+     ! Puis on ecrit la valeur de q qui annule l'equation de m supposee en q3
+     !.........................................................................
+
+        IF (k==2) THEN
+          kmcstat = 1.E+0/mcstat*(unsdz(ig,k)*kmpre(ig,k+1)*mpre(ig,k+1)+ &
+            unsdz(ig,k-1)*cd(ig)*(sqrt(u(ig,3)**2+v(ig,3)**2)-mcstat/unsdzdec &
+            (ig,k)-mpre(ig,k+1)/unsdzdec(ig,k+1))**2)/(unsdz(ig,k)+unsdz(ig,k &
+            -1))
+        ELSE
+          kmcstat = 1.E+0/mcstat*(unsdz(ig,k)*kmpre(ig,k+1)*mpre(ig,k+1)+ &
+            unsdz(ig,k-1)*kmpre(ig,k-1)*mpre(ig,k-1))/ &
+            (unsdz(ig,k)+unsdz(ig,k-1))
+        END IF
+
+        tmp2 = kmcstat/(sm(ig,k)/q2(ig,k))/l(ig, k)
+        q2(ig, k) = max(tmp2, 1.E-12)**(2./3.)
+
+      END DO
+    END DO
+
+
+    ! ------------------------
+    ! Yamada 2.5 a la Didi
+    !-------------------------
+
+  ELSE IF (iflag_pbl==8 .OR. iflag_pbl==9) THEN
+
+    ! Calcul de l, km, au pas precedent
+    !....................................
+    DO k = 2, klev
+      DO ig = 1, ngrid
+        delta(ig, k) = q2(ig, k)/(l(ig,k)**2*sm(ig,k))
+        IF (delta(ig,k)<1.E-20) THEN
+          delta(ig, k) = 1.E-20
+        END IF
+        km(ig, k) = l(ig, k)*sqrt(q2(ig,k))*sm(ig, k)
+        aa0 = (m2(ig,k)-alpha(ig,k)*n2(ig,k)-delta(ig,k)/b1)
+        aa1 = (m2(ig,k)*(1.-rif(ig,k))-delta(ig,k)/b1)
+        aa(ig, k) = aa1*dt/(delta(ig,k)*l(ig,k))
+        qpre = sqrt(q2(ig,k))
+        IF (aa(ig,k)>0.) THEN
+          q2(ig, k) = (qpre+aa(ig,k)*qpre*qpre)**2
+        ELSE
+          q2(ig, k) = (qpre/(1.-aa(ig,k)*qpre))**2
+        END IF
+        ! else ! iflag_pbl=9
+        ! if (aa(ig,k)*qpre.gt.0.9) then
+        ! q2(ig,k)=(qpre*10.)**2
+        ! else
+        ! q2(ig,k)=(qpre/(1.-aa(ig,k)*qpre))**2
+        ! endif
+        ! endif
+        q2(ig, k) = min(max(q2(ig,k),1.E-10), 1.E4)
+      END DO
+    END DO
+
+  ELSE IF (iflag_pbl>=10) THEN
+
+    shear(:,:)=0.
+    buoy(:,:)=0.
+    dissip(:,:)=0.
+    km(:,:)=0.
+        
+    IF (yamada4_num>=1) THEN
+ 
+    DO k = 2, klev - 1
+      DO ig=1,ngrid
+      q2(ig, k) = min(max(q2(ig,k),1.E-10), 1.E4)
+      km(ig, k) = l(ig, k)*sqrt(q2(ig,k))*sm(ig, k)
+      shear(ig,k)=km(ig, k)*m2(ig, k)
+      buoy(ig,k)=km(ig, k)*m2(ig, k)*(-1.*rif(ig,k))
+!      dissip(ig,k)=min(max(((sqrt(q2(ig,k)))**3)/(b1*l(ig,k)),1.E-12),1.E4)
+      dissip(ig,k)=((sqrt(q2(ig,k)))**3)/(b1*l(ig,k)) 
+     ENDDO
+    ENDDO
+    
+    IF (yamada4_num==1) THEN ! Schema du MAR tel quel
+       DO k = 2, klev - 1
+         DO ig=1,ngrid
+         tkeprov=q2(ig,k)/ydeux
+         tkeprov= tkeprov*                           &
+           &  (tkeprov+dt*(shear(ig,k)+max(0.,buoy(ig,k))))/ &
+           &  (tkeprov+dt*((-1.)*min(0.,buoy(ig,k))+dissip(ig,k)+drgpro(ig,k)*tkeprov))
+         q2(ig,k)=tkeprov*ydeux
+        ENDDO
+       ENDDO
+    ELSE IF (yamada4_num==2) THEN ! version modifiee avec integration exacte pour la dissipation
+       DO k = 2, klev - 1
+         DO ig=1,ngrid
+         tkeprov=q2(ig,k)/ydeux
+         disseff=dissip(ig,k)-min(0.,buoy(ig,k))
+         tkeprov = tkeprov/(1.+dt*disseff/(2.*tkeprov))**2
+         tkeprov= tkeprov+dt*(shear(ig,k)+max(0.,buoy(ig,k)))
+         q2(ig,k)=tkeprov*ydeux
+         ! En cas stable, on traite la flotabilite comme la
+         ! dissipation, en supposant que buoy/q2^3 est constant.
+         ! Puis on prend la solution exacte
+        ENDDO
+       ENDDO
+    ELSE IF (yamada4_num==3) THEN ! version modifiee avec integration exacte pour la dissipation
+       DO k = 2, klev - 1
+         DO ig=1,ngrid
+         tkeprov=q2(ig,k)/ydeux
+         disseff=dissip(ig,k)-min(0.,buoy(ig,k))
+         tkeprov=tkeprov*exp(-dt*disseff/tkeprov)
+         tkeprov= tkeprov+dt*(shear(ig,k)+max(0.,buoy(ig,k)))
+         q2(ig,k)=tkeprov*ydeux
+         ! En cas stable, on traite la flotabilite comme la
+         ! dissipation, en supposant que buoy/q2^3 est constant.
+         ! Puis on prend la solution exacte
+        ENDDO
+       ENDDO
+    ELSE IF (yamada4_num==4) THEN ! version modifiee avec integration exacte pour la dissipation
+       DO k = 2, klev - 1
+         DO ig=1,ngrid
+         tkeprov=q2(ig,k)/ydeux
+         tkeprov= tkeprov+dt*(shear(ig,k)+max(0.,buoy(ig,k)))
+         tkeprov= tkeprov*                           &
+           &  tkeprov/ &
+           &  (tkeprov+dt*((-1.)*min(0.,buoy(ig,k))+dissip(ig,k)))
+         q2(ig,k)=tkeprov*ydeux
+         ! En cas stable, on traite la flotabilite comme la
+         ! dissipation, en supposant que buoy/q2^3 est constant.
+         ! Puis on prend la solution exacte
+        ENDDO
+       ENDDO
+       
+      !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+      !! Attention, yamada4_num=5 est inexacte car néglige les termes de flottabilité
+      !! en conditions instables
+      !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+    ELSE IF (yamada4_num==5) THEN ! version modifiee avec integration exacte pour la dissipation
+       DO k = 2, klev - 1
+         DO ig=1,ngrid
+         tkeprov=q2(ig,k)/ydeux
+!FC on ajoute la dissipation due aux arbres
+         disseff=dissip(ig,k)-min(0.,buoy(ig,k)) + drgpro(ig,k)*tkeprov
+         tkeexp=exp(-dt*disseff/tkeprov)
+! on prend en compte la tke cree par les arbres
+         winds(ig,k)=sqrt(u(ig,k)**2+v(ig,k)**2)
+         tkeprov= (shear(ig,k)+ &
+          & drgpro(ig,k)*(winds(ig,k))**3)*tkeprov/disseff*(1.-tkeexp)+tkeprov*tkeexp
+         q2(ig,k)=tkeprov*ydeux
+         ! En cas stable, on traite la flotabilite comme la
+         ! dissipation, en supposant que buoy/q2^3 est constant.
+         ! Puis on prend la solution exacte
+        ENDDO
+       ENDDO
+    ELSE IF (yamada4_num==6) THEN ! version modifiee avec integration exacte pour la dissipation
+       DO k = 2, klev - 1
+         DO ig=1,ngrid
+         ! En cas stable, on traite la flotabilite comme la
+         ! dissipation, en supposant que dissipeff/TKE est constant.
+         ! Puis on prend la solution exacte
+         ! With drag and dissipation from high vegetation (EV & FC, 05/10/2020)
+         winds(ig,k)=sqrt(u(ig,k)**2+v(ig,k)**2)
+         tkeprov=q2(ig,k)/ydeux
+         tkeprov=tkeprov+max(buoy(ig,k)+shear(ig,k)+drgpro(ig,k)*(winds(ig,k))**3,0.)*dt
+         disseff=dissip(ig,k)-min(0.,buoy(ig,k)+shear(ig,k)+drgpro(ig,k)*(winds(ig,k))**3) + drgpro(ig,k)*tkeprov
+         tkeexp=exp(-dt*disseff/tkeprov)
+         tkeprov= tkeprov*tkeexp
+         q2(ig,k)=tkeprov*ydeux
+         
+        ENDDO
+       ENDDO
+    ENDIF
+
+    DO k = 2, klev - 1
+      DO ig=1,ngrid
+      q2(ig, k) = min(max(q2(ig,k),1.E-10), 1.E4)
+      ENDDO
+    ENDDO
+
+   ELSE 
+
+    DO k = 2, klev - 1
+      km(1:ngrid, k) = l(1:ngrid, k)*sqrt(q2(1:ngrid,k))*sm(1:ngrid, k)
+      q2(1:ngrid, k) = q2(1:ngrid, k) + ydeux*dt*km(1:ngrid, k)*m2(1:ngrid, k)*(1.-rif(1:ngrid,k))
+!     q2(1:ngrid, k) = q2(1:ngrid, k) + dt*km(1:ngrid, k)*m2(1:ngrid, k)*(1.-rif(1:ngrid,k))
+      q2(1:ngrid, k) = min(max(q2(1:ngrid,k),1.E-10), 1.E4)
+       q2(1:ngrid, k) = 1./(1./sqrt(q2(1:ngrid,k))+dt/(yun*l(1:ngrid,k)*b1))
+!     q2(1:ngrid, k) = 1./(1./sqrt(q2(1:ngrid,k))+dt/(2*l(1:ngrid,k)*b1))
+      q2(1:ngrid, k) = q2(1:ngrid, k)*q2(1:ngrid, k)
+    END DO
+
+  ENDIF
+
+  ELSE
+     abort_message='Cas nom prevu dans yamada4'
+     CALL abort_physic(modname,abort_message,1)
+
+  END IF ! Fin du cas 8
+
+
+  ! ====================================================================
+  ! Calcul des coefficients de melange
+  ! ====================================================================
+
+  DO k = 2, klev
+    DO ig = 1, ngrid
+      zq = sqrt(q2(ig,k))
+      km(ig, k) = l(ig, k)*zq*sm(ig, k)     ! For momentum
+      kn(ig, k) = km(ig, k)*alpha(ig, k)    ! For scalars
+      kq(ig, k) = l(ig, k)*zq*0.2           ! For TKE
+    END DO
+  END DO
+
+
+  !====================================================================
+  ! Transport diffusif vertical de la TKE par la TKE
+  !====================================================================
+
+
+    ! initialize near-surface and top-layer mixing coefficients
+    !...........................................................
+
+  kq(1:ngrid, 1) = kq(1:ngrid, 2)    ! constant (ie no gradient) near the surface
+  kq(1:ngrid, klev+1) = 0            ! zero at the top
+
+    ! Transport diffusif vertical de la TKE.
+    !.......................................
+
+  IF (iflag_vdif_q2==1) THEN
+    q2(1:ngrid, 1) = q2(1:ngrid, 2)
+    CALL vdif_q2(dt, g, rconst, ngrid, plev, temp, kq, q2)
+  END IF
+
+
+  !====================================================================
+  ! Traitement particulier pour les cas tres stables, introduction d'une
+  ! longueur de m??lange minimale
+  !====================================================================
+  !
+  ! Reference: Local versus Nonlocal boundary-layer diffusion in a global climate model
+  !            Holtslag A.A.M. and Boville B.A.
+  !            J. Clim., 6, 1825-1842, 1993
+
+
+ IF (hboville) THEN
+
+
+  IF (prt_level>1) THEN
+    WRITE(lunout,*) 'YAMADA4 0'
+  END IF 
+
+  DO ig = 1, ngrid
+    coriol(ig) = 1.E-4
+    pblhmin(ig) = 0.07*ustar(ig)/max(abs(coriol(ig)), 2.546E-5)
+  END DO
+
+  IF (1==1) THEN
+    IF (iflag_pbl==8 .OR. iflag_pbl==10) THEN
+
+      DO k = 2, klev
+        DO ig = 1, ngrid
+          IF (teta(ig,2)>teta(ig,1)) THEN
+            qmin = ustar(ig)*(max(1.-zlev(ig,k)/pblhmin(ig),0.))**2
+            kmin = kap*zlev(ig, k)*qmin
+          ELSE
+            kmin = -1. ! kmin n'est utilise que pour les SL stables.
+          END IF
+          IF (kn(ig,k)<kmin .OR. km(ig,k)<kmin) THEN
+
+            kn(ig, k) = kmin
+            km(ig, k) = kmin
+            kq(ig, k) = kmin
+
+ ! la longueur de melange est suposee etre l= kap z
+ ! K=l q Sm d'ou q2=(K/l Sm)**2
+
+            q2(ig, k) = (qmin/sm(ig,k))**2
+          END IF
+        END DO
+      END DO
+
+    ELSE
+      DO k = 2, klev
+        DO ig = 1, ngrid
+          IF (teta(ig,2)>teta(ig,1)) THEN
+            qmin = ustar(ig)*(max(1.-zlev(ig,k)/pblhmin(ig),0.))**2
+            kmin = kap*zlev(ig, k)*qmin
+          ELSE
+            kmin = -1. ! kmin n'est utilise que pour les SL stables.
+          END IF
+          IF (kn(ig,k)<kmin .OR. km(ig,k)<kmin) THEN
+            kn(ig, k) = kmin
+            km(ig, k) = kmin
+            kq(ig, k) = kmin
+ ! la longueur de melange est suposee etre l= kap z
+ ! K=l q Sm d'ou q2=(K/l Sm)**2
+            sm(ig, k) = 1.
+            alpha(ig, k) = 1.
+            q2(ig, k) = min((qmin/sm(ig,k))**2, 10.)
+            zq = sqrt(q2(ig,k))
+            km(ig, k) = l(ig, k)*zq*sm(ig, k)
+            kn(ig, k) = km(ig, k)*alpha(ig, k)
+            kq(ig, k) = l(ig, k)*zq*0.2
+          END IF
+        END DO
+      END DO
+    END IF
+
+  END IF
+
+ END IF ! hboville
+
+! Ajout d'une viscosite moleculaire
+   km(1:ngrid,2:klev)=km(1:ngrid,2:klev)+viscom
+   kn(1:ngrid,2:klev)=kn(1:ngrid,2:klev)+viscoh
+   kq(1:ngrid,2:klev)=kq(1:ngrid,2:klev)+viscoh
+
+  IF (prt_level>1) THEN
+    WRITE(lunout,*)'YAMADA4 1'
+  END IF !(prt_level>1) THEN
+
+
+ !======================================================
+ ! Estimations de w'2 et T'2 d'apres Abdela et McFarlane
+ !======================================================
+ !
+ ! Reference: A New Second-Order Turbulence Closure Scheme for the Planetary Boundary Layer
+ !            Abdella K and McFarlane N
+ !            J. Atmos. Sci., 54, 1850-1867, 1997
+
+  ! Diagnostique pour stokage
+  !..........................
+
+  IF (1==0) THEN
+    rino = rif
+    smyam(1:ngrid, 1) = 0.
+    styam(1:ngrid, 1) = 0.
+    lyam(1:ngrid, 1) = 0.
+    knyam(1:ngrid, 1) = 0.
+    w2yam(1:ngrid, 1) = 0.
+    t2yam(1:ngrid, 1) = 0.
+
+    smyam(1:ngrid, 2:klev) = sm(1:ngrid, 2:klev)
+    styam(1:ngrid, 2:klev) = sm(1:ngrid, 2:klev)*alpha(1:ngrid, 2:klev)
+    lyam(1:ngrid, 2:klev) = l(1:ngrid, 2:klev)
+    knyam(1:ngrid, 2:klev) = kn(1:ngrid, 2:klev)
+
+
+  ! Calcul de w'2 et T'2
+  !.......................
+
+    w2yam(1:ngrid, 2:klev) = q2(1:ngrid, 2:klev)*0.24 + &
+      lyam(1:ngrid, 2:klev)*5.17*kn(1:ngrid, 2:klev)*n2(1:ngrid, 2:klev)/ &
+      sqrt(q2(1:ngrid,2:klev))
+ 
+    t2yam(1:ngrid, 2:klev) = 9.1*kn(1:ngrid, 2:klev)* &
+      dtetadz(1:ngrid, 2:klev)**2/sqrt(q2(1:ngrid,2:klev))* &
+      lyam(1:ngrid, 2:klev)
+  END IF
+
+
+
+!============================================================================
+! Mise a jour de la tke
+!============================================================================
+
+  IF (new_yamada4) THEN
+     DO k=1,klev+1
+        tke(1:ngrid,k)=q2(1:ngrid,k)/ydeux
+     ENDDO
+  ELSE
+     DO k=1,klev+1
+        tke(1:ngrid,k)=q2(1:ngrid,k)
+     ENDDO
+  ENDIF
+
+
+!============================================================================
+! Diagnostique de la dissipation et vitesse verticale
+!============================================================================
+
+! Diagnostics
+
+ eps(:,:)=0.
+ wprime(1:ngrid,:,nsrf)=0.
+ DO k=2,klev
+    DO ig=1,ngrid
+       eps(ig,k)=dissip(ig,k)
+       jg=ni(ig)
+       wprime(jg,k,nsrf)=sqrt(MAX(1./3*q2(ig,k),0.))
+    ENDDO
+ ENDDO
+
+ 
+!=============================================================================
+
+  RETURN
+
+
+END SUBROUTINE yamada4
+
+!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+SUBROUTINE vdif_q2(timestep, gravity, rconst, ngrid, plev, temp, kmy, q2)
+
+  USE dimphy, only : klev,klon
+  IMPLICIT NONE
+ 
+!    vdif_q2: subroutine qui calcule la diffusion de la TKE par la TKE
+!             avec un schema implicite en temps avec 
+!             inversion d'un syst??me tridiagonal
+! 
+!     Reference: Description of the interface with the surface and 
+!                the computation of the turbulet diffusion in LMDZ
+!                Technical note on LMDZ
+!                Dufresne, J-L, Ghattas, J. and Grandpeix, J-Y
+!
+!============================================================================
+! Declarations
+!============================================================================
+
+  REAL plev(klon, klev+1)
+  REAL temp(klon, klev)
+  REAL timestep
+  REAL gravity, rconst
+  REAL kstar(klon, klev+1), zz
+  REAL kmy(klon, klev+1)
+  REAL q2(klon, klev+1)
+  REAL deltap(klon, klev+1)
+  REAL denom(klon, klev+1), alpha(klon, klev+1), beta(klon, klev+1)
+  INTEGER ngrid
+
+  INTEGER i, k
+
+
+!=========================================================================
+! Calcul
+!=========================================================================
+
+  DO k = 1, klev
+    DO i = 1, ngrid
+      zz = (plev(i,k)+plev(i,k+1))*gravity/(rconst*temp(i,k))
+      kstar(i, k) = 0.125*(kmy(i,k+1)+kmy(i,k))*zz*zz/ &
+        (plev(i,k)-plev(i,k+1))*timestep
+    END DO
+  END DO
+
+  DO k = 2, klev
+    DO i = 1, ngrid
+      deltap(i, k) = 0.5*(plev(i,k-1)-plev(i,k+1))
+    END DO
+  END DO
+  DO i = 1, ngrid
+    deltap(i, 1) = 0.5*(plev(i,1)-plev(i,2))
+    deltap(i, klev+1) = 0.5*(plev(i,klev)-plev(i,klev+1))
+    denom(i, klev+1) = deltap(i, klev+1) + kstar(i, klev)
+    alpha(i, klev+1) = deltap(i, klev+1)*q2(i, klev+1)/denom(i, klev+1)
+    beta(i, klev+1) = kstar(i, klev)/denom(i, klev+1)
+  END DO
+
+  DO k = klev, 2, -1
+    DO i = 1, ngrid
+      denom(i, k) = deltap(i, k) + (1.-beta(i,k+1))*kstar(i, k) + &
+        kstar(i, k-1)
+      alpha(i, k) = (q2(i,k)*deltap(i,k)+kstar(i,k)*alpha(i,k+1))/denom(i, k)
+      beta(i, k) = kstar(i, k-1)/denom(i, k)
+    END DO
+  END DO
+
+  ! Si on recalcule q2(1)
+  !.......................
+  IF (1==0) THEN
+    DO i = 1, ngrid
+      denom(i, 1) = deltap(i, 1) + (1-beta(i,2))*kstar(i, 1)
+      q2(i, 1) = (q2(i,1)*deltap(i,1)+kstar(i,1)*alpha(i,2))/denom(i, 1)
+    END DO
+  END IF
+
+
+  DO k = 2, klev + 1
+    DO i = 1, ngrid
+      q2(i, k) = alpha(i, k) + beta(i, k)*q2(i, k-1)
+    END DO
+  END DO
+
+  RETURN
+END SUBROUTINE vdif_q2
+!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+
+!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+ SUBROUTINE vdif_q2e(timestep, gravity, rconst, ngrid, plev, temp, kmy, q2)
+  
+   USE dimphy, only : klev,klon
+  IMPLICIT NONE
+
+! vdif_q2e: subroutine qui calcule la diffusion de TKE par la TKE
+!           avec un schema explicite en temps
+
+
+!====================================================
+! Declarations
+!====================================================
+
+  REAL plev(klon, klev+1)
+  REAL temp(klon, klev)
+  REAL timestep
+  REAL gravity, rconst
+  REAL kstar(klon, klev+1), zz
+  REAL kmy(klon, klev+1)
+  REAL q2(klon, klev+1)
+  REAL deltap(klon, klev+1)
+  REAL denom(klon, klev+1), alpha(klon, klev+1), beta(klon, klev+1)
+  INTEGER ngrid
+  INTEGER i, k
+
+
+!==================================================
+! Calcul
+!==================================================
+
+  DO k = 1, klev
+    DO i = 1, ngrid
+      zz = (plev(i,k)+plev(i,k+1))*gravity/(rconst*temp(i,k))
+      kstar(i, k) = 0.125*(kmy(i,k+1)+kmy(i,k))*zz*zz/ &
+        (plev(i,k)-plev(i,k+1))*timestep
+    END DO
+  END DO
+
+  DO k = 2, klev
+    DO i = 1, ngrid
+      deltap(i, k) = 0.5*(plev(i,k-1)-plev(i,k+1))
+    END DO
+  END DO
+  DO i = 1, ngrid
+    deltap(i, 1) = 0.5*(plev(i,1)-plev(i,2))
+    deltap(i, klev+1) = 0.5*(plev(i,klev)-plev(i,klev+1))
+  END DO
+
+  DO k = klev, 2, -1
+    DO i = 1, ngrid
+      q2(i, k) = q2(i, k) + (kstar(i,k)*(q2(i,k+1)-q2(i, &
+        k))-kstar(i,k-1)*(q2(i,k)-q2(i,k-1)))/deltap(i, k)
+    END DO
+  END DO
+
+  DO i = 1, ngrid
+    q2(i, 1) = q2(i, 1) + (kstar(i,1)*(q2(i,2)-q2(i,1)))/deltap(i, 1)
+    q2(i, klev+1) = q2(i, klev+1) + (-kstar(i,klev)*(q2(i,klev+1)-q2(i, &
+      klev)))/deltap(i, klev+1)
+  END DO
+
+  RETURN
+END SUBROUTINE vdif_q2e
+
+!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+SUBROUTINE mixinglength(ni, nsrf, ngrid,iflag_pbl,pbl_lmixmin_alpha,lmixmin,zlay,zlev,u,v,q2,n2, lmix)
+
+
+
+  USE dimphy, only : klev,klon
+  USE yamada_ini_mod, only : l0
+  USE phys_state_var_mod, only: zstd, zsig, zmea
+  USE phys_local_var_mod, only: l_mixmin, l_mix
+  USE yamada_ini_mod, only : kap, kapb
+
+ ! zstd: ecart type de la'altitud e sous-maille
+ ! zmea: altitude moyenne sous maille
+ ! zsig: pente moyenne de le maille
+
+  USE geometry_mod, only: cell_area
+  ! aire_cell: aire de la maille
+
+  IMPLICIT NONE
+!*************************************************************************
+! Subrourine qui calcule la longueur de m??lange dans le sch??ma de turbulence
+! avec la formule de Blackadar 
+! Calcul d'un  minimum en fonction de l'orographie sous-maille:
+! L'id??e est la suivante: plus il y a de relief, plus il y a du m??lange
+! induit par les circulations meso et submeso ??chelles.
+!
+! References: * The vertical distribution of wind and turbulent exchange in a neutral atmosphere
+!               Blackadar A.K.
+!               J. Geophys. Res., 64, No 8, 1962
+!
+!             * An evaluation of neutral and convective planetary boundary-layer parametrisations relative 
+!               to large eddy simulations
+!               Ayotte K et al 
+!               Boundary Layer Meteorology, 79, 131-175, 1996
+!
+!
+!             * Local Similarity in the Stable Boundary Layer and Mixing length Approaches: consistency of concepts
+!               Van de Wiel B.J.H et al
+!               Boundary-Lay Meteorol, 128, 103-166, 2008
+!
+!
+! Histoire:
+!----------
+! * premi??re r??daction, Etienne et Frederic, 09/06/2016
+!
+! ***********************************************************************
+
+!==================================================================
+! Declarations
+!==================================================================
+
+! Inputs
+!-------
+ INTEGER            ni(klon)           ! indice sur la grille original (non restreinte)
+ INTEGER            nsrf               ! Type de surface
+ INTEGER            ngrid              ! Nombre de points concern??s sur l'horizontal
+ INTEGER            iflag_pbl          ! Choix du sch??ma de turbulence
+ REAL               pbl_lmixmin_alpha  ! on active ou non le calcul de la longueur de melange minimum en fonction du relief
+ REAL               lmixmin            ! Minimum absolu de la longueur de m??lange
+ REAL               zlay(klon, klev)   ! altitude du centre de la couche
+ REAL               zlev(klon, klev+1) ! atitude de l'interface inf??rieure de la couche
+ REAL               u(klon, klev)      ! vitesse du vent zonal
+ REAL               v(klon, klev)      ! vitesse du vent meridional
+ REAL               q2(klon, klev+1)   ! energie cin??tique turbulente 
+ REAL               n2(klon, klev+1)   ! frequence de Brunt-Vaisala
+
+!In/out
+!-------
+
+! Outputs
+!---------
+
+ REAL               lmix(klon, klev+1)    ! Longueur de melange  
+
+
+! Local
+!-------
+  
+ INTEGER  ig,jg, k
+ REAL     h_oro(klon)
+ REAL     hlim(klon)
+ REAL zq
+ REAL sq(klon), sqz(klon)
+ REAL fl, zzz, zl0, zq2, zn2
+ REAL famorti, zzzz, zh_oro, zhlim
+ REAL l1(klon, klev+1), l2(klon,klev+1)
+ REAL winds(klon, klev)
+ REAL xcell
+ REAL zstdslope(klon)  
+ REAL lmax
+ REAL l2strat, l2neutre, extent  
+ REAL l2limit(klon)
+!===============================================================
+! Fonctions utiles
+!===============================================================
+
+! Calcul de l suivant la formule de Blackadar 1962 adapt??e par Ayotte 1996
+!..........................................................................
+
+ fl(zzz, zl0, zq2, zn2) = max(min(l0(ig)*kap*zlev(ig, &
+    k)/(kap*zlev(ig,k)+l0(ig)),0.5*sqrt(q2(ig,k))/sqrt( &
+    max(n2(ig,k),1.E-10))), 1.E-5)
+ 
+! Fonction d'amortissement de la turbulence au dessus de la montagne
+! On augmente l'amortissement en diminuant la valeur de hlim (extent) dans le code
+!.....................................................................
+
+ famorti(zzzz, zh_oro, zhlim)=(-1.)*ATAN((zzzz-zh_oro)/(zhlim-zh_oro))*2./3.1416+1.    
+
+  IF (ngrid==0) RETURN
+
+
+!=====================================================================
+!         CALCUL de la LONGUEUR de m??lange suivant BLACKADAR: l1
+!=====================================================================
+
+  l1(1:ngrid,:)=0.
+  IF (iflag_pbl==8 .OR. iflag_pbl==10) THEN
+
+    
+    ! Iterative computation of l0
+    ! This version is kept for iflag_pbl only for convergence
+    ! with NPv3.1 Cmip5 simulations
+    !...................................................................
+
+    DO ig = 1, ngrid
+      sq(ig) = 1.E-10
+      sqz(ig) = 1.E-10
+    END DO
+    DO k = 2, klev - 1
+      DO ig = 1, ngrid
+        zq = sqrt(q2(ig,k))
+        sqz(ig) = sqz(ig) + zq*zlev(ig, k)*(zlay(ig,k)-zlay(ig,k-1))
+        sq(ig) = sq(ig) + zq*(zlay(ig,k)-zlay(ig,k-1))
+      END DO
+    END DO
+    DO ig = 1, ngrid
+      l0(ig) = 0.2*sqz(ig)/sq(ig)
+    END DO
+    DO k = 2, klev
+      DO ig = 1, ngrid
+        l1(ig, k) = fl(zlev(ig,k), l0(ig), q2(ig,k), n2(ig,k))
+      END DO
+    END DO
+
+  ELSE
+
+    
+    ! In all other case, the assymptotic mixing length l0 is imposed (150m)
+    !......................................................................
+
+    l0(1:ngrid) = 150.
+    DO k = 2, klev
+      DO ig = 1, ngrid
+        l1(ig, k) = fl(zlev(ig,k), l0(ig), q2(ig,k), n2(ig,k))
+      END DO
+    END DO
+
+  END IF
+
+!===========================================================================================
+!  CALCUL d'une longueur de melange minimum en fonctions de la topographie sous maille: l2
+! si pbl_lmixmin_alpha=TRUE et si on se trouve sur de la terre ( pas actif sur les 
+! glacier, la glace de mer et les oc??ans)
+!===========================================================================================
+
+   l2(1:ngrid,:)=0.0
+   l_mixmin(1:ngrid,:,nsrf)=0.
+   l_mix(1:ngrid,:,nsrf)=0.
+   hlim(1:ngrid)=0.
+
+   IF (nsrf .EQ. 1) THEN
+
+! coefficients 
+!--------------
+
+     extent=2.                                                         ! On ??tend l'impact du relief jusqu'?? extent*h, extent >1.  
+     lmax=150.                                                         ! Longueur de m??lange max dans l'absolu
+
+! calculs
+!---------
+
+     DO ig=1,ngrid
+
+      ! On calcule la hauteur du relief
+      !.................................
+      ! On ne peut pas prendre zstd seulement pour caracteriser le relief sous maille
+      ! car sur un terrain pentu mais sans relief, zstd est non nul (comme en Antarctique, C. Genthon)
+      ! On corrige donc zstd avec l'ecart type de l'altitude dans la maille sans relief 
+      ! (en gros, une maille de taille xcell avec une pente constante zstdslope)
+      jg=ni(ig) 
+!     IF (zsig(jg) .EQ. 0.) THEN
+!          zstdslope(ig)=0.         
+!     ELSE
+!     xcell=sqrt(cell_area(jg))
+!     zstdslope(ig)=max((xcell*zsig(jg)-zmea(jg))**3 /(3.*zsig(jg)),0.)
+!     zstdslope(ig)=sqrt(zstdslope(ig))
+!     END IF
+      
+!     h_oro(ig)=max(zstd(jg)-zstdslope(ig),0.)   ! Hauteur du relief
+      h_oro(ig)=zstd(jg)
+      hlim(ig)=extent*h_oro(ig)     
+     ENDDO
+
+     l2limit(1:ngrid)=0.
+
+     DO k=2,klev
+        DO ig=1,ngrid
+           winds(ig,k)=sqrt(u(ig,k)**2+v(ig,k)**2)
+           IF (zlev(ig,k) .LE. h_oro(ig)) THEN  ! sous l'orographie
+              l2strat= kapb*pbl_lmixmin_alpha*winds(ig,k)/sqrt(max(n2(ig,k),1.E-10))  ! si stratifi??, amplitude d'oscillation * kappab (voir Van de Wiel et al 2008)
+              l2neutre=kap*zlev(ig,k)*h_oro(ig)/(kap*zlev(ig,k)+h_oro(ig))            ! Dans le cas neutre, formule de blackadar. tend asymptotiquement vers h
+              l2neutre=MIN(l2neutre,lmax)                                             ! On majore par lmax 
+              l2limit(ig)=MIN(l2neutre,l2strat)                                       ! Calcule de l2 (minimum de la longueur en cas neutre et celle en situation stratifi??e)
+              l2(ig,k)=l2limit(ig)
+                                      
+           ELSE IF (zlev(ig,k) .LE. hlim(ig)) THEN ! Si on est au dessus des montagnes, mais affect?? encore par elles
+
+      ! Au dessus des montagnes, on prend la l2limit au sommet des montagnes 
+      ! (la derni??re calcul??e dans la boucle k, vu que k est un indice croissant avec z)
+      ! et on multiplie l2limit par une fonction qui d??croit entre h et hlim
+              l2(ig,k)=l2limit(ig)*famorti(zlev(ig,k),h_oro(ig), hlim(ig))
+           ELSE                                                                    ! Au dessus de extent*h, on prend l2=l0 
+              l2(ig,k)=0.
+           END IF
+        ENDDO
+     ENDDO
+   ENDIF                                                                           ! pbl_lmixmin_alpha
+
+!==================================================================================
+! On prend le max entre la longueur de melange de blackadar et celle calcul??e
+! en fonction de la topographie 
+!===================================================================================
+
+
+ DO k=1,klev+1
+    DO ig=1,ngrid
+       lmix(ig,k)=MAX(MAX(l1(ig,k), l2(ig,k)),lmixmin)
+   ENDDO
+ ENDDO
+
+! Diagnostics
+
+ DO k=1,klev+1
+    DO ig=1,ngrid
+       jg=ni(ig)
+       l_mix(jg,k,nsrf)=lmix(ig,k)
+       l_mixmin(jg,k,nsrf)=MAX(l2(ig,k),lmixmin)
+    ENDDO
+ ENDDO
+
+
+
+END SUBROUTINE mixinglength
Index: DZ6/trunk/libf/phylmd/yamada_ini_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/yamada_ini_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,96 +1,0 @@
-MODULE yamada_ini_mod
-
-! AFAIRE : frif defini deux fois.
-! peut on passer une fonction du module au code.
-
-implicit none
-
-save
-
-  LOGICAL :: new_yamada4
-  INTEGER :: yamada4_num
-  !$OMP THREADPRIVATE(new_yamada4,yamada4_num)
-  LOGICAL :: hboville=.TRUE.
-  REAL :: viscom,viscoh,pbl_lmixmin_alpha
-  !$OMP THREADPRIVATE( hboville,viscom,viscoh,pbl_lmixmin_alpha)
-  real :: ric, yun,ydeux,lmixmin,b1,kap,kapb
-  !$OMP THREADPRIVATE(ric, yun,ydeux,lmixmin,b1,kap,kapb)
-  integer :: iflag_vdif_q2
-  !$OMP THREADPRIVATE(iflag_vdif_q2)
-
-  real, dimension(:), allocatable, save :: l0
-  !$OMP THREADPRIVATE(l0)
-  integer :: lunout,prt_level
-  !$OMP THREADPRIVATE(lunout,prt_level)
-
-
-CONTAINS
-
-SUBROUTINE yamada_ini(klon,lunout_in,prt_level_in)
-
-   USE ioipsl_getin_p_mod, ONLY : getin_p
-
-! local
-  integer, intent(in) :: klon,lunout_in,prt_level_in
-  real :: ric0
-  real frif,falpha,fsm,ri
-
-  lunout=lunout_in
-  prt_level=prt_level_in
-
-  b1=16.6
-  kap=0.4
-  kapb=0.4
-
-    ALLOCATE (l0(klon))
-
-   new_yamada4=.false.
-   CALL getin_p('new_yamada4',new_yamada4)
-
-   iflag_vdif_q2=1
-   CALL getin_p('iflag_vdif_q2',iflag_vdif_q2)
-
-
-    IF (new_yamada4) THEN
-! Corrections et reglages issus du travail de these d'Etienne Vignon.
-       ric=0.143 ! qui donne des valeurs proches des seuils proposes
-                 ! dans YAMADA 1983 : sm=0.0845 (0.085 dans Y83)
-                 !                    sm=1.1213 (1.12  dans Y83)
-
-       CALL getin_p('yamada4_ric',ric)
-       ric0=0.19489      ! ric=0.195 originalement, mais produisait sm<0
-       ric=min(ric,ric0) ! Au dela de ric0, sm devient n??gatif
-       yun=1.
-       ydeux=2.
-       hboville=.FALSE.
-       viscom=1.46E-5
-       viscoh=2.06E-5
-       !lmixmin=1.0E-3
-       lmixmin=0.
-       yamada4_num=5
-    ELSE
-       ric=0.195
-       yun=2.
-       ydeux=1.
-       hboville=.TRUE.
-       viscom=0.
-       viscoh=0.
-       lmixmin=1.
-       yamada4_num=0
-    ENDIF
-
-
-!    WRITE(lunout,*)'YAMADA4 RIc, RIfc, Sm_min, Alpha_min',ric,rifc,seuilsm,seuilalpha
-    CALL getin_p('lmixmin',lmixmin)
-    CALL getin_p('yamada4_hboville',hboville)
-    CALL getin_p('yamada4_num',yamada4_num)
-    pbl_lmixmin_alpha=0.0
-    CALL getin_p('pbl_lmixmin_alpha',pbl_lmixmin_alpha)
-
-
-   
- RETURN
-
-END SUBROUTINE yamada_ini
-
-END MODULE yamada_ini_mod
Index: /LMDZ6/trunk/libf/phylmd/yamada_ini_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/yamada_ini_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/yamada_ini_mod.f90	(revision 5268)
@@ -0,0 +1,96 @@
+MODULE yamada_ini_mod
+
+! AFAIRE : frif defini deux fois.
+! peut on passer une fonction du module au code.
+
+implicit none
+
+save
+
+  LOGICAL :: new_yamada4
+  INTEGER :: yamada4_num
+  !$OMP THREADPRIVATE(new_yamada4,yamada4_num)
+  LOGICAL :: hboville=.TRUE.
+  REAL :: viscom,viscoh,pbl_lmixmin_alpha
+  !$OMP THREADPRIVATE( hboville,viscom,viscoh,pbl_lmixmin_alpha)
+  real :: ric, yun,ydeux,lmixmin,b1,kap,kapb
+  !$OMP THREADPRIVATE(ric, yun,ydeux,lmixmin,b1,kap,kapb)
+  integer :: iflag_vdif_q2
+  !$OMP THREADPRIVATE(iflag_vdif_q2)
+
+  real, dimension(:), allocatable, save :: l0
+  !$OMP THREADPRIVATE(l0)
+  integer :: lunout,prt_level
+  !$OMP THREADPRIVATE(lunout,prt_level)
+
+
+CONTAINS
+
+SUBROUTINE yamada_ini(klon,lunout_in,prt_level_in)
+
+   USE ioipsl_getin_p_mod, ONLY : getin_p
+
+! local
+  integer, intent(in) :: klon,lunout_in,prt_level_in
+  real :: ric0
+  real frif,falpha,fsm,ri
+
+  lunout=lunout_in
+  prt_level=prt_level_in
+
+  b1=16.6
+  kap=0.4
+  kapb=0.4
+
+    ALLOCATE (l0(klon))
+
+   new_yamada4=.false.
+   CALL getin_p('new_yamada4',new_yamada4)
+
+   iflag_vdif_q2=1
+   CALL getin_p('iflag_vdif_q2',iflag_vdif_q2)
+
+
+    IF (new_yamada4) THEN
+! Corrections et reglages issus du travail de these d'Etienne Vignon.
+       ric=0.143 ! qui donne des valeurs proches des seuils proposes
+                 ! dans YAMADA 1983 : sm=0.0845 (0.085 dans Y83)
+                 !                    sm=1.1213 (1.12  dans Y83)
+
+       CALL getin_p('yamada4_ric',ric)
+       ric0=0.19489      ! ric=0.195 originalement, mais produisait sm<0
+       ric=min(ric,ric0) ! Au dela de ric0, sm devient n??gatif
+       yun=1.
+       ydeux=2.
+       hboville=.FALSE.
+       viscom=1.46E-5
+       viscoh=2.06E-5
+       !lmixmin=1.0E-3
+       lmixmin=0.
+       yamada4_num=5
+    ELSE
+       ric=0.195
+       yun=2.
+       ydeux=1.
+       hboville=.TRUE.
+       viscom=0.
+       viscoh=0.
+       lmixmin=1.
+       yamada4_num=0
+    ENDIF
+
+
+!    WRITE(lunout,*)'YAMADA4 RIc, RIfc, Sm_min, Alpha_min',ric,rifc,seuilsm,seuilalpha
+    CALL getin_p('lmixmin',lmixmin)
+    CALL getin_p('yamada4_hboville',hboville)
+    CALL getin_p('yamada4_num',yamada4_num)
+    pbl_lmixmin_alpha=0.0
+    CALL getin_p('pbl_lmixmin_alpha',pbl_lmixmin_alpha)
+
+
+   
+ RETURN
+
+END SUBROUTINE yamada_ini
+
+END MODULE yamada_ini_mod
Index: DZ6/trunk/libf/phylmd/zilch.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/zilch.F90	(revision 5267)
+++ 	(revision )
@@ -1,17 +1,0 @@
-
-! $Header$
-
-SUBROUTINE zilch(x, m)
-
-  ! Zero the real array x dimensioned m.
-
-  IMPLICIT NONE
-
-  INTEGER m, i
-  REAL x(m)
-
-  DO i = 1, m
-    x(i) = 0.0
-  END DO
-  RETURN
-END SUBROUTINE zilch
Index: /LMDZ6/trunk/libf/phylmd/zilch.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmd/zilch.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmd/zilch.f90	(revision 5268)
@@ -0,0 +1,17 @@
+
+! $Header$
+
+SUBROUTINE zilch(x, m)
+
+  ! Zero the real array x dimensioned m.
+
+  IMPLICIT NONE
+
+  INTEGER m, i
+  REAL x(m)
+
+  DO i = 1, m
+    x(i) = 0.0
+  END DO
+  RETURN
+END SUBROUTINE zilch
Index: DZ6/trunk/libf/phylmdiso/YOEMETH.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/YOEMETH.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/YOEMETH.F90
Index: /LMDZ6/trunk/libf/phylmdiso/YOEMETH.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/YOEMETH.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/YOEMETH.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/YOEMETH.f90
Index: DZ6/trunk/libf/phylmdiso/aaam_bud.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/aaam_bud.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/aaam_bud.F90
Index: /LMDZ6/trunk/libf/phylmdiso/aaam_bud.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/aaam_bud.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/aaam_bud.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/aaam_bud.f90
Index: DZ6/trunk/libf/phylmdiso/acama_gwd_rando_m.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/acama_gwd_rando_m.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/acama_gwd_rando_m.F90
Index: /LMDZ6/trunk/libf/phylmdiso/acama_gwd_rando_m.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/acama_gwd_rando_m.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/acama_gwd_rando_m.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/acama_gwd_rando_m.f90
Index: DZ6/trunk/libf/phylmdiso/aero_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/aero_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/aero_mod.F90
Index: /LMDZ6/trunk/libf/phylmdiso/aero_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/aero_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/aero_mod.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/aero_mod.f90
Index: DZ6/trunk/libf/phylmdiso/aeropt.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/aeropt.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/aeropt.F90
Index: /LMDZ6/trunk/libf/phylmdiso/aeropt.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/aeropt.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/aeropt.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/aeropt.f90
Index: DZ6/trunk/libf/phylmdiso/aeropt_2bands.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/aeropt_2bands.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/aeropt_2bands.F90
Index: /LMDZ6/trunk/libf/phylmdiso/aeropt_2bands.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/aeropt_2bands.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/aeropt_2bands.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/aeropt_2bands.f90
Index: DZ6/trunk/libf/phylmdiso/aeropt_5wv.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/aeropt_5wv.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/aeropt_5wv.F90
Index: /LMDZ6/trunk/libf/phylmdiso/aeropt_5wv.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/aeropt_5wv.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/aeropt_5wv.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/aeropt_5wv.f90
Index: DZ6/trunk/libf/phylmdiso/albedo.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/albedo.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/albedo.F90
Index: /LMDZ6/trunk/libf/phylmdiso/albedo.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/albedo.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/albedo.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/albedo.f90
Index: DZ6/trunk/libf/phylmdiso/albsno.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/albsno.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/albsno.F90
Index: /LMDZ6/trunk/libf/phylmdiso/albsno.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/albsno.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/albsno.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/albsno.f90
Index: DZ6/trunk/libf/phylmdiso/alpale.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/alpale.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/alpale.F90
Index: /LMDZ6/trunk/libf/phylmdiso/alpale.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/alpale.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/alpale.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/alpale.f90
Index: DZ6/trunk/libf/phylmdiso/alpale_th.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/alpale_th.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/alpale_th.F90
Index: /LMDZ6/trunk/libf/phylmdiso/alpale_th.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/alpale_th.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/alpale_th.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/alpale_th.f90
Index: DZ6/trunk/libf/phylmdiso/alpale_wk.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/alpale_wk.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/alpale_wk.F90
Index: /LMDZ6/trunk/libf/phylmdiso/alpale_wk.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/alpale_wk.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/alpale_wk.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/alpale_wk.f90
Index: DZ6/trunk/libf/phylmdiso/atm2geo.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/atm2geo.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/atm2geo.F90
Index: /LMDZ6/trunk/libf/phylmdiso/atm2geo.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/atm2geo.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/atm2geo.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/atm2geo.f90
Index: DZ6/trunk/libf/phylmdiso/borne_var_surf.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/borne_var_surf.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/borne_var_surf.F90
Index: /LMDZ6/trunk/libf/phylmdiso/borne_var_surf.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/borne_var_surf.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/borne_var_surf.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/borne_var_surf.f90
Index: DZ6/trunk/libf/phylmdiso/buffer_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/buffer_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/buffer_mod.F90
Index: /LMDZ6/trunk/libf/phylmdiso/buffer_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/buffer_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/buffer_mod.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/buffer_mod.f90
Index: DZ6/trunk/libf/phylmdiso/cal_tools_m.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/cal_tools_m.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/cal_tools_m.F90
Index: /LMDZ6/trunk/libf/phylmdiso/cal_tools_m.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/cal_tools_m.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/cal_tools_m.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/cal_tools_m.f90
Index: DZ6/trunk/libf/phylmdiso/calbeta.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/calbeta.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/calbeta.F90
Index: /LMDZ6/trunk/libf/phylmdiso/calbeta.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/calbeta.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/calbeta.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/calbeta.f90
Index: DZ6/trunk/libf/phylmdiso/calbeta_clim.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/calbeta_clim.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/calbeta_clim.F90
Index: /LMDZ6/trunk/libf/phylmdiso/calbeta_clim.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/calbeta_clim.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/calbeta_clim.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/calbeta_clim.f90
Index: DZ6/trunk/libf/phylmdiso/calcul_fluxs_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/calcul_fluxs_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/calcul_fluxs_mod.F90
Index: /LMDZ6/trunk/libf/phylmdiso/calcul_fluxs_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/calcul_fluxs_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/calcul_fluxs_mod.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/calcul_fluxs_mod.f90
Index: DZ6/trunk/libf/phylmdiso/carbon_cycle_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/carbon_cycle_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/carbon_cycle_mod.F90
Index: /LMDZ6/trunk/libf/phylmdiso/carbon_cycle_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/carbon_cycle_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/carbon_cycle_mod.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/carbon_cycle_mod.f90
Index: DZ6/trunk/libf/phylmdiso/cdrag_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/cdrag_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/cdrag_mod.F90
Index: /LMDZ6/trunk/libf/phylmdiso/cdrag_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/cdrag_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/cdrag_mod.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/cdrag_mod.f90
Index: DZ6/trunk/libf/phylmdiso/cfmip_point_locations.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/cfmip_point_locations.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/cfmip_point_locations.F90
Index: /LMDZ6/trunk/libf/phylmdiso/cfmip_point_locations.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/cfmip_point_locations.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/cfmip_point_locations.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/cfmip_point_locations.f90
Index: DZ6/trunk/libf/phylmdiso/chemistry_cycle_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/chemistry_cycle_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/chemistry_cycle_mod.F90
Index: /LMDZ6/trunk/libf/phylmdiso/chemistry_cycle_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/chemistry_cycle_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/chemistry_cycle_mod.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/chemistry_cycle_mod.f90
Index: DZ6/trunk/libf/phylmdiso/clc_core_cp.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/clc_core_cp.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/clc_core_cp.F90
Index: /LMDZ6/trunk/libf/phylmdiso/clc_core_cp.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/clc_core_cp.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/clc_core_cp.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/clc_core_cp.f90
Index: DZ6/trunk/libf/phylmdiso/clcdrag.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/clcdrag.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/clcdrag.F90
Index: /LMDZ6/trunk/libf/phylmdiso/clcdrag.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/clcdrag.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/clcdrag.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/clcdrag.f90
Index: DZ6/trunk/libf/phylmdiso/clift.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/clift.F90	(revision 5267)
+++ 	(revision )
@@ -1,74 +1,0 @@
-
-! $Header$
-
-SUBROUTINE clift(p, t, rr, rs, plcl, dplcldt, dplcldq)
-IMPLICIT NONE
-  ! ***************************************************************
-  ! *                                                             *
-  ! * CLIFT : COMPUTE LIFTING CONDENSATION LEVEL AND ITS          *
-  ! *         DERIVATIVES RELATIVE TO T AND R                     *
-  ! *   (WITHIN 0.2% OF FORMULA OF BOLTON, MON. WEA. REV.,1980)   *
-  ! *                                                             *
-  ! * written by   : GRANDPEIX Jean-Yves, 17/11/98, 12.39.01      *
-  ! * modified by :                                               *
-  ! ***************************************************************
-  ! *
-  ! *Arguments :
-  ! *
-  ! * Input :  P = pressure of level from wich lifting is performed
-  ! *          T = temperature of level P
-  ! *          RR = vapour mixing ratio at level P
-  ! *          RS = vapour saturation mixing ratio at level P
-  ! *
-  ! * Output : PLCL = lifting condensation level
-  ! *          DPLCLDT = derivative of PLCL relative to T
-  ! *          DPLCLDQ = derivative of PLCL relative to R
-  ! *
-  ! cccccccccccccccccccccc
-  ! constantes coherentes avec le modele du Centre Europeen
-  ! RD = 1000.0 * 1.380658E-23 * 6.0221367E+23 / 28.9644
-  ! RV = 1000.0 * 1.380658E-23 * 6.0221367E+23 / 18.0153
-  ! CPD = 3.5 * RD
-  ! CPV = 4.0 * RV
-  ! CL = 4218.0
-  ! CI=2090.0
-  ! CPVMCL=CL-CPV
-  ! CLMCI=CL-CI
-  ! EPS=RD/RV
-  ! ALV0=2.5008E+06
-  ! ALF0=3.34E+05
-
-  ! on utilise les constantes thermo du Centre Europeen: (sb)
-
-  include "YOMCST.h"
-  real :: p,t,rr,rs,plcl,dplcldt,dplcldq,cpd,cpv,cl,cpvmcl,eps,alv0,a,b
-  real :: rh,chi,alv
-
-  cpd = rcpd
-  cpv = rcpv
-  cl = rcw
-  cpvmcl = cl - cpv
-  eps = rd/rv
-  alv0 = rlvtt
-
-
-  ! Bolton formula coefficients :
-  a = 1669.0
-  b = 122.0
-
-  rh = rr/rs
-  chi = t/(a-b*rh-t)
-  plcl = p*(rh**chi)
-
-  alv = alv0 - cpvmcl*(t-273.15)
-
-  ! -- sb: correction:
-  ! DPLCLDQ = PLCL*CHI*( 1./RR - B*CHI/T/RS*ALOG(RH) )
-  dplcldq = plcl*chi*(1./rr+b*chi/t/rs*alog(rh))
-  ! sb --
-
-  dplcldt = plcl*chi*((a-b*rh*(1.+alv/rv/t))/t**2*chi*alog(rh)-alv/rv/t**2)
-
-
-  RETURN
-END SUBROUTINE clift
Index: /LMDZ6/trunk/libf/phylmdiso/clift.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/clift.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/clift.f90	(revision 5268)
@@ -0,0 +1,74 @@
+
+! $Header$
+
+SUBROUTINE clift(p, t, rr, rs, plcl, dplcldt, dplcldq)
+IMPLICIT NONE
+  ! ***************************************************************
+  ! *                                                             *
+  ! * CLIFT : COMPUTE LIFTING CONDENSATION LEVEL AND ITS          *
+  ! *         DERIVATIVES RELATIVE TO T AND R                     *
+  ! *   (WITHIN 0.2% OF FORMULA OF BOLTON, MON. WEA. REV.,1980)   *
+  ! *                                                             *
+  ! * written by   : GRANDPEIX Jean-Yves, 17/11/98, 12.39.01      *
+  ! * modified by :                                               *
+  ! ***************************************************************
+  ! *
+  ! *Arguments :
+  ! *
+  ! * Input :  P = pressure of level from wich lifting is performed
+  ! *          T = temperature of level P
+  ! *          RR = vapour mixing ratio at level P
+  ! *          RS = vapour saturation mixing ratio at level P
+  ! *
+  ! * Output : PLCL = lifting condensation level
+  ! *          DPLCLDT = derivative of PLCL relative to T
+  ! *          DPLCLDQ = derivative of PLCL relative to R
+  ! *
+  ! cccccccccccccccccccccc
+  ! constantes coherentes avec le modele du Centre Europeen
+  ! RD = 1000.0 * 1.380658E-23 * 6.0221367E+23 / 28.9644
+  ! RV = 1000.0 * 1.380658E-23 * 6.0221367E+23 / 18.0153
+  ! CPD = 3.5 * RD
+  ! CPV = 4.0 * RV
+  ! CL = 4218.0
+  ! CI=2090.0
+  ! CPVMCL=CL-CPV
+  ! CLMCI=CL-CI
+  ! EPS=RD/RV
+  ! ALV0=2.5008E+06
+  ! ALF0=3.34E+05
+
+  ! on utilise les constantes thermo du Centre Europeen: (sb)
+
+  include "YOMCST.h"
+  real :: p,t,rr,rs,plcl,dplcldt,dplcldq,cpd,cpv,cl,cpvmcl,eps,alv0,a,b
+  real :: rh,chi,alv
+
+  cpd = rcpd
+  cpv = rcpv
+  cl = rcw
+  cpvmcl = cl - cpv
+  eps = rd/rv
+  alv0 = rlvtt
+
+
+  ! Bolton formula coefficients :
+  a = 1669.0
+  b = 122.0
+
+  rh = rr/rs
+  chi = t/(a-b*rh-t)
+  plcl = p*(rh**chi)
+
+  alv = alv0 - cpvmcl*(t-273.15)
+
+  ! -- sb: correction:
+  ! DPLCLDQ = PLCL*CHI*( 1./RR - B*CHI/T/RS*ALOG(RH) )
+  dplcldq = plcl*chi*(1./rr+b*chi/t/rs*alog(rh))
+  ! sb --
+
+  dplcldt = plcl*chi*((a-b*rh*(1.+alv/rv/t))/t**2*chi*alog(rh)-alv/rv/t**2)
+
+
+  RETURN
+END SUBROUTINE clift
Index: DZ6/trunk/libf/phylmdiso/climb_qbs_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/climb_qbs_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/climb_qbs_mod.F90
Index: /LMDZ6/trunk/libf/phylmdiso/climb_qbs_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/climb_qbs_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/climb_qbs_mod.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/climb_qbs_mod.f90
Index: DZ6/trunk/libf/phylmdiso/climb_wind_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/climb_wind_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/climb_wind_mod.F90
Index: /LMDZ6/trunk/libf/phylmdiso/climb_wind_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/climb_wind_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/climb_wind_mod.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/climb_wind_mod.f90
Index: DZ6/trunk/libf/phylmdiso/clouds_bigauss.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/clouds_bigauss.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/clouds_bigauss.F90
Index: /LMDZ6/trunk/libf/phylmdiso/clouds_bigauss.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/clouds_bigauss.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/clouds_bigauss.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/clouds_bigauss.f90
Index: DZ6/trunk/libf/phylmdiso/clouds_gno.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/clouds_gno.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/clouds_gno.F90
Index: /LMDZ6/trunk/libf/phylmdiso/clouds_gno.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/clouds_gno.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/clouds_gno.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/clouds_gno.f90
Index: DZ6/trunk/libf/phylmdiso/cltrac.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/cltrac.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/cltrac.F90
Index: /LMDZ6/trunk/libf/phylmdiso/cltrac.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/cltrac.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/cltrac.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/cltrac.f90
Index: DZ6/trunk/libf/phylmdiso/cltracrn.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/cltracrn.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/cltracrn.F90
Index: /LMDZ6/trunk/libf/phylmdiso/cltracrn.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/cltracrn.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/cltracrn.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/cltracrn.f90
Index: DZ6/trunk/libf/phylmdiso/cmp_seri_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/cmp_seri_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/cmp_seri_mod.F90
Index: /LMDZ6/trunk/libf/phylmdiso/cmp_seri_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/cmp_seri_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/cmp_seri_mod.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/cmp_seri_mod.f90
Index: DZ6/trunk/libf/phylmdiso/coare30_flux_cnrm_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/coare30_flux_cnrm_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/coare30_flux_cnrm_mod.F90
Index: /LMDZ6/trunk/libf/phylmdiso/coare30_flux_cnrm_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/coare30_flux_cnrm_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/coare30_flux_cnrm_mod.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/coare30_flux_cnrm_mod.f90
Index: DZ6/trunk/libf/phylmdiso/coare_cp_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/coare_cp_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/coare_cp_mod.F90
Index: /LMDZ6/trunk/libf/phylmdiso/coare_cp_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/coare_cp_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/coare_cp_mod.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/coare_cp_mod.f90
Index: DZ6/trunk/libf/phylmdiso/coef_diff_turb_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/coef_diff_turb_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/coef_diff_turb_mod.F90
Index: /LMDZ6/trunk/libf/phylmdiso/coef_diff_turb_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/coef_diff_turb_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/coef_diff_turb_mod.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/coef_diff_turb_mod.f90
Index: DZ6/trunk/libf/phylmdiso/coefcdrag.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/coefcdrag.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/coefcdrag.F90
Index: /LMDZ6/trunk/libf/phylmdiso/coefcdrag.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/coefcdrag.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/coefcdrag.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/coefcdrag.f90
Index: DZ6/trunk/libf/phylmdiso/coefkzmin.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/coefkzmin.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/coefkzmin.F90
Index: /LMDZ6/trunk/libf/phylmdiso/coefkzmin.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/coefkzmin.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/coefkzmin.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/coefkzmin.f90
Index: DZ6/trunk/libf/phylmdiso/conccm.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/conccm.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/conccm.F90
Index: /LMDZ6/trunk/libf/phylmdiso/conccm.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/conccm.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/conccm.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/conccm.f90
Index: DZ6/trunk/libf/phylmdiso/condsurf.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/condsurf.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/condsurf.F90
Index: /LMDZ6/trunk/libf/phylmdiso/condsurf.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/condsurf.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/condsurf.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/condsurf.f90
Index: DZ6/trunk/libf/phylmdiso/conema3.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/conema3.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/conema3.F90
Index: /LMDZ6/trunk/libf/phylmdiso/conema3.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/conema3.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/conema3.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/conema3.f90
Index: DZ6/trunk/libf/phylmdiso/conemav.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/conemav.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/conemav.F90
Index: /LMDZ6/trunk/libf/phylmdiso/conemav.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/conemav.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/conemav.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/conemav.f90
Index: DZ6/trunk/libf/phylmdiso/conf_phys_m.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/conf_phys_m.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/conf_phys_m.F90
Index: /LMDZ6/trunk/libf/phylmdiso/conf_phys_m.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/conf_phys_m.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/conf_phys_m.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/conf_phys_m.f90
Index: DZ6/trunk/libf/phylmdiso/conflx.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/conflx.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/conflx.F90
Index: /LMDZ6/trunk/libf/phylmdiso/conflx.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/conflx.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/conflx.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/conflx.f90
Index: DZ6/trunk/libf/phylmdiso/conlmd.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/conlmd.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/conlmd.F90
Index: /LMDZ6/trunk/libf/phylmdiso/conlmd.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/conlmd.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/conlmd.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/conlmd.f90
Index: DZ6/trunk/libf/phylmdiso/convect1.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/convect1.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/convect1.F90
Index: /LMDZ6/trunk/libf/phylmdiso/convect1.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/convect1.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/convect1.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/convect1.f90
Index: DZ6/trunk/libf/phylmdiso/convect2.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/convect2.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/convect2.F90
Index: /LMDZ6/trunk/libf/phylmdiso/convect2.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/convect2.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/convect2.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/convect2.f90
Index: DZ6/trunk/libf/phylmdiso/convect3.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/convect3.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/convect3.F90
Index: /LMDZ6/trunk/libf/phylmdiso/convect3.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/convect3.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/convect3.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/convect3.f90
Index: DZ6/trunk/libf/phylmdiso/create_etat0_limit_unstruct_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/create_etat0_limit_unstruct_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/create_etat0_limit_unstruct_mod.F90
Index: /LMDZ6/trunk/libf/phylmdiso/create_etat0_limit_unstruct_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/create_etat0_limit_unstruct_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/create_etat0_limit_unstruct_mod.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/create_etat0_limit_unstruct_mod.f90
Index: DZ6/trunk/libf/phylmdiso/create_etat0_unstruct_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/create_etat0_unstruct_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/create_etat0_unstruct_mod.F90
Index: /LMDZ6/trunk/libf/phylmdiso/create_etat0_unstruct_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/create_etat0_unstruct_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/create_etat0_unstruct_mod.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/create_etat0_unstruct_mod.f90
Index: DZ6/trunk/libf/phylmdiso/create_limit_unstruct_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/create_limit_unstruct_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/create_limit_unstruct_mod.F90
Index: /LMDZ6/trunk/libf/phylmdiso/create_limit_unstruct_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/create_limit_unstruct_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/create_limit_unstruct_mod.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/create_limit_unstruct_mod.f90
Index: DZ6/trunk/libf/phylmdiso/ctstar.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/ctstar.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/ctstar.F90
Index: /LMDZ6/trunk/libf/phylmdiso/ctstar.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/ctstar.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/ctstar.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/ctstar.f90
Index: DZ6/trunk/libf/phylmdiso/cv3_buoy.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/cv3_buoy.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/cv3_buoy.F90
Index: /LMDZ6/trunk/libf/phylmdiso/cv3_buoy.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/cv3_buoy.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/cv3_buoy.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/cv3_buoy.f90
Index: DZ6/trunk/libf/phylmdiso/cv3_cine.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/cv3_cine.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/cv3_cine.F90
Index: /LMDZ6/trunk/libf/phylmdiso/cv3_cine.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/cv3_cine.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/cv3_cine.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/cv3_cine.f90
Index: DZ6/trunk/libf/phylmdiso/cv3_crit.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/cv3_crit.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/cv3_crit.F90
Index: /LMDZ6/trunk/libf/phylmdiso/cv3_crit.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/cv3_crit.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/cv3_crit.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/cv3_crit.f90
Index: DZ6/trunk/libf/phylmdiso/cv3_inicp.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/cv3_inicp.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/cv3_inicp.F90
Index: /LMDZ6/trunk/libf/phylmdiso/cv3_inicp.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/cv3_inicp.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/cv3_inicp.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/cv3_inicp.f90
Index: DZ6/trunk/libf/phylmdiso/cv3_inip.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/cv3_inip.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/cv3_inip.F90
Index: /LMDZ6/trunk/libf/phylmdiso/cv3_inip.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/cv3_inip.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/cv3_inip.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/cv3_inip.f90
Index: DZ6/trunk/libf/phylmdiso/cv3_mixscale.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/cv3_mixscale.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/cv3_mixscale.F90
Index: /LMDZ6/trunk/libf/phylmdiso/cv3_mixscale.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/cv3_mixscale.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/cv3_mixscale.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/cv3_mixscale.f90
Index: DZ6/trunk/libf/phylmdiso/cv3p1_closure.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/cv3p1_closure.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/cv3p1_closure.F90
Index: /LMDZ6/trunk/libf/phylmdiso/cv3p1_closure.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/cv3p1_closure.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/cv3p1_closure.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/cv3p1_closure.f90
Index: DZ6/trunk/libf/phylmdiso/cv3p2_closure.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/cv3p2_closure.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/cv3p2_closure.F90
Index: /LMDZ6/trunk/libf/phylmdiso/cv3p2_closure.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/cv3p2_closure.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/cv3p2_closure.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/cv3p2_closure.f90
Index: DZ6/trunk/libf/phylmdiso/cv_routines.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/cv_routines.F90	(revision 5267)
+++ 	(revision )
@@ -1,1713 +1,0 @@
-
-! $Id$
-
-SUBROUTINE cv_param(nd)
-  IMPLICIT NONE
-
-  ! ------------------------------------------------------------
-  ! Set parameters for convectL
-  ! (includes microphysical parameters and parameters that
-  ! control the rate of approach to quasi-equilibrium)
-  ! ------------------------------------------------------------
-
-  ! *** ELCRIT IS THE AUTOCONVERSION THERSHOLD WATER CONTENT (gm/gm) ***
-  ! ***  TLCRIT IS CRITICAL TEMPERATURE BELOW WHICH THE AUTO-        ***
-  ! ***       CONVERSION THRESHOLD IS ASSUMED TO BE ZERO             ***
-  ! ***     (THE AUTOCONVERSION THRESHOLD VARIES LINEARLY            ***
-  ! ***               BETWEEN 0 C AND TLCRIT)                        ***
-  ! ***   ENTP IS THE COEFFICIENT OF MIXING IN THE ENTRAINMENT       ***
-  ! ***                       FORMULATION                            ***
-  ! ***  SIGD IS THE FRACTIONAL AREA COVERED BY UNSATURATED DNDRAFT  ***
-  ! ***  SIGS IS THE FRACTION OF PRECIPITATION FALLING OUTSIDE       ***
-  ! ***                        OF CLOUD                              ***
-  ! ***        OMTRAIN IS THE ASSUMED FALL SPEED (P/s) OF RAIN       ***
-  ! ***     OMTSNOW IS THE ASSUMED FALL SPEED (P/s) OF SNOW          ***
-  ! ***  COEFFR IS A COEFFICIENT GOVERNING THE RATE OF EVAPORATION   ***
-  ! ***                          OF RAIN                             ***
-  ! ***  COEFFS IS A COEFFICIENT GOVERNING THE RATE OF EVAPORATION   ***
-  ! ***                          OF SNOW                             ***
-  ! ***     CU IS THE COEFFICIENT GOVERNING CONVECTIVE MOMENTUM      ***
-  ! ***                         TRANSPORT                            ***
-  ! ***    DTMAX IS THE MAXIMUM NEGATIVE TEMPERATURE PERTURBATION    ***
-  ! ***        A LIFTED PARCEL IS ALLOWED TO HAVE BELOW ITS LFC      ***
-  ! ***    ALPHA AND DAMP ARE PARAMETERS THAT CONTROL THE RATE OF    ***
-  ! ***                 APPROACH TO QUASI-EQUILIBRIUM                ***
-  ! ***   (THEIR STANDARD VALUES ARE  0.20 AND 0.1, RESPECTIVELY)    ***
-  ! ***                   (DAMP MUST BE LESS THAN 1)                 ***
-
-  include "cvparam.h"
-  INTEGER nd
-  CHARACTER (LEN=20) :: modname = 'cv_routines'
-  CHARACTER (LEN=80) :: abort_message
-
-  ! noff: integer limit for convection (nd-noff)
-  ! minorig: First level of convection
-
-  noff = 2
-  minorig = 2
-
-  nl = nd - noff
-  nlp = nl + 1
-  nlm = nl - 1
-
-  elcrit = 0.0011
-  tlcrit = -55.0
-  entp = 1.5
-  sigs = 0.12
-  sigd = 0.05
-  omtrain = 50.0
-  omtsnow = 5.5
-  coeffr = 1.0
-  coeffs = 0.8
-  dtmax = 0.9
-
-  cu = 0.70
-
-  betad = 10.0
-
-  damp = 0.1
-  alpha = 0.2
-
-  delta = 0.01 ! cld
-
-  RETURN
-END SUBROUTINE cv_param
-
-SUBROUTINE cv_prelim(len, nd, ndp1, t, q, p, ph, lv, cpn, tv, gz, h, hm)
-  IMPLICIT NONE
-
-  ! =====================================================================
-  ! --- CALCULATE ARRAYS OF GEOPOTENTIAL, HEAT CAPACITY & STATIC ENERGY
-  ! =====================================================================
-
-  ! inputs:
-  INTEGER len, nd, ndp1
-  REAL t(len, nd), q(len, nd), p(len, nd), ph(len, ndp1)
-
-  ! outputs:
-  REAL lv(len, nd), cpn(len, nd), tv(len, nd)
-  REAL gz(len, nd), h(len, nd), hm(len, nd)
-
-  ! local variables:
-  INTEGER k, i
-  REAL cpx(len, nd)
-
-  include "cvthermo.h"
-  include "cvparam.h"
-
-
-  DO k = 1, nlp
-    DO i = 1, len
-      lv(i, k) = lv0 - clmcpv*(t(i,k)-t0)
-      cpn(i, k) = cpd*(1.0-q(i,k)) + cpv*q(i, k)
-      cpx(i, k) = cpd*(1.0-q(i,k)) + cl*q(i, k)
-      tv(i, k) = t(i, k)*(1.0+q(i,k)*epsim1)
-    END DO
-  END DO
-
-  ! gz = phi at the full levels (same as p).
-
-  DO i = 1, len
-    gz(i, 1) = 0.0
-  END DO
-  DO k = 2, nlp
-    DO i = 1, len
-      gz(i, k) = gz(i, k-1) + hrd*(tv(i,k-1)+tv(i,k))*(p(i,k-1)-p(i,k))/ph(i, &
-        k)
-    END DO
-  END DO
-
-  ! h  = phi + cpT (dry static energy).
-  ! hm = phi + cp(T-Tbase)+Lq
-
-  DO k = 1, nlp
-    DO i = 1, len
-      h(i, k) = gz(i, k) + cpn(i, k)*t(i, k)
-      hm(i, k) = gz(i, k) + cpx(i, k)*(t(i,k)-t(i,1)) + lv(i, k)*q(i, k)
-    END DO
-  END DO
-
-  RETURN
-END SUBROUTINE cv_prelim
-
-SUBROUTINE cv_feed(len, nd, t, q, qs, p, hm, gz, nk, icb, icbmax, iflag, tnk, &
-    qnk, gznk, plcl)
-  IMPLICIT NONE
-
-  ! ================================================================
-  ! Purpose: CONVECTIVE FEED
-  ! ================================================================
-
-  include "cvparam.h"
-
-  ! inputs:
-  INTEGER len, nd
-  REAL t(len, nd), q(len, nd), qs(len, nd), p(len, nd)
-  REAL hm(len, nd), gz(len, nd)
-
-  ! outputs:
-  INTEGER iflag(len), nk(len), icb(len), icbmax
-  REAL tnk(len), qnk(len), gznk(len), plcl(len)
-
-  ! local variables:
-  INTEGER i, k
-  INTEGER ihmin(len)
-  REAL work(len)
-  REAL pnk(len), qsnk(len), rh(len), chi(len)
-
-  ! -------------------------------------------------------------------
-  ! --- Find level of minimum moist static energy
-  ! --- If level of minimum moist static energy coincides with
-  ! --- or is lower than minimum allowable parcel origin level,
-  ! --- set iflag to 6.
-  ! -------------------------------------------------------------------
-
-  DO i = 1, len
-    work(i) = 1.0E12
-    ihmin(i) = nl
-  END DO
-  DO k = 2, nlp
-    DO i = 1, len
-      IF ((hm(i,k)<work(i)) .AND. (hm(i,k)<hm(i,k-1))) THEN
-        work(i) = hm(i, k)
-        ihmin(i) = k
-      END IF
-    END DO
-  END DO
-  DO i = 1, len
-    ihmin(i) = min(ihmin(i), nlm)
-    IF (ihmin(i)<=minorig) THEN
-      iflag(i) = 6
-    END IF
-  END DO
-
-  ! -------------------------------------------------------------------
-  ! --- Find that model level below the level of minimum moist static
-  ! --- energy that has the maximum value of moist static energy
-  ! -------------------------------------------------------------------
-
-  DO i = 1, len
-    work(i) = hm(i, minorig)
-    nk(i) = minorig
-  END DO
-  DO k = minorig + 1, nl
-    DO i = 1, len
-      IF ((hm(i,k)>work(i)) .AND. (k<=ihmin(i))) THEN
-        work(i) = hm(i, k)
-        nk(i) = k
-      END IF
-    END DO
-  END DO
-  ! -------------------------------------------------------------------
-  ! --- Check whether parcel level temperature and specific humidity
-  ! --- are reasonable
-  ! -------------------------------------------------------------------
-  DO i = 1, len
-    IF (((t(i,nk(i))<250.0) .OR. (q(i,nk(i))<=0.0) .OR. (p(i,ihmin(i))< &
-      400.0)) .AND. (iflag(i)==0)) iflag(i) = 7
-  END DO
-  ! -------------------------------------------------------------------
-  ! --- Calculate lifted condensation level of air at parcel origin level
-  ! --- (Within 0.2% of formula of Bolton, MON. WEA. REV.,1980)
-  ! -------------------------------------------------------------------
-  DO i = 1, len
-    tnk(i) = t(i, nk(i))
-    qnk(i) = q(i, nk(i))
-    gznk(i) = gz(i, nk(i))
-    pnk(i) = p(i, nk(i))
-    qsnk(i) = qs(i, nk(i))
-
-    rh(i) = qnk(i)/qsnk(i)
-    rh(i) = min(1.0, rh(i))
-    chi(i) = tnk(i)/(1669.0-122.0*rh(i)-tnk(i))
-    plcl(i) = pnk(i)*(rh(i)**chi(i))
-    IF (((plcl(i)<200.0) .OR. (plcl(i)>=2000.0)) .AND. (iflag(i)==0)) iflag(i &
-      ) = 8
-  END DO
-  ! -------------------------------------------------------------------
-  ! --- Calculate first level above lcl (=icb)
-  ! -------------------------------------------------------------------
-  DO i = 1, len
-    icb(i) = nlm
-  END DO
-
-  DO k = minorig, nl
-    DO i = 1, len
-      IF ((k>=(nk(i)+1)) .AND. (p(i,k)<plcl(i))) icb(i) = min(icb(i), k)
-    END DO
-  END DO
-
-  DO i = 1, len
-    IF ((icb(i)>=nlm) .AND. (iflag(i)==0)) iflag(i) = 9
-  END DO
-
-  ! Compute icbmax.
-
-  icbmax = 2
-  DO i = 1, len
-    icbmax = max(icbmax, icb(i))
-  END DO
-
-  RETURN
-END SUBROUTINE cv_feed
-
-SUBROUTINE cv_undilute1(len, nd, t, q, qs, gz, p, nk, icb, icbmax, tp, tvp, &
-    clw)
-  IMPLICIT NONE
-
-  include "cvthermo.h"
-  include "cvparam.h"
-
-  ! inputs:
-  INTEGER len, nd
-  INTEGER nk(len), icb(len), icbmax
-  REAL t(len, nd), q(len, nd), qs(len, nd), gz(len, nd)
-  REAL p(len, nd)
-
-  ! outputs:
-  REAL tp(len, nd), tvp(len, nd), clw(len, nd)
-
-  ! local variables:
-  INTEGER i, k
-  REAL tg, qg, alv, s, ahg, tc, denom, es, rg
-  REAL ah0(len), cpp(len)
-  REAL tnk(len), qnk(len), gznk(len), ticb(len), gzicb(len)
-
-  ! -------------------------------------------------------------------
-  ! --- Calculates the lifted parcel virtual temperature at nk,
-  ! --- the actual temperature, and the adiabatic
-  ! --- liquid water content. The procedure is to solve the equation.
-  ! cp*tp+L*qp+phi=cp*tnk+L*qnk+gznk.
-  ! -------------------------------------------------------------------
-
-  DO i = 1, len
-    tnk(i) = t(i, nk(i))
-    qnk(i) = q(i, nk(i))
-    gznk(i) = gz(i, nk(i))
-    ticb(i) = t(i, icb(i))
-    gzicb(i) = gz(i, icb(i))
-  END DO
-
-  ! ***  Calculate certain parcel quantities, including static energy   ***
-
-  DO i = 1, len
-    ah0(i) = (cpd*(1.-qnk(i))+cl*qnk(i))*tnk(i) + qnk(i)*(lv0-clmcpv*(tnk(i)- &
-      273.15)) + gznk(i)
-    cpp(i) = cpd*(1.-qnk(i)) + qnk(i)*cpv
-  END DO
-
-  ! ***   Calculate lifted parcel quantities below cloud base   ***
-
-  DO k = minorig, icbmax - 1
-    DO i = 1, len
-      tp(i, k) = tnk(i) - (gz(i,k)-gznk(i))/cpp(i)
-      tvp(i, k) = tp(i, k)*(1.+qnk(i)*epsi)
-    END DO
-  END DO
-
-  ! ***  Find lifted parcel quantities above cloud base    ***
-
-  DO i = 1, len
-    tg = ticb(i)
-    qg = qs(i, icb(i))
-    alv = lv0 - clmcpv*(ticb(i)-t0)
-
-    ! First iteration.
-
-    s = cpd + alv*alv*qg/(rrv*ticb(i)*ticb(i))
-    s = 1./s
-    ahg = cpd*tg + (cl-cpd)*qnk(i)*ticb(i) + alv*qg + gzicb(i)
-    tg = tg + s*(ah0(i)-ahg)
-    tg = max(tg, 35.0)
-    tc = tg - t0
-    denom = 243.5 + tc
-    IF (tc>=0.0) THEN
-      es = 6.112*exp(17.67*tc/denom)
-    ELSE
-      es = exp(23.33086-6111.72784/tg+0.15215*log(tg))
-    END IF
-    qg = eps*es/(p(i,icb(i))-es*(1.-eps))
-
-    ! Second iteration.
-
-    s = cpd + alv*alv*qg/(rrv*ticb(i)*ticb(i))
-    s = 1./s
-    ahg = cpd*tg + (cl-cpd)*qnk(i)*ticb(i) + alv*qg + gzicb(i)
-    tg = tg + s*(ah0(i)-ahg)
-    tg = max(tg, 35.0)
-    tc = tg - t0
-    denom = 243.5 + tc
-    IF (tc>=0.0) THEN
-      es = 6.112*exp(17.67*tc/denom)
-    ELSE
-      es = exp(23.33086-6111.72784/tg+0.15215*log(tg))
-    END IF
-    qg = eps*es/(p(i,icb(i))-es*(1.-eps))
-
-    alv = lv0 - clmcpv*(ticb(i)-273.15)
-    tp(i, icb(i)) = (ah0(i)-(cl-cpd)*qnk(i)*ticb(i)-gz(i,icb(i))-alv*qg)/cpd
-    clw(i, icb(i)) = qnk(i) - qg
-    clw(i, icb(i)) = max(0.0, clw(i,icb(i)))
-    rg = qg/(1.-qnk(i))
-    tvp(i, icb(i)) = tp(i, icb(i))*(1.+rg*epsi)
-  END DO
-
-  DO k = minorig, icbmax
-    DO i = 1, len
-      tvp(i, k) = tvp(i, k) - tp(i, k)*qnk(i)
-    END DO
-  END DO
-
-  RETURN
-END SUBROUTINE cv_undilute1
-
-SUBROUTINE cv_trigger(len, nd, icb, cbmf, tv, tvp, iflag)
-  IMPLICIT NONE
-
-  ! -------------------------------------------------------------------
-  ! --- Test for instability.
-  ! --- If there was no convection at last time step and parcel
-  ! --- is stable at icb, then set iflag to 4.
-  ! -------------------------------------------------------------------
-
-  include "cvparam.h"
-
-  ! inputs:
-  INTEGER len, nd, icb(len)
-  REAL cbmf(len), tv(len, nd), tvp(len, nd)
-
-  ! outputs:
-  INTEGER iflag(len) ! also an input
-
-  ! local variables:
-  INTEGER i
-
-
-  DO i = 1, len
-    IF ((cbmf(i)==0.0) .AND. (iflag(i)==0) .AND. (tvp(i, &
-      icb(i))<=(tv(i,icb(i))-dtmax))) iflag(i) = 4
-  END DO
-
-  RETURN
-END SUBROUTINE cv_trigger
-
-SUBROUTINE cv_compress(len, nloc, ncum, nd, iflag1, nk1, icb1, cbmf1, plcl1, &
-    tnk1, qnk1, gznk1, t1, q1, qs1, u1, v1, gz1, h1, lv1, cpn1, p1, ph1, tv1, &
-    tp1, tvp1, clw1, iflag, nk, icb, cbmf, plcl, tnk, qnk, gznk, t, q, qs, u, &
-    v, gz, h, lv, cpn, p, ph, tv, tp, tvp, clw, dph)
-  USE print_control_mod, ONLY: lunout
-  IMPLICIT NONE
-
-  include "cvparam.h"
-
-  ! inputs:
-  INTEGER len, ncum, nd, nloc
-  INTEGER iflag1(len), nk1(len), icb1(len)
-  REAL cbmf1(len), plcl1(len), tnk1(len), qnk1(len), gznk1(len)
-  REAL t1(len, nd), q1(len, nd), qs1(len, nd), u1(len, nd), v1(len, nd)
-  REAL gz1(len, nd), h1(len, nd), lv1(len, nd), cpn1(len, nd)
-  REAL p1(len, nd), ph1(len, nd+1), tv1(len, nd), tp1(len, nd)
-  REAL tvp1(len, nd), clw1(len, nd)
-
-  ! outputs:
-  INTEGER iflag(nloc), nk(nloc), icb(nloc)
-  REAL cbmf(nloc), plcl(nloc), tnk(nloc), qnk(nloc), gznk(nloc)
-  REAL t(nloc, nd), q(nloc, nd), qs(nloc, nd), u(nloc, nd), v(nloc, nd)
-  REAL gz(nloc, nd), h(nloc, nd), lv(nloc, nd), cpn(nloc, nd)
-  REAL p(nloc, nd), ph(nloc, nd+1), tv(nloc, nd), tp(nloc, nd)
-  REAL tvp(nloc, nd), clw(nloc, nd)
-  REAL dph(nloc, nd)
-
-  ! local variables:
-  INTEGER i, k, nn
-  CHARACTER (LEN=20) :: modname = 'cv_compress'
-  CHARACTER (LEN=80) :: abort_message
-
-
-  DO k = 1, nl + 1
-    nn = 0
-    DO i = 1, len
-      IF (iflag1(i)==0) THEN
-        nn = nn + 1
-        t(nn, k) = t1(i, k)
-        q(nn, k) = q1(i, k)
-        qs(nn, k) = qs1(i, k)
-        u(nn, k) = u1(i, k)
-        v(nn, k) = v1(i, k)
-        gz(nn, k) = gz1(i, k)
-        h(nn, k) = h1(i, k)
-        lv(nn, k) = lv1(i, k)
-        cpn(nn, k) = cpn1(i, k)
-        p(nn, k) = p1(i, k)
-        ph(nn, k) = ph1(i, k)
-        tv(nn, k) = tv1(i, k)
-        tp(nn, k) = tp1(i, k)
-        tvp(nn, k) = tvp1(i, k)
-        clw(nn, k) = clw1(i, k)
-      END IF
-    END DO
-  END DO
-
-  IF (nn/=ncum) THEN
-    WRITE (lunout, *) 'strange! nn not equal to ncum: ', nn, ncum
-    abort_message = ''
-    CALL abort_physic(modname, abort_message, 1)
-  END IF
-
-  nn = 0
-  DO i = 1, len
-    IF (iflag1(i)==0) THEN
-      nn = nn + 1
-      cbmf(nn) = cbmf1(i)
-      plcl(nn) = plcl1(i)
-      tnk(nn) = tnk1(i)
-      qnk(nn) = qnk1(i)
-      gznk(nn) = gznk1(i)
-      nk(nn) = nk1(i)
-      icb(nn) = icb1(i)
-      iflag(nn) = iflag1(i)
-    END IF
-  END DO
-
-  DO k = 1, nl
-    DO i = 1, ncum
-      dph(i, k) = ph(i, k) - ph(i, k+1)
-    END DO
-  END DO
-
-  RETURN
-END SUBROUTINE cv_compress
-
-SUBROUTINE cv_undilute2(nloc, ncum, nd, icb, nk, tnk, qnk, gznk, t, q, qs, &
-    gz, p, dph, h, tv, lv, inb, inb1, tp, tvp, clw, hp, ep, sigp, frac)
-  IMPLICIT NONE
-
-  ! ---------------------------------------------------------------------
-  ! Purpose:
-  ! FIND THE REST OF THE LIFTED PARCEL TEMPERATURES
-  ! &
-  ! COMPUTE THE PRECIPITATION EFFICIENCIES AND THE
-  ! FRACTION OF PRECIPITATION FALLING OUTSIDE OF CLOUD
-  ! &
-  ! FIND THE LEVEL OF NEUTRAL BUOYANCY
-  ! ---------------------------------------------------------------------
-
-  include "cvthermo.h"
-  include "cvparam.h"
-
-  ! inputs:
-  INTEGER ncum, nd, nloc
-  INTEGER icb(nloc), nk(nloc)
-  REAL t(nloc, nd), q(nloc, nd), qs(nloc, nd), gz(nloc, nd)
-  REAL p(nloc, nd), dph(nloc, nd)
-  REAL tnk(nloc), qnk(nloc), gznk(nloc)
-  REAL lv(nloc, nd), tv(nloc, nd), h(nloc, nd)
-
-  ! outputs:
-  INTEGER inb(nloc), inb1(nloc)
-  REAL tp(nloc, nd), tvp(nloc, nd), clw(nloc, nd)
-  REAL ep(nloc, nd), sigp(nloc, nd), hp(nloc, nd)
-  REAL frac(nloc)
-
-  ! local variables:
-  INTEGER i, k
-  REAL tg, qg, ahg, alv, s, tc, es, denom, rg, tca, elacrit
-  REAL by, defrac
-  REAL ah0(nloc), cape(nloc), capem(nloc), byp(nloc)
-  LOGICAL lcape(nloc)
-
-  ! =====================================================================
-  ! --- SOME INITIALIZATIONS
-  ! =====================================================================
-
-  DO k = 1, nl
-    DO i = 1, ncum
-      ep(i, k) = 0.0
-      sigp(i, k) = sigs
-    END DO
-  END DO
-
-  ! =====================================================================
-  ! --- FIND THE REST OF THE LIFTED PARCEL TEMPERATURES
-  ! =====================================================================
-
-  ! ---       The procedure is to solve the equation.
-  ! cp*tp+L*qp+phi=cp*tnk+L*qnk+gznk.
-
-  ! ***  Calculate certain parcel quantities, including static energy   ***
-
-
-  DO i = 1, ncum
-    ah0(i) = (cpd*(1.-qnk(i))+cl*qnk(i))*tnk(i) + qnk(i)*(lv0-clmcpv*(tnk(i)- &
-      t0)) + gznk(i)
-  END DO
-
-
-  ! ***  Find lifted parcel quantities above cloud base    ***
-
-
-  DO k = minorig + 1, nl
-    DO i = 1, ncum
-      IF (k>=(icb(i)+1)) THEN
-        tg = t(i, k)
-        qg = qs(i, k)
-        alv = lv0 - clmcpv*(t(i,k)-t0)
-
-        ! First iteration.
-
-        s = cpd + alv*alv*qg/(rrv*t(i,k)*t(i,k))
-        s = 1./s
-        ahg = cpd*tg + (cl-cpd)*qnk(i)*t(i, k) + alv*qg + gz(i, k)
-        tg = tg + s*(ah0(i)-ahg)
-        tg = max(tg, 35.0)
-        tc = tg - t0
-        denom = 243.5 + tc
-        IF (tc>=0.0) THEN
-          es = 6.112*exp(17.67*tc/denom)
-        ELSE
-          es = exp(23.33086-6111.72784/tg+0.15215*log(tg))
-        END IF
-        qg = eps*es/(p(i,k)-es*(1.-eps))
-
-        ! Second iteration.
-
-        s = cpd + alv*alv*qg/(rrv*t(i,k)*t(i,k))
-        s = 1./s
-        ahg = cpd*tg + (cl-cpd)*qnk(i)*t(i, k) + alv*qg + gz(i, k)
-        tg = tg + s*(ah0(i)-ahg)
-        tg = max(tg, 35.0)
-        tc = tg - t0
-        denom = 243.5 + tc
-        IF (tc>=0.0) THEN
-          es = 6.112*exp(17.67*tc/denom)
-        ELSE
-          es = exp(23.33086-6111.72784/tg+0.15215*log(tg))
-        END IF
-        qg = eps*es/(p(i,k)-es*(1.-eps))
-
-        alv = lv0 - clmcpv*(t(i,k)-t0)
-        ! print*,'cpd dans convect2 ',cpd
-        ! print*,'tp(i,k),ah0(i),cl,cpd,qnk(i),t(i,k),gz(i,k),alv,qg,cpd'
-        ! print*,tp(i,k),ah0(i),cl,cpd,qnk(i),t(i,k),gz(i,k),alv,qg,cpd
-        tp(i, k) = (ah0(i)-(cl-cpd)*qnk(i)*t(i,k)-gz(i,k)-alv*qg)/cpd
-        ! if (.not.cpd.gt.1000.) then
-        ! print*,'CPD=',cpd
-        ! stop
-        ! endif
-        clw(i, k) = qnk(i) - qg
-        clw(i, k) = max(0.0, clw(i,k))
-        rg = qg/(1.-qnk(i))
-        tvp(i, k) = tp(i, k)*(1.+rg*epsi)
-      END IF
-    END DO
-  END DO
-
-  ! =====================================================================
-  ! --- SET THE PRECIPITATION EFFICIENCIES AND THE FRACTION OF
-  ! --- PRECIPITATION FALLING OUTSIDE OF CLOUD
-  ! --- THESE MAY BE FUNCTIONS OF TP(I), P(I) AND CLW(I)
-  ! =====================================================================
-
-  DO k = minorig + 1, nl
-    DO i = 1, ncum
-      IF (k>=(nk(i)+1)) THEN
-        tca = tp(i, k) - t0
-        IF (tca>=0.0) THEN
-          elacrit = elcrit
-        ELSE
-          elacrit = elcrit*(1.0-tca/tlcrit)
-        END IF
-        elacrit = max(elacrit, 0.0)
-        ep(i, k) = 1.0 - elacrit/max(clw(i,k), 1.0E-8)
-        ep(i, k) = max(ep(i,k), 0.0)
-        ep(i, k) = min(ep(i,k), 1.0)
-        sigp(i, k) = sigs
-      END IF
-    END DO
-  END DO
-
-  ! =====================================================================
-  ! --- CALCULATE VIRTUAL TEMPERATURE AND LIFTED PARCEL
-  ! --- VIRTUAL TEMPERATURE
-  ! =====================================================================
-
-  DO k = minorig + 1, nl
-    DO i = 1, ncum
-      IF (k>=(icb(i)+1)) THEN
-        tvp(i, k) = tvp(i, k)*(1.0-qnk(i)+ep(i,k)*clw(i,k))
-        ! print*,'i,k,tvp(i,k),qnk(i),ep(i,k),clw(i,k)'
-        ! print*, i,k,tvp(i,k),qnk(i),ep(i,k),clw(i,k)
-      END IF
-    END DO
-  END DO
-  DO i = 1, ncum
-    tvp(i, nlp) = tvp(i, nl) - (gz(i,nlp)-gz(i,nl))/cpd
-  END DO
-
-  ! =====================================================================
-  ! --- FIND THE FIRST MODEL LEVEL (INB1) ABOVE THE PARCEL'S
-  ! --- HIGHEST LEVEL OF NEUTRAL BUOYANCY
-  ! --- AND THE HIGHEST LEVEL OF POSITIVE CAPE (INB)
-  ! =====================================================================
-
-  DO i = 1, ncum
-    cape(i) = 0.0
-    capem(i) = 0.0
-    inb(i) = icb(i) + 1
-    inb1(i) = inb(i)
-  END DO
-
-  ! Originial Code
-
-  ! do 530 k=minorig+1,nl-1
-  ! do 520 i=1,ncum
-  ! if(k.ge.(icb(i)+1))then
-  ! by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k)
-  ! byp=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1)
-  ! cape(i)=cape(i)+by
-  ! if(by.ge.0.0)inb1(i)=k+1
-  ! if(cape(i).gt.0.0)then
-  ! inb(i)=k+1
-  ! capem(i)=cape(i)
-  ! endif
-  ! endif
-  ! 520    continue
-  ! 530  continue
-  ! do 540 i=1,ncum
-  ! byp=(tvp(i,nl)-tv(i,nl))*dph(i,nl)/p(i,nl)
-  ! cape(i)=capem(i)+byp
-  ! defrac=capem(i)-cape(i)
-  ! defrac=max(defrac,0.001)
-  ! frac(i)=-cape(i)/defrac
-  ! frac(i)=min(frac(i),1.0)
-  ! frac(i)=max(frac(i),0.0)
-  ! 540   continue
-
-  ! K Emanuel fix
-
-  ! call zilch(byp,ncum)
-  ! do 530 k=minorig+1,nl-1
-  ! do 520 i=1,ncum
-  ! if(k.ge.(icb(i)+1))then
-  ! by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k)
-  ! cape(i)=cape(i)+by
-  ! if(by.ge.0.0)inb1(i)=k+1
-  ! if(cape(i).gt.0.0)then
-  ! inb(i)=k+1
-  ! capem(i)=cape(i)
-  ! byp(i)=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1)
-  ! endif
-  ! endif
-  ! 520    continue
-  ! 530  continue
-  ! do 540 i=1,ncum
-  ! inb(i)=max(inb(i),inb1(i))
-  ! cape(i)=capem(i)+byp(i)
-  ! defrac=capem(i)-cape(i)
-  ! defrac=max(defrac,0.001)
-  ! frac(i)=-cape(i)/defrac
-  ! frac(i)=min(frac(i),1.0)
-  ! frac(i)=max(frac(i),0.0)
-  ! 540   continue
-
-  ! J Teixeira fix
-
-  CALL zilch(byp, ncum)
-  DO i = 1, ncum
-    lcape(i) = .TRUE.
-  END DO
-  DO k = minorig + 1, nl - 1
-    DO i = 1, ncum
-      IF (cape(i)<0.0) lcape(i) = .FALSE.
-      IF ((k>=(icb(i)+1)) .AND. lcape(i)) THEN
-        by = (tvp(i,k)-tv(i,k))*dph(i, k)/p(i, k)
-        byp(i) = (tvp(i,k+1)-tv(i,k+1))*dph(i, k+1)/p(i, k+1)
-        cape(i) = cape(i) + by
-        IF (by>=0.0) inb1(i) = k + 1
-        IF (cape(i)>0.0) THEN
-          inb(i) = k + 1
-          capem(i) = cape(i)
-        END IF
-      END IF
-    END DO
-  END DO
-  DO i = 1, ncum
-    cape(i) = capem(i) + byp(i)
-    defrac = capem(i) - cape(i)
-    defrac = max(defrac, 0.001)
-    frac(i) = -cape(i)/defrac
-    frac(i) = min(frac(i), 1.0)
-    frac(i) = max(frac(i), 0.0)
-  END DO
-
-  ! =====================================================================
-  ! ---   CALCULATE LIQUID WATER STATIC ENERGY OF LIFTED PARCEL
-  ! =====================================================================
-
-  ! initialization:
-  DO i = 1, ncum*nlp
-    hp(i, 1) = h(i, 1)
-  END DO
-
-  DO k = minorig + 1, nl
-    DO i = 1, ncum
-      IF ((k>=icb(i)) .AND. (k<=inb(i))) THEN
-        hp(i, k) = h(i, nk(i)) + (lv(i,k)+(cpd-cpv)*t(i,k))*ep(i, k)*clw(i, k &
-          )
-      END IF
-    END DO
-  END DO
-
-  RETURN
-END SUBROUTINE cv_undilute2
-
-SUBROUTINE cv_closure(nloc, ncum, nd, nk, icb, tv, tvp, p, ph, dph, plcl, &
-    cpn, iflag, cbmf)
-  IMPLICIT NONE
-
-  ! inputs:
-  INTEGER ncum, nd, nloc
-  INTEGER nk(nloc), icb(nloc)
-  REAL tv(nloc, nd), tvp(nloc, nd), p(nloc, nd), dph(nloc, nd)
-  REAL ph(nloc, nd+1) ! caution nd instead ndp1 to be consistent...
-  REAL plcl(nloc), cpn(nloc, nd)
-
-  ! outputs:
-  INTEGER iflag(nloc)
-  REAL cbmf(nloc) ! also an input
-
-  ! local variables:
-  INTEGER i, k, icbmax
-  REAL dtpbl(nloc), dtmin(nloc), tvpplcl(nloc), tvaplcl(nloc)
-  REAL work(nloc)
-
-  include "cvthermo.h"
-  include "cvparam.h"
-
-  ! -------------------------------------------------------------------
-  ! Compute icbmax.
-  ! -------------------------------------------------------------------
-
-  icbmax = 2
-  DO i = 1, ncum
-    icbmax = max(icbmax, icb(i))
-  END DO
-
-  ! =====================================================================
-  ! ---  CALCULATE CLOUD BASE MASS FLUX
-  ! =====================================================================
-
-  ! tvpplcl = parcel temperature lifted adiabatically from level
-  ! icb-1 to the LCL.
-  ! tvaplcl = virtual temperature at the LCL.
-
-  DO i = 1, ncum
-    dtpbl(i) = 0.0
-    tvpplcl(i) = tvp(i, icb(i)-1) - rrd*tvp(i, icb(i)-1)*(p(i,icb(i)-1)-plcl( &
-      i))/(cpn(i,icb(i)-1)*p(i,icb(i)-1))
-    tvaplcl(i) = tv(i, icb(i)) + (tvp(i,icb(i))-tvp(i,icb(i)+1))*(plcl(i)-p(i &
-      ,icb(i)))/(p(i,icb(i))-p(i,icb(i)+1))
-  END DO
-
-  ! -------------------------------------------------------------------
-  ! --- Interpolate difference between lifted parcel and
-  ! --- environmental temperatures to lifted condensation level
-  ! -------------------------------------------------------------------
-
-  ! dtpbl = average of tvp-tv in the PBL (k=nk to icb-1).
-
-  DO k = minorig, icbmax
-    DO i = 1, ncum
-      IF ((k>=nk(i)) .AND. (k<=(icb(i)-1))) THEN
-        dtpbl(i) = dtpbl(i) + (tvp(i,k)-tv(i,k))*dph(i, k)
-      END IF
-    END DO
-  END DO
-  DO i = 1, ncum
-    dtpbl(i) = dtpbl(i)/(ph(i,nk(i))-ph(i,icb(i)))
-    dtmin(i) = tvpplcl(i) - tvaplcl(i) + dtmax + dtpbl(i)
-  END DO
-
-  ! -------------------------------------------------------------------
-  ! --- Adjust cloud base mass flux
-  ! -------------------------------------------------------------------
-
-  DO i = 1, ncum
-    work(i) = cbmf(i)
-    cbmf(i) = max(0.0, (1.0-damp)*cbmf(i)+0.1*alpha*dtmin(i))
-    IF ((work(i)==0.0) .AND. (cbmf(i)==0.0)) THEN
-      iflag(i) = 3
-    END IF
-  END DO
-
-  RETURN
-END SUBROUTINE cv_closure
-
-SUBROUTINE cv_mixing(nloc, ncum, nd, icb, nk, inb, inb1, ph, t, q, qs, u, v, &
-    h, lv, qnk, hp, tv, tvp, ep, clw, cbmf, m, ment, qent, uent, vent, nent, &
-    sij, elij)
-  IMPLICIT NONE
-
-  include "cvthermo.h"
-  include "cvparam.h"
-
-  ! inputs:
-  INTEGER ncum, nd, nloc
-  INTEGER icb(nloc), inb(nloc), inb1(nloc), nk(nloc)
-  REAL cbmf(nloc), qnk(nloc)
-  REAL ph(nloc, nd+1)
-  REAL t(nloc, nd), q(nloc, nd), qs(nloc, nd), lv(nloc, nd)
-  REAL u(nloc, nd), v(nloc, nd), h(nloc, nd), hp(nloc, nd)
-  REAL tv(nloc, nd), tvp(nloc, nd), ep(nloc, nd), clw(nloc, nd)
-
-  ! outputs:
-  INTEGER nent(nloc, nd)
-  REAL m(nloc, nd), ment(nloc, nd, nd), qent(nloc, nd, nd)
-  REAL uent(nloc, nd, nd), vent(nloc, nd, nd)
-  REAL sij(nloc, nd, nd), elij(nloc, nd, nd)
-
-  ! local variables:
-  INTEGER i, j, k, ij
-  INTEGER num1, num2
-  REAL dbo, qti, bf2, anum, denom, dei, altem, cwat, stemp
-  REAL alt, qp1, smid, sjmin, sjmax, delp, delm
-  REAL work(nloc), asij(nloc), smin(nloc), scrit(nloc)
-  REAL bsum(nloc, nd)
-  LOGICAL lwork(nloc)
-
-  ! =====================================================================
-  ! --- INITIALIZE VARIOUS ARRAYS USED IN THE COMPUTATIONS
-  ! =====================================================================
-
-  DO i = 1, ncum*nlp
-    nent(i, 1) = 0
-    m(i, 1) = 0.0
-  END DO
-
-  DO k = 1, nlp
-    DO j = 1, nlp
-      DO i = 1, ncum
-        qent(i, k, j) = q(i, j)
-        uent(i, k, j) = u(i, j)
-        vent(i, k, j) = v(i, j)
-        elij(i, k, j) = 0.0
-        ment(i, k, j) = 0.0
-        sij(i, k, j) = 0.0
-      END DO
-    END DO
-  END DO
-
-  ! -------------------------------------------------------------------
-  ! --- Calculate rates of mixing,  m(i)
-  ! -------------------------------------------------------------------
-
-  CALL zilch(work, ncum)
-
-  DO j = minorig + 1, nl
-    DO i = 1, ncum
-      IF ((j>=(icb(i)+1)) .AND. (j<=inb(i))) THEN
-        k = min(j, inb1(i))
-        dbo = abs(tv(i,k+1)-tvp(i,k+1)-tv(i,k-1)+tvp(i,k-1)) + &
-          entp*0.04*(ph(i,k)-ph(i,k+1))
-        work(i) = work(i) + dbo
-        m(i, j) = cbmf(i)*dbo
-      END IF
-    END DO
-  END DO
-  DO k = minorig + 1, nl
-    DO i = 1, ncum
-      IF ((k>=(icb(i)+1)) .AND. (k<=inb(i))) THEN
-        m(i, k) = m(i, k)/work(i)
-      END IF
-    END DO
-  END DO
-
-
-  ! =====================================================================
-  ! --- CALCULATE ENTRAINED AIR MASS FLUX (ment), TOTAL WATER MIXING
-  ! --- RATIO (QENT), TOTAL CONDENSED WATER (elij), AND MIXING
-  ! --- FRACTION (sij)
-  ! =====================================================================
-
-
-  DO i = minorig + 1, nl
-    DO j = minorig + 1, nl
-      DO ij = 1, ncum
-        IF ((i>=(icb(ij)+1)) .AND. (j>=icb(ij)) .AND. (i<=inb(ij)) .AND. (j<= &
-            inb(ij))) THEN
-          qti = qnk(ij) - ep(ij, i)*clw(ij, i)
-          bf2 = 1. + lv(ij, j)*lv(ij, j)*qs(ij, j)/(rrv*t(ij,j)*t(ij,j)*cpd)
-          anum = h(ij, j) - hp(ij, i) + (cpv-cpd)*t(ij, j)*(qti-q(ij,j))
-          denom = h(ij, i) - hp(ij, i) + (cpd-cpv)*(q(ij,i)-qti)*t(ij, j)
-          dei = denom
-          IF (abs(dei)<0.01) dei = 0.01
-          sij(ij, i, j) = anum/dei
-          sij(ij, i, i) = 1.0
-          altem = sij(ij, i, j)*q(ij, i) + (1.-sij(ij,i,j))*qti - qs(ij, j)
-          altem = altem/bf2
-          cwat = clw(ij, j)*(1.-ep(ij,j))
-          stemp = sij(ij, i, j)
-          IF ((stemp<0.0 .OR. stemp>1.0 .OR. altem>cwat) .AND. j>i) THEN
-            anum = anum - lv(ij, j)*(qti-qs(ij,j)-cwat*bf2)
-            denom = denom + lv(ij, j)*(q(ij,i)-qti)
-            IF (abs(denom)<0.01) denom = 0.01
-            sij(ij, i, j) = anum/denom
-            altem = sij(ij, i, j)*q(ij, i) + (1.-sij(ij,i,j))*qti - qs(ij, j)
-            altem = altem - (bf2-1.)*cwat
-          END IF
-          IF (sij(ij,i,j)>0.0 .AND. sij(ij,i,j)<0.9) THEN
-            qent(ij, i, j) = sij(ij, i, j)*q(ij, i) + (1.-sij(ij,i,j))*qti
-            uent(ij, i, j) = sij(ij, i, j)*u(ij, i) + &
-              (1.-sij(ij,i,j))*u(ij, nk(ij))
-            vent(ij, i, j) = sij(ij, i, j)*v(ij, i) + &
-              (1.-sij(ij,i,j))*v(ij, nk(ij))
-            elij(ij, i, j) = altem
-            elij(ij, i, j) = max(0.0, elij(ij,i,j))
-            ment(ij, i, j) = m(ij, i)/(1.-sij(ij,i,j))
-            nent(ij, i) = nent(ij, i) + 1
-          END IF
-          sij(ij, i, j) = max(0.0, sij(ij,i,j))
-          sij(ij, i, j) = min(1.0, sij(ij,i,j))
-        END IF
-      END DO
-    END DO
-
-    ! ***   If no air can entrain at level i assume that updraft detrains
-    ! ***
-    ! ***   at that level and calculate detrained air flux and properties
-    ! ***
-
-    DO ij = 1, ncum
-      IF ((i>=(icb(ij)+1)) .AND. (i<=inb(ij)) .AND. (nent(ij,i)==0)) THEN
-        ment(ij, i, i) = m(ij, i)
-        qent(ij, i, i) = q(ij, nk(ij)) - ep(ij, i)*clw(ij, i)
-        uent(ij, i, i) = u(ij, nk(ij))
-        vent(ij, i, i) = v(ij, nk(ij))
-        elij(ij, i, i) = clw(ij, i)
-        sij(ij, i, i) = 1.0
-      END IF
-    END DO
-  END DO
-
-  DO i = 1, ncum
-    sij(i, inb(i), inb(i)) = 1.0
-  END DO
-
-  ! =====================================================================
-  ! ---  NORMALIZE ENTRAINED AIR MASS FLUXES
-  ! ---  TO REPRESENT EQUAL PROBABILITIES OF MIXING
-  ! =====================================================================
-
-  CALL zilch(bsum, ncum*nlp)
-  DO ij = 1, ncum
-    lwork(ij) = .FALSE.
-  END DO
-  DO i = minorig + 1, nl
-
-    num1 = 0
-    DO ij = 1, ncum
-      IF ((i>=icb(ij)+1) .AND. (i<=inb(ij))) num1 = num1 + 1
-    END DO
-    IF (num1<=0) GO TO 789
-
-    DO ij = 1, ncum
-      IF ((i>=icb(ij)+1) .AND. (i<=inb(ij))) THEN
-        lwork(ij) = (nent(ij,i)/=0)
-        qp1 = q(ij, nk(ij)) - ep(ij, i)*clw(ij, i)
-        anum = h(ij, i) - hp(ij, i) - lv(ij, i)*(qp1-qs(ij,i))
-        denom = h(ij, i) - hp(ij, i) + lv(ij, i)*(q(ij,i)-qp1)
-        IF (abs(denom)<0.01) denom = 0.01
-        scrit(ij) = anum/denom
-        alt = qp1 - qs(ij, i) + scrit(ij)*(q(ij,i)-qp1)
-        IF (scrit(ij)<0.0 .OR. alt<0.0) scrit(ij) = 1.0
-        asij(ij) = 0.0
-        smin(ij) = 1.0
-      END IF
-    END DO
-    DO j = minorig, nl
-
-      num2 = 0
-      DO ij = 1, ncum
-        IF ((i>=icb(ij)+1) .AND. (i<=inb(ij)) .AND. (j>=icb( &
-          ij)) .AND. (j<=inb(ij)) .AND. lwork(ij)) num2 = num2 + 1
-      END DO
-      IF (num2<=0) GO TO 783
-
-      DO ij = 1, ncum
-        IF ((i>=icb(ij)+1) .AND. (i<=inb(ij)) .AND. (j>=icb( &
-            ij)) .AND. (j<=inb(ij)) .AND. lwork(ij)) THEN
-          IF (sij(ij,i,j)>0.0 .AND. sij(ij,i,j)<0.9) THEN
-            IF (j>i) THEN
-              smid = min(sij(ij,i,j), scrit(ij))
-              sjmax = smid
-              sjmin = smid
-              IF (smid<smin(ij) .AND. sij(ij,i,j+1)<smid) THEN
-                smin(ij) = smid
-                sjmax = min(sij(ij,i,j+1), sij(ij,i,j), scrit(ij))
-                sjmin = max(sij(ij,i,j-1), sij(ij,i,j))
-                sjmin = min(sjmin, scrit(ij))
-              END IF
-            ELSE
-              sjmax = max(sij(ij,i,j+1), scrit(ij))
-              smid = max(sij(ij,i,j), scrit(ij))
-              sjmin = 0.0
-              IF (j>1) sjmin = sij(ij, i, j-1)
-              sjmin = max(sjmin, scrit(ij))
-            END IF
-            delp = abs(sjmax-smid)
-            delm = abs(sjmin-smid)
-            asij(ij) = asij(ij) + (delp+delm)*(ph(ij,j)-ph(ij,j+1))
-            ment(ij, i, j) = ment(ij, i, j)*(delp+delm)*(ph(ij,j)-ph(ij,j+1))
-          END IF
-        END IF
-      END DO
-783 END DO
-    DO ij = 1, ncum
-      IF ((i>=icb(ij)+1) .AND. (i<=inb(ij)) .AND. lwork(ij)) THEN
-        asij(ij) = max(1.0E-21, asij(ij))
-        asij(ij) = 1.0/asij(ij)
-        bsum(ij, i) = 0.0
-      END IF
-    END DO
-    DO j = minorig, nl + 1
-      DO ij = 1, ncum
-        IF ((i>=icb(ij)+1) .AND. (i<=inb(ij)) .AND. (j>=icb( &
-            ij)) .AND. (j<=inb(ij)) .AND. lwork(ij)) THEN
-          ment(ij, i, j) = ment(ij, i, j)*asij(ij)
-          bsum(ij, i) = bsum(ij, i) + ment(ij, i, j)
-        END IF
-      END DO
-    END DO
-    DO ij = 1, ncum
-      IF ((i>=icb(ij)+1) .AND. (i<=inb(ij)) .AND. (bsum(ij, &
-          i)<1.0E-18) .AND. lwork(ij)) THEN
-        nent(ij, i) = 0
-        ment(ij, i, i) = m(ij, i)
-        qent(ij, i, i) = q(ij, nk(ij)) - ep(ij, i)*clw(ij, i)
-        uent(ij, i, i) = u(ij, nk(ij))
-        vent(ij, i, i) = v(ij, nk(ij))
-        elij(ij, i, i) = clw(ij, i)
-        sij(ij, i, i) = 1.0
-      END IF
-    END DO
-789 END DO
-
-  RETURN
-END SUBROUTINE cv_mixing
-
-SUBROUTINE cv_unsat(nloc, ncum, nd, inb, t, q, qs, gz, u, v, p, ph, h, lv, &
-    ep, sigp, clw, m, ment, elij, iflag, mp, qp, up, vp, wt, water, evap)
-  IMPLICIT NONE
-
-
-  include "cvthermo.h"
-  include "cvparam.h"
-
-  ! inputs:
-  INTEGER ncum, nd, nloc
-  INTEGER inb(nloc)
-  REAL t(nloc, nd), q(nloc, nd), qs(nloc, nd)
-  REAL gz(nloc, nd), u(nloc, nd), v(nloc, nd)
-  REAL p(nloc, nd), ph(nloc, nd+1), h(nloc, nd)
-  REAL lv(nloc, nd), ep(nloc, nd), sigp(nloc, nd), clw(nloc, nd)
-  REAL m(nloc, nd), ment(nloc, nd, nd), elij(nloc, nd, nd)
-
-  ! outputs:
-  INTEGER iflag(nloc) ! also an input
-  REAL mp(nloc, nd), qp(nloc, nd), up(nloc, nd), vp(nloc, nd)
-  REAL water(nloc, nd), evap(nloc, nd), wt(nloc, nd)
-
-  ! local variables:
-  INTEGER i, j, k, ij, num1
-  INTEGER jtt(nloc)
-  REAL awat, coeff, qsm, afac, sigt, b6, c6, revap
-  REAL dhdp, fac, qstm, rat
-  REAL wdtrain(nloc)
-  LOGICAL lwork(nloc)
-
-  ! =====================================================================
-  ! --- PRECIPITATING DOWNDRAFT CALCULATION
-  ! =====================================================================
-
-  ! Initializations:
-
-  DO i = 1, ncum
-    DO k = 1, nl + 1
-      wt(i, k) = omtsnow
-      mp(i, k) = 0.0
-      evap(i, k) = 0.0
-      water(i, k) = 0.0
-    END DO
-  END DO
-
-  DO i = 1, ncum
-    qp(i, 1) = q(i, 1)
-    up(i, 1) = u(i, 1)
-    vp(i, 1) = v(i, 1)
-  END DO
-
-  DO k = 2, nl + 1
-    DO i = 1, ncum
-      qp(i, k) = q(i, k-1)
-      up(i, k) = u(i, k-1)
-      vp(i, k) = v(i, k-1)
-    END DO
-  END DO
-
-
-  ! ***  Check whether ep(inb)=0, if so, skip precipitating    ***
-  ! ***             downdraft calculation                      ***
-
-
-  ! ***  Integrate liquid water equation to find condensed water   ***
-  ! ***                and condensed water flux                    ***
-
-
-  DO i = 1, ncum
-    jtt(i) = 2
-    IF (ep(i,inb(i))<=0.0001) iflag(i) = 2
-    IF (iflag(i)==0) THEN
-      lwork(i) = .TRUE.
-    ELSE
-      lwork(i) = .FALSE.
-    END IF
-  END DO
-
-  ! ***                    Begin downdraft loop                    ***
-
-
-  CALL zilch(wdtrain, ncum)
-  DO i = nl + 1, 1, -1
-
-    num1 = 0
-    DO ij = 1, ncum
-      IF ((i<=inb(ij)) .AND. lwork(ij)) num1 = num1 + 1
-    END DO
-    IF (num1<=0) GO TO 899
-
-
-    ! ***        Calculate detrained precipitation             ***
-
-    DO ij = 1, ncum
-      IF ((i<=inb(ij)) .AND. (lwork(ij))) THEN
-        wdtrain(ij) = g*ep(ij, i)*m(ij, i)*clw(ij, i)
-      END IF
-    END DO
-
-    IF (i>1) THEN
-      DO j = 1, i - 1
-        DO ij = 1, ncum
-          IF ((i<=inb(ij)) .AND. (lwork(ij))) THEN
-            awat = elij(ij, j, i) - (1.-ep(ij,i))*clw(ij, i)
-            awat = max(0.0, awat)
-            wdtrain(ij) = wdtrain(ij) + g*awat*ment(ij, j, i)
-          END IF
-        END DO
-      END DO
-    END IF
-
-    ! ***    Find rain water and evaporation using provisional   ***
-    ! ***              estimates of qp(i)and qp(i-1)             ***
-
-
-    ! ***  Value of terminal velocity and coeffecient of evaporation for snow
-    ! ***
-
-    DO ij = 1, ncum
-      IF ((i<=inb(ij)) .AND. (lwork(ij))) THEN
-        coeff = coeffs
-        wt(ij, i) = omtsnow
-
-        ! ***  Value of terminal velocity and coeffecient of evaporation for
-        ! rain   ***
-
-        IF (t(ij,i)>273.0) THEN
-          coeff = coeffr
-          wt(ij, i) = omtrain
-        END IF
-        qsm = 0.5*(q(ij,i)+qp(ij,i+1))
-        afac = coeff*ph(ij, i)*(qs(ij,i)-qsm)/(1.0E4+2.0E3*ph(ij,i)*qs(ij,i))
-        afac = max(afac, 0.0)
-        sigt = sigp(ij, i)
-        sigt = max(0.0, sigt)
-        sigt = min(1.0, sigt)
-        b6 = 100.*(ph(ij,i)-ph(ij,i+1))*sigt*afac/wt(ij, i)
-        c6 = (water(ij,i+1)*wt(ij,i+1)+wdtrain(ij)/sigd)/wt(ij, i)
-        revap = 0.5*(-b6+sqrt(b6*b6+4.*c6))
-        evap(ij, i) = sigt*afac*revap
-        water(ij, i) = revap*revap
-
-        ! ***  Calculate precipitating downdraft mass flux under     ***
-        ! ***              hydrostatic approximation                 ***
-
-        IF (i>1) THEN
-          dhdp = (h(ij,i)-h(ij,i-1))/(p(ij,i-1)-p(ij,i))
-          dhdp = max(dhdp, 10.0)
-          mp(ij, i) = 100.*ginv*lv(ij, i)*sigd*evap(ij, i)/dhdp
-          mp(ij, i) = max(mp(ij,i), 0.0)
-
-          ! ***   Add small amount of inertia to downdraft              ***
-
-          fac = 20.0/(ph(ij,i-1)-ph(ij,i))
-          mp(ij, i) = (fac*mp(ij,i+1)+mp(ij,i))/(1.+fac)
-
-          ! ***      Force mp to decrease linearly to zero
-          ! ***
-          ! ***      between about 950 mb and the surface
-          ! ***
-
-          IF (p(ij,i)>(0.949*p(ij,1))) THEN
-            jtt(ij) = max(jtt(ij), i)
-            mp(ij, i) = mp(ij, jtt(ij))*(p(ij,1)-p(ij,i))/ &
-              (p(ij,1)-p(ij,jtt(ij)))
-          END IF
-        END IF
-
-        ! ***       Find mixing ratio of precipitating downdraft     ***
-
-        IF (i/=inb(ij)) THEN
-          IF (i==1) THEN
-            qstm = qs(ij, 1)
-          ELSE
-            qstm = qs(ij, i-1)
-          END IF
-          IF (mp(ij,i)>mp(ij,i+1)) THEN
-            rat = mp(ij, i+1)/mp(ij, i)
-            qp(ij, i) = qp(ij, i+1)*rat + q(ij, i)*(1.0-rat) + &
-              100.*ginv*sigd*(ph(ij,i)-ph(ij,i+1))*(evap(ij,i)/mp(ij,i))
-            up(ij, i) = up(ij, i+1)*rat + u(ij, i)*(1.-rat)
-            vp(ij, i) = vp(ij, i+1)*rat + v(ij, i)*(1.-rat)
-          ELSE
-            IF (mp(ij,i+1)>0.0) THEN
-              qp(ij, i) = (gz(ij,i+1)-gz(ij,i)+qp(ij,i+1)*(lv(ij,i+1)+t(ij, &
-                i+1)*(cl-cpd))+cpd*(t(ij,i+1)-t(ij, &
-                i)))/(lv(ij,i)+t(ij,i)*(cl-cpd))
-              up(ij, i) = up(ij, i+1)
-              vp(ij, i) = vp(ij, i+1)
-            END IF
-          END IF
-          qp(ij, i) = min(qp(ij,i), qstm)
-          qp(ij, i) = max(qp(ij,i), 0.0)
-        END IF
-      END IF
-    END DO
-899 END DO
-
-  RETURN
-END SUBROUTINE cv_unsat
-
-SUBROUTINE cv_yield(nloc, ncum, nd, nk, icb, inb, delt, t, q, u, v, gz, p, &
-    ph, h, hp, lv, cpn, ep, clw, frac, m, mp, qp, up, vp, wt, water, evap, &
-    ment, qent, uent, vent, nent, elij, tv, tvp, iflag, wd, qprime, tprime, &
-    precip, cbmf, ft, fq, fu, fv, ma, qcondc)
-  IMPLICIT NONE
-
-  include "cvthermo.h"
-  include "cvparam.h"
-
-  ! inputs
-  INTEGER ncum, nd, nloc
-  INTEGER nk(nloc), icb(nloc), inb(nloc)
-  INTEGER nent(nloc, nd)
-  REAL delt
-  REAL t(nloc, nd), q(nloc, nd), u(nloc, nd), v(nloc, nd)
-  REAL gz(nloc, nd)
-  REAL p(nloc, nd), ph(nloc, nd+1), h(nloc, nd)
-  REAL hp(nloc, nd), lv(nloc, nd)
-  REAL cpn(nloc, nd), ep(nloc, nd), clw(nloc, nd), frac(nloc)
-  REAL m(nloc, nd), mp(nloc, nd), qp(nloc, nd)
-  REAL up(nloc, nd), vp(nloc, nd)
-  REAL wt(nloc, nd), water(nloc, nd), evap(nloc, nd)
-  REAL ment(nloc, nd, nd), qent(nloc, nd, nd), elij(nloc, nd, nd)
-  REAL uent(nloc, nd, nd), vent(nloc, nd, nd)
-  REAL tv(nloc, nd), tvp(nloc, nd)
-
-  ! outputs
-  INTEGER iflag(nloc) ! also an input
-  REAL cbmf(nloc) ! also an input
-  REAL wd(nloc), tprime(nloc), qprime(nloc)
-  REAL precip(nloc)
-  REAL ft(nloc, nd), fq(nloc, nd), fu(nloc, nd), fv(nloc, nd)
-  REAL ma(nloc, nd)
-  REAL qcondc(nloc, nd)
-
-  ! local variables
-  INTEGER i, j, ij, k, num1
-  REAL dpinv, cpinv, awat, fqold, ftold, fuold, fvold, delti
-  REAL work(nloc), am(nloc), amp1(nloc), ad(nloc)
-  REAL ents(nloc), uav(nloc), vav(nloc), lvcp(nloc, nd)
-  REAL qcond(nloc, nd), nqcond(nloc, nd), wa(nloc, nd) ! cld
-  REAL siga(nloc, nd), ax(nloc, nd), mac(nloc, nd) ! cld
-
-
-  ! -- initializations:
-
-  delti = 1.0/delt
-
-  DO i = 1, ncum
-    precip(i) = 0.0
-    wd(i) = 0.0
-    tprime(i) = 0.0
-    qprime(i) = 0.0
-    DO k = 1, nl + 1
-      ft(i, k) = 0.0
-      fu(i, k) = 0.0
-      fv(i, k) = 0.0
-      fq(i, k) = 0.0
-      lvcp(i, k) = lv(i, k)/cpn(i, k)
-      qcondc(i, k) = 0.0 ! cld
-      qcond(i, k) = 0.0 ! cld
-      nqcond(i, k) = 0.0 ! cld
-    END DO
-  END DO
-
-
-  ! ***  Calculate surface precipitation in mm/day     ***
-
-  DO i = 1, ncum
-    IF (iflag(i)<=1) THEN
-      ! c            precip(i)=precip(i)+wt(i,1)*sigd*water(i,1)*3600.*24000.
-      ! c     &                /(rowl*g)
-      ! c            precip(i)=precip(i)*delt/86400.
-      precip(i) = wt(i, 1)*sigd*water(i, 1)*86400/g
-    END IF
-  END DO
-
-
-  ! ***  Calculate downdraft velocity scale and surface temperature and  ***
-  ! ***                    water vapor fluctuations                      ***
-
-  DO i = 1, ncum
-    wd(i) = betad*abs(mp(i,icb(i)))*0.01*rrd*t(i, icb(i))/(sigd*p(i,icb(i)))
-    qprime(i) = 0.5*(qp(i,1)-q(i,1))
-    tprime(i) = lv0*qprime(i)/cpd
-  END DO
-
-  ! ***  Calculate tendencies of lowest level potential temperature  ***
-  ! ***                      and mixing ratio                        ***
-
-  DO i = 1, ncum
-    work(i) = 0.01/(ph(i,1)-ph(i,2))
-    am(i) = 0.0
-  END DO
-  DO k = 2, nl
-    DO i = 1, ncum
-      IF ((nk(i)==1) .AND. (k<=inb(i)) .AND. (nk(i)==1)) THEN
-        am(i) = am(i) + m(i, k)
-      END IF
-    END DO
-  END DO
-  DO i = 1, ncum
-    IF ((g*work(i)*am(i))>=delti) iflag(i) = 1
-    ft(i, 1) = ft(i, 1) + g*work(i)*am(i)*(t(i,2)-t(i,1)+(gz(i,2)-gz(i, &
-      1))/cpn(i,1))
-    ft(i, 1) = ft(i, 1) - lvcp(i, 1)*sigd*evap(i, 1)
-    ft(i, 1) = ft(i, 1) + sigd*wt(i, 2)*(cl-cpd)*water(i, 2)*(t(i,2)-t(i,1))* &
-      work(i)/cpn(i, 1)
-    fq(i, 1) = fq(i, 1) + g*mp(i, 2)*(qp(i,2)-q(i,1))*work(i) + &
-      sigd*evap(i, 1)
-    fq(i, 1) = fq(i, 1) + g*am(i)*(q(i,2)-q(i,1))*work(i)
-    fu(i, 1) = fu(i, 1) + g*work(i)*(mp(i,2)*(up(i,2)-u(i,1))+am(i)*(u(i, &
-      2)-u(i,1)))
-    fv(i, 1) = fv(i, 1) + g*work(i)*(mp(i,2)*(vp(i,2)-v(i,1))+am(i)*(v(i, &
-      2)-v(i,1)))
-  END DO
-  DO j = 2, nl
-    DO i = 1, ncum
-      IF (j<=inb(i)) THEN
-        fq(i, 1) = fq(i, 1) + g*work(i)*ment(i, j, 1)*(qent(i,j,1)-q(i,1))
-        fu(i, 1) = fu(i, 1) + g*work(i)*ment(i, j, 1)*(uent(i,j,1)-u(i,1))
-        fv(i, 1) = fv(i, 1) + g*work(i)*ment(i, j, 1)*(vent(i,j,1)-v(i,1))
-      END IF
-    END DO
-  END DO
-
-  ! ***  Calculate tendencies of potential temperature and mixing ratio  ***
-  ! ***               at levels above the lowest level                   ***
-
-  ! ***  First find the net saturated updraft and downdraft mass fluxes  ***
-  ! ***                      through each level                          ***
-
-  DO i = 2, nl + 1
-
-    num1 = 0
-    DO ij = 1, ncum
-      IF (i<=inb(ij)) num1 = num1 + 1
-    END DO
-    IF (num1<=0) GO TO 1500
-
-    CALL zilch(amp1, ncum)
-    CALL zilch(ad, ncum)
-
-    DO k = i + 1, nl + 1
-      DO ij = 1, ncum
-        IF ((i>=nk(ij)) .AND. (i<=inb(ij)) .AND. (k<=(inb(ij)+1))) THEN
-          amp1(ij) = amp1(ij) + m(ij, k)
-        END IF
-      END DO
-    END DO
-
-    DO k = 1, i
-      DO j = i + 1, nl + 1
-        DO ij = 1, ncum
-          IF ((j<=(inb(ij)+1)) .AND. (i<=inb(ij))) THEN
-            amp1(ij) = amp1(ij) + ment(ij, k, j)
-          END IF
-        END DO
-      END DO
-    END DO
-    DO k = 1, i - 1
-      DO j = i, nl + 1
-        DO ij = 1, ncum
-          IF ((i<=inb(ij)) .AND. (j<=inb(ij))) THEN
-            ad(ij) = ad(ij) + ment(ij, j, k)
-          END IF
-        END DO
-      END DO
-    END DO
-
-    DO ij = 1, ncum
-      IF (i<=inb(ij)) THEN
-        dpinv = 0.01/(ph(ij,i)-ph(ij,i+1))
-        cpinv = 1.0/cpn(ij, i)
-
-        ft(ij, i) = ft(ij, i) + g*dpinv*(amp1(ij)*(t(ij,i+1)-t(ij, &
-          i)+(gz(ij,i+1)-gz(ij,i))*cpinv)-ad(ij)*(t(ij,i)-t(ij, &
-          i-1)+(gz(ij,i)-gz(ij,i-1))*cpinv)) - sigd*lvcp(ij, i)*evap(ij, i)
-        ft(ij, i) = ft(ij, i) + g*dpinv*ment(ij, i, i)*(hp(ij,i)-h(ij,i)+t(ij &
-          ,i)*(cpv-cpd)*(q(ij,i)-qent(ij,i,i)))*cpinv
-        ft(ij, i) = ft(ij, i) + sigd*wt(ij, i+1)*(cl-cpd)*water(ij, i+1)*(t( &
-          ij,i+1)-t(ij,i))*dpinv*cpinv
-        fq(ij, i) = fq(ij, i) + g*dpinv*(amp1(ij)*(q(ij,i+1)-q(ij, &
-          i))-ad(ij)*(q(ij,i)-q(ij,i-1)))
-        fu(ij, i) = fu(ij, i) + g*dpinv*(amp1(ij)*(u(ij,i+1)-u(ij, &
-          i))-ad(ij)*(u(ij,i)-u(ij,i-1)))
-        fv(ij, i) = fv(ij, i) + g*dpinv*(amp1(ij)*(v(ij,i+1)-v(ij, &
-          i))-ad(ij)*(v(ij,i)-v(ij,i-1)))
-      END IF
-    END DO
-    DO k = 1, i - 1
-      DO ij = 1, ncum
-        IF (i<=inb(ij)) THEN
-          awat = elij(ij, k, i) - (1.-ep(ij,i))*clw(ij, i)
-          awat = max(awat, 0.0)
-          fq(ij, i) = fq(ij, i) + g*dpinv*ment(ij, k, i)*(qent(ij,k,i)-awat-q &
-            (ij,i))
-          fu(ij, i) = fu(ij, i) + g*dpinv*ment(ij, k, i)*(uent(ij,k,i)-u(ij,i &
-            ))
-          fv(ij, i) = fv(ij, i) + g*dpinv*ment(ij, k, i)*(vent(ij,k,i)-v(ij,i &
-            ))
-          ! (saturated updrafts resulting from mixing)               ! cld
-          qcond(ij, i) = qcond(ij, i) + (elij(ij,k,i)-awat) ! cld
-          nqcond(ij, i) = nqcond(ij, i) + 1. ! cld
-        END IF
-      END DO
-    END DO
-    DO k = i, nl + 1
-      DO ij = 1, ncum
-        IF ((i<=inb(ij)) .AND. (k<=inb(ij))) THEN
-          fq(ij, i) = fq(ij, i) + g*dpinv*ment(ij, k, i)*(qent(ij,k,i)-q(ij,i &
-            ))
-          fu(ij, i) = fu(ij, i) + g*dpinv*ment(ij, k, i)*(uent(ij,k,i)-u(ij,i &
-            ))
-          fv(ij, i) = fv(ij, i) + g*dpinv*ment(ij, k, i)*(vent(ij,k,i)-v(ij,i &
-            ))
-        END IF
-      END DO
-    END DO
-    DO ij = 1, ncum
-      IF (i<=inb(ij)) THEN
-        fq(ij, i) = fq(ij, i) + sigd*evap(ij, i) + g*(mp(ij,i+1)*(qp(ij, &
-          i+1)-q(ij,i))-mp(ij,i)*(qp(ij,i)-q(ij,i-1)))*dpinv
-        fu(ij, i) = fu(ij, i) + g*(mp(ij,i+1)*(up(ij,i+1)-u(ij, &
-          i))-mp(ij,i)*(up(ij,i)-u(ij,i-1)))*dpinv
-        fv(ij, i) = fv(ij, i) + g*(mp(ij,i+1)*(vp(ij,i+1)-v(ij, &
-          i))-mp(ij,i)*(vp(ij,i)-v(ij,i-1)))*dpinv
-        ! (saturated downdrafts resulting from mixing)               ! cld
-        DO k = i + 1, inb(ij) ! cld
-          qcond(ij, i) = qcond(ij, i) + elij(ij, k, i) ! cld
-          nqcond(ij, i) = nqcond(ij, i) + 1. ! cld
-        END DO ! cld
-        ! (particular case: no detraining level is found)            ! cld
-        IF (nent(ij,i)==0) THEN ! cld
-          qcond(ij, i) = qcond(ij, i) + (1.-ep(ij,i))*clw(ij, i) ! cld
-          nqcond(ij, i) = nqcond(ij, i) + 1. ! cld
-        END IF ! cld
-        IF (nqcond(ij,i)/=0.) THEN ! cld
-          qcond(ij, i) = qcond(ij, i)/nqcond(ij, i) ! cld
-        END IF ! cld
-      END IF
-    END DO
-1500 END DO
-
-  ! *** Adjust tendencies at top of convection layer to reflect  ***
-  ! ***       actual position of the level zero cape             ***
-
-  DO ij = 1, ncum
-    fqold = fq(ij, inb(ij))
-    fq(ij, inb(ij)) = fq(ij, inb(ij))*(1.-frac(ij))
-    fq(ij, inb(ij)-1) = fq(ij, inb(ij)-1) + frac(ij)*fqold*((ph(ij, &
-      inb(ij))-ph(ij,inb(ij)+1))/(ph(ij,inb(ij)-1)-ph(ij, &
-      inb(ij))))*lv(ij, inb(ij))/lv(ij, inb(ij)-1)
-    ftold = ft(ij, inb(ij))
-    ft(ij, inb(ij)) = ft(ij, inb(ij))*(1.-frac(ij))
-    ft(ij, inb(ij)-1) = ft(ij, inb(ij)-1) + frac(ij)*ftold*((ph(ij, &
-      inb(ij))-ph(ij,inb(ij)+1))/(ph(ij,inb(ij)-1)-ph(ij, &
-      inb(ij))))*cpn(ij, inb(ij))/cpn(ij, inb(ij)-1)
-    fuold = fu(ij, inb(ij))
-    fu(ij, inb(ij)) = fu(ij, inb(ij))*(1.-frac(ij))
-    fu(ij, inb(ij)-1) = fu(ij, inb(ij)-1) + frac(ij)*fuold*((ph(ij, &
-      inb(ij))-ph(ij,inb(ij)+1))/(ph(ij,inb(ij)-1)-ph(ij,inb(ij))))
-    fvold = fv(ij, inb(ij))
-    fv(ij, inb(ij)) = fv(ij, inb(ij))*(1.-frac(ij))
-    fv(ij, inb(ij)-1) = fv(ij, inb(ij)-1) + frac(ij)*fvold*((ph(ij, &
-      inb(ij))-ph(ij,inb(ij)+1))/(ph(ij,inb(ij)-1)-ph(ij,inb(ij))))
-  END DO
-
-  ! ***   Very slightly adjust tendencies to force exact   ***
-  ! ***     enthalpy, momentum and tracer conservation     ***
-
-  DO ij = 1, ncum
-    ents(ij) = 0.0
-    uav(ij) = 0.0
-    vav(ij) = 0.0
-    DO i = 1, inb(ij)
-      ents(ij) = ents(ij) + (cpn(ij,i)*ft(ij,i)+lv(ij,i)*fq(ij,i))*(ph(ij,i)- &
-        ph(ij,i+1))
-      uav(ij) = uav(ij) + fu(ij, i)*(ph(ij,i)-ph(ij,i+1))
-      vav(ij) = vav(ij) + fv(ij, i)*(ph(ij,i)-ph(ij,i+1))
-    END DO
-  END DO
-  DO ij = 1, ncum
-    ents(ij) = ents(ij)/(ph(ij,1)-ph(ij,inb(ij)+1))
-    uav(ij) = uav(ij)/(ph(ij,1)-ph(ij,inb(ij)+1))
-    vav(ij) = vav(ij)/(ph(ij,1)-ph(ij,inb(ij)+1))
-  END DO
-  DO ij = 1, ncum
-    DO i = 1, inb(ij)
-      ft(ij, i) = ft(ij, i) - ents(ij)/cpn(ij, i)
-      fu(ij, i) = (1.-cu)*(fu(ij,i)-uav(ij))
-      fv(ij, i) = (1.-cu)*(fv(ij,i)-vav(ij))
-    END DO
-  END DO
-
-  DO k = 1, nl + 1
-    DO i = 1, ncum
-      IF ((q(i,k)+delt*fq(i,k))<0.0) iflag(i) = 10
-    END DO
-  END DO
-
-
-  DO i = 1, ncum
-    IF (iflag(i)>2) THEN
-      precip(i) = 0.0
-      cbmf(i) = 0.0
-    END IF
-  END DO
-  DO k = 1, nl
-    DO i = 1, ncum
-      IF (iflag(i)>2) THEN
-        ft(i, k) = 0.0
-        fq(i, k) = 0.0
-        fu(i, k) = 0.0
-        fv(i, k) = 0.0
-        qcondc(i, k) = 0.0 ! cld
-      END IF
-    END DO
-  END DO
-
-  DO k = 1, nl + 1
-    DO i = 1, ncum
-      ma(i, k) = 0.
-    END DO
-  END DO
-  DO k = nl, 1, -1
-    DO i = 1, ncum
-      ma(i, k) = ma(i, k+1) + m(i, k)
-    END DO
-  END DO
-
-
-  ! *** diagnose the in-cloud mixing ratio   ***            ! cld
-  ! ***           of condensed water         ***            ! cld
-  ! ! cld
-  DO ij = 1, ncum ! cld
-    DO i = 1, nd ! cld
-      mac(ij, i) = 0.0 ! cld
-      wa(ij, i) = 0.0 ! cld
-      siga(ij, i) = 0.0 ! cld
-    END DO ! cld
-    DO i = nk(ij), inb(ij) ! cld
-      DO k = i + 1, inb(ij) + 1 ! cld
-        mac(ij, i) = mac(ij, i) + m(ij, k) ! cld
-      END DO ! cld
-    END DO ! cld
-    DO i = icb(ij), inb(ij) - 1 ! cld
-      ax(ij, i) = 0. ! cld
-      DO j = icb(ij), i ! cld
-        ax(ij, i) = ax(ij, i) + rrd*(tvp(ij,j)-tv(ij,j)) & ! cld
-          *(ph(ij,j)-ph(ij,j+1))/p(ij, j) ! cld
-      END DO ! cld
-      IF (ax(ij,i)>0.0) THEN ! cld
-        wa(ij, i) = sqrt(2.*ax(ij,i)) ! cld
-      END IF ! cld
-    END DO ! cld
-    DO i = 1, nl ! cld
-      IF (wa(ij,i)>0.0) &          ! cld
-        siga(ij, i) = mac(ij, i)/wa(ij, i) & ! cld
-        *rrd*tvp(ij, i)/p(ij, i)/100./delta ! cld
-      siga(ij, i) = min(siga(ij,i), 1.0) ! cld
-      qcondc(ij, i) = siga(ij, i)*clw(ij, i)*(1.-ep(ij,i)) & ! cld
-        +(1.-siga(ij,i))*qcond(ij, i) ! cld
-    END DO ! cld
-  END DO ! cld
-
-  RETURN
-END SUBROUTINE cv_yield
-
-SUBROUTINE cv_uncompress(nloc, len, ncum, nd, idcum, iflag, precip, cbmf, ft, &
-    fq, fu, fv, ma, qcondc, iflag1, precip1, cbmf1, ft1, fq1, fu1, fv1, ma1, &
-    qcondc1)
-  IMPLICIT NONE
-
-  include "cvparam.h"
-
-  ! inputs:
-  INTEGER len, ncum, nd, nloc
-  INTEGER idcum(nloc)
-  INTEGER iflag(nloc)
-  REAL precip(nloc), cbmf(nloc)
-  REAL ft(nloc, nd), fq(nloc, nd), fu(nloc, nd), fv(nloc, nd)
-  REAL ma(nloc, nd)
-  REAL qcondc(nloc, nd) !cld
-
-  ! outputs:
-  INTEGER iflag1(len)
-  REAL precip1(len), cbmf1(len)
-  REAL ft1(len, nd), fq1(len, nd), fu1(len, nd), fv1(len, nd)
-  REAL ma1(len, nd)
-  REAL qcondc1(len, nd) !cld
-
-  ! local variables:
-  INTEGER i, k
-
-  DO i = 1, ncum
-    precip1(idcum(i)) = precip(i)
-    cbmf1(idcum(i)) = cbmf(i)
-    iflag1(idcum(i)) = iflag(i)
-  END DO
-
-  DO k = 1, nl
-    DO i = 1, ncum
-      ft1(idcum(i), k) = ft(i, k)
-      fq1(idcum(i), k) = fq(i, k)
-      fu1(idcum(i), k) = fu(i, k)
-      fv1(idcum(i), k) = fv(i, k)
-      ma1(idcum(i), k) = ma(i, k)
-      qcondc1(idcum(i), k) = qcondc(i, k)
-    END DO
-  END DO
-
-  RETURN
-END SUBROUTINE cv_uncompress
-
Index: /LMDZ6/trunk/libf/phylmdiso/cv_routines.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/cv_routines.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/cv_routines.f90	(revision 5268)
@@ -0,0 +1,1713 @@
+
+! $Id$
+
+SUBROUTINE cv_param(nd)
+  IMPLICIT NONE
+
+  ! ------------------------------------------------------------
+  ! Set parameters for convectL
+  ! (includes microphysical parameters and parameters that
+  ! control the rate of approach to quasi-equilibrium)
+  ! ------------------------------------------------------------
+
+  ! *** ELCRIT IS THE AUTOCONVERSION THERSHOLD WATER CONTENT (gm/gm) ***
+  ! ***  TLCRIT IS CRITICAL TEMPERATURE BELOW WHICH THE AUTO-        ***
+  ! ***       CONVERSION THRESHOLD IS ASSUMED TO BE ZERO             ***
+  ! ***     (THE AUTOCONVERSION THRESHOLD VARIES LINEARLY            ***
+  ! ***               BETWEEN 0 C AND TLCRIT)                        ***
+  ! ***   ENTP IS THE COEFFICIENT OF MIXING IN THE ENTRAINMENT       ***
+  ! ***                       FORMULATION                            ***
+  ! ***  SIGD IS THE FRACTIONAL AREA COVERED BY UNSATURATED DNDRAFT  ***
+  ! ***  SIGS IS THE FRACTION OF PRECIPITATION FALLING OUTSIDE       ***
+  ! ***                        OF CLOUD                              ***
+  ! ***        OMTRAIN IS THE ASSUMED FALL SPEED (P/s) OF RAIN       ***
+  ! ***     OMTSNOW IS THE ASSUMED FALL SPEED (P/s) OF SNOW          ***
+  ! ***  COEFFR IS A COEFFICIENT GOVERNING THE RATE OF EVAPORATION   ***
+  ! ***                          OF RAIN                             ***
+  ! ***  COEFFS IS A COEFFICIENT GOVERNING THE RATE OF EVAPORATION   ***
+  ! ***                          OF SNOW                             ***
+  ! ***     CU IS THE COEFFICIENT GOVERNING CONVECTIVE MOMENTUM      ***
+  ! ***                         TRANSPORT                            ***
+  ! ***    DTMAX IS THE MAXIMUM NEGATIVE TEMPERATURE PERTURBATION    ***
+  ! ***        A LIFTED PARCEL IS ALLOWED TO HAVE BELOW ITS LFC      ***
+  ! ***    ALPHA AND DAMP ARE PARAMETERS THAT CONTROL THE RATE OF    ***
+  ! ***                 APPROACH TO QUASI-EQUILIBRIUM                ***
+  ! ***   (THEIR STANDARD VALUES ARE  0.20 AND 0.1, RESPECTIVELY)    ***
+  ! ***                   (DAMP MUST BE LESS THAN 1)                 ***
+
+  include "cvparam.h"
+  INTEGER nd
+  CHARACTER (LEN=20) :: modname = 'cv_routines'
+  CHARACTER (LEN=80) :: abort_message
+
+  ! noff: integer limit for convection (nd-noff)
+  ! minorig: First level of convection
+
+  noff = 2
+  minorig = 2
+
+  nl = nd - noff
+  nlp = nl + 1
+  nlm = nl - 1
+
+  elcrit = 0.0011
+  tlcrit = -55.0
+  entp = 1.5
+  sigs = 0.12
+  sigd = 0.05
+  omtrain = 50.0
+  omtsnow = 5.5
+  coeffr = 1.0
+  coeffs = 0.8
+  dtmax = 0.9
+
+  cu = 0.70
+
+  betad = 10.0
+
+  damp = 0.1
+  alpha = 0.2
+
+  delta = 0.01 ! cld
+
+  RETURN
+END SUBROUTINE cv_param
+
+SUBROUTINE cv_prelim(len, nd, ndp1, t, q, p, ph, lv, cpn, tv, gz, h, hm)
+  IMPLICIT NONE
+
+  ! =====================================================================
+  ! --- CALCULATE ARRAYS OF GEOPOTENTIAL, HEAT CAPACITY & STATIC ENERGY
+  ! =====================================================================
+
+  ! inputs:
+  INTEGER len, nd, ndp1
+  REAL t(len, nd), q(len, nd), p(len, nd), ph(len, ndp1)
+
+  ! outputs:
+  REAL lv(len, nd), cpn(len, nd), tv(len, nd)
+  REAL gz(len, nd), h(len, nd), hm(len, nd)
+
+  ! local variables:
+  INTEGER k, i
+  REAL cpx(len, nd)
+
+  include "cvthermo.h"
+  include "cvparam.h"
+
+
+  DO k = 1, nlp
+    DO i = 1, len
+      lv(i, k) = lv0 - clmcpv*(t(i,k)-t0)
+      cpn(i, k) = cpd*(1.0-q(i,k)) + cpv*q(i, k)
+      cpx(i, k) = cpd*(1.0-q(i,k)) + cl*q(i, k)
+      tv(i, k) = t(i, k)*(1.0+q(i,k)*epsim1)
+    END DO
+  END DO
+
+  ! gz = phi at the full levels (same as p).
+
+  DO i = 1, len
+    gz(i, 1) = 0.0
+  END DO
+  DO k = 2, nlp
+    DO i = 1, len
+      gz(i, k) = gz(i, k-1) + hrd*(tv(i,k-1)+tv(i,k))*(p(i,k-1)-p(i,k))/ph(i, &
+        k)
+    END DO
+  END DO
+
+  ! h  = phi + cpT (dry static energy).
+  ! hm = phi + cp(T-Tbase)+Lq
+
+  DO k = 1, nlp
+    DO i = 1, len
+      h(i, k) = gz(i, k) + cpn(i, k)*t(i, k)
+      hm(i, k) = gz(i, k) + cpx(i, k)*(t(i,k)-t(i,1)) + lv(i, k)*q(i, k)
+    END DO
+  END DO
+
+  RETURN
+END SUBROUTINE cv_prelim
+
+SUBROUTINE cv_feed(len, nd, t, q, qs, p, hm, gz, nk, icb, icbmax, iflag, tnk, &
+    qnk, gznk, plcl)
+  IMPLICIT NONE
+
+  ! ================================================================
+  ! Purpose: CONVECTIVE FEED
+  ! ================================================================
+
+  include "cvparam.h"
+
+  ! inputs:
+  INTEGER len, nd
+  REAL t(len, nd), q(len, nd), qs(len, nd), p(len, nd)
+  REAL hm(len, nd), gz(len, nd)
+
+  ! outputs:
+  INTEGER iflag(len), nk(len), icb(len), icbmax
+  REAL tnk(len), qnk(len), gznk(len), plcl(len)
+
+  ! local variables:
+  INTEGER i, k
+  INTEGER ihmin(len)
+  REAL work(len)
+  REAL pnk(len), qsnk(len), rh(len), chi(len)
+
+  ! -------------------------------------------------------------------
+  ! --- Find level of minimum moist static energy
+  ! --- If level of minimum moist static energy coincides with
+  ! --- or is lower than minimum allowable parcel origin level,
+  ! --- set iflag to 6.
+  ! -------------------------------------------------------------------
+
+  DO i = 1, len
+    work(i) = 1.0E12
+    ihmin(i) = nl
+  END DO
+  DO k = 2, nlp
+    DO i = 1, len
+      IF ((hm(i,k)<work(i)) .AND. (hm(i,k)<hm(i,k-1))) THEN
+        work(i) = hm(i, k)
+        ihmin(i) = k
+      END IF
+    END DO
+  END DO
+  DO i = 1, len
+    ihmin(i) = min(ihmin(i), nlm)
+    IF (ihmin(i)<=minorig) THEN
+      iflag(i) = 6
+    END IF
+  END DO
+
+  ! -------------------------------------------------------------------
+  ! --- Find that model level below the level of minimum moist static
+  ! --- energy that has the maximum value of moist static energy
+  ! -------------------------------------------------------------------
+
+  DO i = 1, len
+    work(i) = hm(i, minorig)
+    nk(i) = minorig
+  END DO
+  DO k = minorig + 1, nl
+    DO i = 1, len
+      IF ((hm(i,k)>work(i)) .AND. (k<=ihmin(i))) THEN
+        work(i) = hm(i, k)
+        nk(i) = k
+      END IF
+    END DO
+  END DO
+  ! -------------------------------------------------------------------
+  ! --- Check whether parcel level temperature and specific humidity
+  ! --- are reasonable
+  ! -------------------------------------------------------------------
+  DO i = 1, len
+    IF (((t(i,nk(i))<250.0) .OR. (q(i,nk(i))<=0.0) .OR. (p(i,ihmin(i))< &
+      400.0)) .AND. (iflag(i)==0)) iflag(i) = 7
+  END DO
+  ! -------------------------------------------------------------------
+  ! --- Calculate lifted condensation level of air at parcel origin level
+  ! --- (Within 0.2% of formula of Bolton, MON. WEA. REV.,1980)
+  ! -------------------------------------------------------------------
+  DO i = 1, len
+    tnk(i) = t(i, nk(i))
+    qnk(i) = q(i, nk(i))
+    gznk(i) = gz(i, nk(i))
+    pnk(i) = p(i, nk(i))
+    qsnk(i) = qs(i, nk(i))
+
+    rh(i) = qnk(i)/qsnk(i)
+    rh(i) = min(1.0, rh(i))
+    chi(i) = tnk(i)/(1669.0-122.0*rh(i)-tnk(i))
+    plcl(i) = pnk(i)*(rh(i)**chi(i))
+    IF (((plcl(i)<200.0) .OR. (plcl(i)>=2000.0)) .AND. (iflag(i)==0)) iflag(i &
+      ) = 8
+  END DO
+  ! -------------------------------------------------------------------
+  ! --- Calculate first level above lcl (=icb)
+  ! -------------------------------------------------------------------
+  DO i = 1, len
+    icb(i) = nlm
+  END DO
+
+  DO k = minorig, nl
+    DO i = 1, len
+      IF ((k>=(nk(i)+1)) .AND. (p(i,k)<plcl(i))) icb(i) = min(icb(i), k)
+    END DO
+  END DO
+
+  DO i = 1, len
+    IF ((icb(i)>=nlm) .AND. (iflag(i)==0)) iflag(i) = 9
+  END DO
+
+  ! Compute icbmax.
+
+  icbmax = 2
+  DO i = 1, len
+    icbmax = max(icbmax, icb(i))
+  END DO
+
+  RETURN
+END SUBROUTINE cv_feed
+
+SUBROUTINE cv_undilute1(len, nd, t, q, qs, gz, p, nk, icb, icbmax, tp, tvp, &
+    clw)
+  IMPLICIT NONE
+
+  include "cvthermo.h"
+  include "cvparam.h"
+
+  ! inputs:
+  INTEGER len, nd
+  INTEGER nk(len), icb(len), icbmax
+  REAL t(len, nd), q(len, nd), qs(len, nd), gz(len, nd)
+  REAL p(len, nd)
+
+  ! outputs:
+  REAL tp(len, nd), tvp(len, nd), clw(len, nd)
+
+  ! local variables:
+  INTEGER i, k
+  REAL tg, qg, alv, s, ahg, tc, denom, es, rg
+  REAL ah0(len), cpp(len)
+  REAL tnk(len), qnk(len), gznk(len), ticb(len), gzicb(len)
+
+  ! -------------------------------------------------------------------
+  ! --- Calculates the lifted parcel virtual temperature at nk,
+  ! --- the actual temperature, and the adiabatic
+  ! --- liquid water content. The procedure is to solve the equation.
+  ! cp*tp+L*qp+phi=cp*tnk+L*qnk+gznk.
+  ! -------------------------------------------------------------------
+
+  DO i = 1, len
+    tnk(i) = t(i, nk(i))
+    qnk(i) = q(i, nk(i))
+    gznk(i) = gz(i, nk(i))
+    ticb(i) = t(i, icb(i))
+    gzicb(i) = gz(i, icb(i))
+  END DO
+
+  ! ***  Calculate certain parcel quantities, including static energy   ***
+
+  DO i = 1, len
+    ah0(i) = (cpd*(1.-qnk(i))+cl*qnk(i))*tnk(i) + qnk(i)*(lv0-clmcpv*(tnk(i)- &
+      273.15)) + gznk(i)
+    cpp(i) = cpd*(1.-qnk(i)) + qnk(i)*cpv
+  END DO
+
+  ! ***   Calculate lifted parcel quantities below cloud base   ***
+
+  DO k = minorig, icbmax - 1
+    DO i = 1, len
+      tp(i, k) = tnk(i) - (gz(i,k)-gznk(i))/cpp(i)
+      tvp(i, k) = tp(i, k)*(1.+qnk(i)*epsi)
+    END DO
+  END DO
+
+  ! ***  Find lifted parcel quantities above cloud base    ***
+
+  DO i = 1, len
+    tg = ticb(i)
+    qg = qs(i, icb(i))
+    alv = lv0 - clmcpv*(ticb(i)-t0)
+
+    ! First iteration.
+
+    s = cpd + alv*alv*qg/(rrv*ticb(i)*ticb(i))
+    s = 1./s
+    ahg = cpd*tg + (cl-cpd)*qnk(i)*ticb(i) + alv*qg + gzicb(i)
+    tg = tg + s*(ah0(i)-ahg)
+    tg = max(tg, 35.0)
+    tc = tg - t0
+    denom = 243.5 + tc
+    IF (tc>=0.0) THEN
+      es = 6.112*exp(17.67*tc/denom)
+    ELSE
+      es = exp(23.33086-6111.72784/tg+0.15215*log(tg))
+    END IF
+    qg = eps*es/(p(i,icb(i))-es*(1.-eps))
+
+    ! Second iteration.
+
+    s = cpd + alv*alv*qg/(rrv*ticb(i)*ticb(i))
+    s = 1./s
+    ahg = cpd*tg + (cl-cpd)*qnk(i)*ticb(i) + alv*qg + gzicb(i)
+    tg = tg + s*(ah0(i)-ahg)
+    tg = max(tg, 35.0)
+    tc = tg - t0
+    denom = 243.5 + tc
+    IF (tc>=0.0) THEN
+      es = 6.112*exp(17.67*tc/denom)
+    ELSE
+      es = exp(23.33086-6111.72784/tg+0.15215*log(tg))
+    END IF
+    qg = eps*es/(p(i,icb(i))-es*(1.-eps))
+
+    alv = lv0 - clmcpv*(ticb(i)-273.15)
+    tp(i, icb(i)) = (ah0(i)-(cl-cpd)*qnk(i)*ticb(i)-gz(i,icb(i))-alv*qg)/cpd
+    clw(i, icb(i)) = qnk(i) - qg
+    clw(i, icb(i)) = max(0.0, clw(i,icb(i)))
+    rg = qg/(1.-qnk(i))
+    tvp(i, icb(i)) = tp(i, icb(i))*(1.+rg*epsi)
+  END DO
+
+  DO k = minorig, icbmax
+    DO i = 1, len
+      tvp(i, k) = tvp(i, k) - tp(i, k)*qnk(i)
+    END DO
+  END DO
+
+  RETURN
+END SUBROUTINE cv_undilute1
+
+SUBROUTINE cv_trigger(len, nd, icb, cbmf, tv, tvp, iflag)
+  IMPLICIT NONE
+
+  ! -------------------------------------------------------------------
+  ! --- Test for instability.
+  ! --- If there was no convection at last time step and parcel
+  ! --- is stable at icb, then set iflag to 4.
+  ! -------------------------------------------------------------------
+
+  include "cvparam.h"
+
+  ! inputs:
+  INTEGER len, nd, icb(len)
+  REAL cbmf(len), tv(len, nd), tvp(len, nd)
+
+  ! outputs:
+  INTEGER iflag(len) ! also an input
+
+  ! local variables:
+  INTEGER i
+
+
+  DO i = 1, len
+    IF ((cbmf(i)==0.0) .AND. (iflag(i)==0) .AND. (tvp(i, &
+      icb(i))<=(tv(i,icb(i))-dtmax))) iflag(i) = 4
+  END DO
+
+  RETURN
+END SUBROUTINE cv_trigger
+
+SUBROUTINE cv_compress(len, nloc, ncum, nd, iflag1, nk1, icb1, cbmf1, plcl1, &
+    tnk1, qnk1, gznk1, t1, q1, qs1, u1, v1, gz1, h1, lv1, cpn1, p1, ph1, tv1, &
+    tp1, tvp1, clw1, iflag, nk, icb, cbmf, plcl, tnk, qnk, gznk, t, q, qs, u, &
+    v, gz, h, lv, cpn, p, ph, tv, tp, tvp, clw, dph)
+  USE print_control_mod, ONLY: lunout
+  IMPLICIT NONE
+
+  include "cvparam.h"
+
+  ! inputs:
+  INTEGER len, ncum, nd, nloc
+  INTEGER iflag1(len), nk1(len), icb1(len)
+  REAL cbmf1(len), plcl1(len), tnk1(len), qnk1(len), gznk1(len)
+  REAL t1(len, nd), q1(len, nd), qs1(len, nd), u1(len, nd), v1(len, nd)
+  REAL gz1(len, nd), h1(len, nd), lv1(len, nd), cpn1(len, nd)
+  REAL p1(len, nd), ph1(len, nd+1), tv1(len, nd), tp1(len, nd)
+  REAL tvp1(len, nd), clw1(len, nd)
+
+  ! outputs:
+  INTEGER iflag(nloc), nk(nloc), icb(nloc)
+  REAL cbmf(nloc), plcl(nloc), tnk(nloc), qnk(nloc), gznk(nloc)
+  REAL t(nloc, nd), q(nloc, nd), qs(nloc, nd), u(nloc, nd), v(nloc, nd)
+  REAL gz(nloc, nd), h(nloc, nd), lv(nloc, nd), cpn(nloc, nd)
+  REAL p(nloc, nd), ph(nloc, nd+1), tv(nloc, nd), tp(nloc, nd)
+  REAL tvp(nloc, nd), clw(nloc, nd)
+  REAL dph(nloc, nd)
+
+  ! local variables:
+  INTEGER i, k, nn
+  CHARACTER (LEN=20) :: modname = 'cv_compress'
+  CHARACTER (LEN=80) :: abort_message
+
+
+  DO k = 1, nl + 1
+    nn = 0
+    DO i = 1, len
+      IF (iflag1(i)==0) THEN
+        nn = nn + 1
+        t(nn, k) = t1(i, k)
+        q(nn, k) = q1(i, k)
+        qs(nn, k) = qs1(i, k)
+        u(nn, k) = u1(i, k)
+        v(nn, k) = v1(i, k)
+        gz(nn, k) = gz1(i, k)
+        h(nn, k) = h1(i, k)
+        lv(nn, k) = lv1(i, k)
+        cpn(nn, k) = cpn1(i, k)
+        p(nn, k) = p1(i, k)
+        ph(nn, k) = ph1(i, k)
+        tv(nn, k) = tv1(i, k)
+        tp(nn, k) = tp1(i, k)
+        tvp(nn, k) = tvp1(i, k)
+        clw(nn, k) = clw1(i, k)
+      END IF
+    END DO
+  END DO
+
+  IF (nn/=ncum) THEN
+    WRITE (lunout, *) 'strange! nn not equal to ncum: ', nn, ncum
+    abort_message = ''
+    CALL abort_physic(modname, abort_message, 1)
+  END IF
+
+  nn = 0
+  DO i = 1, len
+    IF (iflag1(i)==0) THEN
+      nn = nn + 1
+      cbmf(nn) = cbmf1(i)
+      plcl(nn) = plcl1(i)
+      tnk(nn) = tnk1(i)
+      qnk(nn) = qnk1(i)
+      gznk(nn) = gznk1(i)
+      nk(nn) = nk1(i)
+      icb(nn) = icb1(i)
+      iflag(nn) = iflag1(i)
+    END IF
+  END DO
+
+  DO k = 1, nl
+    DO i = 1, ncum
+      dph(i, k) = ph(i, k) - ph(i, k+1)
+    END DO
+  END DO
+
+  RETURN
+END SUBROUTINE cv_compress
+
+SUBROUTINE cv_undilute2(nloc, ncum, nd, icb, nk, tnk, qnk, gznk, t, q, qs, &
+    gz, p, dph, h, tv, lv, inb, inb1, tp, tvp, clw, hp, ep, sigp, frac)
+  IMPLICIT NONE
+
+  ! ---------------------------------------------------------------------
+  ! Purpose:
+  ! FIND THE REST OF THE LIFTED PARCEL TEMPERATURES
+  ! &
+  ! COMPUTE THE PRECIPITATION EFFICIENCIES AND THE
+  ! FRACTION OF PRECIPITATION FALLING OUTSIDE OF CLOUD
+  ! &
+  ! FIND THE LEVEL OF NEUTRAL BUOYANCY
+  ! ---------------------------------------------------------------------
+
+  include "cvthermo.h"
+  include "cvparam.h"
+
+  ! inputs:
+  INTEGER ncum, nd, nloc
+  INTEGER icb(nloc), nk(nloc)
+  REAL t(nloc, nd), q(nloc, nd), qs(nloc, nd), gz(nloc, nd)
+  REAL p(nloc, nd), dph(nloc, nd)
+  REAL tnk(nloc), qnk(nloc), gznk(nloc)
+  REAL lv(nloc, nd), tv(nloc, nd), h(nloc, nd)
+
+  ! outputs:
+  INTEGER inb(nloc), inb1(nloc)
+  REAL tp(nloc, nd), tvp(nloc, nd), clw(nloc, nd)
+  REAL ep(nloc, nd), sigp(nloc, nd), hp(nloc, nd)
+  REAL frac(nloc)
+
+  ! local variables:
+  INTEGER i, k
+  REAL tg, qg, ahg, alv, s, tc, es, denom, rg, tca, elacrit
+  REAL by, defrac
+  REAL ah0(nloc), cape(nloc), capem(nloc), byp(nloc)
+  LOGICAL lcape(nloc)
+
+  ! =====================================================================
+  ! --- SOME INITIALIZATIONS
+  ! =====================================================================
+
+  DO k = 1, nl
+    DO i = 1, ncum
+      ep(i, k) = 0.0
+      sigp(i, k) = sigs
+    END DO
+  END DO
+
+  ! =====================================================================
+  ! --- FIND THE REST OF THE LIFTED PARCEL TEMPERATURES
+  ! =====================================================================
+
+  ! ---       The procedure is to solve the equation.
+  ! cp*tp+L*qp+phi=cp*tnk+L*qnk+gznk.
+
+  ! ***  Calculate certain parcel quantities, including static energy   ***
+
+
+  DO i = 1, ncum
+    ah0(i) = (cpd*(1.-qnk(i))+cl*qnk(i))*tnk(i) + qnk(i)*(lv0-clmcpv*(tnk(i)- &
+      t0)) + gznk(i)
+  END DO
+
+
+  ! ***  Find lifted parcel quantities above cloud base    ***
+
+
+  DO k = minorig + 1, nl
+    DO i = 1, ncum
+      IF (k>=(icb(i)+1)) THEN
+        tg = t(i, k)
+        qg = qs(i, k)
+        alv = lv0 - clmcpv*(t(i,k)-t0)
+
+        ! First iteration.
+
+        s = cpd + alv*alv*qg/(rrv*t(i,k)*t(i,k))
+        s = 1./s
+        ahg = cpd*tg + (cl-cpd)*qnk(i)*t(i, k) + alv*qg + gz(i, k)
+        tg = tg + s*(ah0(i)-ahg)
+        tg = max(tg, 35.0)
+        tc = tg - t0
+        denom = 243.5 + tc
+        IF (tc>=0.0) THEN
+          es = 6.112*exp(17.67*tc/denom)
+        ELSE
+          es = exp(23.33086-6111.72784/tg+0.15215*log(tg))
+        END IF
+        qg = eps*es/(p(i,k)-es*(1.-eps))
+
+        ! Second iteration.
+
+        s = cpd + alv*alv*qg/(rrv*t(i,k)*t(i,k))
+        s = 1./s
+        ahg = cpd*tg + (cl-cpd)*qnk(i)*t(i, k) + alv*qg + gz(i, k)
+        tg = tg + s*(ah0(i)-ahg)
+        tg = max(tg, 35.0)
+        tc = tg - t0
+        denom = 243.5 + tc
+        IF (tc>=0.0) THEN
+          es = 6.112*exp(17.67*tc/denom)
+        ELSE
+          es = exp(23.33086-6111.72784/tg+0.15215*log(tg))
+        END IF
+        qg = eps*es/(p(i,k)-es*(1.-eps))
+
+        alv = lv0 - clmcpv*(t(i,k)-t0)
+        ! print*,'cpd dans convect2 ',cpd
+        ! print*,'tp(i,k),ah0(i),cl,cpd,qnk(i),t(i,k),gz(i,k),alv,qg,cpd'
+        ! print*,tp(i,k),ah0(i),cl,cpd,qnk(i),t(i,k),gz(i,k),alv,qg,cpd
+        tp(i, k) = (ah0(i)-(cl-cpd)*qnk(i)*t(i,k)-gz(i,k)-alv*qg)/cpd
+        ! if (.not.cpd.gt.1000.) then
+        ! print*,'CPD=',cpd
+        ! stop
+        ! endif
+        clw(i, k) = qnk(i) - qg
+        clw(i, k) = max(0.0, clw(i,k))
+        rg = qg/(1.-qnk(i))
+        tvp(i, k) = tp(i, k)*(1.+rg*epsi)
+      END IF
+    END DO
+  END DO
+
+  ! =====================================================================
+  ! --- SET THE PRECIPITATION EFFICIENCIES AND THE FRACTION OF
+  ! --- PRECIPITATION FALLING OUTSIDE OF CLOUD
+  ! --- THESE MAY BE FUNCTIONS OF TP(I), P(I) AND CLW(I)
+  ! =====================================================================
+
+  DO k = minorig + 1, nl
+    DO i = 1, ncum
+      IF (k>=(nk(i)+1)) THEN
+        tca = tp(i, k) - t0
+        IF (tca>=0.0) THEN
+          elacrit = elcrit
+        ELSE
+          elacrit = elcrit*(1.0-tca/tlcrit)
+        END IF
+        elacrit = max(elacrit, 0.0)
+        ep(i, k) = 1.0 - elacrit/max(clw(i,k), 1.0E-8)
+        ep(i, k) = max(ep(i,k), 0.0)
+        ep(i, k) = min(ep(i,k), 1.0)
+        sigp(i, k) = sigs
+      END IF
+    END DO
+  END DO
+
+  ! =====================================================================
+  ! --- CALCULATE VIRTUAL TEMPERATURE AND LIFTED PARCEL
+  ! --- VIRTUAL TEMPERATURE
+  ! =====================================================================
+
+  DO k = minorig + 1, nl
+    DO i = 1, ncum
+      IF (k>=(icb(i)+1)) THEN
+        tvp(i, k) = tvp(i, k)*(1.0-qnk(i)+ep(i,k)*clw(i,k))
+        ! print*,'i,k,tvp(i,k),qnk(i),ep(i,k),clw(i,k)'
+        ! print*, i,k,tvp(i,k),qnk(i),ep(i,k),clw(i,k)
+      END IF
+    END DO
+  END DO
+  DO i = 1, ncum
+    tvp(i, nlp) = tvp(i, nl) - (gz(i,nlp)-gz(i,nl))/cpd
+  END DO
+
+  ! =====================================================================
+  ! --- FIND THE FIRST MODEL LEVEL (INB1) ABOVE THE PARCEL'S
+  ! --- HIGHEST LEVEL OF NEUTRAL BUOYANCY
+  ! --- AND THE HIGHEST LEVEL OF POSITIVE CAPE (INB)
+  ! =====================================================================
+
+  DO i = 1, ncum
+    cape(i) = 0.0
+    capem(i) = 0.0
+    inb(i) = icb(i) + 1
+    inb1(i) = inb(i)
+  END DO
+
+  ! Originial Code
+
+  ! do 530 k=minorig+1,nl-1
+  ! do 520 i=1,ncum
+  ! if(k.ge.(icb(i)+1))then
+  ! by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k)
+  ! byp=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1)
+  ! cape(i)=cape(i)+by
+  ! if(by.ge.0.0)inb1(i)=k+1
+  ! if(cape(i).gt.0.0)then
+  ! inb(i)=k+1
+  ! capem(i)=cape(i)
+  ! endif
+  ! endif
+  ! 520    continue
+  ! 530  continue
+  ! do 540 i=1,ncum
+  ! byp=(tvp(i,nl)-tv(i,nl))*dph(i,nl)/p(i,nl)
+  ! cape(i)=capem(i)+byp
+  ! defrac=capem(i)-cape(i)
+  ! defrac=max(defrac,0.001)
+  ! frac(i)=-cape(i)/defrac
+  ! frac(i)=min(frac(i),1.0)
+  ! frac(i)=max(frac(i),0.0)
+  ! 540   continue
+
+  ! K Emanuel fix
+
+  ! call zilch(byp,ncum)
+  ! do 530 k=minorig+1,nl-1
+  ! do 520 i=1,ncum
+  ! if(k.ge.(icb(i)+1))then
+  ! by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k)
+  ! cape(i)=cape(i)+by
+  ! if(by.ge.0.0)inb1(i)=k+1
+  ! if(cape(i).gt.0.0)then
+  ! inb(i)=k+1
+  ! capem(i)=cape(i)
+  ! byp(i)=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1)
+  ! endif
+  ! endif
+  ! 520    continue
+  ! 530  continue
+  ! do 540 i=1,ncum
+  ! inb(i)=max(inb(i),inb1(i))
+  ! cape(i)=capem(i)+byp(i)
+  ! defrac=capem(i)-cape(i)
+  ! defrac=max(defrac,0.001)
+  ! frac(i)=-cape(i)/defrac
+  ! frac(i)=min(frac(i),1.0)
+  ! frac(i)=max(frac(i),0.0)
+  ! 540   continue
+
+  ! J Teixeira fix
+
+  CALL zilch(byp, ncum)
+  DO i = 1, ncum
+    lcape(i) = .TRUE.
+  END DO
+  DO k = minorig + 1, nl - 1
+    DO i = 1, ncum
+      IF (cape(i)<0.0) lcape(i) = .FALSE.
+      IF ((k>=(icb(i)+1)) .AND. lcape(i)) THEN
+        by = (tvp(i,k)-tv(i,k))*dph(i, k)/p(i, k)
+        byp(i) = (tvp(i,k+1)-tv(i,k+1))*dph(i, k+1)/p(i, k+1)
+        cape(i) = cape(i) + by
+        IF (by>=0.0) inb1(i) = k + 1
+        IF (cape(i)>0.0) THEN
+          inb(i) = k + 1
+          capem(i) = cape(i)
+        END IF
+      END IF
+    END DO
+  END DO
+  DO i = 1, ncum
+    cape(i) = capem(i) + byp(i)
+    defrac = capem(i) - cape(i)
+    defrac = max(defrac, 0.001)
+    frac(i) = -cape(i)/defrac
+    frac(i) = min(frac(i), 1.0)
+    frac(i) = max(frac(i), 0.0)
+  END DO
+
+  ! =====================================================================
+  ! ---   CALCULATE LIQUID WATER STATIC ENERGY OF LIFTED PARCEL
+  ! =====================================================================
+
+  ! initialization:
+  DO i = 1, ncum*nlp
+    hp(i, 1) = h(i, 1)
+  END DO
+
+  DO k = minorig + 1, nl
+    DO i = 1, ncum
+      IF ((k>=icb(i)) .AND. (k<=inb(i))) THEN
+        hp(i, k) = h(i, nk(i)) + (lv(i,k)+(cpd-cpv)*t(i,k))*ep(i, k)*clw(i, k &
+          )
+      END IF
+    END DO
+  END DO
+
+  RETURN
+END SUBROUTINE cv_undilute2
+
+SUBROUTINE cv_closure(nloc, ncum, nd, nk, icb, tv, tvp, p, ph, dph, plcl, &
+    cpn, iflag, cbmf)
+  IMPLICIT NONE
+
+  ! inputs:
+  INTEGER ncum, nd, nloc
+  INTEGER nk(nloc), icb(nloc)
+  REAL tv(nloc, nd), tvp(nloc, nd), p(nloc, nd), dph(nloc, nd)
+  REAL ph(nloc, nd+1) ! caution nd instead ndp1 to be consistent...
+  REAL plcl(nloc), cpn(nloc, nd)
+
+  ! outputs:
+  INTEGER iflag(nloc)
+  REAL cbmf(nloc) ! also an input
+
+  ! local variables:
+  INTEGER i, k, icbmax
+  REAL dtpbl(nloc), dtmin(nloc), tvpplcl(nloc), tvaplcl(nloc)
+  REAL work(nloc)
+
+  include "cvthermo.h"
+  include "cvparam.h"
+
+  ! -------------------------------------------------------------------
+  ! Compute icbmax.
+  ! -------------------------------------------------------------------
+
+  icbmax = 2
+  DO i = 1, ncum
+    icbmax = max(icbmax, icb(i))
+  END DO
+
+  ! =====================================================================
+  ! ---  CALCULATE CLOUD BASE MASS FLUX
+  ! =====================================================================
+
+  ! tvpplcl = parcel temperature lifted adiabatically from level
+  ! icb-1 to the LCL.
+  ! tvaplcl = virtual temperature at the LCL.
+
+  DO i = 1, ncum
+    dtpbl(i) = 0.0
+    tvpplcl(i) = tvp(i, icb(i)-1) - rrd*tvp(i, icb(i)-1)*(p(i,icb(i)-1)-plcl( &
+      i))/(cpn(i,icb(i)-1)*p(i,icb(i)-1))
+    tvaplcl(i) = tv(i, icb(i)) + (tvp(i,icb(i))-tvp(i,icb(i)+1))*(plcl(i)-p(i &
+      ,icb(i)))/(p(i,icb(i))-p(i,icb(i)+1))
+  END DO
+
+  ! -------------------------------------------------------------------
+  ! --- Interpolate difference between lifted parcel and
+  ! --- environmental temperatures to lifted condensation level
+  ! -------------------------------------------------------------------
+
+  ! dtpbl = average of tvp-tv in the PBL (k=nk to icb-1).
+
+  DO k = minorig, icbmax
+    DO i = 1, ncum
+      IF ((k>=nk(i)) .AND. (k<=(icb(i)-1))) THEN
+        dtpbl(i) = dtpbl(i) + (tvp(i,k)-tv(i,k))*dph(i, k)
+      END IF
+    END DO
+  END DO
+  DO i = 1, ncum
+    dtpbl(i) = dtpbl(i)/(ph(i,nk(i))-ph(i,icb(i)))
+    dtmin(i) = tvpplcl(i) - tvaplcl(i) + dtmax + dtpbl(i)
+  END DO
+
+  ! -------------------------------------------------------------------
+  ! --- Adjust cloud base mass flux
+  ! -------------------------------------------------------------------
+
+  DO i = 1, ncum
+    work(i) = cbmf(i)
+    cbmf(i) = max(0.0, (1.0-damp)*cbmf(i)+0.1*alpha*dtmin(i))
+    IF ((work(i)==0.0) .AND. (cbmf(i)==0.0)) THEN
+      iflag(i) = 3
+    END IF
+  END DO
+
+  RETURN
+END SUBROUTINE cv_closure
+
+SUBROUTINE cv_mixing(nloc, ncum, nd, icb, nk, inb, inb1, ph, t, q, qs, u, v, &
+    h, lv, qnk, hp, tv, tvp, ep, clw, cbmf, m, ment, qent, uent, vent, nent, &
+    sij, elij)
+  IMPLICIT NONE
+
+  include "cvthermo.h"
+  include "cvparam.h"
+
+  ! inputs:
+  INTEGER ncum, nd, nloc
+  INTEGER icb(nloc), inb(nloc), inb1(nloc), nk(nloc)
+  REAL cbmf(nloc), qnk(nloc)
+  REAL ph(nloc, nd+1)
+  REAL t(nloc, nd), q(nloc, nd), qs(nloc, nd), lv(nloc, nd)
+  REAL u(nloc, nd), v(nloc, nd), h(nloc, nd), hp(nloc, nd)
+  REAL tv(nloc, nd), tvp(nloc, nd), ep(nloc, nd), clw(nloc, nd)
+
+  ! outputs:
+  INTEGER nent(nloc, nd)
+  REAL m(nloc, nd), ment(nloc, nd, nd), qent(nloc, nd, nd)
+  REAL uent(nloc, nd, nd), vent(nloc, nd, nd)
+  REAL sij(nloc, nd, nd), elij(nloc, nd, nd)
+
+  ! local variables:
+  INTEGER i, j, k, ij
+  INTEGER num1, num2
+  REAL dbo, qti, bf2, anum, denom, dei, altem, cwat, stemp
+  REAL alt, qp1, smid, sjmin, sjmax, delp, delm
+  REAL work(nloc), asij(nloc), smin(nloc), scrit(nloc)
+  REAL bsum(nloc, nd)
+  LOGICAL lwork(nloc)
+
+  ! =====================================================================
+  ! --- INITIALIZE VARIOUS ARRAYS USED IN THE COMPUTATIONS
+  ! =====================================================================
+
+  DO i = 1, ncum*nlp
+    nent(i, 1) = 0
+    m(i, 1) = 0.0
+  END DO
+
+  DO k = 1, nlp
+    DO j = 1, nlp
+      DO i = 1, ncum
+        qent(i, k, j) = q(i, j)
+        uent(i, k, j) = u(i, j)
+        vent(i, k, j) = v(i, j)
+        elij(i, k, j) = 0.0
+        ment(i, k, j) = 0.0
+        sij(i, k, j) = 0.0
+      END DO
+    END DO
+  END DO
+
+  ! -------------------------------------------------------------------
+  ! --- Calculate rates of mixing,  m(i)
+  ! -------------------------------------------------------------------
+
+  CALL zilch(work, ncum)
+
+  DO j = minorig + 1, nl
+    DO i = 1, ncum
+      IF ((j>=(icb(i)+1)) .AND. (j<=inb(i))) THEN
+        k = min(j, inb1(i))
+        dbo = abs(tv(i,k+1)-tvp(i,k+1)-tv(i,k-1)+tvp(i,k-1)) + &
+          entp*0.04*(ph(i,k)-ph(i,k+1))
+        work(i) = work(i) + dbo
+        m(i, j) = cbmf(i)*dbo
+      END IF
+    END DO
+  END DO
+  DO k = minorig + 1, nl
+    DO i = 1, ncum
+      IF ((k>=(icb(i)+1)) .AND. (k<=inb(i))) THEN
+        m(i, k) = m(i, k)/work(i)
+      END IF
+    END DO
+  END DO
+
+
+  ! =====================================================================
+  ! --- CALCULATE ENTRAINED AIR MASS FLUX (ment), TOTAL WATER MIXING
+  ! --- RATIO (QENT), TOTAL CONDENSED WATER (elij), AND MIXING
+  ! --- FRACTION (sij)
+  ! =====================================================================
+
+
+  DO i = minorig + 1, nl
+    DO j = minorig + 1, nl
+      DO ij = 1, ncum
+        IF ((i>=(icb(ij)+1)) .AND. (j>=icb(ij)) .AND. (i<=inb(ij)) .AND. (j<= &
+            inb(ij))) THEN
+          qti = qnk(ij) - ep(ij, i)*clw(ij, i)
+          bf2 = 1. + lv(ij, j)*lv(ij, j)*qs(ij, j)/(rrv*t(ij,j)*t(ij,j)*cpd)
+          anum = h(ij, j) - hp(ij, i) + (cpv-cpd)*t(ij, j)*(qti-q(ij,j))
+          denom = h(ij, i) - hp(ij, i) + (cpd-cpv)*(q(ij,i)-qti)*t(ij, j)
+          dei = denom
+          IF (abs(dei)<0.01) dei = 0.01
+          sij(ij, i, j) = anum/dei
+          sij(ij, i, i) = 1.0
+          altem = sij(ij, i, j)*q(ij, i) + (1.-sij(ij,i,j))*qti - qs(ij, j)
+          altem = altem/bf2
+          cwat = clw(ij, j)*(1.-ep(ij,j))
+          stemp = sij(ij, i, j)
+          IF ((stemp<0.0 .OR. stemp>1.0 .OR. altem>cwat) .AND. j>i) THEN
+            anum = anum - lv(ij, j)*(qti-qs(ij,j)-cwat*bf2)
+            denom = denom + lv(ij, j)*(q(ij,i)-qti)
+            IF (abs(denom)<0.01) denom = 0.01
+            sij(ij, i, j) = anum/denom
+            altem = sij(ij, i, j)*q(ij, i) + (1.-sij(ij,i,j))*qti - qs(ij, j)
+            altem = altem - (bf2-1.)*cwat
+          END IF
+          IF (sij(ij,i,j)>0.0 .AND. sij(ij,i,j)<0.9) THEN
+            qent(ij, i, j) = sij(ij, i, j)*q(ij, i) + (1.-sij(ij,i,j))*qti
+            uent(ij, i, j) = sij(ij, i, j)*u(ij, i) + &
+              (1.-sij(ij,i,j))*u(ij, nk(ij))
+            vent(ij, i, j) = sij(ij, i, j)*v(ij, i) + &
+              (1.-sij(ij,i,j))*v(ij, nk(ij))
+            elij(ij, i, j) = altem
+            elij(ij, i, j) = max(0.0, elij(ij,i,j))
+            ment(ij, i, j) = m(ij, i)/(1.-sij(ij,i,j))
+            nent(ij, i) = nent(ij, i) + 1
+          END IF
+          sij(ij, i, j) = max(0.0, sij(ij,i,j))
+          sij(ij, i, j) = min(1.0, sij(ij,i,j))
+        END IF
+      END DO
+    END DO
+
+    ! ***   If no air can entrain at level i assume that updraft detrains
+    ! ***
+    ! ***   at that level and calculate detrained air flux and properties
+    ! ***
+
+    DO ij = 1, ncum
+      IF ((i>=(icb(ij)+1)) .AND. (i<=inb(ij)) .AND. (nent(ij,i)==0)) THEN
+        ment(ij, i, i) = m(ij, i)
+        qent(ij, i, i) = q(ij, nk(ij)) - ep(ij, i)*clw(ij, i)
+        uent(ij, i, i) = u(ij, nk(ij))
+        vent(ij, i, i) = v(ij, nk(ij))
+        elij(ij, i, i) = clw(ij, i)
+        sij(ij, i, i) = 1.0
+      END IF
+    END DO
+  END DO
+
+  DO i = 1, ncum
+    sij(i, inb(i), inb(i)) = 1.0
+  END DO
+
+  ! =====================================================================
+  ! ---  NORMALIZE ENTRAINED AIR MASS FLUXES
+  ! ---  TO REPRESENT EQUAL PROBABILITIES OF MIXING
+  ! =====================================================================
+
+  CALL zilch(bsum, ncum*nlp)
+  DO ij = 1, ncum
+    lwork(ij) = .FALSE.
+  END DO
+  DO i = minorig + 1, nl
+
+    num1 = 0
+    DO ij = 1, ncum
+      IF ((i>=icb(ij)+1) .AND. (i<=inb(ij))) num1 = num1 + 1
+    END DO
+    IF (num1<=0) GO TO 789
+
+    DO ij = 1, ncum
+      IF ((i>=icb(ij)+1) .AND. (i<=inb(ij))) THEN
+        lwork(ij) = (nent(ij,i)/=0)
+        qp1 = q(ij, nk(ij)) - ep(ij, i)*clw(ij, i)
+        anum = h(ij, i) - hp(ij, i) - lv(ij, i)*(qp1-qs(ij,i))
+        denom = h(ij, i) - hp(ij, i) + lv(ij, i)*(q(ij,i)-qp1)
+        IF (abs(denom)<0.01) denom = 0.01
+        scrit(ij) = anum/denom
+        alt = qp1 - qs(ij, i) + scrit(ij)*(q(ij,i)-qp1)
+        IF (scrit(ij)<0.0 .OR. alt<0.0) scrit(ij) = 1.0
+        asij(ij) = 0.0
+        smin(ij) = 1.0
+      END IF
+    END DO
+    DO j = minorig, nl
+
+      num2 = 0
+      DO ij = 1, ncum
+        IF ((i>=icb(ij)+1) .AND. (i<=inb(ij)) .AND. (j>=icb( &
+          ij)) .AND. (j<=inb(ij)) .AND. lwork(ij)) num2 = num2 + 1
+      END DO
+      IF (num2<=0) GO TO 783
+
+      DO ij = 1, ncum
+        IF ((i>=icb(ij)+1) .AND. (i<=inb(ij)) .AND. (j>=icb( &
+            ij)) .AND. (j<=inb(ij)) .AND. lwork(ij)) THEN
+          IF (sij(ij,i,j)>0.0 .AND. sij(ij,i,j)<0.9) THEN
+            IF (j>i) THEN
+              smid = min(sij(ij,i,j), scrit(ij))
+              sjmax = smid
+              sjmin = smid
+              IF (smid<smin(ij) .AND. sij(ij,i,j+1)<smid) THEN
+                smin(ij) = smid
+                sjmax = min(sij(ij,i,j+1), sij(ij,i,j), scrit(ij))
+                sjmin = max(sij(ij,i,j-1), sij(ij,i,j))
+                sjmin = min(sjmin, scrit(ij))
+              END IF
+            ELSE
+              sjmax = max(sij(ij,i,j+1), scrit(ij))
+              smid = max(sij(ij,i,j), scrit(ij))
+              sjmin = 0.0
+              IF (j>1) sjmin = sij(ij, i, j-1)
+              sjmin = max(sjmin, scrit(ij))
+            END IF
+            delp = abs(sjmax-smid)
+            delm = abs(sjmin-smid)
+            asij(ij) = asij(ij) + (delp+delm)*(ph(ij,j)-ph(ij,j+1))
+            ment(ij, i, j) = ment(ij, i, j)*(delp+delm)*(ph(ij,j)-ph(ij,j+1))
+          END IF
+        END IF
+      END DO
+783 END DO
+    DO ij = 1, ncum
+      IF ((i>=icb(ij)+1) .AND. (i<=inb(ij)) .AND. lwork(ij)) THEN
+        asij(ij) = max(1.0E-21, asij(ij))
+        asij(ij) = 1.0/asij(ij)
+        bsum(ij, i) = 0.0
+      END IF
+    END DO
+    DO j = minorig, nl + 1
+      DO ij = 1, ncum
+        IF ((i>=icb(ij)+1) .AND. (i<=inb(ij)) .AND. (j>=icb( &
+            ij)) .AND. (j<=inb(ij)) .AND. lwork(ij)) THEN
+          ment(ij, i, j) = ment(ij, i, j)*asij(ij)
+          bsum(ij, i) = bsum(ij, i) + ment(ij, i, j)
+        END IF
+      END DO
+    END DO
+    DO ij = 1, ncum
+      IF ((i>=icb(ij)+1) .AND. (i<=inb(ij)) .AND. (bsum(ij, &
+          i)<1.0E-18) .AND. lwork(ij)) THEN
+        nent(ij, i) = 0
+        ment(ij, i, i) = m(ij, i)
+        qent(ij, i, i) = q(ij, nk(ij)) - ep(ij, i)*clw(ij, i)
+        uent(ij, i, i) = u(ij, nk(ij))
+        vent(ij, i, i) = v(ij, nk(ij))
+        elij(ij, i, i) = clw(ij, i)
+        sij(ij, i, i) = 1.0
+      END IF
+    END DO
+789 END DO
+
+  RETURN
+END SUBROUTINE cv_mixing
+
+SUBROUTINE cv_unsat(nloc, ncum, nd, inb, t, q, qs, gz, u, v, p, ph, h, lv, &
+    ep, sigp, clw, m, ment, elij, iflag, mp, qp, up, vp, wt, water, evap)
+  IMPLICIT NONE
+
+
+  include "cvthermo.h"
+  include "cvparam.h"
+
+  ! inputs:
+  INTEGER ncum, nd, nloc
+  INTEGER inb(nloc)
+  REAL t(nloc, nd), q(nloc, nd), qs(nloc, nd)
+  REAL gz(nloc, nd), u(nloc, nd), v(nloc, nd)
+  REAL p(nloc, nd), ph(nloc, nd+1), h(nloc, nd)
+  REAL lv(nloc, nd), ep(nloc, nd), sigp(nloc, nd), clw(nloc, nd)
+  REAL m(nloc, nd), ment(nloc, nd, nd), elij(nloc, nd, nd)
+
+  ! outputs:
+  INTEGER iflag(nloc) ! also an input
+  REAL mp(nloc, nd), qp(nloc, nd), up(nloc, nd), vp(nloc, nd)
+  REAL water(nloc, nd), evap(nloc, nd), wt(nloc, nd)
+
+  ! local variables:
+  INTEGER i, j, k, ij, num1
+  INTEGER jtt(nloc)
+  REAL awat, coeff, qsm, afac, sigt, b6, c6, revap
+  REAL dhdp, fac, qstm, rat
+  REAL wdtrain(nloc)
+  LOGICAL lwork(nloc)
+
+  ! =====================================================================
+  ! --- PRECIPITATING DOWNDRAFT CALCULATION
+  ! =====================================================================
+
+  ! Initializations:
+
+  DO i = 1, ncum
+    DO k = 1, nl + 1
+      wt(i, k) = omtsnow
+      mp(i, k) = 0.0
+      evap(i, k) = 0.0
+      water(i, k) = 0.0
+    END DO
+  END DO
+
+  DO i = 1, ncum
+    qp(i, 1) = q(i, 1)
+    up(i, 1) = u(i, 1)
+    vp(i, 1) = v(i, 1)
+  END DO
+
+  DO k = 2, nl + 1
+    DO i = 1, ncum
+      qp(i, k) = q(i, k-1)
+      up(i, k) = u(i, k-1)
+      vp(i, k) = v(i, k-1)
+    END DO
+  END DO
+
+
+  ! ***  Check whether ep(inb)=0, if so, skip precipitating    ***
+  ! ***             downdraft calculation                      ***
+
+
+  ! ***  Integrate liquid water equation to find condensed water   ***
+  ! ***                and condensed water flux                    ***
+
+
+  DO i = 1, ncum
+    jtt(i) = 2
+    IF (ep(i,inb(i))<=0.0001) iflag(i) = 2
+    IF (iflag(i)==0) THEN
+      lwork(i) = .TRUE.
+    ELSE
+      lwork(i) = .FALSE.
+    END IF
+  END DO
+
+  ! ***                    Begin downdraft loop                    ***
+
+
+  CALL zilch(wdtrain, ncum)
+  DO i = nl + 1, 1, -1
+
+    num1 = 0
+    DO ij = 1, ncum
+      IF ((i<=inb(ij)) .AND. lwork(ij)) num1 = num1 + 1
+    END DO
+    IF (num1<=0) GO TO 899
+
+
+    ! ***        Calculate detrained precipitation             ***
+
+    DO ij = 1, ncum
+      IF ((i<=inb(ij)) .AND. (lwork(ij))) THEN
+        wdtrain(ij) = g*ep(ij, i)*m(ij, i)*clw(ij, i)
+      END IF
+    END DO
+
+    IF (i>1) THEN
+      DO j = 1, i - 1
+        DO ij = 1, ncum
+          IF ((i<=inb(ij)) .AND. (lwork(ij))) THEN
+            awat = elij(ij, j, i) - (1.-ep(ij,i))*clw(ij, i)
+            awat = max(0.0, awat)
+            wdtrain(ij) = wdtrain(ij) + g*awat*ment(ij, j, i)
+          END IF
+        END DO
+      END DO
+    END IF
+
+    ! ***    Find rain water and evaporation using provisional   ***
+    ! ***              estimates of qp(i)and qp(i-1)             ***
+
+
+    ! ***  Value of terminal velocity and coeffecient of evaporation for snow
+    ! ***
+
+    DO ij = 1, ncum
+      IF ((i<=inb(ij)) .AND. (lwork(ij))) THEN
+        coeff = coeffs
+        wt(ij, i) = omtsnow
+
+        ! ***  Value of terminal velocity and coeffecient of evaporation for
+        ! rain   ***
+
+        IF (t(ij,i)>273.0) THEN
+          coeff = coeffr
+          wt(ij, i) = omtrain
+        END IF
+        qsm = 0.5*(q(ij,i)+qp(ij,i+1))
+        afac = coeff*ph(ij, i)*(qs(ij,i)-qsm)/(1.0E4+2.0E3*ph(ij,i)*qs(ij,i))
+        afac = max(afac, 0.0)
+        sigt = sigp(ij, i)
+        sigt = max(0.0, sigt)
+        sigt = min(1.0, sigt)
+        b6 = 100.*(ph(ij,i)-ph(ij,i+1))*sigt*afac/wt(ij, i)
+        c6 = (water(ij,i+1)*wt(ij,i+1)+wdtrain(ij)/sigd)/wt(ij, i)
+        revap = 0.5*(-b6+sqrt(b6*b6+4.*c6))
+        evap(ij, i) = sigt*afac*revap
+        water(ij, i) = revap*revap
+
+        ! ***  Calculate precipitating downdraft mass flux under     ***
+        ! ***              hydrostatic approximation                 ***
+
+        IF (i>1) THEN
+          dhdp = (h(ij,i)-h(ij,i-1))/(p(ij,i-1)-p(ij,i))
+          dhdp = max(dhdp, 10.0)
+          mp(ij, i) = 100.*ginv*lv(ij, i)*sigd*evap(ij, i)/dhdp
+          mp(ij, i) = max(mp(ij,i), 0.0)
+
+          ! ***   Add small amount of inertia to downdraft              ***
+
+          fac = 20.0/(ph(ij,i-1)-ph(ij,i))
+          mp(ij, i) = (fac*mp(ij,i+1)+mp(ij,i))/(1.+fac)
+
+          ! ***      Force mp to decrease linearly to zero
+          ! ***
+          ! ***      between about 950 mb and the surface
+          ! ***
+
+          IF (p(ij,i)>(0.949*p(ij,1))) THEN
+            jtt(ij) = max(jtt(ij), i)
+            mp(ij, i) = mp(ij, jtt(ij))*(p(ij,1)-p(ij,i))/ &
+              (p(ij,1)-p(ij,jtt(ij)))
+          END IF
+        END IF
+
+        ! ***       Find mixing ratio of precipitating downdraft     ***
+
+        IF (i/=inb(ij)) THEN
+          IF (i==1) THEN
+            qstm = qs(ij, 1)
+          ELSE
+            qstm = qs(ij, i-1)
+          END IF
+          IF (mp(ij,i)>mp(ij,i+1)) THEN
+            rat = mp(ij, i+1)/mp(ij, i)
+            qp(ij, i) = qp(ij, i+1)*rat + q(ij, i)*(1.0-rat) + &
+              100.*ginv*sigd*(ph(ij,i)-ph(ij,i+1))*(evap(ij,i)/mp(ij,i))
+            up(ij, i) = up(ij, i+1)*rat + u(ij, i)*(1.-rat)
+            vp(ij, i) = vp(ij, i+1)*rat + v(ij, i)*(1.-rat)
+          ELSE
+            IF (mp(ij,i+1)>0.0) THEN
+              qp(ij, i) = (gz(ij,i+1)-gz(ij,i)+qp(ij,i+1)*(lv(ij,i+1)+t(ij, &
+                i+1)*(cl-cpd))+cpd*(t(ij,i+1)-t(ij, &
+                i)))/(lv(ij,i)+t(ij,i)*(cl-cpd))
+              up(ij, i) = up(ij, i+1)
+              vp(ij, i) = vp(ij, i+1)
+            END IF
+          END IF
+          qp(ij, i) = min(qp(ij,i), qstm)
+          qp(ij, i) = max(qp(ij,i), 0.0)
+        END IF
+      END IF
+    END DO
+899 END DO
+
+  RETURN
+END SUBROUTINE cv_unsat
+
+SUBROUTINE cv_yield(nloc, ncum, nd, nk, icb, inb, delt, t, q, u, v, gz, p, &
+    ph, h, hp, lv, cpn, ep, clw, frac, m, mp, qp, up, vp, wt, water, evap, &
+    ment, qent, uent, vent, nent, elij, tv, tvp, iflag, wd, qprime, tprime, &
+    precip, cbmf, ft, fq, fu, fv, ma, qcondc)
+  IMPLICIT NONE
+
+  include "cvthermo.h"
+  include "cvparam.h"
+
+  ! inputs
+  INTEGER ncum, nd, nloc
+  INTEGER nk(nloc), icb(nloc), inb(nloc)
+  INTEGER nent(nloc, nd)
+  REAL delt
+  REAL t(nloc, nd), q(nloc, nd), u(nloc, nd), v(nloc, nd)
+  REAL gz(nloc, nd)
+  REAL p(nloc, nd), ph(nloc, nd+1), h(nloc, nd)
+  REAL hp(nloc, nd), lv(nloc, nd)
+  REAL cpn(nloc, nd), ep(nloc, nd), clw(nloc, nd), frac(nloc)
+  REAL m(nloc, nd), mp(nloc, nd), qp(nloc, nd)
+  REAL up(nloc, nd), vp(nloc, nd)
+  REAL wt(nloc, nd), water(nloc, nd), evap(nloc, nd)
+  REAL ment(nloc, nd, nd), qent(nloc, nd, nd), elij(nloc, nd, nd)
+  REAL uent(nloc, nd, nd), vent(nloc, nd, nd)
+  REAL tv(nloc, nd), tvp(nloc, nd)
+
+  ! outputs
+  INTEGER iflag(nloc) ! also an input
+  REAL cbmf(nloc) ! also an input
+  REAL wd(nloc), tprime(nloc), qprime(nloc)
+  REAL precip(nloc)
+  REAL ft(nloc, nd), fq(nloc, nd), fu(nloc, nd), fv(nloc, nd)
+  REAL ma(nloc, nd)
+  REAL qcondc(nloc, nd)
+
+  ! local variables
+  INTEGER i, j, ij, k, num1
+  REAL dpinv, cpinv, awat, fqold, ftold, fuold, fvold, delti
+  REAL work(nloc), am(nloc), amp1(nloc), ad(nloc)
+  REAL ents(nloc), uav(nloc), vav(nloc), lvcp(nloc, nd)
+  REAL qcond(nloc, nd), nqcond(nloc, nd), wa(nloc, nd) ! cld
+  REAL siga(nloc, nd), ax(nloc, nd), mac(nloc, nd) ! cld
+
+
+  ! -- initializations:
+
+  delti = 1.0/delt
+
+  DO i = 1, ncum
+    precip(i) = 0.0
+    wd(i) = 0.0
+    tprime(i) = 0.0
+    qprime(i) = 0.0
+    DO k = 1, nl + 1
+      ft(i, k) = 0.0
+      fu(i, k) = 0.0
+      fv(i, k) = 0.0
+      fq(i, k) = 0.0
+      lvcp(i, k) = lv(i, k)/cpn(i, k)
+      qcondc(i, k) = 0.0 ! cld
+      qcond(i, k) = 0.0 ! cld
+      nqcond(i, k) = 0.0 ! cld
+    END DO
+  END DO
+
+
+  ! ***  Calculate surface precipitation in mm/day     ***
+
+  DO i = 1, ncum
+    IF (iflag(i)<=1) THEN
+      ! c            precip(i)=precip(i)+wt(i,1)*sigd*water(i,1)*3600.*24000.
+      ! c     &                /(rowl*g)
+      ! c            precip(i)=precip(i)*delt/86400.
+      precip(i) = wt(i, 1)*sigd*water(i, 1)*86400/g
+    END IF
+  END DO
+
+
+  ! ***  Calculate downdraft velocity scale and surface temperature and  ***
+  ! ***                    water vapor fluctuations                      ***
+
+  DO i = 1, ncum
+    wd(i) = betad*abs(mp(i,icb(i)))*0.01*rrd*t(i, icb(i))/(sigd*p(i,icb(i)))
+    qprime(i) = 0.5*(qp(i,1)-q(i,1))
+    tprime(i) = lv0*qprime(i)/cpd
+  END DO
+
+  ! ***  Calculate tendencies of lowest level potential temperature  ***
+  ! ***                      and mixing ratio                        ***
+
+  DO i = 1, ncum
+    work(i) = 0.01/(ph(i,1)-ph(i,2))
+    am(i) = 0.0
+  END DO
+  DO k = 2, nl
+    DO i = 1, ncum
+      IF ((nk(i)==1) .AND. (k<=inb(i)) .AND. (nk(i)==1)) THEN
+        am(i) = am(i) + m(i, k)
+      END IF
+    END DO
+  END DO
+  DO i = 1, ncum
+    IF ((g*work(i)*am(i))>=delti) iflag(i) = 1
+    ft(i, 1) = ft(i, 1) + g*work(i)*am(i)*(t(i,2)-t(i,1)+(gz(i,2)-gz(i, &
+      1))/cpn(i,1))
+    ft(i, 1) = ft(i, 1) - lvcp(i, 1)*sigd*evap(i, 1)
+    ft(i, 1) = ft(i, 1) + sigd*wt(i, 2)*(cl-cpd)*water(i, 2)*(t(i,2)-t(i,1))* &
+      work(i)/cpn(i, 1)
+    fq(i, 1) = fq(i, 1) + g*mp(i, 2)*(qp(i,2)-q(i,1))*work(i) + &
+      sigd*evap(i, 1)
+    fq(i, 1) = fq(i, 1) + g*am(i)*(q(i,2)-q(i,1))*work(i)
+    fu(i, 1) = fu(i, 1) + g*work(i)*(mp(i,2)*(up(i,2)-u(i,1))+am(i)*(u(i, &
+      2)-u(i,1)))
+    fv(i, 1) = fv(i, 1) + g*work(i)*(mp(i,2)*(vp(i,2)-v(i,1))+am(i)*(v(i, &
+      2)-v(i,1)))
+  END DO
+  DO j = 2, nl
+    DO i = 1, ncum
+      IF (j<=inb(i)) THEN
+        fq(i, 1) = fq(i, 1) + g*work(i)*ment(i, j, 1)*(qent(i,j,1)-q(i,1))
+        fu(i, 1) = fu(i, 1) + g*work(i)*ment(i, j, 1)*(uent(i,j,1)-u(i,1))
+        fv(i, 1) = fv(i, 1) + g*work(i)*ment(i, j, 1)*(vent(i,j,1)-v(i,1))
+      END IF
+    END DO
+  END DO
+
+  ! ***  Calculate tendencies of potential temperature and mixing ratio  ***
+  ! ***               at levels above the lowest level                   ***
+
+  ! ***  First find the net saturated updraft and downdraft mass fluxes  ***
+  ! ***                      through each level                          ***
+
+  DO i = 2, nl + 1
+
+    num1 = 0
+    DO ij = 1, ncum
+      IF (i<=inb(ij)) num1 = num1 + 1
+    END DO
+    IF (num1<=0) GO TO 1500
+
+    CALL zilch(amp1, ncum)
+    CALL zilch(ad, ncum)
+
+    DO k = i + 1, nl + 1
+      DO ij = 1, ncum
+        IF ((i>=nk(ij)) .AND. (i<=inb(ij)) .AND. (k<=(inb(ij)+1))) THEN
+          amp1(ij) = amp1(ij) + m(ij, k)
+        END IF
+      END DO
+    END DO
+
+    DO k = 1, i
+      DO j = i + 1, nl + 1
+        DO ij = 1, ncum
+          IF ((j<=(inb(ij)+1)) .AND. (i<=inb(ij))) THEN
+            amp1(ij) = amp1(ij) + ment(ij, k, j)
+          END IF
+        END DO
+      END DO
+    END DO
+    DO k = 1, i - 1
+      DO j = i, nl + 1
+        DO ij = 1, ncum
+          IF ((i<=inb(ij)) .AND. (j<=inb(ij))) THEN
+            ad(ij) = ad(ij) + ment(ij, j, k)
+          END IF
+        END DO
+      END DO
+    END DO
+
+    DO ij = 1, ncum
+      IF (i<=inb(ij)) THEN
+        dpinv = 0.01/(ph(ij,i)-ph(ij,i+1))
+        cpinv = 1.0/cpn(ij, i)
+
+        ft(ij, i) = ft(ij, i) + g*dpinv*(amp1(ij)*(t(ij,i+1)-t(ij, &
+          i)+(gz(ij,i+1)-gz(ij,i))*cpinv)-ad(ij)*(t(ij,i)-t(ij, &
+          i-1)+(gz(ij,i)-gz(ij,i-1))*cpinv)) - sigd*lvcp(ij, i)*evap(ij, i)
+        ft(ij, i) = ft(ij, i) + g*dpinv*ment(ij, i, i)*(hp(ij,i)-h(ij,i)+t(ij &
+          ,i)*(cpv-cpd)*(q(ij,i)-qent(ij,i,i)))*cpinv
+        ft(ij, i) = ft(ij, i) + sigd*wt(ij, i+1)*(cl-cpd)*water(ij, i+1)*(t( &
+          ij,i+1)-t(ij,i))*dpinv*cpinv
+        fq(ij, i) = fq(ij, i) + g*dpinv*(amp1(ij)*(q(ij,i+1)-q(ij, &
+          i))-ad(ij)*(q(ij,i)-q(ij,i-1)))
+        fu(ij, i) = fu(ij, i) + g*dpinv*(amp1(ij)*(u(ij,i+1)-u(ij, &
+          i))-ad(ij)*(u(ij,i)-u(ij,i-1)))
+        fv(ij, i) = fv(ij, i) + g*dpinv*(amp1(ij)*(v(ij,i+1)-v(ij, &
+          i))-ad(ij)*(v(ij,i)-v(ij,i-1)))
+      END IF
+    END DO
+    DO k = 1, i - 1
+      DO ij = 1, ncum
+        IF (i<=inb(ij)) THEN
+          awat = elij(ij, k, i) - (1.-ep(ij,i))*clw(ij, i)
+          awat = max(awat, 0.0)
+          fq(ij, i) = fq(ij, i) + g*dpinv*ment(ij, k, i)*(qent(ij,k,i)-awat-q &
+            (ij,i))
+          fu(ij, i) = fu(ij, i) + g*dpinv*ment(ij, k, i)*(uent(ij,k,i)-u(ij,i &
+            ))
+          fv(ij, i) = fv(ij, i) + g*dpinv*ment(ij, k, i)*(vent(ij,k,i)-v(ij,i &
+            ))
+          ! (saturated updrafts resulting from mixing)               ! cld
+          qcond(ij, i) = qcond(ij, i) + (elij(ij,k,i)-awat) ! cld
+          nqcond(ij, i) = nqcond(ij, i) + 1. ! cld
+        END IF
+      END DO
+    END DO
+    DO k = i, nl + 1
+      DO ij = 1, ncum
+        IF ((i<=inb(ij)) .AND. (k<=inb(ij))) THEN
+          fq(ij, i) = fq(ij, i) + g*dpinv*ment(ij, k, i)*(qent(ij,k,i)-q(ij,i &
+            ))
+          fu(ij, i) = fu(ij, i) + g*dpinv*ment(ij, k, i)*(uent(ij,k,i)-u(ij,i &
+            ))
+          fv(ij, i) = fv(ij, i) + g*dpinv*ment(ij, k, i)*(vent(ij,k,i)-v(ij,i &
+            ))
+        END IF
+      END DO
+    END DO
+    DO ij = 1, ncum
+      IF (i<=inb(ij)) THEN
+        fq(ij, i) = fq(ij, i) + sigd*evap(ij, i) + g*(mp(ij,i+1)*(qp(ij, &
+          i+1)-q(ij,i))-mp(ij,i)*(qp(ij,i)-q(ij,i-1)))*dpinv
+        fu(ij, i) = fu(ij, i) + g*(mp(ij,i+1)*(up(ij,i+1)-u(ij, &
+          i))-mp(ij,i)*(up(ij,i)-u(ij,i-1)))*dpinv
+        fv(ij, i) = fv(ij, i) + g*(mp(ij,i+1)*(vp(ij,i+1)-v(ij, &
+          i))-mp(ij,i)*(vp(ij,i)-v(ij,i-1)))*dpinv
+        ! (saturated downdrafts resulting from mixing)               ! cld
+        DO k = i + 1, inb(ij) ! cld
+          qcond(ij, i) = qcond(ij, i) + elij(ij, k, i) ! cld
+          nqcond(ij, i) = nqcond(ij, i) + 1. ! cld
+        END DO ! cld
+        ! (particular case: no detraining level is found)            ! cld
+        IF (nent(ij,i)==0) THEN ! cld
+          qcond(ij, i) = qcond(ij, i) + (1.-ep(ij,i))*clw(ij, i) ! cld
+          nqcond(ij, i) = nqcond(ij, i) + 1. ! cld
+        END IF ! cld
+        IF (nqcond(ij,i)/=0.) THEN ! cld
+          qcond(ij, i) = qcond(ij, i)/nqcond(ij, i) ! cld
+        END IF ! cld
+      END IF
+    END DO
+1500 END DO
+
+  ! *** Adjust tendencies at top of convection layer to reflect  ***
+  ! ***       actual position of the level zero cape             ***
+
+  DO ij = 1, ncum
+    fqold = fq(ij, inb(ij))
+    fq(ij, inb(ij)) = fq(ij, inb(ij))*(1.-frac(ij))
+    fq(ij, inb(ij)-1) = fq(ij, inb(ij)-1) + frac(ij)*fqold*((ph(ij, &
+      inb(ij))-ph(ij,inb(ij)+1))/(ph(ij,inb(ij)-1)-ph(ij, &
+      inb(ij))))*lv(ij, inb(ij))/lv(ij, inb(ij)-1)
+    ftold = ft(ij, inb(ij))
+    ft(ij, inb(ij)) = ft(ij, inb(ij))*(1.-frac(ij))
+    ft(ij, inb(ij)-1) = ft(ij, inb(ij)-1) + frac(ij)*ftold*((ph(ij, &
+      inb(ij))-ph(ij,inb(ij)+1))/(ph(ij,inb(ij)-1)-ph(ij, &
+      inb(ij))))*cpn(ij, inb(ij))/cpn(ij, inb(ij)-1)
+    fuold = fu(ij, inb(ij))
+    fu(ij, inb(ij)) = fu(ij, inb(ij))*(1.-frac(ij))
+    fu(ij, inb(ij)-1) = fu(ij, inb(ij)-1) + frac(ij)*fuold*((ph(ij, &
+      inb(ij))-ph(ij,inb(ij)+1))/(ph(ij,inb(ij)-1)-ph(ij,inb(ij))))
+    fvold = fv(ij, inb(ij))
+    fv(ij, inb(ij)) = fv(ij, inb(ij))*(1.-frac(ij))
+    fv(ij, inb(ij)-1) = fv(ij, inb(ij)-1) + frac(ij)*fvold*((ph(ij, &
+      inb(ij))-ph(ij,inb(ij)+1))/(ph(ij,inb(ij)-1)-ph(ij,inb(ij))))
+  END DO
+
+  ! ***   Very slightly adjust tendencies to force exact   ***
+  ! ***     enthalpy, momentum and tracer conservation     ***
+
+  DO ij = 1, ncum
+    ents(ij) = 0.0
+    uav(ij) = 0.0
+    vav(ij) = 0.0
+    DO i = 1, inb(ij)
+      ents(ij) = ents(ij) + (cpn(ij,i)*ft(ij,i)+lv(ij,i)*fq(ij,i))*(ph(ij,i)- &
+        ph(ij,i+1))
+      uav(ij) = uav(ij) + fu(ij, i)*(ph(ij,i)-ph(ij,i+1))
+      vav(ij) = vav(ij) + fv(ij, i)*(ph(ij,i)-ph(ij,i+1))
+    END DO
+  END DO
+  DO ij = 1, ncum
+    ents(ij) = ents(ij)/(ph(ij,1)-ph(ij,inb(ij)+1))
+    uav(ij) = uav(ij)/(ph(ij,1)-ph(ij,inb(ij)+1))
+    vav(ij) = vav(ij)/(ph(ij,1)-ph(ij,inb(ij)+1))
+  END DO
+  DO ij = 1, ncum
+    DO i = 1, inb(ij)
+      ft(ij, i) = ft(ij, i) - ents(ij)/cpn(ij, i)
+      fu(ij, i) = (1.-cu)*(fu(ij,i)-uav(ij))
+      fv(ij, i) = (1.-cu)*(fv(ij,i)-vav(ij))
+    END DO
+  END DO
+
+  DO k = 1, nl + 1
+    DO i = 1, ncum
+      IF ((q(i,k)+delt*fq(i,k))<0.0) iflag(i) = 10
+    END DO
+  END DO
+
+
+  DO i = 1, ncum
+    IF (iflag(i)>2) THEN
+      precip(i) = 0.0
+      cbmf(i) = 0.0
+    END IF
+  END DO
+  DO k = 1, nl
+    DO i = 1, ncum
+      IF (iflag(i)>2) THEN
+        ft(i, k) = 0.0
+        fq(i, k) = 0.0
+        fu(i, k) = 0.0
+        fv(i, k) = 0.0
+        qcondc(i, k) = 0.0 ! cld
+      END IF
+    END DO
+  END DO
+
+  DO k = 1, nl + 1
+    DO i = 1, ncum
+      ma(i, k) = 0.
+    END DO
+  END DO
+  DO k = nl, 1, -1
+    DO i = 1, ncum
+      ma(i, k) = ma(i, k+1) + m(i, k)
+    END DO
+  END DO
+
+
+  ! *** diagnose the in-cloud mixing ratio   ***            ! cld
+  ! ***           of condensed water         ***            ! cld
+  ! ! cld
+  DO ij = 1, ncum ! cld
+    DO i = 1, nd ! cld
+      mac(ij, i) = 0.0 ! cld
+      wa(ij, i) = 0.0 ! cld
+      siga(ij, i) = 0.0 ! cld
+    END DO ! cld
+    DO i = nk(ij), inb(ij) ! cld
+      DO k = i + 1, inb(ij) + 1 ! cld
+        mac(ij, i) = mac(ij, i) + m(ij, k) ! cld
+      END DO ! cld
+    END DO ! cld
+    DO i = icb(ij), inb(ij) - 1 ! cld
+      ax(ij, i) = 0. ! cld
+      DO j = icb(ij), i ! cld
+        ax(ij, i) = ax(ij, i) + rrd*(tvp(ij,j)-tv(ij,j)) & ! cld
+          *(ph(ij,j)-ph(ij,j+1))/p(ij, j) ! cld
+      END DO ! cld
+      IF (ax(ij,i)>0.0) THEN ! cld
+        wa(ij, i) = sqrt(2.*ax(ij,i)) ! cld
+      END IF ! cld
+    END DO ! cld
+    DO i = 1, nl ! cld
+      IF (wa(ij,i)>0.0) &          ! cld
+        siga(ij, i) = mac(ij, i)/wa(ij, i) & ! cld
+        *rrd*tvp(ij, i)/p(ij, i)/100./delta ! cld
+      siga(ij, i) = min(siga(ij,i), 1.0) ! cld
+      qcondc(ij, i) = siga(ij, i)*clw(ij, i)*(1.-ep(ij,i)) & ! cld
+        +(1.-siga(ij,i))*qcond(ij, i) ! cld
+    END DO ! cld
+  END DO ! cld
+
+  RETURN
+END SUBROUTINE cv_yield
+
+SUBROUTINE cv_uncompress(nloc, len, ncum, nd, idcum, iflag, precip, cbmf, ft, &
+    fq, fu, fv, ma, qcondc, iflag1, precip1, cbmf1, ft1, fq1, fu1, fv1, ma1, &
+    qcondc1)
+  IMPLICIT NONE
+
+  include "cvparam.h"
+
+  ! inputs:
+  INTEGER len, ncum, nd, nloc
+  INTEGER idcum(nloc)
+  INTEGER iflag(nloc)
+  REAL precip(nloc), cbmf(nloc)
+  REAL ft(nloc, nd), fq(nloc, nd), fu(nloc, nd), fv(nloc, nd)
+  REAL ma(nloc, nd)
+  REAL qcondc(nloc, nd) !cld
+
+  ! outputs:
+  INTEGER iflag1(len)
+  REAL precip1(len), cbmf1(len)
+  REAL ft1(len, nd), fq1(len, nd), fu1(len, nd), fv1(len, nd)
+  REAL ma1(len, nd)
+  REAL qcondc1(len, nd) !cld
+
+  ! local variables:
+  INTEGER i, k
+
+  DO i = 1, ncum
+    precip1(idcum(i)) = precip(i)
+    cbmf1(idcum(i)) = cbmf(i)
+    iflag1(idcum(i)) = iflag(i)
+  END DO
+
+  DO k = 1, nl
+    DO i = 1, ncum
+      ft1(idcum(i), k) = ft(i, k)
+      fq1(idcum(i), k) = fq(i, k)
+      fu1(idcum(i), k) = fu(i, k)
+      fv1(idcum(i), k) = fv(i, k)
+      ma1(idcum(i), k) = ma(i, k)
+      qcondc1(idcum(i), k) = qcondc(i, k)
+    END DO
+  END DO
+
+  RETURN
+END SUBROUTINE cv_uncompress
+
Index: DZ6/trunk/libf/phylmdiso/cvltr.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/cvltr.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/cvltr.F90
Index: /LMDZ6/trunk/libf/phylmdiso/cvltr.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/cvltr.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/cvltr.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/cvltr.f90
Index: DZ6/trunk/libf/phylmdiso/cvltr_noscav.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/cvltr_noscav.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/cvltr_noscav.F90
Index: /LMDZ6/trunk/libf/phylmdiso/cvltr_noscav.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/cvltr_noscav.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/cvltr_noscav.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/cvltr_noscav.f90
Index: DZ6/trunk/libf/phylmdiso/cvltr_scav.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/cvltr_scav.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/cvltr_scav.F90
Index: /LMDZ6/trunk/libf/phylmdiso/cvltr_scav.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/cvltr_scav.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/cvltr_scav.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/cvltr_scav.f90
Index: DZ6/trunk/libf/phylmdiso/cvltr_spl.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/cvltr_spl.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/cvltr_spl.F90
Index: /LMDZ6/trunk/libf/phylmdiso/cvltr_spl.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/cvltr_spl.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/cvltr_spl.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/cvltr_spl.f90
Index: DZ6/trunk/libf/phylmdiso/cvltrorig.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/cvltrorig.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/cvltrorig.F90
Index: /LMDZ6/trunk/libf/phylmdiso/cvltrorig.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/cvltrorig.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/cvltrorig.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/cvltrorig.f90
Index: DZ6/trunk/libf/phylmdiso/diag_slp.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/diag_slp.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/diag_slp.F90
Index: /LMDZ6/trunk/libf/phylmdiso/diag_slp.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/diag_slp.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/diag_slp.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/diag_slp.f90
Index: DZ6/trunk/libf/phylmdiso/diagphy.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/diagphy.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/diagphy.F90
Index: /LMDZ6/trunk/libf/phylmdiso/diagphy.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/diagphy.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/diagphy.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/diagphy.f90
Index: DZ6/trunk/libf/phylmdiso/dimphy.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/dimphy.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/dimphy.F90
Index: /LMDZ6/trunk/libf/phylmdiso/dimphy.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/dimphy.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/dimphy.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/dimphy.f90
Index: DZ6/trunk/libf/phylmdiso/ecumev6_flux.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/ecumev6_flux.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/ecumev6_flux.F90
Index: /LMDZ6/trunk/libf/phylmdiso/ecumev6_flux.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/ecumev6_flux.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/ecumev6_flux.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/ecumev6_flux.f90
Index: DZ6/trunk/libf/phylmdiso/ener_conserv.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/ener_conserv.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/ener_conserv.F90
Index: /LMDZ6/trunk/libf/phylmdiso/ener_conserv.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/ener_conserv.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/ener_conserv.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/ener_conserv.f90
Index: DZ6/trunk/libf/phylmdiso/evappot.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/evappot.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/evappot.F90
Index: /LMDZ6/trunk/libf/phylmdiso/evappot.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/evappot.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/evappot.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/evappot.f90
Index: DZ6/trunk/libf/phylmdiso/fisrtilp_tr.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/fisrtilp_tr.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/fisrtilp_tr.F90
Index: /LMDZ6/trunk/libf/phylmdiso/fisrtilp_tr.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/fisrtilp_tr.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/fisrtilp_tr.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/fisrtilp_tr.f90
Index: DZ6/trunk/libf/phylmdiso/flott_gwd_rando_m.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/flott_gwd_rando_m.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/flott_gwd_rando_m.F90
Index: /LMDZ6/trunk/libf/phylmdiso/flott_gwd_rando_m.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/flott_gwd_rando_m.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/flott_gwd_rando_m.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/flott_gwd_rando_m.f90
Index: DZ6/trunk/libf/phylmdiso/flxtr.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/flxtr.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/flxtr.F90
Index: /LMDZ6/trunk/libf/phylmdiso/flxtr.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/flxtr.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/flxtr.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/flxtr.f90
Index: DZ6/trunk/libf/phylmdiso/freinage.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/freinage.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/freinage.F90
Index: /LMDZ6/trunk/libf/phylmdiso/freinage.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/freinage.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/freinage.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/freinage.f90
Index: DZ6/trunk/libf/phylmdiso/geo2atm.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/geo2atm.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/geo2atm.F90
Index: /LMDZ6/trunk/libf/phylmdiso/geo2atm.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/geo2atm.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/geo2atm.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/geo2atm.f90
Index: DZ6/trunk/libf/phylmdiso/global_mean.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/global_mean.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/global_mean.F90
Index: /LMDZ6/trunk/libf/phylmdiso/global_mean.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/global_mean.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/global_mean.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/global_mean.f90
Index: DZ6/trunk/libf/phylmdiso/gr_fi_ecrit.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/gr_fi_ecrit.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/gr_fi_ecrit.F90
Index: /LMDZ6/trunk/libf/phylmdiso/gr_fi_ecrit.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/gr_fi_ecrit.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/gr_fi_ecrit.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/gr_fi_ecrit.f90
Index: DZ6/trunk/libf/phylmdiso/grid_noro_m.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/grid_noro_m.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/grid_noro_m.F90
Index: /LMDZ6/trunk/libf/phylmdiso/grid_noro_m.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/grid_noro_m.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/grid_noro_m.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/grid_noro_m.f90
Index: DZ6/trunk/libf/phylmdiso/haut2bas.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/haut2bas.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/haut2bas.F90
Index: /LMDZ6/trunk/libf/phylmdiso/haut2bas.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/haut2bas.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/haut2bas.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/haut2bas.f90
Index: DZ6/trunk/libf/phylmdiso/hbtm2l.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/hbtm2l.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/hbtm2l.F90
Index: /LMDZ6/trunk/libf/phylmdiso/hbtm2l.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/hbtm2l.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/hbtm2l.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/hbtm2l.f90
Index: DZ6/trunk/libf/phylmdiso/hbtm_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/hbtm_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/hbtm_mod.F90
Index: /LMDZ6/trunk/libf/phylmdiso/hbtm_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/hbtm_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/hbtm_mod.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/hbtm_mod.f90
Index: DZ6/trunk/libf/phylmdiso/hines_gwd.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/hines_gwd.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/hines_gwd.F90
Index: /LMDZ6/trunk/libf/phylmdiso/hines_gwd.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/hines_gwd.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/hines_gwd.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/hines_gwd.f90
Index: DZ6/trunk/libf/phylmdiso/histo_o500_pctau.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/histo_o500_pctau.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/histo_o500_pctau.F90
Index: /LMDZ6/trunk/libf/phylmdiso/histo_o500_pctau.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/histo_o500_pctau.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/histo_o500_pctau.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/histo_o500_pctau.f90
Index: DZ6/trunk/libf/phylmdiso/homogene.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/homogene.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/homogene.F90
Index: /LMDZ6/trunk/libf/phylmdiso/homogene.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/homogene.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/homogene.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/homogene.f90
Index: DZ6/trunk/libf/phylmdiso/hydrol.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/hydrol.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/hydrol.F90
Index: /LMDZ6/trunk/libf/phylmdiso/hydrol.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/hydrol.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/hydrol.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/hydrol.f90
Index: DZ6/trunk/libf/phylmdiso/icefrac_lsc_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/icefrac_lsc_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/icefrac_lsc_mod.F90
Index: /LMDZ6/trunk/libf/phylmdiso/icefrac_lsc_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/icefrac_lsc_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/icefrac_lsc_mod.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/icefrac_lsc_mod.f90
Index: DZ6/trunk/libf/phylmdiso/indice_sol_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/indice_sol_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/indice_sol_mod.F90
Index: /LMDZ6/trunk/libf/phylmdiso/indice_sol_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/indice_sol_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/indice_sol_mod.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/indice_sol_mod.f90
Index: DZ6/trunk/libf/phylmdiso/ini_COSP.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/ini_COSP.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/ini_COSP.F90
Index: /LMDZ6/trunk/libf/phylmdiso/ini_COSP.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/ini_COSP.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/ini_COSP.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/ini_COSP.f90
Index: DZ6/trunk/libf/phylmdiso/ini_csts.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/ini_csts.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/ini_csts.F90
Index: /LMDZ6/trunk/libf/phylmdiso/ini_csts.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/ini_csts.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/ini_csts.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/ini_csts.f90
Index: DZ6/trunk/libf/phylmdiso/ini_undefSTD.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/ini_undefSTD.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/ini_undefSTD.F90
Index: /LMDZ6/trunk/libf/phylmdiso/ini_undefSTD.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/ini_undefSTD.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/ini_undefSTD.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/ini_undefSTD.f90
Index: DZ6/trunk/libf/phylmdiso/ini_wake.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/ini_wake.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/ini_wake.F90
Index: /LMDZ6/trunk/libf/phylmdiso/ini_wake.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/ini_wake.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/ini_wake.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/ini_wake.f90
Index: DZ6/trunk/libf/phylmdiso/inifis_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/inifis_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/inifis_mod.F90
Index: /LMDZ6/trunk/libf/phylmdiso/inifis_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/inifis_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/inifis_mod.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/inifis_mod.f90
Index: DZ6/trunk/libf/phylmdiso/iniorbit.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/iniorbit.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/iniorbit.F90
Index: /LMDZ6/trunk/libf/phylmdiso/iniorbit.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/iniorbit.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/iniorbit.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/iniorbit.f90
Index: DZ6/trunk/libf/phylmdiso/init_be.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/init_be.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/init_be.F90
Index: /LMDZ6/trunk/libf/phylmdiso/init_be.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/init_be.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/init_be.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/init_be.f90
Index: DZ6/trunk/libf/phylmdiso/initphysto.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/initphysto.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/initphysto.F90
Index: /LMDZ6/trunk/libf/phylmdiso/initphysto.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/initphysto.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/initphysto.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/initphysto.f90
Index: DZ6/trunk/libf/phylmdiso/initrrnpb.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/initrrnpb.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/initrrnpb.F90
Index: /LMDZ6/trunk/libf/phylmdiso/initrrnpb.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/initrrnpb.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/initrrnpb.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/initrrnpb.f90
Index: DZ6/trunk/libf/phylmdiso/interfoce_lim.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/interfoce_lim.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/interfoce_lim.F90
Index: /LMDZ6/trunk/libf/phylmdiso/interfoce_lim.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/interfoce_lim.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/interfoce_lim.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/interfoce_lim.f90
Index: DZ6/trunk/libf/phylmdiso/iostart.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/iostart.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/iostart.F90
Index: /LMDZ6/trunk/libf/phylmdiso/iostart.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/iostart.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/iostart.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/iostart.f90
Index: DZ6/trunk/libf/phylmdiso/iotd_ecrit.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/iotd_ecrit.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/iotd_ecrit.F90
Index: /LMDZ6/trunk/libf/phylmdiso/iotd_ecrit.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/iotd_ecrit.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/iotd_ecrit.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/iotd_ecrit.f90
Index: DZ6/trunk/libf/phylmdiso/iotd_fin.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/iotd_fin.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/iotd_fin.F90
Index: /LMDZ6/trunk/libf/phylmdiso/iotd_fin.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/iotd_fin.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/iotd_fin.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/iotd_fin.f90
Index: DZ6/trunk/libf/phylmdiso/iotd_ini.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/iotd_ini.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/iotd_ini.F90
Index: /LMDZ6/trunk/libf/phylmdiso/iotd_ini.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/iotd_ini.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/iotd_ini.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/iotd_ini.f90
Index: DZ6/trunk/libf/phylmdiso/isccp_cloud_types.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/isccp_cloud_types.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/isccp_cloud_types.F90
Index: /LMDZ6/trunk/libf/phylmdiso/isccp_cloud_types.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/isccp_cloud_types.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/isccp_cloud_types.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/isccp_cloud_types.f90
Index: DZ6/trunk/libf/phylmdiso/limit_slab.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/limit_slab.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/limit_slab.F90
Index: /LMDZ6/trunk/libf/phylmdiso/limit_slab.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/limit_slab.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/limit_slab.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/limit_slab.f90
Index: DZ6/trunk/libf/phylmdiso/lmdz_atke_exchange_coeff.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/lmdz_atke_exchange_coeff.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/lmdz_atke_exchange_coeff.F90
Index: /LMDZ6/trunk/libf/phylmdiso/lmdz_atke_exchange_coeff.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/lmdz_atke_exchange_coeff.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/lmdz_atke_exchange_coeff.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/lmdz_atke_exchange_coeff.f90
Index: DZ6/trunk/libf/phylmdiso/lmdz_atke_turbulence_ini.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/lmdz_atke_turbulence_ini.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/lmdz_atke_turbulence_ini.F90
Index: /LMDZ6/trunk/libf/phylmdiso/lmdz_atke_turbulence_ini.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/lmdz_atke_turbulence_ini.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/lmdz_atke_turbulence_ini.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/lmdz_atke_turbulence_ini.f90
Index: DZ6/trunk/libf/phylmdiso/lmdz_blowing_snow_ini.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/lmdz_blowing_snow_ini.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/lmdz_blowing_snow_ini.F90
Index: /LMDZ6/trunk/libf/phylmdiso/lmdz_blowing_snow_ini.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/lmdz_blowing_snow_ini.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/lmdz_blowing_snow_ini.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/lmdz_blowing_snow_ini.f90
Index: DZ6/trunk/libf/phylmdiso/lmdz_blowing_snow_sublim_sedim.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/lmdz_blowing_snow_sublim_sedim.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/lmdz_blowing_snow_sublim_sedim.F90
Index: /LMDZ6/trunk/libf/phylmdiso/lmdz_blowing_snow_sublim_sedim.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/lmdz_blowing_snow_sublim_sedim.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/lmdz_blowing_snow_sublim_sedim.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/lmdz_blowing_snow_sublim_sedim.f90
Index: DZ6/trunk/libf/phylmdiso/lmdz_call_atke.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/lmdz_call_atke.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/lmdz_call_atke.F90
Index: /LMDZ6/trunk/libf/phylmdiso/lmdz_call_atke.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/lmdz_call_atke.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/lmdz_call_atke.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/lmdz_call_atke.f90
Index: DZ6/trunk/libf/phylmdiso/lmdz_call_blowing_snow.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/lmdz_call_blowing_snow.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/lmdz_call_blowing_snow.F90
Index: /LMDZ6/trunk/libf/phylmdiso/lmdz_call_blowing_snow.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/lmdz_call_blowing_snow.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/lmdz_call_blowing_snow.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/lmdz_call_blowing_snow.f90
Index: DZ6/trunk/libf/phylmdiso/lmdz_call_cloud_optics_prop.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/lmdz_call_cloud_optics_prop.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/lmdz_call_cloud_optics_prop.F90
Index: /LMDZ6/trunk/libf/phylmdiso/lmdz_call_cloud_optics_prop.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/lmdz_call_cloud_optics_prop.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/lmdz_call_cloud_optics_prop.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/lmdz_call_cloud_optics_prop.f90
Index: DZ6/trunk/libf/phylmdiso/lmdz_cloud_optics_prop.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/lmdz_cloud_optics_prop.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/lmdz_cloud_optics_prop.F90
Index: /LMDZ6/trunk/libf/phylmdiso/lmdz_cloud_optics_prop.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/lmdz_cloud_optics_prop.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/lmdz_cloud_optics_prop.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/lmdz_cloud_optics_prop.f90
Index: DZ6/trunk/libf/phylmdiso/lmdz_cloud_optics_prop_ini.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/lmdz_cloud_optics_prop_ini.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/lmdz_cloud_optics_prop_ini.F90
Index: /LMDZ6/trunk/libf/phylmdiso/lmdz_cloud_optics_prop_ini.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/lmdz_cloud_optics_prop_ini.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/lmdz_cloud_optics_prop_ini.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/lmdz_cloud_optics_prop_ini.f90
Index: DZ6/trunk/libf/phylmdiso/lmdz_cloudth.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/lmdz_cloudth.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/lmdz_cloudth.F90
Index: /LMDZ6/trunk/libf/phylmdiso/lmdz_cloudth.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/lmdz_cloudth.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/lmdz_cloudth.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/lmdz_cloudth.f90
Index: DZ6/trunk/libf/phylmdiso/lmdz_cloudth_ini.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/lmdz_cloudth_ini.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/lmdz_cloudth_ini.F90
Index: /LMDZ6/trunk/libf/phylmdiso/lmdz_cloudth_ini.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/lmdz_cloudth_ini.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/lmdz_cloudth_ini.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/lmdz_cloudth_ini.f90
Index: DZ6/trunk/libf/phylmdiso/lmdz_lscp.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/lmdz_lscp.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/lmdz_lscp.F90
Index: /LMDZ6/trunk/libf/phylmdiso/lmdz_lscp.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/lmdz_lscp.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/lmdz_lscp.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/lmdz_lscp.f90
Index: DZ6/trunk/libf/phylmdiso/lmdz_lscp_condensation.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/lmdz_lscp_condensation.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/lmdz_lscp_condensation.F90
Index: /LMDZ6/trunk/libf/phylmdiso/lmdz_lscp_condensation.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/lmdz_lscp_condensation.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/lmdz_lscp_condensation.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/lmdz_lscp_condensation.f90
Index: DZ6/trunk/libf/phylmdiso/lmdz_lscp_ini.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/lmdz_lscp_ini.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/lmdz_lscp_ini.F90
Index: /LMDZ6/trunk/libf/phylmdiso/lmdz_lscp_ini.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/lmdz_lscp_ini.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/lmdz_lscp_ini.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/lmdz_lscp_ini.f90
Index: DZ6/trunk/libf/phylmdiso/lmdz_lscp_poprecip.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/lmdz_lscp_poprecip.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/lmdz_lscp_poprecip.F90
Index: /LMDZ6/trunk/libf/phylmdiso/lmdz_lscp_poprecip.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/lmdz_lscp_poprecip.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/lmdz_lscp_poprecip.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/lmdz_lscp_poprecip.f90
Index: DZ6/trunk/libf/phylmdiso/lmdz_lscp_tools.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/lmdz_lscp_tools.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/lmdz_lscp_tools.F90
Index: /LMDZ6/trunk/libf/phylmdiso/lmdz_lscp_tools.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/lmdz_lscp_tools.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/lmdz_lscp_tools.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/lmdz_lscp_tools.f90
Index: DZ6/trunk/libf/phylmdiso/lmdz_ratqs_ini.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/lmdz_ratqs_ini.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/lmdz_ratqs_ini.F90
Index: /LMDZ6/trunk/libf/phylmdiso/lmdz_ratqs_ini.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/lmdz_ratqs_ini.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/lmdz_ratqs_ini.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/lmdz_ratqs_ini.f90
Index: DZ6/trunk/libf/phylmdiso/lmdz_ratqs_main.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/lmdz_ratqs_main.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/lmdz_ratqs_main.F90
Index: /LMDZ6/trunk/libf/phylmdiso/lmdz_ratqs_main.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/lmdz_ratqs_main.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/lmdz_ratqs_main.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/lmdz_ratqs_main.f90
Index: DZ6/trunk/libf/phylmdiso/lmdz_ratqs_multi.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/lmdz_ratqs_multi.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/lmdz_ratqs_multi.F90
Index: /LMDZ6/trunk/libf/phylmdiso/lmdz_ratqs_multi.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/lmdz_ratqs_multi.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/lmdz_ratqs_multi.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/lmdz_ratqs_multi.f90
Index: DZ6/trunk/libf/phylmdiso/lmdz_thermcell_alim.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/lmdz_thermcell_alim.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/lmdz_thermcell_alim.F90
Index: /LMDZ6/trunk/libf/phylmdiso/lmdz_thermcell_alim.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/lmdz_thermcell_alim.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/lmdz_thermcell_alim.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/lmdz_thermcell_alim.f90
Index: DZ6/trunk/libf/phylmdiso/lmdz_thermcell_alp.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/lmdz_thermcell_alp.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/lmdz_thermcell_alp.F90
Index: /LMDZ6/trunk/libf/phylmdiso/lmdz_thermcell_alp.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/lmdz_thermcell_alp.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/lmdz_thermcell_alp.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/lmdz_thermcell_alp.f90
Index: DZ6/trunk/libf/phylmdiso/lmdz_thermcell_closure.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/lmdz_thermcell_closure.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/lmdz_thermcell_closure.F90
Index: /LMDZ6/trunk/libf/phylmdiso/lmdz_thermcell_closure.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/lmdz_thermcell_closure.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/lmdz_thermcell_closure.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/lmdz_thermcell_closure.f90
Index: DZ6/trunk/libf/phylmdiso/lmdz_thermcell_down.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/lmdz_thermcell_down.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/lmdz_thermcell_down.F90
Index: /LMDZ6/trunk/libf/phylmdiso/lmdz_thermcell_down.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/lmdz_thermcell_down.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/lmdz_thermcell_down.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/lmdz_thermcell_down.f90
Index: DZ6/trunk/libf/phylmdiso/lmdz_thermcell_dry.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/lmdz_thermcell_dry.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/lmdz_thermcell_dry.F90
Index: /LMDZ6/trunk/libf/phylmdiso/lmdz_thermcell_dry.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/lmdz_thermcell_dry.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/lmdz_thermcell_dry.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/lmdz_thermcell_dry.f90
Index: DZ6/trunk/libf/phylmdiso/lmdz_thermcell_dtke.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/lmdz_thermcell_dtke.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/lmdz_thermcell_dtke.F90
Index: /LMDZ6/trunk/libf/phylmdiso/lmdz_thermcell_dtke.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/lmdz_thermcell_dtke.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/lmdz_thermcell_dtke.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/lmdz_thermcell_dtke.f90
Index: DZ6/trunk/libf/phylmdiso/lmdz_thermcell_dv2.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/lmdz_thermcell_dv2.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/lmdz_thermcell_dv2.F90
Index: /LMDZ6/trunk/libf/phylmdiso/lmdz_thermcell_dv2.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/lmdz_thermcell_dv2.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/lmdz_thermcell_dv2.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/lmdz_thermcell_dv2.f90
Index: DZ6/trunk/libf/phylmdiso/lmdz_thermcell_env.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/lmdz_thermcell_env.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/lmdz_thermcell_env.F90
Index: /LMDZ6/trunk/libf/phylmdiso/lmdz_thermcell_env.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/lmdz_thermcell_env.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/lmdz_thermcell_env.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/lmdz_thermcell_env.f90
Index: DZ6/trunk/libf/phylmdiso/lmdz_thermcell_flux2.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/lmdz_thermcell_flux2.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/lmdz_thermcell_flux2.F90
Index: /LMDZ6/trunk/libf/phylmdiso/lmdz_thermcell_flux2.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/lmdz_thermcell_flux2.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/lmdz_thermcell_flux2.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/lmdz_thermcell_flux2.f90
Index: DZ6/trunk/libf/phylmdiso/lmdz_thermcell_height.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/lmdz_thermcell_height.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/lmdz_thermcell_height.F90
Index: /LMDZ6/trunk/libf/phylmdiso/lmdz_thermcell_height.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/lmdz_thermcell_height.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/lmdz_thermcell_height.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/lmdz_thermcell_height.f90
Index: DZ6/trunk/libf/phylmdiso/lmdz_thermcell_ini.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/lmdz_thermcell_ini.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/lmdz_thermcell_ini.F90
Index: /LMDZ6/trunk/libf/phylmdiso/lmdz_thermcell_ini.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/lmdz_thermcell_ini.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/lmdz_thermcell_ini.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/lmdz_thermcell_ini.f90
Index: DZ6/trunk/libf/phylmdiso/lmdz_thermcell_qsat.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/lmdz_thermcell_qsat.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/lmdz_thermcell_qsat.F90
Index: /LMDZ6/trunk/libf/phylmdiso/lmdz_thermcell_qsat.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/lmdz_thermcell_qsat.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/lmdz_thermcell_qsat.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/lmdz_thermcell_qsat.f90
Index: DZ6/trunk/libf/phylmdiso/lsc_scav.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/lsc_scav.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/lsc_scav.F90
Index: /LMDZ6/trunk/libf/phylmdiso/lsc_scav.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/lsc_scav.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/lsc_scav.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/lsc_scav.f90
Index: DZ6/trunk/libf/phylmdiso/macv2sp.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/macv2sp.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/macv2sp.F90
Index: /LMDZ6/trunk/libf/phylmdiso/macv2sp.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/macv2sp.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/macv2sp.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/macv2sp.f90
Index: DZ6/trunk/libf/phylmdiso/methox.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/methox.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/methox.F90
Index: /LMDZ6/trunk/libf/phylmdiso/methox.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/methox.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/methox.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/methox.f90
Index: DZ6/trunk/libf/phylmdiso/minmaxqfi.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/minmaxqfi.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/minmaxqfi.F90
Index: /LMDZ6/trunk/libf/phylmdiso/minmaxqfi.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/minmaxqfi.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/minmaxqfi.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/minmaxqfi.f90
Index: DZ6/trunk/libf/phylmdiso/mo_simple_plumes.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/mo_simple_plumes.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/mo_simple_plumes.F90
Index: /LMDZ6/trunk/libf/phylmdiso/mo_simple_plumes.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/mo_simple_plumes.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/mo_simple_plumes.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/mo_simple_plumes.f90
Index: DZ6/trunk/libf/phylmdiso/mod_surf_para.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/mod_surf_para.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/mod_surf_para.F90
Index: /LMDZ6/trunk/libf/phylmdiso/mod_surf_para.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/mod_surf_para.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/mod_surf_para.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/mod_surf_para.f90
Index: DZ6/trunk/libf/phylmdiso/mod_synchro_omp.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/mod_synchro_omp.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/mod_synchro_omp.F90
Index: /LMDZ6/trunk/libf/phylmdiso/mod_synchro_omp.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/mod_synchro_omp.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/mod_synchro_omp.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/mod_synchro_omp.f90
Index: DZ6/trunk/libf/phylmdiso/modd_csts.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/modd_csts.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/modd_csts.F90
Index: /LMDZ6/trunk/libf/phylmdiso/modd_csts.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/modd_csts.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/modd_csts.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/modd_csts.f90
Index: DZ6/trunk/libf/phylmdiso/moy_undefSTD.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/moy_undefSTD.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/moy_undefSTD.F90
Index: /LMDZ6/trunk/libf/phylmdiso/moy_undefSTD.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/moy_undefSTD.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/moy_undefSTD.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/moy_undefSTD.f90
Index: DZ6/trunk/libf/phylmdiso/moyglo_aire.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/moyglo_aire.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/moyglo_aire.F90
Index: /LMDZ6/trunk/libf/phylmdiso/moyglo_aire.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/moyglo_aire.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/moyglo_aire.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/moyglo_aire.f90
Index: DZ6/trunk/libf/phylmdiso/nflxtr.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/nflxtr.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/nflxtr.F90
Index: /LMDZ6/trunk/libf/phylmdiso/nflxtr.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/nflxtr.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/nflxtr.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/nflxtr.f90
Index: DZ6/trunk/libf/phylmdiso/nonlocal.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/nonlocal.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/nonlocal.F90
Index: /LMDZ6/trunk/libf/phylmdiso/nonlocal.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/nonlocal.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/nonlocal.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/nonlocal.f90
Index: DZ6/trunk/libf/phylmdiso/nuage.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/nuage.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/nuage.F90
Index: /LMDZ6/trunk/libf/phylmdiso/nuage.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/nuage.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/nuage.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/nuage.f90
Index: DZ6/trunk/libf/phylmdiso/o3_chem_m.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/o3_chem_m.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/o3_chem_m.F90
Index: /LMDZ6/trunk/libf/phylmdiso/o3_chem_m.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/o3_chem_m.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/o3_chem_m.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/o3_chem_m.f90
Index: DZ6/trunk/libf/phylmdiso/o3cm.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/o3cm.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/o3cm.F90
Index: /LMDZ6/trunk/libf/phylmdiso/o3cm.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/o3cm.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/o3cm.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/o3cm.f90
Index: DZ6/trunk/libf/phylmdiso/ocean_albedo.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/ocean_albedo.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/ocean_albedo.F90
Index: /LMDZ6/trunk/libf/phylmdiso/ocean_albedo.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/ocean_albedo.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/ocean_albedo.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/ocean_albedo.f90
Index: DZ6/trunk/libf/phylmdiso/ocean_albedo_para.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/ocean_albedo_para.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/ocean_albedo_para.F90
Index: /LMDZ6/trunk/libf/phylmdiso/ocean_albedo_para.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/ocean_albedo_para.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/ocean_albedo_para.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/ocean_albedo_para.f90
Index: DZ6/trunk/libf/phylmdiso/ocean_cpl_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/ocean_cpl_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/ocean_cpl_mod.F90
Index: /LMDZ6/trunk/libf/phylmdiso/ocean_cpl_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/ocean_cpl_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/ocean_cpl_mod.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/ocean_cpl_mod.f90
Index: DZ6/trunk/libf/phylmdiso/ocean_slab_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/ocean_slab_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/ocean_slab_mod.F90
Index: /LMDZ6/trunk/libf/phylmdiso/ocean_slab_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/ocean_slab_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/ocean_slab_mod.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/ocean_slab_mod.f90
Index: DZ6/trunk/libf/phylmdiso/open_climoz_m.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/open_climoz_m.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/open_climoz_m.F90
Index: /LMDZ6/trunk/libf/phylmdiso/open_climoz_m.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/open_climoz_m.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/open_climoz_m.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/open_climoz_m.f90
Index: DZ6/trunk/libf/phylmdiso/orbite.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/orbite.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/orbite.F90
Index: /LMDZ6/trunk/libf/phylmdiso/orbite.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/orbite.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/orbite.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/orbite.f90
Index: DZ6/trunk/libf/phylmdiso/orografi.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/orografi.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/orografi.F90
Index: /LMDZ6/trunk/libf/phylmdiso/orografi.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/orografi.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/orografi.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/orografi.f90
Index: DZ6/trunk/libf/phylmdiso/orografi_strato.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/orografi_strato.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/orografi_strato.F90
Index: /LMDZ6/trunk/libf/phylmdiso/orografi_strato.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/orografi_strato.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/orografi_strato.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/orografi_strato.f90
Index: DZ6/trunk/libf/phylmdiso/output_physiqex_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/output_physiqex_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/output_physiqex_mod.F90
Index: /LMDZ6/trunk/libf/phylmdiso/output_physiqex_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/output_physiqex_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/output_physiqex_mod.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/output_physiqex_mod.f90
Index: DZ6/trunk/libf/phylmdiso/ozonecm_m.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/ozonecm_m.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/ozonecm_m.F90
Index: /LMDZ6/trunk/libf/phylmdiso/ozonecm_m.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/ozonecm_m.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/ozonecm_m.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/ozonecm_m.f90
Index: DZ6/trunk/libf/phylmdiso/perturb_radlwsw.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/perturb_radlwsw.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/perturb_radlwsw.F90
Index: /LMDZ6/trunk/libf/phylmdiso/perturb_radlwsw.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/perturb_radlwsw.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/perturb_radlwsw.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/perturb_radlwsw.f90
Index: DZ6/trunk/libf/phylmdiso/phyetat0_get_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/phyetat0_get_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/phyetat0_get_mod.F90
Index: /LMDZ6/trunk/libf/phylmdiso/phyetat0_get_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/phyetat0_get_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/phyetat0_get_mod.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/phyetat0_get_mod.f90
Index: DZ6/trunk/libf/phylmdiso/phys_cal_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/phys_cal_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/phys_cal_mod.F90
Index: /LMDZ6/trunk/libf/phylmdiso/phys_cal_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/phys_cal_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/phys_cal_mod.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/phys_cal_mod.f90
Index: DZ6/trunk/libf/phylmdiso/phys_output_var_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/phys_output_var_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/phys_output_var_mod.F90
Index: /LMDZ6/trunk/libf/phylmdiso/phys_output_var_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/phys_output_var_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/phys_output_var_mod.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/phys_output_var_mod.f90
Index: DZ6/trunk/libf/phylmdiso/phystokenc_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/phystokenc_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/phystokenc_mod.F90
Index: /LMDZ6/trunk/libf/phylmdiso/phystokenc_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/phystokenc_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/phystokenc_mod.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/phystokenc_mod.f90
Index: DZ6/trunk/libf/phylmdiso/phytrac_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/phytrac_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/phytrac_mod.F90
Index: /LMDZ6/trunk/libf/phylmdiso/phytrac_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/phytrac_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/phytrac_mod.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/phytrac_mod.f90
Index: DZ6/trunk/libf/phylmdiso/plevel.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/plevel.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/plevel.F90
Index: /LMDZ6/trunk/libf/phylmdiso/plevel.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/plevel.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/plevel.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/plevel.f90
Index: DZ6/trunk/libf/phylmdiso/plevel_new.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/plevel_new.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/plevel_new.F90
Index: /LMDZ6/trunk/libf/phylmdiso/plevel_new.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/plevel_new.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/plevel_new.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/plevel_new.f90
Index: DZ6/trunk/libf/phylmdiso/pppmer.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/pppmer.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/pppmer.F90
Index: /LMDZ6/trunk/libf/phylmdiso/pppmer.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/pppmer.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/pppmer.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/pppmer.f90
Index: DZ6/trunk/libf/phylmdiso/press_coefoz_m.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/press_coefoz_m.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/press_coefoz_m.F90
Index: /LMDZ6/trunk/libf/phylmdiso/press_coefoz_m.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/press_coefoz_m.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/press_coefoz_m.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/press_coefoz_m.f90
Index: DZ6/trunk/libf/phylmdiso/print_debug_phys.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/print_debug_phys.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/print_debug_phys.F90
Index: /LMDZ6/trunk/libf/phylmdiso/print_debug_phys.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/print_debug_phys.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/print_debug_phys.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/print_debug_phys.f90
Index: DZ6/trunk/libf/phylmdiso/printflag.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/printflag.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/printflag.F90
Index: /LMDZ6/trunk/libf/phylmdiso/printflag.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/printflag.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/printflag.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/printflag.f90
Index: DZ6/trunk/libf/phylmdiso/qcheck.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/qcheck.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/qcheck.F90
Index: /LMDZ6/trunk/libf/phylmdiso/qcheck.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/qcheck.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/qcheck.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/qcheck.f90
Index: DZ6/trunk/libf/phylmdiso/qsat_seawater.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/qsat_seawater.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/qsat_seawater.F90
Index: /LMDZ6/trunk/libf/phylmdiso/qsat_seawater.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/qsat_seawater.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/qsat_seawater.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/qsat_seawater.f90
Index: DZ6/trunk/libf/phylmdiso/qsat_seawater2.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/qsat_seawater2.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/qsat_seawater2.F90
Index: /LMDZ6/trunk/libf/phylmdiso/qsat_seawater2.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/qsat_seawater2.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/qsat_seawater2.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/qsat_seawater2.f90
Index: DZ6/trunk/libf/phylmdiso/qsatseaw_1D.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/qsatseaw_1D.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/qsatseaw_1D.F90
Index: /LMDZ6/trunk/libf/phylmdiso/qsatseaw_1D.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/qsatseaw_1D.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/qsatseaw_1D.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/qsatseaw_1D.f90
Index: DZ6/trunk/libf/phylmdiso/radiation_AR4.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/radiation_AR4.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/radiation_AR4.F90
Index: /LMDZ6/trunk/libf/phylmdiso/radiation_AR4.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/radiation_AR4.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/radiation_AR4.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/radiation_AR4.f90
Index: DZ6/trunk/libf/phylmdiso/radiation_ar4_param.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/radiation_ar4_param.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/radiation_ar4_param.F90
Index: /LMDZ6/trunk/libf/phylmdiso/radiation_ar4_param.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/radiation_ar4_param.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/radiation_ar4_param.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/radiation_ar4_param.f90
Index: DZ6/trunk/libf/phylmdiso/radio_decay.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/radio_decay.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/radio_decay.F90
Index: /LMDZ6/trunk/libf/phylmdiso/radio_decay.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/radio_decay.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/radio_decay.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/radio_decay.f90
Index: DZ6/trunk/libf/phylmdiso/ran0_vec.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/ran0_vec.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/ran0_vec.F90
Index: /LMDZ6/trunk/libf/phylmdiso/ran0_vec.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/ran0_vec.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/ran0_vec.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/ran0_vec.f90
Index: DZ6/trunk/libf/phylmdiso/read_map2D.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/read_map2D.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/read_map2D.F90
Index: /LMDZ6/trunk/libf/phylmdiso/read_map2D.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/read_map2D.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/read_map2D.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/read_map2D.f90
Index: DZ6/trunk/libf/phylmdiso/read_pstoke.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/read_pstoke.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/read_pstoke.F90
Index: /LMDZ6/trunk/libf/phylmdiso/read_pstoke.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/read_pstoke.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/read_pstoke.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/read_pstoke.f90
Index: DZ6/trunk/libf/phylmdiso/read_pstoke0.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/read_pstoke0.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/read_pstoke0.F90
Index: /LMDZ6/trunk/libf/phylmdiso/read_pstoke0.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/read_pstoke0.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/read_pstoke0.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/read_pstoke0.f90
Index: DZ6/trunk/libf/phylmdiso/readaerosol_interp.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/readaerosol_interp.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/readaerosol_interp.F90
Index: /LMDZ6/trunk/libf/phylmdiso/readaerosol_interp.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/readaerosol_interp.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/readaerosol_interp.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/readaerosol_interp.f90
Index: DZ6/trunk/libf/phylmdiso/readaerosol_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/readaerosol_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/readaerosol_mod.F90
Index: /LMDZ6/trunk/libf/phylmdiso/readaerosol_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/readaerosol_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/readaerosol_mod.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/readaerosol_mod.f90
Index: DZ6/trunk/libf/phylmdiso/readaerosol_optic.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/readaerosol_optic.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/readaerosol_optic.F90
Index: /LMDZ6/trunk/libf/phylmdiso/readaerosol_optic.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/readaerosol_optic.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/readaerosol_optic.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/readaerosol_optic.f90
Index: DZ6/trunk/libf/phylmdiso/readaerosolstrato.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/readaerosolstrato.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/readaerosolstrato.F90
Index: /LMDZ6/trunk/libf/phylmdiso/readaerosolstrato.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/readaerosolstrato.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/readaerosolstrato.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/readaerosolstrato.f90
Index: DZ6/trunk/libf/phylmdiso/readaerosolstrato_m.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/readaerosolstrato_m.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/readaerosolstrato_m.F90
Index: /LMDZ6/trunk/libf/phylmdiso/readaerosolstrato_m.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/readaerosolstrato_m.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/readaerosolstrato_m.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/readaerosolstrato_m.f90
Index: DZ6/trunk/libf/phylmdiso/readchlorophyll.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/readchlorophyll.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/readchlorophyll.F90
Index: /LMDZ6/trunk/libf/phylmdiso/readchlorophyll.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/readchlorophyll.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/readchlorophyll.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/readchlorophyll.f90
Index: DZ6/trunk/libf/phylmdiso/regr_horiz_time_climoz_m.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/regr_horiz_time_climoz_m.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/regr_horiz_time_climoz_m.F90
Index: /LMDZ6/trunk/libf/phylmdiso/regr_horiz_time_climoz_m.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/regr_horiz_time_climoz_m.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/regr_horiz_time_climoz_m.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/regr_horiz_time_climoz_m.f90
Index: DZ6/trunk/libf/phylmdiso/regr_lat_time_coefoz_m.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/regr_lat_time_coefoz_m.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/regr_lat_time_coefoz_m.F90
Index: /LMDZ6/trunk/libf/phylmdiso/regr_lat_time_coefoz_m.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/regr_lat_time_coefoz_m.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/regr_lat_time_coefoz_m.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/regr_lat_time_coefoz_m.f90
Index: DZ6/trunk/libf/phylmdiso/regr_pr_comb_coefoz_m.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/regr_pr_comb_coefoz_m.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/regr_pr_comb_coefoz_m.F90
Index: /LMDZ6/trunk/libf/phylmdiso/regr_pr_comb_coefoz_m.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/regr_pr_comb_coefoz_m.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/regr_pr_comb_coefoz_m.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/regr_pr_comb_coefoz_m.f90
Index: DZ6/trunk/libf/phylmdiso/regr_pr_int_m.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/regr_pr_int_m.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/regr_pr_int_m.F90
Index: /LMDZ6/trunk/libf/phylmdiso/regr_pr_int_m.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/regr_pr_int_m.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/regr_pr_int_m.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/regr_pr_int_m.f90
Index: DZ6/trunk/libf/phylmdiso/regr_pr_o3_m.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/regr_pr_o3_m.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/regr_pr_o3_m.F90
Index: /LMDZ6/trunk/libf/phylmdiso/regr_pr_o3_m.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/regr_pr_o3_m.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/regr_pr_o3_m.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/regr_pr_o3_m.f90
Index: DZ6/trunk/libf/phylmdiso/regr_pr_time_av_m.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/regr_pr_time_av_m.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/regr_pr_time_av_m.F90
Index: /LMDZ6/trunk/libf/phylmdiso/regr_pr_time_av_m.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/regr_pr_time_av_m.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/regr_pr_time_av_m.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/regr_pr_time_av_m.f90
Index: DZ6/trunk/libf/phylmdiso/screenc_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/screenc_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/screenc_mod.F90
Index: /LMDZ6/trunk/libf/phylmdiso/screenc_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/screenc_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/screenc_mod.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/screenc_mod.f90
Index: DZ6/trunk/libf/phylmdiso/screenp_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/screenp_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/screenp_mod.F90
Index: /LMDZ6/trunk/libf/phylmdiso/screenp_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/screenp_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/screenp_mod.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/screenp_mod.f90
Index: DZ6/trunk/libf/phylmdiso/simu_airs.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/simu_airs.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/simu_airs.F90
Index: /LMDZ6/trunk/libf/phylmdiso/simu_airs.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/simu_airs.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/simu_airs.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/simu_airs.f90
Index: DZ6/trunk/libf/phylmdiso/slab_heat_transp_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/slab_heat_transp_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/slab_heat_transp_mod.F90
Index: /LMDZ6/trunk/libf/phylmdiso/slab_heat_transp_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/slab_heat_transp_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/slab_heat_transp_mod.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/slab_heat_transp_mod.f90
Index: DZ6/trunk/libf/phylmdiso/soil.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/soil.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/soil.F90
Index: /LMDZ6/trunk/libf/phylmdiso/soil.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/soil.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/soil.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/soil.f90
Index: DZ6/trunk/libf/phylmdiso/solarlong.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/solarlong.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/solarlong.F90
Index: /LMDZ6/trunk/libf/phylmdiso/solarlong.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/solarlong.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/solarlong.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/solarlong.f90
Index: DZ6/trunk/libf/phylmdiso/stdlevvar_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/stdlevvar_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/stdlevvar_mod.F90
Index: /LMDZ6/trunk/libf/phylmdiso/stdlevvar_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/stdlevvar_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/stdlevvar_mod.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/stdlevvar_mod.f90
Index: DZ6/trunk/libf/phylmdiso/stratocu_if.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/stratocu_if.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/stratocu_if.F90
Index: /LMDZ6/trunk/libf/phylmdiso/stratocu_if.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/stratocu_if.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/stratocu_if.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/stratocu_if.f90
Index: DZ6/trunk/libf/phylmdiso/stratosphere_mask.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/stratosphere_mask.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/stratosphere_mask.F90
Index: /LMDZ6/trunk/libf/phylmdiso/stratosphere_mask.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/stratosphere_mask.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/stratosphere_mask.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/stratosphere_mask.f90
Index: DZ6/trunk/libf/phylmdiso/sumethox.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/sumethox.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/sumethox.F90
Index: /LMDZ6/trunk/libf/phylmdiso/sumethox.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/sumethox.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/sumethox.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/sumethox.f90
Index: DZ6/trunk/libf/phylmdiso/suphel.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/suphel.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/suphel.F90
Index: /LMDZ6/trunk/libf/phylmdiso/suphel.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/suphel.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/suphel.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/suphel.f90
Index: DZ6/trunk/libf/phylmdiso/surface_data.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/surface_data.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/surface_data.F90
Index: /LMDZ6/trunk/libf/phylmdiso/surface_data.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/surface_data.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/surface_data.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/surface_data.f90
Index: DZ6/trunk/libf/phylmdiso/sw_aeroAR4.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/sw_aeroAR4.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/sw_aeroAR4.F90
Index: /LMDZ6/trunk/libf/phylmdiso/sw_aeroAR4.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/sw_aeroAR4.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/sw_aeroAR4.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/sw_aeroAR4.f90
Index: DZ6/trunk/libf/phylmdiso/tend_to_tke.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/tend_to_tke.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/tend_to_tke.F90
Index: /LMDZ6/trunk/libf/phylmdiso/tend_to_tke.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/tend_to_tke.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/tend_to_tke.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/tend_to_tke.f90
Index: DZ6/trunk/libf/phylmdiso/tilft43.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/tilft43.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/tilft43.F90
Index: /LMDZ6/trunk/libf/phylmdiso/tilft43.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/tilft43.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/tilft43.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/tilft43.f90
Index: DZ6/trunk/libf/phylmdiso/time_phylmdz_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/time_phylmdz_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/time_phylmdz_mod.F90
Index: /LMDZ6/trunk/libf/phylmdiso/time_phylmdz_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/time_phylmdz_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/time_phylmdz_mod.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/time_phylmdz_mod.f90
Index: DZ6/trunk/libf/phylmdiso/tlift.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/tlift.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/tlift.F90
Index: /LMDZ6/trunk/libf/phylmdiso/tlift.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/tlift.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/tlift.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/tlift.f90
Index: DZ6/trunk/libf/phylmdiso/tracco2i_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/tracco2i_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/tracco2i_mod.F90
Index: /LMDZ6/trunk/libf/phylmdiso/tracco2i_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/tracco2i_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/tracco2i_mod.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/tracco2i_mod.f90
Index: DZ6/trunk/libf/phylmdiso/tracinca_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/tracinca_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/tracinca_mod.F90
Index: /LMDZ6/trunk/libf/phylmdiso/tracinca_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/tracinca_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/tracinca_mod.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/tracinca_mod.f90
Index: DZ6/trunk/libf/phylmdiso/traclmdz_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/traclmdz_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/traclmdz_mod.F90
Index: /LMDZ6/trunk/libf/phylmdiso/traclmdz_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/traclmdz_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/traclmdz_mod.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/traclmdz_mod.f90
Index: DZ6/trunk/libf/phylmdiso/tracreprobus_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/tracreprobus_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/tracreprobus_mod.F90
Index: /LMDZ6/trunk/libf/phylmdiso/tracreprobus_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/tracreprobus_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/tracreprobus_mod.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/tracreprobus_mod.f90
Index: DZ6/trunk/libf/phylmdiso/transp.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/transp.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/transp.F90
Index: /LMDZ6/trunk/libf/phylmdiso/transp.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/transp.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/transp.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/transp.f90
Index: DZ6/trunk/libf/phylmdiso/transp_lay.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/transp_lay.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/transp_lay.F90
Index: /LMDZ6/trunk/libf/phylmdiso/transp_lay.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/transp_lay.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/transp_lay.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/transp_lay.f90
Index: DZ6/trunk/libf/phylmdiso/tropopause_m.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/tropopause_m.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/tropopause_m.F90
Index: /LMDZ6/trunk/libf/phylmdiso/tropopause_m.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/tropopause_m.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/tropopause_m.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/tropopause_m.f90
Index: DZ6/trunk/libf/phylmdiso/undefSTD.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/undefSTD.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/undefSTD.F90
Index: /LMDZ6/trunk/libf/phylmdiso/undefSTD.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/undefSTD.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/undefSTD.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/undefSTD.f90
Index: DZ6/trunk/libf/phylmdiso/ustarhb.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/ustarhb.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/ustarhb.F90
Index: /LMDZ6/trunk/libf/phylmdiso/ustarhb.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/ustarhb.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/ustarhb.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/ustarhb.f90
Index: DZ6/trunk/libf/phylmdiso/vdif_kcay.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/vdif_kcay.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/vdif_kcay.F90
Index: /LMDZ6/trunk/libf/phylmdiso/vdif_kcay.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/vdif_kcay.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/vdif_kcay.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/vdif_kcay.f90
Index: DZ6/trunk/libf/phylmdiso/water_int.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/water_int.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/water_int.F90
Index: /LMDZ6/trunk/libf/phylmdiso/water_int.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/water_int.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/water_int.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/water_int.f90
Index: DZ6/trunk/libf/phylmdiso/wx_pbl_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/wx_pbl_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/wx_pbl_mod.F90
Index: /LMDZ6/trunk/libf/phylmdiso/wx_pbl_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/wx_pbl_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/wx_pbl_mod.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/wx_pbl_mod.f90
Index: DZ6/trunk/libf/phylmdiso/wx_pbl_var_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/wx_pbl_var_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/wx_pbl_var_mod.F90
Index: /LMDZ6/trunk/libf/phylmdiso/wx_pbl_var_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/wx_pbl_var_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/wx_pbl_var_mod.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/wx_pbl_var_mod.f90
Index: DZ6/trunk/libf/phylmdiso/yamada.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/yamada.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/yamada.F90
Index: /LMDZ6/trunk/libf/phylmdiso/yamada.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/yamada.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/yamada.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/yamada.f90
Index: DZ6/trunk/libf/phylmdiso/yamada4.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/yamada4.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/yamada4.F90
Index: /LMDZ6/trunk/libf/phylmdiso/yamada4.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/yamada4.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/yamada4.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/yamada4.f90
Index: DZ6/trunk/libf/phylmdiso/yamada_ini_mod.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/yamada_ini_mod.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/yamada_ini_mod.F90
Index: /LMDZ6/trunk/libf/phylmdiso/yamada_ini_mod.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/yamada_ini_mod.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/yamada_ini_mod.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/yamada_ini_mod.f90
Index: DZ6/trunk/libf/phylmdiso/zilch.F90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/zilch.F90	(revision 5267)
+++ 	(revision )
@@ -1,1 +1,0 @@
-link ../phylmd/zilch.F90
Index: /LMDZ6/trunk/libf/phylmdiso/zilch.f90
===================================================================
--- /LMDZ6/trunk/libf/phylmdiso/zilch.f90	(revision 5268)
+++ /LMDZ6/trunk/libf/phylmdiso/zilch.f90	(revision 5268)
@@ -0,0 +1,1 @@
+link ../phylmd/zilch.f90
